'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/24/2006 15:24'!
addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset

	| row switchHeight divider |

	row := AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 1;
		borderWidth: 1;
		layoutPolicy: ProportionalLayout new.
	switchHeight := 25.
	self 
		addMorphicSwitchesTo: row 
		at: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@(1-switchHeight)  corner: 0@0)
		).

	divider := BorderedSubpaneDividerMorph forTopEdge.
	divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 0.
	row 
		addMorph: divider
		fullFrame: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@switchHeight negated corner: 0@(1-switchHeight))
		).	

	row 
		addMorph: aListPane
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@1) 
				offsets: (0@0 corner: 0@(switchHeight negated))
		).	

	window 
		addMorph: row
		fullFrame: (
			LayoutFrame 
				fractions: nominalFractions 
				offsets: (0@verticalOffset corner: 0@0)
		).	
	row on: #mouseEnter send: #paneTransition: to: window.
	row on: #mouseLeave send: #paneTransition: to: window.

! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 1/10/2001 11:46'!
addClassAndSwitchesTo: window at: nominalFractions plus: verticalOffset

	^self
		addAListPane: self buildMorphicClassList 
		to: window 
		at: nominalFractions 
		plus: verticalOffset
! !

!Browser methodsFor: 'initialize-release' stamp: 'rr 6/21/2005 13:24'!
addMorphicSwitchesTo: window at: aLayoutFrame

	window 
		addMorph: self buildMorphicSwitches
		fullFrame: aLayoutFrame.

! !

!Browser methodsFor: 'initialize-release' stamp: 'rww 8/18/2002 09:31'!
browseSelectionInPlace

	"In place code - incomplete"
"	self systemCategoryListIndex: 
		(self systemCategoryList indexOf: self selectedClass category).
	self classListIndex: (self classList indexOf: self selectedClass name)"

	self spawnHierarchy.! !

!Browser methodsFor: 'initialize-release'!
browserWindowActivated
	"Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes.  The default is to do nothing.  8/5/96 sw"! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
buildClassSwitchView

	| aSwitchView |
	aSwitchView := PluggableButtonView
		on: self
		getState: #classMessagesIndicated
		action: #indicateClassMessages.
	aSwitchView
		label: 'class';
		window: (0@0 extent: 15@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
buildCommentSwitchView

	| aSwitchView |
	aSwitchView := PluggableButtonView
		on: self
		getState: #classCommentIndicated
		action: #plusButtonHit.
	aSwitchView
		label: '?' asText allBold;
		borderWidthLeft: 0 right: 1 top: 0 bottom: 0;	
		window: (0@0 extent: 10@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
buildInstanceClassSwitchView
	| aView aSwitchView instSwitchView comSwitchView |

	aView := View new model: self.
	aView window: (0 @ 0 extent: 50 @ 8).
	instSwitchView := self buildInstanceSwitchView.
	aView addSubView: instSwitchView.
	comSwitchView := self buildCommentSwitchView.
	aView addSubView: comSwitchView toRightOf: instSwitchView.
	aSwitchView := self buildClassSwitchView.
	aView addSubView: aSwitchView toRightOf: comSwitchView.
	^aView! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
buildInstanceSwitchView

	| aSwitchView |
	aSwitchView := PluggableButtonView
		on: self
		getState: #instanceMessagesIndicated
		action: #indicateInstanceMessages.
	aSwitchView
		label: 'instance';
		borderWidthLeft: 0 right: 1 top: 0 bottom: 0;	
		window: (0@0 extent: 25@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'wiz 7/19/2005 23:38'!
buildMorphicClassList

	| myClassList |

	(myClassList := PluggableListMorph new) 
			setProperty: #highlightSelector toValue: #highlightClassList:with:;

			on: self list: #classList
			selected: #classListIndex changeSelected: #classListIndex:
			menu: #classListMenu:shifted: keystroke: #classListKey:from:.
	myClassList borderWidth: 0.
	myClassList enableDragNDrop: Preferences browseWithDragNDrop.
	myClassList doubleClickSelector: #browseSelectionInPlace.
	"For doubleClick to work best disable autoDeselect"
	myClassList autoDeselect: false .
	^myClassList

! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
buildMorphicMessageCatList

	| myMessageCatList |

	(myMessageCatList := PluggableMessageCategoryListMorph new) 
			setProperty: #highlightSelector toValue: #highlightMessageCategoryList:with:;

			on: self list: #messageCategoryList
			selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
			menu: #messageCategoryMenu: 
			keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList.
	myMessageCatList enableDragNDrop: Preferences browseWithDragNDrop.
	^myMessageCatList
! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
buildMorphicMessageList
	"Build a morphic message list, with #messageList as its list-getter"

	| aListMorph |
	(aListMorph := PluggableListMorph new) 
			setProperty: #highlightSelector toValue: #highlightMessageList:with:;
			setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForMethodString;
			on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:shifted:
			keystroke: #messageListKey:from:.
	aListMorph enableDragNDrop: Preferences browseWithDragNDrop.
	aListMorph menuTitleSelector: #messageListSelectorTitle.
	^aListMorph

! !

!Browser methodsFor: 'initialize-release' stamp: 'md 2/24/2006 15:25'!
buildMorphicSwitches

	| instanceSwitch commentSwitch classSwitch row aColor |

	instanceSwitch := PluggableButtonMorph
		on: self
		getState: #instanceMessagesIndicated
		action: #indicateInstanceMessages.
	instanceSwitch
		label: 'instance';
		askBeforeChanging: true;
		borderWidth: 1;
		borderColor: Color gray.
	commentSwitch := PluggableButtonMorph
		on: self
		getState: #classCommentIndicated
		action: #plusButtonHit.
		
	commentSwitch
		label: '?' asText allBold;
		askBeforeChanging: true;
		setBalloonText: 'class comment';
		borderWidth: 1;
		borderColor: Color gray.
	classSwitch := PluggableButtonMorph
		on: self
		getState: #classMessagesIndicated
		action: #indicateClassMessages.
	classSwitch
		label: 'class';
		askBeforeChanging: true;
		borderWidth: 1;
		borderColor: Color gray.
	row := AlignmentMorph newRow
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		cellInset: 1;
		borderWidth: 0;
		addMorphBack: instanceSwitch;
		addMorphBack: commentSwitch;
		addMorphBack: classSwitch.

	aColor := Color white.
	row color: aColor muchLighter.
	{instanceSwitch. commentSwitch. classSwitch} do: [:m | 
		m 
			color: aColor;
			onColor: aColor darker darker offColor: aColor;
			hResizing: #spaceFill;
			vResizing: #spaceFill.].
	^ row
! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
buildMorphicSystemCatList
	| dragNDropFlag myCatList |
	dragNDropFlag := Preferences browseWithDragNDrop.
	(myCatList := PluggableListMorph new) 
			setProperty: #highlightSelector toValue: #highlightSystemCategoryList:with:;

			on: self list: #systemCategoryList
			selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex:
			menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:.
	myCatList enableDragNDrop: dragNDropFlag.
	^myCatList
! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
buildOptionalButtonsView
	"Build the view for the optional buttons (mvc)"

	| aView buttonView offset bWidth bHeight first previousView |
	aView := View new model: self.
	bHeight := self optionalButtonHeight.
	aView window: (0 @ 0 extent: 200 @ bHeight).
	offset := 0.
	first := true.
	previousView := nil.
	self optionalButtonPairs do: [:pair |
		buttonView := PluggableButtonView on: self
			getState: nil
			action: pair second.
		buttonView
			label: pair first asParagraph.
		bWidth := buttonView label boundingBox width // 2.  "Need something more deterministic."
		buttonView window: (offset@0 extent: bWidth@bHeight).
		offset := offset + bWidth + 0.
		first
			ifTrue:
				[aView addSubView: buttonView.
				first := false]
			ifFalse:
				[buttonView borderWidthLeft: 1 right: 0 top: 0 bottom: 0.
				aView addSubView: buttonView toRightOf: previousView]. 
		previousView := buttonView].
	^ aView! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 1/13/2000 16:45'!
defaultBrowserTitle
	^ 'System Browser'! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:56'!
highlightClassList: list with: morphList! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:56'!
highlightMessageCategoryList: list with: morphList! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:56'!
highlightSystemCategoryList: list with: morphList! !

!Browser methodsFor: 'initialize-release' stamp: 'nk 2/13/2001 13:25'!
labelString
	^self selectedClass ifNil: [ self defaultBrowserTitle ]
		ifNotNil: [ self defaultBrowserTitle, ': ', self selectedClass printString ].
! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 9/22/1999 17:13'!
methodCategoryChanged
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #annotation.
	self messageListIndex: 0! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openAsMorphClassEditing: editString
	"Create a pluggable version a Browser on just a single class."
	| window dragNDropFlag hSepFrac switchHeight mySingletonClassList |

	window := (SystemWindow labelled: 'later') model: self.
	dragNDropFlag := Preferences browseWithDragNDrop.
	hSepFrac := 0.3.
	switchHeight := 25.
	mySingletonClassList := PluggableListMorph on: self list: #classListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #classListMenu:shifted: keystroke: #classListKey:from:.
	mySingletonClassList enableDragNDrop: dragNDropFlag.

	self 
		addLowerPanesTo: window 
		at: (0@hSepFrac corner: 1@1) 
		with: editString.
	window 
		addMorph: mySingletonClassList
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 0.5@0) 
				offsets: (0@0 corner: 0@switchHeight)
		).
	
	self 
		addMorphicSwitchesTo: window 
		at: (
			LayoutFrame 
				fractions: (0.5@0 corner: 1.0@0) 
				offsets: (0@0 corner: 0@switchHeight)
		).

	window 
		addMorph: self buildMorphicMessageCatList
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 0.5@hSepFrac) 
				offsets: (0@switchHeight corner: 0@0)
		).

	window 
		addMorph: self buildMorphicMessageList
		fullFrame: (
			LayoutFrame 
				fractions: (0.5@0 corner: 1.0@hSepFrac) 
				offsets: (0@switchHeight corner: 0@0)
		).

	window setUpdatablePanesFrom: #(messageCategoryList messageList).
	^ window
! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openAsMorphEditing: editString
	"Create a pluggable version of all the morphs for a Browser in Morphic"
	| window hSepFrac |

	hSepFrac := 0.4.
	window := (SystemWindow labelled: 'later') model: self.

"The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars need the lowerpanes to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added. "
	Preferences scrollBarsOnRight ifFalse:
		[self 
			addLowerPanesTo: window 
			at: (0@hSepFrac corner: 1@1) 
			with: editString].
		
	window 
		addMorph: self buildMorphicSystemCatList
		frame: (0@0 corner: 0.25@hSepFrac).
	self 
		addClassAndSwitchesTo: window 
		at: (0.25@0 corner: 0.5@hSepFrac)
		plus: 0.
	window 
		addMorph: self buildMorphicMessageCatList
		frame: (0.5@0 extent: 0.25@hSepFrac).
	window addMorph: self buildMorphicMessageList
		frame: (0.75@0 extent: 0.25@hSepFrac).

	Preferences scrollBarsOnRight ifTrue:
		[self 
			addLowerPanesTo: window 
			at: (0@hSepFrac corner: 1@1) 
			with: editString].

	window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList).
	^ window
! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openAsMorphMessageEditing: editString
	"Create a pluggable version a Browser that shows just one message"
	| window mySingletonMessageList verticalOffset nominalFractions |
	window := (SystemWindow labelled: 'later') model: self.

	mySingletonMessageList := PluggableListMorph on: self list: #messageListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #messageListMenu:shifted:
			keystroke: #messageListKey:from:.
	mySingletonMessageList enableDragNDrop: Preferences browseWithDragNDrop.
	verticalOffset := 25.
	nominalFractions := 0@0 corner: 1@0.
	window 
		addMorph: mySingletonMessageList
		fullFrame: (
			LayoutFrame 
				fractions: nominalFractions 
				offsets: (0@0 corner: 0@verticalOffset)
		).

	verticalOffset := self addOptionalAnnotationsTo: window at: nominalFractions plus: verticalOffset.
	verticalOffset := self addOptionalButtonsTo: window  at: nominalFractions plus: verticalOffset.

	window 
		addMorph: (self buildMorphicCodePaneWith: editString)
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@1) 
				offsets: (0@verticalOffset corner: 0@0)
		).

	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openAsMorphMsgCatEditing: editString
	"Create a pluggable version a Browser on just a message category."

	| window hSepFrac |
	window := (SystemWindow labelled: 'later') model: self.
	hSepFrac := 0.3.
	window 
		addMorph: ((PluggableListMorph on: self list: #messageCatListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #messageCategoryMenu:) enableDragNDrop: Preferences browseWithDragNDrop)
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@0) 
				offsets: (0@0 corner: 0@25)
		).
	window 
		addMorph: self buildMorphicMessageList
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@hSepFrac) 
				offsets: (0@25 corner: 0@0)
		).

	self 
		addLowerPanesTo: window 
		at: (0@hSepFrac corner: 1@1) 
		with: editString.
	window setUpdatablePanesFrom: #(messageCatListSingleton messageList).
	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openAsMorphSysCatEditing: editString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| window hSepFrac switchHeight mySingletonList nextOffsets |

	window := (SystemWindow labelled: 'later') model: self.
	hSepFrac := 0.30.
	switchHeight := 25.
	mySingletonList := PluggableListMorph on: self list: #systemCategorySingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:.
 	mySingletonList enableDragNDrop: Preferences browseWithDragNDrop.
	mySingletonList hideScrollBarsIndefinitely.
	window 
		addMorph: mySingletonList
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@0) 
				offsets: (0@0  corner: 0@switchHeight)
		).	

	self 
		addClassAndSwitchesTo: window 
		at: (0@0 corner: 0.3333@hSepFrac)
		plus: switchHeight.

	nextOffsets := 0@switchHeight corner: 0@0.
	window 
		addMorph: self buildMorphicMessageCatList
		fullFrame: (
			LayoutFrame 
				fractions: (0.3333@0 corner: 0.6666@hSepFrac) 
				offsets: nextOffsets
		).	

	window 
		addMorph: self buildMorphicMessageList
		fullFrame: (
			LayoutFrame 
				fractions: (0.6666@0 corner: 1@hSepFrac) 
				offsets: nextOffsets
		).	

	self 
		addLowerPanesTo: window 
		at: (0@hSepFrac corner: 1@1) 
		with: editString.

	window setUpdatablePanesFrom: #( classList messageCategoryList messageList).
	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openEditString: aString
        "Create a pluggable version of all the views for a Browser, including views and controllers."
        | systemCategoryListView classListView 
        messageCategoryListView messageListView browserCodeView topView switchView underPane y optionalButtonsView annotationPane |

        self couldOpenInMorphic ifTrue: [^ self openAsMorphEditing: aString].
        "Sensor leftShiftDown ifTrue: [^ self openAsMorphEditing: aString].
                uncomment-out for testing morphic browser embedded in mvc project"

        topView := StandardSystemView new model: self.
        topView borderWidth: 1. "label and minSize taken care of by caller"

        systemCategoryListView := PluggableListView on: self
                list: #systemCategoryList
                selected: #systemCategoryListIndex
                changeSelected: #systemCategoryListIndex:
                menu: #systemCategoryMenu:
                keystroke: #systemCatListKey:from:.
        systemCategoryListView window: (0 @ 0 extent: 50 @ 70).
        topView addSubView: systemCategoryListView.

        classListView := PluggableListView on: self
                list: #classList
                selected: #classListIndex
                changeSelected: #classListIndex:
                menu: #classListMenu:shifted:
                keystroke: #classListKey:from:.
        classListView window: (0 @ 0 extent: 50 @ 62).
        topView addSubView: classListView toRightOf: systemCategoryListView.

        switchView := self buildInstanceClassSwitchView.
        switchView borderWidth: 1.
        topView addSubView: switchView below: classListView.

        messageCategoryListView := PluggableListView on: self
                list: #messageCategoryList
                selected: #messageCategoryListIndex
                changeSelected: #messageCategoryListIndex:
                menu: #messageCategoryMenu:. 
        messageCategoryListView controller terminateDuringSelect: true.
        messageCategoryListView window: (0 @ 0 extent: 50 @ 70).
        topView addSubView: messageCategoryListView toRightOf: classListView.

        messageListView := PluggableListView on: self
                list: #messageList
                selected: #messageListIndex
                changeSelected: #messageListIndex:
                menu: #messageListMenu:shifted:
                keystroke: #messageListKey:from:.
        messageListView window: (0 @ 0 extent: 50 @ 70).
        messageListView menuTitleSelector: #messageListSelectorTitle.
        topView addSubView: messageListView toRightOf: messageCategoryListView.

       self wantsAnnotationPane
                ifTrue:
                        [annotationPane := PluggableTextView on: self
                                text: #annotation accept: nil
                                readSelection: nil menu: nil.
                        annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
                        topView addSubView: annotationPane below: systemCategoryListView.
                        underPane := annotationPane.
                        y := 110 - self optionalAnnotationHeight]
                ifFalse: [
                        underPane := systemCategoryListView.
                        y := 110].

        self wantsOptionalButtons ifTrue:
                [optionalButtonsView := self buildOptionalButtonsView.
                optionalButtonsView borderWidth: 1.
                topView addSubView: optionalButtonsView below: underPane.
                underPane := optionalButtonsView.
                y := y - self optionalButtonHeight].

        browserCodeView := MvcTextEditor default on: self 
                        text: #contents accept: #contents:notifying:
                        readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
        browserCodeView window: (0@0 extent: 200@y).
        topView addSubView: browserCodeView below: underPane.
        aString ifNotNil: [browserCodeView editString: aString.
                        browserCodeView hasUnacceptedEdits: true].
        topView setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList).

        ^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openMessageCatEditString: aString
        "Create a pluggable version of the views for a Browser that just shows one message category."
        | messageCategoryListView messageListView browserCodeView topView annotationPane underPane y optionalButtonsView |

        self couldOpenInMorphic ifTrue: [^ self openAsMorphMsgCatEditing: aString].

        topView := (StandardSystemView new) model: self.
        topView borderWidth: 1.
                "label and minSize taken care of by caller"

        messageCategoryListView := PluggableListView on: self
                list: #messageCatListSingleton
                selected: #indexIsOne 
                changeSelected: #indexIsOne:
                menu: #messageCategoryMenu:.
        messageCategoryListView window: (0 @ 0 extent: 200 @ 12).
        topView addSubView: messageCategoryListView.

        messageListView := PluggableListView on: self
                list: #messageList
                selected: #messageListIndex
                changeSelected: #messageListIndex:
                menu: #messageListMenu:shifted:
                keystroke: #messageListKey:from:.
        messageListView menuTitleSelector: #messageListSelectorTitle.
        messageListView window: (0 @ 0 extent: 200 @ 70).
        topView addSubView: messageListView below: messageCategoryListView.

        self wantsAnnotationPane
                ifTrue:
                        [annotationPane := PluggableTextView on: self
                                text: #annotation accept: nil
                                readSelection: nil menu: nil.
                        annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
                        topView addSubView: annotationPane below: messageListView.
                        underPane := annotationPane.
                        y := (200 - 12 - 70) - self optionalAnnotationHeight]
                ifFalse:
                        [underPane := messageListView.
                        y := (200 - 12 - 70)].

        self wantsOptionalButtons ifTrue:
                [optionalButtonsView := self buildOptionalButtonsView.
                optionalButtonsView borderWidth: 1.
                topView addSubView: optionalButtonsView below: underPane.
                underPane := optionalButtonsView.
                y := y - self optionalButtonHeight].

        browserCodeView := MvcTextEditor default on: self 
                        text: #contents accept: #contents:notifying:
                        readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
        browserCodeView window: (0@0 extent: 200@y).
        topView addSubView: browserCodeView below: underPane.
        aString ifNotNil: [browserCodeView editString: aString.
                        browserCodeView hasUnacceptedEdits: true].
        topView setUpdatablePanesFrom: #(messageCatListSingleton messageList).
        ^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openMessageEditString: aString
	"Create a pluggable version of the views for a Browser that just shows one message."
	| messageListView browserCodeView topView annotationPane underPane y |

	Smalltalk isMorphic ifTrue: [^ self openAsMorphMessageEditing: aString].

	topView := (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	messageListView := PluggableListView on: self
		list: #messageListSingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #messageListMenu:shifted:.
	messageListView window: (0 @ 0 extent: 200 @ 12).
	topView addSubView: messageListView.

	 self wantsAnnotationPane
		ifTrue:
			[annotationPane := PluggableTextView on: self
				text: #annotation accept: nil
				readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: messageListView.
			underPane := annotationPane.
			y := (200 - 12) - self optionalAnnotationHeight]
		ifFalse:
			[underPane := messageListView.
			y := 200 - 12].

	browserCodeView := MvcTextEditor default on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openOnClassWithEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| classListView messageCategoryListView messageListView browserCodeView topView switchView annotationPane underPane y optionalButtonsView |

	Smalltalk isMorphic ifTrue: [^ self openAsMorphClassEditing: aString].

	topView := (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	classListView := PluggableListView on: self
		list: #classListSingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #classListMenu:shifted:
		keystroke: #classListKey:from:.
	classListView window: (0 @ 0 extent: 100 @ 12).
	topView addSubView: classListView.

	messageCategoryListView := PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 100 @ 70).
	topView addSubView: messageCategoryListView below: classListView.

	messageListView := PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView menuTitleSelector: #messageListSelectorTitle.
	messageListView window: (0 @ 0 extent: 100 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	switchView := self buildInstanceClassSwitchView.
	switchView borderWidth: 1.
	switchView 
		window: switchView window 
		viewport: (classListView viewport topRight 
					corner: messageListView viewport topRight).
	topView addSubView: switchView toRightOf: classListView.

	 self wantsAnnotationPane
		ifTrue:
			[annotationPane := PluggableTextView on: self
				text: #annotation accept: nil
				readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: messageCategoryListView.
			underPane := annotationPane.
			y := (200-12-70) - self optionalAnnotationHeight]
		ifFalse:
			[underPane := messageCategoryListView.
			y := (200-12-70)].

	self wantsOptionalButtons ifTrue:
		[optionalButtonsView := self buildOptionalButtonsView.
		optionalButtonsView borderWidth: 1.
		topView addSubView: optionalButtonsView below: underPane.
		underPane := optionalButtonsView.
		y := y - self optionalButtonHeight].

	browserCodeView := MvcTextEditor default on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].

	topView setUpdatablePanesFrom: #(messageCategoryList messageList).
	^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
openSystemCatEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers.  The top list view is of the currently selected system class category--a single item list."
	| systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView y annotationPane underPane optionalButtonsView |

	Smalltalk isMorphic ifTrue: [^ self openAsMorphSysCatEditing: aString].

	topView := (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	systemCategoryListView := PluggableListView on: self
		list: #systemCategorySingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #systemCatSingletonMenu:
		keystroke: #systemCatSingletonKey:from:.
	systemCategoryListView window: (0 @ 0 extent: 200 @ 12).
	topView addSubView: systemCategoryListView.

	classListView := PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: #classListMenu:shifted:
		keystroke: #classListKey:from:.
	classListView window: (0 @ 0 extent: 67 @ 62).
	topView addSubView: classListView below: systemCategoryListView.

	messageCategoryListView := PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView controller terminateDuringSelect: true.
	messageCategoryListView window: (0 @ 0 extent: 66 @ 70).
	topView addSubView: messageCategoryListView toRightOf: classListView.

	switchView := self buildInstanceClassSwitchView.
	switchView 
		window: switchView window 
		viewport: (classListView viewport bottomLeft 
					corner: messageCategoryListView viewport bottomLeft).
	switchView borderWidth: 1.
	topView addSubView: switchView below: classListView.

	messageListView := PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView menuTitleSelector: #messageListSelectorTitle.
	messageListView window: (0 @ 0 extent: 67 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	 self wantsAnnotationPane
		ifTrue:
			[annotationPane := PluggableTextView on: self
				text: #annotation accept: nil
				readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: switchView.
			y := 110 - 12 - self optionalAnnotationHeight.
			underPane := annotationPane]
		ifFalse:
			[y := 110 - 12.
			underPane := switchView].

	self wantsOptionalButtons ifTrue:
		[optionalButtonsView := self buildOptionalButtonsView.
		optionalButtonsView borderWidth: 1.
		topView addSubView: optionalButtonsView below: underPane.
		underPane := optionalButtonsView.
		y := y - self optionalButtonHeight].

	browserCodeView := MvcTextEditor default on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	topView setUpdatablePanesFrom: #(classList messageCategoryList messageList).
	^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sbw 12/8/1999 12:37'!
optionalAnnotationHeight

	^ 10! !

!Browser methodsFor: 'initialize-release' stamp: 'sbw 12/8/1999 12:23'!
optionalButtonHeight

	^ 10! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
setClass: aBehavior selector: aSymbol
	"Set the state of a new, uninitialized Browser."

	| isMeta aClass messageCatIndex |
	aBehavior ifNil: [^ self].
	(aBehavior isKindOf: Metaclass)
		ifTrue: [
			isMeta := true.
			aClass := aBehavior soleInstance]
		ifFalse: [
			isMeta := false.
			aClass := aBehavior].
	self selectCategoryForClass: aClass.
	self classListIndex: (
		(systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName)
			indexOf: aClass name).
	self metaClassIndicated: isMeta.
	aSymbol ifNil: [^ self].
	messageCatIndex := aBehavior organization numberOfCategoryOfElement: aSymbol.
	self messageCategoryListIndex: (messageCatIndex > 0
		ifTrue: [messageCatIndex + 1]
		ifFalse: [0]).
	messageCatIndex = 0 ifTrue: [^ self].
	self messageListIndex: (
		(aBehavior organization listAtCategoryNumber: messageCatIndex)
			indexOf: aSymbol).! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
setSelector: aSymbol
	"Make the receiver point at the given selector, in the currently chosen class"

	| aClass messageCatIndex |
	aSymbol ifNil: [^ self].
	(aClass := self selectedClassOrMetaClass) ifNil: [^ self].
	messageCatIndex := aClass organization numberOfCategoryOfElement: aSymbol.
	self messageCategoryListIndex: messageCatIndex + 1.
	messageCatIndex = 0 ifTrue: [^ self].
	self messageListIndex:
			((aClass organization listAtCategoryNumber: messageCatIndex)
					indexOf: aSymbol)! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 11/8/1999 13:36'!
systemCatSingletonKey: aChar from: aView
	^ self messageListKey: aChar from: aView! !

!Browser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:26'!
systemOrganizer: aSystemOrganizer
	"Initialize the receiver as a perspective on the system organizer, 
	aSystemOrganizer. Typically there is only one--the system variable 
	SystemOrganization."
	
	contents := nil.
	systemOrganizer := aSystemOrganizer.
	systemCategoryListIndex := 0.
	classListIndex := 0.
	messageCategoryListIndex := 0.
	messageListIndex := 0.
	metaClassIndicated := false.
	self setClassOrganizer.
	self editSelection: #none.! !


!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'!
addCategory
	"Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection"
	| labels reject lines cats menuIndex oldIndex newName |
	self okToChange ifFalse: [^ self].
	classListIndex = 0 ifTrue: [^ self].
	labels := OrderedCollection with: 'new...'.
	reject := Set new.
	reject
		addAll: self selectedClassOrMetaClass organization categories;
		add: ClassOrganizer nullCategory;
		add: ClassOrganizer default.
	lines := OrderedCollection new.
	self selectedClassOrMetaClass allSuperclasses do: [:cls |
		cls = Object ifFalse: [
			cats := cls organization categories reject:
				 [:cat | reject includes: cat].
			cats isEmpty ifFalse: [
				lines add: labels size.
				labels addAll: cats asSortedCollection.
				reject addAll: cats]]].
	newName := (labels size = 1 or: [
		menuIndex := (UIManager default chooseFrom: labels lines: lines title: 'Add Category').
		menuIndex = 0 ifTrue: [^ self].
		menuIndex = 1])
			ifTrue: [
				self request: 'Please type new category name'
					initialAnswer: 'category name']
			ifFalse: [
				labels at: menuIndex].
	oldIndex := messageCategoryListIndex.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName := newName asSymbol].
	self classOrMetaClassOrganizer
		addCategory: newName
		before: (messageCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedMessageCategoryName]).
	self changed: #messageCategoryList.
	self messageCategoryListIndex:
		(oldIndex = 0
			ifTrue: [self classOrMetaClassOrganizer categories size + 1]
			ifFalse: [oldIndex]).
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:47'!
alphabetizeMessageCategories
	classListIndex = 0 ifTrue: [^ false].
	self okToChange ifFalse: [^ false].
	self classOrMetaClassOrganizer sortCategories.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions'!
buildMessageCategoryBrowser
	"Create and schedule a message category browser for the currently 
	selected message category."

	self buildMessageCategoryBrowserEditString: nil! !

!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'!
buildMessageCategoryBrowserEditString: aString 
	"Create and schedule a message category browser for the currently 
	selected	 message category. The initial text view contains the characters 
	in aString."
	"wod 6/24/1998: set newBrowser classListIndex so that it works whether the
	receiver is a standard or a Hierarchy Browser."

	| newBrowser |
	messageCategoryListIndex ~= 0
		ifTrue: 
			[newBrowser := Browser new.
			newBrowser systemCategoryListIndex: systemCategoryListIndex.
			newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName).
			newBrowser metaClassIndicated: metaClassIndicated.
			newBrowser messageCategoryListIndex: messageCategoryListIndex.
			newBrowser messageListIndex: messageListIndex.
			self class openBrowserView: (newBrowser openMessageCatEditString: aString)
				label: 'Message Category Browser (' , 
						newBrowser selectedClassOrMetaClassName , ')']! !

!Browser methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'!
canShowMultipleMessageCategories
	"Answer whether the receiver is capable of showing multiple message categories"

	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'!
categoryOfCurrentMethod
	"Determine the method category associated with the receiver at the current moment, or nil if none"

	| aCategory |
	^ super categoryOfCurrentMethod ifNil:
		[(aCategory := self messageCategoryListSelection) == ClassOrganizer allCategory
					ifTrue:
						[nil]
					ifFalse:
						[aCategory]]! !

!Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:56'!
changeMessageCategories: aString 
	"The characters in aString represent an edited version of the the message 
	categories for the selected class. Update this information in the system 
	and inform any dependents that the categories have been changed. This 
	message is invoked because the user had issued the categories command 
	and edited the message categories. Then the user issued the accept 
	command."

	self classOrMetaClassOrganizer changeFromString: aString.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'nk 2/14/2004 15:06'!
editMessageCategories
	"Indicate to the receiver and its dependents that the message categories of 
	the selected class have been changed."

	self okToChange ifFalse: [^ self].
	classListIndex ~= 0
		ifTrue: 
			[self messageCategoryListIndex: 0.
			self editSelection: #editMessageCategories.
			self changed: #editMessageCategories.
			self contentsChanged]! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
fileOutMessageCategories
	"Print a description of the selected message category of the selected class 
	onto an external file."

Cursor write showWhile:
	[messageCategoryListIndex ~= 0
		ifTrue: 
			[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! !

!Browser methodsFor: 'message category functions' stamp: 'emm 5/30/2002 09:20'!
highlightMessageList: list with: morphList
	"Changed by emm to add emphasis in case of breakpoint"

	morphList do:[:each | 
		| classOrNil methodOrNil |
		classOrNil := self selectedClassOrMetaClass.
		methodOrNil := classOrNil isNil
			ifTrue:[nil]
			ifFalse:[classOrNil methodDictionary at: each contents ifAbsent:[]].
		(methodOrNil notNil and:[methodOrNil hasBreakpoint])
			ifTrue:[each contents: ((each contents ,' [break]') asText allBold)]]! !

!Browser methodsFor: 'message category functions' stamp: 'rr 7/10/2006 11:49'!
messageCategoryMenu: aMenu
	ServiceGui browser: self messageCategoryMenu: aMenu.
	ServiceGui onlyServices ifTrue: [^aMenu].
	^ aMenu labels:
'browse
printOut
fileOut
reorganize
alphabetize
remove empty categories
categorize all uncategorized
new category...
rename...
remove'
		lines: #(3 8)
		selections:
		#(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories
		editMessageCategories alphabetizeMessageCategories removeEmptyCategories
		categorizeAllUncategorizedMethods addCategory renameCategory removeMessageCategory)
! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
printOutMessageCategories
	"Print a description of the selected message category of the selected class 
	onto an external file in Html format."

Cursor write showWhile:
	[messageCategoryListIndex ~= 0
		ifTrue: 
			[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName
										asHtml: true]]! !

!Browser methodsFor: 'message category functions' stamp: 'nk 4/23/2004 09:18'!
removeEmptyCategories
	self okToChange ifFalse: [^ self].
	self selectedClassOrMetaClass organization removeEmptyCategories.
	self changed: #messageCategoryList
! !

!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'!
removeMessageCategory
	"If a message category is selected, create a Confirmer so the user can 
	verify that the currently selected message category should be removed
 	from the system. If so, remove it."

	| messageCategoryName |
	messageCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageCategoryName := self selectedMessageCategoryName.
	(self messageList size = 0
		or: [self confirm: 'Are you sure you want to
remove this method category 
and all its methods?'])
		ifTrue: 
			[self selectedClassOrMetaClass removeCategory: messageCategoryName.
			self messageCategoryListIndex: 0.
			self changed: #classSelectionChanged].
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'!
renameCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(oldIndex := messageCategoryListIndex) = 0 ifTrue: [^ self].
	oldName := self selectedMessageCategoryName.
	newName := self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName := newName asSymbol].
	newName = oldName ifTrue: [^ self].
	self classOrMetaClassOrganizer
		renameCategory: oldName
		toBe: newName.
	self classListIndex: classListIndex.
	self messageCategoryListIndex: oldIndex.
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'!
showHomeCategory
	"Show the home category of the selected method.  This is only really useful if one is in a tool that supports the showing of categories.  Thus, it's good in browsers and hierarchy browsers but not in message-list browsers"

	| aSelector |
	self okToChange ifTrue:
		[(aSelector := self selectedMessageName) ifNotNil:
			[self selectOriginalCategoryForCurrentMethod.
			self selectedMessageName: aSelector]]! !


!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'!
categorizeAllUncategorizedMethods
	"Categorize methods by looking in parent classes for a method category."

	| organizer organizers |
	organizer := self classOrMetaClassOrganizer.
	organizers := self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization].
	(organizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found |
		found := (organizers collect: [ :org | org categoryOfElement: sel])
			detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]]
			ifNone: [].
		found ifNotNil: [organizer classify: sel under: found]].

	self changed: #messageCategoryList! !

!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'!
messageCatListSingleton

	| name |
	name := self selectedMessageCategoryName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'message category list' stamp: 'ccn 3/22/1999 17:56'!
messageCategoryList
	"Answer the selected category of messages."

	classListIndex = 0
		ifTrue: [^ Array new]
		ifFalse: [^ (Array with: ClassOrganizer allCategory), self classOrMetaClassOrganizer categories]! !

!Browser methodsFor: 'message category list'!
messageCategoryListIndex
	"Answer the index of the selected message category."

	^messageCategoryListIndex! !

!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'!
messageCategoryListIndex: anInteger
	"Set the selected message category to be the one indexed by anInteger."

	messageCategoryListIndex := anInteger.
	messageListIndex := 0.
	self changed: #messageCategorySelectionChanged.
	self changed: #messageCategoryListIndex. "update my selection"
	self changed: #messageList.
	self editSelection: (anInteger > 0
		ifTrue: [#newMessage]
		ifFalse: [self classListIndex > 0
			ifTrue: [#editClass]
			ifFalse: [#newClass]]).
	contents := nil.
	self contentsChanged.! !

!Browser methodsFor: 'message category list' stamp: 'ccn 3/24/1999 11:02'!
messageCategoryListSelection
	"Return the selected category name or nil."

	^ ((self messageCategoryList size = 0 
		or: [self messageCategoryListIndex = 0]) 
		or: [self messageCategoryList size < self messageCategoryListIndex])
			ifTrue: [nil]
			ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! !

!Browser methodsFor: 'message category list' stamp: 'sw 10/16/1999 22:56'!
rawMessageCategoryList
	^ classListIndex = 0
		ifTrue: [Array new]
		ifFalse: [self classOrMetaClassOrganizer categories]! !

!Browser methodsFor: 'message category list' stamp: 'nk 4/22/2004 17:59'!
recategorizeMethodSelector: sel 
	"Categorize method named sel by looking in parent classes for a 
	method category. 
	Answer true if recategorized."
	| thisCat |
	self selectedClassOrMetaClass allSuperclasses
		do: [:ea | 
			thisCat := ea organization categoryOfElement: sel.
			(thisCat ~= ClassOrganizer default
					and: [thisCat notNil])
				ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat.
					self changed: #messageCategoryList.
					^ true]].
	^ false! !

!Browser methodsFor: 'message category list' stamp: 'nk 6/13/2004 06:20'!
selectMessageCategoryNamed: aSymbol 
	"Given aSymbol, select the category with that name.  Do nothing if 
	aSymbol doesn't exist."
	self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol ifAbsent: [ 1])! !

!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'!
selectOriginalCategoryForCurrentMethod
	"private - Select the message category for the current method. 
	 
	 Note:  This should only be called when somebody tries to save  
	 a method that they are modifying while ALL is selected. 
	 
	 Returns: true on success, false on failure."
	| aSymbol selectorName |
	aSymbol := self categoryOfCurrentMethod.
	selectorName := self selectedMessageName.
	(aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory])
		ifTrue: 
			[messageCategoryListIndex := (self messageCategoryList indexOf: aSymbol).
			messageListIndex := (self messageList indexOf: selectorName).
			self changed: #messageCategorySelectionChanged.
			self changed: #messageCategoryListIndex.	"update my selection"
			self changed: #messageList.
			self changed: #messageListIndex.
			^ true].
	^ false! !

!Browser methodsFor: 'message category list'!
selectedMessageCategoryName
	"Answer the name of the selected message category, if any. Answer nil 
	otherwise."

	messageCategoryListIndex = 0 ifTrue: [^nil].
	^self messageCategoryList at: messageCategoryListIndex! !

!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'!
setOriginalCategoryIndexForCurrentMethod
	"private - Set the message category index for the currently selected method. 
	 
	 Note:  This should only be called when somebody tries to save  
	 a method that they are modifying while ALL is selected."

	messageCategoryListIndex := self messageCategoryList indexOf: self categoryOfCurrentMethod
	! !

!Browser methodsFor: 'message category list'!
toggleMessageCategoryListIndex: anInteger 
	"If the currently selected message category index is anInteger, deselect 
	the category. Otherwise select the category whose index is anInteger."

	self messageCategoryListIndex: 
		(messageCategoryListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'message functions' stamp: 'sw 1/11/2001 07:22'!
addExtraShiftedItemsTo: aMenu
	"The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate.  If any is added here, a line should be added first -- browse reimplementors of this message for examples."
! !

!Browser methodsFor: 'message functions'!
buildMessageBrowser
	"Create and schedule a message browser on the currently selected 
	message. Do nothing if no message is selected. The initial text view 
	contains nothing."

	self buildMessageBrowserEditString: nil! !

!Browser methodsFor: 'message functions' stamp: 'sd 1/5/2002 21:11'!
buildMessageBrowserEditString: aString 
	"Create and schedule a message browser for the receiver in which the 
	argument, aString, contains characters to be edited in the text view."

	messageListIndex = 0 ifTrue: [^ self].
	^ self class openMessageBrowserForClass: self selectedClassOrMetaClass 
		selector: self selectedMessageName editString: aString! !

!Browser methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:26'!
defineMessage: aString notifying: aController 
	"Compile the expressions in aString. Notify aController if a syntax error 
	occurs. Install the compiled method in the selected class classified under 
	the currently selected message category name. Answer true if 
	compilation succeeds, false otherwise."
	| selectedMessageName selector category oldMessageList |
	selectedMessageName := self selectedMessageName.
	oldMessageList := self messageList.
	contents := nil.
	selector := self selectedClassOrMetaClass
				compile: aString
				classified: (category := self selectedMessageCategoryName)
				notifying: aController.
	selector == nil ifTrue: [^ false].
	contents := aString copy.
	selector ~~ selectedMessageName
		ifTrue: 
			[category = ClassOrganizer nullCategory
				ifTrue: [self changed: #classSelectionChanged.
						self changed: #classList.
						self messageCategoryListIndex: 1].
			self setClassOrganizer.  "In case organization not cached"
			(oldMessageList includes: selector)
				ifFalse: [self changed: #messageList].
			self messageListIndex: (self messageList indexOf: selector)].
	^ true! !

!Browser methodsFor: 'message functions' stamp: 'md 2/20/2006 18:42'!
defineMessageFrom: aString notifying: aController
	"Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under  the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise."
	| selectedMessageName selector category oldMessageList |
	selectedMessageName := self selectedMessageName.
	oldMessageList := self messageList.
	contents := nil.
	selector := (self selectedClassOrMetaClass parserClass new parseSelector: aString).
	(self metaClassIndicated
		and: [(self selectedClassOrMetaClass includesSelector: selector) not
		and: [Metaclass isScarySelector: selector]])
		ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses"
				(self confirm: ((selector , ' is used in the existing class system.
Overriding it could cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size))
				ifFalse: [^nil]].
	selector := self selectedClassOrMetaClass
				compile: aString
				classified: (category := self selectedMessageCategoryName)
				notifying: aController.
	selector == nil ifTrue: [^ nil].
	contents := aString copy.
	selector ~~ selectedMessageName
		ifTrue: 
			[category = ClassOrganizer nullCategory
				ifTrue: [self changed: #classSelectionChanged.
						self changed: #classList.
						self messageCategoryListIndex: 1].
			self setClassOrganizer.  "In case organization not cached"
			(oldMessageList includes: selector)
				ifFalse: [self changed: #messageList].
			self messageListIndex: (self messageList indexOf: selector)].
	^ selector! !

!Browser methodsFor: 'message functions' stamp: 'al 4/24/2004 12:48'!
inspectInstances
	"Inspect all instances of the selected class.  1/26/96 sw"

	| myClass |
	((myClass _ self selectedClassOrMetaClass) isNil or: [myClass isTrait])
		ifFalse: [myClass theNonMetaClass inspectAllInstances]
! !

!Browser methodsFor: 'message functions' stamp: 'al 4/24/2004 12:48'!
inspectSubInstances
	"Inspect all instances of the selected class and all its subclasses  1/26/96 sw"

	| aClass |
	((aClass _ self selectedClassOrMetaClass) isNil or: [aClass isTrait])
		ifFalse: [
			aClass _ aClass theNonMetaClass.
			aClass inspectSubInstances].
! !

!Browser methodsFor: 'message functions' stamp: 'rr 7/10/2006 11:50'!
messageListMenu: aMenu shifted: shifted 
	"Answer the message-list menu"
	ServiceGui browser: self messageListMenu: aMenu.
	ServiceGui onlyServices ifTrue: [^ aMenu].
	shifted
		ifTrue: [^ self shiftedMessageListMenu: aMenu].
	aMenu addList: #(
			('what to show...'			offerWhatToShowMenu)
			('toggle break on entry'		toggleBreakOnEntry)
			-
			('browse full (b)' 			browseMethodFull)
			('browse hierarchy (h)'			classHierarchy)
			('browse method (O)'			openSingleMessageBrowser)
			('browse protocol (p)'			browseFullProtocol)
			-
			('fileOut'				fileOutMessage)
			('printOut'				printOutMessage)
			-
			('senders of... (n)'			browseSendersOfMessages)
			('implementors of... (m)'		browseMessages)
			('inheritance (i)'			methodHierarchy)
			('tile scriptor'			openSyntaxView)
			('versions (v)'				browseVersions)
			-
			('inst var refs...'			browseInstVarRefs)
			('inst var defs...'			browseInstVarDefs)
			('class var refs...'			browseClassVarRefs)
			('class variables'			browseClassVariables)
			('class refs (N)'			browseClassRefs)
			-
			('remove method (x)'			removeMessage)
			-
			('more...'				shiftedYellowButtonActivity)).
	^ aMenu! !

!Browser methodsFor: 'message functions' stamp: 'al 4/24/2004 11:49'!
removeMessage
	"If a message is selected, create a Confirmer so the user can verify that  
	the currently selected message should be removed from the system. If 
	so,  
	remove it. If the Preference 'confirmMethodRemoves' is set to false, the 
	confirmer is bypassed."
	| messageName confirmation |
	messageListIndex = 0
		ifTrue: [^ self].
	self okToChange
		ifFalse: [^ self].
	messageName _ self selectedMessageName.
	confirmation _ self systemNavigation   confirmRemovalOf: messageName on: self selectedClassOrMetaClass.
	confirmation == 3
		ifTrue: [^ self].
	(self selectedClassOrMetaClass includesLocalSelector: messageName)
		ifTrue: [self selectedClassOrMetaClass removeSelector: messageName]
		ifFalse: [self removeNonLocalSelector: messageName].
	self messageListIndex: 0.
	self changed: #messageList.
	self setClassOrganizer.
	"In case organization not cached"
	confirmation == 2
		ifTrue: [self systemNavigation browseAllCallsOn: messageName]! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'!
removeMessageFromBrowser
	"Our list speaks the truth and can't have arbitrary things removed"

	^ self changed: #flash! !

!Browser methodsFor: 'message functions' stamp: 'md 7/29/2005 15:59'!
shiftedMessageListMenu: aMenu
	"Fill aMenu with the items appropriate when the shift key is held down"

	Smalltalk isMorphic ifTrue: [aMenu addStayUpItem].
	aMenu addList: #(
		('method pane' 							makeIsolatedCodePane)
		('tile scriptor'							openSyntaxView)
		('toggle diffing (D)'						toggleDiffing)
		('implementors of sent messages'			browseAllMessages)
		-
		('local senders of...'						browseLocalSendersOfMessages)
		('local implementors of...'				browseLocalImplementors)
		-
		('spawn sub-protocol'					spawnProtocol)
		('spawn full protocol'					spawnFullProtocol)
		-
		('sample instance'						makeSampleInstance)
		('inspect instances'						inspectInstances)
		('inspect subinstances'					inspectSubInstances)).

	self addExtraShiftedItemsTo: aMenu.
	aMenu addList: #(
		-
		('change category...'					changeCategory)).

	self canShowMultipleMessageCategories ifTrue: [aMenu addList:
		 #(('show category (C)'						showHomeCategory))].
	aMenu addList: #(
		-
		('change sets with this method'			findMethodInChangeSets)
		('revert to previous version'				revertToPreviousVersion)
		('remove from current change set'		removeFromCurrentChanges)
		('revert & remove from changes'		revertAndForget)
		('add to current change set'				adoptMessageInCurrentChangeset)
		('copy up or copy down...'				copyUpOrCopyDown)
		-
		('more...' 								unshiftedYellowButtonActivity)).
	^ aMenu
! !


!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
messageList
	"Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range.  Otherwise, answer an empty Array  If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero."
	| sel |
	(sel := self messageCategoryListSelection) ifNil: 
		[
			^ self classOrMetaClassOrganizer
				ifNil:		[Array new]
				ifNotNil:	[self classOrMetaClassOrganizer allMethodSelectors]
			"^ Array new"
		].

	^ sel = ClassOrganizer allCategory
		ifTrue: 
			[self classOrMetaClassOrganizer
				ifNil:		[Array new]
				ifNotNil:	[self classOrMetaClassOrganizer allMethodSelectors]]
		ifFalse:
			[(self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex - 1)
				ifNil: [messageCategoryListIndex := 0.  Array new]]! !

!Browser methodsFor: 'message list'!
messageListIndex
	"Answer the index of the selected message selector into the currently 
	selected message category."

	^messageListIndex! !

!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
messageListIndex: anInteger
	"Set the selected message selector to be the one indexed by anInteger."

	messageListIndex := anInteger.
	self editSelection: (anInteger > 0
		ifTrue: [#editMessage]
		ifFalse: [self messageCategoryListIndex > 0
			ifTrue: [#newMessage]
			ifFalse: [self classListIndex > 0
				ifTrue: [#editClass]
				ifFalse: [#newClass]]]).
	contents := nil.
	self changed: #messageListIndex. "update my selection"
	self contentsChanged.
	self decorateButtons.! !

!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
messageListSingleton

	| name |
	name := self selectedMessageName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'message list' stamp: 'sw 12/1/2000 11:17'!
reformulateList
	"If the receiver has a way of reformulating its message list, here is a chance for it to do so"

	super reformulateList.
	self messageListIndex: 0! !

!Browser methodsFor: 'message list' stamp: 'md 2/20/2006 15:01'!
selectedMessage
	"Answer a copy of the source code for the selected message."

	| class selector method |
	contents == nil ifFalse: [^ contents copy].

	self showingDecompile ifTrue:
		[^ self decompiledSourceIntoContents].

	class := self selectedClassOrMetaClass.
	selector := self selectedMessageName.
	method := class compiledMethodAt: selector ifAbsent: [^ ''].	"method deleted while in another project"
	currentCompiledMethod := method.

	^ contents := (self showingDocumentation
		ifFalse: [ self sourceStringPrettifiedAndDiffed ]
		ifTrue: [ self commentContents ])
			copy asText makeSelectorBoldIn: class! !

!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
selectedMessageName
	"Answer the message selector of the currently selected message, if any. 
	Answer nil otherwise."

	| aList |
	messageListIndex = 0 ifTrue: [^ nil].
	^ (aList := self messageList) size >= messageListIndex
		ifTrue:
			[aList at: messageListIndex]
		ifFalse:
			[nil]! !

!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
selectedMessageName: aSelector
	"Make the given selector be the selected message name"

	| anIndex |
	anIndex := self messageList indexOf: aSelector.
	anIndex > 0 ifTrue:
		[self messageListIndex: anIndex]! !

!Browser methodsFor: 'message list'!
toggleMessageListIndex: anInteger 
	"If the currently selected message index is anInteger, deselect the message 
	selector. Otherwise select the message selector whose index is anInteger."

	self messageListIndex: 
		(messageListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 12:25'!
classCommentIndicated
	"Answer true iff we're viewing the class comment."

	^ editSelection == #editComment 
! !

!Browser methodsFor: 'metaclass' stamp: 'ak 11/24/2000 21:46'!
classMessagesIndicated
	"Answer whether the messages to be presented should come from the 
	metaclass."

	^ self metaClassIndicated and: [self classCommentIndicated not]! !

!Browser methodsFor: 'metaclass'!
classOrMetaClassOrganizer
	"Answer the class organizer for the metaclass or class, depending on 
	which (instance or class) is indicated."

	self metaClassIndicated
		ifTrue: [^metaClassOrganizer]
		ifFalse: [^classOrganizer]! !

!Browser methodsFor: 'metaclass'!
indicateClassMessages
	"Indicate that the message selection should come from the metaclass 
	messages."

	self metaClassIndicated: true! !

!Browser methodsFor: 'metaclass'!
indicateInstanceMessages
	"Indicate that the message selection should come from the class (instance) 
	messages."

	self metaClassIndicated: false! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:20'!
instanceMessagesIndicated
	"Answer whether the messages to be presented should come from the 
	class."

	^metaClassIndicated not and: [self classCommentIndicated not]! !

!Browser methodsFor: 'metaclass' stamp: 'sr 6/21/2000 17:23'!
metaClassIndicated
	"Answer the boolean flag that indicates which of the method dictionaries, 
	class or metaclass."

	^ metaClassIndicated! !

!Browser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:26'!
metaClassIndicated: trueOrFalse 
	"Indicate whether browsing instance or class messages."

	metaClassIndicated := trueOrFalse.
	self setClassOrganizer.
	systemCategoryListIndex > 0 ifTrue:
		[self editSelection: (classListIndex = 0
			ifTrue: [metaClassIndicated
				ifTrue: [#none]
				ifFalse: [#newClass]]
			ifFalse: [#editClass])].
	messageCategoryListIndex := 0.
	messageListIndex := 0.
	contents := nil.
	self changed: #classSelectionChanged.
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #contents.
	self changed: #annotation.
	self decorateButtons
! !

!Browser methodsFor: 'metaclass' stamp: 'al 4/24/2004 11:47'!
selectedClassOrMetaClass
	"Answer the selected class/trait or metaclass/classTrait."

	| cls |
	^self metaClassIndicated
		ifTrue: [(cls _ self selectedClass) ifNil: [nil] ifNotNil: [cls classSide]]
		ifFalse: [self selectedClass]! !

!Browser methodsFor: 'metaclass'!
selectedClassOrMetaClassName
	"Answer the selected class name or metaclass name."

	^self selectedClassOrMetaClass name! !

!Browser methodsFor: 'metaclass' stamp: 'md 2/18/2006 16:31'!
setClassOrganizer
	"Install whatever organization is appropriate"
	| theClass |
	classOrganizer _ nil.
	metaClassOrganizer _ nil.
	classListIndex = 0 ifTrue: [^ self].
	theClass _ self selectedClass ifNil: [ ^self ].
	classOrganizer _ theClass organization.
	metaClassOrganizer _ theClass classSide organization.! !


!Browser methodsFor: 'system category functions' stamp: 'sd 11/20/2005 21:26'!
addSystemCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex newName |
	self okToChange ifFalse: [^ self].
	oldIndex := systemCategoryListIndex.
	newName := self
		request: 'Please type new category name'
		initialAnswer: 'Category-Name'.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName := newName asSymbol].
	systemOrganizer
		addCategory: newName
		before: (systemCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedSystemCategoryName]).
	self systemCategoryListIndex:
		(oldIndex = 0
			ifTrue: [self systemCategoryList size]
			ifFalse: [oldIndex]).
	self changed: #systemCategoryList.! !

!Browser methodsFor: 'system category functions' stamp: 'brp 8/4/2003 21:38'!
alphabetizeSystemCategories

	self okToChange ifFalse: [^ false].
	systemOrganizer sortCategories.
	self systemCategoryListIndex: 0.
	self changed: #systemCategoryList.
! !

!Browser methodsFor: 'system category functions' stamp: 'sd 11/20/2005 21:26'!
browseAllClasses
	"Create and schedule a new browser on all classes alphabetically."
	| newBrowser |
	newBrowser := HierarchyBrowser new initAlphabeticListing.
	self class openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: 'All Classes Alphabetically'! !

!Browser methodsFor: 'system category functions'!
buildSystemCategoryBrowser
	"Create and schedule a new system category browser."

	self buildSystemCategoryBrowserEditString: nil! !

!Browser methodsFor: 'system category functions' stamp: 'sd 11/20/2005 21:26'!
buildSystemCategoryBrowserEditString: aString 
	"Create and schedule a new system category browser with initial textual 
	contents set to aString."

	| newBrowser |
	systemCategoryListIndex > 0
		ifTrue: 
			[newBrowser := self class new.
			newBrowser systemCategoryListIndex: systemCategoryListIndex.
			newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName.
			self class openBrowserView: (newBrowser openSystemCatEditString: aString)
				label: 'Classes in category ', newBrowser selectedSystemCategoryName]! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:21'!
changeSystemCategories: aString 
	"Update the class categories by parsing the argument aString."

	systemOrganizer changeFromString: aString.
	self changed: #systemCategoryList.
	^ true! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:43'!
classNotFound

	self changed: #flash.! !

!Browser methodsFor: 'system category functions' stamp: 'nk 2/14/2004 15:09'!
editSystemCategories
	"Retrieve the description of the class categories of the system organizer."

	self okToChange ifFalse: [^ self].
	self systemCategoryListIndex: 0.
	self editSelection: #editSystemCategories.
	self changed: #editSystemCategories.
	self contentsChanged! !

!Browser methodsFor: 'system category functions' stamp: 'tk 3/31/98 07:52'!
fileOutSystemCategory
	"Print a description of each class in the selected category onto a file 
	whose name is the category name followed by .st."

	systemCategoryListIndex ~= 0
		ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]! !

!Browser methodsFor: 'system category functions' stamp: 'al 1/13/2006 11:24'!
findClass
	"Search for a class by name."
	| pattern foundClassOrTrait |

	self okToChange ifFalse: [^ self classNotFound].
	pattern := UIManager default request: 'Class name or fragment?'.
	pattern isEmpty ifTrue: [^ self classNotFound].
	foundClassOrTrait := Utilities classFromPattern: pattern withCaption: ''.
	foundClassOrTrait ifNil: [^ self classNotFound].
 	self selectCategoryForClass: foundClassOrTrait.
	self selectClass: foundClassOrTrait.
! !

!Browser methodsFor: 'system category functions' stamp: 'sw 11/8/1999 10:04'!
potentialClassNames
	"Answer the names of all the classes that could be viewed in this browser.  This hook is provided so that HierarchyBrowsers can indicate their restricted subset.  For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers."

	^ Smalltalk classNames! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:46'!
printOutSystemCategory
	"Print a description of each class in the selected category as Html."

Cursor write showWhile:
	[systemCategoryListIndex ~= 0
		ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName
								asHtml: true ]]
! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'!
removeSystemCategory
	"If a class category is selected, create a Confirmer so the user can 
	verify that the currently selected class category and all of its classes
 	should be removed from the system. If so, remove it."

	systemCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(self classList size = 0
		or: [self confirm: 'Are you sure you want to
remove this system category 
and all its classes?'])
		ifTrue: 
		[systemOrganizer removeSystemCategory: self selectedSystemCategoryName.
		self systemCategoryListIndex: 0.
		self changed: #systemCategoryList]! !

!Browser methodsFor: 'system category functions' stamp: 'sd 11/20/2005 21:26'!
renameSystemCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	(oldIndex := systemCategoryListIndex) = 0
		ifTrue: [^ self].  "no selection"
	self okToChange ifFalse: [^ self].
	oldName := self selectedSystemCategoryName.
	newName := self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName := newName asSymbol].
	oldName = newName ifTrue: [^ self].
	systemOrganizer
		renameCategory: oldName
		toBe: newName.
	self systemCategoryListIndex: oldIndex.
	self changed: #systemCategoryList.! !

!Browser methodsFor: 'system category functions' stamp: 'sw 11/8/1999 14:07'!
systemCatSingletonMenu: aMenu

	^ aMenu labels:
'browse all
browse
printOut
fileOut
update
rename...
remove' 
	lines: #(2 4)
	selections:
		#(browseAllClasses buildSystemCategoryBrowser
		printOutSystemCategory fileOutSystemCategory updateSystemCategories
		renameSystemCategory removeSystemCategory)
! !

!Browser methodsFor: 'system category functions' stamp: 'rr 7/10/2006 11:52'!
systemCategoryMenu: aMenu
		
	ServiceGui browser: self classCategoryMenu: aMenu.
	ServiceGui onlyServices ifTrue: [^aMenu].
	^ aMenu labels:
'find class... (f)
recent classes... (r)
browse all
browse
printOut
fileOut
reorganize
alphabetize
update
add item...
rename...
remove' 
	lines: #(2 4 6 8)
	selections:
		#(findClass recent browseAllClasses buildSystemCategoryBrowser
		printOutSystemCategory fileOutSystemCategory
		editSystemCategories alphabetizeSystemCategories updateSystemCategories
		addSystemCategory renameSystemCategory removeSystemCategory )! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:17'!
updateSystemCategories
	"The class categories were changed in another browser. The receiver must 
	reorganize its lists based on these changes."

	self okToChange ifFalse: [^ self].
	self changed: #systemCategoryList! !


!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'!
indexIsOne
	"When used as a singleton list, index is always one"
	^ 1! !

!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'!
indexIsOne: value
	"When used as a singleton list, can't change it"

	^ self! !

!Browser methodsFor: 'system category list' stamp: 'stp 01/13/2000 12:25'!
selectCategoryForClass: theClass

	self systemCategoryListIndex: (self systemCategoryList indexOf: theClass category)
! !

!Browser methodsFor: 'system category list' stamp: 'md 3/3/2006 11:02'!
selectedEnvironment
	"Answer the name of the selected system category or nil."

	systemCategoryListIndex = 0 ifTrue: [^nil].
	^ Smalltalk! !

!Browser methodsFor: 'system category list'!
selectedSystemCategoryName
	"Answer the name of the selected system category or nil."

	systemCategoryListIndex = 0 ifTrue: [^nil].
	^self systemCategoryList at: systemCategoryListIndex! !

!Browser methodsFor: 'system category list'!
systemCategoryList
	"Answer the class categories modelled by the receiver."

	^systemOrganizer categories! !

!Browser methodsFor: 'system category list'!
systemCategoryListIndex
	"Answer the index of the selected class category."

	^systemCategoryListIndex! !

!Browser methodsFor: 'system category list' stamp: 'sd 11/20/2005 21:26'!
systemCategoryListIndex: anInteger 
	"Set the selected system category index to be anInteger. Update all other 
	selections to be deselected."

	systemCategoryListIndex := anInteger.
	classListIndex := 0.
	messageCategoryListIndex := 0.
	messageListIndex := 0.
	self editSelection: ( anInteger = 0 ifTrue: [#none] ifFalse: [#newClass]).
	metaClassIndicated := false.
	self setClassOrganizer.
	contents := nil.
	self changed: #systemCategorySelectionChanged.
	self changed: #systemCategoryListIndex.	"update my selection"
	self changed: #classList.
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #relabel.
	self contentsChanged! !

!Browser methodsFor: 'system category list' stamp: 'sd 11/20/2005 21:26'!
systemCategorySingleton

	| cat |
	cat := self selectedSystemCategoryName.
	^ cat ifNil: [Array new]
		ifNotNil: [Array with: cat]! !

!Browser methodsFor: 'system category list'!
toggleSystemCategoryListIndex: anInteger 
	"If anInteger is the current system category index, deselect it. Else make 
	it the current system category selection."

	self systemCategoryListIndex: 
		(systemCategoryListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:19'!
buildWith: builder
	"Create the ui for the browser"
	| windowSpec listSpec textSpec buttonSpec panelSpec max |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'System Browser'.
	windowSpec children: OrderedCollection new.

	max := self wantsOptionalButtons ifTrue:[0.43] ifFalse:[0.5].
	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #systemCategoryList; 
		getIndex: #systemCategoryListIndex; 
		setIndex: #systemCategoryListIndex:; 
		menu: #systemCategoryMenu:; 
		keyPress: #systemCatListKey:from:;
		frame: (0@0 corner: 0.25@max).
	windowSpec children add: listSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #classList; 
		getIndex: #classListIndex; 
		setIndex: #classListIndex:; 
		menu: #classListMenu:; 
		keyPress: #classListKey:from:;
		frame: (0.25@0 corner: 0.5@(max-0.1)).
	windowSpec children add: listSpec.

	panelSpec := builder pluggablePanelSpec new.
	panelSpec frame: (0.25@(max-0.1) corner: 0.5@max).
	panelSpec children: OrderedCollection new.
	windowSpec children addLast: panelSpec.

		buttonSpec := builder pluggableButtonSpec new.
		buttonSpec 
			model: self;
			label: 'instance'; 
			state: #instanceMessagesIndicated; 
			action: #indicateInstanceMessages;
			frame: (0@0 corner: 0.4@1).
		panelSpec children addLast: buttonSpec.

		buttonSpec := builder pluggableButtonSpec new.
		buttonSpec 
			model: self;
			label: '?'; 
			state: #classCommentIndicated; 
			action: #plusButtonHit;
			frame: (0.4@0 corner: 0.6@1).
		panelSpec children addLast: buttonSpec.

		buttonSpec := builder pluggableButtonSpec new.
		buttonSpec 
			model: self;
			label: 'class'; 
			state: #classMessagesIndicated; 
			action: #indicateClassMessages;
			frame: (0.6@0 corner: 1@1).
		panelSpec children addLast: buttonSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #messageCategoryList; 
		getIndex: #messageCategoryListIndex; 
		setIndex: #messageCategoryListIndex:; 
		menu: #messageCategoryMenu:; 
		keyPress: #arrowKey:from:;
		frame: (0.5@0 corner: 0.75@max).
	windowSpec children add: listSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #messageList; 
		getIndex: #messageListIndex; 
		setIndex: #messageListIndex:; 
		menu: #messageListMenu:shifted:; 
		keyPress: #messageListKey:from:;
		frame: (0.75@0 corner: 1@max).
	windowSpec children add: listSpec.

	self wantsOptionalButtons ifTrue:[
		panelSpec := self buildOptionalButtonsWith: builder.
		panelSpec frame: (0@0.43 corner: 1@0.5).
		windowSpec children add: panelSpec.
	].

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		getText: #contents; 
		setText: #contents:notifying:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0@0.5corner: 1@1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !


!Browser methodsFor: 'traits' stamp: 'al 1/9/2006 18:29'!
addSpecialMenu: aMenu
	aMenu addList: #(
		-
		('new class'				newClass)
		('new trait'				newTrait)
		-).
	self selectedClass notNil ifTrue: [
		aMenu addList: #(
			('add trait' addTrait)
			-) ].
	aMenu addList: #(-).
	^ aMenu! !

!Browser methodsFor: 'traits' stamp: 'al 1/9/2006 18:26'!
addTrait
	| input trait |
	input := UIManager default request: 'add trait'.
	input isEmptyOrNil ifFalse: [
		trait := Smalltalk classNamed: input.
		(trait isNil or: [trait isTrait not]) ifTrue: [
			^self inform: 'Input invalid. ' , input , ' does not exist or is not a trait'].
		self selectedClass addToComposition: trait.
		self contentsChanged].
! !

!Browser methodsFor: 'traits' stamp: 'md 3/3/2006 10:58'!
defineTrait: defString notifying: aController  

	| defTokens keywdIx envt oldTrait newTraitName trait |
	oldTrait _ self selectedClassOrMetaClass.
	defTokens _ defString findTokens: Character separators.
	keywdIx _ defTokens findFirst: [:x | x = 'category'].
	envt _ self selectedEnvironment.
	keywdIx _ defTokens findFirst: [:x | x = 'named:'].
	newTraitName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
	((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName])
		and: [envt includesKey: newTraitName asSymbol]) ifTrue:
			["Attempting to define new class/trait over existing one when
				not looking at the original one in this browser..."
			(self confirm: ((newTraitName , ' is an existing class/trait in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size))
				ifFalse: [^ false]].

	trait _ Compiler evaluate: defString notifying: aController logged: true.
	^(trait isKindOf: TraitBehavior)
		ifTrue: [
			self changed: #classList.
			self classListIndex: (self classList indexOf: trait baseTrait name).
			self clearUserEditFlag; editClass.
			true]
		ifFalse: [ false ]
! !

!Browser methodsFor: 'traits' stamp: 'al 4/24/2004 11:48'!
newClass
	(self selectedClassOrMetaClass notNil and: 
		[self selectedClassOrMetaClass isTrait]) ifTrue: [self classListIndex: 0].
	self editClass.
	editSelection _ #newClass.
	self contentsChanged! !

!Browser methodsFor: 'traits' stamp: 'al 4/24/2004 11:48'!
newTrait
	self classListIndex: 0.
	self editClass.
	editSelection _ #newTrait.
	self contentsChanged! !

!Browser methodsFor: 'traits' stamp: 'al 4/24/2004 11:49'!
removeNonLocalSelector: aSymbol
	| traits isAlias |
	traits _ self selectedClassOrMetaClass traitsProvidingSelector: aSymbol.
	isAlias _ self selectedClassOrMetaClass isLocalAliasSelector: aSymbol.
	isAlias
		ifTrue: [
			self assert: traits size = 1.
			self selectedClassOrMetaClass removeAlias: aSymbol of: traits first]
		ifFalse: [
			traits do: [:each |
				self selectedClassOrMetaClass addExclusionOf: aSymbol to: each ]]
	! !


!Browser methodsFor: 'user interface' stamp: 'hpt 9/30/2004 20:51'!
addModelItemsToWindowMenu: aMenu
	"Add model-related items to the window menu"
	super addModelItemsToWindowMenu: aMenu.
	SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self.! !


!Browser methodsFor: '*services-base' stamp: 'rr 6/28/2005 15:50'!
browseReference: ref
	self okToChange ifTrue: [
	self selectCategoryForClass: ref actualClass theNonMetaClass.
	self selectClass: ref actualClass theNonMetaClass .
	ref actualClass isMeta ifTrue: [self indicateClassMessages].
	self changed: #classSelectionChanged.
	self selectMessageCategoryNamed: ref category.
	self selectedMessageName: ref methodSymbol.
	]! !

!Browser methodsFor: '*services-base' stamp: 'rr 8/5/2005 10:03'!
methodReference 
	| cls sel |
	cls := self selectedClassOrMetaClass.
	sel := self selectedMessageName.
	cls isNil | sel isNil ifTrue: [^nil].
	^ MethodReference class: cls selector: sel! !

!Browser methodsFor: '*services-base' stamp: 'rr 3/10/2006 16:01'!
optionalButtonRow
	^ServiceGui browserButtonRow: self inlinedIn: super optionalButtonRow! !

!Browser methodsFor: '*services-base' stamp: 'rr 8/3/2005 17:16'!
selectReference: ref
	self browseReference: ref! !


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

Browser class
	instanceVariableNames: ''!

!Browser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 19:41'!
initialize
	"Browser initialize"

	RecentClasses := OrderedCollection new.
	self 
		registerInFlapsRegistry;
		registerInAppRegistry	! !

!Browser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 19:41'!
registerInAppRegistry
	"Register the receiver in the SystemBrowser AppRegistry"
	SystemBrowser register: self.! !

!Browser class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:32'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(#Browser #prototypicalToolWindow 'Browser' 'A Browser is a tool that allows you to view all the code of all the classes in the system' ) 
						forFlapNamed: 'Tools']! !

!Browser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 19:42'!
unload
	"Unload the receiver from global registries"

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


!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:27'!
fullOnClass: aClass 
	"Open a new full browser set to class."
	| brow |
	brow := self new.
	brow setClass: aClass selector: nil.
	^ self 
		openBrowserView: (brow openEditString: nil)
		label: 'System Browser'! !

!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
fullOnClass: aClass selector: aSelector
	"Open a new full browser set to class."

	| brow classToUse |
	classToUse := SystemBrowser default.
	brow := classToUse new.
	brow setClass: aClass selector: aSelector.
	^ classToUse 
		openBrowserView: (brow openEditString: nil)
		label: brow labelString! !

!Browser class methodsFor: 'instance creation' stamp: 'di 10/18/1999 22:03'!
new

	^super new systemOrganizer: SystemOrganization! !

!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
newOnCategory: aCategory
	"Browse the system category of the given name.  7/13/96 sw"

	"Browser newOnCategory: 'Interface-Browser'"

	| newBrowser catList |
	newBrowser := self new.
	catList := newBrowser systemCategoryList.
	newBrowser systemCategoryListIndex: 
		(catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']).
	^ self 
		openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: 'Classes in category ', aCategory
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:28'!
newOnClass: aClass 
	"Open a new class browser on this class."
	^ self newOnClass: aClass label: 'Class Browser: ', aClass name! !

!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
newOnClass: aClass label: aLabel
	"Open a new class browser on this class."
	| newBrowser |

	newBrowser := self new.
	newBrowser setClass: aClass selector: nil.
	^ self 
		openBrowserView: (newBrowser openOnClassWithEditString: nil)
		label: aLabel
! !

!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
newOnClass: aClass selector: aSymbol
	"Open a new class browser on this class."
	| newBrowser |

	newBrowser := self new.
	newBrowser setClass: aClass selector: aSymbol.
	^ self 
		openBrowserView: (newBrowser openOnClassWithEditString: nil)
		label: 'Class Browser: ', aClass name
! !

!Browser class methodsFor: 'instance creation' stamp: 'md 3/10/2006 21:46'!
open
	^self openBrowser

! !

!Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11'!
openBrowser
	"Create and schedule a BrowserView with default browser label. The
	view consists of five subviews, starting with the list view of system
	categories of SystemOrganization. The initial text view part is empty."

	| br |
	br := self new.
	^ self
		openBrowserView: (br openEditString: nil)
		label: br defaultBrowserTitle.

! !

!Browser class methodsFor: 'instance creation' stamp: 'sps 3/9/2004 15:54'!
openBrowserView: aBrowserView label: aString 
	"Schedule aBrowserView, labelling the view aString."

	aBrowserView isMorph
		ifTrue:  [(aBrowserView setLabel: aString) openInWorld]
		ifFalse: [aBrowserView label: aString.
				aBrowserView minimumSize: 300 @ 200.
				aBrowserView subViews do: [:each | each controller].
				aBrowserView controller open].

	^ aBrowserView model
! !

!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString
	"Create and schedule a message browser for the class, aBehavior, in 
	which the argument, aString, contains characters to be edited in the text 
	view. These characters are the source code for the message selector 
	aSymbol."

	| newBrowser |
	(newBrowser := self new) setClass: aBehavior selector: aSymbol.
	^ self openBrowserView: (newBrowser openMessageEditString: aString)
		label: newBrowser selectedClassOrMetaClassName , ' ' , newBrowser selectedMessageName
! !

!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
prototypicalToolWindow
	"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"

	| aWindow |
	aWindow := self new openAsMorphEditing: nil.
	aWindow setLabel: 'System Browser'; applyModelExtent.
	^ aWindow! !

!Browser class methodsFor: 'instance creation' stamp: 'nk 6/2/2004 12:55'!
systemOrganizer: anOrganizer

	^(super new)
		systemOrganizer: anOrganizer;
		yourself! !


!Browser class methodsFor: 'window color' stamp: 'sw 2/26/2002 13:46'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name  wording: 'Browser' brightColor: #lightGreen pastelColor: #paleGreen helpMessage: 'The standard "system browser" tool that allows you to browse through all the code in the system'! !
PluggableTextMorph subclass: #BrowserCommentTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!BrowserCommentTextMorph commentStamp: '<historical>' prior: 0!
I am a PluggableTextMorph that knows enough to make myself invisible when necessary.!


!BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:12'!
lowerPane
	"Answer the AlignmentMorph that I live beneath"
	^self valueOfProperty: #browserLowerPane! !

!BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:07'!
window
	^self owner ifNil: [ self valueOfProperty: #browserWindow ].! !


!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 13:41'!
hideOrShowPane
	(self model editSelection == #editClass)
		ifTrue: [ self showPane ]
		ifFalse: [ self hidePane ]! !

!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'sd 11/20/2005 21:26'!
hidePane
	| win |
	self window ifNotNilDo: [:window | window removePaneSplitters].
	
	self lowerPane ifNotNilDo:
		[ :lp | 
		lp layoutFrame bottomFraction: self layoutFrame bottomFraction.
		lp layoutFrame bottomOffset: SystemWindow borderWidth negated].
	win := self window ifNil: [ ^self ].
	self delete.
	win updatePanesFromSubmorphs.
	win addPaneSplitters! !

!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'sd 11/20/2005 21:26'!
showPane
	owner ifNil: [
		| win |
		win := self window ifNil: [ ^self ].
		win addMorph: self fullFrame: self layoutFrame.
		win updatePanesFromSubmorphs ].

	self lowerPane ifNotNilDo: [ :lp | lp layoutFrame bottomFraction: self layoutFrame topFraction ].
	
	self window ifNotNilDo: [:win | win addPaneSplitters]! !


!BrowserCommentTextMorph methodsFor: 'updating' stamp: 'nk 2/15/2004 14:11'!
noteNewOwner: win
	super noteNewOwner: win.
	self setProperty: #browserWindow toValue: win.
	win ifNil: [ ^self ].
	win setProperty: #browserClassCommentPane toValue: self.
	self setProperty: #browserLowerPane toValue: (win submorphThat: [ :m | m isAlignmentMorph and: [ m layoutFrame bottomFraction = 1 ]] ifNone: []).
! !

!BrowserCommentTextMorph methodsFor: 'updating' stamp: 'nk 2/15/2004 13:42'!
update: anAspect
	super update: anAspect.
	anAspect == #editSelection ifFalse: [ ^self ].
	self hideOrShowPane! !
ServiceProvider subclass: #BrowserProvider
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base-Providers'!
!BrowserProvider commentStamp: 'rr 7/10/2006 15:17' prior: 0!
I define the default categories of services dealing with browsing:
- the class category menu (service identifier: browserClassCategoryMenu)
- the class menu (browserClassMenu)
- the method category menu (browserMethodCategoryMenu)
- the browser method menu (browserMethodMenu)
- the browser button bar (browserButtonBar)
- the browser code pane/selection menu (browserCodePaneMenu)!


!BrowserProvider methodsFor: 'saved preferences'!
browserClassMenushortcut
	^ #(#'Shortcut for browserClassMenu:' '' 1000 )! !

!BrowserProvider methodsFor: 'saved preferences'!
browserMethodMenushortcut
	^ #(#'Shortcut for browserMethodMenu:' '' 1000 )! !


!BrowserProvider methodsFor: 'services' stamp: 'rr 10/23/2005 14:42'!
browser
	^ ServiceCategory  text: 'Browser' 
					button: 'browser' 
					description: 'The browser menus'! !

!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 18:59'!
browserButtonBar
	^ ServiceCategory 
		 text:'button bar'
		 button:'button'
		 description:'the browser button bar'! !

!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:00'!
browserClassCategoryMenu
	^ ServiceCategory 
		 text:'Class Category'
		 button:'class cat'
		 description:'The browser class category menu'! !

!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:00'!
browserClassMenu
	^ ServiceCategory 
		 text:'Class'
		 button:'class'
		 description:'The browser class menu'! !

!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:01'!
browserCodePaneMenu
	^ ServiceCategory text: 'Code Pane' 
						button: 'pane' 
						description: 'The browser code pane menu'! !

!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:00'!
browserMethodCategoryMenu
	^ ServiceCategory 
		 text:'Method Category'
		 button:'method cat'
		 description:'The browser method menu'! !

!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:01'!
browserMethodMenu
	^ ServiceCategory 
		 text:'Method'
		 button:'method'
		 description:'The browser method menu'! !

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

BrowserProvider class
	instanceVariableNames: ''!

!BrowserProvider class methodsFor: 'initialize-release' stamp: 'rr 1/10/2006 12:53'!
initialize
	ServiceRegistry current buildProvider: self new! !
TextRequestor subclass: #BrowserRequestor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base-Requestors'!
!BrowserRequestor commentStamp: 'rr 7/10/2006 15:24' prior: 0!
I am a requestor specialized to fetch information in a Browser.
I can ask a browser its selected class and selected method for example.
If the RB is installed too, I can also fetch ast nodes in the browser's selected
method.

I am the default requestor for CodeHolder and it's subclasses.

To be integrated with services, alternative browsers, such as the OmniBrowser and Whisker should define a specialized requestor subclassing this one. A few core messages would need to be redefined, such as getClass, getMessage ... to be adapted to the browser's data structures. 
Only a few of them have to be overridden, the majority of the requests rely on a few base ones.!


!BrowserRequestor methodsFor: 'initialize-release' stamp: 'rr 8/27/2005 15:52'!
browser: b
	self model: b! !


!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:43'!
getBrowser
	^ self getModel! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:51'!
getClass
	^ self getBrowser selectedClassOrMetaClass! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 9/11/2004 14:06'!
getInitializingExpressionForTheNewParameter
	^ FillInTheBlank request: 'enter default parameter code'
				 initialAnswer: '42'! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 1/9/2006 11:57'!
getNewSelectorName
	^ FillInTheBlank  request: 'enter the new selector name'
					initialAnswer: self getSelector! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 9/11/2004 16:50'!
getNewVariableName
	^ FillInTheBlank request: 'Enter the new variable name'
				initialAnswer: 'foo'! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/4/2005 14:41'!
getPackage
	self getSelector ifNil: [
			^ PackageInfo named:(
					self getClass ifNil: [self getSystemCategory] 
									ifNotNilDo: [:c | c category copyUpTo:  $-])].
	^ PackageOrganizer default 
			packageOfMethod: 
					(MethodReference class: self getClass
										selector: self getSelector)
			ifNone: [PackageInfo named: (self getClass category copyUpTo:  $-)] ! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:10'!
getPackageForCategory
	"answers a packageinfo for the current class category"
	^ PackageInfo named: self getClass theNonMetaClass category! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:10'!
getPackageForCategoryName
	"answers a packageinfo for the current class category"
	^  self getPackageForCategory packageName! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:10'!
getPackageName
	^ self getPackage packageName! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 1/9/2006 19:27'!
getPackageProvider
	| provs classes |
	provs := ServiceProvider registeredProviders.
	classes := self getPackage classes.
	^ classes detect: [:e | provs includes: e] ifNone: [ServiceProvider newProviderFor: self getPackageName]! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:52'!
getSelection
	self getBrowser selectedInterval ifEmpty: [^super getSelection].
	^ self getBrowser selectedInterval! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 1/9/2006 11:58'!
getSelector
	| s |
	s := self getBrowser selectedMessageName.
	^ s ifNil: [super getSelector] ifNotNil: [s]! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 10/11/2005 15:06'!
getSelectorCollection
	self caption: 'enter selector list'.
	^ self getSymbolCollection ! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:51'!
getSelectorName
	^ self getBrowser selectedMessageName! !

!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:51'!
getSystemCategory
	^ self getBrowser selectedSystemCategoryName ! !
GenericUrl subclass: #BrowserUrl
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!BrowserUrl commentStamp: '<historical>' prior: 0!
URLs that instruct a browser to do something.!


!BrowserUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'!
hasContents
	^true! !
PluggableCanvas subclass: #BufferedCanvas
	instanceVariableNames: 'remote previousVersion lastTick dirtyRect mirrorOfScreen'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!

!BufferedCanvas methodsFor: 'accessing' stamp: 'RAA 11/7/2000 13:04'!
clipRect
	
	^0@0 extent: 99999@99999
! !

!BufferedCanvas methodsFor: 'accessing' stamp: 'RAA 7/31/2000 22:36'!
extent

	^Display extent! !

!BufferedCanvas methodsFor: 'accessing' stamp: 'RAA 7/31/2000 22:36'!
origin

	^0@0! !


!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 15:04'!
asBufferedCanvas

	^self! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
checkIfTimeToDisplay

	remote backlog > 0 ifTrue: [^self].	"why bother if network full?"
	dirtyRect ifNil: [^self].
	self sendDeltas.
	lastTick := Time millisecondClockValue.

! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
connection: connection clipRect: newClipRect transform: transform remoteCanvas: remoteCanvas

	remote := remoteCanvas.
	lastTick := 0.
! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 15:06'!
purgeOutputQueue! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
sendDeltas
"
NebraskaDebug showStats: #sendDeltas
"
	| t deltas dirtyFraction |

	previousVersion ifNil: [
		previousVersion := Display deepCopy.
		remote 
			image: previousVersion 
			at: 0@0 
			sourceRect: previousVersion boundingBox 
			rule: Form paint.
		^remote forceToScreen: previousVersion boundingBox.
	].
	dirtyRect ifNil: [^self].
	t := Time millisecondClockValue.
	dirtyFraction := dirtyRect area / previousVersion boundingBox area roundTo: 0.0001.

	deltas := mirrorOfScreen deltaFrom: (previousVersion copy: dirtyRect) at: dirtyRect origin.
	previousVersion := mirrorOfScreen.
	mirrorOfScreen := nil.

	remote 
		image: deltas at: dirtyRect origin sourceRect: deltas boundingBox rule: Form reverse;
		forceToScreen: dirtyRect.

	t := Time millisecondClockValue - t.
	NebraskaDebug at: #sendDeltas add: {t. dirtyFraction. deltas boundingBox}.
	dirtyRect := nil.
! !


!BufferedCanvas methodsFor: 'drawing-general' stamp: 'RAA 7/31/2000 20:32'!
drawMorph: x
! !


!BufferedCanvas methodsFor: 'drawing-support' stamp: 'RAA 7/31/2000 20:44'!
clipBy: aRectangle during: aBlock
! !


!BufferedCanvas methodsFor: 'Nebraska/embeddedWorlds' stamp: 'RAA 11/7/2000 13:54'!
displayIsFullyUpdated

	self checkIfTimeToDisplay! !


!BufferedCanvas methodsFor: 'other' stamp: 'sd 11/20/2005 21:25'!
forceToScreen: rect

	mirrorOfScreen ifNil: [
		mirrorOfScreen := (previousVersion ifNil: [Display]) deepCopy.
	].
	mirrorOfScreen copy: rect from: rect origin in: Display rule: Form over.
	dirtyRect := dirtyRect ifNil: [rect] ifNotNil: [dirtyRect merge: rect].
! !
Switch subclass: #Button
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Menus'!
!Button commentStamp: '<historical>' prior: 0!
I am a Switch that turns off automatically after being turned on, that is, I act like a push-button switch.!


!Button methodsFor: 'state'!
turnOff
	"Sets the state of the receiver to 'off'. The off action of the receiver is not  
	executed."

	on _ false! !

!Button methodsFor: 'state'!
turnOn
	"The receiver remains in the 'off' state'."

	self doAction: onAction.
	self doAction: offAction! !

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

Button class
	instanceVariableNames: ''!

!Button class methodsFor: 'instance creation'!
newOn 
	"Refer to the comment in Switch|newOn."

	self error: 'Buttons cannot be created in the on state'.
	^nil! !
SymbolListType subclass: #ButtonPhaseType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!

!ButtonPhaseType methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	self vocabularyName: #ButtonPhase.
	symbols := #(buttonDown whilePressed buttonUp)! !


!ButtonPhaseType methodsFor: 'queries' stamp: 'mir 7/15/2004 10:35'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^true! !


!ButtonPhaseType 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.806 1.0 0.806)	! !
Object subclass: #ButtonProperties
	instanceVariableNames: 'target actionSelector arguments actWhen wantsRolloverIndicator mouseDownTime nextTimeToFire visibleMorph delayBetweenFirings mouseOverHaloWidth mouseOverHaloColor mouseDownHaloWidth mouseDownHaloColor stateCostumes currentLook'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Buttons'!
!ButtonProperties commentStamp: '<historical>' prior: 0!
ButtonProperties test1

ButtonProperties test2

ButtonProperties test3

!


!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 09:43'!
actWhen

	^ actWhen! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 09:43'!
actWhen: condition

	(#(buttonDown mouseDown) includes: condition) ifTrue: [ actWhen _ #mouseDown ].
	(#(buttonUp mouseUp) includes: condition) ifTrue: [ actWhen _ #mouseUp ].
	(#(whilePressed mouseStillDown) includes: condition) ifTrue: [ actWhen _ #mouseStillDown ].
	self setEventHandlers: true.! !

!ButtonProperties methodsFor: 'accessing'!
actionSelector

	^ actionSelector
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 08:46'!
actionSelector: aSymbolOrString

	aSymbolOrString isEmptyOrNil ifTrue: [^actionSelector _ nil].
	aSymbolOrString = 'nil' ifTrue: [^actionSelector _ nil].
	actionSelector _ aSymbolOrString asSymbol.
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:35'!
addTextToButton: aStringOrText

	| tm existing |

	existing _ self currentTextMorphsInButton.
	existing do: [ :x | x delete].
	aStringOrText ifNil: [^self].
	tm _ TextMorph new contents: aStringOrText.
	tm 
		fullBounds;
		lock;
		align: tm center with: visibleMorph center;
		setProperty: #textAddedByButtonProperties toValue: true;
		setToAdhereToEdge: #center.
	"maybe the user would like personal control here"
	"visibleMorph extent: (tm extent * 1.5) rounded."
	visibleMorph addMorphFront: tm.
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 07:35'!
adjustPositionsAfterSizeChange

	"re-center label, etc??"! !

!ButtonProperties methodsFor: 'accessing'!
arguments

	^ arguments
! !

!ButtonProperties methodsFor: 'accessing'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 11:40'!
bringUpToDate

	self establishEtoyLabelWording
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:18'!
currentLook

	^currentLook ifNil: [currentLook _ #normal]! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:18'!
currentTextInButton

	| existing |

	existing _ self currentTextMorphsInButton.
	existing isEmpty ifTrue: [^nil].
	^existing first
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:17'!
currentTextMorphsInButton

	^visibleMorph submorphsSatisfying: [ :x | 
		x hasProperty: #textAddedByButtonProperties
	]
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'yo 11/30/2005 14:20'!
establishEtoyLabelWording
	"Set the label wording, unless it has already been manually edited"

	| itsName |

	self isTileScriptingElement ifFalse: [^self].
	itsName _ target externalName.
	self addTextToButton: itsName, ' ', arguments first.
	visibleMorph setBalloonText: 
		('click to run the script "{1}" in player named "{2}"' translated format: {arguments first. itsName}).
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 19:01'!
figureOutScriptSelector

	self halt! !

!ButtonProperties methodsFor: 'accessing' stamp: 'nk 8/29/2004 17:16'!
isTileScriptingElement

	actionSelector == #runScript: ifFalse: [^false].
	arguments isEmptyOrNil ifTrue: [^false].
	^target isPlayerLike! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:19'!
lockAnyText

	self currentTextMorphsInButton do: [ :x | x lock: true].! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:15'!
mouseDownHaloColor

	^mouseDownHaloColor! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:15'!
mouseDownHaloColor: x

	mouseDownHaloColor _ x! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'!
mouseDownHaloWidth

	^mouseDownHaloWidth! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'!
mouseDownHaloWidth: x

	mouseDownHaloWidth _ x! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:43'!
mouseDownLook: aFormOrMorph

	self setLook: #mouseDown to: aFormOrMorph
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:43'!
mouseEnterLook: aFormOrMorph

	self setLook: #mouseEnter to: aFormOrMorph
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:16'!
mouseOverHaloColor

	^mouseOverHaloColor! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:16'!
mouseOverHaloColor: x

	mouseOverHaloColor _ x! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:30'!
mouseOverHaloWidth

	^mouseOverHaloWidth! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'!
mouseOverHaloWidth: x

	mouseOverHaloWidth _ x! !

!ButtonProperties methodsFor: 'accessing' stamp: 'gm 2/22/2003 14:53'!
privateSetLook: aSymbol to: aFormOrMorph 
	| f |
	f := (aFormOrMorph isForm) 
				ifTrue: [aFormOrMorph]
				ifFalse: [aFormOrMorph imageForm].
	self stateCostumes at: aSymbol put: f! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/10/2001 13:57'!
setEventHandlers: enabled

	enabled ifTrue: [
		visibleMorph on: #mouseDown send: #mouseDown: to: self.
		visibleMorph on: #mouseStillDown send: #mouseStillDown: to: self.
		visibleMorph on: #mouseUp send: #mouseUp: to: self.
		visibleMorph on: #mouseEnter send: #mouseEnter: to: self.
		visibleMorph on: #mouseLeave send: #mouseLeave: to: self.
	] ifFalse: [
		#(mouseDown mouseStillDown mouseUp mouseEnter mouseLeave) do: [ :sel |
			visibleMorph on: sel send: nil to: nil
		].
	].
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:14'!
setLook: aSymbol to: aFormOrMorph

	(self stateCostumes includesKey: #normal) ifFalse: [
		self privateSetLook: #normal to: visibleMorph.
	].
	self privateSetLook: aSymbol to: aFormOrMorph.
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:30'!
stateCostumes

	^stateCostumes ifNil: [stateCostumes _ Dictionary new]! !

!ButtonProperties methodsFor: 'accessing'!
target

	^ target
! !

!ButtonProperties methodsFor: 'accessing'!
target: anObject

	target _ anObject
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:19'!
unlockAnyText

	self currentTextMorphsInButton do: [ :x | x lock: false].! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 15:43'!
visibleMorph: x

	visibleMorph ifNotNil: [self setEventHandlers: false].
	visibleMorph _ x.
	visibleMorph ifNotNil: [self setEventHandlers: true].
! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 09:09'!
wantsRolloverIndicator

	^wantsRolloverIndicator ifNil: [false]! !

!ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/10/2001 13:59'!
wantsRolloverIndicator: aBoolean

	wantsRolloverIndicator _ aBoolean.
	wantsRolloverIndicator ifTrue: [
		self setEventHandlers: true.
	].! !


!ButtonProperties methodsFor: 'copying' stamp: 'jm 7/28/97 11:52'!
updateReferencesUsing: aDictionary
	"If the arguments array points at a morph we are copying, then point at the new copy.  And also copies the array, which is important!!"

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !

!ButtonProperties methodsFor: 'copying' stamp: 'tk 1/6/1999 17:55'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!ButtonProperties methodsFor: 'copying' stamp: 'RAA 3/16/2001 08:21'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		a Symbol"
"arguments _ arguments.		All weakly copied"
actWhen _ actWhen veryDeepCopyWith: deepCopier.
"oldColor _ oldColor veryDeepCopyWith: deepCopier."
visibleMorph _ visibleMorph.	"I guess this will have been copied already if needed"
delayBetweenFirings _ delayBetweenFirings.
mouseDownHaloColor _ mouseDownHaloColor.
stateCostumes _ stateCostumes veryDeepCopyWith: deepCopier.
currentLook _ currentLook.! !


!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:28'!
addMouseOverHalo

	self wantsRolloverIndicator ifTrue: [
		visibleMorph 
			addMouseActionIndicatorsWidth: mouseOverHaloWidth 
			color: mouseOverHaloColor.
	].
! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 09:29'!
delayBetweenFirings

	^delayBetweenFirings! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 09:55'!
delayBetweenFirings: millisecondsOrNil

	delayBetweenFirings _ millisecondsOrNil! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/15/2001 09:21'!
displayCostume: aSymbol

	self currentLook == aSymbol ifTrue: [^true].
	self stateCostumes at: aSymbol ifPresent: [ :aForm |
		currentLook _ aSymbol.
		visibleMorph wearCostume: aForm.
		^true
	].
	^false
! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 08:58'!
doButtonAction
	
	self doButtonAction: nil! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 17:08'!
doButtonAction: evt

	| arity |

	target ifNil: [^self].
	actionSelector ifNil: [^self].
	arguments ifNil: [arguments _ #()].
	Cursor normal showWhile: [
		arity _ actionSelector numArgs.
		arity = arguments size ifTrue: [
			target perform: actionSelector withArguments: arguments
		].
		arity = (arguments size + 1) ifTrue: [
			target perform: actionSelector withArguments: {evt},arguments
		].
		arity = (arguments size + 2) ifTrue: [
			target perform: actionSelector withArguments: {evt. visibleMorph},arguments
		].
	]! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 19:01'!
editButtonsScript: evt
	"The user has touched my Scriptor halo-handle.  Bring up a Scriptor on the script of the button."

	| cardsPasteUp cardsPlayer anEditor scriptSelector |

	cardsPasteUp _ self pasteUpMorph.
	(cardsPlayer _ cardsPasteUp assuredPlayer) assureUniClass.
	scriptSelector _ self figureOutScriptSelector.
	scriptSelector ifNil: [
		scriptSelector _ cardsPasteUp scriptSelectorToTriggerFor: self.
		anEditor _ cardsPlayer newTextualScriptorFor: scriptSelector.
		evt hand attachMorph: anEditor.
		^self
	].

	(cardsPlayer class selectors includes: scriptSelector) ifTrue: [
		anEditor _ cardsPlayer scriptEditorFor: scriptSelector.
		evt hand attachMorph: anEditor.
		^self
	].
	"Method somehow got removed; I guess we start aftresh"
	scriptSelector _ nil.
	^ self editButtonsScript! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 18:40'!
mouseDown: evt

	self displayCostume: #mouseDown.
	mouseDownTime _ Time millisecondClockValue.
	nextTimeToFire _ nil.
	delayBetweenFirings ifNotNil: [
		nextTimeToFire _ mouseDownTime + delayBetweenFirings.
	].
	self wantsRolloverIndicator ifTrue: [
		visibleMorph 
			addMouseActionIndicatorsWidth: mouseDownHaloWidth 
			color: mouseDownHaloColor.
	].
	actWhen == #mouseDown ifFalse: [^self].
	(visibleMorph containsPoint: evt cursorPoint) ifFalse: [^self].
	self doButtonAction: evt.

"=====

	aMorph .

	now _ Time millisecondClockValue.
	oldColor _ color. 
	actWhen == #buttonDown
		ifTrue: [self doButtonAction]
		ifFalse: [	self updateVisualState: evt; refreshWorld].
	dt _ Time millisecondClockValue - now max: 0.
	dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait].
	self mouseStillDown: evt.
====="! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:29'!
mouseEnter: evt

	self displayCostume: #mouseEnter.
	self addMouseOverHalo.
! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 18:39'!
mouseLeave: evt

	self displayCostume: #normal.
	visibleMorph deleteAnyMouseActionIndicators.
! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 07:57'!
mouseMove: evt

	actWhen == #mouseDown ifTrue: [^ self].
	self updateVisualState: evt.! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 08:57'!
mouseStillDown: evt

	(visibleMorph containsPoint: evt cursorPoint) ifFalse: [^self].
	nextTimeToFire ifNil: [^self].
	nextTimeToFire <= Time millisecondClockValue ifTrue: [
		self doButtonAction: evt.
		nextTimeToFire _ Time millisecondClockValue + self delayBetweenFirings.
		^self
	].
! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:29'!
mouseUp: evt

	(self displayCostume: #mouseEnter) ifFalse: [self displayCostume: #normal].
	self addMouseOverHalo.
! !

!ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 12:27'!
replaceVisibleMorph: aNewMorph

	| old oldOwner oldText |

	old _ visibleMorph.
	oldText _ self currentTextInButton.
	self visibleMorph: nil.
	old buttonProperties: nil.
	aNewMorph buttonProperties: self.
	self visibleMorph: aNewMorph.
	self addTextToButton: oldText.
	oldOwner _ old owner ifNil: [^self].
	oldOwner replaceSubmorph: old by: aNewMorph.! !


!ButtonProperties methodsFor: 'initialization' stamp: 'ar 3/17/2001 20:12'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	target _ target adaptedToWorld: aWorld.! !

!ButtonProperties methodsFor: 'initialization' stamp: 'RAA 3/9/2001 09:47'!
initialize

	wantsRolloverIndicator _ false.
	delayBetweenFirings _ nil.
	mouseOverHaloWidth _ 10.
	mouseOverHaloColor _ Color blue alpha: 0.3.
	mouseDownHaloWidth _ 15.
	mouseDownHaloColor _ Color blue alpha: 0.7.
	arguments _ #().! !


!ButtonProperties methodsFor: 'menu' stamp: 'yo 3/16/2005 20:58'!
setActWhen

	| selections |
	selections _ #(mouseDown mouseUp mouseStillDown).
	actWhen _ (SelectionMenu labels: (selections collect: [:t | t translated]) selections: selections)
		startUpWithCaption: 'Choose one of the following conditions' translated
! !

!ButtonProperties methodsFor: 'menu' stamp: 'yo 3/16/2005 20:53'!
setActionSelector

	| newSel |
	newSel _ FillInTheBlank
		request:
'Please type the selector to be sent to
the target when this button is pressed' translated
		initialAnswer: actionSelector.
	newSel isEmpty ifFalse: [self actionSelector: newSel].
! !

!ButtonProperties methodsFor: 'menu' stamp: 'yo 3/14/2005 13:07'!
setArguments

	| s newArgs newArgsArray |
	s _ WriteStream on: ''.
	arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
	newArgs _ FillInTheBlank
		request:
'Please type the arguments to be sent to the target
when this button is pressed separated by periods' translated
		initialAnswer: s contents.
	newArgs isEmpty ifFalse: [
		newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.
		self arguments: newArgsArray].
! !

!ButtonProperties methodsFor: 'menu'!
setLabel

	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Please a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self label: newLabel].
! !

!ButtonProperties methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'!
setPageSound: event

	^ target menuPageSoundFor: self event: event! !

!ButtonProperties methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'!
setPageVisual: event

	^ target menuPageVisualFor: self event: event! !

!ButtonProperties methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:52'!
setTarget: evt 
	| rootMorphs |
	rootMorphs := self world rootMorphsAt: evt hand targetOffset.
	target := rootMorphs size > 1 
		ifTrue: [rootMorphs second]
		ifFalse: [nil]! !


!ButtonProperties methodsFor: 'visual properties' stamp: 'RAA 3/8/2001 14:24'!
updateVisualState: evt
	
"	oldColor ifNil: [^self].

	self color: 
		((self containsPoint: evt cursorPoint)
			ifTrue: [oldColor mixed: 1/2 with: Color white]
			ifFalse: [oldColor])"! !

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

ButtonProperties class
	instanceVariableNames: ''!

!ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:29'!
ellipticalButtonWithText: aStringOrText

	| m prop |

	m _ EllipseMorph new.
	prop _ m ensuredButtonProperties.
	prop
		target: #(1 2 3);
		actionSelector: #inspect;
		actWhen: #mouseUp;
		addTextToButton: aStringOrText;
		wantsRolloverIndicator: true.
	^m! !

!ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 08:31'!
test1

	| m prop |
	m _ EllipseMorph new.
	prop _ m ensuredButtonProperties.
	prop
		target: #(1 2 3);
		actionSelector: #inspect;
		actWhen: #mouseUp.
	m openInWorld.! !

!ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 08:41'!
test2

	(self ellipticalButtonWithText: 'Hello world') openInWorld.! !

!ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
test3

	| m |

	(m _ self ellipticalButtonWithText: 'Hello world') openInWorld.
	m ensuredButtonProperties
		target: Beeper;
		actionSelector: #beep;
		delayBetweenFirings: 1000.! !


!ButtonProperties class methodsFor: 'printing' stamp: 'sw 2/16/98 01:31'!
defaultNameStemForInstances
	^ 'button'! !
WidgetStub subclass: #ButtonStub
	instanceVariableNames: 'enabled'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!ButtonStub methodsFor: 'events' stamp: 'cwp 4/22/2005 22:01'!
eventAccessors
	^ #(label color state enabled)! !


!ButtonStub methodsFor: 'simulating' stamp: 'stephaneducasse 2/3/2006 22:32'!
click
	| action |
	action := spec action.
	action isSymbol
		ifTrue: [self model perform: action]
		ifFalse: [action value]! !

!ButtonStub methodsFor: 'simulating' stamp: 'cwp 4/22/2005 22:44'!
color
	^ self model perform: spec color! !

!ButtonStub methodsFor: 'simulating' stamp: 'cwp 7/14/2006 11:09'!
isEnabled
	enabled ifNil: [enabled _ spec model perform: spec enabled].
	^ enabled! !
ArrayedCollection variableByteSubclass: #ByteArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!ByteArray commentStamp: '<historical>' prior: 0!
I represent an ArrayedCollection whose elements are integers between 0 and 255.
!


!ByteArray methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:35'!
asWideString

	^ WideString fromByteArray: self.
! !

!ByteArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'!
atAllPut: value
	"Fill the receiver with the given value"

	<primitive: 145>
	super atAllPut: value! !

!ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'!
byteAt: index
	<primitive: 60>
	^self at: index! !

!ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'!
byteAt: index put: value
	<primitive: 61>
	^self at: index put: value! !

!ByteArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'!
byteSize
	^self size! !

!ByteArray methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'!
bytesPerElement
	"Number of bytes in each item.  This multiplied by (self size)*8 gives the number of bits stored."
	^ 1! !


!ByteArray methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'!
hash
	"#hash is implemented, because #= is implemented"

	^self class
		hashBytes: self
		startingWith: self species hash! !


!ByteArray methodsFor: 'converting' stamp: 'sma 5/12/2000 17:35'!
asByteArray
	^ self! !

!ByteArray methodsFor: 'converting'!
asString
	"Convert to a String with Characters for each byte.
	Fast code uses primitive that avoids character conversion"

	^ (String new: self size) replaceFrom: 1 to: self size with: self! !


!ByteArray methodsFor: 'platform independent access' stamp: 'jmb 12/3/2004 14:54'!
doubleAt: index bigEndian: bool 
	"Return a 64 bit float starting from the given byte index"
	| w1 w2 dbl |
	w1 _ self unsignedLongAt: index bigEndian: bool.
	w2 _ self unsignedLongAt: index + 4 bigEndian: bool.
	dbl _ Float new: 2. 
	bool
		ifTrue: [dbl basicAt: 1 put: w1.
			dbl basicAt: 2 put: w2]
		ifFalse: [dbl basicAt: 1 put: w2.
			dbl basicAt: 2 put: w1].
	^ dbl! !

!ByteArray methodsFor: 'platform independent access' stamp: 'jmb 12/3/2004 14:54'!
doubleAt: index put: value bigEndian: bool 
	"Store a 64 bit float starting from the given byte index"
	| w1 w2 |
	bool
		ifTrue: [w1 _ value basicAt: 1.
			w2 _ value basicAt: 2]
		ifFalse: [w1 _ value basicAt: 2.
			w2 _ value basicAt: 1]. 
	self unsignedLongAt: index put: w1 bigEndian: bool.
	self unsignedLongAt: index + 4 put: w2 bigEndian: bool.
	^ value! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:44'!
longAt: index bigEndian: aBool
	"Return a 32bit integer quantity starting from the given byte index"
	| b0 b1 b2 w h |
	aBool ifTrue:[
		b0 _ self at: index.
		b1 _ self at: index+1.
		b2 _ self at: index+2.
		w _ self at: index+3.
	] ifFalse:[
		w _ self at: index.
		b2 _ self at: index+1.
		b1 _ self at: index+2.
		b0 _ self at: index+3.
	].
	"Minimize LargeInteger arithmetic"
	h _ ((b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80) bitShift: 8) + b1.
	b2 = 0 ifFalse:[w _ (b2 bitShift: 8) + w].
	h = 0 ifFalse:[w _ (h bitShift: 16) + w].
	^w! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 8/2/2003 19:29'!
longAt: index put: value bigEndian: aBool
	"Return a 32bit integer quantity starting from the given byte index"
	| b0 b1 b2 b3 |
	b0 _ value bitShift: -24.
	b0 _ (b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80).
	b0 < 0 ifTrue:[b0 := 256 + b0].
	b1 _ (value bitShift: -16) bitAnd: 255.
	b2 _ (value bitShift: -8) bitAnd: 255.
	b3 _ value bitAnd: 255.
	aBool ifTrue:[
		self at: index put: b0.
		self at: index+1 put: b1.
		self at: index+2 put: b2.
		self at: index+3 put: b3.
	] ifFalse:[
		self at: index put: b3.
		self at: index+1 put: b2.
		self at: index+2 put: b1.
		self at: index+3 put: b0.
	].
	^value! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:57'!
shortAt: index bigEndian: aBool
	"Return a 16 bit integer quantity starting from the given byte index"
	| uShort |
	uShort _ self unsignedShortAt: index bigEndian: aBool.
	^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/3/1998 14:20'!
shortAt: index put: value bigEndian: aBool
	"Store a 16 bit integer quantity starting from the given byte index"
	self unsignedShortAt: index put: (value bitAnd: 16r7FFF) - (value bitAnd: -16r8000) bigEndian: aBool.
	^value! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:49'!
unsignedLongAt: index bigEndian: aBool
	"Return a 32bit unsigned integer quantity starting from the given byte index"
	| b0 b1 b2 w |
	aBool ifTrue:[
		b0 _ self at: index.
		b1 _ self at: index+1.
		b2 _ self at: index+2.
		w _ self at: index+3.
	] ifFalse:[
		w _ self at: index.
		b2 _ self at: index+1.
		b1 _ self at: index+2.
		b0 _ self at: index+3.
	].
	"Minimize LargeInteger arithmetic"
	b2 = 0 ifFalse:[w _ (b2 bitShift: 8) + w].
	b1 = 0 ifFalse:[w _ (b1 bitShift: 16) + w].
	b0 = 0 ifFalse:[w _ (b0 bitShift: 24) + w].
	^w! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:49'!
unsignedLongAt: index put: value bigEndian: aBool
	"Store a 32bit unsigned integer quantity starting from the given byte index"
	| b0 b1 b2 b3 |
	b0 _ value bitShift: -24.
	b1 _ (value bitShift: -16) bitAnd: 255.
	b2 _ (value bitShift: -8) bitAnd: 255.
	b3 _ value bitAnd: 255.
	aBool ifTrue:[
		self at: index put: b0.
		self at: index+1 put: b1.
		self at: index+2 put: b2.
		self at: index+3 put: b3.
	] ifFalse:[
		self at: index put: b3.
		self at: index+1 put: b2.
		self at: index+2 put: b1.
		self at: index+3 put: b0.
	].
	^value! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:51'!
unsignedShortAt: index bigEndian: aBool
	"Return a 16 bit unsigned integer quantity starting from the given byte index"
	^aBool 
		ifTrue:[((self at: index) bitShift: 8) + (self at: index+1)]
		ifFalse:[((self at: index+1) bitShift: 8) + (self at: index)].! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:53'!
unsignedShortAt: index put: value bigEndian: aBool
	"Store a 16 bit unsigned integer quantity starting from the given byte index"
	aBool ifTrue:[
		self at: index put: (value bitShift: -8).
		self at: index+1 put: (value bitAnd: 255).
	] ifFalse:[
		self at: index+1 put: (value bitShift: -8).
		self at: index put: (value bitAnd: 255).
	].
	^value! !


!ByteArray methodsFor: 'zip archive' stamp: 'nk 8/21/2004 15:23'!
lastIndexOfPKSignature: aSignature
	"Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found"
	| a b c d |
	a _ aSignature first.
	b _ aSignature second.
	c _ aSignature third.
	d _ aSignature fourth.
	(self size - 3) to: 1 by: -1 do: [ :i |
		(((self at: i) = a)
			and: [ ((self at: i + 1) = b)
				and: [ ((self at: i + 2) = c)
					and: [ ((self at: i + 3) = d) ]]])
						ifTrue: [ ^i ]
	].
	^0! !



!ByteArray methodsFor: 'private' stamp: 'ar 1/28/2000 17:45'!
asByteArrayPointer
	"Return a ByteArray describing a pointer to the contents of the receiver."
	^self shouldNotImplement! !

!ByteArray methodsFor: 'private'!
defaultElement

	^0! !

!ByteArray methodsFor: 'private'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

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

ByteArray class
	instanceVariableNames: ''!

!ByteArray class methodsFor: 'byte based hash' stamp: 'SqR 8/21/2002 16:21'!
hashBytes: aByteArray startingWith: speciesHash
	"Answer the hash of a byte-indexed collection,
	using speciesHash as the initial value.
	See SmallInteger>>hashMultiply.

	The primitive should be renamed at a
	suitable point in the future"

	| byteArraySize hash low |
	<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>

	self var: #aHash declareC: 'int speciesHash'.
	self var: #aByteArray declareC: 'unsigned char *aByteArray'.

	byteArraySize _ aByteArray size.
	hash _ speciesHash bitAnd: 16rFFFFFFF.
	1 to: byteArraySize do: [:pos |
		hash _ hash + (aByteArray basicAt: pos).
		"Begin hashMultiply"
		low _ hash bitAnd: 16383.
		hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
	].
	^ hash! !
TestCase subclass: #ByteArrayBugz
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Bugs'!

!ByteArrayBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:28'!
testByteArrayLongAt
	| ba value |
	ba := ByteArray new: 4.
	value := -1.
	self shouldnt:[ba longAt: 1 put: value bigEndian: true] raise: Error.
	self assert: (ba longAt: 1 bigEndian: true) = value.
	self shouldnt:[ba longAt: 1 put: value bigEndian: false] raise: Error.
	self assert: (ba longAt: 1 bigEndian: false) = value.
! !
FlattenEncoder subclass: #ByteEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Filters'!

!ByteEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 22:45'!
numberDefaultBase
	^self class numberDefaultBase.
! !


!ByteEncoder methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:33'!
elementSeparator
	^' '.! !


!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 15:17'!
cr
	^target cr.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'nk 12/31/2003 16:01'!
nextPut: encodedObject
	"pass through for stream compatibility"
	^target nextPut: encodedObject.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'nk 12/31/2003 16:00'!
nextPutAll: encodedObject
	"pass through for stream compatibility"
	^target nextPutAll: encodedObject.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 00:48'!
print:encodedObject
	^target write:encodedObject.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 02:18'!
space
	^target space.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 15:16'!
tab
	^target tab.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 20:51'!
writeArray:aCollection
	^self writeArrayedCollection:aCollection.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 20:53'!
writeAssocation:anAssociation
	^self write:anAssociation key; print:'->'; write:anAssociation value.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 02:31'!
writeCollection:aCollection
	^self print:aCollection class name; 
		writeCollectionContents:aCollection.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 02:31'!
writeCollectionContents:aCollection
	self print:'( '.
		super writeCollectionContents:aCollection.
		self print:')'.
	^self.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 22:44'!
writeNumber:aNumber
	^self writeNumber:aNumber base:self numberDefaultBase.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 00:03'!
writeNumber:aNumber base:aBase
	^aNumber byteEncode:self base:aBase.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:25'!
writeObject:anObject
	^self print:anObject stringRepresentation.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 00:21'!
writeString:aString
	^aString encodeDoublingQuoteOn:self.! !

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

ByteEncoder class
	instanceVariableNames: ''!

!ByteEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 01:18'!
defaultTarget
	^WriteStream on:(String new: 40000).! !

!ByteEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:41'!
filterSelector
	^#byteEncode:.! !

!ByteEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 22:46'!
numberDefaultBase
	^10.
! !
String variableByteSubclass: #ByteString
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Strings'!
!ByteString commentStamp: '<historical>' prior: 0!
This class represents the array of 8 bit wide characters.
!


!ByteString methodsFor: 'accessing' stamp: 'yo 8/26/2002 20:33'!
at: index 
	"Primitive. Answer the Character stored in the field of the receiver
	indexed by the argument. Fail if the index argument is not an Integer or
	is out of bounds. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 63>
	^ Character value: (super at: index)! !

!ByteString methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:33'!
at: index put: aCharacter
	"Primitive. Store the Character in the field of the receiver indicated by
	the index. Fail if the index is not an Integer or is out of bounds, or if
	the argument is not a Character. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 64>
	aCharacter isCharacter 
		ifFalse:[^self errorImproperStore].
	aCharacter isOctetCharacter ifFalse:[
		"Convert to WideString"
		self becomeForward: (WideString from: self).
		^self at: index put: aCharacter.
	].
	index isInteger
		ifTrue: [self errorSubscriptBounds: index]
		ifFalse: [self errorNonIntegerIndex]! !

!ByteString methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'!
byteAt: index
	<primitive: 60>
	^(self at: index) asciiValue! !

!ByteString methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'!
byteAt: index put: value
	<primitive: 61>
	self at: index put: value asCharacter.
	^value! !

!ByteString methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'!
byteSize
	^self size! !

!ByteString methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:33'!
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>
	replacement class == WideString ifTrue: [
		self becomeForward: (WideString from: self).
	]. 

	super replaceFrom: start to: stop with: replacement startingAt: repStart.
! !


!ByteString methodsFor: 'comparing' stamp: 'bf 8/31/2004 13:50'!
findSubstring: key in: body startingAt: start matchTable: matchTable
	"Answer the index in the string body at which the substring key first occurs, at or beyond start.  The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches.  If no match is found, zero will be returned.

	The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter."
	| index |
	<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
	self var: #key declareC: 'unsigned char *key'.
	self var: #body declareC: 'unsigned char *body'.
	self var: #matchTable declareC: 'unsigned char *matchTable'.

	key size = 0 ifTrue: [^ 0].
	start to: body size - key size + 1 do:
		[:startIndex |
		index _ 1.
			[(matchTable at: (body at: startIndex+index-1) asciiValue + 1)
				= (matchTable at: (key at: index) asciiValue + 1)]
				whileTrue:
				[index = key size ifTrue: [^ startIndex].
				index _ index+1]].
	^ 0
"
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0
' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0
' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7
"! !


!ByteString methodsFor: 'converting' stamp: 'ar 4/10/2005 17:20'!
asByteArray
	| ba sz |
	sz := self byteSize.
	ba := ByteArray new: sz.
	ba replaceFrom: 1 to: sz with: self startingAt: 1.
	^ba! !

!ByteString methodsFor: 'converting' stamp: 'yo 8/28/2002 16:52'!
asOctetString

	^ self.
! !

!ByteString methodsFor: 'converting' stamp: 'yo 11/11/2002 12:20'!
convertFromCompoundText

	| readStream writeStream converter |
	readStream _ self readStream.
	writeStream _ String new writeStream.
	converter _ CompoundTextConverter new.
	converter ifNil: [^ self].
	[readStream atEnd] whileFalse: [
		writeStream nextPut: (converter nextFromStream: readStream)].
	^ writeStream contents
! !

!ByteString methodsFor: 'converting' stamp: 'mir 7/20/2004 15:50'!
convertFromSystemString

	| readStream writeStream converter |
	readStream _ self readStream.
	writeStream _ String new writeStream.
	converter _ LanguageEnvironment defaultSystemConverter.
	converter ifNil: [^ self].
	[readStream atEnd] whileFalse: [
		writeStream nextPut: (converter nextFromStream: readStream)].
	^ writeStream contents
! !


!ByteString methodsFor: 'testing' stamp: 'ar 4/10/2005 18:04'!
isByteString
	"Answer whether the receiver is a ByteString"
	^true! !

!ByteString methodsFor: 'testing' stamp: 'ar 4/10/2005 17:28'!
isOctetString
	"Answer whether the receiver can be represented as a byte string. 
	This is different from asking whether the receiver *is* a ByteString 
	(i.e., #isByteString)"
	^ true.
! !

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

ByteString class
	instanceVariableNames: ''!

!ByteString class methodsFor: 'primitives' stamp: 'yo 12/15/2005 13:44'!
compare: string1 with: string2 collated: order
	"Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array."

	| len1 len2 c1 c2 |
	<primitive: 'primitiveCompareString' module: 'MiscPrimitivePlugin'>
	self var: #string1 declareC: 'unsigned char *string1'.
	self var: #string2 declareC: 'unsigned char *string2'.
	self var: #order declareC: 'unsigned char *order'.

	len1 _ string1 size.
	len2 _ string2 size.
	1 to: (len1 min: len2) do:
		[:i |
		c1 _ order at: (string1 basicAt: i) + 1.
		c2 _ order at: (string2 basicAt: i) + 1.
		c1 = c2 ifFalse: 
			[c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]].
	len1 = len2 ifTrue: [^ 2].
	len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3].
! !

!ByteString class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:12'!
findFirstInString: aString  inSet: inclusionMap  startingAt: start
	| i stringSize |
	<primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'>
	self var: #aString declareC: 'unsigned char *aString'.
	self var: #inclusionMap  declareC: 'char *inclusionMap'.

	inclusionMap size ~= 256 ifTrue: [ ^0 ].

	i _ start.
	stringSize _ aString size.
	[ i <= stringSize and: [ (inclusionMap at: (aString at: i) asciiValue+1) = 0 ] ] whileTrue: [ 
		i _ i + 1 ].

	i > stringSize ifTrue: [ ^0 ].
	^i! !

!ByteString class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:13'!
indexOfAscii: anInteger inString: aString startingAt: start

	| stringSize |
	<primitive: 'primitiveIndexOfAsciiInString' module: 'MiscPrimitivePlugin'>

	self var: #aCharacter declareC: 'int anInteger'.
	self var: #aString declareC: 'unsigned char *aString'.

	stringSize _ aString size.
	start to: stringSize do: [:pos |
		(aString at: pos) asciiValue = anInteger ifTrue: [^ pos]].

	^ 0
! !

!ByteString class methodsFor: 'primitives' stamp: 'ar 9/28/2001 04:35'!
stringHash: aString initialHash: speciesHash

	| stringSize hash low |
	<primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'>

	self var: #aHash declareC: 'int speciesHash'.
	self var: #aString declareC: 'unsigned char *aString'.

	stringSize _ aString size.
	hash _ speciesHash bitAnd: 16rFFFFFFF.
	1 to: stringSize do: [:pos |
		hash _ hash + (aString at: pos) asciiValue.
		"Begin hashMultiply"
		low _ hash bitAnd: 16383.
		hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
	].
	^ hash! !

!ByteString class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:12'!
translate: aString from: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"
	<primitive: 'primitiveTranslateStringWithTable' module: 'MiscPrimitivePlugin'>
	self var: #table  declareC: 'unsigned char *table'.
	self var: #aString  declareC: 'unsigned char *aString'.

	start to: stop do: [ :i |
		aString at: i put: (table at: (aString at: i) asciiValue+1) ]! !
Symbol variableByteSubclass: #ByteSymbol
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Strings'!
!ByteSymbol commentStamp: '<historical>' prior: 0!
This class represents the symbols containing 8bit characters.!


!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'!
at: index 
	"Primitive. Answer the Character stored in the field of the receiver
	indexed by the argument. Fail if the index argument is not an Integer or
	is out of bounds. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 63>
	^ Character value: (super at: index)! !

!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'!
at: anInteger put: anObject 
	"You cannot modify the receiver."
	self errorNoModification! !

!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'!
byteAt: index
	<primitive: 60>
	^(self at: index) asciiValue! !

!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'!
byteAt: anInteger put: anObject 
	"You cannot modify the receiver."
	self errorNoModification! !

!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:11'!
byteSize
	^self size! !

!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:51'!
species
	"Answer the preferred class for reconstructing the receiver."
	^ByteString
! !


!ByteSymbol methodsFor: 'comparing' stamp: 'ar 4/10/2005 22:14'!
findSubstring: key in: body startingAt: start matchTable: matchTable
	"Answer the index in the string body at which the substring key first occurs, at or beyond start.  The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches.  If no match is found, zero will be returned."
	<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
	^super findSubstring: key in: body startingAt: start matchTable: matchTable! !


!ByteSymbol methodsFor: 'converting' stamp: 'ar 4/10/2005 22:12'!
asByteArray
	| ba sz |
	sz := self byteSize.
	ba := ByteArray new: sz.
	ba replaceFrom: 1 to: sz with: self startingAt: 1.
	^ba! !

!ByteSymbol methodsFor: 'converting' stamp: 'ar 4/10/2005 22:12'!
asOctetString
	^ self! !


!ByteSymbol methodsFor: 'testing' stamp: 'ar 4/10/2005 22:14'!
isByteString
	"Answer whether the receiver is a ByteString"
	^true! !

!ByteSymbol methodsFor: 'testing' stamp: 'ar 4/10/2005 22:14'!
isOctetString
	"Answer whether the receiver can be represented as a byte string. 
	This is different from asking whether the receiver *is* a ByteString 
	(i.e., #isByteString)"
	^ true.
! !


!ByteSymbol methodsFor: 'private' stamp: 'ar 4/11/2005 00:08'!
pvtAt: index put: aCharacter
	"Primitive. Store the Character in the field of the receiver indicated by
	the index. Fail if the index is not an Integer or is out of bounds, or if
	the argument is not a Character. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 64>
	aCharacter isCharacter 
		ifFalse:[^self errorImproperStore].
	index isInteger
		ifTrue: [self errorSubscriptBounds: index]
		ifFalse: [self errorNonIntegerIndex]! !

!ByteSymbol methodsFor: 'private' stamp: 'ar 4/10/2005 23:02'!
string: aString
	1 to: aString size do: [:j | self pvtAt: j put: (aString at: j)].
	^self! !

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

ByteSymbol class
	instanceVariableNames: ''!

!ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'!
findFirstInString: aString inSet: inclusionMap startingAt: start
	^ByteString findFirstInString: aString  inSet: inclusionMap startingAt: start! !

!ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'!
indexOfAscii: anInteger inString: aString startingAt: start
	^ByteString indexOfAscii: anInteger inString: aString startingAt: start! !

!ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'!
stringHash: aString initialHash: speciesHash
	^ByteString stringHash: aString initialHash: speciesHash! !

!ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:47'!
translate: aString from: start  to: stop  table: table
	^ByteString translate: aString from: start  to: stop  table: table! !
EUCTextConverter subclass: #CNGBTextConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!CNGBTextConverter commentStamp: '<historical>' prior: 0!
Text converter for Simplified Chinese variation of EUC.  (Even though the name doesn't look so, it is what it is.)!


!CNGBTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'!
languageEnvironment

	^ SimplifiedChineseEnvironment.
! !

!CNGBTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 14:42'!
leadingChar

	^ GB2312 leadingChar
! !

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

CNGBTextConverter class
	instanceVariableNames: ''!

!CNGBTextConverter class methodsFor: 'utilities' stamp: 'yo 10/23/2002 14:42'!
encodingNames 

	^ #('gb2312' ) copy
! !
ClipboardInterpreter subclass: #CP1250ClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!CP1250ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:09'!
fromSystemClipboard: aString

	| result converter |
	result := WriteStream on: (String new: aString size).
	converter := CP1250TextConverter new.
	aString do: [:each |
		result nextPut: (converter toSqueak: each macToSqueak) asCharacter.
	].
	^ result contents.
! !

!CP1250ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:05'!
toSystemClipboard: aString

	| result converter r |
	aString isAsciiString ifTrue: [^ aString asOctetString]. "optimization"

	result _ WriteStream on: (String new: aString size).
	converter _ CP1250TextConverter new.
	aString do: [:each |
		r _ converter fromSqueak: each.
		r charCode < 255 ifTrue: [
		result nextPut: r squeakToMac]].
	^ result contents.
! !
KeyboardInputInterpreter subclass: #CP1250InputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!CP1250InputInterpreter methodsFor: 'as yet unclassified' stamp: 'pk 1/19/2005 20:40'!
initialize

	converter _ CP1250TextConverter new.
! !

!CP1250InputInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:10'!
nextCharFrom: sensor firstEvt: evtBuf

	"Input from the Czech keyboard under Windows doesn't correspond to cp-1250 or iso-8859-2 encoding!!"

	| keyValue |

	keyValue := evtBuf third.
	^ converter toSqueak: keyValue asCharacter macToSqueak.

! !
TextConverter subclass: #CP1250TextConverter
	instanceVariableNames: ''
	classVariableNames: 'FromTable'
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!CP1250TextConverter commentStamp: '<historical>' prior: 0!
Text converter for CP1250.  Windows code page used in Eastern Europe.!


!CP1250TextConverter methodsFor: 'conversion' stamp: 'pk 1/19/2005 14:34'!
nextFromStream: aStream

	| character1 |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	^ self toSqueak: character1.
! !

!CP1250TextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:28'!
nextPut: aCharacter toStream: aStream

	aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream].
	aCharacter charCode < 128 ifTrue: [
		aStream basicNextPut: aCharacter.
	] ifFalse: [
		aStream basicNextPut: ((Character value: (self fromSqueak: aCharacter) charCode)).
	].

! !


!CP1250TextConverter methodsFor: 'private' stamp: 'yo 2/9/2005 05:29'!
fromSqueak: char

	^ Character value: (FromTable at: char charCode ifAbsent: [char asciiValue])! !

!CP1250TextConverter methodsFor: 'private' stamp: 'ar 4/9/2005 22:24'!
toSqueak: char

	| value |
	value _ char charCode.

	value < 129 ifTrue: [^ char].
	value > 255 ifTrue: [^ char].
	^ Character leadingChar: Latin2Environment leadingChar code: (#(

		16r0081 16r201A 16r0083 16r201E 16r2026 
		16r2020 16r2021 16r0088 16r2030 16r0160 
		16r2039 16r015A 16r0164 16r017D 16r0179 
		16r0090 16r2018 16r2019 16r201C 16r201D 
		16r2022 16r2013 16r2014 16r0098 16r2122 
		16r0161 16r203A 16r015B 16r0165 16r017E 
		16r017A 16r00A0 16r02C7 16r02D8 16r0141 
		16r00A4 16r0104 16r00A6 16r00A7 16r00A8 
		16r00A9 16r015E 16r00AB 16r00AC 16r00AD 
		16r00AE 16r017B 16r00B0 16r00B1 16r02DB 
		16r0142 16r00B4 16r00B5 16r00B6 16r00B7 
		16r00B8 16r0105 16r015F 16r00BB 16r013D 
		16r02DD 16r013E 16r017C 16r0154 16r00C1 
		16r00C2 16r0102 16r00C4 16r0139 16r0106 
		16r00C7 16r010C 16r00C9 16r0118 16r00CB 
		16r011A 16r00CD 16r00CE 16r010E 16r0110 
		16r0143 16r0147 16r00D3 16r00D4 16r0150 
		16r00D6 16r00D7 16r0158 16r016E 16r00DA 
		16r0170 16r00DC 16r00DD 16r0162 16r00DF 
		16r0155 16r00E1 16r00E2 16r0103 16r00E4 
		16r013A 16r0107 16r00E7 16r010D 16r00E9 
		16r0119 16r00EB 16r011B 16r00ED 16r00EE 
		16r010F 16r0111 16r0144 16r0148 16r00F3 
		16r00F4 16r0151 16r00F6 16r00F7 16r0159 
		16r016F 16r00FA 16r0171 16r00FC 16r00FD 
		16r0163 16r02D9 

) at: (value - 129 + 1)).
! !

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

CP1250TextConverter class
	instanceVariableNames: ''!

!CP1250TextConverter class methodsFor: 'class initialization' stamp: 'pk 1/19/2005 19:35'!
initialize
"
	CP1250TextConverter initialize
"
	FromTable _ Dictionary new.

	FromTable at: 16r0081 put: 16r81.
	FromTable at: 16r201A put: 16r82.
	FromTable at: 16r0083 put: 16r83.
	FromTable at: 16r201E put: 16r84.
	FromTable at: 16r2026 put: 16r85.
	FromTable at: 16r2020 put: 16r86.
	FromTable at: 16r2021 put: 16r87.
	FromTable at: 16r0088 put: 16r88.
	FromTable at: 16r2030 put: 16r89.
	FromTable at: 16r0160 put: 16r8A.
	FromTable at: 16r2039 put: 16r8B.
	FromTable at: 16r015A put: 16r8C.
	FromTable at: 16r0164 put: 16r8D.
	FromTable at: 16r017D put: 16r8E.
	FromTable at: 16r0179 put: 16r8F.
	FromTable at: 16r0090 put: 16r90.
	FromTable at: 16r2018 put: 16r91.
	FromTable at: 16r2019 put: 16r92.
	FromTable at: 16r201C put: 16r93.
	FromTable at: 16r201D put: 16r94.
	FromTable at: 16r2022 put: 16r95.
	FromTable at: 16r2013 put: 16r96.
	FromTable at: 16r2014 put: 16r97.
	FromTable at: 16r0098 put: 16r98.
	FromTable at: 16r2122 put: 16r99.
	FromTable at: 16r0161 put: 16r9A.
	FromTable at: 16r203A put: 16r9B.
	FromTable at: 16r015B put: 16r9C.
	FromTable at: 16r0165 put: 16r9D.
	FromTable at: 16r017E put: 16r9E.
	FromTable at: 16r017A put: 16r9F.
	FromTable at: 16r00A0 put: 16rA0.
	FromTable at: 16r02C7 put: 16rA1.
	FromTable at: 16r02D8 put: 16rA2.
	FromTable at: 16r0141 put: 16rA3.
	FromTable at: 16r00A4 put: 16rA4.
	FromTable at: 16r0104 put: 16rA5.
	FromTable at: 16r00A6 put: 16rA6.
	FromTable at: 16r00A7 put: 16rA7.
	FromTable at: 16r00A8 put: 16rA8.
	FromTable at: 16r00A9 put: 16rA9.
	FromTable at: 16r015E put: 16rAA.
	FromTable at: 16r00AB put: 16rAB.
	FromTable at: 16r00AC put: 16rAC.
	FromTable at: 16r00AD put: 16rAD.
	FromTable at: 16r00AE put: 16rAE.
	FromTable at: 16r017B put: 16rAF.
	FromTable at: 16r00B0 put: 16rB0.
	FromTable at: 16r00B1 put: 16rB1.
	FromTable at: 16r02DB put: 16rB2.
	FromTable at: 16r0142 put: 16rB3.
	FromTable at: 16r00B4 put: 16rB4.
	FromTable at: 16r00B5 put: 16rB5.
	FromTable at: 16r00B6 put: 16rB6.
	FromTable at: 16r00B7 put: 16rB7.
	FromTable at: 16r00B8 put: 16rB8.
	FromTable at: 16r0105 put: 16rB9.
	FromTable at: 16r015F put: 16rBA.
	FromTable at: 16r00BB put: 16rBB.
	FromTable at: 16r013D put: 16rBC.
	FromTable at: 16r02DD put: 16rBD.
	FromTable at: 16r013E put: 16rBE.
	FromTable at: 16r017C put: 16rBF.
	FromTable at: 16r0154 put: 16rC0.
	FromTable at: 16r00C1 put: 16rC1.
	FromTable at: 16r00C2 put: 16rC2.
	FromTable at: 16r0102 put: 16rC3.
	FromTable at: 16r00C4 put: 16rC4.
	FromTable at: 16r0139 put: 16rC5.
	FromTable at: 16r0106 put: 16rC6.
	FromTable at: 16r00C7 put: 16rC7.
	FromTable at: 16r010C put: 16rC8.
	FromTable at: 16r00C9 put: 16rC9.
	FromTable at: 16r0118 put: 16rCA.
	FromTable at: 16r00CB put: 16rCB.
	FromTable at: 16r011A put: 16rCC.
	FromTable at: 16r00CD put: 16rCD.
	FromTable at: 16r00CE put: 16rCE.
	FromTable at: 16r010E put: 16rCF.
	FromTable at: 16r0110 put: 16rD0.
	FromTable at: 16r0143 put: 16rD1.
	FromTable at: 16r0147 put: 16rD2.
	FromTable at: 16r00D3 put: 16rD3.
	FromTable at: 16r00D4 put: 16rD4.
	FromTable at: 16r0150 put: 16rD5.
	FromTable at: 16r00D6 put: 16rD6.
	FromTable at: 16r00D7 put: 16rD7.
	FromTable at: 16r0158 put: 16rD8.
	FromTable at: 16r016E put: 16rD9.
	FromTable at: 16r00DA put: 16rDA.
	FromTable at: 16r0170 put: 16rDB.
	FromTable at: 16r00DC put: 16rDC.
	FromTable at: 16r00DD put: 16rDD.
	FromTable at: 16r0162 put: 16rDE.
	FromTable at: 16r00DF put: 16rDF.
	FromTable at: 16r0155 put: 16rE0.
	FromTable at: 16r00E1 put: 16rE1.
	FromTable at: 16r00E2 put: 16rE2.
	FromTable at: 16r0103 put: 16rE3.
	FromTable at: 16r00E4 put: 16rE4.
	FromTable at: 16r013A put: 16rE5.
	FromTable at: 16r0107 put: 16rE6.
	FromTable at: 16r00E7 put: 16rE7.
	FromTable at: 16r010D put: 16rE8.
	FromTable at: 16r00E9 put: 16rE9.
	FromTable at: 16r0119 put: 16rEA.
	FromTable at: 16r00EB put: 16rEB.
	FromTable at: 16r011B put: 16rEC.
	FromTable at: 16r00ED put: 16rED.
	FromTable at: 16r00EE put: 16rEE.
	FromTable at: 16r010F put: 16rEF.
	FromTable at: 16r0111 put: 16rF0.
	FromTable at: 16r0144 put: 16rF1.
	FromTable at: 16r0148 put: 16rF2.
	FromTable at: 16r00F3 put: 16rF3.
	FromTable at: 16r00F4 put: 16rF4.
	FromTable at: 16r0151 put: 16rF5.
	FromTable at: 16r00F6 put: 16rF6.
	FromTable at: 16r00F7 put: 16rF7.
	FromTable at: 16r0159 put: 16rF8.
	FromTable at: 16r016F put: 16rF9.
	FromTable at: 16r00FA put: 16rFA.
	FromTable at: 16r0171 put: 16rFB.
	FromTable at: 16r00FC put: 16rFC.
	FromTable at: 16r00FD put: 16rFD.
	FromTable at: 16r0163 put: 16rFE.
	FromTable at: 16r02D9 put: 16rFF! !


!CP1250TextConverter class methodsFor: 'utilities' stamp: 'pk 1/19/2005 14:35'!
encodingNames 

	^ #('cp-1250') copy
! !
TextConverter subclass: #CP1253TextConverter
	instanceVariableNames: ''
	classVariableNames: 'FromTable'
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!CP1253TextConverter commentStamp: '<historical>' prior: 0!
Text converter for CP1253.  Windows code page used for Greek.!


!CP1253TextConverter methodsFor: 'conversion' stamp: 'yo 2/19/2004 10:12'!
nextFromStream: aStream

	| character1 |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	^ self toSqueak: character1.
! !


!CP1253TextConverter methodsFor: 'private' stamp: 'ar 4/9/2005 22:24'!
toSqueak: char

	| value |
	value _ char charCode.

	value < 128 ifTrue: [^ char].
	value > 255 ifTrue: [^ char].
	^ Character leadingChar: GreekEnvironment leadingChar code: (#(
		16r20AC 16rFFFD 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021
		16rFFFD 16r2030 16rFFFD 16r2039 16rFFFD 16rFFFD 16rFFFD 16rFFFD
		16rFFFD 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014
		16rFFFD 16r2122 16rFFFD 16r203A 16rFFFD 16rFFFD 16rFFFD 16rFFFD
		16r00A0 16r0385 16r0386 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7
		16r00A8 16r00A9 16rFFFD 16r00AB 16r00AC 16r00AD 16r00AE 16r2015
		16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r00B5 16r00B6 16r00B7
		16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F
		16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397
		16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F
		16r03A0 16r03A1 16rFFFD 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7
		16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF
		16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7
		16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF
		16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7
		16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE 16rFFFD
) at: (value - 128 + 1)).
! !

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

CP1253TextConverter class
	instanceVariableNames: ''!

!CP1253TextConverter class methodsFor: 'utilities' stamp: 'yo 2/19/2004 10:11'!
encodingNames 

	^ #('cp-1253') copy
! !
Model subclass: #CPUWatcher
	instanceVariableNames: 'tally watcher threshold'
	classVariableNames: 'CurrentCPUWatcher'
	poolDictionaries: ''
	category: 'Tools-Process Browser'!
!CPUWatcher commentStamp: '<historical>' prior: 0!
CPUWatcher implements a simple runaway process monitoring tool
that will suspend a process that is taking up too much of Squeak's
time and allow user interaction. By default it watches for a Process that
is taking more than 80% of the time; this threshold can be changed.

CPUWatcher can also be used to show cpu percentages for each process 
from within the ProcessBrowser.

	CPUWatcher startMonitoring.	"process period 20 seconds, sample rate 100 msec"
	CPUWatcher current monitorProcessPeriod: 10 sampleRate: 20.
	CPUWatcher current threshold: 0.5.	"change from 80% to 50%"
	CPUWatcher stopMonitoring.
!


!CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 07:56'!
isMonitoring
	^watcher notNil! !

!CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:36'!
tally
	^tally copy! !

!CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:49'!
threshold
	"What fraction of the time can a process be the active process before we stop it?"
	^threshold! !

!CPUWatcher methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
threshold: thresh
	"What fraction of the time can a process be the active process before we stop it?"
	threshold := (thresh max: 0.02) min: 1.0! !

!CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 08:26'!
watcherProcess
	^watcher! !


!CPUWatcher methodsFor: 'porcine capture' stamp: 'sd 11/20/2005 21:27'!
catchThePig: aProcess
	| rules |
	"nickname, allow-stop, allow-debug"
	rules := ProcessBrowser nameAndRulesFor: aProcess.

	(ProcessBrowser isUIProcess: aProcess)
		ifTrue: [ "aProcess debugWithTitle: 'Interrupted from the CPUWatcher'." ]
		ifFalse: [ rules second ifFalse: [ ^self ].
				ProcessBrowser suspendProcess: aProcess.
				self openWindowForSuspendedProcess: aProcess ]
! !

!CPUWatcher methodsFor: 'porcine capture' stamp: 'sd 11/20/2005 21:27'!
findThePig
	"tally has been updated. Look at it to see if there is a bad process.
	This runs at a very high priority, so make it fast"
	| countAndProcess | 
	countAndProcess := tally sortedCounts first.
	(countAndProcess key / tally size > self threshold) ifTrue: [ | proc |
		proc := countAndProcess value.
		proc == Processor backgroundProcess ifTrue: [ ^self ].	"idle process? OK"
		self catchThePig: proc
	].
! !

!CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 18:34'!
openMVCWindowForSuspendedProcess: aProcess
	ProcessBrowser new openAsMVC.! !

!CPUWatcher methodsFor: 'porcine capture' stamp: 'sd 11/20/2005 21:27'!
openMorphicWindowForSuspendedProcess: aProcess
	| menu rules |
	menu := MenuMorph new.
	"nickname  allow-stop  allow-debug"
	rules := ProcessBrowser nameAndRulesFor: aProcess.
	menu add: 'Dismiss this menu' target: menu selector: #delete; addLine.
	menu add: 'Open Process Browser' target: ProcessBrowser selector: #open.
	menu add: 'Resume'
		target: self
		selector: #resumeProcess:fromMenu:
		argumentList: { aProcess . menu }.
	menu add: 'Terminate'
		target: self
		selector: #terminateProcess:fromMenu:
		argumentList: { aProcess . menu }.
	rules third ifTrue: [
		menu add: 'Debug at a lower priority'
			target: self
			selector: #debugProcess:fromMenu:
			argumentList: { aProcess . menu }.
	].
	menu addTitle: aProcess identityHash asString,
		' ', rules first,
		' is taking too much time and has been suspended.
What do you want to do with it?'.
	menu stayUp: true.
	menu popUpInWorld
! !

!CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 18:35'!
openWindowForSuspendedProcess: aProcess

	Smalltalk isMorphic
		ifTrue: [ WorldState addDeferredUIMessage: [ self openMorphicWindowForSuspendedProcess: aProcess ] ]
		ifFalse: [ [ self openMVCWindowForSuspendedProcess: aProcess ] forkAt: Processor userSchedulingPriority ]
! !


!CPUWatcher methodsFor: 'process operations' stamp: 'sd 11/20/2005 21:27'!
debugProcess: aProcess
	| uiPriority oldPriority |
	uiPriority := Processor activeProcess priority.
	aProcess priority >= uiPriority ifTrue: [
		oldPriority := ProcessBrowser setProcess: aProcess toPriority: uiPriority - 1
	].
	ProcessBrowser debugProcess: aProcess.! !

!CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:27'!
debugProcess: aProcess fromMenu: aMenuMorph
	aMenuMorph delete.
	self debugProcess: aProcess.! !

!CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:21'!
resumeProcess: aProcess fromMenu: aMenuMorph
	aMenuMorph delete.
	ProcessBrowser resumeProcess: aProcess.! !

!CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:24'!
terminateProcess: aProcess fromMenu: aMenuMorph
	aMenuMorph delete.
	ProcessBrowser terminateProcess: aProcess.! !


!CPUWatcher methodsFor: 'startup-shutdown' stamp: 'sd 11/20/2005 21:27'!
monitorProcessPeriod: secs sampleRate: msecs
	self stopMonitoring.

	watcher := [ [ | promise |
		promise := Processor tallyCPUUsageFor: secs every: msecs.
		tally := promise value.
		promise := nil.
		self findThePig.
	] repeat ] forkAt: Processor highestPriority.
	Processor yield ! !

!CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/14/2001 08:07'!
startMonitoring
	self
		monitorProcessPeriod: 20 sampleRate: 100! !

!CPUWatcher methodsFor: 'startup-shutdown' stamp: 'sd 11/20/2005 21:27'!
stopMonitoring
	watcher ifNotNil: [
		ProcessBrowser terminateProcess: watcher.
		watcher := nil.
	]! !

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

CPUWatcher class
	instanceVariableNames: ''!

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 18:45'!
current
	^CurrentCPUWatcher
! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:28'!
currentWatcherProcess
	^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ]
! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 21:43'!
dumpTallyOnTranscript
	self current ifNotNil: [
		ProcessBrowser dumpTallyOnTranscript: self current tally
	]! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:15'!
initialize
	"CPUWatcher initialize"
	Smalltalk addToStartUpList: self.
	Smalltalk addToShutDownList: self.! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:06'!
isMonitoring

	^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ]
! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 10/31/2001 10:50'!
monitorPreferenceChanged
	Preferences cpuWatcherEnabled
		ifTrue: [ self startMonitoring ]
		ifFalse: [ self stopMonitoring ]! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'!
shutDown
	self stopMonitoring.! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:17'!
startMonitoring
	"CPUWatcher startMonitoring"

	^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'!
startMonitoringPeriod: pd rate: rt threshold: th
	"CPUWatcher startMonitoring"

	CurrentCPUWatcher ifNotNil: [ ^CurrentCPUWatcher startMonitoring. ].
	CurrentCPUWatcher := (self new)
		monitorProcessPeriod: pd sampleRate: rt;
		threshold: th;
		yourself.
	^CurrentCPUWatcher
! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'!
startUp
	self monitorPreferenceChanged.! !

!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'!
stopMonitoring
	"CPUWatcher stopMonitoring"

	CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ].
	CurrentCPUWatcher := nil.
! !
Error subclass: #CRCError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Streams'!

!CRCError methodsFor: 'as yet unclassified' stamp: 'nk 3/7/2004 15:56'!
isResumable
	^true! !
HTTPDownloadRequest subclass: #CachedHTTPDownloadRequest
	instanceVariableNames: 'cachedName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Download'!

!CachedHTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 14:53'!
cachedName
	^cachedName! !

!CachedHTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 14:53'!
cachedName: aString
	cachedName _ aString.! !

!CachedHTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 15:00'!
startRetrieval
	| fileStream |
	cachedName == nil ifTrue:[^super startRetrieval].
	(FileDirectory default fileExists: cachedName) ifTrue:[
		fileStream _ FileStream concreteStream new open: cachedName forWrite: false.
		fileStream == nil ifFalse:[^self content: 
			(MIMEDocument 
				contentType: 'text/plain' 
				content: fileStream contentsOfEntireFile)].
		FileDirectory default deleteFileNamed: cachedName ifAbsent:[]].
	super startRetrieval. "fetch from URL"
	"and cache in file dir"
	fileStream _ FileStream concreteStream new open: cachedName forWrite: true.
	fileStream == nil ifFalse:[
		fileStream nextPutAll: (content content).
		fileStream close].! !
PluggableCanvas subclass: #CachingCanvas
	instanceVariableNames: 'cacheCanvas mainCanvas'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Support'!
!CachingCanvas commentStamp: '<historical>' prior: 0!
A canvas which has a hidden form caching the events.  contentsOfArea:into: uses the cache, instead of the main canvas.  This is typically used with remote canvases, where querying the bits would involve a network transaction.
!


!CachingCanvas methodsFor: 'accessing' stamp: 'ls 3/27/2000 22:50'!
contentsOfArea: area  into: aForm
	^cacheCanvas contentsOfArea: area  into: aForm! !

!CachingCanvas methodsFor: 'accessing' stamp: 'ls 3/26/2000 20:21'!
form
	^cacheCanvas form! !


!CachingCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/20/2000 13:08'!
allocateForm: extentPoint

	^cacheCanvas form allocateForm: extentPoint! !

!CachingCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/21/2000 09:54'!
showAt: pt  invalidRects: rects

	mainCanvas showAt: pt  invalidRects: rects! !


!CachingCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:35'!
mainCanvas: mainCanvas0
	mainCanvas := mainCanvas0.
	cacheCanvas := FormCanvas extent: mainCanvas extent depth: mainCanvas depth.! !


!CachingCanvas methodsFor: 'private' stamp: 'ls 3/26/2000 13:35'!
apply: aBlock
	aBlock value: cacheCanvas.
	aBlock value: mainCanvas.! !

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

CachingCanvas class
	instanceVariableNames: ''!

!CachingCanvas class methodsFor: 'instance creation' stamp: 'ls 3/26/2000 13:37'!
on: aCanvas
	^super new mainCanvas: aCanvas! !
CodeLoader subclass: #CachingCodeLoader
	instanceVariableNames: 'cacheDir'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Download'!

!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'!
cacheDir
	^cacheDir! !

!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'!
cacheDir: aString
	cacheDir _ aString.! !

!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'!
localCache: stringArray
	| fd |
	fd _ FileDirectory default.
	stringArray do:[:part|
		(fd directoryNames includes: part) 
			ifFalse:[fd createDirectory: part].
		fd _ fd directoryNamed: part].
	self cacheDir: (fd pathName copyWith: fd pathNameDelimiter).! !

!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'!
localCacheDir: aString
	self cacheDir:
		(FileDirectory default pathName,
		FileDirectory slash,
		aString,
		FileDirectory slash)! !


!CachingCodeLoader methodsFor: 'private' stamp: 'mir 12/22/1999 14:11'!
createRequestFor: name in: aLoader
	| request |
	request _ super createRequestFor: name in: aLoader.
	request cachedName: cacheDir, name.
	^request! !

!CachingCodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40'!
httpRequestClass
	^CachedHTTPDownloadRequest
! !
Morph subclass: #CachingMorph
	instanceVariableNames: 'damageRecorder cacheCanvas'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Kernel'!
!CachingMorph commentStamp: '<historical>' prior: 0!
This morph can be used to cache the picture of a morph that takes a long time to draw. It should be used with judgement, however, since heavy use of caching can consume large amounts of memory.!


!CachingMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 23:03'!
updateCacheCanvas: aCanvas 
	"Update the cached image of the morphs being held by this hand."

	| myBnds rectList |
	myBnds := self fullBounds.
	(cacheCanvas isNil or: [cacheCanvas extent ~= myBnds extent]) 
		ifTrue: 
			[cacheCanvas := (aCanvas allocateForm: myBnds extent) getCanvas.
			cacheCanvas translateBy: myBnds origin negated
				during: [:tempCanvas | super fullDrawOn: tempCanvas].
			^self].

	"incrementally update the cache canvas"
	rectList := damageRecorder 
				invalidRectsFullBounds: (0 @ 0 extent: myBnds extent).
	damageRecorder reset.
	rectList do: 
			[:r | 
			cacheCanvas 
				translateTo: myBnds origin negated
				clippingTo: r
				during: 
					[:c | 
					c fillColor: Color transparent.	"clear to transparent"
					super fullDrawOn: c]]! !


!CachingMorph methodsFor: 'caching' stamp: 'jm 11/13/97 16:31'!
releaseCachedState

	super releaseCachedState.
	cacheCanvas _ nil.
! !


!CachingMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:43'!
invalidRect: damageRect from: aMorph
	"Record the given rectangle in the damage list."
	damageRecorder recordInvalidRect: (damageRect translateBy: self fullBounds origin negated).
	super invalidRect: damageRect from: aMorph! !


!CachingMorph methodsFor: 'drawing'!
drawOn: aCanvas

	submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].
! !

!CachingMorph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:14'!
fullDrawOn: aCanvas
	(aCanvas isVisible: self fullBounds) ifFalse:[^self].
	self updateCacheCanvas: aCanvas.
	aCanvas cache: self fullBounds
			using: cacheCanvas form
			during:[:cachingCanvas| super fullDrawOn: cachingCanvas].
! !

!CachingMorph methodsFor: 'drawing' stamp: 'ar 5/28/2000 17:12'!
imageForm

	self updateCacheCanvas: Display getCanvas.
	^ cacheCanvas form offset: self fullBounds topLeft
! !


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

!CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:48'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	damageRecorder _ DamageRecorder new! !
FileStreamException subclass: #CannotDeleteFileException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
FlattenEncoder subclass: #Canvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!Canvas commentStamp: '<historical>' prior: 0!
A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script).

Subclasses must implement (at least) the following methods:
	* Drawing:
		#fillOval:color:borderWidth:borderColor:
		#frameAndFillRectangle:fillColor:borderWidth:borderColor:
		#drawPolygon:color:borderWidth:borderColor:
		#image:at:sourceRect:rule:
		#stencil:at:sourceRect:rule:
		#line:to:width:color:
		#paragraph:bounds:color:
		#text:bounds:font:color:
	* Support
		#clipBy:during:
		#translateBy:during:
		#translateBy:clippingTo:during:
		#transformBy:clippingTo:during:
!


!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:07'!
clipRect
	"Return the currently active clipping rectangle"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: 'ar 2/12/2000 18:17'!
contentsOfArea: aRectangle
	"Return the contents of the given area"
	^self contentsOfArea: aRectangle into: (Form extent: aRectangle extent depth: self depth)! !

!Canvas methodsFor: 'accessing' stamp: 'ar 2/12/2000 18:17'!
contentsOfArea: aRectangle into: aForm
	"Return the contents of the given area"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing'!
depth

	^ Display depth
! !

!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:15'!
extent
	"Return the physical extent of the output device"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: 'jm 6/2/1998 06:39'!
form

	^ Display
! !

!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:11'!
origin
	"Return the current origin for drawing operations"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'!
shadowColor
	"Return the current override color or nil if no such color exists"
	^nil! !

!Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'!
shadowColor: aColor
	"Set a shadow color. If set this color overrides any client-supplied color."! !


!Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:22'!
asAlphaBlendingCanvas: alpha
	^(AlphaBlendingCanvas on: self) alpha: alpha! !

!Canvas methodsFor: 'converting' stamp: 'ar 6/24/1999 17:46'!
asShadowDrawingCanvas
	^self asShadowDrawingCanvas: (Color black alpha: 0.5).! !

!Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:14'!
asShadowDrawingCanvas: aColor
	^(ShadowDrawingCanvas on: self) shadowColor: aColor! !


!Canvas methodsFor: 'copying' stamp: 'jm 8/2/97 13:54'!
copy

	^ self clone
! !

!Canvas methodsFor: 'copying' stamp: 'ls 3/20/2000 21:24'!
copyClipRect: newClipRect

	^ ClippingCanvas canvas: self clipRect: newClipRect
! !


!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:18'!
fillColor: aColor
	"Fill the receiver with the given color.
	Note: This method should be named differently since it is intended to fill the background and thus fills even if the color is transparent"
	^self fillRectangle: self clipRect color: (aColor alpha: 1.0).! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:30'!
line: pt1 to: pt2 brushForm: brush
	"Obsolete - will be removed in the future"! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
line: pt1 to: pt2 color: c

	self line: pt1 to: pt2 width: 1 color: c.
! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:31'!
line: pt1 to: pt2 width: w color: c
	"Draw a line using the given width and color"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing' stamp: 'aoy 2/15/2003 21:41'!
line: pt1 to: pt2 width: width color: color1 dashLength: s1 secondColor: color2 secondDashLength: s2 startingOffset: startingOffset 
	"Draw a line using the given width, colors and dash lengths.
	Originally written by Stephan Rudlof; tweaked by Dan Ingalls
	to use startingOffset for sliding offset as in 'ants' animations.
	Returns the sum of the starting offset and the length of this line."

	| dist deltaBig colors nextPhase segmentOffset phase segmentLength startPoint distDone endPoint segLens |
	dist := pt1 dist: pt2.
	dist = 0 ifTrue: [^startingOffset].
	s1 = 0 & (s2 = 0) ifTrue: [^startingOffset].
	deltaBig := pt2 - pt1.
	colors := { 
				color1.
				color2}.
	segLens := { 
				s1 asFloat.
				s2 asFloat}.
	nextPhase := { 
				2.
				1}.

	"Figure out what phase we are in and how far, given startingOffset."
	segmentOffset := startingOffset \\ (s1 + s2).
	segmentLength := segmentOffset < s1 
		ifTrue: 
			[phase := 1.
			s1 - segmentOffset]
		ifFalse: 
			[phase := 2.
			 s1 + s2 - segmentOffset].
	startPoint := pt1.
	distDone := 0.0.
	[distDone < dist] whileTrue: 
			[segmentLength := segmentLength min: dist - distDone.
			endPoint := startPoint + (deltaBig * segmentLength / dist).
			self 
				line: startPoint truncated
				to: endPoint truncated
				width: width
				color: (colors at: phase).
			distDone := distDone + segmentLength.
			phase := nextPhase at: phase.
			startPoint := endPoint.
			segmentLength := segLens at: phase].
	^startingOffset + dist! !

!Canvas methodsFor: 'drawing' stamp: 'sr 4/27/2000 03:31'!
line: pt1 to: pt2 width: w1 color: c1 stepWidth: s1 secondWidth: w2 secondColor: c2 secondStepWidth: s2 
	"Draw a line using the given width, colors and steps; both steps can  
	have different stepWidths (firstStep, secondStep), draw widths and  
	colors."
	| bigSteps offsetPoint dist p1p2Vec deltaBig delta1 delta2 lastPoint bigStep |
	s1 = 0 & (s2 = 0) ifTrue: [^ self].
	dist _ pt1 dist: pt2.
	dist = 0 ifTrue: [^ self].
	bigStep _ s1 + s2.
	bigSteps _ dist / bigStep.
	p1p2Vec _ pt2 - pt1.
	deltaBig _ p1p2Vec / bigSteps.
	delta1 _ deltaBig * (s1 / bigStep).
	delta2 _ deltaBig * (s2 / bigStep).
	dist <= s1
		ifTrue: 
			[self
				line: pt1 rounded
				to: pt2 rounded
				width: w1
				color: c1.
			^ self].
	0 to: bigSteps truncated - 1 do: 
		[:bigStepIx | 
		self
			line: (pt1 + (offsetPoint _ deltaBig * bigStepIx)) rounded
			to: (pt1 + (offsetPoint _ offsetPoint + delta1)) rounded
			width: w1
			color: c1.
		self
			line: (pt1 + offsetPoint) rounded
			to: (pt1 + (offsetPoint + delta2)) rounded
			width: w2
			color: c2].
	"if there was no loop, offsetPoint is nil"
	lastPoint _ pt1 + ((offsetPoint ifNil: [0 @ 0])
					+ delta2).
	(lastPoint dist: pt2)
		<= s1
		ifTrue: [self
				line: lastPoint rounded
				to: pt2 rounded
				width: w1
				color: c1]
		ifFalse: 
			[self
				line: lastPoint rounded
				to: (lastPoint + delta1) rounded
				width: w1
				color: c1.
			self
				line: (lastPoint + delta1) rounded
				to: pt2
				width: w1
				color: c2]! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:31'!
paragraph: paragraph bounds: bounds color: c
	"Draw the given paragraph"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:32'!
point: p color: c
	"Obsolete - will be removed in the future"! !

!Canvas methodsFor: 'drawing' stamp: 'ar 2/5/1999 18:28'!
render: anObject
	"Do some 3D operations with the object if possible"! !


!Canvas methodsFor: 'drawing-general' stamp: 'ar 5/29/1999 05:14'!
draw: anObject
	^anObject drawOn: self! !

!Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 15:23'!
drawMorph: aMorph
	self draw: aMorph! !

!Canvas methodsFor: 'drawing-general'!
fullDraw: anObject
	^anObject fullDrawOn: self! !

!Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 15:23'!
fullDrawMorph: aMorph
	self fullDraw: aMorph! !

!Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'!
roundCornersOf: aMorph during: aBlock
	^self roundCornersOf: aMorph in: aMorph bounds during: aBlock! !

!Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'!
roundCornersOf: aMorph in: bounds during: aBlock
	^aBlock value! !


!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:45'!
drawImage: aForm at: aPoint
	"Draw the given Form, which is assumed to be a Form or ColorForm"

	self drawImage: aForm
		at: aPoint
		sourceRect: aForm boundingBox! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:47'!
drawImage: aForm at: aPoint sourceRect: sourceRect
	"Draw the given form."
	self shadowColor ifNotNil:[
		^self fillRectangle: ((aForm boundingBox intersect: sourceRect) translateBy: aPoint)
				color: self shadowColor].
	^self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form over! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:48'!
paintImage: aForm at: aPoint
	"Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value."

	self paintImage: aForm
		at: aPoint
		sourceRect: aForm boundingBox
! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:48'!
paintImage: aForm at: aPoint sourceRect: sourceRect
	"Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value."
	self shadowColor ifNotNil:[
		^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor].
	^self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form paint! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'!
stencil: stencilForm at: aPoint color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	^self stencil: stencilForm
		at: aPoint
		sourceRect: stencilForm boundingBox
		color: aColor! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 14:05'!
translucentImage: aForm at: aPoint
	"Draw a translucent image using the best available way of representing translucency."
	self translucentImage: aForm
		at: aPoint
		sourceRect: aForm boundingBox! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/10/2004 17:19'!
translucentImage: aForm at: aPoint sourceRect: sourceRect
	"Draw a translucent image using the best available way of representing translucency.
	Note: This will be fixed in the future."
	self shadowColor ifNotNil:[
		^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor].
	(self depth < 32 or:[aForm isTranslucent not]) 
		ifTrue:[^self paintImage: aForm at: aPoint sourceRect: sourceRect].
	self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form blend! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:44'!
warpImage: aForm transform: aTransform
	"Warp the given form using aTransform"
	^self warpImage: aForm transform: aTransform at: 0@0! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:54'!
warpImage: aForm transform: aTransform at: extraOffset
	"Warp the given form using aTransform.
	TODO: Use transform to figure out appropriate cell size"
	^self warpImage: aForm transform: aTransform at: extraOffset sourceRect: aForm boundingBox cellSize: 1! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 12/29/2001 00:20'!
warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize
	"Warp the given using the appropriate transform and offset."
	^self subclassResponsibility! !


!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:10'!
image: aForm at: aPoint
	"Note: This protocol is deprecated. Use #paintImage: instead."
	self image: aForm
		at: aPoint
		sourceRect: aForm boundingBox
		rule: Form paint.
! !

!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:11'!
image: aForm at: aPoint rule: combinationRule
	"Note: This protocol is deprecated. Use one of the explicit image drawing messages (#paintImage, #drawImage) instead."
	self image: aForm
		at: aPoint
		sourceRect: aForm boundingBox
		rule: combinationRule.
! !

!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:11'!
imageWithOpaqueWhite: aForm at: aPoint
	"Note: This protocol is deprecated. Use #drawImage: instead"
	self image: aForm
		at: aPoint
		sourceRect: (0@0 extent: aForm extent)
		rule: Form over.
! !


!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'!
fillOval: r color: c

	self fillOval: r color: c borderWidth: 0 borderColor: Color transparent.
! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Fill the given oval."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:51'!
fillOval: aRectangle fillStyle: aFillStyle
	"Fill the given oval."
	^self fillOval: aRectangle fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:50'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval.
	Note: The default implementation does not recognize any enhanced fill styles"
	self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'!
frameOval: r color: c

	self fillOval: r color: Color transparent borderWidth: 1 borderColor: c.
! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'!
frameOval: r width: w color: c

	self fillOval: r color: Color transparent borderWidth: w borderColor: c.
! !


!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:56'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Draw the given polygon."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/25/1999 12:18'!
drawPolygon: vertices fillStyle: aFillStyle
	"Fill the given polygon."
	self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! !

!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:58'!
drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given polygon.
	Note: The default implementation does not recognize any enhanced fill styles"
	self drawPolygon: vertices color: aFillStyle asColor borderWidth: bw borderColor: bc! !


!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'!
fillRectangle: r color: c
	"Fill the rectangle using the given color"
	^self 
		frameAndFillRectangle: r
		fillColor: c
		borderWidth: 0
		borderColor: Color transparent! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:34'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle.
	Note: The default implementation does not recognize any enhanced fill styles"
	self fillRectangle: aRectangle color: aFillStyle asColor.! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 8/25/2001 17:27'!
fillRectangle: aRectangle fillStyle: aFillStyle borderStyle: aBorderStyle
	"Fill the given rectangle."
	self fillRectangle: (aRectangle insetBy: aBorderStyle width) fillStyle: aFillStyle.
	aBorderStyle frameRectangle: aRectangle on: self! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Draw the rectangle using the given attributes"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'RAA 8/14/2000 14:22'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
	"Draw the rectangle using the given attributes.
	Note: This is a *very* simple implementation"
	| bw pt |
	self frameAndFillRectangle: r
		fillColor: fillColor
		borderWidth: borderWidth
		borderColor: bottomRightColor.
	bottomRightColor = topLeftColor ifFalse: [
		bw _ borderWidth asPoint.
		pt _ r topLeft + (bw // 2).
		self line: pt to: pt + ((r extent x - bw x)@0) width: borderWidth color: topLeftColor.
		self line: pt to: pt + (0@(r extent y - bw y)) width: borderWidth color: topLeftColor.
	].! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:33'!
frameRectangle: r color: c

	self frameRectangle: r width: 1 color: c.
! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:33'!
frameRectangle: r width: w color: c
	^self frameAndFillRectangle: r fillColor: Color transparent borderWidth: w borderColor: c.! !


!Canvas methodsFor: 'drawing-support' stamp: 'gm 2/22/2003 14:53'!
cache: aRectangle using: aCache during: aBlock 
	"Cache the execution of aBlock by the given cache.
	Note: At some point we may want to actually *create* the cache here;
		for now we're only using it."

	(aCache notNil 
		and: [(aCache isForm) and: [aCache extent = aRectangle extent]]) 
			ifTrue: [^self paintImage: aCache at: aRectangle origin].
	aBlock value: self! !

!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:53'!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 01:43'!
preserveStateDuring: aBlock
	"Preserve the full canvas state during the execution of aBlock"
	^aBlock value: self copy! !

!Canvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 16:02'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock
	"Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
	^ self transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: 1
! !

!Canvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 15:56'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	"Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
	^ self subclassResponsibility! !

!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:00'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 14:08'!
translateTo: newOrigin clippingTo: aRectangle during: aBlock
	"Set a new origin and clipping rectangle only during the execution of aBlock."
	self translateBy: newOrigin - self origin 
		clippingTo: (aRectangle translateBy: self origin negated) 
		during: aBlock! !


!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:35'!
drawString: s at: pt

	^ self drawString: s from: 1 to: s size at: pt font: nil color: Color black! !

!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:25'!
drawString: s at: pt font: aFont color: aColor

	^ self drawString: s from: 1 to: s size at: pt font: aFont color: aColor! !

!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:36'!
drawString: s from: firstIndex to: lastIndex at: pt font: font color: aColor
	self drawString: s from: firstIndex to: lastIndex in: (pt extent: 10000@10000) font: font color: aColor! !

!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:37'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:39'!
drawString: s in: boundsRect
	^self drawString: s from: 1 to: s size in: boundsRect font: nil color: Color black! !

!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:13'!
drawString: s in: boundsRect font: fontOrNil color: c
	^self drawString: s from: 1 to: s size in: boundsRect font: fontOrNil color: c! !

!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:40'!
text: s at: pt font: fontOrNil color: c
	"OBSOLETE"
	^ self drawString: s at: pt font: fontOrNil color: c! !

!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:40'!
text: s bounds: boundsRect font: fontOrNil color: c
	"OBSOLETE"
	^self drawString: s in: boundsRect font: fontOrNil color: c! !


!Canvas methodsFor: 'initialization' stamp: 'ar 5/27/2000 21:50'!
finish
	"If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."
	^self flush! !

!Canvas methodsFor: 'initialization' stamp: 'ar 2/9/1999 06:29'!
flush! !

!Canvas methodsFor: 'initialization' stamp: 'di 9/22/1999 19:21'!
reset
	"Reset the canvas."

	super initWithTarget:self class defaultTarget.
! !


!Canvas methodsFor: 'Nebraska/embeddedWorlds' stamp: 'RAA 11/7/2000 13:54'!
displayIsFullyUpdated! !

!Canvas methodsFor: 'Nebraska/embeddedWorlds' stamp: 'RAA 12/5/2000 18:28'!
transform2By: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	"an attempt to use #displayInterpolatedOn: instead of WarpBlt."

	| patchRect subCanvas pureRect biggerPatch biggerClip interForm |

	self flag: #bob.		"added to Canvas in hopes it will work for Nebraska"
	(aDisplayTransform isPureTranslation) ifTrue: [
		^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated
							clipRect: aClipRect)
	].
	"Prepare an appropriate warp from patch to aClipRect"
	pureRect _ (aDisplayTransform globalBoundsToLocal: aClipRect).
	patchRect _ pureRect rounded.
	patchRect area = 0 ifTrue: [^self]. 	"oh, well!!"
	biggerPatch _ patchRect expandBy: 1.
	biggerClip _ (aDisplayTransform localBoundsToGlobal: biggerPatch) rounded.

	"Render the submorphs visible in the clipping rectangle, as patchForm"
	subCanvas _ FormCanvas extent: biggerPatch extent depth: self depth.
	self isShadowDrawing ifTrue: [
		subCanvas shadowColor: self shadowColor
	].

	"this biggerPatch/biggerClip is an attempt to improve positioning of the final image in high magnification conditions. Since we cannot grab fractional pixels from the source, take one extra and then take just the part we need from the expanded form"

	subCanvas 
		translateBy: biggerPatch topLeft negated rounded
		during: [ :offsetCanvas | aBlock value: offsetCanvas].
	interForm _ Form extent: biggerClip extent depth: self depth.
	subCanvas form 
		displayInterpolatedIn: interForm boundingBox
		on: interForm.
	self 
		drawImage: interForm 
		at: aClipRect origin 
		sourceRect: (aClipRect origin - biggerClip origin extent: aClipRect extent)

! !


!Canvas methodsFor: 'other'!
flushDisplay
		" Dummy ."! !

!Canvas methodsFor: 'other'!
forceToScreen:rect
	" dummy "
! !

!Canvas methodsFor: 'other'!
translateBy:aPoint clippingTo:aRect during:aBlock
	^aBlock value:(self copyOffset:aPoint clipRect:aRect).! !


!Canvas methodsFor: 'testing' stamp: 'di 8/12/2000 15:04'!
doesRoundedCorners 

	^ true! !

!Canvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'!
isBalloonCanvas
	^false! !

!Canvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:09'!
isPostscriptCanvas
	^false! !

!Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 19:03'!
isShadowDrawing
	^false! !

!Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:10'!
isVisible: aRectangle
	"Return true if the given rectangle is (partially) visible"
	^self clipRect intersects: aRectangle
! !

!Canvas methodsFor: 'testing' stamp: 'di 9/24/2000 16:10'!
seesNothingOutside: aRectangle
	"Return true if this canvas will not touch anything outside aRectangle"
	^ aRectangle containsRect: self clipRect
! !


!Canvas methodsFor: '*MorphicExtras-drawing' stamp: 'ls 3/19/2000 15:12'!
paragraph2: para bounds: bounds color: c

	| scanner |
	scanner _ CanvasCharacterScanner new.
	scanner
		 canvas: self;
		text: para text textStyle: para textStyle;
		textColor: c.

	para displayOn: self using: scanner at: bounds topLeft.
! !


!Canvas methodsFor: 'private' stamp: 'ar 2/12/2000 18:12'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Note: The public use of this protocol is deprecated. It will become private. Nobody in the outside world must assume that a thing like a combination rule has any specific effect."
	^self subclassResponsibility! !

!Canvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha
	"Privately used for blending forms w/ constant alpha. Fall back to simpler case by defaul."
	^self image: aForm at: aPoint sourceRect: sourceRect rule: rule! !

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

Canvas class
	instanceVariableNames: ''!

!Canvas class methodsFor: 'configuring'!
filterSelector
	^#drawOnCanvas:.! !
CharacterScanner subclass: #CanvasCharacterScanner
	instanceVariableNames: 'canvas fillBlt foregroundColor runX lineY defaultTextColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Support'!
!CanvasCharacterScanner commentStamp: '<historical>' prior: 0!
A displaying scanner which draws its output to a Morphic canvas.!


!CanvasCharacterScanner methodsFor: 'accessing' stamp: 'ls 9/25/1999 15:59'!
canvas: aCanvas
	"set the canvas to draw on"
	canvas ifNotNil: [ self inform: 'initializing twice!!' ].
	canvas _ aCanvas! !


!CanvasCharacterScanner methodsFor: 'object fileIn' stamp: 'nk 6/17/2003 15:30'!
convertToCurrentVersion: varDict refStream: smartRefStrm

	"From Squeak3.5 [latest update: #5180] on 17 June 2003"
	varDict  at: 'defaultTextColor' put: Color black.
	^ super convertToCurrentVersion: varDict refStream: smartRefStrm! !


!CanvasCharacterScanner methodsFor: 'scanning' stamp: 'aoy 2/15/2003 21:24'!
displayLine: textLine offset: offset leftInRun: leftInRun 
	"largely copied from DisplayScanner's routine"

	| nowLeftInRun done startLoc startIndex stopCondition |
	line := textLine.
	foregroundColor ifNil: [foregroundColor := Color black].
	leftMargin := (line leftMarginForAlignment: alignment) + offset x.
	rightMargin := line rightMargin + offset x.
	lineY := line top + offset y.
	lastIndex := textLine first.
	nowLeftInRun := leftInRun <= 0 
				ifTrue: 
					[self setStopConditions.	"also sets the font"
					text runLengthFor: lastIndex]
				ifFalse: [leftInRun]. 
	runX := destX := leftMargin.
	runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last.
	spaceCount := 0.
	done := false.
	[done] whileFalse: 
			["remember where this portion of the line starts"

			startLoc := destX @ destY.
			startIndex := lastIndex.

			"find the end of this portion of the line"
			stopCondition := self 
						scanCharactersFrom: lastIndex
						to: runStopIndex
						in: text string
						rightX: rightMargin
						stopConditions: stopConditions
						kern: kern.	"displaying: false"

			"display that portion of the line"
			canvas 
				drawString: text string
				from: startIndex
				to: lastIndex
				at: startLoc
				font: font
				color: foregroundColor.

			"handle the stop condition"
			done := self perform: stopCondition].
	^runStopIndex - lastIndex! !


!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/25/1999 16:07'!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	lastIndex_ lastIndex + 1.
	^false! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/25/1999 16:10'!
crossedX
	"This condition will sometimes be reached 'legally' during display, when, 
	for instance the space that caused the line to wrap actually extends over 
	the right boundary. This character is allowed to display, even though it 
	is technically outside or straddling the clipping ectangle since it is in 
	the normal case not visible and is in any case appropriately clipped by 
	the scanner."

	"self fillLeading."
	^ true ! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/25/1999 16:11'!
endOfRun
	"The end of a run in the display case either means that there is actually 
	a change in the style (run code) to be associated with the string or the 
	end of this line has been reached."
	| runLength |

	lastIndex = line last ifTrue: [^true].
	runX _ destX.
	runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
	runStopIndex _ lastIndex + (runLength - 1) min: line last.
	self setStopConditions.
	^ false! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/29/1999 20:13'!
paddedSpace
	"Each space is a stop condition when the alignment is right justified. 
	Padding must be added to the base width of the space according to 
	which space in the line this space is and according to the amount of 
	space that remained at the end of the line when it was composed."

	destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).

	lastIndex _ lastIndex + 1.
	^ false! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:31'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]).
! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'!
tab

	destX _ (alignment == Justified and: [self leadingTab not])
		ifTrue:		"imbedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse: 
			[textStyle nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin].

	lastIndex _ lastIndex + 1.
	^ false! !


!CanvasCharacterScanner methodsFor: 'private' stamp: 'mu 8/9/2003 22:40'!
defaultTextColor
	defaultTextColor ifNil:[defaultTextColor _ Color black].
	^defaultTextColor! !

!CanvasCharacterScanner methodsFor: 'private' stamp: 'yo 6/23/2003 18:09'!
defaultTextColor: color
	"This defaultTextColor inst var is equivalent to paragraphColor of DisplayScanner."
	defaultTextColor _ color.
! !

!CanvasCharacterScanner methodsFor: 'private' stamp: 'ls 9/26/1999 10:03'!
doesDisplaying
	^false   "it doesn't do displaying using copyBits"! !

!CanvasCharacterScanner methodsFor: 'private' stamp: 'mu 8/9/2003 22:40'!
setFont
	foregroundColor _ self defaultTextColor.
	super setFont.
	destY _ lineY + line baseline - font ascent! !

!CanvasCharacterScanner methodsFor: 'private' stamp: 'ls 9/25/1999 16:24'!
textColor: color
	foregroundColor _ color! !
Object subclass: #CanvasDecoder
	instanceVariableNames: 'drawingCanvas clipRect transform connection fonts'
	classVariableNames: 'CachedForms DecodeTable'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!CanvasDecoder commentStamp: '<historical>' prior: 0!
Decodes commands encoded by MREncoder, and draws them onto a canvas.!


!CanvasDecoder methodsFor: 'attributes' stamp: 'ls 4/9/2000 14:29'!
drawingForm
	"return the form that we are drawing on behind thescenes"
	^drawingCanvas form! !


!CanvasDecoder methodsFor: 'decoding' stamp: 'yo 10/23/2002 23:36'!
addFontSetToCache: command

	| index font |
	index := self class decodeInteger: command second.
	font := self class decodeFontSet: command third.

	index > fonts size ifTrue: [
		| newFonts |
		newFonts  := Array new: index.
		newFonts replaceFrom: 1 to: fonts size with: fonts.
		fonts := newFonts ].

	fonts at: index put: font
! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 3/27/2000 17:57'!
addFontToCache: command
	| index font |
	index := self class decodeInteger: command second.
	font := self class decodeFont: command third.

	index > fonts size ifTrue: [
		| newFonts |
		newFonts  := Array new: index.
		newFonts replaceFrom: 1 to: fonts size with: fonts.
		fonts := newFonts ].

	fonts at: index put: font! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'yo 3/21/2003 23:02'!
addTTCFontToCache: command
	| index font |
	index := self class decodeInteger: command second.
	font := self class decodeTTCFont: command third.

	index > fonts size ifTrue: [
		| newFonts |
		newFonts  := Array new: index.
		newFonts replaceFrom: 1 to: fonts size with: fonts.
		fonts := newFonts ].

	fonts at: index put: font.
! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:42'!
drawBalloonOval: command 
	| aRectangle aFillStyle borderWidth borderColor |
	aRectangle := self class decodeRectangle: command second.
	aFillStyle := self class decodeFillStyle: command third.
	borderWidth := self class decodeInteger: command fourth.
	borderColor := self class decodeColor: (command fifth).
	self drawCommand: 
			[:c | 
			c asBalloonCanvas 
				fillOval: aRectangle
				fillStyle: aFillStyle
				borderWidth: borderWidth
				borderColor: borderColor]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:42'!
drawBalloonRect: command 
	| aRectangle aFillStyle |
	aRectangle := self class decodeRectangle: (command second).
	aFillStyle := self class decodeFillStyle: command third.
	self drawCommand: 
			[:c | 
			c asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 4/9/2000 14:26'!
drawCommand: aBlock
	"call aBlock with the canvas it should actually draw on so that the clipping rectangle and transform are set correctly"
	drawingCanvas transformBy: transform clippingTo: clipRect during: aBlock! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'nk 6/25/2003 12:24'!
drawImage: command 
	| image point sourceRect rule cacheID cacheNew previousImage |
	image := self class decodeImage: command second.
	point := self class decodePoint: command third.
	sourceRect := self class decodeRectangle: command fourth.
	rule := self class decodeInteger: command fifth.
	command size >= 7 
		ifTrue: 
			[false ifTrue: [self showSpaceUsed].	"debugging"
			cacheID := self class decodeInteger: (command sixth).
			cacheNew := (self class decodeInteger: command seventh) = 1.
			cacheID > 0 
				ifTrue: 
					[
					cacheNew 
						ifTrue: [CachedForms at: cacheID put: image]
						ifFalse: 
							[previousImage := CachedForms at: cacheID.
							image ifNil: [image := previousImage]
								ifNotNil: 
									[(previousImage notNil and: [image depth > 8]) 
										ifTrue: [image := previousImage addDeltasFrom: image].
									CachedForms at: cacheID put: image]]]].
	self drawCommand: 
			[:c | 
			c 
				image: image
				at: point
				sourceRect: sourceRect
				rule: rule]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:43'!
drawInfiniteFill: command 
	| aRectangle aFillStyle |
	aRectangle := self class decodeRectangle: (command second).
	aFillStyle := InfiniteForm with: (self class decodeImage: command third).
	self drawCommand: 
			[:c | 
			c asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'sd 11/20/2005 21:25'!
drawLine: command 
	| verb pt1Enc pt2Enc widthEnc colorEnc pt1 pt2 width color |
	verb := command first.
	pt1Enc := command second.
	pt2Enc := command third.
	widthEnc := command fourth.
	colorEnc := command fifth.
""
	pt1 := self class decodePoint: pt1Enc.
	pt2 := self class decodePoint: pt2Enc.
	width := self class decodeInteger: widthEnc.
	color := self class decodeColor: colorEnc.
""
	self
		drawCommand: [:c | c
				line: pt1
				to: pt2
				width: width
				color: color]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'sd 11/20/2005 21:25'!
drawMultiText: command

	| boundsEnc colorEnc  text bounds color fontIndexEnc fontIndex |

	text := WideString fromByteArray: (command at: 2) asByteArray.
	"text asByteArray printString displayAt: 800@0."
	"self halt."
	boundsEnc := command at: 3.
	fontIndexEnc := command at: 4.
	colorEnc := command at: 5.


	bounds := self class decodeRectangle: boundsEnc.
	fontIndex := self class decodeInteger: fontIndexEnc.
	color := self class decodeColor: colorEnc.

	self drawCommand: [ :c |
		c drawString: text in: bounds font: (fonts at: fontIndex) color: color ]
! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'sd 11/20/2005 21:25'!
drawOval: command 
	| verb rectEnc colorEnc borderWidthEnc borderColorEnc rect color borderWidth borderColor |
	verb := command first.
	rectEnc := command second.
	colorEnc := command third.
	borderWidthEnc := command fourth.
	borderColorEnc := command fifth.
	""
	rect := self class decodeRectangle: rectEnc.
	color := self class decodeColor: colorEnc.
	borderWidth := self class decodeInteger: borderWidthEnc.
	borderColor := self class decodeColor: borderColorEnc.
	""
	self
		drawCommand: [:c | c
				fillOval: rect
				color: color
				borderWidth: borderWidth
				borderColor: borderColor]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:43'!
drawPoly: command 
	| verticesEnc fillColorEnc borderWidthEnc borderColorEnc vertices fillColor borderWidth borderColor |
	fillColorEnc := command second.
	borderWidthEnc := command third.
	borderColorEnc := command fourth.
	verticesEnc := command copyFrom: 5 to: command size.
	fillColor := self class decodeColor: fillColorEnc.
	borderWidth := self class decodeInteger: borderWidthEnc.
	borderColor := self class decodeColor: borderColorEnc.
	vertices := verticesEnc collect: [:enc | self class decodePoint: enc].
	self drawCommand: 
			[:c | 
			c 
				drawPolygon: vertices
				color: fillColor
				borderWidth: borderWidth
				borderColor: borderColor]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'sd 11/20/2005 21:25'!
drawRect: command 
	| verb rectEnc fillColorEnc borderWidthEnc borderColorEnc rect fillColor borderWidth borderColor |
	verb := command first.
	rectEnc := command second.
	fillColorEnc := command third.
	borderWidthEnc := command fourth.
	borderColorEnc := command fifth.
	""
	rect := self class decodeRectangle: rectEnc.
	fillColor := self class decodeColor: fillColorEnc.
	borderWidth := self class decodeInteger: borderWidthEnc.
	borderColor := self class decodeColor: borderColorEnc.
	""
	self
		drawCommand: [:c | c
				frameAndFillRectangle: rect
				fillColor: fillColor
				borderWidth: borderWidth
				borderColor: borderColor]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'!
drawStencil: command 
	| stencilFormEnc locationEnc sourceRectEnc colorEnc stencilForm location sourceRect color |
	stencilFormEnc := command second.
	locationEnc := command third.
	sourceRectEnc := command fourth.
	colorEnc := command fifth.
	stencilForm := self class decodeImage: stencilFormEnc.
	location := self class decodePoint: locationEnc.
	sourceRect := self class decodeRectangle: sourceRectEnc.
	color := self class decodeColor: colorEnc.
	self drawCommand: 
			[:executor | 
			executor 
				stencil: stencilForm
				at: location
				sourceRect: sourceRect
				color: color]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'!
drawText: command 
	| boundsEnc colorEnc text bounds color fontIndexEnc fontIndex |
	text := command second.
	boundsEnc := command third.
	fontIndexEnc := command fourth.
	colorEnc := command fifth.
	bounds := self class decodeRectangle: boundsEnc.
	fontIndex := self class decodeInteger: fontIndexEnc.
	color := self class decodeColor: colorEnc.
	self drawCommand: 
			[:c | 
			c 
				drawString: text
				in: bounds
				font: (fonts at: fontIndex)
				color: color]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'!
extentDepth: command 
	| depth extent |
	extent := self class decodePoint: (command second).
	depth := self class decodeInteger: (command third).
	drawingCanvas := FormCanvas extent: extent depth: depth! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 3/26/2000 22:04'!
forceToScreen: aCommand  withBlock: forceBlock
	| region |
	region := self class decodeRectangle: aCommand second.
	forceBlock value: region.! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'sd 11/20/2005 21:25'!
processCommand: command  onForceDo: forceBlock
	"Decode the given string command and perform the required action.
	If the command is a forceToScreen command, also pass the forceBlock.
	The previous chained equality tests and conditionals have been replaced by a lookup table in my class variable DecodeTable, which is set in the class-side initialize method."
	| verb verbCode selector |
	command isEmpty ifTrue: [ ^self ].

	verb := command first.
	verbCode := verb first.

	selector := DecodeTable
		at: (verbCode asciiValue + 1)
		ifAbsent: [ self error: 'unknown command: ', verb ].

	"note: codeForce is the only odd one"
	^(selector == #forceToScreen:)
		ifTrue: [ self forceToScreen: command withBlock: forceBlock ]
		ifFalse: [ self perform: selector withArguments: { command } ]
! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'!
releaseImage: command 
	| cacheID |
	CachedForms ifNil: [^self].
	cacheID := self class decodeInteger: (command second).
	CachedForms at: cacheID put: nil! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'!
setClip: command 
	| clipRectEnc |
	clipRectEnc := command second.
	clipRect := self class decodeRectangle: clipRectEnc! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:45'!
setTransform: command 
	| transformEnc |
	transformEnc := command second.
	transform := self class decodeTransform: transformEnc! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 3/3/2001 18:29'!
shadowColor: command

	drawingCanvas shadowColor: (
		command second = '0' ifTrue: [nil] ifFalse: [self class decodeColor: command second]
	)
! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'sd 11/20/2005 21:25'!
showSpaceUsed

	| total |
	CachedForms ifNil: [^self].
	total := 0.
	CachedForms do: [ :each |
		each ifNotNil: [
			total := total + (each depth * each width * each height // 8).
		].
	].
	(total // 1024) printString,'     ',
	(Smalltalk garbageCollectMost // 1024) printString,'     ' displayAt: 0@0! !


!CanvasDecoder methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize
	"set the canvas to draw on"
	drawingCanvas := FormCanvas extent: 100@100 depth: 16.
	clipRect := drawingCanvas extent.
	transform := MorphicTransform identity.

	fonts := Array new: 2.! !


!CanvasDecoder methodsFor: 'network' stamp: 'sd 11/20/2005 21:25'!
connection: aStringSocket
	"set this terminal to talk over the given socket"
	connection := aStringSocket! !

!CanvasDecoder methodsFor: 'network' stamp: 'sd 11/20/2005 21:25'!
processIO
	| command didSomething |
	connection ifNil: [ ^self ].
	connection processIO.
	didSomething := false.
	[ command := connection nextOrNil.  command notNil ] whileTrue: [
		didSomething := true.
		self processCommand: command ].

	^didSomething! !

!CanvasDecoder methodsFor: 'network' stamp: 'sd 11/20/2005 21:25'!
processIOOnForce: forceBlock
	| command didSomething |
	connection ifNil: [ ^self ].
	connection processIO.
	didSomething := false.
	[ command := connection nextOrNil.  command notNil ] whileTrue: [
		didSomething := true.
		self processCommand: command onForceDo: forceBlock].

	^didSomething! !


!CanvasDecoder methodsFor: 'shutting down' stamp: 'ls 4/9/2000 14:33'!
delete
	connection ifNotNil: [ connection destroy ].! !

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

CanvasDecoder class
	instanceVariableNames: ''!

!CanvasDecoder class methodsFor: 'class initialization' stamp: 'yo 12/15/2005 16:07'!
initialize
	"CanvasDecoder initialize"
	"Set up my cache and decode table if necessary."
	CachedForms ifNil: [CachedForms := Array new: 100].
	DecodeTable ifNotNil: [ ^self ].

	DecodeTable _ Array new: 128.
	#((codeClip setClip:)
	(codeTransform setTransform:)
	(codeText drawText:)
	(codeLine drawLine:)
	(codeRect drawRect:)
	(codeBalloonRect drawBalloonRect:)
	(codeBalloonOval drawBalloonOval:)
	(codeInfiniteFill drawInfiniteFill:)
	(codeOval drawOval:)
	(codeImage drawImage:)
	(codeReleaseCache releaseImage:)
	(codePoly drawPoly:)
	(codeStencil drawStencil:)
	(codeForce forceToScreen:)
	(codeFont addFontToCache:)
	(codeFontSet addFontSetToCache:)
	(codeMultiText drawMultiText:) 
	(codeTTCFont addTTCFontToCache:)
	(codeExtentDepth extentDepth:)
	(codeShadowColor shadowColor:))
		do: [ :arr |
			(DecodeTable at: ((CanvasEncoder perform: arr first) asciiValue + 1)) ifNotNil: [self error: 'duplicated code'].
			DecodeTable
				at: ((CanvasEncoder perform: arr first) asciiValue + 1)
				put: arr second
		].
! !

!CanvasDecoder class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:26'!
reinitialize
	"CanvasDecoder reinitialize"
	"Set up my cache and decode table, removing old contents."
	CachedForms := nil.
	DecodeTable := nil.
	self initialize.
! !


!CanvasDecoder class methodsFor: 'decode table modification' stamp: 'nk 6/25/2003 12:49'!
decodeVerb: verb toSelector: selector
	"verb is a single character which will be ferformed by my instances using selector"
	DecodeTable at: verb asciiValue + 1 put: selector.	! !


!CanvasDecoder class methodsFor: 'decoding' stamp: 'RAA 7/25/2000 13:06'!
decodeColor: string
	| rgb a rgb1 rgb2 |
	rgb1 := string getInteger32: 1.
	rgb2 := string getInteger32: 5.
	a := string getInteger32: 9.
	rgb := rgb2 << 16 + rgb1.

	a < 255
		ifTrue: [ ^TranslucentColor basicNew setRgb: rgb  alpha: a/255.0 ]
		ifFalse: [ ^Color basicNew setRGB: rgb ]! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'RAA 7/28/2000 08:33'!
decodeFillStyle: string

	^DataStream unStream: string! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'yo 12/17/2005 22:44'!
decodeFont: fontString

	^StrikeFont decodedFromRemoteCanvas: fontString.
! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'yo 12/17/2005 22:42'!
decodeFontSet: fontString

	^ StrikeFontSet decodedFromRemoteCanvas: fontString
! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'sd 11/20/2005 21:26'!
decodeImage: string
	| bitsStart depth width height bits rs numColors colorArray |

	bitsStart := string indexOf: $|.
	bitsStart = 0 ifTrue: [^nil].
	rs := ReadStream on: string.
	rs peek == $C ifTrue: [
		rs next.
		numColors := Integer readFromString: (rs upTo: $,).
		colorArray := Array new: numColors.
		1 to: numColors do: [ :i |
			colorArray at: i put: (self decodeColor: (rs next: 12))
		].
	].
	depth := Integer readFromString: (rs upTo: $,).
	width :=  Integer readFromString: (rs upTo: $,).
	height :=  Integer readFromString: (rs upTo: $|).

	bits := Bitmap newFromStream: (RWBinaryOrTextStream with: rs upToEnd) binary reset.

	colorArray ifNil: [
		^Form extent: width@height depth: depth bits: bits
	].
	^(ColorForm extent: width@height depth: depth bits: bits)
		colors: colorArray
! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 9/24/1999 20:10'!
decodeInteger: string
	^Integer readFromString: string! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 3/27/2000 00:36'!
decodePoint: string
	| x y |
	x := string getInteger32: 1.
	y := string getInteger32: 5.

	^x@y! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 3/25/2000 23:02'!
decodePoints: aString
	^(aString findTokens: '|') asArray collect: [ :encPoint | self decodePoint: encPoint ]! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 3/27/2000 22:24'!
decodeRectangle: string
	| x y cornerX cornerY |
	x := string getInteger32: 1.
	y := string getInteger32: 5.
	cornerX := string getInteger32: 9.
	cornerY := string getInteger32: 13.

	^x@y corner: cornerX@cornerY! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'sd 11/20/2005 21:26'!
decodeTTCFont: fontString

	"Decode a string that consists of <familyName> <pointSize> <emphasis> (e.g. 'ComicSansMS 12 0') into a proper instance."

	| first second |
	first := fontString indexOf: $  startingAt: 1.
	second := fontString indexOf: $  startingAt: first + 1.

	(first ~= 0 and: [second ~= 0]) ifTrue: [
		^ (TTCFont family: (fontString copyFrom: 1 to: (first - 1))
			size: (fontString copyFrom: first + 1 to: second - 1) asNumber)
				emphasized: (fontString copyFrom: second + 1 to: fontString size) asNumber.
	].

	^ TextStyle defaultFont.
! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 10/9/1999 20:28'!
decodeTransform: transformEnc
	"decode an encoded transform"
	^DisplayTransform fromRemoteCanvasEncoding: transformEnc! !


!CanvasDecoder class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'!
connection: aConnection 
	^(self new)
		connection: aConnection;
		yourself! !
Object subclass: #CanvasEncoder
	instanceVariableNames: 'connection lastClipRect lastTransform fontCache cachedObjects cachingEnabled'
	classVariableNames: 'SentTypesAndSizes SimpleCounters'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!CanvasEncoder commentStamp: '<historical>' prior: 0!
Encodes canvas commands into string-arrays format.

---possible further compression for forms ---
600 * 359 * 4    861600

self encodeForRemoteCanvas size 76063
Time millisecondsToRun: [self encodeForRemoteCanvas]

| raw data |
data _ self encodeForRemoteCanvas.
raw _ RWBinaryOrTextStream on: (String new: 1000).
Time millisecondsToRun: [(GZipWriteStream on: raw) nextPutAll: data; close].
raw contents size
(GZipReadStream on: (ReadStream on: raw contents)) upToEnd size

| raw |
raw _ RWBinaryOrTextStream on: (String new: bits size).
raw nextPutAll: bits

Time millisecondsToRun: [bits compressGZip]   50

bits compressGZip size 861620!


!CanvasEncoder methodsFor: 'clipping and transforming' stamp: 'ls 4/11/2000 18:59'!
setClipRect: newClipRect
	self sendCommand: {
		String with: CanvasEncoder codeClip.
		self class encodeRectangle: newClipRect }! !

!CanvasEncoder methodsFor: 'clipping and transforming' stamp: 'ls 4/11/2000 18:59'!
setTransform: newTransform
	self sendCommand: {
		String with: CanvasEncoder codeTransform.
		self class encodeTransform: newTransform }! !

!CanvasEncoder methodsFor: 'clipping and transforming' stamp: 'sd 11/20/2005 21:25'!
updateTransform: aTransform andClipRect: aClipRect
	"sets the given transform and clip rectangle, if they aren't already the ones being used"
	aTransform = lastTransform ifFalse: [
		self setTransform: aTransform.
		lastTransform := aTransform ].

	aClipRect = lastClipRect ifFalse: [
		self setClipRect: aClipRect.
		lastClipRect := aClipRect. ].! !


!CanvasEncoder methodsFor: 'connection' stamp: 'RAA 8/1/2000 00:17'!
backlog

	^connection backlog! !

!CanvasEncoder methodsFor: 'connection' stamp: 'sd 11/20/2005 21:25'!
connection: aStringSocket
	"set this connection to talk over the given socket"

	cachingEnabled := true.
	connection := aStringSocket! !

!CanvasEncoder methodsFor: 'connection' stamp: 'sd 11/20/2005 21:25'!
disconnect
	connection ifNotNil: [
		connection destroy.
		connection := nil.
	].! !

!CanvasEncoder methodsFor: 'connection' stamp: 'ls 9/26/1999 15:45'!
isConnected
	^connection notNil and: [ connection isConnected ]! !

!CanvasEncoder methodsFor: 'connection' stamp: 'RAA 11/8/2000 15:06'!
purgeOutputQueue

	connection purgeOutputQueue.! !


!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 11/6/2000 15:38'!
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc

	self sendCommand: {
		String with: CanvasEncoder codeBalloonOval.
		self class encodeRectangle: aRectangle.
		aFillStyle encodeForRemoteCanvas.
		self class encodeInteger: bw.
		self class encodeColor: bc.
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/25/2000 13:30'!
balloonFillRectangle: aRectangle fillStyle: aFillStyle

	self sendCommand: {
		String with: CanvasEncoder codeBalloonRect.
		self class encodeRectangle: aRectangle.
		aFillStyle encodeForRemoteCanvas
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:25'!
cachingEnabled: aBoolean

	(cachingEnabled := aBoolean) ifFalse: [
		cachedObjects := nil.
	].
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	| encodedVertices |
	encodedVertices := vertices collect: [ :vertex | self class encodePoint: vertex ].

	self sendCommand: {
		String with: CanvasEncoder codePoly.
		self class encodeColor: aColor.
		self class encodeInteger: bw.
		self class encodeColor: bc},  encodedVertices .! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'yo 12/17/2005 22:44'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	| fontIndex str |
	fontIndex := self establishFont: (fontOrNil ifNil: [ TextStyle defaultFont ]).
	str _ s asString copyFrom: firstIndex to: lastIndex.
	str isWideString ifTrue: [
		self sendCommand: {
			String with: CanvasEncoder codeMultiText.
			str asByteArray asString.
			self class encodeRectangle: boundsRect.
			self class encodeInteger: fontIndex.
			self class encodeColor: c
		}
	] ifFalse: [
		self sendCommand: {
			String with: CanvasEncoder codeText.
			str.
			self class encodeRectangle: boundsRect.
			self class encodeInteger: fontIndex.
			self class encodeColor: c
		}
	].
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/9/2000 14:39'!
extent: newExtent  depth: newDepth
	self sendCommand: {
		self class codeExtentDepth asString.
		self class encodePoint: newExtent. 
		self class encodeInteger: newDepth.
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	self sendCommand: {
		String with: CanvasEncoder codeOval.
		self class encodeRectangle: r.
		self class encodeColor: c.
		self class encodeInteger: borderWidth.
		self class encodeColor: borderColor
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
forceToScreen: aRectangle
	self sendCommand: {
		String with: CanvasEncoder codeForce.
		self class encodeRectangle: aRectangle }! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/25/2000 13:12'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor

	self sendCommand: {
		String with: CanvasEncoder codeRect.
		self class encodeRectangle: r.
		fillColor encodeForRemoteCanvas.
		self class encodeInteger: borderWidth.
		self class encodeColor: borderColor
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'yo 10/6/2005 17:00'!
image: aForm at: aPoint sourceRect: sourceRect rule: argRule

	| cacheID cacheNew cacheReply formToSend cacheEntry destRect visRect aFormArea d2 rule |

	rule _ argRule.

	"first if we are only going to be able to draw a small part of the form,
	it may be faster just to send the part of the form that will actually show up"

	destRect _ aPoint extent: sourceRect extent.
	d2 _ (lastTransform invertBoundsRect: destRect) expandBy: 1.
	(d2 intersects: lastClipRect) ifFalse: [
		^NebraskaDebug at: #bigImageSkipped add: {lastClipRect. d2}.
	].
	aFormArea _ aForm boundingBox area.
	(aFormArea > 20000 and: [aForm isStatic not and: [lastTransform isPureTranslation]]) ifTrue: [
		visRect _ destRect intersect: lastClipRect.
		visRect area < (aFormArea // 20) ifTrue: [
			"NebraskaDebug 
				at: #bigImageReduced 
				add: {lastClipRect. aPoint. sourceRect extent. lastTransform}."
			formToSend _ aForm copy: (visRect translateBy: sourceRect origin - aPoint).
			formToSend depth = 32 ifTrue: [formToSend _ formToSend asFormOfDepth: 16. rule = 24 ifTrue: [rule _ 25]].
			^self 
				image: formToSend 
				at: visRect origin 
				sourceRect: formToSend boundingBox
				rule: rule
				cacheID: 0 		"no point in trying to cache this - it's a one-timer"
				newToCache: false.
		].
	].

	cacheID _ 0.
	cacheNew _ false.
	formToSend _ aForm.
	(aFormArea > 1000 and: [(cacheReply _ self testCache: aForm) notNil]) ifTrue: [
		cacheID _ cacheReply first.
		cacheEntry _ cacheReply third.
		(cacheNew _ cacheReply second) ifFalse: [
			formToSend _ aForm isStatic 
				ifTrue: [nil] 
				ifFalse: [aForm depth <= 8 ifTrue: [aForm] ifFalse: [aForm deltaFrom: cacheEntry fourth]].
		].
		cacheEntry at: 4 put: (aForm isStatic ifTrue: [aForm] ifFalse: [aForm deepCopy]).
	].
	(formToSend notNil and: [formToSend depth = 32]) ifTrue: [formToSend _ formToSend asFormOfDepth: 16. rule = 24 ifTrue: [rule _ 25]].
	self
		image: formToSend 
		at: aPoint 
		sourceRect: sourceRect 
		rule: rule 
		cacheID: cacheID 
		newToCache: cacheNew.

! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:25'!
image: aFormOrNil at: aPoint sourceRect: sourceRect rule: rule cacheID: cacheID newToCache: newToCache

	| t destRect d2 |

	destRect := aPoint extent: sourceRect extent.
	d2 := (lastTransform invertBoundsRect: destRect) expandBy: 1.
	(d2 intersects: lastClipRect) ifFalse: [
		^NebraskaDebug at: #bigImageSkipped add: {lastClipRect. d2}.
	].
	t := Time millisecondsToRun: [
		self sendCommand: {
			String with: CanvasEncoder codeImage.
			self class encodeImage: aFormOrNil.
			self class encodePoint: aPoint.
			self class encodeRectangle: sourceRect.
			self class encodeInteger: rule.
			self class encodeInteger: cacheID.
			self class encodeInteger: (newToCache ifTrue: [1] ifFalse: [0]).
		}.
	].
	(aFormOrNil notNil and: [aFormOrNil boundingBox area > 10000]) ifTrue: [
		NebraskaDebug 
			at: #bigImage 
			add: {lastClipRect. aPoint. sourceRect extent. t. cacheID. newToCache}.
	].

! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/25/2000 13:32'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self sendCommand: {
		String with: CanvasEncoder codeInfiniteFill.
		self class encodeRectangle: aRectangle.
		aFillStyle encodeForRemoteCanvas
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/14/2000 14:27'!
line: pt1  to: pt2  width: w  color: c

"Smalltalk at: #Q3 put: thisContext longStack."
	self sendCommand: {
		String with: CanvasEncoder codeLine.
		self class encodePoint: pt1.
		self class encodePoint: pt2.
		self class encodeInteger: w.
		self class encodeColor: c
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:25'!
purgeCache

	| spaceUsed spaceBefore s | 
	spaceBefore := spaceUsed := self purgeCacheInner.
	spaceBefore > 8000000 ifTrue: [
		Smalltalk garbageCollect.
		spaceUsed := self purgeCacheInner.
	].
	false ifTrue: [
		s := (spaceBefore // 1024) printString,'  ',(spaceUsed // 1024) printString,'  ',
			Time now printString,'     '.
		WorldState addDeferredUIMessage: [s displayAt: 0@0.] fixTemps.
	].
	^spaceUsed
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:25'!
purgeCacheInner

	| cachedObject totalSize thisSize |

	cachedObjects ifNil: [^0].
	totalSize := 0.
	cachedObjects withIndexDo: [ :each :index |
		cachedObject := each first first.
		cachedObject ifNil: [
			each second ifNotNil: [
				2 to: each size do: [ :j | each at: j put: nil].
				self sendCommand: {
					String with: CanvasEncoder codeReleaseCache.
					self class encodeInteger: index.
				}.
			].
		] ifNotNil: [
			thisSize := cachedObject depth * cachedObject width * cachedObject height // 8.
			totalSize := totalSize + thisSize.
		].
	].
	^totalSize
	"---
	newEntry := {
		WeakArray with: anObject.
		1.
		Time millisecondClockValue.
		nil.
	}.
	---"
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 3/3/2001 18:26'!
shadowColor: aFillStyle

	self sendCommand: {
		String with: CanvasEncoder codeShadowColor.
		aFillStyle ifNil: ['0'] ifNotNil: [aFillStyle encodeForRemoteCanvas].
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	self sendCommand: {
		String with: CanvasEncoder codeStencil.
		self class encodeImage: stencilForm.
		self class encodePoint: aPoint.
		self class encodeRectangle: sourceRect.
		self class encodeColor: aColor }! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'dgd 2/22/2003 19:01'!
testCache: anObject 
	| firstFree cachedObject newEntry |
	cachingEnabled 
		ifFalse: 
			[cachedObjects := nil.
			^nil].
	cachedObjects ifNil: 
			[cachedObjects := (1 to: 100) collect: 
							[:x | 
							{ 
								WeakArray new: 1.
								nil.
								nil.
								nil}]].
	self purgeCache.
	firstFree := nil.
	cachedObjects withIndexDo: 
			[:each :index | 
			cachedObject := each first first.
			firstFree ifNil: [cachedObject ifNil: [firstFree := index]].
			cachedObject == anObject 
				ifTrue: 
					[each at: 2 put: (each second) + 1.
					^{ 
						index.
						false.
						each}]].
	firstFree ifNil: [^nil].
	newEntry := { 
				WeakArray with: anObject.
				1.
				Time millisecondClockValue.
				nil}.
	cachedObjects at: firstFree put: newEntry.
	^{ 
		firstFree.
		true.
		newEntry}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:25'!
testRectangleFillTiming
| r fillColor borderWidth borderColor t |
"
CanvasEncoder new testRectangleFillTiming
"
	r := 100@100 extent: 300@300.
	fillColor := Color blue.
	borderWidth := 1.
	borderColor := Color red.
	t := Time millisecondsToRun: [
		1000 timesRepeat: [
		{
		String with: CanvasEncoder codeRect.
		self class encodeRectangle: r.
		self class encodeColor: fillColor.
		self class encodeInteger: borderWidth.
		self class encodeColor: borderColor }
		].
	].
	t inspect.! !


!CanvasEncoder methodsFor: 'fonts' stamp: 'ls 3/27/2000 18:06'!
establishFont: aFont
	"make sure that the given font is in the fonts cache.  If it is not there already, then transmit it.  Either way, after this returns, the font is in the cache at the index specified by the return value"
	| index |
	(fontCache includesFont: aFont) ifTrue: [ ^fontCache indexOf: aFont ].
	index := fontCache indexForNewFont: aFont.
	self sendFont: aFont atIndex: index.
	^index! !

!CanvasEncoder methodsFor: 'fonts' stamp: 'sd 11/20/2005 21:25'!
sendFont: aFont atIndex: index
	"Transmits the given fint to the other side"

	| code |
	code := CanvasEncoder codeFont.
	aFont isTTCFont ifTrue: [code := CanvasEncoder codeTTCFont].
	self sendCommand: {
		String with: code.
		self class encodeInteger: index.
		self class encodeFont: aFont }.
! !


!CanvasEncoder methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize

	cachingEnabled := true.
	fontCache := FontCache new: 5.! !


!CanvasEncoder methodsFor: 'network' stamp: 'ls 9/24/1999 19:52'!
destroy
	self disconnect.! !

!CanvasEncoder methodsFor: 'network' stamp: 'ls 3/21/2000 23:22'!
flush
	connection ifNotNil: [
		connection flush ]! !

!CanvasEncoder methodsFor: 'network' stamp: 'ls 9/24/1999 19:52'!
processIO
	connection ifNil: [ ^self ].
	connection isConnected ifFalse: [ ^self ].
	connection processIO.! !


!CanvasEncoder methodsFor: 'objects from disk' stamp: 'sd 11/20/2005 21:25'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	cachingEnabled ifNil: [cachingEnabled := true].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !


!CanvasEncoder methodsFor: 'private' stamp: 'dgd 2/22/2003 14:41'!
sendCommand: stringArray 
	| bucket |
	connection ifNil: [^self].
	connection isConnected ifFalse: [^self].
	connection nextPut: stringArray.
	SentTypesAndSizes ifNil: [^self].
	bucket := SentTypesAndSizes at: stringArray first
				ifAbsentPut: 
					[{ 
						0.
						0.
						0}].
	bucket at: 1 put: bucket first + 1.
	bucket at: 2
		put: (bucket second) 
				+ (stringArray inject: 4 into: [:sum :array | sum + (array size + 4)])! !

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

CanvasEncoder class
	instanceVariableNames: ''!

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
at: anIndex count: anInteger

	SimpleCounters ifNil: [(SimpleCounters := Array new: 10) atAllPut: 0].
	SimpleCounters at: anIndex put: (SimpleCounters at: anIndex) + anInteger.! !

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

	SentTypesAndSizes := Dictionary new.! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
clearTestVars
"
CanvasEncoder clearTestVars
"
	SimpleCounters := nil

! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
explainTestVars
"
CanvasEncoder explainTestVars
"
	| answer total oneBillion data putter nReps |

	SimpleCounters ifNil: [^ Beeper beep].
	total := 0.
	oneBillion := 1000 * 1000 * 1000.
	answer := String streamContents: [ :strm |
		data := SimpleCounters copy.
		putter := [ :msg :index :nSec |
			nReps := data at: index.
			total := total + (nSec * nReps).
			strm nextPutAll: nReps asStringWithCommas,' * ',nSec printString,' ',
					(nSec * nReps / oneBillion roundTo: 0.01) printString,' secs for ',msg; cr
		].
		putter value: 'string socket' value: 1 value: 8000.
		putter value: 'rectangles' value: 2 value: 40000.
		putter value: 'points' value: 3 value: 18000.
		putter value: 'colors' value: 4 value: 8000.
	].
	StringHolder new
		contents: answer;
		openLabel: 'put integer times'.

! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 17:26'!
inspectTestVars
"
CanvasEncoder inspectTestVars
"
	^SimpleCounters

! !

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

	SentTypesAndSizes := nil! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
nameForCode: aStringOrChar

	| ch |
	ch := (aStringOrChar isString) ifTrue: [aStringOrChar first] ifFalse: [aStringOrChar].
	ch == self codeBalloonOval ifTrue: [^'balloon oval'].
	ch == self codeBalloonRect ifTrue: [^'balloon rectangle'].
	ch == self codeClip ifTrue: [^'clip'].
	ch == self codeExtentDepth ifTrue: [^'codeExtentDepth'].
	ch == self codeFont ifTrue: [^'codeFont'].
	ch == self codeTTCFont ifTrue: [^'codeTTCFont'].
	ch == self codeForce ifTrue: [^'codeForce'].
	ch == self codeImage ifTrue: [^'codeImage'].
	ch == self codeLine ifTrue: [^'codeLine'].
	ch == self codeOval ifTrue: [^'codeOval'].
	ch == self codePoly ifTrue: [^'codePoly'].
	ch == self codeRect ifTrue: [^'codeRect'].
	ch == self codeReleaseCache ifTrue: [^'codeReleaseCache'].
	ch == self codeStencil ifTrue: [^'codeStencil'].
	ch == self codeText ifTrue: [^'codeText'].
	ch == self codeTransform ifTrue: [^'codeTransform'].
	ch == self codeInfiniteFill ifTrue: [^'codeInfiniteFill'].
	ch == self codeShadowColor ifTrue: [^'shadowColor'].
	^'????'
! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
showStats
"
CanvasEncoder showStats
"
	| answer bucket |

	SentTypesAndSizes ifNil: [^Beeper beep].
	answer := WriteStream on: String new.
	SentTypesAndSizes keys asSortedCollection do: [ :each |
		bucket := SentTypesAndSizes at: each.
		answer nextPutAll: each printString,' ',
				bucket first printString,'  ',
				bucket second asStringWithCommas,' ',
				(self nameForCode: each); cr.
	].
	StringHolder new contents: answer contents; openLabel: 'send/receive stats'.
! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
timeSomeThings
"
CanvasEncoder timeSomeThings
"
	| s iter answer ms pt rect bm writer array color |

	iter := 1000000.
	array := Array new: 4.
	color := Color red.
	answer := String streamContents: [ :strm |
		writer := [ :msg :doer |
			ms := [iter timesRepeat: doer] timeToRun.
			strm nextPutAll: msg,((ms * 1000 / iter) roundTo: 0.01) printString,' usec'; cr.
		].
		s := String new: 4.
		bm := Bitmap new: 20.
		pt := 100@300.
		rect := pt extent: pt.
	iter := 1000000.
		writer value: 'empty loop ' value: [self].
		writer value: 'modulo ' value: [12345678 \\ 256].
		writer value: 'bitAnd: ' value: [12345678 bitAnd: 255].
		strm cr.
	iter := 100000.
		writer value: 'putInteger ' value: [s putInteger32: 12345678 at: 1].
		writer value: 'bitmap put ' value: [bm at: 1 put: 12345678].
		writer value: 'encodeBytesOf: (big) ' value: [bm encodeInt: 12345678 in: bm at: 1].
		writer value: 'encodeBytesOf: (small) ' value: [bm encodeInt: 5000 in: bm at: 1].
		writer value: 'array at: (in) ' value: [array at: 1].
		writer value: 'array at: (out) ' value: [array at: 6 ifAbsent: []].
		strm cr.
	iter := 10000.
		writer value: 'color encode ' value: [color encodeForRemoteCanvas].
		writer value: 'pt encode ' value: [pt encodeForRemoteCanvas].
		writer value: 'rect encode ' value: [self encodeRectangle: rect].
		writer value: 'rect encode2 ' value: [rect encodeForRemoteCanvas].
		writer value: 'rect encodeb ' value: [rect encodeForRemoteCanvasB].
	].

	StringHolder new contents: answer; openLabel: 'send/receive stats'.
! !


!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:29'!
aaaReadme
	"these codes are used instead of strings, because String>>= was taking around 20% of the decoder's time"
	! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 11/6/2000 15:28'!
codeBalloonOval

	^$O! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 7/28/2000 07:43'!
codeBalloonRect
	^$R! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeClip
	^$A! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 4/9/2000 14:39'!
codeExtentDepth
	^$M! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeFont
	^$L! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'yo 10/23/2002 23:41'!
codeFontSet

	^ $S
! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeForce
	^$J! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeImage
	^$G! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 8/25/2000 13:31'!
codeInfiniteFill

	^$i! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeLine
	^$D! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'yo 10/23/2002 23:42'!
codeMultiText

	^ $c
! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeOval
	^$F! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codePoly
	^$H! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeRect
	^$E! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 7/28/2000 16:50'!
codeReleaseCache
	^$z! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 3/3/2001 18:24'!
codeShadowColor

	^$s! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeStencil
	^$I! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'yo 3/21/2003 23:00'!
codeTTCFont

	^ $T.
! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeText
	^$C! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:35'!
codeTransform
	^$B! !


!CanvasEncoder class methodsFor: 'encoding' stamp: 'RAA 7/24/2000 13:24'!
encodeColor: color
	
	^color encodeForRemoteCanvas! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'RAA 7/28/2000 07:53'!
encodeFillStyle: aFillStyle
	
	^aFillStyle encodeForRemoteCanvas! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'ls 3/27/2000 17:57'!
encodeFont: aFont
	^aFont encodedForRemoteCanvas! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'sd 11/20/2005 21:26'!
encodeImage: form
	
	| t answer |

	form ifNil: [^''].
	t := Time millisecondsToRun: [answer := form encodeForRemoteCanvas].
	form boundingBox area > 5000 ifTrue: [
		NebraskaDebug at: #FormEncodeTimes add: {t. form extent. answer size}
	].
	^answer

	"HandMorph>>restoreSavedPatchOn: is one culprit here"

! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'ls 3/26/2000 23:12'!
encodeInteger: integer
	^integer asInteger storeString! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'RAA 7/28/2000 08:20'!
encodePoint: point
	
	^point encodeForRemoteCanvas! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'sd 11/20/2005 21:26'!
encodeRectangle: rectangle
	| x y encoded cornerX cornerY |

	x := rectangle origin x asInteger.
	y := rectangle origin y asInteger.
	cornerX := rectangle corner x asInteger.
	cornerY := rectangle corner y asInteger.

	CanvasEncoder at: 2 count:  1.
	encoded := String new: 16.
	encoded putInteger32: x at: 1.
	encoded putInteger32: y at: 5.
	encoded putInteger32: cornerX at: 9.
	encoded putInteger32: cornerY at: 13.

	^encoded! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'ls 10/9/1999 18:54'!
encodeTransform: transform
	^transform encodeForRemoteCanvas! !


!CanvasEncoder class methodsFor: 'instance creation' stamp: 'ls 10/20/1999 21:17'!
on: connection
	^self new connection: connection! !
Player subclass: #CardPlayer
	instanceVariableNames: 'privateMorphs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Stacks'!
!CardPlayer commentStamp: '<historical>' prior: 0!
CardPlayer
	Instance variables of the Uniclass represent the data in the "fields" of each card in the stack.
	Each Instance variable is some kind of value holder.

	The code for the *buttons* on the background resides in the CardPlayer uniclass.

privateMorphs -- OrderedCollection of objects specific to this card.

Individual CardPlayer classes need to store the search results of any instances that are templates.  As a hack, we use a class variable TemplateMatches in each individual class (CardPlayer21).  It is initialized in #matchIndex:.
TemplateMatches   an IndentityDictionary of 
		(aCardPlayer -> (list of matching cards, index in that list))
!


!CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:44'!
matchIndex
	| tms |
	"Index of one we are looking at, in the cards that matched the last search with this template."

	tms _ self class classPool at: #TemplateMatches ifAbsent: [^ 0].
	^ (tms at: self ifAbsent: [#(0 0)]) second.
! !

!CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:47'!
matchIndex: newPlace
	| tms pair |
	"One we are looking at, in cards that matched the last template search."

	tms _ self class classPool at: #TemplateMatches ifAbsent: [
		self class addClassVarName: 'TemplateMatches'.
		self class classPool at: #TemplateMatches put: IdentityDictionary new].
	pair _ tms at: self ifAbsent: [tms at: self put: (Array new: 2)].
	pair at: 2 put: newPlace.
	newPlace = 0 ifTrue: [^ self].
	pair first ifNil: [^ self].
	(costume valueOfProperty: #myStack ifAbsent: [^ self]) goToCard: 
		((pair first "list") at: newPlace).
	self changed: #matchIndex.	"update my selection"
! !

!CardPlayer methodsFor: 'as template' stamp: 'tk 5/31/2001 16:46'!
matchNames
	| list str ll tms stk crds |
	"List of names of cards that matched the last template search."

	tms _ self class classPool at: #TemplateMatches ifAbsent: [^ #()].
	list _ (tms at: self ifAbsent: [#(#() 0)]) first.
	stk _ costume valueOfProperty: #myStack ifAbsent: [nil].
	crds _ stk ifNil: [#()] ifNotNil: [stk cards].
	^ list collect: [:cd | 
		str _ ''.
		(ll _ cd allStringsAfter: nil) ifNotNil: [
			str _ ll inject: '' into: [:strr :this | strr, this]]. 
		(str copyFrom: 1 to: (30 min: str size)), '...  (' , (crds indexOf: cd) printString, ')'].
		"Maybe include a card title?"! !

!CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:49'!
results
	"Return my (cardlist index) pair from the last search"

	^ (self class classPool at: #TemplateMatches ifAbsent: [^ Array new: 2]) at: self
! !


!CardPlayer methodsFor: 'card data' stamp: 'dgd 2/22/2003 14:43'!
allStringsAfter: aText 
	"return an OrderedCollection of strings of text in my instance vars.  If aText is non-nil, begin with that object."

	| list ok instVarValue string |
	list := OrderedCollection new.
	ok := aText isNil.
	self class variableDocks do: 
			[:vdock | 
			instVarValue := self perform: vdock playerGetSelector.
			ok ifFalse: [ok := instVarValue == aText].	"and do this one too"
			ok 
				ifTrue: 
					[string := nil.
					instVarValue isString ifTrue: [string := instVarValue].
					instVarValue isText ifTrue: [string := instVarValue string].
					instVarValue isNumber ifTrue: [string := instVarValue printString].
					instVarValue isMorph ifTrue: [string := instVarValue userString].	"not used"
					string ifNotNil: 
							[string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]].
	privateMorphs 
		ifNotNil: [privateMorphs do: [:mm | list addAll: (mm allStringsAfter: nil)]].
	^list! !

!CardPlayer methodsFor: 'card data' stamp: 'tk 5/25/2001 17:42'!
asKeys
	| keys kk vd gotData |
	"Take my fields, tokenize the text, and return as an array in the same order as variableDocks.  Simple background fields on the top level.  If no data, return nil."

	keys _ self class variableDocks copy.
	gotData _ false.
	1 to: keys size do: [:ind |
		kk _ nil.
		vd _ self class variableDocks at: ind.
		vd type == #text ifTrue: [
			kk _ (self perform: vd playerGetSelector) string
					findTokens: Character separators.
			kk isEmpty ifTrue: [kk _ nil] ifFalse: [gotData _ true]].
		keys at: ind put: kk].
	^ gotData ifTrue: [keys] ifFalse: [nil]! !

!CardPlayer methodsFor: 'card data' stamp: 'sw 10/13/2000 16:46'!
commitCardPlayerData
	"Transport data back from the morphs that may be holding it into the instance variables that must hold it when the receiver is not being viewed"

	| prior |
	self class variableDocks do:
		[:aDock | aDock storeMorphDataInInstance: self].
	prior _ nil.
	privateMorphs _ OrderedCollection new.
	self costume ifNotNil:
		[self costume submorphs do:
			[:aMorph | aMorph renderedMorph isShared
				ifFalse:
					[aMorph setProperty: #priorMorph toValue: prior.
					privateMorphs add: aMorph.
					aMorph delete].
			prior _ aMorph]]! !

!CardPlayer methodsFor: 'card data' stamp: 'sw 11/14/2000 11:21'!
commitCardPlayerDataFrom: aPlayfield
	"Transport data back from the morphs that may be holding it into the instance variables that must hold it when the receiver is not being viewed"

	| prior itsOrigin |
	itsOrigin _ aPlayfield topLeft.
	self class variableDocks do:
		[:aDock | aDock storeMorphDataInInstance: self].
	prior _ nil.
	privateMorphs _ OrderedCollection new.
	self costume ifNotNil:
		[self costume submorphs do:
			[:aMorph | aMorph renderedMorph isShared
				ifFalse:
					[aMorph setProperty: #priorMorph toValue: prior.
					privateMorphs add: aMorph.
					aMorph delete.
					aMorph position: (aMorph position - itsOrigin)].
			prior _ aMorph]]! !

!CardPlayer methodsFor: 'card data' stamp: 'tk 1/16/2001 16:12'!
installPrivateMorphsInto: aBackground
	"The receiver is being installed as the current card in a given pasteup morph being used as a background.  Install the receiver's private morphs into that playfield"

	| prior originToUse |
	self flag: #deferred.  "not robust if the background is showing a list view"
	privateMorphs ifNotNil: [privateMorphs do:
		[:aMorph |
			originToUse _ aBackground topLeft.
			prior _ aMorph valueOfProperty: #priorMorph ifAbsent: [nil].
			aMorph position: (aMorph position + originToUse).
			(prior notNil and: [aBackground submorphs includes: prior])
				ifTrue:
					[aBackground addMorph: aMorph after: prior]
				ifFalse:
					[aBackground addMorphFront: aMorph].
		aMorph removeProperty: #priorMorph]]! !

!CardPlayer methodsFor: 'card data' stamp: 'tk 5/25/2001 17:02'!
match: keys fields: docks
	| longString |
	"see if each key occurs in my corresponding text instance."

	keys withIndexDo: [:kk :ind |
		kk ifNotNil: [
			longString _ (self perform: (docks at: ind) playerGetSelector) string.
			kk do: [:aKey |
				((longString findString: aKey startingAt: 1 caseSensitive: false) > 0)
					ifFalse: [^ false]]]]. 	"all keys must match"
	^ true! !

!CardPlayer methodsFor: 'card data' stamp: 'tk 1/30/2001 23:42'!
privateMorphs

	^ privateMorphs! !

!CardPlayer methodsFor: 'card data' stamp: 'tk 5/7/2001 15:51'!
url
	"For now, don't know we could be on a server"

	^ nil! !


!CardPlayer methodsFor: 'printing' stamp: 'sw 10/23/2000 17:58'!
printOn: aStream
	"Print out a human-readable representation of the receiver onto aStream"

	super printOn: aStream.
	self class instVarNames do:
		[:aName | aStream nextPutAll: ', ', aName, ' = ', (self instVarNamed: aName) printString]! !


!CardPlayer methodsFor: 'scripts-kernel' stamp: 'svp 10/15/2001 14:44'!
renameScript: oldSelector newSelector: newSelector
	"Find all buttons that fire this script and tell them the new name"

	| stack |
	super renameScript: oldSelector newSelector: newSelector.
	costume allMorphsDo: [:mm |
		self retargetButton: mm oldSelector: oldSelector newSelector: newSelector].

	stack _ costume valueOfProperty: #myStack.
	stack ifNotNil:
		[stack cards do: [:cc |
			cc privateMorphs do: [:pp | 
				pp allMorphsDo: [:mm |
					self retargetButton: mm oldSelector: oldSelector newSelector: newSelector]]]]! !

!CardPlayer methodsFor: 'scripts-kernel' stamp: 'tk 9/29/2001 10:27'!
retargetButton: mm oldSelector: oldSelector newSelector: newSelector
	"changing the name of a script -- tell any buttons that fire it"

	(mm respondsTo: #scriptSelector) ifTrue: [
		mm scriptSelector == oldSelector ifTrue: [
			mm scriptSelector: newSelector.
			mm setNameTo: newSelector]].
	(mm respondsTo: #actionSelector) ifTrue: [
		mm actionSelector == oldSelector ifTrue: [
			mm target class == self class ifTrue: [
				mm actionSelector: newSelector.
				mm setNameTo: newSelector]]].
! !


!CardPlayer methodsFor: 'slots-kernel' stamp: 'sw 7/28/2004 21:03'!
tileReferringToSelf
	"Answer a tile that refers to the receiver.  For CardPlayer, want 'self', not the specific name of this card.  Script needs to work for any card of the background."

	Preferences universalTiles ifTrue:
		[^ self universalTileReferringToSelf].

	^ TileMorph new setToReferTo: self! !

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

CardPlayer class
	instanceVariableNames: 'variableDocks'!

!CardPlayer class methodsFor: 'compiling' stamp: 'sw 10/13/2000 13:02'!
acceptsLoggingOfCompilation
	"Answer whether methods of the receiver should be logged when submitted."

	^ #(CardPlayer) includes: self class theNonMetaClass name! !

!CardPlayer class methodsFor: 'compiling' stamp: 'tk 9/28/2001 11:42'!
wantsChangeSetLogging
	"Log changes for CardPlayer itself, but not for automatically-created subclasses like CardPlayer1, CardPlayer2, but *do* log it for uniclasses that have been manually renamed."

	^ (self == CardPlayer or:
		[(self name beginsWith: 'CardPlayer') not]) or:
			[Preferences universalTiles]! !


!CardPlayer class methodsFor: 'instance creation' stamp: 'sw 10/13/2000 13:05'!
isUniClass
	"Answer, for the purpose of providing annotation in a method holder, whether the receiver is a uniClass."

	^ self ~~ CardPlayer! !


!CardPlayer class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41'!
compileAccessorsFor: varName
	"Compile instance-variable accessor methods for the given variable name"

	| nameString |
	nameString _ varName asString capitalized.
	self compileSilently: ('get', nameString, '
	^ ', varName)
		classified: 'access'.
	self compileSilently: ('set', nameString, ': val
	', varName, ' _ val')
		classified: 'access'! !

!CardPlayer class methodsFor: 'slots' stamp: 'NS 1/30/2004 13:11'!
removeAccessorsFor: varName
	"Remove the instance-variable accessor methods associated with varName"

	| nameString |
	nameString _ varName asString capitalized.
	self removeSelectorSilently: ('get', nameString) asSymbol.
	self removeSelectorSilently: ('set', nameString, ':') asSymbol! !


!CardPlayer class methodsFor: 'testing' stamp: 'sw 10/13/2000 13:07'!
officialClass
	"Answer (for the purpose of copying mechanisms) the system class underlying the receiver."

	^ CardPlayer! !


!CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'sw 12/6/2001 20:36'!
resortInstanceVariables: newList
	"Accept a new ordering for instance variables"

	variableDocks _ newList collect: [:aName | variableDocks detect: [:d | d variableName = aName]].
	self setNewInstVarNames: newList asOrderedCollection.
	self newVariableDocks: variableDocks.
! !

!CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'tk 8/26/2001 16:58'!
setNewInstVarNames: listOfStrings
	"Make listOfStrings be the new list of instance variable names for the receiver"

	| disappearing firstAppearing instVarString instVarList |
	instVarList _ self instVarNames asOrderedCollection.
	disappearing _ instVarList copy.
	disappearing removeAllFoundIn: listOfStrings.
	disappearing do:
		[:oldName | 	self removeAccessorsFor: oldName].
	firstAppearing _ listOfStrings copy.
	firstAppearing removeAllFoundIn: instVarList.
	instVarString _ String streamContents:
		[:aStream | listOfStrings do: [:aString | aStream nextPutAll: aString; nextPut: $ ]].

	superclass subclass: self name instanceVariableNames: instVarString 
		classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses.
	firstAppearing do:
		[:newName | self compileAccessorsFor: newName].
! !


!CardPlayer class methodsFor: 'variable docks' stamp: 'sw 10/13/2000 16:36'!
newVariableDocks: dockList
	"Set the receiver's variableDocks to be the list provided in dockList.  Assimilate this new information into the receiver's slotInfo, which contains both automatically-generated variables such as the variable docks and also explicitly-user-specified variables"

	self variableDocks: dockList.
	self setSlotInfoFromVariableDocks! !

!CardPlayer class methodsFor: 'variable docks' stamp: 'md 3/1/2006 09:17'!
setSlotInfoFromVariableDocks
	"Get the slotInfo fixed up after a change in background shape.  Those instance variables that are proactively added by the user will persist, whereas those that are automatically generated will be updated"

	| aDock newInfo |
	
	self slotInfo copy do:  "Remove old automatically-created slots"
		[:aSlotInfo | (aDock _ aSlotInfo variableDock) ifNotNil:
			[slotInfo removeKey: aDock variableName]].

	self variableDocks do:  [:dock | "Generate fresh slots from variable docks"
			newInfo _ SlotInformation new type: dock variableType.
			newInfo variableDock: dock.
			slotInfo at: dock variableName asSymbol put: newInfo]! !

!CardPlayer class methodsFor: 'variable docks' stamp: 'sw 10/13/2000 16:39'!
variableDocks
	"Answer the list of variable docks in the receiver.  Initialize the variable-dock list if not already done."

	variableDocks ifNil: [variableDocks _ OrderedCollection new].
	^ variableDocks! !

!CardPlayer class methodsFor: 'variable docks' stamp: 'sw 10/13/2000 16:39'!
variableDocks: dockList
	"Set the variable-dock list as indicated"

	variableDocks _ dockList! !
ParseNode subclass: #CascadeNode
	instanceVariableNames: 'receiver messages'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!CascadeNode commentStamp: '<historical>' prior: 0!
The first message has the common receiver, the rest have receiver == nil, which signifies cascading.!


!CascadeNode methodsFor: 'accessing' stamp: 'tk 10/22/2000 16:55'!
receiver
	^receiver! !


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

	receiver emitForValue: stack on: aStream.
	1 to: messages size - 1 do: 
		[:i | 
		aStream nextPut: Dup.
		stack push: 1.
		(messages at: i) emitForValue: stack on: aStream.
		aStream nextPut: Pop.
		stack pop: 1].
	messages last emitForValue: stack on: aStream! !

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

	| size |
	size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2).
	messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)].
	^size! !


!CascadeNode methodsFor: 'initialize-release'!
receiver: receivingObject messages: msgs
	" Transcript show: 'abc'; cr; show: 'def' "

	receiver _ receivingObject.
	messages _ msgs! !


!CascadeNode methodsFor: 'printing'!
printOn: aStream indent: level
	self printOn: aStream indent: level precedence: 0! !

!CascadeNode methodsFor: 'printing' stamp: 'di 4/25/2000 19:17'!
printOn: aStream indent: level precedence: p 

	p > 0 ifTrue: [aStream nextPut: $(].
	messages first printReceiver: receiver on: aStream indent: level.
	1 to: messages size do: 
		[:i | (messages at: i) printOn: aStream indent: level.
		i < messages size ifTrue: 
				[aStream nextPut: $;.
				messages first precedence >= 2 ifTrue: [aStream crtab: level + 1]]].
	p > 0 ifTrue: [aStream nextPut: $)]! !


!CascadeNode methodsFor: '*eToys-tiles' stamp: 'RAA 2/22/2001 13:56'!
asMorphicSyntaxIn: parent

	^parent
		cascadeNode: self 
		receiver: receiver 
		messages: messages
! !
Object subclass: #Categorizer
	instanceVariableNames: 'categoryArray categoryStops elementArray'
	classVariableNames: 'Default NullCategory'
	poolDictionaries: ''
	category: 'Kernel-Classes'!

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
addCategory: newCategory
	^ self addCategory: newCategory before: nil ! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
addCategory: catString before: nextCategory
	"Add a new category named heading.
	If default category exists and is empty, remove it.
	If nextCategory is nil, then add the new one at the end,
	otherwise, insert it before nextCategory."
	| index newCategory |
	newCategory _ catString asSymbol.
	(categoryArray indexOf: newCategory) > 0
		ifTrue: [^self].	"heading already exists, so done"
	index _ categoryArray indexOf: nextCategory
		ifAbsent: [categoryArray size + 1].
	categoryArray _ categoryArray
		copyReplaceFrom: index
		to: index-1
		with: (Array with: newCategory).
	categoryStops _ categoryStops
		copyReplaceFrom: index
		to: index-1
		with: (Array with: (index = 1
				ifTrue: [0]
				ifFalse: [categoryStops at: index-1])).
	"remove empty default category"
	(newCategory ~= Default
			and: [(self listAtCategoryNamed: Default) isEmpty])
		ifTrue: [self removeCategory: Default]! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
allMethodSelectors
	"give a list of all method selectors."

	^ elementArray copy sort! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:29'!
categories
	"Answer an Array of categories (names)."
	categoryArray isNil ifTrue: [^ nil].
	(categoryArray size = 1 
		and: [categoryArray first = Default & (elementArray size = 0)])
		ifTrue: [^Array with: NullCategory].
	^categoryArray! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
categories: anArray 
	"Reorder my categories to be in order of the argument, anArray. If the 
	resulting organization does not include all elements, then give an error."

	| newCategories newStops newElements catName list runningTotal | 
	newCategories _ Array new: anArray size.
	newStops _ Array new: anArray size.
	newElements _ Array new: 0.
	runningTotal _ 0.
	1 to: anArray size do:
		[:i |
		catName _ (anArray at: i) asSymbol.
		list _ self listAtCategoryNamed: catName.
				newElements _ newElements, list.
				newCategories at: i put: catName.
				newStops at: i put: (runningTotal _ runningTotal + list size)].
	elementArray do:
		[:element | "check to be sure all elements are included"
		(newElements includes: element)
			ifFalse: [^self error: 'New categories must match old ones']].
	"Everything is good, now update my three arrays."
	categoryArray _ newCategories.
	categoryStops _ newStops.
	elementArray _ newElements! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
categoryOfElement: element 
	"Answer the category associated with the argument, element."

	| index |
	index _ self numberOfCategoryOfElement: element.
	index = 0
		ifTrue: [^nil]
		ifFalse: [^categoryArray at: index]! !

!Categorizer methodsFor: 'accessing' stamp: 'hmm 2/25/2005 10:53'!
changeFromCategorySpecs: categorySpecs 
	"Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment."

	| oldElements newElements newCategories newStops currentStop temp ii cc catSpec |
	oldElements _ elementArray asSet.
	newCategories _ Array new: categorySpecs size.
	newStops _ Array new: categorySpecs size.
	currentStop _ 0.
	newElements _ WriteStream on: (Array new: 16).
	1 to: categorySpecs size do: 
		[:i | | selectors |
		catSpec _ categorySpecs at: i.
		newCategories at: i put: catSpec first asSymbol.
		selectors := catSpec allButFirst collect: [:each | each isSymbol
							ifTrue: [each]
							ifFalse: [each printString asSymbol]].
		selectors asSortedCollection do:
			[:elem |
			(oldElements remove: elem ifAbsent: [nil]) notNil ifTrue:
				[newElements nextPut: elem.
				currentStop _ currentStop+1]].
		newStops at: i put: currentStop].

	"Ignore extra elements but don't lose any existing elements!!"
	oldElements _ oldElements collect:
		[:elem | Array with: (self categoryOfElement: elem) with: elem].
	newElements _ newElements contents.
	categoryArray _ newCategories.
	(cc _ categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element"
		temp _ categoryArray asOrderedCollection.
		temp removeAll: categoryArray asSet asOrderedCollection.
		temp do: [:dup | 
			ii _ categoryArray indexOf: dup.
			[dup _ (dup,' #2') asSymbol.  cc includes: dup] whileTrue.
			cc add: dup.
			categoryArray at: ii put: dup]].
	categoryStops _ newStops.
	elementArray _ newElements.
	oldElements do: [:pair | self classify: pair last under: pair first].! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
changeFromString: aString 
	"Parse the argument, aString, and make this be the receiver's structure."

	| categorySpecs |
	categorySpecs _ Scanner new scanTokens: aString.
	"If nothing was scanned and I had no elements before, then default me"
	(categorySpecs isEmpty and: [elementArray isEmpty])
		ifTrue: [^ self setDefaultList: Array new].

	^ self changeFromCategorySpecs: categorySpecs! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
classify: element under: heading 
	self classify: element under: heading suppressIfDefault: true! !

!Categorizer methodsFor: 'accessing' stamp: 'al 11/28/2005 22:05'!
classify: element under: heading suppressIfDefault: aBoolean
	"Store the argument, element, in the category named heading.   If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein"

	| catName catIndex elemIndex realHeading |
	((heading = NullCategory) or: [heading == nil])
		ifTrue: [realHeading := Default]
		ifFalse: [realHeading := heading asSymbol].
	(catName := self categoryOfElement: element) = realHeading
		ifTrue: [^ self].  "done if already under that category"

	catName ~~ nil ifTrue: 
		[(aBoolean and: [realHeading = Default])
				ifTrue: [^ self].	  "return if non-Default category already assigned in memory"
		self basicRemoveElement: element].	"remove if in another category"

	(categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading].

	catIndex := categoryArray indexOf: realHeading.
	elemIndex := 
		catIndex > 1
			ifTrue: [categoryStops at: catIndex - 1]
			ifFalse: [0].
	[(elemIndex := elemIndex + 1) <= (categoryStops at: catIndex) 
		and: [element >= (elementArray at: elemIndex)]] whileTrue.

	"elemIndex is now the index for inserting the element. Do the insertion before it."
	elementArray := elementArray copyReplaceFrom: elemIndex to: elemIndex-1
						with: (Array with: element).

	"add one to stops for this and later categories"
	catIndex to: categoryArray size do: 
		[:i | categoryStops at: i put: (categoryStops at: i) + 1].

	((categoryArray includes: Default)
		and: [(self listAtCategoryNamed: Default) size = 0]) ifTrue: [self removeCategory: Default].
		
	self assertInvariant.! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
classifyAll: aCollection under: heading

	aCollection do:
		[:element | self classify: element under: heading]! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:20'!
elementCategoryDict
	| dict firstIndex lastIndex |
	elementArray isNil ifTrue: [^ nil].
	dict _ Dictionary new: elementArray size.
	1to: categoryStops size do: [:cat |
		firstIndex _ self firstIndexOfCategoryNumber: cat.
		lastIndex _ self lastIndexOfCategoryNumber: cat.
		firstIndex to: lastIndex do: [:el |
			dict at: (elementArray at: el) put: (categoryArray at: cat)].
	].
	^ dict.! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'!
isEmptyCategoryNamed: categoryName
	| i |
	i _ categoryArray indexOf: categoryName ifAbsent: [^false].
	^self isEmptyCategoryNumber: i! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'!
isEmptyCategoryNumber: anInteger

	| firstIndex lastIndex |
	(anInteger < 1 or: [anInteger > categoryStops size])
		ifTrue: [^ true].
	firstIndex _ self firstIndexOfCategoryNumber: anInteger.
	lastIndex _  self lastIndexOfCategoryNumber: anInteger.
	^ firstIndex > lastIndex! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
listAtCategoryNamed: categoryName
	"Answer the array of elements associated with the name, categoryName."

	| i |
	i _ categoryArray indexOf: categoryName ifAbsent: [^Array new].
	^self listAtCategoryNumber: i! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 13:51'!
listAtCategoryNumber: anInteger 
	"Answer the array of elements stored at the position indexed by anInteger.  Answer nil if anInteger is larger than the number of categories."

	| firstIndex lastIndex |
	(anInteger < 1 or: [anInteger > categoryStops size])
		ifTrue: [^ nil].
	firstIndex _ self firstIndexOfCategoryNumber: anInteger.
	lastIndex _  self lastIndexOfCategoryNumber: anInteger.
	^elementArray copyFrom: firstIndex to: lastIndex! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
numberOfCategoryOfElement: element 
	"Answer the index of the category with which the argument, element, is 
	associated."

	| categoryIndex elementIndex |
	categoryIndex _ 1.
	elementIndex _ 0.
	[(elementIndex _ elementIndex + 1) <= elementArray size]
		whileTrue: 
			["point to correct category"
			[elementIndex > (categoryStops at: categoryIndex)]
				whileTrue: [categoryIndex _ categoryIndex + 1].
			"see if this is element"
			element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]].
	^0! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
removeCategory: cat 
	"Remove the category named, cat. Create an error notificiation if the 
	category has any elements in it."

	| index lastStop |
	index _ categoryArray indexOf: cat ifAbsent: [^self].
	lastStop _ 
		index = 1
			ifTrue: [0]
			ifFalse: [categoryStops at: index - 1].
	(categoryStops at: index) - lastStop > 0 
		ifTrue: [^self error: 'cannot remove non-empty category'].
	categoryArray _ categoryArray copyReplaceFrom: index to: index with: Array new.
	categoryStops _ categoryStops copyReplaceFrom: index to: index with: Array new.
	categoryArray size = 0
		ifTrue:
			[categoryArray _ Array with: Default.
			categoryStops _ Array with: 0]
! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:50'!
removeElement: element 
	^ self basicRemoveElement: element! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
removeEmptyCategories
	"Remove empty categories."

	| categoryIndex currentStop keptCategories keptStops |
	keptCategories _ WriteStream on: (Array new: 16).
	keptStops _ WriteStream on: (Array new: 16).
	currentStop _ categoryIndex _ 0.
	[(categoryIndex _ categoryIndex + 1) <= categoryArray size]
		whileTrue: 
			[(categoryStops at: categoryIndex) > currentStop
				ifTrue: 
					[keptCategories nextPut: (categoryArray at: categoryIndex).
					keptStops nextPut: (currentStop _ categoryStops at: categoryIndex)]].
	categoryArray _ keptCategories contents.
	categoryStops _ keptStops contents.
	categoryArray size = 0
		ifTrue:
			[categoryArray _ Array with: Default.
			categoryStops _ Array with: 0]

	"ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
renameCategory: oldCatString toBe: newCatString
	"Rename a category. No action if new name already exists, or if old name does not exist."
	| index oldCategory newCategory |
	oldCategory _ oldCatString asSymbol.
	newCategory _ newCatString asSymbol.
	(categoryArray indexOf: newCategory) > 0
		ifTrue: [^ self].	"new name exists, so no action"
	(index _ categoryArray indexOf: oldCategory) = 0
		ifTrue: [^ self].	"old name not found, so no action"
	categoryArray _ categoryArray copy.  "need to change identity so smart list update will notice the change"
	categoryArray at: index put: newCategory! !

!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'!
sortCategories
	| privateCategories publicCategories newCategories |

	privateCategories _ self categories select:
		[:one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1].
	publicCategories _ self categories copyWithoutAll: privateCategories.
	newCategories _ publicCategories asSortedCollection asOrderedCollection
		addAll: privateCategories asSortedCollection;
		asArray.
	self categories: newCategories! !


!Categorizer methodsFor: 'fileIn/Out' stamp: 'NS 4/5/2004 17:44'!
scanFrom: aStream
	"Reads in the organization from the next chunk on aStream.
	Categories or elements not found in the definition are not affected.
	New elements are ignored."

	self changeFromString: aStream nextChunk.
	aStream skipStyleChunk.! !


!Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	| elementIndex |
	elementIndex _ 1.
	1 to: categoryArray size do: 
		[:i | 
		aStream nextPut: $(.
		(categoryArray at: i) asString printOn: aStream.
		[elementIndex <= (categoryStops at: i)]
			whileTrue: 
				[aStream space; nextPutAll: (elementArray at: elementIndex).
				elementIndex _ elementIndex + 1].
		aStream nextPut: $); cr]! !

!Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'!
printOnStream: aStream 
	"Refer to the comment in Object|printOn:."

	| elementIndex  |
	elementIndex _ 1.
	1 to: categoryArray size do: 
		[:i | 
		aStream print: '(';
		write:(categoryArray at:i).		" is the asString redundant? "

		[elementIndex <= (categoryStops at: i)]
			whileTrue: 
				[aStream print:' '; write:(elementArray at: elementIndex).
				elementIndex _ elementIndex + 1].
		aStream print:')'.
		aStream cr]! !

!Categorizer methodsFor: 'printing' stamp: 'lr 6/22/2005 08:12'!
printString
	^ String streamContents: [ :stream | self printOn: stream ].! !


!Categorizer methodsFor: 'private' stamp: 'dvf 8/11/2005 22:38'!
assertInvariant
	self assert: (elementArray size = categoryStops last)! !

!Categorizer methodsFor: 'private' stamp: 'dvf 8/10/2005 14:19'!
basicRemoveElement: element 
	"Remove the selector, element, from all categories."
	| categoryIndex elementIndex nextStop newElements |
	categoryIndex := 1.
	elementIndex := 0.
	nextStop := 0.
	"nextStop keeps track of the stops in the new element array"
	newElements := WriteStream on: (Array new: elementArray size).
	[(elementIndex := elementIndex + 1) <= elementArray size]
		whileTrue: 
			[[elementIndex > (categoryStops at: categoryIndex)]
				whileTrue: 
					[categoryStops at: categoryIndex put: nextStop.
					categoryIndex := categoryIndex + 1].
			(elementArray at: elementIndex) = element
				ifFalse: 
					[nextStop := nextStop + 1.
					newElements nextPut: (elementArray at: elementIndex)]].
	[categoryIndex <= categoryStops size]
		whileTrue: 
			[categoryStops at: categoryIndex put: nextStop.
			categoryIndex := categoryIndex + 1].
	elementArray := newElements contents.
	self assertInvariant.! !

!Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:44'!
elementArray

	^ elementArray! !

!Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:51'!
firstIndexOfCategoryNumber: anInteger
	anInteger < 1 ifTrue: [^ nil].
	^ (anInteger > 1
			ifTrue: [(categoryStops at: anInteger - 1) + 1]
			ifFalse: [1]).! !

!Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:52'!
lastIndexOfCategoryNumber: anInteger
	anInteger > categoryStops size ifTrue: [^ nil].
	^ categoryStops at: anInteger! !

!Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:50'!
setDefaultList: aSortedCollection

	categoryArray _ Array with: Default.
	categoryStops _ Array with: aSortedCollection size.
	elementArray _ aSortedCollection asArray! !

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

Categorizer class
	instanceVariableNames: ''!

!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'!
allCategory
	"Return a symbol that represents the virtual all methods category."

	^ '-- all --' asSymbol! !

!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'!
default 
	^ Default! !

!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/6/2004 11:48'!
initialize
	"	self  initialize	"
	
	Default _ 'as yet unclassified' asSymbol.
	NullCategory _ 'no messages' asSymbol.! !

!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'!
nullCategory
	^ NullCategory! !


!Categorizer class methodsFor: 'documentation' stamp: 'NS 4/5/2004 17:44'!
documentation
	"Instances consist of an Array of category names (categoryArray), each of 
	which refers to an Array of elements (elementArray). This association is 
	made through an Array of stop indices (categoryStops), each of which is 
	the index in elementArray of the last element (if any) of the 
	corresponding category. For example: categories _ Array with: 'firstCat' 
	with: 'secondCat' with: 'thirdCat'. stops _ Array with: 1 with: 4 with: 4. 
	elements _ Array with: #a with: #b with: #c with: #d. This means that 
	category firstCat has only #a, secondCat has #b, #c, and #d, and 
	thirdCat has no elements. This means that stops at: stops size must be the 
	same as elements size." ! !


!Categorizer class methodsFor: 'housekeeping' stamp: 'NS 4/6/2004 11:48'!
sortAllCategories

	self allSubInstances
		do: [:x | x sortCategories]! !


!Categorizer class methodsFor: 'instance creation' stamp: 'NS 4/5/2004 17:44'!
defaultList: aSortedCollection 
	"Answer an instance of me with initial elements from the argument, 
	aSortedCollection."

	^self new setDefaultList: aSortedCollection! !
Viewer subclass: #CategoryViewer
	instanceVariableNames: 'namePane chosenCategorySymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!CategoryViewer commentStamp: '<historical>' prior: 0!
A viewer on an object.  Consists of three panes:
   Header pane -- category-name, arrows for moving among categories, etc.
   List pane -- contents are a list of subparts in the chosen category.
   Editing pane -- optional, a detail pane with info relating to the selected element of the list pane.!


!CategoryViewer methodsFor: 'categories' stamp: 'sw 7/7/2004 21:59'!
adjustColorsAndBordersWithin
	"Adjust the colors and borders of submorphs to suit current fashion"

	self allMorphsDo: [:aMorph | 
		(aMorph isKindOf: ViewerLine) ifTrue:
			[aMorph layoutInset: 1].
		(aMorph isKindOf: TilePadMorph) ifTrue:
			[aMorph beTransparent].
		(aMorph isKindOf: PhraseTileMorph) ifTrue:
			[aMorph beTransparent.
			aMorph borderWidth: 0].

		(aMorph isKindOf: TileMorph)
			ifTrue:
				[aMorph borderWidth: 1]].

	self borderWidth: 1! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 8/22/2002 14:00'!
beReplacedByCategory: chosenCategory
	"Be replaced by a category pane pointed at the chosen category"

	self outerViewer replaceSubmorph: self by: (self outerViewer categoryViewerFor: chosenCategory)
	! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:55'!
categoryNameWhoseTranslatedWordingIs: aWording
	"Answer the category name with the given wording"

	| result |
	result _ self currentVocabulary categoryWhoseTranslatedWordingIs: aWording.
	^ result
		ifNotNil:
			[result categoryName]
		ifNil:
			[aWording]! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 9/12/2001 20:34'!
categoryWhoseTranslatedWordingIs: aWording
	"Answer the elementCategory with the given wording"

	^ self currentVocabulary categoryWhoseTranslatedWordingIs: aWording! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 10/30/2001 13:45'!
categoryWording: aCategoryWording
	"Make the category with the given wording be my current one."

	| actualPane |
	(actualPane _ namePane renderedMorph) firstSubmorph contents: aCategoryWording; color: Color black.
	actualPane extent: actualPane firstSubmorph extent.

	self removeAllButFirstSubmorph. "that being the header"
	self addAllMorphs:
		((scriptedPlayer tilePhrasesForCategory: chosenCategorySymbol inViewer: self)).
	self enforceTileColorPolicy.
	self secreteCategorySymbol.
	self world ifNotNil: [self world startSteppingSubmorphsOf: self].
	self adjustColorsAndBordersWithin.

	owner ifNotNil: [owner isStandardViewer ifTrue: [owner fitFlap]]! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 3/2/2004 23:53'!
chooseCategory
	"The mouse went down on my category-list control; pop up a list of category choices"

	| aList aMenu reply aLinePosition lineList |
	aList _ scriptedPlayer categoriesForViewer: self.

	aLinePosition _ aList indexOf: #miscellaneous ifAbsent: [nil].
	aList _ aList collect:	
		[:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol].

	lineList _ aLinePosition ifNil: [#()] ifNotNil: [Array with: aLinePosition].
	aList size == 0 ifTrue: [aList add: ScriptingSystem nameForInstanceVariablesCategory translated].
	aMenu _ CustomMenu labels: aList lines: lineList selections: aList.
	reply _ aMenu startUpWithCaption: 'category' translated.
	reply ifNil: [^ self].
	self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol
! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:56'!
chooseCategoryWhoseTranslatedWordingIs: aWording
	"Choose the category with the given wording"

	self chosenCategorySymbol: (self categoryNameWhoseTranslatedWordingIs: aWording)
! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 5/29/2001 22:43'!
chosenCategorySymbol
	"Answer the inherent category currently being shown, not necessarily the same as the translated word."

	^ chosenCategorySymbol ifNil: [self secreteCategorySymbol]! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:49'!
chosenCategorySymbol: aCategorySymbol
	"Make the given category be my current one."

	| aCategory wording |
	chosenCategorySymbol _ aCategorySymbol.
	aCategory _ self currentVocabulary categoryAt: chosenCategorySymbol.
	wording _ aCategory ifNil: [aCategorySymbol] ifNotNil: [aCategory wording].
	self categoryWording: wording! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 2/23/2001 22:29'!
currentCategory
	"Answer the symbol representing the receiver's currently-selected category"

	| current |
	current _ namePane renderedMorph firstSubmorph contents.
	^ current ifNotNil: [current asSymbol] ifNil: [#basic]! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 10/24/1998 14:24'!
downArrowHit
	self previousCategory! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:57'!
nextCategory
	"Change the receiver to point at the category following the one currently seen"

	| aList anIndex newIndex already aChoice |
	aList _ (scriptedPlayer categoriesForViewer: self) collect:
		[:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol].

	already _ self outerViewer ifNil: [#()] ifNotNil: [self outerViewer categoriesCurrentlyShowing].
	anIndex _ aList indexOf: self currentCategory ifAbsent: [0].
	newIndex _ anIndex = aList size
		ifTrue:		[1]
		ifFalse:		[anIndex + 1].
	[already includes: (aChoice _ aList at: newIndex)] whileTrue:
		[newIndex _ (newIndex \\ aList size) + 1].
	self chooseCategoryWhoseTranslatedWordingIs: aChoice! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:53'!
previousCategory
	"Change the receiver to point at the category preceding the one currently seen"

	| aList anIndex newIndex already aChoice |
	aList _ (scriptedPlayer categoriesForViewer: self) collect:
		[:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol].
	already _ self outerViewer ifNil: [#()] ifNotNil: [self outerViewer categoriesCurrentlyShowing].
	anIndex _ aList indexOf: self currentCategory ifAbsent: [aList size + 1].
	newIndex _ anIndex = 1
		ifTrue:		[aList size]
		ifFalse:		[anIndex - 1].
	[already includes: (aChoice _ aList at: newIndex)] whileTrue:
		[newIndex _ newIndex = 1 ifTrue: [aList size] ifFalse: [newIndex - 1]].

	self chooseCategoryWhoseTranslatedWordingIs: aChoice! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:50'!
secreteCategorySymbol
	"Set my chosenCategorySymbol by translating back from its representation in the namePane.  Answer the chosenCategorySymbol"

	| aCategory |
	aCategory _ self currentVocabulary categoryWhoseTranslatedWordingIs: self currentCategory.
	^ chosenCategorySymbol _ aCategory
		ifNotNil:
			[aCategory categoryName]
		ifNil:
			[self currentCategory]! !

!CategoryViewer methodsFor: 'categories' stamp: 'nk 9/2/2004 19:37'!
showCategoriesFor: aSymbol
	"Put up a pop-up list of categories in which aSymbol is filed; replace the receiver with a CategoryViewer for the one the user selects, if any"

	| allCategories aVocabulary hits meths chosen |
	aVocabulary _ self currentVocabulary.
	allCategories _ scriptedPlayer categoriesForVocabulary: aVocabulary limitClass: ProtoObject.

	hits _ allCategories select:
		[:aCategory | 
			meths _ aVocabulary allMethodsInCategory: aCategory forInstance: scriptedPlayer ofClass: scriptedPlayer class.
			meths includes: aSymbol].

	hits isEmpty ifTrue: [ ^self ].

	chosen _ (SelectionMenu selections: hits) startUp.
	chosen isEmptyOrNil ifFalse:
		[self outerViewer addCategoryViewerFor: chosen atEnd: true]

	! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 10/24/1998 14:25'!
upArrowHit
	self nextCategory! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 5/29/2001 11:41'!
updateCategoryNameTo: aName
	"Update the category name, because of a language change."

	| actualPane |
	(actualPane _ namePane firstSubmorph) contents: aName; color: Color black.
	namePane extent: actualPane extent.
	self world ifNotNil: [self world startSteppingSubmorphsOf: self]
! !


!CategoryViewer methodsFor: 'editing pane' stamp: 'nb 6/17/2003 12:25'!
contents: c notifying: k
	"later, spruce this up so that it can accept input such as new method source"
	
	Beeper beep.
	^ false! !


!CategoryViewer methodsFor: 'entries' stamp: 'sw 7/25/2004 15:37'!
addIsOverColorDetailTo: aRow
	"Special-casee code for the boolean-valued phrase variously known as is-over-color or sees-color."

	| clrTile |
	aRow addMorphBack: (Morph new color: self color; extent: 2@10).  "spacer"
	aRow addMorphBack: (clrTile _ Color blue newTileMorphRepresentative).

"The following commented-out code put a readout up; the readout was very nice, but was very consumptive of cpu time, which is why the is-over-color tile got removed from the viewer long ago.  Now is-over-color is reinstated to the viewer, minus the expensive readout..."

"	aRow addMorphBack: (AlignmentMorph new beTransparent).
	readout _ UpdatingStringMorphWithArgument new
			target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil;
			argumentTarget: clrTile colorSwatch argumentGetSelector: #color.
	readout useDefaultFormat.
	aTile _ StringReadoutTile new typeColor: Color lightGray lighter.
	aTile addMorphBack: readout.
	aRow addMorphBack: aTile.
	aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30"! !

!CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:20'!
addOverlapsDetailTo: aRow
	"Disreputable magic: add necessary items to a viewer row abuilding for the overlaps phrase"

	aRow addMorphBack: (Morph new color: self color; extent: 2@10).  "spacer"
	aRow addMorphBack:  self tileForSelf.
	aRow addMorphBack: (AlignmentMorph new beTransparent).  "flexible spacer"

! !

!CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:21'!
addTouchesADetailTo: aRow
	| clrTile |
	aRow addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer"
	aRow addMorphBack: (clrTile _ self tileForSelf).
	aRow addMorphBack: (AlignmentMorph new beTransparent).  "flexible spacer"

	"readout _ UpdatingStringMorphWithArgument new
			target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil;
			argumentTarget: clrTile colorSwatch argumentGetSelector: #color.
	readout useDefaultFormat.
	aTile _ StringReadoutTile new typeColor: Color lightGray lighter.
	aTile addMorphBack: readout.
	aRow addMorphBack: aTile.
	aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30"! !

!CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:20'!
infoButtonFor: aScriptOrSlotSymbol
	"Answer a fully-formed morph that will serve as the 'info button' alongside an entry corresponding to the given slot or script symbol.  If no such button is appropriate, answer a transparent graphic that fills the same space."

	| aButton |
	(self wantsRowMenuFor: aScriptOrSlotSymbol) ifFalse:
		["Fill the space with sweet nothing, since there is no meaningful menu to offer"
		aButton _ RectangleMorph new beTransparent extent: (17@20).
		aButton borderWidth: 0.
		^ aButton].

	aButton _ IconicButton new labelGraphic: Cursor menu.
	aButton target: scriptedPlayer;
		actionSelector: #infoFor:inViewer:;
		arguments: (Array with:aScriptOrSlotSymbol with: self);
		color: Color transparent;
		borderWidth: 0;
		shedSelvedge;
		actWhen: #buttonDown.
	aButton setBalloonText: 'Press here to get a menu' translated.
	^ aButton! !

!CategoryViewer methodsFor: 'entries' stamp: 'yo 8/18/2005 10:37'!
phraseForCommandFrom: aMethodInterface
	"Answer a phrase for the non-slot-like command represented by aMethodInterface - classic tiles"

	| aRow resultType cmd names argType argTile selfTile aPhrase balloonTextSelector stat inst aDocString universal tileBearingHelp |
	aDocString _ aMethodInterface documentation.
	aDocString = 'no help available' ifTrue: [aDocString _ nil].
	names _ scriptedPlayer class namedTileScriptSelectors.

	resultType _ aMethodInterface resultType.
	cmd _ aMethodInterface selector.
	(universal _ scriptedPlayer isUniversalTiles)
		ifTrue:
			[aPhrase _ scriptedPlayer universalTilesForInterface: aMethodInterface]
		ifFalse: [cmd numArgs == 0
			ifTrue:
				[aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary.
				aPhrase setOperator: cmd
					type: resultType
					rcvrType: #Player]
			ifFalse:
				["only one arg supported in classic tiles, so if this is fed
				with a selector with > 1 arg, results will be very strange"
				argType _ aMethodInterface typeForArgumentNumber: 1.
				aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary.
				(self isSpecialPatchReceiver: scriptedPlayer and: cmd) ifTrue: [
					aPhrase setOperator: cmd
						type: resultType
						rcvrType: #Patch
						argType: argType.
				] ifFalse: [
					aPhrase setOperator: cmd
						type: resultType
						rcvrType: #Player
						argType: argType.
				].
				(self isSpecialPatchCase: scriptedPlayer and: cmd) ifTrue: [
					argTile _ (Vocabulary vocabularyForType: argType) defaultArgumentTileFor: scriptedPlayer.
				] ifFalse: [
					argTile _ ScriptingSystem tileForArgType: argType.
				].
				(#(bounce: wrap:) includes: cmd) ifTrue:
					["help for the embattled bj"
					argTile setLiteral: 'silence'; updateLiteralLabel].
				argTile position: aPhrase lastSubmorph position.
				aPhrase lastSubmorph addMorph: argTile]].

	(scriptedPlayer slotInfo includesKey: cmd)
		ifTrue: [balloonTextSelector _ #userSlot].

	(scriptedPlayer belongsToUniClass and: [scriptedPlayer class includesSelector: cmd])
		ifTrue:
			[aDocString ifNil:
				[aDocString _ (scriptedPlayer class userScriptForPlayer: scriptedPlayer selector: cmd) documentation].
			aDocString ifNil:
				[balloonTextSelector _ #userScript]].

	tileBearingHelp _ universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]. 
	aDocString
		ifNotNil:
			[tileBearingHelp setBalloonText: aDocString]
		ifNil:
			[balloonTextSelector ifNil:
				[tileBearingHelp setProperty: #inherentSelector toValue: cmd.
				balloonTextSelector _ #methodComment].
			tileBearingHelp balloonTextSelector: balloonTextSelector].
	aPhrase markAsPartsDonor.
	cmd == #emptyScript ifTrue:
		[aPhrase setProperty: #newPermanentScript toValue: true.
		aPhrase setProperty: #newPermanentPlayer toValue: scriptedPlayer.
		aPhrase submorphs second setBalloonText: 
'drag and drop to 
add a new script' translated].

	universal ifFalse:
		[selfTile _ self tileForSelf.
		selfTile position: aPhrase firstSubmorph position.
		aPhrase firstSubmorph addMorph: selfTile].

	aRow _ ViewerLine newRow borderWidth: 0; color: self color.
	aRow elementSymbol: cmd asSymbol.

	aRow addMorphBack: (ScriptingSystem tryButtonFor: aPhrase).
	aRow addMorphBack: (Morph new extent: 2@2; beTransparent).
	aRow addMorphBack: (self infoButtonFor: cmd).
	aRow addMorphBack: aPhrase.
	aPhrase on: #mouseEnter send: #addCommandFeedback to: aRow.
	aPhrase on: #mouseLeave send: #removeHighlightFeedback to: aRow.
	aPhrase on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow.

	(names includes: cmd) ifTrue:
		[aPhrase userScriptSelector: cmd.
		cmd numArgs == 0 ifTrue:
			[aPhrase beTransparent.
			aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
			aRow addMorphBack: (stat _ (inst _ scriptedPlayer scriptInstantiationForSelector: cmd) statusControlMorph).
			inst updateStatusMorph: stat]].

	aRow beSticky; disableDragNDrop.

	^ aRow! !

!CategoryViewer methodsFor: 'entries' stamp: 'yo 3/7/2005 08:45'!
phraseForVariableFrom: aMethodInterface
	"Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated.  Functions in both universalTiles mode and classic mode.  Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType."

	| anArrow slotName getterButton cover inner aRow doc setter tryer universal hotTileForSelf spacer buttonFont varName |
	aRow _ ViewerLine newRow
		color: self color;
		beSticky;
		elementSymbol: (slotName _ aMethodInterface selector);
		wrapCentering: #center;
		cellPositioning: #leftCenter.
	(universal _ scriptedPlayer isUniversalTiles) ifFalse:
		[buttonFont _ Preferences standardEToysFont.
			aRow addMorphBack: (Morph new color: self color;
					 extent: (((buttonFont widthOfString: '!!') + 8) @ (buttonFont height + 6));
					 yourself)].  "spacer"
	aRow addMorphBack: (self infoButtonFor: slotName).
	aRow addMorphBack: (Morph new color: self color; extent: 0@10).  " vertical spacer"
	universal
		ifTrue:
			[inner _ scriptedPlayer universalTilesForGetterOf: aMethodInterface.
			cover _ Morph new color: Color transparent.
			cover extent: inner fullBounds extent.
			(getterButton _ cover copy) addMorph: cover; addMorphBack: inner.
			cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: 
					to: self withValue: aMethodInterface.
			aRow addMorphFront:  (tryer _ ScriptingSystem tryButtonFor: inner).
			tryer color: tryer color lighter lighter]
		ifFalse:
			[hotTileForSelf _ self tileForSelf bePossessive.
			hotTileForSelf  on: #mouseDown send: #makeGetter:event:from:
				to: self
				withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType).
			aRow addMorphBack: hotTileForSelf.
			aRow addMorphBack: (spacer _ Morph new color: self color; extent: 2@10).
			spacer on: #mouseEnter send: #addGetterFeedback to: aRow.
			spacer on: #mouseLeave send: #removeHighlightFeedback to: aRow.
			spacer on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow.
			spacer  on: #mouseDown send: #makeGetter:event:from:
				to: self
				withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType).
			hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow.
			hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow.
			hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow.
			getterButton _ self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType].
	aRow addMorphBack: getterButton.
	getterButton on: #mouseEnter send: #addGetterFeedback to: aRow.
	getterButton on: #mouseLeave send: #removeHighlightFeedback to: aRow.
	getterButton on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow.
	(doc _ aMethodInterface documentation) ifNotNil:
		[getterButton setBalloonText: doc].

	(scriptedPlayer slotInfo includesKey: (varName _ Utilities inherentSelectorForGetter: slotName)) "user slot"
		ifTrue:
			["aRow addTransparentSpacerOfSize: 3@0.
			aRow addMorphBack: (self slotTypeMenuButtonFor: varName)"].

	universal ifFalse:
		[(slotName == #seesColor:) ifTrue:
			[self addIsOverColorDetailTo: aRow.
			^ aRow].
		(slotName == #touchesA:) ifTrue:
			[self addTouchesADetailTo: aRow.
			^ aRow].
		(slotName == #overlaps: or: [ slotName == #overlapsAny:]) ifTrue:
			[self addOverlapsDetailTo: aRow.
			^ aRow]].
	aRow addMorphBack: (AlignmentMorph new beTransparent).  "flexible spacer"
	(setter _ aMethodInterface companionSetterSelector) ifNotNil:
		[aRow addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer"
		anArrow _ universal 
			ifTrue: [self arrowSetterButton: #newMakeSetterFromInterface:evt:from:  
						args: aMethodInterface]
			ifFalse: [self arrowSetterButton: #makeSetter:from:forPart:
						args: (Array with: slotName with: aMethodInterface resultType)].
		anArrow beTransparent.
		universal ifFalse:
			[anArrow on: #mouseEnter send: #addSetterFeedback to: aRow.
			anArrow on: #mouseLeave send: #removeHighlightFeedback to: aRow.
			anArrow on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow].
		aRow addMorphBack: anArrow].
	(#(color:sees: playerSeeingColor copy touchesA: overlaps: getTurtleAt: getTurtleOf:) includes: slotName) ifFalse:
 		[(universal and: [slotName == #seesColor:]) ifFalse:
			[aMethodInterface wantsReadoutInViewer ifTrue: 
				[aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]].
	anArrow ifNotNil: [anArrow step].
	^ aRow! !

!CategoryViewer methodsFor: 'entries' stamp: 'sw 7/4/2004 01:09'!
readoutFor: partName type: partType readOnly: readOnly getSelector: getSelector putSelector: putSelector
	"Answer a readout morph for the given part"

	| readout delta |
	readout _ (Vocabulary vocabularyForType: partType) updatingTileForTarget: scriptedPlayer partName: partName getter: getSelector setter: putSelector.

	(partType == #Number) ifTrue:
		[(delta _ scriptedPlayer arrowDeltaFor: getSelector) = 1
			ifFalse:
				[readout setProperty: #arrowDelta toValue: delta].
		scriptedPlayer setFloatPrecisionFor: readout updatingStringMorph].

	readout step.
	^ readout! !

!CategoryViewer methodsFor: 'entries' stamp: 'nk 10/14/2004 10:54'!
wantsRowMenuFor: aSymbol
	"Answer whether a viewer row for the given symbol should have a menu button on it"

	| elementType |

	true ifTrue: [^ true].  "To allow show categories item.  So someday this method can be removed, and its sender can stop sending it..."

	elementType _ scriptedPlayer elementTypeFor: aSymbol vocabulary: self currentVocabulary.
	(elementType == #systemScript) ifTrue: [^ false].
	((elementType == #systemSlot) and:
		[#(color:sees: touchesA: overlaps: overlapsAny:) includes: aSymbol]) ifTrue: [^ false].
	^ true! !


!CategoryViewer methodsFor: 'e-toy support' stamp: 'sw 9/13/2001 19:16'!
adoptVocabulary: aVocabulary
	"Adopt the given vocabulary as the one used in this viewer."

	| aCategory |
	chosenCategorySymbol ifNil: [^ self delete].
	aCategory _ aVocabulary categoryAt: chosenCategorySymbol.
	aCategory ifNil: [self delete] ifNotNil: [self updateCategoryNameTo: aCategory wording].
	super adoptVocabulary: aVocabulary! !

!CategoryViewer methodsFor: 'e-toy support' stamp: 'mir 7/15/2004 15:19'!
localeChanged
	"Update myself to reflect the change in locale"

	chosenCategorySymbol ifNil: [^ self delete].
	self updateCategoryNameTo: ((self currentVocabulary ifNil: [Vocabulary eToyVocabulary]) categoryWordingAt: chosenCategorySymbol)! !


!CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 9/1/2003 13:51'!
arrowSetterButton: sel args: argArray

	| m |
	m _ RectangleMorph new
		color: (ScriptingSystem colorForType: #command);
		extent: 24@TileMorph defaultH;
		borderWidth: 0.
	m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')).
	m setBalloonText: 'drag from here to obtain an assignment phrase.' translated.
	m on: #mouseDown send: sel
		to: self
		withValue: argArray.
	^ m
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 9/1/2003 13:51'!
arrowSetterButtonFor: partName type: partType

	| m |
	m _ RectangleMorph new
		color: (ScriptingSystem colorForType: #command);
		extent: 24@TileMorph defaultH;
		borderWidth: 0.
	m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')).
	m setBalloonText: 'drag from here to obtain an assignment phrase.' translated.
	m on: #mouseDown send: #makeSetter:event:from:
		to: self
		withValue: (Array with: partName with: partType).
	^ m
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 9/27/2001 04:23'!
getterButtonFor: getterSelector type: partType
	"Answer a classic-tiles getter button for a part of the given name"

	| m inherent wording |
	m _ TileMorph new adoptVocabulary: self currentVocabulary.

	inherent _ Utilities inherentSelectorForGetter: getterSelector.
	wording _ (scriptedPlayer slotInfo includesKey: inherent)
		ifTrue: [inherent]
		ifFalse: [self currentVocabulary tileWordingForSelector: 
getterSelector].
	m setOperator: getterSelector andUseWording: wording.
	m typeColor: (ScriptingSystem colorForType: partType).
	m on: #mouseDown send: #makeGetter:event:from:
		to: self
		withValue: (Array with: getterSelector with: partType).
	^ m! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'yo 3/24/2005 13:12'!
getterTilesFor: getterSelector type: aType 
	"Answer classic getter for the given name/type"

	"aPhrase _ nil, assumed"

	| selfTile selector aPhrase |
	(#(#color:sees: #colorSees) includes: getterSelector) 
		ifTrue: [aPhrase := self colorSeesPhrase].
	(#(#getPatchValueIn:) includes: getterSelector)
		ifTrue: [aPhrase _ self patchValuePhrase].
	(#(#getRedComponentIn:) includes: getterSelector)
		ifTrue: [aPhrase _ self colorComponentPhraseFor: #red].
	(#(#getGreenComponentIn:) includes: getterSelector)
		ifTrue: [aPhrase _ self colorComponentPhraseFor: #green].
	(#(#getBlueComponentIn:) includes: getterSelector)
		ifTrue: [aPhrase _ self colorComponentPhraseFor: #blue].
	(#(#getUphillIn:) includes: getterSelector)
		ifTrue: [aPhrase _ self patchUphillPhrase].
	(#(#bounceOn:) includes: getterSelector)
		ifTrue: [aPhrase _ self bounceOnPhrase].
	(#(#bounceOn:color: #bounceOnColor:) includes: getterSelector)
		ifTrue: [aPhrase _ self bounceOnColorPhrase].
	(getterSelector = #getDistanceTo:)
		ifTrue: [aPhrase _ self distanceToPhrase].
	(getterSelector = #getAngleTo:)
		ifTrue: [aPhrase _ self angleToPhrase].
	(getterSelector = #getTurtleOf:)
		ifTrue: [aPhrase _ self turtleOfPhrase].
	(#(#seesColor: #isOverColor) includes: getterSelector) 
		ifTrue: [aPhrase := self seesColorPhrase].
	(#(#overlaps: #overlaps) includes: getterSelector) 
		ifTrue: [aPhrase := self overlapsPhrase].
	(#(#overlapsAny: #overlapsAny) includes: getterSelector) 
		ifTrue: [aPhrase := self overlapsAnyPhrase].
	(#(#touchesA: #touchesA) includes: getterSelector) 
		ifTrue: [aPhrase := self touchesAPhrase].
	aPhrase ifNil: 
			[aPhrase := PhraseTileMorph new setSlotRefOperator: getterSelector asSymbol
						type: aType].
	selfTile := self tileForSelf bePossessive.
	selfTile position: aPhrase firstSubmorph position.
	aPhrase firstSubmorph addMorph: selfTile.
	selector := aPhrase submorphs second.
	(#(#getPatchValueIn: getUphillIn:) includes: getterSelector) ifFalse: [
		(Vocabulary vocabularyNamed: aType capitalized) 
			ifNotNilDo: [:aVocab | aVocab wantsSuffixArrow ifTrue: [selector addSuffixArrow]].
	].
	selector updateLiteralLabel.
	aPhrase enforceTileColorPolicy.
	^aPhrase! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 4/6/2001 00:59'!
makeGetter: args event: evt from: aMorph
	"Hand the user tiles representing a classic getter on the slot represented by aMorph"

	| tiles |
	tiles _ self getterTilesFor: args first type: args second.
	owner
		ifNotNil:	[self primaryHand attachMorph: tiles]
		ifNil: 		[^ tiles]
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:26'!
makeGetter: arg1 from: arg2 forPart: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self makeGetter: arg1 event: arg2 from: arg3! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'yo 8/10/2005 17:29'!
makeSetterForColorComponent: selectorAndTypePair componentName: componentName event: evt from: aMorph 

	| argType m argTile selfTile argValue actualGetter |
	argType := selectorAndTypePair second.
	componentName = #red ifTrue: [actualGetter _ #setRedComponentIn:].
	componentName = #green ifTrue: [actualGetter _ #setGreenComponentIn:].
	componentName = #blue ifTrue: [actualGetter _ #setBlueComponentIn:].
	m := PhraseTileMorph new 
				setColorComponentRoot: actualGetter
				componentName: componentName
				type: #command
				rcvrType: #Patch
				argType: argType
				vocabulary: self currentVocabulary.
	argValue := self scriptedPlayer 
				perform: selectorAndTypePair first asSymbol with: nil.
	(argValue isKindOf: Player) 
		ifTrue: [argTile := argValue tileReferringToSelf]
		ifFalse: 
			[argTile := ScriptingSystem tileForArgType: argType.
			(argType == #Number and: [argValue isNumber]) 
				ifTrue: 
					[(scriptedPlayer decimalPlacesForGetter: actualGetter) 
						ifNotNilDo: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]].
			argTile
				setLiteral: argValue;
				updateLiteralLabel].
	argTile position: m lastSubmorph position.
	m lastSubmorph addMorph: argTile.
	selfTile := self tileForSelf bePossessive.
	selfTile position: m firstSubmorph position.
	m firstSubmorph addMorph: selfTile.
	m enforceTileColorPolicy.
	m submorphs second setPatchDefaultTo: scriptedPlayer defaultPatchPlayer.

	m openInHand! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'yo 3/31/2005 15:54'!
makeSetterForGetPatchValue: selectorAndTypePair event: evt from: aMorph 

	| argType m argTile selfTile argValue actualGetter |
	argType := selectorAndTypePair second.
	actualGetter := #patchValueIn:.
	m := PhraseTileMorph new 
				setPixelValueRoot: actualGetter
				type: #command
				rcvrType: #Player
				argType: argType
				vocabulary: self currentVocabulary.
	argValue := self scriptedPlayer 
				perform: selectorAndTypePair first asSymbol with: nil.
	(argValue isPlayerLike) 
		ifTrue: [argTile := argValue tileReferringToSelf]
		ifFalse: 
			[argTile := ScriptingSystem tileForArgType: argType.
			(argType == #Number and: [argValue isNumber]) 
				ifTrue: 
					[(scriptedPlayer decimalPlacesForGetter: actualGetter) 
						ifNotNilDo: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]].
			argTile
				setLiteral: argValue;
				updateLiteralLabel].
	argTile position: m lastSubmorph position.
	m lastSubmorph addMorph: argTile.
	selfTile := self tileForSelf bePossessive.
	selfTile position: m firstSubmorph position.
	m firstSubmorph addMorph: selfTile.
	m enforceTileColorPolicy.
	m submorphs second setPatchDefaultTo: scriptedPlayer defaultPatchPlayer.

	m openInHand! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'yo 7/22/2005 16:52'!
makeSetter: selectorAndTypePair event: evt from: aMorph 
	"Classic tiles: make a Phrase that comprises a setter of a slot, and hand it to the user."

	| argType m argTile selfTile argValue actualGetter |
	selectorAndTypePair first = #getPatchValueIn: ifTrue: [^ self makeSetterForGetPatchValue: selectorAndTypePair event: evt from: aMorph].
	selectorAndTypePair first = #getRedComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #red event: evt from: aMorph].
	selectorAndTypePair first = #getBlueComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #blue event: evt from: aMorph].
	selectorAndTypePair first = #getGreenComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #green event: evt from: aMorph].
	
	argType := selectorAndTypePair second.
	actualGetter := selectorAndTypePair first asSymbol.
	m := PhraseTileMorph new 
				setAssignmentRoot: (Utilities inherentSelectorForGetter: actualGetter)
				type: #command
				rcvrType: #Player
				argType: argType
				vocabulary: self currentVocabulary.
	argValue := self scriptedPlayer 
				perform: selectorAndTypePair first asSymbol.
	argValue isPlayerLike
		ifTrue: [argTile := argValue tileReferringToSelf]
		ifFalse: 
			[argTile := ScriptingSystem tileForArgType: argType.
			(argType == #Number and: [argValue isNumber]) 
				ifTrue: 
					[(scriptedPlayer decimalPlacesForGetter: actualGetter) 
						ifNotNilDo: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]].
			argTile
				setLiteral: argValue;
				updateLiteralLabel].
	argTile position: m lastSubmorph position.
	m lastSubmorph addMorph: argTile.
	selfTile := self tileForSelf bePossessive.
	selfTile position: m firstSubmorph position.
	m firstSubmorph addMorph: selfTile.
	m enforceTileColorPolicy.
	m openInHand! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'!
makeSetter: arg1 from: arg2 forPart: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].	
	^self makeSetter: arg1 event: arg2 from: arg3! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'RAA 4/6/2001 13:28'!
makeUniversalTilesGetter: aMethodInterface event: evt from: aMorph
	"Button in viewer performs this to make a universal-tiles getter and attach it to hand."

	| newTiles |
	newTiles _ self newGetterTilesFor: scriptedPlayer methodInterface: aMethodInterface.
	newTiles setProperty: #beScript toValue: true.
	owner
		ifNotNil:
			[ActiveHand attachMorph: newTiles.
			newTiles align: newTiles topLeft with: evt hand position + (7@14)]
		ifNil:
			[^ newTiles]
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'nk 10/14/2004 10:53'!
newGetterTilesFor: aPlayer methodInterface: aMethodInterface
	"Return universal tiles for a getter on this property.  Record who self is."

	| ms argTile argArray |
	ms _ MessageSend receiver: aPlayer selector: aMethodInterface selector arguments: #().

	"Handle three idiosyncratic cases..."
	aMethodInterface selector == #color:sees: ifTrue:
		[argTile _ ScriptingSystem tileForArgType: #Color.
		argArray _ Array with: argTile colorSwatch color with: argTile colorSwatch color copy. 
		ms arguments: argArray].
	aMethodInterface selector == #seesColor: ifTrue:
		[argTile _ ScriptingSystem tileForArgType: #Color.
		ms arguments: (Array with: argTile colorSwatch color)].

	(#(touchesA: overlaps: overlapsAny:) includes: aMethodInterface selector) ifTrue:
		[argTile _ ScriptingSystem tileForArgType: #Player.
		ms arguments: (Array with: argTile actualObject)].

	^ ms asTilesIn: aPlayer class globalNames: (aPlayer class officialClass ~~ CardPlayer)
			"For CardPlayers, use 'self'.  For others, name it, and use its name."! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 3/28/2001 14:17'!
newMakeGetter: arg event: evt from: aMorph
	"Button in viewer performs this to makea universal-tiles header tile and attach to hand."

	^ self makeUniversalTilesGetter: arg event: evt from: aMorph! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 3/28/2001 13:04'!
newMakeGetter: arg1 from: arg2 forMethodInterface: arg3
	"Button in viewer performs this to make a new style tile and attach to hand. (Reorder the arguments for existing event handlers)"

	(arg3 isMorph and: [arg3 eventHandler notNil]) ifTrue:
		[arg3 eventHandler fixReversedValueMessages].
	 ^ self makeUniversalTilesGetter: arg1 event: arg2 from: arg3! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'!
newMakeGetter: arg1 from: arg2 forPart: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self newMakeGetter: arg1 event: arg2 from: arg3! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:17'!
newMakeSetter: aSpec event: evt from: aMorph
	"Button in viewer performs this to make a new style tile and attach to hand."

	| m |
	m _ self newTilesFor: scriptedPlayer setter: aSpec.
	owner ifNotNil: [self primaryHand attachMorph: m.
			m align: m topLeft with: evt hand position + (7@14)]
		ifNil: [^ m].
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'!
newMakeSetter: arg1 from: arg2 forPart: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self newMakeSetter: arg1 event: arg2 from: arg3! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'RAA 4/6/2001 13:28'!
newMakeSetterFromInterface: aMethodInterface evt: evt from: aMorph 
	"Button in viewer performs this to make a new style tile and attach to hand."

	| m |
	m _ self newSetterTilesFor: scriptedPlayer methodInterface: aMethodInterface.
	m setProperty: #beScript toValue: true.

	owner
		ifNotNil: [self primaryHand attachMorph: m.
			m align: m topLeft with: evt hand position + (7@14)]
		ifNil: [^ m]
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 9/30/2001 11:20'!
newSetterTilesFor: aPlayer methodInterface: aMethodInterface
	"Return universal tiles for a setter on this property.  Record who self is."

	| ms argValue makeSelfGlobal phrase |
	argValue _ aPlayer perform: aMethodInterface selector.
	ms _ MessageSend receiver: aPlayer 
		selector: aMethodInterface companionSetterSelector 
		arguments: (Array with: argValue).
	makeSelfGlobal _ aPlayer class officialClass ~~ CardPlayer.
	phrase _ ms asTilesIn: aPlayer class globalNames: makeSelfGlobal.
			"For CardPlayers, use 'self'.  For others, name it, and use its name."
	makeSelfGlobal ifFalse: [phrase setProperty: #scriptedPlayer toValue: aPlayer].
	^ phrase! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 11/16/2001 14:44'!
newTilesFor: aPlayer setter: aSpec
	| ms  argValue |
	"Return universal tiles for a getter on this property.  Record who self is."

	argValue _ aPlayer perform: (Utilities getterSelectorFor: aSpec second asSymbol).
	ms _ MessageSend receiver: aPlayer selector: aSpec ninth arguments: (Array with: argValue).
	^ ms asTilesIn: aPlayer class globalNames: (aPlayer class officialClass ~~ CardPlayer)
			"For CardPlayers, use 'self'.  For others, name it, and use its name."! !


!CategoryViewer methodsFor: 'header pane' stamp: 'sw 8/31/2004 14:01'!
addHeaderMorph
	"Add the header at the top of the viewer, with a control for choosing the category, etc."

	| header aButton |
	header _ AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter.
	aButton _ self tanOButton.
	header addMorph: aButton.
	aButton actionSelector: #delete;
		setBalloonText: 'remove this pane from the screen
don''t worry -- nothing will be lost!!.' translated.
	self maybeAddArrowsTo: header.
	header beSticky.
	self addMorph: header.
	self addNamePaneTo: header.
	chosenCategorySymbol _ #basic! !

!CategoryViewer methodsFor: 'header pane' stamp: 'nk 7/12/2004 23:15'!
addNamePaneTo: header 
	"Add the namePane, which may be a popup or a type-in 
	depending on the type of CategoryViewer"
	| aButton |
	namePane := RectangleMorph newSticky color: Color brown veryMuchLighter.
	namePane borderWidth: 0.
	aButton := (StringButtonMorph
				contents: '-----'
				font: Preferences standardButtonFont)
				color: Color black.
	aButton target: self;
		 arguments: Array new;
		 actionSelector: #chooseCategory.
	aButton actWhen: #buttonDown.
	namePane addMorph: aButton.
	aButton position: namePane position.
	namePane align: namePane topLeft with: bounds topLeft + (50 @ 0).
	namePane setBalloonText: 'category (click here to choose a different one)' translated.
	header addMorphBack: namePane.
	(namePane isKindOf: RectangleMorph)
		ifTrue: [namePane addDropShadow.
			namePane shadowColor: Color gray]
! !

!CategoryViewer methodsFor: 'header pane' stamp: 'dgd 9/1/2003 13:47'!
maybeAddArrowsTo: header
	"Maybe add up/down arrows to the header"

	| wrpr |
	header addTransparentSpacerOfSize: 5@5.
	header addUpDownArrowsFor: self.
	(wrpr _ header submorphs last) submorphs second setBalloonText: 'previous category' translated.	
	wrpr submorphs first  setBalloonText: 'next category' translated! !


!CategoryViewer methodsFor: 'initialization' stamp: 'sw 8/22/2002 23:08'!
establishContents
	"Perform any initialization steps that needed to wait until I am installed in my outer viewer"! !

!CategoryViewer methodsFor: 'initialization' stamp: 'sw 9/8/2000 10:58'!
initializeFor: aPlayer
	"Initialize the category pane to show the #basic category by default"

	^ self initializeFor: aPlayer categoryChoice: #basic
! !

!CategoryViewer methodsFor: 'initialization' stamp: 'dgd 8/16/2004 21:51'!
initializeFor: aPlayer categoryChoice: aChoice
	"Initialize the receiver to be associated with the player and category specified"

	self listDirection: #topToBottom;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		borderWidth: 1;
		beSticky.
	self color: Color green muchLighter muchLighter.
	scriptedPlayer _ aPlayer.
	self addHeaderMorph.

	self chooseCategoryWhoseTranslatedWordingIs: aChoice
! !

!CategoryViewer methodsFor: 'initialization' stamp: 'sw 8/17/2002 01:23'!
setCategorySymbolFrom: aChoice
	"Set my category symbol"

	self chosenCategorySymbol: aChoice asSymbol
! !


!CategoryViewer methodsFor: 'macpal' stamp: 'sw 5/4/2001 05:24'!
currentVocabulary
	"Answer the vocabulary currently installed in the viewer.  The outer StandardViewer object holds this information."

	| outerViewer |
	^  (outerViewer _ self outerViewer)
		ifNotNil:
			[outerViewer currentVocabulary]
		ifNil:
			[(self world ifNil: [ActiveWorld]) currentVocabularyFor: scriptedPlayer]! !


!CategoryViewer methodsFor: 'scripting' stamp: 'sw 9/12/2001 22:58'!
isTileScriptingElement
	"Answer whether the receiver is a tile-scripting element"

	^ true! !


!CategoryViewer methodsFor: 'support' stamp: 'yo 9/28/2004 18:24'!
booleanPhraseForBounceOnColorOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setBounceOnColorOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	"getterPhrase submorphs second setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer)."
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	"self halt."
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 9/27/2004 15:00'!
booleanPhraseForBounceOnOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setBounceOnOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	"getterPhrase submorphs second setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer)."
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	"self halt."
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 6/17/2004 10:02'!
booleanPhraseForGetAngleToOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setAngleToOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	getterPhrase submorphs second setTurtleDefaultTo: scriptedPlayer.
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 10/13/2004 01:39'!
booleanPhraseForGetColorComponentOfType: retrieverType componentName: componentName retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setGetColorComponentOperator: retrieverOp componentName: componentName type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	getterPhrase submorphs second setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer).
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	"self halt."
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 6/15/2004 18:45'!
booleanPhraseForGetDistanceToOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setDistanceToOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	getterPhrase submorphs second setTurtleDefaultTo: scriptedPlayer.
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	"self halt."
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 6/15/2004 16:38'!
booleanPhraseForGetPatchValueOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setGetPixelOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	getterPhrase submorphs second setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer).
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	"self halt."
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 10/9/2004 10:39'!
booleanPhraseForGetTurtleAtOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setTurtleAtOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	getterPhrase submorphs second setTurtleDefaultTo: scriptedPlayer.
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	"self halt."
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 3/7/2005 08:41'!
booleanPhraseForGetTurtleOfOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setTurtleOfOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	"getterPhrase submorphs second setTurtleDefaultTo: scriptedPlayer."
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	"self halt."
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 6/15/2004 16:39'!
booleanPhraseForGetUpHillOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setUpHillOperator: retrieverOp type: retrieverType rcvrType: #Player argType: nil.
	getterPhrase submorphs third delete.
	getterPhrase submorphs second setSlotRefOperator: retrieverOp.
	getterPhrase submorphs second setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer).
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	"self halt."
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 9/27/2001 13:28'!
booleanPhraseForRetrieverOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (Vocabulary vocabularyForType:  retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setOperator: retrieverOp type: retrieverType rcvrType: #Player.
	getterPhrase submorphs last setSlotRefOperator: retrieverOp.
	getterPhrase submorphs first changeTableLayout.
	receiverTile _ aPlayer tileToRefer bePossessive.
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ ScriptingSystem tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 3/24/2005 11:18'!
booleanPhraseFromPhrase: phrase
	"Answer, if possible, a boolean-valued phrase derived from the phrase provided"

	|  retrieverOp retrieverTile |
	(phrase isKindOf: ParameterTile) ifTrue: [^ phrase booleanComparatorPhrase].
	phrase isBoolean ifTrue: [^ phrase].
	((scriptedPlayer respondsTo: #costume) 
		and:[scriptedPlayer costume isInWorld not]) ifTrue: [^ Array new].
	((retrieverTile _ phrase submorphs last) isKindOf: TileMorph) ifFalse: [^ phrase].
	retrieverOp _ retrieverTile operatorOrExpression.

	(Vocabulary vocabularyForType: phrase resultType)
		affordsCoercionToBoolean ifTrue: [
			retrieverOp =  #getPatchValueIn: ifTrue: [
				^ self booleanPhraseForGetPatchValueOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp =  #getRedComponentIn: ifTrue: [
				^ self booleanPhraseForGetColorComponentOfType: phrase resultType componentName: #red  retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp =  #getGreenComponentIn: ifTrue: [
				^ self booleanPhraseForGetColorComponentOfType: phrase resultType componentName: #green  retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp =  #getBlueComponentIn: ifTrue: [
				^ self booleanPhraseForGetColorComponentOfType: phrase resultType componentName: #blue retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp = #getUphillIn: ifTrue: [
				^ self booleanPhraseForGetUpHillOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp = #getDistanceTo: ifTrue: [
				^ self booleanPhraseForGetDistanceToOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp = #getAngleTo: ifTrue: [
				^ self booleanPhraseForGetAngleToOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp = #bounceOn: ifTrue: [
				^ self booleanPhraseForBounceOnOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
			].
			(retrieverOp = #bounceOn:color: or: [retrieverOp = #bounceOnColor:]) ifTrue: [
				^ self booleanPhraseForBounceOnColorOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp = #getTurtleAt: ifTrue: [
				^ self booleanPhraseForGetTurtleAtOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
			].
			retrieverOp = #getTurtleOf: ifTrue: [
				^ self booleanPhraseForGetTurtleOfOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.
			].

			^ self booleanPhraseForRetrieverOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject.

		].
	^ phrase! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 8/17/2002 01:11'!
categoryRestorationInfo
	"Answer info needed to reincarnate myself"

	^ self chosenCategorySymbol! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 10/30/1998 18:15'!
contentsSelection
	"Not well understood why this needs to be here!!"
	^ 1 to: 0! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 3/1/1999 11:57'!
invisiblySetPlayer: aPlayer
	scriptedPlayer _ aPlayer! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 8/11/2005 14:54'!
isSpecialPatchCase: aPlayer and: cmd

	((aPlayer costume renderedMorph class = KedamaMorph) and: [cmd = #addToPatchDisplayList:]) ifTrue: [
		^ true.
	].
	(aPlayer costume renderedMorph class = KedamaPatchMorph) ifTrue: [
		(#(#redComponentInto: #greenComponentInto: #blueComponentInto:
			#redComponentFrom: #greenComponentFrom: #blueComponentFrom:) includes: cmd) ifTrue: [
		^ true.
	].
	].

	^ false.
! !

!CategoryViewer methodsFor: 'support' stamp: 'yo 8/11/2005 14:48'!
isSpecialPatchReceiver: aPlayer and: cmd

	^ (aPlayer costume renderedMorph class = KedamaPatchMorph) and: [
		(#(#redComponentInto: #greenComponentInto: #blueComponentInto:
			#redComponentFrom: #greenComponentFrom: #blueComponentFrom:) includes: cmd)
	].
! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 8/6/2001 19:42'!
limitClass
	"Answer the receiver's limitClass"

	| outer |
	^ (outer _ self outerViewer)
		ifNotNil:
			[outer limitClass]
		ifNil:
			[ProtoObject]! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 11/18/1999 16:04'!
outerViewer
	"Answer the StandardViewer or equivalent that contains this object"
	^ self ownerThatIsA: Viewer! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 5/4/2001 05:32'!
tileForSelf
	"Return a tile representing the receiver's viewee"

	^ scriptedPlayer tileToRefer
! !
WorldViewModel subclass: #CautiousModel
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-ST80'!
!CautiousModel commentStamp: '<historical>' prior: 0!
A model for a morphic world view which will ask for confirmation before being closed, unless the corresponding preference is set to false. !


!CautiousModel methodsFor: 'updating' stamp: 'nb 6/17/2003 12:25'!
okToChange
	Preferences cautionBeforeClosing ifFalse: [^ true].
	Sensor leftShiftDown ifTrue: [^ true].

	Beeper beep.
	^ self confirm: 'Warning!!
If you answer "yes" here, this
window will disappear and
its contents will be lost!!
Do you really want to do that?'

"CautiousModel new okToChange"! !
SystemChangeTestRoot subclass: #ChangeHooksTest
	instanceVariableNames: 'previousChangeSet testsChangeSet capturedEvents generatedTestClass generatedTestClassX createdMethodName createdMethod doItExpression'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SystemChangeNotification-Tests'!
!ChangeHooksTest commentStamp: 'rw 4/5/2006 17:14' prior: 0!
This class implements unit tests to verify that when the system changes, notification messages are sent around correctly.

Therefore the test messages make a system change, after registering to receive an event ater the change occured. In this event (sent immediately after the change), the actual assertions take place.

Note that the system changes are *really* made to the system, but in a change set that is created in the setUp method, while the previous one is restored in the tearDown method.!


!ChangeHooksTest methodsFor: 'Private' stamp: 'rw 8/1/2003 17:03'!
addSingleEvent: anEvent

	capturedEvents isEmpty ifFalse: [self assert: false].
	capturedEvents add: anEvent! !

!ChangeHooksTest methodsFor: 'Private' stamp: 'rw 7/11/2003 09:55'!
checkEvent: anEvent kind: changeKind item: item itemKind: itemKind 

	self assert: (anEvent perform: ('is' , changeKind) asSymbol).
	self assert: anEvent item = item.
	self assert: anEvent itemKind = itemKind! !

!ChangeHooksTest methodsFor: 'Private' stamp: 'rw 8/1/2003 17:01'!
checkForOnlySingleEvent

	self assert: capturedEvents size = 1! !

!ChangeHooksTest methodsFor: 'Private' stamp: 'rw 7/2/2003 18:07'!
commentStringForTesting

	^'Added this comment as part of the unit test in SystemChangeTest>>testClassCommentedBasicEvents. You should never see this, unless you are debugging the system somewhere in between the tests.'! !

!ChangeHooksTest methodsFor: 'Private' stamp: 'rw 4/5/2006 17:22'!
removeGeneratedTestClasses
	"Remove all classes that were possibly generated during testing."
	
	| possiblyToRemove |
	possiblyToRemove := OrderedCollection
		with: self generatedTestClassName
		with: self generatedTestClassNameX
		with: self renamedTestClassName
		with: self newlyCreatedClassName.
	possiblyToRemove do: [:name | (Smalltalk hasClassNamed: name) ifTrue: [(Smalltalk at: name) removeFromSystemUnlogged]]! !


!ChangeHooksTest methodsFor: 'Events-Classes' stamp: 'rw 4/5/2006 17:15'!
classCommentedEvent: event 

	self addSingleEvent: event.
	self assert: generatedTestClass comment = self commentStringForTesting.
	self 
		checkEvent: event
		kind: #Commented
		item: generatedTestClass
		itemKind: AbstractEvent classKind! !

!ChangeHooksTest methodsFor: 'Events-Classes' stamp: 'rw 4/5/2006 17:15'!
classCreationEvent: event 

	| classCreated |
	self addSingleEvent: event.
	classCreated := Smalltalk classNamed: self newlyCreatedClassName.
	self assert: classCreated notNil.
	self 
		assert: ((Smalltalk organization 
				listAtCategoryNamed: #'System-Change Notification') 
					includes: self newlyCreatedClassName).
	self 
		checkEvent: event
		kind: #Added
		item: classCreated
		itemKind: AbstractEvent classKind! !

!ChangeHooksTest methodsFor: 'Events-Classes' stamp: 'rw 4/5/2006 17:15'!
classRecategorizedEvent: event 

	self addSingleEvent: event.
	self 
		checkEvent: event
		kind: #Recategorized
		item: generatedTestClass
		itemKind: AbstractEvent classKind.
	self assert: event oldCategory = #'System-Change Notification'! !

!ChangeHooksTest methodsFor: 'Events-Classes' stamp: 'rw 4/5/2006 17:15'!
classRedefinitionEvent: event 
	
	self addSingleEvent: event.
	self 
		checkEvent: event
		kind: #Modified
		item: generatedTestClass
		itemKind: AbstractEvent classKind.! !

!ChangeHooksTest methodsFor: 'Events-Classes' stamp: 'rw 4/5/2006 17:16'!
classRemovalEvent: event 
	"This event used to be sent efter the class was removed.
	This was changed, and therefore this test is useless currently."

	self addSingleEvent: event.
	self assert: (Smalltalk classNamed: self generatedTestClassName) isNil.
	self 
		checkEvent: event
		kind: #Removed
		item: self generatedTestClassName
		itemKind: AbstractEvent classKind! !

!ChangeHooksTest methodsFor: 'Events-Classes' stamp: 'rw 4/5/2006 17:16'!
classRenameEvent: event 

	| renamedClass |
	self addSingleEvent: event.
	renamedClass := Smalltalk classNamed: self renamedTestClassName.
	self assert: renamedClass notNil.
	self assert: (Smalltalk classNamed: self generatedTestClassName) isNil.
	self 
		checkEvent: event
		kind: #Renamed
		item: renamedClass
		itemKind: AbstractEvent classKind.
	self assert: event oldName = self generatedTestClassName! !

!ChangeHooksTest methodsFor: 'Events-Classes' stamp: 'rw 4/5/2006 17:16'!
classSuperChangedEvent: event 

	self addSingleEvent: event.
	self 
		checkEvent: event
		kind: #Modified
		item: generatedTestClass
		itemKind: AbstractEvent classKind.
	self assert: generatedTestClass superclass = Model! !


!ChangeHooksTest methodsFor: 'Private-Generation' stamp: 'rw 4/4/2006 22:10'!
generatedTestClassName


	^#'AutoGeneratedClassForTestingSystemChanges'! !

!ChangeHooksTest methodsFor: 'Private-Generation' stamp: 'rw 4/4/2006 22:10'!
generatedTestClassNameX

	^#'AutoGeneratedClassXForTestingSystemChanges'! !

!ChangeHooksTest methodsFor: 'Private-Generation' stamp: 'rw 4/4/2006 21:41'!
generateTestClass

	generatedTestClass := Object
				subclass: self generatedTestClassName
				instanceVariableNames: ''
				classVariableNames: ''
				poolDictionaries: ''
				category: 'System-Change Notification'.! !

!ChangeHooksTest methodsFor: 'Private-Generation' stamp: 'rw 4/4/2006 21:41'!
generateTestClassX

	generatedTestClassX := Object
				subclass: self generatedTestClassNameX
				instanceVariableNames: 'x'
				classVariableNames: ''
				poolDictionaries: ''
				category: 'System-Change Notification'.! !

!ChangeHooksTest methodsFor: 'Private-Generation' stamp: 'rw 4/4/2006 22:18'!
newlyCreatedClassName

	^#'AutoGeneratedClassWhileTestingSystemChanges'! !

!ChangeHooksTest methodsFor: 'Private-Generation' stamp: 'rw 4/4/2006 22:10'!
renamedTestClassName


	^#'AutoRenamedClassForTestingSystemChanges'! !


!ChangeHooksTest methodsFor: 'Events-Instance Variables' stamp: 'rw 4/5/2006 17:16'!
instanceVariableCreationEvent: event

	self addSingleEvent: event.	
	self assert: event isModified.
	self assert: event item = generatedTestClass.
	self assert: event itemKind = AbstractEvent classKind.
	self assert: event areInstVarsModified.
	self deny: event isSuperclassModified.
	self deny: event areClassVarsModified.
	self deny: event areSharedPoolsModified.
	
! !

!ChangeHooksTest methodsFor: 'Events-Instance Variables' stamp: 'rw 4/5/2006 17:18'!
instanceVariableRemovedEvent: event

	self addSingleEvent: event.	
	self assert: event isModified.
	self assert: event item = generatedTestClassX.
	self assert: event itemKind = AbstractEvent classKind.
	self assert: event areInstVarsModified.
	self deny: event isSuperclassModified.
	self deny: event areClassVarsModified.
	self deny: event areSharedPoolsModified.
	
! !


!ChangeHooksTest methodsFor: 'Events-Methods' stamp: 'rw 4/5/2006 17:18'!
methodCreationEvent1: event 

	| methodCreated |
	self addSingleEvent: event.
	self shouldnt: [methodCreated := generatedTestClass >> createdMethodName]
		raise: Error.
	self 
		checkEvent: event
		kind: #Added
		item: methodCreated
		itemKind: AbstractEvent methodKind! !

!ChangeHooksTest methodsFor: 'Events-Methods' stamp: 'rw 4/5/2006 17:18'!
methodCreationEvent2: event 

	| methodCreated |
	self addSingleEvent: event.
	self shouldnt: [methodCreated := generatedTestClass >> createdMethodName]
		raise: Error.
	self 
		checkEvent: event
		kind: #Added
		item: methodCreated
		itemKind: AbstractEvent methodKind! !

!ChangeHooksTest methodsFor: 'Events-Methods' stamp: 'rw 4/5/2006 17:18'!
methodRecategorizationEvent: event

	| methodCreated |
	self addSingleEvent: event.
	self shouldnt: [methodCreated := generatedTestClass >> createdMethodName]
		raise: Error.
	self assert: ((generatedTestClass organization categoryOfElement: createdMethodName) = #newCategory).
	self assert: event oldCategory = #testing.
	self 
		checkEvent: event
		kind: #Recategorized
		item: methodCreated
		itemKind: AbstractEvent methodKind.! !

!ChangeHooksTest methodsFor: 'Events-Methods' stamp: 'rw 4/5/2006 17:18'!
methodRemovedEvent1: event 

	self addSingleEvent: event.
	self should: [generatedTestClass >> createdMethodName] raise: Error.
	self 
		checkEvent: event
		kind: #Removed
		item: createdMethod
		itemKind: AbstractEvent methodKind.
	event itemClass = generatedTestClass.
	event itemMethod = createdMethodName.
	self assert: ((generatedTestClass organization categoryOfElement: createdMethodName) isNil).! !

!ChangeHooksTest methodsFor: 'Events-Methods' stamp: 'rw 4/5/2006 17:18'!
methodRemovedEvent2: event 

	self methodRemovedEvent1: event! !


!ChangeHooksTest methodsFor: 'Events-Expression' stamp: 'rw 4/5/2006 17:16'!
methodDoItEvent1: event 

	self addSingleEvent: event.
	self 
		checkEvent: event
		kind: #DoIt
		item: doItExpression
		itemKind: AbstractEvent expressionKind.
	self assert: event context isNil.! !


!ChangeHooksTest methodsFor: 'Events-General' stamp: 'rw 8/1/2003 17:11'!
rememberEvent: event

	capturedEvents add: event! !

!ChangeHooksTest methodsFor: 'Events-General' stamp: 'rw 8/1/2003 16:41'!
shouldNotBeCalledEvent: anEvent
	"This event should not be called, so fail the test."

	self assert: false! !


!ChangeHooksTest methodsFor: 'Running' stamp: 'rw 4/4/2006 22:59'!
setUp

	previousChangeSet := ChangeSet current.
	testsChangeSet := ChangeSet new.
	ChangeSet newChanges: testsChangeSet.
	capturedEvents := OrderedCollection new.
	self generateTestClass.
	self generateTestClassX.
	super setUp! !

!ChangeHooksTest methodsFor: 'Running' stamp: 'rw 4/5/2006 17:23'!
tearDown

	super tearDown.
	self removeGeneratedTestClasses.
	ChangeSet newChanges: previousChangeSet.
	ChangeSorter removeChangeSet: testsChangeSet.
	previousChangeSet := nil.
	testsChangeSet := nil.
! !


!ChangeHooksTest methodsFor: 'Testing-Classes' stamp: 'rw 4/5/2006 17:19'!
testClassCommentedEvent

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #classCommentedEvent:.
	generatedTestClass comment: self commentStringForTesting.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Classes' stamp: 'rw 4/5/2006 17:19'!
testClassCreationEvent

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #classCreationEvent:.
	Object 
		subclass: self newlyCreatedClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'System-Change Notification'.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Classes' stamp: 'rw 4/5/2006 17:19'!
testClassRecategorizedEvent1

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #classRecategorizedEvent:.
	Object 
		subclass: generatedTestClass name
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Collections-Abstract'.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Classes' stamp: 'rw 4/5/2006 17:19'!
testClassRecategorizedEvent2

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #classRecategorizedEvent:.
	generatedTestClass category: 'Collections-Abstract'.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Classes' stamp: 'rw 4/5/2006 17:19'!
testClassRedefinition

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #classRedefinitionEvent:.
	self generateTestClass! !

!ChangeHooksTest methodsFor: 'Testing-Classes' stamp: 'rw 4/5/2006 17:20'!
testClassRemovalEvent
	"This event used to be sent efter the class was removed.
	This was changed, and therefore this test is useless currently."
	
	"Keep it, since I really want to check with the responsible for the ChangeSet,
	and it is very likely this will be reintroduced afterwards!!"

"	| createdClass |
	createdClass := self compileUniqueClass.
	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #classRemovalEvent:.
	createdClass removeFromSystem.
	self checkForOnlySingleEvent
	
	"! !

!ChangeHooksTest methodsFor: 'Testing-Classes' stamp: 'rw 4/5/2006 17:20'!
testClassRenamedEvent

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #classRenameEvent:.
	generatedTestClass rename: self renamedTestClassName.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Classes' stamp: 'rw 4/5/2006 17:20'!
testClassSuperChangedEvent

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #classSuperChangedEvent:.
	Model 
		subclass: generatedTestClass name
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'System-Change Notification'.
	self checkForOnlySingleEvent! !


!ChangeHooksTest methodsFor: 'Testing-Expression' stamp: 'rw 4/5/2006 17:20'!
testDoItEvent1

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #methodDoItEvent1:.
	doItExpression := '1 + 2'.
	Compiler evaluate: doItExpression logged: true.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Expression' stamp: 'rw 4/5/2006 17:20'!
testDoItEvent2

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #shouldNotBeCalledEvent:.
	doItExpression := '1 + 2'.
	Compiler evaluate: doItExpression logged: false.! !


!ChangeHooksTest methodsFor: 'Testing-Instance Variables' stamp: 'rw 4/5/2006 17:20'!
testInstanceVariableCreationEvent1

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #instanceVariableCreationEvent:.
	Object 
		subclass: self generatedTestClassName
		instanceVariableNames: 'x'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'System-Change Notification'.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Instance Variables' stamp: 'rw 4/5/2006 17:17'!
testInstanceVariableCreationEvent2

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #instanceVariableCreationEvent:.
	generatedTestClass addInstVarName: 'x'.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Instance Variables' stamp: 'rw 4/5/2006 17:18'!
testInstanceVariableRemovedEvent1

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #instanceVariableRemovedEvent:.
	Object 
		subclass: generatedTestClassX name
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'System-Change Notification'.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Instance Variables' stamp: 'rw 4/5/2006 17:17'!
testInstanceVariableRemovedEvent2

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #instanceVariableRemovedEvent:.
	generatedTestClassX removeInstVarName: 'x'.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Instance Variables' stamp: 'rw 4/5/2006 17:21'!
testInstanceVariableRenamedSilently

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #shouldNotBeCalledEvent:.
	generatedTestClassX renameSilentlyInstVar: 'x' to: 'y'! !


!ChangeHooksTest methodsFor: 'Testing-Methods' stamp: 'rw 4/5/2006 17:21'!
testMethodCreationEvent1

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #methodCreationEvent1:.
	createdMethodName := #testCreation.
	generatedTestClass compile: createdMethodName , '	^1'.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Methods' stamp: 'rw 4/5/2006 17:21'!
testMethodCreationEvent2

	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #methodCreationEvent2:.
	createdMethodName := #testCreation.
	generatedTestClass compile: createdMethodName , '	^1' classified: #testing.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Methods' stamp: 'rw 4/5/2006 17:21'!
testMethodRecategorizationEvent

	createdMethodName := #testCreation.
	generatedTestClass compile: createdMethodName , '	^1' classified: #testing.
	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #methodRecategorizationEvent:.
	generatedTestClass organization 
		classify: createdMethodName
		under: #newCategory
		suppressIfDefault: false.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Methods' stamp: 'rw 4/5/2006 17:21'!
testMethodRemovedEvent1

	createdMethodName := #testCreation.
	generatedTestClass compile: createdMethodName , '	^1'.
	createdMethod := generatedTestClass >> createdMethodName.
	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #methodRemovedEvent1:.
	generatedTestClass removeSelector: createdMethodName.
	self checkForOnlySingleEvent! !

!ChangeHooksTest methodsFor: 'Testing-Methods' stamp: 'rw 4/5/2006 17:21'!
testMethodRemovedEvent2

	createdMethodName := #testCreation.
	generatedTestClass compile: createdMethodName , '	^1'.
	createdMethod := generatedTestClass >> createdMethodName.
	self systemChangeNotifier notify: self
		ofAllSystemChangesUsing: #methodRemovedEvent2:.
	Smalltalk 
		removeSelector: (Array with: generatedTestClass name with: createdMethodName).
	self checkForOnlySingleEvent! !
CodeHolder subclass: #ChangeList
	instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer showsVersions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeList commentStamp: '<historical>' prior: 0!
A ChangeList represents a list of changed methods that reside on a file in fileOut format.  The classes and methods in my list are not necessarily in this image!!  Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...).  Note that the two kinds of window have different controller classes!!!!

It holds three lists:
	changeList - a list of ChangeRecords
	list - a list of one-line printable headers
	listSelections - a list of Booleans (true = selected, false = not selected) multiple OK.
	listIndex 
Items that are removed (removeDoits, remove an item) are removed from all three lists.
Most recently clicked item is the one showing in the bottom pane.!


!ChangeList methodsFor: 'accessing'!
changeList
	^ changeList! !

!ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
changes: changeRecords file: aFile
	file := aFile.
	changeList := OrderedCollection new.
	list := OrderedCollection new.
	listIndex := 0.
	changeRecords do: [:each |
		(each respondsTo: #methodClass)
			ifFalse: [self addItem: ChangeRecord new text: each asString]
			ifTrue:
				[self addItem: each text: ('method: ' , each methodClass name , (each isMetaClassChange ifTrue: [' class '] ifFalse: [' '])
					, each methodSelector
					, '; ' , each stamp)]].
	listSelections := Array new: list size withAll: false! !

!ChangeList methodsFor: 'accessing' stamp: 'ls 5/12/1999 07:55'!
currentChange
	"return the current change being viewed, or nil if none"
	listIndex = 0 ifTrue: [ ^nil ].
	^changeList at: listIndex! !

!ChangeList methodsFor: 'accessing'!
file
	^file! !

!ChangeList methodsFor: 'accessing' stamp: 'TPR 11/28/1998 17:38'!
listHasSingleEntry
	"does the list of changes have only a single item?"
	^list size = 1! !

!ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
listSelections
	listSelections ifNil: [
		list ifNotNil: [
			listSelections := Array new: list size withAll: false]].
	^ listSelections! !

!ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
setLostMethodPointer: sourcePointer
	lostMethodPointer := sourcePointer! !

!ChangeList methodsFor: 'accessing' stamp: 'sw 10/19/1999 15:11'!
showsVersions
	^ false! !


!ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'!
addItem: item text: text
	| cr |
	cr := Character cr.
	changeList addLast: item.
	list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/7/2000 12:42'!
changeListButtonSpecs

	^#(
		('select all' 			selectAll				'select all entries')
		('deselect all'		deselectAll			'deselect all entries')
		('select conflicts'	selectAllConflicts	'select all methods that occur in any change set')
		('file in selections' 	fileInSelections		'file in all selected entries')
		)! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'!
initialize
	"Initialize a blank ChangeList.  Set the contentsSymbol to reflect whether diffs will initally be shown or not"

	contentsSymbol := Preferences diffsInChangeList
		ifTrue:
			[self defaultDiffsSymbol]
		ifFalse:
			[#source].
	changeList := OrderedCollection new.
	list := OrderedCollection new.
	listIndex := 0.
	super initialize! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'!
openAsMorphName: labelString multiSelect: multiSelect 
	"Open a morphic view for the messageSet, whose label is labelString. 
	The listView may be either single or multiple selection type"
	| window listHeight listPane |
	listHeight := 0.4.
	window := (SystemWindow labelled: labelString)
				model: self.
	listPane := multiSelect
				ifTrue: [PluggableListMorphOfMany
						on: self
						list: #list
						primarySelection: #listIndex
						changePrimarySelection: #toggleListIndex:
						listSelection: #listSelectionAt:
						changeListSelection: #listSelectionAt:put:
						menu: (self showsVersions
								ifTrue: [#versionsMenu:]
								ifFalse: [#changeListMenu:])]
				ifFalse: [PluggableListMorph
						on: self
						list: #list
						selected: #listIndex
						changeSelected: #toggleListIndex:
						menu: (self showsVersions
								ifTrue: [#versionsMenu:]
								ifFalse: [#changeListMenu:])].
	listPane keystrokeActionSelector: #changeListKey:from:.
	window
		addMorph: listPane
		frame: (0 @ 0 extent: 1 @ listHeight).
	self
		addLowerPanesTo: window
		at: (0 @ listHeight corner: 1 @ 1)
		with: nil.
	^ window openInWorld! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sbw 12/30/1999 11:02'!
optionalButtonHeight

	^ 15! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'!
optionalButtonRow
	"Answer a row of buttons to occur in a tool pane"

	| aRow aButton |
	aRow := AlignmentMorph newRow.
	aRow hResizing: #spaceFill.
	aRow clipSubmorphs: true.
	aRow layoutInset: 2@2; cellInset: 3.
	aRow wrapCentering: #center; cellPositioning: #leftCenter.
	self changeListButtonSpecs do:
		[:triplet |
			aButton := PluggableButtonMorph
				on: self
				getState: nil
				action: triplet second.
			aButton
				hResizing: #spaceFill;
				vResizing: #spaceFill;
				label: triplet first asString;
				askBeforeChanging: true;
				onColor: Color white offColor: Color white.

			aRow addMorphBack: aButton.
			aButton setBalloonText: triplet third].
	aRow addMorphBack: self regularDiffButton.
	self wantsPrettyDiffOption ifTrue:
		[aRow addMorphBack: self prettyDiffButton].
	^ aRow! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'!
optionalButtonsView
	"Answer the a View containing the optional buttons"

	| view bHeight vWidth first offset previousView bWidth button |
	vWidth := 200.
	bHeight := self optionalButtonHeight.
	previousView := nil.
	offset := 0.
	first := true.

	view := View new
		model: self;
		window: (0 @ 0 extent: vWidth @ bHeight).

	self changeListButtonSpecs do: [:triplet |
		button := PluggableButtonView
			on: self
			getState: nil
			action: triplet second.
		button label: triplet first asParagraph.
		bWidth := button label boundingBox width // 2.
		button
			window: (offset@0 extent: bWidth@bHeight);
			borderWidthLeft: 0 right: 1 top: 0 bottom: 0.
		offset := offset + bWidth.
		first
			ifTrue:
				[view addSubView: button.
				first := false.]
			ifFalse:
				[view addSubView: button toRightOf: previousView].
		previousView := button].

	button := PluggableButtonView
		on: self
		getState: #showingAnyKindOfDiffs
		action: #toggleDiffing.
	button
		label: 'diffs' asParagraph;
		window: (offset@0 extent: (vWidth - offset)@bHeight).
	view addSubView: button toRightOf: previousView.

	^ view! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sw 8/15/2002 22:34'!
wantsPrettyDiffOption
	"Answer whether pretty-diffs are meaningful for this tool"

	^ true! !


!ChangeList methodsFor: 'menu actions' stamp: 'jm 5/3/1998 19:15'!
acceptFrom: aView

	aView controller text = aView controller initialText ifFalse: [
		aView flash.
		^ self inform: 'You can only accept this version as-is.
If you want to edit, copy the text to a browser'].
	(aView setText: aView controller text from: self) ifTrue:
		[aView ifNotNil: [aView controller accept]].	"initialText"
! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
browseAllVersionsOfSelections
	"Opens a Versions browser on all the currently selected methods, showing each alongside all of their historical versions."
	|  oldSelection aList |
	oldSelection := self listIndex.
	aList := OrderedCollection new.
	Cursor read showWhile: [
		1 to: changeList size do: [:i |
			(listSelections at: i) ifTrue: [
				listIndex := i.
				self browseVersions.
				aList add: i.
				]]].
	listIndex := oldSelection.

	aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts'].
! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
browseCurrentVersionsOfSelections
	"Opens a message-list browser on the current in-memory versions of all methods that are currently seleted"
	|  aClass aChange aList |

	aList := OrderedCollection new.
	Cursor read showWhile: [
		1 to: changeList size do: [:i |
			(listSelections at: i) ifTrue: [
				aChange := changeList at: i.
				(aChange type = #method
					and: [(aClass := aChange methodClass) notNil
					and: [aClass includesSelector: aChange methodSelector]])
						ifTrue: [
							aList add: (
								MethodReference new
									setStandardClass: aClass  
									methodSymbol: aChange methodSelector
							)
						]]]].

	aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts'].
	MessageSet 
		openMessageList: aList 
		name: 'Current versions of selected methods in ', file localName! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
browseVersions
	| change class browser |
	listIndex = 0
		ifTrue: [^ nil ].
	change := changeList at: listIndex.
	((class := change methodClass) notNil
			and: [class includesSelector: change methodSelector])
		ifFalse: [ ^nil ].
	browser := super browseVersions.
	browser ifNotNil: [ browser addedChangeRecord: change ].
	^browser! !

!ChangeList methodsFor: 'menu actions' stamp: 'nk 6/2/2006 08:03'!
buildMorphicCodePaneWith: editString

	| codePane |

	codePane := AcceptableCleanTextMorph
		on: self
		text: #contents 
		accept: #contents:
		readSelection: #contentsSelection 
		menu: #codePaneMenu:shifted:.
	codePane font: Preferences standardCodeFont.
	editString ifNotNil: [
		codePane editString: editString.
		codePane hasUnacceptedEdits: true
	].
	^codePane
! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/25/2001 07:22'!
changeListKey: aChar from: view
	"Respond to a Command key in the list pane."

	aChar == $D ifTrue: [^ self toggleDiffing].
	aChar == $a ifTrue: [^ self selectAll].

	^ self arrowKey: aChar from: view! !

!ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 11:11'!
changeListMenu: aMenu
	"Fill aMenu up so that it comprises the primary changelist-browser menu"

	Smalltalk isMorphic ifTrue:
		[aMenu addTitle: 'change list'.
		aMenu addStayUpItemSpecial].

	aMenu addList: #(

	('fileIn selections'							fileInSelections						'import the selected items into the image')
	('fileOut selections...	'						fileOutSelections						'create a new file containing the selected items')
	-
	('compare to current'						compareToCurrentVersion			'open a separate window which shows the text differences between the on-file version and the in-image version.' )
	('toggle diffing (D)'							toggleDiffing						'start or stop showing diffs in the code pane.')
	-
	('select conflicts with any changeset'		selectAllConflicts					'select methods in the file which also occur in any change-set in the system')
	('select conflicts with current changeset'	selectConflicts						'select methods in the file which also occur in the current change-set')
	('select conflicts with...'						selectConflictsWith					'allows you to designate a file or change-set against which to check for code conflicts.')
	-
	('select unchanged methods'					selectUnchangedMethods				'select methods in the file whose in-image versions are the same as their in-file counterparts' )
	('select new methods'						selectNewMethods					'select methods in the file that do not current occur in the image')
	('select methods for this class'				selectMethodsForThisClass			'select all methods in the file that belong to the currently-selected class')

	-
	('select all (a)'								selectAll								'select all the items in the list')
	('deselect all'								deselectAll							'deselect all the items in the list')
	('invert selections'							invertSelections						'select every item that is not currently selected, and deselect every item that *is* currently selected')
	-
	('browse all versions of single selection'			browseVersions		'open a version browser showing the versions of the currently selected method')
	('browse all versions of selections'			browseAllVersionsOfSelections		'open a version browser showing all the versions of all the selected methods')
	('browse current versions of selections'		browseCurrentVersionsOfSelections	'open a message-list browser showing the current (in-image) counterparts of the selected methods')
	('destroy current methods of selections'		destroyCurrentCodeOfSelections		'remove (*destroy*) the in-image counterparts of all selected methods')
	-
	('remove doIts'								removeDoIts							'remove all items that are doIts rather than methods')
	('remove older versions'						removeOlderMethodVersions			'remove all but the most recent versions of methods in the list')
	('remove up-to-date versions'				removeExistingMethodVersions		'remove all items whose code is the same as the counterpart in-image code')
	('remove selected items'						removeSelections					'remove the selected items from the change-list')
	('remove unselected items'					removeNonSelections					'remove all the items not currently selected from the change-list')).

	^ aMenu

! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
compareToCurrentVersion
	"If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text"

	| change class s1 s2 |
	listIndex = 0
		ifTrue: [^ self].
	change := changeList at: listIndex.
	((class := change methodClass) notNil
			and: [class includesSelector: change methodSelector])
		ifTrue: [s1 := (class sourceCodeAt: change methodSelector) asString.
			s2 := change string.
			s1 = s2
				ifTrue: [^ self inform: 'Exact Match'].
			(StringHolder new
				textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: class  prettyDiffs: self showingPrettyDiffs))
				openLabel: 'Comparison to Current Version']
		ifFalse: [self flash]! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
deselectAll 
	"Deselect all items in the list pane, and clear the code pane"

	listIndex := 0.
	listSelections atAllPut: false.
	self changed: #allSelections.
	self contentsChanged! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
destroyCurrentCodeOfSelections
	"Actually remove from the system any in-memory methods with class and selector identical to items current selected.  This may seem rather arcane but believe me it has its great uses, when trying to split out code.  To use effectively, first file out a change set that you wish to split off.  Then open a ChangeList browser on that fileout.  Now look through the methods, and select any of them which you want to remove completely from the system, then issue this command.  For those methods where you have made changes to pre-existing versions, of course, you won't want to remove them from the system, so use this mechanism with care!!"

	|  aClass aChange aList |
	aList := OrderedCollection new.
	1 to: changeList size do:
		[:index |
			(listSelections at: index) ifTrue:
				[aChange := changeList at: index.
				(aChange type = #method
					and: [(aClass := aChange methodClass) notNil
					and: [aClass includesSelector: aChange methodSelector]])
						ifTrue:
							[aList add: {aClass. aChange methodSelector}]]].

	aList size > 0 ifTrue:
		[(self confirm: 'Warning!! This will actually remove ', aList size printString,  ' method(s) from the system!!') ifFalse: [^ self]].
	aList do:
		[:aPair | Transcript cr; show: 'Removed: ', aPair first printString, '.', aPair second.
			aPair first removeSelector: aPair second]! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
fileInSelections 
	| any |
	any := false.
	listSelections with: changeList do: 
		[:selected :item | selected ifTrue: [any := true. item fileIn]].
	any ifFalse:
		[self inform: 'nothing selected, so nothing done']! !

!ChangeList methodsFor: 'menu actions' stamp: 'rbb 3/1/2005 10:27'!
fileOutSelections 
	| fileName internalStream |
	fileName := UIManager default request: 'Enter the base of file name' initialAnswer: 'Filename'.
	internalStream := WriteStream on: (String new: 1000).
	internalStream header; timeStamp.
	listSelections with: changeList do: 
		[:selected :item | selected ifTrue: [item fileOutOn: internalStream]].

	FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false.
! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
invertSelections
	"Invert the selectedness of each item in the changelist"

	listSelections := listSelections collect: [ :ea | ea not].
	listIndex := 0.
	self changed: #allSelections.
	self contentsChanged! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 10/11/1999 17:18'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If I can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 

	(#accept == selector) ifTrue:
		[otherTarget isMorph ifFalse: [^ self acceptFrom: otherTarget view]].
			"weird special case just for mvc changlist"

	^ super perform: selector orSendTo: otherTarget! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
removeDoIts
	"Remove doits from the receiver, other than initializes. 1/26/96 sw"

	| newChangeList newList |

	newChangeList := OrderedCollection new.
	newList := OrderedCollection new.

	changeList with: list do:
		[:chRec :str |
			(chRec type ~~ #doIt or:
				[str endsWith: 'initialize'])
					ifTrue:
						[newChangeList add: chRec.
						newList add: str]].
	newChangeList size < changeList size
		ifTrue:
			[changeList := newChangeList.
			list := newList.
			listIndex := 0.
			listSelections := Array new: list size withAll: false].
	self changed: #list.

	! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
removeExistingMethodVersions
	"Remove all up to date version of entries from the receiver"
	| newChangeList newList str keep cls sel |
	newChangeList := OrderedCollection new.
	newList := OrderedCollection new.

	changeList with: list do:[:chRec :strNstamp | 
			keep := true.
			(cls := chRec methodClass) ifNotNil:[
				str := chRec string.
				sel := cls parserClass new parseSelector: str.
				keep := (cls sourceCodeAt: sel ifAbsent:['']) asString ~= str.
			].
			keep ifTrue:[
					newChangeList add: chRec.
					newList add: strNstamp]].
	newChangeList size < changeList size
		ifTrue:
			[changeList := newChangeList.
			list := newList.
			listIndex := 0.
			listSelections := Array new: list size withAll: false].
	self changed: #list! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
removeNonSelections
	"Remove the unselected items from the receiver."

	| newChangeList newList |

	newChangeList := OrderedCollection new.
	newList := OrderedCollection new.

	1 to: changeList size do:
		[:i | (listSelections at: i) ifTrue:
			[newChangeList add: (changeList at: i).
			newList add: (list at: i)]].
	newChangeList size == 0 ifTrue:
		[^ self inform: 'That would remove everything.
Why would you want to do that?'].

	newChangeList size < changeList size
		ifTrue:
			[changeList := newChangeList.
			list := newList.
			listIndex := 0.
			listSelections := Array new: list size withAll: false].
	self changed: #list

	! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
removeOlderMethodVersions
	"Remove older versions of entries from the receiver."
	| newChangeList newList found str |
	newChangeList := OrderedCollection new.
	newList := OrderedCollection new.
	found := OrderedCollection new.

	changeList reverseWith: list do:
		[:chRec :strNstamp | str := strNstamp copyUpTo: $;.
			(found includes: str)
				ifFalse:
					[found add: str.
					newChangeList add: chRec.
					newList add: strNstamp]].
	newChangeList size < changeList size
		ifTrue:
			[changeList := newChangeList reversed.
			list := newList reversed.
			listIndex := 0.
			listSelections := Array new: list size withAll: false].
	self changed: #list! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
removeSelections
	"Remove the selected items from the receiver.  9/18/96 sw"

	| newChangeList newList |

	newChangeList := OrderedCollection new.
	newList := OrderedCollection new.

	1 to: changeList size do:
		[:i | (listSelections at: i) ifFalse:
			[newChangeList add: (changeList at: i).
			newList add: (list at: i)]].
	newChangeList size < changeList size
		ifTrue:
			[changeList := newChangeList.
			list := newList.
			listIndex := 0.
			listSelections := Array new: list size withAll: false].
	self changed: #list

	! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectAll
	listIndex := 0.
	listSelections atAllPut: true.
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectAllConflicts
	"Selects all method definitions in the receiver which are also in any existing change set in the system.  This makes no statement about whether the content of the methods differ, only whether there is a change represented."

	|  aClass aChange |
	Cursor read showWhile: 
		[1 to: changeList size do:
			[:i | aChange := changeList at: i.
			listSelections at: i put:
				(aChange type = #method
				and: [(aClass := aChange methodClass) notNil
				and: [ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector:  aChange methodSelector]])]].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectConflicts
	"Selects all method definitions for which there is ALSO an entry in changes"
	| change class  |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | change := changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class := change methodClass) notNil
			and: [(ChangeSet current atSelector: change methodSelector
						class: class) ~~ #none]])]].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectConflicts: changeSetOrList
	"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList"
	| change class systemChanges |
	Cursor read showWhile: 
	[(changeSetOrList isKindOf: ChangeSet) ifTrue: [
	1 to: changeList size do:
		[:i | change := changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class := change methodClass) notNil
			and: [(changeSetOrList atSelector: change methodSelector
						class: class) ~~ #none]])]]
	ifFalse: ["a ChangeList"
	1 to: changeList size do:
		[:i | change := changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class := change methodClass) notNil
			and: [changeSetOrList list includes: (list at: i)]])]]
	].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectConflictsWith
	"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk"
	| aStream all index |
	aStream := WriteStream on: (String new: 200).
	(all := ChangeSorter allChangeSets copy) do:
		[:sel | aStream nextPutAll: (sel name contractTo: 40); cr].
	ChangeList allSubInstancesDo:
		[:sel | aStream nextPutAll: (sel file name); cr.
			all addLast: sel].
	aStream skip: -1.
	index := (UIManager default chooseFrom: (aStream contents substrings)).
	index > 0 ifTrue: [
		self selectConflicts: (all at: index)].
! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectMethodsForThisClass
	| name |
	self currentChange ifNil: [ ^self ].
	name := self currentChange methodClassName.
	name ifNil: [ ^self ].
	^self selectSuchThat: [ :change |
		change methodClassName = name ].! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectNewMethods
	"Selects all method definitions for which there is no counterpart method in the current image"

	| change class |
	Cursor read showWhile: 
		[1 to: changeList size do:
			[:i | change := changeList at: i.
			listSelections at: i put:
				((change type = #method and:
					[((class := change methodClass) isNil) or:
						[(class includesSelector: change methodSelector) not]]))]].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'rbb 3/1/2005 10:27'!
selectSuchThat
	"query the user for a selection criterio.  By Lex Spoon.  NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:"
	| code block |
	code := UIManager default request: 'selection criteria for a change named aChangeRecord?\For instance, ''aChangeRecord category = ''System-Network''''' withCRs.

	code isEmpty ifTrue: [^ self ].

	block := Compiler evaluate: '[:aChangeRecord | ', code, ']'.

	self selectSuchThat: block! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectSuchThat: aBlock
	"select all changes for which block returns true"
	listSelections := changeList collect: [ :change | aBlock value: change ].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'!
selectUnchangedMethods
	"Selects all method definitions for which there is already a method in the current image, whose source is exactly the same.  9/18/96 sw"
	| change class |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | change := changeList at: i.
		listSelections at: i put:
			((change type = #method and:
				[(class := change methodClass) notNil]) and:
					[(class includesSelector: change methodSelector) and:
						[change string withBlanksCondensed = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed ]])]].
	self changed: #allSelections! !


!ChangeList methodsFor: 'scanning' stamp: 'sd 11/20/2005 21:26'!
scanCategory  
	"Scan anything that involves more than one chunk; method name is historical only"

	| itemPosition item tokens stamp isComment anIndex |
	itemPosition := file position.
	item := file nextChunk.

	isComment := (item includesSubString: 'commentStamp:').
	(isComment or: [item includesSubString: 'methodsFor:']) ifFalse:
		["Maybe a preamble, but not one we recognize; bail out with the preamble trick"
		^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)
				 text: ('preamble: ' , item contractTo: 50)].

	tokens := Scanner new scanTokens: item.
	tokens size >= 3 ifTrue:
		[stamp := ''.
		anIndex := tokens indexOf: #stamp: ifAbsent: [nil].
		anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)].

		tokens second == #methodsFor:
			ifTrue: [^ self scanCategory: tokens third class: tokens first
							meta: false stamp: stamp].
		tokens third == #methodsFor:
			ifTrue: [^ self scanCategory: tokens fourth class: tokens first
							meta: true stamp: stamp]].

		tokens second == #commentStamp:
			ifTrue:
				[stamp := tokens third.
				self addItem:
						(ChangeRecord new file: file position: file position type: #classComment
										class: tokens first category: nil meta: false stamp: stamp)
						text: 'class comment for ' , tokens first, 
							  (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
				file nextChunk.
				^ file skipStyleChunk]! !

!ChangeList methodsFor: 'scanning' stamp: 'md 2/21/2006 09:42'!
scanCategory: category class: class meta: meta stamp: stamp
	| itemPosition method |
	[itemPosition := file position.
	method := file nextChunk.
	file skipStyleChunk.
	method size > 0]						"done when double terminators"
		whileTrue:
		[self addItem: (ChangeRecord new file: file position: itemPosition type: #method
							class: class category: category meta: meta stamp: stamp)
			text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
				, (self class parserClass new parseSelector: method)
				, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! !

!ChangeList methodsFor: 'scanning' stamp: 'sd 11/20/2005 21:26'!
scanFile: aFile from: startPosition to: stopPosition
	| itemPosition item prevChar |
	file := aFile.
	changeList := OrderedCollection new.
	list := OrderedCollection new.
	listIndex := 0.
	file position: startPosition.
'Scanning ', aFile localName, '...'
	displayProgressAt: Sensor cursorPoint
	from: startPosition to: stopPosition
	during: [:bar |
	[file position < stopPosition]
		whileTrue:
		[bar value: file position.
		[file atEnd not and: [file peek isSeparator]]
				whileTrue: [prevChar := file next].
		(file peekFor: $!!)
		ifTrue:
			[(prevChar = Character cr or: [prevChar = Character lf])
				ifTrue: [self scanCategory]]
		ifFalse:
			[itemPosition := file position.
			item := file nextChunk.
			file skipStyleChunk.
			item size > 0 ifTrue:
				[self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt)
					text: 'do it: ' , (item contractTo: 50)]]]].
	listSelections := Array new: list size withAll: false! !


!ChangeList methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 13:50'!
buildWith: builder
	^self buildWith: builder multiSelect: true! !

!ChangeList methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:46'!
buildWith: builder multiSelect: multiSelect 
	"Open a morphic view for the messageSet, whose label is labelString. 
	The listView may be either single or multiple selection type"

	| windowSpec max listSpec panelSpec textSpec |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'System Browser'.
	windowSpec children: OrderedCollection new.

	max := self wantsOptionalButtons ifTrue:[0.33] ifFalse:[0.4].

	multiSelect ifTrue:[
		listSpec := builder pluggableMultiSelectionListSpec new.
		listSpec getSelectionList: #listSelectionAt:.
		listSpec setSelectionList: #listSelectionAt:put:.
	] ifFalse:[
		listSpec := builder pluggableListSpec new.
	].

	listSpec 
		model: self;
		list: #list; 
		getIndex: #listIndex; 
		setIndex: #toggleListIndex:; 
		menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:]); 
		keyPress: #changeListKey:from:;
		frame: (0@0 corner: 1@max).
	windowSpec children add: listSpec.

	self wantsOptionalButtons ifTrue:[
		panelSpec := self buildOptionalButtonsWith: builder.
		panelSpec frame: (0@0.33 corner: 1@0.4).
		windowSpec children add: panelSpec.
	].

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		getText: #contents; 
		setText: #contents:;
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0@0.4corner: 1@1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !


!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'!
annotation
	"Answer the string to be shown in an annotation pane.  Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact."

	| annot aChange aClass |

	annot := super annotation.
	annot asString = '------' ifTrue: [^ annot].

	^ ((aChange := self currentChange) notNil and: [aChange methodSelector notNil])
		ifFalse:
			[annot]
		ifTrue:
			[((aClass := aChange methodClass) isNil or: [(aClass includesSelector: aChange methodSelector) not])
				ifTrue:
					[aChange methodClassName, ' >> ', aChange methodSelector, ' is not present in the current image.']
				ifFalse:
					['current version: ', annot]]! !

!ChangeList methodsFor: 'viewing access' stamp: 'sw 9/5/2001 13:52'!
contents
	"Answer the contents string, obeying diffing directives if needed"

	^ self showingAnyKindOfDiffs
		ifFalse:
			[self undiffedContents]
		ifTrue:
			[self showsVersions
				ifTrue:
					[self diffedVersionContents]
				ifFalse:
					[self contentsDiffedFromCurrent]]! !

!ChangeList methodsFor: 'viewing access' stamp: 'tk 4/10/1998 09:25'!
contents: aString
	listIndex = 0 ifTrue: [self changed: #flash. ^ false].
	lostMethodPointer ifNotNil: [^ self restoreDeletedMethod].
	self okToChange "means not dirty" ifFalse: ["is dirty"
		self inform: 'This is a view of a method on a file.\Please cancel your changes.  You may\accept, but only when the method is untouched.' withCRs.  ^ false].
		"Can't accept changes here.  Method text must be unchanged!!"
	(changeList at: listIndex) fileIn.
	^ true! !

!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'!
contentsDiffedFromCurrent
	"Answer the contents diffed forward from current (in-memory) method version"

	| aChange aClass |
	listIndex = 0
		ifTrue: [^ ''].
	aChange := changeList at: listIndex.
	^ ((aChange type == #method and: [(aClass := aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector])
		ifTrue:
			 [Utilities methodDiffFor: aChange text class: aClass selector: aChange methodSelector prettyDiffs: self showingPrettyDiffs]
		ifFalse:
			[(changeList at: listIndex) text]! !

!ChangeList methodsFor: 'viewing access' stamp: 'sw 11/13/2001 09:12'!
contentsSymbolQuints
	"Answer a list of quintuplets representing information on the alternative views available in the code pane"

	^ self sourceAndDiffsQuintsOnly! !

!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'!
diffedVersionContents
	"Answer diffed version contents, maybe pretty maybe not"

	| change class earlier later |
	(listIndex = 0
			or: [changeList size < listIndex])
		ifTrue: [^ ''].
	change := changeList at: listIndex.
	later := change text.
	class := change methodClass.
	(listIndex == changeList size or: [class == nil])
		ifTrue: [^ later].

	earlier := (changeList at: listIndex + 1) text.

	^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! !

!ChangeList methodsFor: 'viewing access'!
list
	^ list! !

!ChangeList methodsFor: 'viewing access'!
listIndex
	^ listIndex! !

!ChangeList methodsFor: 'viewing access'!
listSelectionAt: index
	^ listSelections at: index! !

!ChangeList methodsFor: 'viewing access' stamp: 'di 1/13/1999 14:59'!
listSelectionAt: index put: value

	^ listSelections at: index put: value! !

!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'!
restoreDeletedMethod
	"If lostMethodPointer is not nil, then this is a version browser for a method that has been removed.  In this case we want to establish a sourceCode link to prior versions.  We do this by installing a dummy method with the correct source code pointer prior to installing this version."
	| dummyMethod class selector |
	dummyMethod := CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer.
	class := (changeList at: listIndex) methodClass.
	selector := (changeList at: listIndex) methodSelector.
	class addSelectorSilently: selector withMethod: dummyMethod.
	(changeList at: listIndex) fileIn.
	"IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails."
	(class compiledMethodAt: selector) == dummyMethod
		ifTrue: [class basicRemoveSelector: selector].
	^ true! !

!ChangeList methodsFor: 'viewing access' stamp: 'nk 2/26/2004 13:50'!
selectedClass
	^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass ! !

!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'!
selectedClassOrMetaClass
	| c |
	^ (c := self currentChange) ifNotNil: [c methodClass]! !

!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'!
selectedMessageName
	| c |
	^ (c := self currentChange) ifNotNil: [c methodSelector]! !

!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'!
toggleListIndex: newListIndex

	listIndex ~= 0 ifTrue: [listSelections at: listIndex put: false].
	newListIndex ~= 0 ifTrue: [listSelections at: newListIndex put: true].
	listIndex := newListIndex.
	self changed: #listIndex.
	self contentsChanged! !

!ChangeList methodsFor: 'viewing access' stamp: 'sw 1/25/1999 14:45'!
undiffedContents
	^ listIndex = 0
		ifTrue: ['']
		ifFalse: [(changeList at: listIndex) text]! !


!ChangeList methodsFor: '*monticello' stamp: 'stephaneducasse 2/4/2006 20:47'!
changeTo: changeSubset
	| newList newChangeList |

	newChangeList := OrderedCollection new.
	newList := OrderedCollection new.

	1 to: changeList size do:
		[:i | (changeSubset includes: (changeList at: i)) ifTrue:
			[newChangeList add: (changeList at: i).
			newList add: (list at: i)]].
	newChangeList size < changeList size
		ifTrue:
			[changeList := newChangeList.
			list := newList.
			listIndex := 0.
			listSelections := Array new: list size withAll: false].
	self changed: #list

	! !

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

ChangeList class
	instanceVariableNames: ''!

!ChangeList class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !


!ChangeList class methodsFor: 'fileIn/Out' stamp: 'md 10/22/2003 16:13'!
browseChangesFile: fullName
	"Browse the selected file in fileIn format."

	fullName
		ifNotNil:
			[ChangeList browseStream: (FileStream readOnlyFileNamed:  fullName)]
		ifNil:
			[Beeper beep]! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'tak 3/16/2005 11:46'!
browseCompressedChangesFile: fullName 
	"Browse the selected file in fileIn format."

	| zipped unzipped stream |
	fullName ifNil: [^Beeper beep].
	stream := FileStream readOnlyFileNamed: fullName.
	[stream converter: Latin1TextConverter new.
	zipped := GZipReadStream on: stream.
	unzipped := zipped contents asString]
		ensure: [stream close].
	stream := (MultiByteBinaryOrTextStream with: unzipped) reset.
	ChangeList browseStream: stream! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'sd 11/20/2005 21:28'!
fileReaderServicesForFile: fullName suffix: suffix
	| services |
	services := OrderedCollection new.
	(FileStream isSourceFileSuffix: suffix) | (suffix = '*')
		ifTrue: [ services add: self serviceBrowseChangeFile ].
	(suffix = 'changes') | (suffix = '*')
		ifTrue: [ services add: self serviceBrowseDotChangesFile ].
	(fullName asLowercase endsWith: '.cs.gz') | (suffix = '*')
		ifTrue: [ services add: self serviceBrowseCompressedChangeFile ].
	^services! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:35'!
serviceBrowseChangeFile
	"Answer a service for opening a changelist browser on a file"

	^ (SimpleServiceEntry 
		provider: self 
		label: 'changelist browser'
		selector: #browseStream:
		description: 'open a changelist tool on this file'
		buttonLabel: 'changes')
		argumentGetter: [ :fileList | fileList readOnlyStream ]! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:03'!
serviceBrowseCompressedChangeFile
	"Answer a service for opening a changelist browser on a file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'changelist browser'
		selector: #browseCompressedChangesFile:
		description: 'open a changelist tool on this file'
		buttonLabel: 'changes'! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'sw 7/4/2002 18:37'!
serviceBrowseDotChangesFile
	"Answer a service for opening a changelist browser on the tail end of a .changes file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'recent changes in file'
		selector: #browseRecentLogOnPath:
		description: 'open a changelist tool on recent changes in file'
		buttonLabel: 'recent changes'! !

!ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:04'!
services
	"Answer potential file services associated with this class"

	^ { self serviceBrowseChangeFile. 
		self serviceBrowseDotChangesFile.
		self serviceBrowseCompressedChangeFile }! !


!ChangeList class methodsFor: 'initialize-release' stamp: 'hg 8/3/2000 18:14'!
initialize

	FileList registerFileReader: self! !


!ChangeList class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
open: aChangeList name: aString multiSelect: multiSelect
	"Create a standard system view for the messageSet, whose label is aString.
	The listView may be either single or multiple selection type"

	| topView listHeight annoHeight optButtonHeight codeHeight aListView underPane annotationPane buttonsView aBrowserCodeView |
	Smalltalk isMorphic
		ifTrue: [^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect].

	listHeight := 70.
	annoHeight := 10.
	optButtonHeight := aChangeList optionalButtonHeight.
	codeHeight := 110.

	topView := (StandardSystemView new)
		model: aChangeList;
		label: aString;
		minimumSize: 200 @ 120;
		borderWidth: 1.

	aListView := (multiSelect
			ifTrue: [PluggableListViewOfMany
						on: aChangeList
						list: #list
						primarySelection: #listIndex
						changePrimarySelection: #toggleListIndex:
						listSelection: #listSelectionAt:
						changeListSelection: #listSelectionAt:put:
						menu: (aChangeList showsVersions
								ifTrue: [#versionsMenu:]
								ifFalse: [#changeListMenu:])]
			ifFalse: [PluggableListView
						on: aChangeList
						list: #list
						selected: #listIndex
						changeSelected: #toggleListIndex:
						menu: (aChangeList showsVersions
								ifTrue: [#versionsMenu:]
								ifFalse: [#changeListMenu:])]).
	aListView window: (0 @ 0 extent: 200 @ listHeight).
	topView addSubView: aListView.

	underPane := aListView.
	aChangeList wantsAnnotationPane
		ifTrue:
			[annotationPane := PluggableTextView
				on: aChangeList
				text: #annotation
				accept: nil
				readSelection: nil
				menu: nil.
			annotationPane window: (0 @ 0 extent: 200 @ 10).
			topView addSubView: annotationPane below: underPane.
			underPane := annotationPane.
			codeHeight := codeHeight - annoHeight].

	aChangeList wantsOptionalButtons
		ifTrue:
			[buttonsView := aChangeList optionalButtonsView.
			buttonsView borderWidth: 1.
			topView addSubView: buttonsView below: underPane.
			underPane := buttonsView.
			codeHeight := codeHeight - optButtonHeight].

	aBrowserCodeView := PluggableTextView
			on: aChangeList
			text: #contents
			accept: #contents:
			readSelection: #contentsSelection
			menu: #codePaneMenu:shifted:.
	aBrowserCodeView
			controller: ReadOnlyTextController new;
			window: (0 @ 0 extent: 200 @ codeHeight).
	topView addSubView: aBrowserCodeView below: underPane.

	topView controller open.! !

!ChangeList class methodsFor: 'instance creation' stamp: 'RAA 1/11/2001 08:20'!
openAsMorph: aChangeList name: labelString multiSelect: multiSelect
	"Open a morphic view for the messageSet, whose label is labelString.
	The listView may be either single or multiple selection type"

	^aChangeList openAsMorphName: labelString multiSelect: multiSelect
! !


!ChangeList class methodsFor: 'public access' stamp: 'di 1/18/2001 15:30'!
browseFile: fileName    "ChangeList browseFile: 'AutoDeclareFix.st'"
	"Opens a changeList on the file named fileName"

	^ self browseStream: (FileStream readOnlyFileNamed: fileName)! !

!ChangeList class methodsFor: 'public access' stamp: 'HK 4/18/2002 15:02'!
browseRecent: charCount 
	"ChangeList browseRecent: 5000"
	"Opens a changeList on the end of the changes log file"
	^ self browseRecent: charCount on: (SourceFiles at: 2) ! !

!ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'!
browseRecent: charCount on: origChangesFile 
	"Opens a changeList on the end of the specified changes log file"
	| changeList end changesFile |
	changesFile := origChangesFile readOnlyCopy.
	changesFile setConverterForCode.
	end := changesFile size.
	Cursor read
		showWhile: [changeList := self new
						scanFile: changesFile
						from: (0 max: end - charCount)
						to: end].
	changesFile close.
	self
		open: changeList
		name: 'Recent changes'
		multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'sd 11/16/2003 14:10'!
browseRecentLog
	"ChangeList browseRecentLog"
	"Prompt with a menu of how far back to go to browse the current image's changes log file"
	^ self
		browseRecentLogOn: (SourceFiles at: 2)
		startingFrom: SmalltalkImage current lastQuitLogPosition! !

!ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'!
browseRecentLogOn: origChangesFile 
	"figure out where the last snapshot or quit was, then browse the recent entries."

	| end done block pos chunk changesFile positions prevBlock |
	changesFile := origChangesFile readOnlyCopy.
	positions := SortedCollection new.
	end := changesFile size.
	prevBlock := end.
	block := end - 1024 max: 0.
	done := false.
	[done
		or: [positions size > 0]]
		whileFalse: [changesFile position: block.
			"ignore first fragment"
			changesFile nextChunk.
			[changesFile position < prevBlock]
				whileTrue: [pos := changesFile position.
					chunk := changesFile nextChunk.
					((chunk indexOfSubCollection: '----' startingAt: 1) = 1) ifTrue: [
						({ '----QUIT'. '----SNAPSHOT' } anySatisfy: [ :str |
							chunk beginsWith: str ])
								ifTrue: [positions add: pos]]].
			block = 0
				ifTrue: [done := true]
				ifFalse: [prevBlock := block.
					block := block - 1024 max: 0]].
	changesFile close.
	positions isEmpty
		ifTrue: [self inform: 'File ' , changesFile name , ' does not appear to be a changes file']
		ifFalse: [self browseRecentLogOn: origChangesFile startingFrom: positions last]! !

!ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'!
browseRecentLogOn: origChangesFile startingFrom: initialPos 
	"Prompt with a menu of how far back to go when browsing a changes file."

	| end banners positions pos chunk i changesFile |
	changesFile := origChangesFile readOnlyCopy.
	banners := OrderedCollection new.
	positions := OrderedCollection new.
	end := changesFile size.
	changesFile setConverterForCode.
	pos := initialPos.
	[pos = 0
		or: [banners size > 20]]
		whileFalse: [changesFile position: pos.
			chunk := changesFile nextChunk.
			i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
			i > 0
				ifTrue: [positions addLast: pos.
					banners
						addLast: (chunk copyFrom: 5 to: i - 2).
					pos := Number
								readFrom: (chunk copyFrom: i + 13 to: chunk size)]
				ifFalse: [pos := 0]].
	changesFile close.
	banners size == 0 ifTrue: [^ self inform: 
'this image has never been saved
since changes were compressed'].
	pos := (SelectionMenu labelList: banners selections: positions)
				startUpWithCaption: 'Browse as far back as...'.
	pos == nil
		ifTrue: [^ self].
	self browseRecent: end - pos on: origChangesFile! !

!ChangeList class methodsFor: 'public access' stamp: 'nb 6/17/2003 12:25'!
browseRecentLogOnPath: fullName 
	"figure out where the last snapshot or quit was, then browse the recent  entries."

	fullName
		ifNotNil:
			[self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)]
		ifNil:
			[Beeper beep]
	! !

!ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'!
browseStream: changesFile
	"Opens a changeList on a fileStream"
	| changeList charCount |
	changesFile readOnly.
	changesFile setConverterForCode.
	charCount := changesFile size.
	charCount > 1000000 ifTrue:
		[(self confirm: 'The file ', changesFile name , '
is really long (' , charCount printString , ' characters).
Would you prefer to view only the last million characters?')
			ifTrue: [charCount := 1000000]].
	"changesFile setEncoderForSourceCodeNamed: changesFile name."
	Cursor read showWhile:
		[changeList := self new
			scanFile: changesFile from: changesFile size-charCount to: changesFile size].
	changesFile close.
	self open: changeList name: changesFile localName , ' log' multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'!
getRecentLocatorWithPrompt: aPrompt
	"Prompt with a menu of how far back to go.  Return nil if user backs out.  Otherwise return the number of characters back from the end of the .changes file the user wishes to include"
	 "ChangeList getRecentPosition"
	| end changesFile banners positions pos chunk i |
	changesFile := (SourceFiles at: 2) readOnlyCopy.
	banners := OrderedCollection new.
	positions := OrderedCollection new.
	end := changesFile size.
	pos := SmalltalkImage current lastQuitLogPosition.
	[pos = 0 or: [banners size > 20]] whileFalse:
		[changesFile position: pos.
		chunk := changesFile nextChunk.
		i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
		i > 0 ifTrue: [positions addLast: pos.
					banners addLast: (chunk copyFrom: 5 to: i-2).
					pos := Number readFrom: (chunk copyFrom: i+13 to: chunk size)]
			ifFalse: [pos := 0]].
	changesFile close.
	pos := (SelectionMenu labelList: banners selections: positions)
				startUpWithCaption: aPrompt.
	pos == nil ifTrue: [^ nil].
	^ end - pos! !


!ChangeList class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:07'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name  wording: 'Change List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that presents a list of all the changes found in an external file.'! !


!ChangeList class methodsFor: '*monticello' stamp: 'stephaneducasse 2/4/2006 20:47'!
recentLogOn: origChangesFile startingFrom: initialPos 
	"Prompt with a menu of how far back to go when browsing a changes file."

	| end banners positions pos chunk i changesFile |
	changesFile := origChangesFile readOnlyCopy.
	banners := OrderedCollection new.
	positions := OrderedCollection new.
	end := changesFile size.
	pos := initialPos.
	[pos = 0
		or: [banners size > 20]]
		whileFalse: [changesFile position: pos.
			chunk := changesFile nextChunk.
			i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
			i > 0
				ifTrue: [positions addLast: pos.
					banners
						addLast: (chunk copyFrom: 5 to: i - 2).
					pos := Number
								readFrom: (chunk copyFrom: i + 13 to: chunk size)]
				ifFalse: [pos := 0]].
	changesFile close.
	banners size == 0 ifTrue: [^self recent: end on: origChangesFile].

	pos := (SelectionMenu labelList: banners selections: positions)
				startUpWithCaption: 'Browse as far back as...'.
	pos == nil
		ifTrue: [^ self].
	^self recent: end - pos on: origChangesFile! !

!ChangeList class methodsFor: '*monticello' stamp: 'stephaneducasse 2/4/2006 20:47'!
recent: charCount on: origChangesFile 
	"Opens a changeList on the end of the specified changes log file"
	| changeList end changesFile |
	changesFile := origChangesFile readOnlyCopy.
	end := changesFile size.
	Cursor read
		showWhile: [changeList := self new
						scanFile: changesFile
						from: (0 max: end - charCount)
						to: end].
	changesFile close.
	^changeList! !
ChangeList subclass: #ChangeListForProjects
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeListForProjects commentStamp: '<historical>' prior: 0!
A ChangeList that looks at the changes in a revokable project.  This class has no users at present.!


!ChangeListForProjects methodsFor: 'contents' stamp: 'sw 9/5/2001 15:25'!
contents
	^ self showingAnyKindOfDiffs
		ifFalse: [self undiffedContents]
		ifTrue: [self currentDiffedFromContents]
			"Current is writing over one in list.  Show how I would change it"! !

!ChangeListForProjects methodsFor: 'contents' stamp: 'sd 11/20/2005 21:26'!
currentDiffedFromContents
	"Answer the current in-memory method diffed from the current contents"

	| aChange aClass |
	listIndex = 0
		ifTrue: [^ ''].
	aChange := changeList at: listIndex.
	^ ((aChange type == #method
				and: [(aClass := aChange methodClass) notNil])
			and: [aClass includesSelector: aChange methodSelector])
		ifTrue: [TextDiffBuilder
				buildDisplayPatchFrom: aChange text
				to: (aClass sourceCodeAt: aChange methodSelector)
				inClass: aClass
				prettyDiffs: self showingPrettyDiffs]
		ifFalse: [(changeList at: listIndex) text]! !
Object subclass: #ChangeRecord
	instanceVariableNames: 'file position type class category meta stamp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Changes'!
!ChangeRecord commentStamp: '<historical>' prior: 0!
A ChangeRecord represents a change recorded on a file in fileOut format.
It includes a type (more needs to be done here), and additional information
for certain types such as method defs which need class and category.!


!ChangeRecord methodsFor: 'access'!
category
	^category! !

!ChangeRecord methodsFor: 'access' stamp: 'sumim 9/1/2003 18:27'!
fileIndex
	^ (SourceFiles collect: [ :sf | sf name]) 
		indexOf: file name ifAbsent: [^ nil].
! !

!ChangeRecord methodsFor: 'access' stamp: 'nk 1/7/2004 10:28'!
fileName
	^(file ifNotNil: [ file name ]) 
			ifNil: [ '<no file>' ]! !

!ChangeRecord methodsFor: 'access' stamp: 'sw 10/20/2002 02:53'!
fileOutOn: aFileStream
	"File the receiver out on the given file stream"

	| aString |
	type == #method
		ifTrue:
			[aFileStream nextPut: $!!.
			aString _  class asString
							, (meta ifTrue: [' class methodsFor: ']
									ifFalse: [' methodsFor: '])
							, category asString printString.
			stamp ifNotNil:
				[aString _ aString, ' stamp: ''', stamp, ''''].
			aFileStream nextChunkPut: aString.
			aFileStream cr].

	type == #preamble ifTrue: [aFileStream nextPut: $!!].

	type == #classComment
		ifTrue:
			[aFileStream nextPut: $!!.
			aFileStream nextChunkPut: class asString, ' commentStamp: ', stamp storeString.
			aFileStream cr].

	aFileStream nextChunkPut: self string.
	type == #method ifTrue: [aFileStream nextChunkPut: ' '].
	aFileStream cr! !

!ChangeRecord methodsFor: 'access' stamp: 'tk 6/24/1999 15:27'!
headerFor: selector

	^ '    ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
				, selector
				, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])! !

!ChangeRecord methodsFor: 'access'!
isMetaClassChange
	^meta! !

!ChangeRecord methodsFor: 'access'!
methodClass 
	| methodClass |
	type == #method ifFalse: [^ nil].
	(Smalltalk includesKey: class asSymbol) ifFalse: [^ nil].
	methodClass _ Smalltalk at: class asSymbol.
	meta ifTrue: [^ methodClass class]
		ifFalse: [^ methodClass]! !

!ChangeRecord methodsFor: 'access'!
methodClassName
	^class! !

!ChangeRecord methodsFor: 'access' stamp: 'md 2/21/2006 08:54'!
methodSelector
	type == #method
		ifFalse: [^ nil].
	^ self class parserClass new parseSelector: self string! !

!ChangeRecord methodsFor: 'access' stamp: 'ar 7/15/2005 22:57'!
originalChangeSetForSelector: methodSelector
	"Returns the original changeset which contained this method version.  If it is contained in the .sources file, return #sources.  If it is in neither (e.g. its changeset was deleted), return nil.  (The selector is passed in purely as an optimization.)"

	| likelyChangeSets originalChangeSet |
	(file localName findTokens: '.') last = 'sources'
		ifTrue: [^ #sources].
	likelyChangeSets _ ChangeSet allChangeSets select: 
		[:cs | (cs atSelector: methodSelector class: self methodClass) ~~ #none].
	originalChangeSet _ likelyChangeSets
		detect: [:cs | cs containsMethodAtPosition: position]
		ifNone: [nil].
	^ originalChangeSet  "(still need to check for sources file)"! !

!ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 14:07'!
position
	^ position! !

!ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 13:33'!
prior
	| currFile preamble prevPos tokens prevFileIndex |
	currFile _ file readOnlyCopy.
	currFile position: (0 max: position - 150).
	[currFile position < (position - 1)] whileTrue: [preamble _ currFile nextChunk].
	currFile close.
	prevPos _ nil.
	(preamble findString: 'methodsFor:' startingAt: 1) > 0
		ifTrue: [tokens _ Scanner new scanTokens: preamble]
		ifFalse: [tokens _ Array new].
	((tokens size between: 7 and: 8)
	and: [(tokens at: tokens size - 5) == #methodsFor:]) ifTrue: [
		(tokens at: tokens size - 3) == #stamp:
		ifTrue: [
			prevPos _ tokens last.
			prevFileIndex _ SourceFiles fileIndexFromSourcePointer: prevPos.
			prevPos _ SourceFiles filePositionFromSourcePointer: prevPos]
		ifFalse: [
			prevPos _ tokens at: tokens size - 2.
			prevFileIndex _ tokens last].
		(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]].
	prevPos ifNil: [^ nil].
	^ {prevFileIndex. prevPos. 
		SourceFiles sourcePointerFromFileIndex: prevFileIndex andPosition: prevPos}! !

!ChangeRecord methodsFor: 'access' stamp: 'tk 6/21/1999 20:34'!
readStamp
	"Get the time stamp of this method off the file"

	| item tokens anIndex |
	stamp _ ''.
	file ifNil: [^ stamp].
	file position: position.
	item _ file nextChunk.
	tokens _ Scanner new scanTokens: item.
	tokens size < 3 ifTrue: [^ stamp].
	anIndex _ tokens indexOf: #stamp: ifAbsent: [^ stamp].
	^ stamp _ tokens at: (anIndex + 1).
! !

!ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'!
stamp
	^ stamp! !

!ChangeRecord methodsFor: 'access' stamp: 'tk 9/7/2000 15:09'!
stamp: threePartString

	stamp _ threePartString! !

!ChangeRecord methodsFor: 'access' stamp: 'di 1/13/98 16:57'!
string 
	| string |
	file openReadOnly.
	file position: position.
	string _ file nextChunk.
	file close.
	^ string! !

!ChangeRecord methodsFor: 'access' stamp: 'tk 6/23/1999 08:20'!
text
	| text |
	^ file ifNil: ['']
		ifNotNil: [
			file openReadOnly.
			file position: position.
			text _ file nextChunkText.
			file close.
			text]! !

!ChangeRecord methodsFor: 'access' stamp: 'nk 11/25/2003 09:44'!
timeStamp
	"Answer a TimeStamp that corresponds to my (text) stamp"
	| tokens date time |
	tokens := self stamp findTokens: Character separators.
	^ tokens size > 2
		ifTrue: [[date := Date
						fromString: (tokens at: tokens size - 1).
			time := Time fromString: tokens last.
			TimeStamp date: date time: time]
				on: Error
				do: [:ex | ex
						return: (TimeStamp fromSeconds: 0)]]
		ifFalse: [TimeStamp fromSeconds: 0]! !

!ChangeRecord methodsFor: 'access'!
type
	^ type! !


!ChangeRecord methodsFor: 'initialization' stamp: 'tk 6/24/1999 14:51'!
class: clsName category: cat method: method sourceFiles: fileArray
	"This should be enough to find all the information for a method, or method deletion"

	file _ fileArray at: method fileIndex.
	position _ method filePosition.
	type _ #method.
	class _ clsName copyUpTo: $ .	"the non-meta part of a class name"
	category _ cat.
	meta _ clsName endsWith: ' class'.
	self readStamp.! !

!ChangeRecord methodsFor: 'initialization'!
file: f position: p type: t
	file _ f.
	position _ p.
	type _ t! !

!ChangeRecord methodsFor: 'initialization' stamp: '6/6/97 08:48 dhhi'!
file: f position: p type: t class: c category: cat meta: m stamp: s
	self file: f position: p type: t.
	class _ c.
	category _ cat.
	meta _ m.
	stamp _ s! !

!ChangeRecord methodsFor: 'initialization' stamp: 'nk 11/26/2002 12:07'!
fileIn
	"File the receiver in.  If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it."

	| methodClass s aSelector |
	Cursor read showWhile:
		[(methodClass _ self methodClass) notNil ifTrue:
			[methodClass compile: self text classified: category withStamp: stamp notifying: nil.
			(aSelector _ self methodSelector) ifNotNil:
				[Utilities noteMethodSubmission: aSelector forClass: methodClass]].
		(type == #doIt) ifTrue:
			[((s _ self string) beginsWith: '----') ifFalse: [Compiler evaluate: s]].
		(type == #classComment) ifTrue:
			[ | cls | (cls _ Smalltalk at: class asSymbol) comment: self text stamp: stamp.
			Utilities noteMethodSubmission: #Comment forClass: cls ]]! !


!ChangeRecord methodsFor: '*monticello' stamp: 'avi 9/14/2004 14:27'!
asMethodDefinition
	^ MCMethodDefinition 
		className: class
		classIsMeta: meta
		selector: self methodSelector
		category: category
		timeStamp: stamp
		source: self string! !
Object subclass: #ChangeSet
	instanceVariableNames: 'name preamble postscript revertable isolationSet isolatedProject changeRecords structures superclasses'
	classVariableNames: 'AllChangeSets PreviousSet'
	poolDictionaries: ''
	category: 'System-Changes'!
!ChangeSet commentStamp: '<historical>' prior: 0!
ChangeSets keep track of the changes made to a system, so they can be written on a file as source code (a "fileOut").  Every project has an associated changeSet.  For simple projects, a different changeSet may be designated to capture changes at any time.

This implementation of ChangeSet is capable of remembering and manipulating methods for which the classes are not present in the system.  However at the present time, this capability is not used in normal rearranging and fileOuts, but only for invoking and revoking associated with isolation layers.

For isolated projects (see Project class comment), the changeSet binding is semi-permanent.  Every project exists in an isolation layer defined by its closest enclosing parent (or itself) that is isolated.  If a project is not isolated, then changes reported to its designated changeSet must also be reported to the permanent changeSet for that layer, designated in the isolated project.  This ensures that that outer project will be able to revert all changes upon exit.

Note that only certain changes may be reverted.  Classes may not be added, removed, renamed or reshaped except in the layer in which they are defined because these operations on non-local classes are not revertable.

If a Squeak Project is established as being isolated, then its associated changeSet will be declared to be revertable.  In this case all changes stored can be reverted.  The changeSet associated with an isolated project is tied to that project, and cannot be edited in a changeSorter.
------

name - a String used to name the changeSet, and thus any associated project or fileOut.

preamble and postscript:  two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet.

revertable - a Boolean
If this variable is true, then all of the changes recorded by this changeSet can be reverted.

isolationSet - a ChangeSet or nil
The isolationSet is the designated changeSet for an isolation layer.  If this changeSet is an isolationSet, then this variable will be nil.  If not, then it points to the isolationSet for this layer, and all changes reported here will also be reported to the isolationSet.

isolatedProject - a Project or nil
If this is an isolationSet, then this variable points to the project with which it is associated.

changeRecords -  Dictionary {class name -> a ClassChangeRecord}.
These classChangeRecords (qv) remember all of the system changes.

structures -    Dictionary {#Rectangle -> #(<classVersionInteger> 'origin' 'corner')}.
Of  the names of the instances variables before any changes for all classes in classChanges, and all of their superclasses.  In the same format used in SmartRefStream.  Inst var names are strings.  

superclasses -    Dictionary {#Rectangle -> #Object}.
Of all classes in classChanges, and all of their superclasses.

Structures and superclasses save the instance variable names of this class and all of its superclasses.  Later we can tell how it changed and write a conversion method.  The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp).

NOTE:  It should be fairly simple, by adding a bit more information to the classChangeRecords, to reconstruct the information now stored in 'structures' and 'superclasses'.  This would be a welcome simplification.
!


!ChangeSet methodsFor: 'accessing' stamp: 'BJP 4/24/2001 00:23'!
author
	| author |
	self assurePreambleExists.
	author _ self preambleString lineNumber: 3.
	author _ author copyFrom: 8 to: author size. "Strip the 'Author:' prefix. Ugly ugly."	
	^author withBlanksTrimmed.
	! !

!ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'!
classRemoves

	^ changeRecords keys select:
		[:className | (changeRecords at: className) isClassRemoval]! !

!ChangeSet methodsFor: 'accessing' stamp: 'ar 7/16/2005 18:59'!
editPostscript
	"edit the receiver's postscript, in a separate window.  "
	self assurePostscriptExists.
	UIManager default
		edit: self postscript 
		label: 'Postscript for ChangeSet named ', name
		accept:[:aString| self postscript: aString].! !

!ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:44'!
hasPostscript
	^ postscript notNil! !

!ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'!
methodChanges

	| methodChangeDict changeTypes |
	methodChangeDict _ Dictionary new.
	changeRecords associationsDo:
		[:assn |
		changeTypes _ assn value methodChangeTypes.
		changeTypes isEmpty ifFalse: [methodChangeDict at: assn key put: changeTypes]].
	^ methodChangeDict! !

!ChangeSet methodsFor: 'accessing' stamp: 'di 3/29/2000 16:22'!
methodInfoFromRemoval: classAndSelector

	^ (self changeRecorderFor: classAndSelector first)
		infoFromRemoval: classAndSelector last! !

!ChangeSet methodsFor: 'accessing'!
name
	"The name of this changeSet.
	 2/7/96 sw: If name is nil, we've got garbage.  Help to identify."

	^ name == nil
		ifTrue:
			['<no name -- garbage?>']
		ifFalse:
			[name]! !

!ChangeSet methodsFor: 'accessing'!
name: anObject
	name _ anObject! !

!ChangeSet methodsFor: 'accessing' stamp: 'ar 7/16/2005 18:04'!
postscriptHasDependents
	^false! !

!ChangeSet methodsFor: 'accessing'!
printOn: aStream
	"2/7/96 sw: provide the receiver's name in the printout"
	super printOn: aStream.
	aStream nextPutAll: ' named ', self name! !

!ChangeSet methodsFor: 'accessing' stamp: 'MPW 1/1/1901 22:02'!
printOnStream: aStream
	"2/7/96 sw: provide the receiver's name in the printout"
	super printOnStream: aStream.
	aStream print: ' named ', self name! !

!ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:48'!
removePostscript
	postscript _ nil! !

!ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'!
structures
	^structures! !

!ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'!
superclasses
	^superclasses! !


!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 13:10'!
addClass: class 
	"Include indication that a new class was created."

	class wantsChangeSetLogging ifFalse: [^ self].
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet addClass: class].
	self atClass: class add: #new.
	self atClass: class add: #change.
	self addCoherency: class name! !

!ChangeSet methodsFor: 'change logging' stamp: 'NS 1/19/2004 18:30'!
changeClass: class from: oldClass
	"Remember that a class definition has been changed.  Record the original structure, so that a conversion method can be built."

	class wantsChangeSetLogging ifFalse: [^ self]. 
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet changeClass: class from: oldClass].
	class isMeta 
		ifFalse: [self atClass: class add: #change]	"normal"
		ifTrue: [((self classChangeAt: class theNonMetaClass name) includes: #add) 
			ifTrue: [self atClass: class add: #add] 	"When a class is defined, the metaclass
				is not recorded, even though it was added.  A further change is
				really just part of the original add."
			ifFalse: [self atClass: class add: #change]].
	self addCoherency: class name.
	(self changeRecorderFor: class) notePriorDefinition: oldClass.
	self noteClassStructure: oldClass! !

!ChangeSet methodsFor: 'change logging' stamp: 'NS 2/17/2005 18:57'!
event: anEvent
	"Hook for SystemChangeNotifier"
	anEvent itemKind = SystemChangeNotifier classKind ifTrue: [
		anEvent isRemoved 
			ifTrue: [self noteRemovalOf: anEvent item].
		anEvent isAdded 
			ifTrue: [self addClass: anEvent item].
		anEvent isModified 
			ifTrue: [anEvent anyChanges ifTrue: [self changeClass: anEvent item from: anEvent oldItem]].
		anEvent isCommented 
			ifTrue: [self commentClass: anEvent item].
		anEvent isRenamed 
			ifTrue: [self renameClass: anEvent item as: anEvent newName].
		anEvent isReorganized
			ifTrue: [self reorganizeClass: anEvent item].
		anEvent isRecategorized
			ifTrue: [self changeClass: anEvent item from: anEvent item].
	].

	anEvent itemKind = SystemChangeNotifier methodKind ifTrue: [
		anEvent isAdded
			ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: nil].
		anEvent isModified
			ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: anEvent oldItem].
		anEvent isRemoved
			ifTrue: [self removeSelector: anEvent itemSelector class: anEvent itemClass priorMethod: anEvent item lastMethodInfo: {anEvent item sourcePointer. anEvent itemProtocol}].
		anEvent isRecategorized
			ifTrue: [self reorganizeClass: anEvent itemClass].
	].! !

!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 11:08'!
noteNewMethod: newMethod forClass: class selector: selector priorMethod: methodOrNil

	class wantsChangeSetLogging ifFalse: [^ self].
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet noteNewMethod: newMethod forClass: class selector: selector
				priorMethod: methodOrNil].
	(self changeRecorderFor: class)
		noteNewMethod: newMethod selector: selector priorMethod: methodOrNil
! !

!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 12:29'!
removeSelector: selector class: class priorMethod: priorMethod lastMethodInfo: info
	"Include indication that a method has been forgotten.
	info is a pair of the source code pointer and message category
	for the method that was removed."

	class wantsChangeSetLogging ifFalse: [^ self].
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet removeSelector: selector class: class
				priorMethod: priorMethod lastMethodInfo: info].
	(self changeRecorderFor: class)
		noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: info
! !

!ChangeSet methodsFor: 'change logging' stamp: 'tk 6/8/2001 09:27'!
renameClass: class as: newName 
	"Include indication that a class has been renamed."

	| recorder |
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet renameClass: class as: newName].
	(recorder _ self changeRecorderFor: class)
		noteChangeType: #rename;
		noteNewName: newName asSymbol.
		
	"store under new name (metaclass too)"
	changeRecords at: newName put: recorder.
	changeRecords removeKey: class name.
	self noteClassStructure: class.

	recorder _ changeRecords at: class class name ifAbsent: [^ nil].
	changeRecords at: (newName, ' class') put: recorder.
	changeRecords removeKey: class class name.
	recorder noteNewName: newName , ' class'! !


!ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'!
changedClassNames
	"Answer a OrderedCollection of the names of changed or edited classes.
	DOES include removed classes.  Sort alphabetically."

	^ changeRecords keysSortedSafely ! !

!ChangeSet methodsFor: 'class changes' stamp: 'di 3/23/2000 08:12'!
changedClasses
	"Answer an OrderedCollection of changed or edited classes.
	Does not include removed classes.  Sort alphabetically by name."

	"Much faster to sort names first, then convert back to classes.  Because metaclasses reconstruct their name at every comparison in the sorted collection.
	8/91 sw chgd to filter out non-existent classes (triggered by problems with class-renames"

	^ self changedClassNames
		collect: [:className | Smalltalk classNamed: className]
		thenSelect: [:aClass | aClass notNil]! !

!ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'!
classChangeAt: className
	"Return what we know about class changes to this class."

	^ (changeRecords at: className ifAbsent: [^ Set new])
		allChangeTypes! !

!ChangeSet methodsFor: 'class changes' stamp: 'NS 1/26/2004 09:46'!
commentClass: class 
	"Include indication that a class comment has been changed."

	class wantsChangeSetLogging ifFalse: [^ self].
	self atClass: class add: #comment! !

!ChangeSet methodsFor: 'class changes' stamp: 'nk 6/26/2002 12:30'!
containsClass: aClass
	^ self changedClasses includes: aClass! !

!ChangeSet methodsFor: 'class changes' stamp: 'dvf 9/27/2005 19:04'!
fatDefForClass: class

	| newDef oldDef oldStrm newStrm outStrm oldVars newVars addedVars |
	
	class isBehavior ifFalse: [^class definition].
	
	newDef _ class definition.
	oldDef _ (self changeRecorderFor: class) priorDefinition.
	oldDef ifNil: [^ newDef].
	oldDef = newDef ifTrue: [^ newDef].

	oldStrm _ ReadStream on: oldDef.
	newStrm _ ReadStream on: newDef.
	outStrm _ WriteStream on: (String new: newDef size * 2).

	"Merge inst vars from old and new defs..."
	oldStrm upToAll: 'instanceVariableNames'; upTo: $'.
	outStrm 
		nextPutAll: (newStrm upToAll: 'instanceVariableNames'); 
		nextPutAll: 'instanceVariableNames:'.
	newStrm peek = $: ifTrue: [newStrm next].	"may or may not be there, but already written"
	outStrm
		nextPutAll: (newStrm upTo: $'); nextPut: $'.
	oldVars _ (oldStrm upTo: $') findTokens: Character separators.
	newVars _ (newStrm upTo: $') findTokens: Character separators.
	addedVars _ oldVars asSet addAll: newVars; removeAll: oldVars; asOrderedCollection.
	oldVars , addedVars do: [:var | outStrm nextPutAll: var; space].
	outStrm nextPut: $'.

	class isMeta ifFalse:
		["Merge class vars from old and new defs..."
		oldStrm upToAll: 'classVariableNames:'; upTo: $'.
		outStrm nextPutAll: (newStrm upToAll: 'classVariableNames:'); nextPutAll: 'classVariableNames:';
			nextPutAll: (newStrm upTo: $'); nextPut: $'.
		oldVars _ (oldStrm upTo: $') findTokens: Character separators.
		newVars _ (newStrm upTo: $') findTokens: Character separators.
		addedVars _ oldVars asSet addAll: newVars; removeAll: oldVars; asOrderedCollection.
		oldVars , addedVars do: [:var | outStrm nextPutAll: var; space].
		outStrm nextPut: $'].

	outStrm nextPutAll: newStrm upToEnd.
	^ outStrm contents
! !

!ChangeSet methodsFor: 'class changes' stamp: 'tk 6/9/1999 19:54'!
noteClassForgotten: className
	"Remove from structures if class is not a superclass of some other one we are remembering"

	structures ifNil: [^ self].
	Smalltalk at: className ifPresent: [:cls |
		cls subclasses do: [:sub | (structures includesKey: sub) ifTrue: [
			^ self]]].  "No delete"
	structures removeKey: className ifAbsent: [].! !

!ChangeSet methodsFor: 'class changes' stamp: 'dvf 9/27/2005 19:05'!
noteClassStructure: aClass
	"Save the instance variable names of this class and all of its superclasses.  Later we can tell how it changed and write a conversion method.  The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp)."

	| clsName |
	aClass isBehavior ifFalse: [^ self].
	
	structures ifNil: [structures _ Dictionary new.
				superclasses _ Dictionary new].
	clsName _ (aClass name asLowercase beginsWith: 'anobsolete') 
		ifTrue: [(aClass name copyFrom: 11 to: aClass name size) asSymbol]
		ifFalse: [aClass name].
	(structures includesKey: clsName) ifFalse: [
		structures at: clsName put: 
			((Array with: aClass classVersion), (aClass allInstVarNames)).
		superclasses at: clsName put: aClass superclass name].
	"up the superclass chain"
	aClass superclass ifNotNil: [self noteClassStructure: aClass superclass].
! !

!ChangeSet methodsFor: 'class changes' stamp: 'NS 1/19/2004 17:49'!
noteRemovalOf: class
	"The class is about to be removed from the system.
	Adjust the receiver to reflect that fact."

	class wantsChangeSetLogging ifFalse: [^ self].
	(self changeRecorderFor: class)
		noteChangeType: #remove fromClass: class.
	changeRecords removeKey: class class name ifAbsent: [].! !

!ChangeSet methodsFor: 'class changes'!
reorganizeClass: class 
	"Include indication that a class was reorganized."

	self atClass: class add: #reorganize! !

!ChangeSet methodsFor: 'class changes' stamp: 'di 5/16/2000 09:03'!
trimHistory 
	"Drop non-essential history:  methods added and then removed, as well as rename and reorganization of newly-added classes."

	changeRecords do: [:chgRecord | chgRecord trimHistory]! !


!ChangeSet methodsFor: 'converting' stamp: 'RAA 12/20/2000 16:02'!
convertApril2000: varDict using: smartRefStrm
	| cls info selector pair classChanges methodChanges methodRemoves classRemoves |
	"These variables are automatically stored into the new instance:
		('name' 'preamble' 'postscript' 'structures' 'superclasses' ).
	This method is for additional changes.
	It initializes the isolation variables, and then duplicates the logic fo
		assimilateAllChangesFoundIn:."

	revertable _ false.
	isolationSet _ nil.
	isolatedProject _ nil.
	changeRecords _ Dictionary new.

	classChanges _ varDict at: 'classChanges'.
	classChanges keysDo:
		[:className |
	  	(cls _ Smalltalk classNamed: className) ifNotNil:
			[info _ classChanges at: className ifAbsent: [Set new].
			info do: [:each | self atClass: cls add: each]]].

	methodChanges _ varDict at: 'methodChanges'.
	methodRemoves _ varDict at: 'methodRemoves'.
	methodChanges keysDo:
		[:className |
	  	(cls _ Smalltalk classNamed: className) ifNotNil:
			[info _ methodChanges at: className ifAbsent: [Dictionary new].
			info associationsDo:
				[:assoc | selector _ assoc key.
				(assoc value == #remove or: [assoc value == #addedThenRemoved])
					ifTrue:
						[assoc value == #addedThenRemoved
							ifTrue: [self atSelector: selector class: cls put: #add].
						pair _ methodRemoves at: {cls name. selector} ifAbsent: [nil] .
						self removeSelector: selector class: cls priorMethod: nil lastMethodInfo: pair]
					ifFalse: 
						[self atSelector: selector class: cls put: assoc value]]]].

	classRemoves _ varDict at: 'classRemoves'.
	classRemoves do:
		[:className | self noteRemovalOf: className].

! !

!ChangeSet methodsFor: 'converting' stamp: 'tk 11/26/2004 05:56'!
convertToCurrentVersion: varDict refStream: smartRefStrm

	"major change - 4/4/2000"
	| newish |
	varDict at: 'classChanges' ifPresent: [ :x |
		newish _ self convertApril2000: varDict using: smartRefStrm.
		newish == self ifFalse: [^ newish].
		].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/15/2005 21:53'!
askAddedInstVars: classList
	| pairList pairClasses index pls newStruct oldStruct |
	"Ask the author whether these newly added inst vars need to be non-nil"

	pairList _ OrderedCollection new.
	pairClasses _ OrderedCollection new.
	"Class version numbers:  If it must change, something big happened.  Do need a conversion method then.  Ignore them here."
	classList do: [:cls |
		newStruct _ (cls allInstVarNames).
		oldStruct _ (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst.
		newStruct do: [:instVarName |
			(oldStruct includes: instVarName) ifFalse: [
				pairList add: cls name, ' ', instVarName.
				pairClasses add: cls]]].

	pairList isEmpty ifTrue: [^ #()].
	[index _ UIManager default 
		chooseFrom: pairList, #('all of these need a non-nil value'
						'all of these are OK with a nil value')
		title:
'These instance variables were added.
When an old project comes in, newly added 
instance variables will have the value nil.
Click on items to remove them from the list.
Click on any for which nil is an OK value.'.
	(index <= (pls _ pairList size)) & (index > 0) ifTrue: [
		pairList removeAt: index.
		pairClasses removeAt: index].
	index = (pls + 2) ifTrue: ["all are OK" ^ #()].
	pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse.

	^ pairClasses asSet asArray	"non redundant"! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/15/2005 21:54'!
askRemovedInstVars: classList
	| pairList pairClasses index pls newStruct oldStruct |
	"Ask the author whether these newly removed inst vars need to have their info saved"

	pairList _ OrderedCollection new.
	pairClasses _ OrderedCollection new.
	"Class version numbers:  If it must change, something big happened.  Do need a conversion method then.  Ignore them here."
	classList do: [:cls |
		newStruct _ (cls allInstVarNames).
		oldStruct _ (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst.
		oldStruct do: [:instVarName |
			(newStruct includes: instVarName) ifFalse: [
				pairList add: cls name, ' ', instVarName.
				pairClasses add: cls]]].

	pairList isEmpty ifTrue: [^ #()].
	[index _ UIManager default 
		chooseFrom: pairList, #('all of these need a conversion method'
						'all of these have old values that can be erased')
			title:
'These instance variables were removed.
When an old project comes in, instance variables 
that have been removed will lose their contents.
Click on items to remove them from the list.
Click on any whose value is unimportant and need not be saved.'.
	(index <= (pls _ pairList size)) & (index > 0) ifTrue: [
		pairList removeAt: index.
		pairClasses removeAt: index].
	index = (pls + 2) ifTrue: ["all are OK" ^ #()].
	pairList isEmpty | (index = (pls + 1))  "all need conversion, exit"] whileFalse.

	^ pairClasses asSet asArray	"non redundant"! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/15/2005 21:51'!
askRenames: renamed addTo: msgSet using: smart
	| list rec ans oldStruct newStruct |
	"Go through the renamed classes.  Ask the user if it could be in a project.  Add a method in SmartRefStream, and a conversion method in the new class."

	list _ OrderedCollection new.
	renamed do: [:cls |
		rec _ changeRecords at: cls name.
		rec priorName ifNotNil: [
			ans _ UIManager default chooseFrom: 
					#('Yes, write code to convert those instances'
					'No, no instances are in projects')
				title: 'You renamed class ', rec priorName, 
				' to be ', rec thisName,
				'.\Could an instance of ', rec priorName, 
				' be in a project on someone''s disk?'.
			ans = 1 ifTrue: [
					oldStruct _ structures at: rec priorName ifAbsent: [nil].
					newStruct _ (Array with: cls classVersion), (cls allInstVarNames).
					oldStruct ifNotNil: [
						smart writeConversionMethodIn: cls fromInstVars: oldStruct 
								to: newStruct renamedFrom: rec priorName.
						smart writeClassRename: cls name was: rec priorName.
						list add: cls name, ' convertToCurrentVersion:refStream:']]
				ifFalse: [structures removeKey: rec priorName ifAbsent: []]]].
	list isEmpty ifTrue: [^ msgSet].
	msgSet messageList ifNil: [msgSet initializeMessageList: list]
		ifNotNil: [list do: [:item | msgSet addItem: item]].
	^ msgSet! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:05'!
assurePostscriptExists
	"Make sure there is a StringHolder holding the postscript.  "

	"NOTE: FileIn recognizes the postscript by the line with Postscript: on it"
	postscript == nil ifTrue: [postscript _ '"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."
']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:02'!
assurePreambleExists
	"Make sure there is a StringHolder holding the preamble; if it's found to have reverted to empty contents, put up the template"

	(preamble isEmptyOrNil)
		ifTrue: [preamble _ self preambleTemplate]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ls 10/21/2001 21:09'!
buildMessageForMailOutWithUser: userName

	| message compressBuffer compressStream data compressedStream compressTarget |

	"prepare the message"
	message := MailMessage empty.
	message setField: 'from' toString: userName.
	message setField: 'to' toString: 'squeak-dev@lists.squeakfoundation.org'.
	message setField: 'subject' toString: (self chooseSubjectPrefixForEmail, name). 

	message body: (MIMEDocument contentType: 'text/plain' content: (String streamContents: [ :str |
		str nextPutAll: 'from preamble:'; cr; cr.
		self fileOutPreambleOn: str ])).

	"Prepare the gzipped data"
	data _ WriteStream on: String new.
	data header; timeStamp.
	self fileOutPreambleOn: data.
	self fileOutOn: data.
	self fileOutPostscriptOn: data.
	data trailer.
	data _ ReadStream on: data contents.
	compressBuffer _ ByteArray new: 1000.
	compressStream _ GZipWriteStream on: (compressTarget _ WriteStream on: (ByteArray new: 1000)).
	[data atEnd]
		whileFalse: [compressStream nextPutAll: (data nextInto: compressBuffer)].
	compressStream close.
	compressedStream _ ReadStream on: compressTarget contents asString.

	message addAttachmentFrom: compressedStream withName: (name, '.cs.gz').

	^ message! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:15'!
checkForAlienAuthorship
	"Check to see if there are any methods in the receiver that have author initials other than that of the current author, and open a browser on all found"

	| aList initials |
	(initials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
	(aList _ self methodsWithInitialsOtherThan: initials) size > 0
		ifFalse:
			[^ self inform: 'All methods in "', self name, '"
have authoring stamps which start with "', initials, '"']
		ifTrue:
			[self systemNavigation  browseMessageList: aList name: 'methods in "', self name, '" whose authoring stamps do not start with "', initials, '"']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'!
checkForAnyAlienAuthorship
	"Check to see if there are any versions of any methods in the receiver that have author initials other than that of the current author, and open a browser on all found"

	| aList initials |
	(initials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
	(aList _ self methodsWithAnyInitialsOtherThan: initials) size > 0
		ifFalse: [^ self inform: 'All versions of all methods in "', self name, '"
have authoring stamps which start with "', initials, '"']
		ifTrue:
			[self systemNavigation  browseMessageList: aList name: 'methods in "', self name, '" with any authoring stamps not starting with "', initials, '"']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/17/2005 11:13'!
checkForConversionMethods
	"See if any conversion methods are needed"
	| oldStruct newStruct tell choice list need
sel smart restore renamed listAdd listDrop msgSet rec nn |

	Preferences conversionMethodsAtFileOut ifFalse: [^ self].	"Check preference"
	structures ifNil: [^ self].

	list _ OrderedCollection new.
	renamed _ OrderedCollection new.
	self changedClasses do: [:class |
		need _ (self atClass: class includes: #new) not.
		need ifTrue: ["Renamed classes."
			(self atClass: class includes: #rename) ifTrue: [
				rec _ changeRecords at: class name.
				rec priorName ifNotNil: [
					(structures includesKey: rec priorName) ifTrue: [
						renamed add: class.  need _ false]]]].
		need ifTrue: [need _ (self atClass: class includes: #change)].
		need ifTrue: [oldStruct _ structures at: class name 
									ifAbsent: [need _ false.  #()]].
		need ifTrue: [
			newStruct _ (Array with: class classVersion), (class allInstVarNames).
			need _ (oldStruct ~= newStruct)].
		need ifTrue: [sel _ #convertToCurrentVersion:refStream:.
			(#(add change) includes: (self atSelector: sel class: class)) ifFalse: [
				list add: class]].
		].

	list isEmpty & renamed isEmpty ifTrue: [^ self].
	"Ask user if want to do this"
	tell _ 'If there might be instances of ', (list asArray, renamed asArray) printString,
		'\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\'
			withCRs,
		'After you edit the conversion method, you''ll need to fileOut again.\' withCRs,
		'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'.
	choice _ UIManager default chooseFrom:
'Write a conversion method by editing a prototype
These classes are not used in any object file.  fileOut my changes now.
I''m too busy.  fileOut my changes now.
Don''t ever ask again.  fileOut my changes now.' withCRs title: tell. 
	choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
	choice = 2 ifTrue: ["Don't consider this class again in the changeSet"
			list do: [:cls | structures removeKey: cls name ifAbsent: []].
			renamed do: [:cls | 
				nn _ (changeRecords at: cls name) priorName.
				structures removeKey: nn ifAbsent: []]].
	choice ~= 1 ifTrue: [^ self].	"exit if choice 2,3,4"

	listAdd _ self askAddedInstVars: list.	"Go through each inst var that was added"
	listDrop _ self askRemovedInstVars: list.	"Go through each inst var that was removed"
	list _ (listAdd, listDrop) asSet asArray.

	smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345').
	smart structures: structures.
	smart superclasses: superclasses.
	(restore _ self class current) == self ifFalse: [
		self class  newChanges: self].	"if not current one"
	msgSet _ smart conversionMethodsFor: list.
		"each new method is added to self (a changeSet).  Then filed out with the rest."
	self askRenames: renamed addTo: msgSet using: smart.	"renamed classes, add 2 methods"
	restore == self ifFalse: [self class newChanges: restore].
	msgSet isEmpty ifTrue: [^ self].
	self inform: 'Remember to fileOut again after modifying these methods.'.
	ToolSet browseMessageSet: msgSet name: 'Conversion methods for ', self name autoSelect: false.! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/26/2000 10:06'!
checkForSlips
	"Return a collection of method refs with possible debugging code in them."
	| slips method |
	slips _ OrderedCollection new.
	self changedClasses do:
		[:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: 
				[:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
					[method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
					method ifNotNil:
						[method hasReportableSlip
							ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'!
checkForUnclassifiedMethods
	"Open a message list browser on all methods in the current change set that have not been categorized,"

	| aList |
	(aList _ self methodsWithoutClassifications) size > 0
		ifFalse:
			[^ self inform: 'All methods in "', self name, '"
are categorized.']
		ifTrue:
			[self systemNavigation  browseMessageList: aList name: 'methods in "', self name, '" which have not been categorized']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/17/2005 10:48'!
checkForUncommentedClasses
	"Check to see if any classes involved in this change set do not have class comments.  Open up a browser showing all such classes."

	| aList |
	aList _ self changedClasses
		select:
			[:aClass | aClass theNonMetaClass organization classComment isEmptyOrNil]
		thenCollect:
			[:aClass  | aClass theNonMetaClass name].

	aList size > 0
		ifFalse:
			[^ self inform: 'All classes involved in this change set have class comments']
		ifTrue:
			[ToolSet openClassListBrowser: aList asSet asSortedArray title: 'Classes in Change Set ', self name, ': classes that lack class comments']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'!
checkForUncommentedMethods
	| aList |
	"Check to see if there are any methods in the receiver that have no comments, and open a browser on all found"

	(aList _ self methodsWithoutComments) size > 0
		ifFalse:
			[^ self inform: 'All methods in "', self name, '" have comments']
		ifTrue:
			[self systemNavigation  browseMessageList: aList name: 'methods in "', self name, '" that lack comments']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/29/2003 20:19'!
checkForUnsentMessages
	"Check the change set for unsent messages, and if any are found, open 
	up a message-list browser on them"
	| nameLine allChangedSelectors augList unsent |
	nameLine _ '"' , self name , '"'.
	allChangedSelectors _ Set new.
	(augList _ self changedMessageListAugmented)
		do: [:each | each isValid
				ifTrue: [allChangedSelectors add: each methodSymbol]].
	unsent _ self systemNavigation allUnSentMessagesIn: allChangedSelectors.
	unsent size = 0
		ifTrue: [^ self inform: 'There are no unsent 
messages in change set
' , nameLine].
	self systemNavigation
		browseMessageList: (augList
				select: [:each | unsent includes: each methodSymbol])
		name: 'Unsent messages in ' , nameLine! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:21'!
chooseSubjectPrefixForEmail

	| subjectIndex |

	subjectIndex _
		(UIManager default chooseFrom: #('Bug fix [FIX]' 'Enhancement [ENH]' 'Goodie [GOODIE]' 'Test suite [TEST]' 'None of the above (will not be archived)')
			title: 'What type of change set\are you submitting to the list?' withCRs).

	^ #('[CS] ' '[FIX] ' '[ENH] ' '[GOODIE] ' '[TEST] ' '[CS] ') at: subjectIndex + 1! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 10/15/2003 09:55'!
defaultChangeSetDirectory
	^self class defaultChangeSetDirectory! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'md 2/22/2006 21:16'!
fileOut
	"File out the receiver, to a file whose name is a function of the  
	change-set name and either of the date & time or chosen to have a  
	unique numeric tag, depending on the preference  
	'changeSetVersionNumbers'"
	| slips nameToUse internalStream |
	self checkForConversionMethods.
	ChangeSet promptForDefaultChangeSetDirectoryIfNecessary.
	nameToUse := Preferences changeSetVersionNumbers
				ifTrue: [self defaultChangeSetDirectory nextNameFor: self name extension: FileStream cs]
				ifFalse: [self name , FileDirectory dot , Utilities dateTimeSuffix, FileDirectory dot , FileStream cs].
	nameToUse := self defaultChangeSetDirectory fullNameFor: nameToUse.
	Cursor write showWhile: [
			internalStream _ WriteStream on: (String new: 10000).
			internalStream header; timeStamp.
			self fileOutPreambleOn: internalStream.
			self fileOutOn: internalStream.
			self fileOutPostscriptOn: internalStream.
			internalStream trailer.

			FileStream writeSourceCodeFrom: internalStream baseName: (nameToUse copyFrom: 1 to: nameToUse size - 3) isSt: false useHtml: false.
	].
	Preferences checkForSlips
		ifFalse: [^ self].
	slips := self checkForSlips.
	(slips size > 0
			and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?' chooseFrom: 'Ignore\Browse slips')
					= 2])
		ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/28/2000 09:35'!
fileOutChangesFor: class on: stream 
	"Write out all the method changes for this class."

	| changes |
	changes _ Set new.
	(self methodChangesAtClass: class name) associationsDo: 
		[:mAssoc | (mAssoc value = #remove or: [mAssoc value = #addedThenRemoved])
			ifFalse: [changes add: mAssoc key]].
	changes isEmpty ifFalse: 
		[class fileOutChangedMessages: changes on: stream.
		stream cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 19:04'!
fileOutOn: stream 
	"Write out all the changes the receiver knows about"

	| classList traits classes traitList list |
	(self isEmpty and: [stream isKindOf: FileStream])
		ifTrue: [self inform: 'Warning: no changes to file out'].
		
	traits _ self changedClasses reject: [:each | each isBehavior].
	classes _ self changedClasses select: [:each | each isBehavior].
	traitList _ self class traitsOrder: traits asOrderedCollection.
	classList _ self class superclassOrder: classes asOrderedCollection.
	list _ OrderedCollection new
		addAll: traitList;
		addAll: classList;
		yourself.
	
	"First put out rename, max classDef and comment changes."
	list do: [:aClass | self fileOutClassDefinition: aClass on: stream].

	"Then put out all the method changes"
	list do: [:aClass | self fileOutChangesFor: aClass on: stream].

	"Finally put out removals, final class defs and reorganization if any"
	list reverseDo: [:aClass | self fileOutPSFor: aClass on: stream].

	self classRemoves asSortedCollection do:
		[:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 5/8/2000 20:47'!
fileOutPSFor: class on: stream 
	"Write out removals and initialization for this class."

	| dict changeType classRecord currentDef |
	classRecord _ changeRecords at: class name ifAbsent: [^ self].
	dict _ classRecord methodChangeTypes.
	dict keysSortedSafely do:
		[:key | changeType _ dict at: key.
		(#(remove addedThenRemoved) includes: changeType)
			ifTrue: [stream nextChunkPut: class name,
						' removeSelector: ', key storeString; cr]
			ifFalse: [(key = #initialize and: [class isMeta]) ifTrue:
						[stream nextChunkPut: class soleInstance name, ' initialize'; cr]]].
	((classRecord includesChangeType: #change)
		and: [(currentDef _ class definition) ~= (self fatDefForClass: class)]) ifTrue:
		[stream command: 'H3'; nextChunkPut: currentDef; cr; command: '/H3'].
	(classRecord includesChangeType: #reorganize) ifTrue:
		[class fileOutOrganizationOn: stream.
		stream cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/29/1999 13:35'!
fileOutPostscriptOn: stream 
	"If the receiver has a postscript, put it out onto the stream.  "

	| aString |
	aString _ self postscriptString.
	(aString ~~ nil and: [aString size > 0])
		ifTrue:
			[stream nextChunkPut: aString "surroundedBySingleQuotes".
			stream cr; cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/29/1999 14:58'!
fileOutPreambleOn: stream 
	"If the receiver has a preamble, put it out onto the stream.  "

	| aString |
	aString _ self preambleString.
	(aString ~~ nil and: [aString size > 0])
		ifTrue:
			[stream nextChunkPut: aString "surroundedBySingleQuotes".
			stream cr; cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 14:16'!
lookForSlips
	"Scan the receiver for changes that the user may regard as slips to be remedied"

	| slips nameLine msg |
	nameLine _ '
"', self name, '"
'.
	(slips _ self checkForSlips) size == 0 ifTrue:
		[^ self inform: 'No slips detected in change set', nameLine].

	msg _ slips size == 1
		ifTrue:
			[ 'One method in change set', nameLine, 
'has a halt, reference to the Transcript,
and/or some other ''slip'' in it.
Would you like to browse it? ?']
		ifFalse:
			[ slips size printString,
' methods in change set', nameLine, 'have halts or references to the
Transcript or other ''slips'' in them.
Would you like to browse them?'].

	(UIManager default  chooseFrom: #('Ignore' 'Browse slips') title: msg) = 2
		ifTrue: [self systemNavigation  browseMessageList: slips
							name: 'Possible slips in ', name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'!
mailOut
	"Email a compressed version of this changeset to the squeak-dev list, so that it can be shared with everyone.  (You will be able to edit the email before it is sent.)"

	| userName message slips |

	userName _ MailSender userName.

	self checkForConversionMethods.
	Cursor write showWhile: [message _ self buildMessageForMailOutWithUser: userName].

	MailSender sendMessage: message.

	Preferences suppressCheckForSlips ifTrue: [^ self].
	slips _ self checkForSlips.
	(slips size > 0 and: [self confirm: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?'])
		ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]
! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/15/2005 21:27'!
objectForDataStream: refStrm
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	refStrm projectChangeSet == self ifTrue: [^ self].

	"try to write reference for me"
	^ DiskProxy 
		global: #ChangeSet
		selector: #existingOrNewChangeSetNamed: 
		args: (Array with: self name)
"===
	refStrm replace: self with: nil.
	^ nil
==="
! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:03'!
postscript
	"Answer the string representing the postscript.  "
	^postscript ifNotNil:[postscript isString ifTrue:[postscript] ifFalse:[postscript contents asString]]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:03'!
postscriptString
	"Answer the string representing the postscript.  "
	^self postscript! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:03'!
postscriptString: aString
	"Establish aString as the new contents of the postscript.  "
	self postscript: aString! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:03'!
postscript: aString
	"Answer the string representing the postscript.  "
	postscript := aString! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 17:55'!
preamble
	"Answer the string representing the preamble"
	^preamble ifNotNil:[preamble isString ifTrue:[preamble] ifFalse:[preamble contents asString]]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:00'!
preambleString
	"Answer the string representing the preamble"

	^self preamble! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:00'!
preambleString: aString
	"Establish aString as the new contents of the preamble.  "
	self preamble: aString.! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 10:47'!
preambleTemplate
	"Answer a string that will form the default contents for a change set's preamble.
	Just a first stab at what the content should be."

	^ String streamContents: [:strm |
		strm nextPutAll: '"Change Set:'.  "NOTE: fileIn recognizes preambles by this string."
		strm tab;tab; nextPutAll: self name.
		strm cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString.
		strm cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: Preferences defaultAuthorName.
		strm cr; cr; nextPutAll: '<your descriptive text goes here>"']
"ChangeSet current preambleTemplate"! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:00'!
preamble: aString
	"Establish aString as the new contents of the preamble.  "

	preamble _ aString! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 7/16/2005 18:02'!
setPreambleToSay: aString
	"Make aString become the preamble of this change set"
	self preamble: aString! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 9/24/1999 12:33'!
summaryString
	"Answer the string summarizing this changeSet"

	^ self summaryStringDelta: 0
"
To summarize all recent changeSets on a file...
(FileStream newFileNamed: 'Summaries.txt') nextPutAll:
	(String streamContents:
		[:s | (ChangeSorter changeSetsNamedSuchThat:
			[:name | name first isDigit and: [name initialIntegerOrNil >= 948]])
			 do: [:cs | s nextPutAll: cs summaryString; cr]]);
		close

To list all changeSets with a certain string in the preamble...
	(FileStream newFileNamed: 'MyUpdates.txt') nextPutAll:
		(String streamContents:
			[:s | ChangeSorter gatherChangeSetRevertables do:
				[:cs | (cs preambleString notNil
					and: [cs preambleString includesSubString: 'Author Name'])
				 	ifTrue: [s nextPutAll: cs summaryString; cr]]]);
		close
"! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 9/24/1999 12:27'!
summaryStringDelta: delta
	"Answer the string summarizing this changeSet"
	| ps s2 date author line intName |
	^ String streamContents:
		[:s |
		intName _ self name splitInteger.
		intName first isNumber
			ifTrue: [s nextPutAll: (intName first + delta) printString , intName last]
			ifFalse: [s nextPutAll: intName first  "weird convention of splitInteger"].
		(ps _ self preambleString)
			ifNil: [s cr]
			ifNotNil:
			[s2 _ ReadStream on: ps.
			s2 match: 'Date:'; skipSeparators.  date _ s2 upTo: Character cr.
			s2 match: 'Author:'; skipSeparators.  author _ s2 upTo: Character cr.
			s nextPutAll: ' -- '; nextPutAll: author; nextPutAll: ' -- '; nextPutAll: date; cr.
			[s2 atEnd] whileFalse:
				[line _ s2 upTo: Character cr.
				(line isEmpty or: [line = '"']) ifFalse: [s nextPutAll: line; cr]]]].
! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 1/16/2004 21:31'!
verboseFileOut
	"File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'"

	ChangeSet current fileOut.
	Transcript cr; show: 'Changes filed out ', Date dateAndTimeNow printString! !


!ChangeSet methodsFor: 'initialize-release' stamp: 'di 3/29/2000 20:42'!
beIsolationSetFor: aProject

	self isEmpty ifFalse: [self error: 'Must be empty at the start.'].
	isolatedProject _ aProject.
	revertable _ true.! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 4/1/2000 12:00'!
clear 
	"Reset the receiver to be empty.  "

	changeRecords _ Dictionary new.
	preamble _ nil.
	postscript _ nil! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 4/6/2001 09:40'!
initialize 
	"Initialize the receiver to be empty."

	name ifNil:
		[^ self error: 'All changeSets must be registered, as in ChangeSorter newChangeSet'].
	revertable _ false.
	self clear.
! !

!ChangeSet methodsFor: 'initialize-release'!
isMoribund
	"Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter.  2/7/96 sw"

	^ name == nil ! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'sw 3/6/1999 09:31'!
veryDeepCopyWith: deepCopier
	"Return self; this is NOT the way to launch new change sets!! Having this method here allows Change Sorters to be in parts bins"! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 3/23/2000 12:14'!
wither
	"The receiver is to be clobbered.  Clear it out.  2/7/96 sw"

	self clear.
	name _ nil! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 9/21/2000 15:29'!
zapHistory 
	"Much stronger than trimHistory, but it should still leave the changeSet in good shape.
	Must not be done on revertable changeSets
		ChangeSet allInstancesDo: [:cs | cs zapHistory]."

	revertable ifTrue: [^ self].  "No can do"
	changeRecords do: [:chgRecord | chgRecord zapHistory]! !


!ChangeSet methodsFor: 'isolation layers' stamp: 'di 4/1/2000 09:25'!
compileAll: newClass from: oldClass
	"If I have changes for this class, recompile them"

	(changeRecords at: newClass ifAbsent: [^ self])
		compileAll: newClass from: oldClass
! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:47'!
invoke

	"Do the first part of the invoke operation -- no particular hurry."
	changeRecords do: [:changeRecord | changeRecord invokePhase1].

	"Complete the invoke process -- this must be very simple."
	"Replace method dicts for any method changes."
	changeRecords do: [:changeRecord | changeRecord invokePhase2].
	Behavior flushCache.

! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 4/13/2000 12:47'!
isolatedProject
	"Return the isolated project for which I am the changeSet."

	^ isolatedProject! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 13:59'!
isolationSet: setOrNil

	setOrNil == self
		ifTrue: [isolationSet _ nil]  "Means this IS the isolation set"
		ifFalse: [isolationSet _ setOrNil]! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:47'!
revoke

	"Do the first part of the revoke operation -- this must be very simple."
	"Replace original method dicts if there are method changes."
	changeRecords do: [:changeRecord | changeRecord revokePhase1].
	Behavior flushCache.

	"Complete the revoke process -- no particular hurry."
	changeRecords do: [:changeRecord | changeRecord revokePhase2].
! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/23/2000 12:00'!
uninstall

	self halt.
! !


!ChangeSet methodsFor: 'method changes' stamp: 'sw 12/28/2000 18:08'!
adoptSelector: aSelector forClass: aClass
	"Adopt the given selector/class combination as a change in the receiver"

	self noteNewMethod: (aClass methodDictionary at: aSelector)
			forClass: aClass selector: aSelector priorMethod: nil! !

!ChangeSet methodsFor: 'method changes' stamp: 'md 8/27/2005 16:37'!
atSelector: selector class: class put: changeType

	selector isDoIt ifTrue: [^ self].
	(self changeRecorderFor: class) atSelector: selector put: changeType.
! !

!ChangeSet methodsFor: 'method changes' stamp: 'sw 6/26/2001 12:15'!
changedMessageList
	"Used by a message set browser to access the list view information."

	| messageList classNameInFull classNameInParts |
	messageList _ OrderedCollection new.
	changeRecords associationsDo: [:clAssoc |
		classNameInFull _ clAssoc key asString.
		classNameInParts _ classNameInFull findTokens: ' '.

		(clAssoc value allChangeTypes includes: #comment) ifTrue:
			[messageList add:
				(MethodReference new
					setClassSymbol: classNameInParts first asSymbol
					classIsMeta: false 
					methodSymbol: #Comment 
					stringVersion: classNameInFull, ' Comment')].

		clAssoc value methodChangeTypes associationsDo: [:mAssoc |
			(#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
				[messageList add:
					(MethodReference new
						setClassSymbol: classNameInParts first asSymbol
						classIsMeta: classNameInParts size > 1 
						methodSymbol: mAssoc key 
						stringVersion: classNameInFull, ' ' , mAssoc key)]]].
	^ messageList asSortedArray! !

!ChangeSet methodsFor: 'method changes' stamp: 'tk 6/7/1999 18:57'!
changedMessageListAugmented
	"Even added classes have all messages in changedMessageList."
	^ self changedMessageList asArray! !

!ChangeSet methodsFor: 'method changes' stamp: 'sw 4/19/2001 19:45'!
hasAnyChangeForSelector: aSelector
	"Answer whether the receiver has any change under the given selector, whether it be add, change, or remove, for any class"

	changeRecords do:
		[:aRecord | (aRecord changedSelectors  includes: aSelector)
			ifTrue:	[^ true]].
	^ false! !

!ChangeSet methodsFor: 'method changes' stamp: 'RAA 5/28/2001 12:05'!
messageListForChangesWhich: aBlock ifNone: ifEmptyBlock

	| answer |

	answer _ self changedMessageListAugmented select: [ :each |
		aBlock value: each actualClass value: each methodSymbol
	].
	answer isEmpty ifTrue: [^ifEmptyBlock value].
	^answer
! !

!ChangeSet methodsFor: 'method changes' stamp: 'di 4/1/2000 12:00'!
methodChangesAtClass: className
	"Return an old-style dictionary of method change types."

	^(changeRecords at: className ifAbsent: [^ Dictionary new])
		methodChangeTypes! !

!ChangeSet methodsFor: 'method changes' stamp: 'di 4/4/2000 11:14'!
removeSelectorChanges: selector class: class 
	"Remove all memory of changes associated with the argument, selector, in 
	this class."

	| chgRecord |
	(chgRecord _ changeRecords at: class name ifAbsent: [^ self])
		removeSelector: selector.
	chgRecord hasNoChanges ifTrue: [changeRecords removeKey: class name]! !

!ChangeSet methodsFor: 'method changes' stamp: 'SqR 6/13/2000 19:16'!
selectorsInClass: aClassName
	"Used by a ChangeSorter to access the list methods."

	^ (changeRecords at: aClassName ifAbsent: [^#()]) changedSelectors! !


!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 09:37'!
absorbClass: className from: otherChangeSet
	"Absorb into the receiver all the changes found in the class in the other change set.
	*** Classes renamed in otherChangeSet may have problems"

	| cls |
	(self changeRecorderFor: className)
			assimilateAllChangesIn: (otherChangeSet changeRecorderFor: className).

	(cls _ Smalltalk classNamed: className) ifNotNil:
		[self absorbStructureOfClass: cls from: otherChangeSet].
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 3/23/2000 11:52'!
absorbMethod: selector class: aClass from: aChangeSet
	"Absorb into the receiver all the changes for the method in the class in the other change set."

	| info |
	info _ aChangeSet methodChanges at: aClass name ifAbsent: [Dictionary new].
	self atSelector: selector class: aClass put: (info at: selector).

! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 1/30/2001 15:41'!
absorbStructureOfClass: aClass from: otherChangeSet
	"Absorb into the receiver all the structure and superclass info in the other change set.  Used to write conversion methods."

	| sup next |
	otherChangeSet structures ifNil: [^ self].
	(otherChangeSet structures includesKey: aClass name) ifFalse: [^ self].
	structures ifNil:
		[structures _ Dictionary new.
		superclasses _ Dictionary new].
	sup _ aClass name.
	[(structures includesKey: sup) 
		ifTrue: ["use what is here" true]
		ifFalse: [self flag: #noteToDan.  "sw 1/30/2001 13:57 emergency workaround -- a case arose where the otherChangeSet's structures did not have the key, and it gummed up the works."
				(otherChangeSet structures includesKey: sup) ifTrue:
					[structures at: sup put: (otherChangeSet structures at: sup)].
				next _ otherChangeSet superclasses at: sup.
				superclasses at: sup put: next.
				(sup _ next) = 'nil']
	] whileFalse.


! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:21'!
assimilateAllChangesFoundIn: otherChangeSet
	"Make all changes in otherChangeSet take effect on self as if they happened just now."

	otherChangeSet changedClassNames do:
		[:className | self absorbClass: className from: otherChangeSet]
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'ar 7/16/2005 18:59'!
editPreamble
	"edit the receiver's preamble, in a separate window.  "
	self assurePreambleExists.
	UIManager default
		edit: self preamble 
		label: 'Preamble for ChangeSet named ', name
		accept:[:aString| self preamble: aString]! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:49'!
expungeEmptyClassChangeEntries

	changeRecords keysAndValuesRemove:
		[:className :classRecord | classRecord hasNoChanges]! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 4/19/2000 16:17'!
expungeUniclasses

	changeRecords keysAndValuesRemove:
		[:className :classRecord | className endsWithDigit]! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:40'!
forgetAllChangesFoundIn: otherChangeSet
	"Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets.  To use:  in a change sorter, copy over all the changes you want into some new change set, then use the subtract-other-side feature to subtract those changes from the larger change set, and continue in this manner."

	otherChangeSet == self ifTrue: [^ self].
	otherChangeSet changedClassNames do:
		[:className | self forgetChangesForClass: className in: otherChangeSet].
	self expungeEmptyClassChangeEntries.

"  Old code...
	aChangeSet changedClassNames do: 
		[:className |
			(cls _ Smalltalk classNamed: className) ~~ nil ifTrue:
				[itsMethodChanges _ aChangeSet methodChanges at: className 
						ifAbsent: [Dictionary new].
				itsMethodChanges associationsDo: [:assoc | 
					self forgetChange: assoc value forSelector: assoc key class: cls].
				myClassChange _ self classChangeAt: className.
				myClassChange size > 0 ifTrue:
					[(aChangeSet classChangeAt: className) do:
						[:aChange | myClassChange remove: aChange ifAbsent: []]].
				self noteClassForgotten: className]].

	aChangeSet classRemoves do:
		[:className | (recorder _ changeRecords at: className ifAbsent: [])
			ifNotNil: [recorder forgetClassRemoval]].
	self expungeEmptyClassChangeEntries
"
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:04'!
forgetChangesForClass: className in: otherChangeSet
	"See forgetAllChangesFoundIn:.  Used in culling changeSets."

	(self changeRecorderFor: className)
			forgetChangesIn: (otherChangeSet changeRecorderFor: className).
	self noteClassForgotten: className
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:27'!
hasPreamble
	^ preamble notNil! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nk 3/30/2002 09:13'!
methodsWithAnyInitialsOtherThan: myInits
	"Return a collection of method refs whose author appears to be different from the given one, even historically"
	| slips method aTimeStamp |
	slips _ Set new.
	self changedClasses do: [:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc |
			(#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
				[method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
				method ifNotNil: [
					(aClass changeRecordsAt: mAssoc key) do: [ :chg |
						aTimeStamp _ chg stamp.
						(aTimeStamp notNil and: [(aTimeStamp beginsWith: myInits) not])
							ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]].
	^ slips! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47'!
methodsWithInitialsOtherThan: myInits
	"Return a collection of method refs whose author appears to be different from the given one"
	| slips method aTimeStamp |
	slips _ OrderedCollection new.
	self changedClasses do:
		[:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: 
				[:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
					[method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
					method ifNotNil:
						[((aTimeStamp _ Utilities timeStampForMethod: method) notNil and:
							[(aTimeStamp beginsWith: myInits) not])
								ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips

	"Smalltalk browseMessageList: (ChangeSet current methodsWithInitialsOtherThan: 'sw') name: 'authoring problems'"! !

!ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47'!
methodsWithoutComments
	"Return a collection representing methods in the receiver which have no precode comments"

	| slips |
	slips _ OrderedCollection new.
	self changedClasses do:
		[:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: 
				[:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
					[(aClass selectors includes:  mAssoc key) ifTrue:
						[(aClass firstPrecodeCommentFor: mAssoc key) isEmptyOrNil
								ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips

	"Smalltalk browseMessageList: (ChangeSet current methodsWithoutComments) name: 'methods lacking comments'"! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/1/2000 12:00'!
removeClassAndMetaClassChanges: class
	"Remove all memory of changes associated with this class and its metaclass.  7/18/96 sw"

	changeRecords removeKey: class name ifAbsent: [].
	changeRecords removeKey: class class name ifAbsent: [].
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'yo 8/30/2002 13:59'!
removeClassChanges: class
	"Remove all memory of changes associated with this class"
	| cname |
	(class isString)
		ifTrue: [ cname _ class ]
		ifFalse: [ cname _ class name ].

	changeRecords removeKey: cname ifAbsent: [].
	self noteClassForgotten: cname.! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:32'!
removePreamble
	preamble _ nil! !


!ChangeSet methodsFor: 'testing' stamp: 'RAA 10/1/2000 12:28'!
belongsToAProject

	Smalltalk at: #Project ifPresent:
		[:projClass | projClass allProjects do:
			[:proj | proj projectChangeSet == self ifTrue: [^ true]]].
	^ false! !

!ChangeSet methodsFor: 'testing' stamp: 'sw 8/10/2002 22:21'!
containsMethodAtPosition: aFilePosition
	"Answer whether the receiver contains the method logged at the given file position"

	"class: aClassSymbol" "(need class parameter to speed up?)"  "<- dew 9/6/2001"

	changeRecords values do:
		[:classChangeRecord |
		classChangeRecord methodChanges values do:
			[:methodChangeRecord | | changeType |
			changeType _ methodChangeRecord changeType.
			((changeType == #add or: [changeType == #change]) and:
				[methodChangeRecord currentMethod notNil and: [methodChangeRecord currentMethod filePosition = aFilePosition]])
					ifTrue: [^ true]]].
	^ false! !

!ChangeSet methodsFor: 'testing' stamp: 'RAA 11/13/2000 17:15'!
correspondingProject
	"If the receiver is the current change set for any project, answer it, else answer nil"

	^Project allProjects 
		detect: [ :proj |
			proj projectChangeSet == self
		]
		ifNone: [nil]

! !

!ChangeSet methodsFor: 'testing' stamp: 'RAA 10/19/2000 13:17'!
isEmpty
	"Answer whether the receiver contains any elements."
	
	changeRecords ifNil: [^true].
	^ changeRecords isEmpty ! !

!ChangeSet methodsFor: 'testing' stamp: 'nk 7/2/2003 10:47'!
methodsWithoutClassifications
	"Return a collection representing methods in the receiver which have not been categorized"

	| slips notClassified aSelector |

	notClassified _ {'as yet unclassified' asSymbol. #all}.
	slips _ OrderedCollection new.
	self changedClasses do:
		[:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: 
				[:mAssoc | (aClass selectors includes:  (aSelector _ mAssoc key)) ifTrue:
						[(notClassified includes: (aClass organization categoryOfElement: aSelector))
								ifTrue: [slips add: aClass name , ' ' , aSelector]]]].
	^ slips

	"Smalltalk browseMessageList: (ChangeSet current methodsWithoutClassifications) name: 'unclassified methods'"! !

!ChangeSet methodsFor: 'testing' stamp: 'sw 8/3/1998 16:25'!
okayToRemove
	^ self okayToRemoveInforming: true! !

!ChangeSet methodsFor: 'testing' stamp: 'sd 5/23/2003 14:24'!
okayToRemoveInforming: aBoolean
	"Answer whether it is okay to remove the receiver.  If aBoolean is true, inform the receiver if it is not okay"

	| aName |
	aName _ self name.
	self == self class current ifTrue:
		[aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '"
because it is the 
current change set.'].
		^ false].

	self belongsToAProject ifTrue:
		[aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" 
because it belongs to a 
project.'].
			^ false].

	^ true
! !

!ChangeSet methodsFor: 'testing' stamp: 'RAA 9/27/2000 22:40'!
projectsBelongedTo
	"Answer a list of all the projects for which the receiver is the current change set"

	^ Project allProjects select: [:proj | proj projectChangeSet == self]
! !



!ChangeSet methodsFor: 'private' stamp: 'di 3/23/2000 08:37'!
addCoherency: className
	"SqR!! 19980923: If I recreate the class then don't remove it"

	(self changeRecorderFor: className)
		checkCoherence.
"
	classRemoves remove: className ifAbsent: [].
	(classChanges includesKey: className) ifTrue:
		[(classChanges at: className) remove: #remove ifAbsent: []]
"! !

!ChangeSet methodsFor: 'private' stamp: 'di 3/28/2000 14:40'!
atClass: class add: changeType

	(self changeRecorderFor: class)
		noteChangeType: changeType fromClass: class! !

!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'!
atClass: class includes: changeType

	^(changeRecords at: class name ifAbsent: [^false])
		includesChangeType: changeType! !

!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'!
atSelector: selector class: class

	^ (changeRecords at: class name ifAbsent: [^ #none])
		atSelector: selector ifAbsent: [^ #none]! !

!ChangeSet methodsFor: 'private'!
changed: anAspectSymbol with: aParameter 
	"Allow objects to depend on the ChangeSet class instead of a particular instance 
	of ChangeSet (which may be switched using projects)."

	ChangeSet changed: anAspectSymbol with: aParameter.
	super changed: anAspectSymbol with: aParameter! !

!ChangeSet methodsFor: 'private' stamp: 'yo 8/30/2002 13:59'!
changeRecorderFor: class

	| cname |
	(class isString)
		ifTrue: [ cname _ class ]
		ifFalse: [ cname _ class name ].

	"Later this will init the changeRecords so according to whether they should be revertable."
	^ changeRecords at: cname
			ifAbsent: [^ changeRecords at: cname
							put: (ClassChangeRecord new initFor: cname revertable: revertable)]! !

!ChangeSet methodsFor: 'private' stamp: 'tk 3/7/2001 14:06'!
fileOutClassDefinition: class on: stream 
	"Write out class definition for the given class on the given stream, if the class definition was added or changed."

	(self atClass: class includes: #rename) ifTrue:
		[stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr].

	(self atClass: class includes: #change) ifTrue: [ "fat definition only needed for changes"
		stream command: 'H3'; nextChunkPut: (self fatDefForClass: class); cr; command: '/H3'.
		DeepCopier new checkClass: class.	"If veryDeepCopy weakly copies some inst 
			vars in this class, warn author when new ones are added." 
	] ifFalse: [
		(self atClass: class includes: #add) ifTrue: [ "use current definition for add"
			stream command: 'H3'; nextChunkPut: class definition; cr; command: '/H3'.
			DeepCopier new checkClass: class.	"If veryDeepCopy weakly copies some inst 
				vars in this class, warn author when new ones are added." 
		].
	].

	(self atClass: class includes: #comment) ifTrue:
		[class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass.
		stream cr].

! !

!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'!
oldNameFor: class

	^ (changeRecords at: class name) priorName! !

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

ChangeSet class
	instanceVariableNames: 'current'!

!ChangeSet class methodsFor: 'class initialization' stamp: 'ar 7/15/2005 21:12'!
initialize
	"ChangeSet initialize"
	AllChangeSets == nil ifTrue:
		[AllChangeSets _ OrderedCollection new].
	self gatherChangeSets.
	FileServices registerFileReader: self.
! !


!ChangeSet class methodsFor: 'current changeset' stamp: 'ar 7/17/2005 10:48'!
browseChangedMessages
	"Create and schedule a message browser on each method that has been 
	changed."

	current isEmpty ifTrue: [^ self inform: 'There are no changed messages
in the current change set.'].
	ToolSet openChangedMessageSet: current.! !

!ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 21:53'!
current
	"return the current changeset"

	^ current! !

!ChangeSet class methodsFor: 'current changeset' stamp: 'em 3/31/2005 11:48'!
currentChangeSetString
	"ChangeSet current currentChangeSetString"

	^ 'Current Change Set: ' translated, self current name! !

!ChangeSet class methodsFor: 'current changeset' stamp: 'NS 1/16/2004 14:49'!
newChanges: aChangeSet 
	"Set the system ChangeSet to be the argument, aChangeSet.  Tell the current project that aChangeSet is now its change set.  When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current-change-set from within a project, it's vital"

	SystemChangeNotifier uniqueInstance noMoreNotificationsFor: current.
	current isolationSet: nil.
	current _ aChangeSet.
	SystemChangeNotifier uniqueInstance notify: aChangeSet ofAllSystemChangesUsing: #event:.
	Smalltalk currentProjectDo:
		[:proj |
		proj setChangeSet: aChangeSet.
		aChangeSet isolationSet: proj isolationSet]! !

!ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:18'!
noChanges 
	"Initialize the system ChangeSet."

	current initialize! !


!ChangeSet class methodsFor: 'defaults' stamp: 'nk 7/18/2004 16:13'!
defaultChangeSetDirectory
	"Answer the directory in which to store ChangeSets. 
	Answer the default directory if the preferred directory doesn't exist."
	| dir directoryName |
	directoryName := Preferences
				parameterAt: #defaultChangeSetDirectoryName
				ifAbsentPut: [''].
	dir := directoryName isEmptyOrNil
		ifTrue: [ FileDirectory default ]
		ifFalse: [ FileDirectory default directoryNamed: directoryName ].
	dir exists
		ifTrue: [^ dir].
	^ FileDirectory default! !

!ChangeSet class methodsFor: 'defaults' stamp: 'nk 3/24/2004 15:52'!
defaultChangeSetDirectory: dirOrName 
	"Set the Preference for storing change sets to the given directory or name (possibly relative).
	Rewrite directory names below the default directory as relative names.
	If dirOrName is an empty string, use the default directory."

	"ChangeSet defaultChangeSetDirectory: 'changeSets'"

	| dirName defaultFullName |
	dirName := dirOrName isString
				ifTrue: [FileDirectory default fullNameFor: dirOrName]
				ifFalse: [dirOrName fullName].
	defaultFullName := FileDirectory default fullName.
	dirName = defaultFullName
		ifTrue: [dirName := '']
		ifFalse: [(dirName beginsWith: defaultFullName , FileDirectory slash)
				ifTrue: [dirName := dirName copyFrom: defaultFullName size + 2 to: dirName size]].
	Preferences setParameter: #defaultChangeSetDirectoryName to: dirName! !

!ChangeSet class methodsFor: 'defaults' stamp: 'dgd 9/6/2003 19:56'!
defaultName
	^ self uniqueNameLike: 'Unnamed' translated! !

!ChangeSet class methodsFor: 'defaults' stamp: 'ar 7/16/2005 19:35'!
promptForDefaultChangeSetDirectoryIfNecessary
	"Check the Preference (if any), and prompt the user to change it if necessary.
	The default if the Preference is unset is the current directory.
	Answer the directory."

	"ChangeSet promptForDefaultChangeSetDirectoryIfNecessary"
	| choice directoryName dir |
	directoryName := Preferences
				parameterAt: #defaultChangeSetDirectoryName
				ifAbsentPut: [''].
	[dir := FileDirectory default directoryNamed: directoryName.
	dir exists]
		whileFalse: [choice := PopUpMenu withCaption: 
			('The preferred change set directory (''{1}'') does not exist.
Create it or use the default directory ({2})?' translated format: { directoryName. FileDirectory default pathName })
	chooseFrom: (#('Create directory' 'Use default directory and forget preference' 'Choose another directory' ) collect: [ :ea | ea translated ]).
			choice = 1
				ifTrue: [dir assureExistence ].
			choice = 3
				ifTrue: [dir := UIManager default chooseDirectory.
					directoryName := dir
					ifNil: [ '' ]
						ifNotNil: [dir pathName ]]].
		self defaultChangeSetDirectory: directoryName.
		^dir! !

!ChangeSet class methodsFor: 'defaults' stamp: 'ar 7/15/2005 21:24'!
uniqueNameLike: aString

	| try |
	(self named: aString) ifNil: [^ aString].

	1 to: 999999 do:
		[:i | try _ aString , i printString.
		(self named: try) ifNil: [^ try]]! !


!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:20'!
allChangeSetNames
	^ self allChangeSets collect: [:c | c name]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:10'!
allChangeSets
	"Return the list of all current ChangeSets"

	^ AllChangeSets! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:22'!
allChangeSetsWithClass: class selector: selector
	class ifNil: [^ #()].
	^ self allChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:17'!
allChangeSets: aCollection
	"Return the list of all current ChangeSets"

	AllChangeSets := aCollection.! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:14'!
basicNewChangeSet: newName
	| newSet |
	newName ifNil: [^ nil].
	(self named: newName) ifNotNil:
		[self inform: 'Sorry that name is already used'.
		^ nil].
	newSet _ self basicNewNamed: newName.
	AllChangeSets add: newSet.
	^ newSet! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:11'!
changeSetsNamedSuchThat: nameBlock
	"(ChangeSet changeSetsNamedSuchThat:
		[:name | name first isDigit and: [name initialInteger >= 373]])
		do: [:cs | AllChangeSets remove: cs wither]"

	^ AllChangeSets select: [:aChangeSet | nameBlock value: aChangeSet name]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'!
changeSet: aChangeSet containsClass: aClass
	| theClass |
	theClass _ Smalltalk classNamed: aClass.
	theClass ifNil: [^ false].
	^ aChangeSet containsClass: theClass! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'!
deleteChangeSetsNumberedLowerThan: anInteger
	"Delete all changes sets whose names start with integers smaller than anInteger"

	self removeChangeSetsNamedSuchThat:
		[:aName | aName first isDigit and: [aName initialIntegerOrNil < anInteger]].

	"ChangeSet deleteChangeSetsNumberedLowerThan: (ChangeSorterPlus highestNumberedChangeSet name initialIntegerOrNil - 500)"
! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:24'!
existingOrNewChangeSetNamed: aName

	| newSet |
	^(self named: aName) ifNil: [
		newSet _ self basicNewNamed: aName.
		AllChangeSets add: newSet.
		newSet
	]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:12'!
gatherChangeSets		"ChangeSet gatherChangeSets"
	"Collect any change sets created in other projects"
	| allChangeSets obsolete |
	allChangeSets _ AllChangeSets asSet.
	ChangeSet allSubInstances do: [:each |
		(allChangeSets includes: each) == (obsolete _ each isMoribund) ifTrue:[
			obsolete
				ifTrue: ["Was included and is obsolete."
						AllChangeSets remove: each]
				ifFalse: ["Was not included and is not obsolete."
						AllChangeSets add: each]]].
	^ AllChangeSets! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:20'!
highestNumberedChangeSet
	"ChangeSorter highestNumberedChangeSet"
	| aList |
	aList _ (self allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect:
		[:aString | aString initialIntegerOrNil]).
	^ (aList size > 0)
		ifTrue:
			[aList max]
		ifFalse:
			[nil]
! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:29'!
mostRecentChangeSetWithChangeForClass: class selector: selector
	| hits |
	hits _ self allChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none].
	hits isEmpty ifTrue: [^ 'not in any change set'].
	^ 'recent cs: ', hits last name! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:11'!
named: aName
	"Return the change set of the given name, or nil if none found.  1/22/96 sw"

	^ AllChangeSets
			detect: [:aChangeSet | aChangeSet name = aName]
			ifNone: [nil]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'!
promoteToTop: aChangeSet
	"Make aChangeSet the first in the list from now on"

	AllChangeSets remove: aChangeSet ifAbsent: [^ self].
	AllChangeSets add: aChangeSet! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'!
removeChangeSetsNamedSuchThat: nameBlock
	(self changeSetsNamedSuchThat: nameBlock)
		do: [:cs | self removeChangeSet: cs]! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'!
removeChangeSet: aChangeSet
	"Remove the given changeSet.  Caller must assure that it's cool to do this"

	AllChangeSets remove: aChangeSet ifAbsent: [].
	aChangeSet wither
! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'!
removeEmptyUnnamedChangeSets
	"Remove all change sets that are empty, whose names start with Unnamed,
		and which are not nailed down by belonging to a Project."
	"ChangeSorter removeEmptyUnnamedChangeSets"
	| toGo |
	(toGo _ (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed'])
		select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]])
		do: [:cs | self removeChangeSet: cs].
	self inform: toGo size printString, ' change set(s) removed.'! !

!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'!
secondaryChangeSet
	"Answer a likely change set to use as the second initial one in a Dual Change Sorter.  "

	AllChangeSets size = 1 ifTrue: [^ AllChangeSets first].
	AllChangeSets last == ChangeSet current
		ifTrue: 	[^ AllChangeSets at: (AllChangeSets size - 1)]
		ifFalse:	[^ AllChangeSets last]! !


!ChangeSet class methodsFor: 'file list services' stamp: 'ar 7/15/2005 21:36'!
fileReaderServicesForFile: fullName suffix: suffix

	^ (FileStream isSourceFileSuffix: suffix)
		ifTrue: [ self services]
		ifFalse: [#()]! !

!ChangeSet class methodsFor: 'file list services' stamp: 'ar 7/15/2005 21:35'!
serviceFileIntoNewChangeSet
	"Answer a service for installing a file into a new change set"

	^ SimpleServiceEntry 
		provider: self 
		label: 'install into new change set'
		selector: #fileIntoNewChangeSet:
		description: 'install the file as a body of code in the image: create a new change set and file-in the selected file into it'
		buttonLabel: 'install'! !

!ChangeSet class methodsFor: 'file list services' stamp: 'ar 7/15/2005 21:36'!
services
	^ Array with: self serviceFileIntoNewChangeSet! !


!ChangeSet class methodsFor: 'fileIn/Out' stamp: 'SqR 11/14/2000 11:36'!
doWeFileOut: aClass given: aSet cache: cache
	| aClassAllSuperclasses aClassSoleInstanceAllSuperclasses |

	aClassAllSuperclasses _ cache at: aClass
		ifAbsent: [cache at: aClass put: aClass allSuperclasses asArray].
	(aSet includesAnyOf: aClassAllSuperclasses) ifTrue: [^false].
	aClass isMeta ifFalse: [^true].
	(aSet includes: aClass soleInstance) ifTrue: [^false].
	aClassSoleInstanceAllSuperclasses _ cache at: aClass soleInstance
		ifAbsent: [cache at: aClass soleInstance put: aClass soleInstance allSuperclasses asArray].
	(aSet includesAnyOf: aClassSoleInstanceAllSuperclasses) ifTrue: [^false].
	^true! !

!ChangeSet class methodsFor: 'fileIn/Out' stamp: 'SqR 11/14/2000 11:37'!
superclassOrder: classes
	"Arrange the classes in the collection, classes, in superclass order so the 
	classes can be properly filed in. Do it in sets instead of ordered collections.
	SqR 4/12/2000 22:04"

	| all list aClass inclusionSet aClassIndex cache |

	list _ classes copy. "list is indexable"
	inclusionSet _ list asSet. cache _ Dictionary new.
	all _ OrderedCollection new: list size.
	list size timesRepeat:
		[
			aClassIndex _ list findFirst: [:one | one isNil not and: 
				[self doWeFileOut: one given: inclusionSet cache: cache]].
			aClass _ list at: aClassIndex.
			all addLast: aClass.
			inclusionSet remove: aClass.
			list at: aClassIndex put: nil
		].
	^all! !

!ChangeSet class methodsFor: 'fileIn/Out' stamp: 'al 7/18/2004 18:45'!
traitsOrder: aCollection 
	"Answer an OrderedCollection. The traits 
	are ordered so they can be filed in."

	|  traits |
	traits _ aCollection asSortedCollection: [:t1 :t2 |
		(t1 isBaseTrait and: [t1 classTrait == t2]) or: [
			(t2 traitComposition allTraits includes: t1) or: [
				(t1 traitComposition allTraits includes: t2) not]]].
	^traits asArray! !


!ChangeSet class methodsFor: 'instance creation' stamp: 'di 4/6/2001 09:43'!
basicNewNamed: aName

	^ (self basicNew name: aName) initialize! !

!ChangeSet class methodsFor: 'instance creation' stamp: 'ar 7/16/2005 15:17'!
new
	"All current changeSets must be registered in the AllChangeSets collection.
	Due to a quirk of history, this is maintained as class variable of ChangeSorter."

	^ self basicNewChangeSet: ChangeSet defaultName! !


!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 19:22'!
getRecentLocatorWithPrompt: aPrompt
	"Prompt with a menu of how far back to go.  Return nil if user backs out.  Otherwise return the number of characters back from the end of the .changes file the user wishes to include"
	 "ChangeList getRecentPosition"
	| end changesFile banners positions pos chunk i |
	changesFile _ (SourceFiles at: 2) readOnlyCopy.
	banners _ OrderedCollection new.
	positions _ OrderedCollection new.
	end _ changesFile size.
	pos _ SmalltalkImage current lastQuitLogPosition.
	[pos = 0 or: [banners size > 20]] whileFalse:
		[changesFile position: pos.
		chunk _ changesFile nextChunk.
		i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
		i > 0 ifTrue: [positions addLast: pos.
					banners addLast: (chunk copyFrom: 5 to: i-2).
					pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)]
			ifFalse: [pos _ 0]].
	changesFile close.
	pos _ UIManager default chooseFrom: banners values: positions title: aPrompt.
	pos == nil ifTrue: [^ nil].
	^ end - pos! !

!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 15:12'!
scanCategory: file
	"Scan anything that involves more than one chunk; method name is historical only"
	| itemPosition item tokens stamp isComment anIndex |
	itemPosition _ file position.
	item _ file nextChunk.

	isComment _ (item includesSubString: 'commentStamp:').
	(isComment or: [item includesSubString: 'methodsFor:']) ifFalse:
		["Maybe a preamble, but not one we recognize; bail out with the preamble trick"
		^{(ChangeRecord new file: file position: itemPosition type: #preamble)}].

	tokens _ Scanner new scanTokens: item.
	tokens size >= 3 ifTrue:
		[stamp _ ''.
		anIndex _ tokens indexOf: #stamp: ifAbsent: [nil].
		anIndex ifNotNil: [stamp _ tokens at: (anIndex + 1)].

		tokens second == #methodsFor:
			ifTrue: [^ self scanFile: file category: tokens third class: tokens first
							meta: false stamp: stamp].
		tokens third == #methodsFor:
			ifTrue: [^ self scanFile: file category: tokens fourth class: tokens first
							meta: true stamp: stamp]].

		tokens second == #commentStamp:
			ifTrue:
				[stamp _ tokens third.
				item := (ChangeRecord new file: file position: file position type: #classComment
										class: tokens first category: nil meta: false stamp: stamp).
				file nextChunk.
				file skipStyleChunk.
				^Array with: item].
	^#()! !

!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 15:11'!
scanFile: file category: cat class: class meta: meta stamp: stamp
	| itemPosition method items |
	items := OrderedCollection new.
	[itemPosition _ file position.
	method _ file nextChunk.
	file skipStyleChunk.
	method size > 0] whileTrue:[
		items add: (ChangeRecord new file: file position: itemPosition type: #method
							class: class category: cat meta: meta stamp: stamp)].
	^items! !

!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 15:14'!
scanFile: file from: startPosition to: stopPosition
	| itemPosition item prevChar changeList |
	changeList _ OrderedCollection new.
	file position: startPosition.
'Scanning ', file localName, '...'
	displayProgressAt: Sensor cursorPoint
	from: startPosition to: stopPosition
	during: [:bar |
	[file position < stopPosition] whileTrue:[
		bar value: file position.
		[file atEnd not and: [file peek isSeparator]]
			whileTrue: [prevChar _ file next].
		(file peekFor: $!!) ifTrue:[
			(prevChar = Character cr or: [prevChar = Character lf])
				ifTrue: [changeList addAll: (self scanCategory: file)].
		] ifFalse:[
			itemPosition _ file position.
			item _ file nextChunk.
			file skipStyleChunk.
			item size > 0 ifTrue:[
				changeList add: (ChangeRecord new file: file position: itemPosition type: #doIt).
			].
		].
	]].
	^changeList! !

!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 20:19'!
scanVersionsOf: method class: class meta: meta category: cat selector: selector
	| position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp changeList file |
	changeList _ OrderedCollection new.
	position _ method filePosition.
	sourceFilesCopy _ SourceFiles collect:[:x | x ifNotNil:[x readOnlyCopy]].
	method fileIndex == 0 ifTrue: [^ nil].
	file _ sourceFilesCopy at: method fileIndex.
	[position notNil & file notNil] whileTrue:[
		file position: (0 max: position-150).  "Skip back to before the preamble"
		preamble _ method getPreambleFrom: file at: (0 max: position - 3).
		"Preamble is likely a linked method preamble, if we're in
			a changes file (not the sources file).  Try to parse it
			for prior source position and file index"
		prevPos _ nil.
		stamp _ ''.
		(preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [tokens _ Scanner new scanTokens: preamble]
			ifFalse: [tokens _ Array new  "ie cant be back ref"].
		((tokens size between: 7 and: 8)
			and: [(tokens at: tokens size-5) = #methodsFor:]) ifTrue:[
				(tokens at: tokens size-3) = #stamp: ifTrue:[
					"New format gives change stamp and unified prior pointer"
					stamp _ tokens at: tokens size-2.
					prevPos _ tokens last.
					prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos.
					prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos.
				] ifFalse: ["Old format gives no stamp; prior pointer in two parts"
					prevPos _ tokens at: tokens size-2.
					prevFileIndex _ tokens last.
				].
				(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]
			].
		((tokens size between: 5 and: 6)
			and: [(tokens at: tokens size-3) = #methodsFor:]) ifTrue:[
				(tokens at: tokens size-1) = #stamp: ifTrue: [
					"New format gives change stamp and unified prior pointer"
					stamp _ tokens at: tokens size.
			]
		].
 		changeList add: (ChangeRecord new file: file position: position type: #method
						class: class name category: cat meta: meta stamp: stamp).
		position _ prevPos.
		prevPos notNil ifTrue:[file _ sourceFilesCopy at: prevFileIndex].
	].
	sourceFilesCopy do: [:x | x ifNotNil:[x close]].
	^changeList! !


!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:30'!
assuredChangeSetNamed: aName
	"Answer a change set of the given name.  If one already exists, answer that, else create a new one and answer it."

	| existing |
	^ (existing _ self named: aName)
		ifNotNil:
			[existing]
		ifNil:
			[self basicNewChangeSet: aName]! !

!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:28'!
buildAggregateChangeSet
	"Establish a change-set named Aggregate which bears the union of all the changes in all the existing change-sets in the system (other than any pre-existing Aggregate).  This can be useful when wishing to discover potential conflicts between a disk-resident change-set and an image.  Formerly very useful, now some of its unique contributions have been overtaken by new features"

	| aggregateChangeSet |
	aggregateChangeSet _ self existingOrNewChangeSetNamed: 'Aggregate'.
	aggregateChangeSet clear.
	self allChangeSets do:
		[:aChangeSet | aChangeSet == aggregateChangeSet ifFalse:
			[aggregateChangeSet assimilateAllChangesFoundIn: aChangeSet]]

"ChangeSet buildAggregateChangeSet"

	! !

!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:37'!
countOfChangeSetsWithClass: aClass andSelector: aSelector
	"Answer how many change sets record a change for the given class and selector"

	^ (self allChangeSetsWithClass: aClass selector: aSelector) size! !

!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:38'!
doesAnyChangeSetHaveClass: aClass andSelector: aSelector
	"Answer whether any known change set bears a change for the given class and selector"

	^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0! !

!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:35'!
fileIntoNewChangeSet: fullName
	"File in all of the contents of the currently selected file, if any, into a new change set." 

	| fn ff |
	fullName ifNil: [^ Beeper beep].
	ff _ FileStream readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName).
	ChangeSet newChangesFromStream: ff named: (FileDirectory localNameFor: fn)! !

!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:37'!
fileOutChangeSetsNamed: nameList
	"File out the list of change sets whose names are provided"
     "ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')"

	| notFound aChangeSet infoString empty |
	notFound _ OrderedCollection new.
	empty _ OrderedCollection new.
	nameList do:
		[:aName | (aChangeSet _ self named: aName)
			ifNotNil:
				[aChangeSet isEmpty
					ifTrue:
						[empty add: aName]
					ifFalse:
						[aChangeSet fileOut]]
			ifNil:
				[notFound add: aName]].

	infoString _ (nameList size - notFound size) printString, ' change set(s) filed out'.
	notFound size > 0 ifTrue:
		[infoString _ infoString, '

', notFound size printString, ' change set(s) not found:'.
		notFound do:
			[:aName | infoString _ infoString, '
', aName]].
	empty size > 0 ifTrue:
		[infoString _ infoString, '
', empty size printString, ' change set(s) were empty:'.
		empty do:
			[:aName | infoString _ infoString, '
', aName]].

	self inform: infoString! !

!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:31'!
newChangeSet
	"Prompt the user for a name, and establish a new change set of
	that name (if ok), making it the current changeset.  Return nil
	of not ok, else return the actual changeset."

	| newName newSet |
	newName _ UIManager default
		request: 'Please name the new change set:'
		initialAnswer: ChangeSet defaultName.
	newName isEmptyOrNil ifTrue:
		[^ nil].
	newSet _ self basicNewChangeSet: newName.
	newSet ifNotNil:
		[self  newChanges: newSet].
	^ newSet! !

!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:31'!
newChangeSet: aName
	"Makes a new change set called aName, add author initials to try to
	ensure a unique change set name."

	| newName |
	newName _ aName , FileDirectory dot , Utilities authorInitials.
	^ self basicNewChangeSet: newName! !

!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:33'!
newChangesFromStream: aStream named: aName
	"File in the code from the stream into a new change set whose
	name is derived from aName. Leave the 'current change set'
	unchanged. Return the new change set or nil on failure."

	| oldChanges newName newSet newStream |
	oldChanges _ ChangeSet current.
	PreviousSet _ oldChanges name. 		"so a Bumper update can find it"
	newName _ aName sansPeriodSuffix.
	newSet _ self basicNewChangeSet: newName.
	[newSet ifNotNil:[
		(aStream respondsTo: #converter:) ifFalse: [
			newStream _ MultiByteBinaryOrTextStream with: (aStream contentsOfEntireFile).
			newStream reset.
		] ifTrue: [
			newStream _ aStream.
		].

		self newChanges: newSet.
		newStream setConverterForCode.
		newStream fileInAnnouncing: 'Loading ', newName, '...'.
		Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName].
	aStream close] ensure: [self newChanges: oldChanges].
	PreviousSet := nil.
	^ newSet! !

ChangeSorter subclass: #ChangeSetBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeSetBrowser commentStamp: '<historical>' prior: 0!
A tool allowing you to browse the methods of a single change set.!


!ChangeSetBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
addModelItemsToWindowMenu: aMenu
	"Add model-related items to the given window menu"

	| oldTarget |
	oldTarget := aMenu defaultTarget.
	aMenu defaultTarget: self.
	aMenu addLine.
	aMenu add: 'rename change set' action: #rename.
	aMenu add: 'make changes go to me' action: #newCurrent.
	aMenu addLine.
	aMenu add: 'file out' action: #fileOut.
	aMenu add: 'browse methods' action: #browseChangeSet.
	aMenu addLine.
	myChangeSet hasPreamble
		ifTrue:
			[aMenu add: 'edit preamble' action: #addPreamble.
			aMenu add: 'remove preamble' action: #removePreamble]
		ifFalse:
			[aMenu add: 'add preamble' action: #addPreamble].

	myChangeSet hasPostscript
		ifTrue:
			[aMenu add: 'edit postscript...' action: #editPostscript.
			aMenu add: 'remove postscript' action: #removePostscript]
		ifFalse:
			[aMenu add: 'add postscript...' action: #editPostscript].
	aMenu addLine.
	
	aMenu add: 'destroy change set' action: #remove.
	aMenu addLine.
	Smalltalk isMorphic ifTrue:
		[aMenu addLine.
		aMenu add: 'what to show...' target: self action: #offerWhatToShowMenu].
	aMenu addLine.
	aMenu add: 'more...' action: #offerShiftedChangeSetMenu.
	aMenu defaultTarget: oldTarget.

	^ aMenu! !

!ChangeSetBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
openAsMorphIn: window rect: rect
	"Add a set of changeSetBrowser views to the given top view offset by the given amount"

	| aHeight |
	contents := ''.
	aHeight := 0.25.
	self addDependent: window.		"so it will get changed: #relabel"


	window addMorph: (PluggableListMorphByItem on: self
				list: #classList
				selected: #currentClassName
				changeSelected: #currentClassName:
				menu: #classListMenu:shifted:
				keystroke: #classListKey:from:)
		frame: (((0.0@0 extent: 0.5 @ aHeight)
			scaleBy: rect extent) translateBy: rect origin).

	window addMorph: (PluggableListMorphByItem on: self
				list: #messageList
				selected: #currentSelector
				changeSelected: #currentSelector:
				menu: #messageMenu:shifted:
				keystroke: #messageListKey:from:)
		frame: (((0.5@0 extent: 0.5 @ aHeight)
			scaleBy: rect extent) translateBy: rect origin).

	 self addLowerPanesTo: window
		at: (((0@aHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin)
		with: nil! !

!ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/14/2001 10:03'!
wantsAnnotationPane
	"This kind of browser always wants annotation panes, so answer true"

	^ true! !

!ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/9/2001 15:02'!
wantsOptionalButtons
	"Sure, why not?"

	^ true! !


!ChangeSetBrowser methodsFor: 'menu' stamp: 'sw 3/12/2001 14:07'!
offerUnshiftedChangeSetMenu
	"The user chose 'more' from the shifted window menu; go back to the regular window menu"

	self containingWindow ifNotNil: [self containingWindow offerWindowMenu] ! !

!ChangeSetBrowser methodsFor: 'menu' stamp: 'sw 7/20/2002 18:33'!
shiftedChangeSetMenu: aMenu
	"Set up aMenu to hold items relating to the change-set-list pane when the shift key is down"

	Smalltalk isMorphic ifTrue:
		[aMenu title: 'Change set (shifted)'.
		aMenu addStayUpItemSpecial].
	aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts.
	aMenu balloonTextForLastItem: 
'Browse all methods that occur both in this change set and in at least one other change set.'.

	aMenu addLine.
	aMenu add: 'check for slips' action: #lookForSlips.
	aMenu balloonTextForLastItem: 
'Check this change set for halts and references to Transcript.'.

	aMenu add: 'check for unsent messages' action: #checkForUnsentMessages.
	aMenu balloonTextForLastItem:
'Check this change set for messages that are not sent anywhere in the system'.

	aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods.
	aMenu balloonTextForLastItem:
'Check this change set for methods that do not have comments'.

	aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses.
	aMenu balloonTextForLastItem:
'Check for classes with code in this changeset which lack class comments'.


	Utilities authorInitialsPerSe isEmptyOrNil ifFalse:
		[aMenu add: 'check for other authors' action: #checkForAlienAuthorship.
		aMenu balloonTextForLastItem:
'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'.

		aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship.
		aMenu balloonTextForLastItem:
'Check this change set for methods any of whose previous authoring stamps do not start with "', Utilities authorInitials, '"'].

	aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods.
	aMenu balloonTextForLastItem:
'Check to see if any methods in the selected change set have not yet been assigned to a category.  If any are found, open a browser on them.'.
	aMenu addLine.

	aMenu add: 'inspect change set' action: #inspectChangeSet.
	aMenu balloonTextForLastItem: 
'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'.

	aMenu add: 'update' action: #update.
	aMenu balloonTextForLastItem: 
'Update the display for this change set.  (This is done automatically when you activate this window, so is seldom needed.)'.

	aMenu add: 'go to change set''s project' action: #goToChangeSetsProject.
	aMenu balloonTextForLastItem: 
'If this change set is currently associated with a Project, go to that project right now.'.

	aMenu add: 'trim history' action: #trimHistory.
	aMenu balloonTextForLastItem: 
' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes.  NOTE: can cause confusion if later filed in over an earlier version of these changes'.

	aMenu add: 'clear this change set' action: #clearChangeSet.
	aMenu balloonTextForLastItem: 
'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'.
	aMenu add: 'expunge uniclasses' action: #expungeUniclasses.
	aMenu balloonTextForLastItem:
'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'.

	aMenu add: 'uninstall this change set' action: #uninstallChangeSet.
	aMenu balloonTextForLastItem: 
'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'.

	aMenu addLine.

	aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu.
	aMenu balloonTextForLastItem: 
'Takes you back to the primary change-set menu.'.

	^ aMenu! !
ElementCategory subclass: #ChangeSetCategory
	instanceVariableNames: 'membershipSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeSetCategory commentStamp: '<historical>' prior: 0!
A ChangeSetCategory represents a list of change sets to be shown in a ChangeSorter.  It computes whether a given change set is in the list by sending its membershipSelector to ChangeSorter (i.e. the class object) with the change set as message argument.!


!ChangeSetCategory methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
membershipSelector: aSelector
	"Set the membershipSelector"

	membershipSelector := aSelector! !


!ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'sd 5/23/2003 14:25'!
defaultChangeSetToShow
	"Answer the name of a change-set to show"

	^ ChangeSet current! !

!ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'sd 11/20/2005 21:26'!
reconstituteList
	"Clear out the receiver's elements and rebuild them"

	| newMembers |
	"First determine newMembers and check if they have not changed..."
	newMembers := ChangeSorter allChangeSets select:
		[:aChangeSet | ChangeSorter perform: membershipSelector with: aChangeSet].
	(newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self  "all current"].

	"Things have changed.  Need to recompute the whole category"
	self clear.
	newMembers do:
		[:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet] 
! !


!ChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/11/2001 16:11'!
acceptsManualAdditions
	"Answer whether the user is allowed manually to manipulate the contents of the change-set-category."

	^ false! !

!ChangeSetCategory methodsFor: 'queries' stamp: 'sd 11/20/2005 21:26'!
changeSetList
	"Answer the list of change-set names in the category"

	| aChangeSet |
	self reconstituteList.
	keysInOrder size == 0 ifTrue:
		["don't tolerate emptiness, because ChangeSorters gag when they have no change-set selected"
		aChangeSet := ChangeSorter assuredChangeSetNamed: 'New Changes'.
		self elementAt: aChangeSet name put: aChangeSet].
	^ keysInOrder reversed! !

!ChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/5/2001 17:26'!
hasChangeForClassName: aClassName selector: aSelector otherThanIn: excludedChangeSet
	"Answer whether any change set in this category, other than the excluded one, has a change marked for the given class and selector"

	self elementsInOrder do:
		[:aChangeSet |
			(aChangeSet ~~ excludedChangeSet and:
				[((aChangeSet methodChangesAtClass: aClassName) includesKey: aSelector)]) ifTrue:	[^ true]].

	^ false! !

!ChangeSetCategory methodsFor: 'queries' stamp: 'sw 3/30/2001 14:04'!
includesChangeSet: aChangeSet
	"Answer whether the receiver includes aChangeSet in its retrieval list"

	^ ChangeSorter perform: membershipSelector with: aChangeSet! !


!ChangeSetCategory methodsFor: 'services' stamp: 'sd 11/20/2005 21:26'!
fileOutAllChangeSets
	"File out all the nonempty change sets in the current category, suppressing the checks for slips that might otherwise ensue.  Obtain user confirmation before undertaking this possibly prodigious task."

	| aList |
	aList := self elementsInOrder select:
		[:aChangeSet  | aChangeSet isEmpty not].
	aList size == 0 ifTrue: [^ self inform: 'sorry, all the change sets in this category are empty'].
	(self confirm: 'This will result in filing out ', aList size printString, ' change set(s)
Are you certain you want to do this?') ifFalse: [^ self].

	Preferences setFlag: #checkForSlips toValue: false during: 
		[ChangeSorter fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]! !

!ChangeSetCategory methodsFor: 'services' stamp: 'sd 11/20/2005 21:26'!
fillAggregateChangeSet
	"Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category"

	| aggChangeSet |
	aggChangeSet :=  ChangeSorter assuredChangeSetNamed: #Aggregate.
	aggChangeSet clear.
	aggChangeSet setPreambleToSay: '"Change Set:		Aggregate
Created at ', Time now printString, ' on ', Date today printString, ' by combining all the changes in all the change sets in the category ', categoryName printString, '"'.

	(self elementsInOrder copyWithout: aggChangeSet) do:
		[:aChangeSet  | aggChangeSet assimilateAllChangesFoundIn: aChangeSet].
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup] 
! !
ChangeSetCategory subclass: #ChangeSetCategoryWithParameters
	instanceVariableNames: 'parameters'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!

!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:34'!
acceptsManualAdditions
	"Answer whether the user is allowed manually to manipulate the contents of the change-set-category."

	^ true! !

!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:43'!
addChangeSet: aChangeSet
	self inform: 'sorry, you can''t do that'! !

!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:08'!
includesChangeSet: aChangeSet
	"Answer whether the receiver includes aChangeSet in its retrieval list"

	^ ChangeSorter perform: membershipSelector withArguments: { aChangeSet } , parameters! !

!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
parameters: anArray
	parameters := anArray! !

!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
reconstituteList
	"Clear out the receiver's elements and rebuild them"

	| newMembers |
	"First determine newMembers and check if they have not changed..."
	newMembers := ChangeSorter allChangeSets select:
		[:aChangeSet | ChangeSorter perform: membershipSelector withArguments: { aChangeSet }, parameters].
	(newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self  "all current"].

	"Things have changed.  Need to recompute the whole category"
	self clear.
	newMembers do:
		[:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet]! !
TestCase subclass: #ChangeSetClassChangesTest
	instanceVariableNames: 'saveCurrentChangeSet addedChangeSetAccessor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Bugs'!
!ChangeSetClassChangesTest commentStamp: 'dtl 2/19/2005 13:21' prior: 0!
Class category changes are not being properly added to the default changeset in Squeak 3.7. This test case will pass in Squeak 3.6, and fail in Squeak 3.[7-9].
!


!ChangeSetClassChangesTest methodsFor: 'running' stamp: 'dtl 2/19/2005 12:17'!
tearDown

	(Smalltalk classNamed: #JunkClass) ifNotNilDo: [:c | c removeFromSystem: true].
	SystemOrganization removeCategory: #'DeleteMe-1'.
	SystemOrganization removeCategory: #'DeleteMe-2'.
	ChangeSet current removeClassChanges: 'JunkClass'

! !


!ChangeSetClassChangesTest methodsFor: 'support' stamp: 'dtl 2/19/2005 13:08'!
isDefinition: firstString equivalentTo: secondString 
	"When a class definition is reconstructed with #fatDefForClass, it may 
	contain extra trailing space characters in parts of the definition. This 
	is probably a minor bug, but it should be overlooked for purposes of 
	testing the change set update mechanism. The expedient here is to just 
	remove spaces before comparing the definition strings."

	^ firstString notNil
		and: [(firstString copyReplaceAll: ' ''' with: '''')
				= (secondString copyReplaceAll: ' ''' with: '''')]! !


!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'stephaneducasse 2/3/2006 22:39'!
testAddInstanceVariable
	"Adding an instance variable to the class should result in a change
	record being added to the current change set."

	| saveClassDefinition |
	"Define a class and save its definition"
	Object subclass: #JunkClass
		instanceVariableNames: 'zzz'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'DeleteMe-1'.
	saveClassDefinition := (Smalltalk classNamed: #JunkClass) definition.
	self assert: (self
		isDefinition: saveClassDefinition
		equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).

	"Redefine the class, adding one instance variable"
	Object subclass: #JunkClass
		instanceVariableNames: 'zzz aaa'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'DeleteMe-1'.

	"Assert that the class definition has changed"
	self deny: (self
		isDefinition: (Smalltalk classNamed: #JunkClass) definition
		equivalentTo: saveClassDefinition).
	self deny: (self
		isDefinition: saveClassDefinition
		equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).
	self assert: (self
		isDefinition: (Smalltalk classNamed: #JunkClass) definition
		equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).

	"Assert that the change has been recorded in the current change set"
	self assert: (self
		isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass))
			priorDefinition
		equivalentTo: saveClassDefinition).
! !

!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'dtl 2/19/2005 11:55'!
testAddInstanceVariableAddsNewChangeRecord
	"Changing the class category for a class should result in a change
	record being updated in the current change set."

	"At the start of this test, JunkClass should not exist, and there should be
	no change records pertaining to it in the change set."
	self deny: (Smalltalk hasClassNamed: 'JunkClass').
	self assert: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass))
		thisName = 'nil'.
	"Remove bogus change records created as side effect of preceding assert"
	ChangeSet current removeClassChanges: 'nil'.
	"Define a class and save its definition"
	Object subclass: #JunkClass
		instanceVariableNames: 'zzz'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'DeleteMe-1'.

	"Forget about JunkClass in the change set"
	ChangeSet current removeClassChanges: 'JunkClass'.

	"Redefine the class, adding one instance variable"
	Object subclass: #JunkClass
		instanceVariableNames: 'zzz aaa'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'DeleteMe-1'.

	"A change record should now exist in the change set"
	self assert: (self
		isDefinition: (ChangeSet current
			changeRecorderFor: (Smalltalk classNamed: #JunkClass)) priorDefinition
		equivalentTo:
'Object subclass: #JunkClass
	instanceVariableNames: ''zzz ''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''DeleteMe-1''')
! !

!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'stephaneducasse 2/3/2006 22:39'!
testChangeClassCategory
	"Changing the class category for a class should result in a change
	record being added to the current change set."

	| saveClassDefinition |
	"Define a class and save its definition"
	Object subclass: #JunkClass
		instanceVariableNames: 'zzz'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'DeleteMe-1'.
	saveClassDefinition := (Smalltalk classNamed: #JunkClass) definition.
	self assert: saveClassDefinition =
		(ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass)).

	"Redefine the class, changing only the class category"
	Object subclass: #JunkClass
		instanceVariableNames: 'zzz'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'DeleteMe-2'.

	"Assert that the class definition has changed"
	self deny: (self
		isDefinition: (Smalltalk classNamed: #JunkClass) definition
		equivalentTo: saveClassDefinition).
	self deny: (self
		isDefinition: saveClassDefinition
		equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).
	self assert: (self
		isDefinition: (Smalltalk classNamed: #JunkClass) definition
		equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).

	"Assert that the change has been recorded in the current change set"
	self assert: (self
		isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass))
			priorDefinition
		equivalentTo:
'Object subclass: #JunkClass
	instanceVariableNames: ''zzz ''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''DeleteMe-2''')! !

!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'dtl 2/19/2005 12:01'!
testChangeClassCategoryAddsNewChangeRecord
	"Changing the class category for a class should result in a change
	record being updated in the current change set."

	"At the start of this test, JunkClass should not exist, and there should be
	no change records pertaining to it in the change set."
	self deny: (Smalltalk hasClassNamed: 'JunkClass').
	self assert: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass))
		thisName = 'nil'.
	"Remove bogus change records created as side effect of preceding assert"
	ChangeSet current removeClassChanges: 'nil'.
	"Define a class and save its definition"
	Object subclass: #JunkClass
		instanceVariableNames: 'zzz'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'DeleteMe-1'.

	"Forget about JunkClass in the change set"
	ChangeSet current removeClassChanges: 'JunkClass'.

	"Redefine the class, changing only the class category"
	Object subclass: #JunkClass
		instanceVariableNames: 'zzz'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'DeleteMe-2'.

	"A change record should now exist in the change set"
	self assert: (self
		isDefinition: (ChangeSet current
			changeRecorderFor: (Smalltalk classNamed: #JunkClass)) priorDefinition
		equivalentTo:
'Object subclass: #JunkClass
	instanceVariableNames: ''zzz ''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''DeleteMe-2''')! !
CodeHolder subclass: #ChangeSorter
	instanceVariableNames: 'parent myChangeSet currentClassName currentSelector priorChangeSetList changeSetCategory'
	classVariableNames: 'ChangeSetCategories ChangeSetNamesInRelease RecentUpdateMarker'
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeSorter commentStamp: '<historical>' prior: 0!
I display a ChangeSet.  Two of me are in a DualChangeSorter.!


!ChangeSorter methodsFor: 'access' stamp: 'tk 4/29/1998 08:22'!
changeSet
	^ myChangeSet! !

!ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 14:45'!
changeSetCategory
	"Answer the current changeSetCategory object that governs which change sets are shown in this ChangeSorter"

	^ changeSetCategory ifNil:
		[self setDefaultChangeSetCategory]! !

!ChangeSorter methodsFor: 'access' stamp: 'sw 1/27/2000 11:19'!
changeSetCurrentlyDisplayed
	^ myChangeSet! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/30/1998 13:37'!
label
	^ self labelString! !

!ChangeSorter methodsFor: 'access' stamp: 'sd 5/23/2003 14:25'!
labelString
	"The label for my entire window.  The large button that displays my name is gotten via mainButtonName"

	^ String streamContents:
		[:aStream |
			aStream nextPutAll: (ChangeSet current == myChangeSet
				ifTrue: ['Changes go to "', myChangeSet name, '"']
				ifFalse: ['ChangeSet: ', myChangeSet name]).
		(self changeSetCategory categoryName ~~ #All)
			ifTrue:
				[aStream nextPutAll:  ' - ', self parenthesizedCategoryName]]! !

!ChangeSorter methodsFor: 'access' stamp: 'sma 11/11/2000 23:28'!
modelWakeUp
	"A window with me as model is being entered.
	Make sure I am up-to-date with the changeSets."

	self canDiscardEdits ifTrue: [self update]! !

!ChangeSorter methodsFor: 'access' stamp: 'sd 11/20/2005 21:26'!
myChangeSet: anObject
	myChangeSet := anObject! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:42'!
parent
	^ parent! !

!ChangeSorter methodsFor: 'access' stamp: 'sd 11/20/2005 21:26'!
parent: anObject
	parent := anObject! !

!ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 22:51'!
parenthesizedCategoryName
	"Answer my category name in parentheses"

	^ ' (', self changeSetCategory categoryName, ')'! !

!ChangeSorter methodsFor: 'access' stamp: 'sd 11/20/2005 21:26'!
showChangeSet: chgSet

	myChangeSet == chgSet ifFalse: [
		myChangeSet := chgSet.
		currentClassName := nil.
		currentSelector := nil].
	self changed: #relabel.
	self changed: #currentCngSet.	"new -- list of sets"
	self changed: #mainButtonName.	"old, button"
	self changed: #classList.
	self changed: #messageList.
	self setContents.
	self contentsChanged.! !

!ChangeSorter methodsFor: 'access' stamp: 'di 4/5/2001 21:20'!
showChangeSetNamed: aName

	self showChangeSet: (ChangeSorter changeSetNamed: aName) ! !


!ChangeSorter methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:35'!
addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream
	"Add an annotation detailing the prior versions count.  Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset"

	(aClass includesSelector: aSelector) ifTrue:
		[^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream].
	aStream nextPutAll:
		((myChangeSet methodInfoFromRemoval: {aClass name. aSelector})
			ifNil:
				['no prior versions']
			ifNotNil:
				['version(s) retrievable here']), self annotationSeparator! !


!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
addPreamble
	myChangeSet assurePreambleExists.
	self okToChange ifTrue:
		[currentClassName := nil.
		currentSelector := nil.
		self showChangeSet: myChangeSet]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
addToCategoryOpposite
	"Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that"

	| categoryOpposite |
	categoryOpposite := (parent other: self) changeSetCategory.
	categoryOpposite acceptsManualAdditions
		ifTrue:
			[categoryOpposite addChangeSet: myChangeSet.
			categoryOpposite reconstituteList.
			self update]
		ifFalse:
			[self inform: 
'sorry, this command only makes sense
if the category showing on the opposite
side is a static category whose
members are manually maintained']! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:27'!
browseChangeSet
	"Open a message list browser on the new and changed methods in the current change set"

	ChangedMessageSet openFor: myChangeSet

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
browseMethodConflicts
	"Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such."

	| aList |

	aList := myChangeSet 
		messageListForChangesWhich: [ :aClass :aSelector |
			(ChangeSorter allChangeSetsWithClass: aClass selector: aSelector) size > 1
		]
		ifNone: [^ self inform: 'No other change set has changes
for any method in this change set.'].
	
	MessageSet 
		openMessageList: aList 
		name: 'Methods in "', myChangeSet name, '" that are also in other change sets (', aList size printString, ')'
	! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 8/12/2002 17:29'!
categorySubmenu: aMenu  shifted: shiftedIgnored
	"Fill aMenu with less-frequently-needed category items"
	
	aMenu title: 'Change set category'.
	aMenu addStayUpItem.

	aMenu addList: #(
		('make a new category...' makeNewCategory 'Creates a new change-set-category (you will be asked to supply a name) which will start out its life with this change set in it')
		('make a new category with class...' makeNewCategoryShowingClassChanges 'Creates a new change-set-category that includes change sets that change a particular class (you will be asked to supply a name)')
		('rename this category' renameCategory 'Rename this change-set category.   Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.')
		('remove this category' removeCategory 'Remove this change-set category.   Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.')
		('show categories of this changeset' showCategoriesOfChangeSet 'Show a list of all the change-set categories that contain this change-set; if the you choose one of the categories from this pop-up, that category will be installed in this change sorter')
	-).

	parent ifNotNil:
		[aMenu addList: #(
			('add change set to category opposite' addToCategoryOpposite 'Adds this change set to the category on the other side of the change sorter.  Only applies if the category shown on the opposite side is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.'))].

	aMenu addList: #(
		('remove change set from this category' removeFromCategory 'Removes this change set from the current category.  Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.')
		-
		('file out category''s change sets' fileOutAllChangeSets 'File out every change set in this category that has anything in it.  The usual checks for slips are suppressed when this command is done.')
		('set recent-updates marker' setRecentUpdatesMarker 'Allows you to specify a number that will demarcate which updates are considered "recent" and which are not.  This will govern which updates are included in the RecentUpdates category in a change sorter')
		('fill aggregate change set' fillAggregateChangeSet 'Creates a change-set named Aggregate into which all the changes in all the change sets in this category will be copied.')
		-
		('back to main menu' offerUnshiftedChangeSetMenu 'Takes you back to the shifted change-set menu.')
		('back to shifted menu' offerShiftedChangeSetMenu 'Takes you back to the primary change-set menu.')).

	^ aMenu! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 00:00'!
changeSetList
	"Answer a list of ChangeSet names to be shown in the change sorter."

	^ self changeSetCategory changeSetList! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/17/2002 11:37'!
changeSetListKey: aChar from: view
	"Respond to a Command key.  I am a model with a listView that has a list of changeSets."

	aChar == $b ifTrue: [^ self browseChangeSet].
	aChar == $B ifTrue: [^ self openChangeSetBrowser].
	aChar == $c ifTrue: [^ self copyAllToOther].
	aChar == $D ifTrue: [^ self toggleDiffing]. 
	aChar == $f ifTrue: [^ self findCngSet].
	aChar == $m ifTrue: [^ self newCurrent].
	aChar == $n ifTrue: [^ self newSet].
	aChar == $o ifTrue: [^ self fileOut].
	aChar == $p ifTrue: [^ self addPreamble].
	aChar == $r ifTrue: [^ self rename].
	aChar == $s ifTrue: [^ self chooseChangeSetCategory].
	aChar == $x ifTrue: [^ self remove].
	aChar == $- ifTrue: [^ self subtractOtherSide].

	^ self messageListKey: aChar from: view! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/17/2002 11:37'!
changeSetMenu: aMenu shifted: isShifted 
	"Set up aMenu to hold commands for the change-set-list pane.  This could be for a single or double changeSorter"

	isShifted ifTrue: [^ self shiftedChangeSetMenu: aMenu].
	Smalltalk isMorphic
		ifTrue:
			[aMenu title: 'Change Set'.
			aMenu addStayUpItemSpecial]
		ifFalse:
			[aMenu title: 'Change Set:
' , myChangeSet name].

	aMenu add: 'make changes go to me (m)' action: #newCurrent.
	aMenu addLine.
	aMenu add: 'new change set... (n)' action: #newSet.
	aMenu add: 'find...(f)' action: #findCngSet.
	aMenu add: 'show category... (s)' action:  #chooseChangeSetCategory.
	aMenu balloonTextForLastItem:
'Lets you choose which change sets should be listed in this change sorter'.
	aMenu add: 'select change set...' action: #chooseCngSet.
	aMenu addLine.
	aMenu add: 'rename change set (r)' action: #rename.
	aMenu add: 'file out (o)' action: #fileOut.
	aMenu add: 'mail to list' action: #mailOut.
	aMenu add: 'browse methods (b)' action: #browseChangeSet.
	aMenu add: 'browse change set (B)' action: #openChangeSetBrowser.
	aMenu addLine.
	parent
		ifNotNil: 
			[aMenu add: 'copy all to other side (c)' action: #copyAllToOther.
			aMenu add: 'submerge into other side' action: #submergeIntoOtherSide.
			aMenu add: 'subtract other side (-)' action: #subtractOtherSide.
			aMenu addLine].
	myChangeSet hasPreamble
		ifTrue: 
			[aMenu add: 'edit preamble (p)' action: #addPreamble.
			aMenu add: 'remove preamble' action: #removePreamble]
		ifFalse: [aMenu add: 'add preamble (p)' action: #addPreamble].
	myChangeSet hasPostscript
		ifTrue: 
			[aMenu add: 'edit postscript...' action: #editPostscript.
			aMenu add: 'remove postscript' action: #removePostscript]
		ifFalse: [aMenu add: 'add postscript...' action: #editPostscript].
	aMenu addLine.

	aMenu add: 'category functions...' action: #offerCategorySubmenu.
	aMenu balloonTextForLastItem:
'Various commands relating to change-set-categories'.
	aMenu addLine.


	aMenu add: 'destroy change set (x)' action: #remove.
	aMenu addLine.
	aMenu add: 'more...' action: #offerShiftedChangeSetMenu.
	^ aMenu! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 10/30/2000 10:48'!
checkForAlienAuthorship
	"Open a message list browser on all uncommented methods in the current change set that have alien authorship"

	myChangeSet checkForAlienAuthorship

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'nk 3/30/2002 08:56'!
checkForAnyAlienAuthorship
	"Open a message list browser on all uncommented methods in the current change set that have alien authorship, even historically"

	myChangeSet checkForAnyAlienAuthorship

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/29/2001 12:47'!
checkForUnclassifiedMethods
	"Open a message list browser on all methods in the current change set that have not been categorized"

	myChangeSet checkForUnclassifiedMethods

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/18/2002 17:58'!
checkForUncommentedClasses
	"Open a class list browser on classes in the change set that lack class comments"

	myChangeSet checkForUncommentedClasses! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 10/30/2000 10:39'!
checkForUncommentedMethods
	"Open a message list browser on all uncommented methods in the current change set"

	myChangeSet checkForUncommentedMethods

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 10/27/1999 14:20'!
checkForUnsentMessages
	"Open a message list browser on all unsent messages in the current change set"

	myChangeSet checkForUnsentMessages

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/8/1999 13:36'!
checkThatSidesDiffer: escapeBlock
	"If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily"

	(myChangeSet == (parent other: self) changeSet)
		ifTrue:
			[self inform: 
'This command requires that the
change sets selected on the two
sides of the change sorter *not*
be the same.'.
			^ escapeBlock value]
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
chooseChangeSetCategory
	"Present the user with a list of change-set-categories and let her choose one"

	|  cats aMenu result |
	self okToChange ifFalse: [^ self].
	Smalltalk isMorphic ifTrue: [^ self chooseChangeSetCategoryInMorphic].  "gives balloon help"

	cats := ChangeSetCategories elementsInOrder.
	aMenu := SelectionMenu
		labels: (cats collect: [:cat | cat categoryName])
		selections: cats.
	result := aMenu startUp.
	result ifNotNil:
		[changeSetCategory := result.
		self changed: #changeSetList.
		(self changeSetList includes: myChangeSet name) ifFalse:
			[self showChangeSet: (ChangeSorter changeSetNamed: self changeSetList first)].
		self changed: #relabel]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
chooseChangeSetCategoryInMorphic
	"Present the user with a list of change-set-categories and let her choose one.  In this morphic variant, we include balloon help"

	|  aMenu |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu title: 
'Choose the category of
change sets to show in
this Change Sorter
(red = current choice)'.
	ChangeSetCategories elementsInOrder do:
		[:aCategory |
			aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory.
			aCategory == changeSetCategory ifTrue:
				[aMenu lastItem color: Color red].
			aMenu balloonTextForLastItem: aCategory documentation].
	aMenu popUpInWorld! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
chooseCngSet
	"Present the user with an alphabetical list of change set names, and let her choose one"

	| changeSetsSortedAlphabetically chosen |
	self okToChange ifFalse: [^ self].

	changeSetsSortedAlphabetically := self changeSetList asSortedCollection:
		[:a :b | a asLowercase withoutLeadingDigits < b asLowercase withoutLeadingDigits].

	chosen := (SelectionMenu selections: changeSetsSortedAlphabetically)
			startUp.
	chosen ifNil: [^ self].
	self showChangeSet: (ChangeSorter changeSetNamed: chosen)! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
clearChangeSet
	"Clear out the current change set, after getting a confirmation."
	| message |

	self okToChange ifFalse: [^ self].
	myChangeSet isEmpty ifFalse:
		[message := 'Are you certain that you want to\forget all the changes in this set?' withCRs.
		(self confirm: message) ifFalse: [^ self]].
	myChangeSet clear.
	self changed: #classList.
	self changed: #messageList.
	self setContents.
	self contentsChanged.
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
copyAllToOther
	"Copy this entire change set into the one on the other side"
	| companionSorter |
	self checkThatSidesDiffer: [^ self].
	(companionSorter := parent other: self) changeSetCurrentlyDisplayed assimilateAllChangesFoundIn: myChangeSet.
	companionSorter changed: #classList.	"Later the changeSet itself will notice..."
	companionSorter changed: #messageList! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 6/5/1998 06:47'!
currentCngSet
	^ myChangeSet name! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:06'!
editPostscript
	"Allow the user to edit the receiver's change-set's postscript -- in a separate window"

	myChangeSet editPostscript! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:06'!
editPreamble
	"Allow the user to edit the receiver's change-set's preamble -- in a separate window."

	myChangeSet editPreamble! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/19/2000 16:18'!
expungeUniclasses
	"remove all memory of uniclasses in the receiver"

	self okToChange ifFalse: [^ self].
	myChangeSet expungeUniclasses.
	self changed: #classList.
	self changed: #messageList.

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'nk 1/4/2004 17:07'!
fileIntoNewChangeSet
	"Obtain a file designation from the user, and file its contents into a  
	new change set whose name is a function of the filename. Show the  
	new set and leave the current changeSet unaltered."
	| aNewChangeSet stream |
	self okToChange
		ifFalse: [^ self].
	ChangeSet promptForDefaultChangeSetDirectoryIfNecessary.
	stream := StandardFileMenu oldFileStreamFrom: ChangeSet defaultChangeSetDirectory.
	stream
		ifNil: [^ self].
	aNewChangeSet := self class
				newChangesFromStream: stream
				named: (FileDirectory localNameFor: stream name).
	aNewChangeSet
		ifNotNil: [self showChangeSet: aNewChangeSet]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 6/10/1999 12:44'!
fileOut
	"File out the current change set."

	myChangeSet fileOut.
	parent modelWakeUp.	"notice object conversion methods created"
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 00:57'!
fileOutAllChangeSets
	"File out all nonempty change sets in the current category, probably"

	self changeSetCategory fileOutAllChangeSets! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 01:26'!
fillAggregateChangeSet
	"Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category"

	self changeSetCategory fillAggregateChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
findCngSet 
	"Search for a changeSet by name.  Pop up a menu of all changeSets whose name contains the string entered by the user.  If only one matches, then the pop-up menu is bypassed"
	| index pattern candidates nameList |
	self okToChange ifFalse: [^ self].
	pattern := UIManager default request: 'ChangeSet name or fragment?'.
	pattern isEmpty ifTrue: [^ self].
	nameList := self changeSetList asSet.
	candidates := ChangeSet allChangeSets select:
			[:c | (nameList includes: c name) and: 
				[c name includesSubstring: pattern caseSensitive: false]].
	candidates size = 0 ifTrue: [^ Beeper beep].
	candidates size = 1 ifTrue:
		[^ self showChangeSet: candidates first].
	index := (PopUpMenu labels: 
		(candidates collect: [:each | each name]) asStringWithCr) startUp.
	index = 0 ifFalse: [self showChangeSet: (candidates at: index)].
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
goToChangeSetsProject
	"Transport the user to a project which bears the selected changeSet as its current changeSet"

	| aProject |
	(aProject := myChangeSet correspondingProject) 
		ifNotNil:
			[aProject enter: false revert: false saveForRevert: false]
		ifNil:
			[self inform: 'Has no project']! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/10/1999 01:01'!
inspectChangeSet
	"Open a message list browser on the new and changed methods in the current change set"

	myChangeSet inspectWithLabel: 'Change set: ', myChangeSet name

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 2/17/1999 11:05'!
lookForSlips
	"Open a message list browser on the new and changed methods in the current change set"

	myChangeSet lookForSlips

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'dvf 5/13/2000 05:08'!
mailOut
	"Create a mail with a gzipped attachment holding out the current change 
	set. "
	myChangeSet mailOut.
	parent modelWakeUp! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:10'!
mainButtonName

	^ myChangeSet name! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'rbb 3/1/2005 10:28'!
makeNewCategory
	"Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it"

	| catName aCategory |
	catName := UIManager default request: 'Please give the new category a name' initialAnswer: ''.
	catName isEmptyOrNil ifTrue: [^ self].
	catName := catName asSymbol.
	(ChangeSetCategories includesKey: catName) ifTrue:
		[^ self inform: 'Sorry, there is already a category of that name'].

	aCategory := StaticChangeSetCategory new categoryName: catName.
	ChangeSetCategories elementAt: catName put: aCategory.
	aCategory addChangeSet: myChangeSet.
	self showChangeSetCategory: aCategory! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'rbb 3/1/2005 10:28'!
makeNewCategoryShowingClassChanges
	"Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it"

	| catName aCategory clsName |
	clsName := self selectedClass ifNotNil: [self selectedClass name ] ifNil: [''].
	clsName := UIManager default request: 'Which class?' initialAnswer: clsName.
	clsName isEmptyOrNil ifTrue: [^ self].
	catName := ('Changes to ', clsName) asSymbol.
	(ChangeSetCategories includesKey: catName) ifTrue:
		[^ self inform: 'Sorry, there is already a category of that name'].

	aCategory := ChangeSetCategoryWithParameters new categoryName: catName.
	aCategory membershipSelector: #changeSet:containsClass: ; parameters: { clsName }.
	ChangeSetCategories elementAt: catName put: aCategory.
	aCategory reconstituteList.
	self showChangeSetCategory: aCategory! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
methodConflictsWithOppositeCategory
	"Check to see if ANY change set on the other side shares any methods with the selected change set; if so, open a browser on all such."

	| aList otherCategory |

	otherCategory := (parent other: self) changeSetCategory.
	aList := myChangeSet 
		messageListForChangesWhich: [ :aClass :aSelector |
			aClass notNil and: 
				[otherCategory 
					hasChangeForClassName: aClass name 
					selector: aSelector 
					otherThanIn: myChangeSet]
		]
		ifNone: [^ self inform: 
'There are no methods that appear both in
this change set and in any change set
(other than this one) on the other side.'].
	
	MessageSet 
		openMessageList: aList 
		name: 'Methods in "', myChangeSet name, '" also in some other change set in category ', otherCategory categoryName,' (', aList size printString, ')'
	! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
methodConflictsWithOtherSide
	"Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such."

	| aList other |

	self checkThatSidesDiffer: [^ self].
	other := (parent other: self) changeSet.
	aList := myChangeSet 
		messageListForChangesWhich: [ :aClass :aSelector |
			aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector]
		]
		ifNone:  [^ self inform: 'There are no methods that appear
both in this change set and
in the one on the other side.'].
	
	MessageSet 
		openMessageList: aList 
		name: 'Methods in "', myChangeSet name, '" that are also in ', other name,' (', aList size printString, ')'
	! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 5/23/2003 15:15'!
newCurrent
	"make my change set be the current one that changes go into"

	ChangeSet  newChanges: myChangeSet.
	self update.  "Because list of changes in a category may thus have changed"
	self changed: #relabel.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
newSet
	"Create a new changeSet and show it., making it the current one.  Reject name if already in use."

	| aSet |
	self okToChange ifFalse: [^ self].
	aSet := self class newChangeSet.
	aSet ifNotNil:
		[self changeSetCategory acceptsManualAdditions ifTrue:
			[changeSetCategory addChangeSet: aSet].
		self update.
		(changeSetCategory includesChangeSet: aSet) ifTrue:
			[self showChangeSet: aSet].
		self changed: #relabel]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 17:41'!
offerCategorySubmenu
	"Offer a menu of category-related items"

	self offerMenuFrom: #categorySubmenu:shifted: shifted: false! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 2/27/2001 21:55'!
offerShiftedChangeSetMenu
	"Offer the shifted version of the change set menu"

	self offerMenuFrom: #changeSetMenu:shifted: shifted: true! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/6/2001 14:41'!
offerUnshiftedChangeSetMenu
	"Offer the unshifted version of the change set menu"

	self offerMenuFrom: #changeSetMenu:shifted: shifted: false! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/9/2001 15:30'!
openChangeSetBrowser
	"Open a ChangeSet browser on the current change set"

	Smalltalk isMorphic
		ifFalse:
			[self browseChangeSet]  "msg-list browser only"
		ifTrue:
			[(ChangeSetBrowser new myChangeSet: myChangeSet) openAsMorph]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 12/13/2003 18:14'!
promoteToTopChangeSet
	"Move the selected change-set to the top of the list"

	self class promoteToTop: myChangeSet.
	(parent ifNil: [self]) modelWakeUp! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/14/1998 12:00'!
remove
	"Completely destroy my change set.  Check if it's OK first"

	self okToChange ifFalse: [^ self].
	self removePrompting: true.
	self update! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
removeCategory
	"Remove the current category"

	| itsName |
	self changeSetCategory acceptsManualAdditions ifFalse:
		[^ self inform: 'sorry, you can only remove manually-added categories.'].

	(self confirm: 'Really remove the change-set-category
named ', (itsName := changeSetCategory categoryName), '?') ifFalse: [^ self].

	ChangeSetCategories removeElementAt: itsName.
	self setDefaultChangeSetCategory.

	self update! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'rbb 3/1/2005 10:29'!
removeContainedInClassCategories
	| matchExpression |
	myChangeSet removePreamble.
	matchExpression :=  UIManager default request: 'Enter class category name (wildcard is ok)' initialAnswer: 'System-*'. 
	(Smalltalk organization categories
		select: [:each | matchExpression match: each])
		do: [:eachCat | 
			| classNames | 
			classNames := Smalltalk organization listAtCategoryNamed: eachCat.
			classNames
				do: [:eachClassName | 
					myChangeSet removeClassChanges: eachClassName.
					myChangeSet removeClassChanges: eachClassName , ' class'].
			self showChangeSet: myChangeSet]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
removeFromCategory
	"Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that"

	| aCategory |
	(aCategory := self changeSetCategory) acceptsManualAdditions
		ifTrue:
			[aCategory removeElementAt: myChangeSet name.
			aCategory reconstituteList.
			self update]
		ifFalse:
			[self inform: 
'sorry, this command only makes
sense for static categories whose
members are manually maintained']! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 6/29/1999 20:53'!
removePostscript
	(myChangeSet hasPostscript and: [myChangeSet postscriptHasDependents]) ifTrue:
		[^ self inform:
'Cannot remove the postscript right
now because there is at least one
window open on that postscript.
Close that window and try again.'].

	myChangeSet removePostscript.
	self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/5/1999 19:32'!
removePreamble
	myChangeSet removePreamble.
	self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
removePrompting: doPrompt
	"Completely destroy my change set.  Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first."

	| message aName changeSetNumber msg |
	aName := myChangeSet name.
	myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project"
	(myChangeSet isEmpty or: [doPrompt not]) ifFalse:
		[message := 'Are you certain that you want to 
remove (destroy) the change set
named  "', aName, '" ?'.
		(self confirm: message) ifFalse: [^ self]].

	doPrompt ifTrue:
		[msg := myChangeSet hasPreamble
			ifTrue:
				[myChangeSet hasPostscript
					ifTrue:
						['a preamble and a postscript']
					ifFalse:
						['a preamble']]
			ifFalse:
				[myChangeSet hasPostscript
					ifTrue:
						['a postscript']
					ifFalse:
						['']].
		msg isEmpty ifFalse:
			[(self confirm: 
'Caution!!  This change set has
', msg, ' which will be
lost if you destroy the change set.
Do you really want to go ahead with this?') ifFalse: [^ self]]].

	"Go ahead and remove the change set"
	changeSetNumber := myChangeSet name initialIntegerOrNil.
	changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber].
	ChangeSorter removeChangeSet: myChangeSet.
	self showChangeSet: ChangeSet current.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'rbb 3/1/2005 10:29'!
rename
	"Store a new name string into the selected ChangeSet.  reject duplicate name; allow user to back out"

	| newName |
	newName := UIManager default request: 'New name for this change set'
						initialAnswer: myChangeSet name.
	(newName = myChangeSet name or: [newName size == 0]) ifTrue:
			[^ Beeper beep].

	(self class changeSetNamed: newName) ifNotNil:
			[^ Utilities inform: 'Sorry that name is already used'].

	myChangeSet name: newName.
	self update.
	self changed: #mainButtonName.
	self changed: #relabel.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'rbb 3/1/2005 10:29'!
renameCategory
	"Obtain a new name for the category and, if acceptable, apply it"

	| catName oldName |
	self changeSetCategory acceptsManualAdditions ifFalse:
		[^ self inform: 'sorry, you can only rename manually-added categories.'].

	catName := UIManager default request: 'Please give the new category a name' initialAnswer:  (oldName := changeSetCategory categoryName).
	catName isEmptyOrNil ifTrue: [^ self].
	(catName := catName asSymbol) = oldName ifTrue: [^ self inform: 'no change.'].
	(ChangeSetCategories includesKey: catName) ifTrue:
		[^ self inform: 'Sorry, there is already a category of that name'].

	changeSetCategory categoryName: catName.
	ChangeSetCategories removeElementAt: oldName.
	ChangeSetCategories elementAt: catName put: changeSetCategory.

	self update! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/5/2001 11:03'!
reorderChangeSets
	"apply a standard reordering -- let the class handle this"

	^ self class reorderChangeSets! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
setRecentUpdatesMarker
	"Allow the user to change the recent-updates marker"

	| result |
	result := FillInTheBlank request: 
('Enter the lowest change-set number
that you wish to consider "recent"?
(note: highest change-set number
in this image at this time is ', ChangeSet highestNumberedChangeSet asString, ')') initialAnswer: self class recentUpdateMarker asString.
	(result notNil and: [result startsWithDigit]) ifTrue:
		[self class recentUpdateMarker: result asInteger.
		Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'mu 12/11/2003 20:05'!
shiftedChangeSetMenu: aMenu
	"Set up aMenu to hold items relating to the change-set-list pane when the shift key is down"

	Smalltalk isMorphic ifTrue:
		[aMenu title: 'Change set (shifted)'.
		aMenu addStayUpItemSpecial].

	"CONFLICTS SECTION"
	aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts.
	aMenu balloonTextForLastItem: 
'Browse all methods that occur both in this change set and in at least one other change set.'.
	parent ifNotNil:
		[aMenu add: 'conflicts with change set opposite' action: #methodConflictsWithOtherSide.
			aMenu balloonTextForLastItem: 
'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'.

			aMenu add: 'conflicts with category opposite' action: #methodConflictsWithOppositeCategory.
			aMenu balloonTextForLastItem: 
'Browse all methods that occur both in this change set and in ANY change set in the category list on the opposite side of this change sorter, other of course than this change set itself.  (Caution -- this could be VERY slow)'].
	aMenu addLine.

	"CHECKS SECTION"
	aMenu add: 'check for slips' action: #lookForSlips.
	aMenu balloonTextForLastItem: 
'Check this change set for halts and references to Transcript.'.

	aMenu add: 'check for unsent messages' action: #checkForUnsentMessages.
	aMenu balloonTextForLastItem:
'Check this change set for messages that are not sent anywhere in the system'.

	aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods.
	aMenu balloonTextForLastItem:
'Check this change set for methods that do not have comments'.

	aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses.
	aMenu balloonTextForLastItem:
'Check for classes with code in this changeset which lack class comments'.

	Utilities authorInitialsPerSe isEmptyOrNil ifFalse:
		[aMenu add: 'check for other authors' action: #checkForAlienAuthorship.
		aMenu balloonTextForLastItem:
'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'.

	aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship.
	aMenu balloonTextForLastItem:
'Check this change set for methods any of whose authoring stamps do not start with "', Utilities authorInitials, '"'].

	aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods.
	aMenu balloonTextForLastItem:
'Check to see if any methods in the selected change set have not yet been assigned to a category.  If any are found, open a browser on them.'.
	aMenu addLine.

	aMenu add: 'inspect change set' action: #inspectChangeSet.
	aMenu balloonTextForLastItem: 
'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'.

	aMenu add: 'update' action: #update.
	aMenu balloonTextForLastItem: 
'Update the display for this change set.  (This is done automatically when you activate this window, so is seldom needed.)'.

	aMenu add: 'go to change set''s project' action: #goToChangeSetsProject.
	aMenu balloonTextForLastItem: 
'If this change set is currently associated with a Project, go to that project right now.'.

	aMenu add: 'promote to top of list' action: #promoteToTopChangeSet.
	aMenu balloonTextForLastItem:
'Make this change set appear first in change-set lists in all change sorters.'.

	aMenu add: 'trim history' action: #trimHistory.
	aMenu balloonTextForLastItem: 
' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes.  NOTE: can cause confusion if later filed in over an earlier version of these changes'.

	aMenu add: 'remove contained in class categories...' action: #removeContainedInClassCategories.
	aMenu balloonTextForLastItem: ' Drops any changes in given class categories'.

	aMenu add: 'clear this change set' action: #clearChangeSet.
	aMenu balloonTextForLastItem: 
'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'.
	aMenu add: 'expunge uniclasses' action: #expungeUniclasses.
	aMenu balloonTextForLastItem:
'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'.

	aMenu add: 'uninstall this change set' action: #uninstallChangeSet.
	aMenu balloonTextForLastItem: 
'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'.

	aMenu addLine.
	aMenu add: 'file into new...' action: #fileIntoNewChangeSet.
	aMenu balloonTextForLastItem: 
'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'.

	aMenu add: 'reorder all change sets' action: #reorderChangeSets.
	aMenu balloonTextForLastItem:
'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets'.

	aMenu addLine.

	aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu.
	aMenu balloonTextForLastItem: 
'Takes you back to the primary change-set menu.'.

	^ aMenu! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
showCategoriesOfChangeSet
	"Show a list of all the categories in which the selected change-set occurs at the moment.  Install the one the user chooses, if any."

	| aMenu |
	Smalltalk isMorphic
		ifFalse:
			[self inform:
'Only available in morphic, right now, sorry.
It would not take much to make this
also work in mvc, so if you are
inclined to do that, thanks in advance...']
		ifTrue:
			[aMenu := MenuMorph new defaultTarget: self.
	aMenu title: 
'Categories which
contain change set
"', myChangeSet name, '"'.
			ChangeSetCategories elementsInOrder do:
				[:aCategory |
					(aCategory includesChangeSet: myChangeSet)
						ifTrue:
							[aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory.
						aCategory == changeSetCategory ifTrue:
							[aMenu lastItem color: Color red]].
						aMenu balloonTextForLastItem: aCategory documentation].
				aMenu popUpInWorld]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
showChangeSetCategory: aChangeSetCategory
	"Show the given change-set category"
	
	changeSetCategory := aChangeSetCategory.
	self changed: #changeSetList.
	(self changeSetList includes: myChangeSet name) ifFalse:
			[self showChangeSet: (ChangeSorter changeSetNamed: self changeSetList first)].
	self changed: #relabel! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
submergeIntoOtherSide
	"Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well."
	| other message nextToView i all |
	self checkThatSidesDiffer: [^ self].
	self okToChange ifFalse: [^ self].
	other := (parent other: self) changeSet.
	other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!'].
	myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy.  To remove,
simply choose "remove".'].

	myChangeSet okayToRemove ifFalse: [^ self].
	message := 'Please confirm:  copy all changes
in "', myChangeSet name, '" into "', other name, '"
and then destroy the change set
named "', myChangeSet name, '"?'.
 
	(self confirm: message) ifFalse: [^ self].

	(myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue:
		[(self confirm: 
'Caution!!  This change set has a preamble or
a postscript or both.  If you submerge it into
the other side, these will be lost.
Do you really want to go ahead with this?') ifFalse: [^ self]].

	other assimilateAllChangesFoundIn: myChangeSet.
	all := ChangeSet allChangeSets.
	nextToView := ((all includes: myChangeSet)
		and: [(i := all indexOf: myChangeSet) < all size])
		ifTrue: [all at: i+1]
		ifFalse: [other].

	self removePrompting: false.
	self showChangeSet: nextToView.
	parent modelWakeUp.
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/8/1999 12:32'!
subtractOtherSide
	"Subtract the changes found on the other side from the requesting side."
	self checkThatSidesDiffer: [^ self].
	myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet).
	self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 5/12/2000 15:03'!
trimHistory
	"Drop non-essential history (rename, reorg, method removals) from newly-added classes."

	myChangeSet trimHistory

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 3/8/2000 14:18'!
uninstallChangeSet
	"Attempt to uninstall the current change set, after confirmation."

	self okToChange ifFalse: [^ self].
	(self confirm: 'Uninstalling a changeSet is unreliable at best.
It will only work if the changeSet consists only of single
changes, additions and removals of methods, and if
no subsequent changes have been to any of them.
No changes to classes will be undone.
The changeSet will be cleared after uninstallation.
Do you still wish to attempt to uninstall this changeSet?')
	ifFalse: [^ self].

	myChangeSet uninstall.
	self changed: #relabel.
	self changed: #classList.
	self changed: #messageList.
	self setContents.
	self contentsChanged.
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/21/1998 13:02'!
update
	"recompute all of my panes"

	self updateIfNecessary.
	parent ifNotNil: [(parent other: self) updateIfNecessary]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 11/20/2005 21:26'!
updateIfNecessary
	"Recompute all of my panes."

	| newList |
	self okToChange ifFalse: [^ self].

	myChangeSet ifNil: [^ self].  "Has been known to happen though shouldn't"
	(myChangeSet isMoribund or: [(changeSetCategory notNil and: [changeSetCategory includesChangeSet: myChangeSet]) not]) ifTrue:
		[self changed: #changeSetList.
		^ self showChangeSet: self changeSetCategory defaultChangeSetToShow].

	newList := self changeSetList.

	(priorChangeSetList == nil or: [priorChangeSetList ~= newList])
		ifTrue:
			[priorChangeSetList := newList.
			self changed: #changeSetList].
	self showChangeSet: myChangeSet! !


!ChangeSorter methodsFor: 'class list' stamp: 'sw 3/29/2001 15:19'!
classList
	"Computed.  View should try to preserve selections, even though index changes"

	^ myChangeSet ifNotNil: [myChangeSet changedClassNames] ifNil: [OrderedCollection new]
! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 3/5/2001 18:24'!
classListKey: aChar from: view
	"Respond to a Command key in the class-list pane."

	aChar == $x ifTrue: [^ self removeClass].
	aChar == $d ifTrue: [^ self forgetClass]. 

	^ self messageListKey: aChar from: view "picks up b,h,p"! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 11/3/2001 09:34'!
classListMenu: aMenu shifted: shifted
	"Fill aMenu with items appropriate for the class list"

	aMenu title: 'class list'.
	Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].
	(parent notNil and: [shifted not])
		ifTrue: [aMenu addList: #( "These two only apply to dual change sorters"
			('copy class chgs to other side'			copyClassToOther)	
			('move class chgs to other side'			moveClassToOther))].

	aMenu addList: (shifted
		ifFalse: [#(
			-
			('delete class from change set (d)'		forgetClass)
			('remove class from system (x)'			removeClass)
			-
			('browse full (b)'						browseMethodFull)
			('browse hierarchy (h)'					spawnHierarchy)
			('browse protocol (p)'					browseFullProtocol)
			-
			('printOut'								printOutClass)
			('fileOut'								fileOutClass)
			-
			('inst var refs...'						browseInstVarRefs)
			('inst var defs...'						browseInstVarDefs)
			('class var refs...'						browseClassVarRefs)
			('class vars'								browseClassVariables)
			('class refs (N)'							browseClassRefs)
			-
			('more...'								offerShiftedClassListMenu))]

		ifTrue: [#(
			-
			('unsent methods'						browseUnusedMethods)
			('unreferenced inst vars'				showUnreferencedInstVars)
			('unreferenced class vars'				showUnreferencedClassVars)
			-
			('sample instance'						makeSampleInstance)
			('inspect instances'						inspectInstances)
			('inspect subinstances'					inspectSubInstances)
			-
			('more...'								offerUnshiftedClassListMenu ))]).
	^ aMenu! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 2/26/2001 12:00'!
classMenu: aMenu
	"Set up aMenu for the class-list.  Retained for backward compatibility with old change sorters in image segments"

	^ self classListMenu: aMenu shifted: false! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 3/6/2001 12:40'!
classMenu: aMenu shifted: shifted
	"Fill aMenu with items appropriate for the class list.  Retained for bkwd compatibility"

	^ self classListMenu: aMenu shifted: shifted! !

!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'!
copyClassToOther
	"Place these changes in the other changeSet also"

	| otherSorter otherChangeSet |
	self checkThatSidesDiffer: [^ self].
	self okToChange ifFalse: [^ Beeper beep].
	currentClassName ifNil: [^ Beeper beep].
	otherSorter := parent other: self.
	otherChangeSet := otherSorter changeSet.

	otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet.
	otherSorter showChangeSet: otherChangeSet.! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 4/24/1998 09:14'!
currentClassName

	^ currentClassName! !

!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'!
currentClassName: aString

	currentClassName := aString.
	currentSelector := nil.	"fix by wod"
	self changed: #currentClassName.
	self changed: #messageList.
	self setContents.
	self contentsChanged.! !

!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'!
fileOutClass
	"this is a hack!!!! makes a new change set, called the class name, adds author initials to try to make a unique change set name, files it out and removes it. kfr 16 june 2000" 
	| aSet |
	"File out the selected class set."
     aSet := self class newChangeSet: currentClassName.
	aSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet.
	aSet fileOut.
	self class removeChangeSet: aSet.
	parent modelWakeUp.	"notice object conversion methods created"

! !

!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'!
forgetClass
	"Remove all mention of this class from the changeSet"

	self okToChange ifFalse: [^ self].
	currentClassName ifNotNil: [
		myChangeSet removeClassChanges: currentClassName.
		currentClassName := nil.
		currentSelector := nil.
		self showChangeSet: myChangeSet].
! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 3/5/2001 18:30'!
messageListKey: aChar from: view
	"Respond to a Command key in the message-list pane."

	aChar == $d ifTrue: [^ self forget].
	super messageListKey: aChar from: view! !

!ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25'!
moveClassToOther
	"Place class changes in the other changeSet and remove them from this one"

	self checkThatSidesDiffer: [^ self].
	(self okToChange and: [currentClassName notNil]) ifFalse: [^ Beeper beep].

	self copyClassToOther.
	self forgetClass! !

!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'!
selectedClass
	"Answer the currently-selected class.  If there is no selection, or if the selection refers to a class no longer extant, return nil"
	| c |
	^ currentClassName ifNotNil: [(c := self selectedClassOrMetaClass)
		ifNotNil: [c theNonMetaClass]]! !


!ChangeSorter methodsFor: 'code pane' stamp: 'sd 11/20/2005 21:26'!
contents: aString notifying: aController 
	"Compile the code in aString. Notify aController of any syntax errors. 
	Create an error if the category of the selected message is unknown. 
	Answer false if the compilation fails. Otherwise, if the compilation 
	created a new method, deselect the current selection. Then answer true."
	| category selector class oldSelector |

	(class := self selectedClassOrMetaClass) ifNil:
		[(myChangeSet preambleString == nil or: [aString size == 0]) ifTrue: [ ^ false].
		(aString count: [:char | char == $"]) odd 
			ifTrue: [self inform: 'unmatched double quotes in preamble']
			ifFalse: [(Scanner new scanTokens: aString) size > 0 ifTrue: [
				self inform: 'Part of the preamble is not within double-quotes.
To put a double-quote inside a comment, type two double-quotes in a row.
(Ignore this warning if you are including a doIt in the preamble.)']].
		myChangeSet preambleString: aString.
		self currentSelector: nil.  "forces update with no 'unsubmitted chgs' feedback"
		^ true].
	oldSelector := self selectedMessageName.
	category := class organization categoryOfElement: oldSelector.
	selector := class compile: aString
				classified: category
				notifying: aController.
	selector ifNil: [^ false].
	(self messageList includes: selector)
		ifTrue: [self currentSelector: selector]
		ifFalse: [self currentSelector: oldSelector].
	self update.
	^ true! !

!ChangeSorter methodsFor: 'code pane' stamp: 'md 7/17/2006 10:41'!
setContents
	"return the source code that shows in the bottom pane"

	| sel class strm changeType | 
	self clearUserEditFlag.
	currentClassName ifNil: [^ contents := myChangeSet preambleString ifNil: ['']].
	class := self selectedClassOrMetaClass.
	(sel := currentSelector) == nil
		ifFalse: [changeType := (myChangeSet atSelector: (sel := sel asSymbol) class: class).
			changeType == #remove
				ifTrue: [^ contents := 'Method has been removed (see versions)'].
			changeType == #addedThenRemoved
				ifTrue: [^ contents := 'Added then removed (see versions)'].
			class ifNil: [^ contents := 'Method was added, but cannot be found!!'].
			(class includesSelector: sel)
				ifFalse: [^ contents := 'Method was added, but cannot be found!!'].
			contents := class sourceCodeAt: sel.
			(#(prettyPrint colorPrint prettyDiffs) includes: contentsSymbol) ifTrue:
				[contents :=  class prettyPrinterClass
					format: contents in: class notifying: nil contentsSymbol: contentsSymbol].
			self showingAnyKindOfDiffs
				ifTrue: [contents := self diffFromPriorSourceFor: contents].
			^ contents := contents asText makeSelectorBoldIn: class]
		ifTrue: [strm := WriteStream on: (String new: 100).
			(myChangeSet classChangeAt: currentClassName) do:
				[:each |
				each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr].
				each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.'].
				each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.'; cr].
				each = #add ifTrue: [strm nextPutAll: 'Class definition was added.'; cr].
				each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr].
				each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.'; cr].
				each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr.
				]].
			^ contents := strm contents].! !

!ChangeSorter methodsFor: 'code pane' stamp: 'sw 11/13/2001 07:34'!
toggleDiffing
	"Toggle whether diffs should be shown in the code pane"

	self okToChange ifTrue:
		[super toggleDiffing.
		self changed: #contents.
		self update]

! !

!ChangeSorter methodsFor: 'code pane' stamp: 'JW 2/2/2001 21:41'!
wantsOptionalButtons
	"No optional buttons for ChangeSorter"
	^false! !


!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'!
morphicWindow
	"ChangeSorter new openAsMorph"
	|  window |

	myChangeSet ifNil: [self myChangeSet: ChangeSet current]. 
	window := (SystemWindow labelled: self labelString) model: self.
	self openAsMorphIn: window rect: (0@0 extent: 1@1).
	^ window
! !

!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'!
open
	"ChangeSorterPluggable new open"
	| topView |
	Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph].

	topView := StandardSystemView new.
	topView model: self.
	myChangeSet ifNil: [self myChangeSet: ChangeSet current]. 
	topView label: self labelString.
	topView borderWidth: 1; minimumSize: 360@360.
	self openView: topView offsetBy: 0@0.
	topView controller open.
! !

!ChangeSorter methodsFor: 'creation' stamp: 'sw 3/6/1999 09:34'!
openAsMorph
	"ChangeSorter new openAsMorph"
	^ self morphicWindow openInWorld.
! !

!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'!
openAsMorphIn: window rect: rect
	"Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0."

	| csListHeight msgListHeight csMsgListHeight |
	contents := ''.
	csListHeight := 0.25.
	msgListHeight := 0.25.
	csMsgListHeight := csListHeight + msgListHeight.
	self addDependent: window.		"so it will get changed: #relabel"
	
"The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars needs the crrentSelector pane to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added."
	Preferences scrollBarsOnRight ifFalse:
		[window addMorph: (PluggableListMorphByItem on: self
					list: #messageList
					selected: #currentSelector
					changeSelected: #currentSelector:
					menu: #messageMenu:shifted:
					keystroke: #messageListKey:from:)
			frame: (((0@csListHeight extent: 1@msgListHeight)
				scaleBy: rect extent) translateBy: rect origin)].

	window addMorph: ((PluggableListMorphByItem on: self
				list: #changeSetList
				selected: #currentCngSet
				changeSelected: #showChangeSetNamed:
				menu: #changeSetMenu:shifted:
				keystroke: #changeSetListKey:from:)
			autoDeselect: false)
		frame: (((0@0 extent: 0.5@csListHeight)
			scaleBy: rect extent) translateBy: rect origin).

	window addMorph: (PluggableListMorphByItem on: self
				list: #classList
				selected: #currentClassName
				changeSelected: #currentClassName:
				menu: #classListMenu:shifted:
				keystroke: #classListKey:from:)
		frame: (((0.5@0 extent: 0.5@csListHeight)
			scaleBy: rect extent) translateBy: rect origin).

	Preferences scrollBarsOnRight ifTrue:
		[window addMorph: (PluggableListMorphByItem on: self
					list: #messageList
					selected: #currentSelector
					changeSelected: #currentSelector:
					menu: #messageMenu:shifted:
					keystroke: #messageListKey:from:)
			frame: (((0@csListHeight extent: 1@msgListHeight)
				scaleBy: rect extent) translateBy: rect origin)].

	 self addLowerPanesTo: window
		at: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin)
		with: nil.
! !

!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'!
openView: topView offsetBy: offset
	"Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 360@0."

	| classView messageView codeView cngSetListView basePane annoPane annoHeight |
	contents := ''.
	annoHeight := 20.
	self addDependent: topView. "so it will get changed: #relabel"

	cngSetListView := PluggableListViewByItem on: self
		list: #changeSetList
		selected: #currentCngSet
		changeSelected: #showChangeSetNamed:
		menu: #changeSetMenu:shifted:
		keystroke: #changeSetListKey:from:.
	cngSetListView window: ((0@0 extent: 180@100) translateBy: offset).
	topView addSubView: cngSetListView.

	classView := PluggableListViewByItem on: self
		list: #classList
		selected: #currentClassName
		changeSelected: #currentClassName:
		menu: #classListMenu:shifted:
		keystroke: #classListKey:from:.
	classView window: ((0@0 extent: 180@100) translateBy: offset).
	topView addSubView: classView toRightOf: cngSetListView.

	messageView := PluggableListViewByItem on: self
		list: #messageList
		selected: #currentSelector
		changeSelected: #currentSelector:
		menu: #messageMenu:shifted:
		keystroke: #messageListKey:from:.
	messageView menuTitleSelector: #messageListSelectorTitle.
	messageView window: ((0@0 extent: 360@100) translateBy: offset).
	topView addSubView: messageView below: cngSetListView.

	 self wantsAnnotationPane
		ifFalse:
			[basePane := messageView]
		ifTrue:
			[annoPane := PluggableTextView on: self
				text: #annotation
				accept: nil
				readSelection: nil
				menu: nil.
			annoPane window: ((0@0 extent: 360@annoHeight) translateBy: offset).
			topView addSubView: annoPane below: messageView.
			basePane := annoPane].

	codeView := PluggableTextView on: self 
		text: #contents
		accept: #contents:notifying:
		readSelection: #contentsSelection
		menu: #codePaneMenu:shifted:.
	codeView window: ((0 @ 0 extent: 360 @ 180) translateBy: offset).
	topView addSubView: codeView below: basePane.! !

!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'!
setDefaultChangeSetCategory
	"Set a default ChangeSetCategory for the receiver, and answer it"

	^ changeSetCategory := self class changeSetCategoryNamed: #All! !

!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'!
veryDeepFixupWith: deepCopier

	super veryDeepFixupWith: deepCopier.
	parent := deepCopier references at: parent ifAbsent: [parent].
	self updateIfNecessary! !

!ChangeSorter methodsFor: 'creation' 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."

super veryDeepInner: deepCopier.
"parent := parent.		Weakly copied"
"myChangeSet := myChangeSet.		Weakly copied"
currentClassName := currentClassName veryDeepCopyWith: deepCopier.
"currentSelector := currentSelector.		Symbol"
priorChangeSetList := priorChangeSetList veryDeepCopyWith: deepCopier.
changeSetCategory := changeSetCategory.

! !


!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
browseVersions
	"Create and schedule a changelist browser on the versions of the 
	selected message."
	| class selector method category pair sourcePointer |

	(selector := self selectedMessageName) ifNil: [^ self].
	class := self selectedClassOrMetaClass.
	(class includesSelector: selector)
		ifTrue: [method := class compiledMethodAt: selector.
				category := class whichCategoryIncludesSelector: selector.
				sourcePointer := nil]
		ifFalse: [pair := myChangeSet methodInfoFromRemoval: {class name. selector}.
				pair ifNil: [^ nil].
				sourcePointer := pair first.
				method := CompiledMethod toReturnSelf setSourcePointer: sourcePointer.
				category := pair last].
	VersionsBrowser
		browseVersionsOf: method
		class: self selectedClass meta: class isMeta
		category: category selector: selector
		lostMethodPointer: sourcePointer.
! !

!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
copyMethodToOther
	"Place this change in the other changeSet also"
	| other cls sel |
	self checkThatSidesDiffer: [^ self].
	currentSelector ifNotNil:
		[other := (parent other: self) changeSet.
		cls := self selectedClassOrMetaClass.
		sel := currentSelector asSymbol.

		other absorbMethod: sel class: cls from: myChangeSet.
		(parent other: self) showChangeSet: other]
! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/24/1998 09:15'!
currentSelector

	^ currentSelector! !

!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
currentSelector: messageName

	currentSelector := messageName.
	self changed: #currentSelector.
	self setContents.
	self contentsChanged.! !

!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
forget
	"Drop this method from the changeSet"

	self okToChange ifFalse: [^ self].
	currentSelector ifNotNil: [
		myChangeSet removeSelectorChanges: self selectedMessageName 
			class: self selectedClassOrMetaClass.
		currentSelector := nil.
		self showChangeSet: myChangeSet]! !

!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
messageList 

	| probe newSelectors |
	currentClassName ifNil: [^ #()].
	probe := (currentClassName endsWith: ' class')
		ifTrue: [currentClassName]
		ifFalse: [currentClassName asSymbol].
	newSelectors := myChangeSet selectorsInClass: probe.
	(newSelectors includes: currentSelector) ifFalse: [currentSelector := nil].
	^ newSelectors asSortedCollection
! !

!ChangeSorter methodsFor: 'message list' stamp: 'sw 3/9/2001 14:27'!
messageListMenu: aMenu shifted: shifted
	"Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter"

	^ self messageMenu: aMenu shifted: shifted! !

!ChangeSorter methodsFor: 'message list' stamp: 'sw 3/5/2001 18:26'!
messageMenu: aMenu shifted: shifted
	"Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter"

	shifted ifTrue: [^ self shiftedMessageMenu: aMenu].

	aMenu title: 'message list'.
	Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].

	parent ifNotNil:
		[aMenu addList: #(
			('copy method to other side'			copyMethodToOther)
			('move method to other side'			moveMethodToOther))].

	aMenu addList: #(
			('delete method from changeSet (d)'	forget)
			-
			('remove method from system (x)'	removeMessage)
				-
			('browse full (b)'					browseMethodFull)
			('browse hierarchy (h)'				spawnHierarchy)
			('browse method (O)'				openSingleMessageBrowser)
			('browse protocol (p)'				browseFullProtocol)
			-
			('fileOut'							fileOutMessage)
			('printOut'							printOutMessage)
			-
			('senders of... (n)'					browseSendersOfMessages)
			('implementors of... (m)'				browseMessages)
			('inheritance (i)'					methodHierarchy)
			('versions (v)'						browseVersions)
			-
			('more...'							shiftedYellowButtonActivity)).
	^ aMenu
! !

!ChangeSorter methodsFor: 'message list' stamp: 'nk 7/30/2004 17:58'!
moveMethodToOther
	"Place this change in the other changeSet and remove it from this side"

	| other cls sel |
	self checkThatSidesDiffer: [^self].
	self okToChange ifFalse: [^Beeper beep].
	currentSelector ifNotNil: 
			[other := (parent other: self) changeSet.
			other == myChangeSet ifTrue: [^Beeper  beep].
			cls := self selectedClassOrMetaClass.
			sel := currentSelector asSymbol.
			other 
				absorbMethod: sel
				class: cls
				from: myChangeSet.
			(parent other: self) showChangeSet: other.
			self forget	"removes the method from this side"]! !

!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
removeFromCurrentChanges
	"Redisplay after removal in case we are viewing the current changeSet"

	super removeFromCurrentChanges.
	currentSelector := nil.
	self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'!
removeMessage
	"Remove the selected msg from the system. Real work done by the 
	parent, a ChangeSorter"
	| confirmation sel |
	self okToChange
		ifFalse: [^ self].
	currentSelector
		ifNotNil: [confirmation := self systemNavigation   confirmRemovalOf: (sel := self selectedMessageName) on: self selectedClassOrMetaClass.
			confirmation == 3
				ifTrue: [^ self].
			self selectedClassOrMetaClass removeSelector: sel.
			self update.
			confirmation == 2
				ifTrue: [self systemNavigation browseAllCallsOn: sel]]! !

!ChangeSorter methodsFor: 'message list' stamp: 'jm 5/4/1998 07:32'!
selectedMessageName

	currentSelector ifNil: [^ nil].
	^ currentSelector asSymbol! !

!ChangeSorter methodsFor: 'message list' stamp: 'sw 1/25/2001 07:25'!
shiftedMessageMenu: aMenu
	"Arm the menu so that it holds items appropriate to the message-list while the shift key is down.  Answer the menu."

	^ aMenu addList: #(
		-
		('method pane'						makeIsolatedCodePane)
		('toggle diffing (D)'					toggleDiffing)
		('implementors of sent messages'		browseAllMessages)
		('change category...'				changeCategory)
			-
		('sample instance'					makeSampleInstance)
		('inspect instances'					inspectInstances)
		('inspect subinstances'				inspectSubInstances)
		-
		('change sets with this method'		findMethodInChangeSets)
		('revert to previous version'			revertToPreviousVersion)
		('revert & remove from changes'	revertAndForget)
		-
		('more...'							unshiftedYellowButtonActivity))! !


!ChangeSorter methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 20:32'!
buildWith: builder
	"
		MorphicUIBuilder open: ChangeSorter.
	"
	|  windowSpec |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec label: 'Change Sorter'.
	windowSpec model: self.
	windowSpec children: OrderedCollection new.
	self buildWith: builder in: windowSpec rect: (0@0 extent: 1@1).
	^builder build: windowSpec! !

!ChangeSorter methodsFor: 'toolbuilder' stamp: 'sd 11/20/2005 21:26'!
buildWith: builder in: window rect: rect
	| csListHeight msgListHeight csMsgListHeight listSpec textSpec |
	contents := ''.
	csListHeight := 0.25.
	msgListHeight := 0.25.
	csMsgListHeight := csListHeight + msgListHeight.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #changeSetList; 
		getSelected: #currentCngSet; 
		setSelected: #showChangeSetNamed:; 
		menu: #changeSetMenu:shifted:; 
		keyPress: #changeSetListKey:from:;
		autoDeselect: false;
		frame: (((0@0 extent: 0.5@csListHeight)
			scaleBy: rect extent) translateBy: rect origin).
	window children add: listSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #classList; 
		getSelected: #currentClassName; 
		setSelected: #currentClassName:; 
		menu: #classListMenu:shifted:; 
		keyPress: #classListKey:from:;
		frame: (((0.5@0 extent: 0.5@csListHeight)
			scaleBy: rect extent) translateBy: rect origin).
	window children add: listSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #messageList; 
		getSelected: #currentSelector;
		setSelected: #currentSelector:; 
		menu: #messageMenu:shifted:; 
		keyPress: #messageListKey:from:;
		frame: (((0@csListHeight extent: 1@msgListHeight)
			scaleBy: rect extent) translateBy: rect origin).
	window children add: listSpec.

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		getText: #contents; 
		setText: #contents:notifying:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin).
	window children add: textSpec.
	^window! !


!ChangeSorter methodsFor: 'traits' stamp: 'al 7/18/2004 11:44'!
selectedClassOrMetaClass
	"Careful, the class may have been removed!!"

	| cName tName |
	currentClassName ifNil: [^ nil].
	(currentClassName endsWith: ' class')
		ifTrue: [cName _ (currentClassName copyFrom: 1 to: currentClassName size-6) asSymbol.
				^ (Smalltalk at: cName ifAbsent: [^nil]) class].
	(currentClassName endsWith: ' classTrait')
		ifTrue: [tName _ (currentClassName copyFrom: 1 to: currentClassName size-11) asSymbol.
				^ (Smalltalk at: tName ifAbsent: [^nil]) classTrait].
	cName _ currentClassName asSymbol.
	^ Smalltalk at: cName ifAbsent: [nil]! !

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

ChangeSorter class
	instanceVariableNames: ''!

!ChangeSorter class methodsFor: 'adding' stamp: 'ar 7/15/2005 21:15'!
basicNewChangeSet: newName
	^ChangeSet basicNewChangeSet: newName! !

!ChangeSorter class methodsFor: 'adding' stamp: 'rbb 3/1/2005 10:29'!
newChangeSet
	"Prompt the user for a name, and establish a new change set of
	that name (if ok), making it the current changeset.  Return nil
	of not ok, else return the actual changeset."

	| newName newSet |
	newName := UIManager default
		request: 'Please name the new change set:'
		initialAnswer: ChangeSet defaultName.
	newName isEmptyOrNil ifTrue:
		[^ nil].
	newSet := self basicNewChangeSet: newName.
	newSet ifNotNil:
		[ChangeSet  newChanges: newSet].
	^ newSet! !

!ChangeSorter class methodsFor: 'adding' stamp: 'sd 11/20/2005 21:28'!
newChangeSet: aName
	"Makes a new change set called aName, add author initials to try to
	ensure a unique change set name."

	| newName |
	newName := aName , FileDirectory dot , Utilities authorInitials.
	^ self basicNewChangeSet: newName! !

!ChangeSorter class methodsFor: 'adding' stamp: 'ar 7/16/2005 14:20'!
newChangesFromStream: aStream named: aName
	^ChangeSet newChangesFromStream: aStream named: aName
! !


!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 16:01'!
belongsInAdditions: aChangeSet
	"Answer whether a change set belongs in the Additions category, which is fed by all change sets that are neither numbered nor in the initial release"

	^ (((self belongsInProjectsInRelease: aChangeSet) or:
		[self belongsInNumbered: aChangeSet])) not! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:38'!
belongsInAll: aChangeSet
	"Answer whether a change set belongs in the All category"

	^ true ! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:47'!
belongsInMyInitials: aChangeSet
	"Answer whether a change set belongs in the MyInitials category. "

	^ aChangeSet name endsWith: ('-', Utilities authorInitials)! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:45'!
belongsInNumbered:  aChangeSet
	"Answer whether a change set belongs in the Numbered category. "

	^  aChangeSet name startsWithDigit! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:49'!
belongsInProjectChangeSets: aChangeSet
	"Answer whether a change set belongs in the MyInitials category. "

	^ aChangeSet belongsToAProject! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
belongsInProjectsInRelease:  aChangeSet
	"Answer whether a change set belongs in the ProjectsInRelease category.  You can hand-tweak this to suit your working style.  This just covers the space of project names in the 2.9, 3.0, and 3.1a systems"

	| aString |
	^ ((aString := aChangeSet name) beginsWith: 'Play With Me') or: [self changeSetNamesInReleaseImage includes: aString]! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:56'!
belongsInRecentUpdates: aChangeSet
	"Answer whether a change set belongs in the RecentUpdates category."

	^ aChangeSet name startsWithDigit and:
			[aChangeSet name asInteger >= self recentUpdateMarker]! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/29/2001 14:44'!
changeSetCategoryNamed: aName
	"Answer the changeSetCategory of the given name, or nil if none"

	^ ChangeSetCategories elementAt: aName asSymbol ! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
changeSetNamesInReleaseImage
	"Answer a list of names of project change sets that come pre-shipped in the latest sytem release.  On the brink of shipping a new release, call 'ChangeSorter noteChangeSetsInRelease'  "

	^ ChangeSetNamesInRelease ifNil:
		[ChangeSetNamesInRelease := self changeSetNamesInThreeOh]! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 4/16/2002 00:45'!
changeSetNamesInThreeOh
	"Hard-coded: answer a list of names of project change sets that came pre-shipped in Squeak 3.0"

	^ #('The Worlds of Squeak' 'Fun with Morphic' 'Games' 'Fun With Music' 'Building with Squeak' 'Squeak and the Internet' 'Squeak in 3D' 'More About Sound' ) ! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'ar 9/27/2005 19:55'!
initialize
	"Initialize the class variables"
	ChangeSetCategories ifNil:
		[self initializeChangeSetCategories].
	RecentUpdateMarker := 0.

	"ChangeSorter initialize"

	FileList registerFileReader: self.

	self registerInFlapsRegistry.
! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
initializeChangeSetCategories
	"Initialize the set of change-set categories"
	"ChangeSorter initializeChangeSetCategories"

	| aCategory |
	ChangeSetCategories := ElementCategory new categoryName: #ChangeSetCategories.

	aCategory := ChangeSetCategory new categoryName: #All.
	aCategory membershipSelector: #belongsInAll:.
	aCategory documentation: 'All change sets known to the system'.
	ChangeSetCategories addCategoryItem: aCategory.

	aCategory := ChangeSetCategory new categoryName: #Additions.
	aCategory membershipSelector: #belongsInAdditions:.
	aCategory documentation: 'All unnumbered change sets except those representing projects in the system as initially released.'.
	ChangeSetCategories addCategoryItem: aCategory.

	aCategory := ChangeSetCategory new categoryName: #MyInitials.
	aCategory membershipSelector: #belongsInMyInitials:.
	aCategory documentation: 'All change sets whose names end with the current author''s initials.'.
	ChangeSetCategories addCategoryItem: aCategory.

	aCategory := ChangeSetCategory new categoryName: #Numbered.
	aCategory membershipSelector: #belongsInNumbered:.
	aCategory documentation: 'All change sets whose names start with a digit -- normally these will be the official updates to the system.'.
	ChangeSetCategories addCategoryItem: aCategory.

	aCategory := ChangeSetCategory new categoryName: #ProjectChangeSets.
	aCategory membershipSelector: #belongsInProjectChangeSets:.
	aCategory documentation: 'All change sets that are currently associated with projects present in the system right now.'.
	ChangeSetCategories addCategoryItem: aCategory.

	aCategory := ChangeSetCategory new categoryName: #ProjectsInRelease.
	aCategory membershipSelector: #belongsInProjectsInRelease:.
	aCategory documentation: 'All change sets belonging to projects that were shipped in the initial release of this version of Squeak'.
	ChangeSetCategories addCategoryItem: aCategory.

	aCategory := ChangeSetCategory new categoryName: #RecentUpdates.
	aCategory membershipSelector: #belongsInRecentUpdates:.
	aCategory documentation: 'Updates whose numbers are at or beyond the number I have designated as the earliest one to qualify as Recent'.
	ChangeSetCategories addCategoryItem: aCategory.

	ChangeSetCategories elementsInOrder do: [:anElem | anElem reconstituteList] ! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
noteChangeSetsInRelease
	"Freshly compute what the change sets in the release are; to be called manually just before a release"

	ChangeSetNamesInRelease := (Project allProjects collect: [:p | p name]) asSet asOrderedCollection.

"ChangeSorter noteChangeSetsInRelease"! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:42'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(ChangeSorter			prototypicalToolWindow		'Change Set'			'A tool that allows you to view and manipulate all the code changes in a single change set')
						forFlapNamed: 'Tools']! !

!ChangeSorter class methodsFor: 'class initialization' stamp: 'ar 9/27/2005 19:56'!
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] ! !


!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:33'!
allChangeSetNames
	^ self allChangeSets collect: [:c | c name]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:15'!
allChangeSets
	"Return the list of all current ChangeSets"

	^ChangeSet allChangeSets! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:34'!
allChangeSetsWithClass: class selector: selector
	class ifNil: [^ #()].
	^ self allChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'sd 11/20/2005 21:28'!
changeSet: aChangeSet containsClass: aClass
	| theClass |
	theClass := Smalltalk classNamed: aClass.
	theClass ifNil: [^ false].
	^ aChangeSet containsClass: theClass! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:15'!
changeSetNamed: aName
	"Return the change set of the given name, or nil if none found.  1/22/96 sw"
	^ChangeSet named: aName! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:16'!
changeSetsNamedSuchThat: nameBlock
	^ChangeSet changeSetsNamedSuchThat: nameBlock! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:16'!
existingOrNewChangeSetNamed: aName
	^ChangeSet existingOrNewChangeSetNamed: aName! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:16'!
gatherChangeSets		"ChangeSorter gatherChangeSets"
	^ChangeSet gatherChangeSets! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'sd 11/20/2005 21:28'!
highestNumberedChangeSet
	"ChangeSorter highestNumberedChangeSet"
	| aList |
	aList := (ChangeSet allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect:
		[:aString | aString initialIntegerOrNil]).
	^ (aList size > 0)
		ifTrue:
			[aList max]
		ifFalse:
			[nil]
! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'sd 11/20/2005 21:28'!
mostRecentChangeSetWithChangeForClass: class selector: selector
	| hits |
	hits := self allChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none].
	hits isEmpty ifTrue: [^ 'not in any change set'].
	^ 'recent cs: ', hits last name! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:16'!
promoteToTop: aChangeSet
	"Make aChangeSet the first in the list from now on"
	^ChangeSet promoteToTop: aChangeSet! !



!ChangeSorter class methodsFor: 'removing' stamp: 'sw 1/6/2001 06:21'!
deleteChangeSetsNumberedLowerThan: anInteger
	"Delete all changes sets whose names start with integers smaller than anInteger"

	ChangeSorter removeChangeSetsNamedSuchThat:
		[:aName | aName first isDigit and: [aName initialIntegerOrNil < anInteger]].

	"ChangeSorter deleteChangeSetsNumberedLowerThan: (ChangeSorter highestNumberedChangeSet name initialIntegerOrNil - 500)"
! !

!ChangeSorter class methodsFor: 'removing' stamp: 'ar 7/15/2005 21:16'!
removeChangeSet: aChangeSet
	"Remove the given changeSet.  Caller must assure that it's cool to do this"
	^ChangeSet removeChangeSet: aChangeSet! !

!ChangeSorter class methodsFor: 'removing' stamp: 'di 4/5/2001 21:12'!
removeChangeSetsNamedSuchThat: nameBlock
	(ChangeSorter changeSetsNamedSuchThat: nameBlock)
		do: [:cs | self removeChangeSet: cs]! !

!ChangeSorter class methodsFor: 'removing' stamp: 'sd 11/20/2005 21:28'!
removeEmptyUnnamedChangeSets
	"Remove all change sets that are empty, whose names start with Unnamed,
		and which are not nailed down by belonging to a Project."
	"ChangeSorter removeEmptyUnnamedChangeSets"
	| toGo |
	(toGo := (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed'])
		select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]])
		do: [:cs | self removeChangeSet: cs].
	self inform: toGo size printString, ' change set(s) removed.'! !


!ChangeSorter class methodsFor: 'services' stamp: 'sd 11/20/2005 21:28'!
assuredChangeSetNamed: aName
	"Answer a change set of the given name.  If one already exists, answer that, else create a new one and answer it."

	| existing |
	^ (existing := self changeSetNamed: aName)
		ifNotNil:
			[existing]
		ifNil:
			[self basicNewChangeSet: aName]! !

!ChangeSorter class methodsFor: 'services' stamp: 'sd 11/20/2005 21:28'!
browseChangeSetsWithClass: class selector: selector
	"Put up a menu comprising a list of change sets that hold changes for the given class and selector.  If the user selects one, open a single change-sorter onto it"

	| hits index |
	hits := self allChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none].
	hits isEmpty ifTrue: [^ self inform: class name, '.', selector , '
is not in any change set'].
	index := hits size == 1
		ifTrue:	[1]
		ifFalse:	[(UIManager default chooseFrom: (hits collect: [:cs | cs name])
					lines: #())].
	index = 0 ifTrue: [^ self].
	(ChangeSorter new myChangeSet: (hits at: index)) open.
! !

!ChangeSorter class methodsFor: 'services' stamp: 'sd 11/20/2005 21:28'!
browseChangeSetsWithSelector: aSelector
	"Put up a list of all change sets that contain an addition, deletion, or change of any method with the given selector"

	| hits index |
	hits := self allChangeSets select: 
		[:cs | cs hasAnyChangeForSelector: aSelector].
	hits isEmpty ifTrue: [^ self inform: aSelector , '
is not in any change set'].
	index := hits size == 1
		ifTrue:	[1]
		ifFalse:	[(UIManager default chooseFrom: (hits collect: [:cs | cs name])
					lines: #())].
	index = 0 ifTrue: [^ self].
	(ChangeSetBrowser new myChangeSet: (hits at: index)) open

"ChangeSorter browseChangeSetsWithSelector: #clearPenTrails"
! !

!ChangeSorter class methodsFor: 'services' stamp: 'sd 11/20/2005 21:28'!
buildAggregateChangeSet
	"Establish a change-set named Aggregate which bears the union of all the changes in all the existing change-sets in the system (other than any pre-existing Aggregate).  This can be useful when wishing to discover potential conflicts between a disk-resident change-set and an image.  Formerly very useful, now some of its unique contributions have been overtaken by new features"

	| aggregateChangeSet |
	aggregateChangeSet := self existingOrNewChangeSetNamed: 'Aggregate'.
	aggregateChangeSet clear.
	self allChangeSets do:
		[:aChangeSet | aChangeSet == aggregateChangeSet ifFalse:
			[aggregateChangeSet assimilateAllChangesFoundIn: aChangeSet]]

"ChangeSorter buildAggregateChangeSet"

	! !

!ChangeSorter class methodsFor: 'services' stamp: 'sw 6/6/2001 12:51'!
countOfChangeSetsWithClass: aClass andSelector: aSelector
	"Answer how many change sets record a change for the given class and selector"

	^ (self allChangeSetsWithClass: aClass selector: aSelector) size! !

!ChangeSorter class methodsFor: 'services' stamp: 'sw 6/6/2001 12:52'!
doesAnyChangeSetHaveClass: aClass andSelector: aSelector
	"Answer whether any known change set bears a change for the given class and selector"

	^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0! !

!ChangeSorter class methodsFor: 'services' stamp: 'sw 6/13/2001 00:56'!
prototypicalToolWindow
	"Answer a window representing a prototypical instance of the receiver"

	^ self new morphicWindow applyModelExtent! !

!ChangeSorter class methodsFor: 'services' stamp: 'sd 11/20/2005 21:28'!
recentUpdateMarker
	"Answer the number representing the threshold of what counts as 'recent' for an update number.  This allow you to use the RecentUpdates category in a ChangeSorter to advantage"

	^ RecentUpdateMarker ifNil: [RecentUpdateMarker := 0]! !

!ChangeSorter class methodsFor: 'services' stamp: 'sd 11/20/2005 21:28'!
recentUpdateMarker: aNumber
	"Set the recent update marker as indicated"

	^ RecentUpdateMarker := aNumber! !

!ChangeSorter class methodsFor: 'services' stamp: 'sd 11/20/2005 21:28'!
reorderChangeSets
	"Change the order of the change sets to something more convenient:
		First come the project changesets that come with the release.  These are mostly empty.
		Next come all numbered updates.
		Next come all remaining changesets
	In a ChangeSorter, they will appear in the reversed order."

	"ChangeSorter reorderChangeSets"

	| newHead newMid newTail |
	newHead := OrderedCollection new.
	newMid := OrderedCollection new.
	newTail := OrderedCollection new.
	ChangeSet allChangeSets do:
		[:aChangeSet |
			(self belongsInProjectsInRelease: aChangeSet)
				ifTrue:
					[newHead add: aChangeSet]
				ifFalse:
					[(self belongsInNumbered: aChangeSet)
						ifTrue:
							[newMid add: aChangeSet]
						ifFalse:
							[newTail add: aChangeSet]]].
	ChangeSet allChangeSets: newHead, newMid, newTail.
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! !

!ChangeSorter class methodsFor: 'services' stamp: 'ar 7/15/2005 21:17'!
secondaryChangeSet
	^ChangeSet secondaryChangeSet! !


!ChangeSorter class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'!
fileOutChangeSetsNamed: nameList
	"File out the list of change sets whose names are provided"
     "ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')"

	| notFound aChangeSet infoString empty |
	notFound := OrderedCollection new.
	empty := OrderedCollection new.
	nameList do:
		[:aName | (aChangeSet := self changeSetNamed: aName)
			ifNotNil:
				[aChangeSet isEmpty
					ifTrue:
						[empty add: aName]
					ifFalse:
						[aChangeSet fileOut]]
			ifNil:
				[notFound add: aName]].

	infoString := (nameList size - notFound size) printString, ' change set(s) filed out'.
	notFound size > 0 ifTrue:
		[infoString := infoString, '

', notFound size printString, ' change set(s) not found:'.
		notFound do:
			[:aName | infoString := infoString, '
', aName]].
	empty size > 0 ifTrue:
		[infoString := infoString, '
', empty size printString, ' change set(s) were empty:'.
		empty do:
			[:aName | infoString := infoString, '
', aName]].

	self inform: infoString! !


!ChangeSorter class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:09'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name  wording: 'Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that lets you see the code for one change set at a time.'! !
MessageSet subclass: #ChangedMessageSet
	instanceVariableNames: 'changeSet'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!ChangedMessageSet commentStamp: '<historical>' prior: 0!
A ChangedMessageSet is a message set associated with a change-set; it bears an entry for every method added or changed in the change set, as well as for every class-comment of which the change-set bears a note.!


!ChangedMessageSet methodsFor: 'acceptance' stamp: 'md 2/20/2006 18:42'!
contents: aString notifying: aController
	"Accept the string as new source for the current method, and make certain the annotation pane gets invalidated"

	| existingSelector existingClass superResult newSelector |
	existingSelector := self selectedMessageName.
	existingClass := self selectedClassOrMetaClass.

	superResult := super contents: aString notifying: aController.
	superResult ifTrue:  "succeeded"
		[newSelector := existingClass parserClass new parseSelector: aString.
		newSelector ~= existingSelector
			ifTrue:   "Selector changed -- maybe an addition"
				[self reformulateList.
				self changed: #messageList.
				self messageList doWithIndex:
					[:aMethodReference :anIndex |
						(aMethodReference actualClass == existingClass and:
									[aMethodReference methodSymbol == newSelector])
							ifTrue:
								[self messageListIndex: anIndex]]]].
	^ superResult! !


!ChangedMessageSet methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
changeSet: aChangeSet
	changeSet := aChangeSet! !


!ChangedMessageSet methodsFor: 'message list' stamp: 'sw 1/28/2001 20:59'!
growable
	"Answer whether the receiver can be changed by manual additions & deletions"

	^ false! !


!ChangedMessageSet methodsFor: 'reformulation' stamp: 'sw 6/26/2001 11:20'!
reformulateList
	"Reformulate the message list of the receiver"

	self initializeMessageList: (changeSet changedMessageListAugmented select: 
		[:each | each isValid])
! !

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

ChangedMessageSet class
	instanceVariableNames: ''!

!ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'!
openFor: aChangeSet
	"Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message-list consists of all the methods in aChangeSet.  After any method submission, the message list is refigured, making it plausibly dynamic"

	| messageSet |

	messageSet := aChangeSet changedMessageListAugmented select: [ :each | each isValid].
	self 
		openMessageList: messageSet 
		name: 'Methods in Change Set ', aChangeSet name
		autoSelect: nil
		changeSet: aChangeSet! !

!ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'!
openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet
	| messageSet |

	messageSet := self messageList: messageList.
	messageSet changeSet: aChangeSet.
	messageSet autoSelectString: autoSelectString.
	Smalltalk isMorphic
		ifTrue: [self openAsMorph: messageSet name: labelString]
		ifFalse: [ScheduledControllers scheduleActive:  (self open: messageSet name: labelString)]! !
Magnitude subclass: #Character
	instanceVariableNames: 'value'
	classVariableNames: 'CharacterTable ClassificationTable LetterBits LowercaseBit UppercaseBit'
	poolDictionaries: ''
	category: 'Collections-Strings'!
!Character commentStamp: 'ar 4/9/2005 22:35' prior: 0!
I represent a character by storing its associated Unicode. The first 256 characters are created uniquely, so that all instances of latin1 characters ($R, for example) are identical.

	The code point is based on Unicode.  Since Unicode is 21-bit wide character set, we have several bits available for other information.  As the Unicode Standard  states, a Unicode code point doesn't carry the language information.  This is going to be a problem with the languages so called CJK (Chinese, Japanese, Korean.  Or often CJKV including Vietnamese).  Since the characters of those languages are unified and given the same code point, it is impossible to display a bare Unicode code point in an inspector or such tools.  To utilize the extra available bits, we use them for identifying the languages.  Since the old implementation uses the bits to identify the character encoding, the bits are sometimes called "encoding tag" or neutrally "leading char", but the bits rigidly denotes the concept of languages.

	The other languages can have the language tag if you like.  This will help to break the large default font (font set) into separately loadable chunk of fonts.  However, it is open to the each native speakers and writers to decide how to define the character equality, since the same Unicode code point may have different language tag thus simple #= comparison may return false.

I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.!


!Character methodsFor: 'accessing'!
asciiValue
	"Answer the value of the receiver that represents its ascii encoding."

	^value! !

!Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:11'!
charCode

	^ (value bitAnd: 16r3FFFFF).
! !

!Character methodsFor: 'accessing' stamp: 'RAH 4/25/2000 19:49'!
codePoint
	"Return the encoding value of the receiver."
	#Fundmntl.
	^ self asciiValue! !

!Character methodsFor: 'accessing' stamp: 'yo 12/1/2003 19:30'!
digitValue
	"Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 
	otherwise. This is used to parse literal numbers of radix 2-36."

	^ (EncodedCharSet charsetAt: self leadingChar) digitValue: self.
! !

!Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:14'!
leadingChar

	^ (value bitAnd: (16r3FC00000)) bitShift: -22.
! !


!Character methodsFor: 'comparing' stamp: 'md 8/2/2005 18:21'!
sameAs: aCharacter 
	"Answer whether the receiver is equal to aCharacter, ignoring case"
	^ (self asLowercase = aCharacter asLowercase)	! !

!Character methodsFor: 'comparing'!
< aCharacter 
	"Answer true if the receiver's value < aCharacter's value."

	^self asciiValue < aCharacter asciiValue! !

!Character methodsFor: 'comparing' stamp: 'ar 4/9/2005 21:48'!
= aCharacter 
	"Primitive. Answer true if the receiver and the argument are the same
	object (have the same object pointer) and false otherwise. Optional. See
	Object documentation whatIsAPrimitive."

	^ self == aCharacter or:[
		aCharacter isCharacter and: [self asciiValue = aCharacter asciiValue]]! !

!Character methodsFor: 'comparing'!
> aCharacter 
	"Answer true if the receiver's value > aCharacter's value."

	^self asciiValue > aCharacter asciiValue! !

!Character methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^value! !


!Character methodsFor: 'converting'!
asCharacter
	"Answer the receiver itself."

	^self! !

!Character methodsFor: 'converting' stamp: 'ls 9/5/1998 01:18'!
asIRCLowercase
	"convert to lowercase, using IRC's rules"

	self == $[ ifTrue: [ ^ ${ ].
	self == $] ifTrue: [ ^ $} ].
	self == $\ ifTrue: [ ^ $| ].

	^self asLowercase! !

!Character methodsFor: 'converting'!
asInteger
	"Answer the value of the receiver."

	^value! !

!Character methodsFor: 'converting' stamp: 'yo 8/16/2004 11:35'!
asLowercase
	"If the receiver is uppercase, answer its matching lowercase Character."
	"A tentative implementation.  Eventually this should consult the Unicode table."

	| v |
	v _ self charCode.
	(((8r101 <= v and: [v <= 8r132]) or: [16rC0 <= v and: [v <= 16rD6]]) or: [16rD8 <= v and: [v <= 16rDE]])
		ifTrue: [^ Character value: value + 8r40]
		ifFalse: [^ self]! !

!Character methodsFor: 'converting' stamp: 'sma 3/11/2000 17:21'!
asString
	^ String with: self! !

!Character methodsFor: 'converting' stamp: 'raa 5/26/2001 09:54'!
asSymbol 
	"Answer a Symbol consisting of the receiver as the only element."

	^Symbol internCharacter: self! !

!Character methodsFor: 'converting' stamp: 'tk 9/4/2000 12:05'!
asText
	^ self asString asText! !

!Character methodsFor: 'converting' stamp: 'ar 4/9/2005 21:51'!
asUnicode

	| table charset v |
	self leadingChar = 0 ifTrue: [^ value].
	charset _ EncodedCharSet charsetAt: self leadingChar.
	charset isCharset ifFalse: [^ self charCode].
	table _ charset ucsTable.
	table isNil ifTrue: [^ 16rFFFD].

	v _ table at: self charCode + 1.
	v = -1 ifTrue: [^ 16rFFFD].

	^ v.
! !

!Character methodsFor: 'converting' stamp: 'ar 4/9/2005 22:25'!
asUnicodeChar
	"@@@ FIXME: Make this use asUnicode and move it to its lonely sender @@@"
	| table charset v |
	self leadingChar = 0 ifTrue: [^ value].
	charset _ EncodedCharSet charsetAt: self leadingChar.
	charset isCharset ifFalse: [^ self].
	table _ charset ucsTable.
	table isNil ifTrue: [^ Character value: 16rFFFD].

	v _ table at: self charCode + 1.
	v = -1 ifTrue: [^ Character value: 16rFFFD].

	^ Character leadingChar: charset unicodeLeadingChar code: v.! !

!Character methodsFor: 'converting' stamp: 'yo 8/16/2004 11:34'!
asUppercase
	"If the receiver is lowercase, answer its matching uppercase Character."
	"A tentative implementation.  Eventually this should consult the Unicode table."	

	| v |
	v _ self charCode.
	(((8r141 <= v and: [v <= 8r172]) or: [16rE0 <= v and: [v <= 16rF6]]) or: [16rF8 <= v and: [v <= 16rFE]])
		ifTrue: [^ Character value: value - 8r40]
		ifFalse: [^ self]
! !

!Character methodsFor: 'converting' stamp: 'yo 8/11/2003 21:18'!
basicSqueakToIso
	| asciiValue |

	value < 128 ifTrue: [^ self].
	value > 255 ifTrue: [^ self].
	asciiValue _ #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 253 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 254 255 256 ) at: self asciiValue - 127.
	^ Character value: asciiValue.
! !

!Character methodsFor: 'converting' stamp: 'ar 4/9/2005 22:15'!
isoToSqueak 
	^self "no longer needed"! !

!Character methodsFor: 'converting' stamp: 'ar 4/10/2005 16:05'!
macToSqueak
	"Convert the receiver from MacRoman to Squeak encoding"
	| asciiValue |
	value < 128 ifTrue: [^ self].
	value > 255 ifTrue: [^ self].
	asciiValue _ #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 255 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 253 254 ) at: self asciiValue - 127.
	^ Character value: asciiValue.
! !

!Character methodsFor: 'converting' stamp: 'ar 4/9/2005 22:16'!
squeakToIso
	^self "no longer needed"! !

!Character methodsFor: 'converting' stamp: 'ar 4/10/2005 16:05'!
squeakToMac
	"Convert the receiver from Squeak to MacRoman encoding."
	value < 128 ifTrue: [^ self].
	value > 255 ifTrue: [^ self].
	^ Character value: (#(
		173 176 226 196 227 201 160 224 246 228 178 220 206 179 182 183	"80-8F"
		184 212 213 210 211 165 208 209 247 170 185 221 207 186 189 217	"90-9F"
		202 193 162 163 219 180 195 164 172 169 187 199 194 197 168 248	"A0-AF"
		161 177 198 215 171 181 166 225 252 218 188 200 222 223 240 192 	"B0-BF"
		203 231 229 204 128 129 174 130 233 131 230 232 237 234 235 236 	"C0-CF"
		245 132 241 238 239 205 133 249 175 244 242 243 134 250 251 167	"D0-DF"
		136 135 137 139 138 140 190 141 143 142 144 145 147 146 148 149	"E0-EF"
		253 150 152 151 153 155 154 214 191 157 156 158 159 254 255 216	"F0-FF"
	) at: value - 127)
! !

!Character methodsFor: 'converting'!
to: other
	"Answer with a collection in ascii order -- $a to: $z"
	^ (self asciiValue to: other asciiValue) collect:
				[:ascii | Character value: ascii]! !


!Character methodsFor: 'copying' stamp: 'tk 12/9/2000 11:46'!
clone
	"Answer with the receiver, because Characters are unique."! !

!Character methodsFor: 'copying'!
copy
	"Answer with the receiver because Characters are unique."! !

!Character methodsFor: 'copying'!
deepCopy
	"Answer with the receiver because Characters are unique."! !

!Character methodsFor: 'copying' stamp: 'tk 1/7/1999 16:50'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied."! !


!Character methodsFor: 'object fileIn' stamp: 'tk 1/17/2000 11:27'!
comeFullyUpOnReload: smartRefStream
	"Use existing an Character.  Don't use the new copy."

	^ self class value: value! !

!Character methodsFor: 'object fileIn' stamp: 'tk 2/16/2001 14:52'!
objectForDataStream: refStrm
	"I am being collected for inclusion in a segment.  Do not include Characters!!  Let them be in outPointers."

	refStrm insideASegment
		ifFalse: ["Normal use" ^ self]
		ifTrue: ["recording objects to go into an ImageSegment"			
			"remove it from references.  Do not trace."
			refStrm references removeKey: self ifAbsent: [].
			^ nil]
! !


!Character methodsFor: 'printing' stamp: 'ar 4/9/2005 21:53'!
hex
	^value hex! !

!Character methodsFor: 'printing'!
isLiteral

	^true! !

!Character methodsFor: 'printing' stamp: 'lr 11/21/2005 17:40'!
printOn: aStream
	| name |
	value > 32
		ifTrue: [ aStream nextPut: $$; nextPut: self ]
		ifFalse: [
			name := self class constantNameFor: self.
			name notNil
				ifTrue: [ aStream nextPutAll: self class name; space; nextPutAll: name ]
				ifFalse: [ aStream nextPutAll: self class name; nextPutAll: ' value: '; print: value ] ].! !

!Character methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:04'!
printOnStream: aStream

	aStream print:'$', (String with:self).! !

!Character methodsFor: 'printing' stamp: 'ar 4/9/2005 22:30'!
storeBinaryOn: aStream
	"Store the receiver on a binary (file) stream"
	value < 256 
		ifTrue:[aStream basicNextPut: self]
		ifFalse:[Stream nextInt32Put: value].! !

!Character methodsFor: 'printing' stamp: 'lr 11/21/2005 17:40'!
storeOn: aStream
	"Common character literals are preceded by '$', however special need to be encoded differently: for some this might be done by using one of the shortcut constructor methods for the rest we have to create them by ascii-value."

	| name |
	value > 32
		ifTrue: [ aStream nextPut: $$; nextPut: self ]
		ifFalse: [
			name := self class constantNameFor: self.
			name notNil
				ifTrue: [ aStream nextPutAll: self class name; space; nextPutAll: name ]
				ifFalse: [
					aStream 
						nextPut: $(; nextPutAll: self class name; 
						nextPutAll: ' value: '; print: value; nextPut: $) ] ].! !


!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:57'!
canBeGlobalVarInitial

	^ (EncodedCharSet charsetAt: self leadingChar) canBeGlobalVarInitial: self.
! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:58'!
canBeNonGlobalVarInitial

	^ (EncodedCharSet charsetAt: self leadingChar) canBeNonGlobalVarInitial: self.
! !

!Character methodsFor: 'testing'!
isAlphaNumeric
	"Answer whether the receiver is a letter or a digit."

	^self isLetter or: [self isDigit]! !

!Character methodsFor: 'testing' stamp: 'yo 8/28/2002 13:42'!
isCharacter

	^ true.
! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'!
isDigit

	^ (EncodedCharSet charsetAt: self leadingChar) isDigit: self.
! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'!
isLetter

	^ (EncodedCharSet charsetAt: self leadingChar) isLetter: self.
! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'!
isLowercase

	^ (EncodedCharSet charsetAt: self leadingChar) isLowercase: self.
! !

!Character methodsFor: 'testing' stamp: 'yo 8/27/2002 15:18'!
isOctetCharacter

	^ value < 256.
! !

!Character methodsFor: 'testing' stamp: 'yo 7/29/2005 15:21'!
isSafeForHTTP
	"whether a character is 'safe', or needs to be escaped when used, eg, in a URL"
	"[GG]  See http://www.faqs.org/rfcs/rfc1738.html. ~ is unsafe and has been removed"
	^ self charCode < 128
		and: [self isAlphaNumeric
				or: ['.-_' includes: (Character value: self charCode)]]! !

!Character methodsFor: 'testing'!
isSeparator
	"Answer whether the receiver is one of the separator characters--space, 
	cr, tab, line feed, or form feed."

	value = 32 ifTrue: [^true].	"space"
	value = 13 ifTrue: [^true].	"cr"
	value = 9 ifTrue: [^true].	"tab"
	value = 10 ifTrue: [^true].	"line feed"
	value = 12 ifTrue: [^true].	"form feed"
	^false! !

!Character methodsFor: 'testing' stamp: 'di 4/3/1999 00:38'!
isSpecial
	"Answer whether the receiver is one of the special characters"

	^'+-/\*~<>=@,%|&?!!' includes: self! !

!Character methodsFor: 'testing' stamp: 'ar 4/12/2005 14:09'!
isTraditionalDomestic
	"Yoshiki's note about #isUnicode says:
		[This method] is for the backward compatibility when we had domestic
		traditional encodings for CJK languages.  To support loading the
		projects in traditional domestic encodings (From Nihongo4), and load
		some changesets.  Once we decided to get rid of classes like JISX0208
		from the EncodedCharSet table, the need for isUnicode will not be
		necessary.
	I (Andreas) decided to change the name from isUnicode to #isTraditionalDomestic
	since I found isUnicode to be horribly confusing (how could the character *not*
	be Unicode after all?). But still, we should remove this method in due time."
	^ ((EncodedCharSet charsetAt: self leadingChar) isKindOf: LanguageEnvironment class) not! !

!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'!
isUppercase

	^ (EncodedCharSet charsetAt: self leadingChar) isUppercase: self.
! !

!Character methodsFor: 'testing'!
isVowel
	"Answer whether the receiver is one of the vowels, AEIOU, in upper or 
	lower case."

	^'AEIOU' includes: self asUppercase! !

!Character methodsFor: 'testing'!
tokenish
	"Answer whether the receiver is a valid token-character--letter, digit, or 
	colon."

	^self isLetter or: [self isDigit or: [self = $:]]! !


!Character methodsFor: '*packageinfo-base' stamp: 'ab 5/31/2003 17:15'!
escapeEntities
	#($< '&lt;' $> '&gt;' $& '&amp;') pairsDo:
		[:k :v |
		self = k ifTrue: [^ v]].
	^ String with: self! !


!Character methodsFor: 'private' stamp: 'ar 4/9/2005 22:18'!
setValue: newValue
	value ifNotNil:[^self error:'Characters are immutable'].
	value _ newValue.! !

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

Character class
	instanceVariableNames: ''!

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'!
arrowDown
	^ self value: 31! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'!
arrowLeft
	^ self value: 28! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'!
arrowRight
	^ self value: 29! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'!
arrowUp
	^ self value: 30! !

!Character class methodsFor: 'accessing untypeable characters'!
backspace
	"Answer the Character representing a backspace."

	^self value: 8! !

!Character class methodsFor: 'accessing untypeable characters'!
cr
	"Answer the Character representing a carriage return."

	^self value: 13! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'!
delete
	^ self value: 127! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'!
end
	^ self value: 4! !

!Character class methodsFor: 'accessing untypeable characters'!
enter
	"Answer the Character representing enter."

	^self value: 3! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'ls 9/2/1999 08:06'!
escape
	"Answer the ASCII ESC character"

	^self value: 27! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'sma 3/15/2000 22:33'!
euro
	"The Euro currency sign, that E with two dashes. The key code is a wild guess"

	^ Character value: 219! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'!
home
	^ self value: 1! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'!
insert
	^ self value: 5! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'ls 9/8/1998 22:15'!
lf
	"Answer the Character representing a linefeed."

	^self value: 10! !

!Character class methodsFor: 'accessing untypeable characters'!
linefeed
	"Answer the Character representing a linefeed."

	^self value: 10! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'sma 3/11/2000 20:47'!
nbsp
	"non-breakable space."

	^ Character value: 202! !

!Character class methodsFor: 'accessing untypeable characters'!
newPage
	"Answer the Character representing a form feed."

	^self value: 12! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'!
pageDown
	^ self value: 12! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'!
pageUp
	^ self value: 11! !

!Character class methodsFor: 'accessing untypeable characters'!
space
	"Answer the Character representing a space."

	^self value: 32! !

!Character class methodsFor: 'accessing untypeable characters'!
tab
	"Answer the Character representing a tab."

	^self value: 9! !


!Character class methodsFor: 'class initialization' stamp: 'yo 10/4/2003 16:03'!
initialize
	"Create the table of unique Characters."
"	self initializeClassificationTable"! !

!Character class methodsFor: 'class initialization' stamp: 'dgd 8/24/2003 15:10'!
initializeClassificationTable
	"
	Initialize the classification table. The classification table is a
	compact encoding of upper and lower cases of characters with

		- bits 0-7: The lower case value of this character.
		- bits 8-15: The upper case value of this character.
		- bit 16: lowercase bit (e.g., isLowercase == true)
		- bit 17: uppercase bit (e.g., isUppercase == true)

	"
	| ch1 ch2 |

	LowercaseBit := 1 bitShift: 16.
	UppercaseBit := 1 bitShift: 17.

	"Initialize the letter bits (e.g., isLetter == true)"
	LetterBits := LowercaseBit bitOr: UppercaseBit.

	ClassificationTable := Array new: 256.
	"Initialize the defaults (neither lower nor upper case)"
	0 to: 255 do:[:i|
		ClassificationTable at: i+1 put: (i bitShift: 8) + i.
	].

	"Initialize character pairs (upper-lower case)"
	#(
		"Basic roman"
		($A $a) 	($B $b) 	($C $c) 	($D $d) 
		($E $e) 	($F $f) 	($G $g) 	($H $h) 
		($I $i) 		($J $j) 		($K $k) 	($L $l) 
		($M $m)	($N $n)	($O $o)	($P $p) 
		($Q $q) 	($R $r) 	($S $s) 	($T $t) 
		($U $u)	($V $v)	($W $w)	($X $x)
		($Y $y)	($Z $z)
		"International"
		($Ä $ä)	($Å $å)	($Ç $ç)	($É $é)
		($Ñ $ñ)	($Ö $ö)	($Ü $ü)	($À $à)
		($à $ã)	($Õ $õ)	($Œ $œ)	($Æ $æ)
		"International - Spanish"
		($Á $á)	($Í $í)		($Ó $ó)	($Ú $ú)
		"International - PLEASE CHECK"
		($È $è)	($Ì $ì)		($Ò $ò)	($Ù $ù)
		($Ë $ë)	($Ï $ï)
		($Â $â)	($Ê $ê)	($Î $î)	($Ô $ô)	($Û $û)
	) do:[:pair|
		ch1 := pair first asciiValue.
		ch2 := pair last asciiValue.
		ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch2 + UppercaseBit.
		ClassificationTable at: ch2+1 put: (ch1 bitShift: 8) + ch2 + LowercaseBit.
	].

	"Initialize a few others for which we only have lower case versions."
	#($ß $Ø $ø $ÿ) do:[:char|
		ch1 := char asciiValue.
		ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch1 + LowercaseBit.
	].
! !


!Character class methodsFor: 'constants' stamp: 'rhi 9/8/2000 14:57'!
alphabet
	"($a to: $z) as: String"

	^ 'abcdefghijklmnopqrstuvwxyz' copy! !

!Character class methodsFor: 'constants'!
characterTable
	"Answer the class variable in which unique Characters are stored."

	^CharacterTable! !


!Character class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:36'!
allByteCharacters
	"Answer all the characters that can be encoded in a byte"
	^ (0 to: 255) collect: [:v | Character value: v]

	
! !

!Character class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:37'!
allCharacters
	"This name is obsolete since only the characters that will fit in a byte can be queried"
	^self allByteCharacters
	
! !

!Character class methodsFor: 'instance creation' stamp: 'RAH 4/25/2000 19:49'!
codePoint: integer 
	"Return a character whose encoding value is integer."
	#Fundmntl.
	(0 > integer or: [255 < integer])
		ifTrue: [self error: 'parameter out of range 0..255'].
	^ CharacterTable at: integer + 1! !

!Character class methodsFor: 'instance creation'!
digitValue: x 
	"Answer the Character whose digit value is x. For example, answer $9 for 
	x=9, $0 for x=0, $A for x=10, $Z for x=35."

	| index |
	index _ x asInteger.
	^CharacterTable at: 
		(index < 10
			ifTrue: [48 + index]
			ifFalse: [55 + index])
		+ 1! !

!Character class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:24'!
leadingChar: leadChar code: code

	code >= 16r400000 ifTrue: [
		self error: 'code is out of range'.
	].
	leadChar >= 256 ifTrue: [
		self error: 'lead is out of range'.
	].

	^self value: (leadChar bitShift: 22) + code.! !

!Character class methodsFor: 'instance creation'!
new
	"Creating new characters is not allowed."

	self error: 'cannot create new characters'! !

!Character class methodsFor: 'instance creation'!
separators
	^ #(32 "space"
		13 "cr"
		9 "tab"
		10 "line feed"
		12 "form feed")
		collect: [:v | Character value: v]

	
! !

!Character class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:19'!
value: anInteger 
	"Answer the Character whose value is anInteger."

	anInteger > 255 ifTrue: [^self basicNew setValue: anInteger].
	^ CharacterTable at: anInteger + 1.
! !


!Character class methodsFor: 'private' stamp: 'lr 11/21/2005 17:24'!
constantNameFor: aCharacter
	^ self constantNames
		detect: [ :each | (self perform: each) = aCharacter ]
		ifNone: [ nil ].! !

!Character class methodsFor: 'private' stamp: 'lr 11/21/2005 17:33'!
constantNames
	^ #( backspace cr delete escape lf newPage space tab ).! !
Rectangle subclass: #CharacterBlock
	instanceVariableNames: 'stringIndex text textLine'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Text'!
!CharacterBlock commentStamp: '<historical>' prior: 0!
My instances contain information about displayed characters. They are used to return the results of methods:
	Paragraph characterBlockAtPoint: aPoint and
	Paragraph characterBlockForIndex: stringIndex.
Any recomposition or movement of a Paragraph can make the instance obsolete.!


!CharacterBlock methodsFor: 'accessing' stamp: 'di 6/7/2000 17:33'!
copy
	"Overridden because Rectangle does a deepCopy, which goes nuts with the text"

	^ self clone! !

!CharacterBlock methodsFor: 'accessing'!
stringIndex
	"Answer the position of the receiver in the string it indexes."

	^stringIndex! !

!CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'!
textLine
	^ textLine! !

!CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'!
textLine: aLine
	textLine _ aLine! !


!CharacterBlock methodsFor: 'comparing'!
< aCharacterBlock 
	"Answer whether the string index of the receiver precedes that of 
	aCharacterBlock."

	^stringIndex < aCharacterBlock stringIndex! !

!CharacterBlock methodsFor: 'comparing'!
<= aCharacterBlock 
	"Answer whether the string index of the receiver does not come after that 
	of aCharacterBlock."

	^(self > aCharacterBlock) not! !

!CharacterBlock methodsFor: 'comparing'!
= aCharacterBlock

	self species = aCharacterBlock species
		ifTrue: [^stringIndex = aCharacterBlock stringIndex]
		ifFalse: [^false]! !

!CharacterBlock methodsFor: 'comparing'!
> aCharacterBlock 
	"Answer whether the string index of the receiver comes after that of 
	aCharacterBlock."

	^aCharacterBlock < self! !

!CharacterBlock methodsFor: 'comparing'!
>= aCharacterBlock 
	"Answer whether the string index of the receiver does not precede that of 
	aCharacterBlock."

	^(self < aCharacterBlock) not! !

!CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'!
max: aCharacterBlock
	aCharacterBlock ifNil:[^self].
	^aCharacterBlock > self
		ifTrue:[ aCharacterBlock]
		ifFalse:[self].! !

!CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'!
min: aCharacterBlock
	aCharacterBlock ifNil:[^self].
	^aCharacterBlock < self
		ifTrue:[ aCharacterBlock]
		ifFalse:[self].! !


!CharacterBlock methodsFor: 'printing' stamp: 'di 12/2/97 19:15'!
printOn: aStream

	aStream nextPutAll: 'a CharacterBlock with index '.
	stringIndex printOn: aStream.
	(text ~~ nil and: [text size> 0 and: [stringIndex between: 1 and: text size]])
		ifTrue: [aStream nextPutAll: ' and character '.
				(text at: stringIndex) printOn: aStream].
	aStream nextPutAll: ' and rectangle '.
	super printOn: aStream.
	textLine ifNotNil: [aStream cr; nextPutAll: ' in '.
				textLine printOn: aStream].
! !


!CharacterBlock methodsFor: 'private'!
moveBy: aPoint 
	"Change the corner positions of the receiver so that its area translates by 
	the amount defined by the argument, aPoint."

	origin _ origin + aPoint.
	corner _ corner + aPoint! !

!CharacterBlock methodsFor: 'private' stamp: 'di 10/23/97 22:33'!
stringIndex: anInteger text: aText topLeft: topLeft extent: extent

	stringIndex _ anInteger.
	text _ aText.
	super setOrigin: topLeft corner: topLeft + extent ! !
CharacterScanner subclass: #CharacterBlockScanner
	instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Text'!
!CharacterBlockScanner commentStamp: '<historical>' prior: 0!
My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.!


!CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 19:14'!
characterBlockAtPoint: aPoint in: aParagraph
	"Answer a CharacterBlock for character in aParagraph at point aPoint. It 
	is assumed that aPoint has been transformed into coordinates appropriate 
	to the text's destination form rectangle and the composition rectangle."

	self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle.
	characterPoint _ aPoint.
	^self buildCharacterBlockIn: aParagraph! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'nk 11/22/2004 14:32'!
characterBlockAtPoint: aPoint index: index in: textLine
	"This method is the Morphic characterBlock finder.  It combines
	MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:"
	| runLength lineStop done stopCondition |
	line := textLine.
	rightMargin := line rightMargin.
	lastIndex := line first.
	self setStopConditions.		"also sets font"
	characterIndex := index.  " == nil means scanning for point"
	characterPoint := aPoint.
	(characterPoint isNil or: [characterPoint y > line bottom])
		ifTrue: [characterPoint := line bottomRight].
	(text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left])
				or: [characterIndex notNil and: [characterIndex < line first]]])
		ifTrue:	[^ (CharacterBlock new stringIndex: line first text: text
					topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid)
					textLine: line].
	destX := leftMargin := line leftMarginForAlignment: alignment.
	destY := line top.
	runLength := text runLengthFor: line first.
	characterIndex
		ifNotNil:	[lineStop := characterIndex  "scanning for index"]
		ifNil:	[lineStop := line last  "scanning for point"].
	runStopIndex := lastIndex + (runLength - 1) min: lineStop.
	lastCharacterExtent := 0 @ line lineHeight.
	spaceCount := 0.

	done  := false.
	[done] whileFalse:
		[stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.
		"see setStopConditions for stopping conditions for character block 	operations."
		self lastCharacterExtentSetX: (specialWidth
			ifNil: [font widthOf: (text at: lastIndex)]
			ifNotNil: [specialWidth]).
		(self perform: stopCondition) ifTrue:
			[characterIndex
				ifNil: [
					"Result for characterBlockAtPoint: "
					(stopCondition ~~ #cr and: [ lastIndex == line last
						and: [ aPoint x > ((characterPoint x) + (lastCharacterExtent x / 2)) ]])
							ifTrue: [ "Correct for right half of last character in line"
								^ (CharacterBlock new stringIndex: lastIndex + 1
										text: text
										topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0)
										extent:  0 @ lastCharacterExtent y)
									textLine: line ].
						^ (CharacterBlock new stringIndex: lastIndex
							text: text topLeft: characterPoint + (font descentKern @ 0)
							extent: lastCharacterExtent - (font baseKern @ 0))
									textLine: line]
				ifNotNil: ["Result for characterBlockForIndex: "
						^ (CharacterBlock new stringIndex: characterIndex
							text: text topLeft: characterPoint + ((font descentKern) - kern @ 0)
							extent: lastCharacterExtent)
									textLine: line]]]! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 19:14'!
characterBlockForIndex: targetIndex in: aParagraph 
	"Answer a CharacterBlock for character in aParagraph at targetIndex. The 
	coordinates in the CharacterBlock will be appropriate to the intersection 
	of the destination form rectangle and the composition rectangle."

	self 
		initializeFromParagraph: aParagraph 
		clippedBy: aParagraph clippingRectangle.
	characterIndex _ targetIndex.
	characterPoint _ 
		aParagraph rightMarginForDisplay @ 
			(aParagraph topAtLineIndex: 
				(aParagraph lineIndexOfCharacterIndex: characterIndex)).
	^self buildCharacterBlockIn: aParagraph! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'hmm 2/2/2001 15:07'!
indentationLevel: anInteger
	super indentationLevel: anInteger.
	nextLeftMargin _ leftMargin.
	indentationLevel timesRepeat: [
		nextLeftMargin _ textStyle nextTabXFrom: nextLeftMargin
					leftMargin: leftMargin
					rightMargin: rightMargin]! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 19:27'!
placeEmbeddedObject: anchoredMorph
	"Workaround: The following should really use #textAnchorType"
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	specialWidth _ anchoredMorph width.
	^ true! !


!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'RAA 2/25/2001 14:55'!
cr 
	"Answer a CharacterBlock that specifies the current location of the mouse 
	relative to a carriage return stop condition that has just been 
	encountered. The ParagraphEditor convention is to denote selections by 
	CharacterBlocks, sometimes including the carriage return (cursor is at 
	the end) and sometimes not (cursor is in the middle of the text)."

	((characterIndex ~= nil
		and: [characterIndex > text size])
			or: [(line last = text size)
				and: [(destY + line lineHeight) < characterPoint y]])
		ifTrue:	["When off end of string, give data for next character"
				destY _ destY +  line lineHeight.
				lastCharacter _ nil.
				characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ destY.
				lastIndex _ lastIndex + 1.
				self lastCharacterExtentSetX: 0.
				^ true].
		lastCharacter _ CR.
		characterPoint _ destX @ destY.
		self lastCharacterExtentSetX: rightMargin - destX.
		^true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'!
crossedX
	"Text display has wrapping. The scanner just found a character past the x 
	location of the cursor. We know that the cursor is pointing at a character 
	or before one."

	| leadingTab currentX |
	characterIndex == nil ifFalse: [
		"If the last character of the last line is a space,
		and it crosses the right margin, then locating
		the character block after it is impossible without this hack."
		characterIndex > text size ifTrue: [
			lastIndex _ characterIndex.
			characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight).
			^true]].
	characterPoint x <= (destX + (lastCharacterExtent x // 2))
		ifTrue:	[lastCharacter _ (text at: lastIndex).
				characterPoint _ destX @ destY.
				^true].
	lastIndex >= line last 
		ifTrue:	[lastCharacter _ (text at: line last).
				characterPoint _ destX @ destY.
				^true].

	"Pointing past middle of a character, return the next character."
	lastIndex _ lastIndex + 1.
	lastCharacter _ text at: lastIndex.
	currentX _ destX + lastCharacterExtent x + kern.
	self lastCharacterExtentSetX: (font widthOf: lastCharacter).
	characterPoint _ currentX @ destY.
	lastCharacter = Space ifFalse: [^ true].

	"Yukky if next character is space or tab."
	alignment = Justified ifTrue:
		[self lastCharacterExtentSetX:
			(lastCharacterExtent x + 	(line justifiedPadFor: (spaceCount + 1))).
		^ true].

	true ifTrue: [^ true].
	"NOTE:  I find no value to the following code, and so have defeated it - DI"

	"See tabForDisplay for illumination on the following awfulness."
	leadingTab _ true.
	line first to: lastIndex - 1 do:
		[:index | (text at: index) ~= Tab ifTrue: [leadingTab _ false]].
	(alignment ~= Justified or: [leadingTab])
		ifTrue:	[self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX
					leftMargin: leftMargin rightMargin: rightMargin) -
						currentX]
		ifFalse:	[self lastCharacterExtentSetX:  (((currentX + (textStyle tabWidth -
						(line justifiedTabDeltaFor: spaceCount))) -
							currentX) max: 0)].
	^ true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 11/18/2002 13:16'!
endOfRun
	"Before arriving at the cursor location, the selection has encountered an 
	end of run. Answer false if the selection continues, true otherwise. Set 
	up indexes for building the appropriate CharacterBlock."

	| runLength lineStop |
	(((characterIndex ~~ nil and:
		[runStopIndex < characterIndex and: [runStopIndex < text size]])
			or:	[characterIndex == nil and: [lastIndex < line last]]) or: [
				((lastIndex < line last)
				and: [((text at: lastIndex) leadingChar ~= (text at: lastIndex+1) leadingChar)
					and: [lastIndex ~= characterIndex]])])
		ifTrue:	["We're really at the end of a real run."
				runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
				characterIndex ~~ nil
					ifTrue:	[lineStop _ characterIndex	"scanning for index"]
					ifFalse:	[lineStop _ line last			"scanning for point"].
				(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
					ifTrue: 	[runStopIndex _ lineStop].
				self setStopConditions.
				^false].

	lastCharacter _ text at: lastIndex.
	characterPoint _ destX @ destY.
	((lastCharacter = Space and: [alignment = Justified])
		or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]])
		ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent].
	characterIndex ~~ nil
		ifTrue:	["If scanning for an index and we've stopped on that index,
				then we back destX off by the width of the character stopped on
				(it will be pointing at the right side of the character) and return"
				runStopIndex = characterIndex
					ifTrue:	[self characterPointSetX: destX - lastCharacterExtent x.
							^true].
				"Otherwise the requested index was greater than the length of the
				string.  Return string size + 1 as index, indicate further that off the
				string by setting character to nil and the extent to 0."
				lastIndex _  lastIndex + 1.
				lastCharacter _ nil.
				self lastCharacterExtentSetX: 0.
				^true].

	"Scanning for a point and either off the end of the line or off the end of the string."
	runStopIndex = text size
		ifTrue:	["off end of string"
				lastIndex _  lastIndex + 1.
				lastCharacter _ nil.
				self lastCharacterExtentSetX: 0.
				^true].
	"just off end of line without crossing x"
	lastIndex _ lastIndex + 1.
	^true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:51'!
paddedSpace
	"When the line is justified, the spaces will not be the same as the font's 
	space character. A padding of extra space must be considered in trying 
	to find which character the cursor is pointing at. Answer whether the 
	scanning has crossed the cursor."

	| pad |
	pad _ 0.
	spaceCount _ spaceCount + 1.
	pad _ line justifiedPadFor: spaceCount.
	lastSpaceOrTabExtent _ lastCharacterExtent copy.
	self lastSpaceOrTabExtentSetX:  spaceWidth + pad.
	(destX + lastSpaceOrTabExtent x)  >= characterPoint x
		ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy.
				^self crossedX].
	lastIndex _ lastIndex + 1.
	destX _ destX + lastSpaceOrTabExtent x.
	^ false
! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:32'!
setFont
	specialWidth _ nil.
	super setFont! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:30'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]).
! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'!
tab
	| currentX |
	currentX _ (alignment == Justified and: [self leadingTab not])
		ifTrue:		"imbedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse:
			[textStyle
				nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin].
	lastSpaceOrTabExtent _ lastCharacterExtent copy.
	self lastSpaceOrTabExtentSetX: (currentX - destX max: 0).
	currentX >= characterPoint x
		ifTrue: 
			[lastCharacterExtent _ lastSpaceOrTabExtent copy.
			^ self crossedX].
	destX _ currentX.
	lastIndex _ lastIndex + 1.
	^false! !


!CharacterBlockScanner methodsFor: 'private' stamp: 'tlk 5/7/2006 16:42'!
buildCharacterBlockIn: para
	| lineIndex runLength lineStop done stopCondition |
	"handle nullText"
	(para numberOfLines = 0 or: [text size = 0])
		ifTrue:	[^ CharacterBlock new stringIndex: 1  "like being off end of string"
					text: para text
					topLeft: (para leftMarginForDisplayForLine: 1 alignment: (alignment ifNil:[textStyle alignment]))
								@ para compositionRectangle top
					extent: 0 @ textStyle lineGrid].
	"find the line"
	lineIndex _ para lineIndexOfTop: characterPoint y.
	destY _ para topAtLineIndex: lineIndex.
	line _ para lines at: lineIndex.
	lastIndex _ line first.

	rightMargin _ para rightMarginForDisplay.
     self setStopConditions.  " also loads the font and loads all emphasis attributes "


	(lineIndex = para numberOfLines and:
		[(destY + line lineHeight) < characterPoint y])
			ifTrue:	["if beyond lastLine, force search to last character"
					self characterPointSetX: rightMargin]
			ifFalse:	[characterPoint y < (para compositionRectangle) top
						ifTrue: ["force search to first line"
								characterPoint _ (para compositionRectangle) topLeft].
					characterPoint x > rightMargin
						ifTrue:	[self characterPointSetX: rightMargin]].
	destX _ (leftMargin _ para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])).
	nextLeftMargin_ para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]).
	lastIndex _ line first.

	self setStopConditions.		"also sets font"
	runLength _ (text runLengthFor: line first).
	characterIndex == nil
		ifTrue:	[lineStop _ line last  "characterBlockAtPoint"]
		ifFalse:	[lineStop _ characterIndex  "characterBlockForIndex"].
	(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
		ifTrue:	[runStopIndex _ lineStop].
	lastCharacterExtent _ 0 @ line lineHeight.
	spaceCount _ 0. done  _ false.
	self handleIndentation.

	[done]
	whileFalse:
	[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.

	"see setStopConditions for stopping conditions for character block 	operations."
	self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)).
	(self perform: stopCondition) ifTrue:
		[characterIndex == nil
			ifTrue: ["characterBlockAtPoint"
					^ CharacterBlock new stringIndex: lastIndex text: text
						topLeft: characterPoint + (font descentKern @ 0)
						extent: lastCharacterExtent]
			ifFalse: ["characterBlockForIndex"
					^ CharacterBlock new stringIndex: lastIndex text: text
						topLeft: characterPoint + ((font descentKern) - kern @ 0)
						extent: lastCharacterExtent]]]! !

!CharacterBlockScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:34'!
characterPointSetX: xVal
	characterPoint _ xVal @ characterPoint y! !

!CharacterBlockScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:34'!
lastCharacterExtentSetX: xVal
	lastCharacterExtent _ xVal @ lastCharacterExtent y! !

!CharacterBlockScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:34'!
lastSpaceOrTabExtentSetX: xVal
	lastSpaceOrTabExtent _ xVal @ lastSpaceOrTabExtent y! !
Object subclass: #CharacterScanner
	instanceVariableNames: 'destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks'
	classVariableNames: 'DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition'
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Text'!
!CharacterScanner commentStamp: '<historical>' prior: 0!
My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.!


!CharacterScanner methodsFor: 'initialize' stamp: 'ls 1/14/2002 21:26'!
initialize
	destX _ destY _ leftMargin _ 0.! !

!CharacterScanner methodsFor: 'initialize' stamp: 'ar 12/31/2001 00:52'!
initializeStringMeasurer
	stopConditions _ Array new: 258.
	stopConditions at: CrossedX put: #crossedX.
	stopConditions at: EndOfRun put: #endOfRun.
! !

!CharacterScanner methodsFor: 'initialize' stamp: 'RAA 5/7/2001 10:11'!
wantsColumnBreaks: aBoolean

	wantsColumnBreaks _ aBoolean! !


!CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/18/2002 12:32'!
isBreakableAtIndex: index

	^ (EncodedCharSet at: ((text at: index) leadingChar + 1)) isBreakableAt: index in: text.
! !

!CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/13/2003 11:57'!
scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| ascii encoding f nextDestX maxAscii startEncoding |
	lastIndex _ startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
	startEncoding _ (sourceString at: startIndex) leadingChar.
	font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
	((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
		maxAscii _ font maxAsciiFor: startEncoding.
		f _ font fontArray at: startEncoding + 1.
		"xTable _ f xTable.
		maxAscii _ xTable size - 2."
		spaceWidth _ f widthOf: Space.
	] ifFalse: [
		maxAscii _ font maxAscii.
	].
	[lastIndex <= stopIndex] whileTrue: [
		encoding _ (sourceString at: lastIndex) leadingChar.
		encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
		ascii _ (sourceString at: lastIndex) charCode.
		ascii > maxAscii ifTrue: [ascii _ maxAscii].
		(encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1].
		nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)).
		nextDestX > rightX ifTrue: [^ stops at: CrossedX].
		destX _ nextDestX + kernDelta.
		"destX printString displayAt: 0@(lastIndex*20)."
		lastIndex _ lastIndex + 1.
	].
	lastIndex _ stopIndex.
	^ stops at: EndOfRun! !

!CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/27/2002 04:33'!
scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| ascii encoding f nextDestX maxAscii startEncoding |
	lastIndex _ startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
	startEncoding _ (sourceString at: startIndex) leadingChar.
	font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
	((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
		maxAscii _ font maxAsciiFor: startEncoding.
		f _ font fontArray at: startEncoding + 1.
		spaceWidth _ f widthOf: Space.
	] ifFalse: [
		maxAscii _ font maxAscii.
	].

	[lastIndex <= stopIndex] whileTrue: [
		encoding _ (sourceString at: lastIndex) leadingChar.
		encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
		ascii _ (sourceString at: lastIndex) charCode.
		ascii > maxAscii ifTrue: [ascii _ maxAscii].
		(encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1].
		nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)).
		nextDestX > rightX ifTrue: [^ stops at: CrossedX].
		destX _ nextDestX + kernDelta.
		"destX printString displayAt: 0@(lastIndex*20)."
		lastIndex _ lastIndex + 1.
	].
	lastIndex _ stopIndex.
	^ stops at: EndOfRun! !


!CharacterScanner methodsFor: 'scanning' stamp: 'yo 9/23/2002 16:13'!
basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
	"Primitive. This is the inner loop of text display--but see 
	scanCharactersFrom: to:rightX: which would get the string, 
	stopConditions and displaying from the instance. March through source 
	String from startIndex to stopIndex. If any character is flagged with a 
	non-nil entry in stops, then return the corresponding value. Determine 
	width of each character from xTable, indexed by map. 
	If dextX would exceed rightX, then return stops at: 258. 
	Advance destX by the width of the character. If stopIndex has been
	reached, then return stops at: 257. Optional. 
	See Object documentation whatIsAPrimitive."
	| ascii nextDestX char |
	<primitive: 103>
	lastIndex _ startIndex.
	[lastIndex <= stopIndex]
		whileTrue: 
			[char _ (sourceString at: lastIndex).
			ascii _ char asciiValue + 1.
			(stops at: ascii) == nil ifFalse: [^stops at: ascii].
			"Note: The following is querying the font about the width
			since the primitive may have failed due to a non-trivial
			mapping of characters to glyphs or a non-existing xTable."
			nextDestX _ destX + (font widthOf: char).
			nextDestX > rightX ifTrue: [^stops at: CrossedX].
			destX _ nextDestX + kernDelta.
			lastIndex _ lastIndex + 1].
	lastIndex _ stopIndex.
	^stops at: EndOfRun! !

!CharacterScanner methodsFor: 'scanning' stamp: 'RAA 5/4/2001 13:53'!
columnBreak

	^true! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 01:50'!
embeddedObject
	| savedIndex |
	savedIndex _ lastIndex.
	text attributesAt: lastIndex do:[:attr| 
		attr anchoredMorph ifNotNil:[
			"Following may look strange but logic gets reversed.
			If the morph fits on this line we're not done (return false for true) 
			and if the morph won't fit we're done (return true for false)"
			(self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^true]]].
	lastIndex _ savedIndex + 1. "for multiple(!!) embedded morphs"
	^false! !

!CharacterScanner methodsFor: 'scanning' stamp: 'hmm 7/15/2000 22:40'!
handleIndentation
	self indentationLevel timesRepeat: [
		self plainTab]! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 18:20'!
indentationLevel
	"return the number of tabs that are currently being placed at the beginning of each line"
	^indentationLevel ifNil:[0]! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:23'!
indentationLevel: anInteger
	"set the number of tabs to put at the beginning of each line"
	indentationLevel _ anInteger! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:23'!
leadingTab
	"return true if only tabs lie to the left"
	line first to: lastIndex do:
		[:i | (text at: i) == Tab ifFalse: [^ false]].
	^ true! !

!CharacterScanner methodsFor: 'scanning' stamp: 'tak 3/12/2005 00:43'!
measureString: aString inFont: aFont from: startIndex to: stopIndex
	"WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer"
	destX _ destY _ lastIndex _ 0.
	xTable _ aFont xTable.
	self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0.
	^destX! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 19:27'!
placeEmbeddedObject: anchoredMorph
	"Place the anchoredMorph or return false if it cannot be placed.
	In any event, advance destX by its width."
	| w |
	"Workaround: The following should really use #textAnchorType"
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	destX _ destX + (w _ anchoredMorph width).
	(destX > rightMargin and: [(leftMargin + w) <= rightMargin])
		ifTrue: ["Won't fit, but would on next line"
				^ false].
	lastIndex _ lastIndex + 1.
	self setFont.  "Force recalculation of emphasis for next run"
	^ true! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/15/2001 23:28'!
plainTab
	"This is the basic method of adjusting destX for a tab."
	destX _ (alignment == Justified and: [self leadingTab not])
		ifTrue:		"embedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse: 
			[textStyle nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin]! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 4/12/2005 19:53'!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| startEncoding selector |
	(sourceString isByteString) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.].

	(sourceString isWideString) ifTrue: [
		startIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
		startEncoding _  (sourceString at: startIndex) leadingChar.
		selector _ (EncodedCharSet charsetAt: startEncoding) scanSelector.
		^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stopConditions with: kernDelta).
	].
	
	^ stops at: EndOfRun
! !


!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:27'!
addEmphasis: code
	"Set the bold-ital-under-strike emphasis."
	emphasisCode _ emphasisCode bitOr: code! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:27'!
addKern: kernDelta
	"Set the current kern amount."
	kern _ kern + kernDelta! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 5/17/2000 17:13'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	text _ aParagraph text.
	textStyle _ aParagraph textStyle. 
! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:27'!
setActualFont: aFont
	"Set the basal font to an isolated font reference."

	font _ aFont! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 12/15/2001 23:31'!
setAlignment: style
	alignment _ style.
	! !

!CharacterScanner methodsFor: 'private' stamp: 'yo 10/7/2002 14:33'!
setConditionArray: aSymbol

	aSymbol == #paddedSpace ifTrue: [^stopConditions _ PaddedSpaceCondition copy].
	aSymbol == #space ifTrue: [^stopConditions _ SpaceCondition copy].
	aSymbol == nil ifTrue: [^stopConditions _ NilCondition copy].
	self error: 'undefined stopcondition for space character'.
! !

!CharacterScanner methodsFor: 'private' stamp: 'tak 3/12/2005 00:43'!
setFont
	| priorFont |
	"Set the font and other emphasis."
	priorFont _ font.
	text == nil ifFalse:[
		emphasisCode _ 0.
		kern _ 0.
		indentationLevel _ 0.
		alignment _ textStyle alignment.
		font _ nil.
		(text attributesAt: lastIndex forStyle: textStyle)
			do: [:att | att emphasizeScanner: self]].
	font == nil ifTrue:
		[self setFont: textStyle defaultFontIndex].
	font _ font emphasized: emphasisCode.
	priorFont ifNotNil: [destX _ destX + priorFont descentKern].
	destX _ destX - font descentKern.
	"NOTE: next statement should be removed when clipping works"
	leftMargin ifNotNil: [destX _ destX max: leftMargin].
	kern _ kern - font baseKern.

	"Install various parameters from the font."
	spaceWidth _ font widthOf: Space.
	xTable _ font xTable.
	stopConditions _ DefaultStopConditions.! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'!
setFont: fontNumber
	"Set the font by number from the textStyle."

	self setActualFont: (textStyle fontAt: fontNumber)! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'!
text: t textStyle: ts
	text _ t.
	textStyle _ ts! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'!
textColor: ignored
	"Overridden in DisplayScanner"! !

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

CharacterScanner class
	instanceVariableNames: ''!

!CharacterScanner class methodsFor: 'class initialization' stamp: 'yo 12/18/2002 14:09'!
initialize
"
	CharacterScanner initialize
"
	| a |
	a _ Array new: 258.
	a at: 1 + 1 put: #embeddedObject.
	a at: Tab asciiValue + 1 put: #tab.
	a at: CR asciiValue + 1 put: #cr.
	a at: EndOfRun put: #endOfRun.
	a at: CrossedX put: #crossedX.
	NilCondition _ a copy.
	DefaultStopConditions _ a copy.

	PaddedSpaceCondition _ a copy.
	PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace.
	
	SpaceCondition _ a copy.
	SpaceCondition at: Space asciiValue + 1 put: #space.
! !
Collection subclass: #CharacterSet
	instanceVariableNames: 'map'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!CharacterSet commentStamp: '<historical>' prior: 0!
A set of characters.  Lookups for inclusion are very fast.!


!CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:33'!
add: aCharacter
	map at: aCharacter asciiValue+1  put: 1.! !

!CharacterSet methodsFor: 'collection ops' stamp: 'ar 4/9/2005 22:37'!
do: aBlock
	"evaluate aBlock with each character in the set"

	Character allByteCharacters do: [ :c |
		(self includes: c) ifTrue: [ aBlock value: c ] ]
! !

!CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:31'!
includes: aCharacter
	^(map at: aCharacter asciiValue + 1) > 0! !

!CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:34'!
remove: aCharacter
	map at: aCharacter asciiValue + 1  put: 0! !


!CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:58'!
= anObject
	^self species == anObject species and: [
		self byteArrayMap = anObject byteArrayMap ]! !

!CharacterSet methodsFor: 'comparison' stamp: 'ls 8/17/1998 20:46'!
hash
	^self byteArrayMap hash! !

!CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:57'!
species
	^CharacterSet! !


!CharacterSet methodsFor: 'conversion' stamp: 'ls 8/17/1998 20:39'!
complement
	"return a character set containing precisely the characters the receiver does not"
	| set |
	set _ CharacterSet allCharacters.
	self do: [ :c | set remove: c ].
	^set! !


!CharacterSet methodsFor: 'private' stamp: 'ls 8/17/1998 20:35'!
byteArrayMap
	"return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't.  Intended for use by primitives only"
	^map! !

!CharacterSet methodsFor: 'private' stamp: 'ls 8/17/1998 20:30'!
initialize
	map _ ByteArray new: 256 withAll: 0.! !

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

CharacterSet class
	instanceVariableNames: ''!

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/17/1998 20:42'!
allCharacters
	"return a set containing all characters"

	| set |
	set _ self empty.
	0 to: 255 do: [ :ascii | set add: (Character value: ascii) ].
	^set! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'nk 8/3/2004 06:54'!
empty
 	"return an empty set of characters"
	^self new! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 1/3/1999 12:52'!
newFrom: aCollection
	| newCollection |
	newCollection _ self new.
	newCollection addAll: aCollection.
	^newCollection! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'!
nonSeparators
	"return a set containing everything but the whitespace characters"

	^self separators complement! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'!
separators
	"return a set containing just the whitespace characters"

	| set |
	set _ self empty.
	set addAll: Character separators.
	^set! !
ClassTestCase subclass: #CharacterTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!
!CharacterTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Character. 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!


!CharacterTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 09:25'!
testNew

	self should: [Character new] raise: Error.! !


!CharacterTest methodsFor: 'testing-printing' stamp: 'lr 11/21/2005 17:41'!
testPrintString
	self assert: $a printString = '$a'.
	self assert: $5 printString = '$5'.
	self assert: $@ printString = '$@'.

	self assert: Character cr printString = 'Character cr'.
	self assert: Character lf printString = 'Character lf'.
	self assert: Character space printString = 'Character space'.

	self assert: (Character value: 0) printString = 'Character value: 0'.
	self assert: (Character value: 17) printString = 'Character value: 17'.! !

!CharacterTest methodsFor: 'testing-printing' stamp: 'lr 11/21/2005 17:41'!
testPrintStringAll
	Character allCharacters do: [ :each |
		self assert: (self class compilerClass 
			evaluate: each printString) = each ].! !

!CharacterTest methodsFor: 'testing-printing' stamp: 'lr 11/21/2005 17:22'!
testStoreString
	self assert: $a storeString = '$a'.
	self assert: $5 storeString = '$5'.
	self assert: $@ storeString = '$@'.

	self assert: Character cr storeString = 'Character cr'.
	self assert: Character lf storeString = 'Character lf'.
	self assert: Character space storeString = 'Character space'.

	self assert: (Character value: 0) storeString = '(Character value: 0)'.
	self assert: (Character value: 17) storeString = '(Character value: 17)'.! !

!CharacterTest methodsFor: 'testing-printing' stamp: 'lr 11/21/2005 17:24'!
testStoreStringAll
	Character allCharacters do: [ :each |
		self assert: (self class compilerClass 
			evaluate: each storeString) = each ].! !
SimpleButtonMorph subclass: #ChatButtonMorph
	instanceVariableNames: 'actionDownSelector actionUpSelector labelDown labelUp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Audio Chat'!

!ChatButtonMorph methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
actionDownSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	['nil' = aSymbolOrString or:
	[aSymbolOrString isEmpty]])
		ifTrue: [^actionDownSelector := nil].

	actionDownSelector := aSymbolOrString asSymbol.! !

!ChatButtonMorph methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
actionUpSelector: aSymbolOrString


	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionUpSelector := nil].

	actionUpSelector := aSymbolOrString asSymbol.! !

!ChatButtonMorph methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
labelDown: aString

	labelDown := aString.! !

!ChatButtonMorph methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
labelUp: aString

	labelUp := aString! !


!ChatButtonMorph methodsFor: 'event handling' stamp: 'sd 11/20/2005 21:25'!
mouseDown: evt

	oldColor := self fillStyle.
	self label: labelDown.
	self doButtonDownAction.

! !

!ChatButtonMorph methodsFor: 'event handling' stamp: 'RAA 8/6/2000 18:37'!
mouseUp: evt

	"if oldColor nil, it signals that mouse had not gone DOWN inside me, e.g. because of a cmd-drag; in this case we want to avoid triggering the action!!"

	oldColor ifNil: [^self].
	self color: oldColor.
	(self containsPoint: evt cursorPoint) ifTrue: [
		self label: labelUp.
		self doButtonUpAction.
	].
! !


!ChatButtonMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 18:40'!
doButtonDownAction
	(target notNil and: [actionDownSelector notNil]) 
		ifTrue: [Cursor normal showWhile: [target perform: actionDownSelector]]! !

!ChatButtonMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 18:40'!
doButtonUpAction
	(target notNil and: [actionUpSelector notNil]) 
		ifTrue: [Cursor normal showWhile: [target perform: actionUpSelector]]! !
StringHolder subclass: #ChatNotes
	instanceVariableNames: 'name notesIndex names notes recorder player sound isPlaying isRecording isSaving nameTextMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Audio Chat'!

!ChatNotes methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
name

	^name ifNil: [name := '']! !

!ChatNotes methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
name: aString
	name := aString.
	self changed: #name.! !

!ChatNotes methodsFor: 'accessing' stamp: 'RAA 8/1/2000 18:01'!
notesList
	
	self flag: #why.
	^names copy asArray! !

!ChatNotes methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
notesListIndex

	^notesIndex ifNil: [notesIndex := 0]! !

!ChatNotes methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
notesListIndex: index
	
	notesIndex := index = notesIndex ifTrue: [0] ifFalse: [index].
	self name: (self notesList at: notesIndex ifAbsent: ['']).
	self changed: #notesListIndex.! !

!ChatNotes methodsFor: 'accessing' stamp: 'TBP 2/23/2000 21:07'!
recorder
	^recorder! !


!ChatNotes methodsFor: 'button commands' stamp: 'sd 11/20/2005 21:25'!
record

	self isRecording: true.
	notesIndex = 0 ifFalse: [self notesListIndex: 0].
	sound := nil.
	recorder clearRecordedSound.
	recorder resumeRecording.! !

!ChatNotes methodsFor: 'button commands' stamp: 'RAA 8/1/2000 18:03'!
save

	self isSaving: true.
	notesIndex = 0
		ifTrue: [self saveSound]
		ifFalse: [self saveName].
	self isSaving: false.! !

!ChatNotes methodsFor: 'button commands' stamp: 'TBP 2/23/2000 21:07'!
stop
	recorder pause.
	self isRecording: false! !


!ChatNotes methodsFor: 'file i/o' stamp: 'mir 11/27/2001 12:04'!
audioDirectory

	(FileDirectory default directoryExists: 'audio')
		ifFalse: [FileDirectory default createDirectory: 'audio'].
	^FileDirectory default directoryNamed: 'audio'! !

!ChatNotes methodsFor: 'file i/o' stamp: 'sd 11/20/2005 21:25'!
deleteSelection
	"Delete the selection in the list"
	| dir |

	notesIndex <= 0 ifTrue: [^self].
	dir := self audioDirectory.
	dir deleteFileNamed: ((notes at: notesIndex), 'name') ifAbsent: [].
	dir deleteFileNamed: ((notes at: notesIndex), 'aiff') ifAbsent: [].
	names removeAt: notesIndex.
	notes removeAt: notesIndex.
	self notesListIndex: 0.
	self changed: #notesList.
	self changed: #name.! !

!ChatNotes methodsFor: 'file i/o' stamp: 'sd 11/20/2005 21:25'!
getNextName
	"Return the next name available.
	All names are of the form '#.name' and '#.aiff'."
	| dir num |

	dir := self audioDirectory.
	num := 1.
	[dir fileExists: (num asString, '.name')] whileTrue: [num := num + 1].
	^(num asString, '.')! !

!ChatNotes methodsFor: 'file i/o' stamp: 'sd 11/20/2005 21:25'!
play
	| separator |
	self isPlaying: true.
	notesIndex = 0 ifTrue: [
		recorder pause.
		recorder playback.
		self isPlaying: false.
		^self
	].
	separator := FileDirectory pathNameDelimiter asString.
	sound := (AIFFFileReader new readFromFile: (
		FileDirectory default pathName, 
		separator, 'audio', separator, (notes at: notesIndex), 'aiff')) sound.
	[
		sound playAndWaitUntilDone.
		self isPlaying: false
	] fork! !

!ChatNotes methodsFor: 'file i/o' stamp: 'sd 11/20/2005 21:25'!
saveName
	"Save the name to the '.name' file."
	| dir file |

	self name: self textMorphString.
	dir := self audioDirectory.
	file := (notes at: notesIndex), 'name'.
	(dir fileExists: file) ifTrue: [dir deleteFileNamed: file].
	file := dir newFileNamed: file.
	file nextPutAll: name.
	file close.
	names at: notesIndex put: name.
	self changed: #notesList.! !

!ChatNotes methodsFor: 'file i/o' stamp: 'sd 11/20/2005 21:25'!
saveSound
	"Move the sound from the recorder to the files."
	| fname file |
	
	recorder recordedSound ifNil: [^self].
	self isSaving: true.
	fname := self getNextName.
	"Create .name file"
	file := self audioDirectory newFileNamed: (fname, 'name').
	file nextPutAll: self textMorphString.
	file close.
	"Create .aiff file"
	file := (self audioDirectory newFileNamed: (fname, 'aiff')) binary.
	self storeAIFFOnFile: file.
	file close.
	"Add to names and notes"
	names add: self textMorphString.
	notes add: fname.
	self changed: #notesList.
	self notesListIndex: (notes size).
	"Clear Recorder"
	recorder := SoundRecorder new.
	"Stop Button"
	self isSaving: false! !

!ChatNotes methodsFor: 'file i/o' stamp: 'sd 11/20/2005 21:25'!
storeAIFFOnFile: file
	"In a better design, this would be handled by SequentialSound,
	but I figure you will need a new primitive anyway, so it can
	be implemented at that time."
	| sampleCount s |

	sampleCount := recorder recordedSound sounds inject: 0 into: [ :sum :rsound |
		sum + rsound samples monoSampleCount
	].
	file nextPutAll: 'FORM' asByteArray.
	file nextInt32Put: (2 * sampleCount) + 46.
	file nextPutAll: 'AIFF' asByteArray.
	file nextPutAll: 'COMM' asByteArray.
	file nextInt32Put: 18.
	file nextNumber: 2 put: 1. "channels"
	file nextInt32Put: sampleCount.
	file nextNumber: 2 put: 16. "bits/sample"
	(AbstractSound new) storeExtendedFloat: (recorder samplingRate) on: file.
	file nextPutAll: 'SSND' asByteArray.
	file nextInt32Put: (2 * sampleCount) + 8.
	file nextInt32Put: 0.
	file nextInt32Put: 0.
	(recorder recordedSound sounds) do: [:rsound |
		1 to: (rsound samples monoSampleCount) do: [:i |
			s := rsound samples at: i.
			file nextPut: ((s bitShift: -8) bitAnd: 16rFF).
			file nextPut: (s bitAnd: 16rFF)]].! !

!ChatNotes methodsFor: 'file i/o' stamp: 'TBP 2/23/2000 21:07'!
updateNotes
	"Probably not necessary unless several audio notes are
	open at the same time"

	"Clear Notes"
	self loadNotes.
	self changed: #notesList.
	self notesListIndex: 0.
	self name: ''.! !


!ChatNotes methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize

	self loadNotes.
	notesIndex := 0.
	recorder := ChatRecorder new.
	recorder initialize.! !

!ChatNotes methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
loadNotes
	"Load notes from the files"
	| dir |

	names := OrderedCollection new.
	notes := OrderedCollection new.
	(FileDirectory default directoryExists: 'audio')
		ifFalse: [^self].
	dir := self audioDirectory.
	dir fileNames do: [:fname |
		(fname endsWith: '.name') ifTrue: [
			names add: ((dir fileNamed: fname) contentsOfEntireFile).
			notes add: (fname copyFrom: 1 to: (fname size - 4))]].! !

!ChatNotes methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
openAsMorph
	| window aColor recordButton stopButton playButton saveButton |

	window := (SystemWindow labelled: 'Audio Notes') model: self.

	window addMorph: (
		(PluggableListMorph 
			on: self 
			list: #notesList 
			selected: #notesListIndex 
			changeSelected: #notesListIndex: 
			menu: #notesMenu:
		) autoDeselect: false) frame: (0@0 corner: 0.5@1.0).

	nameTextMorph := PluggableTextMorph on: self text: #name accept: nil.
	nameTextMorph askBeforeDiscardingEdits: false.
	window addMorph: nameTextMorph frame: (0.5@0 corner: 1.0@0.4).

	aColor := Color colorFrom: self defaultBackgroundColor.

	(recordButton := PluggableButtonMorph on: self getState: #isRecording action: #record)
		label: 'record';
		askBeforeChanging: true;
		color: aColor;
		onColor: aColor darker offColor: aColor.
	window addMorph: recordButton frame: (0.5@0.4 corner: 0.75@0.7).

	(stopButton := PluggableButtonMorph on: self getState: #isStopped action: #stop)
		label: 'stop';
		askBeforeChanging: true;
		color: aColor;
		onColor: aColor darker offColor: aColor.
	window addMorph: stopButton frame: (0.75@0.4 corner: 1.0@0.7).

	(playButton := PluggableButtonMorph on: self getState: #isPlaying action: #play)
		label: 'play';
		askBeforeChanging: true;
		color: aColor;
		onColor: aColor darker offColor: aColor.
	window addMorph: playButton frame: (0.5@0.7 corner: 0.75@1.0).

	(saveButton := PluggableButtonMorph on: self getState: #isSaving action: #save)
		label: 'save';
		askBeforeChanging: true;
		color: aColor;
		onColor: aColor darker offColor: aColor.
	window addMorph: saveButton frame: (0.75@0.7 corner: 1.0@1.0).

	window openInWorld.! !


!ChatNotes methodsFor: 'morphic' stamp: 'TBP 2/23/2000 21:07'!
defaultBackgroundColor
	"In a better design, this would be handled by preferences."
	^Color r: 1.0 g: 0.7 b: 0.8! !

!ChatNotes methodsFor: 'morphic' stamp: 'TBP 2/23/2000 21:07'!
initialExtent
	"Nice and small--that was the idea.
	It shouldn't take up much screen real estate."
	^200@100! !

!ChatNotes methodsFor: 'morphic' stamp: 'TBP 2/23/2000 21:07'!
notesMenu: aMenu
	"Simple menu to delete notes"
	^(notesIndex = 0)
		ifTrue: [aMenu labels: 'update notes' lines: #() selections: #(updateNotes)]
		ifFalse: [aMenu labels: ('delete', String cr, 'update notes') lines: #() selections: #(deleteSelection updateNotes)]! !

!ChatNotes methodsFor: 'morphic' stamp: 'RAA 8/2/2000 01:11'!
textMorphString

	^nameTextMorph text string! !


!ChatNotes methodsFor: 'testing' stamp: 'sd 11/20/2005 21:25'!
isPlaying

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

!ChatNotes methodsFor: 'testing' stamp: 'sd 11/20/2005 21:25'!
isPlaying: aBoolean

	isPlaying = aBoolean ifTrue: [^self].
	isPlaying := aBoolean.
	self changed: #isPlaying	! !

!ChatNotes methodsFor: 'testing' stamp: 'sd 11/20/2005 21:25'!
isRecording

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

!ChatNotes methodsFor: 'testing' stamp: 'sd 11/20/2005 21:25'!
isRecording: aBoolean
	
	isRecording = aBoolean ifTrue: [^self].
	isRecording := aBoolean.
	self changed: #isRecording	! !

!ChatNotes methodsFor: 'testing' stamp: 'sd 11/20/2005 21:25'!
isSaving

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

!ChatNotes methodsFor: 'testing' stamp: 'sd 11/20/2005 21:25'!
isSaving: aBoolean

	isSaving = aBoolean ifTrue: [^self].
	isSaving := aBoolean.
	self changed: #isSaving! !

!ChatNotes methodsFor: 'testing' stamp: 'RAA 8/1/2000 18:05'!
isStopped

	^false! !

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

ChatNotes class
	instanceVariableNames: ''!

!ChatNotes class methodsFor: 'instance creation' stamp: 'RAA 8/2/2000 01:06'!
openAsMorph

	^self new openAsMorph! !
SoundRecorder subclass: #ChatRecorder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Audio Chat'!

!ChatRecorder methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
recordedSound: aSound

	self clearRecordedSound.
	recordedSound := aSound.! !


!ChatRecorder methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
initialize
	
	"setting a higher desired recording rate seemed to fix certain powerbook problems.
	I'm still trying to understand it all, but there it is for now"

	super initialize.
	samplingRate := 44100.

! !

!ChatRecorder methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
pause
	"Go into pause mode. The record level continues to be updated, but no sound is recorded."

	paused := true.
	((currentBuffer ~~ nil) and: [nextIndex > 1])
		ifTrue: [self emitPartialBuffer.
				self allocateBuffer].

	soundPlaying ifNotNil: [
		soundPlaying pause.
		soundPlaying := nil].

	self stopRecording.

	"Preferences canRecordWhilePlaying ifFalse: [self stopRecording]."
! !

!ChatRecorder methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
playback
	"Playback the sound that has been recorded."

	self pause.
	soundPlaying := self recordedSound ifNil: [^self].
	soundPlaying play.
! !

!ChatRecorder methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
resumeRecording
	"Continue recording from the point at which it was last paused."

	self startRecording.
	paused := false.
! !
SharedPool subclass: #ChronologyConstants
	instanceVariableNames: 'seconds offset jdn nanos'
	classVariableNames: 'DayNames DaysInMonth MonthNames NanosInMillisecond NanosInSecond SecondsInDay SecondsInHour SecondsInMinute SqueakEpoch'
	poolDictionaries: ''
	category: 'Kernel-Chronology'!
!ChronologyConstants commentStamp: 'brp 3/12/2004 14:34' prior: 0!
ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.!


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

ChronologyConstants class
	instanceVariableNames: ''!

!ChronologyConstants class methodsFor: 'as yet unclassified' stamp: 'brp 9/25/2003 10:49'!
initialize
	"ChronologyConstants initialize" 	SqueakEpoch _ 2415386. 		"Julian day number of 1 Jan 1901" 
	SecondsInDay _ 86400.
	SecondsInHour _ 3600.
	SecondsInMinute _ 60.
	NanosInSecond _ 10 raisedTo: 9.
	NanosInMillisecond _ 10 raisedTo: 6.
	DayNames _ #(Sunday Monday Tuesday Wednesday Thursday Friday Saturday).
		
	MonthNames _ #(January February March April May June July
 			August September October November December).
	DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31).
! !
Arc subclass: #Circle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Circle commentStamp: '<historical>' prior: 0!
I represent a full circle. I am made from four Arcs.!


!Circle methodsFor: 'display box access'!
computeBoundingBox

	^center - radius + form offset extent: form extent + (radius * 2) asPoint! !


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

	1 to: 4 do:
		[:i |
		super quadrant: i.
		super displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

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

	1 to: 4 do:
		[:i |
		super quadrant: i.
		super displayOn: aDisplayMedium
			transformation: aTransformation
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

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

Circle class
	instanceVariableNames: ''!

!Circle class methodsFor: 'examples'!
exampleOne 
	"Click any button somewhere on the screen. The point will be the center
	of the circcle of radius 150."

	| aCircle aForm |
	aForm _ Form extent: 1@30.
	aForm fillBlack.
	aCircle _ Circle new.
	aCircle form: aForm.
	aCircle radius: 150.
	aCircle center: Sensor waitButton.
	aCircle displayOn: Display
	
	"Circle exampleOne"! !

!Circle class methodsFor: 'examples'!
exampleTwo
	"Designate a rectangular area that should be used as the brush for
	displaying the circle. Click any button at a point on the screen which
	will be the center location for the circle. The curve will be displayed
	with a long black form."

	| aCircle aForm |
	aForm _ Form fromUser.
	aCircle _ Circle new.
	aCircle form: aForm.
	aCircle radius: 150.
	aCircle center: Sensor waitButton.
	aCircle displayOn: Display at: 0 @ 0 rule: Form reverse
 
	 "Circle exampleTwo"! !
EllipseMorph subclass: #CircleMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!CircleMorph commentStamp: '<historical>' prior: 0!
I am a specialization of EllipseMorph that knows enough to remain circular.
!


!CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 07:04'!
addFlexShellIfNecessary
	"When scaling or rotating from a halo, I can do this without a flex shell"

	^ self
! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 16:29'!
privateMoveBy: delta
	self setProperty: #referencePosition toValue: self referencePosition + delta.
	self setProperty: #originalCenter toValue: (self valueOfProperty: #originalCenter ifAbsent: [ self center ]) + delta.
	super privateMoveBy: delta.
! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 07:28'!
rotationDegrees

	^ self forwardDirection! !

!CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 15:52'!
rotationDegrees: degrees
	| ref newPos flex origAngle origCenter |
	ref _ self referencePosition.
	origAngle _ self valueOfProperty: #originalAngle ifAbsentPut: [ self heading ].
	origCenter _ self valueOfProperty: #originalCenter ifAbsentPut: [ self center ].
	flex _ (MorphicTransform offset: ref negated)
			withAngle: (degrees - origAngle) degreesToRadians.
	newPos _ (flex transform: origCenter) - flex offset.
	self position: (self position + newPos - self center) asIntegerPoint.
	self setProperty: #referencePosition toValue: ref.
	self setProperty: #originalAngle toValue: origAngle.
	self setProperty: #originalCenter toValue: origCenter.
	self forwardDirection: degrees.
	self changed.
! !


!CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 07:01'!
bounds: aRectangle
	| size |
	size _ aRectangle width min: aRectangle height.
	super bounds: (Rectangle origin: aRectangle origin extent: size @ size).! !

!CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 16:39'!
extent: aPoint
	| size oldRotationCenter |
	oldRotationCenter _ self rotationCenter.
	size _ aPoint x min: aPoint y.
	super extent: size @ size.
	self rotationCenter: oldRotationCenter.! !

!CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 08:49'!
transformedBy: aTransform
	aTransform isIdentity ifTrue:[^self].
	^self center: (aTransform localPointToGlobal: self center).
! !



!CircleMorph methodsFor: 'geometry eToy' stamp: 'nk 7/1/2002 07:12'!
heading: newHeading
	"Set the receiver's heading (in eToy terms).
	Note that circles never use flex shells."
	self rotationDegrees: newHeading.! !

!CircleMorph methodsFor: 'geometry eToy' stamp: 'nk 7/1/2002 07:31'!
referencePosition 
	"Return the current reference position of the receiver"
	^ self valueOfProperty: #referencePosition ifAbsent: [ self center ]
! !

!CircleMorph methodsFor: 'geometry eToy' stamp: 'nk 7/1/2002 11:16'!
rotationCenter
	"Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	| refPos |
	refPos _ self referencePosition.
	^ (refPos - self bounds origin) / self bounds extent asFloatPoint! !

!CircleMorph methodsFor: 'geometry eToy' stamp: 'nk 7/1/2002 13:48'!
rotationCenter: aPointOrNil
	"Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	| newRef box |
	aPointOrNil isNil
		ifTrue: [self removeProperty: #referencePosition.
			self removeProperty: #originalCenter.
			self removeProperty: #originalAngle. ]
		ifFalse: [ box _ self bounds.
				newRef _ box origin + (aPointOrNil * box extent).
				self setRotationCenterFrom: newRef ].

! !


!CircleMorph methodsFor: 'parts bin' stamp: 'nk 7/1/2002 16:42'!
initializeToStandAlone
	^super initializeToStandAlone
		extent: 40@40;
		color: Color green lighter;
		yourself! !


!CircleMorph methodsFor: 'menus' stamp: 'nk 7/1/2002 11:30'!
setRotationCenterFrom: aPoint
	"Called by halo rotation code.
	Circles store their referencePosition."
	self setProperty: #referencePosition toValue: aPoint.
	self setProperty: #originalCenter toValue: self center.
	self setProperty: #originalAngle toValue: self heading.! !

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

CircleMorph class
	instanceVariableNames: ''!

!CircleMorph class methodsFor: 'as yet unclassified' stamp: 'nk 8/23/2004 11:45'!
newPin
	"Construct a pin for embedded attachment"
	"CircleMorph newPin openInHand"
	^self new
		removeAllMorphs;
		extent: 18@18;
		hResizing: #rigid;
		vResizing: #rigid;
		layoutPolicy: nil;
		color: Color orange lighter;
		borderColor: Color orange darker;
		borderWidth: 2;
		wantsConnectionWhenEmbedded: true;
		name: 'Pin'! !

!CircleMorph class methodsFor: 'as yet unclassified' stamp: 'wiz 2/25/2006 16:12'!
supplementaryPartsDescriptions
	"Extra items for parts bins"

	^ {DescriptionForPartsBin
		formalName: 'Circle1'
		categoryList: #('Graphics')
		documentation: 'A circular shape'
		globalReceiverSymbol: #CircleMorph 
		nativitySelector: #newStandAlone.

	"DescriptionForPartsBin
		formalName: 'Pin'
		categoryList: #('Connectors')
		documentation: 'An attachment point for Connectors that you can embed in another Morph.'
		globalReceiverSymbol: #NCPinMorph 
		nativitySelector: #newPin."
}! !
MorphTest subclass: #CircleMorphTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!
!CircleMorphTest commentStamp: 'tlk 5/21/2006 14:16' prior: 0!
A CircleMorphTest is a subclass of MorphTest.  It was first implemented when removing some unused and broken functionality.

My fixtures are morph, a CircleMorph and world.
!


!CircleMorphTest methodsFor: 'initialize-release' stamp: 'tlk 5/21/2006 14:17'!
setUp
	morph := CircleMorph new! !
ClassDescription subclass: #Class
	uses: TBehaviorCategorization
	instanceVariableNames: 'subclasses name classPool sharedPools environment category traitComposition localSelectors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!Class commentStamp: '<historical>' prior: 0!
I add a number of facilities to those in ClassDescription:
	A set of all my subclasses (defined in ClassDescription, but only used here and below)
	A name by which I can be found in a SystemDictionary
	A classPool for class variables shared between this class and its metaclass
	A list of sharedPools which probably should be supplanted by some better mechanism.

My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription.

The slot 'subclasses' is a redundant structure.  It is never used during execution, but is used by the development system to simplify or speed certain operations.  !


!Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'!
basicCategory
	^category! !

!Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'!
basicCategory: aSymbol
	category := aSymbol! !

!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'!
basicLocalSelectors
	"Direct accessor for the instance variable localSelectors.
	Since localSelectors is lazily initialized, this may 
	return nil, which means that all selectors are local."

	^ localSelectors! !

!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'!
basicLocalSelectors: aSetOrNil
	localSelectors _ aSetOrNil! !

!Class methodsFor: 'accessing'!
classPool
	"Answer the dictionary of class variables."

	classPool == nil
		ifTrue: [^Dictionary new]
		ifFalse: [^classPool]! !

!Class methodsFor: 'accessing' stamp: 'BG 8/11/2002 20:53'!
classPoolFrom: aClass
	"share the classPool with aClass."

	classPool := aClass classPool! !

!Class methodsFor: 'accessing' stamp: 'al 9/3/2004 13:37'!
classPool: aDictionary
	classPool _ aDictionary! !

!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:38'!
hasTraitComposition
	^traitComposition notNil! !

!Class methodsFor: 'accessing'!
name
	"Answer the name of the receiver."

	name == nil
		ifTrue: [^super name]
		ifFalse: [^name]! !

!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'!
traitComposition
	traitComposition ifNil: [traitComposition _ TraitComposition new].
	^traitComposition! !

!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:37'!
traitComposition: aTraitComposition
	traitComposition := aTraitComposition! !


!Class methodsFor: 'accessing class hierarchy' stamp: 'tk 10/17/1999 13:31'!
addSubclass: aSubclass 
	"Make the argument, aSubclass, be one of the subclasses of the receiver. 
	Create an error notification if the argument's superclass is not the receiver."
	
	aSubclass superclass ~~ self 
		ifTrue: [^self error: aSubclass name , ' is not my subclass'].
	subclasses == nil
		ifTrue:	[subclasses _ Array with: aSubclass.
				^self].
	subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass"
	subclasses _ subclasses copyWith: aSubclass.! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 10:54'!
removeSubclass: aSubclass 
	"If the argument, aSubclass, is one of the receiver's subclasses, remove it."

	subclasses == nil ifFalse:
		[subclasses _  subclasses copyWithout: aSubclass.
		subclasses isEmpty ifTrue: [subclasses _ nil]].
! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'!
subclasses
	"Answer a Set containing the receiver's subclasses."

	^subclasses == nil
		ifTrue: [#()]
		ifFalse: [subclasses copy]! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'tk 8/18/1999 17:42'!
subclassesDoGently: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	subclasses == nil 
		ifFalse: [subclasses do: aBlock]! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'!
subclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	subclasses == nil 
		ifFalse:[subclasses do: aBlock]! !


!Class methodsFor: 'class name' stamp: 'sw 12/1/2000 20:39'!
externalName
	"Answer a name by which the receiver can be known."

	^ name! !

!Class methodsFor: 'class name' stamp: 'sw 12/18/2000 15:50'!
nameForViewer
	"Answer the name to be shown in the header of a viewer looking at the receiver"

	^ self name ifNil: ['Unnamed class']! !

!Class methodsFor: 'class name' stamp: 'Noury Bouraqadi 3/24/2006 20:10'!
rename: aString 
	"The new name of the receiver is the argument, aString."

	| newName |
	(newName _ aString asSymbol) ~= self name
		ifFalse: [^ self].
	(self environment includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	(Undeclared includesKey: newName)
		ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
	self environment renameClass: self as: newName.
	name := newName.
! !


!Class methodsFor: 'class variables' stamp: 'dvf 9/27/2005 17:32'!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol oldState |
	oldState _ self copy.
	aString first canBeGlobalVarInitial
		ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol _ aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		(subclass bindingOf: symbol) ifNotNil:[
			^ self error: aString 
				, ' is already used as a variable name in class ' 
				, subclass name]].
	classPool == nil ifTrue: [classPool _ Dictionary new].
	(classPool includesKey: symbol) ifFalse: 
		["Pick up any refs in Undeclared"
		classPool declare: symbol from: Undeclared.
		SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! !

!Class methodsFor: 'class variables' stamp: 'al 9/3/2004 14:25'!
allClassVarNames
	"Answer a Set of the names of the receiver's class variables, including those
	defined in the superclasses of the receiver."

	| aSet |
	self superclass == nil
		ifTrue: 
			[^self classVarNames]  "This is the keys so it is a new Set."
		ifFalse: 
			[aSet _ self superclass allClassVarNames.
			aSet addAll: self classVarNames.
			^aSet]! !

!Class methodsFor: 'class variables' stamp: 'al 9/3/2004 14:25'!
classVarNames
	"Answer a Set of the names of the class variables defined in the receiver."

	^self classPool keys! !

!Class methodsFor: 'class variables' stamp: 'tk 3/15/98 20:19'!
ensureClassPool

	classPool ifNil: [classPool _ Dictionary new].! !

!Class methodsFor: 'class variables' stamp: 'bf 1/12/2006 10:44'!
removeClassVarName: aString 
	"Remove the class variable whose name is the argument, aString, from 
	the names defined in the receiver, a class. Create an error notification if 
	aString is not a class variable or if it is still being used in the code of 
	the class."

	| aSymbol |
	aSymbol _ aString asSymbol.
	(classPool includesKey: aSymbol)
		ifFalse: [^self error: aString, ' is not a class variable'].
	self withAllSubclasses do:[:subclass |
		(Array with: subclass with: subclass class) do:[:classOrMeta |
			(classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol))
				isEmpty ifFalse: [
					InMidstOfFileinNotification signal ifTrue: [
						Transcript cr; show: self name, ' (' , aString , ' is Undeclared) '.
						^Undeclared declare: aSymbol from: classPool].
					(self confirm: (aString,' is still used in code of class ', classOrMeta name,
						'.\Is it okay to move it to Undeclared?') withCRs)
						ifTrue:[^Undeclared declare: aSymbol from: classPool]
						ifFalse:[^self]]]].
	classPool removeKey: aSymbol.
	classPool isEmpty ifTrue: [classPool _ nil].
! !


!Class methodsFor: 'compiling' stamp: 'md 3/5/2006 23:47'!
binding

	^ Smalltalk associationAt: name ifAbsent: [nil -> self]
! !

!Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:06'!
bindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver"
	| aSymbol binding |
	aSymbol := varName asSymbol.

	"First look in classVar dictionary."
	binding := self classPool bindingOf: aSymbol.
	binding ifNotNil:[^binding].

	"Next look in shared pools."
	self sharedPools do:[:pool | 
		binding := pool bindingOf: aSymbol.
		binding ifNotNil:[^binding].
	].

	"Next look in declared environment."
	binding := self environment bindingOf: aSymbol.
	binding ifNotNil:[^binding].

	"Finally look higher up the superclass chain and fail at the end."
	superclass == nil
		ifTrue: [^ nil]
		ifFalse: [^ superclass bindingOf: aSymbol].

! !

!Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:13'!
canFindWithoutEnvironment: varName
	"This method is used for analysis of system structure -- see senders."
	"Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment."

	"First look in classVar dictionary."
	(self classPool bindingOf: varName) ifNotNil:[^true].

	"Next look in shared pools."
	self sharedPools do:[:pool | 
		(pool bindingOf: varName) ifNotNil:[^true].
	].

	"Finally look higher up the superclass chain and fail at the end."
	superclass == nil
		ifTrue: [^ false]
		ifFalse: [^ (superclass bindingOf: varName) notNil].

! !

!Class methodsFor: 'compiling' stamp: 'ar 7/14/1999 04:56'!
compileAll
	super compileAll.
	self class compileAll.! !

!Class methodsFor: 'compiling'!
compileAllFrom: oldClass
	"Recompile all the methods in the receiver's method dictionary (not the
	subclasses). Also recompile the methods in the metaclass."

	super compileAllFrom: oldClass.
	self class compileAllFrom: oldClass class! !

!Class methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:24'!
possibleVariablesFor: misspelled continuedFrom: oldResults

	| results |
	results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults.
	self sharedPools do: [:pool | 
		results _ misspelled correctAgainstDictionary: pool continuedFrom: results ].
	superclass == nil
		ifTrue: 
			[ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ]
		ifFalse:
			[ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! !


!Class methodsFor: 'copying' stamp: 'di 2/17/2000 22:43'!
copy 
	| newClass |
	newClass _ self class copy new
		superclass: superclass
		methodDict: self methodDict copy
		format: format
		name: name
		organization: self organization copy
		instVarNames: instanceVariables copy
		classPool: classPool copy
		sharedPools: sharedPools.
	Class instSize+1 to: self class instSize do:
		[:offset | newClass instVarAt: offset put: (self instVarAt: offset)].
	^ newClass! !


!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'!
fileOut
	"Create a file whose name is the name of the receiver with '.st' as the 
	extension, and file a description of the receiver onto it."
	^ self fileOutAsHtml: false! !

!Class methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 17:35'!
fileOutAsHtml: useHtml
	"File a description of the receiver onto a new file whose base name is the name of the receiver."

	| internalStream |
	internalStream _ WriteStream on: (String new: 100).
	internalStream header; timeStamp.

	self sharedPools size > 0 ifTrue: [
		self shouldFileOutPools
			ifTrue: [self fileOutSharedPoolsOn: internalStream]].
	self fileOutOn: internalStream moveSource: false toFile: 0.
	internalStream trailer.

	FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: useHtml.
! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:00'!
fileOutInitializerOn: aStream
	^self class fileOutInitializerOn: aStream! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the receiver on aFileStream. If the boolean argument,
	moveSource, is true, then set the trailing bytes to the position of aFileStream and
	to fileIndex in order to indicate where to find the source code."
	^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
	"File a description of the receiver on aFileStream. If the boolean argument,
	moveSource, is true, then set the trailing bytes to the position of aFileStream and
	to fileIndex in order to indicate where to find the source code."

	Transcript cr; show: self name.
	super
		fileOutOn: aFileStream
		moveSource: moveSource
		toFile: fileIndex.
	self class nonTrivial
		ifTrue:
			[aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr.
			self class
				fileOutOn: aFileStream
				moveSource: moveSource
				toFile: fileIndex
				initializing: aBool]! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'!
fileOutPool: aPool onFileStream: aFileStream 
	| aPoolName aValue |
	(aPool  isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now'].
	aPoolName _ self environment keyAtIdentityValue: aPool.
	Transcript cr; show: aPoolName.
	aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr.
	aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr.
	aPool keys asSortedCollection do: [ :aKey |
		aValue _ aPool at: aKey.
		aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put:  '.
		(aValue isKindOf: Number)
			ifTrue: [aValue printOn: aFileStream]
			ifFalse: [aFileStream nextPutAll: '('.
					aValue printOn: aFileStream.
					aFileStream nextPutAll: ')'].
		aFileStream nextPutAll: '!!'; cr].
	aFileStream cr! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'!
fileOutSharedPoolsOn: aFileStream
	"file out the shared pools of this class after prompting the user about each pool"
	| poolsToFileOut |
	poolsToFileOut _ self sharedPools select: 
		[:aPool | (self shouldFileOutPool: (self environment keyAtIdentityValue: aPool))].
	poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream].
	! !

!Class methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 17:36'!
objectForDataStream: refStrm
	"I am about to be written on an object file.  Write a reference to a class in Smalltalk instead."

	refStrm insideASegment
		ifFalse: ["Normal use"
			^ DiskProxy global: self theNonMetaClass name selector: #withClassVersion:
				args: {self classVersion}]
		ifTrue: ["recording objects to go into an ImageSegment"
			self isSystemDefined ifFalse: [^ self].		"do trace Player classes"
			(refStrm rootObject includes: self) ifTrue: [^ self].
				"is in roots, intensionally write out, ^ self"
			
			"A normal class.  remove it from references.  Do not trace."
			refStrm references removeKey: self ifAbsent: []. 	"already there"
			^ nil]
! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!
reformatAll 
	"Reformat all methods in this class.
	Leaves old code accessible to version browsing"
	super reformatAll.		"me..."
	self class reformatAll	"...and my metaclass"! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!
removeFromChanges
	"References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet.
	7/18/96 sw: call removeClassAndMetaClassChanges:"

	ChangeSet current removeClassAndMetaClassChanges: self! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!
shouldFileOutPools
	"respond with true if the user wants to file out the shared pools"
	^self confirm: 'FileOut selected sharedPools?'! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!
shouldFileOutPool: aPoolName
	"respond with true if the user wants to file out aPoolName"
	^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! !

!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'!
storeDataOn: aDataStream
	"I don't get stored.  Use a DiskProxy"

	(aDataStream insideASegment and: [self isSystemDefined not]) ifTrue: [
		^ super storeDataOn: aDataStream].	"do trace me"
	self error: 'use a DiskProxy to store a Class'! !

!Class methodsFor: 'fileIn/Out' stamp: 'ar 4/10/2005 20:27'!
withClassVersion: aVersion
	aVersion = self classVersion ifTrue:[^self].
	^self error: 'Invalid class version'! !


!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:43'!
deactivate
	"A remnant from the 3.3a modules work, retained . Does nothing, but may be overridden in Metaclasses."! !

!Class methodsFor: 'initialize-release' stamp: 'dvf 9/27/2005 17:34'!
declare: varString 
	"Declare class variables common to all instances. Answer whether 
	recompilation is advisable."

	| newVars conflicts |
	newVars _ 
		(Scanner new scanFieldNames: varString)
			collect: [:x | x asSymbol].
	newVars do:
		[:var | var first canBeGlobalVarInitial
			ifFalse: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']].
	conflicts _ false.
	classPool == nil 
		ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: 
					[:var | self removeClassVarName: var]].
	(newVars reject: [:var | self classPool includesKey: var])
		do: [:var | "adding"
			"check if new vars defined elsewhere"
			(self bindingOf: var) notNil
				ifTrue: 
					[self error: var , ' is defined elsewhere'.
					conflicts _ true]].
	newVars size > 0
		ifTrue: 
			[classPool _ self classPool.
			"in case it was nil"
			newVars do: [:var | classPool declare: var from: Undeclared]].
	^conflicts! !

!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 14:07'!
obsolete
	"Change the receiver and all of its subclasses to an obsolete class."
	self == Object 
		ifTrue: [^self error: 'Object is NOT obsolete'].
	self setName: 'AnObsolete' , self name.
	Object class instSize + 1 to: self class instSize do:
		[:i | self instVarAt: i put: nil]. "Store nil over class instVars."
	self classPool: nil.
	self sharedPools: nil.
	self class obsolete.
	super obsolete.! !

!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:35'!
removeFromSystem
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."
	self removeFromSystem: true.! !

!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:36'!
removeFromSystemUnlogged
	"Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver.  Do not log the removal either to the current change set nor to the system changes log"
	^self removeFromSystem: false! !

!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:43'!
removeFromSystem: logged
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."
	
	"keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want."

	"tell class to deactivate and unload itself-- two separate events in the module system"
	self deactivate; unload.
	self superclass ifNotNil:
		["If we have no superclass there's nothing to be remembered"
		self superclass addObsoleteSubclass: self].
	self environment forgetClass: self logged: logged.
	self obsolete.! !

!Class methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 16:09'!
sharing: poolString 
	"Set up sharedPools. Answer whether recompilation is advisable."
	| oldPools found |
	oldPools _ self sharedPools.
	sharedPools _ OrderedCollection new.
	(Scanner new scanFieldNames: poolString) do: 
		[:poolName | 
		sharedPools add: (self environment at: poolName asSymbol ifAbsent:[
			(self confirm: 'The pool dictionary ', poolName,' does not exist.',
						'\Do you want it automatically created?' withCRs)
				ifTrue:[self environment at: poolName asSymbol put: Dictionary new]
				ifFalse:[^self error: poolName,' does not exist']])].
	sharedPools isEmpty ifTrue: [sharedPools _ nil].
	oldPools do: [:pool | found _ false.
				self sharedPools do: [:p | p == pool ifTrue: [found _ true]].
				found ifFalse: [^ true "A pool got deleted"]].
	^ false! !

!Class methodsFor: 'initialize-release' stamp: 'ar 7/20/1999 11:23'!
superclass: aClass methodDictionary: mDict format: fmt
	"Basic initialization of the receiver"
	super superclass: aClass methodDictionary: mDict format: fmt.
	subclasses _ nil. "Important for moving down the subclasses field into Class"
! !

!Class methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 10:55'!
superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet 
	"Answer an instance of me, a new class, using the arguments of the 
	message as the needed information.
	Must only be sent to a new instance; else we would need Object flushCache."

	superclass _ sup.
	methodDict _ md.
	format _ ft.
	name _ nm.
	instanceVariables _ nilOrArray.
	classPool _ pool.
	sharedPools _ poolSet.
	self organization: org.! !

!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:35'!
unload
	"Sent when a the class is removed.  Does nothing, but may be overridden by (class-side) subclasses."
! !


!Class methodsFor: 'instance variables' stamp: 'al 9/3/2004 14:25'!
addInstVarName: aString
	"Add the argument, aString, as one of the receiver's instance variables."
	^(ClassBuilder new)
		name: self name
		inEnvironment: self environment
		subclassOf: self superclass
		type: self typeOfClass
		instanceVariableNames: self instanceVariablesString, ' ', aString
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category
! !

!Class methodsFor: 'instance variables' stamp: 'al 9/3/2004 14:25'!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance variables."

	| newInstVarString |
	(self instVarNames includes: aString)
		ifFalse: [self error: aString , ' is not one of my instance variables'].
	newInstVarString _ ''.
	(self instVarNames copyWithout: aString) do: 
		[:varName | newInstVarString _ newInstVarString , ' ' , varName].
	^(ClassBuilder new)
		name: self name
		inEnvironment: self environment
		subclassOf: self superclass
		type: self typeOfClass
		instanceVariableNames: newInstVarString
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category! !


!Class methodsFor: 'organization' stamp: 'di 11/16/1999 16:25'!
environment

	environment == nil ifTrue: [^ super environment].
	^ environment! !

!Class methodsFor: 'organization' stamp: 'di 12/23/1999 11:42'!
environment: anEnvironment

	environment _ anEnvironment! !


!Class methodsFor: 'pool variables' stamp: 'tpr 5/30/2003 13:04'!
addSharedPool: aSharedPool 
	"Add the argument, aSharedPool, as one of the receiver's shared pools. 
	Create an error if the shared pool is already one of the pools.
	This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses"

	(self sharedPools includes: aSharedPool)
		ifTrue: [^self error: 'This is already in my shared pool list'].
	sharedPools == nil
		ifTrue: [sharedPools _ OrderedCollection with: aSharedPool]
		ifFalse: [sharedPools add: aSharedPool]! !

!Class methodsFor: 'pool variables' stamp: 'al 9/3/2004 14:25'!
allSharedPools
	"Answer a Set of the pools the receiver shares, including those defined  
	in the superclasses of the receiver."
	| aSet | 
	^self superclass == nil
		ifTrue: [self sharedPools copy]
		ifFalse: [aSet _ self superclass allSharedPools.
			aSet addAll: self sharedPools.
			aSet]! !

!Class methodsFor: 'pool variables' stamp: 'tk 9/12/96'!
removeSharedPool: aDictionary 
	"Remove the pool dictionary, aDictionary, as one of the receiver's pool 
	dictionaries. Create an error notification if the dictionary is not one of 
	the pools.
	: Note that it removes the wrong one if there are two empty Dictionaries in the list."

	| satisfiedSet workingSet aSubclass |
	(self sharedPools includes: aDictionary)
		ifFalse: [^self error: 'the dictionary is not in my pool'].

	"first see if it is declared in a superclass in which case we can remove it."
	(self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty
		ifFalse: [sharedPools remove: aDictionary.
				sharedPools isEmpty ifTrue: [sharedPools _ nil].
				^self]. 

	"second get all the subclasses that reference aDictionary through me rather than a 
	superclass that is one of my subclasses."

	workingSet _ self subclasses asOrderedCollection.
	satisfiedSet _ Set new.
	[workingSet isEmpty] whileFalse:
		[aSubclass _ workingSet removeFirst.
		(aSubclass sharedPools includes: aDictionary)
			ifFalse: 
				[satisfiedSet add: aSubclass.
				workingSet addAll: aSubclass subclasses]].

	"for each of these, see if they refer to any of the variables in aDictionary because 
	if they do, we can not remove the dictionary."
	satisfiedSet add: self.
	satisfiedSet do: 
		[:sub | 
		aDictionary associationsDo: 
			[:aGlobal | 
			(sub whichSelectorsReferTo: aGlobal) isEmpty 
				ifFalse: [^self error: aGlobal key 
								, ' is still used in code of class '
								, sub name]]].
	sharedPools remove: aDictionary.
	sharedPools isEmpty ifTrue: [sharedPools _ nil]! !

!Class methodsFor: 'pool variables'!
sharedPools
	"Answer a Set of the pool dictionaries declared in the receiver."

	sharedPools == nil
		ifTrue: [^OrderedCollection new]
		ifFalse: [^sharedPools]! !

!Class methodsFor: 'pool variables' stamp: 'al 9/3/2004 13:41'!
sharedPools: aCollection
	sharedPools _ aCollection! !


!Class methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:46'!
isSelfEvaluating
	^ true! !


!Class methodsFor: 'subclass creation' stamp: 'sd 3/28/2003 15:24'!
newSubclass
	| i className |
	i _ 1.
	[className _ (self name , i printString) asSymbol.
	 self environment includesKey: className]
		whileTrue: [i _ i + 1].

	^ self subclass: className
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: Object categoryForUniclasses

"Point newSubclass new"! !

!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'!
subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver)."
	^(ClassBuilder new)
		superclass: self
		subclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'!
subclass: t uses: aTraitCompositionOrArray instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat 
	| newClass copyOfOldClass |
	copyOfOldClass _ self copy.
	newClass _ self
		subclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat.
		
	
	newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition.
	SystemChangeNotifier uniqueInstance
		classDefinitionChangedFrom: copyOfOldClass to: newClass.
	^newClass! !

!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'!
variableByteSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable byte-sized nonpointer variables."
	^(ClassBuilder new)
		superclass: self
		variableByteSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'!
variableByteSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable byte-sized nonpointer variables."
	
	| newClass copyOfOldClass |
	copyOfOldClass _ self copy.
	newClass _ self
		variableByteSubclass: t 
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat.
	
	newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition.
	SystemChangeNotifier uniqueInstance
		classDefinitionChangedFrom: copyOfOldClass to: newClass.
	^newClass
! !

!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'!
variableSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable pointer variables."
	^(ClassBuilder new)
		superclass: self
		variableSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:17'!
variableSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable pointer variables."
	
	| newClass copyOfOldClass |
	copyOfOldClass _ self copy.
	newClass _ self
		variableSubclass: t 
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat.
	
	newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition.
	SystemChangeNotifier uniqueInstance
		classDefinitionChangedFrom: copyOfOldClass to: newClass.
	^newClass	! !

!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'!
variableWordSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable word-sized nonpointer variables."
	^(ClassBuilder new)
		superclass: self
		variableWordSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'!
variableWordSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable word-sized nonpointer variables."
	
	| newClass copyOfOldClass |
	copyOfOldClass _ self copy.
	newClass _ self
		variableWordSubclass: t 
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat.
	
	newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition.
	SystemChangeNotifier uniqueInstance
		classDefinitionChangedFrom: copyOfOldClass to: newClass.
	^newClass	
! !

!Class methodsFor: 'subclass creation' stamp: 'dwh 11/20/1999 23:44'!
weakSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have weak indexable pointer variables."
	^(ClassBuilder new)
		superclass: self
		weakSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'!
weakSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have weak indexable pointer variables."
	
	| newClass copyOfOldClass |
	copyOfOldClass _ self copy.
	newClass _ self
		weakSubclass: t 
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat.
	
	newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition.
	SystemChangeNotifier uniqueInstance
		classDefinitionChangedFrom: copyOfOldClass to: newClass.
	^newClass	
! !


!Class methodsFor: 'testing'!
hasMethods
	"Answer a Boolean according to whether any methods are defined for the 
	receiver (includes whether there are methods defined in the receiver's 
	metaclass)."

	^super hasMethods or: [self class hasMethods]! !

!Class methodsFor: 'testing' stamp: 'al 6/5/2006 13:13'!
isObsolete
	"Return true if the receiver is obsolete."
	^(self environment at: name ifAbsent: [nil]) ~~ self! !

!Class methodsFor: 'testing' stamp: 'tk 8/12/1999 15:47'!
isSystemDefined
	"Answer true if the receiver is a system-defined class, and not a UniClass (an instance-specific lightweight class)"

	^ self == self officialClass! !

!Class methodsFor: 'testing' stamp: 'tk 8/12/1999 15:49'!
officialClass
	"I am not a UniClass.  (See Player officialClass).  Return the class you use to make new subclasses."

	^ self! !


!Class methodsFor: 'traits' stamp: 'NS 4/12/2004 16:48'!
applyChangesOfNewTraitCompositionReplacing: oldComposition
	"See Trait>>applyChangesOfNewTraitCompositionReplacing:"
	| changedSelectors |
	changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition.
	self classSide
		noteNewBaseTraitCompositionApplied: self traitComposition.
	^ changedSelectors! !


!Class methodsFor: '*eToys-class name' stamp: 'sw 12/1/2000 20:40'!
uniqueNameForReference
	"Answer a unique name by which the receiver can be referred to from user scripts, for example"

	^ name! !


!Class methodsFor: '*monticello' stamp: 'al 3/26/2006 21:31'!
asClassDefinition
	^ MCClassDefinition
		name: self name
		superclassName: self superclass name
		traitComposition: self traitCompositionString
		classTraitComposition: self class traitCompositionString
		category: self category 
		instVarNames: self instVarNames
		classVarNames: self classVarNames
		poolDictionaryNames: self poolDictionaryNames
		classInstVarNames: self class instVarNames
		type: self typeOfClass
		comment: self organization classComment	 asString
		commentStamp: self organization commentStamp	! !

!Class methodsFor: '*monticello' stamp: 'avi 3/10/2004 13:32'!
classDefinitions
	^ Array with: self asClassDefinition! !

!Class methodsFor: '*monticello' stamp: 'ab 4/14/2003 22:30'!
poolDictionaryNames
	^ self sharedPools collect: [:ea | self environment keyAtIdentityValue: ea]! !


!Class methodsFor: 'private' stamp: 'ar 7/15/1999 15:37'!
setName: aSymbol
	"Private - set the name of the class"
	name _ aSymbol.! !

!Class methodsFor: 'private' stamp: 'sd 2/1/2004 15:18'!
spaceUsed

	"Object spaceUsed"
	^ super spaceUsed + self class spaceUsed! !


!Class methodsFor: '*ob-standard-converting' stamp: 'dvf 8/15/2005 17:52'!
asClassSideNode
	^OBMetaclassNode on: self! !

!Class methodsFor: '*ob-standard-converting' stamp: 'dvf 9/1/2005 13:51'!
asNode
	^OBClassNode on: self! !

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

Class class
	instanceVariableNames: ''!

!Class class methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 17:30'!
fileOutPool: aString
	"file out the global pool named aString"
	
	| internalStream |
	internalStream _ WriteStream on: (String new: 1000).
	self new fileOutPool: (self environment at: aString asSymbol) onFileStream: internalStream.

	FileStream writeSourceCodeFrom: internalStream baseName: aString isSt: true useHtml: false.! !


!Class class methodsFor: 'instance creation' stamp: 'di 6/7/2000 22:01'!
template: aSystemCategoryName 
	"Answer an expression that can be edited and evaluated in order to define a new class."

	^ self templateForSubclassOf: Object name category: aSystemCategoryName ! !

!Class class methodsFor: 'instance creation' stamp: 'al 1/9/2006 18:05'!
templateForSubclassOf: priorClassName category: systemCategoryName 
	"Answer an expression that can be edited and evaluated in order to define a new class, given that the class previously looked at was as given"

	^ priorClassName asString, ' subclass: #NameOfSubclass
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''' , systemCategoryName asString , ''''! !


!Class class methodsFor: 'inquiries' stamp: 'md 2/20/2006 22:59'!
rootsOfTheWorld
	"return a collection of classes which have a nil superclass"
	^(Smalltalk select: [:each | each isBehavior and: [each superclass isNil]]) asOrderedCollection! !
Object subclass: #ClassBuilder
	instanceVariableNames: 'environ classMap instVarMap progress maxClassIndex currentClassIndex'
	classVariableNames: 'QuietMode'
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!ClassBuilder commentStamp: 'ar 2/27/2003 22:55' prior: 0!
Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more.

You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works.

Implementation notes:
ClassBuilder relies on the assumption that it can see ALL subclasses of some class. If there are any existing subclasses of some class, regardless of whether they have instances or not, regardless of whether they are considered obsolete or not, ClassBuilder MUST SEE THEM.
!


!ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:20'!
class: oldClass instanceVariableNames: instVarString unsafe: unsafe
	"This is the basic initialization message to change the definition of
	an existing Metaclass"
	| instVars newClass needNew copyOfOldClass |
	environ _ oldClass environment.
	instVars _ Scanner new scanFieldNames: instVarString.
	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil].
		(self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]].
	"See if we need a new subclass or not"
	needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass.
	needNew ifNil:[^nil]. "some error"
	needNew ifFalse:[^oldClass]. "no new class needed"

	"Create the new class"
	copyOfOldClass _ oldClass copy.
	newClass _ self 
		newSubclassOf: oldClass superclass 
		type: oldClass typeOfClass
		instanceVariables: instVars
		from: oldClass.
		
	newClass _ self recompile: false from: oldClass to: newClass mutate: false.
	self doneCompiling: newClass.
	SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/29/1999 15:34'!
name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category
	"Define a new class in the given environment"
	^self 
		name: className 
		inEnvironment: env 
		subclassOf: newSuper 
		type: type 
		instanceVariableNames: instVarString 
		classVariableNames: classVarString 
		poolDictionaries: poolString 
		category: category
		unsafe: false! !

!ClassBuilder methodsFor: 'class definition' stamp: 'rw 4/3/2006 22:14'!
name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe
	"Define a new class in the given environment.
	If unsafe is true do not run any validation checks.
	This facility is provided to implement important system changes."
	| oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory |
 
	environ := env.
	instVars := Scanner new scanFieldNames: instVarString.
	classVars := (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol].

	"Validate the proposed name"
	unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]].
	oldClass := env at: className ifAbsent:[nil].
	oldClass isBehavior 
		ifFalse: [oldClass := nil]  "Already checked in #validateClassName:"
		ifTrue: [
			copyOfOldClass := oldClass copy.
			copyOfOldClass superclass addSubclass: copyOfOldClass].
	
	
	[unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil].
		(self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]].

	"See if we need a new subclass"
	needNew := self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass.
	needNew == nil ifTrue:[^nil]. "some error"

	(needNew and:[unsafe not]) ifTrue:[
		"Make sure we don't redefine any dangerous classes"
		(self tooDangerousClasses includes: oldClass name) ifTrue:[
			self error: oldClass name, ' cannot be changed'.
		].
		"Check if the receiver should not be redefined"
		(oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[
			self notify: oldClass name asText allBold, 
						' should not be redefined. \Proceed to store over it.' withCRs]].

	needNew ifTrue:[
		"Create the new class"
		newClass := self 
			newSubclassOf: newSuper 
			type: type 
			instanceVariables: instVars
			from: oldClass.
		newClass == nil ifTrue:[^nil]. "Some error"
		newClass setName: className.
	] ifFalse:[
		"Reuse the old class"
		newClass := oldClass.
	].

	"Install the class variables and pool dictionaries... "
	force := (newClass declare: classVarString) | (newClass sharing: poolString).

	"... classify ..."
	newCategory := category asSymbol.
	organization := environ ifNotNil:[environ organization].
	oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol].
	organization classify: newClass name under: newCategory.
	newClass environment: environ.

	"... recompile ..."
	newClass := self recompile: force from: oldClass to: newClass mutate: false.

	"... export if not yet done ..."
	(environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[
		[environ at: newClass name put: newClass]
			on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true].
		Smalltalk flushClassNameCache.
	].


	newClass doneCompiling.
	"... notify interested clients ..."
	oldClass isNil ifTrue: [
		SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory.
		^ newClass].
	newCategory ~= oldCategory 
		ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category]
		ifFalse: [SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.].
] ensure: 
		[copyOfOldClass ifNotNil: [copyOfOldClass superclass removeSubclass: copyOfOldClass].
		Behavior flushObsoleteSubclasses.
		].
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 02:57'!
needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass
	"Answer whether we need a new subclass to conform to the requested changes"
	| newFormat |
	"Compute the format of the new class"
	newFormat _ 
		self computeFormat: type 
			instSize: instVars size 
			forSuper: newSuper 
			ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]).
	newFormat == nil ifTrue:[^nil].

	"Check if we really need a new subclass"
	oldClass ifNil:[^true]. "yes, it's a new class"
	newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change"
	newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change"
	instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change"

	^false
! !

!ClassBuilder methodsFor: 'class definition' stamp: 'al 7/3/2006 15:53'!
newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass
	"Create a new subclass of the given superclass with the given specification."
	| newFormat newClass |
	"Compute the format of the new class"
	newFormat := 
		self computeFormat: type 
			instSize: instVars size 
			forSuper: newSuper 
			ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]).

	newFormat == nil ifTrue:[^nil].

	(oldClass == nil or:[oldClass isMeta not]) 
		ifTrue:[newClass := self privateNewSubclassOf: newSuper from: oldClass]
		ifFalse:[newClass := oldClass clone].

	newClass 
		superclass: newSuper
		methodDictionary: MethodDictionary new
		format: newFormat;
		setInstVarNames: instVars.

	oldClass ifNotNil:[
		newClass organization: oldClass organization.
		"Recompile the new class"
		oldClass hasMethods 
			ifTrue:[newClass compileAllFrom: oldClass].

		oldClass hasTraitComposition ifTrue: [
			newClass setTraitComposition: oldClass traitComposition copyTraitExpression ].
		oldClass class hasTraitComposition ifTrue: [
			newClass class setTraitComposition: oldClass class traitComposition copyTraitExpression ].
		
		self recordClass: oldClass replacedBy: newClass.
	].

	(oldClass == nil or:[oldClass isObsolete not]) 
		ifTrue:[newSuper addSubclass: newClass]
		ifFalse:[newSuper addObsoleteSubclass: newClass].

	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:53'!
recompile: force from: oldClass to: newClass mutate: forceMutation
	"Do the necessary recompilation after changine oldClass to newClass.
	If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass
	and all its subclasses. If forceMutation is true force a mutation even
	if oldClass and newClass are the same."

	oldClass == nil ifTrue:[^ newClass].

	(newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[
		^newClass].

	currentClassIndex _ 0.
	maxClassIndex _ oldClass withAllSubclasses size.

	(oldClass == newClass and:[forceMutation not]) ifTrue:[
		"Recompile from newClass without mutating"
		self informUserDuring:[
			newClass isSystemDefined ifFalse:[progress _ nil].
			newClass withAllSubclassesDo:[:cl|
				self showProgressFor: cl.
				cl compileAll]].
		^newClass].
	"Recompile and mutate oldClass to newClass"
	self informUserDuring:[
		newClass isSystemDefined ifFalse:[progress _ nil].
		self mutate: oldClass to: newClass.
	].
	^oldClass "now mutated to newClass"! !

!ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:21'!
silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName
	"Move the instvar from srcClass to dstClass.
	Do not perform any checks."
	| srcVars dstVars dstIndex newClass copyOfSrcClass copyOfDstClass |
	copyOfSrcClass _ srcClass copy.
	copyOfDstClass _ dstClass copy.
	
	srcVars _ srcClass instVarNames copyWithout: instVarName.
	srcClass == dstClass
		ifTrue:[dstVars _ srcVars]
		ifFalse:[dstVars _ dstClass instVarNames].
	dstIndex _ dstVars indexOf: prevInstVarName.
	dstVars _ (dstVars copyFrom: 1 to: dstIndex),
				(Array with: instVarName),
				(dstVars copyFrom: dstIndex+1 to: dstVars size).
	instVarMap at: srcClass name put: srcVars.
	instVarMap at: dstClass name put: dstVars.
	(srcClass inheritsFrom: dstClass) ifTrue:[
		newClass _ self reshapeClass: dstClass toSuper: dstClass superclass.
		self recompile: false from: dstClass to: newClass mutate: true.
	] ifFalse:[
		(dstClass inheritsFrom: srcClass) ifTrue:[
			newClass _ self reshapeClass: srcClass toSuper: srcClass superclass.
			self recompile: false from: srcClass to: newClass mutate: true.
		] ifFalse:[ "Disjunct hierarchies"
			srcClass == dstClass ifFalse:[
				newClass _ self reshapeClass: dstClass toSuper: dstClass superclass.
				self recompile: false from: dstClass to: newClass mutate: true.
			].
			newClass _ self reshapeClass: srcClass toSuper: srcClass superclass.
			self recompile: false from: srcClass to: newClass mutate: true.
		].
	].
	self doneCompiling: srcClass.
	self doneCompiling: dstClass.
	SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfSrcClass to: srcClass.
	SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfDstClass to: dstClass.! !


!ClassBuilder methodsFor: 'class format' stamp: 'ar 9/10/1999 12:55'!
computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex
	"Compute the new format for making oldClass a subclass of newSuper.
	Return the format or nil if there is any problem."
	| instSize isVar isWords isPointers isWeak |
	instSize _ newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
	instSize > 254 ifTrue:[
		self error: 'Class has too many instance variables (', instSize printString,')'.
		^nil].
	type == #compiledMethod
		ifTrue:[^CompiledMethod instSpec].
	type == #normal ifTrue:[isVar _ isWeak _ false. isWords _ isPointers _ true].
	type == #bytes ifTrue:[isVar _ true. isWords _ isPointers _ isWeak _ false].
	type == #words ifTrue:[isVar _ isWords _ true. isPointers _ isWeak _ false].
	type == #variable ifTrue:[isVar _ isPointers _ isWords _ true. isWeak _ false].
	type == #weak ifTrue:[isVar _ isWeak _ isWords _ isPointers _ true].
	(isPointers not and:[instSize > 0]) ifTrue:[
		self error:'A non-pointer class cannot have instance variables'.
		^nil].
	^(self format: instSize 
		variable: isVar 
		words: isWords 
		pointers: isPointers 
		weak: isWeak) + (ccIndex bitShift: 11).! !

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


!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 22:44'!
mutate: oldClass to: newClass
	"Mutate the old class and subclasses into newClass and subclasses.
	Note: This method is slightly different from: #mutate:toSuper: since
	here we are at the root of reshaping and have two distinct roots."
	| newSubclass |
	self showProgressFor: oldClass.
	"Convert the subclasses"
	oldClass subclasses do:[:oldSubclass| 
		newSubclass _ self reshapeClass: oldSubclass toSuper: newClass.
		self mutate: oldSubclass to: newSubclass.
	].
	"And any obsolete ones"
	oldClass obsoleteSubclasses do:[:oldSubclass|
		oldSubclass ifNotNil:[
			newSubclass _ self reshapeClass: oldSubclass toSuper: newClass.
			self mutate: oldSubclass to: newSubclass.
		].
	].
	self update: oldClass to: newClass.
	^newClass! !

!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 9/22/2002 03:16'!
reshapeClass: oldClass toSuper: newSuper
	"Reshape the given class to the new super class. Recompile all the methods in the newly created class. Answer the new class."
	| instVars |

	"ar 9/22/2002: The following is a left-over from some older code. 
	I do *not* know why we uncompact oldClass here. If you do, then 
	please let me know so I can put a comment here..."
	oldClass becomeUncompact.

	instVars _ instVarMap at: oldClass name ifAbsent:[oldClass instVarNames].

	^self newSubclassOf: newSuper 
			type: oldClass typeOfClass 
			instanceVariables: instVars 
			from: oldClass! !

!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 23:42'!
update: oldClass to: newClass
	"Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple in its implementation and surprisingly complex in its nuances and potentially bad side effects. 
	We can rely on two assumptions (which are critical):
		#1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards)
		#2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances.
	Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry.
	"
	| meta |
	meta _ oldClass isMeta.
	"Note: Everything from here on will run without the ability to get interrupted
	to prevent any other process to create new instances of the old class."
	[
		"Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy).
		Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below."

		oldClass superclass removeSubclass: oldClass.
		oldClass superclass removeObsoleteSubclass: oldClass.

		"Convert the instances of oldClass into instances of newClass"
		newClass updateInstancesFrom: oldClass.

		meta
			ifTrue:[oldClass becomeForward: newClass]
			ifFalse:[(Array with: oldClass with: oldClass class)
						elementsForwardIdentityTo:
							(Array with: newClass with: newClass class)].

		Smalltalk garbageCollect.

		"Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout).

		The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives:

		On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants.

		Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear).

		Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc.

		Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it."

	] valueUnpreemptively.
! !


!ClassBuilder methodsFor: 'initialize' stamp: 'ar 3/3/2001 00:29'!
doneCompiling: aClass
	"The receiver has finished modifying the class hierarchy.
	Do any necessary cleanup."
	aClass doneCompiling.
	Behavior flushObsoleteSubclasses.! !

!ClassBuilder methodsFor: 'initialize' stamp: 'ar 8/29/1999 12:32'!
initialize
	environ _ Smalltalk.
	instVarMap _ IdentityDictionary new.! !


!ClassBuilder methodsFor: 'public' stamp: 'ar 8/29/1999 15:38'!
class: oldClass instanceVariableNames: instVarString
	"This is the basic initialization message to change the definition of
	an existing Metaclass"
	oldClass isMeta ifFalse:[^self error: oldClass name, 'is not a Metaclass'].
	^self class: oldClass instanceVariableNames: instVarString unsafe: false! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:40'!
moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName
	"Move the given instVar from srcClass to dstClass"
	(srcClass instVarNames includes: instVarName)
		ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name].
	(prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName])
		ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name].
	(srcClass inheritsFrom: dstClass) ifTrue:[
		"Move the instvar up the hierarchy."
		(self validateClass: srcClass forMoving: instVarName upTo: dstClass)
			ifFalse:[^false].
	].
	(dstClass inheritsFrom: srcClass) ifTrue:[
		"Move the instvar down the hierarchy"
		(self validateClass: srcClass forMoving: instVarName downTo: dstClass)
			ifFalse:[^false].
	].
	^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'!
superclass: newSuper
	subclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class."
	^self 
		name: t
		inEnvironment: newSuper environment
		subclassOf: newSuper
		type: newSuper typeOfClass
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'!
superclass: aClass
	variableByteSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable byte-sized nonpointer variables."
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields'].
	(aClass isVariable and: [aClass isWords])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields'].

	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: #bytes
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'!
superclass: aClass
	variableSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable pointer variables."
	aClass isBits 
		ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: #variable
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'!
superclass: aClass
	variableWordSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable word-sized nonpointer variables."
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a word subclass of a class with named fields'].
	(aClass isVariable and: [aClass isBytes])
		ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields'].

	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: #words
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'!
superclass: aClass
	weakSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have weak indexable pointer variables."
	aClass isBits 
		ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: #weak
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !


!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:41'!
validateClass: srcClass forMoving: iv downTo: dstClass
	"Make sure that we don't have any accesses to the instVar left"
	srcClass withAllSubclassesDo:[:cls|
		(cls == dstClass or:[cls inheritsFrom: dstClass]) ifFalse:[
			cls forgetDoIts.
			(cls whichSelectorsAccess: iv) isEmpty ifFalse:[
				self notify: (iv printString asText allBold), ' is still used in ', cls name asText allBold,'.
Proceed to move it to Undeclared'.
			].
		].
	].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:39'!
validateClass: srcClass forMoving: iv upTo: dstClass
	"Make sure we don't have this instvar already"
	dstClass withAllSubclassesDo:[:cls|
		(cls == srcClass or:[cls inheritsFrom: srcClass]) ifFalse:[
			cls isPointers ifFalse:[
				self error: dstClass name, ' cannot have instance variables'.
				^false].
			cls instSize >= 254 ifTrue:[
				self error: cls name, ' has more than 254 instance variables'.
				^false].
			(cls instVarNames includes: iv) ifTrue:[
				self notify: (iv printString asText allBold),' is defined in ', cls name asText allBold,'
Proceed to move it up to ', dstClass name asText allBold,' as well'.
				instVarMap at: cls name put: (cls instVarNames copyWithout: iv)].
		].
	].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'yo 11/11/2002 10:22'!
validateClassName: aString
	"Validate the new class name"
	aString first canBeGlobalVarInitial ifFalse:[
		self error: 'Class names must be capitalized'.
		^false].
	environ at: aString ifPresent:[:old|
		(old isKindOf: Behavior) ifFalse:[
			self notify: aString asText allBold, 
						' already exists!!\Proceed will store over it.' withCRs]].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:48'!
validateClassvars: classVarArray from: oldClass forSuper: newSuper
	"Check if any of the classVars of oldClass conflict with the new superclass"
	| usedNames classVars temp |
	classVarArray isEmpty ifTrue:[^true]. "Okay"

	"Validate the class var names"
	usedNames _ classVarArray asSet.
	usedNames size = classVarArray size 
		ifFalse:[	classVarArray do:[:var|
					usedNames remove: var ifAbsent:[temp _ var]].
				self error: temp,' is multiply defined'. ^false].
	(usedNames includesAnyOf: self reservedNames) 
		ifTrue:[	self reservedNames do:[:var|
					(usedNames includes: var) ifTrue:[temp _ var]].
				self error: temp,' is a reserved name'. ^false].

	newSuper == nil ifFalse:[
		usedNames _ newSuper allClassVarNames asSet.
		classVarArray do:[:iv|
			(usedNames includes: iv) ifTrue:[
				newSuper withAllSuperclassesDo:[:cl|
					(cl classVarNames includes: iv) ifTrue:[temp _ cl]].
				self error: iv, ' is already defined in ', temp name.
				^false]]].

	oldClass == nil ifFalse:[
		usedNames _ Set new: 20.
		oldClass allSubclassesDo:[:cl| usedNames addAll: cl classVarNames].
		classVars _ classVarArray.
		newSuper == nil ifFalse:[classVars _ classVars, newSuper allClassVarNames asArray].
		classVars do:[:iv|
			(usedNames includes: iv) ifTrue:[
				self error: iv, ' is already defined in a subclass of ', oldClass name.
				^false]]].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ajh 10/17/2002 11:10'!
validateInstvars: instVarArray from: oldClass forSuper: newSuper
	"Check if any of the instVars of oldClass conflict with the new superclass"
	| instVars usedNames temp |
	instVarArray isEmpty ifTrue:[^true]. "Okay"
	newSuper allowsSubInstVars ifFalse: [
		self error: newSuper printString, ' does not allow subclass inst vars. See allowsSubInstVars.'. ^ false].

	"Validate the inst var names"
	usedNames _ instVarArray asSet.
	usedNames size = instVarArray size 
		ifFalse:[	instVarArray do:[:var|
					usedNames remove: var ifAbsent:[temp _ var]].
				self error: temp,' is multiply defined'. ^false].
	(usedNames includesAnyOf: self reservedNames) 
		ifTrue:[	self reservedNames do:[:var|
					(usedNames includes: var) ifTrue:[temp _ var]].
				self error: temp,' is a reserved name'. ^false].

	newSuper == nil ifFalse:[
		usedNames _ newSuper allInstVarNames asSet.
		instVarArray do:[:iv|
			(usedNames includes: iv) ifTrue:[
				newSuper withAllSuperclassesDo:[:cl|
					(cl instVarNames includes: iv) ifTrue:[temp _ cl]].
				self error: iv,' is already defined in ', temp name.
				^false]]].
	oldClass == nil ifFalse:[
		usedNames _ Set new: 20.
		oldClass allSubclassesDo:[:cl| usedNames addAll: cl instVarNames].
		instVars _ instVarArray.
		newSuper == nil ifFalse:[instVars _ instVars, newSuper allInstVarNames].
		instVars do:[:iv|
			(usedNames includes: iv) ifTrue:[
				self error: iv, ' is already defined in a subclass of ', oldClass name.
				^false]]].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:13'!
validateSubclass: subclass canKeepLayoutFrom: oldClass forSubclassFormat: newType 
	"Returns whether the immediate subclasses of oldClass can keep its layout"
	"Note: Squeak does not appear to model classFormat relationships.. so I'm putting some logic here. bkv 4/2/2003"

	 "isWeak implies isVariant"					
	 (oldClass isVariable and: [ subclass isWeak ])
		ifFalse: [ "In general we discourage format mis-matches"
				  (subclass typeOfClass == newType) 
				   	ifFalse: [ self error: subclass name,' cannot be recompiled'.
							  ^ false ]].
	^ true! !

!ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:19'!
validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize
	"Validate the # of instVars and the format of the subclasses"
	| deltaSize |
	oldClass == nil ifTrue: [^ true]. "No subclasses"
	"Compute the # of instvars needed for all subclasses"
	deltaSize _ newInstSize.
	(oldClass notNil)
		ifTrue: [deltaSize _ deltaSize - oldClass instVarNames size].
	(newSuper notNil)
		ifTrue: [deltaSize _ deltaSize + newSuper instSize].
	(oldClass notNil and: [oldClass superclass notNil]) 
		ifTrue: [deltaSize _ deltaSize - oldClass superclass instSize].
	(oldClass == nil)
		 ifTrue: [ (deltaSize > 254)
					ifTrue: [ self error: 'More than 254 instance variables'.
							^ false].
				  ^ true].

	oldClass withAllSubclassesDo: [:sub |  ( sub instSize + deltaSize > 254 )
											ifTrue: [ self error: sub name,' has more than 254 instance variables'.
					 								^ false].

										"If we get this far, check whether the immediate subclasses of oldClass can keep its layout."
               							(newType ~~ #normal) 
											ifTrue: [ self validateSubclass: sub canKeepLayoutFrom: oldClass forSubclassFormat: newType ]].

	^ true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:50'!
validateSuperclass: aSuperClass forSubclass: aClass
	"Check if it is okay to use aSuperClass as the superclass of aClass"
	aClass == nil ifTrue:["New class"
		(aSuperClass == nil or:[aSuperClass isBehavior and:[aSuperClass isMeta not]])
			ifFalse:[self error: aSuperClass name,' is not a valid superclass'.
					^false].
		^true].
	aSuperClass == aClass superclass ifTrue:[^true]. "No change"
	(aClass isMeta) "Not permitted - meta class hierarchy is derived from class hierarchy"
		ifTrue:[^self error: aClass name, ' must inherit from ', aClass superclass name].
	"Check for circular references"
	(aSuperClass ~~ nil and:[aSuperClass == aClass or:[aSuperClass inheritsFrom: aClass]])
		ifTrue:[self error: aSuperClass name,' inherits from ', aClass name.
				^false].
	^true! !


!ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 13:03'!
informUserDuring: aBlock
	self class isSilent ifTrue:[^aBlock value].
	Utilities informUserDuring:[:bar|
		progress _ bar.
		aBlock value].
	progress _ nil.! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'!
privateNewSubclassOf: newSuper
	"Create a new meta and non-meta subclass of newSuper"
	"WARNING: This method does not preserve the superclass/subclass invariant!!"
	| newSuperMeta newMeta |
	newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class].
	newMeta _ Metaclass new.
	newMeta 
		superclass: newSuperMeta 
		methodDictionary: MethodDictionary new 
		format: newSuperMeta format.
	^newMeta new
! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'!
privateNewSubclassOf: newSuper from: oldClass
	"Create a new meta and non-meta subclass of newSuper using oldClass as template"
	"WARNING: This method does not preserve the superclass/subclass invariant!!"
	| newSuperMeta oldMeta newMeta |
	oldClass ifNil:[^self privateNewSubclassOf: newSuper].
	newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class].
	oldMeta _ oldClass class.
	newMeta _ oldMeta clone.
	newMeta 
		superclass: newSuperMeta
		methodDictionary: MethodDictionary new
		format: (self computeFormat: oldMeta typeOfClass 
					instSize: oldMeta instVarNames size 
					forSuper: newSuperMeta
					ccIndex: 0);
		setInstVarNames: oldMeta instVarNames;
		organization: oldMeta organization.
	"Recompile the meta class"
	oldMeta hasMethods 
		ifTrue:[newMeta compileAllFrom: oldMeta].
	"Record the meta class change"
	self recordClass: oldMeta replacedBy: newMeta.
	"And create a new instance"
	^newMeta adoptInstance: oldClass from: oldMeta! !

!ClassBuilder methodsFor: 'private' stamp: 'NS 1/27/2004 14:21'!
recordClass: oldClass replacedBy: newClass
	"Keep the changes up to date when we're moving instVars around"
	(instVarMap includesKey: oldClass name) ifTrue:[
		SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldClass to: newClass.
	].! !

!ClassBuilder methodsFor: 'private' stamp: 'gk 2/28/2005 16:35'!
reservedNames
	"Return a list of names that must not be used for variables"
	^#('self' 'super' 'thisContext' 'true' 'false' 'nil' 
		self super thisContext #true #false #nil).! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 3/5/2001 12:00'!
showProgressFor: aClass
	"Announce that we're processing aClass"
	progress == nil ifTrue:[^self].
	aClass isObsolete ifTrue:[^self].
	currentClassIndex _ currentClassIndex + 1.
	(aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue:
		[progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')]! !

!ClassBuilder methodsFor: 'private' stamp: 'dvf 9/27/2005 16:49'!
tooDangerousClasses
	"Return a list of class names which will not be modified in the public interface"
	^#(
		"Object will break immediately"
		ProtoObject Object
		"Contexts and their superclasses"
		InstructionStream ContextPart BlockContext MethodContext
		"Superclasses of basic collections"
		Collection SequenceableCollection ArrayedCollection
		"Collections known to the VM"
		Array Bitmap String Symbol ByteArray CompiledMethod TranslatedMethod
		"Basic Numbers"
		Magnitude Number SmallInteger Float
		"Misc other"
		LookupKey Association Link Point Rectangle PositionableStream UndefinedObject
	)
! !

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

ClassBuilder class
	instanceVariableNames: ''!

!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:50'!
beSilent: aBool
	"ClassDefiner beSilent: true"
	"ClassDefiner beSilent: false"
	QuietMode _ aBool.! !

!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:53'!
beSilentDuring: aBlock
	"Temporarily suppress information about what is going on"
	| wasSilent result |
	wasSilent _ self isSilent.
	self beSilent: true.
	result _ aBlock value.
	self beSilent: wasSilent.
	^result! !

!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:48'!
isSilent
	^QuietMode == true! !


!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'!
checkClassHierarchyConsistency
	"Check the consistency of the class hierarchy. The class hierarchy is consistent if the following
	two logical equivalences hold for classes A and B:
	- B is obsolete and 'B superclass' yields A  <-->  'A obsoleteSubclasses' contains B
	- B is not obsolete and 'B superclass' yields A  <-->  'A subclasses' contains B"
	Utilities informUserDuring:[:bar|
		self checkClassHierarchyConsistency: bar.
	].! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:03'!
checkClassHierarchyConsistency: informer
	"Check the consistency of the class hierarchy. The class hierarchy is consistent if the following
	two logical equivalences hold for classes A and B:
	- B is obsolete and 'B superclass' yields A  <-->  'A obsoleteSubclasses' contains B
	- B is not obsolete and 'B superclass' yields A  <-->  'A subclasses' contains B"
	| classes |
	Transcript cr; show: 'Start checking the class hierarchy...'.
	Smalltalk garbageCollect.
	classes := Metaclass allInstances.
	classes keysAndValuesDo: [:index :meta |
		informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'.
		meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each].
		self checkClassHierarchyConsistencyFor: meta.
	].
	Transcript show: 'OK'.! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:48'!
checkClassHierarchyConsistencyFor: aClassDescription
	"Check whether aClassDescription has a consistent superclass and consistent regular and obsolete
	subclasses"

	| mySuperclass |
	mySuperclass _ aClassDescription superclass.
	(mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete
			ifTrue: [self error: 'Something wrong!!'].
	mySuperclass ifNil: [^ self].  "Obsolete subclasses of nil cannot be stored"
	(mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete
			ifFalse: [self error: 'Something wrong!!'].

	aClassDescription subclasses do: [:each |
		each isObsolete ifTrue: [self error: 'Something wrong!!'].
		each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!']
	].
	aClassDescription obsoleteSubclasses do: [:each |
		each isObsolete ifFalse: [self error: 'Something wrong!!'].
		each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!']
	].! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:00'!
cleanupAndCheckClassHierarchy
	"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary.
	Afterwards it checks whether the hierarchy is really consistent."
	Utilities informUserDuring:[:bar|
		self cleanupAndCheckClassHierarchy: bar.
	].
! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 15:58'!
cleanupAndCheckClassHierarchy: informer
	"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary.
	Afterwards it checks whether the hierarchy is really consistent."

	Transcript cr; show: '*** Before cleaning up ***'.
	self countReallyObsoleteClassesAndMetaclasses.
	self cleanupClassHierarchy: informer.
	self checkClassHierarchyConsistency: informer.
	Transcript cr; cr; show: '*** After cleaning up ***'.
	self countReallyObsoleteClassesAndMetaclasses.! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'!
cleanupClassHierarchy
	"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary."
	Utilities informUserDuring:[:bar|
		self cleanupClassHierarchy: bar.
	].! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:02'!
cleanupClassHierarchy: informer
	"Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary."
	| classes |
	Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'.
	Smalltalk garbageCollect.
	classes := Metaclass allInstances.
	classes keysAndValuesDo: [:index :meta |
		informer value:'Fixing  class hierarchy ', (index * 100 // classes size) printString,'%'.
		"Check classes before metaclasses (because Metaclass>>isObsolete
		checks whether the related class is obsolete)"
		meta allInstances do: [:each | self cleanupClassHierarchyFor: each].
		self cleanupClassHierarchyFor: meta.
	].
	Transcript show: 'DONE'.! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 5/8/2002 10:55'!
cleanupClassHierarchyFor: aClassDescription
	
	| myName mySuperclass |
	mySuperclass _ aClassDescription superclass.
	(self isReallyObsolete: aClassDescription) ifTrue: [
		
		"Remove class >>>from SystemDictionary if it is obsolete"
		myName _ aClassDescription name asString.
		Smalltalk keys asArray do: [:each | 
			(each asString = myName and: [(Smalltalk at: each) == aClassDescription])
				ifTrue: [Smalltalk removeKey: each]].

		"Make class officially obsolete if it is not"
		(aClassDescription name asString beginsWith: 'AnObsolete')
			ifFalse: [aClassDescription obsolete].

		aClassDescription isObsolete 
			ifFalse: [self error: 'Something wrong!!'].

		"Add class to obsoleteSubclasses of its superclass"
		mySuperclass
			ifNil: [self error: 'Obsolete subclasses of nil cannot be stored'].
		(mySuperclass obsoleteSubclasses includes: aClassDescription)
			ifFalse: [mySuperclass addObsoleteSubclass: aClassDescription].
	] ifFalse:[
		"check if superclass has aClassDescription in its obsolete subclasses"
		mySuperclass ifNil:[mySuperclass _ Class]. "nil subclasses"
		mySuperclass removeObsoleteSubclass: aClassDescription.
	].
	"And remove its obsolete subclasses if not actual superclass"
	aClassDescription obsoleteSubclasses do:[:obs|
		obs superclass == aClassDescription ifFalse:[
			aClassDescription removeObsoleteSubclass: obs]].
! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'!
countReallyObsoleteClassesAndMetaclasses
	"Counting really obsolete classes and metaclasses"

	| metaSize classSize |
	Smalltalk garbageCollect.
	metaSize _ self reallyObsoleteMetaclasses size.
	Transcript cr; show: 'Really obsolete metaclasses: ', metaSize printString.
	classSize _ self reallyObsoleteClasses size.
	Transcript cr; show: 'Really obsolete classes: ', classSize printString; cr.
	"Metaclasses must correspond to classes!!"
	metaSize ~= classSize 
		ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'!
isReallyObsolete: aClassDescription
	"Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete
	isObsolete does not always return the right answer"

	^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'!
reallyObsoleteClasses
	| obsoleteClasses |
	obsoleteClasses _ OrderedCollection new.
	Metaclass allInstances do: [:meta | meta allInstances do: [:each | 
		(self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]].
	^ obsoleteClasses! !

!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'!
reallyObsoleteMetaclasses
	^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! !
TestCase subclass: #ClassBuilderChangeClassTypeTest
	instanceVariableNames: 'baseClass subClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Classes'!


!ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:49'!
baseClassName

   ^'TestClassForClassChangeTest'! !

!ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:51'!
cleanup
	baseClass ifNotNil:[baseClass removeFromSystem].! !
TestCase subclass: #ClassBuilderFormatTests
	instanceVariableNames: 'baseClass subClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Classes'!

!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:21'!
testByteVariableSubclass
	"Ensure that the invariants for superclass/subclass format are preserved"
	baseClass := Object variableByteSubclass: self baseClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.
	[

	self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error.
	self deny: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self assert: (subClass isBytes).
	subClass removeFromSystem.

	"pointer classes"
	self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
	self should:[self makeVariableSubclassOf: baseClass] raise: Error.
	self should:[self makeWeakSubclassOf: baseClass] raise: Error.

	"bit classes"
	self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error.
	self deny: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self assert: (subClass isBytes).
	subClass removeFromSystem.

	self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.

	] ensure:[self cleanup].! !

!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'!
testSubclass
	"Ensure that the invariants for superclass/subclass format are preserved"
	baseClass := Object subclass: self baseClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.
	[
	self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self deny: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	"pointer classes"
	self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self deny: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert:(subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert:(subClass isVariable).
	self assert:(subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	"bit classes"
	self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error.
	self deny: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self assert: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error.
	self deny: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.
	] ensure:[self cleanup].! !

!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:21'!
testSubclassWithInstanceVariables
	"Ensure that the invariants for superclass/subclass format are preserved"
	baseClass := Object subclass: self baseClassName
		instanceVariableNames: 'var1 var2'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.
	[
	self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self deny: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	"pointer classes"
	self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self deny: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self assert: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	"bit classes"
	self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
	self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
	] ensure:[self cleanup].! !

!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'!
testVariableSubclass
	"Ensure that the invariants for superclass/subclass format are preserved"
	baseClass := Object variableSubclass: self baseClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.
	[
	"pointer classes"
	self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self assert: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	"bit classes"
	self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
	self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
	] ensure:[self cleanup].! !

!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'!
testWeakSubclass
	"Ensure that the invariants for superclass/subclass format are preserved"
	baseClass := Object weakSubclass: self baseClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.
	[
	"pointer classes"
	self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self assert: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self assert: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error.
	self assert: (subClass isPointers).
	self assert: (subClass isVariable).
	self assert: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	"bit classes"
	self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
	self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
	] ensure:[self cleanup].! !

!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'!
testWordVariableSubclass
	"Ensure that the invariants for superclass/subclass format are preserved"
	baseClass := Object variableWordSubclass: self baseClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.
	[
	self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error.
	self deny: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	"pointer classes"
	self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
	self should:[self makeVariableSubclassOf: baseClass] raise: Error.
	self should:[self makeWeakSubclassOf: baseClass] raise: Error.

	"bit classes"
	self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
	self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error.
	self deny: (subClass isPointers).
	self assert: (subClass isVariable).
	self deny: (subClass isWeak).
	self deny: (subClass isBytes).
	subClass removeFromSystem.

	] ensure:[self cleanup].! !


!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'!
baseClassName
	^#DummyClassBuilderFormatTestSuperClass! !

!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'!
cleanup
	subClass ifNotNil:[subClass removeFromSystem].
	baseClass ifNotNil:[baseClass removeFromSystem].! !

!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'!
makeByteVariableSubclassOf: aClass
	subClass := aClass variableByteSubclass: self subClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'! !

!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'!
makeIVarsSubclassOf: aClass
	subClass := aClass subclass: self subClassName
		instanceVariableNames: 'var3 var4'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'! !

!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'!
makeNormalSubclassOf: aClass
	subClass := aClass subclass: self subClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'! !

!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'!
makeVariableSubclassOf: aClass
	subClass := aClass variableSubclass: self subClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'.! !

!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'!
makeWeakSubclassOf: aClass
	subClass := aClass weakSubclass: self subClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'! !

!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'!
makeWordVariableSubclassOf: aClass
	subClass := aClass variableWordSubclass: self subClassName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Kernel-Tests-ClassBuilder'! !

!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'!
subClassName
	^#DummyClassBuilderFormatTestSubClass! !
Object subclass: #ClassCategoryReader
	instanceVariableNames: 'class category changeStamp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!ClassCategoryReader commentStamp: '<historical>' prior: 0!
I represent a mechanism for retrieving class descriptions stored on a file.!


!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'al 11/28/2005 22:10'!
scanFrom: aStream 
	"File in methods from the stream, aStream."
	| methodText |
	[methodText := aStream nextChunkText.
	 methodText size > 0]
		whileTrue:
		[class compile: methodText classified: category
			withStamp: changeStamp notifying: nil]! !

!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'tk 1/27/2000 23:24'!
scanFromNoCompile: aStream 
	"Just move the source code for the methods from aStream."
	| methodText selector |

	[methodText _ aStream nextChunkText.
	 methodText size > 0]
		whileTrue:
		[(SourceFiles at: 2) ifNotNil: [
			selector _ class parserClass new parseSelector: methodText.
			(class compiledMethodAt: selector) putSource: methodText 
				fromParseNode: nil class: class category: category
				withStamp: changeStamp inFile: 2 priorMethod: nil]]! !

!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'RAA 6/22/2000 16:08'!
scanFromNoCompile: aStream forSegment: anImageSegment

	^self scanFromNoCompile: aStream 	"subclasses may care about the segment"! !


!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!
setClass: aClass category: aCategory
	^ self setClass: aClass category: aCategory changeStamp: String new
! !

!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!
setClass: aClass category: aCategory changeStamp: aString

	class _ aClass.
	category _ aCategory.
	changeStamp _ aString
! !

!ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'!
theClass

	^ class! !

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

ClassCategoryReader class
	instanceVariableNames: ''!
Object subclass: #ClassChangeRecord
	instanceVariableNames: 'inForce revertable changeTypes thisDefinition priorDefinition thisName priorName thisOrganization priorOrganization thisComment priorComment thisMD priorMD methodChanges'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Changes'!
!ClassChangeRecord commentStamp: '<historical>' prior: 0!
A ClassChangeRecorder keeps track of most substantive changes premissible in a project, isolated or not.

Structure:
inForce		a boolean
			Tells whether these changes are in effect.
			true for all changeSets in and above the current project.
			It should be sufficient only to record this for the changeSet
			as a whole, but this redundancy could help in error recovery.
classIsLocal	a boolean
			True if and only if this class is defined in this layer of the
			project structure.
changeTypes an identitySet
			Summarizes which changes have been made in this class.
			Values include #comment, #reorganize, #rename,
			and the four more summarized below.
thisName	a string
			Retains the class name for this layer.
priorName	a string
			Preserves the prior name.
thisComment	a text
			Retains the class comment for this layer.
priorComment	a text
			Preserves the prior comment.
thisOrganization	a classOrganizer
			Retains the class organization for this layer.
priorOrganization	a classOrganizer
			Preserves the prior organization.
thisMD	a methodDictionary
			Used to prepare changes for nearly atomic invocation
			of this layer (see below).
priorMD	a methodDictionary
			Preserves the state of an altered class as it exists in the next
			outer layer of the project structure.
methodChanges		a dictionary of classChangeRecords
			Retains all the method changes for this layer.

Four of the possible changeTypes are maintained in a mutually exclusive set, analogously to MethodChangeRecords.  Here is a simple summary of the relationship between these four changeType symbols and the recording of prior state
			|	prior == nil			|	prior not nil	
	---------	|----------------------------	|--------------------
	add		|	add					|	change
	---------	|----------------------------	|--------------------
	remove	|	addedThenRemoved	|	remove

A classChangeRecorder is notified of changes by the method
		noteMethodChange: <ClassChangeRecord>.
ClassChangeRecorders are designed to invoke a set of changes relative to the definition of a class in an prior layer.  It is important that both invocation and revocation of these changes take place in a nearly atomic fashion so that interdependent changes will be adopted as a whole, and so that only one flush of the method cache should be necessary.  A further reason for revocation to be simple is that it may be requested as an attempt to recover from an error in a project that is failing.!


!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/2/2000 21:39'!
allChangeTypes

	| chgs |
	(priorName ~~ nil and: [changeTypes includes: #rename]) ifTrue:
		[(chgs _ changeTypes copy) add: 'oldName: ' , priorName.
		^ chgs].
	^ changeTypes! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/2/2000 21:59'!
assimilateAllChangesIn: otherRecord

	| selector changeRecord changeType |
	otherRecord isClassRemoval ifTrue: [^ self noteChangeType: #remove].

	otherRecord allChangeTypes do:
		[:chg | self noteChangeType: chg fromClass: self realClass].

	otherRecord methodChanges associationsDo:
		[:assn | selector _ assn key. changeRecord _ assn value.
		changeType _ changeRecord changeType.
		(changeType == #remove or: [changeType == #addedThenRemoved])
			ifTrue:
				[changeType == #addedThenRemoved
					ifTrue: [self atSelector: selector put: #add].
				self noteRemoveSelector: selector priorMethod: nil
						lastMethodInfo: changeRecord methodInfoFromRemoval]
			ifFalse: 
				[self atSelector: selector put: changeType]].
! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 10:59'!
hasNoChanges

	^ changeTypes isEmpty and: [methodChanges isEmpty]! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/24/2000 09:36'!
includesChangeType: changeType

	changeType == #new ifTrue: [^ changeTypes includes: #add].  "Backwd compat"
	^ changeTypes includes: changeType! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 15:14'!
noteChangeType: changeSymbol

	^ self noteChangeType: changeSymbol fromClass: nil! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'sw 4/3/2001 14:16'!
noteChangeType: changeSymbol fromClass: class

	(changeSymbol = #new or: [changeSymbol = #add]) ifTrue:
		[changeTypes add: #add.
		changeTypes remove: #change ifAbsent: [].
		revertable _ false.
		^ self].
	changeSymbol = #change ifTrue:
		[(changeTypes includes: #add) ifTrue: [^ self].
		^ changeTypes add: changeSymbol].
	changeSymbol == #addedThenRemoved ifTrue:
		[^ self].  "An entire class was added but then removed"
	changeSymbol = #comment ifTrue:
		[^ changeTypes add: changeSymbol].
	changeSymbol = #reorganize ifTrue:
		[^ changeTypes add: changeSymbol].
	changeSymbol = #rename ifTrue:
		[^ changeTypes add: changeSymbol].
	(changeSymbol beginsWith: 'oldName: ') ifTrue:
		["Must only be used when assimilating other changeSets"
		(changeTypes includes: #add) ifTrue: [^ self].
		priorName _ changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size.
		^ changeTypes add: #rename].
	changeSymbol = #remove ifTrue:
		[(changeTypes includes: #add)
			ifTrue: [changeTypes add: #addedThenRemoved]
			ifFalse: [changeTypes add: #remove].
		^ changeTypes removeAllFoundIn: #(add change comment reorganize)].

	self error: 'Unrecognized changeType'! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 5/16/2000 08:43'!
trimHistory
	"Drop non-essential history."

	"Forget methods added and later removed"
	methodChanges keysAndValuesRemove:
		[:sel :chgRecord | chgRecord changeType == #addedThenRemoved].

	"Forget renaming and reorganization of newly-added classes."
	(changeTypes includes: #add) ifTrue:
		[changeTypes removeAllFoundIn: #(rename reorganize)].
! !


!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:06'!
checkCoherence
	"If I recreate the class then don't remove it"

	(changeTypes includes: #remove) ifTrue:
		[changeTypes remove: #remove.
		changeTypes add: #change].
	(changeTypes includes: #addedThenRemoved) ifTrue:
		[changeTypes remove: #addedThenRemoved.
		changeTypes add: #add].
! !

!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:08'!
notePriorDefinition: oldClass

	oldClass ifNil: [^ self].
	priorDefinition ifNil: [priorDefinition _ oldClass definition]! !

!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/28/2000 09:12'!
priorDefinition

	^ priorDefinition! !


!ClassChangeRecord methodsFor: 'initialization' stamp: 'di 4/5/2000 08:11'!
initFor: className revertable: isRevertable

	inForce _ isRevertable.
	changeTypes _ IdentitySet new.
	methodChanges _ IdentityDictionary new.
	priorName _ thisName _ className.
	revertable _ isRevertable and: [self realClass notNil].
	revertable ifTrue:
		[priorMD _ self realClass methodDict copy.
		priorOrganization _ self realClass organization deepCopy].
! !

!ClassChangeRecord methodsFor: 'initialization' stamp: 'di 9/21/2000 12:34'!
zapHistory
	"Drop all recorded information not needed to simply keep track of what has been changed.
	Saves a lot of space."

	methodChanges do: [:r | r noteNewMethod: nil].  "Drop all refes to old methods"
	thisOrganization _ nil.
	priorOrganization _ nil.
	thisComment _ nil.
	priorComment _ nil.
	thisMD _ nil.
	priorMD _ nil.! !


!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 22:00'!
invokePhase1

	| selector changeRecord type elements |
	revertable ifFalse: [^ self].
	inForce ifTrue: [self error: 'Can invoke only when not in force.'].

	"Do the first part of the invoke operation -- no particular hurry."
	"Save the outer method dictionary for quick revert of method changes."
	priorMD _ self realClass methodDict.

	"Prepare a methodDictionary for switcheroo."
	thisMD _ self realClass methodDict copy.
	methodChanges associationsDo:
		[:assn | selector _ assn key. changeRecord _ assn value.
		type _ changeRecord changeType.
		type = #remove ifTrue: [thisMD removeKey: selector].
		type = #add ifTrue: [thisMD at: selector put: changeRecord currentMethod].
		type = #change ifTrue: [thisMD at: selector put: changeRecord currentMethod].
		].

	"Replace the original organization (and comment)."
	priorOrganization _ self realClass organization.
	thisOrganization elementArray copy do:
		[:sel | (thisMD includesKey: sel) ifFalse: [thisOrganization removeElement: sel]].
	#(DoIt DoItIn:) do: [:sel | thisMD removeKey: sel ifAbsent: []].
	thisOrganization elementArray size = thisMD size ifFalse:
		[elements _ thisOrganization elementArray asSet.
		thisMD keysDo:
			[:sel | (elements includes: sel) ifFalse:
				[thisOrganization classify: sel
					under: (priorOrganization categoryOfElement: sel)]]].
	self realClass organization: thisOrganization.


! !

!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'!
invokePhase2

	revertable ifFalse: [^ self].

	"Do the second part of the revert operation.  This must be very simple."
	"Replace original method dicts if there are method changes."
	self realClass methodDictionary: thisMD.  "zap.  Must flush Cache in outer loop."
	inForce _ true.
! !

!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/30/2000 18:03'!
realClass
	"Return the actual class (or meta), as determined from my name."

	thisName ifNil: [^ nil].
	(thisName endsWith: ' class')
		ifTrue: [^ (Smalltalk at: (thisName copyFrom: 1 to: thisName size - 6) asSymbol
						ifAbsent: [^ nil]) class]
		ifFalse: [^ Smalltalk at: thisName ifAbsent: [^ nil]]! !

!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'!
revokePhase1

	revertable ifFalse: [^ self].
	inForce ifFalse: [self error: 'Can revoke only when in force.'].

	"Do the first part of the revoke operation.  This must be very simple."
	"Replace original method dict if there are method changes."
	self realClass methodDictionary: priorMD  "zap.  Must flush Cache in outer loop."! !

!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'!
revokePhase2

	revertable ifFalse: [^ self].

	"Replace the original organization (and comment)."
	thisOrganization _ self realClass organization.
	self realClass organization: priorOrganization.
	inForce _ false.
! !


!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:38'!
atSelector: selector ifAbsent: absentBlock

	^ (methodChanges at: selector ifAbsent: absentBlock)
		changeType! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'!
atSelector: selector put: changeType

	(self findOrMakeMethodChangeAt: selector priorMethod: nil)
		noteChangeType: changeType! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:07'!
changedSelectors
	"Return a set of the changed or removed selectors."

	^ methodChanges keys! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 4/1/2000 10:45'!
compileAll: newClass from: oldClass
	"Something about this class has changed.  Locally retained methods must be recompiled.
	NOTE:  You might think that if this changeSet is in force, then we can just note
	the new methods but a lower change set may override and be in force which
	would mean that only the overriding copies go recompiled.  Just do it."

	| sel changeType changeRecord newMethod |
	methodChanges associationsDo:
		[:assn | sel _ assn key.  changeRecord _ assn value.
		changeType _ changeRecord changeType.
		(changeType == #add or: [changeType == #change]) ifTrue:
			[newMethod _ newClass
				recompileNonResidentMethod: changeRecord currentMethod
				atSelector: sel from: oldClass.
			changeRecord noteNewMethod: newMethod]]! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'!
findOrMakeMethodChangeAt: selector priorMethod: priorMethod

	^ methodChanges at: selector
		ifAbsent: [methodChanges at: selector
						put: (MethodChangeRecord new priorMethod: priorMethod)]! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/29/2000 16:26'!
infoFromRemoval: selector

	^ (methodChanges at: selector ifAbsent: [^ nil])
		methodInfoFromRemoval

! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/24/2000 09:46'!
methodChangeTypes
	"Return an old-style dictionary of method change types."

	| dict selector record |
	dict _ IdentityDictionary new.
	methodChanges associationsDo:
		[:assn | selector _ assn key.  record _ assn value.
		dict at: selector put: record changeType].
	^ dict! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 4/1/2000 23:49'!
methodChanges

	^ methodChanges! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 23:28'!
noteNewMethod: newMethod selector: selector priorMethod: methodOrNil

	| methodChange |
	methodChange _ self findOrMakeMethodChangeAt: selector priorMethod: methodOrNil.
	methodOrNil == nil
		ifTrue: [methodChange noteChangeType: #add]
		ifFalse: [methodChange noteChangeType: #change].
	methodChange noteNewMethod: newMethod.
! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/23/2000 23:00'!
noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: infoOrNil

	| methodChange |
	methodChange _ self findOrMakeMethodChangeAt: selector priorMethod: priorMethod.
	methodChange changeType == #add
		ifTrue: [methodChange noteChangeType: #addedThenRemoved]
		ifFalse: [methodChange noteChangeType: #remove].

	infoOrNil ifNotNil:
		["Save the source code pointer and category so can still browse old versions"
		methodChange noteMethodInfoFromRemoval: infoOrNil]

! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'sw 8/14/2002 11:11'!
removeSelector: selector
	"Remove all memory of changes associated with the argument, selector, in this class."

	selector == #Comment
		ifTrue:
			[changeTypes remove: #comment ifAbsent: []]
		ifFalse:
			[methodChanges removeKey: selector ifAbsent: []]! !


!ClassChangeRecord methodsFor: 'removal' stamp: 'di 4/4/2000 12:49'!
forgetChangesIn: otherRecord
	"See forgetAllChangesFoundIn:.  Used in culling changeSets."

	| cls otherMethodChanges selector actionToSubtract |
	(cls _ self realClass) == nil ifTrue: [^ self].  "We can do better now, though..."
	otherMethodChanges _ otherRecord methodChangeTypes.
	otherMethodChanges associationsDo:
		[:assoc | selector _ assoc key. actionToSubtract _ assoc value.
		(cls includesSelector: selector)
			ifTrue: [(#(add change) includes: actionToSubtract)
					ifTrue: [methodChanges removeKey: selector ifAbsent: []]]
			ifFalse: [(#(remove addedThenRemoved) includes: actionToSubtract)
					ifTrue: [methodChanges removeKey: selector ifAbsent: []]]].
	changeTypes isEmpty ifFalse:
		[changeTypes removeAllFoundIn: otherRecord allChangeTypes.
		(changeTypes includes: #rename) ifFalse:
			[changeTypes removeAllSuchThat: [:x | x beginsWith: 'oldName: ']]]! !

!ClassChangeRecord methodsFor: 'removal' stamp: 'di 3/23/2000 12:27'!
forgetClassRemoval

	self halt.! !

!ClassChangeRecord methodsFor: 'removal' stamp: 'di 4/1/2000 23:05'!
isClassRemoval
	"NOTE: there are other removals with changeType #addedThenRemoved,
	but this message is used to write out removals in fileOut, and those
	cases should not be written out."

	^ (changeTypes includes: #remove) or: [changeTypes includes: #removeClass]! !


!ClassChangeRecord methodsFor: 'rename' stamp: 'di 5/8/2000 20:39'!
noteNewName: newName

	thisName _ newName! !

!ClassChangeRecord methodsFor: 'rename' stamp: 'di 3/24/2000 09:38'!
priorName

	^ priorName! !

!ClassChangeRecord methodsFor: 'rename' stamp: 'tk 6/8/2001 09:11'!
thisName

	^ thisName! !
ClassCategoryReader subclass: #ClassCommentReader
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

!ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'sw 7/31/2002 10:40'!
scanFrom: aStream 
	"File in the class comment from aStream.  Not string-i-fied, just a text, exactly as it is in the browser.  Move to changes file."

	class theNonMetaClass classComment: (aStream nextChunkText) stamp: changeStamp
		"Writes it on the disk and saves a RemoteString ref"! !

!ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'tk 1/27/2000 22:56'!
scanFromNoCompile: aStream 
	"File in the class comment from aStream.  Not string-i-fied, just a text, exactly as it is in the browser.  Move to changes file."

	self scanFrom: aStream.	"for comments, the same as usual"! !

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

ClassCommentReader class
	instanceVariableNames: ''!
VersionsBrowser subclass: #ClassCommentVersionsBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ClassCommentVersionsBrowser commentStamp: 'asm 8/13/2002 23:20' prior: 0!
A class-comment-versions-browser tool!


!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'!
diffedVersionContents
	"Answer diffed version contents, maybe pretty maybe not"

	| change class earlier later |
	(listIndex = 0
			or: [changeList size < listIndex])
		ifTrue: [^ ''].
	change := changeList at: listIndex.
	later := change text.
	class := self selectedClass.
	(listIndex == changeList size or: [class == nil])
		ifTrue: [^ later].

	earlier := (changeList at: listIndex + 1) text.

	^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! !

!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'!
reformulateList

     classOfMethod organization classComment ifNil: [^ self].

	self scanVersionsOf: classOfMethod.
	self changed: #list. "for benefit of mvc"
	listIndex := 1.
	self changed: #listIndex.
	self contentsChanged! !

!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'!
scanVersionsOf: class 
	"Scan for all past versions of the class comment of the given class"

	| oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex |

	classOfMethod := class.
	oldCommentRemoteStr := class  organization commentRemoteStr.
	currentCompiledMethod := oldCommentRemoteStr.
	selectorOfMethod := #Comment.
	changeList := OrderedCollection new.
	list := OrderedCollection new.
	listIndex := 0.
	oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer].

	sourceFilesCopy := SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	position := oldCommentRemoteStr position.
	file := sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  " Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble := file nextChunk].

		prevPos := nil.
		stamp := ''.
		(preamble findString: 'commentStamp:' startingAt: 1) > 0
			ifTrue: [tokens := Scanner new scanTokens: preamble.
				(tokens at: tokens size-3) = #commentStamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp := tokens at: tokens size-2.
						prevPos := tokens last.
						prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]]
			ifFalse: ["The stamp get lost, maybe after a condenseChanges"
					stamp := '<historical>'].
 		self addItem:
				(ChangeRecord new file: file position: position type: #classComment
						class: class name category: nil meta: class stamp: stamp)
			text: stamp , ' ' , class name , ' class comment'. 
		prevPos = 0 ifTrue:[prevPos := nil].
		position := prevPos.
		prevPos notNil 
					ifTrue:[file := sourceFilesCopy at: prevFileIndex]].
	sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
	listSelections := Array new: list size withAll: false! !

!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'!
updateListsAndCodeIn: aWindow
	| aComment |
	aComment := classOfMethod organization commentRemoteStr.
	aComment == currentCompiledMethod
		ifFalse:
			["Do not attempt to formulate if there is no source pointer.
			It probably means it has been recompiled, but the source hasn't been written
			(as during a display of the 'save text simply?' confirmation)."
			aComment last ~= 0 ifTrue: [self reformulateList]].
	^ true
! !


!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
compareToCurrentVersion
	"If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text"

	| change s1 s2 |
	listIndex = 0
		ifTrue: [^ self].
	change := changeList at: listIndex.
	s1 := classOfMethod organization classComment.
	s2 := change string.
	s1 = s2
		ifTrue: [^ self inform: 'Exact Match'].
			(StringHolder new
				textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: classOfMethod  prettyDiffs: self showingPrettyDiffs))
				openLabel: 'Comparison to Current Version'! !

!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:02'!
offerVersionsHelp
	(StringHolder new contents: self versionsHelpString)
		openLabel: 'Class Comment Versions Browsers'! !

!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
openSingleMessageBrowser
	| mr |
	"Create and schedule a message list browser populated only by the currently selected message"

	mr := MethodReference new
				setStandardClass: self selectedClass
				methodSymbol: #Comment.

	self systemNavigation 
		browseMessageList: (Array with: mr)
		name: mr asStringOrText
		autoSelect: nil! !

!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:53'!
versionsMenu: aMenu
	"Fill aMenu with menu items appropriate to the receiver"

	Smalltalk isMorphic ifTrue:
		[aMenu title: 'versions'.
		aMenu addStayUpItemSpecial].
	^ aMenu addList: #(

		('compare to current'		compareToCurrentVersion		'compare selected version to the current version')
		('revert to selected version'	fileInSelections					'resubmit the selected version, so that it becomes the current version')
		('remove from changes'		removeMethodFromChanges		'remove this method from the current change set, if present')
		('edit current method (O)'	openSingleMessageBrowser		'open a single-message browser on the current version of this method')		
		-
		('toggle diffing (D)'			toggleDiffing					'toggle whether or not diffs should be shown here')
		('update list'				reformulateList					'reformulate the list of versions, in case it somehow got out of synch with reality')
		-
		('help...'					offerVersionsHelp				'provide an explanation of the use of this tool'))
! !


!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/17/2002 21:57'!
classCommentIndicated
	"Answer whether the receiver is pointed at a class comment"

	^ true! !

!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:38'!
contentsSymbolQuints
	"Answer a list of quintuplets representing information on the alternative views available in the code pane"

	^ #(
(source			togglePlainSource 		showingPlainSourceString	'source'			'the textual source code as writen')
(showDiffs		toggleRegularDiffing	showingRegularDiffsString	'showDiffs'		'the textual source diffed from its prior version'))! !

!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sd 11/20/2005 21:26'!
priorSourceOrNil
	"If the currently-selected method has a previous version, return its source, else return nil"
	| aClass aSelector  changeRecords |
	(aClass := self selectedClass) ifNil: [^ nil].
	(aSelector := self selectedMessageName) ifNil: [^ nil].
	changeRecords :=  self class commentRecordsOf: self selectedClass.
	(changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil].
	^ (changeRecords at: 2) string 
! !

!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'asm 8/13/2002 20:59'!
selectedClass
	"Answer the class currently selected in the browser.  In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"

	^ classOfMethod! !

!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:35'!
wantsPrettyDiffOption
	"Answer whether pretty-diffs are meaningful for this tool"

	^ false! !

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

ClassCommentVersionsBrowser class
	instanceVariableNames: ''!

!ClassCommentVersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
browseCommentOf: class
	| changeList |
	Cursor read showWhile:
		[changeList := self new scanVersionsOf: class.
	 	 changeList ifNil: [^ self inform: 'No versions available'].
		 self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ]
! !


!ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'!
commentRecordsOf: aClass
	"Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one.  Return nil if the method is absent."

	| aList |
	aList := self new
			scanVersionsOf: aClass.
	^ aList ifNotNil: [aList changeList]! !

!ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'!
timeStampFor: aSelector class: aClass reverseOrdinal: anInteger
	"Answer the time stamp corresponding to some version of the given method, nil if none.  The reverseOrdinal parameter is interpreted as:  1 = current version; 2 = last-but-one version, etc."
	
	| aChangeList |
	aChangeList :=  self new scanVersionsOf: aClass.
	^ aChangeList ifNil: [nil] ifNotNil:
		[aChangeList list size >= anInteger
			ifTrue:
				[(aChangeList changeList at: anInteger) stamp]
			ifFalse:
				[nil]]! !


!ClassCommentVersionsBrowser class methodsFor: 'window color' stamp: 'asm 8/13/2002 20:57'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Class Comment Versions Browser' brightColor: #(0.769 0.653 1.0)	pastelColor: #(0.819 0.753 1.0) helpMessage: 'A tool for viewing prior versions of a class comment.'! !
Behavior subclass: #ClassDescription
	uses: TCopyingDescription + TBasicCategorisingDescription + TCompilingDescription + TAccessingMethodDictDescription + TTraitsCategorisingDescription + TPrintingDescription + TCommentDescription + TFileInOutDescription + TTestingDescription
	instanceVariableNames: 'instanceVariables organization'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!ClassDescription commentStamp: '<historical>' prior: 0!
I add a number of facilities to basic Behaviors:
	Named instance variables
	Category organization for methods
	The notion of a name of this class (implemented as subclass responsibility)
	The maintenance of a ChangeSet, and logging changes on a file
	Most of the mechanism for fileOut.
	
I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass.

The slots 'organization' and 'methodDict' should ONLY be accessed by message in order for things to work during ImageSegment>>discoverActiveClasses (q.v.).!


!ClassDescription methodsFor: 'accessing' stamp: 'sd 6/27/2003 23:57'!
classVersion
	"Default.  Any class may return a later version to inform readers that use ReferenceStream.  8/17/96 tk"
	"This method allows you to distinguish between class versions when the shape of the class 
	hasn't changed (when there's no change in the instVar names).
	In the conversion methods you usually can tell by the inst var names 
	what old version you have. In a few cases, though, the same inst var 
	names were kept but their interpretation changed (like in the layoutFrame).
	By changing the class version when you keep the same instVars you can 
	warn older and newer images that they have to convert."
	^ 0! !

!ClassDescription methodsFor: 'accessing' stamp: 'NS 12/9/2003 15:12'!
version
	"Allows polymoprhism with TraitDescription>>version"

	^ self classVersion! !


!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 2/17/2000 22:36'!
classesThatImplementAllOf: selectorSet
	"Return an array of any classes that implement all the messages in selectorSet."

	| found remaining |
	found _ OrderedCollection new.
	selectorSet do:
		[:sel | (self methodDict includesKey: sel) ifTrue: [found add: sel]].
	found isEmpty
		ifTrue: [^ self subclasses inject: Array new
						into: [:subsThatDo :sub |
							subsThatDo , (sub classesThatImplementAllOf: selectorSet)]]
		ifFalse: [remaining _ selectorSet copyWithoutAll: found.
				remaining isEmpty ifTrue: [^ Array with: self].
				^ self subclasses inject: Array new
						into: [:subsThatDo :sub |
							subsThatDo , (sub classesThatImplementAllOf: remaining)]]! !

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'dtl 8/26/2004 11:02'!
commentInventory
	"Answer a string with a count of the classes with and without comments 
	for all the classes in the package of which this class is a member."

	"Morph commentInventory"

	^ SystemOrganization commentInventory: (self category copyUpTo: $-), '*'! !

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:51'!
printSubclassesOn: aStream level: level 
	"As part of the algorithm for printing a description of the receiver, print the
	subclass on the file stream, aStream, indenting level times."

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

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'!
removeUninstantiatedSubclassesSilently
	"Remove the classes of any subclasses that have neither instances nor subclasses.  Answer the number of bytes reclaimed"
	"Player removeUninstantiatedSubclassesSilently"

	| candidatesForRemoval  oldFree |

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

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'!
subclasses
	^ Array new! !

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'!
subclassesDo: aBlock
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	^self subclasses do: aBlock! !


!ClassDescription methodsFor: 'accessing comment' stamp: 'al 10/17/2005 10:23'!
classCommentBlank

	| existingComment stream |
	existingComment := self theNonMetaClass organization classComment.
	existingComment isEmpty
		ifFalse: [^existingComment].

	stream := WriteStream on: (String new: 100).
	stream
		nextPutAll: 'A';
		nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']);
		nextPutAll: self name;
		nextPutAll: ' is xxxxxxxxx.';
		cr; cr;
		nextPutAll: 'Instance Variables'.

	self instVarNames asSortedCollection do: [:each |
		stream
			cr; tab; nextPutAll: each;
			nextPut: $:;
			tab; tab;
			nextPutAll: '<Object>'].

	stream cr.
	self instVarNames asSortedCollection do: [:each |
		stream
			cr; nextPutAll: each;
			cr; tab; nextPutAll: '- xxxxx'; cr].

	^stream contents! !


!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 09:51'!
addSelectorSilently: selector withMethod: compiledMethod
	super addSelectorSilently: selector withMethod: compiledMethod.
	self instanceSide noteAddedSelector: selector meta: self isMeta.! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 1/5/2001 06:53'!
allMethodCategoriesIntegratedThrough: mostGenericClass
	"Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass"

	| aColl |
	aColl _ OrderedCollection new.
	self withAllSuperclasses do:
		[:aClass |
			(aClass includesBehavior: mostGenericClass)
				ifTrue:	[aColl addAll: aClass organization categories]].
	aColl remove: 'no messages' asSymbol ifAbsent: [].

	^ (aColl asSet asSortedCollection: [:a :b | a asLowercase < b asLowercase]) asArray

"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 4/18/2003 10:26'!
allMethodsInCategory: aName 
	"Answer a list of all the method categories of the receiver and all its 
	superclasses "
	| aColl |
	aColl _ OrderedCollection new.
	self withAllSuperclasses
		do: [:aClass | aColl
				addAll: (aName = ClassOrganizer allCategory
						ifTrue: [aClass organization allMethodSelectors]
						ifFalse: [aClass organization listAtCategoryNamed: aName])].
	^ aColl asSet asSortedArray

	"TileMorph allMethodsInCategory: #initialization"! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:17'!
induceMDFault
	"Stache a copy of the methodDict in the organization slot (hack!!),
	and set the methodDict to nil.  This will induce an MD fault on any message send.
	See: ClassDescription>>recoverFromMDFault
	and ImageSegment>>discoverActiveClasses."

	organization _ Array with: methodDict with: organization.
	methodDict _ nil.
	self flushCache! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 12/11/2000 14:00'!
isUniClass
	"Answer whether the receiver is a uniclass."

	^ self name endsWithDigit! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'di 3/7/2001 17:05'!
recoverFromMDFault
	"This method handles methodDict faults to support, eg, discoverActiveClasses (qv)."
	(organization isMemberOf: Array) ifFalse: [^ self error: 'oops'].
	methodDict _ organization first.
	organization _ organization second.
! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 3/28/2003 15:32'!
recoverFromMDFaultWithTrace
	"This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)."
	self recoverFromMDFault.
	self environment at: #MDFaultDict ifPresent:
		[:faultDict | faultDict at: self name put:
			(String streamContents:
				[:strm | (thisContext stackOfSize: 20) do: [:item | strm print: item; cr]])]

"Execute the following statement to induce MD fault tracing.  This means that, not only will all active classes be recorded but, after a test run, MDFaultDict will contain, for every class used, a stack trace showing how it came to be used.  This statement should be executed just prior to any such text, in order to clear the traces.

	Smalltalk at: #MDFaultDict put: Dictionary new.

"! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 20:49'!
removeSelector: selector 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."
	
	| priorMethod priorProtocol | 
	priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil].
	priorProtocol _ self whichCategoryIncludesSelector: selector.
	super removeSelector: selector.
	SystemChangeNotifier uniqueInstance 
		doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil].
	SystemChangeNotifier uniqueInstance 
			methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! !


!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:03'!
classSide
	^self theMetaClass! !

!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:04'!
instanceSide
	^ self theNonMetaClass! !

!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'sd 6/27/2003 22:50'!
theMetaClass
	"Sent to a class or metaclass, always return the metaclass"

	^self class! !

!ClassDescription methodsFor: 'accessing parallel hierarchy'!
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^self! !


!ClassDescription methodsFor: 'compiling' stamp: 'al 11/28/2005 11:51'!
moveInstVarNamed: instVarName to: anotherClass after: prevInstVarName
	"Move the given instance variable to another class."
	self == anotherClass ifFalse:[
		self notify:'Warning:' asText allBold,' moving ', instVarName printString,' from ', self name,' to ', anotherClass name,' will not be recorded in the change set correctly.
Proceed to do it anyways.'].
	^(ClassBuilder new)
		moveInstVarNamed: instVarName 
		from: self 
		to: anotherClass 
		after: prevInstVarName! !


!ClassDescription methodsFor: 'copying' stamp: 'yo 6/2/2004 23:05'!
copyAllCategoriesUnobtrusivelyFrom: aClass 
	"Specify that the categories of messages for the receiver include all of 
	those found in the class, aClass. Install each of the messages found in 
	these categories into the method dictionary of the receiver, classified 
	under the appropriate categories."

	aClass organization categories do: [:cat | self copyCategoryUnobtrusively: cat from: aClass]! !

!ClassDescription methodsFor: 'copying' stamp: 'yo 6/2/2004 23:04'!
copyAllUnobtrusively: selArray from: class classified: cat 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	the third argument, cat."

	selArray do: 
		[:s | self copyUnobtrusively: s
				from: class
				classified: cat]! !

!ClassDescription methodsFor: 'copying' stamp: 'yo 6/2/2004 23:05'!
copyCategoryUnobtrusively: cat from: class 
	"Specify that one of the categories of messages for the receiver is cat, as 
	found in the class, class. Copy each message found in this category."

	self copyUnobtrusivelyCategory: cat
		from: class
		classified: cat! !

!ClassDescription methodsFor: 'copying' stamp: 'yo 6/2/2004 23:11'!
copyUnobtrusivelyCategory: cat from: aClass classified: newCat 
	"Specify that one of the categories of messages for the receiver is the 
	third argument, newCat. Copy each message found in the category cat in 
	class aClass into this new category."

	self copyAllUnobtrusively: (aClass organization listAtCategoryNamed: cat)
		from: aClass
		classified: newCat! !

!ClassDescription methodsFor: 'copying' stamp: 'KR 4/14/2006 16:10'!
copyUnobtrusively: sel from: class classified: cat 
	"Install the method associated with the first arugment, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under the third 
	argument, cat."

	| code category |
	"Useful when modifying an existing class"
	code _ class sourceMethodAt: sel.
	code == nil
		ifFalse: 
			[cat == nil
				ifTrue: [category _ class organization categoryOfElement: sel]
				ifFalse: [category _ cat].
			(self methodDict includesKey: sel)
				ifTrue: [].
			self compileSilently: code classified: category]! !


!ClassDescription methodsFor: 'fileIn/Out' stamp: 'al 3/26/2006 21:49'!
definitionST80
	"Answer a String that defines the receiver."

	| aStream |
	aStream _ WriteStream on: (String new: 300).
	superclass == nil
		ifTrue: [aStream nextPutAll: 'ProtoObject']
		ifFalse: [aStream nextPutAll: superclass name].
	aStream nextPutAll: self kindOfSubclass;
			store: self name.
	(self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [
		aStream cr; tab; nextPutAll: 'uses: ';
			nextPutAll: self traitCompositionString].
	aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString.
	aStream cr; tab; nextPutAll: 'classVariableNames: ';
			store: self classVariablesString.
	aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: self sharedPoolsString.
	aStream cr; tab; nextPutAll: 'category: ';
			store: (SystemOrganization categoryOfElement: self name) asString.

	superclass ifNil: [ 
		aStream nextPutAll: '.'; cr.
		aStream nextPutAll: self name.
		aStream space; nextPutAll: 'superclass: nil'. ].

	^ aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'md 9/7/2006 22:22'!
fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the receiver's category, aString, onto aFileStream. If 
	moveSource, is true, then set the method source pointer to the new file position.
	Note when this method is called with moveSource=true, it is condensing the
	.sources file, and should only write one preamble per method category."

	| selectors |

	aFileStream cr.
	selectors := (aSymbol asString = ClassOrganizer allCategory)
				ifTrue: [ self organization allMethodSelectors ]
				ifFalse: [ self organization listAtCategoryNamed: aSymbol ].

	selectors _ selectors select: [:each | 
		(self includesLocalSelector: each) or: [(self methodDict at: each) sendsToSuper]].
	
	"Overridden to preserve author stamps in sources file regardless"
	selectors do: [:sel |
		self printMethodChunk: sel 
			withPreamble: true
			on: aFileStream 
			moveSource: moveSource 
			toFile: fileIndex].
	^ self! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'bf 12/17/2005 00:04'!
fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the messages of this class that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream.  If 
	moveSource, is true, then set the method source pointer to the new file position.
	Note when this method is called with moveSource=true, it is condensing the
	.changes file, and should only write a preamble for every method."
	| org sels |
	(org _ self organization) categories do: 
		[:cat | 
		sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
		((cat beginsWith: '*') and: [cat endsWith: '-override'])
			ifTrue: [
				sels do:
					[:sel |  self printMethodChunkHistorically: sel on: aFileStream
						moveSource: moveSource toFile: fileIndex]]
			ifFalse: [
				sels do:
					[:sel |  self printMethodChunk: sel withPreamble: true on: aFileStream
						moveSource: moveSource toFile: fileIndex]]]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sumim 9/2/2003 14:36'!
fileOutChangedMessagesHistorically: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File all historical description of the messages of this class that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream.  If 
	moveSource, is true, then set the method source pointer to the new file position.
	Note when this method is called with moveSource=true, it is condensing the
	.changes file, and should only write a preamble for every method."
	| org sels |
	(org _ self organization) categories do: 
		[:cat | 
		sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
		sels do:
			[:sel |  self printMethodChunkHistorically: sel on: aFileStream
							moveSource: moveSource toFile: fileIndex]]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sumim 9/2/2003 14:37'!
moveChangesWithVersionsTo: newFile 
	"Used in the process of condensing changes, this message requests that 
	the source code of all methods of the receiver that have been changed 
	should be moved to newFile."

	| changes |
	changes _ self methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1].
	self fileOutChangedMessagesHistorically: changes
		on: newFile
		moveSource: true
		toFile: 2! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'md 2/20/2006 15:13'!
printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex
	"Copy all source codes historically for the method associated with selector onto the 
	fileStream.  If moveSource true, then also set the source code pointer of the method."

	| preamble method newPos sourceFile endPos category changeList prior |
	category _ self organization categoryOfElement: selector.
	preamble _ self name , ' methodsFor: ', category asString printString.
	method _ self methodDict at: selector.
	((method fileIndex = 0
	or: [(SourceFiles at: method fileIndex) == nil])
	or: [method filePosition = 0])
	ifTrue: [
		outStream cr; nextPut: $!!; nextChunkPut: preamble; cr.
		outStream nextChunkPut: method decompileString.
		outStream nextChunkPut: ' '; cr]
	ifFalse: [
		changeList _ ChangeSet 
			scanVersionsOf: method 
			class: self 
			meta: self isMeta
			category: category 
			selector: selector.
		newPos _ nil.
		sourceFile _ SourceFiles at: method fileIndex.
		changeList reverseDo: [ :chgRec |
			chgRec fileIndex = fileIndex ifTrue: [
				outStream copyPreamble: preamble from: sourceFile at: chgRec position.
				(prior _ chgRec prior) ifNotNil: [
					outStream position: outStream position - 2.
					outStream nextPutAll: ' prior: ', (
						prior first = method fileIndex ifFalse: [prior third] ifTrue: [
							SourceFiles 
								sourcePointerFromFileIndex: method fileIndex 
								andPosition: newPos]) printString.
					outStream nextPut: $!!; cr].
				"Copy the method chunk"
				newPos _ outStream position.
				outStream copyMethodChunkFrom: sourceFile at: chgRec position.
				sourceFile skipSeparators.      "The following chunk may have ]style["
				sourceFile peek == $] ifTrue: [
					outStream cr; copyMethodChunkFrom: sourceFile].
				outStream nextChunkPut: ' '; cr]].
		moveSource ifTrue: [
			endPos _ outStream position.
			method checkOKToAdd: endPos - newPos at: newPos.
			method setSourcePosition: newPos inFile: fileIndex]].
	^ outStream! !


!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 10:59'!
forgetDoIts
	"get rid of old DoIt methods and bogus entries in the ClassOrganizer."
	SystemChangeNotifier uniqueInstance doSilently: [
		self organization
			removeElement: #DoIt;
			removeElement: #DoItIn:.
	].
	super forgetDoIts.! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 11:00'!
obsolete
	"Make the receiver obsolete."
	superclass removeSubclass: self.
	self organization: nil.
	super obsolete.! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 11:26'!
superclass: aClass methodDictionary: mDict format: fmt
	"Basic initialization of the receiver"
	super superclass: aClass methodDictionary: mDict format: fmt.
	instanceVariables _ nil.
	self organization: nil.! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 23:25'!
updateInstances: oldInstances from: oldClass isMeta: isMeta
	"Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)."
	"If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout."
	| map variable instSize newInstances |

	oldInstances isEmpty ifTrue:[^#()]. "no instances to convert"
	isMeta ifTrue: [
		oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance'].
		self soleInstance class == self ifTrue:[
			^self error:'Metaclasses can only have one instance']].
	map _ self instVarMappingFrom: oldClass.
	variable _ self isVariable.
	instSize _ self instSize.
	newInstances _ Array new: oldInstances size.
	1 to: oldInstances size do:[:i|
		newInstances at: i put: (
			self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)].
	"Now perform a bulk mutation of old instances into new ones"
	oldInstances elementsExchangeIdentityWith: newInstances.
	^newInstances "which are now old"! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 20:48'!
updateInstancesFrom: oldClass
	"Recreate any existing instances of the argument, oldClass, as instances of 
	the receiver, which is a newly changed class. Permute variables as 
	necessary. Return the array of old instances (none of which should be
	pointed to legally by anyone but the array)."
	"ar 7/15/1999: The updating below is possibly dangerous. If there are any
	contexts having an old instance as receiver it might crash the system if
	the new receiver in which the context is executed has a different layout.
	See bottom below for a simple example:"
	| oldInstances |
	oldInstances _ oldClass allInstances asArray.
	oldInstances _ self updateInstances: oldInstances from: oldClass isMeta: self isMeta.
	"Now fix up instances in segments that are out on the disk."
	ImageSegment allSubInstancesDo: [:seg |
		seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta].
	^oldInstances

"	| crashingBlock class |
	class _ Object subclass: #CrashTestDummy
		instanceVariableNames: 'instVar'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Crash-Test'.
	class compile:'instVar: value instVar _ value'.
	class compile:'crashingBlock ^[instVar]'.
	crashingBlock _ (class new) instVar: 42; crashingBlock.
	Object subclass: #CrashTestDummy
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Crash-Test'.
	crashingBlock.
	crashingBlock value.
	"
! !


!ClassDescription methodsFor: 'instance variables'!
addInstVarName: aString 
	"Add the argument, aString, as one of the receiver's instance variables."

	self subclassResponsibility! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'!
allInstVarNamesEverywhere
	"Answer the set of inst var names used by the receiver, all superclasses, and all subclasses"

	| aList |
	aList _ OrderedCollection new.
	(self allSuperclasses , self withAllSubclasses asOrderedCollection) do:
		[:cls | aList addAll: cls instVarNames].
	^ aList asSet

	"BorderedMorph allInstVarNamesEverywhere"! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'!
checkForInstVarsOK: instVarString
	"Return true if instVarString does no include any names used in a subclass"
	| instVarArray |
	instVarArray _ Scanner new scanFieldNames: instVarString.
	self allSubclasses do:
		[:cl | cl instVarNames do:
			[:n | (instVarArray includes: n)
				ifTrue: [self error: n , ' is already used in ' , cl name.
						^ false]]].
	^ true! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 22:14'!
chooseClassVarName 
	"Present the user with a list of class variable names and answer the one selected, or nil if none"

	| lines labelStream vars allVars index |
	lines _ OrderedCollection new.
	allVars _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	self withAllSuperclasses reverseDo:
		[:class |
		vars _ class classVarNames asSortedCollection.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better"
	labelStream skip: -1 "cut last CR".
	index _ (UIManager default chooseFrom: (labelStream contents substrings) lines: lines).
	index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ nil].
	^ allVars at: index
! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 22:16'!
chooseInstVarAlphabeticallyThenDo: aBlock
	| allVars index |
	"Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter."

	allVars _ self allInstVarNames asSortedArray.
	allVars isEmpty ifTrue: [^ self inform: 'There are no
instance variables'].

	index _ (UIManager default chooseFrom: allVars lines: #() title: 'Instance variables in
', self name).
	index = 0 ifTrue: [^ self].
	aBlock value: (allVars at: index)! !

!ClassDescription methodsFor: 'instance variables' stamp: 'Noury Bouraqadi 12/13/2005 07:12'!
chooseInstVarThenDo: aBlock 
	"Put up a menu of all the instance variables in the receiver, and when
the user chooses one, evaluate aBlock with the chosen variable as its
parameter.  If the list is 6 or larger, then offer an alphabetical
formulation as an alternative. triggered by a 'show alphabetically' item
at the top of the list."

	| lines labelStream vars allVars index count offerAlpha |
	(count _ self allInstVarNames size) = 0 ifTrue: 
		[^ self inform: 'There are no
instance variables.'].

	allVars _ OrderedCollection new.
	lines _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	(offerAlpha _ count > 5)
		ifTrue:
			[lines add: 1.
			allVars add: 'show alphabetically'.
			labelStream nextPutAll: allVars first; cr].
	self withAllSuperclasses reverseDo:
		[:class |
		vars _ class instVarNames.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream skip: -1 "cut last CR".
	(lines size > 0 and: [lines last = allVars size]) ifTrue:
		[lines removeLast].  "dispense with inelegant line beneath last item"
	index _ (UIManager default chooseFrom: (labelStream contents subStrings: {Character cr}) lines: lines
title: 'Instance variables in', self name).
	index = 0 ifTrue: [^ self].
	(index = 1 and: [offerAlpha]) ifTrue: [^ self
chooseInstVarAlphabeticallyThenDo: aBlock].
	aBlock value: (allVars at: index)! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'!
classThatDefinesClassVariable: classVarName
	"Answer the class that defines the given class variable"

	(self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. 
	^self superclass ifNotNil: [self superclass classThatDefinesClassVariable: classVarName]! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'!
classThatDefinesInstanceVariable: instVarName
	(self instVarNames notNil and: [self instVarNames includes: instVarName asString]) ifTrue: [^ self]. 
	^self superclass ifNotNil: [self superclass classThatDefinesInstanceVariable: instVarName]! !

!ClassDescription methodsFor: 'instance variables'!
forceNewFrom: anArray
    "Create a new instance of the class and fill
    its instance variables up with the array."
    | object max |

    object _ self new.
    max _ self instSize.
    anArray doWithIndex: [:each :index |
        index > max ifFalse:
            [object instVarAt: index put: each]].
    ^ object! !

!ClassDescription methodsFor: 'instance variables'!
instVarNames
	"Answer an Array of the receiver's instance variable names."

	instanceVariables == nil
		ifTrue: [^#()]
		ifFalse: [^instanceVariables]! !

!ClassDescription methodsFor: 'instance variables'!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance 
	variables. Create an error notification if the argument is not found."

	self subclassResponsibility! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'!
renameInstVar: oldName to: newName

	(self confirm: 'WARNING: Renaming of instance variables
is subject to substitution ambiguities.
Do you still wish to attempt it?') ifFalse: [self halt].
	"...In other words, this does a dumb text search-and-replace,
	which might improperly alter, eg, a literal string.  As long as
	the oldName is unique, everything should work jes' fine. - di"

	^ self renameSilentlyInstVar: oldName to: newName! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'!
renameSilentlyInstVar: old to: new
	| i oldName newName |
	oldName _ old asString.
	newName _ new asString.
	(i _ self instVarNames indexOf: oldName) = 0 ifTrue:
		[self error: oldName , ' is not defined in ', self name].
	self allSuperclasses , self withAllSubclasses asOrderedCollection do:
		[:cls | (cls instVarNames includes: newName) ifTrue:
			[self error: newName , ' is already used in ', cls name]].

	self instVarNames replaceFrom: i to: i with: (Array with: newName).
	self replaceSilently: oldName to: newName.	"replace in text body of all methods"! !

!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'!
replaceSilently: old to: new
	"text-replace any part of a method.  Used for class and pool variables.  Don't touch the header.  Not guaranteed to work if name appears in odd circumstances"
	| oldCode newCode parser header body sels oldName newName |

	oldName _ old asString.
	newName _ new asString.
	self withAllSubclasses do:
		[:cls | sels _ cls selectors.
		sels removeAllFoundIn: #(DoIt DoItIn:).
		sels do:
			[:sel |
			oldCode _ cls sourceCodeAt: sel.
			"Don't make changes in the method header"
			(parser _ cls parserClass new) parseSelector: oldCode.
			header _ oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size).
			body _ header size > oldCode size
					ifTrue: ['']
					ifFalse: [oldCode copyFrom: header size+1 to: oldCode size].
			newCode _ header , (body copyReplaceTokens: oldName with: newName).
			newCode ~= oldCode ifTrue:
				[cls compile: newCode
					classified: (cls organization categoryOfElement: sel)
					notifying: nil]].
			cls isMeta ifFalse:
				[oldCode _ cls comment.
				newCode _ oldCode copyReplaceTokens: oldName with: newName.
				newCode ~= oldCode ifTrue:
					[cls comment: newCode]]]! !


!ClassDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:02'!
organization
	"Answer the instance of ClassOrganizer that represents the organization 
	of the messages of the receiver."

	organization ifNil:
		[self organization: (ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray)].
	(organization isMemberOf: Array) ifTrue:
		[self recoverFromMDFaultWithTrace].
	
	"Making sure that subject is set correctly. It should not be necessary."
	organization ifNotNil: [organization setSubject: self].
	^ organization! !

!ClassDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:04'!
organization: aClassOrg
	"Install an instance of ClassOrganizer that represents the organization of the messages of the receiver."

	aClassOrg ifNotNil: [aClassOrg setSubject: self].
	organization _ aClassOrg! !


!ClassDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:08'!
applyChangesOfNewTraitCompositionReplacing: oldComposition
	| changedSelectors |
	changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition.
	self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition.
	^ changedSelectors.! !


!ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:51'!
classVariablesString
	"Answer a string of my class variable names separated by spaces."

	^String streamContents: [ :stream | 
		self classPool keys asSortedCollection 
			do: [ :each | stream nextPutAll: each ]
			separatedBy: [ stream space ] ]! !

!ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:51'!
instanceVariablesString
	"Answer a string of my instance variable names separated by spaces."

	^String streamContents: [ :stream |
		self instVarNames 
			do: [ :each | stream nextPutAll: each ]
			separatedBy: [ stream space ] ]! !

!ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:52'!
sharedPoolsString
	"Answer a string of my shared pool names separated by spaces."

	^String streamContents: [ :stream |
		self sharedPools 
			do: [ :each |
				stream nextPutAll: (self environment 
					keyAtIdentityValue: each 
					ifAbsent: [ 'private' ]) ]
			separatedBy: [ stream space ] ]! !


!ClassDescription methodsFor: '*39Deprecated' stamp: 'sd 2/1/2004 17:59'!
categoryFromUserWithPrompt: aPrompt
	"SystemDictionary categoryFromUserWithPrompt: 'testing'"

	self deprecated: 'Use CodeHolder>>categoryFromUserWithPrompt: aPrompt for: aClass instead'.
	"this deprecation helps to remove UI dependency from the core of Squeak.
	Normally only CodeHolder was calling this method"
	CodeHolder new categoryFromUserWithPrompt: aPrompt for: self! !

!ClassDescription methodsFor: '*39Deprecated' stamp: 'sd 2/1/2004 18:01'!
letUserReclassify: anElement
	"Put up a list of categories and solicit one from the user.  
	Answer true if user indeed made a change, else false"
	
	self deprecated: 'Use CodeHolder>>letUserReclassify: anElement in: aClass'.
	CodeHolder new letUserReclassify: anElement in: self.! !

!ClassDescription methodsFor: '*39Deprecated' stamp: 'md 2/13/2006 17:44'!
methods
	"Answer a ClassCategoryReader for compiling messages that are not classified, as in fileouts made with Smalltalk/V"
	self deprecated: 'Is this used?'.
	^ ClassCategoryReader new setClass: self category: ClassOrganizer default! !


!ClassDescription methodsFor: '*eToys-accessing method dictionary' stamp: 'sw 3/20/2001 13:26'!
namedTileScriptSelectors
	"Answer a list of all the selectors of named tile scripts.  Initially, only Player reimplements, but if we switch to a scheme in which every class can have uniclass subclasses, this would kick in elsewhere"

	^ OrderedCollection new! !



!ClassDescription methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:45'!
allUnreferencedClassVariables
	"Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses"

	^ self systemNavigation allUnreferencedClassVariablesOf: self! !


!ClassDescription methodsFor: 'private' stamp: 'al 11/28/2005 11:51'!
instVarMappingFrom: oldClass
	"Return the mapping from instVars of oldClass to new class that is used for converting old instances of oldClass."
	| oldInstVarNames |
	oldInstVarNames _ oldClass allInstVarNames.
	^self allInstVarNames 
			collect: [:instVarName | oldInstVarNames indexOf: instVarName].! !

!ClassDescription methodsFor: 'private' stamp: 'md 6/2/2006 10:33'!
linesOfCode
	"An approximate measure of lines of code.
	Includes comments, but excludes blank lines."
	| lines |
	lines _ self methodDict values inject: 0 into: [:sum :each | sum + each linesOfCode]. 
	self isMeta 
		ifTrue: [^ lines]
		ifFalse: [^ lines + self class linesOfCode]! !

!ClassDescription methodsFor: 'private' stamp: 'NS 1/28/2004 14:22'!
logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor
	| priorMethodOrNil newText |
	priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: [].
	newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not
						and: [Preferences confirmFirstUseOfStyle])
			ifTrue: [aText askIfAddStyle: priorMethodOrNil req: requestor]
			ifFalse: [aText].
	aCompiledMethodWithNode method putSource: newText
		fromParseNode: aCompiledMethodWithNode node
		class: self category: category withStamp: changeStamp 
		inFile: 2 priorMethod: priorMethodOrNil.! !

!ClassDescription methodsFor: 'private' stamp: 'ar 7/10/1999 11:17'!
newInstanceFrom: oldInstance variable: variable size: instSize map: map
	"Create a new instance of the receiver based on the given old instance.
	The supplied map contains a mapping of the old instVar names into
	the receiver's instVars"
	| new |
	variable
		ifTrue: [new _ self basicNew: oldInstance basicSize]
		ifFalse: [new _ self basicNew].
	1 to: instSize do: 
		[:offset |  (map at: offset) > 0 ifTrue:
			[new instVarAt: offset
					put: (oldInstance instVarAt: (map at: offset))]].
	variable 
		ifTrue: [1 to: oldInstance basicSize do: 
					[:offset |
					new basicAt: offset put: (oldInstance basicAt: offset)]].
	^new! !

!ClassDescription methodsFor: 'private' stamp: 'ar 7/15/1999 17:04'!
setInstVarNames: instVarArray
	"Private - for class initialization only"
	| required |
	required _ self instSize.
	superclass notNil ifTrue:[required _ required - superclass instSize].
	instVarArray size = required
		ifFalse:[^self error: required printString, ' instvar names are required'].
	instVarArray isEmpty
		ifTrue:[instanceVariables _ nil]
		ifFalse:[instanceVariables _ instVarArray asArray].! !


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

ClassDescription class
	instanceVariableNames: ''!
ClassTestCase subclass: #ClassDescriptionTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Classes'!
!ClassDescriptionTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class ClassDescription. 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!


!ClassDescriptionTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:24'!
testOrganization

	| aClassOrganizer |
	aClassOrganizer := ClassDescription organization.
	self assert: (aClassOrganizer isKindOf: ClassOrganizer).! !
TextDiffBuilder subclass: #ClassDiffBuilder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FilePackage'!

!ClassDiffBuilder methodsFor: 'initialize'!
split: aString
	| lines in out c |
	lines := OrderedCollection new.
	in := ReadStream on: aString.
	out := WriteStream on: String new.
	[in atEnd] whileFalse:[
		(c := in next) isSeparator ifTrue:[
			out nextPut: c.
			lines add: out contents.
			out reset.
		] ifFalse:[
			out nextPut: c.
		].
	].
	out position = 0 ifFalse:[
		lines add: out contents.
	].
	^lines! !


!ClassDiffBuilder methodsFor: 'printing' stamp: 'nk 4/24/2004 08:49'!
printPatchSequence: ps on: aStream 
	| type line |
	ps do: [:assoc | 
			type := assoc key.
			line := assoc value.
			aStream
				withAttributes: (self attributesOf: type)
				do: [aStream nextPutAll: line]]! !
HierarchyBrowser subclass: #ClassListBrowser
	instanceVariableNames: 'defaultTitle'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!ClassListBrowser commentStamp: '<historical>' prior: 0!
A ClassListBrowser displays the code for an arbitrary list of classes.

ClassListBrowser example1.  "all classes that have the string 'Pluggable' in their names"
ClassListBrowser example2.  "all classes whose names start with the letter S"
ClassListBrowser example3.  "all variable classes"
ClassListBrowser example4.  "all classes with more than 100 methods"
ClassListBrowser example5.  "all classes that lack class comments"
ClassListBrowser example6.  "all classes that have class instance variables"

ClassListBrowser new initForClassesNamed: #(Browser Boolean) title: 'Browser and Boolean!!'.
!


!ClassListBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initForClassesNamed: nameList title: aTitle
	"Initialize the receiver for the class-name-list and title provided"

	self systemOrganizer: SystemOrganization.
	metaClassIndicated := false.
	defaultTitle := aTitle.
	classList := nameList copy.
	self class openBrowserView:  (self openSystemCatEditString: nil)
		label: aTitle

	"ClassListBrowser new initForClassesNamed: #(Browser CategoryViewer) title: 'Frogs'"! !


!ClassListBrowser methodsFor: 'title' stamp: 'sd 11/20/2005 21:26'!
defaultTitle: aTitle
	"Set the browser's default title"

	defaultTitle := aTitle! !

!ClassListBrowser methodsFor: 'title' stamp: 'sw 7/18/2002 22:43'!
labelString
	"Answer the label strilng to use on the browser"

	^ defaultTitle ifNil: [super labelString]! !

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

ClassListBrowser class
	instanceVariableNames: ''!

!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:01'!
example1
	"Put up a ClassListBrowser that shows all classes that have the string 'Pluggable' in their names"

	self browseClassesSatisfying: [:cl | cl name includesSubString: 'Pluggable'] title: 'Pluggables'

"ClassListBrowser example1"
	! !

!ClassListBrowser class methodsFor: 'examples' stamp: 'sd 4/17/2003 21:21'!
example2
	"Put up a ClassListBrowser that shows all classes whose names start with 
	the letter S"

	self new
		initForClassesNamed: (self systemNavigation allClasses
				collect: [:c | c name]
				thenSelect: [:aName | aName first == $S])
		title: 'All classes starting with S'
	"ClassListBrowser example2"! !

!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:03'!
example3
	"Put up a ClassListBrowser that shows all Variable classes"

	self browseClassesSatisfying:  [:c | c isVariable] title: 'All Variable classes'

"ClassListBrowser example3"
	! !

!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:04'!
example4
	"Put up a ClassListBrowser that shows all classes implementing more than 100 methods"

	self browseClassesSatisfying:
		[:c | (c selectors size + c class selectors size) > 100] title: 'Classes with more than 100 methods'

"ClassListBrowser example4"
	! !

!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:32'!
example5
	"Put up a ClassListBrowser that shows all classes that lack class comments"

	self
		browseClassesSatisfying: 
			[:c | c organization classComment isEmptyOrNil] 
		title: 'Classes lacking class comments'

"ClassListBrowser example5"
	! !

!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:33'!
example6
	"Put up a ClassListBrowser that shows all classes that have class instance variables"

	self
		browseClassesSatisfying: 
			[:c | c class instVarNames size > 0]
		title:
			'Classes that define class-side instance variables'

"ClassListBrowser example6"! !


!ClassListBrowser class methodsFor: 'instance creation' stamp: 'sd 4/17/2003 21:21'!
browseClassesSatisfying: classBlock title: aTitle
	"Put up a ClassListBrowser showing all classes that satisfy the classBlock."

	self new
		initForClassesNamed:
			(self systemNavigation allClasses select:
					[:c | (classBlock value: c) == true]
				thenCollect:
					[:c | c name])
		title:
			aTitle! !
BasicClassOrganizer subclass: #ClassOrganizer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!ClassOrganizer commentStamp: 'NS 4/6/2004 16:13' prior: 0!
I represent method categorization information for classes.  The handling of class comments has gone through a tortuous evolution.   Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted.   Such grandfathered comments now go out on fileouts with '<historical>' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments.  Everything in good time!!!


!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'!
addCategory: catString before: nextCategory
	| oldCategories |
	oldCategories _ self categories copy.
	SystemChangeNotifier uniqueInstance doSilently: [
		super addCategory: catString before: nextCategory].
	self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:28'!
changeFromCategorySpecs: categorySpecs
	| oldDict oldCategories |
	oldDict _ self elementCategoryDict.
	oldCategories _ self categories copy.
	SystemChangeNotifier uniqueInstance doSilently: [
		super changeFromCategorySpecs: categorySpecs].
	self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict.
	self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'!
classify: element under: heading suppressIfDefault: aBoolean
	| oldCat newCat |
	oldCat _ self categoryOfElement: element.
	SystemChangeNotifier uniqueInstance doSilently: [
		super classify: element under: heading suppressIfDefault: aBoolean].
	newCat _ self categoryOfElement: element.
	self notifyOfChangedSelector: element from: oldCat to: newCat.! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'!
removeCategory: cat 
	| oldCategories |
	oldCategories _ self categories copy.
	SystemChangeNotifier uniqueInstance doSilently: [
		super removeCategory: cat].
	self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'!
removeElement: element
	| oldCat |
	oldCat _ self categoryOfElement: element.
	SystemChangeNotifier uniqueInstance doSilently: [
		super removeElement: element].
	self notifyOfChangedSelector: element from: oldCat to: (self categoryOfElement: element).! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'!
removeEmptyCategories
	| oldCategories |
	oldCategories _ self categories copy.
	SystemChangeNotifier uniqueInstance doSilently: [
		super removeEmptyCategories].
	self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'!
renameCategory: oldCatString toBe: newCatString
	| oldCat newCat oldElementsBefore oldElementsAfter |
	oldCat _ oldCatString asSymbol.
	newCat _ newCatString asSymbol.
	oldElementsBefore _ self listAtCategoryNamed: oldCat.
	SystemChangeNotifier uniqueInstance doSilently: [
		super renameCategory: oldCatString toBe: newCatString].
	oldElementsAfter _ (self listAtCategoryNamed: oldCat) asSet.
	oldElementsBefore do: [:each |
		(oldElementsAfter includes: each)
			ifFalse: [self notifyOfChangedSelector: each from: oldCat to: newCat].
	].
	self notifyOfChangedCategoryFrom: oldCat to: newCat.! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:57'!
setDefaultList: aSortedCollection
	| oldDict oldCategories |
	oldDict _ self elementCategoryDict.
	oldCategories _ self categories copy.
	SystemChangeNotifier uniqueInstance doSilently: [
		super setDefaultList: aSortedCollection].
	self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict.
	self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'!
sortCategories
	| oldCategories |
	oldCategories _ self categories copy.
	SystemChangeNotifier uniqueInstance doSilently: [
		super sortCategories].
	self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! !


!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 10:15'!
notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil
	(self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil]) 
		ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! !

!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 23:02'!
notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil
	(self hasSubject and: [oldNameOrNil ~= newNameOrNil]) 
		ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! !

!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/16/2004 10:47'!
notifyOfChangedSelector: element from: oldCategory to: newCategory
	(self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [
		self subject notifyOfRecategorizedSelector: element from: oldCategory to: newCategory.
	].! !

!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/12/2004 20:56'!
notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil
	| newCat |
	(oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil])
		ifTrue: [^ self].
		
	oldDictionaryOrNil isNil ifTrue: [
	newDictionaryOrNil keysAndValuesDo: [:el :cat |
		self notifyOfChangedSelector: el from: nil to: cat].
		^ self.
	].

	newDictionaryOrNil isNil ifTrue: [
	oldDictionaryOrNil keysAndValuesDo: [:el :cat |
		self notifyOfChangedSelector: el from: cat to: nil].
		^ self.
	].
		
	oldDictionaryOrNil keysAndValuesDo: [:el :cat |
		newCat _ newDictionaryOrNil at: el.
		self notifyOfChangedSelector: el from: cat to: newCat.
	].! !


!ClassOrganizer methodsFor: '*ob-standard-testing' stamp: 'cwp 9/18/2004 23:59'!
isClassOrganizer
	^ true! !

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

ClassOrganizer class
	instanceVariableNames: ''!
TestCase subclass: #ClassRenameFixTest
	instanceVariableNames: 'previousChangeSet testsChangeSet newClassName originalName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Bugs'!

!ClassRenameFixTest methodsFor: 'Running' stamp: 'md 9/6/2005 18:31'!
setUp

	previousChangeSet := ChangeSet current.
	testsChangeSet := ChangeSet new.
	ChangeSet newChanges: testsChangeSet.
	SystemChangeNotifier uniqueInstance
		notify: self
		ofSystemChangesOfItem: #class
		change: #Renamed
		using: #verifyRenameEvent:.
	super setUp! !

!ClassRenameFixTest methodsFor: 'Running' stamp: 'ar 9/27/2005 20:06'!
tearDown

	self removeEverythingInSetFromSystem: testsChangeSet.
	ChangeSet newChanges: previousChangeSet.
	ChangeSet removeChangeSet: testsChangeSet.
	previousChangeSet := nil.
	testsChangeSet := nil.
	super tearDown.! !

!ClassRenameFixTest methodsFor: 'Running' stamp: 'cmm 8/7/2005 19:04'!
verifyRenameEvent: aRenamedEvent

	| renamedClass |
	self assert: aRenamedEvent isRenamed.
	renamedClass :=  aRenamedEvent item.
	self assert: (Smalltalk classNamed: newClassName) name = newClassName.
	self assert: renamedClass name = newClassName! !


!ClassRenameFixTest methodsFor: 'Tests' stamp: 'md 9/6/2005 18:31'!
renameClassUsing: aBlock

	| createdClass foundClasses  |
	originalName := self newUniqueClassName. 
	createdClass := Object 
		subclass: originalName
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'ClassRenameFix-GeneradClass'.
	newClassName := self newUniqueClassName.
	aBlock value: createdClass value: newClassName.
	self assert: (Smalltalk classNamed: originalName) isNil.
	self assert: (Smalltalk classNamed: newClassName) notNil.
	foundClasses := Smalltalk organization listAtCategoryNamed: 'ClassRenameFix-GeneradClass'.
	self assert: (foundClasses notEmpty).
	self assert: (foundClasses includes: newClassName).
	self assert: (createdClass name = newClassName).! !

!ClassRenameFixTest methodsFor: 'Tests' stamp: 'md 9/6/2005 18:30'!
testRenameClassUsingClass
	"self run: #testRenameClassUsingClass"

	self renameClassUsing: [:class :newName | class rename: newName].! !


!ClassRenameFixTest methodsFor: 'Private' stamp: 'md 9/6/2005 18:30'!
newUniqueClassName
	"Return a class name that is not used in the system."

	"self new newClassName"

	| baseName newName |
	baseName := 'AutoGeneratedClassForTestingSystemChanges'.
	1 to: 9999
		do: 
			[:number | 
			newName := baseName , number printString.
			(Smalltalk hasClassNamed: newName) ifFalse: [^newName asSymbol]].
	^self 
		error: 'Can no longer find a new and unique class name for the SystemChangeTest !!'! !

!ClassRenameFixTest methodsFor: 'Private' stamp: 'md 9/6/2005 18:30'!
removeEverythingInSetFromSystem: aChangeSet 

	aChangeSet changedMessageList
		do: [:methodRef | methodRef actualClass removeSelector: methodRef methodSymbol].
	aChangeSet changedClasses
		do: [:each | each isMeta
				ifFalse: [each removeFromSystemUnlogged]]! !
ObjectRepresentativeMorph subclass: #ClassRepresentativeMorph
	instanceVariableNames: 'classRepresented'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
TestCase subclass: #ClassTest
	instanceVariableNames: 'className'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Classes'!

!ClassTest methodsFor: 'setup' stamp: 'Noury Bouraqadi 3/24/2006 20:42'!
deleteClass
	| class |
	class := Smalltalk at: className ifAbsent: [^self].
	class removeFromChanges; removeFromSystemUnlogged 
	! !

!ClassTest methodsFor: 'setup' stamp: 'Noury Bouraqadi 3/24/2006 20:42'!
setUp
	className := #TUTU.
	self deleteClass.
	Object subclass: className
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'KernelTests-Classes'! !

!ClassTest methodsFor: 'setup' stamp: 'Noury Bouraqadi 3/24/2006 20:42'!
tearDown
	self deleteClass! !


!ClassTest methodsFor: 'testing' stamp: 'md 1/5/2004 14:59'!
testAddInstVarName
	"self run: #testAddInstVarName"
	
	
	| tutu |
	tutu := Smalltalk at: #TUTU.
	tutu addInstVarName: 'x'.
	self assert: (tutu instVarNames = #('x')).
	tutu addInstVarName: 'y'.
	self assert: (tutu instVarNames = #('x' 'y'))
	
	! !

!ClassTest methodsFor: 'testing' stamp: 'Noury Bouraqadi 3/24/2006 20:38'!
testRenaming
	| oldName newName newMetaclassName class |
	oldName := className.
	newName := #RenamedTUTU.
	newMetaclassName := (newName, #' class') asSymbol.
	class := Smalltalk at: oldName.
	class class compile: 'dummyMeth'.
	class rename: newName.
	className := class name. "Important for tearDown"
	self assert: class name = newName.
	self assert: (ChangeSet current changedClassNames includes: newName). 
	self assert: (ChangeSet current changedClassNames includes: newMetaclassName).
	! !


!ClassTest methodsFor: 'testing - compiling' stamp: 'sd 6/5/2005 08:25'!
testCompileAll

	self shouldnt: [ClassTest compileAll] raise: Error.! !


!ClassTest methodsFor: 'testing - classside' stamp: 'md 2/20/2006 23:04'!
testRootsOfTheWorld
	self assert: Class rootsOfTheWorld size = 3.
	self assert: (Class rootsOfTheWorld allSatisfy: [:each | each superclass = nil]).
	! !
TestCase subclass: #ClassTestCase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!ClassTestCase commentStamp: 'brp 7/26/2003 16:57' prior: 0!
This class is intended for unit tests of individual classes and their metaclasses.

It provides methods to determine the coverage of the unit tests.

Subclasses are expected to re-implement #classesToBeTested and #selectorsToBeIgnored.

They should also implement to confirm that all methods have been tested.

#testCoverage

	super testCoverage.

!


!ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:32'!
categoriesForClass: aClass

 ^ aClass organization allMethodSelectors collect: 
			[:each |  aClass organization categoryOfElement: each].
! !

!ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:28'!
targetClass
  |className|

  className := self class name asText copyFrom: 0 to: self class name size - 4.
  ^ Smalltalk at: (className asString asSymbol).
! !


!ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/27/2003 12:39'!
classToBeTested
	
	self subclassResponsibility! !

!ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/26/2003 16:35'!
selectorsNotTested

	^ self selectorsToBeTested difference: self selectorsTested.
! !

!ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/26/2003 17:22'!
selectorsToBeIgnored
	^ #(#DoIt #DoItIn:)! !

!ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/27/2003 12:40'!
selectorsToBeTested

	^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors]) 
			difference: self selectorsToBeIgnored! !


!ClassTestCase methodsFor: 'tests' stamp: 'md 3/26/2003 17:39'!
testClassComment
	self shouldnt: [self targetClass organization hasNoComment].! !

!ClassTestCase methodsFor: 'tests' stamp: 'brp 12/14/2003 15:51'!
testCoverage

	| untested | 
	self class mustTestCoverage ifTrue:
		[ untested := self selectorsNotTested.
		self assert: untested isEmpty 
		description: untested size asString, ' selectors are not covered' ]! !

!ClassTestCase methodsFor: 'tests' stamp: 'md 3/25/2003 23:07'!
testNew
	self shouldnt: [self targetClass new] raise: Error.! !

!ClassTestCase methodsFor: 'tests' stamp: 'md 3/26/2003 17:24'!
testUnCategorizedMethods
	| categories slips  |
	categories := self categoriesForClass: self targetClass.
	slips := categories select: [:each | each = #'as yet unclassified'].
	self should: [slips isEmpty].	! !


!ClassTestCase methodsFor: 'Coverage' stamp: 'apb 4/15/2006 11:50'!
selectorsTested
	| literals |
	literals := Set new.
	self class
		selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test')
			ifTrue: [ literals addAll: (m messages)] ].
	^ literals asSortedArray! !

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

ClassTestCase class
	instanceVariableNames: ''!

!ClassTestCase class methodsFor: 'Testing' stamp: 'md 2/22/2006 14:21'!
isAbstract
	"Override to true if a TestCase subclass is Abstract and should not have
	TestCase instances built from it"

	^self name = #ClassTestCase
			! !

!ClassTestCase class methodsFor: 'Testing' stamp: 'brp 12/14/2003 15:50'!
mustTestCoverage

	^ false! !
TraitDescription subclass: #ClassTrait
	uses: TTransformationCompatibility + TApplyingOnClassSide
	instanceVariableNames: 'baseTrait'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Kernel'!
!ClassTrait commentStamp: '<historical>' prior: 0!
While every class has an associated metaclass, a trait can have an associated classtrait, an instance of me. To preserve metaclass compatibility, the associated classtrait (if there is one) is automatically applied to the metaclass, whenever a trait is applied to a class. Consequently, a trait with an associated classtrait can only be applied to classes, whereas a trait without a classtrait can be applied to both classes and metaclasses.!


!ClassTrait methodsFor: 'accessing' stamp: 'al 4/21/2004 09:38'!
name
	^self baseTrait name , ' classTrait'! !


!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:38'!
baseTrait
	^baseTrait! !

!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'!
baseTrait: aTrait
	self assert: aTrait isBaseTrait.
	baseTrait _ aTrait
	
	! !

!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:38'!
classTrait
	^self! !

!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/20/2004 09:44'!
classTrait: aClassTrait
	self error: 'Trait is already a class trait!!'
	
	! !

!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:41'!
hasClassTrait
	^false! !

!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'!
isBaseTrait
	^false! !

!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'!
isClassTrait
	^true! !


!ClassTrait methodsFor: 'compiling' stamp: 'al 4/7/2004 14:54'!
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource
	
	| classSideUsersOfBaseTrait message |
	classSideUsersOfBaseTrait _ self baseTrait users select: [:each | each isClassSide].
	classSideUsersOfBaseTrait isEmpty ifFalse: [
		message _ String streamContents: [:stream |
			stream nextPutAll: 'The instance side of this trait is used on '; cr.
			classSideUsersOfBaseTrait
				do: [:each | stream nextPutAll: each name]
				separatedBy: [ stream nextPutAll: ', '].
			stream cr; nextPutAll: ' You can not add methods to the class side of this trait!!'].
		^TraitException signal:  message].
	
	^super
		compile: text
		classified: category
		withStamp: changeStamp
		notifying: requestor
		logSource: logSource! !


!ClassTrait methodsFor: 'composition' stamp: 'al 7/18/2004 14:02'!
uses: aTraitCompositionOrArray
	| copyOfOldTrait newComposition |
	copyOfOldTrait _ self copy.
	newComposition _ aTraitCompositionOrArray asTraitComposition.
	self assertConsistantCompositionsForNew: newComposition.
	self setTraitComposition: newComposition.
	SystemChangeNotifier uniqueInstance
		traitDefinitionChangedFrom: copyOfOldTrait to: self.! !


!ClassTrait methodsFor: 'copying' stamp: 'dvf 8/30/2005 16:51'!
copy
	"Make a copy of the receiver. Share the 
	reference to the base trait."

	^(self class new)
		baseTrait: self baseTrait;
		initializeFrom: self;
		yourself! !



!ClassTrait methodsFor: 'fileIn/Out' stamp: 'al 3/26/2006 21:31'!
definitionST80
	^String streamContents: [:stream |
		stream
			nextPutAll: self name;
			crtab;
			nextPutAll: 'uses: ';
			nextPutAll: self traitCompositionString]! !


!ClassTrait methodsFor: 'initialize' stamp: 'al 7/18/2004 12:11'!
baseClass: aTrait traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization

	self baseTrait: aTrait.
	self	
		traitComposition: aComposition
		methodDict: aMethodDict
		localSelectors: aSet
		organization: aClassOrganization
! !

!ClassTrait methodsFor: 'initialize' stamp: 'dvf 8/30/2005 16:48'!
initializeFrom: anotherClassTrait
	traitComposition _ self traitComposition copyTraitExpression.
	methodDict _ self methodDict copy.
	localSelectors _ self localSelectors copy.
	organization _ self organization copy.! !

!ClassTrait methodsFor: 'initialize' stamp: 'al 3/24/2004 20:37'!
initializeWithBaseTrait: aTrait
	self baseTrait: aTrait.
	self noteNewBaseTraitCompositionApplied: aTrait traitComposition.
	aTrait users do: [:each | self addUser: each classSide].
	! !

!ClassTrait methodsFor: 'initialize' stamp: 'al 7/17/2004 22:56'!
traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization

	"Used by copy of Trait"

	localSelectors _ aSet.
	methodDict _ aMethodDict.
	traitComposition _ aComposition.
	self organization: aClassOrganization! !


!ClassTrait methodsFor: '*monticello' stamp: 'al 3/26/2006 21:31'!
asMCDefinition
	^MCClassTraitDefinition
		baseTraitName: self baseTrait name
		classTraitComposition: self traitCompositionString
			! !


!ClassTrait methodsFor: '*ob-standard-converting' stamp: 'lr 3/9/2006 21:09'!
asClassSideNode
	^ OBMetaclassNode on: self baseTrait! !

!ClassTrait methodsFor: '*ob-standard-converting' stamp: 'lr 3/9/2006 21:02'!
asNode
	^ OBMetaclassNode on: self! !

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

ClassTrait class
	uses: TTransformationCompatibility classTrait + TApplyingOnClassSide classTrait
	instanceVariableNames: ''!

!ClassTrait class methodsFor: 'instance creation' stamp: 'al 3/23/2004 19:41'!
for: aTrait
	^self new
		initializeWithBaseTrait: aTrait;
		yourself! !
TraitsTestCase subclass: #ClassTraitTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!ClassTraitTest methodsFor: 'testing' stamp: 'al 3/26/2006 12:15'!
testChanges
	"Test the most important features to ensure that
	general functionality of class traits are working."

	"self run: #testChanges"

	| classTrait |
	classTrait := self t1 classTrait.
	classTrait compile: 'm1ClassSide ^17' classified: 'mycategory'.

	"local selectors"
	self assert: (classTrait includesLocalSelector: #m1ClassSide).
	self deny: (classTrait includesLocalSelector: #otherSelector).

	"propagation"
	self assert: (self t5 classSide methodDict includesKey: #m1ClassSide).
	self assert: (self c2 class methodDict includesKey: #m1ClassSide).
	self shouldnt: [self c2 m1ClassSide] raise: Error.
	self assert: self c2 m1ClassSide = 17.

	"category"
	self assert: (self c2 class organization categoryOfElement: #m1ClassSide) 
				= 'mycategory'.

	"conflicts"
	self t2 classSide compile: 'm1ClassSide' classified: 'mycategory'.
	self assert: (self c2 class methodDict includesKey: #m1ClassSide).
	self deny: (self c2 class includesLocalSelector: #m1ClassSide).
	self should: [self c2 m1ClassSide] raise: Error.

	"conflict category"
	self assert: (self c2 class organization categoryOfElement: #m1ClassSide) 
				= #mycategory! !

!ClassTraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testConflictsAliasesAndExclusions
	"conflict"

	self t1 classTrait compile: 'm2ClassSide: x ^99' classified: 'mycategory'.
	self assert: (self t1 classTrait includesLocalSelector: #m2ClassSide:).
	self assert: (self t5 classTrait >> #m2ClassSide:) isConflict.
	self assert: (self c2 class >> #m2ClassSide:) isConflict.

	"exclusion and alias"
	self assert: self t5 classSide traitComposition asString 
				= 'T1 classTrait + T2 classTrait'.
	self t5 classSide 
		setTraitCompositionFrom: (self t1 classTrait @ { (#m2ClassSideAlias1: -> #m2ClassSide:) } 
				+ self t2 classTrait) @ { (#m2ClassSideAlias2: -> #m2ClassSide:) } 
				- { #m2ClassSide: }.
	self deny: (self t5 classTrait >> #m2ClassSide:) isConflict.
	self deny: (self c2 class >> #m2ClassSide:) isConflict.
	self assert: (self c2 m2ClassSideAlias1: 13) = 99.
	self assert: (self c2 m2ClassSideAlias2: 13) = 13! !

!ClassTraitTest methodsFor: 'testing' stamp: 'dvf 8/30/2005 16:17'!
testInitialization
	"self run: #testInitialization"

	| classTrait |
	classTrait := self t1 classTrait.
	self assert: self t1 hasClassTrait.
	self assert: self t1 classTrait == classTrait.
	self assert: classTrait isClassTrait.
	self assert: classTrait classSide == classTrait.
	self deny: classTrait isBaseTrait.
	self assert: classTrait baseTrait == self t1.

	"assert classtrait methods are propagated to users when setting traitComposition"
	self assert: self t4 hasClassTrait.
	self assert: self t5 hasClassTrait.
	self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:).
	self assert: (self t4 classSide methodDict includesKey: #m2ClassSide:).
	self assert: (self t5 classSide methodDict includesKey: #m2ClassSide:).
	self assert: (self c2 m2ClassSide: 17) = 17! !

!ClassTraitTest methodsFor: 'testing' stamp: 'al 3/26/2006 12:06'!
testUsers
	self assert: self t2 classSide users size = 3.
	self assert: (self t2 classSide users includesAllOf: {				
		(self t4 classTrait).
		(self t5 classTrait).
		(self t6 classTrait) }).
	self assert: self t5 classSide users size = 1.
	self assert: self t5 classSide users anyOne = self c2 class.
	self c2 setTraitCompositionFrom: self t1 + self t5.
	self assert: self t5 classSide users size = 1.
	self assert: self t5 classSide users anyOne = self c2 class.
	self c2 setTraitComposition: self t2 asTraitComposition.
	self assert: self t5 classSide users isEmpty! !

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

ClassTraitTest class
	instanceVariableNames: ''!
Object subclass: #Clause
	instanceVariableNames: 'string phrases accent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!
!Clause commentStamp: '<historical>' prior: 0!
My instances are clauses. They can carry a phrase accent (applicable to their last phrase) and a boundary tone: 'L- L%' (for declarative sentences in American English), 'H- H%' (for Yes-No questions), etc.!


!Clause methodsFor: 'accessing' stamp: 'len 12/12/1999 22:46'!
accent
	^ accent! !

!Clause methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
accent: aString
	accent := aString! !

!Clause methodsFor: 'accessing' stamp: 'len 12/13/1999 02:32'!
accept: anObject
	anObject clause: self! !

!Clause methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
events
	| answer |
	answer := CompositeEvent new.
	self phrases do: [ :each | answer addAll: each events].
	^ answer! !

!Clause methodsFor: 'accessing' stamp: 'len 12/8/1999 17:50'!
lastSyllable
	^ self phrases last lastSyllable! !

!Clause methodsFor: 'accessing' stamp: 'len 12/8/1999 17:49'!
phrases
	^ phrases! !

!Clause methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
phrases: aCollection
	phrases := aCollection! !

!Clause methodsFor: 'accessing' stamp: 'len 12/12/1999 22:22'!
string
	^ string! !

!Clause methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
string: aString
	string := aString! !


!Clause methodsFor: 'enumarating' stamp: 'len 12/13/1999 01:19'!
eventsDo: aBlock
	self phrases do: [ :phrase | phrase eventsDo: aBlock]! !

!Clause methodsFor: 'enumarating' stamp: 'len 12/14/1999 04:22'!
syllablesDo: aBlock
	self wordsDo: [ :each | each syllables do: aBlock]! !

!Clause methodsFor: 'enumarating' stamp: 'len 12/13/1999 02:40'!
wordsDo: aBlock
	self phrases do: [ :each | each words do: aBlock]! !


!Clause methodsFor: 'printing' stamp: 'len 12/8/1999 18:17'!
printOn: aStream
	self phrases do: [ :each | aStream print: each; nextPutAll: '- ']! !
RectangleMorph subclass: #ClickExerciser
	instanceVariableNames: 'buttons'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!ClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/23/2005 19:31'!
allSelectors
^ #( #click: #doubleClick: #doubleClickTimeout: #startDrag:) ! !

!ClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/23/2005 19:31'!
alternateBorderColor
"answer the alternate color/fill style for the receiver"
	^ Color yellow! !

!ClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/25/2005 22:38'!
alternateColor
"answer the alternate color/fill style for the receiver"
	^ Color cyan! !

!ClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/23/2005 19:31'!
balloonText
	^ 'Double-click on me to change my color; 
single-click on me to change border color;
hold mouse down within me and then move it to grow 
 or shrink. When I time out my border changes width.
Choose which of the above will work
by selecting the boxes in the middle.
See the boxes balloons.' translated! !

!ClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/23/2005 19:31'!
defaultBorderColor
"answer the alternate color/fill style for the receiver"
	^ Color black! !

!ClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/23/2005 19:31'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color red! !

!ClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/23/2005 19:31'!
selectors
^  self allSelectors with: buttons collect: [ :s :b | b isOn ifTrue: [ s ] ifFalse: [nil ] ] .! !


!ClickExerciser methodsFor: 'event handling' stamp: 'wiz 8/23/2005 19:31'!
click: evt
	self showBalloon: 'click' hand: evt hand.
	self borderColor: (self borderColor = self defaultBorderColor ifTrue: [self alternateBorderColor] ifFalse: [self defaultBorderColor])
! !

!ClickExerciser methodsFor: 'event handling' stamp: 'wiz 8/23/2005 19:31'!
doubleClickTimeout: evt 
	self showBalloon: 'ClickTimeout' hand: evt hand.
	self borderWidth: self borderWidth \\ 11 + 2! !

!ClickExerciser methodsFor: 'event handling' stamp: 'wiz 8/23/2005 19:31'!
doubleClick: evt
	self showBalloon: 'doubleClick' hand: evt hand.
	self color: ((color = self alternateColor ) ifTrue: [self defaultColor] ifFalse: [self alternateColor])
! !

!ClickExerciser methodsFor: 'event handling' stamp: 'wiz 8/23/2005 19:31'!
handlesMouseDown: evt
	^ true! !

!ClickExerciser methodsFor: 'event handling' stamp: 'wiz 8/23/2005 19:31'!
mouseDown: evt 
	"Do nothing upon mouse-down except inform the hand to watch for a  
	double-click; wait until an ensuing click:, doubleClick:, or drag:  
	message gets dispatched"
	Preferences disable: #NewClickTest .
	evt hand
		waitForClicksOrDrag: self
		event: evt
		selectors: self selectors
		threshold: 10
	! !

!ClickExerciser methodsFor: 'event handling' stamp: 'wiz 8/23/2005 19:31'!
startDrag: evt
	"We'll get a mouseDown first, some mouseMoves, and a mouseUp event last"
	| height width both  |
	"evt isMouseDown ifTrue:
		[self showBalloon: 'drag (mouse down)' hand: evt hand.
		self world displayWorld.
		(Delay forMilliseconds: 750) wait].
	evt isMouseUp ifTrue:
		[self showBalloon: 'drag (mouse up)' hand: evt hand].
	(evt isMouseUp or: [evt isMouseDown]) ifFalse:
		[self showBalloon: 'drag (mouse still down)' hand: evt hand].
	(self containsPoint: evt cursorPoint)
		ifFalse: [^ self]."
	self showBalloon: 'drag (mouse down)' hand: evt hand.

	width  := (self defaultSide max: self extent x) min: self alternateSide.
	height := (self defaultSide max: self extent y) min: self alternateSide.
	both  := self defaultSide + self alternateSide. 

self extent:	
 (((color = (self defaultColor)
		ifTrue:
			[ (both - height) @ width  ]
		ifFalse:
			[ height @ (both - width) ]) 
	max: self defaultSide asPoint) 
	min: self alternateSide asPoint )
	
	! !


!ClickExerciser methodsFor: 'initialization' stamp: 'wiz 8/23/2005 19:31'!
alternateSide
"initial extent is square. We return an alternate height/width for drag to manipulate."
^ (self defaultSide asFloat * 1.618) rounded .
! !

!ClickExerciser methodsFor: 'initialization' stamp: 'wiz 8/23/2005 19:31'!
defaultSide
"initial extent is square. We return the default height/width."
^ 100 .
! !

!ClickExerciser methodsFor: 'initialization' stamp: 'wiz 8/25/2005 23:05'!
initButtons
| aButton positions |
aButton := ThreePhaseButtonMorph checkBox. 
positions := ((0@0) rect: aButton extent negated) corners + self center .
buttons := positions collect: [ :p | ThreePhaseButtonMorph checkBox position: p; state: #on ] .
buttons with: self allSelectors collect: [ :b :s | b setBalloonText:  s asString maxLineLength: s size  ] .
self removeAllMorphs .
self addAllMorphs:  buttons .
! !

!ClickExerciser methodsFor: 'initialization' stamp: 'wiz 8/23/2005 19:31'!
initialize
super initialize.
self extent: self defaultSide asPoint.
self initButtons .! !

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

ClickExerciser class
	instanceVariableNames: ''!

!ClickExerciser class methodsFor: 'parts bin' stamp: 'wiz 8/23/2005 19:31'!
descriptionForPartsBin
"WizClickExample descriptionForPartsBin"
	^ self partName:	'ExersizeClick'
		categories:		#('Demo')
		documentation:	'An exersizer for double-click in moprhic'! !
Object subclass: #Clipboard
	instanceVariableNames: 'contents recent interpreter'
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'ST80-Kernel-Remnants'!
!Clipboard commentStamp: '<historical>' prior: 0!
The Clipboard class implements a basic buffering scheme for text. The currently selected text is also exported to the OS so that text can be copied from and to other applications. Commonly only a single instance is used (the default clipboard) but applications are free to use other than the default clipboard if necessary.!


!Clipboard methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:32'!
chooseRecentClipping  "Clipboard chooseRecentClipping"
	"Choose by menu from among the recent clippings"

	recent ifNil: [^ nil].
	^ (SelectionMenu
		labelList: (recent collect: [:txt | ((txt asString contractTo: 50)
									copyReplaceAll: Character cr asString with: '\')
									copyReplaceAll: Character tab asString with: '|'])
		selections: recent) startUp.

! !

!Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:07'!
clearInterpreter

	interpreter _ nil.
! !

!Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:04'!
clipboardText
	"Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard."

	| string decodedString |
	string _ self primitiveClipboardText.
	(string isEmpty
			or: [string = contents asString])
		ifTrue: [^ contents].
	decodedString _ self interpreter fromSystemClipboard: string.
	^ decodedString = contents asString
		ifTrue: [contents]
		ifFalse: [decodedString asText].
! !

!Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:12'!
clipboardText: text 

	| string |
	string _ text asString.
	self noteRecentClipping: text asText.
	contents _ text asText.
	string _ self interpreter toSystemClipboard: string.
	self primitiveClipboardText: string.
! !

!Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 18:23'!
interpreter

	interpreter ifNil: [self setInterpreter].
	^ interpreter.
! !

!Clipboard methodsFor: 'accessing' stamp: 'mir 7/20/2004 15:44'!
setInterpreter

	interpreter _ LanguageEnvironment defaultClipboardInterpreter.
	interpreter ifNil: [
		"Should never be reached, but just in case."
		interpreter _ NoConversionClipboardInterpreter new].
! !


!Clipboard methodsFor: 'initialize' stamp: 'ar 1/15/2001 18:34'!
initialize
	contents _ '' asText.
	recent _ OrderedCollection new.! !


!Clipboard methodsFor: 'primitives' stamp: 'ar 1/15/2001 18:28'!
primitiveClipboardText
	"Get the current clipboard text. Return the empty string if the primitive fails."
	<primitive: 141>
	^ ''! !

!Clipboard methodsFor: 'primitives' stamp: 'ar 1/15/2001 18:30'!
primitiveClipboardText: aString
	"Set the current clipboard text to the given string."

	<primitive: 141>
	"don't fail if the primitive is not implemented"! !


!Clipboard methodsFor: 'private' stamp: 'ar 1/15/2001 18:34'!
noteRecentClipping: text
	"Keep most recent clippings in a queue for pasteRecent (paste... command)"
	text isEmpty ifTrue: [^ self].
	text size > 50000 ifTrue: [^ self].
	(recent includes: text) ifTrue: [^ self].
	recent addFirst: text.
	[recent size > 5] whileTrue: [recent removeLast].
! !

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

Clipboard class
	instanceVariableNames: ''!

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:45'!
chooseRecentClipping  "Clipboard chooseRecentClipping"
	"Choose by menu from among the recent clippings"
	^self default chooseRecentClipping! !

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'!
clipboardText "Clipboard clipboardText"
	^self default clipboardText.! !

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'!
clipboardText: aText 
	^self default clipboardText: aText! !

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:33'!
default
	^Default ifNil:[Default _ self new].! !

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:48'!
default: aClipboard
	"So that clients can switch between different default clipboards"
	Default _ aClipboard.! !


!Clipboard class methodsFor: 'class initialization' stamp: 'yo 8/11/2003 22:43'!
clearInterpreters

	self allInstances do: [:each | each clearInterpreter].
! !

!Clipboard class methodsFor: 'class initialization' stamp: 'yo 12/29/2003 01:03'!
startUp

	self clearInterpreters.
! !
Object subclass: #ClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 19:03'!
fromSystemClipboard: aString

	self subclassResponsibility.
! !

!ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 19:03'!
toSystemClipboard: aString

	self subclassResponsibility.
! !
TextMorph subclass: #ClipboardMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!ClipboardMorph commentStamp: '<historical>' prior: 0!
A morph that always displays the current contents of the text clipboard.!


!ClipboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color
		r: 1.0
		g: 0.355
		b: 0.452! !

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

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


!ClipboardMorph methodsFor: 'parts bin' stamp: 'dgd 2/14/2003 22:09'!
initializeToStandAlone
	super initializeToStandAlone.
""
	self initialize.
	""
	self extent: 200 @ 100.
	self
		backgroundColor: (Color
				r: 0.484
				g: 1.0
				b: 0.484).
	self setBalloonText: 'This shows the current contents of the text clipboard'.
	self newContents: Clipboard clipboardText! !


!ClipboardMorph methodsFor: 'stepping and presenter' stamp: 'sw 6/27/2001 14:15'!
step
	self newContents: Clipboard clipboardText! !


!ClipboardMorph methodsFor: 'testing' stamp: 'sw 6/27/2001 14:18'!
stepTime
	"Answer the interval between steps -- in this case a leisurely 1 seconds"

	^ 1000! !

!ClipboardMorph methodsFor: 'testing' stamp: 'sw 6/27/2001 13:40'!
wantsSteps
	^ true! !

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

ClipboardMorph class
	instanceVariableNames: ''!

!ClipboardMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:21'!
descriptionForPartsBin
	^ self partName:	'Clipboard'
		categories:		#('Useful')
		documentation:	'This object will always show whatever is on the text clipboard'! !
PluggableCanvas subclass: #ClippingCanvas
	instanceVariableNames: 'canvas clipRect'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!ClippingCanvas commentStamp: '<historical>' prior: 0!
A modified canvas which clips all drawing commands.!


!ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/25/2000 22:56'!
clipRect
	^clipRect! !

!ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/26/2000 14:22'!
contentsOfArea: aRectangle into: aForm
	self flag: #hack.    "ignore the clipping specification for this command.  This is purely so that CachingCanvas will work properly when clipped.  There *has* to be a clean way to do this...."
	^canvas contentsOfArea: aRectangle into: aForm! !

!ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:17'!
form
	^canvas form! !

!ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:15'!
shadowColor
	^canvas shadowColor! !


!ClippingCanvas methodsFor: 'initialization' stamp: 'ls 3/20/2000 20:44'!
canvas: aCanvas  clipRect: aRectangle
	canvas := aCanvas.
	clipRect := aRectangle.! !


!ClippingCanvas methodsFor: 'testing' stamp: 'ls 3/20/2000 21:17'!
isBalloonCanvas
	^canvas isBalloonCanvas! !

!ClippingCanvas methodsFor: 'testing' stamp: 'ls 3/20/2000 21:18'!
isShadowDrawing
	^canvas isShadowDrawing! !


!ClippingCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:44'!
apply: aBlock
	"apply the given block to the inner canvas with clipRect as the clipping rectangle"
	canvas clipBy: clipRect during: aBlock! !

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

ClippingCanvas class
	instanceVariableNames: ''!

!ClippingCanvas class methodsFor: 'instance creation' stamp: 'ls 3/20/2000 20:45'!
canvas: aCanvas  clipRect: aRectangle
	^self new canvas: aCanvas  clipRect: aRectangle! !
StringMorph subclass: #ClockMorph
	instanceVariableNames: 'showSeconds show24hr'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!ClockMorph methodsFor: '24hr' stamp: 'fc 2/8/2004 11:38'!
show24hr: aBoolean
	show24hr _ aBoolean! !

!ClockMorph methodsFor: '24hr' stamp: 'fc 2/8/2004 11:39'!
toggleShowing24hr
	show24hr _ (show24hr == true) not
! !


!ClockMorph methodsFor: 'initialization' stamp: 'fc 2/8/2004 11:33'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	showSeconds _ true.
	show24hr _ false.
	self step! !


!ClockMorph methodsFor: 'menu' stamp: 'fc 2/8/2004 11:57'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Note minor loose end here -- if the menu is persistent, then the wording will be wrong half the time"
	| item |
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	item _ showSeconds == true
		ifTrue:	['stop showing seconds']
		ifFalse: ['start showing seconds'].
	aCustomMenu add: item translated target: self action: #toggleShowingSeconds.
	item _ show24hr == true
		ifTrue: ['display Am/Pm']
		ifFalse: ['display 24 hour'].
	aCustomMenu add: item translated target: self action: #toggleShowing24hr.	
		
! !


!ClockMorph methodsFor: 'parts bin' stamp: 'sw 7/12/2001 17:41'!
initializeToStandAlone
	super initializeToStandAlone.
	showSeconds _ true.
	self step! !


!ClockMorph methodsFor: 'seconds' stamp: 'sw 2/17/1999 14:39'!
showSeconds: aBoolean
	showSeconds _ aBoolean! !

!ClockMorph methodsFor: 'seconds' stamp: 'sw 2/17/1999 14:53'!
toggleShowingSeconds
	showSeconds _ (showSeconds == true) not
! !


!ClockMorph methodsFor: 'stepping and presenter' stamp: 'fc 2/8/2004 11:40'!
step
	| time |
	super step.
	time _ String streamContents:
		[:aStrm | Time now print24: (show24hr == true) showSeconds: (showSeconds == true) on: aStrm].

	self contents: time			! !


!ClockMorph methodsFor: 'testing'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 1000! !

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

ClockMorph class
	instanceVariableNames: ''!

!ClockMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:00'!
initialize

	self registerInFlapsRegistry.	! !

!ClockMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:02'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(ClockMorph	authoringPrototype		'Clock'			'A simple digital clock')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(ClockMorph	authoringPrototype		'Clock'			'A simple digital clock')
						forFlapNamed: 'PlugIn Supplies'.]! !

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

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


!ClockMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:22'!
descriptionForPartsBin
	^ self partName:	'Clock'
		categories:		#('Useful')
		documentation:	'A digital clock'! !


!ClockMorph class methodsFor: 'scripting' stamp: 'sw 10/16/1998 15:36'!
authoringPrototype
	^ super authoringPrototype contents: Time now printString! !
Object variableSubclass: #ClosureEnvironment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Contexts'!
!ClosureEnvironment commentStamp: 'ajh 6/24/2004 03:33' prior: 0!
An environment is a collection of temporary variable values that have escaped the original method context and placed in this environment because blocks existed in the method that reference these variables (and blocks may out live their creating context). Nested blocks create nested environments when temp vars are introduced at multiple levels and referenced at lower levels. So each environment has a parent environment in its first slot. The top environment has the original receiver in it first slot (if referenced by an inner block).

A block consists of its outer environment and a method to execute while the outer environment is in the receiver position.

A block that remote returns from its home context holds the home environment in its outer environment. The remote return unwinds the call stack to the context that created the home context.
!


!ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/24/2004 03:54'!
= other

	self class == other class ifFalse: [^ false].
	self size = other size ifFalse: [^ false].
	1 to: self size do: [:i |
		(self at: i) = (other at: i) ifFalse: [^ false].
	].
	^ true! !

!ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/24/2004 03:56'!
hash
	"Answer an integer hash value for the receiver such that,
	  -- the hash value of an unchanged object is constant over time, and
	  -- two equal objects have equal hash values"

	| hash |

	hash _ self species hash.
	self size <= 10 ifTrue:
		[self do: [:elem | hash _ hash bitXor: elem hash]].
	^hash bitXor: self size hash! !

!ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/29/2004 14:33'!
return: value
	"Find thisContext sender that is owner of self and return from it"

	| home |
	home _ thisContext findContextSuchThat: [:ctxt | ctxt myEnv == self].
	home return: value! !

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

ClosureEnvironment class
	instanceVariableNames: ''!
StringHolder subclass: #CodeHolder
	instanceVariableNames: 'currentCompiledMethod contentsSymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Base'!
!CodeHolder commentStamp: '<historical>' prior: 0!
An ancestor class for all models which can show code.  Eventually, much of the code that currently resides in StringHolder which only applies to code-holding StringHolders might get moved down here.!


!CodeHolder methodsFor: 'annotation' stamp: 'md 2/24/2006 15:25'!
addOptionalAnnotationsTo: window at: fractions plus: verticalOffset
	"Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any"

	| aTextMorph divider delta |
	self wantsAnnotationPane ifFalse: [^ verticalOffset].
	aTextMorph := PluggableTextMorph 
		on: self
		text: #annotation 
		accept: #annotation:
		readSelection: nil
		menu: #annotationPaneMenu:shifted:.
	aTextMorph
		askBeforeDiscardingEdits: true;
		acceptOnCR: true;
		borderWidth: 0;
		hideScrollBarsIndefinitely.
	divider := BorderedSubpaneDividerMorph forBottomEdge.
	divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2.
	delta := self defaultAnnotationPaneHeight.
	window 
		addMorph: aTextMorph 
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 2))).
	window 
		addMorph: divider
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@(verticalOffset + delta - 2) corner: 0@(verticalOffset + delta))).
	^ verticalOffset + delta! !

!CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'!
addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream
	"add an annotation detailing the prior versions count"
	| versionsCount |

	versionsCount := VersionsBrowser versionCountForSelector: aSelector class: aClass.
	aStream nextPutAll: 
				((versionsCount > 1
					ifTrue:
						[versionsCount == 2 ifTrue:
							['1 prior version']
							ifFalse:
								[versionsCount printString, ' prior versions']]
					ifFalse:
						['no prior versions']), self annotationSeparator)! !

!CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'!
annotation
	"Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver."

	|  aSelector aClass |

	((aSelector := self selectedMessageName) == nil or: [(aClass := self selectedClassOrMetaClass) == nil])
		ifTrue: [^ '------'].
	^ self annotationForSelector: aSelector ofClass: aClass! !

!CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'!
annotationForClassCommentFor: aClass
	"Provide a line of content for an annotation pane, given that the receiver is pointing at the clas comment of the given class."

	| aStamp nonMeta |
	aStamp :=  (nonMeta := aClass theNonMetaClass) organization commentStamp.
	^ aStamp
		ifNil:
			[nonMeta name, ' has no class comment']
		ifNotNil:
			['class comment for ', nonMeta name,
				(aStamp = '<historical>'
					ifFalse:
						[' - ', aStamp]
					ifTrue:
						[''])]! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'!
annotationForClassDefinitionFor: aClass
	"Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class."

	^ 'Class definition for ', aClass name! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'!
annotationForHierarchyFor: aClass
	"Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class."

	^ 'Hierarchy for ', aClass name! !

!CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'!
annotationForSelector: aSelector ofClass: aClass 
	"Provide a line of content for an annotation pane, representing  
	information about the given selector and class"
	| stamp sendersCount implementorsCount aCategory separator aString aList aComment aStream requestList |
	aSelector == #Comment
		ifTrue: [^ self annotationForClassCommentFor: aClass].
	aSelector == #Definition
		ifTrue: [^ self annotationForClassDefinitionFor: aClass].
	aSelector == #Hierarchy
		ifTrue: [^ self annotationForHierarchyFor: aClass].
	aStream := ReadWriteStream on: ''.
	requestList := self annotationRequests.
	separator := requestList size > 1
				ifTrue: [self annotationSeparator]
				ifFalse: [''].
	requestList
		do: [:aRequest | 
			aRequest == #firstComment
				ifTrue: [aComment := aClass firstCommentAt: aSelector.
					aComment isEmptyOrNil
						ifFalse: [aStream nextPutAll: aComment , separator]].
			aRequest == #masterComment
				ifTrue: [aComment := aClass supermostPrecodeCommentFor: aSelector.
					aComment isEmptyOrNil
						ifFalse: [aStream nextPutAll: aComment , separator]].
			aRequest == #documentation
				ifTrue: [aComment := aClass precodeCommentOrInheritedCommentFor: aSelector.
					aComment isEmptyOrNil
						ifFalse: [aStream nextPutAll: aComment , separator]].
			aRequest == #timeStamp
				ifTrue: [stamp := self timeStamp.
					aStream
						nextPutAll: (stamp size > 0
								ifTrue: [stamp , separator]
								ifFalse: ['no timeStamp' , separator])].
			aRequest == #messageCategory
				ifTrue: [aCategory := aClass organization categoryOfElement: aSelector.
					aCategory
						ifNotNil: ["woud be nil for a method no longer present,  
							e.g. in a recent-submissions browser"
							aStream nextPutAll: aCategory , separator]].
			aRequest == #sendersCount
				ifTrue: [sendersCount := (self systemNavigation allCallsOn: aSelector) size.
					sendersCount := sendersCount == 1
								ifTrue: ['1 sender']
								ifFalse: [sendersCount printString , ' senders'].
					aStream nextPutAll: sendersCount , separator].
			aRequest == #implementorsCount
				ifTrue: [implementorsCount := self systemNavigation numberOfImplementorsOf: aSelector.
					implementorsCount := implementorsCount == 1
								ifTrue: ['1 implementor']
								ifFalse: [implementorsCount printString , ' implementors'].
					aStream nextPutAll: implementorsCount , separator].
			aRequest == #priorVersionsCount
				ifTrue: [self
						addPriorVersionsCountForSelector: aSelector
						ofClass: aClass
						to: aStream].
			aRequest == #priorTimeStamp
				ifTrue: [stamp := VersionsBrowser
								timeStampFor: aSelector
								class: aClass
								reverseOrdinal: 2.
					stamp
						ifNotNil: [aStream nextPutAll: 'prior time stamp: ' , stamp , separator]].
			aRequest == #recentChangeSet
				ifTrue: [aString := ChangeSorter mostRecentChangeSetWithChangeForClass: aClass selector: aSelector.
					aString size > 0
						ifTrue: [aStream nextPutAll: aString , separator]].
			aRequest == #allChangeSets
				ifTrue: [aList := ChangeSorter allChangeSetsWithClass: aClass selector: aSelector.
					aList size > 0
						ifTrue: [aList size = 1
								ifTrue: [aStream nextPutAll: 'only in change set ']
								ifFalse: [aStream nextPutAll: 'in change sets: '].
							aList
								do: [:aChangeSet | aStream nextPutAll: aChangeSet name , ' ']]
						ifFalse: [aStream nextPutAll: 'in no change set'].
					aStream nextPutAll: separator]].
	^ aStream contents! !

!CodeHolder methodsFor: 'annotation' stamp: 'RAA 1/13/2001 07:20'!
annotationPaneMenu: aMenu shifted: shifted

	^ aMenu 
		labels: 'change pane size'
		lines: #()
		selections: #(toggleAnnotationPaneSize)! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 9/27/1999 14:13'!
annotationRequests
	^ Preferences defaultAnnotationRequests! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:02'!
annotationSeparator
	"Answer the separator to be used between annotations"

	^ ' · '! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 9/28/2001 08:43'!
defaultAnnotationPaneHeight
	"Answer the receiver's preferred default height for new annotation panes."

	^ Preferences parameterAt: #defaultAnnotationPaneHeight ifAbsentPut: [25]! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 9/28/2001 08:44'!
defaultButtonPaneHeight
	"Answer the user's preferred default height for new button panes."

	^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! !


!CodeHolder methodsFor: 'categories' stamp: 'sd 11/8/2005 22:06'!
categoryFromUserWithPrompt: aPrompt for: aClass
	"self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary"

	|  labels myCategories reject lines cats newName menuIndex | 
	labels := OrderedCollection with: 'new...'.
	labels addAll: (myCategories := aClass organization categories asSortedCollection:
		[:a :b | a asLowercase < b asLowercase]).
	reject := myCategories asSet.
	reject
		add: ClassOrganizer nullCategory;
		add: ClassOrganizer default.
	lines := OrderedCollection with: 1 with: (myCategories size + 1).

	aClass allSuperclasses do:
		[:cls |
			cats := cls organization categories reject:
				 [:cat | reject includes: cat].
			cats isEmpty ifFalse:
				[lines add: labels size.
				labels addAll: (cats asSortedCollection:
					[:a :b | a asLowercase < b asLowercase]).
				reject addAll: cats]].

	newName := (labels size = 1 or:
		[menuIndex := (UIManager default chooseFrom: labels lines: lines title: aPrompt).
		menuIndex = 0 ifTrue: [^ nil].
		menuIndex = 1])
			ifTrue:
				[UIManager default request: 'Please type new category name'
					initialAnswer: 'category name']
			ifFalse: 
				[labels at: menuIndex].
	^ newName ifNotNil: [newName asSymbol]! !

!CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:27'!
categoryOfCurrentMethod
	"Answer the category that owns the current method.  If unable to determine a category, answer nil."

	| aClass aSelector |
	^ (aClass := self selectedClassOrMetaClass) 
		ifNotNil: [(aSelector := self selectedMessageName) 
			            ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]! !

!CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:26'!
changeCategory
	"Present a menu of the categories of messages for the current class, 
	and let the user choose a new category for the current message"

	| aClass aSelector |
	(aClass := self selectedClassOrMetaClass) ifNotNil:
		[(aSelector := self selectedMessageName) ifNotNil:
			[(self letUserReclassify: aSelector in: aClass) ifTrue:
				["ChangeSet current reorganizeClass: aClass."
				"Decided on further review that the above, when present, could cause more
                    unexpected harm than good"
				self methodCategoryChanged]]]! !

!CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:27'!
letUserReclassify: anElement in: aClass
	"Put up a list of categories and solicit one from the user.  
	Answer true if user indeed made a change, else false"
	

	| currentCat newCat |
	currentCat := aClass organization categoryOfElement: anElement.
	newCat := self 
				categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")' 
				for: aClass.
	(newCat ~~ nil and: [newCat ~= currentCat])
		ifTrue:
			[aClass organization classify: anElement under: newCat suppressIfDefault: false.
			^ true]
		ifFalse:
			[^ false]! !

!CodeHolder methodsFor: 'categories' stamp: 'sw 9/27/1999 14:11'!
methodCategoryChanged
	self changed: #annotation! !

!CodeHolder methodsFor: 'categories' stamp: 'sw 3/22/2000 23:04'!
selectedMessageCategoryName
	"Answer the name of the message category of the message of the currently selected context."

	^ self selectedClass organization categoryOfElement: self selectedMessageName! !


!CodeHolder methodsFor: 'categories & search pane' stamp: 'sd 11/20/2005 21:27'!
listPaneWithSelector: aSelector
	"If, among my window's paneMorphs, there is a list pane defined with aSelector as its retriever, answer it, else answer nil"

	| aWindow |
	^ (aWindow := self containingWindow) ifNotNil:
		[aWindow paneMorphSatisfying:
			[:aMorph | (aMorph isKindOf: PluggableListMorph) and:
				[aMorph getListSelector == aSelector]]]! !

!CodeHolder methodsFor: 'categories & search pane' stamp: 'sd 11/20/2005 21:27'!
newSearchPane
	"Answer a new search pane for the receiver"

	| aTextMorph |
	aTextMorph := PluggableTextMorph on: self
					text: #lastSearchString accept: #lastSearchString:
					readSelection: nil menu: nil.
	aTextMorph setProperty: #alwaysAccept toValue: true.
	aTextMorph askBeforeDiscardingEdits: false.
	aTextMorph acceptOnCR: true.
	aTextMorph setBalloonText: 'Type here and hit ENTER, and all methods whose selectors match what you typed will appear in the list pane below.'.
	^ aTextMorph! !

!CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 3/7/2001 12:22'!
searchPane
	"Answer the search pane associated with the receiver in its window, or nil if none.  Morphic only"

	^ self textPaneWithSelector: #lastSearchString! !

!CodeHolder methodsFor: 'categories & search pane' stamp: 'sd 11/20/2005 21:27'!
textPaneWithSelector: aSelector
	"If, among my window's paneMorphs, there is a text pane defined with aSelector as its retriever, answer it, else answer nil"

	| aWindow |
	^ (aWindow := self containingWindow) ifNotNil:
		[aWindow paneMorphSatisfying:
			[:aMorph | (aMorph isKindOf: PluggableTextMorph) and:
				[aMorph getTextSelector == aSelector]]]! !


!CodeHolder methodsFor: 'commands' stamp: 'sw 7/30/2001 16:31'!
abbreviatedWordingFor: aButtonSelector
	"Answer the abbreviated form of wording, from a static table which you're welcome to edit.  Answer nil if there is no entry -- in which case the long firm will be used on the corresponding browser button."

	#(
	(browseMethodFull				'browse')
	(browseSendersOfMessages	   	'senders')
	(browseMessages				'impl')
	(browseVersions					'vers')
	(methodHierarchy				'inher')
	(classHierarchy					'hier')
	(browseInstVarRefs				'iVar')
	(browseClassVarRefs				'cVar')
	(offerMenu						'menu')) do:

		[:pair | pair first == aButtonSelector ifTrue: [^ pair second]].
	^ nil! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 5/23/2003 14:35'!
adoptMessageInCurrentChangeset
	"Add the receiver's method to the current change set if not already there"

	self setClassAndSelectorIn: [:cl :sel |
		cl ifNotNil:
			[ChangeSet current adoptSelector: sel forClass: cl.
			self changed: #annotation]]
! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'!
browseImplementors
	"Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected."

	| aMessageName |
	(aMessageName := self selectedMessageName) ifNotNil: 
		[self systemNavigation browseAllImplementorsOf: aMessageName]! !

!CodeHolder methodsFor: 'commands' stamp: 'nk 6/26/2003 21:43'!
browseSenders
	"Create and schedule a message set browser on all senders of the currently selected message selector.  Of there is no message currently selected, offer a type-in"

	self sendQuery: #browseAllCallsOn: to: self systemNavigation! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'!
copyUpOrCopyDown
	"Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing.  Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established."

	| aClass aSelector allClasses implementors aMenu aColor |
	Smalltalk isMorphic ifFalse: [^ self inform: 
'Sorry, for the moment you have to be in
Morphic to use this feature.'].

	((aClass := self selectedClassOrMetaClass) isNil or: [(aSelector := self selectedMessageName) == nil]) 
		ifTrue:	[^ Beeper beep].

	allClasses := self systemNavigation hierarchyOfClassesSurrounding: aClass.
	implementors := self systemNavigation hierarchyOfImplementorsOf: aSelector forClass: aClass.
	aMenu := MenuMorph new defaultTarget: self.
	aMenu title: 
aClass name, '.', aSelector, '
Choose where to insert a copy of this method
(blue = current, black = available, red = other implementors'.
	allClasses do:
		[:cl |
			aColor := cl == aClass
				ifTrue:	[#blue]
				ifFalse:
					[(implementors includes: cl)
						ifTrue:	[#red]
						ifFalse:	[#black]].
			(aColor == #red)
				ifFalse:
					[aMenu add: cl name selector: #spawnToClass: argument: cl]
				ifTrue:
					[aMenu add: cl name selector: #spawnToCollidingClass: argument: cl].
			aMenu lastItem color: (Color colorFrom: aColor)].
	aMenu popUpInWorld! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 5/18/2001 17:51'!
offerMenu
	"Offer a menu to the user from the bar of tool buttons"

	self offerDurableMenuFrom: #messageListMenu:shifted: shifted: false! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:14'!
offerShiftedClassListMenu
	"Offer the shifted class-list menu."

	^ self offerMenuFrom: #classListMenu:shifted: shifted: true! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:15'!
offerUnshiftedClassListMenu
	"Offer the shifted class-list menu."

	^ self offerMenuFrom: #classListMenu:shifted: shifted: false! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'!
removeClass
	"Remove the selected class from the system, at interactive user request.  Make certain the user really wants to do this, since it is not reversible.  Answer true if removal actually happened."

	| message  className classToRemove result |
	self okToChange ifFalse: [^ false].
	classToRemove := self selectedClassOrMetaClass ifNil: [Beeper beep. ^ false].
	classToRemove := classToRemove theNonMetaClass.
	className := classToRemove name.
	message := 'Are you certain that you
want to REMOVE the class ', className, '
from the system?'.
	(result := self confirm: message)
		ifTrue: 
			[classToRemove subclasses size > 0
				ifTrue: [(self confirm: 'class has subclasses: ' , message)
					ifFalse: [^ false]].
			classToRemove removeFromSystem.
			self changed: #classList.
			true].
	^ result! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:18'!
shiftedYellowButtonActivity
	"Offer the shifted selector-list menu"

	^ self offerMenuFrom: #messageListMenu:shifted: shifted: true! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:26'!
spawn: aString 
	"Create and schedule a spawned message category browser for the currently selected message category.  The initial text view contains the characters in aString.  In the spawned browser, preselect the current selector (if any) as the going-in assumption, though upon acceptance this will often change"

	| newBrowser aCategory aClass |
	(aClass := self selectedClassOrMetaClass) isNil ifTrue:
		[^ aString isEmptyOrNil ifFalse: [(Workspace new contents: aString) openLabel: 'spawned workspace']].

	(aCategory := self categoryOfCurrentMethod)
		ifNil:
			[self buildClassBrowserEditString: aString]
		ifNotNil:
			[newBrowser := Browser new setClass: aClass selector: self selectedMessageName.
			self suggestCategoryToSpawnedBrowser: newBrowser.
			Browser openBrowserView: (newBrowser openMessageCatEditString: aString)
		label: 'category "', aCategory, '" in ', 
				newBrowser selectedClassOrMetaClassName]! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'!
spawnFullProtocol
	"Create and schedule a new protocol browser on the currently selected class or meta."

	| aClassOrMetaclass |
	(aClassOrMetaclass := self selectedClassOrMetaClass) ifNotNil:
       	[ProtocolBrowser openFullProtocolForClass: aClassOrMetaclass]! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'!
spawnProtocol
	| aClassOrMetaclass |
	"Create and schedule a new protocol browser on the currently selected class or meta."
	(aClassOrMetaclass := self selectedClassOrMetaClass) ifNotNil:
       	[ProtocolBrowser openSubProtocolForClass: aClassOrMetaclass]! !

!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'!
spawnToClass: aClass
	"Used to copy down code from a superclass to a subclass in one easy step, if you know what you're doing.  Spawns a new message-category browser for the indicated class, populating it with the source code seen in the current tool."

	| aCategory newBrowser org |	
	(aCategory := self categoryOfCurrentMethod)
		ifNil:
			[self buildClassBrowserEditString: self contents]
		ifNotNil:
			[((org := aClass organization) categories includes: aCategory)
				ifFalse:	[org addCategory: aCategory].
			newBrowser := Browser new setClass: aClass selector: nil.
			newBrowser selectMessageCategoryNamed: aCategory.
			Browser openBrowserView: (newBrowser openMessageCatEditString: self contents)
		label: 'category "', aCategory, '" in ', 
				newBrowser selectedClassOrMetaClassName]! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 3/20/2001 15:11'!
spawnToCollidingClass: aClass
	"Potentially used to copy down code from a superclass to a subclass in one easy step, in the case where the given class already has its own version of code, which would consequently be clobbered if the spawned code were accepted."

	self inform: 'That would be destructive of
some pre-existing code already in that
class for this selector.  For the moment,
we will not let you do this to yourself.'! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:19'!
unshiftedYellowButtonActivity
	"Offer the unshifted shifted selector-list menu"

	^ self offerMenuFrom: #messageListMenu:shifted: shifted: false! !


!CodeHolder methodsFor: 'construction' stamp: 'sd 11/20/2005 21:27'!
addLowerPanesTo: window at: nominalFractions with: editString

	| verticalOffset row innerFractions |

	row := AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 1;
		borderColor: Color black;
		layoutPolicy: ProportionalLayout new.

	verticalOffset := 0.
	innerFractions := 0@0 corner: 1@0.
	verticalOffset := self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset.
	verticalOffset := self addOptionalButtonsTo: row  at: innerFractions plus: verticalOffset.

	row 
		addMorph: ((self buildMorphicCodePaneWith: editString) borderWidth: 0)
		fullFrame: (
			LayoutFrame 
				fractions: (innerFractions withBottom: 1) 
				offsets: (0@verticalOffset corner: 0@0)
		).
	window 
		addMorph: row
		frame: nominalFractions.

	row on: #mouseEnter send: #paneTransition: to: window.
	row on: #mouseLeave send: #paneTransition: to: window.! !

!CodeHolder methodsFor: 'construction' stamp: 'sd 11/20/2005 21:27'!
buildClassBrowserEditString: aString 
	"Create and schedule a new class browser for the current selection, with initial textual contents set to aString.  This is used specifically in spawning where a class is established but a method-category is not."

	| newBrowser  |
	newBrowser := Browser new.
	newBrowser setClass: self selectedClassOrMetaClass selector: nil.
	newBrowser editSelection: #newMessage.
	Browser openBrowserView: (newBrowser openOnClassWithEditString: aString)
			label: 'Class Browser: ', self selectedClassOrMetaClass name
! !

!CodeHolder methodsFor: 'construction' stamp: 'tween 8/27/2004 12:18'!
buildMorphicCodePaneWith: editString
	"Construct the pane that shows the code.
	Respect the Preference for standardCodeFont."

	| codePane |
	codePane := MorphicTextEditor default
				on: self
				text: #contents
				accept: #contents:notifying:
				readSelection: #contentsSelection
				menu: #codePaneMenu:shifted:.
	codePane font: Preferences standardCodeFont.
	editString
		ifNotNil: [codePane editString: editString.
			codePane hasUnacceptedEdits: true].
	^ codePane! !


!CodeHolder methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'!
commentContents
	"documentation for the selected method"

	| poss aClass aSelector |
	^ (poss := (aClass := self selectedClassOrMetaClass)
						ifNil:
							['----']
						ifNotNil:
							[(aSelector := self selectedMessageName)
								ifNil:
									['---']
								ifNotNil:
									[(aClass precodeCommentOrInheritedCommentFor: aSelector)", String cr, String cr, self timeStamp"
"which however misses comments that are between the temps  declaration and the body of the method; those are picked up by ·aClass commentOrInheritedCommentFor: aSelector· but that method will get false positives from comments *anywhere* in the method source"]])
		isEmptyOrNil
			ifTrue:
				[aSelector
					ifNotNil:
						[((aClass methodHeaderFor: aSelector), '

Has no comment') asText makeSelectorBoldIn: aClass]
					ifNil:
						['Hamna']]
			ifFalse:	[aSelector
				ifNotNil: [((aClass methodHeaderFor: aSelector), '

', poss) asText makeSelectorBoldIn: aClass]
				ifNil: [poss]]! !

!CodeHolder methodsFor: 'contents' stamp: 'di 10/1/2001 22:25'!
contents
	"Answer the source code or documentation for the selected method"

	self showingByteCodes ifTrue:
		[^ self selectedBytecodes].

	self showingDocumentation ifTrue:
		[^ self commentContents].

	^ self selectedMessage! !

!CodeHolder methodsFor: 'contents' stamp: 'rhi 12/3/2001 22:25'!
contentsChanged

	super contentsChanged.
	self changed: #annotation! !

!CodeHolder methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'!
contentsSymbol
	"Answer a symbol indicating what kind of content should be shown for the method; for normal showing of source code, this symbol is #source.  A nil value in the contentsSymbol slot will be set to #source by this method"

	^ contentsSymbol ifNil: [contentsSymbol := 
				Preferences browseWithPrettyPrint
					ifTrue:
						[Preferences colorWhenPrettyPrinting
							ifTrue:	[#colorPrint]
							ifFalse:	[#prettyPrint]]
					ifFalse:
						[#source]]! !

!CodeHolder methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'!
contentsSymbol: aSymbol
	"Set the contentsSymbol as indicated.  #source means to show source code, #comment means to show the first comment found in the source code"

	contentsSymbol := aSymbol! !


!CodeHolder methodsFor: 'controls' stamp: 'gm 2/16/2003 20:37'!
buttonWithSelector: aSelector 
	"If receiver has a control button with the given action selector answer it, else answer nil.  morphic only at this point"

	| aWindow aPane |
	((aWindow := self containingWindow) isSystemWindow) 
		ifFalse: [^nil].
	(aPane := aWindow submorphNamed: 'buttonPane') ifNil: [^nil].
	^aPane submorphThat: 
			[:m | 
			(m isKindOf: PluggableButtonMorph) and: [m actionSelector == aSelector]]
		ifNone: [^nil]! !

!CodeHolder methodsFor: 'controls' stamp: 'sd 11/20/2005 21:27'!
codePaneProvenanceButton
	"Answer a button that reports on, and allow the user to modify,
	the code-pane-provenance setting"
	| aButton |
	aButton := UpdatingSimpleButtonMorph newWithLabel: 'source'.
	aButton setNameTo: 'codeProvenance'.
	aButton useSquareCorners.
	aButton target: self;
		 wordingSelector: #codePaneProvenanceString;
		 actionSelector: #offerWhatToShowMenu.
	aButton setBalloonText: 'Governs what view is shown in the code pane.  Click here to change the view'.
	aButton actWhen: #buttonDown.
	aButton color: Color white;
		borderStyle: BorderStyle thinGray; vResizing: #spaceFill.
	^ aButton! !

!CodeHolder methodsFor: 'controls' stamp: 'sd 11/20/2005 21:26'!
codePaneProvenanceString
	"Answer a string that reports on code-pane-provenance"

	| symsAndWordings |
	(symsAndWordings := self contentsSymbolQuints) do:
		[:aQuad |
			contentsSymbol == aQuad first ifTrue: [^ aQuad fourth]].
	^ symsAndWordings first fourth "default to plain source, for example if nil as initially"! !

!CodeHolder methodsFor: 'controls' stamp: 'md 8/14/2005 17:49'!
contentsSymbolQuints
	"Answer a list of quintuplets representing information on the alternative views available in the code pane
		first element:	the contentsSymbol used
		second element:	the selector to call when this item is chosen.
		third element:	the selector to call to obtain the wording of the menu item.
		fourth element:	the wording to represent this view
		fifth element:	balloon help
	A hypen indicates a need for a seperator line in a menu of such choices"

	^ #(
(source			togglePlainSource 			showingPlainSourceString	'source'		'the textual source code as writen')
(documentation	toggleShowDocumentation	showingDocumentationString	'documentation'		'the first comment in the method')
-
(prettyPrint		togglePrettyPrint 			prettyPrintString			'prettyPrint'			'the method source presented in a standard text format')
(colorPrint		toggleColorPrint				colorPrintString				'colorPrint'			'the method source in a standard text format with colors to distinguish structural parts') 
-
(showDiffs		toggleRegularDiffing		showingRegularDiffsString	'showDiffs'				'the textual source diffed from its prior version')
(prettyDiffs		togglePrettyDiffing			showingPrettyDiffsString	'prettyDiffs'		'formatted textual source diffed from formatted form of prior version')
-
(decompile		toggleDecompile				showingDecompileString		'decompile'			'source code decompiled from byteCodes')
(byteCodes		toggleShowingByteCodes		showingByteCodesString		'byteCodes'			'the bytecodes that comprise the compiled method')
-
(tiles			toggleShowingTiles 			showingTilesString			'tiles'				'universal tiles representing the method'))! !

!CodeHolder methodsFor: 'controls' stamp: 'ar 2/12/2005 14:28'!
decorateButtons
	"Change screen feedback for any buttons in the UI of the receiver that may wish it.  Initially, it is only the Inheritance button that is decorated, but one can imagine others."
	self changed: #inheritanceButtonColor.
	self decorateForInheritance ! !

!CodeHolder methodsFor: 'controls' stamp: 'sd 11/20/2005 21:27'!
decorateForInheritance
	"Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to."

	| aColor aButton flags |
	(aButton := self inheritanceButton) ifNil: [^ self].

	((currentCompiledMethod isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons])
		ifFalse: [^aButton offColor: Color transparent].

	"This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it."

	flags := 0.
	self isThisAnOverride ifTrue: [ flags := flags bitOr: 4 ].
	currentCompiledMethod sendsToSuper ifTrue: [ flags := flags bitOr: 2 ].
	self isThereAnOverride ifTrue: [ flags := flags bitOr: 1 ].
	aColor := {
		Color transparent.
		Color tan lighter.
		Color green muchLighter.
		Color blue muchLighter.
		Color red muchLighter.	"has super but doesn't call it"
		(Color r: 0.94 g: 0.823 b: 0.673).	"has sub; has super but doesn't call it"
		Color green muchLighter.
		Color blue muchLighter.
	} at: flags + 1.

	aButton offColor: aColor! !

!CodeHolder methodsFor: 'controls' stamp: 'sw 1/25/2001 14:44'!
inheritanceButton
	"If receiver has an Inheritance button, answer it, else answer nil.  morphic only at this point"

	^ self buttonWithSelector: #methodHierarchy! !

!CodeHolder methodsFor: 'controls' stamp: 'sd 11/20/2005 21:27'!
optionalButtonPairs
	"Answer a tuple (formerly pairs) defining buttons, in the format:
			button label
			selector to send
			help message"

	| aList |

	aList := #(
	('browse'			browseMethodFull			'view this method in a browser')
	('senders' 			browseSendersOfMessages	'browse senders of...')
	('implementors'		browseMessages				'browse implementors of...')
	('versions'			browseVersions				'browse versions')), 

	(Preferences decorateBrowserButtons
		ifTrue:
			[{#('inheritance'		methodHierarchy 'browse method inheritance
green: sends to super
tan: has override(s)
mauve: both of the above
pink: is an override but doesn''t call super
pinkish tan: has override(s), also is an override but doesn''t call super' )}]
		ifFalse:
			[{#('inheritance'		methodHierarchy			'browse method inheritance')}]),

	#(
	('hierarchy'		classHierarchy				'browse class hierarchy')
	('inst vars'			browseInstVarRefs			'inst var refs...')
	('class vars'			browseClassVarRefs			'class var refs...')).

	^ aList! !

!CodeHolder methodsFor: 'controls' stamp: 'sd 11/20/2005 21:27'!
optionalButtonRow
	"Answer a row of control buttons"
	| aRow aButton aLabel |
	aRow := AlignmentMorph newRow.
	aRow setNameTo: 'buttonPane'.
	aRow beSticky.
	aRow hResizing: #spaceFill.
	aRow wrapCentering: #center;
		 cellPositioning: #leftCenter.
	aRow clipSubmorphs: true.
	aRow cellInset: 1.
	aRow color: Color white.
	Preferences menuButtonInToolPane
		ifTrue: [aRow addMorphFront: self menuButton].
	self optionalButtonPairs
		do: [:tuple | 
			aButton := PluggableButtonMorph
						on: self
						getState: nil
						action: tuple second.
			aButton hResizing: #spaceFill;
				 vResizing: #spaceFill;
				 onColor: Color white offColor: Color white.
			aLabel := Preferences abbreviatedBrowserButtons
						ifTrue: [self abbreviatedWordingFor: tuple second].
			aButton
				label: (aLabel
						ifNil: [tuple first asString]).
			tuple size > 2
				ifTrue: [aButton setBalloonText: tuple third].
			tuple size > 3
				ifTrue: [aButton triggerOnMouseDown: tuple fourth].
			aRow addMorphBack: aButton].
	aRow addMorphBack: self codePaneProvenanceButton.
	^ aRow! !

!CodeHolder methodsFor: 'controls' stamp: 'sw 11/13/2001 09:12'!
sourceAndDiffsQuintsOnly
	"Answer a list of quintuplets representing information on the alternative views available in the code pane for the case where the only plausible choices are showing source or either of the two kinds of diffs"

	^ #(
(source			togglePlainSource 		showingPlainSourceString	'source'			'the textual source code as writen')
(showDiffs		toggleRegularDiffing	showingRegularDiffsString	'showDiffs'		'the textual source diffed from its prior version')
(prettyDiffs		togglePrettyDiffing		showingPrettyDiffsString	'prettyDiffs'		'formatted textual source diffed from formatted form of prior version'))! !


!CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:36'!
defaultDiffsSymbol
	"Answer the code symbol to use when generically switching to diffing"

	^ Preferences diffsWithPrettyPrint 
		ifTrue:
			[#prettyDiffs]
		ifFalse:
			[#showDiffs]! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
diffButton
	"Return a checkbox that lets the user decide whether diffs should be shown or not.  Not sent any more but retained against the possibility of existing subclasses outside the base image using it."

	|  outerButton aButton |
	outerButton := AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleRegularDiffing;
		getSelector: #showingRegularDiffs.
	outerButton addMorphBack: (StringMorph contents: 'diffs') lock.
	outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'.

	^ outerButton
! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
diffFromPriorSourceFor: sourceCode 
	"If there is a prior version of source for the selected method, return a diff, else just return the source code"

	| prior |
	^ (prior := self priorSourceOrNil)
		ifNil: [sourceCode]
		ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode inClass: self selectedClass prettyDiffs: self showingPrettyDiffs]! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
prettyDiffButton
	"Return a checkbox that lets the user decide whether prettyDiffs should be shown or not"

	|  outerButton aButton |
	outerButton := AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #togglePrettyDiffing;
		getSelector: #showingPrettyDiffs.
	outerButton addMorphBack: (StringMorph contents: 'prettyDiffs') lock.
	(self isKindOf: VersionsBrowser)
		ifTrue:
			[outerButton setBalloonText: 'If checked, then pretty-printed code differences from the previous version, if any, will be shown.']
		ifFalse:
			[outerButton setBalloonText: 'If checked, then pretty-printed code differences between the file-based method and the in-memory version, if any, will be shown.'].

	^ outerButton
! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
regularDiffButton
	"Return a checkbox that lets the user decide whether regular diffs should be shown or not"

	|  outerButton aButton |
	outerButton := AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleRegularDiffing;
		getSelector: #showingRegularDiffs.
	outerButton addMorphBack: (StringMorph contents: 'diffs') lock.
	outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'.

	^ outerButton
! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
restoreTextualCodingPane
	"If the receiver is showing tiles, restore the textual coding pane"

	self showingTiles ifTrue:
		[contentsSymbol := #source.
		self installTextualCodingPane]! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:49'!
showDiffs
	"Answer whether the receiver is showing diffs of source code.  The preferred protocol here is #showingRegularDiffs, but this message is still sent by some preexisting buttons so is retained."

	^ contentsSymbol == #showDiffs
! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
showDiffs: aBoolean
	"Set whether I'm showing diffs as indicated; use the global preference to determine which kind of diffs to institute."

	self showingAnyKindOfDiffs
		ifFalse:
			[aBoolean ifTrue:
				[contentsSymbol := self defaultDiffsSymbol]]
		ifTrue:
			[aBoolean ifFalse:
				[contentsSymbol := #source]].
	self setContentsToForceRefetch.
	self contentsChanged! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:26'!
showPrettyDiffs: aBoolean
	"Set whether I'm showing pretty diffs as indicated"

	self showingPrettyDiffs
		ifFalse:
			[aBoolean ifTrue:
				[contentsSymbol := #prettyDiffs]]
		ifTrue:
			[aBoolean ifFalse:
				[contentsSymbol := #source]].
	self setContentsToForceRefetch.
	self contentsChanged! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:26'!
showRegularDiffs: aBoolean
	"Set whether I'm showing regular diffs as indicated"

	self showingRegularDiffs
		ifFalse:
			[aBoolean ifTrue:
				[contentsSymbol := #showDiffs]]
		ifTrue:
			[aBoolean ifFalse:
				[contentsSymbol := #source]].
	self setContentsToForceRefetch.
	self contentsChanged! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:32'!
showingAnyKindOfDiffs
	"Answer whether the receiver is currently set to show any kind of diffs"

	^ #(showDiffs prettyDiffs) includes: contentsSymbol! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 09:10'!
showingDiffsString
	"Answer a string representing whether I'm showing diffs.  Not sent any more but retained so that prexisting buttons that sent this will not raise errors."

	^ (self showingRegularDiffs
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'showDiffs'! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 5/19/2001 00:07'!
showingPrettyDiffs
	"Answer whether the receiver is showing pretty diffs of source code"

	^ contentsSymbol == #prettyDiffs
! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 5/22/2001 16:41'!
showingPrettyDiffsString
	"Answer a string representing whether I'm showing pretty diffs"

	^ (self showingPrettyDiffs
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'prettyDiffs'! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:07'!
showingRegularDiffs
	"Answer whether the receiver is showing regular diffs of source code"

	^ contentsSymbol == #showDiffs
! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:43'!
showingRegularDiffsString
	"Answer a string representing whether I'm showing regular diffs"

	^ (self showingRegularDiffs
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'showDiffs'! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
toggleColorPrint
	"Toggle whether color-print is in effect in the code pane"

	self restoreTextualCodingPane.
	self okToChange ifTrue:
		[self showingColorPrint
			ifTrue:
				[contentsSymbol := #source]
			ifFalse:
				[contentsSymbol := #colorPrint].
		self setContentsToForceRefetch.
		self contentsChanged]

! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 1/18/2001 13:58'!
toggleDiff
	"Retained for backward compatibility with existing buttons in existing images"

	self toggleDiffing! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
toggleDiffing
	"Toggle whether diffs should be shown in the code pane.  If any kind of diffs were being shown, stop showing diffs.  If no kind of diffs were being shown, start showing whatever kind of diffs are called for by default."

	| wasShowingDiffs |
	self okToChange ifTrue:
		[wasShowingDiffs := self showingAnyKindOfDiffs.
		self restoreTextualCodingPane.
		self showDiffs: wasShowingDiffs not.
		self setContentsToForceRefetch.
		self contentsChanged]

! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
togglePlainSource
	"Toggle whether plain source shown in the code pane"
	
	| wasShowingPlainSource |
	self okToChange ifTrue:
		[wasShowingPlainSource := self showingPlainSource.
		self restoreTextualCodingPane.
		wasShowingPlainSource
			ifTrue:
				[self showDocumentation: true]
			ifFalse:
				[contentsSymbol := #source].
		self setContentsToForceRefetch.
		self changed: #contents]

! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
togglePrettyDiffing
	"Toggle whether pretty-diffing should be shown in the code pane"

	| wasShowingDiffs |
	self okToChange ifTrue:
		[wasShowingDiffs := self showingPrettyDiffs.
		self restoreTextualCodingPane.
		self showPrettyDiffs: wasShowingDiffs not.
		self setContentsToForceRefetch.
		self contentsChanged]

! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
togglePrettyPrint
	"Toggle whether pretty-print is in effectin the code pane"

	self restoreTextualCodingPane.
	self okToChange ifTrue:
		[self showingPrettyPrint
			ifTrue:
				[contentsSymbol := #source]
			ifFalse:
				[contentsSymbol := #prettyPrint].
		self setContentsToForceRefetch.
		self contentsChanged]

! !

!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:26'!
toggleRegularDiffing
	"Toggle whether regular-diffing should be shown in the code pane"

	| wasShowingDiffs |
	self okToChange ifTrue:
		[wasShowingDiffs := self showingRegularDiffs.
		self restoreTextualCodingPane.
		self showRegularDiffs: wasShowingDiffs not.
		self setContentsToForceRefetch.
		self contentsChanged]

! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:24'!
wantsDiffFeedback
	"Answer whether the receiver is showing diffs of source code"

	^ self showingAnyKindOfDiffs! !


!CodeHolder methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:19'!
canShowMultipleMessageCategories
	"Answer whether the receiver is capable of showing multiple message categories"

	^ false! !


!CodeHolder methodsFor: 'message list' stamp: 'md 2/22/2006 16:10'!
decompiledSourceIntoContents
	"Obtain a source string by decompiling the method's code, and place 
	that source string into my contents. Also return the string.
	Get temps from source file if shift key is pressed."
	
	|  class |
	class := self selectedClassOrMetaClass.
	"Was method deleted while in another project?"
	currentCompiledMethod := (class compiledMethodAt: self selectedMessageName ifAbsent: [^ '']).

	contents := (Sensor leftShiftDown not) 
		ifTrue: [currentCompiledMethod decompileWithTemps]
		ifFalse: [currentCompiledMethod decompile].
	contents := contents decompileString asText makeSelectorBoldIn: class.
	^ contents copy! !

!CodeHolder methodsFor: 'message list' stamp: 'sw 8/16/2002 23:23'!
selectedBytecodes
	"Answer text to show in a code pane when in showing-byte-codes mode"

	^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName ifAbsent: [^ '' asText]) symbolic asText! !

!CodeHolder methodsFor: 'message list' stamp: 'md 2/20/2006 15:02'!
selectedMessage
	"Answer a copy of the source code for the selected message.  This generic version is probably actually never reached, since every subclass probably reimplements and does not send to super.  In time, ideally, most, or all, reimplementors would vanish and all would defer instead to a universal version right here.  Everything in good time."

	| class selector method |
	contents ifNotNil: [^ contents copy].

	self showingDecompile ifTrue:[^ self decompiledSourceIntoContents].

	class := self selectedClassOrMetaClass.
	(class isNil or: [(selector := self selectedMessageName) isNil]) ifTrue: [^ ''].
	method := class compiledMethodAt: selector ifAbsent: [^ ''].	"method deleted while in another project"
	currentCompiledMethod := method.

	^ contents := (self showComment
		ifFalse: [self sourceStringPrettifiedAndDiffed]
		ifTrue:	[ self commentContents])
			copy asText makeSelectorBoldIn: class! !

!CodeHolder methodsFor: 'message list' stamp: 'md 8/14/2005 17:50'!
sourceStringPrettifiedAndDiffed
	"Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies"

	| class selector sourceString |
	class := self selectedClassOrMetaClass.
	selector := self selectedMessageName.
	(class isNil or: [selector isNil]) ifTrue: [^'missing'].
	sourceString := class ultimateSourceCodeAt: selector ifAbsent: [^'error'].
	self validateMessageSource: sourceString forSelector: selector.
	(#(#prettyPrint #colorPrint #prettyDiffs) 
		includes: contentsSymbol) 
			ifTrue: 
				[sourceString := class prettyPrinterClass 
							format: sourceString
							in: class
							notifying: nil
							contentsSymbol: contentsSymbol].
	self showingAnyKindOfDiffs 
		ifTrue: [sourceString := self diffFromPriorSourceFor: sourceString].
	^sourceString! !

!CodeHolder methodsFor: 'message list' stamp: 'sd 11/20/2005 21:27'!
validateMessageSource: sourceString forSelector: aSelector
	"Check whether there is evidence that method source is invalid"

	| sourcesName |
	(self selectedClass compilerClass == Object compilerClass 
			and: [(sourceString asString findString: aSelector keywords first ) ~= 1])
		ifTrue: [sourcesName := FileDirectory localNameFor: SmalltalkImage current sourcesName.
			self inform: 'There may be a problem with your sources file!!

The source code for every method should (usually) start with the
method selector but this is not the case with this method!! You may
proceed with caution but it is recommended that you get a new source file.

This can happen if you download the "' , sourcesName  , '" file, 
or the ".changes" file you use, as TEXT. It must be transfered 
in BINARY mode, even if it looks like a text file, 
to preserve the CR line ends.

Mac users: This may have been caused by Stuffit Expander. 
To prevent the files above to be converted to Mac line ends 
when they are expanded, do this: Start the program, then 
from Preferences... in the File menu, choose the Cross 
Platform panel, then select "Never" and press OK. 
Then expand the compressed archive again.

(Occasionally, the source code for a method may legitimately
start with a non-alphabetic character -- for example, Behavior
method #formalHeaderPartsFor:.  In such rare cases, you can
happily disregard this warning.)'].! !


!CodeHolder methodsFor: 'message list menu' stamp: 'sd 11/20/2005 21:27'!
messageListKey: aChar from: view
	"Respond to a Command key.  I am a model with a code pane, and I also
	have a listView that has a list of methods.  The view knows how to get
	the list and selection."

	| sel class |
	aChar == $D ifTrue: [^ self toggleDiffing].

	sel := self selectedMessageName.
	aChar == $m ifTrue:  "These next two put up a type in if no message selected"
		[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation].
	aChar == $n ifTrue: 
		[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation].

	"The following require a class selection"
	(class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view].
	aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel].
	aChar == $N ifTrue: [^ self browseClassRefs].
	aChar == $i ifTrue: [^ self methodHierarchy].
	aChar == $h ifTrue: [^ self classHierarchy].
	aChar == $p ifTrue: [^ self browseFullProtocol].

	"The following require a method selection"
	sel ifNotNil: 
		[aChar == $o ifTrue: [^ self fileOutMessage].
		aChar == $c ifTrue: [^ self copySelector].
		aChar == $v ifTrue: [^ self browseVersions].
		aChar == $O ifTrue: [^ self openSingleMessageBrowser].
		aChar == $x ifTrue: [^ self removeMessage].
		aChar == $d ifTrue: [^ self removeMessageFromBrowser].

		(aChar == $C and: [self canShowMultipleMessageCategories])
			ifTrue: [^ self showHomeCategory]].

	^ self arrowKey: aChar from: view! !


!CodeHolder methodsFor: 'misc' stamp: 'md 2/24/2006 15:25'!
addOptionalButtonsTo: window at: fractions plus: verticalOffset 
	"If the receiver wishes it, add a button pane to the window, and
	answer the verticalOffset plus the height added"
	| delta buttons divider |
	self wantsOptionalButtons
		ifFalse: [^ verticalOffset].
	delta := self defaultButtonPaneHeight.
	buttons := self optionalButtonRow color: Color white.
	divider := BorderedSubpaneDividerMorph forBottomEdge.
	divider extent: 4 @ 4;
				color: Color gray;
				borderColor: #simple;
				borderWidth: 1.
	window
		addMorph: buttons
		fullFrame: (LayoutFrame
				fractions: fractions
				offsets: (0 @ verticalOffset corner: 0 @ (verticalOffset + delta - 1))).
	window
		addMorph: divider
		fullFrame: (LayoutFrame
				fractions: fractions
				offsets: (0 @ (verticalOffset + delta - 1) corner: 0 @ (verticalOffset + delta))).
	^ verticalOffset + delta! !

!CodeHolder methodsFor: 'misc' stamp: 'nk 4/10/2001 07:52'!
getSelectorAndSendQuery: querySelector to: queryPerformer
	"Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained as its argument.  If no message is currently selected, then obtain a method name from a user type-in"

	self getSelectorAndSendQuery: querySelector to: queryPerformer with: { }.
! !

!CodeHolder methodsFor: 'misc' stamp: 'md 3/3/2006 09:21'!
getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs
	"Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments.  If no message is currently selected, then obtain a method name from a user type-in"

	| strm array |
	strm := WriteStream on: (array := Array new: queryArgs size + 1).
	strm nextPut: nil.
	strm nextPutAll: queryArgs.

	self selectedMessageName ifNil: [ | selector |
		selector := UIManager default request: 'Type selector:' initialAnswer: 'flag:'.
		selector := selector copyWithout: Character space.
		^ selector isEmptyOrNil ifFalse: [
			(Symbol hasInterned: selector
				ifTrue: [ :aSymbol |
					array at: 1 put: aSymbol.
					queryPerformer perform: querySelector withArguments: array])
				ifFalse: [ self inform: 'no such selector']
		]
	].

	self selectMessageAndEvaluate: [:selector |
		array at: 1 put: selector.
		queryPerformer perform: querySelector withArguments: array
	]! !

!CodeHolder methodsFor: 'misc' stamp: 'md 2/24/2006 15:28'!
isThereAnOverride
	"Answer whether any subclass of my selected class implements my 
	selected selector"
	| aName aClass |
	aName := self selectedMessageName ifNil: [^ false].
	aClass := self selectedClassOrMetaClass ifNil: [^ false].
	aClass allSubclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]].
	^ false! !

!CodeHolder methodsFor: 'misc' stamp: 'md 2/24/2006 15:28'!
isThisAnOverride
	"Answer whether any superclass of my selected class implements my selected selector"
	| aName aClass |
	aName := self selectedMessageName ifNil: [^ false].
	aClass := self selectedClassOrMetaClass ifNil: [^ false].
	aClass allSuperclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]].
	^ false! !

!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'!
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
! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 9/27/2001 01:26'!
modelWakeUpIn: aWindow
	"The window has been activated.  Respond to possible changes that may have taken place while it was inactive"

	self updateListsAndCodeIn: aWindow.
	self decorateButtons.
	self refreshAnnotation.

	super modelWakeUpIn: aWindow! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 11/13/2001 07:42'!
okayToAccept
	"Answer whether it is okay to accept the receiver's input"

	self showingDocumentation ifTrue:
		[self inform: 
'Sorry, for the moment you can
only submit changes here when
you are showing source.  Later, you
will be able to edit the isolated comment
here and save it back, but only if YOU
implement it!!.'.
		^ false].

	self showingAnyKindOfDiffs ifFalse:
		[^ true]. 
	^ SelectionMenu confirm: 
'Caution!!  You are "showing diffs" here, so 
there is a danger that some of the text in the
code pane is contaminated by the "diff" display'
	trueChoice: 'accept anyway -- I''ll take my chances' falseChoice: 'um, let me reconsider'
! !

!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'!
priorSourceOrNil
	"If the currently-selected method has a previous version, return its source, else return nil"
	| aClass aSelector  changeRecords |
	(aClass := self selectedClassOrMetaClass) ifNil: [^ nil].
	(aSelector := self selectedMessageName) ifNil: [^ nil].
	changeRecords := aClass changeRecordsAt: aSelector.
	(changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil].
	^ (changeRecords at: 2) string 
! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 10/28/2001 00:15'!
refreshAnnotation
	"If the receiver has an annotation pane that does not bear unaccepted edits, refresh it"

	(self dependents detect: [:m | (m inheritsFromAnyIn: #('PluggableTextView' 'PluggableTextMorph')) and: [m getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo:
		[:aPane | aPane hasUnacceptedEdits ifFalse:
			[aPane update: #annotation]]! !

!CodeHolder methodsFor: 'misc' stamp: 'md 8/14/2005 17:49'!
refusesToAcceptCode
	"Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to"

	^ (#(byteCodes documentation tiles) includes: self contentsSymbol)! !

!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'!
releaseCachedState
	"Can always be found again.  Don't write on a file."
	currentCompiledMethod := nil.! !

!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'!
sampleInstanceOfSelectedClass
	| aClass |
	"Return a sample instance of the class currently being pointed at"
	(aClass := self selectedClassOrMetaClass) ifNil: [^ nil].
	^ aClass theNonMetaClass initializedInstance! !

!CodeHolder methodsFor: 'misc' stamp: 'rbb 3/1/2005 10:31'!
sendQuery: querySelector to: queryPerformer
	"Apply a query to the primary selector associated with the current context.  If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument."

	| aSelector aString |
	aSelector := self selectedMessageName ifNil:
		[aString :=UIManager default request: 'Type selector:' initialAnswer: 'flag:'.
		^ aString isEmptyOrNil ifFalse:
			[(Symbol hasInterned: aString ifTrue:
				[:aSymbol | queryPerformer perform: querySelector with: aSymbol])
				ifFalse:
					[self inform: 'no such selector']]].

	queryPerformer perform: querySelector with: aSelector! !

!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'!
setClassAndSelectorIn: csBlock
	"Evaluate csBlock with my selected class and and selector as its arguments; provide nil arguments if I don't have a method currently selected"

	| aName |
	(aName := self selectedMessageName)
		ifNil:
			[csBlock value: nil value: nil]
		ifNotNil:
			[csBlock value: self selectedClassOrMetaClass value: aName]
! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 2/22/2001 06:37'!
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."

	aBrowser setOriginalCategoryIndexForCurrentMethod! !

!CodeHolder methodsFor: 'misc' stamp: 'rbb 3/1/2005 10:31'!
useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer
	"If incomingSelector is not nil, use it, else obtain a selector from user type-in.   Using the determined selector, send the query to the performer provided."

	| aSelector |
	incomingSelector
		ifNotNil:
			[queryPerformer perform: querySelector with: incomingSelector]
		ifNil:
			[aSelector :=UIManager default request: 'Type selector:' initialAnswer: 'flag:'.
			aSelector isEmptyOrNil ifFalse:
				[(Symbol hasInterned: aSelector ifTrue:
					[:aSymbol | queryPerformer perform: querySelector with: aSymbol])
					ifFalse:
						[self inform: 'no such selector']]]! !


!CodeHolder methodsFor: 'self-updating' stamp: 'nk 4/29/2004 12:25'!
didCodeChangeElsewhere
	"Determine whether the code for the currently selected method and class has been changed somewhere else."
	| aClass aSelector aCompiledMethod |
	currentCompiledMethod ifNil: [^ false].

	(aClass := self selectedClassOrMetaClass) ifNil: [^ false].

	(aSelector := self selectedMessageName) ifNil: [^ false].

	self classCommentIndicated
		ifTrue: [^ currentCompiledMethod ~~ aClass organization commentRemoteStr].

	^ (aCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod
		and: [aCompiledMethod last ~= 0 "either not yet installed"
				or: [ currentCompiledMethod last = 0 "or these methods don't have source pointers"]]! !

!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 08:37'!
stepIn: aSystemWindow
	self updateListsAndCodeIn: aSystemWindow! !

!CodeHolder methodsFor: 'self-updating' stamp: 'sw 2/14/2001 15:34'!
updateCodePaneIfNeeded
	"If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits"

	self didCodeChangeElsewhere
		ifTrue:
			[self hasUnacceptedEdits
				ifFalse:
					[self setContentsToForceRefetch.
					self contentsChanged]
				ifTrue:
					[self changed: #codeChangedElsewhere]]! !

!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 14:14'!
updateListsAndCodeIn: aWindow
	super updateListsAndCodeIn: aWindow.
	self updateCodePaneIfNeeded! !

!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/20/1999 12:22'!
wantsStepsIn: aWindow
	^ Preferences smartUpdating! !


!CodeHolder methodsFor: 'tiles' stamp: 'yo 2/17/2005 18:14'!
addModelItemsToWindowMenu: aMenu
	"Add model-related item to the window menu"

	super addModelItemsToWindowMenu: aMenu. 
	Smalltalk isMorphic ifTrue:
		[aMenu addLine.
		aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu]! !

!CodeHolder methodsFor: 'tiles' stamp: 'sd 11/20/2005 21:27'!
installTextualCodingPane
	"Install text into the code pane"

	| aWindow codePane aPane boundsToUse |
	(aWindow := self containingWindow) ifNil: [self error: 'where''s that window?'].
	codePane := aWindow findDeepSubmorphThat:   
		[:m | ((m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]) or:
			[m isKindOf: PluggableTileScriptorMorph]] ifAbsent: [self error: 'no code pane'].
	aPane := self buildMorphicCodePaneWith: nil.
	boundsToUse := (codePane bounds origin- (1@1)) corner: (codePane owner bounds corner " (1@1").
	aWindow replacePane: codePane with: aPane.
	aPane vResizing: #spaceFill; hResizing: #spaceFill; borderWidth: 0.
	aPane bounds: boundsToUse.
	aPane owner clipSubmorphs: false.

	self contentsChanged! !


!CodeHolder methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:32'!
buildCodeProvenanceButtonWith: builder
	| buttonSpec |
	buttonSpec := builder pluggableActionButtonSpec new.
	buttonSpec model: self.
	buttonSpec label: #codePaneProvenanceString.
	buttonSpec action: #offerWhatToShowMenu.
	buttonSpec help: 'Governs what view is shown in the code pane.  Click here to change the view'.
	^buttonSpec! !

!CodeHolder methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:32'!
buildOptionalButtonsWith: builder

	| panelSpec buttonSpec |
	panelSpec := builder pluggablePanelSpec new.
	panelSpec children: OrderedCollection new.
	self optionalButtonPairs do:[:spec|
		buttonSpec := builder pluggableActionButtonSpec new.
		buttonSpec model: self.
		buttonSpec label: spec first.
		buttonSpec action: spec second.
		spec second == #methodHierarchy ifTrue:[
			buttonSpec color: #inheritanceButtonColor.
		]. 
		spec size > 2 ifTrue:[buttonSpec help: spec third].
		panelSpec children add: buttonSpec.
	].
	"What to show"
	panelSpec children add: (self buildCodeProvenanceButtonWith: builder).

	panelSpec layout: #horizontal. "buttons"
	^panelSpec! !

!CodeHolder methodsFor: 'toolbuilder' stamp: 'sd 11/20/2005 21:27'!
inheritanceButtonColor
	"Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to."

	| flags aColor |
	((currentCompiledMethod isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons])
		ifFalse: [^Color transparent].

	"This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it."

	flags := 0.
	self isThisAnOverride ifTrue: [ flags := flags bitOr: 4 ].
	currentCompiledMethod sendsToSuper ifTrue: [ flags := flags bitOr: 2 ].
	self isThereAnOverride ifTrue: [ flags := flags bitOr: 1 ].
	aColor := {
		Color transparent.
		Color tan lighter.
		Color green muchLighter.
		Color blue muchLighter.
		Color red muchLighter.	"has super but doesn't call it"
		(Color r: 0.94 g: 0.823 b: 0.673).	"has sub; has super but doesn't call it"
		Color green muchLighter.
		Color blue muchLighter.
	} at: flags + 1.

	^aColor! !


!CodeHolder methodsFor: 'traits' stamp: 'al 4/24/2004 12:46'!
makeSampleInstance
	| aClass nonMetaClass anInstance |
	((aClass _ self selectedClassOrMetaClass) isNil or: [aClass isTrait]) ifTrue: [^ self].
	nonMetaClass _ aClass theNonMetaClass.
	anInstance _ self sampleInstanceOfSelectedClass.
	(anInstance isNil and: [nonMetaClass ~~ UndefinedObject]) ifTrue: 
		[^ self inform: 'Sorry, cannot make an instance of ', nonMetaClass name].

	(Smalltalk isMorphic and: [anInstance isMorph])
		ifTrue:
			[self currentHand attachMorph: anInstance]
		ifFalse:
			[anInstance inspectWithLabel: 'An instance of ', nonMetaClass name]! !

!CodeHolder methodsFor: 'traits' stamp: 'al 4/24/2004 12:44'!
showUnreferencedClassVars
	"Search for all class variables known to the selected class, and put up a 
	list of those that have no references anywhere in the system. The 
	search includes superclasses, so that you don't need to navigate your 
	way to the class that defines each class variable in order to determine 
	whether it is unreferenced"
	| cls aList aReport |
	((cls _ self selectedClass) isNil or: [cls isTrait]) ifTrue: [^ self].
	aList _ self systemNavigation allUnreferencedClassVariablesOf: cls.
	aList size == 0
		ifTrue: [^ self inform: 'There are no unreferenced
class variables in
' , cls name].
	aReport _ String
				streamContents: [:aStream | 
					aStream nextPutAll: 'Unreferenced class variable(s) in ' , cls name;
						 cr.
					aList
						do: [:el | aStream tab; nextPutAll: el; cr]].
	Transcript cr; show: aReport.
	(SelectionMenu labels: aList selections: aList)
		startUpWithCaption: 'Unreferenced
class variables in 
' , cls name! !

!CodeHolder methodsFor: 'traits' stamp: 'al 4/24/2004 12:43'!
showUnreferencedInstVars
	"Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system.  The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced"

	| cls aList aReport |
	((cls _ self selectedClassOrMetaClass) isNil or: [cls isTrait]) ifTrue: [^ self].
	aList _ cls allUnreferencedInstanceVariables.
	aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced
instance variables in
', cls name].
	aReport _ String streamContents:
		[:aStream |
			aStream nextPutAll: 'Unreferenced instance variable(s) in ', cls name; cr.
			aList do: [:el | aStream tab; nextPutAll: el; cr]].
	Transcript cr; show: aReport.
	(SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced
instance variables in 
', cls name! !

!CodeHolder methodsFor: 'traits' stamp: 'al 4/24/2004 12:12'!
spawnHierarchy
	"Create and schedule a new hierarchy browser on the currently selected class or meta."

	| newBrowser aSymbol aBehavior messageCatIndex selectedClassOrMetaClass |
	(selectedClassOrMetaClass _ self selectedClassOrMetaClass)
		ifNil: [^ self].
	selectedClassOrMetaClass isTrait ifTrue: [^self].
	newBrowser _ HierarchyBrowser new initHierarchyForClass: selectedClassOrMetaClass.
	((aSymbol _ self selectedMessageName) notNil and: [(MessageSet isPseudoSelector: aSymbol) not])
		ifTrue:
			[aBehavior _ selectedClassOrMetaClass.
			messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
			newBrowser messageCategoryListIndex: messageCatIndex + 1.
			newBrowser messageListIndex:
				((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)].
	Browser
		openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: newBrowser labelString.
	Smalltalk isMorphic
		ifTrue: ["this workaround only needed in morphic"
			newBrowser assureSelectionsShow]! !


!CodeHolder methodsFor: 'what to show' stamp: 'nk 6/19/2004 16:59'!
addContentsTogglesTo: aMenu 
	"Add updating menu toggles governing contents to aMenu."
	self contentsSymbolQuints
		do: [:aQuint | aQuint == #-
				ifTrue: [aMenu addLine]
				ifFalse: [Smalltalk isMorphic
						ifTrue: [aMenu
								addUpdating: aQuint third
								target: self
								action: aQuint second.
							aMenu balloonTextForLastItem: aQuint fifth]
						ifFalse: [aMenu
								add: (('<yes>*' match: (self perform: aQuint third)) ifTrue: ['*'] ifFalse: ['']), aQuint fourth
								target: self
								selector: #contentsSymbol: 
								argumentList: { aQuint first } ]]]! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:36'!
colorPrintString
	"Answer whether the receiver is showing colorPrint"

	^ (self showingColorPrint
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'colorPrint'! !

!CodeHolder methodsFor: 'what to show' stamp: 'yo 2/17/2005 18:09'!
offerWhatToShowMenu
	"Offer a menu governing what to show"
	| aMenu |
	Smalltalk isMorphic
		ifTrue: [aMenu := MenuMorph new defaultTarget: self.
			aMenu addTitle: 'What to show' translated.
			aMenu addStayUpItem.
			self addContentsTogglesTo: aMenu.
			aMenu popUpInWorld]
		ifFalse: [aMenu := CustomMenu new.
			self addContentsTogglesTo: aMenu.
			aMenu title: 'What to show' translated.
			aMenu invokeOn: self.
			self changed: #contents ]! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:36'!
prettyPrintString
	"Answer whether the receiver is showing pretty-print"

	^ ((contentsSymbol == #prettyPrint)
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'prettyPrint'! !

!CodeHolder methodsFor: 'what to show' stamp: 'sd 11/20/2005 21:27'!
setContentsToForceRefetch
	"Set the receiver's contents such that on the next update the contents will be formulated afresh.  This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty.  By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more"

	contents := nil! !

!CodeHolder methodsFor: 'what to show' stamp: 'sd 11/20/2005 21:27'!
showByteCodes: aBoolean
	"Get into or out of bytecode-showoing mode"

	self okToChange ifFalse: [^ self changed: #flash].
	aBoolean
		ifTrue:
			[contentsSymbol := #byteCodes]
		ifFalse:
			[contentsSymbol == #byteCodes ifTrue: [contentsSymbol := #source]].
	self contentsChanged! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 11:32'!
showComment
	"Answer whether the receiver should show documentation rather than, say, source code"

	^ self contentsSymbol == #documentation
! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:14'!
showDecompile: aBoolean
	"Set the decompile toggle as indicated"

	self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#decompile])! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 12:25'!
showDocumentation: aBoolean
	"Set the showDocumentation toggle as indicated"

	self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#documentation])! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:05'!
showingByteCodes
	"Answer whether the receiver is showing bytecodes"

	^ contentsSymbol == #byteCodes! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 18:28'!
showingByteCodesString
	"Answer whether the receiver is showing bytecodes"

	^ (self showingByteCodes
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'byteCodes'! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 23:50'!
showingColorPrint
	"Answer whether the receiver is showing color-pretty-print"

	^ contentsSymbol == #colorPrint! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:52'!
showingDecompile
	"Answer whether the receiver should show decompile rather than, say, source code"

	^ self contentsSymbol == #decompile
! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:50'!
showingDecompileString
	"Answer a string characerizing whether decompilation is showing"

	^ (self showingDecompile
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'decompile'! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 12:12'!
showingDocumentation
	"Answer whether the receiver should show documentation rather than, say, source code"

	^ self contentsSymbol == #documentation
! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:05'!
showingDocumentationString
	"Answer a string characerizing whether documentation is showing"

	^ (self showingDocumentation
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'documentation'! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 19:43'!
showingPlainSource
	"Answer whether the receiver is showing plain source"

	^ contentsSymbol == #source! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 09:31'!
showingPlainSourceString
	"Answer a string telling whether the receiver is showing plain source"

	^ (self showingPlainSource
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'source'! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:36'!
showingPrettyPrint
	"Answer whether the receiver is showing pretty-print"

	^ contentsSymbol == #prettyPrint! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 11:48'!
showingSource
	"Answer whether the receiver is currently showing source code"

	^ self contentsSymbol == #source
! !

!CodeHolder methodsFor: 'what to show' stamp: 'sd 11/20/2005 21:26'!
toggleDecompile
	"Toggle the setting of the showingDecompile flag, unless there are unsubmitted edits that the user declines to discard"

	| wasShowing |
	self okToChange ifTrue:
		[wasShowing := self showingDecompile.
		self restoreTextualCodingPane.
		self showDecompile: wasShowing not.
		self setContentsToForceRefetch.
		self contentsChanged]

! !

!CodeHolder methodsFor: 'what to show' stamp: 'sd 11/20/2005 21:27'!
toggleShowDocumentation
	"Toggle the setting of the showingDocumentation flag, unless there are unsubmitted edits that the user declines to discard"

	| wasShowing |
	self okToChange ifTrue:
		[wasShowing := self showingDocumentation.
		self restoreTextualCodingPane.
		self showDocumentation: wasShowing not.
		self setContentsToForceRefetch.
		self contentsChanged]

! !

!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:09'!
toggleShowingByteCodes
	"Toggle whether the receiver is showing bytecodes"

	self restoreTextualCodingPane.
	self showByteCodes: self showingByteCodes not.
	self setContentsToForceRefetch.
	self contentsChanged! !


!CodeHolder methodsFor: '*eToys-tiles' stamp: 'nk 4/28/2004 10:14'!
installTilesForSelection
	"Install universal tiles into the code pane."
	| source aSelector aClass tree syn tileScriptor aWindow codePane |
	(aWindow _ self containingWindow)
		ifNil: [self error: 'hamna dirisha'].
	tileScriptor _ ((aSelector _ self selectedMessageName) isNil
					or: [(aClass _ self selectedClassOrMetaClass whichClassIncludesSelector: aSelector) isNil])
				ifTrue: [PluggableTileScriptorMorph new]
				ifFalse: [source _ aClass sourceCodeAt: aSelector.
					tree _ Compiler new
								parse: source
								in: aClass
								notifying: nil.
					(syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass.
					syn inAPluggableScrollPane].
	codePane _ aWindow
				findDeepSubmorphThat: [:m | (m isKindOf: PluggableTextMorph)
						and: [m getTextSelector == #contents]]
				ifAbsent: [].
	codePane
		ifNotNil: [codePane hideScrollBars].
	codePane
		ifNil: [codePane _ aWindow
						findDeepSubmorphThat: [:m | m isKindOf: PluggableTileScriptorMorph]
						ifAbsent: [self error: 'no code pane']].
	tileScriptor color: aWindow paneColorToUse;
		 setProperty: #hideUnneededScrollbars toValue: true.
	aWindow replacePane: codePane with: tileScriptor.
	currentCompiledMethod _ aClass
				ifNotNil: [aClass compiledMethodAt: aSelector].
	tileScriptor owner clipSubmorphs: true.
	tileScriptor extent: codePane extent! !

!CodeHolder methodsFor: '*eToys-tiles' stamp: 'sw 2/3/2001 00:10'!
showingTiles
	"Answer whether the receiver is currently showing tiles"

	^ contentsSymbol == #tiles
! !

!CodeHolder methodsFor: '*eToys-tiles' stamp: 'sw 5/20/2001 21:12'!
showingTilesString
	"Answer a string characterizing whether tiles are currently showing or not"

	^ (self showingTiles
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'tiles'! !

!CodeHolder methodsFor: '*eToys-tiles' stamp: 'rhi 1/4/2002 11:15'!
showTiles: aBoolean
	"Set the showingTiles as indicated.  The fact that there are initially no senders of this reflects that fact that initially this trait is only directly settable through the UI; later there may be senders, such as if one wanted to set a system up so that all newly-opened browsers showed tiles rather than text."

	aBoolean
		ifTrue:
			[contentsSymbol _ #tiles]
		ifFalse:
			[contentsSymbol == #tiles ifTrue: [contentsSymbol _ #source]].
	self setContentsToForceRefetch.
	self changed: #contents! !

!CodeHolder methodsFor: '*eToys-tiles' stamp: 'sw 2/14/2001 15:27'!
toggleShowingTiles
	"Toggle whether tiles should be shown in the code pane"

	self okToChange ifTrue:
		[self showingTiles
			ifTrue:
				[contentsSymbol _ #source.
				self setContentsToForceRefetch.
				self installTextualCodingPane.
				self contentsChanged]
			ifFalse:
				[contentsSymbol _ #tiles.
				self installTilesForSelection.
				self changed: #tiles]]! !


!CodeHolder methodsFor: '*services-base' stamp: 'rr 3/15/2004 09:21'!
requestor
	^ (BrowserRequestor new) browser: self; yourself! !
Object subclass: #CodeLoader
	instanceVariableNames: 'baseURL sourceFiles segments publicKey'
	classVariableNames: 'DefaultBaseURL DefaultKey'
	poolDictionaries: ''
	category: 'System-Download'!
!CodeLoader commentStamp: '<historical>' prior: 0!
CodeLoader provides a simple facility for loading code from the network.

Examples:
	| loader |
	loader _ CodeLoader new.
	loader baseURL:'http://isgwww.cs.uni-magdeburg.de/~raab/test/'.
	loader localCache: #('.cache' 'source').
	"Sources and segments can be loaded in parallel"
	loader loadSourceFiles: #('file1.st' 'file2.st.gz').
	loader localCache: #('.cache' 'segments').
	loader loadSegments: #('is1.extseg' 'is2.extseg.gz').
	"Install sources first - will wait until the files are actually loaded"
	loader installSourceFiles.
	"And then the segments"
	loader installSegments.!


!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/13/1999 18:19'!
baseURL
	^baseURL! !

!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/13/1999 18:19'!
baseURL: aString
	baseURL _ aString.! !

!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:07'!
publicKey
	^publicKey! !

!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:07'!
publicKey: aPublicKey
	publicKey _ aPublicKey! !


!CodeLoader methodsFor: 'initialize-release' stamp: 'mir 1/11/2000 13:47'!
initialize
	publicKey _ DefaultKey.
	baseURL _ self class defaultBaseURL! !


!CodeLoader methodsFor: 'installing' stamp: 'RAA 2/19/2001 08:23'!
installProject
	"Assume that we're loading a single file and it's a project"
	| aStream |
	aStream _ sourceFiles first contentStream.
	aStream ifNil:[^self error:'Project was not loaded'].
	ProjectLoading
			openName: nil 		"<--do we want to cache this locally? Need a name if so"
			stream: aStream
			fromDirectory: nil
			withProjectView: nil.
! !

!CodeLoader methodsFor: 'installing' stamp: 'sd 1/30/2004 15:16'!
installSegment: reqEntry
	"Install the previously loaded segment"
	| contentStream contents trusted |
	contentStream _ reqEntry value contentStream.
	contentStream ifNil:[^self error:'No content to install: ', reqEntry key printString].
	trusted _ SecurityManager default positionToSecureContentsOf: contentStream.
	trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[
		contentStream close.
		^self error:'Insecure content encountered: ', reqEntry key printString]].
	contents _ contentStream ascii upToEnd unzipped.
	(contentStream respondsTo: #close) ifTrue:[contentStream close].
	^(RWBinaryOrTextStream with: contents) reset fileInObjectAndCode install.! !

!CodeLoader methodsFor: 'installing' stamp: 'mir 1/20/2000 13:37'!
installSegments
	"Install the previously loaded segments"
	segments == nil ifTrue:[^self].
	segments do:[:req| self installSegment: req].
	segments _ nil.! !

!CodeLoader methodsFor: 'installing' stamp: 'sd 1/30/2004 15:16'!
installSourceFile: aStream
	"Install the previously loaded source file"
	| contents trusted |
	aStream ifNil:[^self error:'No content to install'].
	trusted _ SecurityManager default positionToSecureContentsOf: aStream.
	trusted ifFalse:[(SecurityManager default enterRestrictedMode) 
					ifFalse:[ aStream close.
							^ self error:'Insecure content encountered']].
	contents _ aStream ascii upToEnd unzipped.
	(aStream respondsTo: #close) ifTrue:[aStream close].
	^(RWBinaryOrTextStream with: contents) reset fileIn! !

!CodeLoader methodsFor: 'installing' stamp: 'ar 12/22/1999 15:02'!
installSourceFiles
	"Install the previously loaded source files"
	sourceFiles == nil ifTrue:[^self].
	sourceFiles do:[:req| self installSourceFile: req contentStream].
	sourceFiles _ nil.! !


!CodeLoader methodsFor: 'loading' stamp: 'mir 10/13/2000 12:24'!
loadSegments: anArray
	"Load all the source files in the given array."
	| loader request reqName |
	loader _ HTTPLoader default.
	segments _ anArray collect:[:name |
		reqName _ (FileDirectory extensionFor: name) isEmpty
			ifTrue: [FileDirectory fileName: name extension: ImageSegment compressedFileExtension]
			ifFalse: [name].
		request _ self createRequestFor: reqName in: loader.
		name->request].
! !

!CodeLoader methodsFor: 'loading' stamp: 'ar 12/14/1999 14:40'!
loadSourceFiles: anArray
	"Load all the source files in the given array."
	| loader request |
	loader _ HTTPLoader default.
	sourceFiles _ anArray collect:[:name|
		request _ self createRequestFor: name in: loader.
		request].
! !


!CodeLoader methodsFor: 'private' stamp: 'mir 2/2/2001 14:44'!
createRequestFor: name in: aLoader
	"Create a URL request for the given string, which can be cached locally."
	| request |
	request _ HTTPLoader httpRequestClass for: self baseURL , name in: aLoader.
	aLoader addRequest: request. "fetch from URL"
	^request! !

!CodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40'!
httpRequestClass
	^HTTPDownloadRequest! !

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

CodeLoader class
	instanceVariableNames: ''!

!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/11/2000 13:45'!
defaultBaseURL
	^DefaultBaseURL ifNil: ['']! !

!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/11/2000 13:45'!
defaultBaseURL: aURLString
	DefaultBaseURL _ aURLString! !

!CodeLoader class methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:08'!
defaultKey
	"Return the default key used for verifying signatures of loaded code"
	^DefaultKey! !

!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/10/2000 18:16'!
defaultKey: aPublicKey
	"Store the default key used for verifying signatures of loaded code"
	DefaultKey _ aPublicKey
	"CodeLoader defaultKey: DOLPublicKey"
	"CodeLoader defaultKey: (DigitalSignatureAlgorithm testKeySet at: 2)"! !


!CodeLoader class methodsFor: 'utilities' stamp: 'mir 9/6/2000 15:03'!
compressFileNamed: aFileName
	self compressFileNamed: aFileName in: FileDirectory default! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/13/2000 13:27'!
compressFileNamed: aFileName in: aDirectory
	"Compress the currently selected file"
	| zipped buffer unzipped zipFileName |
	unzipped _ aDirectory readOnlyFileNamed: (aDirectory fullNameFor: aFileName).
	unzipped binary.
	zipFileName _ aFileName copyUpToLast: $. .
	zipped _ aDirectory newFileNamed: (zipFileName, FileDirectory dot, ImageSegment compressedFileExtension).
	zipped binary.
	zipped _ GZipWriteStream on: zipped.
	buffer _ ByteArray new: 50000.
	'Compressing ', zipFileName displayProgressAt: Sensor cursorPoint
		from: 0 to: unzipped size
		during:[:bar|
			[unzipped atEnd] whileFalse:[
				bar value: unzipped position.
				zipped nextPutAll: (unzipped nextInto: buffer)].
			zipped close.
			unzipped close].
! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 16:22'!
exportCategories: catList to: aFileName
	"CodeLoader exportCategories: #( 'Game-Animation' 'Game-Framework' ) to: 'Game-Framework'"

	| list classList |
	classList _ OrderedCollection new.
	catList do: [:catName |
		list _ SystemOrganization listAtCategoryNamed: catName asSymbol.
		list do: [:nm | classList add: (Smalltalk at: nm); add: (Smalltalk at: nm) class]].
	self exportCodeSegment: aFileName classes: classList keepSource: true! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 20:53'!
exportCategoryNamed: catName
	"CodeLoader exportCategoryNamed: 'OceanicPanic' "

	| list |
	list _ SystemOrganization listAtCategoryNamed: catName asSymbol.
	self exportClassesNamed: list to: catName! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 20:53'!
exportClassesNamed: classNameList to: aFileName

	| classList |
	classList _ OrderedCollection new.
	classNameList do: [:nm | classList add: (Smalltalk at: nm); add: (Smalltalk at: nm) class].
	self exportCodeSegment: aFileName classes: classList keepSource: true! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/11/2000 19:12'!
exportCodeSegment: exportName classes: aClassList keepSource: keepSources

	"Code for writing out a specific category of classes as an external image segment.  Perhaps this should be a method."

	| is oldMethods newMethods m oldCodeString argsAndTemps classList symbolHolder fileName |
	keepSources
		ifTrue: [
			self confirm: 'We are going to abandon sources.
Quit without saving after this has run.' orCancel: [^self]].

	classList _ aClassList asArray.

	"Strong pointers to symbols"
	symbolHolder := Symbol allInstances.

	oldMethods _ OrderedCollection new: classList size * 150.
	newMethods _ OrderedCollection new: classList size * 150.
	keepSources
		ifTrue: [
			classList do: [:cl |
				cl selectors do:
					[:selector |
					m _ cl compiledMethodAt: selector.
					m fileIndex > 0 ifTrue:
						[oldCodeString _ cl sourceCodeAt: selector.
						argsAndTemps _ (cl compilerClass new
							parse: oldCodeString in: cl notifying: nil) tempNames.
						oldMethods addLast: m.
						newMethods addLast: (m copyWithTempNames: argsAndTemps)]]]].
	oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
	oldMethods _ newMethods _ m _ oldCodeString _ argsAndTemps _ nil.

	Smalltalk garbageCollect.
	is _ ImageSegment new copyFromRootsForExport: classList.	"Classes and MetaClasses"

	fileName _ FileDirectory fileName: exportName extension: ImageSegment fileExtension.
	is writeForExport: fileName.
	self compressFileNamed: fileName

! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/12/2000 17:39'!
loadCode: codeSegmentName from: baseURL ifClassNotLoaded: testClass

	CodeLoader defaultBaseURL: baseURL.
	(Smalltalk includesKey: testClass)
		ifFalse: [CodeLoader loadCodeSegment: codeSegmentName].
! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 2/2/2001 14:56'!
loadCodeSegment: segmentName
	| loader |
	loader _ self new.
	loader loadSegments: (Array with: segmentName). 
	loader installSegments.! !

!CodeLoader class methodsFor: 'utilities' stamp: 'asm 12/6/2002 08:11'!
signFile: fileName renameAs: destFile key: privateKey dsa: dsa
	"Sign the given file using the private key."
	| in out |
	in _ FileStream readOnlyFileNamed: fileName.	in binary.
	out _ FileStream newFileNamed: destFile.			out binary.
	[in atEnd] whileFalse:[out nextPutAll: (in next: 4096)].
	in close.	out close.
	FileDirectory activeDirectoryClass splitName: destFile to:[:path :file|
		SecurityManager default signFile: file directory: (FileDirectory on: path).
	].
! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 2/14/2000 16:47'!
signFiles: fileNames in: dirName key: privateKey
	"Sign the files in the current directory and put them into a folder signed."

	|  newNames oldNames |
	oldNames _ fileNames collect:[:fileName | dirName , FileDirectory slash, fileName].
	newNames _ fileNames collect:[:fileName | dirName , FileDirectory slash, 'signed', FileDirectory slash, fileName].
	CodeLoader
		signFilesFrom: oldNames
		to: newNames
		key: privateKey! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 18:49'!
signFiles: fileNames key: privateKey
	"Sign the files in the current directory and put them into a folder signed."

	|  newNames |
	newNames _ fileNames collect:[:fileName | 'signed', FileDirectory slash, fileName].
	CodeLoader
		signFilesFrom: fileNames
		to: newNames
		key: privateKey! !

!CodeLoader class methodsFor: 'utilities' stamp: 'ads 7/31/2003 14:00'!
signFilesFrom: sourceNames to: destNames key: privateKey
	"Sign all the given files using the private key.
	This will add an 's' to the extension of the file."
	"| fd oldNames newNames |
	fd _ FileDirectory default directoryNamed:'unsigned'.
	oldNames _ fd fileNames.
	newNames _ oldNames collect:[:name| 'signed', FileDirectory slash, name].
	oldNames _ oldNames collect:[:name| 'unsigned', FileDirectory slash, name].
	CodeLoader
		signFilesFrom: oldNames
		to: newNames
		key: DOLPrivateKey."
	| dsa |
	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandomNonInteractively.
	'Signing files...' displayProgressAt: Sensor cursorPoint
		from: 1 to: sourceNames size during:[:bar|
			1 to: sourceNames size do:[:i|
				bar value: i.
				self signFile: (sourceNames at: i) renameAs: (destNames at: i) key: privateKey dsa: dsa]].
! !

!CodeLoader class methodsFor: 'utilities' stamp: 'ar 2/6/2001 19:17'!
verifySignedFileNamed: aFileName
	"CodeLoader verifySignedFileNamed: 'signed\dummy1.dsq' "

	| secured signedFileStream |
	signedFileStream _ FileStream fileNamed: aFileName.
	secured _ SecurityManager default positionToSecureContentsOf: signedFileStream.
	signedFileStream close.
	Transcript show: aFileName , ' verified: '; show: secured printString; cr.

! !
ModelExtension subclass: #CodeModelExtension
	instanceVariableNames: 'perClassCache'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!

!CodeModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/6/2005 15:29'!
cacheFor: aClass 
	^perClassCache at: aClass ifAbsentPut: [self newCacheFor: aClass]! !

!CodeModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/1/2005 21:17'!
clearOut: aClass 
	^perClassCache removeKey: aClass ifAbsent: []! !

!CodeModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/5/2005 14:20'!
for: aClass 
	| newSendCache |
	^perClassCache at: aClass
		ifAbsent: 
			[newSendCache := self newCacheFor: aClass.
			(self haveInterestsIn: aClass) 
				ifTrue: [perClassCache at: aClass put: newSendCache].
			newSendCache]! !

!CodeModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/1/2005 21:18'!
initialize
	super initialize.
	perClassCache := IdentityDictionary new.! !


!CodeModelExtension methodsFor: 'invalidation' stamp: 'dvf 1/31/2006 23:38'!
classChanged: modificationEvent 
	"We dont want to provide an out of date reply"
	modificationEvent itemClass ifNil: [self].
	self clearOut: modificationEvent itemClass
! !

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

CodeModelExtension class
	instanceVariableNames: ''!

!CodeModelExtension class methodsFor: 'initialize-release' stamp: 'dvf 9/2/2005 12:20'!
isAbstract
	^self == CodeModelExtension! !
RectangleMorph subclass: #CodecDemoMorph
	instanceVariableNames: 'codecClassName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!CodecDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/4/1999 12:36'!
codecClassName: aStringOrSymbol

	| label |
	codecClassName _ aStringOrSymbol asSymbol.
	self removeAllMorphs.
	label _ StringMorph contents: aStringOrSymbol.
	label position: self position + (5@5).
	self addMorph: label.
	label lock: true.
	self extent: label extent + (10@10).
! !

!CodecDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/4/1999 12:33'!
selectCodec

	| aMenu codecs newCodec |
	aMenu _ CustomMenu new title: 'Codec:'.
	codecs _ (SoundCodec allSubclasses collect: [:c | c name]) asSortedCollection.
	codecs add: 'None'.
	codecs do:[:cName | aMenu add: cName action: cName].
	newCodec _ aMenu startUp.
	newCodec ifNil: [^ self].
	self codecClassName: newCodec.
! !


!CodecDemoMorph methodsFor: 'dropping/grabbing' stamp: 'jm 2/4/1999 12:19'!
wantsDroppedMorph: aMorph event: evt

	^ aMorph isMemberOf: SoundTile
! !


!CodecDemoMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:20'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 1.0
		g: 0.806
		b: 0.677! !

!CodecDemoMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:20'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self codecClassName: 'MuLawCodec'! !


!CodecDemoMorph methodsFor: 'layout' stamp: 'jm 2/4/1999 12:37'!
acceptDroppingMorph: aMorph event: evt

	| codecClass |
	'None' = codecClassName
		ifTrue: [aMorph sound play]
		ifFalse: [
			codecClass _ Smalltalk at: codecClassName ifAbsent: [^ self].
			(codecClass new compressAndDecompress: aMorph sound) play].
	aMorph position: self topRight + (10@0).
! !


!CodecDemoMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'select codec' translated action: #selectCodec.
! !
SystemWindow subclass: #CollapsedMorph
	instanceVariableNames: 'uncollapsedMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!CollapsedMorph methodsFor: 'collapse/expand' stamp: 'sw 5/9/2000 00:18'!
beReplacementFor: aMorph

	| itsWorld priorPosition |
	(itsWorld _ aMorph world) ifNil: [^self].
	uncollapsedMorph _ aMorph.
			
	self setLabel: aMorph externalName.
	aMorph delete.
	itsWorld addMorphFront: self.
	self collapseOrExpand.
	(priorPosition _ aMorph valueOfProperty: #collapsedPosition ifAbsent: [nil])
	ifNotNil:
		[self position: priorPosition].
! !

!CollapsedMorph methodsFor: 'collapse/expand' stamp: 'sw 4/9/2001 14:23'!
uncollapseToHand
	"Hand the uncollapsedMorph to the user, placing it in her hand, after remembering appropriate state for possible future use"

	| nakedMorph |
	nakedMorph _ uncollapsedMorph.
	uncollapsedMorph _ nil.
	nakedMorph setProperty: #collapsedPosition toValue: self position.
	mustNotClose _ false.  "so the delete will succeed"
	self delete.
	ActiveHand attachMorph: nakedMorph! !


!CollapsedMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:41'!
buildWindowMenu
	"Answer the menu to be put up in response to the user's clicking on the window-menu control in the window title.  Specialized for CollapsedMorphs."

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu add: 'change name...' translated action: #relabel.
	aMenu addLine.
	aMenu add: 'send to back' translated action: #sendToBack.
	aMenu add: 'make next-to-topmost' translated action: #makeSecondTopmost.
	aMenu addLine.
	self mustNotClose
		ifFalse:
			[aMenu add: 'make unclosable' translated action: #makeUnclosable]
		ifTrue:
			[aMenu add: 'make closable' translated action: #makeClosable].
	aMenu
		add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) translated 
		action: #toggleStickiness.
	^aMenu! !


!CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 9/1/2000 11:07'!
collapseOrExpand
	"Toggle the expand/collapsd state of the receiver.  If expanding, copy the window title back to the name of the expanded morph"

	| aWorld |
	isCollapsed
		ifTrue: 
			[uncollapsedMorph setProperty: #collapsedPosition toValue: self position.
			labelString ifNotNil: [uncollapsedMorph setNameTo: labelString].
			mustNotClose _ false.	"We're not closing but expanding"
			self delete.
			(aWorld _ self currentWorld) addMorphFront: uncollapsedMorph.
			aWorld startSteppingSubmorphsOf: uncollapsedMorph]
		ifFalse:
			[super collapseOrExpand]! !

!CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 6/5/2001 22:55'!
wantsExpandBox
	"Answer whether I'd like an expand box"

	^ false! !


!CollapsedMorph methodsFor: '*eToys-queries' stamp: 'sw 4/9/2001 12:53'!
isMyUncollapsedMorph: aMorph
	"Answer whether my uncollapsed morph is aMorph"

	^ uncollapsedMorph == aMorph! !

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

CollapsedMorph class
	instanceVariableNames: ''!

!CollapsedMorph class methodsFor: '*eToys-as yet unclassified' stamp: 'sw 4/9/2001 14:19'!
collapsedMorphOrNilFor: anActualMorph
	"If there is any instance of the receiver that represents anActualMorph, answer it, else answer nil"

	self allInstances do:
		[:cm | (cm isMyUncollapsedMorph: anActualMorph)
			ifTrue:	[^ cm]].
	^ nil! !
Object subclass: #Collection
	instanceVariableNames: ''
	classVariableNames: 'MutexForPicking RandomForPicking'
	poolDictionaries: ''
	category: 'Collections-Abstract'!
!Collection commentStamp: '<historical>' prior: 0!
I am the abstract superclass of all classes that represent a group of elements.!


!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:33'!
anyOne
	"Answer a representative sample of the receiver. This method can
	be helpful when needing to preinfer the nature of the contents of 
	semi-homogeneous collections."

	self emptyCheck.
	self do: [:each | ^ each]! !

!Collection methodsFor: 'accessing' stamp: 'sd 11/4/2003 22:05'!
atRandom
	"Answer a random element of the receiver.  Uses a shared random 
	number generator owned by class Collection.  If you use this a lot, 
	define your own instance of Random and use #atRandom:.  Causes 
	an error if self has no elements."

	^ self class mutexForPicking critical: [
		self atRandom: self class randomForPicking ]

"Examples:
	#('one' 'or' 'the' 'other') atRandom
	(1 to: 10) atRandom
	'Just pick one of these letters at random' atRandom
	#(3 7 4 9 21) asSet atRandom		(just to show it also works for Sets)
"! !

!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:41'!
capacity
	"Answer the current capacity of the receiver."

	^ self size! !

!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:34'!
size
	"Answer how many elements the receiver contains."

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


!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:34'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with another Collection, return a Collection of
	the results of each element combined with the scalar in that expression."

	rcvr isSequenceable & self isSequenceable ifFalse:
		[self error: 'Only sequenceable collections may be combined arithmetically'].
	^ rcvr with: self collect:
		[:rcvrElement :myElement | rcvrElement perform: selector with: myElement]! !

!Collection methodsFor: 'adapting' stamp: 'mk 10/27/2003 21:48'!
adaptToComplex: rcvr andSend: selector
	"If I am involved in arithmetic with a scalar, return a Collection of
	the results of each element combined with the scalar in that expression."

	^ self collect: [:element | rcvr perform: selector with: element]! !

!Collection methodsFor: 'adapting' stamp: 'di 11/9/1998 12:16'!
adaptToNumber: rcvr andSend: selector
	"If I am involved in arithmetic with a scalar, return a Collection of
	the results of each element combined with the scalar in that expression."

	^ self collect: [:element | rcvr perform: selector with: element]! !

!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:37'!
adaptToPoint: rcvr andSend: selector
	"If I am involved in arithmetic with a scalar, return a Collection of
	the results of each element combined with the scalar in that expression."

	^ self collect: [:element | rcvr perform: selector with: element]! !

!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:37'!
adaptToString: rcvr andSend: selector
	"If I am involved in arithmetic with a String, convert it to a Number."
	^ rcvr asNumber perform: selector with: self! !


!Collection methodsFor: 'adding'!
add: newObject 
	"Include newObject as one of the receiver's elements. Answer newObject. 
	ArrayedCollections cannot respond to this message."

	self subclassResponsibility! !

!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:21'!
add: newObject withOccurrences: anInteger
	"Add newObject anInteger times to the receiver. Answer newObject."

	anInteger timesRepeat: [self add: newObject].
	^ newObject! !

!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:26'!
addAll: aCollection 
	"Include all the elements of aCollection as the receiver's elements. Answer 
	aCollection. Actually, any object responding to #do: can be used as argument."

	aCollection do: [:each | self add: each].
	^ aCollection! !

!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:23'!
addIfNotPresent: anObject
	"Include anObject as one of the receiver's elements, but only if there
	is no such element already. Anwser anObject."

	(self includes: anObject) ifFalse: [self add: anObject].
	^ anObject! !


!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'!
* arg

	^ arg adaptToCollection: self andSend: #*! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'!
+ arg

	^ arg adaptToCollection: self andSend: #+! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'!
- arg

	^ arg adaptToCollection: self andSend: #-! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'!
/ arg

	^ arg adaptToCollection: self andSend: #/! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'!
// arg

	^ arg adaptToCollection: self andSend: #//! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'!
\\ arg

	^ arg adaptToCollection: self andSend: #\\! !

!Collection methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 00:17'!
raisedTo: arg

	^ arg adaptToCollection: self andSend: #raisedTo:! !


!Collection methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:36'!
hash
	"Answer an integer hash value for the receiver such that,
	  -- the hash value of an unchanged object is constant over time, and
	  -- two equal objects have equal hash values"

	| hash |

	hash _ self species hash.
	self size <= 10 ifTrue:
		[self do: [:elem | hash _ hash bitXor: elem hash]].
	^hash bitXor: self size hash! !


!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'!
asArray
	"Answer an Array whose elements are the elements of the receiver.
	Implementation note: Cannot use ''Array withAll: self'' as that only
	works for SequenceableCollections which support the replacement 
	primitive."

	| array index |
	array _ Array new: self size.
	index _ 0.
	self do: [:each | array at: (index _ index + 1) put: each].
	^ array! !

!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:10'!
asBag
	"Answer a Bag whose elements are the elements of the receiver."

	^ Bag withAll: self! !

!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'!
asByteArray
	"Answer a ByteArray whose elements are the elements of the receiver.
	Implementation note: Cannot use ''ByteArray withAll: self'' as that only
	works for SequenceableCollections which support the replacement 
	primitive."

	| array index |
	array _ ByteArray new: self size.
	index _ 0.
	self do: [:each | array at: (index _ index + 1) put: each].
	^ array! !

!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:26'!
asCharacterSet
	"Answer a CharacterSet whose elements are the unique elements of the receiver.
	The reciever should only contain characters."

	^ CharacterSet newFrom: self! !

!Collection methodsFor: 'converting' stamp: 'ar 9/22/2000 10:12'!
asIdentitySet
	^(IdentitySet new: self size) addAll: self; yourself! !

!Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 20:30'!
asIdentitySkipList
	"Answer a IdentitySkipList whose elements are the elements of the 
	receiver. The sort order is the default less than or equal."

	^ self as: IdentitySkipList! !

!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:43'!
asOrderedCollection
	"Answer an OrderedCollection whose elements are the elements of the
	receiver. The order in which elements are added depends on the order
	in which the receiver enumerates its elements. In the case of unordered
	collections, the ordering is not necessarily the same for multiple 
	requests for the conversion."

	^ self as: OrderedCollection! !

!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:29'!
asSet
	"Answer a Set whose elements are the unique elements of the receiver."

	^ Set withAll: self! !

!Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 18:47'!
asSkipList
	"Answer a SkipList whose elements are the elements of the 
	receiver. The sort order is the default less than or equal."

	^ self as: SkipList! !

!Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 18:46'!
asSkipList: aSortBlock 
	"Answer a SkipList whose elements are the elements of the 
	receiver. The sort order is defined by the argument, aSortBlock."

	| skipList |
	skipList _ SortedCollection new: self size.
	skipList sortBlock: aSortBlock.
	skipList addAll: self.
	^ skipList! !

!Collection methodsFor: 'converting'!
asSortedArray
	"Return a copy of the receiver in sorted order, as an Array.  6/10/96 sw"

	^ self asSortedCollection asArray! !

!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:44'!
asSortedCollection
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is the default less than or equal."

	^ self as: SortedCollection! !

!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:46'!
asSortedCollection: aSortBlock 
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is defined by the argument, aSortBlock."

	| aSortedCollection |
	aSortedCollection _ SortedCollection new: self size.
	aSortedCollection sortBlock: aSortBlock.
	aSortedCollection addAll: self.
	^ aSortedCollection! !

!Collection methodsFor: 'converting' stamp: 'hg 12/26/2001 23:53'!
topologicallySortedUsing: aSortBlock 
	"Answer a SortedCollection whose elements are the elements of the 
	receiver, but topologically sorted. The topological order is defined 
	by the argument, aSortBlock."

	| aSortedCollection |
	aSortedCollection _ SortedCollection new: self size.
	aSortedCollection sortBlock: aSortBlock.
	self do: [:each | aSortedCollection addLast: each].	"avoids sorting"
	^ aSortedCollection sortTopologically
! !


!Collection methodsFor: 'copying' stamp: 'al 12/12/2003 14:31'!
, aCollection
	^self copy addAll: aCollection; yourself! !

!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:41'!
copyWith: newElement
	"Answer a new collection with newElement added (as last
	element if sequenceable)."

	^ self copy
		add: newElement;
		yourself! !

!Collection methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'!
copyWithDependent: newElement
	"Answer a new collection with newElement added (as last
	element if sequenceable)."
	^self copyWith: newElement! !

!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:43'!
copyWithout: oldElement 
	"Answer a copy of the receiver that does not contain any
	elements equal to oldElement."

	^ self reject: [:each | each = oldElement]

"Examples:
	'fred the bear' copyWithout: $e
	#(2 3 4 5 5 6) copyWithout: 5
"! !

!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 18:08'!
copyWithoutAll: aCollection
	"Answer a copy of the receiver that does not contain any elements 
	equal to those in aCollection."

	^ self reject: [:each | aCollection includes: each]! !


!Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'!
allSatisfy: aBlock
	"Evaluate aBlock with the elements of the receiver.
	If aBlock returns false for any element return false.
	Otherwise return true."

	self do: [:each | (aBlock value: each) ifFalse: [^ false]].
	^ true! !

!Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'!
anySatisfy: aBlock
	"Evaluate aBlock with the elements of the receiver.
	If aBlock returns true for any element return true.
	Otherwise return false."

	self do: [:each | (aBlock value: each) ifTrue: [^ true]].
	^ false! !

!Collection methodsFor: 'enumerating'!
associationsDo: aBlock
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations).  If any non-association is within, the error is not caught now,
	but later, when a key or value message is sent to it."

	self do: aBlock! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:45'!
collect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Collect the resulting values into a collection like the receiver. Answer  
	the new collection."

	| newCollection |
	newCollection _ self species new.
	self do: [:each | newCollection add: (aBlock value: each)].
	^ newCollection! !

!Collection methodsFor: 'enumerating' stamp: 'dgd 9/13/2004 23:42'!
collect: collectBlock thenDo: doBlock 
	"Utility method to improve readability."
	^ (self collect: collectBlock) do: doBlock! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:51'!
collect: collectBlock thenSelect: selectBlock
	"Utility method to improve readability."

	^ (self collect: collectBlock) select: selectBlock! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:52'!
count: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Answer the number of elements that answered true."

	| sum |
	sum _ 0.
	self do: [:each | (aBlock value: each) ifTrue: [sum _ sum + 1]].
	^ sum! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:20'!
detect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the first element for which aBlock evaluates to true."

	^ self detect: aBlock ifNone: [self errorNotFound: aBlock]! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:52'!
detect: aBlock ifNone: exceptionBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Answer the first element for which aBlock evaluates to true. If none  
	evaluate to true, then evaluate the argument, exceptionBlock."

	self do: [:each | (aBlock value: each) ifTrue: [^ each]].
	^ exceptionBlock value! !

!Collection methodsFor: 'enumerating'!
detectMax: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the highest magnitude.
	If collection empty, return nil.  This method might also be called elect:."

	| maxElement maxValue val |
	self do: [:each | 
		maxValue == nil
			ifFalse: [
				(val _ aBlock value: each) > maxValue ifTrue: [
					maxElement _ each.
					maxValue _ val]]
			ifTrue: ["first element"
				maxElement _ each.
				maxValue _ aBlock value: each].
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."].
	^ maxElement! !

!Collection methodsFor: 'enumerating'!
detectMin: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the lowest number.
	If collection empty, return nil."

	| minElement minValue val |
	self do: [:each | 
		minValue == nil
			ifFalse: [
				(val _ aBlock value: each) < minValue ifTrue: [
					minElement _ each.
					minValue _ val]]
			ifTrue: ["first element"
				minElement _ each.
				minValue _ aBlock value: each].
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."].
	^ minElement! !

!Collection methodsFor: 'enumerating'!
detectSum: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Return the sum of the answers."
	| sum |
	sum _ 0.
	self do: [:each | 
		sum _ (aBlock value: each) + sum].  
	^ sum! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:52'!
difference: aCollection
	"Answer the set theoretic difference of two collections."

	^ self reject: [:each | aCollection includes: each]! !

!Collection methodsFor: 'enumerating'!
do: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument."

	self subclassResponsibility! !

!Collection methodsFor: 'enumerating' stamp: 'md 7/22/2005 16:26'!
do: aBlock displayingProgress: aString

	aString
		displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
			[:bar |
			self inject: 1 into:
				[:index :each |
				bar value: index.
				aBlock value: each.
				index + 1]]! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:57'!
do: elementBlock separatedBy: separatorBlock
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."

	| beforeFirst | 
	beforeFirst _ true.
	self do:
		[:each |
		beforeFirst
			ifTrue: [beforeFirst _ false]
			ifFalse: [separatorBlock value].
		elementBlock value: each]! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:59'!
do: aBlock without: anItem 
	"Enumerate all elements in the receiver. 
	Execute aBlock for those elements that are not equal to the given item"

	^ self do: [:each | anItem = each ifFalse: [aBlock value: each]]! !

!Collection methodsFor: 'enumerating' stamp: 'dvf 6/10/2000 18:32'!
groupBy: keyBlock having: selectBlock 
	"Like in SQL operation - Split the recievers contents into collections of 
	elements for which keyBlock returns the same results, and return those 
	collections allowed by selectBlock. keyBlock should return an Integer."
	| result key |
	result _ PluggableDictionary integerDictionary.
	self do: 
		[:e | 
		key _ keyBlock value: e.
		(result includesKey: key)
			ifFalse: [result at: key put: OrderedCollection new].
		(result at: key)
			add: e].
	^ result _ result select: selectBlock! !

!Collection methodsFor: 'enumerating'!
inject: thisValue into: binaryBlock 
	"Accumulate a running value associated with evaluating the argument, 
	binaryBlock, with the current value of the argument, thisValue, and the 
	receiver as block arguments. For instance, to sum the numeric elements 
	of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 
	next]."

	| nextValue |
	nextValue _ thisValue.
	self do: [:each | nextValue _ binaryBlock value: nextValue value: each].
	^nextValue! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:52'!
intersection: aCollection
	"Answer the set theoretic intersection of two collections."

	^ self select: [:each | aCollection includes: each]! !

!Collection methodsFor: 'enumerating' stamp: 'gh 9/18/2001 15:59'!
noneSatisfy: aBlock
	"Evaluate aBlock with the elements of the receiver.
	If aBlock returns false for all elements return true.
	Otherwise return false"

	self do: [:item | (aBlock value: item) ifTrue: [^ false]].
	^ true! !

!Collection methodsFor: 'enumerating'!
reject: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect into a new collection like the receiver only those elements for 
	which aBlock evaluates to false. Answer the new collection."

	^self select: [:element | (aBlock value: element) == false]! !

!Collection methodsFor: 'enumerating' stamp: 'dgd 9/13/2004 23:42'!
reject: rejectBlock thenDo: doBlock 
	"Utility method to improve readability."
	^ (self reject: rejectBlock) do: doBlock! !

!Collection methodsFor: 'enumerating'!
select: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect into a new collection like the receiver, only those elements for 
	which aBlock evaluates to true. Answer the new collection."

	| newCollection |
	newCollection _ self species new.
	self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]].
	^newCollection! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:59'!
select: selectBlock thenCollect: collectBlock
	"Utility method to improve readability."

	^ (self select: selectBlock) collect: collectBlock! !

!Collection methodsFor: 'enumerating' stamp: 'dgd 9/13/2004 23:42'!
select: selectBlock thenDo: doBlock 
	"Utility method to improve readability."
	^ (self select: selectBlock) do: doBlock! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:54'!
union: aCollection
	"Answer the set theoretic union of two collections."

	^ self asSet addAll: aCollection; yourself! !


!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'!
contents
	^ self! !

!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:08'!
flattenOnStream: aStream 
	^ aStream writeCollection: self! !

!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'!
write: anObject 
	^ self add: anObject! !


!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'!
abs
	"Absolute value of all elements in the collection"
	^ self collect: [:a | a abs]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'!
arcCos
	^self collect: [:each | each arcCos]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'!
arcSin
	^self collect: [:each | each arcSin]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'!
arcTan
	^self collect: [:each | each arcTan]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:57'!
average
	^ self sum / self size! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'!
ceiling
	^ self collect: [:a | a ceiling]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'!
cos
	^self collect: [:each | each cos]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'!
degreeCos
	^self collect: [:each | each degreeCos]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'!
degreeSin
	^self collect: [:each | each degreeSin]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'!
exp
	^self collect: [:each | each exp]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'!
floor
	^ self collect: [:a | a floor]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'!
ln
	^self collect: [:each | each ln]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:52'!
log
	^ self collect: [:each | each log]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:58'!
max
	^ self inject: self anyOne into: [:max :each | max max: each]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'!
median
	^ self asSortedCollection median! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'!
min
	^ self inject: self anyOne into: [:min :each | min min: each]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:52'!
negated
	"Negated value of all elements in the collection"
	^ self collect: [:a | a negated]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'!
range
	^ self max - self min! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'!
reciprocal
	"Return the reciever full of reciprocated elements"
	^ self collect: [:a | a reciprocal]! !

!Collection methodsFor: 'math functions' stamp: 'nk 12/30/2003 15:47'!
roundTo: quantum
	^self collect: [ :ea | ea roundTo: quantum ]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'!
rounded
	^ self collect: [:a | a rounded]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:23'!
sign
	^self collect: [:each | each sign]! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:22'!
sin
	^self collect: [:each | each sin]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'!
sqrt
	^ self collect: [:each | each sqrt]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'!
squared
	^ self collect: [:each | each * each]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:02'!
sum
	"This is implemented using a variant of the normal inject:into: pattern. 
	The reason for this is that it is not known whether we're in the normal 
	number line, i.e. whether 0 is a good initial value for the sum. 
	Consider a collection of measurement objects, 0 would be the unitless 
	value and would not be appropriate to add with the unit-ed objects."
	| sum sample |
	sample _ self anyOne.
	sum _ self inject: sample into: [:accum :each | accum + each].
	^ sum - sample! !

!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:22'!
tan
	^self collect: [:each | each tan]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:54'!
truncated
	^ self collect: [:a | a truncated]! !


!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:19'!
asCommaString
	"Return collection printed as 'a, b, c' "

	^String streamContents: [:s | self asStringOn: s delimiter: ', ']
		! !

!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:20'!
asCommaStringAnd
	"Return collection printed as 'a, b and c' "

	^String streamContents: [:s | self asStringOn: s delimiter: ', ' last: ' and ']
		! !

!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:27'!
asStringOn: aStream delimiter: delimString
	"Print elements on a stream separated
	with a delimiter String like: 'a, b, c'
	Uses #asString instead of #print:."

	self do: [:elem | aStream nextPutAll: elem asString]
		separatedBy: [aStream nextPutAll: delimString]! !

!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:27'!
asStringOn: aStream delimiter: delimString last: lastDelimString
	"Print elements on a stream separated
	with a delimiter between all the elements and with
	a special one before the last like: 'a, b and c'.
	Uses #asString instead of #print:

	Note: Feel free to improve the code to detect the last element."

	| n sz |
	n _ 1.
	sz _ self size.
	self do: [:elem |
		n _ n + 1.
		aStream nextPutAll: elem asString]
	separatedBy: [
		aStream nextPutAll: (n = sz ifTrue: [lastDelimString] ifFalse: [delimString])]! !

!Collection methodsFor: 'printing' stamp: 'apb 4/21/2006 09:37'!
printElementsOn: aStream
	"The original code used #skip:, but some streams do not support that,
	 and we don't really need it."

	aStream nextPut: $(.
	self do: [:element | aStream print: element] separatedBy: [aStream space].
	aStream nextPut: $)! !

!Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'!
printNameOn: aStream
	super printOn: aStream! !

!Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'!
printOn: aStream 
	"Append a sequence of characters that identify the receiver to aStream."

	self printNameOn: aStream.
	self printElementsOn: aStream! !

!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:01'!
printOn: aStream delimiter: delimString
	"Print elements on a stream separated
	with a delimiter String like: 'a, b, c' "

	self do: [:elem | aStream print: elem] separatedBy: [aStream print: delimString]
		! !

!Collection methodsFor: 'printing' stamp: 'fbs 1/14/2005 10:54'!
printOn: aStream delimiter: delimString last: lastDelimString
	"Print elements on a stream separated
	with a delimiter between all the elements and with
	a special one before the last like: 'a, b and c'

	Note: Feel free to improve the code to detect the last element."

	| n sz |
	n _ 1.
	sz _ self size.
	self do: [:elem |
		n _ n + 1.
		aStream print: elem]
	separatedBy: [
		n = sz
			ifTrue: [aStream print: lastDelimString]
			ifFalse: [aStream print: delimString]]! !

!Collection methodsFor: 'printing'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet _ true.
	self do: 
		[:each | 
		noneYet
			ifTrue: [noneYet _ false]
			ifFalse: [aStream nextPut: $;].
		aStream nextPutAll: ' add: '.
		aStream store: each].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !


!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:22'!
remove: oldObject 
	"Remove oldObject from the receiver's elements. Answer oldObject 
	unless no element is equal to oldObject, in which case, raise an error.
	ArrayedCollections cannot respond to this message."

	^ self remove: oldObject ifAbsent: [self errorNotFound: oldObject]! !

!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:14'!
remove: oldObject ifAbsent: anExceptionBlock 
	"Remove oldObject from the receiver's elements. If several of the 
	elements are equal to oldObject, only one is removed. If no element is 
	equal to oldObject, answer the result of evaluating anExceptionBlock. 
	Otherwise, answer the argument, oldObject. ArrayedCollections cannot 
	respond to this message."

	self subclassResponsibility! !

!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:14'!
removeAll: aCollection 
	"Remove each element of aCollection from the receiver. If successful for 
	each, answer aCollection. Otherwise create an error notification.
	ArrayedCollections cannot respond to this message."

	aCollection do: [:each | self remove: each].
	^ aCollection! !

!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:16'!
removeAllFoundIn: aCollection 
	"Remove each element of aCollection which is present in the receiver 
	from the receiver. Answer aCollection. No error is raised if an element
	isn't found. ArrayedCollections cannot respond to this message."

	aCollection do: [:each | self remove: each ifAbsent: []].
	^ aCollection! !

!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:19'!
removeAllSuchThat: aBlock 
	"Evaluate aBlock for each element and remove all that elements from
	the receiver for that aBlock evaluates to true.  Use a copy to enumerate 
	collections whose order changes when an element is removed (i.e. Sets)."

	self copy do: [:each | (aBlock value: each) ifTrue: [self remove: each]]! !


!Collection methodsFor: 'testing'!
contains: aBlock
	"VW compatibility"
	^self anySatisfy: aBlock! !

!Collection methodsFor: 'testing' stamp: 'ls 3/27/2000 17:25'!
identityIncludes: anObject 
	"Answer whether anObject is one of the receiver's elements."

	self do: [:each | anObject == each ifTrue: [^true]].
	^false! !

!Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:37'!
ifEmpty: aBlock
	"Evaluate the block if I'm empty"

	^ self isEmpty ifTrue: aBlock! !

!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:49'!
ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock
	"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise"
	" If the notEmptyBlock has an argument, eval with the receiver as its argument"

	^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock valueWithPossibleArgument: self]! !

!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 15:36'!
ifEmpty: emptyBlock ifNotEmptyDo: notEmptyBlock
	"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise"
	"Evaluate the notEmptyBlock with the receiver as its argument"

	^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock value: self]! !

!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:58'!
ifNotEmpty: aBlock
	"Evaluate the given block unless the receiver is empty.

      If the block has an argument, eval with the receiver as its argument,
      but it might be better to use ifNotEmptyDo: to make the code easier to
      understand"

	^self isEmpty ifFalse: [aBlock valueWithPossibleArgument: self].
! !

!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:48'!
ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock
	"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise
	 If the notEmptyBlock has an argument, eval with the receiver as its argument"

	^ self isEmpty ifFalse: [notEmptyBlock valueWithPossibleArgument: self] ifTrue: emptyBlock! !

!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:28'!
ifNotEmptyDo: aBlock
	"Evaluate the given block with the receiver as its argument."

	^self isEmpty ifFalse: [aBlock value: self].
! !

!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 15:36'!
ifNotEmptyDo: notEmptyBlock ifEmpty: emptyBlock
	"Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise
	Evaluate the notEmptyBlock with the receiver as its argument"

	^ self isEmpty ifFalse: [notEmptyBlock value: self] ifTrue: emptyBlock! !

!Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:07'!
includes: anObject 
	"Answer whether anObject is one of the receiver's elements."

	^ self anySatisfy: [:each | each = anObject]! !

!Collection methodsFor: 'testing'!
includesAllOf: aCollection 
	"Answer whether all the elements of aCollection are in the receiver."
	aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]].
	^ true! !

!Collection methodsFor: 'testing'!
includesAnyOf: aCollection 
	"Answer whether any element of aCollection is one of the receiver's elements."
	aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]].
	^ false! !

!Collection methodsFor: 'testing' stamp: 'nk 8/30/2004 07:49'!
includesSubstringAnywhere: testString
	"Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring"
	self do:
		[:element |
			(element isString)
				ifTrue:
					[(element includesSubString: testString) ifTrue: [^ true]].
			(element isCollection)
				ifTrue:
					[(element includesSubstringAnywhere: testString) ifTrue: [^ true]]].
	^ false

"#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere:  'lvi'"! !

!Collection methodsFor: 'testing' stamp: 'ar 8/17/1999 19:43'!
isCollection
	"Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:"
	^true! !

!Collection methodsFor: 'testing'!
isEmpty
	"Answer whether the receiver contains any elements."

	^self size = 0! !

!Collection methodsFor: 'testing' stamp: 'bf 3/10/2000 09:29'!
isEmptyOrNil
	"Answer whether the receiver contains any elements, or is nil.  Useful in numerous situations where one wishes the same reaction to an empty collection or to nil"

	^ self isEmpty! !

!Collection methodsFor: 'testing' stamp: 'di 11/6/1998 09:16'!
isSequenceable
	^ false! !

!Collection methodsFor: 'testing' stamp: 'dgd 4/4/2004 12:14'!
isZero
	"Answer whether the receiver is zero"
	^ false! !

!Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 17:49'!
notEmpty
	"Answer whether the receiver contains any elements."

	^ self isEmpty not! !

!Collection methodsFor: 'testing'!
occurrencesOf: anObject 
	"Answer how many of the receiver's elements are equal to anObject."

	| tally |
	tally _ 0.
	self do: [:each | anObject = each ifTrue: [tally _ tally + 1]].
	^tally! !


!Collection methodsFor: '*Morphic-objectMenu' stamp: 'wiz 7/20/2004 13:06'!
asKnownNameMenu
	"Return a menu to select an element of the collection.  
	Menu uses the knownName or class name as only description of  
	element."
	| menu |
	menu := CustomMenu new.
	self
		do: [:m | menu
				add: (m knownName
						ifNil: [m class name asString])
				action: m].
	^ menu! !


!Collection methodsFor: '*packageinfo-base' stamp: 'ab 9/30/2002 19:26'!
gather: aBlock
	^ Array streamContents:
		[:stream |
		self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! !


!Collection methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:59'!
chooseOne: caption 
	"pops up a menu asking for one of the elements in the collection.
	If none is chosen, raises a ServiceCancelled notification"

	| m |
	m := MenuMorph entitled: caption.
	self do: 
			[:ea | 
			m 
				add: ea
				target: [:n | ^ n]
				selector: #value:
				argument: ea].
	m invokeModal.
	ServiceCancelled signal! !


!Collection methodsFor: 'private'!
emptyCheck

	self isEmpty ifTrue: [self errorEmptyCollection]! !

!Collection methodsFor: 'private'!
errorEmptyCollection

	self error: 'this collection is empty'! !

!Collection methodsFor: 'private'!
errorNoMatch

	self error: 'collection sizes do not match'! !

!Collection methodsFor: 'private' stamp: 'sma 5/12/2000 11:22'!
errorNotFound: anObject
	"Actually, this should raise a special Exception not just an error."

	self error: 'Object is not in the collection.'! !

!Collection methodsFor: 'private' stamp: 'yo 6/29/2004 13:14'!
errorNotKeyed

	self error: ('Instances of {1} do not respond to keyed accessing messages.' translated format: {self class name})
! !

!Collection methodsFor: 'private'!
toBraceStack: itsSize 
	"Push receiver's elements onto the stack of thisContext sender.  Error if receiver does
	 not have itsSize elements or if receiver is unordered.
	 Do not call directly: this is called by {a. b} _ ... constructs."

	self size ~= itsSize ifTrue:
		[self error: 'Trying to store ', self size printString,
					' values into ', itsSize printString, ' variables.'].
	thisContext sender push: itsSize fromIndexable: self! !

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

Collection class
	instanceVariableNames: ''!

!Collection class methodsFor: 'instance creation' stamp: 'apb 10/15/2000 22:05'!
ofSize: n
	"Create a new collection of size n with nil as its elements.
	This method exists because OrderedCollection new: n creates an
	empty collection,  not one of size n."
	^ self new: n! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 19:58'!
with: anObject 
	"Answer an instance of me containing anObject."

	^ self new
		add: anObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:01'!
with: firstObject with: secondObject 
	"Answer an instance of me containing the two arguments as elements."

	^ self new
		add: firstObject;
		add: secondObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:03'!
with: firstObject with: secondObject with: thirdObject 
	"Answer an instance of me containing the three arguments as elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'!
with: firstObject with: secondObject with: thirdObject with: fourthObject 
	"Answer an instance of me, containing the four arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
	"Answer an instance of me, containing the five arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		add: fifthObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject
	"Answer an instance of me, containing the six arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		add: fifthObject;
		add: sixthObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:07'!
withAll: aCollection
	"Create a new collection containing all the elements from aCollection."

	^ (self new: aCollection size)
		addAll: aCollection;
		yourself! !


!Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:07'!
initialize
	"Set up a Random number generator to be used by atRandom when the 
	user does not feel like creating his own Random generator."

	RandomForPicking _ Random new.
	MutexForPicking _ Semaphore forMutualExclusion! !

!Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:08'!
mutexForPicking
	^ MutexForPicking! !

!Collection class methodsFor: 'private' stamp: 'sma 5/12/2000 12:31'!
randomForPicking
	^ RandomForPicking! !
TestCase subclass: #CollectionTest
	instanceVariableNames: 'empty nonEmpty'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Abstract'!
!CollectionTest commentStamp: '<historical>' prior: 0!
A TestCase is a Command representing the future running of a test case. Create one with the class method #selector: aSymbol, passing the name of the method to be run when the test case runs.

When you discover a new fixture, subclass TestCase, declare instance variables for the objects in the fixture, override #setUp to initialize the variables, and possibly override# tearDown to deallocate any external resources allocated in #setUp.

When you are writing a test case method, send #assert: aBoolean when you want to check for an expected value. For example, you might say "self assert: socket isOpen" to test whether or not a socket is open at a point in a test.!


!CollectionTest methodsFor: 'initialize-release' stamp: 'st 10/7/2004 16:23'!
setUp
	empty := Set new.
	nonEmpty := OrderedCollection with: #x! !


!CollectionTest methodsFor: 'testing' stamp: 'fbs 1/14/2005 10:19'!
testAsCommaString
	{OrderedCollection new. Set new.} do:
		[ :coll |
		self assert: coll asCommaString = ''.

		coll add: 1.
		self assert: coll asCommaString = '1'.

		coll add: 2; add: 3.
		self assert: coll asCommaString = '1, 2, 3'].! !

!CollectionTest methodsFor: 'testing' stamp: 'fbs 1/14/2005 10:19'!
testAsCommaStringAnd
	{OrderedCollection new. Set new.} do:
		[ :coll |
		self assert: coll asCommaStringAnd = ''.

		coll add: 1.
		self assert: coll asCommaStringAnd = '1'.

		coll add: 2; add: 3.
		self assert: coll asCommaStringAnd = '1, 2 and 3'].! !

!CollectionTest methodsFor: 'testing' stamp: 'fbs 1/14/2005 10:33'!
testAsStringOnDelimiter
	| delim emptyStream oneItemStream multiItemStream |
	delim := ', '.
	{OrderedCollection new. Set new.} do:
		[ :coll |
		emptyStream := ReadWriteStream on: ''.
		coll asStringOn: emptyStream delimiter: delim.
		self assert: emptyStream contents = ''.

		coll add: 1.
		oneItemStream := ReadWriteStream on: ''.
		coll asStringOn: oneItemStream delimiter: delim.
		self assert: oneItemStream contents = '1'.

		coll add: 2; add: 3.
		multiItemStream := ReadWriteStream on: ''.
		coll asStringOn: multiItemStream delimiter: ', '.
		self assert: multiItemStream contents = '1, 2, 3'.]! !

!CollectionTest methodsFor: 'testing' stamp: 'fbs 1/14/2005 10:34'!
testAsStringOnDelimiterLast
	| delim emptyStream last oneItemStream multiItemStream |
	delim := ', '.
	last := ' & '.
	{OrderedCollection new. Set new.} do:
		[ :coll |
		emptyStream := ReadWriteStream on: ''.
		coll asStringOn: emptyStream delimiter: delim last: last.
		self assert: emptyStream contents = ''.

		coll add: 1.
		oneItemStream := ReadWriteStream on: ''.
		coll asStringOn: oneItemStream delimiter: delim last: last.
		self assert: oneItemStream contents = '1'.

		coll add: 2; add: 3.
		multiItemStream := ReadWriteStream on: ''.
		coll asStringOn: multiItemStream delimiter: ', ' last: last.
		self assert: multiItemStream contents = '1, 2 & 3'.]! !

!CollectionTest methodsFor: 'testing' stamp: 'fbs 1/14/2005 10:56'!
testPrintOnDelimiter
	| delim emptyStream oneItemStream multiItemStream |
	delim := ', '.
	{OrderedCollection new. Set new.} do:
		[ :coll |
		emptyStream := ReadWriteStream on: ''.
		coll printOn: emptyStream delimiter: delim.
		self assert: emptyStream contents = ''.

		coll add: 1.
		oneItemStream := ReadWriteStream on: ''.
		coll printOn: oneItemStream delimiter: delim.
		self assert: oneItemStream contents = '1'.

		coll add: 2; add: 3.
		multiItemStream := ReadWriteStream on: ''.
		coll printOn: multiItemStream delimiter: ', '.
		self assert: multiItemStream contents = '1'', ''2'', ''3'.]! !

!CollectionTest methodsFor: 'testing' stamp: 'fbs 1/14/2005 10:56'!
testPrintOnDelimiterLast
	| delim emptyStream last oneItemStream multiItemStream |
	delim := ', '.
	last := ' & '.
	{OrderedCollection new. Set new.} do:
		[ :coll |
		emptyStream := ReadWriteStream on: ''.
		coll printOn: emptyStream delimiter: delim last: last.
		self assert: emptyStream contents = ''.

		coll add: 1.
		oneItemStream := ReadWriteStream on: ''.
		coll printOn: oneItemStream delimiter: delim last: last.
		self assert: oneItemStream contents = '1'.

		coll add: 2; add: 3.
		multiItemStream := ReadWriteStream on: ''.
		coll printOn: multiItemStream delimiter: ', ' last: last.
		self assert: multiItemStream contents = '1'', ''2'' & ''3'.]! !


!CollectionTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:12'!
testIfEmptyifNotEmpty

	self assert: (empty ifEmpty: [true] ifNotEmpty: [false]).
	self assert: (nonEmpty ifEmpty: [false] ifNotEmpty: [true]).
	self assert: (nonEmpty ifEmpty: [false] ifNotEmpty: [:s | s first = #x])! !

!CollectionTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:12'!
testIfEmptyifNotEmptyDo

	self assert: (empty ifEmpty: [true] ifNotEmptyDo: [:s | false]).
	self assert: (nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | s first = #x])! !

!CollectionTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:12'!
testIfNotEmpty

	empty ifNotEmpty: [self assert: false].
	self assert: (nonEmpty ifNotEmpty: [self]) == self.
	self assert: (nonEmpty ifNotEmpty: [:s | s first]) = #x
! !

!CollectionTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:13'!
testIfNotEmptyDo

	empty ifNotEmptyDo: [:s | self assert: false].
	self assert: (nonEmpty ifNotEmptyDo: [:s | s first]) = #x
! !

!CollectionTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:13'!
testIfNotEmptyDoifNotEmpty

	self assert: (empty ifNotEmptyDo: [:s | false] ifEmpty: [true]).
	self assert: (nonEmpty ifNotEmptyDo: [:s | s first = #x] ifEmpty: [false])! !

!CollectionTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:13'!
testIfNotEmptyifEmpty

	self assert: (empty ifEmpty: [true] ifNotEmpty: [false]).
	self assert: (nonEmpty ifEmpty: [false] ifNotEmpty: [true]).
	self assert: (nonEmpty ifEmpty: [false] ifNotEmpty: [:s | s first = #x])! !
Object subclass: #Color
	instanceVariableNames: 'rgb cachedDepth cachedBitPattern'
	classVariableNames: 'Black Blue BlueShift Brown CachedColormaps ColorChart ColorNames ComponentMask ComponentMax Cyan DarkGray Gray GrayToIndexMap Green GreenShift HalfComponentMask HighLightBitmaps IndexedColors LightBlue LightBrown LightCyan LightGray LightGreen LightMagenta LightOrange LightRed LightYellow Magenta MaskingMap Orange PaleBlue PaleBuff PaleGreen PaleMagenta PaleOrange PalePeach PaleRed PaleTan PaleYellow PureBlue PureCyan PureGreen PureMagenta PureRed PureYellow RandomStream Red RedShift TranslucentPatterns Transparent VeryDarkGray VeryLightGray VeryPaleRed VeryVeryDarkGray VeryVeryLightGray White Yellow'
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Color commentStamp: '<historical>' prior: 0!
This class represents abstract color, regardless of the depth of bitmap it will be shown in.  At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with.  The supported depths (in bits) are 1, 2, 4, 8, 16, and 32.  The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million.  (See comment in BitBlt.)  To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8).  (See comment in DisplayMedium)
	Color is represented as the amount of light in red, green, and blue.  White is (1.0, 1.0, 1.0) and black is (0, 0, 0).  Pure red is (1.0, 0, 0).  These colors are "additive".  Think of Color's instance variables as:
	r	amount of red, a Float between 0.0 and 1.0.
	g	amount of green, a Float between 0.0 and 1.0.
	b	amount of blue, a Float between 0.0 and 1.0.
(But, in fact, the three are encoded as values from 0 to 1023 and combined in a single integer, rgb.  The user does not need to know this.)
	Many colors are named.  You find a color by name by sending a message to class Color, for example (Color lightBlue).  Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below)
	A color is essentially immutable.  Once you set red, green, and blue, you cannot change them.  Instead, create a new Color and use it.
	Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number.  Convert the range of this number to an integer from 1 to N.  Then call (Color green lightShades: N) to get an Array of colors from white to green.  Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array.  atPin: gives the first (or last) color if the index is out of range.  atWrap: wraps around to the other end if the index is out of range.
	Here are some fun things to run in when your screen has color:
		Pen new mandala: 30 diameter: Display height-100.
		Pen new web  "Draw with the mouse, opt-click to end"
		Display fillWhite.  Pen new hilberts: 5.
		Form toothpaste: 30  "Draw with mouse, opt-click to end"
You might also want to try the comment in
	Form>class>examples>tinyText...


Messages:
	mixed: proportion with: aColor	Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix.

	+ 	add two colors
	- 	subtract two colors
	*	multiply the values of r, g, b by a number or an Array of factors.  ((Color named: #white) * 0.3) gives a darkish gray.  (aColor * #(0 0 0.9)) gives a color with slightly less blue.
	/	divide a color by a factor or an array of three factors.

	errorForDepth: d     How close the nearest color at this depth is to this abstract color.  Sum of the squares of the RGB differences, square rooted and normalized to 1.0.  Multiply by 100 to get percent.

	hue			Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360.
	saturation	Returns the saturation of the color.  0.0 to 1.0
	brightness	Returns the brightness of the color.  0.0 to 1.0

	name    Look to see if this Color has a name.
	display	Show a swatch of this color tracking the cursor.

	lightShades: thisMany		An array of thisMany colors from white to the receiver. 
	darkShades: thisMany		An array of thisMany colors from black to the receiver.  Array is of length num.
	mix: color2 shades: thisMany		An array of thisMany colors from the receiver to color2.
	wheel: thisMany			An array of thisMany colors around the color wheel starting and ending at the receiver.

	pixelValueForDepth: d    Returns the bits that appear be in a Bitmap of this depth for this color.  Represents the nearest available color at this depth.  Normal users do not need to know which pixelValue is used for which color. 

Messages to Class Color.
	red: r green: g blue: b		Return a color with the given r, g, and b components.
	r: g: b:		Same as above, for fast typing.

 	hue: h saturation: s brightness: b		Create a color with the given hue, saturation, and brightness.

	pink
 	blue
	red ...	Many colors have messages that return an instance of Color.
	canUnderstand: #brown	  Returns true if #brown is a defined color.
	names		An OrderedCollection of the names of the colors.
	named: #notAllThatGray put: aColor    Add a new color to the list and create an access message and a class variable for it.
	fromUser	Shows the palette of colors available at this display depth.  Click anywhere to return the color you clicked on.

	hotColdShades: thisMany	An array of thisMany colors showing temperature from blue to red to white hot.

    stdColorsForDepth: d        An Array of colors available at this depth.  For 16 bit and 32 bits, returns a ColorGenerator.  It responds to at: with a Color for that index, simulating a very big Array. 

   colorFromPixelValue: value depth: d    Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified.  Normal users do not need to use this.

(See also comments in these classes: Form, Bitmap, BitBlt, Pattern, MaskedForm.)!


!Color methodsFor: 'access'!
alpha
	"Return the opacity ('alpha') value of opaque so that normal colors can be compared to TransparentColors."

	^ 1.0
! !

!Color methodsFor: 'access'!
blue
	"Return the blue component of this color, a float in the range [0.0..1.0]."

	^ self privateBlue asFloat / ComponentMax! !

!Color methodsFor: 'access'!
brightness
	"Return the brightness of this color, a float in the range [0.0..1.0]."

	^ ((self privateRed max:
	    self privateGreen) max:
	    self privateBlue) asFloat / ComponentMax! !

!Color methodsFor: 'access'!
green
	"Return the green component of this color, a float in the range [0.0..1.0]."

	^ self privateGreen asFloat / ComponentMax! !

!Color methodsFor: 'access'!
hue
	"Return the hue of this color, an angle in the range [0.0..360.0]."

	| r g b max min span h |
	r _ self privateRed.
	g _ self privateGreen.
	b _ self privateBlue. 

	max _ ((r max: g) max: b).
	min _ ((r min: g) min: b).
	span _ (max - min) asFloat.
	span = 0.0 ifTrue: [ ^ 0.0 ].

	r = max ifTrue: [
		h _ ((g - b) asFloat / span) * 60.0.
	] ifFalse: [
		g = max
			ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ]
			ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ].
	].

	h < 0.0 ifTrue: [ h _ 360.0 + h ].
	^ h! !

!Color methodsFor: 'access'!
luminance
	"Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity."

	^ ((299 * self privateRed) +
	   (587 * self privateGreen) +
	   (114 * self privateBlue)) / (1000 * ComponentMax)
! !

!Color methodsFor: 'access'!
red
	"Return the red component of this color, a float in the range [0.0..1.0]."

	^ self privateRed asFloat / ComponentMax! !

!Color methodsFor: 'access'!
saturation
	"Return the saturation of this color, a value between 0.0 and 1.0."

	| r g b max min |
	r _ self privateRed.
	g _ self privateGreen.
	b _ self privateBlue. 

	max _ min _ r.
	g > max ifTrue: [max _ g].
	b > max ifTrue: [max _ b].
	g < min ifTrue: [min _ g].
	b < min ifTrue: [min _ b].

	max = 0
		ifTrue: [ ^ 0.0 ]
		ifFalse: [ ^ (max - min) asFloat / max asFloat ].
! !


!Color methodsFor: 'conversions' stamp: 'ar 11/2/1998 12:19'!
asColor
	"Convert the receiver into a color"
	^self! !

!Color methodsFor: 'conversions' stamp: 'TBn 6/15/2000 20:37'!
asColorref
	"Convert the receiver into a colorref"
	^(self red * 255) asInteger + ((self green * 255) asInteger << 8) + ((self green * 255) asInteger << 16)! !

!Color methodsFor: 'conversions' stamp: 'st 9/27/2004 13:42'!
asHTMLColor
	^ '#', (self class hex: self red), (self class hex: self green), (self class hex: self blue)! !

!Color methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'!
asNontranslucentColor
	^ self! !

!Color methodsFor: 'conversions' stamp: 'di 3/25/2000 10:13'!
balancedPatternForDepth: depth
	"A generalization of bitPatternForDepth: as it exists.  Generates a 2x2 stipple of color.
	The topLeft and bottomRight pixel are closest approx to this color"
	| pv1 pv2 mask1 mask2 pv3 c |
	(depth == cachedDepth and:[cachedBitPattern size = 2]) ifTrue: [^ cachedBitPattern].
	(depth between: 4 and: 16) ifFalse: [^ self bitPatternForDepth: depth].
	cachedDepth _ depth.
	pv1 _ self pixelValueForDepth: depth.
"
	Subtract error due to pv1 to get pv2.
	pv2 _ (self - (err1 _ (Color colorFromPixelValue: pv1 depth: depth) - self))
						pixelValueForDepth: depth.
	Subtract error due to 2 pv1's and pv2 to get pv3.
	pv3 _ (self - err1 - err1 - ((Color colorFromPixelValue: pv2 depth: depth) - self))
						pixelValueForDepth: depth.
"
	"Above two statements computed faster by the following..."
	pv2 _ (c _ self - ((Color colorFromPixelValue: pv1 depth: depth) - self))
						pixelValueForDepth: depth.
	pv3 _ (c + (c - (Color colorFromPixelValue: pv2 depth: depth)))
						pixelValueForDepth: depth.

	"Return to a 2-word bitmap that encodes a 2x2 stipple of the given pixelValues."
	mask1 _ (#(- - -	
			16r01010101 - - -			"replicates every other 4 bits"
			16r00010001 - - - - - - -	"replicates every other 8 bits"
			16r00000001) at: depth).	"replicates every other 16 bits"
	mask2 _ (#(- - -	
			16r10101010 - - -			"replicates the other 4 bits"
			16r01000100 - - - - - - -	"replicates the other 8 bits"
			16r00010000) at: depth).	"replicates the other 16 bits"
	^ cachedBitPattern _ Bitmap with: (mask1*pv1) + (mask2*pv2) with: (mask1*pv3) + (mask2*pv1)! !

!Color methodsFor: 'conversions' stamp: 'hmm 4/25/2000 09:40'!
bitPatternForDepth: depth
	"Return a Bitmap, possibly containing a stipple pattern, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps. The resulting Bitmap may be multiple words to represent a stipple pattern of several lines.  "
	"See also:	pixelValueAtDepth:	-- value for single pixel
				pixelWordAtDepth:	-- a 32-bit word filled with the pixel value"
	"Details: The pattern for the most recently requested depth is cached."
	"Note for depths > 2, there are stippled and non-stippled versions (generated with #balancedPatternForDepth: and #bitPatternForDepth:, respectively). The stippled versions don't work with the window bit caching of StandardSystemView, so we make sure that for these depths, only unstippled patterns are returned"

	(depth == cachedDepth and: [depth <= 2 or: [cachedBitPattern size = 1]]) ifTrue: [^ cachedBitPattern].
	cachedDepth _ depth.

	depth > 2 ifTrue: [^ cachedBitPattern _ Bitmap with: (self pixelWordForDepth: depth)].
	depth = 1 ifTrue: [^ cachedBitPattern _ self halfTonePattern1].
	depth = 2 ifTrue: [^ cachedBitPattern _ self halfTonePattern2].
! !

!Color methodsFor: 'conversions'!
closestPixelValue1
	"Return the nearest approximation to this color for a monochrome Form."

	"fast special cases"
	rgb = 0 ifTrue: [^ 1].  "black"
	rgb = 16r3FFFFFFF ifTrue: [^ 0].  "white"

	self luminance > 0.5
		ifTrue: [^ 0]  "white"
		ifFalse: [^ 1].  "black"
! !

!Color methodsFor: 'conversions'!
closestPixelValue2
	"Return the nearest approximation to this color for a 2-bit deep Form."

	| lum |
	"fast special cases"
	rgb = 0 ifTrue: [^ 1].  "black"
	rgb = 16r3FFFFFFF ifTrue: [^ 2].  "opaque white"

	lum _ self luminance.
	lum < 0.2 ifTrue: [^ 1].  "black"
	lum > 0.6 ifTrue: [^ 2].  "opaque white"
	^ 3  "50% gray"
! !

!Color methodsFor: 'conversions'!
closestPixelValue4
	"Return the nearest approximation to this color for a 4-bit deep Form."

	| bIndex |
	"fast special cases"
	rgb = 0 ifTrue: [^ 1].  "black"
	rgb = 16r3FFFFFFF ifTrue: [^ 2].  "opaque white"

	rgb = PureRed privateRGB ifTrue: [^ 4].
	rgb = PureGreen privateRGB ifTrue: [^ 5].
	rgb = PureBlue privateRGB ifTrue: [^ 6].
	rgb = PureCyan privateRGB ifTrue: [^ 7].
	rgb = PureYellow privateRGB ifTrue: [^ 8].
	rgb = PureMagenta privateRGB ifTrue: [^ 9].

	bIndex _ (self luminance * 8.0) rounded.  "bIndex in [0..8]"
	^ #(
		1	"black"
		10	"1/8 gray"
		11	"2/8 gray"
		12	"3/8 gray"
		3	"4/8 gray"
		13	"5/8 gray"
		14	"6/8 gray"
		15	"7/8 gray"
		2	"opaque white"
	) at: bIndex + 1.
! !

!Color methodsFor: 'conversions'!
closestPixelValue8
	"Return the nearest approximation to this color for an 8-bit deep Form."

	"fast special cases"
	rgb = 0 ifTrue: [^ 1].  "black"
	rgb = 16r3FFFFFFF ifTrue: [^ 255].  "white"

	self saturation < 0.2 ifTrue: [
		^ GrayToIndexMap at: (self privateGreen >> 2) + 1.  "nearest gray"
	] ifFalse: [
		"compute nearest entry in the color cube"
		^ 40 +
		  ((((self privateRed * 5) + HalfComponentMask) // ComponentMask) * 36) +
		  ((((self privateBlue * 5) + HalfComponentMask) // ComponentMask) * 6) +
		  (((self privateGreen * 5) + HalfComponentMask) // ComponentMask)].
! !

!Color methodsFor: 'conversions' stamp: 'di 9/2/97 20:21'!
dominantColor
	^ self! !

!Color methodsFor: 'conversions' stamp: 'di 6/23/97 23:27'!
halfTonePattern1
	"Return a halftone-pattern to approximate luminance levels on 1-bit deep Forms."

	| lum |
	lum _ self luminance.
	lum < 0.1 ifTrue: [^ Bitmap with: 16rFFFFFFFF]. "black"
	lum < 0.4 ifTrue: [^ Bitmap with: 16rBBBBBBBB with: 16rEEEEEEEE]. "dark gray"
	lum < 0.6 ifTrue: [^ Bitmap with: 16r55555555 with: 16rAAAAAAAA]. "medium gray"
	lum < 0.9 ifTrue: [^ Bitmap with: 16r44444444 with: 16r11111111]. "light gray"
	^ Bitmap with: 0  "1-bit white"
! !

!Color methodsFor: 'conversions'!
halfTonePattern2
	"Return a halftone-pattern to approximate luminance levels on 2-bit deep Forms."

	| lum |
	lum _ self luminance.
	lum < 0.125 ifTrue: [^ Bitmap with: 16r55555555].  "black"
	lum < 0.25 ifTrue: [^ Bitmap with: 16r55555555 with: 16rDDDDDDDD].  "1/8 gray"
	lum < 0.375 ifTrue: [^ Bitmap with: 16rDDDDDDDD with: 16r77777777].  "2/8 gray"
	lum < 0.5 ifTrue: [^ Bitmap with: 16rFFFFFFFF with: 16r77777777].  "3/8 gray"
	lum < 0.625 ifTrue: [^ Bitmap with: 16rFFFFFFFF].  "4/8 gray"
	lum < 0.75 ifTrue: [^ Bitmap with: 16rFFFFFFFF with: 16rBBBBBBBB].  "5/8 gray"
	lum < 0.875 ifTrue: [^ Bitmap with: 16rEEEEEEEE with: 16rBBBBBBBB].  "6/8 gray"
	lum < 1.0 ifTrue: [^ Bitmap with: 16rAAAAAAAA with: 16rBBBBBBBB].  "7/8 gray"
	^ Bitmap with: 16rAAAAAAAA  "opaque white"

"handy expression for computing patterns for 2x2 tiles;
 set p to a string of 4 letters (e.g., 'wggw' for a gray-and-
 white checkerboard) and print the result of evaluating:
| p d w1 w2 |
p _ 'wggw'.
d _ Dictionary new.
d at: $b put: '01'.
d at: $w put: '10'.
d at: $g put: '11'.
w1 _ (d at: (p at: 1)), (d at: (p at: 2)).
w1 _ '2r', w1, w1, w1, w1, w1, w1, w1, w1, ' hex'.
w2 _ (d at: (p at: 3)), (d at: (p at: 4)).
w2 _ '2r', w2, w2, w2, w2, w2, w2, w2, w2, ' hex'.
Array with: (Compiler evaluate: w1) with: (Compiler evaluate: w2) 
"! !

!Color methodsFor: 'conversions' stamp: 'tk 4/24/97'!
indexInMap: aColorMap
	"Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap.  "

	aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1].
	aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1].
	aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1].
	aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1].
	aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1].
	aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1].
	aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 16) + 1].
	self error: 'unknown pixel depth'.
! !

!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25'!
makeForegroundColor
        "Make a foreground color contrasting with me"
        ^self luminance >= 0.5
                ifTrue: [Color black]
                ifFalse: [Color white]! !

!Color methodsFor: 'conversions' stamp: 'ar 5/15/2001 16:12'!
pixelValue32
	"Note: pixelWord not pixelValue so we include translucency"
	^self pixelWordForDepth: 32! !

!Color methodsFor: 'conversions' stamp: 'jm 1/26/2001 15:11'!
pixelValueForDepth: d
	"Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:"
	"Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component."
	"Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue."

	| rgbBlack val |
	d = 8 ifTrue: [^ self closestPixelValue8].  "common case"
	d < 8 ifTrue: [
		d = 4 ifTrue: [^ self closestPixelValue4].
		d = 2 ifTrue: [^ self closestPixelValue2].
		d = 1 ifTrue: [^ self closestPixelValue1]].

	rgbBlack _ 1.  "closest black that is not transparent in RGB"

	d = 16 ifTrue: [
		"five bits per component; top bits ignored"
		val _ (((rgb bitShift: -15) bitAnd: 16r7C00) bitOr:
			 ((rgb bitShift: -10) bitAnd: 16r03E0)) bitOr:
			 ((rgb bitShift: -5) bitAnd: 16r001F).
		^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

	d = 32 ifTrue: [
		"eight bits per component; top 8 bits set to all ones (opaque alpha)"
		val _ LargePositiveInteger new: 4.
		val at: 3 put: ((rgb bitShift: -22) bitAnd: 16rFF).
		val at: 2 put: ((rgb bitShift: -12) bitAnd: 16rFF).
		val at: 1 put: ((rgb bitShift: -2) bitAnd: 16rFF).
		val = 0 ifTrue: [val at: 1 put: 1].  "closest non-transparent black"
		val at: 4 put: 16rFF.  "opaque alpha"
		^ val].

	d = 12 ifTrue: [  "for indexing a color map with 4 bits per color component"
		val _ (((rgb bitShift: -18) bitAnd: 16r0F00) bitOr:
			 ((rgb bitShift: -12) bitAnd: 16r00F0)) bitOr:
			 ((rgb bitShift: -6) bitAnd: 16r000F).
		^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

	d = 9 ifTrue: [  "for indexing a color map with 3 bits per color component"
		val _ (((rgb bitShift: -21) bitAnd: 16r01C0) bitOr:
			 ((rgb bitShift: -14) bitAnd: 16r0038)) bitOr:
			 ((rgb bitShift: -7) bitAnd: 16r0007).
		^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

	self error: 'unknown pixel depth: ', d printString
! !

!Color methodsFor: 'conversions' stamp: 'di 11/30/1998 09:03'!
pixelWordFor: depth filledWith: pixelValue
	"Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."
	| halfword |
	depth = 32 ifTrue: [^ pixelValue].
	depth = 16
		ifTrue: [halfword _ pixelValue]
		ifFalse: [halfword _ pixelValue * 
					(#(16rFFFF				"replicates at every bit"
						16r5555 -			"replicates every 2 bits"
						16r1111 - - -			"replicates every 4 bits"
						16r0101) at: depth)	"replicates every 8 bits"].
	^ halfword bitOr: (halfword bitShift: 16)! !

!Color methodsFor: 'conversions'!
pixelWordForDepth: depth
	"Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."

	| pixelValue |
	pixelValue _ self pixelValueForDepth: depth.
	^ self pixelWordFor: depth filledWith: pixelValue
! !

!Color methodsFor: 'conversions' stamp: 'ar 1/14/1999 15:28'!
scaledPixelValue32
	"Return the alpha scaled pixel value for depth 32"
	^self pixelWordForDepth: 32! !


!Color methodsFor: 'copying' stamp: 'tk 8/19/1998 16:12'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."! !


!Color methodsFor: 'equality' stamp: 'di 1/6/1999 20:26'!
= aColor
	"Return true if the receiver equals the given color. This method handles TranslucentColors, too."

	aColor isColor ifFalse: [^ false].
	^ aColor privateRGB = rgb and:
		[aColor privateAlpha = self privateAlpha]
! !

!Color methodsFor: 'equality' stamp: 'di 9/27/2000 08:07'!
diff: theOther
	"Returns a number between 0.0 and 1.0"

	^ ((self privateRed - theOther privateRed) abs
		+ (self privateGreen - theOther privateGreen) abs
		+ (self privateBlue - theOther privateBlue) abs)
		/ 3.0 / ComponentMax! !

!Color methodsFor: 'equality'!
hash

	^ rgb! !


!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
darkShades: thisMany
	"An array of thisMany colors from black to the receiver.  Array is of length num. Very useful for displaying color based on a variable in your program.  "
	"Color showColors: (Color red darkShades: 12)"

	^ self class black mix: self shades: thisMany
! !

!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
lightShades: thisMany
	"An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program.  "
	"Color showColors: (Color red lightShades: 12)"

	^ self class white mix: self shades: thisMany
! !

!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
mix: color2 shades: thisMany
	"Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program.  "
	"Color showColors: (Color red mix: Color green shades: 12)"

	| redInc greenInc blueInc rr gg bb c out |
	thisMany = 1 ifTrue: [^ Array with: color2].
	redInc _ color2 red - self red / (thisMany-1).
	greenInc _ color2 green - self green / (thisMany-1).
	blueInc _ color2 blue - self blue / (thisMany-1).
	rr _ self red.  gg _ self green.  bb _ self blue.
	out _ (1 to: thisMany) collect: [:num |
		c _ Color r: rr g: gg b: bb.
		rr _ rr + redInc.
		gg _ gg + greenInc.
		bb _ bb + blueInc.
		c].
	out at: out size put: color2.	"hide roundoff errors"
	^ out
! !

!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45'!
wheel: thisMany
	"An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self.  Array is of length thisMany.  Very useful for displaying color based on a variable in your program.  "

	| sat bri hue step c |
	sat _ self saturation.
	bri _ self brightness.
	hue _ self hue.
	step _ 360.0 / (thisMany max: 1).
	^ (1 to: thisMany) collect: [:num |
		c _ Color h: hue s: sat v: bri.  "hue is taken mod 360"
		hue _ hue + step.
		c].
"
(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c]
"! !


!Color methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 12:10'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'change color...' translated target: self selector: #changeColorIn:event: argument: aMorph! !

!Color methodsFor: 'Morphic menu' stamp: 'ar 10/5/2000 18:50'!
changeColorIn: aMorph event: evt
	"Note: This is just a workaround to make sure we don't use the old color inst var"
	aMorph changeColorTarget: aMorph selector: #fillStyle: originalColor: self hand: evt hand! !


!Color methodsFor: 'other' stamp: 'sw 2/16/98 03:42'!
colorForInsets
	^ self! !

!Color methodsFor: 'other' stamp: 'tk 6/14/96'!
display
	"Show a swatch of this color tracking the cursor until the next mouseClick. "
	"Color red display"
	| f |
	f _ Form extent: 40@20 depth: Display depth.
	f fillColor: self.
	Cursor blank showWhile:
		[f follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]! !

!Color methodsFor: 'other' stamp: 'jm 12/4/97 10:24'!
name
	"Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color."

	ColorNames do:
		[:name | (Color perform: name) = self ifTrue: [^ name]].
	^ nil
! !

!Color methodsFor: 'other' stamp: 'ar 8/16/2001 12:47'!
raisedColor
	^ self! !

!Color methodsFor: 'other' stamp: 'jm 12/4/97 10:27'!
rgbTriplet
	"Color fromUser rgbTriplet"

	^ Array
		with: (self red roundTo: 0.01)
		with: (self green roundTo: 0.01)
		with: (self blue roundTo: 0.01)
! !


!Color methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:14'!
byteEncode: aStream

	aStream
		print: '(';
		print: self class name;
		print: ' r: ';
		write: (self red roundTo: 0.001);
		print: ' g: ';
		write: (self green roundTo: 0.001);
		print: ' b: ';
		write: (self blue roundTo: 0.001) ;
		print: ')'.
! !

!Color methodsFor: 'printing' stamp: 'bf 5/25/2000 16:52'!
printOn: aStream
	| name |
	(name _ self name) ifNotNil:
		[^ aStream
			nextPutAll: 'Color ';
			nextPutAll: name].
	self storeOn: aStream.
! !

!Color methodsFor: 'printing'!
shortPrintString
	"Return a short (but less precise) print string for use where space is tight."

	| s |
	s _ WriteStream on: ''.
	s
		nextPutAll: '(' , self class name;
		nextPutAll: ' r: ';
		nextPutAll: (self red roundTo: 0.01) printString;
		nextPutAll: ' g: ';
		nextPutAll: (self green roundTo: 0.01) printString;
		nextPutAll: ' b: ';
		nextPutAll: (self blue roundTo: 0.01) printString;
		nextPutAll: ')'.
	^ s contents
! !

!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'!
storeArrayOn: aStream

	aStream nextPutAll: '#('.
	self storeArrayValuesOn: aStream.
	aStream nextPutAll: ') '
! !

!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'!
storeArrayValuesOn: aStream

	(self red roundTo: 0.001) storeOn: aStream.
	aStream space.
	(self green roundTo: 0.001) storeOn: aStream.
	aStream space.
	(self blue roundTo: 0.001) storeOn: aStream.

! !

!Color methodsFor: 'printing' stamp: 'di 9/27/2000 13:34'!
storeOn: aStream

	aStream
		nextPutAll: '(' , self class name;
		nextPutAll: ' r: '; print: (self red roundTo: 0.001);
		nextPutAll: ' g: '; print: (self green roundTo: 0.001);
		nextPutAll: ' b: '; print: (self blue roundTo: 0.001);
		nextPutAll: ')'.
! !


!Color methodsFor: 'queries' stamp: 'sw 9/27/2001 17:26'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	^ #Color! !

!Color methodsFor: 'queries' stamp: 'ar 1/14/1999 15:27'!
isBitmapFill
	^false! !

!Color methodsFor: 'queries' stamp: 'ar 11/12/1998 19:43'!
isBlack
	"Return true if the receiver represents black"
	^rgb = 0! !

!Color methodsFor: 'queries'!
isColor

	^ true
! !

!Color methodsFor: 'queries' stamp: 'ar 6/18/1999 06:58'!
isGradientFill
	^false! !

!Color methodsFor: 'queries' stamp: 'ar 11/12/1998 19:44'!
isGray
	"Return true if the receiver represents a shade of gray"
	^(self privateRed = self privateGreen) and:[self privateRed = self privateBlue]! !

!Color methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'!
isOpaque
	^true! !

!Color methodsFor: 'queries' stamp: 'ar 6/18/1999 07:57'!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^false! !

!Color methodsFor: 'queries' stamp: 'ar 11/7/1998 20:20'!
isSolidFill
	^true! !

!Color methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'!
isTranslucent

	^ false
! !

!Color methodsFor: 'queries' stamp: 'di 1/3/1999 12:23'!
isTranslucentColor
	"This means: self isTranslucent, but isTransparent not"
	^ false! !

!Color methodsFor: 'queries'!
isTransparent

	^ false
! !


!Color methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:46'!
isSelfEvaluating
	^ self class == Color! !


!Color methodsFor: 'transformations' stamp: 'fbs 2/3/2005 13:09'!
* aNumberOrArray
	"Answer this color with its RGB multiplied by the given number, or
	 multiply this color's RGB values by the corresponding entries in the
	given array."
	"(Color brown * 2) display"
	"(Color brown * #(1 0 1)) display"
	| multipliers |
	multipliers := aNumberOrArray isCollection
		ifTrue: [aNumberOrArray]
		ifFalse:
			[Array
				with: aNumberOrArray
				with: aNumberOrArray
				with: aNumberOrArray].

	^ Color basicNew
		setPrivateRed: (self privateRed * multipliers first) asInteger
		green: (self privateGreen * multipliers second) asInteger
		blue: (self privateBlue * multipliers third) asInteger.! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'!
+ aColor
	"Answer this color mixed with the given color in an additive color space.  "
	"(Color blue + Color green) display"

	^ Color basicNew
		setPrivateRed: self privateRed + aColor privateRed
		green: self privateGreen + aColor privateGreen
		blue: self privateBlue + aColor  privateBlue
! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'!
- aColor
	"Answer aColor is subtracted from the given color in an additive color space.  "
	"(Color white - Color red) display"

	^ Color basicNew
		setPrivateRed: self privateRed - aColor privateRed
		green: self privateGreen - aColor privateGreen
		blue: self privateBlue - aColor  privateBlue
! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:07'!
/ aNumber
	"Answer this color with its RGB divided by the given number. "
	"(Color red / 2) display"

	^ Color basicNew
		setPrivateRed: (self privateRed / aNumber) asInteger
		green: (self privateGreen / aNumber) asInteger
		blue: (self privateBlue / aNumber) asInteger
! !

!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50'!
adjustBrightness: brightness
	"Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)"

	^ Color
		h: self hue
		s: self saturation
		v: (self brightness + brightness min: 1.0 max: 0.005)
		alpha: self alpha! !

!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51'!
adjustSaturation: saturation brightness: brightness
	"Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)"

	^ Color
		h: self hue
		s: (self saturation + saturation min: 1.0 max: 0.005)
		v: (self brightness + brightness min: 1.0 max: 0.005)
		alpha: self alpha! !

!Color methodsFor: 'transformations' stamp: 'sma 6/25/2000 15:36'!
alpha: alphaValue 
	"Answer a new Color with the given amount of opacity ('alpha')."

	alphaValue = 1.0
		ifFalse: [^ TranslucentColor basicNew setRgb: rgb alpha: alphaValue]! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 11:55'!
alphaMixed: proportion with: aColor 
	"Answer this color mixed with the given color. The proportion, a number 
	between 0.0 and 1.0, determines what what fraction of the receiver to  
	use in the mix. For example, 0.9 would yield a color close to the  
	receiver. This method uses RGB interpolation; HSV interpolation can lead 
	to surprises.  Mixes the alphas (for transparency) also."

	| frac1 frac2 |
	frac1 _ proportion asFloat min: 1.0 max: 0.0.
	frac2 _ 1.0 - frac1.
	^ Color
		r: self red * frac1 + (aColor red * frac2)
		g: self green * frac1 + (aColor green * frac2)
		b: self blue * frac1 + (aColor blue * frac2)
		alpha: self alpha * frac1 + (aColor alpha * frac2)! !

!Color methodsFor: 'transformations' stamp: 'RAA 6/2/2000 08:47'!
atLeastAsLuminentAs: aFloat

	| revisedColor |
	revisedColor _ self.
	[revisedColor luminance < aFloat] whileTrue: [revisedColor _ revisedColor slightlyLighter].
	^revisedColor
! !

!Color methodsFor: 'transformations' stamp: 'nk 3/8/2004 09:43'!
atMostAsLuminentAs: aFloat

	| revisedColor |
	revisedColor _ self.
	[revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker].
	^revisedColor
! !

!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'!
blacker

	^ self alphaMixed: 0.8333 with: Color black
! !

!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54'!
dansDarker
	"Return a darker shade of the same color.
	An attempt to do better than the current darker method.
	(now obsolete, since darker has been changed to do this. -dew)"
	^ Color h: self hue s: self saturation
		v: (self brightness - 0.16 max: 0.0)! !

!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:40'!
darker
	"Answer a darker shade of this color."

	^ self adjustBrightness: -0.08! !

!Color methodsFor: 'transformations' stamp: 'dew 3/8/2002 00:13'!
duller

	^ self adjustSaturation: -0.03 brightness: -0.2! !

!Color methodsFor: 'transformations' stamp: 'dew 1/23/2002 20:19'!
lighter
	"Answer a lighter shade of this color."

	^ self adjustSaturation: -0.03 brightness: 0.08! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:00'!
mixed: proportion with: aColor 
	"Mix with another color and do not preserve transpareny.  Only use this for extracting the RGB value and mixing it.  All other callers should use instead: 
	aColor alphaMixed: proportion with: anotherColor
	"

	| frac1 frac2 |
	frac1 _ proportion asFloat min: 1.0 max: 0.0.
	frac2 _ 1.0 - frac1.
	^ Color
		r: self red * frac1 + (aColor red * frac2)
		g: self green * frac1 + (aColor green * frac2)
		b: self blue * frac1 + (aColor blue * frac2)! !

!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29'!
muchDarker

	^ self alphaMixed: 0.5 with: Color black
! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
muchLighter

	^ self alphaMixed: 0.233 with: Color white
! !

!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36'!
negated
	"Return an RGB inverted color"
	^Color
		r: 1.0 - self red
		g: 1.0 - self green
		b: 1.0 - self blue! !

!Color methodsFor: 'transformations' stamp: 'di 9/27/2000 08:14'!
orColorUnlike: theOther
	"If this color is a lot like theOther, then return its complement, otherwide, return self"

	(self diff: theOther) < 0.3
		ifTrue: [^ theOther negated]
		ifFalse: [^ self]! !

!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:42'!
paler
	"Answer a paler shade of this color."

	^ self adjustSaturation: -0.09 brightness: 0.09
! !

!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'!
slightlyDarker

	^ self adjustBrightness: -0.03
! !

!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'!
slightlyLighter

	^ self adjustSaturation: -0.01 brightness: 0.03! !

!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25'!
slightlyWhiter

	^ self alphaMixed: 0.85 with: Color white
! !

!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:44'!
twiceDarker
	"Answer a significantly darker shade of this color."

	^ self adjustBrightness: -0.15! !

!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:45'!
twiceLighter
	"Answer a significantly lighter shade of this color."

	^ self adjustSaturation: -0.06 brightness: 0.15! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
veryMuchLighter

	^ self alphaMixed: 0.1165 with: Color white
! !

!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'!
whiter

	^ self alphaMixed: 0.8333 with: Color white
! !


!Color methodsFor: '*eToys-other' stamp: 'sw 6/10/1998 17:50'!
newTileMorphRepresentative
	^ ColorTileMorph new colorSwatchColor: self! !


!Color methodsFor: '*MorphicExtras-*morphic-Postscript Canvases'!
encodePostscriptOn: aStream

	aStream setrgbcolor:self.

! !


!Color methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'RAA 7/31/2000 17:25'!
encodeForRemoteCanvas

	| encoded |

	CanvasEncoder at: 4 count:  1.
	(encoded := String new: 12)
		putInteger32: (rgb bitAnd: 16rFFFF) at: 1;
		putInteger32: (rgb >> 16) at: 5;
		putInteger32: self privateAlpha at: 9.
	^encoded! !


!Color methodsFor: 'private'!
attemptToMutateError
	"A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it."

	self error: 'Color objects are immutable once created'
! !

!Color methodsFor: 'private'!
flushCache
	"Flush my cached bit pattern."

	cachedDepth _ nil.
	cachedBitPattern _ nil.
! !

!Color methodsFor: 'private'!
privateAlpha
	"Private!! Return the raw alpha value for opaque. Used only for equality testing."

	^ 255! !

!Color methodsFor: 'private'!
privateBlue
	"Private!! Return the internal representation of my blue component."

	^ rgb bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
privateGreen
	"Private!! Return the internal representation of my green component.
	Replaced >> by bitShift: 0 -. SqR!! 2/25/1999 23:08"

	^ (rgb bitShift: 0 - GreenShift) bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
privateRGB
	"Private!! Return the internal representation of my RGB components."

	^ rgb
! !

!Color methodsFor: 'private'!
privateRed
	"Private!! Return the internal representation of my red component."

	^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
setHue: hue saturation: saturation brightness: brightness
	"Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details."

	| s v hf i f p q t | 
	s _ (saturation asFloat max: 0.0) min: 1.0.
	v _ (brightness asFloat max: 0.0) min: 1.0.

	"zero saturation yields gray with the given brightness"
	s = 0.0 ifTrue: [ ^ self setRed: v green: v blue: v ].

	hf _ hue asFloat.
	(hf < 0.0 or: [hf >= 360.0])
		ifTrue: [hf _ hf - ((hf quo: 360.0) asFloat * 360.0)].
	hf _ hf / 60.0.
	i _ hf asInteger.  "integer part of hue"
	f _ hf fractionPart.         "fractional part of hue"
	p _ (1.0 - s) * v.
	q _ (1.0 - (s * f)) * v.
	t _ (1.0 - (s * (1.0 - f))) * v.

	0 = i ifTrue: [ ^ self setRed: v green: t blue: p ].
	1 = i ifTrue: [ ^ self setRed: q green: v blue: p ].
	2 = i ifTrue: [ ^ self setRed: p green: v blue: t ].
	3 = i ifTrue: [ ^ self setRed: p green: q blue: v ].
	4 = i ifTrue: [ ^ self setRed: t green: p blue: v ].
	5 = i ifTrue: [ ^ self setRed: v green: p blue: q ].

	self error: 'implementation error'.
! !

!Color methodsFor: 'private' stamp: 'di 11/2/97 12:19'!
setPrivateRed: r green: g blue: b
	"Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax].  Encoded in a single variable as 3 integers in [0..1023]."

	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _ ((r min: ComponentMask max: 0) bitShift: RedShift) +
		((g min: ComponentMask max: 0) bitShift: GreenShift) +
		 (b min: ComponentMask max: 0).
	cachedDepth _ nil.
	cachedBitPattern _ nil.
! !

!Color methodsFor: 'private' stamp: 'ls 9/24/1999 20:04'!
setRGB: rgb0
	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _ rgb0! !

!Color methodsFor: 'private'!
setRed: r green: g blue: b
	"Initialize this color's r, g, and b components to the given values in the range [0.0..1.0].  Encoded in a single variable as 3 integers in [0..1023]."

	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _
		(((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) +
		(((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) +
		 ((b * ComponentMax) rounded bitAnd: ComponentMask).
	cachedDepth _ nil.
	cachedBitPattern _ nil.
! !

!Color methodsFor: 'private'!
setRed: r green: g blue: b range: range
	"Initialize this color's r, g, and b components to the given values in the range [0..r]."

	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _
		((((r * ComponentMask) // range) bitAnd: ComponentMask) bitShift: RedShift) +
		((((g * ComponentMask) // range) bitAnd: ComponentMask) bitShift: GreenShift) +
		 (((b * ComponentMask) // range) bitAnd: ComponentMask).
	cachedDepth _ nil.
	cachedBitPattern _ nil.
! !



!Color methodsFor: 'html' stamp: 'ms 6/14/2006 11:18'!
printHtmlString
	"answer a string whose characters are the html representation  
	of the receiver"
	^ (self red * 255) asInteger printStringHex , (self green * 255) asInteger printStringHex , (self blue * 255) asInteger printStringHex! !


!Color methodsFor: '*Morphic' stamp: 'ar 7/8/2006 21:00'!
iconOrThumbnailOfSize: aNumberOrPoint 
	"Answer an appropiate form to represent the receiver"
	| form |
	form := Form extent: aNumberOrPoint asPoint asPoint depth: 32.
	form fillColor: self.
	^ form! !

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

Color class
	instanceVariableNames: ''!

!Color class methodsFor: 'class initialization'!
initialize
	"Color initialize"

	"Details: Externally, the red, green, and blue components of color
	are floats in the range [0.0..1.0]. Internally, they are represented
	as integers in the range [0..ComponentMask] packing into a
	small integer to save space and to allow fast hashing and
	equality testing.

	For a general description of color representations for computer
	graphics, including the relationship between the RGB and HSV
	color models used here, see Chapter 17 of Foley and van Dam,
	Fundamentals of Interactive Computer Graphics, Addison-Wesley,
	1982."

	ComponentMask _ 1023.
	HalfComponentMask _ 512.  "used to round up in integer calculations"
	ComponentMax _ 1023.0.  "a Float used to normalize components"
	RedShift _ 20.
	GreenShift _ 10.
	BlueShift _ 0.

	PureRed		 _ self r: 1 g: 0 b: 0.
	PureGreen	 _ self r: 0 g: 1 b: 0.
	PureBlue	 _ self r: 0 g: 0 b: 1.
	PureYellow	 _ self r: 1 g: 1 b: 0.
	PureCyan	 _ self r: 0 g: 1 b: 1.
	PureMagenta _ self r: 1 g: 0 b: 1.

	RandomStream _ Random new.

	self initializeIndexedColors.
	self initializeGrayToIndexMap.
	self initializeNames.
	self initializeHighLights.
! !

!Color class methodsFor: 'class initialization'!
initializeGrayToIndexMap
	"Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level."
	"Note: This method must be called after initializeIndexedColors, since it uses IndexedColors."
	"Color initializeGrayToIndexMap"

	| grayLevels grayIndices c distToClosest dist indexOfClosest |
	"record the level and index of each gray in the 8-bit color table"
	grayLevels _ OrderedCollection new.
	grayIndices _ OrderedCollection new.
	"Note: skip the first entry, which is reserved for transparent"
	2 to: IndexedColors size do: [:i |
		c _ IndexedColors at: i.
		c saturation = 0.0 ifTrue: [  "c is a gray"
			grayLevels add: (c privateBlue) >> 2.  "top 8 bits; R, G, and B are the same"
			grayIndices add: i - 1]].  "pixel values are zero-based"
	grayLevels _ grayLevels asArray.
	grayIndices _ grayIndices asArray.

	"for each gray level in [0..255], select the closest match"
	GrayToIndexMap _ ByteArray new: 256.
	0 to: 255 do: [:level |
		distToClosest _ 10000.  "greater than distance to any real gray"
		1 to: grayLevels size do: [:i |
			dist _ (level - (grayLevels at: i)) abs.
			dist < distToClosest ifTrue: [
				distToClosest _ dist.
				indexOfClosest _ grayIndices at: i]].
		GrayToIndexMap at: (level + 1) put: indexOfClosest].
! !

!Color class methodsFor: 'class initialization' stamp: 'tk 6/22/96'!
initializeHighLights
	"Create a set of Bitmaps for quickly reversing areas of the screen without converting colors. "
	"Color initializeHighLights"

	| t |
	t _ Array new: 32.
	t at: 1 put: (Bitmap with: 16rFFFFFFFF).
	t at: 2 put: (Bitmap with: 16rFFFFFFFF).
	t at: 4 put: (Bitmap with: 16r55555555).
	t at: 8 put: (Bitmap with: 16r7070707).
	t at: 16 put: (Bitmap with: 16rFFFFFFFF).
	t at: 32 put: (Bitmap with: 16rFFFFFFFF).
	HighLightBitmaps _ t.
! !

!Color class methodsFor: 'class initialization'!
initializeIndexedColors
	"Build an array of colors corresponding to the fixed colormap used
	 for display depths of 1, 2, 4, or 8 bits."
	"Color initializeIndexedColors"

	| a index grayVal |
	a _ Array new: 256.

	"1-bit colors (monochrome)"
	a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0).		"white or transparent"
	a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0).	"black"

	"additional colors for 2-bit color"
	a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0).	"opaque white"
	a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5).	"1/2 gray"

	"additional colors for 4-bit color"
	a at:  5 put: (Color r: 1.0 g: 0.0 b: 0.0).	"red"
	a at:  6 put: (Color r: 0.0 g: 1.0 b: 0.0).	"green"
	a at:  7 put: (Color r: 0.0 g: 0.0 b: 1.0).	"blue"
	a at:  8 put: (Color r: 0.0 g: 1.0 b: 1.0).	"cyan"
	a at:  9 put: (Color r: 1.0 g: 1.0 b: 0.0).	"yellow"
	a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0).	"magenta"

	a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125).		"1/8 gray"
	a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25).		"2/8 gray"
	a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375).		"3/8 gray"
	a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625).		"5/8 gray"
	a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75).		"6/8 gray"
	a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875).		"7/8 gray"

	"additional colors for 8-bit color"
	"24 more shades of gray (1/32 increments but not repeating 1/8 increments)"
	index _ 17.
	1 to: 31 do: [:v |
		(v \\ 4) = 0 ifFalse: [
			grayVal _ v / 32.0.
			a at: index put: (Color r: grayVal g: grayVal b: grayVal).
			index _ index + 1]].

	"The remainder of color table defines a color cube with six steps
	 for each primary color. Note that the corners of this cube repeat
	 previous colors, but this simplifies the mapping between RGB colors
	 and color map indices. This color cube spans indices 40 through 255
	 (indices 41-256 in this 1-based array)."
	0 to: 5 do: [:r |
		0 to: 5 do: [:g |
			0 to: 5 do: [:b |
				index _ 41 + ((36 * r) + (6 * b) + g).
				index > 256 ifTrue: [
					self error: 'index out of range in color table compuation'].
				a at: index put: (Color r: r g: g b: b range: 5)]]].

	IndexedColors _ a.
! !

!Color class methodsFor: 'class initialization' stamp: 'dwh 7/7/1999 23:57'!
initializeNames
	"Name some colors."
	"Color initializeNames"

	ColorNames _ OrderedCollection new.
	self named: #black put: (Color r: 0 g: 0 b: 0).
	self named: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125).
	self named: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25).
	self named: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375).
	self named: #gray put: (Color r: 0.5 g: 0.5 b: 0.5).
	self named: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625).
	self named: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75).
	self named: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875).
	self named: #white put: (Color r: 1.0 g: 1.0 b: 1.0).
	self named: #red put: (Color r: 1.0 g: 0 b: 0).
	self named: #yellow put: (Color r: 1.0 g: 1.0 b: 0).
	self named: #green put: (Color r: 0 g: 1.0 b: 0).
	self named: #cyan put: (Color r: 0 g: 1.0 b: 1.0).
	self named: #blue put: (Color r: 0 g: 0 b: 1.0).
	self named: #magenta put: (Color r: 1.0 g: 0 b: 1.0).
	self named: #brown put: (Color r: 0.6 g: 0.2 b: 0).
	self named: #orange put: (Color r: 1.0 g: 0.6 b: 0).
	self named: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8).
	self named: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8).
	self named: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6).
	self named: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0).
	self named: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0).
	self named: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0).
	self named: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2).
	self named: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4).
	self named: #transparent put: (TranslucentColor new alpha: 0.0).
	self named: #paleBuff put: (Color r: 254 g: 250 b: 235 range: 255).
	self named: #paleBlue put: (Color r: 222 g: 249 b: 254 range: 255).
	self named: #paleYellow put: (Color r: 255 g: 255 b: 217 range: 255).
	self named: #paleGreen put: (Color r: 223 g: 255 b: 213 range: 255).
	self named: #paleRed put: (Color r: 255 g: 230 b: 230 range: 255).
	self named: #veryPaleRed put: (Color r: 255 g: 242 b: 242 range: 255).
	self named: #paleTan put: (Color r: 235 g: 224 b: 199 range: 255).
	self named: #paleMagenta put: (Color r: 255 g: 230 b: 255 range: 255).
	self named: #paleOrange put: (Color r: 253 g: 237 b: 215 range: 255).
	self named: #palePeach put: (Color r: 255 g: 237 b: 213 range: 255).

! !

!Color class methodsFor: 'class initialization' stamp: 'ar 2/16/2000 21:56'!
initializeTranslucentPatterns
	"Color initializeTranslucentPatterns"
	| mask bits pattern patternList |
	TranslucentPatterns _ Array new: 8.
	#(1 2 4 8) do:[:d|
		patternList _ Array new: 5.
		mask _ (1 bitShift: d) - 1.
		bits _ 2 * d.
		[bits >= 32] whileFalse: [
			mask _ mask bitOr: (mask bitShift: bits).  "double the length of mask"
			bits _ bits + bits].
		"0% pattern"
		pattern _ Bitmap with: 0 with: 0.
		patternList at: 1 put: pattern.
		"25% pattern"
		pattern _ Bitmap with: mask with: 0.
		patternList at: 2 put: pattern.
		"50% pattern"
		pattern _ Bitmap with: mask with: mask bitInvert32.
		patternList at: 3 put: pattern.
		"75% pattern"
		pattern _ Bitmap with: mask with: 16rFFFFFFFF.
		patternList at: 4 put: pattern.
		"100% pattern"
		pattern _ Bitmap with: 16rFFFFFFFF with: 16rFFFFFFFF.
		patternList at: 5 put: pattern.
		TranslucentPatterns at: d put: patternList.
	].! !

!Color class methodsFor: 'class initialization' stamp: 'tk 6/13/96'!
named: newName put: aColor
	"Add a new color to the list and create an access message and a class variable for it.  The name should start with a lowercase letter.  (The class variable will start with an uppercase letter.)  (Color colorNames) returns a list of all color names.  "
	| str cap sym accessor csym |
	(aColor isKindOf: self) ifFalse: [^ self error: 'not a Color'].
	str _ newName asString.
	sym _ str asSymbol.
	cap _ str capitalized.
	csym _ cap asSymbol.
	(self class canUnderstand: sym) ifFalse: [
		"define access message"
		accessor _ str, (String with: Character cr with: Character tab), 			'^', cap.
		self class compile: accessor
			classified: 'named colors'].
	(self classPool includesKey: csym) ifFalse: [
		self addClassVarName: cap].
	(ColorNames includes: sym) ifFalse: [
		ColorNames add: sym].
	^ self classPool at: csym put: aColor! !


!Color class methodsFor: 'color from user' stamp: 'jm 1/19/1999 11:33'!
colorTest: depth extent: chartExtent colorMapper: colorMapper
	"Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
	"Note: It is slow to build this palette, so it should be cached for quick access."
	"(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display"
	"(Color colorTest: 32 extent: 570@180 colorMapper:
		[:c | Color
			r: (c red * 7) asInteger / 7
			g: (c green * 7) asInteger / 7
			b: (c blue * 3) asInteger / 3]) display"
	"(Color colorTest: 32 extent: 570@180 colorMapper:
		[:c | Color
			r: (c red * 5) asInteger / 5
			g: (c green * 5) asInteger / 5
			b: (c blue * 5) asInteger / 5]) display"
	"(Color colorTest: 32 extent: 570@180 colorMapper:
		[:c | Color
			r: (c red * 15) asInteger / 15
			g: (c green * 15) asInteger / 15
			b: (c blue * 15) asInteger / 15]) display"
	"(Color colorTest: 32 extent: 570@180 colorMapper:
		[:c | Color
			r: (c red * 31) asInteger / 31
			g: (c green * 31) asInteger / 31
			b: (c blue * 31) asInteger / 31]) display"

	| basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps |
	palette _ Form extent: chartExtent depth: depth.
	transCaption _ "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
		(Form extent: 34@9 depth: 1
			fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
			offset: 0@0).
	transHt _ transCaption height.
	palette fillWhite: (0@0 extent: palette width@transHt).
	palette fillBlack: (0@transHt extent: palette width@1).
	transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
	grayWidth _ 10.
	startHue _ 338.0.
	vSteps _ palette height - transHt // 2.
	hSteps _ palette width - grayWidth.
	x _ 0.
	startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h |
		basicHue _ Color h: h asFloat s: 1.0 v: 1.0.
		y _ transHt+1.
		0 to: vSteps do: [:n |
 			c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
			c _ colorMapper value: c.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		1 to: vSteps do: [:n |
 			c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
			c _ colorMapper value: c.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		x _ x + 1].
	y _ transHt + 1.
	1 to: vSteps * 2 do: [:n |
 		c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
		c _ colorMapper value: c.
		palette fill: (x@y extent: 10@1) fillColor: c.
		y _ y + 1].
	^ palette
! !

!Color class methodsFor: 'color from user' stamp: 'di 4/13/1999 14:30'!
fromUser
	"Displays a color palette of colors, waits for a mouse click, and returns the selected color. Any pixel on the Display can be chosen, not just those in the color palette."
	"Note: Since the color chart is cached, you may need to do 'ColorChart _ nil' after changing the oldColorPaletteForDepth:extent: method."
	"Color fromUser"

	| d startPt save tr oldColor c here s |
	d _ Display depth.
	((ColorChart == nil) or: [ColorChart depth ~= Display depth]) 
		ifTrue: [ColorChart _ self oldColorPaletteForDepth: d extent: (2 * 144)@80].
	Sensor cursorPoint y < Display center y 
		ifTrue: [startPt _ 0@(Display boundingBox bottom - ColorChart height)]
		ifFalse: [startPt _ 0@0].

	save _ Form fromDisplay: (startPt extent: ColorChart extent).
	ColorChart displayAt: startPt.
	tr _ ColorChart extent - (50@19) corner: ColorChart extent.
	tr _ tr translateBy: startPt.

	oldColor _ nil.
	[Sensor anyButtonPressed] whileFalse: [
		c _ Display colorAt: (here _ Sensor cursorPoint).
		(tr containsPoint: here)
			ifFalse: [Display fill: (0@61+startPt extent: 20@19) fillColor: c]
			ifTrue: [
				c _ Color transparent.
				Display fill: (0@61+startPt extent: 20@19) fillColor: Color white].
		c = oldColor ifFalse: [
			Display fillWhite: (20@61 + startPt extent: 135@19).
			c isTransparent
				ifTrue: [s _ 'transparent']
				ifFalse: [s _ c shortPrintString.
						s _ s copyFrom: 7 to: s size - 1].
			s displayAt: 20@61 + startPt.
			oldColor _ c]].
	save displayAt: startPt.
	Sensor waitNoButton.
	^ c
! !

!Color class methodsFor: 'color from user' stamp: 'di 4/13/1999 14:28'!
oldColorPaletteForDepth: depth extent: paletteExtent
	"Returns a form of the given size showing a color palette for the given depth."
	"(Color oldColorPaletteForDepth: Display depth extent: 720@100) display"

	| c p f nSteps rect w h q |
	f _ Form extent: paletteExtent depth: depth.
	f fill: f boundingBox fillColor: Color white.
	nSteps _ depth > 8 ifTrue: [12] ifFalse: [6].
	w _ paletteExtent x // (nSteps * nSteps).
	h _ paletteExtent y - 20 // nSteps.
	0 to: nSteps-1 do: [:r |
		0 to: nSteps-1 do: [:g |
			0 to: nSteps-1 do: [:b |
				c _ Color r: r g: g b: b range: nSteps - 1.
				rect _ ((r * nSteps * w) + (b * w)) @ (g * h) extent: w@(h + 1).
				f fill: rect fillColor: c]]].
	q _ Quadrangle origin: paletteExtent - (50@19) corner: paletteExtent.
	q displayOn: f.
	'Trans.' displayOn: f at: q origin + (9@1).

	w _ ((paletteExtent x - q width - 130) // 64) max: 1.
	p _ paletteExtent x - q width - (64 * w) - 1 @ (paletteExtent y - 19).
	0 to: 63 do:
		[:v | c _ Color r: v g: v b: v range: 63.
		f fill: ((v * w)@0 + p extent: (w + 1)@19) fillColor: c].
	^ f
! !


!Color class methodsFor: 'colormaps' stamp: 'jm 5/2/1999 07:24'!
cachedColormapFrom: sourceDepth to: destDepth
	"Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations."
	"Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"
	"Note: The colormap cache may be cleared by evaluating 'Color shutDown'."

	| srcIndex map |
	CachedColormaps class == Array ifFalse: [CachedColormaps _ (1 to: 9) collect: [:i | Array new: 32]].
	srcIndex _ sourceDepth.
	sourceDepth > 8 ifTrue: [srcIndex _ 9].
	(map _ (CachedColormaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [^ map].

	map _ self computeColormapFrom: sourceDepth to: destDepth.
	(CachedColormaps at: srcIndex) at: destDepth put: map.
	^ map
! !

!Color class methodsFor: 'colormaps'!
colorMapIfNeededFrom: sourceDepth to: destDepth
	"Return a colormap for mapping between the given depths, or nil if no colormap is needed."
	"Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"

	sourceDepth = destDepth ifTrue: [^ nil].  "not needed if depths are the same"

	(sourceDepth >= 16) & (destDepth >= 16) ifTrue: [
		"mapping is done in BitBlt by zero-filling or truncating each color component"
		^ nil].

	^ Color cachedColormapFrom: sourceDepth to: destDepth
! !

!Color class methodsFor: 'colormaps' stamp: 'jm 3/25/1999 19:48'!
computeColormapFrom: sourceDepth to: destDepth
	"Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead."

	| map bitsPerColor |
	sourceDepth < 16 ifTrue: [
		"source is 1-, 2-, 4-, or 8-bit indexed color"
		map _ (IndexedColors copyFrom: 1 to: (1 bitShift: sourceDepth))
					collect: [:c | c pixelValueForDepth: destDepth].
		map _ map as: Bitmap.
	] ifFalse: [
		"source is 16-bit or 32-bit RGB"
		destDepth > 8
			ifTrue: [bitsPerColor _ 5]  "retain maximum color resolution"
			ifFalse: [bitsPerColor _ 4].
		map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor].

	"Note: zero is transparent except when source depth is one-bit deep"
	sourceDepth > 1 ifTrue: [map at: 1 put: 0].
	^ map
! !

!Color class methodsFor: 'colormaps' stamp: 'jm 12/4/97 15:25'!
computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor
	"Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component."

	| mask map c |
	(#(3 4 5) includes: bitsPerColor)
		ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component'].
	mask _ (1 bitShift: bitsPerColor) - 1.
	map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)).
	0 to: map size - 1 do: [:i |
		c _ Color
			r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask)
			g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask)
			b: ((i bitShift: 0) bitAnd: mask)
			range: mask.
		map at: i + 1 put: (c pixelValueForDepth: destDepth)].

	map at: 1 put: (Color transparent pixelWordForDepth: destDepth).  "zero always transparent"
	^ map
! !


!Color class methodsFor: 'examples'!
colorRampForDepth: depth extent: aPoint
	"Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths."
	"(Color colorRampForDepth: Display depth extent: 256@80) display"
	"(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint"

	| f dx dy r |
	f _ Form extent: aPoint depth: depth.
	dx _ aPoint x // 256.
	dy _ aPoint y // 4.
	0 to: 255 do: [:i |
		r _ (dx * i)@0 extent: dx@dy.
		f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255).
		r _ r translateBy: 0@dy.
		f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255).
		r _ r translateBy: 0@dy.
		f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255).
		r _ r translateBy: 0@dy.
		f fill: r fillColor: (Color r: i g: i b: i range: 255)].
	^ f
! !

!Color class methodsFor: 'examples' stamp: 'tk 6/19/96'!
hotColdShades: thisMany
	"An array of thisMany colors showing temperature from blue to red to white hot.  (Later improve this by swinging in hue.)  "
	"Color showColors: (Color hotColdShades: 25)"

	| n s1 s2 s3 s4 s5 |
	thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades'].
	n _ thisMany // 5.
	s1 _ self white mix: self yellow shades: (thisMany - (n*4)).
	s2 _ self yellow mix: self red shades: n+1.
	s2 _ s2 copyFrom: 2 to: n+1.
	s3 _ self red mix: self green darker shades: n+1.
	s3 _ s3 copyFrom: 2 to: n+1.
	s4 _ self green darker mix: self blue shades: n+1.
	s4 _ s4 copyFrom: 2 to: n+1.
	s5 _ self blue mix: self black shades: n+1.
	s5 _ s5 copyFrom: 2 to: n+1.
	^ s1, s2, s3, s4, s5
! !

!Color class methodsFor: 'examples'!
showColorCube
	"Show a 12x12x12 color cube."
	"Color showColorCube"

	0 to: 11 do: [:r |
		0 to: 11 do: [:g |
			0 to: 11 do: [:b |	
				Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5)
					fillColor: (Color r: r g: g b: b range: 11)]]].
! !

!Color class methodsFor: 'examples'!
showColors: colorList
	"Display the given collection of colors across the top of the Display."

	| w r |
	w _ Display width // colorList size.
	r _ 0@0 extent: w@((w min: 30) max: 10).
	colorList do: [:c |
		Display fill: r fillColor: c.
		r _ r translateBy: w@0].
! !

!Color class methodsFor: 'examples'!
showHSVPalettes
	"Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32."
	"Color showHSVPalettes"

	| left top c |
	left _ top _ 0.
	0 to: 179 by: 15 do: [:h |
		0 to: 10 do: [:s |
			left _ (h * 4) + (s * 4).
			0 to: 10 do: [:v |
				c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0.
				top _ (v * 4).
				Display fill: (left@top extent: 4@4) fillColor: c.

				c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0.
				top _ (v * 4) + 50.
				Display fill: (left@top extent: 4@4) fillColor: c]]].
! !

!Color class methodsFor: 'examples'!
showHuesInteractively
	"Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point."
	"Color showHuesInteractively"

	| p s v |
	[Sensor anyButtonPressed] whileFalse: [
		p _ Sensor cursorPoint.
		s _ p x asFloat / 300.0.
		v _ p y asFloat / 300.0.
		self showColors: (self wheel: 12 saturation: s brightness: v)].
	^ (s min: 1.0) @ (v min: 1.0)! !

!Color class methodsFor: 'examples'!
wheel: thisMany
	"Return a collection of thisMany colors evenly spaced around the color wheel."
	"Color showColors: (Color wheel: 12)"

	^ Color wheel: thisMany saturation: 0.9 brightness: 0.7
! !

!Color class methodsFor: 'examples'!
wheel: thisMany saturation: s brightness: v
	"Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness."
	"Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)"
	"Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)"

	^ (Color h: 0.0 s: s v: v) wheel: thisMany
! !


!Color class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 18:45'!
colorFrom: parm
	"Return an instantiated color from parm.  If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker).  Else just return the thing"

	| aColor firstParm |
	(parm isKindOf: Color) ifTrue: [^ parm].
	(parm isSymbol) ifTrue: [^ self perform: parm].
	(parm isString) ifTrue: [^ self fromString: parm].
	((parm isKindOf: SequenceableCollection) and: [parm size > 0])
		ifTrue:
			[firstParm := parm first.
			(firstParm isKindOf: Number) ifTrue:
				[^ self fromRgbTriplet: parm].
			aColor := self colorFrom: firstParm.
			parm doWithIndex:
				[:sym :ind | ind > 1 ifTrue:
					[aColor := aColor perform: sym]].
			^ aColor].
	^ parm

"
Color colorFrom: #(blue darker)
Color colorFrom: Color blue darker
Color colorFrom: #blue
Color colorFrom: #(0.0 0.0 1.0)
"! !

!Color class methodsFor: 'instance creation' stamp: 'tk 8/15/2001 11:03'!
colorFromPixelValue: p depth: d
	"Convert a pixel value for the given display depth into a color."
	"Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color."

	| r g b alpha |
	d = 8 ifTrue: [^ IndexedColors at: (p bitAnd: 16rFF) + 1].
	d = 4 ifTrue: [^ IndexedColors at: (p bitAnd: 16r0F) + 1].
	d = 2 ifTrue: [^ IndexedColors at: (p bitAnd: 16r03) + 1].
	d = 1 ifTrue: [^ IndexedColors at: (p bitAnd: 16r01) + 1].

	(d = 16) | (d = 15) ifTrue: [
		"five bits per component"
		r _ (p bitShift: -10) bitAnd: 16r1F.
		g _ (p bitShift: -5) bitAnd: 16r1F.
		b _ p bitAnd: 16r1F.
		(r = 0 and: [g = 0]) ifTrue: [
			b = 0 ifTrue: [^Color transparent].
			b = 1 ifTrue: [^Color black]].
		^ Color r: r g: g b: b range: 31].

	d = 32 ifTrue: [
		"eight bits per component; 8 bits of alpha"
		r _ (p bitShift: -16) bitAnd: 16rFF.
		g _ (p bitShift: -8) bitAnd: 16rFF.
		b _ p bitAnd: 16rFF.
		alpha _ p bitShift: -24.
		alpha = 0 ifTrue: [^Color transparent].
		(r = 0 and: [g = 0 and: [b = 0]])  ifTrue: [^Color transparent].
		alpha < 255
			ifTrue: [^ (Color r: r g: g b: b range: 255) alpha: (alpha asFloat / 255.0)]
			ifFalse: [^ (Color r: r g: g b: b range: 255)]].

	d = 12 ifTrue: [
		"four bits per component"
		r _ (p bitShift: -8) bitAnd: 16rF.
		g _ (p bitShift: -4) bitAnd: 16rF.
		b _ p bitAnd: 16rF.
		^ Color r: r g: g b: b range: 15].

	d = 9 ifTrue: [
		"three bits per component"
		r _ (p bitShift: -6) bitAnd: 16r7.
		g _ (p bitShift: -3) bitAnd: 16r7.
		b _ p bitAnd: 16r7.
		^ Color r: r g: g b: b range: 7].

	self error: 'unknown pixel depth: ', d printString
! !

!Color class methodsFor: 'instance creation' stamp: 'mir 7/21/1999 11:54'!
fromArray: colorDef
	colorDef size == 3
			ifTrue: [^self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)].
	colorDef size == 0
			ifTrue: [^Color transparent].
	colorDef size == 4
			ifTrue: [^(TranslucentColor r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)) alpha: (colorDef at: 4)].
	self error: 'Undefined color definition'! !

!Color class methodsFor: 'instance creation' stamp: 'sw 8/8/97 22:03'!
fromRgbTriplet: list
	^ self r: list first g: list second b: list last! !

!Color class methodsFor: 'instance creation' stamp: 'dvf 6/16/2000 17:48'!
fromString: aString
	"for HTML color spec: #FFCCAA or white/black"
	"Color fromString: '#FFCCAA'.
	 Color fromString: 'white'.
	 Color fromString: 'orange'"
	| aColorHex red green blue |
	aString isEmptyOrNil ifTrue: [^ Color white].
	aString first = $#
		ifTrue: [aColorHex _ aString copyFrom: 2 to: aString size]
		ifFalse: [aColorHex _ aString].
	[aColorHex size = 6
		ifTrue:
			[aColorHex _ aColorHex asUppercase.
			red _ ('16r', (aColorHex copyFrom: 1 to: 2)) asNumber/255.
			green _ ('16r', (aColorHex copyFrom: 3 to: 4)) asNumber/255.
			blue _ ('16r', (aColorHex copyFrom: 5 to: 6)) asNumber/255.
			^ self r: red g: green b: blue]]
	ifError: [:err :rcvr | "not a hex color triplet" ].
	
	"try to match aColorHex with known named colors"
	aColorHex _ aColorHex asLowercase.

	^self perform: (ColorNames detect: [:i | i asString asLowercase = aColorHex]
		ifNone: [#white])! !

!Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:05'!
gray: brightness
	"Return a gray shade with the given brightness in the range [0.0..1.0]."

	^ self basicNew setRed: brightness green: brightness blue: brightness
! !

!Color class methodsFor: 'instance creation'!
h: hue s: saturation v: brightness
	"Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red."
	"Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue."

	^ self basicNew setHue: hue saturation: saturation brightness: brightness! !

!Color class methodsFor: 'instance creation' stamp: 'dew 3/19/2002 23:49'!
h: h s: s v: v alpha: alpha

	^ (self h: h s: s v: v) alpha: alpha! !

!Color class methodsFor: 'instance creation'!
new

	^ self r: 0.0 g: 0.0 b: 0.0! !

!Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:04'!
r: r g: g b: b
	"Return a color with the given r, g, and b components in the range [0.0..1.0]."

	^ self basicNew setRed: r green: g blue: b
! !

!Color class methodsFor: 'instance creation'!
r: r g: g b: b alpha: alpha

	^ (self r: r g: g b: b) alpha: alpha! !

!Color class methodsFor: 'instance creation'!
r: r g: g b: b range: range
	"Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)."

	^ self basicNew setRed: r green: g blue: b range: range! !

!Color class methodsFor: 'instance creation'!
random
	"Return a random color that isn't too dark or under-saturated."

	^ self basicNew
		setHue: (360.0 * RandomStream next)
		saturation: (0.3 + (RandomStream next * 0.7))
		brightness: (0.4 + (RandomStream next * 0.6))! !


!Color class methodsFor: 'named colors'!
black
	^Black! !

!Color class methodsFor: 'named colors'!
blue
	^Blue! !

!Color class methodsFor: 'named colors'!
brown
	^Brown! !

!Color class methodsFor: 'named colors'!
cyan
	^Cyan! !

!Color class methodsFor: 'named colors'!
darkGray
	^DarkGray! !

!Color class methodsFor: 'named colors'!
gray
	^Gray! !

!Color class methodsFor: 'named colors'!
green
	^Green! !

!Color class methodsFor: 'named colors'!
lightBlue
	^LightBlue! !

!Color class methodsFor: 'named colors'!
lightBrown
	^LightBrown! !

!Color class methodsFor: 'named colors'!
lightCyan
	^LightCyan! !

!Color class methodsFor: 'named colors'!
lightGray
	^LightGray! !

!Color class methodsFor: 'named colors'!
lightGreen
	^LightGreen! !

!Color class methodsFor: 'named colors'!
lightMagenta
	^LightMagenta! !

!Color class methodsFor: 'named colors'!
lightOrange
	^LightOrange! !

!Color class methodsFor: 'named colors'!
lightRed
	^LightRed! !

!Color class methodsFor: 'named colors'!
lightYellow
	^LightYellow! !

!Color class methodsFor: 'named colors'!
magenta
	^Magenta! !

!Color class methodsFor: 'named colors'!
orange
	^Orange! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleBlue
	^PaleBlue! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleBuff
	^PaleBuff! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleGreen
	^PaleGreen! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleMagenta
	^PaleMagenta! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleOrange
	^PaleOrange! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
palePeach
	^PalePeach! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleRed
	^PaleRed! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleTan
	^PaleTan! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleYellow
	^PaleYellow! !

!Color class methodsFor: 'named colors'!
red
	^Red! !

!Color class methodsFor: 'named colors' stamp: 'wod 5/24/1998 01:56'!
tan
	^  Color r: 0.8 g: 0.8 b: 0.5! !

!Color class methodsFor: 'named colors'!
transparent
	^Transparent! !

!Color class methodsFor: 'named colors'!
veryDarkGray
	^VeryDarkGray! !

!Color class methodsFor: 'named colors'!
veryLightGray
	^VeryLightGray! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
veryPaleRed
	^VeryPaleRed! !

!Color class methodsFor: 'named colors'!
veryVeryDarkGray
	^VeryVeryDarkGray! !

!Color class methodsFor: 'named colors'!
veryVeryLightGray
	^VeryVeryLightGray! !

!Color class methodsFor: 'named colors'!
white
	^White! !

!Color class methodsFor: 'named colors'!
yellow
	^Yellow! !


!Color class methodsFor: 'other'!
colorNames
	"Return a collection of color names."

	^ ColorNames! !

!Color class methodsFor: 'other' stamp: 'BG 3/16/2005 08:18'!
hex: aFloat
	"Return an hexadecimal two-digits string between 00 and FF
	for a float between 0.0 and 1.0"
	| str |
	str := ((aFloat * 255) asInteger printStringHex) asLowercase.
	str size = 1 ifTrue: [^'0',str] ifFalse: [^str]! !

!Color class methodsFor: 'other'!
indexedColors

	^ IndexedColors! !

!Color class methodsFor: 'other' stamp: 'di 3/29/1999 13:33'!
maskingMap: depth
	"Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map."

	| sizeNeeded |
	depth <= 8
		ifTrue: [sizeNeeded _ 1 bitShift: depth]
		ifFalse: [sizeNeeded _ 4096].

	(MaskingMap == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue:
		[MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF.
		MaskingMap at: 1 put: 0.  "transparent"].

	^ MaskingMap
! !

!Color class methodsFor: 'other'!
pixelScreenForDepth: depth
	"Return a 50% stipple containing alternating pixels of all-zeros and all-ones to be used as a mask at the given depth."

	| mask bits |
	mask _ (1 bitShift: depth) - 1.
	bits _ 2 * depth.
	[bits >= 32] whileFalse: [
		mask _ mask bitOr: (mask bitShift: bits).  "double the length of mask"
		bits _ bits + bits].
	^ Bitmap with: mask with: mask bitInvert32
! !

!Color class methodsFor: 'other'!
quickHighLight: depth
	"Quickly return a Bitblt-ready raw colorValue for highlighting areas.  6/22/96 tk"

	^ HighLightBitmaps at: depth! !

!Color class methodsFor: 'other'!
shutDown
	"Color shutDown"

	ColorChart _ nil.		"Palette of colors for the user to pick from"
	CachedColormaps _ nil.	"Maps to translate between color depths"
	MaskingMap _ nil.		"Maps all colors except transparent to black for creating a mask"
! !

!Color class methodsFor: 'other' stamp: 'ar 2/16/2000 21:56'!
translucentMaskFor: alphaValue depth: d
	"Return a pattern representing a mask usable for stipple transparency"
	^(TranslucentPatterns at: d) at: ((alphaValue min: 1.0 max: 0.0) * 4) rounded + 1! !
ArrayedCollection variableWordSubclass: #ColorArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!

!ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:03'!
at: index
	^(super at: index) asColorOfDepth: 32! !

!ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:04'!
at: index put: aColor
	^super at: index put: (aColor pixelWordForDepth: 32).! !


!ColorArray methodsFor: 'converting' stamp: 'ar 3/3/2001 20:06'!
asColorArray
	^self! !

!ColorArray methodsFor: 'converting' stamp: 'RAA 3/8/2001 06:24'!
bytesPerElement

	^4! !
Form subclass: #ColorForm
	instanceVariableNames: 'colors cachedDepth cachedColormap'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!ColorForm commentStamp: '<historical>' prior: 0!
ColorForm is a normal Form plus a color map of up to 2^depth Colors. Typically, one reserves one entry in the color map for transparent. This allows 1, 3, 15, or 255 non-transparent colors in ColorForms of depths 1, 2, 4, and 8 bits per pixel. ColorForms don't support depths greater than 8 bits because that would require excessively large color maps with little real benefit, since 16-bit and 32-bit depths already support thousands and millions of colors.

ColorForms have several uses:
  1) Precise colors. You can have up to 256 true colors, instead being limited to the 8-bit color palette.
  2) Easy transparency. Just store (Color transparent) at the desired position in the color map.
  3) Cheap color remapping by changing the color map.

A color map is an Array of up to 2^depth Color objects. A Bitmap colorMap is automatically computed and cached for rapid display. Note that if you change the color map, you must resubmit it via the colors: method to flush this cache.

ColorForms can be a bit tricky. Note that:
  a) When you BitBlt from one ColorForm to another, you must remember to copy the color map of the source ColorForm to the destination ColorForm.
  b) A ColorForm's color map is an array of depth-independent Color objects. BitBlt requires a BitMap of actual pixel values, adjusted to the destination depth. These are different things!! ColorForms automatically maintain a cache of the BitBlt-style color map corresponding to the colors array for the last depth on which the ColorForm was displayed, so there should be little need for clients to work with BitBlt-style color maps.
  c) The default map for 8 bit depth has black in the first entry, not transparent.  Say (cform colors at: 1 put: Color transparent).
!


!ColorForm methodsFor: 'accessing' stamp: 'jm 11/14/97 17:39'!
colors
	"Return my color palette."

	self ensureColorArrayExists.
	^ colors
! !

!ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'!
colors: colorList
	"Set my color palette to the given collection."

	| colorArray colorCount newColors |
	colorList ifNil: [
		colors _ cachedDepth _ cachedColormap _ nil.
		^ self].

	colorArray _ colorList asArray.
	colorCount _ colorArray size.
	newColors _ Array new: (1 bitShift: self depth).
	1 to: newColors size do: [:i |
		i <= colorCount
			ifTrue: [newColors at: i put: (colorArray at: i)]
			ifFalse: [newColors at: i put: Color transparent]].

	colors _ newColors.
	cachedDepth _ nil.
	cachedColormap _ nil.
! !

!ColorForm methodsFor: 'accessing' stamp: 'mir 7/21/1999 11:51'!
colorsFromArray: colorArray
	| colorList |
	colorList _ colorArray collect: [:colorDef |
		Color fromArray: colorDef].
	self colors: colorList! !


!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20'!
asGrayScale
	"Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent"
	^ self copy colors:
		(colors collect:
			[:c | c isTransparent ifTrue: [c]
						ifFalse: [Color gray: c luminance]])! !

!ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/17/2001 15:44'!
colormapIfNeededForDepth: destDepth
	"Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed."

	| newMap |
	colors == nil ifTrue: [
		"use the standard colormap"
		^ Color colorMapIfNeededFrom: self depth to: destDepth].

	(destDepth = cachedDepth and:[cachedColormap isColormap not]) 
		ifTrue: [^ cachedColormap].
	newMap _ Bitmap new: colors size.
	1 to: colors size do: [:i |
		newMap
			at: i
			put: ((colors at: i) pixelValueForDepth: destDepth)].

	cachedDepth _ destDepth.
	^ cachedColormap _ newMap.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 4/18/98 20:34'!
colorsUsed
	"Return a list of the colors actually used by this ColorForm."

	| myColor list |
	myColor _ self colors.
	list _ OrderedCollection new.
	self tallyPixelValues doWithIndex: [:count :i |
		count > 0 ifTrue: [list add: (myColor at: i)]].
	^ list asArray
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 11:18'!
ensureTransparentColor
	"Ensure that the receiver (a) includes Color transparent in its color map and (b) that the entry for Color transparent is the first entry in its color map."

	| i |
self error: 'not yet implemented'.
	(colors includes: Color transparent)
		ifTrue: [
			(colors indexOf: Color transparent) = 1 ifTrue: [^ self].
			"shift the entry for color transparent"]
		ifFalse: [
			i _ self unusedColormapEntry.
			i = 0 ifTrue: [self error: 'no color map entry is available'].
			colors at: i put: Color transparent.
			"shift the entry for color transparent"].
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'di 8/28/1998 15:48'!
indexOfColor: aColor
	"Return the index of aColor in my color array"

	self ensureColorArrayExists.
	^ colors indexOf: aColor ifAbsent: [0]! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 10/19/1998 10:52'!
mapColor: oldColor to: newColor
	"Replace all occurances of the given color with the given new color in my color map."

	self ensureColorArrayExists.
	1 to: colors size do: [:i | 
		(colors at: i) = oldColor ifTrue: [colors at: i put: newColor]].
	self clearColormapCache.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 09:08'!
replaceColor: oldColor with: newColor
	"Replace all occurances of the given color with the given new color in my color map."

	self ensureColorArrayExists.
	1 to: colors size do: [:i | 
		(colors at: i) = oldColor ifTrue: [colors at: i put: newColor]].
	self clearColormapCache.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 15:42'!
replaceColorAt: aPoint with: newColor
	"Replace a color map entry with newColor.  The entry replaced is the one used by aPoint.  If there are are two entries in the colorMap for the oldColor, just replace ONE!!!!  There are often two whites or two blacks, and this is what you want, when replacing one."

	| oldIndex |
	self ensureColorArrayExists.
	oldIndex _ self pixelValueAt: aPoint.
	colors at: oldIndex+1 put: newColor.
	self clearColormapCache.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'di 8/28/1998 15:49'!
replaceColorAtIndex: index with: newColor
	"Replace a color map entry with newColor."

	self ensureColorArrayExists.
	colors at: index put: newColor.
	cachedColormap == nil ifFalse:
		[cachedColormap at: index put: (newColor pixelValueForDepth: cachedDepth)]! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:26'!
transparentAllPixelsLike: aPoint
	"Make all occurances of the given pixel value transparent.  Very useful when two entries in the colorMap have the same value.  This only changes ONE."

	self replaceColorAt: aPoint with: Color transparent.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:27'!
transparentColor: aColor
	"Make all occurances of the given color transparent.  Note: for colors like black and white, which have two entries in the colorMap, this changes BOTH of them.  Not always what you want."

	self replaceColor: aColor with: Color transparent.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/28/2000 12:06'!
twoToneFromDisplay: aRectangle backgroundColor: bgColor
	"Copy one-bit deep ColorForm from the Display using a color map that maps all colors except the background color to black. Used for caching the contents of inactive MVC windows."

	| map |
	(width = aRectangle width and: [height = aRectangle height])
		ifFalse: [self setExtent: aRectangle extent depth: depth].

	"make a color map mapping the background color
	 to zero and all other colors to one"
	map _ Bitmap new: (1 bitShift: (Display depth min: 9)).
	1 to: map size do: [:i | map at: i put: 16rFFFFFFFF].
	map at: (bgColor indexInMap: map) put: 0.

	(BitBlt current toForm: self)
		destOrigin: 0@0;
		sourceForm: Display;
		sourceRect: aRectangle;
		combinationRule: Form over;
		colorMap: map;
		copyBits.
! !


!ColorForm methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:44'!
colormapIfNeededFor: destForm
	| newMap color pv |
	(self hasNonStandardPalette or:[destForm hasNonStandardPalette]) ifFalse:[
		^self colormapIfNeededForDepth: destForm depth.
	].
	colors == nil ifTrue: [
		"use the standard colormap"
		^ super colormapIfNeededFor: destForm].

	(destForm depth = cachedDepth and:[cachedColormap isColormap]) 
		ifTrue: [^ cachedColormap].
	newMap _ WordArray new: (1 bitShift: self depth).
	1 to: colors size do: [:i |
		color _ colors at: i.
		pv _ destForm pixelValueFor: color.
		(pv = 0 and:[color isTransparent not]) ifTrue:[pv _ 1].
		newMap at: i put: pv].

	cachedDepth _ destForm depth.
	^cachedColormap _ ColorMap shifts: nil masks: nil colors: newMap.! !


!ColorForm methodsFor: 'copying' stamp: 'RAA 8/14/2000 10:45'!
asCursorForm

	^ (self asFormOfDepth: 32) offset: offset; as: StaticForm! !

!ColorForm methodsFor: 'copying' stamp: 'ar 10/24/2005 22:25'!
blankCopyOf: aRectangle scaledBy: scale
	^Form extent: (aRectangle extent * scale) truncated depth: 32! !

!ColorForm methodsFor: 'copying' stamp: 'ar 5/28/2000 12:06'!
copy: aRect
 	"Return a new ColorForm containing the portion of the receiver delineated by aRect."

	| newForm |
	newForm _ self class extent: aRect extent depth: depth.
	((BitBlt current
		destForm: newForm
		sourceForm: self
		fillColor: nil
		combinationRule: Form over
		destOrigin: 0@0
		sourceOrigin: aRect origin
		extent: aRect extent
		clipRect: newForm boundingBox)
		colorMap: nil) copyBits.
	colors ifNotNil: [newForm colors: colors copy].
	^ newForm
! !

!ColorForm methodsFor: 'copying' stamp: 'jm 2/27/98 09:38'!
deepCopy

	^ self shallowCopy
		bits: bits copy;
		offset: offset copy;
		colors: colors
! !


!ColorForm methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:32'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm

	aDisplayMedium copyBits: self boundingBox
		from: self
		at: aDisplayPoint + self offset
		clippingBox: clipRectangle
		rule: rule
		fillColor: aForm
		map: (self colormapIfNeededFor: aDisplayMedium).
! !

!ColorForm methodsFor: 'displaying' stamp: 'di 7/17/97 10:04'!
displayOnPort: port at: location

	port copyForm: self to: location rule: Form paint! !

!ColorForm methodsFor: 'displaying' stamp: 'ar 12/14/2001 18:14'!
maskingMap
	"Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero."
	| maskingMap |
	maskingMap _ Bitmap new: (1 bitShift: depth) withAll: 16rFFFFFFFF.
	1 to: colors size do:[:i|
		(colors at: i) isTransparent ifTrue:[maskingMap at: i put: 0].
	].
	colors size+1 to: maskingMap size do:[:i| maskingMap at: i put: 0].
	^maskingMap! !


!ColorForm methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 20:07'!
hibernate
	"Make myself take up less space. See comment in Form>hibernate."

	super hibernate.
	self clearColormapCache.
	colors ifNotNil:[colors _ colors asColorArray].! !

!ColorForm methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:46'!
readAttributesFrom: aBinaryStream
	super readAttributesFrom: aBinaryStream.
	colors _ ColorArray new: (2 raisedTo: depth).
	1 to: colors size do: [:idx | 
		colors basicAt: idx put: (aBinaryStream nextLittleEndianNumber: 4).
	]. 
	! !

!ColorForm methodsFor: 'fileIn/Out' stamp: 'bf 5/25/2000 16:31'!
storeOn: aStream
	aStream nextPut: $(.
	super storeOn: aStream.
	aStream
		cr; tab;
		nextPutAll: 'colorsFromArray: #('.
	self colors do: [:color |
		color storeArrayOn: aStream].
	aStream nextPutAll: ' ))'.! !

!ColorForm methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 20:07'!
unhibernate
	colors ifNotNil:[colors _ colors asArray].
	^super unhibernate.
! !

!ColorForm methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:42'!
writeAttributesOn: file
	| colorArray |
	super writeAttributesOn: file.
	colorArray _ self colors asColorArray.
	1 to: (2 raisedTo: depth) do: [:idx |
		file nextLittleEndianNumber: 4 put: (colorArray basicAt: idx).
	] ! !


!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'!
colorAt: aPoint
	"Return the color of the pixel at aPoint."

	^ self colors at: (self pixelValueAt: aPoint) + 1
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'!
colorAt: aPoint put: aColor
	"Store the given color into the pixel at aPoint. The given color must match one of the colors in the receiver's colormap."

	| i |
	i _ self colors indexOf: aColor
		ifAbsent: [^ self error: 'trying to use a color that is not in my colormap'].
	self pixelValueAt: aPoint put: i - 1.
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'tk 10/21/97 12:27'!
isTransparentAt: aPoint 
	"Return true if the receiver is transparent at the given point."

	^ (self colorAt: aPoint) isTransparent
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'ar 5/28/2000 12:06'!
pixelValueAt: aPoint 
	"Return the raw pixel value at the given point. Typical clients use colorAt: to get a Color."
	"Details: To get the raw pixel value, be sure the peeker's colorMap is nil."

	^ (BitBlt current bitPeekerFromForm: self) colorMap: nil; pixelAt: aPoint
! !


!ColorForm methodsFor: 'postscript generation'!
asFormWithSingleTransparentColors
	| transparentIndexes |
	transparentIndexes _ self transparentColorIndexes.
	transparentIndexes size <= 1 ifTrue:[^self]
		ifFalse:[^self mapTransparencies:transparentIndexes].! !

!ColorForm methodsFor: 'postscript generation'!
decodeArray
	^self depth = 1 ifTrue:['[1 0]'] ifFalse:['[0 255]'].! !

!ColorForm methodsFor: 'postscript generation'!
getTransparencyUnificationLUT
	| lut transparentIndex |
	lut _ Array new:colors size.
	transparentIndex _ self indexOfColor:Color transparent.
	1 to: colors size do:
		[ :i | lut at:i put:(((colors at:i) = Color transparent) ifTrue:[transparentIndex] ifFalse:[i])].
 ! !

!ColorForm methodsFor: 'postscript generation'!
mapTransparencies:transparentIndexes
	^self deepCopy mapColors:transparentIndexes to:(transparentIndexes at:1).! !

!ColorForm methodsFor: 'postscript generation'!
setColorspaceOn:aStream
	self depth = 1 ifTrue:[
		aStream print:'/DeviceRGB setcolorspace 0 setgray'; cr.
	]
	ifFalse:[
	aStream print:'[ /Indexed /DeviceRGB ';
	write:self colors size-1;
	print:' <'.
	(self colormapIfNeededForDepth: 32 ) storeBits:20 to:0 on:aStream.
	aStream print:'> ] setcolorspace'; cr.].
! !

!ColorForm methodsFor: 'postscript generation'!
transparentColorIndexes
	^(1 to: colors size) select: [ :index | (colors at:index) isTransparent ].
! !


!ColorForm methodsFor: 'scaling, rotation' stamp: 'ar 3/15/1999 14:28'!
flipBy: direction centerAt: aPoint
	| oldColors newForm |
	oldColors _ colors.
	self colors: nil.
	newForm _ super flipBy: direction centerAt: aPoint.
	self colors: oldColors.
	newForm colors: oldColors.
	^newForm ! !

!ColorForm methodsFor: 'scaling, rotation' stamp: 'RAA 8/5/2000 18:12'!
scaledToSize: newExtent

	"super method did not seem to work so well on ColorForms"

	^(self asFormOfDepth: 16) scaledToSize: newExtent! !


!ColorForm methodsFor: 'testing' stamp: 'ar 5/27/2001 16:34'!
isColorForm
	^true! !

!ColorForm methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'!
isTranslucent
	"Answer whether this form may be translucent"
	^true! !


!ColorForm methodsFor: '*MorphicExtras-*morphic-Postscript Canvases' stamp: 'sma 6/14/2000 14:20'!
encodePostscriptOn: aStream 
	self unhibernate.
	aStream print: '% form contains ';
	 write: (colors select: [:c | c = Color transparent]) size;
	 print: ' transparent colors';
	 cr.
	^ self asFormWithSingleTransparentColors 
		printPostscript: aStream operator: (self depth = 1
			ifTrue: ['imagemask']
			ifFalse: [(self indexOfColor: Color transparent) printString , ' transparentimage'])! !

!ColorForm methodsFor: '*MorphicExtras-*morphic-Postscript Canvases'!
printPostscript:aStream
	aStream nextPutAll:'% form contains '; 
			print:((colors select:[:c| c=Color transparent]) size); 
			nextPutAll:' transparent colors'; cr.
	^self asFormWithSingleTransparentColors printPostscript:aStream operator:(self depth=1 ifTrue:['imagemask'] 
	ifFalse:[ (self indexOfColor:Color transparent) printString ,' transparentimage']) .
! !


!ColorForm methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'sd 11/20/2005 21:25'!
encodeForRemoteCanvas

	"encode into a bitstream for use with RemoteCanvas."

	| colorsToSend |

	colorsToSend := self colors.
	^String streamContents: [ :str |
		str
			nextPut: $C;		"indicates color form"
			nextPutAll: colorsToSend size printString;
			nextPut: $,.
		colorsToSend do: [ :each |
			str nextPutAll: each encodeForRemoteCanvas
		].
		str nextPutAll: super encodeForRemoteCanvas
	].

! !


!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:07'!
clearColormapCache

	cachedDepth _ nil.
	cachedColormap _ nil.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:12'!
depth: bitsPerPixel

	bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits'].
	super depth: bitsPerPixel.
! !

!ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44'!
ensureColorArrayExists
	"Return my color palette."

	colors ifNil: [
		self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits'].
		self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth))].
! !

!ColorForm methodsFor: 'private' stamp: 'jm 4/5/1999 10:11'!
setColors: colorArray cachedColormap: aBitmap depth: anInteger
	"Semi-private. Set the color array, cached colormap, and cached colormap depth to avoid having to recompute the colormap when switching color palettes in animations."

	colors _ colorArray.
	cachedDepth _ anInteger.
	cachedColormap _ aBitmap.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'!
setExtent: extent depth: bitsPerPixel
	"Create a virtual bit map with the given extent and bitsPerPixel."

	bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits'].
	super setExtent: extent depth: bitsPerPixel.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 2/24/98 18:53'!
unusedColormapEntry
	"Return the index of an unused color map entry, or zero if there isn't one."

	| tallies |
	tallies _ self tallyPixelValues.
	1 to: tallies size do: [:i |
		(tallies at: i) = 0 ifTrue: [^ i]].
	^ 0
! !

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

ColorForm class
	instanceVariableNames: ''!

!ColorForm class methodsFor: 'as yet unclassified' stamp: 'nk 4/17/2004 19:44'!
mappingWhiteToTransparentFrom: aFormOrCursor
	"Return a ColorForm copied from the given Form or Cursor with white mapped to transparent."

	| f map |
	aFormOrCursor depth <= 8 ifFalse: [
		^ self error: 'argument depth must be 8-bits per pixel or less'].
	(aFormOrCursor isColorForm) ifTrue: [
		f _ aFormOrCursor deepCopy.
		map _ aFormOrCursor colors.
	] ifFalse: [
		f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth.
		f copyBits: aFormOrCursor boundingBox
			from: aFormOrCursor
			at: 0@0
			clippingBox: aFormOrCursor boundingBox
			rule: Form over
			fillColor: nil.
		map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)].
	map _ map collect: [:c |
		c = Color white ifTrue: [Color transparent] ifFalse: [c]].
	f colors: map.
	^ f
! !

!ColorForm class methodsFor: 'as yet unclassified'!
twoToneFromDisplay: aRectangle using: oldForm backgroundColor: bgColor
	"Return a 1-bit deep ColorForm copied from the given rectangle of the display. All colors except the background color will be mapped to black."

	| f |
	((oldForm ~~ nil) and: [oldForm extent = aRectangle extent]) ifTrue: [
		f _ oldForm fromDisplay: aRectangle.
	] ifFalse: [
		f _ ColorForm extent: aRectangle extent depth: 1.
		f twoToneFromDisplay: aRectangle backgroundColor: bgColor.
		f colors: (Array
			with: bgColor
			with: Color black)].
	^ f
! !
Object subclass: #ColorMap
	instanceVariableNames: 'shifts masks colors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:54'!
alphaMask
	^masks at: 4! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:55'!
alphaMask: value
	masks at: 4 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
alphaShift
	^shifts at: 4! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
alphaShift: value
	shifts at: 4 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'!
at: index
	^colors at: index! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'!
at: index put: value
	^colors at: index put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
blueMask
	^masks at: 3! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
blueMask: value
	masks at: 3 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
blueShift
	^shifts at: 3! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'!
blueShift: value
	shifts at: 3 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 2/10/2000 17:12'!
colors
	^colors! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'!
greenMask
	^masks at: 2! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'!
greenMask: value
	masks at: 2 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'!
greenShift
	^shifts at: 2! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'!
greenShift: value
	shifts at: 2 put: value.! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 5/28/2000 22:08'!
inverseMap
	"Return the inverse map of the receiver"
	| newMasks newShifts |
	colors ifNotNil:[^self error:'Not yet implemented'].
	newMasks _ WriteStream on: (Array new: 4).
	newShifts _ WriteStream on: (Array new: 4).
	masks with: shifts do:[:mask :shift|
		newMasks nextPut: (mask bitShift: shift).
		newShifts nextPut: shift negated].
	^ColorMap
		shifts: newShifts contents
		masks: newMasks contents! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'!
masks
	^masks! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'!
redMask
	^masks at: 1! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'!
redMask: value
	masks at: 1 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'!
redShift
	^shifts at: 1! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'!
redShift: value
	shifts at: 1 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:48'!
rgbaBitMasks
	"Return the rgba bit masks for the receiver"
	^masks asArray with: shifts collect:[:m :s| m bitShift: s]! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'!
shifts
	^shifts! !


!ColorMap methodsFor: 'comparing' stamp: 'tk 7/5/2001 21:59'!
= aColorMap
	"Return true if the receiver is equal to aColorMap"
	self species == aColorMap species ifFalse:[^false].
	self isIndexed == aColorMap isIndexed ifFalse:[^false].
	^self colors = aColorMap colors and:[
		self shifts = aColorMap shifts and:[
			self masks = aColorMap masks]]! !

!ColorMap methodsFor: 'comparing' stamp: 'ar 5/27/2000 19:29'!
hash
	"Hash is re-implemented because #= is re-implemented"
	^colors hash bitXor: (shifts hash bitXor: masks hash)! !


!ColorMap methodsFor: 'pixel mapping' stamp: 'ar 5/15/2001 16:12'!
mapPixel: pixelValue
	"Perform a forward pixel mapping operation"
	| pv |
	(shifts == nil and:[masks == nil]) ifFalse:[
		pv _ (((pixelValue bitAnd: self redMask) bitShift: self redShift) bitOr:
			((pixelValue bitAnd: self greenMask) bitShift: self greenShift)) bitOr:
			(((pixelValue bitAnd: self blueMask) bitShift: self blueShift) bitOr:
			((pixelValue bitAnd: self alphaMask) bitShift: self alphaShift)).
	] ifTrue:[pv _ pixelValue].
	colors ifNotNil:[pv _ colors at: pv].
	"Need to check for translucency else Form>>paint goes gaga"
	pv = 0 ifTrue:[pixelValue = 0 ifFalse:[pv _ 1]].
	^pv! !

!ColorMap methodsFor: 'pixel mapping' stamp: 'ar 6/8/2000 20:36'!
mappingTo: aColorMap
	"Compute a new color map through the receiver and aColorMap.
	Both maps are assumed to be mappings into canonical ARGB space"
	| fixedMap |
	self = aColorMap ifTrue:[^nil]. "No mapping needed"
	aColorMap isIndexed ifTrue:[^nil]. "We can't compute mappings to an indexed map yet"
	fixedMap _ self class mappingFrom: self rgbaBitMasks to: aColorMap rgbaBitMasks.
	self isIndexed ifFalse:[^fixedMap].
	"If the receiver is indexed then we need to map the colors as well"
	self flag: #untested.
	^ColorMap
		shifts: fixedMap shifts
		masks: fixedMap masks
		colors: (colors collect:[:pv| aColorMap pixelMap: pv]).
! !

!ColorMap methodsFor: 'pixel mapping' stamp: 'ar 5/15/2001 16:12'!
pixelMap: pixelValue
	"Perform a reverse pixel mapping operation"
	| pv |
	colors == nil
		ifTrue:[pv _ pixelValue]
		ifFalse:[pv _ colors at: pixelValue].
	(shifts == nil and:[masks == nil]) 
		ifFalse:[pv _ (((pv bitAnd: self redMask) bitShift: self redShift) bitOr: 
				((pv bitAnd: self greenMask) bitShift: self greenShift)) bitOr:
					(((pv bitAnd: self blueMask) bitShift: self blueShift) bitOr: 
						((pv bitAnd: self alphaMask) bitShift: self alphaShift))].
	"Need to check for translucency else Form>>paint goes gaga"
	pv = 0 ifTrue:[pixelValue = 0 ifFalse:[pv _ 1]].
	^pv! !


!ColorMap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:41'!
isColormap
	^true! !

!ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'!
isFixed
	"Return true if the receiver does not use a lookup mechanism for pixel mapping"
	^self isIndexed not! !

!ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'!
isIndexed
	"Return true if the receiver uses a lookup mechanism for pixel mapping"
	^colors notNil! !


!ColorMap methodsFor: 'private' stamp: 'ar 2/22/2000 16:47'!
setShifts: shiftArray masks: maskArray colors: colorArray
	shiftArray ifNotNil:[shifts _ shiftArray asIntegerArray].
	maskArray ifNotNil:[masks _ maskArray asWordArray].
	colorArray ifNotNil:[colors _ colorArray asWordArray].! !

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

ColorMap class
	instanceVariableNames: ''!

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 2/22/2000 14:08'!
colors: colorArray
	^self new setShifts: nil masks: nil colors: colorArray! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:09'!
mapBitsFrom: srcBitMask to: dstBitMask
	"Return an array consisting of the shift and the mask for
	mapping component values out of srcBitMask and into dstBitMask.
	While this computation is somewhat complicated it eases the batch
	conversion of all the pixels in BitBlt."
	| srcBits dstBits srcLow srcHigh dstLow dstHigh bits mask shift |
	(srcBitMask = 0 or:[dstBitMask = 0]) ifTrue:[^#(0 0)]. "Zero mask and shift"
	"Compute low and high bit position for source and dest bit mask"
	srcLow _ srcBitMask lowBit - 1.	srcHigh _ srcBitMask highBit.
	dstLow _ dstBitMask lowBit - 1.	dstHigh _ dstBitMask highBit.
	"Compute the number of bits in source and dest bit mask"
	srcBits _ srcHigh - srcLow.		dstBits _ dstHigh - dstLow.
	"Compute the maximum number of bits we can transfer inbetween"
	bits _ srcBits min: dstBits.
	"Compute the (unshifted) transfer mask"
	mask _ (1 bitShift: bits) - 1.
	"Shift the transfer mask to the mask the highest n bits of srcBitMask"
	mask _ mask bitShift: (srcHigh - bits).
	"Compute the delta shift so that the most significant bit of the
	source bit mask falls on the most significant bit of the dest bit mask.
	Note that delta is used for #bitShift: so
		shift > 0 : shift right
		shift < 0 : shift left
	e.g., if dstHigh > srcHigh we need to shift left and if dstHigh < srcHigh
	we need to shift right. This leads to:"
	shift _ dstHigh - srcHigh.
	"And that's all we need"
	^Array with: shift with: mask! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 19:41'!
mappingFrom: srcBitMasks to: dstBitMasks
	"Return a color map mapping from the array of source bit masks
	to the array of dest bit masks."
	| shifts masks shiftAndMask |
	shifts _ IntegerArray new: 4.
	masks _ WordArray new: 4.
	1 to: 4 do:[:i|
		shiftAndMask _ self mapBitsFrom: (srcBitMasks at: i) to: (dstBitMasks at: i).
		shifts at: i put: (shiftAndMask at: 1).
		masks at: i put: (shiftAndMask at: 2).
	].
	^self shifts: shifts masks: masks! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:08'!
mappingFromARGB: dstBitMasks
	"Return a ColorMap mapping from canonical ARGB space into dstBitMasks"
	^self mappingFrom: #(16rFF0000 16rFF00 16rFF 16rFF000000) to: dstBitMasks! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:08'!
mappingToARGB: srcBitMasks
	"Return a ColorMap mapping from srcBitMasks into canonical ARGB space"
	^self mappingFrom: srcBitMasks to: #(16rFF0000 16rFF00 16rFF 16rFF000000)! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/4/2001 15:59'!
masks: maskArray shifts: shiftArray
	^self shifts: shiftArray masks: maskArray colors: nil.! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'!
shifts: shiftArray masks: maskArray
	^self shifts: shiftArray masks: maskArray colors: nil.! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'!
shifts: shiftArray masks: maskArray colors: colorArray
	^self new setShifts: shiftArray masks: maskArray colors: colorArray! !
Canvas subclass: #ColorMappingCanvas
	instanceVariableNames: 'myCanvas'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:40'!
clipRect
	^myCanvas clipRect! !

!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'!
depth
	^myCanvas depth! !

!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'!
extent
	^myCanvas extent! !

!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/24/1999 17:54'!
form
	^myCanvas form! !

!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'!
origin
	^myCanvas origin! !


!ColorMappingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:15'!
line: pt1 to: pt2 width: w color: c
	"Draw a line using the given width and color"
	myCanvas
		line: pt1
		to: pt2
		width: w
		color: (self mapColor: c).! !

!ColorMappingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:16'!
paragraph: paragraph bounds: bounds color: c
	"Draw the given paragraph"
	myCanvas
		paragraph: paragraph
		bounds: bounds
		color: (self mapColor: c)! !


!ColorMappingCanvas methodsFor: 'drawing-images' stamp: 'ar 6/24/1999 18:26'!
stencil: aForm at: aPoint color: aColor
	myCanvas
		stencil: aForm
		at: aPoint
		color: (self mapColor: aColor)! !

!ColorMappingCanvas methodsFor: 'drawing-images' stamp: 'ar 6/24/1999 18:26'!
stencil: aForm at: aPoint sourceRect: aRect color: aColor
	myCanvas
		stencil: aForm
		at: aPoint
		sourceRect: aRect
		color: (self mapColor: aColor)! !


!ColorMappingCanvas methodsFor: 'drawing-ovals' stamp: 'ar 6/22/1999 17:59'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Fill the given oval."
	myCanvas
		fillOval: r
		color: (self mapColor: c)
		borderWidth: borderWidth
		borderColor: (self mapColor: borderColor)! !


!ColorMappingCanvas methodsFor: 'drawing-polygons' stamp: 'mir 9/12/2001 14:24'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Draw the given polygon."
	^myCanvas
		drawPolygon: vertices
		color: aColor
		borderWidth: bw
		borderColor: (self mapColor: bc)! !


!ColorMappingCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/22/1999 17:59'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Draw the rectangle using the given attributes"
	myCanvas
		frameAndFillRectangle: r
		fillColor: (self mapColor: fillColor)
		borderWidth: borderWidth
		borderColor: (self mapColor: borderColor)! !

!ColorMappingCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/22/1999 18:01'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
	"Draw the rectangle using the given attributes"
	myCanvas
		frameAndFillRectangle: r 
		fillColor: (self mapColor: fillColor) 
		borderWidth: borderWidth 
		topLeftColor: (self mapColor: topLeftColor)
		bottomRightColor: (self mapColor: bottomRightColor)! !


!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:19'!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas clipBy: aRectangle during:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas! !

!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:19'!
preserveStateDuring: aBlock
	"Preserve the full canvas state during the execution of aBlock"
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas preserveStateDuring:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas.! !

!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 16:01'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock	 smoothing: cellSize

	"Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas transformBy: aDisplayTransform
		clippingTo: aClipRect
		during: [:newCanvas |
				myCanvas _ newCanvas.
				aBlock value: self]
		smoothing: cellSize.
	myCanvas _ oldCanvas.! !

!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:22'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas translateBy: delta during:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas.! !

!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:22'!
translateTo: newOrigin clippingTo: aRectangle during: aBlock
	"Set a new origin and clipping rectangle only during the execution of aBlock."
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas translateTo: newOrigin clippingTo: aRectangle during:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas.! !


!ColorMappingCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	"Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used."
	myCanvas
		drawString: s from: firstIndex to: lastIndex 
		in: boundsRect 
		font: fontOrNil 
		color: (self mapColor: c)! !


!ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:24'!
flush
	myCanvas flush.! !

!ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:14'!
on: aCanvas
	myCanvas _ aCanvas.! !

!ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:23'!
reset
	myCanvas reset.! !


!ColorMappingCanvas methodsFor: 'other' stamp: 'ar 6/22/1999 18:21'!
translateBy: delta clippingTo: aRectangle during: aBlock
	"Set a translation and clipping rectangle only during the execution of aBlock."
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas translateBy: delta clippingTo: aRectangle during:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas.! !


!ColorMappingCanvas methodsFor: 'testing' stamp: 'ar 8/8/2001 14:16'!
isShadowDrawing
	^myCanvas isShadowDrawing! !


!ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'!
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."
	^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: rule.! !

!ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'!
mapColor: aColor
	^aColor! !

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

ColorMappingCanvas class
	instanceVariableNames: ''!

!ColorMappingCanvas class methodsFor: 'instance creation' stamp: 'ar 6/22/1999 18:23'!
on: aCanvas
	^self new on: aCanvas! !
FormCanvas subclass: #ColorPatchCanvas
	instanceVariableNames: 'stopMorph foundMorph doStop'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!ColorPatchCanvas commentStamp: '<historical>' prior: 0!
I generate patches of Morphic worlds that views below certain Morphs. This facility is used for the end-user scripting system.!


!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'!
doStop
	^doStop! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'!
doStop: aBoolean
	doStop _ aBoolean! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'!
foundMorph
	^foundMorph! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:38'!
foundMorph: aBoolean
	foundMorph _ aBoolean! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:14'!
stopMorph
	^stopMorph! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:14'!
stopMorph: aMorph
	stopMorph _ aMorph! !


!ColorPatchCanvas methodsFor: 'drawing-general' stamp: 'ar 6/22/1999 16:14'!
fullDrawMorph: aMorph
	(foundMorph and:[doStop]) ifTrue:[^self]. "Found it and should stop"
	aMorph == stopMorph ifTrue:[
		"Never draw the stopMorph"
		foundMorph _ true.
		^self].
	^super fullDrawMorph: aMorph.! !


!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:34'!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	| tempCanvas |
	tempCanvas _ (self copyClipRect: aRectangle).
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:42'!
preserveStateDuring: aBlock
	"Preserve the full canvas state during the execution of aBlock.
	Note: This does *not* include the state in the receiver (e.g., foundMorph)."
	| tempCanvas |
	tempCanvas _ self copy.
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 2/17/2000 00:15'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	"Note: This method has been originally copied from TransformationMorph."
	| innerRect patchRect sourceQuad warp start subCanvas |
	(aDisplayTransform isPureTranslation) ifTrue:[
		subCanvas _ self copyOffset: aDisplayTransform offset negated truncated
							clipRect: aClipRect.
		aBlock value: subCanvas.
		foundMorph _ subCanvas foundMorph.
		^self
	].
	"Prepare an appropriate warp from patch to innerRect"
	innerRect _ aClipRect.
	patchRect _ aDisplayTransform globalBoundsToLocal:
					(self clipRect intersect: innerRect).
	sourceQuad _ (aDisplayTransform sourceQuadFor: innerRect)
					collect: [:p | p - patchRect topLeft].
	warp _ self warpFrom: sourceQuad toRect: innerRect.
	warp cellSize: cellSize.

	"Render the submorphs visible in the clipping rectangle, as patchForm"
	start _ (self depth = 1 and: [self isShadowDrawing not])
		"If this is true B&W, then we need a first pass for erasure."
		ifTrue: [1] ifFalse: [2].
	start to: 2 do:
		[:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W"
		subCanvas _ ColorPatchCanvas extent: patchRect extent depth: self depth.
		subCanvas stopMorph: stopMorph.
		subCanvas foundMorph: foundMorph.
		subCanvas doStop: doStop.
		i=1	ifTrue: [subCanvas shadowColor: Color black.
					warp combinationRule: Form erase]
			ifFalse: [self isShadowDrawing ifTrue:
					[subCanvas shadowColor: self shadowColor].
					warp combinationRule: Form paint].
		subCanvas translateBy: patchRect topLeft negated
			during:[:offsetCanvas| aBlock value: offsetCanvas].
		i = 2 ifTrue:[foundMorph _ subCanvas foundMorph].
		warp sourceForm: subCanvas form; warpBits.
		warp sourceForm: nil.  subCanvas _ nil "release space for next loop"]
! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:39'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	| tempCanvas |
	tempCanvas _ self copyOffset: delta.
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:40'!
translateTo: newOrigin clippingTo: aRectangle during: aBlock
	"Set a new origin and clipping rectangle only during the execution of aBlock."
	| tempCanvas |
	tempCanvas _ self copyOrigin: newOrigin clipRect: aRectangle.
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !


!ColorPatchCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 16:18'!
reset
	"Initialize the receiver to act just as a FormCanvas"
	super reset.
	foundMorph _ false.
	doStop _ false.
	stopMorph _ nil.! !


!ColorPatchCanvas methodsFor: 'other' stamp: 'ar 6/22/1999 16:39'!
translateBy: delta clippingTo: aRectangle during: aBlock
	"Set a translation and clipping rectangle only during the execution of aBlock."
	| tempCanvas |
	tempCanvas _ self copyOffset: delta clipRect: aRectangle.
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !


!ColorPatchCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 16:18'!
setForm: aForm
	"Initialize the receiver to act just as a FormCanvas"
	super setForm: aForm.
	stopMorph _ nil.
	doStop _ false.
	foundMorph _ false.! !
SketchMorph subclass: #ColorPickerMorph
	instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency'
	classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransText TransparentBox'
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!ColorPickerMorph commentStamp: 'kfr 10/27/2003 16:16' prior: 0!
A gui for setting color and transparency. Behaviour can be changed with the Preference modalColorPickers.!


!ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:33'!
argument
	^argument! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:33'!
argument: anObject
	argument _ anObject! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
deleteOnMouseUp

	^ deleteOnMouseUp
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
deleteOnMouseUp: aBoolean

	deleteOnMouseUp _ aBoolean.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 8/25/2001 20:44'!
locationIndicator
	| loc |
	^self valueOfProperty: #locationIndicator ifAbsent:[
		loc _ EllipseMorph new.
		loc color: Color transparent; 
			borderWidth: 1; 
			borderColor: Color red; 
			extent: 6@6.
		self setProperty: #locationIndicator toValue: loc.
		self addMorphFront: loc.
		loc]! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'KR 12/9/2005 22:51'!
originalColor: colorOrSymbol 
	"Set the receiver's original color.  It is at this point that a command is launched to represent the action of the picker, in support of Undo."

	originalColor := (colorOrSymbol isColor) 
				ifTrue: [colorOrSymbol]
				ifFalse: [Color lightGreen].
	originalForm fill: RevertBox fillColor: originalColor.
	selectedColor := originalColor.
	self updateAlpha: originalColor alpha.
	self locationIndicator 
		center: self topLeft + (self positionOfColor: originalColor)! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
selectedColor

	^ selectedColor
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
selector

	^ selector
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'di 8/30/2000 13:40'!
selector: aSymbol
	"Set the selector to be associated with the receiver.  Store it in the receiver's command, if appropriate"

	selector _ aSymbol.
	self updateSelectorDisplay! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
sourceHand

	^ sourceHand
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
sourceHand: aHand

	sourceHand _ aHand.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
target

	^ target
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'aoy 2/15/2003 21:24'!
target: anObject 
	target := anObject.
	selectedColor := (target respondsTo: #color)  
				ifTrue: [target color]
				ifFalse: [Color white]! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
updateContinuously

	^ updateContinuously
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
updateContinuously: aBoolean

	updateContinuously _ aBoolean.
! !


!ColorPickerMorph methodsFor: 'drawing' stamp: 'di 9/3/1999 13:34'!
drawOn: aCanvas
	aCanvas depth = 1 ifTrue: [aCanvas fillRectangle: self bounds color: Color white].
	Display depth = originalForm depth ifFalse: [self buildChartForm].
	super drawOn: aCanvas! !


!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

	^ true
! !

!ColorPickerMorph methodsFor: 'event handling' stamp: 'RAA 2/19/2001 13:16'!
inhibitDragging

	^self hasProperty: #noDraggingThisPicker! !

!ColorPickerMorph methodsFor: 'event handling' stamp: 'RAA 2/19/2001 13:17'!
mouseDown: evt
	| localPt |
	localPt _ evt cursorPoint - self topLeft.
	self deleteAllBalloons.
	clickedTranslucency _ TransparentBox containsPoint: localPt.
	self inhibitDragging ifFalse: [
		(DragBox containsPoint: localPt)
			ifTrue: [^ evt hand grabMorph: self].
	].
	(RevertBox containsPoint: localPt)
		ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].
	self inhibitDragging ifFalse: [self comeToFront].
	sourceHand _ evt hand.
	self startStepping.
! !

!ColorPickerMorph methodsFor: 'event handling' stamp: 'yo 9/29/2004 10:24'!
mouseUp: evt

	| c |
	self stopStepping.
	sourceHand _ nil.
	deleteOnMouseUp ifTrue: [self delete].
	c _ self getColorFromKedamaWorldIfPossible: evt cursorPoint.
	c ifNotNil: [selectedColor _ c].
	self updateTargetColor.
! !


!ColorPickerMorph methodsFor: 'geometry testing' stamp: 'LC 2/2/2000 04:28'!
containsPoint: aPoint 
	^ (super containsPoint: aPoint)
		or: [RevertBox containsPoint: aPoint - self topLeft]! !


!ColorPickerMorph methodsFor: 'halos and balloon help' stamp: 'sw 7/6/1999 09:07'!
isLikelyRecipientForMouseOverHalos
	^ false! !


!ColorPickerMorph methodsFor: 'initialization' stamp: 'di 9/28/2000 12:05'!
buildChartForm
	| chartForm |
	chartForm _ ColorChart deepCopy asFormOfDepth: Display depth.
	chartForm fill: ((TransparentBox left + 9)@0 extent: 1@9) fillColor: Color lightGray.
	chartForm fill: ((TransparentBox right - 10)@0 extent: 1@9) fillColor: Color lightGray.
	TransText displayOn: chartForm at: 62@0.
	Display depth = 32 ifTrue:
		["Set opaque bits for 32-bit display"
		chartForm fill: chartForm boundingBox rule: Form under
				fillColor: (Color r: 0.0 g: 0.0 b: 0.0 alpha: 1.0)].
	chartForm borderWidth: 1.
	self form: chartForm.
	selectedColor ifNotNil: [self updateAlpha: selectedColor alpha].
	self updateSelectorDisplay.

! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'sw 9/8/2000 18:14'!
choseModalityFromPreference
	"Decide whether to be modal or not by consulting the prevailing preference"

	self initializeModal: Preferences modalColorPickers! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'ar 9/4/2001 13:26'!
initialize
	"Initialize the receiver.  Obey the modalColorPickers preference when deciding how to configure myself.  This is not quite satisfactory -- we'd like to have explicit calls tell us things like whether whether to be modal, whether to allow transparency, but for the moment, in grand Morphic fashion, this is rather inflexibly all housed right here"

	super initialize.
	self clipSubmorphs: true.
	self buildChartForm.
	
	selectedColor _ Color white.
	sourceHand _ nil.
	deleteOnMouseUp _ false.
	clickedTranslucency _ false.
	updateContinuously _ true.
	selector _ nil.
	target _ nil! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'yo 2/23/2005 17:17'!
initializeForPropertiesPanel
	"Initialize the receiver.  If beModal is true, it will be a modal color picker, else not"

	isModal _ false.
	self removeAllMorphs.
	self setProperty: #noDraggingThisPicker toValue: true.

	self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'restore original color' translated).
	self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'shows selected color' translated).
	self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'adjust translucency' translated).

	self buildChartForm.
	
	selectedColor ifNil: [selectedColor _ Color white].
	sourceHand _ nil.
	deleteOnMouseUp _ false.
	updateContinuously _ true.
! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'yo 2/23/2005 17:13'!
initializeModal: beModal
	"Initialize the receiver.  If beModal is true, it will be a modal color picker, else not"

	isModal _ beModal.
	self removeAllMorphs.
	isModal ifFalse:
		[theSelectorDisplayMorph _ AlignmentMorph newRow
			color: Color white;
			borderWidth: 1;
			borderColor: Color red;
			hResizing: #shrinkWrap;
			vResizing: #shrinkWrap;
			addMorph: (StringMorph contents: 'theSelector' translated).
		self addMorph: theSelectorDisplayMorph.

		self addMorph: (SimpleButtonMorph new borderWidth: 0;
			label: 'x' font: nil; color: Color transparent;
			actionSelector: #delete; target: self; useSquareCorners;
			position: self topLeft - (0@3); extent: 10@12;
			setCenteredBalloonText: 'dismiss color picker' translated)].

	self addMorph: ((Morph newBounds: (DragBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'put me somewhere' translated).
	self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'restore original color' translated).
	self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'shows selected color' translated).
	self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'adjust translucency' translated).

	self buildChartForm.
	
	selectedColor ifNil: [selectedColor _ Color white].
	sourceHand _ nil.
	deleteOnMouseUp _ false.
	updateContinuously _ true.
! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'sma 4/22/2000 19:39'!
updateSelectorDisplay
	theSelectorDisplayMorph ifNil: [^self].
	theSelectorDisplayMorph position: self bottomLeft.
	theSelectorDisplayMorph firstSubmorph contents: selector asString , ' ' , selectedColor printString! !


!ColorPickerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	deleteOnMouseUp
		ifTrue: [aCustomMenu add: 'stay up' translated action: #toggleDeleteOnMouseUp]
		ifFalse: [aCustomMenu add: 'do not stay up' translated action: #toggleDeleteOnMouseUp].
	updateContinuously
		ifTrue: [aCustomMenu add: 'update only at end' translated action: #toggleUpdateContinuously]
		ifFalse: [aCustomMenu add: 'update continuously' translated action: #toggleUpdateContinuously].
! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'yo 9/29/2004 10:38'!
pickUpColorFor: aMorph
	"Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle"

      | aHand localPt c |
	aHand _ aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand].
	aHand ifNil: [aHand _ self currentHand].
	self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullBounds.
	self owner ifNil: [^ self].

	aHand showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper) 
			hotSpotOffset: 6 negated @ 4 negated.    "<<<< the form was changed a bit??"

	self updateContinuously: false.
	[Sensor anyButtonPressed]
		whileFalse: 
			 [self trackColorUnderMouse].
	self deleteAllBalloons.

	localPt _ Sensor cursorPoint - self topLeft.
	self inhibitDragging ifFalse: [
		(DragBox containsPoint: localPt) ifTrue:
			["Click or drag the drag-dot means to anchor as a modeless picker"
			^ self anchorAndRunModeless: aHand].
	].
	(clickedTranslucency _ TransparentBox containsPoint: localPt)
		ifTrue: [selectedColor _ originalColor].

	self updateContinuously: true.
	[Sensor anyButtonPressed]
		whileTrue:
			 [self updateTargetColorWith: self indicateColorUnderMouse].
	c _ self getColorFromKedamaWorldIfPossible: Sensor cursorPoint.
	c ifNotNil: [selectedColor _ c].
	aHand newMouseFocus: nil;
		showTemporaryCursor: nil;
		flushEvents.
	self delete.
		 
 ! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
toggleDeleteOnMouseUp

	deleteOnMouseUp _ deleteOnMouseUp not.
! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
toggleUpdateContinuously

	updateContinuously _ updateContinuously not.
! !


!ColorPickerMorph methodsFor: 'other' stamp: 'di 11/27/1999 09:12'!
addToWorld: world near: box
	| goodLocation |
	goodLocation _ self bestPositionNear: box inWorld: world.
	world allMorphsDo:
		[:p | (p isMemberOf: ColorPickerMorph) ifTrue:
		[(p ~~ self and: [p owner notNil and: [p target == target]]) ifTrue:
			[(p selector == selector and: [p argument == argument])
				ifTrue: [^ p comeToFront  "uncover existing picker"]
				ifFalse: ["place second picker relative to first"
						goodLocation _ self bestPositionNear: p bounds inWorld: world]]]].
	self position: goodLocation.
	world addMorphFront: self.
	self changed
! !

!ColorPickerMorph methodsFor: 'other' stamp: 'di 11/27/1999 08:51'!
bestPositionNear: box inWorld: world
	| points b |
	points _ #(topCenter rightCenter bottomCenter leftCenter).  "possible anchors"
	1 to: 4 do:
		[:i |  "Try the four obvious anchor points"
		b _ self bounds align: (self bounds perform: (points at: i))
					with: (box perform: (points atWrap: i + 2)).
		(world viewBox containsRect: b) ifTrue:
			[^ b topLeft"  Yes, it fits"]].

	^ 20@20  "when all else fails"
! !

!ColorPickerMorph methodsFor: 'other' stamp: 'di 9/25/2000 15:38'!
indicateColorUnderMouse
	"Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color."

	| pt |
	self pickColorAt: (pt _ Sensor cursorPoint).
	isModal ifTrue:
		[self activeHand position: pt.
		self world displayWorldSafely; runStepMethods].
	^ selectedColor	! !

!ColorPickerMorph methodsFor: 'other' stamp: 'ar 12/8/2000 15:32'!
putUpFor: aMorph near: aRectangle
	"Put the receiver up on the screen.   Note highly variant behavior depending on the setting of the #modalColorPickers preference"
	| layerNumber |
	aMorph isMorph ifTrue: [
		layerNumber _ aMorph morphicLayerNumber.
		aMorph allOwnersDo:[:m|
			layerNumber _ layerNumber min: m morphicLayerNumber].
		self setProperty: #morphicLayerNumber toValue: layerNumber - 0.1
	].

	isModal == true "backward compatibility"
		ifTrue:
			[self pickUpColorFor: aMorph]
		ifFalse:
			[self addToWorld:
				((aMorph notNil and: [aMorph world notNil])
					ifTrue:
						[aMorph world]
					ifFalse:
						[self currentWorld])
		  		near:
					(aRectangle ifNil:
						[aMorph ifNil: [100@100 extent: 1@1] ifNotNil: [aMorph fullBoundsInWorld]])]! !

!ColorPickerMorph methodsFor: 'other' stamp: 'di 9/27/2000 11:48'!
trackColorUnderMouse
	"Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color."

	| pt |
	selectedColor _ originalColor.
	self trackColorAt: (pt _ Sensor cursorPoint).
	isModal ifTrue:
		[self activeHand position: pt.
		self world displayWorldSafely; runStepMethods.
		self modalBalloonHelpAtPoint: pt].
	^ selectedColor	! !


!ColorPickerMorph methodsFor: 'stepping and presenter' stamp: 'jm 11/4/97 07:15'!
step

	sourceHand ifNotNil:
		[self pickColorAt: sourceHand position].
! !


!ColorPickerMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 4/17/2004 19:34'!
delete
	"The moment of departure has come.
	If the receiver has an affiliated command, finalize it and have the system remember it.
	In any case, delete the receiver"

	(selector isNil or: [ target isNil ]) ifFalse: [
		self rememberCommand: 
			(Command new
				cmdWording: 'color change' translated;
				undoTarget: target selector: selector arguments: (self argumentsWith: originalColor);
				redoTarget: target selector: selector arguments: (self argumentsWith: selectedColor)).
	].
	super delete! !


!ColorPickerMorph methodsFor: 'testing' stamp: 'jm 11/4/97 07:15'!
stepTime

	^ 50
! !


!ColorPickerMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 7/6/1999 09:00'!
isCandidateForAutomaticViewing
	^ false! !


!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/27/2000 10:36'!
anchorAndRunModeless: aHand
	"If user clicks on the drag-dot of a modal picker,
	anchor it, and change to modeless operation."

	aHand showTemporaryCursor: nil.  "revert to normal cursor"
	self initializeModal: false; originalColor: originalColor.  "reset as modeless"
	aHand flushEvents.  "Drop any events gathered during modal loop"
	aHand position: Sensor cursorPoint; grabMorph: self.  "Slip into drag operation"
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'ar 7/19/2003 20:40'!
argumentsWith: aColor
	"Return an argument array appropriate to this action selector"

	| nArgs |
	nArgs _ selector ifNil:[0] ifNotNil:[selector numArgs].
	nArgs = 0 ifTrue:[^#()].
	nArgs = 1 ifTrue:[^ {aColor}].
	nArgs = 2 ifTrue:[^ {aColor. sourceHand}].
	nArgs = 3 ifTrue:[^ {aColor. argument. sourceHand}].
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/27/2000 12:55'!
deleteAllBalloons

	self submorphsDo: [:m | m deleteBalloon].
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:59'!
modalBalloonHelpAtPoint: cursorPoint 
	self flag: #arNote.	"Throw this away. There needs to be another way."
	self submorphsDo: 
			[:m | 
			m wantsBalloon 
				ifTrue: 
					[(m valueOfProperty: #balloon) isNil
						ifTrue: 
							[(m containsPoint: cursorPoint) ifTrue: [m showBalloon: m balloonText]]
						ifFalse: [(m containsPoint: cursorPoint) ifFalse: [m deleteBalloon]]]]! !

!ColorPickerMorph methodsFor: 'private' stamp: 'yo 9/29/2004 10:57'!
pickColorAt: aGlobalPoint 

	| alpha selfRelativePoint pickedColor c |
	clickedTranslucency ifNil: [clickedTranslucency _ false].
	selfRelativePoint _ (self globalPointToLocal: aGlobalPoint) - self topLeft.
	(FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self].
	(RevertBox containsPoint: selfRelativePoint)
		ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].

	"check for transparent color and update using appropriate feedback color "
	(TransparentBox containsPoint: selfRelativePoint) ifTrue:
		[clickedTranslucency ifFalse: [^ self].  "Can't wander into translucency control"
		alpha _ (selfRelativePoint x - TransparentBox left - 10) asFloat /
							(TransparentBox width - 20)
							min: 1.0 max: 0.0.
					"(alpha roundTo: 0.01) printString , '   ' displayAt: 0@0." " -- debug"
		self 
			updateColor: (selectedColor alpha: alpha)
			feedbackColor: (selectedColor alpha: alpha).
		^ self].

	"pick up color, either inside or outside this world"
	clickedTranslucency ifTrue: [^ self].  "Can't wander out of translucency control"
	self locationIndicator visible: false. self refreshWorld.
	pickedColor _ Display colorAt: aGlobalPoint.
	c _ self getColorFromKedamaWorldIfPossible: aGlobalPoint.
	c ifNotNil: [pickedColor _ c].
	self locationIndicator visible: true. self refreshWorld.
	self 
		updateColor: (
			(selectedColor isColor and: [selectedColor isTranslucentColor])
						ifTrue: [pickedColor alpha: selectedColor alpha]
						ifFalse: [pickedColor]
		)
		feedbackColor: pickedColor! !

!ColorPickerMorph methodsFor: 'private' stamp: 'ar 9/4/2001 13:27'!
positionOfColor: aColor
	"Compute the position of the given color in the color chart form"
	| rgbRect x y h s v |
	rgbRect _ (0@0 extent: originalForm boundingBox extent) insetBy: (1@10 corner: 11@1).
	h _ aColor hue.
	s _ aColor saturation.
	v _ aColor brightness.
	h = 0.0 ifTrue:["gray"
		^(rgbRect right + 6) @ (rgbRect height * (1.0 - v) + rgbRect top)].
	x _ (h + 22 \\ 360 / 360.0 * rgbRect width) rounded.
	y _ 0.5.
	s < 1.0 ifTrue:[y _ y - (1.0 - s * 0.5)].
	v < 1.0 ifTrue:[y _ y + (1.0 - v * 0.5)].
	y _ (y * rgbRect height) rounded.
	^x@y + (1@10)! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/30/2000 10:07'!
trackColorAt: aGlobalPoint 
	"Before the mouse comes down in a modal color picker, track the color under the cursor, and show it in the feedback box, but do not make transparency changes"

	| selfRelativePoint pickedColor |
	selfRelativePoint _ (self globalPointToLocal: aGlobalPoint) - self topLeft.
	(FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self].
	(RevertBox containsPoint: selfRelativePoint)
		ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].

	"check for transparent color and update using appropriate feedback color "
	(TransparentBox containsPoint: selfRelativePoint) ifTrue: [^ self].

	"pick up color, either inside or outside this world"
	pickedColor _ Display colorAt: aGlobalPoint.
	self updateColor: (pickedColor alpha: originalColor alpha)
		feedbackColor: pickedColor! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/28/2000 11:10'!
updateAlpha: alpha
	| sliderRect |
	sliderRect _ (TransparentBox left + 10)@1 corner: (TransparentBox right - 9)@9.
	originalForm fill: (sliderRect withRight: sliderRect left + (alpha*sliderRect width))
				fillColor: Color lightGray.
	originalForm fillWhite: (sliderRect withLeft: sliderRect left + (alpha*sliderRect width)).
	originalForm fill: ((TransparentBox right - 9)@1 extent: 8@8)
				fillColor: (alpha < 1.0 ifTrue: [Color white] ifFalse: [Color lightGray]).
	TransText displayOn: originalForm at: 62@1 rule: Form paint.
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'ar 8/25/2001 20:50'!
updateColor: aColor feedbackColor: feedbackColor
	"Set my selected color to the given color if it is different. Give user feedback. Inform the target of the change if the target and selector are not nil." 

	selectedColor = aColor ifTrue: [^ self].  "do nothing if color doesn't change"

	self updateAlpha: aColor alpha.
	originalForm fill: FeedbackBox fillColor: feedbackColor.
	self form: originalForm.
	selectedColor _ aColor.
	updateContinuously ifTrue: [self updateTargetColor].
	self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).! !

!ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:41'!
updateTargetColor
	| nArgs |
	(target notNil and: [selector notNil]) 
		ifTrue: 
			[self updateSelectorDisplay.
			nArgs := selector numArgs.
			nArgs = 1 ifTrue: [^target perform: selector with: selectedColor].
			nArgs = 2 
				ifTrue: 
					[^target 
						perform: selector
						with: selectedColor
						with: sourceHand].
			nArgs = 3 
				ifTrue: 
					[^target 
						perform: selector
						with: selectedColor
						with: argument
						with: sourceHand]]! !

!ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:41'!
updateTargetColorWith: aColor 
	"Update the target so that it reflects aColor as the color choice"

	(target notNil and: [selector notNil]) 
		ifTrue: 
			[self updateSelectorDisplay.
			^target perform: selector withArguments: (self argumentsWith: aColor)]! !


!ColorPickerMorph methodsFor: 'kedama' stamp: 'yo 9/29/2004 10:43'!
getColorFromKedamaWorldIfPossible: aGlobalPoint

	self world submorphs do: [:sub |
		 (sub isKindOf: KedamaMorph) ifTrue: [
			sub morphsAt: aGlobalPoint unlocked: false do: [:e |
				^ e colorAt: (aGlobalPoint - e topLeft).
			].
		].
	].
	^ nil.
! !

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

ColorPickerMorph class
	instanceVariableNames: ''!

!ColorPickerMorph class methodsFor: 'as yet unclassified' stamp: 'sw 10/27/1999 11:40'!
perniciousBorderColor
	"Answer the color of the border lines of a color picker; this color gets reported as you drag the mouse through from the translucent box to the true color area, for example, and can cause some difficulties in some special cases, so it is faithfully reported here in this hard-coded fashion in order that energetic clients wishing to handle it as special-case it can do so."

	^ Color r: 0.0 g: 0.0 b: 0.032! !


!ColorPickerMorph class methodsFor: 'class initialization' stamp: 'ar 7/8/2006 20:32'!
colorPaletteForDepth: depth extent: chartExtent
	"Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
	"Note: It is slow to build this palette, so it should be cached for quick access."
	"(Color colorPaletteForDepth: 16 extent: 190@60) display"

	| basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps |
	palette _ Form extent: chartExtent depth: depth.
	transCaption _ "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
		(Form extent: 34@9 depth: 1
			fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
			offset: 0@0).
	transHt _ transCaption height.
	palette fillWhite: (0@0 extent: palette width@transHt).
	palette fillBlack: (0@transHt extent: palette width@1).
	transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
	grayWidth _ 10.
	startHue _ 338.0.
	vSteps _ palette height - transHt // 2.
	hSteps _ palette width - grayWidth.
	x _ 0.
	startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h |
		basicHue _ Color h: h asFloat s: 1.0 v: 1.0.
		y _ transHt+1.
		0 to: vSteps do: [:n |
 			c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		1 to: vSteps do: [:n |
 			c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		x _ x + 1].
	y _ transHt + 1.
	1 to: vSteps * 2 do: [:n |
 		c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
		palette fill: (x@y extent: 10@1) fillColor: c.
		y _ y + 1].
	^ palette
! !

!ColorPickerMorph class methodsFor: 'class initialization' stamp: 'ar 7/8/2006 20:33'!
initialize
	"ColorPickerMorph initialize"

	ColorChart _ ColorPickerMorph colorPaletteForDepth: 16 extent: 190@60.
	DragBox _  (11@0) extent: 9@8.
	RevertBox _ (ColorChart width - 20)@1 extent: 9@8.
	FeedbackBox _ (ColorChart width - 10)@1 extent: 9@8.
	TransparentBox _ DragBox topRight corner: RevertBox bottomLeft.

		ColorChart fillBlack: ((DragBox left - 1)@0 extent: 1@9).
		ColorChart fillBlack: ((TransparentBox left)@0 extent: 1@9).
		ColorChart fillBlack: ((FeedbackBox left - 1)@0 extent: 1@9).
		ColorChart fillBlack: ((RevertBox left - 1)@0 extent: 1@9).
		(Form dotOfSize: 5) displayOn: ColorChart at: DragBox center + (0@1).

	self localeChanged.! !

!ColorPickerMorph class methodsFor: 'class initialization' stamp: 'tak 8/4/2005 14:26'!
localeChanged
	| formTranslator |
	formTranslator := NaturalLanguageFormTranslator localeID: Locale current localeID.
	TransText := formTranslator translate: 'translucent'.
	TransText
		ifNil: [TransText := Form
						extent: 63 @ 8
						depth: 1
						fromArray: #(4194306 1024 4194306 1024 15628058 2476592640 4887714 2485462016 1883804850 2486772764 4756618 2485462016 4748474 1939416064 0 0 )
						offset: 0 @ 0].
	TransText := ColorForm mappingWhiteToTransparentFrom: TransText! !

!ColorPickerMorph class methodsFor: 'class initialization' stamp: 'ar 7/8/2006 20:33'!
noColorCaption
	| formTranslator |
	formTranslator := NaturalLanguageFormTranslator localeID: Locale current localeID.
	^ (formTranslator translate: 'no color')
		ifNil: [Form
				extent: 34 @ 9
				depth: 1
				fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0 )
				offset: 0 @ 0]
! !
ColorTileMorph subclass: #ColorSeerTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!ColorSeerTile methodsFor: 'code generation' stamp: 'dgd 2/22/2003 14:25'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"color:sees:"
	^aStream
		nextPutAll: (parts first);
		space;
		nextPutAll: colorSwatch color printString;
		space;
		nextPutAll: (parts second)! !


!ColorSeerTile methodsFor: 'initialization' stamp: 'mir 7/12/2004 20:23'!
initialize
"initialize the state of the receiver"
	| m1 m2 desiredW wording |
	super initialize.
""
	self removeAllMorphs.
	"get rid of the parts of a regular Color tile"
	type _ #operator.
	operatorOrExpression _ #color:sees:.
	wording _ (Vocabulary eToyVocabulary
				methodInterfaceAt: operatorOrExpression
				ifAbsent: []) wording.
	m1 _ StringMorph contents: wording font: ScriptingSystem fontForTiles.
	m2 _ Morph new extent: 12 @ 8;
				
				color: (Color
						r: 0.8
						g: 0
						b: 0).
	desiredW _ m1 width + 6.
	self extent: (desiredW max: self basicWidth)
			@ self class defaultH.
	m1 position: bounds center x - (m1 width // 2) @ (bounds top + 5).
	m2 position: bounds center x - (m2 width // 2) + 3 @ (bounds top + 8).
	self addMorph: m1;
		 addMorphFront: m2.
	colorSwatch _ m2! !

!ColorSeerTile methodsFor: 'initialization' stamp: 'mir 7/15/2004 15:20'!
updateWordingToMatchVocabulary
	"The current vocabulary has changed; change the wording on my face, if appropriate"

	| aMethodInterface |
	aMethodInterface _ self currentVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: [Vocabulary eToyVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: [^ self]].
	self labelMorph contents: aMethodInterface wording.
	self setBalloonText: aMethodInterface helpMessage.! !
UpdatingRectangleMorph subclass: #ColorSwatch
	instanceVariableNames: 'argument'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Support'!

!ColorSwatch methodsFor: 'as yet unclassified' stamp: 'sw 7/13/1999 13:39'!
argument: arg
	argument _ arg! !


!ColorSwatch methodsFor: 'setting' stamp: 'sw 3/23/2001 12:12'!
setTargetColor: aColor
	"Set the target color as indicated"

	putSelector ifNotNil:
		[self color: aColor.
		contents _ aColor.
		target perform: self putSelector withArguments: (Array with: argument with: aColor)]
! !


!ColorSwatch methodsFor: 'target access' stamp: 'dgd 2/22/2003 13:32'!
readFromTarget
	"Obtain a value from the target and set it into my lastValue"

	| v |
	(target isNil or: [getSelector isNil]) ifTrue: [^contents].
	v := target perform: getSelector with: argument.
	lastValue := v.
	^v! !


!ColorSwatch methodsFor: 'testing' stamp: 'sw 7/13/1999 18:39'!
stepTime
	^ 1000! !
StandardSystemView subclass: #ColorSystemView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!

!ColorSystemView methodsFor: 'as yet unclassified'!
cacheBitsAsTwoTone
	^ false! !

!ColorSystemView methodsFor: 'as yet unclassified' stamp: 'di 2/26/98 08:58'!
displayDeEmphasized 
	"Display this view with emphasis off.
	If windowBits is not nil, then simply BLT if possible."
	bitsValid
		ifTrue: [self lock.
				windowBits displayAt: self windowOrigin]
		ifFalse: [super displayDeEmphasized]
! !
ClassTestCase subclass: #ColorTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'GraphicsTests-Primitives'!

!ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 13:13'!
testMultiplyByArray
	| newColor oldColor tolerance |
	tolerance := 0.001.

	oldColor := Color r: 0.75 g: 0.5 b: 0.25.
	newColor := oldColor * #(0.1 2 3).

	self assert: (0.075 - newColor red) abs < tolerance.
	self assert: (1 - newColor green) abs < tolerance.
	self assert: (0.75 - newColor blue) abs < tolerance.! !

!ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 12:57'!
testMultiplyByArrayIdentityTransform
	| newColor oldColor tolerance |
	tolerance := 0.001.

	oldColor := Color r: 0.75 g: 0.5 b: 0.25.
	newColor := oldColor * 2.

	self assert: (1 - newColor red) abs < tolerance.
	self assert: (1 - newColor green) abs < tolerance.
	self assert: (0.5 - newColor blue) abs < tolerance.! !

!ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 12:56'!
testMultiplyByNumber
	| newColor oldColor tolerance |
	tolerance := 0.001.

	oldColor := Color r: 0.75 g: 0.5 b: 0.25.
	newColor := oldColor * 2.

	self assert: (1 - newColor red) abs < tolerance.
	self assert: (1 - newColor green) abs < tolerance.
	self assert: (0.5 - newColor blue) abs < tolerance.! !


!ColorTest methodsFor: 'tests' stamp: 'st 9/27/2004 13:43'!
testAsHTMLColor
	self assert: (Color white asHTMLColor = '#ffffff').
	self assert: (Color black asHTMLColor = '#000000').! !

!ColorTest methodsFor: 'tests' stamp: 'st 9/27/2004 13:45'!
testColorFrom
	self assert: ((Color colorFrom: #white) asHTMLColor = '#ffffff').
	self assert: ((Color colorFrom: #(1.0 0.5 0.0)) asHTMLColor = '#ff7f00').
	self assert: ((Color colorFrom: (Color white)) asHTMLColor = '#ffffff').
	self assert: ((Color colorFrom: '#FF8800') asHTMLColor = '#ff8800').! !

!ColorTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:14'!
testFromString

	self assert: ((Color fromString: '#FF8800') asHTMLColor = '#ff8800').! !

!ColorTest methodsFor: 'tests' stamp: 'sd 6/16/2006 13:12'!
testPrintHtmlString
	"self debug: #testPrintHtmlString"
	
	self shouldnt: [Color white printHtmlString ] raise: Error.
	self assert: Color white printHtmlString = 'FFFFFF'.
	self assert: Color red printHtmlString =  'FF0000'.
	self assert: Color black printHtmlString = '000000'.! !
Object subclass: #ColorTheme
	instanceVariableNames: ''
	classVariableNames: 'Current'
	poolDictionaries: ''
	category: 'System-Support'!

!ColorTheme methodsFor: 'applying' stamp: 'dgd 4/3/2006 12:05'!
apply
	"apply the receiver as the current theme"
	BalloonMorph setBalloonColorTo: self balloonColor.

	Preferences setParameter: #defaultWorldColor to: self defaultWorldColor.

	Preferences insertionPointColor: self insertionPointColor.
	Preferences keyboardFocusColor: self keyboardFocusColor.
	Preferences textHighlightColor: self textHighlightColor.

	Preferences setParameter: #menuTitleColor to: self menuTitleColor.
	Preferences setParameter: #menuTitleBorderColor to: self menuTitleBorderColor.
	Preferences setParameter: #menuTitleBorderWidth to: self menuTitleBorderWidth.
	Preferences setParameter: #menuColor to: self menuColor.
	Preferences setParameter: #menuBorderColor to: self menuBorderColor.
	Preferences setParameter: #menuLineColor to: self menuLineColor.
	Preferences setParameter: #menuBorderWidth to: self menuBorderWidth.
	Preferences setParameter: #menuSelectionColor to: self menuSelectionColor.

	SystemProgressMorph reset.

	self class current: self.
! !


!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 17:33'!
balloonColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 21:23'!
cancelColor
	^ Color lightRed! !

!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 17:33'!
defaultWorldColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme' stamp: 'dgd 1/7/2005 18:37'!
helpColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 17:33'!
insertionPointColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 17:33'!
keyboardFocusColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 21:22'!
okColor
	^ Color lightGreen! !

!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 17:33'!
textHighlightColor
	^ self subclassResponsibility! !


!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:27'!
dialog3DTitles
	^ true! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 19:56'!
dialogBorderColor
	^ Color fromArray: #(0.355 0.516 1.0 )! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 19:54'!
dialogBorderWidth
	^ 4! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 19:59'!
dialogButtonBorderWidth
	^ 0! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 21:09'!
dialogColor
	^ Color paleYellow! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:49'!
dialogPaneBorderColor
	^ Color black
! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:44'!
dialogPaneBorderWidth
	^ 0! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:30'!
dialogPaneRampOrColor
	^ {0.0 -> (Color r: 0.742 g: 0.871 b: 1.0).
		1.0 -> (Color r: 0.516 g: 0.645 b: 1.0)}! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:38'!
dialogRampOrColor
	^ {0.0 -> (Color r: 0.516 g: 0.645 b: 1.0).
		1.0 -> (Color r: 0.742 g: 0.871 b: 1.0)}! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 21:18'!
dialogTextBoxBorderColor
	^ Color black! !

!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 21:18'!
dialogTextBoxColor
	^ Color white! !


!ColorTheme methodsFor: 'theme - dockingbar' stamp: 'dgd 11/2/2004 17:54'!
dockingBarAutoGradient
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - dockingbar' stamp: 'dgd 11/2/2004 17:49'!
dockingBarColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - dockingbar' stamp: 'dgd 11/2/2004 17:49'!
dockingBarGradientRamp
	^ self subclassResponsibility! !


!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:30'!
menuBorderColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:31'!
menuBorderWidth
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:31'!
menuColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'!
menuLineColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'!
menuSelectionColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'!
menuTitleBorderColor
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'!
menuTitleBorderWidth
	^ self subclassResponsibility! !

!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'!
menuTitleColor
	^ self subclassResponsibility! !

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

ColorTheme class
	instanceVariableNames: ''!

!ColorTheme class methodsFor: 'applying' stamp: 'dgd 3/31/2006 12:25'!
apply
	^self new apply! !

!ColorTheme class methodsFor: 'applying' stamp: 'dgd 3/12/2006 13:08'!
applyTheme: aThemeClass 
	aThemeClass new apply! !


!ColorTheme class methodsFor: 'accessing' stamp: 'dgd 3/31/2006 12:07'!
current
	^ Current
		ifNil: [self defaultTheme apply]! !

!ColorTheme class methodsFor: 'accessing' stamp: 'dgd 11/2/2004 17:52'!
current: aColorTheme
	Current := aColorTheme! !

!ColorTheme class methodsFor: 'accessing' stamp: 'dgd 3/31/2006 13:45'!
defaultTheme
	Smalltalk
		at: #YellowSmallLandColorTheme
		ifPresent: [:yellowSmallLandColorTheme | ^ yellowSmallLandColorTheme].
	^ (self allSubclasses
		select: [:each | each subclasses isEmpty]) anyOne! !
TileMorph subclass: #ColorTileMorph
	instanceVariableNames: 'colorSwatch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!ColorTileMorph methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:27'!
resultType
	"Answer the result type of the receiver"

	^ #Color! !


!ColorTileMorph methodsFor: 'code generation' stamp: 'yo 4/5/2005 11:19'!
kedamaStoreCodeAsPixelValueOn: aStream indent: tabCount

	aStream nextPutAll: ((colorSwatch color pixelValueForDepth: 32) bitAnd: 16rFFFFFF) printString.
! !

!ColorTileMorph methodsFor: 'code generation' stamp: 'jm 5/28/1998 19:02'!
storeCodeOn: aStream indent: tabCount

	aStream nextPutAll: colorSwatch color printString.
! !


!ColorTileMorph methodsFor: 'event handling'!
handlesMouseDown: evt

	(colorSwatch containsPoint: evt cursorPoint)
		ifTrue: [^ true]
		ifFalse: [^ super handlesMouseDown: evt].
! !

!ColorTileMorph methodsFor: 'event handling'!
mouseDown: evt

	(colorSwatch containsPoint: evt cursorPoint)
		ifFalse: [super mouseDown: evt].
! !

!ColorTileMorph methodsFor: 'event handling' stamp: 'yo 9/29/2004 10:50'!
mouseUp: evt
	self changeColorTarget: self selector: #kedamaColorSwatchColor: originalColor: colorSwatch color hand: evt hand
! !


!ColorTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	type _ #literal.
	self addColorSwatch! !

!ColorTileMorph methodsFor: 'initialization' stamp: 'sw 10/13/2004 23:28'!
setLiteral: aLiteral
	"Set the receiver's literal"

	self colorSwatchColor: aLiteral! !

!ColorTileMorph methodsFor: 'initialization' stamp: 'yo 7/2/2004 17:33'!
updateWordingToMatchVocabulary

	| stringMorph |
	stringMorph _ submorphs detect: [:morph | morph class == StringMorph] ifNone: [^ self].
	stringMorph contents: 'color' translated.
! !


!ColorTileMorph methodsFor: 'other' stamp: 'yo 7/2/2004 17:33'!
addColorSwatch

	| m1 m2 desiredW |
	m1 _ StringMorph contents: 'color' translated font: ScriptingSystem fontForTiles.
	m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0).
	desiredW _ m1 width + 6.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	m2 position: (bounds center x - (m2 width // 2)) @ (m1 bottom - 1).
	self addMorph: m1; addMorph: m2.
	colorSwatch _ m2! !

!ColorTileMorph methodsFor: 'other' stamp: 'sw 10/25/1998 00:25'!
colorSwatch
	^ colorSwatch! !

!ColorTileMorph methodsFor: 'other' stamp: 'yo 3/24/2005 12:16'!
colorSwatchColor: aColor
	colorSwatch color: aColor.
! !

!ColorTileMorph methodsFor: 'other' stamp: 'yo 3/24/2005 12:17'!
kedamaColorSwatchColor: aColor

	colorSwatch userSelectedColor: aColor.
! !


!ColorTileMorph methodsFor: 'player viewer' stamp: 'sw 1/6/1999 10:43'!
updateLiteralLabel
	"Do nothing"! !
DataType subclass: #ColorType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!
!ColorType commentStamp: 'sw 1/5/2005 22:15' prior: 0!
A data type representing a Color value.!


!ColorType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:28'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ Color random! !


!ColorType 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: #Color.! !


!ColorType methodsFor: 'tiles' stamp: 'yo 4/5/2005 11:36'!
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter
	"Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter"

	| readout |
	readout _ UpdatingRectangleMorph new.
	readout
		getSelector: getter;
		target: aTarget;
		borderWidth: 1;
		extent:  22@22.
	((aTarget isKindOf: KedamaExamplerPlayer) and: [getter = #getColor]) ifTrue: [
		readout getSelector: #getColorOpaque.
	].
	(setter isNil or: [#(unused none #nil) includes: setter]) ifFalse:
		[readout putSelector: setter].
	^ readout
! !

!ColorType methodsFor: 'tiles' stamp: 'sw 1/5/2005 19:57'!
wantsArrowsOnTiles
	"Answer whether this data type wants up/down arrows on tiles representing its values"

	^ false! !


!ColorType methodsFor: '*eToys-color' stamp: 'sw 9/27/2001 17:21'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(1.0  0 0.065)	! !


!ColorType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ Color blue newTileMorphRepresentative! !
TextStream subclass: #ColoredCodeStream
	instanceVariableNames: 'dialect colorTable'
	classVariableNames: 'ST80ColorTable'
	poolDictionaries: ''
	category: 'Compiler-Kernel'!

!ColoredCodeStream methodsFor: 'color/style' stamp: 'md 8/14/2005 17:33'!
colorTable
	"Answer the table to use to determine colors"

	^ colorTable ifNil: [colorTable _ ST80ColorTable]! !

!ColoredCodeStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 21:05'!
withColor: colorSymbol emphasis: emphasisSymbol do: aBlock
	"Evaluate the given block with the given color and style text attribute"

	^ self withAttributes: {TextColor color: (Color perform: colorSymbol).
							TextEmphasis perform: emphasisSymbol}
		do: aBlock! !

!ColoredCodeStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 11:30'!
withStyleFor: elementType do: aBlock
	"Evaluate aBlock with appropriate emphasis and color for the given elementType"

	| colorAndStyle |
	colorAndStyle _ self colorTable at: elementType.
	^ self withColor: colorAndStyle first emphasis: colorAndStyle second do: aBlock! !

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

ColoredCodeStream class
	instanceVariableNames: ''!

!ColoredCodeStream class methodsFor: 'class initialization' stamp: 'wiz 9/12/2005 00:41'!
initialize
	"Initialize the colors that characterize the ST80 dialect"

	ST80ColorTable _ IdentityDictionary new.
	#(	(temporaryVariable blue italic)
		(methodArgument blue normal)
		(methodSelector black bold)
		(blockArgument red normal)
		(comment brown normal)
		(variable magenta normal)
		(literal	orange normal)
		(keyword darkGray bold)
		(prefixKeyword veryDarkGray bold)
		(setOrReturn black bold)) do:
			[:aTriplet |
				ST80ColorTable at: aTriplet first put: aTriplet allButFirst]

"ColoredCodeStream initialize"! !


!ColoredCodeStream class methodsFor: 'instance creation' stamp: 'md 8/15/2005 11:00'!
contents: blockWithArg 
	"Evaluate blockWithArg on a DialectStream of the given description"

	| stream |
	stream _ self on: (Text new: 400).
	blockWithArg value: stream.
	^ stream contents! !
Object subclass: #CombinedChar
	instanceVariableNames: 'codes combined'
	classVariableNames: 'Compositions Decompositions Diacriticals'
	poolDictionaries: ''
	category: 'Multilingual-Scanning'!

!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 2/10/2004 07:08'!
add: char

	| dict elem |
	codes ifNil: [codes _ Array with: char. combined _ char. ^ true].

	dict _ Compositions at: combined charCode ifAbsent: [^ false].

	elem _ dict at: combined charCode ifAbsent: [^ false].

	codes _ codes copyWith: char.
	combined _ elem.
	^ true.
! !

!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 2/10/2004 07:08'!
base

	^ codes first.
! !

!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 2/10/2004 07:08'!
combined

	^ combined.
! !

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

CombinedChar class
	instanceVariableNames: ''!

!CombinedChar class methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 19:21'!
isDiacriticals: unicode

	^ Diacriticals includes: unicode.
! !

!CombinedChar class methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 19:09'!
parseCompositionMappingFrom: stream
"
	self halt.
	self parseCompositionMapping
"

	| line fieldEnd point fieldStart compositions toNumber diacritical result |

	toNumber _ [:quad | ('16r', quad) asNumber].

	Compositions _ IdentityDictionary new: 2048.
	Decompositions _ IdentityDictionary new: 2048.
	Diacriticals _ IdentitySet new: 2048.

	[(line _ stream upTo: Character cr) size > 0] whileTrue: [
		fieldEnd _ line indexOf: $; startingAt: 1.
		point _ ('16r', (line copyFrom: 1 to: fieldEnd - 1)) asNumber.
		2 to: 6 do: [:i |
			fieldStart _ fieldEnd + 1.
			fieldEnd _ line indexOf: $; startingAt: fieldStart.
		].
		compositions _ line copyFrom: fieldStart to: fieldEnd - 1.
		(compositions size > 0 and: [compositions first ~= $<]) ifTrue: [
			compositions _ compositions substrings collect: toNumber.
			compositions size > 1 ifTrue: [
				diacritical _ compositions first.
				Diacriticals add: diacritical.
				result _ compositions second.
				(Decompositions includesKey: point) ifTrue: [
					self error: 'should not happen'.
				] ifFalse: [
					Decompositions at: point put: (Array with: diacritical with: result).
				].
				(Compositions includesKey: diacritical) ifTrue: [
					(Compositions at: diacritical) at: result put: point.
				] ifFalse: [
					Compositions at: diacritical
						put: (IdentityDictionary new at: result put: point; yourself).
				].
			].
		].
	].
! !
Object subclass: #Command
	instanceVariableNames: 'phase cmdWording undoTarget undoSelector undoArguments redoTarget redoSelector redoArguments parameters'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Undo'!
!Command commentStamp: '<historical>' prior: 0!
An object representing an undoable command to be done in the environment.

Structure:
	phase			indicates whether the cmd is current in undone or redone mode
 	cmdWording		The wording of the command (used in arming the "undo"/"redo" menu items
 	parameters		an IdentityDictionary /NOT USED/
	undoTarget		Receiver, selector and arguments to accomplish undo
	undoSelector
	undoArguments
	redoTarget		Receiver, selector and arguments to accomplish redo
	redoSelector
	redoArguments

To use this, for any command you wish to use, you
	*	Create an instance of Command, as follows...
			cmd _ Command new cmdWording: 'resizing'.
	*	Give the the command undo state and redo state, as follows...
			cmd undoTarget: target selector: #extent: argument: oldExtent.
			cmd redoTarget: target selector: #extent: argument: newExtent.
	*	Send a message of the form
			Command rememberCommand: cmd

LastCommand is the last command that was actually done or undone.

CommandHistory, applicable only when infiniteUndo is set, holds a 'tape' of the complete history of commands, as far back as it's possible to go.

CommandExcursions, also applicable only in the infiniteUndo case, and rather at the fringe even then, holds segments of former CommandHistory that have been lopped off because of variant paths taken.!


!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:04'!
doCommand
	"Do the command represented by the receiver.  Not actually called by active current code, but reachable by the not-yet-unsealed promoteToCurrent: action."

	redoTarget ifNotNil: [redoTarget perform: redoSelector withArguments: redoArguments]! !

!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:04'!
redoCommand
	"Perform the 'redo' operation"

	redoTarget ifNotNil: [redoTarget perform: redoSelector withArguments: redoArguments]! !

!Command methodsFor: 'command execution' stamp: 'sw 2/2/2006 02:00'!
stillValid
	"Answer whether the receiver is still valid."

	^ (undoTarget isMorph and: [undoTarget isInWorld]) or: [redoTarget isMorph and:  [redoTarget isInWorld]]! !

!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:02'!
undoCommand
	"Perform the 'undo' operation"

	undoTarget ifNotNil: [undoTarget perform: undoSelector withArguments: undoArguments]! !


!Command methodsFor: 'copying' stamp: 'tk 2/25/2001 17:53'!
veryDeepFixupWith: deepCopier
	| old |
	"ALL inst vars were weakly copied.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
1 to: self class instSize do:
	[:ii | old _ self instVarAt: ii.
	self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])].

! !

!Command methodsFor: 'copying' stamp: 'tk 2/25/2001 17:53'!
veryDeepInner: deepCopier
	"ALL fields are weakly copied!!  Can't duplicate an object by duplicating a Command that involves it.  See DeepCopier."

	super veryDeepInner: deepCopier.
	"just keep old pointers to all fields"
	parameters _ parameters.! !


!Command methodsFor: 'initialization' stamp: 'sw 8/29/2000 14:12'!
cmdWording: wrd
	"Set the wording to be used in a menu item referring to the receiver"

	cmdWording _ wrd! !

!Command methodsFor: 'initialization' stamp: 'sw 8/29/2000 14:13'!
phase: aPhase
	"Set the phase of the command to the supplied symbol"

	phase _ aPhase! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 13:04'!
redoTarget: target selector: aSymbol argument: argument

	^ self redoTarget: target selector: aSymbol arguments: {argument}! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 20:53'!
redoTarget: target selector: selector arguments: arguments
	"Give target morph a chance to refine its undo operation"

	target refineRedoTarget: target selector: selector arguments: arguments in:
		[:rTarget :rSelector :rArguments |
		redoTarget _ rTarget.
		redoSelector _ rSelector.
		redoArguments _ rArguments]! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 13:04'!
undoTarget: target selector: aSymbol argument: argument

	^ self undoTarget: target selector: aSymbol arguments: {argument}! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 20:53'!
undoTarget: target selector: selector arguments: arguments
	"Give target morph a chance to refine its undo operation"

	target refineUndoTarget: target selector: selector arguments: arguments in:
		[:rTarget :rSelector :rArguments |
		undoTarget _ rTarget.
		undoSelector _ rSelector.
		undoArguments _ rArguments]! !


!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'!
parameterAt: aSymbol
	"Answer the parameter stored at the given symbol, or nil if none"

	^ self parameterAt: aSymbol ifAbsent: [nil]! !

!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'!
parameterAt: aSymbol ifAbsent: aBlock
	"Answer the parameter stored at the aSymbol, but if none, return the result of evaluating aBlock"

	^ self assuredParameterDictionary at: aSymbol ifAbsent: [aBlock value]! !

!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'!
parameterAt: aSymbol put: aValue
	"Place aValue in the parameters dictionary using aSymbol as key"

	^ self assuredParameterDictionary at: aSymbol put: aValue! !


!Command methodsFor: 'printing' stamp: 'di 8/30/2000 14:09'!
printOn: aStream
	"Provide more detailed info about the receiver, put in for debugging, maybe should be removed"

	super printOn: aStream.
	aStream nextPutAll: ' phase: ', phase printString.
	cmdWording ifNotNil: [aStream nextPutAll: '; ', cmdWording asString].
	parameters ifNotNil:
		[parameters associationsDo:
			[:assoc | aStream nextPutAll: ': ', assoc printString]]! !


!Command methodsFor: 'private' stamp: 'sw 8/29/2000 14:09'!
assuredParameterDictionary
	"Private!!  Answer the parameters dictionary, creating it if necessary"

	^ parameters ifNil: [parameters _ IdentityDictionary new]! !

!Command methodsFor: 'private' stamp: 'dgd 8/26/2003 21:43'!
cmdWording
	"Answer the wording to be used to refer to the command in a menu"

	^ cmdWording ifNil: ['last command' translated]! !

!Command methodsFor: 'private' stamp: 'sw 8/29/2000 14:13'!
phase
	"Answer the phase of the command"

	^ phase! !

!Command methodsFor: 'private' stamp: 'di 12/12/2000 12:36'!
undoTarget
	^ undoTarget! !

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

Command class
	instanceVariableNames: ''!

!Command class methodsFor: 'class initialization' stamp: 'RAA 9/21/2000 14:02'!
zapObsolete
"Command zapObsolete"
	"kill some obsolete stuff still retained by the CompiledMethods in change records"

	| before after histories lastCmd histCount lastCount |
	Smalltalk garbageCollect.
	before _ Command allInstances size.
	histories _ Association allInstances select: [ :each | 
		each key == #CommandHistory and: [
			(each value isKindOf: OrderedCollection) and: [
				each value isEmpty not and: [
					each value first isKindOf: Command]]]
	].
	histCount _ histories size.
	lastCmd _ Association allInstances select: [ :each | 
		each key == #LastCommand and: [each value isKindOf: Command]
	].
	lastCount _ lastCmd size.
	histories do: [ :each | each value: OrderedCollection new].
	lastCmd do: [ :each | each value: Command new].
	Smalltalk garbageCollect.
	Smalltalk garbageCollect.
	after _ Command allInstances size.
	Transcript show: {before. after. histCount. histories. lastCount. lastCmd} printString; cr; cr.
	! !


!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'!
redoEnabled
	| w |
	^(w _ self currentWorld) == nil ifTrue:[false] ifFalse:[w commandHistory redoEnabled]! !

!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'!
redoNextCommand
	| w |
	^(w _ self currentWorld) == nil ifFalse:[w commandHistory redoNextCommand]! !

!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'!
undoEnabled
	| w |
	^(w _ self currentWorld) == nil ifTrue:[false] ifFalse:[w commandHistory undoEnabled]! !

!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:14'!
undoLastCommand
	| w |
	^(w _ self currentWorld) == nil ifFalse:[w commandHistory undoLastCommand]! !

!Command class methodsFor: 'dog simple ui' stamp: 'ar 11/9/2000 20:38'!
undoRedoButtons
	"Answer a morph that offers undo and redo buttons"

	| aButton wrapper |
	"self currentHand attachMorph: Command undoRedoButtons"
	wrapper _ AlignmentMorph newColumn.
	wrapper color: Color veryVeryLightGray lighter;
		borderWidth: 0;
		layoutInset: 0;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap.
	#((CrudeUndo undoLastCommand 'undo last command done' undoEnabled CrudeUndoDisabled CrudeUndoDisabled) 
	(CrudeRedo redoNextCommand 'redo last undone command' redoEnabled CrudeRedoDisabled CrudeRedoDisabled)) do:
		[:tuple |
			wrapper addTransparentSpacerOfSize: (8@0).
			aButton _ UpdatingThreePhaseButtonMorph new.
			aButton
				onImage: (ScriptingSystem formAtKey: tuple first);
				offImage: (ScriptingSystem formAtKey: tuple fifth);
				pressedImage: (ScriptingSystem formAtKey: tuple sixth);
				getSelector: tuple fourth;
				color: Color transparent; 
				target: self;
				actionSelector: tuple second;
				setNameTo: tuple second;
				setBalloonText: tuple third;
				extent: aButton onImage extent.
			wrapper addMorphBack: aButton.
			wrapper addTransparentSpacerOfSize: (8@0)].
	^ wrapper! !
Object subclass: #CommandHistory
	instanceVariableNames: 'lastCommand history excursions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Undo'!

!CommandHistory methodsFor: 'called by programmer' stamp: 'sw 2/2/2006 01:48'!
assureLastCommandStillValid
	"If the lastCommand is not valid, set it to nil; answer the lastCommand."

	lastCommand ifNotNil:
		[lastCommand stillValid ifFalse:
			[self cantUndo]].
	^ lastCommand! !

!CommandHistory methodsFor: 'called by programmer' stamp: 'ar 8/31/2000 22:46'!
cantUndo
	"Called by client to indicate that the prior undoable command is no longer undoable"

	lastCommand _ nil.
	history _ OrderedCollection new.! !

!CommandHistory methodsFor: 'called by programmer' stamp: 'ar 8/31/2000 22:47'!
promoteToCurrent: aCommand
	"Very unusual and speculative and unfinished!!.  Not currently reachable.  For the real thing, we presumably march forward or backward from the current command pointer to the target command in an orderly fashion, doing or undoing each command in turn."

	| itsIndex |
	Preferences useUndo ifFalse: [^ self].
	itsIndex _ history indexOf: aCommand ifAbsent: [nil].
	itsIndex ifNotNil:
		[history remove: aCommand ifAbsent: []].
	history add: (lastCommand _ aCommand).
	itsIndex < history size ifTrue:
		[excursions add: (history copyFrom: (itsIndex to: history size))].
	history _ (history copyFrom: 1 to: itsIndex) copyWith: aCommand.

	lastCommand _ aCommand.
	aCommand doCommand.
	lastCommand phase: #done.! !

!CommandHistory methodsFor: 'called by programmer' stamp: 'aoy 2/15/2003 21:14'!
purgeAllCommandsSuchThat: cmdBlock 
	"Remove a bunch of commands, as in [:cmd | cmd undoTarget == zort]"

	Preferences useUndo ifFalse: [^self].
	history := history reject: cmdBlock.
	lastCommand := history isEmpty ifTrue: [nil] ifFalse: [history last] ! !


!CommandHistory methodsFor: 'called from the ui' stamp: 'ar 8/31/2000 22:49'!
commandToUndo
	"Undo the last command, i.e. move backward in the recent-commands tape, if possible."

	| anIndex |
	lastCommand ifNil: [^ nil].
	lastCommand phase == #done ifTrue: [^ lastCommand].
	(lastCommand phase == #undone and:
		[(anIndex _ history indexOf: lastCommand) > 1])
		ifTrue: [^ history at: anIndex - 1]
		ifFalse: [^ nil]
! !

!CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'!
redoNextCommand
	"If there is a way to 'redo' (move FORWARD) in the undo/redo history tape, do it."

	| anIndex |
	lastCommand ifNil: [^ Beeper beep].
	lastCommand phase == #undone
		ifFalse:
			[anIndex _ history indexOf: lastCommand.
			(anIndex < history size)
				ifTrue:
					[lastCommand _ history at: anIndex + 1]
				ifFalse:
					[^ Beeper beep]].

	lastCommand redoCommand.
	lastCommand phase: #done
! !

!CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'!
undoLastCommand
	"Undo the last command, i.e. move backward in the recent-commands tape, if possible."

	| aPhase anIndex |
	lastCommand ifNil: [^ Beeper beep].

	(aPhase _ lastCommand phase) == #done
		ifFalse:
			[aPhase == #undone
				ifTrue:
					[anIndex _ history indexOf: lastCommand.
					anIndex > 1 ifTrue:
						[lastCommand _ history at: anIndex - 1]]].

	lastCommand undoCommand.
	lastCommand phase: #undone

	"Command undoLastCommand"
! !

!CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'!
undoOrRedoCommand
	"This gives a feature comparable to standard Mac undo/redo.  If the undo/redo action taken was a simple do or a redo, then undo it.  But if the last undo/redo action taken was an undo, then redo it."

	"Command undoOrRedoCommand"
	| aPhase |
	lastCommand ifNil: [^ Beeper beep].

	(aPhase _ lastCommand phase) == #done
		ifTrue:
			[lastCommand undoCommand.
			lastCommand phase: #undone]
		ifFalse:
			[aPhase == #undone
				ifTrue:
					[lastCommand redoCommand.
					lastCommand phase: #done]]! !

!CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'!
undoTo
	"Not yet functional, and not yet sent.  Allow the user to choose a point somewhere in the undo/redo tape, and undo his way to there.   Applicable only if infiniteUndo is set. "

	| anIndex commandList aMenu reply |
	(anIndex _ self historyIndexOfLastCommand) == 0 ifTrue: [^ Beeper beep].
	commandList _ history
		copyFrom:	((anIndex - 10) max: 1)
		to:			((anIndex + 10) min: history size).
	aMenu _ SelectionMenu labels:  (commandList collect: [:cmd | cmd cmdWording truncateWithElipsisTo: 20]) selections: commandList.
	reply _ aMenu startUpWithCaption: 'undo or redo to...'.
	reply ifNotNil: [self inform: #deferred]

	"ActiveWorld commandHistory undoTo"
! !


!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:44'!
historyIndexOfLastCommand
	"Answer which position of the CommandHistory list is occupied by the LastCommand"

	^ history indexOf: lastCommand ifAbsent: [0]! !

!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:45'!
lastCommand
	"Answer the last command done or undone"

	^ lastCommand! !

!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:45'!
nextCommand
	"Answer the command object that would be sent the #redoCommand message if the user were to request Redo, or nil if none"

	| anIndex |
	lastCommand ifNil: [^ nil].
	lastCommand phase == #undone ifTrue: [^ lastCommand].
	anIndex _ history indexOf: lastCommand ifAbsent: [^ nil].
	^ anIndex = history size ifTrue: [nil] ifFalse: [history at: (anIndex + 1)]! !

!CommandHistory methodsFor: 'command history' stamp: 'di 12/12/2000 13:46'!
resetCommandHistory    "CommandHistory allInstancesDo: [:ch | ch resetCommandHistory]"
	"Clear out the command history so that no commands are held"

	lastCommand _ nil.
	history _ OrderedCollection new.! !


!CommandHistory methodsFor: 'initialize' stamp: 'ar 8/31/2000 22:50'!
initialize
	lastCommand _ nil.
	history _ OrderedCollection new.
	excursions _ OrderedCollection new.! !


!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:41'!
nextCommandToUndo
	| anIndex |
	lastCommand ifNil: [^ nil].
	lastCommand phase == #done ifTrue: [^ lastCommand].
	(lastCommand phase == #undone and:
		[(anIndex _ history indexOf: lastCommand) > 1])
		ifTrue: [^ history at: anIndex - 1]
		ifFalse: [^ nil]! !

!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:39'!
redoEnabled
	"Answer whether the redo command is currently available"

	^ self nextCommand notNil! !

!CommandHistory methodsFor: 'menu' stamp: 'dgd 4/3/2006 14:26'!
redoMenuWording
	"Answer the wording to be used in a menu offering the current 
	Redo command"
	| nextCommand |

	((nextCommand := self nextCommand) isNil
			or: [Preferences useUndo not])
		ifTrue: [^ 'can''t redo' translated].

	^ String
		streamContents: [:aStream | 
			aStream nextPutAll: 'redo' translated.
			aStream nextPutAll: ' "'.
			aStream nextPutAll: (nextCommand cmdWording truncateWithElipsisTo: 20).
			aStream nextPut: $".
			lastCommand phase == #done
				ifFalse: [aStream nextPutAll: ' (z)']]! !

!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:40'!
undoEnabled
	"Answer whether there is an undoable command at the ready"

	^ lastCommand notNil! !

!CommandHistory methodsFor: 'menu' stamp: 'dgd 4/3/2006 14:26'!
undoMenuWording
	"Answer the wording to be used in an 'undo' menu item"

	(lastCommand isNil
			or: [Preferences useUndo not]
			or: [Preferences infiniteUndo not and: [lastCommand phase == #undone]]
			or: [self nextCommandToUndo isNil])
		ifTrue: [^ 'can''t undo' translated].

	^ String
		streamContents: [:aStream | 
			aStream nextPutAll: 'undo' translated.
			aStream nextPutAll: ' "'.
			aStream nextPutAll: (self nextCommandToUndo cmdWording truncateWithElipsisTo: 20).
			aStream nextPut: $".
			lastCommand phase == #done
				ifTrue: [aStream nextPutAll: ' (z)']].! !

!CommandHistory methodsFor: 'menu' stamp: 'sw 2/2/2006 01:53'!
undoOrRedoMenuWording
	"Answer the wording to be used in a menu item offering undo/redo (i.e., the form used when the #infiniteUndo preference is false)"

	| pre |
	self assureLastCommandStillValid. 
	lastCommand ifNil: [^ 'can''t undo' translated].
	pre _ lastCommand phase == #done
		ifTrue: ['undo' translated]
		ifFalse: ['redo' translated].
	^ pre, ' "', (lastCommand cmdWording truncateWithElipsisTo: 20), '" (z)'! !


!CommandHistory methodsFor: 'undo' stamp: 'di 12/12/2000 10:16'!
rememberCommand: aCommand
	"Make the supplied command be the 'LastCommand', and mark it 'done'"

	| currentCommandIndex |
	Preferences useUndo ifFalse: [^ self].  "Command initialize"

	Preferences infiniteUndo ifTrue:
		[currentCommandIndex _ history indexOf: lastCommand.
		((currentCommandIndex < history size) and: [Preferences preserveCommandExcursions]) ifTrue:
			[excursions add: (history copyFrom: (currentCommandIndex to: history size)).
			history _ history copyFrom: 1 to: currentCommandIndex].
		history addLast: aCommand].

	lastCommand _ aCommand.
	lastCommand phase: #done.! !

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

CommandHistory class
	instanceVariableNames: ''!

!CommandHistory class methodsFor: 'class initialization' stamp: 'dgd 4/3/2006 14:28'!
initialize
	"CommandHistory initialize"

	Smalltalk addToStartUpList: self.
	Smalltalk addToShutDownList: self.! !


!CommandHistory class methodsFor: 'system startup' stamp: 'tk 5/16/2002 13:52'!
forgetAllGrabCommandsFrom: starter
	"Forget all the commands that might be held on to in the properties dicitonary of various morphs for various reasons."

	| object |
	object _ starter.
	[
		[0 == object] whileFalse: [
			object isMorph ifTrue: [object removeProperty: #undoGrabCommand].
			object _ object nextObject].
		] ifError: [:err :rcvr | "object is obsolete"
			self forgetAllGrabCommandsFrom: object nextObject].

	"CommandHistory forgetAllGrabCommandsFrom: true someObject"
! !

!CommandHistory class methodsFor: 'system startup' stamp: 'tk 5/16/2002 13:38'!
resetAllHistory
	"Reset all command histories, and make all morphs that might be holding on to undo-grab-commands forget them"

	self allInstancesDo: [:c | c resetCommandHistory].
	self forgetAllGrabCommandsFrom: self someObject.

	"CommandHistory resetAllHistory"
! !

!CommandHistory class methodsFor: 'system startup' stamp: 'dgd 4/3/2006 14:28'!
shutDown: aboutToQuit 
	Preferences purgeUndoOnQuit ifTrue: [
		aboutToQuit ifTrue: [self resetAllHistory].
	].
! !

!CommandHistory class methodsFor: 'system startup' stamp: 'dgd 10/15/2004 12:11'!
startUp: aboutToQuit 
	Preferences purgeUndoOnQuit
		ifTrue: [
			aboutToQuit ifTrue: [self resetAllHistory].
		].
 
	! !
AbstractLauncher subclass: #CommandLineLauncherExample
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Download'!
!CommandLineLauncherExample commentStamp: '<historical>' prior: 0!
CommandLineLauncherExample provides an example for a command line application. if you start squeak with a command line 'class Integer' it will launch a class browser on class Integer.
To enable this execute
CommandLineLauncherExample activate
before you save the image.
To disable execute
CommandLineLauncherExample deactivate!


!CommandLineLauncherExample methodsFor: 'running' stamp: 'ar 9/27/2005 20:23'!
startUp
	| className |
	className := self parameterAt: 'class'.
	ToolSet browse: (Smalltalk at: className asSymbol ifAbsent: [Object]) selector: nil! !
TileLikeMorph subclass: #CommandTilesMorph
	instanceVariableNames: 'morph playerScripted'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!CommandTilesMorph commentStamp: '<historical>' prior: 0!
An entire Smalltalk statement in tiles.  A line of code.!


!CommandTilesMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:13'!
initialize

	super initialize.
	self wrapCentering: #center; cellPositioning: #leftCenter.
	self hResizing: #shrinkWrap.
	borderWidth _ 0.
	self layoutInset: 0.
	self extent: 5@5.  "will grow to fit"
! !

!CommandTilesMorph methodsFor: 'initialization' stamp: 'sw 1/29/98 18:32'!
setMorph: aMorph
	playerScripted _ aMorph playerScripted
! !


!CommandTilesMorph methodsFor: 'miscellaneous'!
tileRows

	^ Array with: self submorphs! !
ParseNode subclass: #CommentNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
AbstractEvent subclass: #CommentedEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!CommentedEvent methodsFor: 'printing' stamp: 'rw 7/1/2003 11:37'!
printEventKindOn: aStream

	aStream nextPutAll: 'Commented'! !


!CommentedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:37'!
isCommented

	^true! !

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

CommentedEvent class
	instanceVariableNames: ''!

!CommentedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'!
changeKind

	^#Commented! !

!CommentedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:20'!
supportedKinds

	^Array with: self classKind! !
ByteArray variableByteSubclass: #CompiledMethod
	instanceVariableNames: ''
	classVariableNames: 'BlockNodeCache LargeFrame SmallFrame SpecialConstants'
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!CompiledMethod commentStamp: 'ls 7/5/2003 13:48' prior: 0!
My instances are methods suitable for interpretation by the virtual machine.  This is the only class in the system whose instances intermix both indexable pointer fields and indexable integer fields.

	
The current format of a CompiledMethod is as follows:

	header (4 bytes)
	literals (4 bytes each)
	bytecodes  (variable)
	trailer (variable)

The header is a 30-bit integer with the following format:

(index 0)	9 bits:	main part of primitive number   (#primitive)
(index 9)	8 bits:	number of literals (#numLiterals)
(index 17)	1 bit:	whether a large frame size is needed (#frameSize)
(index 18)	6 bits:	number of temporary variables (#numTemps)
(index 24)	4 bits:	number of arguments to the method (#numArgs)
(index 28)	1 bit:	high-bit of primitive number (#primitive)
(index 29)	1 bit:	flag bit, ignored by the VM  (#flag)


The trailer has two variant formats.  In the first variant, the last byte is at least 252 and the last four bytes represent a source pointer into one of the sources files (see #sourcePointer).  In the second variant, the last byte is less than 252, and the last several bytes are a compressed version of the names of the method's temporary variables.  The number of bytes used for this purpose is the value of the last byte in the method.
!


!CompiledMethod methodsFor: 'accessing' stamp: 'dvf 11/12/2002 00:44'!
allLiterals

	^ self literals.! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/18/2006 13:11'!
defaultSelector 
	"Invent and answer an appropriate message selector (a Symbol) for me, 
	that is, one that will parse with the correct number of arguments."

	^#DoIt numArgs: self numArgs! !

!CompiledMethod methodsFor: 'accessing'!
endPC
	"Answer the index of the last bytecode."
	| flagByte |
	flagByte _ self last.
	flagByte = 0 ifTrue:
		["If last byte = 0, may be either 0, 0, 0, 0 or just 0"
		1 to: 4 do: [:i | (self at: self size - i) = 0 ifFalse: [^ self size - i]]].
	flagByte < 252 ifTrue:
		["Magic sources (tempnames encoded in last few bytes)"
		^ self size - self last - 1].
	"Normal 4-byte source pointer"
	^ self size - 4! !

!CompiledMethod methodsFor: 'accessing' stamp: 'ls 7/5/2003 13:50'!
flag
	"Answer the user-level flag bit"

	^( (self header bitShift: -29) bitAnd: 1) = 1
		ifTrue: [ true ]
		ifFalse: [ false ]
! !

!CompiledMethod methodsFor: 'accessing' stamp: 'di 1/2/1999 17:00'!
flushCache
	"Tell the interpreter to remove all references to this method from its method lookup cache, if it has one.  This primitive must be called whenever a method is defined or removed.
	NOTE:  Only one of two selective flush methods needs to be used.
	Squeak 2.2 and earlier uses 119 (See Symbol flushCache).
	Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)."

	<primitive: 116>
! !

!CompiledMethod methodsFor: 'accessing' stamp: 'di 10/23/1999 22:00'!
frameSize
	"Answer the size of temporary frame needed to run the receiver."
	"NOTE:  Versions 2.7 and later use two sizes of contexts."

	(self header noMask: 16r20000)
		ifTrue: [^ SmallFrame]
		ifFalse: [^ LargeFrame]
! !

!CompiledMethod methodsFor: 'accessing'!
initialPC
	"Answer the program counter for the receiver's first bytecode."

	^ (self numLiterals + 1) * 4 + 1! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 8/2/2006 18:58'!
methodClass
	"answer the class that I am installed in"
	^(self literalAt: self numLiterals) value.! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/16/2006 11:30'!
methodClass: aClass
	"set the class binding in the last literal to aClass"
	self literalAt: self numLiterals put: aClass binding! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/16/2006 14:00'!
methodReference
	| class selector |
	class := self methodClass ifNil: [^nil].
	selector := self selector ifNil: [^nil].
	^MethodReference class: class selector: selector.
	! !

!CompiledMethod methodsFor: 'accessing' stamp: 'ar 6/2/1998 16:26'!
numArgs
	"Answer the number of arguments the receiver takes."

	^ (self header bitShift: -24) bitAnd: 16r0F! !

!CompiledMethod methodsFor: 'accessing'!
numLiterals
	"Answer the number of literals used by the receiver."
	
	^ (self header bitShift: -9) bitAnd: 16rFF! !

!CompiledMethod methodsFor: 'accessing'!
numTemps
	"Answer the number of temporary variables used by the receiver."
	
	^ (self header bitShift: -18) bitAnd: 16r3F! !

!CompiledMethod methodsFor: 'accessing' stamp: 'lr 2/6/2006 19:46'!
pragmas
	"Answer an array of the pragmas of the reciever."
	
	^ self properties pragmas.! !

!CompiledMethod methodsFor: 'accessing' stamp: 'ls 6/22/2000 14:35'!
primitive
	"Answer the primitive index associated with the receiver.
	Zero indicates that this is not a primitive method.
	We currently allow 10 bits of primitive index, but they are in two places
	for  backward compatibility.  The time to unpack is negligible,
	since the reconstituted full index is stored in the method cache."
	| primBits |
	primBits _ self header bitAnd: 16r100001FF.
	
	^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19)
! !

!CompiledMethod methodsFor: 'accessing' stamp: 'lr 2/6/2006 19:35'!
properties
	"Answer the method properties of the receiver."

	^ self literalAt: self numLiterals - 1.! !

!CompiledMethod methodsFor: 'accessing'!
returnField
	"Answer the index of the instance variable returned by a quick return 
	method."
	| prim |
	prim _ self primitive.
	prim < 264
		ifTrue: [self error: 'only meaningful for quick-return']
		ifFalse: [^ prim - 264]! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 1/20/2006 16:09'!
scanner

	^ InstructionStream on: self! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/15/2006 20:51'!
searchForClass
	"search me in all classes, if found, return my class. Slow!!"
	self systemNavigation allBehaviorsDo: [:class | 
		(class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^class]].
	^nil.! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/15/2006 20:51'!
searchForSelector
	"search me in all classes, if found, return my selector. Slow!!"
	| selector |
	self systemNavigation allBehaviorsDo: [:class | 
		(selector := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^selector]].
	^nil.! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 8/2/2006 20:23'!
selector
	^self properties selector.! !

!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/16/2006 17:51'!
selector: aSymbol
	self properties selector: aSymbol! !

!CompiledMethod methodsFor: 'accessing' stamp: 'ajh 11/17/2001 14:30'!
trailer

	| end trailer |
	end _ self endPC.
	trailer _ ByteArray new: self size - end.
	end + 1 to: self size do: [:i | 
		trailer at: i - end put: (self at: i)].
	^ trailer! !


!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:10'!
allEmbeddedBlockMethods

	| set |
	set _ OrderedCollection new.
	1 to: self numLiterals do: [:i |  | lit |
		lit _ self literalAt: i.
		(lit isKindOf: CompiledMethod) ifTrue: [
			set add: lit.
			set addAll: lit allEmbeddedBlockMethods.
		] ifFalse: [(lit isKindOf: BlockClosure) ifTrue: [
			set add: lit method.
			set addAll: lit method allEmbeddedBlockMethods
		]].
	].
	^ set! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:01'!
containsBlockClosures

	^ self embeddedBlockMethods size > 0! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:10'!
createBlock: env

	^ BlockClosure new
		env: env;
		method: self! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:00'!
embeddedBlockMethods

	| set |
	set _ OrderedCollection new.
	1 to: self numLiterals do: [:i |  | lit |
		lit _ self literalAt: i.
		(lit isKindOf: CompiledMethod) ifTrue: [
			set add: lit.
		] ifFalse: [(lit isKindOf: BlockClosure) ifTrue: [
			set add: lit method.
		]].
	].
	^ set! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:08'!
isBlockMethod
	"Is this a sub-method (embedded block's method) of another method. If so the last literal points to its outer method"

	^ (self header bitAnd: 1 << 29) ~= 0! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:08'!
isBlockMethod: bool
	"Use the sign bit in the header to mark methods that are sub-methods of an outer method. The outer method will be held in my last literal."

	self objectAt: 1 put: (bool
		ifTrue: [self header bitOr: 1 << 29]
		ifFalse: [self header bitAnd: (1 << 29) bitInvert])! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:08'!
isClosureCompiled
	"Return true if this method was compiled with the new closure compiler, Parser2 (compiled while Preference compileUseNewCompiler was true).  Return false if it was compiled with the old compiler."

	^ self header < 0! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:09'!
isClosureCompiled: bool
	"Use the sign bit in the header to mark methods that have been compiled using the new closure compiler (Parser2)."

	self objectAt: 1 put: (bool
		ifTrue: [(self header bitOr: 1 << 30) as31BitSmallInt]
		ifFalse: [(self header bitAnd: (1 << 30) bitInvert) as31BitSmallInt])! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:09'!
method
	"polymorphic with closure"

	^ self! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:09'!
remoteReturns
	"For closure methods only"

	^ self messages includes: #privRemoteReturnTo:! !

!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:56'!
searchImageForHomeMethod

	Smalltalk allObjectsDo: [:obj |
		obj class == CompiledMethod ifTrue: [
			(obj pointsTo: self) ifTrue: [^ obj searchImageForHomeMethod]
		] ifFalse: [obj class == BlockClosure ifTrue: [
			(obj method == self and: [obj size = 0])
				ifTrue: [^ obj searchImageForHomeMethod]
		]]
	].
	^ self  "must be a loner block method"! !


!CompiledMethod methodsFor: 'comparing' stamp: 'md 2/16/2006 17:07'!
equivalentTo: aCompiledMethod 
	"does not work yet with non-RB parseTrees"
	^ self = aCompiledMethod
		or: [self class == aCompiledMethod class
				and: [self numArgs == aCompiledMethod numArgs
						and: [self decompile = aCompiledMethod decompile]]].! !

!CompiledMethod methodsFor: 'comparing' stamp: 'md 7/12/2006 16:35'!
= method
	| myLits otherLits |
	"Answer whether the receiver implements the same code as the 
	argument, method."
	(method isKindOf: CompiledMethod) ifFalse: [^false].
	self size = method size ifFalse: [^false].
	self header = method header ifFalse: [^false].
	self initialPC to: self endPC do:
		[:i | (self at: i) = (method at: i) ifFalse: [^false]].
	(myLits := self literals allButLast: 2) = (otherLits := method literals allButLast: 2) ifFalse:
		[myLits size = otherLits size ifFalse: [^ false].
		"Dont bother checking FFI and named primitives"
		(#(117 120) includes: self primitive) ifTrue: [^ true].
		myLits with: otherLits do: [:lit1 :lit2 | 
			lit1 = lit2 ifFalse: [
				lit1 isFloat 
					ifTrue: ["Floats match if values are close, due to roundoff error."
						(lit1 closeTo: lit2) ifFalse: [^ false]] 
					ifFalse: ["any other discrepancy is a failure"
						^ false]]]].
	^ true! !


!CompiledMethod methodsFor: 'decompiling' stamp: 'md 3/4/2006 12:34'!
compilerClass
	^self methodClass 
		ifNil: [self class compilerClass] 
		ifNotNilDo: [:class | class compilerClass].! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'md 2/16/2006 17:08'!
decompile
	"Return the decompiled parse tree that represents self"

	|  class selector |
	class := self methodClass ifNil: [Object].
	selector := self selector ifNil: [self defaultSelector].
	^class decompilerClass new decompile: selector in: class method: self.! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'md 3/4/2006 12:34'!
decompilerClass
	^ self isClosureCompiled
			ifTrue: [self compilerClass closureDecompilerClass] 
			ifFalse: [self compilerClass decompilerClass]! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'md 2/16/2006 13:26'!
decompileString
	^self decompile decompileString! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'md 2/22/2006 15:59'!
decompileWithTemps
	"Return the decompiled parse tree that represents self, but get the temp names
	 by compiling the sourcecode..."

	|  class selector |
	class := self methodClass ifNil: [Object].
	selector := self selector ifNil: [self defaultSelector].

	(self fileIndex > 0 and: [(SourceFiles at: self fileIndex) isNil]) ifTrue: [
			"Emergency or no source file -- decompile without temp names "
			^self decompile.
	].
	^((self decompilerClass new withTempNames: self methodNode tempNames)
						decompile: selector
						in: class
						method: self)! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'md 3/4/2006 12:35'!
methodNode
	"Return the parse tree that represents self"

	| source |
	^ (source := self getSourceFromFile)
		ifNil: [self decompile]
		ifNotNil: [self parserClass new 
					parse: source 
					class: (self methodClass ifNil: [self sourceClass])]! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'md 2/19/2006 23:30'!
methodNodeFormattedAndDecorated: decorate
	"Answer a method node made from pretty-printed (and colorized, if decorate is true) 
	 source text."

	| class source node  |
	
	source := self getSourceFromFile.
	class := self methodClass ifNil: [self sourceClass].
	source ifNil: [^self decompile].
	source := class prettyPrinterClass 
				format: source
				in: class
				notifying: nil
				decorated: decorate.
	node := class parserClass new parse: source class: class.
	node sourceText: source.
	^node! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'md 3/4/2006 12:32'!
parserClass
	^ self isClosureCompiled 
			ifTrue: [self compilerClass closureParserClass] 
			ifFalse: [self compilerClass parserClass]! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 7/14/2001 12:34'!
primitiveNode

	| primNode n |
	primNode _ PrimitiveNode new num: (n _ self primitive).
	(n = 117 or: [n = 120]) ifTrue: [
		primNode spec: (self literalAt: 1)].
	^ primNode! !


!CompiledMethod methodsFor: 'evaluating' stamp: 'ajh 1/28/2003 12:33'!
valueWithReceiver: aReceiver arguments: anArray 

	^ aReceiver withArgs: anArray executeMethod: self! !


!CompiledMethod methodsFor: 'file in/out' stamp: 'md 1/21/2006 10:54'!
hasReportableSlip
	"Answer whether the receiver contains anything that should be brought 
	to the attention of the author when filing out. Customize the lists here 
	to suit your preferences. If slips do not get reported in spite of your 
	best efforts here, make certain that the Preference 'checkForSlips' is set 
	to true."
	| assoc |
	#(#doOnlyOnce: #halt #halt: #hottest #printDirectlyToDisplay #toRemove #personal #urgent  #haltOnce #haltOnce: #haltIf: )
		do: [:aLit | (self hasLiteral: aLit)
				ifTrue: [^ true]].
	#(#Transcript #AA #BB #CC #DD #EE )
		do: [:aSymbol | (assoc := Smalltalk
						associationAt: aSymbol
						ifAbsent: [])
				ifNotNil: [(self hasLiteral: assoc)
						ifTrue: [^ true]]].
	^ false! !

!CompiledMethod methodsFor: 'file in/out' stamp: 'yo 10/28/2004 22:38'!
objectForDataStream: refStrm
	
	self primitive = 117 ifTrue: [self literals first at: 4 put: 0].
! !

!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 10/6/2000 14:22'!
readDataFrom: aDataStream size: varsOnDisk
	"Fill in my fields.  My header and number of literals are already installed.  Must read both objects for the literals and bytes for the bytecodes."

	self error: 'Must use readMethod'.! !

!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 3/26/98 09:10'!
storeDataOn: aDataStream
	"Store myself on a DataStream.  I am a mixture of objects and raw data bytes.  Only use this for blocks.  Normal methodDictionaries should not be put out using ReferenceStreams.  Their fileOut should be attached to the beginning of the file."

	| byteLength lits |
	"No inst vars of the normal type"
	byteLength _ self basicSize.
	aDataStream
		beginInstance: self class
		size: byteLength.
	lits _ self numLiterals + 1.	"counting header"
	1 to: lits do:
		[:ii | aDataStream nextPut: (self objectAt: ii)].
	lits*4+1 to: byteLength do:
		[:ii | aDataStream byteStream nextPut: (self basicAt: ii)].
			"write bytes straight through to the file"! !

!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 8/19/1998 16:20'!
veryDeepCopyWith: deepCopier
	"Return self.  I am always shared.  Do not record me.  Only use this for blocks.  Normally methodDictionaries should not be copied this way."! !

!CompiledMethod methodsFor: 'file in/out' stamp: 'RAA 8/21/2001 23:10'!
zapSourcePointer

	"clobber the source pointer since it will be wrong"
	0 to: 3 do: [ :i | self at: self size - i put: 0].
! !


!CompiledMethod methodsFor: 'initialize-release'!
copyWithTrailerBytes: bytes
"Testing:
	(CompiledMethod compiledMethodAt: #copyWithTrailerBytes:)
		tempNamesPut: 'copy end '
"
	| copy end start |
	start _ self initialPC.
	end _ self endPC.
	copy _ CompiledMethod newMethod: end - start + 1 + bytes size
				header: self header.
	1 to: self numLiterals do: [:i | copy literalAt: i put: (self literalAt: i)].
	start to: end do: [:i | copy at: i put: (self at: i)].
	1 to: bytes size do: [:i | copy at: end + i put: (bytes at: i)].
	^ copy! !

!CompiledMethod methodsFor: 'initialize-release' stamp: 'di 10/22/1999 13:14'!
needsFrameSize: newFrameSize
	"Set the largeFrameBit to accomodate the newFrameSize"
	| largeFrameBit header |
	largeFrameBit _ 16r20000.
	(self numTemps + newFrameSize) > LargeFrame ifTrue:
		[^ self error: 'Cannot compile -- stack including temps is too deep'].
	header _ self objectAt: 1.
	(header bitAnd: largeFrameBit) ~= 0
		ifTrue: [header _ header - largeFrameBit].
	self objectAt: 1 put: header
			+ ((self numTemps + newFrameSize) > SmallFrame
					ifTrue: [largeFrameBit]
					ifFalse: [0])! !

!CompiledMethod methodsFor: 'initialize-release' stamp: 'lr 2/6/2006 20:52'!
properties: aMethodProperties
	"Set the method-properties of the receiver to aMethodProperties."

	aMethodProperties pragmas do: [ :each | each setMethod: self ].
	^ self literalAt: self numLiterals - 1 put: aMethodProperties.! !


!CompiledMethod methodsFor: 'literals' stamp: 'di 10/17/97 22:38'!
hasLiteral: literal 
	"Answer whether the receiver references the argument, literal."

	<primitive: 132>  "a fast primitive operation equivalent to..."

	2 to: self numLiterals + 1 do:
		[:index |
		literal == (self objectAt: index) ifTrue: [^ true]].
	^ false! !

!CompiledMethod methodsFor: 'literals' stamp: 'md 3/3/2006 10:52'!
hasLiteralSuchThat: aBlock
	"Answer true if aBlock returns true for any literal in this method, even if imbedded in array structure or within its pragmas."
	
	| literal |
	self pragmas do: [ :pragma |
		(pragma hasLiteralSuchThat: aBlock)
			ifTrue: [ ^ true ] ].
	2 to: self numLiterals + 1 do: [ :index | 
		literal := self objectAt: index.
		(aBlock value: literal)
			ifTrue: [ ^ true ].
		(literal hasLiteralSuchThat: aBlock)
			ifTrue: [ ^ true ] ].
	^ false.! !

!CompiledMethod methodsFor: 'literals' stamp: 'md 3/3/2006 10:51'!
hasLiteralThorough: aLiteral
	"Answer true if any literal in this method is literal, even if embedded in array structure or within its pragmas."

	| literal |
	self pragmas do: [ :pragma |
		(pragma hasLiteral: aLiteral) ifTrue: [ ^ true ] ].
	2 to: self numLiterals + 1 do: [ :index | 
		literal := self objectAt: index.
		literal == aLiteral  ifTrue: [ ^ true ].
		(literal hasLiteralThorough: aLiteral) ifTrue: [ ^ true ] ].
	^ false.! !

!CompiledMethod methodsFor: 'literals'!
header
	"Answer the word containing the information about the form of the 
	receiver and the form of the context needed to run the receiver."

	^self objectAt: 1! !

!CompiledMethod methodsFor: 'literals' stamp: 'md 1/20/2006 16:46'!
headerDescription
	"Answer a description containing the information about the form of the 
	receiver and the form of the context needed to run the receiver."

	| s |
	s _ '' writeStream.
	self header printOn: s.
	s cr; nextPutAll: '"primitive: '.
	self primitive printOn: s.
	s cr; nextPutAll: ' numArgs: '.
	self numArgs printOn: s.
	s cr; nextPutAll: ' numTemps: '.
	self numTemps printOn: s.
	s cr; nextPutAll: ' numLiterals: '.
	self numLiterals printOn: s.
	s cr; nextPutAll: ' frameSize: '.
	self frameSize printOn: s.
	s cr; nextPutAll: ' isClosureCompiled: '.
	self isClosureCompiled printOn: s.
	s cr; nextPutAll: ' isBlockMethod: '.
	self isBlockMethod printOn: s.
	s nextPut: $"; cr.
	^ s contents! !

!CompiledMethod methodsFor: 'literals'!
literalAt: index 
	"Answer the literal indexed by the argument."

	^self objectAt: index + 1! !

!CompiledMethod methodsFor: 'literals'!
literalAt: index put: value 
	"Replace the literal indexed by the first argument with the second 
	argument. Answer the second argument."

	^self objectAt: index + 1 put: value! !

!CompiledMethod methodsFor: 'literals' stamp: 'ar 4/10/2005 22:16'!
literalStrings
	| lits litStrs |
	lits _ self literals.
	litStrs _ OrderedCollection new: lits size * 3.
	self literals do:
		[:lit | 
		(lit isVariableBinding)
			ifTrue: [litStrs addLast: lit key]
			ifFalse: [(lit isSymbol)
				ifTrue: [litStrs addAll: lit keywords]
				ifFalse: [litStrs addLast: lit printString]]].
	^ litStrs! !

!CompiledMethod methodsFor: 'literals'!
literals
	"Answer an Array of the literals referenced by the receiver."
	| literals numberLiterals |
	literals _ Array new: (numberLiterals _ self numLiterals).
	1 to: numberLiterals do:
		[:index |
		literals at: index put: (self objectAt: index + 1)].
	^literals! !

!CompiledMethod methodsFor: 'literals' stamp: 'dvf 11/12/2002 00:44'!
literalsDo: aOneArgumentBlock

	^self literals do:aOneArgumentBlock.! !

!CompiledMethod methodsFor: 'literals'!
objectAt: index 
	"Primitive. Answer the method header (if index=1) or a literal (if index 
	>1) from the receiver. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 68>
	self primitiveFailed! !

!CompiledMethod methodsFor: 'literals'!
objectAt: index put: value 
	"Primitive. Store the value argument into a literal in the receiver. An 
	index of 2 corresponds to the first literal. Fails if the index is less than 2 
	or greater than the number of literals. Answer the value as the result. 
	Normally only the compiler sends this message, because only the 
	compiler stores values in CompiledMethods. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 69>
	self primitiveFailed! !

!CompiledMethod methodsFor: 'literals' stamp: 'dvf 11/12/2002 00:44'!
refersToLiteral:aLiteral

	^self hasLiteral: aLiteral.! !

!CompiledMethod methodsFor: 'literals' stamp: 'dvf 11/12/2002 00:44'!
sendsSelector: aSymbol 

	^ self messages includes: aSymbol! !


!CompiledMethod methodsFor: 'printing' stamp: 'sw 7/29/2002 02:24'!
dateMethodLastSubmitted
	"Answer a Date object indicating when a method was last submitted.  If there is no date stamp, return nil"
	"(CompiledMethod compiledMethodAt: #dateMethodLastSubmitted) dateMethodLastSubmitted"

	| aStamp tokens |
	aStamp _ self timeStamp.
	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]! !

!CompiledMethod methodsFor: 'printing' stamp: 'ajh 2/9/2003 14:17'!
longPrintOn: aStream
	"List of all the byte codes in a method with a short description of each" 

	self longPrintOn: aStream indent: 0! !

!CompiledMethod methodsFor: 'printing' stamp: 'ar 6/28/2003 00:08'!
longPrintOn: aStream indent: tabs
	"List of all the byte codes in a method with a short description of each" 

	self isQuick ifTrue: 
		[self isReturnSpecial ifTrue:
			[^ aStream tab: tabs; nextPutAll: 'Quick return ' , 
				(#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)].
		^ aStream nextPutAll: 'Quick return field ' , self returnField printString , ' (0-based)'].

	self primitive = 0 ifFalse: [
		aStream tab: tabs.
		self printPrimitiveOn: aStream.
	].
	(InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream.
! !

!CompiledMethod methodsFor: 'printing' stamp: 'sma 6/1/2000 09:45'!
printOn: aStream 
	"Overrides method inherited from the byte arrayed collection."

	self printNameOn: aStream.
	aStream space; nextPutAll: self identityHashPrintString! !

!CompiledMethod methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:09'!
printOnStream: aStream 
	"Overrides method inherited from the byte arrayed collection."

	aStream print: 'a CompiledMethod'! !

!CompiledMethod methodsFor: 'printing' stamp: 'ar 11/28/1999 19:37'!
printPrimitiveOn: aStream
	"Print the primitive on aStream"
	| primIndex primDecl |
	primIndex _ self primitive.
	primIndex = 0 ifTrue:[^self].
	primIndex = 120 "External call spec"
		ifTrue:[^aStream print: (self literalAt: 1); cr].
	aStream nextPutAll: '<primitive: '.
	primIndex = 117 ifTrue:[
		primDecl _ self literalAt: 1.
		aStream 
			nextPut: $';
			nextPutAll: (primDecl at: 2);
			nextPut:$'.
		(primDecl at: 1) notNil ifTrue:[
			aStream 
				nextPutAll:' module:';
				nextPut:$';
				nextPutAll: (primDecl at: 1);
				nextPut:$'.
		].
	] ifFalse:[aStream print: primIndex].
	aStream nextPut: $>; cr! !

!CompiledMethod methodsFor: 'printing'!
storeLiteralsOn: aStream forClass: aBehavior
	"Store the literals referenced by the receiver on aStream, each terminated by a space."

	| literal |
	2 to: self numLiterals + 1 do:
		[:index |
		 aBehavior storeLiteral: (self objectAt: index) on: aStream.
		 aStream space]! !

!CompiledMethod methodsFor: 'printing'!
storeOn: aStream
	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' newMethod: '.
	aStream store: self size - self initialPC + 1.
	aStream nextPutAll: ' header: '.
	aStream store: self header.
	aStream nextPut: $).
	noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream.
	1 to: self numLiterals do:
		[:index |
		noneYet
			ifTrue: [noneYet _ false]
			ifFalse: [aStream nextPut: $;].
		aStream nextPutAll: ' literalAt: '.
		aStream store: index.
		aStream nextPutAll: ' put: '.
		aStream store: (self literalAt: index)].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!CompiledMethod methodsFor: 'printing' stamp: 'ajh 3/20/2001 11:41'!
symbolic
	"Answer a String that contains a list of all the byte codes in a method 
	with a short description of each."

	| aStream |
	aStream _ WriteStream on: (String new: 1000).
	self longPrintOn: aStream.
	^aStream contents! !

!CompiledMethod methodsFor: 'printing' stamp: 'yo 3/16/2004 12:29'!
timeStamp
	"Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available."

	"(CompiledMethod compiledMethodAt: #timeStamp) timeStamp"

	| file preamble stamp tokens tokenCount |
	self fileIndex == 0 ifTrue: [^ String new].  "no source pointer for this method"
	file _ SourceFiles at: self fileIndex.
	file ifNil: [^ String new].  "sources file not available"
	"file does not exist happens in secure mode"
	file _ [file readOnlyCopy] on: FileDoesNotExistException do:[:ex| nil].
	file ifNil: [^ String new].
	preamble _ self getPreambleFrom: file at: (0 max: self filePosition - 3).
		stamp _ String new.
		tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [Scanner new scanTokens: preamble]
			ifFalse: [Array new  "ie cant be back ref"].
		(((tokenCount _ tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokenCount - 3) = #stamp:
					ifTrue: ["New format gives change stamp and unified prior pointer"
							stamp _ tokens at: tokenCount - 2]].
		((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokenCount  - 1) = #stamp:
					ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokenCount]].
	file close.
	^ stamp
! !


!CompiledMethod methodsFor: 'scanning' stamp: 'md 4/27/2006 15:12'!
hasInstVarRef
	"Answer whether the method references an instance variable."

	| scanner end printer |

	scanner _ InstructionStream on: self.
	printer _ InstVarRefLocator new.
	end _ self endPC.

	[scanner pc <= end] whileTrue: [
		(printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
	].
	^false! !

!CompiledMethod methodsFor: 'scanning'!
messages
	"Answer a Set of all the message selectors sent by this method."

	| scanner aSet |
	aSet _ Set new.
	scanner _ InstructionStream on: self.
	scanner	
		scanFor: 
			[:x | 
			scanner addSelectorTo: aSet.
			false	"keep scanning"].
	^aSet! !

!CompiledMethod methodsFor: 'scanning' stamp: 'dvf 11/12/2002 00:44'!
messagesDo: aBlock 

	^ self messages do:aBlock.! !

!CompiledMethod methodsFor: 'scanning' stamp: 'md 2/20/2006 21:18'!
readsField: varIndex 
	"Answer whether the receiver loads the instance variable indexed by the argument."

	self allEmbeddedBlockMethods do: [:meth |
		| scanner catcher instr scan |
		scanner := meth scanner.
		catcher := MessageCatcher new.
		[scanner atEnd] whileFalse: [
			instr := scanner interpretNextInstructionFor: catcher.
			(instr selector = #send:super:numArgs: and: [instr argument = #privGetInstVar:]) ifTrue: [
				scan := scanner copy.
				scan pc: scan previousPc. scan pc: scan previousPc.
				instr := scan interpretNextInstructionFor: catcher.
				(instr selector = #pushConstant: and: [instr argument = varIndex])
					ifTrue: [^ true]
			].
		].
	].
	self isReturnField ifTrue: [^ self returnField + 1 = varIndex].
	varIndex <= 16 ifTrue: [^ self scanFor: varIndex - 1].
	varIndex <= 64 ifTrue: [^ self scanLongLoad: varIndex - 1].
	^ self scanVeryLongLoad: 64 offset: varIndex - 1! !

!CompiledMethod methodsFor: 'scanning'!
readsRef: literalAssociation 
	"Answer whether the receiver loads the argument."
	| lit |
	lit _ self literals indexOf: literalAssociation ifAbsent: [^false].
	lit <= 32 ifTrue: [^self scanFor: 64 + lit - 1].
	lit <= 64 ifTrue: [^self scanLongLoad: 192 + lit - 1].
	^ self scanVeryLongLoad: 128 offset: lit - 1! !

!CompiledMethod methodsFor: 'scanning'!
scanFor: byte 
	"Answer whether the receiver contains the argument as a bytecode."

	^ (InstructionStream on: self) scanFor: [:instr | instr = byte]
"
Smalltalk browseAllSelect: [:m | m scanFor: 134]
"! !

!CompiledMethod methodsFor: 'scanning'!
scanLongLoad: extension 
	"Answer whether the receiver contains a long load whose extension is the 
	argument."

	| scanner |
	scanner _ InstructionStream on: self.
	^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! !

!CompiledMethod methodsFor: 'scanning'!
scanLongStore: extension 
	"Answer whether the receiver contains a long store whose extension is 
	the argument."
	| scanner |
	scanner _ InstructionStream on: self.
	^scanner scanFor: 
		[:instr |  (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]! !

!CompiledMethod methodsFor: 'scanning'!
scanVeryLongLoad: extension offset: offset
	"Answer whether the receiver contains a long load whose extension is the 
	argument."
	| scanner |
	scanner _ InstructionStream on: self.
	^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension])
											and: [scanner thirdByte = offset]]! !

!CompiledMethod methodsFor: 'scanning' stamp: 'di 6/25/97 19:08'!
scanVeryLongStore: extension offset: offset
	"Answer whether the receiver contains a long load with the given offset.
	Note that the constant +32 is the known difference between a
	store and a storePop for instVars, and it will always fail on literal variables,
	but these only use store (followed by pop) anyway."
	| scanner ext |
	scanner _ InstructionStream on: self.
	^ scanner scanFor:
		[:instr | (instr = 132 and: [(ext _ scanner followingByte) = extension
											or: ["might be a store/pop into rcvr"
												ext = (extension+32)]])
							and: [scanner thirdByte = offset]]! !

!CompiledMethod methodsFor: 'scanning'!
sendsToSuper
	"Answer whether the receiver sends any message to super."
	| scanner |
	scanner _ InstructionStream on: self.
	^ scanner scanFor: 
		[:instr |  instr = 16r85 or: [instr = 16r84
						and: [scanner followingByte between: 16r20 and: 16r3F]]]! !

!CompiledMethod methodsFor: 'scanning' stamp: 'md 2/20/2006 21:19'!
writesField: field 
	"Answer whether the receiver stores into the instance variable indexed by the argument."

	self allEmbeddedBlockMethods do: [:meth |
		| scanner catcher instr scan |
		scanner := meth scanner.
		catcher := MessageCatcher new.
		[scanner atEnd] whileFalse: [
			instr := scanner interpretNextInstructionFor: catcher.
			(instr selector = #send:super:numArgs: and: [instr argument = #privStoreIn:instVar:]) ifTrue: [
				scan := scanner copy.
				scan pc: scan previousPc. scan pc: scan previousPc.
				instr := scan interpretNextInstructionFor: catcher.
				(instr selector = #pushConstant: and: [instr argument = field])
					ifTrue: [^ true]
			].
		].
	].
	self isQuick ifTrue: [^ false].
	field <= 8 ifTrue:
		[^ (self scanFor: 96 + field - 1) or: [self scanLongStore: field - 1]].
	field <= 64 ifTrue:
		[^ self scanLongStore: field - 1].
	^ self scanVeryLongStore: 160 offset: field - 1! !

!CompiledMethod methodsFor: 'scanning'!
writesRef: ref 
	"Answer whether the receiver stores the argument."
	| lit |
	lit _ self literals indexOf: ref ifAbsent: [^false].
	lit <= 64 ifTrue: [^ self scanLongStore: 192 + lit - 1].
	^ self scanVeryLongStore: 224 offset: lit - 1! !


!CompiledMethod methodsFor: 'source code management' stamp: 'tk 12/7/2000 12:28'!
checkOKToAdd: size at: filePosition
	"Issue several warnings as the end of the changes file approaches its limit,
	and finally halt with an error when the end is reached."

	| fileSizeLimit margin |
	fileSizeLimit _ 16r2000000.
	3 to: 1 by: -1 do:
		[:i | margin _ i*100000.
		(filePosition + size + margin) > fileSizeLimit
			ifTrue: [(filePosition + margin) > fileSizeLimit ifFalse:
						[self inform: 'WARNING: your changes file is within
' , margin printString , ' characters of its size limit.
You should take action soon to reduce its size.
You may proceed.']]
			ifFalse: [^ self]].
	(filePosition + size > fileSizeLimit) ifFalse: [^ self].
	self error: 'You have reached the size limit of the changes file.
You must take action now to reduce it.
Close this error.  Do not attempt to proceed.'! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 1/7/2004 15:32'!
copyWithTempNames: tempNames
	| tempStr compressed |
	tempStr _ String streamContents:
		[:strm | tempNames do: [:n | strm nextPutAll: n; space]].
	compressed := self qCompress: tempStr firstTry: true.
	compressed ifNil:
		["failure case (tempStr too big) will just decompile with tNN names"
		^ self copyWithTrailerBytes: #(0 0 0 0)].
	^ self copyWithTrailerBytes: compressed! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'!
fileIndex
	^SourceFiles fileIndexFromSourcePointer: self sourcePointer! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:45'!
filePosition
	^SourceFiles filePositionFromSourcePointer: self sourcePointer! !

!CompiledMethod methodsFor: 'source code management' stamp: 'yo 3/16/2004 12:23'!
getPreambleFrom: aFileStream at: position
	|  writeStream |
	writeStream _ String new writeStream.
	position
		to: 0
		by: -1
		do: [:p | 
			| c | 
			aFileStream position: p.
			c _ aFileStream basicNext.
			c == $!!
				ifTrue: [^ writeStream contents reverse]
				ifFalse: [writeStream nextPut: c]]! !

!CompiledMethod methodsFor: 'source code management'!
getSource
	^ self getSourceFor: self selector in:self methodClass.! !

!CompiledMethod methodsFor: 'source code management' stamp: 'md 2/28/2006 17:51'!
getSourceFor: selector in: class
	"Retrieve or reconstruct the source code for this method."
	| source flagByte sourceSelector |
	flagByte _ self last.
	(flagByte = 0
		or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0"
			and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]])
		ifTrue: ["No source pointer -- decompile without temp names"
		^ self decompileString].
	flagByte < 252 ifTrue:
		["Magic sources -- decompile with temp names"
		^ ((self decompilerClass new withTempNames: self tempNames)
				decompile: selector in: class method: self)
			decompileString].

	"Situation normal;  read the sourceCode from the file"
	
	[ source _ self getSourceFromFile ] on: Error do: [ :ex |
		"An error can happen here if, for example, the changes file has been truncated by an aborted download.  The present solution is to ignore the error and fall back on the decompiler.  A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file.  Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned."
		source _ nil ].
	
	source ifNotNil: [
		sourceSelector _ Parser parserClass new parseSelector: source.
		^sourceSelector = selector
			ifTrue: [source]
			ifFalse: [
				self replace: sourceSelector with: selector in: source]].

	"Something really wrong -- decompile blind (no temps)"
	^ self decompileString! !

!CompiledMethod methodsFor: 'source code management' stamp: 'tk 12/12/97 13:03'!
getSourceFromFile
	"Read the source code from file, determining source file index and
	file position from the last 3 bytes of this method."
	| position |
	(position _ self filePosition) = 0 ifTrue: [^ nil].
	^ (RemoteString newFileNumber: self fileIndex position: position)
			text! !

!CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 09:45'!
holdsTempNames
	"Are tempNames stored in trailer bytes"

	| flagByte |
	flagByte _ self last.
	(flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0"
			and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]])
		ifTrue: [^ false].  "No source pointer & no temp names"
	flagByte < 252 ifTrue: [^ true].  "temp names compressed"
	^ false	"Source pointer"
! !

!CompiledMethod methodsFor: 'source code management' stamp: 'md 6/2/2006 10:34'!
linesOfCode
	"An approximate measure of lines of code.
	Includes comments, but excludes blank lines."
	| strm line lines |
	lines _ 0.
	strm _ ReadStream on: self getSource.
		[strm atEnd] whileFalse:
			[line _ strm upTo: Character cr.
			line isEmpty ifFalse: [lines _ lines+1]].
	^lines ! !

!CompiledMethod methodsFor: 'source code management'!
putSource: sourceStr fromParseNode: methodNode class: class category: catName
	inFile: fileIndex priorMethod: priorMethod

	^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble:
			[:file | class printCategoryChunk: catName on: file priorMethod: priorMethod.
			file cr]! !

!CompiledMethod methodsFor: 'source code management' stamp: '6/5/97 di'!
putSource: sourceStr fromParseNode: methodNode class: class category: catName
	withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod

	^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble:
			[:file |
			class printCategoryChunk: catName on: file
				withStamp: changeStamp priorMethod: priorMethod.
			file cr]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'md 8/14/2005 17:47'!
putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock
	"Store the source code for the receiver on an external file.
	If no sources are available, i.e., SourceFile is nil, then store
	temp names for decompilation at the end of the method.
	If the fileIndex is 1, print on *.sources;  if it is 2, print on *.changes,
	in each case, storing a 4-byte source code pointer at the method end."

	| file remoteString  |
	(SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue:
		[^ self become: (self copyWithTempNames: methodNode tempNames)].

	SmalltalkImage current assureStartupStampLogged.
	file setToEnd.

	preambleBlock value: file.  "Write the preamble"
	remoteString _ RemoteString newString: sourceStr
						onFileNumber: fileIndex toFile: file.

	file nextChunkPut: ' '.
	InMidstOfFileinNotification signal ifFalse: [file flush].
	self checkOKToAdd: sourceStr size at: remoteString position.
	self setSourcePosition: remoteString position inFile: fileIndex! !

!CompiledMethod methodsFor: 'source code management' stamp: 'yo 3/16/2004 12:48'!
qCompress: string firstTry: firstTry
	"A very simple text compression routine designed for method temp names.
	Most common 12 chars get values 0-11 packed in one 4-bit nibble;
	others get values 12-15 (2 bits) * 16 plus next nibble.
	Last char of str must be a space so it may be dropped without
	consequence if output ends on odd nibble.
	Normal call is with firstTry == true."
	| charTable odd ix oddNibble names shorterStr maybe str temps |
	 str _ string isOctetString
				ifTrue: [string]
				ifFalse: [temps _ string findTokens: ' '.
					String
						streamContents: [:stream | 1
								to: temps size
								do: [:index | 
									stream nextPut: $t.
									stream nextPutAll: index asString.
									stream space]]].
	charTable _  "Character encoding table must match qDecompress:"
	' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
	^ ByteArray streamContents:
		[:strm | odd _ true.  "Flag for odd or even nibble out"
		oddNibble _ nil.
		str do:
			[:char | ix _ (charTable indexOf: char) - 1.
			(ix <= 12 ifTrue: [Array with: ix]
				ifFalse: [Array with: ix//16+12 with: ix\\16])
				do:
				[:nibble | (odd _ odd not)
					ifTrue: [strm nextPut: oddNibble*16 + nibble]
					ifFalse: [oddNibble _ nibble]]].
		strm position > 251 ifTrue:
			["Only values 1...251 are available for the flag byte
			that signals compressed temps. See the logic in endPC."
			"Before giving up completely, we attempt to encode most of
			the temps, but with the last few shortened to tNN-style names."
			firstTry ifFalse: [^ nil "already tried --give up now"].
			names _ str findTokens: ' '.
			names size < 8 ifTrue: [^ nil  "weird case -- give up now"].
			4 to: names size//2 by: 4 do:
				[:i | shorterStr _ String streamContents:
					[:s |
					1 to: names size - i do: [:j | s nextPutAll: (names at: j); space].
					1 to: i do: [:j | s nextPutAll: 't' , j printString; space]].
				(maybe _ self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]].
			^ nil].
		strm nextPut: strm position]
"
  | m s |  m _ CompiledMethod new.
s _ 'charTable odd ix oddNibble '.
^ Array with: s size with: (m qCompress: s) size
	with: (m qDecompress: (m qCompress: s))
"
! !

!CompiledMethod methodsFor: 'source code management'!
qDecompress: byteArray
	"Decompress strings compressed by qCompress:.
	Most common 12 chars get values 0-11 packed in one 4-bit nibble;
	others get values 12-15 (2 bits) * 16 plus next nibble"
	|  charTable extended ext |
	charTable _  "Character encoding table must match qCompress:"
	' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
	^ String streamContents:
		[:strm | extended _ false.  "Flag for 2-nibble characters"
		byteArray do:
			[:byte | 
			(Array with: byte//16 with: byte\\16)
				do:
				[:nibble | extended
					ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended _ false]
					ifFalse: [nibble < 12 ifTrue: [strm nextPut: (charTable at: nibble + 1)]
									ifFalse: [ext _ nibble-12.  extended _ true]]]]]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'md 1/20/2006 16:36'!
setMySourcePointer: srcPointer

	srcPointer = 0 ifTrue: [
		self at: self size put: 0.
		^self].
	(srcPointer between: 16r1000000 and: 16r4FFFFFF) ifFalse: [self error: 'Source pointer out of range'].
	self at: self size put: (srcPointer bitShift: -24) + 251.
	1 to: 3 do: [:i |
		self at: self size-i put: ((srcPointer bitShift: (i-3)*8) bitAnd: 16rFF)]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'md 2/20/2006 21:19'!
setSourcePointer: srcPointer

	self setMySourcePointer: srcPointer.
	self embeddedBlockMethods do: [:m |
		m setSourcePointer: srcPointer].
! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 21:02'!
setSourcePosition: position inFile: fileIndex 
	self setSourcePointer: (SourceFiles sourcePointerFromFileIndex: fileIndex andPosition: position)! !

!CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:19'!
sourceClass
	"Get my receiver class (method class) from the preamble of my source.  Return nil if not found."

	^ [(Compiler evaluate: (self sourceFileStream backChunk "blank"; backChunk "preamble")) theClass] on: Error do: [nil]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:18'!
sourceFileStream 
	"Answer the sources file stream with position set at the beginning of my source string"

	| pos |
	(pos _ self filePosition) = 0 ifTrue: [^ nil].
	^ (RemoteString newFileNumber: self fileIndex position: pos) fileStream! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'!
sourcePointer
	"Answer the integer which can be used to find the source file and position for this method.
	The returned value is either 0 (if no source is stored) or a number between 16r1000000 and 16r4FFFFFF.
	The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles."

	| pos |
	self last < 252 ifTrue: [^ 0  "no source"].
	pos _ self last - 251.
	self size - 1 to: self size - 3 by: -1 do: [:i | pos _ pos * 256 + (self at: i)].
	^pos! !

!CompiledMethod methodsFor: 'source code management' stamp: 'md 8/2/2006 20:25'!
sourceSelector
	"Answer my selector extracted from my source.  If no source answer nil"

	| sourceString |
	sourceString _ self getSourceFromFile ifNil: [^ nil].
	^self methodClass parserClass new parseSelector: sourceString! !

!CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 00:29'!
tempNames

	| byteCount bytes |
	self holdsTempNames ifFalse: [
		^ (1 to: self numTemps) collect: [:i | 't', i printString]
	].
	byteCount _ self at: self size.
	byteCount = 0 ifTrue: [^ Array new].
	bytes _ (ByteArray new: byteCount)
		replaceFrom: 1 to: byteCount with: self 
		startingAt: self size - byteCount.
	^ (self qDecompress: bytes) findTokens: ' '! !


!CompiledMethod methodsFor: 'testing' stamp: 'emm 5/30/2002 09:22'!
hasBreakpoint
	^BreakpointManager methodHasBreakpoint: self! !

!CompiledMethod methodsFor: 'testing' stamp: 'md 2/19/2006 11:26'!
hasNewPropertyFormat
	^self properties isMethodProperties.! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 12/12/2003 15:18'!
isAbstract
	| marker |
	marker _ self markerOrNil.
	^ marker notNil and: [self class abstractMarkers includes: marker].! !

!CompiledMethod methodsFor: 'testing' stamp: 'md 11/21/2003 12:15'!
isCompiledMethod

	^ true! !

!CompiledMethod methodsFor: 'testing' stamp: 'al 1/23/2004 13:12'!
isConflict
	^ self markerOrNil == self class conflictMarker! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'!
isDisabled
	^ self isDisabled: self markerOrNil! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'!
isDisabled: marker
	^ marker == self class disabledMarker! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'!
isExplicitlyRequired
	^ self isExplicitlyRequired: self markerOrNil! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'!
isExplicitlyRequired: marker
	^ marker == self class explicitRequirementMarker! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'!
isImplicitlyRequired
	^ self isImplicitlyRequired: self markerOrNil! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'!
isImplicitlyRequired: marker
	^ marker == self class implicitRequirementMarker! !

!CompiledMethod methodsFor: 'testing' stamp: 'md 2/19/2006 11:26'!
isInstalled
	| class selector |
	class := self methodClass ifNil: [^false].
	selector := self selector ifNil: [^false].
	^self == (class methodDict at: selector ifAbsent: [^false]).! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:40'!
isProvided
	^ self isProvided: self markerOrNil! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:40'!
isProvided: marker
	marker ifNil: [^ true].
	^ (self isRequired: marker) not and: [(self isDisabled: marker) not]! !

!CompiledMethod methodsFor: 'testing' stamp: 'di 12/26/1998 21:31'!
isQuick
	"Answer whether the receiver is a quick return (of self or of an instance 
	variable)."
	^ self primitive between: 256 and: 519! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'!
isRequired
	^ self isRequired: self markerOrNil! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'!
isRequired: marker
	marker ifNil: [^ false].
	(self isImplicitlyRequired: marker) ifTrue: [^ true].
	(self isExplicitlyRequired: marker) ifTrue: [^ true]. 
	(self isSubclassResponsibility: marker) ifTrue: [^ true]. 
	^ false! !

!CompiledMethod methodsFor: 'testing' stamp: 'ar 6/2/1998 16:11'!
isReturnField
	"Answer whether the receiver is a quick return of an instance variable."
	^ self primitive between: 264 and: 519! !

!CompiledMethod methodsFor: 'testing'!
isReturnSelf
	"Answer whether the receiver is a quick return of self."

	^ self primitive = 256! !

!CompiledMethod methodsFor: 'testing'!
isReturnSpecial
	"Answer whether the receiver is a quick return of self or constant."

	^ self primitive between: 256 and: 263! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'!
isSubclassResponsibility
	^ self isSubclassResponsibility: self markerOrNil! !

!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'!
isSubclassResponsibility: marker
	^ marker == self class subclassResponsibilityMarker! !


!CompiledMethod methodsFor: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:32'!
inspectorClass
	"Answer the class of the inspector to be used on the receiver.  Called by inspect; 
	use basicInspect to get a normal (less useful) type of inspector."

	^ CompiledMethodInspector! !


!CompiledMethod methodsFor: 'private' stamp: 'al 2/13/2006 17:44'!
markerOrNil
	"If I am a marker method, answer the symbol used to mark me.  Otherwise
	answer nil.

	What is a marker method?  It is method with body like 
		'self subclassResponsibility' or '^ self subclassResponsibility' 
	used to indicate ('mark') a special property.

	Marker methods compile to bytecode like:

		9 <70> self
		10 <D0> send: <literal 1>
		11 <87> pop
		12 <78> returnSelf

	for the first form, or 

		9 <70> self
		10 <D0> send: <literal 1>
		11 <7C> returnTop

	for the second form."

	| e |
	((e _ self endPC) = 19 or: [e = 20]) ifFalse: [^ nil].
	(self numLiterals = 3) ifFalse:[^ nil].
	(self at: 17) =  16r70 ifFalse:[^ nil].		"push self"
	(self at: 18) = 16rD0 ifFalse:[^ nil].		"send <literal 1>"
	"If we reach this point, we have a marker method that sends self <literal 1>"
	^ self literalAt: 1
! !

!CompiledMethod methodsFor: 'private' stamp: 'md 8/2/2006 20:25'!
replace: oldSelector with: newSelector in: aText
	| oldKeywords newKeywords args newSelectorWithArgs startOfSource lastSelectorToken |
	oldKeywords _ oldSelector keywords.
	newKeywords _ (newSelector ifNil: [self defaultSelector]) keywords.
	self assert: oldKeywords size = newKeywords size.
	args _ (self methodClass parserClass new
		parseArgsAndTemps: aText string notifying: nil) copyFrom: 1 to: self numArgs.
	newSelectorWithArgs _ String streamContents: [:stream |
		newKeywords withIndexDo: [:keyword :index |
			stream nextPutAll: keyword.
			stream space.
			args size >= index ifTrue: [
				stream nextPutAll: (args at: index); space]]].
	lastSelectorToken _ args isEmpty
		ifFalse: [args last]
		ifTrue: [oldKeywords last].
	startOfSource _ (aText string
		indexOfSubCollection: lastSelectorToken startingAt: 1) + lastSelectorToken size.
	^newSelectorWithArgs withBlanksTrimmed asText , (aText copyFrom: startOfSource to: aText size)! !


!CompiledMethod methodsFor: '*39Deprecated' stamp: 'md 2/18/2006 19:40'!
decompileClass: aClass selector: selector
	"Return the decompiled parse tree that represents self"

	self deprecated: 'just call #decompile on the CompiledMethod'.
	^ self decompilerClass new decompile: selector in: aClass method: self! !

!CompiledMethod methodsFor: '*39Deprecated' stamp: 'md 2/16/2006 13:27'!
decompileTree
	self deprecated: 'just use #decompile'.
	^self decompile.! !

!CompiledMethod methodsFor: '*39Deprecated' stamp: 'md 2/16/2006 15:45'!
who
	"Answer an Array of the class in which the receiver is defined and the 
	selector to which it corresponds."
	
	self deprecated: 'use #methodClass and #selector directly'.
	self isInstalled ifFalse: [^#(unknown unknown)].
	^{self methodClass . self selector}.! !

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

CompiledMethod class
	instanceVariableNames: ''!

!CompiledMethod class methodsFor: 'class initialization' stamp: 'di 1/11/1999 22:13'!
fullFrameSize  "CompiledMethod fullFrameSize"
	^ LargeFrame! !

!CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 2/3/2003 21:16'!
initialize    "CompiledMethod initialize"
	"Initialize class variables specifying the size of the temporary frame
	needed to run instances of me."

	SmallFrame _ 16.	"Context range for temps+stack"
	LargeFrame _ 56.

	self classPool at: #BlockNodeCache ifAbsentPut: [nil->nil].! !

!CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 7/18/2001 02:04'!
smallFrameSize

	^ SmallFrame! !


!CompiledMethod class methodsFor: 'constants' stamp: 'NS 12/12/2003 15:17'!
abstractMarkers
	^ #(subclassResponsibility shouldNotImplement)! !

!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'!
conflictMarker
	^ #traitConflict! !

!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'!
disabledMarker
	^ #shouldNotImplement! !

!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'!
explicitRequirementMarker
	^ #explicitRequirement! !

!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'!
implicitRequirementMarker
	^ #requirement! !

!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'!
subclassResponsibilityMarker
	^ #subclassResponsibility! !


!CompiledMethod class methodsFor: 'instance creation' stamp: 'tk 9/9/2000 20:36'!
basicNew: size

	self error: 'CompiledMethods may only be created with newMethod:header:' ! !

!CompiledMethod class methodsFor: 'instance creation'!
new
	"This will not make a meaningful method, but it could be used
	to invoke some otherwise useful method in this class."
	^ self newMethod: 0 header: 0! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'NS 12/12/2003 15:03'!
newFrom: aCompiledMethod
	| inst |
	inst _ super basicNew: aCompiledMethod size.
	1 to: aCompiledMethod size do: [:index |
		inst at: index put: (aCompiledMethod at: index)].
	^ inst.! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'NS 12/12/2003 15:08'!
newInstanceFrom: oldInstance variable: variable size: instSize map: map
	"Create a new instance of the receiver based on the given old instance.
	The supplied map contains a mapping of the old instVar names into
	the receiver's instVars"
	| new |
	new _ self newFrom: oldInstance.
	1 to: instSize do: 
		[:offset |  (map at: offset) > 0 ifTrue:
			[new instVarAt: offset
					put: (oldInstance instVarAt: (map at: offset))]].
	^new! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'tk 1/21/2000 15:25'!
new: size

	self error: 'CompiledMethods may only be created with newMethod:header:'! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 7/14/2006 21:21'!
newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
	"Answer an instance of me. The header is specified by the message 
	arguments. The remaining parts are not as yet determined."
	| largeBit primBits method |
	nTemps > 63 ifTrue:
		[^ self error: 'Cannot compile -- too many temporary variables'].	
	nLits > 255 ifTrue:
		[^ self error: 'Cannot compile -- too many literals variables'].	
	largeBit _ (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0].
	primBits _ primitiveIndex <= 16r1FF
		ifTrue: [primitiveIndex]
		ifFalse: ["For now the high bit of primitive no. is in the 29th bit of header"
				primitiveIndex > 16r3FF ifTrue: [self error: 'prim num too large'].
				(primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19)].
	method _ self newMethod: numberOfBytes + trailer size
		header: (nArgs bitShift: 24) +
				(nTemps bitShift: 18) +
				(largeBit bitShift: 17) +
				(nLits bitShift: 9) +
				primBits.
	1 to: trailer size do:  "Copy the source code trailer to the end"
		[:i | method at: method size - trailer size + i put: (trailer at: i)].
	^ method! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 7/14/2006 21:21'!
newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag
	"Answer an instance of me. The header is specified by the message 
	arguments. The remaining parts are not as yet determined."
	| largeBit primBits method flagBit |
	nTemps > 63 ifTrue:
		[^ self error: 'Cannot compile -- too many temporary variables'].	
	nLits > 255 ifTrue:
		[^ self error: 'Cannot compile -- too many literals variables'].	
	largeBit _ (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0].

	"For now the high bit of the primitive no. is in a high bit of the header"
	primBits _ (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19).

	flagBit := flag ifTrue: [ 1 ] ifFalse: [ 0 ].

	method _ self newMethod: numberOfBytes + trailer size
		header: (nArgs bitShift: 24) +
				(nTemps bitShift: 18) +
				(largeBit bitShift: 17) +
				(nLits bitShift: 9) +
				primBits +
				(flagBit bitShift: 29).

	"Copy the source code trailer to the end"
	1 to: trailer size do:
		[:i | method at: method size - trailer size + i put: (trailer at: i)].

	^ method! !

!CompiledMethod class methodsFor: 'instance creation'!
newMethod: numberOfBytes header: headerWord 
	"Primitive. Answer an instance of me. The number of literals (and other 
	information) is specified the headerWord. The first argument specifies 
	the number of fields for bytecodes in the method. Fail if either 
	argument is not a SmallInteger, or if numberOfBytes is negative. Once 
	the header of a method is set by this primitive, it cannot be changed in 
	any way. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 79>
	(numberOfBytes isInteger and:
	 [headerWord isInteger and:
	 [numberOfBytes >= 0]]) ifTrue: [
		"args okay; space must be low"
		Smalltalk signalLowSpace.
		"retry if user proceeds"
		^ self newMethod: numberOfBytes header: headerWord
	].
	^self primitiveFailed! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 2/20/2006 21:10'!
primitive: primNum numArgs: numArgs numTemps: numTemps stackSize: stackSize literals: literals bytecodes: bytecodes trailer: trailerBytes
	"Create method with given attributes.  numTemps includes numArgs.  stackSize does not include numTemps."

	| compiledMethod |
	compiledMethod _ self
		newBytes: bytecodes size
		trailerBytes: trailerBytes 
		nArgs: numArgs
		nTemps: numTemps
		nStack: stackSize
		nLits: literals size
		primitive: primNum.
	(WriteStream with: compiledMethod)
		position: compiledMethod initialPC - 1;
		nextPutAll: bytecodes.
	literals withIndexDo: [:obj :i | compiledMethod literalAt: i put: obj].
	^ compiledMethod! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:06'!
toReturnConstant: index trailerBytes: trailer
	"Answer an instance of me that is a quick return of the constant
	indexed in (true false nil -1 0 1 2)."

	^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index
! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:06'!
toReturnField: field trailerBytes: trailer
	"Answer an instance of me that is a quick return of the instance variable 
	indexed by the argument, field."

	^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field
! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:51'!
toReturnSelf
	"Answer an instance of me that is a quick return of the instance (^self)."

	^ self toReturnSelfTrailerBytes: #(0 0 0 0)! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:05'!
toReturnSelfTrailerBytes: trailer
	"Answer an instance of me that is a quick return of the instance (^self)."

	^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256
! !
Inspector subclass: #CompiledMethodInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!CompiledMethodInspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
fieldList

	| keys |
	keys := OrderedCollection new.
	keys add: 'self'.
	keys add: 'all bytecodes'.
	keys add: 'header'.
	1 to: object numLiterals do: [ :i |
		keys add: 'literal', i printString ].
	object initialPC to: object size do: [ :i |
		keys add: i printString ].
	^ keys asArray
	! !


!CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2003 00:17'!
contentsIsString
	"Hacked so contents empty when deselected"

	^ #(0 2 3) includes: selectionIndex! !

!CompiledMethodInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'!
selection

	| bytecodeIndex |
	selectionIndex = 0 ifTrue: [^ ''].
	selectionIndex = 1 ifTrue: [^ object ].
	selectionIndex = 2 ifTrue: [^ object symbolic].
	selectionIndex = 3 ifTrue: [^ object headerDescription].
	selectionIndex <= (object numLiterals + 3) 
		ifTrue: [ ^ object objectAt: selectionIndex - 2 ].
	bytecodeIndex := selectionIndex - object numLiterals - 3.
	^ object at: object initialPC + bytecodeIndex - 1! !

!CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2001 11:56'!
selectionUnmodifiable
	"Answer if the current selected variable is unmodifiable via acceptance in the code pane.  For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable"

	^ true! !
ClassTestCase subclass: #CompiledMethodTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Methods'!
!CompiledMethodTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class CompiledMethod. 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!


!CompiledMethodTest methodsFor: 'examples' stamp: 'md 2/18/2006 20:09'!
returnPlusOne: anInteger
	^anInteger + 1. ! !

!CompiledMethodTest methodsFor: 'examples' stamp: 'md 2/18/2006 20:09'!
returnTrue
	^true  ! !


!CompiledMethodTest methodsFor: 'tests - evaluating' stamp: 'md 4/16/2003 15:30'!
testValueWithReceiverArguments
	
	| method value |

	method := self class compiledMethodAt: #returnTrue.

	value := method valueWithReceiver: nil arguments: #().
	self assert: (value = true).

	method := self class compiledMethodAt: #returnPlusOne:.
	value := method valueWithReceiver: nil arguments: #(1).
	self assert: (value = 2).	! !


!CompiledMethodTest methodsFor: 'tests - testing' stamp: 'md 2/19/2006 11:28'!
testHasNewPropertyFormat
		| method |
		method := (self class)>>#returnTrue.
		self assert: method hasNewPropertyFormat.
! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: 'md 2/18/2006 20:10'!
testIsInstalled
|  method cls |

	method := (self class)>>#returnTrue.
	self assert: method isInstalled.

	"now make an orphaned method by just deleting the class."

	Smalltalk removeClassNamed: #TUTU.

	cls := Object subclass: #TUTU
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'KernelTests-Methods'.
	cls compile: 'foo ^ 10'.
	method := cls >> #foo.
	Smalltalk removeClassNamed: #TUTU.

	self deny: method isInstalled. ! !

!CompiledMethodTest methodsFor: 'tests - testing' stamp: 'md 4/16/2003 15:32'!
testIsQuick
	| method  |

	method := self class compiledMethodAt: #returnTrue.
	self assert: (method isQuick).

	method := self class compiledMethodAt: #returnPlusOne:.
	self deny: (method isQuick).

	! !


!CompiledMethodTest methodsFor: 'tests - decompiling' stamp: 'md 2/16/2006 20:29'!
testDecompile
	"self debug: #testDecompileTree"
	| method  cls stream |

	Smalltalk removeClassNamed: #TUTU.

	cls := Object subclass: #TUTU
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'KernelTests-Methods'.
	cls compile: 'foo ^ 10'.
	method := cls >> #foo.
	Smalltalk removeClassNamed: #TUTU.
	stream := ReadWriteStream on: String new.
	method decompile printOn: stream.
	self assert: stream contents = 'foo
	^ 10'
	
	
	! !


!CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/18/2006 20:10'!
testMethodClass
	| method cls |
	method := self class >> #returnTrue.
	self assert: method selector = #returnTrue.
	"now make an orphaned method by just deleting the class.
	old: #unknown
	new semantics: return Absolete class"
	Smalltalk removeClassNamed: #TUTU.
	cls := Object
				subclass: #TUTU
				instanceVariableNames: ''
				classVariableNames: ''
				poolDictionaries: ''
				category: 'KernelTests-Methods'.
	cls compile: 'foo ^ 10'.
	method := cls >> #foo.
	Smalltalk removeClassNamed: #TUTU.
	self assert: method methodClass = cls! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/15/2006 20:54'!
testSearchForClass
	|  method cls |

	method := (self class)>>#returnTrue.
	self assert: (method searchForClass = self class).
	
	"now make an orphaned method. we want to get nil as the class"	
	
	Smalltalk removeClassNamed: #TUTU.

	cls := Object subclass: #TUTU
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'KernelTests-Methods'.
	cls compile: 'foo ^ 10'.
	method := cls >> #foo.
	Smalltalk removeClassNamed: #TUTU.
	
	self assert: method searchForClass = nil. 
! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/15/2006 20:55'!
testSearchForSelector
	|  method cls |

	method := (self class)>>#returnTrue.
	self assert: (method searchForSelector = #returnTrue).

	"now make an orphaned method. we want to get nil as the selector"	
	
	Smalltalk removeClassNamed: #TUTU.

	cls := Object subclass: #TUTU
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'KernelTests-Methods'.
	cls compile: 'foo ^ 10'.
	method := cls >> #foo.
	Smalltalk removeClassNamed: #TUTU.
	
	self assert: method searchForSelector = nil. 
! !

!CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/16/2006 20:28'!
testSelector
	|  method cls |

	method := (self class)>>#returnTrue.
	self assert: (method selector = #returnTrue).

	"now make an orphaned method. new semantics: return corrent name"	
	
	Smalltalk removeClassNamed: #TUTU.

	cls := Object subclass: #TUTU
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'KernelTests-Methods'.
	cls compile: 'foo ^ 10'.
	method := cls >> #foo.
	Smalltalk removeClassNamed: #TUTU.

	self assert: method selector = #foo. 
! !
Object subclass: #CompiledMethodWithNode
	instanceVariableNames: 'node method'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Support'!

!CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:03'!
method
	^ method! !

!CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'!
node
	^ node! !

!CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'!
selector
	^ self node selector! !


!CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:03'!
method: aCompiledMethod
	method _ aCompiledMethod! !

!CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:04'!
node: aMethodNode
	node _ aMethodNode! !

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

CompiledMethodWithNode class
	instanceVariableNames: ''!

!CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'!
generateMethodFromNode: aMethodNode trailer: bytes
	^ self method: (aMethodNode generate: bytes) node: aMethodNode.! !

!CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'!
method: aCompiledMethod node: aMethodNode
	^ self new method: aCompiledMethod; node: aMethodNode.! !
Object subclass: #Compiler
	instanceVariableNames: 'sourceStream requestor class category context parserClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Kernel'!
!Compiler commentStamp: '<historical>' prior: 0!
The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.!


!Compiler methodsFor: 'error handling'!
notify: aString 
	"Refer to the comment in Object|notify:."

	^self notify: aString at: sourceStream position + 1! !

!Compiler methodsFor: 'error handling' stamp: 'ar 9/27/2005 19:21'!
notify: aString at: location
	"Refer to the comment in Object|notify:."

	requestor == nil
		ifTrue: [^SyntaxErrorNotification
					inClass: class
					category: category
					withCode: 
						(sourceStream contents
							copyReplaceFrom: location
							to: location - 1
							with: aString)
					doitFlag: false]
		ifFalse: [^requestor
					notify: aString
					at: location
					in: sourceStream]! !


!Compiler methodsFor: 'public access' stamp: 'md 2/28/2006 10:04'!
compile: textOrStream in: aClass classified: aCategory notifying: aRequestor ifFail: failBlock 
	"Answer a MethodNode for the argument, textOrStream. If the 
	MethodNode can not be created, notify the argument, aRequestor; if 
	aRequestor is nil, evaluate failBlock instead. The MethodNode is the root 
	of a parse tree. It can be told to generate a CompiledMethod to be 
	installed in the method dictionary of the argument, aClass."
	
	| methodNode |
	self from: textOrStream
		class: aClass
		classified: aCategory 
		context: nil
		notifying: aRequestor.
	methodNode := self translate: sourceStream noPattern: false ifFail: failBlock.
	methodNode encoder requestor: requestor.
	^methodNode.
! !

!Compiler methodsFor: 'public access' stamp: 'md 2/28/2006 10:45'!
compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock 
	^self compile: textOrStream in: aClass classified: nil notifying: aRequestor ifFail: failBlock ! !

!Compiler methodsFor: 'public access' stamp: 'vb 8/13/2001 23:11'!
compileNoPattern: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock
	"Similar to #compile:in:notifying:ifFail:, but the compiled code is
	expected to be a do-it expression, with no message pattern."

	self from: textOrStream
		class: aClass
		context: aContext
		notifying: aRequestor.
	^self
		translate: sourceStream
		noPattern: true
		ifFail: failBlock! !

!Compiler methodsFor: 'public access' stamp: 'sd 1/19/2004 20:58'!
evaluate: aString in: aContext to: aReceiver
	"evaluate aString in the given context, and return the result.  2/2/96 sw"
	| result |
	result _ self
				evaluate: aString
				in: aContext
				to: aReceiver
				notifying: nil
				ifFail: [^ #failedDoit].
	^ result! !

!Compiler methodsFor: 'public access' stamp: 'NS 1/19/2004 09:05'!
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock
	^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false.! !

!Compiler methodsFor: 'public access' stamp: 'md 3/1/2006 12:31'!
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag
	"Compiles the sourceStream into a parse tree, then generates code into a method. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is directly invoked without modifying the receiving-class."

	| methodNode method value |
	class := (aContext isNil 
		ifTrue: [ receiver ] 
		ifFalse: [ aContext receiver ])
			class.
	self from: textOrStream class: class context: aContext notifying: aRequestor.
	methodNode := self 
		translate: sourceStream
		noPattern: true 
		ifFail: [ ^ failBlock value ].
	method := methodNode generate.
	method selector ifNil: [method selector: #DoIt].
	self interactive
		ifTrue: [ method := method copyWithTempNames: methodNode tempNames ].
	value := receiver 
		withArgs: (context isNil
			ifTrue: [ #() ]
			ifFalse: [ Array with: aContext ])
		executeMethod: method.
	logFlag 
		ifTrue: [ SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext ].
	^ value.! !

!Compiler methodsFor: 'public access' stamp: 'wiz 2/26/2006 15:35'!
format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol
	"Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely.  If aSymbol is #colorPrint, then decorate the resulting text with color and hypertext actions"

	^self format: textOrStream in: aClass notifying: aRequestor decorated: (aSymbol == #colorPrint)! !

!Compiler methodsFor: 'public access' stamp: 'sw 11/7/1999 00:11'!
format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean
	"Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely.  If aBoolean is true, then decorate the resulting text with color and hypertext actions"
	| aNode |
	self from: textOrStream
		class: aClass
		context: nil
		notifying: aRequestor.
	aNode _ self format: sourceStream noPattern: false ifFail: [^ nil].
	^ aBoolean
		ifTrue: [aNode decompileText]
		ifFalse: [aNode decompileString]! !

!Compiler methodsFor: 'public access' stamp: 'md 8/14/2005 17:58'!
parse: textOrStream in: aClass notifying: req
	"Compile the argument, textOrStream, with respect to the class, aClass, 
	and answer the MethodNode that is the root of the resulting parse tree. 
	Notify the argument, req, if an error occurs. The failBlock is defaulted to 
	an empty block."

	  self from: textOrStream class: aClass context: nil notifying: req.
       ^self parserClass new
                        parse: sourceStream
                        class: class
                        noPattern: false
                        context: context
                        notifying: requestor
                        ifFail: []! !

!Compiler methodsFor: 'public access' stamp: 'md 2/20/2006 21:16'!
translate: aStream noPattern: noPattern ifFail: failBlock parser: parser
	| tree |
	tree := parser
			parse: aStream
			class: class
			noPattern: noPattern
			context: context
			notifying: requestor
			ifFail: [^ failBlock value].
	^ tree! !


!Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:44'!
format: aStream noPattern: noPattern ifFail: failBlock
	| tree |
	tree _ 
		self parserClass new
			parse: aStream
			class: class
			noPattern: noPattern
			context: context
			notifying: requestor
			ifFail: [^ failBlock value].
	^ tree! !

!Compiler methodsFor: 'private' stamp: 'ar 9/27/2005 19:20'!
from: textOrStream class: aClass classified: aCategory context: aContext notifying: req

	(textOrStream isKindOf: PositionableStream)
		ifTrue: [sourceStream  := textOrStream]
		ifFalse: [sourceStream  := ReadStream on: textOrStream asString].
	class  := aClass.
	context  := aContext.
	requestor  := req.
	category  := aCategory
! !

!Compiler methodsFor: 'private'!
from: textOrStream class: aClass context: aContext notifying: req

	(textOrStream isKindOf: PositionableStream)
		ifTrue: [sourceStream _ textOrStream]
		ifFalse: [sourceStream _ ReadStream on: textOrStream asString].
	class _ aClass.
	context _ aContext.
	requestor _ req! !

!Compiler methodsFor: 'private' stamp: 'stephaneducassse 11/5/2005 16:39'!
interactive
	"this version of the method is necessary to load code from MC else the interactive mode is one. 
	This method is really bad since it links the compiler package with the Tools
	one. The solution would be to have a real SyntaxError exception belonging to the 
	compiler package and not a subclass of StringHolder - sd Nov 2005"
	"the code submitted by PlusTools is ideally the one that should be used
	interactive

	      ^requestor ~~ nil "
	
	^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not! !

!Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:44'!
parserClass

	^ parserClass! !

!Compiler methodsFor: 'private' stamp: 'md 1/20/2006 17:04'!
parserClass: aParserClass

	parserClass _ aParserClass.
! !

!Compiler methodsFor: 'private' stamp: 'ar 9/27/2005 19:21'!
translate: aStream noPattern: noPattern ifFail: failBlock
	| tree |
	tree  := 
		self parserClass new
			parse: aStream
			class: class
			category: category
			noPattern: noPattern
			context: context
			notifying: requestor
			ifFail: [^ failBlock value].
	^ tree
! !

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

Compiler class
	instanceVariableNames: ''!

!Compiler class methodsFor: 'accessing' stamp: 'md 3/3/2006 10:32'!
closureDecompilerClass
	^self error: 'not installed'.! !

!Compiler class methodsFor: 'accessing' stamp: 'md 3/3/2006 10:32'!
closureParserClass
	^self error: 'not installed'.! !

!Compiler class methodsFor: 'accessing' stamp: 'nk 8/30/2004 07:56'!
couldEvaluate: anObject
	"Answer true if anObject can be passed to my various #evaluate: methods."
	^anObject isString or: [ anObject isText or: [ anObject isStream ]]! !

!Compiler class methodsFor: 'accessing' stamp: 'md 3/1/2006 21:12'!
decompilerClass
	^Decompiler! !

!Compiler class methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:39'!
new

	^ super new parserClass: self parserClass! !

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

	^Parser! !


!Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 10:07'!
evaluate: textOrString 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor. 
	Compilation is carried out with respect to nil, i.e., no object, and the 
	invocation is not logged."

	^self evaluate: textOrString for: nil logged: false! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString for: anObject logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor."

	^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! !

!Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 09:50'!
evaluate: textOrString for: anObject notifying: aController logged: logFlag
	"Compile and execute the argument, textOrString with respect to the class 
	of anObject. If a compilation error occurs, notify aController. If both 
	compilation and execution are successful then, if logFlag is true, log 
	(write) the text onto a system changes file so that it can be replayed if 
	necessary."

	^ self new
				evaluate: textOrString
				in: nil
				to: anObject
				notifying: aController
				ifFail: [^nil]
				logged: logFlag.! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor. 
	Compilation is carried out with respect to nil, i.e., no object."

	^self evaluate: textOrString for: nil logged: logFlag! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString notifying: aController logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. Compilation is carried out 
	with respect to nil, i.e., no object."

	^self evaluate: textOrString for: nil notifying: aController logged: logFlag! !

!Compiler class methodsFor: 'evaluating' stamp: 'nk 2/23/2005 16:55'!
format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol
	^self new format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol! !

!Compiler class methodsFor: 'evaluating' stamp: 'nk 2/23/2005 16:53'!
format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean
	^self new format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean! !


!Compiler class methodsFor: 'utilities' stamp: 'al 1/13/2006 00:02'!
recompileAll
	"Recompile all classes, starting with given name."

	Smalltalk forgetDoIts.
	Smalltalk allClassesAndTraits do: [:classOrTrait | classOrTrait compileAll] displayingProgress: 'Recompiling all classes and traits'. 


! !

!Compiler class methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:07'!
recompileAllFrom: firstName 
	"Recompile all classes, starting with given name."

	Smalltalk forgetDoIts.
	Smalltalk allClassesDo: 
		[:class | class name >= firstName
			ifTrue: 
				[Transcript show: class name; cr.
				class compileAll]]

	"Compiler recompileAllFrom: 'AAABodyShop'."
! !
Object subclass: #Complex
	instanceVariableNames: 'real imaginary'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Complex commentStamp: 'mk 10/31/2003 22:19' prior: 0!
I represent a complex number.

real			--	real part of the complex number
imaginary	--	imaginary part of the complex number

Complex number constructors:

	5 i
	6 + 7 i.
	5.6 - 8 i.
	Complex real: 10 imaginary: 5.
	Complex abs: 5 arg: (Float pi / 4)

Arithmetic operation with other complex or non-complex numbers work.

	(5 - 6 i) + (-5 + 8 i).			"Arithmetic between two complex numbers."
	5 * (5 - 6 i).				"Arithmetic between a non-complex and a complex number."
					
It is also possible to perform arithmetic operations between a complex number
and a array of (complex) numbers:

	2 * {1 + 2i.
	     3 + 4i.
	     5 + 6i}

	5 + 5i * {1 + 2i.
	          3.
	          5 + 6i}

It behaves analogously as it is with normal numbers and an array.

NOTE: Although Complex something similiar to the Smalltalk's Number class, it would
not be a good idea to make a Complex to be a subclass of a Number because:
- Number is subclass of Magnitude and Complex is certainly not a magnitude.
  Complex does not behave very well as a Magnitude. Operations such as
	<
	>
	<=
	>=
  do not have sense in case of complex numbers.
- Methods in the following Number methods' categories do not have sense for a Complex numbers
	trucation and round off
	testing
	intervals
	comparing
- However the following Number methods' categories do have sense for a Complex number
	arithmetic (with the exception of operation
		//
		\\
		quo:
		rem:	
	mathematical functions

Thus Complex is somewhat similar to a Number but it is not a subclass of it. Some operations
we would like to inherit (e.g. #abs, #negated, #reciprocal) but some of the Number operation
do not have sens to inherit or to overload. Classes are not always neat mechanism.

!!!!!! We had to COPY the implementation of the
		abs
		negated
		reciprocal
		log:
		isZero
		reciprocal
		...
	methods from the Number class to the Complex class. Awful solution. Now I begin to
	appreciate the Self.

Missing methods
	String | converting | asComplex
	Complex | mathematical functions | arcSin
	Complex | mathematical functions | arcCos
	Complex | mathematical functions | arcTan!


!Complex methodsFor: 'accessing' stamp: 'mk 10/27/2003 17:39'!
imaginary
	^ imaginary! !

!Complex methodsFor: 'accessing' stamp: 'mk 10/27/2003 17:39'!
real
	^ real! !


!Complex methodsFor: 'arithmetic' stamp: 'md 7/21/2004 11:25'!
* anObject
	"Answer the result of multiplying the receiver by aNumber."
	| a b c d newReal newImaginary |
	anObject isComplex
		ifTrue:
			[a _ self real.
			b _ self imaginary.
			c _ anObject real.
			d _ anObject imaginary.
			newReal _ (a * c) - (b * d).
			newImaginary _ (a * d) + (b * c).
			^ Complex real: newReal imaginary: newImaginary]
		ifFalse:
			[^ anObject adaptToComplex: self andSend: #*]! !

!Complex methodsFor: 'arithmetic' stamp: 'mk 1/18/2004 23:31'!
+ anObject
	"Answer the sum of the receiver and aNumber."
	| a b c d newReal newImaginary |
	anObject isComplex
		ifTrue:
			[a _ self real.
			b _ self imaginary.
			c _ anObject real.
			d _ anObject imaginary.
			newReal _ a + c.
			newImaginary _ b + d.
			^ Complex real: newReal imaginary: newImaginary]
		ifFalse:
			[^ anObject adaptToComplex: self andSend: #+]! !

!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:45'!
- anObject
	"Answer the difference between the receiver and aNumber."
	| a b c d newReal newImaginary |
	anObject isComplex
		ifTrue:
			[a _ self real.
			b _ self imaginary.
			c _ anObject real.
			d _ anObject imaginary.
			newReal _ a - c.
			newImaginary _ b - d.
			^ Complex real: newReal imaginary: newImaginary]
		ifFalse:
			[^ anObject adaptToComplex: self andSend: #-]! !

!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:45'!
/ anObject
	"Answer the result of dividing receiver by aNumber"
	| a b c d newReal newImaginary |
	anObject isComplex ifTrue:
		[a _ self real.
		b _ self imaginary.
		c _ anObject real.
		d _ anObject imaginary.
		newReal _ ((a * c) + (b * d)) / ((c * c) + (d * d)).
		newImaginary _ ((b * c) - (a * d)) / ((c * c) + (d * d)).
		^ Complex real: newReal imaginary: newImaginary].
	^ anObject adaptToComplex: self andSend: #/.! !

!Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 20:48'!
abs
	"Answer the distance of the receiver from zero (0 + 0 i)."

	^ ((real * real) + (imaginary * imaginary)) sqrt! !

!Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 22:08'!
arg
	"Answer the argument of the receiver."

	self isZero ifTrue: [self error: 'zero has no argument.'].
	0 < real ifTrue: [^ (imaginary / real) arcTan].
	0 = real ifTrue:
		[0 < imaginary
			ifTrue: [^ Float pi / 2]
			ifFalse: [^ (Float pi / 2) negated]].
	real < 0 ifTrue:
		[0 <= imaginary
			ifTrue: [^ (imaginary / real) arcTan + Float pi]
			ifFalse: [^ (imaginary / real) arcTan - Float pi]]! !

!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:48'!
divideFastAndSecureBy: anObject
	"Answer the result of dividing receiver by aNumber"
	" Both operands are scaled to avoid arithmetic overflow. 
	  This algorithm works for a wide range of values, and it needs only three divisions.
	  Note: #reciprocal uses #/ for devision "
	 
	| r d newReal newImaginary |
	anObject isComplex ifTrue:
		[anObject real abs > anObject imaginary abs
		  ifTrue:
		    [r _ anObject imaginary / anObject real.
			d _ r*anObject imaginary + anObject real.
			newReal _ r*imaginary + real/d.
			newImaginary _ r negated * real + imaginary/d.
		    ]
		  ifFalse:
		    [r _ anObject real / anObject imaginary.
			d := r*anObject real + anObject imaginary.
			newReal _ r*real + imaginary/d.
			newImaginary _ r*imaginary - real/d.
		    ].
		
		^ Complex real: newReal imaginary: newImaginary].
	^ anObject adaptToComplex: self andSend: #/.! !

!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:48'!
divideSecureBy: anObject
	"Answer the result of dividing receiver by aNumber"
	" Both operands are scaled to avoid arithmetic overflow. This algorithm 
	  works for a wide range of values, but it requires six divisions.  
	  #divideFastAndSecureBy:  is also quite good, but it uses only 3 divisions.
	   Note: #reciprocal uses #/ for devision"
	 
	| s ars ais brs bis newReal newImaginary |
	anObject isComplex ifTrue:
		[s := anObject real abs + anObject imaginary abs.
		 ars := self real / s.
		 ais := self imaginary / s.
		 brs := anObject real / s.
		 bis := anObject imaginary / s.
		 s := brs squared + bis squared.
		
		newReal _ ars*brs + (ais*bis) /s.
		newImaginary _ ais*brs - (ars*bis)/s.
		^ Complex real: newReal imaginary: newImaginary].
	^ anObject adaptToComplex: self andSend: #/.! !

!Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 19:33'!
negated
	"Answer a Number that is the negation of the receiver."

	^0 - self! !

!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:47'!
reciprocal
	"Answer 1 divided by the receiver. Create an error notification if the 
	receiver is 0."

	self = 0
		ifTrue: [^ (ZeroDivide dividend: self) signal]
		ifFalse: [^1 / self]
		! !


!Complex methodsFor: 'comparing' stamp: 'mk 1/18/2004 23:37'!
= anObject
	anObject isComplex
		ifTrue: [^ (real = anObject real) & (imaginary = anObject imaginary)]
		ifFalse: [^ anObject adaptToComplex: self andSend: #=]! !

!Complex methodsFor: 'comparing' stamp: 'mk 10/27/2003 20:35'!
hash
	"Hash is reimplemented because = is implemented."
	
	^ real hash bitXor: imaginary hash.! !


!Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 21:51'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with a Collection, return a Collection of
	the results of each element combined with me in that expression."

	^ rcvr collect: [:element | element perform: selector with: self]! !

!Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:32'!
adaptToFloat: rcvr andSend: selector
	"If I am involved in arithmetic with a Float, convert it to a Complex number."
	^ rcvr asComplex perform: selector with: self! !

!Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:32'!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert it to a Complex number."
	^ rcvr asComplex perform: selector with: self! !

!Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:31'!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a Complex number."
	^ rcvr asComplex perform: selector with: self! !


!Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'!
cos
	"Answer receiver's cosine."

	| iself |
	iself _ 1 i * self.
	^ (iself exp + iself negated exp) / 2! !

!Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 21:34'!
cosh
	"Answer receiver's hyperbolic cosine."

	^ (self exp + self negated exp) / 2! !

!Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'!
exp
	"Answer the exponential of the receiver."

	^ real exp * (imaginary cos + (1 i * imaginary sin))! !

!Complex methodsFor: 'mathematical functions' stamp: 'laza 9/26/2005 10:25'!
ln
	"Answer the natural log of the receiver."

	^ self abs ln + (1 i * self arg)! !

!Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 22:05'!
log: aNumber 
	"Answer the log base aNumber of the receiver."

	^self ln / aNumber ln! !

!Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'!
sin
	"Answer receiver's sine."

	| iself |
	iself _ 1 i * self.
	^ (iself exp - iself negated exp) / 2 i! !

!Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 21:33'!
sinh
	"Answer receiver's hyperbolic sine."

	^ (self exp - self negated exp) / 2! !

!Complex methodsFor: 'mathematical functions' stamp: 'md 7/20/2004 12:02'!
squared
	"Answer the receiver multipled by itself."

	^self * self! !

!Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 22:04'!
tan
	"Answer receivers tangent."

	^ self sin / self cos! !


!Complex methodsFor: 'printing' stamp: 'mk 10/27/2003 18:02'!
printOn: aStream
	real printOn: aStream.
	aStream nextPut: Character space.
	0 <= imaginary
		ifTrue: [aStream nextPut: $+]
		ifFalse: [aStream nextPut: $-].
	aStream nextPut: Character space.
	imaginary abs printOn: aStream.
	aStream nextPut: Character space.
	aStream nextPut: $i
! !


!Complex methodsFor: 'testing' stamp: 'mk 10/27/2003 17:33'!
isComplex
	^ true! !

!Complex methodsFor: 'testing' stamp: 'mk 10/27/2003 20:06'!
isZero
	^ self = 0! !


!Complex methodsFor: 'private' stamp: 'mk 10/27/2003 17:26'!
imaginary: aNumber
	imaginary _ aNumber.! !

!Complex methodsFor: 'private' stamp: 'mk 10/27/2003 17:26'!
real: aNumber
	real _ aNumber.! !

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

Complex class
	instanceVariableNames: ''!

!Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 21:03'!
abs: aNumber1 arg: aNumber2
	| real imaginary |
	real _ aNumber1 * aNumber2 cos.
	imaginary _ aNumber1 * aNumber2 sin.
	^ real + imaginary i! !

!Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 17:28'!
new
	^ self real: 0 imaginary: 0! !

!Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 17:27'!
real: aNumber1 imaginary: aNumber2
	| newComplex |
	newComplex _ super new.
	newComplex
		real: aNumber1;
		imaginary: aNumber2.
	^ newComplex! !
SimpleBorder subclass: #ComplexBorder
	instanceVariableNames: 'style colors lineStyles'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Borders'!
!ComplexBorder commentStamp: 'kfr 10/27/2003 10:18' prior: 0!
see BorderedMorph.

poly _ polygon250 

baseColor _ Color blue twiceLighter.
border _ (ComplexBorder framed: 10) baseColor: poly color.
border frameRectangle: ((100@100 extent: 200@200) insetBy: -5) on: Display getCanvas.
baseColor _ Color red twiceLighter.
border _ (ComplexBorder framed: 10) baseColor: baseColor.
border drawPolygon: {100@100. 300@100. 300@300. 100@300} on: Display getCanvas.

border drawPolyPatchFrom: 100@200 via: 100@100 via: 200@100 to: 200@200 on: Display getCanvas.
border drawPolyPatchFrom: 100@100 via: 200@100 via: 200@200 to: 100@200 on: Display getCanvas.
border drawPolyPatchFrom: 200@100 via: 200@200 via: 100@200 to: 100@100 on: Display getCanvas.
border drawPolyPatchFrom: 200@200 via: 100@200 via: 100@100 to: 200@100 on: Display getCanvas.

border _ (ComplexBorder raised: 10) baseColor: poly color.
border drawPolygon: poly getVertices on: Display getCanvas

360 / 16.0 22.5
points _ (0 to: 15) collect:[:i| (Point r: 100 degrees: i*22.5) + 200].
Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor.
border drawPolygon: points on: Display getCanvas.

-1 to: points size + 1 do:[:i|
	border drawPolyPatchFrom: (points atWrap: i) via: (points atWrap: i+1) via: (points atWrap: i+2) to: (points atWrap: i+3) on: Display getCanvas.
].

Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor.
0 to: 36 do:[:i|
	border drawLineFrom: (Point r: 100 degrees: i*10) + 200 to: (Point r: 100 degrees: i+1*10) + 200
		on: Display getCanvas.
].
drawPolygon:
Point r: 1.0 degrees: 10
MessageTally spyOn:[
Display deferUpdates: true.
t1 _ [1 to: 1000 do:[:i|
	border drawLineFrom: (100@100) to: (300@100) on: Display getCanvas.
	border drawLineFrom: (300@100) to: (300@300) on: Display getCanvas.
	border drawLineFrom: (300@300) to: (100@300) on: Display getCanvas.
	border drawLineFrom: (100@300) to: (100@100) on: Display getCanvas]] timeToRun.
Display deferUpdates: false.
].

MessageTally spyOn:[
Display deferUpdates: true.
t2 _ [1 to: 1000 do:[:i|
	border drawLine2From: (100@100) to: (300@100) on: Display getCanvas.
	border drawLine2From: (300@100) to: (300@300) on: Display getCanvas.
	border drawLine2From: (300@300) to: (100@300) on: Display getCanvas.
	border drawLine2From: (100@300) to: (100@100) on: Display getCanvas]] timeToRun.
Display deferUpdates: false.
].

!


!ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:13'!
colors
	^colors ifNil:[colors _ self computeColors].! !

!ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'!
style
	^style! !

!ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'!
style: newStyle
	style == newStyle ifTrue:[^self].
	style _ newStyle.
	self releaseCachedState.! !

!ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:14'!
widthForRounding
	^0! !


!ComplexBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'!
trackColorFrom: aMorph
	baseColor ifNil:[self color: aMorph raisedColor].! !


!ComplexBorder methodsFor: 'drawing' stamp: 'aoy 2/17/2003 01:08'!
drawLineFrom: startPoint to: stopPoint on: aCanvas 
	"Here we're using the balloon engine since this is much faster than BitBlt w/ brushes."

	| delta length dir cos sin tfm w h w1 w2 h1 h2 fill |
	width isPoint 
		ifTrue: 
			[w := width x.
			h := width y]
		ifFalse: [w := h := width].
	w1 := w // 2.
	w2 := w - w1.
	h1 := h // 2.
	h2 := h - h1.
	"Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint"
	delta := stopPoint - startPoint.
	length := delta r.
	dir := length > 1.0e-10 ifTrue: [delta / length] ifFalse: [ 1 @ 0].
	cos := dir dotProduct: 1 @ 0.
	sin := dir crossProduct: 1 @ 0.
	tfm := (MatrixTransform2x3 new)
				a11: cos;
				a12: sin;
				a21: sin negated;
				a22: cos.
	"Install the start point offset"
	tfm offset: startPoint.
	"Now get the fill style appropriate for the given direction"
	fill := self fillStyleForDirection: dir.
	"And draw..."
	aCanvas asBalloonCanvas transformBy: tfm
		during: 
			[:cc | 
			cc drawPolygon: { 
						(0 - w1) @ (0 - h1).	"top left"
						(length + w2) @ (0 - h1).	"top right"
						(length + w2) @ h2.	"bottom right"
						(0 - w1) @ h2	"bottom left"}
				fillStyle: fill]! !

!ComplexBorder methodsFor: 'drawing' stamp: 'ar 11/26/2001 15:10'!
drawPolyPatchFrom: startPoint to: stopPoint on: aCanvas usingEnds: endsArray

	| cos sin tfm fill dir fsOrigin fsDirection points x y |
	dir _ (stopPoint - startPoint) normalized.
	"Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint"
	cos _ dir dotProduct: (1@0).
	sin _ dir crossProduct: (1@0).
	"Now get the fill style appropriate for the given direction"
	fill _ self fillStyleForDirection: dir.
false ifTrue:[
	"Transform the fill appropriately"
	fill _ fill clone.
	"Note: Code below is inlined from tfm transformPoint:/transformDirection:"
	x _ fill origin x. y _ fill origin y.
	fsOrigin _ ((x * cos) + (y * sin) + startPoint x) @
					((y * cos) - (x * sin) + startPoint y).
	x _ fill direction x. y _ fill direction y.
	fsDirection _ ((x * cos) + (y * sin)) @ ((y * cos) - (x * sin)).
	fill origin: fsOrigin; 
		direction: fsDirection rounded; "NOTE: This is a bug in the balloon engine!!!!!!"
		normal: nil.
	aCanvas asBalloonCanvas drawPolygon: endsArray fillStyle: fill.
] ifFalse:[
	"Transform the points rather than the fills"
	tfm _ (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos.
	"Install the start point offset"
	tfm offset: startPoint.
	points _ endsArray collect:[:pt| tfm invertPoint: pt].
	aCanvas asBalloonCanvas transformBy: tfm during:[:cc|
		cc drawPolygon: points fillStyle: fill.
	].
].! !

!ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:51'!
framePolygon2: vertices on: aCanvas
	| dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 
	 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends |
	balloon _ aCanvas asBalloonCanvas.
	balloon == aCanvas ifFalse:[balloon deferred: true].
	ends _ Array new: 4.
	w _ width * 0.5.
	pointA _ nil.
	1 to: vertices size do:[:i|
		p1 _ vertices atWrap: i.
		p2 _ vertices atWrap: i+1.
		p3 _ vertices atWrap: i+2.
		p4 _ vertices atWrap: i+3.

		dir1 _ p2 - p1.
		dir2 _ p3 - p2.
		dir3 _ p4 - p3.

		i = 1 ifTrue:[
			"Compute the merge points of p1->p2 with p2->p3"
			cross1 _ dir2 crossProduct: dir1.
			nrm1 _ dir1 normalized. nrm1 _ (nrm1 y * w) @ (0 - nrm1 x * w).
			nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w).
			cross1 < 0 ifTrue:[nrm1 _ nrm1 negated. nrm2 _ nrm2 negated].
			point1 _ (p1 x + nrm1 x) @ (p1 y + nrm1 y).
			point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y).
			pointA _ self intersectFrom: point1 with: dir1 to: point2 with: dir2.
			point1 _ (p1 x - nrm1 x) @ (p1 y - nrm1 y).
			point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y).
			pointB _ self intersectFrom: point1 with: dir1 to: point2 with: dir2.
			pointB ifNotNil:[
				(pointB x - p2 x) abs + (pointB y - p2 y) abs > (4*w) ifTrue:[pointA _ pointB _ nil].
			].
		].

		"Compute the merge points of p2->p3 with p3->p4"
		cross2 _ dir3 crossProduct: dir2.
		nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w).
		nrm3 _ dir3 normalized. nrm3 _ (nrm3 y * w) @ (0 - nrm3 x * w).
		cross2 < 0 ifTrue:[nrm2 _ nrm2 negated. nrm3 _ nrm3 negated].
		point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y).
		point3 _ (p3 x + nrm3 x) @ (p3 y + nrm3 y).
		pointC _ self intersectFrom: point2 with: dir2 to: point3 with: dir3.
		point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y).
		point3 _ (p3 x - nrm3 x) @ (p3 y - nrm3 y).
		pointD _ self intersectFrom: point2 with: dir2 to: point3 with: dir3.
		pointD ifNotNil:[
			(pointD x - p3 x) abs + (pointD y - p3 y) abs > (4*w) ifTrue:[pointC _ pointD _ nil].
		].
		cross1 * cross2 < 0.0 ifTrue:[
			point1 _ pointA.
			pointA _ pointB.
			pointB _ point1.
			cross1 _ 0.0 - cross1].
		ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointD; at: 4 put: pointC.
		pointA ifNil:["degenerate and slow"
			nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w).
			cross1 < 0 ifTrue:[nrm2 _ nrm2 negated].
			point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y).
			ends at: 1 put: point2].
		pointB ifNil:["degenerate and slow"
			nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w).
			cross1 < 0 ifTrue:[nrm2 _ nrm2 negated].
			point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y).
			ends at: 2 put: point2].
		pointC ifNil:["degenerate and slow"
			nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w).
			cross2 < 0 ifTrue:[nrm2 _ nrm2 negated].
			point2 _ (p3 x + nrm2 x) @ (p3 y + nrm2 y).
			ends at: 4 put: point2].
		pointD ifNil:["degenerate and slow"
			nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w).
			cross2 < 0 ifTrue:[nrm2 _ nrm2 negated].
			point2 _ (p3 x - nrm2 x) @ (p3 y - nrm2 y).
			ends at: 3 put: point2].

		self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends.
		pointA _ pointC.
		pointB _ pointD.
		cross1 _ cross2.
	].
	balloon == aCanvas ifFalse:[balloon flush].! !

!ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:50'!
framePolygon: vertices on: aCanvas
	| dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 
	 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends pointE pointF |
	balloon _ aCanvas asBalloonCanvas.
	balloon == aCanvas ifFalse:[balloon deferred: true].
	ends _ Array new: 6.
	w _ width * 0.5.
	pointA _ nil.
	1 to: vertices size do:[:i|
		p1 _ vertices atWrap: i.
		p2 _ vertices atWrap: i+1.
		p3 _ vertices atWrap: i+2.
		p4 _ vertices atWrap: i+3.

		dir1 _ p2 - p1.
		dir2 _ p3 - p2.
		dir3 _ p4 - p3.

		(i = 1 | true) ifTrue:[
			"Compute the merge points of p1->p2 with p2->p3"
			cross1 _ dir2 crossProduct: dir1.
			nrm1 _ dir1 normalized. nrm1 _ (nrm1 y * w) @ (0 - nrm1 x * w).
			nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w).
			cross1 < 0 ifTrue:[nrm1 _ nrm1 negated. nrm2 _ nrm2 negated].
			point1 _ (p1 x + nrm1 x) @ (p1 y + nrm1 y).
			point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y).
			pointA _ self intersectFrom: point1 with: dir1 to: point2 with: dir2.
			point1 _ (p1 x - nrm1 x) @ (p1 y - nrm1 y).
			point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y).
			pointB _ point1 + dir1 + point2 * 0.5.
			pointB _ p2 + ((pointB - p2) normalized * w).
			pointC _ point2.
		].

		"Compute the merge points of p2->p3 with p3->p4"
		cross2 _ dir3 crossProduct: dir2.
		nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w).
		nrm3 _ dir3 normalized. nrm3 _ (nrm3 y * w) @ (0 - nrm3 x * w).
		cross2 < 0 ifTrue:[nrm2 _ nrm2 negated. nrm3 _ nrm3 negated].
		point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y).
		point3 _ (p3 x + nrm3 x) @ (p3 y + nrm3 y).
		pointD _ self intersectFrom: point2 with: dir2 to: point3 with: dir3.
		point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y).
		point3 _ (p3 x - nrm3 x) @ (p3 y - nrm3 y).
		pointF _ point2 + dir2.
		pointE _ pointF + point3 * 0.5.
		pointE _ p3 + ((pointE - p3) normalized * w).
		cross1 * cross2 < 0.0 ifTrue:[
			ends
				at: 1 put: pointA;
				at: 2 put: pointB;
				at: 3 put: pointC;
				at: 4 put: pointD;
				at: 5 put: pointE;
				at: 6 put: pointF.
		] ifFalse:[
			ends 
				at: 1 put: pointA; 
				at: 2 put: pointB;
				at: 3 put: pointC; 
				at: 4 put: pointF; 
				at: 5 put: pointE;
				at: 6 put: pointD.
		].
		self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends.
		pointA _ pointD.
		pointB _ pointE.
		pointC _ pointF.
		cross1 _ cross2.
	].
	balloon == aCanvas ifFalse:[balloon flush].! !

!ComplexBorder methodsFor: 'drawing' stamp: 'ar 8/26/2001 19:01'!
frameRectangle: aRectangle on: aCanvas
	"Note: This uses BitBlt since it's roughly a factor of two faster for rectangles"
	| w h r |
	self colors ifNil:[^super frameRectangle: aRectangle on: aCanvas].
	w _ self width.
	w isPoint ifTrue:[h _ w y. w _ w x] ifFalse:[h _ w].
	1 to: h do:[:i| "top/bottom"
		r _ (aRectangle topLeft + (i-1)) extent: (aRectangle width - (i-1*2))@1. "top"
		aCanvas fillRectangle: r color: (colors at: i).
		r _ (aRectangle bottomLeft + (i @ (0-i))) extent: (aRectangle width - (i-1*2) - 1)@1. "bottom"
		aCanvas fillRectangle: r color: (colors at: colors size - i + 1).
	].
	1 to: w do:[:i| "left/right"
		r _ (aRectangle topLeft + (i-1)) extent: 1@(aRectangle height - (i-1*2)). "left"
		aCanvas fillRectangle: r color: (colors at: i).
		r _ aRectangle topRight + ((0-i)@i) extent: 1@(aRectangle height - (i-1*2) - 1). "right"
		aCanvas fillRectangle: r color: (colors at: colors size - i + 1).
	].! !


!ComplexBorder methodsFor: 'initialize' stamp: 'ar 11/26/2001 14:43'!
releaseCachedState
	colors _ nil.
	lineStyles _ nil.! !


!ComplexBorder methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'!
isComplex
	^true! !


!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:02'!
colorsForDirection: direction 
	"Return an array of colors describing the receiver in the given direction"

	| colorArray dT cc |
	cc := self colors.
	direction x * direction y <= 0 
		ifTrue: 
			["within up->right or down->left transition; no color blend needed"

			colorArray := (direction x > 0 or: [direction y < 0]) 
						ifTrue: 
							["up->right"
							cc copyFrom: 1 to: width]
						ifFalse: 
							["down->left"
							"colors are stored in reverse direction when following a line"
							(cc copyFrom: width + 1 to: cc size) reversed]]
		ifFalse: 
			["right->down or left->up transition; need color blend"

			colorArray := Array new: width.
			dT := direction x asFloat / (direction x + direction y).
			(direction x > 0 or: [direction y >= 0]) 
				ifTrue: 
					["top-right"

					1 to: width
						do: 
							[:i | 
							colorArray at: i put: ((cc at: i) mixed: dT with: (cc at: cc size - i + 1))]]
				ifFalse: 
					["bottom-left"

					1 to: width
						do: 
							[:i | 
							colorArray at: i put: ((cc at: cc size - i + 1) mixed: dT with: (cc at: i))]]].
	^colorArray! !

!ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'!
computeAltFramedColors
	| base light dark w hw colorArray param |
	base _ self color asColor.
	light _ Color white.
	dark _ Color black.
	w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width].
	w _ w asInteger.
	w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}].
	colorArray _ Array new: w.
	hw _ w // 2.
	"brighten"
	0 to: hw-1 do:[:i|
		param _ 0.5 + (i asFloat / hw * 0.5).
		colorArray at: i+1 put: (base mixed: param with: dark). "brighten"
		colorArray at: w-i put: (base mixed: param with: light). "darken"
	].
	w odd ifTrue:[colorArray at: hw+1 put: base].
	^colorArray, colorArray! !

!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:03'!
computeAltInsetColors
	| base light dark w colorArray param hw |
	base := self color asColor.
	light := Color white.
	dark := Color black.
	w := self width isPoint 
				ifTrue: [self width x max: self width y]
				ifFalse: [self width].
	w := w asInteger.
	colorArray := Array new: w * 2.
	hw := 0.5 / w.
	0 to: w - 1
		do: 
			[:i | 
			param := false 
						ifTrue: 
							["whats this ???!! false ifTrue:[]"

							0.5 + (hw * i)]
						ifFalse: [0.5 + (hw * (w - i))].
			colorArray at: i + 1 put: (base mixed: param with: dark).	"darken"
			colorArray at: colorArray size - i put: (base mixed: param with: light)	"brighten"].
	^colorArray! !

!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:05'!
computeAltRaisedColors
	| base light dark w colorArray param hw |
	base := self color asColor.
	light := Color white.
	dark := Color black.
	w := self width isPoint 
				ifTrue: [self width x max: self width y]
				ifFalse: [self width].
	w := w asInteger.
	colorArray := Array new: w * 2.
	hw := 0.5 / w.
	0 to: w - 1
		do: 
			[:i | "again !! false ifTrue:[] ?!!"
			param := false ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))].
			colorArray at: i + 1 put: (base mixed: param with: light).	"brighten"
			colorArray at: colorArray size - i put: (base mixed: param with: dark)	"darken"].
	^colorArray! !

!ComplexBorder methodsFor: 'private' stamp: 'ar 11/26/2001 15:00'!
computeColors
	width = 0 ifTrue:[^colors _ #()].
	style == #complexFramed ifTrue:[^self computeFramedColors].
	style == #complexAltFramed ifTrue:[^self computeAltFramedColors].
	style == #complexRaised ifTrue:[^self computeRaisedColors].
	style == #complexAltRaised ifTrue:[^self computeAltRaisedColors].
	style == #complexInset ifTrue:[^self computeInsetColors].
	style == #complexAltInset ifTrue:[^self computeAltInsetColors].
	self error:'Unknown border style: ', style printString.! !

!ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:35'!
computeFramedColors
	| base light dark w hw colorArray param |
	base _ self color asColor.
	light _ Color white.
	dark _ Color black.
	w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width].
	w _ w asInteger.
	w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}].
	colorArray _ Array new: w.
	hw _ w // 2.
	"brighten"
	0 to: hw-1 do:[:i|
		param _ 0.5 + (i asFloat / hw * 0.5).
		colorArray at: i+1 put: (base mixed: param with: light). "brighten"
		colorArray at: w-i put: (base mixed: param with: dark). "darken"
	].
	w odd ifTrue:[colorArray at: hw+1 put: base].
	^colorArray, colorArray! !

!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:06'!
computeInsetColors
	| base light dark w colorArray param hw |
	base := self color asColor.
	light := Color white.
	dark := Color black.
	w := self width isPoint 
				ifTrue: [self width x max: self width y]
				ifFalse: [self width].
	w := w asInteger.
	colorArray := Array new: w * 2.
	hw := 0.5 / w.
	0 to: w - 1
		do: 
			[:i | 
			param := true 
				ifTrue: [ 0.5 + (hw * i)]
				ifFalse: [0.5 + (hw * (w - i))].
			colorArray at: i + 1 put: (base mixed: param with: dark).	"darken"
			colorArray at: colorArray size - i put: (base mixed: param with: light)	"brighten"].
	^colorArray! !

!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:07'!
computeRaisedColors
	| base light dark w colorArray param hw |
	base := self color asColor.
	light := Color white.
	dark := Color black.
	w := self width isPoint 
				ifTrue: [self width x max: self width y]
				ifFalse: [self width].
	w := w asInteger.
	colorArray := Array new: w * 2.
	hw := 0.5 / w.
	0 to: w - 1
		do: 
			[:i | 
			param := true ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw  * (w - i))].
			colorArray at: i + 1 put: (base mixed: param with: light).	"brighten"
			colorArray at: colorArray size - i put: (base mixed: param with: dark)	"darken"].
	^colorArray! !

!ComplexBorder methodsFor: 'private' stamp: 'ar 9/4/2001 19:51'!
fillStyleForDirection: direction
	"Fill the given form describing the receiver's look at a particular direction"
	| index fill dir |
	index _ direction degrees truncated // 10 + 1.
	lineStyles ifNotNil:[
		fill _ lineStyles at: index.
		fill ifNotNil:[^fill].
	].
	dir _ Point r: 1.0 degrees: index - 1 * 10 + 5.
	fill _ GradientFillStyle colors: (self colorsForDirection: dir).
	fill direction: 0 @ width asPoint y; radial: false.
	fill origin: ((width asPoint x // 2) @ (width asPoint y // 2)) negated.
	fill pixelRamp: (fill computePixelRampOfSize: 16).
	fill isTranslucent. "precompute"
	lineStyles ifNil:[lineStyles _ Array new: 37].
	lineStyles at: index put: fill.
	^fill! !

!ComplexBorder methodsFor: 'private' stamp: 'ar 8/26/2001 23:39'!
intersectFrom: startPt with: startDir to: endPt with: endDir
	"Compute the intersection of two lines. Return nil if either
		* the intersection does not exist, or
		* the intersection is 'before' startPt, or
		* the intersection is 'after' endPt
	"
	| det deltaPt alpha beta |
	det _ (startDir x * endDir y) - (startDir y * endDir x).
	det = 0.0 ifTrue:[^nil]. "There's no solution for it"
	deltaPt _ endPt - startPt.
	alpha _ (deltaPt x * endDir y) - (deltaPt y * endDir x).
	beta _ (deltaPt x * startDir y) - (deltaPt y * startDir x).
	alpha _ alpha / det.
	beta _ beta / det.
	alpha < 0 ifTrue:[^nil].
	beta > 1.0 ifTrue:[^nil].
	"And compute intersection"
	^(startPt x + (alpha * startDir x)) @ (startPt y + (alpha * startDir y))! !

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

ComplexBorder class
	instanceVariableNames: ''!

!ComplexBorder class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:22'!
style: aSymbol
	^self new style: aSymbol! !
Object subclass: #ComplexProgressIndicator
	instanceVariableNames: 'formerWorld targetMorph estimate prevData formerProcess translucentMorph userSuppliedMorph specificHistory historyCategory cumulativeStageTime formerProject newRatio stageCompleted start'
	classVariableNames: 'History'
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ComplexProgressIndicator commentStamp: '<historical>' prior: 0!
Note: in an effort to remove the progress indicator if a walkback occurs, #withProgressDo: must be sent from the current uiProcess. Hopefully we can relax this restriction in the future. !


!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'nk 8/18/2004 16:43'!
addProgressDecoration: extraParam 
	| f m |
	targetMorph ifNil: [^self].
	(extraParam isForm) 
		ifTrue: 
			[targetMorph 
				submorphsDo: [:mm | (mm isSketchMorph) ifTrue: [mm delete]].
			f := Form extent: extraParam extent depth: extraParam depth.
			extraParam displayOn: f.
			m := SketchMorph withForm: f.
			m align: m fullBounds leftCenter
				with: targetMorph fullBounds leftCenter + (2 @ 0).
			targetMorph addMorph: m.
			^self].
	(extraParam isString) 
		ifTrue: 
			[targetMorph 
				submorphsDo: [:mm | (mm isKindOf: StringMorph) ifTrue: [mm delete]].
			m := StringMorph contents: extraParam translated.
			m align: m fullBounds bottomCenter + (0 @ 8)
				with: targetMorph bounds bottomCenter.
			targetMorph addMorph: m.
			^self]! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
backgroundWorldDisplay

	| f |

	self flag: #bob.		"really need a better way to do this"

			"World displayWorldSafely."

	"ugliness to try to track down a possible error"


	[World displayWorld] ifError: [ :a :b |
		stageCompleted _ 999.
		f _ FileDirectory default fileNamed: 'bob.errors'.
		f nextPutAll: a printString,'  ',b printString; cr; cr.
		f nextPutAll: 'worlds equal ',(formerWorld == World) printString; cr; cr.
		f nextPutAll: thisContext longStack; cr; cr.
		f nextPutAll: formerProcess suspendedContext longStack; cr; cr.
		f close. Beeper beep.
	].
! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'ar 7/8/2001 17:05'!
forkProgressWatcher

	| killTarget |
	[
		[stageCompleted < 999 and: 
				[formerProject == Project current and: 
				[formerWorld == World and: 
				[translucentMorph world notNil and:
				[formerProcess suspendedContext notNil and: 
				[Project uiProcess == formerProcess]]]]]] whileTrue: [

			translucentMorph setProperty: #revealTimes toValue: 
					{(Time millisecondClockValue - start max: 1). (estimate * newRatio max: 1)}.
			translucentMorph changed.
			translucentMorph owner addMorphInLayer: translucentMorph.
			(Time millisecondClockValue - WorldState lastCycleTime) abs > 500 ifTrue: [
				self backgroundWorldDisplay
			].
			(Delay forMilliseconds: 100) wait.
		].
		translucentMorph removeProperty: #revealTimes.
		self loadingHistoryAt: 'total' add: (Time millisecondClockValue - start max: 1).
		killTarget _ targetMorph ifNotNil: [
			targetMorph valueOfProperty: #deleteOnProgressCompletion
		].
		formerWorld == World ifTrue: [
			translucentMorph delete.
			killTarget ifNotNil: [killTarget delete].
		] ifFalse: [
			translucentMorph privateDeleteWithAbsolutelyNoSideEffects.
			killTarget ifNotNil: [killTarget privateDeleteWithAbsolutelyNoSideEffects].
		].
	] forkAt: Processor lowIOPriority.! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 10:00'!
historyCategory: aKey

	History ifNil: [History _ Dictionary new].
	specificHistory _ History
		at: aKey
		ifAbsentPut: [Dictionary new].
	^specificHistory
! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 09:55'!
loadingHistoryAt: aKey add: aNumber

	(self loadingHistoryDataForKey: aKey) add: aNumber.

! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 10:02'!
loadingHistoryDataForKey: anObject

	| answer |
	answer _ specificHistory 
		at: anObject
		ifAbsentPut: [OrderedCollection new].
	answer size > 50 ifTrue: [
		answer _ answer copyFrom: 25 to: answer size.
		specificHistory at: anObject put: answer.
	].
	^answer

! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 6/29/2000 11:31'!
targetMorph: aMorph

	targetMorph _ aMorph! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'mir 3/9/2004 16:27'!
withProgressDo: aBlock

	| safetyFactor totals trialRect delta stageCompletedString targetOwner |

	Smalltalk isMorphic ifFalse: [^aBlock value].
	formerProject _ Project current.
	formerWorld _ World.
	formerProcess _ Processor activeProcess.
	targetMorph
		ifNil: [targetMorph _ ProgressTargetRequestNotification signal].
	targetMorph ifNil: [
		trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80.
		delta _ trialRect amountToTranslateWithin: formerWorld bounds.
		trialRect _ trialRect translateBy: delta.
		translucentMorph _ TranslucentProgessMorph new
			opaqueBackgroundColor: Color white;
			bounds: trialRect;
			openInWorld: formerWorld.
	] ifNotNil: [
		targetOwner := targetMorph owner.
		translucentMorph _ TranslucentProgessMorph new
			setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1;
			bounds: targetMorph boundsInWorld;
			openInWorld: targetMorph world.
	].
	stageCompleted _ 0.
	safetyFactor _ 1.1.	"better to guess high than low"
	translucentMorph setProperty: #progressStageNumber toValue: 1.
	translucentMorph hide.
	targetOwner ifNotNil: [targetOwner hide].
	totals _ self loadingHistoryDataForKey: 'total'.
	newRatio _ 1.0.
	estimate _ totals size < 2 ifTrue: [
		15000		"be a pessimist"
	] ifFalse: [
		(totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor.
	].
	start _ Time millisecondClockValue.
	self forkProgressWatcher.

	[
		aBlock 
			on: ProgressInitiationException
			do: [ :ex | 
				ex sendNotificationsTo: [ :min :max :curr |
					"ignore this as it is inaccurate"
				].
			].
	] on: ProgressNotification do: [ :note |
		translucentMorph show.
		targetOwner ifNotNil: [targetOwner show].
		note extraParam ifNotNil:[self addProgressDecoration: note extraParam].
		stageCompletedString _ (note messageText findTokens: ' ') first.
		stageCompleted _ (stageCompletedString copyUpTo: $:) asNumber.
		cumulativeStageTime _ Time millisecondClockValue - start max: 1.
		prevData _ self loadingHistoryDataForKey: stageCompletedString.
		prevData isEmpty ifFalse: [
			newRatio _ (cumulativeStageTime / (prevData average max: 1)) asFloat.
		].
		self 
			loadingHistoryAt: stageCompletedString 
			add: cumulativeStageTime.
		translucentMorph 
			setProperty: #progressStageNumber 
			toValue: stageCompleted + 1.
		note resume.
	].

	stageCompleted _ 999.	"we may or may not get here"

! !

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

ComplexProgressIndicator class
	instanceVariableNames: ''!

!ComplexProgressIndicator class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
historyReport
"
ComplexProgressIndicator historyReport
"
	| answer data |
	History ifNil: [^Beeper beep].
	answer _ String streamContents: [ :strm |
		(History keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :k |
			strm nextPutAll: k printString; cr.
			data _ History at: k.
			(data keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :dataKey |
				strm tab; nextPutAll: dataKey printString,'  ',
					(data at: dataKey) asArray printString; cr.
			].
			strm cr.
		].
	].
	StringHolder new
		contents: answer contents;
		openLabel: 'Progress History'! !
TestCase subclass: #ComplexTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!

!ComplexTest methodsFor: 'testing' stamp: 'nice 2/8/2006 22:09'!
testEquality
	"self run: #testEquality"
	"self debug: #testEquality"
	
	self assert: 0i = 0.
	self assert: (2 - 5i) = ((1 -4 i) + (1 - 1i)).
	self assert: 0i isZero.
	self deny: (1 + 3 i) = 1.
	self deny: (1 + 3 i) = (1 + 2i).

"Some more stuff"
	self deny: (1 i) = nil.
	self deny: nil = (1 i).

	self deny: (1 i) = #(1 2 3).
	self deny: #(1 2 3) = (1 i).

	self deny: (1 i) = 0.
	self deny: 0 = (1 i).

	self assert:  (1 + 0 i) = 1.
	self assert:  1 = (1+ 0 i).

	self assert:  (1 + 0 i) = 1.0.
	self assert:  1.0 = (1+ 0 i).

	self assert:  (1/2 + 0 i) = (1/2).
	self assert:  (1/2) = (1/2+ 0 i).! !


!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:00'!
testAbs
	"self run: #testAbs"
	"self debug: #testAbs"
	
	| c |
	c := (6 - 6 i).
	self assert: c abs  = 72 sqrt.
	! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 13:59'!
testAdding
	"self run: #testAdding"
	
	| c |
	c := (5 - 6 i) + (-5 + 8 i).     "Complex with Complex"
	self assert: (c =  (0 + 2 i)).! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:02'!
testArg
	"self run: #testArg"
	"self debug: #testArg"
	
	| c |
	c := (0 + 5 i) .
	self assert: c arg  = (Float pi/ 2).
	! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:13'!
testComplexCollection
	"self run: #testComplexCollection"
	"self debug: #testComplexCollection"
	
	| array array2 |
	array := Array with: 1 + 2i with:  3 + 4i with: 5 + 6i.
	array2 := 2 * array.
	array with:  array2 do: [:one :two | self assert: (2 * one) = two ] ! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:16'!
testConversion
	"self run: #testConversion"
	"self debug: #testConversion"
	
	self assert: ((1 + 2i) + 1) =  (2 + 2 i).
	self assert: (1 + (1 + 2i)) =  (2 + 2 i).
	self assert: ((1 + 2i) + 1.0) =  (2.0 + 2 i).
	self assert: (1.0 + (1 + 2i)) =  (2.0 + 2 i).
	self assert: ((1 + 2i) + (2/3)) = ((5/3) + 2 i ).
	self assert: ((2/3) + (1 + 2i)) = ((5/3) + 2 i )! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 13:59'!
testCreation
	"self run: #testCreation"
	
	| c |
	c := 5 i.
	self assert: (c real = 0).
	self assert: (c imaginary = 5).
	
	c := 6 + 7 i.
	self assert: (c real = 6).
	self assert: ( c imaginary = 7).
	
	c := 5.6 - 8 i.
	self assert: (c real = 5.6).
	self assert: (c imaginary = -8).
	
	c := Complex real: 10 imaginary: 5.
	self assert: (c real = 10).
	self assert: (c imaginary = 5).
	
	c := Complex abs: 5 arg: (Float pi/2).
	self assert: (c real rounded = 0).
	self assert: (c imaginary = 5).
	! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:29'!
testDivision1
	"self run: #testDivision1"
	"self debug: #testDivision1"
	
	| c1 c2 quotient |
	c1 := 2.0e252 + 3.0e70 i.
	c2 := c1.
	quotient := c1 / c2.
 	self deny: (quotient - 1) isZero.
	
	"This test fails due to the wonders of floating point arithmetic. 
	 Please have a look at Complex>>divideSecureBy: and #divideFastAndSecureBy:
	how this can be avoided."
	
! !

!ComplexTest methodsFor: 'tests' stamp: 'laza 9/26/2005 10:24'!
testLn
	self assert: (Float e + 0 i) ln = Float e ln "See Bug 1815 on Mantis"! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:03'!
testNegated
	"self run: #testNegated"
	"self debug: #testNegated"
	
	| c |
	c := (2 + 5 i) .
	self assert: c negated  = (-2 - 5i).
	! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:05'!
testReciprocal
	"self run: #testReciprocal"
	"self debug: #testReciprocal"
	
	| c |
	c := (2 + 5 i).
	self assert: c reciprocal  = ((2/29) - (5/29)i).
	! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:07'!
testReciprocalError
	"self run: #testReciprocalError"
	"self debug: #testReciprocalError"
	
	| c |
	c := (0 i).
	self should: [c reciprocal] raise: ZeroDivide
	! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:29'!
testSecureDivision1
	"self run: #testSecureDivision1"
	"self debug: #testSecureDivision1"
	
	| c1 c2 quotient |
	c1 := 2.0e252 + 3.0e70 i.
	c2 := c1.
	quotient := c1 divideSecureBy: c2.
	self assert: (quotient - 1) isZero.
	! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:29'!
testSecureDivision2
	"self run: #testSecureDivision2"
	"self debug: #testSecureDivision2"
	
	| c1 c2 quotient |
 	c1 := 2.0e252 + 3.0e70 i.
 	c2 := c1.
 	quotient := c1 divideFastAndSecureBy: c2.
	self assert: (quotient - 1) isZero.
	! !

!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 13:24'!
testSquared
	"self run: #testSquared"
	"self debug: #testSquared"
	
	| c c2 |
	c := (6 - 6 i).
	c2 := (c squared).
	self assert: c2 imaginary = -72.
	self assert: c2 real = 0.! !


!ComplexTest methodsFor: 'testing - bugs' stamp: 'md 2/18/2006 16:53'!
testBug1

	self assert: (0.5 * (2+0i) ln) exp = (0.5 * 2 ln) exp.! !
Player subclass: #Component
	instanceVariableNames: 'model pinSpecs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!Component methodsFor: 'drag and drop' stamp: 'ar 10/5/2000 20:03'!
justDroppedInto: aMorph event: anEvent
	| theModel |
	theModel _ aMorph model.
	((aMorph isKindOf: ComponentLayout) 
		and: [theModel isKindOf: Component]) ifFalse:
		["Disconnect prior to removal by move"
		(theModel isKindOf: Component) ifTrue: [self unwire.  model _ nil].
		^ super justDroppedInto: aMorph event: anEvent].
	theModel == model ifTrue: [^ self  "Presumably just a move"].
	self initComponentIn: aMorph.
	super justDroppedInto: aMorph event: anEvent.! !


!Component methodsFor: 'initialize' stamp: 'di 5/3/1998 20:23'!
initComponentIn: aLayout
	model _ aLayout model.
	self nameMeIn: aLayout world.
	self color: Color lightCyan.
	self showPins.
	model addDependent: self! !


!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:48'!
chooseNameLike: someName 
	| stem otherNames i partName |
	stem _ someName.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString , stem allButFirst.
	otherNames _ self class allInstVarNames asSet.
	"otherNames addAll: self world allKnownNames."
	i _ 1.
	[otherNames includes: (partName _ stem , i printString)]
		whileTrue: [i _ i + 1].
	partName _ FillInTheBlank request: 'Please give this part a name'
						initialAnswer: partName.
	partName isEmpty ifTrue: [^ nil].
	(otherNames includes: partName) ifTrue:
			[self inform: 'Sorry, that name is already used'.
			^ nil].
	^ partName! !

!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:50'!
nameMeIn: aWorld
	| stem otherNames i partName className |
	className _ self class name.
	stem _ className.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString , stem allButFirst.
	otherNames _ Set newFrom: aWorld allKnownNames.
	i _ 1.
	[otherNames includes: (partName _ stem , i printString)]
		whileTrue: [i _ i + 1].
	self setNamePropertyTo: partName! !

!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:51'!
renameMe
	| newName |
	newName _ self chooseNameLike: self knownName.
	newName ifNil: [^ nil].
	self setNamePropertyTo: newName! !


!Component methodsFor: 'variables' stamp: 'gm 3/2/2003 18:35'!
addVariableNamed: varName 
	"Adjust name if necessary and add it"

	| otherNames i partName |
	otherNames := self class allInstVarNames.
	i := nil.
	
	[partName := i isNil 
		ifTrue: [varName]
		ifFalse: [varName , i printString].
	otherNames includes: partName] 
			whileTrue: [i := i isNil ifTrue: [1] ifFalse: [i + 1]].
	self class addInstVarName: partName.

	"Now compile read method and write-with-change method"
	self class 
		compile: (String streamContents: 
					[:s | 
					s
						nextPutAll: partName;
						cr;
						tab;
						nextPutAll: '^' , partName])
		classified: 'view access'
		notifying: nil.
	self class 
		compile: (String streamContents: 
					[:s | 
					s
						nextPutAll: partName , 'Set: newValue';
						cr;
						tab;
						nextPutAll: partName , ' _ newValue.';
						cr;
						tab;
						nextPutAll: 'self changed: #' , partName , '.';
						cr;
						tab;
						nextPutAll: '^ true'	"for components that expect a boolean for accept"])
		classified: 'view access'
		notifying: nil.
	^Array with: partName asSymbol with: (partName , 'Set:') asSymbol! !

!Component methodsFor: 'variables' stamp: 'di 5/3/1998 19:58'!
removeVariableNamed: varName 
	self class removeSelector: varName.
	self class removeSelector: (varName , 'Set:') asSymbol.
	self class removeInstVarName: varName asString! !


!Component methodsFor: 'viewer' stamp: 'di 5/3/1998 19:58'!
externalName 
	^ self class name! !

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

Component class
	instanceVariableNames: ''!

!Component class methodsFor: 'as yet unclassified' stamp: 'di 4/18/1998 11:08'!
addSlotNamed: aName
	(self allInstVarNames includes: aName) ifTrue: [self error: 'Duplicate slot name'].
	self addInstVarName: aName.
! !

!Component class methodsFor: 'as yet unclassified' stamp: 'di 4/13/98 12:15'!
includeInNewMorphMenu
	"Only include instances of subclasses of me"
	^ self ~~ Component! !


!Component class methodsFor: 'compiling' stamp: 'di 4/17/1998 14:02'!
acceptsLoggingOfCompilation
	"Log everything for now"

	^ true! !

!Component class methodsFor: 'compiling' stamp: 'di 5/3/1998 19:55'!
wantsChangeSetLogging
	"Log changes for Component itself, but not for automatically-created subclasses like Component1, Component2"

	"^ self == Component or:
		[(self class name beginsWith: 'Component') not]"

	"Log everything for now"
	false ifTrue: [self halt  "DONT FORGET TO REORDER FILEOUT"].
	^ true! !
PasteUpMorph subclass: #ComponentLayout
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!ComponentLayout methodsFor: 'initialization' stamp: 'di 1/17/2000 16:36'!
initialize
	super initialize.
	self createCustomModel.
	self extent: 384@256! !


!ComponentLayout methodsFor: 'layout' stamp: 'di 5/3/1998 10:17'!
acceptDroppingMorph: aMorph event: evt
	"Eschew all of PasteUp's mechanism for now"

	self addMorph: aMorph.
! !


!ComponentLayout methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:17'!
addCustomMenuItems: menu hand: aHandMorph

	super addCustomMenuItems: menu hand: aHandMorph.
	menu addLine.
	menu add: 'inspect model in morphic' translated action: #inspectModelInMorphic! !


!ComponentLayout methodsFor: 'model' stamp: 'dgd 2/21/2003 23:06'!
createCustomModel
	"Create a model object for this world if it does not yet have one.
	The default model for an EditView is a Component."

	model isNil ifFalse: [^self].	"already has a model"
	model := Component newSubclass new! !


!ComponentLayout methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 19:06'!
allKnownNames
	^super allKnownNames 
		, (self submorphs collect: [:m | m knownName] thenSelect: [:m | m notNil])! !


!ComponentLayout methodsFor: '*Tools' stamp: 'ar 9/27/2005 20:58'!
inspectModelInMorphic
	| insp |
	insp := InspectorBrowser openAsMorphOn: self model.
	self world addMorph: insp; startStepping: insp! !
MorphicModel subclass: #ComponentLikeModel
	instanceVariableNames: 'pinSpecs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/1/1998 16:14'!
addPinFromSpec: pinSpec
	| pin |
	pin _ PinMorph new component: self pinSpec: pinSpec.
	self addMorph: pin.
	pin placeFromSpec.
	^ pin! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/2/1998 15:07'!
deleteComponent
	model removeDependent: self.
	self pinsDo: [:pin | pin delete].
	^ super delete! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/5/1998 00:57'!
initComponentIn: aLayout
	model _ aLayout model.
	self nameMeIn: aLayout.
	self color: Color lightCyan.
	self initPinSpecs.
	self initFromPinSpecs.
	self showPins.
	model addDependent: self! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/1/1998 16:31'!
initFromPinSpecs
	"no-op for default"! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:11'!
initPinSpecs
	"no-op for default"
	pinSpecs _ Array new.
! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 4/26/1998 10:40'!
nameMeIn: aWorld
	| stem otherNames i partName className |
	className _ self class name.
	stem _ className.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString , stem allButFirst.
	otherNames _ Set newFrom: aWorld allKnownNames.
	i _ 1.
	[otherNames includes: (partName _ stem , i printString)]
		whileTrue: [i _ i + 1].
	self setNamePropertyTo: partName! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:18'!
pinSpecs
	^ pinSpecs! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/2/1998 15:09'!
pinsDo: pinBlock
	self submorphsDo: [:m | (m isKindOf: PinMorph) ifTrue: [pinBlock value: m]]! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 09:26'!
renameMe
	| otherNames newName |
	otherNames _ Set newFrom: self pasteUpMorph allKnownNames.
	newName _ FillInTheBlank request: 'Please give this new a name'
						initialAnswer: self knownName.
	newName isEmpty ifTrue: [^ nil].
	(otherNames includes: newName) ifTrue:
			[self inform: 'Sorry, that name is already used'. ^ nil].
	self setNamePropertyTo: newName! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 4/29/1998 15:16'!
showPins
	"Make up sensitized pinMorphs for each of my interface variables"
	self pinSpecs do: [:pinSpec | self addPinFromSpec: pinSpec]! !


!ComponentLikeModel methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 20:03'!
justDroppedInto: aMorph event: anEvent
	| theModel |
	theModel _ aMorph modelOrNil.
	((aMorph isKindOf: ComponentLayout) 
		and: [theModel isKindOf: Component]) ifFalse:
		["Disconnect prior to removal by move"
		(theModel isKindOf: Component) ifTrue: [self unwire.  model _ nil].
		^ super justDroppedInto: aMorph event: anEvent].
	theModel == model ifTrue: [^ self  "Presumably just a move"].
	self initComponentIn: aMorph.
	super justDroppedInto: aMorph event: anEvent! !


!ComponentLikeModel methodsFor: 'geometry' stamp: 'di 4/29/1998 09:49'!
extent: newExtent
	super extent: newExtent.
	self submorphsDo: [:m | (m isKindOf: PinMorph) ifTrue: [m placeFromSpec]]! !


!ComponentLikeModel methodsFor: 'initialization' stamp: 'di 5/3/1998 09:24'!
duplicate: newGuy from: oldGuy
	"oldGuy has just been duplicated and will stay in this world.  Make sure all the ComponentLikeModel requirements are carried out for the copy.  Ask user to rename it.  "

	newGuy installModelIn: oldGuy pasteUpMorph.
	newGuy copySlotMethodsFrom: oldGuy slotName.! !


!ComponentLikeModel methodsFor: 'naming' stamp: 'dgd 2/21/2003 23:01'!
choosePartName
	"When I am renamed, get a slot, make default methods, move any existing methods."

	| old |
	(self pasteUpMorph model isKindOf: Component) 
		ifTrue: 
			[self knownName ifNil: [^self nameMeIn: self pasteUpMorph]
				ifNotNil: [^self renameMe]].
	old := slotName.
	super choosePartName.
	slotName ifNil: [^self].	"user chose bad slot name"
	self model: self world model slotName: slotName.
	old isNil 
		ifTrue: [self compilePropagationMethods]
		ifFalse: [self copySlotMethodsFrom: old]
	"old ones not erased!!"! !


!ComponentLikeModel methodsFor: 'submorphs-add/remove' stamp: 'rbb 2/18/2005 13:32'!
delete
	"Delete the receiver.  Possibly put up confirming dialog.  Abort if user changes mind"

	(model isKindOf: Component) ifTrue: [^self deleteComponent].
	(model isMorphicModel) ifFalse: [^super delete].
	slotName ifNotNil: 
			[(self confirm: 'Shall I remove the slot ' , slotName 
						, '
	along with all associated methods?') 
				ifTrue: 
					[(model class selectors select: [:s | s beginsWith: slotName]) 
						do: [:s | model class removeSelector: s].
					(model class instVarNames includes: slotName) 
						ifTrue: [model class removeInstVarName: slotName]]
				ifFalse: 
					[(self 
						confirm: '...but should I at least dismiss this morph?
	[choose no to leave everything unchanged]') 
							ifFalse: [^self]]].
	super delete! !
VoiceEvent subclass: #CompositeEvent
	instanceVariableNames: 'timedEvents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 02:16'!
addAll: aCollection
	aCollection do: [ :each | self add: each].
	^ aCollection! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 22:57'!
add: aVoiceEvent
	^ self add: aVoiceEvent at: self lastTime! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 22:57'!
add: aVoiceEvent at: time
	^ self timedEvents add: time -> aVoiceEvent! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 22:56'!
add: aVoiceEvent delayed: time
	^ self add: aVoiceEvent at: self lastTime + time! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 03:08'!
at: anInteger
	^ (self timedEvents at: anInteger) value! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 23:18'!
duration
	"Answer the duration (in seconds) of the receiver."
	^ self lastTime / 1000.0! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 03:09'!
first
	^ self at: 1! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 03:09'!
last
	^ self at: self size! !

!CompositeEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
lastTime
	| last |
	self isEmpty ifTrue: [^ 0].
	last := self timedEvents last.
	^ last key + (last value duration * 1000) rounded! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 23:16'!
size
	^ self timedEvents size! !


!CompositeEvent methodsFor: 'accessing-private' stamp: 'len 8/28/1999 22:54'!
timedEvents
	^ timedEvents! !

!CompositeEvent methodsFor: 'accessing-private' stamp: 'stephaneducasse 2/3/2006 22:22'!
timedEvents: aCollection
	timedEvents := aCollection! !


!CompositeEvent methodsFor: 'converting' stamp: 'len 9/29/1999 02:52'!
asArray	
	^ (1 to: self size) collect: [ :each | self at: each]! !

!CompositeEvent methodsFor: 'converting' stamp: 'stephaneducasse 2/3/2006 22:22'!
asPHOString
	| stream |
	stream := WriteStream on: String new.
	self do: [ :each | stream nextPutAll: each asPHOString; nextPut: Character cr].
	^ stream contents! !


!CompositeEvent methodsFor: 'copying' stamp: 'stephaneducasse 2/3/2006 22:22'!
copy
	| answer |
	answer := self class new: self size.
	self timedEvents do: [ :each | answer add: each value copy at: each key].
	^ answer! !


!CompositeEvent methodsFor: 'enumerating' stamp: 'len 12/14/1999 05:49'!
detect: aBlock
	self detect: aBlock ifNone: [self error: 'event not found']! !

!CompositeEvent methodsFor: 'enumerating' stamp: 'len 12/14/1999 05:49'!
detect: aBlock ifNone: exceptionBlock
	self do: [ :each | (aBlock value: each) ifTrue: [^ each]].
	^ exceptionBlock value! !

!CompositeEvent methodsFor: 'enumerating' stamp: 'len 8/28/1999 23:09'!
do: aBlock
	self timedEvents do: [ :each | aBlock value: each value]! !


!CompositeEvent methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize: anInteger
	timedEvents := SortedCollection new: anInteger! !


!CompositeEvent methodsFor: 'playing' stamp: 'len 12/22/1999 03:32'!
playOn: aVoice at: time
	self timedEvents do: [ :each | each value playOn: aVoice at: each key + time].
	aVoice flush! !


!CompositeEvent methodsFor: 'testing' stamp: 'len 8/28/1999 22:56'!
isEmpty
	^ self timedEvents isEmpty! !


!CompositeEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:12'!
compress: aNumber
	self stretch: aNumber reciprocal! !

!CompositeEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:11'!
delay: time
	self timedEvents do: [ :each | each key: each key + time]! !

!CompositeEvent methodsFor: 'transforming' stamp: 'len 9/29/1999 05:16'!
pitchBy: aNumber
	self do: [ :each | each pitchBy: aNumber]! !

!CompositeEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:13'!
stretch: aNumber
	self do: [ :each | each stretch: aNumber].
	self timedEvents do: [ :each | each key: (each key * aNumber) rounded]! !


!CompositeEvent methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
recomputeTimes
	| oldTimedEvents |
	oldTimedEvents := timedEvents.
	timedEvents := SortedCollection new: oldTimedEvents size.
	oldTimedEvents do: [ :each | self add: each value]! !

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

CompositeEvent class
	instanceVariableNames: ''!

!CompositeEvent class methodsFor: 'instance creation' stamp: 'len 8/28/1999 23:14'!
new
	^ self new: 10! !

!CompositeEvent class methodsFor: 'instance creation' stamp: 'len 8/28/1999 23:15'!
new: anInteger
	^ self basicNew initialize: anInteger! !
WidgetStub subclass: #CompositeStub
	instanceVariableNames: 'children'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!CompositeStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:50'!
children
	^children! !

!CompositeStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:50'!
children: anObject
	children := anObject! !

!CompositeStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:51'!
eventAccessors
	^ #(children)! !

!CompositeStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:54'!
widgetNamed: aString
	self name = aString
		ifTrue: [^ self]
		ifFalse: [children do: [:ea | (ea widgetNamed: aString) ifNotNilDo: [:w | ^ w]]].
	^ nil! !
DisplayTransform subclass: #CompositeTransform
	instanceVariableNames: 'globalTransform localTransform'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Transformations'!
!CompositeTransform commentStamp: '<historical>' prior: 0!
A composite transform provides the effect of several levels of coordinate transformations.!


!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 17:06'!
angle
	^ localTransform angle + globalTransform angle! !

!CompositeTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:45'!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self species new
		globalTransform: localTransform inverseTransformation
		localTransform: globalTransform inverseTransformation! !

!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:40'!
offset
	^ (self localPointToGlobal: 0@0) negated! !

!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:39'!
scale
	^ localTransform scale * globalTransform scale! !


!CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:00'!
asCompositeTransform
	^self! !

!CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:56'!
asMatrixTransform2x3
	^globalTransform asMatrixTransform2x3
		composedWithLocal: localTransform asMatrixTransform2x3! !

!CompositeTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'!
asMorphicTransform
	"Squash a composite transform down to a simple one"
	^ MorphicTransform offset: self offset angle: self angle scale: self scale! !


!CompositeTransform methodsFor: 'initialization' stamp: 'di 10/26/1999 17:08'!
composedWith: aTransform
	"Return a new transform that has the effect of transforming points first by the receiver and then by the argument."

	self isIdentity ifTrue: [^ aTransform].
	aTransform isIdentity ifTrue: [^ self].
	^ CompositeTransform new globalTransform: self
							localTransform: aTransform! !

!CompositeTransform methodsFor: 'initialization' stamp: 'di 3/4/98 19:17'!
globalTransform: gt localTransform: lt
	globalTransform _ gt.
	localTransform _ lt! !


!CompositeTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:00'!
isCompositeTransform
	^true! !

!CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'!
isIdentity
	^ globalTransform isIdentity and: [localTransform isIdentity]! !

!CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'!
isPureTranslation
	^ globalTransform isPureTranslation and: [localTransform isPureTranslation]! !


!CompositeTransform methodsFor: 'transformations' stamp: 'di 10/1/1998 13:51'!
invert: aPoint
	^ globalTransform invert: (localTransform invert: aPoint)! !

!CompositeTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:20'!
transform: aPoint
	^ localTransform transform: (globalTransform transform: aPoint)! !


!CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^localTransform globalPointToLocal:
		(globalTransform globalPointToLocal: aPoint)! !

!CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'!
localPointToGlobal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^globalTransform localPointToGlobal:
		(localTransform localPointToGlobal: aPoint)! !


!CompositeTransform methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ls 3/19/2000 16:28'!
encodeForRemoteCanvas
	^String streamContents: [ :str |
		str
			nextPutAll: 'Composite,';
			nextPutAll: '(';
			nextPutAll: globalTransform encodeForRemoteCanvas;
			nextPutAll: ')(';
			nextPutAll: localTransform encodeForRemoteCanvas;
			nextPutAll: ')' ]! !

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

CompositeTransform class
	instanceVariableNames: ''!

!CompositeTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:44'!
globalTransform: gt localTransform: lt
	^self new globalTransform: gt localTransform: lt! !


!CompositeTransform class methodsFor: '*nebraska-instance creation' stamp: 'ls 3/19/2000 16:49'!
fromRemoteCanvasEncoding: encoding
	| firstStart firstEnd firstEncoding firstTransform secondStart secondEnd secondEncoding secondTransform |
	"format: Composite,(enc1)(enc2)"

	"decode the first encoding"
	firstStart := encoding indexOf: $(.
	firstStart = 0 ifTrue: [ self error: 'invalid encoding' ].
	firstEnd := encoding findCloseParenthesisFor: firstStart.
	firstEncoding := encoding copyFrom: firstStart+1 to: firstEnd-1.
	firstTransform := DisplayTransform fromRemoteCanvasEncoding: firstEncoding.

	"decode the second encoding"
	secondStart := firstEnd + 1.
	(encoding at: secondStart) = $( ifFalse: [ ^self error: 'invalid encoding' ].
	secondEnd := encoding findCloseParenthesisFor: secondStart.
	secondEncoding := encoding copyFrom: secondStart+1 to: secondEnd-1.
	secondTransform := DisplayTransform fromRemoteCanvasEncoding: secondEncoding.
	

	"put it together"
	^self globalTransform: firstTransform localTransform: secondTransform! !
Voice subclass: #CompositeVoice
	instanceVariableNames: 'voices'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!CompositeVoice methodsFor: 'accessing' stamp: 'len 9/13/1999 00:00'!
add: aVoice
	^ self voices add: aVoice! !

!CompositeVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 04:01'!
voices
	^ voices! !

!CompositeVoice methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
voices: aCollection
	voices := aCollection! !


!CompositeVoice methodsFor: 'enumerating' stamp: 'len 8/29/1999 02:21'!
do: aBlock
	self voices do: aBlock! !


!CompositeVoice methodsFor: 'initialization' stamp: 'len 8/28/1999 04:00'!
initialize
	super initialize.
	self voices: OrderedCollection new! !


!CompositeVoice methodsFor: 'playing' stamp: 'len 12/22/1999 03:51'!
flush
	"Play all the events in the queue."
	super flush.
	self do: [ :each | each flush]! !

!CompositeVoice methodsFor: 'playing' stamp: 'len 9/26/1999 17:21'!
playGesturalEvent: event at: time
	self do: [ :each | each playGesturalEvent: event at: time]! !

!CompositeVoice methodsFor: 'playing' stamp: 'len 9/26/1999 17:21'!
playPhoneticEvent: event at: time
	self do: [ :each | each playPhoneticEvent: event at: time]! !

!CompositeVoice methodsFor: 'playing' stamp: 'len 9/26/1999 17:22'!
reset
	"Reset the state of the receiver."
	super reset.
	self do: [ :each | each reset]! !
CharacterScanner subclass: #CompositionScanner
	instanceVariableNames: 'spaceX spaceIndex lineHeight baseline lineHeightAtSpace baselineAtSpace'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Text'!
!CompositionScanner commentStamp: '<historical>' prior: 0!
CompositionScanners are used to measure text and determine where line breaks and space padding should occur.!


!CompositionScanner methodsFor: 'accessing' stamp: 'ar 1/8/2000 14:35'!
rightX
	"Meaningful only when a line has just been composed -- refers to the 
	line most recently composed. This is a subtrefuge to allow for easy 
	resizing of a composition rectangle to the width of the maximum line. 
	Useful only when there is only one line in the form or when each line 
	is terminated by a carriage return. Handy for sizing menus and lists."

	^spaceX! !


!CompositionScanner methodsFor: 'intialize-release' stamp: 'ar 5/17/2000 19:14'!
forParagraph: aParagraph
	"Initialize the receiver for scanning the given paragraph."

	self
		initializeFromParagraph: aParagraph
		clippedBy: aParagraph clippingRectangle.
! !


!CompositionScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 02:06'!
composeFrom: startIndex inRectangle: lineRectangle
	firstLine: firstLine leftSide: leftSide rightSide: rightSide
	"Answer an instance of TextLineInterval that represents the next line in the paragraph."
	| runLength done stopCondition |
	"Set up margins"
	leftMargin _ lineRectangle left.
	leftSide ifTrue: [leftMargin _ leftMargin +
						(firstLine ifTrue: [textStyle firstIndent]
								ifFalse: [textStyle restIndent])].
	destX _ spaceX _ leftMargin.
	rightMargin _ lineRectangle right.
	rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent].
	lastIndex _ startIndex.	"scanning sets last index"
	destY _ lineRectangle top.
	lineHeight _ baseline _ 0.  "Will be increased by setFont"
	self setStopConditions.	"also sets font"
	runLength _ text runLengthFor: startIndex.
	runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
	line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
				rectangle: lineRectangle.
	spaceCount _ 0.
	self handleIndentation.
	leftMargin _ destX.
	line leftMargin: leftMargin.

	done _ false.
	[done]
		whileFalse: 
			[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
				in: text string rightX: rightMargin stopConditions: stopConditions
				kern: kern.
			"See setStopConditions for stopping conditions for composing."
			(self perform: stopCondition)
				ifTrue: [^ line lineHeight: lineHeight + textStyle leading
							baseline: baseline + textStyle leading]]! !

!CompositionScanner methodsFor: 'scanning' stamp: 'hmm 7/20/2000 18:24'!
composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph 
	"Answer an instance of TextLineInterval that represents the next line in the paragraph."
	| runLength done stopCondition |
	destX _ spaceX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex.
	destY _ 0.
	rightMargin _ aParagraph rightMarginForComposition.
	leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose'].
	lastIndex _ startIndex.	"scanning sets last index"
	lineHeight _ textStyle lineGrid.  "may be increased by setFont:..."
	baseline _ textStyle baseline.
	self setStopConditions.	"also sets font"
	self handleIndentation.
	runLength _ text runLengthFor: startIndex.
	runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
	line _ TextLineInterval
		start: lastIndex
		stop: 0
		internalSpaces: 0
		paddingWidth: 0.
	spaceCount _ 0.
	done _ false.
	[done]
		whileFalse: 
			[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
				in: text string rightX: rightMargin stopConditions: stopConditions
				kern: kern.
			"See setStopConditions for stopping conditions for composing."
			(self perform: stopCondition)
				ifTrue: [^line lineHeight: lineHeight + textStyle leading
							baseline: baseline + textStyle leading]]! !

!CompositionScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:36'!
setActualFont: aFont
	"Keep track of max height and ascent for auto lineheight"
	| descent |
	super setActualFont: aFont.
	lineHeight == nil
		ifTrue: [descent _ font descent.
				baseline _ font ascent.
				lineHeight _ baseline + descent]
		ifFalse: [descent _ lineHeight - baseline max: font descent.
				baseline _ baseline max: font ascent.
				lineHeight _ lineHeight max: baseline + descent]! !


!CompositionScanner methodsFor: 'stop conditions' stamp: 'RAA 5/4/2001 13:52'!
columnBreak

	"Answer true. Set up values for the text line interval currently being 
	composed."

	line stop: lastIndex.
	spaceX _ destX.
	line paddingWidth: rightMargin - spaceX.
	^true! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:54'!
cr
	"Answer true. Set up values for the text line interval currently being 
	composed."

	line stop: lastIndex.
	spaceX _ destX.
	line paddingWidth: rightMargin - spaceX.
	^true! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:54'!
crossedX
	"There is a word that has fallen across the right edge of the composition 
	rectangle. This signals the need for wrapping which is done to the last 
	space that was encountered, as recorded by the space stop condition."

	spaceCount >= 1 ifTrue:
		["The common case. First back off to the space at which we wrap."
		line stop: spaceIndex.
		lineHeight _ lineHeightAtSpace.
		baseline _ baselineAtSpace.
		spaceCount _ spaceCount - 1.
		spaceIndex _ spaceIndex - 1.

		"Check to see if any spaces preceding the one at which we wrap.
			Double space after punctuation, most likely."
		[(spaceCount > 1 and: [(text at: spaceIndex) = Space])]
			whileTrue:
				[spaceCount _ spaceCount - 1.
				"Account for backing over a run which might
					change width of space."
				font _ text fontAt: spaceIndex withStyle: textStyle.
				spaceIndex _ spaceIndex - 1.
				spaceX _ spaceX - (font widthOf: Space)].
		line paddingWidth: rightMargin - spaceX.
		line internalSpaces: spaceCount]
	ifFalse:
		["Neither internal nor trailing spaces -- almost never happens."
		lastIndex _ lastIndex - 1.
		[destX <= rightMargin]
			whileFalse:
				[destX _ destX - (font widthOf: (text at: lastIndex)).
				lastIndex _ lastIndex - 1].
		spaceX _ destX.
		line paddingWidth: rightMargin - destX.
		line stop: (lastIndex max: line first)].
	^true! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:54'!
endOfRun
	"Answer true if scanning has reached the end of the paragraph. 
	Otherwise step conditions (mostly install potential new font) and answer 
	false."

	| runLength |
	lastIndex = text size
	ifTrue:	[line stop: lastIndex.
			spaceX _ destX.
			line paddingWidth: rightMargin - destX.
			^true]
	ifFalse:	[runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
			runStopIndex _ lastIndex + (runLength - 1).
			self setStopConditions.
			^false]
! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 12/17/2001 02:13'!
placeEmbeddedObject: anchoredMorph
	| descent |
	"Workaround: The following should really use #textAnchorType"
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	(super placeEmbeddedObject: anchoredMorph) ifFalse: ["It doesn't fit"
		"But if it's the first character then leave it here"
		lastIndex < line first ifFalse:[
			line stop: lastIndex-1.
			^ false]].
	descent _ lineHeight - baseline.
	lineHeight _ lineHeight max: anchoredMorph height.
	baseline _ lineHeight - descent.
	line stop: lastIndex.
	^ true! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'RAA 5/7/2001 10:12'!
setFont
	super setFont.
	stopConditions == DefaultStopConditions 
		ifTrue:[stopConditions _ stopConditions copy].
	stopConditions at: Space asciiValue + 1 put: #space.
	wantsColumnBreaks == true ifTrue: [
		stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak.
	].
! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:37'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:55'!
space
	"Record left x and character index of the space character just encounted. 
	Used for wrap-around. Answer whether the character has crossed the 
	right edge of the composition rectangle of the paragraph."

	spaceX _ destX.
	destX _ spaceX + spaceWidth.
	spaceIndex _ lastIndex.
	lineHeightAtSpace _ lineHeight.
	baselineAtSpace _ baseline.
	lastIndex _ lastIndex + 1.
	spaceCount _ spaceCount + 1.
	destX > rightMargin ifTrue: 	[^self crossedX].
	^false
! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:59'!
tab
	"Advance destination x according to tab settings in the paragraph's 
	textStyle. Answer whether the character has crossed the right edge of 
	the composition rectangle of the paragraph."

	destX _ textStyle
				nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin.
	destX > rightMargin ifTrue:	[^self crossedX].
	lastIndex _ lastIndex + 1.
	^false
! !
TextConverter subclass: #CompoundTextConverter
	instanceVariableNames: 'state'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!CompoundTextConverter commentStamp: '<historical>' prior: 0!
Text converter for X Compound Text.!


!CompoundTextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:25'!
nextFromStream: aStream 

	| character character2 size leadingChar offset result |
	aStream isBinary ifTrue: [^ aStream basicNext].

	character _ aStream basicNext.
	character ifNil: [^ nil].
	character == Character escape ifTrue: [
		self parseShiftSeqFromStream: aStream.
		character _ aStream basicNext.
		character ifNil: [^ nil]].
	character asciiValue < 128 ifTrue: [
		size _ state g0Size.
		leadingChar _ state g0Leading.
		offset _ 16r21.
	] ifFalse: [
		size _state g1Size.
		leadingChar _ state g1Leading.
		offset _ 16rA1.
	].
	size = 1 ifTrue: [
		leadingChar = 0
			ifTrue: [^ character]
			ifFalse: [^ Character leadingChar: leadingChar code: character asciiValue]
	].
	size = 2 ifTrue: [
		character2 _ aStream basicNext.
		character2 ifNil: [^ nil. "self errorMalformedInput"].
		character _ character asciiValue - offset.
		character2 _ character2 asciiValue - offset.
		result _ Character leadingChar: leadingChar code: character * 94 + character2.
		^ result asUnicodeChar.
		"^ self toUnicode: result"
	].
	self error: 'unsupported encoding'.
! !

!CompoundTextConverter methodsFor: 'conversion' stamp: 'ar 4/12/2005 14:10'!
nextPut: aCharacter toStream: aStream

	| ascii leadingChar class |
	aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream].
	aCharacter isTraditionalDomestic ifFalse: [
		class _ (EncodedCharSet charsetAt: aCharacter leadingChar) traditionalCharsetClass.
		ascii _ (class charFromUnicode: aCharacter asUnicode) charCode.
		leadingChar _ class leadingChar.
	] ifTrue: [
		ascii _ aCharacter charCode.
		leadingChar _ aCharacter leadingChar.
	].

	self nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar.
! !


!CompoundTextConverter methodsFor: 'friend' stamp: 'yo 9/16/2002 21:41'!
currentCharSize

	^ state charSize.
! !

!CompoundTextConverter methodsFor: 'friend' stamp: 'yo 8/18/2003 17:50'!
emitSequenceToResetStateIfNeededOn: aStream

	Latin1 emitSequenceToResetStateIfNeededOn: aStream forState: state.
! !

!CompoundTextConverter methodsFor: 'friend' stamp: 'yo 11/4/2002 12:33'!
restoreStateOf: aStream with: aConverterState

	state _ aConverterState copy.
	aStream position: state streamPosition.
! !

!CompoundTextConverter methodsFor: 'friend' stamp: 'yo 11/4/2002 13:52'!
saveStateOf: aStream

	| inst |
	inst _  state clone.
	inst streamPosition: aStream position.
	^ inst.
! !


!CompoundTextConverter methodsFor: 'initialize-release' stamp: 'yo 8/13/2003 11:45'!
initialize

	state _ CompoundTextConverterState 
		g0Size: 1 g1Size: 1 g0Leading: 0 g1Leading: 0 charSize: 1 streamPosition: 0.
	acceptingEncodings _ #(ascii iso88591 jisx0208 gb2312 ksc5601 ksx1001 ) copy.
! !


!CompoundTextConverter methodsFor: 'query' stamp: 'yo 8/23/2002 22:39'!
accepts: aSymbol

	^ acceptingEncodings includes: aSymbol.
! !


!CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 14:36'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar

	| charset |
	charset _ EncodedCharSet charsetAt: leadingChar.
	charset ifNotNil: [
		charset nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state.
	] ifNil: [
		"..."
	].
! !

!CompoundTextConverter methodsFor: 'private' stamp: 'yo 12/10/2003 15:46'!
parseShiftSeqFromStream: aStream

	| c set target id |
	c _ aStream basicNext.
	c = $$ ifTrue: [
		set _ #multibyte.
		c _ aStream basicNext.
		c = $( ifTrue: [target _ 1].
		c = $) ifTrue: [target _ 2].
		target ifNil: [target _ 1. id _ c]
			ifNotNil: [id _ aStream basicNext].
	] ifFalse: [
		c = $( ifTrue: [target _ 1. set _ #nintyfour].
		c = $) ifTrue: [target _ 2. set _ #nintyfour].
		c = $- ifTrue: [target _ 2. set _ #nintysix].
		"target = nil ifTrue: [self errorMalformedInput]."
		id _ aStream basicNext.
	].
	(set = #multibyte and: [id = $B]) ifTrue: [
		state charSize: 2.
		target = 1 ifTrue: [
			state g0Size: 2.
			state g0Leading: 1.
		] ifFalse: [
			state g1Size: 2.
			state g1Leading: 1.
		].
		^ self
	].
	(set = #multibyte and: [id = $A]) ifTrue: [
		state charSize: 2.
		target = 1 ifTrue: [
			state g0Size: 2.
			state g0Leading: 2.
		] ifFalse: [
			state g1Size: 2.
			state g1Leading: 2.
		].
		^ self
	].

	(set = #nintyfour and: [id = $B or: [id = $J]]) ifTrue: [
		state charSize: 1.
		state g0Size: 1.
		state g0Leading: 0.
		^ self
	].
	(set = #nintysix and: [id = $A]) ifTrue: [
		state charSize: 1.
		state g1Size: 1.
		state g1Leading: 0.
		^ self
	].

	"self errorUnsupported."
! !

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

CompoundTextConverter class
	instanceVariableNames: ''!

!CompoundTextConverter class methodsFor: 'utilities' stamp: 'yo 10/24/2002 14:16'!
encodingNames

	^ #('iso-2022-jp' 'x-ctext') copy
! !
Object subclass: #CompoundTextConverterState
	instanceVariableNames: 'g0Size g1Size g0Leading g1Leading charSize streamPosition'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!CompoundTextConverterState commentStamp: '<historical>' prior: 0!
This represents the state of CompoundTextConverter.!


!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'!
charSize

	^ charSize
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'!
charSize: s

	charSize _ s.
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'!
g0Leading

	^ g0Leading
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'!
g0Leading: l

	g0Leading _ l.
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'!
g0Size

	^ g0Size
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'!
g0Size: s

	g0Size _ s.
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 14:37'!
g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos

	g0Size _ g0.
	g1Size _ g1.
	g0Leading _ g0l.
	g1Leading _ g1l.
	charSize _ cSize.
	streamPosition _ pos.
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'!
g1Leading

	^ g1Leading
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'!
g1Leading: l

	g1Leading _ l.
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'!
g1Size

	^ g1Size
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'!
g1Size: s

	g1Size _ s.
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 11/4/2002 12:31'!
printOn: aStream

	aStream nextPut: $(;
		nextPutAll: g0Size printString; space;
		nextPutAll: g1Size printString; space;
		nextPutAll: g0Leading printString; space;
		nextPutAll: g1Leading printString; space;
		nextPutAll: charSize printString; space;
		nextPutAll: streamPosition printString.
	aStream nextPut: $).
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'!
streamPosition

	^ streamPosition
! !

!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:40'!
streamPosition: pos

	streamPosition _ pos.
! !

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

CompoundTextConverterState class
	instanceVariableNames: ''!

!CompoundTextConverterState class methodsFor: 'instance creation' stamp: 'yo 8/19/2002 17:04'!
g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos

	^ (self new)
		g0Size: g0
		g1Size: g1
		g0Leading: g0l
		g1Leading: g1l
		charSize: cSize
		streamPosition: pos
	; yourself.
! !
TileLikeMorph subclass: #CompoundTileMorph
	instanceVariableNames: 'type testPart yesPart noPart'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!CompoundTileMorph commentStamp: '<historical>' prior: 0!
A statement with other whole statements inside it.  If-Then.  Test.!


!CompoundTileMorph methodsFor: 'access' stamp: 'sw 8/11/1998 16:42'!
associatedPlayer
	^ nil! !

!CompoundTileMorph methodsFor: 'access' stamp: 'nk 10/14/2004 11:37'!
myMorph
	^nil! !

!CompoundTileMorph methodsFor: 'access' stamp: 'sw 10/13/97 21:23'!
scriptee
	 "Pertains only when the test is outside a script?!!"
	^ nil! !


!CompoundTileMorph methodsFor: 'code generation' stamp: 'sw 9/2/1999 15:22'!
codeString
	^ String streamContents: [:aStream | self storeCodeOn: aStream indent: 1]
! !

!CompoundTileMorph methodsFor: 'code generation' stamp: 'jm 5/29/1998 10:26'!
storeCodeBlockFor: scriptPart on: aStream indent: tabCount

	| rows r |
	rows _ scriptPart tileRows.
	1 to: rows size do: [:i |
		tabCount timesRepeat: [aStream tab].
		r _ rows at: i.
		r do: [:t | t storeCodeOn: aStream indent: tabCount].
		i < rows size ifTrue: [aStream nextPut: $.; cr]].
! !

!CompoundTileMorph methodsFor: 'code generation' stamp: 'jm 5/29/1998 10:31'!
storeCodeOn: aStream indent: tabCount

	aStream nextPut: $(.
	testPart storeCodeOn: aStream indent: 0.
	aStream nextPut: $); cr.

	tabCount + 1 timesRepeat: [aStream tab].
	aStream nextPutAll: 'ifTrue: ['; cr.
	self storeCodeBlockFor: yesPart on: aStream indent: tabCount + 2.
	aStream nextPut: $]; cr.
	tabCount + 1 timesRepeat: [aStream tab].
	aStream nextPutAll: 'ifFalse: ['; cr.
	self storeCodeBlockFor: noPart on: aStream indent: tabCount + 2.
	aStream nextPut: $].
! !


!CompoundTileMorph methodsFor: 'dropping/grabbing' stamp: 'sw 12/13/2001 16:42'!
wantsDroppedMorph: aMorph event: evt
	"Removing this method entirely would be okay someday"

	^ false
"
	^ (aMorph isKindOf: TileMorph) or:
	   [(aMorph isKindOf: ScriptEditorMorph) or:
	   [(aMorph isKindOf: CompoundTileMorph) or:
	   [aMorph isKindOf: CommandTilesMorph]]]"
! !


!CompoundTileMorph methodsFor: 'event handling' stamp: 'tk 2/28/2001 21:22'!
handlesMouseDown: evt
	^true! !

!CompoundTileMorph methodsFor: 'event handling' stamp: 'di 10/17/97 21:36'!
handlesMouseOver: evt

	^ true
! !

!CompoundTileMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:50'!
handlesMouseOverDragging: evt

	^ true
! !

!CompoundTileMorph methodsFor: 'event handling' stamp: 'tk 2/28/2001 21:25'!
mouseDown: evt 
	"Pretend we picked up the tile and then put it down for a trial  
	positioning."
	"The essence of ScriptEditor mouseEnter:"
	| ed ss guyToTake |
"	self isPartsDonor ifTrue:[
		dup _ self duplicate.
		evt hand attachMorph: dup.
		dup position: evt position.
		^self].
	submorphs isEmpty 			never true
		ifTrue: [^ self].
"
	(ed _ self enclosingEditor) ifNil: [^evt hand grabMorph: self].

	guyToTake _ self.
	owner class == TilePadMorph
		ifTrue: ["picking me out of another phrase"
			(ss _ submorphs first) class == TilePadMorph
				ifTrue: [ss _ ss submorphs first].
			guyToTake _  ss veryDeepCopy].
	evt hand grabMorph: guyToTake.
	ed startStepping.
	ed mouseEnterDragging: evt.
	ed setProperty: #justPickedUpPhrase toValue: true.
! !

!CompoundTileMorph methodsFor: 'event handling' stamp: 'jm 10/18/97 21:03'!
mouseEnter: evt
	"Resume drop-tracking in enclosing editor"
	| ed |
	(ed _ self enclosingEditor) ifNotNil:
		[ed mouseLeave: evt]! !

!CompoundTileMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:07'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!CompoundTileMorph methodsFor: 'event handling' stamp: 'jm 10/18/97 21:02'!
mouseLeave: evt
	"Resume drop-tracking in enclosing editor"
	| ed |
	(ed _ self enclosingEditor) ifNotNil:
		[ed mouseEnter: evt]! !

!CompoundTileMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !


!CompoundTileMorph methodsFor: 'e-toy support' stamp: 'ar 2/7/2001 17:57'!
isTileEditor
	"Yes I am"
	^true! !


!CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:21'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 1! !

!CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:21'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color orange muchLighter! !

!CompoundTileMorph methodsFor: 'initialization' stamp: 'sw 7/22/2004 00:13'!
initialize
	"initialize the state of the receiver"

	| r stringMorph |
	super initialize.
	self layoutInset: 2.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellInset: (0 @ 1); minCellSize: (200@14).
	"NB: hResizing gets reset to #spaceFill below, after the standalone structure is created"
	r _ AlignmentMorph newRow color: color;
				 layoutInset: 0.
	r setProperty: #demandsBoolean toValue: true.
	r addMorphBack: (Morph new color: color;
			 extent: 2 @ 5).
	"spacer"
	stringMorph _ StringMorph new contents: 'Test' translated.
	stringMorph name: 'Test'.
	r addMorphBack: stringMorph.
	r addMorphBack: (Morph new color: color;
			 extent: 5 @ 5).
	"spacer"
	r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0;
					 layoutInset: 1).
	testPart color: Color transparent.
	testPart hResizing: #spaceFill.
	self addMorphBack: r.
	r _ AlignmentMorph newRow color: color;
				 layoutInset: 0.
	r addMorphBack: (Morph new color: color;
			 extent: 30 @ 5).
	"spacer"
	stringMorph _ StringMorph new contents: 'Yes' translated.
	stringMorph name: 'Yes'.
	r addMorphBack: stringMorph.
	r addMorphBack: (Morph new color: color;
			 extent: 5 @ 5).
	"spacer"
	r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0;
					 layoutInset: 2).
	yesPart hResizing: #spaceFill.
	yesPart color: Color transparent.
	self addMorphBack: r.
	r _ AlignmentMorph newRow color: color;
				 layoutInset: 0.
	r addMorphBack: (Morph new color: color;
			 extent: 35 @ 5).
	"spacer"
	stringMorph _ StringMorph new contents: 'No' translated.
	stringMorph name: 'No'.
	r addMorphBack: stringMorph.
	r addMorphBack: (Morph new color: color;
			 extent: 5 @ 5).
	"spacer"
	r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0;
					 layoutInset: 2).
	noPart hResizing: #spaceFill.
	noPart color: Color transparent.
	self addMorphBack: r.
	self bounds: self fullBounds.
	self updateWordingToMatchVocabulary.
 	self hResizing:#spaceFill
! !

!CompoundTileMorph methodsFor: 'initialization' stamp: 'nk 10/8/2004 11:56'!
updateWordingToMatchVocabulary
	| labels |
	labels _ OrderedCollection new.
	self submorphs do: [:submorph |
		submorph submorphs do: [:subsubmorph |
			subsubmorph class == StringMorph ifTrue: [labels add: subsubmorph]]].
	labels do: [:label | label knownName ifNotNilDo: [ :nm | label acceptValue: nm translated ]]
! !


!CompoundTileMorph methodsFor: 'layout'!
acceptDroppingMorph: aMorph event: evt
	"Forward the dropped morph to the appropriate part."

	(self targetPartFor: aMorph) acceptDroppingMorph: aMorph event: evt.
! !


!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 10/18/97 18:03'!
install
	"Backstop for obscure cases"! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'ar 2/6/2001 22:07'!
recompileScript
	"Pertains only when the test is outside a script?!!"
! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/27/2001 17:27'!
resultType
	"Answer the result type of the receiver"

	^ #Command! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 5/13/1998 15:19'!
rowOfRightTypeFor: aLayoutMorph forActor: anActor
	aLayoutMorph demandsBoolean ifTrue:
		[^ self error: 'oops, cannot do that, please close this'].
	^ self! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 10/13/97 21:23'!
scriptEdited
	 "Pertains only when the test is outside a script?!!"! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'di 5/6/1998 21:10'!
tile: tile isOnLineAfter: previousTile
	"Return true if the given tile is not on the same line at the previous tile or if the previous tile is nil."

	| tileRow previousRow |
	previousTile ifNil: [^ true].
	tileRow _ tile owner.
	[tileRow isMemberOf: AlignmentMorph]
		whileFalse: [tileRow _ tileRow owner].  "find the owning row"
	previousRow _ previousTile owner.
	[previousRow isMemberOf: AlignmentMorph]
		whileFalse: [previousRow _ previousRow owner].  "find the owning row"
	^ tileRow ~~ previousRow
! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'tk 2/15/2001 16:36'!
tileRows
	"Answer a list of tile rows, in this case just one though it's compound"

	^ Array with: (Array with: self veryDeepCopy)! !

!CompoundTileMorph methodsFor: 'miscellaneous'!
type

	^ #compound
! !


!CompoundTileMorph methodsFor: 'mouse' stamp: 'sw 2/1/98 16:40'!
prepareToUndoDropOf: aMorph
	"needs to be here, as a no-op, owing to being hit obscurely on occasion"! !

!CompoundTileMorph methodsFor: 'mouse'!
targetPartFor: aMorph
	"Return the row into which the given morph should be inserted."

	| centerY |
	centerY _ aMorph fullBounds center y.
	(Array with: testPart with: yesPart with: noPart) do: [:m |
		(centerY <= m bounds bottom) ifTrue: [^ m]].
	^ noPart
! !


!CompoundTileMorph methodsFor: 'testing' stamp: 'yo 11/4/2002 20:33'!
isTileScriptingElement

	^ true
! !

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

CompoundTileMorph class
	instanceVariableNames: ''!

!CompoundTileMorph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
Object subclass: #CompressedBoundaryShape
	instanceVariableNames: 'points leftFills rightFills lineWidths lineFills fillStyles'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!
!CompressedBoundaryShape commentStamp: '<historical>' prior: 0!
This class represents a very compact representation of a boundary shape. It consists of a number of compressed arrays that can be handled by the balloon engine directly. Due to this, there are certain restrictions (see below). Boundaries are always represented by three subsequent points that define a quadratic bezier segment. It is recommended that for straight line segments the control point is set either to the previous or the next point.

Instance variables:
	points		<PointArray | ShortPointArray>	Point storage area
	leftFills		<ShortRunArray>	Containing the "left" fill index of each segment
	rightFills	<ShortRunArray>	Containing the "right" fill index of each segment
	lineWidths	<ShortRunArray>	Containing the line width of each segment
	lineFills		<ShortRunArray>	Containing the line fill (e.g., line color) of each segment
	fillStyles	<Collections>			Contains the actual fill styles referenced by the indexes

RESTRICTIONS:
None of the ShortRunArrays may contain a run of length Zero.
Also, due to the use of ShortRunArrays 
	a) you cannot have more than 32768 different fill styles
	b) you cannot have a line width that exceeds 32768
In case you have trouble with a), try to merge some of the fills into one. You might do so by converting colors to 32bit pixel values. In case you have trouble with b) you might change the general resolution of the compressed shape to have less accuracy.
!


!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ls 10/10/1999
13:52'!
bounds
	| min max width |
	points isEmpty ifTrue:[^0@0 corner: 1@1].
	min := max := points first.
	points do:[:pt|
		min := min min: pt.
		max := max max: pt
	].
	width := 0.
	lineWidths valuesDo:[:w| width := width max: w].
	^(min corner: max) insetBy: (width negated asPoint)! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
fillStyles
	^fillStyles! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
leftFills
	^leftFills! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
lineFills
	^lineFills! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
lineWidths
	^lineWidths! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/4/1998 13:50'!
numSegments
	^points size // 3! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 20:42'!
points
	^points! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
rightFills
	^rightFills! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:09'!
segments
	"Return all the segments in the receiver"
	| out |
	out := WriteStream on: Array new.
	self segmentsDo:[:seg| out nextPut: seg].
	^out contents! !


!CompressedBoundaryShape methodsFor: 'editing' stamp: 'ar 11/12/1998 21:12'!
collectFills: aBlock
	fillStyles := fillStyles collect: aBlock.! !

!CompressedBoundaryShape methodsFor: 'editing' stamp: 'ar 11/12/1998 21:11'!
copyAndCollectFills: aBlock
	^self copy collectFills: aBlock! !


!CompressedBoundaryShape methodsFor: 'enumerating' stamp: 'ar 11/9/1998 14:10'!
segmentsDo: aBlock
	"Enumerate all segments in the receiver and execute aBlock"
	| p1 p2 p3 |
	1 to: points size by: 3 do:[:i|
		p1 := points at: i.
		p2 := points at: i+1.
		p3 := points at: i+2.
		(p1 = p2 or:[p2 = p3]) ifTrue:[
			aBlock value: (LineSegment from: p1 to: p3).
		] ifFalse:[
			aBlock value: (Bezier2Segment from: p1 via: p2 to: p3).
		].
	].! !


!CompressedBoundaryShape methodsFor: 'morphing' stamp: 'ar 9/3/1999 17:19'!
morphFrom: srcShape to: dstShape at: ratio
	| scale unscale srcPoints dstPoints pt1 pt2 x y |
	scale := (ratio * 1024) asInteger.
	scale < 0 ifTrue:[scale := 0].
	scale > 1024 ifTrue:[scale := 1024].
	unscale := 1024 - scale.
	srcPoints := srcShape points.
	dstPoints := dstShape points.
	1 to: points size do:[:i|
		pt1 := srcPoints at: i.
		pt2 := dstPoints at: i.
		x := ((pt1 x * unscale) + (pt2 x * scale)) bitShift: -10.
		y := ((pt1 y * unscale) + (pt2 y * scale)) bitShift: -10.
		points at: i put: x@y].! !


!CompressedBoundaryShape methodsFor: 'private' stamp: 'ar 11/3/1998 18:03'!
setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList
	points := pointList.
	leftFills := leftFillList.
	rightFills := rightFillList.
	lineWidths := lineWidthList.
	lineFills := lineFillList.
	fillStyles := fillStyleList.! !

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

CompressedBoundaryShape class
	instanceVariableNames: ''!

!CompressedBoundaryShape class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 18:02'!
points: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList
	^self new setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList! !
Object subclass: #CompressedSoundData
	instanceVariableNames: 'channels soundClassName codecName loopEnd loopLength perceivedPitch samplingRate gain firstSample cachedSound'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!CompressedSoundData commentStamp: '<historical>' prior: 0!
Instances of this class hold the data resulting from compressing a sound.  Each carries a reference to the codec class that created it, so that it can reconstruct a sound similar to the original in response to the message asSound.

In order to facilitate integration with existing sounds, a CompressedSoundData instance can masquerade as a sound by caching a copy of its original sound and delegating the essential sound-playing protocol to that cached copy.  It should probably be made a subclass of AbstractSound to complete the illusion.!


!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:10'!
channels
	"Answer an array of ByteArrays containing the compressed sound data for each channel."

	^ channels
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
channels: anArray

	channels := anArray.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:34'!
codecName
	"Answer the name of the sound codec used to compress this sound. Typically, this is the name of a class that can be used to decode the sound, but it is possible that the codec has not yet been implemented or is not filed into this image."

	^ codecName
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
codecName: aStringOrSymbol

	codecName := aStringOrSymbol asSymbol.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'!
firstSample
	"Answer the firstSample of the original sound."

	^ firstSample
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:40'!
firstSample: anInteger

	firstSample := anInteger.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:55'!
gain
	"Answer the gain of the original sound."

	^ gain
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
gain: aNumber

	gain := aNumber.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:11'!
loopEnd
	"Answer index of the last sample of the loop, or nil if the original sound was not looped."

	^ loopEnd
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:40'!
loopEnd: anInteger

	loopEnd := anInteger.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:11'!
loopLength
	"Answer length of the loop, or nil if the original sound was not looped."

	^ loopLength
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
loopLength: anInteger

	loopLength := anInteger.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:39'!
perceivedPitch
	"Answer the perceived pitch of the original sound. By convention, unpitched sounds (like drum hits) are given an arbitrary pitch of 100.0."

	^ perceivedPitch
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:40'!
perceivedPitch: aNumber

	perceivedPitch := aNumber.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:13'!
samplingRate
	"Answer the samplingRate of the original sound."

	^ samplingRate
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
samplingRate: aNumber

	samplingRate := aNumber.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:46'!
soundClassName
	"Answer the class name of the uncompressed sound."

	^ soundClassName
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:40'!
soundClassName: aStringOrSymbol

	soundClassName := aStringOrSymbol asSymbol.
! !


!CompressedSoundData methodsFor: 'as yet unclassified' stamp: 'RAA 12/8/2000 09:50'!
compressWith: codecClass

	codecName == codecClass name asSymbol ifTrue: [^self].
	^self asSound compressWith: codecClass! !

!CompressedSoundData methodsFor: 'as yet unclassified' stamp: 'RAA 12/24/2000 08:53'!
compressWith: codecClass atRate: aSamplingRate

	(codecName == codecClass name asSymbol and: [samplingRate = aSamplingRate]) ifTrue: [^self].
	^self asSound compressWith: codecClass atRate: aSamplingRate! !

!CompressedSoundData methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:40'!
withEToySound: aByteArray samplingRate: anInteger

	soundClassName := #SampledSound.
	channels := {aByteArray}.
	codecName := #GSMCodec.
	loopEnd := nil.	"???"
	loopLength :=  nil.
	perceivedPitch := 100.0.
	samplingRate  := anInteger.
	gain  := 1.0.	"???"
	firstSample := 1.
	cachedSound  := nil.	"???"! !


!CompressedSoundData methodsFor: 'asSound' stamp: 'stephaneducasse 2/4/2006 20:41'!
asSound
	"Answer the result of decompressing the receiver."

	| codecClass |
	codecClass := Smalltalk at: codecName
		ifAbsent: [^ self error: 'The codec for decompressing this sound is not available'].
	^ (codecClass new decompressSound: self) reset
! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:49'!
doControl

	cachedSound doControl
! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:49'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol

	cachedSound mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset
	"This message is the cue to start behaving like a real sound in order to be played.
	We do this by caching a decompressed version of this sound.
	See also samplesRemaining."

	cachedSound == nil ifTrue: [cachedSound := self asSound].
	cachedSound reset
! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:44'!
samples

	^ self asSound samples! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'stephaneducasse 2/4/2006 20:40'!
samplesRemaining
	"This message is the cue that the cached sound may no longer be needed.
	We know it is done playing when samplesRemaining=0."

	| samplesRemaining |
	samplesRemaining := cachedSound samplesRemaining.
	samplesRemaining <= 0 ifTrue: [cachedSound := nil].
	^ samplesRemaining! !
ReadWriteStream subclass: #CompressedSourceStream
	instanceVariableNames: 'segmentFile segmentSize nSegments segmentTable segmentIndex dirty endOfFile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-System'!
!CompressedSourceStream commentStamp: 'di 11/3/2003 17:58' prior: 0!
I implement a file format that compresses segment by segment to allow incremental writing and browsing.  Note that the file can only be written at the end.

Structure:
segmentFile		The actual compressed file.
segmentSize		This is the quantum of compression.  The virtual file is sliced up
				into segments of this size.
nSegments		The maximum number of segments to which this file can be grown.
endOfFile		The user's endOfFile pointer.
segmentTable	When a file is open, this table holds the physical file positions
				of the compressed segments.
segmentIndex	Index of the most recently accessed segment.

Inherited from ReadWriteStream...
collection		The segment buffer, uncompressed
position			This is the position *local* to the current segment buffer
readLimit		ReadLimit for the current buffer
writeLimit		WriteLimit for the current buffer

Great care must be exercised to distinguish between the position relative to the segment buffer and the full file position (and, or course, the segment file position ;-).

The implementation defaults to a buffer size of 20k, and a max file size of 34MB (conveniently chosen to be greater than the current 33MB limit of source code pointers).  The format of the file is as follows:
	segmentSize		4 bytes
	nSegments		4 bytes
	endOfFile		4 bytes
	segmentTable	4 bytes * (nSegments+1)
	beginning of first compressed segment

It is possible to override the default allocation by sending the message #segmentSize:nSegments: immediately after opening a new file for writing, as follows:

	bigFile _ (CompressedSourceStream on: (FileStream newFileNamed: 'biggy.stc'))
			segmentSize: 50000 maxSize: 200000000

The difference between segment table entries reveals the size of each compressed segment.  When a file is being written, it may lack the final segment, but any flush, position:, or close will force a dirty segment to be written.!


!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/3/2003 00:41'!
atEnd

	position >= readLimit ifFalse: [^ false].  "more in segment"
	^ self position >= endOfFile  "more in file"! !

!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
contentsOfEntireFile
	| contents |
	self position: 0.
	contents := self next: self size.
	self close.
	^ contents! !

!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 19:50'!
flush
	dirty ifTrue:
		["Write buffer, compressed, to file, and also write the segment offset and eof"
		self writeSegment].! !

!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
next
	<primitive: 65>
	position >= readLimit
		ifTrue: [^ (self next: 1) at: 1]
		ifFalse: [^ collection at: (position := position + 1)]! !

!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
next: n
	| str |
	n <= (readLimit - position) ifTrue:
		["All characters are available in buffer"
		str := collection copyFrom: position + 1 to: position + n.
		position := position + n.
		^ str].

	"Read limit could be segment boundary or real end of file"
	(readLimit + self segmentOffset) = endOfFile ifTrue:
		["Real end of file -- just return what's available"
		^ self next: readLimit - position].

	"Read rest of segment.  Then (after positioning) read what remains"
	str := self next: readLimit - position.
	self position: self position.
	^ str , (self next: n - str size)
! !

!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 11:27'!
nextPut: char
	"Slow, but we don't often write, and then not a lot"
	self nextPutAll: char asString.
	^ char! !

!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
nextPutAll: str
	| n nInSeg |
	n := str size.
	n <= (writeLimit - position) ifTrue:
		["All characters fit in buffer"
		collection replaceFrom: position + 1 to: position + n with: str.
		dirty := true.
		position := position + n.
		readLimit := readLimit max: position.
		endOfFile := endOfFile max: self position.
		^ str].

	"Write what fits in segment.  Then (after positioning) write what remains"
	nInSeg := writeLimit - position.
	nInSeg = 0
		ifTrue: [self position: self position.
				self nextPutAll: str]
		ifFalse: [self nextPutAll: (str first: nInSeg).
				self position: self position.
				self nextPutAll: (str allButFirst: nInSeg)]
	
! !

!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 09:27'!
position

	^ position + self segmentOffset! !

!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
position: newPosition
	| compressedBuffer newSegmentIndex |
	newPosition > endOfFile ifTrue:
		[self error: 'Attempt to position beyond the end of file'].
	newSegmentIndex := (newPosition // segmentSize) + 1.
	newSegmentIndex ~= segmentIndex ifTrue:
		[self flush.
		segmentIndex := newSegmentIndex.
		newSegmentIndex > nSegments ifTrue:
			[self error: 'file size limit exceeded'].
		segmentFile position: (segmentTable at: segmentIndex).
		(segmentTable at: segmentIndex+1) = 0
			ifTrue:
			[newPosition ~= endOfFile ifTrue:
				[self error: 'Internal logic error'].
			collection size = segmentSize ifFalse:
				[self error: 'Internal logic error'].
			"just leave garbage beyond end of file"]
			ifFalse:
			[compressedBuffer := segmentFile next: ((segmentTable at: segmentIndex+1) - (segmentTable at: segmentIndex)).
			collection :=  (GZipReadStream on: compressedBuffer) upToEnd asString].
		readLimit := collection size min: endOfFile - self segmentOffset].
	position := newPosition \\ segmentSize.
	! !

!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 11:41'!
size
	^ endOfFile ifNil: [0]! !


!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/1/2003 22:36'!
binary
	self error: 'Compressed source files are ascii to the user (though binary underneath)'! !

!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/1/2003 22:36'!
close
	self flush.
	segmentFile close! !

!CompressedSourceStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:31'!
openOn: aFile
	"Open the receiver."
	segmentFile := aFile.
	segmentFile binary.
	segmentFile size > 0
	ifTrue:
		[self readHeaderInfo.  "If file exists, then read the parameters"]
	ifFalse:
		[self segmentSize: 20000 maxSize: 34000000.  "Otherwise write default values"]! !

!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 10:13'!
openReadOnly

	segmentFile openReadOnly! !

!CompressedSourceStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:31'!
readHeaderInfo
	| valid a b |
	segmentFile position: 0.
	segmentSize := segmentFile nextNumber: 4.
	nSegments := segmentFile nextNumber: 4.
	endOfFile := segmentFile nextNumber: 4.
	segmentFile size < (nSegments+1 + 3 * 4) ifTrue: "Check for reasonable segment info"
		[self error: 'This file is not in valid compressed source format'].
	segmentTable := (1 to: nSegments+1) collect: [:x | segmentFile nextNumber: 4].
	segmentTable first ~= self firstSegmentLoc ifTrue:
		[self error: 'This file is not in valid compressed source format'].
	valid := true.
	1 to: nSegments do:  "Check that segment offsets are ascending"
		[:i | a := segmentTable at: i.  b := segmentTable at: i+1.
		(a = 0 and: [b ~= 0]) ifTrue: [valid := false].
		(a ~= 0 and: [b ~= 0]) ifTrue: [b <= a ifTrue: [valid := false]]].
	valid ifFalse:
		[self error: 'This file is not in valid compressed source format'].
	dirty := false.
	self position: 0.! !

!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 10:09'!
readOnlyCopy

	^ self class on: segmentFile readOnlyCopy! !

!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/2/2003 23:07'!
test
	"FileDirectory default deleteFileNamed: 'test.stc'.
	(CompressedSourceStream on: (FileStream newFileNamed: 'test.stc')) fileOutChanges"

	"FileDirectory default deleteFileNamed: 'test2.stc'.
	((CompressedSourceStream on: (FileStream newFileNamed: 'test2.stc'))
		segmentSize: 100 nSegments: 1000) fileOutChanges"

	"FileDirectory default deleteFileNamed: 'test3.st'.
	(FileStream newFileNamed: 'test3.st') fileOutChanges"

	"(CompressedSourceStream on: (FileStream oldFileNamed: 'test.stc')) contentsOfEntireFile"
! !


!CompressedSourceStream methodsFor: 'private' stamp: 'di 11/20/2003 12:45'!
fileID  "Only needed for OSProcess stuff"
	^ segmentFile fileID
! !

!CompressedSourceStream methodsFor: 'private' stamp: 'di 11/2/2003 09:35'!
firstSegmentLoc
	"First segment follows 3 header words and segment table"
	^ (3 + nSegments+1) * 4! !

!CompressedSourceStream methodsFor: 'private' stamp: 'di 11/2/2003 09:24'!
segmentOffset

	^ segmentIndex - 1 * segmentSize! !

!CompressedSourceStream methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
segmentSize: segSize maxSize: maxSize
	"Note that this method can be called after the initial open, provided that no
	writing has yet taken place.  This is how to override the default segmentation."
	self size = 0 ifFalse: [self error: 'Cannot set parameters after the first write'].
	segmentFile position: 0.
	segmentFile nextNumber: 4 put: (segmentSize := segSize).
	segmentFile nextNumber: 4 put: (nSegments := maxSize // segSize + 2).
	segmentFile nextNumber: 4 put: (endOfFile := 0).
	segmentTable := Array new: nSegments+1 withAll: 0.
	segmentTable at: 1 put: self firstSegmentLoc.  "Loc of first segment, always."
	segmentTable do: [:i | segmentFile nextNumber: 4 put: i].
	segmentIndex := 1.
	collection := String new: segmentSize.
	writeLimit := segmentSize.
	readLimit := 0.
	position := 0.
	endOfFile := 0.
	self writeSegment.
! !

!CompressedSourceStream methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
writeSegment
	"The current segment must be the last in the file."
	| compressedSegment |
	segmentFile position: (segmentTable at: segmentIndex).
	compressedSegment := ByteArray streamContents:
		[:strm | (GZipWriteStream on: strm) nextPutAll: collection asByteArray; close].
	segmentFile nextPutAll: compressedSegment.
	segmentTable at: segmentIndex + 1 put: segmentFile position.

	segmentFile position: 2 * 4.
	segmentFile nextNumber: 4 put: endOfFile.
	segmentFile position: (segmentIndex + 3) * 4.
	segmentFile nextNumber: 4 put: (segmentTable at: segmentIndex + 1).
	dirty := false! !

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

CompressedSourceStream class
	instanceVariableNames: ''!

!CompressedSourceStream class methodsFor: 'as yet unclassified' stamp: 'di 11/1/2003 22:58'!
on: aFile
	^ self basicNew openOn: aFile! !
NetworkError subclass: #ConnectionClosed
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!ConnectionClosed commentStamp: 'mir 5/12/2003 18:12' prior: 0!
Signals a prematurely closed connection.
!

Object subclass: #ConnectionQueue
	instanceVariableNames: 'portNumber maxQueueLength connections accessSema socket process'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!ConnectionQueue commentStamp: '<historical>' prior: 0!
A ConnectionQueue listens on a given port number and collects a queue of client connections. In order to handle state changes quickly, a ConnectionQueue has its own process that: (a) tries to keep a socket listening on the port whenever the queue isn't already full of connections and (b) prunes stale connections out of the queue to make room for fresh ones.
!


!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 17:31'!
connectionCount
	"Return an estimate of the number of currently queued connections. This is only an estimate since a new connection could be made, or an existing one aborted, at any moment."

	| count |
	self pruneStaleConnections.
	accessSema critical: [count _ connections size].
	^ count
! !

!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/9/98 14:34'!
destroy
	"Terminate the listener process and destroy all sockets in my possesion."

	process ifNotNil: [
		process terminate.
		process _ nil].
	socket ifNotNil: [
		socket destroy.
		socket _ nil].
	connections do: [:s | s destroy].
	connections _ OrderedCollection new.
! !

!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 09:18'!
getConnectionOrNil
	"Return a connected socket, or nil if no connection has been established."

	| result |
	accessSema critical: [
		connections isEmpty
			ifTrue: [result _ nil]
			ifFalse: [
				result _ connections removeFirst.
				((result isValid) and: [result isConnected]) ifFalse: [  "stale connection"
					result destroy.
					result _ nil]]].
	^ result
! !

!ConnectionQueue methodsFor: 'public' stamp: 'RAA 7/15/2000 12:36'!
getConnectionOrNilLenient
	"Return a connected socket, or nil if no connection has been established."

	| result |
	accessSema critical: [
		connections isEmpty ifTrue: [
			result _ nil
		] ifFalse: [
			result _ connections removeFirst.
			(result isValid and: [result isConnected or: [result isOtherEndClosed]]) ifFalse: [
				"stale connection"
				result destroy.
				result _ nil
			]
		]
	].
	^ result
! !

!ConnectionQueue methodsFor: 'public' stamp: 'ls 9/26/1999 15:34'!
isValid
	^process notNil! !


!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 11:07'!
initPortNumber: anInteger queueLength: queueLength
	"Private!! Initialize the receiver to listen on the given port number. Up to queueLength connections will be queued."

	portNumber _ anInteger.
	maxQueueLength _ queueLength.
	connections _ OrderedCollection new.
	accessSema _ Semaphore forMutualExclusion.
	socket _ nil.
	process _ [self listenLoop] newProcess.
	process priority: Processor highIOPriority.
	process resume.
! !

!ConnectionQueue methodsFor: 'private' stamp: 'KLC 10/20/2005 11:24'!
listenLoop
	"Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port."
	"Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection."
	"Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms."


	| newConnection |

	socket := Socket newTCP.
	"We'll accept four simultanous connections at the same time"
	socket listenOn: portNumber backlogSize: 4.
	"If the listener is not valid then the we cannot use the
	BSD style accept() mechanism."
	socket isValid ifFalse: [^self oldStyleListenLoop].
	[true] whileTrue: [
		socket isValid ifFalse: [
			"socket has stopped listening for some reason"
			socket destroy.
			(Delay forMilliseconds: 10) wait.
			^self listenLoop ].
		[newConnection := socket waitForAcceptFor: 10]
			on: ConnectionTimedOut
			do: [:ex | newConnection := nil].
		(newConnection notNil and: [newConnection isConnected]) ifTrue: [
			accessSema critical: [connections addLast: newConnection.].
			newConnection := nil.
			self changed].
		self pruneStaleConnections]. ! !

!ConnectionQueue methodsFor: 'private' stamp: 'mir 5/15/2003 18:28'!
oldStyleListenLoop
	"Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port."
	"Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection."
	"Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms."

	[true] whileTrue: [
		((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [
			"try to create a new socket for listening"
			socket _ Socket createIfFail: [nil]].

		socket == nil
			ifTrue: [(Delay forMilliseconds: 100) wait]
			ifFalse: [
				socket isUnconnected ifTrue: [socket listenOn: portNumber].
				[socket waitForConnectionFor: 10]
					on: ConnectionTimedOut
					do: [:ex |
						socket isConnected
							ifTrue: [  "connection established"
								accessSema critical: [connections addLast: socket].
								socket _ nil]
							ifFalse: [
								socket isWaitingForConnection
									ifFalse: [socket destroy. socket _ nil]]]].  "broken socket; start over"
		self pruneStaleConnections].
! !

!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 17:30'!
pruneStaleConnections
	"Private!! The client may establish a connection and then disconnect while it is still in the connection queue. This method is called periodically to prune such sockets out of the connection queue and make room for fresh connections."

	| foundStaleConnection |
	accessSema critical: [
		foundStaleConnection _ false.
		connections do: [:s |
			s isUnconnected ifTrue: [
				s destroy.
				foundStaleConnection _ true]].
		foundStaleConnection ifTrue: [
			connections _ connections select: [:s | s isValid]]].
! !

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

ConnectionQueue class
	instanceVariableNames: ''!

!ConnectionQueue class methodsFor: 'instance creation' stamp: 'jm 3/9/98 14:09'!
portNumber: anInteger queueLength: queueLength

	^ self new initPortNumber: anInteger queueLength: queueLength
! !
NetworkError subclass: #ConnectionRefused
	instanceVariableNames: 'host port'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!ConnectionRefused commentStamp: 'mir 5/12/2003 18:14' prior: 0!
Signals that a connection to the specified host and port was refused.

	host		host which refused the connection
	port		prot to which the connection was refused
!


!ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'!
host
	^ host! !

!ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:39'!
host: addressOrHostName port: portNumber
	host _ addressOrHostName.
	port _ portNumber! !

!ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'!
port
	^ port! !

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

ConnectionRefused class
	instanceVariableNames: ''!

!ConnectionRefused class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:39'!
host: addressOrHostName port: portNumber
	^ self new host: addressOrHostName port: portNumber! !
NetworkError subclass: #ConnectionTimedOut
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!ConnectionTimedOut commentStamp: 'mir 5/12/2003 18:14' prior: 0!
Signals that a connection attempt timed out.
!

InstructionStream subclass: #ContextPart
	instanceVariableNames: 'stackp'
	classVariableNames: 'PrimitiveFailToken QuickStep'
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!ContextPart commentStamp: '<historical>' prior: 0!
To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself.
	
The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example,
	Transcript show: (ContextPart runSimulated: [3 factorial]) printString.!


!ContextPart methodsFor: 'accessing'!
client
	"Answer the client, that is, the object that sent the message that created this context."

	^sender receiver! !

!ContextPart methodsFor: 'accessing'!
home
	"Answer the context in which the receiver was defined."

	self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
method
	"Answer the method of this context."

	self subclassResponsibility! !

!ContextPart methodsFor: 'accessing' stamp: 'md 2/21/2006 13:52'!
methodNode
	self method isBlockMethod ifTrue: [^ self method blockNode].
	^ self method methodNode.! !

!ContextPart methodsFor: 'accessing' stamp: 'md 2/17/2006 09:50'!
methodNodeFormattedAndDecorated: decorate
	"Answer a method node made from pretty-printed (and colorized, if decorate is true) 
	 source text."

	^ self method methodNodeFormattedAndDecorated: decorate.! !

!ContextPart methodsFor: 'accessing'!
receiver
	"Answer the receiver of the message that created this context."

	self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
tempAt: index
	"Answer the value of the temporary variable whose index is the 
	argument, index."

	self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
tempAt: index put: value 
	"Store the argument, value, as the temporary variable whose index is the 
	argument, index."

	self subclassResponsibility! !


!ContextPart methodsFor: 'controlling'!
activateMethod: newMethod withArgs: args receiver: rcvr class: class 
	"Answer a ContextPart initialized with the arguments."

	^MethodContext 
		sender: self
		receiver: rcvr
		method: newMethod
		arguments: args! !

!ContextPart methodsFor: 'controlling' stamp: 'di 10/23/1999 17:03'!
blockCopy: numArgs 
	"Primitive. Distinguish a block of code from its enclosing method by 
	creating a new BlockContext for that block. The compiler inserts into all 
	methods that contain blocks the bytecodes to send the message 
	blockCopy:. Do not use blockCopy: in code that you write!! Only the 
	compiler can decide to send the message blockCopy:. Fail if numArgs is 
	not a SmallInteger. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 80>
	^ (BlockContext newForMethod: self home method)
		home: self home
		startpc: pc + 2
		nargs: numArgs! !

!ContextPart methodsFor: 'controlling'!
hasSender: context 
	"Answer whether the receiver is strictly above context on the stack."

	| s |
	self == context ifTrue: [^false].
	s _ sender.
	[s == nil]
		whileFalse: 
			[s == context ifTrue: [^true].
			s _ s sender].
	^false! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 3/25/2004 00:07'!
jump
	"Abandon thisContext and resume self instead (using the same current process).  You may want to save thisContext's sender before calling this so you can jump back to it.
	Self MUST BE a top context (ie. a suspended context or a abandoned context that was jumped out of).  A top context already has its return value on its stack (see Interpreter>>primitiveSuspend and other suspending primitives).
	thisContext's sender is converted to a top context (by pushing a nil return value on its stack) so it can be jump back to."

	| top |
	"Make abandoned context a top context (has return value (nil)) so it can be jumped back to"
	thisContext sender push: nil.

	"Pop self return value then return it to self (since we jump to self by returning to it)"
	stackp = 0 ifTrue: [self stepToSendOrReturn].
	stackp = 0 ifTrue: [self push: nil].  "must be quick return self/constant"
	top _ self pop.
	thisContext privSender: self.
	^ top! !

!ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:40'!
pop
	"Answer the top of the receiver's stack and remove the top of the stack."
	| val |
	val _ self at: stackp.
	self stackp: stackp - 1.
	^ val! !

!ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:39'!
push: val 
	"Push val on the receiver's stack."

	self stackp: stackp + 1.
	self at: stackp put: val! !

!ContextPart methodsFor: 'controlling' stamp: 'hmm 7/17/2001 20:57'!
quickSend: selector to: receiver with: arguments super: superFlag
	"Send the given selector with arguments in an environment which closely resembles the non-simulating environment, with an interjected unwind-protected block to catch nonlocal returns.
	Attention: don't get lost!!"
	| oldSender contextToReturnTo result lookupClass |
	contextToReturnTo _ self.
	lookupClass _ superFlag
					ifTrue: [(self method literalAt: self method numLiterals) value superclass]
					ifFalse: [receiver class].
	[oldSender _ thisContext sender swapSender: self.
	result _ receiver perform: selector withArguments: arguments inSuperclass: lookupClass.
	thisContext sender swapSender: oldSender] ifCurtailed: [
		contextToReturnTo _ thisContext sender receiver.	"The block context returning nonlocally"
		contextToReturnTo jump: -1.	"skip to front of return bytecode causing this unwind"
		contextToReturnTo nextByte = 16r7C ifTrue: [
			"If it was a returnTop, push the value to be returned.
			Otherwise the value is implicit in the bytecode"
			contextToReturnTo push: (thisContext sender tempAt: 1)].
		thisContext swapSender: thisContext home sender.	"Make this block return to the method's sender"
		contextToReturnTo].
	contextToReturnTo push: result.
	^contextToReturnTo! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32'!
restart
	"Unwind thisContext to self and resume from beginning.  Execute unwind blocks when unwinding.  ASSUMES self is a sender of thisContext"

	| ctxt unwindBlock |
	self isDead ifTrue: [self cannotReturn: nil to: self].
	self privRefresh.
	ctxt _ thisContext.
	[	ctxt _ ctxt findNextUnwindContextUpTo: self.
		ctxt isNil
	] whileFalse: [
		unwindBlock _ ctxt tempAt: 1.
		unwindBlock ifNotNil: [
			ctxt tempAt: 1 put: nil.
			thisContext terminateTo: ctxt.
			unwindBlock value].
	].
	thisContext terminateTo: self.
	self jump.
! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 6/27/2003 22:17'!
resume
	"Roll back thisContext to self and resume.  Execute unwind blocks when rolling back.  ASSUMES self is a sender of thisContext"

	self resume: nil! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32'!
resume: value
	"Unwind thisContext to self and resume with value as result of last send.  Execute unwind blocks when unwinding.  ASSUMES self is a sender of thisContext"

	| ctxt unwindBlock |
	self isDead ifTrue: [self cannotReturn: value to: self].
	ctxt _ thisContext.
	[	ctxt _ ctxt findNextUnwindContextUpTo: self.
		ctxt isNil
	] whileFalse: [
		unwindBlock _ ctxt tempAt: 1.
		unwindBlock ifNotNil: [
			ctxt tempAt: 1 put: nil.
			thisContext terminateTo: ctxt.
			unwindBlock value].
	].
	thisContext terminateTo: self.
	^ value
! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 1/21/2003 19:27'!
return
	"Unwind until my sender is on top"

	self return: self receiver! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:27'!
return: value
	"Unwind thisContext to self and return value to self's sender.  Execute any unwind blocks while unwinding.  ASSUMES self is a sender of thisContext"

	sender ifNil: [self cannotReturn: value to: sender].
	sender resume: value! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 15:30'!
return: value to: sendr 
	"Simulate the return of value to sendr."

	self releaseTo: sendr.
	sendr ifNil: [^ nil].
	^ sendr push: value! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:20'!
runUntilErrorOrReturnFrom: aSender 
	"ASSUMES aSender is a sender of self.  Execute self's stack until aSender returns or an unhandled exception is raised.  Return a pair containing the new top context and a possibly nil exception.  The exception is not nil if it was raised before aSender returned and it was not handled.  The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it."
	"Self is run by jumping directly to it (the active process abandons thisContext and executes self).  However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated.  We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised.  In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext."

	| error ctxt here topContext |
	here _ thisContext.

	"Insert ensure and exception handler contexts under aSender"
	error _ nil.
	ctxt _ aSender insertSender: (ContextPart
		contextOn: UnhandledError do: [:ex |
			error ifNil: [
				error _ ex exception.
				topContext _ thisContext.
				ex resumeUnchecked: here jump]
			ifNotNil: [ex pass]
		]).
	ctxt _ ctxt insertSender: (ContextPart
		contextEnsure: [error ifNil: [
				topContext _ thisContext.
				here jump]
		]).
	self jump.  "Control jumps to self"

	"Control resumes here once above ensure block or exception handler is executed"
	^ error ifNil: [
		"No error was raised, remove ensure context by stepping until popped"
		[ctxt isDead] whileFalse: [topContext _ topContext stepToCallee].
		{topContext. nil}

	] ifNotNil: [
		"Error was raised, remove inserted above contexts then return signaler context"
		aSender terminateTo: ctxt sender.  "remove above ensure and handler contexts"
		{topContext. error}
	].
! !

!ContextPart methodsFor: 'controlling' stamp: 'di 11/26/1999 19:34'!
send: selector to: rcvr with: args super: superFlag 
	"Simulate the action of sending a message with selector, selector, and 
	arguments, args, to receiver. The argument, superFlag, tells whether the 
	receiver of the message was specified with 'super' in the source method."

	| class meth val |
	class _ superFlag
			ifTrue: [(self method literalAt: self method numLiterals) value superclass]
			ifFalse: [rcvr class].
	meth _ class lookupSelector: selector.
	meth == nil
		ifTrue: [^ self send: #doesNotUnderstand:
					to: rcvr
					with: (Array with: (Message selector: selector arguments: args))
					super: superFlag]
		ifFalse: [val _ self tryPrimitiveFor: meth
						receiver: rcvr
						args: args.
				val == PrimitiveFailToken ifFalse: [^ val].
				(selector == #doesNotUnderstand: and: [class == ProtoObject]) ifTrue:
					[^ self error: 'Simulated message ' , (args at: 1) selector
									, ' not understood'].
				^ self activateMethod: meth
					withArgs: args
					receiver: rcvr
					class: class]! !

!ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 00:56'!
terminate
	"Make myself unresumable."

	sender _ nil.
	pc _ nil.
! !

!ContextPart methodsFor: 'controlling' stamp: 'ar 3/6/2001 14:26'!
terminateTo: previousContext
	"Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender."

	| currentContext sendingContext |
	<primitive: 196>
	(self hasSender: previousContext) ifTrue: [
		currentContext _ sender.
		[currentContext == previousContext] whileFalse: [
			sendingContext _ currentContext sender.
			currentContext terminate.
			currentContext _ sendingContext]].
	sender _ previousContext! !

!ContextPart methodsFor: 'controlling'!
top
	"Answer the top of the receiver's stack."

	^self at: stackp! !


!ContextPart methodsFor: 'debugger access' stamp: 'ajh 9/25/2001 00:12'!
contextStack 
	"Answer an Array of the contexts on the receiver's sender chain."

	^self stackOfSize: 100000! !

!ContextPart methodsFor: 'debugger access'!
depthBelow: aContext
	"Answer how many calls there are between this and aContext."

	| this depth |
	this _ self.
	depth _ 0.
	[this == aContext or: [this == nil]]
		whileFalse:
			[this _ this sender.
			depth _ depth + 1].
	^depth! !

!ContextPart methodsFor: 'debugger access' stamp: 'nk 7/29/2004 10:09'!
errorReportOn: strm
	"Write a detailed error report on the stack (above me) on a stream.  For both the error file, and emailing a bug report.  Suppress any errors while getting printStrings.  Limit the length."

	| cnt aContext startPos |
 	strm print: Date today; space; print: Time now; cr.
	strm cr.
	strm nextPutAll: 'VM: ';
		nextPutAll:  SmalltalkImage current platformName asString;
		nextPutAll: ' - ';
		nextPutAll: SmalltalkImage current asString;
		cr.
	strm nextPutAll: 'Image: ';
		nextPutAll:  SystemVersion current version asString;
		nextPutAll: ' [';
		nextPutAll: SmalltalkImage current lastUpdateString asString;
		nextPutAll: ']';
		cr.
	strm cr.
	SecurityManager default printStateOn: strm.
	
	"Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack."
	cnt _ 0.  startPos _ strm position.
	aContext _ self.
	[aContext notNil and: [(cnt _ cnt + 1) < 5]] whileTrue:
		[aContext printDetails: strm.	"variable values"
		strm cr.
		aContext _ aContext sender].

	strm cr; nextPutAll: '--- The full stack ---'; cr.
	aContext _ self.
	cnt _ 0.
	[aContext == nil] whileFalse:
		[cnt _ cnt + 1.
		cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr].
		strm print: aContext; cr.  "just class>>selector"	

		strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'.
			^ self]. 	"exit early"
		cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'.  ^ self].
		aContext _ aContext sender].
! !

!ContextPart methodsFor: 'debugger access' stamp: 'RAA 5/16/2000 12:14'!
longStack
	"Answer a String showing the top 100 contexts on my sender chain."

	^ String streamContents:
		[:strm |
		(self stackOfSize: 100)
			do: [:item | strm print: item; cr]]! !

!ContextPart methodsFor: 'debugger access' stamp: 'md 2/17/2006 18:41'!
methodClass 
	"Answer the class in which the receiver's method was found."
	
	^self method methodClass ifNil:[self receiver class].! !

!ContextPart methodsFor: 'debugger access'!
pc
	"Answer the index of the next bytecode to be executed."

	^pc! !

!ContextPart methodsFor: 'debugger access'!
release
	"Remove information from the receiver and all of the contexts on its 
	sender chain in order to break circularities."

	self releaseTo: nil! !

!ContextPart methodsFor: 'debugger access'!
releaseTo: caller 
	"Remove information from the receiver and the contexts on its sender 
	chain up to caller in order to break circularities."

	| c s |
	c _ self.
	[c == nil or: [c == caller]]
		whileFalse: 
			[s _ c sender.
			c singleRelease.
			c _ s]! !

!ContextPart methodsFor: 'debugger access' stamp: 'md 2/17/2006 18:47'!
selector
	"Answer the selector of the method that created the receiver."

	^self method selector ifNil: [self method defaultSelector].! !

!ContextPart methodsFor: 'debugger access'!
sender
	"Answer the context that sent the message that created the receiver."

	^sender! !

!ContextPart methodsFor: 'debugger access' stamp: 'di 8/31/1999 09:42'!
shortStack
	"Answer a String showing the top ten contexts on my sender chain."

	^ String streamContents:
		[:strm |
		(self stackOfSize: 10)
			do: [:item | strm print: item; cr]]! !

!ContextPart methodsFor: 'debugger access' stamp: 'ajh 1/24/2003 00:03'!
singleRelease
	"Remove information from the receiver in order to break circularities."

	stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]].
	sender _ nil.
	pc _ nil.
! !

!ContextPart methodsFor: 'debugger access' stamp: 'md 2/22/2006 16:58'!
sourceCode
	^self method getSource.
	
	"Note: The above is a bit safer than
		^ methodClass sourceCodeAt: selector
	which may fail if the receiver's method has been changed in
	the debugger (e.g., the method is no longer in the methodDict
	and thus the above selector is something like #Doit:with:with:with:)
	but the source code is still available."! !

!ContextPart methodsFor: 'debugger access'!
stack 
	"Answer an Array of the contexts on the receiver's sender chain."

	^self stackOfSize: 9999! !

!ContextPart methodsFor: 'debugger access' stamp: 'tfei 3/20/2000 00:51'!
stackOfSize: limit 
	"Answer an OrderedCollection of the top 'limit' contexts
		on the receiver's sender chain."

	| a stack cachedStackTop newLimit |
	stack _ OrderedCollection new.
	stack addLast: (a _ self).
	[(a _ a sender) ~~ nil and: [stack size < limit]]
		whileTrue:
			[a hideFromDebugger ifFalse: [stack addLast: a].
			a cachesStack ifTrue: [cachedStackTop := a cachedStackTop]].
	^cachedStackTop == nil 
		ifTrue: [stack]
		ifFalse:
			[newLimit := limit - stack size.
			newLimit > 0
				ifTrue: [stack addAllLast: (cachedStackTop stackOfSize: newLimit); yourself]
				ifFalse: [stack]]! !

!ContextPart methodsFor: 'debugger access'!
swapSender: coroutine 
	"Replace the receiver's sender with coroutine and answer the receiver's 
	previous sender. For use in coroutining."

	| oldSender |
	oldSender _ sender.
	sender _ coroutine.
	^oldSender! !

!ContextPart methodsFor: 'debugger access' stamp: 'md 2/20/2006 20:54'!
tempNames
	"Answer an OrderedCollection of the names of the receiver's temporary 
	variables, which are strings."

	"unused temps at end are not included in method. On the other hand, extra temps such as to:do: loop limit are added to method"
	| tempNames n |
	tempNames _ self methodNode tempNames.
	n _ self method numTemps.
	tempNames size = n ifTrue: [^ tempNames].
	tempNames size > n ifTrue: [^ tempNames first: n].
	tempNames size + 1 to: n do: [:i |
		tempNames _ tempNames copyWith: 't' , i printString].
	^ tempNames! !

!ContextPart methodsFor: 'debugger access'!
tempsAndValues
	"Return a string of the temporary variabls and their current values"
	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self tempNames
		doWithIndex: [:title :index |
			aStream nextPutAll: title; nextPut: $:; space; tab.
			(self tempAt: index) printOn: aStream.
			aStream cr].
	^aStream contents! !

!ContextPart methodsFor: 'debugger access' stamp: 'tk 10/19/2001 10:20'!
tempsAndValuesLimitedTo: sizeLimit indent: indent
	"Return a string of the temporary variabls and their current values"

	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self tempNames
		doWithIndex: [:title :index |
			indent timesRepeat: [aStream tab].
			aStream nextPutAll: title; nextPut: $:; space; tab.
			aStream nextPutAll: 
				((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)).
			aStream cr].
	^aStream contents! !


!ContextPart methodsFor: 'instruction decoding'!
doDup
	"Simulate the action of a 'duplicate top of stack' bytecode."

	self push: self top! !

!ContextPart methodsFor: 'instruction decoding'!
doPop
	"Simulate the action of a 'remove top of stack' bytecode."

	self pop! !

!ContextPart methodsFor: 'instruction decoding'!
jump: distance 
	"Simulate the action of a 'unconditional jump' bytecode whose offset is 
	the argument, distance."

	pc _ pc + distance! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 7/6/2003 20:38'!
jump: distance if: condition 
	"Simulate the action of a 'conditional jump' bytecode whose offset is the 
	argument, distance, and whose condition is the argument, condition."

	| bool |
	bool _ self pop.
	(bool == true or: [bool == false]) ifFalse: [
		^self
			send: #mustBeBooleanIn:
			to: bool
			with: {self}
			super: false].
	(bool eqv: condition) ifTrue: [self jump: distance]! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35'!
methodReturnConstant: value 
	"Simulate the action of a 'return constant' bytecode whose value is the 
	argument, value. This corresponds to a source expression like '^0'."

	^ self return: value from: self home! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:34'!
methodReturnReceiver
	"Simulate the action of a 'return receiver' bytecode. This corresponds to 
	the source expression '^self'."

	^ self return: self receiver from: self home! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:34'!
methodReturnTop
	"Simulate the action of a 'return top of stack' bytecode. This corresponds 
	to source expressions like '^something'."

	^ self return: self pop from: self home! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoLiteralVariable: value 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into a literal variable of my method."

	value value: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into an instance variable of my receiver."

	self receiver instVarAt: offset + 1 put: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into one of my temporary variables."

	self home at: offset + 1 put: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
pushActiveContext
	"Simulate the action of bytecode that pushes the the active context on the 
	top of its own stack."

	self push: self! !

!ContextPart methodsFor: 'instruction decoding'!
pushConstant: value 
	"Simulate the action of bytecode that pushes the constant, value, on the 
	top of the stack."

	self push: value! !

!ContextPart methodsFor: 'instruction decoding'!
pushLiteralVariable: value 
	"Simulate the action of bytecode that pushes the contents of the literal 
	variable whose index is the argument, index, on the top of the stack."

	self push: value value! !

!ContextPart methodsFor: 'instruction decoding'!
pushReceiver
	"Simulate the action of bytecode that pushes the active context's receiver 
	on the top of the stack."

	self push: self receiver! !

!ContextPart methodsFor: 'instruction decoding'!
pushReceiverVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the receiver's 
	instance variable whose index is the argument, index, on the top of the 
	stack."

	self push: (self receiver instVarAt: offset + 1)! !

!ContextPart methodsFor: 'instruction decoding'!
pushTemporaryVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the 
	temporary variable whose index is the argument, index, on the top of 
	the stack."

	self push: (self home at: offset + 1)! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 3/5/2004 03:44'!
return: value from: aSender 
	"For simulation.  Roll back self to aSender and return value from it.  Execute any unwind blocks on the way.  ASSUMES aSender is a sender of self"

	| newTop ctxt |
	aSender isDead ifTrue: [
		^ self send: #cannotReturn: to: self with: {value} super: false].
	newTop _ aSender sender.
	ctxt _ self findNextUnwindContextUpTo: newTop.
	ctxt ifNotNil: [
		^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false].
	self releaseTo: newTop.
	newTop ifNotNil: [newTop push: value].
	^ newTop
! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'hmm 7/17/2001 20:52'!
send: selector super: superFlag numArgs: numArgs
	"Simulate the action of bytecodes that send a message with selector, 
	selector. The argument, superFlag, tells whether the receiver of the 
	message was specified with 'super' in the source method. The arguments 
	of the message are found in the top numArgs locations on the stack and 
	the receiver just below them."

	| receiver arguments answer |
	arguments _ Array new: numArgs.
	numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop].
	receiver _ self pop.
	selector == #doPrimitive:method:receiver:args:
		ifTrue: [answer _ receiver 
					doPrimitive: (arguments at: 1)
					method: (arguments at: 2)
					receiver: (arguments at: 3)
					args: (arguments at: 4).
				self push: answer.
				^self].
	QuickStep == self ifTrue: [
		QuickStep _ nil.
		^self quickSend: selector to: receiver with: arguments super: superFlag].
	^self send: selector to: receiver with: arguments super: superFlag! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoLiteralVariable: value 
	"Simulate the action of bytecode that stores the top of the stack into a 
	literal variable of my method."

	value value: self top! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoReceiverVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into an 
	instance variable of my receiver."

	self receiver instVarAt: offset + 1 put: self top! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into one 
	of my temporary variables."

	self home at: offset + 1 put: self top! !


!ContextPart methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 22:54'!
storeDataOn: aDataStream
	"Contexts are not allowed go to out in DataStreams.  They must be included inside an ImageSegment."

	aDataStream insideASegment ifTrue: [^ super storeDataOn: aDataStream].

	self error: 'This Context was not included in the ImageSegment'.
		"or perhaps ImageSegments were not used at all"
	^ nil! !


!ContextPart methodsFor: 'printing' stamp: 'tk 10/19/2001 11:24'!
printDetails: strm
	"Put my class>>selector and arguments and temporaries on the stream.  Protect against errors during printing."

	| str |
	self printOn: strm.  

	strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr.
	str _ [self tempsAndValuesLimitedTo: 80 indent: 2] ifError: [:err :rcvr | 
						'<<error during printing>>'].
	strm nextPutAll: str.
	strm peekLast == Character cr ifFalse: [strm cr].! !

!ContextPart methodsFor: 'printing' stamp: 'md 2/17/2006 15:41'!
printOn: aStream 
	| selector class mclass |
	self method == nil ifTrue: [^ super printOn: aStream].
	class := self receiver class.
	mclass := self methodClass.
	selector := self selector ifNil:[self method defaultSelector].
	aStream nextPutAll: class name.
	mclass == class 
		ifFalse: 
			[aStream nextPut: $(.
			aStream nextPutAll: mclass name.
			aStream nextPut: $)].
	aStream nextPutAll: '>>'.
	aStream nextPutAll: selector.
	selector = #doesNotUnderstand: ifTrue: [
		aStream space.
		(self tempAt: 1) selector printOn: aStream.
	].
! !


!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 12:35'!
blockHome

	^ self! !

!ContextPart methodsFor: 'query' stamp: 'ajh 7/21/2003 09:59'!
bottomContext
	"Return the last context (the first context invoked) in my sender chain"

	^ self findContextSuchThat: [:c | c sender isNil]! !

!ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 18:35'!
copyStack

	^ self copyTo: nil! !

!ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 21:20'!
copyTo: aContext
	"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.  It is best to use BlockClosures instead.  They only hold a ContextTag, which will work for all copies of the original home context."

	^ self copyTo: aContext blocks: IdentityDictionary new! !

!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:12'!
findContextSuchThat: testBlock
	"Search self and my sender chain for first one that satisfies testBlock.  Return nil if none satisfy"

	| ctxt |
	ctxt _ self.
	[ctxt isNil] whileFalse: [
		(testBlock value: ctxt) ifTrue: [^ ctxt].
		ctxt _ ctxt sender.
	].
	^ nil! !

!ContextPart methodsFor: 'query' stamp: 'md 1/20/2006 16:15'!
findSecondToOldestSimilarSender
	"Search the stack for the second-to-oldest occurance of self's method.  Very useful for an infinite recursion.  Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning."

	| sec ctxt bot |
	sec _ self.
	ctxt _ self.
	[	bot _ ctxt findSimilarSender.
		bot isNil
	] whileFalse: [
		sec _ ctxt.
		ctxt _ bot.
	].
	^ sec
! !

!ContextPart methodsFor: 'query' stamp: 'md 1/20/2006 16:14'!
findSimilarSender
	"Return the closest sender with the same method, return nil if none found"

	| meth |
	meth _ self method.
	^ self sender findContextSuchThat: [:c | c method == meth]! !

!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 19:42'!
hasContext: aContext 
	"Answer whether aContext is me or one of my senders"

	^ (self findContextSuchThat: [:c | c == aContext]) notNil! !

!ContextPart methodsFor: 'query' stamp: 'md 1/20/2006 16:14'!
isClosureContext

	^ false! !

!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:04'!
isDead
	"Has self finished"

	^ pc isNil! !

!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 22:28'!
secondFromBottom
	"Return the second from bottom of my sender chain"

	self sender ifNil: [^ nil].
	^ self findContextSuchThat: [:c | c sender sender isNil]! !


!ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:43'!
completeCallee: aContext
	"Simulate the execution of bytecodes until a return to the receiver."
	| ctxt current ctxt1 |
	ctxt _ aContext.
	[ctxt == current or: [ctxt hasSender: self]]
		whileTrue: 
			[current _ ctxt.
			ctxt1 _ ctxt quickStep.
			ctxt1 ifNil: [self halt].
			ctxt _ ctxt1].
	^self stepToSendOrReturn! !

!ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/15/2001 20:58'!
quickStep
	"If the next instruction is a send, just perform it.
	Otherwise, do a normal step."

	self willReallySend ifTrue: [QuickStep _ self].
	^self step! !

!ContextPart methodsFor: 'system simulation' stamp: 'ajh 4/15/2003 10:01'!
runSimulated: aBlock contextAtEachStep: block2
	"Simulate the execution of the argument, aBlock, until it ends. aBlock 
	MUST NOT contain an '^'. Evaluate block2 with the current context 
	prior to each instruction executed. Answer the simulated value of aBlock."

	| current |
	(aBlock isBlock and: [aBlock hasMethodReturn])
		ifTrue: [self error: 'simulation of blocks with ^ can run loose'].
	current _ aBlock asContext.
	current privSender: self.
	[current == self]
		whileFalse:
			[block2 value: current.
			current _ current step].
	^ self pop! !

!ContextPart methodsFor: 'system simulation'!
step
	"Simulate the execution of the receiver's next bytecode. Answer the 
	context that would be the active context after this bytecode."

	^self interpretNextInstructionFor: self! !

!ContextPart methodsFor: 'system simulation' stamp: 'ajh 1/24/2003 22:54'!
stepToCallee
	"Step to callee or sender"

	| ctxt |
	ctxt _ self.
	[(ctxt _ ctxt step) == self] whileTrue.
	^ ctxt! !

!ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:48'!
stepToSendOrReturn
	"Simulate the execution of bytecodes until either sending a message or 
	returning a value to the receiver (that is, until switching contexts)."

	| ctxt |
	[self willReallySend | self willReturn | self willStore]
		whileFalse: [
			ctxt _ self step.
			ctxt == self ifFalse: [self halt. 
				"Caused by mustBeBoolean handling"
				^ctxt]]! !


!ContextPart methodsFor: 'private' stamp: 'ajh 5/20/2004 16:27'!
activateReturn: aContext value: value
	"Activate 'aContext return: value' in place of self, so execution will return to aContext's sender"

	^ self
		activateMethod: ContextPart theReturnMethod
		withArgs: {value}
		receiver: aContext
		class: aContext class! !

!ContextPart methodsFor: 'private' stamp: 'ajh 6/29/2003 15:32'!
cannotReturn: result to: homeContext
	"The receiver tried to return result to homeContext that no longer exists."

	^ BlockCannotReturn new
		result: result;
		deadHome: homeContext;
		signal! !

!ContextPart 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 ifPresent: [:blocks | blocks do: [:b | b privHome: copy]].
	self sender ifNotNil: [
		copy privSender: (self sender copyTo: aContext blocks: dict)].
	^ copy! !

!ContextPart methodsFor: 'private' stamp: 'ajh 1/24/2003 00:50'!
cut: aContext
	"Cut aContext and its senders from my sender chain"

	| ctxt callee |
	ctxt _ self.
	[ctxt == aContext] whileFalse: [
		callee _ ctxt.
		ctxt _ ctxt sender.
		ctxt ifNil: [aContext ifNotNil: [self error: 'aContext not a sender']].
	].
	callee privSender: nil.
! !

!ContextPart methodsFor: 'private' stamp: 'md 2/20/2006 20:59'!
doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments 
	"Simulate a primitive method whose index is primitiveIndex.  The
	simulated receiver and arguments are given as arguments to this message."

	| value |
	<primitive: 19> "Simulation guard"
	"If successful, push result and return resuming context,
		else ^ PrimitiveFailToken"
	(primitiveIndex = 19) ifTrue:[
		ToolSet 
			debugContext: self
			label:'Code simulation error'
			contents: nil].

	(primitiveIndex = 80 and: [receiver isKindOf: ContextPart])
		ifTrue: [^self push: ((BlockContext newForMethod: receiver home method)
						home: receiver home
						startpc: pc + 2
						nargs: (arguments at: 1))].
	(primitiveIndex = 81 and: [receiver isMemberOf: BlockContext])
		ifTrue: [^receiver pushArgs: arguments from: self].
	primitiveIndex = 83 "afr 9/11/1998 19:50"
		ifTrue: [^ self send: arguments first to: receiver
					with: arguments allButFirst
					super: false].
	primitiveIndex = 84 "afr 9/11/1998 19:50"
		ifTrue: [^ self send: arguments first to: receiver
					with: (arguments at: 2)
					super: false].
	primitiveIndex = 186 ifTrue: [ "closure value"
		| m |
		m _ receiver method.
		arguments size = m numArgs ifFalse: [^ PrimitiveFailToken].
		^ self activateMethod: m
			withArgs: arguments
			receiver: receiver
			class: receiver class].
	primitiveIndex = 187 ifTrue: [ "closure valueWithArguments:"
		| m args |
		m _ receiver method.
		args _ arguments first.
		args size = m numArgs ifFalse: [^ PrimitiveFailToken].
		^ self activateMethod: m
			withArgs: args
			receiver: receiver
			class: receiver class].
	primitiveIndex = 188 ifTrue: [ "object withArgs:executeMethod:"
		| m args |
		args _ arguments first.
		m _ arguments second.
		args size = m numArgs ifFalse: [^ PrimitiveFailToken].
		^ self activateMethod: m
			withArgs: args
			receiver: receiver
			class: receiver class].
	arguments size > 6 ifTrue: [^ PrimitiveFailToken].
	primitiveIndex = 117 
		ifTrue:[value _ self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
		ifFalse:[value _ receiver tryPrimitive: primitiveIndex withArgs: arguments].
	value == PrimitiveFailToken
		ifTrue: [^ PrimitiveFailToken]
		ifFalse: [^ self push: value]! !

!ContextPart methodsFor: 'private' stamp: 'ajh 7/21/2003 09:59'!
insertSender: aContext
	"Insert aContext and its sender chain between me and my sender.  Return new callee of my original sender."

	| ctxt |
	ctxt _ aContext bottomContext.
	ctxt privSender: self sender.
	self privSender: aContext.
	^ ctxt! !

!ContextPart methodsFor: 'private' stamp: 'ajh 1/23/2003 22:35'!
privSender: aContext 

	sender _ aContext! !

!ContextPart methodsFor: 'private' stamp: 'di 1/11/1999 10:12'!
push: numObjects fromIndexable: anIndexableCollection
	"Push the elements of anIndexableCollection onto the receiver's stack.
	 Do not call directly.  Called indirectly by {1. 2. 3} constructs."

	1 to: numObjects do:
		[:i | self push: (anIndexableCollection at: i)]! !

!ContextPart methodsFor: 'private'!
stackPtr  "For use only by the SystemTracer"
	^ stackp! !

!ContextPart methodsFor: 'private' stamp: 'di 10/23/1999 17:31'!
stackp: newStackp
	"Storing into the stack pointer is a potentially dangerous thing.
	This primitive stores nil into any cells that become accessible as a result,
	and it performs the entire operation atomically."
	"Once this primitive is implemented, failure code should cause an error"

	<primitive: 76>
	self error: 'stackp store failure'.
"
	stackp == nil ifTrue: [stackp _ 0].
	newStackp > stackp  'effectively checks that it is a number'
		ifTrue: [oldStackp _ stackp.
				stackp _ newStackp.
				'Nil any newly accessible cells'
				oldStackp + 1 to: stackp do: [:i | self at: i put: nil]]
		ifFalse: [stackp _ newStackp]
"! !

!ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:41'!
tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
	"Hack. Attempt to execute the named primitive from the given compiled method"
	| selector theMethod spec |
	arguments size > 8 ifTrue:[^PrimitiveFailToken].
	selector _ #(
		tryNamedPrimitive 
		tryNamedPrimitive: 
		tryNamedPrimitive:with: 
		tryNamedPrimitive:with:with: 
		tryNamedPrimitive:with:with:with:
		tryNamedPrimitive:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1.
	theMethod _ aReceiver class lookupSelector: selector.
	theMethod == nil ifTrue:[^PrimitiveFailToken].
	spec _ theMethod literalAt: 1.
	spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1.
	^aReceiver perform: selector withArguments: arguments! !

!ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:45'!
tryPrimitiveFor: method receiver: receiver args: arguments 
	"If this method has a primitive index, then run the primitive and return its result.
	Otherwise (and also if the primitive fails) return PrimitiveFailToken,
	as an indication that the method should be activated and run as bytecodes."
	| primIndex |
	(primIndex _ method primitive) = 0 ifTrue: [^ PrimitiveFailToken].
	^ self doPrimitive: primIndex method: method receiver: receiver args: arguments! !


!ContextPart methodsFor: 'private-debugger' stamp: 'tfei 3/19/2000 23:24'!
cachesStack

	^false! !


!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 01:30'!
canHandleSignal: exception
	"Sent to handler (on:do:) contexts only.  If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context.  If none left, return false (see nil>>canHandleSignal:)"

	^ (((self tempAt: 1) handles: exception) and: [self tempAt: 3])
		or: [self nextHandlerContext canHandleSignal: exception].
! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 19:27'!
findNextHandlerContextStarting
	"Return the next handler marked context, returning nil if there is none.  Search starts with self and proceeds up to nil."

	| ctx |
	<primitive: 197>
	ctx _ self.
		[ctx isHandlerContext ifTrue:[^ctx].
		(ctx _ ctx sender) == nil ] whileFalse.
	^nil! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/23/2000 16:37'!
findNextUnwindContextUpTo: aContext
	"Return the next unwind marked above the receiver, returning nil if there is none.  Search proceeds up to but not including aContext."

	| ctx |
	<primitive: 195>
	ctx _ self.
		[(ctx _ ctx sender) == nil or: [ctx == aContext]] whileFalse:
		[ ctx isUnwindContext ifTrue: [^ctx]].
	^nil! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 6/27/2003 20:47'!
handleSignal: exception
	"Sent to handler (on:do:) contexts only.  If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context.  If none left, execute exception's defaultAction (see nil>>handleSignal:)."

	| val |
	(((self tempAt: 1) handles: exception) and: [self tempAt: 3]) ifFalse: [
		^ self nextHandlerContext handleSignal: exception].

	exception privHandlerContext: self contextTag.
	self tempAt: 3 put: false.  "disable self while executing handle block"
	val _ [(self tempAt: 2) valueWithPossibleArgs: {exception}]
		ensure: [self tempAt: 3 put: true].
	self return: val.  "return from self if not otherwise directed in handle block"
! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 21:29'!
isHandlerContext
	^false! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 15:45'!
isUnwindContext

	^false! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 00:20'!
nextHandlerContext

	^ self sender findNextHandlerContextStarting! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 1/21/2003 17:59'!
unwindTo: aContext

	| ctx unwindBlock |
	ctx := self.
	[(ctx _ ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [
		unwindBlock := ctx tempAt: 1.
		unwindBlock == nil ifFalse: [
			ctx tempAt: 1 put: nil.
			unwindBlock value]
	].
! !


!ContextPart methodsFor: '*39Deprecated' stamp: 'md 2/17/2006 09:35'!
mclass 
	"Answer the class in which the receiver's method was found."
	self deprecated: 'use #methodClass'.
	^ self methodClass! !

!ContextPart methodsFor: '*39Deprecated' stamp: 'md 2/17/2006 12:04'!
methodSelector
	"Answer the selector of the method that created the receiver."
	self deprecated: 'use #selector'.

	^self selector.! !

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

ContextPart class
	instanceVariableNames: ''!

!ContextPart class methodsFor: 'examples'!
tallyInstructions: aBlock
	"This method uses the simulator to count the number of occurrences of
	each of the Smalltalk instructions executed during evaluation of aBlock.
	Results appear in order of the byteCode set."
	| tallies |
	tallies _ Bag new.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current | tallies add: current nextByte].
	^tallies sortedElements

	"ContextPart tallyInstructions: [3.14159 printString]"! !

!ContextPart class methodsFor: 'examples'!
tallyMethods: aBlock
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. Results are given in order of decreasing counts."
	| prev tallies |
	tallies _ Bag new.
	prev _ aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: "call or return"
				[prev sender == nil ifFalse: "call only"
					[tallies add: current printString].
				prev _ current]].
	^tallies sortedCounts

	"ContextPart tallyMethods: [3.14159 printString]"! !

!ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:03'!
trace: aBlock		"ContextPart trace: [3 factorial]"
	"This method uses the simulator to print calls and returned values in the Transcript."

	Transcript clear.
	^ self trace: aBlock on: Transcript! !

!ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:03'!
trace: aBlock on: aStream		"ContextPart trace: [3 factorial]"
	"This method uses the simulator to print calls to a file."
	| prev |
	prev _ aBlock.
	^ thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			Sensor anyButtonPressed ifTrue: [^ nil].
			current == prev
				ifFalse:
					[prev sender ifNil:
						[aStream space; nextPut: $^.
						self carefullyPrint: current top on: aStream].
					aStream cr.
					(current depthBelow: aBlock) timesRepeat: [aStream space].
					self carefullyPrint: current receiver on: aStream.
					aStream space; nextPutAll: current selector; flush.
					prev _ current]]! !

!ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:05'!
trace: aBlock onFileNamed: fileName		"ContextPart trace: [3 factorial] onFileNamed: 'trace'"
	"This method uses the simulator to print calls to a file."

	| aStream |
	^ [aStream _ FileStream fileNamed: fileName.
		self trace: aBlock on: aStream] ensure: [aStream close]! !


!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'!
basicNew: size

	self error: 'Contexts must only be created with newForMethod:'! !

!ContextPart class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 00:30'!
initializedInstance
	^ nil! !

!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'!
new

	self error: 'Contexts must only be created with newForMethod:'! !

!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'!
new: size

	self error: 'Contexts must only be created with newForMethod:'! !

!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:55'!
newForMethod: aMethod
	"This is the only method for creating new contexts, other than primitive cloning.
	Any other attempts, such as inherited methods like shallowCopy, should be
	avoided or must at least be rewritten to determine the proper size from the
	method being activated.  This is because asking a context its size (even basicSize!!)
	will not return the real object size but only the number of fields currently
	accessible, as determined by stackp."

	^ super basicNew: aMethod frameSize! !


!ContextPart class methodsFor: 'simulation' stamp: 'di 2/10/1999 22:15'!
initialize

	"A unique object to be returned when a primitive fails during simulation"
	PrimitiveFailToken _ Object new  ! !

!ContextPart class methodsFor: 'simulation' stamp: 'di 2/10/1999 22:15'!
primitiveFailToken

	^ PrimitiveFailToken! !

!ContextPart class methodsFor: 'simulation'!
runSimulated: aBlock
	"Simulate the execution of the argument, current. Answer the result it 
	returns."

	^ thisContext sender
		runSimulated: aBlock
		contextAtEachStep: [:ignored]

	"ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! !


!ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'!
contextEnsure: block
	"Create an #ensure: context that is ready to return from executing its receiver"

	| ctxt chain |
	ctxt _ thisContext.
	[chain _ thisContext sender cut: ctxt. ctxt jump] ensure: block.
	"jump above will resume here without unwinding chain"
	^ chain! !

!ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'!
contextOn: exceptionClass do: block
	"Create an #on:do: context that is ready to return from executing its receiver"

	| ctxt chain |
	ctxt _ thisContext.
	[chain _ thisContext sender cut: ctxt. ctxt jump] on: exceptionClass do: block.
	"jump above will resume here without unwinding chain"
	^ chain! !

!ContextPart class methodsFor: 'special context creation' stamp: 'ajh 5/20/2004 16:25'!
theReturnMethod

	| meth |
	meth _ self lookupSelector: #return:.
	meth primitive = 0 ifFalse: [^ self error: 'expected #return: to not be a primitive'].
	^ meth! !


!ContextPart class methodsFor: 'private' stamp: 'sma 4/22/2000 17:01'!
carefullyPrint: anObject on: aStream
	aStream nextPutAll: ([anObject printString]
		on: Error
		do: ['unprintable ' , anObject class name])! !
Inspector subclass: #ContextVariablesInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!ContextVariablesInspector commentStamp: '<historical>' prior: 0!
I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.!


!ContextVariablesInspector methodsFor: 'accessing' stamp: 'md 2/20/2006 20:33'!
fieldList 
	"Refer to the comment in Inspector|fieldList."

	| fields |
	object == nil ifTrue: [^Array with: 'thisContext'].
	fields _ (Array with: 'thisContext' with: 'all temp vars') , object tempNames.
	object myEnv ifNotNil: [
		fields _ fields, object capturedTempNames].
	^ fields! !

!ContextVariablesInspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no 
	current selection.
	
	Because no object's inspectorClass method answers this class, it is OK for this method to
	override Inspector >> inspect: "

	object := anObject.
	self initialize
	! !


!ContextVariablesInspector methodsFor: 'code'!
doItContext

	^object! !

!ContextVariablesInspector methodsFor: 'code'!
doItReceiver

	^object receiver! !


!ContextVariablesInspector methodsFor: 'selecting' stamp: 'md 2/20/2006 20:42'!
replaceSelectionValue: anObject 
	"Refer to the comment in Inspector|replaceSelectionValue:."

	| numTemps |
	selectionIndex <= 2 ifTrue: [^ self].
	numTemps _ object method numTemps.
	selectionIndex - 2 <= object method numTemps ifTrue: [
		^ object tempAt: selectionIndex - 2 put: anObject].
	^ object myEnv at: selectionIndex - 2 - numTemps put: anObject! !

!ContextVariablesInspector methodsFor: 'selecting' stamp: 'md 2/20/2006 20:43'!
selection 
	"Refer to the comment in Inspector|selection."

	| numTemps |
	selectionIndex = 0 ifTrue:[^''].
	selectionIndex = 1 ifTrue: [^object].
	selectionIndex = 2 ifTrue: [^ object tempsAndValues].
	numTemps _ object method numTemps.
	selectionIndex - 2 <= object method numTemps ifTrue: [
		^ object tempAt: selectionIndex - 2].
	^ object myEnv at: selectionIndex - 2 - numTemps! !
AbstractScoreEvent subclass: #ControlChangeEvent
	instanceVariableNames: 'control value channel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel

	^ channel
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
channel: midiChannel

	channel := midiChannel.
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'!
control

	^ control
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
control: midiControl

	control := midiControl.
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
control: midiControl value: midiControlValue channel: midiChannel

	control := midiControl.
	value := midiControlValue.
	channel := midiChannel.
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:02'!
value

	^ value
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
value: midiControlValue

	value := midiControlValue.
! !


!ControlChangeEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:45'!
isControlChange

	^ true
! !


!ControlChangeEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'!
outputOnMidiPort: aMidiPort
	"Output this event to the given MIDI port."

	aMidiPort
		midiCmd: 16rB0
		channel: channel
		byte: control
		byte: value.
! !


!ControlChangeEvent methodsFor: 'printing' stamp: 'sma 6/1/2000 09:34'!
printOn: aStream
	aStream
		nextPut: $(;
		print: time;
		nextPutAll: ': ctrl[';
		print: control;
		nextPutAll: ']=';
		print: value;
		nextPut: $)! !

!ControlChangeEvent methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:27'!
printOnStream: aStream
	aStream
		print:'('; write:time;
		print:': ctrl['; write:control;
		print:']=';write:value;
		print:')'.
! !
Object subclass: #ControlManager
	instanceVariableNames: 'scheduledControllers activeController activeControllerProcess screenController newTopClicked'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Kernel-Remnants'!
!ControlManager commentStamp: '<historical>' prior: 0!
I represent the top level control over scheduling which controller of a view on the screen the user is actively using. ScheduledControllers is the global reference to an instance of me, the one attached to the Project currently being used.!


!ControlManager methodsFor: 'accessing'!
activeController
	"Answer the currently active controller."

	^activeController! !

!ControlManager methodsFor: 'accessing' stamp: 'ar 6/5/1998 21:49'!
activeController: aController 
	"Set aController to be the currently active controller. Give the user 
	control in it."
	<primitive: 19> "Simulation guard"
	activeController _ aController.
	(activeController == screenController)
		ifFalse: [self promote: activeController].
	activeControllerProcess _ 
			[activeController startUp.
			self searchForActiveController] newProcess.
	activeControllerProcess priority: Processor userSchedulingPriority.
	activeControllerProcess resume! !

!ControlManager methodsFor: 'accessing'!
activeControllerNoTerminate: aController andProcess: aProcess
	"Set aController to be the currently active controller and aProcess to be 
	the the process that handles controller scheduling activities in the 
	system. This message differs from activeController:andProcess: in that it 
	does not send controlTerminate to the currently active controller."

	self inActiveControllerProcess
		ifTrue: 
			[aController~~nil
				ifTrue: [(scheduledControllers includes: aController)
							ifTrue: [self promote: aController]
							ifFalse: [self error: 'Old controller not scheduled']].
			activeController _ aController.
			activeController == nil
				ifFalse: [activeController controlInitialize].
			activeControllerProcess _ aProcess.
			activeControllerProcess resume]
		ifFalse: 
			[self error: 'New active controller process must be set from old one'] ! !

!ControlManager methodsFor: 'accessing'!
activeControllerProcess
	"Answer the process that is currently handling controller scheduling 
	activities in the system."

	^activeControllerProcess! !

!ControlManager methodsFor: 'accessing'!
controllerSatisfying: aBlock
	"Return the first scheduled controller which satisfies the 1-argument boolean-valued block, or nil if none.  7/25/96 sw"

	scheduledControllers do:
		[:aController | (aBlock value: aController) == true ifTrue: [^ aController]].
	^ nil! !

!ControlManager methodsFor: 'accessing'!
controllerWhoseModelSatisfies: aBlock
	"Return the first scheduled controller whose model satisfies the 1-argument boolean-valued block, or nil if none.  5/6/96 sw"

	scheduledControllers do:
		[:aController | (aBlock value: aController model) == true ifTrue: [^ aController]].
	^ nil! !

!ControlManager methodsFor: 'accessing' stamp: 'sw 5/4/2001 23:20'!
controllersSatisfying: aBlock
	"Return a list of scheduled controllers satisfying aBlock"

	^ (scheduledControllers ifNil: [^ #()]) select:
		[:aController | (aBlock value: aController) == true]! !

!ControlManager methodsFor: 'accessing'!
includes: aController
	^ scheduledControllers includes: aController! !

!ControlManager methodsFor: 'accessing'!
noteNewTop
	newTopClicked _ true! !

!ControlManager methodsFor: 'accessing'!
scheduledControllers
	"Answer a copy of the ordered collection of scheduled controllers."

	^scheduledControllers copy! !

!ControlManager methodsFor: 'accessing' stamp: 'di 10/4/97 09:05'!
scheduledWindowControllers
	"Same as scheduled controllers, but without ScreenController.
	Avoids null views just after closing, eg, a debugger."

	^ scheduledControllers select:
		[:c | c ~~ screenController and: [c view ~~ nil]]! !

!ControlManager methodsFor: 'accessing'!
screenController
	^ screenController! !

!ControlManager methodsFor: 'accessing'!
windowOriginsInUse
	"Answer a collection of the origins of windows currently on the screen in the current project.  5/21/96 sw"

	^ self scheduledWindowControllers collect: [:aController | aController view displayBox origin].! !


!ControlManager methodsFor: 'displaying'!
backgroundForm: aForm
	screenController view model: aForm.
	ScheduledControllers restore
"
	QDPen new mandala: 30 diameter: 640.
	ScheduledControllers backgroundForm:
		(Form fromDisplay: Display boundingBox).

	ScheduledControllers backgroundForm:
		(InfiniteForm with: Form gray).
"! !

!ControlManager methodsFor: 'displaying' stamp: 'di 2/26/98 08:58'!
restore 
	"Clear the screen to gray and then redisplay all the scheduled views.  Try to be a bit intelligent about the view that wants control and not display it twice if possible."

	scheduledControllers first view uncacheBits.  "assure refresh"
	self unschedule: screenController; scheduleOnBottom: screenController.
	screenController view window: Display boundingBox; displayDeEmphasized.
	self scheduledWindowControllers reverseDo:
		[:aController | aController view displayDeEmphasized].
! !

!ControlManager methodsFor: 'displaying' stamp: 'hmm 1/5/2000 07:00'!
restore: aRectangle
	"Restore all windows visible in aRectangle"
	^ self restore: aRectangle without: nil! !

!ControlManager methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:06'!
restore: aRectangle below: index without: aView
	"Restore all windows visible in aRectangle, but without aView"
	| view | 
	view _ (scheduledControllers at: index) view.
	view == aView ifTrue: 
		[index >= scheduledControllers size ifTrue: [^ self].
		^ self restore: aRectangle below: index+1 without: aView].
	view displayOn: ((BitBlt current toForm: Display) clipRect: aRectangle).
	index >= scheduledControllers size ifTrue: [^ self].
	(aRectangle areasOutside: view windowBox) do:
		[:rect | self restore: rect below: index + 1 without: aView]! !

!ControlManager methodsFor: 'displaying' stamp: 'hmm 12/30/1999 19:35'!
restore: aRectangle without: aView
	"Restore all windows visible in aRectangle"
	Display deferUpdates: true.
	self restore: aRectangle below: 1 without: aView.
	Display deferUpdates: false; forceToScreen: aRectangle! !

!ControlManager methodsFor: 'displaying'!
updateGray
	"From Georg Gollmann - 11/96.  tell the Screen Controller's model to use the currently-preferred desktop color."

	"ScheduledControllers updateGray"
	(screenController view model isMemberOf: InfiniteForm)
		ifTrue: [screenController view model: (InfiniteForm with:
Preferences desktopColor)]! !


!ControlManager methodsFor: 'initialize-release'!
initialize
	"Initialize the receiver to refer to only the background controller."
	| screenView |
	screenController _ ScreenController new.
	screenView _ FormView new.
	screenView model: (InfiniteForm with: Color gray) controller: screenController.
	screenView window: Display boundingBox.
	scheduledControllers _ OrderedCollection with: screenController! !

!ControlManager methodsFor: 'initialize-release'!
release 
	"Refer to the comment in Object|release."

	scheduledControllers == nil
		ifFalse: 
			[scheduledControllers 
				do: [:controller | (controller isKindOf: Controller)
								ifTrue: [controller view release]
								ifFalse: [controller release]].
			scheduledControllers _ nil]! !


!ControlManager methodsFor: 'scheduling'!
activateController: aController
	"Make aController, which must already be a scheduled controller, the active window.  5/8/96 sw"

	self activeController: aController.
	(activeController view labelDisplayBox
		intersect: Display boundingBox) area < 200
			ifTrue: [activeController move].
	Processor terminateActive! !

!ControlManager methodsFor: 'scheduling'!
activateTranscript
	"There is known to be a Transcript open in the current project; activate it.  2/5/96 sw"

	| itsController |
	itsController _ scheduledControllers detect:
			[:controller | controller model == Transcript]
		ifNone:
			[^ self].

	self activeController: itsController.
	(activeController view labelDisplayBox
			intersect: Display boundingBox) area < 200
				ifTrue: [activeController move].
	Processor terminateActive! !

!ControlManager methodsFor: 'scheduling' stamp: 'di 5/19/1998 09:03'!
findWindow
	"Present a menu of window titles, and activate the one that gets chosen."

	^ self findWindowSatisfying: [:c | true]! !

!ControlManager methodsFor: 'scheduling' stamp: 'rbb 2/18/2005 10:50'!
findWindowSatisfying: aBlock
	"Present a menu of window titles, and activate the one that gets chosen"

	| sortAlphabetically controllers listToUse labels index |
	sortAlphabetically _ Sensor shiftPressed.
	controllers _ OrderedCollection new.
	scheduledControllers do: [:controller |
		controller == screenController ifFalse:
			[(aBlock value: controller) ifTrue: [controllers addLast: controller]]].
	controllers size == 0 ifTrue: [^ self].
	listToUse _ sortAlphabetically
		ifTrue: [controllers asSortedCollection: [:a :b | a view label < b view label]]
		ifFalse: [controllers].
	labels _ String streamContents:
		[:strm | 
			listToUse do: [:controller | strm nextPutAll: (controller view label contractTo: 40); cr].
		strm skip: -1  "drop last cr"].
	index _ (UIManager default chooseFrom: (labels findTokens: Character cr) asArray).
	index > 0 ifTrue:
		[self activateController: (listToUse at: index)].
! !

!ControlManager methodsFor: 'scheduling'!
inActiveControllerProcess
	"Answer whether the active scheduling process is the actual active 
	process in the system."

	^activeControllerProcess == Processor activeProcess! !

!ControlManager methodsFor: 'scheduling' stamp: 'dtl 4/4/2005 06:42'!
interruptName: labelString
	"Create a Notifier on the active scheduling process with the given label. Make the Notifier the active controller."

	^ self interruptName: labelString preemptedProcess: nil
! !

!ControlManager methodsFor: 'scheduling' stamp: 'dtl 4/6/2005 23:20'!
interruptName: labelString preemptedProcess: theInterruptedProcess
	"Create a Notifier on the active scheduling process with the given label. Make the Notifier the active controller."
	| suspendingList newActiveController preemptedProcess |

	preemptedProcess _ theInterruptedProcess ifNil: [Processor preemptedProcess].
	preemptedProcess == activeControllerProcess
		ifFalse: [(suspendingList _ preemptedProcess suspendingList) == nil
				ifTrue: [preemptedProcess suspend]
				ifFalse: [suspendingList remove: preemptedProcess.
						preemptedProcess offList]].

	(suspendingList _ activeControllerProcess suspendingList) == nil
		ifTrue: [activeControllerProcess == Processor activeProcess
					ifTrue: [activeControllerProcess suspend]]
		ifFalse: [suspendingList remove: activeControllerProcess ifAbsent:[].
				activeControllerProcess offList].

	activeController ~~ nil ifTrue: [
		"Carefully de-emphasis the current window."
		activeController view topView deEmphasizeForDebugger].

	newActiveController _
		(Debugger
			openInterrupt: labelString
			onProcess: preemptedProcess) controller.
	newActiveController centerCursorInView.
	self activeController: newActiveController.
! !

!ControlManager methodsFor: 'scheduling'!
promote: aController
	"Make aController be the first scheduled controller in the ordered 
	collection."
	
	scheduledControllers remove: aController.
	scheduledControllers addFirst: aController! !

!ControlManager methodsFor: 'scheduling' stamp: 'RAA 7/7/2000 09:22'!
resetActiveController
	"When saving a morphic project whose parent is mvc, we need to set this up first"

	activeController _ nil.
	activeControllerProcess _ Processor activeProcess.
! !

!ControlManager methodsFor: 'scheduling' stamp: 'ar 6/5/1998 21:48'!
scheduleActive: aController 
	"Make aController be scheduled as the active controller. Presumably the 
	active scheduling process asked to schedule this controller and that a 
	new process associated this controller takes control. So this is the last act 
	of the active scheduling process."
	<primitive: 19> "Simulation guard"
	self scheduleActiveNoTerminate: aController.
	Processor terminateActive! !

!ControlManager methodsFor: 'scheduling'!
scheduleActiveNoTerminate: aController 
	"Make aController be the active controller. Presumably the process that 
	requested the new active controller wants to keep control to do more 
	activites before the new controller can take control. Therefore, do not 
	terminate the currently active process."

	self schedulePassive: aController.
	self scheduled: aController
		from: Processor activeProcess! !

!ControlManager methodsFor: 'scheduling'!
scheduleOnBottom: aController 
	"Make aController be scheduled as a scheduled controller, but not the 
	active one. Put it at the end of the ordered collection of controllers."

	scheduledControllers addLast: aController! !

!ControlManager methodsFor: 'scheduling'!
schedulePassive: aController 
	"Make aController be scheduled as a scheduled controller, but not the 
	active one. Put it at the beginning of the ordered collection of 
	controllers."

	scheduledControllers addFirst: aController! !

!ControlManager methodsFor: 'scheduling'!
searchForActiveController
	"Find a scheduled controller that wants control and give control to it. If 
	none wants control, then see if the System Menu has been requested."
	| aController |
	activeController _ nil.
	activeControllerProcess _ Processor activeProcess.
	self activeController: self nextActiveController.
	Processor terminateActive! !

!ControlManager methodsFor: 'scheduling' stamp: 'ajh 12/31/2001 15:15'!
spawnNewProcess

	self activeController: self screenController! !

!ControlManager methodsFor: 'scheduling'!
unschedule: aController
	"Remove the view, aController, from the collection of scheduled 
	controllers."

	scheduledControllers remove: aController ifAbsent: []! !

!ControlManager methodsFor: 'scheduling' stamp: 'rbb 2/18/2005 10:52'!
windowFromUser
	"Present a menu of window titles, and returns the StandardSystemController belonging to the one that gets chosen, or nil if none"
	| controllers labels index |
	controllers _ OrderedCollection new.
	labels _ String streamContents:
		[:strm |
		scheduledControllers do:
			[:controller | controller == screenController ifFalse:
				[controllers addLast: controller.
				strm nextPutAll: (controller view label contractTo: 40); cr]].
		strm skip: -1  "drop last cr"].
	index _ (UIManager default chooseFrom: (labels findTokens: Character cr) asArray).
	^ index > 0
		ifTrue:
			[controllers at: index]
		ifFalse:
			[nil]! !


!ControlManager methodsFor: 'private'!
nextActiveController
	"Answer the controller that would like control.  
	If there was a click outside the active window, it's the top window
	that now has the mouse, otherwise it's just the top window."

	(newTopClicked notNil and: [newTopClicked])
		ifTrue: [newTopClicked _ false.
				^ scheduledControllers 
					detect: [:aController | aController isControlWanted]
					ifNone: [scheduledControllers first]]
		ifFalse: [^ scheduledControllers first]! !

!ControlManager methodsFor: 'private'!
scheduled: aController from: aProcess

	activeControllerProcess==aProcess
		ifTrue: 
			[activeController ~~ nil
					ifTrue: [activeController controlTerminate].
			aController centerCursorInView.
			self activeController: aController]! !

!ControlManager methodsFor: 'private' stamp: 'sw 12/6/1999 23:40'!
unCacheWindows
	scheduledControllers ifNotNil: [scheduledControllers do:
		[:aController | aController view uncacheBits]]! !

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

ControlManager class
	instanceVariableNames: ''!

!ControlManager class methodsFor: 'exchange'!
newScheduler: controlManager
	"When switching projects, the control scheduler has to be exchanged. The 
	active one is the one associated with the current project."

	Smalltalk at: #ScheduledControllers put: controlManager.
	ScheduledControllers restore.
	controlManager searchForActiveController! !


!ControlManager class methodsFor: 'snapshots' stamp: 'di 2/4/1999 15:16'!
shutDown  "Saves space in snapshots"

	Smalltalk isMorphic ifFalse: [ScheduledControllers unCacheWindows]! !

!ControlManager class methodsFor: 'snapshots' stamp: 'di 2/4/1999 09:00'!
startUp
	Smalltalk isMorphic ifFalse: [ScheduledControllers restore]! !
Object subclass: #Controller
	instanceVariableNames: 'model view sensor lastActivityTime'
	classVariableNames: 'MinActivityLapse'
	poolDictionaries: ''
	category: 'ST80-Kernel-Remnants'!
!Controller commentStamp: '<historical>' prior: 0!
A Controller coordinates a View, its model, and user actions. It provides scheduling (control) behavior to determine when the user wants to communicate with the model or view.!


!Controller methodsFor: 'basic control sequence'!
controlInitialize
	"Sent by Controller|startUp as part of the standard control sequence, it 
	provides a place in the standard control sequence for initializing the 
	receiver (taking into account the current state of its model and view). It 
	should be redefined in subclasses to perform some specific action."

	^self! !

!Controller methodsFor: 'basic control sequence' stamp: 'ls 7/11/1998 06:33'!
controlLoop 
	"Sent by Controller|startUp as part of the standard control sequence. 
	Controller|controlLoop sends the message Controller|isControlActive to test 
	for loop termination. As long as true is returned, the loop continues. 
	When false is returned, the loop ends. Each time through the loop, the 
	message Controller|controlActivity is sent."

	[self isControlActive] whileTrue: [
		self interActivityPause. self controlActivity. Processor yield]! !

!Controller methodsFor: 'basic control sequence'!
controlTerminate
	"Provide a place in the standard control sequence for terminating the 
	receiver (taking into account the current state of its model and view). It 
	should be redefined in subclasses to perform some specific action."

	^self! !

!Controller methodsFor: 'basic control sequence' stamp: 'RAA 1/30/2001 19:06'!
interActivityPause
	"if we are looping quickly, insert a short delay.  Thus if we are just doing UI stuff, we won't take up much CPU"
	| currentTime wait |
	MinActivityLapse ifNotNil: [
		lastActivityTime ifNotNil: [ 
			currentTime _ Time millisecondClockValue.
			wait _ lastActivityTime + MinActivityLapse - currentTime.
			wait > 0 ifTrue: [ 
				wait <= MinActivityLapse  "big waits happen after a snapshot"
					ifTrue: [DisplayScreen checkForNewScreenSize.
							(Delay forMilliseconds: wait) wait ]. ]. ]. ].

	lastActivityTime _ Time millisecondClockValue.! !

!Controller methodsFor: 'basic control sequence'!
startUp
	"Give control to the receiver. The default control sequence is to initialize 
	(see Controller|controlInitialize), to loop (see Controller|controlLoop), and 
	then to terminate (see Controller|controlTerminate). After this sequence, 
	control is returned to the sender of Control|startUp. The receiver's control 
	sequence is used to coordinate the interaction of its view and model. In 
	general, this consists of polling the sensor for user input, testing the 
	input with respect to the current display of the view, and updating the 
	model to reflect intended changes."

	self controlInitialize.
	self controlLoop.
	self controlTerminate! !

!Controller methodsFor: 'basic control sequence'!
terminateAndInitializeAround: aBlock
	"1/12/96 sw"
	self controlTerminate.
	aBlock value.
	self controlInitialize! !


!Controller methodsFor: 'control defaults'!
controlActivity
	"Pass control to the next control level (that is, to the Controller of a 
	subView of the receiver's view) if possible. It is sent by 
	Controller|controlLoop each time through the main control loop. It should 
	be redefined in a subclass if some other action is needed."

	self controlToNextLevel! !

!Controller methodsFor: 'control defaults'!
controlToNextLevel
	"Pass control to the next control level (that is, to the Controller of a 
	subView of the receiver's view) if possible. The receiver finds the 
	subView (if any) of its view whose inset display box (see 
	View|insetDisplayBox) contains the sensor's cursor point. The Controller 
	of this subView is then given control if it answers true in response to 
	the message Controller|isControlWanted."

	| aView |
	aView _ view subViewWantingControl.
	aView ~~ nil ifTrue: [aView controller startUp]! !

!Controller methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:23'!
isControlActive
	"Answer whether receiver wishes to continue evaluating its controlLoop 
	method. It is sent by Controller|controlLoop in order to determine when 
	the receiver's control loop should terminate, and should be redefined in 
	a subclass if some special condition for terminating the main control loop 
	is needed."

	^ self viewHasCursor
		and: [sensor blueButtonPressed not
		and: [sensor yellowButtonPressed not]]! !

!Controller methodsFor: 'control defaults'!
isControlWanted
	"Answer whether the cursor is inside the inset display box (see 
	View|insetDisplayBox) of the receiver's view. It is sent by 
	Controller|controlNextLevel in order to determine whether or not control 
	should be passed to this receiver from the Controller of the superView of 
	this receiver's view."

	^self viewHasCursor! !


!Controller methodsFor: 'cursor'!
centerCursorInView
	"Position sensor's mousePoint (which is assumed to be connected to the 
	cursor) to the center of its view's inset display box (see 
	Sensor|mousePoint: and View|insetDisplayBox)."

	^sensor cursorPoint: view insetDisplayBox center! !

!Controller methodsFor: 'cursor' stamp: 'sw 7/13/1999 18:42'!
viewHasCursor
	"Answer whether the cursor point of the receiver's sensor lies within the 
	inset display box of the receiver's view (see View|insetDisplayBox). 
	Controller|viewHasCursor is normally used in internal methods."

	^ view ifNotNil: [view containsPoint: sensor cursorPoint] ifNil: [false]! !


!Controller methodsFor: 'initialize-release'!
initialize
	"Initialize the state of the receiver. Subclasses should include 'super 
	initialize' when redefining this message to insure proper initialization."

	sensor _ InputSensor default! !

!Controller methodsFor: 'initialize-release'!
release
	"Breaks the cycle between the receiver and its view. It is usually not 
	necessary to send release provided the receiver's view has been properly 
	released independently."

	model _ nil.
	view ~~ nil
		ifTrue: 
			[view controller: nil.
			view _ nil]! !


!Controller methodsFor: 'model access'!
model
	"Answer the receiver's model which is the same as the model of the 
	receiver's view."

	^model! !

!Controller methodsFor: 'model access'!
model: aModel 
	"Controller|model: and Controller|view: are sent by View|controller: in 
	order to coordinate the links between the model, view, and controller. In 
	ordinary usage, the receiver is created and passed as the parameter to 
	View|controller: so that the receiver's model and view links can be set 
	up by the view."

	model _ aModel! !


!Controller methodsFor: 'sensor access'!
sensor
	"Answer the receiver's sensor. Subclasses may use other objects that are 
	not instances of Sensor or its subclasses if more general kinds of 
	input/output functions are required."

	^sensor! !

!Controller methodsFor: 'sensor access'!
sensor: aSensor
	"Set the receiver's sensor to aSensor."

	sensor _ aSensor! !


!Controller methodsFor: 'view access' stamp: 'apb 7/14/2004 12:50'!
inspectView
	view notNil ifTrue: [^ view inspect; yourself]! !

!Controller methodsFor: 'view access'!
view
	"Answer the receiver's view."

	^view! !

!Controller methodsFor: 'view access'!
view: aView 
	"Controller|view: and Controller|model: are sent by View|controller: in 
	order to coordinate the links between the model, view, and controller. In 
	ordinary usage, the receiver is created and passed as the parameter to 
	View|controller: and the receiver's model and view links are set up 
	automatically by the view."

	view _ aView! !

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

Controller class
	instanceVariableNames: ''!

!Controller class methodsFor: 'initialization' stamp: 'ls 7/13/1998 00:47'!
MinActivityLapse: milliseconds
	"minimum time to delay between calls to controlActivity"
	MinActivityLapse _ milliseconds ifNotNil: [ milliseconds rounded ].! !

!Controller class methodsFor: 'initialization' stamp: 'ls 7/13/1998 00:47'!
initialize
	"Controller initialize"
	self MinActivityLapse: 10.! !
AbstractResizerMorph subclass: #CornerGripMorph
	instanceVariableNames: 'target'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!CornerGripMorph 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 windows.!


!CornerGripMorph methodsFor: 'as yet unclassified' stamp: 'jmv 2/19/2006 14:30'!
handlesMouseDown: anEvent
	^ true! !

!CornerGripMorph methodsFor: 'as yet unclassified' stamp: 'jmv 2/19/2006 14:30'!
handlesMouseOver: anEvent
	^true! !

!CornerGripMorph methodsFor: 'as yet unclassified' stamp: 'jmv 2/2/2006 14:24'!
initialize
	super initialize.
	self extent: self defaultWidth+2 @ (self defaultHeight+2).
	self layoutFrame: self gripLayoutFrame! !

!CornerGripMorph methodsFor: 'as yet unclassified' stamp: 'md 2/27/2006 22:01'!
mouseMove: anEvent 
	| delta |
	target ifNil: [^ self].
	target fastFramingOn 
		ifTrue: [delta := target doFastWindowReframe: self ptName] 
		ifFalse: [
			delta := anEvent cursorPoint - lastMouse.
			lastMouse := anEvent cursorPoint.
			self apply: delta.
			self bounds: (self bounds origin + delta extent: self bounds extent)].! !

!CornerGripMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 14:38'!
target: aMorph

	target _ aMorph! !


!CornerGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:24'!
defaultHeight
	^ 22! !

!CornerGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:24'!
defaultWidth
	^ 22! !
Object subclass: #CornerRounder
	instanceVariableNames: 'cornerMasks cornerOverlays underBits'
	classVariableNames: 'CR0 CR1 CR2'
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!CornerRounder commentStamp: '<historical>' prior: 0!
This class is a quick hack to support rounded corners in morphic.

Rather than produce rounded rectangles, it tweaks the display of corners.
Rather than work for any radius, it only supports a radius of 6.
Rather than work for any border width, it only supports widths 0, 1 and 2.
The corners, while apparently transparent, still behave opaquely to mouse clicks.

Worse than this, the approach relies on the ability to extract underlying bits from the canvas prior to display.  This ran afoul of top-down display, it seems, in SystemWindow spawnReframeHandle: (qv).  It will also make a postscript printer very unhappy.

But, hey, it's cute.!


!CornerRounder methodsFor: 'all' stamp: 'di 6/24/1999 09:35'!
masterMask: maskForm masterOverlay: overlayForm

	cornerMasks _ #(none left pi right) collect:
		[:dir | (maskForm rotateBy: dir centerAt: 0@0) offset: 0@0].
	cornerOverlays _ #(none left pi right) collect:
		[:dir | (overlayForm rotateBy: dir centerAt: 0@0) offset: 0@0].
! !

!CornerRounder methodsFor: 'all' stamp: 'ar 1/5/2002 17:26'!
saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: cornerList

	| offset corner mask form corners rect |
	underBits _ Array new: 4.
	corners _ bounds corners.
	cornerList do:[:i|
		mask _ cornerMasks at: i.
		corner _ corners at: i.
		i = 1 ifTrue: [offset _ 0@0].
		i = 2 ifTrue: [offset _ 0@mask height negated].
		i = 3 ifTrue: [offset _ mask extent negated].
		i = 4 ifTrue: [offset _ mask width negated@0].
		rect _ corner + offset extent: mask extent.
		(aCanvas isVisible: rect) ifTrue:[
			form _ aCanvas contentsOfArea: rect.
			form copyBits: form boundingBox from: mask at: 0@0 clippingBox: form boundingBox rule: Form and fillColor: nil map: (Bitmap with: 16rFFFFFFFF with: 0).
			underBits at: i put: form]].
! !

!CornerRounder methodsFor: 'all' stamp: 'kfr 8/4/2003 23:28'!
tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: cornerList
	"This variant has a cornerList argument, to allow some corners to be rounded and others not"
	| offset corner saveBits fourColors mask outBits shadowColor corners |
	shadowColor _ aCanvas shadowColor.
	aCanvas shadowColor: nil. "for tweaking it's essential"
	w > 0 ifTrue:[
			fourColors _ shadowColor 
				ifNil:[aMorph borderStyle colorsAtCorners]
				ifNotNil:[Array new: 4 withAll: Color transparent]].
	mask _ Form extent: cornerMasks first extent depth: aCanvas depth.
	corners _ bounds corners.
	cornerList do:[:i|
		corner _ corners at: i.
		saveBits _ underBits at: i.
		saveBits ifNotNil:[
			i = 1 ifTrue: [offset _ 0@0].
			i = 2 ifTrue: [offset _ 0@saveBits height negated].
			i = 3 ifTrue: [offset _ saveBits extent negated].
			i = 4 ifTrue: [offset _ saveBits width negated@0].

			"Mask out corner area (painting saveBits won't clear if transparent)."
			mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF).
			outBits _ aCanvas contentsOfArea: (corner + offset extent: mask extent).
			mask displayOn: outBits at: 0@0 rule: Form and.
			"Paint back corner bits."
			saveBits displayOn: outBits at: 0@0 rule: Form paint.
			"Paint back corner bits."
			aCanvas drawImage: outBits at: corner + offset.

			w > 0 ifTrue:[
				
				aCanvas stencil: (cornerOverlays at: i) at: corner + offset
						color: (fourColors at: i)]]].
	aCanvas shadowColor: shadowColor. "restore shadow color"
! !

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

CornerRounder class
	instanceVariableNames: ''!

!CornerRounder class methodsFor: 'all' stamp: 'di 6/28/1999 15:51'!
initialize  "CornerRounder initialize"

	CR0 _ CR1 _ self new
		masterMask:
			(Form extent: 6@6
				fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26)
				offset: 0@0)
		masterOverlay:
			(Form extent: 6@6
				fromArray: #(2r1e26 2r110e26 2r1000e26 2r10000e26 2r10000e26 2r100000e26)
				offset: 0@0).
	CR2 _ self new
		masterMask:
			(Form extent: 6@6
				fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26)
				offset: 0@0)
		masterOverlay:
			(Form extent: 6@6
				fromArray: #(2r1e26 2r111e26 2r1111e26 2r11100e26 2r11000e26 2r111000e26)
				offset: 0@0).

! !

!CornerRounder class methodsFor: 'all' stamp: 'di 3/25/2000 11:12'!
rectWithinCornersOf: aRectangle
	"Return a single sub-rectangle that lies entirely inside corners
	that are made by me.
	Used to identify large regions of window that do not need to be redrawn."

	^ aRectangle insetBy: 0@6! !

!CornerRounder class methodsFor: 'all' stamp: 'ar 1/5/2002 17:24'!
roundCornersOf: aMorph on: aCanvas in: bounds displayBlock: displayBlock borderWidth: w corners: aList

	| rounder |
	rounder _ CR0.
	w = 1 ifTrue: [rounder _ CR1].
	w = 2 ifTrue: [rounder _ CR2].
	rounder _ rounder copy.
	rounder saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: aList.
	displayBlock value.
	rounder tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: aList! !
Object subclass: #CosineInterpolator
	instanceVariableNames: 'origin points stack'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Support'!

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 12/14/1999 00:49'!
at: time
	"Answer the value of the receiver at a given time. (Do linear interpolation.)"
	^ self cosineAt: time + self origin! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 11/24/1999 01:59'!
at: time put: value
	self points add: time + self origin -> value.
	^ value! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
commit
	self cleanBetween: stack first key and: stack last key.
	self points addAll: stack.
	stack := SortedCollection new! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 12/4/1999 17:22'!
duration
	^ self points last key - self points first key! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 11/24/1999 01:59'!
origin
	^ origin! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
origin: aNumber
	origin := aNumber! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 12/4/1999 17:20'!
x: x y: y
	stack add: x + self origin -> y! !


!CosineInterpolator methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	points := SortedCollection new.
	stack := SortedCollection new.
	origin := 0! !


!CosineInterpolator methodsFor: 'private' stamp: 'len 11/23/1999 01:08'!
cleanBetween: start and: end
	self points: (self points reject: [ :each | each key between: start and: end])! !

!CosineInterpolator methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
cosineAt: time
	"Answer the value of the receiver at a given time. (Do cosine interpolation.)"
	| xVal count x1 x2 y1 y2 |
	points isNil ifTrue: [^ nil].
	xVal := points first key.
	count := 1.
	[xVal < time]
		whileTrue: [count := count + 1.
					count > points size ifTrue: [^ points last value].
					xVal := (points at: count) key].
	xVal = time ifTrue: [^ (points at: count) value].
	count = 1 ifTrue: [^ points first value].
	x1 := (points at: count - 1) key.
	x2 := (points at: count) key.
	y1 := (points at: count - 1) value.
	y2 := (points at: count) value.
	^ ((time - x1 / (x2 - x1) * Float pi) cos - 1 / -2.0) * (y2 - y1) + y1! !

!CosineInterpolator methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
linearAt: time
	"Answer the value of the receiver at a given time. (Do linear interpolation.)"
	| xVal count x1 x2 y1 y2 |
	points isNil ifTrue: [^ nil].
	xVal := points first key.
	count := 1.
	[xVal < time]
		whileTrue: [count := count + 1.
					count > points size ifTrue: [^ points last value].
					xVal := (points at: count) key].
	xVal = time ifTrue: [^ (points at: count) value].
	count = 1 ifTrue: [^ points first value].
	x1 := (points at: count - 1) key.
	x2 := (points at: count) key.
	y1 := (points at: count - 1) value.
	y2 := (points at: count) value.
	^ (time - x1) / (x2 - x1) * (y2 - y1) + y1! !

!CosineInterpolator methodsFor: 'private' stamp: 'len 12/4/1999 17:29'!
points
	^ points! !

!CosineInterpolator methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
points: aCollection
	points := aCollection! !

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

CosineInterpolator class
	instanceVariableNames: ''!

!CosineInterpolator class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/3/2006 22:23'!
fromArray: anArray
	| answer |
	answer := self new.
	1 to: anArray size by: 2 do: [ :each | answer at: (anArray at: each) put: (anArray at: each + 1)].
	^ answer! !
StandardFileStream subclass: #CrLfFileStream
	instanceVariableNames: 'lineEndConvention'
	classVariableNames: 'Cr CrLf Lf LineEndDefault LineEndStrings LookAheadCount'
	poolDictionaries: ''
	category: 'Files-Kernel'!
!CrLfFileStream commentStamp: 'ls 11/10/2002 13:32' prior: 0!
I am the same as a regular file stream, except that when I am in text mode, I will automatically convert line endings between the underlying platform's convention, and Squeak's convention of carriage-return only.  The goal is that Squeak text files can be treated as OS text files, and vice versa.

In binary mode, I behave identically to a StandardFileStream.

To enable CrLfFileStream as the default file stream class for an entire image, modify FileStream class concreteStream .


There are two caveats on programming with CrLfFileStream.

First, the choice of text mode versus binary mode affects which characters are visible in Squeak, and no longer just affects whether those characters are returned as Character's or as Integer's.  Thus the choice of mode needs to be made very carefully, and must be based on intent instead of convenience of representation.  The methods asString, asByteArray, asCharacter, and asInteger can be used to convert between character and integer representations.  (Arguably, file streams should accept either strings or characters in nextPut: and nextPutAll:, but that is not the case right now.)

Second, arithmetic on positions no longer works, because one character that Squeak sees (carriage return) could map to two characters in the underlying file (carriage return plus line feed, on MS Windows and MS DOS).  Comparison between positions still works.  (This caveat could perhaps be fixed by maintaining a map between Squeak positions and positions in the underlying file, but it is complicated.  Consider, for example, updates to the middle of the file.  Also, consider that text files are rarely updated in the middle of the file, and that general random access to a text file is rarely very useful.  If general random access with specific file counts is desired, then the file is starting to sound like a binary file instead of a text file.)

!
]style[(448 31 1371 6 32)f1,f1LFileStream class concreteStream;,f1,f1i,f1!


!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:16'!
ascii
	super ascii.
	self detectLineEndConvention! !

!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
binary
	super binary.
	lineEndConvention := nil! !

!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
detectLineEndConvention
	"Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf."
	| char numRead pos |
	self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams'].
	lineEndConvention := LineEndDefault.
	"Default if nothing else found"
	numRead := 0.
	pos := super position.
	[super atEnd not and: [numRead < LookAheadCount]]
		whileTrue: 
			[char := super next.
			char = Lf
				ifTrue: 
					[super position: pos.
					^ lineEndConvention := #lf].
			char = Cr
				ifTrue: 
					[super peek = Lf
						ifTrue: [lineEndConvention := #crlf]
						ifFalse: [lineEndConvention := #cr].
					super position: pos.
					^ lineEndConvention].
			numRead := numRead + 1].
	super position: pos.
	^ lineEndConvention! !

!CrLfFileStream methodsFor: 'access' stamp: 'nk 9/5/2004 12:58'!
lineEndConvention

	^lineEndConvention! !

!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
next
    | char secondChar |
    char := super next.
    self isBinary ifTrue: [^char].
    char == Cr ifTrue:
        [secondChar := super next.
        secondChar ifNotNil: [secondChar == Lf ifFalse: [self skip: -1]].
        ^Cr].
    char == Lf ifTrue: [^Cr].
    ^char! !

!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
next: n

		| string peekChar |
		string := super next: n.
		string size = 0 ifTrue: [ ^string ].
		self isBinary ifTrue: [ ^string ].

		"if we just read a CR, and the next character is an LF, then skip the LF"
		( string last = Character cr ) ifTrue: [
			peekChar := super next.		"super peek doesn't work because it relies on #next"
			peekChar ~= Character lf ifTrue: [
				super position: (super position - 1) ]. ].
 
		string := string withSqueakLineEndings.

		string size = n ifTrue: [ ^string ].

		"string shrunk due to embedded crlfs; make up the difference"
		^string, (self next: n - string size)! !

!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'!
nextPut: char 
	(lineEndConvention notNil and: [char = Cr])
		ifTrue: [super nextPutAll: (LineEndStrings at: lineEndConvention)]
		ifFalse: [super nextPut: char].
	^ char! !

!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'!
nextPutAll: aString 
	super nextPutAll: (self convertStringFromCr: aString).
	^ aString
! !

!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
peek
	"Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil.  "
	| next pos |
	self atEnd ifTrue: [^ nil].
	pos := self position.
	next := self next.
	self position: pos.
	^ next! !

!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'!
upTo: aCharacter
	| newStream char |
	newStream := WriteStream on: (String new: 100).
	[(char := self next) isNil or: [char == aCharacter]]
		whileFalse: [newStream nextPut: char].
	^ newStream contents
! !

!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'!
verbatim: aString 
	super verbatim: (self convertStringFromCr: aString).
	^ aString! !


!CrLfFileStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:31'!
open: aFileName forWrite: writeMode 
	"Open the receiver.  If writeMode is true, allow write, else access will be 
	read-only. "
	| result |
	result := super open: aFileName forWrite: writeMode.
	result ifNotNil: [self detectLineEndConvention].
	^ result! !


!CrLfFileStream methodsFor: '*monticello' stamp: 'stephaneducasse 2/4/2006 20:47'!
lineEndingConvention: aSymbol	
	lineEndConvention := aSymbol! !


!CrLfFileStream methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
convertStringFromCr: aString 
	| inStream outStream |
	lineEndConvention ifNil: [^ aString].
	lineEndConvention == #cr ifTrue: [^ aString].
	lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Cr with: Lf].
	"lineEndConvention == #crlf"
	inStream := ReadStream on: aString.
	outStream := WriteStream on: (String new: aString size).
	[inStream atEnd]
		whileFalse: 
			[outStream nextPutAll: (inStream upTo: Cr).
			(inStream atEnd not or: [aString last = Cr])
				ifTrue: [outStream nextPutAll: CrLf]].
	^ outStream contents! !

!CrLfFileStream methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
convertStringToCr: aString 
	| inStream outStream |
	lineEndConvention ifNil: [^ aString].
	lineEndConvention == #cr ifTrue: [^ aString].
	lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Lf with: Cr].
	"lineEndConvention == #crlf"
	inStream := ReadStream on: aString.
	outStream := WriteStream on: (String new: aString size).
	[inStream atEnd]
		whileFalse: 
			[outStream nextPutAll: (inStream upTo: Cr).
			(inStream atEnd not or: [aString last = Cr])
				ifTrue: 
					[outStream nextPut: Cr.
					inStream peek = Lf ifTrue: [inStream next]]].
	^ outStream contents! !

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

CrLfFileStream class
	instanceVariableNames: ''!

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'!
defaultToCR
	"CrLfFileStream defaultToCR"
	LineEndDefault := #cr.! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'!
defaultToCRLF
	"CrLfFileStream defaultToCRLF"
	LineEndDefault := #crlf.! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'!
defaultToLF
	"CrLfFileStream defaultToLF"
	LineEndDefault := #lf.! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:13'!
guessDefaultLineEndConvention
	"Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory."
	FileDirectory pathNameDelimiter = $: ifTrue:[^self defaultToCR].
	FileDirectory pathNameDelimiter = $/ ifTrue:[^self defaultToLF].
	FileDirectory pathNameDelimiter = $\ ifTrue:[^self defaultToCRLF].
	"in case we don't know"
	^self defaultToCR! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'di 2/4/1999 09:16'!
initialize
	"CrLfFileStream initialize"
	Cr := Character cr.
	Lf := Character lf.
	CrLf := String with: Cr with: Lf.
	LineEndStrings := Dictionary new.
	LineEndStrings at: #cr put: (String with: Character cr).
	LineEndStrings at: #lf put: (String with: Character lf).
	LineEndStrings at: #crlf put: (String with: Character cr with: Character lf).
	LookAheadCount := 2048.
	Smalltalk addToStartUpList: self.
	self startUp.! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 04:46'!
new

	^ (MultiByteFileStream new) wantsLineEndConversion: true; yourself.

! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'djp 1/28/1999 22:08'!
startUp
	self guessDefaultLineEndConvention! !
Array variableSubclass: #Cubic
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Collections-Arrayed'!
!Cubic commentStamp: 'wiz 6/17/2004 20:31' prior: 0!
I am a segment between to points. In the form of a cubic polynomial that can be evaluated between 0..1 to obtain the end points and intermediate values.
!


!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/17/2004 22:32'!
bestSegments
	"Return the smallest integer number of segments that give the 
	best curve."
	^ self honeIn: self calcEnoughSegments! !

!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/18/2004 23:12'!
calcEnoughSegments
	"Find the power of two that represents a sufficient number of  
	segments for this cubic.  
	The measure is the sum of distances for the segments.  
	We want this to be close enough not affect the straightness of  
	the drawn lines. Which means within one pixel."
	"^ self 
	enough: 2 
	withMeasure: (self measureFor: 1) 
	withIn: self leeway 
	This ran into a problem when the curve was an s-curve with 
	inflections. Besides honeIn will check to see if 1 is better than 
	two so we lose nothing by starting a little higher."
	^ self
		enough: 4
		withMeasure: (self measureFor: 2)
		withIn: self leeway! !

!Cubic methodsFor: 'cubic support' stamp: 'wiz 7/18/2004 22:50'!
enough: nTry withMeasure: lastMeasure withIn: closeEnough
"See comment in calcEnoughSegments for which I am a helper"
	| measure |
	measure := self measureFor: nTry.
	measure > (lastMeasure + closeEnough)
		ifFalse: [^ nTry // 2].
	^ self
		enough: 2 * nTry
		withMeasure: measure
		withIn: closeEnough! !

!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/17/2004 23:51'!
honeIn: enough 
	"Find if there is a smaller n than enough that give the same  
	measure for n."
	self
		assert: [enough isPowerOfTwo].
	enough < 2
		ifTrue: [^ enough].
	^ self
		honeIn: enough
		step: enough // 2
		measure: (self measureFor: enough)
		withIn: self leeway! !

!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/17/2004 23:45'!
honeIn: centerN step: step measure: measure withIn: closeEnough 
	"Pick the best n by binary search."
	| nTry |
	step < 1
		ifTrue: [^ centerN].
	nTry := centerN - step.
	^ measure > (closeEnough
				+ (self measureFor: nTry))
		ifTrue: [self
				honeIn: centerN
				step: step // 2
				measure: measure
				withIn: closeEnough]
		ifFalse: [self
				honeIn: nTry
				step: step // 2
				measure: measure
				withIn: closeEnough]! !

!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/19/2004 00:00'!
leeway
	"How close can measure be"
	^ 0.1! !

!Cubic methodsFor: 'cubic support' stamp: 'wiz 1/30/2005 20:59'!
measureFor: n 
	"Return a distance measure for cubic curve with n segments. 
	For convienence and accuracy we use the sum of the
	distances. "
	"first point is poly of 0."
	| p1 p2 measure |
	p1 := self first.
	measure := 0.
	(1 to: n)
		do: [:i | 
			p2 := self polynomialEval: i / n asFloat.
			measure := measure
						+ (p2 dist: p1).
			p1 := p2].
	^ measure! !
Object subclass: #CurrentProjectRefactoring
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: '39Deprecated'!

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

CurrentProjectRefactoring class
	instanceVariableNames: ''!

!CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'dao 9/14/2005 10:46'!
isFlapEnabled: aFlapTab
	"Answer whether the given flap tab is enabled in the current project"
	
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^ self xxxCurrent isFlapEnabled: aFlapTab! !

!CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'dao 9/14/2005 10:46'!
showSharedFlaps
	"Answer whether shared flaps are currently showing (true) or suppressed (false).  The CurrentProjectRefactoring circumlocution is in service of making it possible for shared flaps to appear on the edges of an interior subworld, I believe."
	
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^ self xxxCurrent showSharedFlaps! !

!CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'dao 9/14/2005 10:46'!
suppressFlapsString
	"Answer a string characterizing whether flaps are suppressed 
	at the moment or not"
	
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^ (self currentFlapsSuppressed
		ifTrue: ['<no>']
		ifFalse: ['<yes>']), 'show shared tabs (F)' translated! !


!CurrentProjectRefactoring class methodsFor: 'miscellaneous' stamp: 'dao 9/14/2005 10:46'!
exitCurrentProject
"
CurrentProjectRefactoring exitCurrentProject
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent exit
! !

!CurrentProjectRefactoring class methodsFor: 'miscellaneous' stamp: 'dao 9/14/2005 10:46'!
newProcessIfUI: aDeadOrDyingProcess
"
CurrentProjectRefactoring newProcessIfUI:
used ONLY for Morphic
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^Project spawnNewProcessIfThisIsUI: aDeadOrDyingProcess! !

!CurrentProjectRefactoring class methodsFor: 'miscellaneous' stamp: 'dao 9/14/2005 10:46'!
projectWithNameOrCurrent: aString
"
CurrentProjectRefactoring projectWithNameOrCurrent:
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^(Project named: aString) ifNil: [self xxxCurrent]! !


!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:44'!
currentAddGuard: anObject
"
CurrentProjectRefactoring currentAddGuard:
"	
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent addGuard: anObject! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:44'!
currentBeIsolated
"
CurrentProjectRefactoring currentBeIsolated
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent beIsolated! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:44'!
currentBeParentTo: anotherProject
"
CurrentProjectRefactoring currentBeParentTo:
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^anotherProject setParent: self xxxCurrent! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:44'!
currentBeParentToCurrent
"
CurrentProjectRefactoring currentBeParentToCurrent
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent setParent: self xxxCurrent! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
currentFlapsSuppressed
"
CurrentProjectRefactoring currentFlapsSuppressed
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent flapsSuppressed! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
currentFromMyServerLoad: aProjectName
"
CurrentProjectRefactoring currentFromMyServerLoad:
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent fromMyServerLoad: aProjectName! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
currentInterruptName: aString
"
CurrentProjectRefactoring currentInterruptName:
"

	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^Project interruptName: aString! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dtl 4/3/2005 14:14'!
currentInterruptName: aString preemptedProcess: theInterruptedProcess

	^ Project interruptName: aString preemptedProcess: theInterruptedProcess! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
currentIsolationHead
"
CurrentProjectRefactoring currentIsolationHead
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent isolationHead! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
currentProjectName
"
CurrentProjectRefactoring currentProjectName
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
		
	^self xxxCurrent name! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
currentPropagateChanges
"
CurrentProjectRefactoring currentPropagateChanges
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent propagateChanges! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
currentSpawnNewProcessAndTerminateOld: aBoolean
"
CurrentProjectRefactoring currentSpawnNewProcessAndTerminateOld:
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^Project spawnNewProcessAndTerminateOld: aBoolean

! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
currentToggleFlapsSuppressed
"
CurrentProjectRefactoring currentToggleFlapsSuppressed
"
	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^self xxxCurrent flapsSuppressed: self xxxCurrent flapsSuppressed not.


! !

!CurrentProjectRefactoring class methodsFor: 'revectoring to current' stamp: 'dao 9/14/2005 10:45'!
xxxCurrent

	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^Project current! !


!CurrentProjectRefactoring class methodsFor: '*Flash' stamp: 'dao 9/14/2005 10:46'!
updateProjectFillsIn: aFlashPlayerMorph
"
CurrentProjectRefactoring updateProjectFillsIn:
"

	self deprecated: 'CurrentProjectRefactoring is deprecated'.
	
	^aFlashPlayerMorph updateProjectFillsFrom: self xxxCurrent
! !
Form subclass: #Cursor
	instanceVariableNames: ''
	classVariableNames: 'BlankCursor BottomLeftCursor BottomRightCursor CornerCursor CrossHairCursor CurrentCursor DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor ResizeLeftCursor ResizeTopCursor ResizeTopLeftCursor ResizeTopRightCursor RightArrowCursor SquareCursor TargetCursor TopLeftCursor TopRightCursor UpCursor WaitCursor WebLinkCursor WriteCursor XeqCursor'
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!Cursor commentStamp: '<historical>' prior: 0!
I am a Form that is a possible appearance for a mouse cursor.  My size is always 16x16, ever since the original implementation on the Alto.

There are many examples available in the "current cursor" category of class methods.  For example, "Cursor normal" and "Cursor wait".  For example:

	Cursor wait show

!


!Cursor methodsFor: 'converting' stamp: 'RAA 8/14/2000 10:14'!
asCursorForm
	| form |
	form _ StaticForm extent: self extent depth: 8.
	form fillShape: self fillColor: Color black at: offset negated.
	^ form offset: offset! !

!Cursor methodsFor: 'converting' stamp: 'bf 2/2/1999 19:32'!
withMask
	^CursorWithMask derivedFrom: self! !


!Cursor methodsFor: 'displaying' stamp: 'ls 6/17/2002 11:56'!
show
	"Make the hardware's mouse cursor look like the receiver"

	Sensor currentCursor: self! !

!Cursor methodsFor: 'displaying'!
showGridded: gridPoint 
	"Make the current cursor shape be the receiver, forcing the location of the cursor to the point nearest gridPoint."
	
	Sensor cursorPoint: (Sensor cursorPoint grid: gridPoint).
	Sensor currentCursor: self! !

!Cursor methodsFor: 'displaying' stamp: 'bf 10/13/1999 13:05'!
showWhile: aBlock 
	"While evaluating the argument, aBlock, make the receiver be the cursor 
	shape."

	| oldcursor |
	oldcursor _ Sensor currentCursor.
	self show.
	^aBlock ensure: [oldcursor show]
! !


!Cursor methodsFor: 'primitives'!
beCursor
	"Primitive. Tell the interpreter to use the receiver as the current cursor 
	image. Fail if the receiver does not match the size expected by the 
	hardware. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 101>
	self primitiveFailed! !

!Cursor methodsFor: 'primitives' stamp: 'jm 9/22/1998 23:33'!
beCursorWithMask: maskForm
	"Primitive. Tell the interpreter to use the receiver as the current cursor image with the given mask Form. Both the receiver and the mask should have extent 16@16 and a depth of one. The mask and cursor bits are combined as follow:
			mask	cursor	effect
			 0		  0		transparent (underlying pixel shows through)
			 1		  1		opaque black
			 1		  0		opaque white
			 0		  1		invert the underlying pixel"
"Essential. See Object documentation whatIsAPrimitive."

	<primitive: 101>
	self primitiveFailed
! !


!Cursor methodsFor: 'printing'!
printOn: aStream

	self storeOn: aStream base: 2! !


!Cursor methodsFor: 'testing' stamp: 'bf 2/2/1999 19:34'!
hasMask
	^false! !


!Cursor methodsFor: 'updating' stamp: 'ls 6/17/2002 12:00'!
changed: aParameter
	"overriden to reinstall the cursor if it is the active cursor, in case the appearance has changed.  (Is this used anywhere?  Do cursors really change in place these days?)"
	self == CurrentCursor ifTrue: [self beCursor].
	super changed: aParameter! !

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

Cursor class
	instanceVariableNames: ''!

!Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:57'!
initBottomLeft

	BottomLeftCursor _ 
		(Cursor extent: 16@16
			fromArray: #(
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1111111111111111
		2r1111111111111111)
			offset: 0@-16).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:57'!
initBottomRight

	BottomRightCursor _ 
		(Cursor extent: 16@16
			fromArray: #(
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r1111111111111111
		2r1111111111111111)
			offset: -16@-16).
! !

!Cursor class methodsFor: 'class initialization'!
initCorner

	CornerCursor _ 
		(Cursor 
			extent: 16@16
			fromArray: #(
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r1111111111111111
		2r1111111111111111)
			offset: -16@-16).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:02'!
initCrossHair

	CrossHairCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0000000000000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0111111111111100
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000000000000
		2r0)
			offset: -7@-7).
	
	! !

!Cursor class methodsFor: 'class initialization'!
initDown

	DownCursor  _
		     (Cursor
	extent: 16@16
	fromArray: #(
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r1111110000000000
		2r111100000000000
		2r11000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initMarker

	MarkerCursor _ 
		Cursor
			extent: 16@16
			fromArray: #(
		2r0111000000000000
		2r1111100000000000
		2r1111100000000000
		2r0111000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
			offset: 0@0.
! !

!Cursor class methodsFor: 'class initialization' stamp: 'di 7/30/2001 10:32'!
initMenu 

	MenuCursor  _
		        (Cursor
	extent: 16@16
	fromArray: #(
		2r1111111111100000
		2r1000000000100000
		2r1010011000100000
		2r1000000000100000
		2r1101001101100000
		2r1111111111100000
		2r1000000000100000
		2r1011001010100000
		2r1000000000100000
		2r1010110010100000
		2r1000000000100000
		2r1010010100100000
		2r1000000000100000
		2r1111111111100000
		0)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:10'!
initMove

	MoveCursor _ 
		Cursor 
			extent: 16@16
			fromArray: #(
		2r1111111111111100
		2r1111111111111100
		2r1100001100001100
		2r1100001100001100
		2r1100001100001100
		2r1100001100001100
		2r1111111111111100
		2r1111111111111100
		2r1100001100001100
		2r1100001100001100
		2r1100001100001100
		2r1100001100001100
		2r1111111111111100
		2r1111111111111100
          0)
			offset: 0@0.
! !

!Cursor class methodsFor: 'class initialization'!
initNormal

	NormalCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1000000000000000
		2r1100000000000000
		2r1110000000000000
		2r1111000000000000
		2r1111100000000000
		2r1111110000000000
		2r1111111000000000
		2r1111100000000000
		2r1111100000000000
		2r1001100000000000
		2r0000110000000000
		2r0000110000000000
		2r0000011000000000
		2r0000011000000000
		2r0000001100000000
		2r0000001100000000)
	offset: 0@0).

	
	! !

!Cursor class methodsFor: 'class initialization' stamp: 'di 10/8/1998 17:04'!
initNormalWithMask    "Cursor initNormalWithMask.  Cursor normal show"
	"Next two lines work simply for any cursor..."
	self initNormal.
	NormalCursor _ CursorWithMask derivedFrom: NormalCursor.

	"But for a good looking cursor, you have to tweak things..."
	NormalCursor _ (CursorWithMask extent: 16@16 depth: 1
			fromArray: #( 0 1073741824 1610612736 1879048192
				2013265920 2080374784 2113929216 2130706432
				2080374784 2080374784 1275068416 100663296
				100663296 50331648 50331648 0)
			offset: -1@-1)
		setMaskForm: (Form extent: 16@16 depth: 1
			fromArray: #( 3221225472 3758096384 4026531840 4160749568
				4227858432 4261412864 4278190080 4286578688
				4278190080 4261412864 4261412864 3472883712
				251658240 125829120 125829120 50331648)
			offset: 0@0).! !

!Cursor class methodsFor: 'class initialization'!
initOrigin

	OriginCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000)
			offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 22:55'!
initRead

	ReadCursor _  
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0000000000000000
		2r0000000000000000
		2r0001000000001000
		2r0010100000010100
		2r0100000000100000
		2r1111101111100000
		2r1000010000100000
		2r1000010000100000
		2r1011010110100000
		2r0111101111000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'jrp 8/6/2005 22:50'!
initResizeLeft

       ResizeLeftCursor _
               (Cursor extent: 16@16 fromArray: #(
               2r0000000000000000
               2r0000000000000000
               2r0000000000000000
               2r0000000000000000
               2r0000100000010000
               2r0001100000011000
               2r0011100000011100
               2r0111111111111110
               2r0011100000011100
               2r0001100000011000
               2r0000100000010000
               2r0000000000000000
               2r0000000000000000
               2r0000000000000000
               2r0000000000000000
               2r0000000000000000 )
       offset: -7@-7 ) withMask! !

!Cursor class methodsFor: 'class initialization' stamp: 'jrp 8/6/2005 22:54'!
initResizeTop
    "Cursor initResizeTop"
       ResizeTopCursor _
               (Cursor extent: 16@16 fromArray: #(
               2r000000100000000
               2r000001110000000
               2r000011111000000
               2r000111111100000
               2r000000100000000
               2r000000100000000
               2r000000100000000
               2r000000100000000
               2r000000100000000
               2r000000100000000
               2r000111111100000
               2r000011111000000
               2r000001110000000
               2r000000100000000
               2r000000000000000)
       offset: -7@-7) withMask! !

!Cursor class methodsFor: 'class initialization' stamp: 'jrp 8/6/2005 22:55'!
initResizeTopLeft

       ResizeTopLeftCursor _
               (Cursor extent: 16@16 fromArray: #(
               2r0000000000000000
               2r0111110000000000
               2r0111100000000000
               2r0111000000000000
               2r0110100000000000
               2r0100010000000000
               2r0000001000000000
               2r0000000100000000
               2r0000000010000000
               2r0000000001000100
               2r0000000000101100
               2r0000000000011100
               2r0000000000111100
               2r0000000001111100
               2r0000000000000000
               2r0000000000000000)
       offset: -7@-7) withMask! !

!Cursor class methodsFor: 'class initialization' stamp: 'jrp 8/7/2005 07:54'!
initResizeTopRight

       ResizeTopRightCursor _
               (Cursor extent: 16@16 fromArray: #(
               2r0000000000000000
               2r0000000001111100
               2r0000000000111100
               2r0000000000011100
               2r0000000000101100
               2r0000000001000100
               2r0000000010000000
               2r0000000100000000
               2r0000001000000000
               2r0100010000000000
               2r0110100000000000
               2r0111000000000000
               2r0111100000000000
               2r0111110000000000
               2r0000000000000000
               2r0000000000000000)
       offset: -7@-7) withMask! !

!Cursor class methodsFor: 'class initialization'!
initRightArrow 

	RightArrowCursor  _
		      (Cursor
	extent: 16@16
	fromArray: #(
		2r100000000000
		2r111000000000
		2r1111111110000000
		2r111000000000
		2r100000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
	
	"Cursor initRightArrow"! !

!Cursor class methodsFor: 'class initialization'!
initSquare

	SquareCursor _ 
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0000001111000000
		2r0000001111000000
		2r0000001111000000
		2r0000001111000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: -8@-8).

	! !

!Cursor class methodsFor: 'class initialization' stamp: 'ar 3/1/2006 22:42'!
initTarget
	^TargetCursor := Cursor
				extent: 16 @ 16
				fromArray:  #(1984 6448 8456 16644 17284 33026 35106 65278 35106 33026 17284 16644 8456 6448 1984 0)
				offset: -7 @ -7! !

!Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:01'!
initTopLeft
	TopLeftCursor _ 
		(Cursor extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000)
			offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:02'!
initTopRight
	TopRightCursor _ 
		(Cursor extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011)
			offset: -16@0).
! !

!Cursor class methodsFor: 'class initialization'!
initUp

	UpCursor _ 
		    (Cursor
	extent: 16@16
	fromArray: #(
		2r11000000000000
		2r111100000000000
		2r1111110000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:27'!
initWait

	WaitCursor _ 
		  (Cursor
			extent: 16@16
			fromArray: #(
		2r1111111111111100
		2r1000000000000100
		2r0100000000001000
		2r0010000000010000
		2r0001110011100000
		2r0000111111000000
		2r0000011110000000
		2r0000011110000000
		2r0000100101000000
		2r0001000100100000
		2r0010000110010000
		2r0100001111001000
		2r1000111111110100
		2r1111111111111100
		0)
			offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 22:52'!
initWrite

	WriteCursor _ (Cursor
	extent: 16@16
	fromArray: #(
		2r0000000000011000
		2r0000000000111100
		2r0000000001001000
		2r0000000010010000
		2r0000000100100000
		2r0000001001000100
		2r0000010010000100
		2r0000100100001100
		2r0001001000010000
		2r0010010000010000
		2r0111100000001000
		2r0101000011111000
		2r1110000110000000
		2r0111111100000000
		2r0
		2r0)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initXeq

	XeqCursor _ 
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1000000000010000
		2r1100000000010000
		2r1110000000111000
		2r1111000111111111
		2r1111100011000110
		2r1111110001000100
		2r1111111001111100
		2r1111000001101100
		2r1101100011000110
		2r1001100010000010
		2r0000110000000000
		2r0000110000000000
		2r0000011000000000
		2r0000011000000000
		2r0000001100000000
		2r0000001100000000)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:04'!
initialize
	"Create all the standard cursors..."
		self initOrigin.
		self initRightArrow.
		self initMenu.
		self initCorner.
		self initRead.
		self initWrite.
		self initWait.
		BlankCursor _ Cursor new.
		self initXeq.
		self initSquare.
		self initNormalWithMask.
		self initCrossHair.
		self initMarker.
		self initUp.
		self initDown.
		self initMove.
		self initBottomLeft.
		self initBottomRight.
		self initResizeLeft.
		self initResizeTop.
		self initResizeTopLeft.
		self initResizeTopRight.
		self initTopLeft.
		self initTopRight.
		self makeCursorsWithMask.

		"Cursor initialize"
! !

!Cursor class methodsFor: 'class initialization' stamp: 'bf 2/2/1999 19:33'!
makeCursorsWithMask
	"Cursor initialize;makeCursorsWithMask"

	self classPool associationsDo: [:var |
		var value hasMask
			ifFalse: [var value: var value withMask]] ! !

!Cursor class methodsFor: 'class initialization'!
startUp
	self currentCursor: self currentCursor! !


!Cursor class methodsFor: 'constants'!
blank
	"Answer the instance of me that is all white."

	^BlankCursor! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13'!
bottomLeft
	"Cursor bottomLeft showWhile: [Sensor waitButton]"
	^BottomLeftCursor
! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13'!
bottomRight
	"Cursor bottomRight showWhile: [Sensor waitButton]"
	^BottomRightCursor
! !

!Cursor class methodsFor: 'constants'!
corner
	"Answer the instance of me that is the shape of the bottom right corner 
	of a rectangle."

	^CornerCursor! !

!Cursor class methodsFor: 'constants'!
crossHair
	"Answer the instance of me that is the shape of a cross."

	^CrossHairCursor! !

!Cursor class methodsFor: 'constants'!
down
	"Answer the instance of me that is the shape of an arrow facing 
	downward."

	^DownCursor! !

!Cursor class methodsFor: 'constants'!
execute
	"Answer the instance of me that is the shape of an arrow slanted left 
	with a star next to it."

	^XeqCursor! !

!Cursor class methodsFor: 'constants'!
marker
	"Answer the instance of me that is the shape of a small ball."

	^MarkerCursor! !

!Cursor class methodsFor: 'constants'!
menu 
	"Answer the instance of me that is the shape of a menu."

	^MenuCursor! !

!Cursor class methodsFor: 'constants'!
move
	"Answer the instance of me that is the shape of a cross inside a square."

	^MoveCursor! !

!Cursor class methodsFor: 'constants'!
normal
	"Answer the instance of me that is the shape of an arrow slanted left."

	^NormalCursor! !

!Cursor class methodsFor: 'constants'!
origin
	"Answer the instance of me that is the shape of the top left corner of a 
	rectangle."

	^OriginCursor! !

!Cursor class methodsFor: 'constants'!
read
	"Answer the instance of me that is the shape of eyeglasses."

	^ReadCursor! !

!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:48'!
resizeBottom
	"Cursor resizeBottom showWhile: [Sensor waitButton]"
	^self resizeTop! !

!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:46'!
resizeBottomLeft
	"Cursor resizeBottomLeft showWhile: [Sensor waitButton]"
	^self resizeTopRight! !

!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'!
resizeBottomRight
	"Cursor resizeBottomRight showWhile: [Sensor waitButton]"
	^self resizeTopLeft! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 18:58'!
resizeLeft
	"Cursor resizeLeft showWhile: [Sensor waitButton]"
	^ResizeLeftCursor! !

!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'!
resizeRight
	"Cursor resizeRight showWhile: [Sensor waitButton]"
	^self resizeLeft! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:19'!
resizeTop
	"Cursor resizeTop showWhile: [Sensor waitButton]"
	^ResizeTopCursor! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'!
resizeTopLeft
	"Cursor resizeTopLeft showWhile: [Sensor waitButton]"
	^ ResizeTopLeftCursor! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'!
resizeTopRight
	"Cursor resizeTopRight showWhile: [Sensor waitButton]"
	^ResizeTopRightCursor! !

!Cursor class methodsFor: 'constants'!
rightArrow 
	"Answer the instance of me that is the shape of an arrow pointing to the right."

	^RightArrowCursor! !

!Cursor class methodsFor: 'constants'!
square
	"Answer the instance of me that is the shape of a square."

	^SquareCursor! !

!Cursor class methodsFor: 'constants' stamp: 'ar 3/1/2006 22:42'!
target
	"Answer the instance of me that is the shape of a gunsight."
	"Cursor target show"
	^TargetCursor ifNil:[self initTarget]! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:01'!
topLeft
	"Cursor topLeft showWhile: [Sensor waitButton]"
	^ TopLeftCursor! !

!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:02'!
topRight
	"Cursor topRight showWhile: [Sensor waitButton]"
	^ TopRightCursor! !

!Cursor class methodsFor: 'constants'!
up
	"Answer the instance of me that is the shape of an arrow facing upward."

	^UpCursor! !

!Cursor class methodsFor: 'constants' stamp: 'sw 8/15/97 13:28'!
wait
	"Answer the instance of me that is the shape of an Hourglass (was in the 
	shape of three small balls)."

	^WaitCursor! !

!Cursor class methodsFor: 'constants' stamp: 'ar 9/26/2001 22:37'!
webLink
	"Return a cursor that can be used for emphasizing web links"
	"Cursor webLink showWhile: [Sensor waitButton]"
	^WebLinkCursor ifNil:[
		WebLinkCursor _  (CursorWithMask extent: 16@16
			fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 )
			offset: -5@0) setMaskForm:
		(Form extent: 16@16 
			fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 )  collect: [:bits | bits bitShift: 16])
			offset: 0@0)].! !

!Cursor class methodsFor: 'constants'!
write
	"Answer the instance of me that is the shape of a pen writing."

	^WriteCursor! !


!Cursor class methodsFor: 'current cursor'!
currentCursor
	"Answer the instance of Cursor that is the one currently displayed."

	^CurrentCursor! !

!Cursor class methodsFor: 'current cursor' stamp: 'di 10/6/1998 13:57'!
currentCursor: aCursor 
	"Make the instance of cursor, aCursor, be the current cursor. Display it. 
	Create an error if the argument is not a Cursor."

	(aCursor isKindOf: self)
		ifTrue: [CurrentCursor _ aCursor.
				aCursor beCursor]
		ifFalse: [self error: 'The new cursor must be an instance of class Cursor']! !


!Cursor class methodsFor: 'instance creation'!
extent: extentPoint fromArray: anArray offset: offsetPoint 
	"Answer a new instance of me with width and height specified by
	extentPoint, offset by offsetPoint, and bits from anArray.
	NOTE: This has been kluged to take an array of 16-bit constants,
	and shift them over so they are left-justified in a 32-bit bitmap"

	extentPoint = (16 @ 16)
		ifTrue: 
			[^ super
				extent: extentPoint
				fromArray: (anArray collect: [:bits | bits bitShift: 16])
				offset: offsetPoint]
		ifFalse: [self error: 'cursors must be 16@16']! !

!Cursor class methodsFor: 'instance creation' stamp: 'di 10/6/1998 13:53'!
new

	^ self extent: 16 @ 16
		fromArray: (Array new: 16 withAll: 0)
		offset: 0 @ 0

	"Cursor new bitEdit show"! !

!Cursor class methodsFor: 'instance creation' stamp: 'ar 8/16/2001 15:52'!
resizeForEdge: aSymbol
	"Cursor resizeForEdge: #top"
	"Cursor resizeForEdge: #bottomLeft"
	^self perform: ('resize', aSymbol first asString asUppercase, (aSymbol copyFrom: 2 to: aSymbol size)) asSymbol.! !
Cursor subclass: #CursorWithMask
	instanceVariableNames: 'maskForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!CursorWithMask commentStamp: '<historical>' prior: 0!
A Cursor which additionally has a 16x16 transparency bitmap called a "mask".  See the comment of beCursorWithMask: for details on how the mask is treated.!
]style[(97 17 40)f3,f3LCursor beCursorWithMask:;,f3!


!CursorWithMask methodsFor: 'converting' stamp: 'RAA 8/14/2000 10:14'!
asCursorForm
	| form |
	form _ StaticForm extent: self extent depth: 8.
	form fillShape: maskForm fillColor: Color white.
	form fillShape: self fillColor: Color black at: offset negated.
	^ form offset: offset! !


!CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:34'!
hasMask
	^true! !

!CursorWithMask methodsFor: 'mask' stamp: 'di 10/8/1998 16:46'!
maskForm
	^ maskForm! !

!CursorWithMask methodsFor: 'mask' stamp: 'di 10/8/1998 16:46'!
setMaskForm: aForm
	maskForm _ aForm! !

!CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:30'!
storeOn: aStream base: anInteger

	aStream nextPut: $(.
	super storeOn: aStream base: anInteger.
	aStream nextPutAll: ' setMaskForm: '.
	maskForm storeOn: aStream base: anInteger.
	aStream nextPut: $)! !

!CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:31'!
withMask
	^self! !


!CursorWithMask methodsFor: 'primitives' stamp: 'di 10/6/1998 15:16'!
beCursor
	maskForm unhibernate.
	^ self beCursorWithMask: maskForm! !

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

CursorWithMask class
	instanceVariableNames: ''!

!CursorWithMask class methodsFor: 'as yet unclassified' stamp: 'di 2/18/1999 08:56'!
derivedFrom: aForm      "Cursor initNormalWithMask.  Cursor normal show"
	"aForm is presumably a cursor"
	| cursor mask ext |
	ext _ aForm extent.
	cursor _ self extent: ext.
	cursor copy: (1@1 extent: ext) from: 0@0 in: aForm rule: Form over.
	mask _ Form extent: ext.
	(1@1) eightNeighbors do:
		[:p | mask copy: (p extent: ext) from: 0@0 in: aForm rule: Form under].
	cursor setMaskForm: mask.
	cursor offset: ((aForm offset - (1@1)) max: ext negated).
	^ cursor! !
Path subclass: #CurveFitter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!CurveFitter commentStamp: '<historical>' prior: 0!
I represent a conic section determined by three points p1, p2 and p3. I interpolate p1 and p3 and am tangent to line p1, p2 at p1 and line p3, p2 at p3.!


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

	| pa pb k s p1 p2 p3 line |
	line _ Line new.
	line form: self form.
	collectionOfPoints size < 3 ifTrue: [self error: 'Curve must have three points'].
	p1 _ self firstPoint.
	p2 _ self secondPoint.
	p3 _ self thirdPoint.
	s _ Path new.
	s add: p1.
	pa _ p2 - p1.
	pb _ p3 - p2.
	k _ 5 max: pa x abs + pa y abs + pb x abs + pb y abs // 20.
	"k is a guess as to how many line segments to use to approximate 
	the curve."
	1 to: k do: 
		[:i | 
		s add: pa * i // k + p1 * (k - i) + (pb * (i - 1) // k + p2 * (i - 1)) // (k - 1)].
	s add: p3.
	1 to: s size - 1 do: 
		[:i | 
		line beginPoint: (s at: i).
		line endPoint: (s at: i + 1).
		line displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!CurveFitter methodsFor: 'displaying' stamp: '6/9/97 10:16 di'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

	| transformedPath newCurveFitter |
	transformedPath _ aTransformation applyTo: self.
	newCurveFitter _ CurveFitter new.
	newCurveFitter firstPoint: transformedPath firstPoint.
	newCurveFitter secondPoint: transformedPath secondPoint.
	newCurveFitter thirdPoint: transformedPath thirdPoint.
	newCurveFitter form: self form.
	newCurveFitter
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

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

CurveFitter class
	instanceVariableNames: ''!

!CurveFitter class methodsFor: 'examples' stamp: '6/9/97 10:16 di'!
example
	"Designate three locations on the screen by clicking any button. The
	curve determined by the points will be displayed with a long black form."

	| aCurveFitter aForm |  
	aForm _ Form extent: 1@30.			"make a long thin Form for display "
	aForm fillBlack.							"turn it black"
	aCurveFitter _ CurveFitter new.
	aCurveFitter form: aForm.						"set the form for display"
				"collect three Points and show them on the dispaly"
	aCurveFitter firstPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurveFitter firstPoint.
	aCurveFitter secondPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurveFitter secondPoint.
	aCurveFitter thirdPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurveFitter thirdPoint.

	aCurveFitter displayOn: Display					"display the CurveFitter"

	"CurveFitter example"! !


!CurveFitter class methodsFor: 'instance creation'!
new

	| newSelf | 
	newSelf _ super new: 3.
	newSelf add: 0@0.
	newSelf add: 0@0.
	newSelf add: 0@0.
	^newSelf! !
PolygonMorph subclass: #CurveMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!CurveMorph commentStamp: '<historical>' prior: 0!
This is really only a shell for creating Shapes with smooth outlines.!


!CurveMorph methodsFor: 'initialization' stamp: 'di 9/10/2000 14:28'!
initialize

	super initialize.
	self beSmoothCurve.
! !


!CurveMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'!
initializeToStandAlone

	super initializeToStandAlone.
	self beSmoothCurve.
! !


!CurveMorph methodsFor: 'testing' stamp: 'wiz 1/7/2005 20:02'!
isCurvier
	"Test used by smoothing routines.  If true use true closed curve splines for closed curves. If not mimic old stodgy curveMorph curves with one sharp bend. Curve overrides this test for backward compatability.."
	^ (false)! !

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

CurveMorph class
	instanceVariableNames: ''!

!CurveMorph class methodsFor: 'instance creation' stamp: 'tk 11/14/2001 17:47'!
arrowPrototype

	| aa |
	aa _ PolygonMorph vertices: (Array with: 5@40 with: 5@8 with: 35@8 with: 35@40) 
		color: Color black 
		borderWidth: 2 
		borderColor: Color black.
	aa beSmoothCurve; makeOpen; makeForwardArrow.		"is already open"
	aa dashedBorder: {10. 10. Color red}.
		"A dash spec is a 3- or 5-element array with
		{ length of normal border color.
		length of alternate border color.
		alternate border color}"
	aa computeBounds.
	^ aa! !


!CurveMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'!
descriptionForPartsBin
	^ self partName:	'Curve'
		categories:		#('Graphics' 'Basic')
		documentation:	'A smooth wiggly curve, or a curved solid.  Shift-click to get handles and move the points.'! !


!CurveMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 10:15'!
initialize

	self registerInFlapsRegistry.	! !

!CurveMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 10:16'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(CurveMorph		authoringPrototype		'Curve'		'A curve')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(CurveMorph		authoringPrototype		'Curve'		'A curve')
						forFlapNamed: 'Supplies'.]! !

!CurveMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:33'!
unload
	"Unload the receiver from global registries"

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


!CurveMorph class methodsFor: '*MorphicExtras-parts bin' stamp: 'nk 8/23/2004 18:11'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'Curvy Arrow'
		categoryList: #('Basic' 'Graphics')
		documentation: 'A curved line with an arrowhead.  Shift-click to get handles and move the points.'
		globalReceiverSymbol: #CurveMorph
		nativitySelector: #arrowPrototype}
! !
PolygonMorph subclass: #CurvierMorph
	instanceVariableNames: ''
	classVariableNames: 'SlopeConstantsCache'
	poolDictionaries: ''
	category: 'Morphic-Basic-NewCurve'!
!CurvierMorph commentStamp: '<historical>' prior: 0!
I want to be merged into PolygonMorph.
I implement Closed Cubic Curves and restructured routines to ease maintence and development.



New way to calculate curves.

cVariables
SlopeConstantsCache anArray size 2  indexed by nVerts \\2 .
		Each element is an array of integers. The integers represent the constants for
 		calculating slopes for closed cubic curves from the vertices. 




Class Variable SlopeConstantsCache holds a pair of arrays for even and odd number of vertices( aka knots).
Each array holds a series of constants in Integer form.
This allows slopes to be calculated directly from the array of knots.
Wonderfully it turns out that only two arrays are needed.
By matching up the knots equidistant from the point in question;
Summing the weighted differences of the pairs the unscaled slope can be arrived at.
The scale needed to get the slopes needed is trice the reciprical of the next integer in the series.
We leave the division til last to get the full benifit of the integer arithmetic.

Rounding the vertices before calculation is recommended.


Instead of calculating the number of curve subsegments in lineSegDo we add a ninth array to curve state to allow the number to be precalculated.
Getting better looking curves motivates finding a better way of guessing n. So this provides a framework for trying.

For the first pass we just used the constant 12 for every thing.
In the second pass we judge the number of segments by starting with two and doubling the number until the distance of the curve no longer increases.
Then we hone in using a binary search to find the smallest number of segments with that same curve length.


We have changed some assumptions. Previously curves were figured by solving for the second derivative  first and using the results to determine the slope and the third derivative. So lineSegDo counted on the last second deriv being a number it could use in its calculation of the number of subsegments.

Currently we just solve for slopes and the second and third derivs are derived from that. 
Also the derivation for the second and third derivs only assume C(1) (first derivitive continuity). The calculations for the slopes are the only calcs using C(2) continuity. Therefore the slopes can alternately be chosen to fit some other chriteria  and the resulting curves will still be smooth to the first degree.
A useful variant of closed slopes is to scale them by a constant.


Also the last of each element of curvestate always reflects a closing segment. And we don't add an extra row for closed curves anymore. 
That is now lineSegDo's responsibility to be aware of as it was already doing with segmented curves. So the last n does not track its old value.

Preferences:
A Preference has been added to toggle between the old (ugly) closed curves based on natural cubic slopes and the new smooth algorythim. This doesn't make much difference while newcurves are a subclass of polygons but the ambition is for newcurves to supercede polygons. This will allow backwards  compatibility.

Shapes: With closed curves a smooth oval results from rectagular or diamond vertices. So two menuitems have been added (to PolygonMorph) that allow the vertices to be set to these shapes using the current bounds of the polygon. The former state of vertices will be lost but it seems useful to lose a complicated shape and start fresh with a simple symmetrical one. 

Furthur on: Modify curveState to only contain slope and higher deriv information. Let the information about the knots only be held only in the vertices of the polygon. Once that is done curvestate will not have to be recalcutaled each time the polygon is moved but only when its shape changes.

There is also some possible speed up to be had by refining or experimenting with other number of segment calculating schemes but not as much as preserving curvestate over a move.

Furthur furthur on: Figure out how to combine straight and curved segments into a single shape in a pleasing way.

 







!


!CurvierMorph methodsFor: 'initialization' stamp: 'wiz 11/16/2004 21:35'!
initialize
	"We use an oval shape because we wear it well."
	super initialize.
	self beSmoothCurve.
	self diamondOval! !

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

CurvierMorph class
	instanceVariableNames: ''!

!CurvierMorph class methodsFor: 'parts bin' stamp: 'wiz 11/6/2004 23:24'!
descriptionForPartsBin
	"We are very much like curve only better looking."
	^ self
		partName: 'Curvier'
		categories: #('Graphics' 'Basic' )
		documentation: 'A smooth wiggly curve, or a smooth curved solid without bends.  Shift-click to get handles and move the points.'! !


!CurvierMorph class methodsFor: 'class initialization' stamp: 'wiz 11/6/2004 23:16'!
initialize
	"CurvierMorph initialize"
	Preferences
		preferenceAt: #Curvier
		ifAbsent: [Preferences
				addPreference: #Curvier
				category: #morphic
				default: true
				balloonHelp: 'if true, closed CurvierMorphs will be smoother and more symmetrical all about. If false they will mimic the old curve shapes with the one sharp bend.'].
	self registerInFlapsRegistry! !

!CurvierMorph class methodsFor: 'class initialization' stamp: 'wiz 11/6/2004 23:17'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | 
			cl registerQuad: #(#CurvierMorph #authoringPrototype 'Curvier' 'A curve' ) forFlapNamed: 'PlugIn Supplies'.
			cl registerQuad: #(#CurvierMorph #authoringPrototype 'Curvier' 'A curve' ) forFlapNamed: 'Supplies']! !
SelectionMenu subclass: #CustomMenu
	instanceVariableNames: 'labels dividers lastDivider title targets arguments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Menus'!
!CustomMenu commentStamp: '<historical>' prior: 0!
I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages:

	add: aString action: anAction
	addLine

After the menu is constructed, it may be invoked with one of the following messages:

	startUp: initialSelection
	startUp

I am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are:

	items _ an OrderedCollection of strings to appear in the menu
	selectors _ an OrderedCollection of Symbols to be used as message selectors
	lineArray _ an OrderedCollection of line positions
	lastLine _ used to keep track of the last line to avoid making duplicate entries in lineArray!


!CustomMenu methodsFor: 'compatibility' stamp: 'ads 2/20/2003 08:59'!
add: aString subMenu: aMenu target: target selector: aSymbol argumentList: argList
	"Create a sub-menu with the given label. This isn't really a sub-menu the way Morphic does it; it'll just pop up another menu."

	self
		add: aString
		target: aMenu
		selector: #invokeOn:
		argumentList: argList asArray.! !

!CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:23'!
add: aString target: target selector: aSymbol argument: arg
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument."

	self add: aString
		target: target
		selector: aSymbol
		argumentList: (Array with: arg)! !

!CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:18'!
add: aString target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument."

	self add: aString action: aSymbol.
	targets addLast: target.
	arguments addLast: argList asArray
! !

!CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:19'!
addService: aService for: serviceUser
	"Append a menu item with the given service. If the item is selected, it will perform the given service."

	aService addServiceFor: serviceUser toMenu: self.! !

!CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:02'!
addServices2: services for: served extraLines: linesArray

	services withIndexDo: [:service :i |
		service addServiceFor: served toMenu: self.
		(linesArray includes: i)  ifTrue: [self addLine] ]! !

!CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:20'!
addServices: services for: served extraLines: linesArray

	services withIndexDo: [:service :i |
		self addService: service for: served.
		(linesArray includes: i) | service useLineAfter 
			ifTrue: [self addLine]]! !

!CustomMenu methodsFor: 'compatibility' stamp: 'sw 2/16/2002 00:57'!
arguments
	"Answer my arguments, initializing them to an empty collection if they're found to be nil."

	^ arguments ifNil: [arguments _ OrderedCollection new]! !

!CustomMenu methodsFor: 'compatibility' stamp: 'sw 2/16/2002 00:57'!
targets
	"Answer my targets, initializing them to an empty collection if found to be nil"

	^ targets ifNil: [targets _ OrderedCollection new]! !


!CustomMenu methodsFor: 'construction' stamp: 'dhhi 9/14/2000 22:39'!
add: aString action: actionItem
	"Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client."

	| s |
	aString ifNil: [^ self addLine].
	s _ String new: aString size + 2.
	s at: 1 put: Character space.
	s replaceFrom: 2 to: s size - 1 with: aString.
	s at: s size put: Character space.
	labels addLast: s.
	selections addLast: actionItem.! !

!CustomMenu methodsFor: 'construction'!
addLine
	"Append a line to the menu after the last entry. Suppress duplicate lines."

	(lastDivider ~= selections size) ifTrue: [
		lastDivider _ selections size.
		dividers addLast: lastDivider].! !

!CustomMenu methodsFor: 'construction' stamp: 'sw 2/27/2001 07:52'!
addList: listOfTuplesAndDashes
	"Add a menu item to the receiver for each tuple in the given list of the form (<what to show> <selector>). Add a line for each dash (-) in the list.  The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc."

	listOfTuplesAndDashes do: [:aTuple |
		aTuple == #-
			ifTrue: [self addLine]
			ifFalse: [self add: aTuple first action: aTuple second]]

	"CustomMenu new addList: #(
		('apples' buyApples)
		('oranges' buyOranges)
		-
		('milk' buyMilk)); startUp"

! !

!CustomMenu methodsFor: 'construction' stamp: 'sw 8/12/2002 17:14'!
addStayUpItem
	"For compatibility with MenuMorph.  Here it is a no-op"! !

!CustomMenu methodsFor: 'construction' stamp: 'nk 11/25/2003 10:00'!
addTranslatedList: listOfTuplesAndDashes
	"Add a menu item to the receiver for each tuple in the given list of the form (<what to show> <selector>). Add a line for each dash (-) in the list.  The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc.
	The first element will be translated."

	listOfTuplesAndDashes do: [:aTuple |
		aTuple == #-
			ifTrue: [self addLine]
			ifFalse: [self add: aTuple first translated action: aTuple second]]

	"CustomMenu new addTranslatedList: #(
		('apples' buyApples)
		('oranges' buyOranges)
		-
		('milk' buyMilk)); startUp"

! !

!CustomMenu methodsFor: 'construction' stamp: 'sw 7/20/1999 18:47'!
balloonTextForLastItem: aString
	"Vacuous backstop provided for compatibility with MorphicMenu"! !

!CustomMenu methodsFor: 'construction' stamp: 'jm
 8/20/1998 08:34'!
labels: aString font: aFont lines: anArrayOrNil
	"This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."

	| labelList linesArray |
	labelList _ (aString findTokens: String cr) asArray.
	anArrayOrNil
		ifNil: [linesArray _ #()]
		ifNotNil: [linesArray _ anArrayOrNil].
	1 to: labelList size do: [:i |
		self add: (labelList at: i) action: (labelList at: i).
		(linesArray includes: i) ifTrue: [self addLine]].
	font ifNotNil: [font _ aFont].
! !

!CustomMenu methodsFor: 'construction' stamp: 'yo 8/28/2002 22:34'!
labels: labelList lines: linesArray selections: selectionsArray
	"This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."
	"Labels can be either a sting with embedded crs, or a collection of strings."

	| labelArray |
	labelList isString
		ifTrue: [labelArray _ labelList findTokens: String cr]
		ifFalse: [labelArray _ labelList].
	1 to: labelArray size do: [:i |
		self add: (labelArray at: i) action: (selectionsArray at: i).
		(linesArray includes: i) ifTrue: [self addLine]].
! !


!CustomMenu methodsFor: 'initialize-release' stamp: 'sumim 2/10/2002 01:26'!
initialize

	labels _ OrderedCollection new.
	selections _ OrderedCollection new.
	dividers _ OrderedCollection new.
	lastDivider _ 0.
	targets _ OrderedCollection new.
	arguments _ OrderedCollection new	! !

!CustomMenu methodsFor: 'initialize-release' stamp: 'sw 8/18/1998 12:01'!
title: aTitle
	title _ aTitle! !


!CustomMenu methodsFor: 'invocation' stamp: 'sw 2/17/2002 04:48'!
invokeOn: targetObject
	"Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected.  If the chosen selector has arguments, obtain them from my arguments"

	^ self invokeOn: targetObject orSendTo: nil! !

!CustomMenu methodsFor: 'invocation' stamp: 'jm 11/17/97 16:54'!
invokeOn: targetObject defaultSelection: defaultSelection
	"Invoke the menu with the given default selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen."

	| sel |
	sel _ self startUp: defaultSelection.
	sel = nil ifFalse: [
		sel numArgs = 0
			ifTrue: [^ targetObject perform: sel]
			ifFalse: [^ targetObject perform: sel with: nil]].
	^ nil
! !

!CustomMenu methodsFor: 'invocation' stamp: 'sw 11/16/2002 23:45'!
invokeOn: targetObject orSendTo: anObject
	"Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return  nil if no item is selected.  If the chosen selector has arguments, obtain appropriately.  If the recipient does not respond to the resulting message, send it to the alternate object provided"

	| aSelector anIndex recipient |
	^ (aSelector _ self startUp) ifNotNil:
		[anIndex _ self selection.
		recipient _ ((targets _ self targets) isEmptyOrNil or: [anIndex > targets size])
			ifTrue:
				[targetObject]
			ifFalse:
				[targets at: anIndex].
		aSelector numArgs == 0
			ifTrue:
				[recipient perform: aSelector orSendTo: anObject]
			ifFalse:
				[recipient perform: aSelector withArguments: (self arguments at: anIndex)]]! !

!CustomMenu methodsFor: 'invocation'!
startUp
	"Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

	^ self startUp: nil! !

!CustomMenu methodsFor: 'invocation' stamp: 'sw 8/18/1998 12:01'!
startUp: initialSelection
	"Build and invoke this menu with the given initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

	^ self startUp: initialSelection withCaption: title! !

!CustomMenu methodsFor: 'invocation'!
startUp: initialSelection withCaption: caption
	"Build and invoke this menu with the given initial selection and caption. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

	self build.
	(initialSelection notNil) ifTrue: [self preSelect: initialSelection].
	^ super startUpWithCaption: caption! !

!CustomMenu methodsFor: 'invocation' stamp: 'sw 7/31/97 19:31'!
startUpWithCaption: caption
	"Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen; use the provided caption"

	^ self startUp: nil withCaption: caption! !


!CustomMenu methodsFor: '*Morphic-invocation' stamp: 'wiz 7/20/2004 12:20'!
startUpWithCaption: caption at: aPoint 
	"Build and invoke this menu with no initial selection. Answer the  
	selection associated with the menu item chosen by the user or nil if  
	none is chosen; use the provided caption"
	^ self startUp: nil withCaption: caption at: aPoint! !

!CustomMenu methodsFor: '*Morphic-invocation' stamp: 'wiz 7/20/2004 12:18'!
startUp: initialSelection withCaption: caption at: aPoint 
	"Build and invoke this menu with the given initial selection and caption. 
	Answer the selection associated with the menu item chosen by the user 
	or nil if none is chosen."
	self build.
	initialSelection notNil
		ifTrue: [self preSelect: initialSelection].
	^ super startUpWithCaption: caption at: aPoint! !


!CustomMenu methodsFor: 'private' stamp: 'sw 12/10/1999 11:21'!
build
	"Turn myself into an invokable ActionMenu."

	| stream |
	stream _ WriteStream on: (String new).
	labels do: [:label | stream nextPutAll: label; cr].
	(labels isEmpty) ifFalse: [stream skip: -1].  "remove final cr"
	super labels: stream contents
		font: MenuStyle defaultFont
		lines: dividers! !

!CustomMenu methodsFor: 'private' stamp: 'di 4/14/1999 21:28'!
preSelect: action
	"Pre-select and highlight the menu item associated with the given action."

	| i |
	i _ selections indexOf: action ifAbsent: [^ self].
	marker ifNil: [self computeForm].
	marker _ marker
		align: marker topLeft
		with: (marker left)@(frame inside top + (marker height * (i - 1))).
	selection _ i.! !

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

CustomMenu class
	instanceVariableNames: ''!

!CustomMenu class methodsFor: 'example' stamp: 'sw 11/8/1999 17:27'!
example
	"CustomMenu example"

	| menu |
	menu _ CustomMenu new.
	menu add: 'apples' action: #apples.
	menu add: 'oranges' action: #oranges.
	menu addLine.
	menu addLine.  "extra lines ignored"
	menu add: 'peaches' action: #peaches.
	menu addLine.
	menu add: 'pears' action: #pears.
	menu addLine.
	^ menu startUp: #apples


"NB:  The following is equivalent to the above, but uses the compact #fromArray: consruct:
	(CustomMenu fromArray:
		#(	('apples'		apples)
			('oranges'		oranges)
			-
			-
			('peaches'		peaches)
			-
			('pears'			pears)
			-))
				startUp: #apples"! !
Object subclass: #DECTalkReader
	instanceVariableNames: 'stream phonemes durations events currentDuration currentPitch f0Contour'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Support'!

!DECTalkReader methodsFor: 'accessing' stamp: 'len 12/20/1999 03:28'!
defaultDurationFor: aPhoneme
	^ durations at: aPhoneme ifAbsent: [0.080]! !

!DECTalkReader methodsFor: 'accessing' stamp: 'len 12/20/1999 03:04'!
events
	^ events! !

!DECTalkReader methodsFor: 'accessing' stamp: 'len 12/20/1999 03:04'!
phonemes
	^ phonemes! !

!DECTalkReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
stream: aStream
	stream := aStream! !


!DECTalkReader methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	phonemes := PhonemeSet dectalkToArpabet.
	events := CompositeEvent new.
	currentDuration := 80.
	currentPitch := 100.
	f0Contour := CosineInterpolator new.
	durations := Dictionary new.
	#(
	('ae'	230.0	80.0)
	('aa'	240.0	100.0)
	('ax'	120.0	60.0)
	('er'	180.0	80.0)
	('ay'	250.0	150.0)
	('aw'	240.0	100.0)
	('b'		85.0		60.0)
	('ch'	70.0		50.0)
	('d'		75.0		50.0)
	('dh'	50.0		30.0)
	('eh'	150.0	70.0)
	('ea'	270.0	130.0)
	('ey'	180.0	100.0)
	('f'		100.0	80.0)
	('g'		80.0		60.0)
	('hh'	80.0		20.0)
	('ih'	135.0	40.0)
	('ia'	230.0	100.0)
	('iy'	155.0	55.0)
	('jh'	70.0		50.0)
	('k'		80.0		60.0)
	('l'		80.0		40.0)
	('m'		70.0		60.0)
	('n'		60.0		50.0)
	('ng'	95.0		60.0)
"	('oh'	240.0	130.0)"
	('oy'	280.0	150.0)
	('ao'	240.0	130.0)
	('ow'	220.0	80.0)
	('p'		90.0		50.0)
	('r'		80.0		30.0)
	('s'		105.0	60.0)
	('sh'	105.0	80.0)
	('t'		75.0		50.0)
	('th'	90.0		60.0)
	('uh'	210.0	70.0)
	('ua'	230.0	110.0)
	('ah'	160.0	60.0)
	('uw'	230.0	150.0)
	('v'		60.0		40.0)
	('w'		80.0		60.0)
	('y'		80.0		40.0)
	('z'		75.0		40.0)
	('zh'	70.0		40.0)
	('sil'	100.0	100.0)) do: [ :each |
		durations at: (PhonemeSet arpabet at: each first) put: each second / 1000.0]! !


!DECTalkReader methodsFor: 'reading' stamp: 'stephaneducasse 2/3/2006 22:22'!
addPitches
	| offset |
	offset := 0.0.
	events do: [ :each |
		each pitchPoints: (self pitchesBetween: offset and: offset + each duration).
		offset := offset + each duration].! !

!DECTalkReader methodsFor: 'reading' stamp: 'stephaneducasse 2/3/2006 22:22'!
nextPhoneme
	| try try2 phon |
	try := stream next asString.
	(',.;-' includes: try first) ifTrue: [^ phonemes at: 'sil'].
	try2 := try, stream peek asString.
	(phon := phonemes at: try2 ifAbsent: []) notNil ifTrue: [stream next. ^ phon].
	^ phonemes at: try! !

!DECTalkReader methodsFor: 'reading' stamp: 'stephaneducasse 2/3/2006 22:22'!
pitchesBetween: t1 and: t2
	| step |
	step := (t2 - t1 / 0.035) asInteger + 1. "step small enough"
	^ (t1 to: t2 by: t2 - t1 / step) collect: [ :each | each - t1 @ (f0Contour at: each)]! !

!DECTalkReader methodsFor: 'reading' stamp: 'stephaneducasse 2/3/2006 22:22'!
read
	| phoneme time |
	time := 0.
	[stream skipSeparators; atEnd]
		whileFalse: [phoneme := self nextPhoneme.
					currentDuration := self defaultDurationFor: phoneme.
					stream peek = $< ifTrue: [self readPitchAndDuration].
					f0Contour at: time + (currentDuration / 2.0 min: 0.1) put: currentPitch.
					time := time + currentDuration.
					f0Contour at: time put: currentPitch.
					events add: (PhoneticEvent new phoneme: phoneme; duration: currentDuration; loudness: 1.0)].
	self addPitches! !

!DECTalkReader methodsFor: 'reading' stamp: 'stephaneducasse 2/3/2006 22:22'!
readPitchAndDuration
	| tokens code |
	stream next.
	tokens := (stream upTo: $>) findTokens: ','.
	currentDuration := tokens first asNumber / 1000.0.
	tokens size > 1 ifFalse: [^ self].
	code := tokens last asNumber.
	currentPitch := code > "37" 64 ifTrue: [code] ifFalse: [AbstractSound pitchForMIDIKey: 35 + code]! !

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

DECTalkReader class
	instanceVariableNames: ''!

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:14'!
daisy
	"
	DECTalkReader daisy playOn: KlattVoice new delayed: 10000
	"
	^ self eventsFromString: '_<50,22>dey<400,22>ziy<400,19>dey<400,15>ziy<400,10>
gih<200,12>vmiy<200,14>yurr<200,15>ae<400,12>nsax<200,15>
rduw<400,10>.
ay<400,17>mhxae<400,22>fkrey<400,19>ziy<400,15>ao<200,12>
lfao<200,14>rdhax<200,15>lah<400,17>vao<200,19>vyu<400,17>.
ih<200,19>twow<200,20>ntbiy<200,19>ax<200,17>stay<400,22>
lih<200,19>shmae<200,17>rih<400,15>jh<50,15>.
ay<200,17>kae<400,19>ntax<200,15>fow<400,12>rdax<200,15>
kae<200,12>rih<400,10>jh<50,10>.
bah<200,10>tyu<400,15>lluh<200,19>kswiy<400,17>tah<200,10>
pao<400,15>ndhax<200,19>siy<400,17>t<50,17>.
ao<200,17>vax<200,19>bay<200,22>six<200,19>kel<200,15>
bih<400,17>ltfao<200,10>rtuw<800,15>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:48'!
flower
	"
	DECTalkReader flower playOn: KlattVoice new delayed: 15000
	"
	^ self eventsFromString: '_<25,22>ow<200,22>flaw<400,22>rax<200,20>vskao<400,18>
ao<200,18>tlae<800,13>nd<200,13>
weh<200,13>nwih<400,18>lwiy<200,22>siy<800,20>yu<200,20>
rlay<400,18>kax<200,20>geh<1600,22>n<25,22>
dhax<200,22>tfao<300,23>ao<100,22>tae<200,23>nday<400,25>
d<200,25>fao<800,18>r<25,18>
yu<200,13>rwiy<400,20>bih<200,20>t hxih<200,20>ih<200,18>
lae<200,20>ndgleh<400,22>nae<200,23>ndstuh<400,22>dax<200,20>
geh<600,18>nst hxih<800,13>m<200,13>
praw<200,22>deh<300,23>eh<100,22>dwax<200,23>rdzaa<400,25>
aa<200,25>rmih<800,18>ih<200,18>
ae<200,22>ndseh<200,23>eh<200,22>nt hxih<200,20>mhxow<300,22>
ow<100,20>ow<200,18>mwax<800,18>ax<200,18>rdtey<200,18>
thih<400,16>nxkax<200,20>geh<800,18>eh<400,18>n<200,18>
_<600,22>dhax<200,22>hxih<400,22>lzax<200,20>rbey<400,18>
rr<200,18>naw<800,13>
ae<200,13>ndao<400,18>tah<200,22>mliy<800,20>vzlay<200,20>
thih<400,18>kax<200,20>ndstih<800,22>ih<800,22>l<25,22>
ow<200,22>rlae<300,23>nddhax<100,22>tih<200,23>zlao<400,25>
ao<200,25>stnaw<800,18>
wih<200,13>chdhow<400,20>zsow<200,20>diy<200,20>ax<200,18>
lih<200,20>hxeh<400,22>ldhax<200,23>tstuh<400,22>dax<200,20>
geh<400,18>eh<200,18>nst hxih<800,13>m<200,13>
praw<200,22>deh<300,23>eh<100,22>dwax<200,23>rdzaa<400,25>
aa<200,25>rmih<800,18>ih<200,18>
ae<200,22>ndseh<200,23>eh<200,22>nt hxih<200,20>mhxow<300,22>
ow<100,20>ow<200,18>mwax<800,18>ax<200,18>rdtey<200,18>
thih<400,16>nxkax<200,20>geh<1200,18>n<200,18>
_<600,22>dhow<200,22>zdey<400,22>zax<200,20>rpae<400,18>
ae<200,18>stnaw<800,13>
ae<200,13>ndih<400,18>ndhax<200,22>pae<800,20>stdhey<200,20>
mah<400,18>strix<200,20>mey<800,22>ey<800,22>n<25,22>
bah<200,22>twiy<300,23>kae<100,22>nstih<200,23>lray<600,25>
znaw<800,18>
ae<200,13>ndbiy<400,20>dhax<200,20>ney<200,20>shax<200,18>
nax<200,20>geh<400,22>ndhax<200,23>tstuh<400,22>dax<200,20>
geh<600,18>nst hxih<800,13>m<200,13>
praw<200,22>deh<300,23>eh<100,22>dwax<200,23>rdzaa<400,25>
aa<200,25>rmih<800,18>ih<200,18>
ae<200,22>ndseh<200,23>eh<200,22>nt hxih<200,20>mhxow<300,22>
ow<100,20>ow<200,18>mwax<800,18>ax<200,18>rdtey<200,18>
thih<400,16>nxkax<200,20>geh<1200,18>n<200,18>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:43'!
great
	"
	(DECTalkReader great pitchBy: 0.5) playOn: (KlattVoice new tract: 19; flutter: 0.5) delayed: 10000
	"
	^ self eventsFromString: '_<50,20>ax<200,20>_<1>ax<500,22>_<10>ow<300,20>yxeh<1000,17>
say<200,15>mdhax<80,13>grey<1000,15>t_priy<200,17>iy<200,18>
teh<200,17>eh<200,15>ndrr<1600,13>
_<200,13>priy<200,13>teh<1000,22>ndih<200,22>nxdhae<100,22>
day<1000,18>mduh<200,20>ix<200,22>nweh<1600,20>l<600,20>
_<60,25>may<300,25>niy<1200,22>dix<200,22>zsah<1000,24>chay<200,22>
priy<200,24>teh<1000,25>ndtuh<200,22>_<10>uw<200,25>mah<1000,20>ch<100,20>
_<20,20>ay<300,20>mlow<300,20>neliy<800,17>bah<200,13>
tnow<1000,15>wah<200,13>nkae<200,15>nteh<1800,13>l<400,13>
_<50,20>ax<200,20>_<1>ax<500,22>_<1>ow<300,20>yxeh<1000,17>
say<200,15>mdhax<80,13>grey<1000,15>t_priy<200,17>iy<200,18>
teh<200,17>eh<200,15>ndrr<1800,13>
_<10,13>ah<200,13>drih<1000,22>ftih<50,22>nax<200,22>
wrr<1000,18>ldax<200,20>vmay<200,22>ax<200,22>_<1>ow<1400,20>n<600,20>
_<60,25>ay<300,25>pley<1100,22>dhax<200,22>gey<1000,24>
m<100,24>bah<200,22>tuh<200,24>may<1000,25>riy<200,22>ax<200,25>
lshey<600,20>m<400,20>
_<20,20>yu<200,20>vleh<200,20>ftmiy<800,17>tuw<200,13>
driy<800,15>mao<200,13>lah<200,15>low<1600,13>n<400,13>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:25'!
hawaii
	"
	DECTalkReader hawaii playOn: (KlattVoice new tract: 14.4) delayed: 10000
	"
	^ self eventsFromString: '_<300> naa<600,23> ay<300,23>t ae<300,22>nd yuw<1200,23> ,<600>
ae<600,24>nd
bluw<900,25> hxah<300,24> waa<940,23> aa<240,22> aa<240,21> iy<1200,20>
,<600> dhah<600,32> naa<600,33> ay<300,33>t ih<300,32>z hxeh<900,30>
veh<300,22>n liy<1200,25>
,<600> ae<300,30> ae<300,31>nd yu<900,32> aa<300,30>rx
hxeh<440,28> veh<440,28>n tuw<440,25> miy<2400,23> ,<600> lah<900,23>v
liy<300,22> yuw<1200,23> ,<600> ae<600,24>nd bluw<900,25> hxah<300,24>
waa<940,23>-aa<240,22>-aa<240,21>-iy<1200,20>
,<600> wih<600,32>dh ao<900,33>lx dhih<300,32>s lah<880,30> v<40,30>
liy<300,22> neh<1200,25>s
,<600> dheh<300,30> eh<300,31>rx shuh<900,32>d biy<300,27>
lah<4140,28> v<60,28> ,<600> kah<900,25>m wih<300,32>dh miy<1800,30> ,<600>
waa<400,28> ay<200,28>lx dhah<600,25> muw<300,28>n ih<300,25>z aa<300,28>n
dhah<300,25> siy<2400,23> ,<600> dhah<600,24> naa<600,25> ay<300,25>t
ih<300,32>z yxah<1200,30>nx ,<600> ae<600,28>nd sow<600,25>
aa<600,28>rx-wiy<4200,30> ,<600> driy<900,23>mz kah<300,22>m truw<1000,23>
uw<200,23> ,<600> ih<600,24>n
bluw<900,25> hxah<300,24> waa<940,23> aa<240,22> aa<240,21> iy<1200,20>
,<600> ae<600,32>nd maa<600,33> iy<300>n kuh<300,32>d ao<900,30>lx
kah<300,22>m truw<1200,25> ,<600> dhih<300,30> ih<300,31>s mae<900,32>
jhih<330,27>k naa<600,28> ay<350,28>t ah<350,27>v naa<600,28> ay<350,28>ts
,<40> wih<380,27>dh yuw<1000,28>-uw<600,455>-uw<1800,35>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
silentNightDuetExample
	"
	DECTalkReader silentNightDuetExample
	"

	| song1 song2 voice1 voice2 time |
	song1 := DECTalkReader silentNightVoice1.
	song2 := DECTalkReader silentNightVoice2.
	voice1 := KlattVoice new tract: 14.4.
	voice2 := KlattVoice new tract: 18.5; turbulence: 59.
	time := Time millisecondClockValue + 30000. "give it 30 secounds for precomputing"
	song1 playOn: voice1 at: time.
	song2 playOn: voice2 at: time! !

!DECTalkReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
silentNightDuetExample2
	"
	DECTalkReader silentNightDuetExample2
	"

	| song1 song2 voice1 voice2 time |
	song1 := DECTalkReader silentNightVoice1 pitchBy: 0.5.
	song2 := DECTalkReader silentNightVoice2 pitchBy: 0.5.
	voice1 := KlattVoice new tract: 14.4.
	voice2 := KlattVoice new tract: 18.5; turbulence: 59.
	time := Time millisecondClockValue + 30000. "give it 30 secounds for precomputing"
	song1 playOn: voice1 at: time.
	song2 playOn: voice2 at: time! !

!DECTalkReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
silentNightDuetExample3
	"
	DECTalkReader silentNightDuetExample3
	"

	| song1 song2 voice1 voice2 time |
	song1 := DECTalkReader silentNightVoice1 pitchBy: 0.25.
	song2 := DECTalkReader silentNightVoice2 pitchBy: 0.25.
	voice1 := KlattVoice new tract: 18.5; turbulence: 59.
	voice2 := KlattVoice new tract: 20; flutter: 0.5.
	time := Time millisecondClockValue + 30000. "give it 30 secounds for precomputing"
	song1 playOn: voice1 at: time.
	song2 playOn: voice2 at: time! !

!DECTalkReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
silentNightDuetExample4
	"
	DECTalkReader silentNightDuetExample4
	"

	| song1 song2 voice1 voice2 gestural1 gestural2 time |
	song1 := DECTalkReader silentNightVoice1 pitchBy: 0.5.
	song2 := DECTalkReader silentNightVoice2 pitchBy: 0.5.
	gestural1 := GesturalVoice new.
	gestural1 newHead position: 1 @ 50.
	voice1 := (KlattVoice new tract: 14.4) + gestural1.
	gestural2 := GesturalVoice new.
	gestural2 newHead position: 150 @ 50.
	voice2 := (KlattVoice new tract: 18.5; turbulence: 59) + gestural2.
	time := Time millisecondClockValue + 30000. "give it 30 secounds for precomputing"
	song1 playOn: voice1 at: time.
	song2 playOn: voice2 at: time! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/24/1999 04:58'!
silentNightVoice1
	"
	(DECTalkReader silentNightVoice1 pitchBy: 0.5) playOn: KlattVoice new delayed: 1000
	"

	^ self eventsFromString: 'sae<600,32>ay<200,34>leh<400,32>nt nae<600,29>ay<400>t.
hxow<600,32>ow<200,34>liy<400,32> nae<600,29>ay<400>t.
ao<600,39>l ih<200>z kaa<800,36>lm.
ao<600,37>l ih<200>z bray<800,32>t.
raw<600,34>nd yah<400>ng ver<600,37>er<200,36>jhah<400,34>n
mah<600,32>dher<200,32> ae<400>nd chah<600,29>ay<200>ld.
hxow<800,34>liy<400> ih<600,37>nfah<200,36>nt
sow<400,34> teh<600,32>nder<400,34> ae<400,32>nd may<600,29>ld.
sliy<600,39>p ah<400>n hxeh<400,42>vah<400,39>nliy<400,36> piy<1000,37>iy<800,41>s.
sliy<400,37>iy<400,32>p ah<400,29>n hxeh<400,32>vah<400,30>nliy<600,27> piy<1800,25>s.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/24/1999 05:06'!
silentNightVoice2
	"
	(DECTalkReader silentNightVoice2 pitchBy: 0.5) playOn: KlattVoice new delayed: 1000
	"

	^ self eventsFromString: 'sae<600,29>ay<200,30>leh<400,29>nt nae<600,25>ay<400>t.
hxow<600,29>ow<200,30>liy<400,29> nae<600,25>ay<400>t.
ao<600,30>l ih<200>z kaa<800,27>lm.
ao<600,29>l ih<200>z bray<800,29>t.
raw<600,30>nd yah<400>ng ver<600,34>er<200,32>jhah<400,30>n
mah<600,29>dher<200,30> ae<400,29>nd chah<600,25>ay<200>ld.
hxow<800,30>liy<400> ih<600,34>nfah<200,32>nt
sow<400,30> teh<600,29>nder<400,30> ae<400,29>nd may<600,25>ld.
sliy<600,30>p ah<400>n hxeh<400,27>vah<400,30>nliy<400,27> piy<1000,29>iy<800,32>s.
sliy<400,29>iy<400,29>p ah<400,25>n hxeh<400,24>vah<400,24>nliy<600,24> piy<1800,25>s.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:52'!
startrek
	"
	DECTalkReader startrek playOn: KlattVoice new delayed: 15000
	"
	^ self eventsFromString: '_<50,17>dhey<400,17>rsklih<100,17>nxao<100,17>nzao<100,17>
ndhax<100,17>staa<100,20>rbao<100,20>rdbaw<200,17>staa<100,18>
rbao<100,18>rdbaw<200,15>staa<100,17>rbao<100,17>rdbaw<200,13>.

dhey<100,17>rsklih<100,17>nxao<100,17>nzao<100,17>ndhax<100,17>
staa<100,20>rbao<100,20>rdbaw<200,17>staa<100,18>rbao<100,18>
rdbaw<200,15>jhih<400,13>m<50,13>.

_<50,17>ih<400,17>tslay<100,17>fjhih<100,17>mbah<100,17>
tnao<50,20>tax<50,20>zwiy<100,20>now<100,17>ih<200,17>
tnao<50,18>tax<50,18>zwiy<100,18>now<100,15>ih<200,15>
tnao<50,17>tax<50,17>zwiy<100,17>now<100,13>ih<200,13>
t<50,13>.

ih<100,17>tslay<100,17>fjhih<100,17>mbah<100,17>tnao<50,20>
tax<50,20>zwiy<100,20>now<100,17>ih<200,17>tnao<50,18>
tax<50,18>zwiy<100,18>now<100,15>ih<200,15>tkae<200,13>
ptix<200,13>n<50,13>.

_<50,17>ih<400,17>tswah<100,17>rsdhae<100,17>ndhae<100,17>
t_hxiy<100,20>zdeh<200,20>djhih<200,17>mdeh<200,18>djhih<200,15>
mdeh<200,17>djhih<200,13>m<50,13>.

ih<100,17>tswah<100,17>rsdhae<100,17>ndhae<100,17>t_hxiy<100,20>
zdeh<200,20>djhih<200,17>mdeh<200,18>djhih<200,15>mdeh<400,13>
d<50,13>.

_<50,17>wiy<400,17>kah<100,17>mih<100,17>npiy<200,17>
sshuh<100,20>tuh<100,20>kih<200,17>lshuh<100,18>tuh<100,18>
kih<200,15>lshuh<100,17>tuh<100,17>kih<200,13>l<50,13>.

wiy<100,17>kah<100,17>mih<100,17>npiy<200,17>sshuh<100,20>
tuh<100,20>kih<200,17>lshuh<100,18>tuh<100,18>kih<200,15>
lmeh<400,13>n<50,13>.

_<50,17>yxih<400,17>kaa<100,17>naa<100,17>chey<100,17>
njhdhax<50,17>lao<50,20>zax<100,20>fih<100,17>zih<100,17>
kslao<50,18>zax<100,18>fih<100,15>zih<100,15>kslao<50,17>
zax<100,17>fih<100,13>zih<100,13>ks<50,13>.

yxih<400,17>kaa<100,17>naa<100,17>chey<100,17>njhdhax<50,17>
lao<50,20>zax<100,20>fih<100,17>zih<100,17>kslao<50,18>
zax<100,18>fih<100,15>zih<100,15>kskaa<200,13>ptix<200,13>
n<50,13>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:52'!
startrek1
	"
	DECTalkReader startrek1 playOn: KlattVoice new delayed: 5000
	"
	^ self eventsFromString: '_<50,17>dhey<400,17>rsklih<100,17>nxao<100,17>nzao<100,17>
ndhax<100,17>staa<100,20>rbao<100,20>rdbaw<200,17>staa<100,18>
rbao<100,18>rdbaw<200,15>staa<100,17>rbao<100,17>rdbaw<200,13>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:38'!
vermont
	"
	(DECTalkReader vermont pitchBy: 0.5) playOn: (KlattVoice new tract: 18.5; turbulence: 59) delayed: 15000
	"
	^ self eventsFromString: 'peh<400,25> niy<400,23>z ih<400,20>n ah<400,18> striy<1200,20>m
,<400> fao<400,25> lih<400,23>nx liy<500,20>vz ,<100> ah<200,16>v 
sih<200,18> kah<200,20> mao<1000,12>rx ,<200> muw<400,20>n lay<400,18>t
ih<400,16>n vrr<400,13> maa<1200,16>nt ,<400> ay<400,25> siy<400,23> 
fih<400,20>nx grr<400,18> wey<1200,20>vz ,<400> skiy<400,25> trae<300,23>lxz  
,<100> aa<600,20>n ah<200,16> maw<200,18>n tih<200,20>n 
saa<800,12>-ay<200,12>d ,<200> snow<400,20> lay<400,18>t
ih<400,16>n vrr<400,13> maa<1200,16>nt ,<400> teh<200,15> lah<200,15>
grae<200,15>f key<400,15> bah<300,15>lxz ,<100> dhey<200,15> sih<200,15>nx 
daw<400,15>n dhah<200,15> hxay<200,15> wey<300,15> ,<100> ae<200,15>nd
trae<200,15> vuh<200,15>lx iy<200,15>ch beh<500,27>nd,<100> ih<200,25>n 
dhah<200,27> row<1200,24>d ,<400> piy<200,16> pah<200,16>lx hxuw<200,16>
miy<200,16>t ,<200> 
ih<400,16>n-dhih<200,16>s-row<200,16>-mae<400,16>n-tih<160,16>k ,<40> 
seh<200,16> tih<300,16>nx ,<100> aa<200,16>rx sow<200,16>
hxih<200,16>p nah<200,16> tay<400,28>zd ,<200> bay<200,26> dhah<200,28>
lah<900,25>v liy<700,24> ,<200> iy<400,25>v nih<400,23>nx sah<400,20>
mrr<400,18> briy<1200,20>z ,<400> wao<400,25>rx blih<400,23>nx ah<400,20>v
,<200> ah<200,16> meh<200,18> dow<200,20> laa<800,12>rxk ,<400> muw<400,20>n
lay<400,18>t ih<400,16>n vrr<400,13> maa<1300,16>nt ,<400>
iy<40,12>-yuw<280,12> ae<350,13>n day<420,16> ,<60> ae<340,20>nd
muw<380,25>n lay<340,27>t ,<100> ih<500,24>n vrr<540,26> maa<2000,23>nt.'! !


!DECTalkReader class methodsFor: 'instance creation' stamp: 'len 12/20/1999 03:52'!
eventsFromStream: aStream
	^ self new stream: aStream; read; events! !

!DECTalkReader class methodsFor: 'instance creation' stamp: 'len 12/20/1999 03:52'!
eventsFromString: aString
	^ self eventsFromStream: (ReadStream on: aString)! !
PostscriptCanvas subclass: #DSCPostscriptCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Canvases'!
!DSCPostscriptCanvas commentStamp: '<historical>' prior: 0!
I generate multi-page Postscript files, for example of Book morphs.  The goal is to crete Adobe Document Structuring Conventions compliant, but this is currently not the case.
!


!DSCPostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53'!
fullDraw: aMorph 
	(morphLevel = 0 and: [aMorph pagesHandledAutomatically not]) 
		ifTrue: 
			[pages _ pages + 1.
			target
				print: '%%Page: 1 1';
				cr].
	super fullDraw: aMorph.
	morphLevel = 0 
		ifTrue: 
			[ self writeTrailer: pages. ]! !


!DSCPostscriptCanvas methodsFor: 'initialization' stamp: 'nk 1/2/2004 15:36'!
writePSIdentifierRotated: rotateFlag 
	| morphExtent pageExtent |
	target print: '%!!PS-Adobe-2.0'; cr;
		 print: '%%Pages: (atend)'; cr;
		 print: '%%DocumentFonts: (atend)'; cr.
	"Define initialScale so that the morph will fit the page rotated or not"
	savedMorphExtent := morphExtent := rotateFlag
						ifTrue: [psBounds extent transposed]
						ifFalse: [psBounds extent].
	pageExtent := self defaultImageableArea extent asFloatPoint.
	initialScale := (printSpecs isNil
					or: [printSpecs scaleToFitPage])
				ifTrue: [pageExtent x / morphExtent x min: pageExtent y / morphExtent y]
				ifFalse: [1.0].
	target print: '%%BoundingBox: ';
		 write: self defaultImageableArea; cr.
	target print: '%%Title: '; print: self topLevelMorph externalName; cr.
	target print: '%%Creator: '; print: Utilities authorName; cr.
	target print: '%%CreationDate: '; print: Date today asString; space; print: Time now asString; cr.

	target print: '%%Orientation: ';
		
		print: (rotateFlag
				ifTrue: ['Landscape']
				ifFalse: ['Portrait']); cr.
	target print: '%%EndComments'; cr.
! !


!DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 16:53'!
endGStateForMorph: aMorph 
	"position the morph on the page "
	morphLevel
			== (topLevelMorph pagesHandledAutomatically
					ifTrue: [2]
					ifFalse: [1])
		ifTrue:  [ target showpage; print: 'grestore'; cr  ]! !

!DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 6/10/2004 13:19'!
fullDrawBookMorph: aBookMorph
	" draw all the pages in a book morph, but only if it is the top-level morph "

	morphLevel = 1 ifFalse: [^ super fullDrawBookMorph: aBookMorph].

	"Unfortunately, the printable 'pages' of a StackMorph are the cards, but for a BookMorph, they are the pages.  Separate the cases here."
	(aBookMorph isKindOf: StackMorph) 
		ifTrue: [
			aBookMorph cards do: [:aCard |
				aBookMorph goToCard: aCard.	"cause card-specific morphs to be installed"
				pages _ pages + 1.
				target print: '%%Page: '; write: pages; space; write: pages; cr.
				self drawPage: aBookMorph currentPage]]
		ifFalse: [
			aBookMorph pages do: [:aPage |
				pages _ pages + 1.
				target print: '%%Page: '; write: pages; space; write: pages; cr.
				self drawPage: aPage]].
	morphLevel = 0 ifTrue: [ self writeTrailer: pages ].
! !

!DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/1/2004 18:21'!
setupGStateForMorph: aMorph 
	"position the morph on the page "
	morphLevel
			== (topLevelMorph pagesHandledAutomatically
					ifTrue: [2]
					ifFalse: [1])
		ifTrue:  [ self writePageSetupFor: aMorph ]! !


!DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'mpw 9/15/1999 20:14'!
defaultImageableArea
	^ self defaultPageSize insetBy:self defaultMargin.
! !

!DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'di 8/3/2000 14:18'!
defaultMargin  "In Points"
	^ (0.25 * 72) asInteger.
! !

!DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'di 8/5/2000 22:56'!
defaultPageSize
	" This is Letter size in points.  European A4 is 595 @ 842 "
	^ 0 @ 0 extent: ((8.5 @ 11.0) * 72) asIntegerPoint.
! !

!DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 19:56'!
pageBBox
	| pageSize offset bbox trueExtent |
	trueExtent := savedMorphExtent * initialScale.
	"this one has been rotated"
	pageSize := self defaultPageSize.
	offset := pageSize extent - trueExtent / 2 max: 0 @ 0.
	bbox := offset extent: trueExtent.
	^ bbox! !

!DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 12/30/2003 17:22'!
pageOffset
	^self pageBBox origin.
! !
DSCPostscriptCanvas subclass: #DSCPostscriptCanvasToDisk
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Canvases'!

!DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:41'!
morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset

	^self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: nil
! !

!DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 17:39'!
morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil 
	self reset.
	psBounds := offset extent: aMorph bounds extent.
	topLevelMorph := aMorph.
	self writeHeaderRotated: rotateFlag.
	self fullDrawMorph: aMorph.
	^ self close! !

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

DSCPostscriptCanvasToDisk class
	instanceVariableNames: ''!

!DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 16:58'!
morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil

	| newFileName stream |

	^[
		(self new morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset) close
	]
		on: PickAFileToWriteNotification
		do: [ :ex |
			newFileName _ FillInTheBlank
				request: 'Name of file to write:' translated
				initialAnswer: 'xxx',Time millisecondClockValue printString, self defaultExtension. 
			newFileName isEmptyOrNil ifFalse: [
				stream _ FileStream fileNamed: newFileName.
				stream ifNotNil: [ex resume: stream].
			].
		].

! !

!DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:43'!
morphAsPostscript: aMorph rotated: rotateFlag specs: specsOrNil

	^ self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: self baseOffset specs: specsOrNil
! !


!DSCPostscriptCanvasToDisk class methodsFor: 'configuring' stamp: 'RAA 9/16/2000 22:14'!
defaultTarget

	^PostscriptEncoderToDisk stream.
! !


!DSCPostscriptCanvasToDisk class methodsFor: 'testing' stamp: 'RAA 2/22/2001 07:41'!
morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset

	^self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: nil
! !
Object subclass: #DamageRecorder
	instanceVariableNames: 'invalidRects totalRepaint'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!DamageRecorder methodsFor: 'initialization' stamp: 'sma 6/5/2000 11:55'!
reset
	"Clear the damage list."

	invalidRects _ OrderedCollection new: 15.
	totalRepaint _ false
! !


!DamageRecorder methodsFor: 'recording'!
doFullRepaint
	"Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset."

	^ totalRepaint _ true.
! !

!DamageRecorder methodsFor: 'recording'!
invalidRectsFullBounds: aRectangle
	"Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle."

	totalRepaint
		ifTrue: [^ Array with: aRectangle]
		ifFalse: [^ invalidRects copy].

! !

!DamageRecorder methodsFor: 'recording' stamp: 'di 11/17/2001 14:19'!
recordInvalidRect: newRect
	"Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle."
	"Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle."

	| mergeRect a |
	totalRepaint ifTrue: [^ self].  "planning full repaint; don't bother collecting damage"

	invalidRects do:
		[:rect |
		((a _ (rect intersect: newRect) area) > 40
			and: ["Avoid combining a vertical and horizontal rects.
				  Can make a big diff and we only test when likely."
				  a > (newRect area // 4) or: [a > (rect area // 4)]])
			ifTrue:
			["merge rectangle in place (see note below) if there is significant overlap"
			rect setOrigin: (rect origin min: newRect origin) truncated
				corner: (rect corner max: newRect corner) truncated.
			^ self]].


	invalidRects size >= 15 ifTrue:
		["if there are too many separate areas, merge them all"
		mergeRect _ Rectangle merging: invalidRects.
		self reset.
		invalidRects addLast: mergeRect].

	"add the given rectangle to the damage list"
	"Note: We make a deep copy of all rectangles added to the damage list,
		since rectangles in this list may be extended in place."
	invalidRects addLast:
		(newRect topLeft truncated corner: newRect bottomRight truncated).
! !


!DamageRecorder methodsFor: 'testing' stamp: 'dgd 2/22/2003 14:43'!
updateIsNeeded
	"Return true if the display needs to be updated."

	^totalRepaint or: [invalidRects notEmpty]! !

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

DamageRecorder class
	instanceVariableNames: ''!

!DamageRecorder class methodsFor: 'instance creation'!
new

	^ super new reset
! !
Stream subclass: #DataStream
	instanceVariableNames: 'byteStream topCall basePos'
	classVariableNames: 'TypeMap'
	poolDictionaries: ''
	category: 'System-Object Storage'!
!DataStream commentStamp: '<historical>' prior: 0!
This is the save-to-disk facility. A DataStream can store one or more objects in a persistent form.

To handle objects with sharing and cycles, you must use a
ReferenceStream instead of a DataStream.  (Or SmartRefStream.)  ReferenceStream is typically
faster and produces smaller files because it doesn't repeatedly write the same Symbols.

Here is the way to use DataStream and ReferenceStream:
	rr _ ReferenceStream fileNamed: 'test.obj'.
	rr nextPut: <your object>.
	rr close.

To get it back:
	rr _ ReferenceStream fileNamed: 'test.obj'.
	<your object> _ rr next.
	rr close.

Each object to be stored has two opportunities to control what gets stored.  On the high level, objectToStoreOnDataStream allows you to substitute another object on the way out.  The low level hook is storeDataOn:. The read-in counterparts to these messages are comeFullyUpOnReload and (class) readDataFrom:size:. See these methods, and the class DiskProxy, for more information about externalizing and internalizing.

NOTE: A DataStream should be treated as a write-stream for writing.  It is a read-stream for reading.  It is not a ReadWriteStream.
!


!DataStream methodsFor: 'other'!
atEnd
    "Answer true if the stream is at the end."

    ^ byteStream atEnd! !

!DataStream methodsFor: 'other'!
byteStream
	^ byteStream! !

!DataStream methodsFor: 'other'!
close
	"Close the stream."

	| bytes |
	byteStream closed 
		ifFalse: [
			bytes _ byteStream position.
			byteStream close]
		ifTrue: [bytes _ 'unknown'].
	^ bytes! !

!DataStream methodsFor: 'other' stamp: 'nk 3/12/2004 21:56'!
contents
	^byteStream contents! !

!DataStream methodsFor: 'other' stamp: 'yo 12/3/2004 17:14'!
errorWriteReference: anInteger
    "PRIVATE -- Raise an error because this case of nextPut:'s perform:
     shouldn't be called. -- 11/15/92 jhm"

    self error: 'This should never be called'! !

!DataStream methodsFor: 'other'!
flush
    "Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm"

    ^ byteStream flush! !

!DataStream methodsFor: 'other'!
next: anInteger
    "Answer an Array of the next anInteger objects in the stream."
    | array |

    array _ Array new: anInteger.
    1 to: anInteger do: [:i |
        array at: i put: self next].
    ^ array! !

!DataStream methodsFor: 'other' stamp: 'tk 3/5/2002 09:51'!
nextAndClose
	"Speedy way to grab one object.  Only use when we are inside an object binary file.  Do not use for the start of a SmartRefStream mixed code-and-object file."

	| obj |
	obj _ self next.
	self close.
	^ obj! !

!DataStream methodsFor: 'other' stamp: 'ar 2/24/2001 22:45'!
project
	^nil! !

!DataStream methodsFor: 'other'!
reset
    "Reset the stream."

    byteStream reset! !

!DataStream methodsFor: 'other' stamp: 'tk 5/29/97'!
rootObject
	"Return the object at the root of the tree we are filing out.  "

	^ topCall! !

!DataStream methodsFor: 'other' stamp: 'tk 5/29/97'!
rootObject: anObject
	"Return the object at the root of the tree we are filing out.  "

	topCall _ anObject! !

!DataStream methodsFor: 'other' stamp: '6/9/97 08:03 di'!
setStream: aStream
	"PRIVATE -- Initialization method."

	aStream binary.
	basePos _ aStream position.	"Remember where we start.  Earlier part of file contains a class or method file-in.  Allow that to be edited.  We don't deal in absolute file locations."
	byteStream _ aStream.! !

!DataStream methodsFor: 'other' stamp: 'tk 8/18/1998 08:59'!
setStream: aStream reading: isReading
	"PRIVATE -- Initialization method."

	aStream binary.
	basePos _ aStream position.	"Remember where we start.  Earlier part of file contains a class or method file-in.  Allow that to be edited.  We don't deal in absolute file locations."
	byteStream _ aStream.! !

!DataStream methodsFor: 'other'!
size
    "Answer the stream's size."

    ^ byteStream size! !

!DataStream methodsFor: 'other' stamp: 'tk 7/12/1998 13:16'!
vacantRef
	"Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference
	 position' to identify a reference that's not yet filled in. This must be a
	 value that won't be used as an ordinary reference. Cf. outputReference: and
	 readReference. -- 
	 NOTE: We could use a different type ID for vacant-refs rather than writing
		object-references with a magic value. (The type ID and value are
		overwritten by ordinary object-references when weak refs are fullfilled.)"

	^ SmallInteger maxVal! !


!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:14 tk'!
beginInstance: aClass size: anInteger
	"This is for use by storeDataOn: methods.
	 Cf. Object>>storeDataOn:."

		"Addition of 1 seems to make extra work, since readInstance
		has to compensate.  Here for historical reasons dating back
		to Kent Beck's original implementation in late 1988.

		In ReferenceStream, class is just 5 bytes for shared symbol.

		SmartRefStream puts out the names and number of class's instances variables for checking."

	byteStream nextNumber: 4 put: anInteger + 1.

	self nextPut: aClass name! !

!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:12'!
beginReference: anObject
    "We're starting to read anObject. Remember it and its reference
     position (if we care; ReferenceStream cares). Answer the
     reference position."

    ^ 0! !

!DataStream methodsFor: 'write and read'!
getCurrentReference
    "PRIVATE -- Return the currentReference posn.
     Overridden by ReferenceStream."

    ^ 0! !

!DataStream methodsFor: 'write and read' stamp: 'tk 4/8/1999 13:11'!
maybeBeginReference: internalObject
	"Do nothing.  See ReferenceStream|maybeBeginReference:"

	^ internalObject! !

!DataStream methodsFor: 'write and read' stamp: 'ar 4/10/2005 20:31'!
next
	"Answer the next object in the stream."
	| type selector anObject isARefType pos internalObject |

	type _ byteStream next.
	type ifNil: [pos _ byteStream position.	"absolute!!!!"
		byteStream close.	"clean up"
		byteStream position = 0 
			ifTrue: [self error: 'The file did not exist in this directory'] 
			ifFalse: [self error: 'Unexpected end of object file'].
		pos.	"so can see it in debugger"
		^ nil].
	type = 0 ifTrue: [pos _ byteStream position.	"absolute!!!!"
		byteStream close.	"clean up"
		self error: 'Expected start of object, but found 0'.
		^ nil].
	isARefType _ self noteCurrentReference: type.
	selector _ #(readNil readTrue readFalse readInteger	"<-4"
			readStringOld readSymbol readByteArray		"<-7"
			readArray readInstance readReference readBitmap	"<-11"
			readClass readUser readFloat readRectangle readShortInst 	"<-16"
			readString readWordArray readWordArrayForSegment 	"<-19"
			readWordLike readMethod "<-21") at: type.
	selector == 0 ifTrue: [pos _ byteStream position.	"absolute!!!!"
			byteStream close. 
			self error: 'file is more recent than this system'. ^ nil].
	anObject _ self perform: selector. "A method that recursively
		calls next (readArray, readInstance, objectAt:) must save &
		restore the current reference position."
	isARefType ifTrue: [self beginReference: anObject].

		"After reading the externalObject, internalize it.
		 #readReference is a special case. Either:
		   (1) We actually have to read the object, recursively calling
			   next, which internalizes the object.
		   (2) We just read a reference to an object already read and
			   thus already interalized.
		 Either way, we must not re-internalize the object here."
	selector == #readReference ifTrue: [^ anObject].
	internalObject _ anObject comeFullyUpOnReload: self.
	internalObject == String ifTrue:[
		"This is a hack to figure out if we're loading a String class 
		that really should be a ByteString. Note that these days this
		will no longer be necessary since we use #withClassVersion:
		for constructing the global thus using a different classVersion
		will perfectly do the trick."
		((anObject isKindOf: DiskProxy) 
			and:[anObject globalObjectName == #String
			and:[anObject constructorSelector == #yourself]]) ifTrue:[
				internalObject := ByteString]].
	^ self maybeBeginReference: internalObject! !

!DataStream methodsFor: 'write and read' stamp: 'tk 10/4/2000 10:35'!
nextPut: anObject
	"Write anObject to the receiver stream. Answer anObject."
	| typeID selector objectToStore |

	typeID _ self typeIDFor: anObject.
	(self tryToPutReference: anObject typeID: typeID)
		ifTrue: [^ anObject].

	objectToStore _ (self objectIfBlocked: anObject) objectForDataStream: self.
	objectToStore == anObject ifFalse: [typeID _ self typeIDFor: objectToStore].

	byteStream nextPut: typeID.
	selector _ #(writeNil: writeTrue: writeFalse: writeInteger: 
		writeStringOld: writeSymbol: writeByteArray:
		writeArray: writeInstance: errorWriteReference: writeBitmap:
		writeClass: writeUser: writeFloat: writeRectangle: == "<-16 short inst" 
		writeString: writeBitmap: writeBitmap: writeWordLike: 
		writeInstance: "CompiledMethod") at: typeID.
	self perform: selector with: objectToStore.

	^ anObject


"NOTE: If anObject is a reference type (one that we write cross-references to) but its externalized form (result of objectForDataStream:) isn't (e.g. CompiledMethod and ViewState), then we should remember its externalized form
 but not add to 'references'. Putting that object again should just put its
 external form again. That's more compact and avoids seeks when reading.
 But we just do the simple thing here, allowing backward-references for
 non-reference types like nil. So objectAt: has to compensate. Objects that
 externalize nicely won't contain the likes of ViewStates, so this shouldn't
 hurt much.
	 writeReference: -> errorWriteReference:."! !

!DataStream methodsFor: 'write and read'!
nextPutAll: aCollection
    "Write each of the objects in aCollection to the
     receiver stream. Answer aCollection."

    ^ aCollection do: [:each | self nextPut: each]! !

!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:25'!
noteCurrentReference: typeID
    "PRIVATE -- If we support references for type typeID, remember
     the current byteStream position so we can add the next object to
     the 'objects' dictionary, and return true. Else return false.
     This method is here to be overridden by ReferenceStream"

    ^ false! !

!DataStream methodsFor: 'write and read' stamp: ' 
	6/9/97'!
objectAt: anInteger
	"PRIVATE -- Read & return the object at a given stream position.  08:18 tk  anInteger is a relative file position. "
	| savedPosn anObject refPosn |

	savedPosn _ byteStream position.	"absolute"
	refPosn _ self getCurrentReference.	"relative position"

	byteStream position: anInteger + basePos.	"was relative"
	anObject _ self next.

	self setCurrentReference: refPosn.	"relative position"
	byteStream position: savedPosn.		"absolute"
	^ anObject! !

!DataStream methodsFor: 'write and read' stamp: 'tk 3/13/98 22:16'!
objectIfBlocked: anObject
	"We don't do any blocking"

	^ anObject! !

!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:46 tk'!
outputReference: referencePosn
	"PRIVATE -- Output a reference to the object at integer stream position referencePosn (relative to basePos). To output a weak reference to an object not yet written, supply (self vacantRef) for referencePosn."

	byteStream nextPut: 10. "reference typeID"
	byteStream nextNumber: 4 put: referencePosn	"relative position"! !

!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:32 tk'!
readArray
	"PRIVATE -- Read the contents of an Array.
	 We must do beginReference: here after instantiating the Array
	 but before reading its contents, in case the contents reference
	 the Array. beginReference: will be sent again when we return to
	 next, but that's ok as long as we save and restore the current
	 reference position over recursive calls to next."
	| count array refPosn |

	count _ byteStream nextNumber: 4.

	refPosn _ self beginReference: (array _ Array new: count).		"relative pos"
	1 to: count do: [:i |
		array at: i put: self next].
	self setCurrentReference: refPosn.		"relative pos"
	^ array! !

!DataStream methodsFor: 'write and read'!
readBitmap
	"PRIVATE -- Read the contents of a Bitmap."

	^ Bitmap newFromStream: byteStream
	"Note that the reader knows that the size is in long words, but the data is in bytes."! !

!DataStream methodsFor: 'write and read'!
readBoolean
	"PRIVATE -- Read the contents of a Boolean.
	 This is here only for compatibility with old data files."

	^ byteStream next ~= 0! !

!DataStream methodsFor: 'write and read' stamp: 'jm 8/19/1998 17:00'!
readByteArray
	"PRIVATE -- Read the contents of a ByteArray."

	| count |
	count _ byteStream nextNumber: 4.
	^ byteStream next: count  "assume stream is in binary mode"
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 3/24/98 10:29'!
readClass
	"Should never be executed because a DiskProxy, not a clas comes in."

	^ self error: 'Classes should be filed in'! !

!DataStream methodsFor: 'write and read'!
readFalse
    "PRIVATE -- Read the contents of a False."

    ^ false! !

!DataStream methodsFor: 'write and read'!
readFloat
	"PRIVATE -- Read the contents of a Float.
	 This is the fast way to read a Float.
	 We support 8-byte Floats here.  Non-IEEE"

	| new |
	new _ Float new: 2.		"To get an instance"
	new at: 1 put: (byteStream nextNumber: 4).
	new at: 2 put: (byteStream nextNumber: 4).
	^ new! !

!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:12'!
readFloatString
	"PRIVATE -- Read the contents of a Float string.
	 This is the slow way to read a Float--via its string rep'n.
	 It's here for compatibility with old data files."

	^ Float readFrom: (byteStream next: (byteStream nextNumber: 4))! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/8/97'!
readInstance
	"PRIVATE -- Read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
	Let the instance, not the class read the data.  "
	| instSize aSymbol refPosn anObject newClass |

	instSize _ (byteStream nextNumber: 4) - 1.
	refPosn _ self getCurrentReference.
	aSymbol _ self next.
	newClass _ Smalltalk at: aSymbol asSymbol.
	anObject _ newClass isVariable 	"Create object here"
			ifFalse: [newClass basicNew]
			ifTrue: [newClass basicNew: instSize - (newClass instSize)].
	self setCurrentReference: refPosn.  "before readDataFrom:size:"
	anObject _ anObject readDataFrom: self size: instSize.
	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject! !

!DataStream methodsFor: 'write and read'!
readInteger
    "PRIVATE -- Read the contents of a SmallInteger."

    ^ byteStream nextInt32	"signed!!!!!!"! !

!DataStream methodsFor: 'write and read' stamp: 'tk 10/6/2000 14:36'!
readMethod
	"PRIVATE -- Read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
	Let the instance, not the class read the data.  "
	| instSize refPosn newClass className xxHeader nLits byteCodeSizePlusTrailer newMethod lits |

	instSize _ (byteStream nextNumber: 4) - 1.
	refPosn _ self getCurrentReference.
	className _ self next.
	newClass _ Smalltalk at: className asSymbol.

	xxHeader _ self next.
		"nArgs _ (xxHeader >> 24) bitAnd: 16rF."
		"nTemps _ (xxHeader >> 18) bitAnd: 16r3F."
		"largeBit _ (xxHeader >> 17) bitAnd: 1."
	nLits _ (xxHeader >> 9) bitAnd: 16rFF.
		"primBits _ ((xxHeader >> 19) bitAnd: 16r600) + (xxHeader bitAnd: 16r1FF)."
	byteCodeSizePlusTrailer _ instSize - (newClass instSize "0") - (nLits + 1 * 4).

	newMethod _ newClass 
		newMethod: byteCodeSizePlusTrailer
		header: xxHeader.

	self setCurrentReference: refPosn.  "before readDataFrom:size:"
	self beginReference: newMethod.
	lits _ newMethod numLiterals + 1.	"counting header"
	2 to: lits do:
		[:ii | newMethod objectAt: ii put: self next].
	lits*4+1 to: newMethod basicSize do:
		[:ii | newMethod basicAt: ii put: byteStream next].
			"Get raw bytes directly from the file"
	self setCurrentReference: refPosn.  "before returning to next"
	^ newMethod! !

!DataStream methodsFor: 'write and read'!
readNil
    "PRIVATE -- Read the contents of an UndefinedObject."

    ^ nil! !

!DataStream methodsFor: 'write and read' stamp: ' 6/9/97'!
readRectangle
    "Read a compact Rectangle.  Rectangles with values outside +/- 2047 were stored as normal objects (type=9).  They will not come here.  17:22 tk"

	"Encoding is four 12-bit signed numbers.  48 bits in next 6 bytes.  17:24 tk"
	| acc left top right bottom |
	acc _ byteStream nextNumber: 3.
	left _ acc bitShift: -12.
	(left bitAnd: 16r800) ~= 0 ifTrue: [left _ left - 16r1000].	"sign"
	top _ acc bitAnd: 16rFFF.
	(top bitAnd: 16r800) ~= 0 ifTrue: [top _ top - 16r1000].	"sign"

	acc _ byteStream nextNumber: 3.
	right _ acc bitShift: -12.
	(right bitAnd: 16r800) ~= 0 ifTrue: [right _ right - 16r1000].	"sign"
	bottom _ acc bitAnd: 16rFFF.
	(bottom bitAnd: 16r800) ~= 0 ifTrue: [bottom _ bottom - 16r1000].	"sign"
	
    ^ Rectangle left: left right: right top: top bottom: bottom
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/5/2000 11:47'!
readReference
	"Read the contents of an object reference. (Cf. outputReference:)  File is not now positioned at this object."
	| referencePosition |

	^ (referencePosition _ (byteStream nextNumber: 4)) = self vacantRef	"relative"
		ifTrue:  [nil]
		ifFalse: [self objectAt: referencePosition]		"relative pos"! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/8/97'!
readShortInst
	"Read the contents of an arbitrary instance that has a short header.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
	Let the instance, not the class read the data.  "
	| instSize aSymbol refPosn anObject newClass |

	instSize _ (byteStream next) - 1.	"one byte of size"
	refPosn _ self getCurrentReference.
	aSymbol _ self readShortRef.	"class symbol in two bytes of file pos"
	newClass _ Smalltalk at: aSymbol asSymbol.
	anObject _ newClass isVariable 	"Create object here"
			ifFalse: [newClass basicNew]
			ifTrue: [newClass basicNew: instSize - (newClass instSize)].
	self setCurrentReference: refPosn.  "before readDataFrom:size:"
	anObject _ anObject readDataFrom: self size: instSize.
	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject! !

!DataStream methodsFor: 'write and read' stamp: 'tk 7/12/1998 13:32'!
readShortRef
	"Read an object reference from two bytes only.  Original object must be in first 65536 bytes of the file.  Relative to start of data.  vacantRef not a possibility."

	^ self objectAt: (byteStream nextNumber: 2)! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:03'!
readString

	| str |
	byteStream ascii.
	str _ byteStream nextString.
	byteStream binary.
	^ str
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:27'!
readStringOld

   ^ byteStream nextStringOld! !

!DataStream methodsFor: 'write and read'!
readSymbol
    "PRIVATE -- Read the contents of a Symbol."

    ^ self readString asSymbol! !

!DataStream methodsFor: 'write and read'!
readTrue
    "PRIVATE -- Read the contents of a True."

    ^ true! !

!DataStream methodsFor: 'write and read' stamp: 'tk 3/4/1999 22:58'!
readUser
	"Reconstruct both the private class and the instance.  Still used??"

	^ self readInstance.		"Will create new unique class"
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/24/2000 23:20'!
readWordArray
	"PRIVATE -- Read the contents of a WordArray."

	^ WordArray newFromStream: byteStream
	"Size is number of long words."! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/24/2000 23:23'!
readWordArrayForSegment
	"Read the contents of a WordArray ignoring endianness."

	^ WordArrayForSegment newFromStream: byteStream
	"Size is number of long words."! !

!DataStream methodsFor: 'write and read' stamp: 'tk 2/3/2000 21:11'!
readWordLike
	| refPosn aSymbol newClass anObject |
	"Can be used by any class that is bits and not bytes (WordArray, Bitmap, SoundBuffer, etc)."

	refPosn _ self getCurrentReference.
	aSymbol _ self next.
	newClass _ Smalltalk at: aSymbol asSymbol.
	anObject _ newClass newFromStream: byteStream.
	"Size is number of long words."
	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 9/24/2000 15:39'!
replace: original with: proxy
	"We may wish to remember that in some field, the original object is being replaced by the proxy.  For the hybred scheme that collects with a DummyStream and writes an ImageSegment, it needs to hold onto the originals so they will appear in outPointers, and be replaced."

	"do nothing"! !

!DataStream methodsFor: 'write and read'!
setCurrentReference: refPosn
    "PRIVATE -- Set currentReference to refPosn.
     Noop here. Cf. ReferenceStream."! !

!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 16:59'!
tryToPutReference: anObject typeID: typeID
    "PRIVATE -- If we support references for type typeID, and if
       anObject already appears in my output stream, then put a
       reference to the place where anObject already appears. If we
       support references for typeID but didn't already put anObject,
       then associate the current stream position with anObject in
       case one wants to nextPut: it again.
     Return true after putting a reference; false if the object still
       needs to be put.
     For DataStream this is trivial. ReferenceStream overrides this."

    ^ false! !

!DataStream methodsFor: 'write and read' stamp: 'tk 2/20/1999 23:02'!
typeIDFor: anObject
	"Return the typeID for anObject's class.  This is where the tangle of objects is clipped to stop everything from going out.  
	Classes can control their instance variables by defining objectToStoreOnDataStream.
	Any object in blockers is not written out.  See ReferenceStream.objectIfBlocked: and DataStream nextPut:.
	Morphs do not write their owners.  See Morph.storeDataOn:   Each morph tells itself to 'prepareToBeSaved' before writing out."
	
	^ TypeMap at: anObject class ifAbsent: [9 "instance of any normal class"]	
"See DataStream initialize.  nil=1. true=2. false=3. a SmallInteger=4. (a String was 5). a Symbol=6.  a ByteArray=7. an Array=8. other = 9.  a Bitmap=11. a Metaclass=12. a Float=14.  a Rectangle=15. any instance that can have a short header=16.  a String=17 (new format). a WordArray=18."! !

!DataStream methodsFor: 'write and read'!
writeArray: anArray
	"PRIVATE -- Write the contents of an Array."

	byteStream nextNumber: 4 put: anArray size.
	self nextPutAll: anArray.! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:07'!
writeBitmap: aBitmap
	"PRIVATE -- Write the contents of a Bitmap."

	aBitmap writeOn: byteStream
	"Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!!  Reader must know that size is in long words."! !

!DataStream methodsFor: 'write and read'!
writeBoolean: aBoolean
    "PRIVATE -- Write the contents of a Boolean.
     This method is now obsolete."

    byteStream nextPut: (aBoolean ifTrue: [1] ifFalse: [0])! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:06'!
writeByteArray: aByteArray
	"PRIVATE -- Write the contents of a ByteArray."

	byteStream nextNumber: 4 put: aByteArray size.
	"May have to convert types here..."
	byteStream nextPutAll: aByteArray.! !

!DataStream methodsFor: 'write and read' stamp: 'tk 3/24/98 10:27'!
writeClass: aClass
	"Write out a DiskProxy for the class.  It will look up the class's name in Smalltalk in the new sustem.  Never write classes or methodDictionaries as objects.  For novel classes, front part of file is a fileIn of the new class."

	"This method never executed because objectToStoreOnDataStream returns a DiskProxy.  See DataStream.nextPut:"
    ^ self error: 'Write a DiskProxy instead'! !

!DataStream methodsFor: 'write and read'!
writeFalse: aFalse
    "PRIVATE -- Write the contents of a False."! !

!DataStream methodsFor: 'write and read'!
writeFloat: aFloat
	"PRIVATE -- Write the contents of a Float.
	  We support 8-byte Floats here."

	byteStream nextNumber: 4 put: (aFloat at: 1).
	byteStream nextNumber: 4 put: (aFloat at: 2).
! !

!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:07'!
writeFloatString: aFloat
    "PRIVATE -- Write the contents of a Float string.
     This is the slow way to write a Float--via its string rep'n."

    self writeByteArray: (aFloat printString)! !

!DataStream methodsFor: 'write and read'!
writeInstance: anObject
    "PRIVATE -- Write the contents of an arbitrary instance."

    ^ anObject storeDataOn: self! !

!DataStream methodsFor: 'write and read'!
writeInteger: anInteger
	"PRIVATE -- Write the contents of a SmallInteger."

	byteStream nextInt32Put: anInteger	"signed!!!!!!!!!!"! !

!DataStream methodsFor: 'write and read'!
writeNil: anUndefinedObject
    "PRIVATE -- Write the contents of an UndefinedObject."! !

!DataStream methodsFor: 'write and read' stamp: 'jm 7/31/97 16:16'!
writeRectangle: anObject
    "Write the contents of a Rectangle.  See if it can be a compact Rectangle (type=15).  Rectangles with values outside +/- 2047 were stored as normal objects (type=9).  17:22 tk"

	| ok right bottom top left acc |
	ok _ true.
	(right _ anObject right) > 2047 ifTrue: [ok _ false].
	right < -2048 ifTrue: [ok _ false].
	(bottom _ anObject bottom) > 2047 ifTrue: [ok _ false].
	bottom < -2048 ifTrue: [ok _ false].
	(top _ anObject top) > 2047 ifTrue: [ok _ false].
	top < -2048 ifTrue: [ok _ false].
	(left _ anObject left) > 2047 ifTrue: [ok _ false].
	left < -2048 ifTrue: [ok _ false].
	ok _ ok & left isInteger & right isInteger & top isInteger & bottom isInteger.

	ok ifFalse: [
		byteStream skip: -1; nextPut: 9; skip: 0. "rewrite type to be normal instance"
	    ^ anObject storeDataOn: self].

	acc _ ((left bitAnd: 16rFFF) bitShift: 12) + (top bitAnd: 16rFFF).
	byteStream nextNumber: 3 put: acc.
	acc _ ((right bitAnd: 16rFFF) bitShift: 12) + (bottom bitAnd: 16rFFF).
	byteStream nextNumber: 3 put: acc.! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 20:57'!
writeString: aString
	"PRIVATE -- Write the contents of a String."

	byteStream nextStringPut: aString.! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:23'!
writeStringOld: aString
	"PRIVATE -- Write the contents of a String."

	| length |
	aString size < 16384 
		ifTrue: [
			(length _ aString size) < 192
				ifTrue: [byteStream nextPut: length]
				ifFalse: 
					[byteStream nextPut: (length // 256 + 192).
					byteStream nextPut: (length \\ 256)].
			aString do: [:char | byteStream nextPut: char asciiValue]]
		ifFalse: [self writeByteArray: aString].	"takes more space"! !

!DataStream methodsFor: 'write and read'!
writeSymbol: aSymbol
    "PRIVATE -- Write the contents of a Symbol."

    self writeString: aSymbol! !

!DataStream methodsFor: 'write and read'!
writeTrue: aTrue
    "PRIVATE -- Write the contents of a True."! !

!DataStream methodsFor: 'write and read'!
writeUser: anObject
    "Write the contents of an arbitrary User instance (and its devoted class)."
    " 7/29/96 tk"

	"If anObject is an instance of a unique user class, will lie and say it has a generic class"
    ^ anObject storeDataOn: self! !

!DataStream methodsFor: 'write and read' stamp: 'tk 2/5/2000 21:53'!
writeWordLike: aWordArray
	"Note that we put the class name before the size."

	self nextPut: aWordArray class name.
	aWordArray writeOn: byteStream
	"Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!!  Reader must know that size is in long words or double-bytes."! !

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

DataStream class
	instanceVariableNames: ''!

!DataStream class methodsFor: 'as yet unclassified'!
example
    "An example and test of DataStream/ReferenceStream.
     11/19/92 jhm: Use self testWith:."
    "DataStream example"
    "ReferenceStream example"
    | input sharedPoint |

    "Construct the test data."
    input _ Array new: 9.
    input at: 1 put: nil.
    input at: 2 put: true.
    input at: 3 put: (Form extent: 63 @ 50 depth: 8).
		(input at: 3) fillWithColor: Color lightBlue.
    input at: 4 put: #(3 3.0 'three').
    input at: 5 put: false.
    input at: 6 put: 1024 @ -2048.
    input at: 7 put: #x.
    input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)).
    input at: 9 put: sharedPoint.

    "Write it out, read it back, and return it for inspection."
    ^ self testWith: input! !

!DataStream class methodsFor: 'as yet unclassified'!
exampleWithPictures
	"DataStream exampleWithPictures"
	| file result |
	file _ FileStream fileNamed: 'Test-Picture'.
	file binary.
	(DataStream on: file) nextPut: (Form fromUser).
	file close.

	file _ FileStream fileNamed: 'Test-Picture'.
	file binary.
	result _ (DataStream on: file) next.
	file close.
	result display.
	^ result! !

!DataStream class methodsFor: 'as yet unclassified'!
fileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"

	| strm |
	strm _ self on: (FileStream fileNamed: aString).		"will be binary"
	strm byteStream setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	^ strm! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 22:17'!
initialize
	"TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats.  nextPut: writes these IDs to the data stream.  NOTE: Changing these type ID numbers will invalidate all extant data stream files.  Adding new ones is OK.  
	Classes named here have special formats in the file.  If such a class has a subclass, it will use type 9 and write correctly.  It will just be slow.  (Later write the class name in the special format, then subclasses can use the type also.)
	 See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"
	"DataStream initialize"

	| refTypes t |
	refTypes _ OrderedCollection new.
	t _ TypeMap _ Dictionary new: 80. "sparse for fast hashing"

	t at: UndefinedObject put: 1.   refTypes add: 0.
	t at: True put: 2.   refTypes add: 0.
	t at: False put: 3.   refTypes add: 0.
	t at: SmallInteger put: 4.	 refTypes add: 0.
	t at: ByteString put: 5.   refTypes add: 1.
	t at: ByteSymbol put: 6.   refTypes add: 1.
	t at: ByteArray put: 7.   refTypes add: 1.
	t at: Array put: 8.   refTypes add: 1.
	"(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)"
		refTypes add: 1.
	"(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)"
		refTypes add: 0.
	t at: Bitmap put: 11.   refTypes add: 1.
	t at: Metaclass put: 12.   refTypes add: 0.
	"Type ID 13 is used for HyperSqueak User classes that must be reconstructed."
		refTypes add: 1.
	t at: Float put: 14.  refTypes add: 1.
	t at: Rectangle put: 15.  refTypes add: 1.	"Allow compact Rects."
	"type ID 16 is an instance with short header.  See beginInstance:size:"
		refTypes add: 1.
self flag: #ByteArray.
	t at: ByteString put: 17.   refTypes add: 1.	"new String format, 1 or 4 bytes of length"
	t at: WordArray put: 18.  refTypes add: 1.	"bitmap-like"
	t at: WordArrayForSegment put: 19.  refTypes add: 1.		"bitmap-like"
	t at: SoundBuffer put: 20.  refTypes add: 1.	"And all other word arrays, both 
		16-bit and 32-bit.  See methods in ArrayedCollection.  Overridden in SoundBuffer."
	t at: CompiledMethod put: 21.  refTypes add: 1.	"special creation method"
	"t at:  put: 22.  refTypes add: 0."
	ReferenceStream refTypes: refTypes.		"save it"

	"For all classes that are like WordArrays, store them the way ColorArray is stored.  As bits, and able to change endianness."
	Smalltalk do: [:cls |
		cls isInMemory ifTrue: [
			cls isBehavior ifTrue: [
				cls isPointers not & cls isVariable & cls isWords ifTrue: [
					(t includesKey: cls) ifFalse: [t at: cls put: 20]]]]].! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'di 2/15/98 14:03'!
new
	^ self basicNew! !

!DataStream class methodsFor: 'as yet unclassified'!
newFileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"

	| strm |
	strm _  self on: (FileStream newFileNamed: aString).		"will be binary"
	strm byteStream setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	^ strm! !

!DataStream class methodsFor: 'as yet unclassified'!
oldFileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream oldFileNamed: 'test.obj'.
^ rr nextAndClose.
"

	| strm ff |
	ff _ FileStream oldFileOrNoneNamed: aString.
	ff ifNil: [^ nil].
	strm _ self on: (ff binary).
	^ strm! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'di 6/24/97 00:18'!
on: aStream
	"Open a new DataStream onto a low-level I/O stream."

	^ self basicNew setStream: aStream
		"aStream binary is in setStream:"
! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 08:38'!
streamedRepresentationOf: anObject

	| file |
	file _ (RWBinaryOrTextStream on: (ByteArray new: 5000)).
	file binary.
	(self on: file) nextPut: anObject.
	^file contents! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'jm 12/3/97 19:36'!
testWith: anObject
	"As a test of DataStream/ReferenceStream, write out anObject and read it back.
	11/19/92 jhm: Set the file type. More informative file name."
	"DataStream testWith: 'hi'"
	"ReferenceStream testWith: 'hi'"
	| file result |

	file _ FileStream fileNamed: (self name, ' test').
	file binary.
	(self on: file) nextPut: anObject.
	file close.

	file _ FileStream fileNamed: (self name, ' test').
	file binary.
	result _ (self on: file) next.
	file close.
	^ result! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 08:33'!
unStream: aString

	^(self on: ((RWBinaryOrTextStream with: aString) reset; binary)) next! !
Vocabulary subclass: #DataType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!
!DataType commentStamp: 'sw 8/22/2002 15:01' prior: 0!
A Vocabulary representing typed data.!


!DataType methodsFor: 'initial value' stamp: 'sw 9/26/2001 12:00'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ 'no value'! !


!DataType methodsFor: 'queries' stamp: 'mir 7/15/2004 10:34'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	"^ (self class == DataType) not"  "i.e. subclasses yes, myself no"
	"Assuming this is an abstract class"
	^true! !


!DataType methodsFor: '*eToys-color' stamp: 'sw 8/28/2004 20:30'!
subduedColorFromTriplet: anRGBTriplet
	"Currently:  as an expedient, simply return a standard system-wide constant; this is used only for the border-color of tiles...
	Formerly:  Answer a subdued color derived from the rgb-triplet to use as a tile color."

	^ ScriptingSystem standardTileBorderColor
"
	^ (Color fromRgbTriplet: anRGBTriplet) mixed: ScriptingSystem colorFudge with: ScriptingSystem uniformTileInteriorColor"! !


!DataType methodsFor: '*eToys-initialization' stamp: 'sw 9/27/2001 17:32'!
setFormatForDisplayer: aDisplayer
	"Set up the displayer to have the right format characteristics"

	aDisplayer useDefaultFormat.
	aDisplayer growable: true
	! !


!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:36'!
addExtraItemsToMenu: aMenu forSlotSymbol: slotSym
	"If the receiver has extra menu items to add to the slot menu, here is its chance to do it"! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:38'!
addUserSlotItemsTo: aMenu slotSymbol: slotSym
	"Optionally add items to the menu that pertain to a user-defined slot of the given symbol"
! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 1/12/2005 08:35'!
addWatcherItemsToMenu: aMenu forGetter: aGetter
	"Add watcher items to the menu if appropriate, provided the getter is not an odd-ball one for which a watcher makes no sense"

	(Vocabulary gettersForbiddenFromWatchers includes: aGetter) ifFalse:
		[aMenu add: 'simple watcher' translated selector: #tearOffUnlabeledWatcherFor: argument: aGetter.
		aMenu add: 'detailed watcher' translated selector: #tearOffFancyWatcherFor: argument: aGetter.
		aMenu addLine]! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 02:29'!
affordsCoercionToBoolean
	"Answer true if a tile of this data type, when dropped into a pane that demands a boolean, could plausibly be expanded into a comparison (of the form  frog < toad   or frog = toad) to provide a boolean expression"

	^ true! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 02:53'!
comparatorForSampleBoolean
	"Answer the comparator to use in tile coercions involving the receiver; normally, the equality comparator is used but NumberType overrides"

	^ #=! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 13:15'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ 'arg' newTileMorphRepresentative typeColor: self typeColor! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:37'!
newReadoutTile
	"Answer a tile that can serve as a readout for data of this type"

	^ StringReadoutTile new typeColor: Color lightGray lighter! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 1/4/2005 00:45'!
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter
	"Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter"

	| aTile displayer actualSetter |
	actualSetter _ setter ifNotNil:
		[(#(none #nil unused) includes: setter) ifTrue: [nil] ifFalse: [setter]].

	aTile _ self newReadoutTile.

	displayer _ UpdatingStringMorph new
		getSelector: getter;
		target: aTarget;
		growable: true;
		minimumWidth: 24;
		putSelector: actualSetter.
	"Note that when typeSymbol = #number, the #target: call above will have dealt with floatPrecision details"

	self setFormatForDisplayer: displayer.
	aTile addMorphBack: displayer.
	(actualSetter notNil and: [self wantsArrowsOnTiles]) ifTrue: [aTile addArrows].	
	getter numArgs == 0 ifTrue:
		[aTile setLiteralInitially: (aTarget perform: getter)].
	^ aTile
! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:33'!
wantsArrowsOnTiles
	"Answer whether this data type wants up/down arrows on tiles representing its values"

	^ true! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/26/2001 03:11'!
wantsAssignmentTileVariants
	"Answer whether an assignment tile for a variable of this type should show variants to increase-by, decrease-by, multiply-by.  NumberType says yes, the rest of us say no"

	^ false! !

!DataType methodsFor: '*eToys-tiles' stamp: 'sw 9/26/2001 03:18'!
wantsSuffixArrow
	"Answer whether a tile showing data of this type would like to have a suffix arrow"

	^ false! !
Timespan subclass: #Date
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'ChronologyConstants'
	category: 'Kernel-Chronology'!
!Date commentStamp: '<historical>' prior: 0!
Instances of Date are Timespans with duration of 1 day.
Their default creation assumes a start of midnight in the local time zone.!


!Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:07'!
mmddyyyy
	"Answer the receiver rendered in standard U.S.A format mm/dd/yyyy.
	Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, 
	so that for example February 1 1996 is 2/1/96"


	^ self printFormat: #(2 1 3 $/ 1 1)! !

!Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:06'!
printFormat: formatArray 
	"Answer a String describing the receiver using the argument formatArray."

	| aStream |
	aStream _ WriteStream on: (String new: 16).
	self printOn: aStream format: formatArray.
	^ aStream contents! !

!Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'!
printOn: aStream

	self printOn: aStream format: #(1 2 3 $  3 1 )! !

!Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:05'!
printOn: aStream format: formatArray 
	"Print a description of the receiver on aStream using the format 
	denoted the argument, formatArray: 
	
		#(item item item sep monthfmt yearfmt twoDigits) 
	
		items: 1=day 2=month 3=year will appear in the order given, 
	
		separated by sep which is eaither an ascii code or character. 
	
		monthFmt: 1=09 2=Sep 3=September 
	
		yearFmt: 1=1996 2=96 
	
		digits: (missing or)1=9 2=09. 
	
	See the examples in printOn: and mmddyy"
	| gregorian twoDigits element monthFormat |
	gregorian _ self dayMonthYearDo: [ :d :m :y | {d. m. y} ].
	twoDigits _ formatArray size > 6 and: [(formatArray at: 7) > 1].
	1 to: 3 do: 
		[ :i | 
			element := formatArray at: i.
			element = 1
				ifTrue: [twoDigits
						ifTrue: [aStream
								nextPutAll: (gregorian first asString
										padded: #left
										to: 2
										with: $0)]
						ifFalse: [gregorian first printOn: aStream]].
			element = 2
				ifTrue: [monthFormat := formatArray at: 5.
					monthFormat = 1
						ifTrue: [twoDigits
								ifTrue: [aStream
										nextPutAll: (gregorian middle asString
												padded: #left
												to: 2
												with: $0)]
								ifFalse: [gregorian middle printOn: aStream]].
					monthFormat = 2
						ifTrue: [aStream
								nextPutAll: ((Month nameOfMonth: gregorian middle)
										copyFrom: 1
										to: 3)].
					monthFormat = 3
						ifTrue: [aStream
								nextPutAll: (Month nameOfMonth: gregorian middle)]].
			element = 3
				ifTrue: [(formatArray at: 6)
							= 1
						ifTrue: [gregorian last printOn: aStream]
						ifFalse: [aStream
								nextPutAll: ((gregorian last \\ 100) asString
										padded: #left
										to: 2
										with: $0)]].
			i < 3
				ifTrue: [(formatArray at: 4)
							~= 0
						ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]]
! !

!Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'!
storeOn: aStream

	aStream print: self printString; nextPutAll: ' asDate'! !

!Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:04'!
yyyymmdd
	"Format the date in ISO 8601 standard like '2002-10-22'."

	^ self printFormat: #(3 2 1 $- 1 1 2)! !


!Date methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:09'!
addDays: dayCount 

	^ (self asDateAndTime + (dayCount days)) asDate! !

!Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:08'!
asSeconds
	"Answer the seconds since the Squeak epoch: 1 January 1901"

	^ start asSeconds! !

!Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:08'!
leap
	"Answer whether the receiver's year is a leap year."

	^ start isLeapYear ifTrue: [1] ifFalse: [0].! !

!Date methodsFor: 'smalltalk-80' stamp: 'brp 1/16/2004 14:30'!
previous: dayName 
	"Answer the previous date whose weekday name is dayName."

	| days |
	days _ 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7.
	days = 0 ifTrue: [ days _ 7 ].
	^ self subtractDays: days
! !

!Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:09'!
subtractDate: aDate 
	"Answer the number of days between self and aDate"

	^ (self start - aDate asDateAndTime) days! !

!Date methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:05'!
subtractDays: dayCount 

	^ (self asDateAndTime - (dayCount days)) asDate! !

!Date methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'!
weekday
	"Answer the name of the day of the week on which the receiver falls."

	^ self dayOfWeekName! !

!Date methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'!
weekdayIndex
	"Sunday=1, ... , Saturday=7"

	^ self dayOfWeek! !


!Date methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:10'!
asDate

	^ self! !

!Date methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:10'!
dayMonthYearDo: aBlock 
	"Supply integers for day, month and year to aBlock and return the result"

	^ start dayMonthYearDo: aBlock! !

!Date methodsFor: 'squeak protocol' stamp: 'avi 2/21/2004 18:12'!
month
	^ self asMonth! !

!Date methodsFor: 'squeak protocol' stamp: 'avi 2/29/2004 13:10'!
monthIndex
	^ super month! !


!Date methodsFor: 'utils' stamp: 'tbn 7/11/2006 10:30'!
addMonths: monthCount 
	|year month maxDaysInMonth day |
	year := self year + (monthCount + self monthIndex - 1 // 12).
	month := self monthIndex + monthCount - 1 \\ 12 + 1.
	maxDaysInMonth := Month daysInMonth: month forYear: year.
	day := self dayOfMonth > maxDaysInMonth
				ifTrue: [maxDaysInMonth]
				ifFalse: [self dayOfMonth].
	^ Date
		newDay: day
		month: month
		year: year! !

!Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'!
onNextMonth

	^ self addMonths: 1
! !

!Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'!
onPreviousMonth

	^ self addMonths: -1
! !

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

Date class
	instanceVariableNames: ''!

!Date class methodsFor: 'general inquiries' stamp: 'BG 3/16/2005 14:57'!
easterDateFor: year

 "  compute the easter date.
    source: Physikalisch-Technische Bundesanstalt Braunschweig.
    Lichtenberg, H.: Zur Interpretation der Gaussschen Osterformel
                     und ihrer Ausnahmeregeln,
                     Historia Mathematica 24 (1997), pp. 441-444
  
    http://www.ptb.de/de/org/4/44/441/oste.htm
  "

  | k m s a d r og sz oe day |

  k := year // 100.
  m := 15 + (3*k + 3//4) - (8*k + 13//25).
   s := 2 - (3*k + 3// 4).
  a := year \\ 19.
  d := 19*a + m \\ 30.
  r := d//29 + ((d//28) - (d//29)* (a// 11)).

  og := 21 + d - r.
  sz := 7 - (year//4 + year + s\\7).
  oe := 7 - (og - sz\\7).
  day := og + oe.
  ^day <= 31
    ifTrue: [Date newDay: day month: 3 year: year ]
    ifFalse: [Date newDay: day - 31 month: 4 year: year].! !

!Date class methodsFor: 'general inquiries' stamp: 'BG 3/16/2005 14:48'!
orthodoxEasterDateFor: year

 "  compute the easter date according to the rules of the orthodox calendar.
    source: 
    http://www.smart.net/~mmontes/ortheast.html 
  "
     | r1 r2 r3 r4 ra rb r5 rc date |

    r1 := year \\ 19.
    r2 := year \\ 4.
    r3 := year \\ 7.
    ra := 19*r1 + 16.
    r4 := ra \\ 30.
    rb := r2 + r2 + (4*r3) + (6*r4).
    r5 := rb \\ 7.
    rc := r4 + r5.
    date := Date newDay: 3 month: 4 year: year.
    ^date addDays: rc.! !


!Date class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00'!
dateAndTimeNow
	"Answer an Array whose with Date today and Time now."

	^ Time dateAndTimeNow! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:35'!
dayOfWeek: dayName 

	^ Week indexOfDay: dayName! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:59'!
daysInMonth: monthName forYear: yearInteger 

	^ Month daysInMonth: monthName forYear: yearInteger.
! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:53'!
daysInYear: yearInteger 

	^ Year daysInYear: yearInteger.! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 1/16/2004 14:35'!
firstWeekdayOfMonth: month year: year
	"Answer the weekday index of the first day in <month> in the <year>."

	^ (self newDay: 1 month: month year: year) weekdayIndex
! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'!
fromDays: dayCount 
	"Days since 1 January 1901"

	^ self julianDayNumber: dayCount + SqueakEpoch! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:02'!
fromSeconds: seconds
	"Answer an instance of me which is 'seconds' seconds after January 1, 1901."

	^ self fromDays: ((Duration seconds: seconds) days)! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:39'!
indexOfMonth: aMonthName 

	^ Month indexOfMonth: aMonthName.
! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:56'!
leapYear: yearInteger 

	^ Year leapYear: yearInteger! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:37'!
nameOfDay: dayIndex 

	^ Week nameOfDay: dayIndex ! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:40'!
nameOfMonth: anIndex 

	^ Month nameOfMonth: anIndex.
! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:02'!
newDay: day month: month year: year 

	^ self year: year month: month day: day! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'!
newDay: dayCount year: yearInteger

	^ self year: yearInteger day: dayCount! !

!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'!
today

	^ self current! !


!Date class methodsFor: 'squeak protocol' stamp: 'md 7/15/2006 18:06'!
fromString: aString
	"Answer an instance of created from a string with format mm.dd.yyyy."

	^ self readFrom: aString readStream.! !

!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 18:25'!
julianDayNumber: aJulianDayNumber

	^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber)! !

!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 09:21'!
readFrom: aStream 
	"Read a Date from the stream in any of the forms:  
	
		<day> <monthName> <year>		(5 April 1982; 5-APR-82)  
	
		<monthName> <day> <year>		(April 5, 1982)  
	
		<monthNumber> <day> <year>		(4/5/82) 
			<day><monthName><year>			(5APR82)"
	| day month year |
	aStream peek isDigit
		ifTrue: [day := Integer readFrom: aStream].
	[aStream peek isAlphaNumeric]
		whileFalse: [aStream skip: 1].
	aStream peek isLetter
		ifTrue: ["number/name... or name..."
			month := WriteStream
						on: (String new: 10).
			[aStream peek isLetter]
				whileTrue: [month nextPut: aStream next].
			month := month contents.
			day isNil
				ifTrue: ["name/number..."
					[aStream peek isAlphaNumeric]
						whileFalse: [aStream skip: 1].
					day := Integer readFrom: aStream]]
		ifFalse: ["number/number..."
			month := Month nameOfMonth: day.
			day := Integer readFrom: aStream].
	[aStream peek isAlphaNumeric]
		whileFalse: [aStream skip: 1].
	year := Integer readFrom: aStream.
	year < 10 ifTrue: [year := 2000 + year] 
		ifFalse: [ year < 1900 ifTrue: [ year := 1900 + year]].

	^ self
		year: year
		month: month
		day: day! !

!Date class methodsFor: 'squeak protocol' stamp: 'BP 3/23/2001 12:36'!
starting: aDateAndTime

	^super starting: (aDateAndTime midnight) duration: (Duration days: 1)
! !

!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 18:09'!
tomorrow

	^ self today next! !

!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 22:03'!
year: year day: dayOfYear

	^ self starting: (DateAndTime year: year day: dayOfYear)
! !

!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 22:02'!
year: year month: month day: day

	^ self starting: (DateAndTime year: year month: month day: day)
! !

!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 18:09'!
yesterday

	^ self today previous! !
Magnitude subclass: #DateAndTime
	instanceVariableNames: 'seconds offset jdn nanos'
	classVariableNames: 'LocalTimeZone'
	poolDictionaries: 'ChronologyConstants'
	category: 'Kernel-Chronology'!
!DateAndTime commentStamp: 'brp 5/13/2003 08:07' prior: 0!
I represent a point in UTC time as defined by ISO 8601. I have zero duration.


My implementation uses three SmallIntegers
 and a Duration:
jdn		- julian day number.
seconds	- number of seconds since midnight.
nanos	- the number of nanoseconds since the second.

offset	- duration from UTC.

The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping.
!


!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 7/9/2005 08:45'!
+ operand
	"operand conforms to protocol Duration"

	| ticks |
 	ticks _ self ticks + (operand asDuration ticks) .

	^ self class basicNew
		ticks: ticks
		offset: self offset; 
		yourself.
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 1/9/2004 05:39'!
- operand
	"operand conforms to protocol DateAndTime or protocol Duration"

	^ (operand respondsTo: #asDateAndTime)
		ifTrue: 
			[ | lticks rticks |
			lticks _ self asLocal ticks.
	
		rticks _ operand asDateAndTime asLocal ticks.
			Duration
 				seconds: (SecondsInDay *(lticks first - rticks first)) + 
							(lticks second - rticks second)
 				nanoSeconds: (lticks third - rticks third) ]
	
	ifFalse:
		
 	[ self + (operand negated) ].
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 09:09'!
< comparand
	"comparand conforms to protocol DateAndTime,
	or can be converted into something that conforms."
	| lticks rticks comparandAsDateAndTime |
	comparandAsDateAndTime := comparand asDateAndTime.
	offset = comparandAsDateAndTime offset
		ifTrue: [lticks := self ticks.
			rticks := comparandAsDateAndTime ticks]
		ifFalse: [lticks := self asUTC ticks.
			rticks := comparandAsDateAndTime asUTC ticks].
	^ lticks first < rticks first
		or: [lticks first > rticks first
				ifTrue: [false]
				ifFalse: [lticks second < rticks second
						or: [lticks second > rticks second
								ifTrue: [false]
								ifFalse: [lticks third < rticks third]]]]
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 7/28/2004 16:14'!
= comparand
	"comparand conforms to protocol DateAndTime,
	or can be converted into something that conforms."
	| comparandAsDateAndTime |
	self == comparand
		ifTrue: [^ true].
	[comparandAsDateAndTime := comparand asDateAndTime]
		on: MessageNotUnderstood
		do: [^ false].
	^ self offset = comparandAsDateAndTime offset
		ifTrue: [self hasEqualTicks: comparandAsDateAndTime ]
		ifFalse: [self asUTC ticks = comparandAsDateAndTime asUTC ticks]
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 13:11'!
asLocal
	

	^ (self offset = self class localOffset)

		ifTrue: [self]
		ifFalse: [self utcOffset: self class localOffset]
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'ab 4/22/2006 12:30'!
asUTC
	^ offset isZero
		ifTrue: [self]
		ifFalse: [self utcOffset: 0]! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:03'!
dayOfMonth
	"Answer which day of the month is represented by the receiver."

	^ self
		dayMonthYearDo: [ :d :m :y | d ]! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/24/2003 12:25'!
dayOfWeek

	"Sunday=1, ... , Saturday=7"

	^ (jdn + 1 rem: 7) + 1! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 10:34'!
dayOfWeekAbbreviation

	^ self dayOfWeekName copyFrom: 1 to: 3! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:28'!
dayOfWeekName

	^ Week nameOfDay: self dayOfWeek
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 1/29/2005 10:27'!
dayOfYear
	"This code was contributed by Dan Ingalls. It is equivalent to the terser
		^ jdn - (Year year: self year) start julianDayNumber + 1 but much quicker."

	| monthStart |
	^ self dayMonthYearDo:
		[ :d :m :y |
			monthStart _ #(1 32 60 91 121 152 182 213 244 274 305 335) at: m.
			(m > 2 and: [ Year isLeapYear: y ])
				ifTrue: [ monthStart + d ]
				ifFalse: [ monthStart + d - 1 ]]! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 15:49'!
hash

	^ self asUTC ticks hash
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'!
hour

	^ self hour24
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 18:46'!
hour12
	"Answer an <integer> between 1 and 12, inclusive, representing the hour 
	of the day in the 12-hour clock of the local time of the receiver."
	^ self hour24 - 1 \\ 12 + 1! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'!
hour24


	^ (Duration seconds: seconds) hours
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'!
isLeapYear


	^ Year isLeapYear: self year.
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/24/2003 11:03'!
meridianAbbreviation

	^ self asTime meridianAbbreviation! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'!
minute


	^ (Duration seconds: seconds) minutes
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:05'!
month

	^ self 
		dayMonthYearDo: [ :d :m :y | m ].! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'!
monthAbbreviation


	^ self monthName copyFrom: 1 to: 3
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'!
monthName


	^ Month nameOfMonth: self month
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'!
offset

	^ offset
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:09'!
offset: anOffset

	"Answer a <DateAndTime> equivalent to the receiver but with its local time 
	being offset from UTC by offset."

	^ self class basicNew 
		ticks: self ticks offset: anOffset asDuration;
		yourself
		! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:31'!
second


	^ (Duration seconds: seconds) seconds
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 9/4/2003 06:42'!
timeZoneAbbreviation

	^ self class localTimeZone abbreviation
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 9/4/2003 06:42'!
timeZoneName

	^ self class localTimeZone name
! !

!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:05'!
year
	^ self
		dayMonthYearDo: [ :d :m :y | y ]! !


!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 21:03'!
asSeconds
	"Return the number of seconds since the Squeak epoch"

	^ (self - (self class epoch)) asSeconds
! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 17:53'!
day

	^ self dayOfYear! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:48'!
daysInMonth
	"Answer the number of days in the month represented by the receiver."


	^ self asMonth daysInMonth
! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:48'!
daysInYear

	"Answer the number of days in the year represented by the receiver."

	^ self asYear daysInYear
! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 15:44'!
daysLeftInYear
	"Answer the number of days in the year after the date of the receiver."

	^ self daysInYear - self dayOfYear
! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 15:44'!
firstDayOfMonth

	^ self asMonth start day! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 18:30'!
hours

	^ self hour! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 1/7/2004 15:45'!
minutes

	^ self minute! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:50'!
monthIndex


	^ self month
! !

!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 18:31'!
seconds

	^ self second! !


!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 23:56'!
asDate


	^ Date starting: self
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:46'!
asDateAndTime

	^ self
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'!
asDuration

	"Answer the duration since midnight"

	^ Duration seconds: seconds nanoSeconds: nanos
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'!
asMonth

	^ Month starting: self
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:45'!
asNanoSeconds
	"Answer the number of nanoseconds since midnight"

	^ self asDuration asNanoSeconds
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:00'!
asTime


	^ Time seconds: seconds nanoSeconds: nanos! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:02'!
asTimeStamp

	^ self as: TimeStamp! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'!
asWeek

	^ Week starting: self 
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'!
asYear

	^ Year starting: self
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:47'!
dayMonthYearDo: aBlock
	"Evaluation the block with three arguments: day month, year."

	| l n i j dd mm yyyy |
	l := jdn + 68569.
	n := 4 * l // 146097.
	l := l - (146097 * n + 3 // 4).
	i := 4000 * (l + 1) // 1461001.
	l := l - (1461 * i // 4) + 31.
	j := 80 * l // 2447.
	dd := l - (2447 * j // 80).
	l := j // 11.
	mm := j + 2 - (12 * l).
	yyyy := 100 * (n - 49) + i + l.

	^ aBlock
		value: dd
		value: mm
		value: yyyy.! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'!
duration

	^ Duration zero
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'!
julianDayNumber


	^ jdn
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'!
middleOf: aDuration
	"Return a Timespan where the receiver is the middle of the Duration"

	| duration |
	duration _ aDuration asDuration.

	^ Timespan starting: (self - (duration / 2)) duration: duration.
		! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:48'!
midnight
	"Answer a DateAndTime starting at midnight local time"

	^ self
		dayMonthYearDo: [ :d :m :y | self class year: y month: m day: d ]! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:50'!
nanoSecond


	^ nanos
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:49'!
noon
	"Answer a DateAndTime starting at noon"

	^ self dayMonthYearDo: 
		[ :d :m :y | self class year: y month: m day: d hour: 12 minute: 0 second: 0 ]! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:03'!
printHMSOn: aStream
	"Print just hh:mm:ss"
	aStream
		nextPutAll: (self hour asString padded: #left to: 2 with: $0);
		nextPut: $:;
		nextPutAll: (self minute asString padded: #left to: 2 with: $0);
		nextPut: $:;
		nextPutAll: (self second asString padded: #left to: 2 with: $0).
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:38'!
printOn: aStream
	"Print as per ISO 8601 sections 5.3.3 and 5.4.1.
	Prints either:
		'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)"

	^self printOn: aStream withLeadingSpace: false
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'dtl 10/31/2004 01:20'!
printOn: aStream withLeadingSpace: printLeadingSpaceToo
	"Print as per ISO 8601 sections 5.3.3 and 5.4.1.
	If printLeadingSpaceToo is false, prints either:
		'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)
	If printLeadingSpaceToo is true, prints either:
		' YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)
	"

	self printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo.
	aStream nextPut: $T.
	self printHMSOn: aStream.
	self nanoSecond ~= 0 ifTrue:
		[ | z ps |
		ps := self nanoSecond printString padded: #left to: 9 with: $0.
		z := ps findLast: [ :c | c asciiValue > $0 asciiValue ].
		(z > 0) ifTrue: [aStream nextPut: $.].
		ps from: 1 to: z do: [ :c | aStream nextPut: c ] ].
	aStream
		nextPut: (offset positive ifTrue: [$+] ifFalse: [$-]);
		nextPutAll: (offset hours abs asString padded: #left to: 2 with: $0);
		nextPut: $:;
		nextPutAll: (offset minutes abs asString padded: #left to: 2 with: $0).
	offset seconds = 0 ifFalse:
		[ aStream
			nextPut: $:;
			nextPutAll: (offset seconds abs truncated asString) ].
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:29'!
printYMDOn: aStream
	"Print just YYYY-MM-DD part.
	If the year is negative, prints out '-YYYY-MM-DD'."

	^self printYMDOn: aStream withLeadingSpace: false.
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:29'!
printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo
	"Print just the year, month, and day on aStream.

	If printLeadingSpaceToo is true, then print as:
		' YYYY-MM-DD' (if the year is positive) or '-YYYY-MM-DD' (if the year is negative)
	otherwise print as:
		'YYYY-MM-DD' or '-YYYY-MM-DD' "

	| year month day |
	self dayMonthYearDo: [ :d :m :y | year := y. month := m. day := d ].
	year negative
		ifTrue: [ aStream nextPut: $- ]
		ifFalse: [ printLeadingSpaceToo ifTrue: [ aStream space ]].
	aStream
		nextPutAll: (year abs asString padded: #left to: 4 with: $0);
		nextPut: $-;
		nextPutAll: (month asString padded: #left to: 2 with: $0);
		nextPut: $-;
		nextPutAll: (day asString padded: #left to: 2 with: $0)
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:50'!
to: anEnd
	"Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan"

	^ Timespan starting: self ending: (anEnd asDateAndTime).
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:57'!
to: anEnd by: aDuration
	"Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan"

	^ (Schedule starting: self ending: (anEnd asDateAndTime))
		schedule: (Array with: aDuration asDuration);
		yourself.
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 16:01'!
to: anEnd by: aDuration do: aBlock
	"Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan"

	^ (self to: anEnd by: aDuration) scheduleDo: aBlock
! !

!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:37'!
utcOffset: anOffset

	"Answer a <DateAndTime> equivalent to the receiver but offset from UTC by anOffset"

	| equiv |
	equiv _ self + (anOffset asDuration - self offset).
	^ equiv ticks: (equiv ticks) offset: anOffset asDuration; yourself
! !


!DateAndTime methodsFor: 'private' stamp: 'brp 7/28/2004 16:22'!
hasEqualTicks: aDateAndTime
	
	^ (jdn = aDateAndTime julianDayNumber)
		and: [ (seconds = aDateAndTime secondsSinceMidnight)
			and: [ nanos = aDateAndTime nanoSecond ] ]

! !

!DateAndTime methodsFor: 'private' stamp: 'brp 7/28/2004 16:20'!
secondsSinceMidnight

	^ seconds! !

!DateAndTime methodsFor: 'private' stamp: 'brp 8/23/2003 15:45'!
ticks
	"Private - answer an array with our instance variables. Assumed to be UTC "

	^ Array with: jdn with: seconds with: nanos
.! !

!DateAndTime methodsFor: 'private' stamp: 'nk 3/30/2004 09:38'!
ticks: ticks offset: utcOffset
	"ticks is {julianDayNumber. secondCount. nanoSeconds}"
	| normalize |

	normalize := [ :i :base | | tick div quo rem |
		tick := ticks at: i.
		div := tick digitDiv: base neg: tick negative.
		quo := div first normalize.
		rem := div second normalize.
		rem < 0 ifTrue: [ quo := quo - 1. rem := base + rem ].
		ticks at: (i-1) put: ((ticks at: i-1) + quo).
		ticks at: i put: rem ].

	normalize value: 3 value: NanosInSecond.
	normalize value: 2 value: SecondsInDay.

	jdn	_ ticks first.
	seconds	_ ticks second.
	nanos := ticks third.
	offset := utcOffset.


! !

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

DateAndTime class
	instanceVariableNames: ''!

!DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:32'!
clockPrecision
	"One nanosecond precision"

	^ Duration nanoSeconds: 1
! !

!DateAndTime class methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 19:03'!
now
	^ self basicNew 
		ticks: (Duration 
				days: SqueakEpoch 
				hours: 0 
				minutes: 0 
				seconds: self totalSeconds 
				nanoSeconds: 0) ticks
		offset: self localOffset;
		yourself
! !

!DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 15:25'!
year: year day: dayOfYear hour: hour minute: minute second: second

	^ self
		year: year
		day: dayOfYear
		hour: hour
		minute: minute
		second: second
		offset: self localOffset.
! !

!DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 15:28'!
year: year day: dayOfYear hour: hour minute: minute second: second offset: offset 
	"Return a DataAndTime"

	| y d |
	y _ self
		year: year
		month: 1
		day: 1
		hour: hour
		minute: minute
		second: second
		nanoSecond: 0
		offset: offset.

	d _ Duration days: (dayOfYear - 1).

	^ y + d! !

!DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:00'!
year: year month: month day: day hour: hour minute: minute second: second
	"Return a DateAndTime"

	^ self
		year: year
		month: month
		day: day
		hour: hour
		minute: minute
		second: second
		offset: self localOffset
! !

!DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:36'!
year: year month: month day: day hour: hour minute: minute second: second offset: offset

	^ self
		year: year
		month: month
		day: day
		hour: hour
		minute: minute
		second: second
		nanoSecond: 0
		offset: offset
! !


!DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp` 8/24/2003 19:09'!
fromSeconds: seconds
	"Answer a DateAndTime since the Squeak epoch: 1 January 1901"

	| since |
	since _ Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: seconds.
	^ self basicNew
		ticks: since ticks offset: self localOffset;
		yourself.
! !

!DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00'!
millisecondClockValue

	^ Time millisecondClockValue! !

!DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:01'!
totalSeconds

	^ Time totalSeconds! !


!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:36'!
current


	^ self now
! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 16:12'!
date: aDate time: aTime

	^ self 
		year: aDate year 
		day: aDate dayOfYear 
		hour: aTime hour 
		minute: aTime minute 
		second: aTime second
! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp` 8/24/2003 19:11'!
epoch
	"Answer a DateAndTime representing the Squeak epoch: 1 January 1901"

	^ self julianDayNumber: SqueakEpoch
	! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:36'!
fromString: aString


	^ self readFrom: (ReadStream on: aString)
! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 21:08'!
julianDayNumber: aJulianDayNumber

	^ self basicNew
		ticks: aJulianDayNumber days ticks offset: self localOffset;
		yourself
! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/4/2003 06:40'!
localOffset
	"Answer the duration we are offset from UTC"

	^ self localTimeZone offset
! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/4/2003 06:39'!
localTimeZone
	"Answer the local time zone"

	^ LocalTimeZone ifNil: [ LocalTimeZone _ TimeZone default ]

! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'nk 3/30/2004 09:53'!
localTimeZone: aTimeZone
	"Set the local time zone"

	"
	DateAndTime localTimeZone: (TimeZone offset:  0 hours name: 'Universal Time' abbreviation: 'UTC').
	DateAndTime localTimeZone: (TimeZone offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST').
	"

	LocalTimeZone := aTimeZone


! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'!
midnight

	^ self now midnight
! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:57'!
new
	"Answer a DateAndTime representing the Squeak epoch: 1 January 1901"

	^ self epoch
	! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'!
noon

	^ self now noon! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:58'!
readFrom: aStream
	| bc year month day hour minute second nanos offset buffer ch |


	aStream peek = $- ifTrue: [ aStream next. bc _ -1] ifFalse: [bc _ 1].
	year _ (aStream upTo: $-) asInteger * bc.
	month _ (aStream upTo: $-) asInteger.
	day _ (aStream upTo: $T) asInteger.
	hour _ (aStream upTo: $:) asInteger.
 	buffer _ '00:'. ch _ nil.
	minute _ WriteStream on: buffer.
	[ aStream atEnd | (ch = $:) | (ch = $+) | (ch = $-) ]
		whileFalse: [ ch _ minute nextPut: aStream next. ].
	(ch isNil or: [ch isDigit]) ifTrue: [ ch _ $: ].
	minute _ ((ReadStream on: buffer) upTo: ch) asInteger.
	buffer _ '00.'.
	second _ WriteStream on: buffer.
	[ aStream atEnd | (ch = $.) | (ch = $+) | (ch = $-) ]
		whileFalse: [ ch _ second nextPut: aStream next. ].
	(ch isNil or: [ch isDigit]) ifTrue: [ ch _ $. ].
	second _ ((ReadStream on: buffer) upTo: ch) asInteger.
	buffer _ '00000000+'.
	nanos _ WriteStream on: buffer.
	[ aStream atEnd | (ch = $+) | (ch = $-) ]
		whileFalse: [ ch _ nanos nextPut: aStream next. ].
	(ch isNil or: [ch isDigit]) ifTrue: [ ch _ $+ ].
	nanos _ ((ReadStream on: buffer) upTo: ch) asInteger.
	aStream atEnd
		ifTrue: [ offset _ self localOffset ]
	
	ifFalse:
		 	[offset _ Duration fromString: (ch asString, '0:', aStream upToEnd).
	
		(offset = self localOffset) ifTrue: [ offset _ self localOffset ]].
	^ self
		year: year
		month: month
		day: day
		hour: hour
		minute: minute

		second: second
		nanoSecond:  nanos

		offset: offset.


	"	'-1199-01-05T20:33:14.321-05:00' asDateAndTime
		' 2002-05-16T17:20:45.00000001+01:01' asDateAndTime
  		' 2002-05-16T17:20:45.00000001' asDateAndTime
 		' 2002-05-16T17:20' asDateAndTime
		' 2002-05-16T17:20:45' asDateAndTime
		' 2002-05-16T17:20:45+01:57' asDateAndTime
 		' 2002-05-16T17:20:45-02:34' asDateAndTime
 		' 2002-05-16T17:20:45+00:00' asDateAndTime
		' 1997-04-26T01:02:03+01:02:3' asDateAndTime 
 	"
! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'!
today

	^ self midnight
! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 12:19'!
tomorrow

	^ self today asDate next asDateAndTime! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:53'!
year: year day: dayOfYear
	"Return a DateAndTime"

	^ self
		year: year
		day: dayOfYear
		hour: 0
		minute: 0
		second: 0! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:54'!
year: year month: month day: day
	"Return a DateAndTime, midnight local time" 	^ self
 		year: year
 		month: month
 		day: day
 		hour: 0
		minute: 0! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:54'!
year: year month: month day: day hour: hour minute: minute

	"Return a DateAndTime" 	^ self
 		year: year
 		month: month
 		day: day
 		hour: hour
		minute: minute
		second: 0! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'bvs 9/29/2004 16:43'!
year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanoCount offset: offset
	"Return a DateAndTime"

	| monthIndex daysInMonth p q r s julianDayNumber since |

	monthIndex _ month isInteger ifTrue: [month] ifFalse: [Month indexOfMonth: month].
	daysInMonth _ Month
		daysInMonth: monthIndex
		forYear: year.
	day < 1 ifTrue: [self error: 'day may not be zero or negative'].
	day > daysInMonth ifTrue: [self error: 'day is after month ends']. 	
	
	p _ (monthIndex - 14) quo: 12.
	q _ year + 4800 + p.
	r _ monthIndex - 2 - (12 * p).
	s _ (year + 4900 + p) quo: 100.

	julianDayNumber _
 		( (1461 * q) quo: 4 ) +
			( (367 * r) quo: 12 ) -
 				( (3 * s) quo: 4 ) +
 					( day - 32075 ).

	since _ Duration days: julianDayNumber hours: hour 
				minutes: minute seconds: second nanoSeconds: nanoCount.

	^ self basicNew
 		ticks: since ticks offset: offset;
		yourself.! !

!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 12:19'!
yesterday

	^ self today asDate previous asDateAndTime
! !
TestCase subclass: #DateAndTimeEpochTest
	instanceVariableNames: 'aDateAndTime aDuration aTimeZone localTimeZoneToRestore'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!DateAndTimeEpochTest commentStamp: 'tlk 1/6/2004 18:27' prior: 0!
I represent one of several Sunit test Cases intentended to provide complete coverage  for the Chronology set of classes as part of the external testing. The other Chronology sunit test cases are:
 DateTestCase
 DateAndTimeLeapTestCase,
 DurationTestCase,
 ScheduleTestCase
 TimeStampTestCase
 TimespanDoTestCase, 
 TimespanDoSpanAYearTestCase, 
 TimespanTestCase, 
 YearMonthWeekTestCase.  
These tests attempt to exercise all public and private methods.  Except, they do not explicitly depreciated methods. tlk
My fixtures are:
aDateAndTime = January 01, 1901 midnight (the start of the Squeak epoch) with localTimeZone = Grenwhich Meridian (local offset = 0 hours)
aDuration = 1 day, 2 hours, 3, minutes, 4 seconds and 5 nano seconds.
aTimeZone =  'Epoch Test Time Zone', 'ETZ' , offset: 12 hours, 15 minutes. !


!DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 10:58'!
setUp
     localTimeZoneToRestore := DateAndTime localTimeZone.
	aDateAndTime :=  DateAndTime localTimeZone: TimeZone default; epoch.
	aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'Epoch Test Time Zone' abbreviation: 'ETZ'.
	aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! !

!DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 11:04'!
tearDown
     DateAndTime localTimeZone: localTimeZoneToRestore.
     "wish I could remove the time zones I added earlier, tut there is no method for that"
! !


!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'!
testAsDate
	self assert: aDateAndTime asDate =   'January 1, 1901' asDate.

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:31'!
testAsDateAndTime
	self assert: aDateAndTime asDateAndTime =  aDateAndTime
	
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:34'!
testAsDuration
	self assert: aDateAndTime asDuration =  0 asDuration
	
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:06'!
testAsLocal
	self assert: aDateAndTime asLocal =  aDateAndTime.
	self assert: aDateAndTime asLocal = (aDateAndTime utcOffset: aDateAndTime class localOffset)
	
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:27'!
testAsMonth
	self assert: aDateAndTime asMonth = (Month month: 'January' year: 1901). 
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:59'!
testAsNanoSeconds
	self assert: aDateAndTime asNanoSeconds =  0 asDuration asNanoSeconds
	
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:01'!
testAsSeconds
	self assert: aDateAndTime asSeconds =  0 asDuration asSeconds
	
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:32'!
testAsTime
	self assert: aDateAndTime asTime =  Time midnight.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:51'!
testAsTimeStamp
	self assert: aDateAndTime asTimeStamp =  TimeStamp new.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:07'!
testAsUTC
	self assert: aDateAndTime asUTC =  aDateAndTime
          ! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:43'!
testAsWeek
	self assert: aDateAndTime asWeek = (Week starting: '12-31-1900' asDate). 

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:43'!
testAsYear
	self assert: aDateAndTime asYear =   (Year starting: '01-01-1901' asDate). 
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'!
testCurrent
	self deny: aDateAndTime =  (DateAndTime current).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:46'!
testDateTime
	self assert: aDateAndTime =  (DateAndTime date: '01-01-1901' asDate time: '00:00:00' asTime)
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'!
testDay
	self assert: aDateAndTime day =   DateAndTime new day
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:08'!
testDayMonthYearDo
	|iterations|
	iterations := 0.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  iterations := iterations + 1])  = 1.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachYear])  = 1901.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachMonth]) = 1.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachDay]) = 1.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 15:45'!
testDayOfMonth
	self assert: aDateAndTime dayOfMonth  = 1.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:47'!
testDayOfWeek
	self assert: aDateAndTime dayOfWeek  = 3.
	self assert: aDateAndTime dayOfWeekAbbreviation = 'Tue'.
	self assert: aDateAndTime dayOfWeekName = 'Tuesday'.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'!
testDayOfYear
	self assert: aDateAndTime dayOfYear  = 1.

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'!
testDaysInMonth
	self assert: aDateAndTime daysInMonth  = 31.

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'!
testDaysInYear
	self assert: aDateAndTime daysInYear  = 365.

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'!
testDaysLeftInYear
	self assert: aDateAndTime daysLeftInYear  = 364.

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:24'!
testDuration
	self assert: aDateAndTime duration  = 0 asDuration.

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'!
testEpoch
	self assert: aDateAndTime =  '1901-01-01T00:00:00+00:00'.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:44'!
testFirstDayOfMonth
	self assert: aDateAndTime firstDayOfMonth =   1
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'!
testFromSeconds
	self assert: aDateAndTime =  (DateAndTime fromSeconds: 0).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:26'!
testFromString
	self assert: aDateAndTime =  (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00').
	self assert: aDateAndTime =  (DateAndTime fromString: ' 1901-01-01T00:00:00').
	self assert: aDateAndTime =  (DateAndTime fromString: ' 1901-01-01T00:00').
	self assert: aDateAndTime =  (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00').
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 4/30/2006 22:20'!
testHash
	self assert: aDateAndTime hash =    DateAndTime new hash.
	self assert: aDateAndTime hash =    32161486
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:59'!
testHour
	self assert: aDateAndTime hour =    aDateAndTime hour24.
	self assert: aDateAndTime hour =    0.
	self assert: aDateAndTime hour =    aDateAndTime hours
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:21'!
testHour12
	self assert: aDateAndTime hour12  = DateAndTime new hour12.
	self assert: aDateAndTime hour12  = 12
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'!
testIsLeapYear
	self deny: aDateAndTime isLeapYear
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:18'!
testJulianDayNumber
	self assert: aDateAndTime =  (DateAndTime julianDayNumber: 2415386).
	self assert: aDateAndTime julianDayNumber = 2415386.! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:20'!
testLessThan
	self assert: aDateAndTime  < (aDateAndTime + '1:00:00:00').
	self assert: aDateAndTime + -1 < aDateAndTime.
	! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:40'!
testMeridianAbbreviation
	self assert: aDateAndTime meridianAbbreviation = 'AM'.

	! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:37'!
testMiddleOf
	self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) = 
	 (Timespan starting: '12-31-1900' asDate duration: 2 days).
	
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:39'!
testMidnight
	self assert: aDateAndTime midnight =  aDateAndTime
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:03'!
testMinus
	self assert: aDateAndTime - aDateAndTime =  '0:00:00:00' asDuration.
	self assert: aDateAndTime - '0:00:00:00' asDuration = aDateAndTime.
	self assert: aDateAndTime - aDuration =  (DateAndTime year: 1900 month: 12 day: 30 hour: 21 minute: 56 second: 55 nanoSecond: 999999995 offset: 0 hours ).
	" I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:35'!
testMinute
	self assert: aDateAndTime minute =  0

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:41'!
testMinutes
	self assert: aDateAndTime minutes = 0
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:46'!
testMonth
	self assert: aDateAndTime month  = 1.
	self assert: aDateAndTime monthAbbreviation = 'Jan'.
	self assert: aDateAndTime monthName = 'January'.
	self assert: aDateAndTime monthIndex = 1.! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:47'!
testNanoSecond
	self assert: aDateAndTime nanoSecond =  0

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:27'!
testNew
	self assert: aDateAndTime =  (DateAndTime new).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:49'!
testNoon
	self assert: aDateAndTime noon =  '1901-01-01T12:00:00+00:00'.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'!
testNow
	self deny: aDateAndTime =  (DateAndTime now).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:41'!
testOffset
	self assert: aDateAndTime offset =  '0:00:00:00' asDuration.
     self assert: (aDateAndTime offset: '0:12:00:00') =  '1901-01-01T00:00:00+12:00'.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 11:03'!
testPlus
	self assert: aDateAndTime + '0:00:00:00' = aDateAndTime.
	self assert: aDateAndTime + 0 = aDateAndTime.
	self assert: aDateAndTime + aDuration = (DateAndTime year: 1901 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours )
	" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"
	
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'nk 3/12/2004 10:16'!
testPrintOn
	| cs rw |
	cs := ReadStream on: '1901-01-01T00:00:00+00:00'.
	rw := ReadWriteStream on: ''.
	aDateAndTime printOn: rw.
	self assert: rw contents = cs contents.
	cs  := ReadStream on: 'a TimeZone(ETZ)'.
	rw := ReadWriteStream on: ''.
	aTimeZone printOn:  rw.
	self assert: rw contents = cs contents! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'!
testSecond
	self assert: aDateAndTime second =  0

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'!
testSeconds
	self assert: aDateAndTime seconds =  0

! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:25'!
testTicks
	self assert: aDateAndTime ticks =  (DateAndTime julianDayNumber: 2415386) ticks.
	self assert: aDateAndTime ticks = #(2415386 0 0)! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:31'!
testTicksOffset
	self assert: aDateAndTime =  (aDateAndTime ticks:  #(2415386 0 0) offset: DateAndTime localOffset).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:42'!
testTo
	self assert: (aDateAndTime to: aDateAndTime) = (DateAndTime new to: DateAndTime new) 
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:43'!
testToBy
	self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) = 
				(DateAndTime new to: DateAndTime new + 10 days by: 5 days ) 
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:53'!
testToByDo
	"self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) =  "
	"MessageNotUnderstood: UndefinedObject>>starting:ending:  where UndefinedObject is Timespan "! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:35'!
testToday
	self deny: aDateAndTime =  (DateAndTime today).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:45'!
testTommorrow
	self assert: (DateAndTime today + 24 hours) =  (DateAndTime tomorrow).
	self deny: aDateAndTime =  (DateAndTime tomorrow).
     "MessageNotUnderstood: Date class>>starting:"! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:58'!
testUtcOffset
     self assert: (aDateAndTime utcOffset: '0:12:00:00') =  '1901-01-01T12:00:00+12:00'.
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 21:00'!
testYear
	self assert: aDateAndTime year = 1901.

	! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:30'!
testYearDay
	self assert: aDateAndTime =  (DateAndTime year: 1901 day: 1).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'!
testYearDayHourMinuteSecond
	self assert: aDateAndTime =  (DateAndTime year: 1901 day: 1 hour: 0 minute: 0 second: 0).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'!
testYearMonthDay
	self assert: aDateAndTime =  (DateAndTime year: 1901 month: 1 day: 1).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'!
testYearMonthDayHourMinuteSecond
	self assert: aDateAndTime =  (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:23'!
testYearMonthDayHourMinuteSecondNanosSecondOffset
	self assert: aDateAndTime =  (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset:0 hours ).
	self assert: ((DateAndTime year: 1 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset: 0 hours ) +
				(Duration days: 1 hours: 2 minutes: 3 seconds: 4  nanoSeconds: 5) ) =  	
				(DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) 
	" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"   
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:47'!
testYesterday
	self deny: aDateAndTime =  (DateAndTime yesterday).
! !

!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26'!
testtimeZone
	self assert: aDateAndTime timeZoneName	= 'Universal Time'.
	self assert: aDateAndTime timeZoneAbbreviation	=  'UTC'

! !
TestCase subclass: #DateAndTimeLeapTest
	instanceVariableNames: 'aDateAndTime aDuration aTimeZone localTimeZoneToRestore'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!DateAndTimeLeapTest commentStamp: 'tlk 1/6/2004 17:54' prior: 0!
I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. tlk.
My fixtures are:
aDateAndTime = February 29, 2004 1:33 PM with offset: 2 hours
aDuration = 15 days, 14 hours, 13 minutes, 12 seconds and 11 nano seconds.
aTimeZone =  Grenwhich Meridian (local offset = 0 hours) !


!DateAndTimeLeapTest methodsFor: 'running' stamp: 'nk 3/12/2004 11:00'!
setUp
	localTimeZoneToRestore := DateAndTime localTimeZone.
	DateAndTime localTimeZone: TimeZone default.
	aDateAndTime := (DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0 offset: 2 hours).
	aTimeZone := TimeZone default.
	aDuration := Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0
! !

!DateAndTimeLeapTest methodsFor: 'running' stamp: 'tlk 1/2/2004 21:30'!
tearDown
     DateAndTime localTimeZone: localTimeZoneToRestore.
     "wish I could remove the time zones I added earlier, tut there is no method for that"
! !


!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:00'!
testAsDate
	self assert: aDateAndTime asDate =   'February 29, 2004' asDate.

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:55'!
testAsDuration
	self assert: aDateAndTime asDuration =  aDuration
	
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:00'!
testAsLocal
	self assert: aDateAndTime asLocal =  aDateAndTime.
	self assert: aDateAndTime asLocal = (aDateAndTime utcOffset: aDateAndTime class localOffset)

	
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:24'!
testAsMonth
	self assert: aDateAndTime asMonth = (Month month: 'February' year: 2004).
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:59'!
testAsNanoSeconds
	self assert: aDateAndTime asNanoSeconds =  aDuration asNanoSeconds.
	self assert: aDateAndTime asNanoSeconds = 48780000000000
	
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:05'!
testAsSeconds
	self assert: aDuration asSeconds =  48780.
	self assert: aDateAndTime asSeconds =  3255507180
	
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:26'!
testAsTime
	self assert: aDateAndTime asTime = (Time hour: 13 minute: 33 second: 0)
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:31'!
testAsTimeStamp
	self assert: aDateAndTime asTimeStamp =  ((TimeStamp readFrom: '2-29-2004 1:33 pm' readStream) offset: 2 hours).

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:59'!
testAsUTC
	self assert: aDateAndTime asUTC =  aDateAndTime

          ! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:30'!
testAsWeek
	self assert: aDateAndTime asWeek =    (Week starting: '02-29-2004' asDate).
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:36'!
testAsYear
	self assert: aDateAndTime asYear =   (Year starting: '02-29-2004' asDate).  
	self deny: aDateAndTime asYear =   (Year starting: '01-01-2004' asDate)  
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:23'!
testDay
	self assert: aDateAndTime day =   60. 
	self deny: aDateAndTime day =   29 ! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:16'!
testDayMonthYearDo
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachYear])  = 2004.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachMonth]) = 2.
	self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear |  eachDay]) = 29.
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:17'!
testDayOfMonth
	self assert: aDateAndTime dayOfMonth  = 29.
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:34'!
testDayOfWeek
	self assert: aDateAndTime dayOfWeek  = 1.
	self assert: aDateAndTime dayOfWeekAbbreviation = 'Sun'.
	self assert: aDateAndTime dayOfWeekName = 'Sunday'.
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:59'!
testDayOfYear
	self assert: aDateAndTime dayOfYear  = 60.

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'!
testDaysInMonth
	self assert: aDateAndTime daysInMonth  = 29.

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'!
testDaysInYear
	self assert: aDateAndTime daysInYear  = 366.

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'!
testDaysLeftInYear
	self assert: aDateAndTime daysLeftInYear  = 306.

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:38'!
testFirstDayOfMonth
	self deny: aDateAndTime firstDayOfMonth =  1.
	self assert: aDateAndTime firstDayOfMonth = 32
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:43'!
testFromString
	self assert: aDateAndTime =  (DateAndTime fromString: ' 2004-02-29T13:33:00+02:00').

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 4/30/2006 22:17'!
testHash
	self assert: aDateAndTime hash =     131156085
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:48'!
testHour
	self assert: aDateAndTime hour =    aDateAndTime hour24.
	self assert: aDateAndTime hour =    13.
	self assert: aDateAndTime hour =    aDateAndTime hours
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:19'!
testHour12
	self assert: aDateAndTime hour12  =   1.
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:35'!
testIsLeapYear
	self assert: aDateAndTime isLeapYear
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'!
testLessThan
	self assert: aDateAndTime  < (aDateAndTime + '1:00:00:00').
	self assert: aDateAndTime + -1 < aDateAndTime.
	! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:42'!
testMeridianAbbreviation
	self assert: aDateAndTime meridianAbbreviation = 'PM'.

	! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:12'!
testMiddleOf
	self assert: (aDateAndTime middleOf: aDuration)  = 
	 (Timespan starting: (DateAndTime year: 2004 month: 2 day: 29 hour: 6 minute: 46 second: 30 offset: 2 hours)
	duration: (Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 ))
	! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:57'!
testMidnight
	self assert: aDateAndTime midnight =  '2004-02-29T00:00:00+00:00'.
	self deny: aDateAndTime midnight =  '2004-02-29T00:00:00+02:00'
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:00'!
testMinute
	self assert: aDateAndTime minute =  33

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:44'!
testMinutes
	self assert: aDateAndTime minutes = 33
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:02'!
testMonth
	self assert: aDateAndTime month  = 2.
	self assert: aDateAndTime monthAbbreviation = 'Feb'.
	self assert: aDateAndTime monthName = 'February'.
	self assert: aDateAndTime monthIndex = 2.! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'!
testNanoSecond
	self assert: aDateAndTime nanoSecond =  0

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:03'!
testNoon
	self assert: aDateAndTime noon =  '2004-02-29T12:00:00+00:00'.
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:07'!
testOffset
	self assert: aDateAndTime offset =  '0:02:00:00' asDuration.
     self assert: (aDateAndTime offset: '0:12:00:00') =  '2004-02-29T13:33:00+12:00'.
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:27'!
testPrintOn
	| cs rw |
	cs := ReadStream on: '2004-02-29T13:33:00+02:00'.
	rw := ReadWriteStream on: ''.
	aDateAndTime printOn: rw.
	self assert: rw contents = cs contents.
	cs  := ReadStream on: 'a TimeZone(UTC)'.
	rw := ReadWriteStream on: ''.
	aTimeZone printOn:  rw.
	self assert: rw contents = cs contents	! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'!
testSecond
	self assert: aDateAndTime second =  0

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'!
testSeconds
	self assert: aDateAndTime seconds =  0

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:12'!
testTicks
	self assert: aDateAndTime ticks =  ((DateAndTime julianDayNumber: 2453065) + 48780 seconds) ticks.
	self assert: aDateAndTime ticks =  #(2453065 48780 0)! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:52'!
testTicksOffset
	self assert: aDateAndTime =  (aDateAndTime ticks:  #(2453065 48780 0) offset: DateAndTime localOffset).

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:51'!
testUtcOffset
     self assert: (aDateAndTime utcOffset: '0:02:00:00') =  '2004-02-29T13:33:00+02:00'.

! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:17'!
testYear
	self assert: aDateAndTime year = 2004.

	! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:21'!
testYearDayHourMinuteSecond
	self assert: aDateAndTime =  ((DateAndTime year: 2004 day: 60 hour: 13 minute: 33 second: 0) offset: 2 hours).
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:23'!
testYearMonthDayHourMinuteSecond
	self assert: aDateAndTime =  ((DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0) offset: 2 hours).
! !

!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26'!
testtimeZone
	self assert: aDateAndTime timeZoneName	= 'Universal Time'.
	self assert: aDateAndTime timeZoneAbbreviation	=  'UTC'

! !
ClassTestCase subclass: #DateAndTimeTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!

!DateAndTimeTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 09:25'!
classToBeTested

	^ DateAndTime

! !

!DateAndTimeTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 09:25'!
selectorsToBeIgnored

	| private | 
	private := #( #printOn: ).

	^ super selectorsToBeIgnored, private
! !


!DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 17:00'!
testArithmeticAcrossDateBoundary

	| t1 t2 |
	t1 _ '2004-01-07T11:55:00+00:00' asDateAndTime. 
	t2 _ t1 - ( (42900+1) seconds).  

	self 
		assert: t2 = ('2004-01-06T23:59:59+00:00' asDateAndTime)
		
! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/7/2004 13:00'!
testDateTimeDenotation1
  "DateAndTimeTest new testDateTimeDenotation1"
	
	 " Detroit is 5 hours behind UTC, this offset to UTC is therefore written with a minus sign. This example tests the correct interpretation of the DateAndTime denotation. "

	| twoPmInLondon twoPmUTCInLocalTimeOfDetroit nineAmInDetroit |
	twoPmInLondon := DateAndTime
				year: 2004
				month: 11
				day: 2
				hour: 14
				minute: 0
				second: 0
				offset: 0 hours.
	twoPmUTCInLocalTimeOfDetroit _ twoPmInLondon utcOffset: -5 hours.
	nineAmInDetroit  _ '2004-11-02T09:00:00-05:00' asDateAndTime.
	self assert:  twoPmUTCInLocalTimeOfDetroit = nineAmInDetroit.
	
! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/7/2004 13:01'!
testDateTimeDenotation2
  "DateAndTimeTest new testDateTimeDenotation2"
	
	 " Moscow is 3 hours ahead UTC, this offset to UTC is therefore positive. This example tests the correct interpretation of the DateAndTime denotation. "

	| lateEveningInLondon lateEveningInLocalTimeOfMoscow
	 localMoscowTimeFromDenotation |
	lateEveningInLondon := DateAndTime
				year: 2004
				month: 11
				day: 30
				hour: 23
				minute: 30
				second: 0
				offset: 0 hours.
	lateEveningInLocalTimeOfMoscow _ lateEveningInLondon utcOffset: 3 hours.
	localMoscowTimeFromDenotation  _ '2004-12-01T02:30:00+03:00' asDateAndTime.
	self assert:  lateEveningInLocalTimeOfMoscow = localMoscowTimeFromDenotation.
	
! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'bvs 9/29/2004 16:22'!
testErrorWhenDayIsAfterMonthEnd

	self
		should:
			[DateAndTime
				year: 2004
				month: 2
				day: 30]
		raise: Error.

	self
		shouldnt:
			[DateAndTime
				year: 2004
				month: 2
				day: 29]
		raise: Error.
	! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'bvs 9/29/2004 16:29'!
testErrorWhenDayIsBeforeMonthStart

	self
		should:
			[DateAndTime
				year: 2004
				month: 2
				day: -1]
		raise: Error.

	self
		should:
			[DateAndTime
				year: 2004
				month: 2
				day: 0]
		raise: Error.
		
	self
		shouldnt:
			[DateAndTime
				year: 2004
				month: 2
				day: 1]
		raise: Error.
	! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 15:37'!
testInstanceCreation

	| t |
	t _ DateAndTime 
			year: 1 month: 1 day: 2 
			hour: 2 minute: 3 second: 4 nanoSecond: 5 
			offset: 6 hours.
	self 
		assert: (t julianDayNumber = 1721427);
		assert: (t offset = 6 hours);
		assert: (t hour = 2);
		assert: (t minute = 3);
		assert: (t second = 4);
		assert: (t nanoSecond = 5).
		
! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'nk 3/12/2004 11:06'!
testMonotonicity

	| t1 t2 t3 t4 |
	t1 := DateAndTime now.
	t2 := DateAndTime now.
	(Delay forMilliseconds: 1000) wait.
	t3 := DateAndTime now.
	t4 := DateAndTime now.

	self
		assert: (	t1 <= t2);
		assert: (	t2 < t3);
		assert: (	t3 <= t4).
! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/5/2004 05:45'!
testPrintString

	"(self new setTestSelector: #testPrintString) debug"

	| dt |
	dt _DateAndTime
		year: 2004
		month: 11
		day: 2
		hour: 14
		minute: 3
		second: 5
		nanoSecond: 12345
		offset: (Duration seconds: (5 * 3600)).
	self assert: dt printString = '2004-11-02T14:03:05.000012345+05:00'


! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 15:43'!
testSmalltalk80Accessors

	| t |
	t _ DateAndTime 
			year: 1 month: 1 day: 2 
			hour: 2 minute: 3 second: 4 nanoSecond: 5 
			offset: 6 hours.
	self 
		assert: (t hours = t hours);
		assert: (t minutes = t minute);
		assert: (t seconds = t second).
! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'BG 11/7/2004 12:18'!
testTimeZoneEquivalence
  "DateAndTimeTest new testTimeZoneEquivalence"
	"When the clock on the wall in Detroit says 9:00am, the clock on the wall
	in London says 2:00pm. The Duration difference between the corresponding
	DateAndTime values should be zero."
	
	 " Detroit is 5 hours behind UTC, this offset to UTC is therefore written with a minus sign. This example tests both the correct interpretation of the DateAndTime denotation and correct DateAndTime arithmetics. "

	| twoPmInLondon nineAmInDetroit durationDifference |
	twoPmInLondon _ '2004-11-02T14:00:00+00:00' asDateAndTime.
	nineAmInDetroit  _ '2004-11-02T09:00:00-05:00' asDateAndTime.
	durationDifference _ twoPmInLondon - nineAmInDetroit.
	self assert: durationDifference asSeconds = 0.
	self assert: twoPmInLondon = nineAmInDetroit
! !

!DateAndTimeTest methodsFor: 'Tests' stamp: 'BG 11/7/2004 12:17'!
testTimeZoneEquivalence2
  "DateAndTimeTest new testTimeZoneEquivalence2"
	"This example demonstates the fact that
        2004-05-24T22:40:00  UTC  is
        2004-05-25T01:40:00  in Moscow
     (Moscow is 3 hours ahead of UTC)  "

	| thisMoment thisMomentInMoscow |
    thisMoment := DateAndTime year: 2004 month: 5 day: 24 hour: 22 minute: 40.
    thisMomentInMoscow := thisMoment utcOffset: 3 hours.
	self assert: (thisMoment - thisMomentInMoscow) asSeconds = 0.
	self assert: thisMoment = thisMomentInMoscow
! !
ClassTestCase subclass: #DateTest
	instanceVariableNames: 'date aDate aTime'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!DateTest commentStamp: 'brp 7/26/2003 16:58' prior: 0!
This is the unit test for the class Date. !


!DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:01'!
classToBeTested

	^ self dateClass! !

!DateTest methodsFor: 'Coverage' stamp: 'brp 1/30/2005 09:03'!
selectorsToBeIgnored

	 | deprecated private special |
	deprecated := #().
	private := #().
	special := #( #< #= #new #next #previous #printOn: #printOn:format: #storeOn: #fromString: ).

	^ super selectorsToBeIgnored, deprecated, private, special! !


!DateTest methodsFor: 'Running' stamp: 'brp 1/21/2004 18:46'!
setUp

	date := self dateClass newDay: 153 year: 1973.	"2 June 1973"

	aDate := Date readFrom: '01-23-2004' readStream.
	aTime := Time readFrom: '12:34:56 pm' readStream! !


!DateTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 16:07'!
testAccessing

	self	
		assert: date day = 153;
		assert: date julianDayNumber = 2441836;
		assert: date leap = 0;
		assert: date monthIndex = 6;
		assert: date monthName = #June;
		assert: date weekday = #Saturday;
		assert: date weekdayIndex = 7;
		assert: date year = 1973.
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:10'!
testArithmetic
	| d |
	d := date addDays: 32.		"4 July 1973"

	self 
		assert: d year = 1973;
		assert: d monthIndex = 7;
		assert: d dayOfMonth = 4.
	self 
		assert: (d subtractDate: date) = 32;
		assert: (date subtractDate: d) = -32.
	self	 
		assert: (d subtractDays: 32) = date.
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:54'!
testComparing
	| d1 d2 d3 |
	d1 := self dateClass newDay: 2 month: #June year: 1973.
	d2 := self dateClass newDay: 97 year: 2003. 		"7 April 2003"
	d3 := self dateClass newDay: 250 year: 1865. 		"7 September 1865"

	self
		assert: date = d1;
		assert: date = date copy;
		assert: date hash = d1 hash.
	self 
		assert: date < d2;
		deny: date < d3.
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:15'!
testConverting

	self 
		assert: date asDate = date;
		assert: '2 June 1973' asDate = date;
		assert: date asSeconds = 2285280000.

	date dayMonthYearDo: [ :d :m :y | self assert: d = 2; assert: m = 6; assert: y = 1973 ].! !

!DateTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:47'!
testFromDays
	| epoch d0 d1 d2 |
	epoch := self dateClass newDay: 1 year: 1901.
	d0 := self dateClass fromDays: 0. 			"1 January 1901"
	self assert: d0 = epoch.

	d1 := self dateClass fromDays:  26450. 	"2 June 1973"
	self assert: d1 = date.

	d2 := self dateClass fromDays: -100000.	"18 March 1627"
	self assert: d2 julianDayNumber = 2315386.

	self assert: aDate  =  (Date fromDays:  37642).
	self assert: aDate  =  (Date fromDays: 103*365 + 22 + 25 "leap days") .
	! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:17'!
testFromSeconds
	| d |
	d := self dateClass fromSeconds: 2285280000. 
	self
		assert: d = date.
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 16:37'!
testGeneralInquiries

	| shuffled indices names now | 

	shuffled := #(#January #February #March #April #May #June #July 
					#August #September #October #November #December) shuffled.
	indices := shuffled collect: [ :m | self dateClass indexOfMonth: m ].
	names := indices collect: [ :i | self dateClass nameOfMonth: i ].
	self assert: names = shuffled.

	shuffled := #(#Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday) shuffled.
	indices := shuffled collect: [ :m | self dateClass dayOfWeek: m ].
	names := indices collect: [ :i | self dateClass nameOfDay: i ].
	self assert: names = shuffled.
	
	now  := self dateClass dateAndTimeNow.
	self 
		assert: now size = 2;
		assert: now first = self dateClass today.

	self assert: (self dateClass firstWeekdayOfMonth: #June year: 1973) = 6.

	self
		assert: (self dateClass leapYear: 1973) = 0;
		assert: (self dateClass leapYear: 1972) = 1;
		assert: (self dateClass daysInYear: 1973) = 365;
		assert: (self dateClass daysInYear: 1972) = 366;
		assert: (self dateClass daysInMonth: #February forYear: 1973) = 28;
		assert: (self dateClass daysInMonth: #February forYear: 1972) = 29.
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:17'!
testInitialization

	self should: [ self dateClass initialize. true ].
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:18'!
testInquiries

	self	
		assert: date dayOfMonth = 2;
		assert: date dayOfYear = 153;
		assert: date daysInMonth = 30;
		assert: date daysInYear = 365;
		assert: date daysLeftInYear = (365 - 153);
		assert: date firstDayOfMonth = 152.
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:05'!
testNew
	| epoch |
	epoch := self dateClass newDay: 1 year: 1901.
	self assert: (self dateClass new = epoch).! !

!DateTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 16:33'!
testPreviousNext
	| n p pt ps |
	n := date next.
	p := date previous.

	self
		assert: n year = 1973;
		assert: n dayOfYear = 154;
		assert: p year = 1973;
		assert: p dayOfYear = 152.

	pt := date previous: #Thursday.		"31 May 1973"
	self	
		assert: pt year = 1973;
		assert: pt dayOfYear = 151.

	ps := date previous: #Saturday.		" 26 May 1973"
	self	
		assert: ps year = 1973;
		assert: ps dayOfYear = (153-7).
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:21'!
testPrinting

	self	
		assert: date mmddyyyy = '6/2/1973';
		assert: date yyyymmdd = '1973-06-02';
		assert: (date printFormat: #(3 1 2 $!! 2 1 1)) = '1973!!2!!Jun'.
! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:23'!
testReadFrom
	| s1 s2 s3 s4 s5 | 
	s1 := '2 June 1973'.
	s2 := '2-JUN-73'.
	s3 := 'June 2, 1973'.
	s4 := '6/2/73'.
	s5 := '2JUN73'.

	self	
		assert: date = (self dateClass readFrom: s1 readStream);
		assert: date = (self dateClass readFrom: s2 readStream);
		assert: date = (self dateClass readFrom: s3 readStream);
		assert: date = (self dateClass readFrom: s4 readStream);
		assert: date = (self dateClass readFrom: s5 readStream).! !

!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:05'!
testStoring

	self	
		assert: date storeString = '''2 June 1973'' asDate';
		assert: date = ('2 June 1973' asDate).
! !


!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testAddDays
	self assert: (aDate addDays: 00) yyyymmdd =  '2004-01-23'.	
	self assert: (aDate addDays: 30) yyyymmdd =  '2004-02-22'.
	self assert: (aDate addDays: 60) yyyymmdd =  '2004-03-23'.
	self assert: (aDate addDays: 90) yyyymmdd =  '2004-04-22'.
	self assert: (aDate addDays:120) yyyymmdd =  '2004-05-22'! !

!DateTest methodsFor: 'testing' stamp: 'tbn 7/11/2006 10:37'!
testAddMonths
	self assert: (aDate addMonths: 0) yyyymmdd =  '2004-01-23'.	
	self assert: (aDate addMonths: 1) yyyymmdd =  '2004-02-23'.
	self assert: (aDate addMonths: 2) yyyymmdd =  '2004-03-23'.
	self assert: (aDate addMonths: 3) yyyymmdd =  '2004-04-23'.
	self assert: (aDate addMonths: 12) yyyymmdd =  '2005-01-23'.
	
	self assert: ((Date readFrom: '05-31-2017' readStream) addMonths: 1) yyyymmdd =  '2017-06-30'.
	self assert: ((Date readFrom: '02-29-2000' readStream) addMonths: 12) yyyymmdd =  '2001-02-28'! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testAsDate
	self assert: (aDate asDate) = aDate
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testAsSeconds
	self assert: (aDate asSeconds) =   3252268800.
	self assert: (aDate asSeconds) =  ((103*365*24*60*60) + (22+25"leap days"*24*60*60)) .
	self assert: aDate  =  (Date fromSeconds: 3252268800).! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testDateAndTimeNow
	"Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch time errors"
	self assert: Date dateAndTimeNow first  = Date today 
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testDayMonthYearDo
	self assert: (aDate dayMonthYearDo: [:day :month :year | day asString , month asString, year asString]) = '2312004'
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testDaysInMonthForYear
	self assert: (Date daysInMonth: 'February' forYear: 2008)  = 29.	
	self assert: (Date daysInMonth: 'February' forYear: 2000)  = 29.	
	self assert: (Date daysInMonth: 'February' forYear: 2100)  = 28.	
	self assert: (Date daysInMonth: 'July' forYear: 2100)  = 31.	! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testDaysInYear
	self assert: (Date daysInYear: 2008)  = 366.	
	self assert: (Date daysInYear: 2000)  = 366.	
	self assert: (Date daysInYear: 2100)  = 365	
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testDuration
	self assert: aDate duration = 24 hours! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testEqual
	self assert: aDate = (Date readFrom: (ReadStream on: 'January 23, 2004')).! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testFirstWeekdayOfMonthYear
	self assert: (Date firstWeekdayOfMonth: 'January' year: 2004)  = 5.	
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testIndexOfMonth
	self assert: (Date indexOfMonth: 'January')  = 1.	
	self assert: (Date indexOfMonth: 'December')  = 12.	! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testJulianDayNumber
	self assert: aDate = (Date julianDayNumber: ((4713+2004)*365 +1323) ).  ! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testLeap
	self assert: aDate leap = 1.	

! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testLeapNot
	self assert: (aDate addDays: 365) leap = 0
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testLessThan
	self assert: aDate < (Date readFrom: (ReadStream on: '01-24-2004')).! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testMmddyyyy
	self assert: aDate mmddyyyy =  '1/23/2004'! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testNameOfMonth
	self assert: (Date nameOfMonth: 5) = 'May'.	
	self assert: (Date nameOfMonth: 8) = 'August' ! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testNewDayMonthYear
	self assert: aDate = (Date newDay: 23 month: 1 year: 2004)	
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testNewDayYear
	self assert: aDate = (Date newDay: 23 year: 2004)	
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testPreviousFriday
	self assert: (aDate previous: 'Friday') yyyymmdd = '2004-01-16'

! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testPreviousThursday
	self assert: (aDate previous: 'Thursday') yyyymmdd = '2004-01-22'

! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testPrintFormat
	self assert: (aDate printFormat: #(1 2 3 $? 2 2)) =  '23?Jan?04'! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testPrintOn
	| cs rw |
	cs := ReadStream on: '23 January 2004'.
	rw := ReadWriteStream on: ''.
	aDate printOn: rw.
	self assert: rw contents = cs contents! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testPrintOnFormat
	| cs rw |
	cs := ReadStream on: '04*Jan*23'.
	rw := ReadWriteStream on: ''.
	aDate printOn: rw format: #(3 2 1 $* 2 2).
	self assert: rw contents = cs contents! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testStarting
	self assert: aDate = (Date starting: (DateAndTime fromString: '2004-01-23T12:12')).  ! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testStoreOn
	| cs rw |
	cs := ReadStream on: '''23 January 2004'' asDate'.
	rw := ReadWriteStream on: ''.
	aDate storeOn: rw.
	self assert: rw contents = cs contents! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testSubtractDate
	self assert: (aDate subtractDate:(aDate addDays: 30)) = -30.	
	self assert: (aDate subtractDate:(aDate subtractDays: 00)) = 0.	
	self assert: (aDate subtractDate:(aDate subtractDays: 30)) = 30.

! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testSubtractDays
	self assert: (aDate subtractDays: 00) yyyymmdd =  '2004-01-23'.	
	self assert: (aDate subtractDays: 30) yyyymmdd =  '2003-12-24'.
	self assert: (aDate subtractDays: 60) yyyymmdd =  '2003-11-24'
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testTomorrow
	"Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch many errors"
	self assert: Date tomorrow  > Date today 
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testWeekday
	self assert: aDate weekday = 'Friday'.	
	self assert: aDate weekdayIndex = 6. 
	self assert: (Date dayOfWeek: aDate weekday ) =6.
	self assert: (Date nameOfDay: 6 ) = 'Friday'	! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testYesterday
	"Not a great test:  doesnt catch many errors"
	self assert: Date yesterday  < Date today 
! !

!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'!
testYyyymmdd
	self assert: aDate yyyymmdd =  '2004-01-23'! !


!DateTest methodsFor: 'Private' stamp: 'brp 8/24/2003 00:10'!
dateClass

	^ Date! !
CodeHolder subclass: #Debugger
	instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC sourceMap tempNames savedCursor isolationHead failedProject errorWasInUIProcess labelString theMethodNode'
	classVariableNames: 'ContextStackKeystrokes ErrorRecursion'
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!Debugger commentStamp: '<historical>' prior: 0!
I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context.

Special note on recursive errors:
Some errors affect Squeak's ability to present a debugger.  This is normally an unrecoverable situation.  However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger.  Here is the chain of events in such a recovery.

	* A recursive error is detected.
	* The current project is queried for an isolationHead
	* Changes in the isolationHead are revoked
	* The parent project of isolated project is returned to
	* The debugger is opened there and execution resumes.

If the user closes that debugger, execution continues in the outer project and layer.  If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. !


!Debugger methodsFor: 'accessing' stamp: 'di 10/9/1998 17:15'!
contents 
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information.  This information is the
	method in the currently selected context."

	contents == nil ifTrue: [^ String new].
	^ contents copy! !

!Debugger methodsFor: 'accessing'!
contextVariablesInspector
	"Answer the instance of Inspector that is providing a view of the 
	variables of the selected context."

	^contextVariablesInspector! !

!Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 12:16'!
doNothing: newText
	"Notifier window can't accept text"! !

!Debugger methodsFor: 'accessing'!
interruptedContext
	"Answer the suspended context of the interrupted process."

	^contextStackTop! !

!Debugger methodsFor: 'accessing'!
interruptedProcess
	"Answer the interrupted process."

	^interruptedProcess! !

!Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 15:47'!
isNotifier
	"Return true if this debugger has not been expanded into a full sized window"

	^ receiverInspector == nil! !

!Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'!
labelString
	^labelString! !

!Debugger methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
labelString: aString
	labelString := aString.
	self changed: #relabel! !

!Debugger methodsFor: 'accessing'!
proceedValue
	"Answer the value to return to the selected context when the interrupted 
	process proceeds."

	^proceedValue! !

!Debugger methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
proceedValue: anObject 
	"Set the value to be returned to the selected context when the interrupted 
	process proceeds."

	proceedValue := anObject! !

!Debugger methodsFor: 'accessing'!
receiver
	"Answer the receiver of the selected context, if any. Answer nil 
	otherwise."

	contextStackIndex = 0
		ifTrue: [^nil]
		ifFalse: [^self selectedContext receiver]! !

!Debugger methodsFor: 'accessing'!
receiverInspector
	"Answer the instance of Inspector that is providing a view of the 
	variables of the selected context's receiver."

	^receiverInspector! !

!Debugger methodsFor: 'accessing' stamp: 'md 2/20/2006 18:52'!
receiverInspectorObject: obj context: ctxt

	"set context before object so it can refer to context when building field list"
	receiverInspector context: ctxt.
	receiverInspector object: obj.
! !


!Debugger methodsFor: 'as yet unclassified' stamp: 'nk 8/6/2003 13:52'!
codePaneMenu: aMenu shifted: shifted
	aMenu add: 'run to here' target: self selector: #runToSelection: argument: thisContext sender receiver selectionInterval.
	aMenu addLine.
	super codePaneMenu: aMenu shifted: shifted.
	^aMenu.! !

!Debugger methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
runToSelection: selectionInterval
	| currentContext |
	self pc first >= selectionInterval first ifTrue: [ ^self ].
	currentContext := self selectedContext.
	[ currentContext == self selectedContext and: [ self pc first < selectionInterval first ] ] whileTrue: [ self doStep ].! !


!Debugger methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 10:08'!
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].! !


!Debugger methodsFor: 'class list' stamp: 'md 2/17/2006 09:32'!
selectedClass
	"Answer the class in which the currently selected context's method was 
	found."

	^self selectedContext methodClass! !

!Debugger methodsFor: 'class list' stamp: 'md 2/17/2006 09:29'!
selectedClassOrMetaClass
	"Answer the class in which the currently selected context's method was 
	found."

	^self selectedClass! !


!Debugger methodsFor: 'code pane' stamp: 'tk 4/15/1998 18:31'!
contentsSelection

	^ self pcRange! !

!Debugger methodsFor: 'code pane'!
doItContext
	"Answer the context in which a text selection can be evaluated."

	contextStackIndex = 0
		ifTrue: [^super doItContext]
		ifFalse: [^self selectedContext]! !

!Debugger methodsFor: 'code pane'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a
	text selection."

	^self receiver! !

!Debugger methodsFor: 'code pane' stamp: 'tk 5/2/1998 10:04'!
pc

	^ self pcRange! !

!Debugger methodsFor: 'code pane' stamp: 'sd 11/20/2005 21:27'!
pcRange
	"Answer the indices in the source code for the method corresponding to 
	the selected context's program counter value."

	| i pc end |
	(selectingPC and: [contextStackIndex ~= 0])
		ifFalse: [^1 to: 0].
	sourceMap ifNil:
		[sourceMap := theMethodNode sourceMap.
		tempNames := theMethodNode tempNames].
	(sourceMap size = 0 or: [ self selectedContext isDead ]) ifTrue: [^1 to: 0].
	Smalltalk at: #RBProgramNode ifPresent:[:nodeClass|
		(theMethodNode isKindOf: nodeClass) ifTrue: [
			pc := contextStackIndex = 1
				ifTrue: [self selectedContext pc]
				ifFalse: [self selectedContext previousPc].
			i := sourceMap findLast:[:pcRange | pcRange key <= pc].
			i = 0 ifTrue:[^ 1 to: 0].
			^ (sourceMap at: i) value
		].
	].
	pc:= self selectedContext pc -
		(("externalInterrupt" true and: [contextStackIndex=1])
			ifTrue: [1]
			ifFalse: [2]).
	i := sourceMap indexForInserting: (Association key: pc value: nil).
	i < 1 ifTrue: [^1 to: 0].
	i > sourceMap size
		ifTrue:
			[end := sourceMap inject: 0 into:
				[:prev :this | prev max: this value last].
			^ end+1 to: end].
	^(sourceMap at: i) value! !


!Debugger methodsFor: 'code pane menu' stamp: 'sd 11/20/2005 21:27'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 

	| result |
	(#(debug proceed) includes: selector)		"When I am a notifier window"
		ifTrue: [^ self perform: selector]
		ifFalse: [result := super perform: selector orSendTo: otherTarget.
				selector == #doIt ifTrue: [
					result ~~ #failedDoit ifTrue: [self proceedValue: result]].
				^ result]! !


!Debugger methodsFor: 'context stack menu' stamp: 'sw 12/28/1999 13:04'!
abandon
	"abandon the debugger from its pre-debug notifier"
	self abandon: self topView! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 12/28/1999 13:05'!
abandon: aTopView 
	"abandon the notifier represented by aTopView"
	aTopView controller close! !

!Debugger methodsFor: 'context stack menu' stamp: 'rbb 3/1/2005 10:50'!
askForCategoryIn: aClass default: aString
	| categories index category |
	categories := OrderedCollection with: 'new ...'. 
	categories addAll: (aClass allMethodCategoriesIntegratedThrough: Object).	
	index := UIManager default  
				chooseFrom: categories
				title: 'Please provide a good category for the new method!!' translated.
	index = 0 ifTrue: [^ aString].
	category := index = 1 ifTrue: [UIManager default request: 'Enter category name:']
						ifFalse: [categories at: index].
	^ category isEmpty ifTrue: [^ aString] ifFalse: [category]! !

!Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:24'!
browseMessages
	"Present a menu of all messages sent by the currently selected message.
	Open a message set browser of all implementors of the message chosen.
	Do nothing if no message is chosen."

	contextStackIndex = 0 ifTrue: [^ self].
	super browseMessages.! !

!Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:23'!
browseSendersOfMessages
	"Present a menu of the currently selected message, as well as all
	messages sent by it.  Open a message set browser of all implementors
	of the message chosen."

	contextStackIndex = 0 ifTrue: [^ self].
	super browseSendersOfMessages! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'!
browseVersions
	"Create and schedule a message set browser on all versions of the 
	currently selected message selector."

	| class selector |
	class := self selectedClassOrMetaClass.
	selector := self selectedMessageName.
	VersionsBrowser
		browseVersionsOf: (class compiledMethodAt: selector)
		class: self selectedClass theNonMetaClass
		meta: class isMeta
		category: self selectedMessageCategoryName
		selector: selector! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/6/98 23:00'!
buildMessageBrowser
	"Create and schedule a message browser on the current method."

	contextStackIndex = 0 ifTrue: [^ self].
	^ Browser
		openMessageBrowserForClass: self selectedClassOrMetaClass
		selector: self selectedMessageName
		editString: nil! !

!Debugger methodsFor: 'context stack menu'!
close: aScheduledController 
	"The argument is a controller on a view of the receiver.
	That view is closed."

	aScheduledController close
! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'!
contextStackKey: aChar from: view
	"Respond to a keystroke in the context list"

 	| selector |
	selector := ContextStackKeystrokes at: aChar ifAbsent: [nil].
	selector ifNil: [self messageListKey: aChar from: view]
		ifNotNil: [self perform: selector]! !

!Debugger methodsFor: 'context stack menu' stamp: 'kfr 9/24/2004 21:42'!
contextStackMenu: aMenu shifted: shifted
	"Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided"

	^ shifted ifFalse: 
		[self selectedContext selector = #doesNotUnderstand: ifTrue:
			[aMenu 
				add: 'implement in...' 
				subMenu: (self populateImplementInMenu: (Smalltalk isMorphic ifTrue: [MenuMorph new defaultTarget: self] ifFalse: [CustomMenu new]))
				target: nil 
				selector: nil 
				argumentList: #(nil)].
		aMenu labels: 
'fullStack (f)
restart (r)
proceed (p)
step (t)
step through (T)
send (e)
where (w)
peel to first like this
return entered value
toggle break on entry
senders of... (n)
implementors of... (m)
inheritance (i)
versions (v)
inst var refs...
inst var defs...
class var refs...
class variables
class refs (N)
browse full (b)
file out 
mail out bug report
more...'
	lines: #(8 9 13 15 18 21)
	selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst returnValue toggleBreakOnEntry
browseSendersOfMessages browseMessages methodHierarchy browseVersions
browseInstVarRefs browseInstVarDefs
browseClassVarRefs browseClassVariables browseClassRefs
browseMethodFull fileOutMessage mailOutBugReport
shiftedYellowButtonActivity)]

	ifTrue: [aMenu labels: 
'browse class hierarchy
browse class
browse method (O)
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
revert to previous version
remove from current change set
revert & remove from changes
more...' 
	lines: #(5 7 10)
	selections: #(classHierarchy browseClass 
		openSingleMessageBrowser browseAllMessages findMethodInChangeSets 
		inspectInstances inspectSubInstances
		revertToPreviousVersion 
		removeFromCurrentChanges revertAndForget
		unshiftedYellowButtonActivity)]

! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/16/1998 12:19'!
debugProceedMenu: aMenu
	^ aMenu labels: 
'proceed
debug'
	lines: #()
	selections: #(proceed debug )
! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'!
doStep
	"Send the selected message in the accessed method, and regain control 
	after the invoked method returns."
	
	| currentContext newContext |
	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	currentContext := self selectedContext.
	newContext := interruptedProcess completeStep: currentContext.
	newContext == currentContext ifTrue: [
		newContext := interruptedProcess stepToSendOrReturn].
	self contextStackIndex > 1
		ifTrue: [self resetContext: newContext]
		ifFalse: [newContext == currentContext
				ifTrue: [self changed: #contentsSelection.
						self updateInspectors]
				ifFalse: [self resetContext: newContext]].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'!
down
	"move down the context stack to the previous (enclosing) context"

	self toggleContextStackIndex: contextStackIndex+1! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/17/1998 18:06'!
fullStack
	"Change from displaying the minimal stack to a full one."

	self contextStackList size > 20 "Already expanded"
		ifTrue:
			[self changed: #flash]
		ifFalse:
			[self contextStackIndex = 0 ifFalse: [
				self toggleContextStackIndex: self contextStackIndex].
			self fullyExpandStack]! !

!Debugger methodsFor: 'context stack menu' stamp: 'md 10/6/2005 13:45'!
implement: aMessage inClass: aClass
	
	| category |
	category := self askForCategoryIn: aClass default: 'as yet unclassified'.
	aClass compile: aMessage createStubMethod classified: category.
	self setContentsToForceRefetch.
	self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector).
	aMessage arguments doWithIndex: [:arg :i |
		self selectedContext at: i put: arg.
	].
	self resetContext: self selectedContext.
	self debug.
! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'!
mailOutBugReport
	"Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton - 
'Squeak could pre-fill the bug form with lots of vital, but
oft-repeated, information like what is the image version, last update
number, VM version, platform, available RAM, author...'

and address it to the list with the appropriate subject prefix."

	| messageStrm |
	MailSender default ifNil: [^self].

	Cursor write
		showWhile: 
			["Prepare the message"
			messageStrm := WriteStream on: (String new: 1500).
			messageStrm nextPutAll: 'From: ';
			 nextPutAll: MailSender userName;
			 cr;
			 nextPutAll: 'To: squeak-dev@lists.squeakfoundation.org';
			 cr;
			 nextPutAll: 'Subject: ';
			 nextPutAll: '[BUG]'; nextPutAll: self interruptedContext printString;
			 cr;cr;
			 nextPutAll: 'here insert explanation of what you were doing, suspect changes you''ve made and so forth.';cr;cr.
			self interruptedContext errorReportOn: messageStrm.

			MailSender sendMessage: (MailMessage from: messageStrm contents)].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 3/16/2001 17:20'!
messageListMenu: aMenu shifted: shifted
	"The context-stack menu takes the place of the message-list menu in the debugger, so pass it on"

	^ self contextStackMenu: aMenu shifted: shifted! !

!Debugger methodsFor: 'context stack menu' stamp: 'md 2/20/2006 20:23'!
peelToFirst
	"Peel the stack back to the second occurance of the currently selected message.  Very useful for an infinite recursion.  Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning.  Also frees a lot of space!!"

	| ctxt |
	contextStackIndex = 0 ifTrue: [^ Beeper beep].
	"self okToChange ifFalse: [^ self]."
	ctxt := interruptedProcess popTo: self selectedContext findSecondToOldestSimilarSender.
	self resetContext: ctxt.
! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'!
populateImplementInMenu: aMenu

	| msg |
	msg := self selectedContext at: 1.
	self selectedContext receiver class withAllSuperclasses do:
		[:each |
		aMenu add: each name target: self selector: #implement:inClass: argumentList: (Array with: msg with: each)].
	^ aMenu

! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'!
proceed
	"Proceed execution of the receiver's model, starting after the expression at 
	which an interruption occurred."

	Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [
		self proceed: self topView].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29'!
proceed: aTopView 
	"Proceed from the interrupted state of the currently selected context. The 
	argument is the topView of the receiver. That view is closed."

	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	self resumeProcess: aTopView! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'!
restart
	"Proceed from the initial state of the currently selected context. The 
	argument is a controller on a view of the receiver. That view is closed."
	"Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46"

	| ctxt noUnwindError |
	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	ctxt := interruptedProcess popTo: self selectedContext.
	noUnwindError := false.
	ctxt == self selectedContext ifTrue: [
		noUnwindError := true.
		interruptedProcess restartTop; stepToSendOrReturn].
	self resetContext: ctxt.
	(Preferences restartAlsoProceeds and: [noUnwindError]) ifTrue: [self proceed].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'rbb 3/1/2005 10:50'!
returnValue
	"Force a return of a given value to the previous context!!"

	| previous selectedContext expression value |
	contextStackIndex = 0 ifTrue: [^Beeper beep].
	selectedContext := self selectedContext.
	expression := UIManager default request: 'Enter expression for return value:'.
	value := Compiler new 
				evaluate: expression
				in: selectedContext
				to: selectedContext receiver.
	previous := selectedContext sender.
	self resetContext: previous.
	interruptedProcess popTo: previous value: value! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'!
selectPC
	"Toggle the flag telling whether to automatically select the expression 
	currently being executed by the selected context."

	selectingPC := selectingPC not! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29'!
send
	"Send the selected message in the accessed method, and take control in 
	the method invoked to allow further step or send."

	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	interruptedProcess step: self selectedContext.
	self resetContext: interruptedProcess stepToSendOrReturn.
! !

!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:46'!
stepIntoBlock
	"Send messages until you return to the present method context.
	 Used to step into a block in the method."

	interruptedProcess stepToHome: self selectedContext.
	self resetContext: interruptedProcess stepToSendOrReturn.! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'!
up
	"move up the context stack to the next (enclosed) context"

	contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]! !

!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'!
where
	"Select the expression whose evaluation was interrupted."

	selectingPC := true.
	self contextStackIndex: contextStackIndex oldContextWas: self selectedContext
! !


!Debugger methodsFor: 'context stack (message list)'!
contextStackIndex
	"Answer the index of the selected context."

	^contextStackIndex! !

!Debugger methodsFor: 'context stack (message list)'!
contextStackList
	"Answer the array of contexts."

	^contextStackList! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'sd 11/20/2005 21:27'!
expandStack
	"A Notifier is being turned into a full debugger.  Show a substantial amount of stack in the context pane."

	self newStack: (contextStackTop stackOfSize: 20).
	contextStackIndex := 0.
	receiverInspector := Inspector inspect: nil.
	contextVariablesInspector := ContextVariablesInspector inspect: nil.
	proceedValue := nil! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'ajh 9/25/2001 00:14'!
fullyExpandStack
	"Expand the stack to include all of it, rather than the first four or five
	contexts."

	self okToChange ifFalse: [^ self].
	self newStack: contextStackTop contextStack.
	self changed: #contextStackList! !

!Debugger methodsFor: 'context stack (message list)'!
messageListIndex
	"Answer the index of the currently selected context."

	^contextStackIndex! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'md 2/20/2006 20:21'!
selectedMessage
	"Answer the source code of the currently selected context."

	contents := theMethodNode sourceText asText.
	theMethodNode isDoIt ifFalse: [
		contents := contents makeSelectorBold].
	^ contents! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'md 2/17/2006 12:02'!
selectedMessageName
	"Answer the message selector of the currently selected context."

	^self selectedContext selector! !

!Debugger methodsFor: 'context stack (message list)'!
toggleContextStackIndex: anInteger 
	"If anInteger is the same as the index of the selected context, deselect it. 
	Otherwise, the context whose index is anInteger becomes the selected 
	context."

	self contextStackIndex: 
		(contextStackIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])
		oldContextWas:
		(contextStackIndex = 0
			ifTrue: [nil]
			ifFalse: [contextStack at: contextStackIndex])! !


!Debugger methodsFor: 'dependents access' stamp: 'di 1/14/1999 09:28'!
step 
	"Update the inspectors."

	receiverInspector ifNotNil: [receiverInspector step].
	contextVariablesInspector ifNotNil: [contextVariablesInspector step].
! !

!Debugger methodsFor: 'dependents access' stamp: 'hmm 7/15/2001 19:48'!
updateInspectors 
	"Update the inspectors on the receiver's variables."

	receiverInspector == nil ifFalse: [receiverInspector update].
	contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]! !

!Debugger methodsFor: 'dependents access' stamp: 'di 1/14/1999 09:25'!
wantsSteps
 
	^ true! !


!Debugger methodsFor: 'initialize' stamp: 'md 2/24/2006 15:44'!
addOptionalButtonsTo: window at: fractions plus: verticalOffset 
	"Add button panes to the window. A row of custom
	debugger-specific buttons (Proceed, Restart, etc.) is always
	added, and if optionalButtons is in force, then the standard
	code-tool buttons are also added. Answer the verticalOffset
	plus the height added."
	| delta buttons anOffset |
	anOffset := (Preferences optionalButtons
					and: [Preferences extraDebuggerButtons])
				ifTrue: [super
						addOptionalButtonsTo: window
						at: fractions
						plus: verticalOffset]
				ifFalse: [verticalOffset].
	delta := self defaultButtonPaneHeight.
	buttons := self customButtonRow.
	buttons color: Color white; borderWidth: 0.
	window
		addMorph: buttons
		fullFrame: (LayoutFrame
				fractions: fractions
				offsets: (0 @ anOffset corner: 0 @ (anOffset + delta - 1))).
	^ anOffset + delta! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
buildMorphicNotifierLabelled: label message: messageString
	| notifyPane window contentTop extentToUse |
	self expandStack.
	window := (PreDebugWindow labelled: label) model: self.

	contentTop := 0.25.
	extentToUse := 450 @ 156. "nice and wide to show plenty of the error msg"
	window addMorph: (self buttonRowForPreDebugWindow: window)
				frame: (0@0 corner: 1 @ contentTop).

	Preferences eToyFriendly | messageString notNil
		ifFalse:
			[notifyPane := PluggableListMorph on: self list: #contextStackList
				selected: #contextStackIndex changeSelected: #debugAt:
				menu: nil keystroke: nil]
		ifTrue:
			[notifyPane := PluggableTextMorph on: self text: nil accept: nil
				readSelection: nil menu: #debugProceedMenu:.
			notifyPane editString: (self preDebugNotifierContentsFrom: messageString);
				askBeforeDiscardingEdits: false].

	window addMorph: notifyPane frame: (0@contentTop corner: 1@1).
	"window deleteCloseBox.
		chickened out by commenting the above line out, sw 8/14/2000 12:54"
	window setBalloonTextForCloseBox.

	^ window openInWorldExtent: extentToUse! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
buildMVCDebuggerViewLabel: aString minSize: aPoint
	"Build an MVC debugger view around the receiver, and return the StandardSystemView thus created."

	| topView stackListView stackCodeView rcvrVarView rcvrValView ctxtVarView ctxtValView deltaY underPane annotationPane buttonsView oldContextStackIndex |

	oldContextStackIndex := contextStackIndex.
	self expandStack. "Sets contextStackIndex to zero."
	contextStackIndex := oldContextStackIndex.

	topView := StandardSystemView new model: self.
	topView borderWidth: 1.
	stackListView := PluggableListView on: self
			list: #contextStackList
			selected: #contextStackIndex
			changeSelected: #toggleContextStackIndex:
			menu: #contextStackMenu:shifted:
			keystroke: #contextStackKey:from:.
		stackListView menuTitleSelector: #messageListSelectorTitle.
		stackListView window: (0 @ 0 extent: 150 @ 50).
		topView addSubView: stackListView.
	deltaY := 0.
	 self wantsAnnotationPane
		ifTrue:
			[annotationPane := PluggableTextView on: self
				text: #annotation accept: nil readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 150@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: stackListView.
			deltaY := deltaY + self optionalAnnotationHeight.
			underPane := annotationPane]
		ifFalse:
			[underPane := stackListView].
	self wantsOptionalButtons
		ifTrue:
			[buttonsView := self buildMVCOptionalButtonsButtonsView.
			buttonsView borderWidth: 1.
			topView addSubView: buttonsView below: underPane.
			underPane := buttonsView.
			deltaY := deltaY + self optionalButtonHeight].
	stackCodeView := PluggableTextView on: self
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
		stackCodeView window: (0 @ 0 extent: 150 @ (75 - deltaY)).
		topView addSubView: stackCodeView below: underPane.
	rcvrVarView := PluggableListView on: self receiverInspector
			list: #fieldList
			selected: #selectionIndex
			changeSelected: #toggleIndex:
			menu: #fieldListMenu:
			keystroke: #inspectorKey:from:.
		rcvrVarView window: (0 @ 0 extent: 25 @ (50 - deltaY)).
		topView addSubView: rcvrVarView below: stackCodeView.
	rcvrValView := PluggableTextView on: self receiverInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
		rcvrValView window: (0 @ 0 extent: 50 @ (50 - deltaY)).
		topView addSubView: rcvrValView toRightOf: rcvrVarView.
	ctxtVarView := PluggableListView on: self contextVariablesInspector
			list: #fieldList
			selected: #selectionIndex
			changeSelected: #toggleIndex:
			menu: #fieldListMenu:
			keystroke: #inspectorKey:from:.
		ctxtVarView window: (0 @ 0 extent: 25 @ (50 - deltaY)).
		topView addSubView: ctxtVarView toRightOf: rcvrValView.
	ctxtValView := PluggableTextView on: self contextVariablesInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
		ctxtValView window: (0 @ 0 extent: 50 @ (50 - deltaY)).
		topView addSubView: ctxtValView toRightOf: ctxtVarView.
	topView label: aString.
	topView minimumSize: aPoint.
	^ topView! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
buildMVCNotifierButtonView

	| aView bHeight priorButton buttonView |
	aView := View new model: self.
	bHeight := self notifierButtonHeight.
	aView window: (0@0 extent: 350@bHeight).
	priorButton := nil.
	self preDebugButtonQuads do:
		[:aSpec |
			buttonView := PluggableButtonView
				on: self
				getState: nil
				action: aSpec second.
			buttonView
				label: aSpec first;
				insideColor: (Color perform: aSpec third) muchLighter lighter;
				borderWidthLeft: 1 right: 1 top: 0 bottom: 0;
				window: (0@0 extent: 117@bHeight).
			priorButton
				ifNil:
					[aView addSubView: buttonView]
				ifNotNil:
					[aView addSubView: buttonView toRightOf: priorButton].
			priorButton := buttonView].
	^ aView! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
buildMVCNotifierViewLabel: aString message: messageString minSize: aPoint

	| topView notifyView buttonView x y bHeight |
	self expandStack.
	topView := StandardSystemView new model: self.
	topView borderWidth: 1.
	buttonView := self buildMVCNotifierButtonView.
	topView addSubView: buttonView.
	notifyView := PluggableListView on: self
		list: #contextStackList
		selected: #contextStackIndex
		changeSelected: #debugAt:
		menu: nil
		keystroke: nil.
	x := 350 max: (aPoint x).
	y := ((4 * 15) + 16) max: (aPoint y - 16 - self optionalButtonHeight).
	bHeight := self optionalButtonHeight.
	y := y - bHeight.
	notifyView window: (0@0 extent: x@y).
	topView
		addSubView: notifyView below: buttonView;
		label: aString;
		minimumSize: aPoint.
	^ topView! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
buildMVCOptionalButtonsButtonsView

	| aView bHeight offset aButtonView wid pairs windowWidth previousView |
	aView := View new model: self.
	bHeight := self optionalButtonHeight.
	windowWidth := 150.
	aView window: (0@0 extent: windowWidth@bHeight).
	offset := 0.
	pairs := self optionalButtonPairs.
	previousView := nil.
	pairs do: [:pair |
		aButtonView := PluggableButtonView on: self getState: nil action: pair second.
		pair second = pairs last second
			ifTrue:
				[wid := windowWidth - offset]
			ifFalse:
				[aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0.
				wid := windowWidth // (pairs size)].
		aButtonView
			label: pair first asParagraph;
			insideColor: Color red muchLighter lighter;
			window: (offset@0 extent: wid@bHeight).
		offset := offset + wid.
		pair second = pairs first second
			ifTrue: [aView addSubView: aButtonView]
			ifFalse: [aView addSubView: aButtonView toRightOf: previousView].
		previousView := aButtonView].
	^ aView! !

!Debugger methodsFor: 'initialize' stamp: 'md 2/24/2006 15:45'!
buttonRowForPreDebugWindow: aDebugWindow
	| aRow aButton quads |
	aRow := AlignmentMorph newRow hResizing: #spaceFill; vResizing: #spaceFill.
	aRow layoutInset: 1; cellInset: 1.
	aRow beSticky.
	aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
	quads := OrderedCollection withAll: self preDebugButtonQuads.
	(self interruptedContext selector == #doesNotUnderstand:) ifTrue: [
		quads add: { 'Create'. #createMethod. #magenta. 'create the missing method' }
	].
	quads do:
			[:quad |
				aButton := SimpleButtonMorph new target: aDebugWindow.
				aButton color: Color white; borderWidth: 1.
				aButton actionSelector: quad second.
				aButton label: quad first.
				aButton submorphs first color: (Color colorFrom: quad third).
				aButton setBalloonText: quad fourth.
				aButton borderStyle: BorderStyle thinGray.
				aButton useSquareCorners.
				aRow addMorphBack: aButton.
				aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
customButtonRow
	"Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'customButtonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane"

	| aRow aButton aLabel |
	aRow := AlignmentMorph newRow beSticky.
	aRow setNameTo: 'customButtonPane'.
	aRow clipSubmorphs: true.
	aButton := SimpleButtonMorph new target: self.
	aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker.
	aRow addTransparentSpacerOfSize: (5@0).
	self customButtonSpecs do:
		[:tuple |
			aButton := PluggableButtonMorph
				on: self
				getState: nil
				action: tuple second.
			aButton
				hResizing: #spaceFill;
				vResizing: #spaceFill;
				onColor: Color white offColor: Color white.
			(#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second)
				ifTrue:
					[aButton askBeforeChanging: true].

			aLabel := Preferences abbreviatedBrowserButtons 
				ifTrue: [self abbreviatedWordingFor: tuple second]
				ifFalse: [nil].
			aButton label: (aLabel ifNil: [tuple first asString]).

			tuple size > 2 ifTrue: [aButton setBalloonText: tuple third].
			aRow addMorphBack: aButton.
			aRow addTransparentSpacerOfSize: (3 @ 0)].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
customButtonSpecs
	"Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger."

	| list |
	list := #(('Proceed'	proceed				'close the debugger and proceed.')
		('Restart'		restart				'reset this context to its start.')
		('Into'			send				'step Into message sends')
		('Over'			doStep				'step Over message sends')
		('Through'		stepIntoBlock		'step into a block')
		('Full Stack'		fullStack			'show full stack')
		('Where'		where				'select current pc range')).
	Preferences restartAlsoProceeds ifTrue:
		[list := list collect: [:each |
			each second == #restart
				ifTrue: [each copy at: 3 put: 'proceed from the beginning of this context.'; yourself]
				ifFalse: [each]]].
	^ list! !

!Debugger methodsFor: 'initialize' stamp: 'kfr 10/4/2000 22:13'!
debugAt: anInteger
	self toggleContextStackIndex: anInteger. 
	 ^ self debug.! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
errorWasInUIProcess: boolean

	errorWasInUIProcess := boolean! !

!Debugger methodsFor: 'initialize' stamp: 'tk 5/9/2003 11:20'!
initialExtent
	"Make the full debugger longer!!"

	dependents size < 9 ifTrue: [^ super initialExtent].	"Pre debug window"
	RealEstateAgent standardWindowExtent y < 400 "a tiny screen" 
		ifTrue: [^ super initialExtent].
	
	^ 600@700
! !

!Debugger methodsFor: 'initialize' stamp: 'sw 12/28/1999 13:07'!
notifierButtonHeight

	^ 18! !

!Debugger methodsFor: 'initialize' stamp: 'wiz 2/25/2006 20:22'!
openFullMorphicLabel: aLabelString
	"Open a full morphic debugger with the given label"

	| window aListMorph oldContextStackIndex |
	oldContextStackIndex := contextStackIndex.
	self expandStack. "Sets contextStackIndex to zero."

	window := (SystemWindow labelled: aLabelString) model: self.
	aListMorph := PluggableListMorph on: self list: #contextStackList
			selected: #contextStackIndex changeSelected: #toggleContextStackIndex:
			menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:.
	aListMorph menuTitleSelector: #messageListSelectorTitle.
	window addMorph: aListMorph
		frame: (0@0 corner: 1@0.25).

	self addLowerPanesTo: window at: (0@0.25 corner: 1@0.8) with: nil.

	window addMorph: ((
		PluggableListMorph new
			doubleClickSelector: #inspectSelection;

			on: self receiverInspector list: #fieldList
			selected: #selectionIndex changeSelected: #toggleIndex:
			menu: #fieldListMenu: keystroke: #inspectorKey:from:) 
		autoDeselect: false)
			"For doubleClick to work best disable autoDeselect"
			
		frame: (0@0.8 corner: 0.2@1).
	window addMorph: (PluggableTextMorph on: self receiverInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
		frame: (0.2@0.8 corner: 0.5@1).
	window addMorph: (
		PluggableListMorph new
			doubleClickSelector: #inspectSelection;

			on: self contextVariablesInspector list: #fieldList
			selected: #selectionIndex changeSelected: #toggleIndex:
			menu: #fieldListMenu: keystroke: #inspectorKey:from:)
		frame: (0.5@0.8 corner: 0.7@1).
	window addMorph: (PluggableTextMorph on: self contextVariablesInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
		frame: (0.7@0.8 corner: 1@1).
	window openInWorld.
	self toggleContextStackIndex: oldContextStackIndex.
	^ window ! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
openFullNoSuspendLabel: aString
	"Create and schedule a full debugger with the given label. Do not terminate the current active process."

	| topView |

	Smalltalk isMorphic ifTrue: [
		self openFullMorphicLabel: aString.
		errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: interruptedProcess.
		^self
	].
	topView := self buildMVCDebuggerViewLabel: aString minSize: 300@200.
	topView controller openNoTerminate.
	^ topView
! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
openNotifierContents: msgString label: label
	"Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired."
	"NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended.  The sender will do this."
	| msg topView p |
	Sensor flushKeyboard.
	savedCursor := Sensor currentCursor.
	Sensor currentCursor: Cursor normal.
	(label beginsWith: 'Space is low')
		ifTrue: [msg := self lowSpaceChoices, (msgString ifNil: [''])]
		ifFalse: [msg := msgString].
	isolationHead ifNotNil:
		["We have already revoked the isolation layer -- now jump to the parent project."
		msg := self isolationRecoveryAdvice, msgString.
		failedProject := Project current.
		isolationHead parent enterForEmergencyRecovery].

	Smalltalk isMorphic ifTrue: [
		self buildMorphicNotifierLabelled: label message: msg.
		errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: interruptedProcess.
		^self
	].

	Display fullScreen.
	topView := self 
		buildMVCNotifierViewLabel: label 
		message: thisContext sender sender shortStack 
		minSize: 350@((14 * 5) + 16 + self optionalButtonHeight).
	ScheduledControllers activeController
		ifNil: [p := Display boundingBox center]
		ifNotNil: [p := ScheduledControllers activeController view displayBox center].
	topView controller openNoTerminateDisplayAt: (p max: (200@60)).
	^ topView! !

!Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 09:50'!
optionalAnnotationHeight

	^ 10! !

!Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 08:31'!
optionalButtonHeight

	^ 10! !

!Debugger methodsFor: 'initialize' stamp: 'sw 8/23/2002 00:23'!
optionalButtonPairs
	"Actually, return triples.  In mvc (until someone deals with this) only the custom debugger-specific buttons are shown, but in morphic, the standard code-tool buttons are provided in addition to the custom buttons"

	^ Smalltalk isMorphic
		ifFalse:
			[self customButtonSpecs]
		ifTrue:
			[super optionalButtonPairs]! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
optionalButtonRow
	"Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'buttonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane"

	| aRow aButton aLabel |
	aRow := AlignmentMorph newRow beSticky.
	aRow setNameTo: 'buttonPane'.
	aRow clipSubmorphs: true.
	aButton := SimpleButtonMorph new target: self.
	aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker.
	aRow addTransparentSpacerOfSize: (5@0).
	self optionalButtonPairs do:
		[:tuple |
				aButton := PluggableButtonMorph
					on: self
					getState: nil
					action: tuple second.
				aButton
					hResizing: #spaceFill;
					vResizing: #spaceFill;
					onColor: Color white offColor: Color white.
				(#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second)
					ifTrue:
						[aButton askBeforeChanging: true].

				aLabel := Preferences abbreviatedBrowserButtons 
					ifTrue: [self abbreviatedWordingFor: tuple second]
					ifFalse: [nil].
				aButton label: (aLabel ifNil: [tuple first asString]).

				tuple size > 2 ifTrue: [aButton setBalloonText: tuple third].
				aRow addMorphBack: aButton.
				aRow addTransparentSpacerOfSize: (3 @ 0)].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'yo 3/15/2005 13:18'!
preDebugButtonQuads

	^Preferences eToyFriendly
		ifTrue: [
	{
	{'Store log' translated.	#storeLog. 	#blue. 	'write a log of the encountered problem' translated}.
	{'Abandon' translated.	#abandon. 	#black.	'abandon this execution by closing this window' translated}.
	{'Debug'	 translated.		#debug. 	#red. 	'bring up a debugger' translated}}]
		ifFalse: [
	{
	{'Proceed' translated.	#proceed. 	#blue. 	'continue execution' translated}.
	{'Abandon' translated.	#abandon. 	#black.	'abandon this execution by closing this window' translated}.
	{'Debug'	 translated.		#debug.		#red. 	'bring up a debugger' translated}}]
! !

!Debugger methodsFor: 'initialize' stamp: 'yo 7/2/2004 17:42'!
preDebugNotifierContentsFrom: messageString
	^ Preferences eToyFriendly
		ifFalse:
			[messageString]
		ifTrue:
			['An error has occurred; you should probably just hit ''abandon''.  Sorry!!' translated] ! !

!Debugger methodsFor: 'initialize' stamp: 'jm 8/20/1998 18:31'!
release

	self windowIsClosing.
	super release.
! !

!Debugger methodsFor: 'initialize' stamp: 'sw 1/24/2001 21:22'!
wantsOptionalButtons
	"The debugger benefits so majorly from the optional buttons that we put them up regardless of the global setting.  Some traditionalists will want to change this method manually!!"

	^ true! !

!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'!
windowIsClosing
	"My window is being closed; clean up. Restart the low space watcher."

	interruptedProcess == nil ifTrue: [^ self].
	interruptedProcess terminate.
	interruptedProcess := nil.
	interruptedController := nil.
	contextStack := nil.
	contextStackTop := nil.
	receiverInspector := nil.
	contextVariablesInspector := nil.
	Smalltalk installLowSpaceWatcher.  "restart low space handler"
! !


!Debugger methodsFor: 'message category list'!
selectedMessageCategoryName
	"Answer the name of the message category of the message of the 
	currently selected context."

	^self selectedClass organization categoryOfElement: self selectedMessageName! !


!Debugger methodsFor: 'notifier menu' stamp: 'sd 11/20/2005 21:27'!
debug
	"Open a full DebuggerView."
	| topView |
	topView := self topView.
	topView model: nil.  "so close won't release me."
	Smalltalk isMorphic
		ifTrue:
			[self breakDependents.
			topView delete.
			^ self openFullMorphicLabel: topView label].

	topView controller controlTerminate.
	topView deEmphasize; erase.

	"a few hacks to get the scroll selection artifacts out when we got here by clicking in the list"
	topView subViewWantingControl ifNotNil: [
		topView subViewWantingControl controller controlTerminate
	].
	topView controller status: #closed.

	self openFullNoSuspendLabel: topView label.
	topView controller closeAndUnscheduleNoErase.
	Processor terminateActive.
! !

!Debugger methodsFor: 'notifier menu' stamp: 'mir 3/5/2004 19:26'!
storeLog
	| logFileName |
	logFileName := Preferences debugLogTimestamp
		ifTrue: ['SqueakDebug-' , Time totalSeconds printString , '.log']
		ifFalse: ['SqueakDebug.log'].
	Smalltalk logError: labelString printString inContext: contextStackTop to: logFileName
! !


!Debugger methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 18:30'!
buildFullWith: builder
	| windowSpec listSpec textSpec panelSpec extent |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'Debugger'.
	Display height < 800 "a small screen" 
		ifTrue:[extent := RealEstateAgent standardWindowExtent]
		ifFalse:[extent := 600@700].
	windowSpec extent: extent.
	windowSpec children: OrderedCollection new.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #contextStackList; 
		getIndex: #contextStackIndex; 
		setIndex: #toggleContextStackIndex:; 
		menu: #contextStackMenu:shifted:; 
		keyPress: #contextStackKey:from:;
		frame: (0@0 corner: 1@0.25).
	windowSpec children add: listSpec.


	panelSpec := self buildOptionalButtonsWith: builder.
	panelSpec frame: (0@0.25 corner: 1@0.3).
	windowSpec children add: panelSpec.

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		getText: #contents; 
		setText: #contents:notifying:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0@0.3corner: 1@0.8).
	windowSpec children add: textSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self receiverInspector;
		list: #fieldList; 
		getIndex: #selectionIndex; 
		setIndex: #toggleIndex:; 
		menu: #fieldListMenu:; 
		keyPress: #inspectorKey:from:;
		frame: (0@0.8 corner: 0.2@1).
	windowSpec children add: listSpec.

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self receiverInspector;
		getText: #contents; 
		setText: #accept:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0.2@0.8 corner: 0.5@1).
	windowSpec children add: textSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self contextVariablesInspector;
		list: #fieldList; 
		getIndex: #selectionIndex; 
		setIndex: #toggleIndex:; 
		menu: #fieldListMenu:; 
		keyPress: #inspectorKey:from:;
		frame: (0.5@0.8 corner: 0.7@1).
	windowSpec children add: listSpec.

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self contextVariablesInspector;
		getText: #contents; 
		setText: #accept:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0.7@0.8 corner: 1@1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !

!Debugger methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 18:15'!
buildNotifierWith: builder label: label message: messageString
	| windowSpec listSpec textSpec panelSpec buttonSpec |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec extent: 450 @ 156. "nice and wide to show plenty of the error msg"
	windowSpec label: label.
	windowSpec children: OrderedCollection new.

	panelSpec := builder pluggablePanelSpec new.
	panelSpec children: OrderedCollection new.
	self preDebugButtonQuads do:[:spec|
		buttonSpec := builder pluggableButtonSpec new.
		buttonSpec model: self.
		buttonSpec label: spec first.
		buttonSpec action: spec second.
		buttonSpec help: spec fourth.
		panelSpec children add: buttonSpec.
	].
	panelSpec layout: #horizontal. "buttons"
	panelSpec frame: (0@0 corner: 1@0.2).
	windowSpec children add: panelSpec.

	Preferences eToyFriendly | messageString notNil ifTrue:[
		listSpec := builder pluggableListSpec new.
		listSpec 
			model: self;
			list: #contextStackList; 
			getIndex: #contextStackIndex; 
			setIndex: #debugAt:; 
			frame: (0@0.2 corner: 1@1).
		windowSpec children add: listSpec.
	] ifFalse:[
		textSpec := builder pluggableTextSpec new.
		textSpec 
			model: self;
			getText: #preDebugMessageString; 
			setText: nil; 
			selection: nil; 
			menu: #debugProceedMenu:;
			frame: (0@0.2corner: 1@1).
		windowSpec children add: textSpec.
	].

	^windowSpec! !

!Debugger methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 16:24'!
buildWith: aBuilder
	^self buildFullWith: aBuilder! !

!Debugger methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 16:25'!
preDebugMessageString
	^'An error has occurred; you should probably just hit ''abandon''.  Sorry!!'! !


!Debugger methodsFor: 'traits' stamp: 'al 7/29/2004 14:37'!
contents: aText notifying: aController 
	"The retrieved information has changed and its source must now be  
	updated. In this case, the retrieved information is the method of the  
	selected context."
	| selector classOfMethod category h ctxt originalClassOfMethod |
	contextStackIndex = 0
		ifTrue: [^ false].
	self selectedContext isExecutingBlock
		ifTrue: [h := self selectedContext finalBlockHome.
			h
				ifNil: [self inform: 'Method not found for block, can''t edit'.
					^ false].
			(self confirm: 'I will have to revert to the method from
which this block originated.  Is that OK?')
				ifTrue: [self resetContext: h]
				ifFalse: [^ false]].
	classOfMethod := self selectedClass.
	category := self selectedMessageCategoryName.
	selector := self selectedClass parserClass new parseSelector: aText.
	selector == self selectedMessageName
		ifFalse: [self inform: 'can''t change selector'.
			^ false].
	originalClassOfMethod := classOfMethod traitOrClassOfSelector: selector.
	selector := originalClassOfMethod
				compile: aText
				classified: category
				notifying: aController.
	selector
		ifNil: [^ false].
	"compile cancelled"
	contents := aText.
	ctxt := interruptedProcess popTo: self selectedContext.
	ctxt == self selectedContext ifFalse: [
		self inform: 'Method saved, but current context unchanged
because of unwind error. Click OK to see error'.
	] ifTrue: [
		interruptedProcess
			restartTopWith: (classOfMethod compiledMethodAt: selector);
		 	stepToSendOrReturn.
		contextVariablesInspector object: nil.
		theMethodNode := Preferences browseWithPrettyPrint
			ifTrue: [ctxt methodNodeFormattedAndDecorated: Preferences colorWhenPrettyPrinting]
			ifFalse: [ctxt methodNode].
		sourceMap := theMethodNode sourceMap.
		tempNames := theMethodNode tempNames.
	].
	self resetContext: ctxt.
	^ true! !


!Debugger methodsFor: '*eToys-code pane' stamp: 'di 11/16/2000 16:03'!
createSyntaxMorph

	| methodNode rootMorph |
	methodNode _ self selectedClass compilerClass new
			parse: contents
			in: self selectedClass
			notifying: nil.
	(rootMorph _ methodNode asMorphicSyntaxUsing: SyntaxMorph)
		parsedInClass: self selectedClass;
		debugger: self.
	self addDependent: rootMorph.
	^rootMorph

! !

!Debugger methodsFor: '*eToys-code pane' stamp: 'di 1/31/2001 11:14'!
toggleSyntaxMorph
"
	syntaxMorph ifNil:
		[syntaxMorph _ self createSyntaxMorph inAScrollPane.
		syntaxMorph color: Color paleOrange].
	standardTextMorph visible ifTrue: [
		standardTextMorph owner replacePane: standardTextMorph with: syntaxMorph.
		syntaxMorph scroller firstSubmorph update: #contentsSelection.
	] ifFalse: [
		syntaxMorph owner replacePane: syntaxMorph with: standardTextMorph.
	].
"
! !


!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock
	| classes chosenClassIndex |
	classes := aClass withAllSuperclasses.
	chosenClassIndex := UIManager default 
		chooseFrom: (classes collect: [:c | c name])
		title: 'Define #', aSelector, ' in which class?'.
	chosenClassIndex = 0 ifTrue: [^ cancelBlock value].
	^ classes at: chosenClassIndex! !

!Debugger methodsFor: 'private' stamp: 'yo 8/12/2003 16:34'!
checkContextSelection

	contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil].
! !

!Debugger methodsFor: 'private' stamp: 'md 2/20/2006 20:30'!
contextStackIndex: anInteger oldContextWas: oldContext 
	"Change the context stack index to anInteger, perhaps in response to user selection."

	| newMethod c |
	contextStackIndex := anInteger.
	anInteger = 0
		ifTrue: [currentCompiledMethod := theMethodNode := tempNames := sourceMap := contents := nil.
			self changed: #contextStackIndex.
			self decorateButtons.
			self contentsChanged.
			contextVariablesInspector object: nil.
			self receiverInspectorObject: self receiver context: nil.
			^ self].
	(newMethod := oldContext == nil
					or: [oldContext method ~~ (currentCompiledMethod := self selectedContext method)])
		ifTrue: [tempNames := sourceMap := nil.
			theMethodNode := Preferences browseWithPrettyPrint
				ifTrue: [ 	self selectedContext methodNodeFormattedAndDecorated: Preferences colorWhenPrettyPrinting ]
				ifFalse: [	self selectedContext methodNode ].
			contents := self selectedMessage.
			self contentsChanged.
			self pcRange
			"will compute tempNamesunless noFrills"].
	self changed: #contextStackIndex.
	self decorateButtons.
	tempNames == nil
		ifTrue: [tempNames := self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil].
	contextVariablesInspector object: (c _ self selectedContext).
	self receiverInspectorObject: self receiver context: c.
	newMethod
		ifFalse: [self changed: #contentsSelection]! !

!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
createMethod
	"Should only be called when this Debugger was created in response to a
	MessageNotUnderstood exception. Create a stub for the method that was
	missing and proceed into it."
	
	| msg chosenClass |
	msg := contextStackTop tempAt: 1.
	chosenClass := self
		askForSuperclassOf: contextStackTop receiver class
		toImplement: msg selector
		ifCancel: [^self].
	self implement: msg inClass: chosenClass.
! !

!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
externalInterrupt: aBoolean

	externalInterrupt := aBoolean ! !

!Debugger methodsFor: 'private' stamp: 'tk 8/17/2000 15:36'!
isolationRecoveryAdvice
	"Return a notifier message string to be presented in case of recovery from recursive error by revoking the changes in an isolation layer.  This surely ranks as one of Squeak's longer help messages."

	^ 'Warning!! You have encountered a recursive error situation.

Don''t panic, but do read the following advice.  If you were just fooling around, the simplest thing to do is to quit and NOT save, and restart Squeak.  If you care about recovery, then read on...

In the process of diagnosing one error, further errors occurred, making it impossible to give you a debugger to work with.  Squeak has jumped to an outer project where many of the objects and code changes that might have caused this problem are not involved in normal operation.  If you are looking at this window, chances are that this first level of recovery was successful.  If there are changes you care a lot about, try to save them now.  Then, hopefully, from the state in this debugger, you can determine what the problem was and fix it.  Do not save this image until you are confident of its recovery.

You are no longer in the world that is damaged.  The two most likely causes of recursive errors are malformed objects (for instance a corrupt value encountered in any display of the desktop) and recurring code errors (such as a change that causes errors in any attempt to display the desktop).

In the case of malformed objects, you can attempt to repair them by altering various bindings in the corrupted environment.  Open this debugger and examine the state of the objects closest to the error.

In the case of code errors, note that you are no longer in a world where the erroneous code is in effect.  The only simple option available is for you to browse to the changeSet for the project in distress, and remove one or more of the changes (later it will be possible to edit the code remotely from here).

If you feel you have repaired the problem, then you may proceed from this debugger.  This will put you back in the project that failed with the changes that failed for another try.  Note that the debugger from which you are proceeding is the second one that occurred;  you will likely find the first one waiting for you when you reenter the failed project!!  Also note that if your error occurred while displaying a morph, it may now be flagged as undisplayable (red with yellow cross);  if so, use the morph debug menu to choose ''start drawing again''.

If you have not repaired the problem, you should close this debugger and delete the failed project after retrieving whatever may be of value in it.

Good luck.

	- The Squeak Fairy Godmother

PS:  If you feel you need the help of a quantum mechanic, do NOT close this window.  Instead, the best thing to do (after saving anything that seems safe to save) would be to use the ''save as...'' command in the world menu, and give it a new image name, such as OOPS.  There is a good chance that someone who knows their way around Squeak can help you out.
'! !

!Debugger methodsFor: 'private' stamp: 'yo 12/3/2004 17:14'!
lowSpaceChoices
	"Return a notifier message string to be presented when space is running low."

	^ 'Warning!! Squeak is almost out of memory!!

Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution.

Here are some suggestions:

 If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem.

 If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available...
   > Close any windows that are not needed.
   > Get rid of some large objects (e.g., images).
   > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window.

 If you want to investigate further, choose "debug" in this window.  Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!).

'
! !

!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
newStack: stack
	| oldStack diff |
	oldStack := contextStack.
	contextStack := stack.
	(oldStack == nil or: [oldStack last ~~ stack last])
		ifTrue: [contextStackList := contextStack collect: [:ctx | ctx printString].
				^ self].
	"May be able to re-use some of previous list"
	diff := stack size - oldStack size.
	contextStackList := diff <= 0
		ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size]
		ifFalse: [diff > 1
				ifTrue: [contextStack collect: [:ctx | ctx printString]]
				ifFalse: [(Array with: stack first printString) , contextStackList]]! !

!Debugger methodsFor: 'private' stamp: 'di 4/14/2000 16:24'!
process: aProcess controller: aController context: aContext

	^ self process: aProcess controller: aController context: aContext isolationHead: nil! !

!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
process: aProcess controller: aController context: aContext isolationHead: projectOrNil

	super initialize.
	Smalltalk at: #MessageTally ifPresentAndInMemory: [:c | c new close].
	contents := nil. 
	interruptedProcess := aProcess.
	interruptedController := aController.
	contextStackTop := aContext.
	self newStack: (contextStackTop stackOfSize: 1).
	contextStackIndex := 1.
	externalInterrupt := false.
	selectingPC := true.
	isolationHead := projectOrNil.
	Smalltalk isMorphic ifTrue:
		[errorWasInUIProcess := false]! !

!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
resetContext: aContext 
	"Used when a new context becomes top-of-stack, for instance when the
	method of the selected context is re-compiled, or the simulator steps or
	returns to a new method. There is room for much optimization here, first
	to save recomputing the whole stack list (and text), and secondly to avoid
	recomposing all that text (by editing the paragraph instead of recreating it)."

	| oldContext |
	oldContext := self selectedContext.
	contextStackTop := aContext.
	self newStack: contextStackTop contextStack.
	self changed: #contextStackList.
	self contextStackIndex: 1 oldContextWas: oldContext.
	self contentsChanged.
! !

!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
resumeProcess: aTopView 
	Smalltalk isMorphic
		ifFalse: [aTopView erase].
	savedCursor
		ifNotNil: [Sensor currentCursor: savedCursor].
	isolationHead
		ifNotNil: [failedProject enterForEmergencyRecovery.
			isolationHead invoke.
			isolationHead := nil].
	interruptedProcess isTerminated ifFalse: [
		Smalltalk isMorphic
			ifTrue: [errorWasInUIProcess
					ifTrue: [Project resumeProcess: interruptedProcess]
					ifFalse: [interruptedProcess resume]]
			ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]].
	"if old process was terminated, just terminate current one"
	interruptedProcess := nil.
	"Before delete, so release doesn't terminate it"
	Smalltalk isMorphic
		ifTrue: [aTopView delete.
			World displayWorld]
		ifFalse: [aTopView controller closeAndUnscheduleNoErase].
	Smalltalk installLowSpaceWatcher.
	"restart low space handler"
	errorWasInUIProcess == false
		ifFalse: [Processor terminateActive]! !

!Debugger methodsFor: 'private'!
selectedContext

	contextStackIndex = 0
		ifTrue: [^contextStackTop]
		ifFalse: [^contextStack at: contextStackIndex]! !

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

Debugger class
	instanceVariableNames: ''!

!Debugger class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
initialize
	ErrorRecursion := false.
	ContextStackKeystrokes := Dictionary new
		at: $e put: #send;
		at: $t put: #doStep;
		at: $T put: #stepIntoBlock;
		at: $p put: #proceed;
		at: $r put: #restart;
		at: $f put: #fullStack;
		at: $w put: #where;
		yourself.

	"Debugger initialize"! !

!Debugger class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
openContext: aContext label: aString contents: contentsStringOrNil
	| isolationHead |
	"Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."
	<primitive: 19> "Simulation guard"
	ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue:
		[Smalltalk logError: aString inContext: aContext to: 'SqueakDebug.log'].
	ErrorRecursion ifTrue:
		[ErrorRecursion := false.
		(isolationHead := Project current isolationHead)
			ifNil: [self primitiveError: aString]
			ifNotNil: [isolationHead revoke]].
	ErrorRecursion := true.
	self informExistingDebugger: aContext label: aString.
	(Debugger context: aContext isolationHead: isolationHead)
		openNotifierContents: contentsStringOrNil
		label: aString.
	ErrorRecursion := false.
	Processor activeProcess suspend.
! !


!Debugger class methodsFor: 'instance creation' stamp: 'di 4/14/2000 16:29'!
context: aContext 
	"Answer an instance of me for debugging the active process starting with the given context."

	^ self context: aContext isolationHead: nil! !

!Debugger class methodsFor: 'instance creation' stamp: 'di 4/14/2000 16:29'!
context: aContext isolationHead: isolationHead
	"Answer an instance of me for debugging the active process starting with the given context."

	^ self new
		process: Processor activeProcess
		controller:
			((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess])
				ifTrue: [ScheduledControllers activeController]
				ifFalse: [nil])
		context: aContext
		isolationHead: isolationHead
! !

!Debugger class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
informExistingDebugger: aContext label: aString
	"Walking the context chain, we try to find out if we're in a debugger stepping situation.
	If we find the relevant contexts, we must rearrange them so they look just like they would
	if the methods were excuted outside of the debugger."
	| ctx quickStepMethod oldSender baseContext |
	ctx := thisContext.
	quickStepMethod := ContextPart compiledMethodAt: #quickSend:to:with:super:.
	[ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx := ctx sender].
	ctx sender == nil ifTrue: [^self].
	baseContext := ctx.
	"baseContext is now the context created by the #quickSend... method."
	oldSender := ctx := ctx sender home sender.
	"oldSender is the context which originally sent the #quickSend... method"
	[ctx == nil or: [ctx receiver isKindOf: self]] whileFalse: [ctx := ctx sender].
	ctx == nil ifTrue: [^self].
	"ctx is the context of the Debugger method #doStep"
	ctx receiver labelString: aString.
	ctx receiver externalInterrupt: false; proceedValue: aContext receiver.
	baseContext swapSender: baseContext sender sender sender.	"remove intervening contexts"
	thisContext swapSender: oldSender.	"make myself return to debugger"
	ErrorRecursion := false.
	^aContext! !


!Debugger class methodsFor: 'opening' stamp: 'sd 11/20/2005 21:28'!
openInterrupt: aString onProcess: interruptedProcess
	"Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low."
	| debugger |
	<primitive: 19> "Simulation guard"
	debugger := self new.
	debugger
		process: interruptedProcess
		controller: ((Smalltalk isMorphic not
					and: [ScheduledControllers activeControllerProcess == interruptedProcess])
						ifTrue: [ScheduledControllers activeController])
		context: interruptedProcess suspendedContext.
	debugger externalInterrupt: true.

Preferences logDebuggerStackToFile ifTrue:
	[(aString includesSubString: 'Space') & 
		(aString includesSubString: 'low') ifTrue: [
			Smalltalk logError: aString inContext: debugger interruptedContext to:'LowSpaceDebug.log']].
	Preferences eToyFriendly ifTrue: [World stopRunningAll].
	^ debugger
		openNotifierContents: nil
		label: aString
! !

!Debugger class methodsFor: 'opening' stamp: 'md 3/23/2006 15:55'!
openOn: process context: context label: title contents: contentsStringOrNil fullView: bool
	"Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."

	| controller errorWasInUIProcess  |
	Smalltalk isMorphic
		ifTrue: [errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: process]
		ifFalse: [controller := ScheduledControllers activeControllerProcess == process
				ifTrue: [ScheduledControllers activeController]].
	WorldState addDeferredUIMessage: [ 
		[	| debugger |

			debugger := self new process: process controller: controller context: context.
			Smalltalk isMorphic
				ifTrue: ["schedule debugger in deferred UI message to address redraw
						problems after opening a debugger e.g. from the testrunner."
					"WorldState addDeferredUIMessage: ["bool
						ifTrue: [debugger openFullNoSuspendLabel: title]
						ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]]
				ifFalse: ["deferred UI message would require special controller in MVC"
					bool
						ifTrue: [debugger openFullNoSuspendLabel: title]
						ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]].
			debugger errorWasInUIProcess: errorWasInUIProcess.
			Preferences logDebuggerStackToFile ifTrue: [
				Smalltalk logError: title inContext: context to: 'SqueakDebug.log'].
			Smalltalk isMorphic
				ifFalse: [ScheduledControllers searchForActiveController "needed since openNoTerminate (see debugger #open...) does not set up activeControllerProcess if activeProcess (this fork) is not the current activeControllerProcess (see #scheduled:from:)"].
		] on: Error do: [:ex |
			self primitiveError: 
				'Orginal error: ', 
				title asString, '.
	Debugger error: ', 
				([ex description] on: Error do: ['a ', ex class printString]), ':'
		]
	].
	process suspend.
! !


!Debugger class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:10'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name  wording: 'Debugger' brightColor: #lightRed pastelColor: #veryPaleRed helpMessage: 'The system debugger.'! !
TestCase subclass: #DebuggerUnwindBug
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Debugger-Tests'!

!DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:38'!
testUnwindBlock
	"test if unwind blocks work properly"
	| sema process |
	sema := Semaphore forMutualExclusion.
	self assert: sema isSignaled.
	"deadlock on the semaphore"
	process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority.
	self deny: sema isSignaled.
	"terminate process"
	process terminate.
	self assert: sema isSignaled.
! !

!DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:41'!
testUnwindDebugger
	"test if unwind blocks work properly when a debugger is closed"
	| sema process debugger top |
	sema := Semaphore forMutualExclusion.
	self assert: sema isSignaled.
	process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority.
	self deny: sema isSignaled.

	"everything set up here - open a debug notifier"
	debugger := Debugger openInterrupt: 'test' onProcess: process.
	"get into the debugger"
	debugger debug.
	top := debugger topView.
	"set top context"
	debugger toggleContextStackIndex: 1.
	"close debugger"
	top delete.

	"and see if unwind protection worked"
	self assert: sema isSignaled.! !

!DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:40'!
testUnwindDebuggerWithStep
	"test if unwind blocks work properly when a debugger is closed"
	| sema process debugger top |
	sema := Semaphore forMutualExclusion.
	self assert: sema isSignaled.
	process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority.
	self deny: sema isSignaled.

	"everything set up here - open a debug notifier"
	debugger := Debugger openInterrupt: 'test' onProcess: process.
	"get into the debugger"
	debugger debug.
	top := debugger topView.
	"set top context"
	debugger toggleContextStackIndex: 1.
	"do single step"
	debugger doStep.
	"close debugger"
	top delete.

	"and see if unwind protection worked"
	self assert: sema isSignaled.! !
InstructionStream subclass: #Decompiler
	instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit caseExits lastJumpPc lastReturnPc limit hasValue blockStackBase'
	classVariableNames: 'ArgumentFlag CascadeFlag CaseFlag IfNilFlag'
	poolDictionaries: ''
	category: 'Compiler-Kernel'!
!Decompiler commentStamp: 'ls 1/28/2004 13:31' prior: 0!
I decompile a method in three phases:
	Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms)
	Parser: prefix symbolic codes -> node tree (same as the compiler)
	Printer: node tree -> text (done by the nodes)
	

instance vars:

	constructor
	method
	instVars
	tempVars
	constTable
	stack
	statements
	lastPc
	exit
	caseExits	- stack of exit addresses that have been seen in the branches of caseOf:'s
	lastJumpPc
	lastReturnPc
	limit
	hasValue
	blockStackBase!


!Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'!
blockForCaseTo: end
	"Decompile a range of code as in statementsForCaseTo:, but return a block node."
	| exprs block oldBase |
	oldBase _ blockStackBase.
	blockStackBase _ stack size.
	exprs _ self statementsForCaseTo: end.
	block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
	blockStackBase _ oldBase.
	lastReturnPc _ -1.  "So as not to mislead outer calls"
	^block! !

!Decompiler methodsFor: 'control'!
blockTo: end
	"Decompile a range of code as in statementsTo:, but return a block node."
	| exprs block oldBase |
	oldBase _ blockStackBase.
	blockStackBase _ stack size.
	exprs _ self statementsTo: end.
	block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
	blockStackBase _ oldBase.
	lastReturnPc _ -1.  "So as not to mislead outer calls"
	^block! !

!Decompiler methodsFor: 'control'!
checkForBlock: receiver
	"We just saw a blockCopy: message. Check for a following block."

	| savePc jump args argPos block |
	receiver == constructor codeThisContext ifFalse: [^false].
	savePc _ pc.
	(jump _ self interpretJump) notNil
		ifFalse:
			[pc _ savePc.  ^nil].
	"Definitely a block"
	jump _ jump + pc.
	argPos _ statements size.
	[self willStorePop]
		whileTrue:
			[stack addLast: ArgumentFlag.  "Flag for doStore:"
			self interpretNextInstructionFor: self].
	args _ Array new: statements size - argPos.
	1 to: args size do:  "Retrieve args"
		[:i | args at: i put: statements removeLast.
		(args at: i) scope: -1  "flag args as block temps"].
	block _ self blockTo: jump.
	stack addLast: (constructor codeArguments: args block: block).
	^true! !

!Decompiler methodsFor: 'control' stamp: 'ls 1/28/2004 13:29'!
statementsForCaseTo: end
	"Decompile the method from pc up to end and return an array of
	expressions. If at run time this block will leave a value on the stack,
	set hasValue to true. If the block ends with a jump or return, set exit
	to the destination of the jump, or the end of the method; otherwise, set
	exit = end. Leave pc = end.
	Note that stack initially contains a CaseFlag which will be removed by
	a subsequent Pop instruction, so adjust the StackPos accordingly."

	| blockPos stackPos |
	blockPos _ statements size.
	stackPos _ stack size - 1. "Adjust for CaseFlag"
	[pc < end]
		whileTrue:
			[lastPc _ pc.  limit _ end.  "for performs"
			self interpretNextInstructionFor: self].
	"If there is an additional item on the stack, it will be the value
	of this block."
	(hasValue _ stack size > stackPos)
		ifTrue:
			[stack last == CaseFlag
				ifFalse: [ statements addLast: stack removeLast] ].
	lastJumpPc = lastPc ifFalse: [exit _ pc].
	caseExits add: exit.
	^self popTo: blockPos! !

!Decompiler methodsFor: 'control'!
statementsTo: end
	"Decompile the method from pc up to end and return an array of
	expressions. If at run time this block will leave a value on the stack,
	set hasValue to true. If the block ends with a jump or return, set exit
	to the destination of the jump, or the end of the method; otherwise, set
	exit = end. Leave pc = end."

	| blockPos stackPos t |
	blockPos _ statements size.
	stackPos _ stack size.
	[pc < end]
		whileTrue:
			[lastPc _ pc.  limit _ end.  "for performs"
			self interpretNextInstructionFor: self].
	"If there is an additional item on the stack, it will be the value
	of this block."
	(hasValue _ stack size > stackPos)
		ifTrue:
			[statements addLast: stack removeLast].
	lastJumpPc = lastPc ifFalse: [exit _ pc].
	^self popTo: blockPos! !


!Decompiler methodsFor: 'initialize-release' stamp: 'ajh 7/21/2003 01:14'!
initSymbols: aClass
	| nTemps namedTemps |
	constructor method: method class: aClass literals: method literals.
	constTable _ constructor codeConstants.
	instVars _ Array new: aClass instSize.
	nTemps _ method numTemps.
	namedTemps _ tempVars ifNil: [method tempNames].
	tempVars _ (1 to: nTemps) collect:
				[:i | i <= namedTemps size
					ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)]
					ifFalse: [constructor codeTemp: i - 1]]! !

!Decompiler methodsFor: 'initialize-release'!
withTempNames: tempNameArray
	tempVars _ tempNameArray! !


!Decompiler methodsFor: 'instruction decoding'!
blockReturnTop
	"No action needed"! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'ls 1/28/2004 13:27'!
case: dist
	"statements = keyStmts CascadeFlag keyValueBlock ... keyStmts"

	| nextCase thenJump stmtStream elements b node cases otherBlock myExits |
	nextCase _ pc + dist.

	"Now add CascadeFlag & keyValueBlock to statements"
	statements addLast: stack removeLast.
	stack addLast: CaseFlag. "set for next pop"
	statements addLast: (self blockForCaseTo: nextCase).

	stack last == CaseFlag
		ifTrue: "Last case"
			["ensure jump is within block (in case thenExpr returns wierdly I guess)"
			stack removeLast. "get rid of CaseFlag"
			stmtStream _ ReadStream on: (self popTo: stack removeLast).
			
			elements _ OrderedCollection new.
			b _ OrderedCollection new.
			[stmtStream atEnd] whileFalse:
				[(node _ stmtStream next) == CascadeFlag
					ifTrue:
						[elements addLast: (constructor
							codeMessage: (constructor codeBlock: b returns: false)
							selector: (constructor codeSelector: #-> code: #macro)
							arguments: (Array with: stmtStream next)).
						 b _ OrderedCollection new]
					ifFalse: [b addLast: node]].
			b size > 0 ifTrue: [self error: 'Bad cases'].
			cases _ constructor codeBrace: elements.
			
			"try find the end of the case"
			myExits := caseExits removeLast: elements size.
			myExits := myExits reject: [ :e | e isNil or: [ e < 0 or: [ e > method size ] ] ].
			myExits isEmpty
				ifTrue: [ thenJump := nextCase ]
				ifFalse: [ thenJump := myExits min ].
			
			otherBlock _ self blockTo: thenJump.
			stack addLast:
				(constructor
					codeMessage: stack removeLast
					selector: (constructor codeSelector: #caseOf:otherwise: code: #macro)
					arguments: (Array with: cases with: otherBlock)).
					
			myExits isEmpty ifTrue:[
				"all branches returned; pop off the statement"
				statements addLast: stack removeLast. ] ].! !

!Decompiler methodsFor: 'instruction decoding'!
doDup

	stack last == CascadeFlag
		ifFalse:
			["Save position and mark cascade"
			stack addLast: statements size.
			stack addLast: CascadeFlag].
	stack addLast: CascadeFlag! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'di 2/5/2000 09:34'!
doPop

	stack isEmpty ifTrue:
		["Ignore pop in first leg of ifNil for value"
		^ self].
	stack last == CaseFlag
		ifTrue: [stack removeLast]
		ifFalse: [statements addLast: stack removeLast].! !

!Decompiler methodsFor: 'instruction decoding'!
doStore: stackOrBlock
	"Only called internally, not from InstructionStream. StackOrBlock is stack
	for store, statements for storePop."

	| var expr |
	var _ stack removeLast.
	expr _ stack removeLast.
	stackOrBlock addLast: (expr == ArgumentFlag
		ifTrue: [var]
		ifFalse: [constructor codeAssignTo: var value: expr])! !

!Decompiler methodsFor: 'instruction decoding'!
jump: dist

	exit _ pc + dist.
	lastJumpPc _ lastPc! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'di 2/6/2000 08:46'!
jump: dist if: condition

	| savePc elseDist sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump
		elseJump condHasValue b isIfNil saveStack |
	stack last == CascadeFlag ifTrue: [^ self case: dist].
	elsePc _ lastPc.
	elseStart _ pc + dist.
	end _ limit.
	"Check for bfp-jmp to invert condition.
	Don't be fooled by a loop with a null body."
	sign _ condition.
	savePc _ pc.
	((elseDist _ self interpretJump) notNil and: [elseDist >= 0 and: [elseStart = pc]])
		ifTrue: [sign _ sign not.  elseStart _ pc + elseDist].
	pc _ savePc.
	ifExpr _ stack removeLast.
	(stack size > 0 and: [stack last == IfNilFlag])
		ifTrue: [stack removeLast.  isIfNil _ true]
		ifFalse: [isIfNil _ false].
	saveStack _ stack.
	stack _ OrderedCollection new.
	thenBlock _ self blockTo: elseStart.
	condHasValue _ hasValue or: [isIfNil].
	"ensure jump is within block (in case thenExpr returns)"
	thenJump _ exit <= end ifTrue: [exit] ifFalse: [elseStart].
	"if jump goes back, then it's a loop"
	thenJump < elseStart
		ifTrue:
			["Must be a while loop...
			thenJump will jump to the beginning of the while expr.  In the case of
			while's with a block in the condition, the while expr
			should include more than just the last expression: find all the
			statements needed by re-decompiling."
			stack _ saveStack.
			pc _ thenJump.
			b _ self statementsTo: elsePc.
			"discard unwanted statements from block"
			b size - 1 timesRepeat: [statements removeLast].
			statements addLast: (constructor
					codeMessage: (constructor codeBlock: b returns: false)
					selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro)
					arguments: (Array with: thenBlock)).
			pc _ elseStart.
			self convertToDoLoop]
		ifFalse:
			["Must be a conditional..."
			elseBlock _ self blockTo: thenJump.
			elseJump _ exit.
			"if elseJump is backwards, it is not part of the elseExpr"
			elseJump < elsePc
				ifTrue: [pc _ lastPc].
			isIfNil
			ifTrue: [cond _ constructor
						codeMessage: ifExpr ifNilReceiver
						selector: (sign
							ifTrue: [constructor codeSelector: #ifNotNil: code: #macro]
							ifFalse: [constructor codeSelector: #ifNil: code: #macro])
						arguments: (Array with: thenBlock)]
			ifFalse: [cond _ constructor
						codeMessage: ifExpr
						selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro)
						arguments:
							(sign
								ifTrue: [Array with: elseBlock with: thenBlock]
								ifFalse: [Array with: thenBlock with: elseBlock])].
			stack _ saveStack.
			condHasValue
				ifTrue: [stack addLast: cond]
				ifFalse: [statements addLast: cond]]! !

!Decompiler methodsFor: 'instruction decoding'!
methodReturnConstant: value

	self pushConstant: value; methodReturnTop! !

!Decompiler methodsFor: 'instruction decoding'!
methodReturnReceiver

	self pushReceiver; methodReturnTop! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'th 3/17/2000 20:48'!
methodReturnTop
	| last |
	last _ stack removeLast "test test" asReturnNode.
	stack size > blockStackBase  "get effect of elided pop before return"
		ifTrue: [statements addLast: stack removeLast].
	exit _ method size + 1.
	lastJumpPc _ lastReturnPc _ lastPc.
	statements addLast: last! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoLiteralVariable: value

	self pushLiteralVariable: value; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset

	self pushReceiverVariable: offset; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset

	self pushTemporaryVariable: offset; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
pushActiveContext

	stack addLast: constructor codeThisContext! !

!Decompiler methodsFor: 'instruction decoding'!
pushConstant: value

	| node |
	node _ value == true ifTrue: [constTable at: 2]
		ifFalse: [value == false ifTrue: [constTable at: 3]
		ifFalse: [value == nil ifTrue: [constTable at: 4]
		ifFalse: [constructor codeAnyLiteral: value]]].
	stack addLast: node! !

!Decompiler methodsFor: 'instruction decoding'!
pushLiteralVariable: assoc

	stack addLast: (constructor codeAnyLitInd: assoc)! !

!Decompiler methodsFor: 'instruction decoding'!
pushReceiver

	stack addLast: (constTable at: 1)! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'nk 2/20/2004 11:56'!
pushReceiverVariable: offset

	| var |
	(var _ instVars at: offset + 1 ifAbsent: []) == nil
		ifTrue:
			["Not set up yet"
			var _ constructor codeInst: offset.
			instVars size < (offset + 1) ifTrue: [
				instVars _ (Array new: offset + 1)
					replaceFrom: 1 to: instVars size with: instVars; yourself ].
			instVars at: offset + 1 put: var].
	stack addLast: var! !

!Decompiler methodsFor: 'instruction decoding'!
pushTemporaryVariable: offset

	stack addLast: (tempVars at: offset + 1)! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'di 1/29/2000 08:38'!
send: selector super: superFlag numArgs: numArgs

	| args rcvr selNode msgNode messages |
	args _ Array new: numArgs.
	(numArgs to: 1 by: -1) do:
		[:i | args at: i put: stack removeLast].
	rcvr _ stack removeLast.
	superFlag ifTrue: [rcvr _ constructor codeSuper].
	(selector == #blockCopy: and: [self checkForBlock: rcvr])
		ifFalse:
			[selNode _ constructor codeAnySelector: selector.
			rcvr == CascadeFlag
				ifTrue:
					["May actually be a cascade or an ifNil: for value."
					self willJumpIfFalse
						ifTrue: "= generated by a case macro"
							[selector == #= ifTrue:
								[" = signals a case statement..."
								statements addLast: args first.
								stack addLast: rcvr. "restore CascadeFlag"
								^ self].
							selector == #== ifTrue:
								[" == signals an ifNil: for value..."
								stack removeLast; removeLast.
								rcvr _ stack removeLast.
								stack addLast: IfNilFlag;
									addLast: (constructor
										codeMessage: rcvr
										selector: selNode
										arguments: args).
								^ self].
							self error: 'bad case: ', selector]
						ifFalse:
							[(self willJumpIfTrue and: [selector == #==]) ifTrue:
								[" == signals an ifNotNil: for value..."
								stack removeLast; removeLast.
								rcvr _ stack removeLast.
								stack addLast: IfNilFlag;
									addLast: (constructor
										codeMessage: rcvr
										selector: selNode
										arguments: args).
								^ self].
							msgNode _ constructor codeCascadedMessage: selNode
											arguments: args].
					stack last == CascadeFlag
						ifFalse:
							["Last message of a cascade"
							statements addLast: msgNode.
							messages _ self popTo: stack removeLast.  "Depth saved by first dup"
							msgNode _ constructor
								codeCascade: stack removeLast
								messages: messages]]
				ifFalse:
					[msgNode _ constructor
								codeMessage: rcvr
								selector: selNode
								arguments: args].
			stack addLast: msgNode]! !

!Decompiler methodsFor: 'instruction decoding'!
storeIntoLiteralVariable: assoc

	self pushLiteralVariable: assoc; doStore: stack! !

!Decompiler methodsFor: 'instruction decoding'!
storeIntoReceiverVariable: offset

	self pushReceiverVariable: offset; doStore: stack! !

!Decompiler methodsFor: 'instruction decoding'!
storeIntoTemporaryVariable: offset

	self pushTemporaryVariable: offset; doStore: stack! !


!Decompiler methodsFor: 'public access'!
decompile: aSelector in: aClass 
	"See Decompiler|decompile:in:method:. The method is found by looking up 
	the message, aSelector, in the method dictionary of the class, aClass."

	^self
		decompile: aSelector
		in: aClass
		method: (aClass compiledMethodAt: aSelector)! !

!Decompiler methodsFor: 'public access'!
decompile: aSelector in: aClass method: aMethod
	"Answer a MethodNode that is the root of the parse tree for the 
	argument, aMethod, which is the CompiledMethod associated with the 
	message, aSelector. Variables are determined with respect to the 
	argument, aClass."

	^self
		decompile: aSelector
		in: aClass
		method: aMethod
		using: DecompilerConstructor new! !

!Decompiler methodsFor: 'public access' stamp: 'md 4/24/2006 11:22'!
decompileBlock: aBlock 
	"Decompile aBlock, returning the result as a BlockNode.  
	Show temp names from source if available."

	| startpc end homeClass blockNode home |

	(home := aBlock home) ifNil: [^ nil].
	(homeClass := home methodClass) ifNil: [^ nil].
	method := home method.
	constructor := DecompilerConstructor new.
	
	self withTempNames: method methodNode tempNames.
	
	self initSymbols: homeClass.
	startpc _ aBlock startpc.
	end _ aBlock endPC.
	stack _ OrderedCollection new: method frameSize.
	caseExits _ OrderedCollection new.
	statements _ OrderedCollection new: 20.
	super method: method pc: startpc - 5.
	blockNode _ self blockTo: end.
	stack isEmpty ifFalse: [self error: 'stack not empty'].
	^ blockNode statements first
	
	"Decompiler new decompileBlock: [3 + 4]"! !

!Decompiler methodsFor: 'public access'!
tempAt: offset
	"Needed by BraceConstructor<PopIntoTemporaryVariable"

	^tempVars at: offset + 1! !


!Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 11:06'!
convertToDoLoop
	"If statements contains the pattern
		var _ startExpr.
		[var <= limit] whileTrue: [...statements... var _ var + incConst]
	then replace this by
		startExpr to: limit by: incConst do: [:var | ...statements...]"
	| initStmt toDoStmt limitStmt |
	statements size < 2 ifTrue: [^ self].
	initStmt _ statements at: statements size-1.
	(toDoStmt _ statements last toDoFromWhileWithInit: initStmt)
		== nil ifTrue: [^ self].
	initStmt variable scope: -1.  "Flag arg as block temp"
	statements removeLast; removeLast; addLast: toDoStmt.

	"Attempt further conversion of the pattern
		limitVar _ limitExpr.
		startExpr to: limitVar by: incConst do: [:var | ...statements...]
	to
		startExpr to: limitExpr by: incConst do: [:var | ...statements...]"
	statements size < 2 ifTrue: [^ self].
	limitStmt _ statements at: statements size-1.
	((limitStmt isMemberOf: AssignmentNode)
		and: [limitStmt variable isTemp
		and: [limitStmt variable == toDoStmt arguments first
		and: [self methodRefersOnlyOnceToTemp: limitStmt variable fieldOffset]]])
		ifFalse: [^ self].
	toDoStmt arguments at: 1 put: limitStmt value.
	limitStmt variable scope: -2.  "Flag limit var so it won't print"
	statements removeLast; removeLast; addLast: toDoStmt.

! !

!Decompiler methodsFor: 'private' stamp: 'ls 1/28/2004 13:11'!
decompile: aSelector in: aClass method: aMethod using: aConstructor

	| block |
	constructor _ aConstructor.
	method _ aMethod.
	self initSymbols: aClass.  "create symbol tables"
	method isQuick
		ifTrue: [block _ self quickMethod]
		ifFalse: 
			[stack _ OrderedCollection new: method frameSize.
			caseExits _ OrderedCollection new.
			statements _ OrderedCollection new: 20.
			super method: method pc: method initialPC.
			block _ self blockTo: method endPC + 1.
			stack isEmpty ifFalse: [self error: 'stack not empty']].
	^constructor
		codeMethod: aSelector
		block: block
		tempVars: tempVars
		primitive: method primitive
		class: aClass! !

!Decompiler methodsFor: 'private' stamp: 'md 2/22/2006 15:51'!
interpretNextInstructionFor: client

	| code varNames |

"Change false here will trace all state in Transcript."
true ifTrue: [^ super interpretNextInstructionFor: client].

	varNames _ self class allInstVarNames.
	code _ (self method at: pc) radix: 16.
	Transcript cr; cr; print: pc; space;
		nextPutAll: '<' , code, '>'.
	8 to: varNames size do:
		[:i | i <= 10 ifTrue: [Transcript cr]
				ifFalse: [Transcript space; space].
		Transcript nextPutAll: (varNames at: i);
				nextPutAll: ': '; print: (self instVarAt: i)].
	Transcript endEntry.
	^ super interpretNextInstructionFor: client! !

!Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 10:55'!
methodRefersOnlyOnceToTemp: offset
	| nRefs byteCode extension scanner |
	nRefs _ 0.
	offset <= 15
		ifTrue:
			[byteCode _ 16 + offset.
			(InstructionStream on: method) scanFor:
				[:instr | instr = byteCode ifTrue: [nRefs _ nRefs + 1].
				nRefs > 1]]
		ifFalse:
			[extension _ 64 + offset.
			scanner _ InstructionStream on: method.
			scanner scanFor:
				[:instr | (instr = 128 and: [scanner followingByte = extension])
							ifTrue: [nRefs _ nRefs + 1].
				nRefs > 1]].
	^ nRefs = 1
! !

!Decompiler methodsFor: 'private'!
popTo: oldPos

	| t |
	t _ Array new: statements size - oldPos.
	(t size to: 1 by: -1) do:
		[:i | t at: i put: statements removeLast].
	^t! !

!Decompiler methodsFor: 'private' stamp: 'di 12/26/1998 21:29'!
quickMethod
	| |
	method isReturnSpecial
		ifTrue: [^ constructor codeBlock:
				(Array with: (constTable at: method primitive - 255)) returns: true].
	method isReturnField
		ifTrue: [^ constructor codeBlock:
				(Array with: (constructor codeInst: method returnField)) returns: true].
	self error: 'improper short method'! !

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

Decompiler class
	instanceVariableNames: ''!

!Decompiler class methodsFor: 'class initialization' stamp: 'di 1/28/2000 22:21'!
initialize

	CascadeFlag _ 'cascade'.  "A unique object"
	CaseFlag _ 'case'. "Ditto"
	ArgumentFlag _ 'argument'.  "Ditto"
	IfNilFlag _ 'ifNil'.  "Ditto"

	"Decompiler initialize"! !


!Decompiler class methodsFor: 'testing' stamp: 'md 2/22/2006 15:51'!
recompileAllTest
	"[self recompileAllTest]"
	"decompile every method and compile it back; if the decompiler is correct then the system should keep running.  :)"
	
	| decompiled ast compiled |
	SystemNavigation default allBehaviorsDo: [ :behavior |
		Utilities informUser: (behavior printString) during: [
			behavior selectors do: [ :sel |
				decompiled := Decompiler new decompile: sel in: behavior.
				ast := Compiler new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ].
				compiled := ast generate: (behavior compiledMethodAt: sel) trailer.
				behavior addSelector: sel withMethod: compiled. ] ] ]! !
ParseNode subclass: #DecompilerConstructor
	instanceVariableNames: 'method instVars nArgs literalValues tempVars'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Support'!
!DecompilerConstructor commentStamp: '<historical>' prior: 0!
I construct the node tree for a Decompiler.!


!DecompilerConstructor methodsFor: 'constructor'!
codeAnyLitInd: association

	^VariableNode new
		name: association key
		key: association
		index: 0
		type: LdLitIndType! !

!DecompilerConstructor methodsFor: 'constructor'!
codeAnyLiteral: value

	^LiteralNode new
		key: value
		index: 0
		type: LdLitType! !

!DecompilerConstructor methodsFor: 'constructor'!
codeAnySelector: selector

	^SelectorNode new
		key: selector
		index: 0
		type: SendType! !

!DecompilerConstructor methodsFor: 'constructor'!
codeArguments: args block: block

	^block arguments: args! !

!DecompilerConstructor methodsFor: 'constructor'!
codeAssignTo: variable value: expression

	^AssignmentNode new variable: variable value: expression! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:34'!
codeBlock: statements returns: returns
	^ BlockNode statements: statements returns: returns! !

!DecompilerConstructor methodsFor: 'constructor'!
codeBrace: elements

	^BraceNode new elements: elements! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'di 11/19/1999 11:06'!
codeCascade: receiver messages: messages

	^ (BraceNode new matchBraceStreamReceiver: receiver messages: messages)
		ifNil: [CascadeNode new receiver: receiver messages: messages]! !

!DecompilerConstructor methodsFor: 'constructor'!
codeCascadedMessage: selector arguments: arguments

	^self
		codeMessage: nil
		selector: selector
		arguments: arguments! !

!DecompilerConstructor methodsFor: 'constructor'!
codeConstants
	"Answer with an array of the objects representing self, true, false, nil,
	-1, 0, 1, 2."

	^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil)
		, ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:35'!
codeEmptyBlock
	^ BlockNode withJust: NodeNil! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'nk 2/20/2004 11:51'!
codeInst: index

	^VariableNode new
		name: (instVars at: index + 1 ifAbsent: ['unknown', index asString])
		index: index
		type: LdInstType! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 2/5/2000 12:37'!
codeMessage: receiver selector: selector arguments: arguments
	| symbol node |
	symbol _ selector key.
	(node _ BraceNode new
			matchBraceWithReceiver: receiver
			selector: symbol
			arguments: arguments) ifNotNil: [^ node].
	(node _ self decodeIfNilWithReceiver: receiver
			selector: symbol
			arguments: arguments) ifNotNil: [^ node].
	^ MessageNode new
			receiver: receiver selector: selector
			arguments: arguments
			precedence: symbol precedence! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'lr 2/6/2006 21:08'!
codeMethod: selector block: block tempVars: vars primitive: primitive class: class
	| node methodTemps |
	node _ self codeSelector: selector code: nil.
	tempVars _ vars.
	methodTemps _ tempVars select: [:t | t scope >= 0].
	^MethodNode new
		selector: node
		arguments: (methodTemps copyFrom: 1 to: nArgs)
		precedence: selector precedence
		temporaries: (methodTemps copyFrom: nArgs + 1 to: methodTemps size)
		block: block
		encoder: (Encoder new initScopeAndLiteralTables
					temps: tempVars
					literals: literalValues
					class: class)
		primitive: primitive
		properties: method properties.! !

!DecompilerConstructor methodsFor: 'constructor'!
codeSelector: sel code: code

	^SelectorNode new key: sel code: code! !

!DecompilerConstructor methodsFor: 'constructor'!
codeSuper

	^NodeSuper! !

!DecompilerConstructor methodsFor: 'constructor'!
codeTemp: index

	^ TempVariableNode new
		name: 't' , (index + 1) printString
		index: index
		type: LdTempType
		scope: 0! !

!DecompilerConstructor methodsFor: 'constructor'!
codeTemp: index named: tempName

	^ TempVariableNode new
		name: tempName
		index: index
		type: LdTempType
		scope: 0! !

!DecompilerConstructor methodsFor: 'constructor'!
codeThisContext

	^NodeThisContext! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'di 1/28/2000 21:23'!
decodeIfNilWithReceiver: receiver selector: selector arguments: arguments

	selector == #ifTrue:ifFalse:
		ifFalse: [^ nil].
	(receiver isMessage: #==
				receiver: nil
				arguments: [:argNode | argNode == NodeNil])
		ifFalse: [^ nil].
	^ (MessageNode new
			receiver: receiver
			selector: (SelectorNode new key: #ifTrue:ifFalse: code: #macro)
			arguments: arguments
			precedence: 3)
		noteSpecialSelector: #ifNil:ifNotNil:! !


!DecompilerConstructor methodsFor: 'initialize-release'!
method: aMethod class: aClass literals: literals

	method _ aMethod.
	instVars _ aClass allInstVarNames.
	nArgs _ method numArgs.
	literalValues _ literals! !
Object subclass: #DeepCopier
	instanceVariableNames: 'references uniClasses newUniClasses'
	classVariableNames: 'NextVariableCheckTime'
	poolDictionaries: ''
	category: 'System-Object Storage'!
!DeepCopier commentStamp: 'tk 3/4/2003 19:39' prior: 0!
DeepCopier does a veryDeepCopy.  

It is a complete tree copy using a dictionary.  Any object that is in the tree twice is only copied once.  All references to the object in the copy of the tree will point to the new copy.  See Object|veryDeepCopy which calls (self veryDeepCopyWith: aDeepCopier).

The dictionary of objects that have been seen, holds the correspondance (uniClass -> new uniClass).

When a tree of morphs points at a morph outside of itself, that morph should not be copied.  Use our own kind of weak pointers for the 'potentially outside' morphs.   Default is that any new class will have all of its fields deeply copied.  If a field needs to be weakly copied, define veryDeepInner: and veryDeepFixupWith:.
     veryDeepInner: has the loop that actually copies the fields.  If a class defines its own copy of veryDeepInner: (to leave some fields out), then veryDeepFixupWith: will be called on that object at the end.  veryDeepInner: can compute an alternate object to put in a field.  (Object veryDeepCopyWith: discovers which superclasses did not define veryDeepInner:, and very deeply copies the variables defined in those classes).
	To decide if a class needs veryDeepInner: and veryDeepFixupWith:, ask this about an instance:  If I duplicate this object, does that mean that I also want to make duplicates of the things it holds onto?  If yes, (i.e. a Paragraph does want a new copy of its Text) then do nothing.  If no, (i.e. an undo command does not want to copy the objects it acts upon), then define veryDeepInner: and veryDeepFixupWith:.
	
Here is an analysis for the specific case of a morph being held by another morph.  
Does field X contain a morph (or a Player whose costume is a morph)?  If not, no action needed.
Is the morph in field X already a submorph of the object?  Is it down lower in the submorph tree?
	If so, no action needed.
Could the morph in field X every appear on the screen (be a submorph of some other morph)?
	If not, no action needed.
	If it could, you must write the methods veryDeepFixupWith:   and   veryDeepInner:, and in them, refrain from sending veryDeepCopyWith: to the contents of field X.

newUniClasses =   true in the normal case.  Every duplicated Player gets a new class.  When false, all duplicates will be siblings (sister instances) of existing players.


----- Things Ted is still considering -----
Rule:  If a morph stores a uniClass class (Player 57) as an object in a field, the new uniClass will not be stored there.   Each uniClass instance does have a new class created for it.  (fix this by putting the old class in references and allow lookup?  Wrong if encounter it before seeing an instance?)

Rule: If object A has object C in a field, and A says (^ C) for the copy, but object B has A in a normal field and it gets deepCopied, and A in encountered first, then there will be two copies of C.  (just be aware of it)

Dependents are now fixed up.  Suppose a model has a dependent view.  In the DependentFields dictionary, model -> (view ...).  
	If only the model is copied, no dependents are created (no one knows about the new model).  
	If only the view is copied, it is inserted into DependentFields on the right side.  model -> (view  copiedView ...).  
	If both are copied, the new model has the new view as its dependent.
	If additional things depend on a model that is copied, the caller must add them to its dependents.
!


!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 10/4/2001 13:54'!
checkBasicClasses
	"Check that no indexes of instance vars have changed in certain classes.  If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated.  The idea is to catch a change while it is still in the system of the programmer who made it.  
	DeepCopier new checkVariables	"

	| str str2 objCls morphCls playerCls |
	str _ '|veryDeepCopyWith: or veryDeepInner: is out of date.'.
	(objCls _ self objInMemory: #Object) ifNotNil: [
		objCls instSize = 0 ifFalse: [self error: 
			'Many implementers of veryDeepCopyWith: are out of date']].
	(morphCls _ self objInMemory: #Morph) ifNotNil: [
		morphCls superclass == Object ifFalse: [self error: 'Morph', str].
		(morphCls instVarNames copyFrom: 1 to: 6) = #('bounds' 'owner' 'submorphs' 
				'fullBounds' 'color' 'extension') 
			ifFalse: [self error: 'Morph', str]].	"added ones are OK"

	str2 _ 'Player|copyUniClassWith: and DeepCopier|mapUniClasses are out of date'.
	(playerCls _ self objInMemory: #Player) ifNotNil: [
		playerCls class instVarNames = #('scripts' 'slotInfo')
			ifFalse: [self error: str2]].
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 15:42'!
checkClass: aClass
	| meth |
	"Check that no indexes of instance vars have changed in certain classes.  If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated.  The idea is to catch a change while it is still in the system of the programmer who made it."

	self checkBasicClasses.	"Unlikely, but important to catch when it does happen."

	"Every class that implements veryDeepInner: must copy all its inst vars.  Danger is that a user will add a new instance variable and forget to copy it.  So check that the last one is mentioned in the copy method."
	(aClass includesSelector: #veryDeepInner:) ifTrue: [ 
		((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [
			aClass instSize > 0 ifTrue: [
				self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]].
	(aClass includesSelector: #veryDeepCopyWith:) ifTrue: [
		meth _ aClass compiledMethodAt: #veryDeepCopyWith:.
		(meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [
			(meth writesField: aClass instSize) ifFalse: [
				self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]].
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'dvf 8/23/2003 11:52'!
checkDeep
	"Write exceptions in the Transcript.  Every class that implements veryDeepInner: must copy all its inst vars.  Danger is that a user will add a new instance variable and forget to copy it.  This check is only run by hand once in a while to make sure nothing was forgotten.  
(Please do not remove this method.)
	DeepCopier new checkDeep 	"

	| mm |
	Transcript
		cr;
		show: 'Instance variables shared with the original object when it is copied'.
	(self systemNavigation allClassesImplementing: #veryDeepInner:) do: 
			[:aClass | 
			(mm := aClass instVarNames size) > 0 
				ifTrue: 
					[aClass instSize - mm + 1 to: aClass instSize
						do: 
							[:index | 
							((aClass compiledMethodAt: #veryDeepInner:) writesField: index) 
								ifFalse: 
									[Transcript
										cr;
										show: aClass name;
										space;
										show: (aClass allInstVarNames at: index)]]]]! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'dvf 8/23/2003 11:53'!
checkVariables
	"Check that no indexes of instance vars have changed in certain classes.  If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated.  The idea is to catch a change while it is still in the system of the programmer who made it.  
	DeepCopier new checkVariables	"

	| meth |
	self checkBasicClasses.

	"Every class that implements veryDeepInner: must copy all its inst vars.  Danger is that a user will add a new instance variable and forget to copy it.  So check that the last one is mentioned in the copy method."
	(self systemNavigation allClassesImplementing: #veryDeepInner:) do: 
			[:aClass | 
			((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) 
				ifFalse: 
					[aClass instSize > 0 
						ifTrue: [self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]].
	(self systemNavigation allClassesImplementing: #veryDeepCopyWith:) do: 
			[:aClass | 
			meth := aClass compiledMethodAt: #veryDeepCopyWith:.
			meth size > 20 & (meth literals includes: #veryDeepCopyWith:) not 
				ifTrue: 
					[(meth writesField: aClass instSize) 
						ifFalse: [self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 13:56'!
fixDependents
	"They are not used much, but need to be right"

	| newDep newModel |
	DependentsFields associationsDo: [:pair |
		pair value do: [:dep | 
			newDep _ references at: dep ifAbsent: [nil].
			newDep ifNotNil: [
				newModel _ references at: pair key ifAbsent: [pair key].
				newModel addDependent: newDep]]].
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'hg 11/23/1999 13:36'!
initialize

	self initialize: 4096.
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/4/2003 19:40'!
initialize: size

	references _ IdentityDictionary new: size.
	uniClasses _ IdentityDictionary new.	"UniClass -> new UniClass"
	"self isItTimeToCheckVariables ifTrue: [self checkVariables]."
		"no more checking at runtime"
	newUniClasses _ true.! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 11/24/1999 17:53'!
intervalForChecks
	"set delay interval for checking for new instance variables to 10 minutes. hg 11/23/1999"

	^600
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 11/25/1999 14:37'!
isItTimeToCheckVariables

	| now isIt |
	NextVariableCheckTime ifNil: [
		NextVariableCheckTime _ Time totalSeconds.
		^ true].
	now _ Time totalSeconds.
	isIt _ NextVariableCheckTime < now.
	isIt ifTrue: ["update time for next check"
		NextVariableCheckTime _ now + self intervalForChecks].
	^isIt
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 14:14'!
mapUniClasses
	"For new Uniclasses, map their class vars to the new objects.  And their additional class instance vars.  (scripts slotInfo) and cross references like (player321)."
	"Players also refer to each other using associations in the References dictionary.  Search the methods of our Players for those.  Make new entries in References and point to them."
| pp oldPlayer newKey newAssoc oldSelList newSelList |

	newUniClasses ifFalse: [^ self].	"All will be siblings.  uniClasses is empty"
"Uniclasses use class vars to hold onto siblings who are referred to in code"
pp _ Player class superclass instSize.
uniClasses do: [:playersClass | "values = new ones"
	playersClass classPool associationsDo: [:assoc |
		assoc value: (assoc value veryDeepCopyWith: self)].
	playersClass scripts: (playersClass privateScripts veryDeepCopyWith: self).	"pp+1"
	"(pp+2) slotInfo was deepCopied in copyUniClass and that's all it needs"
	pp+3 to: playersClass class instSize do: [:ii | 
		playersClass instVarAt: ii put: 
			((playersClass instVarAt: ii) veryDeepCopyWith: self)].
	].

"Make new entries in References and point to them."
References keys "copy" do: [:playerName |
	oldPlayer _ References at: playerName.
	(references includesKey: oldPlayer) ifTrue: [
		newKey _ (references at: oldPlayer) "new player" uniqueNameForReference.
		"now installed in References"
		(references at: oldPlayer) renameTo: newKey]].
uniClasses "values" do: [:newClass |
	oldSelList _ OrderedCollection new.   newSelList _ OrderedCollection new.
	newClass selectorsDo: [:sel | 
		(newClass compiledMethodAt: sel)	 literals do: [:assoc |
			assoc isVariableBinding ifTrue: [
				(References associationAt: assoc key ifAbsent: [nil]) == assoc ifTrue: [
					newKey _ (references at: assoc value ifAbsent: [assoc value]) 
									externalName asSymbol.
					(assoc key ~= newKey) & (References includesKey: newKey) ifTrue: [
						newAssoc _ References associationAt: newKey.
						newClass methodDictionary at: sel put: 
							(newClass compiledMethodAt: sel) clone.	"were sharing it"
						(newClass compiledMethodAt: sel)
							literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc)
							put: newAssoc.
						(oldSelList includes: assoc key) ifFalse: [
							oldSelList add: assoc key.  newSelList add: newKey]]]]]].
	oldSelList with: newSelList do: [:old :new |
			newClass replaceSilently: old to: new]].	"This is text replacement and can be wrong"! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 14:13'!
newUniClasses
	"If false, all new Players are merely siblings of the old players"

	^ newUniClasses! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/4/2003 19:44'!
newUniClasses: newVal
	"If false, all new players are merely siblings of the old players"

	newUniClasses _ newVal! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 15:29'!
objInMemory: ClassSymbol
	| cls |
	"Test if this global is in memory and return it if so."

	cls _ Smalltalk at: ClassSymbol ifAbsent: [^ nil].
	^ cls isInMemory ifTrue: [cls] ifFalse: [nil].! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 8/20/1998 22:13'!
references
	^ references! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 8/19/1998 15:48'!
uniClasses
	^uniClasses! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'ar 9/27/2005 20:27'!
warnIverNotCopiedIn: aClass sel: sel
	"Warn the user to update veryDeepCopyWith: or veryDeepInner:"

	self inform: ('An instance variable was added to to class ', aClass name, ',\and it is not copied in the method ', sel, '.\Please rewrite it to handle all instance variables.\See DeepCopier class comment.') withCRs.
	ToolSet browse: aClass selector: sel! !
Object subclass: #DefaultExternalDropHandler
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!DefaultExternalDropHandler commentStamp: 'dgd 4/5/2004 19:07' prior: 0!
An alternative default handler that uses the file-list services to process files.
!


!DefaultExternalDropHandler methodsFor: 'event handling' stamp: 'bf 9/21/2004 18:44'!
handle: dropStream in: pasteUp dropEvent: anEvent 
	"the file was just droped, let's do our job"
	| fileName services theOne |
	fileName := dropStream name.
	""
	services := self servicesForFileNamed: fileName.
	""
	"no service, default behavior"
	services isEmpty
		ifTrue: [""
			dropStream edit.
			^ self].
	""
	theOne := self chooseServiceFrom: services.
	theOne isNil

		ifFalse: [theOne performServiceFor: dropStream]! !


!DefaultExternalDropHandler methodsFor: 'private' stamp: 'dgd 4/5/2004 20:53'!
chooseServiceFrom: aCollection
	"private - choose a service from aCollection asking the user if  
	needed"
	| menu |
	aCollection size = 1
		ifTrue: [^ aCollection anyOne].
	""
	menu := CustomMenu new.
	aCollection
		do: [:each | menu add: each label action: each].
	^ menu startUp! !

!DefaultExternalDropHandler methodsFor: 'private' stamp: 'dgd 4/5/2004 19:23'!
servicesForFileNamed: aString 
	"private - answer a collection of file-services for the file named  
	aString"
	| allServices |
	allServices := FileList itemsForFile: aString.
	^ allServices
		reject: [:svc | self unwantedSelectors includes: svc selector]! !

!DefaultExternalDropHandler methodsFor: 'private' stamp: 'dgd 4/5/2004 19:23'!
unwantedSelectors
	"private - answer a collection well known unwanted selectors "
	^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! !

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

DefaultExternalDropHandler class
	instanceVariableNames: ''!

!DefaultExternalDropHandler class methodsFor: 'class initialization' stamp: 'dgd 4/5/2004 19:10'!
initialize
	"initialize the receiver"
	ExternalDropHandler defaultHandler: self new! !

!DefaultExternalDropHandler class methodsFor: 'class initialization' stamp: 'dgd 4/5/2004 19:09'!
unload
	"initialize the receiver"
	ExternalDropHandler defaultHandler: nil! !
StandardSystemController subclass: #DeferredActionStandardSystemController
	instanceVariableNames: 'queue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Process Browser'!
!DeferredActionStandardSystemController commentStamp: '<historical>' prior: 0!
This is a StandardSystemController that can queue up objects to be evaluated before its control loop.!


!DeferredActionStandardSystemController methodsFor: 'as yet unclassified' stamp: 'nk 10/28/2000 22:28'!
addDeferredUIMessage: valuableObject 
	queue nextPut: valuableObject! !

!DeferredActionStandardSystemController methodsFor: 'as yet unclassified' stamp: 'nk 10/28/2000 22:27'!
controlActivity
	[queue isEmpty]
		whileFalse: [queue next value].
	^super controlActivity! !

!DeferredActionStandardSystemController methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
initialize
	super initialize.
	queue := SharedQueue new.! !
WriteStream subclass: #DeflateStream
	instanceVariableNames: 'hashHead hashTail hashValue blockPosition blockStart'
	classVariableNames: ''
	poolDictionaries: 'ZipConstants'
	category: 'Compression-Streams'!

!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'!
goodMatchLength
	"Return the length that is considered to be a 'good' match.
	Higher values will result in better compression but take more time."
	^MaxMatch "Best compression"! !

!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'!
hashChainLength
	"Return the max. number of hash chains to traverse.
	Higher values will result in better compression but take more time."
	^4096 "Best compression"! !

!DeflateStream methodsFor: 'accessing' stamp: 'ar 2/19/2004 00:34'!
next: bytes putAll: aCollection startingAt: startPos
	(startPos = 1 and:[bytes = aCollection size]) 
		ifTrue:[^self nextPutAll: aCollection].
	^self nextPutAll: (aCollection copyFrom: startPos to: startPos + bytes - 1)! !

!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 17:33'!
nextPutAll: aCollection
	| start count max |
	aCollection species = collection species
		ifFalse:[
			aCollection do:[:ch| self nextPut: ch].
			^aCollection].
	start := 1.
	count := aCollection size.
	[count = 0] whileFalse:[
		position = writeLimit ifTrue:[self deflateBlock].
		max := writeLimit - position.
		max > count ifTrue:[max := count].
		collection replaceFrom: position+1
			to: position+max
			with: aCollection
			startingAt: start.
		start := start + max.
		count := count - max.
		position := position + max].
	^aCollection! !

!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/28/1999 17:35'!
pastEndPut: anObject
	self deflateBlock.
	^self nextPut: anObject! !


!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:24'!
compare: here with: matchPos min: minLength
	"Compare the two strings and return the length of matching characters.
	minLength is a lower bound for match lengths that will be accepted.
	Note: here and matchPos are zero based."
	| length |
	"First test if we can actually get longer than minLength"
	(collection at: here+minLength+1) = (collection at: matchPos+minLength+1)
		ifFalse:[^0].
	(collection at: here+minLength) = (collection at: matchPos+minLength)
		ifFalse:[^0].
	"Then test if we have an initial match at all"
	(collection at: here+1) = (collection at: matchPos+1)
		ifFalse:[^0].
	(collection at: here+2) = (collection at: matchPos+2)
		ifFalse:[^1].
	"Finally do the real comparison"
	length := 3.
	[length <= MaxMatch and:[
		(collection at: here+length) = (collection at: matchPos+length)]]
			whileTrue:[length := length + 1].
	^length - 1! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/31/1999 18:00'!
deflateBlock
	"Deflate the current contents of the stream"
	| flushNeeded lastIndex |
	(blockStart == nil) ifTrue:[
		"One time initialization for the first block"
		1 to: MinMatch-1 do:[:i| self updateHashAt: i].
		blockStart := 0].

	[blockPosition < position] whileTrue:[
		(position + MaxMatch > writeLimit)
			ifTrue:[lastIndex := writeLimit - MaxMatch]
			ifFalse:[lastIndex := position].
		flushNeeded := self deflateBlock: lastIndex-1
							chainLength: self hashChainLength
							goodMatch: self goodMatchLength.
		flushNeeded ifTrue:[
			self flushBlock.
			blockStart := blockPosition].
		"Make room for more data"
		self moveContentsToFront].
! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 18:05'!
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
	"Continue deflating the receiver's collection from blockPosition to lastIndex.
	Note that lastIndex must be at least MaxMatch away from the end of collection"
	| here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch |
	blockPosition > lastIndex ifTrue:[^false]. "Nothing to deflate"
	hasMatch := false.
	here := blockPosition.
	[here <= lastIndex] whileTrue:[
		hasMatch ifFalse:[
			"Find the first match"
			matchResult := self findMatch: here
								lastLength: MinMatch-1
								lastMatch: here
								chainLength: chainLength
								goodMatch: goodMatch.
			self insertStringAt: here. "update hash table"
			hereMatch := matchResult bitAnd: 16rFFFF.
			hereLength := matchResult bitShift: -16].

		"Look ahead if there is a better match at the next position"
		matchResult := self findMatch: here+1
							lastLength: hereLength
							lastMatch: hereMatch
							chainLength: chainLength
							goodMatch: goodMatch.
		newMatch := matchResult bitAnd: 16rFFFF.
		newLength := matchResult bitShift: -16.

		"Now check if the next match is better than the current one.
		If not, output the current match (provided that the current match
		is at least MinMatch long)"
		(hereLength >= newLength and:[hereLength >= MinMatch]) ifTrue:[
			self assert:[self validateMatchAt: here
							from: hereMatch to: hereMatch + hereLength - 1].
			"Encode the current match"
			flushNeeded := self
				encodeMatch: hereLength
				distance: here - hereMatch.
			"Insert all strings up to the end of the current match.
			Note: The first string has already been inserted."
			1 to: hereLength-1 do:[:i| self insertStringAt: (here := here + 1)].
			hasMatch := false.
			here := here + 1.
		] ifFalse:[
			"Either the next match is better than the current one or we didn't
			have a good match after all (e.g., current match length < MinMatch).
			Output a single literal."
			flushNeeded := self encodeLiteral: (collection byteAt: (here + 1)).
			here := here + 1.
			(here <= lastIndex and:[flushNeeded not]) ifTrue:[
				"Cache the results for the next round"
				self insertStringAt: here.
				hasMatch := true.
				hereMatch := newMatch.
				hereLength := newLength].
		].
		flushNeeded ifTrue:[blockPosition := here. ^true].
	].
	blockPosition := here.
	^false! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:45'!
findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch
	"Find the longest match for the string starting at here.
	If there is no match longer than lastLength return lastMatch/lastLength.
	Traverse at most maxChainLength entries in the hash table.
	Stop if a match of at least goodMatch size has been found."
	| matchResult matchPos distance chainLength limit bestLength length |
	"Compute the default match result"
	matchResult := (lastLength bitShift: 16) bitOr: lastMatch.

	"There is no way to find a better match than MaxMatch"
	lastLength >= MaxMatch ifTrue:[^matchResult].

	"Start position for searches"
	matchPos := hashHead at: (self updateHashAt: here + MinMatch) + 1.

	"Compute the distance to the (possible) match"
	distance := here - matchPos.

	"Note: It is required that 0 < distance < MaxDistance"
	(distance > 0 and:[distance < MaxDistance]) ifFalse:[^matchResult].

	chainLength := maxChainLength.	"Max. nr of match chain to search"
	here > MaxDistance	"Limit for matches that are too old"
		ifTrue:[limit := here - MaxDistance]
		ifFalse:[limit := 0].

	"Best match length so far (current match must be larger to take effect)"
	bestLength := lastLength.

	["Compare the current string with the string at match position"
	length := self compare: here with: matchPos min: bestLength.
	"Truncate accidental matches beyound stream position"
	(here + length > position) ifTrue:[length := position - here].
	"Ignore very small matches if they are too far away"
	(length = MinMatch and:[(here - matchPos) > (MaxDistance // 4)])
		ifTrue:[length := MinMatch - 1].
	length > bestLength ifTrue:["We have a new (better) match than before"
		"Compute the new match result"
		matchResult := (length bitShift: 16) bitOr: matchPos.
		bestLength := length.
		"There is no way to find a better match than MaxMatch"
		bestLength >= MaxMatch ifTrue:[^matchResult].
		"But we may have a good, fast match"
		bestLength > goodMatch ifTrue:[^matchResult].
	].
	(chainLength := chainLength - 1) > 0] whileTrue:[
		"Compare with previous entry in hash chain"
		matchPos := hashTail at: (matchPos bitAnd: WindowMask) + 1.
		matchPos <= limit ifTrue:[^matchResult]. "Match position is too old"
	].
	^matchResult! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:37'!
flushBlock
	"Flush a deflated block"! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:46'!
insertStringAt: here
	"Insert the string at the given start position into the hash table.
	Note: The hash value is updated starting at MinMatch-1 since
	all strings before have already been inserted into the hash table
	(and the hash value is updated as well)."
	| prevEntry |
	hashValue := self updateHashAt: (here + MinMatch).
	prevEntry := hashHead at: hashValue+1.
	hashHead at: hashValue+1 put: here.
	hashTail at: (here bitAnd: WindowMask)+1 put: prevEntry.! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:48'!
updateHash: nextValue
	"Update the running hash value based on the next input byte.
	Return the new updated hash value."
	^((hashValue bitShift: HashShift) bitXor: nextValue) bitAnd: HashMask.! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:47'!
updateHashAt: here
	"Update the hash value at position here (one based)"
	^self updateHash: (collection byteAt: here)! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:43'!
validateMatchAt: pos from: startPos to: endPos
	| here |
	here := pos.
	startPos+1 to: endPos+1 do:[:i|
		(collection at: i) = (collection at: (here := here + 1))
			ifFalse:[^self error:'Not a match']].
	^true! !


!DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'!
encodeLiteral: literal
	"Encode the given literal.
	Return true if the current block needs to be flushed."
	^false! !

!DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'!
encodeMatch: matchLength distance: matchDistance
	"Encode a match of the given length and distance.
	Return true if the current block should be flushed."
	^false! !


!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:30'!
flush
	"Force compression"
	self deflateBlock.! !

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/31/1999 18:00'!
initialize
	blockStart := nil.
	blockPosition := 0.
	hashValue := 0.
	self initializeHashTables.! !

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:32'!
initializeHashTables
	hashHead := WordArray new: 1 << HashBits.
	hashTail := WordArray new: WindowSize.
! !

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:33'!
on: aCollection
	self initialize.
	super on: (aCollection species new: WindowSize * 2).! !

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/28/1999 17:34'!
on: aCollection from: firstIndex to: lastIndex
	"Not for DeflateStreams please"
	^self shouldNotImplement! !


!DeflateStream methodsFor: 'private' stamp: 'ar 12/29/1999 17:50'!
moveContentsToFront
	"Move the contents of the receiver to the front"
	| delta |
	delta := (blockPosition - WindowSize).
	delta <= 0 ifTrue:[^self].
	"Move collection"
	collection 
		replaceFrom: 1 
		to: collection size - delta 
		with: collection 
		startingAt: delta+1.
	position := position - delta.
	"Move hash table entries"
	blockPosition := blockPosition - delta.
	blockStart := blockStart - delta.
	self updateHashTable: hashHead delta: delta.
	self updateHashTable: hashTail delta: delta.! !

!DeflateStream methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'!
updateHashTable: table delta: delta
	| pos |
	<primitive: 'primitiveDeflateUpdateHashTable' module: 'ZipPlugin'>
	1 to: table size do:[:i|
		"Discard entries that are out of range"
		(pos := table at: i) >= delta
			ifTrue:[table at: i put: pos - delta]
			ifFalse:[table at: i put: 0]].! !
Object subclass: #Delay
	instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn'
	classVariableNames: 'AccessProtect ActiveDelay ActiveDelayStartTime SuspendedDelays TimingSemaphore'
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!Delay commentStamp: 'stephaneducasse 10/1/2005 21:07' prior: 0!
I am the main way that a process may pause for some amount of time.  The simplest usage is like this:

	(Delay forSeconds: 5) wait.

An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay.

The maximum delay is (SmallInteger maxVal // 2) milliseconds, or about six days. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. Delays work across millisecond clock roll-overs.


For a more complex example, see  #testDelayOf:for:rect: .

A word of advice:
This is THE highest priority code which is run in Squeak, in other words it is time-critical. The speed of this code is critical for accurate responses, it is critical for network services, it affects every last part of the system.

In short: Don't fix it if it ain't broken!! This code isn't supposed to be beautiful, it's supposed to be fast!! The reason for duplicating code is to make it fast. The reason for not using ifNil:[]ifNotNil:[] is that the compiler may not inline those. Since the effect of changes are VERY hard to predict it is best to leave things as they are for now unless there is an actual need to change anything!


!Delay methodsFor: 'delaying' stamp: 'nk 3/14/2001 08:52'!
isExpired

	^delaySemaphore isSignaled.
! !

!Delay methodsFor: 'delaying' stamp: 'jm 9/12/97 11:11'!
unschedule
	"Unschedule this Delay. Do nothing if it wasn't scheduled."

	| done |
	AccessProtect critical: [
		done _ false.
		[done] whileFalse:
			[SuspendedDelays remove: self ifAbsent: [done _ true]].
		ActiveDelay == self ifTrue: [
			SuspendedDelays isEmpty
				ifTrue: [
					ActiveDelay _ nil.
					ActiveDelayStartTime _ nil]
				ifFalse: [
					SuspendedDelays removeFirst activate]]].
! !

!Delay methodsFor: 'delaying' stamp: 'jm 9/12/97 09:10'!
wait
	"Schedule this Delay, then wait on its semaphore. The current process will be suspended for the amount of time specified when this Delay was created."

	self schedule.
	delaySemaphore wait.
! !


!Delay methodsFor: 'public' stamp: 'brp 10/21/2004 16:05'!
delaySemaphore

	^ delaySemaphore! !


!Delay methodsFor: 'private' stamp: 'tpr 10/4/2005 15:14'!
activate
	"Private!! Make the receiver the Delay to be awoken when the next timer interrupt occurs. This method should only be called from a block protected by the AccessProtect semaphore."

	ActiveDelay _ self.
	ActiveDelayStartTime _ Time millisecondClockValue.
	ActiveDelayStartTime >= resumptionTime ifTrue:[
		"if my time is now or in the past, trigger me and get the next in line activated"
		ActiveDelay signalWaitingProcess.
		SuspendedDelays isEmpty ifTrue:[
			ActiveDelay _ nil.
			ActiveDelayStartTime _ nil.
		] ifFalse:[SuspendedDelays removeFirst activate].
	] ifFalse:[
		TimingSemaphore initSignals.
		Delay primSignal: TimingSemaphore atMilliseconds: resumptionTime.
	].! !

!Delay methodsFor: 'private' stamp: 'jm 9/11/97 14:49'!
adjustResumptionTimeOldBase: oldBaseTime newBase: newBaseTime
	"Private!! Adjust the value of the system's millisecond clock at which this Delay will be awoken. Used to adjust resumption times after a snapshot or clock roll-over."

	resumptionTime _ newBaseTime + (resumptionTime - oldBaseTime).
! !

!Delay methodsFor: 'private' stamp: 'tpr 10/3/2005 17:22'!
beGuardianDelay
	"see comment for class method guardianDelay"
	beingWaitedOn _ false.
	resumptionTime _ SmallInteger maxVal.
	delaySemaphore _ Semaphore new! !

!Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'!
resumptionTime
	"Answer the value of the system's millisecondClock at which the receiver's suspended Process will resume."

	^ resumptionTime
! !

!Delay methodsFor: 'private' stamp: 'jm 9/12/97 11:10'!
schedule
	"Private!! Schedule this Delay, but return immediately rather than waiting. The receiver's semaphore will be signalled when its delay duration has elapsed."

	beingWaitedOn ifTrue: [self error: 'This Delay has already been scheduled.'].
	AccessProtect critical: [
		beingWaitedOn _ true.
		resumptionTime _ Time millisecondClockValue + delayDuration.
		ActiveDelay == nil
			ifTrue: [self activate]
			ifFalse: [
				resumptionTime < ActiveDelay resumptionTime
					ifTrue: [
						SuspendedDelays add: ActiveDelay.
						self activate]
					ifFalse: [SuspendedDelays add: self]]].
! !

!Delay methodsFor: 'private' stamp: 'laza 2/12/2005 11:45'!
setDelay: milliseconds forSemaphore: aSemaphore
	"Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds."

	delayDuration _ milliseconds asInteger.
	delayDuration < 0 ifTrue: [self error: 'delay times cannot be negative'].
	delayDuration > (SmallInteger maxVal // 2)
		ifTrue: [self error: 'delay times can''t be longer than about six days (', (SmallInteger maxVal // 2) printString , 'ms)'].
	delaySemaphore _ aSemaphore.
	beingWaitedOn _ false.! !

!Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'!
signalWaitingProcess
	"The delay time has elapsed; signal the waiting process."

	beingWaitedOn _ false.
	delaySemaphore signal.
! !

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

Delay class
	instanceVariableNames: ''!

!Delay class methodsFor: 'example' stamp: 'jm 9/11/97 11:23'!
testDelayOf: delay for: testCount rect: r
	"Delay testDelayOf: 100 for: 20 rect: (10@10 extent: 30@30).
	 Delay testDelayOf: 400 for: 20 rect: (50@10 extent: 30@30)."

	| onDelay offDelay |
	onDelay _ Delay forMilliseconds: 50.
	offDelay _ Delay forMilliseconds: delay - 50.
	Display fillBlack: r.
	[1 to: testCount do: [:i |
		Display fillWhite: r.
		onDelay wait.
		Display reverse: r.
		offDelay wait].
	] forkAt: Processor userInterruptPriority.
! !


!Delay class methodsFor: 'instance creation' stamp: 'brp 9/25/2003 13:43'!
forDuration: aDuration

	^ self forMilliseconds: aDuration asMilliSeconds
! !

!Delay class methodsFor: 'instance creation' stamp: 'laza 1/30/2005 22:10'!
forMilliseconds: aNumber
	"Return a new Delay for the given number of milliseconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time."

	^ self new setDelay: aNumber forSemaphore: Semaphore new
! !

!Delay class methodsFor: 'instance creation' stamp: 'laza 1/30/2005 22:11'!
forSeconds: aNumber
	^ self forMilliseconds: aNumber * 1000
! !

!Delay class methodsFor: 'instance creation' stamp: 'tpr 10/3/2005 17:13'!
guardianDelay
	"Make a Delay with a resumption time far in the future but still a SmallInteger so that it can be used as a guardian for the active delay queue. No process will be waiting on this and when triggered it will do nothing. What it allows is very long Delays where the resumption time is a large integer; should such a delay get activated it will fail the primitive and we creat one of these guardians to make sure the delay timer keeps going and triggers the resumption time recalculations in save/restoreResumptionTime"
	^self new beGuardianDelay! !

!Delay class methodsFor: 'instance creation' stamp: 'laza 1/30/2005 22:13'!
timeoutSemaphore: aSemaphore afterMSecs: anInteger
	"Create and schedule a Delay to signal the given semaphore when the given number of milliseconds has elapsed. Return the scheduled Delay. The timeout can be cancelled by sending 'unschedule' to this Delay."
	"Details: This mechanism is used to provide a timeout when waiting for an external event, such as arrival of data over a network connection, to signal a semaphore. The timeout ensures that the semaphore will be signalled within a reasonable period of time even if the event fails to occur. Typically, the waiting process cancels the timeout request when awoken, then determines if the awaited event has actually occurred."

	^ (self forMilliseconds: anInteger) schedule
! !



!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 14:59'!
restoreResumptionTimes
	"Private!! Restore the resumption times of all scheduled Delays after a snapshot or clock roll-over. This method should be called only while the AccessProtect semaphore is held."

	| newBaseTime |
	newBaseTime _ Time millisecondClockValue.
	SuspendedDelays do: [:d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime].
	ActiveDelay == nil ifFalse: [
		ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime.
		ActiveDelay activate].
! !

!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:15'!
saveResumptionTimes
	"Private!! Record the resumption times of all Delays relative to a base time of zero. This is done prior to snapshotting or adjusting the resumption times after a clock roll-over. This method should be called only while the AccessProtect semaphore is held."

	| oldBaseTime |
	oldBaseTime _ Time millisecondClockValue.
	ActiveDelay == nil
		ifFalse: [
			oldBaseTime < ActiveDelayStartTime
				ifTrue: [oldBaseTime _ ActiveDelayStartTime].  "clock rolled over"
			ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0].
	SuspendedDelays do:
		[:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0].
! !

!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:00'!
shutDown
	"Suspend the active delay, if any, before snapshotting. It will be reactived when the snapshot is resumed."
	"Details: This prevents a timer interrupt from waking up the active delay in the midst snapshoting, since the active delay will be restarted when resuming the snapshot and we don't want to process the delay twice."

	AccessProtect wait.
	self primSignal: nil atMilliseconds: 0.
	self saveResumptionTimes.
! !

!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:01'!
startUp
	"Restart active delay, if any, when resuming a snapshot."

	self restoreResumptionTimes.
	ActiveDelay == nil ifFalse: [ActiveDelay activate].
	AccessProtect signal.
! !


!Delay class methodsFor: 'testing' stamp: 'ar 9/6/1999 17:05'!
anyActive
	"Return true if there is any delay currently active"
	^ActiveDelay notNil! !

!Delay class methodsFor: 'testing'!
nextWakeUpTime
	^ AccessProtect
		critical: [ActiveDelay isNil
				ifTrue: [0]
				ifFalse: [ActiveDelay resumptionTime]]! !

!Delay class methodsFor: 'testing' stamp: 'tpr 10/3/2005 17:26'!
primSignal: aSemaphore atMilliseconds: aSmallInteger
	"Signal the semaphore when the millisecond clock reaches the value of the second argument. Fail if the first argument is neither a Semaphore nor nil. Essential. See Object documentation whatIsAPrimitive."

	| guardianDelay |
	<primitive: 136>
	"VM code actually only fails if the time parameter is not a SmallInteger value"
	aSmallInteger isInteger ifFalse:["somebody messed up badly and we can't do much about it"
		aSemaphore ifNotNil: [
			ActiveDelay _ nil.
			aSemaphore signal. "Prevent an image crash"].
	^self primitiveError: 'primSignal:atMilliseconds: failed because of a non-Integer resumption time parameter. The Semaphore has been signalled as a best guess of the right thing to do'].

	"So now we feel fairly sure that the aSmallInteger resumption time is actually a large integer and we need to just wait some more. To make the system do that we need a fake Delay and a reasonable resumption time to feed to the VM. A decent value is SmallInteger maxVal since the VM handles correlating that sort of largish value and clock wrapping.
	First though we return the problem Delay to the queue"
	SuspendedDelays add: ActiveDelay.
	"Now we want a Delay set to fire and do nothing"
	guardianDelay _ self guardianDelay.
	guardianDelay activate
	! !


!Delay class methodsFor: 'timer process' stamp: 'jm 9/11/97 15:15'!
startTimerInterruptWatcher
	"Reset the class variables that keep track of active Delays and re-start the timer interrupt watcher process. Any currently scheduled delays are forgotten."
	"Delay startTimerInterruptWatcher"

	| p |
	self primSignal: nil atMilliseconds: 0.
	TimingSemaphore == nil
		ifFalse: [TimingSemaphore terminateProcess].
	TimingSemaphore _ Semaphore new.
	AccessProtect _ Semaphore forMutualExclusion.
	SuspendedDelays _ 
		SortedCollection sortBlock: 
			[:d1 :d2 | d1 resumptionTime <= d2 resumptionTime].
	ActiveDelay _ nil.
	p _ [self timerInterruptWatcher] newProcess.
	p priority: Processor timingPriority.
	p resume.
! !

!Delay class methodsFor: 'timer process' stamp: 'tpr 10/4/2005 13:51'!
timerInterruptWatcher
	"This loop runs in its own process. It waits for a timer interrupt and
	wakes up the active delay. Note that timer interrupts are only enabled
	when there are active delays."
	| nowTime |
	[true]
		whileTrue: [TimingSemaphore wait.
			AccessProtect
				critical: [ActiveDelay == nil
						ifFalse: [ActiveDelay signalWaitingProcess.
							(nowTime := Time millisecondClockValue) < ActiveDelayStartTime
								ifTrue: ["clock wrapped so adjust the resumption
									times of all the suspended delays. No
									point adjusting the active delay since
									we've just triggered it"
									SuspendedDelays
										do: [:d | d adjustResumptionTimeOldBase: ActiveDelayStartTime newBase: nowTime]]].
					SuspendedDelays isEmpty
						ifTrue: [ActiveDelay := nil.
							ActiveDelayStartTime := nil]
						ifFalse: [SuspendedDelays removeFirst activate]]]! !
TestCase subclass: #DelayTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Processes'!

!DelayTest methodsFor: 'testing-limits' stamp: 'stephaneducasse 10/2/2005 17:39'!
testBounds
	"self run: #testBounds"
	
	self should: [Delay forMilliseconds: -1] raise: Error.
	self should: [Delay forMilliseconds: SmallInteger maxVal // 2 + 1] raise: Error. "Not longer than a day"
	self shouldnt: [Delay forMilliseconds: SmallInteger maxVal // 2] raise: Error.
	self shouldnt: [(Delay forMilliseconds: Float pi) wait] raise: Error. "Wait 3ms"
! !
Array weakSubclass: #DependentsArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!DependentsArray commentStamp: '<historical>' prior: 0!
An array of (weak) dependents of some object.!


!DependentsArray methodsFor: 'copying' stamp: 'bf 7/21/2006 17:04'!
copyWith: newElement 
	"Re-implemented to not copy any niled out dependents."
	| copy i |
	copy := self class new: self size + 1.
	i := 0.
	self do: [:item | copy at: (i:=i+1) put: item].
	copy at: (i:=i+1) put: newElement.
	^copy! !

!DependentsArray methodsFor: 'copying' stamp: 'tp 7/6/2006 11:11'!
size
	^self inject: 0 into: [ :count :dep | dep ifNil: [ count ] ifNotNil: [ count + 1 ]]! !


!DependentsArray methodsFor: 'enumerating' stamp: 'nk 3/11/2004 09:34'!
do: aBlock
	"Refer to the comment in Collection|do:."
	| dep |
	1 to: self basicSize do:[:i|
		(dep _ self at: i) ifNotNil:[aBlock value: dep]].! !

!DependentsArray methodsFor: 'enumerating' stamp: 'ar 2/11/2001 01:50'!
select: aBlock 
	"Refer to the comment in Collection|select:."
	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	self do:[:obj|
		(aBlock value: obj)
			ifTrue: [aStream nextPut: obj]].
	^ aStream contents! !

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

DependentsArray class
	instanceVariableNames: ''!
Warning subclass: #Deprecation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!Deprecation commentStamp: 'dew 5/21/2003 17:46' prior: 0!
This Warning is signalled by methods which are deprecated.

The use of Object>>#deprecatedExplanation: aString and Object>>#deprecated: aBlock explanation: aString is recommended.

Idiom: Imagine I want to deprecate the message #foo.

foo
	^ 'foo'

I can replace it with:

foo
	self deprecatedExplanation: 'The method #foo was not good. Use Bar>>newFoo instead.'
	^ 'foo'

Or, for certain cases such as when #foo implements a primitive, #foo can be renamed to #fooDeprecated.

fooDeprecated
	^ <primitive>

foo
	^ self deprecated: [self fooDeprecated] explanation: 'The method #foo was not good. Use Bar>>newFoo instead.'
!

Object subclass: #DescriptionForPartsBin
	instanceVariableNames: 'formalName categoryList documentation globalReceiverSymbol nativitySelector sampleImageForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-PartsBin'!
!DescriptionForPartsBin commentStamp: '<historical>' prior: 0!
An object description, for use with the ObjectsTool and other parts-bin-like repositories.

formalName				The formal name by which the object is to be known 
categoryList				A list of category symbols, by way of attribute tags
documentation			For use in balloon help, etc.
globalReceiverSymbol	A symbol representing the global to whom to send nativitySelector 
nativitySelector 		The selector to send to the global receiver to obtain a new instance!


!DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'!
categories
	"Answer the categoryList of the receiver"

	^ categoryList! !

!DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'!
documentation
	"Answer the documentation of the receiver"

	^ documentation! !

!DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'!
formalName
	"Answer the formalName of the receiver"

	^ formalName! !

!DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'!
globalReceiverSymbol
	"Answer the globalReceiverSymbol of the receiver"

	^ globalReceiverSymbol! !

!DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'!
nativitySelector
	"Answer the nativitySelector of the receiver"

	^ nativitySelector! !

!DescriptionForPartsBin methodsFor: 'access' stamp: 'dgd 9/2/2003 18:57'!
translatedCategories
	"Answer translated the categoryList of the receiver"
	^ self categories
		collect: [:each | each translated]! !


!DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 8/2/2001 01:04'!
formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel
	"Set all of the receiver's instance variables from the parameters provided"

	formalName _ aName.
	categoryList _ aList.
	documentation _ aDoc.
	globalReceiverSymbol _ aSym.
	nativitySelector  _ aSel! !

!DescriptionForPartsBin methodsFor: 'initialization' stamp: 'nk 9/1/2004 16:52'!
sampleImageForm
	"If I have a sample image form override stored, answer it, else answer one obtained by launching an actual instance"

	^ sampleImageForm ifNil:
		[((Smalltalk at: globalReceiverSymbol) perform: nativitySelector) imageFormDepth: 32]! !

!DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 10/24/2001 16:37'!
sampleImageForm: aForm
	"Set the sample image form"

	sampleImageForm _ aForm! !

!DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 11/27/2001 13:19'!
sampleImageFormOrNil
	"If I have a sample image form override stored, answer it, dlse answer nil"

	^ sampleImageForm ! !


!DescriptionForPartsBin methodsFor: 'printing' stamp: 'sw 8/10/2001 21:48'!
printOn: aStream
	aStream nextPutAll: 'a DescriptionForPartsBin, with categoryList=', categoryList asString, ' docmentation=', documentation asString,  ' globalReceiverSymbol=', globalReceiverSymbol asString, ' nativitySelector=', nativitySelector asString ! !

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

DescriptionForPartsBin class
	instanceVariableNames: ''!

!DescriptionForPartsBin class methodsFor: 'instance creation' stamp: 'sw 8/10/2001 14:39'!
formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel
	"Answer a new instance of the receiver with the given traits"

	^ self new formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel! !

!DescriptionForPartsBin class methodsFor: 'instance creation' stamp: 'sw 8/10/2001 22:33'!
fromQuad: aQuad categoryList: aList
	"Answer an instance of DescriptionForPartsBin from the part-defining quad provided"

	^ self formalName: aQuad third categoryList: aList documentation: aQuad fourth globalReceiverSymbol: aQuad first nativitySelector: aQuad second! !
Set subclass: #Dictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!Dictionary commentStamp: '<historical>' prior: 0!
I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a container of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key.  I inherit many operations from Set.!


!Dictionary methodsFor: 'accessing'!
associationAt: key 
	^ self associationAt: key ifAbsent: [self errorKeyNotFound]! !

!Dictionary methodsFor: 'accessing'!
associationAt: key ifAbsent: aBlock 
	"Answer the association with the given key.
	If key is not found, return the result of evaluating aBlock."

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	nil == assoc ifTrue: [ ^ aBlock value ].
	^ assoc! !

!Dictionary methodsFor: 'accessing' stamp: 'tk 4/9/1999 10:22'!
associationDeclareAt: aKey
	"Return an existing association, or create and return a new one.  Needed as a single message by ImageSegment.prepareToBeSaved."

	| existing |
	^ self associationAt: aKey ifAbsent: [
		(Undeclared includesKey: aKey)
			ifTrue: 
				[existing _ Undeclared associationAt: aKey.
				Undeclared removeKey: aKey.
				self add: existing]
			ifFalse: 
				[self add: aKey -> false]]! !

!Dictionary methodsFor: 'accessing' stamp: 'dvf 9/17/2003 16:03'!
associations
	"Answer a Collection containing the receiver's associations."
	| out |
	out _ WriteStream on: (Array new: self size).
	self associationsDo: [:value | out nextPut: value].
	^ out contents! !

!Dictionary methodsFor: 'accessing'!
at: key 
	"Answer the value associated with the key."

	^ self at: key ifAbsent: [self errorKeyNotFound]! !

!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:01'!
at: key ifAbsentPut: aBlock 
	"Return the value at the given key. 
	If key is not included in the receiver store the result 
	of evaluating aBlock as new value."

	^ self at: key ifAbsent: [self at: key put: aBlock value]! !

!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 14:59'!
at: key ifAbsent: aBlock 
	"Answer the value associated with the key or, if key isn't found,
	answer the result of evaluating aBlock."

	| assoc |
	assoc _ array at: (self findElementOrNil: key).
	assoc ifNil: [^ aBlock value].
	^ assoc value! !

!Dictionary methodsFor: 'accessing' stamp: 'di 3/7/2001 15:29'!
at: key ifPresentAndInMemory: aBlock
	"Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."

	| v |
	v _ self at: key ifAbsent: [^ nil].
	v isInMemory ifFalse: [^ nil].
	^ aBlock value: v
! !

!Dictionary methodsFor: 'accessing' stamp: 'jm 5/15/1998 07:20'!
at: key ifPresent: aBlock
	"Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."

	| v |
	v _ self at: key ifAbsent: [^ nil].
	^ aBlock value: v
! !

!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:00'!
at: key put: anObject 
	"Set the value at key to be anObject.  If key is not found, create a
	new entry for key and set is value to anObject. Answer anObject."

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	assoc
		ifNil: [self atNewIndex: index put: (Association key: key value: anObject)]
		ifNotNil: [assoc value: anObject].
	^ anObject! !

!Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'!
keyAtIdentityValue: value 
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer nil.
	Note: There can be multiple keys with the same value. Only one is returned."

	^self keyAtIdentityValue: value ifAbsent: [self errorValueNotFound]! !

!Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'!
keyAtIdentityValue: value ifAbsent: exceptionBlock
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer the result of evaluating exceptionBlock.
	Note: There can be multiple keys with the same value. Only one is returned."
 
	self associationsDo: 
		[:association | value == association value ifTrue: [^association key]].
	^exceptionBlock value! !

!Dictionary methodsFor: 'accessing'!
keyAtValue: value 
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer nil."

	^self keyAtValue: value ifAbsent: [self errorValueNotFound]! !

!Dictionary methodsFor: 'accessing' stamp: 'tk 2/18/97'!
keyAtValue: value ifAbsent: exceptionBlock
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer the result of evaluating exceptionBlock.
	: Use =, not ==, so stings like 'this' can be found.  Note that MethodDictionary continues to use == so it will be fast."
 
	self associationsDo: 
		[:association | value = association value ifTrue: [^association key]].
	^exceptionBlock value! !

!Dictionary methodsFor: 'accessing'!
keys
	"Answer a Set containing the receiver's keys."
	| aSet |
	aSet _ Set new: self size.
	self keysDo: [:key | aSet add: key].
	^ aSet! !

!Dictionary methodsFor: 'accessing' stamp: 'sma 6/18/2000 12:56'!
keysSortedSafely
	"Answer a SortedCollection containing the receiver's keys."
	| sortedKeys |
	sortedKeys _ SortedCollection new: self size.
	sortedKeys sortBlock:
		[:x :y |  "Should really be use <obj, string, num> compareSafely..."
		((x isString and: [y isString])
			or: [x isNumber and: [y isNumber]])
			ifTrue: [x < y]
			ifFalse: [x class == y class
				ifTrue: [x printString < y printString]
				ifFalse: [x class name < y class name]]].
	self keysDo: [:each | sortedKeys addLast: each].
	^ sortedKeys reSort! !

!Dictionary methodsFor: 'accessing' stamp: 'ar 7/11/1999 07:28'!
values
	"Answer a Collection containing the receiver's values."
	| out |
	out _ WriteStream on: (Array new: self size).
	self valuesDo: [:value | out nextPut: value].
	^ out contents! !


!Dictionary methodsFor: 'adding' stamp: 'raok 12/17/2003 16:01'!
addAll: aKeyedCollection
	aKeyedCollection == self ifFalse: [
		aKeyedCollection keysAndValuesDo: [:key :value |
			self at: key put: value]].
	^aKeyedCollection! !

!Dictionary methodsFor: 'adding'!
add: anAssociation
	| index element |
	index _ self findElementOrNil: anAssociation key.
	element _ array at: index.
	element == nil
		ifTrue: [self atNewIndex: index put: anAssociation]
		ifFalse: [element value: anAssociation value].
	^ anAssociation! !

!Dictionary methodsFor: 'adding'!
declare: key from: aDictionary 
	"Add key to the receiver. If key already exists, do nothing. If aDictionary 
	includes key, then remove it from aDictionary and use its association as 
	the element of the receiver."

	(self includesKey: key) ifTrue: [^ self].
	(aDictionary includesKey: key)
		ifTrue: 
			[self add: (aDictionary associationAt: key).
			aDictionary removeKey: key]
		ifFalse: 
			[self add: key -> nil]! !


!Dictionary methodsFor: 'comparing' stamp: 'md 10/17/2004 16:14'!
= aDictionary
	"Two dictionaries are equal if
	 (a) they are the same 'kind' of thing.
	 (b) they have the same set of keys.
	 (c) for each (common) key, they have the same value"

	self == aDictionary ifTrue: [ ^ true ].
	(aDictionary isKindOf: Dictionary) ifFalse: [^false].
	self size = aDictionary size ifFalse: [^false].
	self associationsDo: [:assoc|
		(aDictionary at: assoc key ifAbsent: [^false]) = assoc value
			ifFalse: [^false]].
	^true

! !


!Dictionary methodsFor: 'enumerating'!
associationsDo: aBlock 
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations)."

	super do: aBlock! !

!Dictionary methodsFor: 'enumerating' stamp: 'dtl 2/17/2003 09:40'!
associationsSelect: aBlock 
	"Evaluate aBlock with each of my associations as the argument. Collect
	into a new dictionary, only those associations for which aBlock evaluates
	to true."

	| newCollection |
	newCollection _ self species new.
	self associationsDo: 
		[:each | 
		(aBlock value: each) ifTrue: [newCollection add: each]].
	^newCollection! !

!Dictionary methodsFor: 'enumerating'!
collect: aBlock 
	"Evaluate aBlock with each of my values as the argument.  Collect the
	resulting values into a collection that is like me. Answer with the new
	collection."
	| newCollection |
	newCollection _ OrderedCollection new: self size.
	self do: [:each | newCollection add: (aBlock value: each)].
	^ newCollection! !

!Dictionary methodsFor: 'enumerating'!
do: aBlock

	super do: [:assoc | aBlock value: assoc value]! !

!Dictionary methodsFor: 'enumerating' stamp: 'ar 7/11/1999 08:04'!
keysAndValuesDo: aBlock
	^self associationsDo:[:assoc|
		aBlock value: assoc key value: assoc value].! !

!Dictionary methodsFor: 'enumerating'!
keysDo: aBlock 
	"Evaluate aBlock for each of the receiver's keys."

	self associationsDo: [:association | aBlock value: association key]! !

!Dictionary methodsFor: 'enumerating'!
select: aBlock 
	"Evaluate aBlock with each of my values as the argument. Collect into a
	new dictionary, only those associations for which aBlock evaluates to
	true."

	| newCollection |
	newCollection _ self species new.
	self associationsDo: 
		[:each | 
		(aBlock value: each value) ifTrue: [newCollection add: each]].
	^newCollection! !

!Dictionary methodsFor: 'enumerating' stamp: 'dtl 2/17/2003 09:48'!
valuesDo: aBlock 
	"Evaluate aBlock for each of the receiver's values."

	self associationsDo: [:association | aBlock value: association value]! !


!Dictionary methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:33'!
flattenOnStream:aStream
	^aStream writeDictionary:self.
! !

!Dictionary methodsFor: 'printing' stamp: 'apb 7/14/2004 12:48'!
printElementsOn: aStream 
	aStream nextPut: $(.
	self size > 100
		ifTrue: [aStream nextPutAll: 'size '.
			self size printOn: aStream]
		ifFalse: [self keysSortedSafely
				do: [:key | aStream print: key;
						 nextPutAll: '->';				
						 print: (self at: key);
						 space]].
	aStream nextPut: $)! !

!Dictionary methodsFor: 'printing'!
storeOn: aStream
	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet _ true.
	self associationsDo: 
			[:each | 
			noneYet
				ifTrue: [noneYet _ false]
				ifFalse: [aStream nextPut: $;].
			aStream nextPutAll: ' add: '.
			aStream store: each].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !


!Dictionary methodsFor: 'removing' stamp: 'di 4/4/2000 11:47'!
keysAndValuesRemove: keyValueBlock
	"Removes all entries for which keyValueBlock returns true."
	"When removing many items, you must not do it while iterating over the dictionary, since it may be changing.  This method takes care of tallying the removals in a first pass, and then performing all the deletions afterward.  Many places in the sytem could be simplified by using this method."

	| removals |
	removals _ OrderedCollection new.
	self associationsDo:
		[:assoc | (keyValueBlock value: assoc key value: assoc value)
			ifTrue: [removals add: assoc key]].
 	removals do:
		[:aKey | self removeKey: aKey]! !

!Dictionary methodsFor: 'removing'!
removeKey: key 
	"Remove key from the receiver.
	If key is not in the receiver, notify an error."

	^ self removeKey: key ifAbsent: [self errorKeyNotFound]! !

!Dictionary methodsFor: 'removing'!
removeKey: key ifAbsent: aBlock 
	"Remove key (and its associated value) from the receiver. If key is not in 
	the receiver, answer the result of evaluating aBlock. Otherwise, answer 
	the value externally named by key."

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	assoc == nil ifTrue: [ ^ aBlock value ].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ assoc value! !

!Dictionary methodsFor: 'removing'!
removeUnreferencedKeys   "Undeclared removeUnreferencedKeys"

	^ self unreferencedKeys do: [:key | self removeKey: key].! !

!Dictionary methodsFor: 'removing'!
remove: anObject

	self shouldNotImplement! !

!Dictionary methodsFor: 'removing'!
remove: anObject ifAbsent: exceptionBlock

	self shouldNotImplement! !

!Dictionary methodsFor: 'removing' stamp: 'dvf 8/23/2003 11:51'!
unreferencedKeys
	"TextConstants unreferencedKeys"

	| n |
	^'Scanning for references . . .' 
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: self size
		during: 
			[:bar | 
			n := 0.
			self keys select: 
					[:key | 
					bar value: (n := n + 1).
					(self systemNavigation allCallsOn: (self associationAt: key)) isEmpty]]! !


!Dictionary methodsFor: 'testing' stamp: 'tween 9/13/2004 10:11'!
hasBindingThatBeginsWith: aString
	"Answer true if the receiver has a key that begins with aString, false otherwise"
	
	self keysDo:[:each | 
		(each beginsWith: aString)
			ifTrue:[^true]].
	^false! !

!Dictionary methodsFor: 'testing' stamp: 'bf 8/20/1999 15:07'!
hasContentsInExplorer

	^self isEmpty not! !

!Dictionary methodsFor: 'testing' stamp: 'ab 9/17/2004 00:39'!
includesAssociation: anAssociation
  ^ (self   
      associationAt: anAssociation key
      ifAbsent: [ ^ false ]) value = anAssociation value
! !

!Dictionary methodsFor: 'testing' stamp: 'sw 2/14/2000 14:34'!
includesIdentity: anObject
	"Answer whether anObject is one of the values of the receiver.  Contrast #includes: in which there is only an equality check, here there is an identity check"

	self do: [:each | anObject == each ifTrue: [^ true]].
	^ false! !

!Dictionary methodsFor: 'testing' stamp: 'RAA 8/23/2001 12:56'!
includesKey: key 
	"Answer whether the receiver has a key equal to the argument, key."
	
	self at: key ifAbsent: [^false].
	^true! !

!Dictionary methodsFor: 'testing'!
includes: anObject

	self do: [:each | anObject = each ifTrue: [^true]].
	^false! !

!Dictionary methodsFor: 'testing' stamp: 'md 8/11/2005 16:49'!
isDictionary
	^true! !

!Dictionary methodsFor: 'testing' stamp: 'sw 3/23/2000 01:12'!
keyForIdentity: anObject
	"If anObject is one of the values of the receive, return its key, else return nil.  Contrast #keyAtValue: in which there is only an equality check, here there is an identity check"

	self associationsDo: [:assoc | assoc value == anObject ifTrue: [^ assoc key]].
	^ nil! !

!Dictionary methodsFor: 'testing'!
occurrencesOf: anObject 
	"Answer how many of the receiver's elements are equal to anObject."

	| count |
	count _ 0.
	self do: [:each | anObject = each ifTrue: [count _ count + 1]].
	^count! !


!Dictionary methodsFor: 'user interface' stamp: 'hg 10/3/2001 20:47'!
explorerContents

	| contents |
	
	contents _ OrderedCollection new.
	self keysSortedSafely do: [:key |
		contents add: (ObjectExplorerWrapper
			with: (self at: key)
			name: (key printString contractTo: 32)
			model: self)].
	^contents
! !


!Dictionary methodsFor: '*Compiler' stamp: 'ar 5/17/2003 14:07'!
bindingOf: varName
	^self associationAt: varName ifAbsent:[nil]! !

!Dictionary methodsFor: '*Compiler' stamp: 'ar 5/18/2003 20:33'!
bindingsDo: aBlock
	^self associationsDo: aBlock! !


!Dictionary methodsFor: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:32'!
inspectorClass
	"Answer the class of the inspector to be used on the receiver.  Called by inspect; 
	use basicInspect to get a normal (less useful) type of inspector."

	^ DictionaryInspector! !


!Dictionary methodsFor: 'private' stamp: 'raok 4/22/2002 12:09'!
copy
	"Must copy the associations, or later store will affect both the
original and the copy"

	^ self shallowCopy withArray:
		(array collect: [:assoc |
			assoc ifNil: [nil]
				ifNotNil: [Association key: assoc key
value: assoc value]])! !

!Dictionary methodsFor: 'private'!
errorKeyNotFound

	self error: 'key not found'! !

!Dictionary methodsFor: 'private'!
errorValueNotFound

	self error: 'value not found'! !

!Dictionary methodsFor: 'private'!
keyAt: index
	"May be overridden by subclasses so that fixCollisions will work"
	| assn |
	assn _ array at: index.
	assn == nil ifTrue: [^ nil]
				ifFalse: [^ assn key]! !

!Dictionary methodsFor: 'private'!
noCheckAdd: anObject
	"Must be defined separately for Dictionary because (self findElementOrNil:) expects a key, not an association.  9/7/96 tk"

	array at: (self findElementOrNil: anObject key) put: anObject.
	tally _ tally + 1! !

!Dictionary methodsFor: 'private'!
rehash
	"Smalltalk rehash."
	| newSelf |
	newSelf _ self species new: self size.
	self associationsDo: [:each | newSelf noCheckAdd: each].
	array _ newSelf array! !

!Dictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:42'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	finish _ array size.
	start _ (anObject hash \\ finish) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element key = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element key = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!Dictionary methodsFor: 'private'!
valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary 
	"Support for coordinating class variable and global declarations
	with variables that have been put in Undeclared so as to
	redirect all references to the undeclared variable."

	(aDictionary includesKey: aKey)
		ifTrue: 
			[self atNewIndex: index 
				put: ((aDictionary associationAt: aKey) value: anObject).
			aDictionary removeKey: aKey]
		ifFalse: 
			[self atNewIndex: index put: (Association key: aKey value: anObject)]! !

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

Dictionary class
	instanceVariableNames: ''!

!Dictionary class methodsFor: 'instance creation'!
newFrom: aDict 
	"Answer an instance of me containing the same associations as aDict.
	 Error if any key appears twice."
	| newDictionary |
	newDictionary _ self new: aDict size.
	aDict associationsDo:
		[:x |
		(newDictionary includesKey: x key)
			ifTrue: [self error: 'Duplicate key: ', x key printString]
			ifFalse: [newDictionary add: x]].
	^ newDictionary

"	NewDictionary newFrom: {1->#a. 2->#b. 3->#c}
	{1->#a. 2->#b. 3->#c} as: NewDictionary
	NewDictionary newFrom: {1->#a. 2->#b. 1->#c}
	{1->#a. 2->#b. 1->#c} as: NewDictionary
"! !
Inspector subclass: #DictionaryInspector
	instanceVariableNames: 'keyArray'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!DictionaryInspector methodsFor: 'accessing' stamp: 'apb 8/20/2004 23:06'!
fieldList
	^ self baseFieldList
		, (keyArray collect: [:key | key printString])! !


!DictionaryInspector methodsFor: 'initialize-release' stamp: 'PHK 7/21/2004 18:00'!
initialize
	super initialize.
	self calculateKeyArray! !


!DictionaryInspector methodsFor: 'menu' stamp: 'rbb 3/1/2005 10:51'!
addEntry
	| newKey aKey |

	newKey := UIManager default request:
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)
Examples:  #Fred    ''a string''   3+4'.
	aKey := Compiler evaluate: newKey.
	object at: aKey put: nil.
	self calculateKeyArray.
	selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey).
	self changed: #inspectObject.
	self changed: #selectionIndex.
	self changed: #fieldList.
	self update! !

!DictionaryInspector methodsFor: 'menu' stamp: 'apb 8/20/2004 21:19'!
copyName
	"Copy the name of the current variable, so the user can paste it into the 
	window below and work with is. If collection, do (xxx at: 1)."
	| sel |
	self selectionIndex <= self numberOfFixedFields
		ifTrue: [super copyName]
		ifFalse: [sel := String streamContents: [:strm | 
							strm nextPutAll: '(self at: '.
							(keyArray at: selectionIndex - self numberOfFixedFields)
								storeOn: strm.
							strm nextPutAll: ')'].
			Clipboard clipboardText: sel asText 			"no undo allowed"]! !

!DictionaryInspector methodsFor: 'menu' stamp: 'ar 10/31/2004 17:25'!
fieldListMenu: aMenu

	^ aMenu labels:
'inspect
copy name
references
objects pointing to this value
senders of this key
refresh view
add key
rename key
remove
basic inspect'
	lines: #(6 9)
	selections: #(inspectSelection copyName selectionReferences objectReferencesToSelection sendersOfSelectedKey refreshView addEntry renameEntry removeSelection inspectBasic)
! !

!DictionaryInspector methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'!
removeSelection
	selectionIndex = 0 ifTrue: [^ self changed: #flash].
	object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields).
	selectionIndex := 0.
	contents := ''.
	self calculateKeyArray.
	self changed: #inspectObject.
	self changed: #selectionIndex.
	self changed: #fieldList.
	self changed: #selection.! !

!DictionaryInspector methodsFor: 'menu' stamp: 'rbb 3/1/2005 10:51'!
renameEntry
	| newKey aKey value |

	value := object at: (keyArray at: selectionIndex - self numberOfFixedFields).
	newKey := UIManager default request: 
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)
Examples:  #Fred    ''a string''   3+4'
		 initialAnswer: (keyArray at: selectionIndex - self numberOfFixedFields) printString.
	aKey := Compiler evaluate: newKey.
	object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields).
	object at: aKey put: value.
	self calculateKeyArray.
	selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey).
	self changed: #selectionIndex.
	self changed: #inspectObject.
	self changed: #fieldList.
	self update! !

!DictionaryInspector methodsFor: 'menu' stamp: 'ar 10/31/2004 17:26'!
selectionReferences
	"Create a browser on all references to the association of the current selection."

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	object class == MethodDictionary ifTrue: [^ self changed: #flash].
	self systemNavigation browseAllCallsOn: (object associationAt: (keyArray at: selectionIndex  - self numberOfFixedFields)).
! !

!DictionaryInspector methodsFor: 'menu' stamp: 'ar 4/10/2005 22:17'!
sendersOfSelectedKey
	"Create a browser on all senders of the selected key"
	| aKey |
	self selectionIndex = 0
		ifTrue: [^ self changed: #flash].
	((aKey := keyArray at: selectionIndex  - self numberOfFixedFields) isSymbol)
		ifFalse: [^ self changed: #flash].
	SystemNavigation default browseAllCallsOn: aKey! !


!DictionaryInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'!
addEntry: aKey
	object at: aKey put: nil.
	self calculateKeyArray.
	selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey).
	self changed: #inspectObject.
	self changed: #selectionIndex.
	self changed: #fieldList.
	self update! !

!DictionaryInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'!
calculateKeyArray
	"Recalculate the KeyArray from the object being inspected"

	keyArray := object keysSortedSafely asArray.
	selectionIndex := 0.
! !

!DictionaryInspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:25'!
contentsIsString
	"Hacked so contents empty when deselected"

	^ (selectionIndex = 0)! !

!DictionaryInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'!
refreshView
	| i |
	i := selectionIndex.
	self calculateKeyArray.
	selectionIndex := i.
	self changed: #fieldList.
	self changed: #contents.! !

!DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:37'!
replaceSelectionValue: anObject 
	selectionIndex <= self numberOfFixedFields
		ifTrue: [^ super replaceSelectionValue: anObject].
	^ object
		at: (keyArray at: selectionIndex - self numberOfFixedFields)
		put: anObject! !

!DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 21:55'!
selection

	selectionIndex <= (self numberOfFixedFields) ifTrue: [^ super selection].
	^ object at: (keyArray at: selectionIndex - self numberOfFixedFields) ifAbsent:[nil]! !


!DictionaryInspector methodsFor: 'private' stamp: 'apb 8/20/2004 21:15'!
numberOfFixedFields
	^ 2 + object class instSize! !
TestCase subclass: #DictionaryTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Unordered'!

!DictionaryTest methodsFor: 'tests' stamp: 'zz 12/7/2005 19:59'!
testAdd
	
	| dict |
	dict := Dictionary new.
	dict add: #a -> 1.
	dict add: #b -> 2.
	self assert: (dict at: #a) = 1.
	self assert: (dict at: #b) = 2! !

!DictionaryTest methodsFor: 'tests' stamp: 'zz 12/7/2005 19:55'!
testAddAll
	
	| dict1 dict2 |
	dict1 := Dictionary new.
	dict1 at: #a put:1 ; at: #b put: 2. 
	dict2 := Dictionary new.
	dict2 at: #a put: 3 ; at: #c put: 4.
	dict1 addAll: dict2.
	self assert: (dict1 at: #a) = 3.
	self assert: (dict1 at: #b) = 2.
	self assert: (dict1 at: #c) = 4.! !

!DictionaryTest methodsFor: 'tests' stamp: 'zz 12/7/2005 19:57'!
testComma
	
	| dict1 dict2 dict3 |
	dict1 := Dictionary new.
	dict1 at: #a put:1 ; at: #b put: 2. 
	dict2 := Dictionary new.
	dict2 at: #a put: 3 ; at: #c put: 4.
	dict3 := dict1, dict2.
	self assert: (dict3 at: #a) = 3.
	self assert: (dict3 at: #b) = 2.
	self assert: (dict3 at: #c) = 4.! !

!DictionaryTest methodsFor: 'tests' stamp: 'stephaneducasse 9/18/2005 10:45'!
testPseudo
	"(self run: #testPseudo)"
	"true and false are valid keys"
	
	| dict1  |
	dict1 := Dictionary new.
	self shouldnt: [dict1 at: true put: #true] raise: Error.
	self assert: (dict1 at: true) = #true.
		
	self shouldnt: [dict1 at: false put: #false] raise: Error.
	self assert: (dict1 at: false) = #false.! !


!DictionaryTest methodsFor: 'association tests' stamp: 'NDCC 3/8/2006 08:14'!
testAddAssociation
	"self run:#testAddAssociation"
	"self debug:#testAddAssociation"
	
	| dict |
	dict := Dictionary new.
	dict at: #a put: 1.
	dict at: #b put: 2.
	self assert: (dict at: #a) = 1.
	self assert: (dict at: #b) = 2.
	
	dict at: #a put: 10.
	dict at: #c put: 2.
	
	self assert: (dict at: #a) = 10.
	self assert: (dict at: #b) = 2.
	self assert: (dict at: #c) = 2
	
	! !

!DictionaryTest methodsFor: 'association tests' stamp: 'ndCollectionsTests-Unordered 3/16/2006 10:30'!
testAssociationsSelect
	| answer d |
	d := Dictionary new.
	d at: (Array with: #hello with: #world)
	  put: #fooBar.
	d at: Smalltalk put: #'Smalltalk is the key'.
	d at: #Smalltalk put: Smalltalk.
	answer := d
				associationsSelect: [:assoc | assoc key == #Smalltalk
						and: [assoc value == Smalltalk]].
	self
		should: [answer isKindOf: Dictionary].
	self
		should: [answer size == 1].
	self
		should: [(answer at: #Smalltalk)
				== Smalltalk].
	answer := d
				associationsSelect: [:assoc | assoc key == #NoSuchKey
						and: [assoc value == #NoSuchValue]].
	self
		should: [answer isKindOf: Dictionary].
	self
		should: [answer size == 0]! !

!DictionaryTest methodsFor: 'association tests' stamp: 'NDCC 3/8/2006 09:20'!
testIncludesAssociation
	"self run:#testIncludesAssociation"
	
	| dict |
	dict := Dictionary new.
	dict at: #a put: 1.
	dict at: #b put: 2.
	self assert: (dict includesAssociation: (#a -> 1)).
	self assert: (dict includesAssociation: (#b -> 2)).
	
	! !

!DictionaryTest methodsFor: 'association tests' stamp: 'ndCollectionsTests-Unordered 3/16/2006 10:25'!
testIncludesAssociationNoValue
	"self run:#testIncludesAssociationNoValue"
	"self debug:#testIncludesAssociationNoValue"
	
	| dict a1 a3 |
	a1 := Association key: #Italie.
	a3 := Association key: #France value: 'Paris'.
	
	self assert: (a1 key = #Italie).
	self assert: (a1 value isNil).
	
	dict := Dictionary new.
	dict add: a1.
	dict add: a3.
	self assert: (dict includesKey: #France).
	self assert: (dict includesKey: #Italie).
	self assert: (dict at: #Italie) isNil.
	self assert: (dict at: #France) = 'Paris'

	
	
	! !


!DictionaryTest methodsFor: 'basic tests' stamp: 'ndCollectionsTests-Unordered 3/16/2006 10:26'!
testAtError
	"self run: #testAtError"
	
	| dict |
	dict := Dictionary new.
	dict at: #a put: 666.
	self shouldnt: [ dict at: #a ] raise: Error.
	self should: [ dict at: #b ] raise: Error.
	
	! !

!DictionaryTest methodsFor: 'basic tests' stamp: 'NDCC 3/1/2006 14:27'!
testAtIfAbsent
	"self run: #testAtIfAbsent"
	
	| dict |
	dict := Dictionary new.
	dict at: #a put: 666.
	
	self assert: (dict at: #a ifAbsent: [nil]) = 666.
	
	self assert: (dict at: #b ifAbsent: [nil]) isNil.

	! !

!DictionaryTest methodsFor: 'basic tests' stamp: 'NDCC 3/8/2006 09:28'!
testAtPut
	"self run: #testAtPut"
	"self debug: #testAtPut"
	
	| adictionary |
	adictionary := Dictionary new.
	adictionary at: #a put: 3.
	self assert: (adictionary at: #a) = 3.
	adictionary at: #a put: 3.
	adictionary at: #a put: 4.
	self assert: (adictionary at: #a) = 4.
	adictionary at: nil put: 666.
	self assert: (adictionary at: nil) = 666! !

!DictionaryTest methodsFor: 'basic tests' stamp: 'NDCC 3/8/2006 09:53'!
testAtPutNil
	"self run: #testAtPut"
	"self debug: #testAtPut"
	
	| dict |
	dict := Dictionary new.
	dict at: nil put: 1.
	self assert: (dict at: nil) = 1.
	dict at: #a put: nil.
	self assert: (dict at: #a) = nil.
	dict at: nil put: nil.
	self assert: (dict at: nil) = nil.
	
	
	! !

!DictionaryTest methodsFor: 'basic tests' stamp: 'ndCollectionsTests-Unordered 3/16/2006 10:24'!
testIncludesKey
	"self run:#testIncludesKey"
	"self debug:#testIncludesKey"
	
	| dict a1 a2 a3 |
	a1 := Association key: 'Italie'.
	a2 := Association new.
	a3 := Association key: 'France' value: 'Paris'.
	
	dict := Dictionary new.
	dict add: a1 .
	dict add: a2.
	dict add: a3.
	self assert: (dict includesKey: #France).
	self assert: (dict includesKey: 'France').
	self assert: (dict includesKey: #Italie).
	self assert: (dict includesKey: nil).	
		
	self assert: (dict at: 'France' ) = 'Paris'.
! !

!DictionaryTest methodsFor: 'basic tests' stamp: 'NDCC 3/8/2006 09:41'!
testOccurrencesOf
	"self run:#testOccurrencesOf"
	
	| dict |
	dict := Dictionary new.
	dict at: #a put: 1.
	dict at: #b put: 2.
	dict at: #c put: 1.
	dict at: #d put: 3.
	dict at: nil put: nil.
	dict at: #z put: nil.
	
	
	self assert: (dict occurrencesOf: 1 ) = 2.
	self assert: (dict occurrencesOf: nil ) = 2.
	
	
	
	! !


!DictionaryTest methodsFor: 'implementation tests' stamp: 'stephaneducasse 9/18/2005 10:48'!
testAtNil
	"(self run: #testAtNil)"
	"nil is a valid key in squeak. In VW nil is not a valid key"
	"Ansi 1.9 p, 168
    		5.7.2.5 Message: at: key put: newElement
    		Synopsis
    			Store newElement at key in the receiver. Answer newElement.
    		Definition: <abstractDictionary>
    		If lookup succeeds for key, then newElement replaces the element previously stored at key.
    		Otherwise, the newElement is stored at the new key. In either case, subsequent successful
    		lookups for key will answer newElement.  Answer newElement.

    		The result is undefined if the key is nil.

		This clearly indicates that different smalltalks where doing different assumptions."
	
	
	
	| dict1  |
	dict1 := Dictionary new.
	self shouldnt: [ dict1 at: nil put: #none] raise: Error.
	self assert: (dict1 at: nil) = #none. 
	! !

!DictionaryTest methodsFor: 'implementation tests' stamp: 'ndCollectionsTests-Unordered 3/16/2006 10:29'!
testPseudoVariablesAreValidKeys
	"(self run: #testPseudoVariablesAreValidKeys)"
	"true and false are valid keys"
	
	| dict1  |
	dict1 := Dictionary new.
	self shouldnt: [dict1 at: true put: #true] raise: Error.
	self assert: (dict1 at: true) = #true.
		
	self shouldnt: [dict1 at: false put: #false] raise: Error.
	self assert: (dict1 at: false) = #false.! !


!DictionaryTest methodsFor: 'keys and value tests' stamp: 'NDCC 3/8/2006 08:16'!
testDictionaryConcatenation
	"self run: #testDictionaryConcatenation"
	
	
	| dict1 dict2 dict3 |
	dict1 := Dictionary new.
	dict1 at: #a put: 'Nicolas' ; at: #b put: 'Damien'. 
	
	dict2 := Dictionary new.
	dict2 at: #a put: 'Christophe' ; at: #c put: 'Anthony'.
	dict3 := dict1, dict2.
	
	self assert: (dict3 at: #a) = 'Christophe'.
	self assert: (dict3 at: #b) = 'Damien'.
	self assert: (dict3 at: #c) = 'Anthony'.
	

	! !

!DictionaryTest methodsFor: 'keys and value tests' stamp: 'ndCollectionsTests-Unordered 3/16/2006 10:24'!
testKeyAtValue
	"self run: #testKeyAtValue"
	"self debug: #testKeyAtValue"
	
	| dict |
	dict := Dictionary new.
	dict at: #a put: 1.
	dict at: #b put: 2.
	dict at: #c put: 1.
	
	self assert: (dict keyAtValue: 2) = #b.
	self assert: (dict keyAtValue: 1) = #c.
	"ugly may be a bug, why not having a set #a and #c"
	
	self should: [dict keyAtValue: 0] raise: Error
	
	
! !

!DictionaryTest methodsFor: 'keys and value tests' stamp: 'ndCollectionsTests-Unordered 3/16/2006 10:23'!
testKeys

	"self run:#testKeys "
	
	| a1 a2  dict | 
	a1 := Association key: 'France' value: 'Paris'.
	a2 := Association key: 'Italie' value: 'Rome'.
	dict := Dictionary new.
	dict add: a1.
	dict add: a2.
	 		
	self assert: (dict keys size) = 2.
	
	self assert: (dict keys includes: #France)
	
	


	
	! !

!DictionaryTest methodsFor: 'keys and value tests' stamp: 'NDCC 3/8/2006 09:13'!
testKeysDo
	"self run: #testKeysDo"
	"self debug: #testKeysDo"
	
	| dict res |
	dict := Dictionary new.
	
	dict at: #a put: 33.
	dict at: #b put: 66.
	
	res := OrderedCollection new.
	dict keysDo: [ :each | res add: each].
	
	self assert: res asSet = #(a b) asSet.


	
	! !

!DictionaryTest methodsFor: 'keys and value tests' stamp: 'NDCC 3/8/2006 08:56'!
testRemoveKey
		"self run:#testRemoveKey "

	| dict | 
	dict := Dictionary new.
	dict at: #a put: 1.
	dict at: #b put: 2.
	 
	self assert: (dict keys size) = 2.
	dict removeKey: #a.
	self assert: dict keys size  = 1.

	self should: [dict at: #a] raise: Error.
	self assert: (dict at: #b) = 2


	
	! !

!DictionaryTest methodsFor: 'keys and value tests' stamp: 'ndCollectionsTests-Unordered 3/16/2006 10:23'!
testValues
	"self run:#testValues "
	
	| a1 a2 a3 dict | 
	a1 := Association key: 'France' value: 'Paris'.
	a2 := Association key: 'Italie' value: 'Rome'.
	dict := Dictionary new.
	dict add: a1.
	dict add: a2.
	 
	self assert: (dict values size ) = 2.
	self assert: (dict values includes: 'Paris').
	
	a3 := Association new.
	dict add: a3.
	self assert: (dict values size ) = 3.
	self assert: (dict values includes: nil).
	
	
	
	
	
	


	
	! !

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

DictionaryTest class
	instanceVariableNames: 'testToto pt1'!
StarSqueakTurtle subclass: #DiffusionTurtle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!DiffusionTurtle methodsFor: 'demons' stamp: 'jm 3/3/2001 13:04'!
bounce

	(self turtleCountHere > 1) ifTrue: [
		self turnRight: 180 + (self random: 45).
		self turnLeft: (self random: 45)].
! !

!DiffusionTurtle methodsFor: 'demons' stamp: 'jm 2/5/2001 19:32'!
move

	self forward: 1.
! !
Object subclass: #DigitalSignatureAlgorithm
	instanceVariableNames: 'randKey randSeed'
	classVariableNames: 'HighBitOfByte SmallPrimes'
	poolDictionaries: ''
	category: 'System-Digital Signatures'!
!DigitalSignatureAlgorithm commentStamp: '<historical>' prior: 0!
This class implements the Digital Signature Algorithm (DSA) of the U.S. government's "Digital Signature Standard" (DSS). The DSA algorithm was proposed in 1991 and became a standard in May 1994. The official description is available as a Federal Information Processing Standards Publication (FIPS PUB 186, May 19, 1994). A companion standard, the Secure Hash Standard, or SHS (FIPS PUB 180-1, April 17, 1995), describes a 160-bit message digest algorithm known as the Secure Hash Algorithm (SHA). This message digest is used to compute the document signature.

Here's how to use it:

  1. The "signer" creates a pair of keys. One of these must be kept private. The other may be freely distributed. For example, it could be built into the signature checking code of an application.

  2. When the signer wishes to sign a packet of data (a "message") , he uses the secure hash algorithm to create a 160-bit message digest (hash) which is used as the input to DSA. The result of this is a pair of large numbers called a "signature" that is attached to the original message.

  3. When someone receives a signed message purported to have come from the signer, they compute the 160-bit hash of the message and pass that, along with the message signature and the signer's public key, to the signature verification algorithm. If the signature checks, then it is virtually guaranteed that the message originated from someone who had the signer's private key. That is, the message is not a forgery and has not been modified since it was signed. For example, if the message contains a program, and the recipient trusts the signer, then the recipient can run the program with the assurance that it won't do anything harmful. (At least, not intentionally. A digital signature is no guarantee against bugs!! :->)

The signer must keep the private key secure, since anyone who has the private key can forge the signer's signature on any message they like. As long as the secret key is not stolen, cryptographers believe it to be virtually impossible either to forge a signature, to find a message that matches an existing sigature, or to discover the signer's private key by analyzing message signatures. Knowing the public key (which, for example, could be recovered from an application that had it built in), does not weaken the security at all.

An excellent reference work on digital signatures and cryptography in general is:

  Schneier, Bruce
  "Applied Cryptography: Protocols, Algorithms, and Source Code in C"
  John Wiley and Sons, 1996.

I used this book as a guide to implementing many of the numerical algorithms required by DSA.

Patents and Export Restrictions:

Many digital signature technologies are patented. DSA is also patented, but the patent is owned by the U.S. government which has made DSA available royalty-free. There is a claim that the government patent infringes on an earlier patent by Schnorr, but the government is requiring the use of DSA, so they apparently believe this claim is not strong enough to be a serious threat to their own patent.

Most cryptography technology, including digital signature technology, requires an export license for it to be distributed outside the U.S. Recent legislation may have relaxed the export license requirements, but it would be prudent to check the current regulations before exporting this code.!


!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'jm 1/11/2000 00:25'!
initRandom: randomInteger
	"Initialize the the secure random number generator with the given value. The argument should be a positive integer of up to 512 bits chosen randomly to avoid someone being able to predict the sequence of random values generated."
	"Note: The random generator must be initialized before generating a key set or signature. Signature verification does not require initialization of the random generator."

	randSeed _ 16rEFCDAB8998BADCFE10325476C3D2E1F067452301.  "initial seed"
	randKey _ randomInteger.
	Transcript show: 'Random seed: ', randomInteger printString; cr.
! !

!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'ar 2/1/2001 20:18'!
initRandomFromString: aString
	"Ask the user to type a long random string and use the result to seed the secure random number generator."

	| s k srcIndex |
	s _ aString.
	k _ LargePositiveInteger new: (s size min: 64).
	srcIndex _ 0.
	k digitLength to: 1 by: -1 do: [:i |
		k digitAt: i put: (s at: (srcIndex _ srcIndex + 1)) asciiValue].
	k _ k + (Random new next * 16r7FFFFFFF) asInteger.  "a few additional bits randomness"
	k highBit > 512 ifTrue: [k _ k bitShift: k highBit - 512].
	self initRandom: k.
! !

!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'rbb 3/1/2005 10:51'!
initRandomFromUser
	"Ask the user to type a long random string and use the result to seed the secure random number generator."

	| s k srcIndex |
	s := UIManager default request: 'Enter a long random string to seed the random generator.'.
	k := LargePositiveInteger new: (s size min: 64).
	srcIndex := 0.
	k digitLength to: 1 by: -1 do: [:i |
		k digitAt: i put: (s at: (srcIndex := srcIndex + 1)) asciiValue].
	k := k + (Random new next * 16r7FFFFFFF) asInteger.  "a few additional bits randomness"
	k highBit > 512 ifTrue: [k := k bitShift: k highBit - 512].
	self initRandom: k.
! !

!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'gk 2/26/2004 09:52'!
initRandomNonInteractively
	[self initRandom: (SoundService default randomBitsFromSoundInput: 512)]
		ifError: [self initRandomFromString: 
			Time millisecondClockValue printString, 
			Date today printString, 
			SmalltalkImage current platformName printString].! !


!DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: 'jm 12/9/1999 21:49'!
inverseOf: x mod: n
	"Answer the inverse of x modulus n. That is, the integer y such that (x * y) \\ n is 1. Both x and n must be positive, and it is assumed that x < n and that x and n are integers."
	"Details: Use the extended Euclidean algorithm, Schneier, p. 247."

	| v u k u1 u2 u3 t1 t2 t3 tmp |
	((x <= 0) or: [n <= 0]) ifTrue: [self error: 'x and n must be greater than zero'].
	x >= n ifTrue: [self error: 'x must be < n'].

	v _ x.
	u _ n.
	k _ 0.
	[x even and: [n even and: [u > 0]]] whileTrue: [  "eliminate common factors of two"
		k _ k + 1.
		u _ u bitShift: -1.
		v _ v bitShift: -1].

	u1 _ 1. u2 _ 0. u3 _ u.
	t1 _ v. t2 _ u - 1. t3 _ v.
	[	[u3 even ifTrue: [
			((u1 odd) or: [u2 odd]) ifTrue: [
				u1 _ u1 + v.
				u2 _ u2 + u].
			u1 _ u1 bitShift: -1.
			u2 _ u2 bitShift: -1.
			u3 _ u3 bitShift: -1].
		((t3 even) or: [u3 < t3]) ifTrue: [
			tmp _ u1. u1 _ t1. t1 _ tmp.
			tmp _ u2. u2 _ t2. t2 _ tmp.
			tmp _ u3. u3 _ t3. t3 _ tmp].
		u3 even and: [u3 > 0]] whileTrue: ["loop while u3 is even"].

		[((u1 < t1) or: [u2 < t2]) and: [u1 > 0]] whileTrue: [
			u1 _ u1 + v.
			u2 _ u2 + u].
	
		u1 _ u1 - t1.
		u2 _ u2 - t2.
		u3 _ u3 - t3.
		t3 > 0] whileTrue: ["loop while t3 > 0"].

	[u1 >= v and: [u2 >= u]] whileTrue: [
		u1 _ u1 - v.
		u2 _ u2 - u].

	u1 _ u1 bitShift: k.
	u2 _ u2 bitShift: k.
	u3 _ u3 bitShift: k.

	u3 = 1 ifFalse: [self error: 'no inverse'].
	^ u - u2
! !

!DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: 'hh 8/3/2000 18:18'!
isProbablyPrime: p
	"Answer true if p is prime with very high probability. Such a number is sometimes called an 'industrial grade prime'--a large number that is so extremely likely to be prime that it can assumed that it actually is prime for all practical purposes. This implementation uses the Rabin-Miller algorithm (Schneier, p. 159)."

	| iterations factor pMinusOne b m r a j z couldBePrime |
	iterations _ 50.  "Note: The DSA spec requires >50 iterations; Schneier says 5 are enough (p. 260)"

	"quick elimination: check for p divisible by a small prime"
	SmallPrimes ifNil: [  "generate list of small primes > 2"
		SmallPrimes _ Integer primesUpTo: 2000.
		SmallPrimes _ SmallPrimes copyFrom: 2 to: SmallPrimes size].
	factor _ SmallPrimes detect: [:f | (p \\ f) = 0] ifNone: [nil].
	factor ifNotNil: [^ p = factor].

	pMinusOne _ p - 1.
	b _ self logOfLargestPowerOfTwoDividing: pMinusOne.
	m _ pMinusOne // (2 raisedTo: b).
	"Assert: pMinusOne = m * (2 raisedTo: b) and m is odd"

	Transcript show: '      Prime test pass '.
	r _ Random new.
	1 to: iterations do: [:i |
		Transcript show: i printString; space.
		a _ (r next * 16rFFFFFF) truncated.
		j _ 0.
		z _ (a raisedTo: m modulo: p) normalize.
		couldBePrime _ z = 1.
		[couldBePrime] whileFalse: [
			z = 1 ifTrue: [Transcript show: 'failed!!'; cr. ^ false].  "not prime"
			z = pMinusOne
				ifTrue: [couldBePrime _ true]
				ifFalse: [
					(j _ j + 1) < b
						ifTrue: [z _ (z * z) \\ p]
						ifFalse: [Transcript show: 'failed!!'; cr. ^ false]]]].  "not prime"

	Transcript show: 'passed!!'; cr.
	^ true  "passed all tests; probably prime"
! !


!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'hh 8/3/2000 18:17'!
computeSignatureForMessageHash: hash privateKey: privateKey
	"Answer the digital signature of the given message hash using the given private key. A signature is a pair of large integers. The private key is an array of four large integers: (p, q, g, x)."

	| p q g x r s k tmp |
	p _ privateKey first.
	q _ privateKey second.
	g _ privateKey third.
	x _ privateKey fourth.

	r _ s _ 0.
	[r = 0 or: [s = 0]] whileTrue: [
		k _ self nextRandom160 \\ q.
		r _ (g raisedTo: k modulo: p) \\ q.
		tmp _ (hash + (x * r)) \\ q.
		s _ ((self inverseOf: k mod: q) * tmp) \\ q].

	^ Array with: r with: s
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'hh 8/3/2000 18:19'!
generateKeySet
	"Generate and answer a key set for DSA. The result is a pair (<private key><public key>). Each key is an array of four large integers. The private key is (p, q, g, x); the public one is (p, q, g, y). The signer must be sure to record (p, q, g, x), and must keep x secret to prevent someone from forging their signature."
	"Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!"

	| qAndPandS q p exp g h x y |
	qAndPandS _ self generateQandP.
	Transcript show: 'Computing g...'.
	q _ qAndPandS first.
	p _ qAndPandS second.
	exp _ (p - 1) / q.
	h _ 2.
	[g _ h raisedTo: exp modulo: p. g = 1] whileTrue: [h _ h + 1].
	Transcript show: 'done.'; cr.
	Transcript show: 'Computing x and y...'.
	x _ self nextRandom160.
	y _ g raisedTo: x modulo: p.
	Transcript show: 'done.'; cr.
	Transcript show: 'Key generation complete!!'; cr.
	^ Array
		with: (Array with: p with: q with: g with: x)
		with: (Array with: p with: q with: g with: y)
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'md 7/30/2005 14:12'!
signatureToString: aSignature
	"Answer a string representation of the given signature. This string can be parsed using the stringToSignature: method."

	| s |
	s _ WriteStream on: (String new: 2000).
	s nextPutAll: '[DSA digital signature '.
	s nextPutAll: aSignature first printStringHex.
	s space.
	s nextPutAll: aSignature second printStringHex.
	s nextPutAll: ']'.
	^ s contents
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 13:33'!
stringToSignature: aString
	"Answer the signature stored in the given string. A signature string has the format:

		 '[DSA digital signature <r> <s>]'

	where <r> and <s> are large positive integers represented by strings of hexidecimal digits."

	| prefix stream r s |
	prefix _ '[DSA digital signature '.
	(aString beginsWith: prefix) ifFalse: [self error: 'bad signature prefix'].
	stream _ ReadStream on: aString.
	stream position: prefix size.
	r _ Integer readFrom: stream base: 16.
	stream next.
	s _ Integer readFrom: stream base: 16.
	^ Array with: r with: s
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'hh 8/3/2000 18:18'!
verifySignature: aSignature ofMessageHash: hash publicKey: publicKey
	"Answer true if the given signature is the authentic signature of the given message hash. That is, if the signature must have been computed using the private key set corresponding to the given public key. The public key is an array of four large integers: (p, q, g, y)."

	| p q g y r s w u1 u2 v0 v |
	p _ publicKey first.
	q _ publicKey second.
	g _ publicKey third.
	y _ publicKey fourth.
	r _ aSignature first.
	s _ aSignature last.
	((r > 0) and: [r < q]) ifFalse: [^ false].  "reject"
	((s > 0) and: [s < q]) ifFalse: [^ false].  "reject"

	w _ self inverseOf: s mod: q.
	u1 _ (hash * w) \\ q.
	u2 _ (r * w) \\ q.
	v0 _ (g raisedTo: u1 modulo: p) * (y raisedTo: u2 modulo: p).
	v _ ( v0 \\ p) \\ q.
	^ v = r
! !


!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'raa 5/30/2000 15:47'!
generateQandP
	"Generate the two industrial-grade primes, q (160-bits) and p (512-bit) needed to build a key set. Answer the array (q, p, s), where s is the seed that from which q and p were created. This seed is normally discarded, but can be used to verify the key generation process if desired."

	| pBits halfTwoToTheP chunkCount sAndq q twoQ n c w x p s |
	pBits _ 512.  "desired size of p in bits"
	halfTwoToTheP _ 2 raisedTo: (pBits - 1).
	chunkCount _ pBits // 160.

	Transcript show: 'Searching for primes q and p...'; cr.
	[true] whileTrue: [
		sAndq _ self generateSandQ.
		Transcript show: '  Found a candidate q.'; cr.
		s _ sAndq first.
		q _ sAndq last.
		twoQ _ q bitShift: 1.
		n _ 2.
		c _ 0.
		[c < 4096] whileTrue: [
			w _ self generateRandomLength: pBits s: s n: n.
			x _ w + halfTwoToTheP.
			p _ (x - ( x \\ twoQ)) + 1.
			p highBit = pBits ifTrue: [
				Transcript show: '    Testing potential p ', (c + 1) printString, '...'; cr.
				(self isProbablyPrime: p) ifTrue: [
					Transcript show: '  Found p!!'; cr.
					^ Array with: q with: p with: s]].
			n _ n + chunkCount + 1.
			c _ c + 1]].
! !

!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 16:36'!
generateRandomLength: bitLength s: s n: n
	"Answer a random number of bitLength bits generated using the secure hash algorithm."

	| sha out count extraBits v |
	sha _ SecureHashAlgorithm new.
	out _ 0.
	count _ (bitLength // 160).
	extraBits _ bitLength - (count * 160).
	0 to: count do: [:k |
		v _ sha hashInteger: (s + n + k).
		k = count ifTrue: [
			v _ v - ((v >> extraBits) << extraBits)].
		out _ out bitOr: (v bitShift: (160 * k))].
	^ out
! !

!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'raa 5/30/2000 15:46'!
generateSandQ
	"Generate a 160-bit random seed s and an industrial grade prime q."

	| hasher s sPlusOne u q |
	hasher _ SecureHashAlgorithm new.
	[true] whileTrue: [
		s _ self nextRandom160.
		sPlusOne _ s + 1.
		sPlusOne highBit > 160 ifTrue: [sPlusOne _ sPlusOne \\ (2 raisedTo: 160)].
		u _ (hasher hashInteger: s) bitXor: (hasher hashInteger: sPlusOne).
		q _ u bitOr: ((1 bitShift: 159) bitOr: 1).
		(self isProbablyPrime: q) ifTrue: [^ Array with: s with: q]].
! !

!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 11:12'!
logOfLargestPowerOfTwoDividing: aPositiveInteger
	"Answer the base-2 log of the largest power of two that divides the given integer. For example, the largest power of two that divides 24 is 8, whose log base-2 is 3. Do this efficiently even when the given number is a large integer. Assume that the given integer is > 0."
	"DigitalSignatureAlgorithm new largestPowerOfTwoDividing: (32 * 3)"

	| digitIndex power d |
	digitIndex _ (1 to: aPositiveInteger digitLength) detect: [:i | (aPositiveInteger digitAt: i) ~= 0].
	power _ (digitIndex - 1) * 8.
	d _ aPositiveInteger digitAt: digitIndex.
	[d odd] whileFalse: [
		power _ power + 1.
		d _ d bitShift: -1].
	^ power
! !

!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 14:39'!
nextRandom160
	"Answer a newly generated 160-bit random number in the range [1..(2^160 - 1)]."
	"Details: Try again in the extremely unlikely chance that zero is encountered."

	| result |
	result _ 0.
	[result = 0] whileTrue: [
		result _ SecureHashAlgorithm new hashInteger: randKey seed: randSeed.
		randKey _ randKey + result + 1].
	^ result
! !

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

DigitalSignatureAlgorithm class
	instanceVariableNames: ''!

!DigitalSignatureAlgorithm class methodsFor: 'class initialization' stamp: 'jm 12/21/1999 19:15'!
initialize
	"DigitalSignatureAlgorithm initialize"

	"SmallPrimes is a list of small primes greater than two."
	SmallPrimes _ Integer primesUpTo: 2000.
	SmallPrimes _ SmallPrimes copyFrom: 2 to: SmallPrimes size.

	"HighBitOfByte maps a byte to the index of its top non-zero bit."
	HighBitOfByte _ (0 to: 255) collect: [:byte | byte highBit].
! !


!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'jm 12/22/1999 11:23'!
example
	"Example of signing a message and verifying its signature."
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm example"

	| msg keys sig |
	msg _ 'This is a test...'.
	keys _ self testKeySet.
	sig _ self sign: msg privateKey: keys first.
	self inform: 'Signature created'.
	(self verify: sig isSignatureOf: msg publicKey: keys last)
		ifTrue: [self inform: 'Signature verified.']
		ifFalse: [self error: 'ERROR!! Signature verification failed'].
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'mdr 8/31/2000 18:43'!
testExamplesFromDisk
	"verify messages from file on disk"
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm testExamplesFromDisk"

	| msg  sig file publicKey |

	file _ FileStream readOnlyFileNamed: 'dsa.test.out'.
	[
		[file atEnd] whileFalse: [
			sig _ file nextChunk.
			msg _ file nextChunk.
			publicKey _ Compiler evaluate: file nextChunk.
			(self verify: sig isSignatureOf: msg publicKey: publicKey) ifTrue: [
				Transcript show: 'SUCCESS: ',msg; cr.
			] ifFalse: [
				self error: 'ERROR!! Signature verification failed'
			].
		].
	] ensure: [file close]
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'jm 12/22/1999 11:28'!
testKeySet
	"Answer a pair of keys for testing. The first key is the private key, the second one is the public key."
	"WARNING: This test key set is public should be used only for testing!! In a real application, the user would create a set of keys using generateKeySet and would keep the private key secret."

	^ #(
		(8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 957348690772296812)
		(8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 4645213122572190617807944614677917601101008235397095646475699959851618402406173485853587185431290863173614335452934961425661774118334228449202337038283799))
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'RAA 5/31/2000 08:46'!
timeDecode: count
	"Example of signing a message and verifying its signature."
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm timeDecode: 20"

	| msg keys sig s dsa |

	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandomFromUser.

	#(1 10 100 1000 10000 100000) do: [ :extraLen |
		s _ String new: extraLen.
		1 to: s size do: [ :i | s at: i put: (Character value: 200 atRandom)].
		msg _ 'This is a test...',s.
		keys _ self testKeySet.
		sig _ self sign: msg privateKey: keys first dsa: dsa.
		"self inform: 'Signature created'."
		self timeDirect: [
			count timesRepeat: [
				(self verify: sig isSignatureOf: msg publicKey: keys last)
					ifFalse: [self error: 'ERROR!! Signature verification failed'].
			].
		] as: 'verify msgLen = ',msg size printString count: count
	].
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'RAA 5/31/2000 13:13'!
writeExamplesToDisk
	"Example of signing a message and verifying its signature. Used to create samples from one implementation that could later be tested with a different implementation"
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm writeExamplesToDisk"

	| sig file keyList dsa msgList |

	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandomFromUser.
	self inform: 'About to generate 5 key sets. Will take a while'.
	keyList _ {self testKeySet},((1 to: 5) collect: [ :ignore | self generateKeySet]).
	msgList _ {'This is a test...'. 'This is the second test period.'. 'And finally, a third message'}.
	file _ FileStream newFileNamed: 'dsa.test.out'.
	[
		msgList do: [ :msg |
			keyList do: [ :keys |
				sig _ self sign: msg privateKey: keys first dsa: dsa.
				(self verify: sig isSignatureOf: msg publicKey: keys last) ifTrue: [
					file
						nextChunkPut: sig;
						nextChunkPut: msg;
						nextChunkPut: keys last storeString.
				] ifFalse: [
					self error: 'ERROR!! Signature verification failed'
				].
			].
		].
	] ensure: [file close]
! !


!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'ads 7/31/2003 14:01'!
generateKeySet
	"Generate and answer a key set for code signing. The result is a pair (<private key><public key>). Each key is an array of four large integers. The signer must be sure to record this keys set and must keep the private key secret to prevent someone from forging their signature."
	"Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!"
	"Note: Unguessable random numbers are needed for key generation. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before generating a key set. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams."
	"DigitalSignatureAlgorithm generateKeySet"

	| dsa |
	dsa _ DigitalSignatureAlgorithm new.
	(self confirm: 'Shall I seed the random generator from the current sound input?')
		ifTrue: [dsa initRandomNonInteractively]
		ifFalse: [dsa initRandomFromUser].
	^ dsa generateKeySet
! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'jm 12/22/1999 11:18'!
sign: aStringOrStream privateKey: privateKey
	"Sign the given message (a stream or string) and answer a signature string."
	"Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams."

	| dsa hasher h sig |
	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandomFromUser.
	hasher _ SecureHashAlgorithm new.
	(aStringOrStream class isBytes)
		ifTrue: [h _ hasher hashMessage: aStringOrStream]
		ifFalse: [h _ hasher hashStream: aStringOrStream].
	sig _ dsa computeSignatureForMessageHash: h privateKey: privateKey.
	^ dsa signatureToString: sig
! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'RAA 5/31/2000 08:46'!
sign: aStringOrStream privateKey: privateKey dsa: dsa
	"Sign the given message (a stream or string) and answer a signature string."
	"Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams."

	| hasher h sig |

	hasher _ SecureHashAlgorithm new.
	(aStringOrStream class isBytes)
		ifTrue: [h _ hasher hashMessage: aStringOrStream]
		ifFalse: [h _ hasher hashStream: aStringOrStream].
	sig _ dsa computeSignatureForMessageHash: h privateKey: privateKey.
	^ dsa signatureToString: sig
! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'jm 12/22/1999 11:20'!
verify: signatureString isSignatureOf: aStringOrStream publicKey: publicKey
	"Answer true if the given signature string signs the given message (a stream or string)."
	"Note: Random numbers are not needed for signature verification; thus, there is no need to call initRandomFromUser before verifying a signature."

	| dsa hasher h sig |
	dsa _ DigitalSignatureAlgorithm new.
	hasher _ SecureHashAlgorithm new.
	(aStringOrStream class isBytes)
		ifTrue: [h _ hasher hashMessage: aStringOrStream]
		ifFalse: [h _ hasher hashStream: aStringOrStream].
	sig _ dsa stringToSignature: signatureString.
	^ dsa verifySignature: sig ofMessageHash: h publicKey: publicKey
! !


!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:35'!
runTiming
"
DigitalSignatureAlgorithm runTiming
"
	| results ops modeNames |

	modeNames _ #('standard dsa' 'standard integer' 'digitDiv:neg:').
	results _ OrderedCollection new.
	1 to: 3 do: [ :mode |
		results add: (DigitalSignatureAlgorithm timeMultiply: 100000 mode: mode),{mode}.
		results add: (DigitalSignatureAlgorithm timeRemainder: 100000 mode: mode),{mode}.
		results add: (DigitalSignatureAlgorithm timeToDivide: 100000 mode: mode),{mode}.
	].
	ops _ (results collect: [ :each | each second]) asSet asSortedCollection.
	ops do: [ :eachOp |
		results do: [ :eachResult |
			eachResult second = eachOp ifTrue: [
				Transcript show: eachResult first asStringWithCommas,'  ',
					eachResult second ,' took ',
					eachResult third asStringWithCommas,' ms using ',
					(modeNames at: eachResult fourth); cr
			].
		].
		Transcript cr.
	].

! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:21'!
time: aBlock as: aString count: anInteger

	^{anInteger. aString. (Time millisecondsToRun: aBlock)}! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:40'!
timeDirect: aBlock as: aString count: anInteger

	Transcript show: anInteger asStringWithCommas,'  ',
		aString ,' took ',
		(Time millisecondsToRun: aBlock) asStringWithCommas,' ms'; cr
! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:18'!
timeMultiply: iterationCount mode: mode
	"Exercise the multiply primitive on iterationCount pairs of random 60 bit integers."
	"DigitalSignatureAlgorithm timeMultiply: 100000 mode: 1"

	| dsa r x y |
	dsa _ DigitalSignatureAlgorithm new.
	r _ Random new.
		x _ ((r next * 16r3FFFFFFF highBit) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		y _ ((r next * 16r3FFFFFFF) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
	^self time: [
		iterationCount timesRepeat: [
			mode = 1 ifTrue: [dsa multiply: x by: y].
			mode = 2 ifTrue: [x * y].
		].

	] as: 'multiply' count: iterationCount
! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:19'!
timeRemainder: iterationCount mode: mode
	"Exercise the remainder method on iterationCount pairs of random 60 bit integers."
	"DigitalSignatureAlgorithm timeRemainder: 100000 mode: 1"

	| dsa r c d tmp |

	dsa _ DigitalSignatureAlgorithm new.
	r _ Random new.
		c _ ((r next * 16r3FFFFFFF highBit) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		d _ ((r next * 16r3FFFFFFF) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		c < d ifTrue: [tmp _ c. c _ d. d _ tmp].
	^self time: [
		iterationCount timesRepeat: [
			mode = 1 ifTrue: [dsa remainder: c mod: d].
			mode = 2 ifTrue: [c \\ d].
			mode = 3 ifTrue: [(c digitDiv: d neg: false) second].
		].
	] as: 'remainder' count: iterationCount
! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:19'!
timeToDivide: iterationCount mode: mode
	"Exercise the divide primitive on iterationCount pairs of random 60 bit integers."
	"DigitalSignatureAlgorithm timeToDivide: 100000 mode: 1"

	| dsa r c d tmp |
	dsa _ DigitalSignatureAlgorithm new.
	r _ Random new.
		c _ ((r next * 16r3FFFFFFF highBit) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		d _ ((r next * 16r3FFFFFFF) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		c < d ifTrue: [tmp _ c. c _ d. d _ tmp].
	^self time: [
		iterationCount timesRepeat: [
			mode = 1 ifTrue: [dsa divide: c by: d].
			mode = 2 ifTrue: [c // d. c \\ d].
			mode = 3 ifTrue: [(c digitDiv: d neg: false) second].
		].
	] as: 'divide' count: iterationCount
! !
ArrayedCollection subclass: #DirectoryEntry
	instanceVariableNames: 'name creationTime modificationTime dirFlag fileSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Directories'!
!DirectoryEntry commentStamp: '<historical>' prior: 0!
an entry in a directory; a reference to either a file or a directory.!


!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'!
creationTime
	"time the entry was created.  (what's its type?)"
	^creationTime! !

!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:38'!
fileSize
	"size of the entry, if it's a file"
	^fileSize! !

!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:38'!
isDirectory
	"whether this entry represents a directory"
	^dirFlag! !

!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'!
modificationTime
	"time the entry was last modified"
	^modificationTime! !

!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'!
name
	"name of the entry"
	^name! !


!DirectoryEntry methodsFor: 'access-compatibility' stamp: 'ls 7/15/1998 22:29'!
at: index
	"compatibility interface"
	"self halt: 'old-style access to DirectoryEntry'"
	index = 1 ifTrue: [ ^self name ].
	index = 2 ifTrue: [ ^self creationTime ].
	index = 3 ifTrue: [ ^self modificationTime ].
	index = 4 ifTrue:[ ^self isDirectory ].
	index = 5 ifTrue:[ ^self fileSize ].
	self error: 'invalid index specified'.! !

!DirectoryEntry methodsFor: 'access-compatibility' stamp: 'ls 7/15/1998 22:16'!
size
	^5! !


!DirectoryEntry methodsFor: 'multilingual system' stamp: 'stephaneducasse 2/4/2006 20:31'!
convertFromSystemName

	name := (FilePath pathName: name isEncoded: true) asSqueakPathName! !


!DirectoryEntry methodsFor: 'private-initialization' stamp: 'stephaneducasse 2/4/2006 20:31'!
privateName: name0  creationTime: creationTime0  modificationTime: modificationTime0  isDirectory: isDirectory0  fileSize: fileSize0
	name := name0.
	creationTime := creationTime0.
	modificationTime := modificationTime0.
	dirFlag := isDirectory0.
	fileSize := fileSize0.! !

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

DirectoryEntry class
	instanceVariableNames: ''!

!DirectoryEntry class methodsFor: 'instance creation' stamp: 'ls 7/15/1998 21:42'!
fromArray: array
	^self name: (array at: 1) creationTime: (array at: 2) modificationTime: (array at: 3) isDirectory: (array at: 4) fileSize: (array at: 5) ! !

!DirectoryEntry class methodsFor: 'instance creation' stamp: 'ls 7/15/1998 21:41'!
name: name0  creationTime: creationTime  modificationTime: modificationTime   isDirectory: isDirectory  fileSize: fileSize
	^self new privateName: name0  creationTime: creationTime  modificationTime: modificationTime  isDirectory: isDirectory  fileSize: fileSize! !
Object subclass: #DiskProxy
	instanceVariableNames: 'globalObjectName preSelector constructorSelector constructorArgs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Storage'!
!DiskProxy commentStamp: '<historical>' prior: 0!
A DiskProxy is an externalized form of an object to write on a
DataStream. It contains a "constructor" message to regenerate
the object, in context, when sent a comeFullyUpOnReload message
(i.e. "internalize").

We are now using DiskProxy for shared system objects like StrikeFonts.

The idea is to define, for each kind of object that needs special
externalization, a class method that will internalize the object by
reconstructing it from its defining state. We call this a
"constructor" method. Then externalize such an object as a frozen
message that invokes this method--a DiskProxy.

(Here is the old comment:
Constructing a new object is good for any object that (1) can not be
externalized simply by snapshotting and reloading its instance
variables (like a CompiledMethod or a Picture), or (2) wants to be
free to evolve its internal representation without making stored
instances obsolete (and dangerous). Snapshotting and reloading an
object"s instance variables is a dangerous breach of encapsulation.

The internal structure of the class is then free to evolve. All
externalized instances will be useful as long as the
constructor methods are maintained with the same semantics.

There may be several constructor methods for a particular class. This
is useful for (1) instances with characteristically different
defining state, and (2) newer, evolved forms of an object and its
constructors, with the old constructor methods kept around so old
data can still be properly loaded.)

Create one like this example from class Picture

    DiskProxy global: #Picture
            selector: #fromByteArray:
                args: (Array with: self storage asByteArray)

* See also subclass DiskProxyQ that will construct an object in
the above manner and then send it a sequence of messages. This may save
creating a wide variety of constructor methods. It is also useful because
the newly read-in DiskProxyQ can catch messages like #objectContainedIn:
(via #doesNotUnderstand:) and add them to the queue of messages to
send to the new object.

* We may also want a subclass of DiskProxy that evaluates a string
expression to compute the receiver of the constructor message.

My instance variables:
* globalObjectName -- the Symbol name of a global object in the
    System dictionary (usually a class).
* constructorSelector -- the constructor message selector Symbol to
    send to the global object (perform:withArguments:), typically a
    variation on newFrom:.
* constructorArgs -- the Array of arguments to pass in the
    constructor message.

-- 11/9/92 Jerry Morrison
!


!DiskProxy methodsFor: 'accessing' stamp: 'tk 3/10/2000 23:50'!
constructorArgs
	^ constructorArgs! !

!DiskProxy methodsFor: 'accessing' stamp: 'tk 11/6/2000 22:38'!
constructorSelector
	^ constructorSelector! !

!DiskProxy methodsFor: 'accessing' stamp: 'tk 11/6/2000 22:38'!
globalObjectName
	^ globalObjectName! !

!DiskProxy methodsFor: 'accessing' stamp: 'tk 11/6/2000 22:35'!
preSelector

	^ preSelector! !

!DiskProxy methodsFor: 'accessing' stamp: 'tk 4/8/1999 12:54'!
preSelector: aSelector

	preSelector _ aSelector! !

!DiskProxy methodsFor: 'accessing' stamp: 'tk 10/6/2000 15:18'!
simpleGlobalOrNil
	"Return the object I refer to if it is a simple global in Smalltalk."

	preSelector ifNotNil: [^ nil].
	constructorSelector == #yourself ifFalse: [^ nil].
	^ Smalltalk at: globalObjectName ifAbsent: [nil].
! !


!DiskProxy methodsFor: 'exceptions' stamp: 'tk 3/14/2000 16:27'!
enter
	"Enter the new project"
	self enter: false revert: false saveForRevert: false.! !

!DiskProxy methodsFor: 'exceptions' stamp: 'dao 10/1/2004 13:31'!
enter: returningFlag revert: revertFlag saveForRevert: saveForRevert
	"Look for our project on the server, then try to enter it!!  DiskProxy is acting as a stub for the real thing.  Called from a ProjectViewMorph in the current project.  If have url, use it.  Else look in current Project's server and folder."

	constructorSelector == #namedUrl: ifTrue: ["Project namedUrl: xxx"
		^ ((Smalltalk at: globalObjectName) perform: #fromUrl:
					withArguments: constructorArgs) ].
	constructorSelector == #named: ifTrue: [
		Project current fromMyServerLoad: constructorArgs first].	"name"
! !

!DiskProxy methodsFor: 'exceptions' stamp: 'RAA 5/17/2000 11:51'!
loadFromServer

	"In support of check for newer version in ProjectViewMorph menu"

	self enter
! !


!DiskProxy methodsFor: 'initialize-release' stamp: 'tk 4/8/1999 12:58'!
global: globalNameSymbol preSelector: aSelector selector: selectorSymbol args: argArray
	"Initialize self as a DiskProxy constructor with the given
	globalNameSymbol, selectorSymbol, and argument Array.
	I will internalize by looking up the global object name in the
	SystemDictionary (Smalltalk) and sending it this message with
	these arguments."

	globalObjectName _ globalNameSymbol asSymbol.
	preSelector _ aSelector asSymbol.
	constructorSelector _ selectorSymbol asSymbol.
	constructorArgs _ argArray.! !

!DiskProxy methodsFor: 'initialize-release' stamp: 'tk 11/4/1999 19:28'!
global: globalNameSymbol selector: selectorSymbol args: argArray
	"Initialize self as a DiskProxy constructor with the given
	globalNameSymbol, selectorSymbol, and argument Array.
	I will internalize by looking up the global object name in the
	SystemDictionary (Smalltalk) and sending it this message with
	these arguments."

	(globalNameSymbol beginsWith: 'AnObsolete') ifTrue: [
		self error: 'Trying to write out, ', globalNameSymbol].
	globalObjectName _ globalNameSymbol asSymbol.
	constructorSelector _ selectorSymbol asSymbol.
	constructorArgs _ argArray.! !


!DiskProxy methodsFor: 'i/o' stamp: 'yo 11/14/2002 15:23'!
comeFullyUpOnReload: smartRefStream
	"Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.)  DataStream will substitute the object from this eval for the DiskProxy."
	| globalObj symbol pr nn arrayIndex |

	symbol _ globalObjectName.
	"See if class is mapped to another name"
	(smartRefStream respondsTo: #renamed) ifTrue: [
		"If in outPointers in an ImageSegment, remember original class name.  
		 See mapClass:installIn:.  Would be lost otherwise."
		((thisContext sender sender sender sender sender sender 
			sender sender receiver class == ImageSegment) and: [ 
		thisContext sender sender sender sender method == 
			(DataStream compiledMethodAt: #readArray)]) ifTrue: [
				arrayIndex _ (thisContext sender sender sender sender) tempAt: 4.
					"index var in readArray.  Later safer to find i on stack of context."
				smartRefStream renamedConv at: arrayIndex put: symbol].	"save original name"
		symbol _ smartRefStream renamed at: symbol ifAbsent: [symbol]].	"map"
	globalObj _ Smalltalk at: symbol ifAbsent: [
		preSelector == nil & (constructorSelector = #yourself) ifTrue: [
			Transcript cr; show: symbol, ' is undeclared.'.
			(Undeclared includesKey: symbol) ifTrue: [^ Undeclared at: symbol].
			Undeclared at: symbol put: nil.
			^ nil].
		^ self error: 'Global "', symbol, '" not found'].
	((symbol == #World) and: [Smalltalk isMorphic not]) ifTrue: [
		self inform: 'These objects will work better if opened in a Morphic World.
Dismiss and reopen all menus.'].

	preSelector ifNotNil: [
		Symbol hasInterned: preSelector ifTrue: [:selector |
			[globalObj _ globalObj perform: selector] on: Error do: [:ex |
				ex messageText = 'key not found' ifTrue: [^ nil].
				^ ex signal]]
	].
	symbol == #Project ifTrue: [
		(constructorSelector = #fromUrl:) ifTrue: [
			nn _ (constructorArgs first findTokens: '/') last.
			nn _ (nn findTokens: '.|') first.
			pr _ Project named: nn. 
			^ pr ifNil: [self] ifNotNil: [pr]].
		pr _ globalObj perform: constructorSelector withArguments: constructorArgs.
		^ pr ifNil: [self] ifNotNil: [pr]].	"keep the Proxy if Project does not exist"

	constructorSelector ifNil: [^ globalObj].
	Symbol hasInterned: constructorSelector ifTrue: [:selector |
		[^ globalObj perform: selector withArguments: constructorArgs] on: Error do: [:ex |
			ex messageText = 'key not found' ifTrue: [^ nil].
			^ ex signal]
	].
				"args not checked against Renamed"
	^ nil 	"was not in proper form"! !

!DiskProxy methodsFor: 'i/o' stamp: 'tk 3/26/98 11:17'!
storeDataOn: aDataStream
	"Besides just storing, get me inserted into references, so structures will know about class DiskProxy."

	super storeDataOn: aDataStream.
	aDataStream references at: self put: #none.
		"just so instVarInfo: will find it and put it into structures"! !


!DiskProxy methodsFor: 'printing' stamp: 'ar 4/10/2005 18:46'!
printOn: aStream
	"Try to report the name of the project"

	globalObjectName == #Project ifFalse: [^ super printOn: aStream].
	constructorArgs size > 0 ifFalse: [^ super printOn: aStream].
	constructorArgs first isString ifFalse: [^ super printOn: aStream].
	aStream nextPutAll: constructorArgs first, ' (on server)'! !

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

DiskProxy class
	instanceVariableNames: ''!

!DiskProxy class methodsFor: 'instance creation'!
global: globalNameSymbol selector: selectorSymbol args: argArray
    "Create a new DiskProxy constructor with the given
     globalNameSymbol, selectorSymbol, and argument Array.
     It will internalize itself by looking up the global object name
     in the SystemDictionary (Smalltalk) and sending it this message
     with these arguments."

    ^ self new global: globalNameSymbol
             selector: selectorSymbol
                 args: argArray! !
DisplayObject subclass: #DisplayMedium
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!DisplayMedium commentStamp: '<historical>' prior: 0!
I am a display object which can both paint myself on a medium (displayOn: messages), and can act as a medium myself. My chief subclass is Form.!


!DisplayMedium methodsFor: 'bordering'!
border: aRectangle width: borderWidth 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses black for 
	drawing the border."

	self border: aRectangle width: borderWidth fillColor: Color black.
! !

!DisplayMedium methodsFor: 'bordering'!
border: aRectangle width: borderWidth fillColor: aHalfTone 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses aHalfTone for 
	drawing the border."

	self border: aRectangle
		widthRectangle: 
			(Rectangle
				left: borderWidth
				right: borderWidth
				top: borderWidth
				bottom: borderWidth)
		rule: Form over
		fillColor: aHalfTone! !

!DisplayMedium methodsFor: 'bordering'!
border: aRectangle width: borderWidth rule: combinationRule fillColor: aHalfTone 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses aHalfTone for 
	drawing the border."

	self border: aRectangle
		widthRectangle: 
			(Rectangle
				left: borderWidth
				right: borderWidth
				top: borderWidth
				bottom: borderWidth)
		rule: combinationRule
		fillColor: aHalfTone! !

!DisplayMedium methodsFor: 'bordering'!
border: aRectangle widthRectangle: insets rule: combinationRule fillColor: aHalfTone
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of each edge of the border is determined by the four coordinates 
	of insets. Uses aHalfTone and combinationRule for drawing the border."

	(aRectangle areasOutside: (aRectangle insetBy: insets)) do:
		[:edgeStrip | self fill: edgeStrip rule: combinationRule fillColor: aHalfTone]! !


!DisplayMedium methodsFor: 'coloring'!
fill: aRectangle fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by 
	aForm according to the rule over."

	self fill: aRectangle rule: Form over fillColor: aForm! !

!DisplayMedium methodsFor: 'coloring'!
fill: aRectangle rule: anInteger fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by 
	aForm according to the rule anInteger."

	self subclassResponsibility! !

!DisplayMedium methodsFor: 'coloring'!
fillBlack
	"Set all bits in the receiver to black (ones)."

	self fill: self boundingBox fillColor: Color black! !

!DisplayMedium methodsFor: 'coloring'!
fillBlack: aRectangle 
	"Set all bits in the receiver's area defined by aRectangle to black (ones)."

	self fill: aRectangle rule: Form over fillColor: Color black! !

!DisplayMedium methodsFor: 'coloring'!
fillColor: aColor
	"Set all pixels in the receiver to the color.  Must be a correct color for this depth of medium.  TK 1 Jun 96"

	self fill: self boundingBox fillColor: aColor! !

!DisplayMedium methodsFor: 'coloring'!
fillGray
	"Set all bits in the receiver to gray."

	self fill: self boundingBox fillColor: Color gray! !

!DisplayMedium methodsFor: 'coloring'!
fillGray: aRectangle
	"Set all bits in the receiver's area defined by aRectangle to the gray mask."

	self fill: aRectangle rule: Form over fillColor: Color gray! !

!DisplayMedium methodsFor: 'coloring'!
fillShape: aShapeForm fillColor: aColor
	"Fill a region corresponding to 1 bits in aShapeForm with aColor"

	^ self fillShape: aShapeForm fillColor: aColor at: 0@0! !

!DisplayMedium methodsFor: 'coloring' stamp: 'ar 5/28/2000 12:06'!
fillShape: aShapeForm fillColor: aColor at: location
	"Fill a region corresponding to 1 bits in aShapeForm with aColor"

	((BitBlt current destForm: self sourceForm: aShapeForm fillColor: aColor
		combinationRule: Form paint
		destOrigin: location + aShapeForm offset sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF))
		copyBits! !

!DisplayMedium methodsFor: 'coloring'!
fillWhite
	"Set all bits in the form to white."

	self fill: self boundingBox fillColor: Color white.
! !

!DisplayMedium methodsFor: 'coloring'!
fillWhite: aRectangle
	"Set all bits in the receiver's area defined by aRectangle to white."

	self fill: aRectangle rule: Form over fillColor: Color white.
! !

!DisplayMedium methodsFor: 'coloring'!
fillWithColor: aColor
	"Fill the receiver's bounding box with the given color."

	self fill: self boundingBox fillColor: aColor.
! !

!DisplayMedium methodsFor: 'coloring' stamp: 'jm 6/18/1999 19:01'!
reverse
	"Change all the bits in the receiver that are white to black, and the ones 
	that are black to white."

	self fill: self boundingBox rule: Form reverse fillColor: (Color quickHighLight: self depth)! !

!DisplayMedium methodsFor: 'coloring' stamp: 'jm 6/18/1999 19:00'!
reverse: aRectangle
	"Change all the bits in the receiver's area that intersects with aRectangle 
	that are white to black, and the ones that are black to white."

	self fill: aRectangle rule: Form reverse fillColor: (Color quickHighLight: self depth)! !

!DisplayMedium methodsFor: 'coloring'!
reverse: aRectangle fillColor: aMask	
	"Change all the bits in the receiver's area that intersects with aRectangle 
	according to the mask. Black does not necessarily turn to white, rather it 
	changes with respect to the rule and the bit in a corresponding mask 
	location. Bound to give a surprise."

	self fill: aRectangle rule: Form reverse fillColor: aMask! !


!DisplayMedium methodsFor: 'displaying'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 
	"Make up a BitBlt table and copy the bits."

	self subclassResponsibility! !

!DisplayMedium methodsFor: 'displaying' stamp: 'hmm 9/16/2000 21:27'!
deferUpdatesIn: aRectangle while: aBlock
	"DisplayScreen overrides with something more involved..."
	^aBlock value! !

!DisplayMedium methodsFor: 'displaying'!
drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Draw line by copying the argument, sourceForm, starting at location 
	beginPoint and ending at endPoint, clipped by the rectangle, clipRect. 
	The rule and mask for copying are the arguments anInteger and aForm."

	self subclassResponsibility! !
Object subclass: #DisplayObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!DisplayObject commentStamp: '<historical>' prior: 0!
The abstract protocol for most display primitives that are used by Views for presenting information on the screen.!


!DisplayObject methodsFor: 'accessing'!
extent
	"Answer the point that represents the width and height of the receiver's 
	bounding box."

	^self boundingBox extent! !

!DisplayObject methodsFor: 'accessing'!
height
	"Answer the number that represents the height of the receiver's 
	bounding box."

	^self boundingBox height! !

!DisplayObject methodsFor: 'accessing'!
offset
	"Answer the amount by which the receiver should be offset when it is 
	displayed or its position is tested."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'accessing'!
offset: aPoint 
	"Set the amount by which the receiver's position is offset."

	^self! !

!DisplayObject methodsFor: 'accessing'!
relativeRectangle
	"Answer a Rectangle whose top left corner is the receiver's offset position 
	and whose width and height are the same as the receiver."

	^Rectangle origin: self offset extent: self extent! !

!DisplayObject methodsFor: 'accessing'!
width
	"Answer the number that represents the width of the receiver's bounding 
	box."

	^self boundingBox width! !


!DisplayObject methodsFor: 'display box access'!
boundingBox
	"Answer the rectangular area that represents the boundaries of the 
	receiver's space of information."

	^self computeBoundingBox! !

!DisplayObject methodsFor: 'display box access'!
center

	^ self boundingBox center! !

!DisplayObject methodsFor: 'display box access'!
computeBoundingBox
	"Answer the rectangular area that represents the boundaries of the 
	receiver's area for displaying information. This is the primitive for 
	computing the area if it is not already known."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'display box access'!
initialExtent
	"Included here for when a FormView is being opened
	as a window.  (4@4) covers border widths."

	^ self extent + (4@4) ! !


!DisplayObject methodsFor: 'displaying-Display'!
display 
	"Display the receiver on the Display at location 0,0."

	self displayOn: Display! !

!DisplayObject methodsFor: 'displaying-Display'!
follow: locationBlock while: durationBlock
   "Move an image around on the Display. Restore the background
   continuously without causing flashing. The argument, locationBlock,
   supplies each new location, and the argument, durationBlock, supplies
   true to continue, and then false to stop.
   8/20/96 sw: call follow:while:bitsBehind: to do the real work.  Note that th
method
   now returns the final bits behind as method value."
 
   | bitsBehind loc |
   bitsBehind _ Form fromDisplay: ((loc _ locationBlock value) extent: self extent).
   ^ self follow: locationBlock while: durationBlock bitsBehind: bitsBehind startingLoc: loc! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'ar 5/28/2000 12:06'!
follow: locationBlock while: durationBlock bitsBehind: initialBitsBehind startingLoc: loc
   "Move an image around on the Display. Restore the background continuously without causing flashing. The argument, locationBlock, supplies each new location, and the argument, durationBlock, supplies true to continue or false to stop. This variant takes the bitsBehind as an input argument, and returns the final saved saved bits as method value."

   | location rect1 save1 save1Blt buffer bufferBlt newLoc rect2 bothRects |
   location _ loc.
   rect1 _ location extent: self extent.
   save1 _ initialBitsBehind.
   save1Blt _ BitBlt current toForm: save1.
   buffer _ Form extent: self extent*2 depth: Display depth.  "Holds overlapping region"
   bufferBlt _ BitBlt current toForm: buffer.
   Display deferUpdates: true.
   self displayOn: Display at: location rule: Form paint.
   Display deferUpdates: false; forceToScreen: (location extent: self extent).
   [durationBlock value] whileTrue: [
		newLoc _ locationBlock value.
		newLoc ~= location ifTrue: [
			rect2 _ newLoc extent: self extent.
			bothRects _ rect1 merge: rect2.
			(rect1 intersects: rect2)
				ifTrue: [  "when overlap, buffer background for both rectangles"
					bufferBlt copyFrom: bothRects in: Display to: 0@0.
					bufferBlt copyFrom: save1 boundingBox in: save1 to: rect1 origin - bothRects origin.
					"now buffer is clean background; get new bits for save1"
					save1Blt copy: (0@0 extent: self extent) from: rect2 origin - bothRects origin in: buffer.
					self displayOnPort: bufferBlt at: rect2 origin - bothRects origin rule: Form paint.
					Display deferUpdates: true.
					Display copy: bothRects from: 0@0 in: buffer rule: Form over.
					Display deferUpdates: false; forceToScreen: bothRects]
				ifFalse: [  "when no overlap, do the simple thing (both rects might be too big)"
					Display deferUpdates: true.
					Display copy: (location extent: save1 extent) from: 0@0 in: save1 rule: Form over.
					save1Blt copyFrom: rect2 in: Display to: 0@0.
					self displayOn: Display at: newLoc rule: Form paint.
					Display deferUpdates: false; 
						forceToScreen: (location extent: save1 extent); 
						forceToScreen: (newLoc extent: self extent)].
			location _ newLoc.
			rect1 _ rect2]].

	^ save1 displayOn: Display at: location
! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'di 9/12/97 11:09'!
isTransparent
	^ false! !

!DisplayObject methodsFor: 'displaying-Display'!
slideFrom: startPoint to: stopPoint nSteps: nSteps 
	"does not display at the first point, but does at the last"
	| i p delta |
	i_0.  p_ startPoint.
	delta _ (stopPoint-startPoint) // nSteps.
	^ self follow: [p_ p+delta]
		while: [(i_i+1) < nSteps]! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'jm 10/22/97 07:43'!
slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs
	"Slide this object across the display over the given number of steps, pausing for the given number of milliseconds after each step."
	"Note: Does not display at the first point, but does at the last."

	| i p delta |
	i _ 0.
	p _ startPoint.
	delta _ (stopPoint - startPoint) / nSteps asFloat.
	^ self
		follow: [(p _ p + delta) truncated]
		while: [
			(Delay forMilliseconds: milliSecs) wait.
			(i _ i + 1) < nSteps]
! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'di 10/19/97 12:05'!
slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs andStay: stayAtEnd
	"Does not display at the first point, but does at the last.
	Moreover, if stayAtEnd is true, it leaves the dragged image at the stopPoint"
	| i done |
	i _ 0.
	^ self follow: [startPoint + ((stopPoint-startPoint) * i // nSteps)]
		while: [milliSecs ifNotNil: [(Delay forMilliseconds: milliSecs) wait].
				((done _ (i _ i+1) > nSteps) and: [stayAtEnd])
					ifTrue: [^ self "Return without clearing the image"].
				done not]! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'sr 6/6/2000 05:37'!
slideWithFirstFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs 
	"Slide this object across the display over the given number of steps, 
	pausing for the given number of milliseconds after each step."
	"Note: Does display at the first point and at the last."
	| i p delta |
	i _ 0.
	delta _ stopPoint - startPoint / nSteps asFloat.
	p _ startPoint - delta.
	^ self follow: [(p _ p + delta) truncated]
		while: 
			[(Delay forMilliseconds: milliSecs) wait.
			(i _ i + 1) <= nSteps]! !


!DisplayObject methodsFor: 'displaying-generic'!
displayAt: aDisplayPoint 
	"Display the receiver located at aDisplayPoint with default settings for 
	the displayMedium, rule and halftone."

	self displayOn: Display
		at: aDisplayPoint
		clippingBox: Display boundingBox
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium
	"Simple default display in order to see the receiver in the upper left 
	corner of screen."

	self displayOn: aDisplayMedium at: 0 @ 0! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium at: aDisplayPoint 
	"Display the receiver located at aDisplayPoint with default settings for 
	rule and halftone."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: aDisplayMedium boundingBox
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle 
	"Display the receiver located at aDisplayPoint with default settings for 
	rule and halftone. Information to be displayed must be confined to the 
	area that intersects with clipRectangle."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: clipRectangle
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"This is the basic display primitive for graphic display objects. Display 
	the receiver located at aDisplayPoint with rule, ruleInteger, and mask, 
	aForm. Information to be displayed must be confined to the area that 
	intersects with clipRectangle."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium at: aDisplayPoint rule: ruleInteger
	"Display the receiver located at aPoint with default setting for the 
	halftone and clippingBox."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: aDisplayMedium boundingBox
		rule: ruleInteger
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle 
	"Display primitive for the receiver where a DisplayTransformation is 
	provided as an argument. Alignment is defaulted to the receiver's 
	rectangle. Information to be displayed must be confined to the area that 
	intersects with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: self relativeRectangle center
		with: self relativeRectangle center
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint 
	"Display primitive where a DisplayTransformation is provided as an 
	argument, rule is over and mask is Form black. Information to be 
	displayed must be confined to the area that intersects with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: alignmentPoint
		with: relativePoint
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is ruleInteger and mask is aForm. Translate by 
	relativePoint-alignmentPoint. Information to be displayed must be 
	confined to the area that intersects with clipRectangle."

	| absolutePoint |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	self displayOn: aDisplayMedium
		at: (absolutePoint - alignmentPoint) 
		clippingBox: clipRectangle 
		rule: ruleInteger 
		fillColor: aForm ! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle fixedPoint: aPoint 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is over and mask is Form black. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: aPoint
		with: aPoint
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is ruleInteger and mask is aForm. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: self relativeRectangle origin
		with: self relativeRectangle origin
		rule: ruleInteger
		fillColor: aForm! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOnPort: aPort 
	self displayOnPort: aPort at: 0@0! !

!DisplayObject methodsFor: 'displaying-generic' stamp: 'jm 10/21/97 16:56'!
displayOnPort: port at: location rule: rule

	port copyForm: self to: location rule: rule.
! !

!DisplayObject methodsFor: 'displaying-generic'!
followCursor
	"Just show the Form following the mouse. 6/21/96 tk"
	Cursor blank showWhile:
		[self follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]
! !


!DisplayObject methodsFor: 'fileIn/Out'!
writeOnFileNamed: fileName 
	"Saves the receiver on the file fileName in the format:
		fileCode, depth, extent, offset, bits."
	| file |
	file _ FileStream newFileNamed: fileName.
	file binary.
	file nextPut: 2.  "file code = 2"
	self writeOn: file.
	file close
"
 | f |
[(f _ Form fromUser) boundingBox area>25] whileTrue:
	[f writeOnFileNamed: 'test.form'.
	(Form newFromFileNamed: 'test.form') display].
"! !

!DisplayObject methodsFor: 'fileIn/Out' stamp: 'tk 2/19/1999 07:20'!
writeUncompressedOnFileNamed: fileName 
	"Saves the receiver on the file fileName in the format:
		fileCode, depth, extent, offset, bits."
	| file |
	file _ FileStream newFileNamed: fileName.
	file binary.
	file nextPut: 2.  "file code = 2"
	self writeUncompressedOn: file.
	file close
"
 | f |
[(f _ Form fromUser) boundingBox area>25] whileTrue:
	[f writeUncompressedOnFileNamed: 'test.form'.
	(Form fromBinaryStream: (FileStream oldFileNamed: 'test.form')) display].
"! !


!DisplayObject methodsFor: 'transforming'!
align: alignmentPoint with: relativePoint 
	"Translate the receiver's offset such that alignmentPoint aligns with 
	relativePoint."

	self offset: (self offset translateBy: relativePoint - alignmentPoint)! !

!DisplayObject methodsFor: 'transforming'!
scaleBy: aPoint 
	"Scale the receiver's offset by aPoint."

	self offset: (self offset scaleBy: aPoint)! !

!DisplayObject methodsFor: 'transforming'!
translateBy: aPoint 
	"Translate the receiver's offset."

	self offset: (self offset translateBy: aPoint)! !


!DisplayObject methodsFor: 'truncation and round off'!
rounded
	"Convert the offset of the receiver to integer coordinates."

	self offset: self offset rounded! !

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

DisplayObject class
	instanceVariableNames: ''!

!DisplayObject class methodsFor: 'fileIn/Out' stamp: 'mdr 8/31/2000 19:11'!
collectionFromFileNamed: fileName 
	"Answer a collection of Forms read from the external file 
	named fileName. The file format is: fileCode, {depth, extent, offset, bits}."

	| formList f fileCode |
	formList _ OrderedCollection new.
	f _ (FileStream readOnlyFileNamed: fileName) binary.
	fileCode _ f next.
	fileCode = 1
		ifTrue: [
			[f atEnd] whileFalse: [formList add: (self new readFromOldFormat: f)]]
		ifFalse: [
			fileCode = 2 ifFalse: [self error: 'unknown Form file format'. ^ formList].
			[f atEnd] whileFalse: [formList add: (self new readFrom: f)]].
	f close.
	^ formList
! !

!DisplayObject class methodsFor: 'fileIn/Out'!
writeCollection: coll onFileNamed: fileName 
	"Saves a collection of Forms on the file fileName in the format:
		fileCode, {depth, extent, offset, bits}."
	| file |
	file _ FileStream newFileNamed: fileName.
	file binary.
	file nextPut: 2.  "file code = 2"
	coll do: [:f | f writeOn: file].
	file close
"
 | f c | c _ OrderedCollection new.
[(f _ Form fromUser) boundingBox area>25] whileTrue: [c add: f].
Form writeCollection: c onFileNamed: 'test.forms'.
c _ Form collectionFromFileNamed: 'test.forms'.
1 to: c size do: [:i | (c at: i) displayAt: 0@(i*100)].
"! !
CharacterScanner subclass: #DisplayScanner
	instanceVariableNames: 'bitBlt lineY runX foregroundColor backgroundColor fillBlt lineHeight paragraph paragraphColor morphicOffset ignoreColorChanges'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Text'!
!DisplayScanner commentStamp: '<historical>' prior: 0!
My instances are used to scan text and display it on the screen or in a hidden form.!


!DisplayScanner methodsFor: 'MVC-compatibility' stamp: 'BG 5/31/2003 16:08'!
displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle
	"The central display routine. The call on the primitive 
	(scanCharactersFrom:to:in:rightX:) will be interrupted according to an 
	array of stop conditions passed to the scanner at which time the code to 
	handle the stop condition is run and the call on the primitive continued 
	until a stop condition returns true (which means the line has 
	terminated)."
	| runLength done stopCondition leftInRun startIndex string lastPos |
	"leftInRun is the # of characters left to scan in the current run;
		when 0, it is time to call 'self setStopConditions'"
	morphicOffset _ 0@0.
	leftInRun _ 0.
	self initializeFromParagraph: aParagraph clippedBy: visibleRectangle.
	ignoreColorChanges _ false.
	paragraph _ aParagraph.
	foregroundColor _ paragraphColor _ aParagraph foregroundColor.
	backgroundColor _ aParagraph backgroundColor.
	aParagraph backgroundColor isTransparent
		ifTrue: [fillBlt _ nil]
		ifFalse: [fillBlt _ bitBlt copy.  "Blt to fill spaces, tabs, margins"
				fillBlt sourceForm: nil; sourceOrigin: 0@0.
				fillBlt fillColor: aParagraph backgroundColor].
	rightMargin _ aParagraph rightMarginForDisplay.
	lineY _ aParagraph topAtLineIndex: linesInterval first.
	bitBlt destForm deferUpdatesIn: visibleRectangle while: [
		linesInterval do: 
			[:lineIndex | 
			line _ aParagraph lines at: lineIndex.
			lastIndex _ line first.
               self setStopConditions. " causes an assignment to inst var.  alignment "

			leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]).
			destX _ (runX _ leftMargin).
			line _ aParagraph lines at: lineIndex.
			lineHeight _ line lineHeight.
			fillBlt == nil ifFalse:
				[fillBlt destX: visibleRectangle left destY: lineY
					width: visibleRectangle width height: lineHeight; copyBits].
			lastIndex _ line first.
			leftInRun <= 0
				ifTrue: [self setStopConditions.  "also sets the font"
						leftInRun _ text runLengthFor: line first].
			destY _ lineY + line baseline - font ascent.  "Should have happened in setFont"
			runLength _ leftInRun.
			runStopIndex _ lastIndex + (runLength - 1) min: line last.
			leftInRun _ leftInRun - (runStopIndex - lastIndex + 1).
			spaceCount _ 0.
			done _ false.
			string _ text string.
			self handleIndentation.
			[done] whileFalse:[
				startIndex _ lastIndex.
				lastPos _ destX@destY.
				stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
							in: string rightX: rightMargin stopConditions: stopConditions
							kern: kern.
				lastIndex >= startIndex ifTrue:[
					font displayString: string on: bitBlt 
						from: startIndex to: lastIndex at: lastPos kern: kern].
				"see setStopConditions for stopping conditions for displaying."
				done _ self perform: stopCondition].
			fillBlt == nil ifFalse:
				[fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits].
			lineY _ lineY + lineHeight]]! !

!DisplayScanner methodsFor: 'MVC-compatibility' stamp: 'yo 3/14/2005 06:48'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	super initializeFromParagraph: aParagraph clippedBy: clippingRectangle.
	bitBlt _ BitBlt asGrafPort toForm: aParagraph destinationForm.
	bitBlt sourceX: 0; width: 0.	"Init BitBlt so that the first call to a primitive will not fail"
	bitBlt combinationRule:
		((Display depth = 1)
			ifTrue:
				[aParagraph rule]
			ifFalse:
				[Form paint]).
	bitBlt colorMap:
		(Bitmap with: 0      "Assumes 1-bit deep fonts"
				with: (bitBlt destForm pixelValueFor: aParagraph foregroundColor)).
	bitBlt clipRect: clippingRectangle! !


!DisplayScanner methodsFor: 'scanning' stamp: 'yo 10/7/2002 18:38'!
displayLine: textLine offset: offset leftInRun: leftInRun
	"The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated).  leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions."
	| done stopCondition nowLeftInRun startIndex string lastPos |
	line _ textLine.
	morphicOffset _ offset.
	lineY _ line top + offset y.
	lineHeight _ line lineHeight.
	rightMargin _ line rightMargin + offset x.
	lastIndex _ line first.
	leftInRun <= 0 ifTrue: [self setStopConditions].
	leftMargin _ (line leftMarginForAlignment: alignment) + offset x.
	destX _ runX _ leftMargin.
	fillBlt == nil ifFalse:
		["Not right"
		fillBlt destX: line left destY: lineY
			width: line width left height: lineHeight; copyBits].
	lastIndex _ line first.
	leftInRun <= 0
		ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex]
		ifFalse: [nowLeftInRun _ leftInRun].
	destY _ lineY + line baseline - font ascent.
	runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last.
	spaceCount _ 0.
	done _ false.
	string _ text string.
	[done] whileFalse:[
		startIndex _ lastIndex.
		lastPos _ destX@destY.
		stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
						in: string rightX: rightMargin stopConditions: stopConditions
						kern: kern.
		lastIndex >= startIndex ifTrue:[
			font displayString: string on: bitBlt 
				from: startIndex to: lastIndex at: lastPos kern: kern].
		"see setStopConditions for stopping conditions for displaying."
		done _ self perform: stopCondition.
		lastIndex > runStopIndex ifTrue: [done _ true].
	].
	^ runStopIndex - lastIndex   "Number of characters remaining in the current run"! !

!DisplayScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 13:28'!
placeEmbeddedObject: anchoredMorph
	anchoredMorph relativeTextAnchorPosition ifNotNil:[
		anchoredMorph position: 
			anchoredMorph relativeTextAnchorPosition +
			(anchoredMorph owner textBounds origin x @ 0)
			- (0@morphicOffset y) + (0@lineY).
		^true
	].
	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	anchoredMorph isMorph ifTrue: [
		anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset
	] ifFalse: [
		destY _ lineY.
		runX _ destX.
		anchoredMorph 
			displayOn: bitBlt destForm 
			at: destX - anchoredMorph width @ destY
			clippingBox: bitBlt clipRect
	].
	^ true! !


!DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:42'!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	lastIndex_ lastIndex + 1.
	^false! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 16:24'!
crossedX
	"This condition will sometimes be reached 'legally' during display, when, 
	for instance the space that caused the line to wrap actually extends over 
	the right boundary. This character is allowed to display, even though it 
	is technically outside or straddling the clipping ectangle since it is in 
	the normal case not visible and is in any case appropriately clipped by 
	the scanner."

	^ true ! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 16:24'!
endOfRun
	"The end of a run in the display case either means that there is actually 
	a change in the style (run code) to be associated with the string or the 
	end of this line has been reached."
	| runLength |
	lastIndex = line last ifTrue: [^true].
	runX _ destX.
	runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
	runStopIndex _ lastIndex + (runLength - 1) min: line last.
	self setStopConditions.
	^ false! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 16:20'!
paddedSpace
	"Each space is a stop condition when the alignment is right justified. 
	Padding must be added to the base width of the space according to 
	which space in the line this space is and according to the amount of 
	space that remained at the end of the line when it was composed."

	spaceCount _ spaceCount + 1.
	destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).
	lastIndex _ lastIndex + 1.
	^ false! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'hmm 7/16/2000 08:23'!
plainTab
	| oldX |
	oldX _ destX.
	super plainTab.
	fillBlt == nil ifFalse:
		[fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:43'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]).

"
	alignment = Justified ifTrue: [
		stopConditions == DefaultStopConditions 
			ifTrue:[stopConditions _ stopConditions copy].
		stopConditions at: Space asciiValue + 1 put: #paddedSpace]
"! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'hmm 7/16/2000 08:23'!
tab
	self plainTab.
	lastIndex _ lastIndex + 1.
	^ false! !


!DisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 19:26'!
setDestForm: df
	bitBlt setDestForm: df.! !

!DisplayScanner methodsFor: 'private' stamp: 'di 9/3/2000 16:13'!
setFont 
	foregroundColor _ paragraphColor.
	super setFont.  "Sets font and emphasis bits, and maybe foregroundColor"
	font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent.
	text ifNotNil:[destY _ lineY + line baseline - font ascent]! !

!DisplayScanner methodsFor: 'private' stamp: 'hmm 9/16/2000 21:29'!
setPort: aBitBlt
	"Install the BitBlt to use"
	bitBlt _ aBitBlt.
	bitBlt sourceX: 0; width: 0.	"Init BitBlt so that the first call to a primitive will not fail"
	bitBlt sourceForm: nil. "Make sure font installation won't be confused"
! !

!DisplayScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:51'!
text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode
	text _ t.
	textStyle _ ts. 
	foregroundColor _ paragraphColor _ foreColor.
	(backgroundColor _ backColor) isTransparent ifFalse:
		[fillBlt _ blt.
		fillBlt fillColor: backgroundColor].
	ignoreColorChanges _ shadowMode! !

!DisplayScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:51'!
textColor: textColor
	ignoreColorChanges ifTrue: [^ self].
	foregroundColor _ textColor! !

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

DisplayScanner class
	instanceVariableNames: ''!

!DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:39'!
defaultFont
	^ TextStyle defaultFont! !
Form subclass: #DisplayScreen
	instanceVariableNames: 'clippingBox extraRegions'
	classVariableNames: 'DeferringUpdates DisplayChangeSignature ScreenSave'
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!DisplayScreen commentStamp: '<historical>' prior: 0!
There is only one instance of me, Display. It is a global and is used to handle general user requests to deal with the whole display screen. 
	Although I offer no protocol, my name provides a way to distinguish this special instance from all other Forms. This is useful, for example, in dealing with saving and restoring the system.
	To change the depth of your Display...
		Display newDepth: 16.
		Display newDepth: 8.
		Display newDepth: 1.
Valid display depths are 1, 2, 4, 8, 16 and 32.  It is suggested that you run with your monitors setting the same, for better speed and color fidelity.  Note that this can add up to 4Mb for the Display form.  Finally, note that newDepth: ends by executing a 'ControlManager restore' which currently terminates the active process, so nothing that follows in the doit will get executed.

Depths 1, 2, 4 and 8 bits go through a color map to put color on the screen, but 16 and 32-bit color use the pixel values directly for RGB color (5 and 8 bits per, respectivlely).  The color choice an be observed by executing Color fromUser in whatever depth you are using.
!


!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:01'!
defaultBitBltClass
	"Return the BitBlt version to use when I am active"
	^BitBlt! !

!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:02'!
defaultCanvasClass
	"Return the WarpBlt version to use when I am active"
	^FormCanvas! !

!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:01'!
defaultWarpBltClass
	"Return the WarpBlt version to use when I am active"
	^WarpBlt! !


!DisplayScreen methodsFor: 'disk I/O' stamp: 'tk 9/28/2000 15:41'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to the Display in the other system instead.  "

	"A path to me"
	dp _ DiskProxy global: #Display selector: #yourself args: #().
	refStrm replace: self with: dp.
	^ dp
! !


!DisplayScreen methodsFor: 'displaying' stamp: 'ar 4/19/2001 05:44'!
addExtraRegion: aRectangle for: regionDrawer
	"Register the given rectangle as a region which is drawn by the specified region drawer. The region will be excluded from any updates when #forceDamageToScreen: is called. Note that the rectangle is only valid for a single update cycle; once #forceDamageToScreen: has been called, the region drawer and its region are being removed from the list"
	extraRegions ifNil:[extraRegions _ #()].
	extraRegions _ extraRegions copyWith: (Array with: regionDrawer with: aRectangle).
! !

!DisplayScreen methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:07'!
copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf 
	(BitBlt current
		destForm: self
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: rect origin
		extent: rect extent
		clipRect: (clipRect intersect: clippingBox)) copyBits! !

!DisplayScreen methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:07'!
copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf map: map
	((BitBlt current
		destForm: self
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: rect origin
		extent: rect extent
		clipRect: (clipRect intersect: clippingBox)) colorMap: map) copyBits! !

!DisplayScreen methodsFor: 'displaying' stamp: 'jm 5/22/1998 01:23'!
flash: aRectangle 
	"Flash the area of the screen defined by the given rectangle."

	self reverse: aRectangle.
	self forceDisplayUpdate.
	(Delay forMilliseconds: 100) wait.
	self reverse: aRectangle.
	self forceDisplayUpdate.
! !

!DisplayScreen methodsFor: 'displaying' stamp: 'RAA 6/2/2000 12:09'!
flash: aRectangle andWait: msecs
	"Flash the area of the screen defined by the given rectangle."

	self reverse: aRectangle.
	self forceDisplayUpdate.
	(Delay forMilliseconds: msecs) wait.
	self reverse: aRectangle.
	self forceDisplayUpdate.
	(Delay forMilliseconds: msecs) wait.
! !

!DisplayScreen methodsFor: 'displaying' stamp: 'sw 1/1/2005 01:31'!
flashAll: rectangleList andWait: msecs
	"Flash the areas of the screen defined by the given rectangles."

	rectangleList do: [:aRectangle | self reverse: aRectangle].
	self forceDisplayUpdate.
	(Delay forMilliseconds: msecs) wait.
	rectangleList do: [:aRectangle | self reverse: aRectangle].
	self forceDisplayUpdate.
	(Delay forMilliseconds: msecs) wait.
! !

!DisplayScreen methodsFor: 'displaying' stamp: 'ar 5/15/2001 20:08'!
forceDamageToScreen: allDamage
	"Force all the damage rects to the screen."
	| rectList excluded remaining regions |
	rectList _ allDamage.
	"Note: Reset extra regions at the beginning to prevent repeated errors"
	regions _ extraRegions.
	extraRegions _ nil.
	regions ifNotNil:[
		"exclude extra regions"
		regions do:[:drawerAndRect|
			excluded _ drawerAndRect at: 2.
			remaining _ WriteStream on: #().
			rectList do:[:r|
				remaining nextPutAll:(r areasOutside: excluded)].
			rectList _ remaining contents].
	].
	rectList do:[:r| self forceToScreen: r].
	regions ifNotNil:[
		"Have the drawers paint what is needed"
		regions do:[:drawerAndRect| (drawerAndRect at: 1) forceToScreen].
	].! !


!DisplayScreen methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 00:07'!
release
	"I am no longer Display. Release any resources if necessary"! !

!DisplayScreen methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 11:25'!
shutDown 
	"Minimize Display memory saved in image"
	self setExtent: 240@120 depth: depth! !


!DisplayScreen methodsFor: 'other'!
boundingBox
	clippingBox == nil
		ifTrue: [clippingBox _ super boundingBox].
	^ clippingBox! !

!DisplayScreen methodsFor: 'other'!
clippingTo: aRect do: aBlock
	"Display clippingTo: Rectangle fromUser do:
	[ScheduledControllers restore: Display fullBoundingBox]"
	| saveClip |
	saveClip _ clippingBox.
	clippingBox _ aRect.
	aBlock value.
	clippingBox _ saveClip! !

!DisplayScreen methodsFor: 'other' stamp: 'hmm 6/18/2000 19:16'!
deferUpdates: aBoolean
	| wasDeferred |
	"Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer whether updates were deferred before if the primitive succeeds, nil if it fails."

	wasDeferred _ DeferringUpdates == true.
	DeferringUpdates _ aBoolean.
	^(self primitiveDeferUpdates: aBoolean) ifNotNil: [wasDeferred]! !

!DisplayScreen methodsFor: 'other' stamp: 'hmm 2/2/2001 10:14'!
deferUpdatesIn: aRectangle while: aBlock
	| result |
	(self deferUpdates: true) ifTrue: [^aBlock value].
	result _ aBlock value.
	self deferUpdates: false.
	self forceToScreen: aRectangle.
	^result! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 11/27/1999 15:48'!
displayChangeSignature

	^DisplayChangeSignature! !

!DisplayScreen methodsFor: 'other' stamp: 'jm 5/21/1998 23:48'!
forceDisplayUpdate
	"On platforms that buffer screen updates, force the screen to be updated immediately. On other platforms, or if the primitive is not implemented, do nothing."

	<primitive: 231>
	"do nothing if primitive fails"! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 2/11/1999 18:14'!
forceToScreen
	"Force the entire display area to the screen"
	^self forceToScreen: self boundingBox! !

!DisplayScreen methodsFor: 'other' stamp: 'jm 5/19/1998 17:50'!
forceToScreen: aRectangle
	"Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Typically used when the deferUpdates flag in the virtual machine is on; see deferUpdates:."

	self primShowRectLeft: aRectangle left
		right: aRectangle right
		top: aRectangle top
		bottom: aRectangle bottom.
! !

!DisplayScreen methodsFor: 'other'!
fullBoundingBox
	^ super boundingBox! !

!DisplayScreen methodsFor: 'other'!
fullScreen   "Display fullScreen"

	ScreenSave notNil ifTrue: [Display _ ScreenSave].
	clippingBox _ super boundingBox! !

!DisplayScreen methodsFor: 'other' stamp: 'sd 6/7/2003 19:46'!
fullScreenMode: aBoolean
	"On platforms that support it, set full-screen mode to the value of the argument. (Note: you'll need to restore the Display after calling this primitive."
	"Display fullScreenMode: true. Display newDepth: Display depth"

	<primitive: 233>
	self primitiveFailed
! !

!DisplayScreen methodsFor: 'other'!
height
	^ self boundingBox height! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 5/5/1999 23:44'!
newDepth: pixelSize
"
	Display newDepth: 8.
	Display newDepth: 1.
"
	(self supportsDisplayDepth: pixelSize)
		ifFalse:[^self inform:'Display depth ', pixelSize printString, ' is not supported on this system'].
	self newDepthNoRestore: pixelSize.
	self restore.! !

!DisplayScreen methodsFor: 'other' stamp: 'hmm 6/18/2000 19:14'!
primitiveDeferUpdates: aBoolean
	"Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer the receiver if the primitive succeeds, nil if it fails."

	<primitive: 126>
	^ nil  "answer nil if primitive fails"
! !

!DisplayScreen methodsFor: 'other'!
replacedBy: aForm do: aBlock
	"Permits normal display to draw on aForm instead of the display."

	ScreenSave _ self.
	Display _ aForm.
	aBlock value.
	Display _ self.
	ScreenSave _ nil.! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 3/17/2001 23:53'!
restore
	Smalltalk isMorphic
		ifTrue: [World fullRepaintNeeded]
		ifFalse: [ScheduledControllers unCacheWindows; restore].! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 3/17/2001 23:53'!
restoreAfter: aBlock
	"Evaluate the block, wait for a mouse click, and then restore the screen."

	aBlock value.
	Sensor waitButton.
	Smalltalk isMorphic
		ifTrue: [World fullRepaintNeeded]
		ifFalse: [(ScheduledControllers restore; activeController) view emphasize]! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 5/17/2001 21:02'!
supportedDisplayDepths
	"Return all pixel depths supported on the current host platform."
	^#(1 2 4 8 16 32 -1 -2 -4 -8 -16 -32) select: [:d | self supportsDisplayDepth: d]! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 5/5/1999 23:45'!
supportsDisplayDepth: pixelDepth
	"Return true if this pixel depth is supported on the current host platform.
	Primitive. Optional."
	<primitive: 91>
	^#(1 2 4 8 16 32) includes: pixelDepth! !

!DisplayScreen methodsFor: 'other'!
usableArea
	"Answer the usable area of the receiver.  5/22/96 sw."

	^ self boundingBox deepCopy! !

!DisplayScreen methodsFor: 'other'!
width
	^ self boundingBox width! !


!DisplayScreen methodsFor: 'testing' stamp: 'ar 5/25/2000 23:34'!
isDisplayScreen
	^true! !


!DisplayScreen methodsFor: 'private'!
beDisplay
	"Primitive. Tell the interpreter to use the receiver as the current display 
	image. Fail if the form is too wide to fit on the physical display. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 102>
	self primitiveFailed! !

!DisplayScreen methodsFor: 'private' stamp: 'di 3/3/1999 10:00'!
copyFrom: aForm
	"Take on all state of aForm, with complete sharing"

	super copyFrom: aForm.
	clippingBox _ super boundingBox! !

!DisplayScreen methodsFor: 'private' stamp: 'ar 5/25/2000 23:43'!
findAnyDisplayDepth
	"Return any display depth that is supported on this system."
	^self findAnyDisplayDepthIfNone:[
		"Ugh .... now this is a biggie - a system that does not support
		any of the Squeak display depths at all."
		Smalltalk
			logError:'Fatal error: This system has no support for any display depth at all.'
			inContext: thisContext
			to: 'SqueakDebug.log'.
		Smalltalk quitPrimitive. "There is no way to continue from here"
	].! !

!DisplayScreen methodsFor: 'private' stamp: 'ar 5/17/2001 21:03'!
findAnyDisplayDepthIfNone: aBlock
	"Return any display depth that is supported on this system.
	If there is none, evaluate aBlock."
	#(1 2 4 8 16 32 -1 -2 -4 -8 -16 -32) do:[:bpp|
		(self supportsDisplayDepth: bpp) ifTrue:[^bpp].
	].
	^aBlock value! !

!DisplayScreen methodsFor: 'private' stamp: 'ar 5/17/2001 15:44'!
newDepthNoRestore: pixelSize
	"Change depths.  Check if there is enough space!!  , di"
	| area need |
	pixelSize = depth ifTrue: [^ self  "no change"].
	pixelSize abs < self depth ifFalse:
		["Make sure there is enough space"
		area _ Display boundingBox area. "pixels"
		Smalltalk isMorphic ifFalse:
			[ScheduledControllers scheduledWindowControllers do:
				[:aController | "This should be refined..."
				aController view cacheBitsAsTwoTone ifFalse:
					[area _ area + aController view windowBox area]]].
		need _ (area * (pixelSize abs - self depth) // 8)  "new bytes needed"
				+ Smalltalk lowSpaceThreshold.
		(Smalltalk garbageCollectMost <= need
			and: [Smalltalk garbageCollect <= need])
			ifTrue: [self error: 'Insufficient free space']].
	self setExtent: self extent depth: pixelSize.
	Smalltalk isMorphic ifFalse: [ScheduledControllers updateGray].
	DisplayScreen startUp! !

!DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:00'!
primRetryShowRectLeft: l right: r top: t bottom: b
	"Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. Do nothing if it fails. "

	<primitive: 127>
	"do nothing if primitive fails"
! !

!DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:02'!
primShowRectLeft: l right: r top: t bottom: b
	"Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. If this fails, retry integer coordinates."

	<primitive: 127>
	"if this fails, coerce coordinates to integers and try again"
	self primRetryShowRectLeft: l truncated
		right: r rounded
		top: t truncated
		bottom: b rounded.
! !

!DisplayScreen methodsFor: 'private' stamp: 'bf 5/16/2006 11:35'!
setExtent: aPoint depth: bitsPerPixel  "DisplayScreen startUp"
	"This method is critical.  If the setExtent fails, there will be no
	proper display on which to show the error condition..."
	"ar 5/1/1999: ... and that is exactly why we check for the available display depths first."

	"RAA 27 Nov 99 - if depth and extent are the same and acceptable, why go through this.
	also - record when we change so worlds can tell if it is time to repaint"

	(depth == bitsPerPixel and: [aPoint = self extent and: 
					[self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [
		bits _ nil.  "Free up old bitmap in case space is low"
		DisplayChangeSignature _ (DisplayChangeSignature ifNil: [0]) + 1.
		(self supportsDisplayDepth: bitsPerPixel)
			ifTrue:[super setExtent: aPoint depth: bitsPerPixel]
			ifFalse:[(self supportsDisplayDepth: bitsPerPixel negated)
				ifTrue:[super setExtent: aPoint depth: bitsPerPixel negated]
				ifFalse:["Search for a suitable depth"
					super setExtent: aPoint depth: self findAnyDisplayDepth]].
	].
	clippingBox _ super boundingBox! !

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

DisplayScreen class
	instanceVariableNames: ''!

!DisplayScreen class methodsFor: 'display box access'!
boundingBox
	"Answer the bounding box for the form representing the current display 
	screen."

	^Display boundingBox! !

!DisplayScreen class methodsFor: 'display box access' stamp: 'sw 10/31/2001 07:18'!
checkForNewScreenSize
	"Check whether the screen size has changed and if so take appropriate actions"

	Display extent = DisplayScreen actualScreenSize ifTrue: [^ self].
	DisplayScreen startUp.
	Smalltalk isMorphic
		ifTrue:
			[World restoreMorphicDisplay.
			World repositionFlapsAfterScreenSizeChange]
		ifFalse:
			[ScheduledControllers restore; searchForActiveController]! !

!DisplayScreen class methodsFor: 'display box access' stamp: 'sma 4/28/2000 19:07'!
depth: depthInteger width: widthInteger height: heightInteger fullscreen: aBoolean
	"Force Squeak's window (if there's one) into a new size and depth."
	"DisplayScreen depth: 8 width: 1024 height: 768 fullscreen: false"

	<primitive: 92>
	self primitiveFail! !


!DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 2/5/2001 17:24'!
actualScreenDepth
	<primitive: 'primitiveScreenDepth'>
	^ Display depth! !

!DisplayScreen class methodsFor: 'snapshots'!
actualScreenSize
	<primitive: 106>
	^ 640@480! !

!DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/28/2000 11:26'!
shutDown 
	"Minimize Display memory saved in image"
	Display shutDown.! !

!DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/17/2001 15:50'!
startUp  "DisplayScreen startUp"
	Display setExtent: self actualScreenSize depth: Display nativeDepth.
	Display beDisplay! !
DisplayObject subclass: #DisplayText
	instanceVariableNames: 'text textStyle offset form foreColor backColor'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Display Objects'!
!DisplayText commentStamp: '<historical>' prior: 0!
I represent Text whose emphasis changes are mapped to a set of fonts. My instances have an offset used in determining screen placement for displaying. They get used two different ways in the system. In the user interface, they mainly hold onto some text which is viewed by some form of ParagraphEditor. However, as a DisplayObject, they may need to display efficiently, so my instances have a cache for the bits.!


!DisplayText methodsFor: 'accessing'!
alignedTo: alignPointSelector
	"Return a copy with offset according to alignPointSelector which is one of...
	#(topLeft, topCenter, topRight, leftCenter, center, etc)"
	| boundingBox |
	boundingBox _ 0@0 corner: self form extent.
	^ self shallowCopy offset: (0@0) - (boundingBox perform: alignPointSelector)! !

!DisplayText methodsFor: 'accessing'!
fontsUsed
	"Return a list of all fonts used currently in this text.  8/19/96 tk"

	^ text runs values asSet collect: [:each | textStyle fontAt: each]! !

!DisplayText methodsFor: 'accessing'!
form 
	"Answer the form into which the receiver's display bits are cached."

	form == nil ifTrue: [self composeForm].
	^form! !

!DisplayText methodsFor: 'accessing'!
lineGrid
	"Answer the relative space between lines of the receiver's text."

	^textStyle lineGrid! !

!DisplayText methodsFor: 'accessing'!
numberOfLines 
	"Answer the number of lines of text in the receiver."

	^self height // text lineGrid! !

!DisplayText methodsFor: 'accessing'!
offset 
	"Refer to the comment in DisplayObject|offset."

	^offset! !

!DisplayText methodsFor: 'accessing'!
offset: aPoint 
	"Refer to the comment in DisplayObject|offset:."

	offset _ aPoint! !

!DisplayText methodsFor: 'accessing'!
string
	"Answer the string of the characters displayed by the receiver."

	^text string! !

!DisplayText methodsFor: 'accessing'!
text 
	"Answer the text displayed by the receiver."

	^text! !

!DisplayText methodsFor: 'accessing'!
text: aText 
	"Set the receiver to display the argument, aText."
	
	text _ aText.
	form _ nil.
	self changed.
	! !

!DisplayText methodsFor: 'accessing'!
textStyle 
	"Answer the style by which the receiver displays its text."

	^textStyle! !

!DisplayText methodsFor: 'accessing'!
textStyle: aTextStyle 
	"Set the style by which the receiver should display its text."

	textStyle _ aTextStyle.
	form _ nil.
	self changed.
	! !


!DisplayText methodsFor: 'color'!
backgroundColor
	backColor == nil ifTrue: [^ Color transparent].
	^ backColor! !

!DisplayText methodsFor: 'color'!
foregroundColor
	foreColor == nil ifTrue: [^ Color black].
	^ foreColor! !

!DisplayText methodsFor: 'color'!
foregroundColor: cf backgroundColor: cb
	foreColor _ cf.
	backColor _ cb! !


!DisplayText methodsFor: 'converting' stamp: 'tk 10/21/97 12:28'!
asParagraph
	"Answer a Paragraph whose text and style are identical to that of the 
	receiver."
	| para |
	para _ Paragraph withText: text style: textStyle.
	para foregroundColor: foreColor backgroundColor: backColor.
	backColor isTransparent ifTrue: [para rule: Form paint].
	^ para! !


!DisplayText methodsFor: 'display box access'!
boundingBox 
	"Refer to the comment in DisplayObject|boundingBox."

	^self form boundingBox! !

!DisplayText methodsFor: 'display box access'!
computeBoundingBox 
	"Compute minimum enclosing rectangle around characters."

	| character font width carriageReturn lineWidth lineHeight |
	carriageReturn _ Character cr.
	width _ lineWidth _ 0.
	font _ textStyle defaultFont.
	lineHeight _ textStyle lineGrid.
	1 to: text size do: 
		[:i | 
		character _ text at: i.
		character = carriageReturn
		  ifTrue: 
			[lineWidth _ lineWidth max: width.
			lineHeight _ lineHeight + textStyle lineGrid.
			width _ 0]
		  ifFalse: [width _ width + (font widthOf: character)]].
	lineWidth _ lineWidth max: width.
	^offset extent: lineWidth @ lineHeight! !


!DisplayText methodsFor: 'displaying' stamp: 'yo 6/23/2003 20:05'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"For TT font, rule 34 is used if possible."
	"Refer to the comment in 
	DisplayObject|displayOn:at:clippingBox:rule:mask:."

	| form1 rule |
	form1 _ self form.
	rule _ (ruleInteger = Form over and: [backColor isTransparent])
				ifTrue: [form1 depth = 32 ifTrue: [rule _ 34] ifFalse: [Form paint]]
				ifFalse: [ruleInteger].
	form1 depth = 32 ifTrue: [rule _ 34].
	form1
		displayOn: aDisplayMedium
		at: aDisplayPoint + offset
		clippingBox: clipRectangle
		rule: rule
		fillColor: aForm! !

!DisplayText methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayObject|displayOn:transformation:clippingBox:align:with:rule:mask:."

	| absolutePoint |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	absolutePoint _ absolutePoint x asInteger @ absolutePoint y asInteger.
	self displayOn: aDisplayMedium
		at: absolutePoint - alignmentPoint
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm! !

!DisplayText methodsFor: 'displaying'!
displayOnPort: aPort at: location
	self form displayOnPort: aPort at: location + offset! !


!DisplayText methodsFor: 'private' stamp: 'nk 6/25/2003 12:51'!
composeForm
	"For the TT strings in MVC widgets in a Morphic world such as a progress bar, the form is created by Morphic machinery."
	| canvas tmpText |
	Smalltalk isMorphic
		ifTrue:
			[tmpText _ TextMorph new contentsAsIs: text deepCopy.
			foreColor ifNotNil: [tmpText text addAttribute: (TextColor color: foreColor)].
			backColor ifNotNil: [tmpText backgroundColor: backColor].
			tmpText setTextStyle: textStyle.
			canvas _ FormCanvas on: (Form extent: tmpText extent depth: 32).
			tmpText drawOn: canvas.
			form _ canvas form.
		]
		ifFalse: [form _ self asParagraph asForm]! !

!DisplayText methodsFor: 'private'!
setText: aText textStyle: aTextStyle offset: aPoint

	text _ aText.
	textStyle _ aTextStyle.
	offset _ aPoint.
	form _ nil! !

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

DisplayText class
	instanceVariableNames: ''!

!DisplayText class methodsFor: 'examples' stamp: 'tk 11/28/2001 16:03'!
example
	"Continually prints two lines of text wherever you point with the cursor.  Terminate by pressing any button on the
	mouse."
	| tx |
	tx _ 'this is a line of characters and
this is the second line.' asDisplayText.
	tx foregroundColor: Color black backgroundColor: Color transparent.
	tx _ tx alignedTo: #center.
	[Sensor anyButtonPressed]
		whileFalse:
			[tx displayOn: Display at: Sensor cursorPoint]

	"DisplayText example."! !


!DisplayText class methodsFor: 'instance creation'!
text: aText 
	"Answer an instance of me such that the text displayed is aText 
	according to the system's default text style."

	^self new
		setText: aText
		textStyle: DefaultTextStyle copy
		offset: 0 @ 0! !

!DisplayText class methodsFor: 'instance creation'!
text: aText textStyle: aTextStyle 
	"Answer an instance of me such that the text displayed is aText 
	according to the style specified by aTextStyle."

	^self new
		setText: aText
		textStyle: aTextStyle
		offset: 0 @ 0! !

!DisplayText class methodsFor: 'instance creation'!
text: aText textStyle: aTextStyle offset: aPoint 
	"Answer an instance of me such that the text displayed is aText 
	according to the style specified by aTextStyle. The display of the 
	information should be offset by the amount given as the argument, 
	aPoint."

	^self new
		setText: aText
		textStyle: aTextStyle
		offset: aPoint! !
View subclass: #DisplayTextView
	instanceVariableNames: 'rule mask editParagraph centered'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Views'!
!DisplayTextView commentStamp: '<historical>' prior: 0!
I represent a view of an instance of DisplayText.!


!DisplayTextView methodsFor: 'accessing'!
centered

	centered _ true.
	self centerText! !

!DisplayTextView methodsFor: 'accessing'!
fillColor
	"Answer an instance of class Form that is to be used as the mask when 
	displaying the receiver's model (a DisplayText)."

	^ mask! !

!DisplayTextView methodsFor: 'accessing'!
fillColor: aForm 
	"Set aForm to be the mask used when displaying the receiver's model."

	mask _ aForm! !

!DisplayTextView methodsFor: 'accessing'!
isCentered

	^centered! !

!DisplayTextView methodsFor: 'accessing'!
mask
	"Answer an instance of class Form that is to be used as the mask when 
	displaying the receiver's model (a DisplayText)."

	^ mask! !

!DisplayTextView methodsFor: 'accessing'!
rule
	"Answer a number from 0 to 15 that indicates which of the sixteen 
	display rules is to be used when copying the receiver's model (a 
	DisplayText) onto the display screen."

	rule == nil
		ifTrue: [^self defaultRule]
		ifFalse: [^rule]! !

!DisplayTextView methodsFor: 'accessing'!
rule: anInteger 
	"Set anInteger to be the rule used when displaying the receiver's model."

	rule _ anInteger! !


!DisplayTextView methodsFor: 'controller access'!
defaultController 
	"Refer to the comment in View|defaultController."

	^self defaultControllerClass newParagraph: editParagraph! !

!DisplayTextView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^ParagraphEditor! !


!DisplayTextView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."

	(self controller isKindOf: ParagraphEditor)
	 	ifTrue: [controller deselect]! !


!DisplayTextView methodsFor: 'displaying'!
display 
	"Refer to the comment in View|display."

	self isUnlocked ifTrue: [self positionText].
	super display! !

!DisplayTextView methodsFor: 'displaying'!
displayView 
	"Refer to the comment in View|displayView."

	self clearInside.
	(self controller isKindOf: ParagraphEditor )
		ifTrue: [controller changeParagraph: editParagraph].
	editParagraph foregroundColor: self foregroundColor
				backgroundColor: self backgroundColor.
	self isCentered
		ifTrue: 
			[editParagraph displayOn: Display
				transformation: self displayTransformation
				clippingBox: self insetDisplayBox
				fixedPoint: editParagraph boundingBox center]
		ifFalse: 
			[editParagraph displayOn: Display]! !

!DisplayTextView methodsFor: 'displaying'!
uncacheBits
	"Normally only sent to a StandardSystemView, but for casees where a DisplayTextView is used alone, without a superview, in which we make this a no-op, put in so that the Character Recognizer doesn't fail.  8/9/96 sw"! !


!DisplayTextView methodsFor: 'initialize-release'!
initialize 
	"Refer to the comment in View|initialize."

	super initialize.
	centered _ false! !


!DisplayTextView methodsFor: 'lock access'!
lock 
	"Refer to the comment in View|lock.  Must do what would be done by displaying..."

	self isUnlocked ifTrue: [self positionText].
	super lock! !


!DisplayTextView methodsFor: 'model access'!
model: aDisplayText 
	"Refer to the comment in View|model:."

	super model: aDisplayText.
	editParagraph _ model asParagraph.
	self centerText! !


!DisplayTextView methodsFor: 'window access'!
defaultWindow 
	"Refer to the comment in View|defaultWindow."

	^self inverseDisplayTransform: (editParagraph boundingBox expandBy: 6 @ 6)! !

!DisplayTextView methodsFor: 'window access'!
window: aWindow 
	"Refer to the comment in View|window:."

	super window: aWindow.
	self centerText! !


!DisplayTextView methodsFor: 'private'!
centerText

	self isCentered
		ifTrue: 
			[editParagraph
				align: editParagraph boundingBox center
				with: self getWindow center]! !

!DisplayTextView methodsFor: 'private'!
defaultRule

	^Form over! !

!DisplayTextView methodsFor: 'private'!
positionText

	| box |
	box _ (self displayBox insetBy: 6@6) origin extent: editParagraph boundingBox extent.
	editParagraph wrappingBox: box clippingBox: box.
	self centerText! !

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

DisplayTextView class
	instanceVariableNames: ''!

!DisplayTextView class methodsFor: 'examples'!
example2	
	"Create a standarad system view with two parts, one editable, the other not."
	| topView aDisplayTextView |
	topView _ StandardSystemView new.
	topView label: 'Text Editor'.
	aDisplayTextView _ self new model: 'test string label' asDisplayText.
	aDisplayTextView controller: NoController new.
	aDisplayTextView window: (0 @ 0 extent: 100 @ 100).
	aDisplayTextView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	topView addSubView: aDisplayTextView.

	aDisplayTextView _ self new model: 'test string' asDisplayText.
	aDisplayTextView window: (0 @ 0 extent: 100 @ 100).
	aDisplayTextView borderWidth: 2.
	topView
		addSubView: aDisplayTextView
		align: aDisplayTextView viewport topLeft
		with: topView lastSubView viewport topRight.
	topView controller open

	"DisplayTextView example2"! !

!DisplayTextView class methodsFor: 'examples'!
example3	
	"Create a passive view of some text on the screen."
	| view |
	view_ self new model: 'this is a test of one line
and the second line' asDisplayText.
	view translateBy: 100@100.	
	view borderWidth: 2.
	view display.
	view release

	"DisplayTextView example3"! !

!DisplayTextView class methodsFor: 'examples'!
example4	
	"Create four passive views of some text on the screen with fat borders."
	| view |
	view_ self new model: 'this is a test of one line
and the second line' asDisplayText.
	view translateBy: 100@100.	
	view borderWidth: 5.
	view display.
	3 timesRepeat: [view translateBy: 100@100. view display].
	view release

	"DisplayTextView example4"! !
Object subclass: #DisplayTransform
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Transformations'!
!DisplayTransform commentStamp: '<historical>' prior: 0!
This class represents a base for generic transformations of 2D points between different coordinate systems (including scaling and rotation). The transformations map objects between one coordinate system and another where it is assumed that a nested hierarchy of transformations can be defined.

It is assumed that transformations deal with Integer points. All transformations should return Integer coordinates (even though float points may be passed in as argument).

Compositions of transformations MUST work in the following order. A 'global' transformation (the argument in #composedWithGlobal:) is defined as a transformation that takes place between the receiver (the 'local') transformation and any 'global' point computations, whereas a 'local' transformation (e.g., the argument in #composedWithLocal:) takes place between the receiver ('global') and any 'local' points. For the transformation methods this means that combining a global and a local transformation will result in the following order:

		globalPointToLocal: globalPoint
			"globalPoint -> globalTransform -> localTransform -> locaPoint"
			^localTransform globalPointToLocal:
				(globalTransform globalPointToLocal: globalPoint)

		localPointToGlobal: localPoint
			"localPoint -> localTransform -> globalTransform -> globalPoint"
			^globalTransform localPointToGlobal:
				(localTransform localPointToGlobal: localPoint)

!


!DisplayTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:43'!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self subclassResponsibility! !


!DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:15'!
composedWithGlobal: aTransformation
	"Return the composition of the receiver and the global transformation passed in.
	A 'global' transformation is defined as a transformation that takes place
	between the receiver (the 'local') transformation and any 'global' point
	computations, e.g., for the methods

		globalPointToLocal: globalPoint
			globalPoint -> globalTransform -> localTransform -> locaPoint

		localPointToGlobal: localPoint
			localPoint -> localTransform -> globalTransform -> globalPoint

		"
	^aTransformation composedWithLocal: self! !

!DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:41'!
composedWithLocal: aTransformation
	"Return the composition of the receiver and the local transformation passed in.
	A 'local' transformation is defined as a transformation that takes place
	between the receiver (the 'global') transformation and any 'local' point
	computations, e.g., for the methods

		globalPointToLocal: globalPoint
			globalPoint -> globalTransform -> localTransform -> locaPoint

		localPointToGlobal: localPoint
			localPoint -> localTransform -> globalTransform -> globalPoint

		"
	self isIdentity ifTrue:[^ aTransformation].
	aTransformation isIdentity ifTrue:[^ self].
	^ CompositeTransform new globalTransform: self
							localTransform: aTransformation! !


!DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:59'!
asCompositeTransform
	"Represent the receiver as a composite transformation"
	^CompositeTransform new
		globalTransform: self
		localTransform: self species identity! !

!DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:01'!
asMatrixTransform2x3
	"Represent the receiver as a 2x3 matrix transformation"
	^self subclassResponsibility! !


!DisplayTransform methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:18'!
setIdentity
	"Initialize the receiver to the identity transformation (e.g., not affecting points)"
	^self subclassResponsibility! !


!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:47'!
isCompositeTransform
	"Return true if the receiver is a composite transformation.
	Composite transformations may have impact on the accuracy."
	^false! !

!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:17'!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'!
isMatrixTransform2x3
	"Return true if the receiver is 2x3 matrix transformation"
	^false! !

!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'!
isMorphicTransform
	"Return true if the receiver is a MorphicTransform, that is specifies the transformation values explicitly."
	^false! !

!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:16'!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	^self subclassResponsibility! !


!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:17'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'!
globalPointsToLocal: inArray
	"Transform all the points of inArray from global into local coordinates"
	^inArray collect:[:pt| self globalPointToLocal: pt]! !

!DisplayTransform methodsFor: 'transforming points' stamp: 'gh 10/22/2001 13:24'!
invertBoundsRect: aRectangle
	"Return a rectangle whose coordinates have been transformed
	from local back to global coordinates."

	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:18'!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'!
localPointsToGlobal: inArray
	"Transform all the points of inArray from local into global coordinates"
	^inArray collect:[:pt| self localPointToGlobal: pt]! !


!DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^Rectangle encompassing: (self globalPointsToLocal: aRectangle corners)! !

!DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^Rectangle encompassing: (self localPointsToGlobal: aRectangle corners)! !

!DisplayTransform methodsFor: 'transforming rects' stamp: 'di 10/25/1999 12:49'!
sourceQuadFor: aRectangle
	^ aRectangle innerCorners collect: 
		[:p | self globalPointToLocal: p]! !


!DisplayTransform methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ls 10/9/1999 18:56'!
encodeForRemoteCanvas
	"encode this transform into a string for use by a RemoteCanvas"
	^self subclassResponsibility! !

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

DisplayTransform class
	instanceVariableNames: ''!

!DisplayTransform class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 20:55'!
identity
	^self new setIdentity! !


!DisplayTransform class methodsFor: '*nebraska-instance creation' stamp: 'sd 11/20/2005 21:25'!
fromRemoteCanvasEncoding: encoded
	| type |
	"decode a transform from the given encoded string"
	type := (ReadStream on: encoded) upTo: $,.
	type = 'Morphic' ifTrue: [
		^MorphicTransform fromRemoteCanvasEncoding: encoded ].
	type = 'Matrix' ifTrue: [
		^MatrixTransform2x3 fromRemoteCanvasEncoding: encoded ].
	type = 'Composite' ifTrue: [
		^CompositeTransform fromRemoteCanvasEncoding: encoded ].
	^self error: 'invalid transform encoding'! !
BorderedMorph subclass: #DoCommandOnceMorph
	instanceVariableNames: 'target command actionBlock innerArea'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!DoCommandOnceMorph commentStamp: '<historical>' prior: 0!
I am used to execute a once-only command. My first use was in loading/saving the current project. In such cases it is necessary to be in another project to do the actual work. So an instance of me is added to a new world/project and that project is entered. I do my stuff (save/load followed by a re-enter of the previous project) and everyone is happy.!


!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 11:49'!
actionBlock: aBlock

	actionBlock _ aBlock! !

!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 17:30'!
addText: aString

	| t |
	t _ TextMorph new 
		beAllFont: (TextStyle default fontOfSize: 26);
		contents: aString.
	self extent: t extent * 3.
	innerArea _ Morph new 
		color: Color white; 
		extent: self extent - (16@16);
		position: self position + (8@8);
		lock.
	self addMorph: innerArea. 
	self addMorph: (t position: self position + t extent; lock).! !


!DoCommandOnceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color blue! !

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

!DoCommandOnceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:08'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self useRoundedCorners! !

!DoCommandOnceMorph methodsFor: 'initialization' stamp: 'RAA 7/7/2000 12:19'!
openInWorld: aWorld

	self position: aWorld topLeft + (aWorld extent - self extent // 2).
	super openInWorld: aWorld! !


!DoCommandOnceMorph methodsFor: 'stepping and presenter' stamp: 'RAA 7/29/2000 17:30'!
step

	| goForIt |

	actionBlock ifNil: [^self stopStepping].
	goForIt _ actionBlock.
	actionBlock _ nil.
	[
		goForIt value.
	]
		on: ProgressTargetRequestNotification
		do: [ :ex | ex resume: innerArea].		"in case a save/load progress display needs a home"
! !


!DoCommandOnceMorph methodsFor: 'testing' stamp: 'RAA 7/7/2000 11:46'!
stepTime

	^1
! !

!DoCommandOnceMorph methodsFor: 'testing' stamp: 'RAA 7/7/2000 11:50'!
wantsSteps

	^actionBlock notNil
! !
AbstractEvent subclass: #DoItEvent
	instanceVariableNames: 'context'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!DoItEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 11:29'!
context

	^context! !


!DoItEvent methodsFor: 'printing' stamp: 'rw 7/14/2003 10:15'!
printEventKindOn: aStream

	aStream nextPutAll: 'DoIt'! !


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

	^true! !


!DoItEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 11:29'!
context: aContext

	context := aContext! !

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

DoItEvent class
	instanceVariableNames: ''!

!DoItEvent class methodsFor: 'accessing' stamp: 'rw 7/14/2003 10:19'!
changeKind

	^#DoIt! !

!DoItEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:23'!
supportedKinds
	^ Array with: self expressionKind! !


!DoItEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 09:47'!
expression: stringOrStream context: aContext
	| instance |
	instance := self item: stringOrStream kind: AbstractEvent expressionKind.
	instance context: aContext.
	^instance! !
AlignmentMorph subclass: #DockingBarMorph
	instanceVariableNames: 'originalColor gradientRamp fillsOwner avoidVisibleBordersAtEdge autoGradient selectedItem activeSubMenu'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!

!DockingBarMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 9/7/2004 14:47'!
aboutToBeGrabbedBy: aHand 
	"The morph is about to be grabbed, make it float"
	self beFloating.
	self updateBounds.
	self updateColor.
	(self bounds containsPoint: aHand position)
		ifFalse: [self center: aHand position].
self owner restoreFlapsDisplay! !

!DockingBarMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 8/31/2004 14:37'!
justDroppedInto: aMorph event: anEvent 
	| ownerBounds leftRegion droppedPosition rightRegion topRegion bottomRegion |
	super justDroppedInto: aMorph event: anEvent.
	""
	self owner isNil
		ifTrue: [^ self].
	""
	ownerBounds := aMorph bounds.
	topRegion := ownerBounds bottom: ownerBounds top + (ownerBounds height // 5).
	bottomRegion := ownerBounds top: ownerBounds bottom - (ownerBounds height // 5).
	""
	leftRegion := ownerBounds right: ownerBounds left + (ownerBounds width // 5).
	leftRegion := leftRegion top: topRegion bottom.
	leftRegion := leftRegion bottom: bottomRegion top.
	""
	rightRegion := ownerBounds left: ownerBounds right - (ownerBounds width // 5).
	rightRegion := rightRegion top: topRegion bottom.
	rightRegion := rightRegion bottom: bottomRegion top.
	""
	droppedPosition := anEvent position.
	(topRegion containsPoint: droppedPosition)
		ifTrue: [
			^ self adhereToTop].
	(bottomRegion containsPoint: droppedPosition)
		ifTrue: [
			^ self adhereToBottom].
	(leftRegion containsPoint: droppedPosition)
		ifTrue: [
			^ self adhereToLeft].
	(rightRegion containsPoint: droppedPosition)
		ifTrue: [
			^ self adhereToRight].
	""
	self beFloating! !


!DockingBarMorph methodsFor: 'events' stamp: 'dgd 9/1/2004 19:29'!
activate: evt 
	"Receiver should be activated; e.g., so that control passes  
	correctly."
	evt hand newMouseFocus: self! !


!DockingBarMorph methodsFor: 'control' stamp: 'dgd 9/9/2004 21:48'!
activeSubmenu: aSubmenu 
	activeSubMenu isNil
		ifFalse: [activeSubMenu delete].
	activeSubMenu := aSubmenu.
	aSubmenu isNil
		ifTrue: [^ self].
	""
	activeSubMenu selectItem: nil event: nil.
	MenuIcons decorateMenu: activeSubMenu.
	activeSubMenu activatedFromDockingBar: self.
	activeSubMenu borderColor: self borderColor.
	activeSubMenu beSticky.
	activeSubMenu resistsRemoval: true.
activeSubMenu removeMatchString.! !

!DockingBarMorph methodsFor: 'control' stamp: 'dgd 9/1/2004 16:48'!
deleteIfPopUp: evt 
	evt
		ifNotNil: [evt hand releaseMouseFocus: self]! !

!DockingBarMorph methodsFor: 'control' stamp: 'dgd 9/1/2004 16:40'!
selectItem: aMenuItem event: anEvent 
	selectedItem
		ifNotNil: [selectedItem deselect: anEvent].
	selectedItem := aMenuItem.
	selectedItem
		ifNotNil: [selectedItem select: anEvent]! !


!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 19:59'!
addBlankIconsIfNecessary: anIcon 
	"If any of my items have an icon, ensure that all do by using 
	anIcon for those that don't"
	self items
		reject: [:each | each hasIconOrMarker]
		thenDo: [:each | each icon: anIcon]! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'!
adhereToBottom
	"Instract the receiver to adhere to bottom"
	 self adhereTo:#bottom! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'!
adhereToLeft
	"Instract the receiver to adhere to left"
	self adhereTo: #left! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'!
adhereToRight
	"Instract the receiver to adhere to right"
	self adhereTo: #right! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'!
adhereToTop
	"Instract the receiver to adhere to top"
	self adhereTo: #top! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 14:28'!
autoGradient
	"Answer if the receiver is in autoGradient mode"
	^ autoGradient! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 14:28'!
autoGradient: aBoolean 
	"Instruct the receiver to fill the owner or not"
	autoGradient := aBoolean.
	self updateColor! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:38'!
avoidVisibleBordersAtEdge
"Answer if the receiver is in avoidVisibleBordersAtEdge mode"
	^ avoidVisibleBordersAtEdge! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:57'!
avoidVisibleBordersAtEdge: aBoolean 
	"Instruct the receiver to avoid showing the borders at edge"
	avoidVisibleBordersAtEdge := aBoolean.
self updateLayoutProperties.! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:02'!
beFloating
	"Instract the receiver to be floating"
	self adhereTo: #none! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 11/2/2004 12:00'!
color: aColor 
	"Set the receiver's color."
	super color: aColor.
	originalColor := aColor asColor.
""
self updateColor! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:35'!
fillsOwner
	"Answer if the receiver is in fillOwner mode"
	^ fillsOwner! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:57'!
fillsOwner: aBoolean 
	"Instruct the receiver to fill the owner or not"
	fillsOwner := aBoolean.
self updateLayoutProperties! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'!
isAdheringToBottom
	"Answer true if the receiver is adhering to bottom"
	^ self edgeToAdhereTo == #bottom! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'!
isAdheringToLeft
	"Answer true if the receiver is adhering to left"
	^ self edgeToAdhereTo == #left! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'!
isAdheringToRight
	"Answer true if the receiver is adhering to right"
	^ self edgeToAdhereTo == #right! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'!
isAdheringToTop
	"Answer true if the receiver is adhering to top"
	^ self edgeToAdhereTo == #top! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/30/2004 23:13'!
isFloating
	"Answer true if the receiver has a float layout"
	^ self isHorizontal not
		and: [self isVertical not]! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:58'!
isHorizontal
	"Answer true if the receiver has a horizontal layout"
	^ self isAdheringToTop
		or: [self isAdheringToBottom]! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 21:23'!
isSticky
	"answer whether the receiver is Sticky"
	^ Preferences noviceMode
		or: [super isSticky] ! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:58'!
isVertical
	"Answer true if the receiver has a vertical layout"
	^ self isAdheringToLeft
		or: [self isAdheringToRight]
! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/2/2004 11:01'!
resistsRemoval
"Answer whether the receiver is marked as resisting removal"
	^ Preferences noviceMode
		or: [super resistsRemoval]! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/9/2004 19:45'!
rootMenu
	^ self! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 16:39'!
stayUp
	^ false! !

!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 16:33'!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in 
	its owner"
	^ true! !


!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:31'!
addCustomMenuItems: aMenu hand: aHandMorph 
	"Populate aMenu with appropriate menu items for a  
	yellow-button (context menu) click."
	super addCustomMenuItems: aMenu hand: aHandMorph.
	""
	aMenu addLine.
	aMenu addUpdating: #autoGradientString action: #toggleAutoGradient.
	self isFloating
		ifFalse: [""
			aMenu addUpdating: #fillsOwnerString action: #toggleFillsOwner.
			aMenu addUpdating: #avoidVisibleBordersAtEdgeString action: #toggleAvoidVisibleBordersAtEdge]! !

!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:25'!
autoGradientString
	"Answer the string to be shown in a menu to represent the  
	'resistsRemoval' status"
	^ (self autoGradient
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'auto gradient' translated! !

!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:25'!
avoidVisibleBordersAtEdgeString
	"Answer the string to be shown in a menu to represent the  
	'resistsRemoval' status"
	^ (self avoidVisibleBordersAtEdge
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'avoid visible borders at edge' translated! !

!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:23'!
fillsOwnerString
	"Answer the string to be shown in a menu to represent the  
	'resistsRemoval' status"
	^ (self fillsOwner
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'fills owner' translated
! !

!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:27'!
toggleAutoGradient
	self autoGradient: self autoGradient not! !

!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:26'!
toggleAvoidVisibleBordersAtEdge
	self avoidVisibleBordersAtEdge: self avoidVisibleBordersAtEdge not! !

!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:24'!
toggleFillsOwner
	self fillsOwner: self fillsOwner not! !

!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:28'!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	^ Preferences noviceMode not! !


!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 7/28/2005 12:08'!
addDefaultSpace
	"Add a new space of the given size to the receiver."
	^ self addSpace: (Preferences tinyDisplay ifFalse:[10] ifTrue:[3])! !

!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/1/2004 19:10'!
addLine
	"Append a divider line to this menu. Suppress duplicate lines."

	submorphs isEmpty ifTrue: [^ self].
	(self lastSubmorph isKindOf: MenuLineMorph)
		ifFalse: [self addMorphBack: MenuLineMorph new].
! !

!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 8/31/2004 11:34'!
addSpacer
	"Add a new spacer to the receiver. 
	 
	Spacer are objects that try to use as much space as they can"
	self
		addMorphBack: (AlignmentMorph newSpacer: Color transparent)! !

!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 8/31/2004 11:34'!
addSpace: sizePointOrNumber 
	"Add a new space of the given size to the receiver."
	| space |
	space := RectangleMorph new.
	space extent: sizePointOrNumber asPoint.
	space color: Color transparent.
	space borderWidth: 0.
	self addMorphBack: space! !

!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/10/2004 16:48'!
add: wordingString icon: aForm help: helpString subMenu: aMenuMorph 
	"Append the given submenu with the given label."
	| item |
	item := MenuItemMorph new.
	item contents: wordingString.
	item subMenu: aMenuMorph.
	item icon: aForm.
	helpString isNil
		ifFalse: [item setBalloonText: helpString].
	self addMorphBack: item! !

!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/10/2004 16:48'!
add: wordingString icon: aForm subMenu: aMenuMorph 
	"Append the given submenu with the given label."
^ self add: wordingString icon: aForm help: nil subMenu: aMenuMorph ! !

!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/1/2004 19:08'!
add: aString subMenu: aMenuMorph 
	"Append the given submenu with the given label."
	self add: aString icon: nil subMenu: aMenuMorph ! !


!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 8/31/2004 14:35'!
adhereTo: edgeSymbol 
	"Private - Instruct the receiver to adhere to the given edge.  
	 
	Options: #left #top #right #bottom or #none"
	""
	(#(#left #top #right #bottom #none ) includes: edgeSymbol)
		ifFalse: [^ self error: 'invalid option'].
	""
	self setToAdhereToEdge: edgeSymbol.
	self updateLayoutProperties.
	self updateColor! !

!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 8/31/2004 13:56'!
edgeToAdhereTo
	"private - answer the edge where the receiver is adhering to"
	^ self
		valueOfProperty: #edgeToAdhereTo
		ifAbsent: [#none]! !

!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 9/1/2004 15:19'!
predominantDockingBarsOfChastes: predominantChastes 
	"Private - Answer a collection of the docking bar of my owner  
	that are predominant to the receiver.  
	 
	By 'predominant' we mean docking bar that have the right to  
	get a position before the receiver.  
	 
	The predominance of individual living in the same chaste is  
	determinated by the arrival order.  
	"
	| allDockingBars byChaste byArrival |
	(self owner isNil
			or: [self owner isHandMorph])
		ifTrue: [^ #()].
	""
	allDockingBars := self owner dockingBars.
	""
	byChaste := allDockingBars
				select: [:each | predominantChastes includes: each edgeToAdhereTo].
	""
	(predominantChastes includes: self edgeToAdhereTo)
		ifFalse: [^ byChaste].
	""
	byChaste := byChaste
				reject: [:each | each edgeToAdhereTo = self edgeToAdhereTo].
	""
	byArrival := allDockingBars
				select: [:each | each edgeToAdhereTo = self edgeToAdhereTo].

	byArrival := byArrival copyAfter: self.
	""
	^ byChaste , byArrival! !

!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 9/1/2004 19:39'!
usedHeightByPredominantDockingBarsOfChastes: predominantChastes 
	"Private - convenience"
	| predominants |
	predominants := self predominantDockingBarsOfChastes: predominantChastes.
	^ predominants isEmpty
		ifTrue: [0]
		ifFalse: [(predominants
				collect: [:each | each height]) sum]! !

!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 9/1/2004 19:38'!
usedWidthByPredominantDockingBarsOfChastes: predominantChastes 
	"Private - convenience"
	| predominants |
	predominants := self predominantDockingBarsOfChastes: predominantChastes.
	^ predominants isEmpty
		ifTrue: [0]
		ifFalse: [(predominants
				collect: [:each | each width]) sum]! !


!DockingBarMorph methodsFor: 'meta-actions' stamp: 'dgd 9/1/2004 22:11'!
blueButtonDown: anEvent 
	"Special gestures (cmd-mouse on the Macintosh; Alt-mouse on  
	Windows and Unix) allow a mouse-sensitive morph to be  
	moved or bring up a halo for the morph."
	"In NoviceMode we don't want halos"
	
	Preferences noviceMode 
	ifFalse: [super blueButtonDown: anEvent]
	! !


!DockingBarMorph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/1/2004 19:26'!
delete
	activeSubMenu
		ifNotNil: [activeSubMenu delete].
	^ super delete! !


!DockingBarMorph methodsFor: 'geometry' stamp: 'dgd 8/31/2004 14:29'!
extent: aPoint 
	"change the receiver's extent"
	super extent: aPoint.
	self updateColor! !


!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 11:59'!
gradientRamp
	^ gradientRamp ifNil:[{0.0 -> originalColor muchLighter. 1.0 -> originalColor twiceDarker}]! !

!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 12:00'!
gradientRamp: colorRamp 
	gradientRamp := colorRamp.
""
self updateColor! !

!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 9/1/2004 15:29'!
updateBounds
	"private - update the receiver's bounds"
	self updateExtent.
	self isFloating
		ifFalse: [self updatePosition]! !

!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 11:55'!
updateColor
	"private - update the receiver's color"
	| fill |
	self autoGradient
		ifFalse: [^ self].
	""
	fill := GradientFillStyle ramp: self gradientRamp.
	""
	fill origin: self topLeft.
	self isVertical
		ifTrue: [fill direction: self width @ 0]
		ifFalse: [fill direction: 0 @ self height].
	""
	self fillStyle: fill! !

!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 9/1/2004 15:20'!
updateExtent
	"private - update the receiver's extent"
	| margin |
	self fullBounds.
	self fillsOwner
		ifFalse: [^ self].
	""
	margin := self avoidVisibleBordersAtEdge
				ifTrue: [self borderWidth * 2]
				ifFalse: [0].""
	self isHorizontal
		ifTrue: [self width: self owner width + margin].""
	self isVertical
		ifTrue: [| usedHeight | 
			usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top #bottom ).
			self height: self owner height + margin - usedHeight]! !

!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 8/31/2004 14:03'!
updateLayoutProperties
	"private - update the layout properties based on adhering,  
	fillsOwner and avoidVisibleBordersAtEdge preferencs"
	""
	(self isHorizontal
			or: [self isFloating])
		ifTrue: [self listDirection: #leftToRight]
		ifFalse: [self listDirection: #topToBottom].
	""
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self fillsOwner
		ifTrue: [""
			self isHorizontal
				ifTrue: [self hResizing: #spaceFill].
			self isVertical
				ifTrue: [self vResizing: #spaceFill]].
	! !

!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 9/1/2004 13:06'!
updatePosition
	"private - update the receiver's position"
	| edgeSymbol margin |
	edgeSymbol := self edgeToAdhereTo.
	self
		perform: (edgeSymbol , ':') asSymbol
		with: (self owner perform: edgeSymbol).
	""
	margin := self avoidVisibleBordersAtEdge
				ifTrue: [self borderWidth asPoint]
				ifFalse: [0 asPoint].
	""
	self isAdheringToTop
		ifTrue: [| usedHeight | 
			usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ).
			self topLeft: self owner topLeft - margin + (0 @ usedHeight)].
	self isAdheringToBottom
		ifTrue: [| usedHeight | 
			usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#bottom ).
			self bottomLeft: self owner bottomLeft + (-1 @ 1 * margin) - (0 @ usedHeight)].
	""
	self isAdheringToLeft
		ifTrue: [| usedHeight usedWidth | 
			usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ).
			usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#left ).
			self topLeft: self owner topLeft - margin + (usedWidth @ usedHeight)].
	self isAdheringToRight
		ifTrue: [| usedHeight usedWidth | 
			usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ).
			usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#right ).
			self topRight: self owner topRight + (1 @ -1 * margin) + (usedWidth negated @ usedHeight)]! !


!DockingBarMorph methodsFor: 'events-processing' stamp: 'dgd 9/9/2004 21:43'!
handleFocusEvent: evt
	"Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children."

	(evt isMouse and:[ evt isMouseUp ]) ifTrue:[^ self].

	self processEvent: evt.

	"Need to handle keyboard input if we have the focus."
	evt isKeyboard ifTrue: [^ self handleEvent: evt].

	"We need to handle button clicks outside and transitions to local popUps so throw away everything else"
	(evt isMouseOver or:[evt isMouse not]) ifTrue:[^self].
	"What remains are mouse buttons and moves"
	evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means"
	"Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first."
	selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]].
! !


!DockingBarMorph methodsFor: 'initialization' stamp: 'dgd 9/2/2004 11:03'!
initialize
	"initialize the receiver"
	super initialize.
	""
	selectedItem := nil.
	activeSubMenu := nil.
	fillsOwner := true.
	avoidVisibleBordersAtEdge := true.
	autoGradient := Preferences gradientMenu.
	""
	self setDefaultParameters.
	""
	self beFloating.
	""
	self layoutInset: 0.
	! !

!DockingBarMorph methodsFor: 'initialization' stamp: 'dgd 8/30/2004 22:17'!
setDefaultParameters
	"private - set the default parameter using Preferences as the inspiration source"
	| colorFromMenu worldColor menuColor menuBorderColor |
	colorFromMenu := Preferences menuColorFromWorld
				and: [Display depth > 4]
				and: [(worldColor := self currentWorld color) isColor].
	""
	menuColor := colorFromMenu
				ifTrue: [worldColor luminance > 0.7
						ifTrue: [worldColor mixed: 0.85 with: Color black]
						ifFalse: [worldColor mixed: 0.4 with: Color white]]
				ifFalse: [Preferences menuColor].
	""
	menuBorderColor := Preferences menuAppearance3d
				ifTrue: [#raised]
				ifFalse: [colorFromMenu
						ifTrue: [worldColor muchDarker]
						ifFalse: [Preferences menuBorderColor]].
	""
	self
		setColor: menuColor
		borderWidth: Preferences menuBorderWidth
		borderColor: menuBorderColor! !


!DockingBarMorph methodsFor: 'testing' stamp: 'dgd 8/31/2004 15:00'!
isDockingBar
	"Return true if the receiver is a docking bar"
	^ true! !


!DockingBarMorph methodsFor: 'WiW support' stamp: 'dgd 9/7/2004 19:25'!
morphicLayerNumber
	"helpful for insuring some morphs always appear in front of or 
	behind others. smaller numbers are in front"
	^ 11! !


!DockingBarMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/1/2004 18:41'!
noteNewOwner: aMorph 
	"I have just been added as a submorph of aMorph"
	super noteNewOwner: aMorph.

	self submorphs
		do: [:each | each adjustLayoutBounds].
! !


!DockingBarMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 15:29'!
ownerChanged
"The receiver's owner has changed its layout. "
	self updateBounds.
	^ super ownerChanged! !


!DockingBarMorph methodsFor: 'rounding' stamp: 'dgd 8/31/2004 14:16'!
roundedCorners
	"Return a list of those corners to round"
	self isAdheringToTop
		ifTrue: [^ #(2 3 )].
	self isAdheringToBottom
		ifTrue: [^ #(1 4 )].
	self isAdheringToLeft 
		ifTrue: [^ #(3 4 )].
	self isAdheringToRight
		ifTrue: [^ #(1 2 )].
	^ #(1 2 3 4 )! !


!DockingBarMorph methodsFor: 'private' stamp: 'dgd 9/9/2004 21:24'!
selectedItem
	selectedItem isNil
		ifTrue: [^ nil].
	^ selectedItem isSelected
		ifTrue: [ selectedItem]
		ifFalse: [ nil]! !


!DockingBarMorph methodsFor: 'menus' stamp: 'dgd 9/1/2004 15:29'!
snapToEdgeIfAppropriate
	(self owner isNil
			or: [self owner isHandMorph])
		ifTrue: [^ self].
	""
	self updateBounds! !

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

DockingBarMorph class
	instanceVariableNames: ''!

!DockingBarMorph class methodsFor: 'scripting' stamp: 'dgd 8/31/2004 14:26'!
defaultNameStemForInstances
	^ 'DockingBar'! !


!DockingBarMorph class methodsFor: 'samples' stamp: 'dgd 9/1/2004 19:52'!
example1
	" 
	DockingBarMorph example1.  
	 
	(Color lightBlue wheel: 4) do:[:c | DockingBarMorph example1 
	color: c; borderColor: c twiceDarker]. 
	 
	World deleteDockingBars.
	"
	| instance |
	instance := DockingBarMorph new.
	""
	instance addSpace: 10.
	instance
		addMorphBack: (ClockMorph new show24hr: true).
	instance addSpacer.
	instance
		addMorphBack: (ClockMorph new show24hr: true).
	instance addSpace: 10.
	""
	instance adhereToTop.
	""
	instance autoGradient: true.
	instance layoutInset: 10.
	""
	^ instance openInWorld! !

!DockingBarMorph class methodsFor: 'samples' stamp: 'dgd 9/22/2004 18:53'!
example2
	" 
	DockingBarMorph example2.  
	World deleteDockingBars.  
	"
	| menu |
	menu := DockingBarMorph new.
	""
	menu addSpace: 10.
	menu
		add: 'Squeak'
		icon: MenuIcons smallConfigurationIcon
		subMenu: self squeakMenu.
	menu
		add: 'Configuration'
		icon: MenuIcons smallWindowIcon
		subMenu: self squeakMenu.
	menu addSpace: 10.
	menu addLine.
	menu addSpace: 10.
	menu
		addMorphBack: (ImageMorph new image: MenuIcons smallBackIcon).
	menu addSpace: 10.
	menu
		addMorphBack: (ImageMorph new image: MenuIcons smallForwardIcon).
	menu addSpace: 10.
	menu addLine.
	menu addSpacer.
	""
	menu addMorphBack: ProjectNavigationMorph new speakerIcon.
	""
	menu addSpace: 10.
	menu
		addMorphBack: (ClockMorph new show24hr: true).
	menu addSpace: 10.
	""
	menu adhereToTop.
	""
	menu autoGradient: true.
	""
	^ menu openInWorld! !

!DockingBarMorph class methodsFor: 'samples' stamp: 'dgd 9/1/2004 19:55'!
example3
	" 
	DockingBarMorph example3. 
	World deleteDockingBars.
	"
	(Color lightBlue wheel: 4)
		with: #(#top #bottom #left #right )
		do: [:col :edge | 
			| instance | 
			instance := DockingBarMorph example1.
			instance adhereTo: edge.
			instance color: col.
			instance borderColor: col twiceDarker]! !

!DockingBarMorph class methodsFor: 'samples' stamp: 'dgd 9/1/2004 20:12'!
squeakMenu
	| menu |
	menu := MenuMorph new defaultTarget: self.
	menu
		add: 'Hello'
		target: self
		selector: #inform:
		argument: 'Hello World!!'.
	menu
		add: 'Long Hello'
		target: self
		selector: #inform:
		argument: 'Helloooo World!!'.
	menu
		add: 'A very long Hello'
		target: self
		selector: #inform:
		argument: 'Hellooooooooooooooo World!!'.
	menu
		add: 'An incredible long Hello'
		target: self
		selector: #inform:
		argument: 'Hellooooooooooooooooooooooo World!!'.
	^ menu! !
FileDirectory subclass: #DosFileDirectory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Directories'!
!DosFileDirectory commentStamp: '<historical>' prior: 0!
I represent a DOS or Windows FileDirectory.
!


!DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'!
checkName: aFileName fixErrors: fixing
	"Check if the file name contains any invalid characters"
	| fName badChars hasBadChars |
	fName := super checkName: aFileName fixErrors: fixing.
	badChars := #( $: $< $> $| $/ $\ $? $* $") asSet.
	hasBadChars := fName includesAnyOf: badChars.
	(hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name'].
	hasBadChars ifFalse:[^ fName].
	^ fName collect:
		[:char | (badChars includes: char) 
				ifTrue:[$#] 
				ifFalse:[char]]! !

!DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'bf 3/21/2000 17:06'!
setPathName: pathString
	"Ensure pathString is absolute - relative directories aren't supported on all platforms."

	(pathString isEmpty
		or: [pathString first = $\
			or: [pathString size >= 2 and: [pathString second = $: and: [pathString first isLetter]]]])
				ifTrue: [^ super setPathName: pathString].

	self error: 'Fully qualified path expected'! !


!DosFileDirectory methodsFor: 'path access' stamp: 'stephaneducasse 2/4/2006 20:31'!
driveName

   "return a possible drive letter and colon at the start of a Path name, empty string otherwise"

   | firstTwoChars |

   ( pathName asSqueakPathName size >= 2 ) ifTrue: [
      firstTwoChars := (pathName asSqueakPathName copyFrom: 1 to: 2).
      (self class isDrive: firstTwoChars) ifTrue: [^firstTwoChars]
   ].
   ^''! !

!DosFileDirectory methodsFor: 'path access' stamp: 'nk 7/18/2004 17:26'!
fullNameFor: fileName
	"Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name."
	fileName ifNil:[^fileName].
	"Check for fully qualified names"
	((fileName size >= 2 and: [fileName first isLetter and: [fileName second = $:]])
		or: [(fileName beginsWith: '\\') and: [(fileName occurrencesOf: $\) >= 2]])
			ifTrue:[^fileName].
	^super fullNameFor: fileName! !

!DosFileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'!
fullPathFor: path
	"Return the fully-qualified path name for the given file."
	path isEmpty ifTrue:[^pathName asSqueakPathName].
	(path at: 1) = $\ ifTrue:[
		(path size >= 2 and:[(path at: 2) = $\]) ifTrue:[^path]. "e.g., \\pipe\"
		^self driveName , path "e.g., \windows\"].
	(path size >= 2 and:[(path at: 2) = $: and:[path first isLetter]])
		ifTrue:[^path]. "e.g., c:"
	^pathName asSqueakPathName, self slash, path! !

!DosFileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'!
relativeNameFor: path
	"Return the full name for path, assuming that path is a name relative to me."
	path isEmpty ifTrue:[^pathName asSqueakPathName].
	(path at: 1) = $\ ifTrue:[
		(path size >= 2 and:[(path at: 2) = $\]) ifTrue:[^super relativeNameFor: path allButFirst ]. "e.g., \\pipe\"
		^super relativeNameFor: path "e.g., \windows\"].
	(path size >= 2 and:[(path at: 2) = $: and:[path first isLetter]])
		ifTrue:[^super relativeNameFor: (path copyFrom: 3 to: path size) ]. "e.g., c:"
	^pathName asSqueakPathName, self slash, path! !

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

DosFileDirectory class
	instanceVariableNames: ''!

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 5/1/1999 01:48'!
isCaseSensitive
	"Return true if file names are treated case sensitive"
	^false! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 3/6/2004 03:46'!
isDrive: fullName
	"Answer whether the given full name describes a 'drive', e.g., one of the root directories of a Win32 file system. We allow two forms here - the classic one where a drive is specified by a letter followed by a colon, e.g., 'C:', 'D:' etc. and the network share form starting with double-backslashes e.g., '\\server'."
	^ (fullName size = 2 and: [fullName first isLetter and: [fullName last = $:]])
		or: [(fullName beginsWith: '\\') and: [(fullName occurrencesOf: $\) = 2]]! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'jm 5/8/1998 20:45'!
maxFileNameLength

	^ 255
! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'jm 12/4/97 22:57'!
pathNameDelimiter

	^ $\
! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 3/6/2004 04:14'!
splitName: fullName to: pathAndNameBlock
	"Take the file name and convert it to the path name of a directory and a local file name within that directory. 
	IMPORTANT NOTE: For 'drives', e.g., roots of the file system on Windows we treat the full name of that 'drive' as the local name rather than the path. This is because conceptually, all of these 'drives' hang off the virtual root of the entire Squeak file system, specified by FileDirectory root. In order to be consistent with, e.g., 

		DosFileDirectory localNameFor: 'C:\Windows' -> 'Windows'
		DosFileDirectory dirPathFor: 'C:\Windows' -> 'C:'

	we expect the following to be true:

		DosFileDirectory localNameFor: 'C:' -> 'C:'
		DosFileDirectory dirPathFor: 'C:'. -> ''
		DosFileDirectory localNameFor: '\\server' -> '\\server'.
		DosFileDirectory dirPathFor: '\\server' -> ''.

	so that in turn the following relations hold:

		| fd |
		fd := DosFileDirectory on: 'C:\Windows'.
		fd containingDirectory includes: fd localName.
		fd := DosFileDirectory on: 'C:'.
		fd containingDirectory includes: fd localName.
		fd := DosFileDirectory on: '\\server'.
		fd containingDirectory includes: fd localName.
	"
	(self isDrive: fullName)
		ifTrue: [^ pathAndNameBlock value:''  value: fullName].
	^ super splitName: fullName to: pathAndNameBlock! !


!DosFileDirectory class methodsFor: '*network-uri' stamp: 'mir 6/20/2005 18:53'!
privateFullPathForURI: aURI
	| path |
	path := aURI path.

	"Check for drive notation (a: etc)"
	path size > 1
		ifTrue: [
			((path at: 3) = $:)
				ifTrue: [path := path copyFrom: 2 to: path size]
				ifFalse: [
					"All other cases should be network path names (\\xxx\sdsd etc)"
					path := '/' , path]].

	^(path copyReplaceAll: '/' with: self slash) unescapePercents! !
TestCase subclass: #DosFileDirectoryTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Tests'!

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:03'!
testFileDirectoryContainingDirectory
	"Hoping that you have 'C:' of course..."
	| fd |
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	fd := FileDirectory on: 'C:'.
	self assert: fd containingDirectory pathName = ''.
! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:05'!
testFileDirectoryContainingDirectoryExistence
	"Hoping that you have 'C:' of course..."
	| fd |
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	fd := FileDirectory on: 'C:'.
	self assert: (fd containingDirectory fileOrDirectoryExists: 'C:').! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'!
testFileDirectoryContainingEntry
	"Hoping that you have 'C:' of course..."
	| fd |
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	fd := FileDirectory on: 'C:'.
	self assert: (fd containingDirectory entryAt: fd localName) notNil.
! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'!
testFileDirectoryDirectoryEntry
	"Hoping that you have 'C:' of course..."
	| fd |
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	fd := FileDirectory on: 'C:'.
	self assert: fd directoryEntry notNil.! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:28'!
testFileDirectoryEntryFor
	"Hoping that you have 'C:' of course..."
	| fd |
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	fd := FileDirectory root directoryEntryFor: 'C:'.
	self assert: (fd name sameAs: 'C:').! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:21'!
testFileDirectoryExists
	"Hoping that you have 'C:' of course..."
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	self assert: (FileDirectory root directoryExists: 'C:').! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'!
testFileDirectoryLocalName
	"Hoping that you have 'C:' of course..."
	| fd |
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	fd := FileDirectory on: 'C:'.
	self assert: fd localName = 'C:'.
! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:19'!
testFileDirectoryNamed
	"Hoping that you have 'C:' of course..."
	| fd |
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	fd := FileDirectory root directoryNamed: 'C:'.
	self assert: fd pathName = 'C:'.! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'DF 5/26/2006 11:57'!
testFileDirectoryNonExistence

	| inexistentFileName |
	
	"Hoping that you have 'C:' of course..."
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	
	inexistentFileName := DosFileDirectory default nextNameFor: 'DosFileDirectoryTest' extension: 'temp'.
	
	"This test can fail if another process creates a file with the same name as inexistentFileName
	(the probability of that is very very remote)"

	self deny: (DosFileDirectory default fileOrDirectoryExists: inexistentFileName)! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:13'!
testFileDirectoryRootExistence
	"Hoping that you have 'C:' of course..."
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	self assert: (FileDirectory root fileOrDirectoryExists: 'C:').! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:28'!
testFullNameFor
	"Hoping that you have 'C:' of course..."
	FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self].
	self assert: (FileDirectory default fullNameFor: 'C:') = 'C:'.
	self assert: (FileDirectory default fullNameFor: 'C:\test') = 'C:\test'.
	self assert: (FileDirectory default fullNameFor: '\\share') = '\\share'.
	self assert: (FileDirectory default fullNameFor: '\\share\test') = '\\share\test'.
	self assert: (FileDirectory default fullNameFor: '\test') = (FileDirectory default pathParts first, '\test').
! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:17'!
testIsDriveForDrive
	self assert: (DosFileDirectory isDrive: 'C:').
	self deny: (DosFileDirectory isDrive: 'C:\').
	self deny: (DosFileDirectory isDrive: 'C:\foo').
	self deny: (DosFileDirectory isDrive: 'C:foo').! !

!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:17'!
testIsDriveForShare
	self assert: (DosFileDirectory isDrive: '\\server').
	self deny: (DosFileDirectory isDrive: '\\server\').
	self deny: (DosFileDirectory isDrive: '\\server\foo').
! !
RectangleMorph subclass: #DoubleClickExample
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!DoubleClickExample commentStamp: '<historical>' prior: 0!
Illustrates the double-click capabilities of Morphic.

If you have a kind of morph you wish to have respond specially to a double-click, it should:

(1)  Respond "true" to #handlesMouseDown:

(2)  In its mouseDown: method, send #waitForClicksOrDrag:event: to the hand.

(3)  Reimplement #click: to react to single-clicked mouse-down.

(4)  Reimplement #doubleClick: to make the appropriate response to a double-click.

(5)  Reimplement #drag: to react to non-clicks.  This message is sent continuously until the button is released.  You can check the event argument to react differently on the first, intermediate, and last calls.!


!DoubleClickExample methodsFor: 'accessing' stamp: 'nk 7/26/2004 10:38'!
balloonText
	^ 'Double-click on me to change my color; 
single-click on me to change border color;
hold mouse down within me and then move it to grow 
(if I''m red) or shrink (if I''m blue).' translated
! !


!DoubleClickExample methodsFor: 'event handling' stamp: 'ar 10/3/2000 17:05'!
click: evt
	self showBalloon: 'click' hand: evt hand.
	self borderColor: (self borderColor = Color black ifTrue: [Color yellow] ifFalse: [Color black])
! !

!DoubleClickExample methodsFor: 'event handling' stamp: 'ar 10/3/2000 17:05'!
doubleClick: evt
	self showBalloon: 'doubleClick' hand: evt hand.
	self color: ((color = Color blue) ifTrue: [Color red] ifFalse: [Color blue])
! !

!DoubleClickExample methodsFor: 'event handling' stamp: 'sw 9/14/1999 16:05'!
handlesMouseDown: evt
	^ true! !

!DoubleClickExample methodsFor: 'event handling' stamp: 'bf 9/28/1999 17:20'!
mouseDown: evt
	"Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched"

	evt hand waitForClicksOrDrag: self event: evt! !

!DoubleClickExample methodsFor: 'event handling' stamp: 'ar 10/3/2000 17:05'!
startDrag: evt
	"We'll get a mouseDown first, some mouseMoves, and a mouseUp event last"
	| oldCenter |
	evt isMouseDown ifTrue:
		[self showBalloon: 'drag (mouse down)' hand: evt hand.
		self world displayWorld.
		(Delay forMilliseconds: 750) wait].
	evt isMouseUp ifTrue:
		[self showBalloon: 'drag (mouse up)' hand: evt hand].
	(evt isMouseUp or: [evt isMouseDown]) ifFalse:
		[self showBalloon: 'drag (mouse still down)' hand: evt hand].
	(self containsPoint: evt cursorPoint)
		ifFalse: [^ self].

	oldCenter _ self center.
	color = Color red
		ifTrue:
			[self extent: self extent + (1@1)]
		ifFalse:
			[self extent: ((self extent - (1@1)) max: (16@16))].
	self center: oldCenter! !


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

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

DoubleClickExample class
	instanceVariableNames: ''!

!DoubleClickExample class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:46'!
descriptionForPartsBin
	^ self partName:	'DoubleClick'
		categories:		#('Demo')
		documentation:	'An example of how to use double-click in moprhic'! !
Morph subclass: #DrawErrorMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!
!DrawErrorMorph commentStamp: '<historical>' prior: 0!
This morph simply invokes errors during drawing and stepping.!


!DrawErrorMorph methodsFor: 'drawing' stamp: 'ar 4/2/1999 12:13'!
drawOn: aCanvas
	aCanvas error:'DrawErrorMorph drawOn: invoked'! !


!DrawErrorMorph methodsFor: 'printing' stamp: 'ar 4/2/1999 12:15'!
printOn: aStream
	"Indirectly invokes an error during stepping in an Inspector"
	aStream error:'DrawErrorMorph>>printOn: invoked'! !
PopUpChoiceMorph subclass: #DropDownChoiceMorph
	instanceVariableNames: 'items border'
	classVariableNames: 'SubMenuMarker'
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!DropDownChoiceMorph methodsFor: 'accessing' stamp: 'bolot 11/2/1999 12:20'!
border
	^border! !

!DropDownChoiceMorph methodsFor: 'accessing' stamp: 'bolot 11/2/1999 12:20'!
border: newBorder
	border _ newBorder! !

!DropDownChoiceMorph methodsFor: 'accessing' stamp: 'bolot 11/2/1999 12:20'!
items
	(target notNil and: [getItemsSelector notNil])
		ifTrue: [items _ target perform: getItemsSelector withArguments: getItemsArgs].
	items ifNil: [items _ #()].
	^items! !

!DropDownChoiceMorph methodsFor: 'accessing' stamp: 'bolot 11/2/1999 12:20'!
items: someItems
	items _ someItems! !


!DropDownChoiceMorph methodsFor: 'copying' stamp: 'bolot 11/2/1999 12:17'!
veryDeepInner: deepCopier
	super veryDeepInner: deepCopier.
	items _ items veryDeepCopyWith: deepCopier.
	border _ border veryDeepCopyWith: deepCopier! !


!DropDownChoiceMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:35'!
drawOn: aCanvas

	aCanvas drawString: contents in: (bounds insetBy: 2)  font: self fontToUse color: color.

	border ifNotNil: [aCanvas frameAndFillRectangle: bounds
		fillColor: Color transparent
		borderWidth: 1
		borderColor: Color black].

	aCanvas
			paintImage: SubMenuMarker
			at: (self right - 8 @ ((self top + self bottom - SubMenuMarker height) // 2))! !

!DropDownChoiceMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:51'!
maxExtent: listOfStrings

	| h w maxW f |
	maxW _ 0.
	listOfStrings do: [:str |
		f _ self fontToUse.
		w _ f widthOfString: str.
		h _ f height.
		maxW _ maxW max: w].
	self extent: (maxW + 4 + h) @ (h + 4).
	self changed! !


!DropDownChoiceMorph methodsFor: 'event handling' stamp: 'bolot 11/2/1999 12:22'!
mouseDown: evt

	| menu selectedItem |
	self items isEmpty ifTrue: [^ self].
	menu _ CustomMenu new.
	self items do: [:item | menu add: item action: item].
	selectedItem _ menu startUp.
	selectedItem ifNil: [^ self].
	self contentsClipped: selectedItem.  "Client can override this if necess"
	actionSelector ifNotNil: [
		target
			perform: actionSelector
			withArguments: (arguments copyWith: selectedItem)].
! !


!DropDownChoiceMorph methodsFor: 'list access' stamp: 'bolot 11/2/1999 12:21'!
getCurrentSelectionIndex
	^self items indexOf: contents! !

!DropDownChoiceMorph methodsFor: 'list access' stamp: 'bolot 11/2/1999 12:21'!
selection: val
	self contentsClipped: val! !

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

DropDownChoiceMorph class
	instanceVariableNames: ''!

!DropDownChoiceMorph class methodsFor: 'class initialization' stamp: 'bolot 11/2/1999 12:19'!
initialize
	"DropDownChoiceMorph initialize"

	| f |
	f _ Form
		extent: 5@9
		fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648)
		offset: 0@0.
	SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f.
! !
MorphicEvent subclass: #DropEvent
	instanceVariableNames: 'position contents wasHandled'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'!
contents
	^contents! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 19:21'!
cursorPoint
	"For compatibility with mouse events"
	^position! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'!
position
	^position! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'!
type
	^#dropEvent! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'!
wasHandled
	^wasHandled! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'!
wasHandled: aBool
	wasHandled _ aBool.! !


!DropEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:24'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	self type == #dropEvent ifTrue:[^anObject handleDropMorph: self].! !


!DropEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:19'!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
	wasHandled _ anEvent wasHandled.! !

!DropEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"
	wasHandled _ false.! !


!DropEvent methodsFor: 'printing' stamp: 'ar 9/14/2000 18:15'!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: self position printString; space.
	aStream nextPutAll: self type.
	aStream nextPut: $].! !


!DropEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 18:33'!
isDropEvent
	^true! !


!DropEvent methodsFor: 'transforming' stamp: 'ar 10/7/2000 18:28'!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position _  aMorphicTransform globalPointToLocal: position.! !

!DropEvent methodsFor: 'transforming' stamp: 'ar 10/7/2000 18:28'!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."
	^self shallowCopy transformBy: aMorphicTransform! !


!DropEvent methodsFor: 'private' stamp: 'ar 9/13/2000 19:23'!
setPosition: pos contents: aMorph hand: aHand
	position _ pos.
	contents _ aMorph.
	source _ aHand.
	wasHandled _ false.! !
DropEvent subclass: #DropFilesEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!DropFilesEvent methodsFor: 'accessing' stamp: 'ar 1/10/2001 21:35'!
type
	^#dropFilesEvent! !


!DropFilesEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:35'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	self type == #dropFilesEvent ifTrue:[^anObject handleDropFiles: self].! !
Model subclass: #DualChangeSorter
	instanceVariableNames: 'leftCngSorter rightCngSorter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!DualChangeSorter commentStamp: '<historical>' prior: 0!
This class presents a view of a two change sets at once, and supports copying changes between change sets.
!


!DualChangeSorter methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
morphicWindow
	
	| window |
	leftCngSorter := ChangeSorter new myChangeSet: ChangeSet current.
	leftCngSorter parent: self.
	rightCngSorter := ChangeSorter new myChangeSet: 
			ChangeSorter secondaryChangeSet.
	rightCngSorter parent: self.

	window := (SystemWindow labelled: leftCngSorter label) model: self.
	"topView minimumSize: 300 @ 200."
	leftCngSorter openAsMorphIn: window rect: (0@0 extent: 0.5@1).
	rightCngSorter openAsMorphIn: window rect: (0.5@0 extent: 0.5@1).
	^ window
! !

!DualChangeSorter methodsFor: 'initialization' stamp: 'di 5/20/1998 21:44'!
okToChange
	^ leftCngSorter okToChange & rightCngSorter okToChange! !

!DualChangeSorter methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
open
	| topView |
	Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph].

	leftCngSorter := ChangeSorter new myChangeSet: ChangeSet current.
	leftCngSorter parent: self.
	rightCngSorter := ChangeSorter new myChangeSet: 
			ChangeSorter secondaryChangeSet.
	rightCngSorter parent: self.

	topView := (StandardSystemView new) model: self; borderWidth: 1.
	topView label: leftCngSorter label.
	topView minimumSize: 300 @ 200.
	leftCngSorter openView: topView offsetBy: 0@0.
	rightCngSorter openView: topView offsetBy: 360@0.
	topView controller open.
! !

!DualChangeSorter methodsFor: 'initialization' stamp: 'sw 3/6/1999 09:34'!
openAsMorph
	^ self morphicWindow openInWorld
! !

!DualChangeSorter methodsFor: 'initialization'!
release
	leftCngSorter release.
	rightCngSorter release.! !


!DualChangeSorter methodsFor: 'other'!
isLeftSide: theOne
	"Which side am I?"
	^ theOne == leftCngSorter! !

!DualChangeSorter methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'!
labelString
	"The window label"

	| leftName rightName changesName |
	leftName := leftCngSorter changeSetCategory categoryName.
	rightName := rightCngSorter changeSetCategory categoryName.
	changesName := 'Changes go to "', ChangeSet current name,  '"'.
	^ ((leftName ~~ #All) or: [rightName ~~ #All])
		ifTrue:
			['(', leftName, ') - ', changesName, ' - (', rightName, ')']
		ifFalse:
			[changesName]! !

!DualChangeSorter methodsFor: 'other' stamp: 'tk 5/8/1998 16:30'!
modelWakeUp
	"A window with me as model is being entered.  Make sure I am up-to-date with the changeSets."

	"Dumb way"
	leftCngSorter canDiscardEdits 
		ifTrue: [leftCngSorter update]	"does both"
		ifFalse: [rightCngSorter update].
! !

!DualChangeSorter methodsFor: 'other'!
other: theOne
	"Return the other side's ChangeSorter"
	^ theOne == leftCngSorter
		ifTrue: [rightCngSorter]
		ifFalse: [leftCngSorter]! !


!DualChangeSorter methodsFor: 'toolbuilder' stamp: 'sd 11/20/2005 21:27'!
buildWith: builder
	| windowSpec |
	leftCngSorter := ChangeSorter new myChangeSet: ChangeSet current.
	leftCngSorter parent: self.
	rightCngSorter := ChangeSorter new myChangeSet: 
			ChangeSorter secondaryChangeSet.
	rightCngSorter parent: self.

	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'Change Sorter'.
	windowSpec children: OrderedCollection new.
	leftCngSorter buildWith: builder in: windowSpec rect: (0@0 extent: 0.5@1).
	rightCngSorter buildWith: builder in: windowSpec rect: (0.5@0 extent: 0.5@1).
	^builder build: windowSpec
! !

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

DualChangeSorter class
	instanceVariableNames: ''!

!DualChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:44'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(DualChangeSorter		prototypicalToolWindow		'Change Sorter'		'Shows two change sets side by side')
						forFlapNamed: 'Tools']! !

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

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


!DualChangeSorter class methodsFor: 'opening' stamp: 'sw 3/24/1999 17:50'!
open
	"Open a new instance of the receiver's class"

	self new open! !

!DualChangeSorter class methodsFor: 'opening' stamp: 'sw 6/11/2001 17:38'!
prototypicalToolWindow
	"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"

 	^ self new morphicWindow applyModelExtent! !


!DualChangeSorter class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:12'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name  wording: 'Dual Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'Lets you view and manipulate two change sets concurrently.'! !
MenuMorph subclass: #DumberMenuMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!
!DumberMenuMorph commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!DumberMenuMorph methodsFor: 'menu' stamp: 'RAA 6/21/1999 15:40'!
setInvokingView: invokingView
	"I'd rather not, if that's OK"! !
AbstractSoundSystem subclass: #DummySoundSystem
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!DummySoundSystem commentStamp: 'gk 2/24/2004 23:14' prior: 0!
This is a dummy sound system registered in SoundService to absorb all sound playing and to use the primitive beep instead of sampled sounds when playing a beep.!


!DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 20:48'!
randomBitsFromSoundInput: bitCount
	"I'm not sure what the right thing to do here is."

	self error: 'Can not provide random data.'! !

!DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:54'!
sampledSoundChoices
	"No choices other than this."

	^ #('silence')! !

!DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:55'!
soundNamed: soundName
	"There are no sounds to look up."

	^ nil! !


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

	Beeper beepPrimitive! !

!DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:53'!
playSampledSound: samples rate: rate
	"Do nothing."
	! !

!DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:54'!
playSoundNamed: soundName
	"Do nothing."! !

!DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:54'!
playSoundNamed: soundName ifAbsentReadFrom: aifFileName
	"Do nothing."! !

!DummySoundSystem methodsFor: 'playing' stamp: 'gk 4/8/2005 14:15'!
playSoundNamedOrBeep: soundName 
	"There is no sound support, so we make the beep."

	self beep! !

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

DummySoundSystem class
	instanceVariableNames: ''!

!DummySoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'!
initialize
	SoundService register: self new.! !

!DummySoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'!
unload
	SoundService registeredClasses do: [:ss |
		(ss isKindOf: self) ifTrue: [SoundService unregister: ss]].! !
Stream subclass: #DummyStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Storage'!
!DummyStream commentStamp: '<historical>' prior: 0!
The purpose of this class is to absorb all steam messages and do nothing.  This is so ReferenceStream can pretend to write on it while traversing all objects it would normally write.  We need to know what those object are.  8/17/96 tk
!


!DummyStream methodsFor: 'accessing'!
nextInt32Put: arg
	"do nothing"! !

!DummyStream methodsFor: 'accessing'!
nextNumber: cnt put: num
	"do nothing"! !

!DummyStream methodsFor: 'accessing' stamp: 'tk 6/8/1998 21:06'!
nextPutAll: aByteArray
	"do nothing"! !

!DummyStream methodsFor: 'accessing' stamp: 'tk 6/8/1998 21:07'!
nextPut: aByte
	"do nothing"! !

!DummyStream methodsFor: 'accessing'!
nextStringPut: aString
	"do nothing"! !

!DummyStream methodsFor: 'accessing' stamp: 'tk 3/6/2000 11:10'!
originalContents

	^ ''! !

!DummyStream methodsFor: 'accessing'!
position
	"Return any random number.  Here is where the real lying begins.  We are a DummyStream afterall.  8/17/96 tk"

	^ 47 ! !

!DummyStream methodsFor: 'accessing' stamp: 'tk 7/12/1998 12:51'!
position: anOffset
	"Pretend to position wherever the caller says!!"
! !


!DummyStream methodsFor: 'error handling'!
subclassResponsibility
	"Do nothing.  Most messages to class Stream are defined as subclassResponsibility.  Just accept them.  8/17/96 tk"

	"No error.  Just go on."! !


!DummyStream methodsFor: 'open/close' stamp: 'tk 10/31/97 11:43'!
close
	"do nothing"! !


!DummyStream methodsFor: 'positioning' stamp: '6/10/97 17:14 tk'!
skip: aNumber
	"Do nothing."! !


!DummyStream methodsFor: 'protocol'!
binary
	"do nothing"! !

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

DummyStream class
	instanceVariableNames: ''!

!DummyStream class methodsFor: 'instance creation' stamp: 'jm 12/3/97 20:25'!
on: aFile
	"Return a new DummyStream instance, ignoring the argument."

	^ self basicNew
! !
Object subclass: #DummyToolWorkingWithFileList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList-Tests'!
!DummyToolWorkingWithFileList commentStamp: '<historical>' prior: 0!
I'm a dummy class for testing that the registration of the tool to the FileList of actually happens.
In the future the tests should cover that the class register when loaded in memory and unregister when unloaded.!


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

DummyToolWorkingWithFileList class
	instanceVariableNames: ''!

!DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'sd 2/6/2002 21:29'!
fileReaderServicesForFile: fullName suffix: suffix

	^ (suffix = 'kkk')
		ifTrue: [ self services]
		ifFalse: [#()] ! !

!DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'sd 2/6/2002 21:46'!
initialize
	"self initialize"

	FileList registerFileReader: self

! !

!DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'SD 11/14/2001 22:12'!
loadAFileForTheDummyTool: aFileListOrAPath
	
	"attention. if the file list selects a file the argument will be a fullpath of the selected file else it will pass the filelist itself"! !

!DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'sw 2/17/2002 02:36'!
serviceLoadAFilForDummyTool
	"Answer a service for opening the Dummy tool"

	^ SimpleServiceEntry 
		provider: self 
		label: 'menu label'
		selector: #loadAFileForTheDummyTool:
		description: 'Menu label for dummy tool'
		buttonLabel: 'test'! !

!DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'sd 2/1/2002 22:32'!
services 

	^ Array with: self serviceLoadAFilForDummyTool

! !

!DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !

!DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'SD 11/10/2001 21:49'!
unregister

	FileList unregisterFileReader: self.
	! !
Magnitude subclass: #Duration
	instanceVariableNames: 'nanos seconds'
	classVariableNames: ''
	poolDictionaries: 'ChronologyConstants'
	category: 'Kernel-Chronology'!
!Duration commentStamp: '<historical>' prior: 0!
I represent a duration of time. I have nanosecond precision
!


!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'!
* operand
	"operand is a Number" 	^ self class nanoSeconds: ( (self asNanoSeconds * operand) asInteger).
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'!
+ operand

	"operand is a Duration" 	^ self class nanoSeconds: (self asNanoSeconds + operand asNanoSeconds)
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'!
- operand
	"operand is a Duration" 	^ self + operand negated
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:00'!
/ operand

	"operand is a Duration or a Number"


	^ operand isNumber
		ifTrue: [ self class nanoSeconds: (self asNanoSeconds / operand) asInteger ]
		ifFalse: [ self asNanoSeconds / operand asDuration asNanoSeconds ]
.
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:00'!
< comparand

	^ self asNanoSeconds < comparand asNanoSeconds
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 1/9/2004 06:25'!
= comparand 
	"Answer whether the argument is a <Duration> representing the same 
	period of time as the receiver."

	^ self == comparand
		ifTrue: [true]
		ifFalse: 
			[self species = comparand species 
				ifTrue: [self asNanoSeconds = comparand asNanoSeconds]
				ifFalse: [false] ]! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'!
abs

	^ self class seconds: seconds abs nanoSeconds: nanos abs
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'!
asDuration

	^ self
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'!
asSeconds


	^ seconds
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 1/7/2004 16:20'!
days

	"Answer the number of days the receiver represents."

	^ seconds quo: SecondsInDay
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'!
hash 	^seconds bitXor: nanos
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'!
hours
	"Answer the number of hours the receiver represents."


	^ (seconds rem: SecondsInDay) quo: SecondsInHour
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'!
minutes

	"Answer the number of minutes the receiver represents."


	^ (seconds rem: SecondsInHour) quo: SecondsInMinute
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'!
negated

	^ self class seconds: seconds negated nanoSeconds: nanos negated
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'!
negative


	^ self positive not
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'!
positive


	^ seconds = 0 ifTrue: [ nanos positive ] ifFalse: [ seconds positive ]
! !

!Duration methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 10:03'!
seconds
	"Answer the number of seconds the receiver represents."

	^ (seconds rem: SecondsInMinute) + (nanos / NanosInSecond)! !


!Duration methodsFor: 'initialize-release' stamp: 'nk 3/30/2004 10:01'!
initialize
	self seconds: 0 nanoSeconds: 0.
! !


!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 14:29'!
// operand

	"operand is a Duration or a Number"


	^ operand isNumber
		ifTrue: [ self class nanoSeconds: (self asNanoSeconds // operand) asInteger ]
		ifFalse: [ self asNanoSeconds // operand asDuration asNanoSeconds ]
! !

!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:07'!
\\ operand

	"modulo. Remainder defined in terms of //. Answer a Duration with the 
	same sign as aDuration. operand is a Duration or a Number."

	^ operand isNumber
		ifTrue: [ self class nanoSeconds: (self asNanoSeconds \\ operand) ]
		ifFalse: [ self - (operand * (self // operand)) ]
! !

!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:42'!
asDelay

	^ Delay forDuration: self! !

!Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'!
asMilliSeconds


	^ ((seconds * NanosInSecond) + nanos) // (10 raisedToInteger: 6)
! !

!Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'!
asNanoSeconds

	^ (seconds * NanosInSecond) + nanos
! !

!Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'!
nanoSeconds


	^ nanos
! !

!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:22'!
printOn: aStream
	"Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" 	| d h m s n |
	d _ self days abs.
	h _ self hours abs.
	m _ self minutes abs.
 	s _ self seconds abs truncated.
	n _ self nanoSeconds abs. 	self negative ifTrue: [ aStream nextPut: $- ].
	d printOn: aStream. aStream nextPut: $:.
	h < 10 ifTrue: [ aStream nextPut: $0. ].
	h printOn: aStream. aStream nextPut: $:.
	m < 10 ifTrue: [ aStream nextPut: $0. ].
	m printOn: aStream. aStream nextPut: $:.
	s < 10 ifTrue: [ aStream nextPut: $0. ].
	s printOn: aStream.
	n = 0 ifFalse:
		[ | z ps |
		aStream nextPut: $..
		ps _ n printString padded: #left to: 9 with: $0. 
		z _ ps findLast: [ :c | c asciiValue > $0 asciiValue ].
		ps from: 1 to: z do: [ :c | aStream nextPut: c ] ].
! !

!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:42'!
roundTo: aDuration
	"e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 6 minutes."

	^ self class nanoSeconds: (self asNanoSeconds roundTo: aDuration asNanoSeconds)

! !

!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:38'!
truncateTo: aDuration
	"e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 4 minutes."

	^ self class
		nanoSeconds: (self asNanoSeconds truncateTo: aDuration asNanoSeconds)

! !


!Duration methodsFor: 'private' stamp: 'brp 7/27/2003 15:08'!
seconds: secondCount nanoSeconds: nanoCount 
	"Private - only used by Duration class"

	seconds _ secondCount.
	nanos _ nanoCount! !

!Duration methodsFor: 'private' stamp: 'brp 9/25/2003 14:42'!
storeOn: aStream

	aStream
		nextPut: $(;
		nextPutAll: self className;
		nextPutAll: ' seconds: ';
		print: seconds;
		nextPutAll: ' nanoSeconds: ';
		print: nanos;
		nextPut: $).
! !

!Duration methodsFor: 'private' stamp: 'brp 8/23/2003 20:31'!
ticks
	"Answer an array {days. seconds. nanoSeconds}. Used by DateAndTime and Time"

	^ Array 
		with: self days
		with: (self hours * 3600) + (self minutes * 60 ) + (self seconds truncated)
		with: self nanoSeconds! !


!Duration methodsFor: 'testing' stamp: 'tlk 4/30/2006 22:02'!
isZero
	^seconds isZero and:[nanos isZero]! !

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

Duration class
	instanceVariableNames: ''!

!Duration class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:55'!
days: days hours: hours minutes: minutes seconds: seconds

	^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: 0.! !

!Duration class methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 10:05'!
seconds: aNumber

	^ (self basicNew) seconds: aNumber nanoSeconds: 0; yourself.
! !

!Duration class methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 10:06'!
zero

	^ (self basicNew) seconds: 0 nanoSeconds: 0; yourself.
! !


!Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:00'!
days: aNumber

	^ self days: aNumber hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 1/7/2004 15:38'!
days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos

 	^ self nanoSeconds: 
			( ( (days * SecondsInDay) 
				+ (hours * SecondsInHour)
					+ (minutes * SecondsInMinute) 
						+ seconds ) * NanosInSecond )
							+ nanos.
! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 5/16/2003 11:29'!
fromString: aString


	^ self readFrom: (ReadStream on: aString)
! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:00'!
hours: aNumber


	^ self days: 0 hours: aNumber minutes: 0 seconds: 0 nanoSeconds: 0! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:04'!
milliSeconds: milliCount


	^ self days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 
			(milliCount * (10 raisedToInteger: 6))
! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:01'!
minutes: aNumber

	^ self days: 0 hours: 0 minutes: aNumber seconds: 0 nanoSeconds: 0! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 1/9/2004 17:20'!
month: aMonth
	"aMonth is an Integer or a String"
	
	^ (Month month: aMonth year: Year current year) duration
! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 5/21/2003 08:27'!
nanoSeconds: nanos

	^ self new
		seconds: (nanos quo: NanosInSecond) 
		nanoSeconds: (nanos rem: NanosInSecond) rounded;
		yourself.
! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 12:47'!
readFrom: aStream
	"Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]
	To assiste DateAndTime>>#readFrom: SS may be unpadded or absent."

	| sign days hours minutes seconds nanos ws ch |
	sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].

	days _ (aStream upTo: $:) asInteger sign: sign.
	hours _ (aStream upTo: $:) asInteger sign: sign.
	minutes _ (aStream upTo: $:) asInteger sign: sign.

	aStream atEnd 
		ifTrue: [seconds _ 0. nanos _ 0]
		ifFalse: 
			[ ws _ String new writeStream.
			[ch _ aStream next. (ch isNil) | (ch = $.)]
				whileFalse: [ ws nextPut: ch ].
			seconds _ ws contents asInteger sign: sign.
			ws reset.
			9 timesRepeat: 
				[ ch _ aStream next. 
				ws nextPut: (ch ifNil: [$0] ifNotNil: [ch]) ].
			nanos _ ws contents asInteger sign: sign].

	^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos.

	"	'0:00:00:00' asDuration
		'0:00:00:00.000000001' asDuration
		'0:00:00:00.999999999' asDuration
		'0:00:00:00.100000000' asDuration
		'0:00:00:00.10' asDuration
		'0:00:00:00.1' asDuration
		'0:00:00:01' asDuration
		'0:12:45:45' asDuration
		'1:00:00:00' asDuration
		'365:00:00:00' asDuration
		'-7:09:12:06.10' asDuration
		'+0:01:02' asDuration
		'+0:01:02:3' asDuration
 	"
! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:01'!
seconds: seconds nanoSeconds: nanos

	^ self days: 0 hours: 0 minutes: 0 seconds: seconds nanoSeconds: nanos
! !

!Duration class methodsFor: 'squeak protocol' stamp: 'brp 8/6/2003 18:54'!
weeks: aNumber

	^ self days: (aNumber * 7) hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0
! !
ClassTestCase subclass: #DurationTest
	instanceVariableNames: 'aDuration'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!

!DurationTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 14:30'!
classToBeTested

	^ Duration


! !

!DurationTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 14:30'!
selectorsToBeIgnored

	| private | 
	private := #( #printOn: ).

	^ super selectorsToBeIgnored, private
! !


!DurationTest methodsFor: 'running' stamp: 'brp 1/21/2004 18:36'!
setUp
	aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! !


!DurationTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:32'!
testComparing

	| d1 d2 d3 |
	d1 _ Duration seconds: 10 nanoSeconds: 1.
	d2 _ Duration seconds: 10 nanoSeconds: 1.
	d3 _ Duration seconds: 10 nanoSeconds: 2.
	
	self
		assert: (d1 = d1);
		assert: (d1 = d2);
		deny: (d1 = d3);
		assert: (d1 < d3)
! !

!DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:36'!
testModulo

	| d1 d2 d3 |
	d1 _ 11.5 seconds.
	d2 _ d1 \\ 3.
	self assert: d2 = (Duration nanoSeconds: 1).

	d3 _ d1 \\ (3 seconds).
	self assert: d3 =  (Duration seconds: 2 nanoSeconds: 500000000).

	self assert: aDuration \\ aDuration = 
		(Duration days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). 
	self assert: aDuration \\ 2 = 
		(Duration days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 1).
	

! !

!DurationTest methodsFor: 'Tests' stamp: 'brp 1/16/2004 14:17'!
testMonthDurations

	| jan feb dec |
	jan _ Duration month: #January.
	feb _ Duration month: #February.
	dec _ Duration month: #December.
	
	self 
		assert: jan = (Year current months first duration);
		assert: feb = (Year current months second duration);
		assert: dec = (Year current months last duration)

		
! !

!DurationTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:28'!
testNumberConvenienceMethods

	self
		assert: 1 week = (Duration days: 7);
		assert: -1 week = (Duration days: -7);
		assert: 1 day = (Duration days: 1);
		assert: -1 day = (Duration days: -1);
		assert: 1 hours = (Duration hours: 1);
		assert: -1 hour = (Duration hours: -1);
		assert: 1 minute = (Duration seconds: 60);
		assert: -1 minute = (Duration seconds: -60);
		assert: 1 second = (Duration seconds: 1);
		assert: -1 second = (Duration seconds: -1);
		assert: 1 milliSecond = (Duration milliSeconds: 1);
		assert: -1 milliSecond = (Duration milliSeconds: -1);
		assert: 1 nanoSecond = (Duration nanoSeconds: 1);
		assert: -1 nanoSecond = (Duration nanoSeconds: -1)
		! !

!DurationTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 14:57'!
testQuotient

	| d1 d2 q |
	d1 _ 11.5 seconds.
	d2 _ d1 // 3.
	self assert: d2 = (Duration seconds: 3 nanoSeconds: 833333333).

	q _ d1 // (3 seconds).
	self assert: q = 3.

! !

!DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:38'!
testRoundTo

	self assert: ((5 minutes + 37 seconds) roundTo: (2 minutes)) = (6 minutes).
	
	self assert:  (aDuration roundTo: (Duration days: 1)) =
	               (Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0).
	self assert:  (aDuration roundTo: (Duration hours: 1)) =
	               (Duration days: 1 hours: 2 minutes: 0 seconds: 0 nanoSeconds: 0).	
	self assert:  (aDuration roundTo: (Duration minutes: 1)) =
	               (Duration days: 1 hours: 2 minutes: 3 seconds: 0 nanoSeconds: 0).! !

!DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:37'!
testTruncateTo

	self assert: ((5 minutes + 37 seconds) truncateTo: (2 minutes)) = (4 minutes).
	self assert:  (aDuration truncateTo: (Duration days: 1)) =
	               (Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0).
	self assert:  (aDuration truncateTo: (Duration hours: 1)) =
	               (Duration days: 1 hours: 2 minutes: 0 seconds: 0 nanoSeconds: 0).	
	self assert:  (aDuration truncateTo: (Duration minutes: 1)) =
	               (Duration days: 1 hours: 2 minutes: 3 seconds: 0 nanoSeconds: 0).! !


!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testAbs
	self assert: aDuration abs = aDuration. 
	self assert: (Duration nanoSeconds: -5)  abs =  (Duration nanoSeconds: 5). 
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testAsDelay
	self deny: aDuration asDelay =   aDuration.
	"want to come up with a more meaningful test"
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testAsDuration
	self assert: aDuration asDuration =  aDuration
	
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testAsMilliSeconds
	self assert: (Duration nanoSeconds: 1000000)  asMilliSeconds = 1.
	self assert: (Duration seconds: 1)  asMilliSeconds = 1000.	
	self assert: (Duration nanoSeconds: 1000000)  asMilliSeconds = 1.
	self assert: (Duration nanoSeconds: 1000000)  asMilliSeconds = 1.
	self assert: aDuration   asMilliSeconds = 93784000.! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testAsNanoSeconds
	self assert: (Duration nanoSeconds: 1)  asNanoSeconds = 1.
	self assert: (Duration seconds: 1)  asNanoSeconds = 1000000000.	
	self assert: aDuration   asNanoSeconds = 93784000000005.! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testAsSeconds
	self assert: (Duration nanoSeconds: 1000000000)  asSeconds = 1.
	self assert: (Duration seconds: 1)  asSeconds = 1.	
	self assert: aDuration   asSeconds = 93784.! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testDays
	self assert: aDuration   days = 1.
	self assert: (Duration   days: 1) days= 1.	! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testDivide
	self assert: aDuration / aDuration = 1. 
	self assert: aDuration / 2 = (Duration days: 0 hours: 13 minutes: 1 seconds: 32 nanoSeconds: 2). 
	self assert: aDuration / (1/2) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10).
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testFromString
	self assert: aDuration = (Duration fromString: '1:02:03:04.000000005').
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testHash
	self assert: aDuration hash =    	(Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) hash.
	self assert: aDuration hash =     93789
	"must be a more meaningful test?"! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testHours
	self assert: aDuration   hours = 2.
	self assert: (Duration   hours: 2) hours = 2.	! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testIntegerDivision
	self assert: aDuration // aDuration = 1. 
	self assert: aDuration // 2 =  (aDuration / 2). 
	"is there ever a case where this is not true, since precision is always to the nano second?"! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testLessThan
	self assert: aDuration  < (aDuration + 1 day ).
	self deny: aDuration < aDuration.
	! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testMilliSeconds
	self assert: (Duration milliSeconds: 5) nanoSeconds = 5000000.	! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testMinus
	self assert: aDuration - aDuration = (Duration seconds: 0).
	self assert: aDuration - (Duration days: -1 hours: -2 minutes: -3 seconds: -4 nanoSeconds: -5) = 
						    (Duration days: 2  hours: 4  minutes: 6  seconds: 8  nanoSeconds: 10). 
	self assert: aDuration - (Duration days: 0  hours: 1  minutes: 2  seconds: 3  nanoSeconds: 4) = 
						    (Duration days: 1  hours: 1  minutes: 1  seconds: 1  nanoSeconds: 1). 
	self assert: aDuration - (Duration days: 0  hours: 3   minutes: 0  seconds: 5  nanoSeconds: 0) = 
						    (Duration days: 0  hours: 23  minutes: 2  seconds: 59  nanoSeconds: 5). ! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testMinutes
	self assert: aDuration   minutes = 3.
	self assert: (Duration minutes: 3) minutes = 3.	! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testMultiply
	self assert: aDuration * 2 = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testNanoSeconds
	self assert: aDuration nanoSeconds = 5.
	self assert: (Duration nanoSeconds: 5) nanoSeconds = 5.	! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testNegated
	self assert: aDuration + aDuration negated = (Duration seconds: 0). 
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testNegative
	self deny: aDuration negative.
	self assert: aDuration negated negative
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testNew
	"self assert: Duration new =  (Duration seconds: 0)."
    "new is not valid as a creation method: MessageNotUnderstood: UndefinedObject>>quo:, where Duration seconds is nil"! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testPlus
	self assert: (aDuration + 0 hours) = aDuration.
	self assert: (aDuration + aDuration) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testPositive
	self assert: (Duration nanoSeconds: 0) positive.
	self assert: aDuration positive.
	self deny: aDuration negated positive
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testPrintOn
    	|cs rw |
	cs _ ReadStream on: '1:02:03:04.000000005'.
	rw _ ReadWriteStream on: ''.
     aDuration printOn: rw.
     self assert: rw contents = cs contents.! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testReadFrom
	self assert: aDuration =  (Duration readFrom: (ReadStream on: '1:02:03:04.000000005'))
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testSeconds
	self assert: aDuration seconds =   (800000001/200000000).
	self assert: (Duration  nanoSeconds: 2) seconds = (2/1000000000).	
	self assert: (Duration  seconds: 2) seconds = 2.	
	self assert: (Duration  days: 1 hours: 2 minutes: 3 seconds:4) seconds = (4).
	self deny: (Duration  days: 1 hours: 2 minutes: 3 seconds:4) seconds = (1*24*60*60+(2*60*60)+(3*60)+4).	! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testSecondsNanoSeconds 
	self assert: (Duration   seconds: 0 nanoSeconds: 5)  = (Duration  nanoSeconds: 5).	
	"not sure I should include in sunit since its Private "
	self assert: (aDuration seconds: 0 nanoSeconds: 1) = (Duration nanoSeconds: 1). 
! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testStoreOn
     self assert: (aDuration storeOn: (WriteStream on:'')) asString ='1:02:03:04.000000005'. 
     "storeOn: returns a duration (self) not a stream"! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testTicks
	self assert: aDuration ticks =  #(1 7384 5)! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testWeeks
	self assert: (Duration  weeks: 1) days= 7.	! !

!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'!
testZero
	self assert: (Duration zero) = (Duration seconds: 0).	! !
UtteranceVisitor subclass: #DurationsVisitor
	instanceVariableNames: 'inherents lowers speed'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!
!DurationsVisitor commentStamp: '<historical>' prior: 0!
This is an implementation of the Klatt rule system as described in chapter 9 of "From text to speech: The MITalk system", Allen, Hunnicutt and Klatt.!


!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:38'!
defaultDurationFor: aPhoneme
	"Some hardcoded durations for phonemes."
	aPhoneme isVoiced ifTrue: [^ 0.0565].
	aPhoneme isUnvoiced ifTrue: [^ 0.0751].
	aPhoneme isConsonant ifTrue: [^ 0.06508].
	aPhoneme isDiphthong ifTrue: [^ 0.1362].
	^ 0.0741! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
inherentDurationAt: aPhoneme
	^ self inherents at: aPhoneme ifAbsent: [Transcript show: ' default duration for ', aPhoneme name. self defaultDurationFor: aPhoneme]! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
inherents
	^ inherents! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
inherents: aDictionary
	inherents := aDictionary! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
lowerDurationAt: aPhoneme
	^ self lowers at: aPhoneme ifAbsent: [self inherentDurationAt: aPhoneme]! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
lowers
	^ lowers! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
lowers: aDictionary
	lowers := aDictionary! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 18:28'!
speed
	^ speed! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
speed: aNumber
	speed := aNumber! !


!DurationsVisitor methodsFor: 'rules' stamp: 'stephaneducasse 2/3/2006 22:22'!
rule10
	"Rule 10: Shortening in clusters."
	| current next previous stream |
	phrase lastSyllable == syllable ifTrue: [^ self].
	stream := ReadStream on: syllable events.
	current := nil.
	next := stream next.
	[stream atEnd]
		whileFalse: [previous := current.
					current := next.
					next := stream next.
					current phoneme isVowel
						ifTrue: [next phoneme isVowel
									ifTrue: [current stretch: 1.2]
									ifFalse: [(previous notNil and: [previous phoneme isVowel])
												ifTrue: [current stretch: 0.7]]]
						ifFalse: [next phoneme isConsonant
									ifTrue: [(previous notNil and: [previous phoneme isConsonant])
												ifTrue: [current stretch: 0.5]
												ifFalse: [current stretch: 0.7]]
									ifFalse: [(previous notNil and: [previous phoneme isConsonant])
												ifTrue: [current stretch: 0.5]]]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:53'!
rule2
	"Rule 2: Clause Final Lengthening."

	clause lastSyllable events stretch: 1.4! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/13/1999 02:36'!
rule3
	"Rule 3: Non-phrase-final shortening.
	Syllabic segments are shortened by 60 if not in a phrase-final syllable."

	phrase syllablesDo: [ :each |
		phrase lastSyllable == each
			ifFalse: [each events do: [ :event | event phoneme isSyllabic ifTrue: [event stretch: 0.6]]]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:53'!
rule3b
	"A phrase-final postvocalic liquid or nasal is lengthened by 140"

	phrase lastSyllable events do: [ :each | (each phoneme isNasal or: [each phoneme isLiquid]) ifTrue: [each stretch: 1.4]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:56'!
rule4
	"Rule 4: Non-word-final shortening.
	Syllabic segments are shortened by 85 if not in a word-final syllable."

	word lastSyllable == syllable ifTrue: [^ self].
	syllable events do: [ :each | each phoneme isSyllabic ifTrue: [each stretch: 0.85]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:56'!
rule5
	"Rule 5: Polysyllabic Shortening.
	Syllabic segments in a polysyllabic word are shortened by 80."

	word isPolysyllabic ifFalse: [^ self].
	syllable events do: [ :each | each phoneme isSyllabic ifTrue: [each stretch: 0.8]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'stephaneducasse 2/3/2006 22:22'!
rule6
	"Rule 6: Non-initial-consonant shortening."

	| nonInitial |
	nonInitial := false.
	word events do: [ :each |
		(nonInitial and: [each phoneme isConsonant]) ifTrue: [each stretch: 0.85].
		nonInitial := true]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:59'!
rule7
	"Rule 7: Unstressed shortening."

	word syllables
		do: [ :each |
			each stress > 0
				ifFalse: [each events do: [ :event | event phoneme isSyllabic ifTrue: [event stretch: 0.5]].
						each events first phoneme isSyllabic ifTrue: [each events first stretch: 0.7 / 0.5].
						(each events last phoneme isSyllabic and: [each events size > 1]) ifTrue: [each events last stretch: 0.7 / 0.5]]]
! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/13/1999 02:33'!
rule8
	"Rule 8: Lengthening for emphasis."

	word isAccented
		ifTrue: [word events do: [ :each | each phoneme isVowel ifTrue: [each stretch: 1.4]]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'stephaneducasse 2/3/2006 22:22'!
rule9a
	"Rule 9a: Postvocalic context of vowels."

	| events current next nextnext |
	phrase lastSyllable == syllable ifTrue: [^ self].
	events := syllable events.
	1 to: events size do: [ :i |
		current := events at: i.
		next := i + 1 <= events size ifTrue: [(events at: i + 1) phoneme].
		nextnext := i + 2 <= events size ifTrue: [(events at: i + 2) phoneme].
		current stretch: (self rule9a: current phoneme next: next nextnext: nextnext)]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 17:00'!
rule9a: current next: next nextnext: nextnext
	"Rule 9a: Postvocalic context of vowels."

	current isVowel
		ifTrue: [next isNil ifTrue: [^ 1.2].
				nextnext isNil ifTrue: [^ self subRule9a: next].
				(next isSonorant and: [nextnext isObstruent]) ifTrue: [^ self subRule9a: nextnext]]
		ifFalse: [current isSonorant
					ifTrue: [next isNil ifTrue: [^ 1.2].
							next isObstruent ifTrue: [^ self subRule9a: next]]].
	^ 1.0! !

!DurationsVisitor methodsFor: 'rules' stamp: 'stephaneducasse 2/3/2006 22:22'!
rule9b
	"Rule 9b: Postvocalic context of vowels."

	| events current next nextnext |
	phrase lastSyllable == syllable ifFalse: [^ self].
	events := syllable events.
	1 to: events size do: [ :i |
		current := events at: i.
		next := i + 1 <= events size ifTrue: [(events at: i + 1) phoneme].
		nextnext := i + 2 <= events size ifTrue: [(events at: i + 2) phoneme].
		current stretch: 0.3 * (self rule9a: current phoneme next: next nextnext: nextnext) + 0.7]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 17:01'!
subRule9a: aPhoneme
	"Sub-rule 9a, independent of segment position."
	aPhoneme isVoiced ifFalse: [^ aPhoneme isStop ifTrue: [0.7] ifFalse: [1.0]].
	aPhoneme isFricative ifTrue: [^ 1.6].
	aPhoneme isStop ifTrue: [^ 1.2].
	aPhoneme isNasal ifTrue: [^ 0.85].
	^ 1.0! !


!DurationsVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:22'!
clause: aClause
	| min |
	super clause: aClause.

	self rule2.

	clause wordsDo: [ :eachWord |
		eachWord events do: [ :each |
			min := self lowerDurationAt: each phoneme.
			eachWord isAccented ifFalse: [min := min / 2.0].
			each duration: each duration + min / 1.4 / self speed]].
	clause syllablesDo: [ :each | each events recomputeTimes]! !

!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 17:04'!
phrase: aPhrase
	super phrase: aPhrase.
	self rule3; rule3b! !

!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 18:27'!
speaker: aSpeaker
	self speed: aSpeaker speed! !

!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 17:05'!
syllable: aSyllable
	super syllable: aSyllable.

	syllable events do: [ :each | each duration: (self inherentDurationAt: each phoneme) - (self lowerDurationAt: each phoneme)].
	self rule4; rule5; rule9a; rule9b; rule10! !

!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 17:06'!
word: aWord
	super word: aWord.

	self rule6; rule7; rule8! !

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

DurationsVisitor class
	instanceVariableNames: ''!

!DurationsVisitor class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
default
	| phonemes inherents lowers |
	phonemes := PhonemeSet arpabet.
	inherents := Dictionary new.
	lowers := Dictionary new.
	#(
	('ae'	230.0	80.0)
	('aa'	240.0	100.0)
	('ax'	120.0	60.0)
	('er'	180.0	80.0)
	('ay'	250.0	150.0)
	('aw'	240.0	100.0)
	('b'		85.0		60.0)
	('ch'	70.0		50.0)
	('d'		75.0		50.0)
	('dh'	50.0		30.0)
	('eh'	150.0	70.0)
	('ea'	270.0	130.0)
	('ey'	180.0	100.0)
	('f'		100.0	80.0)
	('g'		80.0		60.0)
	('hh'	80.0		20.0)
	('ih'	135.0	40.0)
	('ia'	230.0	100.0)
	('iy'	155.0	55.0)
	('jh'	70.0		50.0)
	('k'		80.0		60.0)
	('l'		80.0		40.0)
	('m'		70.0		60.0)
	('n'		60.0		50.0)
	('ng'	95.0		60.0)
"	('oh'	240.0	130.0)"
	('oy'	280.0	150.0)
	('ao'	240.0	130.0)
	('ow'	220.0	80.0)
	('p'		90.0		50.0)
	('r'		80.0		30.0)
	('s'		105.0	60.0)
	('sh'	105.0	80.0)
	('t'		75.0		50.0)
	('th'	90.0		60.0)
	('uh'	210.0	70.0)
	('ua'	230.0	110.0)
	('ah'	160.0	60.0)
	('uw'	230.0	150.0)
	('v'		60.0		40.0)
	('w'		80.0		60.0)
	('y'		80.0		40.0)
	('z'		75.0		40.0)
	('zh'	70.0		40.0)
	('sil'	100.0	100.0)) do: [ :each |
		inherents at: (phonemes at: each first) put: each second / 1000.0.
		lowers at: (phonemes at: each first) put: each last / 1000.0].
	^ self inherents: inherents lowers: lowers! !


!DurationsVisitor class methodsFor: 'instance creation' stamp: 'len 12/8/1999 16:40'!
inherents: aDictionary lowers: anotherDictionary
	^ self new inherents: aDictionary; lowers: anotherDictionary! !
BDFFontReader subclass: #EFontBDFFontReader
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!EFontBDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 12/28/2002 22:03'!
readCharactersInRangeFrom: start to: stop totalNums: upToNum storeInto: chars

	| array form code |
	1 to: upToNum do: [:i |
		array _ self readOneCharacter.
		code _ array at: 2.
		code > stop ifTrue: [^ self].
		(code between: start and: stop) ifTrue: [
			form _ array at: 1.
			form ifNotNil: [
				chars add: array.
			].
		].
	].
! !

!EFontBDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 15:29'!
readFrom: start to: end

	| xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue |
	form _ encoding _ bbx _ nil.
	self initialize.
	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.
	(properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [
		pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10.
	] ifFalse: [
		pointSize _ (ascent + descent) * 72 // 96.
	].
		
	
	maxWidth _ 0.
	minAscii _ 16r200000.
	strikeWidth _ 0.
	maxAscii _ 0.

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

	self readCharactersInRangeFrom: start to: end totalNums: charsNum storeInto: chars.

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

	chars do: [:array |
		encoding _ array at: 2.
		bbx _ array at: 3..
		width _ bbx at: 1.
		maxWidth _ maxWidth max: width.
		minAscii _ minAscii min: encoding.
		maxAscii _ maxAscii max: encoding.
		strikeWidth _ strikeWidth + width.
	].
	glyphs _ Form extent: strikeWidth@height.
	blt _ BitBlt toForm: glyphs.
	"xTable _ XTableForUnicodeFont new ranges: (Array with: (Array with: start with: end))."
	xTable _ SparseLargeTable new: end + 3 chunkSize: 32 arrayClass: Array base: start + 1 defaultValue: -1.
	lastAscii _ start.	
	1 to: charsNum do: [:i |
		form _ (chars at: i) first.
		encoding _ (chars at: i) second.
		bbx _ (chars at: i) third.
		"lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]."
		lastValue _ xTable at: lastAscii + 1 + 1.
		xTable at: encoding + 1 put: lastValue.
		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.
	].

	xTable zapDefaultOnlyEntries.
	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}"
! !
EFontBDFFontReader subclass: #EFontBDFFontReaderForRanges
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2003 16:55'!
additionalRangesForJapanese

	| basics |
	basics _ {
		Array with: 16r5C with: 16rFF3C.
		Array with: 16r3013 with: 16rFFFD.
	}.
	^ basics
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/15/2004 16:46'!
additionalRangesForKorean

	| basics |
	basics _ {
		Array with: 16rA1 with: 16rFFE6C.
		Array with: 16r3000 with: 16rFFFD.
	}.
	^ basics
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'BG 3/16/2005 08:22'!
override: chars with: otherFileName ranges: pairArray transcodingTable: table additionalRange: additionalRange

	| other rangeStream currentRange newChars code form u newArray j |
	other _ BDFFontReader readOnlyFileNamed: otherFileName.

	rangeStream _ ReadStream on: pairArray.
	currentRange _ rangeStream next.

	newChars _ PluggableSet new.
	newChars hashBlock: [:elem | (elem at: 2) hash].
	newChars equalBlock: [:a :b | (a at: 2) = (b at: 2)].

	other readChars do: [:array | 
		code _ array at: 2.
		"code printStringHex printString displayAt: 0@0."
		code > currentRange last ifTrue: [
			[rangeStream atEnd not and: [currentRange _ rangeStream next. currentRange last < code]] whileTrue.
			rangeStream atEnd ifTrue: [
				newChars addAll: chars.
				^ newChars.
			].
		].
		(code between: currentRange first and: currentRange last) ifTrue: [
			form _ array at: 1.
			form ifNotNil: [
				j _ array at: 2.
				u _ table at: (((j // 256) - 33 * 94 + ((j \\ 256) - 33)) + 1).
				u ~= -1 ifTrue: [
					array at: 2 put: u.
					newChars add: array.
					additionalRange do: [:e |
						e first = (array at: 2) ifTrue: [
							newArray _ array clone.
							newArray at: 2 put: e second.
							newChars add: newArray
						].
					]
				].
			].
		].
	].

	self error: 'should not reach here'.
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 2/14/2004 02:46'!
rangesForGreek

	^ {
		Array with: 16r1 with: 16rFF.
		Array with: 16r370 with: 16r3FF.
		Array with: 16r1F00 with: 16r1FFF.
		Array with: 16r2000 with: 16r206F.
		Array with: 16r20A0 with: 16r20AF
	}.
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2004 23:12'!
rangesForJapanese

	| basics etc |
	basics _ {
		Array with: 16r5C with: 16r5C.
		Array with: 16rA2 with: 16rA3.
		Array with: 16rA7 with: 16rA8.
		Array with: 16rAC with: 16rAC.
		Array with: 16rB0 with: 16rB1.
		Array with: 16rB4 with: 16rB4.
		Array with: 16rB6 with: 16rB6.
		Array with: 16rD7 with: 16rD7.
		Array with: 16rF7 with: 16rF7
	}.
	etc _ {
		Array with: 16r370 with: 16r3FF. "greek"
		Array with: 16r400 with: 16r52F. "cyrillic"
		Array with: 16r1D00 with: 16r1D7F. "phonetic"
		Array with: 16r1E00 with: 16r1EFF. "latin extended additional"
		Array with: 16r2000 with: 16r206F. "general punctuation"
		Array with: 16r20A0 with: 16r20CF. "currency symbols"
		Array with: 16r2100 with: 16r214F. "letterlike"
		Array with: 16r2150 with: 16r218F. "number form"
		Array with: 16r2190 with: 16r21FF. "arrows"
		Array with: 16r2200 with: 16r22FF. "math operators"
		Array with: 16r2300 with: 16r23FF. "misc tech"
		Array with: 16r2460 with: 16r24FF. "enclosed alnum"
		Array with: 16r2500 with: 16r257F. "box drawing"
		Array with: 16r2580 with: 16r259F. "box elem"
		Array with: 16r25A0 with: 16r25FF. "geometric shapes"
		Array with: 16r2600 with: 16r26FF. "misc symbols"
		Array with: 16r2700 with: 16r27BF. "dingbats"
		Array with: 16r27C0 with: 16r27EF. "misc math A"
		Array with: 16r27F0 with: 16r27FF. "supplimental arrow A"
		Array with: 16r2900 with: 16r297F. "supplimental arrow B"
		Array with: 16r2980 with: 16r29FF. "misc math B"
		Array with: 16r2A00 with: 16r2AFF. "supplimental math op"
		Array with: 16r2900 with: 16r297F. "supplimental arrow B"
		Array with: 16r2E80 with: 16r2EFF. "cjk radicals suppliment"
		Array with: 16r2F00 with: 16r2FDF. "kangxi radicals"
		Array with: 16r3000 with: 16r303F. "cjk symbols"
		Array with: 16r3040 with: 16r309F. "hiragana"
		Array with: 16r30A0 with: 16r30FF. "katakana"
		Array with: 16r3190 with: 16r319F. "kanbun"
		Array with: 16r31F0 with: 16r31FF. "katakana extension"
		Array with: 16r3200 with: 16r32FF. "enclosed CJK"
		Array with: 16r3300 with: 16r33FF. "CJK compatibility"
		Array with: 16r3400 with: 16r4DBF. "CJK unified extension A"
		Array with: 16r4E00 with: 16r9FAF. "CJK ideograph"
		Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph"
		Array with: 16rFE30 with: 16rFE4F. "CJK compatiblity forms"
		Array with: 16rFF00 with: 16rFFEF. "half and full"
		Array with: 16rFFFF with: 16rFFFF. "sentinel"
	}.

	^ basics, etc.
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/15/2004 16:53'!
rangesForKorean

	| basics etc |
	basics _ {
		Array with: 16rA1 with: 16rFF
	}.
	etc _ {
		Array with: 16r100 with: 16r17F. "extended latin"
		Array with: 16r370 with: 16r3FF. "greek"
		Array with: 16r400 with: 16r52F. "cyrillic"
		Array with: 16r2000 with: 16r206F. "general punctuation"
		Array with: 16r2100 with: 16r214F. "letterlike"
		Array with: 16r2150 with: 16r218F. "number form"
		Array with: 16r2190 with: 16r21FF. "arrows"
		Array with: 16r2200 with: 16r22FF. "math operators"
		Array with: 16r2300 with: 16r23FF. "misc tech"
		Array with: 16r2460 with: 16r24FF. "enclosed alnum"
		Array with: 16r2500 with: 16r257F. "box drawing"
		Array with: 16r2580 with: 16r259F. "box elem"
		Array with: 16r25A0 with: 16r25FF. "geometric shapes"
		Array with: 16r2600 with: 16r26FF. "misc symbols"
		Array with: 16r3000 with: 16r303F. "cjk symbols"
		Array with: 16r3040 with: 16r309F. "hiragana"
		Array with: 16r30A0 with: 16r30FF. "katakana"
		Array with: 16r3190 with: 16r319F. "kanbun"
		Array with: 16r31F0 with: 16r31FF. "katakana extension"
		Array with: 16r3200 with: 16r32FF. "enclosed CJK"
		Array with: 16r3300 with: 16r33FF. "CJK compatibility"
		Array with: 16r4E00 with: 16r9FAF. "CJK ideograph"
		Array with: 16rAC00 with: 16rD7AF. "Hangul Syllables"
		Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph"
		Array with: 16rFF00 with: 16rFFEF. "half and full"
	}.

	^ basics, etc.
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:20'!
rangesForLatin2

	^ {
		Array with: 0 with: 16r17F.
		Array with: 16r2B0 with: 16r2FF.
		Array with: 16r2000 with: 16r206F.
		Array with: 16r2122 with: 16r2122.
		Array with: 16rFFFF with: 16rFFFF. "sentinel"
	}.
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2004 23:20'!
readCharactersInRanges: ranges storeInto: chars

	| array form code rangeStream currentRange |
	rangeStream _ ReadStream on: ranges.
	currentRange _ rangeStream next.
	[true] whileTrue: [
		array _ self readOneCharacter.
		array second ifNil: [^ self].
		code _ array at: 2.
		code > currentRange last ifTrue: [
			[rangeStream atEnd not and: [currentRange _ rangeStream next. currentRange last < code]] whileTrue.
			rangeStream atEnd ifTrue: [^ self].
		].
		(code between: currentRange first and: currentRange last) ifTrue: [
			form _ array at: 1.
			form ifNotNil: [
				chars add: array.
			].
		].
	].
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:26'!
readRanges: ranges

	| xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue start end |
	form _ encoding _ bbx _ nil.
	self initialize.
	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.
	(properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [
		pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10.
	] ifFalse: [
		pointSize _ (ascent + descent) * 72 // 96.
	].

	maxWidth _ 0.
	minAscii _ 16r200000.
	strikeWidth _ 0.
	maxAscii _ 0.

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

	self readCharactersInRanges: ranges storeInto: chars.

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

	chars do: [:array |
		encoding _ array at: 2.
		bbx _ array at: 3..
		width _ bbx at: 1.
		maxWidth _ maxWidth max: width.
		minAscii _ minAscii min: encoding.
		maxAscii _ maxAscii max: encoding.
		strikeWidth _ strikeWidth + width.
	].

	glyphs _ Form extent: strikeWidth@height.
	blt _ BitBlt toForm: glyphs.
	start _ (ranges collect: [:r | r first]) min.
	end _ (ranges collect: [:r | r second]) max + 3.

	xTable _ SparseLargeTable new: end chunkSize: 64 arrayClass: Array base: start +1 defaultValue: -1.
	lastAscii _ start.
	xTable at: lastAscii + 2 put: 0.
	1 to: charsNum do: [:i |
		form _ (chars at: i) first.
		encoding _ (chars at: i) second.
		bbx _ (chars at: i) third.
		"lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]."
		lastValue _ xTable at: lastAscii + 1 + 1.
		xTable at: encoding + 1 put: lastValue.
		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.
	].
	xTable at: xTable size put: (xTable at: xTable size - 1).
	xTable zapDefaultOnlyEntries.
	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}"
! !

!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 5/26/2004 14:43'!
readRanges: ranges overrideWith: otherFileName otherRanges: otherRanges additionalOverrideRange: additionalRange

	| xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue start end |
	form _ encoding _ bbx _ nil.
	self initialize.
	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.
	(properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [
		pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10.
	] ifFalse: [
		pointSize _ (ascent + descent) * 72 // 96.
	].
		
	
	maxWidth _ 0.
	minAscii _ 16r200000.
	strikeWidth _ 0.
	maxAscii _ 0.

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

	self readCharactersInRanges: ranges storeInto: chars.
	chars _ self override: chars with: otherFileName ranges: otherRanges transcodingTable: (UCSTable jisx0208Table) additionalRange: additionalRange.

	chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)].
	charsNum _ chars size. "undefined encodings make this different"
	
	chars do: [:array |
		encoding _ array at: 2.
		bbx _ array at: 3..
		width _ bbx at: 1.
		maxWidth _ maxWidth max: width.
		minAscii _ minAscii min: encoding.
		maxAscii _ maxAscii max: encoding.
		strikeWidth _ strikeWidth + width.
	].

	glyphs _ Form extent: strikeWidth@height.
	blt _ BitBlt toForm: glyphs.
	start _ ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min.
	end _ ((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 3.
	"xRange _ Array with: (Array with: ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min
						with: (((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 2))."
	"xTable _ XTableForUnicodeFont new
		ranges: xRange."
	xTable _ SparseLargeTable new: end chunkSize: 64 arrayClass: Array base: start defaultValue: -1.
	lastAscii _ start.
	xTable at: lastAscii + 2 put: 0.
	1 to: charsNum do: [:i |
		form _ (chars at: i) first.
		encoding _ (chars at: i) second.
		bbx _ (chars at: i) third.
		"lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]."
		lastValue _ xTable at: lastAscii + 1 + 1.
		xTable at: encoding + 1 put: lastValue.
		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.
	].
	xTable at: xTable size put: (xTable at: xTable size - 1).
	xTable zapDefaultOnlyEntries.
	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}"
! !

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

EFontBDFFontReaderForRanges class
	instanceVariableNames: ''!

!EFontBDFFontReaderForRanges class methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:24'!
rangesForGreek

	^ {
		Array with: 16r1 with: 16rFF.
		Array with: 16r370 with: 16r3FF.
		Array with: 16r1F00 with: 16r1FFF.
		Array with: 16r2000 with: 16r206F.
		Array with: 16r20A0 with: 16r20AF
	}.
! !

!EFontBDFFontReaderForRanges class methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:24'!
rangesForLatin2

	^ {
		Array with: 0 with: 16r17F.
		Array with: 16r2B0 with: 16r2FF.
		Array with: 16r2000 with: 16r206F.
		Array with: 16r2122 with: 16r2122.
		Array with: 16rFFFF with: 16rFFFF. "sentinel"
	}.
! !
PostscriptCanvas subclass: #EPSCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Canvases'!
!EPSCanvas commentStamp: '<historical>' prior: 0!
I am a canvas for generating Encapsulates PostScript (EPS) files from single morphs, for example for screen-dumps.

I make sure that the bounding box of the EPS surrounds exactly the morph, and am not capable of generating multiple pages.  I do not generate an on-screen Preview for the EPS file, though that should be possible.
!


!EPSCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53'!
fullDraw: aMorph
	super fullDraw: aMorph.
	morphLevel = 0 ifTrue: [
		self writeTrailer: 1.
	]! !


!EPSCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 18:29'!
pageBBox
	^psBounds! !

!EPSCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 20:22'!
pageOffset
	^0@0! !


!EPSCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 12:48'!
writeEPSPreviewImageFor: aMorph
	| form stream string lines newExtent |
	newExtent _ (aMorph width roundUpTo: 8) @ aMorph height.
	form _ aMorph imageForm: 1 forRectangle: (aMorph bounds origin extent: newExtent).
	stream _ RWBinaryOrTextStream on: (String new: (form bits byteSize * 2.04) asInteger).
	form storePostscriptHexOn: stream.
	string _ stream contents.
	lines _ string occurrencesOf: Character cr.

	"%%BeginPreview: 80 24 1 24"
	"width height depth "
	target print: '%%BeginPreview: '; write:  newExtent; space; write: form depth; space; write: lines; cr.

	stream position: 0.
	[ stream atEnd ] whileFalse: [
		target nextPut: $%; nextPutAll: (stream upTo: Character cr); cr.
		lines _ lines - 1.
	].

	target print: '%%EndPreview'; cr.

! !

!EPSCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:31'!
writePSIdentifierRotated: rotateFlag 
	target
		print: '%!!PS-Adobe-2.0 EPSF-2.0';
		cr.
	rotateFlag 
		ifTrue: 
			[target
				print: '%%BoundingBox: ';
				write: (0 @ 0 corner: psBounds corner transposed) rounded;
				cr]
		ifFalse: 
			[target
				print: '%%BoundingBox: ';
				write: psBounds rounded;
				cr].
	target
		print: '%%Title: ';
		print: self topLevelMorph externalName;
		cr.
	target
		print: '%%Creator: ';
		print: Utilities authorName;
		cr.
	target
		print: '%%CreationDate: ';
		print: Date today asString;
		space;
		print: Time now asString;
		cr.
		
	"is this relevant?"
	target print: '%%Orientation: ';
		 print: (rotateFlag ifTrue: [ 'Landscape' ] ifFalse: [ 'Portrait' ]);
		cr.
	target print: '%%DocumentFonts: (atend)'; cr.
	target
		print: '%%EndComments';
		cr

	"	self writeEPSPreviewImageFor: topLevelMorph."

	"	target print: '%%EndProlog'; cr."! !

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

EPSCanvas class
	instanceVariableNames: ''!

!EPSCanvas class methodsFor: 'configuring' stamp: 'nk 1/1/2004 20:22'!
baseOffset
	^0@0.! !

!EPSCanvas class methodsFor: 'configuring' stamp: 'nk 12/29/2003 13:19'!
defaultExtension
	^'.eps'! !
EToyChatOrBadgeMorph subclass: #EToyChatMorph
	instanceVariableNames: 'listener receivingPane myForm recipientForm acceptOnCR sendingPane'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Collaborative'!
!EToyChatMorph commentStamp: '<historical>' prior: 0!
EToyChatMorph new open setIPAddress: '1.2.3.4'

"
EToyChatMorph represents a chat session with another person. Type your message in the top text pane and press cmd-S.
"!
]style[(46 122)f2cblue;,f1!


!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
acceptTo: someText forMorph: aMorph

	| betterText |

	betterText := self improveText: someText forMorph: aMorph.
	self 
		transmitStreamedObject: (betterText eToyStreamedRepresentationNotifying: self) 
		to: self ipAddress.
	aMorph setText: '' asText.
	self appendMessage: 
		self startOfMessageFromMe,
		' - ',
		betterText,
		String cr.

	^true! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 22:34'!
appendMessage: aText

	receivingPane appendTextEtoy: aText.! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
chatFrom: ipAddress name: senderName text: text

	| initialText attrib |

	recipientForm ifNil: [
		initialText := senderName asText allBold.
	] ifNotNil: [
		attrib := TextAnchor new anchoredMorph: recipientForm "asMorph".
		initialText := (String value: 1) asText.
		initialText addAttribute: attrib from: 1 to: 1.
	].
	self appendMessage: initialText,' - ',text,String cr.
	EToyCommunicatorMorph playArrivalSound.


! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 10:37'!
getChoice: aSymbol
	
	aSymbol == #acceptOnCR ifTrue: [^acceptOnCR ifNil: [true]].
	^false.
! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
improveText: someText forMorph: aMorph

	| betterText conversions newAttr fontForAll |

	fontForAll := aMorph eToyGetMainFont.
	betterText := someText veryDeepCopy.
	conversions := OrderedCollection new.
	betterText runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextFontChange) ifTrue: [
				conversions add: {att. start. stop}
			]
		]
	].
	conversions do: [ :old |
		betterText removeAttribute: old first from: old second to: old third.
		newAttr := TextFontReference toFont: (fontForAll fontAt: old first fontNumber).
		newAttr fontNumber: old first fontNumber.
		betterText addAttribute: newAttr from: old second to: old third.
	].
	^betterText! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 16:14'!
insetTheScrollbars

	self allMorphsDo: [ :each | 
		(each isKindOf: PluggableTextMorph) ifTrue: [each retractable: false]
	].! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 06:09'!
ipAddress
	
	^(fields at: #ipAddress) contents! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 11:30'!
open
	
	^self openIn: self currentWorld! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/3/2000 07:40'!
openIn: aWorld

	"open an a chat window"

	aWorld ifNil: [^self].
	self 
		position: 400@100;
		extent:  200@150;
		openInWorld: aWorld.! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
rebuild
	| r1 r2 |

	r1 := self addARow: {
		self simpleToggleButtonFor: self attribute: #acceptOnCR help: 'Send with Return?'.
		self inAColumn: {StringMorph new contents: 'Your message to:'; lock}.
		self textEntryFieldNamed: #ipAddress with: ''
					help: 'IP address for chat partner'.
	}.
	recipientForm ifNotNil: [
		r1 addMorphBack: recipientForm asMorph lock
	].
	sendingPane := PluggableTextMorph
				on: self
				text: nil
				accept: #acceptTo:forMorph:.
	sendingPane hResizing: #spaceFill; vResizing: #spaceFill.
	self
		addMorphBack: sendingPane.
	r2 := self addARow: {self inAColumn: {StringMorph new contents: 'Replies'; lock}}.
	receivingPane := PluggableTextMorph
				on: self
				text: nil
				accept: nil.
	receivingPane hResizing: #spaceFill; vResizing: #spaceFill.
	self
		addMorphBack: receivingPane.
	receivingPane spaceFillWeight: 3.
	{r1. r2} do: [ :each |
		each
			vResizing: #shrinkWrap; minHeight: 18;
			color: Color veryLightGray.
	].
	sendingPane acceptOnCR: (acceptOnCR ifNil: [acceptOnCR := true])! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
recipientForm: aForm

	recipientForm := aForm.
	recipientForm ifNotNil: [recipientForm := recipientForm scaledToSize: 20@20].! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 16:43'!
reportError: aString

	receivingPane appendTextEtoy: (aString asText addAttribute: TextColor red), String cr.! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 05:39'!
setIPAddress: aString
	
	(fields at: #ipAddress) contents: aString! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 08:04'!
standardBorderColor

	^Color darkGray! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
startOfMessageFromMe

	myForm ifNil: [
		myForm := EToySenderMorph pictureForIPAddress: NetNameResolver localAddressString.
		myForm ifNotNil: [
			myForm := myForm scaledToSize: 20@20
		].
	].
	myForm ifNil: [
		^(Preferences defaultAuthorName asText allBold addAttribute: TextColor blue)
	].
	^(String value: 1) asText
		addAttribute: (TextAnchor new anchoredMorph: myForm);
		yourself

! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
toggleChoice: aSymbol
	
	aSymbol == #acceptOnCR ifTrue: [
		acceptOnCR := (acceptOnCR ifNil: [true]) not.
		sendingPane ifNotNil: [sendingPane acceptOnCR: acceptOnCR].
		^self
	].

! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 11:58'!
transmittedObjectCategory

	^EToyIncomingMessage typeKeyboardChat! !


!EToyChatMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ self standardBorderColor! !

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

!EToyChatMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'!
defaultBounds
"answer the default bounds for the receiver"
	^ 400 @ 100 extent: 200 @ 150! !

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

!EToyChatMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	acceptOnCR := true.
	self listDirection: #topToBottom;
		 layoutInset: 0;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 rubberBandCells: false;
		 minWidth: 200;
		 minHeight: 200;
		 rebuild ! !

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

EToyChatMorph class
	instanceVariableNames: ''!

!EToyChatMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
chatFrom: ipAddress name: senderName text: text

	| chatWindow |

	chatWindow := self 
		chatWindowForIP: ipAddress 
		name: senderName 
		picture: (EToySenderMorph pictureForIPAddress: ipAddress) 
		inWorld: self currentWorld.
	chatWindow
		chatFrom: ipAddress 
		name: senderName 
		text: text
! !

!EToyChatMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
chatWindowForIP: ipAddress name: senderName picture: aForm inWorld: aWorld

	| makeANewOne aSenderBadge existing |

	existing := self instanceForIP: ipAddress inWorld: aWorld.
	existing ifNotNil: [^existing].
	makeANewOne := [
		self new
			recipientForm: aForm; 
			open; 
			setIPAddress: ipAddress
	].
	EToyCommunicatorMorph playArrivalSound.
	self doChatsInternalToBadge ifTrue: [
		aSenderBadge := EToySenderMorph instanceForIP: ipAddress inWorld: aWorld.
		aSenderBadge ifNotNil: [
			aSenderBadge startChat: false.
			^aSenderBadge 
				findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph] 
				ifAbsent: makeANewOne
		].
		aSenderBadge := EToySenderMorph instanceForIP: ipAddress.
		aSenderBadge ifNotNil: [
			aSenderBadge := aSenderBadge veryDeepCopy.
			aSenderBadge 
				killExistingChat;
				openInWorld: aWorld;
				startChat: false.
			^aSenderBadge 
				findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph] 
				ifAbsent: makeANewOne
		].
		(aSenderBadge := EToySenderMorph new)
			userName: senderName 
			userPicture: aForm
			userEmail: 'unknown' 
			userIPAddress: ipAddress;
			position: 200@200;
			openInWorld: aWorld;
			startChat: false.
		^aSenderBadge 
			findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph] 
			ifAbsent: makeANewOne
	].
	^makeANewOne value.

! !

!EToyChatMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 17:12'!
doChatsInternalToBadge

	^true! !

!EToyChatMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 12:48'!
instanceForIP: ipAddress inWorld: aWorld

	^self allInstances detect: [ :x | 
		x world == aWorld and: [x ipAddress = ipAddress]
	] ifNone: [nil]

! !


!EToyChatMorph class methodsFor: 'parts bin' stamp: 'md 8/10/2006 11:53'!
descriptionForPartsBin

	^ self partName: 	'Text chat'
		categories:		#('Collaborative')
		documentation:	'A tool for sending messages to other Squeak users'! !
EToyCommunicatorMorph subclass: #EToyChatOrBadgeMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Experimental'!

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

EToyChatOrBadgeMorph class
	instanceVariableNames: ''!

!EToyChatOrBadgeMorph class methodsFor: 'new-morph participation' stamp: 'RAA 8/3/2000 07:51'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ self ~~ EToyChatOrBadgeMorph! !
AlignmentMorphBob1 subclass: #EToyCommunicatorMorph
	instanceVariableNames: 'fields resultQueue'
	classVariableNames: 'LastFlashTime'
	poolDictionaries: ''
	category: 'EToys-Experimental'!
!EToyCommunicatorMorph commentStamp: '<historical>' prior: 0!
====== find and report all instances =====
	EToySenderMorph instanceReport


====== zap a bunch of ipAddresses =====
	EToySenderMorph allInstances do: [ :each | 
		each ipAddress = '11.11.11.11' ifTrue: [each ipAddress: 'whizzbang']
	].
==================== now change one of the whizzbang's back to the right address=====
====== delete the whizzbangs ======
	EToySenderMorph allInstances do: [ :each | 
		each ipAddress = 'whizzbang' ifTrue: [each stopStepping; delete]
	].
!


!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:26'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString;
		color: aColor;
		borderColor: aColor muchDarker;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	self field: aSymbol is: f.
	col _ (self inAColumn: {f}) hResizing: #shrinkWrap.
	^col! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 05:57'!
commResult: anArrayOfAssociations

	| aDictionary |
	aDictionary _ Dictionary new.
	anArrayOfAssociations do: [ :each | aDictionary add: each].
	resultQueue nextPut: aDictionary! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 18:33'!
editEvent: anEvent for: aMorph

	| answer |

	(aMorph bounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
	answer _ FillInTheBlankMorph
		request: 'Enter a new ',aMorph balloonText
		initialAnswer: aMorph contents.
	answer isEmptyOrNil ifTrue: [^self].
	aMorph contents: answer
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 16:59'!
field: fieldName is: anObject

	fields at: fieldName put: anObject.
	^anObject! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 10:05'!
flashIndicator: aSymbol

	| now |

	now _ Time millisecondClockValue.
	(LastFlashTime notNil and: [(Time millisecondClockValue - now) abs < 500]) ifTrue: [^self].
	LastFlashTime _ now.
	self trulyFlashIndicator: aSymbol
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 16:42'!
handleResult: aDictionary

	| m |

	aDictionary at: #commFlash ifPresent: [ :ignore | ^self flashIndicator: #communicating].
	self resetIndicator: #communicating.
	m _ aDictionary at: #message ifAbsent: ['unknown message'].
	m = 'OK' ifTrue: [^self].
	self reportError: m! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 17:32'!
indicatorFieldNamed: aSymbol color: aColor help: helpString

	| f col |
	f _ EllipseMorph new
		extent: 10@10;
		color: aColor;
		setBalloonText: helpString.
	self field: aSymbol is: f.
	col _ (self inAColumn: {f}) hResizing: #shrinkWrap.
	^col! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 16:48'!
open

	self openInWorld! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 16:41'!
reportError: aString

	self inform: aString! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 08:18'!
resetIndicator: aSymbol

	| indicator firstColor |
	indicator _ fields at: aSymbol ifAbsent: [^self].
	firstColor _ indicator 
		valueOfProperty: #firstColor
		ifAbsent: [^self].
	indicator color: firstColor.
	self world displayWorldSafely.
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 16:19'!
stopFlashing

	self setProperty: #flashingState toValue: 0.
	self borderColor: (self valueOfProperty: #normalBorderColor ifAbsent: [Color blue]).
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 18:35'!
textEntryFieldNamed: aSymbol with: aString help: helpString

	| f col |
	f _ (StringMorph new contents: aString)
		setBalloonText: helpString;
		on: #mouseUp send: #editEvent:for: to: self.
	self field: aSymbol is: f.
	col _ (self inAColumn: {f}) color: Color white; hResizing: #shrinkWrap.
	^col! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/2/2000 12:42'!
toggleButtonFor: entry attribute: attribute

	^(self inAColumn: {
		self
			simpleToggleButtonFor: entry 
			attribute: attribute 
			help: 'Whether you want "',attribute,'" messages'
	}) hResizing: #shrinkWrap
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 10:05'!
trulyFlashIndicator: aSymbol

	| indicator firstColor |

	indicator _ fields at: aSymbol ifAbsent: [^self].
	firstColor _ indicator 
		valueOfProperty: #firstColor
		ifAbsent: [
			indicator setProperty: #firstColor toValue: indicator color.
			indicator color
		].
	indicator color: (indicator color = firstColor ifTrue: [Color white] ifFalse: [firstColor]).
	self world displayWorldSafely.
! !


!EToyCommunicatorMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:32'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self vResizing: #shrinkWrap;
	 hResizing: #shrinkWrap.
	resultQueue _ SharedQueue new.
	fields _ Dictionary new.
	self useRoundedCorners! !


!EToyCommunicatorMorph methodsFor: 'stepping and presenter' stamp: 'RAA 7/10/2000 10:14'!
step

	| state |

	[resultQueue isEmpty] whileFalse: [
		self handleResult: resultQueue next
	].
	(state _ self valueOfProperty: #flashingState ifAbsent: [0]) > 0 ifTrue: [
		self borderColor: (
			(self valueOfProperty: #flashingColors ifAbsent: [{Color green. Color red}]) atWrap: state
		).
		self setProperty: #flashingState toValue: state + 1
	].! !


!EToyCommunicatorMorph methodsFor: 'submorphs-add/remove' stamp: 'RAA 7/8/2000 17:45'!
delete

	super delete.
	self breakDependents! !


!EToyCommunicatorMorph methodsFor: 'testing' stamp: 'RAA 7/10/2000 10:27'!
stepTime

	(self valueOfProperty: #flashingState ifAbsent: [0]) > 0 ifTrue: [
		^200
	] ifFalse: [
		^1000
	].! !

!EToyCommunicatorMorph methodsFor: 'testing' stamp: 'RAA 7/9/2000 06:25'!
wantsSteps

	^true! !


!EToyCommunicatorMorph methodsFor: '*nebraska-*nebraska-Morphic-Collaborative' stamp: 'sd 11/20/2005 21:25'!
addGateKeeperMorphs

	| list currentTime choices age row |

	self setProperty: #gateKeeperCounterValue toValue: EToyGateKeeperMorph updateCounter.
	choices := #(
		(60 'm' 'in the last minute')
		(3600 'h' 'in the last hour')
		(86400 'd' 'in the last day')
	).
	currentTime := Time totalSeconds.
	list := EToyGateKeeperMorph knownIPAddresses.
	list do: [ :each |
		age := each timeBetweenLastAccessAnd: currentTime.
		age := choices
			detect: [ :x | age <= x first]
			ifNone: [{0. '-'. (age // 86400) printString,'days ago'}].
		row := self addARow:
		(EToyIncomingMessage allTypes collect: [ :type |
				self toggleButtonFor: each attribute: type]
		),
		{

			(self inAColumn: {
				(StringMorph contents: age second) lock.
			}) layoutInset: 2; hResizing: #shrinkWrap; setBalloonText: 'Last attempt was ',age third.

			(self inAColumn: {
				(StringMorph contents: each ipAddress) lock.
			}) layoutInset: 2; hResizing: #shrinkWrap.

			(self inAColumn: {
				(StringMorph contents: each latestUserName) lock.
			}) layoutInset: 2.
		}.
		row
			color: (Color r: 0.6 g: 0.8 b: 1.0);
			borderWidth: 1;
			borderColor: #raised;
			vResizing: #spaceFill;
			"on: #mouseUp send: #mouseUp:in: to: self;"
			setBalloonText: each fullInfoString
	].! !

!EToyCommunicatorMorph methodsFor: '*nebraska-*nebraska-Morphic-Collaborative' stamp: 'mir 10/12/2000 14:55'!
transmitStreamedObject: outData as: objectCategory to: anIPAddress

	EToyPeerToPeer transmitStreamedObject: outData as: objectCategory to: anIPAddress for: self! !

!EToyCommunicatorMorph methodsFor: '*nebraska-*nebraska-Morphic-Collaborative' stamp: 'mir 10/10/2000 12:47'!
transmitStreamedObject: outData to: anIPAddress

	self transmitStreamedObject: outData as: self transmittedObjectCategory to: anIPAddress
! !

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

EToyCommunicatorMorph class
	instanceVariableNames: ''!

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 16:19'!
allForIPAddress: ipString	"for cleaning up Alan's demo"
"
EToySenderMorph allForIPAddress: '1.2.3.4'
"
	Smalltalk garbageCollect.
	(self allInstances select: [ :each | each ipAddress = ipString]) explore! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 16:13'!
instanceReport	"for cleaning up Alan's demo"
"
EToySenderMorph instanceReport
"
	| answer resp |

	Smalltalk garbageCollect.
	answer _ self allInstances collect: [ :each |
		{
			each.
			[each ipAddress] on: Error do: [ 'no ipAddress'].
			each owner 
					ifNil: ['* no owner *'] 
					ifNotNil: [each owner innocuousName,' ',each owner printString].
			each world ifNil: ['-----no project-----'] ifNotNil: [each world project name].
		}
	].
	resp _ (PopUpMenu labels: 'IP Address\Project\Owner' withCRs) startUpWithCaption: 
					'Sorted by'.
	resp = 1 ifTrue: [
		^(answer asSortedCollection: [ :a :b | a second <= b second]) asArray explore
	].
	resp = 2 ifTrue: [
		^(answer asSortedCollection: [ :a :b | a fourth <= b fourth]) asArray explore
	].
	resp = 3 ifTrue: [
		^(answer asSortedCollection: [ :a :b | a third <= b third]) asArray explore
	].
	answer explore! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 17:09'!
otherCleanup
">>>
	EToySenderMorph allInstances do: [ :each | 
		each ipAddress = '11.11.11.11' ifTrue: [each ipAddress: 'whizzbang']
	].
<<<"
	"==================== now change one of the whizzbang's back to the right address====="
">>>
	EToySenderMorph allInstances do: [ :each | 
		each ipAddress = 'whizzbang' ifTrue: [each delete]
	].
<<<"
! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'gk 2/23/2004 21:07'!
playArrivalSound
	"Make a sound that something has arrived."

	SoundService default playSoundNamedOrBeep: 'chirp'! !


!EToyCommunicatorMorph class methodsFor: 'new-morph participation' stamp: 'RAA 8/3/2000 07:48'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ self ~~ EToyCommunicatorMorph! !
EToyCommunicatorMorph subclass: #EToyFridgeMorph
	instanceVariableNames: 'recipients incomingRow recipientRow updateCounter groupMode'
	classVariableNames: 'FridgeRecipients NewItems TheFridgeForm UpdateCounter'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Collaborative'!
!EToyFridgeMorph commentStamp: '<historical>' prior: 0!
EToyFridgeMorph new openInWorld!
]style[(31)f4cblue;!


!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 12:47'!
getChoice: aString

	aString = 'group' ifTrue: [^groupMode ifNil: [true]].! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 13:13'!
groupToggleButton

	^(self inAColumn: {
		(EtoyUpdatingThreePhaseButtonMorph checkBox)
			target: self;
			actionSelector: #toggleChoice:;
			arguments: {'group'};
			getSelector: #getChoice:;
			setBalloonText: 'Changes between group mode and individuals';
			step
	}) hResizing: #shrinkWrap
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:51'!
mouseEnterEither: evt

	evt hand hasSubmorphs ifFalse: [
		^self addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3).
	].
	(evt hand firstSubmorph isKindOf: EToySenderMorph) ifTrue: [
		^self addMouseActionIndicatorsWidth: 10 color: (Color magenta alpha: 0.3).
	].
	self addMouseActionIndicatorsWidth: 10 color: (Color green alpha: 0.3).

! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:53'!
mouseLeaveEither: evt

	self deleteAnyMouseActionIndicators.

! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 11:05'!
noteRemovalOf: aSenderMorph

	self class removeRecipientWithIPAddress: aSenderMorph ipAddress! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
rebuild

	| row filler fudge people maxPerRow insetY |

	updateCounter := self class updateCounter.
	self removeAllMorphs.
	(self addARow: {
		filler := Morph new color: Color transparent; extent: 4@4.
	}) vResizing: #shrinkWrap.
	self addARow: {
		(StringMorph contents: 'the Fridge') lock.
		self groupToggleButton.
	}.
	row := self addARow: {}.
	people := self class fridgeRecipients.
	maxPerRow := people size < 7 ifTrue: [2] ifFalse: [3].	
		"how big can this get before we need a different approach?"
	people do: [ :each |
		row submorphCount >= maxPerRow ifTrue: [row := self addARow: {}].
		row addMorphBack: (
			groupMode ifTrue: [
				(each userPicture scaledToSize: 35@35) asMorph lock
			] ifFalse: [
				each veryDeepCopy killExistingChat
			]
		)
	].
	fullBounds := nil.
	self fullBounds.
	"htsBefore := submorphs collect: [ :each | each height]."

	fudge := 20.
	insetY := self layoutInset.
	insetY isPoint ifTrue: [insetY := insetY y].
	filler extent: 
		4 @ (self height - filler height * 0.37 - insetY - borderWidth - fudge) truncated.

	"self fixLayout.
	htsAfter := submorphs collect: [ :each | each height].
	{htsBefore. htsAfter} explore."

! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
toggleChoice: aString

	updateCounter := nil.		"force rebuild"
	aString = 'group' ifTrue: [^groupMode := (groupMode ifNil: [true]) not].
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 11:50'!
transmittedObjectCategory

	^EToyIncomingMessage typeFridge! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
trulyFlashIndicator: aSymbol

	| state |

	state := (self 
		valueOfProperty: #fridgeFlashingState
		ifAbsent: [false]) not.
	self setProperty: #fridgeFlashingState toValue: state.

	self 
		addMouseActionIndicatorsWidth: 15 
		color: (Color green alpha: (state ifTrue: [0.3] ifFalse: [0.7])). Beeper beep.
	"self world displayWorldSafely."! !


!EToyFridgeMorph methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:25'!
drawOn: aCanvas

	| f cache |
	f := self class fridgeForm ifNil: [^super drawOn: aCanvas].
	cache := Form extent: bounds extent depth: aCanvas depth.
	f
		displayInterpolatedIn: cache boundingBox truncated
		on: cache.
	cache replaceColor: Color black withColor: Color transparent.
	aCanvas 
		translucentImage: cache
		at: bounds origin.
! !


!EToyFridgeMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 7/12/2000 15:53'!
wantsDroppedMorph: aMorph event: evt

	^true! !


!EToyFridgeMorph methodsFor: 'event handling' stamp: 'sd 11/20/2005 21:25'!
handlesMouseDown: globalEvt

	| localCursorPoint |
	localCursorPoint := self globalPointToLocal: globalEvt cursorPoint.
	groupMode ifFalse: [
		self allMorphsDo: [ :each |
			(each isKindOf: EToySenderMorph) ifTrue: [
				(each bounds containsPoint: localCursorPoint) ifTrue: [^false].
			].
		].
	].
	^true! !

!EToyFridgeMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:47'!
handlesMouseOver: globalEvt

	^true! !

!EToyFridgeMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:51'!
handlesMouseOverDragging: globalEvt

	^true! !

!EToyFridgeMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:55'!
mouseDown: localEvt

	self addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7).
! !

!EToyFridgeMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:51'!
mouseEnter: evt

	^self mouseEnterEither: evt
! !

!EToyFridgeMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:51'!
mouseEnterDragging: evt

	^self mouseEnterEither: evt
! !

!EToyFridgeMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:53'!
mouseLeave: evt

	^self mouseLeaveEither: evt
! !

!EToyFridgeMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:54'!
mouseLeaveDragging: evt

	^self mouseLeaveEither: evt
! !

!EToyFridgeMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:55'!
mouseUp: localEvt

	(self containsPoint: localEvt cursorPoint) ifFalse: [^self].
	Project enterIfThereOrFind: 'Fridge'! !


!EToyFridgeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #raised! !

!EToyFridgeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 4! !

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

!EToyFridgeMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	groupMode := true.
	self listDirection: #topToBottom;
		 layoutInset: 10;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 setProperty: #normalBorderColor toValue: self borderColor;
		 setProperty: #flashingColors toValue: {Color red. Color yellow};
		 rebuild! !


!EToyFridgeMorph methodsFor: 'layout' stamp: 'sd 11/20/2005 21:25'!
acceptDroppingMorph: morphToDrop event: evt

	| outData |

	(morphToDrop isKindOf: NewHandleMorph) ifTrue: [		"don't send these"
		^morphToDrop rejectDropMorphEvent: evt
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we will keep a copy"
	(morphToDrop isKindOf: EToySenderMorph) ifTrue: [
		self class addRecipient: morphToDrop.
		^self rebuild
	].
	self stopFlashing.
	"7 mar 2001 - remove #veryDeepCopy"
	outData := morphToDrop eToyStreamedRepresentationNotifying: self.
	self resetIndicator: #working.
	self class fridgeRecipients do: [ :each |
		self transmitStreamedObject: outData to: each ipAddress
	].

! !


!EToyFridgeMorph methodsFor: 'stepping and presenter' stamp: 'RAA 7/13/2000 12:31'!
step

	super step.
	updateCounter = self class updateCounter ifFalse: [self rebuild].
! !

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

EToyFridgeMorph class
	instanceVariableNames: ''!

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
addRecipient: aSenderMorph

	self fridgeRecipients do: [ :each |
		aSenderMorph ipAddress = each ipAddress ifTrue: [^self]
	].
	self fridgeRecipients add: aSenderMorph.
	UpdateCounter := self updateCounter + 1
! !

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

	| fridgeFileName |

	fridgeFileName := 'fridge.form'.
	TheFridgeForm ifNotNil: [^TheFridgeForm].
	(FileDirectory default fileExists: fridgeFileName) ifFalse: [^nil].
	^TheFridgeForm := Form fromFileNamed: fridgeFileName.! !

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

	^FridgeRecipients ifNil: [FridgeRecipients := OrderedCollection new]! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
newItem: newMorph

	| theFridge fridgeWorld trialRect |

	theFridge := Project named: 'Fridge'.
	theFridge ifNil: [^self newItems add: newMorph].
	fridgeWorld := theFridge world.
	trialRect := fridgeWorld randomBoundsFor: newMorph.
	fridgeWorld 
		addMorphFront: (newMorph position: trialRect topLeft);
		startSteppingSubmorphsOf: newMorph
! !

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

	^NewItems ifNil: [NewItems := OrderedCollection new]! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
removeRecipientWithIPAddress: ipString

	FridgeRecipients := self fridgeRecipients reject: [ :each |
		ipString = each ipAddress
	].
	UpdateCounter := self updateCounter + 1
! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 19:22'!
updateCounter

	^UpdateCounter ifNil: [0]! !


!EToyFridgeMorph class methodsFor: 'parts bin' stamp: 'md 8/10/2006 11:53'!
descriptionForPartsBin

	^ self partName: 	'Fridge'
		categories:		#('Collaborative')
		documentation:	'A tool for sending objects to other Squeak users'! !
MorphicModel subclass: #EToyGateKeeperEntry
	instanceVariableNames: 'ipAddress accessAttempts lastTimes acceptableTypes latestUserName attempsDenied lastRequests'
	classVariableNames: 'KnownIPAddresses'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Experimental'!

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:42'!
acceptableTypes

	^acceptableTypes! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
dateAndTimeStringFrom: totalSeconds

	| dateAndTime |
	dateAndTime := Time dateAndTimeFromSeconds: totalSeconds.
	^dateAndTime first printString,' ',dateAndTime second printString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:51'!
fullInfoString

	^self latestUserName,
		' at ',
		ipAddress ,
		' attempts: ',
		accessAttempts printString,
		'/',
		attempsDenied printString,
		' last: ',
		(self lastIncomingMessageTimeString)
	 
"acceptableTypes"

 ! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 12:19'!
getChoice: aString

	^acceptableTypes includes: aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:33'!
ipAddress

	^ipAddress! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
ipAddress: aString

	ipAddress := aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:37'!
lastIncomingMessageTimeString

	lastRequests isEmpty ifTrue: [^'never'].
	^self dateAndTimeStringFrom: lastRequests first first
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:56'!
lastTimeChecked

	^self valueOfProperty: #lastTimeChecked
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:57'!
lastTimeChecked: aDateAndTimeInSeconds

	self setProperty: #lastTimeChecked toValue: aDateAndTimeInSeconds
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
lastTimeCheckedString

	| statusTime |
	statusTime := self valueOfProperty: #lastTimeChecked ifAbsent: [^'none'].
	^(self dateAndTimeStringFrom: statusTime)! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:49'!
latestUserName

	^latestUserName ifNil: ['???']! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
latestUserName: aString

	latestUserName := aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
requestAccessOfType: aString

	| ok |

	accessAttempts := accessAttempts + 1.
	lastRequests addFirst: {Time totalSeconds. aString}.
	lastRequests size > 10 ifTrue: [
		lastRequests := lastRequests copyFrom: 1 to: 10.
	].
	ok := (acceptableTypes includes: aString) or: [acceptableTypes includes: 'all'].
	ok ifFalse: [attempsDenied := attempsDenied + 1].
	^ok! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:10'!
statusReplyReceived: anArray

	self setProperty: #lastStatusReplyTime toValue: Time totalSeconds.
	self setProperty: #lastStatusReply toValue: anArray.! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
statusReplyReceivedString

	| statusTime |
	statusTime := self valueOfProperty: #lastStatusReplyTime ifAbsent: [^'none'].
	^(self dateAndTimeStringFrom: statusTime),' accepts:
', (self valueOfProperty: #lastStatusReply) asArray printString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:38'!
timeBetweenLastAccessAnd: currentTime

	lastRequests isEmpty ifTrue: [^0].
	^currentTime - lastRequests first first
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:39'!
toggleChoice: aString

	(acceptableTypes includes: aString) ifTrue: [
		acceptableTypes remove: aString ifAbsent: []
	] ifFalse: [
		acceptableTypes add: aString
	].! !


!EToyGateKeeperEntry methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize

	self flag: #bob.		"need to decide better initial types"

	super initialize.
	ipAddress := '???'.
	accessAttempts := attempsDenied := 0.
	lastRequests := OrderedCollection new.
	acceptableTypes := Set withAll: EToyIncomingMessage allTypes.

 ! !

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

EToyGateKeeperEntry class
	instanceVariableNames: ''!

!EToyGateKeeperEntry class methodsFor: 'new-morph participation' stamp: 'RAA 8/3/2000 07:48'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
EToyCommunicatorMorph subclass: #EToyGateKeeperMorph
	instanceVariableNames: 'counter'
	classVariableNames: 'KnownIPAddresses UpdateCounter'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Experimental'!
!EToyGateKeeperMorph commentStamp: '<historical>' prior: 0!
EToyGateKeeperMorph new open

"
I am used to control the types of connections a user is willing to allow.
"!
]style[(28 79)f4cblue;,f1!


!EToyGateKeeperMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:29'!
open

	self rebuild.
	self openInWorld.! !

!EToyGateKeeperMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 13:27'!
rebuild

	self removeAllMorphs.
	self addGateKeeperMorphs.
! !


!EToyGateKeeperMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #raised! !

!EToyGateKeeperMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 4! !

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

!EToyGateKeeperMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:42'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 layoutInset: 4;
		 hResizing: #spaceFill;
		 vResizing: #spaceFill;
		 useRoundedCorners;
		 rebuild ! !


!EToyGateKeeperMorph methodsFor: 'stepping and presenter' stamp: 'RAA 7/16/2000 13:28'!
step

	(self valueOfProperty: #gateKeeperCounterValue) = 
			EToyGateKeeperMorph updateCounter ifTrue: [^self].
	self rebuild.
! !

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

EToyGateKeeperMorph class
	instanceVariableNames: ''!

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
acceptRequest: requestType from: senderName at: ipAddressString

	| entry |

	UpdateCounter := self updateCounter + 1.
	entry := self entryForIPAddress: ipAddressString.
	senderName isEmpty ifFalse: [entry latestUserName: senderName].
	^entry requestAccessOfType: requestType! !

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:43'!
acceptableTypesFor: ipAddressString

	^(self knownIPAddresses at: ipAddressString ifAbsent: [^#()]) acceptableTypes! !

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
entryForIPAddress: ipAddressString

	| known entry |

	UpdateCounter := self updateCounter + 1.
	known := self knownIPAddresses.
	entry := known at: ipAddressString ifAbsentPut: [
		entry := EToyGateKeeperEntry new.
		entry ipAddress: ipAddressString.
		entry
	].
	^entry! !

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

	^KnownIPAddresses ifNil: [KnownIPAddresses := Dictionary new]! !

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

	^UpdateCounter ifNil: [UpdateCounter := 0]! !


!EToyGateKeeperMorph class methodsFor: 'new-morph participation' stamp: 'RAA 8/3/2000 07:48'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
AlignmentMorphBob1 subclass: #EToyGenericDialogMorph
	instanceVariableNames: 'namedFields'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 7/12/2003 12:33'!
genericTextFieldNamed: aString 
	| newField |
	newField := ShowEmptyTextMorph new beAllFont: self myFont;
				 extent: 400 @ 20;
				 contentsWrapped: ''.
	namedFields at: aString put: newField.
	^ newField! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:18'!
inAColumnForText: someMorphs 
	^ (self inAColumn: someMorphs) hResizing: #shrinkWrap;
		 color: ColorTheme current dialogTextBoxColor;
		 borderColor: ColorTheme current dialogTextBoxBorderColor;
		 borderWidth: ColorTheme current dialogButtonBorderWidth;
		 useRoundedCorners! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:13'!
lockedString: aString 
	^ self lockedString: aString font: self myFont! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:13'!
lockedString: aString font: aFont
	^ self inAColumn: {(StringMorph contents: aString font: aFont) lock}! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 7/12/2003 12:29'!
myFont
	^ Preferences standardEToysFont! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:53'!
rightLockedString: aString 
	^ self rightLockedString: aString font: self myFont! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:54'!
rightLockedString: aString font: aFont 

	^ self inARightColumn: {(StringMorph contents: aString font: aFont) lock}! !


!EToyGenericDialogMorph methodsFor: 'initialization' stamp: 'dgd 1/7/2005 19:18'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ ColorTheme current dialogBorderColor! !

!EToyGenericDialogMorph methodsFor: 'initialization' stamp: 'dgd 1/7/2005 19:19'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ ColorTheme current dialogBorderWidth! !

!EToyGenericDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:54'!
initialize
	"initialize the state of the receiver"
super initialize.
""
	namedFields _ Dictionary new.
	
	self rebuild! !

!EToyGenericDialogMorph methodsFor: 'initialization' stamp: 'jam 3/9/2003 18:05'!
rebuild
	"rebuilds the receiver"
	^ self! !
AbstractHierarchicalList subclass: #EToyHierarchicalTextGizmo
	instanceVariableNames: 'topNode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Outliner'!
!EToyHierarchicalTextGizmo commentStamp: '<historical>' prior: 0!
EToyHierarchicalTextGizmo example!


!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:53'!
addChild

	self addNewChildAfter: nil.
! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:52'!
addNewChildAfter: aNodeOrNil

	currentSelection addNewChildAfter: aNodeOrNil.
	self changed: #getList.! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:41'!
addSibling

	currentSelection addSibling.
	self changed: #getList.! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:29'!
deleteSelectedItem

	currentSelection delete.
	self changed: #getList.! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:57'!
expandAllBelow

	currentSelection withoutListWrapper withAllChildrenDo: [ :each |
		each setProperty: #showInOpenedState toValue: true
	].
	self changed: #getList.! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:57'!
genericMenu: aMenu

	| menu |

	currentSelection ifNil: [
		aMenu add: '*nothing selected*' target: self selector: #yourself.
		^aMenu
	].
	menu _ DumberMenuMorph new defaultTarget: self.
	menu 
		add: 'expand all below me' target: self selector: #expandAllBelow;
		add: 'addChild' target: self selector: #addChild;
		add: 'delete' target: self  selector: #deleteSelectedItem.
	^ menu! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:50'!
getList

	^Array with: (EToyTextNodeWrapper with: topNode model: self parent: nil)
! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 10:36'!
inAWindow
	| window  |

	window _ (SystemWindow labelled: 'HText') model: self.
	window 
		addMorph: self notInAWindow
		frame: (0@0 corner: 1@1).
     ^ window! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:43'!
notInAWindow
	| listMorph |

	(listMorph _ EToyHierarchicalTextMorph 
		on: self
		list: #getList
		selected: #getCurrentSelection
		changeSelected: #noteNewSelection:
		menu: #genericMenu:
		keystroke: nil).
	listMorph autoDeselect: false.
     ^ listMorph! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 00:40'!
topNode: aTextNode

	topNode _ aTextNode! !

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

EToyHierarchicalTextGizmo class
	instanceVariableNames: ''!

!EToyHierarchicalTextGizmo class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 14:28'!
example
"
EToyHierarchicalTextGizmo example
"

	(EToyHierarchicalTextGizmo new 
		topNode: EToyTextNode newNode;
		notInAWindow) openInWorld! !
SimpleHierarchicalListMorph subclass: #EToyHierarchicalTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Outliner'!

!EToyHierarchicalTextMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 02:08'!
adjustSubmorphPositions

	| p h w |

	p _ 0@0.
	w _ self width.
	scroller submorphsDo: [ :each |
		h _ each position: p andWidth: w.
		p _ p + (0@h)
	].
	self 
		changed;
		layoutChanged;
		setScrollDeltas.
! !

!EToyHierarchicalTextMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 22:20'!
indentingItemClass

	^IndentingListParagraphMorph! !


!EToyHierarchicalTextMorph methodsFor: 'event handling' stamp: 'RAA 7/30/2000 15:05'!
keyStroke: evt

	selectedMorph ifNil: [^self].
	selectedMorph keyStroke: evt
! !


!EToyHierarchicalTextMorph methodsFor: 'geometry' stamp: 'RAA 7/30/2000 01:50'!
extent: aPoint

	| wasDifferent |
	wasDifferent _ self extent ~= aPoint.
	super extent: aPoint.
	wasDifferent ifTrue: [self adjustSubmorphPositions].! !


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

!EToyHierarchicalTextMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:27'!
initialize
	"initialize the state of the receiver"
	super initialize.
	self useRoundedCorners! !


!EToyHierarchicalTextMorph methodsFor: 'selection' stamp: 'RAA 7/30/2000 10:05'!
selectedMorph: aMorph

	selectedMorph == aMorph ifTrue: [^self].
	self unhighlightSelection.
	selectedMorph _ aMorph.
	self highlightSelection! !

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

EToyHierarchicalTextMorph class
	instanceVariableNames: ''!

!EToyHierarchicalTextMorph class methodsFor: 'instance creation' stamp: 'RAA 8/8/2000 14:34'!
new

	| listMorph model |

	model _ EToyHierarchicalTextGizmo new 
		topNode: EToyTextNode newNode.
	(listMorph _ EToyHierarchicalTextMorph 
		on: model
		list: #getList
		selected: #getCurrentSelection
		changeSelected: #noteNewSelection:
		menu: #genericMenu:
		keystroke: nil).
	listMorph autoDeselect: false.
     ^ listMorph! !

!EToyHierarchicalTextMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self basicNew initialize
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel
! !
Object subclass: #EToyIncomingMessage
	instanceVariableNames: ''
	classVariableNames: 'MessageHandlers MessageTypes'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Experimental'!

!EToyIncomingMessage methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
incomingMessgage: dataStream fromIPAddress: ipAddress

	| nullChar messageType senderName  selectorAndReceiver |

	nullChar := 0 asCharacter.
	messageType := dataStream upTo: nullChar.
	senderName := dataStream upTo: nullChar.
	(EToyGateKeeperMorph acceptRequest: messageType from: senderName at: ipAddress) ifFalse: [
		^self
	].
	selectorAndReceiver := self class messageHandlers at: messageType ifAbsent: [^self].
	^selectorAndReceiver second 
		perform: selectorAndReceiver first 
		withArguments: {dataStream. senderName. ipAddress}

! !

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

EToyIncomingMessage class
	instanceVariableNames: ''!

!EToyIncomingMessage class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 13:21'!
forType: aMessageType send: aSymbol to: anObject

	self messageHandlers at: aMessageType put: {aSymbol. anObject}! !

!EToyIncomingMessage class methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 07:52'!
initializeMessageHandlers

	self
		forType: self typeMorph 
		send: #handleNewMorphFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeFridge 
		send: #handleNewFridgeMorphFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeKeyboardChat 
		send: #handleNewChatFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeMultiChat 
		send: #handleNewMultiChatFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeStatusRequest 
		send: #handleNewStatusRequestFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeStatusReply 
		send: #handleNewStatusReplyFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeSeeDesktop 
		send: #handleNewSeeDesktopFrom:sentBy:ipAddress: 
		to: self.


! !

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

	^MessageHandlers ifNil: [MessageHandlers := Dictionary new].! !

!EToyIncomingMessage class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
newObjectFromStream: dataStream

	| newObject |

	[newObject := SmartRefStream objectFromStreamedRepresentation: dataStream upToEnd.]
		on: ProgressInitiationException
		do: [ :ex | 
			ex sendNotificationsTo: [ :min :max :curr |
				"self flashIndicator: #working."
			].
		].
	"self resetIndicator: #working."
	^newObject
! !


!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:32'!
handleNewChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	^ EToyChatMorph 
		chatFrom: ipAddressString 
		name: senderName 
		text: (self newObjectFromStream: dataStream).
	! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'sd 11/20/2005 21:26'!
handleNewFridgeMorphFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	| newObject |

	newObject := self newObjectFromStream: dataStream.
	newObject
		setProperty: #fridgeSender toValue: senderName;
		setProperty: #fridgeIPAddress toValue: ipAddressString;
		setProperty: #fridgeDate toValue: Time dateAndTimeNow.
	WorldState addDeferredUIMessage: [EToyFridgeMorph newItem: newObject] fixTemps.
	! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'sd 11/20/2005 21:26'!
handleNewMorphFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	| newObject thumbForm targetWorld |

	newObject := self newObjectFromStream: dataStream.
	EToyCommunicatorMorph playArrivalSound.
	targetWorld := self currentWorld.
	(EToyMorphsWelcomeMorph morphsWelcomeInWorld: targetWorld) ifTrue: [
		newObject position: (
			newObject 
				valueOfProperty: #positionInOriginatingWorld 
				ifAbsent: [(targetWorld randomBoundsFor: newObject) topLeft]
		).
		WorldState addDeferredUIMessage: [
			newObject openInWorld: targetWorld.
		] fixTemps.
		^self
	].
	thumbForm := newObject imageForm scaledToSize: 50@50.
	EToyListenerMorph addToGlobalIncomingQueue: {
		thumbForm. newObject. senderName. ipAddressString
	}.
	WorldState addDeferredUIMessage: [
		EToyListenerMorph ensureListenerInCurrentWorld
	] fixTemps.
! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/17/2000 09:22'!
handleNewMultiChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	^ EToyMultiChatMorph 
		chatFrom: ipAddressString 
		name: senderName 
		text: (self newObjectFromStream: dataStream).
	! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:34'!
handleNewSeeDesktopFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	"more later"

	^ EToyChatMorph 
		chatFrom: ipAddressString 
		name: senderName 
		text: ipAddressString,' would like to see your desktop'.
	! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:34'!
handleNewStatusReplyFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	(EToyGateKeeperMorph entryForIPAddress: ipAddressString) statusReplyReceived: (
		self newObjectFromStream: dataStream
	)
! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:34'!
handleNewStatusRequestFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	"more later"

	^ EToyChatMorph 
		chatFrom: ipAddressString 
		name: senderName 
		text: ipAddressString,' would like to know if you are available'.
	! !


!EToyIncomingMessage class methodsFor: 'message types' stamp: 'sd 11/20/2005 21:26'!
allTypes

	^MessageTypes ifNil: [
		MessageTypes := {
			self typeKeyboardChat.
			self typeMorph.
			self typeFridge.
			self typeStatusRequest.
			self typeStatusReply.
			self typeSeeDesktop.
			self typeAudioChat.
			self typeAudioChatContinuous.
			self typeMultiChat.
		}
	]
! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'sd 11/20/2005 21:26'!
registerType: aMessageType

	MessageTypes := self allTypes copyWith: aMessageType! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 13:20'!
typeAudioChat

	^'audiochat'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/5/2000 19:21'!
typeAudioChatContinuous

	^'audiochat2'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:49'!
typeFridge

	^'fridge'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:46'!
typeKeyboardChat

	^'chat'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:59'!
typeMorph

	^'morph'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/17/2000 07:41'!
typeMultiChat

	^'multichat'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:56'!
typeSeeDesktop

	^'seedesktop'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:53'!
typeStatusReply

	^'statusreply'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:51'!
typeStatusRequest

	^'statusrequest'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'sd 11/20/2005 21:26'!
unregisterType: aMessageType

	MessageTypes := self allTypes copyWithout: aMessageType! !
EToyCommunicatorMorph subclass: #EToyListenerMorph
	instanceVariableNames: 'listener updateCounter'
	classVariableNames: 'GlobalIncomingQueue GlobalListener QueueSemaphore UpdateCounter WasListeningAtShutdown'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Collaborative'!
!EToyListenerMorph commentStamp: '<historical>' prior: 0!
EToyListenerMorph new open
EToyListenerMorph startListening.
EToyListenerMorph stopListening.

"
EToyListenerMorph listens for messgaes from other EToy communicators. You need one of these open to receive messages from elsewhere.
- Received Morphs are shown in a list. Items can be grabbed (a copy) or deleted.
- Chat messages are sent to an appropriate EToyChatMorph (created if necessary)
"

!
]style[(45 16 18 15 1 299)cblue;f3,bf3,cblue;f3,bf3,cblue;f3,f1!


!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
addNewObject: newObject thumbForm: aForm sentBy: senderName ipAddress: ipAddressString

	| thumb row |

	thumb := aForm asMorph.
	thumb setProperty: #depictedObject toValue: newObject.
	row := self addARow: {
		thumb. 
		self inAColumn: {
			StringMorph new contents: senderName; lock.
			StringMorph new contents: ipAddressString; lock.
		}
	}.
	true ifTrue: [	"simpler protocol"
		row on: #mouseUp send: #mouseUpEvent:for: to: self.
	] ifFalse: [
		row on: #mouseDown send: #mouseDownEvent:for: to: self.
	].

! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 18:59'!
mouseDownEvent: event for: aMorph 
	| menu selection depictedObject |
	depictedObject := aMorph firstSubmorph valueOfProperty: #depictedObject.
	menu := CustomMenu new.
	menu
		add: 'Grab' action: [event hand attachMorph: depictedObject veryDeepCopy];
		add: 'Delete'
			action: 
				[self class removeFromGlobalIncomingQueue: depictedObject.
				self rebuild].
	selection := menu build startUpCenteredWithCaption: 'Morph from ' 
						, (aMorph submorphs second) firstSubmorph contents.
	selection ifNil: [^self].
	selection value! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
mouseUpEvent: event for: aMorph

	| depictedObject |

	depictedObject := aMorph firstSubmorph valueOfProperty: #depictedObject.
	event hand attachMorph: depictedObject.
	self class removeFromGlobalIncomingQueue: depictedObject.
	self rebuild.
! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
rebuild

	| earMorph |
	updateCounter := UpdateCounter.
	self removeAllMorphs.
	self addGateKeeperMorphs.
	GlobalListener ifNil: [
		earMorph := (self class makeListeningToggleNew: false) asMorph.
		earMorph setBalloonText: 'Click to START listening for messages'.
		earMorph on: #mouseUp send: #startListening to: self.
	] ifNotNil: [
		earMorph := (self class makeListeningToggleNew: true) asMorph.
		earMorph setBalloonText: 'Click to STOP listening for messages'.
		earMorph on: #mouseUp send: #stopListening to: self.
	].
	self addARow: {self inAColumn: {earMorph}}.
	self
		addARow: {
			self inAColumn: {(StringMorph contents: 'Incoming communications') lock}.
			self indicatorFieldNamed: #working color: Color blue help: 'working'.
			self indicatorFieldNamed: #communicating color: Color green help: 'receiving'.
		}.
	"{thumbForm. newObject. senderName. ipAddressString}"
	self class globalIncomingQueueCopy do: [ :each |
		self
			addNewObject: each second 
			thumbForm: each first 
			sentBy: each third 
			ipAddress: each fourth.
	].! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:23'!
startListening

	self class startListening! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:23'!
stopListening

	self class stopListening! !


!EToyListenerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color blue! !

!EToyListenerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 4! !

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

!EToyListenerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:44'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 layoutInset: 4;
		 rebuild ! !


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

	| needRebuild |
	super step.
	needRebuild := false.
	(self valueOfProperty: #gateKeeperCounterValue) = 
			EToyGateKeeperMorph updateCounter ifFalse: [needRebuild := true].
	updateCounter = UpdateCounter ifFalse: [
		needRebuild := true.
	].
	needRebuild ifTrue: [self rebuild].
! !


!EToyListenerMorph methodsFor: 'submorphs-add/remove' stamp: 'sd 11/20/2005 21:25'!
delete

	listener ifNotNil: [listener stopListening. listener := nil].	
					"for old instances that were locally listening"
	super delete.! !

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

EToyListenerMorph class
	instanceVariableNames: ''!

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:24'!
addToGlobalIncomingQueue: aMorphTuple

	self critical: [
		self globalIncomingQueue add: aMorphTuple.
		self bumpUpdateCounter.
	].! !

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

	UpdateCounter := (UpdateCounter ifNil: [0]) + 1.
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/6/2000 11:48'!
commResult: anArrayOfAssociations

	WorldState addDeferredUIMessage: [self commResultDeferred: anArrayOfAssociations].! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
commResultDeferred: anArrayOfAssociations

	| m ipAddress aDictionary |

	"to be run as part of the UI process in case user interaction is required"

	aDictionary := Dictionary new.
	anArrayOfAssociations do: [ :each | aDictionary add: each].
	
	aDictionary at: #commFlash ifPresent: [ :ignore | ^self].
	m := aDictionary at: #message ifAbsent: [^self].
	m = 'OK' ifFalse: [^self].
	ipAddress := NetNameResolver stringFromAddress: (aDictionary at: #ipAddress).

	EToyIncomingMessage new 
		incomingMessgage: (ReadStream on: (aDictionary at: #data)) 
		fromIPAddress: ipAddress

	! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 18:05'!
confirmListening

	self isListening ifFalse: [
		(self confirm: 'You currently are not listening and will not hear a reply.
Shall I start listening for you?') ifTrue: [
			self startListening
		].
	].
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
critical: aBlock

	QueueSemaphore ifNil: [QueueSemaphore := Semaphore forMutualExclusion].
	^QueueSemaphore critical: aBlock
! !

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

	| w |
	w := self currentWorld.
	EToyListenerMorph allInstances 
		detect: [ :each | each world == w]
		ifNone: [EToyListenerMorph new open]! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 12:46'!
flashIndicator: ignoredForNow! !

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

	^GlobalIncomingQueue ifNil: [GlobalIncomingQueue := OrderedCollection new].! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 14:13'!
globalIncomingQueueCopy

	^self critical: [self globalIncomingQueue copy].
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 17:56'!
isListening

	^GlobalListener notNil
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
makeListeningToggle: withEars

	| background c capExtent bgExtent earExtent earDeltaX earDeltaY botCent factor parts |

	factor := 2.
	bgExtent := (50@25) * factor.
	capExtent := (30@30) * factor.
	earExtent := (15@15) * factor.
	earDeltaX := capExtent x // 2.
	earDeltaY := capExtent y // 2.
	background := Form extent: bgExtent depth: 8.
	botCent := background boundingBox bottomCenter.
	c := background getCanvas.
	"c fillColor: Color white."
	parts := {
		(botCent - (capExtent // 2)) extent: capExtent.
	}.
	withEars ifTrue: [
		parts := parts , {
			(botCent - (earDeltaX @ earDeltaY) - (earExtent // 2)) extent: earExtent.
			(botCent - (earDeltaX negated @ earDeltaY) - (earExtent // 2)) extent: earExtent.
		} 
	].
	parts do: [ :each |
		c
			fillOval: each
			color: Color black 
			borderWidth: 0 
			borderColor: Color black.
	].
	^background

"=====
	f2 := Form extent: 30@15 depth: 8.
	background displayInterpolatedOn: f2.
	f2 replaceColor: Color white withColor: Color transparent.
	^f2
====="


	! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
makeListeningToggleNew: activeMode

	| background c baseExtent bgExtent botCent factor len endPts base |

	factor := 2.
	bgExtent := (50@25) * factor.
	baseExtent := (15@15) * factor.
	background := Form extent: bgExtent depth: 8.
	botCent := background boundingBox bottomCenter.
	c := background getCanvas.
"c fillColor: Color white."
	base :=  (botCent - (baseExtent // 2)) extent: baseExtent.
	c
		fillOval: base
		color: Color black 
		borderWidth: 0 
		borderColor: Color black.
	activeMode ifTrue: [
		len := background boundingBox height - 15.
		endPts := {botCent - (len@len). botCent - (len negated@len)}.
		endPts do: [ :each |
			c line: botCent to: each width: 2 color: Color black.
		].
		endPts do: [ :each |
			#(4 8 12) do: [ :offset |
				c frameOval: (each - offset corner: each + offset) color: Color red
			].
		].
	].
"background asMorph openInWorld."
	^background


	! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
removeFromGlobalIncomingQueue: theActualObject

	self critical: [
		GlobalIncomingQueue := self globalIncomingQueue reject: [ :each | 
			each second == theActualObject
		].
		self bumpUpdateCounter.
	].! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 12:47'!
resetIndicator: ignoredForNow! !

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

	self stopListening.
	GlobalListener := EToyPeerToPeer new awaitDataFor: self.
	self bumpUpdateCounter.

! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
stopListening
	GlobalListener ifNotNil:
		[GlobalListener stopListening.
		GlobalListener := nil.
		self bumpUpdateCounter]

	"EToyListenerMorph stopListening"! !


!EToyListenerMorph class methodsFor: 'class initialization' stamp: 'RAA 7/25/2000 16:28'!
initialize
"
EToyListenerMorph initialize
"
	
	Smalltalk addToStartUpList: self.
	Smalltalk addToShutDownList: self.
! !

!EToyListenerMorph class methodsFor: 'class initialization' stamp: 'ads 7/18/2003 09:07'!
unload
	Smalltalk removeFromStartUpList: self.
	Smalltalk removeFromShutDownList: self.
! !


!EToyListenerMorph class methodsFor: 'parts bin' stamp: 'md 8/10/2006 11:54'!
descriptionForPartsBin

	^ self partName: 	'Listener'
		categories:		#('Collaborative')
		documentation:	'A tool for receiving things from other Squeak users'! !


!EToyListenerMorph class methodsFor: 'system startup' stamp: 'sd 11/20/2005 21:26'!
shutDown: quitting

	WasListeningAtShutdown := GlobalListener notNil.
	self stopListening.
! !

!EToyListenerMorph class methodsFor: 'system startup' stamp: 'RAA 7/25/2000 16:27'!
startUp: resuming

	WasListeningAtShutdown == true ifTrue: [
		self startListening.
	].
! !
EToyCommunicatorMorph subclass: #EToyMorphsWelcomeMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Collaborative'!
!EToyMorphsWelcomeMorph commentStamp: '<historical>' prior: 0!
EToyMorphsWelcomeMorph new openInWorld!


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

!EToyMorphsWelcomeMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize
	"initialize the state of the receiver"
	| earMorph |
	super initialize.
	""
	
	self layoutInset: 8 @ 8.
	"earMorph := (EToyListenerMorph makeListeningToggle: true)  
	asMorph."
	earMorph := TextMorph new contents: 'Morphs
welcome
here';
				 fontName: Preferences standardEToysFont familyName size: 18;
				 centered;
				 lock.
	self addARow: {earMorph}.
	self setBalloonText: 'My presence in this world means received morphs may appear automatically'! !

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

EToyMorphsWelcomeMorph class
	instanceVariableNames: ''!

!EToyMorphsWelcomeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 13:44'!
morphsWelcomeInWorld: aWorld

	^self allInstances anySatisfy: [ :each | each world == aWorld]! !


!EToyMorphsWelcomeMorph class methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 12:52'!
descriptionForPartsBin

	^ self partName: 	'Welcome'
		categories:		#('Collaborative')
		documentation:	'A sign that you accept morphs dropped directly into your world'! !
EToyChatMorph subclass: #EToyMultiChatMorph
	instanceVariableNames: 'targetIPAddresses'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Collaborative'!

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
acceptTo: someText forMorph: aMorph

	| streamedMessage betterText |

	betterText := self improveText: someText forMorph: aMorph.
	streamedMessage := {targetIPAddresses. betterText} eToyStreamedRepresentationNotifying: self.
	targetIPAddresses do: [ :each |
		self 
			transmitStreamedObject: streamedMessage
			to: each.
	].
	aMorph setText: '' asText.
	self appendMessage: 
		self startOfMessageFromMe,
		' - ',
		betterText,
		String cr.

	^true! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 09:01'!
chatFrom: ipAddress name: senderName text: textPackage

	super chatFrom: ipAddress name: senderName text: textPackage second.
	self updateIPAddressField: (
		targetIPAddresses,textPackage first,{ipAddress} 
			copyWithout: NetNameResolver localAddressString
	).
! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
editEvent: anEvent for: aMorph

	| answer initialText aFillInTheBlankMorph |

	(aMorph bounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
	initialText := String streamContents: [ :strm |
		targetIPAddresses do: [ :each | strm nextPutAll: each; cr].
	].
	aFillInTheBlankMorph := FillInTheBlankMorph new
		setQuery: 'Who are you chatting with?'
		initialAnswer: initialText
		answerHeight: 250
		acceptOnCR: false.
	aFillInTheBlankMorph responseUponCancel: nil.
	self world addMorph: aFillInTheBlankMorph centeredNear: anEvent cursorPoint.
	answer := aFillInTheBlankMorph getUserResponse.
	answer ifNil: [^self].
	self updateIPAddressField: (answer findTokens: ' ',String cr).

! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
rebuild
	| r1 r2 |

	r1 := self addARow: {
		self simpleToggleButtonFor: self attribute: #acceptOnCR help: 'Send with Return?'.
		self inAColumn: {StringMorph new contents: 'Multi chat with:'; lock}.
		self textEntryFieldNamed: #ipAddress with: ''
					help: 'Click to edit participant list'.
	}.
	sendingPane := PluggableTextMorph
				on: self
				text: nil
				accept: #acceptTo:forMorph:.
	sendingPane hResizing: #spaceFill; vResizing: #spaceFill.
	self
		addMorphBack: sendingPane.
	r2 := self addARow: {self inAColumn: {StringMorph new contents: 'Replies'; lock}}.
	receivingPane := PluggableTextMorph
				on: self
				text: nil
				accept: nil.
	receivingPane hResizing: #spaceFill; vResizing: #spaceFill.
	self
		addMorphBack: receivingPane.
	receivingPane spaceFillWeight: 3.
	{r1. r2} do: [ :each |
		each
			vResizing: #shrinkWrap; minHeight: 18;
			color: Color veryLightGray.
	].
	self updateIPAddressField: targetIPAddresses.
	sendingPane acceptOnCR: (acceptOnCR ifNil: [acceptOnCR := true]).! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 08:53'!
standardBorderColor

	^Color veryLightGray! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 07:44'!
transmittedObjectCategory

	^EToyIncomingMessage typeMultiChat! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
updateIPAddressField: newAddresses
	
	targetIPAddresses := (
		newAddresses copyWithout: NetNameResolver localAddressString
	) 
		asSet 
		asSortedCollection 
		asArray.

	(fields at: #ipAddress) contents: targetIPAddresses size printString,' people'.! !


!EToyMultiChatMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 8/17/2000 09:04'!
wantsDroppedMorph: aMorph event: evt

	(aMorph isKindOf: EToySenderMorph) ifFalse: [^false].
	(bounds containsPoint: evt cursorPoint) ifFalse: [^false].
	^true.! !


!EToyMultiChatMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize

	targetIPAddresses := OrderedCollection new.
	super initialize.
	bounds := 0@0 extent: 350@350.! !


!EToyMultiChatMorph methodsFor: 'layout' stamp: 'ar 10/5/2000 19:24'!
acceptDroppingMorph: morphToDrop event: evt

	(morphToDrop isKindOf: EToySenderMorph) ifFalse: [
		^morphToDrop rejectDropMorphEvent: evt.
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we don't really want it"
	self updateIPAddressField: targetIPAddresses,{morphToDrop ipAddress}.

! !

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

EToyMultiChatMorph class
	instanceVariableNames: ''!

!EToyMultiChatMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 08:53'!
chatWindowForIP: ipAddress name: senderName picture: aForm inWorld: aWorld

	^self allInstances 
		detect: [ :x | x world == aWorld] 
		ifNone: [
			EToyCommunicatorMorph playArrivalSound.
			self new open
		].

! !


!EToyMultiChatMorph class methodsFor: 'parts bin' stamp: 'RAA 1/28/2002 15:32'!
descriptionForPartsBin

	^ self partName: 	'Text chat+'
		categories:		#('Collaborative')
		documentation:	'A tool for sending messages to several Squeak users at once'
		sampleImageForm: (Form
	extent: 25@25
	depth: 16
	fromArray: #( 1177640695 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593245696 1593263665 1593270007 1593270007 1593270007 1177634353 1177628012 1177628012 1177640695 1593270007 1593270007 1593278463 2147450879 1316159488 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593274233 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1731723264 1593257324 762064236 762064236 762064236 762064236 762057894 762057894 762064236 762064236 762064236 762064236 762064236 1177616384 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593274233 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1731723264)
	offset: 0@0)! !
Object subclass: #EToyPeerToPeer
	instanceVariableNames: 'socket communicatorMorph process ipAddress connectionQueue dataQueue remoteSocketAddress leftOverData'
	classVariableNames: 'DEBUG PREVTICK'
	poolDictionaries: ''
	category: 'Nebraska-Network-EToy Communications'!

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'sd 11/20/2005 21:25'!
awaitDataFor: aCommunicatorMorph

	Socket initializeNetwork.
	connectionQueue := ConnectionQueue 
		portNumber: self class eToyCommunicationsPort 
		queueLength: 6.
	communicatorMorph := aCommunicatorMorph.
	process := [self doAwaitData] newProcess.
	process priority: Processor highIOPriority.
	process resume.
! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'sd 11/20/2005 21:25'!
doAwaitData

	[true] whileTrue: [
		socket := connectionQueue getConnectionOrNilLenient.
		socket ifNil: [
			(Delay forMilliseconds: 50) wait
		] ifNotNil: [
			self class new receiveDataOn: socket for: communicatorMorph
		]
	].
! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'sd 11/20/2005 21:25'!
doReceiveData

	| answer |

	[answer := self doReceiveOneMessage] 
		on: Error
		do: [ :ex | 
			communicatorMorph commResult: {#message -> (ex description,' ',socket printString)}.
			^false
		].
	communicatorMorph commResult: {
		#message -> 'OK'. 
		#data -> answer .
		#ipAddress -> remoteSocketAddress.
	}.
	^answer size > 0

! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'sd 11/20/2005 21:25'!
doReceiveOneMessage

	| awaitingLength i length answer |

	awaitingLength := true.
	answer := WriteStream on: String new.
	[awaitingLength] whileTrue: [
		leftOverData := leftOverData , socket receiveData.
		(i := leftOverData indexOf: $ ) > 0 ifTrue: [
			awaitingLength := false.
			length := (leftOverData first: i - 1) asNumber.
			answer nextPutAll: (leftOverData allButFirst: i).
		].
	].
	leftOverData := ''.
	[answer size < length] whileTrue: [
		answer nextPutAll: socket receiveData.
		communicatorMorph commResult: {#commFlash -> true}.
	].
	answer := answer contents.
	answer size > length ifTrue: [
		leftOverData := answer allButFirst: length.
		answer := answer first: length
	].
	^answer

! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'sd 11/20/2005 21:25'!
receiveDataOn: aSocket for: aCommunicatorMorph

	socket := aSocket.
	remoteSocketAddress := socket remoteAddress.
	communicatorMorph := aCommunicatorMorph.
	process := [
		leftOverData := ''.
		[self doReceiveData] whileTrue.
		socket closeAndDestroy.
	] newProcess.
	process priority: Processor highIOPriority.
	process resume.
! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'sd 11/20/2005 21:25'!
stopListening

	process ifNotNil: [process terminate. process := nil].
	connectionQueue ifNotNil: [connectionQueue destroy. connectionQueue := nil].

! !


!EToyPeerToPeer methodsFor: 'sending' stamp: 'sd 11/20/2005 21:25'!
doConnectForSend

	| addr |

	addr := NetNameResolver addressForName: ipAddress.
	addr ifNil: [
		communicatorMorph commResult: {#message -> ('could not find ',ipAddress)}.
		^false
	].
	socket connectNonBlockingTo: addr port: self class eToyCommunicationsPort.
	[socket waitForConnectionFor: 15]
		on: ConnectionTimedOut
		do: [:ex |
			communicatorMorph commResult: {#message -> ('no connection to ',ipAddress,' (',
				(NetNameResolver stringFromAddress: addr),')')}.
			^false].
	^true

! !

!EToyPeerToPeer methodsFor: 'sending' stamp: 'sd 11/20/2005 21:25'!
doSendData

	| totalLength myData allTheData |

	myData := dataQueue next ifNil: [socket sendData: '0 '. ^false].
	totalLength := (myData collect: [ :x | x size]) sum.
	socket sendData: totalLength printString,' '.
	allTheData := WriteStream on: (String new: totalLength).
	myData do: [ :chunk | allTheData nextPutAll: chunk asString].
	NebraskaDebug at: #peerBytesSent add: {totalLength}.
	self sendDataCautiously: allTheData contents.
	^true

! !

!EToyPeerToPeer methodsFor: 'sending' stamp: 'sd 11/20/2005 21:25'!
sendDataCautiously: aStringOrByteArray
	"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent. Try not to send too much at once since this seemed to cause problems talking to a port on the same machine"

	| bytesSent bytesToSend count |

	bytesToSend := aStringOrByteArray size.
	bytesSent := 0.
	[bytesSent < bytesToSend] whileTrue: [
		count := socket 
			sendSomeData: aStringOrByteArray 
			startIndex: bytesSent + 1  
			count: (bytesToSend - bytesSent min: 4000).
		bytesSent := bytesSent + count.
		communicatorMorph commResult: {#commFlash -> true}.
		(Delay forMilliseconds: 10) wait.
	].
	^ bytesSent
! !

!EToyPeerToPeer methodsFor: 'sending' stamp: 'sd 11/20/2005 21:25'!
sendSomeData: arrayOfByteObjects to: anIPAddress for: aCommunicatorMorph

	dataQueue := self 
		sendSomeData: arrayOfByteObjects 
		to: anIPAddress 
		for: aCommunicatorMorph 
		multiple: false.
	dataQueue nextPut: nil.		"only this message to send"
! !

!EToyPeerToPeer methodsFor: 'sending' stamp: 'sd 11/20/2005 21:25'!
sendSomeData: arrayOfByteObjects to: anIPAddress for: aCommunicatorMorph multiple: aBoolean

	Socket initializeNetwork.
	socket := Socket newTCP.
	dataQueue := SharedQueue new.
	dataQueue nextPut: arrayOfByteObjects.
	communicatorMorph := aCommunicatorMorph.
	ipAddress := anIPAddress.
	process := [
		self doConnectForSend ifTrue: [
			[self doSendData] whileTrue.
			communicatorMorph commResult: {#message -> 'OK'}.
			socket closeAndDestroy.
		].
	] newProcess.
	process priority: Processor highIOPriority.
	process resume.
	^dataQueue
! !

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

EToyPeerToPeer class
	instanceVariableNames: ''!

!EToyPeerToPeer class methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 06:21'!
eToyCommunicationsPort

	^34151		"picked at random"! !

!EToyPeerToPeer class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
transmitStreamedObject: outData as: objectCategory to: anIPAddress for: aCommunicator

	| null |
	null := String with: 0 asCharacter.
	self new 
		sendSomeData: {
			objectCategory,null. 
			Preferences defaultAuthorName,null.
			outData
		}
		to: anIPAddress
		for: aCommunicator

! !
EToyProjectRenamerMorph subclass: #EToyProjectDetailsMorph
	instanceVariableNames: 'projectDetails'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'ar 2/23/2001 20:56'!
copyOutDetails

	| newDetails |

	newDetails _ Dictionary new.
	self fieldToDetailsMappings do: [ :each |
		namedFields at: each first ifPresent: [ :field |
			newDetails at: each second put: field contents string
		].
	].
	namedFields at: 'projectname' ifPresent: [ :field |
		newDetails at: 'projectname' put: field contents string withBlanksTrimmed.
	].
	^newDetails! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/20/2000 09:45'!
doExpand

	self expandedFormat: true.
	self copyOutDetails.
	self rebuild.
! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 12:43'!
doOK

	self validateTheProjectName ifFalse: [^false].
	actionBlock value: self copyOutDetails.
	self delete.! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'yo 2/23/2005 17:24'!
expandButton

	^self
		buttonNamed: 'More' translated
		action: #doExpand 
		color: self buttonColor 
		help: 'Show more info on this project.' translated.
! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'dgd 3/16/2004 12:10'!
expandedFormat

	^ Preferences expandedPublishing
			or: [self valueOfProperty: #expandedFormat ifAbsent: [false]]
! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/20/2000 09:40'!
expandedFormat: aBoolean

	self setProperty: #expandedFormat toValue: aBoolean! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:33'!
fieldToDetailsMappings

	^#(
		(#description 'projectdescription' 'Description:' 100) 
		(#author 'projectauthor' 'Author:' 20) 
		(#category 'projectcategory' 'Category:' 20)
		(#subCategory 'projectsubcategory' 'Sub-category:' 20)
		(#keywords 'projectkeywords' 'Key words:' 20)
	)
! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:55'!
fillInDetails

	theProject ifNotNil: [
		namedFields at: 'projectname' ifPresent: [ :field |
			field contentsWrapped: theProject name
		].
	].
	projectDetails ifNotNil: [
		self fieldToDetailsMappings do: [ :each |
			namedFields at: each first ifPresent: [ :field |
				projectDetails at: each second ifPresent: [ :data |
					field contentsWrapped: data
				].
			].
		].
	].! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 12:45'!
project: aProject actionBlock: aBlock

	theProject _ aProject.
	actionBlock _ aBlock.
	projectDetails _ theProject world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new]! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 11:08'!
projectDetails: aDictionary

	projectDetails _ aDictionary.! !


!EToyProjectDetailsMorph methodsFor: 'initialization' stamp: 'dgd 11/3/2004 17:55'!
rebuild

	| bottomButtons |

	self removeAllMorphs.

	self addARow: {
		self
			lockedString: 'Please describe this project' translated
			font: Preferences standardEToysTitleFont.
	}.

	self addARow: {self space }.

	self addARow: {
		self rightLockedString: 'Name:' translated.
		self inAColumnForText: {self fieldForProjectName}
	}.

	self expandedFormat ifTrue: [
		self fieldToDetailsMappings do: [ :each |
			self addARow: {
				self rightLockedString: each third translated.
				self inAColumnForText: {(self genericTextFieldNamed: each first) height: each fourth}
			}.
		].
	].
	self addARow: {self space }.

	bottomButtons _ self expandedFormat
		ifTrue: [ { self okButton. self cancelButton } ]
		ifFalse: [ { self okButton. self expandButton. self cancelButton } ].
	self addARow: bottomButtons.

	self fillInDetails.! !

!EToyProjectDetailsMorph methodsFor: 'initialization' stamp: 'dgd 11/3/2004 17:29'!
space
	^ RectangleMorph new extent: 5 @ 5;
		 color: Color transparent;
		 borderWidth: 0 ! !

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

EToyProjectDetailsMorph class
	instanceVariableNames: ''!

!EToyProjectDetailsMorph class methodsFor: 'as yet unclassified' stamp: 'tak 3/15/2005 15:52'!
getFullInfoFor: aProject ifValid: aBlock expandedFormat: expandedFormat

	| me |

	(me _ self basicNew)
		expandedFormat: expandedFormat;
		project: aProject
		actionBlock: [ :x | 
			aProject world setProperty: #ProjectDetails toValue: x.
			x at: 'projectname' ifPresent: [ :newName | 
				aProject renameTo: newName.
			].
			me delete.
			aBlock value.
		];

		initialize;
		becomeModal;
		openCenteredInWorld! !

!EToyProjectDetailsMorph class methodsFor: 'as yet unclassified' stamp: 'mir 6/19/2001 10:17'!
test1: aProject
"EToyProjectDetailsMorph test1: Project current"

	(self basicNew)
		project: aProject
		actionBlock: [ :x | 
			aProject world setProperty: #ProjectDetails toValue: x.
			x at: 'projectname' ifPresent: [ :newName | 
				aProject renameTo: newName.
			]
		];

		initialize;
		openCenteredInWorld! !
EToyCommunicatorMorph subclass: #EToyProjectHistoryMorph
	instanceVariableNames: 'changeCounter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!
!EToyProjectHistoryMorph commentStamp: '<historical>' prior: 0!
EToyProjectHistoryMorph new openInWorld

EToyProjectHistoryMorph provides a quick reference of the most recent projects. Click on one to go there.!


!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'ar 9/28/2000 13:53'!
closeMyFlapIfAny

	| myFlap allTabs myTab myWorld |

	myWorld _ self world.
	myFlap _ self nearestOwnerThat: [ :each | each isFlap].
	myFlap ifNil: [^self].
	allTabs _ myWorld submorphs select: [ :each | each isFlapTab].
	myTab _ allTabs detect: [ :each | each referent == myFlap] ifNone: [^self].
	myTab hideFlap.
	myWorld displayWorldSafely.
	
! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 12:02'!
jumpToProject

	| selection |
	selection _ (Project buildJumpToMenu: CustomMenu new) startUp.
	self closeMyFlapIfAny.
	Project jumpToSelection: selection
! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 07:25'!
mouseDown: evt in: aMorph

	aMorph setProperty: #mouseDownPoint toValue: evt cursorPoint.
! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 07:28'!
mouseLeave: evt in: aMorph

	aMorph removeProperty: #mouseDownPoint.! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/27/2000 22:47'!
mouseMove: evt in: aMorph

	| start tuple project url pvm |
	start _ aMorph valueOfProperty: #mouseDownPoint ifAbsent: [^self].
	(start dist: evt cursorPoint) abs < 5 ifTrue: [^self].
	aMorph removeProperty: #mouseDownPoint.
	evt hand hasSubmorphs ifTrue: [^self].
	tuple _ aMorph valueOfProperty: #projectParametersTuple ifAbsent: [^self].
	project _ tuple fourth first.
	(project notNil and: [project world notNil]) ifTrue: [
		^evt hand attachMorph: (ProjectViewMorph on: project).
	].
	url _ tuple third.
	url isEmptyOrNil ifTrue: [^self].
	pvm _ ProjectViewMorph new.
	pvm
		project: (DiskProxy global: #Project selector: #namedUrl: args: {url});
		lastProjectThumbnail: tuple second.
	evt hand attachMorph: pvm.
! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
mouseUp: evt in: aMorph

	| tuple project url |

	(aMorph boundsInWorld containsPoint: evt cursorPoint) ifFalse: [^self].
	tuple _ aMorph valueOfProperty: #projectParametersTuple ifAbsent: [^Beeper beep].
	project _ tuple fourth first.
	(project notNil and: [project world notNil]) ifTrue: [self closeMyFlapIfAny. ^project enter].
	url _ tuple third.
	url isEmptyOrNil ifTrue: [^Beeper beep].
	self closeMyFlapIfAny.
	ProjectLoading thumbnailFromUrl: url.

"---
	newTuple _ {
		aProject name.
		aProject thumbnail.
		aProject url.
		WeakArray with: aProject.
	}.
---"! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'dgd 9/20/2003 18:52'!
rebuild

	| history r1 |
	history _ ProjectHistory currentHistory mostRecentCopy.
	changeCounter _ ProjectHistory changeCounter.
	self removeAllMorphs.
	self rubberBandCells: false. "enable growing"
	r1 _ self addARow: {
		self inAColumn: {
			StringMorph new contents: 'Jump...' translated; lock.
		}.
	}.
	r1 on: #mouseUp send: #jumpToProject to: self.

	history do: [ :each |
		(
			self addARow: {
				(self inAColumn: {
					StretchyImageMorph new form: each second; minWidth: 35; minHeight: 35; lock
				}) vResizing: #spaceFill.
				self inAColumn: {
					StringMorph new contents: each first; lock.
					"StringMorph new contents: each third; lock."
				}.
			}
		)
			color: Color paleYellow;
			borderWidth: 1;
			borderColor: #raised;
			vResizing: #spaceFill;
			on: #mouseUp send: #mouseUp:in: to: self;
			on: #mouseDown send: #mouseDown:in: to: self;
			on: #mouseMove send: #mouseMove:in: to: self;
			on: #mouseLeave send: #mouseLeave:in: to: self;
			setProperty: #projectParametersTuple toValue: each;
			setBalloonText: (each third isEmptyOrNil ifTrue: ['not saved'] ifFalse: [each third])
	].
"---
	newTuple _ {
		aProject name.
		aProject thumbnail.
		aProject url.
		WeakArray with: aProject.
	}.
---"! !


!EToyProjectHistoryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #raised! !

!EToyProjectHistoryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 4! !

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

!EToyProjectHistoryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:46'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 layoutInset: 4;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 useRoundedCorners;
		 rebuild ! !


!EToyProjectHistoryMorph methodsFor: 'stepping and presenter' stamp: 'RAA 7/10/2000 23:07'!
step

	changeCounter = ProjectHistory changeCounter ifTrue: [^self].
	self rebuild.
	! !

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

EToyProjectHistoryMorph class
	instanceVariableNames: ''!

!EToyProjectHistoryMorph class methodsFor: 'parts bin' stamp: 'sw 8/19/2001 21:15'!
descriptionForPartsBin
	^ self partName: 	'ProjectHistory'
		categories:		#('Navigation')
		documentation:	'A tool that lets you navigate back to recently-visited projects'! !
EToyProjectDetailsMorph subclass: #EToyProjectQueryMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:16'!
doOK

	actionBlock value: self copyOutDetails.
	self delete.! !

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:17'!
fillInDetails

	"leave them blank for now"! !

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:18'!
project: ignored actionBlock: aBlock

	actionBlock _ aBlock.
	projectDetails _ Dictionary new.! !

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:19'!
rebuild

	self removeAllMorphs.
	self addARow: {
		self lockedString: 'Enter things to search for'.
	}.
	self addARow: {
		self lockedString: 'Name:'.
		self inAColumnForText: {self fieldForProjectName}
	}.
	self fieldToDetailsMappings do: [ :each |
		self addARow: {
			self lockedString: each third.
			self inAColumnForText: {(self genericTextFieldNamed: each first) height: each fourth}
		}.
	].

	self addARow: {
		self okButton.
		self cancelButton.
	}.
	self fillInDetails.! !


!EToyProjectQueryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:26'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.545
		g: 0.47
		b: 0.621! !

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

EToyProjectQueryMorph class
	instanceVariableNames: ''!

!EToyProjectQueryMorph class methodsFor: 'as yet unclassified' stamp: 'tak 3/15/2005 16:37'!
onServer: aProjectServer
	"EToyProjectQueryMorph onServer: SuperSwikiServer testOnlySuperSwiki"

	| criteria clean |

	(self basicNew)
		project: nil
		actionBlock: [ :x | 
			criteria _ OrderedCollection new.
			x keysAndValuesDo: [ :k :v |
				(clean _ v withBlanksTrimmed) isEmpty
					ifFalse: [criteria add: k,': *',clean,'*']].
			aProjectServer queryProjectsAndShow: criteria];

		initialize;
		becomeModal;
		openCenteredInWorld! !

!EToyProjectQueryMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:34'!
test1: aProject
"EToyProjectQueryMorph test1: nil"

	| criteria clean |

	(self basicNew)
		project: aProject
		actionBlock: [ :x | 
			criteria _ OrderedCollection new.
			x keysAndValuesDo: [ :k :v |
				(clean _ v withBlanksTrimmed) isEmpty ifFalse: [
					criteria add: k,': *',clean,'*'
				].
			].
			SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow: criteria
		];

		initialize;
		openCenteredInWorld! !
EToyGenericDialogMorph subclass: #EToyProjectRenamerMorph
	instanceVariableNames: 'actionBlock theProject'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 15:01'!
buttonColor

	^color darker! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:25'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString translated font: self myFont;
		color: aColor;
		borderColor: aColor muchDarker;
		actionSelector: aSymbol;
		setBalloonText: helpString translated.
	col _ (self inAColumn: {f}) hResizing: #spaceFill.
	^col! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:24'!
cancelButton
	^ self
		buttonNamed: 'Cancel'
		action: #doCancel
		color: ColorTheme current cancelColor
		help: 'Cancel this Publish operation.'! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 15:06'!
doCancel

	self delete.! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'ar 2/23/2001 20:55'!
doOK

	self validateTheProjectName ifFalse: [^self].
	self delete.
	actionBlock value: (namedFields at: 'projectname') contents string withBlanksTrimmed.! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'yo 2/23/2005 17:25'!
fieldForProjectName

	| tm |

	tm _ self genericTextFieldNamed: 'projectname'.
	tm crAction: (MessageSend receiver: self selector: #doOK).
	tm setBalloonText: 'Pick a name 24 characters or less and avoid the following characters:

 : < > | / \ ? * " .' translated.
	^tm
	
! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:23'!
okButton
	^ self
		buttonNamed: 'OK'
		action: #doOK
		color: ColorTheme current okColor
		help: 'Change my name and continue publishing.'! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:55'!
project: aProject actionBlock: aBlock

	theProject _ aProject.
	actionBlock _ aBlock.
	(namedFields at: 'projectname') contentsWrapped: theProject name.! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 12:36'!
rebuild

	self removeAllMorphs.
	self addARow: {
		self lockedString: 'Please name this project'.
	}.
	self addARow: {
		self inAColumnForText: {self fieldForProjectName}
	}.
	self addARow: {
		self okButton.
		self cancelButton.
	}.
! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 18:53'!
validateTheProjectName

	| proposed |

	proposed _ (namedFields at: 'projectname') contents string withBlanksTrimmed.
	proposed isEmpty ifTrue: [
		self inform: 'I do need a name for the project' translated.
		^false
	].
	proposed size > 24 ifTrue: [
		self inform: 'Please make the name 24 characters or less' translated.
		^false
	].
	(Project isBadNameForStoring: proposed) ifTrue: [
		self inform: 'Please remove any funny characters from the name' translated.
		^false
	].
	proposed = theProject name ifTrue: [^true].
	(ChangeSorter changeSetNamed: proposed) ifNotNil: [
		Utilities inform: 'Sorry that name is already used' translated.
		^false
	].
	^true! !


!EToyProjectRenamerMorph methodsFor: 'initialization' stamp: 'dgd 11/2/2004 21:09'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ ColorTheme current dialogColor! !

!EToyProjectRenamerMorph methodsFor: 'initialization' stamp: 'dgd 1/7/2005 19:21'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self vResizing: #shrinkWrap;
		 hResizing: #shrinkWrap;
		 layoutInset: 4;
		 useRoundedCorners;
		 rebuild! !

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

EToyProjectRenamerMorph class
	instanceVariableNames: ''!

!EToyProjectRenamerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:35'!
validate: aProject andDo: aBlock

	(self new)
		project: aProject actionBlock: aBlock;
		openCenteredInWorld! !
EToyChatOrBadgeMorph subclass: #EToySenderMorph
	instanceVariableNames: 'userPicture'
	classVariableNames: 'DEBUG'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Collaborative'!
!EToySenderMorph commentStamp: '<historical>' prior: 0!
EToySenderMorph
	new
	userName: 'Bob Arning' 
	userPicture: nil 
	userEmail: 'arning@charm.net' 
	userIPAddress: '1.2.3.4';
	position: 200@200;
	open
"
EToySenderMorph represents another person to whom you wish to send things. Drop a morph on an EToySenderMorph and a copy of that morph is sent to the person represented. Currently only peer-to-peer communications are supported, but other options are planned.
"!
]style[(149 1 262)cblue;f2,f2,f1!


!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
checkOnAFriend

	| gateKeeperEntry caption choices resp |

	gateKeeperEntry := EToyGateKeeperMorph entryForIPAddress: self ipAddress.
	caption := 
'Last name: ',gateKeeperEntry latestUserName,
'\Last message in: ',gateKeeperEntry lastIncomingMessageTimeString,
'\Last status check at: ',gateKeeperEntry lastTimeCheckedString,
'\Last status in: ',gateKeeperEntry statusReplyReceivedString.
	choices := 'Get his status now\Send my status now' .
	resp := (PopUpMenu labels: choices withCRs) startUpWithCaption: caption withCRs.
	resp = 1 ifTrue: [
		gateKeeperEntry lastTimeChecked: Time totalSeconds.
		self sendStatusCheck.
	].
	resp = 2 ifTrue: [
		self sendStatusReply.
	].
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/10/2000 12:25'!
currentBadgeVersion

	"enables on-the-fly updating of older morphs"
	^10! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 12:30'!
establishDropZone: aMorph

	self setProperty: #specialDropZone toValue: aMorph.
	aMorph 
		on: #mouseEnterDragging send: #mouseEnteredDZ to: self;
		on: #mouseLeaveDragging send: #mouseLeftDZ to: self;
		on: #mouseLeave send: #mouseLeftDZ to: self.
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
fixOldVersion

	| uName uForm uEmail uIP |
	uName := self userName.
	uForm := userPicture ifNil: [
		(self 
		findDeepSubmorphThat: [ :x | (x isKindOf: ImageMorph) or: [x isSketchMorph]] 
		ifAbsent: [self halt]) form.
	].
	uEmail := (fields at: #emailAddress) contents.
	uIP := self ipAddress.
	self
		userName: uName 
		userPicture: (uForm scaledToSize: 61@53)
		userEmail: uEmail 
		userIPAddress: uIP
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 15:58'!
ipAddress

	^(fields at: #ipAddress) contents! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 16:20'!
ipAddress: aString

	^(fields at: #ipAddress) contents: aString! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
killExistingChat

	| oldOne |
	self rubberBandCells: true. "disable growing"
	(oldOne := self valueOfProperty: #embeddedChatHolder) ifNotNil: [
		oldOne delete.
		self removeProperty: #embeddedChatHolder
	].

	(oldOne := self valueOfProperty: #embeddedAudioChatHolder) ifNotNil: [
		oldOne delete.
		self removeProperty: #embeddedAudioChatHolder
	].

! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
mouseEnteredDZ

	| dz |
	dz := self valueOfProperty: #specialDropZone ifAbsent: [^self].
	dz color: Color blue.! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
mouseLeftDZ

	| dz |
	dz := self valueOfProperty: #specialDropZone ifAbsent: [^self].
	dz color: Color transparent.! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
sendStatusCheck

	| null |
	null := String with: 0 asCharacter.
	EToyPeerToPeer new 
		sendSomeData: {
			EToyIncomingMessage typeStatusRequest,null. 
			Preferences defaultAuthorName,null.
		}
		to: self ipAddress
		for: self.
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
sendStatusReply

	| null |
	null := String with: 0 asCharacter.
	EToyPeerToPeer new 
		sendSomeData: {
			EToyIncomingMessage typeStatusReply,null. 
			Preferences defaultAuthorName,null.
			((EToyGateKeeperMorph acceptableTypesFor: self ipAddress) 
				eToyStreamedRepresentationNotifying: self).
		}
		to: self ipAddress
		for: self.
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 14:22'!
startAudioChat

	self startAudioChat: true
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'aoy 2/15/2003 20:59'!
startAudioChat: toggleMode 
	| chat r |
	(self valueOfProperty: #embeddedAudioChatHolder) ifNotNil: 
			[toggleMode ifFalse: [^self].
			^self killExistingChat].
	chat := AudioChatGUI new ipAddress: self ipAddress.
	(self ownerThatIsA: EToyFridgeMorph) isNil 
		ifTrue: 
			[chat
				removeConnectButton;
				vResizing: #shrinkWrap;
				hResizing: #shrinkWrap;
				borderWidth: 2.	"we already know the connectee"
			r := (self addARow: { 
								chat}) vResizing: #shrinkWrap.
			self world startSteppingSubmorphsOf: chat.
			self setProperty: #embeddedAudioChatHolder toValue: r.
			self
				hResizing: #shrinkWrap;
				vResizing: #shrinkWrap]
		ifFalse: 
			[chat openInWorld: self world]! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 17:14'!
startChat

	self startChat: true
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
startChat: toggleMode

	| chat r |

	(self valueOfProperty: #embeddedChatHolder) ifNotNil: [
		toggleMode ifFalse: [^self].
		^self killExistingChat
	].
	(EToyChatMorph doChatsInternalToBadge and: 
				[(self ownerThatIsA: EToyFridgeMorph) isNil]) ifTrue: [
		chat := EToyChatMorph basicNew
			recipientForm: userPicture; 
			initialize;
			setIPAddress: self ipAddress.
		chat
			vResizing: #spaceFill;
			hResizing: #spaceFill;
			borderWidth: 2;
			insetTheScrollbars.
		r := (self addARow: {chat}) vResizing: #spaceFill.
		self rubberBandCells: false. "enable growing"
		self height: 350. "an estimated guess for allowing shrinking as well as growing"
		self world startSteppingSubmorphsOf: chat.
		self setProperty: #embeddedChatHolder toValue: r.
	] ifFalse: [
		chat := EToyChatMorph 
			chatWindowForIP: self ipAddress
			name: self userName 
			picture: userPicture 
			inWorld: self world.
		chat owner addMorphFront: chat.
	]
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
startNebraskaClient

	| newMorph |
	[
		[
			newMorph := NetworkTerminalMorph connectTo: self ipAddress.
			WorldState addDeferredUIMessage: [newMorph openInStyle: #scaled] fixTemps.
		]
			on: Error
			do: [ :ex |
				WorldState addDeferredUIMessage: [
					self inform: 'No connection to: '. self ipAddress,' (',ex printString,')'
				] fixTemps
			].
	] fork
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/24/2000 14:04'!
startTelemorphic

	self world 
		connectRemoteUserWithName: self userName 
		picture: (userPicture ifNotNil: [userPicture scaledToSize: 16@20]) 
		andIPAddress: self ipAddress
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 11:12'!
tellAFriend

	self world project tellAFriend: (fields at: #emailAddress) contents
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 16:15'!
transmitStreamedObject: outData

	self transmitStreamedObject: outData to: self ipAddress

! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 12:00'!
transmittedObjectCategory

	^EToyIncomingMessage typeMorph! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/20/2001 13:03'!
userName

	^ (self 
		findDeepSubmorphThat: [ :x | x isKindOf: StringMorph] 
		ifAbsent: [^nil]) contents
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
userName: aString userPicture: aFormOrNil userEmail: emailString userIPAddress: ipString

	| dropZoneRow |

	self setProperty: #currentBadgeVersion toValue: self currentBadgeVersion.
	userPicture := aFormOrNil ifNil: [
		(TextStyle default fontOfSize: 26) emphasized: 1; characterFormAt: $?
	].
	userPicture := userPicture scaledToSize: 61@53.
	self killExistingChat.
	self removeAllMorphs.
	self useRoundedCorners.
	self 
		addARow: {
			self inAColumn: {(StringMorph contents: aString) lock}
		}.
	dropZoneRow := self
		addARow: {
			self inAColumn: {userPicture asMorph lock}
		}.
	self establishDropZone: dropZoneRow.
	self
		addARow: {
			self textEntryFieldNamed: #emailAddress with: emailString
					help: 'Email address for this person'
		};
		addARow: {
			self textEntryFieldNamed: #ipAddress with: ipString
					help: 'IP address for this person'
		};
		addARow: {
			self indicatorFieldNamed: #working color: Color blue help: 'working'.
			self indicatorFieldNamed: #communicating color: Color green help: 'sending'.
			self buttonNamed: 'C' action: #startChat color: Color paleBlue 
								help: 'Open a written chat with this person'.
			self buttonNamed: 'T' action: #startTelemorphic color: Color paleYellow 
								help: 'Start telemorphic with this person'.
			self buttonNamed: '!!' action: #tellAFriend color: Color paleGreen 
								help: 'Tell this person about the current project'.
			self buttonNamed: '?' action: #checkOnAFriend color: Color lightBrown 
								help: 'See if this person is available'.
			self buttonNamed: 'A' action: #startAudioChat color: Color yellow 
								help: 'Open an audio chat with this person'.
			self buttonNamed: 'S' action: #startNebraskaClient color: Color white 
								help: 'See this person''s world (if he allows that)'.
		}.
	! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 16:06'!
userPicture

	^userPicture! !


!EToySenderMorph methodsFor: 'debug and other' stamp: 'RAA 8/31/2000 18:31'!
installModelIn: myWorld

	"if we get this far and nothing exists, make it up"

	userPicture ifNotNil: [^self].
	self
		userName: Preferences defaultAuthorName 
		userPicture: nil 
		userEmail: 'who@where.net' 
		userIPAddress: NetNameResolver localAddressString
! !


!EToySenderMorph methodsFor: 'dropping/grabbing' stamp: 'sd 11/20/2005 21:25'!
aboutToBeGrabbedBy: aHand

	| aFridge |
	super aboutToBeGrabbedBy: aHand.
	aFridge := self ownerThatIsA: EToyFridgeMorph.
	aFridge ifNil: [^self].
	aFridge noteRemovalOf: self.! !

!EToySenderMorph methodsFor: 'dropping/grabbing' stamp: 'sd 11/20/2005 21:25'!
wantsDroppedMorph: aMorph event: evt

	| dz |
	dz := self valueOfProperty: #specialDropZone ifAbsent: [^false].
	(dz bounds containsPoint: (evt cursorPoint)) ifFalse: [^false].
	^true.! !


!EToySenderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color magenta! !

!EToySenderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 4! !

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

!EToySenderMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:58'!
initialize
	"initialize the state of the receiver"
	Socket initializeNetwork.
	"we may want our IP address"
	Preferences defaultAuthorName.
	"seems like a good place to insure we have a name"
	super initialize.
	""
	self listDirection: #topToBottom;
		 layoutInset: 4;
		 setProperty: #normalBorderColor toValue: self borderColor;
		 setProperty: #flashingColors toValue: {Color red. Color yellow}! !


!EToySenderMorph methodsFor: 'layout' stamp: 'sd 11/20/2005 21:25'!
acceptDroppingMorph: morphToDrop event: evt

	| myCopy outData |

	(morphToDrop isKindOf: NewHandleMorph) ifTrue: [			"don't send these"
		^morphToDrop rejectDropMorphEvent: evt.
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we don't really want it"

	"7 mar 2001 - remove #veryDeepCopy"
	myCopy := morphToDrop.	"gradient fills require doing this second"
	myCopy setProperty: #positionInOriginatingWorld toValue: morphToDrop position.
	self stopFlashing.

	outData := myCopy eToyStreamedRepresentationNotifying: self.
	self resetIndicator: #working.
	self transmitStreamedObject: outData to: self ipAddress.

! !


!EToySenderMorph methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 13:08'!
initializeToStandAlone

	super initializeToStandAlone.
	self installModelIn: ActiveWorld.
! !


!EToySenderMorph methodsFor: 'stepping and presenter' stamp: 'RAA 8/10/2000 12:24'!
step

	(self valueOfProperty: #currentBadgeVersion) = self currentBadgeVersion ifFalse: [
		self setProperty: #currentBadgeVersion toValue: self currentBadgeVersion.
		self fixOldVersion.
		Preferences defaultAuthorName.		"seems like a good place to insure we have a name"
	].
	super step.! !

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

EToySenderMorph class
	instanceVariableNames: ''!

!EToySenderMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 12:52'!
instanceForIP: ipAddress

	^self allInstances detect: [ :x | 
		x ipAddress = ipAddress
	] ifNone: [nil]
! !

!EToySenderMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 12:50'!
instanceForIP: ipAddress inWorld: aWorld

	^self allInstances detect: [ :x | 
		x world == aWorld and: [x ipAddress = ipAddress]
	] ifNone: [nil]
! !

!EToySenderMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
nameForIPAddress: ipString

	| senderMorphs |

	senderMorphs := EToySenderMorph allInstances select: [ :x | 
		x userName notNil and: [x ipAddress = ipString]
	].
	senderMorphs isEmpty ifTrue: [^nil].
	^senderMorphs first userName

! !

!EToySenderMorph class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
pictureForIPAddress: ipString

	| senderMorphs |

	senderMorphs := EToySenderMorph allInstances select: [ :x | 
		x userPicture notNil and: [x ipAddress = ipString]
	].
	senderMorphs isEmpty ifTrue: [^nil].
	^senderMorphs first userPicture

! !


!EToySenderMorph class methodsFor: 'parts bin' stamp: 'RAA 12/18/2001 10:05'!
descriptionForPartsBin

	^ self partName: 	'Badge'
		categories:		#('Collaborative')
		documentation:	'A tool for collaborating with other Squeak users'
		sampleImageForm: (Form
	extent: 66@72
	depth: 16
	fromArray: #( 7175 1545042975 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082429975 470220800 470252575 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082413575 1545042975 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082429975 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1582767304 1032871511 2134867775 2134842568 2134867775 2134867775 2134867775 1032879935 2134867775 2134867775 2134867775 2134867775 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134842568 1032871511 1032863120 1582775696 1032871511 2134867775 2134867775 1032871511 2134842568 1032863120 482885008 1032879935 482901823 482885008 1032879935 1032863120 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 2134850960 1032879935 1032863120 2134850960 2134867775 2134859351 482876616 2134850960 2134867775 1032879935 1032879935 1032879935 1032879935 1032879935 1032863120 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1582767304 1032871511 1032863120 1582775696 1032871511 2134867775 2134842568 1582767304 1582767304 1582792511 482893399 482893399 482893399 482893399 482893399 1032863120 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1032863120 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 65537 65537 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 65537 1032863120 1032863120 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 81296 2134867775 2134867775 1032847361 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 81296 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 65537 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 81296 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 81296 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 1039171583 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 1039171583 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 1039154672 1593270007 1039163127 1593278463 1593261552 2147442423 1039154672 2147433968 1039154672 1593270007 1039163127 1593278463 1593261552 2147442423 1593270007 1593261552 2147450879 2147442423 1593270007 2147442423 1039171583 484990711 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141150967 1039163127 1039171583 1039163127 1039171583 1039171583 1039154672 1039154672 1039163127 1039163127 1039171583 1039163127 1039171583 484982256 1039146216 1593270007 484982256 1039171583 2147425512 1593261552 2147425512 1039154672 1039171583 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1039154672 1593278463 1039171583 1039171583 1039171583 1039154672 1039146216 1593278463 1039154672 1593278463 1039171583 1039171583 1039171583 1593261552 2147450879 1039171583 1593270007 2147433968 2147433968 2147433968 2147442423 1039171583 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1593270007 2147450879 1039163127 1039163127 1593261552 2147442423 1039163127 2147450879 1593270007 2147450879 1039163127 1039163127 1593261552 2147433968 1593278463 1593261552 2147442423 2147433968 1593261552 1593270007 1039171583 2147442423 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141150967 1039171583 1593261552 2147442423 1039171583 2147450879 2147442423 2147450879 1593278463 1593261552 2147450879 2147442423 1039171583 2147442423 2147450879 2147442423 1039171583 2147442423 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141150967 2147433968 1039171583 1039154672 2147433968 2147450879 1593261552 2147442423 1039171583 1593278463 1039171583 2147433968 2147433968 1593261552 2147450879 2147442423 2147433968 1593261552 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1039171583 1039171583 1039154672 1039154672 2147450879 2147433968 2147425512 484990711 2147433968 1593278463 2147433968 1039154672 2147433968 2147450879 2147450879 1039163127 484973800 1593278367 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 2147442423 1039171583 1039171583 1593270007 1593278463 2147433968 2147450879 1039171583 2147450879 1039163127 2147450879 1593270007 2147433968 2147442423 2147450879 2147433968 2147433968 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 1039163127 1593261552 2147442423 1593278463 1593278463 1593261552 2147450879 1039163127 1593261552 2147442423 2147442423 1593278463 1593261552 2147442423 2147442423 1039171583 2147433968 1593278367 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134861595 1391951679 2134867775 2134867775 2134856439 1729855295 2134867775 2134867775 1729849115 2134867775 2134867775 2134861595 1729855295 2134867775 2134867775 1729843959 1391951679 2134867775 2134867775 2134856439 1729855295 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1326930843 1879001943 1729855295 2134861595 1398112251 1738035990 2134867775 2134855446 1536646039 1326874431 2134867775 1387357800 1718112945 2134867775 2134856463 1736736736 2145407816 1729855295 2134861595 1398243327 1738232599 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 1032863120 1032879935 2134867775 1032863120 1032879935 2134856439 1879011327 1879011327 1264025407 2134856533 2147188731 2147188731 1391951679 1391947770 1878683642 1878676215 2134856439 2120646246 2120646246 1391951679 1391951840 2145419232 2145419232 1397260095 2134856535 2147450879 2147450879 1391951679 2134867775 2082438175 2082438175 2134867775 2134842568 1507359 1514696 2134842568 48235488 48241864 2134854487 1391932912 904949759 1879003895 1391951867 484908263 1039040507 1398112063 1263890426 904753146 1878674261 2134856331 2120629539 1025736294 1384873791 1397260256 2145402336 2145419232 2145407735 1391951871 1039154672 1039171583 1398243135 2134867775 2082438175 2082438175 2134867775 2134835216 2031647 2031632 2134835680 65012704 65012192 2134854487 904949759 1879011327 1879003895 1391951867 2147171822 2147188731 1398112063 1263890426 904753146 1878674261 2134856331 2120646246 1025736294 1384873791 1397260256 1591754208 2145419232 2145407735 1391951871 1039163127 2147450879 1398243135 2134867775 2082438175 2082438175 2134867775 2134835216 2031647 2031632 2134835680 65012704 65012192 2134854487 904949759 1879011327 1879003895 1391951867 2147171822 2147188731 1398112063 1263890426 904753146 1878674261 2134856331 2120629539 2120646246 1384873791 1397260256 484449504 1591771104 2145407735 1391951871 2147442423 1593278463 1398243135 2134867775 2082438175 2082438175 2134867775 2134842568 1507359 1514696 2134842568 48235488 48241864 2134854487 1391932912 904949759 1879003895 1391951867 1593056487 2147188731 1398112063 1263890426 1391685626 1878674261 2134856331 2120637892 2120646246 1384873791 1397251808 484466400 484474848 2145407735 1391951871 484982256 1593278463 1398243135 2134867775 2082438175 2082438175 2134867775 2134867775 1032863120 1032879935 2134867775 1032863120 1032879935 2134855447 1879011327 1879011327 1536911131 1729849240 2147188731 2147188731 1393983295 1326870522 1878683642 1878675222 2134856369 2120646246 2120646246 1387364159 1393524704 2145419232 2145419232 1736730395 1729849243 2147450879 2147450879 1394048831 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134861595 1536913407 1879011327 1326939967 2134856470 2147188731 2147182488 1729855295 1729846167 1878683642 1536648987 2134861595 1718124134 2120640104 1729855295 1729849220 2145419232 2145419232 1393524543 2134856471 2147450879 2147444635 1729855295 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1729842967 1264014071 2134867775 2134867775 1391940437 1393977115 2134867775 2134861595 1326862102 1729855295 2134867775 1729843889 1387357979 2134867775 2134861595 1393513288 1397248759 2134867775 2134867775 1391940439 1394042651 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 1545042975 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082429975 470252575 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082413575 7175 1545042975 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082429975 470220800)
	offset: 0@0)! !
StandardScriptingSystem subclass: #EToySystem
	instanceVariableNames: ''
	classVariableNames: 'EToyVersion EToyVersionDate'
	poolDictionaries: ''
	category: 'EToys-Experimental'!
!EToySystem commentStamp: '<historical>' prior: 0!
A global object holding onto properties and code of the overall E-toy system of the moment.  Its code is entirely held on the class side; the class is never instantiated.!


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

EToySystem class
	instanceVariableNames: ''!

!EToySystem class methodsFor: 'development support' stamp: 'tk 8/21/2000 12:59'!
cleanupsForRelease
	"Miscellaneous space cleanups to do before a release."
	"EToySystem cleanupsForRelease"

	Socket deadServer: ''.  "Don't reveal any specific server name"
	HandMorph initialize.  "free cached ColorChart"
	PaintBoxMorph initialize.	"forces Prototype to let go of extra things it might hold"
	Smalltalk removeKey: #AA ifAbsent: [].
	Smalltalk removeKey: #BB ifAbsent: [].
	Smalltalk removeKey: #CC ifAbsent: [].
	Smalltalk removeKey: #DD ifAbsent: [].
	Smalltalk removeKey: #Temp ifAbsent: [].

	ScriptingSystem reclaimSpace.
	Smalltalk cleanOutUndeclared.
	Smalltalk reclaimDependents.
	Smalltalk forgetDoIts.
	Smalltalk removeEmptyMessageCategories.
	Symbol rehash.
! !

!EToySystem class methodsFor: 'development support' stamp: 'sd 5/11/2003 22:13'!
loadJanForms
	"EToySystem loadJanForms"

	| aReferenceStream newFormDict |
	aReferenceStream _ ReferenceStream fileNamed: 'JanForms'.
	newFormDict _ aReferenceStream next.
	aReferenceStream close.
	newFormDict associationsDo:
		[:assoc | Imports default importImage: assoc value named: assoc key]! !

!EToySystem class methodsFor: 'development support' stamp: 'sd 1/16/2004 20:55'!
stripMethodsForExternalRelease
	"EToySystem stripMethodsForExternalRelease"

	SmalltalkImage current stripMethods: self methodsToStripForExternalRelease messageCode: '2.3External'! !


!EToySystem class methodsFor: 'external release' stamp: 'tk 4/10/2001 13:08'!
methodsToStripForExternalRelease
	"Answer a list of triplets #(className, class/instance, methodName) of methods to be stripped in an external release."
	^ #(
		(EToySystem			class		prepareRelease)	
		(EToySystem			class		previewEToysOn:)
		)! !


!EToySystem class methodsFor: 'misc' stamp: 'sw 1/21/98 15:07'!
fixComicCharacters
	"EToySystem fixComicCharacters"
	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $_ put:
		(Form
	extent: 9@16
	depth: 1
	fromArray: #( 0 0 0 134217728 402653184 805306368 2139095040 4278190080 2139095040 805306368 402653184 134217728 0 0 0 0)
	offset: 0@0).

	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $1 put:
		(Form
	extent: 5@16
	depth: 1
	fromArray: #( 0 0 0 0 1610612736 3758096384 3758096384 1610612736 1610612736 1610612736 1610612736 4026531840 4026531840 0 0 0)
	offset: 0@0).


	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $2 put:
		(Form
	extent: 6@16
	depth: 1
	fromArray: #( 0 0 0 0 1879048192 4160749568 2550136832 939524096 1879048192 3758096384 3221225472 4160749568 4160749568 0 0 0)
	offset: 0@0).


	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $4 put:
		(Form
	extent: 7@16
	depth: 1
	fromArray: #( 0 0 0 0 134217728 402653184 402653184 939524096 1476395008 4227858432 4227858432 402653184 402653184 0 0 0)
	offset: 0@0).

	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $j put:
		(Form
	extent: 4@16
	depth: 1
	fromArray: #( 0 0 0 0 1610612736 1610612736 0 1610612736 1610612736 1610612736 1610612736 1610612736 1610612736 1610612736 3758096384 3221225472)
	offset: 0@0).

! !


!EToySystem class methodsFor: 'stripped' stamp: 'di 1/15/1999 11:29'!
prepareRelease
	self codeStrippedOut: '2.3External'! !

!EToySystem class methodsFor: 'stripped' stamp: 'di 1/15/1999 11:29'!
previewEToysOn: arg1
	self codeStrippedOut: '2.3External'! !
TextMorph subclass: #EToyTextNode
	instanceVariableNames: 'children firstDisplay'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Outliner'!

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 01:12'!
addChild: aTextNode

	children add: aTextNode.
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 10:05'!
addNewChildAfter: anotherOrNilOrZero

	| where newNode |

	anotherOrNilOrZero == 0 ifTrue: [
		newNode _ EToyTextNode newNode.
		children _ {newNode} asOrderedCollection,children.
		^newNode
	].
	where _ children indexOf: anotherOrNilOrZero ifAbsent: [children size].
	children add: (newNode _ EToyTextNode newNode) afterIndex: where.
	^newNode
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 01:13'!
children

	^children
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 13:09'!
clipToOwner: aBoolean

	aBoolean ifFalse: [^self setContainer: nil].
	self setContainer: (SimplerTextContainer new for: self minWidth: textStyle lineGrid*2)! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:52'!
firstDisplay

	^firstDisplay ifNil: [false]! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 10:33'!
firstDisplayedOnLevel: level

	firstDisplay _ false.
	text addAttribute: (TextFontChange fontNumber: ((5 - level) max: 1)).
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:43'!
removeChild: aTextNode

	children remove: aTextNode ifAbsent: [].
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:53'!
showInOpenedState

	| answer |
	answer _ self valueOfProperty: #showInOpenedState ifAbsent: [false].
	self removeProperty: #showInOpenedState.
	^answer! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:55'!
withAllChildrenDo: aBlock

	aBlock value: self.
	children do: [ :each | each withAllChildrenDo: aBlock].! !


!EToyTextNode methodsFor: 'event handling' stamp: 'RAA 7/30/2000 15:08'!
keyStroke: evt

	(owner notNil and: [owner keyStroke: evt]) ifTrue: [^self].
	^super keyStroke: evt.! !

!EToyTextNode methodsFor: 'event handling' stamp: 'RAA 7/30/2000 10:07'!
keyboardFocusChange: aBoolean

	super keyboardFocusChange: aBoolean.
	aBoolean ifTrue: [owner takeFocus].

! !


!EToyTextNode methodsFor: 'initialization' stamp: 'RAA 7/30/2000 17:09'!
initialize

	| newStyle |
	super initialize.
	firstDisplay _ true.
	children _ OrderedCollection new.
	(newStyle _ TextStyle named: #Palatino) ifNotNil: [
		textStyle _ newStyle copy defaultFontIndex: 2
	].

! !

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

EToyTextNode class
	instanceVariableNames: ''!

!EToyTextNode class methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:11'!
newNode

	^self new contents: (
		Text
			string: 'new item'
			attribute: (TextFontChange fontNumber: 2)
	)! !


!EToyTextNode class methodsFor: 'new-morph participation' stamp: 'RAA 8/8/2000 14:36'!
includeInNewMorphMenu

	^ false! !
ListItemWrapper subclass: #EToyTextNodeWrapper
	instanceVariableNames: 'parentWrapper'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Outliner'!

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 17:25'!
addNewChildAfter: anotherOrNil

	item addNewChildAfter: anotherOrNil.
! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
addSibling

	parentWrapper ifNil: [^Beeper beep].
	parentWrapper addNewChildAfter: item.! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 17:08'!
contents

	^item children collect: [ :each | 
		EToyTextNodeWrapper with: each model: model parent: self
	].
! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
delete

	parentWrapper ifNil: [^Beeper beep].
	parentWrapper withoutListWrapper removeChild: item withoutListWrapper.
! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 00:43'!
hasContents

	^true! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:51'!
parentWrapper: anotherWrapper

	parentWrapper _ anotherWrapper
! !


!EToyTextNodeWrapper methodsFor: 'converting' stamp: 'RAA 7/30/2000 00:56'!
asString

	^item contents! !

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

EToyTextNodeWrapper class
	instanceVariableNames: ''!

!EToyTextNodeWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:52'!
with: anObject model: aModel parent: anotherWrapper

	^self new
		setItem: anObject model: aModel;
		parentWrapper: anotherWrapper! !
EToyVocabulary subclass: #EToyVectorVocabulary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Protocols'!
!EToyVectorVocabulary commentStamp: '<historical>' prior: 0!
An extension of the etoy vocabulary in support of an experiment Alan Kay requested in summer 2001 for allowing any morph/player to be thought of as a vector.  In effect, adds a category #vector to the viewer for such all morphs.  Consult Ted Kaehler and Alan Kay for more information on this track.!


!EToyVectorVocabulary methodsFor: 'initialization' stamp: 'sw 9/10/2001 14:44'!
addCustomCategoriesTo: categoryList
	"Add any further categories to the default list of viewer categories for an object"

	categoryList add: #vector! !

!EToyVectorVocabulary methodsFor: 'initialization' stamp: 'sw 9/26/2001 03:56'!
eToyVectorTable
	"Answer a table of specifications to send to #addFromTable: which add the 'players are vectors' extension to the etoy vocabulary."

	"(selector setterOrNil ((arg name  arg type)...) resultType (category ...) 'help msg' 'wording' autoUpdate)"

	^ #(

(+ nil ((aVector  Player)) Player (geometry) 'Adds two players together, treating each as a vector from the origin.')
(- nil ((aVector  Player)) Player (geometry) 'Subtracts one player from another, treating each as a vector from the origin.')
(* nil ((aVector  Number)) Player (geometry) 'Multiply a player by a number, treating the Player as a vector from the origin.')
(/ nil ((aVector  Number)) Player (geometry) 'Divide a player by a Number, treating the Player as a vector from the origin.')

(incr: nil ((aVector  Player)) unknown (geometry) 'Each Player is a vector from the origin.  Increase one by the amount of the other.' 'increase by')
(decr: nil ((aVector  Player)) unknown (geometry) 'Each Player is a vector from the origin.  Decrease one by the amount of the other.' 'decrease by')
(multBy: nil ((factor  Number)) unknown (geometry) 'A Player is a vector from the origin.  Multiply its length by the factor.' 'multiplied by')
(dividedBy: nil ((factor  Number)) unknown (geometry) 'A Player is a vector from the origin.  Divide its length by the factor.' 'divided by')

"distance and theta are already in Player.  See additionsToViewerCategoryGeometry"
).! !

!EToyVectorVocabulary methodsFor: 'initialization' stamp: 'mir 7/15/2004 19:29'!
initialize
	"Initialize the vocabulary"

	super initialize.
	self addFromTable: self eToyVectorTable.
	self vocabularyName: #Vector.
	self documentation: 'This vocabulary adds to the basic etoy experience an interpretation of "players are vectors", requested by Alan Kay and implemented by Ted Kaehler in summer 2001'.
! !


!EToyVectorVocabulary methodsFor: 'method list' stamp: 'sw 7/9/2005 12:02'!
allMethodsInCategory: aCategorySymbol forInstance: anObject ofClass: aClass
	"Answer a list of all methods in the etoy interface which are in the given category, on behalf of anObject, or if it is nil, aClass"

	^ ((anObject isKindOf: Player) and: [aCategorySymbol == #vector])
			ifTrue:
				[anObject costume class vectorAdditions collect:
					[:anAddition | (self methodInterfaceFrom: anAddition) selector]]
			ifFalse:
				[super allMethodsInCategory: aCategorySymbol forInstance: anObject ofClass: aClass]! !
Vocabulary subclass: #EToyVocabulary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Protocols'!
!EToyVocabulary commentStamp: '<historical>' prior: 0!
EToyVocabulary - a vocabulary mirroring the capabilities available to end users in Squeak's old 1997-2000 etoy prototype.!


!EToyVocabulary methodsFor: 'category list' stamp: 'nk 8/29/2004 17:17'!
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given object, considering only code implemented in aClass and lower"

	^ (anObject isPlayerLike)
		ifTrue:
			[self flag: #deferred.  "The bit commented out on next line is desirable but not yet workable, because it delivers categories that are not relevant to the costume in question"
			"#(scripts #'instance variables'), (super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass)]"

			self translatedWordingsFor: ((mostGenericClass == aClass)
				ifFalse:
					[anObject categoriesForVocabulary: self]
				ifTrue:
					[{ScriptingSystem nameForScriptsCategory.  ScriptingSystem nameForInstanceVariablesCategory}])]
		ifFalse:
			[super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass]! !


!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 9/13/2001 16:36'!
addCustomCategoriesTo: categoryList
	"Add any further categories to the categoryList -- for benefit of subclasses wishing to override."! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 12/12/2000 06:06'!
encompassesAPriori: aClass
	"Answer whether an object, by its very nature, is one that the receiver embraces"

	^ aClass isKindOf: Player class! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 12/18/2000 14:33'!
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
	"Answer whether the vocabulary includes the given selector for the given class (and instance, if provided), only considering method implementations in mostGenericClass and lower"

	| classToUse aClass theKeys |
	(aTargetClass isUniClass and:
		[(aTargetClass namedTileScriptSelectors includes: aSelector) or:
			[(((theKeys _ aTargetClass slotInfo keys collect:
				[:anInstVarName | Utilities getterSelectorFor: anInstVarName])) includes: aSelector)
					or:
						[(theKeys collect: [:anInstVarName | Utilities setterSelectorFor: anInstVarName]) includes: aSelector]]]) ifTrue: [^ true].

	(methodInterfaces includesKey: aSelector) ifFalse: [^ false].
	classToUse _ self classToUseFromInstance: anInstance ofClass: aTargetClass.
	^ (aClass _ classToUse whichClassIncludesSelector: aSelector)
		ifNil:
			[false]
		ifNotNil:
			[aClass includesBehavior: mostGenericClass]
! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 9/13/2001 16:39'!
methodInterfaceFrom: elementTuple
	"Tedious revectoring:  The argument is a tuple of the sort that #additionsToViewerCategory: answers a list of; answer a MethodInterface"

	^ elementTuple first == #command
		ifTrue:
			[MethodInterface new initializeFromEToyCommandSpec: elementTuple category: nil]
		ifFalse:  "#slot format"
			[MethodInterface new initializeFromEToySlotSpec: elementTuple]! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'RAA 6/4/2001 19:12'!
objectForDataStream: refStrm
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	vocabularyName == #eToy ifFalse: [^ self].

	^ DiskProxy 
		global: #Vocabulary
		selector: #vocabularyNamed: 
		args: (Array with: vocabularyName)
! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'nk 10/6/2004 11:56'!
setCategoryDocumentationStrings
	"Initialize the documentation strings associated with the old etoy categories, in English"

	self setCategoryStrings: #(
(basic					'basic'					'a few important things')
(#'book navigation'		'book navigation'		'relating to book, stacks, etc')
(button					'button'					'for thinking of this object as a push-button control')
(collections				'collections'				'for thinking of this object as a collection')
(fog					'fog'					'3D fog')
(geometry				'geometry' 				'measurements and coordinates')
(#'color & border'		'color & border'			'matters concerning the colors and borders of objects')
(graphics				'graphics'				'for thinking of this object as a picture')
(variables				'variables'				'variables added by this object')
(joystick				'joystick'				'the object as a Joystick')
(miscellaneous			'miscellaneous' 			'various commands')
(motion					'motion' 				'matters relating to moving and turning')
(paintbox				'paintbox'				'the painting palette')
(#'pen trails'			'pen trails'				'relating to trails put down by pens')
(#'pen use'				'pen use' 				'use of an object''s "pen"')
(playfield				'playfield'				'the object as a container for other visible objects')
(sampling				'sampling'				'sampling')
(scripting				'scripting'				'commands to start and stop scripts')
(scripts					'scripts'					'methods added by this object')
(slider					'slider'					'functions useful to sliders')
(speaker				'speaker'				'the object as an audio Speaker')
(#'stack navigation'		'stack navigation'		'navigation within a stck')
(storyboard				'storyboard'				'storyboard')
(tests					'tests'					'yes/no tests, to use in "Test" panes of scripts')
(text					'text'					'The object as text')
(vector					'vector'					'The object as a vector')
(viewing				'viewing'				'matters relating to viewing')
 ) ! !


!EToyVocabulary methodsFor: 'method list' stamp: 'sw 10/7/2004 17:09'!
allMethodsInCategory: aCategoryName forInstance: anObject ofClass: aClass
	"Answer a list of all methods in the etoy interface which are in the given category, on behalf of anObject, or if it is nil, aClass"

	| aCategory unfiltered suitableSelectors isAll |

	aCategoryName ifNil: [^ OrderedCollection new].
	aClass isUniClass ifTrue:
		[aCategoryName = ScriptingSystem nameForScriptsCategory ifTrue:
			[^ aClass namedTileScriptSelectors].
		aCategoryName = ScriptingSystem nameForInstanceVariablesCategory ifTrue:
			[^ aClass slotInfo keys asSortedArray collect:
				[:anInstVarName | Utilities getterSelectorFor: anInstVarName]]].
	unfiltered _ (isAll _ aCategoryName = self allCategoryName)
		ifTrue:
			[methodInterfaces collect: [:anInterface | anInterface selector]]
		ifFalse:
			[aCategory _ categories detect: [:cat | cat categoryName = aCategoryName] 
							ifNone: [^ OrderedCollection new].
			aCategory elementsInOrder collect: [:anElement | anElement selector]].

	(anObject isKindOf: Player) ifTrue:
		[suitableSelectors _ anObject costume selectorsForViewer.
		unfiltered _ unfiltered  select:
			[:aSelector | suitableSelectors includes: aSelector]].
	(isAll and: [aClass isUniClass]) ifTrue:
		[unfiltered addAll: aClass namedTileScriptSelectors.
		unfiltered addAll: (aClass slotInfo keys asSortedArray collect:
			[:anInstVarName | Utilities getterSelectorFor: anInstVarName])].

	^ (unfiltered copyWithoutAll: #(dummy unused)) asSortedArray! !

!EToyVocabulary methodsFor: 'method list' stamp: 'sw 8/3/2005 14:03'!
masterOrderingOfPhraseSymbols
	"Answer a dictatorially-imposed presentation list of phrase-symbols.  This governs the order in which suitable phrases are presented in etoy viewers using the etoy vocabulary.  For any given category, the default implementation is that any items that are in this list will occur first, in the order specified here; after that, all other items will come, in alphabetic order by formal selector."

	^ #(beep: forward: turn: getX getY getLocationRounded getHeading getScaleFactor

		getLeft getRight getTop getBottom  
		getLength getWidth 
		getTheta getDistance getHeadingTheta getUnitVector

		startScript: pauseScript: stopScript: startAll: pauseAll: stopAll: tellAllSiblings: doScript:

		getColor getUseGradientFill getSecondColor  getRadialGradientFill  getBorderWidth getBorderColor getBorderStyle getRoundedCorners getDropShadow getShadowColor 

		getVolume play playUntilPosition: stop rewind getIsRunning getRepeat getPosition getTotalFrames getTotalSeconds getFrameGraphic getVideoFileName getSubtitlesFileName

		getGraphic getBaseGraphic

		getAllowEtoyUserCustomEvents 

		#getAutoExpansion #getAutoLineLayout #getBatchPenTrails getDropProducesWatcher #getFenceEnabled #getIndicateCursor #getIsOpenForDragNDrop #getIsPartsBin #getMouseOverHalos #getOriginAtCenter #getShowThumbnail

	 getFenceEnabled getKeepTickingWhilePainting getOliveHandleForScriptedObjects  getUseVectorVocabulary 

)! !

!EToyVocabulary methodsFor: 'method list' stamp: 'sw 7/14/2004 18:24'!
phraseSymbolsToSuppress
	"Answer a dictatorially-imposed list of phrase-symbols that are to be suppressed from viewers when the eToyFriendly preference is set to true.  This list at the moment corresponds to the wishes of Alan and Kim and the LA teachers using Squeak in school-year 2001-2"

	^ Preferences eToyFriendly
		ifTrue:
			[#(moveToward: followPath goToRightOf:
				getViewingByIcon initiatePainting
				append: prepend: getClipSubmorphs touchesA:)]
		ifFalse:
			[#()]! !


!EToyVocabulary methodsFor: '*flexibleVocabularies-flexibleVocabularies-testing' stamp: 'nk 8/29/2004 17:20'!
isEToyVocabulary
	^true! !


!EToyVocabulary methodsFor: '*flexibleVocabularies-flexiblevocabularies-initialization' stamp: 'stephaneducasse 2/4/2006 20:33'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	|   classes aMethodCategory selector selectors categorySymbols aMethodInterface |
	super initialize.
	self vocabularyName: #eToy.
	self documentation: '"EToy" is a vocabulary that provides the equivalent of the 1997-2000 etoy prototype'.
	categorySymbols := Set new.
	classes := self class morphClassesDeclaringViewerAdditions.
	classes do:
		[:aMorphClass | categorySymbols addAll: aMorphClass unfilteredCategoriesForViewer].
	self addCustomCategoriesTo: categorySymbols.  "For benefit, e.g., of EToyVectorVocabulary"

	categorySymbols asOrderedCollection do:
		[:aCategorySymbol |
			aMethodCategory := ElementCategory new categoryName: aCategorySymbol.
			selectors := Set new.
			classes do:
				[:aMorphClass |
					 (aMorphClass additionsToViewerCategory: aCategorySymbol) do:
						[:anElement |
						aMethodInterface := self methodInterfaceFrom: anElement.
						selectors add: (selector := aMethodInterface selector).
						(methodInterfaces includesKey: selector) ifFalse:
							[methodInterfaces at: selector put: aMethodInterface].
						self flag: #deferred.
						"NB at present, the *setter* does not get its own method interface.  Need to revisit"].

			(selectors copyWithout: #unused) asSortedArray do:
				[:aSelector |
					aMethodCategory elementAt: aSelector put: (methodInterfaces at: aSelector)]].
				 
			self addCategory: aMethodCategory].

	self addCategoryNamed: ScriptingSystem nameForInstanceVariablesCategory.
	self addCategoryNamed: ScriptingSystem nameForScriptsCategory.
	self setCategoryDocumentationStrings.
	(self respondsTo: #applyMasterOrdering)
		ifTrue: [ self applyMasterOrdering ].! !

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

EToyVocabulary class
	instanceVariableNames: ''!

!EToyVocabulary class methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'nk 10/8/2004 16:21'!
masterOrderingOfCategorySymbols
	"Answer a dictatorially-imposed presentation list of category symbols.
	This governs the order in which available vocabulary categories are presented in etoy viewers using the etoy vocabulary.
	The default implementation is that any items that are in this list will occur first, in the order specified here; after that, all other items will come, in alphabetic order by their translated wording."

	^#(basic #'color & border' geometry motion #'pen use' tests layout #'drag & drop' scripting observation button search miscellaneous)! !

!EToyVocabulary class methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'nk 7/3/2003 20:07'!
morphClassesDeclaringViewerAdditions
	"Answer a list of actual morph classes that either implement #additionsToViewerCategories,
	or that have methods that match #additionToViewerCategory* ."

	^(Morph class allSubInstances select: [ :ea | ea hasAdditionsToViewerCategories ])
! !

!EToyVocabulary class methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'nk 9/11/2004 18:00'!
vocabularySummary
	"Answer a string describing all the vocabulary defined anywhere in the 
	system."
	"
	(StringHolder new contents: EToyVocabulary vocabularySummary)  
	openLabel: 'EToy Vocabulary' translated 
	"
	| etoyVocab rt interfaces allAdditions |
	etoyVocab := Vocabulary eToyVocabulary.
	etoyVocab initialize.		"just to make sure that it's unfiltered."
	^ String streamContents: [:s |
		self morphClassesDeclaringViewerAdditions do: [:cl | 
			s nextPutAll: cl name; cr.
			allAdditions := cl allAdditionsToViewerCategories.
			cl unfilteredCategoriesForViewer do: [ :cat |
				allAdditions at: cat ifPresent: [ :additions |
					interfaces := ((etoyVocab categoryAt: cat) ifNil: [ ElementCategory new ]) elementsInOrder.
					interfaces := interfaces
								select: [:ea | additions
										anySatisfy: [:tuple | (tuple first = #slot
												ifTrue: [tuple at: 7]
												ifFalse: [tuple at: 2])
												= ea selector]].
					s tab; nextPutAll: cat translated; cr.
					interfaces
						do: [:if | 
							s tab: 2.
							rt := if resultType.
							rt = #unknown
								ifTrue: [s nextPutAll: 'command' translated]
								ifFalse: [s nextPutAll: 'property' translated;
										 nextPut: $(;
										 nextPutAll: (if companionSetterSelector
											ifNil: ['RO']
											ifNotNil: ['RW']) translated;
										 space;
										 nextPutAll: rt translated;
										 nextPutAll: ') '].
							s tab; print: if wording; space.
							if argumentVariables
								do: [:av | s nextPutAll: av variableName;
										 nextPut: $(;
										 nextPutAll: av variableType asString;
										 nextPut: $)]
								separatedBy: [s space].
							s tab; nextPutAll: if helpMessage; cr]]]]]! !
EUCTextConverter subclass: #EUCJPTextConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!EUCJPTextConverter commentStamp: '<historical>' prior: 0!
Text converter for Japanese variation of EUC.!


!EUCJPTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'!
languageEnvironment

	^ JapaneseEnvironment.
! !

!EUCJPTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'!
leadingChar

	^ JISX0208 leadingChar
! !

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

EUCJPTextConverter class
	instanceVariableNames: ''!

!EUCJPTextConverter class methodsFor: 'utilities' stamp: 'yo 12/19/2003 22:00'!
encodingNames 

	^ #('euc-jp' 'eucjp') copy
! !
EUCTextConverter subclass: #EUCKRTextConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!EUCKRTextConverter commentStamp: '<historical>' prior: 0!
Text converter for Korean variation of EUC.!


!EUCKRTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'!
languageEnvironment

	^ KoreanEnvironment.
! !

!EUCKRTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 15:19'!
leadingChar

	^ KSX1001 leadingChar
! !

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

EUCKRTextConverter class
	instanceVariableNames: ''!

!EUCKRTextConverter class methodsFor: 'utilities' stamp: 'yo 2/17/2004 18:45'!
encodingNames 

	^ #('euc-kr' 'ks-c-5601-1987' 'euckr') copy
! !
TextConverter subclass: #EUCTextConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!EUCTextConverter commentStamp: '<historical>' prior: 0!
Text converter for Extended Unix Character.  This is an abstract class.  The CJK variations are implemented as subclasses.!


!EUCTextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:25'!
nextFromStream: aStream

	| character1 character2 offset value1 value2 nonUnicodeChar |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	character1 asciiValue <= 127 ifTrue: [^ character1].
	character2 _ aStream basicNext.
	character2 = nil ifTrue: [^ nil].
	offset _ 16rA1.
	value1 _ character1 asciiValue - offset.
	value2 _ character2 asciiValue - offset.
	(value1 < 0 or: [value1 > 93]) ifTrue: [^ nil].
	(value2 < 0 or: [value2 > 93]) ifTrue: [^ nil].

	nonUnicodeChar _ Character leadingChar: self leadingChar code: value1 * 94 + value2.
	^ Character leadingChar: self languageEnvironment leadingChar code: nonUnicodeChar asUnicode.
! !

!EUCTextConverter methodsFor: 'conversion' stamp: 'ar 4/12/2005 14:10'!
nextPut: aCharacter toStream: aStream 
	| value leadingChar nonUnicodeChar value1 value2 |
	aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream].
	value _ aCharacter charCode.
	leadingChar _ aCharacter leadingChar.
	(leadingChar = 0 and: [value < 128]) ifTrue: [
		aStream basicNextPut: (Character value: value).
		^ aStream
	].

	(128 <= value and: [value < 256]) ifTrue: [^ aStream].
	aCharacter isTraditionalDomestic ifFalse: [
		nonUnicodeChar _ self nonUnicodeClass charFromUnicode: value.
	] ifTrue: [
		nonUnicodeChar _(Character value: value)
	].
	nonUnicodeChar ifNotNil: [
		value _ nonUnicodeChar charCode.
		value1 _ value // 94 + 161.
		value2 _ value \\ 94 + 161.
		aStream basicNextPut: (Character value: value1).
		aStream basicNextPut: (Character value: value2).
		^ aStream
	]
! !


!EUCTextConverter methodsFor: 'friend' stamp: 'yo 1/18/2004 15:10'!
restoreStateOf: aStream with: aConverterState

	aStream position: aConverterState.
! !

!EUCTextConverter methodsFor: 'friend' stamp: 'yo 1/18/2004 15:10'!
saveStateOf: aStream

	^ aStream position.
! !


!EUCTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:40'!
languageEnvironment

	self subclassResponsibility
! !

!EUCTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'!
leadingChar

	^ self subclassResponsibility
! !

!EUCTextConverter methodsFor: 'private' stamp: 'yo 10/4/2003 15:48'!
nonUnicodeClass

	^ (EncodedCharSet charsetAt: self leadingChar).
! !
Object subclass: #EditCommand
	instanceVariableNames: 'textMorph phase replacedText replacedTextInterval newText newTextInterval lastSelectionInterval'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!EditCommand commentStamp: '<historical>' prior: 0!
This class handles all paragraph surgery in VI. In general, subclasses of EditCommand should be able to rely on the super class' undo/redo machinery -- only the repeat command needs to be overridden in most cases. This assumes, of course, that the newText, replacedText, newTextInterval, and replacedTextInterval have been set correctly.

When setting the interval, use normal mode style selections, not insert mode selections (see class comment of VIMorphEditor).

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!EditCommand methodsFor: 'accessors' stamp: 'sps 1/11/2002 17:12'!
iEditCommand
	^true! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 14:05'!
lastSelectionInterval
	^lastSelectionInterval! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36'!
newText
	^newText! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/4/2002 22:37'!
newTextInterval
	^newTextInterval! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36'!
newTextInterval: anInterval
	^newText _ anInterval! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36'!
newText: aText
	^newText _ aText! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:01'!
pEditor
	^textMorph editor
! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 13:40'!
phase
	^phase 
! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 13:40'!
phase: aSymbol
	^phase _ aSymbol
! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/11/2002 20:58'!
printOn: aStream

	| |
	aStream 
		nextPutAll: self class name;
		nextPut: $[;
		nextPutAll: ('new: ', newTextInterval asString,' -> "', newText, '", rText: ', replacedTextInterval asString,' -> "', replacedText, '"');
		nextPut: $].! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:37'!
replacedText
	^replacedText! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/4/2002 22:30'!
replacedTextInterval
	^replacedTextInterval! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36'!
replacedTextInterval: anInterval
	^replacedTextInterval _ anInterval! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:37'!
replacedText: aText
	^replacedText _ aText! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:04'!
textMorphEditor
	^textMorph editor
! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:05'!
textMorphString
	^textMorph text string 
! !

!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:02'!
textMorphStringSize
	^textMorph text string size
! !


!EditCommand methodsFor: 'command execution' stamp: 'sps 1/7/2002 21:37'!
doCommand

	^self redoCommand

	! !

!EditCommand methodsFor: 'command execution' stamp: 'sps 7/24/2003 17:04'!
redoCommand

	| |

"Debug dShow: ('rInterval: ', replacedTextInterval asString, '. rText: ', replacedText string, ' nInterval: ', newTextInterval asString, ' nText: ', newText string)."
	self textMorphEditor
		noUndoReplace: replacedTextInterval
		with: newText.

"Debug dShow: ('lastSelInt: ', lastSelectionInterval asString)."
! !

!EditCommand methodsFor: 'command execution' stamp: 'sps 7/24/2003 17:04'!
undoCommand

"Debug dShow: ('new Interval: ', newTextInterval asString, '. rText: ', replacedText string)."

	self textMorphEditor	
		noUndoReplace: newTextInterval
		with: replacedText.
		
	
! !


!EditCommand methodsFor: 'initialization' stamp: 'sps 7/24/2003 17:01'!
textMorph: tm
replacedText: rText 
replacedTextInterval: rInterval
newText: nText 
newTextInterval: nInterval


	textMorph _ tm.
	replacedText _ rText.
	replacedTextInterval _ rInterval.
	newText _ nText.
	newTextInterval _ nInterval.

! !


!EditCommand methodsFor: 'selection' stamp: 'sps 1/7/2002 19:54'!
doSelectionInterval
	^self redoSelectionInterval! !

!EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:34'!
redoSelectionInterval
"Return an interval to be displayed as a subtle selection after undo, or nil"

	^newTextInterval
! !

!EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:36'!
undoSelection
"Return an interval to be displayed as a selection after undo, or nil"

	^replacedTextInterval first to: (replacedTextInterval first + replacedText size - 1)
! !

!EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:03'!
undoSelectionInterval
"Return an interval to be displayed as a selection after undo, or nil"

	| i |
	i _ (replacedTextInterval first min: self textMorphStringSize).
	^i to: i - 1
! !

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

EditCommand class
	instanceVariableNames: ''!

!EditCommand class methodsFor: 'instance creation' stamp: 'sps 7/24/2003 17:08'!
textMorph: tm
replacedText: replacedText 
replacedTextInterval: replacedTextInterval
newText: newText 
newTextInterval: newTextInterval


	^(self new)
			textMorph: tm
			replacedText: replacedText 
			replacedTextInterval: replacedTextInterval
			newText: newText 
			newTextInterval: newTextInterval;
			yourself

! !
ObjectWithDocumentation subclass: #ElementCategory
	instanceVariableNames: 'categoryName keysInOrder elementDictionary'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!
!ElementCategory commentStamp: '<historical>' prior: 0!
ElementCategory
	
Contains a list of elements that affords keyed access but also has an inherent order.

Add items to the category by sending it elementAt:put:.
Obtain the elements in order by sending #elementsInOrder
Obtain the value of an element at a given key by sending #elementAt:!


!ElementCategory methodsFor: 'category name' stamp: 'sw 1/26/2001 22:45'!
categoryName
	"Answer the formal name of the category"

	^ categoryName! !

!ElementCategory methodsFor: 'category name' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoryName: aName
	"Set the category name"

	categoryName := aName! !


!ElementCategory methodsFor: 'copying' stamp: 'sw 12/1/2000 22:45'!
copy
	"Answer a copy of the receiver"

	^ super copy copyFrom: self! !

!ElementCategory methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:39'!
copyFrom: donor
	"Copy the receiver's contents from the donor"

	keysInOrder := donor keysInOrder.
	elementDictionary := donor copyOfElementDictionary! !

!ElementCategory methodsFor: 'copying' stamp: 'sw 12/1/2000 22:46'!
copyOfElementDictionary
	"Answer a copy of the element dictionary"

	^ elementDictionary copy! !


!ElementCategory methodsFor: 'elements' stamp: 'sw 12/1/2000 22:46'!
elementAt: aKey
	"Answer the element at the given key"

	^ elementDictionary at: aKey ifAbsent: [nil]! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 1/26/2001 22:54'!
elementAt: sym put: element
	"Add symbol at the end of my sorted list (unless it is already present), and put the element in the dictionary"

	(keysInOrder includes: sym) ifFalse: [keysInOrder add: sym].
	^ elementDictionary at: sym put: element! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 9/12/2001 22:59'!
elementSymbol
	"Answer the element symbol for the receiver.  Here, the categoryName dominates"

	^ categoryName! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 12/1/2000 22:47'!
elementsInOrder
	"Answer the elements in order"

	^ keysInOrder collect: [:aKey | elementDictionary at: aKey]! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 4/3/2001 11:06'!
fasterElementAt: sym put: element
	"Add symbol at the end of my sorted list and put the element in the dictionary.  This variant adds the key at the end of the keys list without checking whether it already exists."

	keysInOrder add: sym.
	^ elementDictionary at: sym put: element! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 1/26/2001 23:00'!
placeKey: key1 afterKey: key2
	"Place the first key after the second one in my keysInOrder ordering"

	keysInOrder remove: key1.
	keysInOrder add: key1 after: key2! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 1/26/2001 23:00'!
placeKey: key1 beforeKey: key2
	"Place the first key before the second one in my keysInOrder ordering"

	keysInOrder remove: key1.
	keysInOrder add: key1 before: key2! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 4/11/2001 20:08'!
removeElementAt: aKey
	"Remove the element at the given key"

	elementDictionary removeKey: aKey ifAbsent: [^ self].
	keysInOrder remove: aKey ifAbsent: []! !


!ElementCategory methodsFor: 'initialization' stamp: 'sw 3/30/2001 00:12'!
addCategoryItem: anItem
	"Add the item at the end, obtaining its key from itself (it must respond to #categoryName)"

	self elementAt: anItem categoryName put: anItem! !

!ElementCategory methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
clear
	"Clear the receiber's keysInOrder and elementDictionary"

	keysInOrder := OrderedCollection new.
	elementDictionary := IdentityDictionary new! !

!ElementCategory methodsFor: 'initialization' stamp: 'sw 3/28/2001 19:47'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	self clear! !


!ElementCategory methodsFor: 'keys' stamp: 'sw 12/11/2000 15:36'!
includesKey: aKey
	"Answer whether the receiver's dictionary holds the given key"

	^ elementDictionary includesKey: aKey! !

!ElementCategory methodsFor: 'keys' stamp: 'sw 12/1/2000 22:47'!
keysInOrder
	"Answer the keys in their sorted order"

	^ keysInOrder copy! !


!ElementCategory methodsFor: 'printing' stamp: 'sw 1/26/2001 22:47'!
printOn: aStream
	"Append to the argument, aStream, a sequence of characters that identifies the receiver."

	super printOn: aStream.
	categoryName ifNotNil: [aStream nextPutAll: ' named ', categoryName asString]! !


!ElementCategory methodsFor: 'translation' stamp: 'dgd 12/4/2003 20:22'!
translated
	"answer the receiver translated to the current language"
	
	^ self class new categoryName: categoryName asString translated asSymbol! !


!ElementCategory methodsFor: 'private' stamp: 'sw 8/6/2004 10:34'!
initWordingAndDocumentation
	"Initialize wording and documentation (helpMessage) for getters and setters"

	self wording: self categoryName! !
Object subclass: #ElementTranslation
	instanceVariableNames: 'wording helpMessage naturalLanguageSymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!

!ElementTranslation methodsFor: 'access' stamp: 'sw 8/18/2004 22:12'!
helpMessage
	"Answer the helpMessage"

	^ helpMessage! !
Object subclass: #EllipseMidpointTracer
	instanceVariableNames: 'rect x y a b aSquared bSquared d1 d2 inFirstRegion'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!EllipseMidpointTracer methodsFor: 'computing' stamp: 'ar 6/28/1999 15:35'!
stepInY
	"Step to the next y value"
	inFirstRegion ifTrue:[
		"In the upper region we must step until we reach the next y value"
		[(aSquared * (y-0.5)) > (bSquared * (x+1))] whileTrue:[
			d1 < 0.0
				ifTrue:[d1 _ d1 + (bSquared * (2*x+3)).
						x _ x + 1]
				ifFalse:[d1 _ d1 + (bSquared * (2*x+3)) + (aSquared * (-2*y+2)).
						y _ y - 1.
						^x _ x + 1]].
		"Stepping into second region"
		d2 _ (bSquared * (x + 0.5) squared) + (aSquared * (y-1) squared) - (aSquared * bSquared).
		inFirstRegion _ false.
	].
	"In the lower region each step is a y-step"
	d2 < 0.0
		ifTrue:[d2 _ d2 + (bSquared * (2*x+2)) + (aSquared * (-2*y+3)).
				x _ x + 1]
		ifFalse:[d2 _ d2 + (aSquared * (-2*y+3))].
	y _ y - 1.
	^x! !


!EllipseMidpointTracer methodsFor: 'initialize' stamp: 'ar 6/28/1999 15:33'!
on: aRectangle
	rect _ aRectangle.
	a _ rect width // 2.
	b _ rect height // 2.
	x _ 0.
	y _ b.
	aSquared _ a * a.
	bSquared _ b * b.
	d1 _ bSquared - (aSquared * b) + (0.25 * aSquared).
	d2 _ nil.
	inFirstRegion _ true.! !
BorderedMorph subclass: #EllipseMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!EllipseMorph commentStamp: 'kfr 10/27/2003 10:32' prior: 0!
A round BorderedMorph. Supports borderWidth and borderColor. 
Only simple borderStyle is implemented.

EllipseMorph new borderWidth:10; borderColor: Color green; openInWorld.
EllipseMorph new borderStyle:(SimpleBorder width: 5 color: Color blue); openInWorld.!


!EllipseMorph methodsFor: 'accessing' stamp: 'sw 11/24/1999 14:59'!
couldHaveRoundedCorners
	^ false! !

!EllipseMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:29'!
doesBevels
	^ false! !


!EllipseMorph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:27'!
areasRemainingToFill: aRectangle
	"Could be improved by quick check of inner rectangle"

	^ Array with: aRectangle! !

!EllipseMorph methodsFor: 'drawing' stamp: 'di 5/25/2001 01:37'!
drawOn: aCanvas 

	aCanvas isShadowDrawing
		ifTrue: [^ aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: 0 borderColor: nil].
	aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: borderWidth borderColor: borderColor.
! !


!EllipseMorph methodsFor: 'geometry testing' stamp: 'di 11/14/97 13:50'!
containsPoint: aPoint

	| radius other delta xOverY |
	(bounds containsPoint: aPoint) ifFalse: [^ false].  "quick elimination"
	(bounds width = 1 or: [bounds height = 1])
		ifTrue: [^ true].  "Degenerate case -- code below fails by a bit"

	radius _ bounds height asFloat / 2.
	other _ bounds width asFloat / 2.
	delta _ aPoint - bounds topLeft - (other@radius).
	xOverY _ bounds width asFloat / bounds height asFloat.
	^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! !


!EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

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


!EllipseMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'!
canDrawBorder: aBorderStyle
	^aBorderStyle style == #simple! !


!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^true! !


!EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:25'!
bottomLeftCorner
	^self intersectionWithLineSegmentFromCenterTo: bounds bottomLeft 
! !

!EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:23'!
bottomRightCorner
	^self intersectionWithLineSegmentFromCenterTo: bounds bottomRight 
! !

!EllipseMorph methodsFor: 'geometry' stamp: 'nk 2/15/2001 16:08'!
closestPointTo: aPoint
	^self intersectionWithLineSegmentFromCenterTo: aPoint! !

!EllipseMorph methodsFor: 'geometry' stamp: 'nk 2/13/2001 18:16'!
intersectionWithLineSegmentFromCenterTo: aPoint 
	| dx aSquared bSquared m mSquared xSquared x y dy |
	(self containsPoint: aPoint)
		ifTrue: [ ^aPoint ].
	dx _ aPoint x - self center x.
	dy _ aPoint y - self center y.
	dx = 0
		ifTrue: [ ^self bounds pointNearestTo: aPoint ].
	m _ dy / dx.
	mSquared _ m squared.
	aSquared _ (self bounds width / 2) squared.
	bSquared _ (self bounds height / 2) squared.
	xSquared _ 1 / ((1 / aSquared) + (mSquared / bSquared)).
	x _ xSquared sqrt.
	dx < 0 ifTrue: [ x _ x negated ].
	y _ m * x.
	^ self center + (x @ y) asIntegerPoint.
! !

!EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:23'!
topLeftCorner
	^self intersectionWithLineSegmentFromCenterTo: bounds topLeft 
! !

!EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:26'!
topRightCorner
	^self intersectionWithLineSegmentFromCenterTo: bounds topRight
! !


!EllipseMorph methodsFor: 'rounding' stamp: 'ka 12/4/2005 00:52'!
cornerStyle: aSymbol
	"Set the receiver's corner style.  But, in this case, do *not*"

	self removeProperty: #cornerStyle.
	self changed! !

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

EllipseMorph class
	instanceVariableNames: ''!

!EllipseMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'!
descriptionForPartsBin
	^ self partName:	'Ellipse'
		categories:		#('Graphics' 'Basic')
		documentation:	'An elliptical or circular shape'! !


!EllipseMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/10/2003 13:03'!
initialize

	self registerInFlapsRegistry.	! !

!EllipseMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/10/2003 13:05'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(EllipseMorph	authoringPrototype		'Ellipse'			'An ellipse or circle')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(EllipseMorph	authoringPrototype		'Ellipse'			'An ellipse or circle')
						forFlapNamed: 'PlugIn Supplies'.]! !

!EllipseMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:33'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !
AlignmentMorph subclass: #EmbeddedWorldBorderMorph
	instanceVariableNames: 'heights minWidth minHeight'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalSupport'!

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:16'!
goAppView

	self worldIEnclose showApplicationView

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:17'!
goFactoryView

	self worldIEnclose showFactoryView

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:18'!
goFullView

	self worldIEnclose showFullView

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:18'!
goNormalProjectEntry

	| w |
	w _ self worldIEnclose.
	self delete.
	w project enter.

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 13:31'!
myTransformation

	^submorphs detect: [ :x | x isKindOf: TransformationMorph] ifNone: [nil]
! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/14/2000 10:48'!
myWorldChanged
	| trans |
	trans _ self myTransformation.
	self changed.
	self layoutChanged.
	trans ifNotNil:[
		trans extentFromParent: self innerBounds extent.
		bounds _ bounds topLeft extent: trans extent + (borderWidth * 2).
	].
	self changed.
! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:12'!
toggleZoom

	self bounds: (
		bounds area > (Display boundingBox area * 0.9) ifTrue: [
			Display extent // 4 extent: Display extent // 2.
		] ifFalse: [
			Display boundingBox
		]
	)

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 13:31'!
worldIEnclose

	^self myTransformation firstSubmorph	
					"quick hack since this is the only usage pattern at the moment"
! !


!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:04'!
appViewBoxArea

	^self genericBoxArea: 1
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:12'!
boxesAndColorsAndSelectors

	^{
		{self zoomBoxArea. Color blue. #toggleZoom}.
		{self appViewBoxArea. Color yellow. #goAppView}.
		{self factoryViewBoxArea. Color red. #goFactoryView}.
		{self fullViewBoxArea. Color cyan. #goFullView}.
		{self normalEntryBoxArea. Color white. #goNormalProjectEntry}.
	}! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:04'!
factoryViewBoxArea

	^self genericBoxArea: 2
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:04'!
fullViewBoxArea

	^self genericBoxArea: 3
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:03'!
genericBoxArea: countDownFromTop

	^self innerBounds right @ (self top + (countDownFromTop * 2 * borderWidth)) 
		extent: borderWidth @ borderWidth
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:04'!
normalEntryBoxArea

	^self genericBoxArea: 4
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:03'!
zoomBoxArea

	^self genericBoxArea: 0
! !


!EmbeddedWorldBorderMorph methodsFor: 'drawing' stamp: 'RAA 7/13/2000 10:08'!
drawOn: aCanvas

	super drawOn: aCanvas.
	self boxesAndColorsAndSelectors do: [ :each |
		aCanvas fillRectangle: each first fillStyle: each second
	].

! !


!EmbeddedWorldBorderMorph methodsFor: 'event handling' stamp: 'RAA 7/13/2000 10:10'!
handlesMouseDown: evt

	self boxesAndColorsAndSelectors do: [ :each |
		(each first containsPoint: evt cursorPoint) ifTrue: [^true]
	].
	^false

! !

!EmbeddedWorldBorderMorph methodsFor: 'event handling' stamp: 'RAA 7/13/2000 10:13'!
mouseDown: evt

	self boxesAndColorsAndSelectors do: [ :each |
		(each first containsPoint: evt cursorPoint) ifTrue: [
			^self perform: each third
		].
	].


! !


!EmbeddedWorldBorderMorph methodsFor: 'geometry' stamp: 'RAA 6/26/2000 19:10'!
extent: aPoint

	bounds extent = aPoint ifFalse: [
		self changed.
		bounds _ bounds topLeft extent: aPoint.
		self myWorldChanged.
	].
! !


!EmbeddedWorldBorderMorph methodsFor: 'initialization' stamp: 'em 3/24/2005 15:07'!
initialize

	super initialize.
	self setBalloonText: 'This is the frame of an embedded project. Click on the colored boxes:
blue - expand or reduce
yellow - app view
red - factory view
cyan - full view
white - enter the project completely' translated! !


!EmbeddedWorldBorderMorph methodsFor: 'layout' stamp: 'RAA 6/26/2000 18:45'!
minHeight: anInteger

	minHeight _ anInteger! !

!EmbeddedWorldBorderMorph methodsFor: 'layout' stamp: 'RAA 6/26/2000 18:46'!
minWidth: anInteger

	minWidth _ anInteger! !


!EmbeddedWorldBorderMorph methodsFor: 'menus' stamp: 'RAA 7/13/2000 10:16'!
addCustomMenuItems: menu hand: aHandMorph

	super addCustomMenuItems: menu hand: aHandMorph.

	self worldIEnclose
		addScalingMenuItems: menu 
		hand: aHandMorph
! !


!EmbeddedWorldBorderMorph methodsFor: 'WiW support' stamp: 'RAA 6/27/2000 19:23'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^20		"Embedded worlds come in front of other worlds' Project navigation morphs"! !
SelectionMenu subclass: #EmphasizedMenu
	instanceVariableNames: 'emphases'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Menus'!
!EmphasizedMenu commentStamp: '<historical>' prior: 0!
A selection menu in which individual selections are allowed to have different emphases.  Emphases allowed are: bold, italic, struckThrough, and plain.  Provide an emphasis array, with one element per selection, to use.  Refer to the class method #example.!


!EmphasizedMenu methodsFor: 'display'!
startUpWithCaption: captionOrNil
	self setEmphasis.
	^ super startUpWithCaption: captionOrNil! !


!EmphasizedMenu methodsFor: 'emphasis'!
emphases: emphasisArray
	emphases _ emphasisArray! !

!EmphasizedMenu methodsFor: 'emphasis' stamp: 'fc 2/19/2004 22:07'!
onlyBoldItem: itemNumber
	"Set up emphasis such that all items are plain except for the given item number.  "

	emphases _ (Array new: selections size) atAllPut: #normal.
	emphases at: itemNumber put: #bold! !


!EmphasizedMenu methodsFor: 'private' stamp: 'fc 2/20/2004 11:01'!
setEmphasis
	"Set up the receiver to reflect the emphases in the emphases array.  "

	| selStart selEnd currEmphasis |
	
	labelString _ labelString asText.
	emphases isEmptyOrNil ifTrue: [^ self].
	selStart _ 1.
	1 to: selections size do:
		[:line |
			selEnd _ selStart + (selections at: line) size - 1.
			((currEmphasis _ emphases at: line) size > 0 and: [currEmphasis ~~ #normal]) ifTrue:
				[labelString addAttribute: (TextEmphasis perform: currEmphasis)
					from: selStart to: selEnd].
			selStart _ selEnd + 2]! !

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

EmphasizedMenu class
	instanceVariableNames: ''!

!EmphasizedMenu class methodsFor: 'examples' stamp: 'fc 2/19/2004 22:06'!
example1
	"EmphasizedMenu example1"

	^ (self
		selections: #('how' 'well' 'does' 'this' 'work?' ) 
		emphases: #(#bold #normal #italic #struckOut #normal ))
			startUpWithCaption: 'A Menu with Emphases'! !

!EmphasizedMenu class methodsFor: 'examples' stamp: 'sw 9/11/97 16:14'!
example2
	"EmphasizedMenu example2"

	| aMenu |
	aMenu _ EmphasizedMenu selections: #('One' 'Two' 'Three' 'Four').
	aMenu onlyBoldItem: 3.
	^ aMenu startUpWithCaption: 'Only the Bold'! !

!EmphasizedMenu class methodsFor: 'examples' stamp: 'fc 2/19/2004 22:08'!
example3
	"EmphasizedMenu example3"

	^ (self
		selectionAndEmphasisPairs: #('how' #bold 'well' #normal 'does' #italic 'this' #struckOut 'work' #normal))
		startUpWithCaption: 'A Menu with Emphases'! !


!EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sw 12/23/96'!
selectionAndEmphasisPairs: interleavedList
	"An alternative form of call.  "
	| selList  emphList |
	selList _ OrderedCollection new.
	emphList _ OrderedCollection new.
	interleavedList pairsDo:
		[:aSel :anEmph |
			selList add: aSel.
			emphList add: anEmph].
	^ self selections:selList emphases: emphList! !

!EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:14'!
selections: selList emphases: emphList
	"Answer an instance of the receiver with the given selections and 
	emphases."

	^ (self selections: selList) emphases: emphList

"Example:
	(EmphasizedMenu
		selections: #('how' 'well' 'does' 'this' 'work?') 
		emphases: #(bold plain italic struckOut plain)) startUp"! !
Object subclass: #EncodedCharSet
	instanceVariableNames: ''
	classVariableNames: 'EncodedCharSets'
	poolDictionaries: ''
	category: 'Multilingual-Encodings'!
!EncodedCharSet commentStamp: 'yo 10/19/2004 19:08' prior: 0!
An abstract superclasss of the classes that represent encoded character sets.  In the old implementation, the charsets had more important role.  However, in the current implementation, the subclasses are used only for keeping the backward compatibility.

	The other confusion comes from the name of "Latin1" class.  It used to mean the Latin-1 (ISO-8859-1) character set, but now it primarily means that the "Western European languages that are covered by the characters in Latin-1 character set.
!


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

EncodedCharSet class
	instanceVariableNames: 'CompoundTextSequence'!

!EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 12/18/2002 12:34'!
isBreakableAt: index in: text

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 9/4/2002 22:51'!
printingDirection

	self subclassResponsibility.
! !


!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:55'!
canBeGlobalVarInitial: char

	| leadingChar |
	leadingChar _ char leadingChar.

	leadingChar = 0 ifTrue: [^ self isUppercase: char].
	^ self isLetter: char.
! !

!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 17:18'!
canBeNonGlobalVarInitial: char

	| leadingChar |
	leadingChar _ char leadingChar.

	leadingChar = 0 ifTrue: [^ self isLowercase: char].
	^ self isLetter: char.
! !

!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:44'!
isDigit: char
	"Answer whether the receiver is a digit."

	| value |
	value _ char asciiValue.
	^ value >= 48 and: [value <= 57].
! !

!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:40'!
isLetter: char
	"Answer whether the receiver is a letter."

	| value |
	value _ char asciiValue.
	^ (8r141 <= value and: [value <= 8r172]) or: [8r101 <= value and: [value <= 8r132]].
! !

!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:40'!
isLowercase: char
	"Answer whether the receiver is a lowercase letter.
	(The old implementation answered whether the receiver is not an uppercase letter.)"

	| value |
	value _ char asciiValue.
	^ 8r141 <= value and: [value <= 8r172].
! !

!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:44'!
isUppercase: char
	"Answer whether the receiver is an uppercase letter.
	(The old implementation answered whether the receiver is not a lowercase letter.)"

	| value |
	value _ char asciiValue.
	^ 8r101 <= value and: [value <= 8r132].
! !


!EncodedCharSet class methodsFor: 'class methods' stamp: 'tak 11/5/2005 18:14'!
charFromUnicode: unicode

	| table index |
	unicode < 128 ifTrue: [^ Character value: unicode].

	table _ self ucsTable.
	index _ table indexOf: unicode.
	index = 0 ifTrue: [
		^ nil.
	].

	^ Character leadingChar: self leadingChar code: index - 1.

! !

!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 9/4/2002 22:57'!
charsetAt: encoding

	^ EncodedCharSets at: encoding + 1 ifAbsent: [EncodedCharSets at: 1].
! !

!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 12/1/2003 19:29'!
digitValue: char
	"Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 
	otherwise. This is used to parse literal numbers of radix 2-36."

	| value |
	value _ char charCode.
	value <= $9 asciiValue 
		ifTrue: [^value - $0 asciiValue].
	value >= $A asciiValue 
		ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]].
	^ -1
! !

!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 1/19/2005 11:33'!
initialize
"
	self initialize
"
	self allSubclassesDo: [:each | each initialize].

	EncodedCharSets _ Array new: 256.

	EncodedCharSets at: 0+1 put: Latin1Environment.
	EncodedCharSets at: 1+1 put: JISX0208.
	EncodedCharSets at: 2+1 put: GB2312.
	EncodedCharSets at: 3+1 put: KSX1001.
	EncodedCharSets at: 4+1 put: JISX0208.
	EncodedCharSets at: 5+1 put: JapaneseEnvironment.
	EncodedCharSets at: 6+1 put: SimplifiedChineseEnvironment.
	EncodedCharSets at: 7+1 put: KoreanEnvironment.
	EncodedCharSets at: 8+1 put: GB2312.
	"EncodedCharSets at: 9+1 put: UnicodeTraditionalChinese."
	"EncodedCharSets at: 10+1 put: UnicodeVietnamese."
	EncodedCharSets at: 12+1 put: KSX1001.
	EncodedCharSets at: 13+1 put: GreekEnvironment.
	EncodedCharSets at: 14+1 put: Latin2Environment.
	EncodedCharSets at: 256 put: Unicode.
! !

!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 12/2/2004 16:13'!
isCharset

	^ true.
! !

!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 9/2/2002 16:32'!
leadingChar

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 11/4/2002 14:43'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	self subclassResponsibility.
! !

!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'!
ucsTable

	^ UCSTable latin1Table.
! !
ParseNode subclass: #Encoder
	instanceVariableNames: 'scopeTable nTemps supered requestor class literalStream selectorSet litIndSet litSet sourceRanges globalSourceRanges'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Kernel'!
!Encoder commentStamp: '<historical>' prior: 0!
I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger.!


!Encoder methodsFor: 'encoding'!
cantStoreInto: varName

	^StdVariables includesKey: varName! !

!Encoder methodsFor: 'encoding'!
encodeLiteral: object

	^self
		name: object
		key: (class literalScannedAs: object notifying: self)
		class: LiteralNode
		type: LdLitType
		set: litSet! !

!Encoder methodsFor: 'encoding'!
encodeSelector: selector

	^self
		name: selector
		key: selector
		class: SelectorNode
		type: SendType
		set: selectorSet! !

!Encoder methodsFor: 'encoding' stamp: 'di 12/4/1999 20:09'!
encodeVariable: name
	^ self encodeVariable: name sourceRange: nil ifUnknown: [ self undeclared: name ]! !

!Encoder methodsFor: 'encoding' stamp: 'ls 1/19/2001 12:59'!
encodeVariable: name ifUnknown: action
	^self encodeVariable: name sourceRange: nil ifUnknown: action! !

!Encoder methodsFor: 'encoding' stamp: 'yo 11/11/2002 10:22'!
encodeVariable: name sourceRange: range ifUnknown: action
	| varNode |
	varNode _ scopeTable at: name
			ifAbsent: 
				[(self lookupInPools: name 
					ifFound: [:assoc | varNode _ self global: assoc name: name])
					ifTrue: [varNode]
					ifFalse: [action value]].
	range ifNotNil: [
		name first canBeGlobalVarInitial ifTrue:
			[globalSourceRanges addLast: { name. range. false }]. ].

	(varNode isTemp and: [varNode scope < 0]) ifTrue: [
		OutOfScopeNotification signal ifFalse: [ ^self notify: 'out of scope'].
	].
	^ varNode! !

!Encoder methodsFor: 'encoding'!
litIndex: literal
	| p |
	p _ literalStream position.
	p = 256 ifTrue:
		[self notify: 'More than 256 literals referenced. 
You must split or otherwise simplify this method.
The 257th literal is: ', literal printString. ^nil].
		"Would like to show where it is in the source code, 
		 but that info is hard to get."
	literalStream nextPut: literal.
	^ p! !

!Encoder methodsFor: 'encoding' stamp: 'di 1/7/2000 15:24'!
sharableLitIndex: literal
	"Special access prevents multiple entries for post-allocated super send special selectors"
	| p |
	p _ literalStream originalContents indexOf: literal.
	p = 0 ifFalse: [^ p-1].
	^ self litIndex: literal
! !

!Encoder methodsFor: 'encoding' stamp: 'tk 4/20/1999 15:41'!
undeclared: name

	| sym |
	requestor interactive ifTrue: [
		requestor requestor == #error: ifTrue: [requestor error: 'Undeclared'].
		^ self notify: 'Undeclared'].
	Transcript show: ' (' , name , ' is Undeclared) '.
	sym _ name asSymbol.
	Undeclared at: sym put: nil.
	^self global: (Undeclared associationAt: sym) name: sym! !


!Encoder methodsFor: 'error handling'!
notify: string
	"Put a separate notifier on top of the requestor's window"
	| req |
	requestor == nil
		ifFalse: 
			[req _ requestor.
			self release.
			req notify: string].
	^false! !

!Encoder methodsFor: 'error handling'!
notify: string at: location

	| req |
	requestor == nil
		ifFalse: 
			[req _ requestor.
			self release.
			req notify: string at: location].
	^false! !

!Encoder methodsFor: 'error handling'!
requestor: req
	"Often the requestor is a BrowserCodeController"
	requestor _ req! !


!Encoder methodsFor: 'initialize-release'!
fillDict: dict with: nodeClass mapping: keys to: codeArray
	| codeStream |
	codeStream _ ReadStream on: codeArray.
	keys do: 
		[:key | dict 
				at: key
				put:  (nodeClass new name: key key: key code: codeStream next)]! !

!Encoder methodsFor: 'initialize-release' stamp: 'di 12/4/1999 22:22'!
init: aClass context: aContext notifying: req
	| node n homeNode indexNode |
	requestor _ req.
	class _ aClass.
	nTemps _ 0.
	supered _ false.
	self initScopeAndLiteralTables.
	n _ -1.
	class allInstVarNames do: 
		[:variable | 
		node _ VariableNode new
					name: variable
					index: (n _ n + 1)
					type: LdInstType.
		scopeTable at: variable put: node].
	aContext == nil
		ifFalse: 
			[homeNode _ self bindTemp: 'homeContext'.
			"first temp = aContext passed as arg"
			n _ 0.
			aContext tempNames do: 
				[:variable | 
				indexNode _ self encodeLiteral: (n _ n + 1).
				node _ MessageAsTempNode new
							receiver: homeNode
							selector: #tempAt:
							arguments: (Array with: indexNode)
							precedence: 3
							from: self.
				scopeTable at: variable put: node]].
	sourceRanges _ Dictionary new: 32.
	globalSourceRanges _ OrderedCollection new: 32.
! !

!Encoder methodsFor: 'initialize-release'!
initScopeAndLiteralTables

	scopeTable _ StdVariables copy.
	litSet _ StdLiterals copy.
	selectorSet _ StdSelectors copy.
	litIndSet _ Dictionary new: 16.
	literalStream _ WriteStream on: (Array new: 32)! !

!Encoder methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 18:46'!
nTemps: n literals: lits class: cl 
	"Decompile."

	supered _ false.
	class _ cl.
	nTemps _ n.
	literalStream _ ReadStream on: lits.
	literalStream position: lits size.
	sourceRanges _ Dictionary new: 32.
	globalSourceRanges _ OrderedCollection new: 32.
! !

!Encoder methodsFor: 'initialize-release'!
noteSuper

	supered _ true! !

!Encoder methodsFor: 'initialize-release'!
release

	requestor _ nil! !

!Encoder methodsFor: 'initialize-release' stamp: 'ajh 7/21/2003 00:53'!
temps: tempVars literals: lits class: cl 
	"Decompile."

	supered _ false.
	class _ cl.
	nTemps _ tempVars size.
	tempVars do: [:node | scopeTable at: node name put: node].
	literalStream _ ReadStream on: lits.
	literalStream position: lits size.
	sourceRanges _ Dictionary new: 32.
	globalSourceRanges _ OrderedCollection new: 32.
! !


!Encoder methodsFor: 'results' stamp: 'md 3/1/2006 10:47'!
allLiterals
	(literalStream isKindOf: WriteStream) ifTrue: [
		self litIndex: nil.
		self litIndex: class binding .
	].
	^ literalStream contents! !

!Encoder methodsFor: 'results'!
literals
	"Should only be used for decompiling primitives"
	^ literalStream contents! !

!Encoder methodsFor: 'results' stamp: 'di 10/12/1999 16:12'!
tempNames 

	^ self tempNodes collect:
		[:node | (node isMemberOf: MessageAsTempNode)
					ifTrue: [scopeTable keyAtValue: node]
					ifFalse: [node key]]! !

!Encoder methodsFor: 'results' stamp: 'di 10/12/1999 15:31'!
tempNodes 
	| tempNodes |
	tempNodes _ SortedCollection sortBlock: [:n1 :n2 | n1 code <= n2 code].
	scopeTable associationsDo:
		[:assn | assn value isTemp ifTrue: [tempNodes add: assn value]].
	^ tempNodes! !

!Encoder methodsFor: 'results'!
tempsAndBlockArgs
	| tempNodes var |
	tempNodes _ OrderedCollection new.
	scopeTable associationsDo:
		[:assn | var _ assn value.
		((var isTemp and: [var isArg not])
					and: [var scope = 0 or: [var scope = -1]])
			ifTrue: [tempNodes add: var]].
	^ tempNodes! !

!Encoder methodsFor: 'results' stamp: 'di 10/12/1999 17:15'!
unusedTempNames 
	| unused name |
	unused _ OrderedCollection new.
	scopeTable associationsDo:
		[:assn | (assn value isUnusedTemp)
			ifTrue: [name _ assn value key.
					name ~= 'homeContext' ifTrue: [unused add: name]]].
	^ unused! !


!Encoder methodsFor: 'source mapping' stamp: 'di 12/4/1999 22:27'!
globalSourceRanges

	^ globalSourceRanges! !

!Encoder methodsFor: 'source mapping'!
noteSourceRange: range forNode: node

	sourceRanges at: node put: range! !

!Encoder methodsFor: 'source mapping' stamp: 'RAA 8/21/1999 06:52'!
rawSourceRanges

	^ sourceRanges ! !

!Encoder methodsFor: 'source mapping'!
sourceMap
	"Answer with a sorted set of associations (pc range)."

	^ (sourceRanges keys collect: 
		[:key |  Association key: key pc value: (sourceRanges at: key)])
			asSortedCollection! !


!Encoder methodsFor: 'temps'!
autoBind: name 
	"Declare a block argument as a temp if not already declared."
	| node |
	node _ scopeTable 
			at: name
			ifAbsent: 
				[(self lookupInPools: name ifFound: [:assoc | assoc])
					ifTrue: [self notify: 'Name already used in a Pool or Global'].
				^ (self reallyBind: name) nowHasDef nowHasRef scope: 1].
	node isTemp
		ifTrue: [node scope >= 0 ifTrue:
					[^ self notify: 'Name already used in this method'].
				node nowHasDef nowHasRef scope: 1]
		ifFalse: [^ self notify: 'Name already used in this class'].
	^node! !

!Encoder methodsFor: 'temps' stamp: 'di 10/12/1999 16:53'!
bindAndJuggle: name

	| node nodes first thisCode |
	node _ self reallyBind: name.

	"Declared temps must precede block temps for decompiler and debugger to work right"
	nodes _ self tempNodes.
	(first _ nodes findFirst: [:n | n scope > 0]) > 0 ifTrue:
		[node == nodes last ifFalse: [self error: 'logic error'].
		thisCode _ (nodes at: first) code.
		first to: nodes size - 1 do:
			[:i | (nodes at: i) key: (nodes at: i) key
							code: (nodes at: i+1) code].
		nodes last key: nodes last key code: thisCode].
	
	^ node! !

!Encoder methodsFor: 'temps' stamp: 'jm 9/18/97 21:06'!
bindArg: name 
	"Declare an argument."
	| node |
	nTemps >= 15
		ifTrue: [^self notify: 'Too many arguments'].
	node _ self bindTemp: name.
	^ node nowHasDef nowHasRef! !

!Encoder methodsFor: 'temps' stamp: 'crl 2/26/1999 12:18'!
bindBlockTemp: name 
	"Declare a temporary block variable; complain if it's not a field or class variable."

	| node |

	node _ scopeTable at: name ifAbsent: [^self reallyBind: name].
	node isTemp
		ifTrue: [
			node scope >= 0 ifTrue: [^ self notify: 'Name already used in this method'].
			node scope: 0]
		ifFalse: [^self notify: 'Name already used in this class'].
	^node
! !

!Encoder methodsFor: 'temps' stamp: 'mir 1/17/2004 12:22'!
bindTemp: name 
	"Declare a temporary; error not if a field or class variable."
	scopeTable at: name ifPresent:[:node|
		"When non-interactive raise the error only if its a duplicate"
		(node isTemp or:[requestor interactive])
			ifTrue:[^self notify:'Name is already defined']
			ifFalse:[Transcript 
				show: '(', name, ' is shadowed in "' , class printString, '")']].
	^self reallyBind: name! !

!Encoder methodsFor: 'temps' stamp: 'mir 1/17/2004 12:31'!
bindTemp: name in: methodSelector
	"Declare a temporary; error not if a field or class variable."
	scopeTable at: name ifPresent:[:node|
		"When non-interactive raise the error only if its a duplicate"
		(node isTemp or:[requestor interactive])
			ifTrue:[^self notify:'Name is already defined']
			ifFalse:[Transcript 
				show: '(', name, ' is shadowed in "' , class printString , '>>' , methodSelector printString , '")']].
	^self reallyBind: name! !

!Encoder methodsFor: 'temps'!
maxTemp

	^nTemps! !

!Encoder methodsFor: 'temps'!
newTemp: name

	nTemps _ nTemps + 1.
	^ TempVariableNode new
		name: name
		index: nTemps - 1
		type: LdTempType
		scope: 0! !


!Encoder methodsFor: 'private'!
classEncoding
	"This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view."
	^ class! !

!Encoder methodsFor: 'private' stamp: 'ar 8/14/2001 23:12'!
global: ref name: name

	^self
		name: name
		key: ref
		class: LiteralVariableNode
		type: LdLitIndType
		set: litIndSet! !

!Encoder methodsFor: 'private' stamp: 'ar 5/17/2003 14:16'!
lookupInPools: varName ifFound: assocBlock

	Symbol hasInterned: varName ifTrue:[:sym|
		(class bindingOf: sym) ifNotNilDo:[:assoc| 
			assocBlock value: assoc.
			^true].
		(Preferences valueOfFlag: #lenientScopeForGlobals)  "**Temporary**"
			ifTrue: [^ Smalltalk lenientScopeHas: sym ifTrue: assocBlock]
			ifFalse: [^ false]].
	(class bindingOf: varName) ifNotNilDo:[:assoc|
		assocBlock value: assoc.
		^true].
	^false! !

!Encoder methodsFor: 'private'!
name: name key: key class: leafNodeClass type: type set: dict

	| node |
	^dict 
		at: key
		ifAbsent: 
			[node _ leafNodeClass new
						name: name
						key: key
						index: nil
						type: type.
			dict at: key put: node.
			^node]! !

!Encoder methodsFor: 'private' stamp: 'ar 1/2/2002 14:53'!
possibleNamesFor: proposedName
	| results |
	results _ class possibleVariablesFor: proposedName continuedFrom: nil.
	^ proposedName correctAgainst: nil continuedFrom: results.
! !

!Encoder methodsFor: 'private' stamp: 'yo 11/11/2002 10:23'!
possibleVariablesFor: proposedVariable

	| results |
	results _ proposedVariable correctAgainstDictionary: scopeTable
								continuedFrom: nil.
	proposedVariable first canBeGlobalVarInitial ifTrue:
		[ results _ class possibleVariablesFor: proposedVariable
						continuedFrom: results ].
	^ proposedVariable correctAgainst: nil continuedFrom: results.
! !

!Encoder methodsFor: 'private'!
reallyBind: name

	| node |
	node _ self newTemp: name.
	scopeTable at: name put: node.
	^node! !
Error subclass: #EndOfStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Extensions'!
!EndOfStream commentStamp: '<historical>' prior: 0!
Signalled when ReadStream>>next encounters a premature end.!


!EndOfStream methodsFor: 'description' stamp: 'hh 5/17/2000 00:30'!
isResumable
	"EndOfStream is resumable, so ReadStream>>next can answer"

	^ true! !


!EndOfStream methodsFor: 'exceptionDescription' stamp: 'RAA 5/17/2000 03:10'!
defaultAction
	"Answer ReadStream>>next default reply."

	^ nil! !
Object subclass: #Envelope
	instanceVariableNames: 'points loopStartIndex loopEndIndex loopStartMSecs loopMSecs target updateSelector loopEndMSecs endMSecs scale decayScale lastValue currValue valueIncr nextRecomputeTime noChangesDuringLoop'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!Envelope commentStamp: '<historical>' prior: 0!
An envelope models a three-stage progression for a musical note: attack, sustain, decay. Envelopes can either return the envelope value at a given time or can update some target object using a client-specified message selector.

The points instance variable holds an array of (time, value) points, where the times are in milliseconds. The points array must contain at least two points. The time coordinate of the first point must be zero and the time coordinates of subsequent points must be in ascending order, although the spacing between them is arbitrary. Envelope values between points are computed by linear interpolation.

The scale slot is initially set so that the peak of envelope matches some note attribute, such as its loudness. When entering the decay phase, the scale is adjusted so that the decay begins from the envelope's current value. This avoids a potential sharp transient when entering the decay phase.

The loopStartIndex and loopEndIndex slots contain the indices of points in the points array; if they are equal, then the envelope holds a constant value for the sustain phase of the note. Otherwise, envelope values are computed by repeatedly looping between these two points.

The loopEndMSecs slot can be set in advance (as when playing a score) or dynamically (as when responding to interactive inputs from a MIDI keyboard). In the latter case, the value of scale is adjusted to start the decay phase with the current envelope value. Thus, if a note ends before its attack is complete, the decay phase is started immediately (i.e., the attack phase is never completed).

For best results, amplitude envelopes should start and end with zero values. Otherwise, the sharp transient at the beginning or end of the note may cause audible clicks or static. For envelopes on other parameters, this may not be necessary.
!


!Envelope methodsFor: 'accessing' stamp: 'jm 8/17/1998 15:20'!
attackTime
	"Return the time taken by the attack phase."

	^ (points at: loopStartIndex) x
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:10'!
centerPitch: aNumber
	"Set the center pitch of a pitch-controlling envelope. This default implementation does nothing."
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 10:21'!
decayEndIndex

	^ points size
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 08:53'!
decayTime
	"Return the time taken by the decay phase."

	^ points last x - (points at: loopEndIndex) x
! !

!Envelope methodsFor: 'accessing' stamp: 'di 1/20/98 21:35'!
duration
	"Return the time of the final point."

	loopEndMSecs == nil
		ifTrue: [^ points last x]
		ifFalse: [^ loopEndMSecs + self decayTime].
! !

!Envelope methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration: seconds
	"Set the note duration to the given number of seconds."
	"Details: The duration is reduced by 19 mSec to ensure proper cutoffs even when the sound starts playing between doControl epochs."
	"Note: This is a hack. With a little additional work on the envelope logic, it should be possible to reduce or eliminate this fudge factor. In particular, an envelope should use the time remaining, rather than time-since-start to determine when to enter its decay phase. In addition, an envelope must be able to cut off in minimum time (~5-10 msec) if there isn't enough time to do their normal decay. All of this is to allow instruments with leisurely decays to play very short notes if necessary (say, when fast-forwarding through a score)." 

	| attack decay endTime |
	endMSecs := (seconds * 1000.0) asInteger - 19.
	attack := self attackTime.
	decay := self decayTime.
	endMSecs > (attack + decay)
		ifTrue: [endTime := endMSecs - decay]
		ifFalse: [
			endMSecs >= attack
				ifTrue: [endTime := attack]
				ifFalse: [endTime := endMSecs]].

	self sustainEnd: (endTime max: 0).
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'!
loopEndIndex

	^ loopEndIndex
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'!
loopStartIndex

	^ loopStartIndex
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:03'!
name

	^ self updateSelector allButLast
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'!
points

	^ points
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/24/97 14:36'!
scale

	^ scale
! !

!Envelope methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
scale: aNumber

	scale := aNumber asFloat.
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 09:25'!
target

	^ target
! !

!Envelope methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
target: anObject

	target := anObject.
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/24/97 14:34'!
updateSelector

	^ updateSelector
! !

!Envelope methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateSelector: aSymbol

	updateSelector := aSymbol.
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:13'!
volume: aNumber
	"Set the maximum volume of a volume-controlling envelope. This default implementation does nothing."
! !


!Envelope methodsFor: 'applying' stamp: 'stephaneducasse 2/4/2006 20:41'!
computeValueAtMSecs: mSecs
	"Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope."
	"Note: Unlike the private method incrementalComputeValueAtMSecs:, this method does is not increment. Thus it is slower, but it doesn't depend on being called sequentially at fixed time intervals."

	| t i |
	mSecs < 0 ifTrue: [^ 0.0].

	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t := (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i := self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i == nil ifTrue: [^ 0.0].  "past end"
		^ (self interpolate: t between: (points at: i - 1) and: (points at: i)) * decayScale].

	mSecs < loopStartMSecs ifTrue: [  "attack phase"
		i := self indexOfPointAfterMSecs: mSecs startingAt: 1.
		i = 1 ifTrue: [^ (points at: 1) y * scale].
		^ self interpolate: mSecs between: (points at: i - 1) and: (points at: i)].

	"sustain phase"
	loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y * scale].  "looping on a single point"
	t := loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
	i := self indexOfPointAfterMSecs: t startingAt: loopStartIndex.

	^ self interpolate: t between: (points at: i - 1) and: (points at: i)
! !

!Envelope methodsFor: 'applying' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset
	"Reset the state for this envelope."

	lastValue := -100000.0.  "impossible value"
	nextRecomputeTime := 0.
	self updateTargetAt: 0.
! !

!Envelope methodsFor: 'applying' stamp: 'stephaneducasse 2/4/2006 20:41'!
sustainEnd: mSecs
	"Set the ending time of the sustain phase of this envelope; the decay phase will start this point. Typically derived from a note's duration."
	"Details: to avoid a sharp transient, the decay phase is scaled so that the beginning of the decay matches the envelope's instantaneous value when the decay phase starts."

	| vIfSustaining firstVOfDecay |
	loopEndMSecs := nil. "pretend to be sustaining"
	decayScale := 1.0.
	nextRecomputeTime := 0.
	vIfSustaining := self computeValueAtMSecs: mSecs.  "get value at end of sustain phase"
	loopEndMSecs := mSecs.
	firstVOfDecay := (points at: loopEndIndex) y * scale.
	firstVOfDecay = 0.0
		ifTrue: [decayScale := 1.0]
		ifFalse: [decayScale := vIfSustaining / firstVOfDecay].
! !

!Envelope methodsFor: 'applying' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateTargetAt: mSecs
	"Send my updateSelector to the given target object with the value of this envelope at the given number of milliseconds from its onset. Answer true if the value changed."

	| newValue |
	newValue := self valueAtMSecs: mSecs.
	newValue = lastValue ifTrue: [^ false].
	target
		perform: updateSelector
		with: newValue.
	lastValue := newValue.
	^ true
! !

!Envelope methodsFor: 'applying' stamp: 'stephaneducasse 2/4/2006 20:41'!
valueAtMSecs: mSecs
	"Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope."

	mSecs < 0 ifTrue: [^ 0.0].
	mSecs < nextRecomputeTime
		ifTrue: [currValue := currValue + valueIncr]
		ifFalse: [currValue := self incrementalComputeValueAtMSecs: mSecs].
	^ currValue
! !


!Envelope methodsFor: 'storing' stamp: 'di 2/1/98 15:45'!
storeOn: strm
	strm nextPutAll: '((' , self class name;
		nextPutAll: ' points: '; store: (points collect: [:p | p x @ (p y roundTo: 0.00001)]);
		nextPutAll: ' loopStart: '; print: loopStartIndex;
		nextPutAll: ' loopEnd: '; print: loopEndIndex; nextPutAll: ')';
		nextPutAll: ' updateSelector: '; store: self updateSelector; nextPutAll: ';';
		nextPutAll: ' scale: '; print: scale; nextPutAll: ')'.
! !


!Envelope methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
checkParameters
	"Verify that the point array, loopStartIndex, and loopStopIndex obey the rules."

	| lastT t |
	points size > 1
		ifFalse: [^ self error: 'the point list must contain at least two points'].
	points first x = 0
		ifFalse: [^ self error: 'the time of the first point must be zero'].
	lastT := points first x.
	2 to: points size do: [:i |
		t := (points at: i) x.
		t >= lastT
			ifFalse: [^ self error: 'the points must be in ascending time order']].

	(loopStartIndex isInteger and:
	 [(loopStartIndex > 0) and: [loopStartIndex <= points size]])
		ifFalse: [^ self error: 'loopStartIndex is not a valid point index'].
	(loopEndIndex isInteger and:
	 [(loopEndIndex > 0) and: [loopEndIndex <= points size]])
		ifFalse: [^ self error: 'loopEndIndex is not a valid point index'].
	 loopStartIndex <= loopEndIndex
		ifFalse: [^ self error: 'loopEndIndex must not precede loopStartIndex'].
! !

!Envelope methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
computeIncrementAt: mSecs between: p1 and: p2 scale: combinedScale
	"Compute the current and increment values for the given time between the given inflection points."
	"Assume: p1 x <= mSecs <= p2 x"

	| valueRange timeRange |
	valueRange := (p2 y - p1 y) asFloat.
	timeRange := (p2 x - p1 x) asFloat.
	currValue := (p1 y + (((mSecs - p1 x) asFloat / timeRange) * valueRange)) * combinedScale.
	valueIncr := (((p2 y * combinedScale) - currValue) / (p2 x - mSecs)) * 10.0.
	^ currValue
! !

!Envelope methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
incrementalComputeValueAtMSecs: mSecs
	"Compute the current value, per-step increment, and the time of the next inflection point."
	"Note: This method is part of faster, but less general, way of computing envelope values. It depends on a known, fixed control updating rate."

	| t i |
	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t := (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i := self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i == nil ifTrue: [  "past end"
			currValue := points last y * scale * decayScale.
			valueIncr := 0.0.
			nextRecomputeTime := mSecs + 1000000.
			^ currValue].
		nextRecomputeTime := mSecs + ((points at: i) x - t).
		^ self computeIncrementAt: t
			between: (points at: i - 1)
			and: (points at: i)
			scale: scale * decayScale].

	mSecs < loopStartMSecs
		ifTrue: [  "attack phase"
			t := mSecs.
			i := self indexOfPointAfterMSecs: t startingAt: 1.
			nextRecomputeTime := mSecs + ((points at: i) x - t)]
		ifFalse: [  "sustain (looping) phase"
			noChangesDuringLoop ifTrue: [
				currValue := (points at: loopEndIndex) y * scale.
				valueIncr := 0.0.
				loopEndMSecs == nil
					ifTrue: [nextRecomputeTime := mSecs + 10]  "unknown end time"
					ifFalse: [nextRecomputeTime := loopEndMSecs].
				^ currValue].
			t := loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
			i := self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
			nextRecomputeTime := (mSecs + ((points at: i) x - t)) min: loopEndMSecs].

	^ self computeIncrementAt: t
		between: (points at: i - 1)
		and: (points at: i)
		scale: scale.
! !

!Envelope methodsFor: 'private' stamp: 'jm 12/16/97 16:51'!
indexOfPointAfterMSecs: mSecs startingAt: startIndex
	"Return the index of the first point whose time is greater that mSecs, starting with the given index. Return nil if mSecs is after the last point's time."

	startIndex to: points size do:
		[:i | (points at: i) x > mSecs ifTrue: [^ i]].
	^ nil
! !

!Envelope methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
interpolate: mSecs between: p1 and: p2
	"Return the scaled, interpolated value for the given time between the given time points."
	"Assume: p1 x <= mSecs <= p2 x"

	| valueRange timeRange |
	valueRange := (p2 y - p1 y) asFloat.
	valueRange = 0.0 ifTrue: [^ p1 y * scale].
	timeRange := (p2 x - p1 x) asFloat.
	^ (p1 y + (((mSecs - p1 x) asFloat / timeRange) * valueRange)) * scale.
! !

!Envelope methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
setPoints: pointList loopStart: startIndex loopEnd: endIndex

	| lastVal |
	points := pointList asArray collect: [:p | p x asInteger @ p y asFloat].
	loopStartIndex := startIndex.
	loopEndIndex := endIndex.
	self checkParameters.
	loopStartMSecs := (points at: loopStartIndex) x.
	loopMSecs := (points at: loopEndIndex) x - (points at: loopStartIndex) x.
	loopEndMSecs := nil.  "unknown end time; sustain until end time is known"
	scale ifNil: [scale := 1.0].
	decayScale ifNil: [decayScale := 1.0].

	"note if there are no changes during the loop phase"
	noChangesDuringLoop := true.
	lastVal := (points at: loopStartIndex) y.
	loopStartIndex to: loopEndIndex do: [:i | 
		(points at: i) y ~= lastVal ifTrue: [
			noChangesDuringLoop := false.
			^ self]].
! !

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

Envelope class
	instanceVariableNames: ''!

!Envelope class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
example
	"Envelope example"

	| p |
	p := Array with: 0@0 with: 100@1.0 with: 250@0.7 with: 400@1.0 with: 500@0.
	^ (self points: p loopStart: 2 loopEnd: 4) sustainEnd: 1200.
! !

!Envelope class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
exponentialDecay: multiplier
	"(Envelope exponentialDecay: 0.95) "

	| mSecsPerStep pList t v last |
	mSecsPerStep := 10.
	((multiplier > 0.0) and: [multiplier < 1.0])
		ifFalse: [self error: 'multiplier must be greater than 0.0 and less than 1.0'].
	pList := OrderedCollection new.
	pList add: 0@0.0.
	last := 0.0.
	v := 1.0.
	t := 10.
	[v > 0.01] whileTrue: [
		(v - last) abs > 0.02 ifTrue: [
			"only record substatial changes"
			pList add: t@v.
			last := v].
		t := t + mSecsPerStep.
		v := v * multiplier].
	pList add: (t + mSecsPerStep)@0.0.

	^ self points: pList asArray
		loopStart: pList size 
		loopEnd: pList size
! !

!Envelope class methodsFor: 'instance creation' stamp: 'jm 11/26/97 08:49'!
points: pList loopStart: loopStart loopEnd: loopEnd

	^ self new setPoints: pList asArray
		loopStart: loopStart
		loopEnd: loopEnd
! !
RectangleMorph subclass: #EnvelopeEditorMorph
	instanceVariableNames: 'sound soundName envelope hScale vScale graphArea pixPerTick limits limitXs limitHandles line prevMouseDown sampleDuration showAllEnvelopes denominator keyboard'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 7/14/2000 13:08'!
addControls
	| chooser |
	chooser _ PopUpChoiceMorph new extent: 110@14;
		contentsClipped: 'Editing: ' , envelope name;
		target: self;
		actionSelector: #chooseFrom:envelopeItem:;
		getItemsSelector: #curveChoices.
	chooser arguments: (Array with: chooser).
	self addMorph: chooser.
	chooser align: chooser bounds topLeft with: graphArea bounds bottomLeft + (0@5).

	chooser _ PopUpChoiceMorph new extent: 130@14;
		contentsClipped: 'Timbre: ' , soundName;
		target: self;
		actionSelector: #chooseFrom:soundItem:;
		getItemsSelector: #soundChoices.
	chooser arguments: (Array with: chooser).
	self addMorph: chooser.
	chooser align: chooser bounds topRight with: graphArea bounds bottomRight + (-50@5).
! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'ar 3/17/2001 14:24'!
addCurves
	"Add the polyLine corresponding to the currently selected envelope,
	and possibly all the others, too."
	| verts aLine |
	sound envelopes do:
		[:env | 
		(showAllEnvelopes or: [env == envelope]) ifTrue:
			[verts _ env points collect:
				[:p | (self xFromMs: p x) @ (self yFromValue: p y)].
			aLine _ EnvelopeLineMorph basicNew
						vertices: verts borderWidth: 1
						borderColor: (self colorForEnvelope: env).
			env == envelope
				ifTrue: [aLine borderWidth: 2.  line _ aLine]
				ifFalse: [aLine on: #mouseUp send: #clickOn:evt:from:
							to: self withValue: env.
						self addMorph: aLine]]].
	self addMorph: line  "add the active one last (in front)"! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'ar 3/17/2001 14:25'!
addHandlesIn: frame
	| handle |
	handle := PolygonMorph
		vertices: (Array with: 0@0 with: 8@0 with: 4@8)
		color: Color orange borderWidth: 1 borderColor: Color black.
	handle addMorph: ((RectangleMorph
			newBounds: ((self handleOffset: handle)-(2@0) extent: 1@(graphArea height-2))
			color: Color orange) borderWidth: 0).

	limitHandles _ Array with: handle with: handle veryDeepCopy with: handle veryDeepCopy.
	1 to: limitHandles size do:
		[:i | handle _ limitHandles at: i.
		handle on: #mouseDown
				send: #limitHandleMove:event:from:
				to: self withValue: i.
		handle on: #mouseMove
				send: #limitHandleMove:event:from:
				to: self withValue: i.
		self addMorph: handle.
		handle position: ((self xFromMs: 
			(envelope points at: (limits at: i)) x) @ 
				(graphArea top)) - (self handleOffset: handle)]! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 9/4/1998 15:49'!
addKeyboard
	keyboard _ PianoKeyboardMorph new soundPrototype: sound.
	keyboard align: keyboard bounds bottomCenter with: bounds bottomCenter - (0@4).
	self addMorph: keyboard! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 9/4/1998 15:56'!
buildGraphAreaIn: frame
	| r y |
	graphArea _ RectangleMorph
		newBounds: ((frame left + 40) @ (frame top + 40)
		corner: (frame right+1) @ (frame bottom - 60))
		color: Color lightGreen lighter lighter.
	graphArea borderWidth: 1.
	self addMorph: graphArea.
	(envelope updateSelector = #pitch: and: [envelope scale <= 2.0]) ifTrue:
		["Show half-steps"
		r _ graphArea innerBounds.
		0.0 to: 1.0 by: 1.0/12.0/envelope scale do:
			[:val |
			y _ self yFromValue: val.
			graphArea addMorph: ((RectangleMorph
					newBounds: (r left@y extent: r width@1)
					color: Color veryLightGray)
						borderWidth: 0)]].
	(envelope updateSelector = #ratio: and: [denominator ~= 9999]) ifTrue:
		["Show denominator gridding"
		r _ graphArea innerBounds.
		(0.0 to: 1.0 by: 1.0/denominator/envelope scale) do:
			[:v |
			y _ self yFromValue: v.
			graphArea addMorph: ((RectangleMorph
					newBounds: (r left@y extent: r width@1)
					color: Color veryLightGray)
						borderWidth: 0)]].
! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 9/4/1998 13:16'!
buildView
	| frame |
	self color: Color lightGreen.
	self removeAllMorphs.
	frame _ self innerBounds.
	self buildGraphAreaIn: frame.
	self buildScalesIn: frame.
	self addHandlesIn: frame.
	self addCurves.
	line addHandles.
	self addControls.
	self addKeyboard! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 2/3/98 16:50'!
colorForEnvelope: env
	| name index |
	name _ env name.
	index _ #('volume' 'modulation' 'pitch' 'ratio') indexOf: name
				ifAbsent: [5].
	^ Color perform: (#(red green blue magenta black) at: index)! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'JMV 1/29/2001 10:58'!
curveChoices
	| extant others |
	extant _ sound envelopes collect: [:env | env name].
	others _ #('volume' 'modulation' 'pitch' 'random pitch:' 'ratio')
		reject: [:x | (extant includes: x) | ((x = 'pitch') & (extant includes: 'random pitch:')) | ((x = 'random pitch:') & (extant includes: 'pitch')) ].
	^ (extant collect: [:name | 'edit ' , name])
	, (others collect: [:name | 'add ' , name])
	, (sound envelopes size > 1
		ifTrue: [Array with: 'remove ' , envelope name]
		ifFalse: [Array new])! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 1/26/98 15:37'!
handleOffset: handle
	"This is the offset from position to the bottom vertex"
	^ (handle width//2+1) @ handle height
! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 7/14/2000 12:56'!
soundChoices
	^ #('new...') , AbstractSound soundNames! !


!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'dgd 2/22/2003 14:23'!
acceptGraphPoint: p at: index 
	| ms val points whichLim linePoint other boundedP |
	boundedP := p adhereTo: graphArea bounds.
	ms := self msFromX: boundedP x.
	points := envelope points.
	ms := self 
				constrain: ms
				adjacentTo: index
				in: points.
	(index = 1 or: [(whichLim := limits indexOf: index) > 0]) 
		ifTrue: 
			["Limit points must not move laterally"

			ms := (points at: index) x].
	val := self valueFromY: boundedP y.
	points at: index put: ms @ val.
	linePoint := (self xFromMs: ms) @ (self yFromValue: val).
	(whichLim notNil and: [whichLim between: 1 and: 2]) 
		ifTrue: 
			["Loop start and loop end must be tied together"

			other := limits at: 3 - whichLim.	" 1 <--> 2 "
			points at: other put: (points at: other) x @ val.
			line verticesAt: other put: (line vertices at: other) x @ linePoint y].
	"Make sure envelope feels the change in points array..."
	envelope 
		setPoints: points
		loopStart: limits first
		loopEnd: (limits second).
	^linePoint! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'JMV 1/29/2001 10:57'!
addEnvelopeNamed: envName
	| points env |
	points _ OrderedCollection new.
	points add: 0@0.0;
		add: (envelope points at: envelope loopStartIndex) x@1.0;
		add: (envelope points at: envelope loopEndIndex) x@1.0;
		add: (envelope points last) x@0.0.
	envName = 'volume' ifTrue:
		[env _ VolumeEnvelope points: points loopStart: 2 loopEnd: 3.
		env target: sound; scale: 0.7].
	envName = 'modulation' ifTrue:
		[env _ Envelope points: (points collect: [:p | p x @ 0.5])
						loopStart: 2 loopEnd: 3.
		env target: sound; updateSelector: #modulation:;
			scale: sound modulation*2.0].
	envName = 'pitch' ifTrue:
		[env _ PitchEnvelope points: (points collect: [:p | p x @ 0.5])
						loopStart: 2 loopEnd: 3.
		env target: sound; updateSelector: #pitch:; scale: 0.5].
	envName = 'random pitch:' ifTrue:
		[env _ RandomEnvelope for: #pitch:.
		points _ OrderedCollection new.
		points add: 0@(env delta * 5 + 0.5);
			add: (envelope points at: envelope loopStartIndex) x@(env highLimit - 1 * 5 + 0.5);
			add: (envelope points at: envelope loopEndIndex) x@(env highLimit - 1 * 5 + 0.5);
			add: (envelope points last) x@(env lowLimit - 1 * 5 + 0.5).
		env setPoints: points loopStart: 2 loopEnd: 3.
		env target: sound. ].
	envName = 'ratio' ifTrue:
		[denominator _ 9999.  "No gridding"
		env _ Envelope points: (points collect: [:p | p x @ 0.5])
						loopStart: 2 loopEnd: 3.
		env target: sound; updateSelector: #ratio:;
			scale: sound ratio*2.0].
	env ifNotNil:
		[sound addEnvelope: env.
		self editEnvelope: env]! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'JMV 1/26/2001 11:28'!
buildScalesIn: frame
	| env hmajortick hminortick |
	env _ envelope.
	pixPerTick _ graphArea width // (self maxTime//10) max: 1.
	hminortick _ ( 1 + ( self maxTime // 800 ) ) * 10.
	hmajortick _ ( 1 + ( self maxTime // 800 ) ) * 100.
	hScale _ (ScaleMorph newBounds: ((graphArea left)@(frame top) corner: (self xFromMs: self maxTime)@(graphArea top - 1)))
		start: 0 stop: self maxTime
		minorTick: hminortick minorTickLength: 3
		majorTick: hmajortick majorTickLength: 10
		caption: 'milliseconds' tickPrintBlock: [:v | v printString].
	self addMorph: hScale.
	vScale _ ScaleMorph newBounds: (0@0 extent: (graphArea height)@(graphArea left - frame left)).
	env name = 'pitch'
		ifTrue:
		[env scale >= 2.0
			ifTrue:
			[vScale start: 0 stop: env scale
				minorTick: env scale / 24 minorTickLength: 3
				majorTick: env scale / 2.0 majorTickLength: 10
				caption: 'pitch (octaves)'
				tickPrintBlock: [:v | (v-(env scale/2)) asInteger printString]]
			ifFalse:
			[vScale start: 0 stop: env scale
				minorTick: 1.0/48.0 minorTickLength: 3
				majorTick: 1.0/12.0 majorTickLength: 10
				caption: 'pitch (half-steps)'
				tickPrintBlock: [:v | (v-(env scale/2)*12) rounded printString]]]
		ifFalse: [
			env name = 'random pitch:'
				ifTrue: [
					vScale start: 0.9 stop: 1.1
						minorTick: 0.2 / 50.0 minorTickLength: 3
						majorTick: 0.2 / 5.0 majorTickLength: 10
						caption: env name
						tickPrintBlock: [:v | v printString]]
				ifFalse: [
					vScale start: 0 stop: env scale
						minorTick: env scale / 50.0 minorTickLength: 3
						majorTick: env scale / 5.0 majorTickLength: 10
						caption: env name
						tickPrintBlock: [:v | v printString]].
		].
	vScale _ TransformationMorph new asFlexOf: vScale.
	vScale angle: Float pi / 2.0.
	self addMorph: vScale.
	vScale position: (frame left)@(graphArea top-1) - (3@1).
! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:24'!
clickOn: env evt: anEvent from: aLine
	self editEnvelope: env! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:27'!
clickOnLine: arg1 evt: arg2 envelope: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self clickOn: arg1 evt: arg2 from: arg3! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'di 1/29/98 13:06'!
constrain: xVal adjacentTo: ix in: points
	"Return xVal, restricted between points adjacent to vertX"
	| newVal |
	newVal _ xVal.
	ix > 1 ifTrue: [newVal _ newVal max: (points at: ix-1) x].
	ix < points size ifTrue: [newVal _ newVal min: (points at: ix+1) x].
	^ newVal! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'dgd 2/22/2003 14:24'!
deletePoint: ix 
	"If the point is a limit point, return false,
	otherwise, delete the point at ix, and return true."

	(limits includes: ix) ifTrue: [^false].
	1 to: limits size
		do: 
			[:i | 
			"Decrease limit indices beyond the deletion"

			(limits at: i) > ix ifTrue: [limits at: i put: (limits at: i) - 1]].
	envelope 
		setPoints: (envelope points 
				copyReplaceFrom: ix
				to: ix
				with: Array new)
		loopStart: (limits first)
		loopEnd: (limits second).
	^true! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'dgd 2/22/2003 14:24'!
insertPointAfter: ix 
	"If there is not enough roon (in x) then return false.
	Otherwise insert a point between ix and ix+1 and return true."

	| points pt |
	points := envelope points.
	(points at: ix + 1) x - (points at: ix) x < 20 ifTrue: [^false].
	pt := ((points at: ix + 1) + (points at: ix)) // 2.
	1 to: limits size
		do: 
			[:i | 
			"Increase limit indices beyond the insertion"

			(limits at: i) > ix ifTrue: [limits at: i put: (limits at: i) + 1]].
	envelope 
		setPoints: (points 
				copyReplaceFrom: ix + 1
				to: ix
				with: (Array with: pt))
		loopStart: (limits first)
		loopEnd: (limits second).
	^true! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:24'!
limitHandleMove: index event: evt from: handle
	"index is the handle index = 1, 2 or 3"
	| ix p ms x points limIx |
	ix _ limits at: index.  "index of corresponding vertex"
	p _ evt cursorPoint adhereTo: graphArea bounds.
	ms _ self msFromX: p x + (self handleOffset: handle) x.

	"Constrain move to adjacent points on ALL envelopes"
	sound envelopes do:
		[:env | limIx _ env perform:
			(#(loopStartIndex loopEndIndex decayEndIndex) at: index).
		ms _ self constrain: ms adjacentTo: limIx in: env points].

	"Update the handle, the vertex and the line being edited"
	x _ self xFromMs: ms.
	handle position: (x @ graphArea top) - (self handleOffset: handle).
	line verticesAt: ix put: x @ (line vertices at: ix) y.

	sound envelopes do:
		[:env | limIx _ env perform:
			(#(loopStartIndex loopEndIndex decayEndIndex) at: index).
		points _ env points.
		points at: limIx put: ms @ (points at: limIx) y.
		env setPoints: points loopStart: env loopStartIndex loopEnd: env loopEndIndex].! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:27'!
limitHandleMoveEvent: arg1 from: arg2 index: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self limitHandleMove: arg1 event: arg2 from: arg3! !


!EnvelopeEditorMorph methodsFor: 'geometry' stamp: 'di 9/4/1998 16:03'!
extent: newExtent
	super extent: (newExtent max: (self maxTime//10*3+50 max: 355) @ 284).
	self buildView! !


!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 1/31/98 10:41'!
editEnvelope: env
	envelope _ env.
	limits _ Array with: envelope loopStartIndex
				with: envelope loopEndIndex
				with: envelope points size.
	limitXs _ limits collect: [:i | (envelope points at: i) x].
	self buildView! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'JMV 1/9/2001 13:43'!
editSound: aSound

	| p |
	(aSound respondsTo: #envelopes)
		ifFalse: [
			PopUpMenu inform: 'You selected a ', aSound class name, '.', String cr,
				'I can''t handle these kinds of sounds.'.
			^self ].
	sound _ aSound.
	sound envelopes isEmpty ifTrue: [
		"provide a default volume envelope"
		p _ OrderedCollection new.
		p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0.
		sound addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3)].

	self editEnvelope: sound envelopes first.
	keyboard soundPrototype: sound.
! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 9/5/1998 10:40'!
initOnSound: aSound title: title
	sound _ aSound.
	soundName _ title.
	self initialize.
! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 7/14/2000 12:48'!
initialize
	super initialize.
	prevMouseDown _ false.
	showAllEnvelopes _ true.
	soundName ifNil: [soundName _ 'test'].
	self editSound: (sound ifNil: [FMSound brass1 copy]).
	sound duration: 0.25.
	denominator _ 7.
	self extent: 10@10.  "ie the minimum"
! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 11/7/2000 12:45'!
soundBeingEdited

	^ sound! !


!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:19'!
addCustomMenuItems: menu hand: aHandMorph
	super addCustomMenuItems: menu hand: aHandMorph.
	menu addLine.
	envelope updateSelector = #ratio: ifTrue:
		[menu add: 'choose denominator...' translated action: #chooseDenominator:].
	menu add: 'adjust scale...' translated action: #adjustScale:.
	SoundPlayer isReverbOn
		ifTrue: [menu add: 'turn reverb off' translated target: SoundPlayer selector: #stopReverb]
		ifFalse: [menu add: 'turn reverb on' translated target: SoundPlayer selector: #startReverb].
	menu addLine.
	menu add: 'get sound from lib' translated action: #chooseSound:.
	menu add: 'put sound in lib' translated action: #saveSound:.
	menu add: 'read sound from disk...' translated action: #readFromDisk:.
	menu add: 'save sound on disk...' translated action: #saveToDisk:.
	menu add: 'save library on disk...' translated action: #saveLibToDisk:.
! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 14:23'!
adjustScale: evt 
	| scaleString oldScale baseValue |
	oldScale := envelope scale.
	scaleString := FillInTheBlank request: 'Enter the new full-scale value...'
				initialAnswer: oldScale printString.
	scaleString isEmpty ifTrue: [^self].
	envelope scale: (Number readFrom: scaleString) asFloat.
	baseValue := envelope updateSelector = #pitch: ifTrue: [0.5] ifFalse: [0.0].
	envelope 
		setPoints: (envelope points collect: 
					[:p | 
					p x @ ((p y - baseValue) * oldScale / envelope scale + baseValue min: 1.0
								max: 0.0)])
		loopStart: (limits first)
		loopEnd: (limits second).
	self buildView! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
chooseDenominator: evt
	| menu |
	menu _ MenuMorph new.
	(Integer primesUpTo: 30) do:
		[:i |
		menu add: i printString
			target: self selector: #setDenominator:
			argument: i].
	menu addLine.
	menu add: 'none' target: self selector: #setDenominator: argument: 9999.
	menu popUpEvent: evt in: self world! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/3/98 16:50'!
chooseEnvelope: choice
	| name |
	(choice beginsWith: 'edit ') ifTrue:
		[name _ choice copyFrom: 'edit ' size+1 to: choice size.
		^ self editEnvelope: (sound envelopes detect:
				[:env | env name = name])].
	(choice beginsWith: 'add ') ifTrue:
		[name _ choice copyFrom: 'add ' size+1 to: choice size.
		^ self addEnvelopeNamed: name].
	(choice beginsWith: 'remove ') ifTrue:
		[^ self removeEnvelope  "the current one"].
! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/3/98 19:14'!
chooseFrom: chooserMorph envelopeItem: item
	| name |
	(item beginsWith: 'edit ') ifTrue:
		[name _ item copyFrom: 'edit ' size+1 to: item size.
		self editEnvelope: (sound envelopes detect:
				[:env | env name = name])].
	(item beginsWith: 'add ') ifTrue:
		[name _ item copyFrom: 'add ' size+1 to: item size.
		self addEnvelopeNamed: name].
	(item beginsWith: 'remove ') ifTrue:
		[self removeEnvelope  "the current one"].
	chooserMorph contentsClipped: envelope name! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 7/14/2000 13:03'!
chooseFrom: chooserMorph soundItem: item
	self editSoundNamed: item.
! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 7/14/2000 12:42'!
chooseSound: evt
	| menu |
	menu _ MenuMorph new.
	menu add: 'new...' target: self selector: #editNewSound.
	menu addLine.
	AbstractSound soundNames do:
		[:name |
		menu add: name
			target: self selector: #editSoundNamed:
			argument: name].
	menu popUpEvent: evt in: self world! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/30/98 22:58'!
editNewSound
	| known i |
	known _ AbstractSound soundNames.
	i _ 0.
	[soundName _ 'unnamed' , i printString.
	known includes: soundName]
		whileTrue: [i _ 1+1].
	soundName _ soundName.
	self editSound: FMSound default copy! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 7/14/2000 12:44'!
editSoundNamed: name

	name = 'new...' ifTrue: [^ self editNewSound].
	soundName _ name.
	self editSound: (AbstractSound soundNamed: soundName) copy! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/31/98 16:49'!
readFileNamed: fileName
	| snd |
	snd _ Compiler evaluate:
		(FileStream readOnlyFileNamed: fileName) contentsOfEntireFile.
	soundName _ fileName copyFrom: 1 to: fileName size-4. "---.fmp"
	self editSound: snd! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
readFromDisk: evt
	| menu |
	menu _ MenuMorph new.
	(FileDirectory default fileNamesMatching: '*.fmp') do:
		[:fileName |
		menu add: fileName
			target: self selector: #readFileNamed:
			argument: fileName].
	menu popUpEvent: evt in: self world! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/3/98 16:50'!
removeEnvelope
	(PopUpMenu confirm: 'Really remove ' , envelope name , '?')
		ifFalse: [^ self].
	sound removeEnvelope: envelope.
	self editEnvelope: sound envelopes first.! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'sw 5/23/2001 14:26'!
saveLibToDisk: evt
	"Save the library to disk"

	| newName f snd |
	newName _ FillInTheBlank request: 'Please confirm name for library...'
						initialAnswer: 'MySounds'.
	newName isEmpty ifTrue: [^ self].
	f _ FileStream newFileNamed: newName , '.fml'.
	AbstractSound soundNames do:
		[:name | snd _ AbstractSound soundNamed: name.
		"snd isStorable" true ifTrue: [f nextChunkPut: 'AbstractSound soundNamed: ' , name , ' put: ' , snd storeString; cr; cr]
			ifFalse: [self inform: name , ' is not currently storable']].
	f close! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/17/98 11:05'!
saveSound: evt
	| newName |
	newName _ FillInTheBlank request: 'Please confirm name for save...'
						initialAnswer: soundName.
	newName isEmpty ifTrue: [^ self].
	AbstractSound soundNamed: newName put: sound.
	soundName _ newName.! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/31/98 16:41'!
saveToDisk: evt
	| newName f |
	newName _ FillInTheBlank request: 'Please confirm name for save...'
						initialAnswer: soundName.
	newName isEmpty ifTrue: [^ self].
	f _ FileStream newFileNamed: newName , '.fmp'.
	sound storeOn: f.
	f close! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/31/98 01:36'!
setDenominator: denom
	denominator _ denom.
	self buildView! !


!EnvelopeEditorMorph methodsFor: 'playing' stamp: 'di 2/3/98 17:07'!
playNothing
! !


!EnvelopeEditorMorph methodsFor: 'rounding' stamp: 'di 7/14/2000 11:13'!
wantsRoundedCorners
	^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! !


!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/27/98 14:40'!
maxTime
	^ (envelope points at: limits last) x + 100! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/26/98 14:10'!
msFromX: x
	^ (x - graphArea left)//pixPerTick*10! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/31/98 01:10'!
valueFromY: y
	"The convention is that envelope values are between 0.0 and 1.0"
	| value |
	value _ (graphArea bottom - y) asFloat / (graphArea height).
	envelope updateSelector = #ratio: ifTrue:
		["Ratio gets gridded by denominator"
		^ (value * envelope scale * denominator) rounded asFloat / denominator / envelope scale].
	^ value! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/26/98 14:09'!
xFromMs: ms
	^ graphArea left + (ms//10*pixPerTick)! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/27/98 00:23'!
yFromValue: val
	"The convention is that envelope values are between 0.0 and 1.0"
	^ graphArea bottom - (val* (graphArea height))! !


!EnvelopeEditorMorph methodsFor: 'stepping and presenter' stamp: 'di 6/7/1999 15:37'!
step
	| mouseDown hand |
	hand _ self world firstHand.
	(bounds containsPoint: hand position) ifFalse: [^ self].

	mouseDown _ hand lastEvent redButtonPressed.
	mouseDown not & prevMouseDown ifTrue:
		["Mouse just went up"
		limitXs = (limits collect: [:i | (envelope points at: i) x]) ifFalse:
			["Redisplay after changing limits"
			self editEnvelope: envelope]].
	prevMouseDown _ mouseDown! !


!EnvelopeEditorMorph methodsFor: 'testing' stamp: 'di 1/30/98 13:29'!
stepTime
	^ 100! !

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

EnvelopeEditorMorph class
	instanceVariableNames: ''!

!EnvelopeEditorMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/15/1998 09:49'!
openOn: aSound title: aString
	"EnvelopeEditorMorph openOn: (AbstractSound soundNamed: 'brass1') copy title: 'brass1'"
	(self basicNew initOnSound: aSound title: aString) openInWorld! !
PolygonMorph subclass: #EnvelopeLineMorph
	instanceVariableNames: 'editor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/14/2003 20:17'!
vertices: verts borderWidth: bw borderColor: bc 
	super initialize.
	vertices _ verts.
	
	borderWidth _ bw.
	borderColor _ bc.
	closed _ false.
	arrows _ #none.
	self computeBounds! !


!EnvelopeLineMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:38'!
dragVertex: ix event: evt fromHandle: handle
	| p |
	super dragVertex: ix event: evt fromHandle: handle.
	p _ owner acceptGraphPoint: evt cursorPoint at: ix.
	self verticesAt: ix put: p.
! !

!EnvelopeLineMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:31'!
dropVertex: ix event: evt fromHandle: handle
	| oldVerts |
	oldVerts _ vertices.
	super dropVertex: ix event: evt fromHandle: handle.
	vertices = oldVerts ifFalse: [owner deletePoint: ix "deleted a vertex"]! !

!EnvelopeLineMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:39'!
newVertex: ix event: evt fromHandle: handle
	"Install a new vertex if there is room."
	(owner insertPointAfter: ix) ifFalse: [^ self "not enough room"].
	super newVertex: ix event: evt fromHandle: handle.
	self verticesAt: ix+1 put: (owner acceptGraphPoint: evt cursorPoint at: ix+1).
! !


!EnvelopeLineMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color transparent! !
PrototypeTester subclass: #EqualityTester
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!EqualityTester commentStamp: 'mjr 8/20/2003 13:04' prior: 0!
I provide a simple way to test the equality properties of any object.!


!EqualityTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'!
resultFor: runs 
	"Test that equality is the same over runs and answer the result"
	1
		to: runs
		do: [:i | self prototype = self prototype
				ifFalse: [^ false]]. 
	^ true! !
Exception subclass: #Error
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!Error commentStamp: '<historical>' prior: 0!
>From the ANSI standard:
This protocol describes the behavior of instances of class Error. These are used to represent error conditions that prevent the normal continuation of processing. Actual error exceptions used by an application may be subclasses of this class.
As Error is explicitly specified  to be subclassable, conforming implementations must implement its behavior in a non-fragile manner.

Additional notes:
Error>defaultAction uses an explicit test for the presence of the Debugger class to decide whether or not it is in development mode.  In the future, TFEI hopes to enhance the semantics of #defaultAction to improve support for pluggable default handlers.!


!Error methodsFor: 'exceptionDescription' stamp: 'ajh 9/4/2002 19:24'!
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! !


!Error methodsFor: 'private' stamp: 'ajh 2/1/2003 00:54'!
isResumable
	"Determine whether an exception is resumable."

	^ false! !
AlignmentMorphBob1 subclass: #EtoyLoginMorph
	instanceVariableNames: 'theName theNameMorph actionBlock cancelBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!

!EtoyLoginMorph methodsFor: 'actions' stamp: 'ar 9/24/2000 00:08'!
doCancel

	self delete.
	cancelBlock ifNotNil:[cancelBlock value].! !

!EtoyLoginMorph methodsFor: 'actions' stamp: 'dgd 10/8/2003 18:58'!
doOK

	| proposed |

	proposed _ theNameMorph contents string.
	proposed isEmpty ifTrue: [^self inform: 'Please enter your login name' translated].
	proposed size > 24 ifTrue: [^self inform: 'Please make the name 24 characters or less' translated].
	(Project isBadNameForStoring: proposed) ifTrue: [
		^self inform: 'Please remove any funny characters' translated
	].
	(actionBlock value: proposed) ifTrue:[self delete].! !


!EtoyLoginMorph methodsFor: 'building' stamp: 'gm 3/11/2003 21:51'!
buttonColor
	^ Color paleYellow darker!
]style[(11 4 23)f2b,f2,f1cred;! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'dgd 11/2/2004 21:26'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString font: self myFont;
		color: aColor;
		borderColor: aColor muchDarker;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	col _ (self inAColumn: {f}) hResizing: #spaceFill.
	^col! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'dgd 11/2/2004 21:24'!
cancelButton
	^ self
		buttonNamed: 'Cancel'
		action: #doCancel
		color: ColorTheme current cancelColor
		help: 'Cancel this login operation.'! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'nk 7/12/2003 08:40'!
myFont

	^ Preferences standardEToysFont! !

!EtoyLoginMorph methodsFor: 'building' stamp: 'dgd 11/2/2004 21:23'!
okButton
	^ self
		buttonNamed: 'OK'
		action: #doOK
		color:ColorTheme current okColor
		help: 'Login into Squeak'! !


!EtoyLoginMorph methodsFor: 'initialization' stamp: 'gm 3/11/2003 21:53'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color paleYellow darker!
]style[(18 2 61 27)f2b,f2,f2c141039000,f2! !

!EtoyLoginMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 8! !

!EtoyLoginMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 16:01'!
defaultColor
	"answer the default color/fill style for the receiver"
	| result |
	result _ GradientFillStyle ramp: {0.0
					-> (Color
							r: 0.5
							g: 0.5
							b: 1.0). 1.0
					-> (Color
							r: 0.8
							g: 0.8
							b: 1.0)}.
	result origin: self bounds origin.
	result direction: 0 @ self bounds height.
	^ result!
]style[(12 2 54 3 7 4 6 3 17 8 3 10 5 11 3 11 3 11 3 3 3 10 5 11 3 11 3 11 3 5 6 9 4 17 6 12 1 3 4 19 6)f2b,f2,f2c146044000,f2,f2cblue;i,f2,f2cblue;i,f2,f2cmagenta;,f2,f2c196196120,f2,f2cmagenta;,f2,f2c196196120,f2,f2c196196120,f2,f2c196196120,f2,f2c196196120,f2,f2cmagenta;,f2,f2c196196120,f2,f2c196196120,f2,f2c196196120,f2,f2cblue;i,f2,f2cmagenta;,f2,f2cblue;i,f2,f2c196196120,f2,f2cmagenta;,f2,f2cblue;i! !

!EtoyLoginMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:28'!
initialize
	"initialize the state of the receiver"
	
	super initialize.
	""
	self vResizing: #shrinkWrap;
		 hResizing: #shrinkWrap;
		 layoutInset: 4;
		 beSticky;
		 useRoundedCorners;
		 rebuild.
	! !

!EtoyLoginMorph methodsFor: 'initialization' stamp: 'ar 9/23/2000 14:13'!
openInWorld: aWorld
	super openInWorld: aWorld.
	aWorld primaryHand newKeyboardFocus: theNameMorph.! !


!EtoyLoginMorph methodsFor: 'initialize' stamp: 'ar 9/24/2000 00:09'!
name: aString actionBlock: aBlock cancelBlock: altBlock

	theName _ aString.
	actionBlock _ aBlock.
	cancelBlock _ altBlock.
	theNameMorph contentsWrapped: theName.
	theNameMorph editor selectAll.! !

!EtoyLoginMorph methodsFor: 'initialize' stamp: 'ar 9/23/2000 23:52'!
rebuild

	self removeAllMorphs.
	self addARow: { (StringMorph contents:'') lock }.
	self addARow: {
		(StringMorph contents: 'Please enter your Squeak login name' font: self myFont) lock.
	}.
	(self addARow: {
		(theNameMorph _ TextMorph new
			beAllFont: self myFont;
			crAction: (MessageSend receiver: self selector: #doOK);
			extent: 300@20;
			contentsWrapped: 'the old name';
			setBalloonText: 'Enter your name and avoid the following characters:

 : < > | / \ ? * "'

			).
	}) color: Color white; borderColor: Color black; borderWidth: 1.
	self addARow: {
		self okButton.
		self cancelButton.
	}.
	self addARow: { (StringMorph contents:'') lock }.
! !

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

EtoyLoginMorph class
	instanceVariableNames: ''!

!EtoyLoginMorph class methodsFor: 'instance creation' stamp: 'ar 8/23/2001 21:37'!
loginAndDo: aBlock ifCanceled: cancelBlock
	"EtoyLoginMorph loginAndDo:[:n| true] ifCanceled:[]"
	| me |
	(me _ self new)
		name: 'your name' actionBlock: aBlock cancelBlock: cancelBlock;
		fullBounds;
		position: Display extent - me extent // 2;
		openInWorld.
	me position: me position + (0@40).! !
UpdatingThreePhaseButtonMorph subclass: #EtoyUpdatingThreePhaseButtonMorph
	instanceVariableNames: ''
	classVariableNames: 'CheckedForm MouseDownForm UncheckedForm'
	poolDictionaries: ''
	category: 'EToys-Widgets'!
!EtoyUpdatingThreePhaseButtonMorph commentStamp: '<historical>' prior: 0!
A slight variation wherein the actionSelector and getSelector both take argument(s).!


!EtoyUpdatingThreePhaseButtonMorph methodsFor: 'stepping and presenter' stamp: 'RAA 7/11/2000 12:18'!
step
	| newBoolean |

	state == #pressed ifTrue: [^ self].
	newBoolean _ target perform: getSelector withArguments: arguments.
	newBoolean == self isOn
		ifFalse:
			[self state: (newBoolean ifTrue: [#on] ifFalse: [#off])]
! !

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

EtoyUpdatingThreePhaseButtonMorph class
	instanceVariableNames: ''!

!EtoyUpdatingThreePhaseButtonMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 13:34'!
setForms

CheckedForm _ (Form
	extent: 12@12
	depth: 32
	fromArray: #( 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 4278190081 2003331177 4278190081 4278190081 0 0 0 0 0 0 0 4278190081 2003331177 0 4278190081 4278190081 0 0 0 0 0 0 4278190081 2003331177 0 0 4278190081 4278190081 0 4278190081 0 0 0 4278190081 2003331177 0 0 0 4278190081 4278190081 0 2003331177 4278190081 0 4278190081 2003331177 0 0 0 0 4278190081 4278190081 0 0 2003331177 4278190081 2003331177 0 0 0 0 0 4278190081 4278190081 0 0 0 2003331177 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081)
	offset: 0@0).
MouseDownForm _ UncheckedForm _ (Form
	extent: 12@12
	depth: 32
	fromArray: #( 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081)
	offset: 0@0)! !


!EtoyUpdatingThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'RAA 8/8/2000 13:34'!
checkBox
	"Answer a button pre-initialized with checkbox images."

	"(Form extent: 12@12 depth: 32) morphEdit"
	CheckedForm ifNil: [
		self setForms
	].
	^self new
		onImage: CheckedForm;
		pressedImage: MouseDownForm;
		offImage: UncheckedForm;
		extent: CheckedForm extent;
		yourself
! !
Object subclass: #EventHandler
	instanceVariableNames: 'mouseDownRecipient mouseDownSelector mouseMoveRecipient mouseMoveSelector mouseStillDownRecipient mouseStillDownSelector mouseUpRecipient mouseUpSelector mouseEnterRecipient mouseEnterSelector mouseLeaveRecipient mouseLeaveSelector mouseEnterDraggingRecipient mouseEnterDraggingSelector mouseLeaveDraggingRecipient mouseLeaveDraggingSelector keyStrokeRecipient keyStrokeSelector valueParameter startDragRecipient startDragSelector doubleClickSelector doubleClickRecipient doubleClickTimeoutSelector doubleClickTimeoutRecipient clickSelector clickRecipient'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!
!EventHandler commentStamp: '<historical>' prior: 0!
Events in Morphic originate in a Hand, pass to a target morph, and are then dispatched by an EventHandler.  EventHandlers support redirection of mouse and keyboard activity by specifying and independent recipient object and message selector for each of the possible events.  In addition each eventHandler can supply an optional value parameter for distinguishing between, eg, events from a number of otherwise identical source morphs.

The basic protocol of an event handler is to receive a message of the form
	mouseDown: event in: targetMorph
and redirect this as one of
	mouseDownRecipient perform: mouseDownSelector0
	mouseDownRecipient perform: mouseDownSelector1 with: event
	mouseDownRecipient perform: mouseDownSelector2 with: event with: targetMorph
	mouseDownRecipient perform: mouseDownSelector3 with: event with: targetMorph with: valueParameter
depending on the arity of the mouseDownSelector.
!


!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:33'!
allRecipients
	"Answer a list, without duplication, of all the objects serving as recipients to any of the events I handle.  Intended for debugging/documentation use only"
	| aList |
	aList _ OrderedCollection with: mouseDownRecipient with: mouseStillDownRecipient with: mouseUpRecipient with: mouseEnterRecipient with: mouseLeaveRecipient.
	aList addAll: (OrderedCollection with:  mouseEnterDraggingRecipient with: mouseLeaveDraggingRecipient with: doubleClickRecipient with: keyStrokeRecipient).
	aList add: mouseMoveRecipient.
	^ (aList copyWithout: nil) asSet asArray! !

!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:34'!
firstMouseSelector
	"Answer the selector corresponding to the first mouse-handling selector fielded.  Created in support of providing balloon-help for halo handles, triggered by the selector handled"

	mouseDownSelector ifNotNil: [^ mouseDownSelector].
	mouseMoveSelector ifNotNil:[^mouseMoveSelector].
	mouseStillDownSelector ifNotNil: [^ mouseStillDownSelector].
	mouseUpSelector ifNotNil: [^ mouseUpSelector].
	mouseEnterSelector ifNotNil: [^ mouseEnterSelector].
	mouseLeaveSelector ifNotNil: [^ mouseLeaveSelector].
	mouseEnterDraggingSelector ifNotNil: [^ mouseEnterDraggingSelector].
	mouseLeaveDraggingSelector ifNotNil: [^ mouseLeaveDraggingSelector].
	doubleClickSelector ifNotNil: [^ doubleClickSelector].
	^ nil! !

!EventHandler methodsFor: 'access'!
messageList
	"Return a list of 'Class selector' for each message I can send. tk 
	9/13/97"
	| list |
	self flag: #mref.
	"is this still needed? I replaced the one use that I could spot with 
	#methodRefList "
	list _ SortedCollection new.
	mouseDownRecipient
		ifNotNil: [list add: (mouseDownRecipient class whichClassIncludesSelector: mouseDownSelector) name , ' ' , mouseDownSelector].
	mouseMoveRecipient
		ifNotNil: [list add: (mouseMoveRecipient class whichClassIncludesSelector: mouseMoveSelector) name , ' ' , mouseMoveSelector].
	mouseStillDownRecipient
		ifNotNil: [list add: (mouseStillDownRecipient class whichClassIncludesSelector: mouseStillDownSelector) name , ' ' , mouseStillDownSelector].
	mouseUpRecipient
		ifNotNil: [list add: (mouseUpRecipient class whichClassIncludesSelector: mouseUpSelector) name , ' ' , mouseUpSelector].
	mouseEnterRecipient
		ifNotNil: [list add: (mouseEnterRecipient class whichClassIncludesSelector: mouseEnterSelector) name , ' ' , mouseEnterSelector].
	mouseLeaveRecipient
		ifNotNil: [list add: (mouseLeaveRecipient class whichClassIncludesSelector: mouseLeaveSelector) name , ' ' , mouseLeaveSelector].
	mouseEnterDraggingRecipient
		ifNotNil: [list add: (mouseEnterDraggingRecipient class whichClassIncludesSelector: mouseEnterDraggingSelector) name , ' ' , mouseEnterDraggingSelector].
	mouseLeaveDraggingRecipient
		ifNotNil: [list add: (mouseLeaveDraggingRecipient class whichClassIncludesSelector: mouseLeaveDraggingSelector) name , ' ' , mouseLeaveDraggingSelector].
	doubleClickRecipient
		ifNotNil: [list add: (doubleClickRecipient class whichClassIncludesSelector: doubleClickSelector) name , ' ' , doubleClickSelector].
	keyStrokeRecipient
		ifNotNil: [list add: (keyStrokeRecipient class whichClassIncludesSelector: keyStrokeSelector) name , ' ' , keyStrokeSelector].
	^ list! !

!EventHandler methodsFor: 'access'!
methodRefList
	"Return a MethodReference for each message I can send. tk 9/13/97, raa 
	5/29/01 "
	| list adder |
	list _ SortedCollection new.
	adder _ [:recip :sel | recip
				ifNotNil: [list
						add: (MethodReference new
								setStandardClass: (recip class whichClassIncludesSelector: sel)
								methodSymbol: sel)]].
	adder value: mouseDownRecipient value: mouseDownSelector.
	adder value: mouseMoveRecipient value: mouseMoveSelector.
	adder value: mouseStillDownRecipient value: mouseStillDownSelector.
	adder value: mouseUpRecipient value: mouseUpSelector.
	adder value: mouseEnterRecipient value: mouseEnterSelector.
	adder value: mouseLeaveRecipient value: mouseLeaveSelector.
	adder value: mouseEnterDraggingRecipient value: mouseEnterDraggingSelector.
	adder value: mouseLeaveDraggingRecipient value: mouseLeaveDraggingSelector.
	adder value: doubleClickRecipient value: doubleClickSelector.
	adder value: keyStrokeRecipient value: keyStrokeSelector.
	^ list! !

!EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'!
mouseDownSelector
	^ mouseDownSelector! !

!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'!
mouseStillDownRecipient
	^mouseStillDownRecipient! !

!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'!
mouseStillDownSelector
	^mouseStillDownSelector! !

!EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'!
mouseUpSelector
	^ mouseUpSelector! !


!EventHandler methodsFor: 'copying' stamp: 'tk 1/22/2001 17:43'!
veryDeepFixupWith: deepCopier
	| old |
	"ALL inst vars were weakly copied.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
1 to: self class instSize do:
	[:ii | old _ self instVarAt: ii.
	self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])].

! !

!EventHandler methodsFor: 'copying' stamp: 'nk 2/14/2004 18:24'!
veryDeepInner: deepCopier
	"ALL fields are weakly copied!!  Can't duplicate an object by duplicating a button that activates it.  See DeepCopier."

	super veryDeepInner: deepCopier.
	"just keep old pointers to all fields"
!
]style[(25 108 10 78)f1b,f1,f1LDeepCopier Comment;,f1! !


!EventHandler methodsFor: 'events' stamp: 'ar 10/7/2000 22:55'!
click: event fromMorph: sourceMorph 
	"This message is sent only when double clicks are handled."
	^ self
		send: clickSelector
		to: clickRecipient
		withEvent: event
		fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'LC 2/14/2000 08:38'!
doubleClick: event fromMorph: sourceMorph 
	^ self
		send: doubleClickSelector
		to: doubleClickRecipient
		withEvent: event
		fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'jcg 9/21/2001 13:06'!
doubleClickTimeout: event fromMorph: sourceMorph 
	^ self
		send: doubleClickTimeoutSelector
		to: doubleClickTimeoutRecipient
		withEvent: event
		fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
keyStroke: event fromMorph: sourceMorph
	^ self send: keyStrokeSelector to: keyStrokeRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'ar 10/7/2000 22:54'!
mouseDown: event fromMorph: sourceMorph 
	"Take double-clicks into account."
	((self handlesClickOrDrag: event) and:[event redButtonPressed]) ifTrue:[
		event hand waitForClicksOrDrag: sourceMorph event: event.
	].
	^self
		send: mouseDownSelector
		to: mouseDownRecipient
		withEvent: event
		fromMorph: sourceMorph.
! !

!EventHandler methodsFor: 'events'!
mouseEnter: event fromMorph: sourceMorph
	^ self send: mouseEnterSelector to: mouseEnterRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'di 9/15/1998 16:35'!
mouseEnterDragging: event fromMorph: sourceMorph
	^ self send: mouseEnterDraggingSelector to: mouseEnterDraggingRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
mouseLeave: event fromMorph: sourceMorph
	^ self send: mouseLeaveSelector to: mouseLeaveRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'di 9/15/1998 16:35'!
mouseLeaveDragging: event fromMorph: sourceMorph
	^ self send: mouseLeaveDraggingSelector to: mouseLeaveDraggingRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'ar 10/25/2000 17:32'!
mouseMove: event fromMorph: sourceMorph
	^ self send: mouseMoveSelector to: mouseMoveRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
mouseStillDown: event fromMorph: sourceMorph
	^ self send: mouseStillDownSelector to: mouseStillDownRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
mouseUp: event fromMorph: sourceMorph
	^ self send: mouseUpSelector to: mouseUpRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'ar 3/17/2001 14:34'!
send: selector to: recipient withEvent: event fromMorph: sourceMorph
	| arity |
	recipient ifNil: [^ self].
	arity _ selector numArgs.
	arity = 0 ifTrue:
		[^ recipient perform: selector].
	arity = 1 ifTrue:
		[^ recipient perform: selector with: event].
	arity = 2 ifTrue:
		[^ recipient perform: selector with: event with: sourceMorph].
	arity = 3 ifTrue:
		[^ recipient perform: selector with: valueParameter with: event with: sourceMorph].
	self error: 'Event handling selectors must be Symbols and take 0-3 arguments'! !

!EventHandler methodsFor: 'events' stamp: 'mir 5/23/2000 17:43'!
startDrag: event fromMorph: sourceMorph 
	^ self
		send: startDragSelector
		to: startDragRecipient
		withEvent: event
		fromMorph: sourceMorph! !


!EventHandler methodsFor: 'fixups' stamp: 'sw 3/28/2001 14:22'!
fixReversedValueMessages
	"ar 3/18/2001: Due to the change in the ordering of the value parameter old event handlers may have messages that need to be fixed up. Do this here."

	self replaceSendsIn: #( renameCharAction:sourceMorph:requestor: makeGetter:from:forPart: makeSetter:from:forPart: newMakeGetter:from:forPart: newMakeSetter:from:forPart: clickOnLine:evt:envelope: limitHandleMoveEvent:from:index: mouseUpEvent:linkMorph:formData: mouseUpEvent:linkMorph:browserAndUrl: mouseDownEvent:noteMorph:pitch: mouseMoveEvent:noteMorph:pitch: mouseUpEvent:noteMorph:pitch: dragVertex:fromHandle:vertIndex: dropVertex:fromHandle:vertIndex: newVertex:fromHandle:afterVert: prefMenu:rcvr:pref: event:arrow:upDown:
newMakeGetter:from:forMethodInterface:)
			with: #( renameCharAction:event:sourceMorph: makeGetter:event:from: makeSetter:event:from: newMakeGetter:event:from: newMakeSetter:event:from: clickOn:evt:from: limitHandleMove:event:from: mouseUpFormData:event:linkMorph: mouseUpBrowserAndUrl:event:linkMorph: mouseDownPitch:event:noteMorph: mouseMovePitch:event:noteMorph: mouseUpPitch:event:noteMorph: dragVertex:event:fromHandle: dropVertex:event:fromHandle: newVertex:event:fromHandle: prefMenu:event:rcvr: upDown:event:arrow: makeUniversalTilesGetter:event:from:).

"sw 3/28/2001 extended Andreas's original lists by one item"! !

!EventHandler methodsFor: 'fixups' stamp: 'ar 3/18/2001 17:18'!
replaceSendsIn: array1 with: array2
	"Replace all the sends that occur in array1 with those in array2. Used for fixing old event handlers in files."
	| old index |
	1 to: self class instSize do:[:i|
		old _ self instVarAt: i.
		index _ array1 identityIndexOf: old.
		index > 0 ifTrue:[self instVarAt: i put: (array2 at: index)]].! !


!EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:16'!
on: eventName send: selector to: recipient
	eventName == #mouseDown ifTrue:
		[mouseDownRecipient _ recipient.  mouseDownSelector _ selector. ^ self].
	eventName == #mouseMove ifTrue:
		[mouseMoveRecipient _ recipient.  mouseMoveSelector _ selector. ^ self].
	eventName == #mouseStillDown ifTrue:
		[mouseStillDownRecipient _ recipient.  mouseStillDownSelector _ selector. ^ self].
	eventName == #mouseUp ifTrue:
		[mouseUpRecipient _ recipient.  mouseUpSelector _ selector. ^ self].
	eventName == #mouseEnter ifTrue:
		[mouseEnterRecipient _ recipient.  mouseEnterSelector _ selector. ^ self].
	eventName == #mouseLeave ifTrue:
		[mouseLeaveRecipient _ recipient.  mouseLeaveSelector _ selector. ^ self].
	eventName == #mouseEnterDragging ifTrue:
		[mouseEnterDraggingRecipient _ recipient.  mouseEnterDraggingSelector _ selector. ^ self].
	eventName == #mouseLeaveDragging ifTrue:
		[mouseLeaveDraggingRecipient _ recipient.  mouseLeaveDraggingSelector _ selector. ^ self].
	eventName == #click ifTrue:
		[clickRecipient _ recipient. clickSelector _ selector. ^ self].
	eventName == #doubleClick ifTrue:
		[doubleClickRecipient _ recipient. doubleClickSelector _ selector. ^ self].
	eventName == #doubleClickTimeout ifTrue:
		[doubleClickTimeoutRecipient _ recipient. doubleClickTimeoutSelector _ selector. ^ self].
	eventName == #startDrag ifTrue:
		[startDragRecipient _ recipient. startDragSelector _ selector. ^ self].
	eventName == #keyStroke ifTrue:
		[keyStrokeRecipient _ recipient.  keyStrokeSelector _ selector. ^ self].
	eventName == #gesture ifTrue:
		[ ^self onGestureSend: selector to: recipient ].
	self error: 'Event name, ' , eventName , ' is not recognizable.'
! !

!EventHandler methodsFor: 'initialization' stamp: 'wiz 8/21/2005 01:44'!
on: eventName send: selector to: recipient withValue: value
	selector numArgs = 3 ifFalse:
		[self halt: 'Warning: value parameters are passed as first of 3 arguments'].
	self on: eventName send: selector to: recipient.
	valueParameter := value
! !

!EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:59'!
onGestureSend: selector to: recipient! !


!EventHandler methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:45'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"20 dec 2000 - only a few (old) conversion exists"

	varDict at: 'mouseEnterLadenRecipient' ifPresent: [ :x | mouseEnterDraggingRecipient _ x].
	varDict at: 'mouseEnterLadenSelector' ifPresent: [ :x | mouseEnterDraggingSelector _ x].
	varDict at: 'mouseLeaveLadenRecipient' ifPresent: [ :x | mouseLeaveDraggingRecipient _ x].
	varDict at: 'mouseLeaveLadenSelector' ifPresent: [ :x | mouseLeaveDraggingSelector _ x].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!EventHandler methodsFor: 'printing' stamp: 'dgd 2/22/2003 18:40'!
printOn: aStream 
	| aVal recipients |
	super printOn: aStream.
	#('mouseDownSelector' 'mouseStillDownSelector' 'mouseUpSelector' 'mouseEnterSelector' 'mouseLeaveSelector' 'mouseEnterDraggingSelector' 'mouseLeaveDraggingSelector' 'doubleClickSelector' 'keyStrokeSelector') 
		do: 
			[:aName | 
			(aVal := self instVarNamed: aName) notNil 
				ifTrue: [aStream nextPutAll: '; ' , aName , '=' , aVal]].
	(recipients := self allRecipients) notEmpty 
		ifTrue: 
			[aStream nextPutAll: ' recipients: '.
			recipients printOn: aStream]! !


!EventHandler methodsFor: 'testing' stamp: 'ar 10/7/2000 22:56'!
handlesClickOrDrag: evt
	clickRecipient ifNotNil:[^true].
	doubleClickRecipient ifNotNil:[^true].
	startDragRecipient ifNotNil:[^true].
	^false! !

!EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:57'!
handlesGestureStart: evt
	"Does the associated morph want to handle gestures?"
	^false! !

!EventHandler methodsFor: 'testing' stamp: 'ar 10/28/2000 22:17'!
handlesKeyboard: evt
	keyStrokeRecipient ifNotNil: [^ true].
	^ false! !

!EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:13'!
handlesMouseDown: evt
	mouseDownRecipient ifNotNil: [^ true].
	mouseStillDownRecipient ifNotNil: [^ true].
	mouseUpRecipient ifNotNil: [^ true].
	(self handlesClickOrDrag: evt) ifTrue:[^true].
	^self handlesGestureStart: evt! !

!EventHandler methodsFor: 'testing' stamp: 'ar 10/25/2000 17:33'!
handlesMouseMove: evt
	^mouseMoveRecipient notNil and:[mouseMoveSelector notNil]! !

!EventHandler methodsFor: 'testing'!
handlesMouseOver: evt
	mouseEnterRecipient ifNotNil: [^ true].
	mouseLeaveRecipient ifNotNil: [^ true].
	^ false! !

!EventHandler methodsFor: 'testing' stamp: 'di 9/15/1998 16:35'!
handlesMouseOverDragging: evt
	mouseEnterDraggingRecipient ifNotNil: [^ true].
	mouseLeaveDraggingRecipient ifNotNil: [^ true].
	^ false! !

!EventHandler methodsFor: 'testing' stamp: 'ar 10/22/2000 17:05'!
handlesMouseStillDown: evt
	^mouseStillDownRecipient notNil and:[mouseStillDownSelector notNil]! !


!EventHandler methodsFor: '*eToys-initialization' stamp: 'jcg 9/21/2001 12:57'!
forgetDispatchesTo: aSelector
	"aSelector is no longer implemented by my corresponding Player, so don't call it any more"
	mouseDownSelector == aSelector
		ifTrue: [mouseDownRecipient _ mouseDownSelector _ nil].
	mouseMoveSelector == aSelector
		ifTrue: [mouseMoveRecipient _ mouseMoveSelector _ nil].
	mouseStillDownSelector == aSelector
		ifTrue: [mouseStillDownRecipient _ mouseStillDownSelector _ nil].
	mouseUpSelector == aSelector
		ifTrue: [mouseUpRecipient _ mouseUpSelector _ nil].
	mouseEnterSelector == aSelector
		ifTrue: [mouseEnterRecipient _ mouseEnterSelector _ nil].
	mouseLeaveSelector == aSelector
		ifTrue: [mouseLeaveRecipient _ mouseLeaveSelector _ nil].
	mouseEnterDraggingSelector == aSelector
		ifTrue: [mouseEnterDraggingRecipient _ mouseEnterDraggingSelector _ nil].
	mouseLeaveDraggingSelector == aSelector
		ifTrue: [mouseLeaveDraggingRecipient _ mouseLeaveDraggingSelector _ nil].
	clickSelector == aSelector
		ifTrue: [clickRecipient _ clickSelector _ nil].
	doubleClickSelector == aSelector
		ifTrue: [doubleClickRecipient _ doubleClickSelector _ nil].
	doubleClickTimeoutSelector == aSelector
		ifTrue: [doubleClickTimeoutRecipient _ doubleClickTimeoutSelector _ nil].
	keyStrokeSelector == aSelector
		ifTrue: [keyStrokeRecipient _ keyStrokeSelector _ nil].! !



!EventHandler methodsFor: '*MorphicExtras-initialization' stamp: 'ar 3/17/2001 20:12'!
adaptToWorld: aWorld
	"If any of my recipients refer to a world or a hand, make them now refer
	to the corresponding items in the new world.  (instVarNamed: is slow, later
	use perform of two selectors.)"

	| value newValue |
	#(mouseDownRecipient mouseStillDownRecipient mouseUpRecipient
	mouseEnterRecipient mouseLeaveRecipient mouseEnterDraggingRecipient
	mouseLeaveDraggingRecipient clickRecipient doubleClickRecipient startDragRecipient keyStrokeRecipient valueParameter) do:
		[:aName |
		(value _ self instVarNamed: aName asString) ifNotNil:[
			newValue _ value adaptedToWorld: aWorld.
			(newValue notNil and: [newValue ~~ value])
				ifTrue:
					[self instVarNamed: aName asString put: newValue]]]! !
Object subclass: #EventManager
	instanceVariableNames: 'actionMap'
	classVariableNames: 'ActionMaps'
	poolDictionaries: ''
	category: 'System-Object Events'!
!EventManager commentStamp: 'tlk 5/7/2006 20:01' prior: 0!
An EventManager is used to registers a 'observer' object's interest in in changes to an 'observed' object.  Then when the observered object is changed,  EventManager broadcasts the an update message to all objects with a registered interest.  Finally, the Event manager can be used to remove an object from the list of observer object.

An interested object is said to be a dependant on the target object.  Registering an interest in an event is called adding a dependant. Deregistering is called removing  a dependant.  The EventManager's action map is a WeakIdentityDictionary that maps events (selectors) to dependants (objects & selectors) in a way that ensures the mapping is to specific objects (hence identity) and in a way that allows the object to be garbage collected if not other used (hence weak.)  EventManager class has ActionMaps which has one actionMap for each object.

Classic uses of an EventManager are to implement the Observer Pattern, see ChangeNotification or the MorphicModle as examples.!


!EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:37'!
actionMap

    ^actionMap == nil
        ifTrue: [self createActionMap]
        ifFalse: [actionMap]! !

!EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'!
changedEventSelector

	^#changed:! !

!EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:39'!
releaseActionMap

    actionMap := nil! !

!EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'!
updateEventSelector

	^#update:! !

!EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:38'!
updateableActionMap

    actionMap == nil
        ifTrue: [actionMap := self createActionMap].
    ^actionMap! !


!EventManager methodsFor: 'copying' stamp: 'reThink 3/3/2001 10:22'!
copy

	| answer |
	answer := super copy.
	answer release.
	^answer! !


!EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'!
addDependent: anObject
	"Make the given object one of the receiver's dependents."

	self
		when: self changedEventSelector
		send: self updateEventSelector
		to: anObject.
	^anObject! !

!EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'!
breakDependents
	"Remove all of the receiver's dependents."

	self removeActionsForEvent: self changedEventSelector! !

!EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:18'!
dependents

	^(self actionSequenceForEvent: self changedEventSelector) asSet
		collect:
			[:each | each receiver]! !

!EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'!
removeDependent: anObject
	"Remove the given object as one of the receiver's dependents."

	self 
		removeActionsWithReceiver: anObject
		forEvent: self changedEventSelector.
	^ anObject! !


!EventManager methodsFor: 'updating' stamp: 'reThink 3/3/2001 10:20'!
changed: aParameter 
	"Receiver changed. The change is denoted by the argument aParameter. 
	Usually the argument is a Symbol that is part of the dependent's change 
	protocol. Inform all of the dependents."

	self 
		triggerEvent: self changedEventSelector
		with: aParameter! !

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

EventManager class
	instanceVariableNames: ''!

!EventManager class methodsFor: 'accessing' stamp: 'reThink 2/18/2001 14:42'!
actionMapFor: anObject

    ^self actionMaps
        at: anObject
        ifAbsent: [self createActionMap]! !

!EventManager class methodsFor: 'accessing' stamp: 'rww 10/2/2001 07:20'!
actionMaps

	ActionMaps == nil
		ifTrue: [ActionMaps := WeakIdentityKeyDictionary new].
	^ActionMaps! !

!EventManager class methodsFor: 'accessing' stamp: 'reThink 2/25/2001 08:52'!
updateableActionMapFor: anObject

    ^self actionMaps
        at: anObject
        ifAbsentPut: [self createActionMap]! !


!EventManager class methodsFor: 'initialize-release' stamp: 'rw 2/10/2002 13:09'!
flushEvents
	"Object flushEvents"
	| msgSet |
	self actionMaps keysAndValuesDo:[:rcvr :evtDict| rcvr ifNotNil:[
		"make sure we don't modify evtDict while enumerating"
		evtDict keys do:[:evtName|
			msgSet _ evtDict at: evtName ifAbsent:[nil].
			(msgSet == nil) ifTrue:[rcvr removeActionsForEvent: evtName]]]].
	EventManager actionMaps finalizeValues. ! !


!EventManager class methodsFor: 'releasing' stamp: 'reThink 2/18/2001 15:34'!
releaseActionMapFor: anObject

	self actionMaps
		removeKey: anObject
		ifAbsent: []! !
ClassTestCase subclass: #EventManagerTest
	instanceVariableNames: 'eventSource eventListener succeeded'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Events-Tests'!

!EventManagerTest methodsFor: 'running' stamp: 'JWS 9/7/2000 17:19'!
setUp

	super setUp.
	eventSource := EventManager new.
	eventListener := Bag new.
	succeeded := false! !

!EventManagerTest methodsFor: 'running' stamp: 'jws 11/28/2000 16:25'!
tearDown

	eventSource releaseActionMap.
	eventSource := nil.
	eventListener := nil.
	super tearDown.
! !


!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:21'!
testMultipleValueSuppliers

	eventSource
		when: #needsValue
		send: #getFalse
		to: self.
	eventSource
		when: #needsValue
		send: #getTrue
		to: self.
	succeeded := eventSource triggerEvent: #needsValue.
	self should: [succeeded]! !

!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:21'!
testMultipleValueSuppliersEventHasArguments

	eventSource
		when: #needsValue:
		send: #getFalse:
		to: self.
	eventSource
		when: #needsValue:
		send: #getTrue:
		to: self.
	succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'.
	self should: [succeeded]! !

!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:22'!
testNoValueSupplier

	succeeded := eventSource 
		triggerEvent: #needsValue
		ifNotHandled: [true].
	self should: [succeeded]! !

!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:22'!
testNoValueSupplierHasArguments

	succeeded := eventSource 
		triggerEvent: #needsValue:
		with: 'nelja'
		ifNotHandled: [true].
	self should: [succeeded]! !

!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'jws 11/28/2000 15:52'!
testSingleValueSupplier

	eventSource
		when: #needsValue
		send: #getTrue
		to: self.
	succeeded := eventSource triggerEvent: #needsValue.
	self should: [succeeded]! !


!EventManagerTest methodsFor: 'running-copying' stamp: 'SqR 11/12/2000 19:38'!
testCopy
	"Ensure that the actionMap is zapped when
	you make a copy of anEventManager"

	eventSource when: #blah send: #yourself to: eventListener.
	self assert: eventSource actionMap keys isEmpty not.
	self assert: eventSource copy actionMap keys isEmpty! !


!EventManagerTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'!
testNoArgumentEvent

	eventSource when: #anEvent send: #heardEvent to: self.
	eventSource triggerEvent: #anEvent.
	self should: [succeeded]! !

!EventManagerTest methodsFor: 'running-dependent action' stamp: 'JWS 9/7/2000 17:20'!
testOneArgumentEvent

	eventSource when: #anEvent: send: #add: to: eventListener.
	eventSource triggerEvent: #anEvent: with: 9.
	self should: [eventListener includes: 9]! !

!EventManagerTest methodsFor: 'running-dependent action' stamp: 'JWS 9/7/2000 17:20'!
testTwoArgumentEvent

	eventSource when: #anEvent:info: send: #addArg1:addArg2: to: self.
	eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ).
	self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! !


!EventManagerTest methodsFor: 'running-dependent action supplied arguments' stamp: 'JWS 9/7/2000 17:20'!
testNoArgumentEventDependentSuppliedArgument

	eventSource when: #anEvent send: #add: to: eventListener with: 'boundValue'.
	eventSource triggerEvent: #anEvent.
	self should: [eventListener includes: 'boundValue']! !

!EventManagerTest methodsFor: 'running-dependent action supplied arguments' stamp: 'JWS 9/7/2000 17:21'!
testNoArgumentEventDependentSuppliedArguments

	eventSource 
		when: #anEvent 
		send: #addArg1:addArg2: 
		to: self 
		withArguments: #('hello' 'world').
	eventSource triggerEvent: #anEvent.
	self should: [(eventListener includes: 'hello') and: [eventListener includes: 'world']]! !


!EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'!
testReturnValueWithManyListeners

	| value newListener |
	newListener := 'busybody'.
	eventSource
		when: #needsValue
		send: #yourself
		to: eventListener.
	eventSource
		when: #needsValue
		send: #yourself
		to: newListener.
	value := eventSource triggerEvent: #needsValue.
	self should: [value == newListener]! !

!EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'!
testReturnValueWithNoListeners

	| value |
	value := eventSource triggerEvent: #needsValue.
	self should: [value == nil]! !

!EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'!
testReturnValueWithOneListener

	| value |
	eventSource
		when: #needsValue
		send: #yourself
		to: eventListener.
	value := eventSource triggerEvent: #needsValue.
	self should: [value == eventListener]! !


!EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:01'!
testRemoveActionsForEvent

	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	eventSource removeActionsForEvent: #anEvent.
	self shouldnt: [eventSource hasActionForEvent: #anEvent]! !

!EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:01'!
testRemoveActionsTwiceForEvent

	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	eventSource removeActionsForEvent: #anEvent.
	self assert: (eventSource hasActionForEvent: #anEvent) not.
	eventSource removeActionsForEvent: #anEvent.
	self assert: (eventSource hasActionForEvent: #anEvent) not.! !

!EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:10'!
testRemoveActionsWithReceiver

	| action |
	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	eventSource removeActionsWithReceiver: self.
	action := eventSource actionForEvent: #anEvent.
	self assert: (action respondsTo: #receiver).
	self assert: ((action receiver == self) not)! !


!EventManagerTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'!
addArg1: arg1
addArg2: arg2

	eventListener
		add: arg1;
		add: arg2! !

!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'!
getFalse

	^false! !

!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'!
getFalse: anArg

	^false! !

!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'!
getTrue

	^true! !

!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'!
getTrue: anArg

	^true! !

!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:20'!
heardEvent

	succeeded := true! !
AlignmentMorph subclass: #EventRecorderMorph
	instanceVariableNames: 'tape state time deltaTime recHand playHand lastEvent lastDelta tapeStream saved statusLight voiceRecorder startSoundEvent recordMeter caption journalFile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalSupport'!
!EventRecorderMorph commentStamp: '<historical>' prior: 0!
During recording, the EventRecorder subscribes to all events of the normal morphic hand, and saves them as they occur.

For replay, a second playback hand is created that reads events from the recorder and plays them back in the world.

The EventRecorder began with the work of Ted Kaehler and John Malone.  This was then signifcantly expanded by Leandro Caniglia and Valeria Murgia as a tutorial aid for the Morphic Wrapper project.

Since that time, I have...
Changed to a simple inboard array for the tape (event storage).
Provided the ability to condense linear mouse movement with interpolation at replay.
Made simple provisions for wrap-around of the millisecond clock.
Eliminated step methods in favor of using the processEvents cycle in the playback hand.
Provided a pause/resume mechanism that is capable of surviving project changes.
Added the ability to spawn a simple 'play me' button that can be saved as a morph.
Caused the playback hand to display its cursor double size for visibility.
Integrated a voice recorder with on-the-fly compression.
	This currently does NOT survive project changes, not is its data stored on the tape.
	Right now it can only be saved by saving the entire recorder as a morph.
	This will be fixed by adding a startSound event at each project change.
	We will also convert read/write file to use saveOnFile.
Added a journal file facility for recording sequences that end in a crash.
The above two features can be engaged via the ER's morph menu.
	- Dan Ingalls 3/6/99!


!EventRecorderMorph methodsFor: 'accessing' stamp: 'LC 12/23/1998 12:48'!
button: label 
	^ self allMorphs
		detect: [:one | (one isKindOf: SimpleButtonMorph)
				and: [one label = label]]
		ifNone: []! !


!EventRecorderMorph methodsFor: 'commands' stamp: 'yo 2/11/2005 09:59'!
button
	"Make a simple button interface for replay only"
	| butnCaption erm |
	butnCaption _ FillInTheBlank request: 'Caption for this butn?' translated initialAnswer: 'play' translated.
	butnCaption isEmpty ifTrue: [^ self].
	erm _ (EventRecorderMorph basicNew
				caption: butnCaption
				voiceRecorder: voiceRecorder copy
				tape: tape) initialize.
	self world primaryHand attachMorph: erm! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'dgd 2/22/2003 19:01'!
condense
	"Shorten the tape by deleting mouseMove events that can just as well be
	interpolated later at playback time."

	"e1, e2, and e3 are three consecutive events on the tape.
	t1, t2, and t3 are the associated time steps for each of them."

	| e1 e2 t1 t2 e3 t3 |
	tape := Array streamContents: 
					[:tStream | 
					e1 := e2 := e3 := nil.
					t1 := t2 := t3 := nil.
					1 to: tape size
						do: 
							[:i | 
							e1 := e2.
							t1 := t2.
							e2 := e3.
							t2 := t3.
							e3 := tape at: i.
							t3 := e3 timeStamp.
							((e1 notNil and: 
									[e2 type == #mouseMove 
										& (e1 type == #mouseMove or: [e3 type == #mouseMove])]) 
								and: 
									["Middle point within 3 pixels of mean of outer two"

									e2 position 
										onLineFrom: e1 position
										to: e3 position
										within: 2.5]) 
									ifTrue: 
										["Delete middle mouse move event.  Absorb its time into e3"

										e2 := e1.
										t2 := t1]
									ifFalse: [e1 ifNotNil: [tStream nextPut: (e1 copy setTimeStamp: t1)]]].
					e2 ifNotNil: [tStream nextPut: (e2 copy setTimeStamp: t2)].
					e3 ifNotNil: [tStream nextPut: (e3 copy setTimeStamp: t3)]]! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 6/14/2001 16:42'!
play

	self isInWorld ifFalse: [^ self].
	self stop.
	tape ifNil: [^ self].
	tapeStream _ ReadStream on: tape.
	self resumePlayIn: self world.
	self setStatusLight: #nowPlaying.

! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 6/14/2001 16:42'!
record

	self isInWorld ifFalse: [^ self].
	self stop.
	self writeCheck.
	self addJournalFile.
	tapeStream _ WriteStream on: (Array new: 10000).
	self resumeRecordIn: self world.
	self setStatusLight: #nowRecording.
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 6/14/2001 16:43'!
setStatusLight: aSymbol

	aSymbol == #ready ifTrue: [
		statusLight color: Color green.
		tape ifNil: [
			statusLight setBalloonText: 'Ready to record'.
		] ifNotNil: [
			statusLight setBalloonText: 'Ready to record or play'.
		].
		^self
	].
	aSymbol == #nowRecording ifTrue: [
		statusLight 
			color: Color red;
			setBalloonText: 'Recording is active'.
		^self
	].
	aSymbol == #nowPlaying ifTrue: [
		statusLight 
			color: Color yellow;
			setBalloonText: 'Now playing'.
		^self
	].
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'dgd 9/21/2003 17:54'!
shrink
	"Shorten the tape by deleting mouseMove events that can just as well be
	interpolated later at playback time."

	| oldSize priorSize |
	self writeCheck.
	oldSize _ priorSize _ tape size.
	[self condense.  tape size < priorSize] whileTrue: [priorSize _ tape size].
	self inform: ('{1} events reduced to {2}' translated format:{oldSize. tape size}).
	voiceRecorder ifNotNil: [voiceRecorder suppressSilence].
	saved _ false.
! !


!EventRecorderMorph methodsFor: 'event handling' stamp: 'wiz 7/24/2005 21:41'!
nextEventToPlay
	"Return the next event when it is time to be replayed.
	If it is not yet time, then return an interpolated mouseMove.
	Return nil if nothing has happened.
	Return an EOF event if there are no more events to be played."
	| nextEvent now nextTime lastP delta |
	(tapeStream isNil or:[tapeStream atEnd]) 
		ifTrue:[^MorphicUnknownEvent new setType: #EOF argument: nil].
	now := Time millisecondClockValue.
	nextEvent := tapeStream next.
	"nextEvent isKeyboard ifTrue: [ nextEvent setPosition: self position ]."
	deltaTime ifNil:[deltaTime := now - nextEvent timeStamp].
	nextTime := nextEvent timeStamp + deltaTime.
	now < time ifTrue:["clock rollover"
		time := now.
		deltaTime := nil.
		^nil "continue it on next cycle"].
	time := now.
	(now >= nextTime) ifTrue:[
		nextEvent := nextEvent copy setTimeStamp: nextTime.
		nextEvent isMouse ifTrue:[lastEvent := nextEvent] ifFalse:[lastEvent := nil].
		^nextEvent].
	tapeStream skip: -1.
	"Not time for the next event yet, but interpolate the mouse.
	This allows tapes to be compressed when velocity is fairly constant."
	lastEvent ifNil: [^ nil].
	lastP := lastEvent position.
	delta := (nextEvent position - lastP) * (now - lastEvent timeStamp) // (nextTime - lastEvent timeStamp).
	delta = lastDelta ifTrue: [^ nil]. "No movement"
	lastDelta := delta.
	^MouseMoveEvent new
		setType: #mouseMove 
		startPoint: lastEvent position endPoint: lastP + delta
		trail: #() buttons: lastEvent buttons hand: nil stamp: now.! !

!EventRecorderMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 20:44'!
synchronize

	time _ Time millisecondClockValue.
	deltaTime _ nil.! !


!EventRecorderMorph methodsFor: 'events-processing' stamp: 'ar 10/25/2000 21:26'!
handleListenEvent: anEvent
	"Record the given event"
	(state == #record and:[anEvent hand == recHand]) 
		ifFalse:[^self].
	anEvent = lastEvent ifTrue: [^ self].
	(anEvent isKeyboard and:[anEvent keyValue = 27 "esc"])
		ifTrue: [^ self stop].
	time _ anEvent timeStamp.
	tapeStream nextPut: (anEvent copy setHand: nil).
	journalFile ifNotNil:
		[journalFile store: anEvent; cr; flush].
	lastEvent _ anEvent.! !


!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'dgd 2/21/2003 23:15'!
checkTape
	"See if this tape was already converted to the new format"

	tape ifNil: [^self].
	tape isEmpty ifTrue: [^self].
	(tape first isKindOf: Association) 
		ifTrue: [tape := self convertV0Tape: tape]! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/26/2000 01:04'!
convertV0Tape: anArray
	"Convert the tape into the new format"
	| lastKey evt |
	lastKey _ 0.
	^anArray collect:[:assn| 
		evt _ assn value.
		evt setTimeStamp: (lastKey _ lastKey + assn key).
		evt]! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 22:00'!
readFrom: aStream
	"Private"
	| cr header |
	cr _ Character cr.
	header _ aStream upTo: cr.
	(header = 'Event Tape v1 BINARY') ifTrue:[^aStream fileInObjectAndCode].
	(header = 'Event Tape v1 ASCII') ifTrue:[^self readFromV1: aStream].
	"V0 had no header so guess"
	aStream reset.
	header first isDigit ifFalse:[^self convertV0Tape: (aStream fileInObjectAndCode)].
	^self convertV0Tape: (self readFromV0: aStream).
! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/26/2000 01:55'!
readFromV0: aStream
	| cr line lineStream t evt |
	cr _ Character cr.
	^Array streamContents:[:tStream |
		[aStream atEnd] whileFalse:
			[line _ aStream upTo: cr.
			line isEmpty "Some MW tapes have an empty record at the end"
				ifFalse: [lineStream _ ReadStream on: line.
						t _ Integer readFrom: lineStream.
						[lineStream peek isLetter] whileFalse: [lineStream next].
						evt _ MorphicEvent readFromObsolete: lineStream.
						tStream nextPut: t -> evt]]].! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/26/2000 01:55'!
readFromV1: aStream
	| cr |
	cr _ Character cr.
	^Array streamContents:[:tStream |
		[aStream atEnd] whileFalse:[
			tStream nextPut: (MorphicEvent readFromString: (aStream upTo: cr))]]! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'md 7/15/2004 17:22'!
readTape
	^ self readTape: (FillInTheBlank
							request: 'Tape to read'
							initialAnswer: 'tapeName.tape').! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 22:00'!
readTape: fileName 
	| file |
	self writeCheck.
	(FileStream isAFileNamed: fileName) ifFalse: [^ nil].
	file _ FileStream oldFileNamed: fileName.
	tape _ self readFrom: file.
	file close.
	saved _ true  "Still exists on file"! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'di 2/15/1999 16:05'!
writeCheck
	(saved not and: [self confirm: 'The current tape has not been saved.
Would you like to do so now?']) ifTrue:
		[self writeTape].
! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 22:11'!
writeFileNamed: fileName
	| file noVoice delta |
	file _ FileStream newFileNamed: fileName.
	noVoice _ true.
	tape do:[:evt | evt type = #startSound ifTrue: [noVoice _ false]].
	noVoice
		ifTrue: ["Simple format (reads fast) for no voice"
				file nextPutAll:'Event Tape v1 ASCII'; cr.
				delta _ tape first timeStamp.
				tape do: [:evt | file store: (evt copy setTimeStamp: evt timeStamp-delta); cr].
				file close]
		ifFalse: ["Inclusion of voice events requires general object storage"
				file nextPutAll:'Event Tape v1 BINARY'; cr.
				file fileOutClass: nil andObject: tape].
	saved _ true.
	^ file name! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'md 7/15/2004 17:23'!
writeTape
	| args b |
	args := (b := self button: 'writeTape') isNil 
				ifTrue: [#()]
				ifFalse: [b arguments].
	(args notEmpty and: [args first notEmpty]) 
		ifTrue: 
			[args first.
			self writeTape: args first]
		ifFalse: 
			[^self writeTape: (FillInTheBlank request: 'Tape to write'
								initialAnswer: 'tapeName.tape')].! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 22:11'!
writeTape: fileName 
	| b name |
	name _ self writeFileNamed: fileName.
	(b _ self button: 'writeTape') ifNotNil: [
		b actionSelector: #writeTape:.
		b arguments: (Array with: name)].
! !


!EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 6/14/2001 16:52'!
addButtons
	| r b |

	caption ifNotNil: ["Special setup for play-only interface"
		(r _ self makeARowForButtons)
			addMorphBack: (SimpleButtonMorph new target: self;
	 							label: caption; actionSelector: #play);
			addMorphBack: self makeASpacer;
			addMorphBack: self makeStatusLight;
			addMorphBack: self makeASpacer.
		^ self addMorphBack: r
	].

	(r _ self makeARowForButtons)
		addMorphBack: (b _ self buttonFor: {#record. nil. 'Begin recording'});
		addMorphBack: self makeASpacer;
		addMorphBack: (self buttonFor: {#stop. b width. 'Stop recording - you can also use the ESC key to stop it'});
		addMorphBack: self makeASpacer;
		addMorphBack: (self buttonFor: {#play. b width. 'Play current recording'}).
	self addMorphBack: r.

	(r _ self makeARowForButtons)
		addMorphBack: (b _ self buttonFor: {#writeTape. nil. 'Save current recording on disk'});
		addMorphBack: self makeASpacer;
		addMorphBack: (self buttonFor: {#readTape. b width. 'Get a new recording from disk'}).
	self addMorphBack: r.

	(r _ self makeARowForButtons)
		addMorphBack: (b _ self buttonFor: {#shrink. nil. 'Make recording shorter by removing unneeded events'});
		addMorphBack: self makeASpacer;
		addMorphBack: self makeStatusLight;
		addMorphBack: self makeASpacer;
		addMorphBack: (self buttonFor: {#button. b width. 'Make a simple button to play this recording'}).
	self addMorph: r.
	self setStatusLight: #ready.! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'dgd 8/30/2003 21:19'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'add voice controls' translated action: #addVoiceControls.
	aCustomMenu add: 'add journal file' translated action: #addJournalFile.
! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'ar 10/25/2000 21:42'!
addJournalFile
	"In case there is a chance of not regaining control to stop recording and save a file, the EventRecorder can write directly to file as it is recording.  This is useful for capturing a sequence that results in a nasty crash."

	journalFile ifNotNil: [journalFile close].
	journalFile _ FileStream newFileNamed: 'EventRecorder.tape'.
	journalFile nextPutAll:'Event Tape v1 ASCII'; cr.! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'yo 2/11/2005 09:56'!
buttonFor: data 

	| b |
	b _ SimpleButtonMorph new 
		target: self;
		label: data first asString translated;
		actionSelector: data first.
	data second ifNotNil: [b width < data second ifTrue: [b width: data second]].
	data third ifNotNil: [b setBalloonText: data third translated].
	^b! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'di 2/17/1999 17:44'!
caption: butnCaption voiceRecorder: butnRecorder tape: butnTape
	caption _ butnCaption.
	voiceRecorder _ butnRecorder.
	tape _ butnTape! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #raised! !

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

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

!EventRecorderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:21'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	saved _ true.
	self listDirection: #topToBottom;
		 wrapCentering: #center;
		 cellPositioning: #topCenter;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 layoutInset: 2;
		 minCellSize: 4;
		 addButtons! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 6/14/2001 16:19'!
makeARowForButtons

	^AlignmentMorph newRow
		vResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #leftCenter;
		minCellSize: 4;
		color: Color blue! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 6/14/2001 16:14'!
makeASpacer

	^AlignmentMorph newSpacer: Color transparent! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 6/14/2001 16:13'!
makeStatusLight

	^statusLight _ EllipseMorph new 
		extent: 11 @ 11;
		color: Color green;
		borderWidth: 0! !


!EventRecorderMorph methodsFor: 'pause/resume' stamp: 'RAA 6/14/2001 16:50'!
pauseIn: aWorld
	"Suspend playing or recording, either as part of a stop command,
	or as part of a project switch, after which it will be resumed."

	self setStatusLight: #ready.
	state = #play ifTrue:
		[state _ #suspendedPlay.
		playHand delete.
		aWorld removeHand: playHand.
		playHand _ nil].
	state = #record ifTrue:
		[state _ #suspendedRecord.
		recHand removeEventListener: self.
		recHand _ nil].

	voiceRecorder ifNotNil:
		[voiceRecorder pause.
		startSoundEvent ifNotNil:
			[startSoundEvent argument: voiceRecorder recordedSound.
			voiceRecorder clearRecordedSound.
			startSoundEvent _ nil]].
! !

!EventRecorderMorph methodsFor: 'pause/resume' stamp: 'di 4/20/1999 16:29'!
resumeIn: aWorld
	"Resume playing or recording after a project switch."

	state = #suspendedPlay ifTrue:
		[self resumePlayIn: aWorld].
	state = #suspendedRecord ifTrue:
		[self resumeRecordIn: aWorld].
! !

!EventRecorderMorph methodsFor: 'pause/resume' stamp: 'ar 10/25/2000 20:58'!
resumePlayIn: aWorld

	playHand _ HandMorphForReplay new recorder: self.
	playHand position: tapeStream peek position.
	aWorld addHand: playHand.
	playHand newKeyboardFocus: aWorld.
	playHand userInitials: 'play' andPicture: nil.

	lastEvent _ nil.
	lastDelta _ 0@0.
	state _ #play.

	self synchronize.
! !

!EventRecorderMorph methodsFor: 'pause/resume' stamp: 'ar 10/26/2000 00:50'!
resumeRecordIn: aWorld

	recHand _ aWorld activeHand ifNil: [aWorld primaryHand].
	recHand newKeyboardFocus: aWorld.
	recHand addEventListener: self.

	lastEvent _ nil.
	state _ #record.

	voiceRecorder ifNotNil:
		[voiceRecorder clearRecordedSound.
		voiceRecorder resumeRecording.
		startSoundEvent _ MorphicUnknownEvent new setType: #startSound argument: nil hand: nil stamp: Time millisecondClockValue.
		tapeStream nextPut: startSoundEvent].

	self synchronize.
! !


!EventRecorderMorph methodsFor: 'stepping and presenter' stamp: 'RAA 1/2/2001 15:45'!
step

	(state == #record and: [voiceRecorder notNil]) ifTrue: [
		recordMeter width: (voiceRecorder meterLevel + 1).
	].
! !

!EventRecorderMorph methodsFor: 'stepping and presenter' stamp: 'RAA 6/14/2001 16:43'!
stop

	state = #record ifTrue:
		[tape _ tapeStream contents.
		saved _ false].
	journalFile ifNotNil:
		[journalFile close].
	self pauseIn: self world.
	tapeStream _ nil.
	state _ nil.
	self setStatusLight: #ready.
	recordMeter ifNotNil: [recordMeter width: 1].

	self checkTape.! !


!EventRecorderMorph methodsFor: 'testing' stamp: 'RAA 1/2/2001 10:28'!
stepTime

	^500
! !

!EventRecorderMorph methodsFor: 'testing' stamp: 'RAA 1/2/2001 10:25'!
wantsSteps

	^true
! !


!EventRecorderMorph methodsFor: '*sound' stamp: 'stephaneducasse 2/4/2006 20:40'!
addVoiceControls 

	| levelSlider r meterBox |
	voiceRecorder := SoundRecorder new
		desiredSampleRate: 11025.0;		"<==try real hard to get the low rate"
		codec: (GSMCodec new).		"<--this should compress better than ADPCM.. is it too slow?"
		"codec: (ADPCMCodec new initializeForBitsPerSample: 4 samplesPerFrame: 0)."

	levelSlider := SimpleSliderMorph new
		color: color;
		extent: 100@2;
		target: voiceRecorder;
		actionSelector: #recordLevel:;
		adjustToValue: voiceRecorder recordLevel.
	r := AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '0 ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' 10').
	self addMorphBack: r.

	meterBox := Morph new extent: 102@18; color: Color gray.
	recordMeter := Morph new extent: 1@16; color: Color yellow.
	recordMeter position: meterBox topLeft + (1@1).
	meterBox addMorph: recordMeter.

	r := AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: meterBox.
	self addMorphBack: r.
! !


!EventRecorderMorph methodsFor: '*sound-piano rolls' stamp: 'stephaneducasse 2/4/2006 20:40'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	| startX myDurationInTicks endX |

	startX := pianoRoll xForTime: t.
	myDurationInTicks := pianoRoll scorePlayer ticksForMSecs: self myDurationInMS.
	t > rightTime ifTrue: [^ self].  
	(t + myDurationInTicks) < leftTime ifTrue: [^ self].
	endX := pianoRoll xForTime: t + myDurationInTicks.

	morphList add: 
		(self hResizing: #spaceFill; left: startX; width: endX - startX).

! !

!EventRecorderMorph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/13/2000 12:40'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	self play.! !

!EventRecorderMorph methodsFor: '*sound-piano rolls' stamp: 'stephaneducasse 2/4/2006 20:40'!
justDroppedIntoPianoRoll: newOwner event: evt
	
	| startX lengthInTicks endX startTimeInScore endTimeInScore |

	super justDroppedIntoPianoRoll: newOwner event: evt.

	startTimeInScore := newOwner timeForX: self left.
	lengthInTicks := newOwner scorePlayer ticksForMSecs: self myDurationInMS.
	endTimeInScore := startTimeInScore + lengthInTicks.

	endTimeInScore > newOwner scorePlayer durationInTicks ifTrue:
		[newOwner scorePlayer updateDuration].

	startX := newOwner xForTime: startTimeInScore.
	endX := newOwner xForTime: endTimeInScore.
	self width: endX - startX.
! !

!EventRecorderMorph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/13/2000 13:07'!
myDurationInMS

	^tape isEmptyOrNil ifTrue: [
		10
	] ifFalse: [
		tape last timeStamp - tape first timeStamp
	]
! !

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

EventRecorderMorph class
	instanceVariableNames: ''!

!EventRecorderMorph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 17:25'!
initialize

	FileList registerFileReader: self! !


!EventRecorderMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:31'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'tape') | (suffix = '*') 
		ifTrue: [ self services]
		ifFalse: [#()]

! !

!EventRecorderMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:31'!
services

	^{SimpleServiceEntry 
			provider: self 
			label: 'open for playback'
			selector: #openTapeFromFile:.}
! !


!EventRecorderMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !


!EventRecorderMorph class methodsFor: 'instance creation' stamp: 'edc 5/29/2006 08:35'!
fromFileNamed: aFileName
	| file answer |
	file _ FileStream readOnlyFileNamed: aFileName.
	answer _ self readFrom: file setConverterForCode.
	file close.
	^ answer! !

!EventRecorderMorph class methodsFor: 'instance creation' stamp: 'los 2/26/2004 11:46'!
openTapeFromFile: fullName
	"Open an eventRecorder tape for playback."
 
	(self new) readTape: fullName; openInWorld! !

!EventRecorderMorph class methodsFor: 'instance creation' stamp: 'LC 12/23/1998 11:14'!
readFrom: aStream
	^ self new readFrom: aStream! !


!EventRecorderMorph class methodsFor: 'parts bin' stamp: 'sw 11/21/2001 16:06'!
descriptionForPartsBin
	"Answer  a description for use in a parts bin"

	^ self partName: 'Event Recorder'
		categories: #(Presentation Tools)
		documentation: 'Lets you record and play back interactions'! !
InputSensor subclass: #EventSensor
	instanceVariableNames: 'mouseButtons mousePosition keyboardBuffer interruptKey interruptSemaphore eventQueue inputSemaphore lastEventPoll hasInputSemaphore'
	classVariableNames: 'EventPollPeriod EventTicklerProcess'
	poolDictionaries: 'EventSensorConstants'
	category: 'Kernel-Processes'!
!EventSensor commentStamp: 'nk 4/13/2004 11:18' prior: 0!
EventSensor is a replacement for InputSensor based on a set of (optional) event primitives. An EventSensor updates its state when events are received so that all state based users of Sensor (e.g., Sensor keyboard, Sensor leftShiftDown, Sensor mouseButtons) will work exactly as before, by moving the current VM mechanisms into EventSensor itself. An optional input semaphore is part of the new design.

For platforms that support true asynchronous event notification, the semaphore will be signaled to indicate pending events.
On platforms that do not support asynchronous notifications about events, the UI will have to poll EventSensor periodically to read events from the VM.

Instance variables:
	mouseButtons <Integer>	- mouse button state as replacement for primMouseButtons
	mousePosition <Point>	- mouse position as replacement for primMousePt
	keyboardBuffer <SharedQueue>	- keyboard input buffer
	interruptKey <Integer>			- currently defined interrupt key
	interruptSemaphore <Semaphore>	- the semaphore signaled when the interruptKey is detected
	eventQueue <SharedQueue>	- an optional event queue for event driven applications
	inputSemaphore <Semaphore>- the semaphore signaled by the VM if asynchronous event notification is supported
	lastEventPoll <Integer>		- the last millisecondClockValue at which we called fetchMoreEvents
	hasInputSemaphore <Boolean>	- true if my inputSemaphore has actually been signaled at least once.

Class variables:
	EventPollPeriod <Integer>	- the number of milliseconds to wait between polling for more events in the userInterruptHandler.
	EventTicklerProcess <Process>	- the process that makes sure that events are polled for often enough (at least every EventPollPeriod milliseconds).

Event format:
The current event format is very simple. Each event is recorded into an 8 element array. All events must provide some SmallInteger ID (the first field in the event buffer) and a time stamp (the second field in the event buffer), so that the difference between the time stamp of an event and the current time can be reported.

Currently, the following events are defined:

Null event
=============
The Null event is returned when the ST side asks for more events but no more events are available.
Structure:
[1]		- event type 0
[2-8]	- unused

Mouse event structure
==========================
Mouse events are generated when mouse input is detected.
Structure:
[1]	- event type 1
[2]	- time stamp
[3]	- mouse x position
[4]	- mouse y position
[5]	- button state; bitfield with the following entries:
		1	-	yellow (e.g., right) button
		2	-	blue (e.g., middle) button
		4	-	red (e.g., left) button
		[all other bits are currently undefined]
[6]	- modifier keys; bitfield with the following entries:
		1	-	shift key
		2	-	ctrl key
		4	-	(Mac specific) option key
		8	-	Cmd/Alt key
		[all other bits are currently undefined]
[7]	- reserved.
[8]	- reserved.

Keyboard events
====================
Keyboard events are generated when keyboard input is detected.
[1]	- event type 2
[2]	- time stamp
[3]	- character code
		For now the character code is in Mac Roman encoding.
[4]	- press state; integer with the following meaning
		0	-	character
		1	-	key press (down)
		2	- 	key release (up)
[5]	- modifier keys (same as in mouse events)
[6]	- reserved.
[7]	- reserved.
[8]	- reserved.
!


!EventSensor methodsFor: 'accessing' stamp: 'ar 7/23/2000 14:37'!
eventQueue
	"Return the current event queue"
	^eventQueue! !

!EventSensor methodsFor: 'accessing' stamp: 'nk 4/12/2004 19:36'!
eventTicklerProcess
	"Answer my event tickler process, if any"
	^EventTicklerProcess! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:48'!
flushAllButDandDEvents
	| newQueue oldQueue  |
	
	newQueue _ SharedQueue new.
	self eventQueue ifNil: 
		[eventQueue := newQueue.
		^self].
	oldQueue _ self eventQueue.
	[oldQueue size > 0] whileTrue: 
		[| item type | 
		item _ oldQueue next.
		type _ item at: 1.
		type = EventTypeDragDropFiles ifTrue: [ newQueue nextPut: item]].
	eventQueue := newQueue.
! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/7/2001 17:13'!
flushEvents
	eventQueue ifNotNil:[eventQueue flush].! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 7/30/2000 15:50'!
nextEvent
	"Return the next event from the receiver."
	eventQueue == nil 
		ifTrue:[^self nextEventSynthesized]
		ifFalse:[^self nextEventFromQueue]
! !

!EventSensor methodsFor: 'accessing' stamp: 'JMM 11/7/2005 14:38'!
peekButtons
	self wait2ms.
	self fetchMoreEvents.
	^mouseButtons! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:51'!
peekEvent
	"Look ahead at the next event."
	eventQueue ifNil:[^nil].
	self fetchMoreEvents.
	^eventQueue peek! !

!EventSensor methodsFor: 'accessing' stamp: 'tpr 1/5/2005 17:34'!
peekKeyboardEvent
	"Return the next keyboard char event from the receiver or nil if none available"
	^eventQueue nextOrNilSuchThat: 
					[:buf | 
					buf first = EventTypeKeyboard and: [(buf fourth) = EventKeyChar]]! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 2/8/2001 21:45'!
peekMousePt
	^mousePosition! !

!EventSensor methodsFor: 'accessing' stamp: 'JMM 11/7/2005 14:38'!
peekPosition
	self wait2ms.
	self fetchMoreEvents.
	^mousePosition! !


!EventSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 19:21'!
initialize
	"Initialize the receiver"
	mouseButtons := 0.
	mousePosition := 0 @ 0.
	keyboardBuffer := SharedQueue new.
	self setInterruptKey: (interruptKey ifNil: [$. asciiValue bitOr: 16r0800 ]). 	"cmd-."
	interruptSemaphore := (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new].
	self flushAllButDandDEvents.
	inputSemaphore := Semaphore new.
	hasInputSemaphore := false.! !

!EventSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 20:13'!
shutDown
	super shutDown.
	EventTicklerProcess ifNotNil: [
		EventTicklerProcess terminate.
		EventTicklerProcess _ nil. ].
	inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore].
! !

!EventSensor methodsFor: 'initialize' stamp: 'nk 6/21/2004 10:42'!
startUp
	"Run the I/O process"
	self initialize.
	self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore).
	super startUp.
	self installEventTickler.
	Smalltalk isMorphic ifTrue:[self flushAllButDandDEvents].

	"Attempt to discover whether the input semaphore is actually being signaled."
	hasInputSemaphore := false.
	inputSemaphore initSignals.
! !


!EventSensor methodsFor: 'mouse' stamp: 'ar 5/18/2003 18:27'!
createMouseEvent
	"create and return a new mouse event from the current mouse 
	position; this is useful for restarting normal event queue 
	processing after manual polling"

	| buttons modifiers pos mapped eventBuffer |
	eventBuffer _ Array new: 8.
	buttons _ self primMouseButtons.
	pos _ self primMousePt.
	modifiers _ buttons bitShift: -3.
	buttons _ buttons bitAnd: 7.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	eventBuffer
		at: 1
		put: EventTypeMouse;
		 at: 2 put: Time millisecondClockValue;
		 at: 3 put: pos x;
		 at: 4 put: pos y;
		 at: 5 put: mapped;
		 at: 6 put: modifiers.
	^ eventBuffer! !


!EventSensor methodsFor: 'private' stamp: 'nk 4/12/2004 20:16'!
eventTickler
	"Poll infrequently to make sure that the UI process is not been stuck. 
	If it has been stuck, then spin the event loop so that I can detect the 
	interrupt key."
	| delay |
	delay := Delay forMilliseconds: self class eventPollPeriod.
	self lastEventPoll.	"ensure not nil."
	[| delta | 
	[ delay wait.
	delta := Time millisecondClockValue - lastEventPoll.
	(delta < 0
			or: [delta > self class eventPollPeriod])
		ifTrue: ["force check on rollover"
			self fetchMoreEvents]] on: Error do: [:ex | ].
	true ] whileTrue.! !

!EventSensor methodsFor: 'private' stamp: 'di 10/1/2001 20:52'!
flushNonKbdEvents
	eventQueue ifNil: [^ self].
	eventQueue flushAllSuchThat:
		[:buf | (self isKbdEvent: buf) not]
! !

!EventSensor methodsFor: 'private' stamp: 'nk 6/21/2004 10:40'!
installEventTickler
	"Initialize the interrupt watcher process. Terminate the old process if any."
	"Sensor installEventTickler"

	EventTicklerProcess ifNotNil: [EventTicklerProcess terminate].
	EventTicklerProcess _ [self eventTickler] forkAt: Processor lowIOPriority.
! !

!EventSensor methodsFor: 'private' stamp: 'di 10/1/2001 20:51'!
isKbdEvent: buf
	^ (buf at: 1) = EventTypeKeyboard and: [(buf at: 4) = EventKeyChar]! !

!EventSensor methodsFor: 'private' stamp: 'nk 3/18/2004 13:21'!
lastEventPoll
	"Answer the last clock value at which fetchMoreEvents was called."
	^lastEventPoll ifNil: [ lastEventPoll _ Time millisecondClockValue ]! !

!EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:42'!
nextEventFromQueue
	"Return the next event from the receiver."
	eventQueue isEmpty ifTrue:[self fetchMoreEvents].
	eventQueue isEmpty
		ifTrue:[^nil]
		ifFalse:[^eventQueue next]! !

!EventSensor methodsFor: 'private' stamp: 'nk 3/17/2004 07:09'!
nextEventSynthesized
	"Return a synthesized event. This method is called if an event driven client wants to receive events but the primary user interface is not event-driven (e.g., the receiver does not have an event queue but only updates its state). This can, for instance, happen if a Morphic World is run in an MVC window. To simplify the clients work this method will always return all available keyboard events first, and then (repeatedly) the mouse events. Since mouse events come last, the client can assume that after one mouse event has been received there are no more to come. Note that it is impossible for EventSensor to determine if a mouse event has been issued before so the client must be aware of the possible problem of getting repeatedly the same mouse events. See HandMorph>>processEvents for an example on how to deal with this."
	| kbd array buttons pos modifiers mapped |
	"First check for keyboard"
	array _ Array new: 8.
	kbd _ self primKbdNext.
	kbd ifNotNil:
		["simulate keyboard event"
		array at: 1 put: EventTypeKeyboard. "evt type"
		array at: 2 put: Time millisecondClockValue. "time stamp"
		array at: 3 put: (kbd bitAnd: 255). "char code"
		array at: 4 put: EventKeyChar. "key press/release"
		array at: 5 put: (kbd bitShift: -8). "modifier keys"
		^ array].

	"Then check for mouse"
	pos _ self primMousePt.
	buttons _ mouseButtons.
	modifiers _ buttons bitShift: -3.
	buttons _ buttons bitAnd: 7.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	array 
		at: 1 put: EventTypeMouse;
		at: 2 put: Time millisecondClockValue;
		at: 3 put: pos x;
		at: 4 put: pos y;
		at: 5 put: mapped;
		at: 6 put: modifiers.
	^ array

! !

!EventSensor methodsFor: 'private' stamp: 'ar 7/23/2000 00:34'!
primInterruptSemaphore: aSemaphore 
	"Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed."
	interruptSemaphore _ aSemaphore.
	"backward compatibility: use the old primitive which is obsolete now"
	super primInterruptSemaphore: aSemaphore! !

!EventSensor methodsFor: 'private' stamp: 'JMM 11/7/2005 14:38'!
primKbdNext
	"Allows for use of old Sensor protocol to get at the keyboard,
	as when running kbdTest or the InterpreterSimulator in Morphic"
	| evtBuf |
	self wait2ms.
	self fetchMoreEvents.
	keyboardBuffer isEmpty ifFalse:[^ keyboardBuffer next].
	eventQueue ifNotNil:
		[evtBuf _ eventQueue nextOrNilSuchThat: [:buf | self isKbdEvent: buf].
		self flushNonKbdEvents].
	^ evtBuf ifNotNil: [evtBuf at: 3]
! !

!EventSensor methodsFor: 'private' stamp: 'JMM 11/7/2005 14:39'!
primKbdPeek
	"Allows for use of old Sensor protocol to get at the keyboard,
	as when running kbdTest or the InterpreterSimulator in Morphic"
	| char |
	self wait2ms.
	self fetchMoreEvents.
	keyboardBuffer isEmpty ifFalse: [^ keyboardBuffer peek].
	char _ nil.
	eventQueue ifNotNil:
		[eventQueue nextOrNilSuchThat:  "NOTE: must not return out of this block, so loop to end"
			[:buf | (self isKbdEvent: buf) ifTrue: [char ifNil: [char _ buf at: 3]].
			false  "NOTE: block value must be false so Queue won't advance"]].
	^ char! !

!EventSensor methodsFor: 'private' stamp: 'JMM 11/7/2005 14:39'!
primMouseButtons
	self wait2ms.
	self fetchMoreEvents.
	self flushNonKbdEvents.
	^ mouseButtons! !

!EventSensor methodsFor: 'private' stamp: 'JMM 11/7/2005 14:39'!
primMousePt
	self wait2ms.
	self fetchMoreEvents.
	self flushNonKbdEvents.
	^ mousePosition! !

!EventSensor methodsFor: 'private' stamp: 'ls 10/23/2000 14:14'!
primSetInterruptKey: anInteger
	"Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>."
	interruptKey _ anInteger.
	"backward compatibility: use the old primitive which is obsolete now"
	super primSetInterruptKey: anInteger! !

!EventSensor methodsFor: 'private' stamp: 'JMM 11/7/2005 14:37'!
wait2ms
	(Delay forMilliseconds: 2) wait.! !


!EventSensor methodsFor: 'private-I/O' stamp: 'nk 4/12/2004 20:01'!
fetchMoreEvents
	"Fetch more events from the VM"
	| eventBuffer type |

	"Reset input semaphore so clients can wait for the next events after this one."
	inputSemaphore isSignaled
		ifTrue: [ hasInputSemaphore _ true.
			inputSemaphore initSignals ].

	"Remember the last time that I checked for events."
	lastEventPoll := Time millisecondClockValue.

	eventBuffer := Array new: 8.
	[self primGetNextEvent: eventBuffer.
	type := eventBuffer at: 1.
	type = EventTypeNone]
		whileFalse: [self processEvent: eventBuffer].
! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/30/2000 18:12'!
mapButtons: buttons modifiers: modifiers
	"Map the buttons to yellow or blue based on the given modifiers.
	If only the red button is pressed, then map
		Ctrl-RedButton -> BlueButton.
		Cmd-RedButton -> YellowButton.
	"
	(buttons = RedButtonBit)
		ifFalse:[^buttons].
	(modifiers allMask: CtrlKeyBit) 
		ifTrue:[^BlueButtonBit].
	(modifiers allMask: CommandKeyBit) 
		ifTrue:[^YellowButtonBit].
	^buttons! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 8/16/2000 22:06'!
primGetNextEvent: array
	"Store the next OS event available into the provided array.
	Essential. If the VM is not event driven the ST code will fall
	back to the old-style mechanism and use the state based
	primitives instead."
	| kbd buttons modifiers pos mapped |
	<primitive: 94>
	"Simulate the events"
	array at: 1 put: EventTypeNone. "assume no more events"

	"First check for keyboard"
	kbd _ super primKbdNext.
	kbd = nil ifFalse:[
		"simulate keyboard event"
		array at: 1 put: EventTypeKeyboard. "evt type"
		array at: 2 put: Time millisecondClockValue. "time stamp"
		array at: 3 put: (kbd bitAnd: 255). "char code"
		array at: 4 put: EventKeyChar. "key press/release"
		array at: 5 put: (kbd bitShift: -8). "modifier keys"
		^self].

	"Then check for mouse"
	buttons _ super primMouseButtons.
	pos _ super primMousePt.
	modifiers _ buttons bitShift: -3.
	buttons _ buttons bitAnd: 7.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	(pos = mousePosition and:[(mapped bitOr: (modifiers bitShift: 3)) = mouseButtons])
		ifTrue:[^self].
	array 
		at: 1 put: EventTypeMouse;
		at: 2 put: Time millisecondClockValue;
		at: 3 put: pos x;
		at: 4 put: pos y;
		at: 5 put: mapped;
		at: 6 put: modifiers.
! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/30/2000 18:16'!
primSetInputSemaphore: semaIndex
	"Set the input semaphore the VM should use for asynchronously signaling the availability of events. Primitive. Optional."
	<primitive: 93>
	^nil! !

!EventSensor methodsFor: 'private-I/O' stamp: 'wiz 11/11/2005 02:37'!
processEvent: evt 
	"Process a single event. This method is run at high priority."
	| type |
	type := evt at: 1.
	"Tackle mouse events first"
	type = EventTypeMouse
		ifTrue: [evt
				at: 5
				put: (ButtonDecodeTable at: (evt at: 5)
							+ 1). 
				self queueEvent: evt.
				self processMouseEvent: evt . 
				^self].
	
	
	"Store the event in the queue if there's any"
	type = EventTypeKeyboard
		ifTrue: [ "Check if the event is a user interrupt"
			((evt at: 4) = 0
				and: [((evt at: 3)
						bitOr: (((evt at: 5)
							bitAnd: 8)
							bitShift: 8))
							= interruptKey])
					ifTrue: ["interrupt key is meta - not reported as event"
							^ interruptSemaphore signal].
			"Else swap ctrl/alt keys if neeeded.wi"
			KeyDecodeTable
				at: {evt at: 3. evt at: 5}
				ifPresent: [:a | evt at: 3 put: a first;
						 at: 5 put: a second]. 
			self queueEvent: evt. 
			self processKeyboardEvent: evt . 
			^self ].
				
	"Handle all events other than Keyborad or Mouse."
	self queueEvent: evt.
	! !

!EventSensor methodsFor: 'private-I/O' stamp: 'nk 4/11/2001 18:28'!
processKeyboardEvent: evt
	"process a keyboard event, updating InputSensor state"
	| charCode pressCode |
	"Never update keyboardBuffer if we have an eventQueue active"
	mouseButtons _ (mouseButtons bitAnd: 7) bitOr: ((evt at: 5) bitShift: 3).
	eventQueue ifNotNil:[^self]. 
	charCode _ evt at: 3.
	charCode = nil ifTrue:[^self]. "extra characters not handled in MVC"
	pressCode _ evt at: 4.
	pressCode = EventKeyChar ifFalse:[^self]. "key down/up not handled in MVC"
	"mix in modifiers"
	charCode _ charCode bitOr: ((evt at: 5) bitShift: 8).
	keyboardBuffer nextPut: charCode.! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 8/16/2000 22:07'!
processMouseEvent: evt
	"process a mouse event, updating InputSensor state"
	| modifiers buttons mapped |
	mousePosition _ (evt at: 3) @ (evt at: 4).
	buttons _ evt at: 5.
	modifiers _ evt at: 6.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	mouseButtons _ mapped bitOr: (modifiers bitShift: 3).! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/23/2000 14:55'!
queueEvent: evt
	"Queue the given event in the event queue (if any).
	Note that the event buffer must be copied since it
	will be reused later on."
	eventQueue ifNil:[^self].
	eventQueue nextPut: evt clone.! !

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

EventSensor class
	instanceVariableNames: ''!

!EventSensor class methodsFor: 'class initialization' stamp: 'nk 4/12/2004 18:55'!
eventPollPeriod
	^EventPollPeriod ifNil: [ EventPollPeriod _ 500 ].! !

!EventSensor class methodsFor: 'class initialization' stamp: 'nk 4/12/2004 18:55'!
eventPollPeriod: msec
	"Set the number of milliseconds between checking for events to msec."

	EventPollPeriod _ msec max: 10.! !

!EventSensor class methodsFor: 'class initialization' stamp: 'ar 7/23/2000 15:06'!
install	"EventSensor install"
	"Install an EventSensor in place of the current Sensor."
	| newSensor |
	Sensor shutDown.
	newSensor _ self new.
	newSensor startUp.
	"Note: We must use #become: here to replace all references to the old sensor with the new one, since Sensor is referenced from all the existing controllers."
	Sensor becomeForward: newSensor. "done"! !
SharedPool subclass: #EventSensorConstants
	instanceVariableNames: ''
	classVariableNames: 'BlueButtonBit CommandKeyBit CtrlKeyBit EventKeyChar EventKeyDown EventKeyUp EventTypeDragDropFiles EventTypeKeyboard EventTypeMouse EventTypeNone OptionKeyBit RedButtonBit ShiftKeyBit YellowButtonBit'
	poolDictionaries: ''
	category: 'Kernel-Processes'!

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

EventSensorConstants class
	instanceVariableNames: ''!

!EventSensorConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:26'!
initialize
	"EventSensorConstants initialize"
	RedButtonBit := 4.
	BlueButtonBit := 2.
	YellowButtonBit := 1.

	ShiftKeyBit := 1.
	CtrlKeyBit := 2.
	OptionKeyBit := 4.
	CommandKeyBit := 8.

	"Types of events"
	EventTypeNone := 0.
	EventTypeMouse := 1.
	EventTypeKeyboard := 2.
	EventTypeDragDropFiles := 3.

	"Press codes for keyboard events"
	EventKeyChar := 0.
	EventKeyDown := 1.
	EventKeyUp := 2.
! !
TestCase subclass: #EventTest
	instanceVariableNames: 'eventSource eventListener succeeded'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Events-Tests'!

!EventTest methodsFor: 'running' stamp: 'jws 9/7/2000 16:37'!
setUp

	super setUp.
	eventSource := Object new.
	eventListener := Bag new.
	succeeded := false! !

!EventTest methodsFor: 'running' stamp: 'jws 11/28/2000 16:25'!
tearDown

	eventSource releaseActionMap.
	eventSource := nil.
	eventListener := nil.
	super tearDown.
! !


!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'!
testMultipleValueSuppliers

	eventSource
		when: #needsValue
		send: #getFalse
		to: self.
	eventSource
		when: #needsValue
		send: #getTrue
		to: self.
	succeeded := eventSource triggerEvent: #needsValue.
	self should: [succeeded]! !

!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'!
testMultipleValueSuppliersEventHasArguments

	eventSource
		when: #needsValue:
		send: #getFalse:
		to: self.
	eventSource
		when: #needsValue:
		send: #getTrue:
		to: self.
	succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'.
	self should: [succeeded]! !

!EventTest methodsFor: 'running-broadcast query' stamp: 'rw 4/27/2002 09:12'!
testMultipleValueSuppliersEventHasArgumentsWithGC

	eventSource
		when: #needsValue:
		send: #getFalse:
		to: self
		with: Object new.
	eventSource
		when: #needsValue:
		send: #getTrue:
		to: self
		with: Object new.
	Smalltalk garbageCollectMost.
	succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'.
	self should: [succeeded = nil]
! !

!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'!
testNoValueSupplier

	succeeded := eventSource 
		triggerEvent: #needsValue
		ifNotHandled: [true].
	self should: [succeeded]! !

!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'!
testNoValueSupplierHasArguments

	succeeded := eventSource 
		triggerEvent: #needsValue:
		with: 'nelja'
		ifNotHandled: [true].
	self should: [succeeded]! !

!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:42'!
testSingleValueSupplier

	eventSource
		when: #needsValue
		send: #getTrue
		to: self.
	succeeded := eventSource triggerEvent: #needsValue.
	self should: [succeeded]! !


!EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'!
testNoArgumentEvent

	eventSource when: #anEvent send: #heardEvent to: self.
	eventSource triggerEvent: #anEvent.
	self should: [succeeded]! !

!EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'!
testOneArgumentEvent

	eventSource when: #anEvent: send: #add: to: eventListener.
	eventSource triggerEvent: #anEvent: with: 9.
	self should: [eventListener includes: 9]! !

!EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'!
testTwoArgumentEvent

	eventSource when: #anEvent:info: send: #addArg1:addArg2: to: self.
	eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ).
	self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! !


!EventTest methodsFor: 'running-dependent action supplied arguments' stamp: 'jws 9/7/2000 16:39'!
testNoArgumentEventDependentSuppliedArgument

	eventSource when: #anEvent send: #add: to: eventListener with: 'boundValue'.
	eventSource triggerEvent: #anEvent.
	self should: [eventListener includes: 'boundValue']! !

!EventTest methodsFor: 'running-dependent action supplied arguments' stamp: 'jws 9/7/2000 16:40'!
testNoArgumentEventDependentSuppliedArguments

	eventSource 
		when: #anEvent 
		send: #addArg1:addArg2: 
		to: self 
		withArguments: #('hello' 'world').
	eventSource triggerEvent: #anEvent.
	self should: [(eventListener includes: 'hello') and: [eventListener includes: 'world']]! !


!EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'!
testReturnValueWithManyListeners

	| value newListener |
	newListener := 'busybody'.
	eventSource
		when: #needsValue
		send: #yourself
		to: eventListener.
	eventSource
		when: #needsValue
		send: #yourself
		to: newListener.
	value := eventSource triggerEvent: #needsValue.
	self should: [value == newListener]! !

!EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'!
testReturnValueWithNoListeners

	| value |
	value := eventSource triggerEvent: #needsValue.
	self should: [value == nil]! !

!EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'!
testReturnValueWithOneListener

	| value |
	eventSource
		when: #needsValue
		send: #yourself
		to: eventListener.
	value := eventSource triggerEvent: #needsValue.
	self should: [value == eventListener]! !


!EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:04'!
testRemoveActionsForEvent

	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	eventSource removeActionsForEvent: #anEvent.
	self shouldnt: [eventSource hasActionForEvent: #anEvent]! !

!EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:05'!
testRemoveActionsTwiceForEvent

	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	eventSource removeActionsForEvent: #anEvent.
	self assert: (eventSource hasActionForEvent: #anEvent) not.
	eventSource removeActionsForEvent: #anEvent.
	self assert: (eventSource hasActionForEvent: #anEvent) not.! !

!EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:05'!
testRemoveActionsWithReceiver

	| action |
	eventSource
		when: #anEvent send: #size to: eventListener;
		when: #anEvent send: #getTrue to: self;
		when: #anEvent: send: #fizzbin to: self.
	eventSource removeActionsWithReceiver: self.
	action := eventSource actionForEvent: #anEvent.
	self assert: (action respondsTo: #receiver).
	self assert: ((action receiver == self) not)! !


!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'!
addArg1: arg1
addArg2: arg2

	eventListener
		add: arg1;
		add: arg2! !

!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'!
getFalse

	^false! !

!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'!
getFalse: anArg

	^false! !

!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'!
getTrue

	^true! !

!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'!
getTrue: anArg

	^true! !

!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'!
heardEvent

	succeeded := true! !
Object subclass: #Exception
	instanceVariableNames: 'messageText tag signalContext handlerContext outerContext'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!Exception commentStamp: '<historical>' prior: 0!
This is the main class used to implement the exception handling system (EHS).  It plays two distinct roles:  that of the exception, and that of the exception handler.  More specifically, it implements the bulk of the protocols laid out in the ANSI specification - those protocol names are reflected in the message categories.

Exception is an abstract class.  Instances should neither be created nor trapped.  In most cases, subclasses should inherit from Error or Notification rather than directly from Exception.

In implementing this EHS, The Fourth Estate Inc. incorporated some ideas and code from Craig Latta's EHS.  His insights were crucial in allowing us to implement BlockContext>>valueUninterruptably (and by extension, #ensure: and #ifCurtailed:), and we imported the following methods with little or no modification:

ContextPart>>terminateTo:
ContextPart>>terminate
MethodContext>>receiver:
MethodContext>>answer:

Thanks, Craig!!!


!Exception methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:23'!
tag: t
	"This message is not specified in the ANSI protocol, but that looks like an oversight because #tag is specified, and the spec states that the signaler may store the tag value."

	tag := t! !


!Exception methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 14:54'!
tag
	"Return an exception's tag value."

	^tag == nil
		ifTrue: [self messageText]
		ifFalse: [tag]! !


!Exception methodsFor: 'handling' stamp: 'ajh 2/1/2003 01:32'!
isNested
	"Determine whether the current exception handler is within the scope of another handler for the same exception."

	^ handlerContext nextHandlerContext canHandleSignal: self! !

!Exception methodsFor: 'handling' stamp: 'ajh 6/27/2003 22:13'!
outer
	"Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)."

	| prevOuterContext |
	self isResumable ifTrue: [
		prevOuterContext _ outerContext.
		outerContext _ thisContext contextTag.
	].
	self pass.
! !

!Exception methodsFor: 'handling' stamp: 'ajh 2/1/2003 01:33'!
pass
	"Yield control to the enclosing exception action for the receiver."

	handlerContext nextHandlerContext handleSignal: self! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/22/2003 23:04'!
resignalAs: replacementException
	"Signal an alternative exception in place of the receiver."

	self resumeUnchecked: replacementException signal! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/13/2002 15:09'!
resume
	"Return from the message that signaled the receiver."

	self resume: nil! !

!Exception methodsFor: 'handling' stamp: 'ajh 6/27/2003 22:30'!
resumeUnchecked: resumptionValue
	"Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer."

	| ctxt |
	outerContext ifNil: [
		signalContext return: resumptionValue
	] ifNotNil: [
		ctxt _ outerContext.
		outerContext _ ctxt tempAt: 1. "prevOuterContext in #outer"
		ctxt return: resumptionValue
	].
! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/13/2002 15:14'!
resume: resumptionValue
	"Return resumptionValue as the value of the signal message."

	self isResumable ifFalse: [IllegalResumeAttempt signal].
	self resumeUnchecked: resumptionValue! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:36'!
retry
	"Abort an exception handler and re-evaluate its protected block."

	handlerContext restart! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37'!
retryUsing: alternativeBlock
	"Abort an exception handler and evaluate a new block in place of the handler's protected block."

	handlerContext restartWithNewReceiver: alternativeBlock
! !

!Exception methodsFor: 'handling' stamp: 'ajh 9/30/2001 15:33'!
return
	"Return nil as the value of the block protected by the active exception handler."

	self return: nil! !

!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37'!
return: returnValue
	"Return the argument as the value of the block protected by the active exception handler."

	handlerContext return: returnValue! !

!Exception methodsFor: 'handling' stamp: 'ajh 2/16/2003 17:37'!
searchFrom: aContext
	" Set the context where the handler search will start. "

	signalContext := aContext contextTag! !


!Exception methodsFor: 'printing' stamp: 'pnm 8/16/2000 14:53'!
description
	"Return a textual description of the exception."

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

!Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33'!
messageText
	"Return an exception's message text."

	^messageText! !

!Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33'!
printOn: stream

	stream nextPutAll: self description! !

!Exception methodsFor: 'printing' stamp: 'ajh 10/22/2001 14:24'!
receiver

	^ self signalerContext receiver! !

!Exception methodsFor: 'printing' stamp: 'ar 6/28/2003 00:13'!
signalerContext
	"Find the first sender of signal(:)"

	^ signalContext findContextSuchThat: [:ctxt |
		(ctxt receiver == self or: [ctxt receiver == self class]) not]! !


!Exception methodsFor: 'priv handling' stamp: 'ajh 9/30/2001 15:33'!
defaultAction
	"The default action taken if the exception is signaled."

	self subclassResponsibility! !

!Exception methodsFor: 'priv handling' stamp: 'ajh 2/1/2003 00:58'!
isResumable
	"Determine whether an exception is resumable."

	^ true! !

!Exception methodsFor: 'priv handling' stamp: 'ajh 1/29/2003 13:44'!
privHandlerContext: aContextTag

	handlerContext _ aContextTag! !


!Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 15:33'!
messageText: signalerText
	"Set an exception's message text."

	messageText := signalerText! !

!Exception methodsFor: 'signaling' stamp: 'ajh 2/1/2003 01:33'!
signal
	"Ask ContextHandlers in the sender chain to handle this signal.  The default is to execute and return my defaultAction."

	signalContext _ thisContext contextTag.
	^ thisContext nextHandlerContext handleSignal: self! !

!Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 20:13'!
signal: signalerText
	"Signal the occurrence of an exceptional condition with a specified textual description."

	self messageText: signalerText.
	^ self signal! !

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

Exception class
	instanceVariableNames: ''!

!Exception class methodsFor: 'exceptionInstantiator' stamp: 'ajh 9/30/2001 21:54'!
signal
	"Signal the occurrence of an exceptional condition."

	^ self new signal! !

!Exception class methodsFor: 'exceptionInstantiator' stamp: 'ajh 9/30/2001 21:54'!
signal: signalerText
	"Signal the occurrence of an exceptional condition with a specified textual description."

	^ self new signal: signalerText! !


!Exception class methodsFor: 'exceptionSelector' stamp: 'ajh 9/30/2001 15:33'!
, anotherException
	"Create an exception set."

	^ExceptionSet new
		add: self;
		add: anotherException;
		yourself! !

!Exception class methodsFor: 'exceptionSelector' stamp: 'ajh 8/5/2003 11:33'!
handles: exception
	"Determine whether an exception handler will accept a signaled exception."

	^ exception isKindOf: self! !
Notification subclass: #ExceptionAboutToReturn
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!ExceptionAboutToReturn commentStamp: '<historical>' prior: 0!
This class is private to the EHS implementation.  Its use allows for ensured execution to survive code such as:

[self doThis.
^nil]
	ensure: [self doThat]

Signaling or handling this exception is not recommended.  Not even slightly.!

Object subclass: #ExceptionSet
	instanceVariableNames: 'exceptions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!ExceptionSet commentStamp: '<historical>' prior: 0!
An ExceptionSet is a grouping of exception handlers which acts as a single handler.  Within the group, the most recently added handler will be the last handler found during a handler search (in the case where more than one handler in the group is capable of handling a given exception). !


!ExceptionSet methodsFor: 'exceptionSelector' stamp: 'tfei 6/4/1999 18:37'!
, anException
	"Return an exception set that contains the receiver and the argument exception. This is commonly used to specify a set of exception selectors for an exception handler."

	self add: anException.
	^self! !

!ExceptionSet methodsFor: 'exceptionSelector' stamp: 'pnm 8/16/2000 15:15'!
handles: anException
	"Determine whether an exception handler will accept a signaled exception."

	exceptions do:
		[:ex |
		(ex handles: anException)
			ifTrue: [^true]].
	^false! !


!ExceptionSet methodsFor: 'private' stamp: 'tfei 7/16/1999 1:07'!
add: anException

	exceptions add: anException! !

!ExceptionSet methodsFor: 'private' stamp: 'tfei 3/23/1999 14:07'!
initialize

	exceptions := OrderedCollection new! !
Object subclass: #ExceptionTester
	instanceVariableNames: 'log suiteLog iterationsBeforeTimeout'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Tests'!

!ExceptionTester methodsFor: 'accessing' stamp: 'dtl 6/1/2004 21:53'!
basicANSISignaledExceptionTestSelectors

	^#( simpleIsNestedTest simpleOuterTest doubleOuterTest doubleOuterPassTest doublePassOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! !

!ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:54'!
basicTestSelectors
	^ #(#simpleEnsureTest #simpleEnsureTestWithNotification #simpleEnsureTestWithUparrow #simpleEnsureTestWithError #signalFromHandlerActionTest #resumableFallOffTheEndHandler #nonResumableFallOffTheEndHandler #doubleResumeTest #simpleTimeoutWithZeroDurationTest #simpleTimeoutTest simpleNoTimeoutTest)! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'!
doSomethingElseString

	^'Do something else.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'!
doSomethingExceptionalString

	^'Do something exceptional.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:13'!
doSomethingString

	^'Do something.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'!
doYetAnotherThingString

	^'Do yet another thing.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:15'!
iterationsBeforeTimeout

	^ iterationsBeforeTimeout! !

!ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:16'!
iterationsBeforeTimeout: anInteger

	iterationsBeforeTimeout := anInteger! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/7/1999 15:03'!
log

	log == nil
		ifTrue: [log := OrderedCollection new].
	^log! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:30'!
suiteLog

	suiteLog == nil
		ifTrue: [suiteLog := OrderedCollection new].
	^suiteLog! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'!
testString

	^'This is only a test.'! !


!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:17'!
clearLog

	log := nil! !

!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/7/1999 15:16'!
contents

	^( self log
		inject: (WriteStream on: (String new: 80))
		into: 
			[:result :item |
			result 
				cr; 
				nextPutAll: item;
				yourself] ) contents! !

!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/7/1999 15:03'!
log: aString

	self log add: aString! !

!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/12/1999 23:07'!
logTest: aSelector

	self suiteLog add: aSelector! !

!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:38'!
logTestResult: aString

	| index |
	index := self suiteLog size.
	self suiteLog 
		at: index
		put: ((self suiteLog at: index), ' ', aString)! !


!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:13'!
doSomething

	self log: self doSomethingString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'!
doSomethingElse

	self log: self doSomethingElseString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'!
doSomethingExceptional

	self log: self doSomethingExceptionalString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:15'!
doYetAnotherThing

	self log: self doYetAnotherThingString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'!
methodWithError

	MyTestError signal: self testString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'!
methodWithNotification

	MyTestNotification signal: self testString! !


!ExceptionTester methodsFor: 'results' stamp: 'tfei 11/14/1999 17:29'!
doubleResumeTestResults

       ^OrderedCollection new
               add: self doSomethingString;
               add: self doSomethingElseString;
               add: self doYetAnotherThingString;
               yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:21'!
nonResumableFallOffTheEndHandlerResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingExceptionalString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 02:39'!
resumableFallOffTheEndHandlerResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingExceptionalString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 01:51'!
signalFromHandlerActionTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:47'!
simpleEnsureTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingElseString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/9/1999 17:44'!
simpleEnsureTestWithErrorResults

	^OrderedCollection new
		add: self doSomethingString;
		add: 'Unhandled Exception';
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 10:13'!
simpleEnsureTestWithNotificationResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingElseString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 18:55'!
simpleEnsureTestWithUparrowResults

	^OrderedCollection new
		add: self doSomethingString;
"		add: self doSomethingElseString;"
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 16:54'!
simpleNoTimeoutTestResults

	^OrderedCollection new
		add: self doSomethingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 17:44'!
simpleTimeoutTestResults

	| things |
	things := OrderedCollection new: self iterationsBeforeTimeout.

	self iterationsBeforeTimeout timesRepeat: [ things add: self  doSomethingString ].
	things add: self doSomethingElseString.

	^ things! !

!ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 16:52'!
simpleTimeoutWithZeroDurationTestResults

	^OrderedCollection new
		add: self doSomethingElseString;
		yourself! !


!ExceptionTester methodsFor: 'signaledException results' stamp: 'dtl 6/1/2004 21:56'!
doubleOuterPassTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'dtl 6/1/2004 21:56'!
doublePassOuterTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:09'!
simpleIsNestedTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:10'!
simpleOuterTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:10'!
simplePassTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:11'!
simpleResignalAsTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'RAA 12/8/2000 12:59'!
simpleResumeTestResults

	"see if we can resume twice"

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			add: self doSomethingElseString;
			add: self doYetAnotherThingString;
			add: self doSomethingElseString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:23'!
simpleRetryTestResults

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			add: self doSomethingString;
			add: self doSomethingElseString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:23'!
simpleRetryUsingTestResults

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 02:22'!
simpleReturnTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		yourself! !


!ExceptionTester methodsFor: 'signaledException tests' stamp: 'dtl 6/1/2004 21:51'!
doubleOuterPassTest
	"uses #resume"

	[[[self doSomething.
	MyTestNotification signal.
	self doSomethingExceptional]
		on: MyTestNotification
		do: [:ex | ex outer.
			self doSomethingElse]]
			on: MyTestNotification
			do: [:ex | ex pass.
				self doSomethingExceptional]]
				on: MyTestNotification
				do: [:ex | self doYetAnotherThing. ex resume]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'dtl 6/1/2004 21:49'!
doubleOuterTest
	"uses #resume"

	[[[self doSomething.
	MyTestNotification signal.
	self doSomethingExceptional]
		on: MyTestNotification
		do: [:ex | ex outer.
			self doSomethingExceptional]]
			on: MyTestNotification
			do: [:ex | ex outer.
				self doSomethingElse]]
				on: MyTestNotification
				do: [:ex | self doYetAnotherThing. ex resume]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'dtl 6/1/2004 21:52'!
doublePassOuterTest
	"uses #resume"

	[[[self doSomething.
	MyTestNotification signal.
	self doSomethingExceptional]
		on: MyTestNotification
		do: [:ex | ex pass.
			self doSomethingExceptional]]
			on: MyTestNotification
			do: [:ex | ex outer.
				self doSomethingElse]]
				on: MyTestNotification
				do: [:ex | self doYetAnotherThing. ex resume]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:27'!
simpleIsNestedTest
	"uses resignalAs:"

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex |
			ex isNested "expecting to detect handler in #runTest:"
				ifTrue:
					[self doYetAnotherThing.
					ex resignalAs: MyTestNotification new]]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tpr 5/27/2004 21:50'!
simpleOuterTest
	"uses #resume"

	[[self doSomething.
	MyTestNotification signal.
	"self doSomethingElse"
	self doSomethingExceptional]
		on: MyTestNotification
		do: [:ex | ex outer. self doSomethingElse]]
				on: MyTestNotification
				do: [:ex | self doYetAnotherThing. ex resume]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:37'!
simplePassTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex |
			self doYetAnotherThing.
			ex pass "expecting handler in #runTest:"]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 02:12'!
simpleResignalAsTest
	"ExceptionTester new simpleResignalAsTest"

	[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do:
			[:ex | ex resignalAs: MyTestError new]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'RAA 12/8/2000 12:58'!
simpleResumeTest

	"see if we can resume twice"

	| it |
	[self doSomething.
	it := MyResumableTestError signal.
	it = 3 ifTrue: [self doSomethingElse].
	it := MyResumableTestError signal.
	it = 3 ifTrue: [self doSomethingElse].
	]
		on: MyResumableTestError
		do:
			[:ex |
			self doYetAnotherThing.
			ex resume: 3]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:02'!
simpleRetryTest

	| theMeaningOfLife |
	theMeaningOfLife := nil.
	[self doSomething.
	theMeaningOfLife == nil
		ifTrue: [MyTestError signal]
		ifFalse: [self doSomethingElse]]
			on: MyTestError
			do:
				[:ex |
				theMeaningOfLife := 42.
				self doYetAnotherThing.
				ex retry]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:03'!
simpleRetryUsingTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex | ex retryUsing: [self doYetAnotherThing]]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:59'!
simpleReturnTest

	| it |
	it :=
		[self doSomething.
		MyTestError signal.
		self doSomethingElse]
			on: MyTestError
			do: [:ex | ex return: 3].
	it = 3 ifTrue: [self doYetAnotherThing]! !


!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/13/1999 01:25'!
runAllTests
	"ExceptionTester new runAllTests"

	self
		runBasicTests;
		runBasicANSISignaledExceptionTests! !

!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/12/1999 23:54'!
runBasicANSISignaledExceptionTests

	self basicANSISignaledExceptionTestSelectors
		do:
			[:eachTestSelector |
			self runTest: eachTestSelector]! !

!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/9/1999 16:06'!
runBasicTests

	self basicTestSelectors
		do:
			[:eachTestSelector |
			self runTest: eachTestSelector]! !


!ExceptionTester methodsFor: 'testing' stamp: 'brp 10/21/2004 17:40'!
runTest: aSelector

	| actualResult expectedResult |
	[ self 
		logTest: aSelector;
		clearLog;
		perform: aSelector ]
			on: MyTestError do: 
				[ :ex | self log: 'Unhandled Exception'.
					ex return: nil ].

	actualResult	:= self log.
	expectedResult := self perform: (aSelector, #Results) asSymbol.

	actualResult = expectedResult
		ifTrue: [self logTestResult: 'succeeded']
		ifFalse: [self logTestResult: 'failed' ].
! !


!ExceptionTester methodsFor: 'tests' stamp: 'tfei 11/14/1999 17:26'!
doubleResumeTest

       [self doSomething.
       MyResumableTestError signal.
       self doSomethingElse.
       MyResumableTestError signal.
       self doYetAnotherThing]
               on: MyResumableTestError
               do: [:ex | ex resume].! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 13:43'!
nonResumableFallOffTheEndHandler
	
	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do: [:ex | self doSomethingExceptional].
	self doYetAnotherThing! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:07'!
resumableFallOffTheEndHandler

	[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do: [:ex | self doSomethingExceptional].
	self doYetAnotherThing! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 8/19/1999 01:39'!
signalFromHandlerActionTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[self doYetAnotherThing.
			MyTestError signal]! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 09:44'!
simpleEnsureTest

	[self doSomething.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 12:50'!
simpleEnsureTestWithError

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 10:15'!
simpleEnsureTestWithNotification

	[self doSomething.
	self methodWithNotification.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:04'!
simpleEnsureTestWithUparrow

	[self doSomething.
	true ifTrue: [^nil].
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'!
simpleNoTimeoutTest

	[ self doSomething ]
		valueWithin: 1 day onTimeout:
			[ self doSomethingElse ].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'!
simpleTimeoutTest

	| n |
	[1 to: 1000000 do: [ :i | n := i. self doSomething ] ]
		valueWithin: 50 milliSeconds onTimeout:
			[ self iterationsBeforeTimeout: n.
			self doSomethingElse ]! !

!ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'!
simpleTimeoutWithZeroDurationTest

	[ self doSomething ]
		valueWithin: 0 seconds onTimeout:
			[ self doSomethingElse ].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 14:28'!
warningTest

	self log: 'About to signal warning.'.
	Warning signal: 'Ouch'.
	self log: 'Warning signal handled and resumed.'! !
TestCase subclass: #ExceptionTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Tests'!

!ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:42'!
testNoTimeout
	self assertSuccess: (ExceptionTester new runTest: #simpleNoTimeoutTest ) ! !

!ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:41'!
testTimeoutWithZeroDuration
	self assertSuccess: (ExceptionTester new runTest: #simpleTimeoutWithZeroDurationTest ) ! !


!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'dtl 6/1/2004 21:54'!
testDoubleOuterPass
	self assertSuccess: (ExceptionTester new runTest: #doubleOuterPassTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'dtl 6/1/2004 21:54'!
testDoublePassOuter
	self assertSuccess: (ExceptionTester new runTest: #doublePassOuterTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:43'!
testDoubleResume
	self assertSuccess: (ExceptionTester new runTest: #doubleResumeTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:44'!
testNonResumableFallOffTheEndHandler
	self assertSuccess: (ExceptionTester new runTest: #nonResumableFallOffTheEndHandler ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:44'!
testResumableFallOffTheEndHandler
	self assertSuccess: (ExceptionTester new runTest: #resumableFallOffTheEndHandler ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:44'!
testSignalFromHandlerActionTest
	self assertSuccess: (ExceptionTester new runTest: #signalFromHandlerActionTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:48'!
testSimpleEnsure
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:45'!
testSimpleEnsureTestWithError
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithError ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:46'!
testSimpleEnsureTestWithNotification
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithNotification ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:45'!
testSimpleEnsureTestWithUparrow
	self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithUparrow ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:46'!
testSimpleIsNested
	self assertSuccess: (ExceptionTester new runTest: #simpleIsNestedTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:41'!
testSimpleOuter
	self assertSuccess: (ExceptionTester new runTest: #simpleOuterTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:42'!
testSimplePass
	self assertSuccess: (ExceptionTester new runTest: #simplePassTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:43'!
testSimpleResignalAs
	self assertSuccess: (ExceptionTester new runTest: #simpleResignalAsTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:48'!
testSimpleResume
	self assertSuccess: (ExceptionTester new runTest: #simpleResumeTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:48'!
testSimpleRetry
	self assertSuccess: (ExceptionTester new runTest: #simpleRetryTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:47'!
testSimpleRetryUsing
	self assertSuccess: (ExceptionTester new runTest: #simpleRetryUsingTest ) ! !

!ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:48'!
testSimpleReturn
	self assertSuccess: (ExceptionTester new runTest: #simpleReturnTest ) ! !


!ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 21:59'!
testNonResumableOuter

	self should: [
		[Error signal. 4] 
			on: Error 
			do: [:ex | ex outer. ex return: 5]
		] raise: Error
! !

!ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'!
testNonResumablePass

	self should: [
		[Error signal. 4] 
			on: Error 
			do: [:ex | ex pass. ex return: 5]
		] raise: Error
! !

!ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'!
testResumableOuter

	| result |
	result _ [Notification signal. 4] 
		on: Notification 
		do: [:ex | ex outer. ex return: 5].
	self assert: result == 5
! !

!ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'!
testResumablePass

	| result |
	result _ [Notification signal. 4] 
		on: Notification 
		do: [:ex | ex pass. ex return: 5].
	self assert: result == 4
! !


!ExceptionTests methodsFor: 'private' stamp: 'md 3/25/2003 23:40'!
assertSuccess: anExceptionTester
	self should: [ ( anExceptionTester suiteLog first) endsWith:  'succeeded'].! !
Object subclass: #ExternalDropHandler
	instanceVariableNames: 'action type extension'
	classVariableNames: 'DefaultHandler RegisteredHandlers'
	poolDictionaries: ''
	category: 'System-Support'!

!ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 15:54'!
extension
	^extension! !

!ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:29'!
handle: dropStream in: pasteUp dropEvent: anEvent
	| numArgs |
	numArgs _ action numArgs.
	numArgs == 1
		ifTrue: [^action value: dropStream].
	numArgs == 2
		ifTrue: [^action value: dropStream value: pasteUp].
	numArgs == 3
		ifTrue: [^action value: dropStream value: pasteUp value: anEvent].
	self error: 'Wrong number of args for dop action.'! !

!ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 15:54'!
type
	^type! !


!ExternalDropHandler methodsFor: 'initialize' stamp: 'mir 1/10/2002 17:17'!
type: aType extension: anExtension action: anAction 
	action _ anAction.
	type _ aType.
	extension _ anExtension! !


!ExternalDropHandler methodsFor: 'testing' stamp: 'spfa 5/25/2004 13:38'!
matchesExtension: aExtension
	(self extension isNil or: [aExtension isNil])
		ifTrue: [^false].
	FileDirectory activeDirectoryClass isCaseSensitive
		ifTrue: [^extension = aExtension]
		ifFalse: [^extension sameAs: aExtension]! !

!ExternalDropHandler methodsFor: 'testing' stamp: 'mir 1/10/2002 16:35'!
matchesTypes: types
	(self type isNil or: [types isNil])
		ifTrue: [^false].
	^types anySatisfy: [:mimeType | mimeType beginsWith: self type]! !

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

ExternalDropHandler class
	instanceVariableNames: ''!

!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:17'!
defaultHandler
	DefaultHandler ifNil: [DefaultHandler _ ExternalDropHandler type: nil extension: nil action: [:dropStream | dropStream edit]].
	^DefaultHandler! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 16:54'!
defaultHandler: externalDropHandler
	DefaultHandler _ externalDropHandler! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 8/24/2004 15:37'!
lookupExternalDropHandler: stream

	| types extension serviceHandler |
	types _ stream mimeTypes.

	types ifNotNil: [
		self registeredHandlers do: [:handler | 
			(handler matchesTypes: types)
				ifTrue: [^handler]]].

	extension _ FileDirectory extensionFor: stream name.
	self registeredHandlers do: [:handler | 
		(handler matchesExtension: extension)
				ifTrue: [^handler]].
	serviceHandler := self lookupServiceBasedHandler: stream.
	^serviceHandler
		ifNil: [self defaultHandler]! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 8/24/2004 17:15'!
lookupServiceBasedHandler: dropStream
	"the file was just droped, let's do our job"
	| fileName services theOne |
	fileName := dropStream name.

	services := (FileList itemsForFile: fileName)
		reject: [:svc | self unwantedSelectors includes: svc selector].

	"no service, default behavior"
	services isEmpty
		ifTrue: [^nil].

	theOne := self chooseServiceFrom: services.
	^theOne
		ifNotNil: [ExternalDropHandler type: nil extension: nil action: [:stream | theOne performServiceFor: stream]]! !

!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:19'!
registerHandler: aHandler
	self registeredHandlers add: aHandler! !


!ExternalDropHandler class methodsFor: 'class initialization' stamp: 'mir 1/10/2002 17:37'!
initialize
	"ExternalDropHandler initialize"

	self resetRegisteredHandlers.
	self
		registerHandler: self defaultImageHandler;
		registerHandler: self defaultGZipHandler;
		registerHandler: self defaultProjectHandler! !

!ExternalDropHandler class methodsFor: 'class initialization' stamp: 'nk 6/12/2004 16:15'!
registerStandardExternalDropHandlers
	"ExternalDropHandler registerStandardExternalDropHandlers"

	self registeredHandlers add: (
		ExternalDropHandler
			type: 'image/'
			extension: nil
			action: [:stream :pasteUp :event |
				pasteUp addMorph: (World drawingClass withForm: (Form fromBinaryStream: stream binary)) centeredNear: event position])! !


!ExternalDropHandler class methodsFor: 'instance creation' stamp: 'mir 1/10/2002 17:16'!
type: aType extension: anExtension action: anAction 
	^self new type: aType extension: anExtension action: anAction ! !


!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 8/24/2004 15:28'!
chooseServiceFrom: aCollection
	"private - choose a service from aCollection asking the user if  
	needed"
	| menu |
	aCollection size = 1
		ifTrue: [^ aCollection anyOne].
	""
	menu := CustomMenu new.
	aCollection
		do: [:each | menu add: each label action: each].
	^ menu startUp! !

!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 17:23'!
defaultGZipHandler
	^ExternalDropHandler
		type: nil
		extension: 'gz'
		action: [:stream :pasteUp :event |
			stream viewGZipContents]! !

!ExternalDropHandler class methodsFor: 'private' stamp: 'tak 3/13/2005 21:19'!
defaultImageHandler
	| image sketch |
	^ExternalDropHandler
		type: 'image/'
		extension: nil
		action: [:stream :pasteUp :event |
			stream binary.
			image _ Form fromBinaryStream: ((RWBinaryOrTextStream with: stream contents) reset).
			Project current resourceManager 
				addResource: image 
				url: (FileDirectory urlForFileNamed: stream name) asString.
			sketch _ World drawingClass withForm: image.
			pasteUp addMorph: sketch centeredNear: event position.
			image _ sketch _ nil] fixTemps! !

!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 17:38'!
defaultProjectHandler
	^ExternalDropHandler
		type: nil
		extension: 'pr'
		action: [:stream |
				ProjectLoading
					openName: nil
					stream: stream
					fromDirectory: nil
					withProjectView: nil]
! !

!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 15:57'!
registeredHandlers
	RegisteredHandlers ifNil: [RegisteredHandlers _ OrderedCollection new].
	^RegisteredHandlers! !

!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 15:57'!
resetRegisteredHandlers
	RegisteredHandlers _ nil! !

!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 8/24/2004 15:28'!
unwantedSelectors
	"private - answer a collection well known unwanted selectors "
	^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! !
Object subclass: #ExternalSemaphoreTable
	instanceVariableNames: ''
	classVariableNames: 'ProtectTable'
	poolDictionaries: ''
	category: 'System-Support'!
!ExternalSemaphoreTable commentStamp: '<historical>' prior: 0!
By John M McIntosh johnmci@smalltalkconsulting.com
This class was written to mange the external semaphore table. When I was writing a Socket test server I discovered various race conditions on the access to the externalSemaphore table. This new class uses class side methods to restrict access using a mutex semaphore. It seemed cleaner to deligate the reponsibility here versus adding more code and another class variable to SystemDictionary 

Note that in Smalltalk recreateSpecialObjectsArray we still directly play with the table.!


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

ExternalSemaphoreTable class
	instanceVariableNames: ''!

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:36'!
clearExternalObjects
	"Clear the array of objects that have been registered for use in non-Smalltalk code."

	ProtectTable critical: [Smalltalk specialObjectsArray at: 39 put: Array new].
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 21:01'!
externalObjects
	^ProtectTable critical: [Smalltalk specialObjectsArray at: 39].! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:44'!
registerExternalObject: anObject
	^ ProtectTable critical: [self safelyRegisterExternalObject: anObject]
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:57'!
safelyRegisterExternalObject: anObject
	"Register the given object in the external objects array and return its index. If it is already there, just return its index."

	| objects firstEmptyIndex obj sz newObjects |
	objects _ Smalltalk specialObjectsArray at: 39.

	"find the first empty slot"
	firstEmptyIndex _ 0.
	1 to: objects size do: [:i |
		obj _ objects at: i.
		obj == anObject ifTrue: [^ i].  "object already there, just return its index"
		(obj == nil and: [firstEmptyIndex = 0]) ifTrue: [firstEmptyIndex _ i]].

	"if no empty slots, expand the array"
	firstEmptyIndex = 0 ifTrue: [
		sz _ objects size.
		newObjects _ objects species new: sz + 20.  "grow linearly"
		newObjects replaceFrom: 1 to: sz with: objects startingAt: 1.
		firstEmptyIndex _ sz + 1.
		Smalltalk specialObjectsArray at: 39 put: newObjects.
		objects _ newObjects].

	objects at: firstEmptyIndex put: anObject.
	^ firstEmptyIndex
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:59'!
safelyUnregisterExternalObject: anObject
	"Unregister the given object in the external objects array. Do nothing if it isn't registered.
	JMM change to return if we clear the element, since it should only appear once in the array"

	| objects |
	anObject ifNil: [^ self].
	objects _ Smalltalk specialObjectsArray at: 39.
	1 to: objects size do: [:i |
		(objects at: i) == anObject ifTrue: 
		[objects at: i put: nil.
		^self]].
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:45'!
unregisterExternalObject: anObject
	ProtectTable critical: [self safelyUnregisterExternalObject: anObject]
! !


!ExternalSemaphoreTable class methodsFor: 'initialize' stamp: 'JMM 6/6/2000 20:32'!
initialize
	ProtectTable _ Semaphore forMutualExclusion! !
Object subclass: #ExternalSettings
	instanceVariableNames: ''
	classVariableNames: 'RegisteredClients'
	poolDictionaries: ''
	category: 'System-Support'!
!ExternalSettings commentStamp: '<historical>' prior: 0!
ExternalSettings manages settings kept externally, e.g. files.
Objects can register themselves as clients to be notified at startup time to read their settings.

Eventually all the preferences should be managed through this mechanism.
!


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

ExternalSettings class
	instanceVariableNames: ''!

!ExternalSettings class methodsFor: 'accessing' stamp: 'sw 1/25/2002 12:39'!
assuredPreferenceDirectory
	"Answer the preference directory, creating it if necessary"

	|  prefDir |
	prefDir _ self preferenceDirectory.
	prefDir
		ifNil:
			[prefDir _ FileDirectory default directoryNamed: self preferenceDirectoryName.
			prefDir assureExistence].
	^ prefDir! !

!ExternalSettings class methodsFor: 'accessing' stamp: 'mir 8/23/2002 14:22'!
parseServerEntryArgsFrom: stream
	"Args are in the form <argName>: <argValueString> delimited by end of line.
	It's not a very robust format and should be replaced by something like XML later.
	But it avoids evaluating the entries for security reasons."

	| entries lineStream entryName entryValue |
	entries _ Dictionary new.
	stream skipSeparators.
	[stream atEnd]
		whileFalse: [
			lineStream _ ReadStream on: stream nextLine.
			entryName _ lineStream upTo: $:.
			lineStream skipSeparators.
			entryValue _ lineStream upToEnd.
			(entryName isEmptyOrNil 
				or: [entryValue isEmptyOrNil])
				ifFalse: [entries at: entryName put: entryValue withoutTrailingBlanks].
			stream skipSeparators].
	^entries! !

!ExternalSettings class methodsFor: 'accessing' stamp: 'sd 9/30/2003 14:01'!
preferenceDirectory
	| prefDirName path |
	prefDirName := self preferenceDirectoryName.
	path := SmalltalkImage current vmPath.
	^(FileDirectory default directoryExists: prefDirName)
		ifTrue: [FileDirectory default directoryNamed: prefDirName]
		ifFalse: [
			((FileDirectory on: path) directoryExists: prefDirName)
				ifTrue: [(FileDirectory on: path) directoryNamed: prefDirName]
				ifFalse: [nil]]
! !

!ExternalSettings class methodsFor: 'accessing' stamp: 'mir 11/16/2001 13:33'!
preferenceDirectoryName
	^'prefs'! !

!ExternalSettings class methodsFor: 'accessing' stamp: 'mir 6/25/2001 18:45'!
registerClient: anObject
	"Register anObject as a settings client to be notified on startup."

	self registeredClients add: anObject! !


!ExternalSettings class methodsFor: 'class initialization' stamp: 'ar 8/23/2001 22:56'!
initialize
	"ExternalSettings initialize"
	"Order: ExternalSettings, SecurityManager, AutoStart"
	Smalltalk addToStartUpList: self.
	Smalltalk addToShutDownList: self! !

!ExternalSettings class methodsFor: 'class initialization' stamp: 'mir 8/22/2001 15:17'!
shutDown
	"Look for external defs and load them."
	"ExternalSettings shutDown"

	self registeredClients do: [:client | 
		client releaseExternalSettings]! !

!ExternalSettings class methodsFor: 'class initialization' stamp: 'mir 11/16/2001 13:29'!
startUp
	"Look for external defs and load them."
	"ExternalSettings startUp"

	| prefDir |
	prefDir _ self preferenceDirectory.
	prefDir
		ifNil: [^self].
	self registeredClients do: [:client | 
		client fetchExternalSettingsIn: prefDir]! !


!ExternalSettings class methodsFor: 'private' stamp: 'mir 6/25/2001 18:46'!
registeredClients
	RegisteredClients ifNil: [RegisteredClients _ Set new].
	^RegisteredClients! !
Inspector subclass: #ExternalStructureInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!ExternalStructureInspector methodsFor: 'accessing' stamp: 'hg 2/28/2000 14:20'!
fieldList
	^  (Array with: 'self: ', object defaultLabelForInspector with: 'all inst vars'), self recordFieldList! !

!ExternalStructureInspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
recordFieldList
	| fields |
	fields := object class fields.
	(fields first isKindOf: Array) ifFalse: [fields := Array with: fields].
	^fields collect: [ :field | field first ] thenSelect: [:name | name notNil]! !


!ExternalStructureInspector methodsFor: 'selecting' stamp: 'hg 2/28/2000 14:12'!
replaceSelectionValue: anObject 
	"Add colon to fieldname to get setter selector, and send it to object with the argument.
	 Refer to the comment in Inspector|replaceSelectionValue:."

	selectionIndex = 1
		ifTrue: [^object]
		ifFalse: [^object perform: ((self fieldList at: selectionIndex), ':') asSymbol with: anObject]! !

!ExternalStructureInspector methodsFor: 'selecting' stamp: 'hg 2/28/2000 14:22'!
selection 
	"Refer to the comment in Inspector|selection."
	selectionIndex = 0 ifTrue:[^object printString].
	selectionIndex = 1 ifTrue: [^object].
	selectionIndex = 2 ifTrue:[^object longPrintString].
	selectionIndex > 2
		ifTrue: [^object perform: (self fieldList at: selectionIndex)]! !
EllipseMorph subclass: #EyeMorph
	instanceVariableNames: 'iris'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Gestures'!

!EyeMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 15:40'!
iris
	^ iris! !


!EyeMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:25'!
closeEyelid
	self iris delete.
	self position: self position + (0 @ (self extent y // 2)).
	self extent: self extent x @ 2! !

!EyeMorph methodsFor: 'actions' stamp: 'stephaneducasse 2/3/2006 22:22'!
dilate: amount
	| irisCenter |
	irisCenter := self iris center.
	self iris extent: self iris extent * amount.
	self iris position: irisCenter - self iris center + self iris position! !

!EyeMorph methodsFor: 'actions' stamp: 'stephaneducasse 2/3/2006 22:22'!
lookAt: aPoint
	| theta scale |
	(self containsPoint: aPoint) ifTrue: [self iris align: iris center with: aPoint. ^ self].
	theta := (aPoint - self center) theta.
	scale := (aPoint - self center) r / 100.0 min: 1.0.
	self iris align: self iris center with: self center + (theta cos @ theta sin * self extent / 3.0 * scale) rounded! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:03'!
lookAtFront
	self iris position: self center - self iris center + self iris position! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:23'!
lookAtMorph: aMorph
	self lookAt: aMorph center! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/23/1999 22:49'!
openEyelid
	self extent: self extent x @ (self extent x * 37.0 / 30.0) rounded.
	self position: self position - (0 @ (self extent y // 2)).
	self addMorphFront: self iris! !

!EyeMorph methodsFor: 'actions' stamp: 'stephaneducasse 2/3/2006 22:22'!
openness: aNumber
	| previousCenter |
	previousCenter := self center.
	self extent: self extent x @ (self extent x * 37.0 / 30.0 * aNumber) rounded.
	self align: self center with: previousCenter.
	(self containsPoint: self iris center) ifFalse: [self lookAtFront]! !


!EyeMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:24'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 1.0
		g: 0.968
		b: 0.935! !

!EyeMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self extent: 30 @ 37.
	self addMorphFront: (iris := EllipseMorph new extent: 6 @ 6;
					 borderWidth: 0;
					 color: Color black).
	self lookAtFront! !
UtteranceVisitor subclass: #F0RenderingVisitor
	instanceVariableNames: 'pitch range contour'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!F0RenderingVisitor methodsFor: 'accessing' stamp: 'len 12/13/1999 03:47'!
highPitch
	^ pitch + (pitch * range)! !

!F0RenderingVisitor methodsFor: 'accessing' stamp: 'len 12/13/1999 03:47'!
lowPitch
	^ pitch - (pitch * range)! !

!F0RenderingVisitor methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
timeForEvent: aVoiceEvent
	| time |
	time := 0.
	clause eventsDo: [ :each | aVoiceEvent == each ifTrue: [^ time] ifFalse: [time := time + each duration]]! !


!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'len 12/14/1999 02:27'!
boundaryStartTime
	^ self timeForEvent: (phrase ifNil: [clause phrases last]) words last events first! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'stephaneducasse 2/3/2006 22:22'!
boundaryStopTime
	| lastEvent |
	lastEvent := (phrase ifNil: [clause phrases last]) lastSyllable events last.
	^ (self timeForEvent: lastEvent) + lastEvent duration! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialStopTime
	| lastEvent |
	lastEvent := 	clause phrases first words first lastSyllable events last.
	^ (self timeForEvent: lastEvent) + lastEvent duration! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'stephaneducasse 2/3/2006 22:22'!
renderHighBoundary
	"Render a H% boundary tone."
	| start stop |
	start := self boundaryStartTime.
	stop := self boundaryStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: self highPitch - (contour at: start)
		duration: stop - start
		peakPosition: stop - start
		tilt: 1.0! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'stephaneducasse 2/3/2006 22:22'!
renderHighInitial
	"Render a %H tone."
	| start stop |
	start := 0.
	stop := self initialStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: self highPitch - (contour at: start) * 2
		duration: stop - start
		peakPosition: start
		tilt: 0.0! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'stephaneducasse 2/3/2006 22:22'!
renderLowBoundary
	"Render a L% boundary tone."
	| start stop |
	start := self boundaryStartTime.
	stop := self boundaryStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: (contour at: start) - self lowPitch
		duration: stop - start
		peakPosition: stop - start
		tilt: -1.0! !


!F0RenderingVisitor methodsFor: 'rendering-phrase accents' stamp: 'stephaneducasse 2/3/2006 22:22'!
phraseAccentStartTime
	| syl |
	syl := nil.
	(phrase ifNil: [clause phrases last]) syllablesDo: [ :each | (syl isNil or: [syl isAccented]) ifTrue: [syl := each]].
	^ self timeForEvent: syl events last! !

!F0RenderingVisitor methodsFor: 'rendering-phrase accents' stamp: 'stephaneducasse 2/3/2006 22:22'!
phraseAccentStopTime
	| lastEvent |
	lastEvent := (phrase ifNil: [clause phrases last]) lastSyllable events last.
	^ (self timeForEvent: lastEvent) + lastEvent duration! !

!F0RenderingVisitor methodsFor: 'rendering-phrase accents' stamp: 'stephaneducasse 2/3/2006 22:22'!
renderHighPhraseAccent
	"Render a H- accent."
	| start stop |
	start := self phraseAccentStartTime.
	stop := self phraseAccentStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: self highPitch - (contour at: start)
		duration: stop - start
		peakPosition: stop - start
		tilt: 1.0! !

!F0RenderingVisitor methodsFor: 'rendering-phrase accents' stamp: 'stephaneducasse 2/3/2006 22:22'!
renderLowPhraseAccent
	"Render a L- accent."
	| start stop |
	start := self phraseAccentStartTime.
	stop := self phraseAccentStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: (contour at: start) - self lowPitch
		duration: stop - start
		peakPosition: stop - start
		tilt: -0.5! !


!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'stephaneducasse 2/3/2006 22:22'!
renderLowAccent
	"Render a L* accent."
	| start stop peakPosition |
	start := self syllableStartTime.
	stop := self syllableStopTime.
	peakPosition := (syllable events detect: [ :one | one phoneme isSyllabic] ifNone: [syllable events first]) duration / 2.0.
	self time: start
		startingF0: (contour at: start)
		amplitude: (contour at: start) - self lowPitch
		duration: stop - start
		peakPosition: peakPosition
		tilt: 0.0! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'stephaneducasse 2/3/2006 22:22'!
renderPeakAccent
	"Render a H* accent."
	| start stop peakPosition |
	start := self syllableStartTime.
	stop := self syllableStopTime.
	peakPosition := (syllable events detect: [ :one | one phoneme isSyllabic] ifNone: [syllable events first]) duration / 2.0.
	self time: start
		startingF0: (contour at: start)
		amplitude: self highPitch - (contour at: start)
		duration: stop - start
		peakPosition: peakPosition
		tilt: 0.0! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 01:44'!
renderRisingPeakAccent
	"Render a L+H* accent."

	self notYetImplemented! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 01:45'!
renderScoopedAccent
	"Render a L*+H accent."

	self notYetImplemented! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 01:43'!
syllableStartTime
	^ self timeForEvent: syllable events first! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 01:43'!
syllableStopTime
	^ self syllableStartTime + syllable events duration! !


!F0RenderingVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:22'!
clause: aClause
	contour := CosineInterpolator new at: 0 put: pitch; yourself.

	super clause: aClause.
	self renderPhraseAccentOrBoundaryTone: clause accent.

	self assignF0ToEvents! !

!F0RenderingVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 02:31'!
phrase: aPhrase
	super phrase: aPhrase.

	self renderPhraseAccentOrBoundaryTone: phrase accent! !

!F0RenderingVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 02:41'!
renderPhraseAccentOrBoundaryTone: aStringOrNil
	aStringOrNil isNil ifTrue: [^ self].
	(aStringOrNil findTokens: ' ') do: [ :each |
		each = 'H-' ifTrue: [self renderHighPhraseAccent].
		each = 'L-' ifTrue: [self renderLowPhraseAccent].
		each = 'H%' ifTrue: [self renderHighBoundary].
		each = 'L%' ifTrue: [self renderLowBoundary].
		each = '%H' ifTrue: [self renderHighInitial].
		each = '%r' ifTrue: [self notYetImplemented]]! !

!F0RenderingVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:22'!
speaker: aSpeaker
	pitch := aSpeaker pitch.
	range := aSpeaker range! !

!F0RenderingVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 02:41'!
syllable: aSyllable
	super syllable: aSyllable.

	aSyllable isAccented ifFalse: [^ self].
	aSyllable accent = 'H*' ifTrue: [^ self renderPeakAccent].
	aSyllable accent = 'L*' ifTrue: [^ self renderLowAccent].
	aSyllable accent = 'L*+H' ifTrue: [^ self renderScoopedAccent].
	aSyllable accent = 'L+H*' ifTrue: [^ self renderRisingPeakAccent]! !


!F0RenderingVisitor methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
assignF0ToEvents
	| time |
	time := 0.
	clause events do: [ :each |
		each pitchPoints: (self pitchesBetween: time and: time + each duration).
		time := time + each duration]! !

!F0RenderingVisitor methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
pitchesBetween: t1 and: t2
	| step |
	step := (t2 - t1 / 0.035) asInteger + 1. "step small enough"
	^ (t1 to: t2 by: t2 - t1 / step) collect: [ :each | each - t1 @ (contour at: each)]! !

!F0RenderingVisitor methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
time: time startingF0: startingF0 amplitude: amplitude duration: duration peakPosition: peakPosition tilt: tilt
	| vowelStart riseAmplitude fallAmplitude |
	vowelStart := self timeOfFirstVowelAfter: time.
	riseAmplitude := tilt + 1.0 * amplitude / 2.0.
	fallAmplitude := amplitude - riseAmplitude.
	contour
		x: time y: startingF0;
		x: vowelStart + peakPosition y: ((startingF0 + riseAmplitude max: self lowPitch) min: self highPitch);
		x: time + duration y: ((startingF0 + riseAmplitude - fallAmplitude max: self lowPitch) min: self highPitch);
		commit! !

!F0RenderingVisitor methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
timeOfFirstVowelAfter: time
	| currentTime |
	currentTime := 0.
	clause events do: [ :each |
		(currentTime >= time and: [each phoneme isSyllabic]) ifTrue: [^ currentTime].
		currentTime := currentTime + each duration].
	^ time "if not found, answer the time itself"! !

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

F0RenderingVisitor class
	instanceVariableNames: ''!

!F0RenderingVisitor class methodsFor: 'examples' stamp: 'len 12/13/1999 02:25'!
default
	^ self new! !
Object subclass: #FFT
	instanceVariableNames: 'nu n sinTable permTable realData imagData window'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!FFT commentStamp: '<historical>' prior: 0!
This class implements the Fast Fourier Transform roughly as described on page 367
of "Theory and Application of Digital Signal Processing" by Rabiner and Gold.
Each instance caches tables used for transforming a given size (n = 2^nu samples) of data.

It would have been cleaner using complex numbers, but often the data is all real.!


!FFT methodsFor: 'bulk processing' stamp: 'stephaneducasse 2/4/2006 20:41'!
initializeHammingWindow: alpha
	"Initialize the windowing function to the generalized Hamming window. See F. Richard Moore, Elements of Computer Music, p. 100. An alpha of 0.54 gives the Hamming window, 0.5 gives the hanning window."

	| v midPoint |
	window := FloatArray new: n.
	midPoint := (n + 1) / 2.0.
	1 to: n do: [:i |
		v := alpha + ((1.0 - alpha) * (2.0 * Float pi * ((i - midPoint) / n)) cos).
		window at: i put: v].

! !

!FFT methodsFor: 'bulk processing' stamp: 'stephaneducasse 2/4/2006 20:41'!
initializeTriangularWindow
	"Initialize the windowing function to the triangular, or Parzen, window. See F. Richard Moore, Elements of Computer Music, p. 100."

	| v |
	window := FloatArray new: n.
	0 to: (n // 2) - 1 do: [:i |
		v := i / ((n // 2) - 1).
		window at: (i + 1) put: v.
		window at: (n - i) put: v].
! !

!FFT methodsFor: 'bulk processing' stamp: 'stephaneducasse 2/4/2006 20:41'!
setSize: anIntegerPowerOfTwo
	"Initialize variables and tables for performing an FFT on the given number of samples. The number of samples must be an integral power of two (e.g. 1024). Prepare data for use with the fast primitive."

	self nu: (anIntegerPowerOfTwo log: 2) asInteger.
	n = anIntegerPowerOfTwo ifFalse: [self error: 'size must be a power of two'].
	sinTable := sinTable asFloatArray.
	permTable := permTable asWordArray.
	realData := FloatArray new: n.
	imagData := FloatArray new: n.
	self initializeHammingWindow: 0.54.  "0.54 for Hamming, 0.5 for hanning"
! !

!FFT methodsFor: 'bulk processing' stamp: 'stephaneducasse 2/4/2006 20:41'!
transformDataFrom: anIndexableCollection startingAt: index
	"Forward transform a block of real data taken from from the given indexable collection starting at the given index. Answer a block of values representing the normalized magnitudes of the frequency components."

	| j real imag out |
	j := 0.
	index to: index + n - 1 do: [:i |
		realData at: (j := j + 1) put: (anIndexableCollection at: i)].
	realData *= window.
	imagData := FloatArray new: n.
	self pluginTransformData: true.

	"compute the magnitudes of the complex results"
	"note: the results are in bottom half; the upper half is just its mirror image"
	real := realData copyFrom: 1 to: (n / 2).
	imag := imagData copyFrom: 1 to: (n / 2).
	out := (real * real) + (imag * imag).
	1 to: out size do: [:i | out at: i put: (out at: i) sqrt].
	^ out
! !


!FFT methodsFor: 'initialization' stamp: 'jm 8/25/1999 21:59'!
n

	^ n
! !

!FFT methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
nu: order
	"Initialize variables and tables for transforming 2^nu points"
	|  j perms k |
	nu := order.
	n := 2 bitShift: nu-1.

	"Initialize permutation table (bit-reversed indices)"
	j:=0.
	perms := WriteStream on: (Array new: n).
	0 to: n-2 do:
		[:i |
		i < j ifTrue: [perms nextPut: i+1; nextPut: j+1].
		k := n // 2.
		[k <= j] whileTrue: [j := j-k.  k := k//2].
		j := j + k].
	permTable := perms contents.

	"Initialize sin table 0..pi/2 in n/4 steps."
	sinTable := (0 to: n/4) collect: [:i | (i asFloat / (n//4) * Float pi / 2.0) sin]! !

!FFT methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
realData: real
	realData := real.
	imagData := real collect: [:i | 0.0]  "imaginary component all zero"! !

!FFT methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
realData: real imagData: imag
	realData := real.
	imagData := imag! !


!FFT methodsFor: 'plugin-testing' stamp: 'stephaneducasse 2/4/2006 20:41'!
pluginPrepareData
	"The FFT plugin requires data to be represented in WordArrays or FloatArrays"
	sinTable := sinTable asFloatArray.
	permTable := permTable asWordArray.
	realData := realData asFloatArray.
	imagData := imagData asFloatArray.! !

!FFT methodsFor: 'plugin-testing' stamp: 'ar 10/10/1998 21:53'!
pluginTest  "Display restoreAfter: [(FFT new nu: 12) pluginTest]."
	"Test on an array of 256 samples"
	"Initialize to pure (co)Sine Wave, plot, transform, plot, invert and plot again"
	self realData: ((1 to: n) collect: [:i | (Float pi * (i-1) / (n/8)) cos]).
	self plot: realData in: (100@20 extent: 256@60).
	self pluginPrepareData.
	Transcript cr; print: (Time millisecondsToRun:[self pluginTransformData: true]); endEntry.
	self plot: realData in: (100@100 extent: 256@60).
	self plot: imagData in: (100@180 extent: 256@60).
	Transcript cr; print: (Time millisecondsToRun:[self pluginTransformData: false]); endEntry.
	self plot: realData in: (100@260 extent: 256@60)! !

!FFT methodsFor: 'plugin-testing' stamp: 'ar 2/13/2001 21:10'!
pluginTransformData: forward
	"Plugin testing -- if the primitive is not implemented 
	or cannot be found run the simulation. See also: FFTPlugin"
	<primitive: 'primitiveFFTTransformData' module: 'FFTPlugin'>
	^(Smalltalk at: #FFTPlugin ifAbsent:[^self primitiveFailed])
		doPrimitive: 'primitiveFFTTransformData'.! !


!FFT methodsFor: 'testing' stamp: 'jm 8/1/1998 13:08'!
imagData

	^ imagData
! !

!FFT methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:41'!
plot: samples in: rect
	"Throw-away code just to check out a couple of examples"
	| min max x dx pen y |
	Display fillWhite: rect; border: (rect expandBy: 2) width: 2.
	min := 1.0e30.  max := -1.0e30.
	samples do:
		[:v |
		min := min min: v.
		max := max max: v].
	pen := Pen new.  pen up.
	x := rect left.
	dx := rect width asFloat / samples size.
	samples do:
		[:v |
		y := (max-v) / (max-min) * rect height asFloat.
		pen goto: x asInteger @ (rect top + y asInteger).
		pen down.
		x := x + dx].
	max printString displayOn: Display at: (x+2) @ (rect top-9).
	min printString displayOn: Display at: (x+2) @ (rect bottom - 9)! !

!FFT methodsFor: 'testing' stamp: 'jm 8/1/1998 13:08'!
realData

	^ realData
! !

!FFT methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:41'!
samplesPerCycleForIndex: i
	"Answer the number of samples per cycle corresponding to a power peak at the given index. Answer zero if i = 1, since an index of 1 corresponds to the D.C. component."

	| windowSize |
	windowSize := 2 raisedTo: nu.
	(i < 1 or: [i > (windowSize // 2)]) ifTrue: [^ self error: 'index is out of range'].
	i = 1 ifTrue: [^ 0].  "the D.C. component"
	^ windowSize asFloat / (i - 1)
! !

!FFT methodsFor: 'testing' stamp: 'di 6/17/97 07:47'!
test  "Display restoreAfter: [(FFT new nu: 8) test].  --  Test on an array of 256 samples"
	"Initialize to pure (co)Sine Wave, plot, transform, plot, invert and plot again"
	self realData: ((1 to: n) collect: [:i | (Float pi * (i-1) / (n/8)) cos]).
	self plot: realData in: (100@20 extent: 256@60).
	self transformForward: true.
	self plot: realData in: (100@100 extent: 256@60).
	self plot: imagData in: (100@180 extent: 256@60).
	self transformForward: false.
	self plot: realData in: (100@260 extent: 256@60)! !


!FFT methodsFor: 'transforming' stamp: 'stephaneducasse 2/4/2006 20:41'!
permuteData
	| i end a b |
	i := 1.
	end := permTable size.
	[i <= end] whileTrue:
		[a := permTable at: i.
		b := permTable at: i+1.
		realData swap: a with: b.
		imagData swap: a with: b.
		i := i + 2]! !

!FFT methodsFor: 'transforming' stamp: 'stephaneducasse 2/4/2006 20:41'!
scaleData
	"Scale all elements by 1/n when doing inverse"
	| realN |
	realN := n asFloat.
	1 to: n do:
		[:i |
		realData at: i put: (realData at: i) / realN.
		imagData at: i put: (imagData at: i) / realN]! !

!FFT methodsFor: 'transforming' stamp: 'stephaneducasse 2/4/2006 20:41'!
transformForward: forward
	| lev lev1 ip theta realU imagU realT imagT i |
	self permuteData.
	1 to: nu do:
		[:level |
		lev := 1 bitShift: level.
		lev1 := lev // 2.
		1 to: lev1 do:
			[:j |
			theta := j-1 * (n // lev).   "pi * (j-1) / lev1 mapped onto 0..n/2"
			theta < (n//4)  "Compute U, the complex multiplier for each level"
				ifTrue:
					[realU := sinTable at: sinTable size - theta.
					imagU := sinTable at: theta + 1]
				ifFalse:
					[realU := (sinTable at: theta - (n//4) + 1) negated.
					imagU := sinTable at: (n//2) - theta + 1].
			forward ifFalse: [imagU := imagU negated].
"
			Here is the inner loop...
			j to: n by: lev do:
				[:i |   hand-transformed to whileTrue...
"
			i := j.
			[i <= n] whileTrue:
				[ip := i + lev1.
				realT := ((realData at: ip) * realU) - ((imagData at: ip) * imagU).
				imagT := ((realData at: ip) * imagU) + ((imagData at: ip) * realU).
				realData at: ip put: (realData at: i) - realT.
				imagData at: ip put: (imagData at: i) - imagT.
				realData at: i put: (realData at: i) + realT.
				imagData at: i put: (imagData at: i) + imagT.
				i := i + lev]]].
	forward ifFalse: [self scaleData]  "Reverse transform must scale to be an inverse"! !

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

FFT class
	instanceVariableNames: ''!

!FFT class methodsFor: 'instance creation' stamp: 'jm 8/25/1999 12:49'!
new: anIntegerPowerOfTwo
	"Answer a new FFT instance for transforming data packets of the given size."

	^ self new setSize: anIntegerPowerOfTwo
! !
FMSound subclass: #FMBassoonSound
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!FMBassoonSound methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
setPitch: pitchNameOrNumber dur: d loudness: l
	"Select a modulation ratio and modulation envelope scale based on my pitch."

	| p modScale |
	p := self nameOrNumberToPitch: pitchNameOrNumber.
	modScale := 9.4.
	p > 100.0 ifTrue: [modScale := 8.3].
	p > 150.0 ifTrue: [modScale := 6.4].
	p > 200.0 ifTrue: [modScale := 5.2].
	p > 300.0 ifTrue: [modScale := 3.9].
	p > 400.0 ifTrue: [modScale := 2.8].
	p > 600.0 ifTrue: [modScale := 1.7].

	envelopes size > 0 ifTrue: [
		envelopes do: [:e |
			(e updateSelector = #modulation:)
				ifTrue: [e scale: modScale]]].

	super setPitch: p dur: d loudness: l.
! !
FMSound subclass: #FMClarinetSound
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!FMClarinetSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setPitch: pitchNameOrNumber dur: d loudness: l
	"Select a modulation ratio and modulation envelope scale based on my pitch."

	| p modScale |
	p := self nameOrNumberToPitch: pitchNameOrNumber.
	p < 262.0
		ifTrue: [modScale := 25.0. self ratio: 4]
		ifFalse: [modScale := 20.0. self ratio: 2].
	p > 524.0 ifTrue: [modScale := 8.0].

	envelopes size > 0 ifTrue: [
		envelopes do: [:e |
			(e updateSelector = #modulation:)
				ifTrue: [e scale: modScale]]].

	super setPitch: p dur: d loudness: l.
! !
AbstractSound subclass: #FMSound
	instanceVariableNames: 'initialCount count waveTable scaledWaveTableSize scaledIndex scaledIndexIncr modulation multiplier normalizedModulation scaledOffsetIndex scaledOffsetIndexIncr'
	classVariableNames: 'SineTable'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!FMSound methodsFor: 'accessing' stamp: 'jm 3/26/98 10:45'!
duration

	^ initialCount asFloat / self samplingRate asFloat
! !

!FMSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration: seconds

	super duration: seconds.
	count := initialCount := (seconds * self samplingRate) rounded.
! !

!FMSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
internalizeModulationAndRatio
	"Recompute the internal state for the modulation index and frequency ratio relative to the current pitch."

	modulation < 0.0 ifTrue: [modulation := modulation negated].
	multiplier < 0.0 ifTrue: [multiplier := multiplier negated].
	normalizedModulation :=
		((modulation * scaledIndexIncr)  / ScaleFactor) asInteger.
	scaledOffsetIndexIncr := (multiplier * scaledIndexIncr) asInteger.

	"clip to maximum values if necessary"
	normalizedModulation > MaxScaledValue ifTrue: [
		normalizedModulation := MaxScaledValue.
		modulation := (normalizedModulation * ScaleFactor) asFloat / scaledIndexIncr].
	scaledOffsetIndexIncr > (scaledWaveTableSize // 2) ifTrue: [
		scaledOffsetIndexIncr := scaledWaveTableSize // 2.
		multiplier := scaledOffsetIndexIncr asFloat / scaledIndexIncr].
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:15'!
modulation
	"Return the FM modulation index."

	^ modulation
! !

!FMSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
modulation: mod
	"Set the FM modulation index. Typical values range from 0 (no modulation) to 5, although values up to about 10 are sometimes useful."
	"Warning: This method is intended primarily for use by envelopes. For efficiency during envelope processing, this change will not take effect until internalizeModulationAndRatio is called."

	modulation := mod asFloat.
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:39'!
modulation: mod multiplier: freqRatio
	"For backward compatibility. Needed to read old .fmp files."

	self modulation: mod ratio: freqRatio.
! !

!FMSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
modulation: mod ratio: freqRatio
	"Set the modulation index and carrier to modulation frequency ratio for this sound, and compute the internal state that depends on these parameters."

	modulation := mod asFloat.
	multiplier := freqRatio asFloat.
	self internalizeModulationAndRatio.
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 12/17/97 18:05'!
multiplier

	^ multiplier
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 8/7/1998 15:45'!
pitch

	^ (self samplingRate asFloat * scaledIndexIncr / ScaleFactor) asFloat / waveTable size
! !

!FMSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
pitch: p
	"Warning: Since the modulation and ratio are relative to the current pitch, some internal state must be recomputed when the pitch is changed. However, for efficiency during envelope processing, this compuation will not be done until internalizeModulationAndRatio is called."

	scaledIndexIncr :=
		((p asFloat * waveTable size asFloat * ScaleFactor asFloat) / self samplingRate asFloat) asInteger
			min: (waveTable size // 2) * ScaleFactor.
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:08'!
ratio
	"Return the FM modulation to carrier frequency ratio."

	^ multiplier
! !

!FMSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
ratio: freqRatio
	"Set the FM modulation to carrier frequency ratio."
	"Warning: This method is intended primarily for use by envelopes. For efficiency during envelope processing, this change will not take effect until internalizeModulationAndRatio is called."

	multiplier := freqRatio asFloat.
! !


!FMSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	super initialize.
	waveTable := SineTable.
	scaledWaveTableSize := waveTable size * ScaleFactor.
	self setPitch: 440.0 dur: 1.0 loudness: 0.2.
! !

!FMSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setPitch: pitchNameOrNumber dur: d loudness: vol
	"(FMSound pitch: 'a4' dur: 2.5 loudness: 0.4) play"

	super setPitch: pitchNameOrNumber dur: d loudness: vol.
	modulation ifNil: [modulation := 0.0].
	multiplier ifNil: [multiplier := 0.0].
	self pitch: (self nameOrNumberToPitch: pitchNameOrNumber).
	self reset.
! !

!FMSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setWavetable: anArray
	"(AbstractSound lowMajorScaleOn: (FMSound new setWavetable: AA)) play"

	| samples p dur vol |
	"copy the array into a SoundBuffer if necessary"
	anArray class isPointers
		ifTrue: [samples := SoundBuffer fromArray: anArray]
		ifFalse: [samples := anArray].

	p := self pitch.
	dur := self duration.
	vol := self loudness.
	waveTable := samples.
	scaledWaveTableSize := waveTable size * ScaleFactor.
	self setPitch: p dur: dur loudness: vol.
! !


!FMSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy."
	"(FMSound pitch: 440.0 dur: 1.0 loudness: 0.5) play"

	| doingFM lastIndex sample offset i s |
	<primitive:'primitiveMixFMSound' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #waveTable declareC: 'short int *waveTable'.

	doingFM := (normalizedModulation ~= 0) and: [scaledOffsetIndexIncr ~= 0].
	lastIndex := (startIndex + n) - 1.
	startIndex to: lastIndex do: [:sliceIndex |
		sample := (scaledVol * (waveTable at: (scaledIndex // ScaleFactor) + 1)) // ScaleFactor.
		doingFM
			ifTrue: [
				offset := normalizedModulation * (waveTable at: (scaledOffsetIndex // ScaleFactor) + 1).
				scaledOffsetIndex := (scaledOffsetIndex + scaledOffsetIndexIncr) \\ scaledWaveTableSize.
				scaledOffsetIndex < 0
					ifTrue: [scaledOffsetIndex := scaledOffsetIndex + scaledWaveTableSize].
				scaledIndex := (scaledIndex + scaledIndexIncr + offset) \\ scaledWaveTableSize.
				scaledIndex < 0
					ifTrue: [scaledIndex := scaledIndex + scaledWaveTableSize]]
			ifFalse: [
				scaledIndex := (scaledIndex + scaledIndexIncr) \\ scaledWaveTableSize].

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

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

	count := count - n.
! !

!FMSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset

	self internalizeModulationAndRatio.
	super reset.
	count := initialCount.
	scaledIndex := 0.
	scaledOffsetIndex := 0.
! !

!FMSound methodsFor: 'sound generation' stamp: 'jm 12/8/97 19:34'!
samplesRemaining

	^ count
! !

!FMSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds."

	count := (mSecs * self samplingRate) // 1000.
! !


!FMSound methodsFor: 'storing' stamp: 'stephaneducasse 2/4/2006 20:41'!
storeOn: strm
	| env |
	strm nextPutAll: '(((FMSound';
		nextPutAll: ' pitch: '; print: self pitch;
		nextPutAll: ' dur: '; print: self duration;
		nextPutAll: ' loudness: '; print: self loudness; nextPutAll: ')';
		nextPutAll: ' modulation: '; print: self modulation;
		nextPutAll: ' ratio: '; print: self ratio; nextPutAll: ')'.
	1 to: envelopes size do:
		[:i | env := envelopes at: i.
		strm cr; nextPutAll: '    addEnvelope: '. env storeOn: strm.
		i < envelopes size ifTrue: [strm nextPutAll: ';']].
	strm  nextPutAll: ')'.
! !

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

FMSound class
	instanceVariableNames: ''!

!FMSound class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"Build a sine wave table."
	"FMSound initialize"

	| tableSize radiansPerStep peak |
	tableSize := 4000.
	SineTable := SoundBuffer newMonoSampleCount: tableSize.
	radiansPerStep := (2.0 * Float pi) / tableSize asFloat.
	peak := ((1 bitShift: 15) - 1) asFloat.  "range is +/- (2^15 - 1)"
	1 to: tableSize do: [:i |
		SineTable at: i put: (peak * (radiansPerStep * (i - 1)) sin) rounded].
! !

!FMSound class methodsFor: 'class initialization' stamp: 'jm 7/5/1998 14:22'!
sineTable
	"Answer a SoundBuffer containing one complete cycle of a sine wave."

	^ SineTable
! !


!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
bass1
	"FMSound bass1 play"
	"(FMSound lowMajorScaleOn: FMSound bass1) play"

	| snd |
	snd := FMSound new modulation: 0 ratio: 0.
	snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.95).
	^ snd setPitch: 220 dur: 1.0 loudness: 0.3
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
bassoon1
	"FMSound bassoon1 play"
	"(FMSound lowMajorScaleOn: FMSound bassoon1) play"

	| snd p env |
	snd := FMBassoonSound new ratio: 1.

	p := OrderedCollection new.
	p add: 0@0.0; add: 40@0.45; add: 90@1.0; add: 180@0.9; add: 270@1.0; add: 320@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).

	p := OrderedCollection new.
	p add: 0@0.2; add: 40@0.9; add: 90@0.6; add: 270@0.6; add: 320@0.5.
	env := Envelope points: p loopStart: 3 loopEnd: 4.
	env updateSelector: #modulation:; scale: 5.05.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
brass1
	"FMSound brass1 play"
	"(FMSound lowMajorScaleOn: FMSound brass1) play"

	| snd p env |
	snd := FMSound new modulation: 0 ratio: 1.
	p := OrderedCollection new.
	p add: 0@0.0; add: 30@0.8; add: 90@1.0; add: 120@0.9; add: 220@0.7; add: 320@0.9; add: 360@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6).

	p := OrderedCollection new.
	p add: 0@0.5; add: 60@1.0; add: 120@0.8; add: 220@0.65; add: 320@0.8; add: 360@0.0.
	env := Envelope points: p loopStart: 3 loopEnd: 5.
	env target: snd; updateSelector: #modulation:; scale: 5.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
brass2
	"FMSound brass2 play"
	"(FMSound lowMajorScaleOn: FMSound brass2) play"

	| snd p env |
	snd := FMSound new modulation: 1 ratio: 1.

	p := OrderedCollection new.
	p add: 0@0.0; add: 20@1.0; add: 40@0.9; add: 100@0.7; add: 160@0.9; add: 200@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).

	p := OrderedCollection new.
	p add: 0@0.5; add: 30@1.0; add: 40@0.8; add: 100@0.7; add: 160@0.8; add: 200@0.0.
	env := Envelope points: p loopStart: 3 loopEnd: 5.
	env updateSelector: #modulation:; scale: 5.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
clarinet
	"FMSound clarinet play"
	"(FMSound lowMajorScaleOn: FMSound clarinet) play"

	| snd p env |
	snd := FMSound new modulation: 0 ratio: 2.

	p := OrderedCollection new.
	p add: 0@0.0; add: 60@1.0; add: 310@1.0; add: 350@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).

	p := OrderedCollection new.
	p add: 0@0.0167; add: 60@0.106; add: 310@0.106; add: 350@0.0.
	env := Envelope points: p loopStart: 2 loopEnd: 3.
	env updateSelector: #modulation:; scale: 10.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
clarinet2
	"FMSound clarinet2 play"
	"(FMSound lowMajorScaleOn: FMSound clarinet2) play"

	| snd p env |
	snd := FMClarinetSound new modulation: 0 ratio: 2.

	p := OrderedCollection new.
	p add: 0@0.0; add: 60@1.0; add: 310@1.0; add: 350@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).

	p := OrderedCollection new.
	p add: 0@0.0167; add: 60@0.106; add: 310@0.106; add: 350@0.0.
	env := Envelope points: p loopStart: 2 loopEnd: 3.
	env updateSelector: #modulation:; scale: 10.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5

! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/5/98 17:35'!
default

	^ self oboe1
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
flute1
	"FMSound flute1 play"
	"(FMSound majorScaleOn: FMSound flute1) play"

	| snd p |
	snd := FMSound new.
	p := OrderedCollection new.
	p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
flute2
	"FMSound flute2 play"
	"(FMSound majorScaleOn: FMSound flute2) play"

	| snd p |
	snd := FMSound new.
	p := OrderedCollection new.
	p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	snd addEnvelope: (RandomEnvelope for: #pitch:).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
marimba
	"FMSound marimba play"
	"(FMSound majorScaleOn: FMSound marimba) play"

	| snd p env |
	snd := FMSound new modulation: 1 ratio: 0.98.

	p := OrderedCollection new.
	p add: 0@1.0; add: 10@0.3; add: 40@0.1; add: 80@0.02; add: 120@0.1; add: 160@0.02; add: 220@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6).

	p := OrderedCollection new.
	p add: 0@1.2; add: 80@0.85; add: 120@1.0; add: 160@0.85; add: 220@0.0.
	env := Envelope points: p loopStart: 2 loopEnd: 4.
	env updateSelector: #modulation:.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
mellowBrass
	"FMSound mellowBrass play"
	"(FMSound lowMajorScaleOn: FMSound mellowBrass) play"

	| snd p env |
	snd := FMSound new modulation: 0 ratio: 1.

	p := OrderedCollection new.
	p add: 0@0.0; add: 70@0.325; add: 120@0.194; add: 200@0.194; add: 320@0.194; add: 380@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).

	p := OrderedCollection new.
	p add: 0@0.1; add: 70@0.68; add: 120@0.528; add: 200@0.519; add: 320@0.528; add: 380@0.0.
	env := Envelope points: p loopStart: 3 loopEnd: 5.
	env updateSelector: #modulation:; scale: 5.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
oboe1
	"FMSound oboe1 play"
	"(FMSound majorScaleOn: FMSound oboe1) play"

	| snd p |
	snd := FMSound new modulation: 1 ratio: 1.
	p := OrderedCollection new.
	p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
oboe2
	"FMSound oboe2 play"
	"(FMSound majorScaleOn: FMSound oboe2) play"

	| snd p |
	snd := FMSound new modulation: 1 ratio: 1.
	p := OrderedCollection new.
	p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	snd addEnvelope: (RandomEnvelope for: #pitch:).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
organ1
	"FMSound organ1 play"
	"(FMSound majorScaleOn: FMSound organ1) play"

	| snd p |
	snd := FMSound new.
	p := OrderedCollection new.
	p add: 0@0; add: 60@1.0; add: 110@0.8; add: 200@1.0; add: 250@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 4).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
pluckedElecBass
	"FMSound pluckedElecBass play"
	"(FMSound lowMajorScaleOn: FMSound pluckedElecBass) play"

	| snd p env |
	snd := FMSound new modulation: 1 ratio: 3.0.

	p := OrderedCollection new.
	p add: 0@0.4; add: 20@1.0; add: 30@0.6; add: 100@0.6; add: 130@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 4).

	p := OrderedCollection new.
	p add: 0@1.0; add: 20@2.0; add: 30@4.5; add: 100@4.5; add: 130@0.0.
	env := Envelope points: p loopStart: 3 loopEnd: 4.
	env updateSelector: #modulation:.
	snd addEnvelope: env.

	p := OrderedCollection new.
	p add: 0@6.0; add: 20@4.0; add: 30@3.0; add: 100@3.0; add: 130@3.0.
	env := Envelope points: p loopStart: 3 loopEnd: 4.
	env updateSelector: #ratio:.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
randomWeird1
	"FMSound randomWeird1 play"

	| snd p |
	snd := FMSound new.
	snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96).
	p := Array with: 0@0 with: 100@1.0 with: 250@0.7 with: 400@1.0 with: 500@0.
	snd addEnvelope: (PitchEnvelope points: p loopStart: 2 loopEnd: 4).
	^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
randomWeird2
	"FMSound randomWeird2 play"

	| snd |
	snd := FMSound new.
	snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96).
	snd addEnvelope: (PitchEnvelope exponentialDecay: 0.98).
	^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5
! !
TelnetProtocolClient subclass: #FTPClient
	instanceVariableNames: 'dataSocket'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!FTPClient commentStamp: 'mir 5/12/2003 17:55' prior: 0!
A minimal FTP client program.  Could store all state in inst vars, and use an instance to represent the full state of a connection in progress.  But simpler to do all that in one method and have it be a complete transaction.

Always operates in passive mode (PASV).  All connections are initiated from client in order to get through firewalls.

See ServerDirectory openFTP, ServerDirectory getFileNamed:, ServerDirectory putFile:named: for examples of use.

See TCP/IP, second edition, by Dr. Sidnie Feit, McGraw-Hill, 1997, Chapter 14, p311.!


!FTPClient methodsFor: 'protocol' stamp: 'mir 2/13/2002 18:05'!
abortDataConnection
	self sendCommand: 'ABOR'.
	self closeDataSocket! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'!
ascii
	self sendCommand: 'TYPE A'.
	self lookForCode: 200! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'!
binary
	self sendCommand: 'TYPE I'.
	self lookForCode: 200! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:52'!
changeDirectoryTo: newDirName
	self sendCommand: 'CWD ' , newDirName.
	self checkResponse.
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:11'!
deleteDirectory: dirName
	self sendCommand: 'RMD ' , dirName.
	self checkResponse.
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:12'!
deleteFileNamed: fileName
	self sendCommand: 'DELE ' , fileName.
	self checkResponse.
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 2/20/2002 13:53'!
getDirectory
	| dirList |
	self openPassiveDataConnection.
	self sendCommand: 'LIST'.
	dirList _ self getData.
	self checkResponse.
	self checkResponse.
	^dirList
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 16:50'!
getFileList
	| dirList |
	self openPassiveDataConnection.
	self sendCommand: 'NLST'.
	dirList _ self getData.
	self checkResponse.
	self checkResponse.
	^dirList
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 19:23'!
getFileNamed: remoteFileName
	| data |
	self openPassiveDataConnection.
	self sendCommand: 'RETR ', remoteFileName.
	[self checkResponse]
		on: TelnetProtocolError
		do: [:ex |
			self closeDataSocket.
			ex pass].
	data _ self getData.
	self checkResponse.
	^data
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 5/9/2003 15:50'!
getFileNamed: remoteFileName into: dataStream
	self openPassiveDataConnection.
	self sendCommand: 'RETR ', remoteFileName.
	[self checkResponse]
		on: TelnetProtocolError
		do: [:ex |
			self closeDataSocket.
			ex pass].
	self getDataInto: dataStream.
	self closeDataSocket.
	self checkResponse! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 10/31/2000 19:03'!
getPartial: limit fileNamed: remoteFileName into: dataStream
	| data |
	self openPassiveDataConnection.
	self sendCommand: 'RETR ', remoteFileName.
	[self checkResponse]
		on: TelnetProtocolError
		do: [:ex |
			self closeDataSocket.
			ex pass].
	data _ self get: limit dataInto: dataStream.
	self abortDataConnection.
	^data
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/12/2002 18:39'!
loginUser: userName password: passwdString

	self user: userName.
	self password: passwdString.

	self login! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:10'!
makeDirectory: newDirName
	self sendCommand: 'MKD ' , newDirName.
	self checkResponse.
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 17:51'!
openDataSocket: remoteHostAddress port: dataPort
	dataSocket _ Socket new.
	dataSocket connectTo: remoteHostAddress port: dataPort! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 16:55'!
passive
	self sendCommand: 'PASV'.
	self lookForCode: 227! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 16:54'!
putFileNamed: filePath as: fileNameOnServer
	"FTP a file to the server."


	| fileStream |
	fileStream _ FileStream readOnlyFileNamed: filePath.
	fileStream
		ifNil: [(FileDoesNotExistException fileName: filePath) signal].
	self putFileStreamContents: fileStream as: fileNameOnServer
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 12/8/2003 16:54'!
putFileStreamContents: fileStream as: fileNameOnServer
	"FTP a file to the server."


	self openPassiveDataConnection.
	self sendCommand: 'STOR ', fileNameOnServer.

	fileStream reset.

	[self sendStreamContents: fileStream]
		ensure: [self closeDataSocket].

	self checkResponse.
	self checkResponse.
! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 16:43'!
pwd
	| result |
	self sendCommand: 'PWD'.
	self lookForCode: 257.
	result := self lastResponse.
	^result copyFrom: (result indexOf: $")+1 to: (result lastIndexOf: $")-1! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 10/31/2000 13:12'!
quit
	self sendCommand: 'QUIT'.
	self close! !

!FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:50'!
removeFileNamed: remoteFileName
	self sendCommand: 'DELE ', remoteFileName.
	self checkResponse.
! !

!FTPClient methodsFor: 'protocol' stamp: 'nk 1/26/2005 16:40'!
renameFileNamed: oldFileName to: newFileName
	self sendCommand: 'RNFR ' , oldFileName.
	self lookForCode: 350.
	self sendCommand: 'RNTO ' , newFileName.
	self lookForCode: 250! !


!FTPClient methodsFor: 'private' stamp: 'mir 2/19/2002 18:27'!
closeDataSocket
	self dataSocket
		ifNotNil: [
			self dataSocket closeAndDestroy.
			self dataSocket: nil]
! !

!FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 16:24'!
dataSocket
	^dataSocket! !

!FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 18:23'!
dataSocket: aSocket
	dataSocket _ aSocket! !

!FTPClient methodsFor: 'private' stamp: 'mir 4/7/2003 17:20'!
login

	self user ifNil: [^self].

	["repeat both USER and PASS since some servers require it"
	self sendCommand: 'USER ', self user.

	"331 Password required"
	self lookForCode: 331.
	"will ask user, if needed"
	self sendCommand: 'PASS ', self password.

	"230 User logged in"
	([self lookForCode: 230.]
		on: TelnetProtocolError
		do: [false]) == false
		] whileTrue: [
			(LoginFailedException protocolInstance: self) signal: self lastResponse]

! !

!FTPClient methodsFor: 'private' stamp: 'mir 11/14/2002 18:14'!
sendStreamContents: aStream
	self dataSocket sendStreamContents: aStream checkBlock: [self checkForPendingError. true]! !


!FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:06'!
get: limit dataInto: dataStream
	"Reel in data until the server closes the connection or the limit is reached.
	At the same time, watch for errors on otherSocket."

	| buf bytesRead currentlyRead |
	currentlyRead _ 0.
	buf _ String new: 4000.
	[currentlyRead < limit and: 
	[self dataSocket isConnected or: [self dataSocket dataAvailable]]]
		whileTrue: [
			self checkForPendingError.
			bytesRead _ self dataSocket receiveDataWithTimeoutInto: buf.
			1 to: (bytesRead min: (limit - currentlyRead)) do: [:ii | dataStream nextPut: (buf at: ii)].
			currentlyRead _ currentlyRead + bytesRead].
	dataStream reset.	"position: 0."
	^ dataStream! !

!FTPClient methodsFor: 'private protocol' stamp: 'mir 2/13/2002 18:06'!
getData

	| dataStream |
	dataStream _ RWBinaryOrTextStream on: (String new: 4000).
	self getDataInto: dataStream.
	self closeDataSocket.
	^dataStream contents
! !

!FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:04'!
getDataInto: dataStream
	"Reel in all data until the server closes the connection.  At the same time, watch for errors on otherSocket.  Don't know how much is coming.  Put the data on the stream."

	| buf bytesRead |
	buf _ String new: 4000.
	[self dataSocket isConnected or: [self dataSocket dataAvailable]]
		whileTrue: [
			self checkForPendingError.
			bytesRead _ self dataSocket receiveDataWithTimeoutInto: buf.
			1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)]].
	dataStream reset.	"position: 0."
	^ dataStream! !

!FTPClient methodsFor: 'private protocol' stamp: 'gk 9/9/2005 09:31'!
lookForCode: code ifDifferent: handleBlock 
	"We are expecting a certain numeric code next.  
	However, in the FTP protocol, multiple lines are allowed.  
	If the response is multi-line, the fourth character of the first line is a  
	$- and the last line repeats the numeric code but the code is followed by 
	a space. So it's possible that there are more lines left of the last response that 
	we need to throw away. We use peekForAll: so that we don't discard the
	next response that is not a continuation line."

	| headToDiscard |
	"check for multi-line response"
	(self lastResponse size > 3
			and: [(self lastResponse at: 4) = $-])
		ifTrue: ["Discard continuation lines."
			[headToDiscard _ self lastResponse first: 4.
			[[self stream peekForAll: headToDiscard]
				whileTrue: [self stream nextLine]]
				on: Exception
				do: [:ex | ^handleBlock value: nil]]].
	^ super lookForCode: code ifDifferent: handleBlock! !

!FTPClient methodsFor: 'private protocol' stamp: 'mir 4/7/2003 16:59'!
openPassiveDataConnection
	| portInfo list dataPort remoteHostAddress |
	self sendCommand: 'PASV'.
	self lookForCode: 227 ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: 'Could not enter passive mode: ' , response].

	portInfo _ (self lastResponse findTokens: '()') at: 2.
	list _ portInfo findTokens: ','.
	remoteHostAddress _ ByteArray
		with: (list at: 1) asNumber
		with: (list at: 2) asNumber
		with: (list at: 3) asNumber
		with: (list at: 4) asNumber.
	dataPort _ (list at: 5) asNumber * 256 + (list at: 6) asNumber.
	self openDataSocket: remoteHostAddress port: dataPort
! !

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

FTPClient class
	instanceVariableNames: ''!

!FTPClient class methodsFor: 'accessing' stamp: 'mir 10/30/2000 20:10'!
defaultPortNumber
	^21! !

!FTPClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:08'!
logFlag
	^#ftp! !

!FTPClient class methodsFor: 'accessing' stamp: 'mir 2/13/2002 17:50'!
rawResponseCodes
	#(200 'Command okay.'
	500 'Syntax error, command unrecognized. This may include errors such as command line too long.'
	501 'Syntax error in parameters or arguments.'
	202 'Command not implemented, superfluous at this site.'
	502 'Command not implemented.'
	503 'Bad sequence of commands.'
	504 'Command not implemented for that parameter.'
	110 'Restart marker reply. In this case, the text is exact and not left to the particular implementation; it must read: MARK yyyy = mmmm Where yyyy is User-process data stream marker, and mmmm server''s equivalent marker (note the spaces between markers and "=").'
	211 'System status, or system help reply.'
	212 'Directory status.'
	213 'File status.'
	214 'Help message. On how to use the server or the meaning of a particular non-standard command. This reply is useful only to the human user.'
	215 'NAME system type. Where NAME is an official system name from the list in the Assigned Numbers document.'
	120 'Service ready in nnn minutes.'

	220 'Service ready for new user.'
	221 'Service closing control connection. Logged out if appropriate.'
	421 'Service not available, closing control connection. This may be a reply to any command if the service knows it must shut down.'
	125 'Data connection already open; transfer starting.'
	225 'Data connection open; no transfer in progress.'
	425 'Can''t open data connection.'
	226 'Closing data connection. Requested file action successful (for example, file transfer or file abort).'
	426 'Connection closed; transfer aborted.'
	227 'Entering Passive Mode (h1,h2,h3,h4,p1,p2).'

	230 'User logged in, proceed.'
	530 'Not logged in.'
	331 'User name okay, need password.'
	332 'Need account for login.'
	532 'Need account for storing files.'
	150 'File status okay; about to open data connection.'
	250 'Requested file action okay, completed.'
	257 '"PATHNAME" created.'
	350 'Requested file action pending further information.'
	450 'Requested file action not taken. File unavailable (e.g., file busy).'
	550 'Requested action not taken. File unavailable (e.g., file not found, no access).'
	451 'Requested action aborted. Local error in processing.'
	551 'Requested action aborted. Page type unknown.'
	452 'Requested action not taken. Insufficient storage space in system.'
	552 'Requested file action aborted. Exceeded storage allocation (for current directory or dataset).'
	553 'Requested action not taken. File name not allowed.')
! !
Error subclass: #FTPConnectionException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!FTPConnectionException methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 07:47'!
defaultAction

	self resume! !

!FTPConnectionException methodsFor: 'as yet unclassified' stamp: 'RAA 3/14/2001 15:57'!
isResumable

	^true! !
Object subclass: #FWT
	instanceVariableNames: 'alpha beta coeffs h g hTilde gTilde samples nSamples nLevels transform'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!FWT commentStamp: '<historical>' prior: 0!
This class implements the Fast Wavelet Transform.  It follows Mac Cody's article in Dr. Dobb's Journal, April 1992.  See also... 
	http://www.dfw.net/~mcody/fwt/fwt.html

Notable features of his implementation include...
1.  The ability to generate a large family of wavelets (including the Haar (alpha=beta) and Daubechies) from two parameters, alpha and beta, which range between -pi and pi.
2.  All data arrays have 5 elements added on to allow for convolution overrun with filters up to 6 in length (the max for this implementation).
3.  After a forward transform, the detail coefficients of the deomposition are found in transform at: 2*i, for i = 1, 2, ... nLevels;  and the approximation coefficients are in transform at: (2*nLevels-1).  these together comprise the complete wavelet transform.

The following changes from cody's listings should also be noted...
1.  The three DotProduct routines have been merged into one.
2.  The four routines WaveletDecomposition, DecomposeBranches, WaveletReconstruction, ReconstructBranches have all been merged into transformForward:.
3.  All indexing follows the Smalltalk 1-to-N convention, naturally.!


!FWT methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:41'!
coeffs
	"Return all coefficients needed to reconstruct the original samples"
	| header csize strm |
	header := Array with: nSamples with: nLevels with: alpha with: beta.
	csize := header size.
	1 to: nLevels do: [:i | csize := csize + (transform at: i*2) size].
	csize := csize + (transform at: nLevels*2-1) size.
	coeffs := Array new: csize.
	strm := WriteStream on: coeffs.
	strm nextPutAll: header.
	1 to: nLevels do: [:i | strm nextPutAll: (transform at: i*2)].
	strm nextPutAll: (transform at: nLevels*2-1).
	^ coeffs! !

!FWT methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:41'!
coeffs: coeffArray
	"Initialize this instance from the given coeff array (including header)."
	| header strm |
	strm := ReadStream on: coeffArray.
	header := strm next: 4.
	self nSamples: header first nLevels: header second.
	self setAlpha: header third beta: header fourth.
	1 to: nLevels do: [:i | transform at: i*2 put: (strm next: (transform at: i*2) size)].
	transform at: nLevels*2-1 put: (strm next: (transform at: nLevels*2-1) size).
	strm atEnd ifFalse: [self error: 'Data size error'].
! !

!FWT methodsFor: 'access' stamp: 'di 10/31/1998 12:26'!
samples
	^ samples copyFrom: 1 to: nSamples! !

!FWT methodsFor: 'access' stamp: 'di 10/31/1998 12:25'!
samples: anArray
	1 to: anArray size do:
		[:i | samples at: i put: (anArray at: i)].
	nSamples+1 to: nSamples+5 do:
		[:i | samples at: i put: 0.0]! !


!FWT methodsFor: 'computation' stamp: 'stephaneducasse 2/4/2006 20:41'!
convolveAndDec: inData dataLen: inLen filter: filter out: outData
	"convolve the input sequence with the filter and decimate by two"
	| filtLen offset outi dotp |
	filtLen := filter size.
	outi := 1.
	1 to: inLen+9 by: 2 do:
		[:i | 
		i < filtLen
		ifTrue:
			[dotp := self dotpData: inData endIndex: i filter: filter
						start: 1 stop: i inc: 1]
		ifFalse:
			[i > (inLen+5)
			ifTrue:
				[offset := i - (inLen+5).
				dotp := self dotpData: inData endIndex: inLen+5 filter: filter
						start: 1+offset stop: filtLen inc: 1]
			ifFalse:
				[dotp := self dotpData: inData endIndex: i filter: filter
						start: 1 stop: filtLen inc: 1]].
		outData at: outi put: dotp.
		outi := outi + 1]! !

!FWT methodsFor: 'computation' stamp: 'stephaneducasse 2/4/2006 20:41'!
convolveAndInt: inData dataLen: inLen filter: filter sumOutput:
sumOutput into: outData
	"insert zeros between each element of the input sequence and
	   convolve with the filter to interpolate the data"
	| outi filtLen oddTerm evenTerm j |
	outi := 1.
	filtLen := filter size.

	"every other dot product interpolates the data"
	filtLen // 2 to: inLen + filtLen - 2 do:
		[:i |
		oddTerm := self dotpData: inData endIndex: i filter: filter
									start: 2 stop: filter size inc: 2.
		evenTerm := self dotpData: inData endIndex: i+1 filter: filter
									start: 1 stop: filter size inc: 2.
		sumOutput
			ifTrue:
				["summation with previous convolution if true"
				outData at: outi put: (outData at: outi) + oddTerm.
				outData at: outi+1 put: (outData at: outi+1) + evenTerm]
			ifFalse:
				["first convolution of pair if false"
				outData at: outi put: oddTerm.
				outData at: outi+1 put: evenTerm].
		outi := outi + 2].

	"Ought to be able to fit this last term into the above loop."
	j := inLen + filtLen - 1.
	oddTerm := self dotpData: inData endIndex: j filter: filter
									start: 2 stop: filter size inc: 2.
	sumOutput
		ifTrue: [outData at: outi put: (outData at: outi) + oddTerm]
		ifFalse: [outData at: outi put: oddTerm].
! !

!FWT methodsFor: 'computation' stamp: 'stephaneducasse 2/4/2006 20:41'!
dotpData: data endIndex: endIndex filter: filter start: start stop: stop inc: inc
	| sum i j |
	sum := 0.0.
	j := endIndex.
	i := start.
	[i <= stop] whileTrue:
		[sum := sum + ((data at: j) * (filter at: i)).
		i := i + inc.
		j := j - 1].
	^ sum! !

!FWT methodsFor: 'computation' stamp: 'stephaneducasse 2/4/2006 20:41'!
transformForward: forward
	| inData inLen outData |
	forward
	ifTrue:
		["first InData is input signal, following are intermediate approx coefficients"
		inData := samples.  inLen := nSamples.
		1 to: nLevels do:
			[:i |
			self convolveAndDec: inData dataLen: inLen
					filter: hTilde out: (transform at: 2*i-1).
			self convolveAndDec: inData dataLen: inLen
					filter: gTilde out: (transform at: 2*i).
			inData := transform at: 2*i-1.  inLen := inLen // 2]]
	ifFalse:
		[inLen := nSamples >> nLevels.
		"all but last outData are next higher intermediate approximations,
		last is final reconstruction of samples"
		nLevels to: 1 by: -1 do:
			[:i |
			outData := i = 1 ifTrue: [samples]
						ifFalse: [transform at: 2*(i-1)-1].
			self convolveAndInt: (transform at: 2*i-1) dataLen: inLen
					filter: h sumOutput: false into: outData.
			self convolveAndInt: (transform at: 2*i) dataLen: inLen
					filter: g sumOutput: true into: outData.
			inLen := inLen * 2]]
! !


!FWT methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
nSamples: n nLevels: nLevs
	"Initialize a wavelet transform."
	"Note the sample array size must be N + 5, where N is a multiple of 2^nLevels"
	| dyadSize |
	(n // (1 bitShift: nLevs)) > 0 ifFalse: [self error: 'Data size error'].
	(n \\ (1 bitShift: nLevs)) = 0 ifFalse: [self error: 'Data size error'].
	nSamples := n.
	samples := Array new: n + 5.
	nLevels := nLevs.
	transform := Array new: nLevels*2.  "Transformed data is stored as a tree of coeffs"
	dyadSize := nSamples.
	1 to: nLevels do:
		[:i |  dyadSize := dyadSize // 2.
		transform at: 2*i-1 put: (Array new: dyadSize + 5).
		transform at: 2*i put: (Array new: dyadSize + 5)]! !

!FWT methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setAlpha: alph beta: bet
	"Set alpha and beta, compute wavelet coeefs, and derive hFilter and lFilter"
	| tcosa tcosb tsina tsinb |
	alpha := alph.
	beta := bet.

	"WaveletCoeffs..."
	"precalculate cosine of alpha and sine of beta"
	tcosa := alpha cos.
	tcosb := beta cos.
	tsina := alpha sin.
	tsinb := beta sin.
	coeffs := Array new: 6.
	
	"calculate first two wavelet coefficients a := a(-2) and b := a(-1)"
	coeffs at: 1 put: ((1.0 + tcosa + tsina) * (1.0 - tcosb - tsinb)
					+ (2.0 * tsinb * tcosa)) / 4.0.
	coeffs at: 2 put: ((1.0 - tcosa + tsina) * (1.0 + tcosb - tsinb)
					- (2.0 * tsinb * tcosa)) / 4.0.

	"precalculate cosine and sine of alpha minus beta"
	tcosa := (alpha - beta) cos.
	tsina := (alpha - beta) sin.

	"calculate last four wavelet coefficients c := a(0), d := a(1), e := a(2), and f := a(3)"
	coeffs at: 3 put: (1.0 + tcosa + tsina) / 2.0.
	coeffs at: 4 put: (1.0 + tcosa - tsina) / 2.0.
	coeffs at: 5 put: 1.0 - (coeffs at: 1) - (coeffs at: 3).
	coeffs at: 6 put: 1.0 - (coeffs at: 2) - (coeffs at: 4).

	"MakeFiltersFromCoeffs..."
	"Select the non-zero wavelet coefficients"
	coeffs := coeffs copyFrom: (coeffs findFirst: [:c | c abs > 1.0e-14])
						to: (coeffs findLast: [:c | c abs > 1.0e-14]).

	"Form the low pass and high pass filters for decomposition"
	hTilde := coeffs reversed collect: [:c | c / 2.0].
	gTilde := coeffs collect: [:c | c / 2.0].
	1 to: gTilde size by: 2 do:
		[:i | gTilde at: i put: (gTilde at: i) negated].

	"Form the low pass and high pass filters for reconstruction"
	h := coeffs copy.
	g := coeffs reversed.
	2 to: g size by: 2 do:
		[:i | g at: i put: (g at: i) negated]
! !


!FWT methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:41'!
doWaveDemo  "FWT new doWaveDemo"
	"Printing the above should yield a small number -- I get 1.1e-32"
	| originalData |
	self nSamples: 312 nLevels: 3.
	self setAlpha: 0.0 beta: 0.0.

	"Install a sine wave as sample data"
	self samples: ((1 to: nSamples) collect: [:i | ((i-1) * 0.02 * Float pi) sin]).
	originalData := samples copy.
	FFT new plot: (samples copyFrom: 1 to: nSamples) in: (0@0 extent: nSamples@100).

	"Transform forward and plot the decomposition"
	self transformForward: true.
	transform withIndexDo:
		[:w :i |
		FFT new plot: (w copyFrom: 1 to: w size-5)
			in: (i-1\\2*320@(i+1//2*130) extent: (w size-5)@100)].

	"Test copy out and read in the transform coefficients"
	self coeffs: self coeffs.

	"Ttransform back, plot the reconstruction, and return the error figure"
	self transformForward: false.
	FFT new plot: (samples copyFrom: 1 to: nSamples) in: (320@0 extent: nSamples@100).
	^ self meanSquareError: originalData! !

!FWT methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:41'!
meanSquareError: otherData
	"Return the mean-square error between the current sample array and
	some other data, presumably to evaluate a compression scheme."
	| topSum bottomSum pointDiff |
	topSum := bottomSum := 0.0.
	1 to: nSamples do:
		[:i |  pointDiff := (samples at: i) - (otherData at: i).
		topSum := topSum + (pointDiff * pointDiff).
		bottomSum := bottomSum + ((otherData at: i) * (otherData at: i))].
	^ topSum / bottomSum! !

!FWT methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:41'!
viewPhiAndPsi  "(FWT new nSamples: 256 nLevels: 6) viewPhiAndPsi"
	"View the scaling function and mother wavelets for this transform"
	| p |
	Display fillWhite: (0@0 extent: 300@300).
	Display border: (0@0 extent: 300@300) width: 2.
	[Sensor anyButtonPressed] whileFalse:
		["Move mouse around in the outer rectangle to explore"
		p := Sensor cursorPoint min: 300@300.
		self setAlpha: (p x - 150) / 150.0 * Float pi
				beta: (p y - 150) / 150.0 * Float pi.
		'alpha=', (alpha roundTo: 0.01) printString, '   ',
			'beta=', (beta roundTo: 0.01) printString, '    ' displayAt: 50@5.
		transform do: [:w | w atAllPut: 0.0].
		(transform at: transform size - 1) at: (nSamples>>nLevels) put: 1.0.
		self transformForward: false.
		FFT new plot: (samples copyFrom: 1 to: nSamples) in: (20@30 extent: nSamples@100).

		transform do: [:w | w atAllPut: 0.0].
		(transform at: transform size) at: (nSamples>>nLevels) put: 1.0.
		self transformForward: false.
		FFT new plot: (samples copyFrom: 1 to: nSamples) in: (20@170 extent: nSamples@100)].
	Sensor waitNoButton! !
Morph subclass: #FaceMorph
	instanceVariableNames: 'leftEye leftEyebrow rightEye rightEyebrow lips'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Gestures'!

!FaceMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 22:21'!
leftEye
	^ leftEye! !

!FaceMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 19:47'!
lips
	^ lips! !

!FaceMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 22:21'!
rightEye
	^ rightEye! !


!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:23'!
closeEyelids
	leftEye closeEyelid.
	rightEye closeEyelid! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/24/1999 01:18'!
grin
	self leftEye openness: (0.2 to: 1.0 by: 0.1) atRandom.
	self rightEye openness: (0.2 to: 1.0 by: 0.1) atRandom.
	self lips grin! !

!FaceMorph methodsFor: 'actions' stamp: 'len 9/7/1999 02:29'!
happy
	self lips smile! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:00'!
hideTonge
	self lips hideTonge! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:21'!
lookAt: aPoint
	self leftEye lookAt: aPoint.
	self rightEye lookAt: aPoint! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/23/1999 22:51'!
lookAtFront
	self leftEye lookAtFront.
	self rightEye lookAtFront! !

!FaceMorph methodsFor: 'actions' stamp: 'stephaneducasse 2/3/2006 22:22'!
lookAtHand
	| hand |
	self isInWorld ifFalse: [^ self].
	hand := (self world activeHand) ifNil: [self world primaryHand].
	self lookAtMorph: hand! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/24/1999 01:05'!
lookAtMorph: aMorph
	self leftEye lookAtMorph: aMorph.
	self rightEye lookAtMorph: aMorph! !

!FaceMorph methodsFor: 'actions' stamp: 'len 9/7/1999 02:25'!
neutral
	self lips neutral! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:23'!
openEyelids
	leftEye openEyelid.
	rightEye openEyelid! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 23:18'!
say: aString
	self lips showBalloon: aString! !


!FaceMorph methodsFor: 'drawing' stamp: 'stephaneducasse 2/3/2006 22:22'!
drawNoseOn: aCanvas
	| nosePosition |
	nosePosition := self center * 2 + self lips center // 3.
	aCanvas fillOval: (nosePosition- (3@0) extent: 2 @ 2) color: Color black.
	aCanvas fillOval: (nosePosition + (3@0) extent: 2 @ 2) color: Color black! !

!FaceMorph methodsFor: 'drawing' stamp: 'len 8/22/1999 19:02'!
drawOn: aCanvas
	super drawOn: aCanvas.
	self drawNoseOn: aCanvas! !


!FaceMorph methodsFor: 'geometry' stamp: 'len 8/24/1999 01:27'!
mustachePosition
	^ self nosePosition + self lips center // 2! !

!FaceMorph methodsFor: 'geometry' stamp: 'len 8/24/1999 01:26'!
nosePosition
	^ self center * 2 + self lips center // 3! !


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

!FaceMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self addMorph: (leftEye := EyeMorph new);
	  addMorph: (rightEye := EyeMorph new);
	  addMorph: (lips := LipsMorph new).
	leftEye position: self position.
	rightEye position: leftEye extent x @ 0 + leftEye position.
	lips position: 0 @ 20 + (leftEye bottomRight + rightEye bottomLeft - lips extent // 2).
	self bounds: self fullBounds! !


!FaceMorph methodsFor: 'stepping and presenter' stamp: 'stephaneducasse 2/3/2006 22:22'!
step
	| amount |
	super step.
	10 atRandom = 1
		ifTrue: [[self lips perform: #(smile horror surprise sad grin) atRandom.
				 (Delay forMilliseconds: 2000 atRandom) wait.
				 self lips perform: #(neutral neutral smile sad) atRandom] fork].
	5 atRandom = 1
		ifTrue: [[self closeEyelids.
				 (Delay forMilliseconds: 180) wait.
				 self openEyelids.
				 2 atRandom = 1 ifTrue: [self lookAtFront]] fork.
				^ self].
	"20 atRandom = 1 ifTrue: [(self perform: #(leftEye rightEye) atRandom) closeEyelid]."
	20 atRandom = 1 ifTrue: [amount := (0.2 to: 1.0 by: 0.01) atRandom.
							 self leftEye openness: amount. self rightEye openness: amount].
	3 atRandom = 1 ifTrue: [self lookAtHand. ^ self].
	3 atRandom = 1 ifTrue: [self lookAtFront. ^ self].
	3 atRandom = 1 ifTrue: [self lookAtMorph: self world submorphs atRandom]! !


!FaceMorph methodsFor: 'testing' stamp: 'len 9/13/1999 00:18'!
stepTime
	^ 1000! !
Object subclass: #FakeClassPool
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Tools'!
!FakeClassPool commentStamp: '<historical>' prior: 0!
The sole purpose of this class is to allow the Browser code pane to evaluate the class variables of the class whose method it is showing.  It does this by stuffing a pointer to the classpool dictionary of the class being shown into its own classpool.  It does this just around a doIt in the code pane.  An instance of FakeClasspool is then used as the receiver of the doIt.!


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

FakeClassPool class
	instanceVariableNames: ''!


!FakeClassPool class methodsFor: 'initialize' stamp: 'dvf 9/27/2005 19:05'!
adopt: classOrNil
	"Temporarily use the classPool and sharedPools of another class"
	classOrNil isBehavior
		ifFalse: [classPool _ nil.
				sharedPools _ nil]
		ifTrue: [classPool _ classOrNil classPool.
				sharedPools _ classOrNil sharedPools]
! !
Boolean subclass: #False
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!False commentStamp: '<historical>' prior: 0!
False defines the behavior of its single instance, false -- logical negation. Notice how the truth-value checks become direct message sends, without the need for explicit testing.

Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.!


!False methodsFor: 'controlling'!
and: alternativeBlock 
	"Nonevaluating conjunction -- answer with false since the receiver is false."

	^self! !

!False methodsFor: 'controlling'!
ifFalse: alternativeBlock 
	"Answer the value of alternativeBlock. Execution does not actually
	reach here because the expression is compiled in-line."

	^alternativeBlock value! !

!False methodsFor: 'controlling'!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Answer the value of falseAlternativeBlock. Execution does not
	actually reach here because the expression is compiled in-line."

	^falseAlternativeBlock value! !

!False methodsFor: 'controlling'!
ifTrue: alternativeBlock 
	"Since the condition is false, answer the value of the false alternative, 
	which is nil. Execution does not actually reach here because the
	expression is compiled in-line."

	^nil! !

!False methodsFor: 'controlling'!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 
	"Answer the value of falseAlternativeBlock. Execution does not
	actually reach here because the expression is compiled in-line."

	^falseAlternativeBlock value! !

!False methodsFor: 'controlling'!
or: alternativeBlock 
	"Nonevaluating disjunction -- answer value of alternativeBlock."

	^alternativeBlock value! !


!False methodsFor: 'logical operations' stamp: 'md 7/30/2005 18:05'!
& aBoolean 
	"Evaluating conjunction -- answer false since receiver is false."

	^self! !

!False methodsFor: 'logical operations'!
not
	"Negation -- answer true since the receiver is false."

	^true! !

!False methodsFor: 'logical operations'!
| aBoolean 
	"Evaluating disjunction (OR) -- answer with the argument, aBoolean."

	^aBoolean! !


!False methodsFor: 'printing' stamp: 'ajh 7/1/2004 10:36'!
asBit

	^ 0! !

!False methodsFor: 'printing'!
printOn: aStream 

	aStream nextPutAll: 'false'! !

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

False class
	instanceVariableNames: ''!

!False class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 11:09'!
initializedInstance
	^ false! !
ClassTestCase subclass: #FalseTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Objects'!
!FalseTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class False. 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
!


!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'!
testAND

	self assert: (false & true) = false.
	self assert: (false & false) = false.! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'!
testAnd

	self assert: (false and: ['alternativeBlock']) = false.! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'!
testIfFalse
	
	self assert: ((false ifFalse: ['alternativeBlock']) = 'alternativeBlock'). ! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'!
testIfFalseIfTrue

	self assert: (false ifFalse: ['falseAlternativeBlock'] 
                      ifTrue: ['trueAlternativeBlock']) = 'falseAlternativeBlock'. ! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'!
testIfTrue

	self assert: (false ifTrue: ['alternativeBlock']) = nil. ! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'!
testIfTrueIfFalse

	self assert: (false ifTrue: ['trueAlternativeBlock'] 
                      ifFalse: ['falseAlternativeBlock']) = 'falseAlternativeBlock'. ! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'!
testNew

	self should: [False new] raise: TestResult error. ! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'!
testNot

	self assert: (false not = true).! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:04'!
testOR

	self assert: (false | true) =  true.
	self assert: (false | false) = false.! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:04'!
testOr

	self assert: (false or: ['alternativeBlock']) = 'alternativeBlock'.! !

!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:04'!
testPrintOn

	self assert: (String streamContents: [:stream | false printOn: stream]) = 'false'. ! !
MailComposition subclass: #FancyMailComposition
	instanceVariableNames: 'theLinkToInclude to subject textFields'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-EToy-Download'!

!FancyMailComposition methodsFor: 'access' stamp: 'RAA 5/19/2000 18:48'!
subject

	^subject

	! !

!FancyMailComposition methodsFor: 'access' stamp: 'RAA 5/19/2000 19:02'!
subject: x

	subject _ x.
	self changed: #subject.
	^true! !

!FancyMailComposition methodsFor: 'access' stamp: 'RAA 5/19/2000 18:47'!
to

	^to! !

!FancyMailComposition methodsFor: 'access' stamp: 'RAA 5/19/2000 19:02'!
to: x

	to _ x.	
	self changed: #to.
	^true
	! !


!FancyMailComposition methodsFor: 'actions' stamp: 'dvf 6/15/2002 19:09'!
completeTheMessage

	| newText strm |
	textFields do: [ :each | each hasUnacceptedEdits ifTrue: [ each accept ] ].

	newText _ String new: 200.
	strm _ WriteStream on: newText.
	strm 
		nextPutAll: 'Content-Type: text/html'; cr;
		nextPutAll: 'From: ', MailSender userName; cr;
		nextPutAll: 'To: ',to; cr;
		nextPutAll: 'Subject: ',subject; cr;

		cr;
		nextPutAll: '<HTML><BODY><BR>';
		nextPutAll: messageText asString asHtml;
		nextPutAll: '<BR><BR>',theLinkToInclude,'<BR></BODY></HTML>'.
	^strm contents




! !

!FancyMailComposition methodsFor: 'actions' stamp: 'RAA 5/19/2000 12:53'!
sendNow

	self submit: true
! !

!FancyMailComposition methodsFor: 'actions' stamp: 'RAA 5/19/2000 12:53'!
submit

	self submit: false! !

!FancyMailComposition methodsFor: 'actions' stamp: 'mir 5/13/2003 10:58'!
submit: sendNow

	| message |

	messageText _ self breakLines: self completeTheMessage atWidth: 999.
	message _ MailMessage from: messageText.
	SMTPClient
			deliverMailFrom: message from 
			to: (Array with: message to) 
			text: message text 
			usingServer: self smtpServer.
	self forgetIt.
! !


!FancyMailComposition methodsFor: 'initialization' stamp: 'nk 7/3/2003 09:41'!
celeste: aCeleste to: argTo subject: argSubject initialText: aText theLinkToInclude: linkText 
 "self new celeste: Celeste current to: 'danielv@netvision.net.il' subject: 'Mysubj' initialText: 'atext' theLinkToInclude: 'linkText'"

	to _ argTo.
	subject _ argSubject.
	messageText _ aText.
	theLinkToInclude _ linkText.
	textFields _ #().
! !


!FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:51'!
borderAndButtonColor

	^Color r: 0.729 g: 0.365 b: 0.729! !

!FancyMailComposition methodsFor: 'morphic gui' stamp: 'ar 11/9/2000 21:14'!
buttonWithAction: aSymbol label: labelString help: helpString

	^self newColumn
		wrapCentering: #center; cellPositioning: #topCenter;
		addMorph: (
			SimpleButtonMorph new 
				color: self borderAndButtonColor;
				target: self; 
				actionSelector: aSymbol;
				label: labelString;
				setBalloonText: helpString
		)
			! !

!FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:35'!
forgetIt

	morphicWindow ifNotNil: [ morphicWindow delete ].
	mvcWindow ifNotNil: [ mvcWindow controller close ].
! !

!FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:42'!
newColumn

	^AlignmentMorph newColumn color: self staticBackgroundColor! !

!FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:41'!
newRow

	^AlignmentMorph newRow color: self staticBackgroundColor! !

!FancyMailComposition methodsFor: 'morphic gui' stamp: 'ar 11/10/2000 15:46'!
openInMorphic
	"open an interface for sending a mail message with the given initial 
	text "
	| buttonsList container toField subjectField |
	buttonsList _ self newRow.
	buttonsList wrapCentering: #center; cellPositioning: #leftCenter.
	buttonsList
		addMorphBack: (
			(self 
				buttonWithAction: #submit
				label: 'send later'
				help: 'add this to the queue of messages to be sent')
		);
		addMorphBack: (
			(self 
				buttonWithAction: #sendNow
				label: 'send now'
				help: 'send this message immediately')
		);
		addMorphBack: (
			(self 
				buttonWithAction: #forgetIt
				label: 'forget it'
				help: 'forget about sending this message')
		).
	morphicWindow _ container _ AlignmentMorphBob1 new
		borderWidth: 8;
		borderColor: self borderAndButtonColor;
		color: Color white.

	container 
		addMorphBack: (buttonsList vResizing: #shrinkWrap; minHeight: 25; yourself);
		addMorphBack: ((self simpleString: 'To:') vResizing: #shrinkWrap; minHeight: 18; yourself);
		addMorphBack: ((toField _ PluggableTextMorph
			on: self
			text: #to
			accept: #to:) hResizing: #spaceFill; vResizing: #rigid; height: 50; yourself
		);
		addMorphBack: ((self simpleString: 'Subject:') vResizing: #shrinkWrap; minHeight: 18; yourself);
		addMorphBack: ((subjectField _ PluggableTextMorph
			on: self
			text: #subject
			accept: #subject:) hResizing: #spaceFill; vResizing: #rigid; height: 50; yourself
		);
		addMorphBack: ((self simpleString: 'Message:') vResizing: #shrinkWrap; minHeight: 18; yourself);
		addMorphBack: ((textEditor _ PluggableTextMorph
			on: self
			text: #messageText
			accept: #messageText:) hResizing: #spaceFill; vResizing: #spaceFill; yourself
		).
	textFields _ {toField. subjectField. textEditor}.
	container 
		extent: 300@400;
		openInWorld.! !

!FancyMailComposition methodsFor: 'morphic gui' stamp: 'ar 11/9/2000 20:39'!
simpleString: aString

	^self newRow
		layoutInset: 2;
		addMorphBack: (StringMorph contents: aString) lock! !

!FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:38'!
staticBackgroundColor

	^Color veryLightGray! !
InflateStream subclass: #FastInflateStream
	instanceVariableNames: ''
	classVariableNames: 'DistanceMap FixedDistTable FixedLitTable LiteralLengthMap'
	poolDictionaries: ''
	category: 'Compression-Streams'!
!FastInflateStream commentStamp: '<historical>' prior: 0!
This class adds the following optimizations to the basic Inflate decompression:

a) Bit reversed access
If we want to fetch the bits efficiently then we have them in the wrong bit order (e.g., when we should fetch 2r100 we would get 2r001). But since the huffman tree lookup determines the efficiency of the decompression, reversing the bits before traversal is expensive. Therefore the entries in each table are stored in REVERSE BIT ORDER. This is achieved by a reverse increment of the current table index in the huffman table construction phase (see method increment:bits:). According to my measures this speeds up the implementation by about 30-40%.

b) Inplace storage of code meanings and extra bits
Rather than looking up the meaning for each code during decompression of blocks we store the appropriate values directly in the huffman tables, using a pre-defined mapping. Even though this does not make a big difference in speed, it cleans up the code and allows easier translation into primitive code (which is clearly one goal of this implementation).

c) Precomputed huffman tables for fixed blocks
So we don't have to compute the huffman tables from scratch. The precomputed tables are not in our superclass to avoid double storage (and my superclass is more intended for documentation anyways).!


!FastInflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:02'!
nextSingleBits: n
	"Fetch the bits all at once"
	^self nextBits: n.! !


!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'!
distanceMap
	^DistanceMap! !

!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'!
increment: value bits: nBits
	"Increment value in reverse bit order, e.g. 
	for a 3 bit value count as follows:
		000 / 100 / 010 / 110
		001 / 101 / 011 / 111
	See the class comment why we need this."
	| result bit |
	result := value.
	"Test the lowest bit first"
	bit := 1 << (nBits - 1).
	"If the currently tested bit is set then we need to
	turn this bit off and test the next bit right to it"
	[(result bitAnd: bit) = 0] whileFalse:[ 
		"Turn off current bit"
		result := result bitXor: bit.
		"And continue testing the next bit"
		bit := bit bitShift: -1].
	"Turn on the right-most bit that we haven't touched in the loop above"
	^result bitXor: bit! !

!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'!
literalLengthMap
	^LiteralLengthMap! !


!FastInflateStream methodsFor: 'inflating' stamp: 'ar 2/2/2001 15:47'!
decompressBlock: llTable with: dTable
	"Process the compressed data in the block.
	llTable is the huffman table for literal/length codes
	and dTable is the huffman table for distance codes."
	| value extra length distance oldPos oldBits oldBitPos |
	<primitive: 'primitiveInflateDecompressBlock' module: 'ZipPlugin'>
	[readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[
		"Back up stuff if we're running out of space"
		oldBits := bitBuf.
		oldBitPos := bitPos.
		oldPos := sourcePos.
		value := self decodeValueFrom: llTable.
		value < 256 ifTrue:[ "A literal"
			collection byteAt: (readLimit := readLimit + 1) put: value.
		] ifFalse:["length/distance or end of block"
			value = 256 ifTrue:["End of block"
				state := state bitAnd: StateNoMoreData.
				^self].
			"Compute the actual length value (including possible extra bits)"
			extra := (value bitShift: -16) - 1.
			length := value bitAnd: 16rFFFF.
			extra > 0 ifTrue:[length := length + (self nextBits: extra)].
			"Compute the distance value"
			value := self decodeValueFrom: dTable.
			extra := (value bitShift: -16).
			distance := value bitAnd: 16rFFFF.
			extra > 0 ifTrue:[distance := distance + (self nextBits: extra)].
			(readLimit + length >= collection size) ifTrue:[
				bitBuf := oldBits.
				bitPos := oldBitPos.
				sourcePos := oldPos.
				^self].
			collection 
					replaceFrom: readLimit+1 
					to: readLimit + length + 1 
					with: collection 
					startingAt: readLimit - distance + 1.
			readLimit := readLimit + length.
		].
	].! !

!FastInflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:15'!
processFixedBlock
	litTable := FixedLitTable.
	distTable := FixedDistTable.
	state := state bitOr: BlockProceedBit.
	self proceedFixedBlock.! !

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

FastInflateStream class
	instanceVariableNames: ''!

!FastInflateStream class methodsFor: 'class initialization' stamp: 'ar 12/21/1999 23:00'!
initialize
	"FastInflateStream initialize"
	| low high |

	"Init literal/length map"
	low := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258 ).
	high := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0 0).
	LiteralLengthMap := WordArray new: 256 + 32.
	1 to: 257 do:[:i| LiteralLengthMap at: i put: i-1].
	1 to: 29 do:[:i| LiteralLengthMap at: 257+i put: (low at:i) + ( (high at: i) + 1 << 16)].

	"Init distance map"
	high := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13).
	low := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769
			1025 1537 2049 3073 4097 6145 8193 12289 16385 24577).
	DistanceMap := WordArray new: 32.
	1 to: 30 do:[:i| DistanceMap at: i put: (low at: i) + ( (high at: i) << 16)].

	"Init fixed block huffman tables"
	FixedLitTable := self basicNew
				huffmanTableFrom: FixedLitCodes
				mappedBy: LiteralLengthMap.
	FixedDistTable := self basicNew
				huffmanTableFrom: FixedDistCodes
				mappedBy: DistanceMap.! !
SketchMorph subclass: #FatBitsPaint
	instanceVariableNames: 'formToEdit magnification brush brushSize brushColor lastMouse currentTools currentSelectionMorph selectionAnchor backgroundColor'
	classVariableNames: 'FormClipboard'
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWidgets'!
!FatBitsPaint commentStamp: '<historical>' prior: 0!
Extensions to FatBitsPaint

With the goal of making FatBitsPaint a fairly nifty Form fixer-upper in the Squeak/morphic environment, I have started this set of extensions. It will probably be updated as the mood strikes, so keep an eye out for new versions.

First, some basic operating instructions:

Get a Form and send it the message #morphEdit. To get started, you can try:

        (Form fromUser) morphEdit

And there is the form in all its glory. Control click on the form to get theFatBitsPaint menu and choose the "keep this menu up" item. This will be your main tool/command palette. With it you can:
¥ Change the magnification
¥ Change the brush size (in original scale pixels)
¥ Change the brush color (via a ColorPickerMorph)

Now to some of the enhancements:

(25 September 1999 2:38:25 pm )

¥ ColorPickerMorphs now have a label below that indicates their use (you might have more than one open)
¥ A quirk that could get the brush size out of alignment with the pixel size is fixed.
¥ A background has been added so that you can see the full extent of the Form and so that you can observe the effect of translucent pixels in the form.
¥ A menu item has been added to change the background color so that you can simulate the real environment the form will be displayed in.
¥ The magnification and brush size menus now highlight their current value.
¥ An inspect option has been added to the menu so that you can do arbitrary things to the form.
¥ A file out option has been added to write the form to a file.

(25 September 1999 10:02:13 pm ) 

¥ New menu item: Tools allows you to choose between (for now) Paint Brush (all there was before) and Selections. Selections allows you to select rectangular regions of the form where the next menu takes over.
¥ New menu item: Selections gives you choices:
        ¥ edit separately - opens a new editor on the selected rectangle. Useful for cropping.
        ¥ copy - copies the selection rectangle to a clipboard. Can be pasted to this or another FatBitsPaint.
        ¥ cut - does a copy and clears the selection to transparent.
        ¥ paste - paints the contents of the clipboard over the current selection. Only the starting point of the selection matters - the extent is controlled by the clipboard.

!


!FatBitsPaint methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:40'!
drawOn: aCanvas
	| f |
	f _ self rotatedForm.
	backgroundColor ifNotNil: [aCanvas fillRectangle: bounds fillStyle: backgroundColor].
	aCanvas translucentImage: f at: bounds origin.! !


!FatBitsPaint methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

	^ true
! !

!FatBitsPaint methodsFor: 'event handling' stamp: 'RAA 9/25/1999 15:24'!
mouseDown: evt

        ^ self
                perform: (currentTools at: #mouseDown: ifAbsent: [^nil])
                with: evt! !

!FatBitsPaint methodsFor: 'event handling' stamp: 'RAA 9/25/1999 15:24'!
mouseMove: evt

        ^ self
                perform: (currentTools at: #mouseMove: ifAbsent: [^nil])
                with: evt! !


!FatBitsPaint methodsFor: 'events' stamp: 'sw 3/30/2002 16:47'!
mouseDownDefault: evt
	lastMouse _ nil.
	formToEdit depth = 1 ifTrue:
		[self brushColor: (originalForm colorAt: (self pointGriddedFromEvent: evt)) negated]! !

!FatBitsPaint methodsFor: 'events' stamp: 'sw 3/30/2002 16:47'!
mouseDownSelection: evt

        lastMouse _ nil.
        currentSelectionMorph ifNotNil: [currentSelectionMorph delete. currentSelectionMorph _ nil].
        selectionAnchor _ self pointGriddedFromEvent: evt! !

!FatBitsPaint methodsFor: 'events' stamp: 'sw 3/30/2002 16:47'!
mouseMovePaintBrushMode: evt

        | p p2 |
        p _ self pointGriddedFromEvent: evt.
        lastMouse = p ifTrue: [^ self].
        lastMouse ifNil: [lastMouse _ p].  "first point in a stroke"
        "draw etch-a-sketch style-first horizontal, then vertical"
        p2 _ p x@lastMouse y.
        brush drawFrom: lastMouse to: p2.
        brush drawFrom: p2 to: p.
                        
        self revealPenStrokes.
        lastMouse _ p! !

!FatBitsPaint methodsFor: 'events' stamp: 'sw 3/30/2002 16:47'!
pointGriddedFromEvent: evt

	| relativePt |
	relativePt _ evt cursorPoint - self position.
	^ (relativePt x truncateTo: magnification)@(relativePt y truncateTo: magnification)
! !

!FatBitsPaint methodsFor: 'events' stamp: 'nk 4/18/2004 19:04'!
toolMenu: evt
	| menu |
	menu _ MenuMorph new.
	menu
		addTitle: 'Tools';
		addStayUpItem.
	{
		{'paint brush'. self toolsForPaintBrush}.
		{'selections'. self toolsForSelection}
	} do: [:each |
		menu add: each first
			target: self
			selector: #setCurrentToolTo:
			argumentList: {each second}].
	menu toggleStayUp: evt.
	menu popUpEvent: evt in: self world! !


!FatBitsPaint methodsFor: 'geometry testing' stamp: 'RAA 9/25/1999 21:14'!
containsPoint: aPoint

        ^ self bounds containsPoint: aPoint     "even if we are transparent"
! !


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

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 15:54'!
editForm: aForm

        formToEdit _ aForm.
        brushSize _ magnification _ 64 // (aForm height min: aForm width) max: 4.
        self revert! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:54'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self setCurrentToolTo: self toolsForPaintBrush.
	formToEdit _ Form extent: 50 @ 40 depth: 8.
	formToEdit fill: formToEdit boundingBox fillColor: Color veryVeryLightGray.
	brushSize _ magnification _ 4.
	
	brushColor _ Color red.
	backgroundColor _ Color white.
	self revert! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 22:26'!
openWith: aForm

        self editForm: aForm; openInWorld! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 21:44'!
setCurrentToolTo: aDictionary

        currentTools _ aDictionary.
        currentSelectionMorph ifNotNil: [currentSelectionMorph delete. currentSelectionMorph _ nil]! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 15:25'!
toolsForPaintBrush

        ^Dictionary new
                at: #mouseMove: put: #mouseMovePaintBrushMode:;
                at: #mouseDown: put: #mouseDownDefault:;
                yourself! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 15:27'!
toolsForSelection

        ^ Dictionary new
                at: #mouseMove: put: #mouseMoveSelectionMode:;
                at: #mouseDown: put: #mouseDownSelection:;
                yourself! !


!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 5/14/2000 12:42'!
accept
	| f |
	f _ self unmagnifiedForm.
	f boundingBox = formToEdit boundingBox
		ifFalse: [^ self error: 'implementation error; form dimensions should match'].
	f displayOn: formToEdit.  "modify formToEdit in place"! !

!FatBitsPaint methodsFor: 'menu' stamp: 'dgd 10/8/2003 18:59'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

        super addCustomMenuItems: aCustomMenu hand: aHandMorph.
        aCustomMenu 
                add: 'background color' translated action: #setBackgroundColor:;
                add: 'pen color' translated action: #setPenColor:;
                add: 'pen size' translated action: #setPenSize:;
                add: 'fill' translated action: #fill;
                add: 'magnification' translated action: #setMagnification:;
                add: 'accept' translated action: #accept;
                add: 'revert' translated action: #revert;
                add: 'inspect' translated action: #inspectForm;
                add: 'file out' translated action: #fileOut;
                add: 'selection...' translated action: #selectionMenu:;
                add: 'tools...' translated action: #toolMenu:! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 22:27'!
backgroundColor: aColor

        backgroundColor _ aColor.
        self changed! !

!FatBitsPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
brushColor: aColor

	brushColor _ aColor.
	brush color: aColor.
! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 21:50'!
copySelection

        | relativeBounds scaledBounds |
        currentSelectionMorph ifNil: [^ nil].
        relativeBounds _ currentSelectionMorph bounds translateBy: self position negated.
        scaledBounds _ relativeBounds scaleBy: 1 / magnification.
        FormClipboard _ (self unmagnifiedForm copy: scaledBounds).
        ^ relativeBounds! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 16:15'!
cutSelection

        | relativeBounds |
        relativeBounds _ self copySelection ifNil: [^ nil].
        originalForm fill: relativeBounds rule: Form over fillColor: Color transparent.
        self revealPenStrokes! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 16:19'!
editSelection

        (self selectionAsForm ifNil: [^ nil]) morphEdit! !

!FatBitsPaint methodsFor: 'menu' stamp: 'nb 6/17/2003 12:25'!
fileOut

        | fileName result |

        result _ StandardFileMenu newFile ifNil: [^Beeper beep].
        fileName _ result directory fullNameFor: result name.
        Cursor normal showWhile:
                [self unmagnifiedForm writeOnFileNamed: fileName]! !

!FatBitsPaint methodsFor: 'menu' stamp: 'bf 1/5/2000 18:48'!
fill

	| fillPt |
	Cursor blank show.
	Cursor crossHair showWhile:
		[fillPt _ Sensor waitButton - self position].
	originalForm shapeFill: brushColor interiorPoint: fillPt.
	self changed.
! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 15:49'!
inspectForm

        self unmagnifiedForm inspect! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 15:49'!
magnification: aNumber

        | oldPenSize oldForm |
        oldPenSize _ brushSize / magnification.
        oldForm _ self unmagnifiedForm.
        magnification _ aNumber asInteger max: 1.
        self form: (oldForm magnify: oldForm boundingBox by: magnification).
        brush _ Pen newOnForm: originalForm.
        self penSize: oldPenSize.
        brush color: brushColor! !

!FatBitsPaint methodsFor: 'menu' stamp: 'sw 3/30/2002 16:48'!
mouseMoveSelectionMode: evt

        | p |
        p _ self pointGriddedFromEvent: evt.
        lastMouse = p ifTrue: [^ self].

        currentSelectionMorph ifNil:
                [currentSelectionMorph _ MarqueeMorph new 
                        color: Color transparent;
                        borderWidth: 2;
                        lock.
                self addMorphFront: currentSelectionMorph.
                currentSelectionMorph startStepping].
        currentSelectionMorph 
                bounds: ((Rectangle encompassing: {p. selectionAnchor}) translateBy: self position).

        lastMouse _ p! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 21:50'!
pasteSelection

        | relativeBounds tempForm |
        currentSelectionMorph ifNil: [^ nil].
        FormClipboard ifNil: [^nil].
        relativeBounds _ currentSelectionMorph bounds translateBy: self position negated.
        tempForm _ (FormClipboard magnify: FormClipboard boundingBox by: magnification).
        self form
                copy: (relativeBounds origin extent: tempForm boundingBox extent)
                from: 0@0
                in: tempForm
                rule: Form over. 
        self revealPenStrokes! !

!FatBitsPaint methodsFor: 'menu' stamp: 'jm 12/1/97 12:09'!
penSize: aNumber

	brushSize _ (aNumber * magnification) asInteger.
	brush squareNib: brushSize.
! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/28/1999 13:03'!
revert
"since WarpBits may mangle an 8-bit ColorForm, make it 32 first"
        self form: ((formToEdit asFormOfDepth: 32) 
                magnify: formToEdit boundingBox 
                by: magnification 
                smoothing: 1).
        brush _ Pen newOnForm: originalForm.
        brush squareNib: brushSize.
        brush color: brushColor! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 16:18'!
selectionAsForm

        | relativeBounds scaledBounds |
        currentSelectionMorph ifNil: [^nil].
        relativeBounds _ currentSelectionMorph bounds translateBy: self position negated.
        scaledBounds _ relativeBounds scaleBy: 1 / magnification.
        ^ self unmagnifiedForm copy: scaledBounds! !

!FatBitsPaint methodsFor: 'menu' stamp: 'nk 4/18/2004 19:04'!
selectionMenu: evt

        | menu |
 
        (menu _ MenuMorph new)
                addTitle: 'Edit';
                addStayUpItem.

        {
                {'edit separately'. #editSelection}.
                {'copy'. #copySelection}.
                {'cut'. #cutSelection}.
                {'paste'. #pasteSelection}
        } do: [:each |
                menu add: each first
                        target: self
                        selector: each second
                        argumentList: #()].
        menu toggleStayUp: evt.
        menu popUpEvent: evt in: self world! !

!FatBitsPaint methodsFor: 'menu' stamp: 'ar 10/5/2000 18:51'!
setBackgroundColor: evt

	self
		changeColorTarget: self 
		selector: #backgroundColor: 
		originalColor: backgroundColor
		hand: evt hand! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
setMagnification: evt
	| menu |
	menu _ MenuMorph new.
	((1 to: 8), #(16 24 32)) do: [:w |
		menu add: w printString
			target: self
			selector: #magnification:
			argumentList: (Array with: w).
		magnification = w ifTrue: [menu lastSubmorph color: Color red]].
	menu popUpEvent: evt in: self world! !

!FatBitsPaint methodsFor: 'menu' stamp: 'ar 10/5/2000 18:51'!
setPenColor: evt

	self changeColorTarget: self selector: #brushColor: originalColor: brushColor hand: evt hand.! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
setPenSize: evt
	| menu sizes |
 
	menu _ MenuMorph new.
	sizes _ (1 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
	sizes do: [:w |
		menu add: w printString
			target: self
			selector: #penSize:
			argumentList: (Array with: w).
		(brushSize // magnification) = w ifTrue: [menu lastSubmorph color: Color red]].
	menu popUpEvent: evt in: self world! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 15:48'!
unmagnifiedForm

        ^ self form shrink: self form boundingBox by: magnification! !
FileList2 subclass: #FileChooser
	instanceVariableNames: 'view caption captionMorph captionBox cancelButton okButton buttonPane captionPane directoryPane filePane showShortFileNames'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList'!
!FileChooser commentStamp: 'miki 8/15/2005 12:07' prior: 0!
This class provides a simple "modal" dialog box to choose a file, with a directory tree, a file list, and open and cancel buttons. It is meant to be an improvement of FileList2 modalFileSelector. 

An applictaion can customize the user interface in a straightforward way. Creation of the file choser is done in several steps by calling various helper methods.. 

The order of the method calls when creating a customized file chooser are important. The UI must be created before methods that change the attributes of the UI can be called. You can either start by creating the default UI, and them modify the morphs in the file chooser (there are methods to access the buttons and the panes).

You can also build a completely custom UI, by writing your own methods for creating the layout etc. One way to do this is to subclass FileChooser and override the methods you want to change, andother way is to supply your own morphic view to the file chooser. This must be an instance of MorphicModel or a subclass of it, because the file chooser uses the model functionality.

There are two varieties of the UI, one that is supposed to be like a dialog box (uses colors from the menu preferences in class Preference), and one is using a system window. The way a system window works turns out to be somehat different from how a plain Morphic Model works, and this is why there are separate methods for creating the dialog box UI and the system window UI.

On the class side, there are examples that shows differents ways to use this class.

On the to do list is adding support for a file save dialog box, with a directory tree and a text input field for typing a file name.

(Mikael Kindborg, 050815)
!


!FileChooser methodsFor: 'accessing' stamp: 'miki 8/15/2005 11:26'!
buttonPane
	^buttonPane! !

!FileChooser methodsFor: 'accessing' stamp: 'miki 8/14/2005 22:48'!
cancelButton
	^cancelButton! !

!FileChooser methodsFor: 'accessing' stamp: 'miki 8/13/2005 17:52'!
caption
	^caption! !

!FileChooser methodsFor: 'accessing' stamp: 'miki 8/15/2005 11:26'!
captionPane
	^captionPane! !

!FileChooser methodsFor: 'accessing' stamp: 'miki 8/14/2005 22:55'!
directory
	^super directory! !

!FileChooser methodsFor: 'accessing' stamp: 'miki 8/15/2005 11:27'!
directoryPane
	^directoryPane! !

!FileChooser methodsFor: 'accessing' stamp: 'miki 8/15/2005 11:27'!
filePane
	^filePane! !

!FileChooser methodsFor: 'accessing' stamp: 'miki 8/13/2005 17:57'!
morphicView
	^view! !

!FileChooser methodsFor: 'accessing' stamp: 'miki 8/14/2005 22:48'!
okButton
	^okButton! !


!FileChooser methodsFor: 'initialization' stamp: 'miki 8/15/2005 11:45'!
initalizeAsDialogBox
	self initalizeBasicParameters.
	self createDialogBoxUI.
	self morphicView
		useRoundedCorners;
		color: Preferences menuColor;
		adoptPaneColor: Preferences menuLineColor.
	self 
		setCaptionColor: Preferences menuTitleColor;
		setButtonColor: Preferences menuColor.! !

!FileChooser methodsFor: 'initialization' stamp: 'miki 8/15/2005 11:45'!
initalizeAsSystemWindow
	self initalizeBasicParameters.
	self createSystemWindowUI.! !

!FileChooser methodsFor: 'initialization' stamp: 'miki 8/15/2005 11:45'!
initalizeAsSystemWindowWithCaptionPane
	self initalizeBasicParameters.
	self createSystemWindowUIWithCaptionPane.! !

!FileChooser methodsFor: 'initialization' stamp: 'miki 8/15/2005 12:09'!
initalizeBasicParameters
	self showShortFileNames: true.
	self setDirectory: FileDirectory default.! !

!FileChooser methodsFor: 'initialization' stamp: 'miki 8/14/2005 23:12'!
setDirectory: aDir
	^super directory: aDir! !

!FileChooser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
setMorphicView: aMorphicModel
	view := aMorphicModel.
	self modalView: view.
	view model: self.! !

!FileChooser methodsFor: 'initialization' stamp: 'miki 8/14/2005 23:12'!
setSuffixes: aList
	self fileSelectionBlock:  [:entry :myPattern |
			entry isDirectory
				ifTrue:
					[false]
				ifFalse:
					[aList includes: (FileDirectory extensionFor: entry name asLowercase)]] fixTemps! !

!FileChooser methodsFor: 'initialization' stamp: 'miki 8/15/2005 11:32'!
showShortFileNames: aBoolean 
	showShortFileNames := aBoolean! !


!FileChooser methodsFor: 'open' stamp: 'sd 11/20/2005 21:27'!
open
	| model |
	self postOpen. "Funny name in this context, should be renamed, but whatever..."
	self morphicView openInWorld.
	model := self morphicView model.
	FileChooser modalLoopOn: self morphicView.
	^ model getSelectedFile.
! !


!FileChooser methodsFor: 'ui creation' stamp: 'sd 11/20/2005 21:27'!
addFullPanesTo: aMorph from: aCollection
	| frame |
	aCollection do: [ :each |
		frame := LayoutFrame 
			fractions: each second 
			offsets: each third.
		aMorph addMorph: each first fullFrame: frame.
	]! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 18:54'!
centerMorphicView
	self morphicView
		fullBounds;
		position: Display extent - self morphicView extent // 2.
! !

!FileChooser methodsFor: 'ui creation' stamp: 'sd 11/20/2005 21:27'!
createCancelButton
	cancelButton := SimpleButtonMorph new.
	cancelButton
		label: 'Cancel' translated;
		color: Color transparent;
		borderColor: Color black;
		borderWidth: 1.
	cancelButton 
		on: #mouseUp 
		send: #cancelHit
		to: self.
	^cancelButton
! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 15:05'!
createDialogBoxButtonPane
	"Create buttons suitable for a MorphicModel file chooser."

	buttonPane := AlignmentMorph new.
	buttonPane
		layoutPolicy: ProportionalLayout new;
		color: Color transparent;
		borderWidth: 0.
	self createOkButton.
	self createCancelButton.
	buttonPane addMorph: self cancelButton
		fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 0.49 @ 1.0)
				offsets: (0 @ 0 corner: 0 @ 0)).
	buttonPane addMorph: self okButton
		fullFrame: (LayoutFrame fractions: (0.51 @ 0 corner: 1.0 @ 1.0)
				offsets: (0 @ 0 corner: 0 @ 0)).
	^buttonPane! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 18:45'!
createDialogBoxCaptionPane
	"Create a morph to hold the caption string. The caption is created in setCaption:"

	| icon frame |
	captionPane := AlignmentMorph new.
	captionPane
		color: Color transparent;
		layoutPolicy: ProportionalLayout new.

	"You can change the caption later by calling setCaption:"
	self setCaption: 'Please select a file' translated.
	self setCaptionFont: Preferences windowTitleFont.
	icon := SketchMorph new.
	icon form: MenuIcons openIcon.
	captionPane addMorph: icon.
	frame := LayoutFrame new.
	frame
		leftFraction: 0;
		topFraction: 0.5;
		leftOffset: icon form width // 2;
		topOffset: (icon form width // 2) negated.
	icon layoutFrame: frame.
	^captionPane! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 12:13'!
createDialogBoxLayout
	"Create a layout suitable for a MorphicModel file chooser."

	| inset insetNeg captionTop captionBottom buttonsBottom buttonsTop contentTop contentBottom |

	inset := 6.
	insetNeg := inset negated.
	captionTop := 0.
	captionBottom := 33.
	contentTop := captionBottom + inset.
	contentBottom := -30 - inset - inset.
	buttonsTop := contentBottom + inset.
	buttonsBottom := insetNeg.

	self addFullPanesTo: self morphicView
		from: {
				{
					(self captionPane).
					(0 @ 0 corner: 1 @ 0).
					(0 @ captionTop corner: 0 @ captionBottom)
				}.
				{
					(self buttonPane).
					(0 @ 1 corner: 1 @ 1).
					(inset @ buttonsTop corner: insetNeg @ buttonsBottom)
				}.
				{
					(self directoryPane).
					(0 @ 0 corner: 0.5 @ 1).
					(inset @ contentTop corner: insetNeg @ contentBottom)
				}.
				{
					(self filePane).
					(0.5 @ 0 corner: 1 @ 1).
					(inset @ contentTop corner: insetNeg @ contentBottom)
				}
			}! !

!FileChooser methodsFor: 'ui creation' stamp: 'sd 11/20/2005 21:27'!
createDialogBoxMorphicView
	| m |
	m := MorphicModel new
		layoutPolicy: ProportionalLayout new;
		color: Preferences menuColor;
		borderColor: Preferences menuBorderColor;
		borderWidth: Preferences menuBorderWidth;
		layoutInset: 0;
		extent: 600@400.
	self setMorphicView: m.
	^m! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 19:02'!
createDialogBoxUI
	"This method creates UI components and a layout that are suitable for a MorphicModel. Also centers the morphic view in the world. Note that the order of the method calls are important if you modify this."

	self
		createDialogBoxMorphicView;
		createDialogBoxCaptionPane;
		createDialogBoxButtonPane;
		createDirectoryPane;
		createFilePane;
		createDialogBoxLayout;
		centerMorphicView.
	^self morphicView! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 11:27'!
createDirectoryPane
	directoryPane := self morphicDirectoryTreePane.
	directoryPane borderWidth: 0.
	^directoryPane! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 11:27'!
createFilePane
	filePane := self morphicFileListPane.
	filePane borderWidth: 0.
	^filePane! !

!FileChooser methodsFor: 'ui creation' stamp: 'sd 11/20/2005 21:27'!
createOkButton
	okButton := SimpleButtonMorph new.
	okButton 
		label: 'Open' translated;
		color: Color transparent;
		borderColor: Color black;
		borderWidth: 1.
	okButton 
		on: #mouseUp 
		send: #okHit
		to: self.
	^okButton! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 11:26'!
createSystemWindowButtonPane
	"Create buttons suitable for a SystemWindow file chooser."

	self optionalButtonSpecs: self okayAndCancelServices.
	buttonPane := self optionalButtonRow.
	okButton := buttonPane firstSubmorph.
	cancelButton := buttonPane firstSubmorph.
	^buttonPane! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 11:26'!
createSystemWindowCaptionPane
	"Create a morph to hold the caption string. The caption is created in setCaption:"

	captionPane := AlignmentMorph new.
	captionPane
		color: Color transparent;
		layoutPolicy: ProportionalLayout new.
	"You can change the caption later by calling setCaption:"
	self setCaption: 'Please select a file' translated.
	^captionPane! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 12:12'!
createSystemWindowLayout
	"Create a layout suitable for a SystemWindow file chooser."

	| buttonsHeight |

	buttonsHeight := 33.

	self addFullPanesTo: self morphicView
		from: {
				{
					(self buttonPane).
					(0 @ 0 corner: 1 @ 0).
					(0 @ 0 corner: 0 @ buttonsHeight)
				}.
				{
					(self directoryPane).
					(0 @ 0 corner: 0.5 @ 1).
					(0 @ buttonsHeight corner: 0 @ 0)
				}.
				{
					(self filePane).
					(0.5 @ 0 corner: 1 @ 1).
					(0 @ buttonsHeight corner: 0 @ 0)
				}
			}! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 12:18'!
createSystemWindowLayoutWithCaptionPane

	| buttonsHeight captionHeight |

	buttonsHeight := 33.
	captionHeight := 28.

	self addFullPanesTo: self morphicView
		from: {
				{
					(self captionPane). 
					(0 @ 0 corner: 1 @ 0). 
					(0 @ 0 corner: 0 @ captionHeight)
				}.
				{
					(self buttonPane).
					(0 @ 0 corner: 1 @ 0).
					(0 @ captionHeight corner: 0 @ (captionHeight + buttonsHeight))
				}.
				{
					(self directoryPane).
					(0 @ 0 corner: 0.5 @ 1).
					(0 @ (captionHeight + buttonsHeight) corner: 0 @ 0)
				}.
				{
					(self filePane).
					(0.5 @ 0 corner: 1 @ 1).
					(0 @ (captionHeight + buttonsHeight) corner: 0 @ 0)
				}
			}! !

!FileChooser methodsFor: 'ui creation' stamp: 'sd 11/20/2005 21:27'!
createSystemWindowMorphicView
	| m |
	m := SystemWindow labelled: 'Please select a file' translated. "self directory pathName."
	"m deleteCloseBox."
	self setMorphicView: m.! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 11:40'!
createSystemWindowUI
	"This method creates UI components and a layout that are suitable for a SystemWindow. Note that the order of the method calls are important."

	self
		createSystemWindowMorphicView;
		createSystemWindowButtonPane;
		createDirectoryPane;
		createFilePane;
		createSystemWindowLayout.
	^self morphicView! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 11:40'!
createSystemWindowUIWithCaptionPane
	self
		createSystemWindowMorphicView;
		createSystemWindowCaptionPane;
		createSystemWindowButtonPane;
		createDirectoryPane;
		createFilePane;
		createSystemWindowLayoutWithCaptionPane.
	^self morphicView! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 01:12'!
setButtonColor: aColor
	self okButton  color: aColor.
	self cancelButton  color: aColor.
! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 11:23'!
setCaptionColor: aColor 
	self captionPane color: aColor! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 14:55'!
setCaptionFont: aFont
	self caption font: aFont.
	self setCaption: self caption contents asString.

! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 11:23'!
setCaption: aString 
	| frame |
	caption ifNil: 
			[caption := StringMorph new.
			self captionPane addMorph: caption].
	caption contents: aString.
	frame := LayoutFrame new.
	frame
		leftFraction: 0.5;
		topFraction: 0.5;
		leftOffset: caption width negated // 2;
		topOffset: caption height negated // 2.
	caption layoutFrame: frame! !

!FileChooser methodsFor: 'ui creation' stamp: 'miki 8/15/2005 00:41'!
setPaneColor: aColor
	self morphicView 
		color: aColor;
		adoptPaneColor: aColor.

! !


!FileChooser methodsFor: 'updating' stamp: 'miki 8/15/2005 11:32'!
fileNameFormattedFrom: entry sizePad: sizePad 
	"entry is a 5-element array of the form:
		(name creationTime modificationTime dirFlag fileSize)"

	"If the short file list flag is false, we send this on to the superclass."

	| nameStr |
	showShortFileNames 
		ifFalse: [^super fileNameFormattedFrom: entry sizePad: sizePad].

	"Otherwise, just show the name of the file in the file list."
	nameStr := (entry at: 4) 
				ifTrue: [entry first , self folderString]
				ifFalse: [entry first].
	^nameStr! !

!FileChooser methodsFor: 'updating' stamp: 'miki 8/14/2005 23:04'!
updateButtonRow
	"Prevent updating of the the button row."! !

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

FileChooser class
	instanceVariableNames: ''!

!FileChooser class methodsFor: 'examples' stamp: 'sd 11/20/2005 21:28'!
example1
	"Open file chooser with the standard dialog box UI."
	"FileChooser example1"
	| fc stream |
	fc := FileChooser new.
	fc initalizeAsDialogBox.
	stream := fc open.
	stream inspect.! !

!FileChooser class methodsFor: 'examples' stamp: 'sd 11/20/2005 21:28'!
example2
	"Open file chooser with a system window UI."
	"FileChooser example2"
	| fc stream |
	fc := FileChooser new.
	fc initalizeAsSystemWindow.
	stream := fc open.
	stream inspect.! !

!FileChooser class methodsFor: 'examples' stamp: 'sd 11/20/2005 21:28'!
example3
	"Open file chooser with a system window UI that has a caption pane and shows only picture files."
	"FileChooser example3"
	| fc stream |
	fc := FileChooser new.
	fc initalizeAsSystemWindowWithCaptionPane.
	fc setCaption: 'Select a picture file' translated.
	fc setSuffixes: {'png' . 'gif' . 'bmp' . 'jpg' . 'jpeg' }.
	stream := fc open.
	stream ifNotNil: [(Form fromBinaryStream: stream) asMorph openInHand].! !

!FileChooser class methodsFor: 'examples' stamp: 'sd 11/20/2005 21:28'!
example4
	"Open file chooser with a customized dialog box UI. The order of the messages is important. In general, call the initialize method first, then modify things, and finally call open."
	"FileChooser example4"
	| fc stream |
	fc := FileChooser new.
	fc initalizeAsDialogBox.
	fc setDirectory: FileDirectory root.
	fc setSuffixes: {'png' . 'gif' . 'bmp' . 'jpg' . 'jpeg' }.
	fc setCaption: 'Select a picture file' translated.
	fc morphicView 
		borderColor: Color black; 
		borderWidth: 2;
		color: Color white.
	fc setPaneColor: Color gray muchLighter.
	fc captionPane color: Color orange muchLighter.
	fc okButton color: Color green muchLighter.
	fc cancelButton color: Color blue muchLighter.
	fc morphicView position: 20@20.
	stream := fc open.
	stream ifNotNil: [(Form fromBinaryStream: stream) asMorph openInHand].! !
Browser subclass: #FileContentsBrowser
	instanceVariableNames: 'packages infoString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-File Contents Browser'!
!FileContentsBrowser commentStamp: '<historical>' prior: 0!
I am a class browser view on a fileout (either a source file (.st) or change set (.cs)). I do not actually load the code into to the system, nor do I alter the classes in the image. Use me to vet code in a comfortable way before loading it into your image.

From a FileList, I can be invoked by selecting a source file and selecting the "browse code" menu item from the yellow button menu.

I use PseudoClass, PseudoClassOrganizers, and PseudoMetaclass to model the class structure of the source file.!


!FileContentsBrowser methodsFor: 'accessing'!
contents
	self updateInfoView.
	(editSelection == #newClass and:[self selectedPackage notNil])
		ifTrue: [^self selectedPackage packageInfo].
	editSelection == #editClass
		ifTrue:[^self modifiedClassDefinition].
	^super contents! !

!FileContentsBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
contents: input notifying: aController 
	"The retrieved information has changed and its source must now be 
	updated. The information can be a variety of things, depending on the 
	list selections (such as templates for class or message definition, methods) 
	or the user menu commands (such as definition, comment, hierarchy). 
	Answer the result of updating the source."

	| aString aText theClass |
	aString := input asString.
	aText := input asText.

	editSelection == #editComment 
		ifTrue: [theClass := self selectedClass.
				theClass ifNil: [self inform: 'You must select a class
before giving it a comment.'.
				^ false].
				theClass comment: aText. ^ true].
	editSelection == #editMessageCategories 
		ifTrue: [^ self changeMessageCategories: aString].

	self inform:'You cannot change the current selection'.
	^false
! !

!FileContentsBrowser methodsFor: 'accessing'!
packages
	^packages! !

!FileContentsBrowser methodsFor: 'accessing'!
packages: aDictionary
	packages := aDictionary.! !

!FileContentsBrowser methodsFor: 'accessing'!
selectedPackage
	| cat |
	cat := self selectedSystemCategoryName.
	cat isNil ifTrue:[^nil].
	^self packages at: cat asString ifAbsent:[nil]! !


!FileContentsBrowser methodsFor: 'class list' stamp: 'ar 9/27/2005 20:27'!
browseMethodFull
	| myClass |
	(myClass := self selectedClassOrMetaClass) ifNotNil:
		[ToolSet browse: myClass realClass selector: self selectedMessageName]! !

!FileContentsBrowser methodsFor: 'class list'!
classList
	"Answer an array of the class names of the selected category. Answer an 
	empty array if no selection exists."

	(systemCategoryListIndex = 0 or:[self selectedPackage isNil])
		ifTrue: [^Array new]
		ifFalse: [^self selectedPackage classes keys asSortedCollection].! !

!FileContentsBrowser methodsFor: 'class list' stamp: 'rbb 3/1/2005 10:52'!
findClass
	| pattern foundClass classNames index foundPackage |
	self okToChange ifFalse: [^ self classNotFound].
	pattern := (UIManager default request: 'Class Name?') asLowercase.
	pattern isEmpty ifTrue: [^ self].
	classNames := Set new.
	self packages do:[:p| classNames addAll: p classes keys].
	classNames := classNames asArray select: 
		[:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0].
	classNames isEmpty ifTrue: [^ self].
	index := classNames size == 1
				ifTrue:	[1]
				ifFalse:	[(UIManager default chooseFrom: classNames lines: #())].
	index = 0 ifTrue: [^ self].
	foundPackage := nil.
	foundClass := nil.
	self packages do:[:p| 
		(p classes includesKey: (classNames at: index)) ifTrue:[
			foundClass := p classes at: (classNames at: index).
			foundPackage := p]].
	foundClass isNil ifTrue:[^self].
 	self systemCategoryListIndex: (self systemCategoryList indexOf: foundPackage packageName asSymbol).
	self classListIndex: (self classList indexOf: foundClass name). ! !

!FileContentsBrowser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'!
renameClass
	| oldName newName |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	oldName := self selectedClass name.
	newName := (self request: 'Please type new class name'
						initialAnswer: oldName) asSymbol.
	(newName isEmpty or:[newName = oldName]) ifTrue: [^ self].
	(self selectedPackage classes includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists in the package'].
	systemOrganizer classify: newName under: self selectedSystemCategoryName.
	systemOrganizer removeElement: oldName.
	self selectedPackage renameClass: self selectedClass to: newName.
	self changed: #classList.
	self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).
! !

!FileContentsBrowser methodsFor: 'class list'!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	self selectedClassName == nil ifTrue: [^nil].
	^self selectedPackage classAt: self selectedClassName! !


!FileContentsBrowser methodsFor: 'creation' stamp: 'md 2/24/2006 15:46'!
addLowerPanesTo: window at: nominalFractions with: editString

	| verticalOffset row codePane infoPane infoHeight divider |

	row := AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 1;
		borderColor: Color black;
		layoutPolicy: ProportionalLayout new.

	codePane := MorphicTextEditor default on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	infoPane := PluggableTextMorph on: self text: #infoViewContents accept: nil
			readSelection: nil menu: nil.
	infoPane askBeforeDiscardingEdits: false.
	verticalOffset := 0.

">>not with this browser--- at least not yet ---
	innerFractions := 0@0 corner: 1@0.
	verticalOffset := self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset.
	verticalOffset := self addOptionalButtonsTo: row  at: innerFractions plus: verticalOffset.
<<<<"

	infoHeight := 20.
	row 
		addMorph: (codePane borderWidth: 0)
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@1) 
				offsets: (0@verticalOffset corner: 0@infoHeight negated)
		).
	divider := BorderedSubpaneDividerMorph forTopEdge.
	divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2.
	row 
		addMorph: divider
		fullFrame: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@infoHeight negated corner: 0@(1-infoHeight))
		).
	row 
		addMorph: (infoPane borderWidth: 0; hideScrollBarsIndefinitely)
		fullFrame: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@(1-infoHeight) corner: 0@0)
		).
	window 
		addMorph: row
		frame: nominalFractions.

	row on: #mouseEnter send: #paneTransition: to: window.
	row on: #mouseLeave send: #paneTransition: to: window.

! !

!FileContentsBrowser methodsFor: 'creation' stamp: 'sd 11/20/2005 21:27'!
createViews
	"Create a pluggable version of all the views for a Browser, including views and controllers."

	| hasSingleFile width topView packageListView classListView switchView messageCategoryListView messageListView browserCodeView infoView |
	contentsSymbol := self defaultDiffsSymbol.  "#showDiffs or #prettyDiffs"
	Smalltalk isMorphic ifTrue: [^ self openAsMorph].

	(hasSingleFile := self packages size = 1)
		ifTrue: [width := 150]
		ifFalse: [width := 200].

	(topView := StandardSystemView new) 
		model: self;
		borderWidth: 1.
		"label and minSize taken care of by caller"
	
	hasSingleFile 
		ifTrue: [
			self systemCategoryListIndex: 1.
			packageListView := PluggableListView on: self
				list: #systemCategorySingleton
				selected: #indexIsOne 
				changeSelected: #indexIsOne:
				menu: #packageListMenu:
				keystroke: #packageListKey:from:.
			packageListView window: (0 @ 0 extent: width @ 12)]
		ifFalse: [
			packageListView := PluggableListView on: self
				list: #systemCategoryList
				selected: #systemCategoryListIndex
				changeSelected: #systemCategoryListIndex:
				menu: #packageListMenu:
				keystroke: #packageListKey:from:.
			packageListView window: (0 @ 0 extent: 50 @ 70)].
	topView addSubView: packageListView.

	classListView := PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: #classListMenu:
		keystroke: #classListKey:from:.
	classListView window: (0 @ 0 extent: 50 @ 62).
	hasSingleFile 
		ifTrue: [topView addSubView: classListView below: packageListView]
		ifFalse: [topView addSubView: classListView toRightOf: packageListView].

	switchView := self buildInstanceClassSwitchView.
	switchView borderWidth: 1.
	topView addSubView: switchView below: classListView.

	messageCategoryListView := PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageCategoryListView toRightOf: classListView.

	messageListView := PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:
		keystroke: #messageListKey:from:.
	messageListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	browserCodeView := MvcTextEditor default on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: width@110).
	topView 
		addSubView: browserCodeView 
		below: (hasSingleFile 
			ifTrue: [switchView]
			ifFalse: [packageListView]).

	infoView := StringHolderView new
		model: self infoString;
		window: (0@0 extent: width@12);
		borderWidth: 1.
	topView addSubView: infoView below: browserCodeView.

	^ topView
! !

!FileContentsBrowser methodsFor: 'creation' stamp: 'sd 11/20/2005 21:27'!
openAsMorph
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| window aListExtent next mySingletonList |
	window := (SystemWindow labelled: 'later') model: self.
	self packages size = 1
		ifTrue: [
			aListExtent := 0.333333 @ 0.34.
			self systemCategoryListIndex: 1.
			mySingletonList := PluggableListMorph on: self list: #systemCategorySingleton
					selected: #indexIsOne changeSelected: #indexIsOne:
					menu: #packageListMenu:
					keystroke: #packageListKey:from:.
			mySingletonList hideScrollBarsIndefinitely.
			window addMorph: mySingletonList frame: (0@0 extent: 1.0@0.06).
			next := 0@0.06]
		ifFalse: [
			aListExtent := 0.25 @ 0.4.
			window addMorph: (PluggableListMorph on: self list: #systemCategoryList
					selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex:
					menu: #packageListMenu:
					keystroke: #packageListKey:from:)
				frame: (0@0 extent: aListExtent).
			next := aListExtent x @ 0].

	self addClassAndSwitchesTo: window at: (next extent: aListExtent) plus: 0.

	next := next + (aListExtent x @ 0).
	window addMorph: (PluggableListMorph on: self list: #messageCategoryList
			selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
			menu: #messageCategoryMenu:)
		frame: (next extent: aListExtent).
	next := next + (aListExtent x @ 0).
	window addMorph: (PluggableListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:
			keystroke: #messageListKey:from:)
		frame: (next extent: aListExtent).

	self addLowerPanesTo: window at: (0@0.4 corner: 1@1) with: nil.
	^ window
! !


!FileContentsBrowser methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'!
methodDiffFor: aString class: aPseudoClass selector: selector meta: meta 
	"Answer the diff between the current copy of the given class/selector/meta for the string provided"

	| theClass source |
	theClass := Smalltalk
				at: aPseudoClass name
				ifAbsent: [^ aString copy].
	meta
		ifTrue: [theClass := theClass class].
	(theClass includesSelector: selector)
		ifFalse: [^ aString copy].
	source := theClass sourceCodeAt: selector.
	^ Cursor wait
		showWhile: [TextDiffBuilder buildDisplayPatchFrom: source to: aString inClass: theClass prettyDiffs: self showingPrettyDiffs]! !

!FileContentsBrowser methodsFor: 'diffs'!
modifiedClassDefinition
	| pClass rClass old new diff |
	pClass := self selectedClassOrMetaClass.
	pClass hasDefinition ifFalse:[^pClass definition].
	rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent:[nil].
	rClass isNil ifTrue:[^pClass definition].
	self metaClassIndicated ifTrue:[ rClass := rClass class].
	old := rClass definition.
	new := pClass definition.
	Cursor wait showWhile:[
		diff := ClassDiffBuilder buildDisplayPatchFrom: old to: new
	].
	^diff! !


!FileContentsBrowser methodsFor: 'edit pane' stamp: 'md 2/13/2006 14:36'!
selectedBytecodes
	"Compile the source code for the selected message selector and extract and return
	the bytecode listing."
	| class selector |
	class := self selectedClassOrMetaClass.
	selector := self selectedMessageName.
	contents := class sourceCodeAt: selector.
	contents := Compiler new
					parse: contents
					in: class
					notifying: nil.
	contents := contents generate.
	^ contents symbolic asText! !

!FileContentsBrowser methodsFor: 'edit pane' stamp: 'nk 2/23/2005 18:00'!
selectedMessage
	"Answer a copy of the source code for the selected message selector."

	| class selector |
	class := self selectedClassOrMetaClass.
	selector := self selectedMessageName.
	contents := class sourceCodeAt: selector.
	Preferences browseWithPrettyPrint 
		ifTrue: 
			[contents := class prettyPrinterClass 
						format: contents
						in: class
						notifying: nil
						decorated: Preferences colorWhenPrettyPrinting].
	self showingAnyKindOfDiffs 
		ifTrue: 
			[contents := self 
						methodDiffFor: contents
						class: self selectedClass
						selector: self selectedMessageName
						meta: self metaClassIndicated].
	^contents asText makeSelectorBoldIn: class! !


!FileContentsBrowser methodsFor: 'fileIn/fileOut'!
fileInClass
	Cursor read showWhile:[
		self selectedClass fileIn.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 6/16/1998 17:14'!
fileInMessage
	
	self selectedMessageName ifNil: [^self].
	Cursor read showWhile: [
		self selectedClassOrMetaClass fileInMethod: self selectedMessageName.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 2/3/1999 18:46'!
fileInMessageCategories
	Cursor read showWhile:[
		self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 5/13/1998 12:50'!
fileInPackage
	Cursor read showWhile:[
		self selectedPackage fileIn.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'ar 9/27/2005 20:07'!
fileIntoNewChangeSet
	| p ff |
	(p := self selectedPackage) ifNil: [^ Beeper beep].
	ff := FileStream readOnlyFileNamed: p fullPackageName.
	ChangeSet newChangesFromStream: ff named: p packageName! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut'!
fileOutClass
	Cursor write showWhile:[
		self selectedClass fileOut.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 6/16/1998 17:14'!
fileOutMessage

	self selectedMessageName ifNil: [^self].
	Cursor write showWhile: [
		self selectedClassOrMetaClass fileOutMethod: self selectedMessageName].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 2/3/1999 18:46'!
fileOutMessageCategories
	Cursor write showWhile:[
		self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 5/13/1998 14:19'!
fileOutPackage
	Cursor write showWhile:[
		self selectedPackage fileOut.
	].! !


!FileContentsBrowser methodsFor: 'infoView' stamp: 'sma 5/6/2000 19:19'!
extraInfo
	^ (self
		methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName)
		class: self selectedClass
		selector: self selectedMessageName
		meta: self metaClassIndicated) unembellished
			ifTrue: [' - identical']
			ifFalse: [' - modified']! !

!FileContentsBrowser methodsFor: 'infoView'!
infoString
	^infoString isNil
		ifTrue:[infoString := StringHolder new]
		ifFalse:[infoString]! !

!FileContentsBrowser methodsFor: 'infoView' stamp: 'sd 11/20/2005 21:27'!
infoViewContents
	"Answer the string to show in the info view"

	| theClass stamp exists |
	editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage].
	self selectedClass isNil ifTrue: [^ ''].
	theClass := Smalltalk at: self selectedClass name asSymbol ifAbsent: [].
	editSelection == #editClass ifTrue:
		[^ theClass notNil
			ifTrue: ['Class exists already in the system' translated]
			ifFalse: ['New class' translated]].
	editSelection == #editMessage ifFalse: [^ ''].
	(theClass notNil and: [self metaClassIndicated])
		ifTrue: [theClass := theClass class].

	stamp := self selectedClassOrMetaClass stampAt: self selectedMessageName.
	exists := theClass notNil and: [theClass includesSelector: self selectedMessageName].
	^ stamp = 'methodWasRemoved'
		ifTrue:
			[exists
				ifTrue:
					['Existing method removed  by this change-set' translated]
				ifFalse:
					['Removal request for a method that is not present in this image' translated]]
		ifFalse:
			[stamp, ' · ',
				(exists 
					ifTrue: ['Method already exists' translated , self extraInfo]
					ifFalse: ['New method' translated])]! !

!FileContentsBrowser methodsFor: 'infoView'!
packageInfo: p
	| nClasses newClasses oldClasses |
	p isNil ifTrue:[^''].
	nClasses := newClasses := oldClasses := 0.
	p classes do:[:cls|
		nClasses := nClasses + 1.
		(Smalltalk includesKey: (cls name asSymbol))
			ifTrue:[oldClasses := oldClasses + 1]
			ifFalse:[newClasses := newClasses + 1]].
	^nClasses printString,' classes (', newClasses printString, ' new / ', oldClasses printString, ' modified)'! !

!FileContentsBrowser methodsFor: 'infoView' stamp: 'wod 5/19/1998 17:34'!
updateInfoView

	Smalltalk isMorphic 
		ifTrue: [self changed: #infoViewContents]
		ifFalse: [
			self infoString contents: self infoViewContents.
			self infoString changed].! !


!FileContentsBrowser methodsFor: 'initialize-release' stamp: 'dew 9/15/2001 16:19'!
defaultBrowserTitle
	^ 'File Contents Browser'! !


!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:48'!
classListKey: aChar from: view
	aChar == $b ifTrue: [^ self browseMethodFull].
	aChar == $N ifTrue: [^ self browseClassRefs].
	self packageListKey: aChar from: view! !

!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:50'!
messageListKey: aChar from: view
	aChar == $b ifTrue: [^ self browseMethodFull].
	super messageListKey: aChar from: view! !

!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 2/6/2000 12:05'!
packageListKey: aChar from: view
	aChar == $f ifTrue: [^ self findClass].
	self arrowKey: aChar from: view! !


!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 5/6/2000 18:36'!
classListMenu: aMenu

	^ aMenu 
		labels:
'definition
comment
browse full (b)
class refs (N)
fileIn
fileOut
rename...
remove
remove existing'
		lines: #(2 4 6 8)
		selections: #(editClass editComment browseMethodFull browseClassRefs fileInClass fileOutClass renameClass removeClass removeUnmodifiedCategories) 

! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'tpr 3/11/2001 21:26'!
classListMenu: aMenu shifted: ignored
	"Answer the class list menu, ignoring the state of the shift key in this case"

	^ self classListMenu: aMenu! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'sw 11/13/2001 09:12'!
contentsSymbolQuints
	"Answer a list of quintuplets representing information on the alternative views available in the code pane.  For the file-contents browser, the choices are restricted to source and the two diffing options"

	^ self sourceAndDiffsQuintsOnly! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'wod 5/13/1998 17:39'!
messageCategoryMenu: aMenu

	^ aMenu 
		labels:
'fileIn
fileOut
reorganize
add item...
rename...
remove
remove existing'
		lines: #(2 3 6)
		selections: #(fileInMessageCategories fileOutMessageCategories editMessageCategories addCategory renameCategory removeMessageCategory removeUnmodifiedMethods)! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 2/6/2000 12:28'!
messageListMenu: aMenu

	^ aMenu 
		labels:
'fileIn
fileOut
senders (n)
implementors (m)
method inheritance (h)
versions (v)
remove'
		lines: #(2 6)
		selections: #(fileInMessage fileOutMessage
browseSenders browseImplementors methodHierarchy browseVersions
removeMessage).! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 4/22/2000 20:52'!
packageListMenu: aMenu
	^ aMenu 
		labels:
'find class... (f)
fileIn
file into new changeset
fileOut
remove
remove existing'
		lines: #(1 4 5)
		selections: #(findClass fileInPackage fileIntoNewChangeSet fileOutPackage removePackage removeUnmodifiedClasses)! !


!FileContentsBrowser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:27'!
selectedClassOrMetaClass
	"Answer the selected class or metaclass."

	| cls |
	self metaClassIndicated
		ifTrue: [^ (cls := self selectedClass) ifNotNil: [cls metaClass]]
		ifFalse: [^ self selectedClass]! !

!FileContentsBrowser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:27'!
setClassOrganizer
	"Install whatever organization is appropriate"
	| theClass |
	classOrganizer := nil.
	metaClassOrganizer := nil.
	classListIndex = 0 ifTrue: [^ self].
	classOrganizer := (theClass := self selectedClass) organization.
	metaClassOrganizer := theClass metaClass organization.
! !


!FileContentsBrowser methodsFor: 'other' stamp: 'bkv 8/13/2003 23:59'!
browseSenders
	"Create and schedule a message set browser on all senders of the 
	currently selected message selector. Do nothing if no message is selected."

	messageListIndex ~= 0 
		ifTrue: [self systemNavigation browseAllCallsOn: self selectedMessageName]! !

!FileContentsBrowser methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'!
browseVersions
	"Create and schedule a message set browser on all versions of the 
	currently selected message selector."
	| class selector |
	(selector := self selectedMessageName) ifNotNil:
		[class := self selectedClassOrMetaClass.
		(class exists and: [class realClass includesSelector: selector]) ifTrue:
			[VersionsBrowser
				browseVersionsOf: (class realClass compiledMethodAt: selector)
				class: class realClass theNonMetaClass
				meta: class realClass isMeta
				category: self selectedMessageCategoryName
				selector: selector]]! !

!FileContentsBrowser methodsFor: 'other'!
changeMessageCategories: aString 
	"The characters in aString represent an edited version of the the message 
	categories for the selected class. Update this information in the system 
	and inform any dependents that the categories have been changed. This 
	message is invoked because the user had issued the categories command 
	and edited the message categories. Then the user issued the accept 
	command."

	self classOrMetaClassOrganizer changeFromString: aString.
	self unlock.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!FileContentsBrowser methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'!
didCodeChangeElsewhere
	"Determine whether the code for the currently selected method and class has been changed somewhere else."

	| aClass |
	(aClass := self selectedClassOrMetaClass) ifNil: [^ false].

	(aClass isKindOf: PseudoClass) ifTrue: [^ false]. "class not installed"
	^super didCodeChangeElsewhere! !

!FileContentsBrowser methodsFor: 'other' stamp: 'sw 10/1/2001 11:16'!
labelString
	"Answer the string for the window title"

	^ 'File Contents Browser ', (self selectedSystemCategoryName ifNil: [''])! !

!FileContentsBrowser methodsFor: 'other' stamp: 'sma 2/6/2000 12:27'!
methodHierarchy
	(self selectedClassOrMetaClass isNil or:
		[self selectedClassOrMetaClass hasDefinition])
			ifFalse: [super methodHierarchy]! !


!FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'!
removeClass
	| class |
	classListIndex = 0 ifTrue: [^ self].
	class := self selectedClass.
	(self confirm:'Are you certain that you
want to delete the class ', class name, '?') ifFalse:[^self].
	self selectedPackage removeClass: class.
	self classListIndex: 0.
	self changed: #classList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'!
removeMessage
	| messageName |
	messageListIndex = 0
		ifTrue: [^ self].
	self okToChange
		ifFalse: [^ self].
	messageName := self selectedMessageName.
	(self selectedClass confirmRemovalOf: messageName)
		ifFalse: [^ false].
	self selectedClassOrMetaClass removeMethod: self selectedMessageName.
	self messageListIndex: 0.
	self setClassOrganizer.
	"In case organization not cached"
	self changed: #messageList! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'!
removeMessageCategory
	"If a message category is selected, create a Confirmer so the user can 
	verify that the currently selected message category should be removed
 	from the system. If so, remove it."

	| messageCategoryName |
	messageCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageCategoryName := self selectedMessageCategoryName.
	(self messageList size = 0
		or: [self confirm: 'Are you sure you want to
remove this method category 
and all its methods?']) ifFalse: [^ self].
	self selectedClassOrMetaClass removeCategory: messageCategoryName.
	self messageCategoryListIndex: 0.
	self changed: #messageCategoryList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:52'!
removePackage
	systemCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(self confirm: 'Are you sure you want to
remove this package 
and all its classes?') ifFalse:[^self].
	(systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) do:[:el|
		systemOrganizer removeElement: el].
	self packages removeKey: self selectedPackage packageName.
	systemOrganizer removeCategory: self selectedSystemCategoryName.
	self systemCategoryListIndex: 0.
	self changed: #systemCategoryList! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'!
removeUnmodifiedCategories
	| theClass |
	self okToChange ifFalse: [^self].
	theClass := self selectedClass.
	theClass isNil ifTrue: [^self].
	Cursor wait showWhile:
		[theClass removeUnmodifiedMethods: theClass selectors.
		theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors].
	self messageCategoryListIndex: 0.
	self changed: #messageCategoryList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:37'!
removeUnmodifiedClasses
	| packageList |
	self okToChange ifFalse:[^self].
	packageList := self selectedPackage isNil
						ifTrue:[self packages] 
						ifFalse:[Array with: self selectedPackage].
	packageList do:[:package|
		package classes copy do:[:theClass|
			Cursor wait showWhile:[
				theClass removeAllUnmodified.
			].
			theClass hasChanges ifFalse:[
				package removeClass: theClass.
			].
		]].
	self classListIndex: 0.
	self changed: #classList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 2/3/1999 18:47'!
removeUnmodifiedMethods
	| theClass cat |
	self okToChange ifFalse:[^self].
	theClass := self selectedClassOrMetaClass.
	theClass isNil ifTrue:[^self].
	cat := self selectedMessageCategoryName.
	cat isNil ifTrue:[^self].
	Cursor wait showWhile:[
		theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat).
	].
	self messageListIndex: 0.
	self changed: #messageList.! !


!FileContentsBrowser methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:20'!
buildWith: builder
	"Create the ui for the browser"
	| windowSpec listSpec textSpec buttonSpec panelSpec max |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'System Browser'.
	windowSpec children: OrderedCollection new.

	max := self wantsOptionalButtons ifTrue:[0.43] ifFalse:[0.5].
	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #systemCategoryList; 
		getIndex: #systemCategoryListIndex; 
		setIndex: #systemCategoryListIndex:; 
		menu: #packageListMenu:; 
		keyPress: #packageListKey:from:;
		frame: (0@0 corner: 0.25@max).
	windowSpec children add: listSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #classList; 
		getIndex: #classListIndex; 
		setIndex: #classListIndex:; 
		menu: #classListMenu:; 
		keyPress: #classListKey:from:;
		frame: (0.25@0 corner: 0.5@(max-0.1)).
	windowSpec children add: listSpec.

	panelSpec := builder pluggablePanelSpec new.
	panelSpec frame: (0.25@(max-0.1) corner: 0.5@max).
	panelSpec children: OrderedCollection new.
	windowSpec children addLast: panelSpec.

		buttonSpec := builder pluggableButtonSpec new.
		buttonSpec 
			model: self;
			label: 'instance'; 
			state: #instanceMessagesIndicated; 
			action: #indicateInstanceMessages;
			frame: (0@0 corner: 0.4@1).
		panelSpec children addLast: buttonSpec.

		buttonSpec := builder pluggableButtonSpec new.
		buttonSpec 
			model: self;
			label: '?'; 
			state: #classCommentIndicated; 
			action: #plusButtonHit;
			frame: (0.4@0 corner: 0.6@1).
		panelSpec children addLast: buttonSpec.

		buttonSpec := builder pluggableButtonSpec new.
		buttonSpec 
			model: self;
			label: 'class'; 
			state: #classMessagesIndicated; 
			action: #indicateClassMessages;
			frame: (0.6@0 corner: 1@1).
		panelSpec children addLast: buttonSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #messageCategoryList; 
		getIndex: #messageCategoryListIndex; 
		setIndex: #messageCategoryListIndex:; 
		menu: #messageCategoryMenu:; 
		keyPress: #arrowKey:from:;
		frame: (0.5@0 corner: 0.75@max).
	windowSpec children add: listSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #messageList; 
		getIndex: #messageListIndex; 
		setIndex: #messageListIndex:; 
		menu: #messageListMenu:shifted:; 
		keyPress: #messageListKey:from:;
		frame: (0.75@0 corner: 1@max).
	windowSpec children add: listSpec.

	self wantsOptionalButtons ifTrue:[
		panelSpec := self buildOptionalButtonsWith: builder.
		panelSpec frame: (0@0.43 corner: 1@0.5).
		windowSpec children add: panelSpec.
	].

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		getText: #contents; 
		setText: #contents:notifying:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0@0.5corner: 1@0.92).
	windowSpec children add: textSpec.

	textSpec := builder pluggableInputFieldSpec new.
	textSpec 
		model: self;
		getText: #infoViewContents; 
		frame: (0@0.92corner: 1@1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !

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

FileContentsBrowser class
	instanceVariableNames: ''!

!FileContentsBrowser class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 18:17'!
initialize

	FileList registerFileReader: self! !

!FileContentsBrowser class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !


!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:41'!
fileReaderServicesForDirectory: aDirectory
	^{ self serviceBrowseCodeFiles }! !

!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 2/17/2004 19:18'!
fileReaderServicesForFile: fullName suffix: suffix

	((FileStream isSourceFileSuffix: suffix) or: [ suffix = '*' ])
		ifTrue: [ ^Array with: self serviceBrowseCode].

	^(fullName endsWith: 'cs.gz')
		ifTrue: [ Array with: self serviceBrowseCompressedCode ]
		ifFalse: [#()]
! !

!FileContentsBrowser class methodsFor: 'file list services' stamp: 'rbb 3/1/2005 10:53'!
selectAndBrowseFile: aFileList
	"When no file are selected you can ask to browse several of them"

	| selectionPattern files |
	selectionPattern := UIManager default request:'What files?' initialAnswer: '*.cs;*.st'.
	files := (aFileList directory fileNamesMatching: selectionPattern) 
				collect: [:each | aFileList directory fullNameFor: each].
	self browseFiles: files.


! !

!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 4/29/2004 10:35'!
serviceBrowseCode
	"Answer the service of opening a file-contents browser"

	^ (SimpleServiceEntry
		provider: self 
		label: 'code-file browser'
		selector: #browseStream:
		description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code'
		buttonLabel: 'code')
		argumentGetter: [ :fileList | fileList readOnlyStream ]! !

!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:35'!
serviceBrowseCodeFiles

	^  (SimpleServiceEntry 
		provider: self
		label: 'browse code files' 
		selector: #selectAndBrowseFile:)
		argumentGetter: [ :fileList | fileList ];
		yourself! !

!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 4/29/2004 10:35'!
serviceBrowseCompressedCode
	"Answer a service for opening a changelist browser on a file"

	^ (SimpleServiceEntry 
		provider: self 
		label: 'code-file browser'
		selector: #browseCompressedCodeStream:
		description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code'
		buttonLabel: 'code')
		argumentGetter: [ :fileList | fileList readOnlyStream ]! !

!FileContentsBrowser class methodsFor: 'file list services' stamp: 'md 11/23/2004 13:34'!
services
	"Answer potential file services associated with this class"

	^ {self serviceBrowseCode}.! !


!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'tak 3/16/2005 11:37'!
browseCompressedCodeStream: aStandardFileStream 
	"Browse the selected file in fileIn format."
	| zipped unzipped |
	[zipped := GZipReadStream on: aStandardFileStream.
	unzipped := MultiByteBinaryOrTextStream with: zipped contents asString]
		ensure: [aStandardFileStream close].
	unzipped reset.
	self browseStream: unzipped named: aStandardFileStream name! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
browseFiles: fileList

	| package organizer packageDict browser |
	Cursor wait showWhile: [
		packageDict := Dictionary new.
		organizer := SystemOrganizer defaultList: Array new.
		fileList do: [:fileName |
			package := FilePackage fromFileNamed: fileName.
			packageDict 
				at: package packageName 
				put: package.
			organizer 
				classifyAll: package classes keys 
				under: package packageName].
		(browser := self systemOrganizer: organizer)
			packages: packageDict].
	self
		openBrowserView: browser createViews
		label: 'File Contents Browser'.
! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nb 6/17/2003 12:25'!
browseFile: aFilename
	"Open a file contents browser on a file of the given name"

	aFilename ifNil: [^ Beeper beep].
	self browseFiles: (Array with: aFilename)! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'edc 5/12/2006 07:09'!
browseStream: aStream
aStream setConverterForCode.
	self browseStream: aStream named: aStream name! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
browseStream: aStream named: aString

	| package organizer packageDict browser |
	Cursor wait showWhile: [
		packageDict := Dictionary new.
		browser := self new.
		organizer := SystemOrganizer defaultList: Array new.
		package := (FilePackage new fullName: aString; fileInFrom: aStream).
		packageDict 
			at: package packageName 
			put: package.
		organizer 
			classifyAll: package classes keys 
			under: package packageName.
		(browser := self systemOrganizer: organizer)
			packages: packageDict].
	self
		openBrowserView: browser createViews
		label: 'File Contents Browser'.
! !


!FileContentsBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:25'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'File Contents Browser' brightColor: #tan pastelColor: #paleTan helpMessage: 'Lets you view the contents of a file as code, in a browser-like tool.'! !
Object subclass: #FileDirectory
	instanceVariableNames: 'pathName'
	classVariableNames: 'DefaultDirectory DirectoryClass StandardMIMEMappings'
	poolDictionaries: ''
	category: 'Files-Directories'!
!FileDirectory commentStamp: '<historical>' prior: 0!
A FileDirectory represents a folder or directory in the underlying platform's file system. It carries a fully-qualified path name for the directory it represents, and can enumerate the files and directories within that directory.

A FileDirectory can be thought of as a Dictionary whose keys are the local names of files in that directory, and whose values are directory "entries". Each entry is an array of five items:

	<name> <creationTime> <modificationTime> <dirFlag> <fileSize>

The times are given in seconds, and can be converted to a time and date via Time>dateAndTimeFromSeconds:. See the comment in lookupEntry:... which provides primitive access to this information.
!


!FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'!
containingDirectory
	"Return the directory containing this directory."

	^ FileDirectory on: (FileDirectory dirPathFor: pathName asSqueakPathName)
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'nk 2/23/2001 11:35'!
directoryEntry
	^self containingDirectory entryAt: self localName! !

!FileDirectory methodsFor: 'enumeration' stamp: 'stephaneducasse 2/4/2006 20:31'!
directoryEntryFor: filenameOrPath
	"Answer the directory entry for the given file or path. Sorta like a poor man's stat()."
	| fName dir |
	DirectoryClass splitName: filenameOrPath to:[:filePath :name |
		fName := name.
		filePath isEmpty
			ifTrue: [dir := self]
			ifFalse: [dir := FileDirectory on: filePath]].
	self isCaseSensitive 
		ifTrue:[^dir entries detect:[:entry| entry name = fName] ifNone:[nil]]
		ifFalse:[^dir entries detect:[:entry| entry name sameAs: fName] ifNone:[nil]]! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:46'!
directoryNamed: localFileName
	"Return the subdirectory of this directory with the given name."

	^ FileDirectory on: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:44'!
directoryNames
	"Return a collection of names for the subdirectories of this directory."
	"FileDirectory default directoryNames"

	^ (self entries select: [:entry | entry at: 4])
		collect: [:entry | entry first]
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 12:23'!
entries
	"Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: (<name><creationTime><modificationTime><dirFlag><fileSize>). See primLookupEntryIn:index: for further details."
	"FileDirectory default entries"

	^ self directoryContentsFor: pathName
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:39'!
fileAndDirectoryNames
	"FileDirectory default fileAndDirectoryNames"

	^ self entries collect: [:entry | entry first]
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:44'!
fileNames
	"Return a collection of names for the files (but not directories) in this directory."
	"FileDirectory default fileNames"

	^ (self entries select: [:entry | (entry at: 4) not])
		collect: [:entry | entry first]
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'!
fullName
	"Return the full name of this directory."

	^pathName asSqueakPathName
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'stephaneducasse 2/4/2006 20:31'!
fullNamesOfAllFilesInSubtree
	"Answer a collection containing the full names of all the files in the subtree of the file system whose root is this directory."

	| result todo dir |
	result := OrderedCollection new: 100.
	todo := OrderedCollection with: self.
	[todo size > 0] whileTrue: [
		dir := todo removeFirst.
		dir fileNames do: [:n | result add: (dir fullNameFor: n)].
		dir directoryNames do: [:n | todo add: (dir directoryNamed: n)]].
	^ result asArray
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:39'!
keysDo: nameBlock
	"Evaluate the given block for each file or directory name in this directory."

	^ self fileAndDirectoryNames do: nameBlock
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'!
localName
	"Return the local name of this directory."

	^FileDirectory localNameFor: pathName asSqueakPathName! !

!FileDirectory methodsFor: 'enumeration' stamp: 'mir 8/24/2001 12:01'!
matchingEntries: criteria
	"Ignore the filter criteria for now"
	^self entries! !

!FileDirectory methodsFor: 'enumeration' stamp: 'stephaneducasse 2/4/2006 20:31'!
statsForDirectoryTree: rootedPathName
	"Return the size statistics for the entire directory tree starting at the given root. The result is a three element array of the form: (<number of folders><number of files><total bytes in all files>). This method also serves as an example of how recursively enumerate a directory tree."
	"wod 6/16/1998: add Cursor wait, and use 'self pathNameDelimiter asString' rather than hardwired ':' "
	"FileDirectory default statsForDirectoryTree: '\smalltalk'"

	| dirs files bytes todo p entries |
	Cursor wait showWhile: [
		dirs := files := bytes := 0.
		todo := OrderedCollection with: rootedPathName.
		[todo isEmpty] whileFalse: [
			p := todo removeFirst.
			entries := self directoryContentsFor: p.
			entries do: [:entry |
				(entry at: 4)
					ifTrue: [
						todo addLast: (p, self pathNameDelimiter asString, (entry at: 1)).
						dirs := dirs + 1]
					ifFalse: [
						files := files + 1.
						bytes := bytes + (entry at: 5)]]]].

	^ Array with: dirs with: files with: bytes
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'stephaneducasse 2/4/2006 20:31'!
withAllSubdirectoriesCollect: aBlock
	"Evaluate aBlock with each of the directories in the subtree of the file system whose root is this directory.
	Answer the results of these evaluations."

	| result todo dir |
	result := OrderedCollection new: 100.
	todo := OrderedCollection with: self.
	[todo size > 0] whileTrue: [
		dir := todo removeFirst.
		result add: (aBlock value: dir).
		dir directoryNames do: [:n | todo add: (dir directoryNamed: n)]].
	^ result
! !


!FileDirectory methodsFor: 'file directory' stamp: 'hg 2/2/2002 16:37'!
assureExistence
	"Make sure the current directory exists. If necessary, create all parts in between"

	self containingDirectory assureExistenceOfPath: self localName! !

!FileDirectory methodsFor: 'file directory' stamp: 'stephaneducasse 2/4/2006 20:31'!
assureExistenceOfPath: lPath
	"Make sure the local directory exists. If necessary, create all parts in between"
	| localPath |
	localPath := lPath.
	localPath isEmpty ifTrue: [ ^self ]. "Assumed to exist"
	(self directoryExists: localPath) ifTrue: [^ self]. "exists"
	"otherwise check parent first and then create local dir"
	self containingDirectory assureExistenceOfPath: self localName.
	self createDirectory: localPath! !

!FileDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:47'!
localNameFor: fullName
	"Return the local part the given name."

	^self class localNameFor: fullName! !

!FileDirectory methodsFor: 'file directory' stamp: 'tk 12/13/1999 18:55'!
sleep
	"Leave the FileList window.  Do nothing.  Disk directories do not have to be shut down."
! !

!FileDirectory methodsFor: 'file directory' stamp: 'di 2/11/2000 22:37'!
wakeUp
	"Entering a FileList window.  Do nothing.  Disk directories do not have to be awakened."
! !


!FileDirectory methodsFor: 'file name utilities' stamp: 'gk 2/10/2004 13:22'!
asUrl
	"Convert my path into a file:// type url - a FileUrl."
	
	^FileUrl pathParts: (self pathParts copyWith: '')! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'!
checkName: aFileName fixErrors: fixing
	"Check a string aFileName for validity as a file name. Answer the original file name if it is valid. If the name is not valid (e.g., it is too long or contains illegal characters) and fixing is false, raise an error. If fixing is true, fix the name (usually by truncating and/or tranforming characters), and answer the corrected name. The default behavior is just to truncate the name to the maximum length for this platform. Subclasses can do any kind of checking and correction appropriate for their platform."

	| maxLength |
	aFileName size = 0 ifTrue: [self error: 'zero length file name'].
	maxLength := self class maxFileNameLength.
	aFileName size > maxLength ifTrue: [
		fixing
			ifTrue: [^ aFileName contractTo: maxLength]
			ifFalse: [self error: 'file name is too long']].

	^ aFileName
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'!
fileNamesMatching: pat
	"
	FileDirectory default fileNamesMatching: '*'
	FileDirectory default fileNamesMatching: '*.image;*.changes'
	"
	
	| files |
	files := OrderedCollection new.
	
	(pat findTokens: ';', String crlf) do: [ :tok | 
		files addAll: (self fileNames select: [:name | tok match: name]) ].
	
	^files
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'!
fullNameFor: fileName
	"Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name."
	"Details: Note that path relative to a directory, such as '../../foo' are disallowed by this algorithm.  Also note that this method is tolerent of a nil argument -- is simply returns nil in this case."

	| correctedLocalName prefix |
	fileName ifNil: [^ nil].
	DirectoryClass splitName: fileName to:
		[:filePath :localName |
			correctedLocalName := localName isEmpty 
				ifFalse: [self checkName: localName fixErrors: true]
				ifTrue: [localName].
			prefix := self fullPathFor: filePath].
	prefix isEmpty
		ifTrue: [^correctedLocalName].
	prefix last = self pathNameDelimiter
		ifTrue:[^ prefix, correctedLocalName]
		ifFalse:[^ prefix, self slash, correctedLocalName]! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'jm 12/4/97 21:19'!
isLegalFileName: aString 
	"Answer true if the given string is a legal file name."

	^ (self checkName: aString fixErrors: true) = aString
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'ar 2/27/2001 22:23'!
isTypeFile
	^true! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'!
lastNameFor: baseFileName extension: extension
	"Assumes a file name includes a version number encoded as '.' followed by digits 
	preceding the file extension.  Increment the version number and answer the new file name.
	If a version number is not found, set the version to 1 and answer a new file name"

	| files splits |

	files := self fileNamesMatching: (baseFileName,'*', self class dot, extension).
	splits := files 
			collect: [:file | self splitNameVersionExtensionFor: file]
			thenSelect: [:split | (split at: 1) = baseFileName].
	splits := splits asSortedCollection: [:a :b | (a at: 2) < (b at: 2)].
	^splits isEmpty 
			ifTrue: [nil]
			ifFalse: [(baseFileName, '.', (splits last at: 2) asString, self class dot, extension) asFileName]! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'!
nextNameFor: baseFileName extension: extension
	"Assumes a file name includes a version number encoded as '.' followed by digits 
	preceding the file extension.  Increment the version number and answer the new file name.
	If a version number is not found, set the version to 1 and answer a new file name"

	| files splits version |

	files := self fileNamesMatching: (baseFileName,'*', self class dot, extension).
	splits := files 
			collect: [:file | self splitNameVersionExtensionFor: file]
			thenSelect: [:split | (split at: 1) = baseFileName].
	splits := splits asSortedCollection: [:a :b | (a at: 2) < (b at: 2)].
	splits isEmpty 
			ifTrue: [version := 1]
			ifFalse: [version := (splits last at: 2) + 1].
	^ (baseFileName, '.', version asString, self class dot, extension) asFileName! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'!
realUrl
	"Senders expect url without trailing slash - #url returns slash"
	| url |
	url := self url.
	url last = $/ ifTrue:[^url copyFrom: 1 to: url size-1].
	^url! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'yo 12/19/2003 21:15'!
relativeNameFor: aFileName
	"Return the full name for aFileName, assuming that aFileName is a name relative to me."
	aFileName isEmpty ifTrue: [ ^pathName asSqueakPathName].
	^aFileName first = self pathNameDelimiter
		ifTrue: [ pathName asSqueakPathName, aFileName ]
		ifFalse: [ pathName asSqueakPathName, self slash, aFileName ]
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'!
splitNameVersionExtensionFor: fileName
	" answer an array with the root name, version # and extension.
	See comment in nextSequentialNameFor: for more details"

	| baseName version extension i j |

	baseName := self class baseNameFor: fileName.
	extension := self class extensionFor: fileName.
	i := j := baseName findLast: [:c | c isDigit not].
	i = 0
		ifTrue: [version := 0]
		ifFalse:
			[(baseName at: i) = $.
				ifTrue:
					[version := (baseName copyFrom: i+1 to: baseName size) asNumber.
					j := j - 1]
				ifFalse: [version := 0].
			baseName := baseName copyFrom: 1 to: j].
	^ Array with: baseName with: version with: extension! !


!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
copyFileNamed: fileName1 toFileNamed: fileName2
	"Copy the contents of the existing file with the first name into a new file with the second name. Both files are assumed to be in this directory."
	"FileDirectory default copyFileNamed: 'todo.txt' toFileNamed: 'todocopy.txt'"

	| file1 file2 |
	file1 := (self readOnlyFileNamed: fileName1) binary.
	file2 := (self newFileNamed: fileName2) binary.
	self copyFile: file1 toFile: file2.
	file1 close.
	file2 close.
! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
copyFileWithoutOverwriteConfirmationNamed: fileName1 toFileNamed: fileName2
	"Copy the contents of the existing file with the first name into a file with the second name (which may or may not exist). If the second file exists, force an overwrite without confirming.  Both files are assumed to be in this directory."
	"FileDirectory default copyFileWithoutOverwriteConfirmationNamed: 'todo.txt' toFileNamed: 'todocopy.txt'"

	| file1 file2 |
	fileName1 = fileName2 ifTrue: [^ self].
	file1 := (self readOnlyFileNamed: fileName1) binary.
	file2 := (self forceNewFileNamed: fileName2) binary.
	self copyFile: file1 toFile: file2.
	file1 close.
	file2 close.! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
copyFile: fileStream1 toFile: fileStream2
	| buffer |
	buffer := String new: 50000.
	[fileStream1 atEnd] whileFalse:
		[fileStream2 nextPutAll: (fileStream1 nextInto: buffer)].
! !

!FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:33'!
createDirectory: localFileName
	"Create a directory with the given name in this directory. Fail if the name is bad or if a file or directory with that name already exists."

 	self primCreateDirectory: (self fullNameFor: localFileName) asVmPathName
! !

!FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:33'!
deleteDirectory: localDirName
	"Delete the directory with the given name in this directory. Fail if the path is bad or if a directory by that name does not exist."

 	self primDeleteDirectory: (self fullNameFor: localDirName) asVmPathName.
! !

!FileDirectory methodsFor: 'file operations' stamp: 'jm 12/5/97 16:33'!
deleteFileNamed: localFileName
	"Delete the file with the given name in this directory."

	self deleteFileNamed: localFileName ifAbsent: [].
! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
deleteFileNamed: localFileName ifAbsent: failBlock
	"Delete the file of the given name if it exists, else evaluate failBlock.
	If the first deletion attempt fails do a GC to force finalization of any lost references. ar 3/21/98 17:53"
	| fullName |
	fullName := self fullNameFor: localFileName.
	(StandardFileStream 
		retryWithGC:[self primDeleteFileNamed: (self fullNameFor: localFileName) asVmPathName]
		until:[:result| result notNil]
		forFileNamed: fullName) == nil
			ifTrue: [^failBlock value].
! !

!FileDirectory methodsFor: 'file operations' stamp: 'tpr 3/26/2002 16:48'!
deleteLocalFiles
	"Delete the local files in this directory."

	self fileNames do:[:fn| self deleteFileNamed: fn ifAbsent: [(CannotDeleteFileException new
			messageText: 'Could not delete the old version of file ' , (self fullNameFor: fn)) signal]]
! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
fileOrDirectoryExists: filenameOrPath
	"Answer true if either a file or a directory file of the given name exists. The given name may be either a full path name or a local name within this directory."
	"FileDirectory default fileOrDirectoryExists: Smalltalk sourcesName"

	| fName dir |
	DirectoryClass splitName: filenameOrPath to:
		[:filePath :name |
			fName := name.
			filePath isEmpty
				ifTrue: [dir := self]
				ifFalse: [dir := FileDirectory on: filePath]].

	^ (dir includesKey: fName) or: [ fName = '' and:[ dir entries size > 1]]! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
getMacFileTypeAndCreator: fileName 
	| results typeString creatorString |
	"get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)."
	"FileDirectory default getMacFileNamed: 'foo'"

	typeString := ByteArray new: 4 withAll: ($? asInteger).
	creatorString := ByteArray new: 4 withAll: ($? asInteger).
	[self primGetMacFileNamed: (self fullNameFor: fileName) asVmPathName
		type: typeString
		creator: creatorString.] ensure: 
		[typeString := typeString asString. 
		creatorString := creatorString asString].
	results := Array with: typeString convertFromSystemString with: creatorString convertFromSystemString.
	^results
! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
mimeTypesFor: fileName
	"Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type"

	| idx ext dot |
	ext := ''.
	dot := self class extensionDelimiter.
	idx := fileName findLast: [:ch| ch = dot].
	idx = 0 ifFalse: [ext := fileName copyFrom: idx+1 to: fileName size].
	^ StandardMIMEMappings at: ext asLowercase ifAbsent: [nil]! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
putFile: file1 named: destinationFileName
	"Copy the contents of the existing fileStream into the file destinationFileName in this directory.  fileStream can be anywhere in the fileSystem."

	| file2 |
	file1 binary.
	(file2 := self newFileNamed: destinationFileName) ifNil: [^ false].
	file2 binary.
	self copyFile: file1 toFile: file2.
	file1 close.
	file2 close.
	^ true
! !

!FileDirectory methodsFor: 'file operations' stamp: 'tk 2/26/2000 12:54'!
putFile: file1 named: destinationFileName retry: aBool
	"Copy the contents of the existing fileStream into the file destinationFileName in this directory.  fileStream can be anywhere in the fileSystem.  No retrying for local file systems."

	^ self putFile: file1 named: destinationFileName
! !

!FileDirectory methodsFor: 'file operations' stamp: 'tpr 3/26/2002 18:09'!
recursiveDelete
	"Delete the this directory, recursing down its tree."
	self directoryNames
		do: [:dn | (self directoryNamed: dn) recursiveDelete].
	self deleteLocalFiles.
	"should really be some exception handling for directory deletion, but no 
	support for it yet"
	self containingDirectory deleteDirectory: self localName! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
rename: oldFileName toBe: newFileName
	| selection oldName newName |
	"Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name."
	"Modified for retry after GC ar 3/21/98 18:09"
	oldName := self fullNameFor: oldFileName.
	newName := self fullNameFor: newFileName.
	(StandardFileStream 
		retryWithGC:[self primRename: oldName asVmPathName to: newName asVmPathName]
		until:[:result| result notNil]
		forFileNamed: oldName) ~~ nil ifTrue:[^self].
	(self fileExists: oldFileName) ifFalse:[
		^self error:'Attempt to rename a non-existent file'.
	].
	(self fileExists: newFileName) ifTrue:[
		selection := (PopUpMenu labels:
'delete old version
cancel')
				startUpWithCaption: 'Trying to rename a file to be
', newFileName , '
and it already exists.'.
		selection = 1 ifTrue:
			[self deleteFileNamed: newFileName.
			^ self rename: oldFileName toBe: newFileName]].
	^self error:'Failed to rename file'.! !

!FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:34'!
setMacFileNamed: fileName type: typeString creator: creatorString
	"Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)."
	"FileDirectory default setMacFileNamed: 'foo' type: 'TEXT' creator: 'ttxt'"

 	self primSetMacFileNamed: (self fullNameFor: fileName) asVmPathName
		type: typeString convertToSystemString
		creator: creatorString convertToSystemString.
! !

!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
upLoadProject: projectFile named: destinationFileName resourceUrl: resUrl retry: aBool
	"Copy the contents of the existing fileStream into the file destinationFileName in this directory.  fileStream can be anywhere in the fileSystem.  No retrying for local file systems."

	| result |
	result := self putFile: projectFile named: destinationFileName.
	[self
		setMacFileNamed: destinationFileName
		type: 'SOBJ'
		creator: 'FAST']
		on: Error
		do: [ "ignore" ].
	^result! !


!FileDirectory methodsFor: 'file status' stamp: 'mdr 1/14/2000 21:16'!
entryAt: fileName  
	"find the entry with local name fileName"

	^self entryAt: fileName ifAbsent: [ self error: 'file not in directory: ', fileName ].! !

!FileDirectory methodsFor: 'file status' stamp: 'stephaneducasse 2/4/2006 20:31'!
entryAt: fileName ifAbsent: aBlock
	"Find the entry with local name fileName and answer it.
	If not found, answer the result of evaluating aBlock."

	| comparisonBlock |
	self isCaseSensitive
		ifTrue: [comparisonBlock := [:entry | (entry at: 1) = fileName]]
		ifFalse: [comparisonBlock := [:entry | (entry at: 1) sameAs: fileName]].
	^ self entries detect: comparisonBlock ifNone: [aBlock value]! !


!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'!
fileNamed: localFileName
	"Open the file with the given name in this directory for writing."

	^ FileStream concreteStream fileNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'dew 10/26/2000 02:08'!
forceNewFileNamed: localFileName
	"Open the file with the given name in this directory for writing.  If it already exists, delete it first without asking."

	^ FileStream concreteStream forceNewFileNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'!
newFileNamed: localFileName
	"Create a new file with the given name in this directory."

	^ FileStream concreteStream newFileNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'!
oldFileNamed: localFileName
	"Open the existing file with the given name in this directory."

	^ FileStream concreteStream oldFileNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'rop 3/14/2004 13:52'!
oldFileOrNoneNamed: localFileName
	"If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil."

	^ FileStream concreteStream oldFileOrNoneNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'!
readOnlyFileNamed: localFileName
	"Open the existing file with the given name in this directory for read-only access."

	^ FileStream concreteStream readOnlyFileNamed: (self fullNameFor: localFileName)
! !


!FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'!
fullPathFor: path
	^path isEmpty ifTrue:[pathName asSqueakPathName] ifFalse:[path]! !

!FileDirectory methodsFor: 'path access' stamp: 'tk 5/18/1998 22:29'!
on: fullPath
	"Return another instance"

	^ self class on: fullPath! !

!FileDirectory methodsFor: 'path access' stamp: 'stephaneducasse 2/4/2006 20:31'!
pathFromUrl: aFileUrl
	| first |
	^String streamContents: [ :s |
		first := false.
		aFileUrl path do: [ :p |
			first ifTrue: [ s nextPut: self pathNameDelimiter ].
			first := true.
			s nextPutAll: p ] ].! !

!FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'!
pathName
	"Return the path from the root of the file system to this directory."

	^ pathName asSqueakPathName.

! !

!FileDirectory methodsFor: 'path access' stamp: 'jm 12/5/97 12:19'!
pathNameDelimiter
	"Return the delimiter character for this kind of directory. This depends on the current platform."

	^ self class pathNameDelimiter
! !

!FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'!
pathParts
	"Return the path from the root of the file system to this directory as an array of directory names."

	^ pathName asSqueakPathName findTokens: self pathNameDelimiter asString! !

!FileDirectory methodsFor: 'path access' stamp: 'ar 12/18/1999 00:36'!
slash
	^self class slash! !


!FileDirectory methodsFor: 'printing' stamp: 'yo 12/19/2003 21:15'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	aStream nextPutAll: self class name.
	aStream nextPutAll: ' on '.
	pathName asSqueakPathName printOn: aStream.
! !


!FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 16:09'!
eToyBaseFolderSpec
	^ServerDirectory eToyBaseFolderSpecForFileDirectory: self! !

!FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 16:09'!
eToyBaseFolderSpec: aString
	^ServerDirectory eToyBaseFolderSpecForFileDirectory: self put: aString! !

!FileDirectory methodsFor: 'school support' stamp: 'stephaneducasse 2/4/2006 20:31'!
eToyUserList
	| spec index fd list match |
	spec := self eToyBaseFolderSpec. "something like 'U:\Squeak\users\*-Squeak'."
	spec ifNil:[^ServerDirectory eToyUserListForFileDirectory: self].
	"Compute list of users based on base folder spec"
	index := spec indexOf: $*. "we really need one"
	index = 0 ifTrue:[^ServerDirectory eToyUserListForFileDirectory: self].
	fd := FileDirectory on: (FileDirectory dirPathFor: (spec copyFrom: 1 to: index)).
	"reject all non-directories"
	list := fd entries select:[:each| each isDirectory].
	"reject all non-matching entries"
	match := spec copyFrom: fd pathName size + 2 to: spec size.
	list := list collect:[:each| each name].
	list := list select:[:each| match match: each].
	"extract the names (e.g., those positions that match '*')"
	index := match indexOf: $*.
	list := list collect:[:each|
		each copyFrom: index to: each size - (match size - index)].
	^list! !

!FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 15:41'!
eToyUserListUrl
	^ServerDirectory eToyUserListUrlForFileDirectory: self! !

!FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 15:48'!
eToyUserListUrl: urlString
	^ServerDirectory eToyUserListUrlForFileDirectory: self put: urlString.! !

!FileDirectory methodsFor: 'school support' stamp: 'stephaneducasse 2/4/2006 20:31'!
eToyUserName: aString
	"Set the default directory from the given user name"
	| dirName |
	dirName := self eToyBaseFolderSpec. "something like 'U:\Squeak\users\*-Squeak'"
	dirName ifNil:[^self].
	dirName := dirName copyReplaceAll:'*' with: aString.
"	dirName last = self class pathNameDelimiter ifFalse:[dirName := dirName, self slash].
	FileDirectory setDefaultDirectoryFrom: dirName.
	dirName := dirName copyFrom: 1 to: dirName size - 1.

"	pathName := FilePath pathName: dirName! !

!FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 16:13'!
hasEToyUserList
	^self eToyUserListUrl notNil or:[self eToyBaseFolderSpec notNil]! !


!FileDirectory methodsFor: 'searching' stamp: 'stephaneducasse 2/4/2006 20:31'!
filesContaining: searchString caseSensitive: aBoolean
	| aList |
	"Search the contents of all files in the receiver and its subdirectories for the search string.  Return a list of paths found.  Make the search case sensitive if aBoolean is true."

	aList := OrderedCollection new.
	self withAllFilesDo: [:stream |
			(stream contentsOfEntireFile includesSubstring: searchString caseSensitive: aBoolean)
				ifTrue:	[aList add: stream name]]
		andDirectoriesDo: [:d | d pathName].
	^ aList

"FileDirectory default filesContaining: 'includesSubstring:'  caseSensitive: true"! !

!FileDirectory methodsFor: 'searching' stamp: 'stephaneducasse 2/4/2006 20:31'!
withAllFilesDo: fileStreamBlock andDirectoriesDo: directoryBlock

	"For the receiver and all it's subdirectories evaluate directoryBlock.
	For a read only file stream on each file within the receiver 
	and it's subdirectories evaluate fileStreamBlock."

	| todo dir |

	todo := OrderedCollection with: self.
	[todo size > 0] whileTrue: [
		dir := todo removeFirst.
		directoryBlock value: dir.
		dir fileNames do: [: n | 
			fileStreamBlock value: 
				(FileStream readOnlyFileNamed: (dir fullNameFor: n))].
		dir directoryNames do: [: n | 
			todo add: (dir directoryNamed: n)]]

! !


!FileDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/17/2000 14:57'!
directoryObject

	^self! !

!FileDirectory methodsFor: 'squeaklets' stamp: 'mir 6/17/2001 23:42'!
downloadUrl
	^''! !

!FileDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/12/2000 17:18'!
updateProjectInfoFor: aProject

	"only swiki servers for now"! !

!FileDirectory methodsFor: 'squeaklets' stamp: 'dgd 12/23/2003 16:21'!
writeProject: aProject inFileNamed: fileNameString fromDirectory: localDirectory 
	"write aProject (a file version can be found in the file named fileNameString in localDirectory)"
	aProject
		writeFileNamed: fileNameString
		fromDirectory: localDirectory
		toServer: self! !


!FileDirectory methodsFor: 'testing' stamp: 'mir 6/25/2001 13:08'!
acceptsUploads
	^true! !

!FileDirectory methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:31'!
directoryExists: filenameOrPath
	"Answer true if a directory of the given name exists. The given name may be either a full path name or a local directory within this directory."
	"FileDirectory default directoryExists: FileDirectory default pathName"

	| fName dir |
	DirectoryClass splitName: filenameOrPath to:
		[:filePath :name |
			fName := name.
			filePath isEmpty
				ifTrue: [dir := self]
				ifFalse: [dir := self directoryNamed: filePath]].

	^dir exists and: [
		self isCaseSensitive 
			ifTrue:[dir directoryNames includes: fName]
			ifFalse:[dir directoryNames anySatisfy: [:name| name sameAs: fName]]].
! !

!FileDirectory methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:31'!
exists
"Answer whether the directory exists"

	| result |
	result := self primLookupEntryIn: pathName asVmPathName index: 1.
	^ result ~= #badDirectoryPath
! !

!FileDirectory methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:31'!
fileExists: filenameOrPath
	"Answer true if a file of the given name exists. The given name may be either a full path name or a local file within this directory."
	"FileDirectory default fileExists: Smalltalk sourcesName"

	| fName dir |
	DirectoryClass splitName: filenameOrPath to:
		[:filePath :name |
			fName := name.
			filePath isEmpty
				ifTrue: [dir := self]
				ifFalse: [dir := FileDirectory on: filePath]].
	self isCaseSensitive 
		ifTrue:[^dir fileNames includes: fName]
		ifFalse:[^dir fileNames anySatisfy: [:name| name sameAs: fName]].	! !

!FileDirectory methodsFor: 'testing' stamp: 'di 11/21/1999 20:17'!
includesKey: localName
	"Answer true if this directory includes a file or directory of the given name. Note that the name should be a local file name, in contrast with fileExists:, which takes either local or full-qualified file names."
	"(FileDirectory on: Smalltalk vmPath) includesKey: 'SqueakV2.sources'"
	self isCaseSensitive
		ifTrue:[^ self fileAndDirectoryNames includes: localName]
		ifFalse:[^ self fileAndDirectoryNames anySatisfy: [:str| str sameAs: localName]].! !

!FileDirectory methodsFor: 'testing' stamp: 'ar 5/30/2001 21:42'!
isAFileNamed: fName
	^FileStream isAFileNamed: (self fullNameFor: fName)! !

!FileDirectory methodsFor: 'testing' stamp: 'ar 5/1/1999 01:51'!
isCaseSensitive
	"Return true if file names are treated case sensitive"
	^self class isCaseSensitive! !

!FileDirectory methodsFor: 'testing' stamp: 'dgd 12/27/2003 10:46'!
isRemoteDirectory
	"answer whatever the receiver is a remote directory"
	^ false! !


!FileDirectory methodsFor: '*MorphicExtras-file name utilities' stamp: 'fbs 2/2/2005 13:22'!
url
	"Convert my path into a file:// type url String."
	
	^self asUrl asString.! !


!FileDirectory methodsFor: '*network-uri' stamp: 'mir 10/20/2003 16:03'!
uri
	"Convert my path into a file:// type url.  Use slash instead of the local delimiter (:), and convert odd characters to %20 notation."

	"If slash (/) is not the file system delimiter, encode slashes before converting."
	| list |
	list _ self pathParts.
	^(String streamContents: [:strm |
		strm nextPutAll: 'file:'.
		list do: [:each | strm nextPut: $/; nextPutAll: each "encodeForHTTP"].
		strm nextPut: $/]) asURI! !


!FileDirectory 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 index done entryArray f |
	entries := OrderedCollection new: 200.
	index := 1.
	done := false.
	f := fullPath asVmPathName.
	[done] whileFalse: [
		entryArray := self primLookupEntryIn: f index: index.
		#badDirectoryPath = entryArray ifTrue: [
			^(InvalidDirectoryError pathName: pathName asSqueakPathName) signal].
		entryArray == nil
			ifTrue: [done := true]
			ifFalse: [entries addLast: (DirectoryEntry fromArray: entryArray)].
		index := index + 1].

	^ entries asArray collect: [:s | s convertFromSystemName].
! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primCreateDirectory: fullPath
	"Create a directory named by the given path. Fail if the path is bad or if a file or directory by that name already exists."

 	<primitive: 'primitiveDirectoryCreate' module: 'FilePlugin'>
	self primitiveFailed
! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primDeleteDirectory: fullPath
	"Delete the directory named by the given path. Fail if the path is bad or if a directory by that name does not exist."

 	<primitive: 'primitiveDirectoryDelete' module: 'FilePlugin'>
	self primitiveFailed
! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primDeleteFileNamed: aFileName
	"Delete the file of the given name. Return self if the primitive succeeds, nil otherwise."

	<primitive: 'primitiveFileDelete' module: 'FilePlugin'>
	^ nil
! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primGetMacFileNamed: fileName type: typeString creator: creatorString
	"Get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. This primitive is Mac specific; it is a noop on other platforms."

 	<primitive: 'primitiveDirectoryGetMacTypeAndCreator' module: 'FilePlugin'>

! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primLookupEntryIn: fullPath index: index
	"Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing:

	<name> <creationTime> <modificationTime> <dirFlag> <fileSize>

	The empty string enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates the contents of '/'. On Macs and PCs, it enumerates the mounted volumes/drives.)

	The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad."

 	<primitive: 'primitiveDirectoryLookup' module: 'FilePlugin'>
	^ #badDirectoryPath

! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primRename: oldFileFullName to: newFileFullName 
	"Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name.
	Changed to return nil instead of failing ar 3/21/98 18:04"

	<primitive: 'primitiveFileRename' module: 'FilePlugin'>
	^nil! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSetMacFileNamed: fileName type: typeString creator: creatorString
	"Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. This primitive is Mac specific; it is a noop on other platforms."

 	<primitive: 'primitiveDirectorySetMacTypeAndCreator' module: 'FilePlugin'>
	self primitiveFailed
! !

!FileDirectory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
setPathName: pathString

	pathName := FilePath pathName: pathString.
! !

!FileDirectory methodsFor: 'private' stamp: 'mir 6/25/2001 18:05'!
storeServerEntryOn: stream
	
	stream
		nextPutAll: 'name:'; tab; nextPutAll: self localName; cr;
		nextPutAll: 'directory:'; tab; nextPutAll: self pathName; cr;
		nextPutAll: 'type:'; tab; nextPutAll: 'file'; cr! !

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

FileDirectory class
	instanceVariableNames: ''!

!FileDirectory class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:32'!
initializeStandardMIMETypes
	"FileDirectory initializeStandardMIMETypes"
	StandardMIMEMappings := Dictionary new.
	#(
		(gif		('image/gif'))
		(pdf	('application/pdf'))
		(aiff	('audio/aiff'))
		(bmp	('image/bmp'))
		(png	('image/png'))
		(swf	('application/x-shockwave-flash'))
		(htm	('text/html' 'text/plain'))
		(html	('text/html' 'text/plain'))
		(jpg	('image/jpeg'))
		(jpeg	('image/jpeg'))
		(mid	('audio/midi'))
		(midi	('audio/midi'))
		(mp3	('audio/mpeg'))
		(mpeg	('video/mpeg'))
		(mpg	('video/mpg'))
		(txt		('text/plain'))
		(text	('text/plain'))
		(mov	('video/quicktime'))
		(qt		('video/quicktime'))
		(tif		('image/tiff'))
		(tiff	('image/tiff'))
		(ttf		('application/x-truetypefont'))
		(wrl	('model/vrml'))
		(vrml	('model/vrml'))
		(wav	('audio/wav'))
	) do:[:spec|
		StandardMIMEMappings at: spec first asString put: spec last.
	].! !


!FileDirectory class methodsFor: 'create/delete file' stamp: 'stephaneducasse 2/4/2006 20:32'!
deleteFilePath: fullPathToAFile
	"Delete the file after finding its directory"

	| dir |
	dir := self on: (self dirPathFor: fullPathToAFile).
	dir deleteFileNamed: (self localNameFor: fullPathToAFile).
! !

!FileDirectory class methodsFor: 'create/delete file' stamp: 'stephaneducasse 2/4/2006 20:32'!
lookInUsualPlaces: fileName
	"Check the default directory, the imagePath, and the vmPath (and the vmPath's owner) for this file."

	| vmp |
	(FileDirectory default fileExists: fileName)
		ifTrue: [^ FileDirectory default fileNamed: fileName].

	((vmp := FileDirectory on: SmalltalkImage current imagePath) fileExists: fileName)
		ifTrue: [^ vmp fileNamed: fileName].

	((vmp := FileDirectory on: SmalltalkImage current vmPath) fileExists: fileName)
		ifTrue: [^ vmp fileNamed: fileName].

	((vmp := vmp containingDirectory) fileExists: fileName)
		ifTrue: [^ vmp fileNamed: fileName].

	^ nil! !


!FileDirectory class methodsFor: 'instance creation' stamp: 'jm 12/4/97 19:24'!
default
	"Answer the default directory."

	^ DefaultDirectory
! !

!FileDirectory class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
forFileName: aString

	| path |
	path := self dirPathFor: aString.
	path isEmpty ifTrue: [^ self default].
	^ self on: path
! !

!FileDirectory class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
on: pathString
	"Return a new file directory for the given path, of the appropriate FileDirectory subclass for the current OS platform."

	| pathName |
	DirectoryClass ifNil: [self setDefaultDirectoryClass].
	"If path ends with a delimiter (: or /) then remove it"
	((pathName := pathString) endsWith: self pathNameDelimiter asString) ifTrue: [
		pathName := pathName copyFrom: 1 to: pathName size - 1].
	^ DirectoryClass new setPathName: pathName
! !

!FileDirectory class methodsFor: 'instance creation' stamp: 'jm 12/4/97 23:29'!
root
	"Answer the root directory."

	^ self on: ''
! !


!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'!
baseNameFor: fileName
	"Return the given file name without its extension, if any. We have to remember that many (most?) OSs allow extension separators within directory names and so the leaf filename needs to be extracted, trimmed and rejoined. Yuck"
	"The test is 
		FileDirectory baseNameFor: ((FileDirectory default directoryNamed: 'foo.bar') fullNameFor:'blim.blam') 
		should end 'foo.bar/blim' (or as appropriate for your platform AND
		FileDirectory baseNameFor: ((FileDirectory default directoryNamed: 'foo.bar') fullNameFor:'blim')
		should be the same and NOT  'foo'
		Oh, and FileDirectory baseNameFor: 'foo.bar' should be 'foo' not '/foo' "

	| delim i leaf |
	self splitName: fileName to: [:path : fn|
		
		delim := DirectoryClass extensionDelimiter.
		i := fn findLast: [:c | c = delim].
		leaf := i = 0
			ifTrue: [fn]
			ifFalse: [fn copyFrom: 1 to: i - 1].
		path isEmpty ifTrue:[^leaf].
		^path, self slash, leaf]
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'TPR 5/10/1998 21:32'!
changeSuffix
"if 'changes' is not suitable, override this message to return something that is ok"
	^'changes'! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'jf 2/7/2004 17:22'!
checkName: fileName fixErrors: flag
	"Check a string fileName for validity as a file name on the current default file system. Answer the original file name if it is valid. If the name is not valid (e.g., it is too long or contains illegal characters) and fixing is false, raise an error. If fixing is true, fix the name (usually by truncating and/or tranforming characters), and answer the corrected name. The default behavior is to truncate the name to 31 chars. Subclasses can do any kind of checking and correction appropriate to the underlying platform."

	^ DefaultDirectory
		checkName: fileName
		fixErrors: flag
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 10:59'!
dirPathFor: fullName 
	"Return the directory part the given name."
	DirectoryClass
		splitName: fullName
		to: [:dirPath :localName | ^ dirPath]! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'ar 4/7/2002 15:47'!
directoryEntryFor: filenameOrPath
	^self default directoryEntryFor: filenameOrPath! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'!
extensionFor: fileName
	"Return the extension of given file name, if any."

	| delim i |
	delim := DirectoryClass extensionDelimiter.
	i := fileName findLast: [:c | c = delim].
	i = 0
		ifTrue: [^ '']
		ifFalse: [^ fileName copyFrom: i + 1 to: fileName size].
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'!
fileName: fileName extension: fileExtension
	| extension |
	extension := FileDirectory dot , fileExtension.
	^(fileName endsWith: extension)
		ifTrue: [fileName]
		ifFalse: [fileName , extension].! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'TPR 5/10/1998 21:31'!
imageSuffix
"if 'image' is not suitable, override this message to return something that is ok"
	^'image'! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'jm 12/4/97 23:40'!
isLegalFileName: fullName
	"Return true if the given string is a legal file name."

	^ DefaultDirectory isLegalFileName: (self localNameFor: fullName)
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 10:59'!
localNameFor: fullName 
	"Return the local part the given name."
	DirectoryClass
		splitName: fullName
		to: [:dirPath :localName | ^ localName]! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'!
searchAllFilesForAString

	"Prompt the user for a search string, and a starting directory. Search the contents of all files in the starting directory and its subdirectories for the search string (case-insensitive search.)
	List the paths of files in which it is found on the Transcript.
	By Stewart MacLean 5/00; subsequently moved to FileDirectory class-side, and refactored to call FileDirectory.filesContaining:caseSensitive:"

	| searchString dir |

	searchString := FillInTheBlank request: 'Enter search string'.
	searchString isEmpty ifTrue: [^nil].
	Transcript cr; show: 'Searching for ', searchString printString, ' ...'.
	(dir := PluggableFileList getFolderDialog open) ifNotNil:
		[(dir filesContaining: searchString caseSensitive: false) do:
				[:pathname | Transcript cr; show: pathname]].
	Transcript cr; show: 'Finished searching for ', searchString printString

	"FileDirectory searchAllFilesForAString"! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'!
splitName: fullName to: pathAndNameBlock
	"Take the file name and convert it to the path name of a directory and a local file name within that directory. FileName must be of the form: <dirPath><delimiter><localName>, where <dirPath><delimiter> is optional. The <dirPath> part may contain delimiters."

	| delimiter i dirName localName |
	delimiter := self pathNameDelimiter.
	(i := fullName findLast: [:c | c = delimiter]) = 0
		ifTrue:
			[dirName := String new.
			localName := fullName]
		ifFalse:
			[dirName := fullName copyFrom: 1 to: (i - 1 max: 1).
			localName := fullName copyFrom: i + 1 to: fullName size].

	^ pathAndNameBlock value: dirName value: localName! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 12/15/2003 12:03'!
startUp
	"Establish the platform-specific FileDirectory subclass. Do any platform-specific startup."
	self setDefaultDirectoryClass.

	self setDefaultDirectory: (self dirPathFor: SmalltalkImage current imageName).

	Preferences startInUntrustedDirectory 
		ifTrue:[	"The SecurityManager may override the default directory to prevent unwanted write access etc."
				self setDefaultDirectory: SecurityManager default untrustedUserDirectory.
				"Make sure we have a place to go to"
				DefaultDirectory assureExistence].
	SmalltalkImage current openSourceFiles.
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'!
urlForFileNamed: aFilename 
	"Create a URL for the given fully qualified file name"
	"FileDirectory urlForFileNamed: 
	'C:\Home\andreasr\Squeak\DSqueak3\DSqueak3:=1.1\DSqueak3.1.image' "
	| path localName |
	DirectoryClass
		splitName: aFilename
		to: [:p :n | 
			path := p.
			localName := n].
	^ localName asUrlRelativeTo: (self on: path) url asUrl! !


!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 08:17'!
dot
	"Return a one-character string containing the filename extension delimiter for this platform (i.e., the local equivalent of 'dot')"

	^ self extensionDelimiter asString
! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:57'!
extensionDelimiter
	"Return the character used to delimit filename extensions on this platform. Most platforms use the period (.) character."

	^ $.
! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'ar 5/1/1999 01:48'!
isCaseSensitive
	"Return true if file names are treated case sensitive"
	^true! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:58'!
makeAbsolute: path
	"Ensure that path looks like an absolute path"
	^path first = self pathNameDelimiter
		ifTrue: [ path ]
		ifFalse: [ self slash, path ]! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:59'!
makeRelative: path
	"Ensure that path looks like an relative path"
	^path first = self pathNameDelimiter
		ifTrue: [ path copyWithoutFirst ]
		ifFalse: [ path ]! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 5/8/1998 20:45'!
maxFileNameLength

	^ 31
! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/12/1998 22:49'!
pathNameDelimiter
"return the active directory class's directory seperator character"
	^ DirectoryClass pathNameDelimiter! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'ar 4/18/1999 18:18'!
slash
	^ self pathNameDelimiter asString! !


!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'!
openChanges: changesName forImage: imageName
"find the changes file by looking in
a) the directory derived from the image name
b) the DefaultDirectory (which will normally be the directory derived from the image name or the SecurityManager's choice)
If an old file is not found in either place, check for a read-only file in the same places. If that fails, return nil"
	| changes fd |
	"look for the changes file or an alias to it in the image directory"
	fd := FileDirectory on: (FileDirectory dirPathFor: imageName).
	(fd fileExists: changesName)
		ifTrue: [changes := fd oldFileNamed: changesName].
	changes ifNotNil:[^changes].

	"look for the changes in the default directory"
	fd := DefaultDirectory.
	(fd fileExists: changesName)
		ifTrue: [changes := fd oldFileNamed: changesName].
	changes ifNotNil:[^changes].

	"look for read-only changes in the image directory"
	fd := FileDirectory on: (FileDirectory dirPathFor: imageName).
	(fd fileExists: changesName)
		ifTrue: [changes := fd readOnlyFileNamed: changesName].
	changes ifNotNil:[^changes].

	"look for read-only changes in the default directory"
	fd := DefaultDirectory.
	(fd fileExists: changesName)
		ifTrue: [changes := fd readOnlyFileNamed: changesName].
	"this may be nil if the last try above failed to open a file"
	^changes
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'!
openSources: sourcesName andChanges: changesName forImage: imageName 
	"Open the changes and sources files and install them in SourceFiles. Inform the user of problems regarding write permissions or CR/CRLF mixups."
	"Note: SourcesName and imageName are full paths; changesName is a  
	local name."
	| sources changes msg wmsg |
	msg := 'Squeak cannot locate &fileRef.

Please check that the file is named properly and is in the
same directory as this image.'.
	wmsg := 'Squeak cannot write to &fileRef.

Please check that you have write permission for this file.

You won''t be able to save this image correctly until you fix this.'.

	sources := self openSources: sourcesName forImage: imageName.
	changes := self openChanges: changesName forImage: imageName.

	((sources == nil or: [sources atEnd])
			and: [Preferences valueOfFlag: #warnIfNoSourcesFile])
		ifTrue: [SmalltalkImage current platformName = 'Mac OS'
				ifTrue: [msg := msg , '
Make sure the sources file is not an Alias.'].
self inform: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName)].

	(changes == nil
			and: [Preferences valueOfFlag: #warnIfNoChangesFile])
		ifTrue: [self inform: (msg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)].

	((Preferences valueOfFlag: #warnIfNoChangesFile) and: [changes notNil])
		ifTrue: [changes isReadOnly
				ifTrue: [self inform: (wmsg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)].

			((changes next: 200)
					includesSubString: String crlf)
				ifTrue: [self inform: 'The changes file named ' , changesName , '
has been injured by an unpacking utility.  Crs were changed to CrLfs.
Please set the preferences in your decompressing program to 
"do not convert text files" and unpack the system again.']].

	SourceFiles := Array with: sources with: changes! !

!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'!
openSources: fullSourcesName forImage: imageName 
"We first do a check to see if a compressed version ofthe sources file is present.
Open the .sources file read-only after searching in:
a) the directory where the VM lives
b) the directory where the image came from
c) the DefaultDirectory (which is likely the same as b unless the SecurityManager has changed it).
"

	| sources fd sourcesName |
	(fullSourcesName endsWith: 'sources') ifTrue:
		["Look first for a sources file in compressed format."
		sources := self openSources: (fullSourcesName allButLast: 7) , 'stc'
						forImage: imageName.
		sources ifNotNil: [^ CompressedSourceStream on: sources]].

	sourcesName := FileDirectory localNameFor: fullSourcesName.
	"look for the sources file or an alias to it in the VM's directory"
	fd := FileDirectory on: SmalltalkImage current vmPath.
	(fd fileExists: sourcesName)
		ifTrue: [sources := fd readOnlyFileNamed: sourcesName].
	sources ifNotNil: [^ sources].
	"look for the sources file or an alias to it in the image directory"
	fd := FileDirectory on: (FileDirectory dirPathFor: imageName).
	(fd fileExists: sourcesName)
		ifTrue: [sources := fd readOnlyFileNamed: sourcesName].
	sources ifNotNil: [^ sources].
	"look for the sources in the current directory"
	fd := DefaultDirectory.
	(fd fileExists: sourcesName)
		ifTrue: [sources := fd readOnlyFileNamed: sourcesName].
	"sources may still be nil here"
	^sources
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'!
setDefaultDirectory: directoryName
	"Initialize the default directory to the directory supplied. This method is called when the image starts up."
	| dirName |
	DirectoryClass := self activeDirectoryClass.
	dirName := (FilePath pathName: directoryName) asSqueakPathName.
	[dirName endsWith: self slash] whileTrue:[
		dirName := dirName copyFrom: 1 to: dirName size - self slash size.
	].
	DefaultDirectory := self on: dirName.! !

!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'!
setDefaultDirectoryClass
	"Initialize the default directory class to suit this platform. This method is called when the image starts up - it needs to be right at the front of the list of the startup sequence"

	DirectoryClass := self activeDirectoryClass
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'!
setDefaultDirectoryFrom: imageName
	"Initialize the default directory to the directory containing the Squeak image file. This method is called when the image starts up."

	DirectoryClass := self activeDirectoryClass.
	DefaultDirectory := self on: (FilePath pathName: (self dirPathFor: imageName) isEncoded: true) asSqueakPathName.
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'sd 11/16/2003 13:13'!
shutDown

	SmalltalkImage current closeSourceFiles.
! !


!FileDirectory class methodsFor: '*network-uri' stamp: 'mir 3/24/2005 19:06'!
contentStreamForURI: aURI
	| fullPath fileDir |
	fullPath := self fullPathForURI: aURI.
	fileDir := self forFileName: fullPath.
"	^fileDir readOnlyFileNamed: (self localNameFor: fullPath)"
	^StandardFileStream readOnlyFileNamed: fullPath
! !

!FileDirectory class methodsFor: '*network-uri' stamp: 'mir 3/24/2005 17:04'!
directoryEntryForURI: aURI
	^ self directoryEntryFor: (self fullPathForURI: aURI)! !

!FileDirectory class methodsFor: '*network-uri' stamp: 'mir 6/20/2005 18:53'!
fullPathForURI: aURI
	^self activeDirectoryClass privateFullPathForURI: (FileDirectory default uri resolveRelativeURI: aURI)! !

!FileDirectory class methodsFor: '*network-uri' stamp: 'mir 6/20/2005 18:53'!
privateFullPathForURI: aURI
	^(aURI path copyReplaceAll: '/' with: self slash) unescapePercents! !

!FileDirectory class methodsFor: '*network-uri' stamp: 'tb 5/24/2006 22:01'!
retrieveMIMEDocument: uri
	| file |
	file  _ [self contentStreamForURI: uri] 
			on: FileDoesNotExistException do:[:ex| ex return: nil].
	file ifNotNil: [^MIMEDocument contentType: (MIMEDocument guessTypeFromName: uri) content: file contents url: uri].
	^nil! !

!FileDirectory class methodsFor: '*network-uri' stamp: 'mir 6/20/2005 18:34'!
uri: aURI
	^self on: (FileDirectory fullPathForURI: aURI)! !


!FileDirectory class methodsFor: 'private' stamp: 'TPR 5/10/1998 21:47'!
activeDirectoryClass
	"Return the concrete FileDirectory subclass for the platform on which we are currently running."

	FileDirectory allSubclasses do: [:class |
		class isActiveDirectoryClass ifTrue: [^ class]].

	"no responding subclass; use FileDirectory"
	^ FileDirectory
! !

!FileDirectory class methodsFor: 'private' stamp: 'TPR 5/10/1998 21:40'!
isActiveDirectoryClass
	"Does this class claim to be that properly active subclass of FileDirectory for this platform?
	Default test is whether the primPathNameDelimiter matches the one for this class. Other tests are possible"

	^self pathNameDelimiter = self primPathNameDelimiter
! !

!FileDirectory class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primPathNameDelimiter
	"Return the path delimiter for the underlying platform's file system."

 	<primitive: 'primitiveDirectoryDelimitor' module: 'FilePlugin'>
	self primitiveFailed
! !
ClassTestCase subclass: #FileDirectoryTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Tests'!

!FileDirectoryTest methodsFor: 'create/delete tests' stamp: 'nk 11/13/2002 19:39'!
deleteDirectory
	
	(self myDirectory exists) ifTrue:
		[self myDirectory containingDirectory deleteDirectory: self myLocalDirectoryName]! !

!FileDirectoryTest methodsFor: 'create/delete tests' stamp: 'stephaneducasse 2/4/2006 20:31'!
testDeleteDirectory
	"Test deletion of a directory"
	
	| aContainingDirectory preTestItems |
	aContainingDirectory := self myDirectory containingDirectory.
	preTestItems := aContainingDirectory fileAndDirectoryNames.
	
	self assert: self myAssuredDirectory exists.
	aContainingDirectory deleteDirectory: self myLocalDirectoryName.

	self shouldnt: 
		[aContainingDirectory directoryNames 
			includes: self myLocalDirectoryName ]
		description: 'Should successfully delete directory.'.
	self should: 
		[preTestItems = aContainingDirectory fileAndDirectoryNames]
		description: 'Should only delete the indicated directory.'.

	
	! !


!FileDirectoryTest methodsFor: 'existence tests' stamp: 'aka 5/20/2003 16:43'!
testAttemptExistenceCheckWhenFile
"How should a FileDirectory instance respond with an existent file name?"
| directory |
FileDirectory default
				forceNewFileNamed: 'aTestFile'.
directory := FileDirectory default
				directoryNamed: 'aTestFile'.
self shouldnt: [directory exists]
	description: 'Files are not directories.'.! !

!FileDirectoryTest methodsFor: 'existence tests' stamp: 'aka 5/20/2003 23:33'!
testDirectoryExists

	self assert: self myAssuredDirectory exists.
	self should: [self myDirectory containingDirectory 
					directoryExists: self myLocalDirectoryName].

	self myDirectory containingDirectory deleteDirectory: self myLocalDirectoryName.
	self shouldnt: [self myDirectory containingDirectory 
						directoryExists: self myLocalDirectoryName]! !

!FileDirectoryTest methodsFor: 'existence tests' stamp: 'svp 5/20/2003 17:14'!
testDirectoryExistsWhenLikeNamedFileExists

| testFileName |
[testFileName := self myAssuredDirectory fullNameFor: 'zDirExistsTest.testing'.
(FileStream newFileNamed: testFileName) close.

self should: [FileStream isAFileNamed: testFileName].
self shouldnt: [(FileDirectory on: testFileName) exists]]
ensure: [self myAssuredDirectory deleteFileNamed: 'zDirExistsTest.testing']

! !

!FileDirectoryTest methodsFor: 'existence tests' stamp: 'hg 2/2/2002 16:44'!
testDirectoryNamed

	self should: [(self myDirectory containingDirectory 
					directoryNamed: self myLocalDirectoryName) pathName 
						= self myDirectory pathName]! !

!FileDirectoryTest methodsFor: 'existence tests' stamp: 'tpr 8/15/2003 16:30'!
testExists

	self should: [FileDirectory default exists]
		description: 'Should know default directory exists.'.
	self should: [self myAssuredDirectory exists]
		description: 'Should know created directory exists.'.

	self myDirectory containingDirectory deleteDirectory: self myLocalDirectoryName.
	self shouldnt: [(self myDirectory containingDirectory directoryNamed: self myLocalDirectoryName) exists]
		description: 'Should know that recently deleted directory no longer exists.'.! !

!FileDirectoryTest methodsFor: 'existence tests' stamp: 'stephaneducasse 2/4/2006 20:31'!
testNonExistentDirectory

	| directory parentDirectory |
	directory :=FileDirectory default
				directoryNamed: 'nonExistentFolder'.
	self shouldnt: [directory exists] 
		description: 'A FileDirectory instance should know if it points to a non-existent directory.'.

	parentDirectory :=FileDirectory default.
	self shouldnt: [parentDirectory directoryExists: 'nonExistentFolder'] 
		description: 'A FileDirectory instance should know when a directory of the given name doesn''t exist'.
! !

!FileDirectoryTest methodsFor: 'existence tests' stamp: 'CdG 10/19/2005 22:41'!
testOldFileOrNoneNamed

	| file |
	file := self myAssuredDirectory oldFileOrNoneNamed: 'test.txt'.
	[self assert: file isNil.
	
	"Reproduction of Mantis #1049"
	(self myAssuredDirectory fileNamed: 'test.txt')
		nextPutAll: 'foo';
		close.
		
	file := self myAssuredDirectory oldFileOrNoneNamed: 'test.txt'.
	self assert: file notNil]
		ensure: [
			file ifNotNil: [file close].
			self myAssuredDirectory deleteFileNamed: 'test.txt' ifAbsent: nil]
	
! !


!FileDirectoryTest methodsFor: 'resources' stamp: 'hg 2/2/2002 16:44'!
myAssuredDirectory

	^self myDirectory assureExistence! !

!FileDirectoryTest methodsFor: 'resources' stamp: 'hg 2/2/2002 16:42'!
myDirectory

	^FileDirectory default directoryNamed: self myLocalDirectoryName! !

!FileDirectoryTest methodsFor: 'resources' stamp: 'hg 2/2/2002 16:42'!
myLocalDirectoryName

	^'zTestDir'! !

!FileDirectoryTest methodsFor: 'resources' stamp: 'nk 11/13/2002 19:56'!
tearDown

	[ self deleteDirectory ] on: Error do: [ :ex | ]! !
ListItemWrapper subclass: #FileDirectoryWrapper
	instanceVariableNames: 'itemName balloonText hasContents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:01'!
balloonText: aStringOrNil

	balloonText _ aStringOrNil! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/12/2001 16:22'!
directoryNamesFor: anItem
	^model directoryNamesFor: anItem! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'sps 12/5/2002 16:59'!
setItem: anObject name: aString model: aModel

	item _ anObject.
	model _ aModel.
	itemName _ aString.
	hasContents _ nil.
! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 18:30'!
settingSelector

	^#setSelectedDirectoryTo:! !


!FileDirectoryWrapper methodsFor: 'converting' stamp: 'dgd 8/27/2004 18:45'!
asString
	 ^itemName translatedIfCorresponds! !


!FileDirectoryWrapper methodsFor: 'accessing' stamp: 'RAA 7/21/2000 11:00'!
balloonText

	^balloonText! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: 'ar 2/12/2001 16:20'!
contents

	^((model directoryNamesFor: item) sortBy: [ :a :b | a caseInsensitiveLessOrEqual: b]) collect: [ :n | 
		FileDirectoryWrapper with: (item directoryNamed: n) name: n model: self
	]
! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: 'tpr 11/28/2003 14:02'!
hasContents
	"Return whether this directory has subfolders. The value is cached to 
	avoid a performance penalty.	Also for performance reasons, the code 
	below will just assume that the directory does indeed have contents in a 
	few of cases:  
	1. If the item is not a FileDirectory (thus avoiding the cost 
	of refreshing directories that are not local) 
	2. If it's the root directory of a given volume 
	3. If there is an error computing the FileDirectory's contents
	"
	hasContents
		ifNil: [hasContents := true. "default"
			["Best test I could think of for determining if this is a local directory "
			((item isKindOf: FileDirectory)
					and: ["test to see that it's not the root directory"
						"there has to be a better way of doing this test -tpr"
						item pathParts size > 1])
				ifTrue: [hasContents := self contents notEmpty]]
				on: Error
				do: [hasContents := true]].
	^ hasContents! !

!FileDirectoryWrapper methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:22'!
icon
	"Answer a form to be used as icon"
	^ item isRemoteDirectory
		ifTrue: [MenuIcons smallRemoteOpenIcon]
		ifFalse: [MenuIcons smallOpenIcon]! !

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

FileDirectoryWrapper class
	instanceVariableNames: ''!

!FileDirectoryWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 18:01'!
with: anObject name: aString model: aModel

	^self new 
		setItem: anObject name: aString model: aModel! !
FileStreamException subclass: #FileDoesNotExistException
	instanceVariableNames: 'readOnly'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!FileDoesNotExistException methodsFor: 'accessing' stamp: 'mir 7/25/2000 16:41'!
readOnly
	^readOnly == true! !

!FileDoesNotExistException methodsFor: 'accessing' stamp: 'mir 7/25/2000 16:40'!
readOnly: aBoolean
	readOnly _ aBoolean! !


!FileDoesNotExistException methodsFor: 'exceptionDescription' stamp: 'mir 7/25/2000 18:22'!
defaultAction
	"The default action taken if the exception is signaled."


	^self readOnly
		ifTrue: [StandardFileStream readOnlyFileDoesNotExistUserHandling: self fileName]
		ifFalse: [StandardFileStream fileDoesNotExistUserHandling: self fileName]
! !

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

FileDoesNotExistException class
	instanceVariableNames: ''!

!FileDoesNotExistException class methodsFor: 'examples' stamp: 'mir 2/29/2000 11:44'!
example
	"FileDoesNotExistException example"

	| result |
	result _ [(StandardFileStream readOnlyFileNamed: 'error42.log') contentsOfEntireFile]
		on: FileDoesNotExistException
		do: [:ex | 'No error log'].
	Transcript show: result; cr! !
FileStreamException subclass: #FileExistsException
	instanceVariableNames: 'fileClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:49'!
fileClass
	^ fileClass ifNil: [StandardFileStream]! !

!FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:42'!
fileClass: aClass
	fileClass _ aClass! !


!FileExistsException methodsFor: 'exceptionDescription' stamp: 'LC 10/24/2001 21:50'!
defaultAction
	"The default action taken if the exception is signaled."

	^ self fileClass fileExistsUserHandling: self fileName
! !

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

FileExistsException class
	instanceVariableNames: ''!

!FileExistsException class methodsFor: 'exceptionInstantiator' stamp: 'LC 10/24/2001 21:50'!
fileName: aFileName fileClass: aClass 
	^ self new
		fileName: aFileName;
		fileClass: aClass! !
StringHolder subclass: #FileList
	instanceVariableNames: 'fileName directory volList volListIndex list listIndex pattern sortMode brevityState'
	classVariableNames: 'FileReaderRegistry RecentDirs'
	poolDictionaries: ''
	category: 'Morphic-FileList'!
!FileList commentStamp: 'nk 11/26/2002 11:52' prior: 0!
I am model that can be used to navigate the host file system. By omitting the volume list, file list, and template panes from the view, I can also be used as the model for an editor on an individual file.

The FileList now provides a registration mechanism to which any tools the filelist uses ***MUST*** register.  This way it is possible to dynamically load or unload a new tool and have the FileList automatically updated.  This change supports a decomposition of Squeak and removes a problem with dead reference to classes after a major shrink.

Tools should implement the following methods (look for implementors in the image):

#fileReaderServicesForFile:suffix: (appropriate services for given file, takes a file name and a lowercased suffix)

#services (all provided services, to be displayed in full list)

These methods both return a collection of SimpleServiceEntry instances.  These contain a class, a menu label and a method selector having one argument.  They may also provide separate button labels and description.

The argument to the specified method will be a string representing the full name of a file when one is selected or the file list itself when there is no selected file.

Tools must register with the FileList calling the class method #registerFileReader: when they load. They also must call #unregisterFileReader: when they unload.

There is a testSuite called FileListTest that presents some examples. 

Stef (I do not like really this distinction passing always a file list could be better)


Old Comments: 


FileLists can now see FTP servers anywhere on the net.  In the volume list menu: 
fill in server info...		Gives you a form to register a new ftp server you want to use.
open server...		Choose a server to connect to.
local disk			Go back to looking at your local volume.


Still undone (you can contribute code):
[ ] Using a Proxy server to get out through a firewall.  What is the convention for proxy servers with FTP?
[ ] Fill in the date and size info in the list of remote files.  Allow sorting by it.  New smarts needed in (ServerDirectory fileNameFormattedFrom:sizePad:sortMode:).
[ ] Currently the FileList has no way to delete a directory.  Since you can't select a directory without going into it, it would have to be deleting the current directory.  Which would usually be empty.!


!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/19/2003 10:08'!
acceptDroppingMorph: aTransferMorph event: evt inMorph: dest
	| oldName oldEntry destDirectory newName newEntry baseName response |
	destDirectory _ self dropDestinationDirectory: dest event: evt.
	oldName _ aTransferMorph passenger.
	baseName _ FileDirectory localNameFor: oldName.
	newName _ destDirectory fullNameFor: baseName.
	newName = oldName ifTrue: [ "Transcript nextPutAll: 'same as old name'; cr." ^ true ].
	oldEntry _ FileDirectory directoryEntryFor: oldName.
	newEntry _ FileDirectory directoryEntryFor: newName.
	newEntry ifNotNil: [ | msg |
		msg _ String streamContents: [ :s |
			s nextPutAll: 'destination file ';
				nextPutAll: newName;
				nextPutAll: ' exists already,';
				cr;
				nextPutAll: 'and is ';
				nextPutAll: (oldEntry modificationTime < newEntry modificationTime
					ifTrue: [ 'newer' ] ifFalse: [ 'not newer' ]);
				nextPutAll: ' than source file ';
				nextPutAll: oldName;
				nextPut: $.;
				cr;
				nextPutAll: 'Overwrite file ';
				nextPutAll: newName;
				nextPut: $?
		].
		response _ self confirm: msg.
		response ifFalse: [ ^false ].
	].

	aTransferMorph shouldCopy
		ifTrue: [ self primitiveCopyFileNamed: oldName to: newName ]
		ifFalse: [ directory rename: oldName toBe: newName ].

	self updateFileList; fileListIndex: 0.

	aTransferMorph source model ~= self
		ifTrue: [ aTransferMorph source model updateFileList; fileListIndex: 0 ].
	"Transcript nextPutAll: 'copied'; cr."
	^true! !

!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/14/2003 12:58'!
dragPassengerFor: item inMorph: dragSource
	^self directory fullNameFor: ((self fileNameFromFormattedItem: item contents copy)
		copyReplaceAll: self folderString with: '').
! !

!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/14/2003 11:16'!
dragTransferTypeForMorph: aMorph
	^#file! !

!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 13:07'!
dropDestinationDirectory: dest event: evt 
	"Answer a FileDirectory representing the drop destination in the volume list morph dest"
	| index dir delim path |
	index _ volList indexOf: (dest itemFromPoint: evt position) contents.
	index = 1
		ifTrue: [dir _ FileDirectory on: '']
		ifFalse: [delim _ directory pathNameDelimiter.
			path _ String
						streamContents: [:str | 
							2
								to: index
								do: [:d | 
									str nextPutAll: (volList at: d) withBlanksTrimmed.
									d < index
										ifTrue: [str nextPut: delim]].
							nil].
			dir _ directory on: path].
	^ dir! !

!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 21:58'!
isDirectoryList: aMorph
	^aMorph getListSelector == #volumeList! !

!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/12/2004 16:17'!
primitiveCopyFileNamed: srcName to: dstName 
	"Copied from VMMaker code.
	This really ought to be a facility in file system. The major annoyance 
	here is that file types and permissions are not handled by current 
	Squeak code.
	NOTE that this will clobber the destination file!!"
	| buffer src dst |
	<primitive: 'primitiveFileCopyNamedTo' module:'FileCopyPlugin'> "primitiveExternalCall" 
	"If the plugin doesn't do it, go the slow way and lose the filetype info"
	"This method may signal FileDoesNotExistException if either the source or 
	dest files cannnot be opened; possibly permissions or bad name problems"
	[[src _ FileStream readOnlyFileNamed: srcName]
		on: FileDoesNotExistException
		do: [^ self error: ('could not open file ', srcName)].
	[dst _ FileStream forceNewFileNamed: dstName]
		on: FileDoesNotExistException
		do: [^ self error: ('could not open file ', dstName)].
	buffer _ String new: 50000.
	[src atEnd]
		whileFalse: [dst
				nextPutAll: (src nextInto: buffer)]]
		ensure: [src
				ifNotNil: [src close].
			dst
				ifNotNil: [dst close]]! !

!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/19/2003 10:08'!
wantsDroppedMorph: aTransferMorph event: evt inMorph: dest
	| retval |
	retval _ (aTransferMorph isKindOf: TransferMorph)
		and: [ aTransferMorph dragTransferType == #file ]
		and: [ self isDirectoryList: dest ].
	"retval ifFalse: [ Transcript nextPutAll: 'drop not wanted'; cr ]."
	^retval! !


!FileList methodsFor: 'file list'!
fileList
	"Answer the list of files in the current volume."

	^ list! !

!FileList methodsFor: 'file list'!
fileListIndex
	"Answer the index of the currently selected file."

	^ listIndex! !

!FileList methodsFor: 'file list' stamp: 'sw 2/17/2002 02:32'!
fileListIndex: anInteger
	"Select the file name having the given index, and display its contents."

	| item name |
	self okToChange ifFalse: [^ self].
	listIndex := anInteger.
	listIndex = 0 
		ifTrue: [fileName := nil]
		ifFalse:
			[item := self fileNameFromFormattedItem: (list at: anInteger).
			(item endsWith: self folderString)
				ifTrue:
					["remove [...] folder string and open the folder"
					name := item copyFrom: 1 to: item size - self folderString size.
					listIndex := 0.
					brevityState := #FileList.
					self addPath: name.
					name first = $^
						ifTrue: [self directory: (ServerDirectory serverNamed: name allButFirst)]
						ifFalse: [volListIndex = 1 ifTrue: [name _ name, directory slash].
							self directory: (directory directoryNamed: name)]]
				ifFalse: [fileName := item]].  "open the file selected"

	brevityState := #needToGetBrief.
	self changed: #fileListIndex.
	self changed: #contents.
	self updateButtonRow! !

!FileList methodsFor: 'file list' stamp: 'sd 2/14/2002 16:58'!
fileName

	^ fileName! !

!FileList methodsFor: 'file list' stamp: 'nk 4/29/2004 10:34'!
readOnlyStream
	"Answer a read-only stream on the selected file. For the various stream-reading services."

	^self directory ifNotNilDo: [ :dir | dir readOnlyFileNamed: self fileName ]! !


!FileList methodsFor: 'file list menu' stamp: 'RAA 2/2/2002 08:18'!
dirAndFileName

	^{directory. fileName}! !

!FileList methodsFor: 'file list menu' stamp: 'dgd 10/1/2004 13:55'!
fileContentsMenu: aMenu shifted: shifted
	"Construct aMenu to have items appropriate for the file browser's code pane, given the shift state provided"

	| shiftMenu services maybeLine extraLines |
	shifted ifTrue:
		[shiftMenu _ ParagraphEditor shiftedYellowButtonMenu.
		^ aMenu addAllFrom: shiftMenu].
	fileName ifNotNil:
		[services _ OrderedCollection new.
		(#(briefHex briefFile needToGetBriefHex needToGetBrief) includes: brevityState) ifTrue:
			[services add: self serviceGet].
		(#(fullHex briefHex needToGetFullHex needToGetBriefHex) includes: brevityState) ifFalse:
			[services add: self serviceGetHex].
		(#(needToGetShiftJIS needToGetEUCJP needToGetCNGB needToGetEUCKR needToGetUTF8) includes: brevityState) ifFalse:
			[services add: self serviceGetEncodedText].
		maybeLine _ services size.
		(FileStream sourceFileSuffixes includes: self suffixOfSelectedFile) ifTrue:
			[services addAll:
				(self servicesFromSelectorSpecs:
					#(fileIntoNewChangeSet: fileIn: browseChangesFile: browseFile:))].

		extraLines _ OrderedCollection new.
		maybeLine > 0 ifTrue: [extraLines add: maybeLine].
		services size > maybeLine ifTrue: [extraLines add: services size].
		aMenu 
			addServices: services
			for: self fullName
			extraLines: extraLines].

	aMenu addList: {
			{'find...(f)' translated.		#find}.
			{'find again (g)' translated.		#findAgain}.
			{'set search string (h)' translated.	#setSearchString}.
			#-.
			{'do again (j)' translated.		#again}.
			{'undo (z)' translated.			#undo}.
			#-.
			{'copy (c)' translated.			#copySelection}.
			{'cut (x)' translated.			#cut}.
			{'paste (v)' translated.		#paste}.
			{'paste...' translated.			#pasteRecent}.
			#-.
			{'do it (d)' translated.		#doIt}.
			{'print it (p)' translated.		#printIt}.
			{'inspect it (i)' translated.		#inspectIt}.
			{'fileIn selection (G)' translated.	#fileItIn}.
			#-.
			{'accept (s)' translated.		#accept}.
			{'cancel (l)' translated.		#cancel}.
			#-.
			{'more...' translated.			#shiftedYellowButtonActivity}}.


	^ aMenu
! !

!FileList methodsFor: 'file list menu' stamp: 'LEG 10/24/2001 15:37'!
fileListMenu: aMenu

	fileName
		ifNil: [^ self noFileSelectedMenu: aMenu]
		ifNotNil: [^ self fileSelectedMenu: aMenu].
! !

!FileList methodsFor: 'file list menu' stamp: 'nk 11/16/2002 13:00'!
fileSelectedMenu: aMenu

	| firstItems secondItems thirdItems n1 n2 n3 services |
	firstItems _ self itemsForFile: self fullName.
	secondItems _ self itemsForAnyFile.
	thirdItems _ self itemsForNoFile.
	n1 _ firstItems size.
	n2 _ n1 + secondItems size.
	n3 _ n2 + thirdItems size.
	services _ firstItems, secondItems, thirdItems, self serviceAllFileOptions.
	services do: [ :svc | svc addDependent: self ].
	^ aMenu 
		addServices2: services 
		for: self
		extraLines: (Array with: n1 with: n2 with: n3)
! !

!FileList methodsFor: 'file list menu' stamp: 'em 3/29/2005 12:25'!
fullFileListMenu: aMenu shifted: aBoolean
	"Fill the menu with all possible items for the file list pane, regardless of selection."

	| lastProvider |
	aMenu title: 'all possible file operations' translated.
	Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].

	lastProvider _ nil.
	(self itemsForFile: 'a.*') do: [ :svc |
		(lastProvider notNil and: [svc provider ~~ lastProvider])
			ifTrue: [ aMenu addLine ].
		svc addServiceFor: self toMenu: aMenu.
		Smalltalk isMorphic ifTrue: [aMenu submorphs last setBalloonText: svc description].
		lastProvider _ svc provider.
		svc addDependent: self.
	].

	^aMenu! !

!FileList methodsFor: 'file list menu' stamp: 'sw 11/8/2003 13:32'!
itemsForAnyFile
	"Answer a list of universal services that could apply to any file"
	
	| services |
	services := OrderedCollection new: 4.
	services add: self serviceCopyName. 
	services add: self serviceRenameFile. 
	services add: self serviceDeleteFile.
	services add: self serviceViewContentsInWorkspace.
	^ services! !

!FileList methodsFor: 'file list menu' stamp: 'nk 6/12/2004 12:05'!
itemsForDirectory: dir 
	| services |
	services := OrderedCollection new.
	dir ifNotNil: [
		services
			addAll: (self class itemsForDirectory: dir).
		services last useLineAfter: true. ].
	services add: self serviceAddNewFile.
	services add: self serviceAddNewDirectory.
	^ services! !

!FileList methodsFor: 'file list menu' stamp: 'nk 12/7/2002 12:56'!
itemsForFile: fullName
	"Answer a list of services appropriate for a file of the given full name"
	| suffix |
	suffix _ self class suffixOf: fullName.
	^ (self class itemsForFile: fullName) , (self myServicesForFile: fullName suffix: suffix)! !

!FileList methodsFor: 'file list menu' stamp: 'nk 6/12/2004 12:06'!
itemsForNoFile

	| services |
	services := OrderedCollection new.
	services add: self serviceSortByName.
	services add: self serviceSortBySize.
	services add: (self serviceSortByDate useLineAfter: true).
	services addAll: (self itemsForDirectory: (self isFileSelected ifFalse: [ self directory ] ifTrue: [])).
	^ services

		! !

!FileList methodsFor: 'file list menu' stamp: 'sd 2/6/2002 21:25'!
myServicesForFile: fullName suffix: suffix

	^(FileStream isSourceFileSuffix: suffix)
		ifTrue: [ {self serviceBroadcastUpdate} ]
		ifFalse: [ #() ]! !

!FileList methodsFor: 'file list menu' stamp: 'SD 11/8/2001 20:34'!
noFileSelectedMenu: aMenu

	^ aMenu
		addServices: self itemsForNoFile 
		for: self
		extraLines: #()
		
! !

!FileList methodsFor: 'file list menu' stamp: 'sw 2/27/2001 13:52'!
offerAllFileOptions
	"Put up a menu offering all possible file options, whatever the suffix of the current selection may be.  Specially useful if you're wanting to keep the menu up"

	self offerMenuFrom: #fullFileListMenu:shifted: shifted: true! !

!FileList methodsFor: 'file list menu' stamp: 'yo 11/14/2002 15:04'!
openMorphFromFile
	"Reconstitute a Morph from the selected file, presumed to be represent a Morph saved
	via the SmartRefStream mechanism, and open it in an appropriate Morphic world"

 	| aFileStream morphOrList |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].

	aFileStream _ (MultiByteBinaryOrTextStream with: ((FileStream readOnlyFileNamed: self fullName) binary contentsOfEntireFile)) binary reset.
	morphOrList _ aFileStream fileInObjectAndCode.
	(morphOrList isKindOf: SqueakPage) ifTrue: [morphOrList _ morphOrList contentsMorph].
	Smalltalk isMorphic
		ifTrue: [ActiveWorld addMorphsAndModel: morphOrList]
		ifFalse:
			[morphOrList isMorph ifFalse: [^ self errorMustBeMorph].
			morphOrList openInWorld]! !

!FileList methodsFor: 'file list menu' stamp: 'nk 12/7/2002 12:57'!
suffixOfSelectedFile
	"Answer the file extension of the receiver's selected file"
	^ self class suffixOf: self fullName.! !


!FileList methodsFor: 'file menu action' stamp: 'rbb 3/1/2005 10:53'!
addNew: aString byEvaluating: aBlock
	"A parameterization of earlier versions of #addNewDirectory and
	#addNewFile.  Fixes the bug in each that pushing the cancel button
	in the FillInTheBlank dialog gave a walkback."

	| response newName index ending |
	self okToChange ifFalse: [^ self].
	(response := UIManager default
						request: ('New {1} Name?' translated format: {aString translated})
						initialAnswer: ('{1}Name' translated format: {aString translated}))
		isEmpty ifTrue: [^ self].
	newName := response asFileName.
	Cursor wait showWhile: [
		aBlock value: newName].
	self updateFileList.
	index := list indexOf: newName.
	index = 0 ifTrue: [ending := ') ',newName.
		index := list findFirst: [:line | line endsWith: ending]].
	self fileListIndex: index.
! !

!FileList methodsFor: 'file menu action' stamp: 'sge 11/28/1999 09:04'!
addNewDirectory
	self 
		addNew: 'Directory'
		byEvaluating: [:newName | directory createDirectory: newName]
! !

!FileList methodsFor: 'file menu action' stamp: 'sge 11/28/1999 09:04'!
addNewFile
	self 
		addNew: 'File'
		byEvaluating: [:newName | (directory newFileNamed: newName) close]
! !

!FileList methodsFor: 'file menu action' stamp: 'ka 8/3/2001 21:12'!
compressFile
	"Compress the currently selected file"

	| f |
	f _ StandardFileStream
				readOnlyFileNamed: (directory fullNameFor: self fullName).
	f compressFile.
	self updateFileList! !

!FileList methodsFor: 'file menu action' stamp: 'dgd 9/21/2003 17:37'!
deleteFile
	"Delete the currently selected file"
	listIndex = 0 ifTrue: [^ self].
	(self confirm: ('Really delete {1}?' translated format:{fileName})) ifFalse: [^ self].
	directory deleteFileNamed: fileName.
	self updateFileList.
	brevityState _ #FileList.
	self get! !

!FileList methodsFor: 'file menu action' stamp: 'jm 5/3/1998 18:03'!
get
	"Get contents of file again, it may have changed. Do this by making the cancel string be the contents, and doing a cancel."

	Cursor read showWhile: [
		self okToChange ifFalse: [^ nil].
		brevityState == #briefHex
			ifTrue: [brevityState _ #needToGetFullHex]
			ifFalse: [brevityState _ #needToGetFull].
		self changed: #contents].
! !

!FileList methodsFor: 'file menu action' stamp: 'yo 3/31/2003 11:25'!
getEncodedText

	Cursor read showWhile: [
		self selectEncoding.
		self changed: #contents].
! !

!FileList methodsFor: 'file menu action' stamp: 'jm 5/3/1998 18:04'!
getHex
	"Get contents of file again, and display in Hex. Do this by making the cancel string be the contents, and doing a cancel."

	Cursor read showWhile: [
		brevityState _ #needToGetBriefHex.
		self changed: #contents].
! !

!FileList methodsFor: 'file menu action' stamp: 'rbb 3/1/2005 10:53'!
renameFile
	"Rename the currently selected file"
	| newName response |
	listIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(response := UIManager default request: 'NewFileName?' translated
 					initialAnswer: fileName)
		isEmpty ifTrue: [^ self].
	newName := response asFileName.
	newName = fileName ifTrue: [^ self].
	directory rename: fileName toBe: newName.
	self updateFileList.
	listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName].
	listIndex > 0 ifTrue: [fileName := newName].
	self changed: #fileListIndex.
! !

!FileList methodsFor: 'file menu action' stamp: 'di 4/15/98 12:36'!
sortByDate
	self resort: #date! !

!FileList methodsFor: 'file menu action' stamp: 'di 4/15/98 12:37'!
sortByName
	self resort: #name! !

!FileList methodsFor: 'file menu action' stamp: 'di 4/15/98 12:36'!
sortBySize
	self resort: #size! !

!FileList methodsFor: 'file menu action' stamp: 'sd 2/1/2002 20:02'!
spawn: code
	"Open a simple Edit window"

	listIndex = 0 ifTrue: [^ self].
	self class openEditorOn: (directory readOnlyFileNamed: fileName)
				"read only just for initial look"
			editString: code! !


!FileList methodsFor: 'initialization' stamp: 'sw 11/30/2002 00:05'!
buttonSelectorsToSuppress
	"Answer a list of action selectors whose corresponding services we would prefer *not* to have appear in the filelist's button pane; this can be hand-jimmied to suit personal taste."

	^ #(removeLineFeeds: addFileToNewZip: compressFile: putUpdate:)! !

!FileList methodsFor: 'initialization' stamp: 'BG 12/13/2002 15:32'!
directory: dir
	"Set the path of the volume to be displayed."

	self okToChange ifFalse: [^ self].

	self modelSleep.
	directory _ dir.
	self modelWakeUp.

	sortMode == nil ifTrue: [sortMode _ #date].
	volList _ ((Array with: '[]'), directory pathParts)  "Nesting suggestion from RvL"
			withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each].
	volListIndex := volList size.
	self changed: #relabel.
	self changed: #volumeList.
	self pattern: pattern! !

!FileList methodsFor: 'initialization' stamp: 'sw 2/26/2002 00:37'!
dynamicButtonServices
	"Answer services for buttons that may come and go in the button pane, depending on selection"

	^ fileName isEmptyOrNil
		ifTrue:
			[#()]
		ifFalse:
			[ | toReject |
				toReject _ self buttonSelectorsToSuppress.
				(self itemsForFile: self fullName) reject:
					[:svc | toReject includes: svc selector]]! !

!FileList methodsFor: 'initialization' stamp: 'tk 5/18/1998 17:22'!
labelString
	^ directory pathName contractTo: 50! !

!FileList methodsFor: 'initialization' stamp: 'tk 12/17/1999 18:00'!
modelSleep
	"User has exited or collapsed the window -- close any remote connection."

	directory ifNotNil: [directory sleep]! !

!FileList methodsFor: 'initialization' stamp: 'nk 1/19/2005 13:25'!
modelWakeUp
	"User has entered or expanded the window -- reopen any remote connection."

	(directory notNil and:[directory isRemoteDirectory])
		ifTrue: [[directory wakeUp] on: TelnetProtocolError do: [ :ex | self inform: ex printString ]] "It would be good to implement a null method wakeUp on the root of directory"! !

!FileList methodsFor: 'initialization' stamp: 'sbw 12/30/1999 15:53'!
optionalButtonHeight

	^ 15! !

!FileList methodsFor: 'initialization' stamp: 'sw 11/30/2002 14:36'!
optionalButtonRow
	"Answer the button row associated with a file list"

	| aRow |
	aRow _ AlignmentMorph newRow beSticky.
	aRow color: Color transparent.
	aRow clipSubmorphs: true.
	aRow layoutInset: 5@1; cellInset: 6.
	self universalButtonServices do:  "just the three sort-by items"
			[:service |
				aRow addMorphBack: (service buttonToTriggerIn: self).
				(service selector  == #sortBySize)
					ifTrue:
						[aRow addTransparentSpacerOfSize: (4@0)]].
	aRow setNameTo: 'buttons'.
	aRow setProperty: #buttonRow toValue: true.  "Used for dynamic retrieval later on"
	^ aRow! !

!FileList methodsFor: 'initialization' stamp: 'sw 2/17/2002 00:07'!
optionalButtonSpecs
	"Answer a list of services underlying the optional buttons in their initial inception."

	^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize}! !

!FileList methodsFor: 'initialization' stamp: 'sw 2/17/2002 05:39'!
optionalButtonView
	"Answer a view of optional buttons"

	| aView bHeight windowWidth offset previousView aButtonView wid services sel allServices |
	aView _ View new model: self.
	bHeight _ self optionalButtonHeight.
	windowWidth _ 120.
	aView window: (0 @ 0 extent: windowWidth @ bHeight).
	offset _ 0.
	allServices _ self universalButtonServices.
	services _ allServices copyFrom: 1 to: (allServices size min: 5).
	previousView _ nil.
	services
		do: [:service | sel _ service selector.
		aButtonView _ sel asString numArgs = 0
			ifTrue: [PluggableButtonView
					on: service provider
					getState: (service extraSelector == #none
							ifFalse: [service extraSelector])
					action: sel]
			ifFalse: [PluggableButtonView
					on: service provider
					getState: (service extraSelector == #none
							ifFalse: [service extraSelector])
					action: sel
					getArguments: #fullName
					from: self].
		service selector = services last selector
			ifTrue: [wid _ windowWidth - offset]
			ifFalse: [aButtonView
					borderWidthLeft: 0
					right: 1
					top: 0
					bottom: 0.
				wid _ windowWidth // services size - 2].
		aButtonView label: service buttonLabel asParagraph;
			window: (offset @ 0 extent: wid @ bHeight).
		offset _ offset + wid.
		service selector = services first selector
			ifTrue: [aView addSubView: aButtonView]
			ifFalse: [aView addSubView: aButtonView toRightOf: previousView].
		previousView _ aButtonView].
	^ aView! !

!FileList methodsFor: 'initialization' stamp: 'di 5/11/1999 22:25'!
release

	self modelSleep! !

!FileList methodsFor: 'initialization' stamp: 'tk 5/21/1998 12:28'!
setFileStream: aStream
	"Used to initialize a spawned file editor.  Sets directory too."

	self directory: aStream directory.
	fileName _ aStream localName.
	pattern _ '*'.
	listIndex _ 1.  "pretend a file is selected"
	aStream close.
	brevityState _ #needToGetBrief.
	self changed: #contents.
! !

!FileList methodsFor: 'initialization' stamp: 'sw 2/17/2002 05:38'!
universalButtonServices
	"Answer a list of services underlying the universal buttons in their initial inception.  For the moment, only the sorting buttons are shown."

	^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize}! !

!FileList methodsFor: 'initialization' stamp: 'gm 2/16/2003 20:38'!
updateButtonRow
	"Dynamically update the contents of the button row, if any."

	| aWindow aRow |
	Smalltalk isMorphic ifFalse: [^self].
	aWindow := self dependents 
				detect: [:m | (m isSystemWindow) and: [m model == self]]
				ifNone: [^self].
	aRow := aWindow findDeepSubmorphThat: [:m | m hasProperty: #buttonRow]
				ifAbsent: [^self].
	aRow submorphs size - 4 timesRepeat: [aRow submorphs last delete].
	self dynamicButtonServices do: 
			[:service | 
			aRow addMorphBack: (service buttonToTriggerIn: self).
			service addDependent: self]! !


!FileList methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:38'!
copyName

	listIndex = 0 ifTrue: [^ self].
	Clipboard clipboardText: self fullName asText.
! !

!FileList methodsFor: 'menu messages' stamp: 'sw 11/30/2002 15:38'!
perform: selector orSendTo: otherTarget 
	"Selector was just chosen from a menu by a user.
	If it's one of the three sort-by items, handle it specially.
	If I can respond myself, then perform it on myself. 
	If not, send it to otherTarget, presumably the editPane from which the menu was invoked."

	^ (#(sortByDate sortBySize sortByName) includes: selector)
		ifTrue:
			[self resort: selector]
		ifFalse:
			[(#(get getHex copyName openImageInWindow importImage renameFile deleteFile addNewFile) includes: selector)
				ifTrue: [self perform: selector]
				ifFalse: [super perform: selector orSendTo: otherTarget]]! !


!FileList methodsFor: 'own services' stamp: 'sw 2/15/2002 19:07'!
serviceAddNewDirectory
	"Answer a service entry characterizing the 'add new directory' command"

	^ SimpleServiceEntry 
		provider: self 
		label: 'add new directory' 
		selector: #addNewDirectory
		description: 'adds a new, empty directory (folder)' ! !

!FileList methodsFor: 'own services' stamp: 'sw 2/11/2002 23:36'!
serviceAddNewFile
	"Answer a service entry characterizing the 'add new file' command"

	^ SimpleServiceEntry provider: self label: 'add new file' selector: #addNewFile description: 'create a new,. empty file, and add it to the current directory.'! !

!FileList methodsFor: 'own services' stamp: 'sd 1/31/2002 22:12'!
serviceAllFileOptions

	^ {SimpleServiceEntry provider: self label: 'more...' selector: #offerAllFileOptions description: 'show all the options available'}! !

!FileList methodsFor: 'own services' stamp: 'sw 2/17/2002 01:36'!
serviceBroadcastUpdate
	"Answer a service for broadcasting a file as an update"

	^ SimpleServiceEntry
		provider: self 
		label: 'broadcast as update'
		selector: #putUpdate:
		description: 'broadcast file as update'
		buttonLabel: 'broadcast'! !

!FileList methodsFor: 'own services' stamp: 'sw 2/17/2002 02:36'!
serviceCompressFile
	"Answer a service for compressing a file"

	^ SimpleServiceEntry provider: self label: 'compress' selector: #compressFile description: 'compress file' buttonLabel: 'compress'! !

!FileList methodsFor: 'own services' stamp: 'sd 1/31/2002 22:16'!
serviceCopyName

	^ (SimpleServiceEntry provider: self label: 'copy name to clipboard' selector: #copyName description:'copy name to clipboard' )! !

!FileList methodsFor: 'own services' stamp: 'sd 1/31/2002 21:17'!
serviceDeleteFile

	^ (SimpleServiceEntry provider: self label: 'delete' selector: #deleteFile)
			description: 'delete the seleted item'! !

!FileList methodsFor: 'own services' stamp: 'sw 2/16/2002 01:39'!
serviceGet
	"Answer a service for getting the entire file"

	^  (SimpleServiceEntry 
			provider: self 
			label: 'get entire file' 
			selector: #get
			description: 'if the file has only been partially read in, because it is very large, read the entire file in at this time.')! !

!FileList methodsFor: 'own services' stamp: 'yo 3/31/2003 11:24'!
serviceGetEncodedText

	^  (SimpleServiceEntry 
			provider: self 
			label: 'view as encoded text'
			selector: #getEncodedText
			description: 'view as encoded text')

! !

!FileList methodsFor: 'own services' stamp: 'sd 2/1/2002 20:50'!
serviceGetHex

	^  (SimpleServiceEntry 
			provider: self 
			label: 'view as hex' 
			selector: #getHex
			description: 'view as hex')
			
! !

!FileList methodsFor: 'own services' stamp: 'sd 1/31/2002 22:15'!
serviceRenameFile

	^ (SimpleServiceEntry provider: self label: 'rename' selector: #renameFile description: 'rename file')! !

!FileList methodsFor: 'own services' stamp: 'sw 2/16/2002 01:39'!
serviceSortByDate
	"Answer a service for sorting by date"

	^  (SimpleServiceEntry new
			provider: self 
			label: 'by date' 
			selector: #sortByDate 
			description: 'sort entries by date')
		extraSelector: #sortingByDate;
		buttonLabel: 'date'! !

!FileList methodsFor: 'own services' stamp: 'sw 2/16/2002 01:39'!
serviceSortByName
	"Answer a service for soring by name"

	^ (SimpleServiceEntry new
		provider: self label: 'by name' selector: #sortByName 
		description: 'sort entries by name')
		extraSelector: #sortingByName;
		buttonLabel: 'name'! !

!FileList methodsFor: 'own services' stamp: 'sw 2/16/2002 01:40'!
serviceSortBySize
	"Answer a service for sorting by size"

	^  (SimpleServiceEntry 
			provider: self 
			label: 'by size' 
			selector: #sortBySize
			description: 'sort entries by size')
				extraSelector: #sortingBySize;
				buttonLabel: 'size'! !

!FileList methodsFor: 'own services' stamp: 'sw 11/8/2003 13:34'!
serviceViewContentsInWorkspace
	"Answer a service for viewing the contents of a file in a workspace"
	
	^ (SimpleServiceEntry provider: self label: 'workspace with contents' selector: #viewContentsInWorkspace)
			description: 'open a new Workspace whose contents are set to the contents of this file'! !

!FileList methodsFor: 'own services' stamp: 'sw 2/15/2002 20:19'!
servicesFromSelectorSpecs: symbolArray
	"Answer an array of services represented by the incoming symbols, eliminating any that do not have a currently-registered service.  Pass the symbol #- along unchanged to serve as a separator between services"

	"FileList new servicesFromSelectorSpecs: #(fileIn: fileIntoNewChangeSet: browseChangesFile:)"

	| res services col | 
	col := OrderedCollection new.
	services := self class allRegisteredServices, (self myServicesForFile: #dummy suffix: '*').
	symbolArray do: 
		[:sel | 
			sel == #-
				ifTrue:
					[col add: sel]
				ifFalse:
					[res := services
							detect: [:each | each selector = sel] ifNone: [nil].
					res notNil
							ifTrue: [col add: res]]].
	^ col! !

!FileList methodsFor: 'own services' stamp: 'edc 5/31/2006 07:37'!
viewContentsInWorkspace
	"View the contents of my selected file in a new workspace"
	
	| aString aFileStream aName |
	aString := (aFileStream := directory readOnlyFileNamed: self fullName) setConverterForCode contentsOfEntireFile.
	aName := aFileStream localName.
	aFileStream close.
	UIManager default edit: aString label: 'Workspace from ', aName! !


!FileList methodsFor: 'server list' stamp: 'SD 11/10/2001 17:49'!
askServerInfo
	"Get the user to create a ServerDirectory for a new server.  Fill in and say Accept."
	| template |
	template _ '"Please fill in the following info, then select all text and choose DoIt."

	| aa | 
	self flag: #ViolateNonReferenceToOtherClasses.
	aa _ ServerDirectory new.
	aa server: ''st.cs.uiuc.edu''.    "host"
	aa user: ''anonymous''.
	aa password: ''yourEmail@school.edu''.
	aa directory: ''/Smalltalk/Squeak/Goodies''.
	aa url: ''''.    "<- this is optional.  Only used when *writing* update files."
	ServerDirectory addServer: aa named: ''UIUCArchive''.  "<- known by this name in Squeak"'.

	(StringHolder new contents: template) openLabel: 'FTP Server Form'
	! !

!FileList methodsFor: 'server list' stamp: 'di 1/29/2002 21:45'!
putUpdate: fullFileName
	"Put this file out as an Update on the servers."

	| names choice |
	self canDiscardEdits ifFalse: [^ self changed: #flash].
	names _ ServerDirectory groupNames asSortedArray.
	choice _ (SelectionMenu labelList: names selections: names) startUp.
	choice == nil ifTrue: [^ self].
	(ServerDirectory serverInGroupNamed: choice) putUpdate: 
				(directory oldFileNamed: fullFileName).
	self volumeListIndex: volListIndex.
! !

!FileList methodsFor: 'server list' stamp: 'SD 11/10/2001 17:49'!
removeServer

	| choice names |
	self flag: #ViolateNonReferenceToOtherClasses.
	names := ServerDirectory serverNames asSortedArray.
	choice := (SelectionMenu labelList: names selections: names) startUp.
	choice == nil ifTrue: [^ self].
	ServerDirectory removeServerNamed: choice! !


!FileList methodsFor: 'updating' stamp: 'sw 11/30/2002 16:49'!
update: aParameter
	"Receive a change notice from an object of whom the receiver is a dependent"

	(aParameter == #fileListChanged) ifTrue: [self updateFileList].
	super update: aParameter! !


!FileList methodsFor: 'volume list and pattern' stamp: 'tpr 11/28/2003 11:44'!
deleteDirectory
	"Remove the currently selected directory"
	| localDirName |
	directory entries size = 0 ifFalse:[^self inform:'Directory must be empty'].
	localDirName _ directory localName.
	(self confirm: 'Really delete ' , localDirName , '?') ifFalse: [^ self].
	self volumeListIndex: self volumeListIndex-1.
	directory deleteDirectory: localDirName.
	self updateFileList.! !

!FileList methodsFor: 'volume list and pattern' stamp: 'SD 11/11/2001 13:59'!
directory

	^ directory! !

!FileList methodsFor: 'volume list and pattern' stamp: 'ls 7/25/1998 01:15'!
fileNameFormattedFrom: entry sizePad: sizePad
	"entry is a 5-element array of the form:
		(name creationTime modificationTime dirFlag fileSize)"
	| sizeStr nameStr dateStr |
	nameStr _ (entry at: 4)
		ifTrue: [entry first , self folderString]
		ifFalse: [entry first].
	dateStr _ ((Date fromSeconds: (entry at: 3) )
					printFormat: #(3 2 1 $. 1 1 2)) , ' ' ,
				(String streamContents: [:s |
					(Time fromSeconds: (entry at: 3) \\ 86400)
						print24: true on: s]).
	sizeStr _ (entry at: 5) asStringWithCommas.
	sortMode = #name ifTrue:
		[^ nameStr , '    (' , dateStr , ' ' , sizeStr , ')'].
	sortMode = #date ifTrue:
		[^ '(' , dateStr , ' ' , sizeStr , ') ' , nameStr].
	sortMode = #size ifTrue:
		[^ '(' , ((sizeStr size to: sizePad) collect: [:i | $ ]) , sizeStr , ' ' , dateStr , ') ' , nameStr].
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'sma 11/11/2000 18:06'!
listForPattern: pat
	"Make the list be those file names which match the pattern."

	| sizePad newList |
	newList _ (self entriesMatching: pat) asSortedCollection: self sortBlock.
	sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
					asStringWithCommas size - 1.
	newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].

	volList size = 1 ifTrue:
		["Include known servers along with other desktop volumes" 
		^ newList asArray ,
		(ServerDirectory serverNames collect: [:n | '^' , n , self folderString])].
	^ newList asArray! !

!FileList methodsFor: 'volume list and pattern' stamp: 'tk 4/7/98 15:26'!
pattern

	^ pattern ifNil: ['*']
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'jm 5/3/1998 19:01'!
pattern: textOrStringOrNil

	textOrStringOrNil
		ifNil: [pattern _ '*']
		ifNotNil: [pattern _ textOrStringOrNil asString].
	self updateFileList.
	^ true
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'sw 3/6/1999 11:39'!
veryDeepFixupWith: deepCopier
	super veryDeepFixupWith: deepCopier.
	volListIndex _ 1.
	self directory: FileDirectory default.
	self updateFileList! !

!FileList methodsFor: 'volume list and pattern' stamp: 'jm 5/3/1998 18:20'!
volumeList
	"Answer the current list of volumes."

	^ volList
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'jm 5/3/1998 18:21'!
volumeListIndex
	"Answer the index of the currently selected volume."

	^ volListIndex
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'sw 2/21/2002 02:01'!
volumeListIndex: index
	"Select the volume name having the given index."

	| delim path |
	volListIndex := index.
	index = 1 
		ifTrue: [self directory: (FileDirectory on: '')]
		ifFalse: [delim := directory pathNameDelimiter.
				path := String streamContents: [:strm |
					2 to: index do: [:i |
						strm nextPutAll: (volList at: i) withBlanksTrimmed.
						i < index ifTrue: [strm nextPut: delim]]].
				self directory: (directory on: path)].
	brevityState := #FileList.
	self addPath: path.
	self changed: #fileList.
	self changed: #contents.
	self updateButtonRow! !


!FileList methodsFor: 'volume menu' stamp: 'nk 6/12/2004 12:07'!
volumeMenu: aMenu
	aMenu addList: {
			{'recent...' translated.		#recentDirs}.
			#-.
			{'add server...' translated.		#askServerInfo}.
			{'remove server...' translated.		#removeServer}.
			#-.
			{'delete directory...' translated.	#deleteDirectory}.
			#-}.
	aMenu
		addServices: (self itemsForDirectory: self directory)
		for: self
		extraLines: #().
	^aMenu.! !


!FileList methodsFor: 'private' stamp: 'stp 12/11/1999 20:05'!
addPath: aString
	"Add the given string to the list of recently visited directories."

	| full |
	aString ifNil: [^self].
	full := String streamContents: 
		[ :strm | 2 to: volList size do: 
			[ :i | strm nextPutAll: (volList at: i) withBlanksTrimmed.
			strm nextPut: FileDirectory pathNameDelimiter]].
	full := full, aString.
"Remove and super-directories of aString from the collection."
	RecentDirs removeAllSuchThat: [ :aDir | ((aDir, '*') match: full)].

"If a sub-directory is in the list, do nothing."
	(RecentDirs detect: [ :aDir | ((full, '*') match: aDir)] ifNone: [nil])
		ifNotNil: [^self].

	[RecentDirs size >= 10]
		whileTrue: [RecentDirs removeFirst].
	RecentDirs addLast: full! !

!FileList methodsFor: 'private' stamp: 'yo 7/5/2004 19:41'!
contents
	"Answer the contents of the file, reading it first if needed."
	"Possible brevityState values:
		FileList,
		fullFile, briefFile, needToGetFull, needToGetBrief,
		fullHex, briefHex, needToGetFullHex, needToGetBriefHex"

	(listIndex = 0) | (brevityState == #FileList) ifTrue: [^ self defaultContents].  "no file selected"
	brevityState == #fullFile ifTrue: [^ contents].
	brevityState == #fullHex ifTrue: [^ contents].
	brevityState == #briefFile ifTrue: [^ contents].
	brevityState == #briefHex ifTrue: [^ contents].

	brevityState == #needToGetFullHex ifTrue: [^ self readContentsHex: false].
	brevityState == #needToGetBriefHex ifTrue: [^ self readContentsHex: true].

	brevityState == #needToGetFull ifTrue: [^ self readContentsBrief: false].
	brevityState == #needToGetBrief ifTrue: [^ self readContentsBrief: true].  "default"

	(TextConverter allEncodingNames includes: brevityState) 
		ifTrue: [ ^self readContentsAsEncoding: brevityState].

	self halt: 'unknown state ' , brevityState printString! !

!FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:22'!
defaultContents
	contents _ list == nil
		ifTrue: [String new]
		ifFalse: [String streamContents:
					[:s | s nextPutAll: 'NO FILE SELECTED' translated; cr.
					s nextPutAll: '  -- Folder Summary --' translated; cr.
					list do: [:item | s nextPutAll: item; cr]]].
	brevityState _ #FileList.
	^ contents! !

!FileList methodsFor: 'private' stamp: 'yo 7/6/2004 20:52'!
defaultEncoderFor: aFileName

	"This method just illustrates the stupidest possible implementation of encoder selection."
	| l |
	l _ aFileName asLowercase.
"	((l endsWith: FileStream multiCs) or: [
		l endsWith: FileStream multiSt]) ifTrue: [
		^ UTF8TextConverter new.
	].
"
	((l endsWith: FileStream cs) or: [
		l endsWith: FileStream st]) ifTrue: [
		^ MacRomanTextConverter new.
	].

	^ Latin1TextConverter new.

	! !

!FileList methodsFor: 'private' stamp: 'sma 11/11/2000 17:00'!
entriesMatching: patternString
	"Answer a list of directory entries which match the patternString.
	The patternString may consist of multiple patterns separated by ';'.
	Each pattern can include a '*' or '#' as wildcards - see String>>match:"

	| entries patterns |
	entries _ directory entries.
	patterns _ patternString findTokens: ';'.
	(patterns anySatisfy: [:each | each = '*'])
		ifTrue: [^ entries].
	^ entries select: [:entry | 
		entry isDirectory or: [patterns anySatisfy: [:each | each match: entry first]]]! !

!FileList methodsFor: 'private' stamp: 'rhi 9/8/2001 02:17'!
fileNameFromFormattedItem: item
	"Extract fileName and folderString from a formatted fileList item string"

	| from to |
	self sortingByName
		ifTrue: [
			from _ item lastIndexOf: $( ifAbsent: [0].
			to _ item lastIndexOf: $) ifAbsent: [0]]
		ifFalse: [
			from _ item indexOf: $( ifAbsent: [0].
			to _ item indexOf: $) ifAbsent: [0]].
	^ (from * to = 0
		ifTrue: [item]
		ifFalse: [item copyReplaceFrom: from to: to with: '']) withBlanksTrimmed! !

!FileList methodsFor: 'private'!
folderString
	^ ' [...]'! !

!FileList methodsFor: 'private' stamp: 'sw 1/7/2003 17:08'!
fullName
	"Answer the full name for the currently selected file; answer nil if no file is selected."

	^ fileName ifNotNil: [directory
		ifNil:
			[FileDirectory default fullNameFor: fileName]
		ifNotNil:
			[directory fullNameFor: fileName]]
! !

!FileList methodsFor: 'private' stamp: 'SD 11/14/2001 21:59'!
isFileSelected
	"return if a file is currently selected"

	^ fileName isNil not! !

!FileList methodsFor: 'private' stamp: 'nk 2/20/2001 12:36'!
listForPatterns: anArray
	"Make the list be those file names which match the pattern."

	| sizePad newList |
	newList _ Set new.
	anArray do: [ :pat | newList addAll: (self entriesMatching: pat) ].
	newList _ (SortedCollection sortBlock: self sortBlock) addAll: newList; yourself.
	sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
					asStringWithCommas size - 1.
	newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].

	volList size = 1 ifTrue:
		["Include known servers along with other desktop volumes" 
		^ newList asArray ,
		(ServerDirectory serverNames collect: [:n | '^' , n , self folderString])].
	^ newList asArray! !

!FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:24'!
put: aText
	"Private - put the supplied text onto the file"

	| ff type |
	brevityState == #fullFile ifTrue:
		[ff _ directory newFileNamed: self fullName.
		Cursor write showWhile: [ff nextPutAll: aText asString; close].
		fileName = ff localName 
			ifTrue: [contents _ aText asString]
			ifFalse: [self updateFileList].		"user renamed the file"
		^ true  "accepted"].

	listIndex = 0 ifTrue:
		[self inform: 'No fileName is selected' translated.
		^ false  "failed"].
	type _ 'These'.
	brevityState = #briefFile ifTrue: [type _ 'Abbreviated'].
	brevityState = #briefHex ifTrue: [type _ 'Abbreviated'].
	brevityState = #fullHex ifTrue: [type _ 'Hexadecimal'].
	brevityState = #FileList ifTrue: [type _ 'Directory'].
	self inform: ('{1} contents cannot
meaningfully be saved at present.' translated format:{type translated}).
	^ false  "failed"
! !

!FileList methodsFor: 'private' stamp: 'yo 3/14/2005 13:55'!
readContentsAsEncoding: encodingName
	| f writeStream converter c |
	f _ directory oldFileOrNoneNamed: self fullName.
	f ifNil: [^ 'For some reason, this file cannot be read'].
	writeStream _ WriteStream on: String new.
	converter _ TextConverter defaultConverterClassForEncoding: encodingName.
	converter ifNil: [^ 'This encoding is not supported'].
	f converter: converter new.
	f wantsLineEndConversion: true.
	[f atEnd or: [(c _ f next) isNil]]
		whileFalse: [writeStream nextPut: c].
	f close.
	^ writeStream contents! !

!FileList methodsFor: 'private' stamp: 'tlk 11/13/2004 19:01'!
readContentsBrief: brevityFlag
	"Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist."
	| f fileSize first5000 |

	brevityFlag ifTrue: [
		directory isRemoteDirectory ifTrue: [^ self readServerBrief]].
	f := directory oldFileOrNoneNamed: self fullName.
	f ifNil: [^ 'For some reason, this file cannot be read' translated].
	f converter: (self defaultEncoderFor: self fullName).
	(brevityFlag not or: [(fileSize := f size) <= 100000]) ifTrue:
		[contents := f contentsOfEntireFile.
		brevityState := #fullFile.   "don't change till actually read"
		^ contents].

	"if brevityFlag is true, don't display long files when first selected"
	first5000 := f next: 5000.
	f close.
	contents := 'File ''{1}'' is {2} bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 5000 characters...
------------------------------------------
{3}
------------------------------------------
... end of the first 5000 characters.' translated format: {fileName. fileSize. first5000}.
	brevityState := #briefFile.   "don't change till actually read"
	^ contents.
! !

!FileList methodsFor: 'private' stamp: 'ka 8/24/2000 18:55'!
readContentsCNGB
	| f writeStream |
	f _ directory oldFileOrNoneNamed: self fullName.
	f ifNil: [^ 'For some reason, this file cannot be read'].
	writeStream _ WriteStream on: String new.
	f converter: CNGBTextConverter new.
	[f atEnd]
		whileFalse: [writeStream nextPut: f next].
	f close.
	^ writeStream contents! !

!FileList methodsFor: 'private' stamp: 'ka 8/24/2000 18:31'!
readContentsEUCJP
	| f writeStream |
	f _ directory oldFileOrNoneNamed: self fullName.
	f ifNil: [^ 'For some reason, this file cannot be read'].
	writeStream _ WriteStream on: String new.
	f converter: EUCJPTextConverter new.
	[f atEnd]
		whileFalse: [writeStream nextPut: f next].
	f close.
	^ writeStream contents! !

!FileList methodsFor: 'private' stamp: 'ka 8/24/2000 18:56'!
readContentsEUCKR
	| f writeStream |
	f _ directory oldFileOrNoneNamed: self fullName.
	f ifNil: [^ 'For some reason, this file cannot be read'].
	writeStream _ WriteStream on: String new.
	f converter: EUCKRTextConverter new.
	[f atEnd]
		whileFalse: [writeStream nextPut: f next].
	f close.
	^ writeStream contents! !

!FileList methodsFor: 'private' stamp: 'BG 3/16/2005 08:22'!
readContentsHex: brevity
	"retrieve the contents from the external file unless it is too long.
	  Don't create a file here.  Check if exists."
	| f size data hexData s |

	f := directory oldFileOrNoneNamed: self fullName. 
	f == nil ifTrue: [^ 'For some reason, this file cannot be read' translated].
	f binary.
	((size := f size)) > 5000 & brevity
		ifTrue: [data := f next: 10000. f close. brevityState := #briefHex]
		ifFalse: [data := f contentsOfEntireFile. brevityState := #fullHex].

	s := WriteStream on: (String new: data size*4).
	0 to: data size-1 by: 16 do:
		[:loc | s nextPutAll: loc printStringHex; space;
			nextPut: $(; print: loc; nextPut: $); space; tab.
		loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) printStringHex; space].
		s cr].
	hexData := s contents.

	^ contents := ((size > 5000) & brevity
		ifTrue: ['File ''{1}'' is {2} bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 5000 characters...
------------------------------------------
{3}
------------------------------------------
... end of the first 5000 characters.' translated format: {fileName. size. hexData}]
		ifFalse: [hexData]).
! !

!FileList methodsFor: 'private' stamp: 'ka 8/26/2000 18:48'!
readContentsShiftJIS
	| f writeStream |
	f _ directory oldFileOrNoneNamed: self fullName.
	f ifNil: [^ 'For some reason, this file cannot be read'].
	writeStream _ WriteStream on: String new.
	f converter: ShiftJISTextConverter new.
	[f atEnd]
		whileFalse: [writeStream nextPut: f next].
	f close.
	^ writeStream contents! !

!FileList methodsFor: 'private' stamp: 'ka 6/23/2002 15:55'!
readContentsUTF8
	| f writeStream |
	f _ directory oldFileOrNoneNamed: self fullName.
	f ifNil: [^ 'For some reason, this file cannot be read'].
	writeStream _ WriteStream on: String new.
	f converter: UTF8TextConverter new.
	[f atEnd]
		whileFalse: [writeStream nextPut: f next].
	f close.
	^ writeStream contents! !

!FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:09'!
readServerBrief
	| lString sizeStr fsize ff first5000 parts |
	"If file on server is known to be long, just read the beginning.  Cheat badly by reading the fileList string."

	listIndex = 0 ifTrue: [^ self].
	"Get size from file list entry"
	lString := list at: listIndex.
	parts := lString findTokens: '()'.
	sortMode = #name ifTrue: [sizeStr := (parts second findTokens: ' ') third].
	sortMode = #date ifTrue: [sizeStr := (parts first findTokens: ' ') third].
	sortMode = #size ifTrue: [sizeStr := (parts first findTokens: ' ') first].
	fsize := (sizeStr copyWithout: $,) asNumber.

	fsize <= 50000 ifTrue:
		[ff := directory oldFileOrNoneNamed: self fullName.
		ff ifNil: [^ 'For some reason, this file cannot be read' translated].
		contents := ff contentsOfEntireFile.
		brevityState := #fullFile.   "don't change till actually read"
		^ contents].

	"if brevityFlag is true, don't display long files when first selected"
	first5000 := directory getOnly: 3500 from: fileName.
	contents := 'File ''{1}'' is {2} bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 3500 characters...
------------------------------------------
{3}
------------------------------------------
... end of the first 3500 characters.' translated format: {fileName. sizeStr. first5000}.
	brevityState := #briefFile.   "don't change till actually read"
	^ contents.

! !

!FileList methodsFor: 'private' stamp: 'stp 12/11/1999 20:03'!
recentDirs
	"Put up a menu and let the user select from the list of recently visited directories."

	| dirName |
	RecentDirs isEmpty ifTrue: [^self].
	dirName := (SelectionMenu selections: RecentDirs) startUp.
	dirName == nil ifTrue: [^self].
	self directory: (FileDirectory on: dirName)! !

!FileList methodsFor: 'private' stamp: 'SD 11/8/2001 21:11'!
registeredFileReaderClasses
	"return the list of classes that provide file reader services"

	^ self class registeredFileReaderClasses! !

!FileList methodsFor: 'private' stamp: 'sw 11/30/2002 16:34'!
resort: newMode
	"Re-sort the list of files."

	| name |
	listIndex > 0
		ifTrue: [name _ self fileNameFromFormattedItem: (list at: listIndex)].
	sortMode _ newMode.
	self pattern: pattern.
	name ifNotNil: [
		fileName _ name.
		listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = name. ].
		self changed: #fileListIndex].
	listIndex = 0 ifTrue: [self changed: #contents].
	self updateButtonRow
! !

!FileList methodsFor: 'private' stamp: 'mu 8/22/2003 01:46'!
selectEncoding

	| aMenu encodingItems |
	aMenu _ CustomMenu new.
	encodingItems _ OrderedCollection new.
	TextConverter allSubclasses do: [:each | | names |
		names _ each encodingNames.
		names notEmpty ifTrue: [ | label |
			label _ '' writeStream.
			names do: [:eachName | label nextPutAll: eachName ] separatedBy: [ label nextPutAll: ', '].
			encodingItems add: {label contents. names first asSymbol}.
		].
	].
	aMenu addList: encodingItems.
	brevityState _ aMenu startUp.
	brevityState ifNil: [brevityState _ #needToGetBrief].
! !

!FileList methodsFor: 'private' stamp: 'sma 11/11/2000 17:04'!
sortBlock
	"Answer block to decide what order to display the directory entries."

	^ [ :x :y |
			(x isDirectory = y isDirectory) 
				ifTrue: [  
					"sort by user-specified criterion"
					sortMode = #name 
						ifTrue: [(x name compare: y name) <= 2]
						ifFalse: [ sortMode = #date
							ifTrue: [ x modificationTime = y modificationTime
									ifTrue: [ (x name compare: y name) <= 2 ]
									ifFalse: [ x modificationTime > y modificationTime ] ]
							ifFalse: [ "size"
								x fileSize = y fileSize 
									ifTrue: [ (x name compare: y name) <= 2 ]
									ifFalse: [ x fileSize > y fileSize ] ] ] ]
				ifFalse: [
					"directories always precede files"
					x isDirectory ] ]! !

!FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:58'!
sortingByDate
	^ sortMode == #date! !

!FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:57'!
sortingByName
	^ sortMode == #name! !

!FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:58'!
sortingBySize
	^ sortMode == #size! !

!FileList methodsFor: 'private' stamp: 'nk 12/10/2002 07:57'!
updateFileList
	"Update my files list with file names in the current directory  
	that match the pattern.
	The pattern string may have embedded newlines or semicolons; these separate different patterns."
	| patterns |
	patterns _ OrderedCollection new.
	Cursor wait showWhile: [
	(pattern findTokens: (String with: Character cr with: Character lf with: $;))
		do: [ :each |
			(each includes: $*) | (each includes: $#)
					ifTrue: [ patterns add: each]
					ifFalse: [each isEmpty
										ifTrue: [ patterns add: '*']
										ifFalse: [ patterns add: '*' , each , '*']]].

	list _ self listForPatterns: patterns.
	listIndex _ 0.
	volListIndex _ volList size.
	fileName _ nil.
	contents _ ''.
	self changed: #volumeListIndex.
	self changed: #fileList.
	self updateButtonRow]! !

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

FileList class
	instanceVariableNames: ''!

!FileList class methodsFor: 'class initialization' stamp: 'dvf 8/23/2003 12:17'!
initialize
	"FileList initialize"

	RecentDirs := OrderedCollection new.
	(self systemNavigation allClassesImplementing: #fileReaderServicesForFile:suffix:) do: 		[:providerMetaclass |
			self registerFileReader: providerMetaclass soleInstance]! !

!FileList class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:47'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(FileList					prototypicalToolWindow		'File List'			'A File List is a tool for browsing folders and files on disks and on ftp types.') 
						forFlapNamed: 'Tools']! !

!FileList class methodsFor: 'class initialization' stamp: 'ar 9/27/2005 21:48'!
removeObsolete
	"FileList removeObsolete"
	self registeredFileReaderClasses copy 
		do:[:cls| cls isObsolete ifTrue:[self unregisterFileReader: cls]]! !

!FileList class methodsFor: 'class initialization' stamp: 'asm 4/08/2003 12:15'!
unload
	"Unload the receiver from global registries"

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


!FileList class methodsFor: 'file reader registration' stamp: 'sd 2/1/2002 21:30'!
allRegisteredServices
	"self allRegisteredServices"

	| col |
	col := OrderedCollection new.
	self registeredFileReaderClasses do: [:each | col addAll: (each services)].
	^ col! !

!FileList class methodsFor: 'file reader registration' stamp: 'sd 1/31/2002 21:42'!
detectService: aBlock ifNone: anotherBlock
	"self detectService: [:each | each selector = #fileIn:] ifNone: [nil]"

	^ self allRegisteredServices
			detect: aBlock
			ifNone: anotherBlock! !

!FileList class methodsFor: 'file reader registration' stamp: 'SD 11/11/2001 13:53'!
isReaderNamedRegistered: aSymbol
	"return if a given reader class has been registered. Note that this is on purpose that the argument is
	a symbol and not a class"

	 ^ (self registeredFileReaderClasses collect: [:each | each name]) includes: aSymbol
! !

!FileList class methodsFor: 'file reader registration' stamp: 'nk 6/12/2004 11:42'!
itemsForDirectory: aFileDirectory
	"Answer a list of services appropriate when no file is selected."

	| services |
	services _ OrderedCollection new.
	self registeredFileReaderClasses do: [:reader |
		reader ifNotNil: [services addAll: (reader fileReaderServicesForDirectory: aFileDirectory) ]].
	^ services! !

!FileList class methodsFor: 'file reader registration' stamp: 'nk 12/7/2002 12:53'!
itemsForFile: fullName
	"Answer a list of services appropriate for a file of the given full name"

	| services suffix |
	suffix _ self suffixOf: fullName.
	services _ OrderedCollection new.
	self registeredFileReaderClasses do: [:reader |
		reader ifNotNil: [services addAll: (reader fileReaderServicesForFile: fullName suffix: suffix)]].
	^ services! !

!FileList class methodsFor: 'file reader registration' stamp: 'SD 11/8/2001 21:17'!
registerFileReader: aProviderClass
	"register the given class as providing services for reading files"

	| registeredReaders |
	registeredReaders := self registeredFileReaderClasses.
	(registeredReaders includes: aProviderClass) 
			ifFalse: [ registeredReaders addLast: aProviderClass ]! !

!FileList class methodsFor: 'file reader registration' stamp: 'ar 9/29/2005 12:27'!
registeredFileReaderClasses
	FileReaderRegistry := nil. "wipe it out"
	^FileServices registeredFileReaderClasses
	! !

!FileList class methodsFor: 'file reader registration' stamp: 'nk 12/7/2002 12:52'!
suffixOf: aName
	"Answer the file extension of the given file"
	^ aName
		ifNil:
			['']
		ifNotNil:
			[(FileDirectory extensionFor: aName) asLowercase]! !

!FileList class methodsFor: 'file reader registration' stamp: 'SD 11/8/2001 21:18'!
unregisterFileReader: aProviderClass
	"unregister the given class as providing services for reading files"

	self registeredFileReaderClasses remove: aProviderClass ifAbsent: [nil]! !


!FileList class methodsFor: 'instance creation' stamp: 'md 2/24/2006 16:07'!
addButtonsAndFileListPanesTo: window at: upperFraction plus: offset forFileList: aFileList 
	| fileListMorph row buttonHeight fileListTop divider dividerDelta buttons |
	fileListMorph _ PluggableListMorph
				on: aFileList
				list: #fileList
				selected: #fileListIndex
				changeSelected: #fileListIndex:
				menu: #fileListMenu:.
	fileListMorph enableDrag: true; enableDrop: false.
	aFileList wantsOptionalButtons
		ifTrue: [buttons _ aFileList optionalButtonRow.
			divider _ BorderedSubpaneDividerMorph forBottomEdge.
			dividerDelta _ 0.
			buttons color: Color transparent.
					buttons
						submorphsDo: [:m | m borderWidth: 2;
								 borderColor: #raised].
divider extent: 4 @ 4;
						 color: Color transparent;
						 borderColor: #raised;
						 borderWidth: 2.
					fileListMorph borderColor: Color transparent.
					dividerDelta _ 3.
			row _ AlignmentMorph newColumn hResizing: #spaceFill;
						 vResizing: #spaceFill;
						 layoutInset: 0;
						 borderWidth: 2;
						 layoutPolicy: ProportionalLayout new.
			buttonHeight _ self defaultButtonPaneHeight.
			row
				addMorph: buttons
				fullFrame: (LayoutFrame
						fractions: (0 @ 0 corner: 1 @ 0)
						offsets: (0 @ 0 corner: 0 @ buttonHeight)).
			row
				addMorph: divider
				fullFrame: (LayoutFrame
						fractions: (0 @ 0 corner: 1 @ 0)
						offsets: (0 @ buttonHeight corner: 0 @ buttonHeight + dividerDelta)).
			row
				addMorph: fileListMorph
				fullFrame: (LayoutFrame
						fractions: (0 @ 0 corner: 1 @ 1)
						offsets: (0 @ buttonHeight + dividerDelta corner: 0 @ 0)).
			window
				addMorph: row
				fullFrame: (LayoutFrame
						fractions: upperFraction
						offsets: (0 @ offset corner: 0 @ 0)).
			row borderWidth: 2]
		ifFalse: [fileListTop _ 0.
			window
				addMorph: fileListMorph
				frame: (0.3 @ fileListTop corner: 1 @ 0.3)].! !

!FileList class methodsFor: 'instance creation' stamp: 'md 2/24/2006 15:59'!
addVolumesAndPatternPanesTo: window at: upperFraction plus: offset forFileList: aFileList 
	| row patternHeight volumeListMorph patternMorph divider dividerDelta |
	row _ AlignmentMorph newColumn hResizing: #spaceFill;
				 vResizing: #spaceFill;
				 layoutInset: 0;
				 borderWidth: 0;
				 layoutPolicy: ProportionalLayout new.
	patternHeight _ 25.
	volumeListMorph _ (PluggableListMorph
				on: aFileList
				list: #volumeList
				selected: #volumeListIndex
				changeSelected: #volumeListIndex:
				menu: #volumeMenu:)
				autoDeselect: false.
	volumeListMorph enableDrag: false; enableDrop: true.
	patternMorph _ PluggableTextMorph
				on: aFileList
				text: #pattern
				accept: #pattern:.
	patternMorph acceptOnCR: true.
	patternMorph hideScrollBarsIndefinitely.
	divider _ BorderedSubpaneDividerMorph horizontal.
	dividerDelta _ 0.
	divider extent: 4 @ 4;
			color: Color transparent;
			borderColor: #raised;
			borderWidth: 2.
		volumeListMorph borderColor: Color transparent.
		patternMorph borderColor: Color transparent.
		dividerDelta _ 3.
	row
		addMorph: (volumeListMorph autoDeselect: false)
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 1)
				offsets: (0 @ 0 corner: 0 @ patternHeight negated - dividerDelta)).
	row
		addMorph: divider
		fullFrame: (LayoutFrame
				fractions: (0 @ 1 corner: 1 @ 1)
				offsets: (0 @ patternHeight negated - dividerDelta corner: 0 @ patternHeight negated)).
	row
		addMorph: patternMorph
		fullFrame: (LayoutFrame
				fractions: (0 @ 1 corner: 1 @ 1)
				offsets: (0 @ patternHeight negated corner: 0 @ 0)).
	window
		addMorph: row
		fullFrame: (LayoutFrame
				fractions: upperFraction
				offsets: (0 @ offset corner: 0 @ 0)).
	row borderWidth: 2! !

!FileList class methodsFor: 'instance creation' stamp: 'sw 9/28/2001 09:21'!
defaultButtonPaneHeight
	"Answer the user's preferred default height for new button panes."

	^ Preferences
		parameterAt: #defaultButtonPaneHeight
		ifAbsentPut: [25]! !

!FileList class methodsFor: 'instance creation' stamp: 'sw 1/25/2001 08:45'!
open
	"Open a view of an instance of me on the default directory."
	"FileList open"
	| dir aFileList topView volListView templateView fileListView fileContentsView underPane pHeight |
	Smalltalk isMorphic ifTrue: [^ self openAsMorph].

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	topView _ StandardSystemView new.
	topView
		model: aFileList;
		label: dir pathName;
		minimumSize: 200@200.
	topView borderWidth: 1.

	volListView _ PluggableListView on: aFileList
		list: #volumeList
		selected: #volumeListIndex
		changeSelected: #volumeListIndex:
		menu: #volumeMenu:.
	volListView autoDeselect: false.
	volListView window: (0@0 extent: 80@45).
	topView addSubView: volListView.

	templateView _ PluggableTextView on: aFileList
		text: #pattern
		accept: #pattern:.
	templateView askBeforeDiscardingEdits: false.
	templateView window: (0@0 extent: 80@15).
	topView addSubView: templateView below: volListView.

	aFileList wantsOptionalButtons
		ifTrue:
			[underPane _ aFileList optionalButtonView.
			underPane isNil
				ifTrue: [pHeight _ 60]
				ifFalse: [
					topView addSubView: underPane toRightOf: volListView.
					pHeight _ 60 - aFileList optionalButtonHeight]]
		ifFalse:
			[underPane _ nil.
			pHeight _ 60].

	fileListView _ PluggableListView on: aFileList
		list: #fileList
		selected: #fileListIndex
		changeSelected: #fileListIndex:
		menu: #fileListMenu:.
	fileListView window: (0@0 extent: 120@pHeight).
	underPane isNil
		ifTrue: [topView addSubView: fileListView toRightOf: volListView]
		ifFalse: [topView addSubView: fileListView below: underPane].
	fileListView controller terminateDuringSelect: true.  "Pane to left may change under scrollbar"

	fileContentsView _ PluggableTextView on: aFileList
		text: #contents accept: #put:
		readSelection: #contentsSelection menu: #fileContentsMenu:shifted:.
	fileContentsView window: (0@0 extent: 200@140).
	topView addSubView: fileContentsView below: templateView.

	topView controller open! !

!FileList class methodsFor: 'instance creation' stamp: 'sbw 8/29/2001 19:37'!
openAsMorph
	"Open a morphic view of a FileList on the default directory."
	| dir aFileList window upperFraction offset |
	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	window _ (SystemWindow labelled: dir pathName)
				model: aFileList.
	upperFraction _ 0.3.
	offset _ 0.
	self
		addVolumesAndPatternPanesTo: window
		at: (0 @ 0 corner: 0.3 @ upperFraction)
		plus: offset
		forFileList: aFileList.
	self
		addButtonsAndFileListPanesTo: window
		at: (0.3 @ 0 corner: 1.0 @ upperFraction)
		plus: offset
		forFileList: aFileList.
	window
		addMorph: (PluggableTextMorph
				on: aFileList
				text: #contents
				accept: #put:
				readSelection: #contentsSelection
				menu: #fileContentsMenu:shifted:)
		frame: (0 @ 0.3 corner: 1 @ 1).
	^ window! !

!FileList class methodsFor: 'instance creation' stamp: 'SD 11/8/2001 21:21'!
openEditorOn: aFileStream editString: editString
	"Open an editor on the given FileStream."

	| fileModel topView fileContentsView |
	Smalltalk isMorphic ifTrue: [^ (self openMorphOn: aFileStream editString: editString) openInWorld].

	fileModel _ FileList new setFileStream: aFileStream.	"closes the stream"
	topView _ StandardSystemView new.
	topView
		model: fileModel;
		label: aFileStream fullName;
		minimumSize: 180@120.
	topView borderWidth: 1.

	fileContentsView _ PluggableTextView on: fileModel 
		text: #contents accept: #put:
		readSelection: #contentsSelection menu: #fileContentsMenu:shifted:.
	fileContentsView window: (0@0 extent: 180@120).
	topView addSubView: fileContentsView.
	editString ifNotNil: [fileContentsView editString: editString.
			fileContentsView hasUnacceptedEdits: true].

	topView controller open.
! !

!FileList class methodsFor: 'instance creation' stamp: 'SD 11/8/2001 21:20'!
openFileDirectly

	| aResult |
	(aResult _ StandardFileMenu oldFile) ifNotNil:
		[self openEditorOn: (aResult directory readOnlyFileNamed: aResult name) editString: nil]! !

!FileList class methodsFor: 'instance creation' stamp: 'di 10/18/1999 22:34'!
openMorphOn: aFileStream editString: editString 
	"Open a morphic view of a FileList on the given file."
	| fileModel window fileContentsView |

	fileModel _ FileList new setFileStream: aFileStream.	"closes the stream"
	window _ (SystemWindow labelled: aFileStream fullName) model: fileModel.

	window addMorph: (fileContentsView _ PluggableTextMorph on: fileModel 
			text: #contents accept: #put:
			readSelection: #contentsSelection 
			menu: #fileContentsMenu:shifted:)
		frame: (0@0 corner: 1@1).
	editString ifNotNil: [fileContentsView editString: editString.
			fileContentsView hasUnacceptedEdits: true].

	^ window! !

!FileList class methodsFor: 'instance creation' stamp: 'sw 6/11/2001 17:38'!
prototypicalToolWindow
	"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"

	^ self openAsMorph applyModelExtent! !


!FileList class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:04'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name  wording: 'File List' brightColor: #lightMagenta pastelColor: #paleMagenta helpMessage: 'A tool for looking at files'! !
FileList subclass: #FileList2
	instanceVariableNames: 'showDirsInFileList currentDirectorySelected fileSelectionBlock dirSelectionBlock optionalButtonSpecs modalView directoryChangeBlock ok'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-FileList'!
!FileList2 commentStamp: 'BJP 11/19/2003 21:13' prior: 0!
Some variations on FileList that
- use a hierarchical pane to show folder structure
- use different pane combinations, button layouts and prefiltering for specific uses

FileList2 morphicView openInWorld				"an alternative to the standard FileList"
FileList2 morphicViewNoFile openInWorld			"useful for selecting, but not viewing"
FileList2 morphicViewProjectLoader openInWorld	"useful for finding and loading projects"
FileList2 modalFolderSelector						"allows the user to select a folder"



!


!FileList2 methodsFor: 'as yet unclassified' stamp: 'BG 2/29/2004 23:40'!
specsForImageViewer

	 ^{self serviceSortByName. self serviceSortByDate. self serviceSortBySize }! !


!FileList2 methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 13:07'!
dropDestinationDirectory: dest event: evt
	"Answer a FileDirectory representing the drop destination in the directory hierarchy morph dest"
	^ (dest itemFromPoint: evt position) withoutListWrapper! !

!FileList2 methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 22:00'!
isDirectoryList: aMorph
	^aMorph isKindOf: SimpleHierarchicalListMorph! !


!FileList2 methodsFor: 'initialization' stamp: 'ar 10/10/2000 16:00'!
dirSelectionBlock: aBlock
	dirSelectionBlock _ aBlock! !

!FileList2 methodsFor: 'initialization' stamp: 'tpr 12/1/2003 17:14'!
directory: dir
	"Set the path of the volume to be displayed."

	self okToChange ifFalse: [^ self].

	self modelSleep.
	directory _ dir.
	self modelWakeUp.

	sortMode == nil ifTrue: [sortMode _ #date].
	volList _ Array with: '[]'.
	directory ifNotNil: [
		volList _ volList, directory pathParts.  "Nesting suggestion from RvL"
	].
	volList _ volList withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each].
	self changed: #relabel.
	self changed: #volumeList.
	self pattern: pattern.
	directoryChangeBlock ifNotNil: [directoryChangeBlock value: directory].! !

!FileList2 methodsFor: 'initialization' stamp: 'RAA 8/17/2000 13:22'!
directoryChangeBlock: aBlockOrNil

	directoryChangeBlock _ aBlockOrNil.! !

!FileList2 methodsFor: 'initialization' stamp: 'RAA 6/16/2000 13:08'!
fileSelectionBlock: aBlock

	fileSelectionBlock _ aBlock! !

!FileList2 methodsFor: 'initialization' stamp: 'ar 2/12/2001 16:12'!
initialDirectoryList

	| dir nameToShow dirList |
	dirList _ (FileDirectory on: '') directoryNames collect: [ :each |
		FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self].
	dirList isEmpty ifTrue:[
		dirList _ Array with: (FileDirectoryWrapper 
			with: FileDirectory default 
			name: FileDirectory default localName 
			model: self)].
	dirList _ dirList,(
		ServerDirectory serverNames collect: [ :n | 
			dir _ ServerDirectory serverNamed: n.
			nameToShow _ n.
			(dir directoryWrapperClass with: dir name: nameToShow model: self)
				balloonText: dir realUrl
		]
	).
	^dirList! !

!FileList2 methodsFor: 'initialization' stamp: 'RAA 6/16/2000 10:40'!
labelString
	^ (directory ifNil: [^'[]']) pathName contractTo: 50! !

!FileList2 methodsFor: 'initialization' stamp: 'mir 2/6/2004 17:25'!
limitedSuperSwikiDirectoryList

	| dir nameToShow dirList localDirName localDir |

	dirList _ OrderedCollection new.
	ServerDirectory serverNames do: [ :n | 
		dir _ ServerDirectory serverNamed: n.
		dir isProjectSwiki ifTrue: [
			nameToShow _ n.
			dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self)
				balloonText: dir realUrl)
		].
	].
	ServerDirectory localProjectDirectories do: [ :each |
		dirList add: (FileDirectoryWrapper with: each name: each localName model: self)
	].
	"Make sure the following are always shown, but not twice"
	localDirName := SecurityManager default untrustedUserDirectory.
	localDir := FileDirectory on: localDirName.
	((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName)
			ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)].
	FileDirectory default pathName = localDirName
			ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
	(dirList anySatisfy: [:each | each withoutListWrapper acceptsUploads])
		ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
	^dirList! !

!FileList2 methodsFor: 'initialization' stamp: 'mir 2/6/2004 17:25'!
limitedSuperSwikiPublishDirectoryList

	| dirList localDirName localDir |

	dirList _ self publishingServers.
	ServerDirectory localProjectDirectories do: [ :each |
		dirList add: (FileDirectoryWrapper with: each name: each localName model: self)].

	"Make sure the following are always shown, but not twice"
	localDirName := SecurityManager default untrustedUserDirectory.
	localDir := FileDirectory on: localDirName.
	((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName)
			ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)].
	FileDirectory default pathName = localDirName
			ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
	^dirList! !

!FileList2 methodsFor: 'initialization' stamp: 'RAA 6/16/2000 13:00'!
optionalButtonSpecs

	^optionalButtonSpecs ifNil: [super optionalButtonSpecs]! !

!FileList2 methodsFor: 'initialization' stamp: 'RAA 6/16/2000 13:01'!
optionalButtonSpecs: anArray

	optionalButtonSpecs _ anArray! !

!FileList2 methodsFor: 'initialization' stamp: 'mir 11/15/2001 18:16'!
publishingServers

	| dir nameToShow dirList |

	dirList _ OrderedCollection new.
	ServerDirectory serverNames do: [ :n | 
		dir _ ServerDirectory serverNamed: n.
		(dir isProjectSwiki and: [dir acceptsUploads])
			 ifTrue: [
				nameToShow _ n.
				dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self)
					balloonText: dir realUrl)]].
	^dirList! !

!FileList2 methodsFor: 'initialization' stamp: 'sw 2/22/2002 02:34'!
universalButtonServices
	"Answer the services to be reflected in the receiver's buttons"

	^ self optionalButtonSpecs! !

!FileList2 methodsFor: 'initialization' stamp: 'nk 6/14/2004 09:39'!
updateDirectory
	"directory has been changed externally, by calling directory:.
	Now change the view to reflect the change."
	self changed: #currentDirectorySelected.
	self postOpen.! !


!FileList2 methodsFor: 'initialize-release' stamp: 'ar 10/10/2000 15:57'!
initialize

	showDirsInFileList _ false.
	fileSelectionBlock _ [ :entry :myPattern |
		entry isDirectory ifTrue: [
			showDirsInFileList
		] ifFalse: [
			myPattern = '*' or: [myPattern match: entry name]
		]
	] fixTemps.
	dirSelectionBlock _ [ :dirName | true].! !


!FileList2 methodsFor: 'own services' stamp: 'nk 6/14/2004 09:43'!
addNewDirectory
	super addNewDirectory.
	self updateDirectory.! !

!FileList2 methodsFor: 'own services' stamp: 'nk 6/14/2004 09:42'!
deleteDirectory
	super deleteDirectory.
	self updateDirectory.! !

!FileList2 methodsFor: 'own services' stamp: 'sd 5/11/2003 22:15'!
importImage
	"Import the given image file and store the resulting Form in the default Imports"

	| fname image |
	fname _ fileName sansPeriodSuffix.
	image _ Form fromFileNamed: self fullName.
	Imports default importImage: image named: fname.
! !

!FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 02:35'!
okayAndCancelServices
	"Answer ok and cancel services"

	^ {self serviceOkay. self serviceCancel}! !

!FileList2 methodsFor: 'own services' stamp: 'nk 1/6/2004 12:36'!
openImageInWindow
	"Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and BMP.
	Fail if file format is not recognized."

	| image myStream |

	myStream _ (directory readOnlyFileNamed: fileName) binary.
	image _ Form fromBinaryStream: myStream.
	myStream close.

	Smalltalk isMorphic
		ifTrue: [(World drawingClass withForm: image) openInWorld]
		ifFalse: [FormView open: image named: fileName]! !

!FileList2 methodsFor: 'own services' stamp: 'hg 8/3/2000 16:55'!
openProjectFromFile
	"Reconstitute a Morph from the selected file, presumed to be represent
	a Morph saved via the SmartRefStream mechanism, and open it in an
	appropriate Morphic world."

	Project canWeLoadAProjectNow ifFalse: [^ self].
	ProjectViewMorph 
		openFromDirectory: directory 
		andFileName: fileName
! !

!FileList2 methodsFor: 'own services' stamp: 'yo 7/31/2004 18:08'!
removeLinefeeds
	"Remove any line feeds by converting to CRs instead.  This is a temporary implementation for 3.6 only... should be removed during 3.7alpha."
	| fileContents |
	fileContents _ ((FileStream readOnlyFileNamed: self fullName) wantsLineEndConversion: true) contentsOfEntireFile.
	(FileStream newFileNamed: self fullName) 
		nextPutAll: fileContents;
		close.! !

!FileList2 methodsFor: 'own services' stamp: 'nk 6/8/2004 17:09'!
serviceCancel
	"Answer a service for hitting the cancel button"

	^ (SimpleServiceEntry new
		provider: self label: 'cancel' selector: #cancelHit 
		description: 'hit here to cancel ')
		buttonLabel: 'cancel'! !

!FileList2 methodsFor: 'own services' stamp: 'nk 6/8/2004 17:09'!
serviceOkay
	"Answer a service for hitting the okay button"

	^ (SimpleServiceEntry new
		provider: self label: 'okay' selector: #okHit 
		description: 'hit here to accept the current selection')
		buttonLabel: 'ok'! !

!FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 02:07'!
serviceOpenProjectFromFile
	"Answer a service for opening a .pr project file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'load as project'
		selector: #openProjectFromFile
		description: 'open project from file'
		buttonLabel: 'load'! !

!FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 02:36'!
servicesForFolderSelector
	"Answer the ok and cancel servies for the folder selector"

	^ self okayAndCancelServices! !

!FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 02:36'!
servicesForProjectLoader
	"Answer the services to show in the button pane for the project loader"

	^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize. self serviceOpenProjectFromFile}! !


!FileList2 methodsFor: 'user interface' stamp: 'dgd 4/3/2006 13:59'!
blueButtonForService: aService textColor: textColor inWindow: window 
	| block result |
	block := [self fullName isNil
				ifTrue: [self inform: 'Please select a file' translated]
				ifFalse: [aService performServiceFor: self]] copy fixTemps.
	result := window
				fancyText: aService buttonLabel capitalized translated
				font: Preferences standardEToysFont
				color: textColor.
	result setProperty: #buttonText toValue: aService buttonLabel capitalized;
		 hResizing: #rigid;
		 extent: 100 @ 20;
		 layoutInset: 4;
		 borderWidth: ColorTheme current dialogButtonBorderWidth;
		 useRoundedCorners;
		 setBalloonText: aService label.
	result
		on: #mouseUp
		send: #value
		to: block.
	^ result! !

!FileList2 methodsFor: 'user interface' stamp: 'RAA 2/17/2001 12:18'!
morphicDirectoryTreePane

	^self morphicDirectoryTreePaneFiltered: #initialDirectoryList
! !

!FileList2 methodsFor: 'user interface' stamp: 'rww 12/13/2003 13:07'!
morphicDirectoryTreePaneFiltered: aSymbol
	^(SimpleHierarchicalListMorph 
		on: self
		list: aSymbol
		selected: #currentDirectorySelected
		changeSelected: #setSelectedDirectoryTo:
		menu: #volumeMenu:
		keystroke: nil)
			autoDeselect: false;
			enableDrag: false;
			enableDrop: true;
			yourself
		
! !

!FileList2 methodsFor: 'user interface' stamp: 'RAA 6/16/2000 10:53'!
morphicFileContentsPane

	^PluggableTextMorph 
		on: self 
		text: #contents 
		accept: #put:
		readSelection: #contentsSelection 
		menu: #fileContentsMenu:shifted:
! !

!FileList2 methodsFor: 'user interface' stamp: 'nk 6/15/2003 13:05'!
morphicFileListPane

	^(PluggableListMorph 
		on: self 
		list: #fileList 
		selected: #fileListIndex
		changeSelected: #fileListIndex: 
		menu: #fileListMenu:)
			enableDrag: true;
			enableDrop: false;
			yourself

! !

!FileList2 methodsFor: 'user interface' stamp: 'BG 2/28/2004 22:58'!
morphicPatternPane
   | pane |
    pane := PluggableTextMorph 
		on: self 
		text: #pattern 
		accept: #pattern:.
    pane acceptOnCR: true.
   ^pane
		
! !


!FileList2 methodsFor: 'volume list and pattern' stamp: 'nk 6/14/2004 09:45'!
changeDirectoryTo: aFileDirectory
	"Change directory as requested."

	self directory: aFileDirectory.
	self updateDirectory! !

!FileList2 methodsFor: 'volume list and pattern' stamp: 'RAA 8/17/2000 13:59'!
directory

	^directory! !

!FileList2 methodsFor: 'volume list and pattern' stamp: 'mir 8/24/2001 12:03'!
listForPattern: pat
	"Make the list be those file names which match the pattern."

	| sizePad newList entries |
	directory ifNil: [^#()].
	entries _ (Preferences eToyLoginEnabled
		and: [Utilities authorNamePerSe notNil])
		ifTrue: [directory matchingEntries: {'submittedBy: ' , Utilities authorName.} ]
		ifFalse: [directory entries].
	(fileSelectionBlock isKindOf: MessageSend) ifTrue: [
		fileSelectionBlock arguments: {entries}.
		newList _ fileSelectionBlock value.
		fileSelectionBlock arguments: #().
	] ifFalse: [
		newList _ entries select: [:entry | fileSelectionBlock value: entry value: pat].
	].
	newList _ newList asSortedCollection: self sortBlock.
	sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
					asStringWithCommas size - 1.
	newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].
	^ newList asArray! !

!FileList2 methodsFor: 'volume list and pattern' stamp: 'nk 2/20/2001 12:09'!
listForPatterns: anArray
	"Make the list be those file names which match the patterns."

	| sizePad newList |
	directory ifNil: [^#()].
	(fileSelectionBlock isKindOf: MessageSend) ifTrue: [
		fileSelectionBlock arguments: {directory entries}.
		newList _ fileSelectionBlock value.
		fileSelectionBlock arguments: #().
	] ifFalse: [
		newList _ Set new.
		anArray do: [ :pat |
			newList addAll: (directory entries select: [:entry | fileSelectionBlock value: entry value: pat]) ].
	].
	newList _ newList asSortedCollection: self sortBlock.
	sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
					asStringWithCommas size - 1.
	newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].
	^ newList asArray! !


!FileList2 methodsFor: 'private' stamp: 'RAA 4/6/2001 12:45'!
cancelHit

	modalView delete.
	directory _ fileName _ currentDirectorySelected _ nil.! !

!FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 06:50'!
currentDirectorySelected
	^ currentDirectorySelected
! !

!FileList2 methodsFor: 'private' stamp: 'ar 2/12/2001 16:20'!
directoryNamesFor: item
	"item may be file directory or server directory"
	| entries |
	entries _ item directoryNames.
	dirSelectionBlock ifNotNil:[entries _ entries select: dirSelectionBlock].
	^entries! !

!FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 06:51'!
getSelectedDirectory
	ok == true ifFalse: [^ nil].
	^ currentDirectorySelected
! !

!FileList2 methodsFor: 'private' stamp: 'sw 9/12/2002 00:43'!
getSelectedFile
	"Answer a filestream on the selected file.  If it cannot be opened for read/write, try read-only before giving up; answer nil if unsuccessful"

	ok == true ifFalse: [^ nil].
	directory ifNil: [^ nil].
	fileName ifNil: [^ nil].
	^ (directory oldFileNamed: fileName) ifNil:
		[directory readOnlyFileNamed: fileName]! !

!FileList2 methodsFor: 'private' stamp: 'RAA 6/21/2000 12:06'!
modalView: aSystemWindowOrSuch

	modalView _ aSystemWindowOrSuch! !

!FileList2 methodsFor: 'private' stamp: 'md 10/22/2003 15:27'!
okHit
	ok _ true.
	currentDirectorySelected
		ifNil: [Beeper beep]
		ifNotNil: [modalView delete]! !

!FileList2 methodsFor: 'private' stamp: 'TN 4/13/2005 18:32'!
okHitForProjectLoader

	| areaOfProgress |
	fileName ifNil: [^ self].
	ok _ true.
	areaOfProgress _ modalView firstSubmorph.
	[
		areaOfProgress setProperty: #deleteOnProgressCompletion toValue: modalView.
		self openProjectFromFile.
		modalView delete.	"probably won't get here"
	]
		on: ProgressTargetRequestNotification
		do: [ :ex | ex resume: areaOfProgress].


! !

!FileList2 methodsFor: 'private' stamp: 'RAA 6/16/2000 10:48'!
postOpen

	directory ifNotNil: [
		self changed: #(openPath) , directory pathParts. 
	].
! !

!FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 07:12'!
saveLocalOnlyHit
	ok _ true.
	modalView delete.
	directory _ fileName _ nil.
	currentDirectorySelected _ #localOnly.! !

!FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 09:03'!
setSelectedDirectoryTo: aFileDirectoryWrapper
	currentDirectorySelected _ aFileDirectoryWrapper.
	self directory: aFileDirectoryWrapper withoutListWrapper.
	brevityState := #FileList.
	"self addPath: path."
	self changed: #fileList.
	self changed: #contents.
	self changed: #currentDirectorySelected.! !

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

FileList2 class
	instanceVariableNames: ''!

!FileList2 class methodsFor: 'as yet unclassified' stamp: 'ar 10/10/2000 15:59'!
hideSqueakletDirectoryBlock
	^[:dirName| (dirName sameAs: 'Squeaklets') not]! !

!FileList2 class methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:40'!
projectOnlySelectionBlock

	^[ :entry :myPattern |
		entry isDirectory ifTrue: [
			false
		] ifFalse: [
			#('*.pr' '*.pr.gz' '*.project') anySatisfy: [ :each | each match: entry name]
		]
	] fixTemps! !

!FileList2 class methodsFor: 'as yet unclassified' stamp: 'RAA 2/19/2001 06:57'!
projectOnlySelectionMethod: incomingEntries

	| versionsAccepted basicInfoTuple basicName basicVersion |

	"this shows only the latest version of each project"
	versionsAccepted _ Dictionary new.
	incomingEntries do: [ :entry |
		entry isDirectory ifFalse: [
			(#('*.pr' '*.pr.gz' '*.project') anySatisfy: [ :each | each match: entry name]) ifTrue: [
				basicInfoTuple _ Project parseProjectFileName: entry name.
				basicName _ basicInfoTuple first.
				basicVersion _ basicInfoTuple second.
				((versionsAccepted includesKey: basicName) and: 
						[(versionsAccepted at: basicName) first > basicVersion]) ifFalse: [
					versionsAccepted at: basicName put: {basicVersion. entry}
				].
			]
		]
	].
	^versionsAccepted asArray collect: [ :each | each second]! !

!FileList2 class methodsFor: 'as yet unclassified' stamp: 'RAA 7/24/2000 19:13'!
selectionBlockForSuffixes: anArray

	^[ :entry :myPattern |
		entry isDirectory ifTrue: [
			false
		] ifFalse: [
			anArray anySatisfy: [ :each | each match: entry name]
		]
	] fixTemps! !


!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 11/3/2004 20:09'!
blueButtonText: aString textColor: textColor color: aColor inWindow: window 
	| result |
	result := window
				fancyText: aString translated
				font: Preferences standardEToysFont
				color: textColor.
	result setProperty: #buttonText toValue: aString;
		 hResizing: #rigid;
		 extent: 100 @ 20;
		 layoutInset: 4;
		 borderWidth: ColorTheme current dialogButtonBorderWidth;
		 useRoundedCorners.
	aColor isNil
		ifFalse: [""result color: aColor. result borderColor: aColor muchDarker].
	^ result! !

!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 11/3/2004 20:13'!
blueButtonText: aString textColor: textColor color: aColor inWindow: window balloonText: balloonText selector: sel recipient: recip 
	| result |
	result := window
				fancyText: aString translated
font: Preferences standardEToysFont
				color: textColor.
	result setProperty: #buttonText toValue: aString;
		 hResizing: #rigid;
		 extent: 100 @ 20;
		 layoutInset: 4;
		 borderWidth: ColorTheme current dialogButtonBorderWidth;
		 useRoundedCorners;
		 setBalloonText: balloonText.
	result
		on: #mouseUp
		send: sel
		to: recip.
	aColor isNil
		ifFalse: [""
			result color: aColor.
			result borderColor: aColor muchDarker].
	^ result! !

!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 11/2/2004 21:43'!
blueButtonText: aString textColor: textColor inWindow: window 
	^ self
		blueButtonText: aString
		textColor: textColor
		color: nil
		inWindow: window! !

!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 11/3/2004 20:04'!
blueButtonText: aString textColor: textColor inWindow: window balloonText: balloonText selector: sel recipient: recip 
	^ self
		blueButtonText: aString
		textColor: textColor
		color: nil
		inWindow: window
		balloonText: balloonText
		selector: sel
		recipient: recip ! !

!FileList2 class methodsFor: 'blue ui' stamp: 'nk 7/16/2003 17:13'!
enableTypeButtons: typeButtons info: fileTypeInfo forDir: aDirectory

	| foundSuffixes fileSuffixes firstEnabled enableIt |

	firstEnabled _ nil.
	foundSuffixes _ (aDirectory ifNil: [ #()] ifNotNil: [ aDirectory fileNames]) collect: [ :each | (each findTokens: '.') last asLowercase].
	foundSuffixes _ foundSuffixes asSet.
	fileTypeInfo with: typeButtons do: [ :info :button |
		fileSuffixes _ info second.
		enableIt _ fileSuffixes anySatisfy: [ :patt | foundSuffixes includes: patt].
		button 
			setProperty: #enabled 
			toValue: enableIt.
		enableIt ifTrue: [firstEnabled ifNil: [firstEnabled _ button]].
	].
	firstEnabled ifNotNil: [^firstEnabled mouseUp: nil].
	typeButtons do: [ :each | each color: Color gray].

! !

!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 4/3/2006 14:02'!
endingSpecs
	"Answer a collection of specs to build the selective 'find anything' tool called by the Navigator. This version uses the services registry to do so."
	"FileList2 morphicViewGeneralLoaderInWorld: World"
	| categories services specs rejects |
	rejects _ #(addFileToNewZip: compressFile: openInZipViewer: extractAllFrom: openOn:).
	categories _ #(
		('Art' ('bmp' 'gif' 'jpg' 'jpeg' 'form' 'png' 'pcx' 'xbm' 'xpm' 'ppm' 'pbm'))
		('Morphs' ('morph' 'morphs' 'sp'))
		('Projects' ('extseg' 'project' 'pr'))
		('MIDI' ('mid' 'midi'))
		('Music' ('mp3'))
		('Movies' ('movie' 'mpg' 'mpeg' 'qt' 'mov'))
		('Flash' ('swf'))
	).

		"('Books' ('bo'))"
		"('Code' ('st' 'cs'))"
		"('TrueType' ('ttf'))"
		"('3ds' ('3ds'))"
		"('Tape' ('tape'))"
		"('Wonderland' ('wrl'))"
		"('HTML' ('htm' 'html'))"

	categories first at: 2 put: ImageReadWriter allTypicalFileExtensions.
	specs _ OrderedCollection new.
	categories do: [ :cat | | catSpecs catServices okExtensions |
		services _ Dictionary new.
		catSpecs _ Array new: 3.
		catServices _ OrderedCollection new.
		okExtensions _ Set new.

		cat second do: [ :ext | (FileList itemsForFile: 'fred.',ext) do: [ :i |
			(rejects includes: i selector) ifFalse: [
				okExtensions add: ext.
				services at: i label put: i ]]].
		services do: [ :svc | catServices add: svc ].
		services isEmpty ifFalse: [ 
			catSpecs at: 1 put: cat first;
				at: 2 put: okExtensions;
				at: 3 put: catServices.
			specs add: catSpecs ]
	].
	^specs
! !

!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 4/3/2006 14:00'!
morphicViewGeneralLoaderInWorld: aWorld
"
FileList2 morphicViewGeneralLoaderInWorld: self currentWorld
"
	| window aFileList buttons treePane textColor1 fileListPane pane2a pane2b fileTypeInfo fileTypeButtons fileTypeRow actionRow |

	fileTypeInfo _ self endingSpecs.
	window _ AlignmentMorphBob1 newColumn.
	window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	aFileList _ self new directory: FileDirectory default.
	aFileList 
		fileSelectionBlock: self projectOnlySelectionBlock;
		modalView: window.
	window
		setProperty: #FileList toValue: aFileList;
		wrapCentering: #center; cellPositioning: #topCenter;
		borderWidth: ColorTheme current dialogBorderWidth;
		borderColor: ColorTheme current dialogBorderColor;
		useRoundedCorners.

	fileTypeButtons _ fileTypeInfo collect: [ :each |
		(self blueButtonText: each first textColor: Color gray inWindow: window)
			setProperty: #enabled toValue: true;
			hResizing: #shrinkWrap;
			useSquareCorners
	].
	buttons _ {{'OK'. ColorTheme current okColor}. {'Cancel'. ColorTheme current cancelColor}} collect: [ :each |
		self blueButtonText: each first textColor: textColor1 color: each second inWindow: window
	].

	treePane _ aFileList morphicDirectoryTreePane 
		extent: 250@300; 
		retractable: false;
		borderWidth: 0.
	fileListPane _ aFileList morphicFileListPane 
		extent: 350@300; 
		retractable: false;
		borderWidth: 0.
	window addARow: {window fancyText: 'Find...' translated font: Preferences standardEToysTitleFont color: textColor1}.
	fileTypeRow _ window addARowCentered: fileTypeButtons cellInset: 2.
	actionRow _ window addARowCentered: {
		buttons first. 
		(Morph new extent: 30@5) color: Color transparent. 
		buttons second
	} cellInset: 2.
	window
		addARow: {
				(window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) 
					useRoundedCorners;
					layoutInset: 0;
					borderWidth: ColorTheme current dialogPaneBorderWidth;
					borderColor: ColorTheme current dialogPaneBorderColor
				}) layoutInset: 10.
				(window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) 
					useRoundedCorners;
					layoutInset: 0;
					borderWidth: ColorTheme current dialogPaneBorderWidth;
					borderColor: ColorTheme current dialogPaneBorderColor
				}) layoutInset: 10.
		}.
	window fullBounds.
	window fillWithRamp: ColorTheme current dialogRampOrColor oriented: 0.65.
	pane2a fillWithRamp: ColorTheme current dialogPaneRampOrColor oriented: (0.7 @ 0.35).
	pane2b fillWithRamp: ColorTheme current dialogPaneRampOrColor oriented: (0.7 @ 0.35).
"
	buttons do: [ :each |
		each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0).
	].
"
	fileTypeButtons do: [ :each | 
		each 
			on: #mouseUp 
			send: #value:value: 
			to: [ :evt :morph | 
				self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph.
			] fixTemps
	].
	buttons first on: #mouseUp send: #okHit to: aFileList.
	buttons second on: #mouseUp send: #cancelHit to: aFileList.
	aFileList postOpen.
	window position: aWorld topLeft + (aWorld extent - window extent // 2).
	aFileList directoryChangeBlock: [ :newDir |
		self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: nil.
		self enableTypeButtons: fileTypeButtons info: fileTypeInfo forDir: newDir.
	] fixTemps.
	aFileList directory: aFileList directory.
	window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
	window becomeModal.
	^ window openInWorld: aWorld.! !

!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 7/15/2000 19:21'!
morphicViewProjectLoader2InWorld: aWorld

	^self morphicViewProjectLoader2InWorld: aWorld reallyLoad: true! !

!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 2/19/2001 10:14'!
morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean

	^self 
		morphicViewProjectLoader2InWorld: aWorld 
		reallyLoad: aBoolean
		dirFilterType: #initialDirectoryList
! !

!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 4/3/2006 14:03'!
morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean dirFilterType: aSymbol

	| window aFileList buttons treePane textColor1 fileListPane pane2a pane2b treeExtent filesExtent |

	window _ AlignmentMorphBob1 newColumn.
	window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	aFileList _ self new directory: FileDirectory default.
	aFileList 
		optionalButtonSpecs: aFileList servicesForProjectLoader;
		fileSelectionBlock: (
			aSymbol == #limitedSuperSwikiDirectoryList ifTrue: [
				MessageSend receiver: self selector: #projectOnlySelectionMethod:
			] ifFalse: [
				self projectOnlySelectionBlock
			]
		);
		"dirSelectionBlock: self hideSqueakletDirectoryBlock;"
		modalView: window.
	window
		setProperty: #FileList toValue: aFileList;
		wrapCentering: #center; cellPositioning: #topCenter;
		borderWidth: ColorTheme current dialogBorderWidth;
		borderColor: ColorTheme current dialogBorderColor;
		useRoundedCorners.
	buttons _ {{'OK'. ColorTheme current okColor}. {'Cancel'. ColorTheme current cancelColor}} collect: [ :each |
		self blueButtonText: each first textColor: textColor1 color: each second inWindow: window
	].

	aWorld width < 800 ifTrue: [
		treeExtent _ 150@300.
		filesExtent _ 350@300.
	] ifFalse: [
		treeExtent _ 250@300.
		filesExtent _ 350@300.
	].
	(treePane _ aFileList morphicDirectoryTreePaneFiltered: aSymbol)
		extent: treeExtent; 
		retractable: false;
		borderWidth: 0.
	fileListPane _ aFileList morphicFileListPane 
		extent: filesExtent; 
		retractable: false;
		borderWidth: 0.
	window
		addARow: {
			window fancyText: 'Load A Project' translated font: Preferences standardEToysTitleFont color: textColor1
		};
		addARowCentered: {
			buttons first. 
			(Morph new extent: 30@5) color: Color transparent. 
			buttons second
		};
		addARow: {
			window fancyText: 'Please select a project' translated  font: Preferences standardEToysFont color: textColor1
		};
		addARow: {
				(window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) 
					useRoundedCorners;
					layoutInset: 0;
					borderWidth: ColorTheme current dialogPaneBorderWidth;
					borderColor: ColorTheme current dialogPaneBorderColor
				}) layoutInset: 10.
				(window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) 
					useRoundedCorners;
					layoutInset: 0;
					borderWidth: ColorTheme current dialogPaneBorderWidth;
					borderColor: ColorTheme current dialogPaneBorderColor
				}) layoutInset: 10.
		}.
	window fullBounds.
	window fillWithRamp: ColorTheme current dialogRampOrColor oriented: 0.65.
	pane2a fillWithRamp: ColorTheme current dialogPaneRampOrColor oriented: (0.7 @ 0.35).
	pane2b fillWithRamp: ColorTheme current dialogPaneRampOrColor oriented: (0.7 @ 0.35).
"
	buttons do: [ :each |
		each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0).
	].
"
	buttons first 
		on: #mouseUp 
		send: (aBoolean ifTrue: [#okHitForProjectLoader] ifFalse: [#okHit])
		to: aFileList.
	buttons second on: #mouseUp send: #cancelHit to: aFileList.
	aFileList postOpen.
	window position: aWorld topLeft + (aWorld extent - window extent // 2).
	window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
	window becomeModal.
	^ window openInWorld: aWorld.! !

!FileList2 class methodsFor: 'blue ui' stamp: 'dgd 11/3/2004 19:56'!
morphicViewProjectSaverFor: aProject
"
(FileList2 morphicViewProjectSaverFor: Project current) openInWorld
"
	| window aFileList buttons treePane pane2 textColor1 option treeExtent buttonData buttonRow |

	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	aFileList _ self new directory: ServerDirectory projectDefaultDirectory.
	aFileList dirSelectionBlock: self hideSqueakletDirectoryBlock.
	window _ AlignmentMorphBob1 newColumn.
	window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	aFileList modalView: window.
	window
		setProperty: #FileList toValue: aFileList;
		wrapCentering: #center; cellPositioning: #topCenter;
		borderWidth: ColorTheme current dialogBorderWidth;
		borderColor: ColorTheme current dialogBorderColor;
		useRoundedCorners.

	buttonData := Preferences enableLocalSave
				ifTrue: [{
							{'Save'. #okHit. 'Save in the place specified below, and in the Squeaklets folder on your local disk'. ColorTheme current okColor}.
							{'Save on local disk only'. #saveLocalOnlyHit. 'saves in the Squeaklets folder'. ColorTheme current okColor}.
							{'Cancel'. #cancelHit. 'return without saving'. ColorTheme current cancelColor}
						}]
				ifFalse: [{
							{'Save'. #okHit. 'Save in the place specified below, and in the Squeaklets folder on your local disk'. ColorTheme current okColor}.
							{'Cancel'. #cancelHit. 'return without saving'. ColorTheme current cancelColor}
						}].
	buttons _ buttonData collect: [ :each |
		(self blueButtonText: each first textColor: textColor1 color: each fourth inWindow: window)
			setBalloonText: each third translated;
			hResizing: #shrinkWrap;
			on: #mouseUp send: each second to: aFileList
	].

	option _ aProject world 
		valueOfProperty: #SuperSwikiPublishOptions 
		ifAbsent: [#initialDirectoryList].
	aProject world removeProperty: #SuperSwikiPublishOptions.

	treeExtent _ World height < 500
						ifTrue: [ 350@150 ]
						ifFalse: [ 350@300 ].

	(treePane _ aFileList morphicDirectoryTreePaneFiltered: option) 
		extent: treeExtent; 
		retractable: false;
		borderWidth: 0.
	window
		addARowCentered: {
			window fancyText: 'Publish This Project' translated font: Preferences standardEToysTitleFont color: textColor1
		}.
	buttonRow _ OrderedCollection new.
	buttons do: [:button | buttonRow add: button] separatedBy: [buttonRow add: ((Morph new extent: 30@5) color: Color transparent)].

"	addARowCentered: {
			buttons first. 
			(Morph new extent: 30@5) color: Color transparent. 
			buttons second.
			(Morph new extent: 30@5) color: Color transparent. 
			buttons third
		};"
	window
		addARowCentered: buttonRow;
		addARowCentered: { (window inAColumn: {(ProjectViewMorph on: aProject) lock}) layoutInset: 4};
		addARowCentered: {
			window fancyText: 'Please select a folder' translated font: Preferences standardEToysFont color: textColor1
		};
		addARow: {
			(
				window inAColumn: {
					(pane2 _ window inARow: {window inAColumn: {treePane}}) 
						useRoundedCorners;
						layoutInset: 0;
						borderWidth: ColorTheme current dialogPaneBorderWidth;
						borderColor: ColorTheme current dialogPaneBorderColor
				}
			) layoutInset: 10
		}.
	window fullBounds.
	window fillWithRamp: ColorTheme current dialogRampOrColor oriented: 0.65.
	pane2 fillWithRamp: ColorTheme current dialogPaneRampOrColor oriented: (0.7 @ 0.35).
"
	buttons do: [ :each |
		each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0).
	].
"
	window setProperty: #morphicLayerNumber toValue: 11.
	aFileList postOpen.
	window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
	^ window ! !


!FileList2 class methodsFor: 'instance creation' stamp: 'nk 7/12/2000 11:03'!
openMorphicViewInWorld
	"FileList2 openMorphicViewInWorld"
	^self morphicView openInWorld! !

!FileList2 class methodsFor: 'instance creation' stamp: 'nk 6/14/2004 08:41'!
prototypicalToolWindow
	"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"

	^ self morphicView applyModelExtent! !


!FileList2 class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:35'!
modalFileSelector

	| window |

	window _ self morphicViewFileSelector.
	window openCenteredInWorld.
	self modalLoopOn: window.
	^(window valueOfProperty: #fileListModel) getSelectedFile! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:34'!
modalFileSelectorForSuffixes: aList

	| window aFileList |

	window _ self morphicViewFileSelectorForSuffixes: aList.
	aFileList _ window valueOfProperty: #fileListModel.
	window openCenteredInWorld.
	self modalLoopOn: window.
	^aFileList getSelectedFile! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:34'!
modalFileSelectorForSuffixes: aList directory: aDirectory

	| window aFileList |

	window _ self morphicViewFileSelectorForSuffixes: aList directory: aDirectory.
	aFileList _ window valueOfProperty: #fileListModel.
	window openCenteredInWorld.
	self modalLoopOn: window.
	^aFileList getSelectedFile! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'gh 9/16/2002 10:33'!
modalFolderSelector

	^self modalFolderSelector: FileDirectory default! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:34'!
modalFolderSelectorForProjectLoad

	| window fileModel w |

	window _ self morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: false.
	fileModel _ window valueOfProperty: #FileList.
	w _ self currentWorld.
	window position: w topLeft + (w extent - window extent // 2).
	window openInWorld: w.
	self modalLoopOn: window.
	^fileModel getSelectedDirectory withoutListWrapper! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:34'!
modalFolderSelectorForProject: aProject
"
FileList2 modalFolderSelectorForProject: Project current
"
	| window fileModel w |

	window _ FileList2 morphicViewProjectSaverFor: aProject.
	fileModel _ window valueOfProperty: #FileList.
	w _ self currentWorld.
	window position: w topLeft + (w extent - window extent // 2).
	w addMorphInLayer: window.
	w startSteppingSubmorphsOf: window.
	self modalLoopOn: window.
	^fileModel getSelectedDirectory withoutListWrapper! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:33'!
modalFolderSelector: aDir

	| window fileModel |
	window _ self morphicViewFolderSelector: aDir.
	fileModel _ window model.
	window openInWorld: self currentWorld extent: 300@400.
	self modalLoopOn: window.
	^fileModel getSelectedDirectory withoutListWrapper! !


!FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 3/6/2001 12:47'!
morphicViewFileSelector

	^self morphicViewFileSelectorForSuffixes: nil
! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'miki 8/14/2005 21:21'!
morphicViewFileSelectorForSuffixes: aList
	"Answer a morphic file-selector tool for the given suffix list."

	^self 
		morphicViewFileSelectorForSuffixes: aList 
		directory: FileDirectory default.! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'miki 8/14/2005 21:21'!
morphicViewFileSelectorForSuffixes: aList directory: dir
	"Answer a morphic file-selector tool for the given suffix list and the given directory."

	| aFileList window fixedSize midLine gap |
	aFileList _ self new directory: dir.
	aFileList optionalButtonSpecs: aFileList okayAndCancelServices.
	aList ifNotNil:
		[aFileList fileSelectionBlock: [:entry :myPattern |
			entry isDirectory
				ifTrue:
					[false]
				ifFalse:
					[aList includes: (FileDirectory extensionFor: entry name asLowercase)]] fixTemps].
	window _ BorderedMorph new
		layoutPolicy: ProportionalLayout new;
		color: Color lightBlue;
		borderColor: Color blue;
		borderWidth: 4;
		layoutInset: 4;
		extent: 600@400;
		useRoundedCorners.
	window setProperty: #fileListModel toValue: aFileList.
	aFileList modalView: window.
	midLine _ 0.4.
	fixedSize _ 25.
	gap _ 5.
	self addFullPanesTo: window from: {
		{self textRow: 'Please select a file'. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}.
		{aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@fixedSize corner: 0@(fixedSize * 2)}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 
					gap @(fixedSize * 2) corner: gap negated@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 
					gap@(fixedSize * 2) corner: gap negated@0}.
	}.

	aFileList postOpen.

	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'gh 9/16/2002 10:30'!
morphicViewFolderSelector

	^self morphicViewFolderSelector: FileDirectory default! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'bkv 11/12/2002 16:55'!
morphicViewFolderSelector: aDir
	"Answer a tool that allows the user to select a folder"

	| aFileList window fixedSize |
	aFileList _ self new directory: aDir.
	aFileList optionalButtonSpecs: aFileList servicesForFolderSelector.
	window _ (SystemWindow labelled: aDir pathName) model: aFileList.
	aFileList modalView: window.

	fixedSize _ 25.
	self addFullPanesTo: window from: {
		{self textRow: 'Please select a folder'. 0 @ 0 corner: 1 @ 0. 
				0@0 corner: 0@fixedSize}.
		{aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 
				0@fixedSize corner: 0@(fixedSize * 2)}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: 1@1.
				0@(fixedSize * 2) corner: 0@0}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'BG 2/29/2004 23:26'!
morphicViewImageViewer

	| dir aFileList window midLine fixedSize |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	aFileList optionalButtonSpecs: aFileList specsForImageViewer.
	aFileList fileSelectionBlock: [ :entry :myPattern |
		entry isDirectory ifTrue: [
			false
		] ifFalse: [
			#('bmp' 'gif' 'jpg' 'form' 'png') includes: 
					 (FileDirectory extensionFor: entry name asLowercase)
		]
	] fixTemps.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	fixedSize _ 25.
	midLine _ 0.4.
	self addFullPanesTo: window from: {
		{aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0.
				0@0 corner: 0@fixedSize}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1.
				0@fixedSize corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@1.
				0@fixedSize corner: 0@0}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 1/8/2001 21:39'!
morphicViewNoFile

	| dir aFileList window midLine fixedSize |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	fixedSize _ 25.
	midLine _ 0.4.
	self addFullPanesTo: window from: {
		{aFileList morphicPatternPane. 0@0 corner: 0.3@0. 0@0 corner: 0@fixedSize}.
		{aFileList optionalButtonRow. 0.3 @ 0 corner: 1@0. 0@0 corner: 0@fixedSize}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'sw 2/22/2002 02:02'!
morphicViewProjectLoader

	| dir aFileList window midLine fixedSize |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	aFileList optionalButtonSpecs: aFileList servicesForProjectLoader.
	aFileList fileSelectionBlock: self projectOnlySelectionBlock.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	fixedSize _ 25.
	midLine _ 0.4.
	self addFullPanesTo: window from: {
		{aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'dgd 4/3/2006 14:04'!
update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph

	| fileTypeInfo info2 buttons textColor1 fileSuffixes fileActions aFileList fileTypeString |

	(morph notNil and:[(morph valueOfProperty: #enabled) not]) ifTrue: [^self].
	fileTypeRow submorphsDo: [ :sub |
		sub color: (
			sub == morph 
				ifTrue: [Color white] 
				ifFalse: [(sub valueOfProperty: #enabled) 
							ifTrue: [Color transparent] ifFalse: [Color gray]]
		).
	].
	fileTypeString _ morph isNil ifTrue:['xxxx'] ifFalse:[morph valueOfProperty: #buttonText].

	aFileList _ window valueOfProperty: #FileList.
	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	actionRow removeAllMorphs.
	fileTypeInfo _ self endingSpecs.
	info2 _ fileTypeInfo detect: [ :each | each first = fileTypeString] ifNone: [ nil ].
	info2 isNil
		ifTrue:[
			buttons := OrderedCollection new
		]
		ifFalse:[
			fileSuffixes _ info2 second.
			fileActions _ info2 third.
			buttons _ fileActions collect: [ :each | aFileList blueButtonForService: each textColor: textColor1 inWindow: window ].
			buttons do: [ :each |
				each fillWithRamp: ColorTheme current okColor oriented: (0.75 @ 0).
			].
		].
	buttons addLast: (self
								blueButtonText: 'Cancel'
								textColor: textColor1
								color: ColorTheme current cancelColor
								inWindow: window
								balloonText: 'Cancel this search' selector: #cancelHit recipient: aFileList).
	buttons do: [ :each | actionRow addMorphBack: each].
	window fullBounds.
	fileSuffixes isNil ifFalse:[
		aFileList fileSelectionBlock: (
			self selectionBlockForSuffixes: (fileSuffixes collect: [ :each | '*.',each])
		).
	].
	aFileList updateFileList.! !


!FileList2 class methodsFor: 'utility' stamp: 'RAA 1/8/2001 21:23'!
addFullPanesTo: window from: aCollection

	| frame |

	aCollection do: [ :each |
		frame _ LayoutFrame 
			fractions: each second 
			offsets: each third.
		window addMorph: each first fullFrame: frame.
	]! !

!FileList2 class methodsFor: 'utility' stamp: 'miki 8/15/2005 18:34'!
modalLoopOn: aMorph
	[aMorph world notNil] whileTrue: [
		aMorph outermostWorldMorph doOneCycle.
	].! !

!FileList2 class methodsFor: 'utility' stamp: 'RAA 3/6/2001 12:39'!
textRow: aString 

	^AlignmentMorph newRow 
		wrapCentering: #center; cellPositioning: #leftCenter;
		color: Color transparent;
		layoutInset: 0;
		addMorph: (
			AlignmentMorph newColumn
			wrapCentering: #center; cellPositioning: #topCenter;
			color: Color transparent;
			vResizing: #shrinkWrap;
			layoutInset: 0;
			addMorph: (
				AlignmentMorph newRow
				wrapCentering: #center; cellPositioning: #leftCenter;
				color: Color transparent;
				hResizing: #shrinkWrap;
				vResizing: #shrinkWrap;
				layoutInset: 0;
				addMorph: ((StringMorph contents: aString) color: Color blue; lock)
			)
		)! !


!FileList2 class methodsFor: '*smloader-extension' stamp: 'gk 5/5/2006 02:05'!
morphicViewOnDirectory: aFileDirectory
	| aFileList window fileListBottom midLine fileListTopOffset buttonPane |

	aFileList := self new directory: aFileDirectory.
	window := (SystemWindow labelled: aFileDirectory pathName) model: aFileList.

	fileListTopOffset := (TextStyle defaultFont pointSize * 2) + 14.
	fileListBottom := 0.4.
	midLine := 0.4.
	buttonPane := aFileList optionalButtonRow addMorph:
		(aFileList morphicPatternPane vResizing: #spaceFill; yourself).
	self addFullPanesTo: window from: {
		{buttonPane. 0@0 corner: 1@0. 0@0 corner: 0@fileListTopOffset}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@fileListBottom. 
					0@fileListTopOffset corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@fileListBottom. 
					0@fileListTopOffset corner: 0@0}.
		{aFileList morphicFileContentsPane. 0@fileListBottom corner: 1@1. nil}.
	}.
	aFileList postOpen.
	^ window ! !


!FileList2 class methodsFor: '*smloader-override' stamp: 'btr 1/30/2004 00:56'!
morphicView
	^ self morphicViewOnDirectory: FileDirectory default! !
TestCase subclass: #FileList2ModalDialogsTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList-Tests'!
!FileList2ModalDialogsTest commentStamp: '<historical>' prior: 0!
TestRunner open!


!FileList2ModalDialogsTest methodsFor: 'running' stamp: 'sd 11/20/2005 21:27'!
testModalFileSelector
	| window fileList2 |
	window := FileList2 morphicViewFileSelector.
	window openCenteredInWorld.
	fileList2 := window valueOfProperty: #fileListModel.
	fileList2 fileListIndex: 1.
	window delete.
	self assert: fileList2 getSelectedFile isNil.
	fileList2 okHit.
	self deny: fileList2 getSelectedFile isNil


! !

!FileList2ModalDialogsTest methodsFor: 'running' stamp: 'sd 11/20/2005 21:27'!
testModalFileSelectorForSuffixes
	| window fileList2 |
	window := FileList2 morphicViewFileSelectorForSuffixes: nil.
	window openCenteredInWorld.
	fileList2 := window valueOfProperty: #fileListModel.
	fileList2 fileListIndex: 1.
	window delete.
	self assert: fileList2 getSelectedFile isNil.
	fileList2 okHit.
	self deny: fileList2 getSelectedFile isNil
! !

!FileList2ModalDialogsTest methodsFor: 'running' stamp: 'sd 11/20/2005 21:27'!
testModalFolderSelector
	| window fileList2 |
	window := FileList2 morphicViewFolderSelector.
	fileList2 := window model.
	window openInWorld: self currentWorld extent: 300@400.
	fileList2 fileListIndex: 1.
	window delete.
	self assert: fileList2 getSelectedDirectory withoutListWrapper isNil.
	fileList2 okHit.
	self deny: fileList2 getSelectedDirectory withoutListWrapper isNil

! !

!FileList2ModalDialogsTest methodsFor: 'running' stamp: 'sd 11/20/2005 21:27'!
testModalFolderSelectorForProjectLoad
	| window fileList2 w |
	window := FileList2
		morphicViewProjectLoader2InWorld: self currentWorld
		reallyLoad: false.
	fileList2 := window valueOfProperty: #FileList.
	w := self currentWorld.
	window position: w topLeft + (w extent - window extent // 2).
	window openInWorld: w.
	window delete.
	self assert: fileList2 getSelectedDirectory withoutListWrapper isNil.
	fileList2 okHit.
	self deny: fileList2 getSelectedDirectory withoutListWrapper isNil
! !
ClassTestCase subclass: #FileListTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList-Tests'!

!FileListTest methodsFor: 'initialize' stamp: 'SD 11/10/2001 21:48'!
setUp

	DummyToolWorkingWithFileList initialize.! !

!FileListTest methodsFor: 'initialize' stamp: 'SD 11/10/2001 21:49'!
tearDown

	DummyToolWorkingWithFileList unregister.! !


!FileListTest methodsFor: 'test' stamp: 'stephaneducasse 10/9/2005 20:52'!
testAllRegisteredServices
	"(self selector: #testAllRegisteredServices) debug"

	self shouldnt: [FileList allRegisteredServices] raise: Error! !

!FileListTest methodsFor: 'test' stamp: 'SD 11/10/2001 21:53'!
testMenuReturned
	"(self selector: #testToolRegistered) debug"

	self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! !

!FileListTest methodsFor: 'test' stamp: 'stephaneducasse 10/9/2005 20:50'!
testService
	"a stupid test to check that the class returns a service"
	"(self selector: #testService) debug"
	
	| service |
	service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'abab.kkk' suffix: 'kkk') first.
	self assert: (self checkIsServiceIsFromDummyTool: service).
	service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'zkk.gz' suffix: 'gz').
	self assert: service isEmpty! !

!FileListTest methodsFor: 'test' stamp: 'nk 11/30/2002 14:55'!
testServicesForFileEnding
	"(self selector: #testServicesForFileEnding) debug"

	self assert: (((FileList new directory: FileDirectory default; yourself) itemsForFile: 'aaa.kkk') anySatisfy: [ :ea | self checkIsServiceIsFromDummyTool: ea ]).
! !

!FileListTest methodsFor: 'test' stamp: 'SD 11/10/2001 21:52'!
testToolRegistered
	"(self selector: #testToolRegistered) debug"

	self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! !

!FileListTest methodsFor: 'test' stamp: 'SD 11/11/2001 13:54'!
testToolRegisteredUsingInterface
	"(self selector: #testToolRegisteredUsingInterface) debug"

	self assert: (FileList isReaderNamedRegistered: #DummyToolWorkingWithFileList)! !


!FileListTest methodsFor: 'private' stamp: 'sd 2/1/2002 23:04'!
checkIsServiceIsFromDummyTool: service
	
	^ (service instVarNamed: #provider) = DummyToolWorkingWithFileList
	 	& service label = 'menu label'
		& (service instVarNamed: #selector) = #loadAFileForTheDummyTool:! !
SimpleServiceEntry subclass: #FileModifyingSimpleServiceEntry
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FileRegistry'!
!FileModifyingSimpleServiceEntry commentStamp: 'nk 11/26/2002 12:03' prior: 0!
I represent a service that may change the contents of a directory.
Such changes include:
* file creation
* file deletion
* file modification!


!FileModifyingSimpleServiceEntry methodsFor: 'as yet unclassified' stamp: 'nk 11/26/2002 12:08'!
performServiceFor: anObject
	| retval |
	retval _ super performServiceFor: anObject.
	self changed: #fileListChanged.
	^retval	"is this used anywhere?"! !
Object subclass: #FilePackage
	instanceVariableNames: 'fullName sourceSystem classes doIts classOrder'
	classVariableNames: 'LogFileStream'
	poolDictionaries: ''
	category: 'System-FilePackage'!

!FilePackage methodsFor: 'accessing'!
classAt: className
	^self classes at: className! !

!FilePackage methodsFor: 'accessing'!
classes
	^classes! !

!FilePackage methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:31'!
fixClassOrder
	"Essentially bubble sort the classOrder so that superclasses appear before subclasses"
	| superClass index subClass superIndex |
	index := 0.
	[index < classOrder size] whileTrue:[
		subClass := classOrder at: (index := index + 1).
		superClass := nil.
		subClass isMeta ifTrue:[
			"Treat non-meta as superclass"
			superClass := self classes at: subClass name ifAbsent:[nil].
		] ifFalse:[
			subClass hasDefinition ifTrue:[
				superClass := self classes 
					at: (Scanner new scanTokens: subClass definition) first ifAbsent:[nil].
				superClass ifNotNil:[superClass hasDefinition ifFalse:[superClass := nil]].
			].
		].
		superClass ifNotNil:[
			superIndex := classOrder indexOf: superClass ifAbsent:[self error:'Where is the class?'].
			superIndex > index ifTrue:[
				"Move superClass before index"
				classOrder remove: superClass.
				classOrder add: superClass before: subClass.
				"Rewind index - we need to check superClass itself"
				index := index - 1.
			].
		].
	].
! !

!FilePackage methodsFor: 'accessing' stamp: 'pnm
8/23/2000 17:10'!
fullName: aString
	fullName := aString! !

!FilePackage methodsFor: 'accessing'!
fullPackageName
	^fullName! !

!FilePackage methodsFor: 'accessing'!
packageInfo
	^String streamContents:[:s|
		s nextPutAll:'Package: '.
		s nextPutAll: self fullPackageName; cr; cr.
		sourceSystem isEmpty ifFalse:[
			s nextPutAll: sourceSystem; cr; cr].
		doIts isEmpty ifFalse:[
			s nextPutAll:'Unresolvable doIts:'; cr; cr.
			doIts do:[:chgRec|
				s nextPut:$!!; nextPutAll: chgRec string; nextPut: $!!; cr]]].! !

!FilePackage methodsFor: 'accessing' stamp: 'pnm
8/23/2000 17:12'!
packageName
	^FileDirectory localNameFor: self fullPackageName! !

!FilePackage methodsFor: 'accessing'!
removeClass: aPseudoClass
	(self classes removeKey: aPseudoClass name).
	classOrder copy do:[:cls|
		cls name = aPseudoClass name ifTrue:[ classOrder remove: cls].
	].! !

!FilePackage methodsFor: 'accessing' stamp: 'ar 2/5/2004 15:11'!
removeDoIts
	doIts := OrderedCollection new.! !

!FilePackage methodsFor: 'accessing'!
renameClass: aPseudoClass to: newName
	| oldName |
	oldName := aPseudoClass name.
	self classes removeKey: oldName.
	self classes at: newName put: aPseudoClass.
	aPseudoClass renameTo: newName.! !


!FilePackage methodsFor: 'change record types'!
classComment: chgRec

	(self getClass: chgRec methodClassName) classComment: chgRec! !

!FilePackage methodsFor: 'change record types'!
doIt: chgRec
	| string |
	string := chgRec string.
	('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*'
		match: string) ifTrue:[^self classDefinition: string with: chgRec].
	('* class*instanceVariableNames:*'
		match: string) ifTrue:[^self metaClassDefinition: string with: chgRec].
	('* removeSelector: *'
		match: string) ifTrue:[^self removedMethod: string with: chgRec].
	('* comment:*'
		match: string) ifTrue:[^self msgClassComment: string with: chgRec].
	('* initialize'
		match: string) ifTrue:[^self]. "Initialization is done based on class>>initialize"
	('''From *'
		match: string) ifTrue:[^self possibleSystemSource: chgRec].
	doIts add: chgRec.! !

!FilePackage methodsFor: 'change record types'!
method: chgRec
	(self getClass: chgRec methodClassName) methodChange: chgRec! !

!FilePackage methodsFor: 'change record types'!
preamble: chgRec
	self doIt: chgRec! !


!FilePackage methodsFor: 'conflict checker' stamp: 'dew 2/14/2004 00:12'!
checkForMoreRecentUpdateThanChangeSet: updateNumberChangeSet pseudoClass: pseudoClass selector: selector
	"Returns the source code for a conflict if a conflict is found, otherwise returns nil."

	| classOrMeta allChangeSets moreRecentChangeSets conflictingChangeSets changeRecordSource classAndMethodPrintString |

	classAndMethodPrintString _ pseudoClass name, (pseudoClass hasMetaclass ifTrue: [' class'] ifFalse: ['']), '>>', selector asString.

	changeRecordSource _ pseudoClass sourceCode at: selector.
	changeRecordSource isText
		ifTrue: [changeRecordSource _ Text
					fromString: 'method: ', classAndMethodPrintString, ' was removed']
		ifFalse: [changeRecordSource stamp isEmptyOrNil ifTrue:
					[self notify: 'Warning: ', classAndMethodPrintString, ' in ', self packageName, ' has no timestamp/initials!!']].

	pseudoClass exists ifFalse:
		[(self classes at: pseudoClass name) hasDefinition
			ifTrue: [^ nil  "a method was added for a newly defined class; not a conflict"]
			ifFalse: [self class logCr; log: 'CONFLICT found for ', classAndMethodPrintString, '... class ', pseudoClass name asString, ' does not exist in the image and is not defined in the file'.
					^ changeRecordSource]].

	classOrMeta _ pseudoClass realClass.

	"Only printout the replacing methods here, but we still check for removed methods too in the rest of this method."
	(self class verboseConflicts and: [classOrMeta includesSelector: selector])
		ifTrue: [self class logCr; log: '...checking ', classOrMeta asString, '>>', selector asString].

	allChangeSets _ ChangeSorter allChangeSets.
	moreRecentChangeSets _ allChangeSets
				copyFrom: (allChangeSets indexOf: updateNumberChangeSet)
				to: (allChangeSets size).
	conflictingChangeSets _ (moreRecentChangeSets select:
		[:cs | (cs atSelector: selector class: classOrMeta) ~~ #none]).
	conflictingChangeSets isEmpty ifTrue: [^ nil].

	self class logCr; log: 'CONFLICT found for ', classAndMethodPrintString,
				(' with newer changeset' asPluralBasedOn: conflictingChangeSets).
	conflictingChangeSets do: [:cs | self class log: ' ', cs name].
	^ changeRecordSource
! !

!FilePackage methodsFor: 'conflict checker' stamp: 'dew 3/30/2004 23:16'!
conflictsWithUpdatedMethods
	"Check this package for conflicts with methods in the image which are in newer updates."

	| localFileName stream updateNumberString updateNumber imageUpdateNumber updateNumberChangeSet conflicts fileStream |

	localFileName _ FileDirectory localNameFor: fullName.
	stream _ ReadStream on: sourceSystem.
	stream upToAll: 'latest update: #'.
	updateNumberString _ stream upTo: $].
	stream close.
	
	fileStream := FileStream readOnlyFileNamed: fullName.
	(fileStream contentsOfEntireFile includes: Character linefeed)
		ifTrue: [self notifyWithLabel:  'The changeset file ', localFileName, ' contains linefeeds.  Proceed if...
you know that this is okay (e.g. the file contains raw binary data).'].
	fileStream close.

	updateNumberString isEmpty ifFalse:		"remove prepended junk, if any"
		[updateNumberString _ (updateNumberString findTokens: Character space) last].
	updateNumberString asInteger ifNil:
		[(self confirm: 'Error: ', localFileName, ' has no valid Latest Update number in its header.
Do you want to enter an update number for this file?')
			ifFalse: [^ self]
			ifTrue: [updateNumberString _ FillInTheBlank
						request: 'Please enter the estimated update number (e.g. 4332).']].
	updateNumberString asInteger ifNil: [self inform: 'Conflict check cancelled.'. ^ self].
	updateNumber _ updateNumberString asInteger.

	imageUpdateNumber _ SystemVersion current highestUpdate.
	updateNumber > imageUpdateNumber ifTrue:
		[(self confirm: 'Warning: The update number for this file (#', updateNumberString, ')
is greater than the highest update number for this image (#', imageUpdateNumber asString, ').
This probably means you need to update your image.
Should we proceed anyway as if the file update number is #', imageUpdateNumber asString, '?')
			ifTrue:
				[updateNumber _ imageUpdateNumber.
				updateNumberString _ imageUpdateNumber asString]
			ifFalse: [^ self]].

	updateNumberChangeSet _ self findUpdateChangeSetMatching: updateNumber.
	updateNumberChangeSet ifNil: [^ self].

	Smalltalk isMorphic ifTrue: [self currentWorld findATranscript: self currentEvent].
	self class logCr; logCr; log: 'Checking ', localFileName, ' (#', updateNumberString, ') for method conflicts with changesets after ', updateNumberChangeSet name, ' ...'.

	conflicts _ OrderedCollection new.
	self classes values do: [:pseudoClass |
		(Array with: pseudoClass with: pseudoClass metaClass) do: [:classOrMeta |
			classOrMeta selectors do: [:selector | | conflict |
				conflict _ self
							checkForMoreRecentUpdateThanChangeSet: updateNumberChangeSet
							pseudoClass: classOrMeta
							selector: selector.
				conflict ifNotNil: [conflicts add: conflict].
			].
		].
	].
	self class logCr; log: conflicts size asString, (' conflict' asPluralBasedOn: conflicts), ' found.'; logCr.
	self class closeLog.
	^ conflicts! !

!FilePackage methodsFor: 'conflict checker' stamp: 'dew 10/19/2003 21:29'!
findUpdateChangeSetMatching: updateNumber
	"Find update-changeset beginning with updateNumber, or reasonably close."
	"This is to account for the fact that many changeset files are output from final releases, but may be tested for conflicts in a following alpha image, which will often not include that particular update-changeset from the final release but will contain ones near it.  For example, if the file updateNumber is 5180 (from 3.5 final), but the image has no update-changeset beginning with 5180 because it's a 3.6alpha image (which starts at 5181), it will try up to 5190 and down to 5170 for a close match."
	| updateNumberChangeSet updateNumberToTry |

	updateNumberToTry _ updateNumber.
	updateNumberChangeSet _ nil.
	[updateNumberChangeSet isNil and: [updateNumberToTry notNil]] whileTrue:
		[updateNumberChangeSet _ ChangeSorter allChangeSets
			detect: [:cs | (cs name beginsWith: updateNumberToTry asString)
							and: [(cs name at: (updateNumberToTry asString size + 1)) isDigit not]]
			ifNone: [nil].
		updateNumberToTry >= updateNumber ifTrue:
			[updateNumberToTry < (updateNumber + 10)
				ifTrue: [updateNumberToTry _ updateNumberToTry + 1]
				ifFalse: [updateNumberToTry _ updateNumber]].
		updateNumberToTry <= updateNumber ifTrue:
			[updateNumberToTry > (updateNumber - 10)
				ifTrue: [updateNumberToTry _ updateNumberToTry - 1]
				ifFalse: [updateNumberToTry _ nil  "we're done trying"]].
		].

	updateNumberChangeSet ifNil:
		[(self confirm: 'Warning: No changeset beginning with ',
updateNumber asString, ' (within +/- 10) was found in the image.
You must have changesets going back this far in your image
in order to accurately check for conflicts.
Proceed anyway?')
			ifTrue: [updateNumberChangeSet _ ChangeSorter allChangeSets first]].

	^ updateNumberChangeSet! !


!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 15:57'!
askForDoits
	| menu choice choices |
	choices := #('do not process' 'at the beginning' 'at the end' 'cancel').
	menu _ SelectionMenu selections: choices.
	choice := nil.
	[choices includes: choice] whileFalse: [
		choice _ menu startUpWithCaption: 
'The package contains unprocessed doIts.
When would like to process those?'].
	^choices indexOf: choice! !

!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 16:00'!
fileIn
	| doitsMark |
	doitsMark := 1.
	doIts isEmpty ifFalse:[doitsMark := self askForDoits].
	doitsMark = 4 ifTrue: [^nil].
	doitsMark = 2 ifTrue:[self fileInDoits].
	classOrder do:[:cls|
		cls fileInDefinition.
	].
	classes do:[:cls|
		Transcript cr; show:'Filing in ', cls name.
		cls fileInMethods.
		cls hasMetaclass ifTrue:[cls metaClass fileInMethods].
	].
	doitsMark = 3 ifTrue:[self fileInDoits].! !

!FilePackage methodsFor: 'fileIn/fileOut'!
fileInDoits
	doIts do:[:chgRec| chgRec fileIn].! !

!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'ar 7/17/2005 03:36'!
fileOut
	| fileName stream |
	fileName := UIManager default request: 'Enter the file name' initialAnswer:''.
	stream := FileStream newFileNamed: fileName.
	sourceSystem isEmpty ifFalse:[
		stream nextChunkPut: sourceSystem printString;cr ].
	self fileOutOn: stream.
	stream cr; cr.
	self classes do:[:cls|
		cls needsInitialize ifTrue:[
			stream cr; nextChunkPut: cls name,' initialize']].
	stream cr.
	stream close.

	"DeepCopier new checkVariables."
! !

!FilePackage methodsFor: 'fileIn/fileOut'!
fileOutDoits: aStream
	doIts do:[:chgRec| chgRec fileOutOn: aStream].! !

!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 15:59'!
fileOutOn: aStream
	| doitsMark |
	doitsMark := 1.
	doIts isEmpty ifFalse:[doitsMark := self askForDoits].
	doitsMark = 4 ifTrue: [^nil].
	doitsMark = 2 ifTrue:[self fileOutDoits: aStream].
	classOrder do:[:cls|
		cls fileOutDefinitionOn: aStream.
	].
	classes do:[:cls|
		cls fileOutMethodsOn: aStream.
		cls hasMetaclass ifTrue:[cls metaClass fileOutMethodsOn: aStream].
	].
	doitsMark = 3 ifTrue:[self fileOutDoits: aStream].! !


!FilePackage methodsFor: 'initialize' stamp: 'yo 8/17/2004 09:53'!
fromFileNamed: aName
	| stream |
	fullName := aName.
	stream := FileStream readOnlyFileNamed: aName.
	stream setConverterForCode.
	[self fileInFrom: stream] ensure:[stream close].! !

!FilePackage methodsFor: 'initialize' stamp: 'yo 8/17/2004 09:54'!
fromFileNamed: aName encoding: encodingName
	| stream |
	fullName := aName.
	stream := FileStream readOnlyFileNamed: aName.
	stream converter: (TextConverter newForEncoding: encodingName).
	self fileInFrom: stream.! !

!FilePackage methodsFor: 'initialize' stamp: 'pnm
8/23/2000 14:48'!
initialize
	classes := Dictionary new.
	classOrder := OrderedCollection new.
	sourceSystem := ''.
	doIts := OrderedCollection new.! !


!FilePackage methodsFor: 'reading' stamp: 'ar 7/16/2005 15:05'!
fileInFrom: aStream
	| chgRec changes |
	changes := ChangeSet scanFile: aStream from: 0 to: aStream size.
	aStream close.
	('Processing ', self packageName) 
		displayProgressAt: Sensor cursorPoint
		from: 1
		to: changes size
		during:[:bar|
			1 to: changes size do:[:i|
				bar value: i.
				chgRec := changes at: i.
				self perform: (chgRec type copyWith: $:) asSymbol
with: chgRec.
			].
		].! !


!FilePackage methodsFor: '*monticello' stamp: 'al 12/2/2005 13:58'!
classDefinition: string with: chgRec
	| tokens theClass |
	
	self flag: #traits.
		
	tokens := Scanner new scanTokens: string.

	"tokens size = 11 ifFalse:[^doIts add: chgRec]."

	theClass := self getClass: (tokens at: 3).
	theClass definition: string.
	classOrder add: theClass.! !

!FilePackage methodsFor: '*monticello' stamp: 'avi 1/19/2004 23:47'!
doIts
	^ doIts! !


!FilePackage methodsFor: 'private'!
getClass: className
	| pseudoClass |
	(classes includesKey: className) ifTrue:[
		^classes at: className.
	].
	pseudoClass := PseudoClass new.
	pseudoClass name: className.
	classes at: className put: pseudoClass.
	^pseudoClass.! !

!FilePackage methodsFor: 'private'!
metaClassDefinition: string with: chgRec
	| tokens theClass |
	tokens := Scanner new scanTokens: string.
	theClass := self getClass: (tokens at: 1).
	theClass metaClass definition: string.
	classOrder add: theClass metaClass.! !

!FilePackage methodsFor: 'private' stamp: 'ar 4/10/2005 18:46'!
msgClassComment: string with: chgRec
	| tokens theClass |
	tokens := Scanner new scanTokens: string.
	(tokens size = 3 and:[(tokens at: 3) isString]) ifTrue:[
		theClass := self getClass: tokens first.
		^theClass commentString: tokens last].
	(tokens size = 4 and:[(tokens at: 3) asString = 'class' and:[(tokens at: 4) isString]]) ifTrue:[
		theClass := self getClass: tokens first.
		theClass metaClass commentString: tokens last].
! !

!FilePackage methodsFor: 'private' stamp: 'ar 4/10/2005 18:46'!
possibleSystemSource: chgRec
	| tokens |
	sourceSystem isEmpty ifTrue:[
		tokens := Scanner new scanTokens: chgRec string.
		(tokens size = 1 and:[tokens first isString]) ifTrue:[
			sourceSystem := tokens first.
			^self]].
	doIts add: chgRec.! !

!FilePackage methodsFor: 'private'!
removedMethod: string with: chgRec
	| class tokens |
	tokens := Scanner new scanTokens: string.
	(tokens size = 3 and:[(tokens at: 2) == #removeSelector: ]) ifTrue:[
		class := self getClass: (tokens at: 1).
		^class removeSelector: (tokens at: 3).
	].
	(tokens size = 4 and:[(tokens at: 2) == #class and:[(tokens at: 3) == #removeSelector:]]) ifTrue:[
		class := self getClass: (tokens at: 1).
		^class metaClass removeSelector: (tokens at: 4).
	].
	doIts add: chgRec! !

!FilePackage methodsFor: 'private'!
sampleMethod
"	In an existing method there are always a number of changes.
	Other stuff
		will be deleted
	Or even better,
		some things may be just modified.
"! !

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

FilePackage class
	instanceVariableNames: ''!

!FilePackage class methodsFor: 'conflict checker logging' stamp: 'dew 2/13/2004 23:33'!
closeLog
	self logFileStream close.
	LogFileStream _ nil.! !

!FilePackage class methodsFor: 'conflict checker logging' stamp: 'dew 2/14/2004 23:03'!
logCr
	Transcript cr.
	self logFileStream nextPut: Character cr.
! !

!FilePackage class methodsFor: 'conflict checker logging' stamp: 'stephaneducasse 11/1/2005 15:39'!
logFileStream

	LogFileStream ifNil:
		[LogFileStream _ FileStream fileNamed: 'ConflictChecker.log'.
		LogFileStream setToEnd].
	^ LogFileStream! !

!FilePackage class methodsFor: 'conflict checker logging' stamp: 'dew 2/14/2004 23:03'!
log: aString
	Transcript show: aString.
	self logFileStream nextPutAll: aString.
! !


!FilePackage class methodsFor: 'conflict checker preferences' stamp: 'dew 12/22/2002 00:19'!
showIdenticalConflicts
	"(Not implemented yet.  Need to implement versionFromChangeSet first for this to work for the 'false' case.)"
	"Set this to true if we want to show conflicts with methods which have an identical timestamp to the one being checked.  This type of conflict usually just proves that you've already loaded the changeset (or some part of it) in your image."
	^ true
! !

!FilePackage class methodsFor: 'conflict checker preferences' stamp: 'dew 2/13/2004 23:32'!
verboseConflicts
	"Set this to true if we want to list each replacing (potentially conflicting) method being checked."
	^ true! !


!FilePackage class methodsFor: 'instance creation' stamp: 'dew 10/26/2003 22:08'!
conflictsWithUpdatedMethods: fullName
	| conflicts changeList |
	conflicts := (self fromFileNamed: fullName) conflictsWithUpdatedMethods.
	conflicts isEmpty ifTrue: [^ self].
	changeList := ChangeList new.
	changeList
		changes: conflicts
		file: (FileDirectory default readOnlyFileNamed: fullName) close;
		openAsMorphName: 'Conflicts for ', (FileDirectory localNameFor: fullName)
		multiSelect: true 
! !

!FilePackage class methodsFor: 'instance creation'!
fromFileNamed: aName
	^self new fromFileNamed: aName! !


!FilePackage class methodsFor: 'reader service' stamp: 'dew 12/16/2002 18:29'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'st') | (suffix = 'cs') | (suffix = '*')
		ifTrue: [self services]
		ifFalse: [#()]! !

!FilePackage class methodsFor: 'reader service' stamp: 'dew 12/16/2002 18:29'!
serviceConflictsWithUpdatedMethods
	^ SimpleServiceEntry 
		provider: self 
		label: 'conflicts with updated methods'
		selector: #conflictsWithUpdatedMethods:
		description: 'check for conflicts with more recently updated methods in the image, showing the conflicts in a transcript window'
		buttonLabel: 'conflicts'! !

!FilePackage class methodsFor: 'reader service' stamp: 'dew 12/16/2002 18:28'!
services
	^ Array with: self serviceConflictsWithUpdatedMethods! !
Object subclass: #FilePath
	instanceVariableNames: 'squeakPathName vmPathName converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Directories'!
!FilePath commentStamp: 'yo 10/19/2004 21:36' prior: 0!
This class absorb the difference of internal and external representation of the file path.  The idea is to keep the internal one as much as possible, and only when it goes to a primitive, the encoded file path, i.e. the native platform representation is passsed to the primitive.

	The converter used is obtained by "LanguageEnvironment defaultFileNameConverter".
!


!FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:10'!
asSqueakPathName

	^ self pathName.
! !

!FilePath methodsFor: 'conversion' stamp: 'ar 1/31/2005 11:16'!
asString
	^self asSqueakPathName! !

!FilePath methodsFor: 'conversion' stamp: 'yo 2/24/2005 18:45'!
asVmPathName

	^ vmPathName.
! !

!FilePath methodsFor: 'conversion' stamp: 'stephaneducasse 2/4/2006 20:31'!
coverter: aTextConverter

	converter class ~= aTextConverter class ifTrue: [
		converter := aTextConverter.
		vmPathName := squeakPathName convertToWithConverter: converter
	].
! !

!FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:07'!
pathName

	^ squeakPathName.
! !

!FilePath methodsFor: 'conversion' stamp: 'stephaneducasse 2/4/2006 20:31'!
pathName: p isEncoded: isEncoded

	converter := LanguageEnvironment defaultFileNameConverter.
	isEncoded ifTrue: [
		squeakPathName := p convertFromWithConverter: converter.
		vmPathName := p.
	] ifFalse: [
		squeakPathName := p isOctetString ifTrue: [p asOctetString] ifFalse: [p].
		vmPathName := squeakPathName convertToWithConverter: converter.
	].
! !

!FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:07'!
printOn: aStream

	aStream nextPutAll: 'FilePath('''.
	aStream nextPutAll: squeakPathName.
	aStream nextPutAll: ''')'.
! !


!FilePath methodsFor: 'file in/out' stamp: 'stephaneducasse 2/4/2006 20:31'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	"If we're reading in an old version with a system path instance variable, convert it to a vm path."

	varDict at: 'systemPathName' ifPresent: [ :x | 
		vmPathName := x.
	].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !

!FilePath methodsFor: 'file in/out' stamp: 'stephaneducasse 2/4/2006 20:31'!
copySystemToVm

	(self class instVarNames includes: 'systemPathName') ifTrue: [
		vmPathName := self instVarNamed: 'systemPathName'.
	].

! !


!FilePath methodsFor: 'testing' stamp: 'tpr 11/5/2004 11:39'!
isNullPath
	"an empty path is used to represent the root path(s) when calling the primitive to list directory entries. Some users need to check for this and this is cleaner than grabbing the pathname and assuming it is a plain String"
	^self pathName isEmpty! !

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

FilePath class
	instanceVariableNames: ''!

!FilePath class methodsFor: 'as yet unclassified' stamp: 'yo 2/24/2005 18:38'!
classVersion

	^ 1.
! !


!FilePath class methodsFor: 'instance creation' stamp: 'yo 12/19/2003 16:30'!
pathName: pathName

	^ self pathName: pathName isEncoded: false.
! !

!FilePath class methodsFor: 'instance creation' stamp: 'yo 12/19/2003 16:30'!
pathName: pathName isEncoded: aBoolean

	^ (self new) pathName: pathName isEncoded: aBoolean; yourself.
! !
Object subclass: #FileServices
	instanceVariableNames: ''
	classVariableNames: 'FileReaderRegistry'
	poolDictionaries: ''
	category: 'System-FileRegistry'!

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

FileServices class
	instanceVariableNames: ''!

!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 16:59'!
allRegisteredServices
	"self allRegisteredServices"

	| col |
	col := OrderedCollection new.
	self registeredFileReaderClasses do: [:each | col addAll: (each services)].
	^ col! !

!FileServices class methodsFor: 'accessing' stamp: 'ar 9/29/2005 12:30'!
initialize
	"FileServices initialize"
	Smalltalk allClassesDo:[:aClass|
		(aClass class includesSelector: #fileReaderServicesForFile:suffix:)
			ifTrue:[self registerFileReader: aClass]].! !

!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'!
isReaderNamedRegistered: aSymbol
	"return if a given reader class has been registered. Note that this is on purpose that the argument is
	a symbol and not a class"

	 ^ (self registeredFileReaderClasses collect: [:each | each name]) includes: aSymbol
! !

!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'!
itemsForDirectory: aFileDirectory
	"Answer a list of services appropriate when no file is selected."

	| services |
	services _ OrderedCollection new.
	self registeredFileReaderClasses do: [:reader |
		reader ifNotNil: [services addAll: (reader fileReaderServicesForDirectory: aFileDirectory) ]].
	^ services! !

!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'!
itemsForFile: fullName
	"Answer a list of services appropriate for a file of the given full name"

	| services suffix |
	suffix _ self suffixOf: fullName.
	services _ OrderedCollection new.
	self registeredFileReaderClasses do: [:reader |
		reader ifNotNil: [services addAll: (reader fileReaderServicesForFile: fullName suffix: suffix)]].
	^ services! !

!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 16:59'!
registeredFileReaderClasses
	FileReaderRegistry ifNil: [FileReaderRegistry _ OrderedCollection new].
	^ FileReaderRegistry! !

!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'!
registerFileReader: aProviderClass
	"register the given class as providing services for reading files"

	| registeredReaders |
	registeredReaders := self registeredFileReaderClasses.
	(registeredReaders includes: aProviderClass) 
			ifFalse: [ registeredReaders addLast: aProviderClass ]! !

!FileServices class methodsFor: 'accessing' stamp: 'ar 7/17/2005 02:36'!
removeObsolete
	"FileServices removeObsolete"
	self registeredFileReaderClasses copy 
		do:[:cls| cls isObsolete ifTrue:[self unregisterFileReader: cls]]! !

!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'!
unregisterFileReader: aProviderClass
	"unregister the given class as providing services for reading files"

	self registeredFileReaderClasses remove: aProviderClass ifAbsent: [nil]! !
ReadWriteStream subclass: #FileStream
	instanceVariableNames: 'rwmode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Kernel'!
!FileStream commentStamp: '<historical>' prior: 0!
I represent a Stream that accesses a FilePage from a File. One use for my instance is to access larger "virtual Strings" than can be stored contiguously in main memory. I restrict the objects stored and retrieved to be Integers or Characters. An end of file pointer terminates reading; it can be extended by writing past it, or the file can be explicitly truncated.
	
To use the file system for most applications, you typically create a FileStream. This is done by sending a message to a FileDirectory (file:, oldFile:, newFile:, rename:newName:) which creates an instance of me. Accesses to the file are then done via my instance.

*** On DOS, files cannot be shortened!!  ***  To overwrite a file with a shorter one, first delete the old file (FileDirectory deleteFilePath: 'Hard Disk:aFolder:dataFolder:foo') or (aFileDirectory deleteFileNamed: 'foo').  Then write your new shorter version.!


!FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'!
contents
	"Return the contents of the receiver. Do not close or otherwise touch the receiver. Return data in whatever mode the receiver is in (e.g., binary or text)."
	| s savePos |
	savePos := self position.
	self position: 0.
	s := self next: self size.
	self position: savePos.
	^s! !

!FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'!
contentsOfEntireFile
	"Read all of the contents of the receiver."

	| s binary |
	self readOnly.
	binary := self isBinary.
	self reset.	"erases knowledge of whether it is binary"
	binary ifTrue: [self binary].
	s := self next: self size.
	self close.
	^s! !

!FileStream methodsFor: 'accessing' stamp: 'nk 2/22/2001 17:07'!
directoryEntry
	^self directory entryAt: self localName! !

!FileStream methodsFor: 'accessing' stamp: 'ar 1/25/2001 19:33'!
mimeTypes
	^FileDirectory default mimeTypesFor: self name.! !

!FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'!
next

	(position >= readLimit and: [self atEnd])
		ifTrue: [^nil]
		ifFalse: [^collection at: (position := position + 1)]! !

!FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'!
next: anInteger

	| newCollection howManyRead increment |
	newCollection := collection species new: anInteger.
	howManyRead := 0.
	[howManyRead < anInteger] whileTrue:
		[self atEnd ifTrue:
			[(howManyRead + 1) to: anInteger do: [:i | newCollection at: i put: (self next)].
			^newCollection].
		increment := (readLimit - position) min: (anInteger - howManyRead).
		newCollection replaceFrom: (howManyRead + 1)
			to: (howManyRead := howManyRead + increment)
			with: collection
			startingAt: (position + 1).
		position := position + increment].
	^newCollection! !

!FileStream methodsFor: 'accessing'!
nextPut: aByte
	"1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'accessing'!
nextPutAll: aCollection
	"1/31/96 sw: made subclass responsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'accessing'!
size
	"Answer the size of the file in characters.
	 1/31/96 sw: made subclass responsibility"

	self subclassResponsibility! !


!FileStream methodsFor: 'converting' stamp: 'tk 2/4/2000 09:16'!
asBinaryOrTextStream
	"I can switch between binary and text data"

	^ self! !


!FileStream methodsFor: 'editing' stamp: 'di 5/20/1998 23:20'!
edit
	"Create and schedule an editor on this file."

	FileList openEditorOn: self editString: nil.
! !

!FileStream methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:31'!
viewGZipContents
	"View the contents of a gzipped file"

	| stringContents |
	self binary.
	stringContents := self contentsOfEntireFile.
	Cursor wait showWhile: [stringContents := (GZipReadStream on: stringContents) upToEnd].
	stringContents := stringContents asString withSqueakLineEndings.

	Workspace new
		contents: stringContents;
		openLabel: 'Decompressed contents of: ', self localName! !


!FileStream methodsFor: 'file accessing' stamp: 'gk 2/10/2004 13:21'!
asUrl
	"Convert my path into a file:// type url - a FileUrl."
	
	^FileUrl pathParts: (self directory pathParts copyWith: self localName)! !

!FileStream methodsFor: 'file accessing'!
file
	"Answer the file for the page the receiver is streaming over.
	 1/31/96 sw: made subclass responsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'file accessing' stamp: 'jm 12/5/97 12:53'!
localName

	^ FileDirectory localNameFor: self name
! !

!FileStream methodsFor: 'file accessing'!
name
	"Answer the name of the file for the page the receiver is streaming over.  1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility! !


!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'!
ascii
	"Set this file to ascii (text) mode."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'!
binary
	"Set this file to binary mode."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'!
readOnly
	"Set this file's mode to read-only."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file modes' stamp: 'mir 8/24/2004 17:58'!
readOnlyStream
	^self readOnly! !

!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:00'!
readWrite
	"Set this file's mode to read-write."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'!
text
	"Set this file to text (ascii) mode."

	self ascii.
! !


!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'!
close
	"Close this file."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'!
closed
	"Answer true if this file is closed."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:03'!
flush
	"When writing, flush the current buffer out to disk."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:04'!
reopen
	"Ensure that the receiver is open, re-open it if necessary."
	"Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened."

	self subclassResponsibility
! !


!FileStream methodsFor: 'fileIn/Out' stamp: 'sw 11/19/1998 16:42'!
fileIn
	"Guarantee that the receiver is readOnly before fileIn for efficiency and
	to eliminate remote sharing conflicts."

	self readOnly.
	self fileInAnnouncing: 'Loading ', self localName! !

!FileStream methodsFor: 'fileIn/Out' stamp: 'tk 1/21/2000 16:38'!
fileInObjectAndCode
	"Read the file directly, do not use an RWBinaryOrTextStream."

	self text.
	^ super fileInObjectAndCode
! !

!FileStream methodsFor: 'fileIn/Out' stamp: 'di 10/31/2001 12:07'!
fileIntoNewChangeSet
	"File all of my contents into a new change set." 

	self readOnly.
	ChangeSorter newChangesFromStream: self named: (self localName)
! !


!FileStream methodsFor: 'positioning'!
position
	"Answer the current character position in the file.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
position: pos
	"Set the current character position in the file to pos.
	 1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
reset
	"Set the current character position to the beginning of the file.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
setToEnd
	"Set the current character position to the end of the File. The same as
	self position: self size.  1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
skip: n
	"Set the character position to n characters from the current position.
	Error if not enough characters left in the file
	1/31/96 sw: made subclassResponsibility."
 
	self subclassResponsibility! !

!FileStream methodsFor: 'positioning' stamp: 'JMM 5/24/2001 22:58'!
truncate: pos
	"Truncate file to pos"

	self subclassResponsibility! !


!FileStream methodsFor: 'printing' stamp: 'tk 12/5/2001 09:12'!
longPrintOn: aStream
	"Do nothing, so it will print short.  Called to print the error file.  If the error was in a file operation, we can't read the contents of that file.  Just print its name instead."
! !

!FileStream methodsFor: 'printing' stamp: 'tk 12/5/2001 09:32'!
longPrintOn: aStream limitedTo: sizeLimit indent: indent

	"Do nothing, so it will print short.  Called to print the error file.  If the error was in a file operation, we can't read the contents of that file.  Just print its name instead."

	aStream cr! !

!FileStream methodsFor: 'printing'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' on '.
	self file printOn: aStream! !


!FileStream methodsFor: 'remote file compatibility' stamp: 'RAA 9/24/2000 18:00'!
dataIsValid

	self flag: #bob.		"we needed this if a remote stream, but could be local as well"! !


!FileStream methodsFor: 'testing'!
atEnd
	"Answer true if the current position is >= the end of file position.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !


!FileStream methodsFor: '*MorphicExtras-file accessing' stamp: 'fbs 2/2/2005 13:23'!
url
	"Convert my path into a file:// type url String."
	
	^self asUrl asString! !


!FileStream methodsFor: '*network-uri' stamp: 'mir 3/24/2005 18:44'!
uri
	^self directory uri resolveRelativeURI: self localName! !

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

FileStream class
	instanceVariableNames: ''!

!FileStream class methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
httpPostDocument: url args: argsDict
	| argString |
	argString := argsDict
		ifNotNil: [argString := HTTPSocket argString: argsDict]
		ifNil: [''].
	^self post: argString url: url , argString ifError: [self halt]! !

!FileStream class methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
httpPostMultipart: url args: argsDict
	| mimeBorder argsStream crLf fieldValue resultStream result |
	" do multipart/form-data encoding rather than x-www-urlencoded "

	crLf := String crlf.
	mimeBorder := '----squeak-', Time millisecondClockValue printString, '-stuff-----'.
	"encode the arguments dictionary"
	argsStream := WriteStream on: String new.
	argsDict associationsDo: [:assoc |
		assoc value do: [ :value |
		"print the boundary"
		argsStream nextPutAll: '--', mimeBorder, crLf.
		" check if it's a non-text field "
		argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'.
		(value isKindOf: MIMEDocument)
			ifFalse: [fieldValue := value]
			ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', crLf, 'Content-Type: ', value contentType.
				fieldValue := (value content
					ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile]
					ifNotNil: [value content]) asString].
" Transcript show: 'field=', key, '; value=', fieldValue; cr. "
		argsStream nextPutAll: crLf, crLf, fieldValue, crLf.
	]].
	argsStream nextPutAll: '--', mimeBorder, '--'.

	resultStream := self
		post: 
			('Content-type: multipart/form-data; boundary=', mimeBorder, crLf,
			'Content-length: ', argsStream contents size printString, crLf, crLf, 
			argsStream contents)
		url: url ifError: [^'Error in post ' url asString].
	"get the header of the reply"
	result := resultStream upToEnd.
	^MIMEDocument content: result! !

!FileStream class methodsFor: 'browser requests' stamp: 'mir 2/2/2001 14:23'!
post: data target: target url: url ifError: errorBlock
	^self concreteStream new post: data target: target url: url ifError: errorBlock! !

!FileStream class methodsFor: 'browser requests' stamp: 'mir 2/2/2001 14:23'!
post: data url: url ifError: errorBlock
	^self post: data target: nil url: url ifError: errorBlock! !

!FileStream class methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
requestURL: url target: target
	"FileStream requestURL:'http://isgwww.cs.uni-magdeburg.de/~raab' target: ':=blank' "
	^self concreteStream new requestURL: url target: target! !

!FileStream class methodsFor: 'browser requests'!
requestURLStream: url
	"FileStream requestURLStream:'http://isgwww.cs.uni-magdeburg.de/~raab'"
	^self concreteStream new requestURLStream: url! !

!FileStream class methodsFor: 'browser requests'!
requestURLStream: url ifError: errorBlock
	"FileStream requestURLStream:'http://isgwww.cs.uni-magdeburg.de/~raab'"
	^self concreteStream new requestURLStream: url ifError: errorBlock! !


!FileStream class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !


!FileStream class methodsFor: 'concrete classes' stamp: 'yo 7/5/2004 20:18'!
concreteStream
	"Who should we really direct class queries to?  "
	^ MultiByteFileStream.
! !


!FileStream class methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 19:41'!
requestDropStream: dropIndex
	"Request a read-only stream for some file that was dropped onto Squeak"
	^self concreteStream new requestDropStream: dropIndex.! !


!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'!
cs

	^ 'cs' clone.
! !

!FileStream class methodsFor: 'file reader services' stamp: 'stephaneducasse 2/4/2006 20:32'!
fileIn: fullName
	"File in the entire contents of the file specified by the name provided"

	| ff |
	fullName ifNil: [^ Beeper beep].
	ff := self readOnlyFileNamed: (GZipReadStream uncompressedFileName: fullName).
	ff fileIn.
! !

!FileStream class methodsFor: 'file reader services' stamp: 'nk 7/16/2003 15:49'!
fileReaderServicesForFile: fullName suffix: suffix
	"Answer services for the given file"

	^ ((self isSourceFileSuffix: suffix) or: [ suffix = '*' ])
		ifTrue:
			[{self serviceRemoveLineFeeds.
			self serviceFileIn}]
		ifFalse:
			[#()]! !

!FileStream class methodsFor: 'file reader services' stamp: 'tpr 9/15/2005 15:06'!
isSourceFileSuffix: suffix

	^ FileStream sourceFileSuffixes includes: suffix
! !

!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:00'!
multiCs

	^ 'mcs' clone.
! !

!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'!
multiSt

	^ 'mst' clone.
! !

!FileStream class methodsFor: 'file reader services' stamp: 'stephaneducasse 2/4/2006 20:32'!
removeLineFeeds: fullName
	| fileContents |
	fileContents := ((FileStream readOnlyFileNamed: fullName) wantsLineEndConversion: true) contentsOfEntireFile.
	(FileStream newFileNamed: fullName) 
		nextPutAll: fileContents;
		close.! !

!FileStream class methodsFor: 'file reader services' stamp: 'sw 2/17/2002 01:38'!
serviceFileIn
	"Answer a service for filing in an entire file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'fileIn entire file'
		selector: #fileIn:
		description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format'
		buttonLabel: 'filein'! !

!FileStream class methodsFor: 'file reader services' stamp: 'nk 11/26/2002 12:49'!
serviceRemoveLineFeeds
	"Answer a service for removing linefeeds from a file"

	^ FileModifyingSimpleServiceEntry
		provider: self 
		label: 'remove line feeds'
		selector: #removeLineFeeds:	
		description: 'remove line feeds in file'
		buttonLabel: 'remove lfs'! !

!FileStream class methodsFor: 'file reader services' stamp: 'sd 2/1/2002 22:28'!
services

	^ Array 
			with: self serviceRemoveLineFeeds
			with: self serviceFileIn
	! !

!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/7/2004 09:43'!
sourceFileSuffixes

	^ {FileStream st. FileStream cs. FileStream multiSt. FileStream multiCs} asSet asArray.

! !

!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'!
st

	^ 'st' clone.
! !

!FileStream class methodsFor: 'file reader services' stamp: 'stephaneducasse 2/4/2006 20:32'!
writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag useHtml: useHtml

	| extension converter f fileName |
	aStream contents isAsciiString ifTrue: [
		stOrCsFlag ifTrue: [
			extension := (FileDirectory dot, FileStream st).
		] ifFalse: [
			extension := (FileDirectory dot, FileStream cs).
		].
		converter := MacRomanTextConverter new.
	] ifFalse: [
		stOrCsFlag ifTrue: [
			extension := (FileDirectory dot, FileStream st "multiSt").
		] ifFalse: [
			extension := (FileDirectory dot, FileStream cs "multiCs").
		].
		converter := UTF8TextConverter new.
	].
	fileName := useHtml ifTrue: [baseName, '.html'] ifFalse: [baseName, extension].
	f := FileStream newFileNamed: fileName.
	f ifNil: [^ self error: 'Cannot open file'].
	(converter isMemberOf: UTF8TextConverter)
		ifTrue: [f binary.
			UTF8TextConverter writeBOMOn: f].
	f text.
	f converter: converter.
	f nextPutAll: aStream contents.
	f close.
! !


!FileStream class methodsFor: 'initialize-release' stamp: 'hg 8/3/2000 18:00'!
initialize

	FileList registerFileReader: self! !


!FileStream class methodsFor: 'instance creation' stamp: 'CdG 10/19/2005 23:21'!
detectFile: aBlock do: anotherBlock
	
	| file |

	file := aBlock value.
	^ file 
		ifNil: [ nil ]
         ifNotNil: [ [anotherBlock value: file] ensure: [file close]]! !

!FileStream class methodsFor: 'instance creation'!
fileNamed: fileName 
	^ self concreteStream fileNamed: (self fullName: fileName)! !

!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:28'!
fileNamed: fileName do: aBlock
	"Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})).  It's time Squeak had it, too.''
	
	Returns the result of aBlock."
	
	^ self detectFile: [ self fileNamed: fileName ] do: aBlock! !

!FileStream class methodsFor: 'instance creation' stamp: 'tpr 10/16/2001 12:49'!
forceNewFileNamed: fileName
 	"Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, delete it without asking before creating the new file."

	^self concreteStream forceNewFileNamed: fileName! !

!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:29'!
forceNewFileNamed: fileName do: aBlock
	"Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})).  It's time Squeak had it, too.''
	
	Returns the result of aBlock."
	
	^ self detectFile: [ self forceNewFileNamed: fileName ] do: aBlock! !

!FileStream class methodsFor: 'instance creation'!
fullName: fileName
	^ FileDirectory default fullNameFor: fileName! !

!FileStream class methodsFor: 'instance creation' stamp: 'TPR 8/26/1999 10:49'!
isAFileNamed: fName
	"return whether a file exists with the given name"
	^self concreteStream isAFileNamed: (self fullName: fName)! !

!FileStream class methodsFor: 'instance creation' stamp: 'di 2/15/98 14:03'!
new
	^ self basicNew! !

!FileStream class methodsFor: 'instance creation'!
newFileNamed: fileName 
	^ self concreteStream newFileNamed: (self fullName: fileName)! !

!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:28'!
newFileNamed: fileName do: aBlock
	"Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})).  It's time Squeak had it, too.''
	
	Returns the result of aBlock."
	
	^ self detectFile: [ self newFileNamed: fileName ] do: aBlock! !

!FileStream class methodsFor: 'instance creation'!
oldFileNamed: fileName 
	^ self concreteStream oldFileNamed: (self fullName: fileName)! !

!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:29'!
oldFileNamed: fileName do: aBlock
	"Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})).  It's time Squeak had it, too.''
	
	Returns the result of aBlock."
	
	^ self detectFile: [ self oldFileNamed: fileName ] do: aBlock! !

!FileStream class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
oldFileOrNoneNamed: fileName
	"If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil."

	| fullName |
	fullName := self fullName: fileName.
	(self concreteStream isAFileNamed: fullName)
		ifTrue: [^ self concreteStream readOnlyFileNamed: fullName]
		ifFalse: [^ nil].
! !

!FileStream class methodsFor: 'instance creation'!
readOnlyFileNamed: fileName 
	^ self concreteStream readOnlyFileNamed: (self fullName: fileName)! !

!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:29'!
readOnlyFileNamed: fileName do: aBlock
	"Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})).  It's time Squeak had it, too.''
	
	Returns the result of aBlock."
	
	^ self detectFile: [ self readOnlyFileNamed: fileName ] do: aBlock! !
Error subclass: #FileStreamException
	instanceVariableNames: 'fileName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!FileStreamException methodsFor: 'exceptionBuilder' stamp: 'mir 2/23/2000 20:13'!
fileName: aFileName
	fileName _ aFileName! !


!FileStreamException methodsFor: 'exceptionDescription' stamp: 'mir 2/25/2000 17:29'!
fileName
	^fileName! !

!FileStreamException methodsFor: 'exceptionDescription' stamp: 'mir 2/23/2000 20:13'!
isResumable
	"Determine whether an exception is resumable."

	^true! !

!FileStreamException methodsFor: 'exceptionDescription' stamp: 'mir 2/23/2000 20:14'!
messageText
	
	"Return an exception's message text."

	^messageText == nil
		ifTrue: [fileName printString]
		ifFalse: [messageText]! !

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

FileStreamException class
	instanceVariableNames: ''!

!FileStreamException class methodsFor: 'exceptionInstantiator' stamp: 'mir 2/23/2000 20:12'!
fileName: aFileName
	^self new fileName: aFileName! !
ClassTestCase subclass: #FileStreamTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Tests'!

!FileStreamTest methodsFor: 'as yet unclassified' stamp: 'CdG 10/19/2005 23:20'!
testDetectFileDo
	"Mantis #1838"
	
	[(FileDirectory default forceNewFileNamed: 'filestream.tst')
		nextPutAll: '42';
		close.
		
	FileStream 
		detectFile: [FileDirectory default oldFileNamed: 'filestream.tst']
		do: [:file |
			self assert: file notNil.
			self deny: file closed.
			self assert: file contentsOfEntireFile = '42']]
	
		ensure: [FileDirectory default deleteFileNamed: 'filestream.txt' ifAbsent: nil]! !
Url subclass: #FileUrl
	instanceVariableNames: 'host path isAbsolute'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!FileUrl commentStamp: 'gk 10/21/2005 10:58' prior: 0!
This class models a file URL according to (somewhat) RFC1738, see http://www.w3.org/Addressing/rfc1738.txt

Here is the relevant part of the RFC:

3.10 FILES

   The file URL scheme is used to designate files accessible on a
   particular host computer. This scheme, unlike most other URL schemes,
   does not designate a resource that is universally accessible over the
   Internet.

   A file URL takes the form:

       file://<host>/<path>

   where <host> is the fully qualified domain name of the system on
   which the <path> is accessible, and <path> is a hierarchical
   directory path of the form <directory>/<directory>/.../<name>.

   For example, a VMS file

     DISK$USER:[MY.NOTES]NOTE123456.TXT

   might become

     <URL:file://vms.host.edu/disk$user/my/notes/note12345.txt>

   As a special case, <host> can be the string "localhost" or the empty
   string; this is interpreted as `the machine from which the URL is
   being interpreted'.

   The file URL scheme is unusual in that it does not specify an
   Internet protocol or access method for such files; as such, its
   utility in network protocols between hosts is limited.

From the above we can conclude that the RFC says that the <path> part never starts or ends with a slash and is always absolute. If the last name can be a directory instead of a file is not specified clearly.

The path is stored as a SequenceableCollection of path parts.

Notes regarding non RFC features in this class:

- If the last path part is the empty string, then the FileUrl is referring to a directory. This is also shown with a trailing slash when converted to a String.

- The FileUrl has an attribute isAbsolute which signals if the path should be considered absolute or relative to the current directory. This distinction is not visible in the String representation of FileUrl, since the RFC does not have that.

- Fragment is supported (kept for historical reasons)

!


!FileUrl methodsFor: 'access' stamp: 'gk 10/21/2005 10:21'!
directoryUrl
	"The path always has at least one element so this works."

	^self copy path: (path copyFrom: 1 to: path size - 1)! !

!FileUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:14'!
fileName
	"Return the last part of the path,
	most often a filename but can also be a directory."

	^self path last! !

!FileUrl methodsFor: 'access' stamp: 'ar 10/13/2004 17:54'!
pathForFile
	"Path using local file system's delimiter.  $\ or $:"
	^FileDirectory default pathFromUrl: self! !


!FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 10:16'!
host
	"Return the host name, either 'localhost', '', or a fully qualified domain name."
	
	^host ifNil: ['']! !

!FileUrl methodsFor: 'accessing' stamp: 'gk 2/12/2004 16:22'!
host: hostName
	"Set the host name, either 'localhost', '', or a fully qualified domain name."
	
	host _ hostName! !

!FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:12'!
isAbsolute
	"Should the path be considered absolute to
	the filesystem instead of relative to the default directory?"
 
	^isAbsolute! !

!FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:13'!
isAbsolute: aBoolean
	"Set if the path should be considered absolute to
	the filesystem instead of relative to the default directory."

	isAbsolute _ aBoolean! !

!FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:15'!
path
	"Return an ordered collection of the path elements."
	
	^path! !

!FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:11'!
path: aCollection
	"Set the collection of path elements."

	path _ aCollection! !


!FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'!
scheme
	^self class schemeName! !

!FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'!
schemeName
	^self class schemeName! !


!FileUrl methodsFor: 'copying' stamp: 'gk 10/21/2005 11:15'!
copy
	"Be sure not to share the path with the copy."

	^self clone path: path copy! !


!FileUrl methodsFor: 'downloading' stamp: 'gk 2/10/2004 13:06'!
default
	"Use the default local Squeak file directory."
	
	| local |
	local _ self class pathParts: (FileDirectory default pathParts), #('') isAbsolute: true.
	self privateInitializeFromText: self pathString relativeTo: local.
		"sets absolute also"! !

!FileUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'!
hasContents
	^true! !

!FileUrl methodsFor: 'downloading' stamp: 'ASF 4/30/2005 16:37'!
retrieveContents
	| file pathString s type entries |
	pathString _ self pathForFile.
	file _ [FileStream readOnlyFileNamed: pathString] 
			on: FileDoesNotExistException do:[:ex| ex return: nil].
	file ifNotNil: [
		type _ file mimeTypes.
		type ifNotNil:[type _ type first].
		type ifNil:[type _ MIMEDocument guessTypeFromName: self path last].
		^MIMELocalFileDocument 
			contentType: type
			contentStream: file].

	"see if it's a directory..."
	entries _ [(FileDirectory on: pathString) entries] 
				on: InvalidDirectoryError do:[:ex| ex return: nil].
	entries ifNil:[^nil].

	s _ WriteStream on: String new.
	(pathString endsWith: '/') ifFalse: [ pathString _ pathString, '/' ].
	s nextPutAll: '<title>Directory Listing for ', pathString, '</title>'.
	s nextPutAll: '<h1>Directory Listing for ', pathString, '</h1>'.
	s nextPutAll: '<ul>'.
	s cr.
	entries do: [ :entry |
		s nextPutAll: '<li><a href="'.
		s nextPutAll: entry name.
		s nextPutAll: '">'.
		s nextPutAll: entry name.
		s nextPutAll: '</a>'.
		s cr. ].
	s nextPutAll: '</ul>'.
	^MIMEDocument  contentType: 'text/html'  content: s contents  url: ('file://', pathString)! !


!FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 00:19'!
pathDirString
	"Path to directory as url, using slash as delimiter.
	Filename is left out."

	^String streamContents: [ :s |
		isAbsolute ifTrue: [ s nextPut: $/ ].
		1 to: self path size - 1 do: [ :ii |
			s nextPutAll: (path at: ii); nextPut: $/]]! !

!FileUrl methodsFor: 'paths' stamp: 'gk 10/21/2005 10:01'!
pathForDirectory
	"Path using local file system's pathname delimiter.
	DOS paths with drive letters should not
	be prepended with a delimiter even though
	they are absolute. Filename is left out."

	| delimiter |
	delimiter _  FileDirectory default pathNameDelimiter.
	^String streamContents: [ :s |
		(self isAbsolute and: [self firstPartIsDriveLetter not])
			ifTrue: [ s nextPut: delimiter ].
		1 to: self path size - 1 do: [ :ii |
			s nextPutAll: (path at: ii); nextPut: delimiter]]! !

!FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 10:22'!
pathString
	"Path as it appears in a URL with $/ as delimiter."
	
	| first |
	^String streamContents: [ :s |
		"isAbsolute ifTrue:[ s nextPut: $/ ]."
		first _ true.
		self path do: [ :p |
			first ifFalse: [ s nextPut: $/ ].
			first _ false.
			s nextPutAll: p encodeForHTTP ] ]! !


!FileUrl methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:09'!
printOn: aStream
	"Return the FileUrl according to RFC1738 plus supporting fragments:
		'file://<host>/<path>#<fragment>'
	Note that <host> being '' is equivalent to 'localhost'.
	Note: The pathString can not start with a leading $/
	to indicate an 'absolute' file path.
	This is not according to RFC1738 where the path should have
	no leading or trailing slashes, and always
	be considered absolute relative to the filesystem."

	aStream nextPutAll: self schemeName, '://'.

	host ifNotNil: [aStream nextPutAll: host].

	aStream
		nextPut: $/;
		nextPutAll: self pathString.

	fragment ifNotNil:
		[aStream
			nextPut: $#;
			nextPutAll: fragment encodeForHTTP].! !


!FileUrl methodsFor: 'testing' stamp: 'gk 2/9/2004 20:32'!
firstPartIsDriveLetter
	"Return true if the first part of the path is a letter
	followed by a $: like 'C:' "
	
	| firstPart |
	path isEmpty ifTrue: [^false].
	firstPart _ path first.
	^firstPart size = 2 and: [
		firstPart first isLetter
			and: [firstPart last = $:]]! !


!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:05'!
host: aHostString pathParts: aCollection isAbsolute: aBoolean

	host _ aHostString.
	path _ aCollection.
	isAbsolute _ aBoolean! !

!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:01'!
initializeFromPathString: aPathString
	"<aPathString> is a file path as a String.
	We construct a path collection using various heuristics."

	| pathString hasDriveLetter |
	pathString _ aPathString.
	pathString isEmpty ifTrue: [pathString _ '/'].
	path _ (pathString findTokens: '/') collect: [:token | token unescapePercents].

	"A path like 'C:' refers in practice to 'c:/'"
	((pathString endsWith: '/') or:
		[(hasDriveLetter _ self firstPartIsDriveLetter) and: [path size = 1]])
			ifTrue: [path add: ''].

	"Decide if we are absolute by checking for leading $/ or
	beginning with drive letter. Smarts for other OSes?"
	self isAbsolute: ((pathString beginsWith: '/')
						or: [hasDriveLetter ifNil: [self firstPartIsDriveLetter]])! !

!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:04'!
pathParts: aCollection isAbsolute: aBoolean

	^self host: nil pathParts: aCollection isAbsolute: aBoolean! !

!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:11'!
privateInitializeFromText: aString
	"Calculate host and path from a file URL in String format.
	Some malformed formats are allowed and interpreted by guessing."

	| schemeName pathString bare hasDriveLetter stream char i |
	bare _ aString withBlanksTrimmed.
	schemeName _ Url schemeNameForString: bare.
	(schemeName isNil or: [schemeName ~= self schemeName])
		ifTrue: [
			host _ ''.
			pathString _ bare]
		ifFalse: [
			"First remove schemeName and colon"
			bare _ bare copyFrom: (schemeName size + 2) to: bare size.
			"A proper file URL then has two slashes before host,
			A malformed URL is interpreted as using syntax file:<path>."
			(bare beginsWith: '//')
				ifTrue: [i _ bare indexOf: $/ startingAt: 3.
						i=0 ifTrue: [
								host _ bare copyFrom: 3 to: bare size.
								pathString _ '']
							ifFalse: [
								host _ bare copyFrom: 3 to: i-1.
								pathString _ bare copyFrom: host size + 3 to: bare size]]
				ifFalse: [host _ ''.
						pathString _ bare]].
	self initializeFromPathString: pathString
! !

!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:29'!
privateInitializeFromText: pathString relativeTo: aUrl
	"<pathString> should be a filesystem path.
	This url is adjusted to be aUrl + the path."

	| bare newPath |
	self host: aUrl host.
	self initializeFromPathString: pathString.
	self isAbsolute: aUrl isAbsolute.

	newPath _ aUrl path copy.
	newPath removeLast.	"empty string that says its a directory"
	path do: [ :token |
		((token ~= '..') and: [token ~= '.']) ifTrue: [ 
			newPath addLast: token unescapePercents ].
		token = '..' ifTrue: [ 
			newPath isEmpty ifFalse: [ 
				newPath last = '..' ifFalse: [ newPath removeLast ] ] ].
		"token = '.' do nothing" ].
	path _ newPath

	! !

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

FileUrl class
	instanceVariableNames: ''!

!FileUrl class methodsFor: 'constants' stamp: 'gk 2/10/2004 10:33'!
schemeName
	^'file'! !


!FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 12:16'!
absoluteFromText: aString
	"Method that can be called explicitly to create a FileUrl."

	^self new privateInitializeFromText: aString! !

!FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:04'!
host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean
	"Create a FileUrl."

	^self new host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean! !

!FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:10'!
pathParts: aCollectionOfPathParts
	"Create a FileUrl."

	^self host: nil pathParts: aCollectionOfPathParts isAbsolute: true! !

!FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:06'!
pathParts: aCollectionOfPathParts isAbsolute: aBoolean
	"Create a FileUrl."

	^self host: nil pathParts: aCollectionOfPathParts isAbsolute: aBoolean! !
ClassTestCase subclass: #FileUrlTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NetworkTests-Url'!

!FileUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 12:43'!
testAsString
	| target url |
	target := 'file://localhost/etc/rc.conf'.
	url := target asUrl.
	self assert: url asString = target.
		! !
StringHolder subclass: #FillInTheBlank
	instanceVariableNames: 'acceptOnCR done responseUponCancel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Menus'!
!FillInTheBlank commentStamp: '<historical>' prior: 0!
I represent a prompt for string input from the user. The user is asked to type in and edit a string. The resulting string is supplied as the argument to a client-supplied action block.
!


!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 4/28/1998 06:18'!
acceptOnCR
	"Answer whether a carriage return should cause input to be accepted."

	^ acceptOnCR
! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 4/28/1998 06:18'!
acceptOnCR: aBoolean

	acceptOnCR _ aBoolean.
! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 5/6/1998 15:13'!
done
	"Answer whether the user has ended the interaction."

	^ done
! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 5/6/1998 15:13'!
done: aBoolean

	done _ aBoolean.
! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'sw 1/31/2000 14:45'!
responseUponCancel: resp
	responseUponCancel _ resp! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'sw 1/31/2000 14:47'!
setResponseForCancel
	self contents: responseUponCancel! !


!FillInTheBlank methodsFor: 'initialize-release' stamp: 'sw 1/31/2000 14:42'!
initialize

	super initialize.
	acceptOnCR _ false.
	done _ false.
	responseUponCancel _ ''
! !


!FillInTheBlank methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:59'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	varDict at: 'responseUponCancel' ifAbsent: [responseUponCancel _ ''].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!FillInTheBlank methodsFor: 'private' stamp: 'sma 6/18/2000 10:54'!
show: fillInView
	| savedArea |
	savedArea _ Form fromDisplay: fillInView displayBox.
	fillInView display.
	contents isEmpty
		ifFalse: [fillInView lastSubView controller selectFrom: 1 to: contents size].
	(fillInView lastSubView containsPoint: Sensor cursorPoint)
		ifFalse: [fillInView lastSubView controller centerCursorInView].
	fillInView controller startUp.
	fillInView release.
	savedArea displayOn: Display at: fillInView viewport topLeft.
	^ contents! !

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

FillInTheBlank class
	instanceVariableNames: ''!

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'!
multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight 
	"Create a multi-line instance of me whose question is queryString with
	the given initial answer. Invoke it centered at the given point, and
	answer the string the user accepts.  Answer nil if the user cancels.  An
	empty string returned means that the ussr cleared the editing area and
	then hit 'accept'.  Because multiple lines are invited, we ask that the user
	use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 
	submit; that way, the return key can be typed to move to the next line.
	NOTE: The ENTER key does not work on Windows platforms."

	"FillInTheBlank
		multiLineRequest:
'Enter several lines; end input by accepting
or canceling via menu or press Alt+s/Alt+l'
		centerAt: Display center
		initialAnswer: 'Once upon a time...'
		answerHeight: 200"

	| model fillInView |
	Smalltalk isMorphic 
		ifTrue: 
			[^self fillInTheBlankMorphClass 
				request: queryString
				initialAnswer: defaultAnswer
				centerAt: aPoint
				inWorld: self currentWorld
				onCancelReturn: nil
				acceptOnCR: false].
	model := self new.
	model contents: defaultAnswer.
	model responseUponCancel: nil.
	model acceptOnCR: false.
	fillInView := self fillInTheBlankViewClass 
				multiLineOn: model
				message: queryString
				centerAt: aPoint
				answerHeight: answerHeight.
	^model show: fillInView! !

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:53'!
request: queryString 
	"Create an instance of me whose question is queryString. Invoke it 
	centered at the cursor, and answer the string the user accepts. Answer 
	the empty string if the user cancels."

	"FillInTheBlank request: 'Your name?'"

	^ self
		request: queryString
		initialAnswer: ''
		centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! !

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'!
request: queryString initialAnswer: defaultAnswer 
	"Create an instance of me whose question is queryString with the given 
	initial answer. Invoke it centered at the given point, and answer the 
	string the user accepts. Answer the empty string if the user cancels."

	"FillInTheBlank 
		request: 'What is your favorite color?' 
		initialAnswer: 'red, no blue. Ahhh!!'"

	^ self
		request: queryString
		initialAnswer: defaultAnswer
		centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! !

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint 
	"Create an instance of me whose question is queryString with the given
	initial answer. Invoke it centered at the given point, and answer the
	string the user accepts. Answer the empty string if the user cancels."

	"FillInTheBlank
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	| model fillInView |
	Smalltalk isMorphic 
		ifTrue: 
			[^self fillInTheBlankMorphClass 
				request: queryString
				initialAnswer: defaultAnswer
				centerAt: aPoint].
	model := self new.
	model contents: defaultAnswer.
	fillInView := self fillInTheBlankViewClass 
				on: model
				message: queryString
				centerAt: aPoint.
	^model show: fillInView! !

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'!
requestPassword: queryString 
	"Create an instance of me whose question is queryString. Invoke it centered
	at the cursor, and answer the string the user accepts. Answer the empty 
	string if the user cancels."

	"FillInTheBlank requestPassword: 'POP password'"

	| model fillInView |
	Smalltalk isMorphic 
		ifTrue: [^self fillInTheBlankMorphClass requestPassword: queryString].
	model := self new.
	model contents: ''.
	fillInView := self fillInTheBlankViewClass 
				requestPassword: model
				message: queryString
				centerAt: Sensor cursorPoint
				answerHeight: 40.
	^model show: fillInView! !


!FillInTheBlank class methodsFor: 'private' stamp: 'sma 6/18/2000 10:39'!
fillInTheBlankMorphClass
	"By factoring out this class references, it becomes possible to discard 
	morphic by simply removing this class.  All calls to this method needs
	to be protected by 'Smalltalk isMorphic' tests."

	^ FillInTheBlankMorph! !

!FillInTheBlank class methodsFor: 'private' stamp: 'sma 6/18/2000 10:47'!
fillInTheBlankViewClass
	"By factoring out this class references, it becomes possible to discard 
	MVC by simply removing this class.  All calls to this method needs
	to be protected by 'Smalltalk isMorphic' tests."

	^ FillInTheBlankView! !
StringHolderController subclass: #FillInTheBlankController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!FillInTheBlankController commentStamp: '<historical>' prior: 0!
I am the controller for a FillInTheBlankView. Based on a flag in the view, I can either accept the input string when a carriage return is typed, or I can allow multiple lines of input that is accepted by either typing enter or by invoking the 'accept' command.
!


!FillInTheBlankController methodsFor: 'basic control sequence' stamp: 'th 9/17/2002 16:46'!
controlInitialize

	model acceptOnCR ifFalse: [^ super controlInitialize].
	self setMark: self markBlock stringIndex.
	self setPoint: self pointBlock stringIndex.
	self initializeSelection.
	beginTypeInBlock _ nil.
! !

!FillInTheBlankController methodsFor: 'basic control sequence' stamp: 'jm 5/6/1998 15:11'!
controlTerminate

	| topController |
	super controlTerminate.
	topController _ view topView controller.
	topController ifNotNil: [topController close].
! !


!FillInTheBlankController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 14:45'!
isControlActive
	^ self isControlWanted! !

!FillInTheBlankController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 14:45'!
isControlWanted
	^ model done not! !


!FillInTheBlankController methodsFor: 'other' stamp: 'jm 5/6/1998 15:13'!
accept

	super accept.
	model done: true.
! !

!FillInTheBlankController methodsFor: 'other' stamp: 'sw 1/31/2000 14:47'!
cancel

	model setResponseForCancel.
	super cancel.
	model done: true.
! !

!FillInTheBlankController methodsFor: 'other' stamp: 'jm 4/28/1998 06:25'!
dispatchOnCharacter: char with: typeAheadStream
	"Accept the current input if the user hits the carriage return or the enter key."

	(model acceptOnCR and:
	 [(char = Character cr) | (char = Character enter)])
		ifTrue: [
			sensor keyboard.  "absorb the character"
			self accept.
			^ true]
		ifFalse: [
			^ super dispatchOnCharacter: char with: typeAheadStream].
! !

!FillInTheBlankController methodsFor: 'other' stamp: 'jm 4/28/1998 08:01'!
processYellowButton
	"Suppress yellow-button menu if acceptOnCR is true."

	model acceptOnCR ifFalse: [^ super processYellowButton].
! !
RectangleMorph subclass: #FillInTheBlankMorph
	instanceVariableNames: 'response done textPane responseUponCancel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 14:03'!
response

	^ response
! !

!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 14:22'!
response: aText
	"Sent when text pane accepts."

	response _ aText asString.
	done _ true.
	^ true
! !

!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'di 5/22/1998 00:58'!
selectionInterval
	^ 1 to: response size
! !


!FillInTheBlankMorph methodsFor: 'event handling' stamp: 'ar 10/7/2000 15:47'!
handlesMouseDown: evt
	^true! !

!FillInTheBlankMorph methodsFor: 'event handling' stamp: 'md 10/22/2003 16:20'!
mouseDown: evt
	(self containsPoint: evt position) ifFalse:[^ Beeper beep]. "sent in response to outside modal click"
	evt hand grabMorph: self. "allow repositioning"! !


!FillInTheBlankMorph methodsFor: 'geometry' stamp: 'jrp 7/6/2005 21:42'!
extent: aPoint 
	"change the receiver's extent"

	super extent: aPoint .
	self setDefaultParameters.
	self updateColor! !


!FillInTheBlankMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/7/2000 15:50'!
undoGrabCommand
	^nil! !


!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 13:34'!
createAcceptButton
	"create the [accept] button"
	| result frame |
	result := SimpleButtonMorph new target: self;
				 color: ColorTheme current okColor.
	result
		borderColor: (Preferences menuAppearance3d
				ifTrue: [#raised]
				ifFalse: [result color twiceDarker]).
	result label: 'Accept(s)' translated;
		 actionSelector: #accept.
	result setNameTo: 'accept'.
	frame := LayoutFrame new.
	frame rightFraction: 0.5;
		 rightOffset: -10;
		 bottomFraction: 1.0;
		 bottomOffset: -2.
	result layoutFrame: frame.
	self addMorph: result.
	self
		updateColor: result
		color: result color
		intensity: 2.
	^ result! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 13:34'!
createCancelButton
	"create the [cancel] button"
	| result frame |
	result := SimpleButtonMorph new target: self;
				 color: ColorTheme current cancelColor.
	result
		borderColor: (Preferences menuAppearance3d
				ifTrue: [#raised]
				ifFalse: [result color twiceDarker]).
	result label: 'Cancel(l)' translated;
		 actionSelector: #cancel.
	result setNameTo: 'cancel'.
	frame := LayoutFrame new.
	frame leftFraction: 0.5;
		 leftOffset: 10;
		 bottomFraction: 1.0;
		 bottomOffset: -2.
	result layoutFrame: frame.
	self addMorph: result.
	self
		updateColor: result
		color: result color
		intensity: 2.
	^ result! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'yo 7/2/2004 17:52'!
createQueryTextMorph: queryString 
	"create the queryTextMorph"
	| result frame |
	result := TextMorph new contents: queryString.
	result setNameTo: 'query' translated.
	result lock.
	frame := LayoutFrame new.
	frame topFraction: 0.0;
		 topOffset: 2.
	frame leftFraction: 0.5;
		 leftOffset: (result width // 2) negated.
	result layoutFrame: frame.
	self addMorph: result.
	^ result! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:56'!
createTextPaneExtent: answerExtent acceptBoolean: acceptBoolean topOffset: topOffset buttonAreaHeight: buttonAreaHeight 
	"create the textPane"
	| result frame |
	result := PluggableTextMorph
				on: self
				text: #response
				accept: #response:
				readSelection: #selectionInterval
				menu: #codePaneMenu:shifted:.
	result extent: answerExtent.
	result hResizing: #spaceFill;
		 vResizing: #spaceFill.
	result borderWidth: 1.
	result hasUnacceptedEdits: true.
	result acceptOnCR: acceptBoolean.
	result setNameTo: 'textPane'.
	frame := LayoutFrame new.
	frame leftFraction: 0.0;
		 rightFraction: 1.0;
		 topFraction: 0.0;
		 topOffset: topOffset;
		 bottomFraction: 1.0;
		 bottomOffset: buttonAreaHeight negated.
	result layoutFrame: frame.
	self addMorph: result.
	^ result! !

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

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 22:35'!
delete

	self breakDependents.
	super delete.! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:57'!
initialize

	super initialize.
	self setDefaultParameters.
	self extent: 400 @ 150.
	responseUponCancel := ''.
	Preferences roundedMenuCorners
		ifTrue: [self useRoundedCorners].
	! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sw 1/31/2000 11:01'!
responseUponCancel: anObject
	responseUponCancel _ anObject
! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 10:54'!
setDefaultParameters
	"change the receiver's appareance parameters"

	| colorFromMenu worldColor menuColor |

	colorFromMenu := Preferences menuColorFromWorld
									and: [Display depth > 4]
									and: [(worldColor := self currentWorld color) isColor].

	menuColor := colorFromMenu
						ifTrue: [worldColor luminance > 0.7
										ifTrue: [worldColor mixed: 0.85 with: Color black]
										ifFalse: [worldColor mixed: 0.4 with: Color white]]
						ifFalse: [Preferences menuColor].

	self color: menuColor.
	self borderWidth: Preferences menuBorderWidth.

	Preferences menuAppearance3d ifTrue: [
		self borderStyle: BorderStyle thinGray.
		self
			addDropShadow;
			shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666);
			shadowOffset: 1 @ 1
	]
	ifFalse: [
		| menuBorderColor |
		menuBorderColor := colorFromMenu
										ifTrue: [worldColor muchDarker]
										ifFalse: [Preferences menuBorderColor].
		self borderColor: menuBorderColor.
	].


	self layoutInset: 3.
! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'ar 11/4/2000 23:21'!
setPasswordQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean
	| pane |
	self setQuery: queryString 
		initialAnswer: initialAnswer 
		answerHeight: answerHeight 
		acceptOnCR: acceptBoolean.
	pane _ self submorphNamed: 'textPane'.
	pane font: (StrikeFont passwordFontSize: 12).! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:58'!
setQuery: queryString initialAnswer: initialAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean 
	| query topOffset accept cancel buttonAreaHeight |
	response := initialAnswer.
	done := false.
	self removeAllMorphs.
	self layoutPolicy: ProportionalLayout new.
	query := self createQueryTextMorph: queryString.
	topOffset := query height + 4.
	accept := self createAcceptButton.
	cancel := self createCancelButton.
	buttonAreaHeight := (accept height max: cancel height)
				+ 4.
	textPane := self
				createTextPaneExtent: answerExtent
				acceptBoolean: acceptBoolean
				topOffset: topOffset
				buttonAreaHeight: buttonAreaHeight.
	self extent: (query extent x max: answerExtent x)
			+ 4 @ (topOffset + answerExtent y + 4 + buttonAreaHeight).
	! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'NS 8/1/2000 11:44'!
setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean
	self setQuery: queryString initialAnswer: initialAnswer 
		answerExtent: (self class defaultAnswerExtent x @ answerHeight) 
		acceptOnCR: acceptBoolean
! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:58'!
updateColor
	"update the recevier's fillStyle"
	| textPaneBorderColor |
	self
		updateColor: self
		color: self color
		intensity: 1.
	textPane isNil
		ifTrue: [^ self].
	textPaneBorderColor := self borderColor == #raised
				ifTrue: [#inset]
				ifFalse: [self borderColor].
	textPane borderColor: textPaneBorderColor! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jrp 7/6/2005 21:44'!
updateColor: aMorph color: aColor intensity: anInteger 
	"update the apareance of aMorph"
	| fill |
	Preferences gradientMenu
		ifFalse: [^ self].

	fill _ GradientFillStyle ramp: {0.0 -> Color white. 1 -> aColor}.
	fill radial: false;
		origin: aMorph topLeft;
		direction: 0 @ aMorph height.
	aMorph fillStyle: fill! !


!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'jrp 10/4/2004 16:06'!
getUserResponse
	"Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels."
	"Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."

	| w |
	w _ self world.
	w ifNil: [^ response].
	
	(ProvideAnswerNotification signal:
		(self submorphOfClass: TextMorph) userString) ifNotNilDo:
		[:answer |
		self delete.
		w doOneCycle.
		^ response _ (answer == #default) ifTrue: [response] ifFalse: [answer]].

	done _ false.
	w activeHand newKeyboardFocus: textPane.
	[done] whileFalse: [w doOneCycle].
	self delete.
	w doOneCycle.
	^ response
! !

!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'RAA 7/19/2000 20:40'!
morphicLayerNumber

	^10.6! !


!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jm 5/4/1998 14:21'!
accept
	"Sent by the accept button."

	textPane accept.
! !

!FillInTheBlankMorph methodsFor: 'menu' stamp: 'sw 1/31/2000 11:11'!
cancel
	"Sent by the cancel button."

	response _ responseUponCancel.
	done _ true.
! !

!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jm 5/4/1998 15:15'!
codePaneMenu: aMenu shifted: shifted

	^ StringHolder new codePaneMenu: aMenu shifted: shifted.
! !


!FillInTheBlankMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:59'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	varDict at: 'responseUponCancel' ifAbsent: [responseUponCancel _ ''].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!FillInTheBlankMorph methodsFor: '*services-base' stamp: 'rr 1/9/2006 11:52'!
selection
	"answers what is actually selected in the morph"
	^ textPane selectionInterval! !

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

FillInTheBlankMorph class
	instanceVariableNames: ''!

!FillInTheBlankMorph class methodsFor: 'default constants' stamp: 'dgd 4/27/2003 17:10'!
defaultAnswerExtent
	^  (200@60 * (Preferences standardMenuFont height / 12)) rounded! !


!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'!
request: queryString
	"Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels."
	"FillInTheBlankMorph request: 'What is your favorite color?'"

	^ self
		request: queryString
		initialAnswer: ''
		centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'!
request: queryString initialAnswer: defaultAnswer 
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels."
	"FillInTheBlankMorph
		request: 'What is your favorite color?'
		initialAnswer: 'red, no blue. Ahhh!!'"

	^ self
		request: queryString
		initialAnswer: defaultAnswer
		centerAt: ActiveHand cursorPoint! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/17/2001 23:43'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels.
	This variant is only for calling from within a Morphic project."
	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	 ^ self 
		request: queryString 
		initialAnswer: defaultAnswer 
		centerAt: aPoint 
		inWorld: ActiveWorld
! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 1/31/2000 11:03'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.  Answer the empty string if the user cancels."
	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: ''! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 2/2/2000 22:43'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.   If the user cancels, answer returnOnCancel.  If user hits cr, treat it as a normal accept."

	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: true! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:44'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.   If the user cancels, answer returnOnCancel."

	^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint 
		inWorld: aWorld onCancelReturn: returnOnCancel 
		acceptOnCR: acceptBoolean answerExtent: self defaultAnswerExtent! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:39'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerExtent: answerExtent
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.   If the user cancels, answer returnOnCancel."
	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	| aFillInTheBlankMorph |
	aFillInTheBlankMorph _ self new
		setQuery: queryString
		initialAnswer: defaultAnswer
		answerExtent: answerExtent
		acceptOnCR: acceptBoolean.
	aFillInTheBlankMorph responseUponCancel: returnOnCancel.
	aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint.
	^ aFillInTheBlankMorph getUserResponse
! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:43'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerHeight: answerHeight
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.   If the user cancels, answer returnOnCancel."
	^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint 
		inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean 
		answerExtent: self defaultAnswerExtent x @ answerHeight! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 13:57'!
requestPassword: queryString
	"Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels."
	"use password font"
	"FillInTheBlankMorph requestPassword: 'Password?'"

	^ self
		requestPassword: queryString
		initialAnswer: ''
		centerAt: Sensor cursorPoint
		inWorld: World
		onCancelReturn: ''
		acceptOnCR: true
! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 13:53'!
requestPassword: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.   If the user cancels, answer returnOnCancel."
	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	| aFillInTheBlankMorph |
	aFillInTheBlankMorph _ self new
		setPasswordQuery: queryString
		initialAnswer: defaultAnswer
		answerHeight: 50
		acceptOnCR: acceptBoolean.
	aFillInTheBlankMorph responseUponCancel: returnOnCancel.
	aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint.
	^ aFillInTheBlankMorph getUserResponse
! !
StringHolderView subclass: #FillInTheBlankView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!FillInTheBlankView commentStamp: '<historical>' prior: 0!
I am a view of a FillInTheBlank. I display a query and an editable view of the user's reply string.
!


!FillInTheBlankView methodsFor: 'controller access' stamp: 'jm 4/28/1998 06:37'!
defaultControllerClass

	^ FillInTheBlankController
! !

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

FillInTheBlankView class
	instanceVariableNames: ''!

!FillInTheBlankView class methodsFor: 'instance creation' stamp: 'jm 4/28/1998 08:35'!
multiLineOn: aFillInTheBlank message: queryString centerAt: aPoint answerHeight: answerHeight
	"Answer an instance of me on aFillInTheBlank asking the question queryString. Allow the reply to be multiple lines, and make the user input view the given height."

	| messageView answerView topView |
	messageView _ DisplayTextView new
		model: queryString asDisplayText;
		borderWidthLeft: 2 right: 2 top: 2 bottom: 0;
		controller: NoController new.
	messageView
		window: (0@0 extent: (messageView window extent max: 200@30));
		centered.
	answerView _ self new
		model: aFillInTheBlank;
		window: (0@0 extent: (messageView window width@answerHeight));
		borderWidth: 2.
	topView _ View new model: aFillInTheBlank.
	topView controller: ModalController new.
	topView addSubView: messageView.
	topView addSubView: answerView below: messageView.
	topView align: topView viewport center with: aPoint.
	topView window:
		(0 @ 0 extent:
			(messageView window width) @
			  (messageView window height + answerView window height)).
	topView translateBy:
		(topView displayBox amountToTranslateWithin: Display boundingBox).
	^ topView
! !

!FillInTheBlankView class methodsFor: 'instance creation' stamp: 'jm 4/28/1998 08:22'!
on: aFillInTheBlank message: queryString centerAt: aPoint
	"Answer an instance of me on aFillInTheBlank for a single line of input in response to the question queryString."

	aFillInTheBlank acceptOnCR: true.
	^ self
		multiLineOn: aFillInTheBlank
		message: queryString
		centerAt: aPoint
		answerHeight: 40
! !

!FillInTheBlankView class methodsFor: 'instance creation' stamp: 'jdr 6/4/2000 15:03'!
requestPassword: aFillInTheBlank message: queryString centerAt: aPoint answerHeight: answerHeight
	"Answer an instance of me on aFillInTheBlank asking the question queryString. Allow the reply to be multiple lines, and make the user input view the given height."

	| messageView answerView topView myPar pwdFont myArray myStyle |
	aFillInTheBlank acceptOnCR: true.
	messageView _ DisplayTextView new
		model: queryString asDisplayText;
		borderWidthLeft: 2 right: 2 top: 2 bottom: 0;
		controller: NoController new.
	messageView
		window: (0@0 extent: (messageView window extent max: 200@30));
		centered.
	answerView _ self new
		model: aFillInTheBlank;
		window: (0@0 extent: (messageView window width@answerHeight));
		borderWidth: 2.
	" now answerView to use the password font"
	myPar _ answerView displayContents.
	pwdFont _ (StrikeFont passwordFontSize: 12).
	myArray _ Array new: 1.
	myArray at: 1 put: pwdFont.
	myStyle _ TextStyle fontArray: myArray.
	myPar setWithText: (myPar text) style: myStyle.

	topView _ View new model: aFillInTheBlank.
	topView controller: ModalController new.
	topView addSubView: messageView.
	topView addSubView: answerView below: messageView.
	topView align: topView viewport center with: aPoint.
	topView window:
		(0 @ 0 extent:
			(messageView window width) @
			  (messageView window height + answerView window height)).
	topView translateBy:
		(topView displayBox amountToTranslateWithin: Display boundingBox).
	^ topView
! !
Object subclass: #FillStyle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!
!FillStyle commentStamp: '<historical>' prior: 0!
FillStyle is an abstract base class for fills in the BalloonEngine.!


!FillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:23'!
scaledPixelValue32
	"Return a pixel value of depth 32 for the primary color in the fill style"
	^self asColor scaledPixelValue32! !


!FillStyle methodsFor: 'converting' stamp: 'ar 11/9/1998 13:53'!
asColor
	^self subclassResponsibility! !

!FillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:41'!
mixed: fraction with: aColor
	^self asColor mixed: fraction with: aColor! !


!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'!
isBitmapFill
	^false! !

!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'!
isGradientFill
	^false! !

!FillStyle methodsFor: 'testing' stamp: 'ar 6/18/1999 07:57'!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^false! !

!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'!
isSolidFill
	^false! !

!FillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:28'!
isTranslucent
	^true "Since we don't know better"! !

!FillStyle methodsFor: 'testing' stamp: 'ar 10/26/2000 19:24'!
isTransparent
	^false! !
MagnifierMorph subclass: #FishEyeMorph
	instanceVariableNames: 'gridNum d clipRects toRects quads savedExtent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!FishEyeMorph methodsFor: 'geometry' stamp: 'yo 12/17/1999 12:27'!
extent: aPoint
	"Round to a number divisible by grid.  Note that the superclass has its own implementation."
	| g gridSize |
	gridSize _ self gridSizeFor: aPoint.
	"self halt."
	g _ (aPoint - (2 * borderWidth)) // gridSize.
	srcExtent _ g * gridSize.
	gridNum _ g.
	^super extent: self defaultExtent! !


!FishEyeMorph methodsFor: 'initialization' stamp: 'yo 12/17/1999 12:00'!
calculateTransform
	| stepX stepY rect tx ty arrayX arrayY |
	(gridNum x = 0 or: [gridNum y = 0]) ifTrue: [^self].
	stepX _ srcExtent x // gridNum x.
	stepY _ srcExtent y // gridNum y.

	arrayX _ (1 to: gridNum y + 1) collect: [:j | FloatArray new: gridNum x + 1].
	arrayY _ (1 to: gridNum y + 1) collect: [:j |  FloatArray new: gridNum x + 1].

	0 to: gridNum y do: [:j |
		0 to: gridNum x do: [:i |
			(arrayX at: (j + 1)) at: (i + 1) put: i*stepX.
			(arrayY at: (j + 1)) at: (i + 1) put: j*stepY.
		].
	].

	0 to: gridNum y do: [:j |
		self transformX: (arrayX at: (j+1)).
		self transformY: (arrayY at: (j+1)).
	].

	0 to: gridNum y do: [:j |
		arrayX at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayX at: (j+1)) at: i) asInteger]).
		arrayY at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayY at: (j+1)) at: i) asInteger]).
	].


	clipRects _ (1 to: gridNum y) collect: [:j | Array new: gridNum x].
	toRects _ (1 to: gridNum y) collect: [:j |  Array new: gridNum x].
	quads _ (1 to: gridNum y) collect: [:j |  Array new: gridNum x].
	0 to: gridNum y - 1 do: [:j |
		0 to: gridNum x- 1 do: [:i |
			rect _ (((arrayX at: (j+1)) at: (i+1))@((arrayY at: (j+1)) at: (i+1)))
						corner: ((arrayX at: (j+2)) at: (i+2))@((arrayY at: (j+2)) at: (i+2)).
			(clipRects at: j+1) at: i+1 put: rect.

			rect width >= stepX ifTrue: [rect _ rect expandBy: (1@0)].
			rect height >= stepY ifTrue: [rect _ rect expandBy: (0@1)].
			(toRects at: j+1) at: i+1 put: rect.

			tx _ (i)*stepX.
			ty _ (j)*stepY.
			(quads at: j+1) at: i+1
						put: {(tx)@(ty). (tx)@(ty+stepY). (tx+stepX)@(ty+stepY). (tx+stepX)@(ty)}.
		].
	].

! !

!FishEyeMorph methodsFor: 'initialization' stamp: 'yo 12/17/1999 10:15'!
g: aFloatArray max: max focus: focus
	| dNormX array |

	dNormX _ aFloatArray - focus.
	
	array _ dNormX / max.
	array *= d.
	array += 1.0.
	array _ 1.0 / array.
	dNormX *= (d+1.0).
	array *= dNormX.
	^array += focus.
! !

!FishEyeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:39'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	"magnification should be always 1"
	magnification _ 1.
	d _ 1.3.
	self extent: 130 @ 130! !

!FishEyeMorph methodsFor: 'initialization' stamp: 'md 11/14/2003 16:32'!
transformX: aFloatArray
	| focus gridNum2 subArray dMaxX |

	focus _ srcExtent x asFloat / 2.

	gridNum2 _ (aFloatArray findFirst: [:x | x > focus]) - 1.

	dMaxX _ 0.0 - focus.
	subArray _ self g: (aFloatArray copyFrom: 1 to: gridNum2) max: dMaxX focus: focus.

	aFloatArray replaceFrom: 1 to: gridNum2 with: subArray startingAt: 1.


	dMaxX _ focus.    " = (size - focus)"
	subArray _ self g: (aFloatArray copyFrom: gridNum2 + 1 to: gridNum x + 1)
		max: dMaxX focus: focus.

	aFloatArray replaceFrom: gridNum2 + 1 to: gridNum x + 1 with: subArray startingAt: 1.
! !

!FishEyeMorph methodsFor: 'initialization' stamp: 'dgd 2/21/2003 23:04'!
transformY: aFloatArray 
	| focus subArray dMaxY |
	focus := srcExtent y asFloat / 2.
	dMaxY := (aFloatArray first) <= focus 
				ifTrue: [0.0 - focus]
				ifFalse: [focus].
	subArray := self 
				g: (aFloatArray copyFrom: 1 to: gridNum x + 1)
				max: dMaxY
				focus: focus.
	aFloatArray 
		replaceFrom: 1
		to: gridNum x + 1
		with: subArray
		startingAt: 1! !


!FishEyeMorph methodsFor: 'magnifying' stamp: 'ar 5/28/2000 12:12'!
magnifiedForm
	| warp warpForm fromForm |

	savedExtent ~= srcExtent ifTrue: [
		savedExtent _ srcExtent.
		self calculateTransform].

	warpForm _ Form extent: srcExtent depth: Display depth.
	fromForm _ super magnifiedForm.

	warp _  (WarpBlt current toForm: warpForm)
		sourceForm: fromForm;
		colorMap: nil;
		cellSize: 2;
		combinationRule: Form over.

	1 to: gridNum y do: [:j |
		1 to: gridNum x do: [:i |
			warp
				clipRect: ((clipRects at: j) at: i);
				copyQuad: ((quads at: j) at: i)
					toRect: ((toRects at: j) at: i).
		].
	].
	^warpForm
! !


!FishEyeMorph methodsFor: 'menu' stamp: 'yo 12/17/1999 12:03'!
chooseMagnification: evt
! !


!FishEyeMorph methodsFor: 'menus' stamp: 'dgd 9/21/2003 17:55'!
chooseMagnification
	self inform: 'Magnification is fixed, sorry.' translated! !


!FishEyeMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'!
initializeToStandAlone
	super initializeToStandAlone.
	"magnification should be always 1"
	magnification _ 1.
	d _ 1.3.
	self extent: 130@130.
! !


!FishEyeMorph methodsFor: 'private' stamp: 'yo 12/17/1999 11:15'!
gridSizeFor: aPoint
	"returns appropriate size for specified argument"
	| g |
	g _ aPoint x min: aPoint y.
	g <= 256 ifTrue: [^8].
	^16.! !

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

FishEyeMorph class
	instanceVariableNames: ''!

!FishEyeMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:47'!
descriptionForPartsBin
	^ self partName:	'FishEye'
		categories:		#('Useful')
		documentation:	'An extreme-wide-angle lens'! !
Object subclass: #FixUnderscores
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FixUnderscores'!

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

FixUnderscores class
	instanceVariableNames: ''!

!FixUnderscores class methodsFor: 'class initialization' stamp: 'bf 10/18/2005 12:13'!
initialize
	"self initialize"

	self fixFonts.
	self inform: 'Fonts were _fixed_.\The arrow glyph is now Character value ' withCRs,
		self arrowChar asInteger hex, ' ($', self arrowChar asString, ')'.
! !


!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 4/7/2006 14:47'!
arrowChar
	"FIXME: this should rather be (Character leftArrow)"
	^Character value: 16r8F! !

!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 11/26/2004 21:52'!
fixFonts
	"self fixFonts"

	StrikeFont allInstances
		do: [:fnt | self fixFont: fnt]
		displayingProgress: 'Fixing Bitmap Fonts'.! !

!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 10/18/2005 19:05'!
fixFont: aFont
	| glyph underline |
	glyph := aFont characterFormAt: $_.
	"save arrow glyph to arrowChar codepoint"
	((glyph copy: (0@aFont ascent corner: glyph extent)) isAllWhite
		and: [(aFont characterFormAt: self arrowChar) isAllWhite])
			ifTrue: [aFont characterFormAt: self arrowChar put: glyph].
	"make underscore glyph"
	glyph fillWhite.
	underline := aFont ascent + 1.
	glyph fillBlack: (1@underline extent: glyph width-1@1).
	aFont characterFormAt: $_ put: glyph.! !

!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 4/7/2006 15:23'!
fixPackages: packageNames
	"FixUnderscores fixPackages: #('FixUnderscores' 'Bert')"

	| failed |
	failed := OrderedCollection new.

	packageNames
		do: [:pkgName | (PackageInfo named: pkgName) methods
			do: [:mRef | mRef fixUnderscores ifFalse: [failed add: mRef]] 
			displayingProgress: pkgName]
		displayingProgress: 'Fixing ...'.

	failed isEmpty ifFalse: [
		MessageSet openMessageList: failed
			name: 'These methods with literal underscores were not fixed'
			autoSelect: '_'].! !

!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 4/7/2006 15:11'!
fixPackage: aPackageName
	^self fixPackages: {aPackageName}

! !
AbstractFont subclass: #FixedFaceFont
	instanceVariableNames: 'baseFont substitutionCharacter displaySelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!
!FixedFaceFont commentStamp: 'tak 12/22/2004 01:45' prior: 0!
I am a font for special purpose like password or fallback.
I can show same form whenever someone requests any character.

Variable displaySelector is future use to show a form dynamically.
(Although it would be unnecessary...)!


!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'!
ascent
	^baseFont ascent! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'!
ascentOf: aCharacter
	^ self ascent! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'!
baseFont
	^baseFont! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'!
baseFont: aFont
	baseFont := aFont! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'!
baseKern
	^baseFont baseKern! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/22/2004 02:01'!
characterFormAt: character 
	^ baseFont characterFormAt: substitutionCharacter! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 17:00'!
descent
	^baseFont descent! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'!
descentKern
	^baseFont descentKern! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'!
descentOf: aCharacter
	^ self descent! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:10'!
emphasized: emph
	^self class new baseFont: (baseFont emphasized: emph)! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:25'!
familyName
	^baseFont familyName, '-pw'! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:19'!
fontSize: aNumber 
	self baseFont: (StrikeFont familyName: baseFont familyName size: aNumber) copy! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'!
height
	^baseFont height! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:26'!
lineGrid
	^baseFont lineGrid! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'!
maxAscii
	^ SmallInteger maxVal! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'!
passwordCharacter
	^$*! !

!FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:28'!
pointSize
	^baseFont pointSize! !


!FixedFaceFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:48'!
releaseCachedState
	baseFont releaseCachedState.! !


!FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 18:06'!
displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta 
	| maskedString |
	maskedString := String new: length.
	maskedString atAllPut: substitutionCharacter.
	^ baseFont
		displayString: maskedString
		on: aCanvas
		from: 1
		to: length
		at: aPoint
		kern: kernDelta! !

!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:49'!
displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY
	| maskedString |
	maskedString := String new: length.
	maskedString atAllPut: substitutionCharacter.
	^ baseFont
		displayString: maskedString
		on: aCanvas
		from: 1
		to: length
		at: aPoint
		kern: kernDelta
		baselineY: baselineY! !

!FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 18:06'!
displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta 
	| maskedString |
	maskedString := String new: length.
	maskedString atAllPut: substitutionCharacter.
	^ baseFont
		displayString: maskedString
		on: aCanvas
		from: 1
		to: length
		at: aPoint
		kern: kernDelta! !

!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:50'!
displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY
	| maskedString |
	maskedString := String new: length.
	maskedString atAllPut: substitutionCharacter.
	^ baseFont
		displayString: maskedString
		on: aCanvas
		from: 1
		to: length
		at: aPoint
		kern: kernDelta
		baselineY: baselineY! !

!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:00'!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta 
	| size |
	size := stopIndex - startIndex + 1.
	^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: aPoint y + self ascent).! !

!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:19'!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY
	| size |
	size := stopIndex - startIndex + 1.
	^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: baselineY).! !

!FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 11:10'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont 
	| destPoint |
	destPoint := self
				displayString: aString
				on: aBitBlt
				from: startIndex
				to: stopIndex
				at: aPoint
				kern: kernDelta.
	^ Array with: stopIndex + 1 with: destPoint! !

!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:51'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY
	| destPoint |
	destPoint := self
				displayString: aString
				on: aBitBlt
				from: startIndex
				to: stopIndex
				at: aPoint
				kern: kernDelta
				baselineY: baselineY.
	^ Array with: stopIndex + 1 with: destPoint! !

!FixedFaceFont methodsFor: 'displaying' stamp: 'ar 1/5/2003 17:00'!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! !


!FixedFaceFont methodsFor: 'initialize-release' stamp: 'yo 1/7/2005 11:59'!
errorFont
	displaySelector := #displayErrorOn:length:at:kern:baselineY:.
	substitutionCharacter := $?.! !

!FixedFaceFont methodsFor: 'initialize-release' stamp: 'tak 12/20/2004 10:37'!
initialize
	baseFont := TextStyle defaultFont.
	self passwordFont! !

!FixedFaceFont methodsFor: 'initialize-release' stamp: 'yo 1/7/2005 11:59'!
passwordFont
	displaySelector := #displayPasswordOn:length:at:kern:baselineY:.
	substitutionCharacter := $*! !


!FixedFaceFont methodsFor: 'measuring' stamp: 'tak 12/20/2004 18:05'!
widthOf: aCharacter 
	^ baseFont widthOf: substitutionCharacter! !


!FixedFaceFont methodsFor: 'private' stamp: 'yo 1/11/2005 18:54'!
glyphInfoOf: aCharacter into: glyphInfoArray

	^ baseFont glyphInfoOf: substitutionCharacter into: glyphInfoArray.
! !
Array variableSubclass: #FixedIdentitySet
	instanceVariableNames: 'tally capacity'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Requires'!
!FixedIdentitySet commentStamp: 'NS 5/26/2005 13:00' prior: 0!
This is a fast but lazy implementation of fixed size identity sets. The two main difference to regular identity sets are:

1) These identity sets have a fixed size. If they are full, adding another element doesn't have any effect.
2) No rehashing. If two elements were to be stored on the same position in the underlying array, one of them is simply discarded.

As a consequence of (1) and (2), these identity sets are very fast!! Note that this class inherits form Array. This is not clean but reduces memory overhead when instances are created.!


!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 10:49'!
addAll: aCollection
	aCollection do: [:each | 
		self isFull ifTrue: [^ self].
		self add: each.
	].! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 10:50'!
addAll: aCollection notIn: notCollection
	aCollection do: [:each | 
		self isFull ifTrue: [^ self].
		(notCollection includes: each) ifFalse: [self add: each].
	].! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 10:47'!
add: anObject
	| index old |
	self isFull ifTrue: [^ false].
	index _ self indexOf: anObject.
	old _ self basicAt: index.
	old == anObject ifTrue: [^ true].
	old ifNotNil: [^ false].
	self basicAt: index put: anObject.
	tally _ tally + 1.
	^ true! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 08:44'!
at: index
	self shouldNotImplement! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 08:43'!
at: index put: anObject
	self shouldNotImplement! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/23/2005 17:40'!
capacity
	^ capacity! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 10:46'!
destructiveAdd: anObject
	| index old |
	self isFull ifTrue: [^ false].
	index _ self indexOf: anObject.
	old _ self basicAt: index.
	self basicAt: index put: anObject.
	old ifNil: [tally _ tally + 1].
	^ true! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 08:45'!
includes: anObject
	^ (self basicAt: (self indexOf: anObject)) == anObject! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 13:12'!
remove: anObject ifAbsent: aBlock
	| index |
	index _ self indexOf: anObject.
	^ (self basicAt: index) == anObject 
		ifTrue: [self basicAt: index put: nil. tally _ tally - 1. anObject]
		ifFalse: [aBlock value].! !

!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/23/2005 13:13'!
size
	^ tally! !


!FixedIdentitySet methodsFor: 'comparing' stamp: 'NS 5/24/2005 08:56'!
hash
	"Answer an integer hash value for the receiver such that,
	  -- the hash value of an unchanged object is constant over time, and
	  -- two equal objects have equal hash values"

	| hash |
	hash _ self species hash.
	self size <= 10 ifTrue:
		[self do: [:elem | hash _ hash bitXor: elem hash]].
	^hash bitXor: self size hash! !

!FixedIdentitySet methodsFor: 'comparing' stamp: 'NS 5/24/2005 08:59'!
= aCollection
	self == aCollection ifTrue: [^ true].
	aCollection size = self size ifFalse: [^ false].
	aCollection do: [:each | (self includes: each) ifFalse: [^ false]].
	^ true! !


!FixedIdentitySet methodsFor: 'enumerating' stamp: 'NS 5/24/2005 09:04'!
do: aBlock
	| obj count |
	count _ 0.
	1 to: self basicSize do: [:index |
		count >= tally ifTrue: [^ self].
		obj _ self basicAt: index.
		obj ifNotNil: [count _ count + 1. aBlock value: obj].
	].
! !

!FixedIdentitySet methodsFor: 'enumerating' stamp: 'NS 5/24/2005 13:52'!
select: aBlock
	| result |
	result _ self species new: self capacity.
	self do: [:each | (aBlock value: each) ifTrue: [result add: each]].
	^ result.! !


!FixedIdentitySet methodsFor: 'initialize-release' stamp: 'NS 5/23/2005 17:39'!
initializeCapacity: anInteger
	tally _ 0.
	capacity _ anInteger.! !


!FixedIdentitySet methodsFor: 'printing' stamp: 'NS 5/23/2005 18:32'!
printOn: aStream
	| count |
	aStream nextPutAll: '#('.
	count _ 0.
	self do: [:each | 
		count _ count + 1.
		each printOn: aStream.
		count < self size ifTrue: [aStream nextPut: $ ]
	].
	aStream nextPut: $).! !


!FixedIdentitySet methodsFor: 'testing' stamp: 'NS 5/24/2005 10:45'!
isFull
	^ tally >= capacity! !

!FixedIdentitySet methodsFor: 'testing' stamp: 'NS 5/24/2005 10:46'!
notFull
	^ tally < capacity! !


!FixedIdentitySet methodsFor: 'private' stamp: 'NS 5/23/2005 18:08'!
arraySize
	^ super size! !

!FixedIdentitySet methodsFor: 'private' stamp: 'NS 5/24/2005 10:48'!
indexOf: anObject
	anObject isNil ifTrue: [self error: 'This class collection cannot handle nil as an element'].
	^ (anObject identityHash bitAnd: self basicSize - 1) + 1! !

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

FixedIdentitySet class
	instanceVariableNames: ''!

!FixedIdentitySet class methodsFor: 'constants' stamp: 'NS 5/26/2005 13:02'!
arraySizeForCapacity: anInteger
	"Because of the hash performance, the array size is always a power of 2 
	and at least twice as big as the capacity anInteger"

	^ anInteger <= 0 
		ifTrue: [0]
		ifFalse: [1 << (anInteger << 1 - 1) highBit].! !

!FixedIdentitySet class methodsFor: 'constants' stamp: 'NS 5/26/2005 13:03'!
defaultSize
	^ 4! !

!FixedIdentitySet class methodsFor: 'constants' stamp: 'NS 5/23/2005 13:09'!
new
	^ self new: self defaultSize! !

!FixedIdentitySet class methodsFor: 'constants' stamp: 'NS 5/23/2005 17:40'!
new: anInteger
	^ (super new: (self arraySizeForCapacity: anInteger)) initializeCapacity: anInteger! !


!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/26/2005 13:05'!
readonlyWithAll: aCollection notIn: notCollection
	"For performance reasons, this method may return an array rather than a FixedIdentitySet. 
	Therefore it should only be used if the return value does not need to be modified.
	Use #withAll:notIn: if the return value might need to be modified."

	| size |
	aCollection isEmpty ifTrue: [^ #()].
	size _ aCollection size = 1 
		ifTrue: [1]
		ifFalse: [self sizeFor: aCollection].
	^ (self new: size) addAll: aCollection notIn: notCollection; yourself! !

!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 13:57'!
withAll: aCollection
	"Create a new collection containing all the elements from aCollection."

	^ (self new: (self sizeFor: aCollection))
		addAll: aCollection;
		yourself! !

!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 13:58'!
withAll: aCollection notIn: notCollection
	^ (self new: (self sizeFor: aCollection)) addAll: aCollection notIn: notCollection; yourself! !

!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:51'!
with: anObject 
	"Answer an instance of me containing anObject."

	^ self new
		add: anObject;
		yourself! !

!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:51'!
with: firstObject with: secondObject 
	"Answer an instance of me containing the two arguments as elements."

	^ self new
		add: firstObject;
		add: secondObject;
		yourself! !

!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:51'!
with: firstObject with: secondObject with: thirdObject 
	"Answer an instance of me containing the three arguments as elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		yourself! !

!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:51'!
with: firstObject with: secondObject with: thirdObject with: fourthObject 
	"Answer an instance of me, containing the four arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		yourself! !

!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:52'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
	"Answer an instance of me, containing the five arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		add: fifthObject;
		yourself! !

!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:52'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject
	"Answer an instance of me, containing the six arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		add: fifthObject;
		add: sixthObject;
		yourself! !


!FixedIdentitySet class methodsFor: 'private' stamp: 'NS 5/24/2005 13:57'!
sizeFor: aCollection
	^ aCollection species == self 
		ifTrue: [aCollection capacity]
		ifFalse: [self defaultSize].! !
ReferenceMorph subclass: #FlapTab
	instanceVariableNames: 'flapShowing edgeToAdhereTo slidesOtherObjects popOutOnDragOver popOutOnMouseOver inboard dragged lastReferentThickness edgeFraction labelString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Flaps'!
!FlapTab commentStamp: '<historical>' prior: 0!
The tab associated with a flap.

nb: slidesOtherObjects and inboard are instance variables relating to disused features.  The feature implementations still exist in the system, but the UI to them has been sealed off.!


!FlapTab methodsFor: 'access' stamp: 'dgd 8/31/2003 18:58'!
acquirePlausibleFlapID
	"Give the receiver a flapID that is globally unique; try to hit the mark vis a vis the standard system flap id's, for the case when this method is invoked as part of the one-time transition"

	| wording |
	wording _ self wording.
	(wording isEmpty or: [wording = '---']) ifTrue: [wording _ 'Flap' translated].
	
	^ self provideDefaultFlapIDBasedOn: wording! !

!FlapTab methodsFor: 'access' stamp: 'sw 4/30/2001 18:39'!
flapID
	"Answer the receiver's flapID, creating it if necessary"

	^ self knownName ifNil: [self acquirePlausibleFlapID]! !

!FlapTab methodsFor: 'access' stamp: 'sw 4/30/2001 18:39'!
flapID: anID
	"Set the receiver's flapID"

	self setNameTo: anID! !

!FlapTab methodsFor: 'access' stamp: 'sw 5/4/2001 23:25'!
flapIDOrNil
	"If the receiver has a flapID, answer it, else answer nil"

	^ self knownName! !

!FlapTab methodsFor: 'access' stamp: 'sw 2/9/1999 14:44'!
flapShowing
	^ flapShowing == true! !

!FlapTab methodsFor: 'access' stamp: 'MAL 1/7/2005 12:25'!
orientation
	^ (#left == edgeToAdhereTo or: [#right == edgeToAdhereTo])
		ifTrue:		[#vertical]
		ifFalse:		[#horizontal]! !

!FlapTab methodsFor: 'access' stamp: 'sw 6/18/1999 13:38'!
referentThickness
	^ (self orientation == #horizontal)
		ifTrue:
			[referent height]
		ifFalse:
			[referent width]! !

!FlapTab methodsFor: 'access' stamp: 'sw 2/27/1999 13:14'!
tabThickness
	^ (self orientation == #vertical)
		ifTrue:
			[self width]
		ifFalse:
			[self height]! !


!FlapTab methodsFor: 'accessing' stamp: 'tk 9/25/2002 18:08'!
labelString
	^labelString! !


!FlapTab methodsFor: 'change reporting' stamp: 'ar 10/26/2000 17:36'!
ownerChanged
	self fitOnScreen.
	^super ownerChanged.! !


!FlapTab methodsFor: 'classification' stamp: 'ar 9/28/2000 13:53'!
isFlapTab
	^true! !


!FlapTab methodsFor: 'disused options' stamp: 'sw 6/21/1999 13:03'!
inboard
	^ inboard == true! !

!FlapTab methodsFor: 'disused options' stamp: 'sw 2/15/1999 12:57'!
inboard: aBoolean
	inboard _ aBoolean! !

!FlapTab methodsFor: 'disused options' stamp: 'sw 2/11/1999 10:55'!
slidesOtherObjects
	^ slidesOtherObjects! !


!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 20:51'!
applyEdgeFractionWithin: aBoundsRectangle
	"Make the receiver reflect remembered edgeFraction"

	| newPosition |
	edgeFraction ifNil: [^ self].
	self isCurrentlySolid ifTrue: [^ self].
	newPosition _ self
		ifVertical:
			[self left @  (self edgeFraction * (aBoundsRectangle height - self height))]
		ifHorizontal:
			[(self edgeFraction * (aBoundsRectangle width - self width) @ self top)].

	self position: (aBoundsRectangle origin + newPosition)
	! !

!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 15:01'!
computeEdgeFraction
	"Compute and remember the edge fraction"

	| aBox aFraction |
	self isCurrentlySolid ifTrue: [^ edgeFraction ifNil: [self edgeFraction: 0.5]].

	aBox _ ((owner ifNil: [ActiveWorld]) bounds) insetBy: (self extent // 2).
	aFraction _ self
		ifVertical: 
			[(self center y - aBox top) / (aBox height max: 1)]
		ifHorizontal:
			[(self center x - aBox left) / (aBox width max: 1)].
	^ self edgeFraction: aFraction! !

!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 06:56'!
edgeFraction
	^ edgeFraction ifNil: [self computeEdgeFraction]! !

!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 08:38'!
edgeFraction: aNumber
	"Set my edgeFraction to the given number, without side effects"

	edgeFraction _ aNumber asFloat! !

!FlapTab methodsFor: 'edge' stamp: 'yo 2/10/2005 18:06'!
edgeString
	^ 'cling to edge... (current: {1})' translated format: {edgeToAdhereTo translated}! !

!FlapTab methodsFor: 'edge' stamp: 'sw 2/11/1999 00:41'!
edgeToAdhereTo
	^ edgeToAdhereTo! !

!FlapTab methodsFor: 'edge' stamp: 'MAL 1/7/2005 12:20'!
edgeToAdhereTo: e
	edgeToAdhereTo _ e asSymbol! !

!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 15:58'!
ifVertical: block1 ifHorizontal: block2
	"Evaluate and return the value of either the first or the second block, depending whether I am vertically or horizontally oriented"

	^ self orientation == #vertical
		ifTrue:
			[block1 value]
		ifFalse:
			[block2 value]
	! !

!FlapTab methodsFor: 'edge' stamp: 'MAL 1/7/2005 12:24'!
setEdge: anEdge
	"Set the edge as indicated, if possible"

	| newOrientation e |
	e _ anEdge asSymbol.
	self edgeToAdhereTo = anEdge ifTrue: [^ self].
	newOrientation _ nil.
	self orientation == #vertical
		ifTrue: [(#top == e or: [#bottom == e]) ifTrue:
					[newOrientation _ #horizontal]]
		ifFalse: [(#top == e or: [#bottom == e]) ifFalse:
					[newOrientation _ #vertical]].
	self edgeToAdhereTo: e.
	newOrientation ifNotNil: [self transposeParts].
	referent isInWorld ifTrue: [self positionReferent].
	self adjustPositionVisAVisFlap! !

!FlapTab methodsFor: 'edge' stamp: 'dgd 10/17/2003 22:36'!
setEdgeToAdhereTo
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	#(left top right bottom) do:
		[:sym | aMenu add: sym asString translated target: self selector:  #setEdge: argument: sym].
	aMenu popUpEvent: self currentEvent in: self world! !


!FlapTab methodsFor: 'event handling' stamp: 'sw 10/31/2001 15:46'!
mouseMove: evt
	| aPosition newReferentThickness adjustedPosition thick |

	dragged ifFalse: [(thick _ self referentThickness) > 0
			ifTrue: [lastReferentThickness _ thick]].
	((self containsPoint: (aPosition _ evt cursorPoint)) and: [dragged not])
		ifFalse:
			[flapShowing ifFalse: [self showFlap].
			adjustedPosition _ aPosition - evt hand targetOffset.
			(edgeToAdhereTo == #bottom)
				ifTrue:
					[newReferentThickness _ inboard
						ifTrue:
							[self world height - adjustedPosition y]
						ifFalse:
							[self world height - adjustedPosition y - self height]].

			(edgeToAdhereTo == #left)
					ifTrue:
						[newReferentThickness _
							inboard
								ifTrue:
									[adjustedPosition x + self width]
								ifFalse:
									[adjustedPosition x]].

			(edgeToAdhereTo == #right)
					ifTrue:
						[newReferentThickness _
							inboard
								ifTrue:
									[self world width - adjustedPosition x]
								ifFalse:
									[self world width - adjustedPosition x - self width]].

			(edgeToAdhereTo == #top)
					ifTrue:
						[newReferentThickness _
							inboard
								ifTrue:
									[adjustedPosition y + self height]
								ifFalse:
									[adjustedPosition y]].
		
			self isCurrentlySolid ifFalse:
				[(#(left right) includes: edgeToAdhereTo)
					ifFalse:
						[self left: adjustedPosition x]
					ifTrue:
						[self top: adjustedPosition y]].

			self applyThickness: newReferentThickness.
			dragged _ true.
			self fitOnScreen.
			self computeEdgeFraction]! !

!FlapTab methodsFor: 'event handling' stamp: 'sw 11/22/2001 08:11'!
mouseUp: evt
	"The mouse came back up, presumably after having dragged the tab.  Caution: if not operating full-screen, this notification can easily be *missed*, which is why the edge-fraction-computation is also being done on mouseMove."

	super mouseUp: evt.
	(self referentThickness <= 0 or:
		[(referent isInWorld and: [(referent boundsInWorld intersects: referent owner boundsInWorld) not])]) ifTrue:
			[self hideFlap.
			flapShowing _ false].
	self fitOnScreen.
	dragged ifTrue:
		[self computeEdgeFraction.
		dragged _ false].
	Flaps doAutomaticLayoutOfFlapsIfAppropriate! !


!FlapTab methodsFor: 'events' stamp: 'sw 2/12/2001 17:04'!
tabSelected
	"The user clicked on the tab.  Show or hide the flap.  Try to be a little smart about a click on a tab whose flap is open but only just barely."

	dragged == true ifTrue:
		[^ dragged _ false].
	self flapShowing
		ifTrue:
			[self referentThickness < 23  "an attractive number"
				ifTrue:
					[self openFully]
				ifFalse:
					[self hideFlap]]
		ifFalse:
			[self showFlap]! !


!FlapTab methodsFor: 'globalness' stamp: 'sw 5/4/2001 23:25'!
isGlobalFlap
	"Answer whether the receiver is currently a shared flap"

	^ Flaps globalFlapTabsIfAny includes: self! !

!FlapTab methodsFor: 'globalness' stamp: 'dgd 8/30/2003 21:36'!
isGlobalFlapString
	"Answer a string to construct a menu item representing control 
	over whether the receiver is or is not a shared flap"
	^ (self isGlobalFlap
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'shared by all projects' translated! !

!FlapTab methodsFor: 'globalness' stamp: 'sw 4/30/2001 18:52'!
toggleIsGlobalFlap
	"Toggle whether the receiver is currently a global flap or not"

	| oldWorld |
	self hideFlap.
	oldWorld _ self currentWorld.
	self isGlobalFlap
		ifTrue:
			[Flaps removeFromGlobalFlapTabList: self.
			oldWorld addMorphFront: self]
		ifFalse:
			[self delete.
			Flaps addGlobalFlap: self.
			self currentWorld addGlobalFlaps].
	ActiveWorld reformulateUpdatingMenus
		! !


!FlapTab methodsFor: 'graphical tabs' stamp: 'sw 6/17/1999 16:07'!
graphicalTab
	self isCurrentlyGraphical
		ifTrue:
			[self changeTabGraphic]
		ifFalse:
			[self useGraphicalTab]! !

!FlapTab methodsFor: 'graphical tabs' stamp: 'dgd 8/30/2003 21:29'!
graphicalTabString
	^ (self isCurrentlyGraphical
		ifTrue: ['choose new graphic...']
		ifFalse: ['use graphical tab']) translated! !


!FlapTab methodsFor: 'initialization' stamp: 'tk 12/11/2000 16:29'!
adaptToWorld
	| wasShowing new |
	(wasShowing _ self flapShowing) ifTrue:
					[self hideFlap].
	(self respondsTo: #unhibernate) ifTrue: [
		(new _ self unhibernate) == self ifFalse: [
			^ new adaptToWorld]].
	self spanWorld.
	self positionObject: self.
	wasShowing ifTrue:
		[self showFlap]! !

!FlapTab methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:49'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	edgeToAdhereTo _ #left.
	flapShowing _ false.
	slidesOtherObjects _ false.
	popOutOnDragOver _ false.
	popOutOnMouseOver _ false.
	inboard _ false.
	dragged _ false! !

!FlapTab methodsFor: 'initialization' stamp: 'di 11/18/2001 13:09'!
provideDefaultFlapIDBasedOn: aStem
	"Provide the receiver with a default flap id"

	| aNumber usedIDs anID  |
	aNumber _ 0.
	usedIDs _ FlapTab allSubInstances select: [:f | f ~~ self] thenCollect: [:f | f flapIDOrNil].
	anID _ aStem.
	[usedIDs includes: anID] whileTrue:
		[aNumber _ aNumber + 1.
		anID _ aStem, (aNumber asString)].
	self flapID: anID.
	^ anID! !

!FlapTab methodsFor: 'initialization' stamp: 'di 11/19/2001 21:20'!
setName: nameString edge: edgeSymbol color: flapColor
	"Set me up with the usual..."

	self setNameTo: nameString.
	self edgeToAdhereTo: edgeSymbol; inboard: false.
	self assumeString: nameString font: Preferences standardFlapFont
		orientation: self orientation color: flapColor.
	self setToPopOutOnDragOver: true.
	self setToPopOutOnMouseOver: false.
! !


!FlapTab methodsFor: 'layout' stamp: 'ar 10/26/2000 17:36'!
layoutChanged
	self fitOnScreen.
	^super layoutChanged! !


!FlapTab methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:21'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add further items to the menu as appropriate"

	aMenu add: 'tab color...' translated target: self action: #changeColor.
	aMenu add: 'flap color...' translated target: self action: #changeFlapColor.
	aMenu addLine.
	aMenu addUpdating: #edgeString action: #setEdgeToAdhereTo.
	aMenu addLine.
	aMenu addUpdating: #textualTabString action: #textualTab.
	aMenu addUpdating: #graphicalTabString action: #graphicalTab.
	aMenu addUpdating: #solidTabString enablement: #notSolid action: #solidTab.
	aMenu addLine.

	(referent isKindOf: PasteUpMorph) ifTrue: 
		[aMenu addUpdating: #partsBinString action: #togglePartsBinMode].
	aMenu addUpdating: #dragoverString action: #toggleDragOverBehavior.
	aMenu addUpdating: #mouseoverString action: #toggleMouseOverBehavior.
	aMenu addLine.
	aMenu addUpdating: #isGlobalFlapString enablement: #sharedFlapsAllowed action: #toggleIsGlobalFlap.
	aMenu balloonTextForLastItem: 'If checked, this flap will be available in all morphic projects; if not, it will be private to this project.,' translated.

	aMenu addLine.
	aMenu add: 'destroy this flap' translated action: #destroyFlap.

	"aMenu addUpdating: #slideString action: #toggleSlideBehavior.
	aMenu addUpdating: #inboardString action: #toggleInboardness.
	aMenu addUpdating: #thicknessString ('thickness... (current: ', self thickness printString, ')') action: #setThickness."

! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/20/1999 23:41'!
applyThickness: newThickness
	| toUse |
	toUse _ newThickness asNumber max: 0.
	(self orientation == #vertical)
			ifTrue:
				[referent width: toUse]
			ifFalse:
				[referent height: toUse].
	self positionReferent. 
	self adjustPositionVisAVisFlap! !

!FlapTab methodsFor: 'menu' stamp: 'dgd 9/21/2003 17:55'!
changeColor
	self isCurrentlyGraphical
		ifTrue:
			[^ self inform: 'Color only pertains to a flap tab when the 
tab is textual or "solid".  This tab is
currently graphical, so color-choice
does not apply.' translated].
	super changeColor
	
! !

!FlapTab methodsFor: 'menu' stamp: 'dgd 9/21/2003 17:55'!
changeFlapColor
	(self flapShowing)
		ifTrue:
			[referent changeColor]
		ifFalse:
			[self inform: 'The flap itself needs to be open
before you can change its
color.' translated]! !

!FlapTab methodsFor: 'menu' stamp: 'yo 7/2/2004 17:58'!
changeTabText
	"Allow the user to change the text on the tab"

	| reply |
	reply _ FillInTheBlank
		request: 'new wording for this tab:' translated
		initialAnswer: self existingWording.
	reply isEmptyOrNil ifTrue: [^ self].
	self changeTabText: reply.
! !

!FlapTab methodsFor: 'menu' stamp: 'dgd 9/5/2003 18:25'!
destroyFlap
	"Destroy the receiver"

	| reply request |
	request _ self isGlobalFlap
		ifTrue:
			['Caution -- this would permanently
remove this flap, so it would no longer be
available in this or any other project.
Do you really want to this? ']
		ifFalse:
			['Caution -- this is permanent!!  Do
you really want to do this? '].
	reply _ self confirm: request translated orCancel: [^ self].
	reply ifTrue:
		[self isGlobalFlap
			ifTrue:
				[Flaps removeFlapTab: self keepInList: false.
				self currentWorld reformulateUpdatingMenus]
			ifFalse:
				[referent isInWorld ifTrue: [referent delete].
				self delete]]! !

!FlapTab methodsFor: 'menu' stamp: 'di 11/17/2001 20:17'!
existingWording
	^ labelString! !

!FlapTab methodsFor: 'menu' stamp: 'sw 7/8/1999 15:44'!
flapMenuTitle
	^ 'flap: ', self wording! !

!FlapTab methodsFor: 'menu' stamp: 'gm 2/22/2003 13:11'!
isCurrentlyTextual
	| first |
	^submorphs notEmpty and: 
			[((first := submorphs first) isKindOf: StringMorph) 
				or: [first isTextMorph]]! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/20/1999 19:17'!
preserveDetails
	"The receiver is being switched to use a different format.  Preserve the existing details (e.g. wording if textual, grapheme if graphical) so that if the user reverts back to the current format, the details will be right"

	| thickness |
	color = Color transparent ifFalse: [self setProperty: #priorColor toValue: color].
	self isCurrentlyTextual
		ifTrue:
			[self setProperty: #priorWording toValue: self existingWording]
		ifFalse:
			[self isCurrentlyGraphical
				ifTrue:
					[self setProperty: #priorGraphic toValue: submorphs first form]
				ifFalse:
					[thickness _ (self orientation == #vertical)
						ifTrue:	[self width]
						ifFalse:	[self height].
					self setProperty: #priorThickness toValue: thickness]]! !

!FlapTab methodsFor: 'menu' stamp: 'sw 4/24/2001 11:04'!
sharedFlapsAllowed
	"Answer (for the benefit of a menu item for which I am the target) whether the system presently allows shared flaps"

	^ Flaps sharedFlapsAllowed! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/14/1999 16:38'!
thicknessString
	^ 'thickness... (currently ', self thickness printString, ')'! !

!FlapTab methodsFor: 'menu' stamp: 'ar 12/18/2000 16:38'!
wording
	^ self isCurrentlyTextual
		ifTrue:
			[self existingWording]
		ifFalse:
			[self valueOfProperty: #priorWording ifAbsent: ['---']]! !


!FlapTab methodsFor: 'menus' stamp: 'nk 2/15/2004 08:19'!
addGestureMenuItems: aMenu hand: aHandMorph
	"If the receiver wishes the Genie menu items, add a line to the menu and then those Genie items, else do nothing"! !

!FlapTab methodsFor: 'menus' stamp: 'sw 6/19/1999 23:16'!
addTitleForHaloMenu: aMenu
	aMenu addTitle: self externalName updatingSelector: #flapMenuTitle updateTarget: self! !


!FlapTab methodsFor: 'misc' stamp: 'di 11/19/2001 12:19'!
fitContents
	self isCurrentlyTextual ifFalse: [^ super fitContents].
	self ifVertical:
		[self extent: submorphs first extent + (2 * self borderWidth) + (0@4).
		submorphs first position: self position + self borderWidth + (1@4)]
	ifHorizontal:
		[self extent: submorphs first extent + (2 * self borderWidth) + (8@-1).
		submorphs first position: self position + self borderWidth + (5@1)]! !


!FlapTab methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 18:43'!
balloonTextForFlapsMenu
	"Answer the balloon text to show on a menu item in the flaps menu that governs the visibility of the receiver in the current project"

	| id |
	id _ self flapID.
	#(
	('Squeak'		'Has a few generally-useful controls; it is also a place where you can "park" objects')
	('Tools'			'A quick way to get browsers, change sorters, file lists, etc.')
	('Widgets'		'A variety of controls and media tools')
	('Supplies' 		'A source for many basic types of objects')
	('Stack Tools' 	'Tools for building stacks.  Caution!!  Powerful but young and underdocumented')
	('Scripting'		'Tools useful when doing tile scripting')
	('Navigator'		'Project navigator:  includes controls for navigating through linked projects.  Also supports finding, loading and publishing projects in a shared environment')
	('Painting'		'A flap housing the paint palette.  Click on the closed tab to make make a new painting')) do:
		[:pair | (FlapTab givenID: id matches: pair first translated) ifTrue: [^ pair second translated]].

	^ self balloonText! !


!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 4/7/2000 07:52'!
arrangeToPopOutOnDragOver: aBoolean
	aBoolean
		ifTrue:
			[self on: #mouseEnterDragging send: #showFlapIfHandLaden: to: self.
			referent on: #mouseLeaveDragging send: #maybeHideFlapOnMouseLeaveDragging to: self.
			self on: #mouseLeaveDragging send: #maybeHideFlapOnMouseLeaveDragging to: self]
		ifFalse:
			[self on: #mouseEnterDragging send: nil to: nil.
			referent on: #mouseLeaveDragging send: nil to: nil.
			self on: #mouseLeaveDragging send: nil to: nil]! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 7/31/2002 00:53'!
arrangeToPopOutOnMouseOver: aBoolean
	aBoolean
		ifTrue:
			[self on: #mouseEnter send: #showFlap to: self.
			referent on: #mouseLeave send: #hideFlapUnlessBearingHalo to: self.
			self on: #mouseLeave send: #maybeHideFlapOnMouseLeave to: self]
		ifFalse:
			[self on: #mouseEnter send: nil to: nil.
			self on: #mouseLeave send: nil to: nil.
			referent on: #mouseLeave send: nil to: nil]! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'dgd 8/30/2003 21:32'!
dragoverString
	"Answer the string to be shown in a menu to represent the 
	dragover status"
	^ (popOutOnDragOver
		ifTrue: ['<yes>']
		ifFalse: ['<no>']), 'pop out on dragover' translated! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'ar 12/18/2000 01:14'!
makeNewDrawing: evt
	self flapShowing ifTrue:[
		self world makeNewDrawing: evt.
	] ifFalse:[
		self world assureNotPaintingEvent: evt.
	].! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'dgd 8/30/2003 21:36'!
mouseoverString
	"Answer the string to be shown in a menu to represent the  
	mouseover status"
	^ (popOutOnMouseOver
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'pop out on mouseover' translated ! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/25/1999 14:53'!
setToPopOutOnDragOver: aBoolean
	self arrangeToPopOutOnDragOver:  (popOutOnDragOver _ aBoolean)! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/25/1999 14:52'!
setToPopOutOnMouseOver: aBoolean
	self arrangeToPopOutOnMouseOver:  (popOutOnMouseOver _ aBoolean)! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'ar 2/8/2001 19:27'!
startOrFinishDrawing: evt
	| w |
	self flapShowing ifTrue:[
		(w _ self world) makeNewDrawing: evt at:  w center.
	] ifFalse:[
		self world endDrawing: evt.
	].! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/15/1999 14:10'!
toggleDragOverBehavior
	self arrangeToPopOutOnDragOver:  (popOutOnDragOver _ popOutOnDragOver not)! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/15/1999 14:07'!
toggleMouseOverBehavior
	self arrangeToPopOutOnMouseOver:  (popOutOnMouseOver _ popOutOnMouseOver not)! !


!FlapTab methodsFor: 'objects from disk' stamp: 'sw 5/4/2001 23:27'!
objectForDataStream: refStrm
	"I am about to be written on an object file.  If I am a global flap, write a proxy instead."

	| dp |
	self isGlobalFlap ifTrue:
		[dp _ DiskProxy global: #Flaps selector: #globalFlapTabOrDummy: 
					args: {self flapID}.
		refStrm replace: self with: dp.
		^ dp].

	^ super objectForDataStream: refStrm! !


!FlapTab methodsFor: 'parts bin' stamp: 'dgd 8/30/2003 21:31'!
partsBinString
	"Answer the string to be shown in a menu to represent the 
	parts-bin status"
	^ (referent isPartsBin
		ifTrue: ['<yes>']
		ifFalse: ['<no>']), 'parts-bin' translated! !

!FlapTab methodsFor: 'parts bin' stamp: 'sw 2/25/1999 13:17'!
togglePartsBinMode
	referent setPartsBinStatusTo: referent isPartsBin not! !


!FlapTab methodsFor: 'positioning' stamp: 'sw 2/16/1999 18:13'!
adjustPositionVisAVisFlap
	| sideToAlignTo opposite |
	opposite _ Utilities oppositeSideTo: edgeToAdhereTo.
	sideToAlignTo _ inboard
		ifTrue:	[opposite]
		ifFalse:	[edgeToAdhereTo].
	self perform: (Utilities simpleSetterFor: sideToAlignTo) with: (referent perform: opposite)! !

!FlapTab methodsFor: 'positioning' stamp: 'dgd 4/4/2006 16:12'!
fitOnScreen
	"19 sept 2000 - allow flaps in any paste up"
	| constrainer t l |
	constrainer _ (owner ifNil: [self]) clearArea.
	self flapShowing "otherwise no point in doing this"
		ifTrue:[self spanWorld].
	self orientation == #vertical ifTrue: [
		t _ ((self top min: (constrainer bottom- self height)) max: constrainer top).
		t = self top ifFalse: [self top: t].
	] ifFalse: [
		l _ ((self left min: (constrainer right - self width)) max: constrainer left).
		l = self left ifFalse: [self left: l].
	].
	self flapShowing ifFalse: [self positionObject: self atEdgeOf: constrainer].
! !

!FlapTab methodsFor: 'positioning' stamp: 'dgd 4/4/2006 16:08'!
positionObject: anObject
        "anObject could be myself or my referent"

"Could consider container _ referent pasteUpMorph, to allow flaps on things other than the world, but for the moment, let's skip it!!"

	"19 sept 2000 - going for all paste ups"

	| pum |
	pum _ self pasteUpMorph ifNil: [^ self].

	^self 
		positionObject: anObject 
		atEdgeOf: pum clearArea! !

!FlapTab methodsFor: 'positioning' stamp: 'RAA 6/14/2000 19:35'!
positionObject: anObject atEdgeOf: container
        "anObject could be myself or my referent"

        edgeToAdhereTo == #left ifTrue: [^ anObject left: container left].
        edgeToAdhereTo == #right ifTrue: [^ anObject right: container right].
        edgeToAdhereTo == #top ifTrue: [^ anObject top: container top].
        edgeToAdhereTo == #bottom ifTrue: [^ anObject bottom: container bottom]! !

!FlapTab methodsFor: 'positioning' stamp: 'sw 2/16/1999 17:58'!
positionReferent
	self positionObject: referent! !

!FlapTab methodsFor: 'positioning' stamp: 'dgd 4/4/2006 16:10'!
spanWorld
	| container area |
	
	container := self pasteUpMorph
				ifNil: [self currentWorld].

	area := container clearArea.

	self orientation == #vertical ifTrue: [
		referent vResizing == #rigid
			ifTrue: [referent height: area height].
		referent hResizing == #rigid
			ifTrue: [referent width: (referent width min: area width - self width)].
		referent top: area top.
		referent bottom: (area bottom min: referent bottom)
	]
	ifFalse: [
		referent hResizing == #rigid
			ifTrue: [referent width: area width].
		referent vResizing == #rigid
			ifTrue: [referent height: (referent height min: area height - self height)].
		referent left: area left.
		referent right: (area right min: referent right)
	].
! !

!FlapTab methodsFor: 'positioning' stamp: 'sw 2/11/1999 14:46'!
stickOntoReferent
	"Place the receiver directly onto the referent -- for use when the referent is being shown as a flap"
	| newPosition |
	referent addMorph: self.
	edgeToAdhereTo == #left
		ifTrue:
			[newPosition _ (referent width - self width) @ self top].
	edgeToAdhereTo == #right
		ifTrue:
			[newPosition _ (referent left @ self top)].
	edgeToAdhereTo == #top
		ifTrue:
			[newPosition _ self left @ (referent height - self height)].
	edgeToAdhereTo == #bottom
		ifTrue:
			[newPosition _ self left @ referent top].
	self position: newPosition! !

!FlapTab methodsFor: 'positioning' stamp: 'di 11/21/2001 16:02'!
transposeParts
	"The receiver's orientation has just been changed from vertical to horizontal or vice-versa."
	"First expand the flap to screen size, letting the submorphs lay out to fit,
	and then shrink the minor dimension back to the last row."

	self isCurrentlyTextual ifTrue:  "First recreate the tab with proper orientation"
		[self assumeString: self existingWording font: Preferences standardFlapFont
			orientation: self orientation color: self color].
	self orientation == #vertical
		ifTrue:	"changed from horizontal"
			[referent listDirection: #topToBottom; wrapDirection: #leftToRight.
			referent hasSubmorphs ifTrue:
				[referent extent: self currentWorld extent.
				referent fullBounds.  "Needed to trigger layout"
				referent width: (referent submorphs collect: [:m | m right]) max
									- referent left + self width]]
		ifFalse:
			[referent listDirection: #leftToRight; wrapDirection: #topToBottom.
			referent hasSubmorphs ifTrue:
				[referent extent: self currentWorld extent.
				referent fullBounds.  "Needed to trigger layout"
				referent height: (referent submorphs collect: [:m | m bottom]) max
									- referent top + self height]].
	referent hasSubmorphs ifFalse: [referent extent: 100@100].

	self spanWorld.
	flapShowing ifTrue: [self showFlap]! !


!FlapTab methodsFor: 'printing' stamp: 'sw 11/6/2000 15:41'!
printOn: aStream
	"Append a textual representation of the receiver to aStream"

	super printOn: aStream.
	aStream nextPutAll: ' "', self wording, '"'! !


!FlapTab methodsFor: 'rounding' stamp: 'di 11/20/2001 08:20'!
roundedCorners
	edgeToAdhereTo == #bottom ifTrue: [^ #(1 4)].
	edgeToAdhereTo == #right ifTrue: [^ #(1 2)].
	edgeToAdhereTo == #left ifTrue: [^ #(3 4)].
	^ #(2 3)  "#top and undefined"
! !

!FlapTab methodsFor: 'rounding' stamp: 'ar 12/22/2001 22:45'!
wantsRoundedCorners
	^self isCurrentlyTextual or:[super wantsRoundedCorners]! !


!FlapTab methodsFor: 'show & hide' stamp: 'sw 2/16/1999 17:58'!
adjustPositionAfterHidingFlap
	self positionObject: self! !

!FlapTab methodsFor: 'show & hide' stamp: 'tk 1/31/2001 12:27'!
hideFlap
	| aWorld |
	aWorld _ self world ifNil: [self currentWorld].
	referent privateDelete.
	aWorld removeAccommodationForFlap: self.
	flapShowing _ false.
	self isInWorld ifFalse: [aWorld addMorphFront: self].
	self adjustPositionAfterHidingFlap.
	aWorld haloMorphs do:
		[:m | m target isInWorld ifFalse: [m delete]]! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 12/29/1999 12:41'!
hideFlapUnlessBearingHalo
	self hasHalo ifFalse: [self hideFlapUnlessOverReferent]! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 11/24/2001 21:50'!
hideFlapUnlessOverReferent
	"Hide the flap unless the mouse is over my referent."

	| aWorld where |
	(referent isInWorld and: 
		[where _ self outermostWorldMorph activeHand lastEvent cursorPoint.
			referent bounds containsPoint: (referent globalPointToLocal: where)])
				ifTrue: [^ self].
	(aWorld _ self world) ifNil: [^ self].  "In case flap tabs just got hidden"
	self referent delete.
	aWorld removeAccommodationForFlap: self.
	flapShowing _ false.
	self isInWorld ifFalse:
		[self inboard ifTrue: [aWorld addMorphFront: self]].
	self adjustPositionAfterHidingFlap! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 2/12/2001 16:49'!
lastReferentThickness: anInteger
	"Set the last remembered referent thickness to the given integer"

	lastReferentThickness _ anInteger! !

!FlapTab methodsFor: 'show & hide' stamp: 'RAA 6/2/2000 14:07'!
maybeHideFlapOnMouseLeave
	self hasHalo ifTrue: [^ self].
	referent isInWorld ifFalse: [^ self].
	self hideFlapUnlessOverReferent.
! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 3/5/1999 17:42'!
maybeHideFlapOnMouseLeaveDragging
	| aWorld |
	self hasHalo ifTrue: [^ self].
	referent isInWorld ifFalse: [^ self].
	(dragged or: [referent bounds containsPoint: self cursorPoint])
		ifTrue:	[^ self].
	aWorld _ self world.
	referent privateDelete.  "could make me worldless if I'm inboard"
	aWorld ifNotNil: [aWorld removeAccommodationForFlap: self].
	flapShowing _ false.
	self isInWorld ifFalse: [aWorld addMorphFront: self].
	self adjustPositionAfterHidingFlap! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 2/12/2001 16:59'!
openFully
	"Make an educated guess at how wide or tall we are to be, and open to that thickness"

	| thickness amt |
	thickness _ referent boundingBoxOfSubmorphs extent max: (100 @ 100).
	self applyThickness: (amt _ self orientation == #horizontal
			ifTrue:
				[thickness y]
			ifFalse:
				[thickness x]).
	self lastReferentThickness: amt.
	self showFlap! !

!FlapTab methodsFor: 'show & hide' stamp: 'dgd 8/31/2004 16:25'!
showFlap
	"Open the flap up"

	| thicknessToUse flapOwner |

	"19 sept 2000 - going for all paste ups <- raa note"
	flapOwner _ self pasteUpMorph.
	self referentThickness <= 0
		ifTrue:
			[thicknessToUse _ lastReferentThickness ifNil: [100].
			self orientation == #horizontal
				ifTrue:
					[referent height: thicknessToUse]
				ifFalse:
					[referent width: thicknessToUse]].
	inboard ifTrue:
		[self stickOntoReferent].  "makes referent my owner, and positions me accordingly"
	referent pasteUpMorph == flapOwner
		ifFalse:
			[flapOwner accommodateFlap: self.  "Make room if needed"
			flapOwner addMorphFront: referent.
			flapOwner startSteppingSubmorphsOf: referent.
			self positionReferent.
			referent adaptToWorld: flapOwner].
	inboard  ifFalse:
		[self adjustPositionVisAVisFlap].
	flapShowing _ true.
	
	self pasteUpMorph hideFlapsOtherThan: self ifClingingTo: edgeToAdhereTo.

	flapOwner bringTopmostsToFront! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 4/7/2000 07:51'!
showFlapIfHandLaden: evt
	"The hand has drifted over the receiver with the button down.  If the hand is carrying anything, show the flap.  If the hand is empty, the likely cause is that it's manipulating a scrollbar or some such, so in that case don't pop the flap out."

	evt hand hasSubmorphs ifTrue: [self showFlap]! !


!FlapTab methodsFor: 'solid tabs' stamp: 'sw 2/27/1999 13:16'!
applyTabThickness: newThickness
	(self orientation == #vertical)
			ifTrue:
				[submorphs first width: newThickness asNumber]
			ifFalse:
				[submorphs first height: newThickness asNumber].
	self fitContents.
	self positionReferent. 
	self adjustPositionVisAVisFlap! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:40'!
changeTabSolidity
	"Presently no actual options associated with this menu item if the flap is currently alreadly solid, so entertain the user with an anuran sound.  However, in latest scheme, the corresponding menu item is disabled in this circumstance, so this method is effectively unreachable."

	self playSoundNamed: 'croak'! !

!FlapTab methodsFor: 'solid tabs' stamp: 'dgd 2/21/2003 22:39'!
changeTabThickness
	| newThickness |
	newThickness := FillInTheBlank request: 'New thickness:'
				initialAnswer: self tabThickness printString.
	newThickness notEmpty ifTrue: [self applyTabThickness: newThickness]! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:39'!
isCurrentlySolid
	"Don't never use double negatives"

	^ self notSolid not! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:36'!
notSolid
	"Answer whether the receiver is currenty not solid.  Used for determining whether the #solidTab menu item should be enabled"

	^ self isCurrentlyTextual or: [self isCurrentlyGraphical]! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/20/1999 21:34'!
solidTab
	self isCurrentlySolid
		ifFalse:
			[self useSolidTab]
		ifTrue:
			[self changeTabSolidity]! !

!FlapTab methodsFor: 'solid tabs' stamp: 'dgd 8/30/2003 21:31'!
solidTabString
	^ (self isCurrentlySolid
		ifTrue: ['currently using solid tab']
		ifFalse: ['use solid tab']) translated! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/20/1999 20:55'!
useSolidTab
	| thickness colorToUse |
	self preserveDetails.

	thickness _ self valueOfProperty: #priorThickness ifAbsent: [20].
	colorToUse _ self valueOfProperty: #priorColor ifAbsent: [Color red muchLighter].
	self color: colorToUse.
	self removeAllMorphs.
	
	(self orientation == #vertical)
		ifTrue:
			[self width: thickness.
			self height: self currentWorld height.
			self position: (self position x @ 0)]
		ifFalse:
			[self height: thickness.
			self width: self currentWorld width.
			self position: (0 @ self position y)].

	self borderWidth: 0.
	self layoutChanged.! !


!FlapTab methodsFor: 'submorphs-add/remove' stamp: 'rbb 2/18/2005 14:13'!
dismissViaHalo
	"Dismiss the receiver (and its referent), unless it resists"

	self resistsRemoval ifTrue:
		[(UIManager default chooseFrom: #( 'Yes' 'Um, no, let me reconsider') 
				title: 'Really throw this flap away?') = 2 ifFalse: [^ self]].

	referent delete.
	self delete! !


!FlapTab methodsFor: 'textual tabs' stamp: 'yo 7/16/2003 15:25'!
assumeString: aString font: aFont orientation: orientationSymbol color: aColor 
	| aTextMorph workString tabStyle |
	labelString := aString asString.
	workString := orientationSymbol == #vertical 
				ifTrue: 
					[String streamContents: 
							[:s | 
							labelString do: [:c | s nextPut: c] separatedBy: [s nextPut: Character cr]]]
				ifFalse: [labelString]. 
	tabStyle := (TextStyle new)
				leading: 0;
				newFontArray: (Array with: aFont).
	aTextMorph := (TextMorph new setTextStyle: tabStyle) 
				contents: (workString asText addAttribute: (TextKern kern: 3)).
	self removeAllMorphs.
	self
		borderWidth: 2;
		borderColor: #raised.
	aColor ifNotNil: [self color: aColor].
	self addMorph: aTextMorph centered.
	aTextMorph lock
	"
FlapTab allSubInstancesDo: [:ft | ft reformatTextualTab]
"! !

!FlapTab methodsFor: 'textual tabs' stamp: 'ar 9/3/2004 14:58'!
changeTabText: aString 

	| label |
	aString isEmptyOrNil ifTrue: [^ self].
	label _ Locale current languageEnvironment class flapTabTextFor: aString in: self.
	label isEmptyOrNil ifTrue: [^ self].
	self useStringTab: label.
	submorphs first delete.
	self assumeString: label
		font: Preferences standardFlapFont
		orientation: (Flaps orientationForEdge: self edgeToAdhereTo)
		color: nil.
! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 12/8/1999 18:16'!
reformatTextualTab
	"The font choice possibly having changed, reformulate the receiver"

	self isCurrentlyTextual ifFalse: [^ self].
	self assumeString: self existingWording font: Preferences standardFlapFont orientation: self orientation color: self color! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 6/17/1999 13:21'!
textualTab
	self isCurrentlyTextual
		ifTrue:
			[self changeTabText]
		ifFalse:
			[self useTextualTab]! !

!FlapTab methodsFor: 'textual tabs' stamp: 'dgd 8/30/2003 21:27'!
textualTabString
	^ (self isCurrentlyTextual
		ifTrue: ['change tab wording...']
		ifFalse: ['use textual tab']) translated! !

!FlapTab methodsFor: 'textual tabs' stamp: 'di 11/17/2001 20:22'!
useStringTab: aString
	| aLabel |
	labelString _ aString asString.
	aLabel _ StringMorph  new contents: labelString.
	self addMorph: aLabel.
	aLabel position: self position.
	aLabel highlightColor: self highlightColor; regularColor: self regularColor.
	aLabel lock.
	self fitContents.
	self layoutChanged! !

!FlapTab methodsFor: 'textual tabs' stamp: 'dgd 10/8/2003 19:03'!
useTextualTab
	| stringToUse colorToUse |
	self preserveDetails.
	colorToUse _ self valueOfProperty: #priorColor ifAbsent: [Color green muchLighter].
	submorphs notEmpty ifTrue: [self removeAllMorphs].
	stringToUse _ self valueOfProperty: #priorWording ifAbsent: ['Unnamed Flap' translated].
	self assumeString: stringToUse font:  Preferences standardFlapFont orientation: self orientation color: colorToUse! !


!FlapTab methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:29'!
permitsThumbnailing
	^ false! !


!FlapTab methodsFor: 'WiW support' stamp: 'RAA 10/3/2000 09:24'!
morphicLayerNumber
	^self flapShowing ifTrue: [26] ifFalse: [25] 	"As navigators"! !


!FlapTab methodsFor: '*eToys-e-toy support' stamp: 'sw 1/25/2000 11:07'!
isCandidateForAutomaticViewing
	^ false! !

!FlapTab methodsFor: '*eToys-e-toy support' stamp: 'sw 7/28/2001 01:31'!
succeededInRevealing: aPlayer
	"Try to reveal aPlayer, and answer whether we succeeded"

	(super succeededInRevealing: aPlayer) ifTrue: [^ true].
	self flapShowing ifTrue: [^ false].
	(referent succeededInRevealing: aPlayer)
		ifTrue:
			[self showFlap.
			aPlayer costume goHome; addHalo.
			^ true].
	^ false! !

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

FlapTab class
	instanceVariableNames: ''!

!FlapTab class methodsFor: 'as yet unclassified' stamp: 'di 11/19/2001 21:59'!
givenID: aFlapID matches: pureID
	"eg, FlapTab givenID: 'Stack Tools2' matches: 'Stack Tools' "

	^ aFlapID = pureID or:
		[(aFlapID beginsWith: pureID)
			and: [(aFlapID copyFrom: pureID size+1 to: aFlapID size)
					allSatisfy: [:c | c isDigit]]]! !


!FlapTab class methodsFor: 'new-morph participation' stamp: 'kfr 5/3/2000 12:51'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !


!FlapTab class methodsFor: 'printing' stamp: 'sw 2/11/1999 14:39'!
defaultNameStemForInstances
	^ 'flap tab'! !
Object subclass: #Flaps
	instanceVariableNames: ''
	classVariableNames: 'FlapsQuads SharedFlapTabs SharedFlapsAllowed'
	poolDictionaries: ''
	category: 'MorphicExtras-Flaps'!
!Flaps commentStamp: 'asm 3/13/2003 12:46' prior: 0!
ClassVariables

FlapsQuads               quads defining predefined flaps
			default flaps are: 'PlugIn Supplies', 'Stack Tools', 'Supplies', 'Tools', 'Widgets' and 'Scripting'

SharedFlapTabs          an  array of flaps shared between squeak projects
SharedFlapsAllowed     boolean

!


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

Flaps class
	instanceVariableNames: ''!

!Flaps class methodsFor: 'class initialization' stamp: 'nk 6/14/2004 08:37'!
initialize
	self initializeFlapsQuads! !


!Flaps class methodsFor: 'construction support' stamp: 'sw 5/4/2001 23:52'!
addMorph: aMorph asElementNumber: aNumber inGlobalFlapSatisfying: flapBlock
	"If any global flap satisfies flapBlock, add aMorph to it at the given position.  Applies to flaps that are parts bins and that like thumbnailing"

	| aFlapTab flapPasteUp |
	aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self].
	flapPasteUp _ aFlapTab referent.
	flapPasteUp addMorph: aMorph asElementNumber: aNumber.
	flapPasteUp replaceTallSubmorphsByThumbnails; setPartsBinStatusTo: true! !

!Flaps class methodsFor: 'construction support' stamp: 'sw 5/4/2001 23:52'!
addMorph: aMorph asElementNumber: aNumber inGlobalFlapWithID: anID
	"If any global flap satisfies flapBlock, add aMorph to it at the given position.  No senders in the image -- intended to be invoked by doits in code updates only, and applies to flaps that are parts bins and that like thumbnailing"

	^ self addMorph: aMorph asElementNumber: aNumber inGlobalFlapSatisfying: [:aFlap | aFlap flapID = anID]! !

!Flaps class methodsFor: 'construction support' stamp: 'sw 4/30/2001 18:57'!
addToSuppliesFlap: aMorph asElementNumber: aNumber
	"Add the given morph to the supplies flap.  To be called by doits in updates, so don't be alarmed by its lack of senders."

	self addMorph: aMorph asElementNumber: aNumber inGlobalFlapWithID: 'Supplies'! !

!Flaps class methodsFor: 'construction support' stamp: 'sw 5/5/2001 02:12'!
deleteMorphsSatisfying: deleteBlock fromGlobalFlapSatisfying: flapBlock
	"If any global flap satisfies flapBlock, then delete objects satisfying from deleteBlock from it.  Occasionally called from do-its in updates or other fileouts."

	| aFlapTab flapPasteUp |
	aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self].
	flapPasteUp _ aFlapTab referent.
	flapPasteUp submorphs do:
		[:aMorph | (deleteBlock value: aMorph) ifTrue: [aMorph delete]]! !

!Flaps class methodsFor: 'construction support' stamp: 'sw 7/5/2004 17:54'!
possiblyReplaceEToyFlaps
	"If in eToyFriendly mode, and if it's ok to reinitialize flaps, replace the existing flaps with up-too-date etoy flaps.  Caution:  this is destructive of existing flaps.  If preserving the contents of existing flaps is important, set the preference 'okToReinitializeFlaps' to true"

	PartsBin thumbnailForPartsDescription: StickyPadMorph descriptionForPartsBin.  "Puts StickyPadMorph's custom icon back in the cache which typically will have been called"
	(Preferences eToyFriendly and: [Preferences okToReinitializeFlaps]) ifTrue:
		[Flaps disableGlobalFlaps: false.
		Flaps addAndEnableEToyFlaps.
		Smalltalk isMorphic ifTrue: [ActiveWorld enableGlobalFlaps]].
	"PartsBin clearThumbnailCache"

"Flaps possiblyReplaceEToyFlaps"! !


!Flaps class methodsFor: 'flap mechanics' stamp: 'sw 2/16/1999 18:29'!
clobberFlapTabList
	"Flaps clobberFlapTabList"

	SharedFlapTabs _ nil! !

!Flaps class methodsFor: 'flap mechanics' stamp: 'sw 7/12/2001 22:01'!
freshFlapsStart
	"To be called manually only, as a drastic measure.  Delete all flap artifacts and establish fresh default global flaps
	Flaps freshFlapsStart
	"
	self currentWorld deleteAllFlapArtifacts.
	self clobberFlapTabList.
	self addStandardFlaps
! !

!Flaps class methodsFor: 'flap mechanics' stamp: 'dgd 10/7/2003 22:47'!
reinstateDefaultFlaps
	"Remove all existing 'standard' global flaps clear the global list, and and add fresh ones.  To be called by doits in updates etc.  This is a radical step, but it does *not* clobber non-standard global flaps or local flaps.  To get the effect of the *former* version of this method, call Flaps freshFlapsStart"

	"Flaps reinstateDefaultFlaps"
	self globalFlapTabsIfAny do:
		[:aFlapTab |
			({
				'Painting' translated.
				'Stack Tools' translated.
				'Squeak' translated.
				'Menu' translated.
				'Widgets' translated.
				'Tools' translated.
				'Supplies' translated.
				'Scripting' translated.
				'Objects' translated.
				'Navigator' translated
			  } includes: aFlapTab flapID) ifTrue:
				[self removeFlapTab: aFlapTab keepInList: false]].

	"The following reduces the risk that flaps will be created with variant IDs
		such as 'Stack Tools2', potentially causing some shared flap logic to fail."
		"Smalltalk garbageCollect."  "-- see if we are OK without this"

	self addStandardFlaps.
	"self disableGlobalFlapWithID: 'Scripting'.
	self disableGlobalFlapWithID: 'Objects'."
	self currentWorld addGlobalFlaps.
	self currentWorld reformulateUpdatingMenus.
! !

!Flaps class methodsFor: 'flap mechanics' stamp: 'sw 4/17/2001 14:47'!
removeFlapTab: aFlapTab keepInList: aBoolean
	"Remove the given flap tab from the screen, and, if aBoolean is true, also from the global list"

	(SharedFlapTabs ~~ nil and: [SharedFlapTabs includes: aFlapTab])
		ifTrue:
			[aBoolean ifFalse: [self removeFromGlobalFlapTabList: aFlapTab]].
	aFlapTab ifNotNil:
		[aFlapTab referent delete.
		aFlapTab delete]! !


!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:22'!
defaultsQuadsDefiningScriptingFlap
	"Answer a structure defining the default items in the Scripting flap.
	previously in quadsDeiningScriptingFlap"

	^ #(
	(TrashCanMorph			new						'Trash'				'A tool for discarding objects')	
	(ScriptingSystem 		scriptControlButtons 			'Status'				'Buttons to run, stop, or single-step scripts')
	(AllScriptsTool			allScriptsToolForActiveWorld	'All Scripts' 		'A tool that lets you control all the running scripts in your world')
	(ScriptingSystem		newScriptingSpace			'Scripting'			'A confined place for drawing and scripting, with its own private stop/step/go buttons.')

	(PaintInvokingMorph	new						'Paint'				'Drop this into an area to start making a fresh painting there')
	(ScriptableButton		authoringPrototype		'Button'			'A Scriptable button')
	(ScriptingSystem		prototypicalHolder 		'Holder'			'A place for storing alternative pictures in an animation, etc.')
	(RandomNumberTile		new		'Random'		'A tile that will produce a random number in a given range')
	(ScriptingSystem		anyButtonPressedTiles	'ButtonDown?'	'Tiles for querying whether the mouse button is down')
	(ScriptingSystem		noButtonPressedTiles		'ButtonUp?'		'Tiles for querying whether the mouse button is up')

	(SimpleSliderMorph		authoringPrototype		'Slider'			'A slider for showing and setting numeric values.')
	(JoystickMorph			authoringPrototype		'Joystick'		'A joystick-like control')
	(TextFieldMorph			exampleBackgroundField		'Scrolling Field'	'A scrolling data field which will have a different value on every card of the background')

	(PasteUpMorph			authoringPrototype		'Playfield'		'A place for assembling parts or for staging animations')


	(StackMorph 			authoringPrototype		'Stack' 			'A multi-card data base'	)
	(TextMorph				exampleBackgroundLabel	'Background Label' 'A piece of text that will occur on every card of the background')
	(TextMorph				exampleBackgroundField		'Background Field'	'A  data field which will have a different value on every card of the background')

		) asOrderedCollection! !

!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:22'!
defaultsQuadsDefiningStackToolsFlap
	"Answer a structure defining the items on the default system Stack Tools flap.
	previously in quadsDefiningStackToolsFlap"

	^ #(
	(StackMorph 			authoringPrototype		'Stack' 				'A multi-card data base'	)
	(StackMorph			stackHelpWindow		'Stack Help'			'Some hints about how to use Stacks')
	(TextMorph				authoringPrototype		'Simple Text'		'Text that you can edit into anything you wish')
	(TextMorph				fancyPrototype			'Fancy Text' 		'A text field with a rounded shadowed border, with a fancy font.')
	(ScrollableField			newStandAlone			'Scrolling Text'		'Holds any amount of text; has a scroll bar')
	(ScriptableButton		authoringPrototype		'Scriptable Button'	'A button whose script will be a method of the background Player')
	(StackMorph			previousCardButton 		'Previous Card' 		'A button that takes the user to the previous card in the stack')
	(StackMorph			nextCardButton			'Next Card'			'A button that takes the user to the next card in the stack')) asOrderedCollection
! !

!Flaps class methodsFor: 'flaps registry' stamp: 'nk 9/2/2004 15:49'!
defaultsQuadsDefiningSuppliesFlap
	"Answer a list of quads which define the objects to appear in the default Supplies flap.
	previously in quadsDefiningSuppliesFlap"

	^  #(
	(RectangleMorph 		authoringPrototype		'Rectangle' 		'A rectangle')
	(RectangleMorph		roundRectPrototype		'RoundRect'		'A rectangle with rounded corners')
	(EllipseMorph			authoringPrototype		'Ellipse'			'An ellipse or circle')
	(StarMorph				authoringPrototype		'Star'			'A star')
	(CurveMorph			authoringPrototype		'Curve'			'A curve')
	(PolygonMorph			authoringPrototype		'Polygon'		'A straight-sided figure with any number of sides')
	(TextMorph				boldAuthoringPrototype		'Text'			'Text that you can edit into anything you desire.')
	(ScriptingSystem		prototypicalHolder 		'Holder'			'A place for storing alternative pictures in an animation, etc.')
	(ImageMorph			authoringPrototype		'Picture'		'A non-editable picture of something')
	(ScriptableButton		authoringPrototype		'Button'			'A Scriptable button')
	(SimpleSliderMorph		authoringPrototype		'Slider'			'A slider for showing and setting numeric values.')
	(PasteUpMorph			authoringPrototype		'Playfield'		'A place for assembling parts or for staging animations')
	(BookMorph				authoringPrototype		'Book'			'A multi-paged structure')
	(TabbedPalette			authoringPrototype		'TabbedPalette'	'A structure with tabs')
	(JoystickMorph			authoringPrototype		'Joystick'		'A joystick-like control')
	(ClockMorph				authoringPrototype		'Clock'			'A simple digital clock')
	(BookMorph				previousPageButton 		'PreviousPage'	'A button that takes you to the previous page')
	(BookMorph				nextPageButton			'NextPage'		'A button that takes you to the next page')
		) asOrderedCollection! !

!Flaps class methodsFor: 'flaps registry' stamp: 'md 2/24/2006 15:20'!
defaultsQuadsDefiningToolsFlap
	"Answer a structure defining the default Tools flap.
	previously in quadsDefiningToolsFlap"

	^ OrderedCollection new
	addAll: #(
	(Browser 				prototypicalToolWindow		'Browser'			'A Browser is a tool that allows you to view all the code of all the classes in the system')
	(TranscriptStream		openMorphicTranscript				'Transcript'			'A Transcript is a window usable for logging and debugging; browse references to #Transcript for examples of how to write to it.')
	(Workspace			prototypicalToolWindow		'Workspace'			'A Workspace is a simple window for editing text.  You can later save the contents to a file if you desire.'));
		add: {   FileList2 .
				#prototypicalToolWindow.
				'File List'.
				'A File List is a tool for browsing folders and files on disks and FTP servers.' };
	addAll: #(
	(DualChangeSorter		prototypicalToolWindow		'Change Sorter'		'Shows two change sets side by side')
	(SelectorBrowser		prototypicalToolWindow		'Method Finder'		'A tool for discovering methods by providing sample values for arguments and results')
	(MessageNames		prototypicalToolWindow		'Message Names'		'A tool for finding, viewing, and editing all methods whose names contain a given character sequence.')
	(Preferences			preferencesControlPanel	'Preferences'			'Allows you to control numerous options')
	(Utilities				recentSubmissionsWindow	'Recent'				'A message browser that tracks the most recently-submitted methods')
	(ProcessBrowser		prototypicalToolWindow		'Processes'			'A Process Browser shows you all the running processes')
	(Preferences			annotationEditingWindow	'Annotations'		'Allows you to specify the annotations to be shown in the annotation panes of browsers, etc.')
	(Scamper				newOpenableMorph			'Scamper'			'A web browser')
	(Celeste				newOpenableMorph			'Celeste'				'Celeste -- an EMail reader')
	(PackagePaneBrowser	prototypicalToolWindow		'Packages'			'Package Browser:  like a System Browser, except that if has extra level of categorization in the top-left pane, such that class-categories are further organized into groups called "packages"')
	(ChangeSorter			prototypicalToolWindow		'Change Set'			'A tool that allows you to view and manipulate all the code changes in a single change set'));
		yourself! !

!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:21'!
defaultsQuadsDefiningWidgetsFlap
	"Answer a structure defining the default Widgets flap.
     previously in quadsDefiningWidgetsFlap"

	^ #(
	(TrashCanMorph			new						'Trash'				'A tool for discarding objects')
	(AllScriptsTool			allScriptsToolForActiveWorld	'All Scripts' 		'A tool that lets you see and control all the running scripts in your project')
	(PaintInvokingMorph	new						'Paint'				'Drop this into an area to start making a fresh painting there')
	(GeeMailMorph			new						'Gee-Mail'			'A place to present annotated content')
	(RecordingControlsMorph	authoringPrototype		'Sound'				'A device for making sound recordings.')
	(MPEGMoviePlayerMorph	authoringPrototype		'Movie Player'		'A Player for MPEG movies')
	(FrameRateMorph		authoringPrototype			'Frame Rate'		'An indicator of how fast your system is running')
	(MagnifierMorph		newRound					'Magnifier'			'A magnifying glass')
	(ScriptingSystem		newScriptingSpace			'Scripting'			'A confined place for drawing and scripting, with its own private stop/step/go buttons.')
	(ScriptingSystem		holderWithAlphabet			'Alphabet'			'A source for single-letter objects')
	(BouncingAtomsMorph	new						'Bouncing Atoms'	'Atoms, mate')
	(ObjectsTool				newStandAlone				'Object Catalog'		'A tool that lets you browse the catalog of objects')
	) asOrderedCollection! !

!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 10:58'!
initializeFlapsQuads
	"initialize the list of dynamic flaps quads.
	self initializeFlapsQuads"
	FlapsQuads _ nil. 
	self registeredFlapsQuads at: 'PlugIn Supplies' put: self defaultsQuadsDefiningPlugInSuppliesFlap;
		 at: 'Stack Tools' put: self defaultsQuadsDefiningStackToolsFlap;
		 at: 'Supplies' put: self defaultsQuadsDefiningSuppliesFlap;
		 at: 'Tools' put: self defaultsQuadsDefiningToolsFlap;
		 at: 'Widgets' put: self defaultsQuadsDefiningWidgetsFlap;
		 at: 'Scripting' put: self defaultsQuadsDefiningScriptingFlap.
	^ self registeredFlapsQuads! !

!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 09:55'!
registeredFlapsQuads
	"Answer the list of dynamic flaps quads"
	
	FlapsQuads ifNil: [FlapsQuads _ Dictionary new].
	^ FlapsQuads

" FlapsQuads _ nil. "! !

!Flaps class methodsFor: 'flaps registry' stamp: 'hpt 4/26/2004 16:46'!
registeredFlapsQuadsAt: aLabel
	"Answer the list of dynamic flaps quads at aLabel"

	^ (self registeredFlapsQuads at: aLabel)
		removeAllSuchThat: [:q | (self environment includesKey: q first) not or: [(self environment at: q first) isNil]]
! !

!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:09'!
registerQuad: aQuad forFlapNamed: aLabel
	"If any previous registration of the same label string is already known, delete the old one."

	"aQuad received must be an array of the form {TargetObject. #command label  'A Help String'} 

Flaps registerQuad: #(FileList2 openMorphicViewInWorld	'Enhanced File List'	'A nicer File List.')
	forFlapNamed: 'Tools' "

	self unregisterQuad: aQuad forFlapNamed: aLabel.
	(self registeredFlapsQuads at: aLabel) add: aQuad! !

!Flaps class methodsFor: 'flaps registry' stamp: 'ar 9/27/2005 22:10'!
unregisterQuadsWithReceiver: aReceiver 
	"delete all quads with receiver aReceiver."
	self registeredFlapsQuads
		do: [:assoc | assoc value
				removeAllSuchThat: [:q | (self environment at: (q first) ifAbsent:[nil]) = aReceiver ]]! !

!Flaps class methodsFor: 'flaps registry' stamp: 'asm 4/12/2003 14:16'!
unregisterQuadsWithReceiver: aReceiver fromFlapNamed: aLabel
	"delete all quads with receiver aReceiver."
	(self registeredFlapsQuads at: aLabel) removeAllSuchThat: [:q | q first = aReceiver name]! !

!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 10:34'!
unregisterQuad: aQuad forFlapNamed: aLabel 
	"If any previous registration at the same label string has the same receiver-command,
	delete the old one."
	(self registeredFlapsQuadsAt: aLabel)
		removeAllSuchThat: [:q | q first = aQuad first
				and: [q second = aQuad second]]! !


!Flaps class methodsFor: 'menu commands' stamp: 'mir 8/22/2001 18:55'!
disableGlobalFlaps
	"Clobber all the shared flaps structures.  First read the user her Miranda rights."

	self disableGlobalFlaps: true! !

!Flaps class methodsFor: 'menu commands' stamp: 'dgd 8/31/2003 19:01'!
disableGlobalFlaps: interactive
	"Clobber all the shared flaps structures.  First read the user her Miranda rights."

	interactive
		ifTrue: [(self confirm: 
'CAUTION!! This will destroy all the shared
flaps, so that they will not be present in 
*any* project.  If, later, you want them
back, you will have to reenable them, from
this same menu, whereupon the standard
default set of shared flaps will be created.
Do you really want to go ahead and clobber
all shared flaps at this time?' translated) ifFalse: [^ self]].

	self globalFlapTabsIfAny do:
		[:aFlapTab | self removeFlapTab: aFlapTab keepInList: false.
		aFlapTab isInWorld ifTrue: [self error: 'Flap problem' translated]].
	self clobberFlapTabList.
	SharedFlapsAllowed _ false.
	Smalltalk isMorphic ifTrue:
		[ActiveWorld restoreMorphicDisplay.
		ActiveWorld reformulateUpdatingMenus].

	"The following reduces the risk that flaps will be created with variant IDs
		such as 'Stack Tools2', potentially causing some shared flap logic to fail."
		"Smalltalk garbageCollect."  "-- see if we are OK without this"
! !

!Flaps class methodsFor: 'menu commands' stamp: 'sw 5/7/2001 13:15'!
disableGlobalFlapWithID: aFlapID
	"Mark this project as having the given flapID disabled"

	| disabledFlapIDs  aFlapTab currentProject |
	(currentProject _ Project current) assureFlapIntegrity.
	Smalltalk isMorphic ifFalse: [^ self].
	disabledFlapIDs _ currentProject parameterAt: #disabledGlobalFlapIDs.
	(aFlapTab _ self globalFlapTabWithID: aFlapID) ifNotNil:
		[aFlapTab hideFlap].
	(disabledFlapIDs includes: aFlapID)
		ifFalse:
			[disabledFlapIDs add: aFlapID].
	aFlapTab ifNotNil: [aFlapTab delete]

	! !

!Flaps class methodsFor: 'menu commands' stamp: 'sw 11/22/2001 08:31'!
enableDisableGlobalFlapWithID: aFlapID
	"Toggle the enable/disable status of the given global flap"

	| disabledFlapIDs  aFlapTab currentProject |
	(currentProject _ Project current) assureFlapIntegrity.
	Smalltalk isMorphic ifFalse: [^ self].
	disabledFlapIDs _ currentProject parameterAt: #disabledGlobalFlapIDs.
	(aFlapTab _ self globalFlapTabWithID: aFlapID) ifNotNil:
		[aFlapTab hideFlap].
	(disabledFlapIDs includes: aFlapID)
		ifTrue:
			[disabledFlapIDs remove: aFlapID.
			self currentWorld addGlobalFlaps]
		ifFalse:
			[disabledFlapIDs add: aFlapID.
			aFlapTab ifNotNil: [aFlapTab delete]].
	self doAutomaticLayoutOfFlapsIfAppropriate! !

!Flaps class methodsFor: 'menu commands' stamp: 'sw 5/7/2001 13:15'!
enableGlobalFlapWithID: aFlapID
	"Remove any memory of this flap being disabled in this project"

	| disabledFlapIDs  currentProject |
	(currentProject _ Project current) assureFlapIntegrity.
	Smalltalk isMorphic ifFalse: [^ self].
	disabledFlapIDs _ currentProject parameterAt: #disabledGlobalFlapIDs ifAbsent: [^ self].
	disabledFlapIDs remove: aFlapID ifAbsent: []
	! !

!Flaps class methodsFor: 'menu commands' stamp: 'sw 3/3/2004 15:49'!
explainFlaps
	"Open a window giving flap help."

	(StringHolder new contents: self explainFlapsText translated)
		openLabel: 'Flaps' translated

"Flaps explainFlaps"




	! !

!Flaps class methodsFor: 'menu commands' stamp: 'sw 3/3/2004 15:51'!
explainFlapsText
	"Answer the text, in English, to show in a help-window about Flaps."

	^'Flaps are like drawers on the edge of the screen, which can be opened so that you can use what is inside them, and closed when you do not need them.  They have many possible uses, a few of which are illustrated by the default set of flaps you can get as described below.

''Shared flaps'' are available in every morphic project.  As you move from project to project, you will see these same shared flaps in each, though there are also options, on a project-by-project basis, to choose which of the shared flaps should be shown, and also momentarily to suppress the showing of all shared flaps.   

To get started using flaps, bring up the desktop menu and choose ''flaps...'', and make the menu stay up by choosing ''keep this menu up''.  If you see, in this flaps menu,  a list of flap names such as ''Squeak'', ''Tools'', etc., it means that shared flaps are already set up in your image.  If you do not see the list, you will instead see a menu item that invites you to ''install default shared flaps''; choose that, and new flaps will be created, and the flaps menu will change to reflect their presence.

''Project flaps'' are flaps that belong to a single morphic project.  You will see them when you are in that project, but not when you are in any other morphic project.

If a flap is set up as a parts bin (such as the default Tools and Supplies flaps), you can use it to create new objects -- just open the flap, then find the object you want, and drag it out; when the cursor leaves the flap, the flap itself will snap closed, and you''ll be left holding the new object -- just click to place it exactly where you want it.

If a flap is *not* set up as a parts bin (such as the default ''Squeak'' flap at the left edge of the screen) you can park objects there (this is an easy way to move objects from project to project) and you can place your own private controls there, etc.  Everything in the default ''Squeak'' flap (and all the other default flaps, for that matter) is there only for illustrative purposes -- every user will want to fine-tune the flaps to suit his/her own style and needs.

Each flap may be set up to appear on mouseover, dragover, both, or neither.  See the menu items described below for more about these and other options.

You can open a closed flap by clicking on its tab, or by dragging the tab toward the center of the screen

You can close an open flap by clicking on its tab or by dragging the tab back off the edge of the screen.

Drag the tab of a flap to reposition the tab and to resize the flap itself.  Repositioning starts when you drag the cursor out of the original tab area.

If flaps or their tabs seem wrongly positioned or lost, try issuing a restoreDisplay from the screen menu.

The red-halo menu on a flap allows you to change the flap''s properties.   For greatest ease of use, request ''keep this menu up'' here -- that way, you can easily explore all the options in the menu.

tab color...				Lets you change the color of the flap''s tab.
flap color...				Lets you change the color of the flap itself.

use textual tab...		If the tab is not textual, makes it become textual.
change tab wording...	If the tab is already textual, allows you to edit
							its wording.

use graphical tab...		If the tab is not graphical, makes it become
							graphical.
choose tab graphic...	If the tab is already graphical, allows you
							to change the picture.

use solid tab...			If the tab is not solid, makes it become solid, i.e.
							appear as a solid band of color along the
							entire length or width of the screen.

parts-bin behavior		If set, then dragging an object from the flap
							tears off a new copy of the object.

dragover				If set, the flap opens on dragover and closes
							again on drag-leave.

mouseover				If set, the flap opens on mouseover and closes
							again on mouse-leave. 

cling to edge...			Governs which edge (left, right, top, bottom)
							the flap adheres to.

shared					If set, the same flap will be available in all projects; if not, the
							flap will will occur only in one project.

destroy this flap		Deletes the flap.

To define a new flap, use ''make a new flap'', found in the ''flaps'' menu.

To reinstate the default system flaps, you can use ''destroy all shared flaps'' from the ''flaps'' menu, and once they are destroyed, choose ''install default shared flaps''.

To add, delete, or edit things on a given flap, it is often wise first to suspend the flap''s mouse-over and drag-over sensitivity, so it won''t keep disappearing on you while you''re trying to work with it.

Besides the three standard flaps delivered with the default system, there are two other flaps readily available on demand from the ''flaps'' menu -- one is called ''Stack Tools'', which provides some tools useful for building stack-like content, the other is called ''Painting'', which provides a quick way to make a new painting.  Simply clicking on the appropriate checkbox in the ''flaps'' menu will toggle the corresponding flap between being visible and not being visible in the project.'! !


!Flaps class methodsFor: 'menu support' stamp: 'sw 4/24/2001 11:03'!
addIndividualGlobalFlapItemsTo: aMenu
	"Add items governing the enablement of specific global flaps to aMenu"

	|  anItem |
	self globalFlapTabsIfAny do:
		[:aFlapTab |
			anItem _ aMenu addUpdating: #globalFlapWithIDEnabledString: enablementSelector: #showSharedFlaps target: self selector: #enableDisableGlobalFlapWithID: argumentList: {aFlapTab flapID}.
			anItem wordingArgument: aFlapTab flapID.
			anItem setBalloonText: aFlapTab balloonTextForFlapsMenu].! !

!Flaps class methodsFor: 'menu support' stamp: 'sw 6/11/2002 14:05'!
enableEToyFlaps
	"Start using global flaps, plug-in version, given that they were not present."

	Cursor wait showWhile:
		[self addAndEnableEToyFlaps.
		self enableGlobalFlaps]! !

!Flaps class methodsFor: 'menu support' stamp: 'sw 11/22/2001 11:15'!
enableGlobalFlaps
	"Start using global flaps, given that they were not present."

	Cursor wait showWhile:
		[SharedFlapsAllowed _ true.
		self globalFlapTabs. "This will create them"
		Smalltalk isMorphic ifTrue:
			[ActiveWorld addGlobalFlaps.
			self doAutomaticLayoutOfFlapsIfAppropriate.
			FlapTab allInstancesDo:
				[:aTab | aTab computeEdgeFraction].
			ActiveWorld reformulateUpdatingMenus]]! !

!Flaps class methodsFor: 'menu support' stamp: 'sw 4/17/2001 13:50'!
globalFlapWithIDEnabledString: aFlapID
	"Answer the string to be shown in a menu to represent the status of the givne flap regarding whether it it should be shown in this project."

	| aFlapTab wording |
	aFlapTab _ self globalFlapTabWithID: aFlapID.
	wording _ aFlapTab ifNotNil: [aFlapTab wording] ifNil: ['(',  aFlapID, ')'].
	^ (Project current isFlapIDEnabled: aFlapID)
		ifTrue:
			['<on>', wording]
		ifFalse:
			['<off>', wording]! !

!Flaps class methodsFor: 'menu support' stamp: 'dgd 8/31/2003 19:39'!
setUpSuppliesFlapOnly
	"Set up the Supplies flap as the only shared flap.  A special version formulated for this stand-alone use is used, defined in #newLoneSuppliesFlap"

	| supplies |
	SharedFlapTabs isEmptyOrNil ifFalse:  "get rid of pre-existing guys if any"
		[SharedFlapTabs do:
			[:t | t referent delete.  t delete]].

	SharedFlapsAllowed _ true.
	SharedFlapTabs _ OrderedCollection new.
	SharedFlapTabs add: (supplies _ self newLoneSuppliesFlap).
	self enableGlobalFlapWithID: 'Supplies' translated.
	supplies setToPopOutOnMouseOver: false.

	Smalltalk isMorphic ifTrue:
		[ActiveWorld addGlobalFlaps.
		ActiveWorld reformulateUpdatingMenus]! !

!Flaps class methodsFor: 'menu support' stamp: 'dao 10/1/2004 12:59'!
showSharedFlaps
	"Answer whether shared flaps are currently showing.  Presumably it is in service of Alan's wishes to have flaps show sometimes on interior subprojects and sometomes on outer projects that Bob's CurrentProjectRefactoring is threaded into the logic here."

	^ Project current showSharedFlaps! !

!Flaps class methodsFor: 'menu support' stamp: 'dao 10/1/2004 13:12'!
suppressFlapsString
	"Answer the string to be shown in a menu to represent the suppress-flaps-in-this-project status"

	^ Project current suppressFlapsString! !


!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/22/2001 10:04'!
automaticFlapLayoutChanged
	"Sent when the automaticFlapLayout preference changes.  No senders in easily traceable in the image, but this is really sent by a Preference object!!"

	Preferences automaticFlapLayout ifTrue:
		[self positionNavigatorAndOtherFlapsAccordingToPreference]! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/22/2001 09:58'!
doAutomaticLayoutOfFlapsIfAppropriate
	"Do automatic layout of flaps if appropriate"

	Preferences automaticFlapLayout ifTrue:
		[self positionNavigatorAndOtherFlapsAccordingToPreference]! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 19:26'!
enableClassicNavigatorChanged
	"The #classicNavigatorEnabled preference has changed.   No senders in easily traceable in the image, but this is really sent by a Preference object!!"

	Preferences classicNavigatorEnabled
		ifTrue:
			[Flaps disableGlobalFlapWithID: 'Navigator' translated.
			Preferences enable: #showProjectNavigator.
			self disableGlobalFlapWithID: 'Navigator' translated.]
		ifFalse:
			[self enableGlobalFlapWithID: 'Navigator' translated.
			ActiveWorld addGlobalFlaps].

	self doAutomaticLayoutOfFlapsIfAppropriate.
	Project current assureNavigatorPresenceMatchesPreference.
	ActiveWorld reformulateUpdatingMenus! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'sd 1/16/2004 21:33'!
fileOutChanges
	"Bug workaround for squeak-flap 'fileOutChanges' buttons which for a while were mistakenly sending their requests here..."

	^ ChangeSet current verboseFileOut. ! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 19:28'!
makeNavigatorFlapResembleGoldenBar
	"At explicit request, make the flap-based navigator resemble the golden bar.  No senders in the image, but sendable from a doit"

	"Flaps makeNavigatorFlapResembleGoldenBar"

	Preferences setPreference: #classicNavigatorEnabled toValue: false.
	Preferences setPreference: #showProjectNavigator toValue: false.
	(self globalFlapTabWithID: 'Navigator' translated) ifNil:
		[SharedFlapTabs add: self newNavigatorFlap delete].
	self enableGlobalFlapWithID: 'Navigator' translated.
	Preferences setPreference: #navigatorOnLeftEdge toValue: true.
	(self globalFlapTabWithID: 'Navigator' translated) arrangeToPopOutOnMouseOver: true.
	ActiveWorld addGlobalFlaps.
	self doAutomaticLayoutOfFlapsIfAppropriate.
	Project current assureNavigatorPresenceMatchesPreference.
	! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 4/17/2001 13:24'!
orientationForEdge: anEdge
	"Answer the orientation -- #horizontal or #vertical -- that corresponds to the edge symbol"

	^ (#(left right) includes: anEdge)
		ifTrue:	[#vertical]
		ifFalse:	[#horizontal]! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 4/17/2001 13:24'!
paintFlapButton
	"Answer a button to serve as the paint flap"

	| pb oldArgs brush myButton m |
	pb _ PaintBoxMorph new submorphNamed: #paint:.
	pb
		ifNil:
			[(brush _ Form extent: 16@16 depth: 16) fillColor: Color red]
		ifNotNil:
			[oldArgs _ pb arguments.
			brush _ oldArgs third.
			brush _ brush copy: (2@0 extent: 42@38).
			brush _ brush scaledToSize: brush extent // 2].
	myButton _ BorderedMorph new.
	myButton color: (Color r: 0.833 g: 0.5 b: 0.0); borderWidth: 2; borderColor: #raised.
	myButton addMorph: (m _ brush asMorph lock).
	myButton extent: m extent + (myButton borderWidth + 6).
	m position: myButton center - (m extent // 2).
	^ myButton

! !

!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/6/2000 14:23'!
removeFromGlobalFlapTabList: aFlapTab
	"If the flap tab is in the global list, remove it"

	SharedFlapTabs remove: aFlapTab ifAbsent: []! !


!Flaps class methodsFor: 'new flap' stamp: 'dgd 8/31/2003 18:58'!
addLocalFlap
	"Menu command -- let the user add a new project-local flap.  Once the new flap is born, the user can tell it to become a shared flap.  Obtain an initial name and edge for the flap, launch the flap, and also launch a menu governing the flap, so that the user can get started right away with customizing it."

	| aMenu reply aFlapTab aWorld edge |
	aMenu _ MVCMenuMorph entitled: 'Where should the new flap cling?' translated.
	aMenu defaultTarget: aMenu.
	#(left right top bottom) do:
		[:sym | aMenu add: sym asString translated selector: #selectMVCItem: argument: sym].
	edge _ aMenu invokeAt: self currentHand position in: self currentWorld.

	edge ifNotNil:
		[reply _ FillInTheBlank request: 'Wording for this flap: ' translated initialAnswer: 'Flap' translated.
		reply isEmptyOrNil ifFalse:
			[aFlapTab _ self newFlapTitled: reply onEdge: edge.
			(aWorld _ self currentWorld) addMorphFront: aFlapTab.
			aFlapTab adaptToWorld: aWorld.
			aMenu _ aFlapTab buildHandleMenu: ActiveHand.
			aFlapTab addTitleForHaloMenu: aMenu.
			aFlapTab computeEdgeFraction.
			aMenu popUpEvent: ActiveEvent in: ActiveWorld]]
	
! !

!Flaps class methodsFor: 'new flap' stamp: 'sw 5/4/2001 23:59'!
defaultColorForFlapBackgrounds
	"Answer the color to use, by default, in new flap backgrounds"

	^ (Color blue mixed: 0.8 with: Color white) alpha: 0.6! !

!Flaps class methodsFor: 'new flap' stamp: 'sw 4/17/2001 13:24'!
newFlapTitled: aString onEdge: anEdge
	"Create a new flap with the given title and place it on the given edge"

	^ self newFlapTitled: aString onEdge: anEdge inPasteUp: self currentWorld
! !

!Flaps class methodsFor: 'new flap' stamp: 'di 11/19/2001 21:07'!
newFlapTitled: aString onEdge: anEdge inPasteUp: aPasteUpMorph
	"Add a flap with the given title, placing it on the given edge, in the given pasteup"

	| aFlapBody aFlapTab  |
	aFlapBody _ PasteUpMorph newSticky.
	aFlapTab _ FlapTab new referent: aFlapBody.
	aFlapTab setName: aString edge: anEdge color: (Color r: 0.516 g: 0.452 b: 1.0).

	anEdge == #left ifTrue:
		[aFlapTab position: (aPasteUpMorph left @ aPasteUpMorph top).
		aFlapBody extent: (200 @ aPasteUpMorph height)].
	anEdge == #right ifTrue:
		[aFlapTab position: ((aPasteUpMorph right - aFlapTab width) @ aPasteUpMorph top).
		aFlapBody extent: (200 @ aPasteUpMorph height)].
	anEdge == #top ifTrue:
		[aFlapTab position: ((aPasteUpMorph left + 50) @ aPasteUpMorph top).
		aFlapBody extent: (aPasteUpMorph width @ 200)].
	anEdge == #bottom ifTrue:
		[aFlapTab position: ((aPasteUpMorph left + 50) @ (aPasteUpMorph bottom - aFlapTab height)).
		aFlapBody extent: (aPasteUpMorph width @ 200)].

	aFlapBody beFlap: true.
	aFlapBody color: self defaultColorForFlapBackgrounds.

	^ aFlapTab! !


!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 4/3/2006 13:22'!
addAndEnableEToyFlaps
	"Initialize the standard default out-of-box set of global flaps.  This method creates them and places them in my class variable #SharedFlapTabs, but does not itself get them displayed."

	| aSuppliesFlap |
	SharedFlapTabs
		ifNotNil: [^ self].
	SharedFlapTabs _ OrderedCollection new.

	aSuppliesFlap _ self newSuppliesFlapFromQuads: self quadsDefiningPlugInSuppliesFlap positioning: #right.
	aSuppliesFlap referent setNameTo: 'Supplies Flap' translated.  "Per request from Kim Rose, 7/19/02"
	SharedFlapTabs add: aSuppliesFlap.  "The #center designation doesn't quite work at the moment"

	Preferences showProjectNavigator
		ifTrue:[ SharedFlapTabs add: self newNavigatorFlap ].

	self enableGlobalFlapWithID: 'Supplies' translated.

	Preferences showProjectNavigator
		ifTrue:[ self enableGlobalFlapWithID: 'Navigator' translated ].

	SharedFlapsAllowed _ true.
	Project current flapsSuppressed: false.
	^ SharedFlapTabs

"Flaps addAndEnableEToyFlaps"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 18:44'!
addNewDefaultSharedFlaps
	"Add the stack tools flap and the navigator flap to the global list, but do not have them showing initially.  Transitional, called by the postscript of the FlapsOnBottom update; probably dispensable afterwards."

	SharedFlapTabs ifNotNil:
		[(self globalFlapTabWithID: 'Stack Tools' translated) ifNil:
			[SharedFlapTabs add: self newStackToolsFlap delete].
		self enableGlobalFlapWithID: 'Stack Tools' translated.
		(self globalFlapTabWithID: 'Navigator' translated) ifNil:
			[SharedFlapTabs add: self newNavigatorFlap delete].
		self enableGlobalFlapWithID: 'Navigator' translated.
		self currentWorld addGlobalFlaps]! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 4/3/2006 13:21'!
addStandardFlaps
	"Initialize the standard default out-of-box set of global flaps. 
	This method creates them and places them in my class 
	variable #SharedFlapTabs, but does not itself get them 
	displayed. "
	SharedFlapTabs
		ifNil: [SharedFlapTabs := OrderedCollection new].
	SharedFlapTabs add: self newSqueakFlap.
	SharedFlapTabs add: self newSuppliesFlap.
	SharedFlapTabs add: self newToolsFlap.
	SharedFlapTabs add: self newWidgetsFlap.
	SharedFlapTabs add: self newStackToolsFlap.

	Preferences showProjectNavigator
		ifTrue:[SharedFlapTabs add: self newNavigatorFlap].

	SharedFlapTabs add: self newPaintingFlap.
	SharedFlapTabs add: self newObjectsFlap.
	self disableGlobalFlapWithID: 'Stack Tools' translated.
	self disableGlobalFlapWithID: 'Painting' translated.

	Preferences showProjectNavigator
		ifTrue:[self disableGlobalFlapWithID: 'Navigator' translated].

	^ SharedFlapTabs! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'nk 9/2/2004 15:49'!
defaultsQuadsDefiningPlugInSuppliesFlap
	"Answer a list of quads which define the objects to appear in the default Supplies flap used in the Plug-in image"

	^  #(
	(ObjectsTool				newStandAlone				'Object Catalog'		'A tool that lets you browse the catalog of available objects')
	(AllScriptsTool			allScriptsToolForActiveWorld	'All Scripts' 		'Stop, Step, and Go buttons for controlling all your scripts at once.  The tool can also be "opened up" to control each script in your project individually.')
	(TrashCanMorph			new						'Trash'				'A tool for discarding objects')
	(GrabPatchMorph		new						'Grab Patch'		'Allows you to create a new Sketch by grabbing a rectangular patch from the screen')
	(LassoPatchMorph		new						'Lasso'		'Allows you to create a new Sketch by lassoing an area from the screen')

	(StickyPadMorph		newStandAlone			'Sticky Pad'			'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.')
	"(PaintInvokingMorph	new						'Paint'				'Drop this into an area to start making a fresh painting there')"
	(TextMorph				boldAuthoringPrototype			'Text'				'Text that you can edit into anything you desire.')
	(RecordingControlsMorph	authoringPrototype		'Sound'				'A device for making sound recordings.')
	(RectangleMorph 		authoringPrototype		'Rectangle' 		'A rectangle')
	(RectangleMorph		roundRectPrototype		'RoundRect'		'A rectangle with rounded corners')
	(EllipseMorph			authoringPrototype		'Ellipse'			'An ellipse or circle')
	(StarMorph				authoringPrototype		'Star'			'A star')
	(CurveMorph			authoringPrototype		'Curve'			'A curve')
	(PolygonMorph			authoringPrototype		'Polygon'		'A straight-sided figure with any number of sides')
	(ScriptableButton		authoringPrototype		'Button'			'A Scriptable button')
	(BookMorph				nextPageButton			'NextPage'		'A button that takes you to the next page')
	(BookMorph				previousPageButton 		'PreviousPage'	'A button that takes you to the previous page')
	(ScriptingSystem		prototypicalHolder 		'Holder'			'A place for storing alternative pictures in an animation, etc.')
	(PasteUpMorph			authoringPrototype		'Playfield'		'A place for assembling parts or for staging animations')
	(SimpleSliderMorph		authoringPrototype		'Slider'			'A slider for showing and setting numeric values.')
	(JoystickMorph			authoringPrototype		'Joystick'		'A joystick-like control')
	(BookMorph				authoringPrototype		'Book'			'A multi-paged structure')
	(ClockMorph				authoringPrototype		'Clock'			'A simple digital clock')
	(RandomNumberTile		new					'Random'		'A random-number tile for use with tile scripting')) asOrderedCollection! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 8/12/2001 16:55'!
initializeStandardFlaps
	"Initialize the standard default out-of-box set of global flaps. This method creates them and places them in my class variable #SharedFlapTabs, but does not itself get them displayed."

	SharedFlapTabs _ nil.
	self addStandardFlaps! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:37'!
newLoneSuppliesFlap
	"Answer a fully-instantiated flap named 'Supplies' to be placed at the bottom of the screen, for use when it is the only flap shown upon web launch"

	|  aFlapTab aStrip leftEdge |  "Flaps setUpSuppliesFlapOnly"
	aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: Color red muchLighter from:	 #(

	(TrashCanMorph			new						'Trash'				'A tool for discarding objects')	
	(ScriptingSystem 		scriptControlButtons 			'Status'				'Buttons to run, stop, or single-step scripts')
	(AllScriptsTool			allScriptsToolForActiveWorld	'All Scripts' 		'A tool that lets you control all the running scripts in your world')

	(PaintInvokingMorph	new						'Paint'				'Drop this into an area to start making a fresh painting there')
	(RectangleMorph 		authoringPrototype		'Rectangle' 		'A rectangle'	)
	(RectangleMorph		roundRectPrototype		'RoundRect'		'A rectangle with rounded corners')
	(EllipseMorph			authoringPrototype		'Ellipse'			'An ellipse or circle')
	(StarMorph				authoringPrototype		'Star'			'A star')
	(CurveMorph			authoringPrototype		'Curve'			'A curve')
	(PolygonMorph			authoringPrototype		'Polygon'		'A straight-sided figure with any number of sides')
	(TextMorph				authoringPrototype		'Text'			'Text that you can edit into anything you desire.')
	(SimpleSliderMorph		authoringPrototype		'Slider'			'A slider for showing and setting numeric values.')
	(JoystickMorph			authoringPrototype		'Joystick'		'A joystick-like control')
	(ScriptingSystem		prototypicalHolder 		'Holder'			'A place for storing alternative pictures in an animation, ec.')
	(ScriptableButton		authoringPrototype		'Button'			'A Scriptable button')
	(PasteUpMorph			authoringPrototype		'Playfield'		'A place for assembling parts or for staging animations')
	(BookMorph				authoringPrototype		'Book'			'A multi-paged structure')
	(TabbedPalette			authoringPrototype		'Tabs'			'A structure with tabs')

	(RecordingControlsMorph authoringPrototype			'Sound'				'A device for making sound recordings.')
	(MagnifierMorph		newRound					'Magnifier'			'A magnifying glass')

	(ImageMorph			authoringPrototype		'Picture'		'A non-editable picture of something')
	(ClockMorph				authoringPrototype		'Clock'			'A simple digital clock')
	(BookMorph				previousPageButton 		'Previous'		'A button that takes you to the previous page')
	(BookMorph				nextPageButton			'Next'			'A button that takes you to the next page')
		).

	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Supplies' translated edge: #bottom color: Color red lighter.

	aStrip extent: self currentWorld width @ 78.
	leftEdge _ ((Display width - (16  + aFlapTab width)) + 556) // 2.

	aFlapTab position: (leftEdge @ (self currentWorld height - aFlapTab height)).

	aStrip beFlap: true.
	aStrip autoLineLayout: true.
	
	^ aFlapTab! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:03'!
newNavigatorFlap
	"Answer a newly-created flap which adheres to the bottom edge of the screen and which holds the project navigator controls. "

	|  aFlapTab navBar aFlap |
	navBar _ ProjectNavigationMorph preferredNavigator new.
	aFlap _ PasteUpMorph newSticky borderWidth: 0;
			extent: navBar extent + (0@20);
			color: (Color orange alpha: 0.8);
			beFlap: true;
			addMorph: navBar beSticky.
	aFlap hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	aFlap useRoundedCorners.
	aFlap setNameTo: 'Navigator Flap' translated.
	navBar fullBounds.  "to establish width"
	
	aFlapTab _ FlapTab new referent: aFlap.
	aFlapTab setName: 'Navigator' translated edge: #bottom color: Color orange.
	aFlapTab position: ((navBar width // 2) - (aFlapTab width // 2))
					@ (self currentWorld height - aFlapTab height).
	aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Navigator' translated "
! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'nk 9/3/2004 12:51'!
newObjectsFlap
	"Answer a fully-instantiated flap named 'Objects' to be placed at the top of the screen."

	|  aFlapTab anObjectsTool |
	anObjectsTool _ ObjectsTool new.
	anObjectsTool initializeForFlap.

	aFlapTab _ FlapTab new referent: anObjectsTool beSticky.
	aFlapTab setName: 'Objects' translated edge: #top color: Color red lighter.
	aFlapTab position: ((Display width - (aFlapTab width + 22)) @ 0).
	aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.

	anObjectsTool extent: self currentWorld width @ 200.
	anObjectsTool beFlap: true.
	anObjectsTool color: Color red muchLighter.
	anObjectsTool clipSubmorphs: true.

	anObjectsTool showCategories.

	^ aFlapTab! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:50'!
newPaintingFlap
	"Add a flap with the paint palette in it"

	| aFlap aFlapTab  |
	"Flaps reinstateDefaultFlaps. Flaps addPaintingFlap"

	aFlap _ PasteUpMorph new borderWidth: 0.
	aFlap color: Color transparent.
	aFlap layoutPolicy: TableLayout new.
	aFlap hResizing: #shrinkWrap.
	aFlap vResizing: #shrinkWrap.
	aFlap cellPositioning: #topLeft.
	aFlap clipSubmorphs: false.

	aFlap beSticky. "really?!!"
	aFlap addMorphFront: PaintBoxMorph new.
	aFlap setProperty: #flap toValue: true.
	aFlap fullBounds. "force layout"

	aFlapTab _ FlapTab new referent: aFlap.
	aFlapTab setNameTo: 'Painting' translated.
	aFlapTab setProperty: #priorWording toValue: 'Paint' translated.
	aFlapTab useGraphicalTab.
	aFlapTab removeAllMorphs.
	aFlapTab setProperty: #paintingFlap toValue: true.
	aFlapTab addMorphFront: 
		"(SketchMorph withForm: (ScriptingSystem formAtKey: #PaintingFlapPic))"
		self paintFlapButton.
	aFlapTab cornerStyle: #rounded.
	aFlapTab edgeToAdhereTo: #right.
	aFlapTab setToPopOutOnDragOver: false.
	aFlapTab setToPopOutOnMouseOver: false.
	aFlapTab on: #mouseUp send: #startOrFinishDrawing: to: aFlapTab.
	aFlapTab setBalloonText:'Click here to start or finish painting.' translated.

	aFlapTab fullBounds. "force layout"
	aFlapTab position: (0@6).
	self currentWorld addMorphFront: aFlapTab.  
	^ aFlapTab! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'nk 7/29/2004 10:12'!
newSqueakFlap
	"Answer a new default 'Squeak' flap for the left edge of the screen"

	| aFlap aFlapTab aButton aClock buttonColor anOffset bb aFont |
	aFlap _ PasteUpMorph newSticky borderWidth: 0.
	aFlapTab _ FlapTab new referent: aFlap.
	aFlapTab setName: 'Squeak' translated edge: #left color: Color brown lighter lighter.
	aFlapTab position: (0 @ ((Display height - aFlapTab height) // 2)).
	aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.

	aFlap cellInset: 14@14.
	aFlap beFlap: true.
	aFlap color: (Color brown muchLighter lighter "alpha: 0.3").
	aFlap extent: 150 @ self currentWorld height.
	aFlap layoutPolicy: TableLayout new.
	aFlap wrapCentering: #topLeft.
	aFlap layoutInset: 2.
	aFlap listDirection: #topToBottom.
	aFlap wrapDirection: #leftToRight.

	"self addProjectNavigationButtonsTo: aFlap."
	anOffset _ 16.

	aClock _ ClockMorph newSticky.
	aClock color: Color red.
	aClock showSeconds: false.
	aClock font: (TextStyle default fontAt: 3).
	aClock step.
	aClock setBalloonText: 'The time of day.  If you prefer to see seconds, check out my menu.' translated.
	aFlap addCenteredAtBottom: aClock offset: anOffset.

	buttonColor _  Color cyan muchLighter.
	bb _ SimpleButtonMorph new target: SmalltalkImage current.
	bb color: buttonColor.
	aButton _ bb copy.
	aButton actionSelector: #saveSession.
	aButton setBalloonText: 'Make a complete snapshot of the current state of the image onto disk.' translated.
	aButton label: 'save' translated font: (aFont _ ScriptingSystem fontForTiles).
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ bb copy target: Utilities.
	aButton actionSelector: #updateFromServer.
	aButton label: 'load code updates' translated font: aFont.
	aButton color: buttonColor.
	aButton setBalloonText: 'Check the Squeak server for any new code updates, and load any that are found.' translated.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ SimpleButtonMorph new target: SmalltalkImage current; actionSelector: #aboutThisSystem;
		label: 'about this system' translated font: aFont.
	aButton color: buttonColor.
	aButton setBalloonText: 'click here to find out version information' translated.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aFlap addCenteredAtBottom: (Preferences themeChoiceButtonOfColor: buttonColor font: aFont) offset: anOffset.

	aButton _ TrashCanMorph newSticky.
	aFlap addCenteredAtBottom: aButton offset: anOffset.
	aButton startStepping.

	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Squeak' translated "! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:39'!
newStackToolsFlap
	"Add a flap with stack tools in it"

	| aFlapTab aStrip |
	aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight
		andColor: (Color red muchLighter "alpha: 0.2") from: self quadsDefiningStackToolsFlap.

	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Stack Tools' translated edge: #bottom color: Color brown lighter lighter.
	aFlapTab position: ((Display width - (aFlapTab width + 226)) @ (self currentWorld height - aFlapTab height)).
	aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.

	aStrip extent: self currentWorld width @ 78.
	aStrip beFlap: true.
	aStrip autoLineLayout: true.
	aStrip extent: self currentWorld width @ 70.

	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Stack Tools' translated"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 6/11/2002 14:00'!
newSuppliesFlap
	"Answer a fully-instantiated flap named 'Supplies' to be placed at the bottom of the screen; this is for the non-plug-in-version"

	^ self newSuppliesFlapFromQuads: self quadsDefiningSuppliesFlap positioning: #right! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'mir 10/7/2005 16:32'!
newSuppliesFlapFromQuads: quads positioning: positionSymbol
	"Answer a fully-instantiated flap named 'Supplies' to be placed at the bottom of the screen.  Use #center as the positionSymbol to have it centered at the bottom of the screen, or #right to have it placed off near the right edge."

	|  aFlapTab aStrip hPosition |
	aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: Color red muchLighter from:	 quads.
	self twiddleSuppliesButtonsIn: aStrip.
	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Supplies' translated edge: #bottom color: Color red lighter.
	hPosition _ positionSymbol == #center
		ifTrue:
			[(Display width // 2) - (aFlapTab width // 2)]
		ifFalse:
			[Display width - (aFlapTab width + 22)].
	aFlapTab position: (hPosition @ (self currentWorld height - aFlapTab height)).
	aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.

	aStrip extent: self currentWorld width @ 136.
	aStrip beFlap: true.
	aStrip autoLineLayout: true.
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Supplies' translated"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:39'!
newToolsFlap
	"Answer a newly-created flap which adheres to the right edge of the screen and which holds prototypes of standard tools."

	|  aFlapTab aStrip |
	aStrip _ PartsBin newPartsBinWithOrientation: #topToBottom andColor: (Color orange muchLighter alpha: 0.8) from: self quadsDefiningToolsFlap.
 
	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Tools' translated edge: #right color: Color orange lighter.
	aFlapTab position: (self currentWorld width - aFlapTab width) @ ((Display height - aFlapTab height) // 2).
	aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.

	aStrip extent: (90 @ self currentWorld height).
	aStrip beFlap: true.
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Tools' translated "
! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:40'!
newWidgetsFlap
	"Answer a newly-created flap which adheres to the bottom edge of the screen and which holds prototypes of standard widgets. "

	|  aFlapTab aStrip |
	aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: (Color blue muchLighter alpha: 0.8)
		from:	 self quadsDefiningWidgetsFlap.

	aFlapTab _ FlapTab new referent: aStrip beSticky.
	aFlapTab setName: 'Widgets' translated edge: #bottom color: Color blue lighter lighter.
	aFlapTab position: ((Display width - (aFlapTab width + 122)) @ (self currentWorld height - aFlapTab height)).
	aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu.

	aStrip extent: self currentWorld width @ 78.
	aStrip beFlap: true.
	aStrip autoLineLayout: true.
	
	^ aFlapTab

"Flaps replaceGlobalFlapwithID: 'Widgets' translated "
! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 3/3/2004 13:38'!
quadsDefiningPlugInSuppliesFlap
	"Answer a list of quads which define the objects to appear in the default Supplies flap used in the Plug-in image"

	^ self registeredFlapsQuadsAt: 'PlugIn Supplies'! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:25'!
quadsDefiningStackToolsFlap
	"Answer a structure defining the items on the default system Stack Tools flap"

	^ self registeredFlapsQuadsAt: 'Stack Tools'

	"Flaps replaceGlobalFlapwithID: 'Stack Tools'"! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'!
quadsDefiningSuppliesFlap
	"Answer a list of quads which define the objects to appear in the default Supplies flap"

	^ self registeredFlapsQuadsAt: 'Supplies'! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:51'!
quadsDefiningToolsFlap
	"Answer a structure defining the default Tools flap"

	^ self registeredFlapsQuadsAt: 'Tools'! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'!
quadsDefiningWidgetsFlap
	"Answer a structure defining the default Widgets flap"

	^ self registeredFlapsQuadsAt: 'Widgets'! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'!
quadsDeiningScriptingFlap
	"Answer a structure defining the default items in the Scripting flap"

	^ self registeredFlapsQuadsAt: 'Scripting'! !

!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 4/3/2003 16:35'!
twiddleSuppliesButtonsIn: aStrip
	"Munge item(s) in the strip whose names as seen in the parts bin should be different from the names to be given to resulting torn-off instances"

	(aStrip submorphs detect: [:m | m target == StickyPadMorph] ifNone: [nil])
		ifNotNilDo:
			[:aButton | aButton arguments: {#newStandAlone.  'tear off'}]! !


!Flaps class methodsFor: 'replacement' stamp: 'sw 7/25/2004 00:56'!
replaceGlobalFlapwithID: flapID
	"If there is a global flap with flapID, replace it with an updated one."

	| replacement tabs |
	(tabs _ self globalFlapTabsWithID: flapID) size = 0 ifTrue: [^ self].
	tabs do: [:tab |
		self removeFlapTab: tab keepInList: false].
	flapID = 'Stack Tools' translated ifTrue: [replacement _ self newStackToolsFlap].
	flapID = 'Supplies' translated ifTrue: [replacement _ self newSuppliesFlapFromQuads: 
		(Preferences eToyFriendly
			ifFalse: [self quadsDefiningSuppliesFlap]
			ifTrue: [self quadsDefiningPlugInSuppliesFlap]) positioning: #right].
	flapID = 'Tools' translated ifTrue: [replacement _ self newToolsFlap].
	flapID = 'Widgets' translated ifTrue: [replacement _ self newWidgetsFlap].
	flapID = 'Navigator' translated ifTrue: [replacement _ self newNavigatorFlap].
	flapID = 'Squeak' translated ifTrue: [replacement _ self newSqueakFlap].
	replacement ifNil: [^ self].
	self addGlobalFlap: replacement.
	self currentWorld ifNotNil: [self currentWorld addGlobalFlaps]

"Flaps replaceFlapwithID: 'Widgets' translated "! !

!Flaps class methodsFor: 'replacement' stamp: 'sw 5/3/1999 22:44'!
replacePartSatisfying: elementBlock inGlobalFlapSatisfying: flapBlock with: replacement
	"If any global flap satisfies flapBlock, look in it for a part satisfying elementBlock; if such a part is found, replace it with the replacement morph, make sure the flap's layout is made right, etc."

	| aFlapTab flapPasteUp anElement |
	aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self].
	flapPasteUp _ aFlapTab referent.
	anElement _ flapPasteUp submorphs detect: [:aMorph | elementBlock value: aMorph] ifNone: [^ self].
	flapPasteUp replaceSubmorph: anElement by: replacement.
	flapPasteUp replaceTallSubmorphsByThumbnails; setPartsBinStatusTo: true.

"Flaps replacePartSatisfying: [:el |  (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented label = 'scripting area']]]
inGlobalFlapSatisfying: [:fl | (fl submorphs size > 0) and:  [(fl submorphs first isKindOf: TextMorph) and: [(fl submorphs first contents string copyWithout: Character cr) = 'Tools']]] with: ScriptingSystem newScriptingSpace"! !

!Flaps class methodsFor: 'replacement' stamp: 'sw 4/17/2001 13:15'!
replacePartSatisfying: elementBlock inGlobalFlapWithID: aFlapID with: replacement
	"If a global flapl exists with the given flapID, look in it for a part satisfying elementBlock; if such a part is found, replace it with the replacement morph, make sure the flap's layout is made right, etc."

	^ self replacePartSatisfying: elementBlock inGlobalFlapSatisfying: [:fl | fl flapID = aFlapID] with: replacement! !

!Flaps class methodsFor: 'replacement' stamp: 'dgd 8/31/2003 19:41'!
replaceToolsFlap
	"if there is a global tools flap, replace it with an updated one."

	self replaceGlobalFlapwithID: 'Tools' translated

"Flaps replaceToolsFlap"! !


!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/17/2001 13:31'!
addGlobalFlap: aFlapTab
	"Add the given flap tab to the list of shared flaps"

	SharedFlapTabs ifNil: [SharedFlapTabs _ OrderedCollection new].
	SharedFlapTabs add: aFlapTab! !

!Flaps class methodsFor: 'shared flaps' stamp: 'sw 7/24/2001 22:01'!
enableOnlyGlobalFlapsWithIDs: survivorList
	"In the current project, suppress all global flaps other than those with ids in the survivorList"

	self globalFlapTabsIfAny do: [:aFlapTab |
		(survivorList includes: aFlapTab flapID)
			ifTrue:
				[self enableGlobalFlapWithID: aFlapTab flapID]
			ifFalse:
				[self disableGlobalFlapWithID: aFlapTab flapID]].
	ActiveWorld addGlobalFlaps 

	"Flaps enableOnlyGlobalFlapsWithIDs: #('Supplies')"! !

!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/27/2001 16:36'!
globalFlapTabOrDummy: aName
	"Answer a global flap tab in the current image with the given name.  If none is found, answer a dummy StringMorph for some reason (check with tk about the use of this)"

	| gg |
	(gg _ self globalFlapTab: aName) ifNil:
		[^ StringMorph contents: aName, ' can''t be found'].
	^ gg! !

!Flaps class methodsFor: 'shared flaps' stamp: 'sw 5/5/2001 02:41'!
globalFlapTabs
	"Answer the list of shared flap tabs, creating it if necessary.  Much less aggressive is #globalFlapTabsIfAny"

	SharedFlapTabs ifNil: [self initializeStandardFlaps].
	^ SharedFlapTabs copy! !

!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/23/2001 18:04'!
globalFlapTabsIfAny
	"Answer a list of the global flap tabs, but it they don't exist, just answer an empty list"

	^ SharedFlapTabs copy ifNil: [Array new]! !

!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/8/2002 08:41'!
globalFlapTabsWithID: aFlapID
	"Answer all flap tabs whose ids start with the given id"

	^ self globalFlapTabsIfAny select:
		[:aFlapTab |
			(aFlapTab flapID = aFlapID) or: [FlapTab givenID: aFlapTab flapID matches: aFlapID]]

"Flaps globalFlapTabsWithID: 'Stack Tools'"! !

!Flaps class methodsFor: 'shared flaps' stamp: 'di 11/19/2001 22:07'!
globalFlapTabWithID: aFlapID
	"answer the global flap tab with the given id, or nil if none"

	^ self globalFlapTabsIfAny detect: [:aFlapTab | aFlapTab flapID = aFlapID]
		ifNone:
		["Second try allows sequence numbers"
		self globalFlapTabsIfAny detect: [:aFlapTab | FlapTab givenID: aFlapTab flapID matches: aFlapID]
			ifNone: [nil]]! !

!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/27/2001 16:34'!
globalFlapTab: aName
	"Answer the global flap tab in the current system whose flapID is the same as aName, or nil if none found."

	| idToMatch |
	idToMatch _ (aName beginsWith: 'flap: ')
		ifTrue:  "Ted's old scheme; this convention may still be found
				in pre-existing content that has been externalized"
			[aName copyFrom: 7 to: aName size]
		ifFalse:
			[aName].

	^ self globalFlapTabsIfAny detect: [:ft | ft flapID = idToMatch] ifNone: [nil]! !

!Flaps class methodsFor: 'shared flaps' stamp: 'dgd 8/31/2003 19:27'!
positionNavigatorAndOtherFlapsAccordingToPreference
	"Lay out flaps along the designated edge right-to-left, possibly positioning the navigator flap, exceptionally, on the left."

	| ids |
	ids _ Preferences navigatorOnLeftEdge ifTrue: [{'Navigator' translated}] ifFalse: [#()].

	Flaps positionVisibleFlapsRightToLeftOnEdge: #bottom butPlaceAtLeftFlapsWithIDs: ids

"Flaps positionNavigatorAndOtherFlapsAccordingToPreference"! !

!Flaps class methodsFor: 'shared flaps' stamp: 'dgd 8/31/2003 19:29'!
positionVisibleFlapsRightToLeftOnEdge: edgeSymbol butPlaceAtLeftFlapsWithIDs: idList
	"Lay out flaps along the designated edge right-to-left, while laying left-to-right any flaps found in the exception list

	Flaps positionVisibleFlapsRightToLeftOnEdge: #bottom butPlaceAtLeftFlapWithIDs: {'Navigator' translated. 'Supplies' translated}
	Flaps sharedFlapsAlongBottom"

	| leftX flapList flapsOnRight flapsOnLeft |
	flapList _ self globalFlapTabsIfAny select:
		[:aFlapTab | aFlapTab isInWorld and: [aFlapTab edgeToAdhereTo == edgeSymbol]].
	flapsOnLeft _ flapList select: [:fl | idList includes: fl flapID].
	flapList removeAll: flapsOnLeft.

	flapsOnRight _ flapList asSortedCollection:
		[:f1 :f2 | f1 left > f2 left].
	leftX _ ActiveWorld width - 15.

	flapsOnRight do:
		[:aFlapTab |
			aFlapTab right: leftX - 3.
			leftX _ aFlapTab left].

	leftX _ ActiveWorld left.
	flapsOnLeft _ flapsOnLeft asSortedCollection:
		[:f1 :f2 | f1 left > f2 left].
	flapsOnLeft do:
		[:aFlapTab |
			aFlapTab left: leftX + 3.
			leftX _ aFlapTab right].

	(flapsOnLeft asOrderedCollection, flapsOnRight asOrderedCollection) do:
		[:ft | ft computeEdgeFraction.
		ft flapID = 'Navigator' translated ifTrue:
			[ft referent left: (ft center x - (ft referent width//2) max: 0)]]
! !

!Flaps class methodsFor: 'shared flaps' stamp: 'mir 8/24/2001 20:42'!
removeDuplicateFlapTabs
	"Remove flaps that were accidentally added multiple times"
	"Flaps removeDuplicateFlapTabs"
	| tabs duplicates same |
	SharedFlapTabs copy ifNil: [^self].
	tabs _ SharedFlapTabs copy.
	duplicates _ Set new.
	tabs do: [:tab |
		same _ tabs select: [:each | each wording = tab wording].
		same isEmpty not
			ifTrue: [
				same removeFirst.
				duplicates addAll: same]].
	SharedFlapTabs removeAll: duplicates! !

!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/24/2001 11:17'!
sharedFlapsAllowed
	"Answer whether the shared flaps feature is allowed in this system"

	^ SharedFlapsAllowed ifNil: [SharedFlapsAllowed _ SharedFlapTabs isEmptyOrNil not]! !

!Flaps class methodsFor: 'shared flaps' stamp: 'dgd 10/7/2003 22:47'!
sharedFlapsAlongBottom
	"Put all shared flaps (except Painting which can't be moved) along the bottom"
	"Flaps sharedFlapsAlongBottom"

	| leftX unordered ordered |
	unordered _ self globalFlapTabsIfAny asIdentitySet.
	ordered _ Array streamContents:
		[:s | {
				'Squeak' translated.
				'Navigator' translated.
				'Supplies' translated.
				'Widgets' translated.
				'Stack Tools' translated.
				'Tools' translated.
				'Painting' translated.
			} do:
			[:id | (self globalFlapTabWithID: id) ifNotNilDo:
				[:ft | unordered remove: ft.
				id = 'Painting' translated ifFalse: [s nextPut: ft]]]].

	"Pace off in order from right to left, setting positions"
	leftX _ Display width-15.
	ordered , unordered asArray reverseDo:
		[:ft | ft setEdge: #bottom.
		ft right: leftX - 3.  leftX _ ft left].

	"Put Nav Bar centered under tab if possible"
	(self globalFlapTabWithID: 'Navigator' translated) ifNotNilDo:
		[:ft | ft referent left: (ft center x - (ft referent width//2) max: 0)].
	self positionNavigatorAndOtherFlapsAccordingToPreference.
! !
CompressedBoundaryShape subclass: #FlashBoundaryShape
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/9/1998 02:30'!
complexity
	^points size // 3! !


!FlashBoundaryShape methodsFor: 'disk i/o' stamp: 'nk 8/30/2004 07:49'!
compress
	(points isOctetString) ifFalse:[
		points := FlashCodec compress: self.
		leftFills := rightFills := lineWidths := lineFills := fillStyles := nil].! !

!FlashBoundaryShape methodsFor: 'disk i/o' stamp: 'nk 8/30/2004 07:49'!
decompress
	| newShape |
	(points isOctetString) ifTrue:[
		newShape := FlashCodec decompress: (ReadStream on: points).
		points := newShape points.
		leftFills := newShape leftFills.
		rightFills := newShape rightFills.
		lineWidths := newShape lineWidths.
		lineFills := newShape lineFills.
		fillStyles := newShape fillStyles].! !


!FlashBoundaryShape methodsFor: 'private' stamp: 'ar 11/3/1998 21:54'!
remapFills
	"Replace the fill style dictionary with an array"
	| indexMap newFillStyles index |
	(fillStyles isKindOf: Dictionary) ifFalse:[^false].
	indexMap := Dictionary new.
	indexMap at: 0 put: 0. "Map zero to zero"
	newFillStyles := Array new: fillStyles size.
	index := 1.
	fillStyles associationsDo:[:assoc|
		indexMap at: assoc key put: index.
		newFillStyles at: index put: assoc value.
		index := index + 1.
	].
	leftFills := leftFills valuesCollect:[:value| indexMap at: value ifAbsent:[0]].
	rightFills := rightFills valuesCollect:[:value| indexMap at: value ifAbsent:[0]].
	lineFills := lineFills valuesCollect:[:value| indexMap at: value ifAbsent:[0]].
	fillStyles := newFillStyles! !
FlashCharacterMorph subclass: #FlashButtonMorph
	instanceVariableNames: 'events sounds target'
	classVariableNames: 'ActionHelpText'
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashButtonMorph methodsFor: 'accessing' stamp: 'ar 10/15/1998 21:16'!
addSound: aSound forState: state
	sounds ifNil:[sounds := Dictionary new].
	sounds at: state put: aSound.! !

!FlashButtonMorph methodsFor: 'accessing' stamp: 'di 11/12/2000 15:59'!
ownerSprite
	"Return the sprite owning the receiver.
	The owning sprite is responsible for executing
	the actions associated with the button."
	^ self orOwnerSuchThat: [:sprite | sprite isFlashMorph and: [sprite isFlashSprite]]! !

!FlashButtonMorph methodsFor: 'accessing' stamp: 'ar 11/20/1998 02:03'!
trackAsMenu: aBoolean
	"Currently unused"
	aBoolean 
		ifTrue:[self setProperty: #trackAsMenu toValue: true]
		ifFalse:[self removeProperty: #trackAsMenu].! !


!FlashButtonMorph methodsFor: 'balloon help' stamp: 'ar 11/20/1998 15:15'!
analyzeActionsForBalloonHelp: actionList
	| helpText |
	actionList do:[:msg|
		helpText := ActionHelpText at: msg selector ifAbsent:[nil].
		helpText ifNotNil:[self setBalloonText: helpText].
	].
! !


!FlashButtonMorph methodsFor: 'classification' stamp: 'ar 11/16/1998 23:47'!
isFlashButton
	^true! !

!FlashButtonMorph methodsFor: 'classification' stamp: 'ar 11/19/1998 22:22'!
isMouseSensitive
	"Return true if the receiver is mouse sensitive and must stay unlocked"
	^true! !


!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/12/1999 15:47'!
executeActions: type
	| rcvr |
	(events isNil or:[events isEmpty]) ifTrue:[^self].
	rcvr := target.
	rcvr ifNil:[rcvr := self ownerSprite].
	rcvr isNil ifTrue:[^self].
	(events at: type ifAbsent:[^self]) do:[:action|
		action sentTo: rcvr.
	].! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/10/1999 04:16'!
executeSounds: type
	| sound |
	(sounds isNil or:[sounds isEmpty]) ifTrue:[^self].
	sound := sounds at: type ifAbsent:[^self].
	sound isPlaying & false ifFalse:[sound play].! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/16/1998 23:25'!
handlesMouseDown: evt
	^self visible! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/19/1998 20:32'!
handlesMouseOver: evt
	"Handle mouse events only if I am visible,"
	^self visible! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/16/1998 23:24'!
handlesMouseOverDragging: evt
	^false! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/10/1999 04:32'!
mouseDown: evt
	self lookEnable: #(pressLook) disable:#(overLook).
	self executeSounds: #mouseDown.
	self executeActions: #mouseDown.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/21/1998 02:30'!
mouseEnter: evt
	self lookEnable: #(overLook) disable:#(pressLook defaultLook).
	evt hand needsToBeDrawn ifFalse:[Cursor webLink show].
	self executeSounds: #mouseEnter.
	evt anyButtonPressed
		ifTrue:[self executeActions: #mouseEnterDown]
		ifFalse:[self executeActions: #mouseEnter].! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/21/1998 02:30'!
mouseLeave: evt
	self lookEnable: #(defaultLook) disable:#(pressLook overLook).
	evt hand needsToBeDrawn ifFalse:[Cursor normal show].
	self executeSounds: #mouseLeave.
	evt anyButtonPressed
		ifTrue:[self executeActions: #mouseLeaveDown]
		ifFalse:[self executeActions: #mouseLeave].! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 10/15/1998 21:08'!
mouseMove: evt! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/10/1999 04:33'!
mouseUp: evt
	self lookEnable:#(overLook) disable:#(pressLook).
	self executeSounds: #mouseUp.
	self executeActions: #mouseUp.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/12/1999 15:48'!
on: eventName send: action
	"Note: We handle more than the standard Morphic events here"
	^self on: eventName sendAll:(Array with: action).! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/20/1998 02:09'!
on: eventName sendAll: actions
	"Note: We handle more than the standard Morphic events here"
	| actionList |
	events ifNil:[events := Dictionary new].
	self analyzeActionsForBalloonHelp: actions.
	actionList := events at: eventName ifAbsent:[#()].
	actionList := actionList, actions.
	events at: eventName put: actionList.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/11/1999 03:52'!
simulateMouseDown
	"Invoked from a client --  simulate mouse down"
	self lookEnable: #(pressLook) disable:#(overLook).
	self executeSounds: #mouseDown.
	self executeActions: #mouseDown.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/11/1999 03:52'!
simulateMouseEnter
	"Invoked from a client -- simulate mouseEnter"
	self lookEnable: #(overLook) disable:#(pressLook defaultLook).
	self executeSounds: #mouseEnter.
	self executeActions: #mouseEnter.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/11/1999 03:53'!
simulateMouseLeave
	"Invoked from a client -- simulate mouse leave"
	self lookEnable: #(defaultLook) disable:#(pressLook overLook).
	self executeSounds: #mouseLeave.
	self executeActions: #mouseLeave.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/11/1999 03:53'!
simulateMouseUp
	"Invoked from a client -- simulate mouse up"
	self lookEnable:#(overLook) disable:#(pressLook).
	self executeSounds: #mouseUp.
	self executeActions: #mouseUp.! !


!FlashButtonMorph methodsFor: 'events-processing' stamp: 'ar 9/12/2000 23:05'!
handlerForMouseDown: anEvent
	"Don't give anybody over me a chance"
	^self! !


!FlashButtonMorph methodsFor: 'geometry' stamp: 'ar 11/16/1998 21:09'!
lookEnable: list1 disable: list2
	self changed.
	submorphs do:[:m|
		list2 do:[:sym|
			((m valueOfProperty: sym) ifNil:[false]) ifTrue:[m visible: false].
		].
		list1 do:[:sym|
			((m valueOfProperty: sym) ifNil:[false]) ifTrue:[m visible: true].
		].
	].
	self computeBounds.
	self changed.! !


!FlashButtonMorph methodsFor: 'geometry testing' stamp: 'ar 11/16/1998 21:46'!
containsPoint: aPoint
	| localPt |
	(self bounds containsPoint: aPoint) ifFalse:[^false].
	localPt := self transform globalPointToLocal: aPoint.
	submorphs do:[:m| 
		((m valueOfProperty: #sensitive) ifNil:[false]) ifTrue:[
			(m bounds containsPoint: localPt) ifTrue:[^true].
		].
	].
	^false! !


!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:04'!
defaultLook: aMorph
	"Assign the default look"
	aMorph setProperty: #defaultLook toValue: true.
	self addMorph: aMorph.! !

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:26'!
loadInitialFrame
	"Resort our children"
	super loadInitialFrame.
	submorphs := submorphs sortBy:[:m1 :m2| m1 depth > m2 depth].
	self lookEnable: #(defaultLook) disable:#(sensitive overLook pressLook)! !

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:25'!
overLook: aMorph
	"Assign the look if the mouse if over"
	aMorph setProperty: #overLook toValue: true.
	self addMorph: aMorph.! !

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:25'!
pressLook: aMorph
	"Assign the look if the mouse is pressed"
	aMorph setProperty: #pressLook toValue: true.
	self addMorph: aMorph.! !

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:04'!
sensitiveLook: aMorph
	"Assign the look for the sensitive area."
	aMorph setProperty: #sensitive toValue: true.
	self addMorph: aMorph! !


!FlashButtonMorph methodsFor: 'menu' stamp: 'ar 2/23/1999 00:37'!
addCustomAction
	| string code |
	string := FillInTheBlank request:'Enter the Smalltalk code to execute:' initialAnswer:'Smalltalk beep.'.
	string isEmpty ifTrue:[^self].
	string := '[', string,']'.
	code := Compiler evaluate: string for: self notifying: nil logged: false.
	self removeActions.
	target := code.
	self on: #mouseDown send:(Message selector: #value).! !

!FlashButtonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:41'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'set custom action' translated action: #addCustomAction.
	aCustomMenu add: 'remove all actions' translated action: #removeActions.
! !

!FlashButtonMorph methodsFor: 'menu' stamp: 'ar 2/23/1999 00:37'!
removeActions
	events := nil.
	target := nil.! !


!FlashButtonMorph methodsFor: 'printing' stamp: 'ar 11/21/1998 01:36'!
printOn: aStream
	super printOn: aStream.
	events ifNil:[^self].
	aStream nextPut:$[.
	events keys do:[:k| aStream print: k; space].
	aStream nextPut: $].! !

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

FlashButtonMorph class
	instanceVariableNames: ''!

!FlashButtonMorph class methodsFor: 'class initialization' stamp: 'ar 11/20/1998 22:58'!
initialize
	"FlashButtonMorph initialize"
	ActionHelpText := Dictionary new.
	#(	(getURL:window: 'Jump to URL')
		(gotoFrame: 'Continue playing')
		(gotoLabel: 'Continue playing')
		(gotoNextFrame 'Continue playing')
		(gotoPrevFrame 'Continue playing')
		(actionPlay 'Continue playing')
		(actionStop 'Stop playing')
		(stopSounds 'Stop all sounds')
		(toggleQuality 'Toggle display quality')
	) do:[:spec| ActionHelpText at: spec first put: spec last].! !
FlashMorph subclass: #FlashCharacterMorph
	instanceVariableNames: 'id stepTime frame renderTime vData mData dData cmData rData'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 11/13/1998 13:40'!
activationKeys
	"Return the keyframes on which the receiver morph becomes visible"
	^self visibleData keys select:[:key| self visibleAtFrame: key]! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 10/3/1998 21:39'!
depth
	^self depthAtFrame: frame! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 8/14/1998 18:19'!
id
	^id! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 8/14/1998 18:19'!
id: aNumber
	id := aNumber! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:32'!
isSpriteHolder
	^self hasProperty: #spriteHolder! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:32'!
isSpriteHolder: aBoolean
	aBoolean
		ifTrue:[self setProperty: #spriteHolder toValue: true]
		ifFalse:[self removeProperty: #spriteHolder]! !


!FlashCharacterMorph methodsFor: 'classification' stamp: 'ar 8/14/1998 21:52'!
isFlashCharacter
	^true! !


!FlashCharacterMorph methodsFor: 'copying' stamp: 'ar 5/19/1999 19:07'!
copyMovieFrom: firstFrame to: lastFrame
	| copy newFrame |
	copy := super copyMovieFrom: firstFrame to: lastFrame.
	copy reset.
	copy visible: false atFrame: 0.
	firstFrame to: lastFrame do:[:i|
		newFrame := i - firstFrame + 1.
		copy visible: (self visibleAtFrame: i) atFrame: newFrame.
		copy matrix: (self matrixAtFrame: i) atFrame: newFrame.
		copy depth: (self depthAtFrame: i) atFrame: newFrame.
		copy colorTransform: (self colorTransformAtFrame: i) atFrame: newFrame.
	].
	^copy! !


!FlashCharacterMorph methodsFor: 'drawing' stamp: 'ar 11/17/1998 17:52'!
fullDrawOn: canvas
	renderTime := Time millisecondsToRun:[super fullDrawOn: canvas].! !


!FlashCharacterMorph methodsFor: 'initialization' stamp: 'ar 9/3/1999 18:03'!
initialize
	super initialize.
	frame := 1.
	self reset.! !


!FlashCharacterMorph methodsFor: 'initialize' stamp: 'ar 9/1/1999 15:25'!
loadInitialFrame
	"Force the transformations taking place in the first frame."
	super loadInitialFrame.
	self stepToFrame: 1.
	(self isSpriteHolder and:[self visible]) ifTrue:[self activateSprites: true].! !

!FlashCharacterMorph methodsFor: 'initialize' stamp: 'ar 9/3/1999 18:02'!
reset
	self removeAllKeyFrameData.
	self matrix: MatrixTransform2x3 identity atFrame: 0.
	self visible: false atFrame: 0.
	self depth: 0 atFrame: 0.
	self ratio: 0.0 atFrame: 0.
	self visible: true.
! !


!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/24/1998 14:50'!
colorTransform: aColorTransform atFrame: frameNumber
	self colorTransformData at: frameNumber put: aColorTransform! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/24/1998 14:51'!
colorTransformAtFrame: frameNumber
	^self colorTransformData at: frameNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/24/1998 14:51'!
colorTransformData
	^cmData
	"^self keyframeData: #colorMatrixData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 8/14/1998 19:20'!
depth: aNumber atFrame: frameNumber
	self depthData at: frameNumber put: aNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 8/14/1998 19:20'!
depthAtFrame: frameNumber
	^self depthData at: frameNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:15'!
depthData
	^dData
	"^self keyframeData: #depthData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 17:11'!
matrix: aMatrixTransform atFrame: frameNumber
	"self position: aMatrixTransform offset atFrame: frameNumber."
	self matrixData at: frameNumber put: aMatrixTransform.! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 17:12'!
matrixAtFrame: frameNumber
	^(self matrixData at: frameNumber) "copy offset: (self positionAtFrame: frameNumber)"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:15'!
matrixData
	^mData
	"^self keyframeData: #matrixData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:20'!
ratio: aNumber atFrame: frameNumber
	^self ratioData at: frameNumber put: aNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:20'!
ratioAtFrame: frameNumber
	^self ratioData at: frameNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:24'!
ratioData
	^rData! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:20'!
removeAllKeyFrameData
	"Remove all of the keyframe data associated with this morph"
	self removeColorMatrixData.
	self removeDepthData.
	self removeMatrixData.
	self removeVisibleData.
	self removeRatioData.! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
removeColorMatrixData
	cmData := FlashKeyframes new.
	"^self removeKeyframeData: #colorMatrixData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
removeDepthData
	dData := FlashKeyframes new.
	"^self removeKeyframeData: #depthData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
removeMatrixData
	mData := FlashKeyframes new.
	"^self removeKeyframeData: #matrixData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:30'!
removeRatioData
	rData := FlashKeyframes new.! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
removeVisibleData
	vData := FlashKeyframes new.
	"^self removeKeyframeData: #visibilityData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 17:13'!
visible: aBool atFrame: frameNumber
	^self visibleData at: frameNumber put: aBool! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 8/14/1998 19:23'!
visibleAtFrame: frameNumber
	^self visibleData at: frameNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
visibleData
	^vData
	"^self keyframeData: #visibilityData"! !


!FlashCharacterMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:41'!
addCustomMenuItems: aMenu hand: aHand
	super addCustomMenuItems: aMenu hand: aHand.
	aMenu add:'add project target' translated action: #addProjectTarget.
	aMenu add:'remove project target' translated action: #removeProjectTarget.! !

!FlashCharacterMorph methodsFor: 'menu' stamp: 'ar 6/2/1999 04:18'!
addProjectTarget
	| player fill |
	player := self flashPlayer.
	player ifNil:[^self inform:'I must be in a flash player for this'].
	(submorphs size = 1 and:[submorphs first isFlashShape])
		ifFalse:[^self inform:'Cannot use me as a project target'].
	fill := submorphs first fillForProjectTarget.
	fill ifNil:[^self inform:'No suitable fill style found'].
	player addFillForProjectTarget: fill.! !

!FlashCharacterMorph methodsFor: 'menu' stamp: 'ar 6/2/1999 04:18'!
removeProjectTarget
	| player fill |
	player := self flashPlayer.
	player ifNil:[^self inform:'I must be in a flash player for this'].
	(submorphs size = 1 and:[submorphs first isFlashShape])
		ifFalse:[^self inform:'Cannot use me as a project target'].
	fill := submorphs first fillForProjectTarget.
	fill ifNil:[^self inform:'No suitable fill style found'].
	player removeFillForProjectTarget: fill.! !


!FlashCharacterMorph methodsFor: 'printing' stamp: 'ar 9/1/1999 15:19'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll:'(renderTime = '; print: renderTime;
		nextPutAll:'; depth = '; print: self depth;
		"nextPutAll:' complexity = '; print: self complexity * bounds area // 1000 / 1000.0;"
		"nextPutAll:' size = '; print: bounds area;"
	 nextPutAll:')'.! !


!FlashCharacterMorph methodsFor: 'stepping' stamp: 'ar 8/14/1998 18:18'!
stepTime: aNumber
	stepTime := aNumber! !

!FlashCharacterMorph methodsFor: 'stepping' stamp: 'ar 11/24/1998 14:52'!
stepToFrame: frameNumber
	| m wasVisible isVisible noTransform cm |
	wasVisible := self visible.
	self visible: (self visibleAtFrame: frameNumber).
	isVisible := self visible.
	frame := frameNumber.
	isVisible ifTrue:[
		m := self matrixAtFrame: frame.
		cm := self colorTransformAtFrame: frame.
		noTransform := (m = transform) and:[colorTransform = cm].
		(noTransform and:[isVisible = wasVisible]) ifTrue:[^self]. "No change"
		((noTransform not) and:[wasVisible]) ifTrue:[
			"Invalidate with old transform"
			self changed.
		].
		self transform: m.
		self colorTransform: cm.
		((noTransform not) and:[isVisible]) ifTrue:[
			"Invalidate with new transform"
			self changed.
		].
		((noTransform) and:[isVisible ~~ wasVisible]) ifTrue:[
			"Invalidate with new transform"
			self changed.
		].
	] ifFalse:[
		wasVisible ifTrue:[self changed].
	].
	(isVisible ~~ wasVisible and:[self isSpriteHolder])
		ifTrue:[self activateSprites: isVisible].! !

!FlashCharacterMorph methodsFor: 'stepping' stamp: 'ar 8/14/1998 21:03'!
stepToNextFrame
	self stepToFrame: frame + 1.! !


!FlashCharacterMorph methodsFor: 'testing' stamp: 'ar 8/14/1998 18:17'!
stepTime
	^stepTime ifNil:[super stepTime]! !

!FlashCharacterMorph methodsFor: 'testing' stamp: 'ar 11/13/1998 14:02'!
wantsSteps
	^false
	"^stepTime notNil"! !


!FlashCharacterMorph methodsFor: 'private' stamp: 'ar 11/24/1998 14:34'!
activateSprites: aBool
	submorphs do:[:m|
		(m isFlashMorph and:[m isFlashSprite]) ifTrue:[
			aBool 
				ifTrue:[m startPlaying]
				ifFalse:[m stopPlaying].
		].
	].! !

!FlashCharacterMorph methodsFor: 'private' stamp: 'ar 5/19/1999 18:58'!
isVisibleBetween: firstFrame and: lastFrame
	firstFrame to: lastFrame do:[:frameNr| 
		(self visibleAtFrame: frameNr) ifTrue:[^true]].
	^false! !

!FlashCharacterMorph methodsFor: 'private' stamp: 'ar 8/14/1998 20:03'!
keyframeData: aSymbol
	| data |
	data := self valueOfProperty: aSymbol.
	data isNil ifFalse:[^data].
	data := FlashKeyframes new.
	self setProperty: aSymbol toValue: data.
	^data! !

!FlashCharacterMorph methodsFor: 'private' stamp: 'ar 9/20/1998 23:41'!
removeKeyframeData: aSymbol
	self removeProperty: aSymbol.! !
Object subclass: #FlashCodec
	instanceVariableNames: 'stream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashCodec methodsFor: 'accessing'!
compress: aShape

	self compressPoints: aShape points.
	self compressRunArray: aShape leftFills.
	self compressRunArray: aShape rightFills.
	self compressRunArray: aShape lineWidths.
	self compressRunArray: aShape lineFills.
	self compressFills: aShape fillStyles.
	^stream contents! !

!FlashCodec methodsFor: 'accessing'!
contents
	^stream contents! !

!FlashCodec methodsFor: 'accessing'!
decompress
	| points leftFills rightFills lineWidths lineFills fillStyles |
	points := self decompressPoints.
	leftFills := self decompressRunArray.
	rightFills := self decompressRunArray.
	lineWidths := self decompressRunArray.
	lineFills := self decompressRunArray.
	fillStyles := self decompressFills.
	^FlashBoundaryShape points: points leftFills: leftFills rightFills: rightFills fillStyles: fillStyles lineWidths: lineWidths lineFills: lineFills! !


!FlashCodec methodsFor: 'compressing fills'!
compressFillStyle: aFillStyle
	aFillStyle isSolidFill ifTrue:[^self compressSolidFill: aFillStyle].
	aFillStyle isGradientFill ifTrue:[^self compressGradientFill: aFillStyle].
	aFillStyle isBitmapFill ifTrue:[^self compressBitmapFill: aFillStyle].
	self error:'Unknown fill style'! !

!FlashCodec methodsFor: 'compressing fills'!
compressFills: anArray
	stream print: anArray size.
	anArray do:[:fillStyle| self compressFillStyle: fillStyle].
	stream nextPut:$X. "Terminator"! !

!FlashCodec methodsFor: 'compressing fills'!
compressGradientFill: aFillStyle
	"Note: No terminators for simple colors"
	| ramp key |
	aFillStyle radial
		ifTrue:[stream nextPut: $R] " 'R'adial gradient"
		ifFalse:[stream nextPut: $L]. " 'L' inear gradient"
	self printPoint: aFillStyle origin on: stream.
	self printPoint: aFillStyle direction on: stream.
	self printPoint: aFillStyle normal on: stream.
	ramp := aFillStyle colorRamp.
	stream nextPut: $+; print: ramp size.
	ramp do:[:assoc|
		key := (assoc key * 255) truncated.
		stream nextPut: (Character value: key).
		self storeColor: assoc value on: stream].
	stream nextPut:$X. "Terminator"! !

!FlashCodec methodsFor: 'compressing fills'!
compressSolidFill: aFillStyle
	"Note: No terminators for simple colors"
	stream nextPut: $S. " 'S'olid fill"
	self storeColor: aFillStyle asColor on: stream.! !

!FlashCodec methodsFor: 'compressing fills'!
decompressFillStyle
	| type |
	type := stream next.
	type = $S ifTrue:[^self decompressSolidFill].
	type = $R ifTrue:[^self decompressGradientFill: true].
	type = $L ifTrue:[^self decompressGradientFill: false].
	type = $B ifTrue:[^self decompressBitmapFill].
	^self error:'Unknown fill type'! !

!FlashCodec methodsFor: 'compressing fills'!
decompressFills
	| fills n |
	n := Integer readFrom: stream.
	fills := Array new: n.
	1 to: n do:[:i|
		fills at: i put: self decompressFillStyle.
	].
	stream next = $X ifFalse:[^self error:'Compression problem'].
	^fills! !

!FlashCodec methodsFor: 'compressing fills' stamp: 'mir 3/2/2000 13:21'!
decompressGradientFill: radial
	"Note: No terminators for simple colors"
	| ramp fs rampSize rampIndex rampColor |
	fs := GradientFillStyle new.
	fs radial: radial.
	fs origin: (self readPointFrom: stream).
	fs direction: (self readPointFrom: stream).
	fs normal: (self readPointFrom: stream).
	stream next = $+ ifFalse:[self error:'Negative Array size'].
	rampSize := Integer readFrom: stream.
	ramp := Array new: rampSize.
	1 to: rampSize do:[:i|
		rampIndex := stream next asciiValue / 255.0.
		rampColor := self readColorFrom: stream.
		ramp at: i put: (rampIndex -> rampColor)].
	fs colorRamp: ramp.
	fs pixelRamp. "Force computation"
	stream next = $X ifFalse:[^self error:'Compressio problem'].
	^fs! !

!FlashCodec methodsFor: 'compressing fills'!
decompressSolidFill
	| color |
	color := self readColorFrom: stream.
	^SolidFillStyle color: color! !

!FlashCodec methodsFor: 'compressing fills' stamp: 'ar 7/20/1999 16:05'!
readColorFrom: aStream
	| pv |
	pv := stream next asciiValue +
			(stream next asciiValue bitShift: 8) +
				(stream next asciiValue bitShift: 16) +
					(stream next asciiValue bitShift: 24).
	^Color colorFromPixelValue: pv depth: 32! !

!FlashCodec methodsFor: 'compressing fills' stamp: 'mir 1/17/2000 15:12'!
storeColor: color on: aStream
	| pv |
	pv := color pixelWordForDepth: 32.
	aStream 
		nextPut: (pv digitAt: 1) asCharacter;
		nextPut: (pv digitAt: 2) asCharacter;
		nextPut: (pv digitAt: 3) asCharacter;
		nextPut: (pv digitAt: 4) asCharacter.

! !


!FlashCodec methodsFor: 'compressing points'!
compressPoints: points
	"Compress the points using delta values and RLE compression."
	| lastPt runLength runValue nextPt deltaPt |
	points class == ShortPointArray 
		ifTrue:[stream print: points size]
		ifFalse:[points class == PointArray 
					ifTrue:[stream print: points size negated]
					ifFalse:[self error:'The point array has the wrong type!!']].
	points size = 0 ifTrue:[^self].
	lastPt := points at: 1.
	"First point has no delta"
	self printCompressedPoint: lastPt on: stream runLength: 1.
	runLength := 0.
	runValue := nil.
	2 to: points size do:[:i|
		nextPt := points at: i.
		deltaPt := nextPt - lastPt.
		runValue = deltaPt ifTrue:[
			runLength := runLength + 1.
		]ifFalse:[
			self printCompressedPoint: runValue on: stream runLength: runLength.
			runValue := deltaPt.
			runLength := 1.
		].
		lastPt := nextPt].
	runLength > 0 ifTrue:[self printCompressedPoint: runValue on: stream runLength: runLength].
	stream nextPut:$X."Terminating character"
	^stream! !

!FlashCodec methodsFor: 'compressing points'!
decompressPoints
	"Decompress the points using delta values and RLE compression."
	| pts n index runValue spl runLength c x y |
	n := Integer readFrom: stream.
	n = 0 ifTrue:[^ShortPointArray new].
	n < 0
		ifTrue:[	n := 0 - n.
				pts := PointArray new: n]
		ifFalse:[pts := ShortPointArray new: n].
	index := 0.
	runValue := 0@0.
	"Prefetch special character"
	spl := stream next.
	[index < n] whileTrue:[
		"Read runLength/value"
		spl = $* ifTrue:[
			"Run length follows"
			runLength := 0.
			[(c := stream next) isDigit] 
				whileTrue:[runLength := (runLength * 10) + c digitValue].
			spl := c.
		] ifFalse:[runLength := 1].
		"Check for special zero point"
		(spl = $Z or:[spl = $A]) ifTrue:[
			"Since deltaPt is 0@0 there is no need to update runValue.
			Just prefetch the next special character"
			spl = $A ifTrue:[runLength := 2].
			spl := stream next.
		] ifFalse:["Regular point"
			"Fetch absolute delta x value"
			x := 0.
			[(c := stream next) isDigit] 
				whileTrue:[x := (x * 10) + c digitValue].
			"Sign correct x"
			spl = $- 
				ifTrue:[x := 0 - x]
				ifFalse:[spl = $+ ifFalse:[self error:'Bad special character']].
			spl := c.
			"Fetch absolute delta y value"
			y := 0.
			[(c := stream next) isDigit] 
				whileTrue:[y := (y * 10) + c digitValue].
			"Sign correct y"
			spl = $-
				ifTrue:[y := 0 - y]
				ifFalse:[spl = $+ ifFalse:[self error:'Bad special character']].
			spl := c.
			"Compute absolute run value"
			runValue := runValue + (x@y).
		].
		"And store points"
		1 to: runLength
			do:[:i| pts at: (index := index + 1) put: runValue].
	].
	"Last char must be X"
	spl = $X ifFalse:[self error:'Bad special character'].
	^pts! !

!FlashCodec methodsFor: 'compressing points'!
printCompressedPoint: aPoint on: aStream runLength: n
	"Print the given point on the stream using the given run length"
	n = 0 ifTrue:[^self]. "Can only happen for the first run"
	"Check if we're storing a zero point"
	(aPoint x = 0 and:[aPoint y = 0]) 
		ifTrue:[
			"Two zero points are specially encoded since they
			occur if a line segment ends and the next segment
			starts from its end point, e.g., (p1,p2,p2) (p2,p3,p4) - this is very likely."
			n = 2 ifTrue:[^aStream nextPut:$A].
			n = 1 ifTrue:[^aStream nextPut: $Z].
			^aStream nextPut:$*; print: n; nextPut:$Z].

	n > 1 ifTrue:[
		"Run length encoding: '*N' repeat the following point n times"
		aStream nextPut: $*; print: n].
	"Point encoding: Two numbers.
	Number encoding: '+XYZ' or '-XYZ'"
	self printPoint: aPoint on: aStream! !

!FlashCodec methodsFor: 'compressing points'!
printPoint: aPoint on: aStream
	aPoint x < 0
		ifTrue:[aStream print: aPoint x]
		ifFalse:[aStream nextPut: $+; print: aPoint x].
	aPoint y < 0
		ifTrue:[aStream print: aPoint y]
		ifFalse:[aStream nextPut: $+; print: aPoint y].! !

!FlashCodec methodsFor: 'compressing points'!
readPointFrom: aStream
	| sign x y |
	sign := aStream next.
	x := Integer readFrom: aStream.
	sign = $- ifTrue:[x := 0-x].
	sign := aStream next.
	y := Integer readFrom: aStream.
	sign = $- ifTrue:[y := 0-y].
	^x@y! !


!FlashCodec methodsFor: 'compressing run arrays'!
compressRunArray: aShortRunArray
	stream nextPut:$+; print: aShortRunArray runSize.
	aShortRunArray lengthsAndValuesDo:[:runLength :runValue|
		runLength < 0 ifTrue:[self error:'Bad run length'].
		stream nextPut:$+; print: runLength.
		runValue < 0
			ifTrue:[stream print: runValue]
			ifFalse:[stream nextPut:$+; print: runValue].
	].
	stream nextPut:$X. "Terminator"
	^stream! !

!FlashCodec methodsFor: 'compressing run arrays'!
decompressRunArray
	| n array runIndex runLength runValue spl c |
	stream next = $+ ifFalse:[self error:'Negative array size'].
	n := Integer readFrom: stream.
	array := ShortRunArray basicNew: n.
	runIndex := 0.
	spl := stream next.
	[runIndex < n] whileTrue:[
		"Read runLength"
		runLength := 0.
		[(c := stream next) isDigit] 
			whileTrue:[runLength := (runLength * 10) + c digitValue].
		spl = $+ ifFalse:[self error:'Negative run length'].
		"Read run value"
		spl := c.
		runValue := 0.
		[(c := stream next) isDigit]
			whileTrue:[runValue := (runValue * 10) + c digitValue].
		spl = $-
			ifTrue:[runValue := 0 - runValue]
			ifFalse:[spl = $+ ifFalse:[self error:'Compression problem']].
		array setRunAt: (runIndex := runIndex+1) toLength: runLength value: runValue.
		spl := c.
	].
	spl = $X ifFalse:[^self error:'Unexpected special character'].
	^array	! !


!FlashCodec methodsFor: 'initialize'!
initialize
	stream := WriteStream on: (String new: 1000).! !

!FlashCodec methodsFor: 'initialize'!
on: aStream
	stream := aStream! !

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

FlashCodec class
	instanceVariableNames: ''!

!FlashCodec class methodsFor: 'compressing'!
compress: aFlashBoundaryShape
	^self new compress: aFlashBoundaryShape! !

!FlashCodec class methodsFor: 'compressing' stamp: 'nk 7/30/2004 21:51'!
compressPoints: points 
	^(self new compressPoints: points) contents! !


!FlashCodec class methodsFor: 'decompressing'!
decompress: aStream
	^(self new on: aStream) decompress! !

!FlashCodec class methodsFor: 'decompressing'!
decompressPoints: aStream
	^(self new on: aStream) decompressPoints! !
Object subclass: #FlashColorTransform
	instanceVariableNames: 'rMul rAdd gMul gAdd bMul bAdd aMul aAdd'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
aAdd
	^aAdd! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
aAdd: aFixed
	aAdd := aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:43'!
aMul
	^aMul! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
aMul: aFixed
	aMul := aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
bAdd
	^bAdd! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
bAdd: aFixed
	bAdd := aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:43'!
bMul
	^bMul! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
bMul: aFixed
	bMul := aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
gAdd
	^gAdd! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
gAdd: aFixed
	gAdd := aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:43'!
gMul
	^gMul! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
gMul: aFixed
	gMul := aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
rAdd
	^rAdd! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
rAdd: aFixed
	rAdd := aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:43'!
rMul
	^rMul! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
rMul: aFixed
	rMul := aFixed! !


!FlashColorTransform methodsFor: 'comparing' stamp: 'ar 8/14/1998 19:39'!
= aCT
	self class == aCT class ifFalse:[^false].
	^rAdd = aCT rAdd and:[rMul = aCT rMul and:[
		gAdd = aCT gAdd and:[gMul = aCT gMul and:[
			bAdd = aCT bAdd and:[bMul = aCT bMul and:[
				aAdd = aCT aAdd and:[aMul = aCT aMul]]]]]]]! !

!FlashColorTransform methodsFor: 'comparing' stamp: 'ar 8/14/1998 19:40'!
hash
	^rAdd hash + gMul hash + bAdd hash + aMul hash! !


!FlashColorTransform methodsFor: 'composing' stamp: 'ar 11/24/1998 14:54'!
composedWithGlobal: aColorTransform
	^aColorTransform composedWithLocal: self.! !

!FlashColorTransform methodsFor: 'composing' stamp: 'ar 11/25/1998 21:34'!
composedWithLocal: aColorTransform
	| cm |
	cm := self clone.
	cm rAdd: self rAdd + (aColorTransform rAdd * self rMul).
	cm rMul: self rMul * aColorTransform rMul.
	cm gAdd: self gAdd + (aColorTransform gAdd * self gMul).
	cm gMul: self gMul * aColorTransform gMul.
	cm bAdd: self bAdd + (aColorTransform bAdd * self bMul).
	cm bMul: self bMul * aColorTransform bMul.
	cm aAdd: self aAdd + (aColorTransform aAdd * self aMul).
	cm aMul: self aMul * aColorTransform aMul.
	^cm! !

!FlashColorTransform methodsFor: 'composing' stamp: 'ar 11/24/1998 15:06'!
localColorToGlobal: aColor
	^Color
		r: (aColor red * self rMul + self rAdd)
		g: (aColor green * self gMul + self gAdd)
		b: (aColor blue * self bMul + self bAdd)
		alpha: (aColor alpha * self aMul + self aAdd)! !


!FlashColorTransform methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:01'!
initialize
	rMul := bMul := gMul := aMul := 1.0.
	rAdd := bAdd := gAdd := aAdd := 0.0.! !


!FlashColorTransform methodsFor: 'printing' stamp: 'ar 11/24/1998 14:40'!
printOn: aStream
	aStream
		nextPutAll: self class name;
		nextPut:$(;
		cr; nextPutAll:' r * '; print: rMul; nextPutAll:' + '; print: rAdd;
		cr; nextPutAll:' g * '; print: gMul; nextPutAll:' + '; print: gAdd;
		cr; nextPutAll:' b * '; print: bMul; nextPutAll:' + '; print: bAdd;
		cr; nextPutAll:' a * '; print: aMul; nextPutAll:' + '; print: aAdd;
		nextPut:$).! !


!FlashColorTransform methodsFor: 'testing' stamp: 'ar 9/2/1999 15:01'!
isAlphaTransform
	(aAdd = 0.0 and:[aMul = 1.0]) ifTrue:[^false].
	^true! !
DamageRecorder subclass: #FlashDamageRecorder
	instanceVariableNames: 'fullDamageRect'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashDamageRecorder methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 18:41'!
fullDamageRect
	invalidRects isEmpty ifTrue:[^0@0 corner: 0@0].
	^fullDamageRect! !

!FlashDamageRecorder methodsFor: 'as yet unclassified' stamp: 'ar 11/13/1998 15:54'!
fullDamageRect: maxBounds
	invalidRects isEmpty ifTrue:[^0@0 corner: 0@0].
	^fullDamageRect intersect: maxBounds! !

!FlashDamageRecorder methodsFor: 'as yet unclassified' stamp: 'ar 11/13/1998 15:43'!
recordInvalidRect: rect
	totalRepaint ifTrue:[^self].
	self updateIsNeeded ifTrue:[
		fullDamageRect := fullDamageRect merge: rect.
	] ifFalse:[
		fullDamageRect := rect copy.
	].
	^super recordInvalidRect: rect! !
Object subclass: #FlashFileReader
	instanceVariableNames: 'stream log dataSize nFillBits nLineBits nGlyphBits nAdvanceBits jpegDecoder version'
	classVariableNames: 'ActionTable IndexTables StepTable TagTable'
	poolDictionaries: ''
	category: 'Flash-Import'!

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:43'!
recordMorphBoundary: id! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:06'!
recordMorphFill: i color1: color1 color2: color2! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:07'!
recordMorphFill: id matrix1: matrix1 matrix2: matrix2 id: bmId clipped: aBool! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:07'!
recordMorphFill: id matrix1: matrix1 ramp1: ramp1 matrix2: matrix2 ramp2: ramp2 linear: isLinear! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:13'!
recordMorphLineStyle: i width1: lineWidth1 width2: lineWidth2 color1: lineColor1 color2: lineColor2! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:18'!
recordMorphShapeEnd: id! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:06'!
recordMorphShapeStart: id srcBounds: bounds1 dstBounds: bounds2! !


!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:46'!
recordCurveSegmentTo: anchorPoint with: controlPoint! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 11/17/1998 00:36'!
recordEndSubshape
	"A new subshape begins with a full set of line and fill styles"! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 10/14/1998 00:39'!
recordFillStyle0: fillIndex! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 10/14/1998 00:39'!
recordFillStyle1: fillIndex! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 20:56'!
recordLineSegmentBy: deltaPoint! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/8/1998 15:56'!
recordLineSegmentHorizontalBy: deltaX
	^self recordLineSegmentBy: (deltaX@0)! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/8/1998 15:56'!
recordLineSegmentVerticalBy: deltaY
	^self recordLineSegmentBy: (0@deltaY)! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:48'!
recordLineStyle: styleIndex! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:47'!
recordMoveTo: aPoint! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:59'!
recordShapeEnd: shapeId! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 1/4/1999 08:44'!
recordShapeProperty: id length: length! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:59'!
recordShapeStart: shapeId bounds: shapeBounds! !


!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 7/15/1998 20:22'!
recordButton: buttonId actions: actionList
	"Associate an action list with the given button"
	^self recordButton: buttonId actions: actionList condition: 8. "OverDownToOverUp"! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 7/15/1998 20:34'!
recordButton: buttonId actions: actionList condition: condition
	"Associate an action list with the given button:
		buttonId:	global ID of the button
		actions:		Collection of MessageSends (e.g., actions)
		condition:	bit mask describing when the actions should be applied
					General conditions:
						1 - IdleToOverUp (Mouse enter up)
						2 - OverUpToIdle (Mouse exit up)
						4 - OverUpToOverDown (Mouse down)
						8 - OverDownToOverUp (Mouse up in)
					Push button conditions:
						16 - OverDownToOutDown (Mouse exit down)
						32 - OutDownToOverDown (Mouse enter down)
						64 - OutDownToIdle (Mouse up out)
					Menu button conditions:
						128 - IdleToOverDown (Mouse enter down)
						256 - OverDownToIdle (Mouse exit down)"
! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 11/24/1998 14:23'!
recordButton: buttonId character: characterId state: state layer: layer matrix: matrix colorTransform: cxForm
	"Define the character to use for a button.
		buttonId:	global ID used for the button
		characterId:	ID of the character defining the shape for the button
		state:		bit mask for when to use the character
						1 - default (e.g. no other state applies)
						2 - display when the mouse is over the button but not pressed
						4 - display when the button is pressed
						8 - the area in which the mouse is supposed to be 'over' the button
		layer:		UNKNOWN.
		matrix:		Transformation to apply to the character. (Guess!!)"! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 8/10/1998 15:51'!
recordButton: id sound: soundId info: soundInfo state: state! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 7/15/1998 20:06'!
recordButton: id trackAsMenu: aBoolean
	"Track the button with the given ID as a menu (in contrast to a push) button. Push buttons capture the mouse until the button is released. Menu buttons don't.
	Note: If defined for a button, this method will be called prior to any other #recordButton: methods."! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 20:36'!
recordDefineButton: id
	"Record the definition of a new button with the given id"! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 20:47'!
recordEndButton: id
	"Record the end of a button definition with the given id"
! !


!FlashFileReader methodsFor: 'defining sounds' stamp: 'ar 10/15/1998 02:36'!
recordSound: id data: aSampledSound! !

!FlashFileReader methodsFor: 'defining sounds' stamp: 'ar 8/10/1998 15:41'!
recordSoundStreamBlock: compressedData! !

!FlashFileReader methodsFor: 'defining sounds' stamp: 'ar 8/10/1998 15:45'!
recordSoundStreamHead: mixFmt stereo: stereo bitsPerSample: bitsPerSample sampleCount: sampleCount compressed: compressed! !

!FlashFileReader methodsFor: 'defining sounds' stamp: 'ar 8/10/1998 15:41'!
recordStartSound: id info: info! !


!FlashFileReader methodsFor: 'defining styles' stamp: 'ar 11/13/1998 20:31'!
recordBitmapFill: fillIndex matrix: bmMatrix id: bitmapID clipped: aBoolean! !

!FlashFileReader methodsFor: 'defining styles' stamp: 'ar 7/4/1998 19:52'!
recordGradientFill: fillIndex matrix: gradientMatrix ramp: colorRampArray linear: aBoolean! !

!FlashFileReader methodsFor: 'defining styles' stamp: 'ar 7/4/1998 19:55'!
recordLineStyle: styleIndex width: lineWidth color: lineColor! !

!FlashFileReader methodsFor: 'defining styles' stamp: 'ar 7/4/1998 19:48'!
recordSolidFill: index color: fillColor! !


!FlashFileReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 22:35'!
recordFont: id name: fontName charMap: charMap wide: isWide
	"Record the name and character mapping of the font for the given id.
	If isWide is set then the font is a 16bit Unicode font."! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 18:50'!
recordFontBegin: fontId with: nGlyphs! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 18:50'!
recordFontEnd: fontId! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:08'!
recordFontShapeEnd: fontId with: charId! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:08'!
recordFontShapeStart: fontId with: charId! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:09'!
recordNextChar: glyphIndex advanceWidth: advance! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:08'!
recordTextChange: fontId color: color xOffset: xOffset yOffset: yOffset height: height! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:16'!
recordTextEnd: id! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:16'!
recordTextStart: id bounds: bounds matrix: matrix! !


!FlashFileReader methodsFor: 'initialize' stamp: 'ar 7/4/1998 20:14'!
on: aStream
	aStream binary.
	stream := FlashFileStream on: aStream.
	log := Transcript.
	log := nil.! !


!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 20:33'!
recordBackgroundColor: aColor! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 11/16/1998 16:54'!
recordBeginSprite: id frames: frameCount! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 22:27'!
recordBitmap: bitmapId data: aForm! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 11/16/1998 16:55'!
recordEndSprite: id! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/15/1998 19:41'!
recordFrameActions: actionList
	"Record the list of actions executed at the next showFrame"! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 11/18/1998 22:00'!
recordFrameCount: maxFrames! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 11/17/1998 13:36'!
recordFrameLabel: label
	"Name the current frame with the given label"! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 8/10/1998 18:23'!
recordFrameRate: fps! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/15/1998 20:30'!
recordFreeCharacter: id
	"Free the character with the given id.
	Not documented."! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/10/1998 15:51'!
recordGlobalBounds: bounds! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 9/3/1999 15:10'!
recordMorph: id depth: depth ratio: ratio! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 9/1/1999 14:40'!
recordMoveObject: objectIndex name: aString depth: depth matrix: matrix colorMatrix: colorMatrix! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 9/1/1999 14:42'!
recordPlaceObject: objectIndex name: aString depth: depth matrix: matrix colorMatrix: colorMatrix! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 20:32'!
recordProtection! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 22:34'!
recordRemoveObject: id depth: depth! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 20:34'!
recordShowFrame! !


!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/24/1998 15:32'!
processActionGetURL: data
	| length position urlString winString |
	length := data nextWord.
	position := data position.
	urlString := data nextString.
	winString := data nextString.
	data position = (position + length) ifFalse:[
		self halt.
		data position: position.
		^self processUnknownAction: data].
	log ifNotNil:[
		log 
			nextPutAll:' url='; print: urlString;
			nextPutAll:', win='; print: winString].
	^Message selector: #getURL:window: arguments: (Array with: urlString with: winString)! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionGotoFrame: data
	| length frame |
	length := data nextWord.
	length = 2 ifFalse:["There is something wrong here"
		self halt.
		data skip: -2.
		^self processUnknownAction: data].
	frame := data nextWord.
	log ifNotNil:[log nextPutAll:' frame = '; print: frame.].
	^Message selector: #gotoFrame: argument: frame! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/24/1998 15:31'!
processActionGotoLabel: data
	| length label |
	length := data nextWord.
	label := data nextString.
	log ifNotNil:[log nextPutAll:' label = '; print: label].
	^Message selector: #gotoLabel: argument: label! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionNextFrame: data
	^Message selector: #gotoNextFrame! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/19/1998 20:39'!
processActionPlay: data
	^Message selector: #actionPlay! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionPrevFrame: data
	^Message selector: #gotoPrevFrame! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 7/15/1998 19:39'!
processActionRecordsFrom: data
	| code actionList action |
	actionList := OrderedCollection new.
	[code := data nextByte.
	code = 0] whileFalse:[
		code := code bitAnd: 127. "Mask out the length-follow flag"
		log ifNotNil:[
			log cr; nextPutAll:'	Action #'; print: code.
			log nextPutAll:' ('; nextPutAll: (ActionTable at: code); nextPutAll:')'].
		action := self dispatch: data on: code in: ActionTable 
					ifNone:[self processUnknownAction: data].
		action ifNotNil:[actionList add: action].
		log ifNotNil:[self flushLog].
	].
	^actionList! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/17/1998 13:37'!
processActionSetTarget: data
	| length target |
	length := data nextWord.
	target := data nextString.
	log ifNotNil:[log nextPutAll:' target = '; print: target].
	^Message selector: #actionTarget: argument: target.! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/19/1998 20:39'!
processActionStop: data
	^Message selector: #actionStop! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionStopSounds: data
	^Message selector: #stopSounds! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionToggleQuality: data
	^Message selector: #toggleQuality! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 5/4/2001 16:21'!
processActionWaitForFrame: data
	| length frame skip |
	length := data nextWord.
	length = 3 ifFalse:["Something is wrong"
		data skip: -2.
		^self processUnknownAction: data].
	frame := data nextWord.
	skip := data nextByte.
	log ifNotNil:[
		log nextPutAll:'frame = '; print: frame;
			nextPutAll:', skip = '; print: skip].
	^Message selector: #isFrameLoaded:elseSkip: arguments: (Array with: frame with: skip).! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 7/15/1998 19:37'!
processUnknownAction: data
	| code length |
	data skip: -1. "For determining the length of the action"
	code := data nextByte.
	(code anyMask: 128) ifTrue:["Two byte length following"
		length := data nextWord.
		data skip: length].
	log ifNotNil:[log nextPutAll:'*** skipped ***'].
	^nil! !


!FlashFileReader methodsFor: 'processing buttons' stamp: 'ar 6/28/1999 16:32'!
processButtonRecords: id from: data cxForm: haveCxForm
	| flags state characterId layer matrix cxForm |
	[flags := data nextByte.
	flags = 0] whileFalse:[
		state := flags bitAnd: 15.
		characterId := data nextWord.
		layer := data nextWord.
		matrix := data nextMatrix.
		haveCxForm ifTrue:[cxForm := data nextColorMatrix: version >= 3].
		self recordButton: id 
			character: characterId 
			state: state 
			layer: layer 
			matrix: matrix
			colorTransform: cxForm].! !


!FlashFileReader methodsFor: 'processing glyphs' stamp: 'ar 7/14/1998 23:17'!
processGlyphEntries: nGlyphs from: data
	| index advance |
	data initBits.
	1 to: nGlyphs do:[:i|
		index := data nextBits: nGlyphBits.
		advance := data nextSignedBits: nAdvanceBits.
		self recordNextChar: index+1 advanceWidth: advance.
		log ifNotNil:[
			log nextPut:$(;print: index; space; print: advance; nextPut:$).
			self flushLog].
	].! !

!FlashFileReader methodsFor: 'processing glyphs' stamp: 'ar 11/20/1998 02:47'!
processGlyphRecordFrom: data
	| flags |
	flags := data nextByte.
	flags = 0 ifTrue:[^false].
	self flag: #wrongSpec.
	"From news://forums.macromedia.com/macromedia.open-swf
It is an error in the spec. There can be up to 255 characters in run. The
high bit does not mean anything. The text record type 0 and type 1 is poorly
described. The real format is that all of the info in a 'text record type 1'
is always followed by the info in a 'text record type 2'. Note the high bit
of 'text record type 1' is reserved and should always be zero.
"
	self processGlyphStateChange: flags from: data.
	flags := data nextByte.
	flags = 0 ifTrue:[^false].
	self processGlyphEntries: flags from: data.
	"Old stuff - which is according to the f**cking spec"
	"(flags anyMask: 128) ifTrue:[
		self processGlyphStateChange: flags from: data.
	] ifFalse:[
		self processGlyphEntries: flags from: data.
	]."
	^true! !

!FlashFileReader methodsFor: 'processing glyphs' stamp: 'ar 7/15/1998 19:45'!
processGlyphStateChange: flags from: data
	| hasFont hasColor hasXOffset hasYOffset fontId color xOffset yOffset height |
	hasFont := flags anyMask: 8.
	hasColor := flags anyMask: 4.
	hasYOffset := flags anyMask: 2.
	hasXOffset := flags anyMask: 1.
	hasFont ifTrue:[fontId := data nextWord].
	hasColor ifTrue:[color := data nextColor].
	hasXOffset ifTrue:[xOffset := data nextWord].
	hasYOffset ifTrue:[yOffset := data nextWord].
	hasFont ifTrue:[height := data nextWord].
	log ifNotNil:[
		log nextPutAll:'['.
		hasFont ifTrue:[log nextPutAll:' font='; print: fontId].
		hasColor ifTrue:[log nextPutAll:' color='; print: color].
		hasXOffset ifTrue:[log nextPutAll:' xOfs=';print: xOffset].
		hasYOffset ifTrue:[log nextPutAll:' yOfs=';print: yOffset].
		hasFont ifTrue:[log nextPutAll:' height='; print: height].
		log nextPutAll:' ]'.
		self flushLog.
	].
	self recordTextChange: fontId color: color xOffset: xOffset yOffset: yOffset height: height.! !

!FlashFileReader methodsFor: 'processing glyphs' stamp: 'ar 10/15/1998 03:23'!
processGlyphsFrom: data
	| id bounds matrix |
	id := data nextWord.
	bounds := data nextRect.
	matrix := data nextMatrix.
	self recordTextStart: id bounds: bounds matrix: matrix.
	nGlyphBits := data nextByte.
	nAdvanceBits := data nextByte.
	log ifNotNil:[
		log	nextPutAll:'(nGlyphBits = '; 
			print: nGlyphBits; 
			nextPutAll:' nAdvanceBits = '; 
			print: nAdvanceBits;
			nextPutAll:') '.
		self flushLog].
	[self processGlyphRecordFrom: data] whileTrue.
	self recordTextEnd: id.! !


!FlashFileReader methodsFor: 'processing morphs' stamp: 'mir 11/2/1999 17:05'!
processMorphFillStylesFrom: data
	| nFills nColors rampIndex rampColor id fillStyleType color1 color2 matrix1 matrix2 ramp1 ramp2 |
	nFills := data nextByte.
	nFills = 255 ifTrue:[nFills := data nextWord].
	log ifNotNil:[log crtab; print: nFills; nextPutAll:' New fill styles'].
	1 to: nFills do:[:i|
		log ifNotNil:[log crtab: 2; print: i; nextPut:$:; tab].
		fillStyleType := data nextByte.
		(fillStyleType = 0) ifTrue:["Solid fill"
			color1 := data nextColor: true.
			color2 := data nextColor: true.
			self recordMorphFill: i color1: color1 color2: color2.
			log ifNotNil:[log nextPutAll:'solid color '; print: color1; nextPutAll:' -- '; print: color2].
		].
		(fillStyleType anyMask: 16) ifTrue:["Gradient fill"
			"Read gradient matrix"
			matrix1 := data nextMatrix.
			matrix2 := data nextMatrix.
			"Read color ramp data"
			nColors := data nextByte.
			ramp1 := Array new: nColors.
			ramp2 := Array new: nColors.
			log ifNotNil:[log nextPutAll:'Gradient fill with '; print: nColors; nextPutAll:' colors'].
			1 to: nColors do:[:j|
				rampIndex := data nextByte.
				rampColor := data nextColor: true.
				ramp1 at: j put: (rampIndex -> rampColor).
				rampIndex := data nextByte.
				rampColor := data nextColor: true.
				ramp2 at: j put: (rampIndex -> rampColor)].
			self recordMorphFill: i matrix1: matrix1 ramp1: ramp1 matrix2: matrix2 ramp2: ramp2 linear: (fillStyleType = 16).
			fillStyleType := 0].
		(fillStyleType anyMask: 16r40) ifTrue:["Bit fill"
			"Read bitmap id"
			id := data nextWord.
			"Read bitmap matrix"
			matrix1 := data nextMatrix.
			matrix2 := data nextMatrix.
			log ifNotNil:[log nextPutAll:'Bitmap fill id='; print: id].
			self recordMorphFill: i matrix1: matrix1 matrix2: matrix2 id: id clipped: (fillStyleType anyMask: 1).
			fillStyleType := 0].
		fillStyleType = 0 ifFalse:[self error:'Unknown fill style: ',fillStyleType printString].
		self flushLog.
	].! !

!FlashFileReader methodsFor: 'processing morphs' stamp: 'ar 9/3/1999 14:40'!
processMorphLineStylesFrom: data
	| nStyles styles lineWidth1 lineWidth2 lineColor1 lineColor2 |
	nStyles := data nextByte.
	nStyles = 255 ifTrue:[nStyles := data nextWord].
	log ifNotNil:[log crtab; print: nStyles; nextPutAll:' New line styles'].
	styles := Array new: nStyles.
	1 to: nStyles do:[:i|
		lineWidth1 := data nextWord.
		lineWidth2 := data nextWord.
		lineColor1 := data nextColor: true.
		lineColor2 := data nextColor: true.
		self recordMorphLineStyle: i width1: lineWidth1 width2: lineWidth2 color1: lineColor1 color2: lineColor2.
		log ifNotNil:[log crtab: 2; print: i; nextPut:$:; tab; 
						print: lineWidth1; tab; print: lineColor1; tab;
						print: lineWidth2; tab; print: lineColor2; tab]].
	self flushLog.
	^styles! !

!FlashFileReader methodsFor: 'processing morphs' stamp: 'ar 9/3/1999 19:08'!
processMorphShapeFrom: data
	"Process a new morph shape"
	| id bounds1 bounds2 edgeOffset |
	"Read shape id and bounding box"
	id := data nextWord.
	bounds1 := data nextRect.
	bounds2 := data nextRect.
	edgeOffset := data nextULong. "edge offset"
	edgeOffset := edgeOffset + data position.
	"Start new shape definition"
	self recordMorphShapeStart: id srcBounds: bounds1 dstBounds: bounds2.
	"Read fill styles for this shape"
	self processMorphFillStylesFrom: data.
	"Read line styles for this shape"
	self processMorphLineStylesFrom: data.
	"Get number of bits for fill and line styles"
	data initBits.
	nFillBits := data nextBits: 4.
	nLineBits := data nextBits: 4.
	"Process all records in this shape definition"
	[self processShapeRecordFrom: data] whileTrue.
	self recordMorphBoundary: id.
	data position: edgeOffset.
	data initBits.
	nFillBits := data nextBits: 4.
	nLineBits := data nextBits: 4.
	[self processShapeRecordFrom: data] whileTrue.
	"And mark the end of this shape"
	self recordMorphShapeEnd: id.
	self recordShapeProperty: id length: data size.! !


!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/13/1998 17:53'!
processCurveRecordFrom: data
	| nBits cx cy ax ay |
	log ifNotNil:[log crtab; nextPutAll:'C: '].
	nBits := (data nextBits: 4) + 2. "Offset by 2"
	"Read control point change"
	cx := data nextSignedBits: nBits.
	cy := data nextSignedBits: nBits.
	log ifNotNil:[log print: cx@cy].
	"Read anchor point change"
	ax := data nextSignedBits: nBits.
	ay := data nextSignedBits: nBits.
	log ifNotNil:[log nextPutAll:' -- '; print: ax@ay.
				self flushLog].
	self recordCurveSegmentTo: ax@ay with: cx@cy! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 11/13/1998 20:31'!
processFillStylesFrom: data
	| nFills matrix nColors rampIndex rampColor id color fillStyleType ramp |
	nFills := data nextByte.
	nFills = 255 ifTrue:[nFills := data nextWord].
	log ifNotNil:[log crtab; print: nFills; nextPutAll:' New fill styles'].
	1 to: nFills do:[:i|
		log ifNotNil:[log crtab: 2; print: i; nextPut:$:; tab].
		fillStyleType := data nextByte.
		(fillStyleType = 0) ifTrue:["Solid fill"
			color := data nextColor.
			self recordSolidFill: i color: color.
			log ifNotNil:[log nextPutAll:'solid color '; print: color].
		].
		(fillStyleType anyMask: 16) ifTrue:["Gradient fill"
			"Read gradient matrix"
			matrix := data nextMatrix.
			"Read color ramp data"
			nColors := data nextByte.
			ramp := Array new: nColors.
			log ifNotNil:[log nextPutAll:'Gradient fill with '; print: nColors; nextPutAll:' colors'].
			1 to: nColors do:[:j|
				rampIndex := data nextByte.
				rampColor := data nextColor.
				ramp at: j put: (rampIndex -> rampColor)].
			self recordGradientFill: i matrix: matrix ramp: ramp linear: (fillStyleType = 16)].
		(fillStyleType anyMask: 16r40) ifTrue:["Bit fill"
			"Read bitmap id"
			id := data nextWord.
			"Read bitmap matrix"
			matrix := data nextMatrix.
			log ifNotNil:[log nextPutAll:'Bitmap fill id='; print: id].
			self recordBitmapFill: i matrix: matrix id: id clipped: (fillStyleType anyMask: 1)].
		self flushLog.
	].! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/12/1998 23:35'!
processFontShapeFrom: data
	data initBits.
	nFillBits := data nextBits: 4.
	nLineBits := data nextBits: 4.
	"Process all records in this shape definition"
	[self processShapeRecordFrom: data] whileTrue.! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/9/1998 20:43'!
processLineRecordFrom: data
	| nBits x y |
	nBits := (data nextBits: 4) + 2. "Offset by 2"
	data nextBitFlag ifTrue:[
		"General line"
		x := data nextSignedBits: nBits.
		y := data nextSignedBits: nBits.
		self recordLineSegmentBy: x@y.
	] ifFalse:[
		data nextBitFlag 
			ifTrue:[	"vertical line"
					y := data nextSignedBits: nBits. 
					self recordLineSegmentVerticalBy: y]
			ifFalse:[	"horizontal line"
					x := data nextSignedBits: nBits.
					self recordLineSegmentHorizontalBy: x].
	].
	log ifNotNil:[log crtab; nextPutAll:'E: ';print: x; nextPut:$@; print: y.
				self flushLog].! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/4/1998 20:04'!
processLineStylesFrom: data
	| nStyles styles lineWidth lineColor |
	nStyles := data nextByte.
	nStyles = 255 ifTrue:[nStyles := data nextWord].
	log ifNotNil:[log crtab; print: nStyles; nextPutAll:' New line styles'].
	styles := Array new: nStyles.
	1 to: nStyles do:[:i|
		lineWidth := data nextWord.
		lineColor := data nextColor.
		self recordLineStyle: i width: lineWidth color: lineColor.
		log ifNotNil:[log crtab: 2; print: i; nextPut:$:; tab; 
						print: lineWidth; tab; print: lineColor]].
	self flushLog.
	^styles! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 11/17/1998 00:35'!
processShapeRecordFrom: data
	| flags pt lineInfo fillInfo0 fillInfo1 |
	data nextBitFlag ifTrue:["Boundary edge record"
		data nextBitFlag
			ifTrue:[self processLineRecordFrom: data]
			ifFalse:[self processCurveRecordFrom: data].
		^true].
	flags := data nextBits: 5.
	flags = 0 ifTrue:[^false]. "At end of shape"
	(flags anyMask: 1) ifTrue:["move to"
		pt := data nextPoint.
		self recordMoveTo: pt.
		log ifNotNil:[log crtab; nextPutAll:'MoveTo '; print: pt]].
	(flags anyMask: 2) ifTrue:["fill info 0"
		fillInfo0 := data nextBits: nFillBits.
		self recordFillStyle0: fillInfo0.
		log ifNotNil:[log crtab; nextPutAll:'FillInfo0 '; print: fillInfo0]].
	(flags anyMask: 4) ifTrue:["fill info 1"
		fillInfo1 := data nextBits: nFillBits.
		self recordFillStyle1: fillInfo1.
		log ifNotNil:[log crtab; nextPutAll:'FillInfo1 '; print: fillInfo1]].
	(flags anyMask: 8) ifTrue:["line info"
		lineInfo := data nextBits: nLineBits.
		self recordLineStyle: lineInfo.
		log ifNotNil:[log crtab; nextPutAll:'LineInfo '; print: lineInfo]].
	(flags anyMask: 16) ifTrue:["new styles"
		self recordEndSubshape.
		log ifNotNil:[log crtab; nextPutAll:'New Set of styles '].
		self processShapeStylesFrom: data.
		"And reset info"
		data initBits.
		nFillBits := data nextBits: 4.
		nLineBits := data nextBits: 4].
	^true! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/4/1998 20:05'!
processShapeStylesFrom: data
	self processFillStylesFrom: data.
	self processLineStylesFrom: data.! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 9/3/1999 14:54'!
processShapesFrom: data
	"Process a new shape"
	| id bounds |
	"Read shape id and bounding box"
	id := data nextWord.
	bounds := data nextRect.
	"Start new shape definition"
	self recordShapeStart: id bounds: bounds.
	"Read styles for this shape"
	self processShapeStylesFrom: data.
	"Get number of bits for fill and line styles"
	data initBits.
	nFillBits := data nextBits: 4.
	nLineBits := data nextBits: 4.
	"Process all records in this shape definition"
	[self processShapeRecordFrom: data] whileTrue.
	"And mark the end of this shape"
	self recordShapeEnd: id.
	self recordShapeProperty: id length: data size.! !


!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 11/21/1998 00:46'!
createSoundBuffersOfSize: numSamples stereo: stereo
	| channels buffers |
	channels := stereo ifTrue:[2] ifFalse:[1].
	buffers := Array new: channels.
	1 to: channels do:[:i| 
		buffers at: i put: 
			(WriteStream on: ((SoundBuffer newMonoSampleCount: numSamples)))].
	^buffers! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'jm 3/30/1999 09:08'!
createSoundFrom: soundBuffers stereo: stereo samplingRate: samplingRate

	| snds |
	snds := soundBuffers collect: [:buf |
		(SampledSound samples: buf samplingRate: samplingRate) loudness: 1.0].
	stereo
		ifTrue:[
			^ MixedSound new
				add: (snds at: 1) pan: 0.0;
				add: (snds at: 2) pan: 1.0;
				yourself]
		ifFalse: [
			^ snds at: 1].! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'jm 3/30/1999 08:55'!
decompressSound: aByteArray stereo: stereo samples: numSamples rate: samplingRate

	| buffers |
	buffers := ADPCMCodec new
		decodeFlash: aByteArray sampleCount: numSamples stereo: stereo.
	^ self createSoundFrom: buffers stereo: stereo samplingRate: samplingRate
! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 11/29/1998 14:53'!
decompressSound: aByteArray stereo: stereo samples: numSamples rate: samplingRate into: buffers
	| data nBits signMask indexTable channels valPred index vp idx delta step vpdiff allButSignMask k k0 |
	data := FlashFileStream on: (ReadStream on: aByteArray).
	data initBits.
	nBits := (data nextBits: 2) + 2.
	signMask := 1 bitShift: nBits - 1.
	allButSignMask := signMask bitInvert32.
	k0 := 1 bitShift: (nBits - 2).
	indexTable := IndexTables at: nBits - 1.
	channels := stereo ifTrue:[2] ifFalse:[1].
	valPred := IntegerArray new: channels.
	index := IntegerArray new: channels.
	1 to: numSamples do:[:nOut|
		(nOut bitAnd: 16rFFF) = 1 ifTrue:["New block header starts every 4KB"
			1 to: channels do:[:i|
				vp := data nextSignedBits: 16.
				valPred at: i put: vp.
				(buffers at: i) nextPut: vp.
				"First sample has no delta"
				index at: i put: (data nextBits: 6).
			].
		] ifFalse:[ "Decode next sample"
			1 to: channels do:[:i|
				vp := valPred at: i.
				idx := index at: i.
				"Get next delta value"
				delta := data nextBits: nBits.
				"Compute difference and new predicted value"
				"Computes 'vpdiff = (delta+0.5)*step/4"
				step := StepTable at: idx + 1.
				k := k0.
				vpdiff := 0.
				[	(delta bitAnd: k) = 0 ifFalse:[vpdiff := vpdiff + step].
					step := step bitShift: -1.
					k := k bitShift: -1.
					k = 0] whileFalse.
				vpdiff := vpdiff + step.
				(delta anyMask: signMask) 
					ifTrue:[vp := vp - vpdiff]
					ifFalse:[vp := vp + vpdiff].
				"Compute new index value"
				idx := idx + (indexTable at: (delta bitAnd: allButSignMask) + 1).
				"Clamp index"
				idx < 0 ifTrue:[idx := 0].
				idx > 88 ifTrue:[idx := 88].
				"Clamp output value"
				vp < -32768 ifTrue:[vp := -32768].
				vp > 32767 ifTrue:[vp := 32767].
				"Store values back"
				index at: i put: idx.
				valPred at: i put: vp.
				(buffers at: i) nextPut: vp.
			]
		].
	].! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 8/10/1998 15:37'!
processEnvelopeFrom: data
	| env |
	env := FlashSoundEnvelope new.
	env mark44: data nextULong.
	env level0: data nextWord.
	env level1: data nextWord.
	^env! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 8/10/1998 16:11'!
processSoundInfoFrom: data
	| flags info nPoints |
	flags := data nextByte.
	info := FlashSoundInformation new.
	info syncFlags: (flags bitShift: -4).
	(flags anyMask: 1) ifTrue:[info inPoint: data nextULong].
	(flags anyMask: 2) ifTrue:[info outPoint: data nextULong].
	(flags anyMask: 4) ifTrue:[info loopCount: data nextWord].
	(flags anyMask: 8) ifTrue:[
		nPoints := data nextByte.
		info envelopes: ((1 to: nPoints) collect:[:i| self processEnvelopeFrom: data]).
	].
	^info! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 11/20/1998 22:37'!
processSoundStreamHeadFrom: data
	| mixFmt flags stereo bitsPerSample compressed sampleCount |
	mixFmt := data nextByte.
	flags := data nextByte.
	stereo := flags anyMask: 1.
	self flag: #wrongSpec.
	bitsPerSample := (flags anyMask: 2) ifTrue:[16] ifFalse:[8].
	compressed := (flags bitShift: -4) = 1.
	sampleCount := data nextWord.
	self recordSoundStreamHead: mixFmt stereo: stereo bitsPerSample: bitsPerSample sampleCount: sampleCount compressed: compressed.
	^true! !


!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/8/2006 21:19'!
processAlphaBitmapData: data

	" read zlib compressed alphabitmapdata from data stream"

	| zLibStream width height r g b a image |

	"read width and height of image"
	width := data nextWord.
	height := data nextWord.
	"self halt."	

	zLibStream := ZLibReadStream on: data stream contents from: data position + 1  to: data size.
	image := Form extent: (width @ height) depth: 32.
	
	1 to: image bits size do:[:i|
		a := zLibStream next.
		r := zLibStream next.
		g := zLibStream next.
		b := zLibStream next.
		a = 0 ifTrue:[ image bits at: i put: 0]
					ifFalse:[image bits at: i put: ( a << 24 ) + ( r << 16) + ( g << 8) + b]
	].
	
	^ image

	
	

	

	
	
	! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/8/2006 21:20'!
processAlphaColorMapData: data

	" read zlib compressed alphacolormapdata from data stream"
	| zLibStream width height colorTableSize colorTable r g b a image color |
	"read width and height of image"
	width := data nextWord.
	height := data nextWord.
	colorTableSize := data nextByte.

	zLibStream := ZLibReadStream on: data stream contents from: data position + 1  to: data size.
	
	"read color table"
	colorTable := Array new: colorTableSize + 1.
	1 to: colorTableSize + 1 do:[ :i|
		r := zLibStream next.
		g := zLibStream next.
		b := zLibStream next.
		a := zLibStream next.
		colorTable at: i put: ( a << 24 ) + ( r << 16) + ( g << 8) + b.
	].

	"round width to 32 bit allignment"
	(width \\ 32) > 0 ifTrue:[ width := 32 * (( width // 32 ) + 1)].

	image := Form extent: (width @ height) depth: 32.

	1 to: image bits size do:[:i|
		color := colorTable at: zLibStream next.
		(color >> 24) = 0 ifTrue:[ image bits at: i put: 0]
					ifFalse:[image bits at: i put: color]
	].
	^ image

	
	! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 2/23/1999 00:10'!
processDefineBits: data
	| id image |
	id := data nextWord.
	image := jpegDecoder decodeNextImageFrom: data.
	Preferences compressFlashImages ifTrue:[image := image asFormOfDepth: 8].
	"image display."
	self recordBitmap: id data: image.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/8/2006 21:20'!
processDefineBitsJPEG2: data
	| id image decoder sPos |
	id := data nextWord.
	decoder := FlashJPEGDecoder new.
	decoder isStreaming: self isStreaming.
	sPos := data stream position.
	decoder decodeJPEGTables: data.
	data stream position: sPos.
	data atEnd
		ifFalse: [
			image := decoder decodeNextImageFrom: data.
			Preferences compressFlashImages ifTrue:[image := image asFormOfDepth: 8].
			self recordBitmap: id data: image].
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/8/2006 21:20'!
processDefineBitsJPEG3: data

	| id image decoder alphaDataOffset sPos alphaBytes zLibStream alphaByte rgbWord |

	id := data nextWord.
	self flag: #wrongSpec.

	alphaDataOffset := data nextLong.
	
	decoder := FlashJPEGDecoder new.
	decoder isStreaming: self isStreaming.

	sPos := data stream position.
	decoder decodeJPEGTables: data.
	data stream position: sPos.
	
	image := decoder decodeNextImage32From: (data streamNextBytes: alphaDataOffset) .
	alphaBytes := image height * image width.

	"Note: We must read the zlib compressed alpha values here."
	data stream position: ( sPos + alphaDataOffset).

	zLibStream := ZLibReadStream on: data stream contents from: ( sPos + alphaDataOffset + 1 )   to: data size.
	1 to: alphaBytes do:[ :i |
		alphaByte := zLibStream next.
		rgbWord := image bits at: i.
		alphaByte = 0 ifTrue:[image bits at: i put: 0 ]
					ifFalse:[image bits at: i put: (alphaByte << 24 + (rgbWord bitAnd: 16r00FFFFFF))]
	].
	self recordBitmap: id data: image.
	
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/8/2006 21:20'!
processDefineBitsLossless2: data
	| id format image |
	id := data nextWord.
	format := data nextByte.	
	format = 3 ifTrue:[image := self processAlphaColorMapData: data ]
				ifFalse:[image := self processAlphaBitmapData: data].	
	self recordBitmap: id data: image.
	
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:12'!
processDefineBitsLossless: data
	"TODO: Read zlib compressed data."
	| id format width height |
	id := data nextWord.
	format := data nextByte.
	width := data nextWord.
	height := data nextWord.
	self recordBitmap: id data: nil.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 02:41'!
processDefineButton2: data
	| id flags actions condition actionOffset |
	data hasAlpha: true.
	id := data nextWord.
	self recordDefineButton: id.
	flags := data nextByte.
	self recordButton: id trackAsMenu: flags = 0.
	self flag: #wrongSpec.
	actionOffset := data nextWord.
	self processButtonRecords: id from: data cxForm: true.
	[actionOffset = 0] whileFalse:[
		actionOffset := data nextWord.
		condition := data nextWord.
		actions := self processActionRecordsFrom: data.
		self recordButton: id actions: actions condition: condition].
	data hasAlpha: false.
	self recordEndButton: id.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/16/1998 20:47'!
processDefineButton: data
	| id actions |
	id := data nextWord.
	self recordDefineButton: id.
	self processButtonRecords: id from: data cxForm: false.
	actions := self processActionRecordsFrom: data.
	self recordButton: id actions: actions.
	self recordEndButton: id.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/24/1998 15:32'!
processDefineButtonCxform: data
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/21/1998 13:56'!
processDefineButtonSound: data
	| id soundID soundInfo |
	id := data nextWord.
	#(0 mouseEnter mouseDown 3) do:[:state|
		soundID := data nextWord.
		soundID = 0 ifFalse:[
			soundInfo := self processSoundInfoFrom: data.
			self recordButton: id sound: soundID info: soundInfo state: state]].
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/24/1998 15:31'!
processDefineFont2: data
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/15/1998 03:18'!
processDefineFont: data
	| fontId firstOffset offsets nShapes |
	fontId := data nextWord.
	firstOffset := data nextWord.
	nShapes := firstOffset // 2.
	offsets := Array new: nShapes.
	offsets at: 1 put: firstOffset.
	2 to: nShapes do:[:i| offsets at: i put: data nextWord].
	self recordFontBegin: fontId with: nShapes.
	1 to: nShapes do:[:i|
		log ifNotNil:[log cr; nextPutAll:'Glyph '; print: i].
		self recordFontShapeStart: fontId with: i.
		self processFontShapeFrom: data.
		self recordFontShapeEnd: fontId with: i].
	data atEnd ifFalse:[self halt].
	self recordFontEnd: fontId.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:34'!
processDefineFontInfo: data
	| id nameLength fontName flags charMap |
	id := data nextWord.
	nameLength := data nextByte.
	fontName := (data nextBytes: nameLength) asString.
	flags := data nextByte.
	charMap := data upToEnd.
	self recordFont: id name: fontName charMap: charMap wide: (flags anyMask: 1).
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 9/3/1999 14:45'!
processDefineMorphShape: data
	self processMorphShapeFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/13/1998 23:52'!
processDefineShape2: data
	self processShapesFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/15/1998 19:48'!
processDefineShape3: data
	data hasAlpha: true.
	self processShapesFrom: data.
	data hasAlpha: false.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/13/1998 23:22'!
processDefineShape: data
	self processShapesFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/18/1998 21:29'!
processDefineSound: data
	| flags sampleCount sampleData id stereo bitsPerSample rate compressed sound |
	id := data nextWord.
	flags := data nextByte.
	stereo := (flags anyMask: 1).
	bitsPerSample := (flags anyMask: 2) ifTrue:[16] ifFalse:[8].
	rate := #( 5512 11025 22050 44100 ) at: (flags >> 2 bitAnd: 3)+1.
	compressed := flags anyMask: 16.
	sampleCount := data nextULong.
	sampleData := data upToEnd.
	compressed ifTrue:[
		self isStreaming ifFalse:[Cursor wait show].
		sound := self decompressSound: sampleData 
						stereo: stereo 
						samples: sampleCount 
						rate: rate.
		self isStreaming ifFalse:[Cursor normal show].
	] ifFalse:[
		self halt.
		sound := nil.
	].
	self recordSound: id data: sound.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 02:42'!
processDefineSprite: data
	| id frameCount |
	id := data nextWord.
	self flag: #wrongSpec.
	frameCount := data nextWord.
	self recordBeginSprite: id frames: frameCount.
	[self processTagFrom: data] whileTrue.
	self recordEndSprite: id.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/15/1998 19:47'!
processDefineText2: data
	data hasAlpha: true.
	self processGlyphsFrom: data.
	data hasAlpha: false.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/15/1998 23:23'!
processDefineText: data
	self processGlyphsFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/18/1998 22:57'!
processDoAction: data
	| actions |
	actions := self processActionRecordsFrom: data.
	self recordFrameActions: actions.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:30'!
processEnd: data
	"At end of data"
	^false! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/17/1998 13:35'!
processFrameLabel: data
	| label |
	label := data nextString.
	self recordFrameLabel: label.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/24/1998 15:31'!
processFreeCharacter: data
	| id |
	id := data nextWord.
	data atEnd ifFalse:[self halt].
	self recordFreeCharacter: id.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/18/1998 21:32'!
processJPEGTables: data
	jpegDecoder := FlashJPEGDecoder new.
	jpegDecoder isStreaming: self isStreaming.
	jpegDecoder decodeJPEGTables: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/24/1998 15:32'!
processNameCharacter: data
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 9/3/1999 15:23'!
processPlaceObject2: data
	| id flags depth matrix cxForm ratio name move |
	flags := data nextByte.
	depth := data nextWord.

	move := (flags anyMask: 1).
	(flags anyMask: 2) ifTrue:[id := data nextWord].
	(flags anyMask: 4) ifTrue:[matrix := data nextMatrix].
	(flags anyMask: 8) ifTrue:[cxForm := data nextColorMatrix: version >= 3].
	self flag: #checkThis.
	(flags anyMask: 16) ifTrue:["self halt." ratio := data nextWord / 65536.0].
	(flags anyMask: 32) ifTrue:["self halt." name := data nextString].
	(flags anyMask: 64) ifTrue:["self halt:'Clip shape encountered'." ^true].
	log ifNotNil:[
		log nextPutAll:' (id = ', id printString,' name = ', name printString,' depth = ', depth printString, ' move: ', move printString, ')'.
		self flushLog].
	move 
		ifTrue:[self recordMoveObject: id name: name depth: depth matrix: matrix colorMatrix: cxForm ratio: ratio]
		ifFalse:[self recordPlaceObject: id name: name depth: depth matrix: matrix colorMatrix: cxForm ratio: ratio].
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 9/3/1999 15:12'!
processPlaceObject: data
	| id depth matrix colorMatrix |
	id := data nextWord.
	depth := data nextWord.
	matrix := data nextMatrix.
	log ifNotNil:[
		log nextPutAll:' (id = ', id printString,' depth = ', depth printString, ')'.
		self flushLog].
	data atEnd ifFalse:[colorMatrix := data nextColorMatrix].
	self recordPlaceObject: id name: nil depth: depth matrix: matrix colorMatrix: colorMatrix ratio: nil.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:32'!
processProtect: data
	self recordProtection.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 02:43'!
processRemoveObject2: data
	| depth |
	depth := data nextWord.
	log ifNotNil:[
		log nextPutAll:' (depth = ', depth printString, ')'.
		self flushLog].
	self recordRemoveObject: nil depth: depth.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/13/1998 00:19'!
processRemoveObject: data
	| id depth |
	id := data nextWord.
	depth := data nextWord.
	log ifNotNil:[
		log nextPutAll:' (id = ', id printString,' depth = ', depth printString, ')'.
		self flushLog].
	self recordRemoveObject: id depth: depth.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:33'!
processSetBackgroundColor: data
	| color |
	color := data nextColor.
	self recordBackgroundColor: color.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:34'!
processShowFrame: data
	"Show the current frame"
	self recordShowFrame.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:37'!
processSoundStreamBlock: data
	self recordSoundStreamBlock: data upToEnd.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:21'!
processSoundStreamHead2: data
	self processSoundStreamHeadFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:22'!
processSoundStreamHead: data
	self processSoundStreamHeadFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/15/1998 02:47'!
processStartSound: data
	| id info |
	id := data nextWord.
	info := self processSoundInfoFrom: data.
	self recordStartSound: id info: info.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:34'!
processUnknown: data
	"An unknown tag has been encountered"
	^true! !


!FlashFileReader methodsFor: 'property access' stamp: 'ar 11/18/1998 21:25'!
isStreaming
	"Subclasses may override this"
	^false! !


!FlashFileReader methodsFor: 'reading' stamp: 'ar 11/18/1998 23:41'!
processFile
	"Read and process the entire file"
	self processHeader ifFalse:[^nil].
	self processFileContents.! !

!FlashFileReader methodsFor: 'reading' stamp: 'sd 1/30/2004 15:17'!
processFileContents
	"Process the contents of the flash file.
	Assume that the header has been read before."
	| time |
	time := Time millisecondsToRun:[
	self isStreaming ifTrue:[
		"Don't show progress for a streaming connection.
		Note: Yielding is done someplace else."
		[self processTagFrom: stream] whileTrue.
	] ifFalse:[
		'Reading file' displayProgressAt: Sensor cursorPoint
			from: 1 to: 100
			during:[:theBar|

		[self processTagFrom: stream] whileTrue:[
			theBar value: (stream position * 100 // stream size).
			stream atEnd ifTrue:[
				log ifNotNil:[
					log cr; nextPutAll:'Unexpected end of data (no end tag)'.
					self flushLog].
				^self]].
		].
	].
	stream close.
	].
	Transcript cr; print: time / 1000.0; show:' secs to read file'! !

!FlashFileReader methodsFor: 'reading' stamp: 'dgd 9/21/2003 17:38'!
processHeader
	"Read header information from the source stream.
	Return true if successful, false otherwise."
	| twipsFrameSize frameRate frameCount |
	self processSignature ifFalse:[^false].
	version := stream nextByte.
	"Check for the version supported"
	version > self maximumSupportedVersion ifTrue:[
		(self confirm:('This file''s version ({1}) is higher than 
the currently supported version ({2}). 
It may contain features that are not supported 
and it may not display correctly.
Do you want to continue?' translated format:{version. self maximumSupportedVersion})) ifFalse:[^false]].

	dataSize := stream nextLong.
	"Check for the minimal file size"
	dataSize < 21 ifTrue:[^false].
	twipsFrameSize := stream nextRect.
	self recordGlobalBounds: twipsFrameSize.
	frameRate := stream nextWord / 256.0.
	self recordFrameRate: frameRate.
	frameCount := stream nextWord.
	self recordFrameCount: frameCount.
	log ifNotNil:[
		log cr; nextPutAll:'------------- Header information --------------'.
		log cr; nextPutAll:'File version		'; print: version.
		log cr; nextPutAll:'File size			'; print: dataSize.
		log cr; nextPutAll:'Movie width		'; print: twipsFrameSize extent x // 20.
		log cr; nextPutAll:'Movie height	'; print: twipsFrameSize extent y // 20.
		log cr; nextPutAll:'Frame rate		'; print: frameRate.
		log cr; nextPutAll:'Frame count	'; print: frameCount.
		log cr; cr.
		self flushLog].
	^true! !

!FlashFileReader methodsFor: 'reading' stamp: 'ar 7/4/1998 20:08'!
processSignature
	"Check the signature of the SWF file"
	stream nextByte asCharacter = $F ifFalse:[^false].
	stream nextByte asCharacter = $W ifFalse:[^false].
	stream nextByte asCharacter = $S ifFalse:[^false].
	^true! !

!FlashFileReader methodsFor: 'reading' stamp: 'ar 10/12/1998 23:57'!
processTagFrom: aStream
	"Read and process the next tag from the input stream."
	| tag data result |
	tag := aStream nextTag.
	log ifNotNil:[
		log cr; nextPutAll:'Tag #'; print: tag key.
		log nextPutAll:' ('; nextPutAll: (TagTable at: tag key + 1); space; print: tag value size;
			nextPutAll:' bytes)'.
		self flushLog].
	data := FlashFileStream on: (ReadStream on: tag value).
	result := self dispatch: data on: tag key+1 in: TagTable ifNone:[self processUnknown: data].
	(log isNil or:[data atEnd]) ifFalse:[
		log 
			nextPutAll:'*** ';
			print: (data size - data position);
			nextPutAll:' bytes skipped ***'.
		self flushLog].
	^result! !


!FlashFileReader methodsFor: 'private' stamp: 'ar 11/20/1998 22:11'!
dispatch: argument on: aKey in: aTable ifNone: exceptionBlock
	| selector |
	(aKey < 1 or:[aKey > aTable size]) ifTrue:[^exceptionBlock value].
	selector := aTable at: aKey.
	^self perform: selector with: argument! !

!FlashFileReader methodsFor: 'private' stamp: 'ar 11/5/1998 23:42'!
flushLog
	(log == Transcript) ifTrue:[
		log endEntry.
		Sensor leftShiftDown ifTrue:[self halt].
	].! !

!FlashFileReader methodsFor: 'private' stamp: 'ar 5/4/2001 16:22'!
maximumSupportedVersion
	^3! !

!FlashFileReader methodsFor: 'private' stamp: 'ar 7/12/1998 23:41'!
warn: aString
	Transcript cr; show: aString.! !

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

FlashFileReader class
	instanceVariableNames: ''!

!FlashFileReader class methodsFor: 'accessing' stamp: 'ar 10/16/1998 00:29'!
tagTable
	^TagTable! !


!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 10/15/1998 01:18'!
initialize
	"FlashFileReader initialize"
	self initializeTagTable.
	self initializeActionTable.
	self initializeStepTable.
	self initializeIndexTables.! !

!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 7/15/1998 18:53'!
initializeActionTable
	"Create and return a new SWF action table"
	"FlashFileReader initializeActionTable"
	ActionTable := Array new: 12.
	ActionTable atAllPut: #processUnknownAction:.
	#(
		(processActionGotoFrame:	1)
		(processActionGetURL:		3)
		(processActionNextFrame:	4)
		(processActionPrevFrame:	5)
		(processActionPlay:			6)
		(processActionStop:			7)
		(processActionToggleQuality:	8)
		(processActionStopSounds:	9)
		(processActionWaitForFrame:	10)
		(processActionSetTarget:		11)
		(processActionGotoLabel:		12)
	) do:[:spec|
			ActionTable at: spec last put: spec first.
	].
! !

!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 10/15/1998 01:18'!
initializeIndexTables
	IndexTables := Array new: 4.
	IndexTables at: 1 put:
		#(-1 2).
	IndexTables at: 2 put:
		#(-1 -1 2 4).
	IndexTables at: 3 put:
		#(-1 -1 -1 -1 2 4 6 8).
	IndexTables at: 4 put:
		#(-1 -1 -1 -1 -1 -1 -1 -1 1 2 4 6 8 10 13 16).! !

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

!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 11/20/1998 22:10'!
initializeTagTable
	"Create and return a new SWF tag table"
	"FlashFileReader initializeTagTable"
	TagTable := Array new: 50.
	TagTable atAllPut: #processUnknown:.
	#(
	(processEnd:					0)
	(processShowFrame:			1)
	(processDefineShape:		2)
	(processFreeCharacter:		3)
	(processPlaceObject:			4)
	(processRemoveObject:		5)
	(processDefineBits:			6)
	(processDefineButton:		7)
	(processJPEGTables:			8)
	(processSetBackgroundColor:	9)
	(processDefineFont:			10)
	(processDefineText:			11)
	(processDoAction:			12)
	(processDefineFontInfo:		13)
	"Event sound tags."
	(processDefineSound:		14)
	(processStartSound:			15)
	(processDefineButtonSound:	17)
	(processSoundStreamHead:	18)
	(processSoundStreamBlock:	19)
	(processDefineBitsLossless:	20)	"A bitmap using lossless zlib compression."
	(processDefineBitsJPEG2:		21)	"A bitmap using an internal JPEG compression table"
	(processDefineShape2:		22)
	(processDefineButtonCxform:	23)
	(processProtect:				24)	"This file should not be importable for editing."

	"These are the new tags for Flash 3."
	(processPlaceObject2:			26)	"The new style place w/ alpha color transform and name."
	(processRemoveObject2:		28)	"A more compact remove object that omits the character tag (just depth)."
	(processDefineShape3:		32)	"A shape V3 includes alpha values."
	(processDefineText2:			33) "A text V2 includes alpha values."
	(processDefineButton2:		34)	"A button V2 includes color transform) alpha and multiple actions"
	(processDefineBitsJPEG3:		35)	"A JPEG bitmap with alpha info."
	(processDefineBitsLossless2:	36)	"A lossless bitmap with alpha info."
	(processDefineSprite:		39) "Define a sequence of tags that describe the behavior of a sprite."
	(processNameCharacter:		40) "Name a character definition, character id and a string, (used for buttons) bitmaps, sprites and sounds)."
	(processFrameLabel:			43) "A string label for the current frame."
	(processSoundStreamHead2:	45) "For lossless streaming sound, should not have needed this..."
	(processDefineMorphShape:	46) "A morph shape definition"
	(processDefineFont2:			48)
	) do:[:spec|
			TagTable at: spec last+1 put: spec first.
	].! !


!FlashFileReader class methodsFor: 'instance creation' stamp: 'ar 7/3/1998 19:04'!
fileNamed: aString
	"FlashFileReader fileNamed:'/home/isg/raab/WDI/flash/samples/top.swf'"
	^self on: (FileStream readOnlyFileNamed: aString).! !

!FlashFileReader class methodsFor: 'instance creation' stamp: 'ar 7/2/1998 19:53'!
on: aStream
	^self new on: aStream! !


!FlashFileReader class methodsFor: 'testing' stamp: 'ar 7/2/1998 20:30'!
canRead: aStream
	"Return true if instances of the receiver know how to handle the data from aStream."
	| ok pos |
	pos := aStream position.
	ok := aStream next asCharacter = $F and:[
			aStream next asCharacter  = $W and:[
				aStream next asCharacter = $S]].
	aStream position: pos.
	^ok! !
Stream subclass: #FlashFileStream
	instanceVariableNames: 'stream bitBuffer bitPosition hasAlpha'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Import'!

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 17:48'!
atEnd
	^stream atEnd! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/16/1998 01:44'!
close
	self flushBits.
	stream close! !

!FlashFileStream methodsFor: 'accessing' stamp: 'jf 12/13/2005 11:25'!
contents

	^ stream contents! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/15/1998 19:46'!
hasAlpha
	^hasAlpha! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/15/1998 19:46'!
hasAlpha: aBoolean
	hasAlpha := aBoolean! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/1/1998 14:23'!
next
	"Make sure the bit buffer is reset"
	self initBits.
	^stream next! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/13/1998 00:40'!
nextByte
	"Make sure the bit buffer is reset"
	self initBits.
	^stream next! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/15/1998 02:24'!
nextByteForBits
	^stream next ifNil:[0]! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/16/1998 01:19'!
nextByteForBitsPut: aByte
	^stream nextPut: aByte! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/16/1998 01:27'!
nextBytePut: aByte
	"Make sure the bit buffer is reset"
	self flushBits.
	stream nextPut: aByte! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 17:50'!
nextBytes: n
	"Return a ByteArray containing the next n bytes"
	^stream next: n! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/1/1998 14:43'!
peekFor: anObject
	^stream peekFor: anObject! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 18:00'!
position
	^stream position! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/1/1998 14:56'!
position: aNumber
	stream position: aNumber.! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 18:00'!
size
	^stream size! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/15/1998 19:01'!
skip: nBytes
	self initBits.
	stream skip: nBytes! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 17:48'!
stream
	^stream! !

!FlashFileStream methodsFor: 'accessing' stamp: 'jf 12/14/2005 14:07'!
streamNextBytes: nBytes
	^ FlashFileStream on: (ReadStream
		on: stream contents
		from: stream position + 1
		to: stream position + nBytes).! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 8/10/1998 14:18'!
upToEnd
	^self stream upToEnd.! !


!FlashFileStream methodsFor: 'initialize' stamp: 'ar 7/15/1998 20:10'!
on: aSourceStream
	stream := aSourceStream.
	bitBuffer := bitPosition := 0.
	hasAlpha := false. "Turn on if needed"! !


!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:38'!
initBits
	"Initialize the bit buffer for future bit reading operations.
	Note: We do not fetch the first byte here so we can do multiple #initBits
	without harming the position of the input stream."
	bitPosition := bitBuffer := 0.! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 21:39'!
nextBitFlag
	^(self nextBits: 1) = 1! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/4/1998 18:27'!
nextBits: n
	"Return the next n bits"
	| shift value remaining |
	n = 0 ifTrue:[^0].
	(n between: 1 and: 32) ifFalse:[^self error:'Bad number of bits'].
	value := 0.
	remaining := n.
	[true] whileTrue:[
		shift := remaining - bitPosition.
		value := value bitOr: (bitBuffer bitShift: shift).
		shift > 0 ifTrue:["Consumes entire buffer"
			remaining := remaining - bitPosition.
			"And get next byte"
			bitBuffer := self nextByteForBits.
			bitPosition := 8.
		] ifFalse:["Consumes a portion of the buffer"
			bitPosition := bitPosition - remaining.
			"Mask off the consumed bits"
			bitBuffer := bitBuffer bitAnd: (255 bitShift: (bitPosition - 8)).
			^value]].! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/15/1998 19:44'!
nextColor
	| r g b baseColor |
	r := self nextByte / 255.0.
	g := self nextByte / 255.0.
	b := self nextByte / 255.0.
	baseColor := Color r: r g: g b: b.
	^hasAlpha 
		ifTrue:[baseColor alpha: self nextByte / 255.0]
		ifFalse:[baseColor]! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 9/3/1999 14:40'!
nextColor: usingAlpha
	| r g b baseColor |
	r := self nextByte / 255.0.
	g := self nextByte / 255.0.
	b := self nextByte / 255.0.
	baseColor := Color r: r g: g b: b.
	^usingAlpha 
		ifTrue:[baseColor alpha: self nextByte / 255.0]
		ifFalse:[baseColor]! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 11/24/1998 15:01'!
nextColorMatrix
	"Read a (possibly compressed) color transformation"
	| transform nBits flags |
	transform := FlashColorTransform new.
	self initBits.
	flags := self nextBits: 2.
	nBits := self nextBits: 4.
	(flags anyMask: 1) ifTrue:["Read multiplication factors"
		transform rMul: (self nextSignedBits: nBits) / 256.0.
		transform gMul: (self nextSignedBits: nBits) / 256.0.
		transform bMul: (self nextSignedBits: nBits) / 256.0.
		hasAlpha ifTrue:[transform aMul: (self nextSignedBits: nBits) / 256.0]].
	(flags anyMask: 2) ifTrue:["Read multiplication factors"
		transform rAdd: (self nextSignedBits: nBits) / 256.0.
		transform gAdd: (self nextSignedBits: nBits) / 256.0.
		transform bAdd: (self nextSignedBits: nBits) / 256.0.
		hasAlpha ifTrue:[transform aAdd: (self nextSignedBits: nBits) / 256.0]].
	^transform! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 6/28/1999 16:33'!
nextColorMatrix: usingAlpha
	| hadAlpha transform |
	hadAlpha := hasAlpha.
	hasAlpha := usingAlpha.
	transform := self nextColorMatrix.
	hasAlpha := hadAlpha.
	^transform! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 10/16/1998 00:47'!
nextLong
	| ulong |
	ulong := self nextULong.
	^ulong > 16r80000000
		ifTrue:[ulong - 16r100000000]
		ifFalse:[ulong]! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 11/20/1998 00:29'!
nextMatrix
	"Read a (possibly compressed) transformation matrix"
	| transform nBits |
	transform := MatrixTransform2x3 identity.
	self initBits.
	(self nextBits: 1) = 1 ifTrue:["Read a,d"
		nBits := self nextBits: 5.
		transform a11: (self nextSignedBits: nBits) / 65536.0.
		transform a22: (self nextSignedBits: nBits) / 65536.0].
	(self nextBits: 1) = 1 ifTrue:["Read b,c"
		nBits := self nextBits: 5.
		transform a21: (self nextSignedBits: nBits) / 65536.0.
		transform a12: (self nextSignedBits: nBits) / 65536.0].
	"Read tx, ty"
	nBits := self nextBits: 5.
	"Transcript cr; show:'nBits = ', nBits printString, ' from ', thisContext sender printString."
	transform a13: (self nextSignedBits: nBits) asFloat.
	transform a23: (self nextSignedBits: nBits) asFloat.
	^transform! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/4/1998 18:42'!
nextPoint
	"Read a (possibly compressed) point"
	| nBits point |
	nBits := self nextBits: 5.
	point := (self nextSignedBits: nBits) @ (self nextSignedBits: nBits).
	^point! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:41'!
nextRect
	"Read a (possibly compressed) rectangle"
	| nBits xMin xMax yMin yMax |
	self initBits.
	nBits := self nextBits: 5.
	xMin := self nextSignedBits: nBits.
	xMax := self nextSignedBits: nBits.
	yMin := self nextSignedBits: nBits.
	yMax := self nextSignedBits: nBits.
	^(xMin@yMin) corner: (xMax@yMax).! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 19:11'!
nextSignedBits: n
	"Return the next n bits as signed integer value"
	| value bits signBit |
	n = 0 ifTrue:[^0].
	value := self nextBits: n.
	"Use a lookup for determining whether or not the value should be sign extended"
	bits := #( 1 2 4 8 16 32 64 128 "1 ... 8"
			256 512 1024 2048 4096 8192 16384 32768 "9 ... 16"
			65536 131072 262144 524288 1048576 2097152 4194304 8388608 "17 ... 24"
			16777216 33554432 67108864 134217728 268435456 536870912 1073741824 2147483648 "25 ... 32"
			 4294967296 "33 bit -- for negation only" ).
	signBit := bits at: n.
	^(value bitAnd: signBit) = 0
		ifTrue:[value]
		ifFalse:[value - (bits at: n+1)]! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:40'!
nextString
	| out byte |
	out := WriteStream on: (String new: 50).
	[byte := self nextByte.
	byte = 0] whileFalse:
		[out nextPut: (self convertChar2Squeak: byte asCharacter)].
	^out contents! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:44'!
nextTag
	"Read the next tag. Return an association with the key being the tag id and its value the contents of the chunk following."
	| word tag length |
	word := self nextWord.
	"Extract tag and length from the word"
	length := word bitAnd: 16r3F.
	tag := word bitShift: -6.
	"Check if an extra word follows"
	length = 16r3F ifTrue:[length := self nextULong].
	^Association key: tag value: (self nextBytes: length).! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:40'!
nextULong
	^self nextByte + 
		(self nextByte bitShift: 8) + 
		(self nextByte bitShift: 16) + 
		(self nextByte bitShift: 24).! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:40'!
nextWord
	^self nextByte + (self nextByte bitShift: 8)! !


!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:27'!
flushBits
	"Flush the bit buffer for future bit writing operations."
	bitPosition = 0 ifFalse:[self nextByteForBitsPut: bitBuffer].
	bitPosition := 0.
	bitBuffer := 0.! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:36'!
nextBitFlag: aBoolean
	^self nextBits: 1 put: (aBoolean ifTrue:[1] ifFalse:[0])! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:41'!
nextBits: n put: aNumber
	"Write the next n bits"
	| value remaining shift |
	value := aNumber. "Do not round - this is a sanity check"
	value isInteger ifFalse:[^self error:'Not an integer number'].
	value < 0 ifTrue:[^self error:'Not a positive number'].
	n = 0 ifTrue:[^0].
	(n between: 1 and: 32) ifFalse:[^self error:'Bad number of bits'].
	value < (1 bitShift: n) ifFalse:[^self error:'Unable to represent number'].
	remaining := n.
	[true] whileTrue:[
		shift := 8 - bitPosition - remaining.
		bitBuffer := bitBuffer + (value bitShift: shift).
		"Mask out consumed bits"
		value := value bitAnd: (1 bitShift: 0-shift) - 1.
		shift < 0 ifTrue:["Buffer overflow"
			remaining := remaining - (8 - bitPosition).
			"Store next byte"
			self nextByteForBitsPut: bitBuffer.
			bitBuffer := 0.
			bitPosition := 0.
		] ifFalse:["Store only portion of the buffer"
			bitPosition := bitPosition + remaining.
			^self
		].
	].! !

!FlashFileStream methodsFor: 'writing data' stamp: 'bf 3/16/2000 19:01'!
nextColorMatrixPut: cm
	"Write a (possibly compressed) color transformation"
	self flushBits.
	self nextBits: 2 put: 3. "Always write full transform"
	self nextBits: 4 put: 15. "Always use full accuracy"
	self nextSignedBits: 15 put: cm rMul.
	self nextSignedBits: 15 put: cm gMul.
	self nextSignedBits: 15 put: cm bMul.
	hasAlpha ifTrue:[self nextSignedBits: 15 put: cm aMul].
	self nextSignedBits: 15 put: cm rAdd.
	self nextSignedBits: 15 put: cm gAdd.
	self nextSignedBits: 15 put: cm bAdd.
	hasAlpha ifTrue:[self nextSignedBits: 15 put: cm aAdd].! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:38'!
nextColorPut: aColor
	self nextBytePut: (aColor red * 255) rounded.
	self nextBytePut: (aColor green * 255) rounded.
	self nextBytePut: (aColor blue * 255) rounded.
	hasAlpha ifTrue:[self nextBytePut: (aColor alpha * 255) rounded].
! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:46'!
nextLongPut: value

	value < 0 
		ifTrue:[self nextULongPut: 16r100000000 - value]
		ifFalse:[self nextULongPut: value]! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 11/2/1998 23:00'!
nextMatrixPut: matrix
	"write a (possibly compressed) transformation matrix"
	self flushBits.
	(matrix a11 = 0.0 and:[matrix  a22 = 0.0]) ifFalse:[
		"Write a/d"
		self nextBits: 1 put: 1.
		self nextBits: 5 put: 31. "Always use full accuracy"
		self nextSignedBits: 31 put: matrix a11 * 65536.
		self nextSignedBits: 31 put: matrix a22 * 65536.
	] ifTrue:[self nextBits: 1 put: 0].
	((matrix a12) = 0.0 and:[(matrix  a21) = 0.0]) ifFalse:[
		"Write b/c"
		self nextBits: 1 put: 1.
		self nextBits: 5 put: 31. "Always use full accuracy"
		self nextSignedBits: 31 put: matrix a12 * 65536.
		self nextSignedBits: 31 put: matrix a21 * 65536.
	] ifTrue:[self nextBits: 1 put: 0].
	"Write tx/ty"
	self nextBits: 5 put: 31. "Always use full accuracy"
	self nextSignedBits: 31 put: matrix a13.
	self nextSignedBits: 31 put: matrix a23.
! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:55'!
nextPointPut: aPoint
	"Write a (possibly compressed) point"
	self nextBits: 5 put: 31. "Always write full accuracy"
	self nextSignedBits: 31 put: aPoint x.
	self nextSignedBits: 31 put: aPoint y.
! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:29'!
nextRectPut: aRect
	"Write a (possibly compressed) rectangle"
	self nextBits: 5 put: 31. "Always use full accuracy"
	self nextSignedBits: 31 put: aRect origin x.
	self nextSignedBits: 31 put: aRect corner x.
	self nextSignedBits: 31 put: aRect origin y.
	self nextSignedBits: 31 put: aRect corner y.! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:59'!
nextSignedBits: n put: someValue
	"Write the next n bits as signed integer value"
	| value |
	value := someValue rounded. "Do rounding here if not done before"
	value < 0
		ifTrue:[self nextBits: n put: 16r100000000 - value]
		ifFalse:[self nextBits: n put: value]! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:01'!
nextStringPut: aString

	aString do:[:char| self nextBytePut: (self convertCharFromSqueak: char) asInteger].
	self nextBytePut: 0.! !

!FlashFileStream methodsFor: 'writing data' stamp: 'di 2/9/1999 15:16'!
nextTagPut: tag length: length
	"Write the next tag."
	length >= 16r3F ifTrue:[
		self nextWordPut: (tag bitShift: 6) + 16r3F.
		self nextULongPut: length.
	] ifFalse:[
		self nextWordPut: (tag bitShift: 6) + length.
	].! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:04'!
nextULongPut: long
	self nextBytePut: (long bitAnd: 255).
	self nextBytePut: ((long bitShift: -8) bitAnd: 255).
	self nextBytePut: ((long bitShift: -16) bitAnd: 255).
	self nextBytePut: ((long bitShift: -24) bitAnd: 255).! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:06'!
nextWordPut: value
	self nextBytePut: (value bitAnd: 255).
	self nextBytePut: ((value bitShift: -8) bitAnd: 255).! !


!FlashFileStream methodsFor: 'private' stamp: 'ar 7/3/1998 18:17'!
convertChar2Squeak: aCharacter
	"Convert aCharacter from SWF char set (whatever this may be) to Squeaks char set"
	^aCharacter! !

!FlashFileStream methodsFor: 'private' stamp: 'ar 10/16/1998 01:01'!
convertCharFromSqueak: aCharacter
	"Convert aCharacter to SWF char set (whatever this may be) "
	^aCharacter! !

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

FlashFileStream class
	instanceVariableNames: ''!

!FlashFileStream class methodsFor: 'instance creation' stamp: 'ar 7/3/1998 17:33'!
on: aSourceStream
	^self basicNew on: aSourceStream! !
Object subclass: #FlashFileWriter
	instanceVariableNames: 'stream log dataSize nFillBits nLineBits nGlyphBits nAdvanceBits jpegEncoder'
	classVariableNames: 'TagTable'
	poolDictionaries: ''
	category: 'Flash-Import'!

!FlashFileWriter methodsFor: 'initialize' stamp: 'ar 10/16/1998 01:23'!
close
	stream close! !

!FlashFileWriter methodsFor: 'initialize' stamp: 'ar 10/16/1998 01:22'!
on: aStream
	aStream binary.
	stream := FlashFileStream on: aStream.! !


!FlashFileWriter methodsFor: 'writing' stamp: 'ar 10/16/1998 01:26'!
writeHeader: bounds rate: frameRate
	"Read header information from the source stream.
	Return true if successful, false otherwise."
	self halt.
	self writeSignature.
	stream nextBytePut: 3. "Always write flash3"
	dataSize := stream nextLongPut: 0.	"Place holder for data size"
	stream nextRectPut: bounds.
	stream nextWordPut: (frameRate * 256) truncated.! !

!FlashFileWriter methodsFor: 'writing' stamp: 'ar 10/16/1998 01:20'!
writeSignature
	stream nextBytePut: $F asInteger.
	stream nextBytePut: $W asInteger.
	stream nextBytePut: $S asInteger.! !

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

FlashFileWriter class
	instanceVariableNames: ''!

!FlashFileWriter class methodsFor: 'class initialization' stamp: 'ar 10/16/1998 00:31'!
initialize
	"FlashFileWriter initialize"
	TagTable := Dictionary new.
	FlashFileReader tagTable doWithIndex:[:tag :index|
		TagTable at: (tag copyWithout: $:) asSymbol put: index
	].! !


!FlashFileWriter class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 01:23'!
newFileNamed: aString
	"FlashFileWriter newFileNamed:'f:\wdi\GraphicsEngine\flash\test.swf'"
	^self on: (FileStream newFileNamed: aString).! !

!FlashFileWriter class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 01:24'!
on: aStream
	^self new on: aStream! !
FlashMorph subclass: #FlashGlyphMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashGlyphMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 17:17'!
color: aColor
	super color: aColor.
	submorphs do:[:m| m color: aColor].! !

!FlashGlyphMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 02:51'!
defaultAALevel
	^4! !
JPEGReadWriter subclass: #FlashJPEGDecoder
	instanceVariableNames: 'eoiSeen streaming'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Import'!

!FlashJPEGDecoder methodsFor: 'accessing' stamp: 'ar 11/18/1998 21:32'!
isStreaming
	^streaming! !

!FlashJPEGDecoder methodsFor: 'accessing' stamp: 'ar 11/18/1998 21:31'!
isStreaming: aBool
	streaming := aBool! !

!FlashJPEGDecoder methodsFor: 'accessing' stamp: 'ar 1/15/1999 03:35'!
understandsImageFormat
	"Return false so we don't get confused with ImageReadWriter's mechanism for finding the right class to read a given stream."
	^false! !


!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'RAA 8/21/2001 23:15'!
decodeJPEGTables: aStream
"
fixing the #atEnd allows the following to work:

(FlashMorphReader on: (HTTPSocket httpGet: 'http://www.audi.co.uk/flash/intro1.swf' accept:'application/x-shockwave-flash')) processFile startPlaying openInWorld. 
"
	self setStream: aStream.
	eoiSeen := false.
	self parseFirstMarker.
	[eoiSeen or: [stream atEnd]] whileFalse:[self parseNextMarker].
! !

!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 7/8/2006 21:21'!
decodeNextImage32From: aStream
	| image |
	self setStream: aStream.
	self isStreaming ifFalse:[Cursor wait show].
	image := self nextImageDitheredToDepth: 32.
	self isStreaming ifFalse:[Cursor normal show].
	^image! !

!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 11/18/1998 21:33'!
decodeNextImageFrom: aStream
	| image |
	self setStream: aStream.
	self isStreaming ifFalse:[Cursor wait show].
	image := self nextImage.
	self isStreaming ifFalse:[Cursor normal show].
	^image! !

!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 10/28/2001 16:25'!
nextImageDitheredToDepth: depth
	"Overwritten to yield every now and then."
	| form xStep yStep x y |
	ditherMask := DitherMasks
		at: depth
		ifAbsent: [self error: 'can only dither to display depths'].
	residuals := WordArray new: 3.
	sosSeen := false.
	self parseFirstMarker.
	[sosSeen] whileFalse: [self parseNextMarker].
	form := Form extent: (width @ height) depth: depth.
	xStep := mcuWidth * DCTSize.
	yStep := mcuHeight * DCTSize.
	y := 0.
	1 to: mcuRowsInScan do:
		[:row |
		"self isStreaming ifTrue:[Processor yield]."
		x := 0.
		1 to: mcusPerRow do:
			[:col |
			self decodeMCU.
			self idctMCU.
			self colorConvertMCU.
			mcuImageBuffer displayOn: form at: (x @ y).
			x := x + xStep].
		y := y + yStep].
	^ form! !

!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 10/1/1998 14:34'!
parseEndOfInput
	eoiSeen := true.! !


!FlashJPEGDecoder methodsFor: 'stream access' stamp: 'ar 10/1/1998 14:42'!
next
	^stream nextByte! !

!FlashJPEGDecoder methodsFor: 'stream access' stamp: 'ar 10/1/1998 14:43'!
next: n
	^stream nextBytes: n! !
Object subclass: #FlashKeyframe
	instanceVariableNames: 'start stop data'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:48'!
data
	^data! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:48'!
data: anObject
	data := anObject! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:55'!
start
	^start! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:55'!
start: startValue
	start := startValue! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:55'!
stop
	^stop! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:55'!
stop: stopValue
	stop := stopValue! !


!FlashKeyframe methodsFor: 'initialize' stamp: 'ar 11/12/1998 22:55'!
from: startValue to: stopValue data: newData
	start := startValue.
	stop := stopValue.
	data := newData.! !


!FlashKeyframe methodsFor: 'printing' stamp: 'ar 11/13/1998 14:33'!
printOn: aStream
	aStream nextPutAll: self class name;
		nextPut:$(;
		print: start;
		nextPut:$-;
		print: stop;
		nextPutAll:' -> ';
		print: data;
		nextPut:$)! !


!FlashKeyframe methodsFor: 'testing' stamp: 'di 11/21/1999 20:26'!
includesFrame: aNumber
	^aNumber >= start and:[aNumber <= stop]! !

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

FlashKeyframe class
	instanceVariableNames: ''!

!FlashKeyframe class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 22:47'!
from: startValue to: stopValue
	^self new from: startValue to: stopValue! !

!FlashKeyframe class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 22:54'!
from: startValue to: stopValue data: newData
	^self new from: startValue to: stopValue data: newData! !
Object subclass: #FlashKeyframes
	instanceVariableNames: 'kfList lastIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashKeyframes methodsFor: 'accessing' stamp: 'di 11/21/1999 20:26'!
at: frameNumber
	"Return data from the keyframe list at the given frame number"
	| lastEntry |
	kfList isEmpty ifTrue:[^nil].
	lastIndex ifNil:[lastIndex := self searchFor: frameNumber].
	lastEntry := kfList at: lastIndex.
	(lastEntry includesFrame: frameNumber) ifTrue:[^lastEntry data].
	"Do a quick check if the frame is out of range"
	kfList first stop >= frameNumber 
		ifTrue:[	lastIndex := 1.
				^kfList first data].
	kfList last start <= frameNumber 
		ifTrue:[	lastIndex := kfList size. 
				^kfList last data].

	"Search linearly from lastEntry - most times we'll just be one step away"
	[lastEntry stop >= frameNumber] whileFalse:[
		lastIndex := lastIndex+1.
		lastEntry := kfList at: lastIndex].
	[lastEntry start <= frameNumber] whileFalse:[
		lastIndex := lastIndex-1.
		lastEntry := kfList at: lastIndex].
	^lastEntry data! !

!FlashKeyframes methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:51'!
at: frameNumber put: newData
	"Add newData to the keyframe list at the given frameNumber"
	| kf |
	kfList ifNil:[kfList := OrderedCollection new].
	kfList isEmpty ifFalse:["Check if we can extend the last interval"
		kf := kfList last.
		kf stop < frameNumber 
			ifFalse:[^self replaceData: newData at: frameNumber].
		kf data = newData "Extend interval to include frameNumber"
			ifTrue:[	kf stop: frameNumber.
					^newData].
		"Extend last interval to just before frameNumer"
		kf stop: frameNumber - 1].
	kfList add: (FlashKeyframe from: frameNumber to: frameNumber data: newData).
	^newData! !

!FlashKeyframes methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:51'!
keys
	^kfList collect:[:kf| kf start].! !

!FlashKeyframes methodsFor: 'accessing' stamp: 'ar 10/14/1998 20:27'!
size
	^kfList size! !


!FlashKeyframes methodsFor: 'initialize' stamp: 'ar 8/14/1998 19:32'!
initialize
	kfList := OrderedCollection new.! !


!FlashKeyframes methodsFor: 'printing' stamp: 'ar 8/14/1998 19:32'!
printOn: aStream
	aStream
		nextPutAll: self class name;
		nextPut: $(;
		cr.
	kfList do:[:item| aStream print: item; cr].

	aStream nextPut:$).! !


!FlashKeyframes methodsFor: 'private' stamp: 'ar 11/12/1998 22:51'!
replaceData: newData at: frameNumber
	(kfList last stop = frameNumber) 
		ifTrue:[^self replaceLastData: newData at: frameNumber].
	self halt:'Not implemented yet'! !

!FlashKeyframes methodsFor: 'private' stamp: 'ar 11/18/1998 23:29'!
replaceLastData: newData at: frameNumber
	| kf |
	lastIndex := nil.
	kf := kfList last.
	(kf stop = kf start)
		ifTrue:[kfList removeLast]
		ifFalse:[kf stop: kf stop-1].
	^self at: frameNumber put: newData! !

!FlashKeyframes methodsFor: 'private' stamp: 'di 11/21/1999 20:26'!
searchFor: frameNumber
	"Return data from the keyframe list at the given frame number"
	| low high mid kf |
	low := kfList at: 1.
	high := kfList at: kfList size.
	"Check if in or before first keyframe interval"
	frameNumber <= low stop ifTrue:[^1].
	"Check if in or after last keyframe interval"
	frameNumber >= high start ifTrue:[^kfList size].
	"Somewhere inbetween 2nd to (n-1)th interval"
	low := 2. high := kfList size - 1.
	[mid := high + low // 2.
	low > high] whileFalse:[
		kf := kfList at: mid.
		(kf includesFrame: frameNumber) ifTrue:[^mid].
		(kf start < frameNumber)
			ifTrue:[low := mid + 1]
			ifFalse:[high := mid - 1]].
	kf := kfList at: low.
	(kf includesFrame: frameNumber) ifFalse:[self error:'No keyframe found'].
	^low! !
Object subclass: #FlashLineStyle
	instanceVariableNames: 'width color'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
color
	^color! !

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
color: aColor
	color := aColor! !

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
color: aColor width: aNumber
	self color: aColor.
	self width: aNumber.! !

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
width
	^width! !

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
width: aNumber
	width := aNumber! !


!FlashLineStyle methodsFor: 'comparing' stamp: 'ar 8/15/1998 00:59'!
= aLineStyle
	self class = aLineStyle class ifFalse:[^false].
	^self color = aLineStyle color and:[self width = aLineStyle width].! !

!FlashLineStyle methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:03'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^self color hash bitXor: self width hash! !

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

FlashLineStyle class
	instanceVariableNames: ''!

!FlashLineStyle class methodsFor: 'instance creation' stamp: 'ar 7/14/1998 21:19'!
color: aColor width: aNumber
	^self new color: aColor width: aNumber! !
HashAndEqualsTestCase subclass: #FlashLineStyleTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support-Tests'!

!FlashLineStyleTest methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'!
setUp
	super setUp.
	prototypes
		add: (FlashLineStyle color: 1 width: 1);
		
		add: (FlashLineStyle color: 1 width: 2);
		
		add: (FlashLineStyle color: 2 width: 1);
		
		add: (FlashLineStyle color: 2 width: 2) ! !
MatrixTransformMorph subclass: #FlashMorph
	instanceVariableNames: 'colorTransform'
	classVariableNames: 'FlashSoundVolume'
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 21:41'!
activationKeys
	^#()! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:27'!
colorTransform
	^colorTransform! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:27'!
colorTransform: aColorTransform
	colorTransform := aColorTransform! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 02:48'!
defaultAALevel
	^self valueOfProperty: #aaLevel! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 02:51'!
defaultAALevel: aNumber
	aNumber isNil 
		ifTrue:[self removeProperty: #aaLevel]
		ifFalse:[self setProperty: #aaLevel toValue: aNumber]! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 21:00'!
depth
	^(self valueOfProperty: #depth) ifNil:[0]! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 21:00'!
depth: d
	d = 0
		ifTrue:[self removeProperty: #depth]
		ifFalse:[self setProperty: #depth toValue: d]! !

!FlashMorph methodsFor: 'accessing' stamp: 'di 11/12/2000 15:53'!
flashPlayer
	^ self firstOwnerSuchThat: [:parent | parent isFlashMorph and: [parent isFlashPlayer]]! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 11:40'!
id
	^-1! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 1/4/1999 08:48'!
originalFileSize
	^(self valueOfProperty: #originalFileSize) ifNil:[0]! !


!FlashMorph methodsFor: 'classification' stamp: 'ar 11/16/1998 23:47'!
isFlashButton
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 8/14/1998 21:52'!
isFlashCharacter
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 8/14/1998 21:12'!
isFlashMorph
	^true! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 11/15/1998 19:04'!
isFlashPlayer
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 6/2/1999 03:15'!
isFlashShape
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 11/16/1998 17:03'!
isFlashSprite
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 11/19/1998 22:22'!
isMouseSensitive
	"Return true if the receiver is mouse sensitive and must stay unlocked"
	^false! !


!FlashMorph methodsFor: 'copying' stamp: 'dgd 2/16/2003 19:58'!
copyExtension
	"Copy my extensions dictionary"
	| copiedExtension |
	self hasExtension
		ifFalse: [^ self].
	copiedExtension := self extension copy.
	copiedExtension removeOtherProperties.
	self extension otherProperties
		ifNotNil: [self extension otherProperties
				associationsDo: [:assoc | copiedExtension setProperty: assoc key toValue: assoc value copy]].
	self privateExtension: copiedExtension! !

!FlashMorph methodsFor: 'copying' stamp: 'ar 5/20/1999 15:30'!
copyMovieFrom: firstFrame to: lastFrame
	| copy |
	copy := self copy.
	copy copyExtension.
	copy addAllMorphs: 
		(self submorphs collect:[:m| m copyMovieFrom: firstFrame to: lastFrame]).
	^copy! !

!FlashMorph methodsFor: 'copying' stamp: 'dgd 2/22/2003 14:24'!
duplicate
	"Usually, FlashMorphs exist in a player. 
	If they're grabbed and moved outside the player
	they should keep their position."

	| dup player |
	dup := super duplicate.
	player := self flashPlayer.
	dup transform: (self transformFrom: self world).
	"If extracted from player and no default AA level is set use prefs"
	(player notNil and: [self defaultAALevel isNil]) 
		ifTrue: 
			[Preferences extractFlashInHighQuality ifTrue: [dup defaultAALevel: 2].
			Preferences extractFlashInHighestQuality ifTrue: [dup defaultAALevel: 4]].
	^dup! !


!FlashMorph methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:23'!
compress
	"Compress the receiver for efficient storage on disk"
	fullBounds := nil. "Will be computed on the fly"
	submorphs do:[:m| m compress].! !

!FlashMorph methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:23'!
decompress
	"Decompress the receiver"
	submorphs do:[:m| m decompress].
	self fullBounds. "Force computation"! !


!FlashMorph methodsFor: 'drawing' stamp: 'ar 11/16/1998 19:04'!
debugDraw
	| vis canvas m |
	vis := self visible.
	self visible: true.
	canvas := BalloonCanvas on:Display.
	m := MatrixTransform2x3 withScale: 0.05.
	m offset: (self fullBounds origin // 20) negated.
	canvas transformBy: m.
	self fullDrawOn: canvas.
	self visible: vis.! !

!FlashMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:08'!
drawSubmorphsOn: aCanvas
	| aaLevel |
	aCanvas asBalloonCanvas preserveStateDuring:[:myCanvas|
		colorTransform ifNotNil:[myCanvas colorTransformBy: colorTransform].
		(aaLevel := self defaultAALevel) ifNotNil:[myCanvas aaLevel: aaLevel].
		super drawSubmorphsOn: myCanvas].! !

!FlashMorph methodsFor: 'drawing' stamp: 'ar 5/6/2001 19:03'!
fullDrawOn: aCanvas
	| myCanvas |
	aCanvas isBalloonCanvas ifTrue:[^super fullDrawOn: aCanvas].
	myCanvas := aCanvas asBalloonCanvas.
	myCanvas deferred: true.
	super fullDrawOn: myCanvas.
	myCanvas flush.! !


!FlashMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:24'!
aboutToBeGrabbedBy: aHand 
	"Usually, FlashMorphs exist in a player. 
	If they're grabbed and moved outside the player
	they should keep their position."

	| player |
	super aboutToBeGrabbedBy: aHand.
	player := self flashPlayer.
	player ifNotNil: [player noticeRemovalOf: self].
	self transform: (self transformFrom: self world).
	"If extracted from player and no default AA level is set use prefs"
	(player notNil and: [self defaultAALevel isNil]) 
		ifTrue: 
			[Preferences extractFlashInHighQuality ifTrue: [self defaultAALevel: 2].
			Preferences extractFlashInHighestQuality ifTrue: [self defaultAALevel: 4]].
	^self	"Grab me"! !

!FlashMorph methodsFor: 'dropping/grabbing' stamp: 'ar 11/18/1998 14:04'!
justDroppedInto: newOwner event: evt
	| ownerTransform |
	ownerTransform := (newOwner transformFrom: newOwner world).
	ownerTransform isIdentity ifFalse:[
		ownerTransform := ownerTransform asMatrixTransform2x3 inverseTransformation.
		self transform: (self transform composedWithGlobal: ownerTransform).
	].
	super justDroppedInto: newOwner event: evt.! !


!FlashMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 17:28'!
loadInitialFrame
	self computeBounds.! !

!FlashMorph methodsFor: 'initialize' stamp: 'ar 11/19/1998 22:23'!
lockChildren
	submorphs do:[:m| 
		m isMouseSensitive ifFalse:[m lock]].! !

!FlashMorph methodsFor: 'initialize' stamp: 'ar 11/13/1998 16:10'!
reset
	submorphs do:[:m| m isFlashMorph ifTrue:[m reset]].! !

!FlashMorph methodsFor: 'initialize' stamp: 'ar 8/15/1998 17:21'!
unlockChildren
	submorphs do:[:m| m unlock].! !


!FlashMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:42'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addUpdating: #getSmoothingLevel action: #nextSmoothingLevel.
	aCustomMenu add:'show compressed size' translated action: #showCompressedSize.! !

!FlashMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:42'!
getSmoothingLevel
	"Menu support"
	| aaLevel |
	aaLevel := self defaultAALevel
				ifNil: [1].
	aaLevel = 1
		ifTrue: [^ 'turn on smoothing' translated].
	aaLevel = 2
		ifTrue: [^ 'more smoothing' translated].
	aaLevel = 4
		ifTrue: [^ 'turn off smoothing' translated]! !

!FlashMorph methodsFor: 'menu' stamp: 'ar 6/16/1999 07:17'!
nextSmoothingLevel
	| aaLevel |
	aaLevel := self defaultAALevel ifNil:[1].
	aaLevel = 1 ifTrue:[self defaultAALevel: 2].
	aaLevel = 2 ifTrue:[self defaultAALevel: 4].
	aaLevel = 4 ifTrue:[self defaultAALevel: nil].
	self changed.! !

!FlashMorph methodsFor: 'menu' stamp: 'gm 2/28/2003 00:16'!
showCompressedSize
	| size string |
	size := self originalFileSize.
	string := size = 0 
		ifTrue: ['Compressed size: not available']
		ifFalse: ['Compressed size: ' , size asStringWithCommas , ' bytes'].
	self world primaryHand attachMorph: ((TextMorph new)
				contents: string;
				beAllFont: ScriptingSystem fontForTiles)! !


!FlashMorph methodsFor: 'printing' stamp: 'ar 11/16/1998 11:40'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut:$[;
		print: self depth;
		space.
	self visible 
		ifTrue:[aStream nextPutAll:'visible']
		ifFalse:[aStream nextPutAll:'invisible'].
	aStream
		nextPutAll:' id = ';
		print: self id;
		nextPut:$];
		cr.! !


!FlashMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/24/1998 14:19'!
keepsTransform
	"Return true if the receiver will keep it's transform while being grabbed by a hand."
	^true! !


!FlashMorph methodsFor: 'sound' stamp: 'jm 6/7/1999 08:25'!
playFlashSound: aSound
	"Play the given sound at the volume level for Flash sounds."

	FlashSoundVolume ifNil: [FlashSoundVolume := 0.3].
	(MixedSound new add: aSound pan: 0.5 volume: FlashSoundVolume) play.
! !


!FlashMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 11/16/1998 16:13'!
delete
	| player |
	player := self flashPlayer.
	player ifNotNil:[player noticeRemovalOf: self].
	^super delete! !

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

FlashMorph class
	instanceVariableNames: ''!

!FlashMorph class methodsFor: 'instance creation' stamp: 'ar 11/15/1998 16:44'!
withAll: aCollection
	^(self new) 
		addAllMorphs: aCollection;
		computeBounds;
		yourself! !
FlashFileReader subclass: #FlashMorphReader
	instanceVariableNames: 'location fillStyles lineStyles shapes fonts forms sounds buttons lineSequence currentShape player spriteOwners stepTime frameRate frame activeMorphs passiveMorphs activeFont textOffset textHeight textMorph canCompressPoints pointList compressionBounds fillIndex0 fillIndex1 lineStyleIndex leftFillList rightFillList lineStyleList streamingSound morphedFillStyles morphedLineStyles'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Import'!

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:48'!
recordMorphBoundary: id
	self recordShapeEnd: id.
	morphedLineStyles keysAndValuesDo:[:idx :val| lineStyles at: idx put: val].
	morphedFillStyles keysAndValuesDo:[:idx :val| fillStyles at: idx put: val].
	location := 0@0.
	self beginShape.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:43'!
recordMorphFill: id color1: color1 color2: color2
	self recordSolidFill: id color: color2.
	morphedFillStyles at: id put: (fillStyles at: id).
	self recordSolidFill: id color: color1.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:43'!
recordMorphFill: id matrix1: matrix1 matrix2: matrix2 id: bmId clipped: aBool
	self recordBitmapFill: id matrix: matrix2 id: bmId clipped: aBool.
	morphedFillStyles at: id put: (fillStyles at: id).
	self recordBitmapFill: id matrix: matrix1 id: bmId clipped: aBool.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:44'!
recordMorphFill: id matrix1: matrix1 ramp1: ramp1 matrix2: matrix2 ramp2: ramp2 linear: isLinear
	self recordGradientFill: id matrix: matrix2 ramp: ramp2 linear: isLinear.
	morphedFillStyles at: id put: (fillStyles at: id).
	self recordGradientFill: id matrix: matrix1 ramp: ramp1 linear: isLinear.	! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:45'!
recordMorphLineStyle: id width1: lineWidth1 width2: lineWidth2 color1: lineColor1 color2: lineColor2
	self recordLineStyle: id width: lineWidth2 color: lineColor2.
	morphedLineStyles at: id put: (lineStyles at: id).
	self recordLineStyle: id width: lineWidth1 color: lineColor1.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:46'!
recordMorphShapeEnd: id
	| startShape endShape morphShape |
	startShape := shapes at: id.
	self recordShapeEnd: id.
	endShape := shapes at: id.
	morphShape := FlashMorphingMorph from: startShape to: endShape.
	morphShape id: id.
	morphShape stepTime: stepTime.
	shapes at: id put: morphShape.
	morphedLineStyles := morphedFillStyles := nil.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:42'!
recordMorphShapeStart: shapeId srcBounds: bounds1 dstBounds: bounds2
	morphedFillStyles := Dictionary new.
	morphedLineStyles := Dictionary new.
	location := 0@0.
	self logShapes ifFalse:[log := nil].
	self beginShape.! !


!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 8/14/1998 16:19'!
recordCurveSegmentTo: anchorPoint with: controlPoint
	| target midPoint |
	midPoint := location + controlPoint.
	target := midPoint + anchorPoint.
	self addLineFrom: location to: target via: midPoint.
	location := target.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/17/1998 00:36'!
recordEndSubshape
	"A new subshape begins with a full set of line and fill styles"
	self endShape.
	self beginShape.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/12/1998 20:45'!
recordFillStyle0: fillIndex
	fillIndex0 := fillIndex.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/12/1998 20:45'!
recordFillStyle1: fillIndex
	fillIndex1 := fillIndex.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/3/1998 16:09'!
recordLineSegmentBy: deltaPoint
	| target |
	target := location + deltaPoint.
	self addLineFrom: location to: target via: location.
	location := target.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/12/1998 20:40'!
recordLineStyle: styleIndex
	lineStyleIndex := styleIndex.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/12/1998 20:44'!
recordMoveTo: aPoint
	location := aPoint.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/16/1998 01:23'!
recordShapeEnd: shapeId
	| shape |
	self endShape.
	shape := FlashCharacterMorph withAll: (currentShape contents reversed).
	shape lockChildren.
	currentShape resetToStart.
	shape id: shapeId.
	shape stepTime: stepTime.
	shapes at: shapeId put: shape.
	self doLog ifTrue:[log := Transcript].! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 1/4/1999 08:47'!
recordShapeProperty: id length: length
	(shapes at: id ifAbsent:[^self]) setProperty: #originalFileSize toValue: length! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 8/14/1998 23:23'!
recordShapeStart: shapeId bounds: bounds
	location := 0@0.
	self logShapes ifFalse:[log := nil].
	self beginShape.! !


!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/3/1998 18:09'!
addLineFrom: start to: end via: via

	canCompressPoints ifTrue:[
		"Check if we can compress the incoming points"
		(compressionBounds containsPoint: start) ifFalse:[canCompressPoints := false].
		(compressionBounds containsPoint: via) ifFalse:[canCompressPoints := false].
		(compressionBounds containsPoint: end) ifFalse:[canCompressPoints := false].
	].
	pointList nextPut: start.
	pointList nextPut: via.
	pointList nextPut: end.
	leftFillList nextPut: fillIndex0.
	rightFillList nextPut: fillIndex1.
	lineStyleList nextPut: lineStyleIndex.
! !

!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/12/1998 21:43'!
beginShape

	canCompressPoints := true.
	fillStyles := Dictionary new.
	lineStyles := Dictionary new.
	pointList resetToStart.
	leftFillList resetToStart.
	rightFillList resetToStart.
	lineStyleList resetToStart.
	fillIndex0 := fillIndex1 := lineStyleIndex := 0.! !

!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/12/1998 21:24'!
computeFillLists
	"Compute the fill index lists"
	| leftFills rightFills |
	leftFills:= leftFillList contents as: ShortRunArray.
	rightFills := rightFillList contents as: ShortRunArray.
	^Array with: leftFills with: rightFills! !

!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/16/1998 13:02'!
computeLineStyleLists
	"Compute the line style index lists.
	Each line style will be splitted into two parts, the width and the fill.
	Then, the fills will be added to the fillStyles and the indexes will be adjusted.
	Finally, we compute two arrays containing the width of each line and the
	fill style of each line"
	| widthList fillList indexMap oldIndex newIndex allFillStyles style |
	allFillStyles := Dictionary new.
	fillStyles associationsDo:[:assoc| 
		allFillStyles at: assoc key put: assoc value].
	indexMap := Dictionary new.
	lineStyles associationsDo:[:assoc|
		oldIndex := assoc key.
		style := assoc value.
		allFillStyles at: allFillStyles size+1 put: (SolidFillStyle color: style color).
		newIndex := allFillStyles size.
		indexMap at: oldIndex put: newIndex.
	].
	widthList := OrderedCollection new: lineStyles size.
	fillList := OrderedCollection new: lineStyles size.
	lineStyleList contents do:[:index|
		index = 0 ifTrue:[
			widthList add: 0.
			fillList add: 0.
		] ifFalse:[
			style := lineStyles at: index ifAbsent:[FlashLineStyle color: Color black width: 20].
			widthList add: style width.
			fillList add: (indexMap at: index ifAbsent:[1]).
		].
	].
	widthList := widthList as: ShortRunArray.
	fillList := fillList as: ShortRunArray.
	^Array with: allFillStyles with: fillList with: widthList! !

!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/15/1998 15:32'!
endShape
	| points shape fillLists lineLists index |
	canCompressPoints ifTrue:[
		points := ShortPointArray new: pointList size.
	] ifFalse:[
		points := PointArray new: pointList size.
	].
	index := 1.
	pointList contents do:[:p|
		points at: index put: p.
		index := index + 1].

	fillLists := self computeFillLists.
	lineLists := self computeLineStyleLists.
	shape := FlashBoundaryShape 
				points: points 
				leftFills: fillLists first
				rightFills: fillLists last
				fillStyles: lineLists first
				lineWidths: lineLists last
				lineFills: (lineLists at: 2).
	shape remapFills.
	currentShape nextPut:(FlashShapeMorph shape: shape).! !


!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/20/1998 01:59'!
recordButton: buttonId actions: actionList condition: condition
	| button |
	button := buttons at: buttonId ifAbsent:[^self halt].
	(condition anyMask: 1) ifTrue:[
		button on: #mouseEnter sendAll: actionList.
	].
	(condition anyMask: 2) ifTrue:[
		button on: #mouseLeave sendAll: actionList.
	].
	(condition anyMask: 4) ifTrue:[
		button on: #mouseDown sendAll: actionList.
	].
	(condition anyMask: 8) ifTrue:[
		button on: #mouseUp sendAll: actionList.
	].
	(condition anyMask: 16) ifTrue:[
		button on: #mouseLeaveDown sendAll: actionList.
	].
	(condition anyMask: 32) ifTrue:[
		button on: #mouseEnterDown sendAll: actionList.
	].
	(condition anyMask: 64) ifTrue:[
		button on: #mouseUpOut sendAll: actionList.
	].
	(condition anyMask: 128) ifTrue:[
		button on: #mouseEnterDown sendAll: actionList.
	].
	(condition anyMask: 256) ifTrue:[
		button on: #mouseLeaveDown sendAll: actionList.
	].
! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'tk 2/16/2001 11:30'!
recordButton: buttonId character: characterId state: state layer: layer matrix: matrix colorTransform: cxForm
	| button children shape |
	button := buttons at: buttonId ifAbsent:[^self error: 'button missing'].
	button id: buttonId.
	shape := self oldMorphFromShape: characterId.
	shape isNil ifTrue:[^nil].
	children := shape submorphs collect:[:m| m veryDeepCopy].
	shape := FlashMorph withAll: children.
	shape lockChildren.
	shape depth: layer.
	shape transform: matrix.
	shape colorTransform: cxForm.
	(state anyMask: 1) ifTrue:[
		button defaultLook: shape.
	].
	(state anyMask: 2) ifTrue:[
		button overLook: shape.
	].
	(state anyMask: 4) ifTrue:[
		button pressLook: shape.
	].
	(state anyMask: 8) ifTrue:[
		button sensitiveLook: shape.
	].
	button lockChildren.! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/21/1998 02:20'!
recordButton: id sound: soundId info: soundInfo state: state
	"Give the button a sound"
	| button theSound |
	button := buttons at: id ifAbsent:[^self halt].
	theSound := self createSound: soundId info: soundInfo.
	theSound ifNil:[^self].
	button addSound: theSound forState: state.! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 20:51'!
recordButton: id trackAsMenu: aBoolean
	| button |
	button := buttons at: id ifAbsent:[^self halt].
	button trackAsMenu: aBoolean.
! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 20:36'!
recordDefineButton: id
	"Record the definition of a new button with the given id"
	| button |
	button := buttons at: id put: FlashButtonMorph new.
	button id: id.
	shapes at: id put: button.! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 21:11'!
recordEndButton: id
	"Record the end of a button definition with the given id"
! !


!FlashMorphReader methodsFor: 'defining sounds' stamp: 'jm 3/30/1999 09:43'!
flushStreamingSound

	| bufs sound |
	streamingSound buffers ifNil: [^ self].
	streamingSound buffers first position = 0 ifFalse: [
		bufs := streamingSound buffers collect: [:b | b contents].
		sound := self createSoundFrom: bufs
					stereo: streamingSound stereo
					samplingRate: streamingSound samplingRate.
		player addSound: sound at: streamingSound firstFrame].
	streamingSound firstFrame: frame.
	streamingSound frameNumber: frame.
	streamingSound buffers do: [:s | s reset].
! !

!FlashMorphReader methodsFor: 'defining sounds' stamp: 'ar 11/20/1998 22:38'!
recordSound: id data: aSampledSound
	aSampledSound ifNotNil:[sounds at: id put: aSampledSound]! !

!FlashMorphReader methodsFor: 'defining sounds' stamp: 'jm 3/30/1999 09:14'!
recordSoundStreamBlock: data

	| newBufs |
	streamingSound frameNumber + 1 = frame 
		ifFalse: [self flushStreamingSound].
	newBufs := ADPCMCodec new
		decodeFlash: data
		sampleCount: streamingSound sampleCount
		stereo: streamingSound stereo.
	streamingSound buffers with: newBufs do:
		[:streamBuf :newBuf | streamBuf nextPutAll: newBuf].
	streamingSound frameNumber: frame.
! !

!FlashMorphReader methodsFor: 'defining sounds' stamp: 'ar 11/21/1998 00:53'!
recordSoundStreamHead: mixFmt stereo: stereo bitsPerSample: bitsPerSample sampleCount: sampleCount compressed: compressed
	streamingSound buffers isNil ifFalse:[self flushStreamingSound].
	streamingSound mixFmt: mixFmt.
	streamingSound stereo: stereo.
	streamingSound bitsPerSample: bitsPerSample.
	streamingSound sampleCount: sampleCount.
	streamingSound compressed: compressed.
	streamingSound samplingRate: (frameRate * sampleCount) truncated.
	streamingSound buffers: (self createSoundBuffersOfSize: sampleCount stereo: stereo).
	streamingSound firstFrame: frame.
	streamingSound frameNumber: frame.
! !

!FlashMorphReader methodsFor: 'defining sounds' stamp: 'ar 11/20/1998 22:38'!
recordStartSound: id info: info
	| theSound |
	theSound := self createSound: id info: info.
	theSound ifNotNil:[player addSound: theSound at: frame].! !


!FlashMorphReader methodsFor: 'defining styles' stamp: 'ar 12/5/1998 22:22'!
recordBitmapFill: index matrix: bmMatrix id: bitmapID clipped: aBoolean
	| fillStyle form |
	form := forms at: bitmapID ifAbsent:[^nil].
	fillStyle := BitmapFillStyle form: form.
	fillStyle origin: (bmMatrix localPointToGlobal: 0@0).
	fillStyle direction: (bmMatrix localPointToGlobal: form extent x @ 0) - fillStyle origin.
	fillStyle normal: (bmMatrix localPointToGlobal: 0 @ form extent y) - fillStyle origin.
	fillStyle tileFlag: aBoolean not.
	fillStyles at: index put: fillStyle.! !

!FlashMorphReader methodsFor: 'defining styles' stamp: 'ar 11/18/1998 21:36'!
recordGradientFill: fillIndex matrix: gradientMatrix ramp: colorRampArray linear: aBoolean
	| fillStyle ramp origin direction normal |
	ramp := colorRampArray collect:[:assoc| (assoc key / 255.0) -> assoc value].
	origin := gradientMatrix localPointToGlobal: (aBoolean ifFalse:[0@0] ifTrue:[-16384@0]).
	direction := (gradientMatrix localPointToGlobal: (16384@0)) - origin.
	normal := (gradientMatrix localPointToGlobal: (0@16384)) - origin.
	fillStyle := GradientFillStyle ramp: ramp.
	fillStyle origin: origin.
	fillStyle direction: direction.
	fillStyle normal: normal.
	fillStyle radial: aBoolean not.
	fillStyle pixelRamp. "Force creation beforehand"
	fillStyles at: fillIndex put: fillStyle.! !

!FlashMorphReader methodsFor: 'defining styles' stamp: 'ar 8/15/1998 00:58'!
recordLineStyle: styleIndex width: lineWidth color: lineColor
	lineStyles at: styleIndex put: (FlashLineStyle color: lineColor width: lineWidth).! !

!FlashMorphReader methodsFor: 'defining styles' stamp: 'ar 11/11/1998 22:39'!
recordSolidFill: index color: fillColor
	fillStyles at: index put: (SolidFillStyle color: fillColor)! !


!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/16/1998 01:23'!
recordFontShapeEnd: fontId with: charId
	| font shape |
	self endShape.
	shape := FlashGlyphMorph withAll: currentShape contents reversed.
	shape lockChildren.
	currentShape resetToStart.
	font := fonts at: fontId ifAbsentPut:[Dictionary new].
	font at: charId put: shape.
	self doLog ifTrue:[log := Transcript].! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/12/1998 21:39'!
recordFontShapeStart: fontId with: charId
	location := 0@0.
	self logShapes ifFalse:[log := nil].
	self beginShape.
	self recordSolidFill: 1 color: Color black.! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'tk 2/15/2001 16:34'!
recordNextChar: glyphIndex advanceWidth: advance
	| shape transform |
	(activeFont includesKey: glyphIndex) ifTrue:[
		shape := (activeFont at: glyphIndex) veryDeepCopy reset.
		"Must include the textMorph's transform here - it might be animated"
		transform :=  ((MatrixTransform2x3 withOffset: textOffset) 
							setScale: (textHeight@textHeight) / 1024.0).
		transform := transform composedWithGlobal: textMorph transform.
		shape transform: transform.
		shape color: textMorph color.
		textMorph addMorphBack: shape.].
	textOffset := textOffset + (advance@0).! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 01:46'!
recordTextChange: fontId color: color xOffset: xOffset yOffset: yOffset height: height

	fontId ifNotNil:[activeFont := fonts at: fontId].
	height ifNotNil:[textHeight := height].
	xOffset ifNotNil:[textOffset := xOffset @ textOffset x].
	yOffset ifNotNil:[textOffset := textOffset x @ yOffset].
	color ifNotNil:[textMorph color: color].! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 00:50'!
recordTextEnd: id
	textMorph submorphs isEmpty ifFalse:[
		textMorph allMorphsDo:[:m| m color: textMorph color].
		textMorph transform: nil.
		textMorph id: id.
		textMorph stepTime: stepTime.
		textMorph lockChildren.
		shapes at: id put: textMorph].
	self doLog ifTrue:[log := Transcript].! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 01:41'!
recordTextStart: id bounds: bounds matrix: matrix

	textOffset := 0@0.
	textMorph := FlashTextMorph new.
	textMorph privateBounds: bounds.
	textMorph color: Color black.
	matrix ifNotNil:[textMorph transform: matrix].! !


!FlashMorphReader methodsFor: 'initialize' stamp: 'ar 10/15/1998 23:45'!
doLog
	^false! !

!FlashMorphReader methodsFor: 'initialize' stamp: 'ar 10/14/1998 19:22'!
logShapes
	^false! !

!FlashMorphReader methodsFor: 'initialize' stamp: 'ar 11/21/1998 00:30'!
on: aStream
	super on: aStream.
	self doLog ifTrue:[log := Transcript].
	fillStyles := Dictionary new.
	lineStyles := Dictionary new.
	shapes := Dictionary new.
	player := FlashPlayerMorph new.
	fonts := Dictionary new.
	forms := Dictionary new.
	sounds := Dictionary new.
	buttons := Dictionary new.
	spriteOwners := IdentityDictionary new.
	stepTime := 1000.
	frame := 1.
	activeMorphs := Dictionary new: 100.
	passiveMorphs := Dictionary new: 100.
	self recordSolidFill: 1 color: Color black.
	compressionBounds := (-16r7FFF asPoint) corner: (16r8000) asPoint.
	currentShape := WriteStream on: (Array new: 5).
	pointList := WriteStream on: (Array new: 100).
	leftFillList := WriteStream on: (WordArray new: 100).
	rightFillList := WriteStream on: (WordArray new: 100).
	lineStyleList := WriteStream on: (WordArray new: 100).
	fillIndex0 := fillIndex1 := lineStyleIndex := 0.
	streamingSound := FlashStreamingSound new.! !


!FlashMorphReader methodsFor: 'misc' stamp: 'ar 10/15/1998 20:44'!
recordBackgroundColor: aColor
	player color: aColor! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/19/1998 20:30'!
recordBeginSprite: id frames: frameCount
	| sprite |
	sprite := FlashSpriteMorph new.
	sprite maxFrames: frameCount.
	sprite stepTime: stepTime.
	spriteOwners at: sprite put: (
		Array with: player 
			with: frame
			with: activeMorphs
			with: passiveMorphs).
	player := sprite.
	frame := 1.
	activeMorphs := Dictionary new: 100.
	passiveMorphs := Dictionary new: 100.
! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/12/1998 21:50'!
recordBitmap: id data: aForm
	aForm ifNil:[^self].
	"Record the current form"
	forms at: id put: aForm.
	"Define a new character"
! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/24/1998 14:35'!
recordEndSprite: id
	| shape sprite |
	sprite := player.
	player := (spriteOwners at: sprite) at: 1.
	frame := (spriteOwners at: sprite) at: 2.
	activeMorphs := (spriteOwners at: sprite) at: 3.
	passiveMorphs := (spriteOwners at: sprite) at: 4.
	spriteOwners removeKey: sprite.
	sprite loadInitialFrame.
	shape := FlashCharacterMorph withAll: (Array with: sprite).
	shape id: id.
	shape isSpriteHolder: true.
	shape stepTime: stepTime.
	shapes at: id put: shape.
	shape lockChildren.
! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/16/1998 22:53'!
recordFrameActions: actionList
	player addActions: actionList atFrame: frame.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/18/1998 22:00'!
recordFrameCount: maxFrames
	player maxFrames: maxFrames! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/17/1998 13:36'!
recordFrameLabel: label
	"Name the current frame with the given label"
	player addLabel: label atFrame: frame.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/21/1998 00:32'!
recordFrameRate: fps
	frameRate := fps.
	fps > 0.0 ifTrue:[stepTime := (1000.0 / fps) rounded].
	player stepTime: stepTime.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/18/1998 20:42'!
recordGlobalBounds: bounds
	player localBounds: bounds.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 9/3/1999 15:10'!
recordMorph: id depth: depth ratio: ratio! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 9/3/1999 15:50'!
recordMoveObject: objectIndex name: aString depth: depth matrix: matrix colorMatrix: colorMatrix ratio: ratio
	| index oldObj mat |
	index := nil.
	activeMorphs do:[:list|
		list do:[:morph|
			((morph visibleAtFrame: frame-1) and:[
				(morph depthAtFrame: frame-1) = depth])
					ifTrue:[index := morph id]]].
	oldObj := self recordRemoveObject: index depth: depth.
	oldObj isNil ifTrue:[^self].
	objectIndex isNil ifFalse:[index := objectIndex].
	matrix isNil 
		ifTrue:[mat := oldObj matrixAtFrame: frame]
		ifFalse:[mat := matrix].
	self recordPlaceObject: index name: aString depth: depth matrix: mat colorMatrix: colorMatrix ratio: ratio.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 9/3/1999 15:50'!
recordPlaceObject: objectIndex name: aString depth: depth matrix: matrix colorMatrix: colorTransform ratio: ratio
	| cached active doLoad |
	cached := passiveMorphs at: objectIndex ifAbsent:[#()].
	cached size >= 1 
		ifTrue:["Got an old morph. Re-use it"
				doLoad := false.
				active := cached first.
				passiveMorphs at: objectIndex put: (cached copyWithout: active)]
		ifFalse:["Need a new morph"
				doLoad := true.
				active := self newMorphFromShape: objectIndex.
				active isNil ifTrue:[^self].
				active reset.
				active visible: false atFrame: frame - 1].
	active isNil ifTrue:[^self].
	active visible: true atFrame: frame.
	active depth: depth atFrame: frame.
	active matrix:  matrix atFrame: frame.
	active colorTransform: colorTransform atFrame: frame.
	doLoad ifTrue:[
		active loadInitialFrame.
		player addMorph: active].
	cached := (activeMorphs at: objectIndex ifAbsent:[#()]) copyWith: active.
	activeMorphs at: objectIndex put: cached.
	aString ifNotNil:[active setNameTo: aString].
	ratio ifNotNil:[active ratio: ratio atFrame: frame].! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/21/1998 01:57'!
recordRemoveObject: id depth: depth
	id ifNotNil:["Faster if id is given"
		(activeMorphs at: id ifAbsent:[#()]) do:[:morph|
			((morph visibleAtFrame: frame-1) and:[
				(morph depthAtFrame: frame-1) = depth]) 
					ifTrue:[^self removeActiveMorph: morph]]].
	activeMorphs do:[:list|
		list do:[:morph|
			((morph visibleAtFrame: frame-1) and:[
				(morph depthAtFrame: frame-1) = depth]) 
					ifTrue:[^self removeActiveMorph: morph]]].
	Transcript cr; nextPutAll:'Shape (id = '; print: id; nextPutAll:' depth = '; print: depth; nextPutAll:') not removed in frame '; print: frame; endEntry.
	^nil! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/19/1998 20:30'!
recordShowFrame
	player loadedFrames: frame.
	frame := frame + 1.! !


!FlashMorphReader methodsFor: 'reading' stamp: 'ar 2/13/1999 21:25'!
processFile
	"Read and process the entire file"
	super processFile.
	player loadInitialFrame.
	^player! !

!FlashMorphReader methodsFor: 'reading' stamp: 'ar 11/19/1998 21:54'!
processFileAsync
	"Read and process the entire file"
	self processHeader ifFalse:[^nil].
	player sourceUrl:'dummy'.
	[self processFileContents] fork.
	^player! !

!FlashMorphReader methodsFor: 'reading' stamp: 'ar 11/18/1998 23:44'!
processFileAsync: aPlayer
	"Read and process the entire file"
	player := aPlayer.
	super processFile.! !

!FlashMorphReader methodsFor: 'reading' stamp: 'ar 11/21/1998 00:50'!
processFileContents
	super processFileContents.
	self flushStreamingSound.! !


!FlashMorphReader methodsFor: 'testing' stamp: 'ar 11/18/1998 21:37'!
isStreaming
	^player isStreaming! !


!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/20/1998 01:04'!
createSound: id info: info
	| theSound loops |
	theSound := sounds at: id ifAbsent:[^nil].
	loops := info loopCount.
	loops <= 1 ifTrue:[^theSound].
	^RepeatingSound repeat: theSound count: loops! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/16/1998 19:39'!
myActiveMorphs
	| out |
	out := WriteStream on: (Array new: 10).
	activeMorphs do:[:array| out nextPutAll: array].
	^out contents! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/16/1998 19:26'!
myFlush
		Transcript endEntry.
		Sensor leftShiftDown ifTrue:[self halt].! !

!FlashMorphReader methodsFor: 'private' stamp: 'tk 2/15/2001 16:33'!
newMorphFromShape: objectIndex
	"Return a new character morph from the given object index.
	If the character morph at objectIndex is already used, then create and return a full copy of it"
	| prototype |

	prototype := self oldMorphFromShape: objectIndex.
	prototype isNil ifTrue:[^nil].
	^(prototype owner notNil) 
		ifTrue:[prototype veryDeepCopy]
		ifFalse:[prototype].! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/16/1998 20:24'!
oldMorphFromShape: objectIndex
	"Return an existing character morph from the given object index."
	| prototype |
	prototype := shapes at: objectIndex ifAbsent:[nil].
	"prototype ifNil:[prototype := buttons at: objectIndex ifAbsent:[nil]]."
	prototype ifNil:[Transcript cr; nextPutAll:'No shape for '; print: objectIndex; nextPutAll:' in frame '; print: frame; endEntry].
	^prototype! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 8/15/1998 15:27'!
placeGlyph: aMorph at: position
	aMorph privateFullMoveBy: position.! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/16/1998 21:55'!
removeActiveMorph: aMorph
	| newActive newPassive |
	aMorph visible: false atFrame: frame.
	newActive := (activeMorphs at: aMorph id) copyWithout: aMorph.
	newPassive := (passiveMorphs at: aMorph id ifAbsent:[#()]) copyWith: aMorph.
	activeMorphs at: aMorph id put: newActive.
	passiveMorphs at: aMorph id put: newPassive.
	^aMorph! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 8/15/1998 15:28'!
resizeGlyph: aMorph to: extent
	aMorph extent: 1440@1440.
	aMorph extent: extent.! !

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

FlashMorphReader class
	instanceVariableNames: ''!

!FlashMorphReader class methodsFor: 'class initialization' stamp: 'hg 8/1/2000 20:07'!
initialize

	FileList registerFileReader: self! !

!FlashMorphReader class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !


!FlashMorphReader class methodsFor: 'read Flash file' stamp: 'sd 2/6/2002 21:35'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'swf') | (suffix = '*') 
		ifTrue: [ self services]
		ifFalse: [#()]
! !

!FlashMorphReader class methodsFor: 'read Flash file' stamp: 'hg 8/3/2000 16:04'!
openAsFlash: fullFileName
	"Open a MoviePlayerMorph on the file (must be in .movie format)."
	| f player |
	f := (FileStream readOnlyFileNamed: fullFileName) binary.
	player := (FlashMorphReader on: f) processFile.
	player startPlaying.
	player open.
! !

!FlashMorphReader class methodsFor: 'read Flash file' stamp: 'sw 2/17/2002 02:42'!
serviceOpenAsFlash
	"Answer a service for opening a flash file"

	^ SimpleServiceEntry 
				provider: self 
				label: 'open as Flash'
				selector: #openAsFlash:
				description: 'open file as flash'
				buttonLabel: 'open'! !

!FlashMorphReader class methodsFor: 'read Flash file' stamp: 'sd 2/1/2002 22:09'!
services

	^ Array with: self serviceOpenAsFlash! !
FlashCharacterMorph subclass: #FlashMorphingMorph
	instanceVariableNames: 'srcShapes dstShapes morphShapes'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashMorphingMorph methodsFor: 'copying' stamp: 'dgd 2/21/2003 23:04'!
updateReferencesUsing: aDictionary 
	| srcMorph dstMorph |
	super updateReferencesUsing: aDictionary.
	srcMorph := submorphs at: submorphs size - 1.
	dstMorph := submorphs last.
	self removeAllMorphs.
	self from: srcMorph to: dstMorph! !


!FlashMorphingMorph methodsFor: 'initialize' stamp: 'ar 9/3/1999 16:58'!
extractShapesFrom: aMorph
	| shapes |
	shapes := WriteStream on: Array new.
	aMorph allMorphsDo:[:m|
		(m isFlashMorph and:[m isFlashShape])
			ifTrue:[shapes nextPut: m shape].
	].
	^shapes contents.
! !

!FlashMorphingMorph methodsFor: 'initialize' stamp: 'ar 9/3/1999 18:35'!
from: srcMorph to: dstMorph
	| shape |
	"Note: Add srcMorph and dstMorph to the receiver so the damned bounds will be correct."
	self addMorphBack: srcMorph.
	self addMorphBack: dstMorph.
	self computeBounds.
	srcShapes := self extractShapesFrom: srcMorph.
	dstShapes := self extractShapesFrom: dstMorph.
	srcShapes size = dstShapes size ifFalse:[^self error:'Shape size mismatch'].
	1 to: srcShapes size do:[:i|
		(srcShapes at: i) numSegments = (dstShapes at: i) numSegments
			ifFalse:[^self error:'Edge size mismatch']].
	morphShapes := WriteStream on: Array new.
	srcShapes do:[:s|
		shape := FlashBoundaryShape
					points: s points copy
					leftFills: s leftFills
					rightFills: s rightFills
					fillStyles: s fillStyles
					lineWidths: s lineWidths
					lineFills: s lineFills.
		morphShapes nextPut: shape.
		self addMorphFront: (FlashShapeMorph shape: shape)].
	morphShapes := morphShapes contents.
	srcMorph visible: false.
	dstMorph visible: false.! !


!FlashMorphingMorph methodsFor: 'stepping' stamp: 'ar 9/3/1999 18:50'!
morphTo: ratio
	| srcShape dstShape morphShape |
	1 to: morphShapes size do:[:i|
		srcShape := srcShapes at: i.
		dstShape := dstShapes at: i.
		morphShape := morphShapes at: i.
		morphShape morphFrom: srcShape to: dstShape at: ratio].		! !

!FlashMorphingMorph methodsFor: 'stepping' stamp: 'ar 9/3/1999 18:38'!
stepToFrame: frameNumber
	| ratio |
	super stepToFrame: frameNumber.
	self visible ifTrue:[
		ratio := self ratioAtFrame: frame.
		self morphTo: ratio.
		self changed].! !

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

FlashMorphingMorph class
	instanceVariableNames: ''!

!FlashMorphingMorph class methodsFor: 'instance creation' stamp: 'ar 9/3/1999 16:53'!
from: srcMorph to: dstMorph
	^self new from: srcMorph to: dstMorph! !
Model subclass: #FlashPlayerModel
	instanceVariableNames: 'player'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 14:47'!
initialExtent
	^player bounds extent! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:02'!
isStreaming
	^player isStreaming! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:33'!
loadedFrames
	^player loadedFrames! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:02'!
maxFrames
	^player maxFrames! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 14:45'!
player: flashPlayer
	player := flashPlayer! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:42'!
progressValue
	^player progressValue! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:45'!
startPlaying
	player startPlaying! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:43'!
stopPlaying
	player stopPlaying! !

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

FlashPlayerModel class
	instanceVariableNames: ''!

!FlashPlayerModel class methodsFor: 'instance creation' stamp: 'ar 11/17/1998 14:45'!
player: flashPlayer
	^self new player: flashPlayer! !
FlashSpriteMorph subclass: #FlashPlayerMorph
	instanceVariableNames: 'activationKeys activeMorphs localBounds sourceUrl progressValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 2/10/1999 03:37'!
activeMorphs
	^activeMorphs! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:13'!
deferred
	^self hasProperty:#deferred! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:14'!
deferred: aBoolean
	aBoolean 
		ifTrue:[self setProperty: #deferred toValue: true]
		ifFalse:[self removeProperty: #deferred]! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 21:46'!
isStreaming
	"Return true if we're in streaming mode"
	^sourceUrl notNil! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 23:40'!
loadedFrames: aNumber 
	self isStreaming
		ifTrue: 
			[activationKeys := self collectActivationKeys: aNumber.
			aNumber = 1
				ifTrue: 
					[activeMorphs addAll: activationKeys first.
					self changed].
			progressValue contents: aNumber asFloat / maxFrames.
			"Give others a chance"
			Smalltalk isMorphic
				ifTrue: [World doOneCycle]
				ifFalse: [Processor yield]].
	loadedFrames := aNumber! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 00:56'!
localBounds
	^localBounds ifNil:[localBounds := self transform globalBoundsToLocal: self bounds]! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 20:43'!
localBounds: newBounds

	localBounds := newBounds.
	bounds := (self position extent: newBounds extent // 20).
	transform := MatrixTransform2x3 
					transformFromLocal: newBounds 
					toGlobal: bounds! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:17'!
loopFrames
	^(self valueOfProperty: #loopFrames) ifNil:[false]! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 10/15/1998 02:51'!
loopFrames: aBoolean
	self setProperty: #loopFrames toValue: aBoolean! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:33'!
progressValue
	^progressValue! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:33'!
progressValue: aValueHolder
	progressValue := aValueHolder! !


!FlashPlayerMorph methodsFor: 'classification' stamp: 'ar 11/15/1998 19:05'!
isFlashPlayer
	^true! !


!FlashPlayerMorph methodsFor: 'copying' stamp: 'ar 5/20/1999 12:16'!
copyMovieFrom: firstFrame to: lastFrame
	"Create a copy of the receiver containing the given frames"
	| player delta actionList newMorphs |
	delta := firstFrame - 1.
	player := FlashPlayerMorph new.
	player bounds: self bounds.
	player localBounds: self localBounds.
	player maxFrames: lastFrame - firstFrame + 1.
	player loadedFrames: player maxFrames.
	player stepTime: stepTime.
	player color: self color.
	"Copy the sounds, actions and labels"
	sounds associationsDo:[:sndAssoc|
		(sndAssoc key between: firstFrame and: lastFrame) ifTrue:[
			sndAssoc value do:[:snd|
				player addSound: snd at: sndAssoc key - delta]]].
	actions associationsDo:[:action|
		actionList := action value collect:[:a|
			a selector == #gotoFrame: 
				ifTrue:[Message selector: a selector argument: (a argument - delta)]
				ifFalse:[a]].
		(action key between: firstFrame and: lastFrame)
			ifTrue:[player addActions: actionList atFrame: action key - delta]].
	labels associationsDo:[:label|
		(label value between: firstFrame and: lastFrame)
			ifTrue:[player addLabel: label key atFrame: label value - delta]].
	"Finally, copy the morphs"
	newMorphs := submorphs 
					select:[:m| m isVisibleBetween: firstFrame and: lastFrame]
					thenCollect:[:m| m copyMovieFrom: firstFrame to: lastFrame].
	player addAllMorphs: newMorphs.
	player loadInitialFrame.
	player stepToFrame: 1.
	^player! !


!FlashPlayerMorph methodsFor: 'disk i/o'!
compress
	super compress.
	activeMorphs := activeMorphs asOrderedCollection! !

!FlashPlayerMorph methodsFor: 'disk i/o'!
decompress
	super decompress.
	activeMorphs := activeMorphs asSortedCollection: [:a :b | a depth > b depth]! !


!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 5/25/2000 17:58'!
debugDraw
	self fullDrawOn: (Display getCanvas)! !

!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:34'!
drawOn: aCanvas 
	"Draw the background of the player"
	| box bgImage |
	box := self bounds.
	bgImage := self valueOfProperty: #transitionBackground ifAbsent:[nil].
	bgImage 
		ifNil:[aCanvas fillRectangle: box color: color]
		ifNotNil:[aCanvas drawImage: bgImage at: box origin].! !

!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:49'!
drawSubmorphsOn: aCanvas
	| myCanvas |
	aCanvas clipBy: self bounds during:[:tempCanvas|
		myCanvas := tempCanvas asBalloonCanvas.
		myCanvas aaLevel: (self defaultAALevel ifNil:[1]).
		myCanvas deferred: self deferred.
		myCanvas transformBy: self transform during:[:childCanvas| 
			activeMorphs reverseDo:[:m| childCanvas fullDrawMorph: m]].
		myCanvas flush].
! !

!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 5/19/1999 17:57'!
imageFormOfSize: extentPoint forFrame: frameNr
	"Create an image of the given size for the given frame number"
	| thumbTransform form canvas morphsToDraw |
	thumbTransform := MatrixTransform2x3 
						transformFromLocal: localBounds 
						toGlobal: (0@0 extent: extentPoint).
	form := Form extent: extentPoint depth: 8.
	form fillColor: self color.
	canvas := BalloonCanvas on: form.
	canvas transformBy: thumbTransform.
	canvas aaLevel: (self defaultAALevel ifNil:[1]).
	canvas deferred: true.
	morphsToDraw := (submorphs select:[:m|
		m stepToFrame: frameNr.
		m visible]) sortBy:[:m1 :m2| m1 depth > m2 depth].
	morphsToDraw reverseDo:[:m|
		m fullDrawOn: canvas].
	submorphs do:[:m| m stepToFrame: frameNumber].
	canvas flush.
	^form! !


!FlashPlayerMorph methodsFor: 'e-toy support' stamp: 'nk 1/6/2004 12:36'!
asWearableCostumeOfExtent: extent
	"Return a wearable costume for some player"
	| image oldExtent |
	oldExtent := self extent.
	self extent: extent.
	image := self imageForm.
	self extent: oldExtent.
	image mapColor: self color to: Color transparent.
	^(World drawingClass withForm: image) copyCostumeStateFrom: self! !

!FlashPlayerMorph methodsFor: 'e-toy support' stamp: 'mir 6/12/2001 12:07'!
cursor 
	^self frameNumber
! !

!FlashPlayerMorph methodsFor: 'e-toy support' stamp: 'mir 6/12/2001 12:08'!
cursor: aNumber
	"for backward compatibility"

	self cursorWrapped: aNumber! !


!FlashPlayerMorph methodsFor: 'geometry' stamp: 'ar 2/3/2000 17:23'!
boundsChangedFrom: oldBounds to: newBounds
	| newWidth newLeft |
	newWidth := localBounds width * newBounds height // localBounds height.
	newLeft := newBounds left + (newBounds width - newWidth // 2).
	transform := MatrixTransform2x3
		transformFromLocal: localBounds
		toGlobal: (newLeft @ newBounds top extent: newWidth @ newBounds height).! !

!FlashPlayerMorph methodsFor: 'geometry' stamp: 'ar 11/16/1998 01:06'!
computeBounds
	"Do nothing."! !


!FlashPlayerMorph methodsFor: 'geometry testing' stamp: 'ar 6/2/1999 02:41'!
containsPoint: aPoint
	^self bounds containsPoint: aPoint! !

!FlashPlayerMorph methodsFor: 'geometry testing' stamp: 'ar 11/19/1998 20:48'!
fullContainsPoint: pt
	"The player clips its children"
	(bounds containsPoint: pt) ifFalse:[^false].
	^super fullContainsPoint: pt! !


!FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 15:05'!
cursorWrapped: aNumber
	"Set the cursor to the given number, modulo the number of items I contain. Fractional cursor values are allowed."
	| nextFrame |
	nextFrame := aNumber truncated abs.
	nextFrame >= self maxFrames
		ifTrue: [nextFrame := 1].
	self stepToFrame: nextFrame! !

!FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 12:30'!
numberAtCursor
	"Answer the number represented by the object at my current cursor position"
	^0! !

!FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 12:32'!
selectedRect
	"Return a rectangle enclosing the morph at the current cursor. Note that the cursor may be a float and may be out of range, so pick the nearest morph. Assume there is at least one submorph."
	self transform localBoundsToGlobal: self localBounds! !

!FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 12:32'!
valueAtCursor
	"Answer the submorph of mine indexed by the value of my 'cursor' slot"
	^self! !

!FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 12:33'!
valueAtCursor: aMorph
	self shouldNotImplement! !


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

!FlashPlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self loopFrames: true.
	localBounds := bounds.
	activationKeys := #().
	activeMorphs := SortedCollection new: 50.
	activeMorphs
		sortBlock: [:m1 :m2 | m1 depth > m2 depth].
	progressValue := ValueHolder new.
	progressValue contents: 0.0.
	self defaultAALevel: 2.
	self deferred: true! !


!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/19/1998 22:53'!
downloadState
	| doc |
	doc := sourceUrl retrieveContents.
	(FlashMorphReader on: doc contentStream binary) processFileAsync: self.
	self startPlaying.! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/19/1998 23:09'!
downloadStateIn: aScamper
	| doc |
	doc := sourceUrl retrieveContents.
	(FlashMorphReader on: doc contentStream binary) processFileAsync: self.
	"Wait until the first frame is there"
	[loadedFrames = 0] whileTrue:[(Delay forMilliseconds: 100) wait].
	aScamper invalidateLayout.
	self startPlaying.! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/19/1998 20:31'!
loadInitialFrame
	"Note: Must only be sent to a player if not in streaming mode"
	self isStreaming ifTrue:[^self].
	super loadInitialFrame.
	activationKeys := self collectActivationKeys: maxFrames.
	activeMorphs := SortedCollection new: 50.
	activeMorphs sortBlock:[:m1 :m2| m1 depth > m2 depth].
	activeMorphs addAll: activationKeys first.! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'tk 2/19/2001 17:47'!
makeControls

	| bb r loopSwitch |
	r := AlignmentMorph newRow.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: 'Rewind';		actionSelector: #rewind).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: 'Play';		actionSelector: #startPlaying).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: 'Pause';		actionSelector: #stopPlaying).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: 'Next';		actionSelector: #stepForward).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: 'Prev';		actionSelector: #stepBackward).
	loopSwitch := SimpleSwitchMorph new
		borderWidth: 2;
		label: 'Loop';
		actionSelector: #loopFrames:;
		target: self;
		setSwitchState: self loopFrames.
	r addMorphBack: loopSwitch.
	loopSwitch := SimpleSwitchMorph new
		borderWidth: 2;
		label: 'Defer';
		actionSelector: #toggleDeferred;
		target: self;
		setSwitchState: self deferred.
	r addMorphBack: loopSwitch.
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: 'Fastest'; 	actionSelector: #drawFastest).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: 'Medium';	actionSelector: #drawMedium).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: 'Nicest';		actionSelector: #drawNicest).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
				borderWidth: 2.
	r addMorphBack: (bb label: '+10';		actionSelector: #jump10).
	^ self world activeHand attachMorph: r! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/18/1998 21:40'!
open
	Smalltalk isMorphic 
		ifTrue:[self openInWorld]
		ifFalse:[self openInMVC]! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'dgd 9/20/2003 16:42'!
openInMVC
	| window extent |
	self localBounds: localBounds.
	extent := bounds extent.
	window := FlashPlayerWindow labelled:'Flash Player' translated.
	window model: (FlashPlayerModel player: self).
	window addMorph: self frame:(0@0 corner: 1@1).
	window openInMVCExtent: extent! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'dgd 9/20/2003 16:42'!
openInWorld
	| window extent |
	self localBounds: localBounds.
	extent := bounds extent.
	window := FlashPlayerWindow labelled:'Flash Player' translated.
	window model: (FlashPlayerModel player: self).
	window addMorph: self frame:(0@0 corner: 1@1).
	window openInWorldExtent: extent! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/18/1998 19:21'!
sourceUrl: urlString
	sourceUrl := urlString! !


!FlashPlayerMorph methodsFor: 'layout' stamp: 'ar 11/15/1998 16:07'!
fullBounds
	"The player clips its children"
	^bounds! !


!FlashPlayerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:42'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'open sorter' translated action: #openSorter.
	aCustomMenu add: 'make controls' translated action: #makeControls.
	aCustomMenu addLine.! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 12/30/1998 14:44'!
drawFastest
	self defaultAALevel: 1.
	self changed.! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 12/30/1998 14:44'!
drawMedium
	self defaultAALevel: 2.
	self changed.! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 12/30/1998 14:44'!
drawNicest
	self defaultAALevel: 4.
	self changed.! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 5/19/1999 16:28'!
openSorter
	(FlashSorterMorph new on: self) openInWindow! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 12/30/1998 11:33'!
toggleDeferred
	self deferred: self deferred not.
	self changed.! !


!FlashPlayerMorph methodsFor: 'player' stamp: 'mir 6/13/2001 14:45'!
shouldRememberCostumes
	^false! !


!FlashPlayerMorph methodsFor: 'project transition' stamp: 'dao 10/1/2004 13:22'!
addFillForProjectTarget: aFillStyle
	| fillStyles |
	fillStyles := self valueOfProperty: #projectTargetFills ifAbsent:[IdentityDictionary new].
	(fillStyles includesKey: aFillStyle) ifTrue:[^self].
	fillStyles at: aFillStyle put: aFillStyle form.
	self setProperty: #projectTargetFills toValue: fillStyles.
	self updateProjectFillsFrom: Project current.
	self changed.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'ar 6/2/1999 05:59'!
beFullScreenTransition: aBoolean
	"Make the receiver a full-screen transition if requested"
	self setProperty: #fullScreenTransition toValue: true.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'dao 10/1/2004 13:35'!
beTransitionFrom: srcProjectName

	^self beTransitionFrom: srcProjectName to: Project current name! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'dao 10/1/2004 13:19'!
beTransitionFrom: srcProjectName to: dstProjectName
	"Make the receiver the animation between the two projects"
	| srcProject dstProject |
	srcProject := Project namedOrCurrent: srcProjectName.
	dstProject := Project namedOrCurrent: dstProjectName.
	(dstProject projectParameters at: #flashTransition ifAbsentPut:[IdentityDictionary new])
		at: srcProject put: self.
! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'dao 10/1/2004 13:35'!
beTransitionTo: dstProjectName

	^self beTransitionFrom: Project current name to: dstProjectName! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'ar 8/10/2003 18:17'!
playProjectTransitionFrom: oldProject to: newProject entering: aBoolean
	"Play the transition from the old to the new project."

	Smalltalk isMorphic ifFalse: [^ self]. "Not in MVC"
	self stopPlaying.
	owner ifNotNil:[
		self stopStepping.
		owner removeMorph: self].
	aBoolean ifTrue:[
		self updateProjectFillsFrom: newProject.
	] ifFalse:[
		self updateProjectFillsFrom: oldProject.
		self setProperty: #transitionBackground toValue: newProject imageForm.
	].
	self frameNumber: 1.
	self loopFrames: false.
	(self valueOfProperty: #fullScreenTransition ifAbsent:[false])
		ifTrue:[self bounds: self world bounds].
	self comeToFront.
	self startStepping.
	self startPlaying.
	[playing] whileTrue: [World doOneCycleNow].
	self stopPlaying.
	self stopStepping.
	owner removeMorph: self.
	self removeProperty: #transitionBackground.
	Display deferUpdates: true.
	ActiveWorld fullDrawOn: (Display getCanvas).
	Display deferUpdates: false.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'dao 10/1/2004 13:21'!
removeFillForProjectTarget: aFillStyle
	| fillStyles |
	fillStyles := self valueOfProperty: #projectTargetFills ifAbsent:[^self].
	aFillStyle form: (fillStyles at: aFillStyle ifAbsent:[^self]).
	fillStyles removeKey: aFillStyle.
	self updateProjectFillsFrom: Project current.
	self changed.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'ar 6/2/1999 05:00'!
updateProjectFillsFrom: aProject
	"Update all the project target fills from the given project"
	| fillStyles projImage |
	fillStyles := self valueOfProperty: #projectTargetFills ifAbsent:[^self].
	fillStyles isEmpty ifTrue:[^self].
	projImage := aProject imageFormOfSize: Display extent depth: 8.
	fillStyles keysDo:[:fs| fs form: projImage].
	"Note: We must issue a full GC here for cleaning up the old bitmaps"
	Smalltalk garbageCollect.! !


!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 11/6/1998 23:56'!
jump10
	1 to: 10 do:[:i| self stepForward].! !

!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 8/14/1998 21:54'!
rewind
	self frameNumber: 1.! !

!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 5/24/2001 16:50'!
stepToFrame: frame
	| fullRect postDamage |
	frame = frameNumber ifTrue:[^self].
	frame > loadedFrames ifTrue:[^self].
	postDamage := damageRecorder isNil.
	postDamage ifTrue:[damageRecorder := FlashDamageRecorder new].
	frame = (frameNumber+1) ifTrue:[
		self stepToFrameForward: frame.
	] ifFalse:[
		activeMorphs := activeMorphs select:[:any| false].
		submorphs do:[:m|
			(m isFlashMorph and:[m isFlashCharacter]) ifTrue:[
				m stepToFrame: frame.
				m visible ifTrue:[activeMorphs add: m].
			]].
	].
	frameNumber := frame.
	playing ifTrue:[
		self playSoundsAt: frame.
		self executeActionsAt: frame.
	].
	(postDamage and:[owner notNil]) ifTrue:[
		damageRecorder updateIsNeeded ifTrue:[
			fullRect := damageRecorder fullDamageRect: self localBounds.
			fullRect := (self transform localBoundsToGlobal: fullRect).
			owner invalidRect: (fullRect insetBy: -1) from: self.
		].
	].
	postDamage ifTrue:[damageRecorder := nil].! !

!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 11/17/1998 18:33'!
stepToFrameForward: frame
	| activeRemoved resortNeeded morph |
	frameNumber+1 to: frame do:[:f|
		activeRemoved := false.
		resortNeeded := false.
		1 to: activeMorphs size do:[:i|
			morph := activeMorphs at: i.
			morph stepToFrame: f.
			morph visible ifFalse:[activeRemoved := true].
			(i > 1 and:[(activeMorphs at: i-1) depth < morph depth])
				ifTrue:[resortNeeded := true].
		].
		activeRemoved ifTrue:[
			activeMorphs := activeMorphs select:[:m| m visible].
			resortNeeded := false.
		].
		resortNeeded ifTrue:[activeMorphs reSort].
		(activationKeys at: f) do:[:m|
			m stepToFrame: f.
			m visible ifTrue:[activeMorphs add: m].
		].
	].! !

!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 5/19/1999 17:23'!
stepToFrameSilently: frame
	"Like stepToFrame but without executing any actions or starting sounds.
	Note: This method is not intended for fast replay."
	| fullRect postDamage |
	frame = frameNumber ifTrue:[^self].
	frame > loadedFrames ifTrue:[^self].
	postDamage := damageRecorder isNil.
	postDamage ifTrue:[damageRecorder := FlashDamageRecorder new].
	activeMorphs := activeMorphs select:[:any| false].
	submorphs do:[:m|
		(m isFlashMorph and:[m isFlashCharacter]) ifTrue:[
			m stepToFrame: frame.
			m visible ifTrue:[activeMorphs add: m].
		].
	].
	frameNumber := frame.
	(postDamage and:[owner notNil]) ifTrue:[
		damageRecorder updateIsNeeded ifTrue:[
			fullRect := damageRecorder fullDamageRect: self localBounds.
			fullRect := (self transform localBoundsToGlobal: fullRect).
			owner invalidRect: (fullRect insetBy: -1).
		].
	].
	postDamage ifTrue:[damageRecorder := nil].! !


!FlashPlayerMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 11/20/1998 02:27'!
addMorph: aMorph
	aMorph isFlashMorph ifFalse:[^super addMorph: aMorph].
	aMorph isMouseSensitive
		ifTrue:[self addMorphFront: aMorph]
		ifFalse:[self addMorphBack: aMorph].! !


!FlashPlayerMorph methodsFor: 'private' stamp: 'ar 11/18/1998 23:21'!
collectActivationKeys: frame
	"Note: Must only be called after a frame has been completed"
	| vis lastKey |
	vis := Array new: frame.
	vis atAllPut: #().
	lastKey := activationKeys size.
	vis replaceFrom: 1 to: lastKey with: activationKeys startingAt: 1.
	submorphs do:[:m|
		(m isFlashMorph and:[m isFlashCharacter]) ifTrue:[
			m activationKeys do:[:key|
				key > lastKey ifTrue:[
					vis at: key put: ((vis at: key) copyWith: m)
				].
			].
		].
	].
	^vis! !

!FlashPlayerMorph methodsFor: 'private' stamp: 'ar 11/16/1998 02:58'!
noticeRemovalOf: aFlashMorph
	"The flash morph is removed from the player.
	Remove it's activation keys so that we don't have any problems."
	| morphs |
	aFlashMorph activationKeys do:[:key|
		morphs := activationKeys at: key.
		activationKeys at: key put: (morphs copyWithout: aFlashMorph).
	].
	"And remove it from the activeMorphs"
	activeMorphs remove: aFlashMorph ifAbsent:[]! !

!FlashPlayerMorph methodsFor: 'private' stamp: 'ar 6/12/2001 06:37'!
privateFullMoveBy: delta
	self handleBoundsChange:[super privateMoveBy: delta]! !

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

FlashPlayerMorph class
	instanceVariableNames: ''!

!FlashPlayerMorph class methodsFor: 'project transition' stamp: 'dao 10/1/2004 13:35'!
transitionFrom: srcProjectName

	^self transitionFrom: srcProjectName to: Project current name! !

!FlashPlayerMorph class methodsFor: 'project transition' stamp: 'dao 10/1/2004 13:19'!
transitionFrom: srcProjectName to: dstProjectName
	"Return the transition between the two projects"
	| srcProject dstProject |

	srcProject := Project namedOrCurrent: srcProjectName.
	dstProject := Project namedOrCurrent: dstProjectName.
	^dstProject projectParameters at: #flashTransition ifPresent:[:dict|
		dict at: srcProject ifAbsent:[nil]].
! !

!FlashPlayerMorph class methodsFor: 'project transition' stamp: 'dao 10/1/2004 13:36'!
transitionTo: dstProjectName

	^self transitionFrom: Project current name to: dstProjectName! !


!FlashPlayerMorph class methodsFor: 'scripting' stamp: 'sw 9/26/2001 03:56'!
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."

	^ # (

(collections (
(slot cursor 'The index of the chosen element' Number readWrite player getCursor player setCursorWrapped:)
(slot playerAtCursor 'the object currently at the cursor' Player readWrite player getValueAtCursor  unused unused)
(slot firstElement  'The first object in my contents' Player  readWrite player getFirstElement  player  setFirstElement:)
(slot graphicAtCursor 'the graphic worn by the object at the cursor' Graphic readOnly player getGraphicAtCursor  unused unused)


))

)
! !
SystemWindow subclass: #FlashPlayerWindow
	instanceVariableNames: 'startButton stopButton progress'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'dgd 5/1/2003 21:05'!
addProgressIndicator
	progress := ProgressBarMorph new.
	progress borderWidth: 1.
	progress color: Color transparent.
	progress progressColor: Color gray.
	progress extent: 100 @ (startButton extent y - 6).
	self addMorph: progress! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'dgd 5/1/2003 21:05'!
addProgressIndicator: aValueHolder 
	progress := ProgressBarMorph new.
	progress borderWidth: 1.
	progress color: Color transparent.
	progress progressColor: Color gray.
	progress value: aValueHolder.
	progress extent: 100 @ (startButton extent y - 6).
	self addMorph: progress! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 10:14'!
adjustBookControls
	| inner |
	startButton ifNil: [^ self].
	startButton align: startButton topLeft with: (inner := self innerBounds) topLeft + (35@-4).
	progress ifNotNil:
		[progress align: progress topLeft with: (startButton right @ inner top) + (10@0)].
	stopButton align: stopButton topRight with: inner topRight - (16@4)! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:46'!
startPlaying
	model startPlaying! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:43'!
stopPlaying
	model stopPlaying! !


!FlashPlayerWindow methodsFor: 'geometry' stamp: 'ar 11/17/1998 15:09'!
extent: newExtent
	super extent: (newExtent max: 100 @ 50).
	self adjustBookControls! !


!FlashPlayerWindow methodsFor: 'initialization' stamp: 'dgd 9/20/2003 16:43'!
initialize
	| aFont |
	super initialize.
	aFont :=  Preferences standardButtonFont.
	self addMorph: (startButton := SimpleButtonMorph new borderWidth: 0;
			label: 'play' translated font: aFont; color: Color transparent;
			actionSelector: #startPlaying; target: self).
	startButton setBalloonText: 'continue playing' translated.

	self addMorph: (stopButton := SimpleButtonMorph new borderWidth: 0;
			label: 'stop' translated font: aFont; color: Color transparent;
			actionSelector: #stopPlaying; target: self).
	stopButton setBalloonText: 'stop playing' translated.

	startButton submorphs first color: Color blue.
	stopButton submorphs first color: Color red.

	self adjustBookControls! !

!FlashPlayerWindow methodsFor: 'initialization' stamp: 'ar 11/19/1998 21:10'!
model: aFlashPlayerModel
	aFlashPlayerModel isStreaming
		ifTrue:[self addProgressIndicator: aFlashPlayerModel progressValue].
	^super model: aFlashPlayerModel! !


!FlashPlayerWindow methodsFor: 'open/close' stamp: 'ar 11/17/1998 15:39'!
openInMVCExtent: extent
	Smalltalk isMorphic ifTrue:[^self openInWorldExtent: extent].
	super openInMVCExtent: (extent + borderWidth + (0@self labelHeight))! !

!FlashPlayerWindow methodsFor: 'open/close' stamp: 'ar 11/17/1998 15:39'!
openInWorldExtent: extent
	Smalltalk isMorphic ifFalse:[^self openInMVCExtent: extent].
	super openInWorldExtent: (extent + borderWidth + (0@self labelHeight))! !


!FlashPlayerWindow methodsFor: 'panes' stamp: 'ar 11/9/2000 01:31'!
addMorph: aMorph frame: relFrame
	"Do not change the color"
	| cc |
	cc := aMorph color.
	super addMorph: aMorph frame: relFrame.
	aMorph color: cc.! !


!FlashPlayerWindow methodsFor: 'resize/collapse' stamp: 'ar 11/18/1998 22:40'!
collapseOrExpand
	super collapseOrExpand.
	isCollapsed ifTrue:[
		startButton delete.
		stopButton delete.
		progress ifNotNil:[progress delete].
	] ifFalse:[
		self addMorph: startButton.
		self addMorph: stopButton.
		progress ifNotNil:[self addMorph: progress].
		self adjustBookControls.
	].! !
FlashMorph subclass: #FlashShapeMorph
	instanceVariableNames: 'shape'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 17:19'!
color: aColor
	| fillStyle |
	color := aColor.
	fillStyle := SolidFillStyle color: aColor.
	shape := shape copyAndCollectFills:[:fill| fillStyle]! !

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 6/2/1999 04:38'!
fillForProjectTarget
	"Find a fill style that is suitable for a project target."
	shape fillStyles do:[:fs| fs isBitmapFill ifTrue:[^fs]].
	^nil! !

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 15:31'!
shape
	^shape! !

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 16:43'!
shape: newShape
	shape := newShape.
	self computeBounds.! !


!FlashShapeMorph methodsFor: 'classification' stamp: 'ar 6/2/1999 03:15'!
isFlashShape
	^true! !


!FlashShapeMorph methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:37'!
compress
	super compress.
	shape compress.! !

!FlashShapeMorph methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:38'!
decompress
	shape decompress.
	super decompress.! !


!FlashShapeMorph methodsFor: 'drawing' stamp: 'ar 12/30/1998 10:47'!
drawOn: aCanvas 
	"Display the receiver."
	| aaLevel |
	shape ifNil:[^aCanvas frameRectangle: self bounds color: Color black.].
	aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
		balloonCanvas transformBy: self transform.
		aaLevel := self defaultAALevel.
		aaLevel ifNotNil:[balloonCanvas aaLevel: aaLevel].
		balloonCanvas drawCompressedShape: shape.
	].! !


!FlashShapeMorph methodsFor: 'geometry' stamp: 'ar 11/18/1998 13:59'!
computeBounds
	bounds := self transform localBoundsToGlobal: (shape bounds).
	fullBounds := nil.! !

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

FlashShapeMorph class
	instanceVariableNames: ''!

!FlashShapeMorph class methodsFor: 'instance creation' stamp: 'ar 11/15/1998 15:32'!
shape: aCompressedFlashGeometry
	^self new shape: aCompressedFlashGeometry! !
TransformMorph subclass: #FlashSorterMorph
	instanceVariableNames: 'player'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashSorterMorph methodsFor: 'editing' stamp: 'ar 5/19/1999 19:38'!
makeMovie
	"Take all the currently selected frames and make a new movie out of it"
	| firstSelection lastSelection |
	firstSelection :=  submorphs size + 1.
	lastSelection := 0.
	submorphs doWithIndex:[:m :index|
		m isSelected ifTrue:[
			firstSelection := firstSelection min: index.
			lastSelection := lastSelection max: index.
		].
	].
	firstSelection > lastSelection
		ifTrue:[^self inform:'You have to select the frames first'].
	(player copyMovieFrom: firstSelection to: lastSelection) open! !


!FlashSorterMorph methodsFor: 'geometry' stamp: 'ar 5/19/1999 16:25'!
extent: extentPoint
	super extent: extentPoint.
	self doLayout.! !


!FlashSorterMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:27'!
addThumbnails: extentPoint
	| m morphList handler |
	handler := nil.
	'Preparing thumbnails' displayProgressAt: Sensor cursorPoint
		from: 1 to: player maxFrames during:[:bar|
			morphList := Array new: player maxFrames.
			1 to: player maxFrames do:[:i|
				bar value: i.
				m := FlashThumbnailMorph new.
				m extent: extentPoint.
				m player: player.
				m frameNumber: i.
				handler isNil ifTrue:[
					m on: #mouseDown send: #mouseDown:onItem: to: self.
					m on: #mouseStillDown send: #mouseStillDown:onItem: to: self.
					m on: #mouseUp send: #mouseUp:onItem: to: self.
					handler := m eventHandler.
				] ifFalse:[m eventHandler: handler].
				morphList at: i put: m].
		self addAllMorphs: morphList.
		self doLayout.
	].! !

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

!FlashSorterMorph methodsFor: 'initialization' stamp: 'tk 2/19/2001 17:48'!
makeControls

	| bb r |
	bb := SimpleButtonMorph new
		target: self;
		borderColor: #raised;
		borderWidth: 2.
	r := AlignmentMorph newRow.
	r hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2.
	r addMorphBack: (bb label: 'Make movie';		actionSelector: #makeMovie).
	^r! !

!FlashSorterMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:10'!
on: aFlashPlayerMorph
	| w h |
	player := aFlashPlayerMorph.
	w := player bounds width.
	h := player bounds height.
	w > h ifTrue:[
		h := h * 50 // w.
		w := 50.
	] ifFalse:[
		w := w * 50 // h.
		h := 50.
	].
	self addThumbnails: w@h.! !

!FlashSorterMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:54'!
openInWindow
	| window wrapper |
	window := SystemWindow new.
	wrapper := self makeControls.
	window addMorph: wrapper frame: (0@0 extent: 1@0.1).
	wrapper := ScrollPane new.
	wrapper scroller: self.
	window addMorph: wrapper frame: (0 @ 0.1 extent: 1 @ 1).
	self bounds: owner bounds.
	self doLayout.
	window openInWorld.! !


!FlashSorterMorph methodsFor: 'interaction' stamp: 'ar 5/19/1999 17:35'!
mouseDown: event onItem: aMorph
	submorphs do:[:m|
		m == aMorph ifFalse:[m isSelected: false]].
	aMorph isSelected: true.! !

!FlashSorterMorph methodsFor: 'interaction' stamp: 'ar 10/5/2000 18:42'!
mouseStillDown: evt onItem: aMorph
	| pt index m yOffset |
	submorphs do:[:mm|
		mm == aMorph ifFalse:[mm isSelected: false]].
	pt := evt cursorPoint.
	yOffset := self offset y.
	index := aMorph frameNumber. "What a fake hack@!!"
	pt y - yOffset < 0 ifTrue:[
		owner scrollBy: 0@owner scrollDeltaHeight].
	pt y - yOffset > self extent y ifTrue:[
		owner scrollBy: 0@owner scrollDeltaHeight negated].
	(aMorph bounds containsPoint: pt) ifTrue:[^self].
	(pt y > aMorph bottom or:[pt x > aMorph right]) ifTrue:[
		"Select all morphs forward."
		index+1 to: submorphs size do:[:i|
			m := submorphs at: i.
			m isSelected: aMorph isSelected.
			(m bounds containsPoint: pt) ifTrue:[^self]. "Done"
		].
		^self].
	"Select morphs backwards"
	index-1 to: 1 by: -1 do:[:i|
		m := submorphs at: i.
		m isSelected: aMorph isSelected.
		(m bounds containsPoint: pt) ifTrue:[^self].
	].! !

!FlashSorterMorph methodsFor: 'interaction' stamp: 'ar 5/19/1999 17:30'!
mouseUp: evt onItem: aMorph
	| pt |
	pt := evt cursorPoint.
	(aMorph bounds containsPoint: pt) ifTrue:[
		player stepToFrameSilently: aMorph frameNumber.
		^self].! !


!FlashSorterMorph methodsFor: 'layout' stamp: 'ar 5/19/1999 16:47'!
doLayout
	"Do the layout of the child morphs"
	| x y maxHeight w |
	w := self bounds width.
	x := 0.
	y := 0.
	maxHeight := 0.
	submorphs do:[:m|
		x + m bounds width > w ifTrue:[
			"Wrap the guy on the next line"
			x := 0.
			y := y + maxHeight.
			maxHeight := 0].
		m position: x@y.
		x := x + m bounds width.
		maxHeight := maxHeight max: m bounds height].
! !
Object subclass: #FlashSoundEnvelope
	instanceVariableNames: 'mark44 level0 level1'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
level0
	^level0! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
level0: anInteger
	level0 := anInteger! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
level1
	^level1! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
level1: anInteger
	level1 := anInteger! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
mark44
	^mark44! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
mark44: anInteger
	mark44 := anInteger! !


!FlashSoundEnvelope methodsFor: 'initialize' stamp: 'ar 8/10/1998 15:35'!
initialize
	mark44 := level0 := level1 := 0.! !
Object subclass: #FlashSoundInformation
	instanceVariableNames: 'syncFlags inPoint outPoint loopCount envelopes'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:32'!
envelopes
	^envelopes! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:32'!
envelopes: aCollection
	envelopes := aCollection! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
inPoint
	^inPoint! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
inPoint: anInteger
	inPoint := anInteger! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
loopCount
	^loopCount! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:32'!
loopCount: anInteger
	loopCount := anInteger! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
outPoint
	^outPoint! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
outPoint: anInteger
	outPoint := anInteger! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:30'!
syncFlags
	^syncFlags! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
syncFlags: anInteger
	syncFlags := anInteger! !


!FlashSoundInformation methodsFor: 'initialize' stamp: 'ar 8/10/1998 15:30'!
initialize
	syncFlags := 0.
	inPoint := -1.
	outPoint := -1.
	loopCount := 0.
	envelopes := #().! !


!FlashSoundInformation methodsFor: 'testing' stamp: 'ar 8/10/1998 15:33'!
syncNoMultiple
	"Don't start the sound if already playing."
	^syncFlags anyMask: 1! !

!FlashSoundInformation methodsFor: 'testing' stamp: 'ar 8/10/1998 15:34'!
syncStopSound
	"Stop the sound."
	^syncFlags anyMask: 2! !
FlashMorph subclass: #FlashSpriteMorph
	instanceVariableNames: 'playing maxFrames loadedFrames frameNumber stepTime damageRecorder sounds actions labels lastStepTime useTimeSync'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 16:48'!
addActions: actionList atFrame: frame
	actions ifNil:[actions := Dictionary new].
	actions at: frame put: actionList.! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 16:48'!
addLabel: labelString atFrame: frame
	labels ifNil:[labels := Dictionary new].
	labels at: labelString put: frame.! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 16:49'!
addSound: aSound at: frameNr
	| oldSound newSound |
	oldSound := sounds at: frameNr ifAbsent:[nil].
	oldSound isNil 
		ifTrue:[newSound := Array with: aSound]
		ifFalse:[newSound := oldSound copyWith: newSound].
	sounds at: frameNr put: newSound.! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:09'!
frameNumber
	^frameNumber! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:09'!
frameNumber: frame
	^self stepToFrame: frame! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:02'!
loadedFrames
	^loadedFrames! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:02'!
loadedFrames: n
	loadedFrames := n.! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 9/1/1999 15:27'!
loopFrames
	^true! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:16'!
loopFrames: aBool! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:02'!
maxFrames
	^maxFrames! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:02'!
maxFrames: n
	maxFrames := n! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 7/11/2000 11:08'!
useTimeSync
	^useTimeSync ifNil:[true]! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 7/11/2000 11:08'!
useTimeSync: aBool
	useTimeSync := aBool! !


!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:10'!
actionPlay
	self startPlaying.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:10'!
actionStop
	"Stop playing at the current frame."
	self stopPlaying.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 9/1/1999 15:50'!
actionTarget: target
	"Set the context (e.g., the receiver) of the following actions."
	| rcvr lastSlash nextSlash loc |
	target = '' ifTrue:[^self].
	target first = $/
		ifTrue:[rcvr := self flashPlayer ifNil:[self]. lastSlash := 1.] "absoute path"
		ifFalse:[rcvr := self. lastSlash := 0]. "relative path"
	[lastSlash > target size] whileFalse:[
		nextSlash := target findString:'/' startingAt: lastSlash+1.
		nextSlash = 0 ifTrue:[nextSlash := target size + 1].
		loc := target copyFrom: lastSlash+1 to: nextSlash-1.
		(loc size = 2 and:[loc = '..']) ifTrue:[
			[rcvr := rcvr owner.
			rcvr isFlashSprite] whileFalse.
		] ifFalse:[
			rcvr := rcvr submorphs detect:[:m| m knownName = loc] ifNone:[rcvr owner].
			rcvr := rcvr submorphs detect:[:m| m isFlashSprite].
		].
		lastSlash := nextSlash].
	^rcvr! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 9/1/1999 16:15'!
executeActionsAt: frame
	| rcvr actionList index msg result |
	actionList := actions at: frame ifAbsent:[^self].
	index := 1.
	rcvr := self.
	[index <= actionList size] whileTrue:[
		msg := actionList at: index.
"Transcript cr; print: msg selector; space; print: msg arguments; endEntry."
		msg selector == #actionTarget:
			ifTrue:[	rcvr := msg sentTo: self]
			ifFalse:[	result := msg sentTo: rcvr.
					result ifNotNil:[index := index + result]].
		index := index + 1].! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/20/1998 02:36'!
getURL: urlString window: windowString
	"Load the given url in display it in the window specified by windowString.
	Ignored for now."
	| browser |
	browser := self getWebBrowser.
	browser ifNotNil:[
		browser jumpToUrl: urlString.
		^nil].
	"(self confirm: ('open a browser to view\',urlString,' ?') withCRs) ifTrue: [
		browser := Scamper new.
		browser jumpToUrl: urlString.
		browser openAsMorph
	]."
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 2/3/2000 17:21'!
gotoFrame: frame
	"Jump to the given frame"
	self stopPlaying.
	self frameNumber: frame+1.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
gotoLabel: labelString
	"Go to the frame with the associated label string."
	labels ifNil:[^nil].
	self frameNumber: (labels at: labelString ifAbsent:[^nil]).
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
gotoNextFrame
	"Go to the next frame"
	self frameNumber: self frameNumber+1.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
gotoPrevFrame
	"Go to the previous frame"
	self frameNumber: self frameNumber-1.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
isFrameLoaded: frame elseSkip: nActions
	"Skip nActions if the given frame is not loaded yet."
	^loadedFrames >= frameNumber 
		ifTrue:[nil]
		ifFalse:[nActions].! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 2/3/2000 17:20'!
playSoundsAt: frame
	(sounds at: frame ifAbsent:[#()]) 
		do: [:sound | sound ifNotNil:[self playFlashSound: sound]].! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
stopSounds
	"Stop all sounds"
	SoundPlayer shutDown.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
toggleQuality
	"Toggle the display quality.
	Ignored for now - we're aiming at adaptive quality settings."
	^nil! !


!FlashSpriteMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:43'!
invalidRect: rect from: aMorph
	damageRecorder isNil ifTrue:[
		super invalidRect: rect from: aMorph
	] ifFalse:[
		damageRecorder recordInvalidRect: rect.
	].! !


!FlashSpriteMorph methodsFor: 'classification' stamp: 'ar 11/16/1998 17:03'!
isFlashSprite
	^true! !

!FlashSpriteMorph methodsFor: 'classification' stamp: 'ar 11/19/1998 22:22'!
isMouseSensitive
	"Return true - my children may be sensitive"
	^true! !


!FlashSpriteMorph methodsFor: 'copying' stamp: 'ar 5/19/1999 19:11'!
copyMovieFrom: firstFrame to: lastFrame
	"Note: This is different if sent to a sprite since a sprite contains a *full* animation
	and is therefore always completely."
	^super copyMovieFrom: 1 to: maxFrames.! !


!FlashSpriteMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	playing := false.
	loadedFrames := 0.
	maxFrames := 1.
	frameNumber := 1.
	sounds := Dictionary new.
	actions := Dictionary new.
	labels := Dictionary new.
	stepTime := 1.
	useTimeSync := true! !


!FlashSpriteMorph methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:45'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	lastStepTime ifNil: [lastStepTime := 0].
	useTimeSync ifNil: [useTimeSync := true].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !


!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 2/3/2000 17:46'!
startPlaying
	"Start playing from the current frame"
	playing ifTrue:[^self].
	loadedFrames = 0 ifTrue:[^nil].
	frameNumber >= maxFrames ifTrue:[self frameNumber: 1].
	playing := true.
	self playSoundsAt: frameNumber.
	self executeActionsAt: frameNumber.
	lastStepTime := Time millisecondClockValue.! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 11/19/1998 22:09'!
stepBackward
	frameNumber > 1
		ifTrue:[self frameNumber: frameNumber - 1]
		ifFalse:[self frameNumber: loadedFrames].! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 9/1/1999 16:15'!
stepForward
	frameNumber < maxFrames
		ifTrue:[^self frameNumber: frameNumber + 1].
	self loopFrames
		ifTrue:[self frameNumber: 1]
		ifFalse:[self stopPlaying].! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 11/16/1998 17:07'!
stepTime: time
	stepTime := time.! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 5/24/2001 16:50'!
stepToFrame: frame
	"Step to the given frame"
	| fullRect postDamage lastVisible resortNeeded |
	frame = frameNumber ifTrue:[^self].
	frame > loadedFrames ifTrue:[^self].
	postDamage := damageRecorder isNil.
	postDamage ifTrue:[damageRecorder := FlashDamageRecorder new].
	lastVisible := nil.
	resortNeeded := false.
	submorphs do:[:m|
		(m isFlashMorph and:[m isFlashCharacter]) ifTrue:[
			m stepToFrame: frame.
			m visible ifTrue:[
				(lastVisible notNil and:[lastVisible depth < m depth])
					ifTrue:[resortNeeded := true].
				lastVisible := m.
				(bounds containsRect: m bounds) ifFalse:[bounds := bounds merge: m bounds].
			].
		].
	].
	resortNeeded ifTrue:[submorphs := submorphs sortBy:[:m1 :m2| m1 depth > m2 depth]].
	frameNumber := frame.
	playing ifTrue:[
		self playSoundsAt: frame.
		self executeActionsAt: frame.
	].
	(postDamage and:[owner notNil]) ifTrue:[
		damageRecorder updateIsNeeded ifTrue:[
			"fullRect := damageRecorder fullDamageRect.
			fullRect := (self transform localBoundsToGlobal: fullRect)."
			fullRect := bounds.
			owner invalidRect: (fullRect insetBy: -1) from: self.
		].
	].
	postDamage ifTrue:[
		damageRecorder := nil].! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 11/19/1998 22:10'!
stopPlaying
	"Stop playing at the current frame."
	playing := false.! !


!FlashSpriteMorph methodsFor: 'stepping and presenter' stamp: 'ar 7/11/2000 11:08'!
step
	| nowStepTime maxSteps |
	playing ifFalse:[^self].
	self useTimeSync ifTrue:[
		maxSteps := 5.
		nowStepTime := Time millisecondClockValue.
		[(lastStepTime + stepTime <= nowStepTime) and:[playing and:[maxSteps >= 0]]]
			whileTrue:[
				self stepForward.
				lastStepTime := lastStepTime + stepTime.
				maxSteps := maxSteps - 1.
			].
	] ifFalse:[self stepForward].
	damageRecorder := nil. "Insurance"! !


!FlashSpriteMorph methodsFor: 'testing' stamp: 'ar 7/11/2000 11:08'!
stepTime
	"If we're syncing with time step at double speed."
	^self useTimeSync
		ifTrue:[stepTime // 2]
		ifFalse:[stepTime]! !

!FlashSpriteMorph methodsFor: 'testing' stamp: 'ar 11/16/1998 16:27'!
wantsSteps
	^true! !


!FlashSpriteMorph methodsFor: 'private' stamp: 'di 11/13/2000 00:51'!
getWebBrowser
	"Return a web browser if we're running in one"

	self withAllOwnersDo:
		[:morph | morph isWebBrowser ifTrue: [^ morph].
		(morph hasProperty: #webBrowserView) ifTrue: [^ morph model]].
	^ nil! !
Object subclass: #FlashStreamingSound
	instanceVariableNames: 'mixFmt stereo samplingRate bitsPerSample sampleCount compressed firstFrame frameNumber buffers'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Support'!

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
bitsPerSample
	^bitsPerSample! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
bitsPerSample: aNumber
	bitsPerSample := aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:45'!
buffers
	^buffers! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:45'!
buffers: anArray
	buffers := anArray! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
compressed
	^compressed! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
compressed: aBool
	compressed := aBool! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:34'!
firstFrame
	^firstFrame! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:34'!
firstFrame: frame
	firstFrame := frame.! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:45'!
frameNumber
	^frameNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:45'!
frameNumber: aNumber
	frameNumber := aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
mixFmt
	^mixFmt! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
mixFmt: aNumber
	mixFmt := aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
sampleCount
	^sampleCount! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
sampleCount: aNumber
	sampleCount := aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:33'!
samplingRate
	^samplingRate! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:33'!
samplingRate: aNumber
	samplingRate := aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
stereo
	^stereo! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
stereo: aBool
	stereo := aBool! !
FlashCharacterMorph subclass: #FlashTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!
BorderedMorph subclass: #FlashThumbnailMorph
	instanceVariableNames: 'player frameNumber image selected'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Flash-Morphs'!

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:01'!
frameNumber
	^frameNumber! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:02'!
frameNumber: aNumber
	frameNumber = aNumber ifFalse:[
		frameNumber := aNumber.
		image := nil.
	].! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:01'!
image
	^image! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:01'!
image: aForm
	image := aForm.
	self changed.! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 17:14'!
isSelected
	^selected == true! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 17:29'!
isSelected: aBoolean
	selected == aBoolean ifTrue:[^self].
	selected := aBoolean.
	self borderColor: (self isSelected ifTrue:[Color red] ifFalse:[Color black]).! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:42'!
player
	"answer the receiver's player"
	^ player! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:01'!
player: aFlashPlayerMorph
	player := aFlashPlayerMorph.! !


!FlashThumbnailMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 13:29'!
drawOn: aCanvas 
	(player isNil or: [frameNumber isNil]) ifTrue: [^super drawOn: aCanvas].
	false 
		ifTrue: 
			[super drawOn: aCanvas.
			^aCanvas 
				drawString: frameNumber printString
				in: self innerBounds
				font: nil
				color: Color red].
	image ifNil: 
			[Cursor wait showWhile: 
					[image := player imageFormOfSize: self extent - (self borderWidth * 2)
								forFrame: frameNumber.
					frameNumber printString displayOn: image]].
	aCanvas 
		frameRectangle: self bounds
		width: self borderWidth
		color: self borderColor.
	aCanvas paintImage: image at: self topLeft + self borderWidth! !


!FlashThumbnailMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:29'!
initialize
	super initialize.
	selected := false.! !
EllipseMorph subclass: #Flasher
	instanceVariableNames: 'onColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!Flasher commentStamp: '<historical>' prior: 0!
A simple example - a circle that flashes.

The "onColor" instance variable indicates the color to use when "on",  A darker color is used to represent "off".

The #step method, called every 500ms. by default, alternatively makes the flasher show its "on" and its "off" color.!


!Flasher methodsFor: 'operations' stamp: 'sw 5/28/2002 18:44'!
onColor
	"Answer my onColor"

	^ onColor ifNil: [onColor _ Color red]! !

!Flasher methodsFor: 'operations' stamp: 'sd 4/21/2002 09:55'!
onColor: aColor
	"Change my on color to be aColor"

	onColor := aColor.
	self color: aColor! !


!Flasher methodsFor: 'parts bin' stamp: 'sd 4/21/2002 09:36'!
initializeToStandAlone
	"Initialize the flasher."

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


!Flasher methodsFor: 'stepping and presenter' stamp: 'sw 5/28/2002 18:45'!
step
	"Perform my standard periodic action"

	super step.
	self color = self onColor
		ifTrue: [self color: (onColor alphaMixed: 0.5 with: Color black)]
		ifFalse: [self color: onColor]! !


!Flasher methodsFor: 'testing' stamp: 'sw 4/17/2002 12:05'!
stepTime
	"Answer the desired time between steps, in milliseconds."

	^ 500! !

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

Flasher class
	instanceVariableNames: ''!

!Flasher class methodsFor: 'parts bin' stamp: 'sw 4/17/2002 11:37'!
descriptionForPartsBin
	"Answer a description of the receiver for use in a parts bin"

	^ self partName:	'Flasher'
		categories:		#('Demo')
		documentation:	'A circle that flashes'! !
NullEncoder subclass: #FlattenEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!FlattenEncoder commentStamp: '<historical>' prior: 0!
The simplest possible encoding:  leave the objects as is.
!


!FlattenEncoder methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:32'!
elementSeparator
	^target elementSeparator.! !


!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 21:51'!
cr
	^self print:String cr.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 21:50'!
writeArrayedCollection:anArrayedCollection
	^self writeCollectionContents:anArrayedCollection.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:03'!
writeCollection:aCollection
	^self writeCollectionContents:aCollection.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:26'!
writeCollectionContents:aCollection
    ^self writeCollectionContents:aCollection separator:self elementSeparator iterationMessage:#do:.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:26'!
writeCollectionContents:aCollection separator:separator
	^self writeCollectionContents:aCollection separator:separator iterationMessage:#do:.! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:25'!
writeCollectionContents:aCollection separator:separator iterationMessage:op
	| first |
	first _ true.
	aCollection perform:op with: [ :each |  first ifFalse:[ self writeObject:separator ]. self write:each. first_false.].
! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:30'!
writeDictionary:aCollection
	^self writeDictionaryContents:aCollection separator:nil.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:29'!
writeDictionaryContents:aCollection separator:separator
	^self writeCollectionContents:aCollection separator:separator iterationMessage:#associationsDo:.! !

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

FlattenEncoder class
	instanceVariableNames: ''!

!FlattenEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:08'!
filterSelector
	^#flattenOnStream:
! !
SketchMorph subclass: #FlexMorph
	instanceVariableNames: 'originalMorph borderWidth borderColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalMorphs'!

!FlexMorph methodsFor: 'accessing' stamp: 'di 1/11/1999 21:43'!
borderColor: aColor
	borderColor _ aColor.
	self updateFromOriginal! !

!FlexMorph methodsFor: 'accessing' stamp: 'di 1/11/1999 21:43'!
borderWidth: width
	borderWidth _ width asPoint.
	self updateFromOriginal! !

!FlexMorph methodsFor: 'accessing' stamp: 'di 1/11/1999 20:35'!
form

	self loadOriginalForm.  "make sure it's not nil"
	^ super form! !


!FlexMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 18:52'!
changeBorderColor: evt
	| aHand |
	aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand].
	self changeColorTarget: self selector: #borderColor: originalColor: self borderColor hand: aHand.! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 8/30/2000 21:39'!
changeBorderWidth: evt
	| handle origin aHand |
	aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin _ aHand position.
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | handle removeAllMorphs.
		handle addMorph:
			(LineMorph from: origin to: newPoint color: Color black width: 1).
		self borderWidth: (newPoint - origin) r asInteger // 5].
	aHand attachMorph: handle.
	handle startStepping! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:34'!
loadOriginalForm

	originalForm ifNil: [self updateFromOriginal].
! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/25/1999 10:36'!
originalMorph

	^ originalMorph! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:19'!
originalMorph: aMorph

	originalMorph _ aMorph.
	scalePoint _ 0.25@0.25.
	self updateFromOriginal.! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 21:46'!
updateFromOriginal

	| intermediateForm |
	intermediateForm _ originalMorph imageForm offset: 0@0.
	intermediateForm border: intermediateForm boundingBox
		widthRectangle: (borderWidth corner: borderWidth+1)
		rule: Form over fillColor: borderColor.
	self form: intermediateForm.
	originalMorph fullReleaseCachedState! !


!FlexMorph methodsFor: 'caching' stamp: 'di 1/11/1999 19:44'!
releaseCachedState
	"Clear cache of rotated, scaled Form."

	originalForm _ Form extent: 10@10.  "So super hibernate won't have to work hard
												but won't crash either."
	super releaseCachedState.
	rotatedForm _ nil.
	originalForm _ nil.! !


!FlexMorph methodsFor: 'drawing' stamp: 'di 1/11/1999 20:54'!
drawOn: aCanvas

	originalForm _ nil.  "Aggressively uncache the originalForm"
	^ super drawOn: aCanvas! !

!FlexMorph methodsFor: 'drawing' stamp: 'di 1/11/1999 20:35'!
generateRotatedForm

	self loadOriginalForm.  "make sure it's not nil"
	^ super generateRotatedForm! !


!FlexMorph methodsFor: 'geometry' stamp: 'di 1/11/1999 20:35'!
extent: newExtent

	self loadOriginalForm.  "make sure it's not nil"
	^ super extent: newExtent! !


!FlexMorph methodsFor: 'initialization' stamp: 'di 1/11/1999 21:37'!
initialize
	super initialize.
	borderWidth _ 2@2.
	borderColor _ Color black.! !


!FlexMorph methodsFor: 'layout' stamp: 'di 1/11/1999 20:35'!
layoutChanged

	self loadOriginalForm.  "make sure it's not nil"
	^ super layoutChanged! !


!FlexMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:44'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	"super addCustomMenuItems: aCustomMenu hand: aHandMorph."
	aCustomMenu addLine.
	aCustomMenu add: 'update from original' translated action: #updateFromOriginal.
	aCustomMenu addList: {
						{'border color...' translated. #changeBorderColor:}.
						{'border width...' translated. #changeBorderWidth:}.
						}.
	aCustomMenu addLine.
! !
PackageInfo subclass: #FlexibleVocabulariesInfo
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FlexibleVocabularies-Info'!
!FlexibleVocabulariesInfo commentStamp: 'nk 3/11/2004 16:38' prior: 0!
Package:		FlexibleVocabularies-nk
Date:			12 October 2003
Author:			Ned Konz

This makes it possible for packages to extend Morph class vocabularies.
Previously, you'd have to edit #additionsToViewerCategories, which would result in potential conflicts between different packages that all wanted to (for instance) extend Morph's vocabulary.

Subclasses that have additions can do one or both of:
	- override #additionsToViewerCategories (as before)
	- define one or more additionToViewerCategory* methods.

The advantage of the latter technique is that class extensions may be added
by external packages without having to re-define additionsToViewerCategories.

So, for instance, package A could add a method named #additionsToViewerCategoryPackageABasic
and its methods would be added to the vocabulary automatically.

NOTE: this change set is hand-rearranged to avoid problems on file-in.

Specifically, Morph>>hasAdditionsToViewerCategories must come before Morph class>>additionsToViewerCategories
!


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

FlexibleVocabulariesInfo class
	instanceVariableNames: ''!

!FlexibleVocabulariesInfo class methodsFor: 'class initialization' stamp: 'nk 5/3/2004 15:48'!
initialize
	[self new register] on: MessageNotUnderstood do: [].
	SyntaxMorph class removeSelector: #initialize.
	SyntaxMorph removeSelector: #allSpecs.
	EToyVocabulary removeSelector: #morphClassesDeclaringViewerAdditions.
	SyntaxMorph clearAllSpecs.
	Vocabulary initialize.
! !
Number variableWordSubclass: #Float
	instanceVariableNames: ''
	classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 ThreePi Twopi'
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Float commentStamp: '<historical>' prior: 0!
My instances represent IEEE-754 floating-point double-precision numbers.  They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are:
	
	8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12

Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point.  It is actually possible to specify a radix for Squeak Float constants.  This is great for teaching about numbers, but may be confusing to the average reader:

	3r20.2 --> 6.66666666666667
	8r20.2 --> 16.25

If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex.  It may help you to know that the basic format is...
	sign		1 bit
	exponent	11 bits with bias of 1023 (16r3FF) to produce an exponent
						in the range -1023 .. +1024
				- 16r000:
					significand = 0: Float zero
					significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit)
				- 16r7FF:
					significand = 0: Infinity
					significand ~= 0: Not A Number (NaN) representation
	mantissa	53 bits, but only 52 are stored (20 in the first word, 32 in the second).  This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead.  People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND.

The single-precision format is...
	sign		1 bit
	exponent	8 bits, with bias of 127, to represent -126 to +127
                    - 0x0 and 0xFF reserved for Float zero (mantissa is ignored)
                    - 16r7F reserved for Float underflow/overflow (mantissa is ignored)
	mantissa	24 bits, but only 23 are stored
This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:.

Thanks to Rich Harmon for asking many questions and to Tim Olson, Bruce Cohen, Rick Zaccone and others for the answers that I have collected here.!


!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'!
* aNumber 
	"Primitive. Answer the result of multiplying the receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 49>
	^ aNumber adaptToFloat: self andSend: #*! !

!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:22'!
+ aNumber 
	"Primitive. Answer the sum of the receiver and aNumber. Essential.
	Fail if the argument is not a Float. See Object documentation
	whatIsAPrimitive."

	<primitive: 41>
	^ aNumber adaptToFloat: self andSend: #+! !

!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:55'!
- aNumber 
	"Primitive. Answer the difference between the receiver and aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 42>
	^ aNumber adaptToFloat: self andSend: #-! !

!Float methodsFor: 'arithmetic' stamp: 'hh 10/3/2000 11:46'!
/ aNumber 
	"Primitive. Answer the result of dividing receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 50>
	aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal].
	^ aNumber adaptToFloat: self andSend: #/! !

!Float methodsFor: 'arithmetic'!
abs
	"This is faster than using Number abs."
	self < 0.0
		ifTrue: [^ 0.0 - self]
		ifFalse: [^ self]! !

!Float methodsFor: 'arithmetic'!
negated
	"Answer a Number that is the negation of the receiver."

	^0.0 - self! !

!Float methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'!
reciprocal
	#Numeric.
	"Changed 200/01/19 For ANSI <number> support."
	self = 0 ifTrue: ["<- Chg"
		^ (ZeroDivide dividend: self) signal"<- Chg"].
	"<- Chg"
	^ 1.0 / self! !


!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:55'!
< aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is less than the argument. Otherwise return false.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 43>
	^ aNumber adaptToFloat: self andSend: #<! !

!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:55'!
<= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is less than or equal to the argument. Otherwise return
	false. Fail if the argument is not a Float. Optional. See Object
	documentation whatIsAPrimitive."

	<primitive: 45>
	^ aNumber adaptToFloat: self andSend: #<=! !

!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:56'!
= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is equal to the argument. Otherwise return false.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 47>
	aNumber isNumber ifFalse: [^ false].
	^ aNumber adaptToFloat: self andSend: #=! !

!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:57'!
> aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is greater than the argument. Otherwise return false.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 44>
	^ aNumber adaptToFloat: self andSend: #>! !

!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:57'!
>= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is greater than or equal to the argument. Otherwise return
	false. Fail if the argument is not a Float. Optional. See Object documentation 
	whatIsAPrimitive. "

	<primitive: 46>
	^ aNumber adaptToFloat: self andSend: #>! !

!Float methodsFor: 'comparing' stamp: 'tk 11/27/1999 21:47'!
closeTo: num
	"are these two numbers close?"
	| fuzz ans |
	num isNumber ifFalse: [
		[ans _ self = num] ifError: [:aString :aReceiver | ^ false].
		^ ans].
	self = 0.0 ifTrue: [^ num abs < 0.0001].
	num = 0.0 ifTrue: [^ self abs < 0.0001].
	self isNaN == num isNaN ifFalse: [^ false].
	self isInfinite == num isInfinite ifFalse: [^ false].
	fuzz := (self abs max: num abs) * 0.0001.
	^ (self - num) abs <= fuzz! !

!Float methodsFor: 'comparing' stamp: 'jm 4/28/1998 01:04'!
hash
	"Hash is reimplemented because = is implemented. Both words of the float are used; 8 bits are removed from each end to clear most of the exponent regardless of the byte ordering. (The bitAnd:'s ensure that the intermediate results do not become a large integer.) Slower than the original version in the ratios 12:5 to 2:1 depending on values. (DNS, 11 May, 1997)"

	^ (((self basicAt: 1) bitAnd: 16r00FFFF00) +
	   ((self basicAt: 2) bitAnd: 16r00FFFF00)) bitShift: -8
! !

!Float methodsFor: 'comparing'!
~= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is not equal to the argument. Otherwise return false.
	Fail if the argument is not a Float. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 48>
	^super ~= aNumber! !


!Float methodsFor: 'converting' stamp: 'mk 10/27/2003 18:16'!
adaptToComplex: rcvr andSend: selector
	"If I am involved in arithmetic with a Complex number, convert me to a Complex number."
	^ rcvr perform: selector with: self asComplex! !

!Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:38'!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert it to a Float."
	^ rcvr asFloat perform: selector with: self! !

!Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:07'!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a Float."
	^ rcvr asFloat perform: selector with: self! !

!Float methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector 
	"Convert receiverScaledDecimal to a Float and do the arithmetic. 
	receiverScaledDecimal arithmeticOpSelector self."
	#Numeric.
	"add 200/01/19 For ScaledDecimal support."
	^ receiverScaledDecimal asFloat perform: arithmeticOpSelector with: self! !

!Float methodsFor: 'converting' stamp: 'st 9/17/2004 17:17'!
asApproximateFraction
	"Answer a Fraction approximating the receiver. This conversion uses the 
	continued fraction method to approximate a floating point number."

	^ self asApproximateFractionAtOrder: 0! !

!Float methodsFor: 'converting' stamp: 'st 9/17/2004 17:14'!
asApproximateFractionAtOrder: maxOrder
	"Answer a Fraction approximating the receiver. This conversion uses the 
	continued fraction method to approximate a floating point number. If maxOrder
	is zero, use maximum order"

	| num1 denom1 num2 denom2 int frac newD temp order |
	num1 := self asInteger.	"The first of two alternating numerators"
	denom1 := 1.		"The first of two alternating denominators"
	num2 := 1.		"The second numerator"
	denom2 := 0.		"The second denominator--will update"
	int := num1.		"The integer part of self"
	frac := self fractionPart.		"The fractional part of self"
	order := maxOrder = 0 ifTrue: [-1] ifFalse: [maxOrder].
	[frac = 0 or: [order = 0] ]
		whileFalse: 
			["repeat while the fractional part is not zero and max order is not reached"
			order _ order - 1.
			newD := 1.0 / frac.			"Take reciprocal of the fractional part"
			int := newD asInteger.		"get the integer part of this"
			frac := newD fractionPart.	"and save the fractional part for next time"
			temp := num2.				"Get old numerator and save it"
			num2 := num1.				"Set second numerator to first"
			num1 := num1 * int + temp.	"Update first numerator"
			temp := denom2.				"Get old denominator and save it"
			denom2 := denom1.			"Set second denominator to first"
			denom1 := int * denom1 + temp.		"Update first denominator"
			10000000000.0 < denom1
				ifTrue: 
					["Is ratio past float precision?  If so, pick which 
					of the two ratios to use"
					num2 = 0.0 
						ifTrue: ["Is second denominator 0?"
								^ Fraction numerator: num1 denominator: denom1].
					^ Fraction numerator: num2 denominator: denom2]].
	"If fractional part is zero, return the first ratio"
	denom1 = 1
		ifTrue: ["Am I really an Integer?"
				^ num1 "Yes, return Integer result"]
		ifFalse: ["Otherwise return Fraction result"
				^ Fraction numerator: num1 denominator: denom1]! !

!Float methodsFor: 'converting' stamp: 'mk 10/27/2003 17:46'!
asComplex
	"Answer a Complex number that represents value of the the receiver."

	^ Complex real: self imaginary: 0! !

!Float methodsFor: 'converting'!
asFloat
	"Answer the receiver itself."

	^self! !

!Float methodsFor: 'converting' stamp: 'sma 5/3/2000 21:46'!
asFraction
	^ self asTrueFraction ! !

!Float methodsFor: 'converting' stamp: 'nice 5/30/2006 02:29'!
asIEEE32BitWord
	"Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format.
	Used for conversion in FloatArrays only."
	
	| word1 word2 sign mantissa exponent destWord truncatedBits mask roundToUpper |
	
	"skip fast positive and nnegative zero"
	self = 0.0 ifTrue: [^self basicAt: 1].
	
	"retrieve 64 bits of IEEE 754 double"
	word1 := self basicAt: 1.
	word2 := self basicAt: 2.
	
	"prepare sign exponent and mantissa of 32 bits float"
	sign := word1 bitAnd: 16r80000000.
	exponent := ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127.
	mantissa := (word2 bitShift: -29) + ((word1 bitAnd:  16rFFFFF) bitShift: 3).
	truncatedBits := (word2 bitAnd: 16r1FFFFFFF).

	"We must now honour default IEEE rounding mode (round to nearest even)"
	
	"we are below gradual underflow, even if rounded to upper mantissa"
	exponent < -24 ifTrue: [^sign "this can be negative zero"].
	
	"BEWARE: rounding occurs on less than 23bits when gradual underflow"
	exponent <= 0
		ifTrue:
			[mask := 1 bitShift: exponent negated.
			mantissa := mantissa bitOr: 16r800000.
			roundToUpper := (mantissa bitAnd: mask) isZero not
				and: [truncatedBits isZero not
					or: [(mantissa bitAnd: mask - 1) isZero not
						or: [(mantissa bitAnd: mask*2) isZero not]]].
			mantissa := mantissa bitShift: exponent - 1.
			"exponent := exponent + 1"]
		ifFalse:
			[roundToUpper := (truncatedBits bitAnd: 16r10000000) isZero not
				and: [(mantissa bitAnd: 16r1) isZero not
					or: [(truncatedBits bitAnd: 16r0FFFFFFF) isZero not]]
			].
		
	"adjust mantissa and exponent due to IEEE rounding mode"
	roundToUpper
		ifTrue:
			[mantissa := mantissa + 1.
			mantissa > 16r7FFFFF
				ifTrue:
					[mantissa := 0.
					exponent := exponent+1]].

	exponent > 254 ifTrue: ["Overflow"
		exponent := 255.
		self isNaN
			ifTrue: [mantissa isZero
				ifTrue: ["BEWARE: do not convert a NaN to infinity due to truncatedBits"
					mantissa := 1]]
			ifFalse: [mantissa := 0]].
		
	"Encode the word"
	destWord := (sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa.
	^ destWord! !

!Float methodsFor: 'converting' stamp: 'nice 3/29/2006 01:01'!
asTrueFraction
	" Answer a fraction that EXACTLY represents self,
	  a double precision IEEE floating point number.
	  Floats are stored in the same form on all platforms.
	  (Does handle gradual underflow but not NANs.)
	  By David N. Smith with significant performance
	  improvements by Luciano Esteban Notarfrancesco.
	  (Version of 11April97)"
	| signexp positive expPart exp fraction fractionPart signedFraction result zeroBitsCount |
	self isInfinite ifTrue: [self error: 'Cannot represent infinity as a fraction'].
	self isNaN ifTrue: [self error: 'Cannot represent Not-a-Number as a fraction'].


	" Extract the sign and the biased exponent "
	signexp := (self basicAt: 1) bitShift: -20.
	positive := (signexp bitAnd: 16r800) = 0.
	expPart := signexp bitAnd: 16r7FF.

	" Extract fractional part; answer 0 if this is a true 0.0 value "
	fractionPart := (((self basicAt: 1) bitAnd: 16rFFFFF) bitShift: 32)+ (self basicAt: 2).
	( expPart=0 and: [ fractionPart=0 ] ) ifTrue: [ ^ 0  ].

	" Replace omitted leading 1 in fraction unless gradual underflow"
	fraction := expPart = 0
		ifTrue: [fractionPart bitShift: 1]
		ifFalse: [fractionPart bitOr: 16r0010000000000000].
	signedFraction := positive ifTrue: [fraction] ifFalse: [fraction negated].
	
	"Unbias exponent: 16r3FF is bias; 52 is fraction width"
	exp := 16r3FF + 52 - expPart.

	" Form the result. When exp>52, the exponent is adjusted by
	  the number of trailing zero bits in the fraction to minimize
	  the (huge) time otherwise spent in #gcd:. "
	exp negative
		ifTrue: [
			result := signedFraction bitShift: exp negated ]
		ifFalse:	[
			zeroBitsCount _ fraction lowBit - 1.
			exp := exp - zeroBitsCount.
			exp <= 0
				ifTrue: [
					zeroBitsCount := zeroBitsCount + exp.
					"exp := 0."   " Not needed; exp not
refernced again "
					result := signedFraction bitShift:
zeroBitsCount negated ]
				ifFalse: [
					result := Fraction
						numerator: (signedFraction
bitShift: zeroBitsCount negated)
						denominator: (1 bitShift:
exp) ] ].

	"Low cost validation omitted after extensive testing"
	"(result asFloat = self) ifFalse: [self error: 'asTrueFraction validation failed']."
	^ result ! !

!Float methodsFor: 'converting'!
degreesToRadians
	"Answer the receiver in radians. Assumes the receiver is in degrees."

	^self * RadiansPerDegree! !

!Float methodsFor: 'converting' stamp: 'tao 10/10/97 16:38'!
isInf
	"simple, byte-order independent test for +/- Infinity"

	^ self = (self * 1.5 + 1.0)! !

!Float methodsFor: 'converting'!
radiansToDegrees
	"Answer the receiver in degrees. Assumes the receiver is in radians."

	^self / RadiansPerDegree! !


!Float methodsFor: 'copying'!
deepCopy

	^self copy! !

!Float methodsFor: 'copying'!
shallowCopy

	^self + 0.0! !

!Float methodsFor: 'copying' stamp: 'tk 8/19/1998 16:08'!
veryDeepCopyWith: deepCopier
	"Return self.  Do not record me."

	^ self clone! !


!Float methodsFor: 'mathematical functions'!
arcCos
	"Answer the angle in radians."

	^ Halfpi - self arcSin! !

!Float methodsFor: 'mathematical functions' stamp: 'jsp 2/25/1999 11:15'!
arcSin
	"Answer the angle in radians."

	((self < -1.0) or: [self > 1.0]) ifTrue: [self error: 'Value out of range'].
	((self = -1.0) or: [self = 1.0])
		ifTrue: [^ Halfpi * self]
		ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]! !

!Float methodsFor: 'mathematical functions'!
arcTan
	"Answer the angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| theta eps step sinTheta cosTheta |
	<primitive: 57>

	"Newton-Raphson"
	self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ].

	"first guess"
	theta _ (self * Halfpi) / (self + 1.0).

	"iterate"
	eps _ Halfpi * Epsilon.
	step _ theta.
	[(step * step) > eps] whileTrue: [
		sinTheta _ theta sin.
		cosTheta _ theta cos.
		step _ (sinTheta * cosTheta) - (self * cosTheta * cosTheta).
		theta _ theta - step].
	^ theta! !

!Float methodsFor: 'mathematical functions' stamp: 'HilaireFernandes 1/16/2006 21:47'!
arcTan: denominator
	"Answer the angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| result |

	(self = 0.0) ifTrue: [ (denominator > 0.0) ifTrue: [ result := 0 ]
										    ifFalse: [ result := Pi ]
						]
			    ifFalse: [(denominator = 0.0)
					ifTrue: [ (self > 0.0) ifTrue: [ result := Halfpi ]
												ifFalse: [ result := Halfpi negated ]
							]
					ifFalse: [ (denominator > 0) ifTrue: [ result := (self / denominator) arcTan ]
								 ifFalse: [ (self > 0) ifTrue: [result := ((self / denominator) arcTan) + Pi ]
															ifFalse: [result := ((self / denominator) arcTan) - Pi]
											]
							].
						].
	
	^ result.! !

!Float methodsFor: 'mathematical functions'!
cos
	"Answer the cosine of the receiver taken as an angle in radians."

	^ (self + Halfpi) sin! !

!Float methodsFor: 'mathematical functions'!
degreeCos
	"Answer the cosine of the receiver taken as an angle in degrees."

	^ self degreesToRadians cos! !

!Float methodsFor: 'mathematical functions'!
degreeSin
	"Answer the sine of the receiver taken as an angle in degrees."

	^ self degreesToRadians sin! !

!Float methodsFor: 'mathematical functions'!
exp
	"Answer E raised to the receiver power.
	 Optional. See Object documentation whatIsAPrimitive." 

	| base fract correction delta div |
	<primitive: 59>

	"Taylor series"
	"check the special cases"
	self < 0.0 ifTrue: [^ (self negated exp) reciprocal].
	self = 0.0 ifTrue: [^ 1].
	self abs > MaxValLn ifTrue: [self error: 'exp overflow'].

	"get first approximation by raising e to integer power"
	base _ E raisedToInteger: (self truncated).

	"now compute the correction with a short Taylor series"
	"fract will be 0..1, so correction will be 1..E"
	"in the worst case, convergance time is logarithmic with 1/Epsilon"
	fract _ self fractionPart.
	fract = 0.0 ifTrue: [ ^ base ].  "no correction required"

	correction _ 1.0 + fract.
	delta _ fract * fract / 2.0.
	div _ 2.0.
	[delta > Epsilon] whileTrue: [
		correction _ correction + delta.
		div _ div + 1.0.
		delta _ delta * fract / div].
	correction _ correction + delta.
	^ base * correction! !

!Float methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:28'!
floorLog: radix
	"Answer the floor of the log base radix of the receiver."

	^ (self log: radix) floor
! !

!Float methodsFor: 'mathematical functions'!
ln
	"Answer the natural logarithm of the receiver.
	 Optional. See Object documentation whatIsAPrimitive."

	| expt n mant x div pow delta sum eps |
	<primitive: 58>

	"Taylor series"
	self <= 0.0 ifTrue: [self error: 'ln is only defined for x > 0.0'].

	"get a rough estimate from binary exponent"
	expt _ self exponent.
	n _ Ln2 * expt.
	mant _ self timesTwoPower: 0 - expt.

	"compute fine correction from mantinssa in Taylor series"
	"mant is in the range [0..2]"
	"we unroll the loop to avoid use of abs"
	x _ mant - 1.0.
	div _ 1.0.
	pow _ delta _ sum _ x.
	x _ x negated.  "x <= 0"
	eps _ Epsilon * (n abs + 1.0).
	[delta > eps] whileTrue: [
		"pass one: delta is positive"
		div _ div + 1.0.
		pow _ pow * x.
		delta _ pow / div.
		sum _ sum + delta.
		"pass two: delta is negative"
		div _ div + 1.0.
		pow _ pow * x.
		delta _ pow / div.
		sum _ sum + delta].

	^ n + sum

	"2.718284 ln 1.0"! !

!Float methodsFor: 'mathematical functions'!
log
	"Answer the base 10 logarithm of the receiver."

	^ self ln / Ln10! !

!Float methodsFor: 'mathematical functions' stamp: 'AFi 11/23/2002 21:06'!
raisedTo: aNumber
	"Answer the receiver raised to aNumber."

	aNumber isInteger ifTrue:
		["Do the special case of integer power"
		^ self raisedToInteger: aNumber].
	self < 0.0 ifTrue:
		[ ArithmeticError signal: ' raised to a non-integer power' ].
	0.0 = aNumber ifTrue: [^ 1.0].				"special case for exponent = 0.0"
	(self= 0.0) | (aNumber = 1.0) ifTrue: [^ self].	"special case for self = 1.0"
	^ (self ln * aNumber asFloat) exp			"otherwise use logarithms"
! !

!Float methodsFor: 'mathematical functions' stamp: 'tao 4/19/98 23:22'!
reciprocalFloorLog: radix 
	"Quick computation of (self log: radix) floor, when self < 1.0.
	Avoids infinite recursion problems with denormalized numbers"

	| adjust scale n |
	adjust _ 0.
	scale _ 1.0.
	[(n _ radix / (self * scale)) isInfinite]
		whileTrue:
			[scale _ scale * radix.
			adjust _ adjust + 1].
	^ ((n floorLog: radix) + adjust) negated! !

!Float methodsFor: 'mathematical functions' stamp: 'tao 10/15/97 14:23'!
reciprocalLogBase2
	"optimized for self = 10, for use in conversion for printing"

	^ self = 10.0
		ifTrue: [Ln2 / Ln10]
		ifFalse: [Ln2 / self ln]! !

!Float methodsFor: 'mathematical functions' stamp: 'laza 12/21/1999 12:15'!
safeArcCos
	"Answer the angle in radians."
	(self between: -1.0 and: 1.0)
		ifTrue: [^ self arcCos]
		ifFalse: [^ self sign arcCos]! !

!Float methodsFor: 'mathematical functions'!
sin
	"Answer the sine of the receiver taken as an angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| sum delta self2 i |
	<primitive: 56>

	"Taylor series"
	"normalize to the range [0..Pi/2]"
	self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))].
	self > Twopi ifTrue: [^ (self \\ Twopi) sin].
	self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)].
	self > Halfpi ifTrue: [^ (Pi - self) sin].

	"unroll loop to avoid use of abs"
	sum _ delta _ self.
	self2 _ 0.0 - (self * self).
	i _ 2.0.
	[delta > Epsilon] whileTrue: [
		"once"
		delta _ (delta * self2) / (i * (i + 1.0)).
		i _ i + 2.0.
		sum _ sum + delta.
		"twice"
		delta _ (delta * self2) / (i * (i + 1.0)).
		i _ i + 2.0.
		sum _ sum + delta].
	^ sum! !

!Float methodsFor: 'mathematical functions' stamp: 'RAH 4/25/2000 19:49'!
sqrt
	"Answer the square root of the receiver. 
	 Optional. See Object documentation whatIsAPrimitive."
	| exp guess eps delta |
	<primitive: 55>
	#Numeric.
	"Changed 200/01/19 For ANSI <number> support."
	"Newton-Raphson"
	self <= 0.0
		ifTrue: [self = 0.0
				ifTrue: [^ 0.0]
				ifFalse: ["v Chg"
					^ FloatingPointException signal: 'undefined if less than zero.']].
	"first guess is half the exponent"
	exp := self exponent // 2.
	guess := self timesTwoPower: 0 - exp.
	"get eps value"
	eps := guess * Epsilon.
	eps := eps * eps.
	delta := self - (guess * guess) / (guess * 2.0).
	[delta * delta > eps]
		whileTrue: 
			[guess := guess + delta.
			delta := self - (guess * guess) / (guess * 2.0)].
	^ guess! !

!Float methodsFor: 'mathematical functions'!
tan
	"Answer the tangent of the receiver taken as an angle in radians."

	^ self sin / self cos! !

!Float methodsFor: 'mathematical functions'!
timesTwoPower: anInteger 
	"Primitive. Answer with the receiver multiplied by 2.0 raised
	to the power of the argument.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 54>

	anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)].
	anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat].
	anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat].
	^ self * (2.0 raisedToInteger: anInteger)! !


!Float methodsFor: 'printing' stamp: 'MPW 1/1/1901 01:59'!
absByteEncode: aStream base: base
	"Print my value on a stream in the given base.  Assumes that my value is strictly
	positive; negative numbers, zero, and NaNs have already been handled elsewhere.
	Based upon the algorithm outlined in:
	Robert G. Burger and R. Kent Dybvig
	Printing Floating Point Numbers Quickly and Accurately
	ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation
	June 1996.
	This version performs all calculations with Floats instead of LargeIntegers, and loses
	about 3 lsbs of accuracy compared to an exact conversion."

	| significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount |
	self isInfinite ifTrue: [aStream print: 'Infinity'. ^ self].
	significantBits _ 50.  "approximately 3 lsb's of accuracy loss during conversion"
	fBase _ base asFloat.
	exp _ self exponent.
	baseExpEstimate _ (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
	exp >= 0
		ifTrue:
			[r _ self.
			s _ 1.0.
			mPlus _ 1.0 timesTwoPower: exp - significantBits.
			mMinus _ self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]]
		ifFalse:
			[r _ self timesTwoPower: significantBits.
			s _ 1.0 timesTwoPower:  significantBits.
			mMinus _ 1.0 timesTwoPower: (exp max: -1024).
			mPlus _
				(exp = MinValLogBase2) | (self significand ~= 1.0)
					ifTrue: [mMinus]
					ifFalse: [mMinus * 2.0]].
	baseExpEstimate >= 0
		ifTrue:
			[s _ s * (fBase raisedToInteger: baseExpEstimate).
			exp = 1023
				ifTrue:   "scale down to prevent overflow to Infinity during conversion"
					[r _ r / fBase.
					s _ s / fBase.
					mPlus _ mPlus / fBase.
					mMinus _ mMinus / fBase]]
		ifFalse:
			[exp < -1023
				ifTrue:   "scale up to prevent denorm reciprocals overflowing to Infinity"
					[d _ (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
					scale _ fBase raisedToInteger: d.
					r _ r * scale.
					mPlus _ mPlus * scale.
					mMinus _ mMinus * scale.
					scale _ fBase raisedToInteger: (baseExpEstimate + d) negated]
				ifFalse:
				[scale _ fBase raisedToInteger: baseExpEstimate negated].
			s _ s / scale].
	(r + mPlus >= s)
		ifTrue: [baseExpEstimate _ baseExpEstimate + 1]
		ifFalse:
			[s _ s / fBase].
	(fixedFormat _ baseExpEstimate between: -3 and: 6)
		ifTrue:
			[decPointCount _ baseExpEstimate.
			baseExpEstimate <= 0
				ifTrue: [aStream print: ('0.000000' truncateTo: 2 - baseExpEstimate)]]
		ifFalse:
			[decPointCount _ 1].
	[d _ (r / s) truncated.
	r _ r - (d * s).
	(tc1 _ r <= mMinus) | (tc2 _ r + mPlus >= s)] whileFalse:
		[aStream print: (Character digitValue: d).
		r _ r * fBase.
		mPlus _ mPlus * fBase.
		mMinus _ mMinus * fBase.
		decPointCount _ decPointCount - 1.
		decPointCount = 0 ifTrue: [aStream print: $.]].
	tc2 ifTrue:
		[tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d _ d + 1]].
	aStream print: (Character digitValue: d).
	decPointCount > 0
		ifTrue:
		[decPointCount - 1 to: 1 by: -1 do: [:i | aStream print: $0].
		aStream print: '.0'].
	fixedFormat ifFalse:
		[aStream print: $e.
		aStream print: (baseExpEstimate - 1) printString]! !

!Float methodsFor: 'printing' stamp: 'tao 4/19/98 23:21'!
absPrintExactlyOn: aStream base: base
	"Print my value on a stream in the given base.  Assumes that my value is strictly
	positive; negative numbers, zero, and NaNs have already been handled elsewhere.
	Based upon the algorithm outlined in:
	Robert G. Burger and R. Kent Dybvig
	Printing Floating Point Numbers Quickly and Accurately
	ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation
	June 1996.
	This version guarantees that the printed representation exactly represents my value
	by using exact integer arithmetic."

	| fBase significand exp baseExpEstimate be be1 r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount |
	self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self].
	fBase _ base asFloat.
	significand _ self significandAsInteger.
	roundingIncludesLimits _ significand even.
	exp _ (self exponent - 52) max: MinValLogBase2.
	baseExpEstimate _ (self exponent * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
	exp >= 0
		ifTrue:
			[be _ 1 << exp.
			significand ~= 16r10000000000000
				ifTrue:
					[r _ significand * be * 2.
					s _ 2.
					mPlus _ be.
					mMinus _ be]
				ifFalse:
					[be1 _ be * 2.
					r _ significand * be1 * 2.
					s _ 4.
					mPlus _ be1.
					mMinus _ be]]
		ifFalse:
			[(exp = MinValLogBase2) | (significand ~= 16r10000000000000)
				ifTrue:
					[r _ significand * 2.
					s _ (1 << (exp negated)) * 2.
					mPlus _ 1.
					mMinus _ 1]
				ifFalse:
					[r _ significand * 4.
					s _ (1 << (exp negated + 1)) * 2.
					mPlus _ 2.
					mMinus _ 1]].
	baseExpEstimate >= 0
		ifTrue: [s _ s * (base raisedToInteger: baseExpEstimate)]
		ifFalse:
			[scale _ base raisedToInteger: baseExpEstimate negated.
			r _ r * scale.
			mPlus _ mPlus * scale.
			mMinus _ mMinus * scale].
	(r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s))
		ifTrue: [baseExpEstimate _ baseExpEstimate + 1]
		ifFalse:
			[r _ r * base.
			mPlus _ mPlus * base.
			mMinus _ mMinus * base].
	(fixedFormat _ baseExpEstimate between: -3 and: 6)
		ifTrue:
			[decPointCount _ baseExpEstimate.
			baseExpEstimate <= 0
				ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]]
		ifFalse:
			[decPointCount _ 1]. 
	[d _ r // s.
	r _ r \\ s.
	(tc1 _ (r < mMinus) | (roundingIncludesLimits & (r = mMinus))) |
	(tc2 _ (r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s)))] whileFalse:
		[aStream nextPut: (Character digitValue: d).
		r _ r * base.
		mPlus _ mPlus * base.
		mMinus _ mMinus * base.
		decPointCount _ decPointCount - 1.
		decPointCount = 0 ifTrue: [aStream nextPut: $.]].
	tc2 ifTrue:
		[tc1 not | (tc1 & (r*2 >= s)) ifTrue: [d _ d + 1]].
	aStream nextPut: (Character digitValue: d).
	decPointCount > 0
		ifTrue:
		[decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0].
		aStream nextPutAll: '.0'].
	fixedFormat ifFalse:
		[aStream nextPut: $e.
		aStream nextPutAll: (baseExpEstimate - 1) printString]! !

!Float methodsFor: 'printing' stamp: 'tao 4/22/98 11:58'!
absPrintOn: aStream base: base
	"Print my value on a stream in the given base.  Assumes that my value is strictly
	positive; negative numbers, zero, and NaNs have already been handled elsewhere.
	Based upon the algorithm outlined in:
	Robert G. Burger and R. Kent Dybvig
	Printing Floating Point Numbers Quickly and Accurately
	ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation
	June 1996.
	This version performs all calculations with Floats instead of LargeIntegers, and loses
	about 3 lsbs of accuracy compared to an exact conversion."

	| significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount |
	self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self].
	significantBits _ 50.  "approximately 3 lsb's of accuracy loss during conversion"
	fBase _ base asFloat.
	exp _ self exponent.
	baseExpEstimate _ (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
	exp >= 0
		ifTrue:
			[r _ self.
			s _ 1.0.
			mPlus _ 1.0 timesTwoPower: exp - significantBits.
			mMinus _ self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]]
		ifFalse:
			[r _ self timesTwoPower: significantBits.
			s _ 1.0 timesTwoPower:  significantBits.
			mMinus _ 1.0 timesTwoPower: (exp max: -1024).
			mPlus _
				(exp = MinValLogBase2) | (self significand ~= 1.0)
					ifTrue: [mMinus]
					ifFalse: [mMinus * 2.0]].
	baseExpEstimate >= 0
		ifTrue:
			[s _ s * (fBase raisedToInteger: baseExpEstimate).
			exp = 1023
				ifTrue:   "scale down to prevent overflow to Infinity during conversion"
					[r _ r / fBase.
					s _ s / fBase.
					mPlus _ mPlus / fBase.
					mMinus _ mMinus / fBase]]
		ifFalse:
			[exp < -1023
				ifTrue:   "scale up to prevent denorm reciprocals overflowing to Infinity"
					[d _ (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
					scale _ fBase raisedToInteger: d.
					r _ r * scale.
					mPlus _ mPlus * scale.
					mMinus _ mMinus * scale.
					scale _ fBase raisedToInteger: (baseExpEstimate + d) negated]
				ifFalse:
				[scale _ fBase raisedToInteger: baseExpEstimate negated].
			s _ s / scale].
	(r + mPlus >= s)
		ifTrue: [baseExpEstimate _ baseExpEstimate + 1]
		ifFalse:
			[s _ s / fBase].
	(fixedFormat _ baseExpEstimate between: -3 and: 6)
		ifTrue:
			[decPointCount _ baseExpEstimate.
			baseExpEstimate <= 0
				ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]]
		ifFalse:
			[decPointCount _ 1].
	[d _ (r / s) truncated.
	r _ r - (d * s).
	(tc1 _ r <= mMinus) | (tc2 _ r + mPlus >= s)] whileFalse:
		[aStream nextPut: (Character digitValue: d).
		r _ r * fBase.
		mPlus _ mPlus * fBase.
		mMinus _ mMinus * fBase.
		decPointCount _ decPointCount - 1.
		decPointCount = 0 ifTrue: [aStream nextPut: $.]].
	tc2 ifTrue:
		[tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d _ d + 1]].
	aStream nextPut: (Character digitValue: d).
	decPointCount > 0
		ifTrue:
		[decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0].
		aStream nextPutAll: '.0'].
	fixedFormat ifFalse:
		[aStream nextPut: $e.
		aStream nextPutAll: (baseExpEstimate - 1) printString]! !

!Float methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:02'!
byteEncode: aStream base: base
	"Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" 

	self isNaN ifTrue: [aStream print: 'NaN'. ^ self]. "check for NaN before sign"
	self > 0.0
		ifTrue: [self absByteEncode: aStream base: base]
		ifFalse:
			[self sign = -1
				ifTrue: [aStream print: '-'].
			self = 0.0
				ifTrue: [aStream print: '0.0'. ^ self]
				ifFalse: [aStream writeNumber:self negated base: base]]! !

!Float methodsFor: 'printing'!
hex  "If ya really want to know..."
	| word nibble |
	^ String streamContents:
		[:strm |
		1 to: 2 do:
			[:i | word _ self at: i.
			1 to: 8 do: 
				[:s | nibble _ (word bitShift: -8+s*4) bitAnd: 16rF.
				strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]]
"
(-2.0 to: 2.0) collect: [:f | f hex]
"! !

!Float methodsFor: 'printing' stamp: 'tao 4/19/98 23:31'!
printOn: aStream base: base
	"Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" 

	self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign"
	self > 0.0
		ifTrue: [self absPrintOn: aStream base: base]
		ifFalse:
			[self sign = -1
				ifTrue: [aStream nextPutAll: '-'].
			self = 0.0
				ifTrue: [aStream nextPutAll: '0.0'. ^ self]
				ifFalse: [self negated absPrintOn: aStream base: base]]! !

!Float methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'!
printPaddedWith: aCharacter to: aNumber 
	"Answer the string containing the ASCII representation of the receiver 
	padded on the left with aCharacter to be at least on aNumber 
	integerPart characters and padded the right with aCharacter to be at 
	least anInteger fractionPart characters."
	| aStream digits fPadding fLen iPadding iLen curLen periodIndex |
	#Numeric.
	"2000/03/04  Harmon R. Added Date and Time support"
	aStream := WriteStream on: (String new: 10).
	self printOn: aStream.
	digits := aStream contents.
	periodIndex := digits indexOf: $..
	curLen := periodIndex - 1.
	iLen := aNumber integerPart.
	curLen < iLen
		ifTrue: [iPadding := (String new: (iLen - curLen) asInteger) atAllPut: aCharacter;
					 yourself]
		ifFalse: [iPadding := ''].
	curLen := digits size - periodIndex.
	fLen := (aNumber fractionPart * (aNumber asFloat exponent * 10)) asInteger.
	curLen < fLen
		ifTrue: [fPadding := (String new: fLen - curLen) atAllPut: aCharacter;
					 yourself]
		ifFalse: [fPadding := ''].
	^ iPadding , digits , fPadding! !


!Float methodsFor: 'testing' stamp: 'bf 8/20/1999 12:56'!
hasContentsInExplorer

	^false! !

!Float methodsFor: 'testing'!
isFloat
	^ true! !

!Float methodsFor: 'testing' stamp: 'jm 4/30/1998 13:50'!
isInfinite
	"Return true if the receiver is positive or negative infinity."

	^ self = Infinity or: [self = NegativeInfinity]
! !

!Float methodsFor: 'testing'!
isLiteral

	^true! !

!Float methodsFor: 'testing' stamp: 'tao 10/10/97 16:39'!
isNaN
	"simple, byte-order independent test for Not-a-Number"

	^ self ~= self! !

!Float methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'!
isPowerOfTwo
	"Return true if the receiver is an integral power of two.
	Floats never return true here."
	^false! !

!Float methodsFor: 'testing'!
isZero
	^self = 0.0! !

!Float methodsFor: 'testing' stamp: 'jm 4/28/1998 01:10'!
sign
	"Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0.
	Handle IEEE-754 negative-zero by reporting a sign of -1"

	self > 0 ifTrue: [^ 1].
	(self < 0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1].
	^ 0! !


!Float methodsFor: 'truncation and round off'!
exponent
	"Primitive. Consider the receiver to be represented as a power of two
	multiplied by a mantissa (between one and two). Answer with the
	SmallInteger to whose power two is raised. Optional. See Object
	documentation whatIsAPrimitive."

	| positive |
	<primitive: 53>
	self >= 1.0 ifTrue: [^self floorLog: 2].
	self > 0.0
		ifTrue: 
			[positive _ (1.0 / self) exponent.
			self = (1.0 / (1.0 timesTwoPower: positive))
				ifTrue: [^positive negated]
				ifFalse: [^positive negated - 1]].
	self = 0.0 ifTrue: [^-1].
	^self negated exponent! !

!Float methodsFor: 'truncation and round off'!
fractionPart
	"Primitive. Answer a Float whose value is the difference between the 
	receiver and the receiver's asInteger value. Optional. See Object 
	documentation whatIsAPrimitive."

	<primitive: 52>
	^self - self truncated asFloat! !

!Float methodsFor: 'truncation and round off'!
integerPart
	"Answer a Float whose value is the receiver's truncated value."

	^self - self fractionPart! !

!Float methodsFor: 'truncation and round off' stamp: 'tk 12/30/2000 20:04'!
reduce
    "If self is close to an integer, return that integer"

    (self closeTo: self rounded) ifTrue: [^ self rounded]! !

!Float methodsFor: 'truncation and round off'!
rounded
	"Answer the integer nearest the receiver."

	self >= 0.0
		ifTrue: [^(self + 0.5) truncated]
		ifFalse: [^(self - 0.5) truncated]! !

!Float methodsFor: 'truncation and round off' stamp: 'tao 4/19/98 13:14'!
significand

	^ self timesTwoPower: (self exponent negated)! !

!Float methodsFor: 'truncation and round off' stamp: 'tao 4/19/98 14:27'!
significandAsInteger

	| exp sig |
	exp _ self exponent.
	sig _ (((self at: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self at: 2).
	exp > -1023
		ifTrue: [sig _ sig bitOr: (1 bitShift: 52)].
	^ sig.! !

!Float methodsFor: 'truncation and round off' stamp: 'nice 4/26/2006 05:09'!
truncated
	"Answer with a SmallInteger equal to the value of the receiver without 
	its fractional part. The primitive fails if the truncated value cannot be 
	represented as a SmallInteger. In that case, the code below will compute 
	a LargeInteger truncated value.
	Essential. See Object documentation whatIsAPrimitive. "

	<primitive: 51>
	(self isInfinite or: [self isNaN]) ifTrue: [self error: 'Cannot truncate this number'].

	self abs < 2.0e16
		ifTrue: ["Fastest way when it may not be an integer"
				"^ (self quo: 1073741823.0) * 1073741823 + (self rem: 1073741823.0) truncated"
				| di df q r |
				di := (SmallInteger maxVal bitShift: -1)+1.
				df := di asFloat.
				q := self quo: df.
				r := self - (q asFloat * df).
				^q*di+r truncated]
		ifFalse: [^ self asTrueFraction.  "Extract all bits of the mantissa and shift if necess"]

		

		! !


!Float methodsFor: 'private' stamp: 'ls 10/10/1999 11:55'!
absPrintOn: aStream base: base digitCount: digitCount 
	"Print me in the given base, using digitCount significant figures."

	| fuzz x exp q fBase scale logScale xi |
	self isInf ifTrue: [^ aStream nextPutAll: 'Inf'].
	fBase _ base asFloat.
	"x is myself normalized to [1.0, fBase), exp is my exponent"
	exp _ 
		self < 1.0
			ifTrue: [self reciprocalFloorLog: fBase]
			ifFalse: [self floorLog: fBase].
	scale _ 1.0.
	logScale _ 0.
	[(x _ fBase raisedTo: (exp + logScale)) = 0]
		whileTrue:
			[scale _ scale * fBase.
			logScale _ logScale + 1].
	x _ self * scale / x.
	fuzz _ fBase raisedTo: 1 - digitCount.
	"round the last digit to be printed"
	x _ 0.5 * fuzz + x.
	x >= fBase
		ifTrue: 
			["check if rounding has unnormalized x"
			x _ x / fBase.
			exp _ exp + 1].
	(exp < 6 and: [exp > -4])
		ifTrue: 
			["decimal notation"
			q _ 0.
			exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000'
at: i)]]]
		ifFalse: 
			["scientific notation"
			q _ exp.
			exp _ 0].
	[x >= fuzz]
		whileTrue: 
			["use fuzz to track significance"
			xi _ x asInteger.
			aStream nextPut: (Character digitValue: xi).
			x _ x - xi asFloat * fBase.
			fuzz _ fuzz * fBase.
			exp _ exp - 1.
			exp = -1 ifTrue: [aStream nextPut: $.]].
	[exp >= -1]
		whileTrue: 
			[aStream nextPut: $0.
			exp _ exp - 1.
			exp = -1 ifTrue: [aStream nextPut: $.]].
	q ~= 0
		ifTrue: 
			[aStream nextPut: $e.
			q printOn: aStream]! !

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

Float class
	instanceVariableNames: ''!

!Float class methodsFor: 'class initialization' stamp: 'yo 6/17/2004 17:44'!
initialize
	"Float initialize"
	"Constants from Computer Approximations, pp. 182-183:
		Pi = 3.14159265358979323846264338327950288
		Pi/2 = 1.57079632679489661923132169163975144
		Pi*2 = 6.28318530717958647692528676655900576
		Pi/180 = 0.01745329251994329576923690768488612
		2.0 ln = 0.69314718055994530941723212145817657
		2.0 sqrt = 1.41421356237309504880168872420969808"

	Pi _ 3.14159265358979323846264338327950288.
	Halfpi _ Pi / 2.0.
	Twopi _ Pi * 2.0.
	ThreePi _ Pi * 3.0.
	RadiansPerDegree _ Pi / 180.0.

	Ln2 _ 0.69314718055994530941723212145817657.
	Ln10 _ 10.0 ln.
	Sqrt2 _ 1.41421356237309504880168872420969808.
	E _ 2.718281828459045235360287471353.

	Epsilon _ 0.000000000001.  "Defines precision of mathematical functions"

	MaxVal _ 1.7976931348623159e308.
	MaxValLn _ 709.782712893384.
	MinValLogBase2 _ -1074.

	Infinity _ MaxVal * MaxVal.
	NegativeInfinity _ 0.0 - Infinity.
	NaN _ Infinity - Infinity.
	NegativeZero _ 1.0 / Infinity negated.
! !


!Float class methodsFor: 'constants'!
e
	"Answer the constant, E."

	^E! !

!Float class methodsFor: 'constants' stamp: 'sw 10/8/1999 22:59'!
halfPi
	^ Halfpi! !

!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 11:37'!
infinity
	"Answer the value used to represent an infinite magnitude"

	^ Infinity! !

!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 11:38'!
nan
	"Answer the canonical value used to represent Not-A-Number"

	^ NaN! !

!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 12:05'!
negativeZero

	^ NegativeZero! !

!Float class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'!
one
	#Numeric.
	"add 200/01/19 For <number> protocol support."
	^ 1.0! !

!Float class methodsFor: 'constants'!
pi
	"Answer the constant, Pi."

	^Pi! !

!Float class methodsFor: 'constants' stamp: 'yo 6/17/2004 17:44'!
threePi

	^ ThreePi
! !

!Float class methodsFor: 'constants' stamp: 'yo 6/17/2004 17:41'!
twoPi

	^ Twopi
! !


!Float class methodsFor: 'instance creation' stamp: 'nice 5/30/2006 03:13'!
fromIEEE32Bit: word
	"Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Squeak float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects."
	
	| sign mantissa exponent newFloat delta |
	word negative ifTrue: [^ self error:'Cannot deal with negative numbers'].
	word = 0 ifTrue: [^ 0.0].
	sign := word bitAnd: 16r80000000.
	word = sign ifTrue: [^self negativeZero].
	
	exponent := ((word bitShift: -23) bitAnd: 16rFF) - 127.
	mantissa := word bitAnd:  16r7FFFFF.

	exponent = 128 ifTrue:["Either NAN or INF"
		mantissa = 0 ifFalse:[^ Float nan].
		sign = 0 
			ifTrue:[^ Float infinity]
			ifFalse:[^ Float infinity negated]].

	exponent = -127 ifTrue: [
		"gradual underflow (denormalized number)
		Remove first bit of mantissa and adjust exponent"
		delta := mantissa highBit.
		mantissa := (mantissa bitShift: 1) bitAnd: (1 bitShift: delta) - 1.
		exponent := exponent + delta - 23].
	
	"Create new float"
	newFloat := self new: 2.
	newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)).
	newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29).
	^newFloat! !

!Float class methodsFor: 'instance creation'!
readFrom: aStream 
	"Answer a new Float as described on the stream, aStream."

	^(super readFrom: aStream) asFloat! !
ArrayedCollection variableWordSubclass: #FloatArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!FloatArray commentStamp: '<historical>' prior: 0!
FloatArrays store 32bit IEEE floating point numbers.!


!FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
at: index
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
at: index put: value
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

!FloatArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0.0! !

!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'!
length
	"Return the length of the receiver"
	^self squaredLength sqrt! !

!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'!
squaredLength
	"Return the squared length of the receiver"
	^self dot: self! !


!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/7/2001 23:07'!
adaptToNumber: rcvr andSend: selector
	"If I am involved in arithmetic with a Number. If possible,
	convert it to a float and perform the (more efficient) primitive operation."
	selector == #+ ifTrue:[^self + rcvr].
	selector == #* ifTrue:[^self * rcvr].
	selector == #- ifTrue:[^self negated += rcvr].
	selector == #/ ifTrue:[^self * (1.0 / rcvr)].
	^super adaptToNumber: rcvr andSend: selector! !

!FloatArray methodsFor: 'arithmetic' stamp: 'laza 3/24/2000 13:07'!
dot: aFloatVector
	"Primitive. Return the dot product of the receiver and the argument.
	Fail if the argument is not of the same size as the receiver."
	| result |
	"<primitive:'primitiveFloatArrayDotProduct'>"
	self size = aFloatVector size ifFalse:[^self error:'Must be equal size'].
	result _ 0.0.
	1 to: self size do:[:i|
		result _ result + ((self at: i) * (aFloatVector at: i)).
	].
	^result! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/7/2001 23:04'!
negated
	^self clone *= -1! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'!
* anObject
	^self clone *= anObject! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'!
*= anObject
	^anObject isNumber
		ifTrue:[self primMulScalar: anObject asFloat]
		ifFalse:[self primMulArray: anObject]! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'!
+ anObject
	^self clone += anObject! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:48'!
+= anObject
	^anObject isNumber
		ifTrue:[self primAddScalar: anObject asFloat]
		ifFalse:[self primAddArray: anObject]! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'!
- anObject
	^self clone -= anObject! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'!
-= anObject
	^anObject isNumber
		ifTrue:[self primSubScalar: anObject asFloat]
		ifFalse:[self primSubArray: anObject]! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:34'!
/ anObject
	^self clone /= anObject! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 10/7/1998 19:58'!
/= anObject
	^anObject isNumber
		ifTrue:[self primDivScalar: anObject asFloat]
		ifFalse:[self primDivArray: anObject]! !

!FloatArray methodsFor: 'arithmetic' stamp: 'yo 9/14/2004 17:12'!
\\= other

	other isNumber ifTrue: [
		1 to: self size do: [:i |
			self at: i put: (self at: i) \\ other
		].
		^ self.
	].
	1 to: (self size min: other size) do: [:i |
		self at: i put: (self at: i) \\ (other at: i).
	].

! !


!FloatArray methodsFor: 'comparing' stamp: 'ar 5/3/2001 13:02'!
hash
	| result |
	<primitive:'primitiveHashArray' module: 'FloatArrayPlugin'>
	result _ 0.
	1 to: self size do:[:i| result _ result + (self basicAt: i) ].
	^result bitAnd: 16r1FFFFFFF! !

!FloatArray methodsFor: 'comparing' stamp: 'ar 2/2/2001 15:47'!
= aFloatArray 
	| length |
	<primitive: 'primitiveEqual' module: 'FloatArrayPlugin'>
	aFloatArray class = self class ifFalse: [^ false].
	length _ self size.
	length = aFloatArray size ifFalse: [^ false].
	1 to: self size do: [:i | (self at: i)
			= (aFloatArray at: i) ifFalse: [^ false]].
	^ true! !


!FloatArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'!
asFloatArray
	^self! !


!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primAddArray: floatArray

	<primitive: 'primitiveAddFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primAddScalar: scalarValue

	<primitive: 'primitiveAddScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primDivArray: floatArray

	<primitive: 'primitiveDivFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) / (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primDivScalar: scalarValue

	<primitive: 'primitiveDivScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primMulArray: floatArray

	<primitive: 'primitiveMulFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primMulScalar: scalarValue

	<primitive: 'primitiveMulScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primSubArray: floatArray

	<primitive: 'primitiveSubFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primSubScalar: scalarValue

	<primitive: 'primitiveSubScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'jcg 6/12/2003 17:54'!
sum

	<primitive: 'primitiveSum' module: 'FloatArrayPlugin'>
	^ super sum! !


!FloatArray methodsFor: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:33'!
inspectorClass 
	"Answer the class of the inspector to be used on the receiver.  Called by inspect; 
	use basicInspect to get a normal (less useful) type of inspector."

	^OrderedCollectionInspector! !


!FloatArray methodsFor: 'private' stamp: 'ar 10/9/1998 11:27'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !
ClassTestCase subclass: #FloatArrayTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Arrayed'!
!FloatArrayTest commentStamp: 'nice 5/30/2006 01:24' prior: 0!
These tests are used to assert that FloatArrayPlugin has same results as Float asIEEE32BitWord!


!FloatArrayTest methodsFor: 'testing' stamp: 'nice 5/30/2006 03:17'!
testFloatArrayPluginPrimitiveAt
	"if FloatArrayPlugin primitive are not here, this test is dumb.
	Otherwise, it will compare primitive and #fromIEEE32Bit:"
	
	#(
		"regular numbers no truncation or rounding"
		2r0.0 2r1.0 2r1.1 2r1.00000000000000000000001
		2r1.0e-10 2r1.1e-10 2r1.00000000000000000000001e-10
		2r1.0e10 2r1.1e10 2r1.00000000000000000000001e10
		
		"smallest float32 before gradual underflow"
		2r1.0e-126
		
		"biggest float32"
		2r1.11111111111111111111111e127
		
		"overflow"
		2r1.11111111111111111111111e128
		
		"gradual underflow"
		2r0.11111111111111111111111e-126
		2r0.00000000000000000000001e-126
		
		"with rounding mode : tests on 25 bits"
		
		2r1.0000000000000000000000001
		2r1.0000000000000000000000010
		2r1.0000000000000000000000011
		2r1.0000000000000000000000100
		2r1.0000000000000000000000101
		2r1.0000000000000000000000110
		2r1.0000000000000000000000111
		2r1.1111111111111111111111001
		2r1.1111111111111111111111010
		2r1.1111111111111111111111011
		2r1.1111111111111111111111101
		2r1.1111111111111111111111110
		2r1.1111111111111111111111111
		
		"overflow"
		2r1.1111111111111111111111110e127
		
		"gradual underflow"
		2r0.1111111111111111111111111e-126
		2r0.1111111111111111111111110e-126
		2r0.1111111111111111111111101e-126
		2r0.1111111111111111111111011e-126
		2r0.1111111111111111111111010e-126
		2r0.1111111111111111111111001e-126
		2r0.0000000000000000000000111e-126
		2r0.0000000000000000000000110e-126
		2r0.0000000000000000000000101e-126
		2r0.0000000000000000000000011e-126
		2r0.0000000000000000000000010e-126
		2r0.0000000000000000000000001e-126
		2r0.0000000000000000000000010000000000000000000000000001e-126
		) do: [:e |
			self assert: ((FloatArray with: e) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1)).
			self assert: ((FloatArray with: e negated) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e negated) basicAt: 1))].
		
	"special cases"
	(Array with: Float infinity with: Float infinity negated with: Float negativeZero)
		do: [:e | self assert: ((FloatArray with: e) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1))].
		
	"Cannot compare NaN"
	(Array with: Float nan)
		do: [:e | self assert: (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1)) isNaN].! !

!FloatArrayTest methodsFor: 'testing' stamp: 'nice 5/30/2006 03:17'!
testFloatArrayPluginPrimitiveAtPut
	"if FloatArrayPlugin primitive are not here, this test is dumb.
	Otherwise, it will compare primitive and #asIEEE32BitWord"
	
	#(
		"regular numbers no truncation or rounding"
		2r0.0 2r1.0 2r1.1 2r1.00000000000000000000001
		2r1.0e-10 2r1.1e-10 2r1.00000000000000000000001e-10
		2r1.0e10 2r1.1e10 2r1.00000000000000000000001e10
		
		"smallest float32 before gradual underflow"
		2r1.0e-126
		
		"biggest float32"
		2r1.11111111111111111111111e127
		
		"overflow"
		2r1.11111111111111111111111e128
		
		"gradual underflow"
		2r0.11111111111111111111111e-126
		2r0.00000000000000000000001e-126
		
		"with rounding mode : tests on 25 bits"
		
		2r1.0000000000000000000000001
		2r1.0000000000000000000000010
		2r1.0000000000000000000000011
		2r1.0000000000000000000000100
		2r1.0000000000000000000000101
		2r1.0000000000000000000000110
		2r1.0000000000000000000000111
		2r1.1111111111111111111111001
		2r1.1111111111111111111111010
		2r1.1111111111111111111111011
		2r1.1111111111111111111111101
		2r1.1111111111111111111111110
		2r1.1111111111111111111111111
		
		"overflow"
		2r1.1111111111111111111111110e127
		
		"gradual underflow"
		2r0.1111111111111111111111111e-126
		2r0.1111111111111111111111110e-126
		2r0.1111111111111111111111101e-126
		2r0.1111111111111111111111011e-126
		2r0.1111111111111111111111010e-126
		2r0.1111111111111111111111001e-126
		2r0.0000000000000000000000111e-126
		2r0.0000000000000000000000110e-126
		2r0.0000000000000000000000101e-126
		2r0.0000000000000000000000011e-126
		2r0.0000000000000000000000010e-126
		2r0.0000000000000000000000001e-126
		2r0.0000000000000000000000010000000000000000000000000001e-126
		) do: [:e |
			self assert: ((FloatArray with: e) basicAt: 1) = e asIEEE32BitWord.
			self assert: ((FloatArray with: e negated) basicAt: 1) = e negated asIEEE32BitWord].
		
	"special cases"
	(Array with: Float infinity with: Float infinity negated with: Float negativeZero with: Float nan)
		do: [:e | self assert: ((FloatArray with: e) basicAt: 1) = e asIEEE32BitWord].
		! !
TestCase subclass: #FloatMathPluginTests
	instanceVariableNames: 'random'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-VM'!
!FloatMathPluginTests commentStamp: '<historical>' prior: 0!
FloatMathPluginTests buildSuite run.!


!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:34'!
arcCosH: f
	<primitive: 'primitiveArcCosH' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:34'!
arcCos: f
	<primitive: 'primitiveArcCos' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:34'!
arcSinH: f
	<primitive: 'primitiveArcSinH' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:34'!
arcSin: f
	<primitive: 'primitiveArcSin' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:35'!
arcTan2: value with: arg
	<primitive: 'primitiveArcTan2' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:35'!
arcTanH: value
	<primitive: 'primitiveArcTanH' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 14:29'!
arcTan: value
	<primitive: 'primitiveArcTan' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:35'!
cosH: value
	<primitive: 'primitiveCosH' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:35'!
cos: value
	<primitive: 'primitiveCos' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 14:29'!
exp: value
	<primitive: 'primitiveExp' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 14:29'!
fractionPart: value
	<primitive: 'primitiveFractionalPart' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:36'!
hypot: x with: y
	<primitive: 'primitiveHypot' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:24'!
ln: value
	<primitive: 'primitiveLogN' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:41'!
log10: value
	<primitive: 'primitiveLog10' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:37'!
sinH: value
	<primitive: 'primitiveSinH' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 14:29'!
sin: value
	<primitive: 'primitiveSin' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 14:29'!
sqrt: value
	<primitive: 'primitiveSqrt' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:37'!
tanH: value
	<primitive: 'primitiveTanH' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 17:37'!
tan: value
	<primitive: 'primitiveTan' module: 'FloatMathPlugin'>
	^self primitiveFailed! !

!FloatMathPluginTests methodsFor: 'math' stamp: 'ar 3/26/2006 14:29'!
timesTwoPower: f with: arg
	<primitive: 'primitiveTimesTwoPower' module: 'FloatMathPlugin'>
	^self primitiveFailed! !


!FloatMathPluginTests methodsFor: 'running' stamp: 'ar 3/26/2006 16:52'!
makeLargeTestData
	"self basicNew makeLargeTestData"
	self makeTestData: 'sin-large.dat' using:[:f| self sin: f] seed: 432567 rounds: 1000000.
	self makeTestData: 'log-large.dat' using:[:f| self ln: f abs] seed: 432567 rounds: 1000000.
	self makeTestData: 'sqrt-large.dat' using:[:f| self sqrt: f abs] seed: 432567 rounds: 1000000.
	self makeTestData: 'atan-large.dat' using:[:f| self arcTan: f] seed: 432567 rounds: 1000000.
	self makeTestData: 'exp-large.dat' using:[:f| self exp: f] seed: 432567 rounds: 1000000.
! !

!FloatMathPluginTests methodsFor: 'running' stamp: 'ar 3/26/2006 16:52'!
makeSmallTestData
	"self basicNew makeSmallTestData"
	self makeTestData: 'sin-small.dat' using:[:f| self sin: f] seed: 321567 rounds: 10000.
	self makeTestData: 'log-small.dat' using:[:f| self ln: f abs] seed: 321567 rounds: 10000.
	self makeTestData: 'sqrt-small.dat' using:[:f| self sqrt: f abs] seed: 321567 rounds: 10000.
	self makeTestData: 'atan-small.dat' using:[:f| self arcTan: f] seed: 321567 rounds: 10000.
	self makeTestData: 'exp-small.dat' using:[:f| self exp: f] seed: 321567 rounds: 10000.
! !

!FloatMathPluginTests methodsFor: 'running' stamp: 'ar 3/26/2006 16:11'!
makeTestData: fileName using: aBlock seed: seed rounds: rounds
	| bytes out float result |
	bytes := ByteArray new: 8.
	out := FileStream newFileNamed: fileName.
	[
		out binary. 
		out nextNumber: 4 put: rounds.
		out nextNumber: 4 put: seed.
		random := Random seed: seed.
		float := Float basicNew: 2.
		'Creating test data for: ', fileName 
			displayProgressAt: Sensor cursorPoint 
			from: 1 to: rounds during:[:bar|
				1 to: rounds do:[:i|
					i \\ 10000 = 0 ifTrue:[bar value: i].
					[1 to: 8 do:[:j| bytes at: j put: (random nextInt: 256)-1].
					float basicAt: 1 put: (bytes unsignedLongAt: 1 bigEndian: true).
					float basicAt: 2 put: (bytes unsignedLongAt: 5 bigEndian: true).
					float isNaN] whileTrue.
					result := aBlock value: float.
					out nextNumber: 4 put: (result basicAt: 1).
					out nextNumber: 4 put: (result basicAt: 2).
				].
			].
	] ensure:[out close].
! !

!FloatMathPluginTests methodsFor: 'running' stamp: 'ar 3/26/2006 16:58'!
runTest: aBlock
	| bytes out float result |
	bytes := ByteArray new: 8.
	out := WriteStream on: ByteArray new.
	float := Float basicNew: 2.
	1 to: 10000 do:[:i|
		[1 to: 8 do:[:j| bytes at: j put: (random nextInt: 256)-1].
		float basicAt: 1 put: (bytes unsignedLongAt: 1 bigEndian: true).
		float basicAt: 2 put: (bytes unsignedLongAt: 5 bigEndian: true).
		float isNaN] whileTrue.
		result := aBlock value: float.
		out nextNumber: 4 put: (result basicAt: 1).
		out nextNumber: 4 put: (result basicAt: 2).
	].
	^self md5HashMessage: out contents.! !

!FloatMathPluginTests methodsFor: 'running' stamp: 'ar 3/26/2006 14:38'!
setUp
	random := Random seed: 253213.! !

!FloatMathPluginTests methodsFor: 'running' stamp: 'ar 3/26/2006 16:53'!
verifyTestData: fileName using: aBlock
	| rounds seed bytes float result in expected count bits |
	in := [FileStream readOnlyFileNamed: fileName] 
			on: FileDoesNotExistException 
			do:[:ex| ex return: nil].
	in ifNil:[^nil].
	count := bits := 0.
	bytes := ByteArray new: 8.
	[
		in binary.
		rounds := in nextNumber: 4.
		seed := in nextNumber: 4.
		random := Random seed: seed.
		float := Float basicNew: 2.
		expected := Float basicNew: 2.
		'Verifying test data from: ', fileName 
			displayProgressAt: Sensor cursorPoint 
			from: 1 to: rounds during:[:bar|
				1 to: rounds do:[:i|
					i \\ 10000 = 0 ifTrue:[bar value: i].
					[1 to: 8 do:[:j| bytes at: j put: (random nextInt: 256)-1].
					float basicAt: 1 put: (bytes unsignedLongAt: 1 bigEndian: true).
					float basicAt: 2 put: (bytes unsignedLongAt: 5 bigEndian: true).
					float isNaN] whileTrue.
					result := aBlock value: float.
					expected basicAt: 1 put: (in nextNumber: 4).
					expected basicAt: 2 put: (in nextNumber: 4).
					((expected isNaN and:[result isNaN]) or:[expected = result]) ifFalse:[
						(expected basicAt: 1) = (result basicAt: 1)
							ifFalse:[self error: 'Verification failure'].
						count := count + 1.
						bits := bits + ((expected basicAt: 2) - (result basicAt: 2)) abs.
					].
				].
			].
	] ensure:[in close].
	self assert: count = 0. "all the same"! !


!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 15:19'!
md5HashMessage: aStringOrByteArray
	^ self md5HashStream: (ReadStream on: aStringOrByteArray asByteArray)
! !

!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 19:49'!
md5HashStream: aStream
	| start buffer bytes sz n words hash large |
	hash := WordArray with: 16r67452301 with: 16rEFCDAB89 with: 16r98BADCFE with: 16r10325476.
	words := WordArray new: 16.
	buffer := ByteArray new: 64.
	start _ aStream position.
	[aStream atEnd] whileFalse: [
		bytes _ aStream nextInto: buffer.
		(bytes size < 64 or:[aStream atEnd]) ifTrue:[
			sz := bytes size.
			buffer replaceFrom: 1 to: sz with: bytes startingAt: 1.
			buffer from: sz+1 to: buffer size put: 0.
			sz < 56 ifTrue:[
				buffer at: sz + 1 put: 128. "trailing bit"
			] ifFalse:[
				"not enough room for the length, so just pad this one, then..."
				sz < 64 ifTrue:[buffer at: sz + 1 put: 128].
				1 to: 16 do:[:i| words at: i put: (buffer unsignedLongAt: i*4-3 bigEndian: false)].
				self md5Transform: words hash: hash.
				"process one additional block of padding ending with the length"
				buffer atAllPut: 0.
				sz = 64 ifTrue: [buffer at: 1 put: 128].
			].
			"Fill in the final 8 bytes with the 64-bit length in bits."
			n _ (aStream position - start) * 8.
			7 to: 0 by: -1 do:[:i| buffer at: (buffer size - i) put: ((n bitShift: 7-i*-8) bitAnd: 255)].
		].
		1 to: 16 do:[:i| words at: i put: (buffer unsignedLongAt: i*4-3 bigEndian: false)].
		self md5Transform: words hash: hash.
	].
	bytes := ByteArray new: 16.
	bytes unsignedLongAt: 1 put: (hash at: 4) bigEndian: true.
	bytes unsignedLongAt: 5 put: (hash at: 3) bigEndian: true.
	bytes unsignedLongAt: 9 put: (hash at: 2) bigEndian: true.
	bytes unsignedLongAt: 13 put: (hash at: 1) bigEndian: true.
	large := LargePositiveInteger new: 16.
	1 to: 16 do:[:i| large digitAt: i put: (bytes at: i)].
	^large normalize! !

!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 19:45'!
md5Transform: in hash: hash
	"This adds the incoming words to the existing hash"
	| a b c d |
	<primitive: 'primitiveMD5Transform' module: 'CroquetPlugin'>
	a := hash at: 1.
	b := hash at: 2.
	c := hash at: 3.
	d := hash at: 4.

	a := self step1: a x: b y: c z: d data: (in at:  1) add: 16rD76AA478 shift: 7.
	d := self step1: d x: a y: b z: c data: (in at:  2) add: 16rE8C7B756 shift: 12.
	c := self step1: c x: d y: a z: b data: (in at:  3) add: 16r242070DB shift: 17.
	b := self step1: b x: c y: d z: a data: (in at:  4) add: 16rC1BDCEEE shift: 22.
	a := self step1: a x: b y: c z: d data: (in at:  5) add: 16rF57C0FAF shift:  7.
	d := self step1: d x: a y: b z: c data: (in at:  6) add: 16r4787C62A shift: 12.
	c := self step1: c x: d y: a z: b data: (in at:  7) add: 16rA8304613 shift: 17.
	b := self step1: b x: c y: d z: a data: (in at:  8) add: 16rFD469501 shift: 22.
	a := self step1: a x: b y: c z: d data: (in at:  9) add: 16r698098D8 shift:  7.
	d := self step1: d x: a y: b z: c data: (in at: 10) add: 16r8B44F7AF shift: 12.
	c := self step1: c x: d y: a z: b data: (in at: 11) add: 16rFFFF5BB1 shift: 17.
	b := self step1: b x: c y: d z: a data: (in at: 12) add: 16r895CD7BE shift: 22.
	a := self step1: a x: b y: c z: d data: (in at: 13) add: 16r6B901122 shift:  7.
	d := self step1: d x: a y: b z: c data: (in at: 14) add: 16rFD987193 shift: 12.
	c := self step1: c x: d y: a z: b data: (in at: 15) add: 16rA679438E shift: 17.
	b := self step1: b x: c y: d z: a data: (in at: 16) add: 16r49B40821 shift: 22.

	a := self step2: a x: b y: c z: d data: (in at:  2) add: 16rF61E2562 shift:  5.
	d := self step2: d x: a y: b z: c data: (in at:  7) add: 16rC040B340 shift:  9.
	c := self step2: c x: d y: a z: b data: (in at: 12) add: 16r265E5A51 shift: 14.
	b := self step2: b x: c y: d z: a data: (in at:  1) add: 16rE9B6C7AA shift: 20.
	a := self step2: a x: b y: c z: d data: (in at:  6) add: 16rD62F105D shift:  5.
	d := self step2: d x: a y: b z: c data: (in at: 11) add: 16r02441453 shift:  9.
	c := self step2: c x: d y: a z: b data: (in at: 16) add: 16rD8A1E681 shift: 14.
	b := self step2: b x: c y: d z: a data: (in at:  5) add: 16rE7D3FBC8 shift: 20.
	a := self step2: a x: b y: c z: d data: (in at: 10) add: 16r21E1CDE6 shift:  5.
	d := self step2: d x: a y: b z: c data: (in at: 15) add: 16rC33707D6 shift:  9.
	c := self step2: c x: d y: a z: b data: (in at:  4) add: 16rF4D50D87 shift: 14.
	b := self step2: b x: c y: d z: a data: (in at:  9) add: 16r455A14ED shift: 20.
	a := self step2: a x: b y: c z: d data: (in at: 14) add: 16rA9E3E905 shift:  5.
	d := self step2: d x: a y: b z: c data: (in at:  3) add: 16rFCEFA3F8 shift:  9.
	c := self step2: c x: d y: a z: b data: (in at:  8) add: 16r676F02D9 shift: 14.
	b := self step2: b x: c y: d z: a data: (in at: 13) add: 16r8D2A4C8A shift: 20.

	a := self step3: a x: b y: c z: d data: (in at:  6) add: 16rFFFA3942 shift:  4.
	d := self step3: d x: a y: b z: c data: (in at:  9) add: 16r8771F681 shift: 11.
	c := self step3: c x: d y: a z: b data: (in at: 12) add: 16r6D9D6122 shift: 16.
	b := self step3: b x: c y: d z: a data: (in at: 15) add: 16rFDE5380C shift: 23.
	a := self step3: a x: b y: c z: d data: (in at:  2) add: 16rA4BEEA44 shift:  4.
	d := self step3: d x: a y: b z: c data: (in at:  5) add: 16r4BDECFA9 shift: 11.
	c := self step3: c x: d y: a z: b data: (in at:  8) add: 16rF6BB4B60 shift: 16.
	b := self step3: b x: c y: d z: a data: (in at: 11) add: 16rBEBFBC70 shift: 23.
	a := self step3: a x: b y: c z: d data: (in at: 14) add: 16r289B7EC6 shift:  4.
	d := self step3: d x: a y: b z: c data: (in at:  1) add: 16rEAA127FA shift: 11.
	c := self step3: c x: d y: a z: b data: (in at:  4) add: 16rD4EF3085 shift: 16.
	b := self step3: b x: c y: d z: a data: (in at:  7) add: 16r04881D05 shift: 23.
	a := self step3: a x: b y: c z: d data: (in at: 10) add: 16rD9D4D039 shift:  4.
	d := self step3: d x: a y: b z: c data: (in at: 13) add: 16rE6DB99E5 shift: 11.
	c := self step3: c x: d y: a z: b data: (in at: 16) add: 16r1FA27CF8 shift: 16.
	b := self step3: b x: c y: d z: a data: (in at:  3) add: 16rC4AC5665 shift: 23.

	a := self step4: a x: b y: c z: d data: (in at:  1) add: 16rF4292244 shift:  6.
	d := self step4: d x: a y: b z: c data: (in at:  8) add: 16r432AFF97 shift: 10.
	c := self step4: c x: d y: a z: b data: (in at: 15) add: 16rAB9423A7 shift: 15.
	b := self step4: b x: c y: d z: a data: (in at:  6) add: 16rFC93A039 shift: 21.
	a := self step4: a x: b y: c z: d data: (in at: 13) add: 16r655B59C3 shift:  6.
	d := self step4: d x: a y: b z: c data: (in at:  4) add: 16r8F0CCC92 shift: 10.
	c := self step4: c x: d y: a z: b data: (in at: 11) add: 16rFFEFF47D shift: 15.
	b := self step4: b x: c y: d z: a data: (in at:  2) add: 16r85845DD1 shift: 21.
	a := self step4: a x: b y: c z: d data: (in at:  9) add: 16r6FA87E4F shift:  6.
	d := self step4: d x: a y: b z: c data: (in at: 16) add: 16rFE2CE6E0 shift: 10.
	c := self step4: c x: d y: a z: b data: (in at:  7) add: 16rA3014314 shift: 15.
	b := self step4: b x: c y: d z: a data: (in at: 14) add: 16r4E0811A1 shift: 21.
	a := self step4: a x: b y: c z: d data: (in at:  5) add: 16rF7537E82 shift:  6.
	d := self step4: d x: a y: b z: c data: (in at: 12) add: 16rBD3AF235 shift: 10.
	c := self step4: c x: d y: a z: b data: (in at:  3) add: 16r2AD7D2BB shift: 15.
	b := self step4: b x: c y: d z: a data: (in at: 10) add: 16rEB86D391 shift: 21.

	a := (a + (hash at: 1)) bitAnd: 16rFFFFFFFF. hash at: 1 put: a.
	b := (b + (hash at: 2)) bitAnd: 16rFFFFFFFF. hash at: 2 put: b.
	c := (c + (hash at: 3)) bitAnd: 16rFFFFFFFF. hash at: 3 put: c.
	d := (d + (hash at: 4)) bitAnd: 16rFFFFFFFF. hash at: 4 put: d.

	^hash! !

!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 15:19'!
rotate: value by: amount
	"Rotate value left by amount"
	| lowMask highMask |
	lowMask := (1 bitShift: 32-amount) - 1.
	highMask := 16rFFFFFFFF - lowMask.
	^((value bitAnd: lowMask) bitShift: amount) + 
		((value bitAnd: highMask) bitShift: amount-32)! !

!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 15:19'!
step1: w x: x y: y z: z data: data add: add shift: s
	"First step in MD5 transformation"
	| f result |
	f := z bitXor: (x bitAnd: (y bitXor: z)).
	result := w + f + data + add.
	result := self rotate: result by: s.
	^result + x bitAnd: 16rFFFFFFFF! !

!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 15:19'!
step2: w x: x y: y z: z data: data add: add shift: s
	"First step in MD5 transformation"
	| f result |
	f := y bitXor: (z bitAnd: (x bitXor: y)).
	result := w + f + data + add.
	result := self rotate: result by: s.
	^result + x bitAnd: 16rFFFFFFFF! !

!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 15:19'!
step3: w x: x y: y z: z data: data add: add shift: s
	"First step in MD5 transformation"
	| f result |
	f := (x bitXor: y) bitXor: z.
	result := w + f + data + add.
	result := self rotate: result by: s.
	^result + x bitAnd: 16rFFFFFFFF! !

!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 15:19'!
step4: w x: x y: y z: z data: data add: add shift: s
	"First step in MD5 transformation"
	| f result |
	f := y bitXor: (x bitOr: (z  bitXor: 16rFFFFFFFF)).
	result := w + f + data + add.
	result := self rotate: result by: s.
	^result + x bitAnd: 16rFFFFFFFF! !

!FloatMathPluginTests methodsFor: 'md5' stamp: 'ar 3/26/2006 15:20'!
testMD5
	self assert: (self md5HashMessage: 'a') = 16r0CC175B9C0F1B6A831C399E269772661.
	self assert: (self md5HashMessage: 'abc') = 16r900150983CD24FB0D6963F7D28E17F72.
	self assert: (self md5HashMessage: 'message digest') = 16rF96B697D7CB7938D525A2F31AAF161D0.
	self assert: (self md5HashMessage:
		'abcdefghijklmnopqrstuvwxyz') = 16rC3FCD3D76192E4007DFB496CCA67E13B.
	self assert: (self md5HashMessage:
		'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789') =
		16rD174AB98D277D9F5A5611C2C9F419D9F.
	self assert: (self md5HashMessage:
		'12345678901234567890123456789012345678901234567890123456789012345678901234567890') =
 		16r57EDF4A22BE3C955AC49DA2E2107B67A.! !


!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:42'!
testArcCos
	| hash |
	hash := self runTest:[:f| self arcCos: f].
	self assert: hash = 175366936335278026567589867783483480383! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:44'!
testArcCosH
	| hash |
	hash := self runTest:[:f| self arcCosH: f].
	self assert: hash = 6724426144112251941037505276242428134! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:43'!
testArcSin
	| hash |
	hash := self runTest:[:f| self arcSin: f].
	self assert: hash = 27372132577303862731837100895783885417! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:42'!
testArcSinH
	| hash |
	hash := self runTest:[:f| self arcSinH: f].
	self assert: hash = 255911863578190171815115260235896145802! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:43'!
testArcTan
	| hash |
	hash := self runTest:[:f| self arcTan: f].
	self assert: hash = 17311773710959114634056077345168823659! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:51'!
testArcTan2
	| hash |
	hash := self runTest:[:f| self arcTan2: f with: f].
	self assert: hash = 287068347279655848752274030373495709564! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:44'!
testArcTanH
	| hash |
	hash := self runTest:[:f| self arcTanH: f].
	self assert: hash = 295711907369004359459882231908879164929! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:45'!
testCos
	| hash |
	hash := self runTest:[:f| self cos: f].
	self assert: hash = 110207739557966732640546618158077332978! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:42'!
testCosH
	| hash |
	hash := self runTest:[:f| self cosH: f].
	self assert: hash = 139309299067563830037108641802292492276! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 14:27'!
testExp
	| hash |
	hash := self runTest:[:f| self exp: f].
	self assert: hash = 264681209343177480335132131244505189510! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 14:27'!
testFloatAt
	| hash flt |
	flt := FloatArray new: 1.
	hash := self runTest:[:f| flt at: 1 put: f. flt at: 1].
	self assert: hash = 80498428122197125691266588764018905399! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 14:27'!
testFraction
	| hash |
	hash := self runTest:[:f| self fractionPart: f].
	self assert: hash = 320444785026869345695277323179170692004! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:51'!
testHypot
	| hash |
	hash := self runTest:[:f| self hypot: f with: f+1].
	self assert: hash = 217113721886532765853628735806816720346! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 14:27'!
testLog
	| hash |
	hash := self runTest:[:f| self ln: f abs].
	self assert: hash = 24389651894375564945708989023746058645! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:42'!
testLog10
	| hash |
	hash := self runTest:[:f| self log10: f abs].
	self assert: hash = 135564553959509933253581837789050718785! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:44'!
testSin
	| hash |
	hash := self runTest:[:f| self sin: f].
	self assert: hash = 290162321010315440569513182938961037473! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:44'!
testSinH
	| hash |
	hash := self runTest:[:f| self sinH: f].
	self assert: hash = 146029709156303766079448006055284064911! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 14:28'!
testSqrt
	| hash |
	hash := self runTest:[:f| self sqrt: f abs].
	self assert: hash = 112236588358122834093969606123302196127! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:45'!
testTan
	| hash |
	hash := self runTest:[:f| self tan: f].
	self assert: hash = 169918898922109300293069449425089094780! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 17:43'!
testTanH
	| hash |
	hash := self runTest:[:f| self tanH: f].
	self assert: hash = 15738508136206638425252880299326548123! !

!FloatMathPluginTests methodsFor: 'tests' stamp: 'ar 3/26/2006 14:28'!
testTimesTwoPower
	| hash |
	hash := self runTest:[:f| self timesTwoPower: f with: (random nextInt: 200) - 100].
	self assert: hash = 278837335583284459890979576373223649870.! !


!FloatMathPluginTests methodsFor: 'data' stamp: 'ar 3/26/2006 17:56'!
testAtanData
	self verifyTestData: 'atan-small.dat' using:[:f| self arcTan: f].
	self verifyTestData: 'atan-large.dat' using:[:f| self arcTan: f].
! !

!FloatMathPluginTests methodsFor: 'data' stamp: 'ar 3/26/2006 17:56'!
testExpData
	self verifyTestData: 'exp-small.dat' using:[:f| self exp: f].
	self verifyTestData: 'exp-large.dat' using:[:f| self exp: f].
! !

!FloatMathPluginTests methodsFor: 'data' stamp: 'ar 3/26/2006 17:56'!
testLogData
	self verifyTestData: 'log-small.dat' using:[:f| self ln: f abs].
	self verifyTestData: 'log-large.dat' using:[:f| self ln: f abs].
! !

!FloatMathPluginTests methodsFor: 'data' stamp: 'ar 3/26/2006 17:56'!
testSinData
	self verifyTestData: 'sin-small.dat' using:[:f| self sin: f].
	self verifyTestData: 'sin-large.dat' using:[:f| self sin: f].
! !

!FloatMathPluginTests methodsFor: 'data' stamp: 'ar 3/26/2006 17:56'!
testSqrtData
	self verifyTestData: 'sqrt-small.dat' using:[:f| self sqrt: f abs].
	self verifyTestData: 'sqrt-large.dat' using:[:f| self sqrt: f abs].! !
ClassTestCase subclass: #FloatTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!
!FloatTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0!
I provide a test suite for Float values. Examine my tests to see how Floats should behave, and see how to use them.!


!FloatTest methodsFor: 'testing - arithmetic' stamp: 'st 9/20/2004 17:04'!
testContinuedFractions
	self assert: (Float pi asApproximateFractionAtOrder: 1) = (22/7).
	self assert: (Float pi asApproximateFractionAtOrder: 3) = (355/113)! !

!FloatTest methodsFor: 'testing - arithmetic' stamp: 'fbs 3/8/2004 22:10'!
testDivide
	self assert: 2.0 / 1 = 2.
	self should: [ 2.0 / 0 ] raise: ZeroDivide.! !


!FloatTest methodsFor: 'infinity behavior' stamp: 'sd 6/5/2005 08:30'!
testInfinity1
   "FloatTest new testInfinity1"

	| i1  i2 |

	i1 := 10000 exp.
	i2 := 1000000000 exp.
	self assert: i1 isInfinite & i2 isInfinite & (i1 = i2).
	"All infinities are equal. (This is a very substantial difference to NaN's, which are never equal."
! !

!FloatTest methodsFor: 'infinity behavior' stamp: 'sd 6/5/2005 08:30'!
testInfinity2
   "FloatTest new testInfinity2"

	| i1  i2 |
	i1 := 10000 exp.
	i2 := 1000000000 exp.
	i2 := 0 - i2. " this is entirely ok. You can compute with infinite values."

	self assert: i1 isInfinite & i2 isInfinite & i1 positive & i2 negative.
	self deny: i1 = i2.
  	"All infinities are signed. Negative infinity is not equal to Infinity"
! !


!FloatTest methodsFor: 'IEEE 754' stamp: 'nice 5/30/2006 02:34'!
test32bitGradualUnderflow
	"method asIEEE32BitWord did not respect IEEE gradual underflow"
	
	| conv expected exponentPart |
	
	"IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1
	2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign
	except when 2reeeeeeee isZero, which is a gradual underflow:
	2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-126) * sign
	and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise"
	
	"case 1: This example is the first gradual underflow case"
	conv := 2r0.11111111111111111111111e-126 asIEEE32BitWord.
	
	"expected float encoded as sign/exponent/mantissa (whithout leading 1 or 0)"
	exponentPart := 0.
	expected := exponentPart bitOr: 2r11111111111111111111111.
	self assert: expected = conv.
	
	"case 2: smallest number"
	conv := 2r0.00000000000000000000001e-126 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r1.
	self assert: expected = conv.
	
	"case 3: round to nearest even also in underflow cases... here round to upper"
	conv := 2r0.000000000000000000000011e-126 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r10.
	self assert: expected = conv.
	
	"case 4: round to nearest even also in underflow cases... here round to lower"
	conv := 2r0.000000000000000000000101e-126 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r10.
	self assert: expected = conv.
	
	"case 5: round to nearest even also in underflow cases... here round to upper"
	conv := 2r0.0000000000000000000001011e-126 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r11.
	self assert: expected = conv.
	! !

!FloatTest methodsFor: 'IEEE 754' stamp: 'nice 5/30/2006 00:07'!
test32bitRoundingMode
	"method asIEEE32BitWord did not respect IEEE default rounding mode"
	
	| conv expected exponentPart |
	
	"IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1
	2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign
	except when 2reeeeeeee isZero, which is a gradual underflow:
	2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-127) * sign
	and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise"
	
	"This example has two extra bits in mantissa for testing rounding mode
	case 1: should obviously round to upper"
	conv := 2r1.0000000000000000000000111e25 asIEEE32BitWord.
	
	"expected float encoded as sign/exponent/mantissa (whithout leading 1)"
	exponentPart := 25+127 bitShift: 23. "127 is 2r01111111 or 16r7F"
	expected := exponentPart bitOr: 2r10.
	self assert: expected = conv.
	
	"case 2: exactly in the mid point of two 32 bit float: round toward nearest even (to upper)"
	conv := 2r1.0000000000000000000000110e25 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r10.
	self assert: expected = conv.
	
	"case 3: exactly in the mid point of two 32 bit float: round toward nearest even (to lower)"
	conv := 2r1.0000000000000000000000010e25 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r0.
	self assert: expected = conv.
	
	"case 4: obviously round to upper"
	conv := 2r1.0000000000000000000000011e25 asIEEE32BitWord.
	expected := exponentPart bitOr: 2r1.
	self assert: expected = conv.
! !

!FloatTest methodsFor: 'IEEE 754' stamp: 'pmm 2/27/2006 10:49'!
testInfinity3
	self assert: (Float infinity negated asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) =
		'11111111100000000000000000000000'.
	self assert: (Float fromIEEE32Bit:
		(Integer readFrom: '11111111100000000000000000000000' readStream base: 2))
			= Float infinity negated! !

!FloatTest methodsFor: 'IEEE 754' stamp: 'pmm 2/27/2006 10:48'!
testNaN5
	self assert: (Float nan asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) =
		'01111111110000000000000000000000'.
	self assert: (Float fromIEEE32Bit:
		(Integer readFrom: '01111111110000000000000000000000' readStream base: 2)) isNaN! !

!FloatTest methodsFor: 'IEEE 754' stamp: 'pmm 2/27/2006 10:49'!
testZero2
	self assert: (Float negativeZero asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) =
		'10000000000000000000000000000000'.
	self assert: (Float fromIEEE32Bit:
		(Integer readFrom: '10000000000000000000000000000000' readStream base: 2))
			= Float negativeZero! !


!FloatTest methodsFor: 'zero behavior' stamp: 'md 4/16/2003 15:02'!
testIsZero
	self assert: 0.0 isZero.
	self deny:  0.1 isZero.! !

!FloatTest methodsFor: 'zero behavior' stamp: 'sd 6/5/2005 08:33'!
testZero1
	"FloatTest new testZero1"

	self assert: Float negativeZero = 0 asFloat.
	self assert: (Float negativeZero at: 1) ~= (0 asFloat at: 1).

	"The negative zero has a bit representation that is different from the bit representation of the positive zero. Nevertheless, both values are defined to be equal."
! !


!FloatTest methodsFor: 'NaN behavior' stamp: 'sd 6/5/2005 08:31'!
testNaN1
   	"FloatTest new testNaN1"

	self assert: Float nan == Float nan.
	self deny: Float nan = Float nan.
	"a NaN is not equal to itself."
! !

!FloatTest methodsFor: 'NaN behavior' stamp: 'dtl 10/1/2004 18:26'!
testNaN2
	"Two NaN values are always considered to be different.
	On an little-endian machine (32 bit Intel), Float nan is 16rFFF80000 16r00000000.
	On a big-endian machine (PowerPC), Float nan is 16r7FF80000 16r00000000. Changing
	the bit pattern of the first word of a NaN produces another value that is still
	considered equal to NaN. This test should work on both little endian and big
	endian machines. However, it is not guaranteed to work on future 64 bit versions
	of Squeak, for which Float may have different internal representations."

	"FloatTest new testNaN2"

	| nan1 nan2 |
	nan1 := Float nan copy.
	nan2 := Float nan copy.

	"test two instances of NaN with the same bit pattern"
	self deny: nan1 = nan2.
	self deny: nan1 == nan2.
	self deny: nan1 = nan1.
	self assert: nan1 == nan1.

	"change the bit pattern of nan1"
	self assert: nan1 size == 2.
	self assert: (nan1 at: 2) = 0.
	nan1 at: 1 put: (nan1 at: 1) + 999.
	self assert: nan1 isNaN.
	self assert: nan2 isNaN.
	self deny: (nan1 at: 1) = (nan2 at: 1).

	"test two instances of NaN with different bit patterns"
	self deny: nan1 = nan2.
	self deny: nan1 == nan2.
	self deny: nan1 = nan1.
	self assert: nan1 == nan1
! !

!FloatTest methodsFor: 'NaN behavior' stamp: 'sd 6/5/2005 08:32'!
testNaN3
   "FloatTest new testNaN3"

   	| set item identitySet |
	set := Set new.
	set add: (item := Float nan).
	self deny: (set includes: item).
	identitySet := IdentitySet new.
	identitySet add: (item := Float nan).
	self assert: (identitySet includes: item).
	"as a NaN is not equal to itself, it can not be retrieved from a set"
! !

!FloatTest methodsFor: 'NaN behavior' stamp: 'sd 6/5/2005 08:32'!
testNaN4
   	"FloatTest new testNaN4"

	| dict |
	dict := Dictionary new.
	dict at: Float nan put: #NaN.
	self deny: (dict includes: Float nan).
	"as a NaN is not equal to itself, it can not be retrieved when it is used as a dictionary key"
! !


!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 4/26/2006 05:21'!
testFloatTruncated
	"(10 raisedTo: 16) asFloat has an exact representation (no round off error).
	It should convert back to integer without loosing bits.
	This is a no regression test on http://bugs.impara.de/view.php?id=3504"
	
	| x y int r |
	int := 10 raisedTo: 16.
	x := int asFloat.
	y := (5 raisedTo: 16) asFloat timesTwoPower: 16.
	self assert: x = y.
	
	self assert: x asInteger = int.
	
	"this one should be true for any float"
	self assert: x asInteger = x asTrueFraction asInteger.

	"a random test"
	r := Random new.
	10000 timesRepeat: [
		x := r next * 1.9999e16 + 1.0e12 .
		self assert: x truncated = x asTrueFraction truncated]! !

!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 5/7/2006 16:22'!
testFractionAsFloat
	"use a random test"
	
	| r m frac err collec |
	r := Random new seed: 1234567.
	m := (2 raisedTo: 54) - 1.
	200 timesRepeat: [
		frac := ((r nextInt: m) * (r nextInt: m) + 1) / ((r nextInt: m) * (r nextInt: m) + 1).
		err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52).
		self assert: err < (1/2)].
	
	collec := #(16r10000000000000 16r1FFFFFFFFFFFFF 1 2 16r20000000000000 16r20000000000001 16r3FFFFFFFFFFFFF 16r3FFFFFFFFFFFFE 16r3FFFFFFFFFFFFD).
	collec do: [:num |
		collec do: [:den |
			frac := Fraction numerator: num denominator: den.
			err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52).
			self assert: err <= (1/2)]].! !

!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 5/6/2006 22:13'!
testIntegerAsFloat
	"assert IEEE 754 round to nearest even mode is honoured"
	
	self deny: 16r1FFFFFFFFFFFF0801 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 65 bits"
	self deny: 16r1FFFFFFFFFFFF0802 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 64 bits"
	self assert: 16r1FFFFFFFFFFF1F800 asFloat = 16r1FFFFFFFFFFF20000 asFloat. "nearest even is upper"
	self assert: 16r1FFFFFFFFFFFF0800 asFloat = 16r1FFFFFFFFFFFF0000 asFloat. "nearest even is lower"
! !

!FloatTest methodsFor: 'testing - conversion' stamp: 'dtl 9/18/2004 12:40'!
testStringAsNumber
	"This covers parsing in Number>>readFrom:"

	| aFloat |
	aFloat _ '10r-12.3456' asNumber.
	self assert: -12.3456 = aFloat.
	aFloat _ '10r-12.3456e2' asNumber.
	self assert: -1234.56 = aFloat.
	aFloat _ '10r-12.3456d2' asNumber.
	self assert: -1234.56 = aFloat.
	aFloat _ '10r-12.3456q2' asNumber.
	self assert: -1234.56 = aFloat.
	aFloat _ '-12.3456q2' asNumber.
	self assert: -1234.56 = aFloat.
	aFloat _ '12.3456q2' asNumber.
	self assert: 1234.56 = aFloat.
! !
AlignmentMorph subclass: #FloatingBookControlsMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Navigators'!

!FloatingBookControlsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!FloatingBookControlsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:16'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self layoutInset: 0;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap ! !


!FloatingBookControlsMorph methodsFor: 'stepping and presenter' stamp: 'RAA 8/23/2000 12:48'!
step

	owner == self world ifFalse: [^ self].
	owner addMorphInLayer: self.
! !


!FloatingBookControlsMorph methodsFor: 'testing' stamp: 'RAA 8/23/2000 12:47'!
stepTime

	^1000! !

!FloatingBookControlsMorph methodsFor: 'testing' stamp: 'RAA 8/23/2000 12:47'!
wantsSteps

	^true! !


!FloatingBookControlsMorph methodsFor: 'WiW support' stamp: 'RAA 8/23/2000 12:47'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^23		"page controls are behind menus and balloons, but in front of most other stuff"! !
ArithmeticError subclass: #FloatingPointException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
Object subclass: #FontCache
	instanceVariableNames: 'fonts'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!FontCache commentStamp: '<historical>' prior: 0!
Used by MREncoder and MRDecoder.  It associates an integer index with a number of fonts.  Fonts can be searched by index, and the index can be found for a font that isn't present.  If a font is added to the cache, sometimes the cache will discard another font to make room.!


!FontCache methodsFor: 'initialization' stamp: 'ls 3/27/2000 17:23'!
initialize: cacheSize
	fonts := Array new: cacheSize.! !


!FontCache methodsFor: 'lookups' stamp: 'ls 3/27/2000 17:28'!
fontAt: index
	"return the font associated with the given index"
	^fonts at: index! !

!FontCache methodsFor: 'lookups' stamp: 'ls 3/27/2000 17:25'!
includesFont: aFont
	"decide whether the given font is included in the collection"
	^fonts identityIncludes: aFont	! !

!FontCache methodsFor: 'lookups' stamp: 'ls 3/27/2000 17:28'!
indexForNewFont: aFont
	"add aFont to the cache.  Return its index.  The receiver will sometimes choose an index that is already used; that means that aFont is replacing the other font"
	| index |
	index := fonts size atRandom.      "random is simpler to manage than anything else"
	fonts at: index put: aFont.
	^index! !

!FontCache methodsFor: 'lookups' stamp: 'ls 3/27/2000 17:25'!
indexOf: aFont
	"return the index for a given font"
	^fonts identityIndexOf: aFont! !

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

FontCache class
	instanceVariableNames: ''!

!FontCache class methodsFor: 'instance creation' stamp: 'ls 3/27/2000 17:33'!
new: size
	^super new initialize: size! !
Object subclass: #FontSet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Fonts'!
!FontSet commentStamp: '<historical>' prior: 0!
FontSet provides a mechanism for storing a set of fonts as a class that can be conveniently filedOut, filedIn, and installed as a TextStyle.

The most common use is...
	Find a font you like.
	Use BitFont to convert a bunch of sizes to data files named, eg, LovelyNN.BF
	Use FontSet convertFontsNamed: 'Lovely' to produce a FontSet named Lovely.
	FileOut that FontSet for later use.
	Use Lovely installAsTextStyle to make all sizes available in a TextStyle
		named #Lovely in the TextConstants dictionary.
	Use ctrl-k in any text pane to select the new Lovely style for that paragraph.
	Then use cmd-1 through 5 or cmd-k to set the point-size for any selection.
!


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

FontSet class
	instanceVariableNames: ''!

!FontSet class methodsFor: 'as yet unclassified' stamp: 'di 9/15/97 12:01'!
convertFontsNamed: familyName  "FontSet convertFontsNamed: 'Palatino' "
	^ self convertFontsNamed: familyName inDirectoryNamed: ''! !


!FontSet class methodsFor: 'compiling' stamp: 'sma 12/29/1999 11:48'!
acceptsLoggingOfCompilation
	"Dont log sources for my subclasses, so as not to waste time
	and space storing printString versions of the string literals."

	^ self == FontSet! !

!FontSet class methodsFor: 'compiling' stamp: 'di 1/24/2005 12:40'!
compileFont: strikeFont 
	| tempName literalString header sizeStr familyName |
	tempName _ 'FontTemp.sf2'.
	strikeFont writeAsStrike2named: tempName.
	literalString _ (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: tempName) binary) contents fullPrintString.
	sizeStr _ strikeFont pointSize asString.
	familyName _ strikeFont name first: (strikeFont name findLast: [:x | x isDigit not]).

	header _ 'size' , sizeStr , '
	^ self fontNamed: ''' , familyName , sizeStr , ''' fromMimeLiteral:
' .
	self class
		compile: header , literalString
		classified: 'fonts'
		notifying: nil.
	FileDirectory default deleteFileNamed: tempName
! !


!FontSet class methodsFor: 'converting' stamp: 'sma 12/29/1999 21:18'!
convertFontsNamed: familyName inDirectoryNamed: dirName
		"FontSet convertFontsNamed: 'Tekton' inDirectoryNamed: 'Tekton Fonts' "
	"This utility is for use after you have used BitFont to produce data files 
	for the fonts you wish to use.  It will read the BitFont files and build
	a fontset class from them.  If one already exists, the sizes that can be
	found will be overwritten."
	"For this utility to work as is, the BitFont data files must be named 'familyNN.BF',
	and must reside in the directory named by dirName (use '' for the current directory)."

	| allFontNames fontSet dir |
	"Check first for matching file names and usable FontSet class name."
	dir _ dirName isEmpty
		ifTrue: [FileDirectory default]
		ifFalse: [FileDirectory default directoryNamed: dirName].
	allFontNames _ dir fileNamesMatching: familyName , '##.BF'.
	allFontNames isEmpty ifTrue: [^ self error: 'No files found like ' , familyName , 'NN.BF'].
	fontSet _ self fontSetClass: familyName.
	allFontNames do:
		[:each |
		Transcript cr; show: each.
		fontSet compileFont: (StrikeFont new readFromBitFont: (dir fullNameFor: each))]! !

!FontSet class methodsFor: 'converting' stamp: 'sma 12/29/1999 12:27'!
convertTextStyleNamed: aString
	| style fontSet |
	(style _ TextStyle named: aString) ifNil: [^ self error: 'unknown text style ' , aString].
	fontSet _ self fontSetClass: aString.
	style fontArray do: [:each | fontSet compileFont: each]! !


!FontSet class methodsFor: 'filein/out' stamp: 'sma 12/29/1999 11:49'!
fileOut
	"FileOut and then change the properties of the file so that it won't be
	treated as text by, eg, email attachment facilities"

	super fileOut.
	(FileStream oldFileNamed: self name , '.st') setFileTypeToObject; close! !


!FontSet class methodsFor: 'installing' stamp: 'di 1/24/2005 12:48'!
fontNamed: fontName fromLiteral: aString
	"NOTE -- THIS IS AN OBSOLETE METHOD THAT MAY CAUSE ERRORS.

The old form of fileOut for FontSets produced binary literal strings which may not be accurately read in systems with support for international character sets.  If possible, file the FontSet out again from a system that produces the newer MIME encoding (current def of compileFont:), and uses the corresponding altered version of this method.  If this is not easy, then
	file the fontSet into an older system (3.7 or earlier),
	assume it is called FontSetZork...
	execute FontSetZork installAsTextStyle.
	copy the compileFont: method from this system into that older one.
	remove the class FontSetZork.
	Execute:  FontSet convertTextStyleNamed: 'Zork', and see that it creates a new FontSetZork.
	FileOut the new class FontSetZork.
	The resulting file should be able to be read into this system.
"

	^ StrikeFont new 
		name: fontName;
		readFromStrike2Stream: (ReadStream on: aString asByteArray)! !

!FontSet class methodsFor: 'installing' stamp: 'di 1/24/2005 11:13'!
fontNamed: fontName fromMimeLiteral: aString
	"This method allows a font set to be captured as sourcecode in a subclass.
	The string literals will presumably be created by printing, eg,
		(FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile,
		and following the logic in compileFont: to encode and add a heading.

	See the method installAsTextStyle to see how this can be used."

	^ StrikeFont new 
		name: fontName;
		readFromStrike2Stream: (Base64MimeConverter mimeDecodeToBytes: aString readStream)! !

!FontSet class methodsFor: 'installing' stamp: 'rbb 2/18/2005 13:20'!
installAsDefault  "FontSetNewYork installAsDefault"
	(SelectionMenu confirm: 'Do you want to install
''' , self fontName , ''' as default font?')
		ifFalse: [^ self].
	self installAsTextStyle.
	"TextConstants at: #OldDefaultTextStyle put: TextStyle default."
	TextConstants at: #DefaultTextStyle put: (TextStyle named: self fontName).
	ListParagraph initialize.
	"rbb 2/18/2005 13:20 - How should this change for UIManger, if at all?"
	PopUpMenu initialize.
	StandardSystemView initialize.
	"SelectionMenu notify: 'The old text style has been saved
as ''OldDefaultTextStyle''.'"! !

!FontSet class methodsFor: 'installing' stamp: 'sma 12/30/1999 15:05'!
installAsTextStyle  "FontSetNewYork installAsTextStyle"
	| selectors |
	(TextConstants includesKey: self fontName) ifTrue:
		[(self confirm: 
self fontName , ' is already defined in TextConstants.
Do you want to replace that definition?')
			ifFalse: [^ self]].
	selectors _ (self class selectors select: [:s | s beginsWith: 'size']) asSortedCollection.
	TextConstants
		at: self fontName
		put: (TextStyle fontArray: (selectors collect: [:each | self perform: each]))! !

!FontSet class methodsFor: 'installing' stamp: 'nk 8/31/2004 09:23'!
size: pointSize fromLiteral: aString 
	"This method allows a font set to be captured as sourcecode in a subclass.
	The string literals will presumably be created by printing, eg,
		(FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile,
		and then pasting into a browser after a heading like, eg,
size24
	^ self size: 24 fromLiteral:
	'--unreadable binary data--'

	See the method installAsTextStyle to see how this can be used."

	"This method is old and for backward compatibility only.
	please use fontNamed:fromLiteral: instead."

	self flag: #bob.	"used in Alan's projects"
	^(StrikeFont new)
		name: self fontName , (pointSize < 10 
							ifTrue: ['0' , pointSize printString]
							ifFalse: [pointSize printString]);
		readFromStrike2Stream: ((RWBinaryOrTextStream with: aString)
					reset;
					binary);
		yourself! !


!FontSet class methodsFor: 'private' stamp: 'sma 12/29/1999 12:58'!
fontCategory
	^ 'Graphics-Fonts' asSymbol! !

!FontSet class methodsFor: 'private' stamp: 'RAA 6/20/2000 13:29'!
fontName

	self flag: #bob.		"temporary hack until I figure out what's happening here"
	(self name beginsWith: superclass name) ifFalse: [^self name].
	^ (self name copyFrom: superclass name size + 1 to: self name size) asSymbol! !

!FontSet class methodsFor: 'private' stamp: 'sma 12/29/1999 12:58'!
fontSetClass: aString
	| className fontSet |
	className _ (self name , (aString select: [:c | c isAlphaNumeric]) capitalized) asSymbol.
	fontSet _ Smalltalk
		at: className
		ifAbsentPut: [self
			subclass: className
			instanceVariableNames: ''
			classVariableNames: ''
			poolDictionaries: ''
			category: self fontCategory].
	(fontSet inheritsFrom: self) ifFalse: [^ self error: 'The name ' , className , ' is already in use'].
	^ fontSet! !
Notification subclass: #FontSubstitutionDuringLoading
	instanceVariableNames: 'familyName pixelSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!FontSubstitutionDuringLoading commentStamp: '<historical>' prior: 0!
signaled by font loading code when reading a DiskProxy that calls for a missing font.!


!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:04'!
defaultAction
	familyName ifNil: [ familyName := 'NoName' ].
	pixelSize ifNil: [ pixelSize := 12 ].

	^((familyName beginsWith: 'Comic')
		ifTrue: [ TextStyle named: (Preferences standardEToysFont familyName) ]
		ifFalse: [ TextStyle default ]) fontOfSize: pixelSize.! !

!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'!
familyName
	"Answer the value of familyName"

	^ familyName! !

!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'!
familyName: anObject
	"Set the value of familyName"

	familyName _ anObject! !

!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'!
pixelSize
	"Answer the value of pixelSize"

	^ pixelSize! !

!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'!
pixelSize: anObject
	"Set the value of pixelSize"

	pixelSize _ anObject! !

!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 16:55'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(;
		nextPutAll: familyName;
		nextPut: $-;
		print: pixelSize;
		nextPut: $).! !

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

FontSubstitutionDuringLoading class
	instanceVariableNames: ''!

!FontSubstitutionDuringLoading class methodsFor: 'instance creation' stamp: 'nk 11/8/2004 15:07'!
forFamilyName: aName pixelSize: aSize
	^(self new)
		familyName: aName;
		pixelSize: aSize;
		yourself.! !
TestCase subclass: #FontTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!
!FontTest commentStamp: 'tak 3/11/2005 14:31' prior: 0!
I am mainly a test for fallback font.
FontTest buildSuite run!


!FontTest methodsFor: 'testing' stamp: 'yo 1/13/2005 16:44'!
testDisplay
	"self debug: #testDisplay"
	| text font bb destPoint width |
	text _ 'test' asText.
	font _ TextStyle default fontOfSize: 21.
	text addAttribute: (TextFontReference toFont: font).
	bb _ (Form extent: 100 @ 30) getCanvas privatePort.
	bb combinationRule: Form paint.

	font installOn: bb foregroundColor: Color black backgroundColor: Color white.
	destPoint _ font displayString: text on: bb from: 1 to: 4 at: 0@0 kern: 1.

	width _ text inject: 0 into: [:max :char | max + (font widthOf: char)].
	self assert: destPoint x = (width + 4).
	"bb destForm asMorph openInHand."
! !

!FontTest methodsFor: 'testing' stamp: 'yo 1/13/2005 16:41'!
testFallback
	"self debug: #testFallback"
	| text font bb destPoint |
	text _ (Character value: 257) asString asText.
	font _ TextStyle default fontOfSize: 21.
	text addAttribute: (TextFontReference toFont: font).
	bb _ (Form extent: 100 @ 30) getCanvas privatePort.
	bb combinationRule: Form paint.

	font installOn: bb foregroundColor: Color black backgroundColor: Color white.
	destPoint _ font displayString: text on: bb from: 1 to: 1 at: 0@0 kern: 1.

	"bb destForm asMorph openInHand."
	self assert: destPoint x = ((font widthOf: $?) + 1).
! !

!FontTest methodsFor: 'testing' stamp: 'tak 12/22/2004 00:56'!
testMultistringFallbackFont
	"self debug: #testMultistringFallbackFont"
	| text p style height width |
	[(TextStyle default fontArray at: JapaneseEnvironment leadingChar)
		ifNil: [^ self]]
		ifError: [:err :rcvr | ^ self].
	text := ((#(20983874 20983876 20983878 )
				collect: [:e | e asCharacter])
				as: String) asText.
	p := MultiNewParagraph new.
	style := TextStyle new leading: 0; newFontArray: {Preferences standardFlapFont}.
	p
		compose: text
		style: style
		from: 1
		in: (0 @ 0 corner: 100 @ 100).
	"See CompositionScanner>>setActualFont: &  
	CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:"
	height := style defaultFont height + style leading.
	width := text
				inject: 0
				into: [:tally :next | tally
						+ (style defaultFont widthOf: next)].
	p adjustRightX.
	self assert: p extent = (width @ height).
	"Display getCanvas
		paragraph: p
		bounds: (10 @ 10 extent: 100 @ 100)
		color: Color black"! !

!FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 18:02'!
testMultistringFont
	"self debug: #testMultistringFont"
	| text p style height width |
	[(TextStyle default fontArray at: JapaneseEnvironment leadingChar)
		ifNil: [^ self]]
		ifError: [:err :rcvr | ^ self].
	text := ((#(20983874 20983876 20983878 )
				collect: [:e | e asCharacter])
				as: String) asText.
	p := MultiNewParagraph new.
	style := TextStyle default.
	p
		compose: text
		style: style
		from: 1
		in: (0 @ 0 corner: 100 @ 100).
	"See CompositionScanner>>setActualFont: &  
	CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:"
	height := style defaultFont height + style leading.
	width := text
				inject: 0
				into: [:tally :next | tally
						+ (style defaultFont widthOf: next)].
	p adjustRightX.
	self assert: p extent = (width @ height).
	"Display getCanvas
		paragraph: p
		bounds: (10 @ 10 extent: 100 @ 100)
		color: Color black"! !

!FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 14:50'!
testParagraph
	"self debug: #testParagraph"
	| text p style height width |
	text := 'test' asText.
	p := MultiNewParagraph new.
	style := TextStyle default.
	p
		compose: text
		style: style
		from: 1
		in: (0 @ 0 corner: 100 @ 100).
	"See CompositionScanner>>setActualFont: &  
	CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:"
	height := style defaultFont height + style leading.
	width := text
				inject: 0
				into: [:tally :next | tally
						+ (style defaultFont widthOf: next)].
	p adjustRightX.
	self assert: p extent = (width @ height)! !

!FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 17:19'!
testParagraphFallback
	"self debug: #testParagraphFallback"
	| text p style height width e expect |
	e := (Character value: 257) asString.
	text := ('test' , e , e , e , e , 'test') asText.
	expect := 'test????test'.
	p := MultiNewParagraph new.
	style := TextStyle default.
	p
		compose: text
		style: style
		from: 1
		in: (0 @ 0 corner: 100 @ 100).
	"See CompositionScanner>>setActualFont: &  
	CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:"
	height := style defaultFont height + style leading.
	width := expect
				inject: 0
				into: [:tally :next | tally
						+ (style defaultFont widthOf: next)].
	p adjustRightX.
	self assert: p extent = (width @ height).
	"Display getCanvas
		paragraph: p
		bounds: (10 @ 10 extent: 100 @ 100)
		color: Color black"! !

!FontTest methodsFor: 'testing' stamp: 'DF 5/25/2006 20:49'!
testResetAfterEmphasized
	"self debug: #testResetAfterEmphasized"
	| normal derivative |
	normal _ TextStyle defaultFont.
	derivative _ normal emphasized: 3.
	self assert: (normal derivativeFonts at: 3) == derivative.
	normal reset.
	self assert: normal derivativeFonts isEmpty
! !
DisplayMedium subclass: #Form
	instanceVariableNames: 'bits width height depth offset'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!Form commentStamp: 'ls 1/4/2004 17:16' prior: 0!
A rectangular array of pixels, used for holding images.  All pictures, including character images are Forms.  The depth of a Form is how many bits are used to specify the color at each pixel.  The actual bits are held in a Bitmap, whose internal structure is different at each depth.  Class Color allows you to deal with colors without knowing how they are actually encoded inside a Bitmap.
	  The supported depths (in bits) are 1, 2, 4, 8, 16, and 32.  The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million.
	Forms are indexed starting at 0 instead of 1; thus, the top-left pixel of a Form has coordinates 0@0.
	Forms are combined using BitBlt.  See the comment in class BitBlt.  Forms that repeat many times to fill a large destination are InfiniteForms.

	colorAt: x@y		Returns the abstract Color at this location
	displayAt: x@y		shows this form on the screen
	displayOn: aMedium at: x@y	shows this form in a Window, a Form, or other DisplayMedium
	fillColor: aColor		Set all the pixels to the color.
	edit		launch an editor to change the bits of this form.
	pixelValueAt: x@y	The encoded color.  The encoding depends on the depth.
!
]style[(223 6 62 5 374 6 11 23 64 12 40 5 337)f1,f1LBitmap Definition;,f1,f1LColor Definition;,f1,f1LBitBlt Definition;,f1,f1LBitBlt Comment;,f1,f1LInfiniteForm Definition;,f1,f1RColor;,f1!


!Form methodsFor: 'accessing'!
bits
	"Answer the receiver's Bitmap containing its bits."

	^ bits! !

!Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:41'!
bitsSize
	| pixPerWord |
	depth == nil ifTrue: [depth _ 1].
	pixPerWord _ 32 // self depth.
	^ width + pixPerWord - 1 // pixPerWord * height! !

!Form methodsFor: 'accessing'!
bits: aBitmap 
	"Reset the Bitmap containing the receiver's bits."

	bits _ aBitmap! !

!Form methodsFor: 'accessing' stamp: 'tk 3/9/97'!
center
	"Note that offset is ignored here.  Are we really going to embrace offset?  "
	^ (width @ height) // 2! !

!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 12:03'!
defaultCanvasClass
	"Return the default canvas used for drawing onto the receiver"
	^Display defaultCanvasClass! !

!Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'!
depth
	^ depth < 0 ifTrue:[0-depth] ifFalse:[depth]! !

!Form methodsFor: 'accessing'!
depth: bitsPerPixel
	(bitsPerPixel > 32 or:
		[(bitsPerPixel bitAnd: bitsPerPixel-1) ~= 0])
		ifTrue: [self halt: 'bitsPerPixel must be 1, 2, 4, 8, 16 or 32'].
	depth _ bitsPerPixel! !

!Form methodsFor: 'accessing' stamp: 'ar 5/27/2000 16:56'!
displayScreen
	"Return the display screen the receiver is allocated on. 
	Forms in general are Squeak internal and not allocated on any particular display."
	^nil! !

!Form methodsFor: 'accessing'!
extent
	^ width @ height! !

!Form methodsFor: 'accessing'!
form
	"Answer the receiver's form.  For vanilla Forms, this degenerates to self.  Makes several methods that operate on both Forms and MaskedForms much more straightforward.   6/1/96 sw"

	^ self! !

!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 12:03'!
getCanvas
	"Return a Canvas that can be used to draw onto the receiver"
	^self defaultCanvasClass on: self! !

!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 00:48'!
hasBeenModified
	"Return true if something *might* have been drawn into the receiver"
	^(bits == nil or:[bits class == ByteArray]) not
	"Read the above as: If the receiver has forgotten its contents (bits == nil) 
	or is still hibernated it can't be modified."! !

!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 00:48'!
hasBeenModified: aBool
	"Change the receiver to reflect the modification state"
	aBool ifTrue:[^self unhibernate].
	self shouldPreserveContents
		ifTrue:[self hibernate]
		ifFalse:[bits _ nil]! !

!Form methodsFor: 'accessing'!
height
	^ height! !

!Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:50'!
nativeDepth
	"Return the 'native' depth of the receiver, e.g., including the endianess"
	^depth! !

!Form methodsFor: 'accessing' stamp: 'ar 2/16/2000 22:00'!
offset
	^offset ifNil:[0@0]! !

!Form methodsFor: 'accessing'!
offset: aPoint

	offset _ aPoint! !

!Form methodsFor: 'accessing'!
size
	"Should no longer be used -- use bitsSize instead.  length of variable part of instance."
	^ super size! !

!Form methodsFor: 'accessing'!
width
	^ width! !


!Form methodsFor: 'analyzing'!
cgForPixelValue: pv orNot: not
	"Return the center of gravity for all pixels of value pv.
	Note:  If orNot is true, then produce the center of gravity for all pixels
	that are DIFFERENT from the supplied (background) value"
	| pixCount weighted xAndY |
	xAndY _ (Array with: (self xTallyPixelValue: pv orNot: not)
					with: (self yTallyPixelValue: pv orNot: not)) collect:
		[:profile |	"For both x and y profiles..."
		pixCount _ 0.  weighted _ 0.
		profile doWithIndex:
			[:t :i | pixCount _ pixCount + t.
			weighted _ weighted + (t*i)].
		pixCount = 0  "Produce average of nPixels weighted by coordinate"
			ifTrue: [0.0]
			ifFalse: [weighted asFloat / pixCount asFloat - 1.0]].

	^ xAndY first @ xAndY last
"
| f cg |
[Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: (Sensor cursorPoint extent: 50@50).
	cg _ f cgForPixelValue: (Color black pixelValueForDepth: f depth) orNot: false.
	f displayAt: 0@0.
	Display fill: (cg extent: 2@2) fillColor: Color red].
	ScheduledControllers restore
"! !

!Form methodsFor: 'analyzing' stamp: 'jm 12/5/97 19:48'!
colorsUsed
	"Return a list of the Colors this form uses."

	| tallies tallyDepth usedColors |
	tallies _ self tallyPixelValues.
	tallyDepth _ (tallies size log: 2) asInteger.
	usedColors _ OrderedCollection new.
	tallies doWithIndex: [:count :i |
		count > 0 ifTrue: [
			usedColors add: (Color colorFromPixelValue: i - 1 depth: tallyDepth)]].
	^ usedColors asArray
! !

!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40'!
dominantColor
	| tally max maxi |
	self depth > 16 ifTrue:
		[^(self asFormOfDepth: 16) dominantColor].
	tally _ self tallyPixelValues.
	max _ maxi _ 0.
	tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]].
	^ Color colorFromPixelValue: maxi - 1 depth: self depth! !

!Form methodsFor: 'analyzing'!
innerPixelRectFor: pv orNot: not
	"Return a rectangle describing the smallest part of me that includes 
	all pixels of value pv.
	Note:  If orNot is true, then produce a copy that includes all pixels
	that are DIFFERENT from the supplied (background) value"

	| xTally yTally |
	xTally _ self xTallyPixelValue: pv orNot: not.
	yTally _ self yTallyPixelValue: pv orNot: not.
	^ ((xTally findFirst: [:t | t>0]) - 1) @ ((yTally findFirst: [:t | t>0]) - 1)
		corner:
			(xTally findLast: [:t | t>0])@(yTally findLast: [:t | t>0])! !

!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40'!
pixelCompare: aRect with: otherForm at: otherLoc
	"Compare the selected bits of this form (those within aRect) against
	those in a similar rectangle of otherFrom.  Return the sum of the
	absolute value of the differences of the color values of every pixel.
	Obviously, this is most useful for rgb (16- or 32-bit) pixels but,
	in the case of 8-bits or less, this will return the sum of the differing
	bits of the corresponding pixel values (somewhat less useful)"
	| pixPerWord temp |
	pixPerWord _ 32//self depth.
	(aRect left\\pixPerWord = 0 and: [aRect right\\pixPerWord = 0]) ifTrue:
		["If word-aligned, use on-the-fly difference"
		^ (BitBlt current toForm: self) copy: aRect from: otherLoc in: otherForm
				fillColor: nil rule: 32].
	"Otherwise, combine in a word-sized form and then compute difference"
	temp _ self copy: aRect.
	temp copy: aRect from: otherLoc in: otherForm rule: 21.
	^ (BitBlt current toForm: temp) copy: aRect from: otherLoc in: nil
				fillColor: (Bitmap with: 0) rule: 32
"  Dumb example prints zero only when you move over the original rectangle...
 | f diff | f _ Form fromUser.
[Sensor anyButtonPressed] whileFalse:
	[diff _ f pixelCompare: f boundingBox
		with: Display at: Sensor cursorPoint.
	diff printString , '        ' displayAt: 0@0]
"! !

!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:42'!
primCountBits
	"Count the non-zero pixels of this form."
	self depth > 8 ifTrue:
		[^(self asFormOfDepth: 8) primCountBits].
	^ (BitBlt current toForm: self)
		fillColor: (Bitmap with: 0);
		destRect: (0@0 extent: width@height);
		combinationRule: 32;
		copyBits! !

!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:37'!
rectangleEnclosingPixelsNotOfColor: aColor
	"Answer the smallest rectangle enclosing all the pixels of me that are different from the given color. Useful for extracting a foreground graphic from its background."

	| cm slice copyBlt countBlt top bottom newH left right |
	"map the specified color to 1 and all others to 0"
	cm _ Bitmap new: (1 bitShift: (self depth min: 15)).
	cm primFill: 1.
	cm at: (aColor indexInMap: cm) put: 0.

	"build a 1-pixel high horizontal slice and BitBlts for counting pixels of interest"
	slice _ Form extent: width@1 depth: 1.
	copyBlt _ (BitBlt current toForm: slice)
		sourceForm: self;
		combinationRule: Form over;
		destX: 0 destY: 0 width: width height: 1;
		colorMap: cm.
	countBlt _ (BitBlt current toForm: slice)
		fillColor: (Bitmap with: 0);
		destRect: (0@0 extent: slice extent);
		combinationRule: 32.

	"scan in from top and bottom"
	top _ (0 to: height)
		detect: [:y |
			copyBlt sourceOrigin: 0@y; copyBits.
			countBlt copyBits > 0]
		ifNone: [^ 0@0 extent: 0@0].
	bottom _ (height - 1 to: top by: -1)
		detect: [:y |
			copyBlt sourceOrigin: 0@y; copyBits.
			countBlt copyBits > 0].

	"build a 1-pixel wide vertical slice and BitBlts for counting pixels of interest"
	newH _ bottom - top + 1.
	slice _ Form extent: 1@newH depth: 1.
	copyBlt _ (BitBlt current toForm: slice)
		sourceForm: self;
		combinationRule: Form over;
		destX: 0 destY: 0 width: 1 height: newH;
		colorMap: cm.
	countBlt _ (BitBlt current toForm: slice)
		fillColor: (Bitmap with: 0);
		destRect: (0@0 extent: slice extent);
		combinationRule: 32.

	"scan in from left and right"
	left _ (0 to: width)
		detect: [:x |
			copyBlt sourceOrigin: x@top; copyBits.
			countBlt copyBits > 0].
	right _ (width - 1 to: left by: -1)
		detect: [:x |
			copyBlt sourceOrigin: x@top; copyBits.
			countBlt copyBits > 0].

	^ left@top corner: (right + 1)@(bottom + 1)
! !

!Form methodsFor: 'analyzing' stamp: 'jm 6/18/1999 18:41'!
tallyPixelValues
	"Answer a Bitmap whose elements contain the number of pixels in this Form with the pixel value corresponding to their index. Note that the pixels of multiple Forms can be tallied together using tallyPixelValuesInRect:into:."

	^ self tallyPixelValuesInRect: self boundingBox
		into: (Bitmap new: (1 bitShift: (self depth min: 15)))
"
Move a little rectangle around the screen and print its tallies...
 | r tallies nonZero |
Cursor blank showWhile: [
[Sensor anyButtonPressed] whileFalse:
	[r _ Sensor cursorPoint extent: 10@10.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil.
	tallies _ (Display copy: r) tallyPixelValues.
	nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0]
			thenCollect: [:i | (tallies at: i) -> (i-1)].
	nonZero printString , '          ' displayAt: 0@0.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]]
"
! !

!Form methodsFor: 'analyzing' stamp: 'ar 5/28/2000 12:09'!
tallyPixelValuesInRect: destRect into: valueTable
	"Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable."

	(BitBlt current toForm: self)
		sourceForm: self;  "src must be given for color map ops"
		sourceOrigin: 0@0;
		tallyMap: valueTable;
		combinationRule: 33;
		destRect: destRect;
		copyBits.
	^ valueTable

"
Move a little rectangle around the screen and print its tallies...
 | r tallies nonZero |
Cursor blank showWhile: [
[Sensor anyButtonPressed] whileFalse:
	[r _ Sensor cursorPoint extent: 10@10.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil.
	tallies _ (Display copy: r) tallyPixelValues.
	nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0]
			thenCollect: [:i | (tallies at: i) -> (i-1)].
	nonZero printString , '          ' displayAt: 0@0.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]]
"! !

!Form methodsFor: 'analyzing' stamp: 'ar 5/28/2000 12:09'!
xTallyPixelValue: pv orNot: not
	"Return an array of the number of pixels with value pv by x-value.
	Note that if not is true, then this will tally those different from pv."
	| cm slice countBlt copyBlt |
	cm _ self newColorMap.		"Map all colors but pv to zero"
	not ifTrue: [cm atAllPut: 1].		"... or all but pv to one"
	cm at: pv+1 put: 1 - (cm at: pv+1).
	slice _ Form extent: 1@height.
	copyBlt _ (BitBlt current destForm: slice sourceForm: self
				halftoneForm: nil combinationRule: Form over
				destOrigin: 0@0 sourceOrigin: 0@0 extent: 1 @ slice height
				clipRect: slice boundingBox) colorMap: cm.
	countBlt _ (BitBlt current toForm: slice)
				fillColor: (Bitmap with: 0);
				destRect: (0@0 extent: slice extent);
				combinationRule: 32.
	^ (0 to: width-1) collect:
		[:x |
		copyBlt sourceOrigin: x@0; copyBits.
		countBlt copyBits]! !

!Form methodsFor: 'analyzing' stamp: 'ar 5/28/2000 12:09'!
yTallyPixelValue: pv orNot: not
	"Return an array of the number of pixels with value pv by y-value.
	Note that if not is true, then this will tally those different from pv."
	| cm slice copyBlt countBlt |
	cm _ self newColorMap.		"Map all colors but pv to zero"
	not ifTrue: [cm atAllPut: 1].		"... or all but pv to one"
	cm at: pv+1 put: 1 - (cm at: pv+1).
	slice _ Form extent: width@1.
	copyBlt _ (BitBlt current destForm: slice sourceForm: self
				halftoneForm: nil combinationRule: Form over
				destOrigin: 0@0 sourceOrigin: 0@0 extent: slice width @ 1
				clipRect: slice boundingBox) colorMap: cm.
	countBlt _ (BitBlt current toForm: slice)
				fillColor: (Bitmap with: 0);
				destRect: (0@0 extent: slice extent);
				combinationRule: 32.
	^ (0 to: height-1) collect:
		[:y |
		copyBlt sourceOrigin: 0@y; copyBits.
		countBlt copyBits]! !


!Form methodsFor: 'bordering' stamp: 'ar 5/17/2001 15:42'!
borderFormOfWidth: borderWidth sharpCorners: sharpen
	"Smear this form around and then subtract the original to produce
	an outline.  If sharpen is true, then cause right angles to be outlined
	by right angles (takes an additional diagonal smears ANDed with both
	horizontal and vertical smears)."
	| smearForm bigForm smearPort all cornerForm cornerPort nbrs |
	self depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms."
	bigForm _ self deepCopy.
	all _ bigForm boundingBox.
	smearForm _ Form extent: self extent.
	smearPort _ BitBlt current toForm: smearForm.
	sharpen ifTrue:
		[cornerForm _ Form extent: self extent.
		cornerPort _ BitBlt current toForm: cornerForm].
	nbrs _ (0@0) fourNeighbors.
	1 to: borderWidth do:
		[:i |  "Iterate to get several layers of 'skin'"
		nbrs do:
			[:d |  "Smear the self in 4 directions to grow each layer of skin"
			smearPort copyForm: bigForm to: d rule: Form under].
		sharpen ifTrue:
			["Special treatment to smear sharp corners"
			nbrs with: ((2 to: 5) collect: [:i2 | nbrs atWrap: i2]) do:
				[:d1 :d2 |
				"Copy corner points diagonally"
				cornerPort copyForm: bigForm to: d1+d2 rule: Form over.
				"But only preserve if there were dots on either side"
				cornerPort copyForm: bigForm to: d1+d1+d2 rule: Form and.
				cornerPort copyForm: bigForm to: d1+d2+d2 rule: Form and.
				smearPort copyForm: cornerForm to: 0@0 rule: Form under].
			].
		bigForm copy: all from: 0@0 in: smearForm rule: Form over.
		].
	"Now erase the original shape to obtain the outline"
	bigForm copy: all from: 0@0 in: self rule: Form erase.
	^ bigForm! !

!Form methodsFor: 'bordering'!
borderWidth: anInteger 
	"Set the width of the border for the receiver to be anInteger and paint it 
	using black as the border color."

	self border: self boundingBox width: anInteger fillColor: Color black! !

!Form methodsFor: 'bordering'!
borderWidth: anInteger color: aMask
	"Set the width of the border for the receiver to be anInteger and paint it 
	using aMask as the border color."

	self border: self boundingBox width: anInteger fillColor: aMask! !

!Form methodsFor: 'bordering'!
borderWidth: anInteger fillColor: aMask
	"Set the width of the border for the receiver to be anInteger and paint it 
	using aMask as the border color."

	self border: self boundingBox width: anInteger fillColor: aMask! !

!Form methodsFor: 'bordering' stamp: 'ar 5/28/2000 12:07'!
border: rect width: borderWidth rule: rule fillColor: fillColor
        "Paint a border whose rectangular area is defined by rect. The
width of the border of each side is borderWidth. Uses fillColor for drawing
the border."
        | blt |
        blt _ (BitBlt current toForm: self) combinationRule: rule; fillColor: fillColor.
        blt sourceOrigin: 0@0.
        blt destOrigin: rect origin.
        blt width: rect width; height: borderWidth; copyBits.
        blt destY: rect corner y - borderWidth; copyBits.
        blt destY: rect origin y + borderWidth.
        blt height: rect height - borderWidth - borderWidth; width:
borderWidth; copyBits.
        blt destX: rect corner x - borderWidth; copyBits! !

!Form methodsFor: 'bordering' stamp: 'di 10/21/2001 09:39'!
shapeBorder: aColor width: borderWidth
	"A simplified version for shapes surrounded by transparency (as SketchMorphs).
	Note also this returns a new form that may be larger, and does not affect the original."
	| shapeForm borderForm newForm |
	newForm _ Form extent: self extent + (borderWidth*2) depth: self depth.
	newForm fillColor: Color transparent.
	self displayOn: newForm at: (0@0) + borderWidth.
	"First identify the shape in question as a B/W form"
	shapeForm _ (newForm makeBWForm: Color transparent) reverse.
	"Now find the border of that shape"
	borderForm _ shapeForm borderFormOfWidth: borderWidth sharpCorners: false.
	"Finally use that shape as a mask to paint the border with color"
	^ newForm fillShape: borderForm fillColor: aColor! !

!Form methodsFor: 'bordering'!
shapeBorder: aColor width: borderWidth interiorPoint: interiorPoint
	sharpCorners: sharpen internal: internal
	"Identify the shape (region of identical color) at interiorPoint,
	and then add an outline of width=borderWidth and color=aColor.
	If sharpen is true, then cause right angles to be outlined by
	right angles.  If internal is true, then produce a border that lies
	within the identified shape.  Thus one can put an internal border
	around the whole background, thus effecting a normal border
	around every other foreground image."
	| shapeForm borderForm interiorColor |
	"First identify the shape in question as a B/W form"
	interiorColor _ self colorAt: interiorPoint.
	shapeForm _ (self makeBWForm: interiorColor) reverse
				findShapeAroundSeedBlock:
					[:form | form pixelValueAt: interiorPoint put: 1].
	"Reverse the image to grow the outline inward"
	internal ifTrue: [shapeForm reverse].
	"Now find the border fo that shape"
	borderForm _ shapeForm borderFormOfWidth: borderWidth sharpCorners: sharpen.
	"Finally use that shape as a mask to paint the border with color"
	self fillShape: borderForm fillColor: aColor! !


!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'!
balancedPatternFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	self hasNonStandardPalette
		ifTrue:[^self bitPatternFor: aColor]
		ifFalse:[^aColor balancedPatternForDepth: self depth]! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'!
bitPatternFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	aColor isColor ifFalse:[^aColor bitPatternForDepth: self depth].
	self hasNonStandardPalette
		ifTrue:[^Bitmap with: (self pixelWordFor: aColor)]
		ifFalse:[^aColor bitPatternForDepth: self depth]! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'!
colormapFromARGB
	"Return a ColorMap mapping from canonical ARGB space into the receiver.
	Note: This version is optimized for Squeak forms."
	| map nBits |
	self hasNonStandardPalette 
		ifTrue:[^ColorMap mappingFromARGB: self rgbaBitMasks].
	self depth <= 8 ifTrue:[
		map _ Color colorMapIfNeededFrom: 32 to: self depth.
		map size = 512 ifTrue:[nBits _ 3].
		map size = 4096 ifTrue:[nBits _ 4].
		map size = 32768 ifTrue:[nBits _ 5].
		^ColorMap
			shifts: (Array 
						with: 3 * nBits - 24
						with: 2 * nBits - 16
						with: 1 * nBits - 8
						with: 0)
			masks: (Array
						with: (1 << nBits) - 1 << (24 - nBits)
						with: (1 << nBits) - 1 << (16 - nBits)
						with: (1 << nBits) - 1 << (8 - nBits)
						with: 0)
			colors: map].
	self depth = 16 ifTrue:[
		^ColorMap
			shifts: #(-9 -6 -3 0)
			masks: #(16rF80000 16rF800 16rF8 0)].
	self depth = 32 ifTrue:[
		^ColorMap
			shifts: #(0 0 0 0)
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)].
	self error:'Bad depth'! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42'!
colormapIfNeededForDepth: destDepth
	"Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed."

	self depth = destDepth ifTrue: [^ nil].  "not needed if depths are the same"
	^ Color colorMapIfNeededFrom: self depth to: destDepth
! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/16/2001 22:23'!
colormapIfNeededFor: destForm
	"Return a ColorMap mapping from the receiver to destForm."
	(self hasNonStandardPalette or:[destForm hasNonStandardPalette]) 
		ifTrue:[^self colormapFromARGB mappingTo: destForm colormapFromARGB]
		ifFalse:[^self colormapIfNeededForDepth: destForm depth]! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'!
colormapToARGB
	"Return a ColorMap mapping from the receiver into canonical ARGB space."
	self hasNonStandardPalette 
		ifTrue:[^self colormapFromARGB inverseMap].
	self depth <= 8 ifTrue:[
		^ColorMap
			shifts: #(0 0 0 0)
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)
			colors: (Color colorMapIfNeededFrom: self depth to: 32)].
	self depth = 16 ifTrue:[
		^ColorMap 
			shifts: #( 9 6 3 0) 
			masks: #(16r7C00 16r3E0 16r1F 0)].
	self depth = 32 ifTrue:[
		^ColorMap
			shifts: #(0 0 0 0) 
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)].
	self error:'Bad depth'! !

!Form methodsFor: 'color mapping'!
makeBWForm: foregroundColor
	"Map this form into a B/W form with 1's in the foreground regions."
	| bwForm map |
	bwForm _ Form extent: self extent.
	map _ self newColorMap.  "All non-foreground go to 0's"
	map at: (foregroundColor indexInMap: map) put: 1.
	bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map.
	^ bwForm! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:40'!
mapColors: oldColorBitsCollection to: newColorBits
	"Make all pixels of the given color in this Form to the given new color."
	"Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution."

	| map |
	self depth < 16
		ifTrue: [map _ (Color cachedColormapFrom: self depth to: self depth) copy]
		ifFalse: [
			"use maximum resolution color map"
			"source is 16-bit or 32-bit RGB; use colormap with 5 bits per color component"
			map _ Color computeRGBColormapFor: self depth bitsPerColor: 5].
	oldColorBitsCollection do:[ :oldColor | map at: oldColor put: newColorBits].

	(BitBlt current toForm: self)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form over;
		destX: 0 destY: 0 width: width height: height;
		colorMap: map;
		copyBits.
! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:38'!
mapColor: oldColor to: newColor
	"Make all pixels of the given color in this Form to the given new color."
	"Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution."

	| map |
	map _ (Color cachedColormapFrom: self depth to: self depth) copy.
	map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth).
	(BitBlt current toForm: self)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form over;
		destX: 0 destY: 0 width: width height: height;
		colorMap: map;
		copyBits.
! !

!Form methodsFor: 'color mapping' stamp: 'ar 12/14/2001 18:11'!
maskingMap
	"Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero."
	^Color maskingMap: self depth! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:41'!
newColorMap 
	"Return an uninitialized color map array appropriate to this Form's depth."

	^ Bitmap new: (1 bitShift: (self depth min: 15))
! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'!
pixelValueFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	self hasNonStandardPalette
		ifTrue:[^self colormapFromARGB mapPixel: (aColor pixelValueForDepth: 32)]
		ifFalse:[^aColor pixelValueForDepth: self depth]! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'!
pixelWordFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	| basicPattern |
	self hasNonStandardPalette 
		ifFalse:[^aColor pixelWordForDepth: self depth].
	basicPattern _ self pixelValueFor: aColor.
	self depth = 32 
		ifTrue:[^basicPattern]
		ifFalse:[^aColor pixelWordFor: self depth filledWith: basicPattern]! !

!Form methodsFor: 'color mapping' stamp: 'di 10/16/2001 15:23'!
reducedPaletteOfSize: nColors
	"Return an array of colors of size nColors, such that those colors
	represent well the pixel values actually found in this form."
	| threshold tallies colorTallies dist delta palette cts top cluster |
	tallies _ self tallyPixelValues.  "An array of tallies for each pixel value"
	threshold _ width * height // 500.

	"Make an array of (color -> tally) for all tallies over threshold"
	colorTallies _ Array streamContents:
		[:s | tallies withIndexDo:
			[:v :i | v >= threshold ifTrue:
				[s nextPut: (Color colorFromPixelValue: i-1 depth: depth) -> v]]].

	"Extract a set of clusters by picking the top tally, and then removing all others
	whose color is within dist of it.  Iterate the process, adjusting dist until we get nColors."
	dist _ 0.2.  delta _ dist / 2.
		[cts _ colorTallies copy.
		palette _ Array streamContents: [:s |
			[cts isEmpty] whileFalse:
				[top _ cts detectMax: [:a | a value].
				cluster _ cts select: [:a | (a key diff: top key) < dist].
				s nextPut: top key -> (cluster detectSum: [:a | a value]).
				cts _ cts copyWithoutAll: cluster]].
		palette size = nColors or: [delta < 0.001]]
		whileFalse:
			[palette size > nColors
				ifTrue: [dist _ dist + delta]
				ifFalse: [dist _ dist - delta].
			delta _ delta / 2].
	^ palette collect: [:a | a key]
! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 20:14'!
rgbaBitMasks
	"Return the masks for specifying the R,G,B, and A components in the receiver"
	self depth <= 8
		ifTrue:[^#(16rFF0000 16rFF00 16rFF 16rFF000000)].
	self depth = 16
		ifTrue:[^#(16r7C00 16r3E0 16r1F 16r0)].
	self depth = 32
		ifTrue:[^#(16rFF0000 16rFF00 16rFF 16rFF000000)].
	self error:'Bad depth for form'! !


!Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28'!
as8BitColorForm
	"Simple conversion of zero pixels to transparent.  Force it to 8 bits."

	| f map |
	f _ ColorForm extent: self extent depth: 8.
	self displayOn: f at: self offset negated.
	map _ Color indexedColors copy.
	map at: 1 put: Color transparent.
	f colors: map.
	f offset: self offset.
	^ f
! !

!Form methodsFor: 'converting' stamp: 'RAA 8/14/2000 10:13'!
asCursorForm

	^ self as: StaticForm! !

!Form methodsFor: 'converting' stamp: 'ar 6/16/2002 17:44'!
asFormOfDepth: d
	| newForm |
	d = self depth ifTrue:[^self].
	newForm _ Form extent: self extent depth: d.
	(BitBlt current toForm: newForm)
		colorMap: (self colormapIfNeededFor: newForm);
		copy: (self boundingBox)
		from: 0@0 in: self
		fillColor: nil rule: Form over.
	^newForm! !

!Form methodsFor: 'converting' stamp: 'ar 5/17/2001 15:39'!
asGrayScale
	"Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.)"
	| f32 srcForm result map bb grays |
	self depth = 32 ifFalse: [
		f32 _ Form extent: width@height depth: 32.
		self displayOn: f32.
		^ f32 asGrayScale].
	self unhibernate.
	srcForm _ Form extent: (width * 4)@height depth: 8.
	srcForm bits: bits.
	result _ ColorForm extent: width@height depth: 8.
	map _ Bitmap new: 256.
	2 to: 256 do: [:i | map at: i put: i - 1].
	map at: 1 put: 1.  "map zero pixel values to near-black"
	bb _ (BitBlt current toForm: result)
		sourceForm: srcForm;
		combinationRule: Form over;
		colorMap: map.
	0 to: width - 1 do: [:dstX |
		bb  sourceRect: (((dstX * 4) + 2)@0 extent: 1@height);
			destOrigin: dstX@0;
			copyBits].

	"final BitBlt to zero-out pixels that were truely transparent in the original"
	map _ Bitmap new: 512.
	map at: 1 put: 16rFF.
	(BitBlt current toForm: result)
		sourceForm: self;
		sourceRect: self boundingBox;
		destOrigin: 0@0;
		combinationRule: Form erase;
		colorMap: map;
		copyBits.
	
	grays _ (0 to: 255) collect: [:brightness | Color gray: brightness asFloat / 255.0].
	grays at: 1 put: Color transparent.
	result colors: grays.
	^ result
! !

!Form methodsFor: 'converting' stamp: 'ar 11/7/1999 20:29'!
asMorph
	^ImageMorph new image: self! !

!Form methodsFor: 'converting' stamp: 'ar 2/7/2004 18:16'!
asSourceForm
	^self! !

!Form methodsFor: 'converting' stamp: 'jm 4/5/1999 19:20'!
colorReduced
	"Return a color-reduced ColorForm version of the receiver, if possible, or the receiver itself if not."

	| tally tallyDepth colorCount newForm cm oldPixelValues newFormColors nextColorIndex c |
	tally _ self tallyPixelValues asArray.
	tallyDepth _ (tally size log: 2) asInteger.
	colorCount _ 0.
	tally do: [:n | n > 0 ifTrue: [colorCount _ colorCount + 1]].
	(tally at: 1) = 0 ifTrue: [colorCount _ colorCount + 1].  "include transparent"
	colorCount > 256 ifTrue: [^ self].  "cannot reduce"
	newForm _ self formForColorCount: colorCount.

	"build an array of just the colors used, and a color map to translate
	 old pixel values to their indices into this color array"
	cm _ Bitmap new: tally size.
	oldPixelValues _ self colormapIfNeededForDepth: 32.
	newFormColors _ Array new: colorCount.
	newFormColors at: 1 put: Color transparent.
	nextColorIndex _ 2.
	2 to: cm size do: [:i |
		(tally at: i) > 0 ifTrue: [
			oldPixelValues = nil
				ifTrue: [c _ Color colorFromPixelValue: i - 1 depth: tallyDepth]
				ifFalse: [c _ Color colorFromPixelValue: (oldPixelValues at: i) depth: 32].
			newFormColors at: nextColorIndex put: c.
			cm at: i put: nextColorIndex - 1.  "pixel values are zero-based indices"
			nextColorIndex _ nextColorIndex + 1]].

	"copy pixels into new ColorForm, mapping to new pixel values"
	newForm copyBits: self boundingBox
		from: self
		at: 0@0
		clippingBox: self boundingBox
		rule: Form over
		fillColor: nil
		map: cm.
	newForm colors: newFormColors.
	newForm offset: offset.
	^ newForm
! !

!Form methodsFor: 'converting' stamp: 'di 10/16/2001 19:23'!
copyWithColorsReducedTo: nColors
	"Note: this has not been engineered.
	There are better solutions in the literature."
	| palette colorMap pc closest |
	palette _ self reducedPaletteOfSize: nColors.
	colorMap _ (1 to: (1 bitShift: depth)) collect:
		[:i | pc _ Color colorFromPixelValue: i-1 depth: depth.
		closest _ palette detectMin: [:c | c diff: pc].
		closest pixelValueForDepth: depth].
	^ self deepCopy copyBits: self boundingBox from: self at: 0@0 colorMap: (colorMap as: Bitmap)
		! !

!Form methodsFor: 'converting' stamp: 'ar 7/23/1999 17:04'!
orderedDither32To16
	"Do an ordered dithering for converting from 32 to 16 bit depth."
	| ditherMatrix ii out inBits outBits index pv dmv r di dmi dmo g b pvOut outIndex |
	self depth = 32 ifFalse:[^self error:'Must be 32bit for this'].
	ditherMatrix _ #(	0	8	2	10
						12	4	14	6
						3	11	1	9
						15	7	13	5).
	ii _ (0 to: 31) collect:[:i| i].
	out _ Form extent: self extent depth: 16.
	inBits _ self bits.
	outBits _ out bits.
	index _ outIndex _ 0.
	pvOut _ 0.
	0 to: self height-1 do:[:y|
		0 to: self width-1 do:[:x|
			pv _ inBits at: (index _ index + 1).
			dmv _ ditherMatrix at: (y bitAnd: 3) * 4 + (x bitAnd: 3) + 1.
			r _ pv bitAnd: 255.	di _ r * 496 bitShift: -8.
			dmi _ di bitAnd: 15.	dmo _ di bitShift: -4.
			r _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo].
			g _ (pv bitShift: -8) bitAnd: 255.	di _ g * 496 bitShift: -8.
			dmi _ di bitAnd: 15.	dmo _ di bitShift: -4.
			g _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo].
			b _ (pv bitShift: -16) bitAnd: 255.	di _ b * 496 bitShift: -8.
			dmi _ di bitAnd: 15.	dmo _ di bitShift: -4.
			b _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo].
			pvOut _ (pvOut bitShift: 16) + 
						(b bitShift: 10) + (g bitShift: 5) + r.
			(x bitAnd: 1) = 1 ifTrue:[
				outBits at: (outIndex _ outIndex+1) put: pvOut.
				pvOut _ 0].
		].
		(self width bitAnd: 1) = 1 ifTrue:[
			outBits at: (outIndex _ outIndex+1) put: (pvOut bitShift: -16).
			pvOut _ 0].
	].
	^out! !


!Form methodsFor: 'copying' stamp: 'RAA 9/28/1999 11:20'!
blankCopyOf: aRectangle scaledBy: scale

        ^ self class extent: (aRectangle extent * scale) truncated depth: depth! !

!Form methodsFor: 'copying' stamp: 'ar 6/9/2000 18:59'!
contentsOfArea: aRect
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	^self contentsOfArea: aRect 
		into: (self class extent: aRect extent depth: depth).! !

!Form methodsFor: 'copying' stamp: 'ar 6/9/2000 19:00'!
contentsOfArea: aRect into: newForm
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	^ newForm copyBits: aRect from: self at: 0@0
		clippingBox: newForm boundingBox rule: Form over fillColor: nil! !

!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'!
copyBits: sourceForm at: destOrigin translucent: factor
	"Make up a BitBlt table and copy the bits with the given colorMap."
	(BitBlt current 
		destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: 30
		destOrigin: destOrigin
		sourceOrigin: 0@0
		extent: sourceForm extent
		clipRect: self boundingBox)
		copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255)
"
 | f f2 f3 | f _ Form fromUser. f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 deepCopy.
0.0 to: 1.0 by: 1.0/32 do:
	[:t | f3 _ f2 deepCopy. f3 copyBits: f at: 0@0 translucent: t.
	f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait].
"! !

!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 
	"Make up a BitBlt table and copy the bits."

	(BitBlt current 
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: rule
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: clipRect) copyBits! !

!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm map: map
	"Make up a BitBlt table and copy the bits.  Use a colorMap."

	((BitBlt current 
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: rule
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: clipRect) colorMap: map) copyBits! !

!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'!
copyBits: sourceRect from: sourceForm at: destOrigin colorMap: map 
	"Make up a BitBlt table and copy the bits with the given colorMap."
	((BitBlt current 
		destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: Form over
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: self boundingBox) colorMap: map) copyBits! !

!Form methodsFor: 'copying'!
copy: aRect
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	| newForm |
	newForm _ self class extent: aRect extent depth: depth.
	^ newForm copyBits: aRect from: self at: 0@0
		clippingBox: newForm boundingBox rule: Form over fillColor: nil! !

!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'!
copy: destRectangle from: sourcePt in: sourceForm rule: rule 
	"Make up a BitBlt table and copy the bits."
	(BitBlt current toForm: self)
		copy: destRectangle
		from: sourcePt in: sourceForm
		fillColor: nil rule: rule! !

!Form methodsFor: 'copying'!
copy: sourceRectangle from: sourceForm to: destPt rule: rule
	^ self copy: (destPt extent: sourceRectangle extent)
		from: sourceRectangle topLeft in: sourceForm rule: rule! !

!Form methodsFor: 'copying' stamp: 'jm 2/27/98 09:35'!
deepCopy

	^ self shallowCopy
		bits: bits copy;
		offset: offset copy
! !

!Form methodsFor: 'copying' stamp: 'tk 8/19/1998 16:11'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."
	^ self! !


!Form methodsFor: 'display box access'!
boundingBox
	^ Rectangle origin: 0 @ 0
			corner: width @ height! !

!Form methodsFor: 'display box access'!
computeBoundingBox
	^ Rectangle origin: 0 @ 0
			corner: width @ height! !


!Form methodsFor: 'displaying' stamp: 'ar 2/13/2001 22:13'!
displayInterpolatedIn: aRectangle on: aForm
	"Display the receiver on aForm, using interpolation if necessary.
		Form fromUser displayInterpolatedOn: Display.
	Note: When scaling we attempt to use bilinear interpolation based
	on the 3D engine. If the engine is not there then we use WarpBlt.
	"
	| engine adjustedR |
	self extent = aRectangle extent ifTrue:[^self displayOn: aForm at: aRectangle origin].
	Smalltalk at: #B3DRenderEngine 
		ifPresent:[:engineClass| engine _ (engineClass defaultForPlatformOn: aForm)].
	engine ifNil:[
		"We've got no bilinear interpolation. Use WarpBlt instead"
		(WarpBlt current toForm: aForm)
			sourceForm: self destRect: aRectangle;
			combinationRule: 3;
			cellSize: 2;
			warpBits.
		^self
	].

	"Otherwise use the 3D engine for our purposes"

	"there seems to be a slight bug in B3D which the following adjusts for"
	adjustedR _ (aRectangle withRight: aRectangle right + 1) translateBy: 0@1.
	engine viewport: adjustedR.
	engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white).
	engine texture: self.
	engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect).
	engine finish.! !

!Form methodsFor: 'displaying' stamp: 'ar 2/13/2001 22:12'!
displayInterpolatedOn: aForm
	"Display the receiver on aForm, using interpolation if necessary.
		Form fromUser displayInterpolatedOn: Display.
	Note: When scaling we attempt to use bilinear interpolation based
	on the 3D engine. If the engine is not there then we use WarpBlt.
	"
	| engine |
	self extent = aForm extent ifTrue:[^self displayOn: aForm].
	Smalltalk at: #B3DRenderEngine 
		ifPresent:[:engineClass| engine _ (engineClass defaultForPlatformOn: aForm)].
	engine ifNil:[
		"We've got no bilinear interpolation. Use WarpBlt instead"
		(WarpBlt current toForm: aForm)
			sourceForm: self destRect: aForm boundingBox;
			combinationRule: 3;
			cellSize: 2;
			warpBits.
		^self
	].
	"Otherwise use the 3D engine for our purposes"
	engine viewport: aForm boundingBox.
	engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white).
	engine texture: self.
	engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect).
	engine finish.! !

!Form methodsFor: 'displaying'!
displayOnPort: port at: location
	port copyForm: self to: location rule: Form over! !

!Form methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:33'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm

	aDisplayMedium copyBits: self boundingBox
		from: self
		at: aDisplayPoint + self offset
		clippingBox: clipRectangle
		rule: rule
		fillColor: aForm
		map: (self colormapIfNeededFor: aDisplayMedium).
! !

!Form methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Graphically, it means nothing to scale a Form by floating point values.  
	Because scales and other display parameters are kept in floating point to 
	minimize round off errors, we are forced in this routine to round off to the 
	nearest integer."

	| absolutePoint scale magnifiedForm |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	absolutePoint _ absolutePoint x asInteger @ absolutePoint y asInteger.
	displayTransformation noScale
		ifTrue: [magnifiedForm _ self]
		ifFalse: 
			[scale _ displayTransformation scale.
			scale _ scale x @ scale y.
			(1@1 = scale)
					ifTrue: [scale _ nil. magnifiedForm _ self]
					ifFalse: [magnifiedForm _ self magnify: self boundingBox by: scale]].
	magnifiedForm
		displayOn: aDisplayMedium
		at: absolutePoint - alignmentPoint
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm! !

!Form methodsFor: 'displaying' stamp: 'ar 5/17/2001 15:40'!
displayResourceFormOn: aForm
	"a special display method for blowing up resource thumbnails"
	| engine tx cmap blitter |
	self extent = aForm extent ifTrue:[^self displayOn: aForm].
	Smalltalk at: #B3DRenderEngine ifPresentAndInMemory:
		[:engineClass | engine _ engineClass defaultForPlatformOn: aForm].
	engine ifNil:[
		"We've got no bilinear interpolation. Use WarpBlt instead"
		(WarpBlt current toForm: aForm)
			sourceForm: self destRect: aForm boundingBox;
			combinationRule: 3;
			cellSize: 2;
			warpBits.
		^self
	].
	tx _ self asTexture.
	(blitter _ BitBlt current toForm: tx)
		sourceForm: self; destRect: aForm boundingBox;
		sourceOrigin: 0@0;
		combinationRule: Form paint.
	"map transparency to current World background color"
	(World color respondsTo: #pixelWordForDepth:) ifTrue: [
		cmap _ Bitmap new: (self depth <= 8 ifTrue: [1 << self depth] ifFalse: [4096]).
		cmap at: 1 put: (tx pixelWordFor: World color).
		blitter colorMap: cmap.
	].
	blitter copyBits.
	engine viewport: aForm boundingBox.
	engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white).
	engine texture: tx.
	engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect).
	engine finish.
	"the above, using bilinear interpolation doesn't leave transparent pixel values intact"
	(WarpBlt current toForm: aForm)
		sourceForm: self destRect: aForm boundingBox;
		combinationRule: Form and;
		colorMap: (Color maskingMap: self depth);
		warpBits.! !

!Form methodsFor: 'displaying' stamp: 'ar 3/2/2001 21:32'!
displayScaledOn: aForm
	"Display the receiver on aForm, scaling if necessary.
		Form fromUser displayScaledOn: Display.
	"
	self extent = aForm extent ifTrue:[^self displayOn: aForm].
	(WarpBlt current toForm: aForm)
		sourceForm: self destRect: aForm boundingBox;
		combinationRule: Form paint;
		cellSize: 2;
		warpBits.! !

!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'!
drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayMedium|drawLine:from:to:clippingBox:rule:mask:." 
	
	| dotSetter |
	"set up an instance of BitBlt for display"
	dotSetter _ BitBlt current
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: anInteger
		destOrigin: beginPoint
		sourceOrigin: 0 @ 0
		extent: sourceForm extent
		clipRect: clipRect.
	dotSetter drawFrom: beginPoint to: endPoint! !

!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'!
paintBits: sourceForm at: destOrigin translucent: factor
	"Make up a BitBlt table and copy the bits with the given colorMap."
	(BitBlt current destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: 31
		destOrigin: destOrigin
		sourceOrigin: 0@0
		extent: sourceForm extent
		clipRect: self boundingBox)
		copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255)
"
 | f f2 f3 | f _ Form fromUser. f replaceColor: f peripheralColor withColor: Color transparent.
f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 deepCopy.
0.0 to: 1.0 by: 1.0/32 do:
	[:t | f3 _ f2 deepCopy. f3 paintBits: f at: 0@0 translucent: t.
	f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait].
"! !


!Form methodsFor: 'editing' stamp: 'bf 10/11/1999 15:38'!
bitEdit
	"Create and schedule a view located in an area designated by the user 
	that contains a view of the receiver magnified by 8@8 that can be 
	modified using the Bit Editor. It also contains a view of the original 
	form."

	Smalltalk isMorphic
		ifFalse: [BitEditor openOnForm: self]
		ifTrue: [self currentHand attachMorph: (FatBitsPaint new
			editForm: self;
			magnification: 8;
			brushColor: Color black;
			penSize: 1;
			yourself)].

	"Note that using direct messages to BitEditor, fixed locations and scales can be created.
	That is, also try:
		BitEditor openOnForm: self at: <some point>
		BitEditor openOnForm: self at: <some point> scale: <some point>"! !

!Form methodsFor: 'editing'!
bitEditAt: magnifiedFormLocation scale: scaleFactor 
	"Create and schedule a view whose top left corner is magnifiedLocation 
	and that contains a view of the receiver magnified by scaleFactor that 
	can be modified using the Bit Editor. It also contains a view of the 
	original form."

	BitEditor openOnForm: self at: magnifiedFormLocation scale: scaleFactor ! !

!Form methodsFor: 'editing'!
edit
	"Start up an instance of the FormEditor on this form. Typically the form 
	is not visible on the screen. The editor menu is located at the bottom of 
	the form editing frame. The form is displayed centered in the frame. 
	YellowButtonMenu accept is used to modify the form to reflect the 
	changes made on the screen version; cancel restores the original form to 
	the screen. Note that the changes are clipped to the original size of the 
	form."
 
	FormEditor openOnForm: self! !

!Form methodsFor: 'editing' stamp: 'RAA 9/28/1999 09:11'!
morphEdit

        ^ FatBitsPaint new openWith: self! !


!Form methodsFor: 'fileIn/Out' stamp: 'ar 2/24/2001 22:41'!
comeFullyUpOnReload: smartRefStream
	bits isForm ifFalse:[^self].
	"make sure the resource gets loaded afterwards"
	ResourceCollector current ifNil:[^self].
	ResourceCollector current noteResource: bits replacing: self.
! !

!Form methodsFor: 'fileIn/Out' stamp: 'di 8/5/1998 11:37'!
hibernate
	"Replace my bitmap with a compactly encoded representation (a ByteArray).  It is vital that BitBlt and any other access to the bitmap (such as writing to a file) not be used when in this state.  Since BitBlt will fail if the bitmap size is wrong (not = bitsSize), we do not allow replacement by a byteArray of the same (or larger) size."

	"NOTE: This method copies code from Bitmap compressToByteArray so that it can
	nil out the old bits during the copy, thus avoiding 2x need for extra storage."
	| compactBits lastByte |
	(bits isMemberOf: Bitmap) ifFalse: [^ self  "already hibernated or weird state"].
	compactBits _ ByteArray new: (bits size*4) + 7 + (bits size//1984*3).
	lastByte _ bits compress: bits toByteArray: compactBits.
	lastByte < (bits size*4) ifTrue:
		[bits _ nil.  "Let GC reclaim the old bits before the copy if necessary"
		bits _ compactBits copyFrom: 1 to: lastByte]! !

!Form methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 16:16'!
objectForDataStream: refStream
	| prj repl |
	prj _ refStream project.
	prj ifNil:[^super objectForDataStream: refStream].
	ResourceCollector current ifNil:[^super objectForDataStream: refStream].
	repl _ ResourceCollector current objectForDataStream: refStream fromForm: self.
	^repl! !

!Form methodsFor: 'fileIn/Out' stamp: 'di 3/15/1999 14:50'!
printOn: aStream
    aStream
        nextPutAll: self class name;
        nextPut: $(; print: width;
        nextPut: $x; print: height;
        nextPut: $x; print: depth;
        nextPut: $).
! !

!Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:44'!
readAttributesFrom: aBinaryStream
	| offsetX offsetY |
	depth _ aBinaryStream next.
	(self depth isPowerOfTwo and: [self depth between: 1 and: 32])
		ifFalse: [self error: 'invalid depth; bad Form file?'].
	width _ aBinaryStream nextWord.
	height _ aBinaryStream nextWord.
	offsetX  _ aBinaryStream nextWord.
	offsetY _ aBinaryStream nextWord.
	offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536].
	offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536].
	offset _ Point x: offsetX y: offsetY.
	
! !

!Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:43'!
readBitsFrom: aBinaryStream
	
	bits _ Bitmap newFromStream: aBinaryStream.
	bits size = self bitsSize ifFalse: [self error: 'wrong bitmap size; bad Form file?'].
	^ self
! !

!Form methodsFor: 'fileIn/Out' stamp: 'jm 3/27/98 16:54'!
readFromOldFormat: aBinaryStream
	"Read a Form in the original ST-80 format."

	| w h offsetX offsetY newForm theBits pos |
	self error: 'this method must be updated to read into 32-bit word bitmaps'.
	w _ aBinaryStream nextWord.
	h _ aBinaryStream nextWord.
	offsetX  _ aBinaryStream nextWord.
	offsetY _ aBinaryStream nextWord.
	offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536].
	offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536].
	newForm _ Form extent: w @ h offset: offsetX @ offsetY.
	theBits _ newForm bits.
	pos _ 0.
	1 to: w + 15 // 16 do: [:j |
		1 to: h do: [:i |
			theBits at: (pos _ pos+1) put: aBinaryStream nextWord]].
	newForm bits: theBits.
	^ newForm
! !

!Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:44'!
readFrom: aBinaryStream
	"Reads the receiver from the given binary stream with the format:
		depth, extent, offset, bits."
	self readAttributesFrom: aBinaryStream.
	self readBitsFrom: aBinaryStream! !

!Form methodsFor: 'fileIn/Out' stamp: 'ar 2/24/2001 22:39'!
replaceByResource: aForm
	"Replace the receiver by some resource that just got loaded"
	(self extent = aForm extent and:[self depth = aForm depth]) ifTrue:[
		bits _ aForm bits.
	].! !

!Form methodsFor: 'fileIn/Out' stamp: 'nk 12/31/2003 16:06'!
store15To24HexBitsOn:aStream

	| buf i lineWidth |

	"write data for 16-bit form, optimized for encoders writing directly to files to do one single file write rather than 12. I'm not sure I understand the significance of the shifting pattern, but I think I faithfully translated it from the original"

	lineWidth _ 0.
	buf _ String new: 12.
	bits do: [:word | 
		i _ 0.
		"upper pixel"
		buf at: (i _ i + 1) put: ((word bitShift: -27) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -32) bitAnd: 8) asHexDigit.

		buf at: (i _ i + 1) put: ((word bitShift: -22) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -27) bitAnd: 8) asHexDigit.

		buf at: (i _ i + 1) put: ((word bitShift: -17) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -22) bitAnd: 8) asHexDigit.

		"lower pixel"

		buf at: (i _ i + 1) put: ((word bitShift: -11) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -16) bitAnd: 8) asHexDigit.

		buf at: (i _ i + 1) put: ((word bitShift: -6) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -11) bitAnd: 8) asHexDigit.

		buf at: (i _ i + 1) put: ((word bitShift: -1) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -6) bitAnd: 8) asHexDigit.
		aStream nextPutAll: buf.
		lineWidth _ lineWidth + 12.
		lineWidth > 100 ifTrue: [ aStream cr. lineWidth _ 0 ].
		"#( 31 26 21 15 10 5 )  do:[:startBit | ]"
	].! !

!Form methodsFor: 'fileIn/Out'!
store32To24HexBitsOn:aStream
	^self storeBits:20 to:0 on:aStream.! !

!Form methodsFor: 'fileIn/Out' stamp: 'laza 3/29/2004 12:21'!
storeBitsOn:aStream base:anInteger
	bits do: [:word | 
		anInteger = 10
			ifTrue: [aStream space]
			ifFalse: [aStream crtab: 2].
		word storeOn: aStream base: anInteger].
! !

!Form methodsFor: 'fileIn/Out'!
storeBits:startBit to:stopBit on:aStream
	bits storeBits:startBit to:stopBit on:aStream.! !

!Form methodsFor: 'fileIn/Out'!
storeHexBitsOn:aStream
	^self storeBits:28 to:0 on:aStream.! !

!Form methodsFor: 'fileIn/Out'!
storeOn: aStream

	self storeOn: aStream base: 10! !

!Form methodsFor: 'fileIn/Out'!
storeOn: aStream base: anInteger 
	"Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original."

	self unhibernate.
	aStream nextPut: $(.
	aStream nextPutAll: self species name.
	aStream crtab: 1.
	aStream nextPutAll: 'extent: '.
	self extent printOn: aStream.
	aStream crtab: 1.
	aStream nextPutAll: 'depth: '.
	self depth printOn: aStream.
	aStream crtab: 1.
	aStream nextPutAll: 'fromArray: #('.
	self storeBitsOn:aStream base:anInteger.
	aStream nextPut: $).
	aStream crtab: 1.
	aStream nextPutAll: 'offset: '.
	self offset printOn: aStream.
	aStream nextPut: $).
! !

!Form methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 15:50'!
unhibernate
	"If my bitmap has been compressed into a ByteArray,
	then expand it now, and return true."
	| resBits |
	bits isForm ifTrue:[
		resBits _ bits.
		bits _ Bitmap new: self bitsSize.
		resBits displayResourceFormOn: self.
		^true].
	bits == nil ifTrue:[bits _ Bitmap new: self bitsSize. ^true].
	(bits isMemberOf: ByteArray)
		ifTrue: [bits _ Bitmap decompressFromByteArray: bits. ^ true].
	^ false! !

!Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:35'!
writeAttributesOn: file
	self unhibernate.
	file nextPut: depth.
	file nextWordPut: width.
	file nextWordPut: height.
	file nextWordPut: ((self offset x) >=0
					ifTrue: [self offset x]
					ifFalse: [self offset x + 65536]).
	file nextWordPut: ((self offset y) >=0
					ifTrue: [self offset y]
					ifFalse: [self offset y + 65536]).
	! !

!Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:35'!
writeBitsOn: file
	bits writeOn: file! !

!Form methodsFor: 'fileIn/Out' stamp: 'ar 6/16/2002 17:53'!
writeBMPfileNamed: fName  "Display writeBMPfileNamed: 'display.bmp'"
	BMPReadWriter putForm: self onFileNamed: fName! !

!Form methodsFor: 'fileIn/Out' stamp: 'sw 2/20/2002 15:37'!
writeJPEGfileNamed: fileName 
	"Write a JPEG file to the given filename using default settings"

	self writeJPEGfileNamed: fileName progressive: false

"
Display writeJPEGfileNamed: 'display.jpeg'
Form fromUser writeJPEGfileNamed: 'yourPatch.jpeg'
"! !

!Form methodsFor: 'fileIn/Out' stamp: 'sw 2/20/2002 15:29'!
writeJPEGfileNamed: fileName  progressive: aBoolean
	"Write a JPEG file to the given filename using default settings.  Make it progressive or not, depending on the boolean argument"

	JPEGReadWriter2 putForm: self quality: -1 "default" progressiveJPEG: aBoolean onFileNamed: fileName

"
Display writeJPEGfileNamed: 'display.jpeg' progressive: false.
Form fromUser writeJPEGfileNamed: 'yourPatch.jpeg' progressive: true
"! !

!Form methodsFor: 'fileIn/Out' stamp: 'di 7/6/1998 23:00'!
writeOnMovie: file
	"Write just my bits on the file."
	self unhibernate.
	bits writeUncompressedOn: file! !

!Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:36'!
writeOn: file
	"Write the receiver on the file in the format
		depth, extent, offset, bits."
	self writeAttributesOn: file.
	self writeBitsOn: file! !

!Form methodsFor: 'fileIn/Out' stamp: 'tk 2/19/1999 07:30'!
writeUncompressedOn: file
	"Write the receiver on the file in the format depth, extent, offset, bits.  Warning:  Caller must put header info on file!!  Use writeUncompressedOnFileNamed: instead."
	self unhibernate.
	file binary.
	file nextPut: depth.
	file nextWordPut: width.
	file nextWordPut: height.
	file nextWordPut: ((self offset x) >=0
					ifTrue: [self offset x]
					ifFalse: [self offset x + 65536]).
	file nextWordPut: ((self offset y) >=0
					ifTrue: [self offset y]
					ifFalse: [self offset y + 65536]).
	bits writeUncompressedOn: file! !


!Form methodsFor: 'filling' stamp: 'di 2/19/1999 07:07'!
anyShapeFill
	"Fill the interior of the outermost outlined region in the receiver, a 1-bit deep form.  Typically the resulting form is used with fillShape:fillColor: to paint a solid color.  See also convexShapeFill:"

	| shape |
	"Draw a seed line around the edge and fill inward from the outside."
	shape _ self findShapeAroundSeedBlock: [:f | f borderWidth: 1].
	"Reverse so that this becomes solid in the middle"
	shape _ shape reverse.
	"Finally erase any bits from the original so the fill is only elsewhere"
	shape copy: shape boundingBox from: self to: 0@0 rule: Form erase.
	^ shape! !

!Form methodsFor: 'filling'!
bitPatternForDepth: suspectedDepth
	"Only called when a Form is being used as a fillColor.  Use a Pattern or InfiniteForm instead for this purpose.
	Interpret me as an array of (32/depth) Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"

	^ self! !

!Form methodsFor: 'filling' stamp: 'di 9/11/1998 16:25'!
convexShapeFill: aMask 
	"Fill the interior of the outtermost outlined region in the receiver.  The outlined region must not be concave by more than 90 degrees.  Typically aMask is Color black, to produce a solid fill. then the resulting form is used with fillShape: to paint a solid color.  See also anyShapeFill"
	| destForm tempForm |
	destForm _ Form extent: self extent.  destForm fillBlack.
	tempForm _ Form extent: self extent.
	(0@0) fourNeighbors do:
		[:dir |  "Smear self in all 4 directions, and AND the result"
		self displayOn: tempForm at: (0@0) - self offset.
		tempForm smear: dir distance: (dir dotProduct: tempForm extent) abs.
		tempForm displayOn: destForm at: 0@0
			clippingBox: destForm boundingBox
			rule: Form and fillColor: nil].
	destForm displayOn: self at: 0@0
		clippingBox: self boundingBox
		rule: Form over fillColor: aMask! !

!Form methodsFor: 'filling' stamp: 'di 10/17/2001 10:09'!
eraseShape: bwForm
	"use bwForm as a mask to clear all pixels where bwForm has 1's"
	((BitBlt current destForm: self sourceForm: bwForm 
		fillColor: nil
		combinationRule: Form erase1bitShape	"Cut a hole in the picture with my mask"
		destOrigin: bwForm offset 
		sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF))
		copyBits.
! !

!Form methodsFor: 'filling'!
fillFromXColorBlock: colorBlock
	"Horizontal Gradient Fill.
	Supply relative x in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| xRel |
	0 to: width-1 do:
		[:x |  xRel _ x asFloat / (width-1) asFloat.
		self fill: (x@0 extent: 1@height) 
			fillColor: (colorBlock value: xRel)]
"
((Form extent: 100@100 depth: Display depth)
	fillFromXColorBlock: [:x | Color r: x g: 0.0 b: 0.5]) display
"! !

!Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'!
fillFromXYColorBlock: colorBlock
	"General Gradient Fill.
	Supply relative x and y in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| poker yRel xRel |
	poker _ BitBlt current bitPokerToForm: self.
	0 to: height-1 do:
		[:y | yRel _ y asFloat / (height-1) asFloat.
		0 to: width-1 do:
			[:x |  xRel _ x asFloat / (width-1) asFloat.
			poker pixelAt: x@y
				put: ((colorBlock value: xRel value: yRel) pixelWordForDepth: self depth)]]
"
 | d |
((Form extent: 100@20 depth: Display depth)
	fillFromXYColorBlock:
	[:x :y | d _ 1.0 - (x - 0.5) abs - (y - 0.5) abs.
	Color r: d g: 0 b: 1.0-d]) display
"! !

!Form methodsFor: 'filling'!
fillFromYColorBlock: colorBlock
	"Vertical Gradient Fill.
	Supply relative y in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| yRel |
	0 to: height-1 do:
		[:y |  yRel _ y asFloat / (height-1) asFloat.
		self fill: (0@y extent: width@1) 
			fillColor: (colorBlock value: yRel)]
"
((Form extent: 100@100 depth: Display depth)
	fillFromYColorBlock: [:y | Color r: y g: 0.0 b: 0.5]) display
"! !

!Form methodsFor: 'filling' stamp: 'ar 5/28/2000 12:08'!
fill: aRectangle rule: anInteger fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by aForm 
	according to the rule anInteger."
	(BitBlt current toForm: self)
		copy: aRectangle
		from: 0@0 in: nil
		fillColor: aForm rule: anInteger! !

!Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'!
findShapeAroundSeedBlock: seedBlock
	"Build a shape that is black in any region marked by seedBlock. 
	SeedBlock will be supplied a form, in which to blacken various
	pixels as 'seeds'.  Then the seeds are smeared until 
	there is no change in the smear when it fills the region, ie,
	when smearing hits a black border and thus goes no further."
	| smearForm previousSmear all count smearPort |
	self depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms."
	all _ self boundingBox.
	smearForm _ Form extent: self extent.
	smearPort _ BitBlt current toForm: smearForm.
	seedBlock value: smearForm.		"Blacken seeds to be smeared"
	smearPort copyForm: self to: 0@0 rule: Form erase.  "Clear any in black"
	previousSmear _ smearForm deepCopy.
	count _ 1.
	[count = 10 and:   "check for no change every 10 smears"
		[count _ 1.
		previousSmear copy: all from: 0@0 in: smearForm rule: Form reverse.
		previousSmear isAllWhite]]
		whileFalse: 
			[smearPort copyForm: smearForm to: 1@0 rule: Form under.
			smearPort copyForm: smearForm to: -1@0 rule: Form under.
			"After horiz smear, trim around the region border"
			smearPort copyForm: self to: 0@0 rule: Form erase.
			smearPort copyForm: smearForm to: 0@1 rule: Form under.
			smearPort copyForm: smearForm to: 0@-1 rule: Form under.
			"After vert smear, trim around the region border"
			smearPort copyForm: self to: 0@0 rule: Form erase.
			count _ count+1.
			count = 9 ifTrue: "Save penultimate smear for comparison"
				[previousSmear copy: all from: 0@0 in: smearForm rule: Form over]].
	"Now paint the filled region in me with aHalftone"
	^ smearForm! !

!Form methodsFor: 'filling' stamp: 'ar 5/14/2001 23:46'!
floodFill2: aColor at: interiorPoint
	"Fill the shape (4-connected) at interiorPoint.  The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990.
	NOTE: This is a less optimized variant for flood filling which is precisely along the lines of Heckbert's algorithm. For almost all cases #floodFill:at: will be faster (see the comment there) but this method is left in both as reference and as a fallback if such a strange case is encountered in reality."
	| peeker poker stack old new x y top x1 x2 dy left goRight |
	peeker _ BitBlt current bitPeekerFromForm: self.
	poker _ BitBlt current bitPokerToForm: self.
	stack _ OrderedCollection new: 50.
	"read old pixel value"
	old _ peeker pixelAt: interiorPoint.
	"compute new value"
	new _ self pixelValueFor: aColor.
	old = new ifTrue:[^self]. "no point, is there?!!"

	x _ interiorPoint x.
	y _ interiorPoint y.
	(y >= 0 and:[y < height]) ifTrue:[
		stack addLast: {y. x. x. 1}. "y, left, right, dy"
		stack addLast: {y+1. x. x. -1}].
	[stack isEmpty] whileFalse:[
		top _ stack removeLast.
		y _ top at: 1. x1 _ top at: 2. x2 _ top at: 3. dy _ top at: 4.
		y _ y + dy.
		"Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled.
		Now explore adjacent pixels in scanline y."
		x _ x1.
		[x >= 0 and:[(peeker pixelAt: x@y) = old]] whileTrue:[
			poker pixelAt: x@y put: new.
			x _ x - 1].
		goRight _ x < x1.
		left _ x+1.
		(left < x1 and:[y-dy >= 0 and:[y-dy < height]]) 
			ifTrue:[stack addLast: {y. left. x1-1. 0-dy}].
		goRight ifTrue:[x _ x1 + 1].
		[
			goRight ifTrue:[
				[x < width and:[(peeker pixelAt: x@y) = old]] whileTrue:[
					poker pixelAt: x@y put: new.
					x _ x + 1].
				(y+dy >= 0 and:[y+dy < height]) 
					ifTrue:[stack addLast: {y. left. x-1. dy}].
				(x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) 
					ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]].
			[(x _ x + 1) <= x2 and:[(peeker pixelAt: x@y) ~= old]] whileTrue.
			left _ x.
			goRight _ true.
		x <= x2] whileTrue.
	].
! !

!Form methodsFor: 'filling' stamp: 'di 10/20/2001 10:09'!
floodFillMapFrom: sourceForm to: scanlineForm mappingColorsWithin: dist to: centerPixVal
	"This is a helper routine for floodFill.  It's written for clarity (scanning the entire
	map using colors) rather than speed (which would require hacking rgb components
	in the nieghborhood of centerPixVal.  Note that some day a better proximity metric
	would be (h s v) where tolerance could be reduced in hue."

	| colorMap centerColor |
	scanlineForm depth = 32 ifFalse: [self error: 'depth 32 assumed'].
	"First get a modifiable identity map"
	colorMap _ 	(Color cachedColormapFrom: sourceForm depth to: scanlineForm depth) copy.
	centerColor _ Color colorFromPixelValue: (centerPixVal bitOr: 16rFFe6) depth: scanlineForm depth.
	"Now replace all entries that are close to the centerColor"
	1 to: colorMap size do:
		[:i | ((Color colorFromPixelValue: ((colorMap at: i) bitOr: 16rFFe6) depth: scanlineForm depth)
				diff: centerColor) <= dist ifTrue: [colorMap at: i put: centerPixVal]].
	^ colorMap! !

!Form methodsFor: 'filling' stamp: 'di 10/20/2001 22:03'!
floodFill: aColor at: interiorPoint
	Preferences areaFillsAreVeryTolerant ifTrue:
		[^ self floodFill: aColor at: interiorPoint tolerance: 0.2].
	Preferences areaFillsAreTolerant ifTrue:
		[^ self floodFill: aColor at: interiorPoint tolerance: 0.1].
	^ self floodFill: aColor at: interiorPoint tolerance: 0
! !

!Form methodsFor: 'filling' stamp: 'di 10/20/2001 08:47'!
floodFill: aColor at: interiorPoint tolerance: tolerance
	"Fill the shape (4-connected) at interiorPoint.  The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990.
	NOTE (ar): This variant has been heavily optimized to prevent the overhead of repeated calls to BitBlt. Usually this is a really big winner but the runtime now depends a bit on the complexity of the shape to be filled. For extremely complex shapes (say, a Hilbert curve) with very few pixels to fill it can be slower than #floodFill2:at: since it needs to repeatedly read the source bits. However, in all practical cases I found this variant to be 15-20 times faster than anything else.
	Further note (di):  I have added a feature that allows this routine to fill areas of approximately constant color (such as  photos, scans, and jpegs).  It does this by computing a color map for the peeker that maps all colors close to 'old' into colors identical to old.  This mild colorblindness achieves the desired effect with no further change or degradation of the algorithm.  tolerance should be 0 (exact match), or a value corresponding to those returned by Color>>diff:, with 0.1 being a reasonable starting choice."

	| peeker poker stack old new x y top x1 x2 dy left goRight span spanBits w box debug |
	debug _ false. "set it to true to see the filling process"
	box _ interiorPoint extent: 1@1.
	span _ Form extent: width@1 depth: 32.
	spanBits _ span bits.

	peeker _ BitBlt current toForm: span.
	peeker 
		sourceForm: self; 
		combinationRule: 3; 
		width: width; 
		height: 1.

	"read old pixel value"
	peeker sourceOrigin: interiorPoint; destOrigin: interiorPoint x @ 0; width: 1; copyBits.
	old _ spanBits at: interiorPoint x + 1.

	"compute new value (take care since the algorithm will fail if old = new)"
	new _ self privateFloodFillValue: aColor.
	old = new ifTrue: [^ box].
	tolerance > 0 ifTrue:
		["Set up color map for approximate fills"
		peeker colorMap: (self floodFillMapFrom: self to: span mappingColorsWithin: tolerance to: old)].

	poker _ BitBlt current toForm: self.
	poker 
		fillColor: aColor;
		combinationRule: 3;
		width: width;
		height: 1.

	stack _ OrderedCollection new: 50.
	x _ interiorPoint x.
	y _ interiorPoint y.
	(y >= 0 and:[y < height]) ifTrue:[
		stack addLast: {y. x. x. 1}. "y, left, right, dy"
		stack addLast: {y+1. x. x. -1}].

	[stack isEmpty] whileFalse:[
		debug ifTrue:[self displayOn: Display].
		top _ stack removeLast.
		y _ top at: 1. x1 _ top at: 2. x2 _ top at: 3. dy _ top at: 4.
		y _ y + dy.
		debug ifTrue:[
			(Line from: (x1-1)@y to: (x2+1)@y 
				withForm: (Form extent: 1@1 depth: 8) fillWhite) displayOn: Display].
		"Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled.
		Now explore adjacent pixels in scanline y."
		peeker sourceOrigin: 0@y; destOrigin: 0@0; width: width; copyBits.
			"Note: above is necessary since we don't know where we'll end up filling"
		x _ x1.
		w _ 0.
		[x >= 0 and:[(spanBits at: x+1) = old]] whileTrue:[
			w _ w + 1.
			x _ x - 1].
		w > 0 ifTrue:[
			"overwrite pixels"
			poker destOrigin: x+1@y; width: w; copyBits.
			box _ box quickMerge: ((x+1@y) extent: w@1)].
		goRight _ x < x1.
		left _ x+1.
		(left < x1 and:[y-dy >= 0 and:[y-dy < height]]) 
			ifTrue:[stack addLast: {y. left. x1-1. 0-dy}].
		goRight ifTrue:[x _ x1 + 1].
		[
			goRight ifTrue:[
				w _ 0.
				[x < width and:[(spanBits at: x+1) = old]] whileTrue:[
					w _ w + 1.
					x _ x + 1].
				w > 0 ifTrue:[
					"overwrite pixels"
					poker destOrigin: (x-w)@y; width: w; copyBits.
					box _ box quickMerge: ((x-w@y) extent: w@1)].
				(y+dy >= 0 and:[y+dy < height]) 
					ifTrue:[stack addLast: {y. left. x-1. dy}].
				(x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) 
					ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]].
			[(x _ x + 1) <= x2 and:[(spanBits at: x+1) ~= old]] whileTrue.
			left _ x.
			goRight _ true.
		x <= x2] whileTrue.
	].
	^box! !

!Form methodsFor: 'filling' stamp: 'di 10/17/2001 10:10'!
shapeFill: aColor interiorPoint: interiorPoint
	"Identify the shape (region of identical color) at interiorPoint,
	and then fill that shape with the new color, aColor
	: modified di's original method such that it returns the bwForm, for potential use by the caller"

	| bwForm interiorPixVal map ppd color ind |
	self depth = 1 ifTrue:
		[^ self shapeFill: aColor
			seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]].

	"First map this form into a B/W form with 0's in the interior region."
		"bwForm _ self makeBWForm: interiorColor."	"won't work for two whites"
	interiorPixVal _ self pixelValueAt: interiorPoint.
	bwForm _ Form extent: self extent.
	map _ Bitmap new: (1 bitShift: (self depth min: 12)).  "Not calling newColorMap.  All 
			non-foreground go to 0.  Length is 2 to 4096."
	ppd _ self depth.	"256 long color map in depth 8 is not one of the following cases"
	3 to: 5 do: [:bitsPerColor | 
		(2 raisedTo: bitsPerColor*3) = map size 
			ifTrue: [ppd _ bitsPerColor*3]].	"ready for longer maps than 512"

	ppd <= 8
		ifTrue: [map at: interiorPixVal+1 put: 1]
		ifFalse: [interiorPixVal = 0 
			ifFalse: [color _ Color colorFromPixelValue: interiorPixVal depth: self depth.
				ind _ color pixelValueForDepth: ppd.
				map at: ind+1 put: 1]
			ifTrue: [map at: 1 put: 1]].
	bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map.
	bwForm reverse.  "Make interior region be 0's"

	"Now fill the interior region and return that shape"
	bwForm _ bwForm findShapeAroundSeedBlock:
					[:form | form pixelValueAt: interiorPoint put: 1].

	"Finally use that shape as a mask to flood the region with color"
	self eraseShape: bwForm.
	self fillShape: bwForm fillColor: aColor.
	^ bwForm! !

!Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'!
shapeFill: aColor seedBlock: seedBlock
	self depth > 1 ifTrue: [self error: 'This call only meaningful for B/W forms'].
	(self findShapeAroundSeedBlock: seedBlock)
		displayOn: self at: 0@0 clippingBox: self boundingBox
		rule: Form under fillColor: aColor ! !


!Form methodsFor: 'image manipulation' stamp: 'ar 5/17/2001 15:40'!
replaceColor: oldColor withColor: newColor
	"Replace one color with another everywhere is this form"

	| cm newInd target ff |
	self depth = 32
		ifTrue: [cm _ (Color  cachedColormapFrom: 16 to: 32) copy]
		ifFalse: [cm _ Bitmap new: (1 bitShift: (self depth min: 15)).
				1 to: cm size do: [:i | cm at: i put: i - 1]].
	newInd _ newColor pixelValueForDepth: self depth.
	cm at: (oldColor pixelValueForDepth: (self depth min: 16))+1 put: newInd.
	target _ newColor isTransparent 
		ifTrue: [ff _ Form extent: self extent depth: depth.
			ff fillWithColor: newColor.  ff]
		ifFalse: [self].
	(BitBlt current toForm: target)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form paint;
		destX: 0 destY: 0 width: width height: height;
		colorMap: cm;
		copyBits.
	newColor = Color transparent 
		ifTrue: [target displayOn: self].! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:09'!
smear: dir distance: dist
	"Smear any black pixels in this form in the direction dir in Log N steps"
	| skew bb |
	bb _ BitBlt current destForm: self sourceForm: self fillColor: nil
		combinationRule: Form under destOrigin: 0@0 sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox.
	skew _ 1.
	[skew < dist] whileTrue:
		[bb destOrigin: dir*skew; copyBits.
		skew _ skew+skew]! !

!Form methodsFor: 'image manipulation' stamp: 'LB 8/26/2002 18:08'!
stencil
	"return a 1-bit deep, black-and-white stencil of myself"

	| canvas |
	canvas _ FormCanvas extent: self extent depth: 1.
	canvas fillColor: (Color white).

	canvas stencil: self at: 0@0  
				sourceRect: (Rectangle origin: 0@0 corner: self extent) color: Color black.

	^ canvas form
! !

!Form methodsFor: 'image manipulation' stamp: 'jm 6/30/1999 15:36'!
trimBordersOfColor: aColor
	"Answer a copy of this Form with each edge trimmed in to the first pixel that is not of the given color. (That is, border strips of the given color are removed)."

	| r |
	r _ self rectangleEnclosingPixelsNotOfColor: aColor.
	^ self copy: r
! !


!Form methodsFor: 'initialize-release' stamp: 'ar 5/17/2001 22:54'!
allocateForm: extentPoint
	"Allocate a new form which is similar to the receiver and can be used for accelerated blts"
	^Form extent: extentPoint depth: self nativeDepth! !

!Form methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 00:46'!
finish
	"If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."! !

!Form methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 00:45'!
flush
	"If there are any pending operations on the receiver start doing them. In time, they will show up on the receiver but not necessarily immediately after this method returns."! !

!Form methodsFor: 'initialize-release'!
fromDisplay: aRectangle 
	"Create a virtual bit map from a user specified rectangular area on the 
	display screen. Reallocates bitmap only if aRectangle ~= the receiver's 
	extent."

	(width = aRectangle width and: [height = aRectangle height])
		ifFalse: [self setExtent: aRectangle extent depth: depth].
	self
		copyBits: (aRectangle origin extent: self extent)
		from: Display
		at: 0 @ 0
		clippingBox: self boundingBox
		rule: Form over
		fillColor: nil! !

!Form methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 18:45'!
shutDown
	"The system is going down. Try to preserve some space"
	self hibernate! !

!Form methodsFor: 'initialize-release' stamp: 'ar 6/16/2002 18:39'!
swapEndianness
	"Swap from big to little endian pixels and vice versa"
	depth := 0 - depth.! !


!Form methodsFor: 'other' stamp: 'ar 12/12/2003 18:24'!
fixAlpha
	"Fix the alpha channel if the receiver is 32bit"
	| bb |
	self depth = 32 ifFalse:[^self].
	bb := BitBlt toForm: self.
	bb combinationRule: 40 "fixAlpha:with:".
	bb copyBits.! !

!Form methodsFor: 'other' stamp: 'jm 9/27/97 21:02'!
formForColorCount: colorCount
	"Return a ColorForm of sufficient depth to represent the given number of colors. The maximum number of colors is 256."

	colorCount > 256 ifTrue: [^ self error: 'too many colors'].

	colorCount > 16 ifTrue: [^ ColorForm extent: self extent depth: 8].
	colorCount > 4 ifTrue: [^ ColorForm extent: self extent depth: 4].
	colorCount > 2 ifTrue: [^ ColorForm extent: self extent depth: 2].
	^ ColorForm extent: self extent depth: 1
! !

!Form methodsFor: 'other' stamp: 'jm 1/6/98 10:37'!
primPrintHScale: hScale vScale: vScale landscape: aBoolean
	"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
	"(Form extent: 10@10) primPrintHScale: 1.0 vScale: 1.0 landscape: true"

	<primitive: 232>
	self primitiveFailed
! !

!Form methodsFor: 'other' stamp: 'RAA 1/30/2002 16:42'!
relativeTextAnchorPosition

	^nil		"so forms can be in TextAnchors"! !

!Form methodsFor: 'other' stamp: 'dgd 8/26/2003 21:44'!
setAsBackground
	"Set this form as a background image."

	| world newColor |
	Smalltalk isMorphic 
		ifTrue:
			[world _ self currentWorld.
			newColor _ InfiniteForm with: self.
			self rememberCommand:
				(Command new cmdWording: 'set background to a picture' translated;
					undoTarget: world selector: #color: argument: world color;
					redoTarget: world selector: #color: argument: newColor).
			world color: newColor]
		ifFalse:
			[ScheduledControllers screenController model form: self.
			Display restoreAfter: []]! !


!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42'!
colorAt: aPoint
	"Return the color in the pixel at the given point.  "

	^ Color 
		colorFromPixelValue: (self pixelValueAt: aPoint)
		depth: self depth
! !

!Form methodsFor: 'pixel access' stamp: 'ar 5/14/2001 23:46'!
colorAt: aPoint put: aColor
	"Store a Color into the pixel at coordinate aPoint.  "

	self pixelValueAt: aPoint put: (self pixelValueFor: aColor).

"[Sensor anyButtonPressed] whileFalse:
	[Display colorAt: Sensor cursorPoint put: Color red]"
! !

!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:39'!
isTransparentAt: aPoint 
	"Return true if the receiver is transparent at the given point."

	self depth = 1 ifTrue: [^ false].  "no transparency at depth 1"
	^ (self pixelValueAt: aPoint) = (self pixelValueFor: Color transparent)
! !

!Form methodsFor: 'pixel access' stamp: 'ar 5/28/2000 12:08'!
pixelValueAt: aPoint 
	"Return the raw pixel value at the given point. This pixel value depends on the receiver's depth. Typical clients use colorAt: to get a Color.  "

	^ (BitBlt current bitPeekerFromForm: self) pixelAt: aPoint
! !

!Form methodsFor: 'pixel access' stamp: 'ar 5/28/2000 12:08'!
pixelValueAt: aPoint put: pixelValue
	"Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. "

	(BitBlt current bitPokerToForm: self) pixelAt: aPoint put: pixelValue.
! !


!Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:36'!
bitsPerComponent
	^self depth <= 8 ifTrue:[self depth] ifFalse:[8].
! !

!Form methodsFor: 'postscript generation' stamp: 'mpw 11/14/1999 22:22'!
bytesPerRow
	^ self numComponents * self paddedWidth * self bitsPerComponent / 8.! !

!Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:39'!
decodeArray
	^self depth <= 8 ifTrue:['[1 0]'] ifFalse:['[0 1 0 1 0 1 ]'].
! !

!Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:43'!
numComponents
	^self depth <= 8 ifTrue:[1] ifFalse:[3].
! !

!Form methodsFor: 'postscript generation'!
paddedWidth
	^ (self width + (self rowPadding-1)// self rowPadding) * self rowPadding.! !

!Form methodsFor: 'postscript generation' stamp: 'nk 12/31/2003 15:46'!
printPostscript: aStream operator: operator 
	aStream preserveStateDuring: 
			[:inner | 
			inner rectclip: (0 @ 0 extent: width @ height).
			self setColorspaceOn: inner.
			inner
				print: '[ ';
				cr;
				print: '/ImageType 1';
				cr;
				print: '/ImageMatrix [1 0 0 1 0 0]';
				cr;
				print: '/MultipleDataSources false';
				cr;
				print: '/DataSource level1 { { currentfile ';
				write: self bytesPerRow;
				print: ' string readhexstring pop }} bind { currentfile /ASCIIHexDecode filter } ifelse';
				cr;
				print: '/Width ';
				write: self paddedWidth;
				cr;
				print: '/Height ';
				write: self height;
				cr;
				print: '/Decode ';
				print: self decodeArray;
				cr;
				print: '/BitsPerComponent ';
				write: self bitsPerComponent;
				cr;
				print: 'makeDict ';
				print: operator;
				cr.
			self storePostscriptHexOn: inner.
			inner
				print: $>;
				cr.
			inner cr].
	aStream cr! !

!Form methodsFor: 'postscript generation' stamp: 'mpw 11/15/1999 08:34'!
rowPadding
	^ 32 // self depth! !

!Form methodsFor: 'postscript generation'!
setColorspaceOn:aStream
	self numComponents = 1 ifTrue:[aStream print:'/DeviceGray setcolorspace 0 setgray'; cr.]
		ifFalse:[aStream print:'/DeviceRGB setcolorspace'; cr.].! !

!Form methodsFor: 'postscript generation' stamp: 'nk 12/31/2003 15:46'!
storePostscriptHexOn: inner 
	self depth <= 8 ifTrue: [self storeHexBitsOn: inner].
	self depth = 16 ifTrue: [self store15To24HexBitsOn: inner].
	self depth = 32 ifTrue: [self store32To24HexBitsOn: inner]! !


!Form methodsFor: 'resources' stamp: 'ar 12/9/2002 16:04'!
readNativeResourceFrom: byteStream
	| img aStream |
	(byteStream isKindOf: FileStream) ifTrue:[
		"Ugly, but ImageReadWriter will send #reset which is implemented as #reopen and we may not be able to do so."
		aStream _ RWBinaryOrTextStream with: byteStream contents.
	] ifFalse:[
		aStream _ byteStream.
	].
	img _ [ImageReadWriter formFromStream: aStream] on: Error do:[:ex| nil].
	img ifNil:[^nil].
	(img isColorForm and:[self isColorForm]) ifTrue:[
		| cc |
		cc := img colors.
		img colors: nil.
		img displayOn: self.
		img colors: cc.
	] ifFalse:[
		img displayOn: self.
	].
	img _ nil.! !

!Form methodsFor: 'resources' stamp: 'nk 7/30/2004 17:53'!
readResourceFrom: aStream 
	"Store a resource representation of the receiver on aStream.
	Must be specific to the receiver so that no code is filed out."

	| bitsSize msb |
	(aStream next: 4) asString = self resourceTag 
		ifFalse: 
			[aStream position: aStream position - 4.
			^self readNativeResourceFrom: aStream].
	width := aStream nextNumber: 4.
	height := aStream nextNumber: 4.
	depth := aStream nextNumber: 4.
	bitsSize := aStream nextNumber: 4.
	bitsSize = 0 
		ifFalse: 
			[bits := aStream next: bitsSize.
			^self].
	msb := (aStream nextNumber: 4) = 1.
	bitsSize := aStream nextNumber: 4.
	bits := Bitmap new: self bitsSize.
	(Form 
		extent: width @ height
		depth: depth
		bits: (aStream next: bitsSize * 4)) displayOn: self.
	msb = SmalltalkImage current  isBigEndian 
		ifFalse: 
			[Bitmap 
				swapBytesIn: bits
				from: 1
				to: bits size]! !

!Form methodsFor: 'resources' stamp: 'ar 2/27/2001 14:56'!
resourceTag
	^'FORM'! !

!Form methodsFor: 'resources' stamp: 'sd 9/30/2003 13:41'!
storeResourceOn: aStream
	"Store a resource representation of the receiver on aStream.
	Must be specific to the receiver so that no code is filed out."
	self hibernate.
	aStream nextPutAll: self resourceTag asByteArray. "tag"
	aStream nextNumber: 4 put: width.
	aStream nextNumber: 4 put: height.
	aStream nextNumber: 4 put: depth.
	(bits isMemberOf: ByteArray) ifFalse:[
		"must store bitmap"
		aStream nextNumber: 4 put: 0. "tag"
		aStream nextNumber: 4 put: (SmalltalkImage current  isBigEndian ifTrue:[1] ifFalse:[0]).
	].
	aStream nextNumber: 4 put: bits size.
	aStream nextPutAll: bits.
! !


!Form methodsFor: 'scaling, rotation' stamp: 'ar 5/14/2001 23:33'!
flipBy: direction centerAt: aPoint
	"Return a copy of the receiver flipped either #vertical or #horizontal."
	| newForm quad |
	newForm _ self class extent: self extent depth: depth.
	quad _ self boundingBox innerCorners.
	quad _ (direction = #vertical ifTrue: [#(2 1 4 3)] ifFalse: [#(4 3 2 1)])
		collect: [:i | quad at: i].
	(WarpBlt current toForm: newForm)
		sourceForm: self;
		colorMap: (self colormapIfNeededFor: newForm);
		combinationRule: 3;
		copyQuad: quad toRect: newForm boundingBox.
	newForm offset: (self offset flipBy: direction centerAt: aPoint).
	^ newForm
"
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
			flipBy: #vertical centerAt: 0@0) display]
"
"Consistency test...
 | f f2 p | [Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).
	Display fillBlack: (p extent: 31@41).
	f2 _ f flipBy: #vertical centerAt: 0@0.
	(f2 flipBy: #vertical centerAt: 0@0) displayAt: p]
"
! !

!Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 17:00'!
magnifyBy: scale 
	"Answer a Form created as a scaling of the receiver.
	Scale may be a Float or even a Point, and may be greater or less than 1.0."

	^ self magnify: self boundingBox by: scale
			smoothing: (scale < 1 ifTrue: [2] ifFalse: [1])! !

!Form methodsFor: 'scaling, rotation'!
magnify: aRectangle by: scale 
	"Answer a Form created as a scaling of the receiver.
	Scale may be a Float, and may be greater or less than 1.0."
	^ self magnify: aRectangle by: scale smoothing: 1

"Dynamic test...
[Sensor anyButtonPressed] whileFalse:
	[(Display magnify: (Sensor cursorPoint extent: 31@41) by: 5@3) display]
"
"Scaling test...
| f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100).
Display restoreAfter: [Sensor waitNoButton.
[Sensor anyButtonPressed] whileFalse:
	[cp _ Sensor cursorPoint.
	(f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent) display]]
"
"Consistency test...
 | f f2 p | [Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).
	Display fillBlack: (p extent: 31@41).
	f2 _ f magnify: f boundingBox by: 5@3.
	(f2 shrink: f2 boundingBox by: 5@3) displayAt: p]
"
! !

!Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 17:00'!
magnify: aRectangle by: scale smoothing: cellSize
        "Answer a Form created as a scaling of the receiver.
        Scale may be a Float or even a Point, and may be greater or less than 1.0."
        | newForm |
        newForm _ self blankCopyOf: aRectangle scaledBy: scale.
        (WarpBlt current toForm: newForm)
                sourceForm: self;
                colorMap: (self colormapIfNeededFor: newForm);
                cellSize: cellSize;  "installs a new colormap if cellSize > 1"
                combinationRule: 3;
                copyQuad: aRectangle innerCorners toRect: newForm boundingBox.
        ^ newForm

"Dynamic test...
[Sensor anyButtonPressed] whileFalse:
        [(Display magnify: (Sensor cursorPoint extent: 131@81) by: 0.5 smoothing: 2) display]
"
"Scaling test...
| f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100).
Display restoreAfter: [Sensor waitNoButton.
[Sensor anyButtonPressed] whileFalse:
        [cp _ Sensor cursorPoint.
        (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent smoothing: 2) display]]
"! !

!Form methodsFor: 'scaling, rotation'!
rotateBy: deg
	"Rotate the receiver by the indicated number of degrees."
	"rot is the destination form, bit enough for any angle."

	^ self rotateBy: deg smoothing: 1
"
 | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: (a _ a+5)) display].
f display
"! !

!Form methodsFor: 'scaling, rotation' stamp: 'wiz 1/22/2006 01:15'!
rotateBy: direction centerAt: aPoint
	"Return a rotated copy of the receiver. 
	direction = #none, #right, #left, or #pi"
	| newForm quad rot scale |
	direction == #none ifTrue: [^ self].
	scale :=  (direction = #pi ifTrue: [width@height] ifFalse: [height@width]) / self extent .
	newForm := self blankCopyOf: self boundingBox scaledBy: scale.
	quad _ self boundingBox innerCorners.
	rot _ #(right pi left) indexOf: direction.
	(WarpBlt current toForm: newForm)
		sourceForm: self;
		colorMap: (self colormapIfNeededFor: newForm);
		combinationRule: 3;
		copyQuad: ((1+rot to: 4+rot) collect: [:i | quad atWrap: i])
			 toRect: newForm boundingBox.
	newForm offset: (self offset rotateBy: direction centerAt: aPoint).
	^ newForm
"
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: #left centerAt: 0@0) display]
"
"Consistency test...
 | f f2 p | [Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).
	Display fillBlack: (p extent: 31@41).
	f2 _ f rotateBy: #left centerAt: 0@0.
	(f2 rotateBy: #right centerAt: 0@0) displayAt: p]
"
! !

!Form methodsFor: 'scaling, rotation' stamp: 'ar 3/1/2006 23:04'!
rotateBy: deg magnify: scale smoothing: cellSize
	"Rotate the receiver by the indicated number of degrees and magnify. scale can be a Point to make for interesting 3D effects "
	"rot is the destination form, big enough for any angle."

	| side rot warp r1 pts p bigSide |
	side _ 1 + self extent r asInteger.
	bigSide _ (side asPoint * scale) rounded.
	rot := self blankCopyOf: self boundingBox scaledBy: ( bigSide / self extent ).
	warp _ (WarpBlt current toForm: rot)
		sourceForm: self;
		colorMap: (self colormapIfNeededFor: rot);
		cellSize: cellSize;  "installs a new colormap if cellSize > 1"
		combinationRule: Form paint.
	r1 _ (0@0 extent: side@side) align: (side@side)//2 with: self boundingBox center.

	"Rotate the corners of the source rectangle." 
	pts _ r1 innerCorners collect:
		[:pt | p _ pt - r1 center.
		(r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @
		(r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))].
	warp copyQuad: pts toRect: rot boundingBox.
	^ rot
"
 | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: (a _ a+5) magnify: 0.75@2 smoothing: 2) display].
f display
"! !

!Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 16:55'!
rotateBy: deg smoothing: cellSize
	"Rotate the receiver by the indicated number of degrees."
	^self rotateBy: deg magnify: 1 smoothing: cellSize
"
 | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: (a _ a+5) smoothing: 2) display].
f display
"! !

!Form methodsFor: 'scaling, rotation' stamp: 'RAA 7/13/2000 12:09'!
scaledToSize: newExtent

	| scale |

	newExtent = self extent ifTrue: [^self].
	scale _ newExtent x / self width min: newExtent y / self height.
	^self magnify: self boundingBox by: scale smoothing: 2.
! !

!Form methodsFor: 'scaling, rotation'!
shrink: aRectangle by: scale 
	| scalePt |
	scalePt _ scale asPoint.
	^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! !


!Form methodsFor: 'testing' stamp: 'ar 5/15/2001 16:14'!
hasNonStandardPalette
	"Return true if the receiver has a non-standard palette.
	Non-standard means that RGBA components may be located
	at positions differing from the standard Squeak RGBA layout
	at the receiver's depth."
	^false! !

!Form methodsFor: 'testing' stamp: 'di 3/2/98 12:42'!
isAllWhite
	"Answer whether all bits in the receiver are white (=0)."

	self unhibernate.
	1 to: bits size do: [:i | (bits at: i) = 0 ifFalse: [^ false]].
	^ true! !

!Form methodsFor: 'testing' stamp: 'ar 5/17/2001 15:46'!
isBigEndian
	"Return true if the receiver contains big endian pixels, meaning the left-most pixel is stored in the most significant bits of a word."
	^depth > 0! !

!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'!
isBltAccelerated: ruleInteger for: sourceForm
	"Return true if the receiver can perform accelerated blts operations by itself"
	^false! !

!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 15:04'!
isDisplayScreen
	^false! !

!Form methodsFor: 'testing' stamp: 'ar 5/27/2000 16:54'!
isExternalForm
	^false! !

!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'!
isFillAccelerated: ruleInteger for: aColor
	"Return true if the receiver can perform accelerated fill operations by itself"
	^false! !

!Form methodsFor: 'testing' stamp: 'ar 10/30/2000 23:23'!
isForm
	^true! !

!Form methodsFor: 'testing' stamp: 'ar 5/17/2001 15:47'!
isLittleEndian
	"Return true if the receiver contains little endian pixels, meaning the left-most pixel is stored in the least significant bits of a word."
	^depth < 0! !

!Form methodsFor: 'testing' stamp: 'RAA 8/14/2000 10:00'!
isStatic

	^false! !

!Form methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'!
isTranslucent
	"Answer whether this form may be translucent"
	^self depth = 32! !

!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'!
shouldPreserveContents
	"Return true if the receiver should preserve it's contents when flagged to be clean. Most forms can not be trivially restored by some drawing operation but some may."
	^true! !


!Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:42'!
fadeImageCoarse: otherImage at: topLeft
	"Display fadeImageCoarse: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	| pix j d |
	d _ self depth.
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		i=1 ifTrue: [pix _ (1 bitShift: d) - 1.
					1 to: 8//d-1 do: [:q | pix _ pix bitOr: (pix bitShift: d*4)]].
		i <= 16 ifTrue:
		[j _ i-1//4+1.
		(0 to: 28 by: 4) do: [:k |
			mask bits at: j+k
				put: ((mask bits at: j+k) bitOr: (pix bitShift: i-1\\4*d))].
		"mask display." true]
		ifFalse: [false]]! !

!Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:41'!
fadeImageFine: otherImage at: topLeft
	"Display fadeImageFine: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	| pix j ii d |
	d _ self depth.
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		i=1 ifTrue: [pix _ (1 bitShift: d) - 1.
					1 to: 8//d-1 do:
						[:q | pix _ pix bitOr: (pix bitShift: d*4)]].
		i <= 16 ifTrue:
		[ii _ #(0 10 2 8 7 13 5 15 1 11 3 9 6 12 4 14) at: i.
		j _ ii//4+1.
		(0 to: 28 by: 4) do:
			[:k | mask bits at: j+k put:
				((mask bits at: j+k) bitOr: (pix bitShift: ii\\4*d))].
		true]
		ifFalse: [false]]! !

!Form methodsFor: 'transitions'!
fadeImageHorFine: otherImage at: topLeft
	"Display fadeImageHorFine: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: (0@(i-1) extent: mask width@1) fillColor: Color black.
		mask fill: (0@(i-1+16) extent: mask width@1) fillColor: Color black.
		(i*2) <= mask width]! !

!Form methodsFor: 'transitions'!
fadeImageHor: otherImage at: topLeft
	"Display fadeImageHor: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: (0@(mask height//2-i) extent: mask width@(i*2)) fillColor: Color black.
		(i*2) <= mask width]! !

!Form methodsFor: 'transitions'!
fadeImageSquares: otherImage at: topLeft 
	"Display fadeImageSquares: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: ((16-i) asPoint extent: (i*2) asPoint) fillColor: Color black.
		i <= 16]! !

!Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:39'!
fadeImageVert: otherImage at: topLeft
	"Display fadeImageVert: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	| d |
	d _ self depth.
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: ((mask width//2//d-i*d)@0 extent: i*2*d@mask height) fillColor: Color black.
		i <= (mask width//d)]! !

!Form methodsFor: 'transitions' stamp: 'jm 5/21/1998 23:46'!
fadeImage: otherImage at: topLeft
	indexAndMaskDo: indexAndMaskBlock
	"This fade uses halftones as a blending hack.
	Zeros in the halftone produce the original image (self), and 
	ones in the halftone produce the 'otherImage'.
	IndexAndMaskBlock gets evaluated prior to each cycle,
	and the resulting boolean determines whether to continue cycling."
	| index imageRect maskForm resultForm |
	imageRect _ otherImage boundingBox.
	resultForm _ self copy: (topLeft extent: imageRect extent).
	maskForm _ Form extent: 32@32.
	index _ 0.
	[indexAndMaskBlock value: (index _ index+1) value: maskForm]
	whileTrue:
		[maskForm reverse.
		resultForm copyBits: imageRect from: resultForm at: 0@0
			clippingBox: imageRect rule: Form over fillColor: maskForm.
		maskForm reverse.
		resultForm copyBits: imageRect from: otherImage at: 0@0
			clippingBox: imageRect rule: Form under fillColor: maskForm.
		self copyBits: imageRect from: resultForm at: topLeft
				clippingBox: self boundingBox rule: Form over fillColor: nil.
		Display forceDisplayUpdate]! !

!Form methodsFor: 'transitions' stamp: 'jm 6/1/1998 10:55'!
pageImage: otherImage at: topLeft corner: corner
	"Produce a page-turning illusion that gradually reveals otherImage
	located at topLeft in this form.  Corner specifies which corner, as
		1=topLeft, 2=topRight, 3=bottomRight, 4=bottomLeft."
	| bb maskForm resultForm delta maskLoc maskRect stepSize cornerSel smallRect |
	stepSize _ 10.
	bb _ otherImage boundingBox.
	resultForm _ self copy: (topLeft extent: bb extent).
	maskForm _ Form extent: ((otherImage width min: otherImage height) + stepSize) asPoint.

	"maskLoc _ starting loc rel to topLeft"
	otherImage width > otherImage height
		ifTrue: ["wide image; motion is horizontal."
				(corner between: 2 and: 3) not ifTrue:
					["motion is to the right"
					delta _ 1@0.
					maskLoc _ bb topLeft - (corner = 1
						ifTrue: [maskForm width@0]
						ifFalse: [maskForm width@stepSize])]
					ifFalse:
					["motion is to the left"
					delta _ -1@0.
					maskLoc _ bb topRight - (corner = 2
						ifTrue: [0@0]
						ifFalse: [0@stepSize])]]
		ifFalse: ["tall image; motion is vertical."
				corner <= 2 ifTrue:
					["motion is downward"
					delta _ 0@1.
					maskLoc _ bb topLeft - (corner = 1
						ifTrue: [0@maskForm height]
						ifFalse: [stepSize@maskForm height])]
					ifFalse:
					["motion is upward"
					delta _ 0@-1.
					maskLoc _ bb bottomLeft - (corner = 3
						ifTrue: [stepSize@0]
						ifFalse: [0@0])]].

	"Build a solid triangle in the mask form"
	(Pen newOnForm: maskForm) in: [:p |
		corner even  "Draw 45-degree line"
			ifTrue: [p place: 0@0; turn: 135; go: maskForm width*3//2]
			ifFalse: [p place: 0@(maskForm height-1); turn: 45; go: maskForm width*3//2]].
	maskForm smear: delta negated distance: maskForm width.
	"Copy the mask to full resolution for speed.  Make it be the reversed
	so that it can be used for ORing in the page-corner color"
	maskForm _ (Form extent: maskForm extent depth: otherImage depth)
		copyBits: maskForm boundingBox from: maskForm at: 0@0
		colorMap: (Bitmap with: 16rFFFFFFFF with: 0).

	"Now move the triangle maskForm across the resultForm selecting the
	triangular part of otherImage to display, and across the resultForm,
	selecting the part of the original image to erase."
	cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: corner.
	1 to: (otherImage width + otherImage height // stepSize)+1 do:
		[:i |		"Determine the affected square"
		maskRect _ (maskLoc extent: maskForm extent) intersect: bb.
		((maskLoc x*delta x) + (maskLoc y*delta y)) < 0 ifTrue:
			[smallRect _ 0@0 extent: (maskRect width min: maskRect height) asPoint.
			maskRect _ smallRect align: (smallRect perform: cornerSel)
								with: (maskRect perform: cornerSel)].

		"AND otherForm with triangle mask, and OR into result"
		resultForm copyBits: bb from: otherImage at: 0@0
				clippingBox: maskRect rule: Form over fillColor: nil.
		resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc
				clippingBox: maskRect rule: Form erase fillColor: nil.
		resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc
				clippingBox: maskRect rule: Form under fillColor: Color lightBrown.

		"Now update Display in a single BLT."
		self copyBits: maskRect from: resultForm at: topLeft + maskRect topLeft
				clippingBox: self boundingBox rule: Form over fillColor: nil.
		Display forceDisplayUpdate.
		maskLoc _ maskLoc + (delta*stepSize)]
"
1 to: 4 do: [:corner | Display pageImage:
				(Form fromDisplay: (10@10 extent: 200@300)) reverse
			at: 10@10 corner: corner]
"
! !

!Form methodsFor: 'transitions' stamp: 'ar 5/28/2000 12:12'!
pageWarp: otherImage at: topLeft forward: forward
	"Produce a page-turning illusion that gradually reveals otherImage
	located at topLeft in this form.
	forward == true means turn pages toward you, else away. [ignored for now]"
	| pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d |
	pageRect _ otherImage boundingBox.
	oldPage _ self copy: (pageRect translateBy: topLeft).
	(forward ifTrue: [oldPage] ifFalse: [otherImage])
		border: pageRect
		widthRectangle: (Rectangle
				left: 0
				right: 2
				top: 1
				bottom: 1)
		rule: Form over
		fillColor: Color black.
	oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))).
	nSteps _ 8.
	buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth.
	d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight.
	1 to: nSteps-1 do:
		[:i | forward
			ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over.
					p _ pageRect topRight + (d * i // nSteps)]
			ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over.
					p _ pageRect topRight + (d * (nSteps-i) // nSteps)].
		buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over.
		leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y).
		sourceQuad _ Array with: pageRect topLeft
			with: pageRect bottomLeft + (0@p y)
			with: pageRect bottomRight
			with: pageRect topRight - (0@p y).
		warp _ (WarpBlt current toForm: buffer)
				clipRect: leafRect;
				sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]);
				combinationRule: Form paint.
		warp copyQuad: sourceQuad toRect: leafRect.
		self copy: buffer boundingBox from: buffer to: topLeft rule: Form over.
		Display forceDisplayUpdate].

	buffer copy: pageRect from: otherImage to: 0@0 rule: Form over.
	buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over.
	self copy: buffer boundingBox from: buffer to: topLeft rule: Form over.
	Display forceDisplayUpdate.
"
1 to: 4 do: [:corner | Display pageWarp:
				(Form fromDisplay: (10@10 extent: 200@300)) reverse
			at: 10@10 forward: false]
"
! !

!Form methodsFor: 'transitions' stamp: 'jm 5/21/1998 23:46'!
slideImage: otherImage at: topLeft delta: delta
	"Display slideImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse
		at: 40@40 delta: 3@-4"
	| bb nSteps clipRect |
	bb _ otherImage boundingBox.
	clipRect _ topLeft extent: otherImage extent.
	nSteps _ 1.
	delta x = 0 ifFalse: [nSteps _ nSteps max: (bb width//delta x abs) + 1].
	delta y = 0 ifFalse: [nSteps _ nSteps max: (bb height//delta y abs) + 1].
	1 to: nSteps do:
			[:i | self copyBits: bb from: otherImage
				at: delta*(i-nSteps) + topLeft
				clippingBox: clipRect rule: Form paint fillColor: nil.
			Display forceDisplayUpdate]! !

!Form methodsFor: 'transitions' stamp: 'jm 6/18/1998 12:57'!
wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex: rectForIndexBlock

	| i clipRect t rectOrList waitTime |
	i _ 0.
	clipRect _ topLeft extent: otherImage extent.
	clipBox ifNotNil: [clipRect _ clipRect intersect: clipBox].
	[rectOrList _ rectForIndexBlock value: (i _ i + 1).
	 rectOrList == nil]
		whileFalse: [
			t _ Time millisecondClockValue.
			rectOrList asOrderedCollection do: [:r |
				self copyBits: r from: otherImage at: topLeft + r topLeft
					clippingBox: clipRect rule: Form over fillColor: nil].
			Display forceDisplayUpdate.
			waitTime _ 3 - (Time millisecondClockValue - t).
			waitTime > 0 ifTrue:
				["(Delay forMilliseconds: waitTime) wait"]].
! !

!Form methodsFor: 'transitions' stamp: 'jm 10/16/97 15:21'!
wipeImage: otherImage at: topLeft delta: delta
	"Display wipeImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse
		at: 40@40 delta: 0@-2"

	self wipeImage: otherImage at: topLeft delta: delta clippingBox: nil.
! !

!Form methodsFor: 'transitions' stamp: 'jm 10/16/97 15:17'!
wipeImage: otherImage at: topLeft delta: delta clippingBox: clipBox

	| wipeRect bb nSteps |
	bb _ otherImage boundingBox.
	wipeRect _ delta x = 0
		ifTrue:
		[delta y = 0 ifTrue: [nSteps _ 1. bb "allow 0@0"] ifFalse: [
		nSteps _ bb height//delta y abs + 1.  "Vertical movement"
		delta y > 0
			ifTrue: [bb topLeft extent: bb width@delta y]
			ifFalse: [bb bottomLeft+delta extent: bb width@delta y negated]]]
		ifFalse:
		[nSteps _ bb width//delta x abs + 1.  "Horizontal movement"
		delta x > 0
			ifTrue: [bb topLeft extent: delta x@bb height]
			ifFalse: [bb topRight+delta extent: delta x negated@bb height]].
	^ self wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex:
		[:i | i <= nSteps
			ifTrue: [wipeRect translateBy: (delta* (i-1))]
			ifFalse: [nil]]! !

!Form methodsFor: 'transitions' stamp: 'di 3/2/98 09:14'!
zoomInTo: otherImage at: topLeft
	"Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self zoomIn: true orOutTo: otherImage at: topLeft
		vanishingPoint: otherImage extent//2+topLeft! !

!Form methodsFor: 'transitions' stamp: 'di 1/28/1999 09:20'!
zoomIn: goingIn orOutTo: otherImage at: topLeft vanishingPoint: vp 
	"Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40.
	Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40."
	| nSteps j bigR lilR minTime startTime lead |
	nSteps _ 16.
	minTime _ 500.  "milliseconds"
	startTime _ Time millisecondClockValue.
	^ self wipeImage: otherImage at: topLeft clippingBox: nil rectForIndex:
		[:i | "i runs from 1 to nsteps"
		i > nSteps
			ifTrue: [nil "indicates all done"]
			ifFalse:
			["If we are going too fast, delay for a bit"
			lead _ startTime + (i-1*minTime//nSteps) - Time millisecondClockValue.
			lead > 10 ifTrue: [(Delay forMilliseconds: lead) wait].

			"Return an array with the difference rectangles for this step."
			j _ goingIn ifTrue: [i] ifFalse: [nSteps+1-i].
			bigR _ vp - (vp*(j)//nSteps) corner:
				vp + (otherImage extent-vp*(j)//nSteps).
			lilR _ vp - (vp*(j-1)//nSteps) corner:
				vp + (otherImage extent-vp*(j-1)//nSteps).
			bigR areasOutside: lilR]]! !

!Form methodsFor: 'transitions' stamp: 'di 3/2/98 09:15'!
zoomOutTo: otherImage at: topLeft
	"Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self zoomIn: false orOutTo: otherImage at: topLeft
		vanishingPoint: otherImage extent//2+topLeft! !


!Form methodsFor: '*eToys-testing' stamp: 'RAA 1/19/2001 15:04'!
appearsToBeSameCostumeAs: anotherForm

	(anotherForm isKindOf: self class) ifFalse: [^false].
	anotherForm depth = self depth ifFalse: [^false].
	^anotherForm bits = bits
! !


!Form methodsFor: '*MorphicExtras-other' stamp: 'sw 5/3/2001 16:23'!
graphicForViewerTab
	"Answer the graphic to be used in the tab of a viewer open on me"

	^ self! !


!Form methodsFor: '*MorphicExtras-postscript generation' stamp: 'RAA 4/20/2001 15:40'!
encodePostscriptOn: aStream 
	self unhibernate.

	"since current Postscript support treats 8-bit forms as 0 to 255 gray scale, convert
	to 16 first so we get more faithful results"

	self depth <= 8 ifTrue: [^(self asFormOfDepth: 16) encodePostscriptOn: aStream].

	^ self printPostscript: aStream operator: (self depth = 1
			ifTrue: ['imagemask']
			ifFalse: ['image'])! !


!Form methodsFor: '*nebraska-encoding' stamp: 'RAA 7/29/2000 09:01'!
addDeltasFrom: previousForm

	(BitBlt 
		destForm: self 
		sourceForm: previousForm 
		fillColor: nil 
		combinationRule: Form reverse
		destOrigin: 0@0
		sourceOrigin: 0@0
		extent: self extent 
		clipRect: self boundingBox) copyBits.
	^self! !

!Form methodsFor: '*nebraska-encoding' stamp: 'sd 11/20/2005 21:25'!
deltaFrom: previousForm

	| newForm |
	newForm := previousForm deepCopy.
	(BitBlt 
		destForm: newForm 
		sourceForm: self 
		fillColor: nil 
		combinationRule: Form reverse 
		destOrigin: 0@0
		sourceOrigin: 0@0
		extent: self extent 
		clipRect: self boundingBox) copyBits.
	^newForm! !

!Form methodsFor: '*nebraska-encoding' stamp: 'sd 11/20/2005 21:25'!
deltaFrom: smallerForm at: offsetInMe

	| newForm |
	newForm := smallerForm deepCopy.
	(BitBlt 
		destForm: newForm 
		sourceForm: self 
		fillColor: nil 
		combinationRule: Form reverse 
		destOrigin: 0@0
		sourceOrigin: offsetInMe
		extent: smallerForm extent 
		clipRect: newForm boundingBox) copyBits.
	^newForm! !

!Form methodsFor: '*nebraska-encoding' stamp: 'RAA 8/13/2000 15:32'!
encodeForRemoteCanvas
	| header binaryForm |
	"encode into a bitstream for use with RemoteCanvas.  The format does not require invoking the Compiler"
	header := String streamContents: [ :str |
	str "nextPutAll: 'F|';"
		nextPutAll: self depth printString;
		nextPut: $,;
		nextPutAll: self width printString;
		nextPut: $,;
		nextPutAll: self height printString;
		nextPut: $|. ].

	binaryForm := ByteArray streamContents: [ :str |
		self unhibernate.
		bits writeOn: str. ].

	^header, binaryForm asString
! !


!Form methodsFor: 'private' stamp: 'tk 3/13/2000 15:21'!
hackBits: bitThing
	"This method provides an initialization so that BitBlt may be used, eg, to 
	copy ByteArrays and other non-pointer objects efficiently.
	The resulting form looks 4 wide, 8 deep, and bitThing-size-in-words high."
	width _ 4.
	depth _ 8.
	bitThing class isBits ifFalse: [self error: 'bitThing must be a non-pointer object'].
	bitThing class isBytes
		ifTrue: [height _ bitThing basicSize // 4]
		ifFalse: [height _ bitThing basicSize].
	bits _ bitThing! !

!Form methodsFor: 'private'!
initFromArray: array
	"Fill the bitmap from array.  If the array is shorter,
	then cycle around in its contents until the bitmap is filled."
	| ax aSize array32 i j word16 |
	ax _ 0.
	aSize _ array size.
	aSize > bits size ifTrue:
		["backward compatibility with old 16-bit bitmaps and their forms"
		array32 _ Array new: height * (width + 31 // 32).
		i _ j _ 0.
		1 to: height do:
			[:y | 1 to: width+15//16 do:
				[:x16 | word16 _ array at: (i _ i + 1).
				x16 odd ifTrue: [array32 at: (j _ j+1) put: (word16 bitShift: 16)]
						ifFalse: [array32 at: j put: ((array32 at: j) bitOr: word16)]]].
		^ self initFromArray: array32].
	1 to: bits size do:
		[:index |
		(ax _ ax + 1) > aSize ifTrue: [ax _ 1].
		bits at: index put: (array at: ax)]! !

!Form methodsFor: 'private' stamp: 'ar 12/19/2000 16:23'!
privateFloodFillValue: aColor
	"Private. Compute the pixel value in the receiver's depth but take into account implicit color conversions by BitBlt."
	| f1 f2 bb |
	f1 _ Form extent: 1@1 depth: depth.
	f2 _ Form extent: 1@1 depth: 32.
	bb _ BitBlt toForm: f1.
	bb fillColor: aColor; 
		destRect: (0@0 corner: 1@1); 
		combinationRule: 3; 
		copyBits.
	bb _ BitBlt toForm: f2.
	bb sourceForm: f1; 
		sourceOrigin: 0@0;
		destRect: (0@0 corner: 1@1);
		combinationRule: 3;
		copyBits.
	^f2 pixelValueAt: 0@0.! !

!Form methodsFor: 'private' stamp: '6/9/97 16:10 di'!
setExtent: extent depth: bitsPerPixel
	"Create a virtual bit map with the given extent and bitsPerPixel."

	width _ extent x asInteger.
	width < 0 ifTrue: [width _ 0].
	height _ extent y asInteger.
	height < 0 ifTrue: [height _ 0].
	depth _ bitsPerPixel.
	bits _ Bitmap new: self bitsSize! !

!Form methodsFor: 'private' stamp: 'ar 5/28/2000 15:49'!
setExtent: extent depth: bitsPerPixel bits: bitmap
	"Create a virtual bit map with the given extent and bitsPerPixel."

	width _ extent x asInteger.
	width < 0 ifTrue: [width _ 0].
	height _ extent y asInteger.
	height < 0 ifTrue: [height _ 0].
	depth _ bitsPerPixel.
	(bits isNil or:[self bitsSize = bitmap size]) ifFalse:[^self error:'Bad dimensions'].
	bits _ bitmap! !

!Form methodsFor: 'private' stamp: 'ar 10/30/2000 23:22'!
setResourceBits: aForm
	"Private. Really. Used for setting the 'resource bits' when externalizing some form"
	bits _ aForm.! !



!Form methodsFor: '*Morphic' stamp: 'ar 7/8/2006 21:01'!
iconOrThumbnailOfSize: aNumberOrPoint 
	"Answer an appropiate form to represent the receiver"
	^ self scaledIntoFormOfSize: aNumberOrPoint! !

!Form methodsFor: '*Morphic' stamp: 'ar 7/8/2006 21:01'!
scaledIntoFormOfSize: aNumberOrPoint 
	"Scale and center the receiver into a form of a given size"

	| extent scale scaledForm result |

	extent := aNumberOrPoint asPoint.
	extent = self extent ifTrue: [^ self].

	(self height isZero or: [self width isZero])
		ifTrue: [^ Form extent: extent depth: self depth].

	scale := extent y / self height min: extent x / self width.
	scaledForm := self
				magnify: self boundingBox
				by: scale
				smoothing: 8.

	result := Form extent: extent depth: 32.
	result getCanvas
		translucentImage: scaledForm
		at: extent - scaledForm extent // 2.

	^ result
! !

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

Form class
	instanceVariableNames: ''!

!Form class methodsFor: 'BMP file reading' stamp: 'ar 6/16/2002 17:41'!
fromBMPFile: aBinaryStream
	"Obsolete"
	^self fromBinaryStream: aBinaryStream.! !

!Form class methodsFor: 'BMP file reading' stamp: 'ar 6/16/2002 17:41'!
fromBMPFileNamed: fileName
	"Obsolete"
	^self fromFileNamed: fileName
! !


!Form class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !


!Form class methodsFor: 'examples'!
exampleBorder    "Form exampleBorder"
	"This example demonstrates the border finding algorithm. Start
	by having the user sketch on the screen (end with option-click) and then select a rectangular
	area of the screen which includes all of the area to be filled. Finally,
	(with crosshair cursor), the user points at the interior of the region to be
	outlined, and the region begins with that place as its seed."
	| f r interiorPoint |
	Form exampleSketch.		"sketch a little area with an enclosed region"
	r _ Rectangle fromUser.
	f _ Form fromDisplay: r.
	Cursor crossHair showWhile:
		[interiorPoint _ Sensor waitButton - r origin].
	Cursor execute showWhile:
		[f shapeBorder: Color blue width: 2 interiorPoint: interiorPoint
			sharpCorners: false internal: false].
	f displayOn: Display at: r origin	! !

!Form class methodsFor: 'examples'!
exampleEdits
	"In Form category editing are messages edit and bitEdit that make it possible to 
	create editors on instances of Form. 
	 
	This is the general form editor:
	| f | 
	f _ Form fromUser. 
	f edit. 
	 
	This is the general bit editor:
	| f | 
	f _ Form fromUser. 
	f bitEdit."! !

!Form class methodsFor: 'examples'!
exampleMagnify

	| f m |
	f _ Form fromUser.
	m _ f magnify: f boundingBox by: 5 @ 5.
	m displayOn: Display at: Sensor waitButton

	"Form exampleMagnify."! !

!Form class methodsFor: 'examples'!
exampleShrink

	| f s |
	f _ Form fromUser.
	s _ f shrink: f boundingBox by: 2 @ 5.
	s displayOn: Display at: Sensor waitButton	

	"Form exampleShrink."! !

!Form class methodsFor: 'examples'!
exampleSketch
	"This is a simple drawing algorithm to get a sketch on the display screen.
	Draws whenever mouse button down.  Ends with option-click."
	| aPen color |
	aPen _ Pen new.
	color _ 0.
	[Sensor yellowButtonPressed]
		whileFalse:
		[aPen place: Sensor cursorPoint; color: (color _ color + 1).
		[Sensor redButtonPressed]
			whileTrue: [aPen goto: Sensor cursorPoint]].
	Sensor waitNoButton.

	"Form exampleSketch"! !

!Form class methodsFor: 'examples'!
exampleSpaceFill    "Form exampleSpaceFill"
	"This example demonstrates the area filling algorithm. Starts by having
	the user sketch on the screen (ended by option-click) and then select a rectangular
	area of the screen which includes all of the area to be filled. Finally,
	(with crosshair cursor), the user points at the interior of some region to be
	filled, and the filling begins with that place as its seed."
	| f r interiorPoint |
	Form exampleSketch.		"sketch a little area with an enclosed region"
	r _ Rectangle fromUser.
	f _ Form fromDisplay: r.
	Cursor crossHair showWhile:
		[interiorPoint _ Sensor waitButton - r origin].
	Cursor execute showWhile:
		[f shapeFill: Color gray interiorPoint: interiorPoint].
	f displayOn: Display at: r origin	! !

!Form class methodsFor: 'examples'!
makeStar  "See the similar example in OpaqueForm"
	| sampleForm pen |
	sampleForm _ Form extent: 50@50.  "Make a form"
	pen _ Pen newOnForm: sampleForm.
	pen place: 24@50; turn: 18.		"Draw a 5-pointed star on it."
	1 to: 5 do: [:i | pen go: 19; turn: 72; go: 19; turn: -144].
	^ sampleForm
"
Form makeStar follow: [Sensor cursorPoint]
				while: [Sensor noButtonPressed]
"! !

!Form class methodsFor: 'examples' stamp: 'tk 7/4/2000 12:08'!
toothpaste: diam		"Display restoreAfter: [Form toothpaste: 30]"
	"Draws wormlike lines by laying down images of spheres.
	See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352.
	Draw with mouse button down; terminate by option-click."
	| facade ball filter point queue port color q colors colr colr2 |
	colors _ Display depth = 1
		ifTrue: [Array with: Color black]
		ifFalse: [Color red wheel: 12].
	facade _ Form extent: diam@diam offset: (diam//-2) asPoint.
	(Form dotOfSize: diam) displayOn: facade
			at: (diam//2) asPoint clippingBox: facade boundingBox
			rule: Form under fillColor: Color white.
	#(1 2 3) do:
		[:x |  "simulate facade by circles of gray"
		(Form dotOfSize: x*diam//5) displayOn: facade
			at: (diam*2//5) asPoint clippingBox: facade boundingBox
			rule: Form under
			fillColor: (Color perform: 
					(#(black gray lightGray) at: x)).
		"facade displayAt: 50*x@50"].
	ball _ Form dotOfSize: diam.
	color _ 8.
	[ true ] whileTrue:
		[port _ BitBlt current toForm: Display.
		"Expand 1-bit forms to any pixel depth"
		port colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
		queue _ OrderedCollection new: 32.
		16 timesRepeat: [queue addLast: -20@-20].
		Sensor waitButton.
		Sensor yellowButtonPressed ifTrue: [^ self].
		filter _ Sensor cursorPoint.
		colr _ colors atWrap: (color _ color + 5).  "choose increment relatively prime to colors size"
		colr2 _ colr alphaMixed: 0.3 with: Color white.
		[Sensor redButtonPressed or: [queue size > 0]] whileTrue:
			[filter _ filter * 4 + Sensor cursorPoint // 5.
			point _ Sensor redButtonPressed
				ifTrue: [filter] ifFalse: [-20@-20].
			port copyForm: ball to: point rule: Form paint fillColor: colr.
			(q _ queue removeFirst) == nil ifTrue: [^ self].	"exit"
			Display depth = 1
				ifTrue: [port copyForm: facade to: q rule: Form erase]
				ifFalse: [port copyForm: facade to: q rule: Form paint fillColor: colr2].
			Sensor redButtonPressed ifTrue: [queue addLast: point]]].
! !

!Form class methodsFor: 'examples'!
xorHack: size  "Display restoreAfter: [Form xorHack: 256]"
	"Draw a smiley face or stick figure, and end with option-click.
	Thereafter image gets 'processed' as long as you have button down.
	If you stop at just the right time, you'll see you figure upside down,
	and at the end of a full cycle, you'll see it perfectly restored.
	Dude -- this works in color too!!"
	| rect form i bb |
	rect _ 5@5 extent: size@size.
	Display fillWhite: rect; border: (rect expandBy: 2) width: 2.
	Display border: (rect topRight - (0@2) extent: rect extent*2 + 4) width: 2.
	Form exampleSketch.
	form _ Form fromDisplay: rect.
	bb _ form boundingBox.
	i _ 0.
	[Sensor yellowButtonPressed] whileFalse:
		[[Sensor redButtonPressed] whileTrue:
			[i _ i + 1.
			(Array with: 0@1 with: 0@-1 with: 1@0 with: -1@0) do:
				[:d | form copyBits: bb from: form at: d
					clippingBox: bb rule: Form reverse fillColor: nil].
			form displayAt: rect topLeft.
			i+2\\size < 4 ifTrue: [(Delay forMilliseconds: 300) wait]].
		(form magnify: form boundingBox by: 2@2) displayAt: rect topRight + (2@0).
		Sensor waitButton].! !


!Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 12:56'!
fileReaderServicesForDirectory: aFileDirectory
	^{
		self serviceImageImportDirectory.
		self serviceImageImportDirectoryWithSubdirectories.
	}! !

!Form class methodsFor: 'file list services' stamp: 'nk 7/16/2003 18:01'!
fileReaderServicesForFile: fullName suffix: suffix

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

!Form class methodsFor: 'file list services' stamp: 'hg 8/3/2000 16:26'!
openAsBackground: fullName
	"Set an image as a background image.  Support Squeak's common file format 
	(GIF, JPG, PNG, 'Form stoteOn: (run coded)' and BMP)"

	(self fromFileNamed: fullName) setAsBackground! !

!Form class methodsFor: 'file list services' stamp: 'nk 1/6/2004 12:36'!
openImageInWindow: fullName
	"Handle five file formats: GIF, JPG, PNG, Form storeOn: (run coded), and BMP.
	Fail if file format is not recognized."

	| image myStream |

	myStream _ (FileStream readOnlyFileNamed: fullName) binary.
	image _ self fromBinaryStream: myStream.
	myStream close.

	Smalltalk isMorphic ifTrue:[
		Project current resourceManager 
			addResource: image 
			url: (FileDirectory urlForFileNamed: fullName) asString.
	].

	Smalltalk isMorphic
		ifTrue: [(World drawingClass withForm: image) openInWorld]
		ifFalse: [FormView open: image named: fullName]! !

!Form class methodsFor: 'file list services' stamp: 'sw 2/17/2002 01:38'!
serviceImageAsBackground
	"Answer a service for setting the desktop background from a given graphical file's contents"

	^ SimpleServiceEntry 
		provider: self 
		label: 'use graphic as background'
		selector: #openAsBackground:
		description: 'use the graphic as the background for the desktop'
		buttonLabel: 'background'! !

!Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 13:16'!
serviceImageImportDirectory
	"Answer a service for reading a graphic into ImageImports"

	^(SimpleServiceEntry
			provider: self 
			label: 'import all images from this directory'
			selector: #importImageDirectory:
			description: 'Load all graphics found in this directory, adding them to the ImageImports repository.'
			buttonLabel: 'import dir')
			argumentGetter: [ :fileList | fileList directory ];
			yourself
! !

!Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 13:15'!
serviceImageImportDirectoryWithSubdirectories
	"Answer a service for reading all graphics from a directory and its subdirectories into ImageImports"

	^(SimpleServiceEntry
			provider: self 
			label: 'import all images from here and subdirectories'
			selector: #importImageDirectoryWithSubdirectories:
			description: 'Load all graphics found in this directory and its subdirectories, adding them to the ImageImports repository.'
			buttonLabel: 'import subdirs')
			argumentGetter: [ :fileList | fileList directory ];
			yourself
! !

!Form class methodsFor: 'file list services' stamp: 'sw 2/17/2002 01:39'!
serviceImageImports
	"Answer a service for reading a graphic into ImageImports"

	^	SimpleServiceEntry
			provider: self 
			label: 'read graphic into ImageImports'
			selector: #importImage:
			description: 'Load a graphic, placing it in the ImageImports repository.'
			buttonLabel: 'import'! !

!Form class methodsFor: 'file list services' stamp: 'sw 2/17/2002 00:31'!
serviceOpenImageInWindow
	"Answer a service for opening a graphic in a window"

	^ SimpleServiceEntry 
		provider: self 
		label: 'open graphic in a window'
		selector: #openImageInWindow:
		description: 'open a graphic file in a window'
		buttonLabel: 'open'! !

!Form class methodsFor: 'file list services' stamp: 'sd 2/1/2002 21:43'!
services

	^ Array 
		with: self serviceImageImports
		with: self serviceOpenImageInWindow
		with: self serviceImageAsBackground ! !


!Form class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 12:47'!
importImage: fullName
	"Import the given image file and store the resulting Form in the default Imports.
	The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique."

	Imports default importImageFromFileNamed: fullName.
! !

!Form class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 13:08'!
importImageDirectory: dir
	"Import the given image file and store the resulting Form in the default Imports.
	The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique."

	Imports default importImageDirectory: dir
! !

!Form class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 12:55'!
importImageDirectoryWithSubdirectories: dir
	"Import the given image file and store the resulting Form in the default Imports.
	The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique."

	Imports default importImageDirectoryWithSubdirectories: dir
! !


!Form class methodsFor: 'initialize-release' stamp: 'hg 8/3/2000 16:25'!
initialize

	FileList registerFileReader: self! !


!Form class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:07'!
dotOfSize: diameter
	"Create a form which contains a round black dot."
	| radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx |
	radius _ diameter//2.
	form _ self extent: diameter@diameter offset: (0@0) - (radius@radius).	
	bb _ (BitBlt current toForm: form)
		sourceX: 0; sourceY: 0;
		combinationRule: Form over;
		fillColor: Color black.
	rect _ form boundingBox.
	centerX _ rect center x.
	centerY _ rect center y.
	centerYBias _ rect height odd ifTrue: [0] ifFalse: [1].
	centerXBias _ rect width odd ifTrue: [0] ifFalse: [1].
	radiusSquared _ (rect height asFloat / 2.0) squared - 0.01.
	xOverY _ rect width asFloat / rect height asFloat.
	maxy _ rect height - 1 // 2.

	"First do the inner fill, and collect x values"
	0 to: maxy do:
		[:dy |
		dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated.
		bb	destX: centerX - centerXBias - dx
			destY: centerY - centerYBias - dy
			width: dx + dx + centerXBias + 1
			height: 1;
			copyBits.
		bb	destY: centerY + dy;
			copyBits].
	^ form
"
Time millisecondsToRun:
	[1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]]
"! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:27'!
extent: extentPoint
	"Answer an instance of me with a blank bitmap of depth 1."

	^ self extent: extentPoint depth: 1
! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:36'!
extent: extentPoint depth: bitsPerPixel
	"Answer an instance of me with blank bitmap of the given dimensions and depth."

	^ self basicNew setExtent: extentPoint depth: bitsPerPixel
! !

!Form class methodsFor: 'instance creation' stamp: 'ar 10/9/1998 23:44'!
extent: extentPoint depth: bitsPerPixel bits: aBitmap
	"Answer an instance of me with blank bitmap of the given dimensions and depth."

	^ self basicNew setExtent: extentPoint depth: bitsPerPixel bits: aBitmap! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:35'!
extent: extentPoint depth: bitsPerPixel fromArray: anArray offset: offsetPoint 
	"Answer an instance of me with a pixmap of the given depth initialized from anArray."

	^ (self extent: extentPoint depth: bitsPerPixel)
		offset: offsetPoint;
		initFromArray: anArray
! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:33'!
extent: extentPoint fromArray: anArray offset: offsetPoint 
	"Answer an instance of me of depth 1 with bitmap initialized from anArray."

	^ (self extent: extentPoint depth: 1)
		offset: offsetPoint;
		initFromArray: anArray
! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:28'!
extent: extentPoint fromStipple: fourNibbles
	"Answer an instance of me with bitmap initialized from
	a repeating 4x4 bit stipple encoded in a 16-bit constant."
	| nibble |
	^ (self extent: extentPoint depth: 1)
		initFromArray: ((1 to: 4) collect:
				[:i | nibble _ (fourNibbles bitShift: -4*(4-i)) bitAnd: 16rF.
				16r11111111 * nibble])  "fill 32 bits with each 4-bit nibble"
! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:26'!
extent: extentPoint offset: offsetPoint 
	"Answer an instance of me with a blank bitmap of depth 1."

	^ (self extent: extentPoint depth: 1) offset: offsetPoint
! !

!Form class methodsFor: 'instance creation' stamp: 'nk 7/7/2003 18:19'!
fromBinaryStream: aBinaryStream
	"Read a Form or ColorForm from given file, using the first byte of the file to guess its format. Currently handles: GIF, uncompressed BMP, and both old and new DisplayObject writeOn: formats, JPEG, and PCX. Return nil if the file could not be read or was of an unrecognized format."

	| firstByte |
	aBinaryStream binary.
	firstByte _ aBinaryStream next.
	firstByte = 1 ifTrue: [
		"old Squeakform format"
		^ self new readFromOldFormat: aBinaryStream].
	firstByte = 2 ifTrue: [
		"new Squeak form format"
		^ self new readFrom: aBinaryStream].

	"Try for JPG, GIF, or PCX..."
	"Note: The following call closes the stream."
	^ ImageReadWriter formFromStream: aBinaryStream
! !

!Form class methodsFor: 'instance creation'!
fromDisplay: aRectangle 
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen defined by aRectangle."

	^ (self extent: aRectangle extent depth: Display depth)
		fromDisplay: aRectangle! !

!Form class methodsFor: 'instance creation'!
fromDisplay: aRectangle using: oldForm
	"Like fromDisplay: only if oldForm is the right size, copy into it and answer it instead."

	((oldForm ~~ nil) and: [oldForm extent = aRectangle extent])
		ifTrue:
			[oldForm fromDisplay: aRectangle.
			 ^ oldForm]
		ifFalse:
			[^ self fromDisplay: aRectangle]! !

!Form class methodsFor: 'instance creation' stamp: 'mir 11/19/2001 14:13'!
fromFileNamed: fileName
	"Read a Form or ColorForm from the given file."

	| file form |
	file _ (FileStream readOnlyFileNamed: fileName) binary.
	form _ self fromBinaryStream: file.
	Smalltalk isMorphic ifTrue:[
		Project current resourceManager
			addResource: form
			url: (FileDirectory urlForFileNamed: file name) asString].
	file close.
	^ form
! !

!Form class methodsFor: 'instance creation'!
fromUser
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen designated by the user. The grid for selecting an area is 
	1@1."

	^self fromUser: 1 @ 1! !

!Form class methodsFor: 'instance creation' stamp: 'ar 3/1/2006 22:50'!
fromUser: gridPoint
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen designated by the user. The grid for selecting an area is 
	aPoint. Ensures that the returned form has positive extent."
	| rect |
	rect := Rectangle fromUser: gridPoint.
	^ self fromDisplay: (rect origin extent: (rect extent max: gridPoint))! !

!Form class methodsFor: 'instance creation' stamp: 'jm 12/5/97 19:32'!
fromUserWithExtent: anExtent
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen whose origin is designated by the user and whose size is anExtent"

	^ self fromDisplay: (Rectangle originFromUser: anExtent)

"(Form fromUserWithExtent: 50@50) displayAt: 10@10"! !


!Form class methodsFor: 'mode constants'!
and
	"Answer the integer denoting the logical 'and' combination rule."

	^1! !

!Form class methodsFor: 'mode constants'!
blend
	"Answer the integer denoting BitBlt's alpha blend combination rule."
	^24! !

!Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'!
blendAlpha
	"Answer the integer denoting BitBlt's blend-with-constant-alpha rule."

	^ 30! !

!Form class methodsFor: 'mode constants'!
erase
	"Answer the integer denoting mode erase."

	^4! !

!Form class methodsFor: 'mode constants'!
erase1bitShape
	"Answer the integer denoting mode erase."

	^ 26! !

!Form class methodsFor: 'mode constants'!
oldErase1bitShape
	"Answer the integer denoting mode erase."

	^ 17! !

!Form class methodsFor: 'mode constants'!
oldPaint
	"Answer the integer denoting the 'paint' combination rule."

	^16! !

!Form class methodsFor: 'mode constants'!
over
	"Answer the integer denoting mode over."

	^3! !

!Form class methodsFor: 'mode constants'!
paint
	"Answer the integer denoting the 'paint' combination rule."

	^25! !

!Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'!
paintAlpha
	"Answer the integer denoting BitBlt's paint-with-constant-alpha rule."

	^ 31! !

!Form class methodsFor: 'mode constants'!
reverse
	"Answer the integer denoting mode reverse."

	^6! !

!Form class methodsFor: 'mode constants' stamp: 'hg 1/29/2001 17:28'!
rgbMul
	"Answer the integer denoting 'Multiply each color component, 
	 their values regarded as fractions of 1' rule."

	^ 37! !

!Form class methodsFor: 'mode constants'!
under
	"Answer the integer denoting mode under."

	^7! !


!Form class methodsFor: 'shut down' stamp: 'ar 5/28/2000 23:35'!
shutDown  "Form shutDown"
	"Compress all instances in the system.  Will decompress on demand..."
	Form allInstancesDo: [:f | f hibernate].
	ColorForm allInstancesDo: [:f | f hibernate].! !
Object subclass: #FormButtonCache
	instanceVariableNames: 'offset form value initialState'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Editors'!
!FormButtonCache commentStamp: '<historical>' prior: 0!
My instances are used to save information needed to construct the switch in a menu for a FormEditor. A collection of my instances is stored as a class variable of FormMenuView.!


!FormButtonCache methodsFor: 'accessing'!
form
	"Answer the receiver's form, the image of the button on the screen."

	^form! !

!FormButtonCache methodsFor: 'accessing'!
form: aForm
	"Set the receiver's form to be the argument."

	form _ aForm! !

!FormButtonCache methodsFor: 'accessing'!
initialState
	"Answer the receiver's initial state, on or off."

	^initialState! !

!FormButtonCache methodsFor: 'accessing'!
initialState: aBoolean
	"Set the receiver's initial state, on or off, to be the argument."

	initialState _ aBoolean! !

!FormButtonCache methodsFor: 'accessing'!
offset
	"Answer the receiver's offset, its relative position for displaying the 
	button."

	^offset! !

!FormButtonCache methodsFor: 'accessing'!
offset: anInteger
	"Set the receiver's offset."

	offset _ anInteger! !

!FormButtonCache methodsFor: 'accessing'!
value
	"Answer the receiver's value, the keyboard key that selects the button."

	^value! !

!FormButtonCache methodsFor: 'accessing'!
value: aCharacter
	"Set the receiver's key character."

	value _ aCharacter! !
Canvas subclass: #FormCanvas
	instanceVariableNames: 'origin clipRect form port shadowColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!FormCanvas commentStamp: '<historical>' prior: 0!
Note that when shadowDrawing is true, shadowStipple may be either a color, for a solid shadow of the given color, or it may be a stipple used to simulate gray shading when the display cannot support alpha blending.!


!FormCanvas methodsFor: 'accessing' stamp: 'ar 5/28/2000 17:11'!
allocateForm: extentPoint
	"Allocate a new form which is similar to the receiver"
	^form allocateForm: extentPoint! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:06'!
clipRect
	"Return the currently active clipping rectangle"
	^ clipRect translateBy: origin negated! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 12/31/2001 03:26'!
contentsOfArea: aRectangle into: aForm
	| bb |
	self flush.
	bb _ BitBlt toForm: aForm.
	bb sourceForm: form; combinationRule: Form over;
		sourceX: (aRectangle left + origin x); sourceY: (aRectangle top + origin y);
		width: aRectangle width; height: aRectangle height;
		copyBits.
	^aForm! !

!FormCanvas methodsFor: 'accessing'!
depth

	^ form depth
! !

!FormCanvas methodsFor: 'accessing'!
extent

	^ form extent! !

!FormCanvas methodsFor: 'accessing'!
form

	^ form! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:10'!
origin
	"Return the current origin for drawing operations"
	^ origin! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 00:26'!
shadowColor
	^shadowColor! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 00:26'!
shadowColor: aColor
	shadowColor _ aColor! !


!FormCanvas methodsFor: 'converting' stamp: 'ar 2/17/2000 00:17'!
asShadowDrawingCanvas
	"Note: This is sort of an optimization here since since the logic is all there"
	^self copy shadowColor: (Color black alpha: 0.5)! !

!FormCanvas methodsFor: 'converting' stamp: 'ar 2/17/2000 00:16'!
asShadowDrawingCanvas: aColor
	"Note: This is sort of an optimization here since since the logic is all there"
	^self copy shadowColor: aColor! !


!FormCanvas methodsFor: 'copying' stamp: 'jm 8/2/97 14:00'!
copy
	"Make a copy the receiver on the same underlying Form but with its own grafPort."

	^ self clone resetGrafPort
! !

!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:51'!
copyClipRect: aRectangle
	^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin)
! !

!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'!
copyOffset: aPoint
	^ self copyOrigin: origin + aPoint clipRect: clipRect! !

!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'!
copyOffset: aPoint clipRect: sourceClip
	"Make a copy of me offset by aPoint, and further clipped
	by sourceClip, a rectangle in the un-offset coordinates"
	^ self copyOrigin: aPoint + origin
		clipRect: ((sourceClip translateBy: origin) intersect: clipRect)! !

!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'!
copyOrigin: aPoint clipRect: aRectangle
	"Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed."
	^ self copy
		setOrigin: aPoint
		clipRect: (clipRect intersect: aRectangle)! !


!FormCanvas methodsFor: 'drawing' stamp: 'ar 5/14/2000 15:50'!
fillColor: c
	"Note: This always fills, even if the color is transparent."
	self setClearColor: c.
	port fillRect: form boundingBox offset: origin.! !

!FormCanvas methodsFor: 'drawing' stamp: 'ar 5/14/2001 23:34'!
line: pt1 to: pt2 brushForm: brush
	| offset |
	offset _ origin.
	self setPaintColor: Color black.
	port sourceForm: brush; fillColor: nil;
		sourceRect: brush boundingBox;
		colorMap: (brush colormapIfNeededFor: form);
		drawFrom: (pt1 + offset) to: (pt2 + offset)! !

!FormCanvas methodsFor: 'drawing' stamp: 'ar 2/16/2000 22:07'!
line: pt1 to: pt2 width: w color: c
	| offset |
	offset _ origin - (w // 2) asPoint.
	self setFillColor: c.
	port width: w; height: w;
		drawFrom: (pt1 + offset) to: (pt2 + offset)! !

!FormCanvas methodsFor: 'drawing' stamp: 'yo 1/23/2003 17:50'!
paragraph3: para bounds: bounds color: c

	| scanner |
	self setPaintColor: c.
	scanner _ (port clippedBy: (bounds translateBy: origin)) displayScannerForMulti: para
		foreground: (self shadowColor ifNil:[c]) background: Color transparent
		ignoreColorChanges: self shadowColor notNil.
	para displayOnTest: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft.
! !

!FormCanvas methodsFor: 'drawing' stamp: 'di 9/12/2001 21:38'!
paragraph: para bounds: bounds color: c

	| scanner |
	self setPaintColor: c.
	scanner _ (port clippedBy: (bounds translateBy: origin)) displayScannerFor: para
		foreground: (self shadowColor ifNil:[c]) background: Color transparent
		ignoreColorChanges: self shadowColor notNil.
	para displayOn: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft.
! !

!FormCanvas methodsFor: 'drawing'!
point: pt color: c

	form colorAt: (pt + origin) put: c.! !

!FormCanvas methodsFor: 'drawing' stamp: 'ar 9/9/2000 22:18'!
render: anObject
	"Do some 3D operations with the object if possible"
	^self asBalloonCanvas render: anObject! !


!FormCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:58'!
roundCornersOf: aMorph in: bounds during: aBlock
	aMorph wantsRoundedCorners ifFalse:[^aBlock value].
	(self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds))
		ifTrue: ["Don't bother with corner logic if the region is inside them"
				^ aBlock value].
	CornerRounder roundCornersOf: aMorph on: self in: bounds
		displayBlock: aBlock
		borderWidth: aMorph borderWidthForRounding
		corners: aMorph roundedCorners! !


!FormCanvas methodsFor: 'drawing-images' stamp: 'tpr 9/15/2004 10:27'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	self setPaintColor: aColor.
	port colorMap: stencilForm maskingMap.
	port stencil: stencilForm
		at: aPoint + origin
		sourceRect: sourceRect.! !

!FormCanvas methodsFor: 'drawing-images' stamp: 'ar 12/30/2001 16:36'!
warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize
	"Warp the given using the appropriate transform and offset."
	| tfm |
	tfm _ (MatrixTransform2x3 withOffset: origin) composedWithLocal: aTransform.
	^self privateWarp: aForm transform: tfm at: extraOffset sourceRect: sourceRect cellSize: cellSize! !


!FormCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 15:21'!
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc

	self asBalloonCanvas
		fillOval: aRectangle
		fillStyle: aFillStyle
		borderWidth: bw
		borderColor: bc! !

!FormCanvas methodsFor: 'drawing-ovals' stamp: 'di 5/25/2001 01:40'!
fillOval: r color: fillColor borderWidth: borderWidth borderColor: borderColor
	| rect |
	"draw the border of the oval"
	rect _ (r translateBy: origin) truncated.
	(borderWidth = 0 or: [borderColor isTransparent]) ifFalse:[
		self setFillColor: borderColor.
		(r area > 10000 or: [fillColor isTranslucent]) 
			ifTrue: [port frameOval: rect borderWidth: borderWidth]
			ifFalse: [port fillOval: rect]]. "faster this way"
	"fill the inside"
	fillColor isTransparent ifFalse:
		[self setFillColor: fillColor.
		port fillOval: (rect insetBy: borderWidth)].
! !

!FormCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 16:42'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval."

	self flag: #bob.		"this and its siblings could be moved up to Canvas with the
						right #balloonFillOval:..."

	self shadowColor ifNotNil:
		[^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
	(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
		self flag: #fixThis.
		^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc].
	(aFillStyle isSolidFill) ifTrue:[
		^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
	"Use a BalloonCanvas instead"
	self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! !


!FormCanvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:57'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Generalize for the BalloonCanvas"
	^self drawPolygon: vertices fillStyle: aColor borderWidth: bw borderColor: bc! !

!FormCanvas methodsFor: 'drawing-polygons' stamp: 'ar 12/6/2000 14:59'!
drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Use a BalloonCanvas"
	self asBalloonCanvas 
		drawPolygon: vertices asArray
		fillStyle: (self shadowColor ifNil:[aFillStyle])
		borderWidth: bw 
		borderColor: bc! !


!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'RAA 7/28/2000 07:39'!
balloonFillRectangle: aRectangle fillStyle: aFillStyle

	self asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle.! !

!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 10/26/2000 19:26'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle."
	| pattern |
	self shadowColor ifNotNil:
		[^self fillRectangle: aRectangle color: aFillStyle asColor].

	(aFillStyle isKindOf: InfiniteForm) ifTrue: [
		^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	].

	(aFillStyle isSolidFill) 
		ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor].
	"We have a very special case for filling with infinite forms"
	(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
		pattern _ aFillStyle form.
		(aFillStyle direction = (pattern width @ 0) 
			and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
				"Can use an InfiniteForm"
				^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
	].
	"Use a BalloonCanvas instead"
	self balloonFillRectangle: aRectangle fillStyle: aFillStyle.! !

!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 5/14/2000 15:50'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	| rect |
	rect _ r translateBy: origin.
	"draw the border of the rectangle"
	borderColor isTransparent ifFalse:[
		self setFillColor: borderColor.
		(r area > 10000 or: [fillColor isTranslucent]) ifTrue: [
			port frameRect: rect borderWidth: borderWidth.
		] ifFalse: ["for small rectangles, it's faster to fill the entire outer rectangle
					than to compute and fill the border rects"
					port fillRect: rect offset: origin]].

	"fill the inside"
	fillColor isTransparent ifFalse:
		[self setFillColor: fillColor.
		port fillRect: (rect insetBy: borderWidth) offset: origin].! !

!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 2/16/2000 22:07'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor

	| w h rect |
	"First use quick code for top and left borders and fill"
	self frameAndFillRectangle: r
		fillColor: fillColor
		borderWidth: borderWidth
		borderColor: topLeftColor.

	"Now use slow code for bevelled bottom and right borders"
	bottomRightColor isTransparent ifFalse: [
		borderWidth isNumber
			ifTrue: [w _ h _ borderWidth]
			ifFalse: [w _ borderWidth x.   h _ borderWidth y].
		rect _ r translateBy: origin.
		self setFillColor: bottomRightColor.
		port 
			 frameRectRight: rect width: w;
			 frameRectBottom: rect height: h].
! !

!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'RAA 2/6/2001 14:00'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	| additionalOffset rInPortTerms clippedPort targetTopLeft clipOffset ex |

	"this is a bit of a kludge to get the form to be aligned where I *think* it should be.
	something better is needed, but not now"

	additionalOffset _ 0@0.
	ex _ aFillStyle form extent.
	rInPortTerms _ aRectangle translateBy: origin.
	clippedPort _ port clippedBy: rInPortTerms.
	targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex.
	clipOffset _ rInPortTerms topLeft - targetTopLeft.
	additionalOffset _ (clipOffset \\ ex) - ex.
	^aFillStyle
		displayOnPort: clippedPort
		offsetBy: additionalOffset
! !


!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	^aBlock value: (self copyClipRect: aRectangle)! !

!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 10/18/2004 00:05'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock	 smoothing: cellSize

	"Note: This method has been originally copied from TransformationMorph."
	| innerRect patchRect sourceQuad warp start subCanvas |
	(aDisplayTransform isPureTranslation) ifTrue:[
		^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated
							clipRect: aClipRect)
	].
	"Prepare an appropriate warp from patch to innerRect"
	innerRect _ aClipRect.
	patchRect _ (aDisplayTransform globalBoundsToLocal: innerRect) truncated.
	sourceQuad _ (aDisplayTransform sourceQuadFor: innerRect)
					collect: [:p | p - patchRect topLeft].
	warp _ self warpFrom: sourceQuad toRect: innerRect.
	warp cellSize: cellSize.

	"Render the submorphs visible in the clipping rectangle, as patchForm"
	start _ (self depth = 1 and: [self isShadowDrawing not])
		"If this is true B&W, then we need a first pass for erasure."
		ifTrue: [1] ifFalse: [2].
	start to: 2 do:
		[:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W"
		subCanvas _ self class extent: patchRect extent depth: self depth.
		i=1	ifTrue: [subCanvas shadowColor: Color black.
					warp combinationRule: Form erase]
			ifFalse: [self isShadowDrawing ifTrue:
					[subCanvas shadowColor: self shadowColor].
					warp combinationRule: Form paint].
		subCanvas translateBy: patchRect topLeft negated
			during:[:offsetCanvas| aBlock value: offsetCanvas].
		warp sourceForm: subCanvas form; warpBits.
		warp sourceForm: nil.  subCanvas _ nil "release space for next loop"]
! !

!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	^aBlock value: (self copyOffset: delta)! !

!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:55'!
translateTo: newOrigin clippingTo: aRectangle during: aBlock
	"Set a new origin and clipping rectangle only during the execution of aBlock."
	aBlock value: (self copyOrigin: newOrigin clipRect: aRectangle)! !


!FormCanvas methodsFor: 'drawing-text' stamp: 'ar 2/5/2002 19:03'!
drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: c
	| font |
	port colorMap: nil.
	font _ fontOrNil ifNil: [TextStyle defaultFont].
	port combinationRule: Form paint.
	font installOn: port
		foregroundColor: (self shadowColor ifNil:[c]) 
		backgroundColor: Color transparent.
	font displayString: aString on: port 
		from: firstIndex to: lastIndex at: (origin + aPoint) kern: 0.! !

!FormCanvas methodsFor: 'drawing-text' stamp: 'ar 2/5/2002 19:03'!
drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c
	| font portRect |
	port colorMap: nil.
	portRect _ port clipRect.
	port clipByX1: bounds left + origin x 
		y1: bounds top + origin y 
		x2: bounds right + origin x 
		y2: bounds bottom + origin y.
	font _ fontOrNil ifNil: [TextStyle defaultFont].
	port combinationRule: Form paint.
	font installOn: port
		foregroundColor: (self shadowColor ifNil:[c]) 
		backgroundColor: Color transparent.
	font displayString: aString asString on: port 
		from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: 0.
	port clipRect: portRect.! !


!FormCanvas methodsFor: 'initialization' stamp: 'ar 5/27/2000 21:51'!
finish
	"If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."
	form finish! !

!FormCanvas methodsFor: 'initialization' stamp: 'ar 2/17/2000 00:21'!
reset

	origin _ 0@0.							"origin of the top-left corner of this cavas"
	clipRect _ (0@0 corner: 10000@10000).		"default clipping rectangle"
	self shadowColor: nil.! !


!FormCanvas methodsFor: 'other' stamp: 'ar 11/11/1998 22:57'!
asBalloonCanvas
	^(BalloonCanvas on: form) setOrigin: origin clipRect: clipRect! !

!FormCanvas methodsFor: 'other'!
flushDisplay
		Display deferUpdates: false; forceDisplayUpdate.! !

!FormCanvas methodsFor: 'other'!
forceToScreen:rect
	^Display forceToScreen:rect.
! !

!FormCanvas methodsFor: 'other'!
showAt: pt

	^ form displayAt: pt! !

!FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 12:09'!
showAt: pt invalidRects: updateRects
	| blt |
	blt _ (BitBlt current toForm: Display)
		sourceForm: form;
		combinationRule: Form over.
	updateRects do:
		[:rect |
		blt sourceRect: rect;
			destOrigin: rect topLeft + pt;
			copyBits]! !

!FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 12:12'!
warpFrom: sourceQuad toRect: destRect
        ^ (WarpBlt current toForm: port destForm)
                combinationRule: Form paint;
                sourceQuad: sourceQuad destRect: (destRect translateBy: origin);
                clipRect: clipRect! !


!FormCanvas methodsFor: 'printing' stamp: 'ar 5/28/2000 17:07'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll:' on: '; print: form.! !


!FormCanvas methodsFor: 'testing' stamp: 'ar 2/17/2000 00:24'!
isShadowDrawing
	^ self shadowColor notNil! !

!FormCanvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:08'!
isVisible: aRectangle
	"Optimization"
	(aRectangle right + origin x) < clipRect left	ifTrue: [^ false].
	(aRectangle left + origin x) > clipRect right	ifTrue: [^ false].
	(aRectangle bottom + origin y) < clipRect top	ifTrue: [^ false].
	(aRectangle top + origin y) > clipRect bottom	ifTrue: [^ false].
	^ true
! !


!FormCanvas methodsFor: 'private' stamp: 'ar 5/14/2001 23:34'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule 
	"Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."
	port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil.
	port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule.! !

!FormCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha
	"Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."
	port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil.
	port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule alpha: sourceAlpha.! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/28/2000 14:52'!
portClass
	"Return the class used as port"
	^Display defaultBitBltClass asGrafPort! !

!FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:24'!
privateClipRect

	^clipRect! !

!FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:25'!
privatePort

	^port! !

!FormCanvas methodsFor: 'private' stamp: 'yo 6/18/2004 15:11'!
privateWarp: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize
	"Warp the given using the appropriate transform and offset."
	| globalRect sourceQuad warp tfm |
	tfm _ aTransform.
	globalRect _ tfm localBoundsToGlobal: sourceRect.
	sourceQuad _ (tfm sourceQuadFor: globalRect) collect:[:p| p - sourceRect topLeft].
	extraOffset ifNotNil:[globalRect _ globalRect translateBy: extraOffset].
     warp _ (WarpBlt current toForm: port destForm)
                combinationRule: Form paint;
                sourceQuad: sourceQuad destRect: (globalRect origin corner: globalRect corner+(1@1));
                clipRect: port clipRect.
	warp cellSize: cellSize.
	warp sourceForm: aForm.
	warp warpBits! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/25/2000 17:25'!
resetGrafPort
	"Private!! Create a new grafPort for a new copy."

	port _ self portClass toForm: form.
	port clipRect: clipRect.
! !

!FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'!
setClearColor: aColor
	"Install a new clear color - e.g., a color is used for clearing the background"
	| clearColor |
	clearColor _ aColor ifNil:[Color transparent].
	clearColor isColor ifFalse:[
		(clearColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: clearColor; combinationRule: Form over].
	"Okay, so clearColor really *is* a color"
	port sourceForm: nil.
	port combinationRule: Form over.
	port fillPattern: clearColor.
	self depth = 8 ifTrue:[
		"Use a stipple pattern"
		port fillColor: (form balancedPatternFor: clearColor)].
! !

!FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'!
setFillColor: aColor
	"Install a new color used for filling."
	| screen patternWord fillColor |
	fillColor _ self shadowColor ifNil:[aColor].
	fillColor ifNil:[fillColor _ Color transparent].
	fillColor isColor ifFalse:[
		(fillColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: fillColor; combinationRule: Form over].
	"Okay, so fillColor really *is* a color"
	port sourceForm: nil.
	fillColor isTranslucent ifFalse:[
		port combinationRule: Form over.
		port fillPattern: fillColor.
		self depth = 8 ifTrue:[
			"In 8 bit depth it's usually a good idea to use a stipple pattern"
			port fillColor: (form balancedPatternFor: fillColor)].
		^self].
	"fillColor is some translucent color"

	self depth > 8 ifTrue:[
		"BitBlt setup for alpha masked transfer"
		port fillPattern: fillColor.
		self depth = 16
			ifTrue:[port alphaBits: fillColor privateAlpha; combinationRule: 30]
			ifFalse:[port combinationRule: Form blend].
		^self].
	"Can't represent actual transparency -- use stipple pattern"
	screen _ Color translucentMaskFor: fillColor alpha depth: self depth.
	patternWord _ form pixelWordFor: fillColor.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint.
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/25/2000 17:25'!
setForm: aForm

	self reset.
	form _ aForm.
	port _ self portClass toForm: form.
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 14:06'!
setOrigin: aPoint clipRect: aRectangle

	origin _ aPoint.
	clipRect _ aRectangle.
	port clipRect: aRectangle.
! !

!FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'!
setPaintColor: aColor
	"Install a new color used for filling."
	| paintColor screen patternWord |
	paintColor _ self shadowColor ifNil:[aColor].
	paintColor ifNil:[paintColor _ Color transparent].
	paintColor isColor ifFalse:[
		(paintColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: paintColor; combinationRule: Form paint].
	"Okay, so paintColor really *is* a color"
	port sourceForm: nil.
	(paintColor isTranslucent) ifFalse:[
		port fillPattern: paintColor.
		port combinationRule: Form paint.
		self depth = 8 ifTrue:[
			port fillColor: (form balancedPatternFor: paintColor)].
		^self].
	"paintColor is translucent color"

	self depth > 8 ifTrue:[
		"BitBlt setup for alpha mapped transfer"
		port fillPattern: paintColor.
		self depth = 16
			ifTrue:[port alphaBits: paintColor privateAlpha; combinationRule: 31]
			ifFalse:[port combinationRule: Form blend].
		^self].

	"Can't represent actual transparency -- use stipple pattern"
	screen _ Color translucentMaskFor: paintColor alpha depth: self depth.
	patternWord _ form pixelWordFor: paintColor.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint
! !

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

FormCanvas class
	instanceVariableNames: ''!

!FormCanvas class methodsFor: 'instance creation'!
extent: aPoint

	^ self extent: aPoint depth: Display depth
! !

!FormCanvas class methodsFor: 'instance creation'!
extent: extent depth: depth

	^ self new setForm: (Form extent: extent depth: depth)! !

!FormCanvas class methodsFor: 'instance creation' stamp: 'nk 7/4/2003 10:11'!
extent: extent depth: depth origin: aPoint clipRect: aRectangle

	^ self new
		setForm: (Form extent: extent depth: depth);
		setOrigin: aPoint clipRect: aRectangle;
		yourself! !

!FormCanvas class methodsFor: 'instance creation' stamp: 'jm 8/2/97 13:54'!
on: aForm

	^ self new setForm: aForm
! !


!FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:26'!
test1
	"FormCanvas test1"

	| canvas |
	canvas _ FormCanvas extent: 200@200.
	canvas fillColor: (Color black).
	canvas line: 10@10 to: 50@30 width: 1 color: (Color red).
	canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color green).
	canvas point: 100@100 color: (Color black).
	canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: (Color cyan).
	canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color magenta).
	canvas fillOval: ((10@80) corner: (31@121)) color: (Color cyan).
	canvas frameOval: ((40@80) corner: (61@121)) color: (Color blue).
	canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: (Color red alpha: 0.2).
	canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color lightYellow).
	canvas showAt: 0@0.
! !

!FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:26'!
test2
	"FormCanvas test2"

	| baseCanvas p |
	baseCanvas _ FormCanvas extent: 200@200.
	p _ Sensor cursorPoint.
	[Sensor anyButtonPressed] whileFalse: [
		baseCanvas translateBy: (Sensor cursorPoint - p) during:[:canvas|
			canvas fillColor: Color white.
			canvas line: 10@10 to: 50@30 width: 1 color: Color red.
			canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green.
			canvas point: 100@100 color: Color black.
			canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: Color cyan.
			canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta.
			canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan.
			canvas frameOval: ((40@80) corner: (61@121)) color: Color blue.
			canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red.
			canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow.
			canvas showAt: 0@0]].
! !

!FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:25'!
test3
	"FormCanvas test3"

	| baseCanvas |
	baseCanvas _ FormCanvas extent: 200@200.
	baseCanvas fillColor: Color white.
	baseCanvas translateBy: 10@10 during:[:canvas|
		canvas shadowColor: (Color black alpha: 0.5).
		canvas line: 10@10 to: 50@30 width: 1 color: Color red.
		canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green.
		canvas point: 100@100 color: Color black.
		canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: Color cyan.
		canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta.
		canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan.
		canvas frameOval: ((40@80) corner: (61@121)) color: Color blue.
		canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red.
		canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow.
		canvas showAt: 0@0.
	].! !
MouseMenuController subclass: #FormEditor
	instanceVariableNames: 'form tool grid togglegrid mode previousTool color unNormalizedColor xgridOn ygridOn hasUnsavedChanges'
	classVariableNames: 'BitEditKey BlackKey BlockKey ChangeGridsKey CurveKey DarkGrayKey EraseKey FlashCursor GrayKey InKey LightGrayKey LineKey OutKey OverKey RepeatCopyKey ReverseKey SelectKey SingleCopyKey TogglexGridKey ToggleyGridKey UnderKey WhiteKey YellowButtonMenu YellowButtonMessages YgridKey'
	poolDictionaries: ''
	category: 'ST80-Editors'!
!FormEditor commentStamp: 'BG 12/5/2003 22:40' prior: 0!
I represent the basic editor for creating and modifying Forms. This is intended to be an easy to use general-purpose picture (bitMap) editor. I am a kind of MouseMenuController that creates a yellow button menu for accepting and canceling edits. My instances give up control if the cursor is outside the FormView or if a key on the keyboard is pressed.

The form to be edited is stored in instance variable model.
The instance variable form references the paint brush.!


!FormEditor methodsFor: 'basic control sequence' stamp: 'sma 4/22/2000 12:56'!
controlInitialize

	Cursor crossHair show.
	self normalizeColor: unNormalizedColor.
	sensor waitNoButton! !

!FormEditor methodsFor: 'basic control sequence'!
controlTerminate
	"Resets the cursor to be the normal Smalltalk cursor."

	Cursor normal show.
	view updateDisplay! !


!FormEditor methodsFor: 'control defaults'!
controlActivity

	super controlActivity.
	self dragForm! !

!FormEditor methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:07'!
isControlActive
	^ super isControlActive and: [sensor keyboardPressed not]! !


!FormEditor methodsFor: 'cursor'!
cursorPoint
	"Answer the mouse coordinate data gridded according to the receiver's 
	grid."

	^sensor cursorPoint grid: grid! !


!FormEditor methodsFor: 'editing tools' stamp: 'BG 12/5/2003 23:00'!
block
	"Allow the user to fill a rectangle with the gray tone and mode currently 
	selected."

	| rectangle originRect |
	originRect := (Sensor cursorPoint grid: grid) extent: 2 @ 2.
 	rectangle := Cursor corner showWhile:
		[originRect newRectFrom:
			[:f | f origin corner: (Sensor cursorPoint grid: grid)]].
	rectangle isNil 
		ifFalse:
		  [sensor waitNoButton.
		   Display
					fill: (rectangle intersect: view insetDisplayBox)
					rule: mode
					fillColor: color.
		   hasUnsavedChanges contents: true.]! !

!FormEditor methodsFor: 'editing tools' stamp: 'rbb 3/1/2005 11:21'!
changeGridding
	"Allow the user to change the values of the horizontal and/or vertical 
	grid modules. Does not change the primary tool."

	| response gridInteger gridX gridY |
	gridX := togglegrid x.
	gridY := togglegrid y.
	response := UIManager default
		request:
'Current horizontal gridding is: ', gridX printString, '.
Type new horizontal gridding.'.
	response isEmpty
		ifFalse: 
			[gridInteger := Integer readFromString: response.
			gridX := ((gridInteger max: 1) min: Display extent x)].
	response := UIManager default
		request:
'Current vertical gridding is: ', gridY printString, '.
Type new vertical gridding.'.
	response isEmpty
		ifFalse: 
			[gridInteger := Integer readFromString: response.
			gridY := ((gridInteger max: 1) min: Display extent y)].
	xgridOn ifTrue: [grid := gridX @ grid y].
	ygridOn ifTrue: [grid := grid x @ gridY].
	togglegrid := gridX @ gridY.
	tool := previousTool! !

!FormEditor methodsFor: 'editing tools'!
changeTool: aCharacter 
	"Change the value of the instance variable tool to be the tool 
	corresponding to aCharacter. Typically sent from a Switch in a 
	FormMenuView."

	previousTool _ tool.
	tool _ self selectTool: aCharacter.
	(#(singleCopy repeatCopy line curve block) includes: tool)
		ifFalse:
			[self perform: tool]! !

!FormEditor methodsFor: 'editing tools'!
colorBlack
	"Set the mask (color) to black. Leaves the tool set in its previous state."

	self setColor: Color black! !

!FormEditor methodsFor: 'editing tools'!
colorDarkGray
	"Set the mask (color) to dark gray. Leaves the tool set in its previous 
	state."

	self setColor: Color darkGray! !

!FormEditor methodsFor: 'editing tools'!
colorGray
	"Set the color to gray. Leaves the tool set in its previous state."

	self setColor: Color gray.
! !

!FormEditor methodsFor: 'editing tools'!
colorLightGray
	"Set the mask (color) to light gray. Leaves the tool set in its previous 
	state."

	self setColor: Color lightGray! !

!FormEditor methodsFor: 'editing tools'!
colorWhite
	"Set the color to white. Leaves the tool set in its previous state."

	self setColor: Color white! !

!FormEditor methodsFor: 'editing tools' stamp: 'BG 12/10/2003 16:21'!
curve
	"Conic-section specified by three points designated by: first point--press 
	red button second point--release red button third point--click red button. 
	The resultant curve on the display is displayed according to the current 
	form and mode."

	| firstPoint secondPoint thirdPoint curve drawForm |
	"sensor noButtonPressed ifTrue: [^self]."
	firstPoint _ self cursorPoint.
	secondPoint _ self rubberBandFrom: firstPoint until: [sensor noButtonPressed].
	thirdPoint _  self rubberBandFrom: secondPoint until: [sensor redButtonPressed].
	Display depth > 1
	  ifTrue:
	    [self deleteRubberBandFrom: secondPoint to: thirdPoint.
	     self deleteRubberBandFrom: firstPoint to: secondPoint].
	curve _ CurveFitter new.
	curve firstPoint: firstPoint.
	curve secondPoint: secondPoint.
	curve thirdPoint: thirdPoint.
	drawForm := form asFormOfDepth: Display depth.
	Display depth > 1 ifTrue:
	  [drawForm mapColor: Color white to: Color transparent; 
	               mapColor: Color black to: color].

	curve form: drawForm.
	curve
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [mode ~= Form erase ifTrue: [Form paint] ifFalse: [mode]]
										ifFalse: [mode])
		fillColor: (Display depth = 1 ifTrue: [color] ifFalse: [nil]). 
	sensor waitNoButton.
	hasUnsavedChanges contents: true.! !

!FormEditor methodsFor: 'editing tools'!
eraseMode
	"Set the mode for the tools that copy the form onto the display to erase. 
	Leaves the tool set in its previous state."

	mode _ 4.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools' stamp: 'CdG 10/17/2005 20:51'!
fileInForm
	"Ask the user for a file name and then recalls the Form in that file as the current source Form (form). Does not change the tool."

	| fileName |
	fileName := UIManager default
		request: 'File name?' translated
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	form := Form fromFileNamed: fileName.
	tool := previousTool.
! !

!FormEditor methodsFor: 'editing tools' stamp: 'CdG 10/17/2005 20:52'!
fileOutForm
	"Ask the user for a file name and save the current source form under that name. Does not change the tool."

	| fileName |
	fileName := UIManager default
		request: 'File name?' translated
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	Cursor normal
		showWhile: [form writeOnFileNamed: fileName].
	tool := previousTool.
! !

!FormEditor methodsFor: 'editing tools' stamp: 'BG 12/12/2003 15:51'!
line
	"Line is specified by two points from the mouse: first point--press red 
	button; second point--release red button. The resultant line is displayed 
	according to the current form and mode."

	| firstPoint endPoint drawForm |
	drawForm := form asFormOfDepth: Display depth.
	
	 Display depth > 1 
	  ifTrue:
	    [drawForm mapColor: Color white to: Color transparent; 
	                 mapColor: Color black to: color].
	           
	firstPoint _ self cursorPoint.
	endPoint _ self rubberBandFrom: firstPoint until: [sensor noButtonPressed].
	endPoint isNil ifTrue: [^self].
	Display depth > 1 ifTrue: [self deleteRubberBandFrom: firstPoint to: endPoint.].
	(Line from: firstPoint to: endPoint withForm: drawForm)
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [mode ~= Form erase ifTrue: [Form paint] ifFalse: [mode]]
								ifFalse: [mode])
		fillColor: (Display depth = 1 ifTrue: [color] ifFalse: [nil]).  
		hasUnsavedChanges contents: true.! !

!FormEditor methodsFor: 'editing tools'!
magnify
	"Allow for bit editing of an area of the Form. The user designates a 
	rectangular area that is scaled by 5 to allow individual screens dots to be 
	modified. Red button is used to set a bit to black, and yellow button is 
	used to set a bit to white. Editing continues until the user depresses any 
	key on the keyboard."

	| smallRect smallForm scaleFactor tempRect |
	scaleFactor _ 8@8.
	smallRect _ (Rectangle fromUser: grid) intersect: view insetDisplayBox.
	smallRect isNil ifTrue: [^self].
	smallForm _ Form fromDisplay: smallRect.

	"Do this computation here in order to be able to save the existing display screen."
	tempRect _ BitEditor locateMagnifiedView: smallForm scale: scaleFactor.
	BitEditor
		openScreenViewOnForm: smallForm 
		at: smallRect topLeft 
		magnifiedAt: tempRect topLeft 
		scale: scaleFactor.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools' stamp: 'jm 6/30/1999 15:46'!
newSourceForm
	"Allow the user to define a new source form for the FormEditor. Copying 
	the source form onto the display is the primary graphical operation. 
	Resets the tool to be repeatCopy."
	| dForm interiorPoint interiorColor |

	dForm _ Form fromUser: grid.
	"sourceForm must be only 1 bit deep"
	interiorPoint _ dForm extent // 2.
	interiorColor _ dForm colorAt: interiorPoint.
	form _ (dForm makeBWForm: interiorColor) reverse
				findShapeAroundSeedBlock:
					[:f | f pixelValueAt: interiorPoint put: 1].
	form _ form trimBordersOfColor: Color white.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
overMode
	"Set the mode for the tools that copy the form onto the display to over. 
	Leaves the tool set in its previous state."

	mode _ Form over.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools' stamp: 'BG 12/10/2003 15:59'!
repeatCopy
	"As long as the red button is pressed, copy the source form onto the 
	display screen."
  | drawingWasChanged |
	drawingWasChanged := false.
	[sensor redButtonPressed]
		whileTrue: 
		[(BitBlt current destForm: Display sourceForm: form halftoneForm: color
			combinationRule: (Display depth > 1 ifTrue: [mode ~= Form erase ifTrue: [Form paint] ifFalse: [mode]]
										ifFalse: [mode])
			destOrigin: self cursorPoint sourceOrigin: 0@0 extent: form extent
			clipRect: view insetDisplayBox)
			colorMap: (Bitmap with: 0 with: 16rFFFFFFFF);
			copyBits.
		  drawingWasChanged := true.
		].
	drawingWasChanged
	  ifTrue: [hasUnsavedChanges contents: true.]! !

!FormEditor methodsFor: 'editing tools'!
reverseMode
	"Set the mode for the tools that copy the form onto the display to reverse. 
	Leaves the tool set in its previous state."

	mode _ Form reverse.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools' stamp: 'BG 2/25/2001 21:36'!
setColor: aColor
	"Set the mask (color) to aColor.
	Hacked to invoke color chooser if not B/W screen.
	Leaves the tool set in its previous state."

	self normalizeColor:  (unNormalizedColor := Display depth > 1
							ifTrue: [Color fromUser]
							ifFalse: [aColor]).
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools' stamp: 'BG 12/10/2003 16:00'!
singleCopy 
	"If the red button is clicked, copy the source form onto the display 
	screen."

   (BitBlt destForm: Display
           sourceForm: form halftoneForm: color
           combinationRule: (Display depth > 1 ifTrue: [mode ~= Form erase ifTrue: [Form paint] ifFalse: [mode]]
                                                     ifFalse: [mode])
           destOrigin: self cursorPoint sourceOrigin: 0@0 extent: form extent
           clipRect: view insetDisplayBox)
           colorMap: (Bitmap with: 0 with: 16rFFFFFFFF);
	copyBits.
	sensor waitNoButton.
	hasUnsavedChanges contents: true.! !

!FormEditor methodsFor: 'editing tools'!
togglexGridding
	"Turn x (horizontal) gridding off, if it is on, and turns it on, if it is off. 
	Does not change the primary tool."

	xgridOn
		ifTrue: 
			[grid _ 1 @ grid y.
			xgridOn _ false]
		ifFalse: 
			[grid _ togglegrid x @ grid y.
			xgridOn _ true].
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
toggleyGridding
	"Turn y (vertical) gridding off, if it is on, and turns it on, if it is off. 
	Does not change the primary tool."

	ygridOn
		ifTrue: 
			[grid _ grid x @ 1.
			ygridOn _ false]
		ifFalse: 
			[grid _ grid x @ togglegrid y.
			ygridOn _ true].
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
underMode
	"Set the mode for the tools that copy the form onto the display to under. 
	Leaves the tool set in its previous state."

	mode _ Form under.
	tool _ previousTool! !


!FormEditor methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 15:07'!
initialize
	super initialize.
	self setVariables! !

!FormEditor methodsFor: 'initialize-release'!
release
	"Break the cycle between the Controller and its view. It is usually not 
	necessary to send release provided the Controller's view has been properly 
	released independently."

	super release.
	form _ nil! !


!FormEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 22:59'!
accept
	"The edited information should now be accepted by the view."

	view updateDisplay.
	view accept.
	hasUnsavedChanges contents: false.! !

!FormEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 22:59'!
cancel
	"The edited information should be forgotten by the view."

	view cancel.
	hasUnsavedChanges contents: false.! !

!FormEditor methodsFor: 'menu messages'!
edit
	model edit! !

!FormEditor methodsFor: 'menu messages' stamp: 'CdG 10/17/2005 20:52'!
fileOut

	| fileName |
	fileName := UIManager default
		request: 'File name?' translated
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	Cursor normal
		showWhile: [model writeOnFileNamed: fileName].
! !

!FormEditor methodsFor: 'menu messages'!
redButtonActivity 
	"Refer to the comment in MouseMenuController|redButtonActivity."

	self perform: tool! !


!FormEditor methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 15:08'!
getPluggableYellowButtonMenu: shiftKeyState
	^ YellowButtonMenu! !


!FormEditor methodsFor: 'window support' stamp: 'rbb 2/16/2005 16:49'!
okToChange

  ^hasUnsavedChanges contents not
	ifFalse:
	  [self confirm:
		'This drawing was not saved.\Is it OK to close this window?' withCRs
	  ]
	ifTrue:
	  [true]
! !


!FormEditor methodsFor: 'private' stamp: 'BG 12/10/2003 17:02'!
deleteRubberBandFrom: startPoint to: endPoint

	(Line from: startPoint to: endPoint withForm: form)
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: (Display depth = 1 ifTrue: [Color black] ifFalse: [Color gray]).! !

!FormEditor methodsFor: 'private'!
dragForm

	tool = #block
		ifTrue:
			[Cursor origin show.
			[sensor anyButtonPressed
				or: [sensor keyboardPressed
				or: [self viewHasCursor not]]]
				whileFalse: [].
			^self cursorPoint]
		ifFalse:
			[^self trackFormUntil:
				[sensor anyButtonPressed
					or: [sensor keyboardPressed
					or: [self viewHasCursor not]]]]! !

!FormEditor methodsFor: 'private' stamp: 'jm 12/4/97 10:22'!
normalizeColor: aColor

	color _ aColor.
! !

!FormEditor methodsFor: 'private' stamp: 'BG 12/10/2003 16:47'!
rubberBandFrom: startPoint until: aBlock

	| endPoint previousEndPoint |
	previousEndPoint _ startPoint.
	[aBlock value] whileFalse:
		[(endPoint _ self cursorPoint) = previousEndPoint 
			ifFalse:
			[(Line from: startPoint to: previousEndPoint withForm: form) 
				displayOn: Display
				at: 0 @ 0
				clippingBox: view insetDisplayBox
				rule: Form reverse
				fillColor: Color gray.
			(Line from: startPoint to: endPoint withForm: form)
				displayOn: Display
				at: 0 @ 0
				clippingBox: view insetDisplayBox
				rule: Form reverse
				fillColor: Color gray.
			previousEndPoint  _ endPoint]].
	(Line from: startPoint to: previousEndPoint withForm: form)
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: (Display depth = 1 ifTrue: [Color gray] ifFalse: [Color black]).
	^endPoint! !

!FormEditor methodsFor: 'private'!
selectTool: aCharacter
	"A new tool has been selected. It is denoted by aCharacter. Set the tool.
	This code is written out in long hand (i.e., rather than dispatching on a
	table of options) so that it is obvious what is happening."
	
	aCharacter =  SingleCopyKey	ifTrue: [^#singleCopy].
	aCharacter =  RepeatCopyKey	ifTrue: [^#repeatCopy].
	aCharacter =  LineKey			ifTrue: [^#line].					
	aCharacter =  CurveKey			ifTrue: [^#curve].				
	aCharacter =  BlockKey			ifTrue: [^#block].		
	aCharacter =  SelectKey			ifTrue: [^#newSourceForm].		
	aCharacter =  OverKey			ifTrue: [^#overMode].
	aCharacter =  UnderKey			ifTrue: [^#underMode].
	aCharacter =  ReverseKey		ifTrue: [^#reverseMode].
	aCharacter =  EraseKey			ifTrue: [^#eraseMode].
	aCharacter =  ChangeGridsKey	ifTrue: [^#changeGridding].
	aCharacter =  TogglexGridKey	ifTrue: [^#togglexGridding].
	aCharacter =  ToggleyGridKey	ifTrue: [^#toggleyGridding].
	aCharacter =  BitEditKey			ifTrue: [^#magnify].			
	aCharacter =  WhiteKey			ifTrue: [^#colorWhite].			
	aCharacter =  LightGrayKey		ifTrue: [^#colorLightGray].			
	aCharacter =  GrayKey			ifTrue: [^#colorGray].				
	aCharacter =  DarkGrayKey		ifTrue: [^#colorDarkGray].			
	aCharacter =  BlackKey			ifTrue: [^#colorBlack].				
	aCharacter =  OutKey			ifTrue: [^#fileOutForm].			
	aCharacter =  InKey				ifTrue: [^#fileInForm]! !

!FormEditor methodsFor: 'private' stamp: 'BG 12/5/2003 22:58'!
setVariables
	tool _ #repeatCopy.
	previousTool _ tool.
	grid _ 1 @ 1.
	togglegrid _ 8 @ 8.
	xgridOn _ false.
	ygridOn _ false.
	mode _ Form over.
	form _ Form extent: 8 @ 8.
	form fillBlack.
	unNormalizedColor _ color _ Color black.
	hasUnsavedChanges := ValueHolder new contents: false.
! !

!FormEditor methodsFor: 'private' stamp: 'BG 12/12/2003 15:50'!
trackFormUntil: aBlock

	| previousPoint cursorPoint displayForm |
	previousPoint _ self cursorPoint.
	displayForm := Form extent: form extent depth: form depth.
	displayForm copy: (0 @ 0 extent: form extent)
	               from: form
	               to: 0 @ 0
	               rule: Form over.
	Display depth > 1 ifTrue: [displayForm reverse]. 
	displayForm displayOn: Display at: previousPoint rule: Form reverse.
	[aBlock value] whileFalse:
		[cursorPoint _ self cursorPoint.
		(FlashCursor or: [cursorPoint ~= previousPoint])
			ifTrue:
			[displayForm displayOn: Display at: previousPoint rule: Form reverse.
			displayForm displayOn: Display at: cursorPoint rule: Form reverse.
			previousPoint _ cursorPoint]].
	displayForm displayOn: Display at: previousPoint rule: Form reverse.
	^previousPoint! !

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

FormEditor class
	instanceVariableNames: ''!

!FormEditor class methodsFor: 'class initialization'!
flashCursor: aBoolean

	FlashCursor _ aBoolean

	"FormEditor flashCursor: true"! !

!FormEditor class methodsFor: 'class initialization' stamp: 'sma 3/11/2000 15:06'!
initialize

	FlashCursor _ false.
	self setKeyboardMap.
	YellowButtonMenu _ SelectionMenu 
		labels:
'accept
cancel
edit
file out'
		lines: #(2)
		selections: #(accept cancel edit fileOut).

	"FormEditor initialize"! !


!FormEditor class methodsFor: 'examples'!
formFromDisplay
	"Create an instance of me on a new form designated by the user at a
	location designated by the user."

	Form fromUser edit

	"FormEditor formFromDisplay"! !

!FormEditor class methodsFor: 'examples'!
fullScreen
	"Create an instance of me on a new form that fills the full size of the
	display screen."

	FormEditor openFullScreenForm

	"FormEditor fullScreen"! !

!FormEditor class methodsFor: 'examples' stamp: 'BG 12/5/2003 22:39'!
newForm
	"Create an instance of me on a new form at a location designated by the user. "

	(Form extent: 400 @ 200 depth: Display depth)
	    fillWhite;
	    edit

	"FormEditor newForm"! !


!FormEditor class methodsFor: 'instance creation'!
openFullScreenForm
	"Create and schedule an instance of me on the form whose extent is the 
	extent of the display screen."

	| topView |
	topView _ self createFullScreenForm.
	topView controller 
		openDisplayAt: (topView viewport extent//2)

	"FormEditor openFullScreenForm."! !

!FormEditor class methodsFor: 'instance creation'!
openOnForm: aForm
	"Create and schedule an instance of me on the form aForm."

	| topView |
	topView _ self createOnForm: aForm.
	topView controller open

! !


!FormEditor class methodsFor: 'private' stamp: 'di 1/16/98 15:46'!
createFullScreenForm
	"Create a StandardSystemView for a FormEditor on the form whole screen."
	| formView formEditor menuView topView extent aForm |
	aForm _ Form extent: (Display extent x @ (Display extent y - 112)) depth: Display depth.
	formView _ FormHolderView new model: aForm.
	formView borderWidthLeft: 0 right: 0 top: 0 bottom: 1.
	formEditor _ formView controller.
	menuView _ FormMenuView new makeFormEditorMenu model: formEditor.
	formEditor model: menuView controller.
	topView _ StandardSystemView new.
	topView backgroundColor: #veryLightGray.
	topView model: aForm.
	topView addSubView: formView.
	topView 
		addSubView: menuView
		align: menuView viewport topCenter
		with: formView viewport bottomCenter + (0@16).
	topView window: 
		(formView viewport 
			merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16))).
	topView label: 'Form Editor'.
	extent _ topView viewport extent.
	topView minimumSize: extent.
	topView maximumSize: extent.
	^topView

! !

!FormEditor class methodsFor: 'private' stamp: 'BG 12/5/2003 23:18'!
createOnForm: aForm
	"Create a StandardSystemView for a FormEditor on the form aForm."
	| formView formEditor menuView aView topView extent topViewBorder |
	topViewBorder _ 2.
	formView _ FormHolderView new model: aForm.
	formEditor _ formView controller.
	menuView _ FormMenuView new makeFormEditorMenu model: formEditor.
	formEditor model: aForm.
	aView _ View new.
	aView model: aForm.
	aView addSubView: formView.
	aView 
		addSubView: menuView
		align: menuView viewport topCenter
		with: formView viewport bottomCenter + (0@16).
	aView window: 
		((formView viewport 
			merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16))) 
		  expandBy: (0@topViewBorder corner: 0@0)).
	topView _ "ColorSystemView" FormEditorView new.
	topView model: formEditor.
	topView backgroundColor: #veryLightGray.
	topView addSubView: aView.
	topView label: 'Form Editor'.
	topView borderWidth: topViewBorder.
	extent _ topView viewport extent.
	topView minimumSize: extent.
	topView maximumSize: extent.
	^topView! !

!FormEditor class methodsFor: 'private'!
setKeyboardMap
	"Keyboard Mapping."

	SelectKey_$a.
	SingleCopyKey_$s.			"tools"
	RepeatCopyKey_$d.
	LineKey_$f.
	CurveKey_$g.
	BlockKey_$h.
	OverKey_$j.				"modes"
	UnderKey_$k.
	ReverseKey_$l.
	EraseKey_$;.
	InKey_$'.					"file In"
	BitEditKey_$z.
	WhiteKey_$x.				"colors"
	LightGrayKey_$c.
	GrayKey_$v.
	DarkGrayKey_$b.
	BlackKey_$n.
	TogglexGridKey_$m.		"gridding"
	ToggleyGridKey_$,.
	ChangeGridsKey_$..
	OutKey_$/					"file Out"! !
StandardSystemView subclass: #FormEditorView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Editors'!

!FormEditorView methodsFor: 'as yet unclassified'!
cacheBitsAsTwoTone
	^ false! !
FormView subclass: #FormHolderView
	instanceVariableNames: 'displayedForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Views'!
!FormHolderView commentStamp: '<historical>' prior: 0!
I represent a view of a Form. Editing takes place by modifying a working version of the Form. The message accept is used to copy the working version into the Form; the message cancel copies the Form into the working version.!


!FormHolderView methodsFor: 'displaying'!
displayView 
	"Display the Form associated with this View according to the rule and
	fillColor specifed by this class."

	| oldOffset |
	oldOffset _ displayedForm offset.
	displayedForm offset: 0@0.
	displayedForm
		displayOn: Display
		transformation: self displayTransformation
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor.
	displayedForm offset: oldOffset! !

!FormHolderView methodsFor: 'displaying'!
updateDisplay
	"The working version is redefined by copying the bits displayed in the 
	receiver's display area."

	displayedForm fromDisplay: self displayBox.
	displayedForm changed: self! !


!FormHolderView methodsFor: 'initialize-release'!
release

	super release.
	displayedForm release.
	displayedForm _ nil! !


!FormHolderView methodsFor: 'menu messages'!
accept 
	"Refer to the comment in FormView|accept."
	model
		copyBits: displayedForm boundingBox
		from: displayedForm
		at: 0 @ 0
		clippingBox: model boundingBox
		rule: Form over
		fillColor: nil.
	model changed: self! !

!FormHolderView methodsFor: 'menu messages'!
cancel 
	"Refer to the comment in FormView|cancel."

	displayedForm become: model deepCopy.
	displayedForm changed: self.
	self display! !


!FormHolderView methodsFor: 'model access'!
changeValueAt: location put: anInteger 
	"Refer to the comment in FormView|changeValueAt:put:."

	displayedForm pixelValueAt: location put: anInteger.
	displayedForm changed: self! !

!FormHolderView methodsFor: 'model access'!
model: aForm

	super model: aForm.
	displayedForm _ aForm deepCopy! !

!FormHolderView methodsFor: 'model access'!
workingForm
	"Answer the form that is currently being displayed--the working version 
	in which edits are carried out."

	^displayedForm! !
FormView subclass: #FormInspectView
	instanceVariableNames: 'offset'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Views'!

!FormInspectView methodsFor: 'as yet unclassified'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^  NoController! !

!FormInspectView methodsFor: 'as yet unclassified' stamp: 'di 9/23/1998 10:55'!
displayView 
	"Display the form as a value in an inspector.  8/11/96 sw"
	"Defeated form scaling for HS FormInspector.  8/20/96 di"
	| scale |
	Display fill: self insetDisplayBox fillColor: Color white.
	model selectionIndex == 0 ifTrue: [^ self].
	scale _ self insetDisplayBox extent / model selection extent.
	scale _ (scale x min: scale y) min: 1.
	model selection
		displayOn: Display
		transformation: (WindowingTransformation
			scale: scale asPoint
			translation: self insetDisplayBox topLeft - model selection offset)
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor! !

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

FormInspectView class
	instanceVariableNames: ''!

!FormInspectView class methodsFor: 'instance creation' stamp: 'sd 5/11/2003 21:36'!
openOn: aFormDictionary withLabel: aLabel
	"open a graphical dictionary in a window having the label aLabel. 
     aFormDictionary should be a dictionary containing as value a form."

     ^ DictionaryInspector
                openOn: aFormDictionary
                withEvalPane: true
                withLabel: aLabel
                valueViewClass: self! !
Controller subclass: #FormMenuController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Editors'!
!FormMenuController commentStamp: '<historical>' prior: 0!
I represent a Controller that takes control if a key on the keyboard is depressed or if the cursor is within my rectangular area.!


!FormMenuController methodsFor: 'control defaults'!
controlActivity
	"Pass control to a subView corresponding to a pressed keyboard key or to
	a mouse button pressed, if any."

	sensor keyboardPressed
		ifTrue: [self processMenuKey]
		ifFalse: [self controlToNextLevel]! !

!FormMenuController methodsFor: 'control defaults'!
isControlActive
	"Answer false if the blue mouse button is pressed and the cursor is
	outside of the inset display box of the Controller's view; answer true,
	otherwise."

	^sensor keyboardPressed |
		(view containsPoint: sensor cursorPoint) & sensor blueButtonPressed not! !

!FormMenuController methodsFor: 'control defaults'!
isControlWanted
	"Answer true if the cursor is inside the inset display box (see 
	View|insetDisplayBox) of the receiver's view, and answer false, 
	otherwise. It is sent by Controller|controlNextLevel in order to determine 
	whether or not control should be passed to this receiver from the
	Controller of the superView of this receiver's view."

	^sensor keyboardPressed | self viewHasCursor! !

!FormMenuController methodsFor: 'control defaults' stamp: 'jm 4/7/98 20:59'!
processMenuKey
	"The user typed a key on the keyboard. Perform the action of the button whose shortcut is that key, if any."

	| aView |
	aView _ view subViewContainingCharacter: sensor keyboard.
	aView ~~ nil ifTrue: [aView performAction].
! !
View subclass: #FormMenuView
	instanceVariableNames: ''
	classVariableNames: 'BorderForm FormButtons SpecialBorderForm'
	poolDictionaries: ''
	category: 'ST80-Editors'!
!FormMenuView commentStamp: '<historical>' prior: 0!
I represent a View whose subViews are Switches (and Buttons and OneOnSwitches) whose actions set the mode, color, and tool for editing a Form on the screen. The default controller of my instances is FormMenuController.!


!FormMenuView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^FormMenuController! !


!FormMenuView methodsFor: 'initialize-release'!
makeFormEditorMenu

	| button buttonCache form aSwitchView aSwitchController|
	"Now get those forms into the subviews"
	self makeButton: 1.					"form source"
	self makeConnections: (2 to: 6).		"tools"
	self makeConnections: (7 to: 10).		"modes"
	self makeButton: 11.					"filing in"
	self makeButton: 12.					"bit editing"
	self makeColorConnections: (13 to: 17).		"colors"
	self makeGridSwitch: 18.					"toggle x"
	self makeGridSwitch: 19.					"toggle y"
	self makeButton: 20.					"setting grid"
	self makeButton: 21					"filing out"! !


!FormMenuView methodsFor: 'subView access' stamp: 'jm 4/2/98 17:29'!
subViewContainingCharacter: aCharacter
	"Answer the receiver's subView that corresponds to the key, aCharacter. 
	Answer nil if no subView is selected by aCharacter."

	self subViews reverseDo: 
		[:aSubView |
		(aSubView shortcutCharacter = aCharacter) ifTrue: [^aSubView]].
	^nil	
! !


!FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:22'!
makeButton: index

	| buttonCache button |
	buttonCache _ (FormButtons at: index) shallowCopy.
	buttonCache form: (FormButtons at: index) form copy.
	button _ Button newOff.
	button onAction: [model changeTool: buttonCache value].
	self makeViews: buttonCache for: button.
! !

!FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:23'!
makeColorConnections: indexInterval

	| connector buttonCache button aSwitchView |
	connector _ Object new.  "a dummy model for connecting dependents"
	indexInterval do: [:index |
	buttonCache _ (FormButtons at: index) shallowCopy.
	buttonCache form: (FormButtons at: index) form copy.
		buttonCache initialState = #true
			ifTrue: [button _ OneOnSwitch newOn]
			ifFalse: [button _ OneOnSwitch newOff].
		button onAction: [model changeTool: buttonCache value].
		button connection: connector.
		aSwitchView _ self makeViews: buttonCache for: button.
		aSwitchView
			borderWidthLeft: 1 right: 0 top: 1 bottom: 1;
			action: #turnOn].
	aSwitchView borderWidth: 1.
! !

!FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:23'!
makeConnections: indexInterval

	| connector buttonCache button aSwitchView |
	connector _ Object new.  "a dummy model for connecting dependents."
	indexInterval do: [:index |
	buttonCache _ (FormButtons at: index) shallowCopy.
	buttonCache form: (FormButtons at: index) form copy.
		buttonCache initialState = #true
			ifTrue: [button _ OneOnSwitch newOn]
			ifFalse: [button _ OneOnSwitch newOff].
		button onAction: [model changeTool: buttonCache value].
		button connection: connector.
		aSwitchView _ self makeViews: buttonCache for: button.
		aSwitchView
			borderWidthLeft: 1 right: 0 top: 1 bottom: 1;
			action: #turnOn].
	aSwitchView borderWidth: 1.
! !

!FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 15:24'!
makeGridSwitch: index

	| buttonCache button |
	buttonCache _ FormButtons at: index.
	buttonCache form: (FormButtons at: index) form copy.
	buttonCache initialState = #true
		ifTrue: [button _ Switch newOn]
		ifFalse: [button _ Switch newOff].
	button onAction: [model changeTool: buttonCache value].
	button offAction: [model changeTool: buttonCache value].
	self makeViews: buttonCache for: button.
! !

!FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:23'!
makeSwitch: index

	| buttonCache button |
	buttonCache _ (FormButtons at: index) shallowCopy.
	buttonCache form: (FormButtons at: index) form copy.
	buttonCache initialState = #true
		ifTrue: [button _ Switch newOn]
		ifFalse: [button _ Switch newOff].
	button onAction: [model changeTool: buttonCache value].
	self makeViews: buttonCache for: button.
! !

!FormMenuView methodsFor: 'private' stamp: 'jm 4/7/98 20:24'!
makeViews: cache for: aSwitch

	| form aSwitchView |
	form _ cache form.
	aSwitchView _ PluggableButtonView
		on: aSwitch
		getState: #isOn
		action: #switch.
	aSwitchView
		label: form;
		shortcutCharacter: cache value;
		window: (0@0 extent: form extent);
		translateBy: cache offset;
		borderWidth: 1.
	self addSubView: aSwitchView.
	^ aSwitchView
! !

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

FormMenuView class
	instanceVariableNames: ''!

!FormMenuView class methodsFor: 'accessing' stamp: 'BG 12/4/2003 12:11'!
formButtons

  ^FormButtons! !


!FormMenuView class methodsFor: 'class initialization' stamp: 'jm 3/27/98 14:54'!
fileOut
	"Save the FormEditor button icons."
	"FormMenuView fileOut"

	| names |
	names _ 
		#('select.form' 'singlecopy.form' 'repeatcopy.form' 'line.form' 'curve.form'
		'block.form' 'over.form' 'under.form' 'reverse.form' 'erase.form' 'in.form'
		'magnify.form' 'white.form' 'lightgray.form' 'gray.form' 'darkgray.form' 'black.form'
		'xgrid.form' 'ygrid.form' 'togglegrids.form' 'out.form').
	1 to: FormButtons size do: [:i |
		(FormButtons at: i) form writeOnFileNamed: (names at: i)].
	SpecialBorderForm writeOnFileNamed: 'specialborderform.form'.
	BorderForm writeOnFileNamed: 'borderform.form'.
! !

!FormMenuView class methodsFor: 'class initialization' stamp: 'gk 2/28/2005 16:38'!
initialize
	"The icons for the menu are typically stored on files. In order to avoid reading them every time, they are stored in a collection in a class variable, along with their offset, tool value, and initial visual state (on or off)."
	"FormMenuView initialize"

	| offsets keys states names button |
	offsets _ OrderedCollection new: 21.
	#(0 64 96 128 160 192 256 288 320 352 420) do: [:i | offsets addLast: i@0].  "First row"
	#(0 64 96 128 160 192 256 304 352 420) do: [:i | offsets addLast: i@48].  "Second row"
	offsets _ offsets asArray.
	keys _ #($a $s $d $f $g $h $j $k $l $; $' $z $x $c $v $b $n $m $, $. $/ ).  "Keyboard"
	states _ #(
		#false #false #true #false #false #false #true #false #false #false #false
		#false #false #false #false #false #true #false #false #false #false).  "Initial button states"
	names _ 
		#('select.form' 'singlecopy.form' 'repeatcopy.form' 'line.form' 'curve.form'
		'block.form' 'over.form' 'under.form' 'reverse.form' 'erase.form' 'in.form'
		'magnify.form' 'white.form' 'lightgray.form' 'gray.form' 'darkgray.form' 'black.form'
		'xgrid.form' 'ygrid.form' 'togglegrids.form' 'out.form').  "Files of button images"
	FormButtons _ OrderedCollection new.
	1 to: 21 do: [:index |
		button _ FormButtonCache new.
		button form: (Form fromFileNamed: (names at: index)).
		button offset: (offsets at: index).
		button value: (keys at: index).
		button initialState: (states at: index).
		FormButtons addLast: button].
	SpecialBorderForm  _ Form fromFileNamed: 'specialborderform.form'.
	BorderForm _ Form fromFileNamed: 'borderform.form'.
! !
StrikeFont subclass: #FormSetFont
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Fonts'!
!FormSetFont commentStamp: '<historical>' prior: 0!
FormSetFonts are designed to capture individual images as character forms for imbedding in normal text.  While most often used to insert an isolated glyph in some text, the code is actually desinged to support an entire user-defined font.  The TextAttribute subclass TextFontReference is specifically designed for such in-line insertion of exceptional fonts in normal text.!


!FormSetFont methodsFor: 'as yet unclassified' stamp: 'ar 5/23/2000 12:49'!
fromFormArray: formArray asciiStart: asciiStart ascent: ascentVal
	| height width x badChar |
	type _ 2.
	name _ 'aFormFont'.
	minAscii _ asciiStart.
	maxAscii _ minAscii + formArray size - 1.
	ascent _ ascentVal.
	subscript _ superscript _ emphasis _ 0.
	height _ width _ 0.
	maxWidth _ 0.
	formArray do:
		[:f | width _ width + f width.
		maxWidth _ maxWidth max: f width.
		height _ height max: f height + f offset y].
	badChar _ (Form extent: 7@height) borderWidth: 1.
	width _ width + badChar width.
	descent _ height - ascent.
	pointSize _ height.
	glyphs _ Form extent: width @ height depth: formArray first depth.
	xTable _ Array new: maxAscii + 3 withAll: 0.
	x _ 0.
	formArray doWithIndex:
		[:f :i | f displayOn: glyphs at: x@0.
		xTable at: minAscii + i+1 put: (x _ x + f width)].
	badChar displayOn: glyphs at: x@0.
	xTable at: maxAscii + 3 put: x + badChar width.
	characterToGlyphMap _ nil.! !

!FormSetFont methodsFor: 'as yet unclassified'!
reset  "Ignored by FormSetFonts"! !

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

FormSetFont class
	instanceVariableNames: ''!

!FormSetFont class methodsFor: 'examples' stamp: 'ar 1/15/2001 18:38'!
copy: charForm toClipBoardAs: char ascent: ascent
	Clipboard clipboardText:
		(Text string: char asString
			attribute: (TextFontReference toFont: 
				(FormSetFont new
					fromFormArray: (Array with: charForm)
					asciiStart: char asciiValue
					ascent: ascent)))
"
	The S in the Squeak welcome window was installed by doing the following
	in a workspace (where the value of, eg, charForm will persist through BitEdit...
	f _ TextStyle default fontAt: 4.
	oldS _ f characterFormAt: $S.
	charForm _ Form extent: oldS extent depth: 8.
	oldS displayOn: charForm.
	charForm bitEdit.
	...Play around with the BitEditor, then accept and close...
	FormSetFont copy: charForm toClipBoardAs: $S ascent: f ascent.
	...Then do a paste into the Welcome window
"! !

!FormSetFont class methodsFor: 'examples'!
example    "FormSetFont example"
	"Lets the user select a (small) area of the screen to represent the
	character A, then copies 'A' to the clipboard with that as the letter form.
	Thereafter, a paste operation will imbed that character in any text."
	| charForm |
	charForm _ Form fromUser.
	self copy: charForm toClipBoardAs: $A ascent: charForm height! !
Form subclass: #FormStub
	instanceVariableNames: 'locator'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!

!FormStub methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:02'!
locator
	^locator! !

!FormStub methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:02'!
locator: aString
	locator _ aString! !


!FormStub methodsFor: 'fileIn/Out' stamp: 'ar 2/27/2001 21:36'!
objectForDataStream: refStream
	"Force me into outPointers so that I get notified about startup"
	refStream replace: self with: self.
	^self! !
View subclass: #FormView
	instanceVariableNames: 'rule mask'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Views'!
!FormView commentStamp: '<historical>' prior: 0!
I represent a view of a Form.!


!FormView methodsFor: 'accessing'!
fillColor
	"Answer an instance of class Form that is the mask used when displaying 
	the receiver's model (a Form) on the display screen (see BitBlt for the 
	meaning of this mask)."

	^ mask! !

!FormView methodsFor: 'accessing'!
fillColor: aForm 
	"Set the display mask for displaying the receiver's model to be the 
	argument, aForm."

	mask _ aForm! !

!FormView methodsFor: 'accessing'!
mask
	"Answer an instance of class Form that is the mask used when displaying 
	the receiver's model (a Form) on the display screen (see BitBlt for the 
	meaning of this mask)."

	^ mask! !

!FormView methodsFor: 'accessing'!
rule
	"Answer a number from 0 to 15 that indicates which of the sixteen 
	display rules (logical function of two boolean values) is to be used when 
	copying the receiver's model (a Form) onto the display screen."

	rule == nil
		ifTrue: [^self defaultRule]
		ifFalse: [^rule]! !

!FormView methodsFor: 'accessing'!
rule: anInteger 
	"Set the display rule for the receiver to be the argument, anInteger."

	rule _ anInteger! !


!FormView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^  FormEditor! !


!FormView methodsFor: 'displaying'!
displayOn: aPort
	model displayOnPort: aPort at: self displayBox origin! !

!FormView methodsFor: 'displaying' stamp: 'hmm 7/21/97 20:45'!
displayView 
	"Refer to the comment in View|displayView."

	| oldOffset |
	super displayView.
	insideColor == nil ifFalse: [Display fill: self insetDisplayBox fillColor: insideColor].
	oldOffset _ model offset.
	model offset: "borderWidth origin" 0@0.
	model
		displayOn: Display
		transformation: self displayTransformation
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor.
	model offset: oldOffset! !

!FormView methodsFor: 'displaying'!
uncacheBits
	"Placed vacuously here so that when ControlManager>>restore calls uncacheBits for a project with no windows, we don't hang.  1/24/96 sw"! !

!FormView methodsFor: 'displaying'!
updateDisplay
	"overridden by subclass"! !


!FormView methodsFor: 'menu messages'!
accept
	"The receiver's model is set to the working version, the one in which 
	edits are carried out."

	^self! !

!FormView methodsFor: 'menu messages'!
cancel
	"Set the working form to be a copy of the model."

	^self! !


!FormView methodsFor: 'model access'!
changeValueAt: location put: anInteger
	"The receiver's model is a form which has an array of bits. Change the 
	bit at index, location, to be anInteger (either 1 or 0). Inform all objects 
	that depend on the model that it has changed."

	model pixelValueAt: location put: anInteger.
	model changed: self! !


!FormView methodsFor: 'updating'!
update: aFormView 
	"Refer to the comment in View|update:."

	self == aFormView ifFalse: [self display]! !


!FormView methodsFor: 'window access'!
defaultWindow 
	"Refer to the comment in View|defaultWindow."

	^(Rectangle origin: 0 @ 0 extent: model extent)
		expandBy: borderWidth! !

!FormView methodsFor: 'window access'!
windowBox
	"For comaptibility with Control manager (see senders)"
	^ self insetDisplayBox! !


!FormView methodsFor: 'private'!
defaultRule 
	"The default display rule is 3=over or storing."

	^Form over! !

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

FormView class
	instanceVariableNames: ''!

!FormView class methodsFor: 'examples'!
exampleOne
	"Frame a Form (specified by the user) with a border of 2 bits in width and display it offset 60 x 40 from the cornor of the display screen. "
	| f view |
	f _ Form fromUser.
	view _ self new model: f.
	view translateBy: 60 @ 40.
	view borderWidth: 2.
	view display.
	view release

	"FormView exampleOne"! !

!FormView class methodsFor: 'examples'!
exampleTwo
	"Frame a Form (specified by the user) that is scaled by 2. The border is 2 bits in width. Displays at location 60, 40."
	| f view |
	f _ Form fromUser.
	view _ self new model: f.
	view scaleBy: 2.0.
	view translateBy: 60 @ 40.
	view borderWidth: 2.
	view display.
	view release

	"FormView exampleTwo"! !

!FormView class methodsFor: 'examples' stamp: 'BG 12/5/2003 14:45'!
open: aForm named: aString
	"FormView open: ((Form extent: 100@100) borderWidth: 1) named: 'Squeak' "
	"Open a window whose model is aForm and whose label is aString."
	| topView aView |
	topView _ StandardSystemView new.
	topView model: aForm.
	topView label: aString.
	topView minimumSize: aForm extent;
	          maximumSize: aForm extent.
	aView _ FormView new.
	aView model: aForm.
	aView window: (aForm boundingBox expandBy: 2).
	aView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	topView addSubView: aView.
	topView controller open! !
Number subclass: #Fraction
	instanceVariableNames: 'numerator denominator'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Fraction commentStamp: '<historical>' prior: 0!
Fraction provides methods for dealing with fractions like 1/3 as fractions (not as 0.33333...).  All public arithmetic operations answer reduced fractions (see examples).

instance variables: 'numerator denominator '

Examples: (note the parentheses required to get the right answers in Smalltalk and Squeak):

(2/3) + (2/3)
(2/3) + (1/2)		 "answers shows the reduced fraction" 
(2/3) raisedToInteger: 5		 "fractions also can have exponents"
!


!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'!
* aNumber 
	"Answer the result of multiplying the receiver by aNumber."
	| d1 d2 |
	aNumber isFraction ifTrue: 
		[d1 _ numerator gcd: aNumber denominator.
		d2 _ denominator gcd: aNumber numerator.
		(d2 = denominator and: [d1 = aNumber denominator])
			ifTrue: [^ numerator // d1 * (aNumber numerator // d2)].
		^ Fraction numerator: numerator // d1 * (aNumber numerator // d2)
				denominator: denominator // d2 * (aNumber denominator // d1)].
	^ aNumber adaptToFraction: self andSend: #*! !

!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'!
+ aNumber 
	"Answer the sum of the receiver and aNumber."
	| n d d1 d2 |
	aNumber isFraction ifTrue: 
		[d _ denominator gcd: aNumber denominator.
		n _ numerator * (d1 _ aNumber denominator // d) + (aNumber numerator * (d2 _ denominator // d)).
		d1 _ d1 * d2.
		n _ n // (d2 _ n gcd: d).
		(d _ d1 * (d // d2)) = 1 ifTrue: [^ n].
		^ Fraction numerator: n denominator: d].
	^ aNumber adaptToFraction: self andSend: #+! !

!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'!
- aNumber
	"Answer the difference between the receiver and aNumber."
	aNumber isFraction ifTrue:
		[^ self + aNumber negated].
	^ aNumber adaptToFraction: self andSend: #-! !

!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'!
/ aNumber
	"Answer the result of dividing the receiver by aNumber."
	aNumber isFraction
		ifTrue: [^self * aNumber reciprocal].
	^ aNumber adaptToFraction: self andSend: #/! !

!Fraction methodsFor: 'arithmetic'!
negated 
	"Refer to the comment in Number|negated."

	^ Fraction
		numerator: numerator negated
		denominator: denominator! !

!Fraction methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'!
reciprocal
	"Refer to the comment in Number|reciprocal."
	#Numeric.
	"Changed 200/01/19 For ANSI <number> support."
	numerator = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"].
	numerator = 1 ifTrue: [^ denominator].
	numerator = -1 ifTrue: [^ denominator negated].
	^ Fraction numerator: denominator denominator: numerator! !


!Fraction methodsFor: 'comparing' stamp: 'di 11/6/1998 13:58'!
< aNumber
	aNumber isFraction ifTrue:
		[^ numerator * aNumber denominator < (aNumber numerator * denominator)].
	^ aNumber adaptToFraction: self andSend: #<! !

!Fraction methodsFor: 'comparing' stamp: 'di 8/31/1999 10:33'!
= aNumber
	aNumber isNumber ifFalse: [^ false].
	aNumber isFraction
		ifTrue: [numerator = 0 ifTrue: [^ aNumber numerator = 0].
				^ (numerator * aNumber denominator) =
					(aNumber numerator * denominator)
				"Note: used to just compare num and denom,
					but this fails for improper fractions"].
	^ aNumber adaptToFraction: self andSend: #=! !

!Fraction methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:33'!
hash
	"Hash is reimplemented because = is implemented."

	^numerator hash bitXor: denominator hash! !


!Fraction methodsFor: 'converting' stamp: 'mk 10/27/2003 18:13'!
adaptToComplex: rcvr andSend: selector
	"If I am involved in arithmetic with a Complex number, convert me to a Complex number."
	^ rcvr perform: selector with: self asComplex! !

!Fraction methodsFor: 'converting' stamp: 'di 11/6/1998 13:10'!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a Fraction."
	^ rcvr asFraction perform: selector with: self! !

!Fraction methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector 
	"Convert receiverScaledDecimal to a Fraction and do the arithmetic. 
	receiverScaledDecimal arithmeticOpSelector self."
	#Numeric.
	"add 200/01/19 For ScaledDecimal support."
	^ receiverScaledDecimal asFraction perform: arithmeticOpSelector with: self! !

!Fraction methodsFor: 'converting' stamp: 'mk 10/27/2003 18:13'!
asComplex
	"Answer a Complex number that represents value of the the receiver."

	^ Complex real: self imaginary: 0! !

!Fraction methodsFor: 'converting' stamp: 'nice 5/7/2006 17:10'!
asFloat
	"Answer a Float that closely approximates the value of the receiver.
	This implementation will answer the closest floating point number to
	the receiver.
	It uses the IEEE 754 round to nearest even mode
	(can happen in case denominator is a power of two)"
	
	| a b q r exponent floatExponent n ha hb hq q1 |
	a := numerator abs.
	b := denominator abs.
	ha := a highBit.
	hb := b highBit.
	
	"If both numerator and denominator are represented exactly in floating point number,
	then fastest thing to do is to use hardwired float division"
	(ha < 54 and: [hb < 54]) ifTrue: [^numerator asFloat / denominator asFloat].
	
	"Try and obtain a mantissa with 54 bits.
	First guess is rough, we might get one more bit or one less"
	exponent := ha - hb - 54.
	exponent > 0
		ifTrue: [b := b bitShift: exponent]
		ifFalse: [a := a bitShift: exponent negated].
	q := a quo: b.
	r := a - (q * b).
	hq := q highBit.
	
	"check for gradual underflow, in which case we should use less bits"
	floatExponent := exponent + hq - 1.
	n := floatExponent > -1023
		ifTrue: [54]
		ifFalse: [54 + floatExponent + 1022].
	
	hq > n
		ifTrue: [exponent := exponent + hq - n.
			r := (q bitAnd: (1 bitShift: n - hq) - 1) * b + r.
			q := q bitShift: n - hq].
	hq < n
		ifTrue: [exponent := exponent + hq - n.
			q1 := (r bitShift: n - hq) quo: b.
			q := (q bitShift: n - hq) bitAnd: q1.
			r := r - (q1 * b)].
		
	"check if we should round upward.
	The case of exact half (q bitAnd: 1) isZero not & (r isZero)
	will be handled by Integer>>asFloat"
	((q bitAnd: 1) isZero or: [r isZero])
		ifFalse: [q := q + 1].
		
	^ (self positive
		ifTrue: [q asFloat]
		ifFalse: [q asFloat negated])
		timesTwoPower: exponent! !

!Fraction methodsFor: 'converting'!
asFraction	
	"Answer the receiver itself."

	^self! !

!Fraction methodsFor: 'converting'!
isFraction
	^ true! !


!Fraction methodsFor: 'mathematical functions' stamp: 'LC 4/22/1998 14:03'!
raisedToInteger: anInteger 
	"See Number | raisedToInteger:"
	anInteger = 0 ifTrue: [^ 1].
	anInteger < 0 ifTrue: [^ self reciprocal raisedToInteger: anInteger negated].
	^ Fraction numerator: (numerator raisedToInteger: anInteger)
		denominator: (denominator raisedToInteger: anInteger)! !

!Fraction methodsFor: 'mathematical functions' stamp: 'LC 4/22/1998 14:05'!
squared
	"See Fraction (Number) | squared"
	^ Fraction numerator: numerator squared denominator: denominator squared! !


!Fraction methodsFor: 'printing'!
printOn: aStream

	aStream nextPut: $(.
	numerator printOn: aStream.
	aStream nextPut: $/.
	denominator printOn: aStream.
	aStream nextPut: $).
! !

!Fraction methodsFor: 'printing' stamp: 'laza 3/29/2004 12:56'!
printOn: aStream base: base

	aStream nextPut: $(.
	numerator printOn: aStream base: base.
	aStream nextPut: $/.
	denominator printOn: aStream base: base.
	aStream nextPut: $).
! !

!Fraction methodsFor: 'printing' stamp: 'laza 3/29/2004 13:25'!
storeOn: aStream base: base

	aStream nextPut: $(.
	numerator storeOn: aStream base: base.
	aStream nextPut: $/.
	denominator storeOn: aStream base: base.
	aStream nextPut: $).
! !


!Fraction methodsFor: 'truncation and round off'!
truncated 
	"Refer to the comment in Number|truncated."

	^numerator quo: denominator! !


!Fraction methodsFor: 'private'!
denominator

	^denominator! !

!Fraction methodsFor: 'private'!
numerator

	^numerator! !

!Fraction methodsFor: 'private'!
reduced

	| gcd numer denom |
	numerator = 0 ifTrue: [^0].
	gcd _ numerator gcd: denominator.
	numer _ numerator // gcd.
	denom _ denominator // gcd.
	denom = 1 ifTrue: [^numer].
	^Fraction numerator: numer denominator: denom! !

!Fraction methodsFor: 'private' stamp: 'tfei 4/12/1999 12:45'!
setNumerator: n denominator: d

	d = 0
		ifTrue: [^(ZeroDivide dividend: n) signal]
		ifFalse: 
			[numerator _ n asInteger.
			denominator _ d asInteger abs. "keep sign in numerator"
			d < 0 ifTrue: [numerator _ numerator negated]]! !


!Fraction methodsFor: 'self evaluating' stamp: 'apb 4/20/2006 18:41'!
isSelfEvaluating 
	^ true! !

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

Fraction class
	instanceVariableNames: ''!

!Fraction class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'!
one
	#Numeric.
	"add 200/01/19 For <number> protocol support."
	^ self numerator: 1 denominator: 1! !


!Fraction class methodsFor: 'instance creation' stamp: 'di 8/31/1999 10:16'!
numerator: numInteger denominator: denInteger 
	"Answer an instance of me (numInteger/denInteger).
	NOTE: This primitive initialization method will not reduce improper fractions,
	so normal usage should be coded as, eg,
		(Fraction numerator: a denominator: b) reduced
	or, more simply, as
		a / b."

	^self new setNumerator: numInteger denominator: denInteger! !
ClassTestCase subclass: #FractionTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!

!FractionTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 09:28'!
testFractionPrinting

	self assert: (353/359) printString = '(353/359)'.
	self assert: ((2/3) printStringBase: 2) = '(10/11)'.
	self assert: ((2/3) storeStringBase: 2) = '(2r10/2r11)'.
	self assert: ((5/7) printStringBase: 3) = '(12/21)'.
	self assert: ((5/7) storeStringBase: 3) = '(3r12/3r21)'.
	self assert: ((11/13) printStringBase: 4) = '(23/31)'.
	self assert: ((11/13) storeStringBase: 4) = '(4r23/4r31)'.
	self assert: ((17/19) printStringBase: 5) = '(32/34)'.
	self assert: ((17/19) storeStringBase: 5) = '(5r32/5r34)'.
	self assert: ((23/29) printStringBase: 6) = '(35/45)'.
	self assert: ((23/29) storeStringBase: 6) = '(6r35/6r45)'.
	self assert: ((31/37) printStringBase: 7) = '(43/52)'.
	self assert: ((31/37) storeStringBase: 7) = '(7r43/7r52)'.
	self assert: ((41/43) printStringBase: 8) = '(51/53)'.
	self assert: ((41/43) storeStringBase: 8) = '(8r51/8r53)'.
	self assert: ((47/53) printStringBase: 9) = '(52/58)'.
	self assert: ((47/53) storeStringBase: 9) = '(9r52/9r58)'.
	self assert: ((59/61) printStringBase: 10) = '(59/61)'.
	self assert: ((59/61) storeStringBase: 10) = '(59/61)'.
	self assert: ((67/71) printStringBase: 11) = '(61/65)'.
	self assert: ((67/71) storeStringBase: 11) = '(11r61/11r65)'.
	self assert: ((73/79) printStringBase: 12) = '(61/67)'.
	self assert: ((73/79) storeStringBase: 12) = '(12r61/12r67)'.
	self assert: ((83/89) printStringBase: 13) = '(65/6B)'.
	self assert: ((83/89) storeStringBase: 13) = '(13r65/13r6B)'.
	self assert: ((97/101) printStringBase: 14) = '(6D/73)'.
	self assert: ((97/101) storeStringBase: 14) = '(14r6D/14r73)'.
	self assert: ((103/107) printStringBase: 15) = '(6D/72)'.
	self assert: ((103/107) storeStringBase: 15) = '(15r6D/15r72)'.
	self assert: ((109/113) printStringBase: 16) = '(6D/71)'.
	self assert: ((109/113) storeStringBase: 16) = '(16r6D/16r71)'.
	self assert: ((127/131) printStringBase: 17) = '(78/7C)'.
	self assert: ((127/131) storeStringBase: 17) = '(17r78/17r7C)'.
	self assert: ((137/139) printStringBase: 18) = '(7B/7D)'.
	self assert: ((137/139) storeStringBase: 18) = '(18r7B/18r7D)'.
	self assert: ((149/151) printStringBase: 19) = '(7G/7I)'.
	self assert: ((149/151) storeStringBase: 19) = '(19r7G/19r7I)'.
	self assert: ((157/163) printStringBase: 20) = '(7H/83)'.
	self assert: ((157/163) storeStringBase: 20) = '(20r7H/20r83)'.
	self assert: ((167/173) printStringBase: 21) = '(7K/85)'.
	self assert: ((167/173) storeStringBase: 21) = '(21r7K/21r85)'.
	self assert: ((179/181) printStringBase: 22) = '(83/85)'.
	self assert: ((179/181) storeStringBase: 22) = '(22r83/22r85)'.
	self assert: ((191/193) printStringBase: 23) = '(87/89)'.
	self assert: ((191/193) storeStringBase: 23) = '(23r87/23r89)'.
	self assert: ((197/199) printStringBase: 24) = '(85/87)'.
	self assert: ((197/199) storeStringBase: 24) = '(24r85/24r87)'.
	self assert: ((211/223) printStringBase: 25) = '(8B/8N)'.
	self assert: ((211/223) storeStringBase: 25) = '(25r8B/25r8N)'.
	self assert: ((227/229) printStringBase: 26) = '(8J/8L)'.
	self assert: ((227/229) storeStringBase: 26) = '(26r8J/26r8L)'.
	self assert: ((233/239) printStringBase: 27) = '(8H/8N)'.
	self assert: ((233/239) storeStringBase: 27) = '(27r8H/27r8N)'.
	self assert: ((241/251) printStringBase: 28) = '(8H/8R)'.
	self assert: ((241/251) storeStringBase: 28) = '(28r8H/28r8R)'.
	self assert: ((257/263) printStringBase: 29) = '(8P/92)'.
	self assert: ((257/263) storeStringBase: 29) = '(29r8P/29r92)'.
	self assert: ((269/271) printStringBase: 30) = '(8T/91)'.
	self assert: ((269/271) storeStringBase: 30) = '(30r8T/30r91)'.
	self assert: ((277/281) printStringBase: 31) = '(8T/92)'.
	self assert: ((277/281) storeStringBase: 31) = '(31r8T/31r92)'.
	self assert: ((283/293) printStringBase: 32) = '(8R/95)'.
	self assert: ((283/293) storeStringBase: 32) = '(32r8R/32r95)'.
	self assert: ((307/311) printStringBase: 33) = '(9A/9E)'.
	self assert: ((307/311) storeStringBase: 33) = '(33r9A/33r9E)'.
	self assert: ((313/317) printStringBase: 34) = '(97/9B)'.
	self assert: ((313/317) storeStringBase: 34) = '(34r97/34r9B)'.
	self assert: ((331/337) printStringBase: 35) = '(9G/9M)'.
	self assert: ((331/337) storeStringBase: 35) = '(35r9G/35r9M)'.
	self assert: ((347/349) printStringBase: 36) = '(9N/9P)'.
	self assert: ((347/349) storeStringBase: 36) = '(36r9N/36r9P)'.

	self assert: ((-2/3) printStringBase: 2) = '(-10/11)'.
	self assert: ((-2/3) storeStringBase: 2) = '(-2r10/2r11)'.
	self assert: ((5/-7) printStringBase: 3) = '(-12/21)'.
	self assert: ((5/-7) storeStringBase: 3) = '(-3r12/3r21)'.
! !


!FractionTest methodsFor: 'tests - sinuses' stamp: 'sd 3/4/2004 21:13'!
testDegreeCos
	"self run: #testDegreeCos"
	
	self shouldnt: [ (4/3) degreeCos] raise: Error.
	self assert: (1/3) degreeCos printString =  '0.999983076857744'! !

!FractionTest methodsFor: 'tests - sinuses' stamp: 'sd 3/5/2004 14:54'!
testDegreeSin
	"self run: #testDegreeSin"
	
	self shouldnt: [ (4/3) degreeSin] raise: Error.
	self assert: (1/3) degreeSin printString =  '0.005817731354993834'.! !
StringMorph subclass: #FrameRateMorph
	instanceVariableNames: 'lastDisplayTime framesSinceLastDisplay'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!FrameRateMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	lastDisplayTime _ 0.
	framesSinceLastDisplay _ 0! !


!FrameRateMorph methodsFor: 'parts bin' stamp: 'sw 7/19/2001 13:39'!
initializeToStandAlone
	"Initialize the receiver as a stand-alone entity"

	super initializeToStandAlone.
	self color: Color blue.
	self step! !


!FrameRateMorph methodsFor: 'stepping and presenter' stamp: 'sw 10/5/2000 06:52'!
step
	"Compute and display (every half second or so) the current framerate"

	| now mSecs mSecsPerFrame framesPerSec newContents |
	framesSinceLastDisplay _ framesSinceLastDisplay + 1.
	now _ Time millisecondClockValue.
	mSecs _ now - lastDisplayTime.
	(mSecs > 500 or: [mSecs < 0 "clock wrap-around"]) ifTrue: 
		[mSecsPerFrame _ mSecs // framesSinceLastDisplay.
		framesPerSec _ (framesSinceLastDisplay * 1000) // mSecs.
		newContents _ mSecsPerFrame printString, ' mSecs (', framesPerSec printString, ' frame', (framesPerSec == 1 ifTrue: [''] ifFalse: ['s']), '/sec)'.
		self contents: newContents.
		lastDisplayTime _ now.
		framesSinceLastDisplay _ 0]! !


!FrameRateMorph methodsFor: 'testing' stamp: 'jm 2/23/98 18:41'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 0
! !

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

FrameRateMorph class
	instanceVariableNames: ''!

!FrameRateMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:05'!
initialize

	self registerInFlapsRegistry.	! !

!FrameRateMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:06'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(FrameRateMorph		authoringPrototype		'Frame Rate'		'An indicator of how fast your system is running')
						forFlapNamed: 'Widgets']! !

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

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


!FrameRateMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:49'!
descriptionForPartsBin
	^ self partName:	'FrameRate'
		categories:		#('Useful')
		documentation:	'A readout that allows you to monitor the frame rate of your system'! !


!FrameRateMorph class methodsFor: 'scripting' stamp: 'sw 6/13/2001 00:57'!
authoringPrototype
	"Answer a morph representing a prototypical instance of the receiver"

	| aMorph |
	aMorph _ self new.
	aMorph color: Color blue.
	aMorph step.
	^ aMorph! !
HierarchicalUrl subclass: #FtpUrl
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!FtpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0!
a reference to a file which may be downloaded by anonymous ftp .



TODO: use the username and password, if specified
!


!FtpUrl methodsFor: 'access' stamp: 'ls 7/24/1998 00:18'!
pathString
	self path isEmpty ifTrue: [ ^'/' copy ].

	^String streamContents: [ :s |
		self path do: [ :p |
		 	s nextPut: $/.
			s nextPutAll: p ] ]! !


!FtpUrl methodsFor: 'downloading' stamp: 'mir 8/5/2004 11:55'!
downloadUrl
	"Returns a http download url for the location defined by this url."
	| ans |
	ans _ WriteStream on: String new.
	ans nextPutAll: self schemeName.
	ans nextPutAll: '://'.
	ans nextPutAll: self authority.
	port ifNotNil: [ans nextPut: $:; print: port].
	path do: [ :pathElem |
		ans nextPut: $/.
		ans nextPutAll: pathElem encodeForHTTP. ].
	self query isNil ifFalse: [ 
		ans nextPut: $?.
		ans nextPutAll: self query. ].
	self fragment isNil ifFalse: [
		ans nextPut: $#.
		ans nextPutAll: self fragment encodeForHTTP. ].
	
	^ans contents! !

!FtpUrl methodsFor: 'downloading' stamp: 'mir 6/27/2003 19:42'!
retrieveContents
	"currently assumes directories end in /, and things that don't end in / are files.  Also, doesn't handle errors real well...."
	| server contents pathString listing auth idx fileName serverName userName password |
	pathString _ self pathString.
	pathString _ pathString copyFrom: 2 to: pathString size. "remove the leading /"
	pathString last = $/ ifTrue:["directory?!!"
		fileName _ nil.
	] ifFalse:[
		fileName _ pathString copyFrom: (pathString lastIndexOf: $/)+1 to: pathString size.
		pathString _ pathString copyFrom: 1 to: (pathString lastIndexOf: $/) - 1.
	].
	auth _ self authority.
	idx _ auth indexOf: $@.
	idx > 0 ifTrue:[
		serverName _ (auth copyFrom: idx+1 to: auth size).
		userName _ (auth copyFrom: 1 to: idx-1).
		password _ nil.
	] ifFalse:[
		serverName _ auth.
		userName _ 'anonymous'.
		password _ 'SqueakUser'.
	].
	server _ ServerDirectory servers 
		detect:[:s| s isTypeFTP and:[s server asLowercase = serverName asLowercase]]
		ifNone:[nil].
	server ifNil:[
		server _ ServerDirectory new.
		server server: serverName.
	] ifNotNil:[server _ server copy reset].
	server user: userName.
	password ifNotNil:[server password: password].
	server directory: pathString.

	fileName == nil ifFalse:[
		"a file"
		contents _ (server getFileNamed: fileName).
		server sleep.
		^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: contents].

	"a directory?"
	listing _ String streamContents: [ :stream |
		stream nextPutAll: '<title>', self pathString, '</title>'; cr.
		stream nextPutAll: '<h1>Listing for ', self pathString, '</h1>'; cr.
		stream nextPutAll: '<ul>'; cr.
		server entries do: [ :entry |
			stream nextPutAll: '<li>';
				nextPutAll: '<a href="', entry name encodeForHTTP.
			entry isDirectory ifTrue: [ stream nextPut: $/ ].
			stream nextPutAll: '">';
				nextPutAll: entry name;
				nextPutAll: '</a>';
				cr ] ].
	server sleep.
	^MIMEDocument contentType: 'text/html' content: listing! !


!FtpUrl methodsFor: 'testing' stamp: 'ar 2/27/2001 22:07'!
hasRemoteContents
	"Return true if the receiver describes some remotely accessible content.
	Typically, this should only return if we could retrieve the contents
	on an arbitrary place in the outside world using a standard browser.
	In other words: If you can get to it from the next Internet Cafe, 
	return true, else return false."
	^true! !
RequiresSpeedTestCase subclass: #FullMERequiresSpeedTestCase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Requires'!

!FullMERequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 11:37'!
getInformationFor: classes 
	classes do: 
			[:interestingCl | 
			interestingCl withAllSuperclassesDo: 
					[:cl | 
					LocalSends current for: cl.
					ProvidedSelectors current for: cl.
					RequiredSelectors current for: cl]]! !

!FullMERequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/9/2005 23:15'!
loseInterestInClasses: classes 
	classes do: [:interestingCl | 
		RequiredSelectors current lostInterest: self in: interestingCl.
		interestingCl withAllSuperclassesDo: [:cl | 
			ProvidedSelectors current lostInterest: self in: cl.
			LocalSends current lostInterest: self in: cl]]! !

!FullMERequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/9/2005 23:11'!
noteInterestInClasses: classes 
	classes do: 
			[:interestingCl | 
			interestingCl withAllSuperclassesDo: 
					[:cl | 
					LocalSends current noteInterestOf: self in: cl.
					ProvidedSelectors current noteInterestOf: self in: cl].
				RequiredSelectors current noteInterestOf: self in: interestingCl]! !

!FullMERequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 11:37'!
prepareAllCaches
	| classes |
	classes := displayedClasses , focusedClasses.
	self noteInterestInClasses: classes.
	self getInformationFor: classes! !

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

FullMERequiresSpeedTestCase class
	instanceVariableNames: ''!
DataType subclass: #FullVocabulary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!
!FullVocabulary commentStamp: '<historical>' prior: 0!
The vocabulary that it all-encompassing.  Its categories consist of the union of all categories of a class and all its superclasses.  The methods in each category consist of those with selectors that are associated with that category.!


!FullVocabulary methodsFor: 'category list' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given object, considering only code implemented in mostGeneric and lower (or higher, depending on which way you're facing"

	| classToUse |
	classToUse := anObject ifNil: [aClass] ifNotNil: [anObject class].
	^ mostGenericClass == classToUse
		ifTrue:
			[mostGenericClass organization categories]
		ifFalse:
			[classToUse allMethodCategoriesIntegratedThrough: mostGenericClass]! !


!FullVocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')
Vocabulary initialize
"

	super initialize.
	vocabularyName := #Object.
	self documentation: '"Object" is all-encompassing vocabulary that embraces all methods understood by an object'.
	self rigAFewCategories! !

!FullVocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
rigAFewCategories
	"Formerly used to rig generic categories, now seemingly disfunctional and in abeyance"

	| aMethodCategory |
	true ifTrue: [^ self].

	self flag: #deferred.
"Vocabulary fullVocabulary rigAFewCategories "
	#(	(accessing	'Generally holds methods to read and write instance variables')
		(initialization	'messages typically sent when an object is created, to set up its initial state'))

		do:
			[:pair |
				aMethodCategory := ElementCategory new categoryName: pair first.
				aMethodCategory documentation: pair second.
				self addCategory: aMethodCategory]! !


!FullVocabulary methodsFor: 'method list' stamp: 'stephaneducasse 2/4/2006 20:39'!
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
	"Answer a list of all methods which are in the given category, on behalf of anObject"

	| classToUse |
	classToUse := aClass ifNil: [anObject class].
	^ classToUse allMethodsInCategory: categoryName! !


!FullVocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoriesContaining: aSelector forClass: aTargetClass 
	"Answer a list of category names (all symbols) of categories that contain 
	the given selector for the target object. Initially, this just returns one."
	| classDefiningSelector catName |
	classDefiningSelector := aTargetClass whichClassIncludesSelector: aSelector.
	classDefiningSelector
		ifNil: [^ OrderedCollection new].
	catName := classDefiningSelector whichCategoryIncludesSelector: aSelector.
	^ OrderedCollection with: catName! !

!FullVocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: targetInstance ofClass: targetClass 
	"Answer the name of a category, from among the provided 
	categoryNames, which defines the selector for the given class. Here, if 
	the category designated by the implementing class is acceptable it is the 
	one returned"
	| aClass catName result |
	(aClass := targetClass whichClassIncludesSelector: aSelector)
		ifNotNil: [(categoryNames includes: (catName := aClass whichCategoryIncludesSelector: aSelector))
				ifTrue: [catName ~~ #'as yet unclassified'
						ifTrue: [^ catName]]].
	result := super
				categoryWithNameIn: categoryNames
				thatIncludesSelector: aSelector
				forInstance: targetInstance
				ofClass: aClass.
	^ result
		ifNil: [#'as yet unclassified']! !

!FullVocabulary methodsFor: 'queries' stamp: 'sw 12/12/2000 06:06'!
encompassesAPriori: aClass
	"Answer whether an object, by its very nature, is one that the receiver embraces"

	^ true! !

!FullVocabulary methodsFor: 'queries' stamp: 'sw 3/20/2001 15:42'!
includesDefinitionForSelector: aSelector
	"Answer whether the given selector is known to the vocabulary.  Unsent at the moment, may disappear."

	^ true! !

!FullVocabulary methodsFor: 'queries' stamp: 'sw 12/1/2000 21:57'!
includesSelector: aSelector
	"Answer whether the given selector is known to the vocabulary"

	^ true! !

!FullVocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
	"Answer whether the vocabulary includes the given selector for the given class, only considering method implementations in mostGenericClass and lower"

	| classToUse aClass |
	classToUse := self classToUseFromInstance: anInstance ofClass: aTargetClass.
	^ (aClass := classToUse whichClassIncludesSelector: aSelector)
		ifNil:
			[false]
		ifNotNil:
			[aClass includesBehavior: mostGenericClass]! !

!FullVocabulary methodsFor: 'queries' stamp: 'sw 9/27/2001 03:28'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^ false! !


!FullVocabulary methodsFor: '*eToys-initialization' stamp: 'sw 9/27/2001 17:21'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(1.0 0.26 0.98)	! !
TextComponent subclass: #FunctionComponent
	instanceVariableNames: 'inputSelectors functionSelector outputSelector outputValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/4/1998 08:56'!
addPin 
	| i prev sideLength wasNew |
	wasNew _ self getText = textMorph asText.
	i _ pinSpecs size.
	prev _ pinSpecs last.
	sideLength _ prev pinLoc asInteger odd ifTrue: [self height] ifFalse: [self width].
	pinSpecs _ pinSpecs copyWith:
		(PinSpec new pinName: ('abcdefghi' copyFrom: i to: i) direction: #input
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: nil modelWriteSelector: nil
				defaultValue: nil pinLoc: prev pinLoc + (8/sideLength) asFloat \\ 4).
	self initFromPinSpecs.
	self addPinFromSpec: pinSpecs last.
	wasNew ifTrue: [self setText: self getText].
	self accept
	! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 22:04'!
headerString
	| ps |
	^ String streamContents:
		[:s | s nextPutAll: self knownName.
		2 to: pinSpecs size do:
			[:i | ps _ pinSpecs at: i.
			s nextPutAll: ps pinName , ': ';
				nextPutAll: ps pinName , ' '].
		s cr; tab; nextPutAll: '^ ']! !


!FunctionComponent methodsFor: 'button' stamp: 'dgd 2/22/2003 14:25'!
fire
	| arguments newValue |
	outputSelector ifNil: [^outputValue := nil].
	functionSelector ifNil: [^outputValue := nil].
	arguments := inputSelectors 
				collect: [:s | s ifNil: [nil] ifNotNil: [model perform: s]].
	newValue := (arguments findFirst: [:a | a isNil]) = 0 
				ifTrue: [model perform: functionSelector withArguments: arguments]
				ifFalse: [nil].
	newValue = outputValue 
		ifFalse: 
			[model perform: outputSelector with: newValue.
			outputValue := newValue]! !


!FunctionComponent methodsFor: 'components' stamp: 'di 5/3/1998 23:34'!
initFromPinSpecs
	outputSelector _ pinSpecs first modelWriteSelector.
	inputSelectors _ (pinSpecs copyFrom: 2 to: pinSpecs size)
						collect: [:ps | ps modelReadSelector]! !

!FunctionComponent methodsFor: 'components' stamp: 'di 5/3/1998 16:14'!
initPinSpecs 
	pinSpecs _ Array
		with: (PinSpec new pinName: 'output' direction: #output
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: nil modelWriteSelector: nil
				defaultValue: nil pinLoc: 3.5)
		with: (PinSpec new pinName: 'a' direction: #input
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: nil modelWriteSelector: nil
				defaultValue: nil pinLoc: 1.5)
! !


!FunctionComponent methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:45'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add custom menu items"

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu add: 'add pin' translated target: self selector: #addPin.
! !


!FunctionComponent methodsFor: 'menu commands' stamp: 'di 5/4/1998 08:57'!
accept
	"Inform the model of text to be accepted, and return true if OK."
	| textToAccept oldSelector |
	oldSelector _ functionSelector.
	textToAccept _ textMorph asText.
	textToAccept = self getText ifTrue: [^ self].  "No body to compile yet"
	functionSelector _ model class
		compile: self headerString , textToAccept asString
		classified: 'functions' notifying: nil.
	self setText: textToAccept.
	self hasUnacceptedEdits: false.
	oldSelector ifNotNil:
		[functionSelector = oldSelector ifFalse: [model class removeSelector: oldSelector]].
	self fire! !


!FunctionComponent methodsFor: 'model access' stamp: 'di 5/3/1998 22:12'!
getText
	| ps |
	^ ('"type a function of' ,
		(String streamContents:
			[:s | 2 to: pinSpecs size do:
				[:i | ps _ pinSpecs at: i.
				(i>2 and: [i = pinSpecs size]) ifTrue: [s nextPutAll: ' and'].
				s nextPutAll: ' ', ps pinName]]) ,
		'"') asText! !


!FunctionComponent methodsFor: 'updating' stamp: 'di 5/3/1998 23:25'!
update: aSymbol
	inputSelectors do:
		[:s | aSymbol = s ifTrue: [^ self fire]].! !
EncodedCharSet subclass: #GB2312
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Encodings'!
!GB2312 commentStamp: 'yo 10/19/2004 19:52' prior: 0!
This class represents the domestic character encoding called GB 2312 used for simplified Chinese.
!


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

GB2312 class
	instanceVariableNames: ''!

!GB2312 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:50'!
compoundTextSequence

	^ CompoundTextSequence
! !

!GB2312 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:50'!
initialize
"
	GB2312 initialize
"

	CompoundTextSequence _ String
				streamContents: 
					[:stream | 
					stream nextPut: Character escape.
					stream nextPut: $$.
					stream nextPut: $(.
					stream nextPut: $A].
! !

!GB2312 class methodsFor: 'class methods' stamp: 'yo 8/6/2003 05:30'!
isLetter: char

	| value leading |

	leading _ char leadingChar.
	value _ char charCode.

	leading = 0 ifTrue: [^ super isLetter: char].

	value _ value // 94 + 1.
	^ 1 <= value and: [value < 84].
! !

!GB2312 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:51'!
leadingChar

	^ 2.
! !

!GB2312 class methodsFor: 'class methods' stamp: 'yo 11/24/2002 17:03'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	| c1 c2 |
	state charSize: 2.
	(state g0Leading ~= self leadingChar) ifTrue: [
		state g0Leading: self leadingChar.
		state g0Size: 2.
		aStream basicNextPutAll: CompoundTextSequence.
	].
	c1 _ ascii // 94 + 16r21.
	c2 _ ascii \\ 94 + 16r21.
	^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2).
! !

!GB2312 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'!
ucsTable

	^ UCSTable gb2312Table.
! !
ImageReadWriter subclass: #GIFReadWriter
	instanceVariableNames: 'width height bitsPerPixel colorPalette rowByteSize xpos ypos pass interlace codeSize clearCode eoiCode freeCode maxCode prefixTable suffixTable remainBitCount bufByte bufStream transparentIndex mapOf32 localColorTable delay loopCount offset'
	classVariableNames: 'Extension ImageSeparator Terminator'
	poolDictionaries: ''
	category: 'Graphics-Files'!
!GIFReadWriter commentStamp: '<historical>' prior: 0!
Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved.

Used with permission.  Modified for use in Squeak.!


!GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:43'!
delay: aNumberOrNil
	"Set delay for next image in hundredth (1/100) of seconds"
	delay := aNumberOrNil! !

!GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:39'!
loopCount: aNumber
	"Set looping. This must be done before any image is written!!"
	loopCount := aNumber! !

!GIFReadWriter methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:18'!
nextImage
	"Read in the next GIF image from the stream. Read it all into
memory first for speed."

	| f thisImageColorTable |
	stream class == ReadWriteStream ifFalse: [
		stream binary.
		self on: (ReadWriteStream with: (stream contentsOfEntireFile))].

	localColorTable _ nil.
	self readHeader.
	f _ self readBody.
	self close.
	f == nil ifTrue: [^ self error: 'corrupt GIF file'].

	thisImageColorTable _ localColorTable ifNil: [colorPalette].
	transparentIndex ifNotNil: [
		transparentIndex + 1 > thisImageColorTable size ifTrue: [
			thisImageColorTable _ thisImageColorTable 
				forceTo: transparentIndex + 1 
				paddingWith: Color white
		].
		thisImageColorTable at: transparentIndex + 1 put: Color transparent
	].
	f colors: thisImageColorTable.
	^ f
! !

!GIFReadWriter methodsFor: 'accessing' stamp: 'ar 10/24/2005 22:52'!
nextPutImage: aForm

	| reduced tempForm |
	aForm unhibernate.
	aForm depth > 8 ifTrue:[
		reduced := aForm colorReduced.  "minimize depth"
		reduced depth > 8 ifTrue: [
			"Not enough color space; do it the hard way."
			reduced := reduced asFormOfDepth: 8].
	] ifFalse:[reduced := aForm].
	reduced depth < 8 ifTrue: [
		"writeBitData: expects depth of 8"
		tempForm := reduced class extent: reduced extent depth: 8.
		(reduced isColorForm) ifTrue:[
			tempForm
				copyBits: reduced boundingBox
				from: reduced at: 0@0
				clippingBox: reduced boundingBox
				rule: Form over
				fillColor: nil
				map: nil.
			tempForm colors: reduced colors.
		] ifFalse: [reduced displayOn: tempForm].
		reduced := tempForm.
	].
	(reduced isColorForm) ifTrue:[
		(reduced colorsUsed includes: Color transparent) ifTrue: [
			transparentIndex := (reduced colors indexOf: Color transparent) - 1.
		]
	] ifFalse: [transparentIndex := nil].
	width := reduced width.
	height := reduced height.
	bitsPerPixel := reduced depth.
	colorPalette := reduced colormapIfNeededForDepth: 32.
	interlace := false.
	self writeHeader.
	self writeBitData: reduced bits.
! !

!GIFReadWriter methodsFor: 'accessing' stamp: '6/18/97 13:18 '!
setStream: aStream
	"Feed it in from an existing source"
	stream _ aStream! !

!GIFReadWriter methodsFor: 'accessing' stamp: 'di 9/15/1998 09:53'!
understandsImageFormat
	^('abc' collect: [:x | stream next asCharacter]) = 'GIF'! !


!GIFReadWriter methodsFor: 'stream access' stamp: 'bf 5/29/2003 01:23'!
close
	"Write terminator"
	self nextPut: Terminator.
	^super close! !


!GIFReadWriter methodsFor: 'private'!
checkCodeSize
	(freeCode > maxCode and: [codeSize < 12])
		ifTrue:
			[codeSize _ codeSize + 1.
			maxCode _ (1 bitShift: codeSize) - 1]! !

!GIFReadWriter methodsFor: 'private'!
setParameters: initCodeSize
	clearCode _ 1 bitShift: initCodeSize.
	eoiCode _ clearCode + 1.
	freeCode _ clearCode + 2.
	codeSize _ initCodeSize + 1.
	maxCode _ (1 bitShift: codeSize) - 1! !

!GIFReadWriter methodsFor: 'private'!
updatePixelPosition
	(xpos _ xpos + 1) >= width ifFalse: [^self].
	xpos _ 0.
	interlace
		ifFalse: [ypos _ ypos + 1. ^self].
	pass = 0 ifTrue:
		[(ypos _ ypos + 8) >= height
			ifTrue:
				[pass _ pass + 1.
				ypos _ 4].
		^self].
	pass = 1 ifTrue:
		[(ypos _ ypos + 8) >= height
			ifTrue:
				[pass _ pass + 1.
				ypos _ 2].
		^self].
	pass = 2 ifTrue:
		[(ypos _ ypos + 4) >= height
			ifTrue:
				[pass _ pass + 1.
				ypos _ 1].
		^self].
	pass = 3 ifTrue:
		[ypos _ ypos + 2.
		^self].

	^self error: 'can''t happen'! !


!GIFReadWriter methodsFor: 'private-bits access'!
flushBits
	remainBitCount = 0 ifFalse:
		[self nextBytePut: bufByte.
		remainBitCount _ 0].
	self flushBuffer! !

!GIFReadWriter methodsFor: 'private-bits access'!
nextBits
	| integer readBitCount shiftCount byte |
	integer _ 0.
	remainBitCount = 0
		ifTrue:
			[readBitCount _ 8.
			shiftCount _ 0]
		ifFalse:
			[readBitCount _ remainBitCount.
			shiftCount _ remainBitCount - 8].
	[readBitCount < codeSize]
		whileTrue:
			[byte _ self nextByte.
			byte == nil ifTrue: [^eoiCode].
			integer _ integer + (byte bitShift: shiftCount).
			shiftCount _ shiftCount + 8.
			readBitCount _ readBitCount + 8].
	(remainBitCount _ readBitCount - codeSize) = 0
		ifTrue:	[byte _ self nextByte]
		ifFalse:	[byte _ self peekByte].
	byte == nil ifTrue: [^eoiCode].
	^(integer + (byte bitShift: shiftCount)) bitAnd: maxCode! !

!GIFReadWriter methodsFor: 'private-bits access'!
nextBitsPut: anInteger
	| integer writeBitCount shiftCount |
	shiftCount _ 0.
	remainBitCount = 0
		ifTrue:
			[writeBitCount _ 8.
			integer _ anInteger]
		ifFalse:
			[writeBitCount _ remainBitCount.
			integer _ bufByte + (anInteger bitShift: 8 - remainBitCount)].
	[writeBitCount < codeSize]
		whileTrue:
			[self nextBytePut: ((integer bitShift: shiftCount) bitAnd: 255).
			shiftCount _ shiftCount - 8.
			writeBitCount _ writeBitCount + 8].
	(remainBitCount _ writeBitCount - codeSize) = 0
		ifTrue: [self nextBytePut: (integer bitShift: shiftCount)]
		ifFalse: [bufByte _ integer bitShift: shiftCount].
	^anInteger! !


!GIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:19'!
readBitData
	"using modified Lempel-Ziv Welch algorithm."

	| outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f c packedBits hasLocalColor localColorSize maxOutCodes |

	maxOutCodes _ 4096.
	offset := self readWord@self readWord. "Image Left@Image Top"
	width _ self readWord.
	height _ self readWord.

	"---
	Local Color Table Flag        1 Bit
	Interlace Flag                1 Bit
	Sort Flag                     1 Bit
	Reserved                      2 Bits
	Size of Local Color Table     3 Bits
	----"
	packedBits _ self next.
	interlace _ (packedBits bitAnd: 16r40) ~= 0.
	hasLocalColor _ (packedBits bitAnd: 16r80) ~= 0.
	localColorSize _ 1 bitShift: ((packedBits bitAnd: 16r7) + 1).
	hasLocalColor ifTrue: [localColorTable _ self readColorTable: localColorSize].

	pass _ 0.
	xpos _ 0.
	ypos _ 0.
	rowByteSize _ ((width + 3) // 4) * 4.
	remainBitCount _ 0.
	bufByte _ 0.
	bufStream _ ReadStream on: ByteArray new.

	outCodes _ ByteArray new: maxOutCodes + 1.
	outCount _ 0.
	bitMask _ (1 bitShift: bitsPerPixel) - 1.
	prefixTable _ Array new: 4096.
	suffixTable _ Array new: 4096.

	initCodeSize _ self next.

	self setParameters: initCodeSize.
	bitsPerPixel > 8 ifTrue: [^self error: 'never heard of a GIF that deep'].
	bytes _ ByteArray new: rowByteSize * height.
	[(code _ self readCode) = eoiCode] whileFalse:
		[code = clearCode
			ifTrue:
				[self setParameters: initCodeSize.
				curCode _ oldCode _ code _ self readCode.
				finChar _ curCode bitAnd: bitMask.
				"Horrible hack to avoid running off the end of the bitmap.  Seems to cure problem reading some gifs!!? tk 6/24/97 20:16"
				xpos = 0 ifTrue: [
						ypos < height ifTrue: [
							bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]]
					ifFalse: [bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar].
				self updatePixelPosition]
			ifFalse:
				[curCode _ inCode _ code.
				curCode >= freeCode ifTrue:
					[curCode _ oldCode.
					outCodes at: (outCount _ outCount + 1) put: finChar].
				[curCode > bitMask] whileTrue:
					[outCount > maxOutCodes
						ifTrue: [^self error: 'corrupt GIF file (OutCount)'].
					outCodes at: (outCount _ outCount + 1)
						put: (suffixTable at: curCode + 1).
					curCode _ prefixTable at: curCode + 1].
				finChar _ curCode bitAnd: bitMask.
				outCodes at: (outCount _ outCount + 1) put: finChar.
				i _ outCount.
				[i > 0] whileTrue:
					["self writePixel: (outCodes at: i) to: bits"
					bytes at: (ypos * rowByteSize) + xpos + 1 put: (outCodes at: i).
					self updatePixelPosition.
					i _ i - 1].
				outCount _ 0.
				prefixTable at: freeCode + 1 put: oldCode.
				suffixTable at: freeCode + 1 put: finChar.
				oldCode _ inCode.
				freeCode _ freeCode + 1.
				self checkCodeSize]].
	prefixTable _ suffixTable _ nil.

	f _ ColorForm extent: width@height depth: 8.
	f bits copyFromByteArray: bytes.
	"Squeak can handle depths 1, 2, 4, and 8"
	bitsPerPixel > 4 ifTrue: [^ f].
	"reduce depth to save space"
	c _ ColorForm extent: width@height
		depth: (bitsPerPixel = 3 ifTrue: [4] ifFalse: [bitsPerPixel]).
	f displayOn: c.
	^ c
! !

!GIFReadWriter methodsFor: 'private-decoding' stamp: 'KLC 1/25/2004 14:04'!
readBody
	"Read the GIF blocks. Modified to return a form.  "

	| form extype block blocksize packedFields delay1 |
	form _ nil.
	[stream atEnd] whileFalse: [
		block _ self next.
		block = Terminator ifTrue: [^ form].
		block = ImageSeparator ifTrue: [
			form isNil
				ifTrue: [form _ self readBitData]
				ifFalse: [self skipBitData].
		] ifFalse: [
			block = Extension
				ifFalse: [^ form "^ self error: 'Unknown block type'"].
			"Extension block"
			extype _ self next.	"extension type"
			extype = 16rF9 ifTrue: [  "graphics control"
				self next = 4 ifFalse: [^ form "^ self error: 'corrupt GIF file'"].
				"====
				Reserved                      3 Bits
				Disposal Method               3 Bits
				User Input Flag               1 Bit
				Transparent Color Flag        1 Bit
				==="
 
				packedFields _ self next.
				delay1 := self next.	"delay time 1"
				delay := (self next*256 + delay1) *10.	 "delay time 2"
				transparentIndex _ self next.
				(packedFields bitAnd: 1) = 0 ifTrue: [transparentIndex _ nil].
				self next = 0 ifFalse: [^ form "^ self error: 'corrupt GIF file'"].
			] ifFalse: [
				"Skip blocks"
				[(blocksize _ self next) > 0]
					whileTrue: [
						"Read the block and ignore it and eat the block terminator"
						self next: blocksize]]]]! !

!GIFReadWriter methodsFor: 'private-decoding'!
readCode
	^self nextBits! !

!GIFReadWriter methodsFor: 'private-decoding' stamp: 'RAA 4/25/2001 08:48'!
readColorTable: numberOfEntries

	| array r g b |

	array _ Array new: numberOfEntries.
	1 to: array size do: [ :i |
		r _ self next.  
		g _ self next.  
		b _ self next.
		array at: i put: (Color r: r g: g b: b range: 255)
	].
	^array! !

!GIFReadWriter methodsFor: 'private-decoding' stamp: 'RAA 4/25/2001 08:49'!
readHeader
	| is89 byte hasColorMap |
	(self hasMagicNumber: 'GIF87a' asByteArray)
		ifTrue: [is89 _ false]
		ifFalse: [(self hasMagicNumber: 'GIF89a' asByteArray)
			ifTrue: [is89 _ true]
			ifFalse: [^ self error: 'This does not appear to be a GIF file']].
	self readWord.	"skip Screen Width"
	self readWord.	"skip Screen Height"
	byte _ self next.
	hasColorMap _ (byte bitAnd: 16r80) ~= 0.
	bitsPerPixel _ (byte bitAnd: 7) + 1.
	byte _ self next.	"skip background color."
	self next ~= 0
		ifTrue: [is89
			ifFalse: [^self error: 'corrupt GIF file (screen descriptor)']].
	hasColorMap
		ifTrue:
			[colorPalette _ self readColorTable: (1 bitShift: bitsPerPixel)]
		ifFalse:
			["Transcript cr; show: 'GIF file does not have a color map.'."
			colorPalette _ nil "Palette monochromeDefault"].! !

!GIFReadWriter methodsFor: 'private-decoding'!
readWord
	^self next + (self next bitShift: 8)! !

!GIFReadWriter methodsFor: 'private-decoding'!
skipBitData
	| misc blocksize |
	self readWord.  "skip Image Left"
	self readWord.  "skip Image Top"
	self readWord.  "width"
	self readWord.  "height"
	misc _ self next.
	(misc bitAnd: 16r80) = 0 ifFalse: [ "skip colormap"
		1 to: (1 bitShift: (misc bitAnd: 7) + 1) do: [:i |
			self next; next; next]].
	self next.  "minimum code size"
	[(blocksize _ self next) > 0]
		whileTrue: [self next: blocksize]! !


!GIFReadWriter methodsFor: 'private-encoding'!
flushCode
	self flushBits! !

!GIFReadWriter methodsFor: 'private-encoding' stamp: 'tk 9/14/97 16:25'!
readPixelFrom: bits
	"Since bits is a Bitmap with 32 bit values, watch out for the
padding at the end of each row.  But, GIF format already wants padding to
32 bit boundary!!  OK as is.  tk 9/14/97"

	| pixel |
	ypos >= height ifTrue: [^nil].
	pixel _ bits byteAt: (ypos * rowByteSize + xpos + 1).
	self updatePixelPosition.
	^pixel! !

!GIFReadWriter methodsFor: 'private-encoding' stamp: 'bf 5/29/2003 01:21'!
writeBitData: bits
	"using modified Lempel-Ziv Welch algorithm."

	| maxBits maxMaxCode tSize initCodeSize ent tShift fCode pixel index disp nomatch |
	pass _ 0.
	xpos _ 0.
	ypos _ 0.
	rowByteSize _ width * 8 + 31 // 32 * 4.
	remainBitCount _ 0.
	bufByte _ 0.
	bufStream _ WriteStream on: (ByteArray new: 256).

	maxBits _ 12.
	maxMaxCode _ 1 bitShift: maxBits.
	tSize _ 5003.
	prefixTable _ Array new: tSize.
	suffixTable _ Array new: tSize.

	initCodeSize _ bitsPerPixel <= 1 ifTrue: [2] ifFalse: [bitsPerPixel].
	self nextPut: initCodeSize.
	self setParameters: initCodeSize.

	tShift _ 0.
	fCode _ tSize.
	[fCode < 65536] whileTrue:
		[tShift _ tShift + 1.
		fCode _ fCode * 2].
	tShift _ 8 - tShift.
	1 to: tSize do: [:i | suffixTable at: i put: -1].

	self writeCodeAndCheckCodeSize: clearCode.
	ent _ self readPixelFrom: bits.
	[(pixel _ self readPixelFrom: bits) == nil] whileFalse:
		[
		fCode _ (pixel bitShift: maxBits) + ent.
		index _ ((pixel bitShift: tShift) bitXor: ent) + 1.
		(suffixTable at: index) = fCode
			ifTrue: [ent _ prefixTable at: index]
			ifFalse:
				[nomatch _ true.
				(suffixTable at: index) >= 0
					ifTrue:
						[disp _ tSize - index + 1.
						index = 1 ifTrue: [disp _ 1].
						"probe"
						[(index _ index - disp) < 1 ifTrue: [index _ index + tSize].
						(suffixTable at: index) = fCode
							ifTrue:
								[ent _ prefixTable at: index.
								nomatch _ false.
								"continue whileFalse:"].
						nomatch and: [(suffixTable at: index) > 0]]
							whileTrue: ["probe"]].
				"nomatch"
				nomatch ifTrue:
					[self writeCodeAndCheckCodeSize: ent.
					ent _ pixel.
					freeCode < maxMaxCode
						ifTrue:
							[prefixTable at: index put: freeCode.
							suffixTable at: index put: fCode.
							freeCode _ freeCode + 1]
						ifFalse:
							[self writeCodeAndCheckCodeSize: clearCode.
							1 to: tSize do: [:i | suffixTable at: i put: -1].
							self setParameters: initCodeSize]]]].
	prefixTable _ suffixTable _ nil.
	self writeCodeAndCheckCodeSize: ent.
	self writeCodeAndCheckCodeSize: eoiCode.
	self flushCode.

	self nextPut: 0.	"zero-length packet"
! !

!GIFReadWriter methodsFor: 'private-encoding'!
writeCode: aCode
	self nextBitsPut: aCode! !

!GIFReadWriter methodsFor: 'private-encoding'!
writeCodeAndCheckCodeSize: aCode
	self writeCode: aCode.
	self checkCodeSize! !

!GIFReadWriter methodsFor: 'private-encoding' stamp: 'bf 5/29/2003 01:38'!
writeHeader

	| byte |
	stream position = 0 ifTrue: [
		"For first image only"
		self nextPutAll: 'GIF89a' asByteArray.
		self writeWord: width.	"Screen Width"
		self writeWord: height.	"Screen Height"
		byte _ 16r80.  "has color map"
		byte _ byte bitOr: ((bitsPerPixel - 1) bitShift: 5).  "color resolution"
		byte _ byte bitOr: bitsPerPixel - 1.  "bits per pixel"
		self nextPut: byte.
		self nextPut: 0.		"background color."
		self nextPut: 0.		"reserved"
		colorPalette do: [:pixelValue |
			self	nextPut: ((pixelValue bitShift: -16) bitAnd: 255);
				nextPut: ((pixelValue bitShift: -8) bitAnd: 255);
				nextPut: (pixelValue bitAnd: 255)].
		loopCount notNil ifTrue: [
			"Write a Netscape loop chunk"
			self nextPut: Extension.
			self nextPutAll: #(255 11 78 69 84 83 67 65 80 69 50 46 48 3 1) asByteArray.
			self writeWord: loopCount.
			self nextPut: 0]].

	delay notNil | transparentIndex notNil ifTrue: [
		self nextPut: Extension;
			nextPutAll: #(16rF9 4) asByteArray;
			nextPut: (transparentIndex isNil ifTrue: [0] ifFalse: [9]);
			writeWord: (delay isNil ifTrue: [0] ifFalse: [delay]);
			nextPut: (transparentIndex isNil ifTrue: [0] ifFalse: [transparentIndex]);
			nextPut: 0].

	self nextPut: ImageSeparator.
	self writeWord: 0.		"Image Left"
	self writeWord: 0.		"Image Top"
	self writeWord: width.	"Image Width"
	self writeWord: height.	"Image Height"
	byte _ interlace ifTrue: [16r40] ifFalse: [0].
	self nextPut: byte.
! !

!GIFReadWriter methodsFor: 'private-encoding'!
writeWord: aWord
	self nextPut: (aWord bitAnd: 255).
	self nextPut: ((aWord bitShift: -8) bitAnd: 255).
	^aWord! !


!GIFReadWriter methodsFor: 'private-packing'!
fillBuffer
	| packSize |
	packSize _ self next.
	bufStream _ ReadStream on: (self next: packSize)! !

!GIFReadWriter methodsFor: 'private-packing'!
flushBuffer
	bufStream isEmpty ifTrue: [^self].
	self nextPut: bufStream size.
	self nextPutAll: bufStream contents.
	bufStream _ WriteStream on: (ByteArray new: 256)! !

!GIFReadWriter methodsFor: 'private-packing'!
nextByte
	bufStream atEnd
		ifTrue:
			[self atEnd ifTrue: [^nil].
			self fillBuffer].
	^bufStream next! !

!GIFReadWriter methodsFor: 'private-packing'!
nextBytePut: aByte
	bufStream nextPut: aByte.
	bufStream size >= 254 ifTrue: [self flushBuffer]! !

!GIFReadWriter methodsFor: 'private-packing'!
peekByte
	bufStream atEnd
		ifTrue:
			[self atEnd ifTrue: [^nil].
			self fillBuffer].
	^bufStream peek! !

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

GIFReadWriter class
	instanceVariableNames: ''!

!GIFReadWriter class methodsFor: 'class initialization'!
initialize
	"GIFReadWriter initialize"

	ImageSeparator _ $, asInteger.
	Extension _ $!! asInteger.
	Terminator _ $; asInteger.
! !


!GIFReadWriter class methodsFor: 'examples' stamp: 'bf 5/29/2003 01:56'!
exampleAnim
	"GIFReadWriter exampleAnim"

	| writer extent center |
	writer := GIFReadWriter on: (FileStream newFileNamed: 'anim.gif').
	writer loopCount: 20.		"Repeat 20 times"
	writer delay: 10.		"Wait 10/100 seconds"
	extent := 42@42.
	center := extent / 2.
	Cursor write showWhile: [
		[2 to: center x - 1 by: 2 do: [:r |
			"Make a fancy anim without using Canvas - inefficient as hell"
			| image |
			image := ColorForm extent: extent depth: 8.
			0.0 to: 359.0 do: [:theta | image colorAt: (center + (Point r: r degrees: theta)) rounded put: Color red].
			writer nextPutImage: image]
		]	ensure: [writer close]].! !

!GIFReadWriter class methodsFor: 'examples' stamp: 'nk 7/30/2004 21:40'!
grabScreenAndSaveOnDisk
	"GIFReaderWriter grabScreenAndSaveOnDisk"

	| form fileName |
	form := Form fromUser.
	form bits size = 0 ifTrue: [^Beeper beep].
	fileName := FileDirectory default nextNameFor: 'Squeak' extension: 'gif'.
	Utilities informUser: 'Writing ' , fileName
		during: [GIFReadWriter putForm: form onFileNamed: fileName]! !


!GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can 
	read might commonly have"

	self
		allSubclasses detect: [:cls | cls wantsToHandleGIFs ]
					 ifNone: ["if none of my subclasses wants , then i''ll have to do"
							^ #('gif' )].
	^ #( )! !

!GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'!
wantsToHandleGIFs
	^ false! !
SoundCodec subclass: #GSMCodec
	instanceVariableNames: 'encodeState decodeState'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:33'!
primDecode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex

	<primitive: 'primitiveGSMDecode' module: 'SoundCodecPrims'>
	self primitiveFailed.
! !

!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:33'!
primEncode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex

	<primitive: 'primitiveGSMEncode' module: 'SoundCodecPrims'>
	self primitiveFailed.
! !

!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:35'!
primNewState

	<primitive: 'primitiveGSMNewState' module: 'SoundCodecPrims'>
	self error: 'The SoundCodecPrims plugin is not available'.
! !


!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:36'!
bytesPerEncodedFrame

	^ 33
! !

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex

	| p |
	p := self	primDecode: decodeState frames: frameCount
			from: srcByteArray at: srcIndex
			into: dstSoundBuffer at: dstIndex.
	^ Array with: p x with: p y
! !

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex

	| p |
	p := self	primEncode: encodeState frames: frameCount
			from: srcSoundBuffer at: srcIndex
			into: dstByteArray at: dstIndex.
	^ Array with: p x with: p y
! !

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset
	"Reset my encoding/decoding state to prepare to encode or decode a new sound stream."

	encodeState := self primNewState.
	decodeState := self primNewState.
! !

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:36'!
samplesPerFrame

	^ 160
! !

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

GSMCodec class
	instanceVariableNames: ''!

!GSMCodec class methodsFor: 'instance creation' stamp: 'jm 10/21/2001 10:10'!
new

	^ super new reset
! !
SharedPool subclass: #GZipConstants
	instanceVariableNames: ''
	classVariableNames: 'GZipAsciiFlag GZipCommentFlag GZipContinueFlag GZipDeflated GZipEncryptFlag GZipExtraField GZipMagic GZipNameFlag GZipReservedFlags'
	poolDictionaries: ''
	category: 'Compression-Streams'!

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

GZipConstants class
	instanceVariableNames: ''!

!GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'!
gzipMagic
	^GZipMagic! !

!GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'!
initialize
	"GZipConstants initialize"
	GZipMagic := 16r8B1F.		"GZIP magic number"
	GZipDeflated := 8.			"Compression method"

	GZipAsciiFlag := 16r01.		"Contents is ASCII"
	GZipContinueFlag := 16r02.	"Part of a multi-part archive"
	GZipExtraField := 16r04.		"Archive has extra fields"
	GZipNameFlag := 16r08.		"Archive has original file name"
	GZipCommentFlag := 16r10.	"Archive has comment"
	GZipEncryptFlag := 16r20.	"Archive is encrypted"
	GZipReservedFlags := 16rC0.	"Reserved" ! !
FastInflateStream subclass: #GZipReadStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'GZipConstants'
	category: 'Compression-Streams'!

!GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:30'!
updateCrc: oldCrc from: start to: stop in: aCollection
	"Answer an updated CRC for the range of bytes in aCollection"
	^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection.! !

!GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:20'!
verifyCrc
	| stored |
	stored := 0.
	0 to: 24 by: 8 do: [ :i |
		sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ].
		stored := stored + (self nextByte bitShift: i) ].
	stored := stored bitXor: 16rFFFFFFFF.
	stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ].
	^stored! !


!GZipReadStream methodsFor: 'initialize' stamp: 'ar 2/29/2004 03:32'!
on: aCollection from: firstIndex to: lastIndex
	"Check the header of the GZIP stream."
	| method magic flags length |
	super on: aCollection from: firstIndex to: lastIndex.
	crc := 16rFFFFFFFF.
	magic := self nextBits: 16.
	(magic = GZipMagic) 
		ifFalse:[^self error:'Not a GZipped stream'].
	method := self nextBits: 8.
	(method = GZipDeflated)
		ifFalse:[^self error:'Bad compression method'].
	flags := self nextBits: 8.
	(flags anyMask: GZipEncryptFlag) 
		ifTrue:[^self error:'Cannot decompress encrypted stream'].
	(flags anyMask: GZipReservedFlags)
		ifTrue:[^self error:'Cannot decompress stream with unknown flags'].
	"Ignore stamp, extra flags, OS type"
	self nextBits: 16; nextBits: 16. "stamp"
	self nextBits: 8. "extra flags"
	self nextBits: 8. "OS type"
	(flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored"
		ifTrue:[self nextBits: 16]. 
	(flags anyMask: GZipExtraField) "Extra fields - ignored"
		ifTrue:[	length := self nextBits: 16.
				1 to: length do:[:i| self nextBits: 8]].
	(flags anyMask: GZipNameFlag) "Original file name - ignored"
		ifTrue:[[(self nextBits: 8) = 0] whileFalse].
	(flags anyMask: GZipCommentFlag) "Comment - ignored"
		ifTrue:[[(self nextBits: 8) = 0] whileFalse].
! !

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

GZipReadStream class
	instanceVariableNames: ''!

!GZipReadStream class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'!
unload

	FileList unregisterFileReader: self ! !


!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'yo 8/18/2004 20:24'!
fileIn: fullFileName
	"FileIn the contents of a gzipped file"
	| zipped unzipped |
	zipped := self on: (FileStream readOnlyFileNamed: fullFileName).
	unzipped := MultiByteBinaryOrTextStream with: (zipped contents asString).
	unzipped reset.
	unzipped fileIn.
! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 21:32'!
fileIntoNewChangeSet: fullFileName
	"FileIn the contents of a gzipped file"
	| zipped unzipped cs |
	cs := Smalltalk at: #ChangeSorter ifAbsent: [ ^self ].
	zipped := self on: (FileStream readOnlyFileNamed: fullFileName).
	unzipped := MultiByteBinaryOrTextStream with: zipped contents asString.
	unzipped reset.
	cs newChangesFromStream: unzipped named: (FileDirectory localNameFor: fullFileName)
! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 21:10'!
fileReaderServicesForFile: fullName suffix: suffix 
	| services |
	(suffix = 'gz') | (suffix = '*')
		ifFalse: [^ #()].
	services := OrderedCollection new.
	(suffix = '*') | (fullName asLowercase endsWith: '.cs.gz') | (fullName asLowercase endsWith: '.mcs.gz')
		ifTrue: [services add: self serviceFileIn.
			(Smalltalk includesKey: #ChangeSorter)
				ifTrue: [services add: self serviceFileIntoNewChangeSet]].
	services addAll: self services.
	^ services! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'LEG 10/24/2001 23:56'!
saveContents: fullFileName
	"Save the contents of a gzipped file"
	| zipped buffer unzipped newName |
	newName := fullFileName copyUpToLast: FileDirectory extensionDelimiter.
	unzipped := FileStream newFileNamed: newName.
	unzipped binary.
	zipped := GZipReadStream on: (FileStream readOnlyFileNamed: fullFileName).
	buffer := ByteArray new: 50000.
	'Extracting ' , fullFileName
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: zipped sourceStream size
		during: 
			[:bar | 
			[zipped atEnd]
				whileFalse: 
					[bar value: zipped sourceStream position.
					unzipped nextPutAll: (zipped nextInto: buffer)].
			zipped close.
			unzipped close].
	^ newName! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 11/26/2002 12:11'!
serviceDecompressToFile

	^ FileModifyingSimpleServiceEntry 
				provider: self 
				label: 'decompress to file'
				selector: #saveContents:
				description: 'decompress to file'! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 11:14'!
serviceFileIn
	"Answer a service for filing in an entire file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'fileIn entire file'
		selector: #fileIn:
		description: 'file in the entire decompressed contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format'
		buttonLabel: 'filein'

! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 11:26'!
serviceFileIntoNewChangeSet
	"Answer a service for filing in an entire file"
	^ SimpleServiceEntry
		provider: self
		label: 'install into new change set'
		selector: #fileIntoNewChangeSet:
		description: 'install the decompressed contents of the file as a body of code in the image: create a new change set and file-in the selected file into it'
		buttonLabel: 'install'! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:15'!
serviceViewDecompress

	^ SimpleServiceEntry 
				provider: self 
				label: 'view decompressed'
				selector: #viewContents:
				description: 'view decompressed' 
! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:16'!
services

	^ Array 
		with: self serviceViewDecompress
		with: self serviceDecompressToFile
	! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'dgd 9/21/2003 17:46'!
uncompressedFileName: fullName
	^((fullName endsWith: '.gz') and: [self confirm: ('{1}
appears to be a compressed file.
Do you want to uncompress it?' translated format:{fullName})])
		ifFalse: [fullName]
		ifTrue:[self saveContents: fullName]! !

!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'sw 3/12/2002 19:34'!
viewContents: fullFileName
	"Open the decompressed contents of the .gz file with the given name.  This method is only required for the registering-file-list of Squeak 3.3a and beyond, but does no harm in an earlier system"

	(FileStream readOnlyFileNamed: fullFileName) ifNotNilDo:
		[:aStream | aStream viewGZipContents]! !
Object subclass: #GZipSurrogateStream
	instanceVariableNames: 'gZipStream zippedFileStream bufferStream positionThusFar'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Streams'!
!GZipSurrogateStream commentStamp: '<historical>' prior: 0!
A pseudo stream that allows SmartRefStream to write directly to a gzipped file. There are some peculiarities of the project exporting process that require:

1. We ignore #close since the file is closed and may be reopened to continue writing. We implement #reallyClose for when we know that all writing is over.

2. We use a BitBlt to write WordArrayForSegment objects. Bit of a hack, but there it is.

| fileStream wa |

wa _ WordArrayForSegment new: 30000.
1 to: wa size do: [ :i | wa at: i put: i].
fileStream _ GZipSurrogateStream newFileNamed: 'xxx3.gz' inDirectory: FileDirectory default.
fileStream nextPutAll: 'this is a test'.
fileStream nextPutAll: wa.
fileStream reallyClose.
!


!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
ascii

	self bufferStream ascii! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'!
binary

	self bufferStream binary! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:43'!
bufferStream

	^bufferStream ifNil: [bufferStream := RWBinaryOrTextStream on: (ByteArray new: 5000)].
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:26'!
close
	
	"we don't want to until user is really done"
	

! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:26'!
closed

	^false! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:59'!
command: aString
	"Overridden by HtmlFileStream to append commands directly without translation.  4/5/96 tk"
	"We ignore any HTML commands.  Do nothing"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
cr

	self bufferStream cr! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:18'!
fileOutClass: extraClass andObject: theObject
	"Write a file that has both the source code for the named class and an object as bits.  Any instance-specific object will get its class written automatically."

	| class srefStream |

	self timeStamp.

	extraClass ifNotNil: [
		class := extraClass.	"A specific class the user wants written"
		class sharedPools size > 0 ifTrue: [
			class shouldFileOutPools ifTrue: [class fileOutSharedPoolsOn: self]
		].
		class fileOutOn: self moveSource: false toFile: 0
	].

	"Append the object's raw data"
	srefStream := SmartRefStream on: self.
	srefStream nextPut: theObject.  "and all subobjects"
	srefStream close.		"also closes me - well it thinks it does, anyway"
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:16'!
flushBuffer

	| data |
	bufferStream ifNil: [^self].
	data := bufferStream contents asByteArray.
	gZipStream nextPutAll: data.
	positionThusFar := positionThusFar + data size.
	bufferStream := nil.
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:36'!
header

	"ignore"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:12'!
newFileNamed: fName inDirectory: aDirectory

	positionThusFar := 0.
	zippedFileStream := aDirectory newFileNamed: fName.
	zippedFileStream binary; setFileTypeToObject.
		"Type and Creator not to be text, so can be enclosed in an email"
	gZipStream := GZipWriteStream on: zippedFileStream.
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:23'!
next

	^self bufferStream next! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'!
nextChunkPut: aString

	self bufferStream nextChunkPut: aString! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'!
nextInt32Put: int32

	^self bufferStream nextInt32Put: int32
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
nextNumber: n put: v 

	^self bufferStream nextNumber: n put: v 
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
nextPut: aByte

	^self bufferStream nextPut: aByte
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:24'!
nextPutAll: aString

	^aString writeOnGZIPByteStream: self
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
nextPutAllBytes: aString

	^self bufferStream nextPutAll: aString
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:36'!
nextPutAllWordArray: aWordArray

	| ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining |

	self flag: #bob.		"do we need to be concerned by bytesPerElement??"
	ba := nil.
	rowsAtATime := 2000.		"or 8000 bytes"
	hackwa := Form new hackBits: aWordArray.
	sourceOrigin := 0@0.
	[(rowsRemaining := hackwa height - sourceOrigin y) > 0] whileTrue: [
		rowsAtATime := rowsAtATime min: rowsRemaining.
		(ba isNil or: [ba size ~= (rowsAtATime * 4)]) ifTrue: [
			ba := ByteArray new: rowsAtATime * 4.
			hackba := Form new hackBits: ba.
			blt := (BitBlt toForm: hackba) sourceForm: hackwa.
		].
		blt 
			combinationRule: Form over;
			sourceOrigin: sourceOrigin;
			destX: 0 destY: 0 width: 4 height: rowsAtATime;
			copyBits.
		self bufferStream nextPutAll: ba.
		self flushBuffer.
		sourceOrigin := sourceOrigin x @ (sourceOrigin y + rowsAtATime).
	].
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:42'!
nextStringPut: s 
	"Append the string, s, to the receiver.  Only used by DataStream.  Max size of 64*256*256*256."

	| length |
	(length := s size) < 192
		ifTrue: [self nextPut: length]
		ifFalse: 
			[self nextPut: (length digitAt: 4)+192.
			self nextPut: (length digitAt: 3).
			self nextPut: (length digitAt: 2).
			self nextPut: (length digitAt: 1)].
	self nextPutAll: s.
	^s! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2001 19:08'!
nextWordsPutAll: aCollection
	"Write the argument a word-like object in big endian format on the receiver.
	May be used to write other than plain word-like objects (such as ColorArray)."
	^self nextPutAllWordArray: aCollection! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:22'!
originalContents

	^''		"used only to determine if we are byte-structured"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:26'!
padToEndWith: aChar
	"We don't have pages, so we are at the end, and don't need to pad."! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:12'!
position

	^self bufferStream position + positionThusFar! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:13'!
reallyClose

	self flushBuffer.
	gZipStream close.
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:30'!
reopen

	"ignore"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:36'!
setFileTypeToObject

	"ignore"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:30'!
setToEnd

	"ignore"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:21'!
skip: aNumber

	^self bufferStream skip: aNumber
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'nk 7/29/2004 10:10'!
timeStamp
	"Append the current time to the receiver as a String."
	self bufferStream nextChunkPut:	"double string quotes and !!s"
		(String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString.
	self bufferStream cr! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:37'!
trailer

	"ignore"! !

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

GZipSurrogateStream class
	instanceVariableNames: ''!

!GZipSurrogateStream class methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 11:50'!
newFileNamed: fName inDirectory: aDirectory

	^self new newFileNamed: fName inDirectory: aDirectory! !
ZipWriteStream subclass: #GZipWriteStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'GZipConstants'
	category: 'Compression-Streams'!

!GZipWriteStream methodsFor: 'initialize-release' stamp: 'nk 2/19/2004 08:31'!
writeFooter
	"Write some footer information for the crc"
	super writeFooter.
	0 to: 3 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)].
	0 to: 3 do:[:i| encoder nextBytePut: (bytesWritten >> (i*8) bitAnd: 255)].! !

!GZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 11:41'!
writeHeader
	"Write the GZip header"
	encoder nextBits: 16 put: GZipMagic.
	encoder nextBits: 8 put: GZipDeflated.
	encoder nextBits: 8 put: 0. "No flags"
	encoder nextBits: 32 put: 0. "no time stamp"
	encoder nextBits: 8 put: 0. "No extra flags"
	encoder nextBits: 8 put: 0. "No OS type"
! !

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

GZipWriteStream class
	instanceVariableNames: ''!

!GZipWriteStream class methodsFor: 'class initialization' stamp: 'nk 11/26/2002 13:09'!
initialize
	FileList registerFileReader: self! !

!GZipWriteStream class methodsFor: 'class initialization' stamp: 'nk 11/26/2002 13:09'!
unload
	FileList unregisterFileReader: self! !


!GZipWriteStream class methodsFor: 'file list services' stamp: 'sw 11/30/2002 00:11'!
compressFile: fileName
	"Create a compressed file from the file of the given name"

	(FileStream readOnlyFileNamed: fileName) compressFile! !

!GZipWriteStream class methodsFor: 'file list services' stamp: 'st 9/18/2004 23:44'!
fileReaderServicesForFile: fullName suffix: suffix
	"Don't offer to compress already-compressed files
	sjc 3-May 2003-added jpeg extension"

	^({ 'gz' . 'sar' . 'zip' . 'gif' . 'jpg' . 'jpeg'. 'pr'. 'png'} includes: suffix)
		ifTrue: [ #() ]
		ifFalse: [ self services ]
! !

!GZipWriteStream class methodsFor: 'file list services' stamp: 'nk 11/26/2002 13:17'!
serviceCompressFile

	^ FileModifyingSimpleServiceEntry 
				provider: self 
				label: 'compress file'
				selector: #compressFile:
				description: 'compress file using gzip compression, making a new file'! !

!GZipWriteStream class methodsFor: 'file list services' stamp: 'nk 11/26/2002 13:10'!
services
	^ { self serviceCompressFile }! !
GesturalEvent subclass: #GazeGesturalEvent
	instanceVariableNames: 'point'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!GazeGesturalEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 03:17'!
point
	^ point! !

!GazeGesturalEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
point: aPoint
	point := aPoint! !


!GazeGesturalEvent methodsFor: 'playing' stamp: 'len 9/6/1999 00:42'!
actOn: aHeadMorph
	aHeadMorph face lookAt: self point! !


!GazeGesturalEvent methodsFor: 'printing' stamp: 'len 9/6/1999 00:42'!
printOn: aStream
	aStream nextPutAll: 'look at '; print: self point! !
BookMorph subclass: #GeeBookMorph
	instanceVariableNames: 'geeMail'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!GeeBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 11:48'!
geeMail: aGeeMail

	geeMail _ aGeeMail.! !

!GeeBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:13'!
geePageRectangles

	| pageBounds allPageRects |

	pageBounds _ geeMail topLeft 
			extent: geeMail width @ (geeMail height min: Display height - 50).
	allPageRects _ OrderedCollection new.
	[pageBounds top <= geeMail bottom] whileTrue: [
		allPageRects add: pageBounds.
		pageBounds _ pageBounds translateBy: 0 @ pageBounds height.
	].
	^allPageRects
! !

!GeeBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:44'!
rebuildPages

	pages _ self geePageRectangles collect: [ :each |
		GeeBookPageMorph new 
			disableDragNDrop;
			geeMail: geeMail geeMailRectangle: each.
	].
	currentPage delete.
	currentPage _ nil.
	pages isEmpty ifTrue: [^ self insertPage].
	self goToPage: 1.

! !


!GeeBookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.909
		g: 0.819
		b: 0.09! !

!GeeBookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:10'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	newPagePrototype _ GeeBookPageMorph new extent: Display extent // 3 ! !

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

GeeBookMorph class
	instanceVariableNames: ''!

!GeeBookMorph class methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:07'!
includeInNewMorphMenu

	^ false! !
PasteUpMorph subclass: #GeeBookPageMorph
	instanceVariableNames: 'geeMail geeMailRectangle'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!GeeBookPageMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 11:57'!
geeMail: aGeeMail geeMailRectangle: aRectangle

	geeMail _ aGeeMail.
	geeMailRectangle _ aRectangle.
	self extent: aRectangle extent.! !


!GeeBookPageMorph methodsFor: 'drawing' stamp: 'RAA 10/3/2000 12:40'!
fullDrawOn: aCanvas

	aCanvas 
		translateTo: self topLeft + aCanvas origin - geeMailRectangle origin 
		clippingTo: (bounds translateBy: aCanvas origin) 
		during: [ :c |
			geeMail disablePageBreaksWhile: [geeMail fullDrawOn: c].
		].
! !


!GeeBookPageMorph methodsFor: 'event handling' stamp: 'RAA 10/3/2000 13:51'!
mouseDown: evt
	"Handle a mouse down event."

	
	"{evt. self recipientForMouseDown: evt. self} explore."
! !

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

GeeBookPageMorph class
	instanceVariableNames: ''!

!GeeBookPageMorph class methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:07'!
includeInNewMorphMenu

	^ false! !
ScrollPane subclass: #GeeMailMorph
	instanceVariableNames: 'theTextMorph thePasteUp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!
!GeeMailMorph commentStamp: '<historical>' prior: 0!
GeeMail is a scrolling playfield with a text morph (typically on the left) and room on the right for other morphs to be placed. The morphs on the right can be linked to text selections on the left so that they remain positioned beside the pertinent text as the text is reflowed. Probably the best thing is and example and Alan will be making some available soon.!


!GeeMailMorph methodsFor: 'access' stamp: 'RAA 9/6/2000 16:25'!
wantsSlot

	^false! !


!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/30/2003 20:50'!
addGeeMailMenuItemsTo: menu

	self flag: #convertToBook.	"<-- no longer used"
	menu 
		addUpdating: #showPageBreaksString action: #togglePageBreaks;
		addUpdating: #keepScrollbarString action: #toggleKeepScrollbar;
		addLine;
		add: 'Print...' translated action: #printPSToFile;
		addLine.
	thePasteUp allTextPlusMorphs size = 1 ifTrue: [
		menu add: 'make 1-column book' translated selector: #makeBookStyle: argument: 1.
		menu add: 'make 2-column book' translated selector: #makeBookStyle: argument: 2.
		menu add: 'make 3-column book' translated selector: #makeBookStyle: argument: 3.
		menu add: 'make 4-column book' translated selector: #makeBookStyle: argument: 4.
	] ifFalse: [
		menu add: 'make a galley of me' translated action: #makeGalleyStyle.
	].
	^menu! !

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

	| newBottom |

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

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:42'!
allTextPlusMorphs

	^thePasteUp allTextPlusMorphs! !

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

	GeeBookMorph new 
		geeMail: thePasteUp;
		rebuildPages;
		openInWorld! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:57'!
keepScrollBarAlways

	^self valueOfProperty: #keepScrollBarAlways ifAbsent: [false]! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:59'!
keepScrollbarString

	^self keepScrollBarAlways ifTrue: ['<on>scrollbar stays up'] ifFalse: ['<off>scrollbar stays up']! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2001 11:15'!
makeBookStyle: nColumns

	| all totalWidth second columnWidth currY prev columnHeight currX currColumn pageBreakRectangles r rm columnGap pageGap starter |

	pageBreakRectangles _ OrderedCollection new.
	all _ thePasteUp allTextPlusMorphs.
	all size = 1 ifFalse: [^self].
	Cursor wait show.
	starter _ prev _ all first.
	totalWidth _ self width - 16.
	columnGap _ 32.
	pageGap _ 16.
	columnWidth _ totalWidth - (columnGap * (nColumns - 1)) // nColumns.
	columnHeight _ self height - 12.
	currY _ 4.
	currX _ 4.
	currColumn _ 1.
	prev
		position: currX@currY;
		width: columnWidth.
	[
		second _ prev makeSuccessorMorph.
		thePasteUp addMorphBack: second.
		prev 
			setProperty: #autoFitContents toValue: false;
			height: columnHeight.
		(currColumn _ currColumn + 1) <= nColumns ifTrue: [
			currX _ currX + columnWidth + columnGap.
		] ifFalse: [
			r _ 4@(prev bottom + 4) corner: (self right - 4 @ (prev bottom + pageGap - 4)).
			rm _ RectangleMorph new bounds: r; color: (Color gray alpha: 0.3); borderWidth: 0.
			pageBreakRectangles add: rm beSticky.
			thePasteUp addMorphBack: rm.
			currColumn _ 1.
			currX _ 4.
			currY _ prev bottom + pageGap.
		].
		second 
			autoFit: true;
			position: currX@currY;
			width: columnWidth.
		prev recomposeChain.		"was commented"
		prev _ second.
		prev height > columnHeight
	] whileTrue.
	prev autoFit: true.
	thePasteUp height: (prev bottom + 20 - self top).
	self layoutChanged.
	self setProperty: #pageBreakRectangles toValue: pageBreakRectangles.
	thePasteUp allTextPlusMorphs do: [ :each |
		each repositionAnchoredMorphs
	].
	Cursor normal show.
! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2001 12:12'!
makeGalleyStyle

	| all first theRest |

	(self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]) do: [ :each |
		each delete
	].
	self removeProperty: #pageBreakRectangles.
	all _ thePasteUp allTextPlusMorphs.
	first _ all select: [ :x | x predecessor isNil].
	first size = 1 ifFalse: [^self].
	Cursor wait show.
	first _ first first.
	theRest _ all reject: [ :x | x predecessor isNil].
	theRest do: [ :each | each delete].
	first autoFit: true.
	first width: self width - 8.
	first recomposeChain.
	first repositionAnchoredMorphs.
	Cursor normal show.
! !

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

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

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:25'!
pageRectanglesForPrinting

	| pageBreaks prevBottom pageRects r |

	pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [^nil].
	prevBottom _ 0.
	pageRects _ pageBreaks collect: [ :each |
		r _ 0@prevBottom corner: self width @ each top.
		prevBottom _ each bottom.
		r
	].
	pageRects add: (0@prevBottom corner: self width @ thePasteUp bottom).
	^pageRects! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 09:21'!
scrollSelectionIntoView: event alignTop: alignTop inTextMorph: tm
	"Scroll my text into view if necessary and return true, else return false"

	| selRects delta selRect rectToTest transform cpHere |

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

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 13:06'!
scrollToPage: pageNumber

	| rects oneRect |

	rects _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()].
	oneRect _ rects at: pageNumber - 1 ifAbsent: [0@0 extent: 0@0].
	self scrollToYAbsolute: oneRect bottom.
! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 13:01'!
scrollToYAbsolute: yValue

	| transform transformedPoint |

	transform _ scroller transformFrom: self.
	transformedPoint _ transform localPointToGlobal: 0@yValue.

	self scrollBy: 0@(bounds top - transformedPoint y).
! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:10'!
showPageBreaksString

	^(thePasteUp ifNil: [^'???']) showPageBreaksString! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:58'!
toggleKeepScrollbar

	self setProperty: #keepScrollBarAlways toValue: self keepScrollBarAlways not! !

!GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:12'!
togglePageBreaks

	(thePasteUp ifNil: [^self]) togglePageBreaks! !


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

	^false! !


!GeeMailMorph methodsFor: 'event handling' stamp: 'RAA 5/3/2001 17:33'!
handlesMouseDown: evt

	^evt yellowButtonPressed ! !


!GeeMailMorph methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:54'!
extraScrollRange
	^ bounds height
! !


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

!GeeMailMorph methodsFor: 'initialization' stamp: 'gm 3/10/2003 22:58'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self initializeThePasteUp.
	self position: 100@100.
	self extent: Display extent // 3.
	self useRoundedCorners.
	! !

!GeeMailMorph methodsFor: 'initialization' stamp: 'jam 3/9/2003 16:38'!
initializeThePasteUp
"initialize the receiver's thePasteUp"
	thePasteUp _ TextPlusPasteUpMorph new borderWidth: 0;
				 color: color.
	scroller addMorph: thePasteUp! !


!GeeMailMorph methodsFor: 'layout' stamp: 'RAA 3/5/2001 23:19'!
doLayoutIn: layoutBounds
	"layout has changed. update scroll deltas or whatever else"

	self adjustPasteUpSize.
	scroller ifNotNil: [self setScrollDeltas].
	super doLayoutIn: layoutBounds.
! !


!GeeMailMorph methodsFor: 'menu' stamp: 'RAA 5/3/2001 17:50'!
getMenu: shiftKeyState

	| menu |

	self flag: #convertToBook.	"<-- no longer used"

	menu _ MenuMorph new defaultTarget: self.
	self addGeeMailMenuItemsTo: menu.
	^menu! !


!GeeMailMorph methodsFor: 'menus' stamp: 'RAA 5/3/2001 17:50'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addGeeMailMenuItemsTo: aCustomMenu.! !


!GeeMailMorph methodsFor: 'Postscript Canvases' stamp: 'RAA 5/7/2001 12:20'!
printPSToFile

	thePasteUp printer
		geeMail: self;
		doPages! !


!GeeMailMorph methodsFor: 'scroll bar events' stamp: 'nk 4/28/2004 10:22'!
scrollBarValue: scrollValue

	| newPt pageBreaks topOfPage |

	scroller hasSubmorphs ifFalse: [^ self].
	newPt _ -3 @ (self vLeftoverScrollRange * scrollValue).

	pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()].
	pageBreaks isEmpty ifTrue: [
		^scroller offset: newPt.
	].
	topOfPage _ pageBreaks inject: (0@0 corner: 0@0) into: [ :closest :each |
		(each bottom - newPt y) abs < (closest bottom - newPt y) abs ifTrue: [
			each 
		] ifFalse: [
			closest 
		].
	].
	topOfPage ifNotNil: [
		newPt _ newPt x @ topOfPage bottom.
		scrollBar value: newPt y / self vLeftoverScrollRange.
	].
	scroller offset: newPt.! !


!GeeMailMorph methodsFor: 'scrolling' stamp: 'nk 4/28/2004 10:14'!
vHideScrollBar

	self keepScrollBarAlways ifTrue: [^self].
	^super vHideScrollBar! !


!GeeMailMorph methodsFor: '*eToys-customevents' stamp: 'nk 10/12/2003 13:23'!
releaseCachedState
	super releaseCachedState.
	self removeProperty: #visibleMorphs! !


!GeeMailMorph methodsFor: '*eToys-customevents-access' stamp: 'nk 10/12/2003 13:22'!
visibleMorphs
	"Answer a collection of morphs that were visible as of the last step"
	^Array withAll: (self valueOfProperty: #visibleMorphs ifAbsentPut: [ WeakArray new ]).! !

!GeeMailMorph methodsFor: '*eToys-customevents-access' stamp: 'nk 10/12/2003 13:22'!
visibleMorphs: morphs
	"Answer a collection of morphs that were visible as of the last step"
	self setProperty: #visibleMorphs toValue: (WeakArray withAll: morphs)! !


!GeeMailMorph methodsFor: '*eToys-customevents-stepping and presenter' stamp: 'nk 10/12/2003 13:23'!
step
	"For each submorph of thePasteUp that has just been scrolled into view, fire the script named #scrolledIntoView, if any.
	For each submorph of thePasteUp that has just been scrolled out of view, fire the script named #scrolledOutOfView, if any."
	| lastVisible nowVisible newlyVisible newlyInvisible |
	super step.
	lastVisible _ self visibleMorphs.
	nowVisible _ (thePasteUp submorphs copyWithoutAll: (self allTextPlusMorphs))
		select: [ :m | self bounds intersects: (m boundsIn: self world) ].
	newlyInvisible _ lastVisible difference: nowVisible.
	newlyInvisible do: [ :ea | ea triggerEvent: #scrolledOutOfView ].
	newlyVisible _ nowVisible difference: lastVisible.
	newlyVisible do: [ :ea | ea triggerEvent: #scrolledIntoView ].
	self visibleMorphs: nowVisible.
	! !

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

GeeMailMorph class
	instanceVariableNames: ''!

!GeeMailMorph class methodsFor: 'new-morph participation' stamp: 'RAA 9/10/2000 12:52'!
includeInNewMorphMenu

	^ false		"to encourage the use of GeeMail instead"! !
Object subclass: #GeePrinter
	instanceVariableNames: 'pasteUp printSpecs geeMail computedBounds'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:37'!
allPages

	| pageNumber allPages maxPages |

	maxPages _ 9999.
	pageNumber _ 0.
	allPages _ self pageRectangles collect: [ :rect |
		pageNumber _ pageNumber + 1.
		(self as: GeePrinterPage) pageNumber: pageNumber bounds: rect
	].
	allPages size > maxPages ifTrue: [allPages _ allPages first: maxPages].
	allPages do: [ :each | each totalPages: allPages size].
	^allPages

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:49'!
bounds

	^computedBounds ifNil: [computedBounds _ self computeBounds]! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:49'!
computeBounds

	| w ratio |

	w _ pasteUp width.
	self printSpecs scaleToFitPage ifTrue: [
		^0@0 extent: w@(w * self hOverW) rounded.
	].
	ratio _ 8.5 @ 11.
	self printSpecs landscapeFlag ifTrue: [
		ratio _ ratio transposed
	].
	^0@0 extent: (ratio * 72) rounded! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:41'!
doPrintPreview

	| pageDisplay sz newPage subBounds pic align |

	sz _ (85 @ 110) * 3.
	self printSpecs landscapeFlag ifTrue: [
		sz _ sz transposed
	].
	pageDisplay _ BookMorph new
		color: Color paleYellow;
		borderWidth: 1.
	self allPages withIndexDo: [ :each :index |
		pic _ ImageMorph new image: (each pageThumbnailOfSize: sz).
		align _ AlignmentMorph newColumn
			addMorph: pic;
			borderWidth: 1;
			layoutInset: 0;
			borderColor: Color blue.
		newPage _ pageDisplay 
			insertPageLabel: 'Page ',index printString
			morphs: {align}.
		subBounds _ newPage boundingBoxOfSubmorphs.
		newPage extent: subBounds corner - newPage topLeft + ((subBounds left - newPage left)@0).
	].
	pageDisplay 
		goToPage: 1;
		deletePageBasic;
		position: Display extent - pageDisplay extent // 2;
		openInWorld.
! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/22/2000 13:58'!
drawOn: aCanvas

	pasteUp drawOn: aCanvas

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 17:40'!
fullBounds

	^self bounds! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/22/2000 14:28'!
fullDrawOn: aCanvas

	pasteUp fullDrawOn: aCanvas

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:20'!
geeMail: aGeeMail

	geeMail _ aGeeMail! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:46'!
hOverW

	^self printSpecs landscapeFlag ifTrue: [
		8.5 /  11.0
	] ifFalse: [
		11.0 / 8.5
	].
! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:32'!
pageRectangles

	| pageBounds allPageRects maxExtent |

	geeMail ifNotNil: [
		allPageRects _ geeMail pageRectanglesForPrinting.
		allPageRects ifNotNil: [
			maxExtent _ allPageRects inject: 0@0 into: [ :max :each |
				max max: each extent
			].
			computedBounds _ 0@0 extent: maxExtent.
			^allPageRects
		].
	].
	pageBounds _ self bounds.
	allPageRects _ OrderedCollection new.
	[pageBounds top <= pasteUp bottom] whileTrue: [
		allPageRects add: pageBounds.
		pageBounds _ pageBounds translateBy: 0 @ pageBounds height.
	].
	^allPageRects
! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 17:41'!
pagesHandledAutomatically

	^true! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 17:35'!
pasteUp: x

	pasteUp _ x.! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:33'!
printSpecs

	^printSpecs ifNil: [printSpecs _ PrintSpecifications defaultSpecs].
! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:28'!
printSpecs: aPrintSpecification

	printSpecs _ aPrintSpecification! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 17:40'!
wantsRoundedCorners

	^false! !


!GeePrinter methodsFor: 'Postscript Canvases' stamp: 'RAA 9/18/2000 12:51'!
doPages

	| dialog |
	(dialog _ GeePrinterDialogMorph new) 
		printSpecs: self printSpecs 
		printBlock: [ :preview :specs |
			preview ifTrue: [self doPrintPreview] ifFalse: [self doPrintToPrinter]
		];
		fullBounds;
		position: Display extent - dialog extent // 2;
		openInWorld

! !

!GeePrinter methodsFor: 'Postscript Canvases' stamp: 'RAA 5/7/2001 12:54'!
doPrintToPrinter

	"fileName _ ('gee.',Time millisecondClockValue printString,'.eps') asFileName."
	self pageRectangles.	"ensure bounds computed"
	DSCPostscriptCanvasToDisk 
		morphAsPostscript: self 
		rotated: self printSpecs landscapeFlag
		specs: self printSpecs
! !

!GeePrinter methodsFor: 'Postscript Canvases' stamp: 'RAA 9/18/2000 11:33'!
fullDrawPostscriptOn: aCanvas

	aCanvas drawPages: self allPages.

! !
AlignmentMorphBob1 subclass: #GeePrinterDialogMorph
	instanceVariableNames: 'printSpecs printBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:50'!
buttonColor

	^color darker! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 4/3/2006 13:18'!
buttonNamed: aString action: aSymbol color: aColor help: helpString 
	| f col |
	f := SimpleButtonMorph new target: self;
				 label: aString;
				 color: aColor;
				 borderColor: aColor muchDarker;
				 actionSelector: aSymbol;
				 setBalloonText: helpString.
	col := self inAColumn: {f}.
	col hResizing: #shrinkWrap.
	^ col! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 4/3/2006 13:19'!
cancelButton
	^ self
		buttonNamed: 'Cancel'
		action: #doCancel
		color: ColorTheme current cancelColor
		help: 'Cancel this printing operation.'! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:24'!
doCancel

	self delete! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:42'!
doPreview

	self delete.
	printBlock value: true value: printSpecs.! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:42'!
doPrint

	self delete.
	printBlock value: false value: printSpecs.! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:36'!
getChoice: aSymbol

	aSymbol == #landscapeFlag ifTrue: [^printSpecs landscapeFlag].
	aSymbol == #drawAsBitmapFlag ifTrue: [^printSpecs drawAsBitmapFlag].
	aSymbol == #scaleToFitPage ifTrue: [^printSpecs scaleToFitPage].
! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:51'!
previewButton

	^self
		buttonNamed: 'Preview' 
		action: #doPreview 
		color: self buttonColor 
		help: 'Show a preview of the pages that will be printed on the screen.'! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:49'!
printButton

	^self
		buttonNamed: 'Print' 
		action: #doPrint 
		color: self buttonColor 
		help: 'Print me (a PostScript file will be created)'! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:26'!
printSpecs: aPrintSpecification printBlock: aTwoArgBlock

	printSpecs _ aPrintSpecification.
	printBlock _ aTwoArgBlock.! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:51'!
rebuild

	self removeAllMorphs.
	self addARow: {
		(StringMorph contents: 'PostScript Printing Options') lock.
	}.
	self addARow: {
		self
			simpleToggleButtonFor: self
			attribute: #landscapeFlag
			help: 'Print in landscape mode'.
		(StringMorph contents: ' Landscape') lock.
	}.
	self addARow: {
		self
			simpleToggleButtonFor: self
			attribute: #drawAsBitmapFlag
			help: 'Print as a bitmap'.
		(StringMorph contents: ' Bitmap') lock.
	}.
	self addARow: {
		self
			simpleToggleButtonFor: self
			attribute: #scaleToFitPage
			help: 'Scale printing to fill page'.
		(StringMorph contents: ' Scale to fit') lock.
	}.


	self addARow: {
		self printButton.
		self previewButton.
		self cancelButton.
	}.! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:50'!
toggleChoice: aSymbol

	aSymbol == #landscapeFlag ifTrue: [
		printSpecs landscapeFlag: printSpecs landscapeFlag not
	].
	aSymbol == #drawAsBitmapFlag ifTrue: [
		printSpecs drawAsBitmapFlag: printSpecs drawAsBitmapFlag not
	].
	aSymbol == #scaleToFitPage ifTrue: [
		printSpecs scaleToFitPage: printSpecs scaleToFitPage not
	].
! !


!GeePrinterDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ self color darker! !

!GeePrinterDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 8! !

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

!GeePrinterDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:52'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self vResizing: #shrinkWrap;
		 hResizing: #shrinkWrap;
		 layoutInset: 4;
		 useRoundedCorners.
	printSpecs
		ifNil: [printSpecs _ PrintSpecifications defaultSpecs].
	self rebuild ! !

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

GeePrinterDialogMorph class
	instanceVariableNames: ''!

!GeePrinterDialogMorph class methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:08'!
includeInNewMorphMenu

	^ false! !
GeePrinter subclass: #GeePrinterPage
	instanceVariableNames: 'pageNumber bounds totalPages'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 16:00'!
pageAsForm

	| f canvas |
	f _ Form extent: bounds extent depth: 16.
	canvas _ f getCanvas.
	canvas fillColor: pasteUp color.
	canvas translateTo: bounds origin negated clippingTo: f boundingBox during: [ :c |
		pasteUp fullDrawForPrintingOn: c
	].
	^f

! !

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 17:53'!
pageNumber: anInteger bounds: aRect

	pageNumber _ anInteger.
	bounds _ aRect.! !

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 16:00'!
pageThumbnailOfSize: aPoint

	^self pageAsForm scaledToSize: aPoint

! !

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/17/2000 16:51'!
totalPages: x

	totalPages _ x! !


!GeePrinterPage methodsFor: 'Postscript Canvases' stamp: 'RAA 2/22/2001 09:05'!
fullDrawPostscriptOn: aCanvas

	| s |
	s _ TextMorph new 
		beAllFont: (TextStyle default fontOfSize: 30);
		contentsAsIs: '   Drawing page ',pageNumber printString,' of ',totalPages printString,'     '.
	s layoutChanged; fullBounds.
	s _ AlignmentMorph newRow
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		addMorph: s;
		color: Color yellow.
	s position: Display center - (s width // 2 @ 0).
	World addMorphFront: s.
	World displayWorld.
	printSpecs drawAsBitmapFlag ifTrue: [
		aCanvas paintImage: self pageAsForm at: 0@0
	] ifFalse: [
		aCanvas 
			translateTo: bounds origin negated 
			clippingTo: (0@0 extent: bounds extent) 
			during: [ :c |
				pasteUp fullDrawForPrintingOn: c
			].
	].
	s delete.

! !
AlignmentMorphBob1 subclass: #GenericPropertiesMorph
	instanceVariableNames: 'myTarget thingsToRevert'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:23'!
addARow: anArray

	^(super addARow: anArray) cellPositioning: #topLeft! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 22:18'!
buildFakeSlider: nameStringOrSymbol selector: aSymbol help: helpString 
	| col |
	col := self inAColumn: { 
						(nameStringOrSymbol isSymbol) 
							ifTrue: 
								[(UpdatingStringMorph new)
									useStringFormat;
									getSelector: nameStringOrSymbol;
									target: self;
									growable: true;
									minimumWidth: 24;
									lock]
							ifFalse: [self lockedString: nameStringOrSymbol]}.
	col
		borderWidth: 2;
		borderColor: color darker;
		color: color muchLighter;
		hResizing: #shrinkWrap;
		setBalloonText: helpString;
		on: #mouseMove
			send: #mouseAdjust:in:
			to: self;
		on: #mouseDown
			send: #mouseAdjust:in:
			to: self;
		on: #mouseUp
			send: #clearSliderFeedback
			to: self;
		setProperty: #changeSelector toValue: aSymbol.
	^col! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 11/2/2004 21:26'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString;
		color: aColor;
		borderColor: aColor muchDarker;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	col _ (self inAColumn: {f}) hResizing: #shrinkWrap.
	^col! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:41'!
clearSliderFeedback

	| feedBack |

	feedBack _ self valueOfProperty: #sliderFeedback ifAbsent: [^self].
	feedBack delete! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:15'!
colorPickerFor: target getter: getterSymbol setter: setterSymbol

	^ColorPickerMorph new
		initializeForPropertiesPanel;
		target: target;
		selector: setterSymbol;
		originalColor: (target perform: getterSymbol)! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:36'!
directToggleButtonFor: target getter: getterSymbol setter: setterSymbol help: helpText

	^(EtoyUpdatingThreePhaseButtonMorph checkBox)
		target: target;
		actionSelector: setterSymbol;
		arguments: #();
		getSelector: getterSymbol;
		setBalloonText: helpText;
		step
! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:36'!
doAccept

	self delete! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 19:40'!
doCancel

	thingsToRevert keysAndValuesDo: [ :k :v |
		myTarget perform: k with: v
	].
	self delete! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:24'!
doEnables! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:50'!
doMainProperties

	myTarget openAPropertySheet.
	self delete.
! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 12:57'!
doTextProperties

	myTarget openATextPropertySheet.
	self delete.
! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:23'!
enable: aMorph when: aBoolean

	aBoolean = (aMorph hasProperty: #disabledMaskColor) ifFalse: [^self].
	aBoolean ifTrue: [
		aMorph 
			removeProperty: #disabledMaskColor;
			lock: false;
			changed.
		^self
	].
	aMorph 
		setProperty: #disabledMaskColor toValue: (Color black alpha: 0.5);
		lock: true;
		changed
! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:22'!
inAColumn: aCollectionOfMorphs

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

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:22'!
inAColumn: anArray named: aString

	^(self inAColumn: anArray) setNamePropertyTo: aString! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:27'!
inARow: aCollectionOfMorphs

	| row |
	row _ AlignmentMorphBob1 newRow
		color: Color transparent;
		vResizing: #shrinkWrap;
		layoutInset: 1;
		wrapCentering: #center;
		cellPositioning: #leftCenter.
	aCollectionOfMorphs do: [ :each | row addMorphBack: each].
	^row
! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:22'!
inARow: anArray named: aString

	^(self inARow: anArray) setNamePropertyTo: aString! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:37'!
lockedString: s

	^(StringMorph contents: s) lock.
! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:22'!
mouseAdjust: evt in: aMorph

	| fractionalPosition feedBack testExtent |

	feedBack _ self showSliderFeedback: nil.
	feedBack world ifNil: [
		feedBack bottomLeft: evt cursorPoint - (0@8)
	].
	testExtent _ 100@100.		"the real extent may change"
	fractionalPosition _ (evt cursorPoint - aMorph topLeft) / testExtent.
	self 
		perform: (aMorph valueOfProperty: #changeSelector)
		with: fractionalPosition
! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 13:09'!
openNearTarget

	| w wb tb leftOverlap rightOverlap topOverlap bottomOverlap best |

	w _ myTarget world ifNil: [World].
	wb _ w bounds.
	self fullBounds.
	tb _ myTarget boundsInWorld.
	leftOverlap _ self width - (tb left - wb left).
	rightOverlap _ self width - (wb right - tb right).
	topOverlap _ self height - (tb top - wb top).
	bottomOverlap _ self height - (wb bottom - tb bottom).
	best _ nil.
	{
		{leftOverlap. #topRight:. #topLeft}.
		{rightOverlap. #topLeft:. #topRight}.
		{topOverlap. #bottomLeft:. #topLeft}.
		{bottomOverlap. #topLeft:. #bottomLeft}.
	} do: [ :tuple |
		(best isNil or: [tuple first < best first]) ifTrue: [best _ tuple].
	].
	self perform: best second with: (tb perform: best third).
	self bottom: (self bottom min: wb bottom) rounded.
	self right: (self right min: wb right) rounded.
	self top: (self top max: wb top) rounded.
	self left: (self left max: wb left) rounded.

	self openInWorld: w.! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:12'!
showSliderFeedback: aString

	| feedBack |

	feedBack _ self 
		valueOfProperty: #sliderFeedback 
		ifAbsent: [
			feedBack _ AlignmentMorph newRow
				hResizing: #shrinkWrap;
				vResizing: #shrinkWrap;
				color: (Color yellow" alpha: 0.6");
				addMorph: (
					TextMorph new 
						contents: '?';
						beAllFont: ((TextStyle default fontOfSize: 24) emphasized: 1)
				).
			self setProperty: #sliderFeedback toValue: feedBack.
			feedBack
		].
	aString ifNotNil: [
		feedBack firstSubmorph contents: aString asString.
		feedBack world ifNil: [feedBack openInWorld].
	].
	^feedBack! !

!GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:01'!
targetMorph: x

	myTarget _ x! !


!GenericPropertiesMorph methodsFor: 'dropping/grabbing' stamp: 'tk 7/11/2001 14:00'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph"
	^aMorph isWorldMorph or:[Preferences systemWindowEmbedOK]! !


!GenericPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:15'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 4! !

!GenericPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:16'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""

	self layoutInset: 4.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	thingsToRevert _ Dictionary new.
	self useRoundedCorners! !


!GenericPropertiesMorph methodsFor: 'stepping and presenter' stamp: 'RAA 3/8/2001 16:24'!
step

	super step.
	self doEnables! !


!GenericPropertiesMorph methodsFor: 'testing' stamp: 'RAA 3/8/2001 16:24'!
stepTime

	^500! !
Url subclass: #GenericUrl
	instanceVariableNames: 'schemeName locator'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!GenericUrl commentStamp: '<historical>' prior: 0!
a URL type that can't be broken down in any systematic way.  For example, mailto: and telnet: URLs.  The part after the scheme name is stored available via the #locator message.!


!GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'!
locator
	^locator! !

!GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'!
schemeName
	^schemeName! !


!GenericUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:39'!
scheme
	^ self schemeName.! !


!GenericUrl methodsFor: 'parsing' stamp: 'ls 8/4/1998 01:28'!
privateInitializeFromText: aString
	schemeName _ Url schemeNameForString: aString.
	schemeName ifNil: [ self error: 'opaque URL with no scheme--shouldn''t happen!!'. ].
	locator _ aString copyFrom: (schemeName size+2) to: aString size.! !

!GenericUrl methodsFor: 'parsing' stamp: 'ls 8/4/1998 01:28'!
privateInitializeFromText: aString relativeTo: aUrl
	schemeName _ aUrl schemeName.
	locator _ aString.! !


!GenericUrl methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:06'!
printOn: aStream

	aStream nextPutAll: self schemeName.
	aStream nextPut: $:.
	aStream nextPutAll: self locator.

	self fragment ifNotNil:
		[aStream nextPut: $#.
		aStream nextPutAll: self fragment].! !


!GenericUrl methodsFor: 'private' stamp: 'ls 6/20/1998 19:46'!
schemeName: schemeName0  locator: locator0
	schemeName _ schemeName0.
	locator _ locator0.! !

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

GenericUrl class
	instanceVariableNames: ''!

!GenericUrl class methodsFor: 'instance creation' stamp: 'ls 6/20/1998 19:46'!
schemeName: schemeName  locator: locator
	^self new schemeName: schemeName  locator: locator! !


!GenericUrl class methodsFor: 'parsing' stamp: 'ls 7/26/1998 21:24'!
absoluteFromText: aString
	| schemeName locator |
	schemeName _ Url schemeNameForString: aString.
	schemeName ifNil: [ ^self schemeName: 'xnoscheme' locator: aString ].
	locator _ aString copyFrom: (schemeName size + 2) to: aString size.
	^self schemeName: schemeName locator: locator! !
ClassTestCase subclass: #GenericUrlTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NetworkTests-Url'!

!GenericUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 12:56'!
testAsString
	| url |
	url := GenericUrl new schemeName: 'sip' locator: 'foo@bar'.
	self assert: url asString = 'sip:foo@bar'.! !
VoiceEvent subclass: #GesturalEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!GesturalEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 02:18'!
voice
	"Answer the default voice for the reciever."
	^ Voice voices detect: [ :one | one class == GesturalVoice] ifNone: [super voice]! !


!GesturalEvent methodsFor: 'playing' stamp: 'len 9/6/1999 00:40'!
actOn: aHeadMorph
	self subclassResponsibility! !

!GesturalEvent methodsFor: 'playing' stamp: 'len 8/28/1999 03:53'!
playOn: aVoice at: time
	aVoice playGesturalEvent: self at: time! !


!GesturalEvent methodsFor: 'testing' stamp: 'len 8/29/1999 21:18'!
isGestural
	^ true! !
Voice subclass: #GesturalVoice
	instanceVariableNames: 'head'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Gestures'!
!GesturalVoice commentStamp: '<historical>' prior: 0!
My instances are speaking voices with a head that acts in response to gestural events.!


!GesturalVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 23:07'!
face
	^ self head face! !

!GesturalVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 23:06'!
head
	^ head! !

!GesturalVoice methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
head: aHeadMorph
	head notNil ifTrue: [aHeadMorph position: head position. head delete].
	head := aHeadMorph! !

!GesturalVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 23:06'!
lips
	^ self face lips! !

!GesturalVoice methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
newHead
	| m |
	m := HeadMorph new.
	self head: m.
	m openInWorld.
	^ m! !


!GesturalVoice methodsFor: 'playing' stamp: 'len 9/7/1999 01:41'!
playGesturalEvent: event at: time
	self head playEvent: event at: time! !

!GesturalVoice methodsFor: 'playing' stamp: 'len 9/6/1999 00:46'!
playPhoneticEvent: event at: time
	(TalkGesturalEvent new phoneme: event phoneme) playOn: self at: time! !
Notification subclass: #GetTriggeringObjectNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-CustomEvents'!
!GetTriggeringObjectNotification commentStamp: '<historical>' prior: 0!
This is used to report on the sender of #triggerScript:!

ImageMorph subclass: #GrabPatchMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!GrabPatchMorph commentStamp: 'sw 8/1/2004 13:27' prior: 0!
When an instance of GrabPatchMorph is dropped by the user, it signals a desire to do a screen-grab of a rectangular area.!


!GrabPatchMorph methodsFor: 'dropping' stamp: 'sw 4/6/2004 15:52'!
justDroppedInto: aPasteUpMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph"

	aPasteUpMorph isPartsBin ifFalse:
		[self delete.
		ActiveWorld displayWorldSafely; runStepMethods.  "But the HW cursor stays up still ???"
		^ aPasteUpMorph grabDrawingFromScreen: anEvent].
	^ super justDroppedInto: aPasteUpMorph event: anEvent! !

!GrabPatchMorph methodsFor: 'dropping' stamp: 'sw 4/6/2004 14:40'!
wantsToBeDroppedInto: aMorph
	"Only into PasteUps that are not part bins"

	^ aMorph isPlayfieldLike! !


!GrabPatchMorph methodsFor: 'initialization' stamp: 'sw 7/5/2004 01:51'!
initialize
	"Initialize the receiver.  Emblazon the GrabPatch icon on its face"

	super initialize.
	self image: (ScriptingSystem formAtKey: 'GrabPatch')! !

!GrabPatchMorph methodsFor: 'initialization' stamp: 'sw 7/5/2004 01:51'!
initializeToStandAlone
	"Initialize the receiver.  Emblazon the GrabPatch icon on its face"

	super initializeToStandAlone.
	self image: (ScriptingSystem formAtKey: 'GrabPatch')! !


!GrabPatchMorph methodsFor: '*eToys-misc' stamp: 'sw 7/5/2004 01:49'!
isCandidateForAutomaticViewing
	"Answer whether the receiver is a candidate for automatic viewing.  Only relevant if a now-seldom-used feature, automaticViewing, is in play"

	^ self isPartsDonor not! !

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

GrabPatchMorph class
	instanceVariableNames: ''!

!GrabPatchMorph class methodsFor: 'instance creation' stamp: 'sw 7/5/2004 01:53'!
authoringPrototype
	"Answer a prototype for use in a parts bin"

	^ self new image: (ScriptingSystem formAtKey: 'GrabPatch'); markAsPartsDonor; setBalloonText: 'Use this to grab a rectangular patch from the screen'; yourself! !


!GrabPatchMorph class methodsFor: 'parts bin' stamp: 'sw 7/5/2004 01:51'!
descriptionForPartsBin
	"Answer a description of the receiver's instances for a parts bin"

	^ self partName:	'Grab Patch'
		categories:		#('Graphics')
		documentation:	'Use this to grab a rectangular patch from the screen'! !
RectangleMorph subclass: #GradientFillMorph
	instanceVariableNames: 'fillColor2 gradientDirection colorArray colorDepth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!GradientFillMorph commentStamp: '<historical>' prior: 0!
Class GradientFillMorph is obsolete. For getting gradient fills use a BorderedMorph with an appropriate fill style, e.g.,

	| morph fs |
	morph _ BorderedMorph new.
	fs _ GradientFillStyle ramp: {0.0 -> Color red. 1.0 -> Color green}.
	fs origin: morph bounds center.
	fs direction: (morph bounds width // 2) @ 0.
	fs radial: true.
	morph fillStyle: fs.
	World primaryHand attachMorph: morph.

Here's the old (obsolete) comment:
GradientFills cache an array of bitpatterns for the colors across their rectangle.  It costs a bit of space, but makes display fast enough to eschew the use of a bitmap.  The array must be recomputed whenever the colors, dimensions or display depth change.!


!GradientFillMorph methodsFor: '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].
	(fillColor2 isColor and: [fillColor2 isTranslucentColor]) ifTrue: [^ true].
	^ false
! !


!GradientFillMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/5/97 12:40'!
gradientFillColor: aColor

	fillColor2 _ aColor.
	self changed.
! !

!GradientFillMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 18:52'!
setGradientColor: evt

	self changeColorTarget: self selector: #gradientFillColor: originalColor: fillColor2 hand: evt hand! !


!GradientFillMorph methodsFor: 'drawing' stamp: 'gm 2/22/2003 13:15'!
drawOn: aCanvas 
	"Note that this could run about 4 times faster if we got hold of
	the canvas's port and just sent it copyBits with new coords and color"

	| style |
	super drawOn: aCanvas.
	(color isColor) ifFalse: [^self].	"An InfiniteForm, for example"
	color = Color transparent ifTrue: [^self].	"Skip the gradient attempts, which will drop into debugger"
	color = fillColor2 ifTrue: [^self].	"same color; no gradient"
	"Check if we can use the cached gradient fill"
	((self valueOfProperty: #cachedGradientColor1) = color 
		and: [(self valueOfProperty: #cachedGradientColor2) = fillColor2]) 
			ifTrue: [style := self valueOfProperty: #cachedGradientFill].
	style ifNil: 
			[style := GradientFillStyle ramp: { 
								0.0 -> color.
								1.0 -> fillColor2}.
			self setProperty: #cachedGradientColor1 toValue: color.
			self setProperty: #cachedGradientColor2 toValue: fillColor2.
			self setProperty: #cachedGradientFill toValue: style].
	style origin: self position.
	style direction: (gradientDirection == #vertical 
				ifTrue: [0 @ self height]
				ifFalse: [self width @ 0]).
	aCanvas fillRectangle: self innerBounds fillStyle: style! !


!GradientFillMorph methodsFor: 'initialization' stamp: 'di 1/9/98 22:17'!
initialize
	super initialize.
	borderWidth _ 0.
	fillColor2 _ Color black.
	gradientDirection _ #vertical! !


!GradientFillMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:45'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'gradient color' translated action: #setGradientColor:.
	gradientDirection == #vertical
		ifTrue: [aCustomMenu add: 'horizontal pan' translated action: #beHorizontal]
		ifFalse: [aCustomMenu add: 'vertical pan' translated action: #beVertical].
! !

!GradientFillMorph methodsFor: 'menu' stamp: 'di 11/2/97 14:35'!
beHorizontal
	gradientDirection _ #horizontal.
	self changed! !

!GradientFillMorph methodsFor: 'menu' stamp: 'di 11/2/97 14:35'!
beVertical
	gradientDirection _ #vertical.
	self changed! !


!GradientFillMorph methodsFor: 'updating' stamp: 'di 11/13/97 15:20'!
changed
	super changed.
	self releaseCachedState! !
OrientedFillStyle subclass: #GradientFillStyle
	instanceVariableNames: 'colorRamp pixelRamp radial isTranslucent'
	classVariableNames: 'PixelRampCache'
	poolDictionaries: ''
	category: 'Balloon-Fills'!
!GradientFillStyle commentStamp: 'efc 8/30/2005 21:44' prior: 0!
A gradient fill style is a fill which interpolates smoothly between any number of colors.

Instance variables:
	colorRamp	<Array of: Association> Contains the colors and their relative positions along the fill, which is a number between zero and one.
	pixelRamp	<Bitmap>		A cached version of the colorRamp to avoid needless recomputations.
	radial		<Boolean>	If true, this fill describes a radial gradient. If false, it is a linear gradient.
	isTranslucent	<Boolean>	A (cached) flag determining if there are any translucent colors involved.

Class variables:
	PixelRampCache <LRUCache>	Recently used pixelRamps. They tend to have high temporal locality and this saves space and time.!


!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:10'!
colorRamp
	^colorRamp! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 9/2/1999 14:30'!
colorRamp: anArray
	colorRamp := anArray.
	pixelRamp := nil.
	isTranslucent := nil.! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'efc 8/30/2005 21:42'!
pixelRamp

"Compute a pixel ramp, and cache it for future accesses"

^pixelRamp ifNil:[
	"Insure the PixelRampCache is in place"
	PixelRampCache ifNil:[ self class initPixelRampCache  ].

	"Ask my cache for an existing instance if one is available"
	pixelRamp := PixelRampCache at: colorRamp	
].! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:06'!
pixelRamp: aBitmap
	pixelRamp := aBitmap! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 8/31/2004 11:06'!
radial
	^radial ifNil:[false]! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:11'!
radial: aBoolean
	radial := aBoolean! !


!GradientFillStyle methodsFor: 'converting' stamp: 'ar 8/25/2001 21:02'!
asColor
	"Guess..."
	^colorRamp first value mixed: 0.5 with: colorRamp last value! !

!GradientFillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:42'!
mixed: fraction with: aColor
	^self copy colorRamp: (colorRamp collect:[:assoc| assoc key -> (assoc value mixed: fraction with: aColor)])! !


!GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:12'!
isGradientFill
	^true! !

!GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:13'!
isRadialFill
	^radial == true! !

!GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:12'!
isSolidFill
	^false! !

!GradientFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:29'!
isTranslucent
	^isTranslucent ifNil:[isTranslucent := self checkTranslucency]! !


!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'dgd 10/17/2003 22:37'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	self isRadialFill ifTrue:[
		aMenu add: 'linear gradient' translated target: self selector: #beLinearGradientIn: argument: aMorph.
	] ifFalse:[
		aMenu add: 'radial gradient' translated target: self selector: #beRadialGradientIn: argument: aMorph.
	].
	aMenu addLine.
	aMenu add: 'change first color' translated target: self selector: #changeFirstColorIn:event: argument: aMorph.
	aMenu add: 'change second color' translated target: self selector: #changeSecondColorIn:event: argument: aMorph.
	aMenu addLine.
	super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! !

!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'ar 6/18/1999 09:49'!
addNewColorIn: aMorph event: evt
	^self inform:'not yet implemented'! !

!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'ar 6/18/1999 07:25'!
beLinearGradientIn: aMorph
	self radial: false.
	aMorph changed.! !

!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'ar 6/18/1999 07:25'!
beRadialGradientIn: aMorph
	self radial: true.
	aMorph changed.! !

!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'sw 9/8/2000 18:13'!
changeColorSelector: aSymbol hand: aHand morph: aMorph originalColor: originalColor
	"Change either the firstColor or the lastColor (depending on aSymbol).  Put up a color picker to hande it.  We always use a modal picker so that the user can adjust both colors concurrently."

	ColorPickerMorph new
		initializeModal: false;
		sourceHand: aHand;
		target: self;
		selector: aSymbol;
		argument: aMorph;
		originalColor: originalColor;
		putUpFor: aMorph near: aMorph fullBoundsInWorld! !

!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'di 9/3/1999 11:34'!
changeFirstColorIn: aMorph event: evt
	^self changeColorSelector: #firstColor:forMorph:hand: hand: evt hand morph: aMorph originalColor: colorRamp first value! !

!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'di 9/3/1999 11:34'!
changeSecondColorIn: aMorph event: evt
	^self changeColorSelector: #lastColor:forMorph:hand: hand: evt hand morph: aMorph originalColor: colorRamp last value! !

!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'nk 7/18/2003 16:35'!
firstColor: aColor forMorph: aMorph hand: aHand
	colorRamp first value: aColor.
	isTranslucent _ nil.
	pixelRamp _ nil.
	aMorph changed.! !

!GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'nk 7/18/2003 16:35'!
lastColor: aColor forMorph: aMorph hand: aHand
	colorRamp last value: aColor.
	isTranslucent _ nil.
	pixelRamp _ nil.
	aMorph changed.! !


!GradientFillStyle methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'RAA 7/28/2000 08:37'!
encodeForRemoteCanvas

	^(DataStream streamedRepresentationOf: self) asString
! !


!GradientFillStyle methodsFor: 'private' stamp: 'di 11/21/1999 20:18'!
checkTranslucency
	^colorRamp anySatisfy: [:any| any value isTranslucent]! !

!GradientFillStyle methodsFor: 'private' stamp: 'ar 7/16/2000 18:32'!
computePixelRampOfSize: length
	"Compute the pixel ramp in the receiver"
	| bits lastColor lastIndex nextIndex nextColor distance theta lastValue ramp lastWord nextWord step |
	ramp := colorRamp asSortedCollection:[:a1 :a2| a1 key < a2 key].
	bits := Bitmap new: length.
	lastColor := ramp first value.
	lastWord := lastColor pixelWordForDepth: 32.
	lastIndex := 0.
	ramp do:[:assoc|
		nextIndex := (assoc key * length) rounded.
		nextColor := assoc value.
		nextWord := nextColor pixelWordForDepth: 32.
		distance := (nextIndex - lastIndex).
		distance = 0 ifTrue:[distance := 1].
		step := 1.0 / distance asFloat.
		theta := 0.0.
		lastIndex+1 to: nextIndex do:[:i|
			theta := theta + step.
			"The following is an open-coded version of:
				color := nextColor alphaMixed: theta with: lastColor.
				bits at: i put: (color scaledPixelValue32).
			"
			bits at: i put: (self scaledAlphaMix: theta of: lastWord with: nextWord).
		].
		lastIndex := nextIndex.
		lastColor := nextColor.
		lastWord := nextWord.
	].
	lastValue := lastColor scaledPixelValue32.
	lastIndex+1 to: length do:[:i| bits at: i put: lastValue].
	^bits! !

!GradientFillStyle methodsFor: 'private' stamp: 'ar 11/9/1998 16:56'!
display
	| f ramp |
	ramp := self pixelRamp.
	f := Form extent: ramp size @ 1 depth: 32 bits: ramp.
	1 to: 100 do:[:i| f displayAt: 1@i].
	[Sensor anyButtonPressed] whileFalse.
	[Sensor anyButtonPressed] whileTrue.! !

!GradientFillStyle methodsFor: 'private' stamp: 'ar 7/11/2000 16:47'!
scaledAlphaMix: theta of: lastWord with: nextWord
	"Open-coded version of alpha mixing two 32bit pixel words and returning the scaled pixel value."
	| word0 word1 a0 a1 alpha v0 v1 vv value |
	word0 := lastWord.
	word1 := nextWord.
	"note: extract alpha first so we'll be in SmallInteger range afterwards"
	a0 := word0 bitShift: -24. a1 := word1 bitShift: -24.
	alpha := a0 + (a1 - a0 * theta) truncated.
	"Now make word0 and word1 SmallIntegers"
	word0 := word0 bitAnd: 16rFFFFFF. word1 := word1 bitAnd: 16rFFFFFF.
	"Compute first component value"
	v0 := (word0 bitAnd: 255). v1 := (word1 bitAnd: 255).
	vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value := vv.
	"Compute second component value"
	v0 := ((word0 bitShift: -8) bitAnd: 255). v1 := ((word1 bitShift: -8) bitAnd: 255).
	vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value := value bitOr: (vv bitShift: 8).
	"Compute third component value"
	v0 := ((word0 bitShift: -16) bitAnd: 255). v1 := ((word1 bitShift: -16) bitAnd: 255).
	vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value := value bitOr: (vv bitShift: 16).
	"Return result"
	^value bitOr: (alpha bitShift: 24)! !

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

GradientFillStyle class
	instanceVariableNames: ''!

!GradientFillStyle class methodsFor: 'class initialization' stamp: 'md 8/31/2005 17:33'!
initPixelRampCache

"Create an LRUCache to use for accessing pixel ramps."

"Details: when a new pixel ramp is needed, a temporary GradientFillStyle is created so that it can be used to create a new pixel ramp"

^PixelRampCache := LRUCache size: 32 factory:[:key| 
	(GradientFillStyle new colorRamp: key) computePixelRampOfSize: 512]  ! !

!GradientFillStyle class methodsFor: 'class initialization' stamp: 'md 8/31/2005 17:33'!
pixelRampCache

"Allow access to my cache of pixel ramps. This is mainly for debugging and profiling purposes."

^PixelRampCache ! !


!GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 23:09'!
colors: colorArray
	"Create a gradient fill style from an array of equally spaced colors"
	^self ramp: (colorArray withIndexCollect:
		[:color :index| (index-1 asFloat / (colorArray size - 1 max: 1)) -> color]).! !

!GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/9/1998 14:05'!
ramp: colorRamp
	^self new colorRamp: colorRamp! !

!GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/10/1998 19:13'!
sample
	"GradientFill sample"
	^(self ramp: { 0.0 -> Color red. 0.5 -> Color green. 1.0 -> Color blue})
		origin: 300 @ 300;
		direction: 400@0;
		normal: 0@400;
		radial: true;
	yourself! !
BitBlt subclass: #GrafPort
	instanceVariableNames: 'alpha fillPattern lastFont lastFontForegroundColor lastFontBackgroundColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:07'!
alphaBits: a
	alpha _ a! !

!GrafPort methodsFor: 'accessing' stamp: 'ar 5/28/2000 14:41'!
contentsOfArea: aRectangle into: aForm
	destForm 
		displayOn: aForm 
		at:  aRectangle origin
		clippingBox: (0@0 extent: aRectangle extent).
	^aForm! !

!GrafPort methodsFor: 'accessing' stamp: 'ar 4/10/2005 18:56'!
displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode

	((para isMemberOf: MultiNewParagraph) or: [para text string isByteString]) ifTrue: [
		^ (MultiDisplayScanner new text: para text textStyle: para textStyle
				foreground: foreColor background: backColor fillBlt: self
				ignoreColorChanges: shadowMode)
			setPort: self clone
	].
	^ (DisplayScanner new text: para text textStyle: para textStyle
			foreground: foreColor background: backColor fillBlt: self
			ignoreColorChanges: shadowMode)
		setPort: self clone
! !

!GrafPort methodsFor: 'accessing' stamp: 'ar 4/10/2005 18:56'!
displayScannerForMulti: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode

	((para isMemberOf: MultiNewParagraph) or: [para text string isByteString]) ifTrue: [
		^ (MultiDisplayScanner new text: para presentationText textStyle: para textStyle
				foreground: foreColor background: backColor fillBlt: self
				ignoreColorChanges: shadowMode)
			setPort: self clone
	].
	^ (DisplayScanner new text: para text textStyle: para textStyle
			foreground: foreColor background: backColor fillBlt: self
			ignoreColorChanges: shadowMode)
		setPort: self clone
! !

!GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:09'!
fillPattern: anObject
	fillPattern _ anObject.
	self fillColor: anObject.! !


!GrafPort methodsFor: 'copying' stamp: 'ar 12/30/2001 20:32'!
clippedBy: aRectangle
	^ self copy clipBy: aRectangle! !

!GrafPort methodsFor: 'copying' stamp: 'dgd 2/21/2003 22:38'!
copyBits
	"Override copybits to do translucency if desired"

	(combinationRule >= 30 and: [combinationRule <= 31]) 
		ifTrue: 
			[alpha isNil 
				ifTrue: [self copyBitsTranslucent: 255]
				ifFalse: [self copyBitsTranslucent: alpha]]
		ifFalse: [super copyBits]! !


!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:32'!
fillOval: rect
	| centerX centerY nextY yBias xBias outer nextOuterX |
	rect area <= 0 ifTrue: [^ self].
	height _ 1.
	yBias _ rect height odd ifTrue: [0] ifFalse: [-1].
	xBias _ rect width odd ifTrue: [1] ifFalse: [0].
	centerX _ rect center x.
	centerY _ rect center y.
	outer _ EllipseMidpointTracer new on: rect.
	nextY _ rect height // 2.
	[nextY > 0] whileTrue:[
		nextOuterX _ outer stepInY.
		width _ (nextOuterX bitShift: 1) + xBias.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		self copyBits.
		destY _ centerY + nextY + yBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	destY _ centerY.
	height _ 1 + yBias.
	width _ rect width.
	destX _ rect left.
	self copyBits.
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 5/17/2000 21:20'!
fillRect: rect offset: aPoint
	"The offset is really just for stupid InfiniteForms."
	| fc |
	fillPattern class == InfiniteForm ifTrue:[
		fc _ halftoneForm.
		self fillColor: nil.
		fillPattern displayOnPort: ((self clippedBy: rect) colorMap: nil) at: aPoint.
		halftoneForm _ fc.
		^self].

	destX _ rect left.
	destY _ rect top.
	sourceX _ 0.
	sourceY _ 0.
	width _ rect width.
	height _ rect height.
	self copyBits.! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:26'!
frameOval: rect borderWidth: borderWidth
	| centerX centerY nextY yBias xBias wp outer inner nextOuterX nextInnerX fillAlpha |
	rect area <= 0 ifTrue: [^ self].
	height _ 1.
	wp _ borderWidth asPoint.
	yBias _ rect height odd ifTrue: [0] ifFalse: [-1].
	xBias _ rect width odd ifTrue: [1] ifFalse: [0].
	centerX _ rect center x.
	centerY _ rect center y.
	outer _ EllipseMidpointTracer new on: rect.
	inner _ EllipseMidpointTracer new on: (rect insetBy: wp).
	nextY _ rect height // 2.
	1 to: (wp y min: nextY) do:[:i|
		nextOuterX _ outer stepInY.
		width _ (nextOuterX bitShift: 1) + xBias.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		self copyBits.
		destY _ centerY + nextY + yBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	[nextY > 0] whileTrue:[
		nextOuterX _ outer stepInY.
		nextInnerX _ inner stepInY.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		width _ nextOuterX - nextInnerX.
		self copyBits.
		destX _ centerX + nextInnerX + xBias.
		self copyBits.
		destX _ centerX - nextOuterX.
		destY _ centerY + nextY + yBias.
		self copyBits.
		destX _ centerX + nextInnerX + xBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	destY _ centerY.
	height _ 1 + yBias.
	width _ wp x.
	destX _ rect left.
	self copyBits.
	destX _ rect right - wp x.
	self copyBits.
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 14:44'!
frameRect: rect borderWidth: borderWidth
	sourceX _ 0.
	sourceY _ 0.
	(rect areasOutside: (rect insetBy: borderWidth)) do:
		[:edgeStrip | self destRect: edgeStrip; copyBits].
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'!
frameRectBottom: rect height: h

	destX _ rect left + 1.
	destY _ rect bottom - 1.
	width _ rect width - 2.
	height _ 1.
	1 to: h do: [:i |
		self copyBits.
		destX _ destX + 1.
		destY _ destY - 1.
		width _ width - 2].
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'!
frameRectRight: rect width: w

	width _ 1.
	height _ rect height - 1.
	destX _ rect right - 1.
	destY _ rect top + 1.
	1 to: w do: [:i |
		self copyBits.
		destX _ destX - 1.
		destY _ destY + 1.
		height _ height - 2].
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."

	sourceForm _ aForm.
	combinationRule _ rule.
	self sourceRect: sourceRect.
	self destOrigin: aPoint.
	self copyBits! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 8/8/2001 14:26'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha
	"Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."

	sourceForm _ aForm.
	combinationRule _ rule.
	self sourceRect: sourceRect.
	self destOrigin: aPoint.
	self copyBitsTranslucent: (alpha _ (sourceAlpha * 255) truncated min: 255 max: 0).! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 00:31'!
stencil: stencilForm at: aPoint sourceRect: aRect
	"Paint using aColor wherever stencilForm has non-zero pixels"
	self sourceForm: stencilForm;
		destOrigin: aPoint;
		sourceRect: aRect.
	self copyBits! !


!GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'!
installStrikeFont: aStrikeFont

	^ self installStrikeFont: aStrikeFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]).
! !

!GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:11'!
installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor
	super installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor.
	alpha _ foregroundColor privateAlpha.
	"dynamically switch between blend modes to support translucent text"
	"To handle the transition from TTCFont to StrikeFont, rule 34 must be taken into account."
	alpha = 255 ifTrue:[
		combinationRule = 30 ifTrue: [combinationRule _ Form over].
		combinationRule = 31 ifTrue: [combinationRule _ Form paint].
		combinationRule = 34 ifTrue: [combinationRule _ Form paint].
	] ifFalse:[
		combinationRule = Form over ifTrue: [combinationRule _ 30].
		combinationRule = Form paint ifTrue: [combinationRule _ 31].
		combinationRule = 34 ifTrue: [combinationRule _ 31].
	].
	lastFont _ aStrikeFont.
	lastFontForegroundColor _ foregroundColor.
	lastFontBackgroundColor _ backgroundColor.
! !

!GrafPort methodsFor: 'private' stamp: 'yo 1/12/2005 16:39'!
installTTCFont: aTTCFont

	^ self installTTCFont: aTTCFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]).
! !

!GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'!
installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor

	super installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor.
	lastFont _ aTTCFont.
	lastFontForegroundColor _ foregroundColor.
	lastFontBackgroundColor _ backgroundColor.
! !

!GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:13'!
lastFont

	^ lastFont.
! !
RectangleMorph subclass: #GraphMorph
	instanceVariableNames: 'data dataColor cursor cursorColor cursorColorAtZeroCrossings startIndex minVal maxVal cachedForm hasChanged'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!GraphMorph commentStamp: '<historical>' prior: 0!
I display a graph of numbers, normalized so the full range of values just fits my height. I support a movable cursor that can be dragged with the mouse.

Implementation notes: Some operations on me may be done at sound sampling rates (e.g. 11-44 thousand times/second). To allow such high bandwidth application, certain operations that change my appearance do not immediately report a damage rectangle. Instead, a flag is set indicating that my display needs to refreshed and a step method reports the damage rectangle if that flag is set. Also, I cache a bitmap of my graph to allow the cursor to be moved without redrawing the graph.
!


!GraphMorph methodsFor: 'accessing'!
color: aColor

	super color: aColor.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing'!
cursorAtEnd

	^ cursor truncated >= data size
! !

!GraphMorph methodsFor: 'accessing'!
cursorColor

	^ cursorColor
! !

!GraphMorph methodsFor: 'accessing'!
cursorColor: aColor

	cursorColor _ aColor.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:32'!
cursorColorAtZeroCrossing

	^ cursorColorAtZeroCrossings
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:32'!
cursorColorAtZeroCrossings: aColor

	cursorColorAtZeroCrossings _ aColor.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 6/17/1999 21:43'!
cursorWrapped: aNumber

	| sz |
	cursor ~= aNumber ifTrue: [
		cursor _ aNumber.
		sz _ data size.
		sz = 0
			ifTrue: [cursor _ 1]
			ifFalse: [
				((cursor >= (sz + 1)) or: [cursor < 0]) ifTrue: [
					cursor _ cursor - ((cursor // sz) * sz)].
				cursor < 1 ifTrue: [cursor _ sz + cursor]].
		"assert: 1 <= cursor < data size + 1"
		hasChanged _ true].
! !

!GraphMorph methodsFor: 'accessing'!
data

	^ data
! !

!GraphMorph methodsFor: 'accessing'!
data: aCollection

	data _ aCollection.
	maxVal _ minVal _ 0.
	data do: [:x |
		x < minVal ifTrue: [minVal _ x].
		x > maxVal ifTrue: [maxVal _ x]].

	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing'!
dataColor

	^ dataColor
! !

!GraphMorph methodsFor: 'accessing'!
dataColor: aColor

	dataColor _ aColor.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:40'!
interpolatedValueAtCursor
	| sz prev frac next |
	data isEmpty ifTrue: [^0].
	sz := data size.
	cursor < 0 ifTrue: [^data first].	"just to be safe, though cursor shouldn't be negative"
	prev := cursor truncated.
	frac := cursor - prev.
	prev < 1 ifTrue: [prev := sz].
	prev > sz ifTrue: [prev := 1].
	"assert: 1 <= prev <= sz"
	frac = 0 ifTrue: [^data at: prev].	"no interpolation needed"

	"interpolate"
	next := prev = sz ifTrue: [1] ifFalse: [prev + 1].
	^(1.0 - frac) * (data at: prev) + (frac * (data at: next))! !

!GraphMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:40'!
lastValue
	data isEmpty ifTrue: [^0].
	^data last! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 4/21/1999 11:25'!
lastValue: aNumber

	self appendValue: aNumber.
! !

!GraphMorph methodsFor: 'accessing'!
startIndex

	^ startIndex
! !

!GraphMorph methodsFor: 'accessing'!
startIndex: aNumber

	startIndex ~= aNumber ifTrue:  [
		startIndex _ aNumber asInteger.
		self flushCachedForm].
! !

!GraphMorph methodsFor: 'accessing'!
valueAtCursor

	data isEmpty ifTrue: [^ 0].
	^ data at: ((cursor truncated max: 1) min: data size)
! !

!GraphMorph methodsFor: 'accessing'!
valueAtCursor: aPointOrNumber

	data isEmpty ifTrue: [^ 0].
	data
		at: ((cursor truncated max: 1) min: data size)
		put: (self asNumber: aPointOrNumber).
	self flushCachedForm.
! !


!GraphMorph methodsFor: 'commands'!
appendValue: aPointOrNumber

	| newVal |
	(data isKindOf: OrderedCollection) ifFalse: [data _ data asOrderedCollection].
	newVal _ self asNumber: aPointOrNumber.
	data addLast: newVal.
	newVal < minVal ifTrue: [minVal _ newVal].
	newVal > maxVal ifTrue: [maxVal _ newVal].
	self cursor: data size.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'commands' stamp: 'jm 7/30/1998 12:17'!
centerCursor
	"Scroll so that the cursor is as close as possible to the center of my window."

	| w |
	w _ self width - (2 * borderWidth).
	self startIndex: ((cursor - (w // 2)) max: 1).
! !

!GraphMorph methodsFor: 'commands'!
clear

	self startIndex: 1.
	self cursor: 1.
	self data: OrderedCollection new.
! !

!GraphMorph methodsFor: 'commands' stamp: 'ads 7/31/2003 11:11'!
loadSineWave

	self loadSoundData: SoundBuffer sineTable.
! !

!GraphMorph methodsFor: 'commands' stamp: 'jm 4/22/1999 14:17'!
loadSound: aSound

	self loadSoundData: aSound samples.
! !

!GraphMorph methodsFor: 'commands' stamp: 'jm 4/22/1999 14:23'!
loadSoundData: aCollection

	| scale absV newData |
	scale _ 0.
	aCollection do: [:v | (absV _ v abs) > scale ifTrue: [scale _ absV]].
	scale _ 100.0 / scale.
	newData _ OrderedCollection new: aCollection size.
	1 to: aCollection size do: [:i | newData addLast: (scale * (aCollection at: i))].

	self data: newData.
	self startIndex: 1.
	self cursor: 1.
! !

!GraphMorph methodsFor: 'commands' stamp: 'gk 2/23/2004 21:08'!
playOnce

	| scale absV scaledData |
	data isEmpty ifTrue: [^ self].  "nothing to play"
	scale _ 1.
	data do: [:v | (absV _ v abs) > scale ifTrue: [scale _ absV]].
	scale _ 32767.0 / scale.
	scaledData _ SoundBuffer newMonoSampleCount: data size.
	1 to: data size do: [:i | scaledData at: i put: (scale * (data at: i)) truncated].
	SoundService default playSampledSound: scaledData rate: 11025.
! !

!GraphMorph methodsFor: 'commands'!
reverse

	data _ data reversed.
	self flushCachedForm.
! !


!GraphMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 14:39'!
drawOn: aCanvas 
	| c |
	cachedForm isNil 
		ifTrue: 
			[c := Display defaultCanvasClass extent: bounds extent.
			c translateBy: bounds origin negated
				during: [:tempCanvas | self drawDataOn: tempCanvas].
			cachedForm := c form].
	aCanvas 
		cache: bounds
		using: cachedForm
		during: [:cachingCanvas | self drawDataOn: cachingCanvas].
	self drawCursorOn: aCanvas! !


!GraphMorph methodsFor: 'event handling' stamp: 'jm 10/18/97 11:32'!
handlesMouseDown: evt

	evt shiftPressed
		ifTrue: [^ super handlesMouseDown: evt]
		ifFalse: [^ true].
! !

!GraphMorph methodsFor: 'event handling' stamp: 'jm 10/18/97 11:52'!
mouseMove: evt

	| x w |
	x _ evt cursorPoint x - (bounds left + borderWidth).
	w _ self width - (2 * borderWidth).

	self changed.
	x < 0 ifTrue: [
		cursor _ startIndex + (3 * x).
		cursor _ (cursor max: 1) min: data size.
		^ self startIndex: cursor].
	x > w ifTrue: [
		cursor _ startIndex + w + (3 * (x - w)).
		cursor _ (cursor max: 1) min: data size.
		^ self startIndex: cursor - w].

	cursor _ ((startIndex + x) max: 1) min: data size.
! !


!GraphMorph methodsFor: 'e-toy support'!
cursor

	^ cursor
! !

!GraphMorph methodsFor: 'e-toy support' stamp: 'jm 6/17/1999 21:41'!
cursor: aNumber

	| truncP |
	cursor ~= aNumber ifTrue:  [
		cursor _ aNumber.
		truncP _ aNumber truncated.
		truncP > data size ifTrue: [cursor _ data size].
		truncP < 0 ifTrue: [cursor _ 1].
		self keepIndexInView: truncP.
		hasChanged _ true].
! !


!GraphMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:27'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.8
		g: 0.8
		b: 0.6! !

!GraphMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:28'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: 365 @ 80.

	dataColor _ Color darkGray.
	cursor _ 1.0.
	"may be fractional"
	cursorColor _ Color red.
	cursorColorAtZeroCrossings _ Color red.
	startIndex _ 1.
	hasChanged _ false.
	self
		data: ((0 to: 360 - 1)
				collect: [:x | (100.0 * x degreesToRadians sin) asInteger])! !


!GraphMorph methodsFor: 'layout'!
layoutChanged

	super layoutChanged.
	cachedForm _ nil.
! !


!GraphMorph methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:46'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	hasChanged ifNil: [hasChanged _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!GraphMorph methodsFor: 'stepping and presenter' stamp: 'dgd 2/22/2003 14:40'!
step
	"Make a deferred damage rectangle if I've changed. This allows applications to call methods that invalidate my display at high-bandwidth without paying the cost of doing the damage reporting on ever call; they can merely set hasChanged to true."

	super step.
	hasChanged isNil ifTrue: [hasChanged := false].
	hasChanged 
		ifTrue: 
			[self changed.
			hasChanged := false]! !


!GraphMorph methodsFor: '*sound' stamp: 'dgd 8/30/2003 21:45'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'open wave editor' translated action: #openWaveEditor.
	aCustomMenu add: 'read file' translated action: #readDataFromFile.
! !

!GraphMorph methodsFor: '*sound' stamp: 'stephaneducasse 2/4/2006 20:40'!
openWaveEditor

	| scaleFactor scaledData editor |
	self data: data.  "make sure maxVal and minVal are current"
	scaleFactor := 32767 // ((minVal abs max: maxVal abs) max: 1).
	scaledData := SoundBuffer newMonoSampleCount: data size.
	1 to: data size do: [:i | scaledData at: i put: (scaleFactor * (data at: i)) truncated].
	editor := WaveEditor new
		data: scaledData;
		samplingRate: 11025;
		perceivedFrequency: 220.0.
	editor openInWorld.
! !

!GraphMorph methodsFor: '*sound' stamp: 'stephaneducasse 2/4/2006 20:40'!
readDataFromFile

	| fileName |
	fileName := FillInTheBlank
		request: 'File name?' translated
		initialAnswer: ''.
	fileName isEmpty ifTrue: [^ self].
	(StandardFileStream isAFileNamed: fileName) ifFalse: [
		^ self inform: 'Sorry, I cannot find that file' translated].
	self data: (SampledSound fromAIFFfileNamed: fileName) samples.

! !


!GraphMorph methodsFor: 'private' stamp: 'jm 6/17/1999 21:36'!
drawCursorOn: aCanvas

	| ptr x r c |
	ptr _ (cursor asInteger max: 1) min: data size.
	c _ cursorColor.
	((ptr > 1) and: [ptr < data size]) ifTrue: [
		(data at: ptr) sign ~= (data at: ptr + 1) sign
			ifTrue: [c _ cursorColorAtZeroCrossings]].
	r _ self innerBounds.
	x _ r left + ptr - startIndex.
	((x >= r left) and: [x <= r right]) ifTrue: [
		aCanvas fillRectangle: (x@r top corner: x + 1@r bottom) color: c].
! !

!GraphMorph methodsFor: 'private'!
drawDataOn: aCanvas

	| yScale baseLine x start end value left top bottom right |
	super drawOn: aCanvas.

	data isEmpty ifTrue: [^ self].
	maxVal = minVal ifTrue: [
		yScale _ 1.
	] ifFalse: [
		yScale _ (bounds height - (2 * borderWidth)) asFloat / (maxVal - minVal)].
	baseLine _ bounds bottom - borderWidth + (minVal * yScale) truncated.
	left _ top _ 0. right _ 10. bottom _ 0.
	x _ bounds left + borderWidth.
	start _ (startIndex asInteger max: 1) min: data size.
	end _ (start + bounds width) min: data size.
	start to: end do: [:i |
		left _ x truncated. right _ x + 1.
		right > (bounds right - borderWidth) ifTrue: [^ self].
		value _ (data at: i) asFloat.
		value >= 0.0 ifTrue: [
			top _ baseLine - (yScale * value) truncated.
			bottom _ baseLine.
		] ifFalse: [
			top _ baseLine.
			bottom _ baseLine - (yScale * value) truncated].
		aCanvas fillRectangle: (left@top corner: right@bottom) color: dataColor.
		x _ x + 1].
! !

!GraphMorph methodsFor: 'private' stamp: 'jm 6/17/1999 20:10'!
flushCachedForm

	cachedForm _ nil.
	hasChanged _ true.
! !

!GraphMorph methodsFor: 'private' stamp: 'jm 4/21/1999 11:30'!
keepIndexInView: index

	| w newStart |
	w _ bounds width - (2 * borderWidth).
	index < startIndex ifTrue: [
		newStart _ index - w + 1.
		^ self startIndex: (newStart max: 1)].
	index > (startIndex + w) ifTrue: [
		^ self startIndex: (index min: data size)].
! !

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

GraphMorph class
	instanceVariableNames: ''!

!GraphMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:50'!
descriptionForPartsBin
	^ self partName:	'Graph'
		categories:		#('Useful')
		documentation:	'A graph of numbers, normalized so the full range of values just fits my height.  I support a movable cursor that can be dragged with the mouse.'! !


!GraphMorph class methodsFor: '*eToys-scripting' stamp: 'sw 9/26/2001 04:19'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(

	(basic (
(slot cursor 	'The current cursor location, wrapped back to the beginning if appropriate' Number	 readWrite Player getCursor Player setCursorWrapped:)

(slot sampleAtCursor	'The sample value at the current cursor location' Number readWrite Player getSampleAtCursor Player setSampleAtCursor:)))

	(sampling (
(slot cursor 	'The current cursor location, wrapped back to the beginning if appropriate' Number	 readWrite Player getCursor Player setCursorWrapped:)
(slot sampleAtCursor	'The sample value at the current cursor location' Number readWrite Player getSampleAtCursor Player setSampleAtCursor:)
(slot lastValue 'The last value obtained' Number readWrite	Player getLastValue Player setLastValue:)
(command clear 'Clear the graph of current contents')
(command loadSineWave 'Load a sine wave as the current graph')
(command loadSound: 'Load the specified sound into the current graph' Sound)
(command reverse 'Reverse the graph')
(command play 'Play the current graph as a sound'))))! !
OrderedCollection variableSubclass: #GraphicSymbol
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Symbols'!
!GraphicSymbol commentStamp: '<historical>' prior: 0!
I represent a structured picture built from primitive display objects and other instances of me.!


!GraphicSymbol methodsFor: 'accessing' stamp: 'jrm 2/6/2000 11:01'!
computeBoundingBox
	"Compute a boundingBox that encloses all of the Paths in this symbol"

	^Rectangle merging: (self collect: [:each | each computeBoundingBox])
! !


!GraphicSymbol methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Display the receiver on the Display where aTransformation is provided 
	as an argument, rule is anInteger and mask is aForm. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRect."

	self do: 
		[:element | 
		element
			displayOn: aDisplayMedium
			transformation: aTransformation
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!GraphicSymbol methodsFor: 'displaying'!
displayTransformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm
	"Display the receiver where aTransformation is provided as an argument, 
	rule is anInteger and mask is aForm. No translation. Information to be 
	displayed must be confined to the area that intersects with clipRect."

	self displayOn: Display transformation: aTransformation clippingBox: clipRect
		rule: anInteger fillColor: aForm! !
Object subclass: #GraphicSymbolInstance
	instanceVariableNames: 'transformation graphicSymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Symbols'!
!GraphicSymbolInstance commentStamp: '<historical>' prior: 0!
I represent a display transformation of a GraphicSymbol. Multiple copies of a GraphicSymbol can be displayed at different positions and scales on the screen by making appropriate, multiple, instances of me.!


!GraphicSymbolInstance methodsFor: 'accessing'!
graphicSymbol
	"Answer the graphic symbol that the receiver displays."

	^graphicSymbol! !

!GraphicSymbolInstance methodsFor: 'accessing'!
graphicSymbol: aGraphicSymbol 
	"Set the argument, aGraphicSymbol, to be the graphic symbol that the 
	receiver displays."

	graphicSymbol _ aGraphicSymbol! !


!GraphicSymbolInstance methodsFor: 'displaying' stamp: 'jrm 2/13/2000 10:02'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox:
clipRect rule: anInteger fillColor: aForm 
	"Display the graphic symbol on the Display according to the arguments 
	of this message."

	graphicSymbol
		displayOn: aDisplayMedium
		transformation: aTransformation 
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

!GraphicSymbolInstance methodsFor: 'displaying'!
displayTransformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm
	"Display the graphic symbol according to the arguments of this message."

	self displayOn: Display transformation: aTransformation clippingBox: clipRect
		rule: anInteger fillColor: aForm! !


!GraphicSymbolInstance methodsFor: 'transforming'!
transformation
	"Answer the receiver's display transformation."

	^transformation! !

!GraphicSymbolInstance methodsFor: 'transforming'!
transformation: aWindowingTransformation 
	"Set the argument, aWindowingTransformation, to be the receiver's 
	display transformation."

	transformation _ aWindowingTransformation! !

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

GraphicSymbolInstance class
	instanceVariableNames: ''!

!GraphicSymbolInstance class methodsFor: 'examples'!
example
	"Simply evaluate the method and two GraphicSymbolInstances, each
	displaying a transformation of the same graphic symbol, will be
	presented on the screen. Clears the screen to white."

	| gate instance1 instance2 trans1 trans2 line arc f|
	Display fillWhite.			"clear the Screen."
	f _ Form extent: 2@2.
	f fillBlack.
	gate_ GraphicSymbol new.		"make a logic gate out of lines and arcs."
	line_Line new.  line beginPoint: -20@-20.  line endPoint: 0@-20. line form: f.
	gate add: line.

	line_Line new.  line beginPoint: -20@20.  line endPoint: 0@20. line form: f.
	gate add: line.

	line_Line new.  line beginPoint: 0@-40.  line endPoint: 0@40. line form: f.
	gate add: line.

	arc _ Arc new. arc center: 0@0 radius: 40 quadrant: 1.
	arc form: f.
	gate add: arc.

	arc _ Arc new. arc center: 0@0 radius: 40 quadrant: 4.
	arc form: f.
	gate add: arc.

			"one instance at 1/2 scale."
	trans1_WindowingTransformation identity.	
	trans1_ trans1 scaleBy: 0.5@0.5.
	trans1_ trans1 translateBy: 100@100.

			"the other instance at 2 times scale"
	trans2_WindowingTransformation identity.	
	trans2_ trans2 scaleBy: 2.0@2.0.
	trans2_ trans2 translateBy: 200@200.

	instance1 _ GraphicSymbolInstance new.
	instance1 transformation: trans1.
	instance1 graphicSymbol: gate.

	instance2 _ GraphicSymbolInstance new.
	instance2 transformation: trans2.
	instance2 graphicSymbol: gate.

			"display both instances of the logic gate"
	instance1 displayOn: Display
					transformation: WindowingTransformation identity
					clippingBox: Display boundingBox
					rule: Form under
					fillColor: nil.
	instance2 displayOn: Display
					transformation: WindowingTransformation identity
					clippingBox: Display boundingBox
					rule: Form under
					fillColor: nil

	"GraphicSymbolInstance example"! !
TileMorph subclass: #GraphicTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!GraphicTile commentStamp: '<historical>' prior: 0!
A tile representing a graphic image.!


!GraphicTile methodsFor: 'accessing' stamp: 'sw 9/26/2001 04:05'!
resultType
	"Answer the result type of the argument represented by the receiver"

	^ #Graphic! !


!GraphicTile methodsFor: 'code generation' stamp: 'sw 4/2/2001 23:09'!
storeCodeOn: aStream indent: tabCount
	"Write code that will reconstitute the receiver"

	aStream nextPutAll: literal uniqueNameForReference! !


!GraphicTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	type _ #literal.
	self
		useForm: (ScriptingSystem formAtKey: #Menu)! !

!GraphicTile methodsFor: 'initialization' stamp: 'sw 4/3/2001 15:52'!
setLiteral: anObject
	"Set the receiver's literal to be anObject. No readout morph here."

	type _ #literal.
	self setLiteralInitially: anObject.
! !

!GraphicTile methodsFor: 'initialization' stamp: 'sw 4/3/2001 15:40'!
useForm: aForm
	"Set the receiver to represent the given form"

	| thumbnail |
	self removeAllMorphs.
	literal _ aForm.
	thumbnail _ ThumbnailMorph  new objectToView: self viewSelector: #literal.
	self addMorphBack: thumbnail.
	thumbnail extent: 16 @ 16.! !
DataType subclass: #GraphicType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!

!GraphicType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:29'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ ScriptingSystem formAtKey: #PaintTab! !


!GraphicType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:24'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	self vocabularyName: #Graphic.! !


!GraphicType methodsFor: '*eToys-color' stamp: 'sw 9/27/2001 17:21'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(0.806 1.0 0.806)	! !


!GraphicType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ GraphicTile new typeColor: self typeColor! !

!GraphicType methodsFor: '*eToys-tiles' stamp: 'sw 9/25/2001 21:06'!
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter
	"Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter"

	^ ThumbnailMorph new objectToView: aTarget viewSelector: getter; extent: 21@21; yourself! !
GraphicalMenu subclass: #GraphicalDictionaryMenu
	instanceVariableNames: 'baseDictionary entryNames lastSearchString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWidgets'!
!GraphicalDictionaryMenu commentStamp: '<historical>' prior: 0!
A morph that allows you to view, rename, and remove elements from a dictionary whose keys are strings and whose values are forms.!


!GraphicalDictionaryMenu methodsFor: 'initialization' stamp: 'sw 12/24/1998 11:59'!
baseDictionary: aDictionary
	baseDictionary _ aDictionary.
	entryNames _ aDictionary keys asSortedArray.
	formChoices _ entryNames collect: [:n | aDictionary at: n].
	currentIndex _ 1! !

!GraphicalDictionaryMenu methodsFor: 'initialization' stamp: 'nk 1/11/2004 16:22'!
initializeFor: aTarget fromDictionary: aDictionary 
	"Initialize me for a target and a dictionary."

	| anIndex aButton |
	self baseDictionary: aDictionary.
	target := aTarget.
	coexistWithOriginal := true.
	self extent: 210 @ 210.
	self clipSubmorphs: true.
	self layoutPolicy: ProportionalLayout new.
	aButton := (IconicButton new)
				borderWidth: 0;
				labelGraphic: (ScriptingSystem formAtKey: 'TinyMenu');
				color: Color transparent;
				actWhen: #buttonDown;
				actionSelector: #showMenu;
				target: self;
				setBalloonText: 'menu'.
	self addMorph: aButton
		fullFrame: (LayoutFrame fractions: (0.5 @ 0 extent: 0 @ 0)
				offsets: (-50 @ 6 extent: aButton extent)).
	aButton := (SimpleButtonMorph new)
				target: self;
				borderColor: Color black;
				label: 'Prev';
				actionSelector: #downArrowHit;
				actWhen: #whilePressed;
				setBalloonText: 'show previous picture';
				yourself.
	self addMorph: aButton
		fullFrame: (LayoutFrame fractions: (0.5 @ 0 extent: 0 @ 0)
				offsets: (-24 @ 4 extent: aButton extent)).
	aButton := (SimpleButtonMorph new)
				target: self;
				borderColor: Color black;
				label: 'Next';
				actionSelector: #upArrowHit;
				actWhen: #whilePressed;
				setBalloonText: 'show next pictutre'.
	self addMorph: aButton
		fullFrame: (LayoutFrame fractions: (0.5 @ 0 extent: 0 @ 0)
				offsets: (24 @ 4 extent: aButton extent)).
	self addMorph: ((UpdatingStringMorph new)
				contents: ' ';
				target: self;
				putSelector: #renameGraphicTo:;
				getSelector: #truncatedNameOfGraphic;
				useStringFormat;
				setBalloonText: 'The name of the current graphic';
				yourself)
		fullFrame: (LayoutFrame fractions: (0 @ 0 extent: 1 @ 0)
				offsets: (10 @ 40 corner: -10 @ 60)).
	self addMorph: ((Morph new)
				extent: 100 @ 4;
				color: Color black)
		fullFrame: (LayoutFrame fractions: (0 @ 0 extent: 1 @ 0)
				offsets: (0 @ 60 corner: 0 @ 64)).
	formDisplayMorph := (Thumbnail new)
				extent: 100 @ 100;
				useInterpolation: true;
				maxWidth: 3000 minHeight: 100;
				yourself.
	self addMorph: formDisplayMorph
		fullFrame: (LayoutFrame fractions: (0 @ 0 extent: 0@0)
				offsets: (8 @ 72 corner:  108 @ 172)).
	self minimumExtent: 116@180.
	target ifNotNil: 
			[(anIndex := formChoices indexOf: target form ifAbsent: []) 
				ifNotNil: [currentIndex := anIndex]].
	self updateThumbnail! !


!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 11/10/2003 13:14'!
browseIconReferences
	"Browse all calls on the symbol by which the currently-seen graphic is keyed"

	self systemNavigation browseAllCallsOn: self nameOfGraphic! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 11/10/2003 13:14'!
browseStringIconReferences
	"Browse string references to the selected entry's key"

	self systemNavigation browseMethodsWithString: self nameOfGraphic asString matchCase: true! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 10/25/2002 16:58'!
copyName
	"Copy the name of the current selection to the clipboard"

	Clipboard clipboardText: self nameOfGraphic asText! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 10/12/2004 05:04'!
findAgain
	"Look for the next occurrence of the search string"

	| toFind searchIndex |
	lastSearchString ifNil: [lastSearchString _ 'controls'].
	searchIndex _ currentIndex + 1.
	searchIndex > entryNames size ifTrue:
		[currentIndex _ 0.
		self inform: 'not found' translated.
		^ self].
	toFind _ '*', lastSearchString, '*'.
	[toFind match: (entryNames at: searchIndex) asString]
		whileFalse:
			[searchIndex _ (searchIndex \\ entryNames size) + 1.
			searchIndex == currentIndex ifTrue:
				[^ (toFind match: (entryNames at: searchIndex) asString)
					ifFalse:
						[self inform: 'not found' translated]
					ifTrue:
						[self flash]]].

	currentIndex _ searchIndex.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 2/24/2003 15:57'!
findEntry
	"Prompt the user for a search string and find the next match for it"

	| toFind searchIndex |
	lastSearchString ifNil: [lastSearchString _ 'controls'].
	toFind _ FillInTheBlank request: 'Type name or fragment: ' initialAnswer: lastSearchString.
	toFind isEmptyOrNil ifTrue: [^ self].
	lastSearchString _ toFind asLowercase.
	searchIndex _ currentIndex + 1.
	toFind _ '*', lastSearchString, '*'.
	[toFind match: (entryNames at: searchIndex) asString]
		whileFalse:
			[searchIndex _ (searchIndex \\ entryNames size) + 1.
			searchIndex == currentIndex ifTrue: [^ self inform: 'not found']].

	currentIndex _ searchIndex.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'nk 1/6/2004 12:36'!
handMeOne
	self currentHand attachMorph: (World drawingClass new form: (formChoices at: currentIndex))! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 12/24/1998 12:15'!
removeEntry
	baseDictionary removeKey: (entryNames at: currentIndex).
	self baseDictionary: baseDictionary.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'nb 6/17/2003 12:25'!
renameEntry
	| reply curr |
	reply _ FillInTheBlank
		request: 'New key? '
		initialAnswer: (curr _ entryNames at: currentIndex)
		centerAt: self center.
	(reply isEmptyOrNil or: [reply = curr]) ifTrue: [^ Beeper beep].
	(baseDictionary includesKey: reply) ifTrue:
		[^ self inform: 'sorry that conflicts with
the name of another
entry in this dictionary'].
	baseDictionary at: reply put: (baseDictionary at: curr).
	baseDictionary removeKey: curr.
	self baseDictionary: baseDictionary.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'nb 6/17/2003 12:25'!
renameGraphicTo: newName
	| curr |
	curr _ entryNames at: currentIndex.
	(newName isEmptyOrNil or: [newName = curr]) ifTrue: [^ Beeper beep].
	(baseDictionary includesKey: newName) ifTrue:
		[^ self inform: 'sorry that conflicts with
the name of another
entry in this dictionary'].
	baseDictionary at: newName put: (baseDictionary at: curr).
	baseDictionary removeKey: curr.
	self baseDictionary: baseDictionary.
	currentIndex _ entryNames indexOf: newName.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'nk 1/6/2004 12:37'!
repaintEntry
	"Let the user enter into painting mode to repaint the item and save it back."

	| aWorld bnds sketchEditor aPaintBox formToEdit |
	
	(aWorld _ self world) assureNotPaintingElse: [^ self].

	aWorld prepareToPaint.
	aWorld displayWorld.
	formToEdit _ formChoices at: currentIndex.
	bnds _ (submorphs second boundsInWorld origin extent: formToEdit extent) intersect: aWorld bounds.
	bnds _ (aWorld paintingBoundsAround: bnds center) merge: bnds.
	sketchEditor _ SketchEditorMorph new.
	aWorld addMorphFront: sketchEditor.
	sketchEditor initializeFor: ((World drawingClass withForm: formToEdit) position: submorphs second positionInWorld)  inBounds: bnds pasteUpMorph: aWorld paintBoxPosition: bnds topRight.
	sketchEditor
		afterNewPicDo: [:aForm :aRect |
			formChoices at: currentIndex put: aForm.
			baseDictionary at: (entryNames at: currentIndex) put: aForm.
			self updateThumbnail.
			(aPaintBox _ aWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]] 
		ifNoBits:
			[(aPaintBox _ aWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]].
	
! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 2/24/2003 15:59'!
showMenu
	"Show the receiver's menu"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu title: 'Graphics Library'.
	aMenu addStayUpItem.
	aMenu addList: #(
		('remove'			removeEntry			'Remove this entry from the dictionary')
		('rename'			renameEntry			'Rename this entry')
		('repaint'			repaintEntry			'Edit the actual graphic for this entry' )
		-
		('hand me one'		handMeOne				'Hand me a morph with this picture as its form')
		('browse symbol references'
							browseIconReferences	'Browse methods that refer to this icon''s name')
		('browse string references'
							browseStringIconReferences'
													'Browse methods that refer to string constants that contian this icon''s name)
		('copy name'		copyName				'Copy the name of this graphic to the clipboard')
		-
		('find...'			findEntry				'Find an entry by name')
		('find again'		findAgain				'Find the next match for the keyword previously searched for')).
	aMenu popUpInWorld
! !

!GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 5/28/2000 23:19'!
truncatedNameOfGraphic
	^ self nameOfGraphic truncateTo: 30! !


!GraphicalDictionaryMenu methodsFor: 'private' stamp: 'sw 12/24/1998 11:25'!
nameOfGraphic
	^ entryNames at: currentIndex! !

!GraphicalDictionaryMenu methodsFor: 'private' stamp: 'nk 1/11/2004 15:14'!
updateThumbnail
	super updateThumbnail.
	(self findA: UpdatingStringMorph)
		doneWithEdits;
		contents: (entryNames at: currentIndex)
! !

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

GraphicalDictionaryMenu class
	instanceVariableNames: ''!

!GraphicalDictionaryMenu class methodsFor: 'example' stamp: 'sd 5/11/2003 20:53'!
example
	"GraphicalDictionaryMenu example"
	| aDict |
	aDict _ Dictionary new.
	#('ColorTilesOff' 'ColorTilesOn' 'Controls') do:
		[:aString | aDict at: aString put: (ScriptingSystem formAtKey: aString)].
	self openOn: aDict withLabel: 'Testing One Two Three'! !

!GraphicalDictionaryMenu class methodsFor: 'example' stamp: 'sd 5/11/2003 20:56'!
example2
	"GraphicalDictionaryMenu example2"
	| aDict |
	aDict _ Dictionary new.
	self openOn: aDict withLabel: 'Testing Zero'! !


!GraphicalDictionaryMenu class methodsFor: 'instance creation' stamp: 'nk 1/11/2004 15:50'!
openOn: aFormDictionary withLabel: aLabel
	"open a graphical dictionary in a window having the label aLabel. 
     aFormDictionary should be a dictionary containing as value a form."

	| inst aWindow |
	aFormDictionary size isZero ifTrue: [^ self inform: 'Empty!!'].	
	inst := self new initializeFor: nil fromDictionary: aFormDictionary.

	aWindow _ (SystemWindow labelled: aLabel) model: inst.
	aWindow addMorph: inst frame: (0@0 extent: 1@1).
	aWindow extent: inst fullBounds extent + (3 @ aWindow labelHeight + 3);
		minimumExtent: inst minimumExtent + (3 @ aWindow labelHeight + 3).
	
     HandMorph attach: aWindow.

	^ inst! !
AlignmentMorph subclass: #GraphicalMenu
	instanceVariableNames: 'target selector argument currentIndex formChoices formDisplayMorph coexistWithOriginal'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWidgets'!

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
argument
	^argument! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
argument: anObject
	argument _ anObject! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/4/1998 23:49'!
cancel
	coexistWithOriginal
		ifTrue:
			[self delete]
		ifFalse:
			[owner replaceSubmorph: self topRendererOrSelf by: target]! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 17:56'!
downArrowHit
	currentIndex _ currentIndex - 1.
	(currentIndex < 1) ifTrue:  [currentIndex _ formChoices size].
	self updateThumbnail
	
! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
okay
	| nArgs |
	target ifNotNil:[
		nArgs _ selector numArgs.
		nArgs = 1 ifTrue:[target perform: selector with: (formChoices at: currentIndex)].
		nArgs = 2 ifTrue:[target perform: selector with: (formChoices at: currentIndex) with: argument]].
	coexistWithOriginal
		ifTrue:
			[self delete]
		ifFalse:
			[owner replaceSubmorph: self topRendererOrSelf by: target]! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
selector
	^selector! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
selector: aSymbol
	selector _ aSymbol! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 17:54'!
upArrowHit
	currentIndex _ currentIndex + 1.
	(currentIndex > formChoices size) ifTrue: [currentIndex _ 1].
	self updateThumbnail
	
! !


!GraphicalMenu methodsFor: 'event handling' stamp: 'nk 1/11/2004 14:44'!
updateThumbnail
	| f |
	f _ formChoices at: currentIndex.
	formDisplayMorph 
		makeThumbnailFromForm: f.
! !


!GraphicalMenu methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color blue darker! !

!GraphicalMenu methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

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

!GraphicalMenu methodsFor: 'initialization' stamp: 'ar 6/25/1999 11:53'!
initialize
	super initialize.
	selector _ #newForm:.! !

!GraphicalMenu methodsFor: 'initialization' stamp: 'nk 1/11/2004 15:09'!
initializeFor: aTarget withForms: formList coexist: aBoolean 
	"World primaryHand attachMorph:
		(GraphicalMenu new initializeFor: nil  
		withForms: Form allInstances coexist: true)"
	| buttons bb anIndex buttonCage |
	target := aTarget.
	coexistWithOriginal := aBoolean.
	formChoices := formList.
	currentIndex := 1.
	self borderWidth: 1;
		 cellPositioning: #center;
		 color: Color white;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap.
	buttons := AlignmentMorph newRow.
	buttons borderWidth: 0;
		 layoutInset: 0.
	buttons hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 extent: 5 @ 5.
	buttons wrapCentering: #topLeft.
	buttonCage := AlignmentMorph newColumn.
	buttonCage hResizing: #shrinkWrap;
		 vResizing: #spaceFill.
	buttonCage addTransparentSpacerOfSize: 0 @ 10.
	bb := SimpleButtonMorph new target: self;
				 borderColor: Color black.
	buttons addMorphBack: (bb label: 'Prev';
			 actionSelector: #downArrowHit;
			 actWhen: #whilePressed).
	buttons addTransparentSpacerOfSize: 9 @ 0.
	bb := SimpleButtonMorph new target: self;
				 borderColor: Color black.
	buttons addMorphBack: (bb label: 'Next';
			 actionSelector: #upArrowHit;
			 actWhen: #whilePressed).
	buttons addTransparentSpacerOfSize: 5 @ 0.
	buttons submorphs last color: Color white.
	buttonCage addMorphBack: buttons.
	buttonCage addTransparentSpacerOfSize: 0 @ 12.
	buttons := AlignmentMorph newRow.
	bb := SimpleButtonMorph new target: self;
				 borderColor: Color black.
	buttons addMorphBack: (bb label: 'OK';
			 actionSelector: #okay).
	buttons addTransparentSpacerOfSize: 5 @ 0.
	bb := SimpleButtonMorph new target: self;
				 borderColor: Color black.
	buttons addMorphBack: (bb label: 'Cancel';
			 actionSelector: #cancel).
	buttonCage addMorphBack: buttons.
	buttonCage addTransparentSpacerOfSize: 0 @ 10.
	self addMorphFront: buttonCage.
	formDisplayMorph := Thumbnail new extent: 100 @ 100;
				 maxWidth: 100 minHeight: 30;
				 yourself.
	self addMorphBack: (Morph new color: Color white;
			 layoutPolicy: TableLayout new;
			 layoutInset: 4 @ 4;
			 hResizing: #spaceFill;
			 vResizing: #spaceFill;
			 listCentering: #center;
			 addMorphBack: formDisplayMorph;
			 yourself).
	target
		ifNotNil: [(anIndex := formList
						indexOf: target form
						ifAbsent: [])
				ifNotNil: [currentIndex := anIndex]].
	self updateThumbnail! !
SmallLandColorTheme subclass: #GraySmallLandColorTheme
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!GraySmallLandColorTheme methodsFor: 'initialization' stamp: 'dgd 3/12/2006 14:48'!
baseColors
	" 
	GraySmallLandColorTheme apply.
	"
	^ Array
		with: (Color fromArray: #(0.4 0.4 0.4 ))
		with: (Color fromArray: #(0.8 0.8 0.8 ))
		with: (Color fromArray: #(0.97 0.97 0.97 ))! !
LanguageEnvironment subclass: #GreekEnvironment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Languages'!
!GreekEnvironment commentStamp: '<historical>' prior: 0!
This class provides the support for Greek.  It is here, but most of the methods are not implemented yet.
!


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

GreekEnvironment class
	instanceVariableNames: ''!

!GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 00:38'!
leadingChar

	^ 13.
! !

!GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:23'!
supportedLanguages
	"Return the languages that this class supports. 
	Any translations for those languages will use this class as their environment."
	
	^#('el' )! !
SmallLandColorTheme subclass: #GreenSmallLandColorTheme
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!GreenSmallLandColorTheme methodsFor: 'initialize-release' stamp: 'dgd 3/12/2006 13:50'!
baseColors
	" 
	GreenSmallLandColorTheme apply.
	"
	^ Array
		with: (Color fromArray: #(0.1 0.5 0.3 ))
		with: (Color fromArray: #(0.2 0.9 0.6 ))
		with: (Color fromArray: #(0.85 1.0 0.98 ))! !
Object subclass: #HTTPClient
	instanceVariableNames: ''
	classVariableNames: 'BrowserSupportsAPI RunningInBrowser'
	poolDictionaries: ''
	category: 'System-Support'!

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

HTTPClient class
	instanceVariableNames: ''!

!HTTPClient class methodsFor: 'class initialization' stamp: 'mir 4/2/2002 15:37'!
browserSupportsAPI
	^BrowserSupportsAPI == true! !

!HTTPClient class methodsFor: 'class initialization' stamp: 'mir 4/2/2002 15:36'!
browserSupportsAPI: aBoolean
	BrowserSupportsAPI _ aBoolean! !

!HTTPClient class methodsFor: 'class initialization' stamp: 'mir 2/2/2001 17:27'!
determineIfRunningInBrowser
	"HTTPClient determineIfRunningInBrowser"

	RunningInBrowser _ StandardFileStream isRunningAsBrowserPlugin
! !


!HTTPClient class methodsFor: 'examples' stamp: 'mir 2/2/2001 17:43'!
exampleMailTo
	"HTTPClient exampleMailTo"

	HTTPClient mailTo: 'm.rueger@acm.org' message: 'A test message from within Squeak'
! !

!HTTPClient class methodsFor: 'examples' stamp: 'md 7/28/2005 10:33'!
examplePostArgs
	"HTTPClient examplePostArgs"

	| args result |
	args := Dictionary new.
	args
		at: 'arg1' put: #('val1');
		at: 'arg2' put: #('val2');
		yourself.
	result := HTTPClient httpPostDocument: 'http://www.squeaklet.com/cgi-bin/thrd.pl [^]' args: args.
	Transcript show: result content; cr; cr.

! !

!HTTPClient class methodsFor: 'examples' stamp: 'mir 2/2/2001 17:44'!
examplePostMultipart
	"HTTPClient examplePostMultipart"

	| args result |
	args _ Dictionary new.
	args
		at: 'arg1' put: #('val1');
		at: 'arg2' put: #('val2');
		yourself.
	result _ HTTPClient httpPostMultipart: 'http://www.squeaklet.com/cgi-bin/thrd.pl'  args: args.
	Transcript show: result content; cr; cr.

! !


!HTTPClient class methodsFor: 'post/get' stamp: 'nk 8/30/2004 07:50'!
httpGet: url
	| document |
	document _ self httpGetDocument: url.
	^(document isString)
		ifTrue: [
			"strings indicate errors"
			document]
		ifFalse: [(RWBinaryOrTextStream with: document content) reset]! !

!HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/11/2001 12:55'!
httpGetDocument: url
	| stream content | 
	^self shouldUsePluginAPI
		ifTrue: [
			stream _ FileStream requestURLStream: url ifError: [self error: 'Error in get from ' , url printString].
			stream ifNil: [^''].
			stream position: 0.
			content _ stream upToEnd.
			stream close.
			MIMEDocument content: content]
		ifFalse: [HTTPSocket httpGetDocument: url]! !

!HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 15:04'!
httpPostDocument: url args: argsDict
	^self httpPostDocument: url target: nil args: argsDict! !

!HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 15:06'!
httpPostDocument: url target: target args: argsDict
	| argString stream content |
	^self shouldUsePluginAPI
		ifTrue: [
			argString _ argsDict
				ifNotNil: [argString _ HTTPSocket argString: argsDict]
				ifNil: [''].
			stream _ FileStream post: argString , ' ' target: target url: url , argString ifError: [self error: 'Error in post to ' , url printString].
			stream position: 0.
			content _ stream upToEnd.
			stream close.
			MIMEDocument content: content]
		ifFalse: [HTTPSocket httpPostDocument: url  args: argsDict]! !

!HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 12:51'!
httpPostMultipart: url args: argsDict
	" do multipart/form-data encoding rather than x-www-urlencoded "

	^self shouldUsePluginAPI
		ifTrue: [self pluginHttpPostMultipart: url args: argsDict]
		ifFalse: [HTTPSocket httpPostMultipart: url args: argsDict accept: nil request: '']! !

!HTTPClient class methodsFor: 'post/get' stamp: 'mir 4/2/2002 15:52'!
requestURL: url target: target
	^self shouldUsePluginAPI
		ifTrue: [FileStream requestURL: url target: target]
		ifFalse: [self error: 'Requesting a new URL target is not supported.']! !


!HTTPClient class methodsFor: 'testing' stamp: 'ccn 3/14/2001 19:56'!
isRunningInBrowser

	RunningInBrowser isNil
		ifTrue: [self determineIfRunningInBrowser].
	^RunningInBrowser! !

!HTTPClient class methodsFor: 'testing' stamp: 'mir 8/4/2003 13:44'!
isRunningInBrowser: aBoolean
	"Override the automatic process.
	This should be used with caution.
	One way to determine it without using the primitive is to check for parameters typically only encountered when running as a plugin."

	RunningInBrowser := aBoolean! !

!HTTPClient class methodsFor: 'testing' stamp: 'sd 9/30/2003 13:56'!
shouldUsePluginAPI
	"HTTPClient shouldUsePluginAPI" 

	self isRunningInBrowser
		ifFalse: [^false].
	self browserSupportsAPI
		ifFalse: [^false].
	"The Mac plugin calls do not work in full screen mode"
	^((SmalltalkImage current  platformName = 'Mac OS')
		and: [ScreenController lastScreenModeSelected]) not! !


!HTTPClient class methodsFor: 'utilities' stamp: 'mir 8/22/2001 12:29'!
composeMailTo: address subject: subject body: body
	"HTTPClient composeMailTo: 'michael.rueger@squeakland.org' subject: 'test subject' body: 'message' "
	| mailTo |
	mailTo _ WriteStream on: String new.
	mailTo nextPutAll: 'mailto:'.
	mailTo
		nextPutAll: address;
		nextPut: $?.
	subject isEmptyOrNil
		ifFalse: [mailTo nextPutAll: 'subject='; nextPutAll: subject; nextPut: $&].
	body isEmptyOrNil
		ifFalse: [mailTo nextPutAll: 'body='; nextPutAll: body].

	self httpGet: mailTo contents! !

!HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/13/2003 10:43'!
getDirectoryListing: dirListURL
	"HTTPClient getDirectoryListing: 'http://www.squeakalpha.org/uploads' "
	| answer ftpEntries |
"	answer _ self 
		httpPostDocument: dirListURL
		args: Dictionary new."
	"Workaround for Mac IE problem"
	answer _ self httpGetDocument: dirListURL.
	answer isString
		ifTrue: [^self error: 'Listing failed: ' , answer]
		ifFalse: [answer _ answer content].
	answer first == $<
		ifTrue: [self error: 'Listing failed: ' , answer].
	ftpEntries _ answer findTokens: String crlf.
	^ ftpEntries 
		collect:[:ftpEntry | ServerDirectory parseFTPEntry: ftpEntry]
		thenSelect: [:entry | entry notNil]! !

!HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/1/2001 12:51'!
mailTo: address message: aString
	HTTPClient shouldUsePluginAPI
		ifFalse: [^self error: 'You need to run inside a web browser.'].
	FileStream post: aString url: 'mailto:' , address ifError: [self error: 'Can not send mail']! !

!HTTPClient class methodsFor: 'utilities' stamp: 'md 2/24/2006 15:17'!
tellAFriend: emailAddressOrNil url: urlForLoading name: projectName
	| recipient subject body linkToInclude |
	recipient _ emailAddressOrNil ifNil: ['RECIPIENT.GOESHERE'].
	subject _ 'New/Updated Squeak project'.
	body _ 'This is a link to the Squeak project ' , projectName , ': ' , String crlf.
	linkToInclude _ urlForLoading.
	HTTPClient shouldUsePluginAPI
		ifTrue: [
			self composeMailTo: recipient subject: subject body: body , (linkToInclude copyReplaceAll: '%' with: '%25')]
		ifFalse: [FancyMailComposition new
				celeste: nil 
				to: recipient
				subject: subject
				initialText: body
				theLinkToInclude: linkToInclude;
				open].! !

!HTTPClient class methodsFor: 'utilities' stamp: 'mir 2/2/2001 17:59'!
uploadFileNamed: aFilename to: baseUrl user: user passwd: passwd

	| fileContents remoteFilename |
	remoteFilename _ (baseUrl endsWith: '/')
		ifTrue: [baseUrl , '/' , aFilename]
		ifFalse: [baseUrl , aFilename].
	fileContents _ (StandardFileStream readOnlyFileNamed: aFilename) contentsOfEntireFile.
	HTTPSocket httpPut: fileContents to: remoteFilename user: user passwd: passwd! !


!HTTPClient class methodsFor: 'private' stamp: 'fbs 2/2/2005 13:23'!
pluginHttpPostMultipart: url args: argsDict
	| mimeBorder argsStream crLf fieldValue resultStream result |
	" do multipart/form-data encoding rather than x-www-urlencoded "

	crLf _ String crlf.
	mimeBorder _ '----squeak-', Time millisecondClockValue printString, '-stuff-----'.
	"encode the arguments dictionary"
	argsStream _ WriteStream on: String new.
	argsDict associationsDo: [:assoc |
		assoc value do: [ :value |
		"print the boundary"
		argsStream nextPutAll: '--', mimeBorder, crLf.
		" check if it's a non-text field "
		argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'.
		(value isKindOf: MIMEDocument)
			ifFalse: [fieldValue _ value]
			ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', crLf, 'Content-Type: ', value contentType.
				fieldValue _ (value content
					ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile]
					ifNotNil: [value content]) asString].
" Transcript show: 'field=', key, '; value=', fieldValue; cr. "
		argsStream nextPutAll: crLf, crLf, fieldValue, crLf.
	]].
	argsStream nextPutAll: '--', mimeBorder, '--'.
	resultStream _ FileStream
		post: 
			('ACCEPT: text/html', crLf,
			'User-Agent: Squeak 3.1', crLf,
			'Content-type: multipart/form-data; boundary=', mimeBorder, crLf,
			'Content-length: ', argsStream contents size printString, crLf, crLf, 
			argsStream contents)
		url: url ifError: [^'Error in post ' url asString].
	"get the header of the reply"
	result _ resultStream
		ifNil: ['']
		ifNotNil: [resultStream upToEnd].
	^MIMEDocument content: result! !
Object subclass: #HTTPDownloadRequest
	instanceVariableNames: 'semaphore url content loader process'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Download'!

!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:26'!
content: retrievedContent
	content _ retrievedContent.
	semaphore signal! !

!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 5/30/2001 21:03'!
contentStream
	"Return a stream on the content of a previously completed HTTP request"
	semaphore wait.
	^content ifNotNil:[content contentStream]! !

!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:25'!
contents
	semaphore wait.
	^content! !

!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 10/7/1999 16:57'!
process: aProcess
	process _ aProcess! !

!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 1/15/2000 22:55'!
signalAbort
	loader removeProcess: process.
	self content: 'Retrieval aborted'.
	process ifNotNil: [process terminate]! !

!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 1/10/2000 18:33'!
startRetrieval
	self content: url asUrl retrieveContents! !


!HTTPDownloadRequest methodsFor: 'initialize' stamp: 'KR 9/4/2005 10:33'!
for: aUrl in: aLoader
	url _ aUrl.
	loader _ aLoader.
	semaphore _ Semaphore new.! !


!HTTPDownloadRequest methodsFor: 'testing' stamp: 'ar 3/2/2001 16:53'!
isSemaphoreSignaled
	"Return true if the associated semaphore is currently signaled. This information can be used to determine whether the download has finished given that there is no other process waiting on the semaphore."
	^semaphore isSignaled! !


!HTTPDownloadRequest methodsFor: '*MorphicExtras-accessing' stamp: 'mir 1/20/2000 13:33'!
url
	^url! !


!HTTPDownloadRequest methodsFor: 'private' stamp: 'yo 7/29/2005 16:04'!
httpEncodeSafely: aUrl
	"Encode the url but skip $/ and $:."

	| unescaped |
	unescaped _ aUrl unescapePercents.

	^ unescaped encodeForHTTPWithTextEncoding: 'utf-8'
		conditionBlock: [:c | c isSafeForHTTP or: [c = $/ or: [c = $:]]].
! !

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

HTTPDownloadRequest class
	instanceVariableNames: ''!

!HTTPDownloadRequest class methodsFor: 'instance creation' stamp: 'mir 10/7/1999 16:59'!
for: aUrl in: aLoader
	^self new for: aUrl in: aLoader! !
Object subclass: #HTTPLoader
	instanceVariableNames: 'requests downloads'
	classVariableNames: 'DefaultLoader MaxNrOfConnections'
	poolDictionaries: ''
	category: 'System-Download'!

!HTTPLoader methodsFor: 'initialize/release' stamp: 'mir 10/7/1999 18:14'!
initialize
	requests _ SharedQueue new.
	downloads _ OrderedCollection new! !

!HTTPLoader methodsFor: 'initialize/release' stamp: 'mir 10/7/1999 16:59'!
release
	self abort.
	downloads _ nil.
	requests _ nil! !


!HTTPLoader methodsFor: 'requests' stamp: 'mir 1/15/2000 22:59'!
abort
	| oldRequests |
	"Abort all requests"
	oldRequests _ requests.
	requests _ SharedQueue new.
	[oldRequests isEmpty] whileFalse: [
		oldRequests next signalAbort].
	downloads do: [:each | each ifNotNil: [each terminate]].
	downloads _ OrderedCollection new
! !

!HTTPLoader methodsFor: 'requests' stamp: 'mir 4/16/2001 17:48'!
retrieveContentsFor: url
	| request |
	request _ self class httpRequestClass for: url in: self.
	self addRequest: request.
	^request contents! !

!HTTPLoader methodsFor: 'requests' stamp: 'nk 8/30/2004 07:50'!
retrieveObjectsFor: aURL
	"Load a remote image segment and extract the root objects.
	Check if the remote file is a zip archive."
	"'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.extSeg' 
		asUrl loadRemoteObjects" 
	"'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.zip' 
		asUrl loadRemoteObjects" 

	| stream info data |
 	data _ self retrieveContentsFor: aURL.
	(data isString)
		ifTrue: [^self error: data]
		ifFalse: [data _ data content].
	(data beginsWith: 'error')
		ifTrue: [^self error: data].
	data _ data unzipped.
	stream _ RWBinaryOrTextStream on: data.
	stream reset.
	info _ stream fileInObjectAndCode.
	stream close.
	^info originalRoots! !


!HTTPLoader methodsFor: 'private' stamp: 'mir 1/16/2000 16:11'!
addRequest: aHTTPRequest
	requests nextPut: aHTTPRequest.
	self startDownload! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 10/4/1999 18:31'!
maxNrOfConnections
	^MaxNrOfConnections! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 10/7/1999 18:16'!
nextRequest
	^requests next! !

!HTTPLoader methodsFor: 'private' stamp: 'md 11/14/2003 16:38'!
removeProcess: downloadProcess
	downloads remove: downloadProcess ifAbsent: []! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 10/7/1999 17:02'!
removeRequest: request
	requests remove: request! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 5/12/2003 18:10'!
startDownload
	| newDownloadProcess |
	
	downloads size >= self maxNrOfConnections ifTrue: [^self].
	requests size <= 0 ifTrue: [^self].

	newDownloadProcess _ [
		[
			self nextRequest startRetrieval
		] on: FTPConnectionException do: [ :ex | 
			Cursor normal show.
			self removeProcess: Processor activeProcess.
			self startDownload
		].
		self removeProcess: Processor activeProcess.
		self startDownload
	] newProcess.
	downloads add: newDownloadProcess.
	newDownloadProcess resume! !

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

HTTPLoader class
	instanceVariableNames: ''!

!HTTPLoader class methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:41'!
default
	DefaultLoader ifNil: [
		DefaultLoader _ HTTPLoader new].
	^DefaultLoader! !

!HTTPLoader class methodsFor: 'accessing' stamp: 'avi 4/30/2004 01:40'!
httpRequestClass
	^HTTPClient shouldUsePluginAPI
		ifTrue: [PluginHTTPDownloadRequest]
		ifFalse: [HTTPDownloadRequest]! !


!HTTPLoader class methodsFor: 'class initialization' stamp: 'mir 3/8/2001 16:31'!
initialize
	"HTTPLoader initialize"

	MaxNrOfConnections _ 4.
	DefaultLoader ifNotNil: [
		DefaultLoader release.
		DefaultLoader _ nil]! !
ProjectSwikiServer subclass: #HTTPServerDirectory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RemoteDirectory'!

!HTTPServerDirectory methodsFor: 'accessing' stamp: 'tak 3/16/2005 17:25'!
dirListUrl
	| listURL |
	listURL := self altUrl
				ifNil: [^ nil].
	^ listURL last ~= $/
		ifTrue: [listURL , '/']
		ifFalse: [listURL]! !

!HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 4/16/2001 18:02'!
directoryNamed: localFileName
	| newDir |
	newDir _ super directoryNamed: localFileName.
	newDir altUrl: (self altUrl , '/' , localFileName).
	^newDir! !

!HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 17:17'!
typeForPrefs

	^'http'! !


!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:44'!
directoryNames
	| dirNames projectNames entries |
	"Return a collection of names for the subdirectories of this directory but filter out project directories."

	entries _ self entries.
	dirNames _ (entries select: [:entry | entry at: 4])
		collect: [:entry | entry first].
	projectNames _ Set new.
	entries do: [:entry | 
		((entry at: 4) not
			and: ['*.pr' match: entry first])
			ifTrue: [projectNames add: (entry first copyFrom: 1 to: entry first size-3)]].
	^dirNames reject: [:each | projectNames includes: each]
! !

!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:43'!
entries 
	^HTTPClient getDirectoryListing: self dirListUrl! !

!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:26'!
fileNames
	"Return a collection of names for the files (but not directories) in this directory."
	"(ServerDirectory serverNamed: 'UIUCArchive') fileNames"

	self dirListUrl
		ifNil: [^self error: 'No URL set for fetching the directory listing.'	].
	^(self entries select: [:entry | (entry at: 4) not])
		collect: [:entry | entry first]
! !

!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/16/2001 17:54'!
oldFileNamed: aName

	|  contents |
	contents _ HTTPLoader default retrieveContentsFor: (self altUrl , '/' , aName).
	^(SwikiPseudoFileStream with: contents content)
		reset;
		directory: self;
		localName: aName;
		yourself
! !

!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 6/5/2001 16:40'!
pathName
	"Path name as used in reading the file.  with slashes for ftp, with local file delimiter (:) for a file: url"

	urlObject ifNotNil: [^ urlObject pathForFile].
	directory size = 0 ifTrue: [^ server].
	^(directory at: 1) = self pathNameDelimiter
		ifTrue: [server, directory]
		ifFalse: [user
			ifNil: [server, self pathNameDelimiter asString, directory]
			ifNotNil: [user, '@', server, self pathNameDelimiter asString, directory]]! !

!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 5/30/2001 19:55'!
readOnlyFileNamed: aName

	^self oldFileNamed: aName! !
OldSimpleClientSocket subclass: #HTTPSocket
	instanceVariableNames: 'headerTokens headers responseCode'
	classVariableNames: 'HTTPBlabEmail HTTPPort HTTPProxyCredentials HTTPProxyExceptions LogToTranscript ParamDelimiters'
	poolDictionaries: ''
	category: 'Network-Protocols'!
!HTTPSocket commentStamp: '<historical>' prior: 0!
HTTPSockets support HTTP requests, either directly or via an HTTP proxy server. An HTTPSocket saves the parse of the last ASCII header it saw, to avoid having to parse it repeatedly.

The real action is in httpGet:accept:.  See the examples in the class, especially httpFileInNewChangeSet: and httpShowGif:.!


!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/14/1998 10:17'!
contentType
	| type i |
	type _ self getHeader: 'content-type' default: nil.
	type ifNil: [ ^nil ].
	type _ type withBlanksTrimmed.
	i _ type indexOf: $;.
	i = 0 ifTrue: [ ^type ].
	^(type copyFrom: 1 to: i-1) withBlanksTrimmed	! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:23'!
contentType: header
	"extract the content type from the header.  Content-type: text/plain<cr><lf>,  User may look in headerTokens afterwards."

	| this |
	headerTokens ifNil: [ headerTokens _ header findTokens: ParamDelimiters keep: (String with: CR) ].
	1 to: headerTokens size do: [:ii | 
		this _ headerTokens at: ii.
		(this first asLowercase = $c and: [#('content-type:' 'content type') includes: this asLowercase]) ifTrue: [
			^ (headerTokens at: ii+1)]].
	^ nil	"not found"! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/15/97 11:35'!
contentsLength: header
	"extract the data length from the header.  Content-length: 1234<cr><lf>,  User may look in headerTokens afterwards."

	| this |
	headerTokens _ header findTokens: ParamDelimiters keep: (String with: CR).
	1 to: headerTokens size do: [:ii | 
		this _ headerTokens at: ii.
		(this first asLowercase = $c and: [this asLowercase = 'content-length:']) ifTrue: [
			^ (headerTokens at: ii+1) asNumber]].
	^ nil	"not found"! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:37'!
getHeader: name 
	^self getHeader: name  default: nil! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:36'!
getHeader: name  default: defaultValue
	^headers at: name  ifAbsent: [ defaultValue ]! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'hg 2/11/2002 13:55'!
getResponseUpTo: markerString
	"Keep reading until the marker is seen.  Return three parts: header, marker, beginningOfData.  Fails if no marker in first 2000 chars." 

	| buf response bytesRead tester mm tries |
	buf _ String new: 2000.
	response _ WriteStream on: buf.
	tester _ 1. mm _ 1.
	tries _ 3.
	[tester _ tester - markerString size + 1 max: 1.  "rewind a little, in case the marker crosses a read boundary"
	tester to: response position do: [:tt |
		(buf at: tt) = (markerString at: mm) ifTrue: [mm _ mm + 1] ifFalse: [mm _ 1].
			"Not totally correct for markers like xx0xx"
		mm > markerString size ifTrue: ["got it"
			^ Array with: (buf copyFrom: 1 to: tt+1-mm)
				with: markerString
				with: (buf copyFrom: tt+1 to: response position)]].
	 tester _ 1 max: response position.	"OK if mm in the middle"
	 (response position < buf size) & (self isConnected | self dataAvailable) 
			& ((tries _ tries - 1) >= 0)] whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
			Transcript show: ' <response was late> '].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
			startingAt: response position + 1 count: buf size - response position.
		"response position+1 to: response position+bytesRead do: [:ii | 
			response nextPut: (buf at: ii)].	totally redundant, but needed to advance position!!"
		response instVarAt: 2 "position" put: 
			(response position + bytesRead)].	"horrible, but fast"

	^ Array with: response contents
		with: ''
		with: ''		"Marker not found and connection closed"
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'tao 6/22/1999 07:56'!
getResponseUpTo: markerString ignoring: ignoreString
	"Keep reading, until the marker is seen, skipping characters in ignoreString when
      comparing to the marker.  Return three parts: header, marker, beginningOfData.
     Fails if no marker in first 2000 chars." 

	| buf response bytesRead tester mm skipped |
	buf _ String new: 2000.
	response _ WriteStream on: buf.
	tester _ 1. mm _ 1.
	skipped _ 0.
	[tester _ tester - markerString size + 1 max: 1.  "rewind a little, in case the marker crosses a read boundary"
	tester to: response position do: [:tt |
		(buf at: tt) = (markerString at: mm) ifFalse:
			[[ignoreString includes: (markerString at: mm)] whileTrue:
				[mm _ mm + 1. skipped _ skipped + 1]].
		(buf at: tt) = (markerString at: mm)
			ifTrue: [mm _ mm + 1]
			ifFalse: [mm _ 1. skipped _ 0].
			"Not totally correct for markers like xx0xx"
		mm > markerString size ifTrue: ["got it"
			^ Array with: (buf copyFrom: 1 to: tt+1-mm+skipped)
				with: markerString
				with: (buf copyFrom: tt+1 to: response position)]].
	 tester _ 1 max: response position.	"OK if mm in the middle"
	 (response position < buf size) & (self isConnected | self dataAvailable)] whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
			Transcript show: 'data was late'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
			startingAt: response position + 1 count: buf size - response position.
		"response position+1 to: response position+bytesRead do: [:ii | 
			response nextPut: (buf at: ii)].	totally redundant, but needed to advance position!!"
		response instVarAt: 2 "position" put: 
			(response position + bytesRead)].	"horrible, but fast"

	^ Array with: response contents
		with: ''
		with: ''		"Marker not found and connection closed"
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'hg 2/11/2002 20:13'!
getRestOfBuffer: beginning
	"We don't know the length.  Keep going until connection is closed.  Part of it has already been received.  Response is of type text, not binary."

	| buf response bytesRead |
	response _ RWBinaryOrTextStream on: (String new: 2000).
	response nextPutAll: beginning.
	buf _ String new: 2000.

	[self isConnected | self dataAvailable] 
	whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
	 		Transcript show: 'data was slow'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
				startingAt: 1 count: buf size. 
		bytesRead > 0 ifTrue: [  
			response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ].
	self logToTranscript ifTrue: [
		Transcript cr; show: 'data byte count: ', response position printString].
	response reset.	"position: 0."
	^ response
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'sma 4/22/2000 17:34'!
getRestOfBuffer: beginning totalLength: length
	"Reel in a string of a fixed length.  Part of it has already been received.  Close the connection after all chars are received.  We do not strip out linefeed chars.  tk 6/16/97 22:32" 
	"if length is nil, read until connection close.  Response is of type text, not binary."

	| buf response bytesRead |
	length ifNil: [^ self getRestOfBuffer: beginning].
	buf _ String new: length.
	response _ RWBinaryOrTextStream on: buf.
	response nextPutAll: beginning.
	buf _ String new: length.

	[(response position < length) & (self isConnected | self dataAvailable)] 
	whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
	 		Transcript show: 'data was slow'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 
				count: (length - response position). 
		bytesRead > 0 ifTrue: [  
			response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ].
	"Transcript cr; show: 'data byte count: ', response position printString."
	"Transcript cr; show: ((self isConnected) ifTrue: ['Over length by: ', bytesRead printString] 
		ifFalse: ['Socket closed'])."
	response position < length ifTrue: [^ 'server aborted early'].
	response reset.	"position: 0."
	^ response! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 16:39'!
header: headerText
	"set the headers.  Then getHeader: can be used"

	"divide into basic lines"
	| lines foldedLines i statusLine |
	lines _ headerText findTokens: (String with: Character cr  with: Character linefeed).
	statusLine _ lines first.
	lines _ lines copyFrom: 2 to: lines size.

	"parse the status (pretty trivial right now)"
	responseCode _ (statusLine findTokens: ' ') second.

	"fold lines that start with spaces into the previous line"
	foldedLines _ OrderedCollection new.
	lines do: [ :line |
		line first isSeparator ifTrue: [
			foldedLines at: foldedLines size  put: (foldedLines last, line) ]
		ifFalse: [ foldedLines add: line ] ].

	"make a dictionary mapping headers to header contents"
	headers _ Dictionary new.
	foldedLines do: [ :line |
		i _ line indexOf: $:.
		i > 0 ifTrue: [
			headers 
			at: (line copyFrom: 1 to: i-1) asLowercase 
			put: (line copyFrom: i+1 to: line size) withBlanksTrimmed ] ].
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'hg 2/11/2002 19:47'!
logToTranscript

	^LogToTranscript == true! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/26/97 18:28'!
redirect
	"See if the header has a 'Location: url CrLf' in it.  If so, return the new URL of this page.  tk 6/24/97 18:03"

	| this |
	1 to: headerTokens size do: [:ii | 
		this _ headerTokens at: ii.
		(this first asLowercase = $l and: [this asLowercase = 'location:']) ifTrue: [
			^ (headerTokens at: ii+1)]].
	^ nil	"not found"
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:41'!
responseCode
	^responseCode! !

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

HTTPSocket class
	instanceVariableNames: ''!

!HTTPSocket class methodsFor: 'class initialization' stamp: 'tk 9/21/1998 10:45'!
blabEmail: aRequest
	"Of the form 'From: me@isp.com <crlf>'"
	HTTPBlabEmail _ aRequest! !

!HTTPSocket class methodsFor: 'class initialization' stamp: 'hpt 12/9/2004 22:55'!
initialize
	"HTTPSocket initialize"

	ParamDelimiters := ' ', CrLf.
	HTTPPort := 80.
	self httpProxyServer: nil.
	HTTPBlabEmail := ''.  "	'From: somebody@no.where', CrLf	"
	HTTPProxyCredentials := ''.

	ExternalSettings registerClient: self! !


!HTTPSocket class methodsFor: 'get the page' stamp: 'ar 9/27/2005 20:07'!
httpFileInNewChangeSet: url
	"Do a regular file-in of a file that is served from a web site.  Put it into a new changeSet."
	"Notes: To store a file on an HTTP server, use the program 'Fetch'.  After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc.  Use any file extension as long as it is not one of the common ones."
	"	HTTPSocket httpFileInNewChangeSet: '206.18.68.12/squeak/updates/83tk_test.cs'	 "

	| doc |
	doc := self httpGet: url accept: 'application/octet-stream'.
	doc isString ifTrue:
			[self inform: 'Cannot seem to contact the web site'].
	doc reset.
	ChangeSet newChangesFromStream: doc
				named: (url findTokens: '/') last.! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'ar 4/10/2005 18:47'!
httpFileIn: url
	"Do a regular file-in of a file that is served from a web site.  If the file contains an EToy, then open it.  Might just be code instead.  tk 7/23/97 17:10"
	"Notes: To store a file on an HTTP server, use the program 'Fetch'.  After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc.  Use any file extension as long as it is not one of the common ones.  The server does not have to know about the .sqo extension in order to send your file.  (We do not need a new MIME type and .sqo does not have to be registered with the server.)"
	"	HTTPSocket httpFileIn: 'www.webPage.com/~kaehler2/sample.etoy'	 "
	"	HTTPSocket httpFileIn: '206.18.68.12/squeak/car.sqo'	 "
	"	HTTPSocket httpFileIn: 'jumbo/tedk/sample.etoy'	 "

	| doc eToyHolder |
	doc _ self httpGet: url accept: 'application/octet-stream'.
	doc isString ifTrue:
			[self inform: 'Cannot seem to contact the web site'].
	doc reset.
	eToyHolder _ doc fileInObjectAndCode.

	eToyHolder ifNotNil: [eToyHolder open].
	"Later may want to return it, instead of open it"
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:25'!
httpGetDocument: url
	"Return the exact contents of a web page or other web object. The parsed header is saved.  Use a proxy server if one has been registered.  tk 7/23/97 17:21"
	"	HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html'	 "
	"	HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html'	 "
	"	HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html'	 "
	"	HTTPSocket httpShowPage: 'www.apple.com/default.html'	 "
	"	HTTPSocket httpShowPage: 'www.altavista.digital.com/'	 "
	"	HTTPSocket httpShowPage: 'jumbo/tedk/ab.html'	 "

	^ self httpGetDocument: url args: nil accept: 'application/octet-stream' request: ''
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:26'!
httpGetDocument: url accept: mimeType
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  tk 7/23/97 17:12"
	^self httpGetDocument: url args: nil accept: mimeType request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:26'!
httpGetDocument: url args: args
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  tk 7/23/97 17:12"
	"Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'."
	^self httpGetDocument: url args: args accept: 'application/octet-stream' request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 17:48'!
httpGetDocument: url args: args accept: mimeType
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  Note: To fetch raw data, you can use the MIME type 'application/octet-stream'."

	^ self httpGetDocument: url args: args accept: mimeType request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'hpt 12/9/2004 22:52'!
httpGetDocument: url args: args accept: mimeType request: requestString
	"Return the exact contents of a web object. Asks for the given MIME 
type. If mimeType is nil, use 'text/html'. An extra requestString may be 
submitted and must end with crlf.  The parsed header is saved. Use a 
proxy server if one has been registered.  tk 7/23/97 17:12"
	"Note: To fetch raw data, you can use the MIME type 
'application/octet-stream'."

	| serverName serverAddr port sock header length bare page list firstData 
aStream index connectToHost connectToPort type newUrl |
	Socket initializeNetwork.
	bare := (url asLowercase beginsWith: 'http://') 
		ifTrue: [url copyFrom: 8 to: url size]
		ifFalse: [url].
	bare := bare copyUpTo: $#.  "remove fragment, if specified"
	serverName := bare copyUpTo: $/.
	page := bare copyFrom: serverName size + 1 to: bare size.
	(serverName includes: $:) 
		ifTrue: [ index := serverName indexOf: $:.
			port := (serverName copyFrom: index+1 to: serverName size) asNumber.
			serverName := serverName copyFrom: 1 to: index-1. ]
		ifFalse: [ port := self defaultPort ].
	page size = 0 ifTrue: [page := '/'].
	"add arguments"
	args ifNotNil: [page := page, (self argString: args) ].


	(self shouldUseProxy: serverName)
		ifFalse: [ 
			connectToHost := serverName.
			connectToPort := port ]
		ifTrue:  [
			page := 'http://', serverName, ':', port printString, page.		"put back 
together"
			connectToHost := self httpProxyServer.
			connectToPort := self httpProxyPort].
	

	serverAddr := NetNameResolver addressForName: connectToHost timeout: 20.
	serverAddr ifNil: [
		^ 'Could not resolve the server named: ', connectToHost].

3 timesRepeat: [
	sock := HTTPSocket new.
	sock connectTo: serverAddr port: connectToPort.
	(sock waitForConnectionUntil: (self deadlineSecs: 30)) ifFalse: [
		Socket deadServer: connectToHost.  sock destroy.
		^ 'Server ',connectToHost,' is not responding'].
	"Transcript cr;show: url; cr.
	Transcript show: page; cr."
	sock sendCommand: 'GET ', page, ' HTTP/1.0', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		self userAgentString, CrLf,
		'Host: ', serverName, ':', port printString, CrLf.	"blank line 
automatically added"

	list := sock getResponseUpTo: CrLf, CrLf ignoring: (String with: CR).	"list = header, CrLf, CrLf, 
beginningOfData"
	header := list at: 1.
	"Transcript show: page; cr; show: header; cr."
	firstData := list at: 3.
	header isEmpty 
		ifTrue: [aStream := 'server aborted early']
		ifFalse: [
			"dig out some headers"
			sock header: header.
			length := sock getHeader: 'content-length'.
			length ifNotNil: [ length := length asNumber ].
			type := sock getHeader: 'content-type'.
			sock responseCode first = $3 ifTrue: [
				newUrl := sock getHeader: 'location'.
				newUrl ifNotNil: [ 
					Transcript show: 'redirecting to ', newUrl; cr.
					sock destroy.
					newUrl := self expandUrl: newUrl ip: serverAddr port: connectToPort.
					^self httpGetDocument: newUrl args: args  accept: mimeType request: requestString] ].
			aStream := sock getRestOfBuffer: firstData totalLength: length.
			"a 400-series error"
			sock responseCode first = $4 ifTrue: [^ header, aStream contents].
			].
	sock destroy.	"Always OK to destroy!!"
	aStream class ~~ String ifTrue: [
 		^ MIMEDocument contentType: type content: aStream contents url: url].
	aStream = 'server aborted early' ifTrue: [ ^aStream ].
	].

{'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect.

	^'some other bad thing happened!!'! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'nk 8/30/2004 07:50'!
httpGetNoError: url args: args accept: mimeType
	"Return the exact contents of a web file.  Do better error checking.  Asks for the given MIME type.  To fetch raw data, you can use the MIMI type 'application/octet-stream'.  If mimeType is nil, use 'text/html'.  The parsed header is saved. Use a proxy server if one has been registered."

"Edited to remove a lineFeed from the source 4/4/99 - di"

	| document data |
	document _ self httpGetDocument: url  args: args  accept: mimeType.
	(document isString) ifTrue: [
		"strings indicate errors"
		^ document ].
	data _ document content.
	(data beginsWith: '<HTML><HEAD>' , (String with: Character linefeed) , '<TITLE>4')
		ifTrue: ["an error message  404 File not found"
				^ data copyFrom: 21 to: data size-16].	

	^ (RWBinaryOrTextStream with: data) reset
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 12/7/2001 17:36'!
httpGet: url
	"Return the exact contents of a web page or other web object. The parsed header is saved.  Use a proxy server if one has been registered.  tk 7/23/97 17:21"
	"	HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html'	 "
	"	HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html'	 "
	"	HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html'	 "
	"	HTTPSocket httpShowPage: 'www.apple.com/default.html'	 "
	"	HTTPSocket httpShowPage: 'www.altavista.digital.com/'	 "
	"	HTTPSocket httpShowPage: 'jumbo/tedk/ab.html'	 "

	^ self httpGet: url accept: '*/*'
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 12/7/2001 17:37'!
httpGet: url accept: mimeType
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.
	Note: To fetch raw data, you can use the MIME type 'application/octet-stream'.  To accept anything, use '*/*'."

	^self httpGet: url  args: nil accept: mimeType! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'hg 2/12/2002 11:39'!
httpGet: url args: args accept: mimeType

	^self httpGet: url args: args accept: mimeType request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'nk 8/30/2004 07:50'!
httpGet: url args: args accept: mimeType request: requestString
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  tk 7/23/97 17:12"
	"Note: To fetch raw data, you can use the MIME type 'application/octet-stream'."

	| document |
	document _ self httpGetDocument: url  args: args  accept: mimeType request: requestString.
	(document isString) ifTrue: [
		"strings indicate errors"
		^ document ].

	^ (RWBinaryOrTextStream with: document content) reset
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'avi 2/10/2004 14:02'!
httpGet: url args: args user: user passwd: passwd
	| authorization |
	authorization _ (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents.
	^self 
		httpGet: url args: args accept: '*/*' 
		request: 'Authorization: Basic ' , authorization , CrLf! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'ar 4/10/2005 18:48'!
httpGif: url
	"Fetch the given URL, parse it using the GIF reader, and return the resulting Form."
	"	HTTPSocket httpShowGif: 'www.altavista.digital.com/av/pix/default/av-adv.gif'	 "
	"	HTTPSocket httpShowGif: 'www.webPage.com/~kaehler2/ainslie.gif'	 "

	| doc ggg |
	doc _ self httpGet: url accept: 'image/gif'.
	doc isString ifTrue: [
		self inform: 'The server with that GIF is not responding'.
		^ ColorForm extent: 20@20 depth: 8].
	doc binary; reset.
	(ggg _ GIFReadWriter new) setStream: doc.
	^ ggg nextImage.
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'nk 7/7/2003 18:37'!
httpJpeg: url
	"Fetch the given URL, parse it using the JPEG reader, and return the resulting Form."

	| doc ggg |
	doc _ self httpGet: url.
	doc binary; reset.
	(ggg _ JPEGReadWriter new) setStream: doc.
	^ ggg nextImage.
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:27'!
httpPostDocument: url  args: argsDict
	"like httpGET, except it does a POST instead of a GET.  POST allows data to be uploaded"

	^self httpPostDocument: url args: argsDict accept: 'application/octet-stream' request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 20:16'!
httpPostDocument: url  args: argsDict accept: mimeType 
	"like httpGET, except it does a POST instead of a GET.  POST allows data to be uploaded"

	^ self httpPostDocument: url args: argsDict accept: mimeType request: ''
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'gk 12/15/2005 00:24'!
httpPostDocument: url  args: argsDict accept: mimeType request: requestString
	"like httpGET, except it does a POST instead of a GET.  POST allows data to be uploaded"

	| s header length page list firstData aStream type newUrl httpUrl argString |
	Socket initializeNetwork.
	httpUrl _ Url absoluteFromText: url.
	page _ httpUrl fullPath.
	"add arguments"
	argString _ argsDict
		ifNotNil: [
			argString _ self argString: argsDict.
			argString first = $? ifTrue: [ argString _ argString copyFrom: 2 to: argString size]]
		ifNil: [''].

	s _ HTTPSocket new. 
	s _ self initHTTPSocket: httpUrl wait: (self deadlineSecs: 30) ifError: [:errorString | ^errorString].
	s sendCommand: 'POST ', page, ' HTTP/1.0', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPProxyCredentials,
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		self userAgentString, CrLf,
		'Content-type: application/x-www-form-urlencoded', CrLf,
		'Content-length: ', argString size printString, CrLf,
		'Host: ', httpUrl authority, CrLf.  "blank line automatically added"

	"umur - IE sends argString without a $? and swiki expects so"
	s sendCommand: argString.

	"get the header of the reply"
	list _ s getResponseUpTo: CrLf, CrLf ignoring: (String with: CR).	"list = header, CrLf, CrLf, beginningOfData"
	header _ list at: 1.
	"Transcript show: page; cr; show: argsStream contents; cr; show: header; cr."
	firstData _ list at: 3.

	"dig out some headers"
	s header: header.
	length _ s getHeader: 'content-length'.
	length ifNotNil: [ length _ length asNumber ].
	type _ s getHeader: 'content-type'.
	s responseCode first = $3 ifTrue: [
		newUrl _ s getHeader: 'location'.
		newUrl ifNotNil: [
			"umur 6/25/2003 12:58 - If newUrl is relative then we need to make it absolute."
			newUrl _ (httpUrl newFromRelativeText: newUrl) asString.
			self flag: #refactor. "get, post, postmultipart are almost doing the same stuff"
			s destroy.
			"^self httpPostDocument: newUrl  args: argsDict  accept: mimeType"
			^self httpGetDocument: newUrl accept: mimeType ] ].

	aStream _ s getRestOfBuffer: firstData totalLength: length.
	s responseCode = '401' ifTrue: [^ header, aStream contents].
	s destroy.	"Always OK to destroy!!"

	^ MIMEDocument contentType: type  content: aStream contents url: url! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'hpt 12/9/2004 22:53'!
httpPostMultipart: url args: argsDict accept: mimeType request: requestString
	" do multipart/form-data encoding rather than x-www-urlencoded "
	" by Bolot Kerimbaev, 1998 "
	" this version is a memory hog: puts the whole file in memory "
	"bolot 12/14/2000 18:28 -- minor fixes to make it comply with RFC 1867"

	| serverName serverAddr s header length bare page list firstData aStream port argsStream specifiedServer type newUrl mimeBorder fieldValue |
	Socket initializeNetwork.

	"parse url"
	bare := (url asLowercase beginsWith: 'http://') 
		ifTrue: [url copyFrom: 8 to: url size]
		ifFalse: [url].
	serverName := bare copyUpTo: $/.
	specifiedServer := serverName.
	(serverName includes: $:) ifFalse: [ port := self defaultPort ] ifTrue: [
		port := (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber.
		serverName := serverName copyUpTo: $:.
	].

	page := bare copyFrom: (bare indexOf: $/) to: bare size.
	page size = 0 ifTrue: [page := '/'].
	(self shouldUseProxy: serverName) ifTrue: [ 
		page := 'http://', serverName, ':', port printString, page.		"put back together"
		serverName := self httpProxyServer.
		port := self httpProxyPort].

	mimeBorder := '----squeak-georgia-tech-', Time millisecondClockValue printString, '-csl-cool-stuff-----'.
	"encode the arguments dictionary"
	argsStream := WriteStream on: String new.
	argsDict associationsDo: [:assoc |
		assoc value do: [ :value |
		"print the boundary"
		argsStream nextPutAll: '--', mimeBorder, CrLf.
		" check if it's a non-text field "
		argsStream nextPutAll: 'Content-disposition: multipart/form-data; name="', assoc key, '"'.
		(value isKindOf: MIMEDocument)
			ifFalse: [fieldValue := value]
			ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', CrLf, 'Content-Type: ', value contentType.
				fieldValue := (value content
					ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile]
					ifNotNil: [value content]) asString].
" Transcript show: 'field=', key, '; value=', fieldValue; cr. "
		argsStream nextPutAll: CrLf, CrLf, fieldValue, CrLf.
	]].
	argsStream nextPutAll: '--', mimeBorder, '--'.

  	"make the request"	
	serverAddr := NetNameResolver addressForName: serverName timeout: 20.
	serverAddr ifNil: [
		^ 'Could not resolve the server named: ', serverName].


	s := HTTPSocket new.
	s connectTo: serverAddr port: port.
	s waitForConnectionUntil: self standardDeadline.
	Transcript cr; show: serverName, ':', port asString; cr.
	s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPProxyCredentials,
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		self userAgentString, CrLf,
		'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf,
		'Content-length: ', argsStream contents size printString, CrLf,
		'Host: ', specifiedServer, CrLf.  "blank line automatically added"

	s sendCommand: argsStream contents.

	"get the header of the reply"
	list := s getResponseUpTo: CrLf, CrLf.	"list = header, CrLf, CrLf, beginningOfData"
	header := list at: 1.
	"Transcript show: page; cr; show: argsStream contents; cr; show: header; cr."
	firstData := list at: 3.

	"dig out some headers"
	s header: header.
	length := s getHeader: 'content-length'.
	length ifNotNil: [ length := length asNumber ].
	type := s getHeader: 'content-type'.
	s responseCode first = $3 ifTrue: [
		"redirected - don't re-post automatically"
		"for now, just do a GET, without discriminating between 301/302 codes"
		newUrl := s getHeader: 'location'.
		newUrl ifNotNil: [
			(newUrl beginsWith: 'http://')
				ifFalse: [
					(newUrl beginsWith: '/')
						ifTrue: [newUrl := (bare copyUpTo: $/), newUrl]
						ifFalse: [newUrl := url, newUrl. self flag: #todo
							"should do a relative URL"]
				].
			Transcript show: 'redirecting to: ', newUrl; cr.
			s destroy.
			^self httpGetDocument: newUrl
			"for some codes, may do:
			^self httpPostMultipart: newUrl args: argsDict  accept: mimeType request: requestString"] ].

	aStream := s getRestOfBuffer: firstData totalLength: length.
	s responseCode = '401' ifTrue: [^ header, aStream contents].
	s destroy.	"Always OK to destroy!!"

	^ MIMEDocument contentType: type  content: aStream contents url: url! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'hpt 12/9/2004 22:53'!
httpPostToSuperSwiki: url args: argsDict accept: mimeType request: requestString

	| serverName serverAddr s header length bare page list firstData aStream port specifiedServer type mimeBorder contentsData |

	Socket initializeNetwork.

	"parse url"
	bare := (url asLowercase beginsWith: 'http://') 
		ifTrue: [url copyFrom: 8 to: url size]
		ifFalse: [url].
	serverName := bare copyUpTo: $/.
	specifiedServer := serverName.
	(serverName includes: $:) ifFalse: [ port := self defaultPort ] ifTrue: [
		port := (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber.
		serverName := serverName copyUpTo: $:.
	].

	page := bare copyFrom: (bare indexOf: $/ ifAbsent: [^'error']) to: bare size.
	page size = 0 ifTrue: [page := '/'].
		(self shouldUseProxy: serverName) ifTrue: [ 
		page := 'http://', serverName, ':', port printString, page.		"put back together"
		serverName := self httpProxyServer.
		port := self httpProxyPort].

	mimeBorder := '---------SuperSwiki',Time millisecondClockValue printString,'-----'.
	contentsData := String streamContents: [ :strm |
		strm nextPutAll: mimeBorder, CrLf.
		argsDict associationsDo: [:assoc |
			assoc value do: [ :value |
				strm
					nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"';
					nextPutAll: CrLf;
					nextPutAll: CrLf;
					nextPutAll: value;
					nextPutAll: CrLf;
					nextPutAll: CrLf;
					nextPutAll: mimeBorder;
					nextPutAll: CrLf.
			]
		].
	].

  	"make the request"	
	serverAddr := NetNameResolver addressForName: serverName timeout: 20.
	serverAddr ifNil: [
		^ 'Could not resolve the server named: ', serverName].

	s := HTTPSocket new.
	s connectTo: serverAddr port: port.
	s waitForConnectionUntil: self standardDeadline.
	s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPProxyCredentials,
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		self userAgentString, CrLf,
		'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf,
		'Content-length: ', contentsData size printString, CrLf,
		'Host: ', specifiedServer, CrLf.  "blank line automatically added"

	s sendCommand: contentsData.

	list := s getResponseUpTo: CrLf, CrLf.	"list = header, CrLf, CrLf, beginningOfData"
	header := list at: 1.
	firstData := list at: 3.

	header isEmpty ifTrue: [
		s destroy.
		^'no response'
	].
	s header: header.
	length := s getHeader: 'content-length'.
	length ifNotNil: [ length := length asNumber ].
	type := s getHeader: 'content-type'.
	aStream := s getRestOfBuffer: firstData totalLength: length.
	s responseCode = '401' ifTrue: [^ header, aStream contents].
	s destroy.	"Always OK to destroy!!"

	^ MIMEDocument contentType: type  content: aStream contents url: url! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'nk 8/30/2004 07:50'!
httpPost: url  args: argsDict accept: mimeType 
	"like httpGET, except it does a POST instead of a GET.  POST allows data to be uploaded"
	| document |
	document _ self httpPostDocument: url  args: argsDict  accept: mimeType  request: ''.
	(document isString) ifTrue: [ 
		"strings indicate errors"
		^document ].

	
	^RWBinaryOrTextStream with: document content! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'avi 2/10/2004 15:04'!
httpPost: url args: args user: user passwd: passwd
	| authorization |
	authorization _ (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents.
	^self 
		httpPostDocument: url args: args accept: '*/*' 
		request: 'Authorization: Basic ' , authorization , CrLf! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'hpt 12/9/2004 22:54'!
httpPut: contents to: url user: user passwd: passwd
	"Upload the contents of the stream to a file on the server"

	| bare serverName specifiedServer port page serverAddr authorization s list header firstData length aStream command |
	Socket initializeNetwork.
 
	"parse url"
	bare := (url asLowercase beginsWith: 'http://') 
		ifTrue: [url copyFrom: 8 to: url size]
		ifFalse: [url].
	serverName := bare copyUpTo: $/.
	specifiedServer := serverName.
	(serverName includes: $:) ifFalse: [ port := self defaultPort ] ifTrue: [
		port := (serverName copyFrom: (serverName indexOf: $:) + 1 
				to: serverName size) asNumber.
		serverName := serverName copyUpTo: $:.
	].

	page := bare copyFrom: (bare indexOf: $/) to: bare size.
	page size = 0 ifTrue: [page := '/'].
	(self shouldUseProxy: serverName) ifTrue: [ 
		page := 'http://', serverName, ':', port printString, page.		"put back together"
		serverName := self httpProxyServer.
		port := self httpProxyPort].

  	"make the request"	
	serverAddr := NetNameResolver addressForName: serverName timeout: 20.
	serverAddr ifNil: [
		^ 'Could not resolve the server named: ', serverName].

	authorization := (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents.
	s := HTTPSocket new.
	s connectTo: serverAddr port: port.
	s waitForConnectionUntil: self standardDeadline.
	Transcript cr; show: url; cr.
	command := 
		'PUT ', page, ' HTTP/1.0', CrLf, 
		self userAgentString, CrLf,
		'Host: ', specifiedServer, CrLf, 
		'ACCEPT: */*', CrLf,
		HTTPProxyCredentials,
		'Authorization: Basic ' , authorization , CrLf , 
		'Content-length: ', contents size printString, CrLf , CrLf , 
		contents.
	s sendCommand: command.
	"get the header of the reply"
	list := s getResponseUpTo: CrLf, CrLf ignoring: (String with: CR).	"list = header, CrLf, CrLf, beginningOfData"
	header := list at: 1.
	"Transcript show: page; cr; show: argsStream contents; cr; show: header; cr."
	firstData := list at: 3.

	"dig out some headers"
	s header: header.
	length := s getHeader: 'content-length'.
	length ifNotNil: [ length := length asNumber ].

	aStream := s getRestOfBuffer: firstData totalLength: length.
	s destroy.	"Always OK to destroy!!"

	^ header, aStream contents! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'ar 4/10/2005 18:48'!
httpShowChunk: url
	"From a Swiki server, get a text chunk in the changes file.  Show its text in a window with style.  Vertical bar separates class and selector.  BE SURE TO USE ; instead of : in selectors!!"
	"	HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Socket|Comment'	 "
	"	HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Point|class|x;y;'	"

	| doc text |
	doc _ (self httpGet: url accept: 'application/octet-stream').
"	doc size = 0 ifTrue: [doc _ 'The server does not seem to be responding']."
	doc isString ifTrue: [text _ doc] ifFalse: [text _ doc nextChunkText].
	(StringHolder new contents: text) openLabel: url.
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'sma 4/30/2000 09:50'!
httpShowGif: url
	"Display the picture retrieved from the given URL, which is assumed to be a GIF file.
	See examples in httpGif:."

	self showImage: (self httpGif: url) named: (url findTokens: '/') last! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'sma 4/30/2000 09:51'!
httpShowJpeg: url
	"Display the picture retrieved from the given URL, which is assumed to be a JPEG file.
	See examples in httpGif:."

	self showImage: (self httpJpeg: url) named: (url findTokens: '/') last! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 5/4/1998 17:01'!
httpShowPage: url
	"Display the exact contents of the given URL as text. See examples in httpGet:"

	| doc |
	doc _ (self httpGet: url accept: 'application/octet-stream') contents.
	doc size = 0 ifTrue: [^ self error: 'Document could not be fetched'].
	(StringHolder new contents: doc) openLabel: url.
! !


!HTTPSocket class methodsFor: 'magic numbers' stamp: 'ls 9/17/1998 07:17'!
defaultPort
	"default port to connect on"
	^80! !


!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 23:18'!
addHTTPProxyPreferences
	" This method will add to Squeak the HTTP Proxy preferences. "
	Preferences addTextPreference: #httpProxyServer category: #'http proxy'  default: '' balloonHelp: 'HTTP Proxy Server. Leave blank if you don''t want to use a Proxy'.
	Preferences addNumericPreference: #httpProxyPort  category:  #'http proxy' default: 80 balloonHelp: 'HTTP Proxy Port'.! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 16:08'!
addProxyException: domainName
	"Add a (partial, wildcard) domain name to the list of proxy exceptions"
	"HTTPSocket addProxyException: '*.online.disney.com'"

	self httpProxyExceptions add: domainName! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 22:40'!
checkHTTPProxyPreferences
	Preferences preferenceAt: #httpProxyPort ifAbsent: [self addHTTPProxyPreferences].
	Preferences preferenceAt: #httpProxyServer ifAbsent: [self addHTTPProxyPreferences].! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/9/2004 22:51'!
fetchExternalSettingsIn: aDirectory
	"Scan for server configuration files"
	"HTTPSocket fetchExternalSettingsIn: (FileDirectory default directoryNamed: 'prefs')"

	| stream entries |
	(aDirectory fileExists: self proxySettingsFileName)
		ifFalse: [^self].
	stream := aDirectory readOnlyFileNamed: self proxySettingsFileName.
	stream
		ifNotNil: [
			[entries := ExternalSettings parseServerEntryArgsFrom: stream]
				ensure: [stream close]].

	entries ifNil: [^self].

	self httpProxyServer:  (entries at: 'host' ifAbsent: [nil]).
	self httpProxyPort: ((entries at: 'port' ifAbsent: ['80']) asInteger ifNil: [self defaultPort]).
	HTTPSocket addProxyException: (entries at: 'exception' ifAbsent: [nil])! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 15:03'!
httpProxyExceptions
	HTTPProxyExceptions ifNil: [HTTPProxyExceptions _ OrderedCollection new].
	^HTTPProxyExceptions! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 22:39'!
httpProxyPort
	"answer the httpProxyPort"
	self checkHTTPProxyPreferences.
	^Preferences valueOfPreference: #httpProxyPort.! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 23:20'!
httpProxyPort: aPortNumber
	self checkHTTPProxyPreferences.
	Preferences setPreference: #httpProxyPort toValue: aPortNumber.! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 23:19'!
httpProxyServer
	"answer the httpProxyServer. Take into account that as a Preference the Server might appear as an empty string but HTTPSocket expect it to be nil"
	self checkHTTPProxyPreferences.
	^Preferences valueOfPreference: #httpProxyServer.
! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 23:17'!
httpProxyServer: aStringOrNil
	| serverName |
	self checkHTTPProxyPreferences.
	serverName _ aStringOrNil 
						ifNil: [''] 
						ifNotNil: [aStringOrNil withBlanksTrimmed ].
	Preferences setPreference: #httpProxyServer toValue: serverName! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 8/23/2002 14:29'!
proxySettingsFileName
	^'proxySettings'! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'jm 9/15/97 12:06'!
proxyTestingComment
	"Test Kevin's SmartCache on this machine"
	"	HTTPSocket useProxyServerNamed: '127.0.0.1' port: 8080.
		HTTPSocket httpShowPage: 'http://www.disneyblast.com/default.html'.
		HTTPSocket stopUsingProxyServer.	"

	"Test getting to outside world from DOL"
	"	HTTPSocket useProxyServerNamed: 'web-proxy.online.disney.com' port: 8080.
		HTTPSocket httpShowPage: 'http://www.apple.com/default.html'.
		HTTPSocket stopUsingProxyServer.	"

	"Test Windows Machine in our cubicle at DOL"
	"	HTTPSocket useProxyServerNamed: '206.18.67.150' port: 8080.
		HTTPSocket httpShowPage: 'http://kids.online.disney.com/~kevin/squeak/k_t.morph'.
		HTTPSocket stopUsingProxyServer.	"

	"	HTTPSocket httpShowPage: 'kids.online.disney.com/'	"
	"	HTTPSocket httpShowGif: 'kids.online.disney.com/~kevin/images/dlogo.gif'	"
! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'al 1/8/2004 12:27'!
proxyUser: userName password: password
	"Store  HTTP 1.0 basic authentication credentials
	Note: this is an ugly hack that stores your password
	in your image.  It's just enought to get you going
	if you use a firewall that requires authentication"

    | stream encodedStream |
	stream _ ReadWriteStream on: (String new: 16).
	stream nextPutAll: userName ,':' , password.
	encodedStream _ Base64MimeConverter mimeEncode: stream.
	HTTPProxyCredentials _ 'Proxy-Authorization: Basic ' , (encodedStream contents) , String crlf! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 15:03'!
removeProxyException: domainName
	"Remove a (partial, wildcard) domain name from the list of proxy exceptions"

	self httpProxyExceptions remove: domainName ifAbsent: []! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/9/2004 22:55'!
stopUsingProxyServer
	"Stop directing HTTP request through a proxy server."

	self httpProxyServer: nil.
	self httpProxyPort: 80.
	HTTPProxyCredentials := ''
! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'md 8/29/2005 17:29'!
useProxyServerNamed: proxyServerName port: portNum
	"Direct all HTTP requests to the HTTP proxy server with the given name and port number."

	proxyServerName ifNil: [  "clear proxy settings"
		self httpProxyServer: nil.
		self httpProxyPort: 80.
		^ self].

	proxyServerName isString
		ifFalse: [self error: 'Server name must be a String or nil'].
	self httpProxyServer: proxyServerName.

	self httpProxyPort: portNum.
	self httpProxyPort class == String ifTrue: [HTTPPort := portNum asNumber].
	self httpProxyPort ifNil: [self httpProxyPort: self defaultPort].! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'al 1/8/2004 12:54'!
useProxyServerNamed: proxyServerName port: portNum proxyUser: aString password: anotherString
	self useProxyServerNamed: proxyServerName port: portNum.
	self proxyUser: aString password: anotherString! !


!HTTPSocket class methodsFor: 'utilities' stamp: 'ar 4/10/2005 18:47'!
argStringUnencoded: args
	"Return the args in a long string, as encoded in a url"

	| argsString first |
	args isString ifTrue: ["sent in as a string, not a dictionary"
		^ (args first = $? ifTrue: [''] ifFalse: ['?']), args].
	argsString _ WriteStream on: String new.
	argsString nextPut: $?.
	first _ true.
	args associationsDo: [ :assoc |
		assoc value do: [ :value |
			first ifTrue: [ first _ false ] ifFalse: [ argsString nextPut: $& ].
			argsString nextPutAll: assoc key.
			argsString nextPut: $=.
			argsString nextPutAll: value. ] ].
	^ argsString contents
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'ar 4/10/2005 18:47'!
argString: args
	"Return the args in a long string, as encoded in a url"

	| argsString first |
	args isString ifTrue: ["sent in as a string, not a dictionary"
		^ (args first = $? ifTrue: [''] ifFalse: ['?']), args].
	argsString _ WriteStream on: String new.
	argsString nextPut: $?.
	first _ true.
	args associationsDo: [ :assoc |
		assoc value do: [ :value |
			first ifTrue: [ first _ false ] ifFalse: [ argsString nextPut: $& ].
			argsString nextPutAll: assoc key encodeForHTTP.
			argsString nextPut: $=.
			argsString nextPutAll: value encodeForHTTP. ] ].
	^ argsString contents
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'tk 12/7/2001 12:24'!
expandUrl: newUrl ip: byteArrayIP port: portNum

^ (newUrl beginsWith: '../') 
	ifTrue: [
		String streamContents: [:strm | 
			byteArrayIP do: [:bb | bb printOn: strm.  strm nextPut: $.].
			strm skip: -1; nextPut: $:.
			portNum printOn: strm.
			strm nextPutAll: (newUrl allButFirst: 2)]]
	ifFalse: [newUrl]! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'mir 7/30/1999 15:46'!
initHTTPSocket: httpUrl ifError: aBlock
	"Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request."

	^self initHTTPSocket: httpUrl wait: self standardDeadline ifError: aBlock! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'hpt 12/9/2004 22:54'!
initHTTPSocket: httpUrl wait: timeout ifError: aBlock
	"Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request."

	| serverName port serverAddr s |
	Socket initializeNetwork.

	serverName := httpUrl authority.
	port := httpUrl port ifNil: [self defaultPort].

	(self shouldUseProxy: serverName) ifTrue: [ 
		serverName := self httpProxyServer.
		port := self httpProxyPort].

  	"make the request"	
	serverAddr := NetNameResolver addressForName: serverName timeout: 20.
	serverAddr ifNil: [
		aBlock value: 'Error: Could not resolve the server named: ', serverName].

	s := HTTPSocket new.
	s connectTo: serverAddr port: port.
	(s waitForConnectionUntil: timeout) ifFalse: [
		Socket deadServer: httpUrl authority.
		s destroy.
		^aBlock value: 'Error: Server ',httpUrl authority,' is not responding'].
	^s
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'rbb 2/18/2005 13:23'!
retry: tryBlock asking: troubleString ifGiveUp: abortActionBlock
	"Execute the given block. If it evaluates to true, return true. If it evaluates to false, prompt the user with the given string to see if he wants to try again. If not, evaluate the abortActionBlock and return false."

	| response  |
	[tryBlock value] whileFalse: [
		| sema |
		sema _ Semaphore new.
		WorldState addDeferredUIMessage: [
			response _ UIManager default chooseFrom: #('Retry' 'Give Up')
				title: troubleString.
			sema signal.
		].
		sema wait.
		response = 2 ifTrue: [abortActionBlock value. ^ false]].
	^ true
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'hpt 12/10/2004 23:21'!
shouldUseProxy: serverName
	"Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request."

	self httpProxyServer ifNotEmpty: [
		self httpProxyExceptions
			detect: [:domainName | domainName match: serverName]
			ifNone: [^true]].
	^false
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'nk 6/12/2004 09:24'!
showImage: image named: imageName
	Smalltalk isMorphic
		ifTrue: [HandMorph attach: (World drawingClass withForm: image)]
		ifFalse: [FormView open: image named: imageName]! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'hg 2/11/2002 11:31'!
userAgentString 
	"self userAgentString"

	^'User-Agent: ',
		SystemVersion current version, '-', 
		SystemVersion current highestUpdate printString! !
Morph subclass: #HaloMorph
	instanceVariableNames: 'target innerTarget positionOffset angleOffset minExtent growingOrRotating directionArrowAnchor haloBox simpleMode originalExtent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!HaloMorph commentStamp: '<historical>' prior: 0!
This morph provides a halo of handles for its target morph. Dragging, duplicating, rotating, and resizing to be done by mousing down on the appropriate handle. There are also handles for help and for a menu of infrequently used operations.!


!HaloMorph methodsFor: 'accessing' stamp: 'sw 1/26/2000 15:36'!
haloBox: aBox
	haloBox _ aBox! !

!HaloMorph methodsFor: 'accessing' stamp: 'jm 5/22/1998 16:28'!
innerTarget

	^ innerTarget
! !

!HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:35'!
isMagicHalo
	^self valueOfProperty: #isMagicHalo ifAbsent:[false].! !

!HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 15:37'!
isMagicHalo: aBool
	self setProperty: #isMagicHalo toValue: aBool.
	aBool ifFalse:[
		"Reset everything"
		self stopStepping. "get rid of all"
		self startStepping. "only those of interest"
	].! !

!HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:28'!
magicAlpha
	^self valueOfProperty: #magicAlpha ifAbsent:[1.0]! !

!HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:42'!
magicAlpha: alpha
	self setProperty: #magicAlpha toValue: alpha.
	self changed.! !

!HaloMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 21:56'!
setTarget: aMorph
	"Private!! Set the target without adding handles."

	target _ aMorph topRendererOrSelf.
	innerTarget _ target renderedMorph.
	innerTarget wantsDirectionHandles
		ifTrue: [self showDirectionHandles: true addHandles: false].
	target hasHalo: true.

! !

!HaloMorph methodsFor: 'accessing' stamp: 'jm 7/16/97 06:51'!
target

	^ target
! !

!HaloMorph methodsFor: 'accessing' stamp: 'jm 5/7/1998 15:42'!
target: aMorph

	self setTarget: aMorph.
	target ifNotNil: [self addHandles].
! !

!HaloMorph methodsFor: 'accessing' stamp: 'dgd 9/9/2004 22:55'!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in 
	its owner"
	^ true! !



!HaloMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:37'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
innerTarget _ deepCopier references at: innerTarget ifAbsent: [innerTarget].
! !

!HaloMorph methodsFor: 'copying' stamp: 'st 9/14/2004 13:03'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	"target _ target.		Weakly copied"
	"innerTarget _ innerTarget.		Weakly copied"
	positionOffset _ positionOffset veryDeepCopyWith: deepCopier.
	angleOffset _ angleOffset veryDeepCopyWith: deepCopier.
	growingOrRotating _ growingOrRotating veryDeepCopyWith: deepCopier.
	directionArrowAnchor _ directionArrowAnchor.
	simpleMode _ simpleMode.
	haloBox _ haloBox.
	originalExtent _ originalExtent
! !


!HaloMorph methodsFor: 'drawing' stamp: 'dgd 9/12/2004 22:00'!
drawOn: aCanvas 
	"Draw this morph only if it has no target."
	target isNil
		ifTrue: [^ super drawOn: aCanvas].
	(Preferences showBoundsInHalo
			and: [target isWorldMorph not])
		ifTrue: [| boundsColor | 
			boundsColor := Preferences menuSelectionColor
						ifNil: [Color blue].
			aCanvas
				frameAndFillRectangle: self bounds
				fillColor: Color transparent
				borderWidth: 2
				borderColor: boundsColor]! !

!HaloMorph methodsFor: 'drawing' stamp: 'ar 8/8/2001 15:13'!
drawSubmorphsOn: aCanvas
	| alpha |
	((alpha _ self magicAlpha) = 1.0)
		ifTrue:[^super drawSubmorphsOn: aCanvas].
	^super drawSubmorphsOn: (aCanvas asAlphaBlendingCanvas: alpha)! !


!HaloMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/2/2001 22:09'!
startDrag: evt with: dragHandle
	"Drag my target without removing it from its owner."

	| itsOwner |
	self obtainHaloForEvent: evt andRemoveAllHandlesBut: dragHandle.
	positionOffset _ dragHandle center - (target point: target position in: owner).

	 ((itsOwner _ target topRendererOrSelf owner) notNil and:
			[itsOwner automaticViewing]) ifTrue:
				[target openViewerForArgument]! !


!HaloMorph methodsFor: 'event handling' stamp: 'tk 7/14/2001 11:04'!
mouseMove: evt
	"Drag our target around"
	| thePoint |
	thePoint _ target point: (evt position - positionOffset) from: owner.
	target setConstrainedPosition: thePoint hangOut: true.! !

!HaloMorph methodsFor: 'event handling' stamp: 'sw 5/21/1998 15:41'!
wantsKeyboardFocusFor: aSubmorph
	"to allow the name to be edited in the halo in the old tty way; when we morphic-text-ize the name editing, presumably this method should be removed"
	^ true! !


!HaloMorph methodsFor: 'events' stamp: 'tk 7/14/2001 11:04'!
dragTarget: event
	"Begin dragging the target"
	| thePoint |
	thePoint _ target point: event position - positionOffset from: owner.
	target setConstrainedPosition: thePoint hangOut: true.
	event hand newMouseFocus: self.! !

!HaloMorph methodsFor: 'events' stamp: 'aoy 2/17/2003 01:27'!
popUpFor: aMorph event: evt 
	"This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame."

	| hand anEvent |
	self flag: #workAround.	"We should really have some event/hand here..."
	anEvent := evt isNil 
				ifTrue: 
					[hand := aMorph world activeHand.
					hand ifNil: [hand := aMorph world primaryHand]. 
					hand lastEvent transformedBy: (aMorph transformedFrom: nil)]
				ifFalse: 
					[hand := evt hand.
					evt].
	self target: aMorph.
	hand halo: self.
	hand world addMorphFront: self.
	positionOffset := anEvent position 
				- (aMorph point: aMorph position in: owner).
	self startStepping.
	(Preferences haloTransitions or: [self isMagicHalo]) 
		ifTrue: 
			[self magicAlpha: 0.0.
			self startSteppingSelector: #fadeInInitially]! !

!HaloMorph methodsFor: 'events' stamp: 'ar 8/8/2001 15:50'!
popUpMagicallyFor: aMorph hand: aHand
	"Programatically pop up a halo for a given hand."
	Preferences magicHalos ifTrue:[
		self isMagicHalo: true.
		self magicAlpha: 0.2].
	self target: aMorph.
	aHand halo: self.
	aHand world addMorphFront: self.
	Preferences haloTransitions ifTrue:[
		self magicAlpha: 0.0.
		self startSteppingSelector: #fadeInInitially.
	].
	positionOffset _ aHand position - (aMorph point: aMorph position in: owner).
	self startStepping.! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/4/2000 19:26'!
staysUpWhenMouseIsDownIn: aMorph
	^ ((aMorph == target) or: [aMorph hasOwner: self])! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/10/2000 19:09'!
transferHalo: event
	"Transfer the halo to the next likely recipient"
	target ifNil:[^self delete].
	target transferHalo: (event transformedBy: (target transformedFrom: self)) from: target.! !


!HaloMorph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 16:54'!
containsPoint: aPoint event: anEvent
	"Blue buttons are handled by the halo"
	(anEvent isMouse and:[anEvent isMouseDown and:[anEvent blueButtonPressed]])
		ifFalse:[^super containsPoint: aPoint event: anEvent].
	^bounds containsPoint: anEvent position! !

!HaloMorph methodsFor: 'events-processing' stamp: 'nk 6/26/2002 07:19'!
handleListenEvent: anEvent
	"We listen for possible drop events here to add back those handles after a dup/grab operation"

	(anEvent isMouse and:[anEvent isMove not]) ifFalse:[^ self]. "not interested"
	anEvent hand removeMouseListener: self. "done listening"
	(self world ifNil: [target world]) ifNil: [^ self].
	self addHandles  "and get those handles back"! !

!HaloMorph methodsFor: 'events-processing' stamp: 'ar 10/10/2000 22:00'!
rejectsEvent: anEvent
	"Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it."
	(super rejectsEvent: anEvent) ifTrue:[^true].
	anEvent isDropEvent ifTrue:[^true]. "never attempt to drop on halos"
	^false! !


!HaloMorph methodsFor: 'geometry' stamp: 'di 9/26/2000 21:03'!
position: pos
	"Halos display imprefectly if their coordinates are non-integral
		-- especially the direction handles."

	^ super position: pos asIntegerPoint! !


!HaloMorph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 13:46'!
containsPoint: aPoint 
	"This method is overridden so that, once up, the handles will stay up as long as the mouse is within the box that encloses all the handles even if it is not over any handle or over its owner."

	target isNil ifTrue: [^super containsPoint: aPoint] ifFalse: [^false]! !


!HaloMorph methodsFor: 'halos and balloon help' stamp: 'nk 6/12/2004 09:34'!
addSimpleHandlesTo: aHaloMorph box: aBox
	| aHandle |
	simpleMode _ true.

	target isWorldMorph ifTrue: [^ self addSimpleHandlesForWorldHalos].

	self removeAllMorphs.  "remove old handles, if any"
	
	self bounds: target renderedMorph worldBoundsForHalo.  "update my size"
	
	self addHandleAt: (((aBox topLeft + aBox leftCenter) // 2) + self simpleFudgeOffset) color: Color paleBuff icon: 'Halo-MoreHandles'
		on: #mouseDown send: #addFullHandles to: self.

	aHandle _ self addGraphicalHandle: #Rotate at: aBox bottomLeft on: #mouseDown send: #startRot:with: to: self.
	aHandle on: #mouseMove send: #doRot:with: to: self.

	target isFlexMorph
		ifTrue: [(self addGraphicalHandle: #Scale at: aBox bottomRight  on: #mouseDown send: #startScale:with: to: self)
				on: #mouseMove send: #doScale:with: to: self]
		ifFalse: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startGrow:with: to: self)
				on: #mouseMove send: #doGrow:with: to: self].

	innerTarget wantsSimpleSketchMorphHandles ifTrue:
		[self addSimpleSketchMorphHandlesInBox: aBox].

	growingOrRotating _ false.
	self layoutChanged.
	self changed.
! !


!HaloMorph methodsFor: 'handles' stamp: 'nk 6/12/2004 09:24'!
addChooseGraphicHandle: haloSpec
	"If the target is a sketch morph, and if the governing preference is set, add a halo handle allowing the user to select a new graphic"

	(Preferences showChooseGraphicHaloHandle and: [innerTarget isSketchMorph]) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #chooseNewGraphicFromHalo to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 12/13/2001 14:07'!
addCollapseHandle: handleSpec
	"Add the collapse handle, with all of its event handlers set up, unless the target's owner is not the world or the hand."

	| collapseHandle |
	(target owner notNil "nil happens, amazingly"
			and: [target owner isWorldOrHandMorph])
		ifFalse: [^ self].
	collapseHandle _ self addHandle: handleSpec
		on: #mouseDown send: #mouseDownInCollapseHandle:with: to: self.
	collapseHandle on: #mouseUp send: #maybeCollapse:with: to: self.
	collapseHandle on: #mouseMove send: #setDismissColor:with: to: self
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 15:51'!
addDebugHandle: handleSpec
	Preferences debugHaloHandle ifTrue:
		[self addHandle: handleSpec
			on: #mouseDown send: #doDebug:with: to: self]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 11/27/2001 11:18'!
addDismissHandle: handleSpec
	"Add the dismiss handle according to the spec, unless selectiveHalos is on and my target resists dismissal"

	| dismissHandle |
	(target okayToAddDismissHandle or: [Preferences selectiveHalos not]) ifTrue:
		[dismissHandle _ self addHandle: handleSpec
			on: #mouseDown send: #mouseDownInDimissHandle:with: to: self.
		dismissHandle on: #mouseUp send: #maybeDismiss:with: to: self.
		dismissHandle on: #mouseDown send: #setDismissColor:with: to: self.
		dismissHandle on: #mouseMove send: #setDismissColor:with: to: self]
! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:48'!
addDragHandle: haloSpec
	(self addHandle: haloSpec on: #mouseDown send: #startDrag:with: to: self)
		on: #mouseMove send: #doDrag:with: to: self


! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 12/29/2004 22:18'!
addDupHandle: haloSpec
	"Add the halo that offers duplication, or, when shift is down, make-sibling"

	self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self

! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/28/2000 09:59'!
addFewerHandlesHandle: haloSpec
	self addHandle: haloSpec on: #mouseDown send: #addSimpleHandles to: self
! !

!HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'!
addFontEmphHandle: haloSpec 
	(innerTarget isTextMorph) 
		ifTrue: 
			[self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseEmphasisOrAlignment
				to: innerTarget]! !

!HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'!
addFontSizeHandle: haloSpec 
	(innerTarget isTextMorph) 
		ifTrue: 
			[self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseFont
				to: innerTarget]! !

!HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'!
addFontStyleHandle: haloSpec 
	(innerTarget isTextMorph) 
		ifTrue: 
			[self 
				addHandle: haloSpec
				on: #mouseDown
				send: #chooseStyle
				to: innerTarget]! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/27/2000 17:22'!
addGrabHandle: haloSpec
	"If appropriate, add the black halo handle for picking up the target"

	innerTarget okayToAddGrabHandle ifTrue:
		[self addHandle: haloSpec on: #mouseDown send: #doGrab:with: to: self]

! !

!HaloMorph methodsFor: 'handles' stamp: 'dgd 8/28/2004 18:13'!
addGrowHandle: haloSpec
	target isFlexMorph ifFalse: 
		[(self addHandle: haloSpec
				on: #mouseDown send: #startGrow:with: to: self)
				on: #mouseMove send: #doGrow:with: to: self]
	"This or addScaleHandle:, but not both, will prevail at any one time"
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:16'!
addHelpHandle: haloSpec
	target balloonText ifNotNil:
		[(self addHandle: haloSpec on: #mouseDown send: #mouseDownOnHelpHandle: to: innerTarget)
			on: #mouseUp send: #deleteBalloon to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 12/29/2004 22:18'!
addMakeSiblingHandle: haloSpec
	"Add the halo handle that allows a sibling instance to be torn off, or, if the shift key is down, for a deep-copy duplicate to be made."

	self addHandle: haloSpec on: #mouseDown send: #doMakeSiblingOrDup:with: to: self

! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:05'!
addMenuHandle: haloSpec
	self addHandle: haloSpec on: #mouseDown send: #doMenu:with: to: self! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/27/2000 16:23'!
addPaintBgdHandle: haloSpec
	(innerTarget isKindOf: PasteUpMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #paintBackground to: innerTarget].
! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 11/16/2002 19:24'!
addPoohHandle: handleSpec
	(innerTarget isKindOf: (Smalltalk at: #WonderlandCameraMorph ifAbsent:[nil])) ifTrue:
		[self addHandle: handleSpec on: #mouseDown send: #strokeMode to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'RAA 3/15/2001 11:24'!
addRecolorHandle: haloSpec
	"Add a recolor handle to the receiver, if appropriate"

	| recolorHandle |

	"since this halo now opens a more general properties panel, allow it in all cases"
	"innerTarget canSetColor ifTrue:"

	recolorHandle _ self addHandle: haloSpec on: #mouseUp send: #doRecolor:with: to: self.
	recolorHandle on: #mouseUp send: #doRecolor:with: to: self

! !

!HaloMorph methodsFor: 'handles' stamp: 'nk 6/12/2004 09:24'!
addRepaintHandle: haloSpec
	(innerTarget isSketchMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #editDrawing to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:49'!
addRotateHandle: haloSpec
	(self addHandle: haloSpec on: #mouseDown send: #startRot:with: to: self)
		on: #mouseMove send: #doRot:with: to: self

! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:49'!
addScaleHandle: haloSpec
	target isFlexMorph ifTrue: 
		[(self addHandle: haloSpec
				on: #mouseDown send: #startScale:with: to: self)
				on: #mouseMove send: #doScale:with: to: self].
	"This or addGrowHandle:, but not both, will prevail at any one time"
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/9/2000 16:57'!
addScriptHandle: haloSpec
	"If the halo's innerTarget claims it wants a Script handle, add one to the receiver, forming it as per haloSpec"

	innerTarget wantsScriptorHaloHandle ifTrue:
		[self addHandle: haloSpec
				on: #mouseUp send: #editButtonsScript to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/2/2001 22:17'!
addTileHandle: haloSpec
	"Add the 'tear-off-tile' handle from the spec"

	self addHandle: haloSpec on: #mouseDown send: #tearOffTileForTarget:with: to: self
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/2/2001 22:17'!
addViewHandle: haloSpec
	"Add the 'open viewer' handle from the halo spec"

	self addHandle: haloSpec
		on: #mouseDown send: #openViewerForTarget:with: to: self


! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/23/2000 18:19'!
addViewingHandle: haloSpec
	"If appropriate, add a special Viewing halo handle to the receiver"

	(innerTarget isKindOf: PasteUpMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #presentViewMenu to: innerTarget].
! !

!HaloMorph methodsFor: 'handles' stamp: 'wiz 3/13/2005 13:53'!
openViewerForTarget: evt with: aHandle 
	"Open a viewer for my inner target or if shift pressed make a snapshot of morph."
	self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
	evt shiftPressed
		ifTrue: [target duplicateMorphImage: evt]
		ifFalse: [innerTarget openViewerForArgument]! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 1/30/2001 23:32'!
positionIn: aBox horizontalPlacement: horiz verticalPlacement: vert
	| xCoord yCoord |

	horiz == #left
		ifTrue:	[xCoord _ aBox left].
	horiz == #leftCenter
		ifTrue:	[xCoord _ aBox left + (aBox width // 4)].
	horiz == #center
		ifTrue:	[xCoord _ (aBox left + aBox right) // 2].
	horiz == #rightCenter
		ifTrue:	[xCoord _ aBox left + ((3 * aBox width) // 4)].
	horiz == #right
		ifTrue:	[xCoord _ aBox right].

	vert == #top
		ifTrue:	[yCoord _ aBox top].
	vert == #topCenter
		ifTrue:	[yCoord _ aBox top + (aBox height // 4)].
	vert == #center
		ifTrue:	[yCoord _ (aBox top + aBox bottom) // 2].
	vert == #bottomCenter
		ifTrue:	[yCoord _ aBox top + ((3 * aBox height) // 4)].
	vert == #bottom
		ifTrue:	[yCoord _ aBox bottom].

	^ xCoord asInteger @ yCoord asInteger! !

!HaloMorph methodsFor: 'handles' stamp: 'wiz 1/1/2006 12:57'!
tearOffTileForTarget: evt with: aHandle
	"Tear off a tile representing my inner target.  If shift key is down, open up an instance browser on the morph itself, not the player, with tiles showing, instead"

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
	evt shiftPressed
		ifTrue: [innerTarget openInstanceBrowserWithTiles]
		ifFalse: [innerTarget tearOffTile]
	! !


!HaloMorph methodsFor: 'initialization' stamp: 'sw 10/2/2001 21:20'!
acceptNameEdit
	"If the name is currently under edit, accept the changes"

	| label |
	(label _ self findA: NameStringInHalo) ifNotNil:
		[label hasFocus ifTrue:
			[label lostFocusWithoutAccepting]]! !

!HaloMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:28'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.6
		g: 0.8
		b: 1.0! !

!HaloMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:29'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	growingOrRotating _ false.
	simpleMode _ Preferences simpleHalosInForce ! !


!HaloMorph methodsFor: 'meta-actions' stamp: 'jcg 9/21/2001 13:18'!
blueButtonDown: event
	"Transfer the halo to the next likely recipient"
	target ifNil:[^self delete].
	event hand obtainHalo: self.
	positionOffset _ event position - (target point: target position in: owner).
	self isMagicHalo ifTrue:[
		self isMagicHalo: false.
		^self magicAlpha: 1.0].
	"wait for drags or transfer"
	event hand 
		waitForClicksOrDrag: self 
		event: event
		selectors: { #transferHalo:. nil. nil. #dragTarget:. }
		threshold: 5.! !

!HaloMorph methodsFor: 'meta-actions' stamp: 'ar 9/15/2000 16:42'!
handlerForBlueButtonDown: anEvent
	"Blue button was clicked within the receiver"
	^self! !


!HaloMorph methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:46'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	simpleMode ifNil: [simpleMode _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 14:56'!
fadeIn
	self magicAlpha >= 1.0 ifTrue:[self stopSteppingSelector: #fadeIn].
	self magicAlpha: ((self magicAlpha + 0.1) min: 1.0)
! !

!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:44'!
fadeInInitially
	| max |
	max _ self isMagicHalo ifTrue:[0.3] ifFalse:[1.0].
	self magicAlpha >= max ifTrue:[self stopSteppingSelector: #fadeInInitially].
	self magicAlpha: ((self magicAlpha + (max * 0.1)) min: max)
! !

!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 14:57'!
fadeOut
	self magicAlpha <= 0.3 ifTrue:[self stopSteppingSelector: #fadeOut].
	self magicAlpha: ((self magicAlpha - 0.1) max: 0.3)
! !

!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:46'!
fadeOutFinally
	self magicAlpha <= 0.05 ifTrue:[^super delete].
	self magicAlpha <= 0.3 ifTrue:[
		^self magicAlpha: (self magicAlpha - 0.03 max: 0.0)].
	self magicAlpha: ((self magicAlpha * 0.5) max: 0.0)
! !

!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:38'!
handleEntered
	self isMagicHalo ifFalse:[^self].
	self stopStepping; startStepping.
	self startSteppingSelector: #fadeIn.
! !

!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:38'!
handleLeft
	self isMagicHalo ifFalse:[^self].
	self stopStepping; startStepping.
	self startSteppingSelector: #fadeOut.! !

!HaloMorph methodsFor: 'stepping' stamp: 'nk 6/27/2003 12:28'!
localHaloBoundsFor: aMorph

	"aMorph may be in the hand and perhaps not in our world"

	| r |

	r _ aMorph worldBoundsForHalo truncated.
	aMorph world = self world ifFalse: [^r].
	^((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated! !

!HaloMorph methodsFor: 'stepping' stamp: 'nk 6/27/2003 12:32'!
step
	| newBounds |
	target
		ifNil: [^ self].
	newBounds _ target isWorldMorph
				ifTrue: [target bounds]
				ifFalse: [self localHaloBoundsFor: target renderedMorph].
	newBounds = self bounds
		ifTrue: [^ self].
	newBounds extent = self bounds extent
		ifTrue: [^ self position: newBounds origin].
	growingOrRotating
		ifFalse: [submorphs size > 1
				ifTrue: [self addHandles]].
	"adjust halo bounds if appropriate"
	self bounds: newBounds! !


!HaloMorph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/2/2001 21:23'!
delete
	"Delete the halo.  Tell the target that it no longer has the halo; accept any pending edits to the name; and then either actually delete myself or start to fade out"

	target ifNotNil:
		[target hasHalo: false].
	self acceptNameEdit.
	self isMagicHalo: false.
	Preferences haloTransitions
		ifTrue:
			[self stopStepping; startStepping.
			self startSteppingSelector: #fadeOutFinally]
		ifFalse:
			[super delete]! !


!HaloMorph methodsFor: 'testing' stamp: 'jm 7/16/97 06:54'!
stepTime

	^ 0  "every cycle"
! !


!HaloMorph methodsFor: 'updating' stamp: 'di 11/17/2001 10:56'!
changed
	"Quicker to invalidate handles individually if target is large (especially the world)"

	self extent > (200@200)
		ifTrue: [(target notNil and: [target ~~ self world]) ifTrue:
					["Invalidate 4 outer strips first, thus subsuming separate damage."
					(self fullBounds areasOutside: target bounds) do:
						[:r | self invalidRect: r]].
				self submorphsDo: [:m | m changed]]
		ifFalse: [super changed].
! !


!HaloMorph methodsFor: 'WiW support' stamp: 'RAA 6/27/2000 19:12'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^7		"Halos are very front-like things"! !


!HaloMorph methodsFor: '*eToys-handles' stamp: 'sw 3/30/2005 04:26'!
doDupOrMakeSibling: evt with: dupHandle
	"Ask hand to duplicate my target, if shift key *not* pressed, or make a sibling if shift key *is* pressed"

	^ (evt shiftPressed and: [target couldMakeSibling])
		ifTrue:
			[dupHandle color: Color green muchDarker.
			self doMakeSibling: evt with: dupHandle]
		ifFalse:
			[self doDup: evt with: dupHandle]! !

!HaloMorph methodsFor: '*eToys-handles' stamp: 'sw 3/30/2005 04:28'!
doMakeSiblingOrDup: evt with: dupHandle
	"Ask hand to duplicate my target, if shift key *is* pressed, or make a sibling if shift key *not* pressed"

	^ (evt shiftPressed or: [target couldMakeSibling not])
		ifFalse:
			[self doMakeSibling: evt with: dupHandle]
		ifTrue:
			[dupHandle color: Color green.
			self doDup: evt with: dupHandle]! !




!HaloMorph methodsFor: 'private' stamp: 'sw 4/27/2000 13:39'!
addCircleHandles
	| box |
	simpleMode _ false.
	target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos].

	self removeAllMorphs.  "remove old handles, if any"
	self bounds: target renderedMorph worldBoundsForHalo.  "update my size"
	box _ self basicBox.

	target addHandlesTo: self box: box.

	self addName.
	growingOrRotating _ false.
	self layoutChanged.
	self changed.
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 4/4/2006 16:56'!
addDirectionHandles

	| centerHandle d w directionShaft patch patchColor crossHairColor |
	self showingDirectionHandles ifFalse: [^ self].

	directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
	patch _ target imageFormForRectangle: (Rectangle center: directionArrowAnchor extent: 3@3).
	patchColor _ patch colorAt: 1@1.

	(directionShaft _ LineMorph newSticky makeForwardArrow)
		borderWidth: 2; borderColor: (Color green orColorUnlike: patchColor).
	self positionDirectionShaft: directionShaft.
	self addMorphFront: directionShaft.
	directionShaft setCenteredBalloonText: 'Set forward direction' translated;
		on: #mouseDown send: #doDirection:with: to: self;
		on: #mouseMove send: #trackDirectionArrow:with: to: self;
		on: #mouseUp send: #setDirection:with: to: self.

	d _ 15.  "diameter"  w _ 3.  "borderWidth"
	crossHairColor _ Color red orColorUnlike: patchColor.
	(centerHandle _ EllipseMorph newBounds: (0@0 extent: d@d) color: Color transparent)
			borderWidth: w; borderColor: (Color blue orColorUnlike: patchColor);
			addMorph: (LineMorph from: (d//2)@w to: (d//2)@(d-w-1) color: crossHairColor width: 1) lock;
			addMorph: (LineMorph from: w@(d//2) to: (d-w-1)@(d//2) color: crossHairColor width: 1) lock;
			align: centerHandle bounds center with: directionArrowAnchor.
	centerHandle wantsYellowButtonMenu: false.
	self addMorph: centerHandle.
	centerHandle setCenteredBalloonText: 'Rotation center (hold down the shift key and drag from here to change it)' translated;
			on: #mouseDown send: #prepareToTrackCenterOfRotation:with: to: self;
			on: #mouseMove send: #trackCenterOfRotation:with: to: self;
			on: #mouseUp send: #setCenterOfRotation:with: to: self
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/29/1999 15:31'!
addFullHandles
	"Later, obey a preference to choose between circle-iconic and solid-circles"
	self addCircleHandles! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/18/2004 18:23'!
addGraphicalHandleFrom: formKey at: aPoint
	"Add the supplied form as a graphical handle centered at the given point.  Return the handle."
	| handle aForm |
	aForm _ (ScriptingSystem formAtKey: formKey) ifNil: [ScriptingSystem formAtKey: #SolidMenu].
	handle _ ImageMorph new image: aForm; bounds: (Rectangle center: aPoint extent: aForm extent).
	handle wantsYellowButtonMenu: false.
	self addMorph: handle.
	handle on: #mouseUp send: #endInteraction to: self.
	^ handle
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 8/28/2003 15:15'!
addGraphicalHandle: formKey at: aPoint on: eventName send: selector to: recipient
	"Add the supplied form as a graphical handle centered at the given point, and set it up to respond to the given event by sending the given selector to the given recipient.  Return the handle."
	| handle |
	handle _ self addGraphicalHandleFrom: formKey at: aPoint.
	handle on: eventName send: selector to: recipient.
	handle setBalloonText: (target balloonHelpTextForHandle: handle) translated.
	^ handle
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 19:39'!
addHandleAt: aPoint color: aColor icon: iconName on: eventName send: selector to: recipient 
	"Add a handle centered at the given point with the given color, 
	and set it up to respond to the given event by sending the 
	given selector to the given recipient. Return the handle."
	| handle |
	handle := self createHandleAt: aPoint color: aColor iconName: iconName.
	self addMorph: handle.

	handle on: #mouseUp send: #endInteraction to: self.
	handle on: eventName send: selector to: recipient.
	handle setBalloonText: (target balloonHelpTextForHandle: handle) translated.

	^ handle ! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/29/2000 18:36'!
addHandleAt: aPoint color: aColor on: eventName send: selector to: recipient
	^ self addHandleAt: aPoint color: aColor icon: nil on: eventName send: selector to: recipient
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/28/2000 09:57'!
addHandles
	simpleMode == true
		ifTrue:
			[self addSimpleHandles]
		ifFalse:
			[self addCircleHandles]
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/4/2000 16:27'!
addHandlesForWorldHalos
	"Add handles for world halos, like the man said"

	| box w |
	w _ self world ifNil:[target world].
	self removeAllMorphs.  "remove old handles, if any"
	self bounds: target bounds.
	box _ w bounds insetBy: 9.
	target addWorldHandlesTo: self box: box.

	Preferences uniqueNamesInHalos ifTrue:
		[innerTarget assureExternalName].
	self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
	growingOrRotating _ false.
	self layoutChanged.
	self changed.
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 19:37'!
addHandle: handleSpec on: eventName send: selector to: recipient 
	"Add a handle within the halo box as per the haloSpec, and set 
	it up to respond to the given event by sending the given 
	selector to the given recipient. Return the handle."
	| handle aPoint |

	aPoint := self
				positionIn: haloBox
				horizontalPlacement: handleSpec horizontalPlacement
				verticalPlacement: handleSpec verticalPlacement.

	handle := self
				addHandleAt: aPoint
				color: (Color colorFrom: handleSpec color)
				icon: handleSpec iconSymbol
				on: eventName
				send: selector
				to: recipient.

	self isMagicHalo
		ifTrue: [
			handle on: #mouseEnter send: #handleEntered to: self.
			handle on: #mouseLeave send: #handleLeft to: self].

	^ handle! !

!HaloMorph methodsFor: 'private' stamp: 'sw 8/16/2000 17:41'!
addName
	"Add a name readout at the bottom of the halo."

	Preferences uniqueNamesInHalos ifTrue:
		[target assureExternalName].

	self addNameBeneath: self basicBox string: target externalName
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 4/4/2006 16:58'!
addNameBeneath: outerRectangle string: aString
	"Add a name display centered beneath the bottom of the outer rectangle. Return the handle."

	| nameMorph namePosition w |
	w _ self world ifNil:[target world].
	nameMorph _ NameStringInHalo contents: aString font: Preferences standardHaloLabelFont.
	nameMorph wantsYellowButtonMenu: false.
	nameMorph color: Color black.
	nameMorph useStringFormat; target: innerTarget; putSelector: #tryToRenameTo:.
	namePosition _ outerRectangle bottomCenter -
		((nameMorph width // 2) @ (self handleSize negated // 2 - 1)).
	nameMorph position: (namePosition min: w viewBox bottomRight - nameMorph extent y + 2).
	nameMorph balloonTextSelector: #objectNameInHalo.
	self addMorph: nameMorph.
	^ nameMorph! !

!HaloMorph methodsFor: 'private' stamp: 'sw 4/27/2000 13:40'!
addSimpleHandles
	target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos].
	self removeAllMorphs.  "remove old handles, if any"
	self bounds: target renderedMorph worldBoundsForHalo.  "update my size"
	self innerTarget addSimpleHandlesTo: self box: self basicBoxForSimpleHalos

! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/28/1999 15:39'!
addSimpleHandlesForWorldHalos
	"Nothing special at present here -- just use the regular handles.  Cannot rotate or resize world"

	self addHandlesForWorldHalos
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 17:37'!
addSimpleSketchMorphHandlesInBox: box

	self addGraphicalHandle: #PaintTab at: box bottomCenter on: #mouseDown send: #editDrawing to: self innerTarget.

	self addDirectionHandles! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/7/2000 23:36'!
basicBox
	| aBox minSide anExtent w |
	minSide _ 4 * self handleSize.
	anExtent _ ((self width + self handleSize + 8) max: minSide) @
				((self height + self handleSize + 8) max: minSide).
	aBox _ Rectangle center: self center extent: anExtent.
	w _ self world ifNil:[target outermostWorldMorph].
	^ w
		ifNil:
			[aBox]
		ifNotNil:
			[aBox intersect: (w viewBox insetBy: 8@8)]
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/7/2000 23:36'!
basicBoxForSimpleHalos
	| w |
	w _ self world ifNil:[target outermostWorldMorph].
	^ (target topRendererOrSelf worldBoundsForHalo expandBy: self handleAllowanceForIconicHalos)
			intersect: (w bounds insetBy: 8@8)
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/29/2004 19:51'!
createHandleAt: aPoint color: aColor iconName: iconName 
	| bou handle |
	bou := Rectangle center: aPoint extent: self handleSize asPoint.
	Preferences alternateHandlesLook
		ifTrue: [
			handle := RectangleMorph newBounds: bou color: aColor.
			handle borderWidth: 1.
			handle useRoundedCorners.
			self setColor: aColor toHandle: handle]
		ifFalse: [handle := EllipseMorph newBounds: bou color: aColor].
	""
	handle borderColor: aColor muchDarker.
	handle wantsYellowButtonMenu: false.
	""
	iconName isNil
		ifFalse: [| form | 
			form := ScriptingSystem formAtKey: iconName.
			form isNil
				ifFalse: [| image | 
					image := ImageMorph new.
					image image: form.
					image color: aColor makeForegroundColor.
					image lock.
					handle addMorphCentered: image]].
	""
	^ handle! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:16'!
directionArrowLength
	^ 25! !

!HaloMorph methodsFor: 'private' stamp: 'sw 6/17/1999 16:58'!
dismiss
	"Remove my target from the world."

	| w |
	self isThisEverCalled. "Seemingly no longer enfranchised"
	w _ self world.
	w ifNotNil: [w stopStepping: target].
	self delete.
	target dismissViaHalo! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/27/2002 09:27'!
doDebug: evt with: menuHandle
	"Ask hand to invoke the a debugging menu for my inner target.  If shift key is down, immediately put up an inspector on the inner target"

	| menu |
	self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
	self world displayWorld.
	evt shiftPressed ifTrue: 
		[self delete.
		^ innerTarget inspectInMorphic: evt].

	menu _ innerTarget buildDebugMenu: evt hand.
	menu addTitle: (innerTarget externalName truncateWithElipsisTo: 40).
	menu popUpEvent: evt in: self world! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'!
doDirection: anEvent with: directionHandle
	anEvent hand obtainHalo: self.
	self removeAllHandlesBut: directionHandle! !

!HaloMorph methodsFor: 'private' stamp: 'tk 7/14/2001 11:04'!
doDrag: evt with: dragHandle
	| thePoint |
	evt hand obtainHalo: self.
	thePoint _ target point: evt position - positionOffset from: owner.
	target setConstrainedPosition:(target griddedPoint: thePoint) hangOut: true.
! !

!HaloMorph methodsFor: 'private' stamp: 'jcg 5/30/2002 09:12'!
doDup: evt with: dupHandle
	"Ask hand to duplicate my target."

	(target isKindOf: SelectionMorph) ifTrue:
		[^ target doDup: evt fromHalo: self handle: dupHandle].

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle.
	self setTarget: (target duplicateMorph: evt).
	evt hand grabMorph: target.
	self step. "update position if necessary"
	evt hand addMouseListener: self. "Listen for the drop"! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:35'!
doGrab: evt with: grabHandle
	"Ask hand to grab my target."

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: grabHandle.
	evt hand grabMorph: target.
	self step. "update position if necessary"
	evt hand addMouseListener: self. "Listen for the drop"! !

!HaloMorph methodsFor: 'private' stamp: 'sw 2/2/2006 02:48'!
doGrow: evt with: growHandle
	"Called while the mouse is down in the grow handle"

	| newExtent extentToUse scale |
	evt hand obtainHalo: self.
	newExtent _ (target pointFromWorld: (target griddedPoint: evt cursorPoint - positionOffset))
								- target topLeft.
	evt shiftPressed ifTrue: [
		scale _ (newExtent x / (originalExtent x max: 1)) min:
					(newExtent y / (originalExtent y max: 1)).
		newExtent _ (originalExtent x * scale) asInteger @ (originalExtent y * scale) asInteger
	].
	(newExtent x < 1 or: [newExtent y < 1 ]) ifTrue: [^ self].
	target renderedMorph setExtentFromHalo: (extentToUse _ newExtent).
	growHandle position: evt cursorPoint - (growHandle extent // 2).
	self layoutChanged.
	(self valueOfProperty: #commandInProgress) ifNotNilDo:  
		[:cmd | "Update the final extent"
			cmd redoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: extentToUse]
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 3/30/2005 04:31'!
doMakeSibling: evt with: dupHandle
	"Ask hand to make a sibling of my target.  Only reachable if target is of a uniclass"

	target couldMakeSibling ifFalse: [^ self].

	target assuredPlayer assureUniClass.
	self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle.
	self setTarget: (target makeSiblings: 1) first.
	evt hand grabMorph: target.
	self step. "update position if necessary"
	evt hand addMouseListener: self. "Listen for the drop"! !

!HaloMorph methodsFor: 'private' stamp: 'ar 11/29/2001 20:01'!
doMenu: evt with: menuHandle
	"Ask hand to invoke the halo menu for my inner target."

	| menu |
	self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
	self world displayWorld.
	menu _ innerTarget buildHandleMenu: evt hand.
	innerTarget addTitleForHaloMenu: menu.
	menu popUpEvent: evt in: self world.
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 9/20/2001 00:16'!
doRecolor: evt with: aHandle
	"The mouse went down in the 'recolor' halo handle.  Allow the user to change the color of the innerTarget"

	evt hand obtainHalo: self.
	(aHandle containsPoint: evt cursorPoint)
		ifFalse:  "only do it if mouse still in handle on mouse up"
			[self delete.
			target addHalo: evt]
		ifTrue:
			[(Preferences propertySheetFromHalo == evt shiftPressed)
				ifFalse:	[innerTarget openAPropertySheet]
				ifTrue:	[innerTarget changeColor].
			self showingDirectionHandles ifTrue: [self addHandles]]! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 4/4/2006 16:57'!
doRot: evt with: rotHandle
	"Update the rotation of my target if it is rotatable.  Keep the relevant command object up to date."

	| degrees |
	evt hand obtainHalo: self.
	degrees _ (evt cursorPoint - (target pointInWorld: target referencePosition)) degrees.
	degrees _ degrees - angleOffset degrees.
	degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false.
	degrees = 0.0
		ifTrue: [self setColor: Color lightBlue toHandle: rotHandle]
		ifFalse: [self setColor: Color blue toHandle: rotHandle].
	rotHandle submorphsDo:
		[:m | m color: rotHandle color makeForegroundColor].
	self removeAllHandlesBut: rotHandle.
	self showingDirectionHandles ifFalse:
		[self showDirectionHandles: true addHandles: false].
	self addDirectionHandles.

	target rotationDegrees: degrees.

	rotHandle position: evt cursorPoint - (rotHandle extent // 2).
	(self valueOfProperty: #commandInProgress) ifNotNilDo:
		[:cmd | "Update the final rotation"
		cmd redoTarget: target renderedMorph selector: #heading: argument: degrees].
	self layoutChanged! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 4/4/2006 16:53'!
doScale: evt with: scaleHandle
	"Update the scale of my target if it is scalable."
	| newHandlePos colorToUse |
	evt hand obtainHalo: self.
	newHandlePos _ evt cursorPoint - (scaleHandle extent // 2).
	target scaleToMatch: newHandlePos.
	colorToUse := target scale = 1.0
						ifTrue: [Color yellow]
						ifFalse: [Color orange].
	self setColor: colorToUse toHandle: scaleHandle.
	scaleHandle
		submorphsDo: [:m | m color: colorToUse makeForegroundColor].
	scaleHandle position: newHandlePos.
	self layoutChanged.

	(self valueOfProperty: #commandInProgress) ifNotNilDo:[:cmd |
		"Update the final extent"
		cmd redoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent
	].
! !

!HaloMorph methodsFor: 'private' stamp: 'md 12/12/2003 16:21'!
endInteraction
	"Clean up after a user interaction with the a halo control"

	| m |
	self isMagicHalo: false.	"no longer"
	self magicAlpha: 1.0.
	(target isInWorld not or: [owner isNil]) ifTrue: [^self].
	[target isFlexMorph and: [target hasNoScaleOrRotation]] whileTrue: 
			[m := target firstSubmorph.
			target removeFlexShell.
			target := m].
	self isInWorld 
		ifTrue: 
			["make sure handles show in front, even if flex shell added"

			self comeToFront.
			self addHandles].
	(self valueOfProperty: #commandInProgress) ifNotNilDo: 
			[:cmd | 
			self rememberCommand: cmd.
			self removeProperty: #commandInProgress]! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:42'!
handleAllowanceForIconicHalos
	^ 12! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 5/17/2004 20:18'!
handleSize
	^ Preferences biggerHandles
		ifTrue: [20]
		ifFalse: [16]! !

!HaloMorph methodsFor: 'private' stamp: 'aoy 2/15/2003 21:10'!
maybeCollapse: evt with: collapseHandle 
	"Ask hand to collapse my target if mouse comes up in it."

	evt hand obtainHalo: self.
	self delete.
	(collapseHandle containsPoint: evt cursorPoint) 
		ifFalse: 
			[
			target addHalo: evt]
		ifTrue: 
			[
			target collapse]! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 4/4/2006 17:02'!
maybeDismiss: evt with: dismissHandle
	"Ask hand to dismiss my target if mouse comes up in it."

	evt hand obtainHalo: self.
	(dismissHandle containsPoint: evt cursorPoint)
		ifFalse:
			[self delete.
			target addHalo: evt]
		ifTrue:
			[target resistsRemoval ifTrue:
				[(PopUpMenu
					confirm: 'Really throw this away' translated
					trueChoice: 'Yes' translated
					falseChoice: 'Um, no, let me reconsider' translated) ifFalse: [^ self]].
			evt hand removeHalo.
			self delete.
			target dismissViaHalo.
			ActiveWorld presenter flushPlayerListCache]! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'!
maybeDoDup: evt with: dupHandle
	evt hand obtainHalo: self.
	^ target okayToDuplicate ifTrue:
		[self doDup: evt with: dupHandle]! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/3/2001 00:21'!
mouseDownInCollapseHandle: evt with: collapseHandle
	"The mouse went down in the collapse handle; collapse the morph"

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: collapseHandle.
	self setDismissColor: evt with: collapseHandle! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/29/2004 19:55'!
mouseDownInDimissHandle: evt with: dismissHandle
	evt hand obtainHalo: self.
	Preferences soundsEnabled ifTrue: [TrashCanMorph playMouseEnterSound].
	self removeAllHandlesBut: dismissHandle.
	self setColor: Color darkGray toHandle: dismissHandle.
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:16'!
obtainHaloForEvent: evt andRemoveAllHandlesBut: aHandle
	"Make sure the event's hand correlates with the receiver, and remove all handles except the given one.  If nil is provided as the handles argument, the result is that all handles are removed.  Note that any pending edits to the name-string in the halo are accepted at this time."

	evt hand obtainHalo: self.
	self acceptNameEdit.
	self removeAllHandlesBut: aHandle! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:12'!
positionDirectionShaft: shaft
	"Position the shaft."
	| alphaRadians unitVector |
	"Pretty crude and slow approach at present, but a stake in the ground"
	alphaRadians _ target heading degreesToRadians.
	unitVector _ alphaRadians sin  @ alphaRadians cos negated.
	shaft setVertices: {unitVector * 6 + directionArrowAnchor.  "6 = radius of deadeye circle"
					unitVector * self directionArrowLength + directionArrowAnchor}
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:35'!
prepareToTrackCenterOfRotation: evt with: rotationHandle
	evt hand obtainHalo: self.
	evt shiftPressed ifTrue:[
		self removeAllHandlesBut: rotationHandle.
	] ifFalse:[
		rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
		self startDrag: evt with: rotationHandle
	].
	evt hand showTemporaryCursor: Cursor blank! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/10/2004 13:38'!
removeAllHandlesBut: h
	"Remove all handles except h."
	(Preferences maintainHalos and:[h isNil])
		ifTrue:[self removeHalo]
		ifFalse:[
			submorphs copy do:
				[:m | m == h ifFalse: [m delete]]
		].
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:33'!
setCenterOfRotation: evt with: rotationHandle
	| localPt |
	evt hand obtainHalo: self.
	evt hand showTemporaryCursor: nil.
	(rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
		localPt _ innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
		innerTarget setRotationCenterFrom: localPt.
	].
	rotationHandle removeProperty: #dragByCenterOfRotation.
	self endInteraction
! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/29/2004 19:51'!
setColor: aColor toHandle: aHandle 
	"private - change the color to the given handle, applying the 
	alternate look if corresponds"
	aHandle color: aColor.
	Preferences alternateHandlesLook
		ifTrue: [| fill | 
			fill := GradientFillStyle ramp: {0.0 -> aColor muchLighter. 1.0 -> aColor darker}.
			fill origin: aHandle topLeft.
			fill direction: aHandle extent.
			aHandle fillStyle: fill] ! !

!HaloMorph methodsFor: 'private' stamp: 'ar 6/12/2001 05:24'!
setDirection: anEvent with: directionHandle
	"The user has let up after having dragged the direction arrow; now set the forward direction of the actual SketchMorph accordingly"
	anEvent hand obtainHalo: self.
	target setDirectionFrom: directionHandle center.
	self endInteraction! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 9/29/2004 19:56'!
setDismissColor: evt with: dismissHandle
	"Called on mouseStillDown in the dismiss handle; set the color appropriately."

	| colorToUse |
	evt hand obtainHalo: self.
	colorToUse _  (dismissHandle containsPoint: evt cursorPoint)
		ifFalse:
			[Color red muchLighter]
		ifTrue:
			[Color lightGray].
	self setColor: colorToUse toHandle: dismissHandle.
! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:25'!
showDirectionHandles: wantToShow

	self showDirectionHandles: wantToShow addHandles: true  "called from menu"
! !

!HaloMorph methodsFor: 'private' stamp: 'aoy 2/17/2003 01:27'!
showDirectionHandles: wantToShow addHandles: needHandles 
	directionArrowAnchor := wantToShow 
				ifTrue: [target referencePositionInWorld	"not nil means show"]
				ifFalse: [nil].
	needHandles ifTrue: [self addHandles] ! !

!HaloMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 19:04'!
showingDirectionHandles
	^directionArrowAnchor notNil! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:43'!
simpleFudgeOffset
	"account for the difference in basicBoxes between regular and simple handles"

	^ 0@0
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 2/2/2006 02:46'!
startGrow: evt with: growHandle
	"Initialize resizing of my target.  Launch a command representing it, to support Undo"

	| botRt |
	self obtainHaloForEvent: evt andRemoveAllHandlesBut: growHandle.
	botRt _ target point: target bottomRight in: owner.
	positionOffset _ (self world viewBox containsPoint: botRt)
		ifTrue: [evt cursorPoint - botRt]
		ifFalse: [0@0].

	self setProperty: #commandInProgress toValue:
		(Command new
			cmdWording: ('resize ' translated, target nameForUndoWording);
			undoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent).

	originalExtent _ target extent! !

!HaloMorph methodsFor: 'private' stamp: 'sw 2/2/2006 01:31'!
startRot: evt with: rotHandle
	"Initialize rotation of my target if it is rotatable.  Launch a command object to represent the action"

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: rotHandle.
	target isFlexMorph ifFalse: 
		[target isInWorld ifFalse: [self setTarget: target player costume].
		target addFlexShellIfNecessary].
	growingOrRotating _ true.

	self removeAllHandlesBut: rotHandle.  "remove all other handles"
	angleOffset _ evt cursorPoint - (target pointInWorld: target referencePosition).
	angleOffset _ Point
			r: angleOffset r
			degrees: angleOffset degrees - target rotationDegrees.
	self setProperty: #commandInProgress toValue:
		(Command new
			cmdWording: ('rotate ' translated, target nameForUndoWording);
			undoTarget: target renderedMorph selector: #heading: argument: target rotationDegrees)

! !

!HaloMorph methodsFor: 'private' stamp: 'sw 2/2/2006 00:28'!
startScale: evt with: scaleHandle
	"Initialize scaling of my target."

	self obtainHaloForEvent: evt andRemoveAllHandlesBut: scaleHandle.
	target isFlexMorph ifFalse: [target addFlexShellIfNecessary].
	growingOrRotating _ true.
	positionOffset _ 0@0.

	self setProperty: #commandInProgress toValue:
		(Command new
			cmdWording: ('resize ' translated, target nameForUndoWording);
			undoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent).
	originalExtent _ target extent
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:32'!
trackCenterOfRotation: anEvent with: rotationHandle
	(rotationHandle hasProperty: #dragByCenterOfRotation) 
		ifTrue:[^self doDrag: anEvent with: rotationHandle].
	anEvent hand obtainHalo: self.
	rotationHandle center: anEvent cursorPoint.! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:43'!
trackDirectionArrow: anEvent with: shaft
	anEvent hand obtainHalo: self.
	shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
	self layoutChanged! !


!HaloMorph methodsFor: 'menu' stamp: 'dgd 9/20/2004 19:35'!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	^ false! !
Object subclass: #HaloSpec
	instanceVariableNames: 'addHandleSelector horizontalPlacement verticalPlacement color iconSymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!HaloSpec commentStamp: 'kfr 10/27/2003 16:23' prior: 0!
Sets spec's for how handles are layed out in a halo.!


!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 19:54'!
addHandleSelector
	^ addHandleSelector! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'!
color
	^ color! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'!
horizontalPlacement
	^ horizontalPlacement! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 19:54'!
horizontalPlacement: hp verticalPlacement: vp color: col iconSymbol: is addHandleSelector: sel
	horizontalPlacement _ hp.
	verticalPlacement _ vp.
	color_ col.
	iconSymbol _ is asSymbol.
	addHandleSelector _ sel! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'!
iconSymbol
	^ iconSymbol! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'!
verticalPlacement
	^ verticalPlacement! !


!HaloSpec methodsFor: 'printing' stamp: 'sw 11/15/2001 16:31'!
printOn: aStream
	"Add a textual printout representing the receiver to a stream"

	super printOn: aStream.
	aStream nextPutAll: ' (', addHandleSelector asString, ' ', iconSymbol asString, ')'! !
PreferenceView subclass: #HaloThemePreferenceView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!HaloThemePreferenceView commentStamp: '<historical>' prior: 0!
I am responsible for building the view for the preference that choose the halo theme!


!HaloThemePreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 23:12'!
haloThemeRadioButtons
	"Answer a column of butons representing the choices of halo theme"

	| buttonColumn aRow aRadioButton aStringMorph |
	buttonColumn := AlignmentMorph newColumn beTransparent.
	#(	(iconicHaloSpecifications iconic iconicHalosInForce	'circular halos with icons inside')
		(classicHaloSpecs	classic	classicHalosInForce		'plain circular halos')
		(simpleFullHaloSpecifications		simple	simpleHalosInForce	'fewer, larger halos')
		(customHaloSpecs	custom	customHalosInForce		'customizable halos')) do:

		[:quad |
			aRow := AlignmentMorph newRow beTransparent.
			aRow addMorph: (aRadioButton := UpdatingThreePhaseButtonMorph radioButton).
			aRadioButton target: Preferences.
			aRadioButton setBalloonText: quad fourth.
			aRadioButton actionSelector: #installHaloTheme:.
			aRadioButton getSelector: quad third.
			aRadioButton arguments: (Array with: quad first).
			aRow addTransparentSpacerOfSize: (4 @ 0).
			aRow addMorphBack: (aStringMorph := StringMorph contents: quad second asString).
			aStringMorph setBalloonText: quad fourth.
			buttonColumn addMorphBack: aRow].
	^ buttonColumn

	"(Preferences preferenceAt: #haloTheme) view tearOffButton"! !

!HaloThemePreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 23:11'!
representativeButtonWithColor: aColor inPanel: aPreferencesPanel
	| outerButton editButton |
	editButton := SimpleButtonMorph new 
					target: Preferences; 
					color: Color transparent; 
					actionSelector: #editCustomHalos; 
					label: 'Edit custom halos' translated;
					setBalloonText: 'Click here to edit the method that defines the custom halos' translated.
	
	outerButton := AlignmentMorph newColumn.
	outerButton
		color:  (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]);
		hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]);
		vResizing: #shrinkWrap;	
		addTransparentSpacerOfSize: (0@4);
		addMorphBack: self haloThemeRadioButtons;
		addTransparentSpacerOfSize: (0@4);
		addMorphBack: editButton.
		
	^outerButton.
	
	"(Preferences preferenceAt: #haloTheme) view tearOffButton"	! !

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

HaloThemePreferenceView class
	instanceVariableNames: ''!

!HaloThemePreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:58'!
initialize
	"adding the halo theme preference to Preferences and registering myself as its view"
	PreferenceViewRegistry ofHaloThemePreferences register: self.
	Preferences 
		addPreference: #haloTheme 
		categories: {#halos} 
		default: #iconicHaloSpecifications
		balloonHelp: ''
		projectLocal: false
		changeInformee: nil
		changeSelector: nil
		viewRegistry: PreferenceViewRegistry ofHaloThemePreferences.! !

!HaloThemePreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:58'!
unload
	PreferenceViewRegistry ofHaloThemePreferences unregister: self.! !


!HaloThemePreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:10'!
handlesPanel: aPreferencePanel
	^aPreferencePanel isKindOf: PreferencesPanel! !
Exception subclass: #Halt
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Extensions'!
!Halt commentStamp: '<historical>' prior: 0!
Halt is provided to support Object>>halt.!


!Halt methodsFor: 'description' stamp: 'tfei 5/10/1999 14:24'!
isResumable

	^true! !


!Halt methodsFor: 'priv handling' stamp: 'ajh 8/5/2003 11:30'!
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! !
Morph subclass: #HandMorph
	instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners mouseClickState mouseOverHandler lastMouseEvent targetOffset damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hardwareCursor hasChanged savedPatch userInitials lastEventBuffer genieGestureProcessor keyboardInterpreter'
	classVariableNames: 'CompositionWindowManager DoubleClickTime EventStats NewEventRules NormalCursor PasteBuffer ShowEvents'
	poolDictionaries: 'EventSensorConstants'
	category: 'Morphic-Kernel'!
!HandMorph commentStamp: '<historical>' prior: 0!
The cursor may be thought of as the HandMorph.  The hand's submorphs hold anything being carried by dragging.  

There is some minimal support for multiple hands in the same world.!


!HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'!
anyButtonPressed
	^lastMouseEvent anyButtonPressed! !

!HandMorph methodsFor: 'accessing' stamp: 'sw 2/11/98 18:00'!
colorForInsets
	"Morphs being dragged by the hand use the world's color"
	^ owner colorForInsets! !

!HandMorph methodsFor: 'accessing' stamp: 'ar 10/5/2000 23:17'!
lastEvent
	^ lastMouseEvent! !

!HandMorph methodsFor: 'accessing' stamp: 'ar 9/25/2000 14:24'!
mouseOverHandler
	^mouseOverHandler ifNil:[mouseOverHandler _ MouseOverHandler new].! !

!HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'!
noButtonPressed
	"Answer whether any mouse button is not being pressed."

	^self anyButtonPressed not! !

!HandMorph methodsFor: 'accessing'!
targetOffset
	"Return the offset of the last mouseDown location relative to the origin of the recipient morph. During menu interactions, this is the absolute location of the mouse down event that invoked the menu."

	^ targetOffset
! !

!HandMorph methodsFor: 'accessing'!
userInitials

	^ userInitials! !

!HandMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 15:18'!
userPicture
	^self valueOfProperty: #remoteUserPicture

! !

!HandMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 15:34'!
userPicture: aFormOrNil
	^self setProperty: #remoteUserPicture toValue: aFormOrNil
! !


!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 16:49'!
balloonHelp
	"Return the balloon morph associated with this hand"
	^self valueOfProperty: #balloonHelpMorph! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 16:51'!
balloonHelp: aBalloonMorph
	"Return the balloon morph associated with this hand"
	| oldHelp |
	oldHelp _ self balloonHelp.
	oldHelp ifNotNil:[oldHelp delete].
	aBalloonMorph
		ifNil:[self removeProperty: #balloonHelpMorph]
		ifNotNil:[self setProperty: #balloonHelpMorph toValue: aBalloonMorph]! !

!HandMorph methodsFor: 'balloon help' stamp: 'sw 10/15/2002 20:01'!
deleteBalloonTarget: aMorph
	"Delete any existing balloon help.  This is now done unconditionally, whether or not the morph supplied is the same as the current balloon target"
	
	self balloonHelp: nil

"	| h |
	h _ self balloonHelp ifNil: [^ self].
	h balloonOwner == aMorph ifTrue: [self balloonHelp: nil]"! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/6/2000 00:14'!
removePendingBalloonFor: aMorph
	"Get rid of pending balloon help."
	self removeAlarm: #spawnBalloonFor:.
	self deleteBalloonTarget: aMorph.! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:15'!
spawnBalloonFor: aMorph
	aMorph showBalloon: aMorph balloonText hand: self.! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:14'!
triggerBalloonFor: aMorph after: timeOut
	"Trigger balloon help after the given time out for some morph"
	self addAlarm: #spawnBalloonFor: with: aMorph after: timeOut.! !


!HandMorph methodsFor: 'caching' stamp: 'ar 10/26/2000 15:28'!
releaseCachedState
	| oo ui |
	ui _ userInitials.
	super releaseCachedState.
	cacheCanvas _ nil.
	oo _ owner.
	self removeAllMorphs.
	self initialize.	"nuke everything"
	self privateOwner: oo.
	self releaseAllFoci.
	self userInitials: ui andPicture: (self userPicture).! !


!HandMorph methodsFor: 'change reporting' stamp: 'ar 12/30/2001 17:32'!
invalidRect: damageRect from: aMorph
	"Note that a change has occurred and record the given damage rectangle relative to the origin this hand's cache."
	hasChanged _ true.
	aMorph == self ifTrue:[^self].
	damageRecorder recordInvalidRect: damageRect.
! !


!HandMorph methodsFor: 'classification'!
isHandMorph

	^ true! !


!HandMorph methodsFor: 'copying' stamp: 'ar 10/6/2000 00:11'!
veryDeepCopyWith: deepCopier
	"Return self.  Do not copy hands this way."
	^ self! !


!HandMorph methodsFor: 'cursor' stamp: 'jwh 6/5/2000 07:38'!
cursorBounds

	^temporaryCursor 
		ifNil: [self position extent: NormalCursor extent]
		ifNotNil: [self position + temporaryCursorOffset extent: temporaryCursor extent]! !

!HandMorph methodsFor: 'cursor' stamp: 'di 3/6/1999 23:52'!
showTemporaryCursor: cursorOrNil
	"Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor."

	self showTemporaryCursor: cursorOrNil hotSpotOffset: 0@0
! !

!HandMorph methodsFor: 'cursor' stamp: 'JW 9/6/2005 23:12'!
showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset 
	"Set the temporary cursor to the given Form.
	If the argument is nil, revert to the normal hardware cursor."

	self changed.
	temporaryCursorOffset 
		ifNotNil: [bounds := bounds translateBy: temporaryCursorOffset negated].
	cursorOrNil isNil 
		ifTrue: [temporaryCursor := temporaryCursorOffset := hardwareCursor := nil]
		ifFalse: 
			[temporaryCursor := cursorOrNil asCursorForm.
			temporaryCursorOffset := temporaryCursor offset - hotSpotOffset.
			(cursorOrNil isKindOf: Cursor) ifTrue: [hardwareCursor := cursorOrNil]].
	bounds := self cursorBounds.
	self
		userInitials: userInitials andPicture: self userPicture;
		layoutChanged;
		changed! !

!HandMorph methodsFor: 'cursor' stamp: 'NS 2/17/2001 11:01'!
temporaryCursor
	^ temporaryCursor! !


!HandMorph methodsFor: 'double click support' stamp: 'ar 9/18/2000 17:16'!
resetClickState
	"Reset the double-click detection state to normal (i.e., not waiting for a double-click)."
	mouseClickState _ nil.! !

!HandMorph methodsFor: 'double click support' stamp: 'nk 7/26/2004 10:29'!
waitForClicksOrDrag: aMorph event: evt
	"Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks.
	This message is typically sent to the Hand by aMorph when it first receives a mouse-down event.
	The callback methods invoked on aMorph (which are passed a copy of evt) are:
		#click:	sent when the mouse button goes up within doubleClickTime.
		#doubleClick:	sent when the mouse goes up, down, and up again all within DoubleClickTime.
		#doubleClickTimeout:  sent when the mouse does not have a doubleClick within DoubleClickTime.
		#startDrag:	sent when the mouse moves more than 10 pixels from evt's position within DoubleClickTime.
	Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus,
	which is typically done by aMorph in its click:, doubleClick:, or drag: methods."
	
	^self waitForClicksOrDrag: aMorph event: evt selectors: #( #click: #doubleClick: #doubleClickTimeout: #startDrag:) threshold: 10
! !

!HandMorph methodsFor: 'double click support' stamp: 'nk 7/26/2004 10:32'!
waitForClicksOrDrag: aMorph event: evt selectors: clickAndDragSelectors threshold: threshold

	"Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks.
	This message is typically sent to the Hand by aMorph when it first receives a mouse-down event.
	The callback methods, named in clickAndDragSelectors and passed a copy of evt, are:
		1 	(click) sent when the mouse button goes up within doubleClickTime.
		2	(doubleClick) sent when the mouse goes up, down, and up again all within DoubleClickTime.
		3	(doubleClickTimeout) sent when the mouse does not have a doubleClick within DoubleClickTime.
		4	(startDrag) sent when the mouse moves more than threshold pixels from evt's position within DoubleClickTime.
	Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus,
	which is typically done by aMorph in its click:, doubleClick:, or drag: methods."
	
	mouseClickState _ 
		MouseClickState new
			client: aMorph 
			click: clickAndDragSelectors first 
			dblClick: clickAndDragSelectors second 
			dblClickTime: DoubleClickTime 
			dblClickTimeout: clickAndDragSelectors third
			drag: clickAndDragSelectors fourth 
			threshold: threshold 
			event: evt.
! !


!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:43'!
drawOn: aCanvas 
	"Draw the hand itself (i.e., the cursor)."

	| userPic |
	temporaryCursor isNil 
		ifTrue: [aCanvas paintImage: NormalCursor at: bounds topLeft]
		ifFalse: [aCanvas paintImage: temporaryCursor at: bounds topLeft].
	self hasUserInformation 
		ifTrue: 
			[aCanvas 
				drawString: userInitials
				at: self cursorBounds topRight + (0 @ 4)
				font: nil
				color: color.
			(userPic := self userPicture) ifNotNil: 
					[aCanvas paintImage: userPic at: self cursorBounds topRight + (0 @ 24)]]! !

!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:44'!
fullDrawOn: aCanvas 
	"A HandMorph has unusual drawing requirements:
		1. the hand itself (i.e., the cursor) appears in front of its submorphs
		2. morphs being held by the hand cast a shadow on the world/morphs below
	The illusion is that the hand plucks up morphs and carries them above the world."

	"Note: This version caches an image of the morphs being held by the hand for
	 better performance. This cache is invalidated if one of those morphs changes."

	| disableCaching subBnds roundCorners rounded |
	self visible ifFalse: [^self].
	(aCanvas isVisible: self fullBounds) ifFalse: [^self].
	disableCaching := false.
	disableCaching 
		ifTrue: 
			[self nonCachingFullDrawOn: aCanvas.
			^self].
	submorphs isEmpty 
		ifTrue: 
			[cacheCanvas := nil.
			^self drawOn: aCanvas].	"just draw the hand itself"
	subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]).
	self updateCacheCanvas: aCanvas.
	(cacheCanvas isNil 
		or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]]) 
			ifTrue: 
				["could not use caching due to translucency; do full draw"

				self nonCachingFullDrawOn: aCanvas.
				^self].

	"--> begin rounded corners hack <---"
	roundCorners := cachedCanvasHasHoles == false 
				and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]].
	roundCorners 
		ifTrue: 
			[rounded := submorphs first.
			aCanvas asShadowDrawingCanvas translateBy: self shadowOffset
				during: 
					[:shadowCanvas | 
					shadowCanvas roundCornersOf: rounded
						during: 
							[(subBnds areasOutside: (rounded boundsWithinCorners 
										translateBy: self shadowOffset negated)) 
								do: [:r | shadowCanvas fillRectangle: r color: Color black]]].
			aCanvas roundCornersOf: rounded
				during: 
					[aCanvas 
						drawImage: cacheCanvas form
						at: subBnds origin
						sourceRect: cacheCanvas form boundingBox].
			^self drawOn: aCanvas	"draw the hand itself in front of morphs"].
	"--> end rounded corners hack <---"

	"draw the shadow"
	aCanvas asShadowDrawingCanvas translateBy: self shadowOffset
		during: 
			[:shadowCanvas | 
			cachedCanvasHasHoles 
				ifTrue: 
					["Have to draw the real shadow of the form"

					shadowCanvas paintImage: cacheCanvas form at: subBnds origin]
				ifFalse: 
					["Much faster if only have to shade the edge of a solid rectangle"

					(subBnds areasOutside: (subBnds translateBy: self shadowOffset negated)) 
						do: [:r | shadowCanvas fillRectangle: r color: Color black]]].

	"draw morphs in front of the shadow using the cached Form"
	cachedCanvasHasHoles 
		ifTrue: [aCanvas paintImage: cacheCanvas form at: subBnds origin]
		ifFalse: 
			[aCanvas 
				drawImage: cacheCanvas form
				at: subBnds origin
				sourceRect: cacheCanvas form boundingBox].
	self drawOn: aCanvas	"draw the hand itself in front of morphs"! !

!HandMorph methodsFor: 'drawing' stamp: 'ls 4/3/2000 20:30'!
hasChanged
	"Return true if this hand has changed, either because it has moved or because some morph it is holding has changed."

	^ hasChanged ifNil: [ true ]
! !

!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:46'!
hasUserInformation
	^self userInitials notEmpty or: [self userPicture notNil]! !

!HandMorph methodsFor: 'drawing' stamp: 'JW 9/6/2005 23:28'!
needsToBeDrawn
	"Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden."
	"Details:  Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor and shadow from the display."
	| cursor |
	(savedPatch notNil
		or: [ (submorphs anySatisfy: [ :ea | ea visible ])
			or: [ (temporaryCursor notNil and: [hardwareCursor isNil])
				or: [ self hasUserInformation ]]])
		ifTrue: [
			"using the software cursor; hide the hardware one"
			Sensor currentCursor == Cursor blank ifFalse: [Cursor blank show].
			^ true].
	"Switch from one hardware cursor to another, if needed."
	cursor := hardwareCursor ifNil: [Cursor normal].
	Sensor currentCursor == cursor ifFalse: [cursor show].
	^ false
! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 2/18/2000 15:19'!
nonCachingFullDrawOn: aCanvas
	| shadowForm |
	"A HandMorph has unusual drawing requirements:
		1. the hand itself (i.e., the cursor) appears in front of its submorphs
		2. morphs being held by the hand cast a shadow on the world/morphs below
	The illusion is that the hand plucks up morphs and carries them above the world."
	"Note: This version does not cache an image of the morphs being held by the hand.
	 Thus, it is slower for complex morphs, but consumes less space."

	submorphs isEmpty ifTrue: [^ self drawOn: aCanvas].  "just draw the hand itself"
	aCanvas asShadowDrawingCanvas
		translateBy: self shadowOffset during:[:shadowCanvas|
		"Note: We use a shadow form here to prevent drawing
		overlapping morphs multiple times using the transparent
		shadow color."
		shadowForm _ self shadowForm.
"
shadowForm displayAt: shadowForm offset negated. Display forceToScreen: (0@0 extent: shadowForm extent).
"
		shadowCanvas paintImage: shadowForm at: shadowForm offset.  "draw shadows"
	].
	"draw morphs in front of shadows"
	self drawSubmorphsOn: aCanvas.
	self drawOn: aCanvas.  "draw the hand itself in front of morphs"
! !

!HandMorph methodsFor: 'drawing' stamp: 'JW 9/6/2005 23:10'!
restoreSavedPatchOn: aCanvas 
	"Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor."
	| cursor |

	hasChanged := false.
	savedPatch ifNotNil: 
			[aCanvas drawImage: savedPatch at: savedPatch offset.
			self hasUserInformation ifTrue: [^self].	"cannot use hw cursor if so"
			submorphs notEmpty ifTrue: [^self].
			(temporaryCursor notNil and: [hardwareCursor isNil]) ifTrue: [^self].

			"Make the transition to using hardware cursor. Clear savedPatch and
		 report one final damage rectangle to erase the image of the software cursor."
			super invalidRect: (savedPatch offset 
						extent: savedPatch extent + self shadowOffset)
				from: self.
			cursor := hardwareCursor ifNil: [Cursor normal].
			Sensor currentCursor == cursor ifFalse: [cursor show].	"show hardware cursor"
			savedPatch := nil]! !

!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'!
savePatchFrom: aCanvas 
	"Save the part of the given canvas under this hand as a Form and return its bounding rectangle."

	"Details: The previously used patch Form is recycled when possible to reduce the burden on storage management."

	| damageRect myBnds |
	damageRect := myBnds := self fullBounds.
	savedPatch ifNotNil: 
			[damageRect := myBnds merge: (savedPatch offset extent: savedPatch extent)].
	(savedPatch isNil or: [savedPatch extent ~= myBnds extent]) 
		ifTrue: 
			["allocate new patch form if needed"

			savedPatch := aCanvas form allocateForm: myBnds extent].
	aCanvas contentsOfArea: (myBnds translateBy: aCanvas origin)
		into: savedPatch.
	savedPatch offset: myBnds topLeft.
	^damageRect! !

!HandMorph methodsFor: 'drawing' stamp: 'JW 7/12/2005 20:13'!
shadowForm
	"Return a 1-bit shadow of my submorphs.  Assumes submorphs is not empty"
	| bnds canvas |
	bnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]).
	canvas := (Display defaultCanvasClass extent: bnds extent depth: 1) 
		asShadowDrawingCanvas: Color black.
	canvas translateBy: bnds topLeft negated
		during:[:tempCanvas| self drawSubmorphsOn: tempCanvas].
	^ canvas form offset: bnds topLeft! !

!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'!
updateCacheCanvas: aCanvas 
	"Update the cached image of the morphs being held by this hand."

	"Note: The following is an attempt to quickly get out if there's no change"

	| subBnds rectList nPix |
	subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]).
	rectList := damageRecorder invalidRectsFullBounds: subBnds.
	damageRecorder reset.
	(rectList isEmpty 
		and: [cacheCanvas notNil and: [cacheCanvas extent = subBnds extent]]) 
			ifTrue: [^self].

	"Always check for real translucency -- can't be cached in a form"
	self submorphsDo: 
			[:m | 
			m wantsToBeCachedByHand 
				ifFalse: 
					[cacheCanvas := nil.
					cachedCanvasHasHoles := true.
					^self]].
	(cacheCanvas isNil or: [cacheCanvas extent ~= subBnds extent]) 
		ifTrue: 
			[cacheCanvas := (aCanvas allocateForm: subBnds extent) getCanvas.
			cacheCanvas translateBy: subBnds origin negated
				during: [:tempCanvas | self drawSubmorphsOn: tempCanvas].
			self submorphsDo: 
					[:m | 
					(m areasRemainingToFill: subBnds) isEmpty 
						ifTrue: [^cachedCanvasHasHoles := false]].
			nPix := cacheCanvas form tallyPixelValues first.
			"--> begin rounded corners hack <---"
			cachedCanvasHasHoles := (nPix = 48 
						and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]]) 
							ifTrue: [false]
							ifFalse: [nPix > 0].
			"--> end rounded corners hack <---"
			^self].

	"incrementally update the cache canvas"
	cacheCanvas translateBy: subBnds origin negated
		during: 
			[:cc | 
			rectList do: 
					[:r | 
					cc clipBy: r
						during: 
							[:c | 
							c fillColor: Color transparent.
							self drawSubmorphsOn: c]]]! !

!HandMorph methodsFor: 'drawing' stamp: 'nk 10/24/2003 22:12'!
visible: aBoolean
	self needsToBeDrawn ifFalse: [ ^self ].
	super visible: aBoolean! !


!HandMorph methodsFor: 'drop shadows'!
shadowOffset

	^ 6@8! !


!HandMorph methodsFor: 'event handling' stamp: 'tpr 1/5/2005 17:34'!
checkForMoreKeyboard
	"Quick check for more keyboard activity -- Allows, eg, many characters
	to be accumulated into a single replacement during type-in."

	| evtBuf |
	self flag: #arNote.	"Will not work if we don't examine event queue in Sensor"
	evtBuf := Sensor peekKeyboardEvent.
	evtBuf ifNil: [^nil].
	^self generateKeyboardEvent: evtBuf! !

!HandMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:43'!
cursorPoint
	"Implemented for allowing embedded worlds in an event cycle to query a hand's position and get it in its coordinates. The same can be achieved by #point:from: but this is simply much more convenient since it will look as if the hand is in the lower world."

	| pos |
	pos := self position.
	(ActiveWorld isNil or: [ActiveWorld == owner]) ifTrue: [^pos].
	^ActiveWorld point: pos from: owner! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 23:17'!
flushEvents
	"Flush any events that may be pending"
	self flag: #arNote. "Remove it and fix senders"
	Sensor flushEvents.! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 9/25/2000 14:27'!
noticeMouseOver: aMorph event: anEvent
	mouseOverHandler ifNil:[^self].
	mouseOverHandler noticeMouseOver: aMorph event: anEvent.! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 20:08'!
pauseEventRecorderIn: aWorld
	"Suspend any recorder prior to a project change, and return it.
	It will be resumed after starting the new project."
	eventListeners ifNil:[^nil].
	eventListeners do:
		[:er | (er isKindOf: EventRecorderMorph) ifTrue: [^ er pauseIn: aWorld]].
	^ nil! !

!HandMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:48'!
processEvents
	"Process user input events from the local input devices."

	| evt evtBuf type hadAny |
	ActiveEvent ifNotNil: 
			["Meaning that we were invoked from within an event response.
		Make sure z-order is up to date"

			self mouseOverHandler processMouseOver: lastMouseEvent].
	hadAny := false.
	[(evtBuf := Sensor nextEvent) isNil] whileFalse: 
			[evt := nil.	"for unknown event types"
			type := evtBuf first.
			type = EventTypeMouse ifTrue: [evt := self generateMouseEvent: evtBuf].
			type = EventTypeKeyboard 
				ifTrue: [evt := self generateKeyboardEvent: evtBuf].
			type = EventTypeDragDropFiles 
				ifTrue: [evt := self generateDropFilesEvent: evtBuf].
			"All other events are ignored"
			(type ~= EventTypeDragDropFiles and: [evt isNil]) ifTrue: [^self].
			evt isNil 
				ifFalse: 
					["Finally, handle it"

					self handleEvent: evt.
					hadAny := true.

					"For better user feedback, return immediately after a mouse event has been processed."
					evt isMouse ifTrue: [^self]]].
	"note: if we come here we didn't have any mouse events"
	mouseClickState notNil 
		ifTrue: 
			["No mouse events during this cycle. Make sure click states time out accordingly"

			mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
	hadAny 
		ifFalse: 
			["No pending events. Make sure z-order is up to date"

			self mouseOverHandler processMouseOver: lastMouseEvent]! !


!HandMorph methodsFor: 'events-processing' stamp: 'nk 7/20/2003 10:02'!
handleEvent: anEvent
	| evt ofs |
	owner ifNil:[^self].
	evt _ anEvent.

	EventStats ifNil:[EventStats _ IdentityDictionary new].
	EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1.
	EventStats at: evt type put: (EventStats at: evt type ifAbsent:[0]) + 1.

	evt isMouseOver ifTrue:[^self sendMouseEvent: evt].

ShowEvents == true ifTrue:[
	Display fill: (0@0 extent: 250@120) rule: Form over fillColor: Color white.
	ofs _ (owner hands indexOf: self) - 1 * 60.
	evt printString displayAt: (0@ofs) + (evt isKeyboard ifTrue:[0@30] ifFalse:[0@0]).
	self keyboardFocus printString displayAt: (0@ofs)+(0@45).
].
	"Notify listeners"
	self sendListenEvent: evt to: self eventListeners.

	evt isKeyboard ifTrue:[
		self sendListenEvent: evt to: self keyboardListeners.
		self sendKeyboardEvent: evt.
		^self mouseOverHandler processMouseOver: lastMouseEvent].

	evt isDropEvent ifTrue:[
		self sendEvent: evt focus: nil.
		^self mouseOverHandler processMouseOver: lastMouseEvent].

	evt isMouse ifTrue:[
		self sendListenEvent: evt to: self mouseListeners.
		lastMouseEvent _ evt].

	"Check for pending drag or double click operations."
	mouseClickState ifNotNil:[
		(mouseClickState handleEvent: evt from: self) ifFalse:[
			"Possibly dispatched #click: or something and will not re-establish otherwise"
			^self mouseOverHandler processMouseOver: lastMouseEvent]].

	evt isMove ifTrue:[
		self position: evt position.
		self sendMouseEvent: evt.
	] ifFalse:[
		"Issue a synthetic move event if we're not at the position of the event"
		(evt position = self position) ifFalse:[self moveToEvent: evt].
		"Drop submorphs on button events"
		(self hasSubmorphs) 
			ifTrue:[self dropMorphs: evt]
			ifFalse:[self sendMouseEvent: evt].
	].
	ShowEvents == true ifTrue:[self mouseFocus printString displayAt: (0@ofs) + (0@15)].
	self mouseOverHandler processMouseOver: lastMouseEvent.
! !

!HandMorph methodsFor: 'events-processing' stamp: 'nk 2/15/2004 09:01'!
isCapturingGesturePoints
	^false! !


!HandMorph methodsFor: 'focus handling' stamp: 'yo 11/7/2002 19:10'!
compositionWindowManager

	^ self class compositionWindowManager.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'!
keyboardFocus 
	^ keyboardFocus! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:30'!
keyboardFocus: aMorphOrNil
	keyboardFocus _ aMorphOrNil! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'!
mouseFocus
	^mouseFocus! !

!HandMorph methodsFor: 'focus handling' stamp: 'nk 2/14/2004 18:44'!
mouseFocus: aMorphOrNil
	mouseFocus _ aMorphOrNil! !

!HandMorph methodsFor: 'focus handling' stamp: 'yo 11/7/2002 19:11'!
newKeyboardFocus: aMorphOrNil
	"Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled."
	| oldFocus |
	oldFocus _ self keyboardFocus.
	self keyboardFocus: aMorphOrNil.
	oldFocus ifNotNil: [oldFocus == aMorphOrNil ifFalse: [oldFocus keyboardFocusChange: false]].
	aMorphOrNil ifNotNil: [aMorphOrNil keyboardFocusChange: true. self compositionWindowManager keyboardFocusForAMorph: aMorphOrNil].
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:32'!
newMouseFocus: aMorphOrNil
	"Make the given morph the new mouse focus, canceling the previous mouse focus if any. If the argument is nil, the current mouse focus is cancelled."
	self mouseFocus: aMorphOrNil.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'dgd 2/21/2003 22:48'!
newMouseFocus: aMorph event: event 
	aMorph isNil 
		ifFalse: [targetOffset := event cursorPoint - aMorph position].
	^self newMouseFocus: aMorph! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'!
releaseAllFoci
	mouseFocus _ nil.
	keyboardFocus _ nil.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'!
releaseKeyboardFocus
	"Release the current keyboard focus unconditionally"
	self newKeyboardFocus: nil.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:31'!
releaseKeyboardFocus: aMorph
	"If the given morph had the keyboard focus before, release it"
	self keyboardFocus == aMorph ifTrue:[self releaseKeyboardFocus].! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'!
releaseMouseFocus
	"Release the current mouse focus unconditionally."
	self newMouseFocus: nil.! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'!
releaseMouseFocus: aMorph
	"If the given morph had the mouse focus before, release it"
	self mouseFocus == aMorph ifTrue:[self releaseMouseFocus].! !


!HandMorph methodsFor: 'genie-stubs' stamp: 'nk 3/10/2004 10:06'!
autoFocusRectangleBoundsFor: aMorph
	^aMorph bounds! !

!HandMorph methodsFor: 'genie-stubs' stamp: 'nk 3/10/2004 10:15'!
disableGenieFocus
! !

!HandMorph methodsFor: 'genie-stubs' stamp: 'nk 3/11/2004 17:47'!
enableGenie
	self error: 'Genie is not available for this hand'.! !

!HandMorph methodsFor: 'genie-stubs' stamp: 'nk 3/11/2004 17:44'!
focusStartEvent
	^nil! !

!HandMorph methodsFor: 'genie-stubs' stamp: 'nk 3/10/2004 10:06'!
genieGestureProcessor
	^nil! !

!HandMorph methodsFor: 'genie-stubs' stamp: 'nk 3/11/2004 17:45'!
isGenieAvailable
	"Answer whether the Genie gesture recognizer is available for this hand"
	^false! !

!HandMorph methodsFor: 'genie-stubs' stamp: 'nk 3/11/2004 17:46'!
isGenieEnabled
	"Answer whether the Genie gesture recognizer is enabled for this hand"
	^false! !

!HandMorph methodsFor: 'genie-stubs' stamp: 'nk 3/11/2004 17:46'!
isGenieFocused
	"Answer whether the Genie gesture recognizer is auto-focused for this hand"
	^false! !


!HandMorph methodsFor: 'geometry' stamp: 'ar 3/20/2001 20:34'!
position

	^temporaryCursor
		ifNil: [bounds topLeft]
		ifNotNil: [bounds topLeft - temporaryCursorOffset]! !

!HandMorph methodsFor: 'geometry' stamp: 'nk 8/20/2003 17:39'!
position: aPoint
	"Overridden to align submorph origins to the grid if gridding is on."
	| adjustedPosition delta box |
	adjustedPosition := aPoint.
	temporaryCursor ifNotNil: [adjustedPosition := adjustedPosition + temporaryCursorOffset].

	"Copied from Morph to avoid owner layoutChanged"
	"Change the position of this morph and and all of its submorphs."
	delta _ adjustedPosition - bounds topLeft.
	(delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"
	box _ self fullBounds.
	(delta dotProduct: delta) > 100 ifTrue:[
		"e.g., more than 10 pixels moved"
		self invalidRect: box.
		self invalidRect: (box translateBy: delta).
	] ifFalse:[
		self invalidRect: (box merge: (box translateBy: delta)).
	].
	self privateFullMoveBy: delta.
! !

!HandMorph methodsFor: 'geometry' stamp: 'ar 12/30/2001 20:44'!
userInitials: aString andPicture: aForm

	| cb pictRect initRect f |

	userInitials _ aString.
	pictRect _ initRect _ cb _ self cursorBounds.
	userInitials isEmpty ifFalse: [
		f _ TextStyle defaultFont.
		initRect _ cb topRight + (0@4) extent: (f widthOfString: userInitials)@(f height).
	].
	self userPicture: aForm.
	aForm ifNotNil: [
		pictRect _ (self cursorBounds topRight + (0@24)) extent: aForm extent.
	].
	self bounds: ((cb merge: initRect) merge: pictRect).


! !


!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/8/2000 23:42'!
attachMorph: m
	"Position the center of the given morph under this hand, then grab it.
	This method is used to grab far away or newly created morphs."
	| delta |
	self releaseMouseFocus. "Break focus"
	delta _ m bounds extent // 2.
	m position: (self position - delta).
	m formerPosition: m position.
	targetOffset _ m position - self position.
	self addMorphBack: m.! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/5/2000 16:23'!
dropMorphs
	"Drop the morphs at the hands position"
	self dropMorphs: lastMouseEvent.! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 9/14/2000 11:22'!
dropMorphs: anEvent
	"Drop the morphs at the hands position"
	self submorphsReverseDo:[:m|
		"Drop back to front to maintain z-order"
		self dropMorph: m event: anEvent.
	].! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 8/13/2003 11:39'!
dropMorph: aMorph event: anEvent
	"Drop the given morph which was carried by the hand"
	| event dropped |
	(anEvent isMouseUp and:[aMorph shouldDropOnMouseUp not]) ifTrue:[^self].

	"Note: For robustness in drag and drop handling we remove the morph BEFORE we drop him, but we keep his owner set to the hand. This prevents system lockups when there is a problem in drop handling (for example if there's an error in #wantsToBeDroppedInto:). THIS TECHNIQUE IS NOT RECOMMENDED FOR CASUAL USE."
	self privateRemove: aMorph.
	aMorph privateOwner: self.

	dropped _ aMorph.
	(dropped hasProperty: #addedFlexAtGrab) 
		ifTrue:[dropped _ aMorph removeFlexShell].
	event _ DropEvent new setPosition: self position contents: dropped hand: self.
	self sendEvent: event focus: nil.
	event wasHandled ifFalse:[aMorph rejectDropMorphEvent: event].
	aMorph owner == self ifTrue:[aMorph delete].
	self mouseOverHandler processMouseOver: anEvent.! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 4/23/2001 15:17'!
grabMorph: aMorph from: formerOwner
	"Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand."

	| grabbed offset targetPoint grabTransform fullTransform |
	self releaseMouseFocus. "Break focus"
	grabbed _ aMorph.
	aMorph keepsTransform ifTrue:[
		grabTransform _ fullTransform _ IdentityTransform new.
	] ifFalse:[
		"Compute the transform to apply to the grabbed morph"
		grabTransform _ formerOwner 
			ifNil:		[IdentityTransform new] 
			ifNotNil:	[formerOwner grabTransform].
		"Compute the full transform for the grabbed morph"
		fullTransform _ formerOwner 
			ifNil:		[IdentityTransform new] 
			ifNotNil:	[formerOwner transformFrom: owner].
	].
	"targetPoint is point in aMorphs reference frame"
	targetPoint _ fullTransform globalPointToLocal: self position.
	"but current position will be determined by grabTransform, so compute offset"
	offset _ targetPoint - (grabTransform globalPointToLocal: self position).
	"apply the transform that should be used after grabbing"
	grabbed _ grabbed transformedBy: grabTransform.
	grabbed == aMorph 
		ifFalse:	[grabbed setProperty: #addedFlexAtGrab toValue: true].
	"offset target to compensate for differences in transforms"
	grabbed position: grabbed position - offset asIntegerPoint.
	"And compute distance from hand's position"
	targetOffset _ grabbed position - self position.
	self addMorphBack: grabbed.
	grabbed justGrabbedFrom: formerOwner.! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'di 10/16/2000 10:46'!
targetOffset: offsetPoint
	"Set the offset at which we clicked down in the target morph"

	targetOffset _ offsetPoint! !


!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/4/2000 13:40'!
halo: newHalo
	"Set halo associated with this hand"
	| oldHalo |
	oldHalo _ self halo.
	(oldHalo isNil or:[oldHalo == newHalo]) ifFalse:[oldHalo delete].
	newHalo
		ifNil:[self removeProperty: #halo]
		ifNotNil:[self setProperty: #halo toValue: newHalo]! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/24/2000 18:40'!
obtainHalo: aHalo
	"Used for transfering halos between hands"
	| formerOwner |
	self halo == aHalo ifTrue:[^self].
	"Find former owner"
	formerOwner _ self world hands detect:[:h| h halo == aHalo] ifNone:[nil].
	formerOwner ifNotNil:[formerOwner releaseHalo: aHalo].
	self halo: aHalo! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/24/2000 18:40'!
releaseHalo: aHalo
	"Used for transfering halos between hands"
	self removeProperty: #halo! !

!HandMorph methodsFor: 'halo handling' stamp: 'dgd 4/4/2006 16:14'!
removeHalo
	"remove the receiver's halo (if any)"
	| halo |
	halo := self halo.
	halo
		ifNil: [^ self].
	halo delete.
	self removeProperty: #halo! !

!HandMorph methodsFor: 'halo handling' stamp: 'dgd 9/9/2004 22:44'!
removeHaloFromClick: anEvent on: aMorph 
	| halo |
	halo := self halo
				ifNil: [^ self].
	(halo target hasOwner: self)
		ifTrue: [^ self].
	(halo staysUpWhenMouseIsDownIn: aMorph)
		ifFalse: [self removeHalo]! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:49'!
removePendingHaloFor: aMorph
	"Get rid of pending balloon help or halo actions."
	self removeAlarm: #spawnMagicHaloFor:.! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:50'!
spawnMagicHaloFor: aMorph
	(self halo notNil and:[self halo target == aMorph]) ifTrue:[^self].
	aMorph addMagicHaloFor: self.! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:51'!
triggerHaloFor: aMorph after: timeOut
	"Trigger automatic halo after the given time out for some morph"
	self addAlarm: #spawnMagicHaloFor: with: aMorph after: timeOut! !


!HandMorph methodsFor: 'halos and balloon help' stamp: 'ar 10/4/2000 13:40'!
halo
	"Return the halo associated with this hand, if any"
	^self valueOfProperty: #halo! !


!HandMorph methodsFor: 'initialization' stamp: 'tk 8/9/2001 16:55'!
initForEvents
	mouseOverHandler _ nil.
	lastMouseEvent _ MouseEvent new setType: #mouseMove position: 0@0 buttons: 0 hand: self.
	lastEventBuffer _ {1. 0. 0. 0. 0. 0. nil. nil}.
	self resetClickState.! !

!HandMorph methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:58'!
initialize
	super initialize.
	self initForEvents.
	keyboardFocus _ nil.
	mouseFocus _ nil.
	bounds _ 0@0 extent: Cursor normal extent.
	userInitials _ ''.
	damageRecorder _ DamageRecorder new.
	cachedCanvasHasHoles _ false.
	temporaryCursor _ temporaryCursorOffset _ nil.
	self initForEvents.! !

!HandMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:28'!
interrupted
	"Something went wrong - we're about to bring up a debugger. 
	Release some stuff that could be problematic."
	self releaseAllFoci. "or else debugger might not handle clicks"
! !

!HandMorph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:27'!
resourceJustLoaded
	"In case resource relates to me"
	cacheCanvas _ nil.! !


!HandMorph methodsFor: 'layout' stamp: 'jm 2/20/98 18:55'!
fullBounds
	"Extend my bounds by the shadow offset when carrying morphs."

	| bnds |
	bnds _ super fullBounds.
	submorphs isEmpty
		ifTrue: [^ bnds ]
		ifFalse: [^ bnds topLeft corner: bnds bottomRight + self shadowOffset].
! !


!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:43'!
addEventListener: anObject
	"Make anObject a listener for all events. All events will be reported to the object."
	self eventListeners: (self addListener: anObject to: self eventListeners)! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:42'!
addKeyboardListener: anObject
	"Make anObject a listener for keyboard events. All keyboard events will be reported to the object."
	self keyboardListeners: (self addListener: anObject to: self keyboardListeners)! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:40'!
addListener: anObject to: aListenerGroup
	"Add anObject to the given listener group. Return the new group."
	| listeners |
	listeners _ aListenerGroup.
	(listeners notNil and:[listeners includes: anObject]) ifFalse:[
		listeners
			ifNil:[listeners _ WeakArray with: anObject]
			ifNotNil:[listeners _ listeners copyWith: anObject]].
	listeners _ listeners copyWithout: nil. "obsolete entries"
	^listeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:42'!
addMouseListener: anObject
	"Make anObject a listener for mouse events. All mouse events will be reported to the object."
	self mouseListeners: (self addListener: anObject to: self mouseListeners)! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'!
eventListeners
	^eventListeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'!
eventListeners: anArrayOrNil
	eventListeners _ anArrayOrNil! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'!
keyboardListeners
	^keyboardListeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'!
keyboardListeners: anArrayOrNil
	keyboardListeners _ anArrayOrNil! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'!
mouseListeners
	^mouseListeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'!
mouseListeners: anArrayOrNil
	mouseListeners _ anArrayOrNil! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'!
removeEventListener: anObject
	"Remove anObject from the current event listeners."
	self eventListeners: (self removeListener: anObject from: self eventListeners).! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'!
removeKeyboardListener: anObject
	"Remove anObject from the current keyboard listeners."
	self keyboardListeners: (self removeListener: anObject from: self keyboardListeners).! !

!HandMorph methodsFor: 'listeners' stamp: 'dgd 2/21/2003 22:48'!
removeListener: anObject from: aListenerGroup 
	"Remove anObject from the given listener group. Return the new group."

	| listeners |
	aListenerGroup ifNil: [^nil].
	listeners := aListenerGroup.
	listeners := listeners copyWithout: anObject.
	listeners := listeners copyWithout: nil.	"obsolete entries"
	listeners isEmpty ifTrue: [listeners := nil].
	^listeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'!
removeMouseListener: anObject
	"Remove anObject from the current mouse listeners."
	self mouseListeners: (self removeListener: anObject from: self mouseListeners).! !


!HandMorph methodsFor: 'meta-actions' stamp: 'ar 11/6/2000 13:07'!
copyToPasteBuffer: aMorph
	"Save this morph in the paste buffer. This is mostly useful for copying morphs between projects."
	aMorph ifNil:[^PasteBuffer _ nil].
	Cursor wait showWhile:[
		PasteBuffer _ aMorph topRendererOrSelf veryDeepCopy.
		PasteBuffer privateOwner: nil].

! !

!HandMorph methodsFor: 'meta-actions' stamp: 'ar 11/21/2000 17:42'!
grabMorph: aMorph
	"Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand."
	| grabbed |
	self releaseMouseFocus. "Break focus"
	grabbed _ aMorph aboutToBeGrabbedBy: self.
	grabbed ifNil:[^self].
	grabbed _ grabbed topRendererOrSelf.
	^self grabMorph: grabbed from: grabbed owner! !


!HandMorph methodsFor: 'multilingual' stamp: 'yo 9/26/2003 22:11'!
clearKeyboardInterpreter

	keyboardInterpreter _ nil.
! !

!HandMorph methodsFor: 'multilingual' stamp: 'yo 7/28/2004 21:35'!
keyboardInterpreter

	^keyboardInterpreter ifNil: [keyboardInterpreter _ LanguageEnvironment currentPlatform class defaultInputInterpreter]! !


!HandMorph methodsFor: 'objects from disk' stamp: 'ar 10/5/2000 19:48'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	(refStrm project world hands includes: self) ifTrue: [
		^ self].	"owned by the project"
	dp _ DiskProxy global: #World selector: #primaryHand args: #().
	refStrm replace: self with: dp.
	^ dp
	"Note, when this file is loaded in an MVC project, this will return nil.  The MenuItemMorph that has this in a field will have that item not work.  Maybe warn the user at load time?"! !


!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'!
objectToPaste
	"It may need to be sent #startRunning by the client"
	^ Cursor wait showWhile: [PasteBuffer veryDeepCopy]

	"PasteBuffer usableDuplicateIn: self world"
! !

!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'!
pasteBuffer
	"Return the paste buffer associated with this hand"
	^ PasteBuffer! !

!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:11'!
pasteBuffer: aMorphOrNil
	"Set the contents of the paste buffer."
	PasteBuffer _ aMorphOrNil.

! !

!HandMorph methodsFor: 'paste buffer' stamp: 'dgd 9/19/2004 13:49'!
pasteMorph

	| aPastee |
	PasteBuffer ifNil: [^ self inform: 'Nothing to paste.' translated].
	self attachMorph: (aPastee _ self objectToPaste).
	aPastee align: aPastee center with: self position.
	aPastee player ifNotNil: [aPastee player startRunning]
! !


!HandMorph methodsFor: 'updating' stamp: 'jm 2/20/98 19:54'!
changed

	hasChanged _ true.
! !


!HandMorph methodsFor: '*eToys-pen' stamp: 'di 9/10/1998 16:20'!
trailMorph
	"You can't draw trails when picked up by the hand."
	^ nil! !


!HandMorph methodsFor: '*eToys-scripting' stamp: 'ar 3/17/2001 20:11'!
adaptedToWorld: aWorld
	"If I refer to a world or a hand, return the corresponding items in the new world."
	^aWorld primaryHand! !


!HandMorph methodsFor: 'private events' stamp: 'dgd 3/31/2003 18:22'!
generateDropFilesEvent: evtBuf 
	"Generate the appropriate mouse event for the given raw event buffer"

	"Note: This is still in an experimental phase and will need more work"

	| position buttons modifiers stamp numFiles dragType |
	stamp := evtBuf second.
	stamp = 0 ifTrue: [stamp := Time millisecondClockValue].
	dragType := evtBuf third.
	position := evtBuf fourth @ evtBuf fifth.
	buttons := 0.
	modifiers := evtBuf sixth.
	buttons := buttons bitOr: (modifiers bitShift: 3).
	numFiles := evtBuf seventh.
	dragType = 4 
		ifTrue: 
			["e.g., drop"

			owner borderWidth: 0.
			^DropFilesEvent new 
				setPosition: position
				contents: numFiles
				hand: self].
	"the others are currently not handled by morphs themselves"
	dragType = 1 
		ifTrue: 
			["experimental drag enter"

			owner
				borderWidth: 4;
				borderColor: owner color asColor negated].
	dragType = 2 
		ifTrue: 
			["experimental drag move"

			].
	dragType = 3 
		ifTrue: 
			["experimental drag leave"

			owner borderWidth: 0].
	^nil! !

!HandMorph methodsFor: 'private events' stamp: 'yo 7/25/2003 16:56'!
generateKeyboardEvent: evtBuf
	"Generate the appropriate mouse event for the given raw event buffer"

	| buttons modifiers type pressType stamp char |
	stamp := evtBuf second.
	stamp = 0 ifTrue: [stamp := Time millisecondClockValue].
	pressType := evtBuf fourth.
	pressType = EventKeyDown ifTrue: [type := #keyDown].
	pressType = EventKeyUp ifTrue: [type := #keyUp].
	pressType = EventKeyChar ifTrue: [type := #keystroke].
	modifiers := evtBuf fifth.
	buttons := modifiers bitShift: 3.
	char _ self keyboardInterpreter nextCharFrom: Sensor firstEvt: evtBuf.
	^ KeyboardEvent new
		setType: type
		buttons: buttons
		position: self position
		keyValue: char asciiValue
		hand: self
		stamp: stamp.
! !

!HandMorph methodsFor: 'private events' stamp: 'efc 8/18/2003 18:40'!
generateMouseEvent: evtBuf 
	"Generate the appropriate mouse event for the given raw event buffer"

	| position buttons modifiers type trail stamp oldButtons evtChanged |
	evtBuf first = lastEventBuffer first 
		ifTrue: 
			["Workaround for Mac VM bug, *always* generating 3 events on clicks"

			evtChanged := false.
			3 to: evtBuf size
				do: [:i | (lastEventBuffer at: i) = (evtBuf at: i) ifFalse: [evtChanged := true]].
			evtChanged ifFalse: [^nil]].
	stamp := evtBuf second.
	stamp = 0 ifTrue: [stamp := Time millisecondClockValue].
	position := evtBuf third @ evtBuf fourth.
	buttons := evtBuf fifth.
	modifiers := evtBuf sixth.
	type := buttons = 0 
		ifTrue: 
			[lastEventBuffer fifth = 0 ifTrue: [#mouseMove] ifFalse: [#mouseUp]]
		ifFalse: 
			[lastEventBuffer fifth = 0 
						ifTrue: [#mouseDown]
						ifFalse: [#mouseMove]].
	buttons := buttons bitOr: (modifiers bitShift: 3).
	oldButtons := lastEventBuffer fifth 
				bitOr: (lastEventBuffer sixth bitShift: 3).
	lastEventBuffer := evtBuf.
	type == #mouseMove 
		ifTrue: 
			[trail := self mouseTrailFrom: evtBuf.
			^MouseMoveEvent new 
				setType: type
				startPoint: (self position)
				endPoint: trail last
				trail: trail
				buttons: buttons
				hand: self
				stamp: stamp].
	^MouseButtonEvent new 
		setType: type
		position: position
		which: (oldButtons bitXor: buttons)
		buttons: buttons
		hand: self
		stamp: stamp! !

!HandMorph methodsFor: 'private events' stamp: 'dgd 2/22/2003 14:58'!
mouseTrailFrom: currentBuf 
	"Current event, a mouse event buffer, is about to be processed.  If there are other similar mouse events queued up, then drop them from the queue, and report the positions inbetween."

	| nextEvent trail |
	trail := WriteStream on: (Array new: 1).
	trail nextPut: currentBuf third @ currentBuf fourth.
	[(nextEvent := Sensor peekEvent) isNil] whileFalse: 
			[nextEvent first = currentBuf first 
				ifFalse: [^trail contents	"different event type"].
			nextEvent fifth = currentBuf fifth 
				ifFalse: [^trail contents	"buttons changed"].
			nextEvent sixth = currentBuf sixth 
				ifFalse: [^trail contents	"modifiers changed"].
			"nextEvent is similar.  Remove it from the queue, and check the next."
			nextEvent := Sensor nextEvent.
			trail nextPut: nextEvent third @ nextEvent fourth].
	^trail contents! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/6/2000 00:08'!
moveToEvent: anEvent
	"Issue a mouse move event to make the receiver appear at the given position"
	self handleEvent: (MouseMoveEvent new
		setType: #mouseMove 
		startPoint: self position 
		endPoint: anEvent position 
		trail: (Array with: self position with: anEvent position)
		buttons: anEvent buttons
		hand: self
		stamp: anEvent timeStamp)! !

!HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:43'!
sendEvent: anEvent focus: focusHolder
	"Send the event to the morph currently holding the focus, or if none to the owner of the hand."
	^self sendEvent: anEvent focus: focusHolder clear:[nil]! !

!HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:42'!
sendEvent: anEvent focus: focusHolder clear: aBlock
	"Send the event to the morph currently holding the focus, or if none to the owner of the hand."
	| result |
	focusHolder ifNotNil:[^self sendFocusEvent: anEvent to: focusHolder clear: aBlock].
	ActiveEvent _ anEvent.
	result _ owner processEvent: anEvent.
	ActiveEvent _ nil.
	^result! !

!HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:42'!
sendFocusEvent: anEvent to: focusHolder clear: aBlock
	"Send the event to the morph currently holding the focus"
	| result w |
	w _ focusHolder world ifNil:[^ aBlock value].
	w becomeActiveDuring:[
		ActiveHand _ self.
		ActiveEvent _ anEvent.
		result _ focusHolder handleFocusEvent: 
			(anEvent transformedBy: (focusHolder transformedFrom: self)).
	].
	^result! !

!HandMorph methodsFor: 'private events' stamp: 'rr 3/9/2006 15:36'!
sendKeyboardEvent: anEvent 
	"Send the event to the morph currently holding the focus, or if none to
	the owner of the hand."
	ServiceShortcuts handleKeystroke: anEvent.
	^ self
		sendEvent: anEvent
		focus: self keyboardFocus
		clear: [self keyboardFocus: nil]! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/26/2000 01:43'!
sendListenEvent: anEvent to: listenerGroup
	"Send the event to the given group of listeners"
	listenerGroup ifNil:[^self].
	listenerGroup do:[:listener| 
		listener ifNotNil:[listener handleListenEvent: anEvent copy]].! !

!HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:45'!
sendMouseEvent: anEvent
	"Send the event to the morph currently holding the focus, or if none to the owner of the hand."
	^self sendEvent: anEvent focus: self mouseFocus clear:[self mouseFocus: nil]! !


!HandMorph methodsFor: 'selected object' stamp: 'dgd 8/28/2004 16:30'!
selectedObject
	"answer the selected object for the hand or nil is none"
	| halo |
	halo := self halo.
	halo isNil
		ifTrue: [^ nil].
	^ halo target renderedMorph! !


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

HandMorph class
	instanceVariableNames: ''!

!HandMorph class methodsFor: 'accessing' stamp: 'nk 7/30/2004 21:39'!
compositionWindowManager
	CompositionWindowManager ifNotNil: [^CompositionWindowManager].
	SmalltalkImage current  platformName = 'Win32' 
		ifTrue: [^CompositionWindowManager := ImmWin32 new].
	(SmalltalkImage current  platformName = 'unix' 
		and: [(SmalltalkImage current  getSystemAttribute: 1005) = 'X11']) 
			ifTrue: [^CompositionWindowManager := ImmX11 new].
	^CompositionWindowManager := ImmAbstractPlatform new! !

!HandMorph class methodsFor: 'accessing'!
doubleClickTime

	^ DoubleClickTime
! !

!HandMorph class methodsFor: 'accessing'!
doubleClickTime: milliseconds

	DoubleClickTime _ milliseconds.
! !


!HandMorph class methodsFor: 'class initialization' stamp: 'kfr 7/13/2003 14:15'!
initialize
	"HandMorph initialize"

	PasteBuffer _ nil.
	DoubleClickTime _ 350.
	NormalCursor _ CursorWithMask normal asCursorForm.
! !


!HandMorph class methodsFor: 'initialization' stamp: 'yo 8/13/2003 15:49'!
clearCompositionWindowManager

	CompositionWindowManager _ nil.
! !

!HandMorph class methodsFor: 'initialization' stamp: 'yo 8/13/2003 15:45'!
clearInterpreters

	self allInstances do: [:each | each clearKeyboardInterpreter].
! !

!HandMorph class methodsFor: 'initialization' stamp: 'yo 8/13/2003 15:49'!
startUp

	self clearCompositionWindowManager.
	self clearInterpreters.
! !


!HandMorph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !


!HandMorph class methodsFor: 'utilities' stamp: 'sma 4/30/2000 10:34'!
attach: aMorph
	"Attach aMorph the current world's primary hand."

	self currentWorld primaryHand attachMorph: aMorph! !

!HandMorph class methodsFor: 'utilities' stamp: 'ar 9/17/2000 17:02'!
newEventRules: aBool
	NewEventRules _ aBool.! !

!HandMorph class methodsFor: 'utilities' stamp: 'nk 7/20/2003 10:03'!
showEvents: aBool
	"HandMorph showEvents: true"
	"HandMorph showEvents: false"
	ShowEvents _ aBool.
	aBool ifFalse: [ ActiveWorld invalidRect: (0@0 extent: 250@120) ].! !
HandMorph subclass: #HandMorphForReplay
	instanceVariableNames: 'recorder'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalSupport'!
!HandMorphForReplay commentStamp: '<historical>' prior: 0!
I am a hand for replaying events stored in an EventRecorderMorph.  When there are no more events, I delete myself.!


!HandMorphForReplay methodsFor: 'copying' stamp: 'LC 12/23/1998 13:26'!
veryDeepCopyWith: deepCopier
	^ self copy! !


!HandMorphForReplay methodsFor: 'cursor' stamp: 'di 3/7/1999 00:00'!
showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset
	"When I show my cursor, it appears double size,
	unless it is a form such as a paint brush."

	cursorOrNil
	ifNil: ["Setting cursor to nil cannot revert to hardware cursor -- just show normal."
			^ self showTemporaryCursor: Cursor normal hotSpotOffset: Cursor normal offset]
	ifNotNil:
		[(cursorOrNil isKindOf: Cursor)
			ifTrue: ["Show cursors magnified for visibility"
					^ super showTemporaryCursor:
									(CursorWithMask derivedFrom: (cursorOrNil magnifyBy: 2))
				 				hotSpotOffset: (cursorOrNil offset negated*2) + hotSpotOffset]
			ifFalse: [^ super showTemporaryCursor: cursorOrNil
				 				hotSpotOffset: hotSpotOffset]]! !


!HandMorphForReplay methodsFor: 'drawing' stamp: 'RAA 12/12/2000 14:45'!
needsToBeDrawn

	^true! !


!HandMorphForReplay methodsFor: 'event handling' stamp: 'di 3/4/1999 14:57'!
pauseEventRecorderIn: aWorld
	"Suspend my recorder prior to a project change, and return it.
	It will be resumed after starting the new project."

	^ recorder pauseIn: aWorld! !

!HandMorphForReplay methodsFor: 'event handling' stamp: 'dgd 2/22/2003 13:25'!
processEvents
	"Play back the next event"

	| evt hadMouse hadAny |
	hadMouse := hadAny := false.
	[(evt := recorder nextEventToPlay) isNil] whileFalse: 
			[evt type == #EOF 
				ifTrue: 
					[recorder pauseIn: self world.
					^self].
			evt type == #startSound 
				ifTrue: 
					[evt argument play.
					recorder synchronize.
					^self].
			evt isMouse ifTrue: [hadMouse := true].
			(evt isMouse or: [evt isKeyboard]) 
				ifTrue: 
					[self handleEvent: (evt setHand: self) resetHandlerFields.
					hadAny := true]].
	(mouseClickState notNil and: [hadMouse not]) 
		ifTrue: 
			["No mouse events during this cycle. Make sure click states time out accordingly"

			mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
	hadAny 
		ifFalse: 
			["No pending events. Make sure z-order is up to date"

			self mouseOverHandler processMouseOver: lastMouseEvent]! !


!HandMorphForReplay methodsFor: 'initialization' stamp: 'ar 10/25/2000 20:58'!
initialize
	super initialize.
	self showTemporaryCursor: Cursor normal.
! !

!HandMorphForReplay methodsFor: 'initialization' stamp: 'di 3/3/1999 14:54'!
recorder: anEventRecorder
	recorder _ anEventRecorder! !
EllipseMorph subclass: #HandleMorph
	instanceVariableNames: 'pointBlock lastPointBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!HandleMorph commentStamp: '<historical>' prior: 0!
A HandleMorph provides mouse-up control behavior.!


!HandleMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 9/10/2004 13:40'!
justDroppedInto: aMorph event: anEvent
	"So that when the hand drops me (into the world) I go away"
	self removeHalo.
	lastPointBlock ifNotNil: [lastPointBlock value: self center].
	self flag: #arNote. "Probably unnecessary"
	anEvent hand releaseKeyboardFocus: self.
	self changed.
	self delete.
! !


!HandleMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:30'!
keyStroke: evt
	"Check for cursor keys"
	| keyValue |
	owner isHandMorph ifFalse:[^self].
	keyValue _ evt keyValue.
	keyValue = 28 ifTrue:[^self position: self position - (1@0)].
	keyValue = 29 ifTrue:[^self position: self position + (1@0)].
	keyValue = 30 ifTrue:[^self position: self position - (0@1)].
	keyValue = 31 ifTrue:[^self position: self position + (0@1)].
	"Special case for return"
	keyValue = 13 ifTrue:[
		"Drop the receiver and be done"
	self flag: #arNote. "Probably unnecessary"
		owner releaseKeyboardFocus: self.
		self delete].
! !


!HandleMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:30'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: 8 @ 8.
	! !


!HandleMorph methodsFor: 'initialize' stamp: 'di 11/3/97 16:34'!
forEachPointDo: aBlock
	pointBlock _ aBlock! !

!HandleMorph methodsFor: 'initialize' stamp: 'di 8/30/2000 21:48'!
forEachPointDo: aBlock lastPointDo: otherBlock
	pointBlock _ aBlock.
	lastPointBlock _ otherBlock! !


!HandleMorph methodsFor: 'stepping and presenter' stamp: 'ar 9/15/2000 23:24'!
startStepping
	"Make the receiver the keyboard focus for editing"
	super startStepping.
	"owner isHandMorph ifTrue:[owner newKeyboardFocus: self]."
self flag: #arNote. "make me #handleKeyboard:"! !

!HandleMorph methodsFor: 'stepping and presenter' stamp: 'di 11/3/97 16:34'!
step
	pointBlock value: self center! !


!HandleMorph methodsFor: 'testing' stamp: 'JMM 10/21/2003 18:15'!
stepTime
	"Update every hundredth of a second."
	^ 10
! !


!HandleMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 6/30/1999 20:40'!
isCandidateForAutomaticViewing
	^ false! !
TestCase subclass: #HashAndEqualsTestCase
	instanceVariableNames: 'prototypes'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!HashAndEqualsTestCase commentStamp: 'mjr 8/20/2003 17:37' prior: 0!
I am a simple TestCase that tests for correct operation of #hash and #=.

Subclasses of me need to fill my prototypes with suitable objects to be tested.!


!HashAndEqualsTestCase methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/3/2006 22:39'!
setUp
	"subclasses will add their prototypes into this collection"
	prototypes := OrderedCollection new ! !

!HashAndEqualsTestCase methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'!
testEquality
	"Check that TextFontChanges report equality correctly"
	prototypes
		do: [:p | self
				should: [(EqualityTester with: p) result]] ! !

!HashAndEqualsTestCase methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'!
testHash
	"test that TextFontChanges hash correctly"
	prototypes
		do: [:p | self
				should: [(HashTester with: p) result]] ! !
PrototypeTester subclass: #HashTester
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!HashTester commentStamp: 'mjr 8/20/2003 12:48' prior: 0!
I provide a simple way to test the hash properties of any object.  

I am given an object that should be tested and I treat it like a prototype.  I take a copy of it when I am given it so that it can't change whilst I am holding on to it.  I can then test that multiple copies of this object all hash to the same value.!


!HashTester methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/3/2006 22:39'!
resultFor: runs 
	"Test that the hash is the same over runs and answer the result"
	| hash |
	hash := self prototype hash.
	1
		to: runs
		do: [:i | hash = self prototype hash
				ifFalse: [^ false]].
	^ true ! !
TestCase subclass: #HashTesterTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!HashTesterTest commentStamp: 'mjr 8/20/2003 12:48' prior: 0!
I am a simple test case to check that HashTester works correctly!


!HashTesterTest methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'!
testBasicBehaviour
	self
		should: [(HashTester with: 1)
				resultFor: 100].
	self
		should: [(HashTester with: 'fred')
				resultFor: 100].
	self
		shouldnt: [(HashTester with: BadHasher new)
				resultFor: 100] ! !
EllipseMorph subclass: #HeadMorph
	instanceVariableNames: 'face queue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Gestures'!

!HeadMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 23:25'!
face
	^ face! !

!HeadMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
face: aFaceMorph
	face notNil ifTrue: [face delete].
	self addMorphFront: (face := aFaceMorph)! !

!HeadMorph methodsFor: 'accessing' stamp: 'len 9/7/1999 01:38'!
playEvent: event at: time
	self queue nextPut: time -> event! !


!HeadMorph methodsFor: 'accessing-private' stamp: 'len 9/6/1999 00:43'!
queue
	^ queue! !


!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addAfroHair
	| hair |
	hair := CurveMorph
		vertices: {115@4. 144@20. 166@79. 132@131. 116@93. 88@85. 54@94. 40@134. 2@79. 31@16. 79@1}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	hair extent: (hair extent * (self width / hair width * 1.9)) rounded.
	hair align: hair center with: self center x @ self top.
	self addMorphFront: hair! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addBeret
	| beret pompon |
	beret := CurveMorph
		vertices: {66@1. 90@14. 106@22. 114@35. 98@43. 55@35. 20@46. 2@38. 8@23. 23@13. 39@7}
		color: Color random
		borderWidth: 1
		borderColor: Color black.
	beret extent: (beret extent * (self width / beret width * 4 / 3)) rounded.
	beret align: beret center x @ beret bottom with: self center x @ self face top.
	pompon := EllipseMorph new color: beret color; borderWidth: 1; borderColor: Color black; extent: beret height // 2.
	pompon align: pompon center with: beret center x @ beret top.
	beret addMorphFront: pompon.
	self addMorphFront: beret! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addEars
	| leftEar rightEar |
	leftEar := EllipseMorph new color: self color; extent: self height // 10 @ (self height // 7).
	rightEar := leftEar copy.
	leftEar align: leftEar center with: self left @ self center y.
	rightEar align: rightEar center with: self right @ self center y.
	self addMorphBack: leftEar; addMorphBack: rightEar! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addGlasses
	| glass glass2 diameter |
	diameter := self face leftEye height * 2 // 3.
	glass := EllipseMorph new extent: diameter @ diameter; color: (Color yellow alpha: 0.5).
	glass2 := glass copy.
	glass align: glass center with: self face leftEye center.
	glass2 align: glass2 center with: self face rightEye center.
	self addMorph: glass; addMorph: glass2! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addHighHat
	| hat |
	hat := CurveMorph
		vertices: {70@3. 98@11. 94@46. 112@50. 96@58. 53@50. 18@61. 2@58. 24@48. 30@6. 47@6}
		color: Color random
		borderWidth: 1
		borderColor: Color black.
	hat extent: (hat extent * (self width / hat width * 4 / 3)) rounded.
	hat align: hat center x @ hat bottom with: self center x @ self face top.
	self addMorphFront: hat! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addLargeMustache
	| mustache |
	mustache := CurveMorph
		vertices: {48@4. 75@3. 93@15. 48@9. 3@19. 17@5}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	mustache extent: (mustache extent * (self width / mustache width)) rounded.
	mustache align: mustache center with: self face mustachePosition.
	self addMorphFront: mustache! !

!HeadMorph methodsFor: 'furnitures' stamp: 'dgd 3/7/2003 14:31'!
addRandomFurnitures

	self perform: #(#yourself #addBeret #addHighHat #addAfroHair #addShortHair #addSpikyHair ) atRandom.
	self perform: #(#yourself #yourself #addShortMustache ) atRandom! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addShortHair
	| hair |
	hair := CurveMorph
		vertices: {81@3. 101@22. 105@48. 93@65. 76@32. 54@32. 28@35. 11@64. 2@52. 10@15. 45@2}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	hair extent: (hair extent * (self width / hair width * 1.15)) rounded.
	hair align: hair center x @ (hair top * 4 + hair bottom // 5) with: self center x @ self top.
	self addMorphFront: hair! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addShortMustache
	| mustache |
	mustache := CurveMorph
		vertices: {29@1. 54@14. 30@11. 1@15}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	mustache extent: (mustache extent * (self width / mustache width * 0.5)) rounded.
	mustache align: mustache center with: self face mustachePosition.
	self addMorphFront: mustache! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addSpikyHair
	| hair |
	hair := PolygonMorph
		vertices: {83@3. 81@30. 91@27. 111@23. 97@32. 112@37. 99@45. 114@52. 95@53. 55@43. 10@50. 1@40. 14@40. 8@26. 24@37. 15@11. 29@29. 30@16. 36@30. 41@6. 49@31. 54@8. 61@32. 64@1. 70@27}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	hair extent: (hair extent * (self width / hair width * 1.15)) rounded.
	hair align: hair center with: self center x @ self top.
	self addMorphFront: hair! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
addWhiteHat
	| stage1 stage2 |
	stage1 := CurveMorph
		vertices: {18@1. 93@18. 91@45. 8@40}
		color: (Color r: 1.0 g: 0.968 b: 0.935)
		borderWidth: 1
		borderColor: Color black.
	stage1 extent: (stage1 extent * (self width / stage1 width * 1.20)) rounded.

	stage2 := CurveMorph
		vertices: {27@7. 81@5. 111@34. 11@28}
		color: stage1 color
		borderWidth: 1
		borderColor: Color black.
	stage2 extent: (stage2 extent * (self width / stage2 width * 1.20)) rounded.

	stage1 align: stage1 center with: self center x @ self top.
	stage2 align: stage2 center with: stage1 center x @ stage1 top.

	stage1 addMorphFront: stage2.
	self addMorphFront: stage1! !

!HeadMorph methodsFor: 'furnitures' stamp: 'stephaneducasse 2/3/2006 22:22'!
randomHairColor
	| hairColors |
	hairColors := {Color r: 0.613 g: 0.161 b: 0.0. "red"
		Color r: 0.323 g: 0.226 b: 0.0. "dark brown"
		Color r: 0.774 g: 0.548 b: 0.0. "light brown"
		Color r: 0.968 g: 0.871 b: 0.0. "yellow"
		Color r: 0.581 g: 0.581 b: 0.581. "gray"
		Color black}.
	self submorphs do: [ :each | (hairColors includes: each color) ifTrue: [^ each color]].
	^ hairColors atRandom! !


!HeadMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:32'!
defaultColor
	"answer the default color/fill style for the receiver"

	^ {Color
		r: 0.258
		g: 0.161
		b: 0.0. Color
		r: 0.452
		g: 0.258
		b: 0.0. Color
		r: 0.516
		g: 0.323
		b: 0.0. Color
		r: 1.0
		g: 0.935
		b: 0.645. Color
		r: 1.0
		g: 0.806
		b: 0.548} atRandom! !

!HeadMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""

	self face: FaceMorph new.
	self extent: self face extent * (1.5 @ 1.7).
	self face align: self face center with: self center + (0 @ self height // 10).
	self addRandomFurnitures.
	queue := SharedQueue new! !


!HeadMorph methodsFor: 'stepping and presenter' stamp: 'stephaneducasse 2/3/2006 22:22'!
step
	| now |
	super step.
	now := Time millisecondClockValue.
	[queue isEmpty not and: [now >= queue peek key]]
		whileTrue: [queue next value actOn: self].
	self face lips updateShape! !


!HeadMorph methodsFor: 'testing' stamp: 'len 9/6/1999 23:30'!
stepTime
	^ 0! !
RectangleMorph subclass: #HeadingMorph
	instanceVariableNames: 'degrees magnitude'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!HeadingMorph methodsFor: 'accessing'!
degrees

	^ (degrees + 90.0) \\ 360.0! !

!HeadingMorph methodsFor: 'accessing'!
degrees: aNumber

	degrees _ (aNumber asFloat + 270.0) \\ 360.0.! !

!HeadingMorph methodsFor: 'accessing'!
magnitude

	^ magnitude! !

!HeadingMorph methodsFor: 'accessing'!
magnitude: aNumber

	magnitude _ (aNumber asFloat max: 0.0) min: 1.0.! !


!HeadingMorph methodsFor: 'drawing'!
drawArrowFrom: p1 to: p2 width: w color: aColor on: aCanvas

	| d p |
	d _ (p1 - p2) theta radiansToDegrees.
	aCanvas line: p1 to: p2 width: w color: aColor.
	p _ p2 + (Point r: 5 degrees: d - 50).
	aCanvas line: p to: p2 width: w color: aColor.
	p _ p2 + (Point r: 5 degrees: d + 50).
	aCanvas line: p to: p2 width: w color: aColor.
! !

!HeadingMorph methodsFor: 'drawing'!
drawOn: aCanvas

	| x y r center box |
	super drawOn: aCanvas.
	box _ self innerBounds.
	1 to: 9 do: [:i |
		x _ box left + ((box width * i) // 10).
		aCanvas line: (x@box top) to: (x@(box bottom - 1)) color: 
Color black.
		y _ box top + ((box height * i) // 10).
		aCanvas line: (box left@y) to: ((box right - 1)@y) color: 
Color black].

	r _ ((box width asFloat * magnitude asFloat) / 2.0) - 1.0.
	center _ box center.
	self drawArrowFrom: center - (1@1)
		to: center + ((r * degrees degreesToRadians cos)@0) - (1@1)
		width: 3
		color: (Color red)
		on: aCanvas.
	self drawArrowFrom: center - (1@1)
		to: center + (0@(r * degrees degreesToRadians sin)) - (1@1)
		width: 3
		color: (Color red)
		on: aCanvas.
	self drawArrowFrom: center - (1@1)
		to: center + (Point r: r degrees: degrees) - (1@1)
		width: 3
		color: Color black
		on: aCanvas.
! !


!HeadingMorph methodsFor: 'event handling'!
handlesMouseDown: evt

	^ true
! !


!HeadingMorph methodsFor: 'events' stamp: 'mk 11/7/2003 11:35'!
mouseDown: evt

	| v |
	self changed.
	v _ evt cursorPoint - bounds center.
	degrees _ v theta radiansToDegrees.
	magnitude _ (v r asFloat / (bounds width asFloat / 2.0)) min: 1.0.
! !

!HeadingMorph methodsFor: 'events' stamp: 'mk 11/7/2003 11:36'!
mouseMove: evt

	self mouseDown: evt! !


!HeadingMorph methodsFor: 'geometry'!
extent: aPoint
	"Contrain extent to be square."

	| d |
	d _ aPoint x min: aPoint y.
	super extent: d@d.
! !


!HeadingMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:34'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 1! !

!HeadingMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:33'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.6
		g: 1.0
		b: 1.0! !

!HeadingMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:34'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	degrees _ 90.0.
	magnitude _ 1.0.
	
	self extent: 160 @ 160! !
SequenceableCollection subclass: #Heap
	instanceVariableNames: 'array tally sortBlock indexUpdateBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!Heap commentStamp: '<historical>' prior: 0!
Class Heap implements a special data structure commonly referred to as 'heap'. Heaps are more efficient than SortedCollections if:
a) Elements are only removed at the beginning
b) Elements are added with arbitrary sort order.
The sort time for a heap is O(n log n) in all cases.

Instance variables:
	array		<Array>		The data repository
	tally		<Integer>	The number of elements in the heap
	sortBlock	<Block|nil>	A two-argument block defining the sort order,
							or nil in which case the default sort order is
								[:element1 :element2| element1 <= element2]
	indexUpdateBlock 	<Block|nil> 
							A two-argument block of the form [:data :index | ... ]
							which allows an application object to keep track of its
							index within the heap.  Useful for quick heap update
							when object's sort value changes (for example, when an
							object in a priority queue has its priority increased
							by an external event, you don't want to have to search
							through the whole heap to find the index before fixing
							the heap).  No update occurs if nil.!


!Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 13:02'!
at: index
	"Return the element at the given position within the receiver"
	(index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index].
	^array at: index! !

!Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:14'!
at: index put: newObject
	"Heaps are accessed with #add: not #at:put:"
	^self shouldNotImplement! !

!Heap methodsFor: 'accessing' stamp: 'md 1/19/2006 09:56'!
first
	"Return the first element in the receiver"
	^array at: 1! !

!Heap methodsFor: 'accessing' stamp: 'jcg 3/8/2003 02:00'!
indexUpdateBlock: aBlockOrNil

	indexUpdateBlock _ aBlockOrNil.
	indexUpdateBlock fixTemps.
! !

!Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 14:08'!
reSort
	"Resort the entire heap"
	self isEmpty ifTrue:[^self].
	tally // 2 to: 1 by: -1 do:[:i| self downHeap: i].! !

!Heap methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:37'!
size
	"Answer how many elements the receiver contains."

	^ tally! !

!Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:21'!
sortBlock
	^sortBlock! !

!Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:21'!
sortBlock: aBlock
	sortBlock _ aBlock.
	sortBlock fixTemps.
	self reSort.! !


!Heap methodsFor: 'adding' stamp: 'jcg 3/8/2003 02:07'!
add: anObject
	"Include newObject as one of the receiver's elements. Answer newObject."
	tally = array size ifTrue:[self grow].
	array at: (tally _ tally + 1) put: anObject.
	self updateObjectIndex: tally.
	self upHeap: tally.
	^anObject! !


!Heap methodsFor: 'comparing' stamp: 'rhi 8/14/2003 10:05'!
= anObject

	^ self == anObject
		ifTrue: [true]
		ifFalse: [anObject isHeap
			ifTrue: [sortBlock = anObject sortBlock and: [super = anObject]]
			ifFalse: [super = anObject]]! !


!Heap methodsFor: 'enumerating' stamp: 'ar 9/10/1999 13:05'!
do: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument."
	1 to: tally do:[:i| aBlock value: (array at: i)]! !


!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:17'!
grow
	"Become larger."
	self growTo: self size + self growSize.! !

!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'!
growSize
	"Return the size by which the receiver should grow if there are no empty slots left."
	^array size max: 5! !

!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'!
growTo: newSize
	"Grow to the requested size."
	| newArray |
	newArray _ Array new: (newSize max: tally).
	newArray replaceFrom: 1 to: array size with: array startingAt: 1.
	array _ newArray! !

!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'!
trim
	"Remove any empty slots in the receiver."
	self growTo: self size.! !


!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:04'!
remove: oldObject ifAbsent: aBlock
	"Remove oldObject as one of the receiver's elements. If several of the 
	elements are equal to oldObject, only one is removed. If no element is 
	equal to oldObject, answer the result of evaluating anExceptionBlock. 
	Otherwise, answer the argument, oldObject."
	1 to: tally do:[:i| 
		(array at: i) = oldObject ifTrue:[^self privateRemoveAt: i]].
	^aBlock value! !

!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:05'!
removeAt: index
	"Remove the element at given position"
	(index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index].
	^self privateRemoveAt: index! !

!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:05'!
removeFirst
	"Remove the first element from the receiver"
	^self removeAt: 1! !


!Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'!
isEmpty
	"Answer whether the receiver contains any elements."
	^tally = 0! !

!Heap methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'!
isHeap

	^ true! !

!Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'!
sorts: element1 before: element2
	"Return true if element1 should be sorted before element2.
	This method defines the sort order in the receiver"
	^sortBlock == nil
		ifTrue:[element1 <= element2]
		ifFalse:[sortBlock value: element1 value: element2].! !


!Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:19'!
array
	^array! !

!Heap methodsFor: 'private' stamp: 'ar 9/15/2000 17:12'!
privateRemoveAt: index
	"Remove the element at the given index and make sure the sorting order is okay"
	| removed |
	removed _ array at: index.
	array at: index put: (array at: tally).
	array at: tally put: nil.
	tally _ tally - 1.
	index > tally ifFalse:[
		"Use #downHeapSingle: since only one element has been removed"
		self downHeapSingle: index].
	^removed! !

!Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:35'!
setCollection: aCollection
	array _ aCollection.
	tally _ 0.! !

!Heap methodsFor: 'private' stamp: 'ar 9/10/1999 13:18'!
setCollection: aCollection tally: newTally
	array _ aCollection.
	tally _ newTally.! !

!Heap methodsFor: 'private' stamp: 'sma 4/22/2000 19:30'!
species
	^ Array! !

!Heap methodsFor: 'private' stamp: 'jcg 3/8/2003 02:08'!
updateObjectIndex: index
	"If indexUpdateBlock is not nil, notify the object at index of its new position in the heap array."
	indexUpdateBlock ifNotNil: [
		indexUpdateBlock value: (array at: index) value: index]! !


!Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:11'!
downHeap: anIndex
	"Check the heap downwards for correctness starting at anIndex.
	 Everything above (i.e. left of) anIndex is ok."
	| value k n j |
	anIndex = 0 ifTrue:[^self].
	n _ tally bitShift: -1.
	k _ anIndex.
	value _ array at: anIndex.
	[k <= n] whileTrue:[
		j _ k + k.
		"use max(j,j+1)"
		(j < tally and:[self sorts: (array at: j+1) before: (array at: j)])
				ifTrue:[ j _ j + 1].
		"check if position k is ok"
		(self sorts: value before: (array at: j)) 
			ifTrue:[	"yes -> break loop"
					n _ k - 1]
			ifFalse:[	"no -> make room at j by moving j-th element to k-th position"
					array at: k put: (array at: j).
					self updateObjectIndex: k.
					"and try again with j"
					k _ j]].
	array at: k put: value.
	self updateObjectIndex: k.! !

!Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:11'!
downHeapSingle: anIndex
	"This version is optimized for the case when only one element in the receiver can be at a wrong position. It avoids one comparison at each node when travelling down the heap and checks the heap upwards after the element is at a bottom position. Since the probability for being at the bottom of the heap is much larger than for being somewhere in the middle this version should be faster."
	| value k n j |
	anIndex = 0 ifTrue:[^self].
	n _ tally bitShift: -1.
	k _ anIndex.
	value _ array at: anIndex.
	[k <= n] whileTrue:[
		j _ k + k.
		"use max(j,j+1)"
		(j < tally and:[self sorts: (array at: j+1) before: (array at: j)])
				ifTrue:[	j _ j + 1].
		array at: k put: (array at: j).
		self updateObjectIndex: k.
		"and try again with j"
		k _ j].
	array at: k put: value.
	self updateObjectIndex: k.
	self upHeap: k! !

!Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:12'!
upHeap: anIndex
	"Check the heap upwards for correctness starting at anIndex.
	 Everything below anIndex is ok."
	| value k kDiv2 tmp |
	anIndex = 0 ifTrue:[^self].
	k _ anIndex.
	value _ array at: anIndex.
	[ (k > 1) and:[self sorts: value before: (tmp _ array at: (kDiv2 _ k bitShift: -1))] ] 
		whileTrue:[
			array at: k put: tmp.
			self updateObjectIndex: k.
			k _ kDiv2].
	array at: k put: value.
	self updateObjectIndex: k.! !

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

Heap class
	instanceVariableNames: ''!

!Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'!
new
	^self new: 10! !

!Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'!
new: n
	^super new setCollection: (Array new: n)! !

!Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 14:13'!
sortBlock: aBlock
	"Create a new heap sorted by the given block"
	^self new sortBlock: aBlock! !

!Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 13:23'!
withAll: aCollection
	"Create a new heap with all the elements from aCollection"
	^(self basicNew)
		setCollection: aCollection asArray copy tally: aCollection size;
		reSort;
		yourself! !

!Heap class methodsFor: 'instance creation' stamp: 'ar 5/23/2001 17:22'!
withAll: aCollection sortBlock: sortBlock
	"Create a new heap with all the elements from aCollection"
	^(self basicNew)
		setCollection: aCollection asArray copy tally: aCollection size;
		sortBlock: sortBlock;
		yourself! !
ClassTestCase subclass: #HeapTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Sequenceable'!

!HeapTest methodsFor: 'examples' stamp: 'md 2/12/2006 15:33'!
heapExample	"HeapTest new heapExample"
	"Create a sorted collection of numbers, remove the elements
	sequentially and add new objects randomly.
	Note: This is the kind of benchmark a heap is designed for."
	| n rnd array time sorted |
	n _ 5000. "# of elements to sort"
	rnd _ Random new.
	array _ (1 to: n) collect:[:i| rnd next].
	"First, the heap version"
	time _ Time millisecondsToRun:[
		sorted _ Heap withAll: array.
		1 to: n do:[:i| 
			sorted removeFirst.
			sorted add: rnd next].
	].
	Transcript cr; show:'Time for Heap: ', time printString,' msecs'.
	"The quicksort version"
	time _ Time millisecondsToRun:[
		sorted _ SortedCollection withAll: array.
		1 to: n do:[:i| 
			sorted removeFirst.
			sorted add: rnd next].
	].
	Transcript cr; show:'Time for SortedCollection: ', time printString,' msecs'.
! !

!HeapTest methodsFor: 'examples' stamp: 'md 2/12/2006 15:34'!
heapSortExample	"HeapTest new heapSortExample"
	"Sort a random collection of Floats and compare the results with
	SortedCollection (using the quick-sort algorithm) and 
	ArrayedCollection>>mergeSortFrom:to:by: (using the merge-sort algorithm)."
	| n rnd array  time sorted |
	n _ 10000. "# of elements to sort"
	rnd _ Random new.
	array _ (1 to: n) collect:[:i| rnd next].
	"First, the heap version"
	time _ Time millisecondsToRun:[
		sorted _ Heap withAll: array.
		1 to: n do:[:i| sorted removeFirst].
	].
	Transcript cr; show:'Time for heap-sort: ', time printString,' msecs'.
	"The quicksort version"
	time _ Time millisecondsToRun:[
		sorted _ SortedCollection withAll: array.
	].
	Transcript cr; show:'Time for quick-sort: ', time printString,' msecs'.
	"The merge-sort version"
	time _ Time millisecondsToRun:[
		array mergeSortFrom: 1 to: array size by: [:v1 :v2| v1 <= v2].
	].
	Transcript cr; show:'Time for merge-sort: ', time printString,' msecs'.
! !


!HeapTest methodsFor: 'testing' stamp: 'zz 12/7/2005 19:25'!
test1
	| data h |

	"The first element of each array is the sort value, and the second will be updated by the heap with the index of the element within the heap."
	data :=  (1 to: 8) collect: [:i | {i*2. 0}].

	"Repeat with different data ordering."
	5 timesRepeat: [
		h := Heap new sortBlock: [:e1 :e2 | e1 first < e2 first].
		h indexUpdateBlock: [:array :index | array at: 2 put: index].

		data shuffled do: [:d | h add: d].
		data do: [:d | self should: (h at: d second) == d].
	]! !

!HeapTest methodsFor: 'testing' stamp: 'md 2/12/2006 15:35'!
testExamples
	self shouldnt: [self heapExample] raise: Error.
	self shouldnt: [self heapSortExample] raise: Error.! !


!HeapTest methodsFor: 'basic tests' stamp: 'nm 2/28/2006 09:37'!
testAdd
	"self run: #testAdd"

	| heap |
	heap := Heap new.
	self assert: heap size = 0.
	heap add: 3.
	self assert: heap size = 1.
	self assert: heap isEmpty not.
	self assert: heap first = 3.
	self assert: (heap at: 1) = 3.
	heap add: 2.
	self assert: heap size = 2.
	self assert: heap first = 2.
	self assert: (heap at: 2) = 3.
	! !

!HeapTest methodsFor: 'basic tests' stamp: 'sd 4/8/2006 21:37'!
testAt
	"self run: #testAt"

	| heap |
	heap := Heap new.
	heap add: 3.
	self assert: (heap at: 1) = 3.
	self should: [heap at: 2] raise: Error.
	heap add: 4.
	self assert: (heap at: 1) = 3.
	self assert: (heap at: 2) = 4.

	! !

!HeapTest methodsFor: 'basic tests' stamp: 'nm 4/3/2006 11:22'!
testDo
	"self run: #testDo"

	| heap coll |
	heap := Heap withAll: #(1 3 5).
	coll := OrderedCollection new.
	
	heap do: [:each | coll add: each].
	
	self assert: coll = #(1 3 5) asOrderedCollection.
! !

!HeapTest methodsFor: 'basic tests' stamp: 'nm 2/28/2006 09:36'!
testFirst
	"self run: #testFirst"
	| heap |
	heap := Heap new.
	heap add: 5.
	heap add: 12.
	heap add: 1.
	self assert: heap first = 1.
	heap removeFirst.
	self assert: heap first = 5.! !

!HeapTest methodsFor: 'basic tests' stamp: 'nm 4/3/2006 11:27'!
testHeap
	"self run: #testHeap"

	| heap |
	heap := Heap new.
	self assert: heap isHeap.
	
	self assert: heap isEmpty.
	heap add: 1.
	self assert: heap isEmpty not
	
! !

!HeapTest methodsFor: 'basic tests' stamp: 'nm 2/15/2006 09:55'!
testRemove
	"self run: #testRemove"
	
	| heap |
	heap := Heap new.
	self should: [heap removeFirst] raise: Error.
	heap add: 5.
	self shouldnt: [heap removeFirst] raise: Error.
	self assert: heap size = 0.
	heap add: 5.
	self should: [heap removeAt: 2] raise: Error.! !

!HeapTest methodsFor: 'basic tests' stamp: 'nm 4/3/2006 11:17'!
testSortBlock
	"self run: #testSortBlock"

	| heap |
	heap := Heap withAll: #(1 3 5).
	self assert: heap = #(1 3 5).
	
	heap sortBlock: [ :e1 :e2 | e1 >= e2 ].
	self assert: heap = #(5 3 1)
! !
URI subclass: #HierarchicalURI
	instanceVariableNames: 'authority query'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-URI'!

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 3/6/2002 14:46'!
absolutePath
	^self schemeSpecificPart isEmpty
		ifTrue: ['/']
		ifFalse: [self schemeSpecificPart]! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/25/2002 18:37'!
authority
	^authority! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 11/30/2003 23:59'!
baseName
	"returns the last component stripped of its extension"

	| baseName i |
	baseName _ self pathComponents last.
	i _ baseName findLast: [:c | c = $.].
	^i = 0
		ifTrue: [baseName]
		ifFalse: [baseName copyFrom: 1 to: i-1].
! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 1/8/2004 00:50'!
extension
	"This method assumes a $. as extension delimiter"

	| i leafName |
	leafName := self pathComponents last.
	i _ leafName findLast: [:c | c = $.].
	^i = 0
		ifTrue: ['']
		ifFalse: [leafName copyFrom: i + 1 to: leafName size].
! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:26'!
host
	^self authority host! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/27/2002 14:21'!
path
"	^self schemeSpecificPart isEmpty
		ifTrue: ['/']
		ifFalse: [self schemeSpecificPart]"
	^self schemeSpecificPart! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/26/2002 19:21'!
pathComponents
	^self path findTokens: $/! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:26'!
port
	^self authority port! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'!
query
	^query! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/27/2002 16:17'!
resolveRelativeURI: aURI
	| relativeURI newAuthority newPath pathComponents newURI relComps |
	relativeURI _ aURI asURI.

	relativeURI isAbsolute
		ifTrue: [^relativeURI].

	relativeURI authority
		ifNil: [
			newAuthority _ self authority.
			(relativeURI path beginsWith: '/')
				ifTrue: [newPath _ relativeURI path]
				ifFalse: [
					pathComponents _ (self path copyUpToLast: $/) findTokens: $/.
					relComps _ relativeURI pathComponents.
					relComps removeAllSuchThat: [:each | each = '.'].
					pathComponents addAll: relComps.
					pathComponents removeAllSuchThat: [:each | each = '.'].
					self removeComponentDotDotPairs: pathComponents.
					newPath _ self buildAbsolutePath: pathComponents.
					((relComps isEmpty
						or: [relativeURI path last == $/ ]
						or: [(relativeURI path endsWith: '/..') or: [relativeURI path = '..']]
						or: [relativeURI path endsWith: '/.' ])
						and: [newPath size > 1])
						ifTrue: [newPath _ newPath , '/']]]
		ifNotNil: [
			newAuthority _ relativeURI authority.
			newPath _ relativeURI path].

	newURI _ String streamContents: [:stream |
		stream nextPutAll: self scheme.
		stream nextPut: $: .
		newAuthority notNil
			ifTrue: [
				stream nextPutAll: '//'.
				newAuthority printOn: stream].
		newPath notNil
			ifTrue: [stream nextPutAll: newPath].
		relativeURI query notNil
			ifTrue: [stream nextPutAll: relativeURI query].
		relativeURI fragment notNil
			ifTrue: [
				stream nextPut: $# .
				stream nextPutAll: relativeURI fragment]].
	^newURI asURI! !

!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'!
userInfo
	^self authority userInfo! !


!HierarchicalURI methodsFor: 'directory operations' stamp: 'mir 3/8/2002 10:51'!
assureExistance
	! !


!HierarchicalURI methodsFor: 'printing' stamp: 'mir 2/27/2002 12:51'!
printSchemeSpecificPartOn: stream
	self isAbsolute
		ifTrue: [stream nextPutAll: '//'].
	authority
		ifNotNil: [self authority printOn: stream].
	super printSchemeSpecificPartOn: stream.
	query
		ifNotNil: [stream nextPutAll: query]! !


!HierarchicalURI methodsFor: 'private' stamp: 'mir 6/20/2005 18:49'!
absoluteFromString: aString scheme: schemeName
	| remainder |
	super absoluteFromString: aString scheme: schemeName.

	"We now have the interesting part in schemeSpecficPart and can parse it further"

	"This check is somewhat redundant, just in case somebody calls this directly."
	remainder _ schemeSpecificPart.
	(remainder isEmpty
		or: [remainder first ~~ $/])
		ifTrue: [(IllegalURIException new uriString: remainder) signal: 'Invalid absolute URI'].

	(aString beginsWith: '//')
		ifTrue: [remainder := self extractAuthority: (remainder copyFrom: 3 to: remainder size)].

	self extractSchemeSpecificPartAndFragment: remainder! !

!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/26/2002 19:35'!
buildAbsolutePath: pathComponents
	^String streamContents: [:stream |
		stream nextPut: $/.
		pathComponents
			do: [:pathPart | stream nextPutAll: pathPart]
			separatedBy: [stream nextPut: $/]]! !

!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/27/2002 12:46'!
extractAuthority: aString
	| endAuthorityIndex authorityString |
	endAuthorityIndex _ (aString indexOf: $/ ) - 1.
	endAuthorityIndex < 0
		ifTrue: [endAuthorityIndex _ aString size].
	authorityString _ aString copyFrom: 1 to: endAuthorityIndex.
	authority _ URIAuthority fromString: authorityString.
	^aString copyFrom: endAuthorityIndex+1 to: aString size! !

!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/26/2002 14:13'!
extractQuery: remainder
	| queryIndex |
	queryIndex _ remainder indexOf: $?.
	queryIndex > 0
		ifFalse: [^remainder].
	query _ remainder copyFrom: queryIndex to: remainder size.
	^remainder copyFrom: 1 to: queryIndex-1! !

!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/26/2002 14:13'!
extractSchemeSpecificPartAndFragment: remainder
	super extractSchemeSpecificPartAndFragment: remainder.
	schemeSpecificPart _ self extractQuery: schemeSpecificPart! !

!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/27/2002 14:16'!
relativeFromString: aString
	| remainder authorityEnd |
	remainder _ (aString beginsWith: '//')
		ifTrue: [
			authorityEnd _ aString indexOf: $/ startingAt: 3.
			authorityEnd == 0
				ifTrue: [authorityEnd _ aString size+1].
			self extractAuthority: (aString copyFrom: 3 to: authorityEnd-1)]
		ifFalse: [aString].
	self extractSchemeSpecificPartAndFragment: remainder! !

!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/27/2002 14:30'!
removeComponentDotDotPairs: pathComponents
	| dotDotIndex |
	dotDotIndex _ pathComponents indexOf: '..'.
	[dotDotIndex > 1]
		whileTrue: [
			pathComponents
				removeAt: dotDotIndex;
				removeAt: dotDotIndex-1.
			dotDotIndex _ pathComponents indexOf: '..']! !
Url subclass: #HierarchicalUrl
	instanceVariableNames: 'schemeName authority path query port username password'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!HierarchicalUrl commentStamp: '<historical>' prior: 0!
A URL which has a hierarchical encoding.  For instance, http and ftp URLs are hierarchical.!


!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'!
authority
	^authority! !

!HierarchicalUrl methodsFor: 'access' stamp: 'gk 10/21/2005 10:21'!
directoryUrl
	"The path always has at least one element so this works."

	^self copy path: (path copyFrom: 1 to: path size - 1)! !

!HierarchicalUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:06'!
fileName
	"Return the last part of the path,
	most often a filename but does not need to be."

	^self path last! !

!HierarchicalUrl methodsFor: 'access' stamp: 'tk 9/6/1998 12:45'!
isAbsolute
	
	path size > 0 ifFalse: [^ false].
	(path at: 1) size > 0 ifFalse: [^ false].
	^ ((path at: 1) at: 1) ~~ $.! !

!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'!
password
	"http://user:pword@foo.com' asUrl password"
	^password! !

!HierarchicalUrl methodsFor: 'access' stamp: 'KLC 4/3/2006 10:05'!
path
	"return a collection of the decoded path elements, as strings"
	^path! !

!HierarchicalUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:15'!
path: aCollection
	"Set the collection of path elements."

	path _ aCollection! !

!HierarchicalUrl methodsFor: 'access' stamp: 'mir 7/30/1999 13:05'!
port
	^port! !

!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:59'!
query
	"return the query, the part after any ?.  Any %XY's have already been decoded.  If there wasno query part, nil is returned (it is possible to also have an empty query"
	^query ! !

!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'!
schemeName
	^schemeName! !

!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'!
username
	"http://user:pword@foo.com' asUrl username"
	^username! !


!HierarchicalUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:07'!
scheme
	^ self schemeName.! !


!HierarchicalUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:44'!
hasContents
	"most of these do...."
	^true! !


!HierarchicalUrl methodsFor: 'parsing' stamp: 'jrp 8/28/2004 14:53'!
privateInitializeFromText: aString 
	| remainder ind specifiedSchemeName |
	remainder _ aString.
	schemeName ifNil: 
			[specifiedSchemeName _ Url schemeNameForString: remainder.
			specifiedSchemeName ifNotNil: 
					[schemeName _ specifiedSchemeName.
					remainder _ remainder copyFrom: schemeName size + 2 to: remainder size].
			schemeName ifNil: 
					["assume HTTP"

					schemeName _ 'http']].

	"remove leading // if it's there"
	(remainder beginsWith: '//') 
		ifTrue: [remainder _ remainder copyFrom: 3 to: remainder size].


	"get the query"
	ind _ remainder indexOf: $?.
	ind > 0 
		ifTrue: 
			[query _ remainder copyFrom: ind + 1 to: remainder size.
			remainder _ remainder copyFrom: 1 to: ind - 1].

	"get the authority"
	ind _ remainder indexOf: $/.
	ind > 0 
		ifTrue: 
			[ind = 1 
				ifTrue: [authority _ '']
				ifFalse: 
					[authority _ remainder copyFrom: 1 to: ind - 1.
					remainder _ remainder copyFrom: ind + 1 to: remainder size]]
		ifFalse: 
			[authority _ remainder.
			remainder _ ''].

	"extract the username+password"
	(authority includes: $@) 
		ifTrue: 
			[username _ authority copyUpTo: $@.
			authority _ authority copyFrom: (authority indexOf: $@) + 1
						to: authority size.
			(username includes: $:) 
				ifTrue: 
					[password _ username copyFrom: (username indexOf: $:) + 1 to: username size.
					username _ username copyUpTo: $:]].

	"Extract the port"
	(authority includes: $:) 
		ifTrue: 
			[| lastColonIndex portString |
			lastColonIndex _ authority findLast: [:c | c = $:].
			portString _ authority copyFrom: lastColonIndex + 1 to: authority size.
			portString isAllDigits 
				ifTrue: 
					[port _ Integer readFromString: portString.
					(port > 65535) ifTrue: [self error: 'Invalid port number'].
					 authority _ authority copyFrom: 1 to: lastColonIndex - 1]
				ifFalse:[self error: 'Invalid port number']].

	"get the path"
	path _ self privateParsePath: remainder relativeTo: #() .! !

!HierarchicalUrl methodsFor: 'parsing' stamp: 'ls 6/15/2003 13:40'!
privateInitializeFromText: aString relativeTo: aUrl 
	| remainder ind basePath |
	remainder _ aString.
	"set the scheme"
	schemeName _ aUrl schemeName.

	"a leading // means the authority is specified, meaning it is absolute"
	(remainder beginsWith: '//')
		ifTrue: [^ self privateInitializeFromText: aString].

	"otherwise, use the same authority"
	authority _ aUrl authority.
	port _ aUrl port.
	username _ aUrl username.
	password _ aUrl password.

	"get the query"
	ind _ remainder indexOf: $?.
	ind > 0
		ifTrue: [query _ remainder copyFrom: ind + 1 to: remainder size.
			remainder _ remainder copyFrom: 1 to: ind - 1].

	"get the path"
	(remainder beginsWith: '/')
		ifTrue: [ basePath := #() ]
		ifFalse: [ basePath := aUrl path ].
	path := self privateParsePath: remainder  relativeTo: basePath.

! !

!HierarchicalUrl methodsFor: 'parsing' stamp: 'ls 7/21/2003 11:55'!
privateParsePath: remainder relativeTo: basePath 
	| nextTok s parsedPath |
	s := ReadStream on: remainder.

	parsedPath := OrderedCollection new.
	parsedPath addAll: basePath.
	parsedPath isEmpty ifFalse: [ parsedPath removeLast ].
	
	[s peek = $/ ifTrue: [s next].
	nextTok := WriteStream on: String new.
	[s atEnd or: [s peek = $/]] whileFalse: [nextTok nextPut: s next].
	nextTok := nextTok contents unescapePercents.
	nextTok = '..' 
		ifTrue: [parsedPath size > 0 ifTrue: [parsedPath removeLast]]
		ifFalse: [nextTok ~= '.' ifTrue: [parsedPath add: nextTok]].
	s atEnd] 
			whileFalse.
	parsedPath isEmpty ifTrue: [parsedPath add: ''].

	^parsedPath! !


!HierarchicalUrl methodsFor: 'printing' stamp: 'mir 9/29/2000 14:16'!
fullPath
	| ans |
	ans _ WriteStream on: String new.
	path do: [ :pathElem |
		ans nextPut: $/.
		ans nextPutAll: pathElem encodeForHTTP. ].
	self query isNil ifFalse: [ 
		ans nextPut: $?.
		ans nextPutAll: self query. ].
	self fragment isNil ifFalse: [
		ans nextPut: $#.
		ans nextPutAll: self fragment encodeForHTTP. ].
	
	^ans contents! !

!HierarchicalUrl methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:04'!
printOn: aStream

	aStream nextPutAll: self schemeName.
	aStream nextPutAll: '://'.
	self username ifNotNil: [
		aStream nextPutAll: self username.
		self password ifNotNil: [
			aStream nextPutAll: ':'.
			aStream nextPutAll: self password ].
		aStream nextPutAll: '@' ].
	aStream nextPutAll: self authority.
	port ifNotNil: [aStream nextPut: $:; print: port].
	path do: [ :pathElem |
		aStream nextPut: $/.
		aStream nextPutAll: pathElem encodeForHTTP. ].
	self query isNil ifFalse: [ 
		aStream nextPut: $?.
		aStream nextPutAll: self query. ].
	self fragment isNil ifFalse: [
		aStream nextPut: $#.
		aStream nextPutAll: self fragment encodeForHTTP. ].! !


!HierarchicalUrl methodsFor: 'private' stamp: 'ls 6/20/1998 19:41'!
schemeName: schemeName0  authority: authority0  path: path0  query: query0
	"initialize a new instance"
	schemeName _ schemeName0.
	authority _ authority0.
	path _ path0.
	query _ query0.
! !


!HierarchicalUrl methodsFor: 'copying' stamp: 'gk 10/21/2005 11:14'!
copy
	"Be sure not to share the path with the copy"

	^self clone path: path copy! !

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

HierarchicalUrl class
	instanceVariableNames: ''!

!HierarchicalUrl class methodsFor: 'instance creation' stamp: 'ls 6/20/1998 19:41'!
schemeName: schemeName  authority: authority  path: path  query: query
	^self new schemeName: schemeName  authority: authority  path: path  query: query! !
ClassTestCase subclass: #HierarchicalUrlTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NetworkTests-Url'!

!HierarchicalUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 13:03'!
testAsString
	| url |
	url := HierarchicalUrl new
		schemeName: 'ftp'
		authority: 'localhost'
		path: #('path' 'to' 'file')
		query: 'aQuery'.
	self assert: url asString = 'ftp://localhost/path/to/file?aQuery'.! !
Browser subclass: #HierarchyBrowser
	instanceVariableNames: 'classList centralClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!

!HierarchyBrowser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'!
assureSelectionsShow
	"This is a workaround for the fact that a hierarchy browser, when launched, often does not show the selected class"

	| saveCatIndex saveMsgIndex |
	saveCatIndex := messageCategoryListIndex.
	saveMsgIndex := messageListIndex.
	self classListIndex: classListIndex.
	self messageCategoryListIndex: saveCatIndex.
	self messageListIndex: saveMsgIndex! !

!HierarchyBrowser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'!
classList
	classList := classList select: [:each | Smalltalk includesKey: each withBlanksTrimmed asSymbol].
	^ classList! !


!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:28'!
changed: sym
	sym == #classList ifTrue: [self updateAfterClassChange].
	super changed: sym! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
classListIndex: newIndex
	"Cause system organization to reflect appropriate category"
	| newClassName ind |
	newIndex ~= 0 ifTrue:
		[newClassName := (classList at: newIndex) copyWithout: $ .
		systemCategoryListIndex :=
			systemOrganizer numberOfCategoryOfElement: newClassName].
	ind := super classListIndex: newIndex.
	self changed: #systemCategorySingleton.
	^ ind! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'dew 9/15/2001 16:19'!
defaultBrowserTitle
	^ 'Hierarchy Browser'! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
initAlphabeticListing
	| tab stab index |
	self systemOrganizer: SystemOrganization.
	metaClassIndicated := false.
	classList := Smalltalk classNames.! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
initHierarchyForClass: aClassOrMetaClass
	| tab stab index nonMetaClass |
	centralClass := aClassOrMetaClass.
	nonMetaClass := aClassOrMetaClass theNonMetaClass.
	self systemOrganizer: SystemOrganization.
	metaClassIndicated := aClassOrMetaClass isMeta.
	classList := OrderedCollection new.
	tab := ''.
	nonMetaClass allSuperclasses reverseDo: 
		[:aClass | 
		classList add: tab , aClass name.
		tab := tab , '  '].
	index := classList size + 1.
	nonMetaClass allSubclassesWithLevelDo:
		[:aClass :level |
		stab := ''.  1 to: level do: [:i | stab := stab , '  '].
		classList add: tab , stab , aClass name]
	 	startingLevel: 0.
	self classListIndex: index! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'tk 4/5/98 10:29'!
openEditString: aString
	"Create a pluggable version of all the views for a HierarchyBrowser, including views and controllers.  The top list view is of the currently selected system class category--a single item list."

	^ self openSystemCatEditString: aString! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 11/8/1999 09:38'!
potentialClassNames
	"Answer the names of all the classes that could be viewed in this browser"
	^ self classList collect:
		[:aName | aName copyWithout: $ ]! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
selectClass: classNotMeta
	| name |
	name := classNotMeta name.
	self classListIndex: (self classList findFirst:
			[:each | (each endsWith: name)
					and: [each size = name size
							or: [(each at: each size - name size) isSeparator]]])! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
selectedClassName
	"Answer the name of the class currently selected.   di
	  bug fix for the case where name cannot be found -- return nil rather than halt"

	| aName |
	aName := super selectedClassName.
	^ aName == nil
		ifTrue:
			[aName]
		ifFalse:
			[(aName copyWithout: $ ) asSymbol]! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
systemCategorySingleton

	| cls |
	cls := self selectedClass.
	^ cls ifNil: [Array new]
		ifNotNil: [Array with: cls category]! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'rhi 12/2/2001 21:32'!
updateAfterClassChange
	"It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser."

	(centralClass notNil and: [centralClass isObsolete not])
		ifTrue: [self initHierarchyForClass: centralClass]! !


!HierarchyBrowser methodsFor: 'menu messages' stamp: 'tk 4/7/98 13:53'!
buildClassBrowserEditString: aString 
	"Create and schedule a new class browser for the current selection, if one 
	exists, with initial textual contents set to aString."

	self spawnHierarchy! !

!HierarchyBrowser methodsFor: 'menu messages' stamp: 'tk 4/3/98 11:22'!
removeSystemCategory
	"If a class category is selected, create a Confirmer so the user can 
	verify that the currently selected class category and all of its classes
 	should be removed from the system. If so, remove it."

	self inform: 'Use a normal Browser, in which you can see 
the entire category you are trying to remove.'! !

!HierarchyBrowser methodsFor: 'menu messages' stamp: 'sw 11/8/1999 13:35'!
systemCatSingletonKey: aChar from: aView
	^ self systemCatListKey: aChar from: aView! !

!HierarchyBrowser methodsFor: 'menu messages' stamp: 'sw 11/8/1999 14:08'!
systemCatSingletonMenu: aMenu

	^ aMenu labels:
'find class... (f)
browse
printOut
fileOut
update
rename...
remove' 
	lines: #(1 4)
	selections:
		#(findClass buildSystemCategoryBrowser
		printOutSystemCategory fileOutSystemCategory updateSystemCategories
		 renameSystemCategory removeSystemCategory )
! !

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

HierarchyBrowser class
	instanceVariableNames: ''!

!HierarchyBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
newFor: aClass
	"Open a new HierarchyBrowser on the given class"
	|  newBrowser |
	newBrowser := HierarchyBrowser new initHierarchyForClass: aClass.
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: newBrowser labelString

"HierarchyBrowser newFor: Boolean"! !

!HierarchyBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
newFor: aClass labeled: aLabel
	"Open a new HierarchyBrowser on the given class, using aLabel as the window title."

	|  newBrowser |
	newBrowser := HierarchyBrowser new initHierarchyForClass: aClass.
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: aLabel

"HierarchyBrowser newFor: Boolean labeled: 'Testing'"! !
StrikeFont subclass: #HostFont
	instanceVariableNames: 'fullWidth kernPairs ranges'
	classVariableNames: 'IsoToSqueakMap'
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Fonts'!

!HostFont methodsFor: 'accessing' stamp: 'ar 2/2/2002 18:49'!
baseKern
	^0! !

!HostFont methodsFor: 'accessing' stamp: 'yo 2/13/2004 04:06'!
createCharacterToGlyphMap

	^ IdentityGlyphMap new.
! !

!HostFont methodsFor: 'accessing' stamp: 'ar 2/2/2002 18:49'!
descentKern
	^0! !

!HostFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 12:03'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 

	^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent.
! !

!HostFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 15:14'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY

 	^ super displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY.
! !

!HostFont methodsFor: 'accessing' stamp: 'ar 2/18/2001 20:01'!
getFontData
	| fontHandle bufSize buffer |
	fontHandle _ self primitiveCreateFont: name size: pointSize emphasis: emphasis.
	fontHandle ifNil:[^nil].
	bufSize _ self primitiveFontDataSize: fontHandle.
	buffer _ ByteArray new: bufSize.
	self primitiveFont: fontHandle getData: buffer.
	^buffer! !

!HostFont methodsFor: 'accessing' stamp: 'ar 2/18/2001 20:04'!
testEmbeddingFlags
	"HostFont basicNew testEmbeddingFlags"
	| list fontHandle |
	list _ self class listFontNames.
	list do:[:fName|
		fontHandle _ self primitiveCreateFont: fName size: 12 emphasis: 0.
		fontHandle ifNotNil:[
			type _ self primitiveFontEmbeddingFlags: fontHandle.
			Transcript cr; show: fName,': ', type printString.
			self primitiveDestroyFont: fontHandle.
		].
	].! !

!HostFont methodsFor: 'accessing' stamp: 'yo 2/17/2004 16:23'!
widthOfString: aString from: firstIndex to: lastIndex
	
	^ (aString copyFrom: firstIndex to: lastIndex) inject: 0 into: [:s :t | s _ s + (self widthOf: t)].! !


!HostFont methodsFor: 'emphasis' stamp: 'ar 8/29/2000 21:18'!
emphasized: code
	| derivative addedEmphasis base safeCode |
	code = 0 ifTrue: [^ self].
	derivativeFonts == nil ifTrue:[derivativeFonts _ Array new: 32].
	derivative _ derivativeFonts at: (safeCode _ code min: derivativeFonts size).
	derivative == nil ifFalse: [^ derivative].  "Already have this style"

	"Dont have it -- derive from another with one with less emphasis"
	addedEmphasis _ 1 bitShift: safeCode highBit - 1.
	base _ self emphasized: safeCode - addedEmphasis.  "Order is Bold, Ital, Under, Narrow"
	addedEmphasis = 1 ifTrue:   "Compute synthetic bold version of the font"
		[derivative _ (base copy name: base name) makeBoldGlyphs].
	addedEmphasis = 2 ifTrue:   "Compute synthetic italic version of the font"
		[ derivative _ (base copy name: base name) makeItalicGlyphs].
	addedEmphasis = 4 ifTrue:   "Compute underlined version of the font"
		[derivative _ (base copy name: base name) makeUnderlinedGlyphs].
	addedEmphasis = 8 ifTrue:   "Compute narrow version of the font"
		[derivative _ (base copy name: base name) makeCondensedGlyphs].
	addedEmphasis = 16 ifTrue:   "Compute struck-out version of the font"
		[derivative _ (base copy name: base name) makeStruckOutGlyphs].
	derivative emphasis: safeCode.
	derivativeFonts at: safeCode put: derivative.
	^ derivative! !

!HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:38'!
makeBoldGlyphs
	"First check if we can use some OS support for this"
	(self class listFontNames includes: name) ifFalse:[^super makeBoldGlyphs].
	"Now attempt a direct creation through the appropriate primitives"
	(self fontName: name size: pointSize emphasis: (emphasis bitOr: 1) rangesArray: ranges) 
		ifNil:[^super makeBoldGlyphs]. "nil means we failed"! !

!HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:39'!
makeItalicGlyphs
	"First check if we can use some OS support for this"
	(self class listFontNames includes: name) ifFalse:[^super makeItalicGlyphs].
	"Now attempt a direct creation through the appropriate primitives"
	(self fontName: name size: pointSize emphasis: (emphasis bitOr: 2) rangesArray: ranges)
		ifNil:[^super makeItalicGlyphs]. "nil means we failed"! !

!HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:39'!
makeStruckOutGlyphs
	"First check if we can use some OS support for this"
	(self class listFontNames includes: name) ifFalse:[^super makeStruckOutGlyphs].
	"Now attempt a direct creation through the appropriate primitives"
	(self fontName: name size: pointSize emphasis: (emphasis bitOr: 8) rangesArray: ranges)
		ifNil:[^super makeStruckOutGlyphs]. "nil means we failed"! !

!HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:40'!
makeUnderlinedGlyphs
	"First check if we can use some OS support for this"
	(self class listFontNames includes: name) ifFalse:[^super makeUnderlinedGlyphs].
	"Now attempt a direct creation through the appropriate primitives"
	(self fontName: name size: pointSize emphasis: (emphasis bitOr: 4) rangesArray: ranges)
		ifNil:[^super makeUnderlinedGlyphs]. "nil means we failed"! !


!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:11'!
primitiveCreateFont: fontName size: fontSize emphasis: fontFlags
	<primitive:'primitiveCreateFont' module:'FontPlugin'>
	^nil! !

!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'!
primitiveDestroyFont: fontHandle
	<primitive:'primitiveDestroyFont' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'!
primitiveFont: fontHandle fullWidthOfChar: aCharIndex 
	<primitive:'primitiveFontFullWidthOfChar' module:'FontPlugin'>
	^Array 
		with: 0
		with: (self primitiveFont: fontHandle widthOfChar: aCharIndex)
		with: 0! !

!HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 19:46'!
primitiveFont: fontHandle getData: buffer
	<primitive:'primitiveGetFontData' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'ar 8/28/2000 16:05'!
primitiveFont: fontHandle getKernPair: kernIndex
	<primitive:'primitiveFontGetKernPair' module:'FontPlugin'>
	^0! !

!HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'!
primitiveFont: fontHandle glyphOfChar: aCharIndex into: glyphForm 
	<primitive:'primitiveFontGlyphOfChar' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'!
primitiveFont: fontHandle widthOfChar: aCharIndex 
	<primitive:'primitiveFontWidthOfChar' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'!
primitiveFontAscent: fontHandle
	<primitive:'primitiveFontAscent' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 19:45'!
primitiveFontDataSize: fontHandle
	<primitive:'primitiveFontDataSize' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'!
primitiveFontDescent: fontHandle
	<primitive:'primitiveFontDescent' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 20:00'!
primitiveFontEmbeddingFlags: fontHandle
	<primitive:'primitiveFontEmbeddingFlags' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:02'!
primitiveFontEncoding: fontHandle
	<primitive:'primitiveFontEncoding' module:'FontPlugin'>
	^self primitiveFailed! !

!HostFont methodsFor: 'primitives' stamp: 'ar 8/28/2000 16:04'!
primitiveFontNumKernPairs: fontHandle
	<primitive:'primitiveFontNumKernPairs' module:'FontPlugin'>
	^0! !


!HostFont methodsFor: 'private-creation' stamp: 'yo 2/14/2004 01:38'!
fontName: fontName size: ptSize emphasis: emphasisCode

	^ self fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: (Array with: (Array with: 0 with: 255)).
! !

!HostFont methodsFor: 'private-creation' stamp: 'yo 2/14/2004 01:41'!
fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: rangesArray
	"
		^HostFont fontName: ('MS UI Gothic') size: 12 emphasis: 0 rangesArray: EFontBDFFontReaderForRanges basicNew rangesForJapanese.
	"
	| fontHandle xStart w glyphForm fontHeight fw enc rangesStream currentRange |
	fontHandle _ self primitiveCreateFont: fontName size: ptSize emphasis: emphasisCode.
	fontHandle ifNil:[^nil].
	ranges _ rangesArray.
	ranges ifNil: [ranges _ Array with: (Array with: 0 with: 255)].
	pointSize _ ptSize.
	name _ fontName.
	emphasis _ emphasisCode.
	minAscii _ 0.
	maxAscii _ ranges last last.
	ascent _ self primitiveFontAscent: fontHandle.
	descent _ self primitiveFontDescent: fontHandle.
	kernPairs _ Array new: (self primitiveFontNumKernPairs: fontHandle).
	1 to: kernPairs size do:[:i|
		kernPairs at: i put: (self primitiveFont: fontHandle getKernPair: i)].
	fontHeight _ ascent + descent.
	xTable _ Array new: maxAscii + 3.
	fullWidth _ Array new: maxAscii + 1.
	xStart _ maxWidth _ 0.
	rangesStream _ ReadStream on: (ranges collect: [:e | (e first to: e second)]).
	currentRange _ rangesStream next.
	0 to: maxAscii do:[:i|
		xTable at: i+1 put: xStart.
		i > currentRange last ifTrue: [
			[rangesStream atEnd not and: [currentRange _ rangesStream next. currentRange last < i]] whileTrue.
			rangesStream atEnd ifTrue: [].
		].
		(currentRange includes: i) ifTrue: [
			xTable at: i+1 put: xStart.
			fw _ self primitiveFont: fontHandle fullWidthOfChar: i.
			(#(	1 "anchored morph"
				9 "tab"
				10 "LF"
				13 "CR"
			) includes: i) ifTrue:[fw := {0. 0. 0}].
			fullWidth at: i+1 put: fw.
			w _ fw at: 2.
			(fw at: 1) > 0 ifTrue:[w _ w + (fw at: 1)].
			(fw at: 3) > 0 ifTrue:[w _ w + (fw at: 3)].
			w > maxWidth ifTrue:[maxWidth _ w].
			xStart _ xStart + w].
		].
	xStart = 0 ifTrue:[^nil].
	strikeLength _ xStart.
	xTable at: maxAscii+1 put: xStart.
	xTable at: maxAscii+2 put: xStart.
	xTable at: maxAscii+3 put: xStart.
	glyphs _ Form extent: xTable last @ fontHeight depth: 1.
	glyphForm _ Form extent: maxWidth @ fontHeight depth: 1.
	0 to: maxAscii do:[:i|
		glyphForm fillWhite.
		self primitiveFont: fontHandle glyphOfChar: i into: glyphForm.
		xStart _ xTable at: i+1.
		glyphForm displayOn: glyphs at: xStart@0.
		"glyphForm displayOn: Display at: xStart@0."
	].
	enc := self primitiveFontEncoding: fontHandle.
	enc = 1 ifTrue:[characterToGlyphMap := self isoToSqueakMap].
	self primitiveDestroyFont: fontHandle.
	^self! !

!HostFont methodsFor: 'private-creation' stamp: 'yo 2/13/2004 02:53'!
isoToSqueakMap
	^nil
! !

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

HostFont class
	instanceVariableNames: ''!

!HostFont class methodsFor: 'accessing' stamp: 'yo 2/14/2004 01:50'!
defaultRanges

	^ Array with: (Array with: 0 with: 16r2AFF).
! !

!HostFont class methodsFor: 'accessing' stamp: 'rbb 2/18/2005 13:23'!
fontNameFromUser
	"HostFont fontNameFromUser"
	| fontNames index labels |
	fontNames _ self listFontNames asSortedCollection.
	labels _ WriteStream on: (String new: 100).
	fontNames do:[:fn| labels nextPutAll: fn] separatedBy:[labels cr].
	index _ (UIManager default chooseFrom: (labels contents substrings) title: 'Choose your font').
	index = 0 ifTrue:[^nil].
	^fontNames at: index! !

!HostFont class methodsFor: 'accessing' stamp: 'ar 6/4/2000 23:18'!
listFontName: index
	<primitive:'primitiveListFont' module:'FontPlugin'>
	^nil! !

!HostFont class methodsFor: 'accessing' stamp: 'ar 6/4/2000 23:18'!
listFontNames
	"HostFont listFontNames"
	"List all the OS font names"
	| font fontNames index |
	fontNames _ WriteStream on: Array new.
	index _ 0.
	[font _ self listFontName: index.
	font == nil] whileFalse:[
		fontNames nextPut: font.
		index _ index + 1].
	^fontNames contents! !

!HostFont class methodsFor: 'accessing' stamp: 'yo 2/14/2004 01:57'!
rangesForJapanese

	| basics etc |
	basics _ {
		Array with: 0 with: 255
	}.
	etc _ {
		Array with: 16r370 with: 16r3FF. "greek"
		Array with: 16r400 with: 16r52F. "cyrillic"
		Array with: 16r1D00 with: 16r1D7F. "phonetic"
		Array with: 16r1E00 with: 16r1EFF. "latin extended additional"
		Array with: 16r2000 with: 16r206F. "general punctuation"
		Array with: 16r20A0 with: 16r20CF. "currency symbols"
		Array with: 16r2100 with: 16r214F. "letterlike"
		Array with: 16r2150 with: 16r218F. "number form"
		Array with: 16r2190 with: 16r21FF. "arrows"
		Array with: 16r2200 with: 16r22FF. "math operators"
		Array with: 16r2300 with: 16r23FF. "misc tech"
		Array with: 16r2460 with: 16r24FF. "enclosed alnum"
		Array with: 16r2500 with: 16r257F. "box drawing"
		Array with: 16r2580 with: 16r259F. "box elem"
		Array with: 16r25A0 with: 16r25FF. "geometric shapes"
		Array with: 16r2600 with: 16r26FF. "misc symbols"
		Array with: 16r2700 with: 16r27BF. "dingbats"
		Array with: 16r27C0 with: 16r27EF. "misc math A"
		Array with: 16r27F0 with: 16r27FF. "supplimental arrow A"
		Array with: 16r2900 with: 16r297F. "supplimental arrow B"
		Array with: 16r2980 with: 16r29FF. "misc math B"
		Array with: 16r2A00 with: 16r2AFF. "supplimental math op"
		Array with: 16r2900 with: 16r297F. "supplimental arrow B"
		Array with: 16r2E80 with: 16r2EFF. "cjk radicals suppliment"
		Array with: 16r2F00 with: 16r2FDF. "kangxi radicals"
		Array with: 16r3000 with: 16r303F. "cjk symbols"
		Array with: 16r3040 with: 16r309F. "hiragana"
		Array with: 16r30A0 with: 16r30FF. "katakana"
		Array with: 16r3190 with: 16r319F. "kanbun"
		Array with: 16r31F0 with: 16r31FF. "katakana extension"
		Array with: 16r3200 with: 16r32FF. "enclosed CJK"
		Array with: 16r3300 with: 16r33FF. "CJK compatibility"
		Array with: 16r3400 with: 16r4DBF. "CJK unified extension A"
		Array with: 16r4E00 with: 16r9FAF. "CJK ideograph"
		Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph"
		Array with: 16rFE30 with: 16rFE4F. "CJK compatiblity forms"
		Array with: 16rFF00 with: 16rFFEF. "half and full"
	}.

	^ basics, etc.
! !

!HostFont class methodsFor: 'accessing' stamp: 'ar 1/27/2002 19:37'!
textStyleFrom: fontName
	"HostFont textStyleFromUser"
	| styleName fonts |
	styleName _ fontName asSymbol.
	"(TextConstants includesKey: styleName)
		ifTrue:[(self confirm: 
styleName , ' is already defined in TextConstants.
Do you want to replace that definition?')
			ifFalse: [^ self]]."
	fonts _ #(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90).
	('Rendering ', styleName) displayProgressAt: Sensor cursorPoint
		from: 1 to: fonts size during:[:bar|
			fonts _ fonts
				collect:[:ptSize| bar value: (fonts indexOf: ptSize).
							   self fontName: styleName 
									size: ptSize
									emphasis: 0]
				thenSelect:[:font| font notNil]]. "reject those that failed"
	fonts size = 0 ifTrue:[^self error:'Could not create font style', styleName].
	TextConstants
		at: styleName
		put: (TextStyle fontArray: fonts).! !

!HostFont class methodsFor: 'accessing' stamp: 'ar 1/27/2002 20:12'!
textStyleFrom: fontName sizes: ptSizes
	| styleName fonts |
	styleName _ fontName asSymbol.
	(TextConstants includesKey: styleName)
		ifTrue:[(self confirm: 
styleName , ' is already defined in TextConstants.
Do you want to replace that definition?')
			ifFalse: [^ self]].
	('Rendering ', styleName) displayProgressAt: Sensor cursorPoint
		from: 1 to: ptSizes size during:[:bar|
			fonts _ ptSizes
				collect:[:ptSize| bar value: (ptSizes indexOf: ptSize).
							   self fontName: styleName 
									size: ptSize
									emphasis: 0]
				thenSelect:[:font| font notNil]]. "reject those that failed"
	fonts size = 0 ifTrue:[^self error:'Could not create font style', styleName].
	TextConstants
		at: styleName
		put: (TextStyle fontArray: fonts).! !

!HostFont class methodsFor: 'accessing' stamp: 'yo 2/14/2004 01:26'!
textStyleFrom: fontName sizes: ptSizes ranges: ranges
	| styleName fonts |
	styleName _ fontName asSymbol.
	(TextConstants includesKey: styleName)
		ifTrue:[(self confirm: 
styleName , ' is already defined in TextConstants.
Do you want to replace that definition?')
			ifFalse: [^ self]].
	('Rendering ', styleName) displayProgressAt: Sensor cursorPoint
		from: 1 to: ptSizes size during:[:bar|
			fonts _ ptSizes
				collect:[:ptSize| bar value: (ptSizes indexOf: ptSize).
							   self fontName: styleName 
									size: ptSize
									emphasis: 0 rangesArray: ranges
				]
				thenSelect:[:font| font notNil]]. "reject those that failed"
	fonts size = 0 ifTrue:[^self error:'Could not create font style', styleName].
	TextConstants
		at: styleName
		put: (TextStyle fontArray: fonts).! !

!HostFont class methodsFor: 'accessing' stamp: 'ar 8/28/2000 17:27'!
textStyleFromUser
	"HostFont textStyleFromUser"
	| styleName fonts |
	styleName _ self fontNameFromUser ifNil:[^self].
	styleName _ styleName asSymbol.
	(TextConstants includesKey: styleName)
		ifTrue:[(self confirm: 
styleName , ' is already defined in TextConstants.
Do you want to replace that definition?')
			ifFalse: [^ self]].
	fonts _ #(10 12 14 16 18 20 22 24 26 28 30 36 48 60 72 90).
	('Rendering ', styleName) displayProgressAt: Sensor cursorPoint
		from: 1 to: fonts size during:[:bar|
			fonts _ fonts
				collect:[:ptSize| bar value: (fonts indexOf: ptSize).
							   self fontName: styleName 
									size: ptSize
									emphasis: 0]
				thenSelect:[:font| font notNil]]. "reject those that failed"
	fonts size = 0 ifTrue:[^self error:'Could not create font style', styleName].
	TextConstants
		at: styleName
		put: (TextStyle fontArray: fonts).! !


!HostFont class methodsFor: 'instance creation' stamp: 'ar 6/4/2000 23:13'!
fontName: fontName size: ptSize emphasis: emphasisCode
	"
		^HostFont fontName: (HostFont fontNameFromUser) size: 12 emphasis: 0.
	"
	^self new fontName: fontName size: ptSize emphasis: emphasisCode! !

!HostFont class methodsFor: 'instance creation' stamp: 'yo 2/14/2004 01:17'!
fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: ranges
	"
		^HostFont fontName: (HostFont fontNameFromUser) size: 12 emphasis: 0.
	"
	^self new fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: ranges! !


!HostFont class methodsFor: 'system defaults' stamp: 'yo 3/17/2004 00:39'!
initForSubtitles
"
	HostFont initForSubtitles
"

	HostFont textStyleFrom: 'Verdana' sizes: #(18 20 22 24 26 28) ranges: HostFont defaultRanges.

	StrikeFontSet installExternalFontFileName: 'greekFont.out' encoding: GreekEnvironment leadingChar encodingName: #Greek textStyleName: #DefaultMultiStyle.


	TTCFontReader encodingTag: SimplifiedChineseEnvironment leadingChar.
	TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\simhei.TTF'.

	TTCFontReader encodingTag: JapaneseEnvironment leadingChar.
	TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\msgothic.TTC'.

	TTCFontReader encodingTag: KoreanEnvironment leadingChar.
	TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\gulim.TTC'.
! !

!HostFont class methodsFor: 'system defaults' stamp: 'yo 2/13/2004 23:25'!
initWin32
	"HostFont initWin32"
	#(
			"Basic fonts"
			('Arial'				"menu/text serifless"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))
			('Times New Roman'	"menu/text serifs"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))
			('Courier New'			"menu/text fixed"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))
			('Wingdings'			"deco"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))
			('Symbol'				"deco"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))

			"Nice fonts"
			('Verdana'			"menu/text serifless"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))

			('Tahoma'			"menu/text serifless"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))

			('Garamond'			"menu/text serifs"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))
			('Georgia'			"menu/text serifs"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))

			('Comic Sans MS'	"eToy"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))

			"Optional fonts"
			('Impact'			"flaps"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))

			('Webdings'			"deco"
				(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90))

			('System'		"12pt only"
				(12))
			('Fixedsys'		"12pt only"
				(12))
		) do:[:spec| HostFont textStyleFrom: spec first sizes: spec last].

	TextConstants removeKey: #Atlanta ifAbsent: [].
	TextConstants removeKey: #ComicPlain ifAbsent: [].
	TextConstants removeKey: #ComicBold ifAbsent: [].
	TextConstants removeKey: #Courier ifAbsent: [].
	TextConstants removeKey: #Palatino ifAbsent: [].

	TextConstants at: #DefaultFixedTextStyle put: (TextConstants at: #'Courier New').
	TextConstants at: #Helvetica put:  (TextConstants at: #'Arial').

! !

!HostFont class methodsFor: 'system defaults' stamp: 'yo 12/2/2004 12:50'!
unloadAsianTT
"
	self unloadAsianTT
"

	TTCFontSet removeStyleName: 'MultiSimHei'.
	TTCFontSet removeStyleName: 'MultiMSGothic'.
	TTCFontSet removeStyleName: 'MultiGulim'.
! !
CrLfFileStream subclass: #HtmlFileStream
	instanceVariableNames: 'prevPreamble'
	classVariableNames: 'TabThing'
	poolDictionaries: ''
	category: 'Files-Kernel'!
!HtmlFileStream commentStamp: 'mk 8/30/2005 15:10' prior: 0!
The Class apes StandardFileStream, but converts the text to HTML before putting it out (primarily intended for printOut).  It can be invoked with

	((FileStream fileNamed: 'changes.html') asHtml) fileOutChanges

Use usual FileStream methods to put out text converted to
	HTML fairly approximating that text  (for best looks, use 
	method:, methodHeader:, methodBody:, for code);

verbatim: puts text out without conversion;

command: put out HTML items, such as <br>, supplying the brackets.

header: and trailer: put out an HTML wrapper (preamble and closing text)

nextPut does the actual conversion, nextPutAll: defers characters to nextPut.

The code is fairly dumb at present, doing a wooden straightforward conversion of the text without attempting to capture the style or fonts in which the original text was rendered.  Tabs are handled awkwardly, using &nbsp, so that probably only leading strings are working right.  Style sheets now permit us to do a much neater looking job if there is interest in improving the looks of things.

Example:
	Perform
		HtmlFileStream example1
	and then navigate your browser to file 'example1.html'!


!HtmlFileStream methodsFor: 'fileIn/Out' stamp: 'stephaneducasse 2/4/2006 20:31'!
copyMethodChunkFrom: aStream
	"Overridden to bolden the first line (presumably a method header)"
	| terminator code firstLine |
	terminator := $!!.
	aStream skipSeparators.
	code := aStream upTo: terminator.
	firstLine := code copyUpTo: Character cr.
	firstLine size = code size
		ifTrue: [self nextPutAll: code]
		ifFalse: [self command: 'b'; nextPutAll: firstLine; command: '/b'.
				self nextPutAll: (code copyFrom: firstLine size + 1 to: code size)].
	self nextPut: terminator.
	[aStream peekFor: terminator] whileTrue:   "case of imbedded (doubled) terminators"
			[self nextPut: terminator;
				nextPutAll: (aStream upTo: terminator);
				nextPut: terminator]! !

!HtmlFileStream methodsFor: 'fileIn/Out' stamp: 'stephaneducasse 2/4/2006 20:31'!
nextChunk
	"Answer the contents of the receiver, up to the next terminator character (!!).  Imbedded terminators are doubled.  Undo and strip out all Html stuff in the stream and convert the characters back.  4/12/96 tk"
	| out char did rest |
	self skipSeparators.	"Absorb <...><...> also"
	out := WriteStream on: (String new: 500).
	[self atEnd] whileFalse: [
		self peek = $< ifTrue: [self unCommand].	"Absorb <...><...>"
		(char := self next) = $&
			ifTrue: [
				rest := self upTo: $;.
				did := out position.
				rest = 'lt' ifTrue: [out nextPut: $<].
				rest = 'gt' ifTrue: [out nextPut: $>].
				rest = 'amp' ifTrue: [out nextPut: $&].
				did = out position ifTrue: [
					self error: 'new HTML char encoding'.
					"Please add it to this code"]]
			ifFalse: [char = $!!	"terminator"
				ifTrue: [
					self peek = $!! ifFalse: [^ out contents].
					out nextPut: self next]	"pass on one $!!"
				ifFalse: [char asciiValue = 9
							ifTrue: [self next; next; next; next "TabThing"].
						out nextPut: char]]
		].
	^ out contents! !

!HtmlFileStream methodsFor: 'fileIn/Out' stamp: 'stephaneducasse 2/4/2006 20:31'!
skipSeparators
	"Bsides the normal spacers, also skip any <...>, html commands.
	4/12/96 tk"
	| did |
	[did := self position.
		super skipSeparators.
		self unCommand.	"Absorb <...><...>"
		did = self position] whileFalse.	"until no change"
! !


!HtmlFileStream methodsFor: 'HTML'!
command: aString
	"Append HTML commands directly without translation.  Caller should not include < or >.  Note that font change info comes through here!!  4/5/96 tk"

	(aString includes: $<) ifTrue: [self error: 'Do not put < or > in arg'].
		"We do the wrapping with <> here!!  Don't put it in aString."
	^ self verbatim: '<', aString, '>'! !


!HtmlFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:31'!
header
	"append the HTML header.  Be sure to call trailer after you put out the data.
	4/4/96 tk"
	| cr |
	cr := String with: Character cr.
	self command: 'HTML'; verbatim: cr.
	self command: 'HEAD'; verbatim: cr.
	self command: 'TITLE'.
	self nextPutAll: '"', self name, '"'.
	self command: '/TITLE'; verbatim: cr.
	self command: '/HEAD'; verbatim: cr.
	self command: 'BODY'; verbatim: cr.
! !

!HtmlFileStream methodsFor: 'read, write, position' stamp: 'acg 01/01/1999 13:59'!
nextPut: char
	"Put a character on the file, but translate it first. 4/6/96 tk 1/1/98 acg"
	char = $< ifTrue: [^ super nextPutAll: '&lt;'].
	char = $> ifTrue: [^ super nextPutAll: '&gt;'].
	char = $& ifTrue: [^ super nextPutAll: '&amp;'].
	char asciiValue = 13 "return" 
		ifTrue: [self command: 'br'].
	char = $	"tab" 
		ifTrue: [self verbatim: TabThing. ^super nextPut: char].
	^ super nextPut: char! !

!HtmlFileStream methodsFor: 'read, write, position'!
nextPutAll: aString
	"Write the whole string, translating as we go. 4/6/96 tk"
	"Slow, but faster than using aString asHtml?"

	aString do: [:each | self nextPut: each].! !

!HtmlFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:31'!
trailer
	"append the HTML trailer.  Call this just before file close.
	4/4/96 tk"
	| cr |
	cr := String with: Character cr.
	self command: '/BODY'; verbatim: cr.
	self command: '/HTML'; verbatim: cr.
! !

!HtmlFileStream methodsFor: 'read, write, position' stamp: 'acg 01/02/1999 00:38'!
verbatim: aString
	"Put out the string without HTML conversion. 1/1/99 acg"

	super nextPutAll: aString

	"'super verbatim:' in the 2.3beta draft didn't perform as expected -- the code was printed with conversion.  In a sense, that wouldn't make sense either -- we don't want strictly verbatim printing, just printing without the HTML conversion (that is, skipping around just the nextPut: and nextPutAll: for just this Class).  If there were intermediate conversions (say, CRLF!!), we would want those to happen as advertised -- perhaps we should use a differently named selector, perhaps something like nextPutWithoutHTMLConversion:, so that verbatim isn't overridden?"! !

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

HtmlFileStream class
	instanceVariableNames: ''!

!HtmlFileStream class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:32'!
initialize   "HtmlFileStream initialize"
	TabThing := '&nbsp;&nbsp;&nbsp;'

"I took Ted's suggestion to use &nbsp, which works far better for the HTML.  Style sheets provide an alternative, possibly better, solution since they permit finer-grain control of the HTML formatting, and thus would permit capturing the style in which text was originally rendered.  Internal tabbings would still get lost. 1/1/99 acg."! !


!HtmlFileStream class methodsFor: 'examples' stamp: 'stephaneducasse 2/4/2006 20:32'!
example1
	"This example shows how HtmlFileStream class can be used for generating HTML file."

	| htmlFileStream |
	htmlFileStream := HtmlFileStream newFrom: (FileStream fileNamed: 'example1.html').
	htmlFileStream
		header;
		command: 'H1';
		nextPutAll: 'Hello, world!!';
		command: '/H1';
		trailer;
		close.! !


!HtmlFileStream class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
newFrom: aFileStream
	"Answer an HtmlFileStream that is 'like' aFileStream.  As a side-effect, the surviving fileStream answered by this method replaces aFileStream on the finalization registry. 1/6/99 acg"

	|inst|
	inst := super newFrom: aFileStream.
	StandardFileStream unregister: aFileStream.
	HtmlFileStream register: inst.
	inst detectLineEndConvention.
	^inst
! !
HierarchicalUrl subclass: #HttpUrl
	instanceVariableNames: 'realm'
	classVariableNames: 'Passwords'
	poolDictionaries: ''
	category: 'Network-Url'!
!HttpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0!
A URL that can be accessed via the Hypertext Transfer Protocol (HTTP), ie, a standard Web URL

realm = the name of the security realm that has been discovered for this URL.   Look it up in Passwords.

Passwords = a Dictionary of (realm -> encoded user&password)


TODO: use the username and password, if specified
!


!HttpUrl methodsFor: 'downloading' stamp: 'rbb 3/1/2005 10:57'!
askNamePassword
	"Authorization is required by the host site.  Ask the user for a userName and password.  Encode them and store under this realm.  Return false if the user wants to give up."

	| user pass |
	(self confirm: 'Host ', self toText, '
wants a different user and password.  Type them now?' orCancel: [false])
		ifFalse: [^ false].
	user := UIManager default request: 'User account name?' initialAnswer: '' 
				centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint - (50@0).
	pass := UIManager default requestPassword: 'Password?'.
	Passwords at: realm put: (Authorizer new encode: user password: pass).
	^ true! !

!HttpUrl methodsFor: 'downloading' stamp: 'nk 8/30/2004 07:50'!
checkAuthorization: webDocument retry: retryBlock
	"authorization failed if webDocument is a String"
	| oldRealm i end encoded |
	((webDocument isString)
		and: [(webDocument beginsWith: 'HTTP/1.0 401')
			or: [webDocument beginsWith: 'HTTP/1.1 401']])
	ifFalse: [^self].

	oldRealm _ realm.
	i _ webDocument findString: 'realm="'.
	i = 0 ifTrue: [^self].
	end _ webDocument indexOf: $" startingAt: i.
	realm _ webDocument copyFrom: i+7 to: end.
	"realm _ (webDocument findTokens: '""') at: 2."
	Passwords ifNil: [Passwords _ Dictionary new].
	encoded _ Passwords at: realm ifAbsent: [nil].
	(oldRealm ~= realm) & (encoded ~~ nil) 
		ifTrue: [^ retryBlock value]
		ifFalse: ["ask the user"
			self askNamePassword ifTrue: [^ retryBlock value]]! !

!HttpUrl methodsFor: 'downloading' stamp: 'mir 10/13/1999 19:41'!
loadRemoteObjects
	"Load a remote image segment and extract the root objects.
	Check if the remote file is a zip archive."
	"'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.extSeg' 
		asUrl loadRemoteObjects" 
	"'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.zip' 
		asUrl loadRemoteObjects" 

	| stream info data extension |
 	data _ self retrieveContents content.
	extension _ (FileDirectory extensionFor: self path last) asLowercase.
	(#('zip' 'gzip') includes: extension)
		ifTrue: [data _ (GZipReadStream on: data) upToEnd].
"	stream _ StreamWrapper streamOver: (ReadStream on: data)."
	stream _ RWBinaryOrTextStream on: data.
	stream reset.
	info _ stream fileInObjectAndCode.
	stream close.
	^info arrayOfRoots! !

!HttpUrl methodsFor: 'downloading' stamp: 'fbs 2/2/2005 13:24'!
normalizeContents: webDocument
	(webDocument isString) ifTrue: [
		^MIMEDocument
			contentType: 'text/plain'
			content: 'error occured retrieving ', self asString, ': ', webDocument
			url: (Url absoluteFromText: '')].
	webDocument contentType = MIMEDocument defaultContentType ifTrue: [
		^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) 
			content: webDocument content url: webDocument url ].

	^webDocument! !

!HttpUrl methodsFor: 'downloading' stamp: 'fbs 2/2/2005 13:24'!
postFormArgs: args
	| contents request |
	request _ realm ifNotNil: [Passwords at: realm ifAbsent: ['']]
		ifNil: [''].
	request = '' ifFalse: [request _ 'Authorization: Basic ', request, String crlf].
		"Why doesn't Netscape send the name of the realm instead of Basic?"
	contents _ (HTTPSocket httpPostDocument: self asString args: args
				accept: 'application/octet-stream' request: request).

	self checkAuthorization: contents retry: [^ self postFormArgs: args].

	^self normalizeContents: contents! !

!HttpUrl methodsFor: 'downloading' stamp: 'fbs 2/2/2005 13:24'!
postMultipartFormArgs: args
	| contents request |
	request _ realm ifNotNil: [Passwords at: realm ifAbsent: ['']]
		ifNil: [''].
	request = '' ifFalse: [request _ 'Authorization: Basic ', request, String crlf].
		"Why doesn't Netscape send the name of the realm instead of Basic?"
	contents _ (HTTPSocket httpPostMultipart: self asString args: args
				accept: 'application/octet-stream' request: request).

	self checkAuthorization: contents retry: [^ self postMultipartFormArgs: args].

	^self normalizeContents: contents! !

!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 19:49'!
privateInitializeFromText: aString relativeTo: aUrl

	super privateInitializeFromText: aString relativeTo: aUrl.
	realm _ aUrl realm.! !

!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 19:47'!
realm
	^ realm! !

!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 20:21'!
retrieveContents
	^ self retrieveContentsArgs: nil! !

!HttpUrl methodsFor: 'downloading'!
retrieveContentsAccept: mimeType
	^ self retrieveContentsArgs: nil accept: mimeType! !

!HttpUrl methodsFor: 'downloading' stamp: 'EW 4/30/2006 12:00'!
retrieveContentsArgs: args
	^self retrieveContentsArgs: args accept: '*/*; q=1'! !

!HttpUrl methodsFor: 'downloading' stamp: 'fbs 2/2/2005 13:24'!
retrieveContentsArgs: args accept: mimeType
	| contents request |
	request _ realm ifNotNil: [Passwords at: realm ifAbsent: ['']] ifNil: [''].
	request = '' ifFalse: [request _ 'Authorization: Basic ' , request , String crlf].
		"Why doesn't Netscape send the name of the realm instead of Basic?"

	contents _ (HTTPSocket
		httpGetDocument: self withoutFragment asString
		args: args
		accept: mimeType
		request: request).

	self checkAuthorization: contents retry: [^ self retrieveContentsArgs: args].

	^ self normalizeContents: contents! !


!HttpUrl methodsFor: 'testing' stamp: 'ar 2/27/2001 22:08'!
hasRemoteContents
	"Return true if the receiver describes some remotely accessible content.
	Typically, this should only return if we could retrieve the contents
	on an arbitrary place in the outside world using a standard browser.
	In other words: If you can get to it from the next Internet Cafe, 
	return true, else return false."
	^true! !

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

HttpUrl class
	instanceVariableNames: ''!

!HttpUrl class methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 23:13'!
shutDown
	"Forget all cached passwords, so they won't stay in the image"

	Passwords _ nil.! !
ClipboardInterpreter subclass: #ISO88592ClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!ISO88592ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 08:35'!
fromSystemClipboard: aString

	^ aString convertFromWithConverter: ISO88592TextConverter new.
! !

!ISO88592ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'pk 1/4/2005 03:56'!
toSystemClipboard: aString

	| result converter r |

	aString isAsciiString ifTrue: [^ aString asOctetString]. "optimization"

	result _ WriteStream on: (String new: aString size).
	converter _ ISO88592TextConverter new.
	aString do: [:each |
		r _ converter fromSqueak: each.].
	^ result contents.
! !
KeyboardInputInterpreter subclass: #ISO88592InputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!ISO88592InputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 08:58'!
initialize

	converter _ ISO88592TextConverter new.
! !

!ISO88592InputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 08:58'!
nextCharFrom: sensor firstEvt: evtBuf

	| keyValue |
	keyValue := evtBuf third.
	^ converter toSqueak: keyValue asCharacter.
! !
TextConverter subclass: #ISO88592TextConverter
	instanceVariableNames: ''
	classVariableNames: 'FromTable'
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!ISO88592TextConverter commentStamp: '<historical>' prior: 0!
Text converter for ISO 8859-2.  An international encoding used in Eastern Europe.!


!ISO88592TextConverter methodsFor: 'conversion' stamp: 'yo 1/18/2005 08:30'!
nextFromStream: aStream

	| character1 |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	^ self toSqueak: character1.
! !

!ISO88592TextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:28'!
nextPut: aCharacter toStream: aStream

	aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream].
	aCharacter charCode < 128 ifTrue: [
		aStream basicNextPut: aCharacter.
	] ifFalse: [
		aStream basicNextPut: ((Character value: (self fromSqueak: aCharacter) charCode)).
	].

! !


!ISO88592TextConverter methodsFor: 'private' stamp: 'yo 2/9/2005 05:29'!
fromSqueak: char

	^ Character value: (FromTable at: char charCode ifAbsent: [char asciiValue])! !

!ISO88592TextConverter methodsFor: 'private' stamp: 'ar 4/9/2005 22:30'!
toSqueak: char

	| value |
	value _ char charCode.

	value < 160 ifTrue: [^ char].
	value > 255 ifTrue: [^ char].
	^ Character leadingChar: Latin2Environment leadingChar code: (#(
16r00A0 16r0104 16r02D8 16r0141 16r00A4 16r013D 16r015A 16r00A7
16r00A8 16r0160 16r015E 16r0164 16r0179 16r00AD 16r017D 16r017B
16r00B0 16r0105 16r02DB 16r0142 16r00B4 16r013E 16r015B 16r02C7
16r00B8 16r0161 16r015F 16r0165 16r017A 16r02DD 16r017E 16r017C
16r0154 16r00C1 16r00C2 16r0102 16r00C4 16r0139 16r0106 16r00C7
16r010C 16r00C9 16r0118 16r00CB 16r011A 16r00CD 16r00CE 16r010E
16r0110 16r0143 16r0147 16r00D3 16r00D4 16r0150 16r00D6 16r00D7
16r0158 16r016E 16r00DA 16r0170 16r00DC 16r00DD 16r0162 16r00DF
16r0155 16r00E1 16r00E2 16r0103 16r00E4 16r013A 16r0107 16r00E7
16r010D 16r00E9 16r0119 16r00EB 16r011B 16r00ED 16r00EE 16r010F
16r0111 16r0144 16r0148 16r00F3 16r00F4 16r0151 16r00F6 16r00F7
16r0159 16r016F 16r00FA 16r0171 16r00FC 16r00FD 16r0163 16r02D9
) at: (value - 160 + 1)).
! !

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

ISO88592TextConverter class
	instanceVariableNames: ''!

!ISO88592TextConverter class methodsFor: 'class initialization' stamp: 'yo 1/18/2005 09:17'!
initialize
"
	self initialize
"
	FromTable _ Dictionary new.

	FromTable at: 16r00A0 put: 16rA0.	
	FromTable at: 16r0104 put: 16rA1.	
	FromTable at: 16r02D8 put: 16rA2.	
	FromTable at: 16r0141 put: 16rA3.	
	FromTable at: 16r00A4 put: 16rA4.	
	FromTable at: 16r013D put: 16rA5.	
	FromTable at: 16r015A put: 16rA6.	
	FromTable at: 16r00A7 put: 16rA7.	
	FromTable at: 16r00A8 put: 16rA8.	
	FromTable at: 16r0160 put: 16rA9.	
	FromTable at: 16r015E put: 16rAA.	
	FromTable at: 16r0164 put: 16rAB.	
	FromTable at: 16r0179 put: 16rAC.	
	FromTable at: 16r00AD put: 16rAD.	
	FromTable at: 16r017D put: 16rAE.	
	FromTable at: 16r017B put: 16rAF.	
	FromTable at: 16r00B0 put: 16rB0.	
	FromTable at: 16r0105 put: 16rB1.	
	FromTable at: 16r02DB put: 16rB2.	
	FromTable at: 16r0142 put: 16rB3.	
	FromTable at: 16r00B4 put: 16rB4.	
	FromTable at: 16r013E put: 16rB5.	
	FromTable at: 16r015B put: 16rB6.	
	FromTable at: 16r02C7 put: 16rB7.	
	FromTable at: 16r00B8 put: 16rB8.	
	FromTable at: 16r0161 put: 16rB9.	
	FromTable at: 16r015F put: 16rBA.	
	FromTable at: 16r0165 put: 16rBB.	
	FromTable at: 16r017A put: 16rBC.	
	FromTable at: 16r02DD put: 16rBD.	
	FromTable at: 16r017E put: 16rBE.	
	FromTable at: 16r017C put: 16rBF.	
	FromTable at: 16r0154 put: 16rC0.	
	FromTable at: 16r00C1 put: 16rC1.	
	FromTable at: 16r00C2 put: 16rC2.	
	FromTable at: 16r0102 put: 16rC3.	
	FromTable at: 16r00C4 put: 16rC4.	
	FromTable at: 16r0139 put: 16rC5.	
	FromTable at: 16r0106 put: 16rC6.	
	FromTable at: 16r00C7 put: 16rC7.	
	FromTable at: 16r010C put: 16rC8.	
	FromTable at: 16r00C9 put: 16rC9.	
	FromTable at: 16r0118 put: 16rCA.	
	FromTable at: 16r00CB put: 16rCB.	
	FromTable at: 16r011A put: 16rCC.	
	FromTable at: 16r00CD put: 16rCD.	
	FromTable at: 16r00CE put: 16rCE.	
	FromTable at: 16r010E put: 16rCF.	
	FromTable at: 16r0110 put: 16rD0.	
	FromTable at: 16r0143 put: 16rD1.	
	FromTable at: 16r0147 put: 16rD2.	
	FromTable at: 16r00D3 put: 16rD3.	
	FromTable at: 16r00D4 put: 16rD4.	
	FromTable at: 16r0150 put: 16rD5.	
	FromTable at: 16r00D6 put: 16rD6.	
	FromTable at: 16r00D7 put: 16rD7.	
	FromTable at: 16r0158 put: 16rD8.	
	FromTable at: 16r016E put: 16rD9.	
	FromTable at: 16r00DA put: 16rDA.	
	FromTable at: 16r0170 put: 16rDB.	
	FromTable at: 16r00DC put: 16rDC.	
	FromTable at: 16r00DD put: 16rDD.	
	FromTable at: 16r0162 put: 16rDE.	
	FromTable at: 16r00DF put: 16rDF.	
	FromTable at: 16r0155 put: 16rE0.	
	FromTable at: 16r00E1 put: 16rE1.	
	FromTable at: 16r00E2 put: 16rE2.	
	FromTable at: 16r0103 put: 16rE3.	
	FromTable at: 16r00E4 put: 16rE4.	
	FromTable at: 16r013A put: 16rE5.	
	FromTable at: 16r0107 put: 16rE6.	
	FromTable at: 16r00E7 put: 16rE7.	
	FromTable at: 16r010D put: 16rE8.	
	FromTable at: 16r00E9 put: 16rE9.	
	FromTable at: 16r0119 put: 16rEA.	
	FromTable at: 16r00EB put: 16rEB.	
	FromTable at: 16r011B put: 16rEC.	
	FromTable at: 16r00ED put: 16rED.	
	FromTable at: 16r00EE put: 16rEE.	
	FromTable at: 16r010F put: 16rEF.	
	FromTable at: 16r0111 put: 16rF0.	
	FromTable at: 16r0144 put: 16rF1.	
	FromTable at: 16r0148 put: 16rF2.	
	FromTable at: 16r00F3 put: 16rF3.	
	FromTable at: 16r00F4 put: 16rF4.	
	FromTable at: 16r0151 put: 16rF5.	
	FromTable at: 16r00F6 put: 16rF6.	
	FromTable at: 16r00F7 put: 16rF7.	
	FromTable at: 16r0159 put: 16rF8.	
	FromTable at: 16r016F put: 16rF9.	
	FromTable at: 16r00FA put: 16rFA.	
	FromTable at: 16r0171 put: 16rFB.	
	FromTable at: 16r00FC put: 16rFC.	
	FromTable at: 16r00FD put: 16rFD.	
	FromTable at: 16r0163 put: 16rFE.	
	FromTable at: 16r02D9 put: 16rFF.	
! !


!ISO88592TextConverter class methodsFor: 'utilities' stamp: 'yo 1/18/2005 09:17'!
encodingNames 

	^ #('iso-8859-2') copy
! !
TextConverter subclass: #ISO88597TextConverter
	instanceVariableNames: ''
	classVariableNames: 'FromTable'
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!ISO88597TextConverter commentStamp: '<historical>' prior: 0!
Text converter for ISO 8859-7.  An international encoding used for Greek.!


!ISO88597TextConverter methodsFor: 'conversion' stamp: 'yo 2/10/2004 06:28'!
nextFromStream: aStream

	| character1 |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	^ self toSqueak: character1.
! !

!ISO88597TextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:28'!
nextPut: aCharacter toStream: aStream

	aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream].
	aCharacter charCode < 128 ifTrue: [
		aStream basicNextPut: aCharacter.
	] ifFalse: [
		aStream basicNextPut: ((Character value: (self fromSqueak: aCharacter) charCode)).
	].

! !


!ISO88597TextConverter methodsFor: 'private' stamp: 'yo 2/9/2005 05:29'!
fromSqueak: char

	^ Character value: (FromTable at: char charCode ifAbsent: [char asciiValue])! !

!ISO88597TextConverter methodsFor: 'private' stamp: 'ar 4/9/2005 22:30'!
toSqueak: char

	| value |
	value _ char charCode.

	value < 160 ifTrue: [^ char].
	value > 255 ifTrue: [^ char].
	^ Character leadingChar: GreekEnvironment leadingChar code: (#(
16r00A0 16r2018 16r2019 16r00A3 16r20AC 16r20AF 16r00A6 16r00A7
16r00A8 16r00A9 16r037A 16r00AB 16r00AC 16r00AD 16rFFFD 16r2015
16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r0385 16r0386 16r00B7
16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F
16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397
16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F
16r03A0 16r03A1 16rFFFD 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7
16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF
16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7
16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF
16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7
16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE 16rFFFD
) at: (value - 160 + 1)).
! !

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

ISO88597TextConverter class
	instanceVariableNames: ''!

!ISO88597TextConverter class methodsFor: 'class initialization' stamp: 'yo 2/9/2004 17:36'!
initialize
"
	self initialize
"
	FromTable _ Dictionary new.

	FromTable at: 16r00A0 put: 16rA0.
	FromTable at: 16r2018 put: 16rA1.
	FromTable at: 16r2019 put: 16rA2.
	FromTable at: 16r00A3 put: 16rA3.
	FromTable at: 16r20AC put: 16rA4.
	FromTable at: 16r20AF put: 16rA5.
	FromTable at: 16r00A6 put: 16rA6.
	FromTable at: 16r00A7 put: 16rA7.
	FromTable at: 16r00A8 put: 16rA8.
	FromTable at: 16r00A9 put: 16rA9.
	FromTable at: 16r037A put: 16rAA.
	FromTable at: 16r00AB put: 16rAB.
	FromTable at: 16r00AC put: 16rAC.
	FromTable at: 16r00AD put: 16rAD.
	FromTable at: 16r2015 put: 16rAF.
	FromTable at: 16r00B0 put: 16rB0.
	FromTable at: 16r00B1 put: 16rB1.
	FromTable at: 16r00B2 put: 16rB2.
	FromTable at: 16r00B3 put: 16rB3.
	FromTable at: 16r0384 put: 16rB4.
	FromTable at: 16r0385 put: 16rB5.
	FromTable at: 16r0386 put: 16rB6.
	FromTable at: 16r00B7 put: 16rB7.
	FromTable at: 16r0388 put: 16rB8.
	FromTable at: 16r0389 put: 16rB9.
	FromTable at: 16r038A put: 16rBA.
	FromTable at: 16r00BB put: 16rBB.
	FromTable at: 16r038C put: 16rBC.
	FromTable at: 16r00BD put: 16rBD.
	FromTable at: 16r038E put: 16rBE.
	FromTable at: 16r038F put: 16rBF.
	FromTable at: 16r0390 put: 16rC0.
	FromTable at: 16r0391 put: 16rC1.
	FromTable at: 16r0392 put: 16rC2.
	FromTable at: 16r0393 put: 16rC3.
	FromTable at: 16r0394 put: 16rC4.
	FromTable at: 16r0395 put: 16rC5.
	FromTable at: 16r0396 put: 16rC6.
	FromTable at: 16r0397 put: 16rC7.
	FromTable at: 16r0398 put: 16rC8.
	FromTable at: 16r0399 put: 16rC9.
	FromTable at: 16r039A put: 16rCA.
	FromTable at: 16r039B put: 16rCB.
	FromTable at: 16r039C put: 16rCC.
	FromTable at: 16r039D put: 16rCD.
	FromTable at: 16r039E put: 16rCE.
	FromTable at: 16r039F put: 16rCF.
	FromTable at: 16r03A0 put: 16rD0.
	FromTable at: 16r03A1 put: 16rD1.
	FromTable at: 16r03A3 put: 16rD3.
	FromTable at: 16r03A4 put: 16rD4.
	FromTable at: 16r03A5 put: 16rD5.
	FromTable at: 16r03A6 put: 16rD6.
	FromTable at: 16r03A7 put: 16rD7.
	FromTable at: 16r03A8 put: 16rD8.
	FromTable at: 16r03A9 put: 16rD9.
	FromTable at: 16r03AA put: 16rDA.
	FromTable at: 16r03AB put: 16rDB.
	FromTable at: 16r03AC put: 16rDC.
	FromTable at: 16r03AD put: 16rDD.
	FromTable at: 16r03AE put: 16rDE.
	FromTable at: 16r03AF put: 16rDF.
	FromTable at: 16r03B0 put: 16rE0.
	FromTable at: 16r03B1 put: 16rE1.
	FromTable at: 16r03B2 put: 16rE2.
	FromTable at: 16r03B3 put: 16rE3.
	FromTable at: 16r03B4 put: 16rE4.
	FromTable at: 16r03B5 put: 16rE5.
	FromTable at: 16r03B6 put: 16rE6.
	FromTable at: 16r03B7 put: 16rE7.
	FromTable at: 16r03B8 put: 16rE8.
	FromTable at: 16r03B9 put: 16rE9.
	FromTable at: 16r03BA put: 16rEA.
	FromTable at: 16r03BB put: 16rEB.
	FromTable at: 16r03BC put: 16rEC.
	FromTable at: 16r03BD put: 16rED.
	FromTable at: 16r03BE put: 16rEE.
	FromTable at: 16r03BF put: 16rEF.
	FromTable at: 16r03C0 put: 16rF0.
	FromTable at: 16r03C1 put: 16rF1.
	FromTable at: 16r03C2 put: 16rF2.
	FromTable at: 16r03C3 put: 16rF3.
	FromTable at: 16r03C4 put: 16rF4.
	FromTable at: 16r03C5 put: 16rF5.
	FromTable at: 16r03C6 put: 16rF6.
	FromTable at: 16r03C7 put: 16rF7.
	FromTable at: 16r03C8 put: 16rF8.
	FromTable at: 16r03C9 put: 16rF9.
	FromTable at: 16r03CA put: 16rFA.
	FromTable at: 16r03CB put: 16rFB.
	FromTable at: 16r03CC put: 16rFC.
	FromTable at: 16r03CD put: 16rFD.
	FromTable at: 16r03CE put: 16rFE.
! !


!ISO88597TextConverter class methodsFor: 'utilities' stamp: 'yo 2/10/2004 06:32'!
encodingNames 

	^ #('iso-8859-7' 'greek-iso-8859-8bit') copy
! !
Object subclass: #ISOLanguageDefinition
	instanceVariableNames: 'iso3 iso2 iso3Alternate language'
	classVariableNames: 'ISO2Countries ISO2Table ISO3Countries ISO3Table'
	poolDictionaries: ''
	category: 'System-Localization'!

!ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:20'!
iso2
	^iso2 ifNil: [self iso3]! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:21'!
iso3
	^iso3 ifNil: ['']! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 6/30/2004 15:47'!
iso3Alternate
	^iso3Alternate ifNil: ['']! !

!ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 8/15/2003 13:13'!
language
	^language! !


!ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'!
iso2: aString
	iso2 := aString ifEmpty: [nil] ifNotEmpty: [aString]! !

!ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'!
iso3: aString
	iso3 := aString ifEmpty: [nil] ifNotEmpty: [aString]! !

!ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'!
iso3Alternate: aString
	iso3Alternate := aString ifEmpty: [nil] ifNotEmpty: [aString]! !

!ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 8/15/2003 13:40'!
language: aString
	language := aString! !

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

ISOLanguageDefinition class
	instanceVariableNames: ''!

!ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'!
iso2LanguageDefinition: aString
	^self iso2LanguageTable at: aString! !

!ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'!
iso3LanguageDefinition: aString
	^self iso3LanguageTable at: aString! !


!ISOLanguageDefinition class methodsFor: 'class initialization' stamp: 'mir 7/1/2004 18:19'!
initialize
	"ISOLanguageDefinition initialize"

	ISO3Table := nil.
	ISO2Table := nil! !


!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:06'!
buildIso3166CodesTables
	"ISOLanguageDefinition buildIso3166CodesTables"
	| rawdata stream country isoa2 isoa3 unNumeric macName macCode windowsName windowsCode empty table |
	rawdata := self iso3166Codes.
	table := OrderedCollection new: 200. 
	stream := rawdata readStream.
	empty := 160 asCharacter asString.
	[stream atEnd] whileFalse: 
		[country := stream nextLine.
		isoa2 := stream nextLine.
		isoa3 := stream nextLine.
		unNumeric := stream nextLine.
		windowsName := stream nextLine.
		windowsName = empty ifTrue: [windowsName := nil].
		windowsCode := stream nextLine. 
		windowsCode = empty ifTrue: [windowsCode := nil].
		macName := stream nextLine.
		macName = empty ifTrue: [macName := nil].
		macCode := stream nextLine.
		macCode = empty ifTrue: [macCode := nil].
		table add: { country.  isoa2. isoa3.  unNumeric. windowsName.  windowsCode.  macName. macCode. }].
	^table! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:14'!
extraCountryDefinitions
	^{
	{'Kids'. 'KIDS'. 'KIDS'.}.
	}! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:14'!
extraISO3Definitions

	^self readISOLanguagesFrom: 'jpk		Japanese (Kids)
' readStream! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:13'!
initISO3LanguageTable
	"ISOLanguageDefinition initIso3LanguageTable"

	| table |
	table := ISOLanguageDefinition readISOLanguagesFrom: ISOLanguageDefinition isoLanguages readStream.
	table addAll: self extraISO3Definitions.
	^table! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:12'!
initISOCountries
	"ISOLanguageDefinition initISOCountries"
	| iso3166Table |
	iso3166Table := ISOLanguageDefinition buildIso3166CodesTables.
	ISO2Countries := Dictionary new.
	ISO3Countries := Dictionary new.
	iso3166Table do: [:entry | 
		ISO2Countries at: (entry at: 2) put: (entry at: 1).
		ISO3Countries at: (entry at: 3) put: (entry at: 1)].
	self extraCountryDefinitions do: [:entry | 
		ISO2Countries at: (entry at: 2) put: (entry at: 1).
		ISO3Countries at: (entry at: 3) put: (entry at: 1)]! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:18'!
iso2Countries
	"ISOLanguageDefinition iso2Countries"
	"ISO2Countries := nil. ISO3Countries := nil"

	ISO2Countries ifNil: [self initISOCountries].
	^ISO2Countries! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/1/2004 18:14'!
iso2LanguageTable
	"ISOLanguageDefinition iso2LanguageTable"

	ISO2Table ifNotNil: [^ISO2Table].
	ISO2Table := Dictionary new: self iso3LanguageTable basicSize.
	self iso3LanguageTable do: [:entry |
		ISO2Table at: entry iso2 put: entry].
	^ISO2Table! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 13:57'!
iso3166Codes
"http://www.unicode.org/onlinedat/countries.html"

^'ÅLAND ISLANDS
AX


 
 
 
 
AFGHANISTAN
AF
AFG
004
 
 
 
 
ALBANIA
AL
ALB
008
CTRY_ALBANIA
355
 
 
ALGERIA
DZ
DZA
012
CTRY_ALGERIA
213
verArabic
16
AMERICAN SAMOA
AS
ASM
016
 
 
 
 
ANDORRA
AD
AND
020
 
 
 
 
ANGOLA
AO
AGO
024
 
 
 
 
ANGUILLA
AI
AIA
660
 
 
 
 
ANTARCTICA
AQ
ATA
010
 
 
 
 
ANTIGUA AND BARBUDA
AG
ATG
028
 
 
 
 
ARGENTINA
AR
ARG
032
CTRY_ARGENTINA
54
 
 
ARMENIA
AM
ARM
051
CTRY_ARMENIA
374
verArmenian
84
ARUBA
AW
ABW
533
 
 
 
 
AUSTRALIA
AU
AUS
036
CTRY_AUSTRALIA
61
verAustralia
15
AUSTRIA
AT
AUT
040
CTRY_AUSTRIA
43
verAustria
92
AZERBAIJAN
AZ
AZE
031
CTRY_AZERBAIJAN
994
 
 
BAHAMAS
BS
BHS
044
 
 
 
 
BAHRAIN
BH
BHR
048
CTRY_BAHRAIN
973
 
 
BANGLADESH
BD
BGD
050
 
 
verBengali
60
BARBADOS
BB
BRB
052
 
 
 
 
BELARUS
BY
BLR
112
CTRY_BELARUS
375
 
 
BELGIUM
BE
BEL
056
CTRY_BELGIUM
32
verFrBelgium, verFlemish
98
BELIZE
BZ
BLZ
084
CTRY_BELIZE
501
 
 
BENIN
BJ
BEN
204
 
 
 
 
BERMUDA
BM
BMU
060
 
 
 
 
BHUTAN
BT
BTN
064
 
 
verBhutan
83
BOLIVIA
BO
BOL
068
CTRY_BOLIVIA
591
 
 
BOSNIA AND HERZEGOVINA
BA
BIH
070
 
 
 
 
BOTSWANA
BW
BWA
072
 
 
 
 
BOUVET ISLAND
BV
BVT
074
 
 
 
 
BRAZIL
BR
BRA
076
CTRY_BRAZIL
55
verBrazil
71
BRITISH INDIAN OCEAN TERRITORY
IO
IOT
086
 
 
 
 
BRUNEI DARUSSALAM
BN
BRN
096
CTRY_BRUNEI_DARUSSALAM
673
 
 
BULGARIA
BG
BGR
100
CTRY_BULGARIA
359
verBulgaria 
72
BURKINA FASO
BF
BFA
854
 
 
 
 
BURUNDI
BI
BDI
108
 
 
 
 
CAMBODIA
KH
KHM
116
 
 
 
 
CAMEROON
CM
CMR
120
 
 
 
 
CANADA
CA
CAN
124
CTRY_CANADA
2
verFrCanada, verEndCanada
82
CAPE VERDE
CV
CPV
132
 
 
 
 
CAYMAN ISLANDS
KY
CYM
136
 
 
 
 
CENTRAL AFRICAN REPUBLIC
CF
CAF
140
 
 
 
 
CHAD
TD
TCD
148
 
 
 
 
CHILE
CL
CHL
152
CTRY_CHILE
56
 
 
CHINA
CN
CHN
156
CTRY_PRCHINA
86
verChina
52
CHRISTMAS ISLAND
CX
CXR
162
 
 
 
 
COCOS (KEELING) ISLANDS
CC
CCK
166
 
 
 
 
COLOMBIA
CO
COL
170
CTRY_COLOMBIA
57
 
 
COMOROS
KM
COM
174
 
 
 
 
CONGO
CG
COG
178
 
 
 
 
CONGO, THE DEMOCRATIC REPUBLIC OF THE
CD


 
 
 
 
COOK ISLANDS
CK
COK
184
 
 
 
 
COSTA RICA
CR
CRI
188
CTRY_COSTA_RICA
506
 
 
COTE D''IVOIRE
CI
CIV
384
 
 
 
 
CROATIA (local name: Hrvatska)
HR
HRV
191
CTRY_CROATIA
385
verCroatia, verYugoCroatian
68 (c), 25 (y)
CUBA
CU
CUB
192
 
 
 
 
CYPRUS
CY
CYP
196
 
 
verCyprus
23
CZECH REPUBLIC
CZ
CZE
203
CTRY_CZECH
420
verCzech 
56
DENMARK
DK
DNK
208
CTRY_DENMARK
45
verDenmark(da), verFaeroeIsl(fo)
9(da), 47(fo)
DJIBOUTI
DJ
DJI
262
 
 
 
 
DOMINICA
DM
DMA
212
 
 
 
 
DOMINICAN REPUBLIC
DO
DOM
214
CTRY_DOMINICAN_REPUBLIC
1
 
 
EAST TIMOR
TL
TLS
626
 
 
 
 
ECUADOR
EC
ECU
218
CTRY_ECUADOR
593
 
 
EGYPT
EG
EGY
818
CTRY_EGYPT
20
verArabic
16
EL SALVADOR
SV
SLV
222
CTRY_EL_SALVADOR
503
 
 
EQUATORIAL GUINEA
GQ
GNQ
226
 
 
 
 
ERITREA
ER
ERI
232
 
 
 
 
ESTONIA
EE
EST
233
CTRY_ESTONIA
372
verEstonia
44
ETHIOPIA
ET
ETH
210
 
 
 
 
FALKLAND ISLANDS (MALVINAS)
FK
FLK
238
 
 
 
 
FAROE ISLANDS
FO
FRO
234
CTRY_FAEROE_ISLANDS
298
 
 
FIJI
FJ
FJI
242
 
 
 
 
FINLAND
FI
FIN
246
CTRY_FINLAND
358
verFinland
17
FRANCE
FR
FRA
250
CTRY_FRANCE
33
verFrance
1
FRANCE, METROPOLITAN
FX
FXX
249
 
 
 
 
FRENCH GUIANA
GF
GUF
254
 
 
 
 
FRENCH POLYNESIA
PF
PYF
258
 
 
 
 
FRENCH SOUTHERN TERRITORIES
TF
ATF
260
 
 
 
 
GABON
GA
GAB
266
 
 
 
 
GAMBIA
GM
GMB
270
 
 
 
 
GEORGIA
GE
GEO
268
CTRY_GEORGIA
995
verGeorgian
85
GERMANY
DE
DEU
276
CTRY_GERMANY
49
verGermany
3
GHANA
GH
GHA
288
 
 
 
 
GIBRALTAR
GI
GIB
292
 
 
 
 
GREECE
GR
GRC
300
CTRY_GREECE
30
verGreece, verGreecePoly
20, 40
GREENLAND
GL
GRL
304
 
 
verGreenland
107
GRENADA
GD
GRD
308
 
 
 
 
GUADELOUPE
GP
GLP
312
 
 
 
 
GUAM
GU
GUM
316
 
 
 
 
GUATEMALA
GT
GTM
320
CTRY_GUATEMALA
502
 
 
GUINEA
GN
GIN
324
 
 
 
 
GUINEA-BISSAU
GW
GNB
624
 
 
 
 
GUYANA
GY
GUY
328
 
 
 
 
HAITI
HT
HTI
332
 
 
 
 
HEARD ISLAND & MCDONALD ISLANDS
HM
HMD
334
 
 
 
 
HONDURAS
HN
HND
340
CTRY_HONDURAS
504
 
 
HONG KONG
HK
HKG
344
CTRY_HONG_KONG
852
 
 
HUNGARY
HU
HUN
348
CTRY_HUNGARY
36
verHungary
43
ICELAND
IS
ISL
352
CTRY_ICELAND
354
verIceland
21
INDIA
IN
IND
356
CTRY_INDIA
91
verIndiaHindi(hi)
33
INDONESIA
ID
IDN
360
CTRY_INDONESIA
62
 
 
IRAN, ISLAMIC REPUBLIC OF
IR
IRN
364
CTRY_IRAN
981
verIran
48
IRAQ
IQ
IRQ
368
CTRY_IRAQ
964
verArabic
16
IRELAND
IE
IRL
372
CTRY_IRELAND
353
verIreland
50
ISRAEL
IL
ISR
376
CTRY_ISRAEL
972
verIsrael
13
ITALY
IT
ITA
380
CTRY_ITALY
39
verItaly
4
JAMAICA
JM
JAM
388
CTRY_JAMAICA
1
 
 
JAPAN
JP
JPN
392
CTRY_JAPAN
81
verJapan
14
JORDAN
JO
JOR
400
CTRY_JORDAN
962
 
 
KAZAKHSTAN
KZ
KAZ
398
CTRY_KAZAKSTAN
7
 
 
KENYA
KE
KEN
404
CTRY_KENYA
254
 
 
KIRIBATI
KI
KIR
296
 
 
 
 
KOREA, DEMOCRATIC PEOPLE''S REPUBLIC OF
KP
PRK
408
 
 
verKorea
51
KOREA, REPUBLIC OF
KR
KOR
410
CTRY_SOUTH_KOREA
82
verKorea
 
KUWAIT
KW
KWT
414
CTRY_KUWAIT
965
 
 
KYRGYZSTAN
KG
KGZ
417
CTRY_KYRGYZSTAN
996
 
 
LAO PEOPLE''S DEMOCRATIC REPUBLIC
LA
LAO
418
 
 
 
 
LATVIA
LV
LVA
428
CTRY_LATVIA
371
verLatvia
45
LEBANON
LB
LBN
422
CTRY_LEBANON
961
 
 
LESOTHO
LS
LSO
426
 
 
 
 
LIBERIA
LR
LBR
430
 
 
 
 
LIBYAN ARAB JAMAHIRIYA
LY
LBY
434
CTRY_LIBYA
218
verArabic
16
LIECHTENSTEIN
LI
LIE
438
CTRY_LIECHTENSTEIN
41
 
 
LITHUANIA
LT
LTU
440
CTRY_LITHUANIA
370
verLithuania
41
LUXEMBOURG
LU
LUX
442
CTRY_LUXEMBOURG
352
verFrBelgiumLux
6
MACAU
MO
MAC
446
CTRY_MACAU
853
 
 
MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF
MK
MKD
807
CTRY_MACEDONIA
389
verMacedonian
 
MADAGASCAR
MG
MDG
450
 
 
 
 
MALAWI
MW
MWI
454
 
 
 
 
MALAYSIA
MY
MYS
458
CTRY_MALAYSIA
60
 
 
MALDIVES
MV
MDV
462
CTRY_MALDIVES
960
 
 
MALI
ML
MLI
466
 
 
 
 
MALTA
MT
MLT
470
 
 
verMalta
22
MARSHALL ISLANDS
MH
MHL
584
 
 
 
 
MARTINIQUE
MQ
MTQ
474
 
 
 
 
MAURITANIA
MR
MRT
478
 
 
 
 
MAURITIUS
MU
MUS
480
 
 
 
 
MAYOTTE
YT
MYT
175
 
 
 
 
MEXICO
MX
MEX
484
CTRY_MEXICO
52
 
 
MICRONESIA, FEDERATED STATES OF
FM
FSM
583
 
 
 
 
MOLDOVA, REPUBLIC OF
MD
MDA
498
 
 
 
 
MONACO
MC
MCO
492
CTRY_MONACO
33
 
 
MONGOLIA
MN
MNG
496
CTRY_MONGOLIA
976
 
 
MONTSERRAT
MS
MSR
500
 
 
 
 
MOROCCO
MA
MAR
504
CTRY_MOROCCO
212
verArabic
16
MOZAMBIQUE
MZ
MOZ
508
 
 
 
 
MYANMAR
MM
MMR
104
 
 
 
 
NAMIBIA
NA
NAM
516
 
 
 
 
NAURU
NR
NRU
520
 
 
 
 
NEPAL
NP
NPL
524
 
 
verNepal
106
NETHERLANDS
NL
NLD
528
CTRY_NETHERLANDS
31
verNetherlands
5
NETHERLANDS ANTILLES
AN
ANT
530
 
 
 
 
NEW CALEDONIA
NC
NCL
540
 
 
 
 
NEW ZEALAND
NZ
NZL
554
CTRY_NEW_ZEALAND
64
 
 
NICARAGUA
NI
NIC
558
CTRY_NICARAGUA
505
 
 
NIGER
NE
NER
562
 
 
 
 
NIGERIA
NG
NGA
566
 
 
 
 
NIUE
NU
NIU
570
 
 
 
 
NORFOLK ISLAND
NF
NFK
574
 
 
 
 
NORTHERN MARIANA ISLANDS
MP
MNP
580
 
 
 
 
NORWAY
NO
NOR
578
CTRY_NORWAY
47
verNorway
12
OMAN
OM
OMN
512
CTRY_OMAN
968
 
 
PAKISTAN
PK
PAK
586
CTRY_PAKISTAN
92
verPakistanUrdu, verPunjabi
34 (U), 95 (P)
PALAU
PW
PLW
585
 
 
 
 
PANAMA
PA
PAN
591
CTRY_PANAMA
507
 
 
PALESTINIAN TERRITORY, OCCUPIED
PS




 
 
PAPUA NEW GUINEA
PG
PNG
598
 
 
 
 
PARAGUAY
PY
PRY
600
CTRY_PARAGUAY
595
 
 
PERU
PE
PER
604
CTRY_PERU
51
 
 
PHILIPPINES
PH
PHL
608
CTRY_PHILIPPINES
63
 
 
PITCAIRN
PN
PCN
612
 
 
 
 
POLAND
PL
POL
616
CTRY_POLAND
48
verPoland
42
PORTUGAL
PT
PRT
620
CTRY_PORTUGAL
351
verPortugal
10
PUERTO RICO
PR
PRI
630
CTRY_PUERTO_RICO
1
 
 
QATAR
QA
QAT
634
CTRY_QATAR
974
 
 
REUNION
RE
REU
638
 
 
 
 
ROMANIA
RO
ROU*
642
CTRY_ROMANIA
40
verRomania
39
RUSSIAN FEDERATION
RU
RUS
643
CTRY_RUSSIA
7
verRussia
49
RWANDA
RW
RWA
646
 
 
 
 
SAINT KITTS AND NEVIS
KN
KNA
659
 
 
 
 
SAINT LUCIA
LC
LCA
662
 
 
 
 
SAINT VINCENT AND THE GRENADINES
VC
VCT
670
 
 
 
 
SAMOA
WS
WSM
882
 
 
 
 
SAN MARINO
SM
SMR
674
 
 
 
 
SAO TOME AND PRINCIPE
ST
STP
678
 
 
 
 
SAUDI ARABIA
SA
SAU
682
CTRY_SAUDI_ARABIA
966
verArabic
16
SENEGAL
SN
SEN
686
 
 
 
 
SERBIA AND MONTENEGRO
CS
 
 
CTRY_SERBIA
381
 
 
SEYCHELLES
SC
SYC
690
 
 
 
 
SIERRA LEONE
SL
SLE
694
 
 
 
 
SINGAPORE
SG
SGP
702
CTRY_SINGAPORE
65
verSingapore
100
SLOVAKIA (Slovak Republic)
SK
SVK
703
CTRY_SLOVAK
421
verSlovak
57 
SLOVENIA
SI
SVN
705
CTRY_SLOVENIA
386
verSlovenian
66
SOLOMON ISLANDS
SB
SLB
90
 
 
 
 
SOMALIA
SO
SOM
706
 
 
 
 
SOUTH AFRICA
ZA
ZAF
710
CTRY_SOUTH_AFRICA
27
 
 
SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS
GS




 
 
SPAIN
ES
ESP
724
CTRY_SPAIN
34
verSpain
8
SRI LANKA
LK
LKA
144
 
 
 
 
SAINT HELENA
SH
SHN
654
 
 
 
 
SAINT PIERRE AND MIQUELON
PM
SPM
666
 
 
 
 
SUDAN
SD
SDN
736
 
 
 
 
SURINAME
SR
SUR
740
 
 
 
 
SVALBARD AND JAN MAYEN ISLANDS
SJ
SJM
744
 
 
 
 
SWAZILAND
SZ
SWZ
748
 
 
 
 
SWEDEN
SE
SWE
752
CTRY_SWEDEN
46
verSweden
7
SWITZERLAND
CH
CHE
756
CTRY_SWITZERLAND
41
verFrSwiss(fr), verGrSwiss(de)
18(fr), 19(de)
SYRIAN ARAB REPUBLIC
SY
SYR
760
CTRY_SYRIA
963
 
 
TAIWAN, PROVINCE OF CHINA
TW
TWN
158
CTRY_TAIWAN
886
verTaiwan
53
TAJIKISTAN
TJ
TJK
762
 
 
 
 
TANZANIA, UNITED REPUBLIC OF
TZ
TZA
834
 
 
 
 
TATARSTAN


 
CTRY_TATARSTAN
7
 
 
THAILAND
TH
THA
764
CTRY_THAILAND
66
verThailand
54
TIMOR-LESTE
TL


 
 
 
 
TOGO
TG
TGO
768
 
 
 
 
TOKELAU
TK
TKL
772
 
 
 
 
TONGA
TO
TON
776
 
 
verTonga
88
TRINIDAD AND TOBAGO
TT
TTO
780
CTRY_TRINIDAD_Y_TOBAGO
1
 
 
TUNISIA
TN
TUN
788
CTRY_TUNISIA
216
verArabic
16
TURKEY
TR
TUR
792
CTRY_TURKEY
90
verTurkey
24
TURKMENISTAN
TM
TKM
795
 
 
 
 
TURKS AND CAICOS ISLANDS
TC
TCA
796
 
 
 
 
TUVALU
TV
TUV
798
 
 
 
 
UGANDA
UG
UGA
800
 
 
 
 
UKRAINE
UA
UKR
804
CTRY_UKRAINE
380
verUkraine 
62
UNITED ARAB EMIRATES
AE
ARE
784
CTRY_UAE
971
 
 
UNITED KINGDOM
GB
GBR
826
CTRY_UNITED_KINGDOM
44
verBritain
2
UNITED STATES
US
USA
840
CTRY_UNITED_STATES
1
verUS
0
UNITED STATES MINOR OUTLYING ISLANDS
UM
UMI
581
 
 
 
 
URUGUAY
UY
URY
858
CTRY_URUGUAY
598
 
 
UZBEKISTAN
UZ
UZB
860
CTRY_UZBEKISTAN
7
 
 
VANUATU
VU
VUT
548
 
 
 
 
VATICAN CITY STATE (HOLY SEE)
VA
VAT
336
 
 
 
 
VENEZUELA
VE
VEN
862
CTRY_VENEZUELA
58
 
 
VIET NAM
VN
VNM
704
CTRY_VIET_NAM
84
verVietnam
 
VIRGIN ISLANDS (BRITISH)
VG
VGB
92
 
 
 
 
VIRGIN ISLANDS (U.S.)
VI
VIR
850
 
 
 
 
WALLIS AND FUTUNA ISLANDS
WF
WLF
876
 
 
 
 
WESTERN SAHARA
EH
ESH
732
 
 
 
 
YEMEN
YE
YEM
887
CTRY_YEMEN
967
 
 
YUGOSLAVIA
YU
YUG
891
 
 
 
 
ZAIRE
ZR
ZAR
180
 
 
 
 
ZAMBIA
ZM
ZMB
894
 
 
 
 
ZIMBABWE
ZW
ZWE
716
CTRY_ZIMBABWE
263
 
 
'! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:18'!
iso3Countries
	"ISOLanguageDefinition iso3Countries"
	"ISO2Countries := nil. ISO3Countries := nil"

	ISO3Countries ifNil: [self initISOCountries].
	^ISO3Countries! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/21/2004 13:10'!
iso3LanguageTable
	"ISOLanguageDefinition iso3LanguageTable"

	^ISO3Table ifNil: [ISO3Table := self initISO3LanguageTable]! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'yo 12/3/2004 17:46'!
isoLanguages
	"ISO 639: 3-letter codes"
	^'abk	ab	Abkhazian
ace		Achinese
ach		Acoli
ada		Adangme
aar	aa	Afar
afh		Afrihili
afr	af	Afrikaans
afa		Afro-Asiatic (Other)
aka		Akan
akk		Akkadian
alb/sqi	sq	Albanian
ale		Aleut
alg		Algonquian languages
tut		Altaic (Other)
amh	am	Amharic
apa		Apache languages
ara	ar	Arabic
arc		Aramaic
arp		Arapaho
arn		Araucanian
arw		Arawak
arm/hye	hy	Armenian
art		Artificial (Other)
asm	as	Assamese
ath		Athapascan languages
map		Austronesian (Other)
ava		Avaric
ave		Avestan
awa		Awadhi
aym	ay	Aymara
aze	az	Azerbaijani
nah		Aztec
ban		Balinese
bat		Baltic (Other)
bal		Baluchi
bam		Bambara
bai		Bamileke languages
bad		Banda
bnt		Bantu (Other)
bas		Basa
bak	ba	Bashkir
baq/eus	eu	Basque
bej		Beja
bem		Bemba
ben	bn	Bengali
ber		Berber (Other)
bho		Bhojpuri
bih	bh	Bihari
bik		Bikol
bin		Bini
bis	bi	Bislama
bra		Braj
bre	be	Breton
bug		Buginese
bul	bg	Bulgarian
bua		Buriat
bur/mya	my	Burmese
bel	be	Byelorussian
cad		Caddo
car		Carib
cat	ca	Catalan
cau		Caucasian (Other)
ceb		Cebuano
cel		Celtic (Other)
cai		Central American Indian (Other)
chg		Chagatai
cha		Chamorro
che		Chechen
chr		Cherokee
chy		Cheyenne
chb		Chibcha
chi/zho	zh	Chinese
chn		Chinook jargon
cho		Choctaw
chu		Church Slavic
chv		Chuvash
cop		Coptic
cor		Cornish
cos	co	Corsican
cre		Cree
mus		Creek
crp		Creoles and Pidgins (Other)
cpe		Creoles and Pidgins, English-based (Other)
cpf		Creoles and Pidgins, French-based (Other)
cpp		Creoles and Pidgins, Portuguese-based (Other)
cus		Cushitic (Other)
	hr	Croatian
ces/cze	cs	Czech
dak		Dakota
dan	da	Danish
del		Delaware
din		Dinka
div		Divehi
doi		Dogri
dra		Dravidian (Other)
dua		Duala
dut/nla	nl	Dutch
dum		Dutch, Middle (ca. 1050-1350)
dyu		Dyula
dzo	dz	Dzongkha
efi		Efik
egy		Egyptian (Ancient)
eka		Ekajuk
elx		Elamite
eng	en	English
enm		English, Middle (ca. 1100-1500)
ang		English, Old (ca. 450-1100)
esk		Eskimo (Other)
epo	eo	Esperanto
est	et	Estonian
ewe		Ewe
ewo		Ewondo
fan		Fang
fat		Fanti
fao	fo	Faroese
fij	fj	Fijian
fin	fi	Finnish
fiu		Finno-Ugrian (Other)
fon		Fon
fra/fre	fr	French
frm		French, Middle (ca. 1400-1600)
fro		French, Old (842- ca. 1400)
fry	fy	Frisian
ful		Fulah
gaa		Ga
gae/gdh		Gaelic (Scots)
glg	gl	Gallegan
lug		Ganda
gay		Gayo
gez		Geez
geo/kat	ka	Georgian
deu/ger	de	German
gmh		German, Middle High (ca. 1050-1500)
goh		German, Old High (ca. 750-1050)
gem		Germanic (Other)
gil		Gilbertese
gon		Gondi
got		Gothic
grb		Grebo
grc		Greek, Ancient (to 1453)
ell/gre	el	Greek, Modern (1453-)
kal	kl	Greenlandic
grn	gn	Guarani
guj	gu	Gujarati
hai		Haida
hau	ha	Hausa
haw		Hawaiian
heb	he	Hebrew
her		Herero
hil		Hiligaynon
him		Himachali
hin	hi	Hindi
hmo		Hiri Motu
hun	hu	Hungarian
hup		Hupa
iba		Iban
ice/isl	is	Icelandic
ibo		Igbo
ijo		Ijo
ilo		Iloko
inc		Indic (Other)
ine		Indo-European (Other)
ind	id	Indonesian
ina	ia	Interlingua (International Auxiliary language Association)
ine		 Interlingue
iku	iu	Inuktitut
ipk	ik	Inupiak
ira		Iranian (Other)
gai/iri	ga	Irish
sga		Irish, Old (to 900)
mga		Irish, Middle (900 - 1200)
iro		Iroquoian languages
ita	it	Italian
jpn	ja	Japanese
jav/jaw	jv/jw Javanese
jrb		Judeo-Arabic
jpr		Judeo-Persian
kab		Kabyle
kac		Kachin
kam		Kamba
kan	kn	Kannada
kau		Kanuri
kaa		Kara-Kalpak
kar		Karen
kas	ks	Kashmiri
kaw		Kawi
kaz	kk	Kazakh
kha		Khasi
khm	km	Khmer
khi		Khoisan (Other)
kho		Khotanese
kik		Kikuyu
kin	rw	Kinyarwanda
kir	ky	Kirghiz
kom		Komi
kon		Kongo
kok		Konkani
kor	ko	Korean
kpe		Kpelle
kro		Kru
kua		Kuanyama
kum		Kumyk
kur	ku	Kurdish
kru		Kurukh
kus		Kusaie
kut		Kutenai
lad		Ladino
lah		Lahnda
lam		Lamba
oci	oc	Langue d''Oc (post 1500)
lao	lo	Lao
lat	la	Latin
lav	lv	Latvian
ltz		Letzeburgesch
lez		Lezghian
lin	ln	Lingala
lit	lt	Lithuanian
loz		Lozi
lub		Luba-Katanga
lui		Luiseno
lun		Lunda
luo		Luo (Kenya and Tanzania)
mac/mak	mk	Macedonian
mad		Madurese
mag		Magahi
mai		Maithili
mak		Makasar
mlg	mg	Malagasy
may/msa	ms	Malay
mal		Malayalam
mlt	ml	Maltese
man		Mandingo
mni		Manipuri
mno		Manobo languages
max		Manx
mao/mri	mi	Maori
mar	mr	Marathi
chm		Mari
mah		Marshall
mwr		Marwari
mas		Masai
myn		Mayan languages
men		Mende
mic		Micmac
min		Minangkabau
mis		Miscellaneous (Other)
moh		Mohawk
mol	mo	Moldavian
mkh		Mon-Kmer (Other)
lol		Mongo
mon	mn	Mongolian
mos		Mossi
mul		Multiple languages
mun		Munda languages
nau	na	Nauru
nav		Navajo
nde		Ndebele, North
nbl		Ndebele, South
ndo		Ndongo
nep	ne	Nepali
new		Newari
nic		Niger-Kordofanian (Other)
ssa		Nilo-Saharan (Other)
niu		Niuean
non		Norse, Old
nai		North American Indian (Other)
nor	no	Norwegian
nno		Norwegian (Nynorsk)
nub		Nubian languages
nym		Nyamwezi
nya		Nyanja
nyn		Nyankole
nyo		Nyoro
nzi		Nzima
oji		Ojibwa
ori	or	Oriya
orm	om	Oromo
osa		Osage
oss		Ossetic
oto		Otomian languages
pal		Pahlavi
pau		Palauan
pli		Pali
pam		Pampanga
pag		Pangasinan
pan	pa	Panjabi
pap		Papiamento
paa		Papuan-Australian (Other)
fas/per	fa	Persian
peo		Persian, Old (ca 600 - 400 B.C.)
phn		Phoenician
pol	pl	Polish
pon		Ponape
por	pt	Portuguese
pra		Prakrit languages
pro		Provencal, Old (to 1500)
pus	ps	Pushto
que	qu	Quechua
roh	rm	Rhaeto-Romance
raj		Rajasthani
rar		Rarotongan
roa		Romance (Other)
ron/rum	ro	Romanian
rom		Romany
run	rn	Rundi
rus	ru	Russian
sal		Salishan languages
sam		Samaritan Aramaic
smi		Sami languages
smo	sm	Samoan
sad		Sandawe
sag	sg	Sango
san	sa	Sanskrit
srd		Sardinian
sco		Scots
sel		Selkup
sem		Semitic (Other)
	sr	Serbian
scr	sh	Serbo-Croatian
srr		Serer
shn		Shan
sna	sn	Shona
sid		Sidamo
bla		Siksika
snd	sd	Sindhi
sin	si	Singhalese
sit		Sino-Tibetan (Other)
sio		Siouan languages
sla		Slavic (Other)
ssw	ss	Siswant
slk/slo	sk	Slovak
slv	sl	Slovenian
sog		Sogdian
som	so	Somali
son		Songhai
wen		Sorbian languages
nso		Sotho, Northern
sot	st	Sotho, Southern
sai		South American Indian (Other)
esl/spa	es	Spanish
suk		Sukuma
sux		Sumerian
sun	su	Sudanese
sus		Susu
swa	sw	Swahili
ssw		Swazi
sve/swe	sv	Swedish
syr		Syriac
tgl	tl	Tagalog
tah		Tahitian
tgk	tg	Tajik
tmh		Tamashek
tam	ta	Tamil
tat	tt	Tatar
tel	te	Telugu
ter		Tereno
tha	th	Thai
bod/tib	bo	Tibetan
tig		Tigre
tir	ti	Tigrinya
tem		Timne
tiv		Tivi
tli		Tlingit
tog	to	Tonga (Nyasa)
ton		Tonga (Tonga Islands)
tru		Truk
tsi		Tsimshian
tso	ts	Tsonga
tsn	tn	Tswana
tum		Tumbuka
tur	tr	Turkish
ota		Turkish, Ottoman (1500 - 1928)
tuk	tk	Turkmen
tyv		Tuvinian
twi	tw	Twi
uga		Ugaritic
uig	ug	Uighur
ukr	uk	Ukrainian
umb		Umbundu
und		Undetermined
urd	ur	Urdu
uzb	uz	Uzbek
vai		Vai
ven		Venda
vie	vi	Vietnamese
vol	vo	Volapük
vot		Votic
wak		Wakashan languages
wal		Walamo
war		Waray
was		Washo
cym/wel	cy	Welsh
wol	wo	Wolof
xho	xh	Xhosa
sah		Yakut
yao		Yao
yap		Yap
yid	yi	Yiddish
yor	yo	Yoruba
zap		Zapotec
zen		Zenaga
zha	za	Zhuang
zul	zu	Zulu
zun		Zuni'! !

!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/1/2004 18:07'!
readISOLanguagesFrom: stream
	"ISOLanguageDefinition readISOLanguagesFrom: ISOLanguageDefinition isoLanguages readStream "
	| languages language code3 index line |
	languages := Dictionary new.
	[stream atEnd
		or: [(line := stream nextLine readStream) atEnd]]
		whileFalse: [
			language := ISOLanguageDefinition new.
			code3 := line upTo: Character tab.
			(index := code3 indexOf: $/) > 0
				ifTrue: [
					language iso3: (code3 copyFrom: 1 to: index-1).
					language iso3Alternate: (code3 copyFrom: index+1 to: code3 size)]
				ifFalse: [language iso3: code3].
			language
				iso2: (line upTo: Character tab);
				language: line upToEnd.
			languages at: language iso3 put: language].
	^languages! !
SimpleButtonMorph subclass: #IconicButton
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!IconicButton commentStamp: '<historical>' prior: 0!
A "Simple Button" in which the appearance is provided by a Form.!


!IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:38'!
borderInset
	self borderStyle: (BorderStyle inset width: 2).! !

!IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:41'!
borderRaised
	self borderStyle: (BorderStyle raised width: 2).! !


!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 14:11'!
labelFromString: aString
	"Make an iconic label from aString"

	self labelGraphic: (StringMorph contents: aString) imageForm
! !

!IconicButton methodsFor: 'as yet unclassified' stamp: 'di 2/17/2000 20:30'!
labelGraphic: aForm
	| oldLabel graphicalMorph |
	(oldLabel _ self findA: SketchMorph)
		ifNotNil: [oldLabel delete].
	graphicalMorph _ SketchMorph withForm: aForm.
	self extent: graphicalMorph extent + (borderWidth + 6).
	graphicalMorph position: self center - (graphicalMorph extent // 2).
	self addMorph: graphicalMorph.
	graphicalMorph lock
! !

!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 11/29/1999 20:56'!
shedSelvedge
	self extent: (self extent - (6@6))! !


!IconicButton methodsFor: 'events' stamp: 'jrp 7/5/2005 23:15'!
mouseEnter: evt

	self borderStyle: BorderStyle thinGray! !

!IconicButton methodsFor: 'events' stamp: 'jrp 7/5/2005 22:50'!
mouseLeave: evt

	self borderNormal! !


!IconicButton methodsFor: 'initialization' stamp: 'ar 12/12/2001 01:38'!
borderNormal
	self borderStyle: (BorderStyle width: 2 color: Color transparent).! !

!IconicButton methodsFor: 'initialization' stamp: 'ar 12/17/2001 21:17'!
borderThick
	self borderStyle: (BorderStyle width: 2 color: self raisedColor twiceDarker).! !

!IconicButton methodsFor: 'initialization' stamp: 'ar 12/15/2001 14:43'!
buttonSetup
	self actWhen: #buttonUp.
	self cornerStyle: #rounded.
	self borderNormal.
	self on: #mouseEnter send: #borderRaised to: self.
	self on: #mouseLeave send: #borderNormal to: self.
	self on: #mouseLeaveDragging send: #borderNormal to: self.
	self on: #mouseDown send: #borderInset to: self.
	self on: #mouseUp send: #borderRaised to: self.! !

!IconicButton methodsFor: 'initialization' stamp: 'sw 11/29/1999 20:52'!
initialize
	super initialize.
	self useSquareCorners! !

!IconicButton methodsFor: 'initialization' stamp: 'nk 9/7/2004 11:43'!
initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: aColor andSend: aSelector to: aReceiver 	
	"Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver"

	| labeledItem nonTranslucent |
	nonTranslucent := aColor asNontranslucentColor.
	labeledItem _ AlignmentMorph newColumn.
	labeledItem color: nonTranslucent.
	labeledItem borderWidth: 0.
	labeledItem
		layoutInset: 4@0;
		cellPositioning: #center.
	labeledItem addMorph: aThumbnail.
	labeledItem addMorphBack: (Morph new extent: (4@4)) beTransparent.
	labeledItem addMorphBack: (TextMorph new
		backgroundColor: nonTranslucent;
		contentsAsIs: aLabel;
		beAllFont: Preferences standardEToysFont;
		centered).

	self
		beTransparent;
		labelGraphic: ((labeledItem imageForm: 32 backgroundColor: nonTranslucent forRectangle: labeledItem fullBounds) replaceColor: nonTranslucent withColor: Color transparent);
		borderWidth: 0;
		target: aReceiver;
		actionSelector: #launchPartVia:label:;
		arguments: {aSelector. aLabel};
		actWhen: #buttonDown.

	self stationarySetup.! !

!IconicButton methodsFor: 'initialization' stamp: 'nk 8/6/2004 11:34'!
initializeWithThumbnail: aThumbnail withLabel: aLabel andSend: aSelector to: aReceiver 	
	"Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver"

	^self initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: Color transparent   andSend: aSelector to: aReceiver 	! !

!IconicButton methodsFor: 'initialization' stamp: 'sw 9/28/1999 18:38'!
setDefaultLabel
	self labelGraphic: (ScriptingSystem formAtKey: 'squeakyMouse')! !

!IconicButton methodsFor: 'initialization' stamp: 'ar 12/18/2001 21:22'!
stationarySetup

	self actWhen: #startDrag.
	self cornerStyle: #rounded.
	self borderNormal.
	self on: #mouseEnter send: #borderThick to: self.
	self on: #mouseDown send: nil to: nil.
	self on: #mouseLeave send: #borderNormal to: self.
	self on: #mouseLeaveDragging send: #borderNormal to: self.
	self on: #mouseUp send: #borderThick to: self.! !


!IconicButton methodsFor: 'menu' stamp: 'sw 9/28/1999 20:42'!
addLabelItemsTo: aCustomMenu hand: aHandMorph
	"don't do the inherited behavior, since there is no textual label in this case"! !


!IconicButton methodsFor: '*MorphicExtras-initialization' stamp: 'nk 9/1/2004 17:14'!
initializeToShow: aMorph withLabel: aLabel andSend: aSelector to: aReceiver 	
	"Initialize the receiver to show the current appearance of aMorph on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the specified selector to the specified receiver"

	| aThumbnail |
	aThumbnail _ Thumbnail new.
	aThumbnail makeThumbnailFromForm: (aMorph imageFormDepth: 32).
	^ self initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: self color andSend: aSelector to: aReceiver 	! !
Bag subclass: #IdentityBag
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!IdentityBag commentStamp: '<historical>' prior: 0!
Like a Bag, except that items are compared with #== instead of #= .

See the comment of IdentitySet for more information.
!
]style[(88 11 23)f3,f3LIdentitySet Comment;,f3!


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

IdentityBag class
	instanceVariableNames: ''!

!IdentityBag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:53'!
contentsClass
	^IdentityDictionary! !
TestCase subclass: #IdentityBagTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Unordered'!

!IdentityBagTest methodsFor: 'tests' stamp: 'EP 3/8/2006 09:50'!
testIdentity
	"self run:#testIdentity"
	"self debug:#testIdentity"
	| bag identityBag aString anOtherString |
	
	aString := 'hello'.
	anOtherString := aString copy.
	
	self assert: (aString = anOtherString).
	self assert: (aString == anOtherString) not.

	bag := Bag new.
	bag add: aString.
	bag add: aString.
	bag add: anOtherString.
	self assert: (bag occurrencesOf: aString) = 3.
	self assert: (bag occurrencesOf: anOtherString) = 3.
	
	identityBag := IdentityBag new.
	identityBag add: aString.
	identityBag add: aString.
	identityBag add: anOtherString.
	
	self assert: (identityBag occurrencesOf: aString) = 2.
	self assert: (identityBag occurrencesOf: anOtherString) = 1.



! !
Dictionary subclass: #IdentityDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!IdentityDictionary commentStamp: 'ls 06/15/02 22:35' prior: 0!
Like a Dictionary, except that keys are compared with #== instead of #= .

See the comment of IdentitySet for more information.!
]style[(94 11 22)f1,f1LIdentitySet Comment;,f1!


!IdentityDictionary methodsFor: 'private' stamp: 'RAA 1/10/2001 14:57'!
fasterKeys
	"This was taking some time in publishing and we didn't really need a Set"
	| answer index |
	answer _ Array new: self size.
	index _ 0.
	self keysDo: [:key | answer at: (index _ index + 1) put: key].
	^ answer! !

!IdentityDictionary methodsFor: 'private' stamp: 'di 12/1/1999 20:54'!
keyAtValue: value ifAbsent: exceptionBlock
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer the result of evaluating exceptionBlock."
 
	self associationsDo: 
		[:association | value == association value ifTrue: [^ association key]].
	^ exceptionBlock value! !

!IdentityDictionary methodsFor: 'private' stamp: 'md 1/21/2006 20:04'!
keys
	"Answer a Set containing the receiver's keys."
	| aSet |
	aSet := IdentitySet new: self size.
	self keysDo: [:key | aSet add: key].
	^ aSet! !

!IdentityDictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:41'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| finish hash start element |
	finish _ array size.
	finish > 4096
		ifTrue: [hash _ anObject identityHash * (finish // 4096)]
		ifFalse: [hash _ anObject identityHash].
	start _ (hash \\ finish) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element key == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element key == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
Object subclass: #IdentityGlyphMap
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Fonts'!

!IdentityGlyphMap methodsFor: 'as yet unclassified' stamp: 'yo 2/13/2004 04:07'!
at: index

	^ index - 1.
! !
Set subclass: #IdentitySet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!IdentitySet commentStamp: 'sw 1/14/2003 22:35' prior: 0!
The same as a Set, except that items are compared using #== instead of #=.

Almost any class named IdentityFoo is the same as Foo except for the way items are compared.  In Foo, #= is used, while in IdentityFoo, #== is used.  That is, identity collections will treat items as the same only if they have the same identity.

For example, note that copies of a string are equal:

	('abc' copy) = ('abc' copy)

but they are not identitcal:

	('abc' copy) == ('abc' copy)

A regular Set will only include equal objects once:

	| aSet |
	aSet := Set new.
	aSet add: 'abc' copy.
	aSet add: 'abc' copy.
	aSet


An IdentitySet will include multiple equal objects if they are not identical:

	| aSet |
	aSet := IdentitySet new.
	aSet add: 'abc' copy.
	aSet add: 'abc' copy.
	aSet
!


!IdentitySet methodsFor: 'converting' stamp: 'ar 9/22/2000 10:13'!
asIdentitySet
	^self! !


!IdentitySet methodsFor: 'private' stamp: 'md 10/5/2005 15:42'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| finish hash start element |
	finish _ array size.
	finish > 4096
		ifTrue: [hash _ anObject identityHash * (finish // 4096)]
		ifFalse: [hash _ anObject identityHash].
	start _ (hash \\ finish) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
SkipList subclass: #IdentitySkipList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-SkipLists'!
!IdentitySkipList commentStamp: '<historical>' prior: 0!
Like a SkipList, except that elements are compared with #== instead of #= .

See the comment of IdentitySet for more information.
!
]style[(96 11 23)f3,f3LIdentitySet Comment;,f3!


!IdentitySkipList methodsFor: 'element comparison' stamp: 'LC 6/18/2001 20:28'!
is: element1 equalTo: element2
	^ element1 == element2! !
DisplayTransform subclass: #IdentityTransform
	instanceVariableNames: ''
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'Graphics-Transformations'!

!IdentityTransform methodsFor: 'accessing' stamp: 'di 9/29/2000 09:04'!
angle
	^ 0.0! !

!IdentityTransform methodsFor: 'accessing' stamp: 'ar 9/11/2000 21:18'!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self! !

!IdentityTransform methodsFor: 'accessing' stamp: 'ar 4/19/2001 06:01'!
offset
	^0@0! !


!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:27'!
composedWith: aTransform
	^aTransform! !

!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'!
composedWithGlobal: aTransformation
	^aTransformation! !

!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'!
composedWithLocal: aTransformation
	^aTransformation! !


!IdentityTransform methodsFor: 'converting' stamp: 'ar 9/11/2000 21:21'!
asMatrixTransform2x3
	"Represent the receiver as a 2x3 matrix transformation"
	^MatrixTransform2x3 identity! !


!IdentityTransform methodsFor: 'initialize' stamp: 'ar 9/11/2000 21:18'!
setIdentity
	"I *am* the identity transform"
	^self! !


!IdentityTransform methodsFor: 'testing' stamp: 'ar 9/11/2000 21:18'!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."
	^true! !

!IdentityTransform methodsFor: 'testing' stamp: 'ar 9/11/2000 21:19'!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	^true! !


!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:19'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^aPoint! !

!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'!
globalPointsToLocal: inArray
	"Transform all the points of inArray from global into local coordinates"
	^inArray! !

!IdentityTransform methodsFor: 'transforming points' stamp: 'gh 10/22/2001 13:24'!
invertBoundsRect: aRectangle
	"Return a rectangle whose coordinates have been transformed
	from local back to global coordinates. Since I am the identity matrix
	no transformation is made."

	^aRectangle
! !

!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	^aPoint! !

!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'!
localPointsToGlobal: inArray
	"Transform all the points of inArray from local into global coordinates"
	^inArray! !


!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^aRectangle! !

!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^aRectangle! !

!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:21'!
sourceQuadFor: aRectangle
	^ aRectangle innerCorners! !

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

IdentityTransform class
	instanceVariableNames: ''!

!IdentityTransform class methodsFor: 'class initialization' stamp: 'ar 9/11/2000 21:24'!
initialize
	"IdentityTransform initialize"
	Default _ self basicNew.! !


!IdentityTransform class methodsFor: 'instance creation' stamp: 'ar 9/11/2000 21:24'!
new
	"There can be only one"
	^Default! !
Exception subclass: #IllegalResumeAttempt
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!IllegalResumeAttempt commentStamp: '<historical>' prior: 0!
This class is private to the EHS implementation.  An instance of it is signaled whenever an attempt is made to resume from an exception which answers false to #isResumable.!


!IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 9/4/2002 19:24'!
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! !

!IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 2/1/2003 00:57'!
isResumable
	
	^ false! !

!IllegalResumeAttempt methodsFor: 'comment' stamp: 'tfei 6/2/1999 14:59'!
readMe

	"Never handle this exception!!"! !
Error subclass: #IllegalURIException
	instanceVariableNames: 'uriString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-URI'!

!IllegalURIException methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:21'!
uriString
	^uriString! !

!IllegalURIException methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:20'!
uriString: aString
	uriString _ aString! !
Morph subclass: #ImageMorph
	instanceVariableNames: 'image'
	classVariableNames: 'DefaultForm'
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!ImageMorph commentStamp: 'efc 3/7/2003 17:48' prior: 0!
ImageMorph is a morph that displays a picture (Form). My extent is determined by the extent of my form.

Use #image: to set my picture.

Structure:
 instance var		Type 		Description
 image				Form		The Form to use when drawing

Code examples:
	ImageMorph new openInWorld; grabFromScreen

	(Form fromFileNamed: 'myGraphicsFileName') asMorph openInWorld

Relationship to SketchMorph: ImageMorph should be favored over SketchMorph, a parallel, legacy class -- see the Swiki FAQ for details ( http://minnow.cc.gatech.edu/squeak/1372 ). 
!
]style[(10 37 4 97 33 11 5 47 42 3 62 18 11 109 39 5)f1LImageMorph Hierarchy;,f1,f1LForm Comment;,f1,f1i,f1,f1LForm Comment;,f1,f1dImageMorph new openInWorld; grabFromScreen;;,f1,f1d(Form fromFileNamed: 'myGraphicsFileName') asMorph openInWorld;;,f1,f1LSketchMorph Comment;,f1,f1Rhttp://minnow.cc.gatech.edu/squeak/1372;,f1!


!ImageMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:08'!
borderStyle: newStyle
	| newExtent |
	newExtent _ 2 * newStyle width + image extent.
	bounds extent = newExtent ifFalse:[super extent: newExtent].
	super borderStyle: newStyle.! !

!ImageMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:11'!
borderWidth: bw
	| newExtent |
	newExtent _ 2 * bw + image extent.
	bounds extent = newExtent ifFalse:[super extent: newExtent].
	super borderWidth: bw! !

!ImageMorph methodsFor: 'accessing' stamp: 'bf 10/13/1999 14:09'!
color: aColor
        super color: aColor.
        (image depth == 1 and: [aColor isColor]) ifTrue: [
                image colors: {Color transparent. aColor}.
                self changed]! !

!ImageMorph methodsFor: 'accessing'!
form
	"For compatability with SketchMorph."

	^ image
! !

!ImageMorph methodsFor: 'accessing' stamp: 'jm 9/27/97 20:16'!
image

	^ image
! !

!ImageMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:17'!
image: anImage 
	self changed.
	image := anImage depth = 1 
				ifTrue: [ColorForm mappingWhiteToTransparentFrom: anImage]
				ifFalse: [anImage]. 
	super extent: image extent! !

!ImageMorph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 20:01'!
isOpaque
	"Return true if the receiver is marked as being completely opaque"
	^ self
		valueOfProperty: #isOpaque
		ifAbsent: [false]! !

!ImageMorph methodsFor: 'accessing' stamp: 'ar 11/7/2000 14:57'!
isOpaque: aBool
	"Mark the receiver as being completely opaque or not"
	aBool == false
		ifTrue:[self removeProperty: #isOpaque]
		ifFalse:[self setProperty: #isOpaque toValue: aBool].
	self changed! !

!ImageMorph methodsFor: 'accessing' stamp: 'sw 10/24/2000 05:53'!
setNewImageFrom: formOrNil
	"Change the receiver's image to be one derived from the supplied form.  If nil is supplied, clobber any existing image in the receiver, and in its place put a default graphic, either the one known to the receiver as its default value, else a squeaky mouse"

	|  defaultImage |
	formOrNil ifNotNil: [^ self image: formOrNil].
	defaultImage _ self defaultValueOrNil ifNil: [ScriptingSystem squeakyMouseForm].
	self image: defaultImage
! !

!ImageMorph methodsFor: 'accessing' stamp: 'wiz 4/7/2004 15:10'!
withSnapshotBorder
	self borderStyle: ((ComplexBorder style: #complexFramed)
			color: (Color
					r: 0.613
					g: 1.0
					b: 0.516);
			 width: 1;
			
			 yourself)! !


!ImageMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/29/2004 11:04'!
wantsRecolorHandle
	^ image isNil not
		and: [image depth == 1]! !


!ImageMorph methodsFor: 'caching'!
releaseCachedState

	super releaseCachedState.
	image hibernate.
! !


!ImageMorph methodsFor: 'drawing' stamp: 'dgd 9/7/2004 17:24'!
drawOn: aCanvas
	| style |
	(style _ self borderStyle) ifNotNil:[
		style frameRectangle: bounds on: aCanvas.
	].
	self isOpaque
		ifTrue:[aCanvas drawImage: image at: self innerBounds origin]
		ifFalse:[aCanvas translucentImage: image at: self innerBounds origin]! !


!ImageMorph methodsFor: 'geometry'!
extent: aPoint
	"Do nothing; my extent is determined by my image Form."
! !


!ImageMorph methodsFor: 'initialization'!
initialize

	super initialize.
	self image: DefaultForm.
! !


!ImageMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 14:57'!
changeOpacity
	self isOpaque: self isOpaque not! !

!ImageMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:46'!
opacityString
	^ (self isOpaque
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'opaque' translated! !


!ImageMorph methodsFor: 'menu commands'!
grabFromScreen

	self image: Form fromUser.
! !

!ImageMorph methodsFor: 'menu commands' stamp: 'di 9/15/1998 09:58'!
readFromFile
	| fileName |
	fileName _ FillInTheBlank
		request: 'Please enter the image file name'
		initialAnswer: 'fileName'.
	fileName isEmpty ifTrue: [^ self].
	self image: (Form fromFileNamed: fileName).
! !


!ImageMorph methodsFor: 'menus' stamp: 'ar 11/7/2000 14:55'!
addCustomMenuItems: aMenu hand: aHand
	super addCustomMenuItems: aMenu hand: aHand.
	aMenu addUpdating: #opacityString action: #changeOpacity! !


!ImageMorph methodsFor: 'other' stamp: 'sw 12/17/1998 12:11'!
newForm: aForm
	self image: aForm! !


!ImageMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'!
initializeToStandAlone

	super initializeToStandAlone.
	self image: DefaultForm.
! !


!ImageMorph methodsFor: 'testing' stamp: 'tk 11/1/2001 12:43'!
basicType
	"Answer a symbol representing the inherent type I hold"

	"Number String Boolean player collection sound color etc"
	^ #Image! !


!ImageMorph methodsFor: '*eToys-card in a stack' stamp: 'sw 10/23/2000 18:22'!
couldHoldSeparateDataForEachInstance
	"Answer whether the receiver can potentially hold separate data for each instance"

	^ true! !


!ImageMorph methodsFor: '*eToys-other'!
wearCostume: anotherMorph

	self image: anotherMorph form.
! !


!ImageMorph methodsFor: '*eToys-player' stamp: 'sw 10/23/2000 18:22'!
currentDataValue
	"Answer the current data value of the receiver, to be stored in each card instance if appropriate"

	^ image! !

!ImageMorph methodsFor: '*eToys-player' stamp: 'sw 10/25/2000 06:58'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield"

	^ Array with: (VariableDock new variableName: self defaultVariableName type: #form definingMorph: self morphGetSelector: #image morphPutSelector: #setNewImageFrom:)! !


!ImageMorph methodsFor: '*MorphicExtras-*morphic-Postscript Canvases' stamp: 'RAA 4/20/2001 12:11'!
drawPostscriptOn: aCanvas

	| top f2 c2 clrs |

	clrs _ image colorsUsed.
	(clrs includes: Color transparent) 
		ifFalse: [^super drawPostscriptOn: aCanvas].		"no need for this, then"

	top _ aCanvas topLevelMorph.
	f2 _ Form extent: self extent depth: image depth.
	c2 _ f2 getCanvas.
	c2 fillColor: Color white.
	c2 translateBy: bounds origin negated clippingTo: f2 boundingBox during: [ :c |
		top fullDrawOn: c
	].
	aCanvas paintImage: f2 at: bounds origin

! !

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

ImageMorph class
	instanceVariableNames: ''!

!ImageMorph class methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:59'!
defaultForm
	^DefaultForm! !


!ImageMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:09'!
initialize
	"ImageMorph initialize"

	| h p d |
	DefaultForm _ (Form extent: 80@40 depth: 16).
	h _ DefaultForm height // 2.
	0 to: h - 1 do: [:i |
		p _ (i * 2)@i.
		d _ i asFloat / h asFloat.
		DefaultForm fill:
			(p corner: DefaultForm extent - p)
			fillColor: (Color r: d g: 0.5 b: 1.0 - d)].

	self registerInFlapsRegistry.! !

!ImageMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:10'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(ImageMorph		authoringPrototype		'Picture'		'A non-editable picture of something') 
						forFlapNamed: 'Supplies']! !

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

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


!ImageMorph class methodsFor: 'instance creation' stamp: 'sw 10/23/2000 18:21'!
fromString: aString 
	"Create a new ImageMorph which displays the input string in the standard button font"

	^ self fromString: aString font: Preferences standardButtonFont! !

!ImageMorph class methodsFor: 'instance creation' stamp: 'sw 10/23/2000 18:21'!
fromString: aString font: aFont
	"Create a new ImageMorph showing the given string in the given font"

	^ self new image: (StringMorph contents: aString font: aFont) imageForm! !


!ImageMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'!
descriptionForPartsBin
	^ self partName:	'Image'
		categories:		#('Graphics' 'Basic')
		documentation:	'A non-editable picture.  If you use the Paint palette to make a picture, you can edit it afterwards.'! !


!ImageMorph class methodsFor: 'scripting' stamp: 'sw 5/19/1998 18:30'!
authoringPrototype
	| aMorph aForm |
	aMorph _ super authoringPrototype.
	aForm _ ScriptingSystem formAtKey: 'Image'.
	aForm ifNil: [aForm _ aMorph image rotateBy: 90].
	aMorph image: aForm.
	^ aMorph! !
ImageMorph subclass: #ImageMorphWithSpotlight
	instanceVariableNames: 'spotImage spotShape spotBuffer spotOn'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!ImageMorphWithSpotlight commentStamp: '<historical>' prior: 0!
This class implements an image that appears one way or another depending upon whether it lies within a spotlight shape that moves with the cursor.  As delivered, the shape is a simple circle, the spotlighted appearance is that of a ColorForm, and the non-highlighted apperarance is a derived gray-scale form.

The implementation will space-efficient if supplied with a ColorForm, because the gray-scale derived form will share the same bitmap.

In general, any two images can be used -- one could be blurred, the other sharp -- and the masking form can be any shape.

At some point this class should be merged somehow with ScreeningMorph.!


!ImageMorphWithSpotlight methodsFor: 'accessing' stamp: 'di 5/26/1999 08:05'!
image: anImage

	"The spotlight will reveal the original  form supplied
	while the background form will be derived grayscale."
	"See class comment."
	self backgroundImage: anImage asGrayScale
		spotImage: anImage
		spotShape: (Form dotOfSize: 100)
! !


!ImageMorphWithSpotlight methodsFor: 'all' stamp: 'di 5/26/1999 07:51'!
backgroundImage: bkgndImage spotImage: anImage spotShape: formOfDepth1

	"See class comment."
	spotImage _ anImage.
	spotShape _ formOfDepth1.
	spotBuffer _ Form extent: spotShape extent depth: spotImage depth.
	super image: bkgndImage.
	spotOn _ false.! !

!ImageMorphWithSpotlight methodsFor: 'all' stamp: 'di 5/24/1999 22:37'!
spotChanged

	self invalidRect:
		((spotBuffer offset extent: spotBuffer extent) "intersect: self bounds")! !


!ImageMorphWithSpotlight methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:06'!
drawOn: aCanvas

	super drawOn: aCanvas.
	spotOn ifTrue:
		[aCanvas paintImage: spotBuffer at: spotBuffer offset].
! !


!ImageMorphWithSpotlight methodsFor: 'stepping and presenter' stamp: 'ar 5/28/2000 12:09'!
step
	| cp |
	((self bounds expandBy: spotBuffer extent // 2) containsPoint: (cp _ self cursorPoint))
		ifTrue:
		[(cp - (spotBuffer extent // 2)) = spotBuffer offset ifTrue: [^ self].  "No change"
		"Cursor has moved where its spotShape is visible"
		spotOn _ true.
		self spotChanged.
		spotBuffer offset: cp - (spotBuffer extent // 2).
		self spotChanged.
		(BitBlt current toForm: spotBuffer)
			"clear the buffer"
			fill: spotBuffer boundingBox fillColor: (Bitmap with: 0) rule: Form over;
			"Clip anything outside the base form"
			clipRect: (spotBuffer boundingBox
				intersect: (self bounds translateBy: spotBuffer offset negated));
			"Fill the spotBuffer with the spot image"
			copyForm: spotImage to: self position - spotBuffer offset rule: Form over;
			"Mask everything outside the spot shape to 0 (transparent)."
			copyForm: spotShape to: spotShape offset negated rule: Form and
				colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)]
		ifFalse:
		[spotOn ifTrue: [self spotChanged. spotOn _ false]]! !


!ImageMorphWithSpotlight methodsFor: 'testing' stamp: 'di 5/24/1999 21:43'!
stepTime

	^ 20! !
Object subclass: #ImageReadWriter
	instanceVariableNames: 'stream'
	classVariableNames: 'ImageNotStoredSignal MagicNumberErrorSignal'
	poolDictionaries: ''
	category: 'Graphics-Files'!
!ImageReadWriter commentStamp: '<historical>' prior: 0!
Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved.

I am an abstract class to provide for encoding and/or decoding an image on a stream.

Instance Variables:
	stream		<ReadStream | WriteStream>	stream for image storages

Class Variables:
	ImageNotStoredSignal		<Signal>	image not stored error signal
	MagicNumberErrorSignal		<Signal>	magic number error signal

Subclasses must implement the following messages:
	accessing
		nextImage
		nextPutImage:
	testing
		canUnderstand         (added tao 10/26/97)!


!ImageReadWriter methodsFor: 'accessing'!
nextImage
	"Dencoding an image on stream and answer the image."

	^self subclassResponsibility! !

!ImageReadWriter methodsFor: 'accessing'!
nextPutImage: anImage
	"Encoding anImage on stream."

	^self subclassResponsibility! !


!ImageReadWriter methodsFor: 'stream access'!
atEnd

	^stream atEnd! !

!ImageReadWriter methodsFor: 'stream access' stamp: 'sd 1/30/2004 15:18'!
close
	
	stream close! !

!ImageReadWriter methodsFor: 'stream access'!
contents

	^stream contents! !

!ImageReadWriter methodsFor: 'stream access'!
cr

	^stream nextPut: Character cr asInteger! !

!ImageReadWriter methodsFor: 'stream access'!
lf
	"PPM and PBM are used LF as CR."

	^stream nextPut: Character lf asInteger! !

!ImageReadWriter methodsFor: 'stream access'!
next

	^stream next! !

!ImageReadWriter methodsFor: 'stream access'!
next: size

	^stream next: size! !

!ImageReadWriter methodsFor: 'stream access'!
nextLong
	"Read a 32-bit quantity from the input stream."

	^(stream next bitShift: 24) + (stream next bitShift: 16) +
		(stream next bitShift: 8) + stream next! !

!ImageReadWriter methodsFor: 'stream access'!
nextLongPut: a32BitW
	"Write out a 32-bit integer as 32 bits."

	stream nextPut: ((a32BitW bitShift: -24) bitAnd: 16rFF).
	stream nextPut: ((a32BitW bitShift: -16) bitAnd: 16rFF).
	stream nextPut: ((a32BitW bitShift: -8) bitAnd: 16rFF).
	stream nextPut: (a32BitW bitAnd: 16rFF).
	^a32BitW! !

!ImageReadWriter methodsFor: 'stream access'!
nextPut: aByte

	^stream nextPut: aByte! !

!ImageReadWriter methodsFor: 'stream access'!
nextPutAll: aByteArray

	^stream nextPutAll: aByteArray! !

!ImageReadWriter methodsFor: 'stream access'!
nextWord
	"Read a 16-bit quantity from the input stream."

	^(stream next bitShift: 8) + stream next! !

!ImageReadWriter methodsFor: 'stream access'!
nextWordPut: a16BitW
	"Write out a 16-bit integer as 16 bits."

	stream nextPut: ((a16BitW bitShift: -8) bitAnd: 16rFF).
	stream nextPut: (a16BitW bitAnd: 16rFF).
	^a16BitW! !

!ImageReadWriter methodsFor: 'stream access' stamp: 'tao 10/23/97 18:00'!
peekFor: aValue

	^stream peekFor: aValue! !

!ImageReadWriter methodsFor: 'stream access'!
position

	^stream position! !

!ImageReadWriter methodsFor: 'stream access'!
position: anInteger

	^stream position: anInteger! !

!ImageReadWriter methodsFor: 'stream access'!
size

	^stream size! !

!ImageReadWriter methodsFor: 'stream access'!
skip: anInteger

	^stream skip: anInteger! !

!ImageReadWriter methodsFor: 'stream access'!
space

	^stream nextPut: Character space asInteger! !

!ImageReadWriter methodsFor: 'stream access'!
tab

	^stream nextPut: Character tab asInteger! !


!ImageReadWriter methodsFor: 'testing' stamp: 'tao 10/27/97 09:26'!
understandsImageFormat
	"Test to see if the image stream format is understood by this decoder.
	This should be implemented in each subclass of ImageReadWriter so that
	a proper decoder can be selected without ImageReadWriter having to know
	about all possible image file types."

	^ false! !


!ImageReadWriter methodsFor: 'private'!
changePadOfBits: bits width: width height: height depth: depth from: oldPad
to: newPad
	"Change padding size of bits."

	| srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset |
	(#(8 16 32) includes: oldPad)
		ifFalse: [^self error: 'Invalid pad: ', oldPad printString].
	(#(8 16 32) includes: newPad)
		ifFalse: [^self error: 'Invalid pad: ', newPad printString].
	srcRowByteSize _ width * depth + oldPad - 1 // oldPad * (oldPad / 8).
	srcRowByteSize * height = bits size
		ifFalse: [^self error: 'Incorrect bitmap array size.'].
	dstRowByteSize _ width * depth + newPad - 1 // newPad * (newPad / 8).
	newBits _ ByteArray new: dstRowByteSize * height.
	srcRowBase _ 1.
	rowEndOffset _ dstRowByteSize - 1.
	1 to: newBits size by: dstRowByteSize do:
		[:dstRowBase |
		newBits replaceFrom: dstRowBase
			to: dstRowBase + rowEndOffset
			with: bits
			startingAt: srcRowBase.
		srcRowBase _ srcRowBase + srcRowByteSize].
	^newBits! !

!ImageReadWriter methodsFor: 'private'!
hasMagicNumber: aByteArray
	| position |
	position _ stream position.
	((stream size - position) >= aByteArray size and:
	[(stream next: aByteArray size)  = aByteArray])
		ifTrue: [^true].
	stream position: position.
	^false! !

!ImageReadWriter methodsFor: 'private' stamp: 'sd 1/30/2004 15:18'!
on: aStream
	(stream _ aStream) reset.
	stream binary.
	"Note that 'reset' makes a file be text.  Must do this after."! !

!ImageReadWriter methodsFor: 'private'!
unpackBits: bits depthTo8From: depth with: width height: height pad: pad
	"Unpack bits of depth 1, 2, or 4 image to it of depth 8 image."

	| bitMask pixelInByte bitsWidth upBitsWidth stopWidth
	 trailingSize upBits bitIndex upBitIndex val |
	(#(1 2 4) includes: depth)
		ifFalse: [^self error: 'depth must be 1, 2, or 4'].
	(#(8 16 32) includes: pad)
		ifFalse: [^self error: 'pad must be 8, 16, or 32'].
	bitMask _ (1 bitShift: depth) - 1.
	pixelInByte _ 8 / depth.
	bitsWidth _ width * depth + pad - 1 // pad * (pad / 8).
	upBitsWidth _ width * 8 + pad - 1 // pad * (pad / 8).
	stopWidth _ width * depth + 7 // 8.
	trailingSize _ width - (stopWidth - 1 * pixelInByte).
	upBits _ ByteArray new: upBitsWidth * height.
	1 to: height do: [:i |
		bitIndex _ i - 1 * bitsWidth.
		upBitIndex _ i - 1 * upBitsWidth.
		1 to: stopWidth - 1 do: [:j |
			val _ bits at: (bitIndex _ bitIndex + 1).
			upBitIndex _ upBitIndex + pixelInByte.
			1 to: pixelInByte do: [:k |
				upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask).
				val _ val bitShift: depth negated]].
		val _ (bits at: (bitIndex _ bitIndex + 1))
				bitShift: depth negated * (pixelInByte - trailingSize).
		upBitIndex _ upBitIndex + trailingSize.
		1 to: trailingSize do: [:k |
			upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask).
			val _ val bitShift: depth negated]].
	^ upBits
! !

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

ImageReadWriter class
	instanceVariableNames: ''!

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:59'!
allTypicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that my subclasses can read might commonly have"
	"ImageReadWriter allTypicalFileExtensions"
	| extensions |
	extensions _ Set new.
	self allSubclassesDo: [ :cls | extensions addAll: cls typicalFileExtensions ].
	^extensions! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ls 9/15/1998 19:08'!
formFromFileNamed: fileName
	"Answer a ColorForm stored on the file with the given name."
	| stream |
	stream _ FileStream readOnlyFileNamed: fileName.
	^self formFromStream: stream! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'tk 5/7/1998 17:35'!
formFromServerFile: fileName
	"Answer a ColorForm stored on the file with the given name.  Meant to be called from during the getting of updates from the server.  That assures that (Utilities serverUrls) returns the right group of servers."

	| form urls doc |
	urls _ Utilities serverUrls collect:
		[:url | url, fileName].  " fileName starts with: 'updates/'  "
	urls do: [:aURL |
		(fileName findTokens: '.') last asLowercase = 'gif' ifTrue: [
			form _ HTTPSocket httpGif: aURL.
			form = (ColorForm extent: 20@20 depth: 8) 
				ifTrue: [self inform: 'The file ',aURL,' is ill formed.'].
			^ form].
		(fileName findTokens: '.') last asLowercase = 'bmp' ifTrue: [
			doc _ HTTPSocket httpGet: aURL accept: 'image/bmp'.
			form _ Form fromBMPFile: doc.
			doc close.
			form ifNil: [self inform: 'The file ',aURL,' is ill formed.'. ^ Form new]
				ifNotNil: [^ form]].
		self inform: 'File ', fileName, 'does not end with .gif or .bmp'].
	self inform: 'That file not found on any server we know'.! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'sd 1/30/2004 15:18'!
formFromStream: aBinaryStream
	"Answer a ColorForm stored on the given stream.  closes the stream"
	| reader readerClass form  |

	readerClass _ self withAllSubclasses
		detect: [:subclass | subclass understandsImageFormat: aBinaryStream]
		ifNone: [
			aBinaryStream close.
			^self error: 'image format not recognized'].
	reader _ readerClass new on: aBinaryStream reset.
	Cursor read showWhile: [
		form _ reader nextImage.
		reader close].
	^ form
! !

!ImageReadWriter class methodsFor: 'image reading/writing'!
putForm: aForm onFileNamed: fileName
	"Store the given form on a file of the given name."

	| writer |
	writer _ self on: (FileStream newFileNamed: fileName) binary.
	Cursor write showWhile: [writer nextPutImage: aForm].
	writer close.
! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'tk
9/13/97 16:13'!
putForm: aForm onStream: aWriteStream
	"Store the given form on a file of the given name."

	| writer |
	writer _ self on: aWriteStream.
	Cursor write showWhile: [writer nextPutImage: aForm].
	writer close.
! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:55'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#()! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 3/1/2006 22:59'!
understandsImageFormat: aStream 
	^[(self new on: aStream) understandsImageFormat] on: Error do:[:ex| ex return: false]! !


!ImageReadWriter class methodsFor: 'instance creation'!
on: aStream
	"Answer an instance of the receiver for encoding and/or decoding images on the given."

	^ self new on: aStream
! !
Object subclass: #ImageSegment
	instanceVariableNames: 'arrayOfRoots segment outPointers state segmentName fileName endMarker userRootCnt renamedClasses'
	classVariableNames: 'BiggestFileNumber RecentlyRenamedClasses'
	poolDictionaries: ''
	category: 'System-Object Storage'!
!ImageSegment commentStamp: 'tk 12/2/2004 12:33' prior: 0!
I represent a segment of Squeak address space.  I am created from an
array of root objects.  After storing, my segment contains a binary
encoding of every object accessible from my roots but not otherwise
accessible from anywhere else in the system.  My segment contains
outward pointers that are indices into my table of outPointers.
	The main use of ImageSegments is to store Projects.  A dummy
version of SmartRefStream traverses the Project.  Everything it finds
is classified as either an object that is owned by the project (only
pointed to inside the project), or an object outside the project that
is pointed to from inside the project.  The objects that are
completely owned by the project are compressed into pure binary form
in an ImageSegment.  The outside objects are put in the 'outPointers'
array.  The entire ImageSegment (binary part plus outPointers) is
encoded in a SmartRefStream, and saved on the disk.  (aProject
exportSegmentWithChangeSet:fileName:directory:) calls (anImageSegment
writeForExportWithSources:inDirectory:changeSet:).
	Note that every object inside the project is put into the
segment's arrayOfRoots.  This is because a dummy SmartRefStream to
scan the project, in order to make intelligent decisions about what
belongs in the project.
	See Project's class comment for what messages are sent to
objects as they are unpacked in a new image.

---- Older Details ------

	The primary kind of image segment is an Export Segment.  It
can be saved on a server and read into a completely different Squeak
image.
Old way to create one:
(ImageSegment new copyFromRootsForExport: (Array with: Baz with: Baz class))
		writeForExport: 'myFile.extSeg'.
Old way to create one for a project:
	(Project named: 'Play With Me - 3') exportSegment.
To read it into another image:  Select 'myFile.extSeg' in a FileList,
Menu 'load as project'.  It will install its classes automatically.
If you need to see the roots array, it is temporarily stored in
(SmartRefStream scannedObject).

Most of 'states' of an ImageSegment are not used to export a project,
and have been abandoned.

	When a segment is written out onto a file, it goes in a
folder called <image name>_segs.  If your image is called
"Squeak2.6.image", the folder "Squeak2.6_segs" must accompany the
image whenever your move, copy, or rename it.
	Whenever a Class is in arrayOfRoots, its class (aClass class)
must also be in the arrayOfRoots.
	There are two kinds of image segments.  Normal image segments
are a piece of a specific Squeak image, and can only be read back
into that image.  The image holds the array of outPointers that are
necessary to turn the bits in the file into objects.
	To put out a normal segment that holds a Project (not the
current project), execute (Project named: 'xxx') storeSegment.


arrayOfRoots	The objects that head the tree we will trace.
segment			The WordArray of raw bits of all objects in the tree.
outPointers		Oops of all objects outside the segment
pointed to from inside.
state			(see below)
segmentName	Its basic name.  Often the name of a Project.
fileName		The local name of the file.  'Foo-23.seg'
endMarker		An object located in memory somewhere after a
segment that has
		just been brought in.  To enumerate the objects in
the segment, start at
		the segment and go to this object.
userRootCnt		number of roots submitted by caller.  Extras
are added in preparation for saving.

state that an ImageSegment may exist in...

#activeCopy			(has been copied, with the intent to
become active)
arrayOfRoots, segment, and outPointers have been created by
copyFromRoots:.  The tree of objects has been encoded in the segment,
but those objects are still present in the Squeak system.

#active				(segment is actively holding objects)
The segment is now the only holder of tree of objects.  Each of the
original roots has been transmuted into an ImageSegmentRootStub that
refers back to this image segment.  The original objects in the
segment will all be garbageCollected.

#onFile
The segment has been written out to a file and replaced by a file
pointer.  Only ImageSegmentRootStubs and the array of outPointers
remains in the image.  To get this far:
(ImageSegment new copyFromRoots: (Array with: Baz with: Baz class))
		writeToFile: 'myFile.seg'.

#inactive
The segment has been brought back into memory and turned back into
objects.  rootsArray is set, but the segment is invalid.

#onFileWithSymbols
The segment has been written out to a file, along with the text of
all the symbols in the outPointers array, and replaced by a file
pointer.  This reduces the size of the outPointers array, and also
allows the system to reclaim any symbols that are not referred to
from elsewhere in the image.  The specific format used is that of a
literal array as follows:
	#(symbol1 symbol2 # symbol3 symbol4 'symbolWithSpaces' # symbol5).
In this case, the original outPointers array was 8 long, but the
compacted table of outPointers retains only two entries.  These get
inserted in place of the #'s in the array of symbols after it is read
back in.  Symbols with embedded spaces or other strange characters
are written as strings, and converted back to symbols when read back
in.  The symbol # is never written out.
	NOTE: All IdentitySets or dictionaries must be rehashed when
being read back from this format.  The symbols are effectively
internal.  (No, not if read back into same image.  If a different
image, then use #imported.  -tk)

#imported
The segment is on an external file or just read in from one.  The
segment and outPointers are meant to be read into a foreign image.
In this form, the image segment can be read from a URL, and
installed.  A copy of the original array of root objects is
constructed, with former outPointers bound to existing objects in the
host system.
	(Any Class inside the segment MUST be in the arrayOfRoots.
This is so its association can be inserted into Smalltalk.  The
class's metaclass must be in roots also.  Methods that are in
outPointers because blocks point at them, were found and added to the
roots.
	All IdentitySets and dictionaries are rehashed when being
read back from exported segments.)


To discover why only some of the objects in a project are being
written out, try this (***Destructive Test***).  This breaks lots of
backpointers in the target project, and puts up an array of
suspicious objects, a list of the classes of the outPointers, and a
debugger.
"Close any transcripts in the target project"
World currentHand objectToPaste ifNotNil: [
	self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs,
		World currentHand objectToPaste printString].
PV _ Project named: 'xxxx'.
(IS _ ImageSegment new) findRogueRootsImSeg:
	(Array with: PV world presenter with: PV world).
IS findOwnersOutPtrs.	"Optionally: write a file with owner chains"
"Quit and DO NOT save"

When an export image segment is brought into an image, it is like an
image starting up.  Certain startUp messages need to be run.  These
are byte and word reversals for nonPointer data that comes from a
machine of the opposite endianness.  #startUpProc passes over all
objects in the segment, and:
	The first time an instance of class X is encountered, (msg _
X startUpFrom: anImageSegment) is sent.  If msg is nil, the usual
case, it means that instances of X do not need special work.  X is
included in the IdentitySet, noStartUpNeeded.  If msg is not nil,
store it in the dictionary, startUps (aClass -> aMessage).
	When a later instance of X is encountered, if X is in
noStartUpNeeded, do nothing.  If X is in startUps, send the message
to the instance.  Typically this is a message like #swapShortObjects.
	Every class that implements #startUp, should see if it needs
a parallel implementation of #startUpFrom:.  !


!ImageSegment methodsFor: 'access' stamp: 'tk 10/4/1999 17:52'!
allObjectsDo: aBlock
	"Enumerate all objects that came from this segment.  NOTE this assumes that the segment was created (and extracted).  After the segment has been installed (install), this method allows you to enumerate its objects."
	| obj |

	endMarker == nil ifTrue: [
		^ self error: 'Just extract and install, don''t writeToFile:'].
	segment size ~= 1 ifTrue: [
		^ self error: 'Vestigial segment size must be 1 (version word)'].

	obj _ segment nextObject.  "Start with the next object after the vestigial header"
	[obj == endMarker] whileFalse:  "Stop at the next object after the full segment"
		[aBlock value: obj.
		obj _ obj nextObject].  "Step through the objects installed from the segment."! !

!ImageSegment methodsFor: 'access' stamp: 'tk 4/6/1999 13:15'!
arrayOfRoots
	^ arrayOfRoots! !

!ImageSegment methodsFor: 'access' stamp: 'tk 12/8/1999 21:12'!
arrayOfRoots: array
	arrayOfRoots _ array! !

!ImageSegment methodsFor: 'access' stamp: 'tk 1/20/2000 20:16'!
originalRoots
	"Return only the roots that the user submitted, not the ones we had to add."

	userRootCnt ifNil: [^ arrayOfRoots].
	^ arrayOfRoots copyFrom: 1 to: userRootCnt! !

!ImageSegment methodsFor: 'access' stamp: 'tk 3/31/1999 21:47'!
outPointers
	^ outPointers! !

!ImageSegment methodsFor: 'access' stamp: 'tk 8/18/1999 22:19'!
segment
	^ segment! !

!ImageSegment methodsFor: 'access' stamp: 'tk 9/26/1999 22:54'!
state
	^ state! !


!ImageSegment methodsFor: 'compact classes' stamp: 'tk 1/8/2000 17:39'!
aComment
	"Compact classes are a potential problem because a pointer to the class would not ordinarily show up in the outPointers.  We add the classes of all compact classes to outPointers, both for local and export segments.
	Compact classes are never allowed as roots.  No compact class may be in an Environment that is written out to disk.  (In local segments, the compact classes array should never have an ImageSegmentRootStub in it.  For export, fileIn the class first, then load a segment with instances of it.  The fileIn code can be pasted onto the front of the .extSeg file) 
	For local segments, a class may become compact while its instances are out on the disk.  Or it may become un-compact.  A compact class may change shape while some of its instances are on disk.  All three cases go through (ClassDescription updateInstancesFrom:).  If it can't rule out an instance being in the segment, it reads it in to fix the instances.  
	See Behavior.becomeCompact for the rules on Compact classes.  Indexes may not be reused.  This is so that an incoming export segment has its index available.  (Changes may be needed in the way indexes are assigned.)
	For export segments, a compact class may have a different shape.  The normal class reshape mechanism will catch this.  During the installation of the segment, objects will have the wrong version of their class momentarily.  We will change them back before we get caught.
	For export segments, the last two items in outPointers are the number 1717 and an array of the compact classes used in this segment.  (The classes in the array are converted from DiskProxies by SmartRefStream.)  If that class is not compact in the new image, the instances are recopied.
	"!
]style[(8 275 5 1435)f1b,f1,f3,f1! !

!ImageSegment methodsFor: 'compact classes' stamp: 'ar 4/10/2005 19:55'!
cc: ind new: inTheSeg current: inTheImage fake: fakeCls refStrm: smartRefStream
	"Sort out all the cases and decide what to do.  Every Fake class is uncompacted before having insts converted.  As the segment is installed, instances of reshaped compact classes will have the wrong class.  Trouble cases:
	1) Existing class is compact in the segment and not compact here.  Make that compact, (error if that slot is used), load the segment.  If an class was just filed in, it is an existing class as far as we are concerned.
	2) A compact class has a different shape.  We created a Fake class.  Load the segment, with instances in the seg having the Wrong Class!!!!  Find the bad instancees, and copy them over to being the real class.
	3) An existing class is not compact in the segment, but is in the image.  Just let the new instance be uncompact.  That is OK, and never reaches this code.
	A class that is a root in this segment cannot be compact.  That is not allowed."

	(inTheImage == nil) & (fakeCls == nil) ifTrue: ["case 1 and empty slot" 
		inTheSeg becomeCompactSimplyAt: ind.  ^ true].
	
	(inTheImage == inTheSeg) & (fakeCls == nil) ifTrue: ["everything matches" 
		^ true].

	inTheImage ifNil: ["reshaped and is an empty slot"
		fakeCls becomeCompactSimplyAt: ind.  ^ true].
		"comeFullyUpOnReload: will clean up"

	(inTheSeg == String and:[inTheImage == ByteString]) ifTrue:[
		"ar 4/10/2005: Workaround after renaming String to ByteString"
		^true
	].

	"Is the image class really the class we are expecting?  inTheSeg came in as a DiskProxy, and was mapped if it was renamed!!"
	inTheImage == inTheSeg ifFalse: [
		self inform: 'The incoming class ', inTheSeg name, ' wants compact class \location ', ind printString, ', but that is occupied by ', inTheImage name, '.  \This file cannot be read into this system.  The author of the file \should make the class uncompact and create the file again.' withCRs.
		^ false].

	"Instances of fakeCls think they are compact, and thus will say they are instances of the class inTheImage, which is a different shape.  Just allow this to happen.  Collect them and remap them as soon as the segment is installed."
	^ true! !

!ImageSegment methodsFor: 'compact classes' stamp: 'ar 2/21/2001 19:26'!
compactClassesArray
	| ccIndexes ind ccArray hdrBits |
	"A copy of the real compactClassesArray, but with only the classes actually used in the segment.  Slow, but OK for export."

	ccIndexes _ Set new.
	ind _ 2. 	"skip version word, first object"
	"go past extra header words"
	(hdrBits _ (segment atPin: ind) bitAnd: 3) = 1 ifTrue: [ind _ ind+1].
	hdrBits = 0 ifTrue: [ind _ ind+2].

	[ccIndexes add: (self compactIndexAt: ind).	"0 if has class field"
	 ind _ self objectAfter: ind.
	 ind > segment size] whileFalse.
	ccArray _ Smalltalk compactClassesArray clone.
	1 to: ccArray size do: [:ii | "only the ones we use"
		(ccIndexes includes: ii) ifFalse: [ccArray at: ii put: nil]].
	^ ccArray! !

!ImageSegment methodsFor: 'compact classes' stamp: 'tk 12/21/1999 21:53'!
compactIndexAt: ind
	| word |
	"Look in this header word in the segment and find it's compact class index. *** Warning: When class ObjectMemory change, be sure to change it here. *** "

	((word _ segment at: ind) bitAnd: 3) = 2 ifTrue: [^ 0].  "free block"
	^ (word >> 12) bitAnd: 16r1F 	"Compact Class field of header word"

! !

!ImageSegment methodsFor: 'compact classes' stamp: 'tk 3/15/2000 09:51'!
objectAfter: ind
	"Return the object or free chunk immediately following the given object or free chunk in the segment.  *** Warning: When class ObjectMemory change, be sure to change it here. ***"

	| sz word newInd hdrBits |
	sz _ ((word _ segment at: ind "header") bitAnd: 3) = 2   "free block?"
		ifTrue: [word bitAnd: 16rFFFFFFFC]
		ifFalse: [(word bitAnd: 3) = 0 "HeaderTypeSizeAndClass"
			ifTrue: [(segment at: ind-2) bitAnd: 16rFFFFFFFC]
			ifFalse: [word bitAnd: "SizeMask" 252]].

	newInd _ ind + (sz>>2).
	"adjust past extra header words"
	(hdrBits _ (segment atPin: newInd) bitAnd: 3) = 3 ifTrue: [^ newInd].
		"If at end, header word will be garbage.  This is OK"
	hdrBits = 1 ifTrue: [^ newInd+1].
	hdrBits = 0 ifTrue: [^ newInd+2].
	^ newInd	"free"! !

!ImageSegment methodsFor: 'compact classes' stamp: 'tk 1/11/2000 15:27'!
remapCompactClasses: mapFakeClassesToReal refStrm: smartRefStream
	| ccArray current fake info |
	"See if our compact classes are compatible with this system.  Convert to what the system already has.  If we are adding a new class, it has already been filed in.  A compact class may not be a root."

	(outPointers at: (outPointers size - 1)) = 1717 ifFalse: [^ true].
	ccArray _ outPointers last.
	current _ Smalltalk compactClassesArray.
	1 to: ccArray size do: [:ind | 
		(ccArray at: ind) ifNotNil: ["is compact in the segment"
			fake _ mapFakeClassesToReal keyAtValue: (current at: ind) ifAbsent: [nil].
			info _ self cc: ind new: (ccArray at: ind) current: (current at: ind) 
					fake: fake refStrm: smartRefStream.
			info ifFalse: [^ false]]].
	^ true! !


!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 1/17/2001 12:15'!
acceptSingleMethodSource: aDictionary

	| oldClassInfo oldClassName ismeta newName actualClass selector |
	oldClassInfo _ (aDictionary at: #oldClassName) findTokens: ' '.	"'Class' or 'Class class'"
	oldClassName _ oldClassInfo first asSymbol.
	ismeta _ oldClassInfo size > 1.

	"must use class var since we may not be the same guy who did the initial work"

	newName _ RecentlyRenamedClasses ifNil: [
		oldClassName
	] ifNotNil: [
		RecentlyRenamedClasses at: oldClassName ifAbsent: [oldClassName]
	].
	actualClass _ Smalltalk at: newName.
	ismeta ifTrue: [actualClass _ actualClass class].
	selector _ actualClass parserClass new parseSelector: (aDictionary at: #methodText).
	(actualClass compiledMethodAt: selector ifAbsent: [^self "hosed input"]) 
		putSource: (aDictionary at: #methodText)
		fromParseNode: nil
		class: actualClass
		category: (aDictionary at: #category)
		withStamp: (aDictionary at: #changeStamp)
		inFile: 2
		priorMethod: nil.

! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'yo 7/29/2005 21:48'!
comeFullyUpOnReload: smartRefStream
	"fix up the objects in the segment that changed size.  An
object in the segment is the wrong size for the modern version of the
class.  Construct a fake class that is the old size.  Replace the
modern class with the old one in outPointers.  Load the segment.
Traverse the instances, making new instances by copying fields, and
running conversion messages.  Keep the new instances.  Bulk forward
become the old to the new.  Let go of the fake objects and classes.
	After the install (below), arrayOfRoots is filled in.
Globalize new classes.  Caller may want to do some special install on
certain objects in arrayOfRoots.
	May want to write the segment out to disk in its new form."

	| mapFakeClassesToReal ccFixups receiverClasses
rootsToUnhiberhate myProject existing |

	RecentlyRenamedClasses _ nil.		"in case old data
hanging around"
	mapFakeClassesToReal _ smartRefStream reshapedClassesIn: outPointers.
		"Dictionary of just the ones that change shape.
Substitute them in outPointers."
	ccFixups _ self remapCompactClasses: mapFakeClassesToReal
				refStrm: smartRefStream.
	ccFixups ifFalse: [^ self error: 'A class in the file is not
compatible'].
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
	self fixCapitalizationOfSymbols.
	arrayOfRoots _ self loadSegmentFrom: segment outPointers: outPointers.
		"Can't use install.  Not ready for rehashSets"
	mapFakeClassesToReal isEmpty ifFalse: [
		self reshapeClasses: mapFakeClassesToReal refStream:
smartRefStream
	].
	"When a Project is stored, arrayOfRoots has all objects in
the project, except those in outPointers"
	arrayOfRoots do: [:importedObject |
		((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [
			importedObject mutateJISX0208StringToUnicode.
			importedObject class = WideSymbol ifTrue: [
				"self halt."
				Symbol hasInterned: 
importedObject asString ifTrue: [:multiSymbol |
					multiSymbol == importedObject
ifFalse: [
						importedObject
becomeForward: multiSymbol.
					].
				].
			].
		].
		(importedObject isKindOf: TTCFontSet) ifTrue: [
			existing _ TTCFontSet familyName:
importedObject familyName
						pointSize:
importedObject pointSize.	"supplies default"
			existing == importedObject ifFalse:
[importedObject becomeForward: existing].
		].
	].
	"Smalltalk garbageCollect.   MultiSymbol rehash.  These take
time and are not urgent, so don't to them.  In the normal case, no
bad MultiSymbols will be found."

	receiverClasses _ self restoreEndianness.		"rehash sets"
	smartRefStream checkFatalReshape: receiverClasses.

	"Classes in this segment."
	arrayOfRoots do: [:importedObject |
		importedObject class class == Metaclass ifTrue: [self
declare: importedObject]].
	arrayOfRoots do: [:importedObject |
		(importedObject isKindOf: CompiledMethod) ifTrue: [
			importedObject sourcePointer > 0 ifTrue:
[importedObject zapSourcePointer]].
		(importedObject isKindOf: Project) ifTrue: [
			myProject _ importedObject.
			importedObject ensureChangeSetNameUnique.
			Project addingProject: importedObject.
			importedObject restoreReferences.
			self dependentsRestore: importedObject.
			ScriptEditorMorph writingUniversalTiles:
				((importedObject projectPreferenceAt:
#universalTiles) ifNil: [false])]].

	rootsToUnhiberhate _ arrayOfRoots select: [:importedObject |
		importedObject respondsTo: #unhibernate
	"ScriptEditors and ViewerFlapTabs"
	].
	myProject ifNotNil: [
		myProject world setProperty: #thingsToUnhibernate
toValue: rootsToUnhiberhate
	].

	mapFakeClassesToReal isEmpty ifFalse: [
		mapFakeClassesToReal keys do: [:aFake |
			aFake indexIfCompact > 0 ifTrue: [aFake
becomeUncompact].
			aFake removeFromSystemUnlogged].
		SystemOrganization removeEmptyCategories].
	"^ self"
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 1/17/2001 12:06'!
declare: classThatIsARoot

	| nameOnArrival |
	"The class just arrived in this segment.  How fit it into the Smalltalk dictionary?  If it had an association, that was installed with associationDeclareAt:."

	nameOnArrival _ classThatIsARoot name.
	self declareAndPossiblyRename: classThatIsARoot.
	nameOnArrival == classThatIsARoot name ifTrue: [^self].
	renamedClasses ifNil: [RecentlyRenamedClasses _ renamedClasses _ Dictionary new].
	renamedClasses at: nameOnArrival put: classThatIsARoot name.

! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 12/5/2001 14:47'!
declareAndPossiblyRename: classThatIsARoot
	| existing catInstaller |
	"The class just arrived in this segment.  How fit it into the Smalltalk dictionary?  If it had an association, that was installed with associationDeclareAt:."

	catInstaller _ [
		classThatIsARoot superclass name == #Player 
			ifTrue: [classThatIsARoot category: Object categoryForUniclasses]
			ifFalse: [(classThatIsARoot superclass name beginsWith: 'WonderLandActor')
				ifTrue: [classThatIsARoot category: 'Balloon3D-UserObjects']
				ifFalse: [classThatIsARoot category: 'Morphic-Imported']].
	].
	classThatIsARoot superclass addSubclass: classThatIsARoot.
	(Smalltalk includesKey: classThatIsARoot name) ifFalse: [
		"Class entry in Smalltalk not referred to in Segment, install anyway."
		catInstaller value.
		^ Smalltalk at: classThatIsARoot name put: classThatIsARoot].
	existing _ Smalltalk at: classThatIsARoot name.
	existing xxxClass == ImageSegmentRootStub ifTrue: [
		"We are that segment!!  Must ask it carefully!!"
		catInstaller value.
		^ Smalltalk at: classThatIsARoot name put: classThatIsARoot].
	existing == false | (existing == nil) ifTrue: [
		"association is in outPointers, just installed"
		catInstaller value.
		^ Smalltalk at: classThatIsARoot name put: classThatIsARoot].
	"Conflict with existing global or copy of the class"
	(existing isKindOf: Class) ifTrue: [
		classThatIsARoot isSystemDefined not ifTrue: [
			"UniClass.  give it a new name"
			classThatIsARoot setName: classThatIsARoot baseUniclass chooseUniqueClassName.
			catInstaller value.	"must be after new name"
			^ Smalltalk at: classThatIsARoot name put: classThatIsARoot].
		"Take the incoming one"
		self inform: 'Using newly arrived version of ', classThatIsARoot name.
		classThatIsARoot superclass removeSubclass: classThatIsARoot.	"just in case"
		(Smalltalk at: classThatIsARoot name) becomeForward: classThatIsARoot.
		catInstaller value.
		^ classThatIsARoot superclass addSubclass: classThatIsARoot].
	self error: 'Name already in use by a non-class: ', classThatIsARoot name.
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 10/24/2001 18:31'!
endianness
	"Return which endian kind the incoming segment came from"

	^ (segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'ar 4/12/2005 17:37'!
fixCapitalizationOfSymbols
	"MultiString>>capitalized was not implemented 
correctly. 
	Fix eventual accessors and mutators here."
	| sym ms |
	1 to: outPointers size do:[:i|
		sym := outPointers at: i.
		(sym class == WideSymbol and:[sym size > 3]) ifTrue:[
			((sym beginsWith: 'get')
				and:[(sym at: 4) asInteger < 256
				and:[(sym at: 4) isLowercase]]) ifTrue:[
					ms _ sym asString.
					ms at: 4 put: (ms at: 4) asUppercase.
					ms _ ms asSymbol.
					sym becomeForward: ms.
			].
			((sym beginsWith: 'set')
				and:[(sym at: 4) asInteger < 256
				and:[(sym at: 4) isLowercase
				and:[sym last = $:
				and:[(sym occurrencesOf: $:) = 1]]]]) ifTrue:[
					ms _ sym asString.
					ms at: 4 put: (ms at: 4) asUppercase.
					ms _ ms asSymbol.
					sym becomeForward: ms.
				].
			outPointers at: i put: sym.
		].
	].! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'ar 8/16/2001 13:26'!
prepareToBeSaved
	"Prepare objects in outPointers to be written on the disk.  They must be able to match up with existing objects in their new system.  outPointers is already a copy.
	Classes are already converted to a DiskProxy.  
	Associations in outPointers:
1) in Smalltalk.
2) in a classPool.
3) in a shared pool.
4) A pool dict pointed at directly"

| left pool myClasses outIndexes key |
myClasses _ Set new.
arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]].
outIndexes _ IdentityDictionary new.
outPointers withIndexDo: [:anOut :ind | 
	anOut isVariableBinding ifTrue: [
		(myClasses includes: anOut value)
			ifFalse: [outIndexes at: anOut put: ind]
			ifTrue: [(Smalltalk associationAt: anOut key ifAbsent: [3]) == anOut 
				ifTrue: [outPointers at: ind put: 
					(DiskProxy global: #Smalltalk selector: #associationDeclareAt: 
						args: (Array with: anOut key))]
				ifFalse: [outIndexes at: anOut put: ind]
				]].
	(anOut isKindOf: Dictionary) ifTrue: ["Pools pointed at directly"
		(key _ Smalltalk keyAtIdentityValue: anOut ifAbsent: [nil]) ifNotNil: [
			outPointers at: ind put: 
				(DiskProxy global: key selector: #yourself args: #())]].
	anOut isMorph ifTrue: [outPointers at: ind put: 
		(StringMorph contents: anOut printString, ' that was not counted')]
	].
left _ outIndexes keys asSet.
left size > 0 ifTrue: ["Globals"
	(left copy) do: [:assoc |	"stay stable while delete items"
		(Smalltalk associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
			outPointers at: (outIndexes at: assoc) put: 
				(DiskProxy global: #Smalltalk selector: #associationAt: 
					args: (Array with: assoc key)).
			left remove: assoc]]].
left size > 0 ifTrue: ["Class variables"
	Smalltalk allClassesDo: [:cls | cls classPool size > 0 ifTrue: [
		(left copy) do: [:assoc |	"stay stable while delete items"
			(cls classPool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
				outPointers at: (outIndexes at: assoc) put: 
					(DiskProxy new global: cls name
						preSelector: #classPool
						selector: #associationAt: 
						args: (Array with: assoc key)).
				left remove: assoc]]]]].
left size > 0 ifTrue: ["Pool variables"
	Smalltalk associationsDo: [:poolAssoc |
		poolAssoc value class == Dictionary ifTrue: ["a pool"
			pool _ poolAssoc value.
			(left copy) do: [:assoc |	"stay stable while delete items"
				(pool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
					outPointers at: (outIndexes at: assoc) put: 
						(DiskProxy global: poolAssoc key selector: #associationAt: 
							args: (Array with: assoc key)).
					left remove: assoc]]]]].
left size > 0 ifTrue: [
	"If points to class in arrayOfRoots, must deal with it separately"
	"OK to have obsolete associations that just get moved to the new system"
	self inform: 'extra associations'.
	left inspect].
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 1/25/2000 22:23'!
rehashSets
	"I have just been brought in and converted to live objects.  Find all Sets and Dictionaries in the newly created objects and rehash them.  Segment is near then end of memory, since is was newly brought in (and a new object created for it).
	Also, collect all classes of receivers of blocks.  Return them.  Caller will check if they have been reshaped."

	| object sets receiverClasses inSeg |
	object _ segment.
	sets _ OrderedCollection new.
		"have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one."
	receiverClasses _ IdentitySet new.
	inSeg _ true.
	[object _ object nextObject.  
		object == endMarker ifTrue: [inSeg _ false].	"off end"
		object isInMemory ifTrue: [
			(object isKindOf: Set) ifTrue: [sets add: object].
			object class == BlockContext ifTrue: [inSeg ifTrue: [
					receiverClasses add: object receiver class]].	
			object class == MethodContext ifTrue: [inSeg ifTrue: [
					receiverClasses add: object receiver class]].	
			]. 
		object == 0] whileFalse.
	sets do: [:each | each rehash].	"our purpose"
	^ receiverClasses	"our secondary job"
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 12/20/2000 11:07'!
reshapeClasses: mapFakeClassesToReal refStream: smartRefStream 

	| bads allVarMaps perfect insts partials in out |

	self flag: #bobconv.	

	partials _ OrderedCollection new.
	bads _ OrderedCollection new.
	allVarMaps _ IdentityDictionary new.
	mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass | 
		(theRealClass indexIfCompact > 0) "and there is a fake class"
			ifFalse: [insts _ aFakeClass allInstances]
			ifTrue: ["instances have the wrong class.  Fix them before anyone notices."
				insts _ OrderedCollection new.
				self allObjectsDo: [:obj | obj class == theRealClass ifTrue: [insts add: obj]].
			].
		insts do: [ :misShapen | 
			perfect _ smartRefStream convert1: misShapen to: theRealClass allVarMaps: allVarMaps.
			bads 
				detect: [ :x | x == misShapen] 
				ifNone: [
					bads add: misShapen.
					partials add: perfect
				].
		].
	].
	bads isEmpty ifFalse: [
		bads asArray elementsForwardIdentityTo: partials asArray
	].

	in _ OrderedCollection new.
	out _ OrderedCollection new.
	partials do: [ :each |
		perfect _ smartRefStream convert2: each allVarMaps: allVarMaps.
		in 
			detect: [ :x | x == each]
			ifNone: [
				in add: each.
				out add: perfect
			]
	].
	in isEmpty ifFalse: [
		in asArray elementsForwardIdentityTo: out asArray
	].
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 10/24/2001 18:21'!
restoreEndianness
	"Fix endianness (byte order) of any objects not already fixed.  Do this by discovering classes that need a startUp message sent to each instance, and sending it.
	I have just been brought in and converted to live objects.  Find all Sets and Dictionaries in the newly created objects and rehash them.  Segment is near then end of memory, since is was newly brought in (and a new object created for it).
	Also, collect all classes of receivers of blocks which refer to instance variables.  Return them.  Caller will check if they have been reshaped."

	| object sets receiverClasses inSeg noStartUpNeeded startUps cls msg |

	object _ segment.
	sets _ OrderedCollection new.
		"have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one."
	receiverClasses _ IdentitySet new.
	noStartUpNeeded _ IdentitySet new.	"classes that don't have a per-instance startUp message"
	startUps _ IdentityDictionary new.	"class -> MessageSend of a startUp message"
	inSeg _ true.
	[object _ object nextObject.  "all the way to the end of memory to catch remade objects"
		object == endMarker ifTrue: [inSeg _ false].	"off end"
		object isInMemory ifTrue: [
			(object isKindOf: Set) ifTrue: [sets add: object].
			(object isKindOf: ContextPart) ifTrue: [
				(inSeg and: [object hasInstVarRef]) ifTrue: [
					receiverClasses add: object receiver class]].
			inSeg ifTrue: [
				(noStartUpNeeded includes: object class) ifFalse: [
					cls _ object class.
					(msg _ startUps at: cls ifAbsent: [nil]) ifNil: [
						msg _ cls startUpFrom: self.	"a Message, if we need to swap bytes this time"
						msg ifNil: [noStartUpNeeded add: cls]
							ifNotNil: [startUps at: cls put: msg]].
					msg ifNotNil: [msg sentTo: object]]]]. 
		object == 0] whileFalse.
	sets do: [:each | each rehash].	"our purpose"
	^ receiverClasses	"our secondary job"
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 6/22/2000 17:49'!
scanFrom: aStream
	"Move source code from a fileIn to the changes file for classes in an ImageSegment.  Do not compile the methods.  They already came in via the image segment.  After the ImageSegment in the file, !!ImageSegment new!! captures control, and scanFrom: is called."
	| val chunk |

	[aStream atEnd] whileFalse: 
		[aStream skipSeparators.
		val _ (aStream peekFor: $!!)
			ifTrue: ["Move (aStream nextChunk), find the method or class 
						comment, and install the file location bytes"
					(Compiler evaluate: aStream nextChunk logged: false)
						scanFromNoCompile: aStream forSegment: self]
			ifFalse: [chunk _ aStream nextChunk.
					aStream checkForPreamble: chunk.
					Compiler evaluate: chunk logged: true].
		aStream skipStyleChunk].
	"regular fileIn will close the file"
	^ val! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 10/21/2002 14:40'!
storeDataOn: aDataStream
	"Don't wrote the array of Roots.  Also remember the structures of the classes of objects inside the segment."

	| tempRoots tempOutP list |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
		"real state is activeCopy, but we changed it will be right when coming in"
	tempRoots _ arrayOfRoots.
	tempOutP _ outPointers.
	outPointers _ outPointers clone.
	self prepareToBeSaved.
	arrayOfRoots _ nil.
	state _ #imported.
	super storeDataOn: aDataStream.		"record my inst vars"
	arrayOfRoots _ tempRoots.
	outPointers _ tempOutP.
	state _ #activeCopy.
	aDataStream references at: #AnImageSegment put: false.	"the false is meaningless"
		"This key in refs is the flag that there is an ImageSegment in this file."

	"Find the receivers of blocks in the segment.  Need to get the structure of their classes into structures.  Put the receivers into references."
	(aDataStream byteStream isKindOf: DummyStream) ifTrue: [
		list _ Set new.
		arrayOfRoots do: [:ea | 
			(ea class == BlockContext) | (ea class == MethodContext) ifTrue: [ 
				list add: ea receiver class ]].
		aDataStream references at: #BlockReceiverClasses put: list].
! !


!ImageSegment methodsFor: 'instance change shape' stamp: 'tk 1/25/2000 21:54'!
allInstancesOf: aClass do: aBlock
	| withSymbols oldInstances segSize |
	"Bring me in, locate instances of aClass and submit them to the block.  Write me out again."

	(state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self].
	withSymbols _ state = #onFileWithSymbols.
	(outPointers includes: aClass) ifFalse: [^ self].
		"If has instances, they point out at the class"
	state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]].
	segSize _ segment size.
	self install.
	oldInstances _ OrderedCollection new.
	self allObjectsDo: [:obj | obj class == aClass ifTrue: [
		oldInstances add: obj]].
	oldInstances do: [:inst | aBlock value: inst].	"do the work"
	self copyFromRoots: arrayOfRoots sizeHint: segSize.
	self extract.
	withSymbols 
		ifTrue: [self writeToFileWithSymbols]
		ifFalse: [self writeToFile].

! !

!ImageSegment methodsFor: 'instance change shape' stamp: 'tk 1/25/2000 21:54'!
ifOutPointer: anObject thenAllObjectsDo: aBlock
	| withSymbols segSize |
	"If I point out to anObject, bring me in, Submit all my objects to the block.  Write me out again."

	(state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self].
	withSymbols _ state = #onFileWithSymbols.
	(outPointers includes: anObject) ifFalse: [^ self].
	state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]].
	segSize _ segment size.
	self install.
	self allObjectsDo: [:obj | aBlock value: obj].	"do the work"
	self copyFromRoots: arrayOfRoots sizeHint: segSize.
	self extract.
	withSymbols 
		ifTrue: [self writeToFileWithSymbols]
		ifFalse: [self writeToFile].

! !

!ImageSegment methodsFor: 'instance change shape' stamp: 'ar 4/10/2005 22:19'!
segUpdateInstancesOf: oldClass toBe: newClass isMeta: isMeta
	| withSymbols oldInstances segSize |
	"Bring me in, locate instances of oldClass and get them converted.  Write me out again."

	(state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self].
	withSymbols _ state = #onFileWithSymbols.
	"If has instances, they point out at the class"
	(outPointers includes: oldClass) ifFalse: [
		oldClass == SmallInteger ifTrue: [^ self].	"instance not changable"
		oldClass == Symbol ifTrue: [^ self].	"instance is never in a segment"
		oldClass == ByteSymbol ifTrue: [^ self].	"instance is never in a segment"
		(Smalltalk compactClassesArray includes: oldClass) ifFalse: [^ self]].
		"For a compact class, must search the segment.  Instance does not 
		 point outward to class"
	state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]].
	segSize _ segment size.
	self install.
	oldInstances _ OrderedCollection new.
	self allObjectsDo: [:obj | obj class == oldClass ifTrue: [
		oldInstances add: obj]].
	newClass updateInstances: oldInstances asArray from: oldClass isMeta: isMeta.
	self copyFromRoots: arrayOfRoots sizeHint: segSize.
	self extract.
	withSymbols 
		ifTrue: [self writeToFileWithSymbols]
		ifFalse: [self writeToFile].
! !


!ImageSegment methodsFor: 'primitives' stamp: 'di 3/28/1999 13:47'!
loadSegmentFrom: segmentWordArray outPointers: outPointerArray
	"This primitive will install a binary image segment and return as its value the array of roots of the tree of objects represented.  Upon successful completion, the wordArray will have been transmuted into an object of zero length.  If this primitive should fail, it will have destroyed the contents of the segment wordArray."

	<primitive: 99>	"successful completion returns the array of roots"
	^ nil			"failure returns nil"! !

!ImageSegment methodsFor: 'primitives' stamp: 'di 3/28/1999 13:49'!
storeSegmentFor: rootsArray into: segmentWordArray outPointers: outPointerArray
	"This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree).  Note: all elements of the reciever are treated as roots indetermining the extent of the tree.  All pointers from within the tree to objects outside the tree will be copied into the array of outpointers.  In their place in the image segment will be an oop equal to the offset in the outpointer array (the first would be 4). but with the high bit set."

	"The primitive expects the array and wordArray to be more than adequately long.  In this case it returns normally, and truncates the two arrays to exactly the right size.  If either array is too small, the primitive will fail, but in no other case."

	<primitive: 98>	"successful completion returns self"
	^ nil			"failure returns nil"! !


!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/5/2000 11:09'!
copyFromRoots: aRootArray sizeHint: segSizeHint
	"Copy a tree of objects into a WordArray segment.  The copied objects in the segment are not in the normal Squeak space.  If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside.  (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)
	Caller must hold onto Symbols.
	To go faster, make sure objects are not repeated in aRootArray and other method directly, with true."

	self copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: false
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 1/10/2001 14:03'!
copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: areUnique
	"Copy a tree of objects into a WordArray segment.  The copied objects in the segment are not in the normal Squeak space.  
	[1] For exporting a project.  Objects were enumerated by ReferenceStream and aRootArray has them all.
	[2] For exporting some classes.  See copyFromRootsForExport:. (Caller must hold Symbols, or they will not get registered in the target system.)
	[3] For 'local segments'.  outPointers are kept in the image.
	If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside.  (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)"
	| segmentWordArray outPointerArray segSize rootSet uniqueRoots |
	aRootArray ifNil: [self errorWrongState].
	uniqueRoots _ areUnique 
		ifTrue: [aRootArray]
		ifFalse: [rootSet _ IdentitySet new: aRootArray size * 3.
			uniqueRoots _ OrderedCollection new.
			1 to: aRootArray size do: [:ii |	"Don't include any roots twice"
				(rootSet includes: (aRootArray at: ii)) 
					ifFalse: [
						uniqueRoots addLast: (aRootArray at: ii).
						rootSet add: (aRootArray at: ii)]
					ifTrue: [userRootCnt ifNotNil: ["adjust the count"
								ii <= userRootCnt ifTrue: [userRootCnt _ userRootCnt - 1]]]].
			uniqueRoots].
	arrayOfRoots _ uniqueRoots asArray.
	rootSet _ uniqueRoots _ nil.	"be clean"
	userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
	arrayOfRoots do: [:aRoot | 
		aRoot indexIfCompact > 0 ifTrue: [
			self error: 'Compact class ', aRoot name, ' cannot be a root'].
		aRoot _ nil].	"clean up"
	outPointers _ nil.	"may have used this instance before"
	segSize _ segSizeHint > 0 ifTrue: [segSizeHint *3 //2] ifFalse: [50000].

	["Guess a reasonable segment size"
	segmentWordArray _ WordArrayForSegment new: segSize.
	[outPointerArray _ Array new: segSize // 20] ifError: [
		state _ #tooBig.  ^ self].
	"Smalltalk garbageCollect."
	(self storeSegmentFor: arrayOfRoots
					into: segmentWordArray
					outPointers: outPointerArray) == nil]
		whileTrue:
			["Double the segment size and try again"
			segmentWordArray _ outPointerArray _ nil.
			segSize _ segSize * 2].
	segment _ segmentWordArray.
	outPointers _ outPointerArray.
	state _ #activeCopy.
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'ar 4/10/2005 22:49'!
copyFromRootsForExport: rootArray 
	"When possible, use copySmartRootsExport:.  This way may not copy a complete tree of objects.  Add to roots: all of the methods pointed to from the outside by blocks."
	| newRoots list segSize symbolHolder |
	arrayOfRoots _ rootArray.
	Smalltalk forgetDoIts.
	"self halt."
	symbolHolder _ Symbol allSymbols.	"Hold onto Symbols with strong pointers, 
		so they will be in outPointers"
	(newRoots _ self rootsIncludingPlayers) ifNotNil: [
		arrayOfRoots _ newRoots].		"world, presenter, and all Player classes"
	"Creation of the segment happens here"
	self copyFromRoots: arrayOfRoots sizeHint: 0.
	segSize _ segment size.
	[(newRoots _ self rootsIncludingBlockMethods) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize].
		"with methods pointed at from outside"
	[(newRoots _ self rootsIncludingBlocks) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize].
		"with methods, blocks from outPointers"
	"classes of receivers of blocks"
	list _ self compactClassesArray.
	outPointers _ outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
	"Zap sender of a homeContext. Can't send live stacks out."
	1 to: outPointers size do: [:ii | 
		(outPointers at: ii) class == BlockContext ifTrue: [outPointers at: ii put: nil].
		(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]].
	symbolHolder.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 2/8/2000 13:34'!
copyFromRootsLocalFileFor: rootArray sizeHint: segSize
	"If the roots include a World, add its Player classes to the roots."
	| newRoots |

	arrayOfRoots _ rootArray.
	[(newRoots _ self rootsIncludingPlayers) == nil] whileFalse: [
		arrayOfRoots _ newRoots].		"world, presenter, and all Player classes"
	Smalltalk forgetDoIts.  
	self copyFromRoots: arrayOfRoots sizeHint: segSize.
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'CdG 10/17/2005 19:46'!
copySmartRootsExport: rootArray 
	"Use SmartRefStream to find the object.  Make them all roots.  Create the segment in memory.  Project should be in first five objects in rootArray."
	| newRoots list segSize symbolHolder dummy replacements naughtyBlocks goodToGo allClasses sizeHint proj |
	Smalltalk forgetDoIts.

	"self halt."
	symbolHolder _ Symbol allInstances.	"Hold onto Symbols with strong pointers, 
		so they will be in outPointers"

	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy insideASegment: true.	"So Uniclasses will be traced"
	dummy rootObject: rootArray.	"inform him about the root"
	dummy nextPut: rootArray.
	(proj _dummy project) ifNotNil: [self dependentsSave: dummy].
	allClasses _ SmartRefStream new uniClassInstVarsRefs: dummy.
		"catalog the extra objects in UniClass inst vars.  Put into dummy"
	allClasses do: [:cls | 
		dummy references at: cls class put: false.	"put Player5 class in roots"
		dummy blockers removeKey: cls class ifAbsent: []].
	"refs _ dummy references."
	arrayOfRoots _ self smartFillRoots: dummy.	"guaranteed none repeat"
	self savePlayerReferences: dummy references.	"for shared References table"
	replacements _ dummy blockers.
	dummy project "recompute it" ifNil: [self error: 'lost the project!!'].
	dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project'].
	dummy _ nil.	"force GC?"
	naughtyBlocks _ arrayOfRoots select: [ :each |
		(each isKindOf: ContextPart) and: [each hasInstVarRef]
	].

	"since the caller switched ActiveWorld, put the real one back temporarily"
	naughtyBlocks isEmpty ifFalse: [
		World becomeActiveDuring: [
			goodToGo _ UIManager default
					chooseFrom: #('keep going' 'stop and take a look') 
					title: 
'Some block(s) which reference instance variables 
are included in this segment. These may fail when
the segment is loaded if the class has been reshaped.
What would you like to do?' 
.
			(goodToGo = 1) ifFalse: [
				naughtyBlocks inspect.
				self error: 'Here are the bad blocks'].
		].
	].
	"Creation of the segment happens here"

	"try using one-quarter of memory min: four megs to publish (will get bumped later)"
	sizeHint _ (Smalltalk garbageCollect // 4 // 4) min: 1024*1024.
	self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true.
	segSize _ segment size.
	[(newRoots _ self rootsIncludingBlockMethods) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
		"with methods pointed at from outside"
	[(newRoots _ self rootsIncludingBlocks) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
		"with methods, blocks from outPointers"
	list _ self compactClassesArray.
	outPointers _ outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
	1 to: outPointers size do: [:ii | 
		(outPointers at: ii) class == BlockContext ifTrue: [outPointers at: ii put: nil].
		(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil].
		"substitute new object in outPointers"
		(replacements includesKey: (outPointers at: ii)) ifTrue: [
			outPointers at: ii put: (replacements at: (outPointers at: ii))]].
	proj ifNotNil: [self dependentsCancel: proj].
	symbolHolder.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'sw 11/19/2002 14:40'!
dependentsCancel: aProject
	"Erase the place we temporarily held the dependents of things in this project.  So we don't carry them around forever."

	aProject projectParameters removeKey: #GlobalDependentsInProject ifAbsent: []! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/21/2002 16:17'!
dependentsRestore: aProject
	"Retrieve the list of dependents from the exporting system, hook them up, and erase the place we stored them."

	| dict |
	dict _ aProject projectParameterAt: #GlobalDependentsInProject.
	dict ifNil: [^ self].
	dict associationsDo: [:assoc |
		assoc value do: [:dd | assoc key addDependent: dd]].

	self dependentsCancel: aProject.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/21/2002 16:25'!
dependentsSave: dummy
	"Object that have dependents are supposed to be instances of subclasses of Model.  But, class Objects still provides 'Global Dependents', and some people still use them.  When both the model and the dependent are in a project that is being saved, remember them, so we can hook them up when this project is loaded in."

	| dict proj list |
	proj _ dummy project.
	dict _ Dictionary new.
	DependentsFields associationsDo: [:assoc |
		(dummy references includesKey: assoc key) ifTrue: [
			list _ assoc value select: [:dd | dummy references includesKey: dd].
			list size > 0 ifTrue: [dict at: assoc key put: list]]].

	dict size > 0 ifTrue: [
		proj projectParameterAt: #GlobalDependentsInProject put: dict].
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 11/30/1999 22:30'!
extract
	"This operation replaces (using become:) all the original roots of a segment with segmentRootStubs.  Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed."

	Cursor write showWhile: [
		state = #inactive ifTrue: [self copyFromRoots: arrayOfRoots sizeHint: 0].
		state = #activeCopy ifFalse: [self errorWrongState].
		arrayOfRoots elementsForwardIdentityTo:
			(arrayOfRoots collect: [:r | r rootStubInImageSegment: self]).
		state _ #active].
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'di 3/28/1999 13:47'!
extractThenInstall
	"For testing only"

	| newRoots |
	state = #activeCopy ifFalse: [self errorWrongState].
	arrayOfRoots elementsForwardIdentityTo:
		(arrayOfRoots collect: [:r | r rootStubInImageSegment: self]).
	state _ #active.
	newRoots _ self loadSegmentFrom: segment outPointers: outPointers.
	state _ #inactive.
	arrayOfRoots elementsForwardIdentityTo: newRoots.
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 6/22/2001 15:40'!
findStacks
	"Return an array of all the StackMorphs in this project."

| guys stacks |
guys _ StackMorph withAllSubclasses asIdentitySet.
stacks _ OrderedCollection new.
arrayOfRoots do: [:obj |
	(guys includes: obj class) ifTrue: [stacks add: obj]].
^ stacks! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'gk 2/24/2004 23:53'!
install
	"This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment."

	| newRoots |
	state = #onFile ifTrue: [self readFromFile].
	state = #onFileWithSymbols ifTrue: [self readFromFileWithSymbols.
		endMarker _ segment nextObject. 	"for enumeration of objects"
		endMarker == 0 ifTrue: [endMarker _ 'End' clone]].
	(state = #active) | (state = #imported) ifFalse: [self errorWrongState].
	newRoots _ self loadSegmentFrom: segment outPointers: outPointers.
	state = #imported 
		ifTrue: ["just came in from exported file"
			arrayOfRoots _ newRoots]
		ifFalse: [
			arrayOfRoots elementsForwardIdentityTo: newRoots].
	state _ #inactive.
	Beeper beepPrimitive! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/17/1999 00:03'!
localName
	| segs ind sep |
	"Return the current file name for this segment, a local name in the segments directory."

	fileName ifNil: [^ nil].
	"^ fileName"	

	"The following is for backward compatibility.  Remove this part after June 2000.
	Check if the fileName is a full path, and make it local.  Regardless of current or previous file system delimiter."

	segs _ self class folder copyLast: 4.  "_segs"
	ind _ 1.
	[ind _ fileName findString: segs startingAt: ind+1 caseSensitive: false.
		ind = 0 ifTrue: [^ fileName].
		sep _ fileName at: ind + (segs size).
		sep isAlphaNumeric ] whileTrue.		"sep is letter or digit, not a separator"

	^ fileName _ fileName copyFrom: ind+(segs size)+1 "delimiter" to: fileName size! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'mdr 8/31/2000 19:01'!
readFromFile
	"Read in a simple segment.  Use folder of this image, even if remembered as previous location of this image"

	| ff realName |
	realName _ self class folder, FileDirectory slash, self localName.
	ff _ FileStream readOnlyFileNamed: realName.
	segment _ ff nextWordsInto: (WordArrayForSegment new: ff size//4).
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
	ff close.
	state _ #active! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/26/1999 13:07'!
revert
	"Pretend this segment was never brought in.  Check that it has a fileName.  Replace (using become:) all the original roots of a segment with segmentRootStubs.  Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed.
	How to use revert:  In the project, choose 'save for reverting'.

	ReEnter the project.  Make changes.
	Either exit normally, and change will be kept, or
		Choose 'Revert to saved version'."

	fileName ifNil: [^ self].
	(state = #inactive) | (state = #onFile) ifFalse: [^ self].
	Cursor write showWhile: [
		arrayOfRoots elementsForwardIdentityTo:
			(arrayOfRoots collect: [:r | r rootStubInImageSegment: self]).
		state _ #onFile.
		segment _ nil.
		endMarker _ nil].

"Old version:
	How to use revert:  In the project, execute 
(Project current projectParameters at: #frozen put: true)
	Leave the project.  Check that the project went out to disk (it is gray in the Jump to Project list).
	ReEnter the project.  Hear a plink as it comes in from disk.  Make a change.
	Exit the project.  Choose 'Revert to previous version' in the dialog box.
	Check that the project went out to disk (it is gray in the Jump to Project list).
	ReEnter the project and see that it is in the original state."

! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 3/6/2000 11:05'!
rootsIncludingBlockMethods
	"Return a new roots array with more objects.  (Caller should store into rootArray.) Any CompiledMethods that create blocks will be in outPointers if the block is held outside of this segment.  Put such methods into the roots list.  Then ask for the segment again."

| extras myClasses gotIt |
userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
extras _ OrderedCollection new.
myClasses _ OrderedCollection new.
arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [
					myClasses add: aRoot]].
myClasses isEmpty ifTrue: [^ nil].	"no change"
outPointers do: [:anOut | 
	anOut class == CompiledMethod ifTrue: [
		"specialized version of who"
		gotIt _ false.
		myClasses detect: [:class |
			class selectorsDo: [:sel |
				(class compiledMethodAt: sel) == anOut 
					ifTrue: [extras add: anOut.  gotIt _ true]].
			gotIt] 
			ifNone: []
		].
	anOut _ nil].
extras _ extras select: [:ea | (arrayOfRoots includes: ea) not].
extras isEmpty ifTrue: [^ nil].	"no change"
^ arrayOfRoots, extras! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 3/6/2000 11:04'!
rootsIncludingBlocks
	"For export segments only.  Return a new roots array with more objects.  (Caller should store into rootArray.)  Collect Blocks and external methods pointed to by them.  Put them into the roots list.  Then ask for the segment again."

	| extras have |
	userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
	extras _ OrderedCollection new.
	outPointers do: [:anOut | 
		anOut class == CompiledMethod ifTrue: [extras add: anOut].
		(anOut class == BlockContext) ifTrue: [extras add: anOut].
		(anOut class == MethodContext) ifTrue: [extras add: anOut].
		anOut _ nil].	"don't hang onto it"

	[have _ extras size.
	 extras copy do: [:anOut |
		(anOut class == BlockContext) ifTrue: [
			anOut home ifNotNil: [
				(extras includes: anOut home) ifFalse: [extras add: anOut home]]].
		(anOut class == MethodContext) ifTrue: [
			anOut method ifNotNil: [
				(extras includes: anOut method) ifFalse: [extras add: anOut method]]]].
	 have = extras size] whileFalse.
	extras _ extras select: [:ea | (arrayOfRoots includes: ea) not].
	extras isEmpty ifTrue: [^ nil].	"no change"

	^ arrayOfRoots, extras! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'md 3/16/2006 22:44'!
rootsIncludingPlayers
	"Return a new roots array with more objects.  (Caller should store into rootArray.) Player (non-systemDefined) gets its class and metaclass put into the Roots array.  Then ask for the segment again."

| extras havePresenter players morphs existing |
userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
extras _ OrderedCollection new.
arrayOfRoots do: [:root | 
	(root isKindOf: Presenter) ifTrue: [havePresenter _ root].
	(root isKindOf: PasteUpMorph) ifTrue: [
			root isWorldMorph ifTrue: [havePresenter _ root presenter]].
	(root isKindOf: Project) ifTrue: [havePresenter _ root world presenter]].
havePresenter ifNotNil: [
	havePresenter flushPlayerListCache.		"old and outside guys"
	morphs _ IdentitySet new: 400.
	havePresenter associatedMorph allMorphsAndBookPagesInto: morphs.
	players _ (morphs select: [:m | m player ~~ nil] 
				thenCollect: [:m | m player]) asArray.
	players _ players select: [:ap | (arrayOfRoots includes: ap class) not
		& (ap class isSystemDefined not)].
	extras addAll: (players collect: [:each | each class]).
	extras addAll: (players collect: [:each | each class class]).
	extras addAll: morphs.	"Make then ALL roots!!"
	].
existing _ arrayOfRoots asIdentitySet.
extras _ extras reject: [ :each | existing includes: each].
extras isEmpty ifTrue: [^ nil].	"no change"
	
		havePresenter _ players _ morphs _ nil.
		^ arrayOfRoots, extras	"will contain multiples of some, but reduced later"
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/8/2000 10:00'!
savePlayerReferences: dictOfAllObjects
	| save world |
	"Save our associations we own in the shared References table.  They will be installed when the segment is imported."

	save _ OrderedCollection new.
	References associationsDo: [:assoc |
		(dictOfAllObjects includesKey: assoc) ifTrue: [save add: assoc]].
	1 to: 5 do: [:ii | ((arrayOfRoots at: ii) respondsTo: #isCurrentProject) ifTrue: [
					world _ (arrayOfRoots at: ii) world]].
	world setProperty: #References toValue: save.
		"assume it is not refed from outside and will be traced"! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'di 3/28/1999 13:48'!
segmentCopy
	"This operation will install a copy of the segment in memory, and return a copy of the array of roots.  The effect is to perform a deep copy of the original structure.  Note that installation destroys the segment, so it must be copied before doing the operation."

	state = #activeCopy ifFalse: [self errorWrongState].
	^ self loadSegmentFrom: segment copy outPointers: outPointers! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:39'!
segmentName
	"Return the local file name for this segment."

	^ segmentName! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/13/1999 09:19'!
segmentName: aString
	"Local file name for this segment."

	segmentName _ aString! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'ar 4/10/2005 22:19'!
smartFillRoots: dummy
	| refs known ours ww blockers |
	"Put all traced objects into my arrayOfRoots.  Remove some
that want to be in outPointers.  Return blockers, an
IdentityDictionary of objects to replace in outPointers."

	blockers _ dummy blockers.
	known _ (refs _ dummy references) size.
	refs fasterKeys do: [:obj | "copy keys to be OK with removing items"
		(obj isSymbol) ifTrue: [refs removeKey: obj.
known _ known-1].
		(obj class == PasteUpMorph) ifTrue: [
			obj isWorldMorph & (obj owner == nil) ifTrue: [
				obj == dummy project world ifFalse: [
					refs removeKey: obj.  known _ known-1.
					blockers at: obj put:
						(StringMorph
contents: 'The worldMorph of a different world')]]].
					"Make a ProjectViewMorph here"
		"obj class == Project ifTrue: [Transcript show: obj; cr]."
		(blockers includesKey: obj) ifTrue: [
			refs removeKey: obj ifAbsent: [known _
known+1].  known _ known-1].
		].
	ours _ dummy project world.
	refs keysDo: [:obj |
			obj isMorph ifTrue: [
				ww _ obj world.
				(ww == ours) | (ww == nil) ifFalse: [
					refs removeKey: obj.  known _ known-1.
					blockers at: obj put:
(StringMorph contents:
								obj
printString, ' from another world')]]].
	"keep original roots on the front of the list"
	(dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []].
	^ dummy rootObject, refs fasterKeys asArray.

! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'mir 10/11/2000 19:08'!
writeForExport: shortName
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk."

	| fileStream temp |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	temp _ endMarker.
	endMarker _ nil.
	fileStream _ FileStream newFileNamed: (FileDirectory fileName: shortName extension: self class fileExtension).
	fileStream fileOutClass: nil andObject: self.
		"remember extra structures.  Note class names."
	endMarker _ temp.
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 9/30/2000 20:53'!
writeForExportWithSources: fName inDirectory: aDirectory
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk.  Append the source code of any classes in roots.  Target system will quickly transfer the sources to its changes file."

	"this is the old version which I restored until I solve the gzip problem"

	| fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	(fName includes: $.) ifFalse: [
		^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.].
	temp _ endMarker.
	endMarker _ nil.
	tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'.
	zipper _ [
		ProgressNotification signal: '3:uncompressedSaveComplete'.
		(aDirectory oldFileNamed: tempFileName) compressFile.	"makes xxx.gz"
		aDirectory 
			rename: (tempFileName, FileDirectory dot, 'gz')
			toBe: fName.
		aDirectory
			deleteFileNamed: tempFileName
			ifAbsent: []
	].
	fileStream _ aDirectory newFileNamed: tempFileName.
	fileStream fileOutClass: nil andObject: self.
		"remember extra structures.  Note class names."
	endMarker _ temp.

	"append sources"
	allClassesInRoots _ arrayOfRoots select: [:cls | cls isKindOf: Behavior].
	classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined].
	methodsWithSource _ OrderedCollection new.
	allClassesInRoots do: [ :cls |
		(classesToWriteEntirely includes: cls) ifFalse: [
			cls selectorsAndMethodsDo: [ :sel :meth |
				meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}].
			].
		].
	].
	(classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self].

	fileStream reopen; setToEnd.
	fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
	methodsWithSource do: [ :each |
		fileStream nextPut: $!!.	"try to pacify ImageSegment>>scanFrom:"
		fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ',
				each first name printString,' methodsFor: ',
				(each first organization categoryOfElement: each second) asString printString,
				' stamp: ',(Utilities timeStampForMethod: each third) printString; cr.
		fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString.
		fileStream nextChunkPut: ' '; cr.
	].
	classesToWriteEntirely do: [:cls | 
		cls isMeta ifFalse: [fileStream nextPutAll: 
						(cls name, ' category: ''', cls category, '''.!!'); cr; cr].
		cls organization
			putCommentOnFile: fileStream
			numbered: 0
			moveSource: false
			forClass: cls.	"does nothing if metaclass"
		cls organization categories do: 
			[:heading |
			cls fileOutCategory: heading
				on: fileStream
				moveSource: false
				toFile: 0]].
	"no class initialization -- it came in as a real object"
	fileStream close.
	zipper value.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/2/2004 12:41'!
writeForExportWithSources: fName inDirectory: aDirectory changeSet:
aChangeSetOrNil
	"Write the segment on the disk with all info needed to
reconstruct it in a new image.  For export.  Out pointers are encoded
as normal objects on the disk.  Append the source code of any classes
in roots.  Target system will quickly transfer the sources to its
changes file."
	"Files out a changeSet first, so that a project can contain
classes that are unique to the project."

	| fileStream temp tempFileName zipper allClassesInRoots
classesToWriteEntirely methodsWithSource |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	(fName includes: $.) ifFalse: [
		^ self inform: 'Please use ''.pr'' or ''.extSeg'' at
the end of the file name'.].
	temp _ endMarker.
	endMarker _ nil.
	tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'.
	zipper _ [
		Preferences debugPrintSpaceLog ifTrue:[
			fileStream _ aDirectory newFileNamed:
				(fName copyFrom: 1 to: (fName
lastIndexOf: $.)), 'space'.
			self printSpaceAnalysisOn: fileStream.
			fileStream close].
		ProgressNotification signal: '3:uncompressedSaveComplete'.
		(aDirectory oldFileNamed: tempFileName) compressFile.
	"makes xxx.gz"
		aDirectory
			rename: (tempFileName, FileDirectory dot, 'gz')
			toBe: fName.
		aDirectory
			deleteFileNamed: tempFileName
			ifAbsent: []
	].
	fileStream _ aDirectory newFileNamed: tempFileName.
	fileStream fileOutChangeSet: aChangeSetOrNil andObject: self.
		"remember extra structures.  Note class names."
	endMarker _ temp.

	"append sources"
	allClassesInRoots _ arrayOfRoots select: [:cls | cls
isKindOf: Behavior].
	classesToWriteEntirely _ allClassesInRoots select: [ :cls |
cls theNonMetaClass isSystemDefined].
	methodsWithSource _ OrderedCollection new.
	allClassesInRoots do: [ :cls |
		(classesToWriteEntirely includes: cls) ifFalse: [
			cls selectorsAndMethodsDo: [ :sel :meth |
				meth sourcePointer = 0 ifFalse:
[methodsWithSource add: {cls. sel. meth}].
			].
		].
	].
	(classesToWriteEntirely isEmpty and: [methodsWithSource
isEmpty]) ifTrue: [zipper value. ^ self].

	fileStream reopen; setToEnd.
	fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
	methodsWithSource do: [ :each |
		fileStream nextPut: $!!.	"try to pacify
ImageSegment>>scanFrom:"
		fileStream nextChunkPut: 'RenamedClassSourceReader
formerClassName: ',
				each first name printString,' methodsFor: ',
				(each first organization
categoryOfElement: each second) asString printString,
				' stamp: ',(Utilities
timeStampForMethod: each third) printString; cr.
		fileStream nextChunkPut: (each third getSourceFor:
each second in: each first) asString.
		fileStream nextChunkPut: ' '; cr.
	].
	classesToWriteEntirely do: [:cls |
		cls isMeta ifFalse: [fileStream nextPutAll:
						(cls name, '
category: ''', cls category, '''.!!'); cr; cr].
		cls organization
			putCommentOnFile: fileStream
			numbered: 0
			moveSource: false
			forClass: cls.	"does nothing if metaclass"
		cls organization categories do:
			[:heading |
			cls fileOutCategory: heading
				on: fileStream
				moveSource: false
				toFile: 0]].
	"no class initialization -- it came in as a real object"
	fileStream close.
	zipper value.
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 7/11/2000 18:33'!
writeForExportWithSourcesGZ: fName inDirectory: aDirectory
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk.  Append the source code of any classes in roots.  Target system will quickly transfer the sources to its changes file."

	"this is the gzipped version which I have temporarily suspended until I can get resolve the problem with forward references tring to reposition the stream - RAA 11 june 2000"




	| fileStream temp allClassesInRoots classesToWriteEntirely methodsWithSource |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	(fName includes: $.) ifFalse: [
		^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.].
	temp _ endMarker.
	endMarker _ nil.
	fileStream _ GZipSurrogateStream newFileNamed: fName inDirectory: aDirectory.
	fileStream fileOutClass: nil andObject: self.
		"remember extra structures.  Note class names."
	endMarker _ temp.

	"append sources"
	allClassesInRoots _ arrayOfRoots select: [:cls | cls isKindOf: Behavior].
	classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined].
	methodsWithSource _ OrderedCollection new.
	allClassesInRoots do: [ :cls |
		(classesToWriteEntirely includes: cls) ifFalse: [
			cls selectorsAndMethodsDo: [ :sel :meth |
				meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}].
			].
		].
	].
	(classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [
		fileStream reallyClose.	"since #close is ignored"
		^ self
	].
	"fileStream reopen; setToEnd."	"<--not required with gzipped surrogate stream"
	fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
	methodsWithSource do: [ :each |
		fileStream nextPut: $!!.	"try to pacify ImageSegment>>scanFrom:"
		fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ',
				each first name printString,' methodsFor: ',
				(each first organization categoryOfElement: each second) asString printString,
				' stamp: ',(Utilities timeStampForMethod: each third) printString; cr.
		fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString.
		fileStream nextChunkPut: ' '; cr.
	].
	classesToWriteEntirely do: [:cls | 
		cls isMeta ifFalse: [fileStream nextPutAll: 
						(cls name, ' category: ''', cls category, '''.!!'); cr; cr].
		cls organization
			putCommentOnFile: fileStream
			numbered: 0
			moveSource: false
			forClass: cls.	"does nothing if metaclass"
		cls organization categories do: 
			[:heading |
			cls fileOutCategory: heading
				on: fileStream
				moveSource: false
				toFile: 0]].
	"no class initialization -- it came in as a real object"
	fileStream reallyClose.	"since #close is ignored"
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/17/1999 00:13'!
writeToFile

	state = #active ifFalse: [self error: 'wrong state'. ^ self].
	Cursor write showWhile: [
		segmentName ifNil: [
			segmentName _ (FileDirectory localNameFor: fileName) sansPeriodSuffix].
			"OK that still has number on end.  This is an unusual case"
		fileName _ self class uniqueFileNameFor: segmentName.	"local name"
		(self class segmentDirectory newFileNamed: fileName) nextPutAll: segment; close.
		segment _ nil.
		endMarker _ nil.
		state _ #onFile].! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:23'!
writeToFile: shortName
	"The short name can't have any fileDelimiter characters in it.  It is remembered in case the segment must be brought in and then sent out again (see ClassDescription updateInstancesFrom:)."

	segmentName _ (shortName endsWith: '.seg')
		ifTrue: [shortName copyFrom: 1 to: shortName size - 4]
		ifFalse: [shortName].
	segmentName last isDigit ifTrue: [segmentName _ segmentName, '-'].
	self writeToFile.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'ar 4/10/2005 22:19'!
writeToFileWithSymbols
	| symbols nonSymbols pound |

	state = #extracted ifFalse: [self error: 'wrong state'].
	segmentName ifNil: [
		segmentName _ (FileDirectory localNameFor: fileName) sansPeriodSuffix].
		"OK that still has number on end.  This is an unusual case"
	fileName _ self class uniqueFileNameFor: segmentName.
	symbols _ OrderedCollection new.
	nonSymbols _ OrderedCollection new.
	pound _ '#' asSymbol.
	outPointers do:
		[:s | 
		((s isSymbol) and: [s isLiteral and: [s ~~ pound]])
			ifTrue: [symbols addLast: s]
			ifFalse: [symbols addLast: pound.  nonSymbols addLast: s]].
	(self class segmentDirectory newFileNamed: fileName)
		store: symbols asArray; cr;
		nextPutAll: segment; close.
	outPointers _ nonSymbols asArray.
	state _ #onFileWithSymbols! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:23'!
writeToFileWithSymbols: shortName

	segmentName _ (shortName endsWith: '.seg')
		ifTrue: [shortName copyFrom: 1 to: shortName size - 4]
		ifFalse: [shortName].
	segmentName last isDigit ifTrue: [segmentName _ segmentName, '-'].
	self writeToFileWithSymbols.! !


!ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 18:44'!
classNameAt: index
	| ccIndex |
	ccIndex _ self compactIndexAt: index.
	ccIndex = 0 ifFalse:[^(Smalltalk compactClassesArray at: ccIndex) name].
	ccIndex _ segment at: index-1.
	(ccIndex bitAnd: 16r80000000) = 0 ifTrue:[
		"within segment; likely a user object"
		^#UserObject].
	ccIndex _ (ccIndex bitAnd: 16r7FFFFFFF) bitShift: -2.
	^(outPointers at: ccIndex) name! !

!ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 19:19'!
doSpaceAnalysis
	"Capture statistics about the IS and print the number of instances per class and space usage"
	| index sz word hdrBits cc instCount instSpace |
	state == #activeCopy ifFalse:[self errorWrongState].
	instCount _ IdentityDictionary new.
	instSpace _ IdentityDictionary new.
	index _ 2. 	"skip version word, first object"
	"go past extra header words"
	hdrBits _ (segment at: index) bitAnd: 3.
	hdrBits = 1 ifTrue: [index _ index+1].
	hdrBits = 0 ifTrue: [index _ index+2].
	[index > segment size] whileFalse:[
		hdrBits _ (word _ segment at: index) bitAnd: 3.
		hdrBits = 2 ifTrue:[sz _ word bitAnd: 16rFFFFFFFC].
		hdrBits = 0 ifTrue:[sz _ ((segment at: index-2) bitAnd: 16rFFFFFFFC) + 8].
		hdrBits = 1 ifTrue:[sz _ (word bitAnd: "SizeMask" 252) + 4].
		hdrBits = 3 ifTrue:[sz _ word bitAnd: "SizeMask" 252].
		hdrBits = 2 
			ifTrue:[cc _ #freeChunk]
			ifFalse:[cc _ self classNameAt: index].
		instCount at: cc put: (instCount at: cc ifAbsent:[0]) + 1.
		instSpace at: cc put: (instSpace at: cc ifAbsent:[0]) + sz.
		index _ self objectAfter: index].
	^{instCount. instSpace}! !

!ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 19:22'!
printSpaceAnalysisOn: aStream
	"Capture statistics about the IS and print the number of instances per class and space usage"
	| instCount instSpace sorted sum1 sum2 |
	instCount _ self doSpaceAnalysis.
	instSpace _ instCount last.
	instCount _ instCount first.
	sorted _ SortedCollection sortBlock:[:a1 :a2| a1 value >= a2 value].
	instSpace associationsDo:[:a| sorted add: a].
	sorted do:[:assoc|
		aStream cr; nextPutAll: assoc key; tab.
		aStream print: (instCount at: assoc key); nextPutAll:' instances '.
		aStream print: assoc value; nextPutAll: ' bytes '.
	].
	sum1 _ instCount inject: 0 into:[:sum :n| sum + n].
	sum2 _ instSpace inject: 0 into:[:sum :n| sum + n].
	aStream cr; cr.
	aStream print: sum1; nextPutAll:' instances '.
	aStream print: sum2; nextPutAll: ' bytes '.
! !


!ImageSegment methodsFor: 'testing' stamp: 'tk 11/30/1999 22:29'!
deepCopyTest: aRootArray
	"ImageSegment new deepCopyTest: Morph withAllSubclasses asArray"
	"Project allInstances do:
		[:p | p == Project current ifFalse:
			[Transcript cr; cr; nextPutAll: p name.
			ImageSegment new deepCopyTest: (Array with: p)]]."
	| t1 t2 copy |
	t1 _ Time millisecondsToRun: [self copyFromRoots: aRootArray sizeHint: 0].
	t2 _ Time millisecondsToRun: [copy _ self segmentCopy].
	Transcript cr; print: segment size * 4; nextPutAll: ' bytes stored with ';
		print: outPointers size; show: ' outpointers in '; print: t1; show: 'ms.'.
	Transcript cr; nextPutAll: 'Reconstructed in '; print: t2; show: 'ms.'.
	^ copy
"
Smalltalk allClasses do:
	[:m | ImageSegment new deepCopyTest: (Array with: m with: m class)]
"! !

!ImageSegment methodsFor: 'testing' stamp: 'di 3/26/1999 22:51'!
errorWrongState

	^ self error: 'wrong state'! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 9/3/1999 14:11'!
findInOut: anArray
	"Take an array of references to a morph, and try to classify them:  in the segment, in outPointers, or other."

String streamContents: [:strm |
	anArray withIndexDo: [:obj :ind |
		strm cr; nextPutAll: obj printString; space.

		]].! !

!ImageSegment methodsFor: 'testing' stamp: 'ar 9/14/2000 16:47'!
findOwnerMap: morphs
	| st |
	"Construct a string that has a printout of the owner chain for every morph in the list.  Need it as a string so not hold onto them."

st _ ''.
morphs do: [:mm |
	(st includesSubString: mm printString) ifFalse: [
		st _ st, '
', mm allOwners printString]].
Smalltalk at: #Owners put: st.
! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 9/7/1999 09:48'!
findOwnersOutPtrs

| ow ff |
ow _ Smalltalk at: #Owners ifAbsent: [^ self].
ow ifNil: [^ self].
outPointers do: [:oo | 
	oo isMorph ifTrue: [
		ow _ ow copyReplaceAll: oo printString with: oo printString, '[<<<- Pointed at]']].
ff _ FileStream fileNamed: 'Owners log'.
ff nextPutAll: ow; close.
Smalltalk at: #Owners put: ow.
ff edit.! !

!ImageSegment methodsFor: 'testing' stamp: 'ar 9/27/2005 18:02'!
findRogueRootsAllMorphs: rootArray 
	"This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
1) assemble all objects should be in seg:  morph tree, presenter, scripts, player classes, metaclasses.  Put in a Set.
2) Remove the roots from this list.  Ask for senders of each.  Of the senders, forget the ones that are in the segment already.  Keep others.  The list is now all the 'incorrect' pointers into the segment."

	| inSeg testRoots scriptEditors pointIn wld xRoots |
	Smalltalk garbageCollect.
	inSeg := IdentitySet new: 200.
	arrayOfRoots := rootArray.
	(testRoots := self rootsIncludingPlayers) ifNil: [testRoots := rootArray].
	testRoots do: 
			[:obj | 
			(obj isKindOf: Project) 
				ifTrue: 
					[inSeg add: obj.
					wld := obj world.
					inSeg add: wld presenter].
			(obj isKindOf: Presenter) ifTrue: [inSeg add: obj]].
	xRoots := wld ifNil: [testRoots] ifNotNil: [testRoots , (Array with: wld)].
	xRoots do: 
			[:obj | 
			"root is a project"

			obj isMorph 
				ifTrue: 
					[obj allMorphs do: 
							[:mm | 
							inSeg add: mm.
							mm player ifNotNil: [inSeg add: mm player]].
					obj isWorldMorph ifTrue: [inSeg add: obj presenter]]].
	scriptEditors := IdentitySet new.
	inSeg do: 
			[:obj | 
			obj isPlayerLike 
				ifTrue: 
					[scriptEditors addAll: (obj class tileScriptNames 
								collect: [:nn | obj scriptEditorFor: nn])]].
	scriptEditors do: [:se | inSeg addAll: se allMorphs].
	testRoots do: [:each | inSeg remove: each ifAbsent: []].
	"want them to be pointed at from outside"
	pointIn := IdentitySet new: 400.
	inSeg do: [:ob | pointIn addAll: (Utilities pointersTo: ob except: inSeg)].
	testRoots do: [:each | pointIn remove: each ifAbsent: []].
	pointIn remove: inSeg array ifAbsent: [].
	pointIn remove: pointIn array ifAbsent: [].
	inSeg do: 
			[:obj | 
			obj isMorph 
				ifTrue: 
					[pointIn remove: (obj instVarAt: 3)
						ifAbsent: 
							["submorphs"

							].
					"associations in extension"
					pointIn remove: obj extension ifAbsent: [].
					obj extension ifNotNil: 
							[obj extension otherProperties ifNotNil: 
									[obj extension otherProperties associationsDo: 
											[:ass | 
											pointIn remove: ass ifAbsent: []
											"*** and extension actorState"
											"*** and ActorState instantiatedUserScriptsDictionary ScriptInstantiations"]]]].
			obj isPlayerLike 
				ifTrue: [obj class scripts values do: [:us | pointIn remove: us ifAbsent: []]]].
	"*** presenter playerlist"
	self halt: 'Examine local variables pointIn and inSeg'.
	^pointIn! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 11/30/1999 22:30'!
findRogueRootsImSeg: rootArray
	"This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
1) Break all owner pointers in submorphs and all scripts.
2) Create the segment and look at outPointers.
3) Remove those we expect.
4) Remember to quit without saving -- the owner pointers are smashed."

| newRoots suspects bag1 bag2 |
arrayOfRoots _ rootArray.
[(newRoots _ self rootsIncludingPlayers) == nil] whileFalse: [
	arrayOfRoots _ newRoots].		"world, presenter, and all Player classes"
self findRogueRootsPrep.	"and free that context!!"
Smalltalk forgetDoIts.
Smalltalk garbageCollect.
self copyFromRoots: arrayOfRoots sizeHint: 0.

suspects _ outPointers select: [:oo | oo isMorph].
suspects size > 0 ifTrue: [suspects inspect].
bag1 _ Bag new.  bag2 _ Bag new.
outPointers do: [:key | 
	(key isKindOf: Class) 
		ifTrue: [bag2 add: key class name]
		ifFalse: [(#(Symbol Point Rectangle True False String Float Color Form ColorForm StrikeFont Metaclass UndefinedObject TranslucentColor) includes: key class name)
			ifTrue: [bag2 add: key class name]
			ifFalse: [bag1 add: key class name]]].
"(bag sortedCounts) is the SortedCollection"
(StringHolder new contents: bag1 sortedCounts printString, '

', bag2 sortedCounts printString) 
	openLabel: 'Objects pointed at by the outside'.
self halt: 'Examine local variables pointIn and inSeg'.

"Use this in inspectors:
	outPointers select: [:oo | oo class == <a Class>].		"

! !

!ImageSegment methodsFor: 'testing' stamp: 'gm 2/22/2003 18:36'!
findRogueRootsPrep
	"Part of the tool to track down unwanted pointers into the segment.  Break all owner pointers in submorphs, scripts, and viewers in flaps."

| wld players morphs scriptEditors |
wld _ arrayOfRoots detect: [:obj | 
	obj isMorph ifTrue: [obj isWorldMorph] ifFalse: [false]] ifNone: [nil].
wld ifNil: [wld _ arrayOfRoots detect: [:obj | obj isMorph] 
				ifNone: [^ self error: 'can''t find a root morph']].
morphs _ IdentitySet new: 400.
wld allMorphsAndBookPagesInto: morphs.
players _ wld presenter allExtantPlayers.	"just the cached list"
players do: [:pp |
	scriptEditors _ pp class tileScriptNames collect: [:nn | 
			pp scriptEditorFor: nn].
	scriptEditors do: [:se | morphs addAll: se allMorphs]].
wld submorphs do: [:mm | 	"non showing flaps"
	(mm isKindOf: FlapTab) ifTrue: [
		mm referent allMorphsAndBookPagesInto: morphs]].
morphs do: [:mm | 	"break the back pointers"
	mm isInMemory ifTrue: [
	(mm respondsTo: #target) ifTrue: [
		mm nearestOwnerThat: [:ow | ow == mm target 
			ifTrue: [mm target: nil. true]
			ifFalse: [false]]].
	(mm respondsTo: #arguments) ifTrue: [
		mm arguments do: [:arg | arg ifNotNil: [
			mm nearestOwnerThat: [:ow | ow == arg
				ifTrue: [mm arguments at: (mm arguments indexOf: arg) put: nil. true]
				ifFalse: [false]]]]].
	mm eventHandler ifNotNil: ["recipients point back up"
		(morphs includesAllOf: (mm eventHandler allRecipients)) ifTrue: [
			mm eventHandler: nil]].
	"temporary, until using Model for PartsBin"
	(mm isMorphicModel) ifTrue: [
		(mm model isMorphicModel) ifTrue: [
			mm model breakDependents]].
	(mm isTextMorph) ifTrue: [mm setContainer: nil]]].
(Smalltalk includesKey: #Owners) ifTrue: [Smalltalk at: #Owners put: nil].
	"in case findOwnerMap: is commented out"
"self findOwnerMap: morphs."
morphs do: [:mm | 	"break the back pointers"
	mm isInMemory ifTrue: [mm privateOwner: nil]].
"more in extensions?"

! !

!ImageSegment methodsFor: 'testing' stamp: 'ar 9/27/2005 18:02'!
findRogueRootsRefStrm: rootArray 
	"This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
1) assemble all objects that should be in the segment by using SmartReference Stream and a dummyReference Stream.  Put in a Set.
2) Remove the roots from this list.  Ask for senders of each.  Of the senders, forget the ones that are in the segment already.  Keep others.  The list is now all the 'incorrect' pointers into the segment."

	| dummy goodInSeg inSeg ok pointIn |
	dummy := ReferenceStream on: (DummyStream on: nil).
	"Write to a fake Stream, not a file"
	rootArray do: 
			[:root | 
			dummy rootObject: root.	"inform him about the root"
			dummy nextPut: root].
	inSeg := dummy references keys.
	dummy := nil.
	Smalltalk garbageCollect.	"dump refs dictionary"
	rootArray do: [:each | inSeg remove: each ifAbsent: []].
	"want them to be pointed at from outside"
	pointIn := IdentitySet new: 500.
	goodInSeg := IdentitySet new: 2000.
	inSeg do: 
			[:obj | 
			ok := obj class isPointers.
			obj class == Color ifTrue: [ok := false].
			obj class == TranslucentColor ifTrue: [ok := false].
			obj class == Array ifTrue: [obj size = 0 ifTrue: [ok := false]].
			"shared #() in submorphs of all Morphs"
			ok ifTrue: [goodInSeg add: obj]].
	goodInSeg 
		do: [:ob | pointIn addAll: (Utilities pointersTo: ob except: #())].
	inSeg do: [:each | pointIn remove: each ifAbsent: []].
	rootArray do: [:each | pointIn remove: each ifAbsent: []].
	pointIn remove: inSeg array ifAbsent: [].
	pointIn remove: goodInSeg array ifAbsent: [].
	pointIn remove: pointIn array ifAbsent: [].
	self halt: 'Examine local variables pointIn and inSeg'.
	^pointIn! !

!ImageSegment methodsFor: 'testing' stamp: 'di 9/29/1999 16:50'!
isOnFile
	^ state == #onFile! !

!ImageSegment methodsFor: 'testing' stamp: 'di 3/27/1999 22:04'!
verify: ob1 matches: ob2 knowing: matchDict

	| priorMatch first |
	ob1 == ob2 ifTrue:
		["If two pointers are same, they must be ints or in outPointers"
		((ob1 isMemberOf: SmallInteger) and: [ob1 = ob2]) ifTrue: [^ self].
		((ob1 isKindOf: Behavior) and: [ob1 indexIfCompact = ob2 indexIfCompact]) ifTrue: [^ self].
		(outPointers includes: ob1) ifTrue: [^ self].
		self halt].
	priorMatch _ matchDict at: ob1 ifAbsent: [nil].
	priorMatch == nil
		ifTrue: [matchDict at: ob1 put: ob2]
		ifFalse: [priorMatch == ob2
					ifTrue: [^ self]
					ifFalse: [self halt]].
	self verify: ob1 class matches: ob2 class knowing: matchDict.
	ob1 class isVariable ifTrue: 
		[ob1 basicSize = ob2 basicSize ifFalse: [self halt].
		first _ 1.
		(ob1 isMemberOf: CompiledMethod) ifTrue: [first _ ob1 initialPC].
		first to: ob1 basicSize do:
			[:i | self verify: (ob1 basicAt: i) matches: (ob2 basicAt: i) knowing: matchDict]].
	ob1 class instSize = ob2 class instSize ifFalse: [self halt].
	1 to: ob1 class instSize do:
		[:i | self verify: (ob1 instVarAt: i) matches: (ob2 instVarAt: i) knowing: matchDict].
	(ob1 isMemberOf: CompiledMethod) ifTrue:
		[ob1 header = ob2 header ifFalse: [self halt].
		ob1 numLiterals = ob2 numLiterals ifFalse: [self halt].
		1 to: ob1 numLiterals do:
			[:i | self verify: (ob1 literalAt: i) matches: (ob2 literalAt: i) knowing: matchDict]]! !

!ImageSegment methodsFor: 'testing' stamp: 'di 3/27/1999 21:36'!
verifyCopy

	| copyOfRoots matchDict |
	copyOfRoots _ self segmentCopy.
	matchDict _ IdentityDictionary new.
	arrayOfRoots with: copyOfRoots do:
		[:r :c | self verify: r matches: c knowing: matchDict]! !


!ImageSegment methodsFor: '*SMBase-export' stamp: 'stephaneducasse 2/4/2006 20:38'!
writeForExportOn: fileStream
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk."

	| temp |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	temp := endMarker.
	endMarker := nil.
	fileStream fileOutClass: nil andObject: self.
		"remember extra structures.  Note class names."
	endMarker := temp.
! !

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

ImageSegment class
	instanceVariableNames: ''!

!ImageSegment class methodsFor: 'accessing' stamp: 'mir 10/11/2000 17:33'!
compressedFileExtension
	^'sqz'! !

!ImageSegment class methodsFor: 'accessing' stamp: 'mir 10/11/2000 17:32'!
fileExtension
	^'extSeg'! !


!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'sd 9/30/2003 14:02'!
folder
	| im |
	"Full path name of segments folder.  Be sure to duplicate and rename the folder when you duplicate and rename an image.  Is $_ legal in all file systems?"

	im _ SmalltalkImage current imageName.
	^ (im copyFrom: 1 to: im size - 6 "'.image' size"), '_segs'! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'tk 12/16/1999 23:44'!
reclaimObsoleteSegmentFiles  "ImageSegment reclaimObsoleteSegmentFiles"
	"Delete segment files that can't be used after this image is saved.
	Note that this is never necessary -- it just saves file space."

	| aFileName segDir segFiles folderName byName exists |
	folderName _ FileDirectory default class localNameFor: self folder.
	(FileDirectory default includesKey: folderName) ifFalse: [
		^ self "don't create if absent"].
	segDir _ self segmentDirectory.
	segFiles _ (segDir fileNames select: [:fn | fn endsWith: '.seg']) asSet.
	exists _ segFiles copy.
	segFiles isEmpty ifTrue: [^ self].
	byName _ Set new.
	"Remove (save) every file owned by a segment in memory"
	ImageSegment allInstancesDo: [:is | 
		(aFileName _ is localName) ifNotNil: [
			segFiles remove: aFileName ifAbsent: [].
			(exists includes: aFileName) ifFalse: [
				Transcript cr; show: 'Segment file not found: ', aFileName].
			byName add: is segmentName]].
	"Of the segments we have seen, delete unclaimed the files."
	segFiles do: [:fName | 
		"Delete other file versions with same project name as one known to us"
		(byName includes: (fName sansPeriodSuffix stemAndNumericSuffix first))
			ifTrue: [segDir deleteFileNamed: fName]].! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'di 9/29/1999 15:45'!
segmentDirectory
	"Return a directory object for the folder of segments.
	Create such a folder if none exists."
	| dir folderName |
	dir _ FileDirectory default.
	folderName _ dir class localNameFor: self folder. "imageName_segs"
	(dir includesKey: folderName) ifFalse:
		[dir createDirectory: folderName].	"create the folder if necess"
	^ dir directoryNamed: folderName! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'tk 9/23/1999 17:50'!
shutDown
	"Delete segment files that can't be used after this image is saved."

	"This is Optional.  
(1) How tell if saving image now?  Only do if is.
(2) ImageSegmentRootStub allInstancesDo: 
	If more than one file, delete all but one we are using now.
	Leave files with not stubs (could be out in a segment)
	Must forbid two projects from having the same name!!
(3) all Projects do:
	If project is in, delete all files with its name.
"
	! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'rbb 2/18/2005 13:25'!
startUp
	| choice |
	"Minimal thing to assure that a .segs folder is present"

(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
	(FileDirectory default includesKey: (FileDirectory localNameFor: self folder)) 
		ifFalse: [
			choice _ UIManager default 
				chooseFrom: #('Create folder' 'Quit without saving')
				title: 
					'The folder with segments for this image is missing.\' withCRs,
					self folder, '\If you have moved or renamed the image file,\' withCRs,
					'please Quit and rename the segments folder in the same way'.
			choice = 1 ifTrue: [FileDirectory default createDirectory: self folder].
			choice = 2 ifTrue: [SmalltalkImage current snapshot: false andQuit: true]]]

	! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'tk 12/16/1999 22:33'!
uniqueFileNameFor: segName
	"Choose a unique file name for the segment with this name."
	| segDir fileName listOfFiles |
	segDir _ self segmentDirectory.
	listOfFiles _ segDir fileNames.
	BiggestFileNumber ifNil: [BiggestFileNumber _ 1].
	BiggestFileNumber > 99 ifTrue: [BiggestFileNumber _ 1].	"wrap"
	[fileName _ segName, BiggestFileNumber printString, '.seg'.
	 (listOfFiles includes: fileName)] whileTrue: [
		BiggestFileNumber _ BiggestFileNumber + 1].	"force a unique file name"
	^ fileName! !


!ImageSegment class methodsFor: 'testing' stamp: 'di 2/17/2000 21:58'!
activeClasses   "ImageSegment activeClasses"
	"Restore all remaining MD faults and return the active classes"

	| unused active |
	unused _ OrderedCollection new.
	active _ OrderedCollection new.
	Smalltalk allClasses do:
		[:c | (c instVarNamed: 'methodDict') 
			ifNil: [unused addLast: c]
			ifNotNil: [active addLast: c]].
	unused do: [:c | c recoverFromMDFault].
	^ active
! !

!ImageSegment class methodsFor: 'testing' stamp: 'di 2/17/2000 22:08'!
activeClassesByCategory   "ImageSegment activeClassesByCategory"
	"Return a dictionary of active classes by system category.
	Useful for finding kernel categories to minimize swapping."

	| active dict cat list |
	active _ self activeClasses.
	dict _ Dictionary new.
	active do:
		[:c | cat _ c category.
		list _ dict at: cat ifAbsent: [Array new].
		dict at: cat put: (list copyWith: c)].
	^ dict
"
	ImageSegment discoverActiveClasses  <-- do it
		-- do something typical --
	ImageSegment activeClassesByCategory  <-- inspect it
"! !

!ImageSegment class methodsFor: 'testing' stamp: 'di 3/7/2001 17:07'!
discoverActiveClasses   "ImageSegment discoverActiveClasses" 
	"Run this method, do a few things, maybe save and resume the image.
	This will leave unused classes with MDFaults.
	You MUST follow this soon by activeClasses, or by swapOutInactiveClasses."

	"NOTE:  discoverActiveClasses uses Squeak's ability to detect and recover from faults due to a nil method dictionary.  It staches the method dict in with the organization during the time when discovery is in progress (Gag me with a spoon).  This is why the faults need to be cleared promptly before resuming normal work with the system.  It is also important that classes *do not* refer directly to their method dictionary, but only via the accessor message."
	| ok |
	Smalltalk allClasses do:
		[:c | ok _ true.
		#(Array Object Class Message MethodDictionary) do:
			[:n | ((Smalltalk at: n) == c or:
				[(Smalltalk at: n) inheritsFrom: c]) ifTrue: [ok _ false]].
		ok ifTrue: [c induceMDFault]].
"
	ImageSegment discoverActiveClasses.
		-- do something typical --
	PopUpMenu notify: ImageSegment activeClasses size printString , ' classes were active out of ' ,
			Smalltalk allClasses size printString.
"! !

!ImageSegment class methodsFor: 'testing' stamp: 'tk 11/30/1999 22:27'!
swapOutInactiveClasses  "ImageSegment swapOutInactiveClasses"  
	"Make up segments by grouping unused classes by system category.
	Read about, and execute discoverActiveClasses, and THEN execute this one."

	| unused groups i roots |
	ImageSegment recoverFromMDFault.
	ImageSegmentRootStub recoverFromMDFault.
	unused _ Smalltalk allClasses select: [:c | (c instVarNamed: 'methodDict') == nil].
	unused do: [:c | c recoverFromMDFault].
	groups _ Dictionary new.
	SystemOrganization categories do:
		[:cat |
		i _ (cat findLast: [:c | c = $-]) - 1.
		i <= 0 ifTrue: [i _ cat size].
		groups at: (cat copyFrom: 1 to: i)
			put: (groups at: (cat copyFrom: 1 to: i) ifAbsent: [Array new]) ,
			((SystemOrganization superclassOrder: cat) select: [:c | 
				unused includes: c]) asArray].
	groups keys do:
		[:cat | roots _ groups at: cat.
		Transcript cr; cr; show: cat; cr; print: roots; endEntry.
		roots _ roots , (roots collect: [:c | c class]).
		(cat beginsWith: 'Sys' "something here breaks") ifFalse:
			[(ImageSegment new copyFromRoots: roots sizeHint: 0) extract; 
				writeToFile: cat].
		Transcript cr; print: Smalltalk garbageCollect; endEntry]! !

!ImageSegment class methodsFor: 'testing' stamp: 'RAA 9/27/2000 18:50'!
swapOutProjects  "ImageSegment swapOutProjects"  
	"Swap out segments for all projects other than the current one."

	| spaceLeft newSpaceLeft |
	spaceLeft _ Smalltalk garbageCollect.
	Project allProjects doWithIndex:
		[:p :i | p couldBeSwappedOut ifTrue:
			[Transcript cr; cr; nextPutAll: p name.
			(ImageSegment new copyFromRoots: (Array with: p) sizeHint: 0)
				extract; writeToFile: 'project' , i printString.
			newSpaceLeft _ Smalltalk garbageCollect.
			Transcript cr; print: newSpaceLeft - spaceLeft; endEntry.
			spaceLeft _ newSpaceLeft]].! !

!ImageSegment class methodsFor: 'testing' stamp: 'tk 11/30/1999 22:27'!
testClassFaultOn: someClass  "ImageSegment testClassFaultOn: FileList"  
	"Swap out a class with an existing instance.  Then send a message to the inst.
	This will cause the VM to choke down deep and resend #cannotInterpret:.
	This in turn will send a message to the stubbed class which will choke
	and resend: #doesNotUnderstand:.  Then, if we're lucky, things will start working."

	(ImageSegment new copyFromRoots: (Array with: someClass with: someClass class) 
		sizeHint: 0) extract; writeToFile: 'test'.
! !
ProtoObject subclass: #ImageSegmentRootStub
	instanceVariableNames: 'shadowSuper shadowMethodDict shadowFormat imageSegment'
	classVariableNames: 'FaultLogs LoggingFaults'
	poolDictionaries: ''
	category: 'System-Object Storage'!
!ImageSegmentRootStub commentStamp: '<historical>' prior: 0!
An ImageSegmentRootStub is a stub that replaces one of the root of an ImageSegment that has been extracted from the Squeak ObjectMemory.  It has two very simple roles:

1.  If any message is sent to one of these objects, it will be caught by doesNotUnderstand:, and bring about a reinstallation of the missing segment.  This exception is caused by the fact that no other messages are defined in this class, and neither does it inherit any from above, since its superclass is nil.  When the reinstallation has been accomplished, the message will be resent as though nothing was amiss.

2.  If one of these objects is a class, and a message is sent to one of its instances, it will cause a similar fault which will be caught by cannotInterpret:.  This exception is caused by a somewhat more subtle condition:  the primitive operations of the virtual machine do not have time to check whether classes are resident or not -- they assume that all classes are resident.  However every non-cached message lookup does test for a nil in the methodDictionary slot.  If a rootStub replaces a class (or any behavior), it masquerades as the class, but it will have a nil in the slot where the method Dictionary is expected.  This will cause the VM to send cannotInterpret:, eventually leading to the same process for reinstalling the missing segment and resending the message as above.

Just to be on the safe side, a rootStub that replaces a Behavior also carries a copy of both the superclass and format fields from the original class.  This insures that, even if some operations of the VM require these values, things will continue to operate properly when the segment is absent.!


!ImageSegmentRootStub methodsFor: 'basics' stamp: 'tk 8/13/1999 15:59'!
isInMemory
	"We are a place holder for an object that is out."
	^ false! !


!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'di 3/4/2001 22:45'!
doesNotUnderstand: aMessage 
	 | segmentName |
"Any normal message sent to this object is really intended for another object that is in a non-resident imageSegment.  Reinstall the segment and resend the message."

	segmentName _ imageSegment segmentName.
	imageSegment install.
	LoggingFaults ifTrue:		"Save the stack printout to show who caused the fault"
		[FaultLogs at: Time millisecondClockValue printString
			put: (String streamContents:
				[:strm | 
				strm nextPutAll: segmentName; cr.
				strm print: self class; space; print: aMessage selector; cr.
				(thisContext sender stackOfSize: 30)
					do: [:item | strm print: item; cr]])].

	"NOTE:  The following should really be (aMessage sentTo: self)
		in order to recover properly from a fault in a super-send,
		however, the lookupClass might be bogus in this case, and it's
		almost unthinkable that the first fault would be a super send."
	^ self perform: aMessage selector withArguments: aMessage arguments! !

!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'di 3/27/1999 12:19'!
xxSuperclass: superclass format: format segment: segment

	"Set up fields like a class but with null methodDict"
	shadowSuper _ superclass.
	shadowMethodDict _ nil.
	shadowFormat _ format.
	imageSegment _ segment.
! !

!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'tk 4/9/1999 10:32'!
xxxClass
	"Primitive. Answer the object which is the receiver's class. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 111>
	self primitiveFailed! !

!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'tk 10/24/1999 10:57'!
xxxSegment
	^ imageSegment! !

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

ImageSegmentRootStub class
	instanceVariableNames: ''!

!ImageSegmentRootStub class methodsFor: 'accessing' stamp: 'di 2/11/2000 12:33'!
faultLogs  "ImageSegmentRootStub faultLogs"  "<-- inspect it"

	^ FaultLogs! !


!ImageSegmentRootStub class methodsFor: 'settings' stamp: 'di 2/7/2000 23:43'!
doLogFaults  "ImageSegmentRootStub doLogFaults"

	FaultLogs _ Dictionary new.
	LoggingFaults _ true.! !

!ImageSegmentRootStub class methodsFor: 'settings' stamp: 'di 2/7/2000 23:17'!
dontLogFaults  "ImageSegmentRootStub dontLogFaults"

	FaultLogs _ Dictionary new.
	LoggingFaults _ false.! !

!ImageSegmentRootStub class methodsFor: 'settings' stamp: 'di 2/11/2000 12:31'!
startLoggingFaults  "ImageSegmentRootStub startLoggingFaults"

	FaultLogs _ Dictionary new.
	LoggingFaults _ true.! !

!ImageSegmentRootStub class methodsFor: 'settings' stamp: 'di 2/11/2000 12:33'!
stopLoggingFaults  "ImageSegmentRootStub stopLoggingFaults"

	FaultLogs _ Dictionary new.
	LoggingFaults _ false.! !
Object subclass: #ImmAbstractPlatform
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-ImmPlugin'!

!ImmAbstractPlatform methodsFor: 'all' stamp: 'yo 11/7/2002 17:43'!
keyboardFocusForAMorph: aMorph

	"do nothing"
! !
ImmAbstractPlatform subclass: #ImmWin32
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-ImmPlugin'!

!ImmWin32 methodsFor: 'all' stamp: 'fbs 1/7/2005 15:42'!
keyboardFocusForAMorph: aMorph

	| left top pos |
	aMorph ifNil: [^ self].
	[
		pos _ aMorph preferredKeyboardPosition.
		left _ (pos x min: Display width max: 0) asInteger.
		top _ (pos y min: Display height max: 0) asInteger.
		self setCompositionWindowPositionX: left y: top
	] on: Error
	do: [:ex |].
! !


!ImmWin32 methodsFor: 'as yet unclassified' stamp: 'yo 11/7/2002 16:47'!
setCompositionWindowPositionX: x y: y

	<primitive: 'primSetCompositionWindowPosition' module: 'ImmWin32Plugin'>

	^ nil
! !
ImmAbstractPlatform subclass: #ImmX11
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-ImmPlugin'!

!ImmX11 methodsFor: 'as yet unclassified' stamp: 'fbs 1/7/2005 15:42'!
keyboardFocusForAMorph: aMorph

	| left bottom pos |
	aMorph ifNil: [^ self].
	[
		pos _ aMorph preferredKeyboardPosition.
		left _ (pos x min: Display width max: 0) asInteger.
		bottom _ (pos y min: Display height max: 0) asInteger
			 + (aMorph paragraph
				characterBlockForIndex: aMorph editor selectionInterval first) height.
		self setCompositionWindowPositionX: left y: bottom
	] on: Error
	do: [:ex |].
! !

!ImmX11 methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/8/2003 08:46'!
setCompositionWindowPositionX: x y: y

	<primitive: 'primSetCompositionWindowPosition' module: 'ImmX11Plugin'>

	^ nil
! !
Object subclass: #Imports
	instanceVariableNames: 'imports'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!Imports commentStamp: 'sd 5/11/2003 20:34' prior: 0!
I represent imported resources such as images, sounds, and other kind of files. 
For now I only store images in a simple way. 

To access my default instance use: Imports default. However I'm not a strict singleton
and clients may create several of me using new. !


!Imports methodsFor: 'icons' stamp: 'nk 6/12/2004 12:44'!
importImageDirectory: directoryOrName 
	| dir extensions forms |
	dir := directoryOrName isString
		ifFalse: [ directoryOrName ]
		ifTrue: [ FileDirectory default directoryNamed: directoryOrName ].
	dir exists
		ifFalse: [self error: dir fullName , ' does not exist'. ^ #()].
	extensions := (ImageReadWriter allTypicalFileExtensions add: 'form';
				 yourself)
				collect: [:ex | '.' , ex].
	forms := OrderedCollection new.
	dir fileNames
		do: [:fileName | | fullName | (fileName endsWithAnyOf: extensions)
				ifTrue: [fullName := dir fullNameFor: fileName.
					(self importImageFromFileNamed: fullName)
						ifNotNilDo: [:form | forms add: form]]].
	^ forms! !

!Imports methodsFor: 'icons' stamp: 'nk 6/12/2004 12:44'!
importImageDirectoryWithSubdirectories: directoryOrName 
	| dir forms |
	dir := directoryOrName isString
		ifFalse: [ directoryOrName ]
		ifTrue: [ FileDirectory default directoryNamed: directoryOrName ].
	dir exists
		ifFalse: [self error: dir fullName , ' does not exist'. ^ #()].
	forms := OrderedCollection new.
	dir withAllSubdirectoriesCollect: [ :subdir | forms addAll: (self importImageDirectory: dir) ].
	^ forms! !

!Imports methodsFor: 'icons' stamp: 'nk 6/12/2004 12:25'!
importImageFromFileNamed: fullName 
	| localName pathParts form imageName |
	FileDirectory
		splitName: fullName
		to: [:dirPath :lname | 
			localName := lname.
			pathParts := dirPath findTokens: FileDirectory slash].
	form := [Form fromFileNamed: fullName]
				on: Error
				do: [:ex | ex return: nil].
	form
		ifNil: [^ nil].
	imageName := FileDirectory baseNameFor: localName.
	[imports includesKey: imageName]
		whileTrue: [imageName := pathParts isEmpty
						ifTrue: [Utilities
								keyLike: imageName
								satisfying: [:ea | (imports includesKey: ea) not]]
						ifFalse: [pathParts removeLast , '-' , imageName]].
	imports at: imageName put: form.
	^ form! !


!Imports methodsFor: 'images' stamp: 'sd 5/11/2003 20:36'!
images
	"returns all the imported images"

	^ imports values

	! !

!Imports methodsFor: 'images' stamp: 'nk 6/12/2004 12:49'!
importImage: anImage named: aName 
	imports
		at: (Utilities
				keyLike: aName
				satisfying: [:ea | (imports includesKey: ea) not])
		put: anImage! !

!Imports methodsFor: 'images' stamp: 'yo 7/17/2003 00:17'!
imports

	^ imports
! !

!Imports methodsFor: 'images' stamp: 'sd 5/11/2003 22:26'!
namesAndImagesDo: aBlock
	"iterate over all the names and image"

	^ imports keysAndValuesDo: aBlock

	! !

!Imports methodsFor: 'images' stamp: 'sd 5/11/2003 22:21'!
viewImages
	"Open up a special Form inspector on the dictionary of graphical imports."
	"Imports default viewImages"
	| widgetClass |
	imports size isZero ifTrue:
		[^ self inform: 
'The ImageImports repository is currently empty,
so there is nothing to view at this time.  You can
use a file list to import graphics from external files
into Imports, and once you have done that,
you will find this command more interesting.'].
	
	widgetClass := self couldOpenInMorphic
                ifTrue: [GraphicalDictionaryMenu]
			  ifFalse: [FormInspectView].
	widgetClass openOn:  imports withLabel: 'Graphical Imports'

! !


!Imports methodsFor: 'initialize' stamp: 'sd 5/11/2003 18:17'!
initialize

	imports := Dictionary new.! !

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

Imports class
	instanceVariableNames: 'default'!

!Imports class methodsFor: 'instance creation' stamp: 'nk 7/12/2003 10:38'!
default
	"Answer my default instance, creating one if necessary."
	"Imports default"
	^default ifNil: [ default _ self new ]! !

!Imports class methodsFor: 'instance creation' stamp: 'nk 7/12/2003 10:36'!
default: anImports
	"Set my default instance. Returns the old value if any."
	| old |
	old _ default.
	default _ anImports.
	^old! !
Notification subclass: #InMidstOfFileinNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!InMidstOfFileinNotification methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 17:07'!
defaultAction

	self resume: false! !
StringMorph subclass: #IndentingListItemMorph
	instanceVariableNames: 'indentLevel isExpanded complexContents firstChild container nextSibling icon'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!IndentingListItemMorph commentStamp: '<historical>' prior: 0!
An IndentingListItemMorph is a StringMorph that draws itself with an optional toggle at its left, as part of the display of the SimpleHierarchicalListMorph.

It will also display lines around the toggle if the #showLinesInHierarchyViews Preference is set.

Instance variables:

indentLevel <SmallInteger> 	the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy.

isExpanded <Boolean>		true if this item is expanded (showing its children)

complexContents <ListItemWrapper>	an adapter wrapping my represented item that can answer its children, etc.
	
firstChild <IndentingListItemMorph|nil>	my first child, or nil if none
	
container <SimpleHierarchicalListMorph>	my container
	
nextSibling <IndentingListItemMorph|nil>	the next item in the linked list of siblings, or nil if none.

Contributed by Bob Arning as part of the ObjectExplorer package.
Don't blame him if it's not perfect.  We wanted to get it out for people to play with.!


!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/21/2000 11:00'!
balloonText

	^complexContents balloonText ifNil: [super balloonText]! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 3/31/1999 17:44'!
canExpand

	^complexContents hasContents! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 15:30'!
children
	| children |
	children _ OrderedCollection new.
	self childrenDo: [:each | children add: each].
	^children! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 8/2/1999 16:48'!
firstChild

	^firstChild! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'dgd 9/25/2004 22:25'!
hasIcon
	"Answer whether the receiver has an icon."
	^ icon notNil! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'dgd 9/25/2004 22:27'!
icon
	"answer the receiver's icon"
	^ icon! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/30/2000 19:15'!
indentLevel

	^indentLevel! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/31/1998 00:30'!
isExpanded

	^isExpanded! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/31/1998 00:48'!
isExpanded: aBoolean

	isExpanded _ aBoolean! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'nk 3/8/2004 09:14'!
isFirstItem
	^owner submorphs first == self! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'nk 3/8/2004 09:15'!
isSoleItem
	^self isFirstItem and: [ owner submorphs size = 1 ]! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/11/1998 12:15'!
nextSibling

	^nextSibling! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 8/1/1998 01:05'!
nextSibling: anotherMorph

	nextSibling _ anotherMorph! !

!IndentingListItemMorph methodsFor: 'accessing' stamp: 'bf 2/9/2004 10:55'!
userString
	"Add leading tabs to my userString"
	^ (String new: indentLevel withAll: Character tab), super userString
! !


!IndentingListItemMorph methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'!
withoutListWrapper

	^complexContents withoutListWrapper! !


!IndentingListItemMorph methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 16:49'!
acceptDroppingMorph: toDrop event: evt
	complexContents acceptDroppingObject: toDrop complexContents.
	toDrop delete.
	self highlightForDrop: false.! !


!IndentingListItemMorph methodsFor: 'drawing' stamp: 'dgd 9/25/2004 22:47'!
drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle
	"If I am not the only item in my container, draw the line between:
		- my toggle (if any) or my left edge (if no toggle)
		- and my text left edge"

	| myBounds myCenter hLineY hLineLeft |
	self isSoleItem ifTrue: [ ^self ].
	myBounds := self toggleBounds.
	myCenter := myBounds center.
	hLineY := myCenter y.
	hLineLeft := myCenter x - 1.
	"Draw line from toggle to text"
	aCanvas
		line: hLineLeft @ hLineY
		to: myBounds right + 0 @ hLineY
		width: 1
		color: lineColor! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:43'!
drawLinesOn: aCanvas lineColor: lineColor 
	| hasToggle |
	hasToggle _ self hasToggle.
	"Draw line from toggle to text"
	self drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle.

	"Draw the line from my toggle to the nextSibling's toggle"
	self nextSibling ifNotNil: [ self drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle ].

	"If I have children and am expanded, draw a line to my first child"
	(self firstChild notNil and: [ self isExpanded ])
		ifTrue: [ self drawLinesToFirstChildOn: aCanvas lineColor: lineColor]! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:44'!
drawLinesToFirstChildOn: aCanvas lineColor: lineColor 
	"Draw line from me to next sibling"

	| vLineX vLineTop vLineBottom childBounds childCenter |
	childBounds := self firstChild toggleBounds.
	childCenter := childBounds center.
	vLineX := childCenter x - 1.
	vLineTop := bounds bottom.
	self firstChild hasToggle
		ifTrue: [vLineBottom := childCenter y - 7]
		ifFalse: [vLineBottom := childCenter y].
	aCanvas
		line: vLineX @ vLineTop
		to: vLineX @ vLineBottom
		width: 1
		color: lineColor! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'dgd 9/25/2004 22:46'!
drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle
	| myBounds nextSibBounds vLineX myCenter vLineTop vLineBottom |
	myBounds := self toggleBounds.
	nextSibBounds := self nextSibling toggleBounds.
	myCenter := myBounds center.
	vLineX := myCenter x - 1.
	vLineTop := myCenter y.
	vLineBottom := nextSibBounds center y.
	"Draw line from me to next sibling"
	aCanvas
		line: vLineX @ vLineTop
		to: vLineX @ vLineBottom
		width: 1
		color: lineColor! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'dgd 9/25/2004 22:36'!
drawOn: aCanvas

	| tRect sRect columnRect columnScanner columnData columnLeft colorToUse |

	tRect := self toggleRectangle.
	sRect := bounds withLeft: tRect right + 4.
	self drawToggleOn: aCanvas in: tRect.
	colorToUse _ complexContents preferredColor ifNil: [color].

	icon isNil ifFalse:[
		aCanvas
			translucentImage: icon
			at: sRect left @ (self top + (self height - icon height // 2)).

		sRect := sRect left: sRect left + icon width + 2.
	].

	(container columns isNil or: [(contents asString indexOf: Character tab) = 0]) ifTrue: [
		sRect := sRect top: sRect top + sRect bottom - self fontToUse height // 2.
		aCanvas drawString: contents asString in: sRect font: self fontToUse color: colorToUse.
	] ifFalse: [
		columnLeft _ sRect left.
		columnScanner _ ReadStream on: contents asString.
		container columns do: [ :width |
			columnRect _ columnLeft @ sRect top extent: width @ sRect height.
			columnData _ columnScanner upTo: Character tab.
			columnData isEmpty ifFalse: [
				aCanvas drawString: columnData in: columnRect font: self fontToUse color: colorToUse.
			].
			columnLeft _ columnRect right + 5.
		].
	]
! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 2/19/2004 18:19'!
drawToggleOn: aCanvas in: aRectangle

	| aForm centeringOffset |
	complexContents hasContents ifFalse: [^self].
	aForm _ isExpanded 
		ifTrue: [container expandedForm]
		ifFalse: [container notExpandedForm].
	centeringOffset _ ((aRectangle height - aForm extent y) / 2.0) rounded.
	^aCanvas 
		paintImage: aForm 
		at: (aRectangle topLeft translateBy: 0 @ centeringOffset).
! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:46'!
unhighlight

	complexContents highlightingColor ifNotNil: [self color: Color black].
	self changed.
	
	
! !


!IndentingListItemMorph methodsFor: 'enumeration' stamp: 'panda 4/28/2000 15:29'!
childrenDo: aBlock

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aBlock value: aNode].
	]! !


!IndentingListItemMorph methodsFor: 'halos and balloon help' stamp: 'RAA 7/21/2000 11:13'!
boundsForBalloon

	"some morphs have bounds that are way too big"
	container ifNil: [^super boundsForBalloon].
	^self boundsInWorld intersect: container boundsInWorld! !


!IndentingListItemMorph methodsFor: 'initialization' stamp: 'dgd 9/25/2004 22:33'!
initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel

	container _ hostList.
	complexContents _ anObject.
	self initWithContents: anObject asString font: Preferences standardListFont emphasis: nil.
	indentLevel _ 0.
	isExpanded _ false.
 	nextSibling _ firstChild _ nil.
	priorMorph ifNotNil: [
		priorMorph nextSibling: self.
	].
	indentLevel _ newLevel.
	icon := anObject icon.
	self extent: self minWidth @ self minHeight! !

!IndentingListItemMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	indentLevel _ 0.
	isExpanded _ false! !


!IndentingListItemMorph methodsFor: 'mouse events' stamp: 'ar 3/17/2001 17:32'!
inToggleArea: aPoint

	^self toggleRectangle containsPoint: aPoint! !


!IndentingListItemMorph methodsFor: 'private' stamp: 'nk 2/19/2004 18:29'!
hasToggle
	^ complexContents hasContents! !

!IndentingListItemMorph methodsFor: 'private' stamp: 'nk 12/5/2002 15:16'!
toggleBounds
	^self toggleRectangle! !

!IndentingListItemMorph methodsFor: 'private' stamp: 'RAA 7/29/2000 22:06'!
toggleRectangle

	| h |
	h _ bounds height.
	^(bounds left + (12 * indentLevel)) @ bounds top extent: 12@h! !

!IndentingListItemMorph methodsFor: 'private' stamp: 'RAA 7/11/1998 14:25'!
withSiblingsDo: aBlock

	| node |
	node _ self.
	[node isNil] whileFalse: [
		aBlock value: node.
		node _ node nextSibling
	].! !


!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 7/30/2000 19:49'!
addChildrenForList: hostList addingTo: morphList withExpandedItems: expandedItems

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode delete].
	].
	firstChild _ nil.
	complexContents hasContents ifFalse: [^self].
	firstChild _ hostList 
		addMorphsTo: morphList
		from: complexContents contents 
		allowSorting: true
		withExpandedItems: expandedItems
		atLevel: indentLevel + 1.
	! !

!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 7/11/1998 14:34'!
complexContents

	^complexContents! !

!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 8/3/1999 09:47'!
highlight

	complexContents highlightingColor ifNotNil: [self color: complexContents highlightingColor].
	self changed.
	
! !

!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'nk 10/14/2003 10:36'!
openPath: anArray 
	| found |
	anArray isEmpty
		ifTrue: [^ container setSelectedMorph: nil].
	found _ nil.
	self
		withSiblingsDo: [:each | found
				ifNil: [(each complexContents asString = anArray first
							or: [anArray first isNil])
						ifTrue: [found _ each]]].
	found
		ifNil: ["try again with no case sensitivity"
			self
				withSiblingsDo: [:each | found
						ifNil: [(each complexContents asString sameAs: anArray first)
								ifTrue: [found _ each]]]].
	found
		ifNotNil: [found isExpanded
				ifFalse: [found toggleExpandedState.
					container adjustSubmorphPositions].
			found changed.
			anArray size = 1
				ifTrue: [^ container setSelectedMorph: found].
			^ found firstChild
				ifNil: [container setSelectedMorph: nil]
				ifNotNil: [found firstChild openPath: anArray allButFirst]].
	^ container setSelectedMorph: nil! !

!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 6/21/1999 14:54'!
recursiveAddTo: aCollection

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection].
	].
	aCollection add: self
	! !

!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 4/2/1999 18:02'!
recursiveDelete

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete].
	].
	self delete
	! !

!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 7/30/2000 19:17'!
toggleExpandedState

 	| newChildren toDelete c |

	isExpanded _ isExpanded not.
	toDelete _ OrderedCollection new.
	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: toDelete].
	].
	container noteRemovalOfAll: toDelete.
	(isExpanded and: [complexContents hasContents]) ifFalse: [
		^self changed
	].
	(c _ complexContents contents) isEmpty ifTrue: [^self changed].
	newChildren _ container 
		addSubmorphsAfter: self 
		fromCollection: c 
		allowSorting: true.
	firstChild _ newChildren first.
! !


!IndentingListItemMorph methodsFor: 'layout' stamp: 'dgd 9/25/2004 22:26'!
minHeight
	| iconHeight |
	iconHeight := self hasIcon
				ifTrue: [self icon height + 2]
				ifFalse: [0].
	^ self fontToUse height max: iconHeight ! !

!IndentingListItemMorph methodsFor: 'layout' stamp: 'dgd 9/25/2004 22:26'!
minWidth
	| iconWidth |
	iconWidth := self hasIcon
				ifTrue: [self icon width + 2]
				ifFalse: [0].
	^ (self fontToUse widthOfString: contents)
		+ iconWidth ! !
IndentingListItemMorph subclass: #IndentingListParagraphMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Outliner'!

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:10'!
desiredHeight

	submorphs isEmpty ifTrue: [^self height].
	"isExpanded ifFalse: [^self height]."
	^complexContents withoutListWrapper height "max: self height"
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 14:47'!
isExpanded: aBoolean

	| tm |
	super isExpanded: aBoolean.
	tm _ self repositionText.
	isExpanded ifFalse: [
		self height: tm height.
	].
	self addMorph: tm.
	"tm clipToOwner: isExpanded not."		"not really working right yet"

! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:06'!
position: p andWidth: w

	| widthChanged |

	widthChanged _ self width ~= w.
	self position: p.
	self width: w.
	submorphs isEmpty ifTrue: [^self height].
	widthChanged ifTrue: [
		self repositionText.
	].
	self height: self desiredHeight.
	^self desiredHeight
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:19'!
repositionText

	| sRect tm |
	sRect _ self textMorphBounds.
	(tm _ complexContents withoutListWrapper)
		"clipToOwner: isExpanded not;"
		position: sRect origin;
		width: sRect width.
	isExpanded ifTrue: [
		tm extent: sRect width@10.
		tm contents: tm contents wrappedTo: sRect width.
		tm extent: sRect width@10.
	] ifFalse: [
		tm contentsAsIs: tm contents.
		tm extent: tm extent.		"force bounds recompute"
	].
	tm lock: isExpanded not.
"{tm. tm bounds. sRect} explore."
	^tm
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 10:21'!
takeFocus

	container setSelectedMorph: self! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 15:36'!
textMorphBounds

	^(bounds withRight: self right - 4)
		 withLeft: self textMorphLeft.
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 14:45'!
textMorphLeft
	
	^self toggleRectangle right + 3
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 12:29'!
toggleExpandedState

	super toggleExpandedState.
	self isExpanded: isExpanded.
! !


!IndentingListParagraphMorph methodsFor: 'drawing' stamp: 'RAA 7/30/2000 12:53'!
drawOn: aCanvas

	self drawToggleOn: aCanvas in: self toggleRectangle.
! !

!IndentingListParagraphMorph methodsFor: 'drawing' stamp: 'RAA 1/26/2001 10:26'!
drawToggleOn: aCanvas in: aRectangle

	| aForm |

	aCanvas 
		fillRectangle: (bounds withRight: aRectangle right)
		color: container color.
	complexContents hasContents ifFalse: [^self].
	aForm _ isExpanded 
		ifTrue: [container expandedForm]
		ifFalse: [container notExpandedForm].
	^aCanvas 
		paintImage: aForm 
		at: aRectangle topLeft
! !


!IndentingListParagraphMorph methodsFor: 'event handling' stamp: 'RAA 7/31/2000 10:04'!
keyStroke: evt

	| char |
	char _ evt keyCharacter.
	evt controlKeyPressed ifTrue: [
		char = Character cr ifTrue: [
			container model addSibling.
			^true	"we did handle it"
		].
		char = Character tab ifTrue: [
			container model addNewChildAfter: 0.
			^true	"we did handle it"
		].
	].
	^false	"we did not handle it"
! !


!IndentingListParagraphMorph methodsFor: 'initialization' stamp: 'RAA 7/31/2000 09:52'!
initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel

	super initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel.
	self width: hostList width.
	complexContents withoutListWrapper firstDisplay ifTrue: [
		complexContents withoutListWrapper firstDisplayedOnLevel: indentLevel.
		isExpanded _ true.
	].
	complexContents withoutListWrapper showInOpenedState ifTrue: [
		isExpanded _ true.
	].
	self addMorph: self repositionText.

! !


!IndentingListParagraphMorph methodsFor: 'layout' stamp: 'RAA 7/30/2000 12:54'!
layoutChanged

	super layoutChanged.
	submorphs isEmpty ifTrue: [^self].
	self desiredHeight = self height ifTrue: [^self].
	self height: self desiredHeight.
	container adjustSubmorphPositions.
! !

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

IndentingListParagraphMorph class
	instanceVariableNames: ''!

!IndentingListParagraphMorph class methodsFor: 'new-morph participation' stamp: 'RAA 8/8/2000 14:36'!
includeInNewMorphMenu

	^ false! !
PasteUpMorph subclass: #IndexTabs
	instanceVariableNames: 'highlightColor regularColor basicHeight basicWidth verticalPadding fixedWidth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Palettes'!
!IndexTabs commentStamp: '<historical>' prior: 0!
Used in conjunction wi[th a TabbedPalette -- each TabbedPalette has one.  Each submorph of an IndexTabs is a TabMorph.  When you click on one of the tabs, a corresponding action is taken -- sometimes, the existing palette gets replaced by the new one, other times, the tab results in some selector being invoked; in any case, tab highlighting takes place accordingly.!


!IndexTabs methodsFor: 'accessing' stamp: 'sw 7/2/1998 14:56'!
highlightColor
	^ highlightColor ifNil: [Color yellow]! !

!IndexTabs methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:29'!
highlightColor: aColor
	highlightColor _ aColor! !

!IndexTabs methodsFor: 'accessing' stamp: 'sw 7/2/1998 14:47'!
regularColor
	^ regularColor ifNil: [Color r: 0.4 g: 0.2 b: 0.6]! !

!IndexTabs methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:29'!
regularColor: aColor
	regularColor _ aColor! !


!IndexTabs methodsFor: 'change reporting' stamp: 'sw 1/13/2000 15:19'!
ownerChanged
	fixedWidth ifNil: [self laySubpartsOutInOneRow]! !


!IndexTabs methodsFor: 'dropping/grabbing' stamp: 'sw 4/27/2000 13:30'!
repelsMorph: aMorph event: evt
	^ false! !


!IndexTabs methodsFor: 'highlighting' stamp: 'sw 7/2/1998 13:43'!
highlightColor: color1 regularColor: color2
	"Apply these colors to all of the receiver's tabs"
	highlightColor _ color1.
	regularColor _ color2.
	self tabMorphs do:
		[:m | m highlightColor: color1.  m regularColor: color2]! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 11/30/1998 12:43'!
highlightTab: aTab
	self tabMorphs do:
		[:m | m == aTab
			ifTrue: [m highlight]
			ifFalse: [m unHighlight]]! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 11/30/1998 12:44'!
highlightTabFor: aBook
	| theOne |
	self tabMorphs do: [:m |
		(m morphToInstall == aBook)
				ifTrue: [m highlight.  theOne _ m]
				ifFalse: [m unHighlight]].
	^ theOne
! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 12/2/1998 12:30'!
highlightedTab
	^ self tabMorphs detect: [:m | m isHighlighted] ifNone: [nil]! !


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

!IndexTabs methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.0
		g: 0.6
		b: 0.6! !

!IndexTabs methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:43'!
initialize
	"Initialize the receiver. Make sure it is not open to drag and  
	drop"
	super initialize.
	""
	padding _ 10.
	verticalPadding _ 4.
	basicHeight _ 14.
	basicWidth _ 200.
	
	self enableDragNDrop: false! !


!IndexTabs methodsFor: 'layout' stamp: 'sw 7/3/1998 18:37'!
basicHeight
	^ basicHeight! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 11/30/1998 15:38'!
basicWidth
	basicWidth ifNil: [basicWidth _ owner ifNotNil: [owner width] ifNil: [100]].
	^ basicWidth! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 1/13/2000 15:18'!
fixedWidth: aWidth
	fixedWidth _ aWidth! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 1/19/2000 13:57'!
laySubpartsOutInOneRow
	| aPosition neededHeight widthToUse mid |
	fixedWidth ifNotNil: [self error: 'incompatibility in IndexTabs'].
	verticalPadding ifNil: [verticalPadding _ 4].  "for benefit of old structures"
	aPosition _ self topLeft.
	neededHeight _ self basicHeight.
	submorphs do:
		[:aMorph |
			aMorph position: (aPosition + (padding @ 0)).
			aPosition _ aMorph topRight.
			neededHeight _ neededHeight max: aMorph height].
	neededHeight _ neededHeight + (verticalPadding * 2).
	mid _ self top + (neededHeight // 2).
	submorphs do:
		[:aMorph |
			aMorph top: (mid - (aMorph height // 2))].
	widthToUse _ self widthImposedByOwner max: self requiredWidth.
	self extent: (((aPosition x + padding - self left) max: widthToUse) @ neededHeight)! !

!IndexTabs methodsFor: 'layout' stamp: 'dgd 2/22/2003 13:25'!
requiredWidth
	submorphs isEmpty ifTrue: [^self basicWidth].
	^(submorphs detectSum: [:m | m width]) + (submorphs size * padding)! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 1/13/2000 15:50'!
rowsNoWiderThan: maxWidth
	| aPosition neededHeight |
	self fixedWidth: maxWidth.
	verticalPadding ifNil: [verticalPadding _ 4].  "for benefit of old structures"
	aPosition _ self topLeft.
	neededHeight _ self basicHeight.
	submorphs do:
		[:aMorph |
			aMorph position: (aPosition + (padding @ 0)).
			(aMorph right > (self left + maxWidth)) ifTrue:
				[aPosition _ self left @ (aPosition y + neededHeight).
				aMorph position: aPosition + (padding @ 0).
				neededHeight _ self basicHeight].
			aPosition _ aMorph topRight.
			neededHeight _ neededHeight max: aMorph height].
	self extent: (maxWidth @ ((aPosition y + neededHeight) - self top))! !

!IndexTabs methodsFor: 'layout' stamp: 'dgd 2/22/2003 13:25'!
widthImposedByOwner
	((owner isNil or: [owner isWorldOrHandMorph]) 
		or: [owner submorphs size < 2]) ifTrue: [^self basicWidth].
	^owner submorphs second width! !


!IndexTabs methodsFor: 'selection' stamp: 'sw 7/3/1998 18:43'!
selectTab: aTab
	| aWorld |
	(aWorld _ self world) ifNotNil: [aWorld abandonAllHalos].  "nil can happen at init time"
	self highlightTab: aTab.
! !


!IndexTabs methodsFor: 'tabs' stamp: 'sw 7/3/1998 11:44'!
addTab: aTab
	self addMorphBack: aTab.
	self laySubpartsOutInOneRow! !

!IndexTabs methodsFor: 'tabs' stamp: 'sw 1/11/2000 11:15'!
addTabFor: aReferent font: aFont
	|  aTab |
	aTab _ ReferenceMorph forMorph: aReferent font: aFont.
	self addMorphBack: aTab.
	aTab highlightColor: self highlightColor; regularColor: self regularColor.
	aTab unHighlight.
	self laySubpartsOutInOneRow; layoutChanged.
	^ aTab! !

!IndexTabs methodsFor: 'tabs' stamp: 'sw 12/2/1998 17:53'!
addTabForBook: aBook
	|  aTab |
	aTab _ ReferenceMorph forMorph: aBook.
	self addMorphBack: aTab.
	aTab highlightColor: self highlightColor; regularColor: self regularColor.
	aTab unHighlight.
	self laySubpartsOutInOneRow; layoutChanged.
	^ aTab! !

!IndexTabs methodsFor: 'tabs' stamp: 'sw 1/11/2000 10:17'!
tabMorphs
	"Presently all the submorphs are ReferenceMorphs, but this still supports an earlier design where spacers are interleaved, and where the old TabMorph class was used"

	^ submorphs select: [:m | (m isKindOf: TabMorph) or: [m isKindOf: ReferenceMorph]]! !

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

IndexTabs class
	instanceVariableNames: ''!

!IndexTabs class methodsFor: 'printing' stamp: 'sw 7/2/1998 15:16'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ 'tabs'! !
DisplayObject subclass: #InfiniteForm
	instanceVariableNames: 'patternForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!InfiniteForm commentStamp: '<historical>' prior: 0!
I represent a Form obtained by replicating a pattern form indefinitely in all directions.!


!InfiniteForm methodsFor: 'accessing' stamp: 'mjg 7/9/2001 14:12'!
asColor
	^ patternForm dominantColor! !

!InfiniteForm methodsFor: 'accessing'!
asForm
	^ patternForm! !

!InfiniteForm methodsFor: 'accessing' stamp: 'di 9/2/97 20:21'!
dominantColor
	^ patternForm dominantColor! !

!InfiniteForm methodsFor: 'accessing'!
offset 
	"Refer to the comment in DisplayObject|offset."

	^0 @ 0! !


!InfiniteForm methodsFor: 'as yet unclassified' stamp: 'RAA 6/1/2000 10:50'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"

	"prevents a walkback when control menu is built for morph with me as color"! !


!InfiniteForm methodsFor: 'display box access'!
computeBoundingBox 
	"Refer to the comment in DisplayObject|computeBoundingBox."

	^0 @ 0 corner: SmallInteger maxVal @ SmallInteger maxVal! !


!InfiniteForm methodsFor: 'displaying' stamp: 'sw 2/16/98 03:42'!
colorForInsets
	^ Color transparent! !

!InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"This is the real display message, but it doesn't get used until the new
	display protocol is installed."
	| targetBox patternBox bb |
	(patternForm isForm) ifFalse:
		[^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm].

	"Do it iteratively"
	targetBox _ aDisplayMedium boundingBox intersect: clipRectangle.
	patternBox _ patternForm boundingBox.
	bb _ BitBlt current destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm
		combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0
		extent: patternBox extent clipRect: clipRectangle.
	bb colorMap:
		(patternForm colormapIfNeededFor: aDisplayMedium).
	(targetBox left truncateTo: patternBox width)
		to: targetBox right - 1 by: patternBox width do:
		[:x |
		(targetBox top truncateTo: patternBox height)
			to: targetBox bottom - 1 by: patternBox height do:
			[:y |
			bb destOrigin: x@y; copyBits]]! !

!InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'!
displayOnPort: aPort at: offset

	| targetBox patternBox savedMap top left |

	self flag: #bob.

	"this *may* not get called at the moment. I have been trying to figure out the right way for this to work and am using #displayOnPort:offsetBy: as my current offering - Bob"

	(patternForm isForm) ifFalse: [
		"patternForm is a Pattern or Color; just use it as a mask for BitBlt"
		^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over].

	"do it iteratively"
	targetBox _ aPort clipRect.
	patternBox _ patternForm boundingBox.
	savedMap _ aPort colorMap.
	aPort sourceForm: patternForm;
		fillColor: nil;
		combinationRule: Form paint;
		sourceRect: (0@0 extent: patternBox extent);
		colorMap: (patternForm colormapIfNeededFor: aPort destForm).
	top _ (targetBox top truncateTo: patternBox height) "- (offset y \\ patternBox height)".
	left _  (targetBox left truncateTo: patternBox width) "- (offset x \\ patternBox width)".
	left to: (targetBox right - 1) by: patternBox width do:
		[:x | top to: (targetBox bottom - 1) by: patternBox height do:
			[:y | aPort destOrigin: x@y; copyBits]].
	aPort colorMap: savedMap.
! !

!InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'!
displayOnPort: aPort offsetBy: offset

	| targetBox patternBox savedMap top left |

	"this version tries to get the form aligned where the user wants it and not just aligned with the cliprect"

	(patternForm isForm) ifFalse: [
		"patternForm is a Pattern or Color; just use it as a mask for BitBlt"
		^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over].

	"do it iteratively"
	targetBox _ aPort clipRect.
	patternBox _ patternForm boundingBox.
	savedMap _ aPort colorMap.
	aPort sourceForm: patternForm;
		fillColor: nil;
		combinationRule: Form paint;
		sourceRect: (0@0 extent: patternBox extent);
		colorMap: (patternForm colormapIfNeededFor: aPort destForm).
	top _ (targetBox top truncateTo: patternBox height) + offset y.
	left _  (targetBox left truncateTo: patternBox width) + offset x.

	left to: (targetBox right - 1) by: patternBox width do:
		[:x | top to: (targetBox bottom - 1) by: patternBox height do:
			[:y | aPort destOrigin: x@y; copyBits]].
	aPort colorMap: savedMap.
! !

!InfiniteForm methodsFor: 'displaying' stamp: 'ar 8/16/2001 12:47'!
raisedColor
	^ Color transparent! !


!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'bolot 9/15/1999 10:13'!
bitPatternForDepth: suspectedDepth
	^ patternForm! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'!
direction
	^patternForm width @ 0! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'!
form
	"Bitmap fills respond to #form"
	^patternForm! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'!
isBitmapFill
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'!
isGradientFill
	^false! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:59'!
isOrientedFill
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'!
isSolidFill
	^false! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:55'!
isTiled
	"Return true if the receiver should be drawn as a tiled pattern"
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 9/2/1999 14:32'!
isTranslucent
	"Return true since the bitmap may be translucent and we don't really want to check"
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:57'!
normal
	^0 @ patternForm height! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'!
origin
	^0@0! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'!
origin: aPoint
	"Ignored"
! !


!InfiniteForm methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'RAA 8/28/2000 10:27'!
encodeForRemoteCanvas

	^patternForm encodeForRemoteCanvas
! !


!InfiniteForm methodsFor: 'private'!
form: aForm

	patternForm _ aForm! !

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

InfiniteForm class
	instanceVariableNames: ''!

!InfiniteForm class methodsFor: 'instance creation'!
with: aForm 
	"Answer an instance of me whose pattern form is the argument, aForm."

	^self new form: aForm! !
ReadStream subclass: #InflateStream
	instanceVariableNames: 'state bitBuf bitPos source sourcePos sourceLimit litTable distTable sourceStream crc'
	classVariableNames: 'BlockProceedBit BlockTypes FixedDistCodes FixedLitCodes MaxBits StateNewBlock StateNoMoreData'
	poolDictionaries: ''
	category: 'Compression-Streams'!
!InflateStream commentStamp: '<historical>' prior: 0!
This class implements the Inflate decompression algorithm as defined by RFC1951 and used in PKZip, GZip and ZLib (and many, many more). It is a variant of the LZ77 compression algorithm described in

[LZ77] Ziv J., Lempel A., "A Universal Algorithm for Sequential Data Compression", IEEE Transactions on Information Theory", Vol. 23, No. 3, pp. 337-343.

[RFC1951] Deutsch. P, "DEFLATE Compressed Data Format Specification version 1.3"

For more information see the above mentioned RFC 1951 which can for instance be found at

	http://www.leo.org/pub/comp/doc/standards/rfc/index.html

Huffman Tree Implementation Notes:
===========================================
The huffman tree used for decoding literal, distance and length codes in the inflate algorithm has been encoded in a single Array. The tree is made up of subsequent tables storing all entries at the current bit depth. Each entry in the table (e.g., a 32bit Integer value) is either a leaf or a non-leaf node. Leaf nodes store the immediate value in its low 16 bits whereas non-leaf nodes store the offset of the subtable in its low 16bits. The high 8 bits of non-leaf nodes contain the number of additional bits needed for the sub table (the high 8 bits of leaf-nodes are always zero). The first entry in each table is always a non-leaf node indicating how many bits we need to fetch initially. We can thus travel down the tree as follows (written in sort-of-pseudocode the actual implementation can be seen in InflateStream>>decodeValueFrom:):

	table _ initialTable.
	bitsNeeded _ high 8 bits of (table at: 1).		"Determine initial bits"
	table _ initialTable + (low 16 bits of (table at: 1)). "Determine start of first real table"
	[bits _ fetch next bitsNeeded bits.			"Grab the bits"
	value _ table at: bits.						"Lookup the value"
	value has high 8 bit set] whileTrue:[		"Check if it's leaf"
		table _ initialTable + (low 16 bits of value).	"No - compute new sub table start"
		bitsNeeded _ high 8 bit of value].		"Compute additional number of bits needed"
	^value
!


!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'!
close
	sourceStream ifNotNil:[sourceStream close].! !

!InflateStream methodsFor: 'accessing' stamp: 'tk 2/4/2000 10:26'!
contents

	^ self upToEnd! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 01:29'!
next
	"Answer the next decompressed object in the Stream represented by the
	receiver."

	<primitive: 65>
	position >= readLimit
		ifTrue: [^self pastEndRead]
		ifFalse: [^collection at: (position := position + 1)]! !

!InflateStream methodsFor: 'accessing' stamp: 'nk 3/7/2004 18:45'!
next: anInteger 
	"Answer the next anInteger elements of my collection.  overriden for simplicity"
	| newArray |

	"try to do it the fast way"
	position + anInteger < readLimit ifTrue: [
		newArray := collection copyFrom: position + 1 to: position + anInteger.
		position := position + anInteger.
		^newArray
	].

	"oh, well..."
	newArray := collection species new: anInteger.
	1 to: anInteger do: [:index | newArray at: index put: (self next ifNil: [ ^newArray copyFrom: 1 to: index - 1]) ].
	^newArray! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 16:06'!
next: n into: buffer startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than
	n elements have been read."
	| c numRead count |
	numRead := 0.
	["Force decompression if necessary"
	(c := self next) == nil 
		ifTrue:[^buffer copyFrom: 1 to: startIndex+numRead-1].
	"Store the first value which provoked decompression"
	buffer at: startIndex + numRead put: c.
	numRead := numRead + 1.
	"After collection has been filled copy as many objects as possible"
	count := (readLimit - position) min: (n - numRead).
	buffer 
		replaceFrom: startIndex + numRead 
		to: startIndex + numRead + count - 1 
		with: collection 
		startingAt: position+1.
	position := position + count.
	numRead := numRead + count.
	numRead = n] whileFalse.
	^buffer! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'!
size
	"This is a compressed stream - we don't know the size beforehand"
	^self shouldNotImplement! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:54'!
sourceLimit
	^sourceLimit! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:52'!
sourcePosition
	^sourcePos! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'!
sourceStream
	^sourceStream! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'!
upTo: anObject 
	"Answer a subcollection from the current access position to the 
	occurrence (if any, but not inclusive) of anObject in the receiver. If 
	anObject is not in the collection, answer the entire rest of the receiver."
	| newStream element |
	newStream := WriteStream on: (collection species new: 100).
	[self atEnd or: [(element := self next) = anObject]]
		whileFalse: [newStream nextPut: element].
	^newStream contents! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 02:04'!
upToEnd
	"Answer a subcollection from the current access position through the last element of the receiver."

	| newStream buffer |
	buffer := collection species new: 1000.
	newStream := WriteStream on: (collection species new: 100).
	[self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)].
	^ newStream contents! !


!InflateStream methodsFor: 'bit access' stamp: 'ar 12/27/1999 13:47'!
bitPosition
	"Return the current bit position of the source"
	sourceStream == nil
		ifTrue:[^sourcePos * 8 + bitPos]
		ifFalse:[^sourceStream position + sourcePos * 8 + bitPos]! !

!InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:00'!
nextBits: n
	| bits |
	[bitPos < n] whileTrue:[
		bitBuf := bitBuf + (self nextByte bitShift: bitPos).
		bitPos := bitPos + 8].
	bits := bitBuf bitAnd: (1 bitShift: n)-1.
	bitBuf := bitBuf bitShift: 0 - n.
	bitPos := bitPos - n.
	^bits! !

!InflateStream methodsFor: 'bit access' stamp: 'ar 12/5/1998 14:54'!
nextByte
	^source byteAt: (sourcePos := sourcePos + 1)! !

!InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:01'!
nextSingleBits: n
	| out |
	out := 0.
	1 to: n do:[:i| out := (out bitShift: 1) + (self nextBits: 1)].
	^out! !


!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:04'!
crcError: aString
	^CRCError signal: aString! !

!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:49'!
updateCrc: oldCrc from: start to: stop in: aCollection
	"Answer an updated CRC for the range of bytes in aCollection.
	Subclasses can implement the appropriate means for the check sum they wish to use."
	^oldCrc! !

!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:22'!
verifyCrc
	"Verify the crc checksum in the input"! !


!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/21/1999 22:59'!
computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits
	"Assign numerical values to all codes.
	Note: The values are stored according to the bit length"
	| offsets values baseOffset codeLength |
	offsets := Array new: maxBits.
	offsets atAllPut: 0.
	baseOffset := 1.
	minBits to: maxBits do:[:bits|
		offsets at: bits put: baseOffset.
		baseOffset := baseOffset + (counts at: bits+1)].
	values := WordArray new: aCollection size.
	1 to: aCollection size do:[:i|
		codeLength := aCollection at: i.
		codeLength > 0 ifTrue:[
			baseOffset := offsets at: codeLength.
			values at: baseOffset put: i-1.
			offsets at: codeLength put: baseOffset + 1]].
	^values! !

!InflateStream methodsFor: 'huffman trees' stamp: 'sma 5/12/2000 10:49'!
createHuffmanTables: values counts: counts from: minBits to: maxBits
	"Create the actual tables"
	| table tableStart tableSize tableEnd 
	valueIndex tableStack numValues deltaBits maxEntries
	lastTable lastTableStart tableIndex lastTableIndex |

	table := WordArray new: ((4 bitShift: minBits) max: 16).

	"Create the first entry - this is a dummy.
	It gives us information about how many bits to fetch initially."
	table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2"

	"Create the first table from scratch."
	tableStart := 2. "See above"
	tableSize := 1 bitShift: minBits.
	tableEnd := tableStart + tableSize.
	"Store the terminal symbols"
	valueIndex := (counts at: minBits+1).
	tableIndex := 0.
	1 to: valueIndex do:[:i|
		table at: tableStart + tableIndex put: (values at: i).
		tableIndex := self increment: tableIndex bits: minBits].
	"Fill up remaining entries with invalid entries"
	tableStack := OrderedCollection new: 10. "Should be more than enough"
	tableStack addLast: 
		(Array 
			with: minBits	"Number of bits (e.g., depth) for this table"
			with: tableStart	"Start of table"
			with: tableIndex "Next index in table"
			with: minBits	"Number of delta bits encoded in table"
			with: tableSize - valueIndex "Entries remaining in table").
	"Go to next value index"
	valueIndex := valueIndex + 1.
	"Walk over remaining bit lengths and create new subtables"
	minBits+1 to: maxBits do:[:bits|
		numValues := counts at: bits+1.
		[numValues > 0] whileTrue:["Create a new subtable"
			lastTable := tableStack last.
			lastTableStart := lastTable at: 2.
			lastTableIndex := lastTable at: 3.
			deltaBits := bits - (lastTable at: 1).
			"Make up a table of deltaBits size"
			tableSize := 1 bitShift: deltaBits.
			tableStart := tableEnd.
			tableEnd := tableEnd + tableSize.
			[tableEnd > table size ]
				whileTrue:[table := self growHuffmanTable: table].
			"Connect to last table"
			self assert:[(table at: lastTableStart + lastTableIndex) = 0]."Entry must be unused"
			table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart.
			lastTable at: 3 put: (self increment: lastTableIndex bits: (lastTable at: 4)).
			lastTable at: 5 put: (lastTable at: 5) - 1.
			self assert:[(lastTable at: 5) >= 0]. "Don't exceed tableSize"
			"Store terminal values"
			maxEntries := numValues min: tableSize.
			tableIndex := 0.
			1 to: maxEntries do:[:i|
				table at: tableStart + tableIndex put: (values at: valueIndex).
				valueIndex := valueIndex + 1.
				numValues := numValues - 1.
				tableIndex := self increment: tableIndex bits: deltaBits].
			"Check if we have filled up the current table completely"
			maxEntries = tableSize ifTrue:[
				"Table has been filled. Back up to the last table with space left."
				[tableStack isEmpty not and:[(tableStack last at: 5) = 0]]
						whileTrue:[tableStack removeLast].
			] ifFalse:[
				"Table not yet filled. Put it back on the stack."
				tableStack addLast:
					(Array
						with: bits		"Nr. of bits in this table"
						with: tableStart	"Start of table"
						with: tableIndex "Index in table"
						with: deltaBits	"delta bits of table"
						with: tableSize - maxEntries "Unused entries in table").
			].
		].
	].
	 ^table copyFrom: 1 to: tableEnd-1! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:25'!
decodeDynamicTable: nItems from: aHuffmanTable
	"Decode the code length of the literal/length and distance table
	in a block compressed with dynamic huffman trees"
	| values index value repCount theValue |
	values := Array new: nItems.
	index := 1.
	theValue := 0.
	[index <= nItems] whileTrue:[
		value := self decodeValueFrom: aHuffmanTable.
		value < 16 ifTrue:[
			"Immediate values"
			theValue := value.
			values at: index put: value.
			index := index+1.
		] ifFalse:[
			"Repeated values"
			value = 16 ifTrue:[
				"Repeat last value"
				repCount := (self nextBits: 2) + 3.
			] ifFalse:[
				"Repeat zero value"
				theValue := 0.
				value = 17 
					ifTrue:[repCount := (self nextBits: 3) + 3]
					ifFalse:[value = 18 
								ifTrue:[repCount := (self nextBits: 7) + 11]
								ifFalse:[^self error:'Invalid bits tree value']]].
			0 to: repCount-1 do:[:i| values at: index+i put: theValue].
			index := index + repCount].
	].
	^values! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:51'!
distanceMap
	"This is used by the fast decompressor"
	^nil! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/3/1998 13:16'!
growHuffmanTable: table
	| newTable |
	newTable := table species new: table size * 2.
	newTable replaceFrom: 1 to: table size with: table startingAt: 1.
	^newTable! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:27'!
huffmanTableFrom: aCollection mappedBy: valueMap
	"Create a new huffman table from the given code lengths.
	Map the actual values by valueMap if it is given.
	See the class comment for a documentation of the huffman
	tables used in this decompressor."
	| counts  values table minBits maxBits |
	minBits := MaxBits + 1.
	maxBits := 0.
	"Count the occurences of each code length and compute minBits and maxBits"
	counts := Array new: MaxBits+1.
	counts atAllPut: 0.
	aCollection do:[:length| 
		length > 0 ifTrue:[
			length < minBits ifTrue:[minBits := length].
			length > maxBits ifTrue:[maxBits := length].
			counts at: length+1 put: (counts at: length+1)+1]].
	maxBits = 0 ifTrue:[^nil]. "Empty huffman table"

	"Assign numerical values to all codes."
	values := self computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits.

	"Map the values if requested"
	self mapValues: values by: valueMap.

	"Create the actual tables"
	table := self createHuffmanTables: values counts: counts from: minBits to: maxBits.

	^table! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'!
increment: value bits: nBits
	"Increment a value of nBits length.
	The fast decompressor will do this differently"
	^value+1! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:50'!
literalLengthMap
	"This is used by the fast decompressor"
	^nil! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:28'!
mapValues: values by: valueMap
	| oldValue |
	valueMap ifNil:[^values].
	1 to: values size do:[:i|
		oldValue := values at: i.
		"Note: there may be nil values if not all values are used"
		oldValue isNil
			ifTrue:[^values]
			ifFalse:[values at: i put: (valueMap at: oldValue+1)]].
! !


!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 02:24'!
decodeValueFrom: table
	"Decode the next value in the receiver using the given huffman table."
	| bits bitsNeeded tableIndex value |
	bitsNeeded := (table at: 1) bitShift: -24.	"Initial bits needed"
	tableIndex := 2.							"First real table"
	[bits := self nextSingleBits: bitsNeeded.	"Get bits"
	value := table at: (tableIndex + bits).		"Lookup entry in table"
	(value bitAnd: 16r3F000000) = 0] 			"Check if it is a non-leaf node"
		whileFalse:["Fetch sub table"
			tableIndex := value bitAnd: 16rFFFF.	"Table offset in low 16 bit"
			bitsNeeded := (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit"
			bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']].
	^value! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 3/15/1999 15:38'!
decompressBlock: llTable with: dTable
	"Process the compressed data in the block.
	llTable is the huffman table for literal/length codes
	and dTable is the huffman table for distance codes."
	| value extra length distance oldPos oldBits oldBitPos |
	[readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[
		"Back up stuff if we're running out of space"
		oldBits := bitBuf.
		oldBitPos := bitPos.
		oldPos := sourcePos.
		value := self decodeValueFrom: llTable.
		value < 256 ifTrue:[ "A literal"
			collection byteAt: (readLimit := readLimit + 1) put: value.
		] ifFalse:["length/distance or end of block"
			value = 256 ifTrue:["End of block"
				state := state bitAnd: StateNoMoreData.
				^self].
			"Compute the actual length value (including possible extra bits)"
			extra := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0) at: value - 256.
			length := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258) at: value - 256.
			extra > 0 ifTrue:[length := length + (self nextBits: extra)].
			"Compute the distance value"
			value := self decodeValueFrom: dTable.
			extra := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13) at: value+1.
			distance := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769
						1025 1537 2049 3073 4097 6145 8193 12289 16385 24577) at: value+1.
			extra > 0 ifTrue:[distance := distance + (self nextBits: extra)].
			(readLimit + length >= collection size) ifTrue:[
				bitBuf := oldBits.
				bitPos := oldBitPos.
				sourcePos := oldPos.
				^self].
			collection 
					replaceFrom: readLimit+1 
					to: readLimit + length + 1 
					with: collection 
					startingAt: readLimit - distance + 1.
			readLimit := readLimit + length.
		].
	].! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'!
proceedDynamicBlock
	self decompressBlock: litTable with: distTable! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'!
proceedFixedBlock
	self decompressBlock: litTable with: distTable! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'!
proceedStoredBlock
	"Proceed decompressing a stored (e.g., uncompressed) block"
	| length decoded |
	"Literal table must be nil for a stored block"
	litTable == nil ifFalse:[^self error:'Bad state'].
	length := distTable.
	[length > 0 and:[readLimit < collection size and:[sourcePos < sourceLimit]]] 
		whileTrue:[
			collection at: (readLimit := readLimit + 1) put: 
				(source at: (sourcePos := sourcePos + 1)).
			length := length - 1].
	length = 0 ifTrue:[state := state bitAnd: StateNoMoreData].
	decoded := length - distTable.
	distTable := length.
	^decoded! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 01:46'!
processDynamicBlock
	| nLit nDist nLen codeLength lengthTable bits |
	nLit := (self nextBits: 5) + 257.
	nDist := (self nextBits: 5) + 1.
	nLen := (self nextBits: 4) + 4.
	codeLength := Array new: 19.
	codeLength atAllPut: 0.
	1 to: nLen do:[:i|
		bits := #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) at: i.
		codeLength at: bits+1 put: (self nextBits: 3).
	].
	lengthTable := self huffmanTableFrom: codeLength mappedBy: nil.
	"RFC 1951: In other words, all code lengths form a single sequence..."
	codeLength := self decodeDynamicTable: nLit+nDist from: lengthTable.
	litTable := self 
				huffmanTableFrom: (codeLength copyFrom: 1 to: nLit)
				mappedBy: self literalLengthMap.
	distTable := self 
				huffmanTableFrom: (codeLength copyFrom: nLit+1 to: codeLength size)
				mappedBy: self distanceMap.
	state := state bitOr: BlockProceedBit.
	self proceedDynamicBlock.! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:13'!
processFixedBlock
	litTable := self 
				huffmanTableFrom: FixedLitCodes
				mappedBy: self literalLengthMap.
	distTable := self 
				huffmanTableFrom: FixedDistCodes
				mappedBy: self distanceMap.
	state := state bitOr: BlockProceedBit.
	self proceedFixedBlock.! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'!
processStoredBlock
	| chkSum length |
	"Skip to byte boundary"
	self nextBits: (bitPos bitAnd: 7).
	length := self nextBits: 16.
	chkSum := self nextBits: 16.
	(chkSum bitXor: 16rFFFF) = length
		ifFalse:[^self error:'Bad block length'].
	litTable := nil.
	distTable := length.
	state := state bitOr: BlockProceedBit.
	^self proceedStoredBlock! !


!InflateStream methodsFor: 'initialize' stamp: 'ls 1/2/2001 11:44'!
on: aCollectionOrStream
	aCollectionOrStream isStream 
		ifTrue:[	aCollectionOrStream binary.
				sourceStream := aCollectionOrStream.
				self getFirstBuffer]
		ifFalse:[source := aCollectionOrStream].
	^self on: source from: 1 to: source size.! !

!InflateStream methodsFor: 'initialize' stamp: 'ar 12/23/1999 15:35'!
on: aCollection from: firstIndex to: lastIndex
	bitBuf := bitPos := 0.
	"The decompression buffer has a size of at 64k,
	since we may have distances up to 32k back and
	repetitions of at most 32k length forward"
	collection := aCollection species new: 1 << 16.
	readLimit := 0. "Not yet initialized"
	position := 0.
	source := aCollection.
	sourceLimit := lastIndex.
	sourcePos := firstIndex-1.
	state := StateNewBlock.! !

!InflateStream methodsFor: 'initialize' stamp: 'ar 12/3/1998 16:32'!
reset
	"Position zero - nothing decoded yet"
	position := readLimit := 0.
	sourcePos := 0.
	bitBuf := bitPos := 0.
	state := 0.! !


!InflateStream methodsFor: 'testing' stamp: 'ar 12/27/1999 13:43'!
atEnd
	"Note: It is possible that we have a few bits left,
	representing just the EOB marker. To check for
	this we must force decompression of the next
	block if at end of data."
	super atEnd ifFalse:[^false]. "Primitive test"
	(position >= readLimit and:[state = StateNoMoreData]) ifTrue:[^true].
	"Force decompression, by calling #next. Since #moveContentsToFront
	will never move data to the beginning of the buffer it is safe to
	skip back the read position afterwards"
	self next == nil ifTrue:[^true].
	position := position - 1.
	^false! !


!InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'!
decompressAll
	"Profile the decompression speed"
	[self atEnd] whileFalse:[
		position := readLimit.
		self next "Provokes decompression"
	].! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:15'!
getFirstBuffer
	"Get the first source buffer after initialization has been done"
	sourceStream == nil ifTrue:[^self].
	source := sourceStream next: 1 << 16. "This is more than enough..."
	sourceLimit := source size.! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/3/1998 17:32'!
getNextBlock
	^self nextBits: 3! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:17'!
moveContentsToFront
	"Move the decoded contents of the receiver to the front so that we have enough space for decoding more data."
	| delta |
	readLimit > 32768 ifTrue:[
		delta := readLimit - 32767.
		collection 
			replaceFrom: 1 
			to: collection size - delta + 1 
			with: collection 
			startingAt: delta.
		position := position - delta + 1.
		readLimit := readLimit - delta + 1].! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:27'!
moveSourceToFront
	"Move the encoded contents of the receiver to the front so that we have enough space for decoding more data."
	(sourceStream == nil or:[sourceStream atEnd]) ifTrue:[^self].
	sourcePos > 10000 ifTrue:[
		source 
			replaceFrom: 1 
			to: source size - sourcePos
			with: source 
			startingAt: sourcePos + 1.
		source := sourceStream 
			next: sourcePos 
			into: source 
			startingAt: source size - sourcePos + 1.
		sourcePos := 0.
		sourceLimit := source size].! !

!InflateStream methodsFor: 'private' stamp: 'ar 2/29/2004 04:18'!
pastEndRead
	"A client has attempted to read beyond the read limit.
	Check in what state we currently are and perform
	the appropriate action"
	| blockType bp oldLimit |
	state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible"
	"Check if we can move decoded data to front"
	self moveContentsToFront.
	"Check if we can fetch more source data"
	self moveSourceToFront.
	state = StateNewBlock ifTrue:[state := self getNextBlock].
	blockType := state bitShift: -1.
	bp := self bitPosition.
	oldLimit := readLimit.
	self perform: (BlockTypes at: blockType+1).
	"Note: if bit position hasn't advanced then nothing has been decoded."
	bp = self bitPosition 
		ifTrue:[^self primitiveFailed].
	"Update crc for the decoded contents"
	readLimit > oldLimit 
		ifTrue:[crc := self updateCrc: crc from: oldLimit+1 to: readLimit in: collection].
	state = StateNoMoreData ifTrue:[self verifyCrc].
	^self next! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'!
profile
	"Profile the decompression speed"
	MessageTally spyOn:[self decompressAll].! !

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

InflateStream class
	instanceVariableNames: ''!

!InflateStream class methodsFor: 'class initialization' stamp: 'ar 12/4/1998 19:12'!
initialize
	"InflateStream initialize"
	MaxBits := 16.
	StateNewBlock := 0.
	StateNoMoreData := 1.
	BlockProceedBit := 8.
	BlockTypes := #(	processStoredBlock	"New block in stored format"
					processFixedBlock	"New block with fixed huffman tables"
					processDynamicBlock	"New block with dynamic huffman tables"
					errorBadBlock		"Bad block format"
					proceedStoredBlock	"Continue block in stored format"
					proceedFixedBlock	"Continue block in fixed format"
					proceedDynamicBlock	"Continue block in dynamic format"
					errorBadBlock		"Bad block format").
	"Initialize fixed block values"
	FixedLitCodes := 	((1 to: 144) collect:[:i| 8]),
					((145 to: 256) collect:[:i| 9]),
					((257 to: 280) collect:[:i| 7]),
					((281 to: 288) collect:[:i| 8]).
	FixedDistCodes := ((1 to: 32) collect:[:i| 5]).! !
StringMorph subclass: #InfoStringMorph
	instanceVariableNames: 'stepTime block'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!InfoStringMorph commentStamp: '<historical>' prior: 0!
A generalization of the clock morph

Try
	InfoStringMorph new openInWorld
or
	(InfoStringMorph on: [Smalltalk vmParameterAt: 9])
		stepTime: 50;
		openInWorld!


!InfoStringMorph methodsFor: 'accessing' stamp: 'sma 6/1/2000 14:06'!
block
	^ block! !

!InfoStringMorph methodsFor: 'accessing' stamp: 'sma 6/1/2000 14:05'!
block: aBlock
	block _ aBlock! !

!InfoStringMorph methodsFor: 'accessing' stamp: 'sma 6/1/2000 14:06'!
stepTime: anInteger
	stepTime _ anInteger! !


!InfoStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	stepTime _ 1000.
	block _ [Time now]! !


!InfoStringMorph methodsFor: 'stepping and presenter' stamp: 'sma 6/1/2000 14:03'!
step
	self contents: block value asString! !


!InfoStringMorph methodsFor: 'testing' stamp: 'sma 6/1/2000 14:03'!
stepTime
	^ stepTime! !

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

InfoStringMorph class
	instanceVariableNames: ''!

!InfoStringMorph class methodsFor: 'instance creation' stamp: 'sma 6/1/2000 14:07'!
on: aBlock
	^ self new block: aBlock! !
Object subclass: #InputSensor
	instanceVariableNames: ''
	classVariableNames: 'ButtonDecodeTable InterruptSemaphore InterruptWatcherProcess KeyDecodeTable'
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!InputSensor commentStamp: '<historical>' prior: 0!
An InputSensor is an interface to the user input devices.
There is at least one (sub)instance of InputSensor named Sensor in the system.

Class variables:

ButtonDecodeTable <ByteArray> - maps mouse buttons as reported by the VM to ones reported in the events.

KeyDecodeTable <Dictionary<SmallInteger->SmallInteger>> - maps some keys and their modifiers to other keys (used for instance to map Ctrl-X to Alt-X)

InterruptSemaphore <Semaphore> - signalled by the the VM and/or the event loop upon receiving an interrupt keystroke.

InterruptWatcherProcess <Process> - waits on the InterruptSemaphore and then responds as appropriate.!


!InputSensor methodsFor: 'accessing' stamp: 'ar 10/11/2000 17:34'!
eventQueue
	^nil! !

!InputSensor methodsFor: 'accessing' stamp: 'ar 10/11/2000 17:35'!
eventQueue: aSharedQueue
! !

!InputSensor methodsFor: 'accessing' stamp: 'JMM 10/5/2001 12:54'!
flushAllButDandDEvents! !


!InputSensor methodsFor: 'buttons' stamp: 'nk 7/12/2000 09:33'!
buttons
	"Answer the result of primMouseButtons, but swap the mouse  
	buttons if Preferences swapMouseButtons is set."
	^ ButtonDecodeTable at: self primMouseButtons + 1! !


!InputSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:15'!
currentCursor
	"The current cursor is maintained in class Cursor."

	^ Cursor currentCursor! !

!InputSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:16'!
currentCursor: newCursor 
	"The current cursor is maintained in class Cursor."

	Cursor currentCursor: newCursor.! !

!InputSensor methodsFor: 'cursor'!
cursorPoint
	"Answer a Point indicating the cursor location."

	^self mousePoint! !

!InputSensor methodsFor: 'cursor'!
cursorPoint: aPoint 
	"Set aPoint to be the current cursor location."

	^self primCursorLocPut: aPoint! !

!InputSensor methodsFor: 'cursor' stamp: 'ar 2/14/2001 00:00'!
peekPosition
	^self cursorPoint! !


!InputSensor methodsFor: 'initialize' stamp: 'ar 9/26/2000 21:35'!
flushEvents
	"Do nothing"! !

!InputSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 19:45'!
shutDown
	InterruptWatcherProcess ifNotNil: [
		InterruptWatcherProcess terminate.
		InterruptWatcherProcess _ nil ].! !

!InputSensor methodsFor: 'initialize' stamp: 'ar 7/23/2000 00:00'!
startUp
	self installInterruptWatcher.! !


!InputSensor methodsFor: 'joystick'!
joystickButtons: index

	^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F
	! !

!InputSensor methodsFor: 'joystick'!
joystickOn: index

	^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0
	! !

!InputSensor methodsFor: 'joystick'!
joystickXY: index

	| inputWord x y |
	inputWord _ self primReadJoystick: index.
	x _ (inputWord bitAnd: 16r7FF) - 16r400.
	y _ ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400.
	^ x@y
	! !

!InputSensor methodsFor: 'joystick' stamp: 'BG 3/16/2005 08:23'!
testJoystick: index
	"Sensor testJoystick: 3"

	| f pt buttons status |
	f _ Form extent: 110@50.
	[Sensor anyButtonPressed] whileFalse: [
		pt _ Sensor joystickXY: index.
		buttons _ Sensor joystickButtons: index.
		status _
'xy: ', pt printString, '
buttons: ', buttons printStringHex.
		f fillWhite.
		status displayOn: f at: 10@10.
		f displayOn: Display at: 10@10.
	].
! !


!InputSensor methodsFor: 'keyboard'!
flushKeyboard
	"Remove all characters from the keyboard buffer."

	[self keyboardPressed]
		whileTrue: [self keyboard]! !

!InputSensor methodsFor: 'keyboard' stamp: 'di 10/29/97 20:20'!
kbdTest    "Sensor kbdTest"
	"This test routine will print the unmodified character, its keycode,
	and the OR of all its modifier bits, until the character x is typed"
	| char |
	char _ nil.
	[char = $x] whileFalse: 
		[[self keyboardPressed] whileFalse: [].
		char _ self characterForKeycode: self keyboard.
		(String streamContents: 
			[:s | s nextPut: char; space; print: char asciiValue;
					space; print: self primMouseButtons; nextPutAll: '     '])
			displayAt: 10@10]! !

!InputSensor methodsFor: 'keyboard' stamp: 'yo 8/18/2003 23:36'!
keyboard
	"Answer the next character from the keyboard."

	| firstCharacter secondCharactor stream multiCharacter converter |
	firstCharacter _ self characterForKeycode: self primKbdNext.
	secondCharactor _ self characterForKeycode: self primKbdPeek.
	secondCharactor isNil
		ifTrue: [^ firstCharacter].
	converter _ TextConverter defaultSystemConverter.
	converter isNil
		ifTrue: [^ firstCharacter].
	stream _ ReadStream
				on: (String with: firstCharacter with: secondCharactor).
	multiCharacter _ converter nextFromStream: stream.
	multiCharacter isOctetCharacter
		ifTrue: [^ multiCharacter].
	self primKbdNext.
	^ multiCharacter
! !

!InputSensor methodsFor: 'keyboard'!
keyboardPeek
	"Answer the next character in the keyboard buffer without removing it, or nil if it is empty."

	^ self characterForKeycode: self primKbdPeek! !

!InputSensor methodsFor: 'keyboard'!
keyboardPressed
	"Answer true if keystrokes are available."

	^self primKbdPeek notNil! !


!InputSensor methodsFor: 'modifier keys' stamp: 'di 9/28/1999 08:29'!
anyModifierKeyPressed
	"ignore, however, the shift keys 'cause that's not REALLY a command key"

	^ self primMouseButtons anyMask: 16r70	"cmd | opt | ctrl"! !

!InputSensor methodsFor: 'modifier keys'!
commandKeyPressed
	"Answer whether the command key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 64! !

!InputSensor methodsFor: 'modifier keys'!
controlKeyPressed
	"Answer whether the control key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 16! !

!InputSensor methodsFor: 'modifier keys'!
leftShiftDown
	"Answer whether the shift key on the keyboard is being held down. The name of this message is a throwback to the Alto, which had independent left and right shift keys."

	^ self primMouseButtons anyMask: 8! !

!InputSensor methodsFor: 'modifier keys' stamp: 'sw 9/21/2000 12:41'!
rawMacOptionKeyPressed
	"Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific.  Clients are discouraged from calling this directly, since it circumvents bert's attempt to eradicate option-key checks"

	^ self primMouseButtons anyMask: 32! !

!InputSensor methodsFor: 'modifier keys' stamp: 'jm 5/21/1998 16:13'!
shiftPressed
	"Answer whether the shift key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 8
! !


!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'!
anyButtonPressed
	"Answer whether at least one mouse button is currently being pressed."

	^ self primMouseButtons anyMask: 7
! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'!
blueButtonPressed
	"Answer whether only the blue mouse button is being pressed. 
	This is the third mouse button or cmd+click on the Mac."

	^ (self primMouseButtons bitAnd: 7) = 1
! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'!
mouseButtons
	"Answer a number from 0 to 7 that encodes the state of the three mouse buttons in its lowest 3 bits."

	^ self primMouseButtons bitAnd: 7
! !

!InputSensor methodsFor: 'mouse'!
mousePoint
	"Answer a Point indicating the coordinates of the current mouse location."

	^self primMousePt! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:02'!
noButtonPressed
	"Answer whether any mouse button is not being pressed."

	^self anyButtonPressed not
! !

!InputSensor methodsFor: 'mouse' stamp: 'ar 2/14/2001 00:02'!
peekButtons
	^self primMouseButtons! !

!InputSensor methodsFor: 'mouse' stamp: 'ar 2/8/2001 21:45'!
peekMousePt
	^self primMousePt! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:16'!
redButtonPressed
	"Answer true if only the red mouse button is being pressed.
	This is the first mouse button, usually the left one."

	^ (self primMouseButtons bitAnd: 7) = 4
! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'!
waitButton
	"Wait for the user to press any mouse button and then answer with the 
	current location of the cursor."

	| delay |
	delay _ Delay forMilliseconds: 50.
	[self anyButtonPressed] whileFalse: [ delay wait ].
	^self cursorPoint
! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'!
waitButtonOrKeyboard
	"Wait for the user to press either any mouse button or any key. 
	Answer the current cursor location or nil if a keypress occured."

	| delay |
	delay := Delay forMilliseconds: 50.
	[self anyButtonPressed]
		whileFalse: [delay wait.
			self keyboardPressed
				ifTrue: [^ nil]].
	^ self cursorPoint
! !

!InputSensor methodsFor: 'mouse'!
waitClickButton
	"Wait for the user to click (press and then release) any mouse button and 
	then answer with the current location of the cursor."

	self waitButton.
	^self waitNoButton! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:25'!
waitNoButton
	"Wait for the user to release any mouse button and then answer the current location of the cursor."

	| delay |
	delay _ Delay forMilliseconds: 50.
	[self anyButtonPressed] whileTrue: [ delay wait].
	^self cursorPoint
! !

!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:05'!
yellowButtonPressed
	"Answer whether only the yellow mouse button is being pressed. 
	This is the second mouse button or option+click on the Mac."

	^ (self primMouseButtons bitAnd: 7) = 2
! !


!InputSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 22:14'!
hasTablet
	"Answer true if there is a pen tablet available on this computer."

	^ (self primTabletGetParameters: 1) notNil
! !

!InputSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:02'!
tabletExtent
	"Answer the full tablet extent in tablet coordinates."

	| params |
	params _ self primTabletGetParameters: 1.
	params ifNil: [^ self error: 'no tablet available'].
	^ (params at: 1)@(params at: 2)
! !

!InputSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:12'!
tabletPoint
	"Answer the current position of the first tablet pointing device (pen, puck, or eraser) in tablet coordinates."

	| data |
	data _ self primTabletRead: 1.  "state of first/primary pen"
	^ (data at: 3) @ (data at: 4)
! !

!InputSensor methodsFor: 'tablet' stamp: 'jm 4/12/1999 13:05'!
tabletPressure
	"Answer the current pressure of the first tablet pointing device (pen, puck, or eraser), a number between 0.0 (no pressure) and 1.0 (max pressure)"

	| params data |
	params _ self primTabletGetParameters: 1.
	params ifNil: [^ self].
	data _ self primTabletRead: 1.  "state of first/primary pen"
	^ (data at: 10) asFloat / ((params at: 10) - 1)
! !

!InputSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 23:03'!
tabletTimestamp
	"Answer the time (in tablet clock ticks) at which the tablet's primary pen last changed state. This can be used in polling loops; if this timestamp hasn't changed, then the pen state hasn't changed either."

	| data |
	data _ self primTabletRead: 1.  "state of first/primary pen"
	^ data at: 2
! !


!InputSensor methodsFor: 'user interrupts' stamp: 'nk 4/12/2004 19:36'!
eventTicklerProcess
	"Answer my event tickler process, if any"
	^nil! !

!InputSensor methodsFor: 'user interrupts' stamp: 'nk 10/29/2000 11:23'!
inputProcess
	"For non-event image compatibility"
	^ nil! !

!InputSensor methodsFor: 'user interrupts' stamp: 'nk 6/21/2004 10:41'!
installInterruptWatcher
	"Initialize the interrupt watcher process. Terminate the old process if any."
	"Sensor installInterruptWatcher"

	InterruptWatcherProcess ifNotNil: [InterruptWatcherProcess terminate].
	InterruptSemaphore _ Semaphore new.
	InterruptWatcherProcess _ [self userInterruptWatcher] forkAt: Processor lowIOPriority.
	self primInterruptSemaphore: InterruptSemaphore.! !

!InputSensor methodsFor: 'user interrupts' stamp: 'nk 10/28/2000 20:33'!
interruptWatcherProcess
	"Answer my interrupt watcher process, if any"
	^InterruptWatcherProcess! !

!InputSensor methodsFor: 'user interrupts'!
setInterruptKey: anInteger
	"Register the given keycode as the user interrupt key."

	self primSetInterruptKey: anInteger.
! !

!InputSensor methodsFor: 'user interrupts' stamp: 'gk 2/23/2004 20:51'!
userInterruptWatcher
	"Wait for user interrupts and open a notifier on the active process when one occurs."

	[true] whileTrue: [
		InterruptSemaphore wait.
		Display deferUpdates: false.
		SoundService default shutDown.
		Smalltalk handleUserInterrupt]
! !


!InputSensor methodsFor: 'private'!
characterForKeycode: keycode
	"Map the given keycode to a Smalltalk character object. Encoding:
		A keycode is 12 bits:   <4 modifer bits><8 bit ISO character>
		Modifier bits are:       <command><option><control><shift>"

	"NOTE: the command and option keys are specific to the Macintosh and may not have equivalents on other platforms."

	keycode = nil ifTrue: [ ^nil ].
	keycode class = Character ifTrue: [ ^keycode ].  "to smooth the transition!!"
	^ Character value: (keycode bitAnd: 16rFF)! !

!InputSensor methodsFor: 'private'!
primCursorLocPut: aPoint
	"If the primitive fails, try again with a rounded point."

	<primitive: 91>
	^ self primCursorLocPutAgain: aPoint rounded! !

!InputSensor methodsFor: 'private'!
primCursorLocPutAgain: aPoint
	"Do nothing if primitive is not implemented."

	<primitive: 91>
	^ self! !

!InputSensor methodsFor: 'private' stamp: 'ar 7/23/2000 15:38'!
primInterruptSemaphore: aSemaphore 
	"Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed."

	<primitive: 134>
	^self primitiveFailed
"Note: This primitive is obsolete with the new event driven architecture in which EventSensor can handle the interrupts itself. However, for supporting older images running on newer VMs the primitive must still be implemented."! !

!InputSensor methodsFor: 'private'!
primKbdNext
	<primitive: 108>
	^ nil! !

!InputSensor methodsFor: 'private'!
primKbdPeek
	<primitive: 109>
	^ nil! !

!InputSensor methodsFor: 'private'!
primMouseButtons
	<primitive: 107>
	^ 0! !

!InputSensor methodsFor: 'private'!
primMousePt
	"Primitive. Poll the mouse to find out its position. Return a Point. Fail if
	event-driven tracking is used instead of polling. Optional. See Object
	documentation whatIsAPrimitive."

	<primitive: 90>
	^ 0@0! !

!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primReadJoystick: index
	"Return the joystick input word for the joystick with the given index in the range [1..16]. Returns zero if the index does not correspond to a currently installed joystick."

	<primitive: 'primitiveReadJoystick' module: 'JoystickTabletPlugin'>
	^ 0

	! !

!InputSensor methodsFor: 'private' stamp: 'ar 7/23/2000 15:38'!
primSetInterruptKey: anInteger
	"Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>."

	<primitive: 133>
	^self primitiveFailed
"Note: This primitive is obsolete with the new event driven architecture in which EventSensor can handle the interrupts itself. However, for supporting older images running on newer VMs the primitive must still be implemented."! !

!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primTabletGetParameters: cursorIndex
	"Answer the pen tablet parameters. For parameters that differ from cursor to cursor, answer those associated with the cursor having the given index. Answer nil if there is no pen tablet. The parameters are:
	1. tablet width, in tablet units
	2. tablet height, in tablet units
	3. number of tablet units per inch
	4. number of cursors (pens, pucks, etc; some tablets have more than one)
	5. this cursor index
	6. and 7. x scale and x offset for scaling tablet coordintes (e.g., to fit the screen)
	8. and 9. y scale and y offset for scaling tablet coordintes  (e.g., to fit the screen)
	10. number of pressure levels
	11. presure threshold needed close pen tip switch 
	12. number of pen tilt angles"

	<primitive: 'primitiveGetTabletParameters' module: 'JoystickTabletPlugin'>
	^ nil
! !

!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primTabletRead: cursorIndex
	"Answer the pen tablet data for the cursor having the given index. Answer nil if there is no pen tablet. The data is:
	1. index of the cursor to which this data applies
	2. timestamp of the last state chance for this cursor
	3., 4., and 5. x, y, and z coordinates of the cursor (z is typically 0)
	6. and 7. xTilt and yTilt of the cursor; (signed)
	8. type of cursor (0 = unknown, 1 = pen, 2 = puck, 3 = eraser)
	9. cursor buttons
	10. cursor pressure, downward
	11. cursor pressure, tangential
	12. flags"

	<primitive: 'primitiveReadTablet' module: 'JoystickTabletPlugin'>
	self primitiveFailed
! !

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

InputSensor class
	instanceVariableNames: ''!

!InputSensor class methodsFor: 'class initialization' stamp: 'nk 7/11/2002 07:41'!
defaultCrossPlatformKeys
	"Answer a list of key letters that are used for common editing operations
	on different platforms."
	^{ $c . $x . $v . $a . $s . $f . $g . $z }
! !

!InputSensor class methodsFor: 'class initialization' stamp: 'dew 12/13/2004 23:21'!
installKeyDecodeTable
	"Create a decode table that swaps some keys if 
	Preferences swapControlAndAltKeys is set"
	KeyDecodeTable _ Dictionary new.
	Preferences duplicateControlAndAltKeys 
		ifTrue: [ self defaultCrossPlatformKeys do:
				[ :c | self installDuplicateKeyEntryFor: c ] ].
	Preferences swapControlAndAltKeys 
		ifTrue: [ self defaultCrossPlatformKeys do:
				[ :c | self installSwappedKeyEntryFor: c ] ].
	Preferences duplicateAllControlAndAltKeys
		ifTrue: [ (Character allCharacters select: [:ea | ea isAlphaNumeric]) do:
				[ :c | self installDuplicateKeyEntryFor: c ] ].
! !

!InputSensor class methodsFor: 'class initialization' stamp: 'nk 2/10/2002 11:55'!
installMouseDecodeTable
	"Create a decode table that swaps the lowest-order 2 bits if 
	Preferences swapMouseButtons is set"
	ButtonDecodeTable _ Preferences swapMouseButtons
				ifTrue: [ByteArray withAll:
							((0 to: 255) collect: [:ea |
								((ea bitAnd: 1) << 1
									bitOr: (ea bitAnd: 2) >> 1)
										bitOr: (ea bitAnd: 16rFC) ])]
				ifFalse: [ByteArray
						withAll: (0 to: 255)]! !


!InputSensor class methodsFor: 'preference change notification' stamp: 'dew 12/14/2004 23:54'!
duplicateAllControlAndAltKeysChanged
	"The Preference for duplicateAllControlAndAltKeys has changed; reset the other two."
	"At some point the various exclusive CtrlAlt-key prefs should become a radio button set, then these methods wouldn't be needed."
	(Preferences
		valueOfFlag: #swapControlAndAltKeys
		ifAbsent: [false]) ifTrue: [
			self inform: 'Resetting swapControlAndAltKeys preference'.
			(Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false.
		].
	(Preferences
		valueOfFlag: #duplicateControlAndAltKeys
		ifAbsent: [false]) ifTrue: [
			self inform: 'Resetting duplicateControlAndAltKeys preference'.
			(Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false.
		].
	self installKeyDecodeTable.
! !

!InputSensor class methodsFor: 'preference change notification' stamp: 'dew 12/13/2004 18:58'!
duplicateControlAndAltKeysChanged
	"The Preference for duplicateControlAndAltKeys has changed; reset the other two."
	(Preferences
		valueOfFlag: #swapControlAndAltKeys
		ifAbsent: [false]) ifTrue: [
			self inform: 'Resetting swapControlAndAltKeys preference'.
			(Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false.
		].
	(Preferences
		valueOfFlag: #duplicateAllControlAndAltKeys
		ifAbsent: [false]) ifTrue: [
			self inform: 'Resetting duplicateAllControlAndAltKeys preference'.
			(Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false.
		].
	self installKeyDecodeTable.
! !

!InputSensor class methodsFor: 'preference change notification' stamp: 'dew 12/13/2004 18:58'!
swapControlAndAltKeysChanged
	"The Preference for swapControlAndAltKeys has changed; reset the other two."
	(Preferences
		valueOfFlag: #duplicateControlAndAltKeys
		ifAbsent: [false]) ifTrue: [
			self inform: 'Resetting duplicateControlAndAltKeys preference'.
			(Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false.
		].
	(Preferences
		valueOfFlag: #duplicateAllControlAndAltKeys
		ifAbsent: [false]) ifTrue: [
			self inform: 'Resetting duplicateAllControlAndAltKeys preference'.
			(Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false.
		].
	self installKeyDecodeTable.
! !


!InputSensor class methodsFor: 'public'!
default
	"Answer the default system InputSensor, Sensor."

	^ Sensor! !

!InputSensor class methodsFor: 'public' stamp: 'nk 7/11/2002 07:14'!
duplicateControlAndAltKeys: aBoolean
	"InputSensor duplicateControlAndAltKeys: true"

	Preferences setPreference: #duplicateControlAndAltKeys toValue: aBoolean.
	self installKeyDecodeTable
! !

!InputSensor class methodsFor: 'public' stamp: 'nk 7/11/2002 07:09'!
installDuplicateKeyEntryFor: c
	| key |
	key _ c asInteger.
	"first do control->alt key"
	KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }.
	"then alt->alt key"
	KeyDecodeTable at: { key . 8 } put: { key . 8 }
! !

!InputSensor class methodsFor: 'public' stamp: 'nk 2/11/2002 12:39'!
installSwappedKeyEntryFor: c
	| key |
	key _ c asInteger.
	"first do control->alt key"
	KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }.
	"then alt->control key"
	KeyDecodeTable at: { key . 8 } put: { key bitAnd: 16r9F . 2 }! !

!InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'!
keyDecodeTable
	^KeyDecodeTable ifNil: [ self installKeyDecodeTable ]! !

!InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'!
swapControlAndAltKeys: aBoolean
	"InputSensor swapControlAndAltKeys: true"

	Preferences setPreference: #swapControlAndAltKeys toValue: aBoolean.
	self installKeyDecodeTable! !

!InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'!
swapMouseButtons: aBoolean
	"InputSensor swapMouseButtons: true"

	Preferences setPreference: #swapMouseButtons toValue: aBoolean.
	self installMouseDecodeTable.! !


!InputSensor class methodsFor: 'system startup' stamp: 'nk 6/21/2004 10:36'!
shutDown
	self default shutDown.! !

!InputSensor class methodsFor: 'system startup' stamp: 'nk 2/10/2002 11:57'!
startUp
	
	self installMouseDecodeTable.
	self installKeyDecodeTable.
	self default startUp! !
SimpleBorder subclass: #InsetBorder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Borders'!
!InsetBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0!
see BorderedMorph!


!InsetBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:11'!
bottomRightColor
	^width = 1 
		ifTrue: [color twiceLighter]
		ifFalse: [color lighter]! !

!InsetBorder methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:23'!
colorsAtCorners
	| c c14 c23 |
	c _ self color.
	c14 _ c lighter. c23 _ c darker.
	^Array with: c23 with: c14 with: c14 with: c23.! !

!InsetBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'!
style
	^#inset! !

!InsetBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:11'!
topLeftColor
	^width = 1 
		ifTrue: [color twiceDarker]
		ifFalse: [color darker]! !


!InsetBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'!
trackColorFrom: aMorph
	baseColor ifNil:[self color: aMorph insetColor].! !
StringHolder subclass: #Inspector
	instanceVariableNames: 'object selectionIndex timeOfLastListUpdate selectionUpdateTime context'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!
!Inspector commentStamp: '<historical>' prior: 0!
I represent a query path into the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected variable of the observed object.!


!Inspector methodsFor: 'accessing'!
baseFieldList
	"Answer an Array consisting of 'self'
	and the instance variable names of the inspected object."

	^ (Array with: 'self' with: 'all inst vars')
			, object class allInstVarNames! !

!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
context: ctxt
	"Set the context of inspection. Currently only used by my subclass ClosureEnvInspector. The inst var is here because we do primitiveChangeClassTo: between subclasses (see inspect:) between different subclasses, but also context could be used as a general concept in all inspectors"

	context := ctxt! !

!Inspector methodsFor: 'accessing'!
fieldList
	"Answer the base field list plus an abbreviated list of indices."

	object class isVariable ifFalse: [^ self baseFieldList].
	^ self baseFieldList ,
		(object basicSize <= (self i1 + self i2)
			ifTrue: [(1 to: object basicSize)
						collect: [:i | i printString]]
			ifFalse: [(1 to: self i1) , (object basicSize-(self i2-1) to: object basicSize)
						collect: [:i | i printString]])! !

!Inspector methodsFor: 'accessing'!
i1
	"This is the max index shown before skipping to the 
	last i2 elements of very long arrays"
	^ 100! !

!Inspector methodsFor: 'accessing'!
i2
	"This is the number of elements to show at the end
	of very long arrays"
	^ 10! !

!Inspector methodsFor: 'accessing' stamp: 'sw 5/22/96'!
initialExtent
	"Answer the desired extent for the receiver when it is first opened on the screen.  "

	^ 250 @ 200! !

!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
modelWakeUpIn: aWindow
	| newText |
	self updateListsAndCodeIn: aWindow.
	newText := self contentsIsString
		ifTrue: [newText := self selection]
		ifFalse: ["keep it short to reduce time to compute it"
			self selectionPrintString ].
	newText = contents ifFalse:
		[contents := newText.
		self changed: #contents]! !

!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
noteSelectionIndex: anInteger for: aSymbol
	aSymbol == #fieldList
		ifTrue:
			[selectionIndex := anInteger]! !

!Inspector methodsFor: 'accessing'!
object
	"Answer the object being inspected by the receiver."

	^object! !

!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
object: anObject 
	"Set anObject to be the object being inspected by the receiver."

	| oldIndex |
	anObject == object
		ifTrue: [self update]
		ifFalse:
			[oldIndex := selectionIndex <= 2 ifTrue: [selectionIndex] ifFalse: [0].
			self inspect: anObject.
			oldIndex := oldIndex min: self fieldList size.
			self changed: #inspectObject.
			oldIndex > 0
				ifTrue: [self toggleIndex: oldIndex].
			self changed: #fieldList.
			self changed: #contents]! !

!Inspector methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:37'!
selectedClass
	"Answer the class of the receiver's current selection"

	self selectionUnmodifiable ifTrue: [^ object class].
	^ self selection class! !

!Inspector methodsFor: 'accessing' stamp: 'sma 6/15/2000 16:48'!
stepTimeIn: aSystemWindow
	^ (selectionUpdateTime ifNil: [0]) * 10 max: 1000! !

!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
timeOfLastListUpdate
	^ timeOfLastListUpdate ifNil: [timeOfLastListUpdate := 0]! !

!Inspector methodsFor: 'accessing' stamp: 'tk 4/10/1998 11:28'!
trash
	"What goes in the bottom pane"
	^ ''! !

!Inspector methodsFor: 'accessing' stamp: 'tk 6/11/1998 22:23'!
trash: newText
	"Don't save it"
	^ true! !

!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
update
	"Reshow contents, assuming selected value may have changed."

	selectionIndex = 0
		ifFalse:
			[self contentsIsString
				ifTrue: [contents := self selection]
				ifFalse: [contents := self selectionPrintString].
			self changed: #contents.
			self changed: #selection.
			self changed: #selectionIndex]! !

!Inspector methodsFor: 'accessing' stamp: 'di 1/13/1999 14:36'!
wantsSteps
	^ true! !


!Inspector methodsFor: 'code'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a
	text selection."

	^object! !


!Inspector methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
initialize
	
	selectionIndex := 0.
	super initialize! !

!Inspector methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no current selection.
	
	Normally the receiver will be of the correct class (as defined by anObject inspectorClass),
	because it will have just been created by sedning inspect to anObject.   However, the
	debugger uses two embedded inspectors, which are re-targetted on the current receiver
	each time the stack frame changes.  The left-hand inspector in the debugger has its
	class changed by the code here.  Care should be taken if this method is overridden to
	ensure that the overriding code calls 'super inspect: anObject', or otherwise ensures that 
	the class of these embedded inspectors are changed back."

	| c |
	c := anObject inspectorClass.
	(self class ~= c and: [self class format = c format]) ifTrue: [
		self primitiveChangeClassTo: c basicNew].
	
	"Set 'object' before sending the initialize message, because some implementations
	of initialize (e.g., in DictionaryInspector) require 'object' to be non-nil."
	
	object := anObject. 
	self initialize! !


!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
addCollectionItemsTo: aMenu
	"If the current selection is an appropriate collection, add items to aMenu that cater to that kind of selection"

	| sel |
	((((sel := self selection) isMemberOf: Array) or: [sel isMemberOf: OrderedCollection]) and: 
		[sel size > 0]) ifTrue: [
			aMenu addList: #(
				('inspect element...'					inspectElement))].

	(sel isKindOf: MorphExtension) ifTrue: [
			aMenu addList: #(
				('inspect property...'				inspectElement))].! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
browseFullProtocol
	"Open up a protocol-category browser on the value of the receiver's current selection.  If in mvc, an old-style protocol browser is opened instead."

	| objectToRepresent |
	Smalltalk isMorphic ifFalse: [^ self spawnProtocol].

	objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
	InstanceBrowser new openOnObject: objectToRepresent inWorld: ActiveWorld showingSelector: nil! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
chasePointers
	| selected  saved |
	self selectionIndex == 0 ifTrue: [^ self changed: #flash].
	selected := self selection.
	saved := self object.
	[self object: nil.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [PointerFinder on: selected]
		ifFalse: [self inspectPointers]]
		ensure: [self object: saved]! !

!Inspector methodsFor: 'menu commands' stamp: 'tk 4/10/1998 17:53'!
classOfSelection
	"Answer the class of the receiver's current selection"

	self selectionUnmodifiable ifTrue: [^ object class].
	^ self selection class! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
classVarRefs
	"Request a browser of methods that store into a chosen instance variable"

	| aClass |
	(aClass := self classOfSelection) ifNotNil:
		[self systemNavigation  browseClassVarRefs: aClass].
! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
copyName
	"Copy the name of the current variable, so the user can paste it into the 
	window below and work with is. If collection, do (xxx at: 1)."
	| sel aClass variableNames |
	self selectionUnmodifiable
		ifTrue: [^ self changed: #flash].
	aClass := self object class.
	variableNames := aClass allInstVarNames.
	(aClass isVariable and: [selectionIndex > (variableNames size + 2)])
		ifTrue: [sel := '(self basicAt: ' , (selectionIndex - (variableNames size + 2)) asString , ')']
		ifFalse: [sel := variableNames at: selectionIndex - 2].
	(self selection isKindOf: Collection)
		ifTrue: [sel := '(' , sel , ' at: 1)'].
	Clipboard clipboardText: sel asText! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
defsOfSelection
	"Open a browser on all defining references to the selected instance variable, if that's what currently selected. "
	| aClass sel |

	self selectionUnmodifiable ifTrue: [^ self changed: #flash].
	(aClass := self object class) isVariable ifTrue: [^ self changed: #flash].

	sel := aClass allInstVarNames at: self selectionIndex - 2.
	self systemNavigation  browseAllStoresInto: sel from: aClass! !

!Inspector methodsFor: 'menu commands' stamp: 'avi 2/18/2004 01:31'!
explorePointers
	PointerExplorer new openExplorerFor: self selection! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 9/21/1999 12:16'!
exploreSelection

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	^ self selection explore! !

!Inspector methodsFor: 'menu commands' stamp: 'md 9/30/2004 16:42'!
fieldListMenu: aMenu
	"Arm the supplied menu with items for the field-list of the receiver"

	Smalltalk isMorphic ifTrue:
		[aMenu addStayUpItemSpecial].

	aMenu addList: #(
		('inspect (i)'						inspectSelection)
		('explore (I)'						exploreSelection)).

	self addCollectionItemsTo: aMenu.

	aMenu addList: #(
		-
		('method refs to this inst var'		referencesToSelection)
		('methods storing into this inst var'	defsOfSelection)
		('objects pointing to this value'		objectReferencesToSelection)
		('chase pointers'					chasePointers)
		('explore pointers'				explorePointers)
		-
		('browse full (b)'					browseMethodFull)
		('browse class'						browseClass)
		('browse hierarchy (h)'					classHierarchy)
		('browse protocol (p)'				browseFullProtocol)
		-
		('inst var refs...'					browseInstVarRefs)
		('inst var defs...'					browseInstVarDefs)
		('class var refs...'					classVarRefs)
		('class variables'					browseClassVariables)
		('class refs (N)'						browseClassRefs)
		-
		('copy name (c)'					copyName)		
		('basic inspect'						inspectBasic)).

	Smalltalk isMorphic ifTrue:
		[aMenu addList: #(
			-
			('tile for this value	(t)'			tearOffTile)
			('viewer for this value (v)'		viewerForValue))].

	^ aMenu


"			-
			('alias for this value'			aliasForValue)
			('watcher for this slot'			watcherForSlot)"

! !

!Inspector methodsFor: 'menu commands' stamp: 'tk 4/12/1998 08:49'!
inspectBasic
	"Bring up a non-special inspector"

	selectionIndex = 0 ifTrue: [^ object basicInspect].
	self selection basicInspect! !

!Inspector methodsFor: 'menu commands' stamp: 'rbb 3/1/2005 10:57'!
inspectElement
	| sel selSize countString count nameStrs |
	"Create and schedule an Inspector on an element of the receiver's model's currently selected collection."

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	((sel := self selection) isKindOf: SequenceableCollection) ifFalse:
		[(sel isKindOf: MorphExtension) ifTrue: [^ sel inspectElement].
		^ sel inspect].
	(selSize := sel size) == 1 ifTrue: [^ sel first inspect].
	selSize <= 20 ifTrue:
		[nameStrs := (1 to: selSize) asArray collect: [:ii | 
			ii printString, '   ', (((sel at: ii) printStringLimitedTo: 25) replaceAll: Character cr with: Character space)].
		count := UIManager default chooseFrom: (nameStrs substrings) title: 'which element?'.
		count = 0 ifTrue: [^ self].
		^ (sel at: count) inspect].

	countString := UIManager default request: 'Which element? (1 to ', selSize printString, ')' initialAnswer: '1'.
	countString isEmptyOrNil ifTrue: [^ self].
	count := Integer readFrom: (ReadStream on: countString).
	(count > 0 and: [count <= selSize])
		ifTrue: [(sel at: count) inspect]
		ifFalse: [Beeper beep]! !

!Inspector methodsFor: 'menu commands' stamp: 'apb 7/14/2004 13:16'!
inspectSelection
	"Create and schedule an Inspector on the receiver's model's currently selected object."

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	self selection inspect.
	^ self selection! !

!Inspector methodsFor: 'menu commands' stamp: 'rhi 5/27/2004 17:09'!
inspectorKey: aChar from: view
	"Respond to a Command key issued while the cursor is over my field list"

	aChar == $i ifTrue: [^ self selection inspect].
	aChar == $I ifTrue: [^ self selection explore].
	aChar == $b ifTrue:	[^ self browseMethodFull].
	aChar == $h ifTrue:	[^ self classHierarchy].
	aChar == $c ifTrue: [^ self copyName].
	aChar == $p ifTrue: [^ self browseFullProtocol].
	aChar == $N ifTrue: [^ self browseClassRefs].
	aChar == $t ifTrue: [^ self tearOffTile].
	aChar == $v ifTrue: [^ self viewerForValue].

	^ self arrowKey: aChar from: view! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 4/16/2003 11:41'!
objectReferencesToSelection
	"Open a list inspector on all the objects that point to the value of the selected instance variable, if any.  "

	self selectionIndex == 0 ifTrue: [^ self changed: #flash].
	self systemNavigation
		browseAllObjectReferencesTo: self selection
		except: (Array with: self object)
		ifNone: [:obj | self changed: #flash].
! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
referencesToSelection
	"Open a browser on all references to the selected instance variable, if that's what currently selected.  1/25/96 sw"
	| aClass sel |

	self selectionUnmodifiable ifTrue: [^ self changed: #flash].
	(aClass := self object class) isVariable ifTrue: [^ self changed: #flash].

	sel := aClass allInstVarNames at: self selectionIndex - 2.
	self systemNavigation   browseAllAccessesTo: sel from: aClass! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
spawnFullProtocol
	"Spawn a window showing full protocol for the receiver's selection"

	| objectToRepresent |
	objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
	ProtocolBrowser openFullProtocolForClass: objectToRepresent class! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
spawnProtocol
	"Spawn a protocol on browser on the receiver's selection"

	| objectToRepresent |
	objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
	ProtocolBrowser openSubProtocolForClass: objectToRepresent class! !

!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
viewerForValue
	"Open up a viewer on the value of the receiver's current selection"

	| objectToRepresent |
	objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
	objectToRepresent beViewed
	! !


!Inspector methodsFor: 'object fileIn' stamp: 'sd 11/20/2005 21:27'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	timeOfLastListUpdate ifNil: [timeOfLastListUpdate := 0].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!Inspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:45'!
accept: aString 
	| result |
	result := self doItReceiver class evaluatorClass new
				evaluate: (ReadStream on: aString)
				in: self doItContext
				to: self doItReceiver
				notifying: nil  "fix this"
				ifFail: [self changed: #flash.
					^ false].
	result == #failedDoit ifTrue: [^ false].
	self replaceSelectionValue: result.
	self changed: #contents.
	^ true! !

!Inspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:24'!
contentsIsString
	"Hacked so contents empty when deselected and = long printString when item 2"

	^ (selectionIndex = 2) | (selectionIndex = 0)! !

!Inspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'!
replaceSelectionValue: anObject 
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. The value of the selected variable is set to the value, 
	anObject."
	| basicIndex si |
	selectionIndex <= 2 ifTrue: [
		self toggleIndex: (si := selectionIndex).  
		self toggleIndex: si.
		^ object].
	object class isVariable
		ifFalse: [^ object instVarAt: selectionIndex - 2 put: anObject].
	basicIndex := selectionIndex - 2 - object class instSize.
	(object basicSize <= (self i1 + self i2)  or: [basicIndex <= self i1])
		ifTrue: [^object basicAt: basicIndex put: anObject]
		ifFalse: [^object basicAt: object basicSize - (self i1 + self i2) + basicIndex
					put: anObject]! !

!Inspector methodsFor: 'selecting' stamp: 'hg 10/8/2000 14:46'!
selectedSlotName

	^ self fieldList at: self selectionIndex! !

!Inspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'!
selection
	"The receiver has a list of variables of its inspected object.
	One of these is selected. Answer the value of the selected variable."
	| basicIndex |
	selectionIndex = 0 ifTrue: [^ ''].
	selectionIndex = 1 ifTrue: [^ object].
	selectionIndex = 2 ifTrue: [^ object longPrintStringLimitedTo: 20000].
	(selectionIndex - 2) <= object class instSize
		ifTrue: [^ object instVarAt: selectionIndex - 2].
	basicIndex := selectionIndex - 2 - object class instSize.
	(object basicSize <= (self i1 + self i2)  or: [basicIndex <= self i1])
		ifTrue: [^ object basicAt: basicIndex]
		ifFalse: [^ object basicAt: object basicSize - (self i1 + self i2) + basicIndex]! !

!Inspector methodsFor: 'selecting'!
selectionIndex
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. Answer the index into the list of the selected variable."

	^selectionIndex! !

!Inspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:03'!
selectionPrintString
	| text |
	selectionUpdateTime := [text := [self selection printStringLimitedTo: 5000]
						on: Error
						do: [text := self printStringErrorText.
							text
								addAttribute: TextColor red
								from: 1
								to: text size.
							text]] timeToRun.
	^ text! !

!Inspector methodsFor: 'selecting' stamp: 'PHK 6/30/2004 11:50'!
selectionUnmodifiable
	"Answer if the current selected variable is modifiable via acceptance in the code pane.  For most inspectors, no selection and a selection of 'self' (selectionIndex = 1) and 'all inst vars' (selectionIndex = 2) are unmodifiable"

	^ selectionIndex <= 2! !

!Inspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'!
toggleIndex: anInteger
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. If anInteger is the index of this variable, then deselect it. 
	Otherwise, make the variable whose index is anInteger be the selected 
	item."

	selectionUpdateTime := 0.
	selectionIndex = anInteger
		ifTrue: 
			["same index, turn off selection"
			selectionIndex := 0.
			contents := '']
		ifFalse:
			["different index, new selection"
			selectionIndex := anInteger.
			self contentsIsString
				ifTrue: [contents := self selection]
				ifFalse: [contents := self selectionPrintString]].
	self changed: #selection.
	self changed: #contents.
	self changed: #selectionIndex.! !


!Inspector methodsFor: 'stepping' stamp: 'sd 11/20/2005 21:27'!
stepAt: millisecondClockValue in: aWindow
	| newText |

	(Preferences smartUpdating and: [(millisecondClockValue - self timeOfLastListUpdate) > 8000]) "Not more often than once every 8 seconds"
		ifTrue:
			[self updateListsAndCodeIn: aWindow.
			timeOfLastListUpdate := millisecondClockValue].

	newText := self contentsIsString
		ifTrue: [self selection]
		ifFalse: ["keep it short to reduce time to compute it"
			self selectionPrintString ].
	newText = contents ifFalse:
		[contents := newText.
		self changed: #contents]! !


!Inspector methodsFor: '*eToys-menu commands' stamp: 'sw 10/23/2000 18:25'!
tearOffTile
	"Tear off a tile that refers to the receiver's selection, and place it in the mophic hand"

	| objectToRepresent |
	objectToRepresent _ self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
	self currentHand attachMorph: (TileMorph new referTo: objectToRepresent)
	! !


!Inspector methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
printStringErrorText
	| nm |
	nm := self selectionIndex < 3
					ifTrue: ['self']
					ifFalse: [self selectedSlotName].
	^ ('<error in printString: evaluate "' , nm , ' printString" to debug>') asText.! !

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

Inspector class
	instanceVariableNames: ''!

!Inspector class methodsFor: 'instance creation' stamp: 'sw 1/19/1999 14:38'!
horizontalDividerProportion
	^ 0.3! !

!Inspector class methodsFor: 'instance creation' stamp: 'PHK 7/22/2004 17:04'!
inspect: anObject 
	"Answer an instance of me to provide an inspector for anObject."
	
	"We call basicNew to avoid a premature initialization; the instance method 
	inspect: anObject will do a self initialize."

	^self basicNew inspect: anObject! !

!Inspector class methodsFor: 'instance creation' stamp: 'sw 9/23/1998 08:16'!
openAsMorphOn: anObject
	^ self openAsMorphOn: anObject withLabel: anObject defaultLabelForInspector! !

!Inspector class methodsFor: 'instance creation' stamp: 'apb 7/14/2004 12:54'!
openAsMorphOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass
	"Note: for now, this always adds an eval pane, and ignores the valueViewClass"

	^ (self openAsMorphOn: anObject withLabel: label) openInWorld! !

!Inspector class methodsFor: 'instance creation' stamp: 'wiz 2/25/2006 20:31'!
openAsMorphOn: anObject withLabel: aLabel 
	"(Inspector openAsMorphOn: SystemOrganization) openInMVC"
	| window inspector |
	inspector := self inspect: anObject.
	window := (SystemWindow labelled: aLabel)
				model: inspector.
	window
		addMorph: ((PluggableListMorph new doubleClickSelector: #inspectSelection;
				
				on: inspector
				list: #fieldList
				selected: #selectionIndex
				changeSelected: #toggleIndex:
				menu: #fieldListMenu:
				keystroke: #inspectorKey:from:) 
				autoDeselect: false )
				"For doubleClick to work best disable autoDeselect"
		frame: (0 @ 0 corner: self horizontalDividerProportion @ self verticalDividerProportion).
	window
		addMorph: (PluggableTextMorph
				on: inspector
				text: #contents
				accept: #accept:
				readSelection: #contentsSelection
				menu: #codePaneMenu:shifted:)
		frame: (self horizontalDividerProportion @ 0 corner: 1 @ self verticalDividerProportion).
	window
		addMorph: ((PluggableTextMorph
				on: inspector
				text: #trash
				accept: #trash:
				readSelection: #contentsSelection
				menu: #codePaneMenu:shifted:)
				askBeforeDiscardingEdits: false)
		frame: (0 @ self verticalDividerProportion corner: 1 @ 1).
	window setUpdatablePanesFrom: #(#fieldList ).
	window position: 16 @ 0.
	"Room for scroll bar."
	^ window! !

!Inspector class methodsFor: 'instance creation' stamp: 'ar 9/27/2005 18:30'!
openOn: anObject
	"Create and schedule an instance of me on the model, anInspector. "

	^ self openOn: anObject withEvalPane: true! !

!Inspector class methodsFor: 'instance creation'!
openOn: anObject withEvalPane: withEval 
	"Create and schedule an instance of me on the model, anInspector. "

	^ self openOn: anObject withEvalPane: withEval withLabel: anObject defaultLabelForInspector! !

!Inspector class methodsFor: 'instance creation' stamp: 'RAA 6/14/2000 18:20'!
openOn: anObject withEvalPane: withEval withLabel: label
        
        self couldOpenInMorphic ifTrue:
                [^ self openAsMorphOn: anObject withEvalPane: withEval
                        withLabel: label valueViewClass: nil].
        ^ self openOn: anObject 
                withEvalPane: withEval 
                withLabel: label 
                valueViewClass: PluggableTextView
! !

!Inspector class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
openOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass
	| topView inspector listView valueView evalView |
	inspector := self inspect: anObject.
	topView := StandardSystemView new model: inspector.
	topView borderWidth: 1.

	listView := PluggableListView on: inspector
		list: #fieldList
		selected: #selectionIndex
		changeSelected: #toggleIndex:
		menu: #fieldListMenu:
		keystroke: #inspectorKey:from:.
	listView window: (0 @ 0 extent: 40 @ 40).
	topView addSubView: listView.

	valueView := valueViewClass new.
		"PluggableTextView or PluggableFormView"
	(valueView respondsTo: #getText) ifTrue: [
		valueView on: inspector 
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:].
	(valueViewClass inheritsFrom: FormView) ifTrue: [
		valueView model: inspector].
	valueView window: (0 @ 0 extent: 75 @ 40).
	topView addSubView: valueView toRightOf: listView.
	
	withEval ifTrue:
		[evalView := PluggableTextView new on: inspector 
			text: #trash accept: #trash:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
		evalView window: (0 @ 0 extent: 115 @ 20).
		evalView askBeforeDiscardingEdits: false.
		topView addSubView: evalView below: listView].
	topView label: label.
	topView minimumSize: 180 @ 120.
	topView setUpdatablePanesFrom: #(fieldList).
	topView controller open! !

!Inspector class methodsFor: 'instance creation' stamp: 'sw 1/19/1999 14:38'!
verticalDividerProportion
	^ 0.7! !
Inspector subclass: #InspectorBrowser
	instanceVariableNames: 'fieldList msgList msgListIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
fieldList
	fieldList ifNotNil: [^ fieldList].
	^ (fieldList := super fieldList)! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
msgAccept: newText from: editor
	| category |
	category := msgListIndex = 0
		ifTrue: [ClassOrganizer default]
		ifFalse: [object class organization categoryOfElement: (msgList at: msgListIndex)].
	^ (object class compile: newText classified: category notifying: editor) ~~ nil! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 14:18'!
msgListIndex 
	^msgListIndex! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
msgListIndex: anInteger
	"A selection has been made in the message pane"

	msgListIndex := anInteger.
	self changed: #msgText.! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/20/1998 07:44'!
msgPaneMenu: aMenu shifted: shifted
	^ aMenu labels: 
'find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
do it (d)
print it (p)
inspect it (i)
accept (s)
cancel (l)' 
		lines: #(0 3 5 8 11)
		selections: #(find findAgain setSearchString again undo copySelection cut paste doIt printIt inspectIt accept cancel)! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 14:38'!
msgText
	msgListIndex = 0 ifTrue: [^ nil].
	^ object class sourceCodeAt: (msgList at: msgListIndex)! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
step
	| list fieldString msg |
	(list := super fieldList) = fieldList ifFalse:
		[fieldString := selectionIndex > 0 ifTrue: [fieldList at: selectionIndex] ifFalse: [nil].
		fieldList := list.
		selectionIndex := fieldList indexOf: fieldString ifAbsent: [0].
		self changed: #fieldList.
		self changed: #selectionIndex].
	list := msgList.  msgList := nil.  "force recomputation"
		list = self msgList ifFalse:
		[msg := msgListIndex > 0 ifTrue: [list at: msgListIndex] ifFalse: [nil].
		msgListIndex := msgList indexOf: msg ifAbsent: [0].
		self changed: #msgList.
		self changed: #msgListIndex].
	super step! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 1/14/1999 09:01'!
wantsSteps
	^ true! !


!InspectorBrowser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
initialize

	super initialize.
	fieldList := nil.
	msgListIndex := 0.
	self changed: #msgText
! !

!InspectorBrowser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no current selection.
	Overriden so that my class is not changed to 'anObject inspectorClass'."
	
	object := anObject.
	self initialize
! !


!InspectorBrowser methodsFor: 'messages' stamp: 'sd 11/20/2005 21:27'!
msgList
	msgList ifNotNil: [^ msgList].
	^ (msgList := object class selectors asSortedArray)! !

!InspectorBrowser methodsFor: 'messages' stamp: 'apb 7/14/2004 13:57'!
msgListMenu: aMenu 
	^ aMenu labels: 'Not yet implemented' lines: #(0) selections: #(flash)! !

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

InspectorBrowser class
	instanceVariableNames: ''!

!InspectorBrowser class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'!
openAsMorphOn: anObject
	"(InspectorBrowser openAsMorphOn: SystemOrganization) openInMVC"
	| window inspector |
	inspector := self inspect: anObject.
	window := (SystemWindow labelled: anObject defaultLabelForInspector)
				model: inspector.

	window addMorph: (PluggableListMorph on: inspector list: #fieldList
				selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu:)
		frame: (0@0 corner: 0.3@0.5).
	window addMorph: (PluggableTextMorph on: inspector text: #contents accept: #accept:
				readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0.3@0 corner: 1.0@0.5).
	window addMorph: (PluggableListMorph on: inspector list: #msgList
				selected: #msgListIndex changeSelected: #msgListIndex: menu: #msgListMenu:)
		frame: (0@0.5 corner: 0.3@1.0).
	window addMorph: (PluggableTextMorph on: inspector text: #msgText accept: #msgAccept:from:
				readSelection: nil menu: #msgPaneMenu:shifted:)
		frame: (0.3@0.5 corner: 1.0@1.0).
	
	window setUpdatablePanesFrom: #(fieldList msgList).
	window position: 16@0.  "Room for scroll bar."
	^ window! !
InstructionClient subclass: #InstVarRefLocator
	instanceVariableNames: 'bingo'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!InstVarRefLocator commentStamp: 'md 4/8/2003 12:50' prior: 0!
My job is to scan bytecodes for instance variable references.

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


!InstVarRefLocator methodsFor: 'initialize-release' stamp: 'md 4/8/2003 11:35'!
interpretNextInstructionUsing: aScanner 
	
	bingo _ false.
	aScanner interpretNextInstructionFor: self.
	^bingo! !


!InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'!
popIntoReceiverVariable: offset 

	bingo _ true! !

!InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'!
pushReceiverVariable: offset

	bingo _ true! !

!InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'!
storeIntoReceiverVariable: offset 

	bingo _ true! !

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

InstVarRefLocator class
	instanceVariableNames: ''!
TestCase subclass: #InstVarRefLocatorTest
	instanceVariableNames: 'tt'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Methods'!
!InstVarRefLocatorTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class InstVarRefLocator. 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!


!InstVarRefLocatorTest methodsFor: 'examples' stamp: 'sd 6/5/2005 08:27'!
example1
	| ff |
	(1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']].
	^ ff.! !

!InstVarRefLocatorTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:31'!
example2
	| ff|	
	ff := 1.
	(1 < 2) ifTrue: [ff ifNotNil: [ff _ 'hallo']].
	^ ff.! !


!InstVarRefLocatorTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:42'!
testExample1
	| method |

	method := self class compiledMethodAt: #example1.
	self assert: (self hasInstVarRef: method).! !

!InstVarRefLocatorTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:42'!
testExample2
	| method |

	method := self class compiledMethodAt: #example2.
	self deny: (self hasInstVarRef: method).! !

!InstVarRefLocatorTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:35'!
testInstructions

	| scanner end printer methods |

	methods := Object methodDict values. 

	methods do: [:method |
		scanner _ InstructionStream on: method.
		printer _ InstVarRefLocator new.
		end _ scanner method endPC.

		[scanner pc <= end] whileTrue: [
			self shouldnt: [printer interpretNextInstructionUsing: scanner] raise: Error.
		].
	].! !


!InstVarRefLocatorTest methodsFor: 'private' stamp: 'md 4/8/2003 12:39'!
hasInstVarRef: aMethod
	"Answer whether the receiver references an instance variable."

	| scanner end printer |

	scanner _ InstructionStream on: aMethod.
	printer _ InstVarRefLocator new.
	end _ scanner method endPC.

	[scanner pc <= end] whileTrue: [
		(printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
	].
	^false! !
Lexicon subclass: #InstanceBrowser
	instanceVariableNames: 'objectViewed'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Protocols'!

!InstanceBrowser methodsFor: 'initialization' stamp: 'sw 5/25/2001 10:47'!
desiredWindowLabelHeightIn: aSystemWindow
	"Answer the desired window label height.  To be exploited in due course"

	self flag: #deferred.  "For tweaking appearance in due course"
	^ nil! !

!InstanceBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
openOnObject: anObject inWorld: aWorld showingSelector: aSelector
	"Create and open a SystemWindow to house the receiver, showing the categories pane."

	objectViewed := anObject.
	self openOnClass: anObject class inWorld: aWorld showingSelector: aSelector! !

!InstanceBrowser methodsFor: 'initialization' stamp: 'wiz 1/18/2006 15:39'!
windowWithLabel: aLabel
	"Answer a SystemWindow associated with the receiver," 

	^ (SystemWindow labelled: aLabel) model: self
! !


!InstanceBrowser methodsFor: 'menu commands' stamp: 'sw 3/20/2001 13:20'!
inspectViewee
	"Open an Inspector on the object I view"

	objectViewed inspect! !

!InstanceBrowser methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
offerMenu
	"Offer a menu to the user, in response to the hitting of the menu button on the tool pane"

	| aMenu |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu title: 'Messages of ', objectViewed nameForViewer.
	aMenu addStayUpItem.
	aMenu addList: #(
		('vocabulary...' 			chooseVocabulary)
		('what to show...'			offerWhatToShowMenu)
		-
		('inst var refs (here)'		setLocalInstVarRefs)
		('inst var defs (here)'		setLocalInstVarDefs)
		('class var refs (here)'		setLocalClassVarRefs)
		-

		('navigate to a sender...' 	navigateToASender)
		('recent...' 					navigateToRecentMethod)
		('show methods in current change set'
									showMethodsInCurrentChangeSet)
		('show methods with initials...'
									showMethodsWithInitials)
		-
		"('toggle search pane' 		toggleSearch)"

		-
		-
		('browse full (b)' 			browseMethodFull)
		('browse hierarchy (h)'		classHierarchy)
		('browse method (O)'		openSingleMessageBrowser)
		('browse protocol (p)'		browseFullProtocol)
		-
		('fileOut'					fileOutMessage)
		('printOut'					printOutMessage)
		-
		('senders of... (n)'			browseSendersOfMessages)
		('implementors of... (m)'		browseMessages)
		('versions (v)' 				browseVersions)
		('inheritance (i)'			methodHierarchy)
		-
		('inst var refs' 				browseInstVarRefs)
		('inst var defs' 				browseInstVarDefs)
		('class var refs' 			browseClassVarRefs)
		-
		('viewer on me'				viewViewee)
		('inspector on me'			inspectViewee)
		-
		('more...'					shiftedYellowButtonActivity)).

	aMenu popUpInWorld: ActiveWorld! !

!InstanceBrowser methodsFor: 'menu commands' stamp: 'sw 3/20/2001 13:19'!
viewViewee
	"Open a viewer on the object I view"

	objectViewed beViewed! !


!InstanceBrowser methodsFor: 'target-object access' stamp: 'sw 3/20/2001 12:10'!
targetObject
	"Answer the object to which this tool is bound"

	^ objectViewed! !


!InstanceBrowser methodsFor: 'window title' stamp: 'sw 3/20/2001 12:18'!
startingWindowTitle
	"Answer the initial window title to apply"

	^ 'Vocabulary of ', objectViewed nameForViewer! !

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

InstanceBrowser class
	instanceVariableNames: ''!

!InstanceBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:31'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Instance Browser' brightColor: #(0.806 1.0 1.0) pastelColor: #(0.925 1.000 1.0) helpMessage: 'A tool for browsing the full protocol of an instance.'! !
Object subclass: #InstructionClient
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!InstructionClient commentStamp: 'md 4/8/2003 12:50' prior: 0!
My job is to make it easier to implement clients for InstructionStream. See InstVarRefLocator
as an example. !


!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'!
blockReturnTop
	"Return Top Of Stack bytecode."

! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'!
doDup
	"Duplicate Top Of Stack bytecode."

! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'!
doPop
	"Remove Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'!
jump: offset
	"Unconditional Jump bytecode."

! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'!
jump: offset if: condition 
	"Conditional Jump bytecode."

! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'!
methodReturnConstant: value 
	"Return Constant bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'!
methodReturnReceiver
	"Return Self bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
methodReturnTop
	"Return Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
popIntoLiteralVariable: anAssociation 
	"Remove Top Of Stack And Store Into Literal Variable bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
popIntoReceiverVariable: offset 
	"Remove Top Of Stack And Store Into Instance Variable bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
popIntoTemporaryVariable: offset 
	"Remove Top Of Stack And Store Into Temporary Variable bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
pushActiveContext
	"Push Active Context On Top Of Its Own Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
pushConstant: value
	"Push Constant, value, on Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
pushLiteralVariable: anAssociation
	"Push Contents Of anAssociation On Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
pushReceiver
	"Push Active Context's Receiver on Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'!
pushReceiverVariable: offset
	"Push Contents Of the Receiver's Instance Variable Whose Index 
	is the argument, offset, On Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'!
pushTemporaryVariable: offset
	"Push Contents Of Temporary Variable Whose Index Is the 
	argument, offset, On Top Of Stack bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'!
send: selector super: supered numArgs: numberArguments
	"Send Message With Selector, selector, bytecode. The argument, 
	supered, indicates whether the receiver of the message is specified with 
	'super' in the source method. The arguments of the message are found in 
	the top numArguments locations on the stack and the receiver just 
	below them."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'!
storeIntoLiteralVariable: anAssociation 
	"Store Top Of Stack Into Literal Variable Of Method bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'!
storeIntoReceiverVariable: offset 
	"Store Top Of Stack Into Instance Variable Of Method bytecode."
! !

!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'!
storeIntoTemporaryVariable: offset 
	"Store Top Of Stack Into Temporary Variable Of Method bytecode."
! !

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

InstructionClient class
	instanceVariableNames: ''!
TestCase subclass: #InstructionClientTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Methods'!
!InstructionClientTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class InstructionClient. 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!


!InstructionClientTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:07'!
testInstructions
	"just interpret all of methods of Object"

	| methods client scanner|
	
	methods := Object methodDict values. 
	client := InstructionClient new.	

	methods do: [:method |
			scanner := (InstructionStream on: method).
			[scanner pc <= method endPC] whileTrue: [
					self shouldnt: [scanner interpretNextInstructionFor: client] raise: Error.
			].
	].
! !
InstructionClient subclass: #InstructionPrinter
	instanceVariableNames: 'method scanner stream oldPC indent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!InstructionPrinter commentStamp: 'md 4/8/2003 12:47' prior: 0!
My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The variable method  is used to hold the method being printed.!


!InstructionPrinter methodsFor: 'accessing' stamp: 'ajh 6/27/2003 22:25'!
indent

	^ indent ifNil: [0]! !

!InstructionPrinter methodsFor: 'accessing' stamp: 'md 4/8/2003 11:20'!
method
	^method.! !

!InstructionPrinter methodsFor: 'accessing' stamp: 'md 4/8/2003 11:20'!
method: aMethod
	method :=  aMethod.! !


!InstructionPrinter methodsFor: 'initialize-release' stamp: 'ajh 2/9/2003 14:16'!
indent: numTabs

	indent _ numTabs! !

!InstructionPrinter methodsFor: 'initialize-release' stamp: 'md 4/8/2003 11:19'!
printInstructionsOn: aStream 
	"Append to the stream, aStream, a description of each bytecode in the 
	instruction stream."
	
	| end |
	stream _ aStream.
	scanner _ InstructionStream on: method.
	end _ method endPC.
	oldPC _ scanner pc.
	[scanner pc <= end]
		whileTrue: [scanner interpretNextInstructionFor: self]! !


!InstructionPrinter methodsFor: 'instruction decoding'!
blockReturnTop
	"Print the Return Top Of Stack bytecode."

	self print: 'blockReturn'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
doDup
	"Print the Duplicate Top Of Stack bytecode."

	self print: 'dup'! !

!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 12:14'!
doPop
	"Print the Remove Top Of Stack bytecode."

	self print: 'pop'! !

!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 11:13'!
jump: offset
	"Print the Unconditional Jump bytecode."

	self print: 'jumpTo: ' , (scanner pc + offset) printString! !

!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 11:13'!
jump: offset if: condition 
	"Print the Conditional Jump bytecode."

	self print: 
		(condition
			ifTrue: ['jumpTrue: ']
			ifFalse: ['jumpFalse: '])
			, (scanner pc + offset) printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
methodReturnConstant: value 
	"Print the Return Constant bytecode."

	self print: 'return: ' , value printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
methodReturnReceiver
	"Print the Return Self bytecode."

	self print: 'returnSelf'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
methodReturnTop
	"Print the Return Top Of Stack bytecode."

	self print: 'returnTop'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
popIntoLiteralVariable: anAssociation 
	"Print the Remove Top Of Stack And Store Into Literal Variable bytecode."

	self print: 'popIntoLit: ' , anAssociation key! !

!InstructionPrinter methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset 
	"Print the Remove Top Of Stack And Store Into Instance Variable 
	bytecode."

	self print: 'popIntoRcvr: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset 
	"Print the Remove Top Of Stack And Store Into Temporary Variable 
	bytecode."

	self print: 'popIntoTemp: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushActiveContext
	"Print the Push Active Context On Top Of Its Own Stack bytecode."

	self print: 'pushThisContext: '! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushLiteralVariable: anAssociation
	"Print the Push Contents Of anAssociation On Top Of Stack bytecode."

	self print: 'pushLit: ' , anAssociation key! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushReceiver
	"Print the Push Active Context's Receiver on Top Of Stack bytecode."

	self print: 'self'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushReceiverVariable: offset
	"Print the Push Contents Of the Receiver's Instance Variable Whose Index 
	is the argument, offset, On Top Of Stack bytecode."

	self print: 'pushRcvr: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushTemporaryVariable: offset
	"Print the Push Contents Of Temporary Variable Whose Index Is the 
	argument, offset, On Top Of Stack bytecode."

	self print: 'pushTemp: ' , offset printString! !

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

	self print: (supered ifTrue: ['superSend: '] ifFalse: ['send: ']) , selector! !

!InstructionPrinter methodsFor: 'instruction decoding'!
storeIntoLiteralVariable: anAssociation 
	"Print the Store Top Of Stack Into Literal Variable Of Method bytecode."

	self print: 'storeIntoLit: ' , anAssociation key! !

!InstructionPrinter methodsFor: 'instruction decoding'!
storeIntoReceiverVariable: offset 
	"Print the Store Top Of Stack Into Instance Variable Of Method bytecode."

	self print: 'storeIntoRcvr: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
storeIntoTemporaryVariable: offset 
	"Print the Store Top Of Stack Into Temporary Variable Of Method 
	bytecode."

	self print: 'storeIntoTemp: ' , offset printString! !


!InstructionPrinter methodsFor: 'printing' stamp: 'laza 3/29/2004 18:45'!
print: instruction 
	"Append to the receiver a description of the bytecode, instruction." 

	| code |
	stream tab: self indent; print: oldPC; space.
	stream nextPut: $<.
	oldPC to: scanner pc - 1 do: 
		[:i | 
		code _ (method at: i) radix: 16.
		stream nextPut: 
			(code size < 2
				ifTrue: [$0]
				ifFalse: [code at: 1]).
		stream nextPut: code last; space].
	stream skip: -1.
	stream nextPut: $>.
	stream space.
	stream nextPutAll: instruction.
	stream cr.
	oldPC _ scanner pc.
	"(InstructionPrinter compiledMethodAt: #print:) symbolic."
! !

!InstructionPrinter methodsFor: 'printing' stamp: 'ajh 6/27/2003 22:26'!
pushConstant: obj
	"Print the Push Constant, obj, on Top Of Stack bytecode."

	self print: 'pushConstant: ' , (String streamContents: [:s |
		(obj isKindOf: LookupKey)
			ifFalse: [s withStyleFor: #literal do: [obj printOn: s]]
			ifTrue: [obj key
				ifNotNil: [s nextPutAll: '##'; nextPutAll: obj key]
				ifNil: [s nextPutAll: '###'; nextPutAll: obj value soleInstance name]]
	]).

	(obj isKindOf: CompiledMethod) ifTrue: [
		obj longPrintOn: stream indent: self indent + 2. ^ self].
	Smalltalk at: #BlockClosure ifPresent:[:aClass|
		(obj isKindOf: aClass) ifTrue: [
			obj method longPrintOn: stream indent: self indent + 2. ^ self]].! !

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

InstructionPrinter class
	instanceVariableNames: ''!

!InstructionPrinter class methodsFor: 'printing' stamp: 'md 4/8/2003 11:19'!
on: aMethod
	^self new method: aMethod.
	! !

!InstructionPrinter class methodsFor: 'printing'!
printClass: class 
	"Create a file whose name is the argument followed by '.bytes'. Store on 
	the file the symbolic form of the compiled methods of the class."
	| file |
	file _ FileStream newFileNamed: class name , '.bytes'.
	class selectors do: 
		[:sel | 
		file cr; nextPutAll: sel; cr.
		(self on: (class compiledMethodAt: sel)) printInstructionsOn: file].
	file close
	"InstructionPrinter printClass: Parser."
! !
ClassTestCase subclass: #InstructionPrinterTest
	instanceVariableNames: 'tt'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Methods'!
!InstructionPrinterTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class InstructionPrinter. 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!


!InstructionPrinterTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:28'!
example1
	| ff|
	(1 < 2) ifTrue: [tt ifNotNil: [ff _ 'hallo']].
	^ ff.! !


!InstructionPrinterTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:13'!
testInstructions
	"just print all of methods of Object and see if no error accours"

	| methods printer  |
	
	methods := Object methodDict values. 
	printer  := InstructionPrinter.	

	methods do: [:method |
					self shouldnt: [ 
						String streamContents: [:stream | 
							(printer on: method) printInstructionsOn: stream]] raise: Error.
			].
! !
Object subclass: #InstructionStream
	instanceVariableNames: 'sender pc'
	classVariableNames: 'SpecialConstants'
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!InstructionStream commentStamp: '<historical>' prior: 0!
My instances can interpret the byte-encoded Smalltalk instruction set. They maintain a program counter (pc) for streaming through CompiledMethods. My subclasses are Contexts, which inherit this capability. They store the return pointer in the instance variable sender, and the current position in their method in the instance variable pc. For other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function.!


!InstructionStream methodsFor: 'decoding' stamp: 'ajh 7/29/2001 20:45'!
atEnd

	^ pc > self method endPC! !

!InstructionStream methodsFor: 'decoding' stamp: 'ajh 3/2/2003 14:06'!
interpret

	[self atEnd] whileFalse: [self interpretNextInstructionFor: self]! !

!InstructionStream methodsFor: 'decoding'!
interpretJump

	| byte |
	byte _ self method at: pc.
	(byte between: 144 and: 151) ifTrue:
		[pc _ pc + 1. ^byte - 143].
	(byte between: 160 and: 167) ifTrue:
		[pc _ pc + 2. ^(byte - 164) * 256 + (self method at: pc - 1)].
	^nil! !

!InstructionStream methodsFor: 'decoding' stamp: 'md 1/20/2006 17:19'!
interpretNextInstructionFor: client 
	"Send to the argument, client, a message that specifies the type of the 
	next instruction."

	| byte type offset method |
	method := self method.  
	byte := method at: pc.
	type := byte // 16.  
	offset := byte \\ 16.  
	pc := pc+1.
	"We do an inline binary search on each of the possible 16 values of type:
	The old, cleaner but slowe code is retained as a comment below"
	type < 8
	ifTrue: [type < 4
				ifTrue: [type < 2
						ifTrue: [type < 1
								ifTrue: ["type = 0"
									^ client pushReceiverVariable: offset]
								ifFalse: ["type = 1"
									^ client pushTemporaryVariable: offset]]
						ifFalse: [type < 3
								ifTrue: ["type = 2"
									^ client
										pushConstant: (method literalAt: offset + 1)]
								ifFalse: ["type = 3"
									^ client
										pushConstant: (method literalAt: offset + 17)]]]
				ifFalse: [type < 6
						ifTrue: [type < 5
								ifTrue: ["type = 4"
									^ client
										pushLiteralVariable: (method literalAt: offset + 1)]
								ifFalse: ["type = 5"
									^ client
										pushLiteralVariable: (method literalAt: offset + 17)]]
						ifFalse: [type < 7
								ifTrue: ["type = 6"
									offset < 8
										ifTrue: [^ client popIntoReceiverVariable: offset]
										ifFalse: [^ client popIntoTemporaryVariable: offset - 8]]
								ifFalse: ["type = 7"
									offset = 0
										ifTrue: [^ client pushReceiver].
									offset < 8
										ifTrue: [^ client
												pushConstant: (SpecialConstants at: offset)].
									offset = 8
										ifTrue: [^ client methodReturnReceiver].
									offset < 12
										ifTrue: [^ client
												methodReturnConstant: (SpecialConstants at: offset - 8)].
									offset = 12
										ifTrue: [^ client methodReturnTop].
									offset = 13
										ifTrue: [^ client blockReturnTop].
									offset > 13
										ifTrue: [^ self error: 'unusedBytecode']]]]]
		ifFalse: [type < 12
				ifTrue: [type < 10
						ifTrue: [type < 9
								ifTrue: ["type = 8"
									^ self
										interpretExtension: offset
										in: method
										for: client]
								ifFalse: ["type = 9 (short jumps)"
									offset < 8
										ifTrue: [^ client jump: offset + 1].
									^ client jump: offset - 8 + 1 if: false]]
						ifFalse: [type < 11
								ifTrue: ["type = 10 (long jumps)"
									byte := method at: pc.
									pc := pc + 1.
									offset < 8
										ifTrue: [^ client jump: offset - 4 * 256 + byte].
									^ client jump: (offset bitAnd: 3)
											* 256 + byte if: offset < 12]
								ifFalse: ["type = 11"
									^ client
										send: (Smalltalk specialSelectorAt: offset + 1)
										super: false
										numArgs: (Smalltalk specialNargsAt: offset + 1)]]]
				ifFalse: [type = 12
						ifTrue: [^ client
								send: (Smalltalk specialSelectorAt: offset + 17)
								super: false
								numArgs: (Smalltalk specialNargsAt: offset + 17)]
						ifFalse: ["type = 13, 14 or 15"
							^ client
								send: (method literalAt: offset + 1)
								super: false
								numArgs: type - 13]]].


"    old code 
	type=0 ifTrue: [^client pushReceiverVariable: offset].
	type=1 ifTrue: [^client pushTemporaryVariable: offset].
	type=2 ifTrue: [^client pushConstant: (method literalAt: offset+1)].
	type=3 ifTrue: [^client pushConstant: (method literalAt: offset+17)].
	type=4 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+1)].
	type=5 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+17)].
	type=6 
		ifTrue: [offset<8
					ifTrue: [^client popIntoReceiverVariable: offset]
					ifFalse: [^client popIntoTemporaryVariable: offset-8]].
	type=7
		ifTrue: [offset=0 ifTrue: [^client pushReceiver].
				offset<8 ifTrue: [^client pushConstant: (SpecialConstants at: offset)].
				offset=8 ifTrue: [^client methodReturnReceiver].
				offset<12 ifTrue: [^client methodReturnConstant: 
												(SpecialConstants at: offset-8)].
				offset=12 ifTrue: [^client methodReturnTop].
				offset=13 ifTrue: [^client blockReturnTop].
				offset>13 ifTrue: [^self error: 'unusedBytecode']].
	type=8 ifTrue: [^self interpretExtension: offset in: method for: client].
	type=9
		ifTrue:  short jumps
			[offset<8 ifTrue: [^client jump: offset+1].
			^client jump: offset-8+1 if: false].
	type=10 
		ifTrue:  long jumps
			[byte:= method at: pc.  pc:= pc+1.
			offset<8 ifTrue: [^client jump: offset-4*256 + byte].
			^client jump: (offset bitAnd: 3)*256 + byte if: offset<12].
	type=11 
		ifTrue: 
			[^client 
				send: (Smalltalk specialSelectorAt: offset+1) 
				super: false
				numArgs: (Smalltalk specialNargsAt: offset+1)].
	type=12 
		ifTrue: 
			[^client 
				send: (Smalltalk specialSelectorAt: offset+17) 
				super: false
				numArgs: (Smalltalk specialNargsAt: offset+17)].
	type>12
		ifTrue: 
			[^client send: (method literalAt: offset+1) 
					super: false
					numArgs: type-13]"! !


!InstructionStream methodsFor: 'scanning'!
addSelectorTo: set 
	"If this instruction is a send, add its selector to set."

	| byte literalNumber byte2 |
	byte _ self method at: pc.
	byte < 128 ifTrue: [^self].
	byte >= 176
		ifTrue: 
			["special byte or short send"
			byte >= 208
				ifTrue: [set add: (self method literalAt: (byte bitAnd: 15) + 1)]
				ifFalse: [set add: (Smalltalk specialSelectorAt: byte - 176 + 1)]]
		ifFalse: 
			[(byte between: 131 and: 134)
				ifTrue: 
					[byte2 _ self method at: pc + 1.
					byte = 131 ifTrue: [set add: (self method literalAt: byte2 \\ 32 + 1)].
					byte = 132 ifTrue: [byte2 < 64 ifTrue: [set add: (self method literalAt: (self method at: pc + 2) + 1)]].
					byte = 133 ifTrue: [set add: (self method literalAt: byte2 \\ 32 + 1)].
					byte = 134 ifTrue: [set add: (self method literalAt: byte2 \\ 64 + 1)]]]! !

!InstructionStream methodsFor: 'scanning'!
followingByte
	"Answer the next bytecode."

	^self method at: pc + 1! !

!InstructionStream methodsFor: 'scanning'!
method
	"Answer the compiled method that supplies the receiver's bytecodes."

	^sender		"method access when used alone (not as part of a context)"! !

!InstructionStream methodsFor: 'scanning'!
nextByte
	"Answer the next bytecode."

	^self method at: pc! !

!InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:32'!
nextInstruction
	"Return the next bytecode instruction as a message that an InstructionClient would understand.  This advances the pc by one instruction."

	^ self interpretNextInstructionFor: MessageCatcher new! !

!InstructionStream methodsFor: 'scanning'!
pc
	"Answer the index of the next bytecode."

	^pc! !

!InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:36'!
peekInstruction
	"Return the next bytecode instruction as a message that an InstructionClient would understand.  The pc remains unchanged."

	| currentPc instr |
	currentPc _ self pc.
	instr _ self nextInstruction.
	self pc: currentPc.
	^ instr! !

!InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:29'!
previousPc

	| currentPc dummy prevPc |
	currentPc _ pc.
	pc _ self method initialPC.
	dummy _ MessageCatcher new.
	[pc = currentPc] whileFalse: [
		prevPc _ pc.
		self interpretNextInstructionFor: dummy.
	].
	^ prevPc! !

!InstructionStream methodsFor: 'scanning'!
scanFor: scanBlock 
	"Answer the index of the first bytecode for which scanBlock answer true 
	when supplied with that bytecode."

	| method end byte type |
	method _ self method.
	end _ method endPC.
	[pc <= end]
		whileTrue: 
			[(scanBlock value: (byte _ method at: pc)) ifTrue: [^true].
			type _ byte // 16.
			pc _ 
				type = 8
					ifTrue: ["extensions"
							pc + (#(2 2 2 2 3 2 2 1 1 1 ) at: byte \\ 16 + 1)]
					ifFalse: [type = 10
								ifTrue: [pc + 2"long jumps"]
								ifFalse: [pc + 1]]].
	^false! !

!InstructionStream methodsFor: 'scanning' stamp: 'hmm 7/29/2001 21:25'!
skipBackBeforeJump
	"Assuming that the receiver is positioned jast after a jump, skip back one or two bytes, depending on the size of the previous jump instruction."
	| strm short |
	strm _ InstructionStream on: self method.
	(strm scanFor: [:byte |
		((short _ byte between: 152 and: 159) or: [byte between: 168 and: 175])
			and: [strm pc = (short ifTrue: [pc-1] ifFalse: [pc-2])]]) ifFalse: [self error: 'Where''s the jump??'].
	self jump: (short ifTrue: [-1] ifFalse: [-2]).
! !

!InstructionStream methodsFor: 'scanning'!
thirdByte
	"Answer the next bytecode."

	^self method at: pc + 2! !


!InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 11:34'!
willBlockReturn

	^ (self method at: pc) = Encoder blockReturnCode! !

!InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 11:10'!
willJump
	"unconditionally"

	| byte |
	byte _ self method at: pc.
	^ (byte between: 144 and: 151) or: [byte between: 160 and: 167]! !

!InstructionStream methodsFor: 'testing'!
willJumpIfFalse
	"Answer whether the next bytecode is a jump-if-false."

	| byte |
	byte _ self method at: pc.
	^(byte between: 152 and: 159) or: [byte between: 172 and: 175]! !

!InstructionStream methodsFor: 'testing' stamp: 'di 1/29/2000 14:42'!
willJumpIfTrue 
	"Answer whether the next bytecode is a jump-if-true."
 
	| byte |
	byte _ self method at: pc.
	^ byte between: 168 and: 171! !

!InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 17:32'!
willJustPop

	^ (self method at: pc) = Encoder popCode! !

!InstructionStream methodsFor: 'testing' stamp: 'sn 8/22/97 21:55'!
willReallySend
	"Answer whether the next bytecode is a real message-send,
	not blockCopy:."

	| byte |
	byte _ self method at: pc.
	byte < 128 ifTrue: [^false].
	byte == 200 ifTrue: [^false].
	byte >= 176 ifTrue: [^true].	"special send or short send"
	^byte between: 131 and: 134	"long sends"! !

!InstructionStream methodsFor: 'testing'!
willReturn
	"Answer whether the next bytecode is a return."

	^(self method at: pc) between: 120 and: 125! !

!InstructionStream methodsFor: 'testing'!
willSend
	"Answer whether the next bytecode is a message-send."

	| byte |
	byte _ self method at: pc.
	byte < 128 ifTrue: [^false].
	byte >= 176 ifTrue: [^true].	"special send or short send"
	^byte between: 131 and: 134	"long sends"! !

!InstructionStream methodsFor: 'testing' stamp: 'hmm 7/15/2001 22:00'!
willStore
	"Answer whether the next bytecode is a store or store-pop"

	| byte |
	byte _ self method at: pc.
	^(byte between: 96 and: 132) and: [
		byte <= 111 or: [byte >= 129 and: [
			byte <= 130 or: [byte = 132 and: [
				(self method at: pc+1) >= 160]]]]]! !

!InstructionStream methodsFor: 'testing'!
willStorePop
	"Answer whether the next bytecode is a store-pop."

	| byte |
	byte _ self method at: pc.
	^byte = 130 or: [byte between: 96 and: 111]! !


!InstructionStream methodsFor: 'private'!
interpretExtension: offset in: method for: client
	| type offset2 byte2 byte3 |
	offset <=6 ifTrue: 
		["Extended op codes 128-134"
		byte2 _ method at: pc.
		pc _ pc + 1.
		offset <= 2 ifTrue:
			["128-130:  extended pushes and pops"
			type _ byte2 // 64.
			offset2 _ byte2 \\ 64.
			offset = 0 ifTrue: 
				[type = 0 ifTrue: [^ client pushReceiverVariable: offset2].
				type = 1 ifTrue: [^ client pushTemporaryVariable: offset2].
				type = 2  ifTrue: [^ client pushConstant: (method literalAt: offset2 + 1)].
				type = 3 ifTrue: [^ client pushLiteralVariable: (method literalAt: offset2 + 1)]].
			offset = 1 ifTrue: 
				[type = 0 ifTrue: [^ client storeIntoReceiverVariable: offset2].
				type = 1 ifTrue: [^ client storeIntoTemporaryVariable: offset2].
				type = 2 ifTrue: [self error: 'illegalStore'].
				type = 3 ifTrue: [^ client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]].
			offset = 2 ifTrue: 
				[type = 0 ifTrue: [^ client popIntoReceiverVariable: offset2].
				type = 1 ifTrue: [^ client popIntoTemporaryVariable: offset2].
				type = 2 ifTrue: [self error: 'illegalStore'].
				type = 3  ifTrue: [^ client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]].
		"131-134: extended sends"
		offset = 3 ifTrue:  "Single extended send"
			[^ client send: (method literalAt: byte2 \\ 32 + 1)
					super: false numArgs: byte2 // 32].
		offset = 4 ifTrue:    "Double extended do-anything"
			[byte3 _ method at: pc.  pc _ pc + 1.
			type _ byte2 // 32.
			type = 0 ifTrue: [^ client send: (method literalAt: byte3 + 1)
									super: false numArgs: byte2 \\ 32].
			type = 1 ifTrue: [^ client send: (method literalAt: byte3 + 1)
									super: true numArgs: byte2 \\ 32].
			type = 2 ifTrue: [^ client pushReceiverVariable: byte3].
			type = 3 ifTrue: [^ client pushConstant: (method literalAt: byte3 + 1)].
			type = 4 ifTrue: [^ client pushLiteralVariable: (method literalAt: byte3 + 1)].
			type = 5 ifTrue: [^ client storeIntoReceiverVariable: byte3].
			type = 6 ifTrue: [^ client popIntoReceiverVariable: byte3].
			type = 7 ifTrue: [^ client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]].
		offset = 5 ifTrue:  "Single extended send to super"
			[^ client send: (method literalAt: byte2 \\ 32 + 1)
					super: true numArgs: byte2 // 32].
		offset = 6 ifTrue:   "Second extended send"
			[^ client send: (method literalAt: byte2 \\ 64 + 1)
					super: false numArgs: byte2 // 64]].
	offset = 7 ifTrue: [^ client doPop].
	offset = 8 ifTrue: [^ client doDup].
	offset = 9 ifTrue: [^ client pushActiveContext].
	self error: 'unusedBytecode'! !

!InstructionStream methodsFor: 'private'!
method: method pc: startpc

	sender _ method. 
	"allows this class to stand alone as a method scanner"
	pc _ startpc! !

!InstructionStream methodsFor: 'private' stamp: 'ajh 8/1/2001 02:57'!
pc: n

	pc _ n! !

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

InstructionStream class
	instanceVariableNames: ''!

!InstructionStream class methodsFor: 'class initialization'!
initialize
	"Initialize an array of special constants returned by single-bytecode returns."

	SpecialConstants _ 
		(Array with: true with: false with: nil)
			, (Array with: -1 with: 0 with: 1 with: 2)	
	"InstructionStream initialize."
! !


!InstructionStream class methodsFor: 'instance creation'!
on: method 
	"Answer an instance of me on the argument, method."

	^self new method: method pc: method initialPC! !
Number subclass: #Integer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Integer commentStamp: '<historical>' prior: 0!
I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger.
	
Integer division consists of:
	/	exact division, answers a fraction if result is not a whole integer
	//	answers an Integer, rounded towards negative infinity
	\\	is modulo rounded towards negative infinity
	quo: truncated division, rounded towards zero!


!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'!
* aNumber
	"Refer to the comment in Number * " 
	aNumber isInteger ifTrue:
		[^ self digitMultiply: aNumber 
					neg: self negative ~~ aNumber negative].
	^ aNumber adaptToInteger: self andSend: #*! !

!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'!
+ aNumber
	"Refer to the comment in Number + "
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [^ (self digitAdd: aNumber) normalize]
			ifFalse: [^ self digitSubtract: aNumber]].
	^ aNumber adaptToInteger: self andSend: #+! !

!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'!
- aNumber
	"Refer to the comment in Number - "
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [^ self digitSubtract: aNumber]
			ifFalse: [^ (self digitAdd: aNumber) normalize]].
	^ aNumber adaptToInteger: self andSend: #-! !

!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:00'!
/ aNumber
	"Refer to the comment in Number / "
	| quoRem |
	aNumber isInteger ifTrue:
		[quoRem _ self digitDiv: aNumber abs	"*****I've added abs here*****"
						neg: self negative ~~ aNumber negative.
		(quoRem at: 2) = 0
			ifTrue: [^ (quoRem at: 1) normalize]
			ifFalse: [^ (Fraction numerator: self denominator: aNumber) reduced]].
	^ aNumber adaptToInteger: self andSend: #/! !

!Integer methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'!
// aNumber 
	| q |
	#Numeric.
	"Changed 200/01/19 For ANSI support."
	aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"].
	self = 0 ifTrue: [^ 0].
	q := self quo: aNumber.
	"Refer to the comment in Number|//."
	(q negative
		ifTrue: [q * aNumber ~= self]
		ifFalse: [q = 0 and: [self negative ~= aNumber negative]])
		ifTrue: [^ q - 1"Truncate towards minus infinity."]
		ifFalse: [^ q]! !

!Integer methodsFor: 'arithmetic' stamp: 'hh 8/4/2000 00:39'!
\\\ anInteger 
	"a modulo method for use in DSA. Be careful if you try to use this elsewhere"

	^self \\ anInteger! !

!Integer methodsFor: 'arithmetic'!
alignedTo: anInteger
	"Answer the smallest number not less than receiver that is a multiple of anInteger."

	^(self+anInteger-1//anInteger)*anInteger

"5 alignedTo: 2"
"12 alignedTo: 3"! !

!Integer methodsFor: 'arithmetic' stamp: 'mga 5/11/2006 15:42'!
crossSumBase: aBase
	|aResult|
	"Precondition"
	self assert:[aBase isInteger and: [aBase >=2]].

	self < 0 ifTrue: [^self negated crossSumBase: aBase].
	self < aBase ifTrue: [^ self].
	aResult := self \\ aBase + (self // aBase crossSumBase: aBase).

	"Postcondition
	E.g. 18 crossSumBase: 10 -> 9 => 18\\(10-1) = 0"
	self assert: [((aResult \\ (aBase - 1) = 0)) = ((self \\ (aBase - 1)) =0)].
	^aResult! !

!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:00'!
quo: aNumber 
	"Refer to the comment in Number quo: "
	| ng quo |
	aNumber isInteger ifTrue: 
		[ng _ self negative == aNumber negative == false.
		quo _ (self digitDiv:
			(aNumber class == SmallInteger
				ifTrue: [aNumber abs]
				ifFalse: [aNumber])
			neg: ng) at: 1.
		^ quo normalize].
	^ aNumber adaptToInteger: self andSend: #quo:! !


!Integer methodsFor: 'benchmarks' stamp: 'jm 11/20/1998 07:06'!
benchFib  "Handy send-heavy benchmark"
	"(result // seconds to run) = approx calls per second"
	" | r t |
	  t _ Time millisecondsToRun: [r _ 26 benchFib].
	  (r * 1000) // t"
	"138000 on a Mac 8100/100"
	^ self < 2
		ifTrue: [1] 
		ifFalse: [(self-1) benchFib + (self-2) benchFib + 1]
! !

!Integer methodsFor: 'benchmarks' stamp: 'di 4/11/1999 11:20'!
benchmark  "Handy bytecode-heavy benchmark"
	"(500000 // time to run) = approx bytecodes per second"
	"5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000"
	"3059000 on a Mac 8100/100"
    | size flags prime k count |
    size _ 8190.
    1 to: self do:
        [:iter |
        count _ 0.
        flags _ (Array new: size) atAllPut: true.
        1 to: size do:
            [:i | (flags at: i) ifTrue:
                [prime _ i+1.
                k _ i + prime.
                [k <= size] whileTrue:
                    [flags at: k put: false.
                    k _ k + prime].
                count _ count + 1]]].
    ^ count! !

!Integer methodsFor: 'benchmarks' stamp: 'dwh 11/21/1999 16:40'!
tinyBenchmarks
	"Report the results of running the two tiny Squeak benchmarks.
	ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results"
	"0 tinyBenchmarks"
	"On a 292 MHz G3 Mac: 22727272 bytecodes/sec; 984169 sends/sec"
	"On a 400 MHz PII/Win98:  18028169 bytecodes/sec; 1081272 sends/sec"
	| t1 t2 r n1 n2 |
	n1 _ 1.
	[t1 _ Time millisecondsToRun: [n1 benchmark].
	t1 < 1000] whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)"

	n2 _ 28.
	[t2 _ Time millisecondsToRun: [r _ n2 benchFib].
	t2 < 1000] whileTrue:[n2 _ n2 + 1]. 
	"Note: #benchFib's runtime is about O(k^n),
		where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...."

	^ ((n1 * 500000 * 1000) // t1) printString, ' bytecodes/sec; ',
	  ((r * 1000) // t2) printString, ' sends/sec'! !


!Integer methodsFor: 'bit manipulation'!
<< shiftAmount  "left shift"
	shiftAmount < 0 ifTrue: [self error: 'negative arg'].
	^ self bitShift: shiftAmount! !

!Integer methodsFor: 'bit manipulation' stamp: 'dwh 8/18/1999 21:57'!
>> shiftAmount  "right shift"
	shiftAmount < 0 ifTrue: [self error: 'negative arg'].
	^ self bitShift: 0 - shiftAmount! !

!Integer methodsFor: 'bit manipulation'!
allMask: mask 
	"Treat the argument as a bit mask. Answer whether all of the bits that 
	are 1 in the argument are 1 in the receiver."

	^mask = (self bitAnd: mask)! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 11/29/2000 14:32'!
anyBitOfMagnitudeFrom: start to: stopArg 
	"Tests for any magnitude bits in the interval from start to stopArg."
	"Primitive fixed in LargeIntegers v1.2. If you have an earlier version 
	comment out the primitive call (using this ST method then)."
	| magnitude firstDigitIx lastDigitIx rightShift leftShift stop |
	<primitive: 'primAnyBitFromTo' module:'LargeIntegers'>
	start < 1 | (stopArg < 1)
		ifTrue: [^ self error: 'out of range'].
	magnitude _ self abs.
	stop _ stopArg min: magnitude highBit.
	start > stop
		ifTrue: [^ false].
	firstDigitIx _ start - 1 // 8 + 1.
	lastDigitIx _ stop - 1 // 8 + 1.
	rightShift _ (start - 1 \\ 8) negated.
	leftShift _ 7 - (stop - 1 \\ 8).
	firstDigitIx = lastDigitIx
		ifTrue: [| digit mask | 
			mask _ (255 bitShift: rightShift negated)
						bitAnd: (255 bitShift: leftShift negated).
			digit _ magnitude digitAt: firstDigitIx.
			^ (digit bitAnd: mask)
				~= 0].
	((magnitude digitAt: firstDigitIx)
			bitShift: rightShift)
			~= 0
		ifTrue: [^ true].
	firstDigitIx + 1
		to: lastDigitIx - 1
		do: [:ix | (magnitude digitAt: ix)
					~= 0
				ifTrue: [^ true]].
	(((magnitude digitAt: lastDigitIx)
			bitShift: leftShift)
			bitAnd: 255)
			~= 0
		ifTrue: [^ true].
	^ false! !

!Integer methodsFor: 'bit manipulation'!
anyMask: mask 
	"Treat the argument as a bit mask. Answer whether any of the bits that 
	are 1 in the argument are 1 in the receiver."

	^0 ~= (self bitAnd: mask)! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'!
bitAnd: n 
	"Answer an Integer whose bits are the logical AND of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitAnd' module:'LargeIntegers'>
	norm _ n normalize.
	^ self
		digitLogic: norm
		op: #bitAnd:
		length: (self digitLength max: norm digitLength)! !

!Integer methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:32'!
bitClear: aMask 
	"Answer an Integer equal to the receiver, except with all bits cleared that are set in aMask."

	^ (self bitOr: aMask) - aMask! !

!Integer methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'!
bitInvert
	"Answer an Integer whose bits are the logical negation of the receiver's bits.
	Numbers are interpreted as having 2's-complement representation."

	^ -1 - self! !

!Integer methodsFor: 'bit manipulation'!
bitInvert32
	"Answer the 32-bit complement of the receiver."

	^ self bitXor: 16rFFFFFFFF! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'!
bitOr: n 
	"Answer an Integer whose bits are the logical OR of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitOr' module:'LargeIntegers'>
	norm _ n normalize.
	^ self
		digitLogic: norm
		op: #bitOr:
		length: (self digitLength max: norm digitLength)! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 10:09'!
bitShift: shiftCount 
	"Answer an Integer whose value (in twos-complement representation) is  
	the receiver's value (in twos-complement representation) shifted left by 
	the number of bits indicated by the argument. Negative arguments  
	shift right. Zeros are shifted in from the right in left shifts."
	| magnitudeShift |
	magnitudeShift _ self bitShiftMagnitude: shiftCount.
	^ ((self negative and: [shiftCount negative])
		and: [self anyBitOfMagnitudeFrom: 1 to: shiftCount negated])
		ifTrue: [magnitudeShift - 1]
		ifFalse: [magnitudeShift]! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 14:02'!
bitShiftMagnitude: shiftCount 
	"Answer an Integer whose value (in magnitude representation) is  
	the receiver's value (in magnitude representation) shifted left by  
	the number of bits indicated by the argument. Negative arguments
	shift right. Zeros are shifted in from the right in left shifts."
	| rShift |
	<primitive: 'primDigitBitShiftMagnitude' module:'LargeIntegers'>
	shiftCount >= 0 ifTrue: [^ self digitLshift: shiftCount].
	rShift _ 0 - shiftCount.
	^ (self
		digitRshift: (rShift bitAnd: 7)
		bytes: (rShift bitShift: -3)
		lookfirst: self digitLength) normalize! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'!
bitXor: n 
	"Answer an Integer whose bits are the logical XOR of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitXor' module:'LargeIntegers'>
	norm _ n normalize.
	^ self
		digitLogic: norm
		op: #bitXor:
		length: (self digitLength max: norm digitLength)! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:13'!
highBit
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. Raise an error if the receiver is negative, since  
	negative integers are defined to have an infinite number of leading 1's 
	in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to  
	get the highest bit of the magnitude."

	^ self subclassResponsibility! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 01:55'!
highBitOfMagnitude
	"Answer the index of the high order bit of the magnitude of the  
	receiver, or zero if the receiver is zero."
	^ self subclassResponsibility! !

!Integer methodsFor: 'bit manipulation' stamp: 'jm 2/19/98 12:11'!
lowBit
	"Answer the index of the low order bit of this number."
	| index |
	self = 0 ifTrue: [ ^ 0 ].
	index := 1.
	[ (self digitAt: index) = 0 ]
		whileTrue:
			[ index := index + 1 ].
	^ (self digitAt: index) lowBit + (8 * (index - 1))! !

!Integer methodsFor: 'bit manipulation'!
noMask: mask 
	"Treat the argument as a bit mask. Answer whether none of the bits that 
	are 1 in the argument are 1 in the receiver."

	^0 = (self bitAnd: mask)! !


!Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'!
< aNumber
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [self negative
						ifTrue: [^ (self digitCompare: aNumber) > 0]
						ifFalse: [^ (self digitCompare: aNumber) < 0]]
			ifFalse: [^ self negative]].
	^ aNumber adaptToInteger: self andSend: #<! !

!Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'!
= aNumber
	aNumber isNumber ifFalse: [^ false].
	aNumber isInteger ifTrue:
		[aNumber negative == self negative
			ifTrue: [^ (self digitCompare: aNumber) = 0]
			ifFalse: [^ false]].
	^ aNumber adaptToInteger: self andSend: #=! !

!Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'!
> aNumber
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [self negative
						ifTrue: [^(self digitCompare: aNumber) < 0]
						ifFalse: [^(self digitCompare: aNumber) > 0]]
			ifFalse: [^ aNumber negative]].
	^ aNumber adaptToInteger: self andSend: #>! !

!Integer methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^(self lastDigit bitShift: 8) + (self digitAt: 1)! !


!Integer methodsFor: 'converting' stamp: 'mk 10/27/2003 17:45'!
adaptToComplex: rcvr andSend: selector
	"If I am involved in arithmetic with a Complex number, convert me to a Complex number."
	^ rcvr perform: selector with: self asComplex! !

!Integer methodsFor: 'converting' stamp: 'di 11/6/1998 13:43'!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert me to a Fraction."
	^ rcvr perform: selector with: self asFraction! !

!Integer methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector 
	"Convert me to a ScaledDecimal and do the arithmetic. 
	receiverScaledDecimal arithmeticOpSelector self."
	#Numeric.
	"add 200/01/19 For ScaledDecimal support."
	^ receiverScaledDecimal perform: arithmeticOpSelector with: (self asScaledDecimal: 0)! !

!Integer methodsFor: 'converting' stamp: 'ar 4/9/2005 22:31'!
asCharacter
	"Answer the Character whose value is the receiver."
	^Character value: self! !

!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04'!
asColorOfDepth: d
	"Return a color value representing the receiver as color of the given depth"
	^Color colorFromPixelValue: self depth: d! !

!Integer methodsFor: 'converting' stamp: 'mk 10/27/2003 17:44'!
asComplex
	"Answer a Complex number that represents value of the the receiver."

	^ Complex real: self imaginary: 0! !

!Integer methodsFor: 'converting' stamp: 'nice 7/8/2006 01:05'!
asFloat
	"Answer a Float that represents the value of the receiver.
	Optimized to process only the significant digits of a LargeInteger.
	SqR: 11/30/1998 21:1
	
	This algorithm does honour IEEE 754 round to nearest even mode.
	Numbers are first rounded on nearest integer on 53 bits.
	In case of exact half difference between two consecutive integers (2r0.1),
	there are two possible choices (two integers are as near, 0 and 1)
	In this case, the nearest even integer is chosen.
	examples (with less than 53bits for clarity)
	2r0.00001 is rounded to 2r0
	2r1.00001 is rounded to 2.1
	2r0.1 is rounded to 2r0 (nearest event)
	2r1.1 is rounded to 2.10 (neraest even)
	2r0.10001 is rounded to 2r1
	2r1.10001 is rounded to 2.10"
	
	| abs shift sum delta mask trailingBits carry |
	self isZero
		ifTrue: [^ 0.0].
	abs := self abs.

	"Assume Float is a double precision IEEE 754 number with 53bits mantissa.
	We should better use some Float class message for that (Float precision)..."
	delta := abs highBit - 53.
	delta > 0
		ifTrue: [mask := (1 bitShift: delta) - 1.
			trailingBits := abs bitAnd: mask.
			"inexact := trailingBits isZero not."
			carry := trailingBits bitShift: 1 - delta.
			abs := abs bitShift: delta negated.
			shift := delta.
			(carry isZero
					or: [(trailingBits bitAnd: (mask bitShift: -1)) isZero
							and: [abs even]])
				ifFalse: [abs := abs + 1]]
		ifFalse: [shift := 0].
	
	"now, abs has no more than 53 bits, we can do exact floating point arithmetic"
	sum := 0.0.
	1 to: abs size do:
		[:byteIndex | 
		sum := ((abs digitAt: byteIndex) asFloat timesTwoPower: shift) + sum.
		shift := shift + 8].
	^ self positive
			ifTrue: [sum]
			ifFalse: [sum negated]! !

!Integer methodsFor: 'converting' stamp: 'nice 5/6/2006 21:32'!
asFloatSimply
	"Answer a Float that represents the value of the receiver.
	Optimized to process only the significant digits of a LargeInteger.
	NOTA: this version does not honour IEEE 754 arithmetic
	(round to nearest event mode).
	It should be used on 53 or less binary digits numbers.
	SqR: 11/30/1998 21:11"

	| sum firstByte shift |
	shift _ 0.
	sum _ 0.0.
	firstByte _ self size - 7 max: 1.
	firstByte to: self size do:
		[:byteIndex | 
		sum _ ((self digitAt: byteIndex) asFloat timesTwoPower: shift) + sum.
		shift _ shift + 8].
	^sum * self sign asFloat timesTwoPower: firstByte - 1 * 8! !

!Integer methodsFor: 'converting'!
asFraction
	"Answer a Fraction that represents value of the the receiver."

	^Fraction numerator: self denominator: 1! !

!Integer methodsFor: 'converting' stamp: 'ls 5/26/1998 20:53'!
asHexDigit
	^'0123456789ABCDEF' at: self+1! !

!Integer methodsFor: 'converting'!
asInteger
	"Answer with the receiver itself."

	^self

! !

!Integer methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asScaledDecimal: scaleNotUsed 
	"The number of significant digits of the answer is the same as the 
	number of decimal digits in the receiver.  The scale of the answer is 0."
	#Numeric.
	"add 200/01/19 For <integer> protocol."
	^ ScaledDecimal newFromNumber: self scale: 0! !

!Integer methodsFor: 'converting' stamp: 'brp 5/13/2003 10:12'!
asYear

	^ Year year: self 
! !


!Integer methodsFor: 'enumerating'!
timesRepeat: aBlock 
	"Evaluate the argument, aBlock, the number of times represented by the 
	receiver."

	| count |
	count _ 1.
	[count <= self]
		whileTrue: 
			[aBlock value.
			count _ count + 1]! !


!Integer methodsFor: 'explorer' stamp: 'laza 3/17/2005 13:37'!
explorerContents
	^{
		'hexadecimal' -> 16.
		'octal' -> 8.
		'binary' -> 2
	} collect: [:each |
		ObjectExplorerWrapper with: each key translated name: (self printStringBase: each value) model: self]! !

!Integer methodsFor: 'explorer' stamp: 'laza 3/17/2005 13:38'!
hasContentsInExplorer
	^true! !


!Integer methodsFor: 'mathematical functions' stamp: 'di 4/22/1998 14:45'!
factorial
	"Answer the factorial of the receiver."

	self = 0 ifTrue: [^ 1].
	self > 0 ifTrue: [^ self * (self - 1) factorial].
	self error: 'Not valid for negative integers'! !

!Integer methodsFor: 'mathematical functions' stamp: 'LC 6/17/1998 19:22'!
gcd: anInteger
	"See Knuth, Vol 2, 4.5.2, Algorithm L"
	"Initialize"
	| higher u v k uHat vHat a b c d vPrime vPrimePrime q t |
	higher _ SmallInteger maxVal highBit.
	u _ self abs max: (v _ anInteger abs).
	v _ self abs min: v.
	[v class == SmallInteger]
		whileFalse: 
			[(uHat _ u bitShift: (k _ higher - u highBit)) class == SmallInteger
				ifFalse: 
					[k _ k - 1.
					uHat _ uHat bitShift: -1].
			vHat _ v bitShift: k.
			a _ 1.
			b _ 0.
			c _ 0.
			d _ 1.
			"Test quotient"
			[(vPrime _ vHat + d) ~= 0
				and: [(vPrimePrime _ vHat + c) ~= 0 and: [(q _ uHat + a // vPrimePrime) = (uHat + b // vPrime)]]]
				whileTrue: 
					["Emulate Euclid"
					c _ a - (q * (a _ c)).
					d _ b - (q * (b _ d)).
					vHat _ uHat - (q * (uHat _ vHat))].
			"Multiprecision step"
			b = 0
				ifTrue: 
					[v _ u rem: (u _ v)]
				ifFalse: 
					[t _ u * a + (v * b).
					v _ u * c + (v * d).
					u _ t]].
	^ v gcd: u! !

!Integer methodsFor: 'mathematical functions'!
lcm: n 
	"Answer the least common multiple of the receiver and n."

	^self // (self gcd: n) * n! !

!Integer methodsFor: 'mathematical functions' stamp: 'es 5/25/2005 11:04'!
raisedToInteger: exp modulo: m
	(exp = 0) ifTrue: [^ 1].
	exp even
		ifTrue: [^ (self raisedToInteger: (exp // 2) modulo: m) squared \\ m]
		ifFalse: [^ (self * (self raisedToInteger: (exp - 1) modulo: m)) \\ m].! !

!Integer methodsFor: 'mathematical functions' stamp: 'hh 8/4/2000 01:09'!
raisedTo: y modulo: n
	"Answer the modular exponential. Code by Jesse Welton."
	| s t u |
	s _ 1.
	t _ self.
	u _ y.
	[u = 0] whileFalse: [
		u odd ifTrue: [
			s _ s * t.
			s >= n ifTrue: [s _ s \\\ n]].
		t _ t * t.
		t >= n ifTrue: [t _ t \\\ n].
		u _ u bitShift: -1].
	^ s
! !

!Integer methodsFor: 'mathematical functions' stamp: 'tk 7/30/97 13:08'!
take: kk
	"Return the number of combinations of (self) elements taken kk at a time.  For 6 take 3, this is 6*5*4 / (1*2*3).  Zero outside of Pascal's triangle.  Use a trick to go faster."
	" 6 take: 3  "

	| num denom |
	kk < 0 ifTrue: [^ 0].
	kk > self ifTrue: [^ 0].
	num _ 1.
	self to: (kk max: self-kk) + 1 by: -1 do: [:factor | num _ num * factor].
	denom _ 1.
	1 to: (kk min: self-kk) do: [:factor | denom _ denom * factor].
	^ num // denom! !


!Integer methodsFor: 'printing' stamp: 'sw 11/24/1998 14:53'!
asStringWithCommas
	"123456789 asStringWithCommas"
	"-123456789 asStringWithCommas"
	| digits |
	digits _ self abs printString.
	^ String streamContents:
		[:strm | 
		self sign = -1 ifTrue: [strm nextPut: $-].
		1 to: digits size do: 
			[:i | strm nextPut: (digits at: i).
			(i < digits size and: [(i - digits size) \\ 3 = 0])
				ifTrue: [strm nextPut: $,]]]! !

!Integer methodsFor: 'printing' stamp: 'ar 7/18/2001 22:09'!
asStringWithCommasSigned
	"123456789 asStringWithCommasSigned"
	"-123456789 asStringWithCommasSigned"
	| digits |
	digits _ self abs printString.
	^ String streamContents:
		[:strm | 
		self sign = -1 ifTrue: [strm nextPut: $-] ifFalse:[strm nextPut: $+].
		1 to: digits size do: 
			[:i | strm nextPut: (digits at: i).
			(i < digits size and: [(i - digits size) \\ 3 = 0])
				ifTrue: [strm nextPut: $,]]]! !

!Integer methodsFor: 'printing' stamp: 'sw 11/13/1999 23:00'!
asTwoCharacterString
	"Answer a two-character string representing the receiver, with leading zero if required.  Intended for use with integers in the range 0 to 99, but plausible replies given for other values too"

	^ (self >= 0 and: [self < 10])
		ifTrue:	['0', self printString]
		ifFalse:	[self printString copyFrom: 1 to: 2]


"
2 asTwoCharacterString
11 asTwoCharacterString
1943 asTwoCharacterString
0 asTwoCharacterString
-2 asTwoCharacterString
-234 asTwoCharacterString
"! !

!Integer methodsFor: 'printing' stamp: 'tk 4/1/2002 11:30'!
asWords
	"SmallInteger maxVal asWords"
	| mils minus three num answer milCount |
	self = 0 ifTrue: [^'zero'].
	mils _ #('' ' thousand' ' million' ' billion' ' trillion' ' quadrillion' ' quintillion' ' sextillion' ' septillion' ' octillion' ' nonillion' ' decillion' ' undecillion' ' duodecillion' ' tredecillion' ' quattuordecillion' ' quindecillion' ' sexdecillion' ' septendecillion' ' octodecillion' ' novemdecillion' ' vigintillion').
	num _ self.
	minus _ ''.
	self < 0 ifTrue: [
		minus _ 'negative '.
		num _ num negated.
	].
	answer _ String new.
	milCount _ 1.
	[num > 0] whileTrue: [
		three _ (num \\ 1000) threeDigitName.
		num _ num // 1000.
		three isEmpty ifFalse: [
			answer isEmpty ifFalse: [
				answer _ ', ',answer
			].
			answer _ three,(mils at: milCount),answer.
		].
		milCount _ milCount + 1.
	].
	^minus,answer! !

!Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:14'!
destinationBuffer:digitLength
  digitLength <= 1
		ifTrue: [self]
		ifFalse: [LargePositiveInteger new: digitLength].! !

!Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:16'!
digitBuffer:digitLength
  ^Array new:digitLength*8.! !

!Integer methodsFor: 'printing'!
isLiteral

	^true! !

!Integer methodsFor: 'printing' stamp: 'fbs 2/9/2006 08:57'!
printOn: outputStream base: baseInteger showRadix: flagBoolean 
	"Write a sequence of characters that describes the receiver in radix 
	baseInteger with optional radix specifier. 
	The result is undefined if baseInteger less than 2 or greater than 36."
	| tempString startPos |
	#Numeric.
	"2000/03/04  Harmon R. Added ANSI <integer> protocol"

	tempString := self printStringRadix: baseInteger.
	flagBoolean ifTrue: [^ outputStream nextPutAll: tempString].
	startPos := (tempString indexOf: $r ifAbsent: [self error: 'radix indicator not found.'])
				+ 1.
	self negative ifTrue: [outputStream nextPut: $-].
	outputStream nextPutAll: (tempString copyFrom: startPos to: tempString size)! !

!Integer methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'!
printPaddedWith: aCharacter to: anInteger 
	"Answer the string containing the ASCII representation of the receiver 
	padded on the left with aCharacter to be at least anInteger characters."
	#Numeric.
	"2000/03/04  Harmon R. Added Date and Time support"
	^ self
		printPaddedWith: aCharacter
		to: anInteger
		base: 10! !

!Integer methodsFor: 'printing' stamp: 'md 7/30/2005 21:13'!
printPaddedWith: aCharacter to: anInteger base: aRadix 
	"Answer the string containing the ASCII representation of the receiver 
	padded on the left with aCharacter to be at least anInteger characters."
	| aStream padding digits |
	#Numeric.
	"2000/03/04  Harmon R. Added Date and Time support"
	aStream := WriteStream on: (String new: 10).
	self
		printOn: aStream
		base: aRadix
		showRadix: false.
	digits := aStream contents.
	padding := anInteger - digits size.
	padding > 0 ifFalse: [^ digits].
	^ ((String new: padding) atAllPut: aCharacter;
	 yourself) , digits! !

!Integer methodsFor: 'printing' stamp: 'md 7/30/2005 21:00'!
printStringRadix: baseInteger 
	"Return a string containing a sequence of characters that represents the 
	numeric value of the receiver in the radix specified by the argument.  
	If the receiver is negative, a minus sign ('-') is prepended to the 
	sequence of characters. 
	The result is undefined if baseInteger less than 2 or greater than 36."
	| tempString |
	#Numeric.
	"2000/03/04  Harmon R. Added ANSI <integer> protocol"
	baseInteger = 10
		ifTrue: 
			[tempString := self storeStringBase: baseInteger.
			self negative
				ifTrue: [^ '-10r' , (tempString copyFrom: 2 to: tempString size)]
				ifFalse: [^ '10r' , tempString]].
	^ self storeStringBase: baseInteger! !


!Integer methodsFor: 'printing-numerative' stamp: 'laza 1/30/2005 13:53'!
byteEncode: aStream base: base
	^self printOn: aStream base: base	! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:06'!
printOn: aStream base: base
	aStream nextPutAll: (self printStringBase: base)! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:13'!
printOn: aStream base: base length: minimum padded: zeroFlag
	| prefix |
	prefix _ self negative ifTrue: ['-'] ifFalse: [String new].
	self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag
! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 9/19/2004 10:52'!
printStringBase: base
	| stream integer next |
	self = 0 ifTrue: [^'0'].
	self negative ifTrue: [^'-', (self negated printStringBase: base)].
	stream _ WriteStream on: String new.
	integer _ self normalize.
	[integer > 0] whileTrue: [
		next _ integer quo: base.
		stream nextPut: (Character digitValue: integer - (next * base)).
		integer _ next].
	^stream contents reversed

! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:14'!
printStringBase: base length: minimum padded: zeroFlag
	^String streamContents: [:s| self printOn: s base: base length: minimum padded: zeroFlag]! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 10:58'!
printStringHex
	^self printStringBase: 16! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:21'!
printStringLength: minimal
	^self printStringLength: minimal padded: false
! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'!
printStringLength: minimal padded: zeroFlag
	^self printStringBase: 10 length: minimal padded: zeroFlag! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'!
printStringPadded: minimal
	^self printStringLength: minimal padded: true
! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/30/2004 09:40'!
printStringRoman
	| stream integer |
	stream _ WriteStream on: String new.
	integer _ self negative ifTrue: [stream nextPut: $-. self negated] ifFalse: [self].
	integer // 1000 timesRepeat: [stream nextPut: $M].
	integer
		romanDigits: 'MDC' for: 100 on: stream;
		romanDigits: 'CLX' for: 10 on: stream;
		romanDigits: 'XVI' for: 1 on: stream.
	^stream contents! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:35'!
radix: base 
	^ self printStringBase: base! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:36'!
storeOn: aStream base: base
	"Print a representation of the receiver on the stream
	<aStream> in base <base> where
	2 <= <baseInteger> <= 16. If <base> is other than 10
	it is written first separated by $r followed by the number
	like for example: 16rFCE2"

	| integer |
	integer _ self negative
		ifTrue: [aStream nextPut: $-. self negated]
		ifFalse: [self].
	base = 10 ifFalse: [aStream nextPutAll: base printString; nextPut: $r].
	aStream nextPutAll: (integer printStringBase: base).
! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:16'!
storeOn: aStream base: base length: minimum padded: zeroFlag
	| prefix |
	prefix _ self negative ifTrue: ['-'] ifFalse: [String new].
	base = 10 ifFalse: [prefix _ prefix, base printString, 'r'].
	self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag
! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:16'!
storeStringBase: base length: minimum padded: zeroFlag
	^String streamContents: [:s| self storeOn: s base: base length: minimum padded: zeroFlag]! !

!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 10:58'!
storeStringHex
	^self storeStringBase: 16! !


!Integer methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:26'!
lastDigit
	"Answer the last digit of the integer base 256.  LargePositiveInteger uses bytes of base two number, and each is a 'digit'."

	^self digitAt: self digitLength! !

!Integer methodsFor: 'system primitives'!
replaceFrom: start to: stop with: replacement startingAt: repStart
	| j |  "Catches failure if LgInt replace primitive fails"
	j _ repStart.
	start to: stop do:
		[:i |
		self digitAt: i put: (replacement digitAt: j).
		j _ j+1]! !


!Integer methodsFor: 'testing'!
even 
	"Refer to the comment in Number|even."

	^((self digitAt: 1) bitAnd: 1) = 0! !

!Integer methodsFor: 'testing'!
isInteger
	"True for all subclasses of Integer."

	^ true! !

!Integer methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'!
isPowerOfTwo
	"Return true if the receiver is an integral power of two."
	^ (self bitAnd: self-1) = 0! !

!Integer methodsFor: 'testing' stamp: 'md 2/12/2006 14:37'!
isPrime
	"See isProbablyPrimeWithK:andQ: for the algoritm description."
	| k q |
	self <= 1 ifTrue: [^self error: 'operation undefined'].
	self even ifTrue: [^self = 2].
	k := 1.

	q := self - 1 bitShift: -1.
	[q odd] whileFalse: 
			[q := q bitShift: -1.
			k := k + 1].
	
	25 timesRepeat: [(self isProbablyPrimeWithK: k andQ: q) ifFalse: [^false]].
	^true! !


!Integer methodsFor: 'tiles' stamp: 'RAA 8/24/1999 15:32'!
asPrecedenceName

	^#('unary' 'binary' 'keyword') at: self
! !


!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 19:16'!
asLargerPowerOfTwo
	"Convert the receiver into a power of two which is not less than the receiver"
	self isPowerOfTwo
		ifTrue:[^self]
		ifFalse:[^1 bitShift: (self highBit)]! !

!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 18:56'!
asPowerOfTwo
	"Convert the receiver into a power of two"
	^self asSmallerPowerOfTwo! !

!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 19:16'!
asSmallerPowerOfTwo
	"Convert the receiver into a power of two which is not larger than the receiver"
	self isPowerOfTwo
		ifTrue:[^self]
		ifFalse:[^1 bitShift: (self highBit - 1)]! !

!Integer methodsFor: 'truncation and round off' stamp: 'lr 11/4/2003 12:14'!
atRandom
	"Answer a random integer from 1 to self.  This implementation uses a
	shared generator. Heavy users should their own implementation or use
	Interval>atRandom: directly."

	self = 0 ifTrue: [ ^0 ].
	self < 0 ifTrue: [ ^self negated atRandom negated ].
	^Collection mutexForPicking critical: [
		self atRandom: Collection randomForPicking ]! !

!Integer methodsFor: 'truncation and round off' stamp: 'sma 5/12/2000 12:35'!
atRandom: aGenerator
	"Answer a random integer from 1 to self picked from aGenerator."

	^ aGenerator nextInt: self! !

!Integer methodsFor: 'truncation and round off'!
ceiling 
	"Refer to the comment in Number|ceiling."! !

!Integer methodsFor: 'truncation and round off'!
floor 
	"Refer to the comment in Number|floor."! !

!Integer methodsFor: 'truncation and round off'!
normalize 
	"SmallInts OK; LgInts override"
	^ self! !

!Integer methodsFor: 'truncation and round off'!
rounded 
	"Refer to the comment in Number|rounded."! !

!Integer methodsFor: 'truncation and round off'!
truncated 
	"Refer to the comment in Number|truncated."! !


!Integer methodsFor: 'private'!
copyto: x
	| stop |
	stop _ self digitLength min: x digitLength.
	^ x replaceFrom: 1 to: stop with: self startingAt: 1! !

!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:41'!
digitAdd: arg 
	| len arglen accum sum |
	<primitive: 'primDigitAdd' module:'LargeIntegers'>
	accum _ 0.
	(len _ self digitLength) < (arglen _ arg digitLength) ifTrue: [len _ arglen].
	"Open code max: for speed"
	sum _ Integer new: len neg: self negative.
	1 to: len do: 
		[:i | 
		accum _ (accum bitShift: -8)
					+ (self digitAt: i) + (arg digitAt: i).
		sum digitAt: i put: (accum bitAnd: 255)].
	accum > 255
		ifTrue: 
			[sum _ sum growby: 1.
			sum at: sum digitLength put: (accum bitShift: -8)].
	^ sum! !

!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:43'!
digitCompare: arg 
	"Compare the magnitude of self with that of arg.   
	Return a code of 1, 0, -1 for self >, = , < arg"
	| len arglen argDigit selfDigit |
	<primitive: 'primDigitCompare' module:'LargeIntegers'>
	len _ self digitLength.
	(arglen _ arg digitLength) ~= len
		ifTrue: [arglen > len
				ifTrue: [^ -1]
				ifFalse: [^ 1]].
	[len > 0]
		whileTrue: 
			[(argDigit _ arg digitAt: len) ~= (selfDigit _ self digitAt: len)
				ifTrue: [argDigit < selfDigit
						ifTrue: [^ 1]
						ifFalse: [^ -1]].
			len _ len - 1].
	^ 0! !

!Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:28'!
digitDiv: arg neg: ng 
	"Answer with an array of (quotient, remainder)."
	| quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t |
	<primitive: 'primDigitDivNegative' module:'LargeIntegers'>
	arg = 0 ifTrue: [^ (ZeroDivide dividend: self) signal].
	"TFEI added this line"
	l _ self digitLength - arg digitLength + 1.
	l <= 0 ifTrue: [^ Array with: 0 with: self].
	"shortcut against #highBit"
	d _ 8 - arg lastDigit highBitOfPositiveReceiver.
	div _ arg digitLshift: d.
	div _ div growto: div digitLength + 1.
	"shifts so high order word is >=128"
	rem _ self digitLshift: d.
	rem digitLength = self digitLength ifTrue: [rem _ rem growto: self digitLength + 1].
	"makes a copy and shifts"
	quo _ Integer new: l neg: ng.
	dl _ div digitLength - 1.
	"Last actual byte of data"
	ql _ l.
	dh _ div digitAt: dl.
	dnh _ dl = 1
				ifTrue: [0]
				ifFalse: [div digitAt: dl - 1].
	1 to: ql do: 
		[:k | 
		"maintain quo*arg+rem=self"
		"Estimate rem/div by dividing the leading to bytes of rem by dh."
		"The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles."
		j _ rem digitLength + 1 - k.
		"r1 _ rem digitAt: j."
		(rem digitAt: j)
			= dh
			ifTrue: [qhi _ qlo _ 15
				"i.e. q=255"]
			ifFalse: 
				["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh.  
				Note that r1,r2 are bytes, not nibbles.  
				Be careful not to generate intermediate results exceeding 13  
				bits."
				"r2 _ (rem digitAt: j - 1)."
				t _ ((rem digitAt: j)
							bitShift: 4)
							+ ((rem digitAt: j - 1)
									bitShift: -4).
				qhi _ t // dh.
				t _ (t \\ dh bitShift: 4)
							+ ((rem digitAt: j - 1)
									bitAnd: 15).
				qlo _ t // dh.
				t _ t \\ dh.
				"Next compute (hi,lo) _ q*dnh"
				hi _ qhi * dnh.
				lo _ qlo * dnh + ((hi bitAnd: 15)
								bitShift: 4).
				hi _ (hi bitShift: -4)
							+ (lo bitShift: -8).
				lo _ lo bitAnd: 255.
				"Correct overestimate of q.  
				Max of 2 iterations through loop -- see Knuth vol. 2"
				r3 _ j < 3
							ifTrue: [0]
							ifFalse: [rem digitAt: j - 2].
				[(t < hi
					or: [t = hi and: [r3 < lo]])
					and: 
						["i.e. (t,r3) < (hi,lo)"
						qlo _ qlo - 1.
						lo _ lo - dnh.
						lo < 0
							ifTrue: 
								[hi _ hi - 1.
								lo _ lo + 256].
						hi >= dh]]
					whileTrue: [hi _ hi - dh].
				qlo < 0
					ifTrue: 
						[qhi _ qhi - 1.
						qlo _ qlo + 16]].
		"Subtract q*div from rem"
		l _ j - dl.
		a _ 0.
		1 to: div digitLength do: 
			[:i | 
			hi _ (div digitAt: i)
						* qhi.
			lo _ a + (rem digitAt: l) - ((hi bitAnd: 15)
							bitShift: 4) - ((div digitAt: i)
							* qlo).
			rem digitAt: l put: lo - (lo // 256 * 256).
			"sign-tolerant form of (lo bitAnd: 255)"
			a _ lo // 256 - (hi bitShift: -4).
			l _ l + 1].
		a < 0
			ifTrue: 
				["Add div back into rem, decrease q by 1"
				qlo _ qlo - 1.
				l _ j - dl.
				a _ 0.
				1 to: div digitLength do: 
					[:i | 
					a _ (a bitShift: -8)
								+ (rem digitAt: l) + (div digitAt: i).
					rem digitAt: l put: (a bitAnd: 255).
					l _ l + 1]].
		quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4)
				+ qlo].
	rem _ rem
				digitRshift: d
				bytes: 0
				lookfirst: dl.
	^ Array with: quo with: rem! !

!Integer methodsFor: 'private' stamp: 'hmm 1/7/2002 20:55'!
digitLogic: arg op: op length: len
	| result neg1 neg2 rneg z1 z2 rz b1 b2 b |
	neg1 _ self negative.
	neg2 _ arg negative.
	rneg _ 
		((neg1 ifTrue: [-1] ifFalse: [0])
			perform: op 
			with: (neg2
					ifTrue: [-1]
					ifFalse: [0])) < 0.
	result _ Integer new: len neg: rneg.
	rz _ z1 _ z2 _ true.
	1 to: result digitLength do: 
		[:i | 
		b1 _ self digitAt: i.
		neg1 
			ifTrue: [b1 _ z1
						ifTrue: [b1 = 0
									ifTrue: [0]
									ifFalse: 
										[z1 _ false.
										256 - b1]]
						ifFalse: [255 - b1]].
		b2 _ arg digitAt: i.
		neg2 
			ifTrue: [b2 _ z2
						ifTrue: [b2 = 0
									ifTrue: [0]
									ifFalse: 
										[z2 _ false.
										256 - b2]]
						ifFalse: [255 - b2]].
		b _ b1 perform: op with: b2.
		result 
			digitAt: i 
			put: (rneg
					ifTrue: [rz ifTrue: [b = 0
										ifTrue: [0]
										ifFalse:
											[rz _ false.
											256 - b]]
								ifFalse: [255 - b]]
				ifFalse: [b])].
	^ result normalize! !

!Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:30'!
digitLshift: shiftCount 
	| carry rShift mask len result digit byteShift bitShift highBit |
	(highBit _ self highBitOfMagnitude) = 0 ifTrue: [^ 0].
	len _ highBit + shiftCount + 7 // 8.
	result _ Integer new: len neg: self negative.
	byteShift _ shiftCount // 8.
	bitShift _ shiftCount \\ 8.
	bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts"
		^ result
			replaceFrom: byteShift + 1
			to: len
			with: self
			startingAt: 1].
	carry _ 0.
	rShift _ bitShift - 8.
	mask _ 255 bitShift: 0 - bitShift.
	1 to: byteShift do: [:i | result digitAt: i put: 0].
	1 to: len - byteShift do: 
		[:i | 
		digit _ self digitAt: i.
		result digitAt: i + byteShift put: (((digit bitAnd: mask)
				bitShift: bitShift)
				bitOr: carry).
		carry _ digit bitShift: rShift].
	^ result! !

!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'!
digitMultiply: arg neg: ng 
	| prod prodLen carry digit k ab |
	<primitive: 'primDigitMultiplyNegative' module:'LargeIntegers'>
	(arg digitLength = 1 and: [(arg digitAt: 1)
			= 0])
		ifTrue: [^ 0].
	(self digitLength = 1 and: [(self digitAt: 1)
			= 0])
		ifTrue: [^ 0].
	prodLen _ self digitLength + arg digitLength.
	prod _ Integer new: prodLen neg: ng.
	"prod starts out all zero"
	1 to: self digitLength do: [:i | (digit _ self digitAt: i) ~= 0
			ifTrue: 
				[k _ i.
				carry _ 0.
				"Loop invariant: 0<=carry<=0377, k=i+j-1"
				1 to: arg digitLength do: 
					[:j | 
					ab _ (arg digitAt: j)
								* digit + carry + (prod digitAt: k).
					carry _ ab bitShift: -8.
					prod digitAt: k put: (ab bitAnd: 255).
					k _ k + 1].
				prod digitAt: k put: carry]].
	^ prod normalize! !

!Integer methodsFor: 'private'!
digitRshift: anInteger bytes: b lookfirst: a 
	 "Shift right 8*b+anInteger bits, 0<=n<8.
	Discard all digits beyond a, and all zeroes at or below a."
	| n x r f m digit count i |
	n _ 0 - anInteger.
	x _ 0.
	f _ n + 8.
	i _ a.
	m _ 255 bitShift: 0 - f.
	digit _ self digitAt: i.
	[((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue:
		[x _ digit bitShift: f "Can't exceed 8 bits".
		i _ i - 1.
		digit _ self digitAt: i].
	i <= b ifTrue: [^Integer new: 0 neg: self negative].  "All bits lost"
	r _ Integer new: i - b neg: self negative.
	count _ i.
	x _ (self digitAt: b + 1) bitShift: n.
	b + 1 to: count do:
		[:j | digit _ self digitAt: j + 1.
		r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) 
			"Avoid values > 8 bits".
		x _ digit bitShift: n].
	^r! !

!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'!
digitSubtract: arg 
	| smaller larger z sum sl al ng |
	<primitive: 'primDigitSubtract' module:'LargeIntegers'>
	sl _ self digitLength.
	al _ arg digitLength.
	(sl = al
		ifTrue: 
			[[(self digitAt: sl)
				= (arg digitAt: sl) and: [sl > 1]]
				whileTrue: [sl _ sl - 1].
			al _ sl.
			(self digitAt: sl)
				< (arg digitAt: sl)]
		ifFalse: [sl < al])
		ifTrue: 
			[larger _ arg.
			smaller _ self.
			ng _ self negative == false.
			sl _ al]
		ifFalse: 
			[larger _ self.
			smaller _ arg.
			ng _ self negative].
	sum _ Integer new: sl neg: ng.
	z _ 0.
	"Loop invariant is -1<=z<=1"
	1 to: sl do: 
		[:i | 
		z _ z + (larger digitAt: i) - (smaller digitAt: i).
		sum digitAt: i put: z - (z // 256 * 256).
		"sign-tolerant form of (z bitAnd: 255)"
		z _ z // 256].
	^ sum normalize! !

!Integer methodsFor: 'private'!
growby: n

	^self growto: self digitLength + n! !

!Integer methodsFor: 'private'!
growto: n

	^self copyto: (self species new: n)! !

!Integer methodsFor: 'private' stamp: 'es 5/31/2005 09:30'!
isProbablyPrimeWithK: k andQ: q 
	"Algorithm P, probabilistic primality test, from
	Knuth, Donald E. 'The Art of Computer Programming', Vol 2,
	Third Edition, section 4.5.4, page 395, P1-P5 refer to Knuth description."

	"P1"

	| x j y |
	x := (self - 2) atRandom + 1.
	"P2"
	j := 0.
	y := x raisedToInteger: q modulo: self.
	"P3"
	
	[(((j = 0) & (y = 1)) | (y = (self - 1))) ifTrue: [^true].
	((j > 0) & (y = 1)) ifTrue: [^false].	"P5"
	true]  
			whileTrue: 
				[j := j + 1.
				(j < k) ifTrue: [y := y squared \\ self]
				ifFalse:[^ false]]! !

!Integer methodsFor: 'private' stamp: 'laza 3/29/2004 18:16'!
print: positiveNumberString on: aStream prefix: prefix length: minimum padded: zeroFlag
	| padLength |
	padLength _ minimum - positiveNumberString size - prefix size.
	padLength > 0
		ifTrue: [zeroFlag
				ifTrue: [aStream nextPutAll: prefix; nextPutAll: (String new: padLength withAll: $0)]
				ifFalse: [aStream nextPutAll: (String new: padLength withAll: Character space); nextPutAll: prefix]]
		ifFalse: [aStream nextPutAll: prefix].
	aStream nextPutAll: positiveNumberString
	! !

!Integer methodsFor: 'private' stamp: 'sma 5/20/2000 17:00'!
romanDigits: digits for: base on: aStream
	| n |
	n _ self \\ (base * 10) // base.
	n = 9 ifTrue: [^ aStream nextPut: digits last; nextPut: digits first].
	n = 4 ifTrue: [^ aStream nextPut: digits last; nextPut: digits second].
	n > 4 ifTrue: [aStream nextPut: digits second].
	n \\ 5 timesRepeat: [aStream nextPut: digits last]! !

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

Integer class
	instanceVariableNames: ''!

!Integer class methodsFor: 'compatibility' stamp: 'laza 10/16/2004 14:34'!
readFrom: aStream radix: radix
	^self readFrom: aStream base: radix! !


!Integer class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'!
one
	#Numeric.
	"add 200/01/19 For <number> protocol support."
	^ 1! !


!Integer class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'!
basicNew

	self == Integer ifTrue: [
		^ self error: 'Integer is an abstract class.  Make a concrete subclass.'].
	^ super basicNew! !

!Integer class methodsFor: 'instance creation' stamp: 'bf 2/2/2004 00:23'!
byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4 
	"Depending on high-order byte copy directly into a LargeInteger,
	or build up a SmallInteger by shifting"
	| value |
	byte4 < 16r40 ifTrue:
		[^ (byte4 bitShift: 24)
		 + (byte3 bitShift: 16)
		 + (byte2 bitShift: 8)
		 + byte1].
	value _ LargePositiveInteger new: 4.
	value digitAt: 4 put: byte4.
	value digitAt: 3 put: byte3.
	value digitAt: 2 put: byte2.
	value digitAt: 1 put: byte1.
	^ value! !

!Integer class methodsFor: 'instance creation' stamp: 'sw 5/8/2000 11:05'!
initializedInstance
	^ 2468! !

!Integer class methodsFor: 'instance creation' stamp: 'tk 4/18/1999 22:01'!
new

	self == Integer ifTrue: [
		^ self error: 'Integer is an abstract class.  Make a concrete subclass.'].
	^ super new! !

!Integer class methodsFor: 'instance creation'!
new: length neg: neg
	"Answer an instance of a large integer whose size is length. neg is a flag 
	determining whether the integer is negative or not."

	neg 
		ifTrue: [^LargeNegativeInteger new: length]
		ifFalse: [^LargePositiveInteger new: length]! !

!Integer class methodsFor: 'instance creation'!
readFrom: aStream 
	"Answer a new Integer as described on the stream, aStream.
	Embedded radix specifiers not allowed - use Number readFrom: for that."
	^self readFrom: aStream base: 10! !

!Integer class methodsFor: 'instance creation' stamp: 'laza 11/14/2004 00:59'!
readFrom: aStream base: base 
	"Answer an instance of one of the concrete subclasses if Integer. 
	Initial minus sign accepted, and bases > 10 use letters A-Z.
	Imbedded radix specifiers not allowed;  use Number 
	class readFrom: for that. Answer zero if there are no digits."

	| digit value neg |
	neg := aStream peekFor: $-.
	value := 0.
	[aStream atEnd]
		whileFalse: 
			[digit := aStream next digitValue.
			(digit < 0 or: [digit >= base])
				ifTrue: 
					[aStream skip: -1.
					neg ifTrue: [^value negated].
					^value]
				ifFalse: [value := value * base + digit]].
	neg ifTrue: [^value negated].
	^value! !


!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:34'!
largePrimesUpTo: maxValue
	"Compute and return all the prime numbers up to maxValue"
	^Array streamContents:[:s| self largePrimesUpTo: maxValue do:[:prime| s nextPut: prime]]! !

!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 02:38'!
largePrimesUpTo: max do: aBlock
	"Evaluate aBlock with all primes up to maxValue.
	The Algorithm is adapted from http://www.rsok.com/~jrm/printprimes.html
	It encodes prime numbers much more compactly than #primesUpTo: 
	38.5 integer per byte (2310 numbers per 60 byte) allow for some fun large primes.
	(all primes up to SmallInteger maxVal can be computed within ~27MB of memory;
	the regular #primesUpTo: would require 4 *GIGA*bytes).
	Note: The algorithm could be re-written to produce the first primes (which require
	the longest time to sieve) faster but only at the cost of clarity."

	| limit flags maskBitIndex bitIndex maskBit byteIndex index primesUpTo2310 indexLimit |
	limit _ max asInteger - 1.
	indexLimit _ max sqrt truncated + 1.
	"Create the array of flags."
	flags _ ByteArray new: (limit + 2309) // 2310 * 60 + 60.
	flags atAllPut: 16rFF. "set all to true"

	"Compute the primes up to 2310"
	primesUpTo2310 _ self primesUpTo: 2310.

	"Create a mapping from 2310 integers to 480 bits (60 byte)"
	maskBitIndex _ Array new: 2310.
	bitIndex _ -1. "for pre-increment"
	maskBitIndex at: 1 put: (bitIndex _ bitIndex + 1).
	maskBitIndex at: 2 put: (bitIndex _ bitIndex + 1).

	1 to: 5 do:[:i| aBlock value: (primesUpTo2310 at: i)].

	index _ 6.
	2 to: 2309 do:[:n|
		[(primesUpTo2310 at: index) < n] 
			whileTrue:[index _ index + 1].
		n = (primesUpTo2310 at: index) ifTrue:[
			maskBitIndex at: n+1 put: (bitIndex _ bitIndex + 1).
		] ifFalse:[
			"if modulo any of the prime factors of 2310, then could not be prime"
			(n \\ 2 = 0 or:[n \\ 3 = 0 or:[n \\ 5 = 0 or:[n \\ 7 = 0 or:[n \\ 11 = 0]]]]) 
				ifTrue:[maskBitIndex at: n+1 put: 0]
				ifFalse:[maskBitIndex at: n+1 put: (bitIndex _ bitIndex + 1)].
		].
	].

	"Now the real work begins...
	Start with 13 since multiples of 2,3,5,7,11 are handled by the storage method;
	increment by 2 for odd numbers only."
	13 to: limit by: 2 do:[:n|
		(maskBit _ maskBitIndex at: (n \\ 2310 + 1)) = 0 ifFalse:["not a multiple of 2,3,5,7,11"
			byteIndex _ n // 2310 * 60 + (maskBit-1 bitShift: -3) + 1.
			bitIndex _ 1 bitShift: (maskBit bitAnd: 7).
			((flags at: byteIndex) bitAnd: bitIndex) = 0 ifFalse:["not marked -- n is prime"
				aBlock value: n.
				"Start with n*n since any integer < n has already been sieved 
				(e.g., any multiple of n with a number k < n has been cleared 
				when k was sieved); add 2 * i to avoid even numbers and
				mark all multiples of this prime. Note: n < indexLimit below
				limits running into LargeInts -- nothing more."
				n < indexLimit ifTrue:[
					index _ n * n.
					(index bitAnd: 1) = 0 ifTrue:[index _ index + n].
					[index <= limit] whileTrue:[
						(maskBit _ maskBitIndex at: (index \\ 2310 + 1)) = 0 ifFalse:[
							byteIndex _ (index // 2310 * 60) + (maskBit-1 bitShift: -3) + 1.
							maskBit _ 255 - (1 bitShift: (maskBit bitAnd: 7)).
							flags at: byteIndex put: ((flags at: byteIndex) bitAnd: maskBit).
						].
						index _ index + (2 * n)].
				].
			].
		].
	].
! !

!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'!
primesUpTo: max
	"Return a list of prime integers up to the given integer."
	"Integer primesUpTo: 100"
	^Array streamContents:[:s| self primesUpTo: max do:[:prime| s nextPut: prime]]! !

!Integer class methodsFor: 'prime numbers' stamp: 'md 2/13/2006 14:38'!
primesUpTo: max do: aBlock
	"Compute aBlock with all prime integers up to the given integer."
	"Integer primesUpTo: 100"

	| limit flags prime k |
	limit _ max asInteger - 1.
	"Fall back into #largePrimesUpTo:do: if we'd require more than 100k of memory; 
	the alternative will only requre 1/154th of the amount we need here and is almost as fast."
	limit > 25000 ifTrue:[^self largePrimesUpTo: max do: aBlock].
	flags _ (Array new: limit) atAllPut: true.
	1 to: limit - 1 do: [:i |
		(flags at: i) ifTrue: [
			prime _ i + 1.
			k _ i + prime.
			[k <= limit] whileTrue: [
				flags at: k put: false.
				k _ k + prime].
			aBlock value: prime]].
! !

!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'!
verbosePrimesUpTo: max
	"Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh"
	"Compute primes up to max, but be verbose about it"
	^Array streamContents:[:s| self verbosePrimesUpTo: max do:[:prime| s nextPut: prime]].! !

!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'!
verbosePrimesUpTo: max do: aBlock
	"Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh"
	"Compute primes up to max, but be verbose about it"
	| lastTime nowTime |
	lastTime _ Time millisecondClockValue.
	Utilities informUserDuring:[:bar|
		bar value:'Computing primes...'.
		self primesUpTo: max do:[:prime|
			aBlock value: prime.
			nowTime _ Time millisecondClockValue.
			(nowTime - lastTime > 1000) ifTrue:[
				lastTime _ nowTime.
				bar value:'Last prime found: ', prime printString]]].! !
ArrayedCollection variableWordSubclass: #IntegerArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!IntegerArray commentStamp: '<historical>' prior: 0!
IntegerArrays store 32bit signed Integer values.
Negative values are stored as 2's complement.!


!IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:40'!
at: 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]! !

!IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:40'!
at: index put: anInteger
	| word |
	<primitive: 166>
	anInteger < 0
		ifTrue:["word _ 16r100000000 + anInteger"
				word _ (anInteger + 1) negated bitInvert32]
		ifFalse:[word _ anInteger].
	self  basicAt: index put: word.
	^anInteger! !

!IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 23:34'!
atAllPut: anInteger
	| word |
	anInteger < 0
		ifTrue:["word _ 16r100000000 + anInteger"
				word _ (anInteger + 1) negated bitInvert32]
		ifFalse:[word _ anInteger].
	self primFill: word.! !

!IntegerArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0! !


!IntegerArray methodsFor: 'converting' stamp: 'ar 10/10/1998 16:18'!
asIntegerArray
	^self! !


!IntegerArray methodsFor: 'private' stamp: 'ar 3/3/2001 23:34'!
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.! !
TestCase subclass: #IntegerDigitLogicTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!

!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'!
testAndSingleBitWithMinusOne
	"And a single bit with -1 and test for same value"
	1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:13'!
testMixedSignDigitLogic
	"Verify that mixed sign logic with large integers works."
	self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'!
testNBitAndNNegatedEqualsN
	"Verify that (n bitAnd: n negated) = n for single bits"
	| n |
	1 to: 100 do: [:i | n _ 1 bitShift: i.
				self assert: (n bitAnd: n negated) = n]! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'!
testNNegatedEqualsNComplementedPlusOne
	"Verify that n negated = (n complemented + 1) for single bits"
	| n |
	1 to: 100 do: [:i | n _ 1 bitShift: i.
				self assert: n negated = ((n bitXor: -1) + 1)]! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:13'!
testShiftMinusOne1LeftThenRight
	"Shift -1 left then right and test for 1"
	1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1].
! !

!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'!
testShiftOneLeftThenRight
	"Shift 1 bit left then right and test for 1"
	1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1].
! !
TestCase subclass: #IntegerTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!

!IntegerTest methodsFor: 'tests - basic' stamp: 'sd 3/5/2004 14:50'!
testDegreeCos
	"self run: #testDegreeCos"
	
	self shouldnt: [ 45 degreeCos] raise: Error.
	self assert: 45  degreeCos printString =  (2 sqrt / 2) asFloat printString ! !

!IntegerTest methodsFor: 'tests - basic' stamp: 'md 4/21/2003 16:17'!
testEven
	
	self deny: (1073741825 even).
	self assert: (1073741824  even).
	! !

!IntegerTest methodsFor: 'tests - basic' stamp: 'sd 6/5/2005 08:45'!
testIsInteger

	self assert: (0 isInteger).
	! !

!IntegerTest methodsFor: 'tests - basic' stamp: 'md 4/15/2003 20:40'!
testIsPowerOfTwo

	self assert: (0 isPowerOfTwo).
	self assert: (1 isPowerOfTwo).
	self assert: (2 isPowerOfTwo).
	self deny:  (3 isPowerOfTwo).
	self assert: (4 isPowerOfTwo).
	! !

!IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:40'!
testIsPrime

	"The following tests should return 'true'"
	self assert: 17 isPrime.
	self assert: 78901 isPrime.
	self assert: 104729 isPrime.
	self assert: 15485863 isPrime.
	self assert: 2038074743 isPrime.
	self assert: 29996224275833 isPrime.
	
	"The following tests should return 'false' (first 5 are Carmichael integers)"
	self deny: 561 isPrime.
	self deny: 2821 isPrime.
	self deny: 6601 isPrime.
	self deny: 10585 isPrime.
	self deny: 15841 isPrime.
	self deny: 256 isPrime.
	self deny: 29996224275831 isPrime.! !

!IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:36'!
testLargePrimesUpTo

	| nn | 
	nn := (2 raisedTo: 17) - 1. 
	self deny: (Integer primesUpTo: nn) last = nn.
	self assert: (Integer primesUpTo: nn + 1) last  = nn.
	
	
! !

!IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:36'!
testPrimesUpTo

	| primes nn|
	primes := Integer primesUpTo: 100.
	self assert: primes = #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97).
	
	"upTo: semantics means 'non-inclusive'"
	primes := Integer primesUpTo: 5.
	self assert: primes = #(2 3).
	
	"this test is green for nn>25000, see #testLargePrimesUpTo"
	nn := 5. 
	self deny: (Integer primesUpTo: nn) last = nn.
	self assert: (Integer primesUpTo: nn + 1) last  = nn.! !


!IntegerTest methodsFor: 'tests - benchmarks' stamp: 'sd 6/5/2005 08:37'!
testBenchFib

	self assert: (0 benchFib = 1).
	self assert: (1 benchFib = 1).
	self assert: (2 benchFib = 3).
	! !


!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'sd 6/5/2005 08:43'!
testBitLogic  
	"This little suite of tests is designed to verify correct operation of most
	of Squeak's bit manipulation code, including two's complement
	representation of negative values.  It was written in a hurry and
	is probably lacking several important checks."

	"Shift 1 bit left then right and test for 1"
	"self run: #testBitLogic"
	| n |
	1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1].

	"Shift -1 left then right and test for 1"
	1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1].

	"And a single bit with -1 and test for same value"
	1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].

	"Verify that (n bitAnd: n negated) = n for single bits"
	1 to: 100 do: [:i |  n := 1 bitShift: i. self assert: (n bitAnd: n negated) = n].

	"Verify that n negated = (n complemented + 1) for single bits"
	1 to: 100 do: [:i | 
					n := 1 bitShift: i. 
					self assert: n negated = ((n bitXor: -1) + 1)].

	"Verify that (n + n complemented) = -1 for single bits"
	1 to: 100 do: [:i | 
					n := 1 bitShift: i.
					self assert: (n + (n bitXor: -1)) = -1].

	"Verify that n negated = (n complemented +1) for single bits"
	1 to: 100 do: [:i | 
					n := 1 bitShift: i.
					self assert: n negated = ((n bitXor: -1) + 1)].

	self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE.! !

!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'sd 6/5/2005 08:44'!
testTwoComplementRightShift
	"self run: #testTwoComplementRightShift"

	| large small |
	small := 2 << 16.
	large := 2 << 32.	
	self assert: ((small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1)
		== ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1))).
		
     self assert: ((small bitShift: -1) ~= (small + 1 bitShift: -1)
		== ((large bitShift: -1) ~= (large + 1 bitShift: -1))).! !


!IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:48'!
testCreationFromBytes1
	"self run: #testCreationFromBytes1"
	"it is illegal for a LargeInteger to be less than SmallInteger maxVal." 
	"here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs SmallInteger maxVal as an instance of SmallInteger. "
  
	| maxSmallInt hexString byte1 byte2 byte3 byte4 
	builtInteger |
	maxSmallInt := SmallInteger maxVal.
	hexString := maxSmallInt printStringHex.
	self assert: hexString size = 8.
	byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16.
	byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16.
	byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16.
	byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16.
	builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4.
	self assert: builtInteger = maxSmallInt.
	self assert: builtInteger class = SmallInteger
! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:48'!
testCreationFromBytes2
 	"self run: #testCreationFromBytes2"

	"it is illegal for a LargeInteger to be less than SmallInteger maxVal." 
	"here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal + 1) as an instance of LargePositiveInteger. "
	| maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger |
	maxSmallInt := SmallInteger maxVal.
	hexString := (maxSmallInt + 1) printStringHex.
	self assert: hexString size = 8.
	byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16.
	byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16.
	byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16.
	byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16.
	builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4.
	self assert: builtInteger = (maxSmallInt + 1).
	self deny: builtInteger class = SmallInteger
! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:49'!
testCreationFromBytes3
	"self run: #testCreationFromBytes3"

	"it is illegal for a LargeInteger to be less than SmallInteger maxVal." 
	"here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal - 1) as an instance of SmallInteger. "
	| maxSmallInt hexString byte1 byte2 byte3 byte4 
    builtInteger |
	maxSmallInt := SmallInteger maxVal.
	hexString := (maxSmallInt - 1) printStringHex.
	self assert: hexString size = 8.
	byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16.
	byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16.
	byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16.
	byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16.
	builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4.
	self assert: builtInteger = (maxSmallInt - 1).
	self assert: builtInteger class = SmallInteger
! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:46'!
testDifferentBases
	"self run: #testDifferentBases"
	"| value |
	2 to: 36 do: [:each|
		value _ 0.
		1 to: each-1 do: [:n| value _ value + (n * (each raisedToInteger: n))].
		value _ value negated.
		Transcript tab; show: 'self assert: (', value printString, ' printStringBase: ', each printString, ') = ''', (value printStringBase: each), '''.'; cr.
		Transcript tab; show: 'self assert: (', value printString, ' radix: ', each printString, ') = ''', (value radix: each), '''.'; cr.
		Transcript tab; show: 'self assert: ', value printString, ' printStringHex = ''', (value printStringBase: 16), '''.'; cr.
		Transcript tab; show: 'self assert: (', value printString, ' storeStringBase: ', each printString, ') = ''', (value storeStringBase: each), '''.'; cr.
		Transcript tab; show: 'self assert: ', value printString, ' storeStringHex = ''', (value storeStringBase: 16), '''.'; cr.


].
	"

	self assert: 2r10 = 2.
	self assert: 3r210 = 21.
	self assert: 4r3210 = 228.
	self assert: 5r43210 = 2930.
	self assert: 6r543210 = 44790.
	self assert: 7r6543210 = 800667.
	self assert: 8r76543210 = 16434824.
	self assert: 9r876543210 = 381367044.
	self assert: 10r9876543210 = 9876543210.
	self assert: 11rA9876543210 = 282458553905.
	self assert: 12rBA9876543210 = 8842413667692.
	self assert: 13rCBA9876543210 = 300771807240918.
	self assert: 14rDCBA9876543210 = 11046255305880158.
	self assert: 15rEDCBA9876543210 = 435659737878916215.
	self assert: 16rFEDCBA9876543210 = 18364758544493064720.
	self assert: 17rGFEDCBA9876543210 = 824008854613343261192.
	self assert: 18rHGFEDCBA9876543210 = 39210261334551566857170.
	self assert: 19rIHGFEDCBA9876543210 = 1972313422155189164466189.
	self assert: 20rJIHGFEDCBA9876543210 = 104567135734072022160664820.
	self assert: 21rKJIHGFEDCBA9876543210 = 5827980550840017565077671610.
	self assert: 22rLKJIHGFEDCBA9876543210 = 340653664490377789692799452102.
	self assert: 23rMLKJIHGFEDCBA9876543210 = 20837326537038308910317109288851.
	self assert: 24rNMLKJIHGFEDCBA9876543210 = 1331214537196502869015340298036888.
	self assert: 25rONMLKJIHGFEDCBA9876543210 = 88663644327703473714387251271141900.
	self assert: 26rPONMLKJIHGFEDCBA9876543210 = 6146269788878825859099399609538763450.
	self assert: 27rQPONMLKJIHGFEDCBA9876543210 = 442770531899482980347734468443677777577.
	self assert: 28rRQPONMLKJIHGFEDCBA9876543210 = 33100056003358651440264672384704297711484.
	self assert: 29rSRQPONMLKJIHGFEDCBA9876543210 = 2564411043271974895869785066497940850811934.
	self assert: 30rTSRQPONMLKJIHGFEDCBA9876543210 = 205646315052919334126040428061831153388822830.
	self assert: 31rUTSRQPONMLKJIHGFEDCBA9876543210 = 17050208381689099029767742314582582184093573615.
	self assert: 32rVUTSRQPONMLKJIHGFEDCBA9876543210 = 1459980823972598128486511383358617792788444579872.
	self assert: 33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = 128983956064237823710866404905431464703849549412368.
	self assert: 34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 11745843093701610854378775891116314824081102660800418.
	self assert: 35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 1101553773143634726491620528194292510495517905608180485.
	self assert: 36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 106300512100105327644605138221229898724869759421181854980.

	self assert: -2r10 = -2.
	self assert: -3r210 = -21.
	self assert: -4r3210 = -228.
	self assert: -5r43210 = -2930.
	self assert: -6r543210 = -44790.
	self assert: -7r6543210 = -800667.
	self assert: -8r76543210 = -16434824.
	self assert: -9r876543210 = -381367044.
	self assert: -10r9876543210 = -9876543210.
	self assert: -11rA9876543210 = -282458553905.
	self assert: -12rBA9876543210 = -8842413667692.
	self assert: -13rCBA9876543210 = -300771807240918.
	self assert: -14rDCBA9876543210 = -11046255305880158.
	self assert: -15rEDCBA9876543210 = -435659737878916215.
	self assert: -16rFEDCBA9876543210 = -18364758544493064720.
	self assert: -17rGFEDCBA9876543210 = -824008854613343261192.
	self assert: -18rHGFEDCBA9876543210 = -39210261334551566857170.
	self assert: -19rIHGFEDCBA9876543210 = -1972313422155189164466189.
	self assert: -20rJIHGFEDCBA9876543210 = -104567135734072022160664820.
	self assert: -21rKJIHGFEDCBA9876543210 = -5827980550840017565077671610.
	self assert: -22rLKJIHGFEDCBA9876543210 = -340653664490377789692799452102.
	self assert: -23rMLKJIHGFEDCBA9876543210 = -20837326537038308910317109288851.
	self assert: -24rNMLKJIHGFEDCBA9876543210 = -1331214537196502869015340298036888.
	self assert: -25rONMLKJIHGFEDCBA9876543210 = -88663644327703473714387251271141900.
	self assert: -26rPONMLKJIHGFEDCBA9876543210 = -6146269788878825859099399609538763450.
	self assert: -27rQPONMLKJIHGFEDCBA9876543210 = -442770531899482980347734468443677777577.
	self assert: -28rRQPONMLKJIHGFEDCBA9876543210 = -33100056003358651440264672384704297711484.
	self assert: -29rSRQPONMLKJIHGFEDCBA9876543210 = -2564411043271974895869785066497940850811934.
	self assert: -30rTSRQPONMLKJIHGFEDCBA9876543210 = -205646315052919334126040428061831153388822830.
	self assert: -31rUTSRQPONMLKJIHGFEDCBA9876543210 = -17050208381689099029767742314582582184093573615.
	self assert: -32rVUTSRQPONMLKJIHGFEDCBA9876543210 = -1459980823972598128486511383358617792788444579872.
	self assert: -33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = -128983956064237823710866404905431464703849549412368.
	self assert: -34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -11745843093701610854378775891116314824081102660800418.
	self assert: -35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -1101553773143634726491620528194292510495517905608180485.
	self assert: -36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -106300512100105327644605138221229898724869759421181854980.! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: 'laza 11/14/2004 00:14'!
testIntegerReadFrom
	self assert: (Integer readFrom: '123' readStream base: 10) = 123.
	self assert: (Integer readFrom: '-123' readStream base: 10) = -123.
	self assert: (Integer readFrom: 'abc' readStream base: 10) = 0.
	self assert: (Integer readFrom: 'D12' readStream base: 10) = 0.
	self assert: (Integer readFrom: '1two3' readStream base: 10) = 1.
! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: 'md 3/25/2003 23:14'!
testNew
	self should: [Integer new] raise: TestResult error. ! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: 'dtl 9/18/2004 17:14'!
testReadFrom
	"Ensure remaining characters in a stream are not lost when parsing an integer."

	| rs i s |
	rs _ ReadStream on: '123s could be confused with a ScaledDecimal'.
	i _ Number readFrom: rs.
	self assert: i == 123.
	s _ rs upToEnd.
	self assert: 's could be confused with a ScaledDecimal' = s.
	rs _ ReadStream on: '123.s could be confused with a ScaledDecimal'.
	i _ Number readFrom: rs.
	self assert: i == 123.
	s _ rs upToEnd.
	self assert: '.s could be confused with a ScaledDecimal' = s
! !

!IntegerTest methodsFor: 'tests - instance creation' stamp: 'dtl 9/18/2004 17:07'!
testStringAsNumber
	"This covers parsing in Number>>readFrom:
	Trailing decimal points should be ignored."

	self assert: ('123' asNumber == 123).
	self assert: ('-123' asNumber == -123).
	self assert: ('123.' asNumber == 123).
	self assert: ('-123.' asNumber == -123).
	self assert: ('123This is not to be read' asNumber == 123).
	self assert: ('123s could be confused with a ScaledDecimal' asNumber == 123).
	self assert: ('123e could be confused with a Float' asNumber == 123).
! !


!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 1/30/2005 14:04'!
testIntegerByteEncoded
	self assert: (ByteEncoder stream writeNumber: 2 base: 2; yourself) contents = '10'.
	self assert: (ByteEncoder stream writeNumber: 21 base: 3; yourself) contents = '210'.
	self assert: (ByteEncoder stream writeNumber: 228 base: 4; yourself) contents = '3210'.
	self assert: (ByteEncoder stream writeNumber: 2930 base: 5; yourself) contents = '43210'.
	self assert: (ByteEncoder stream writeNumber: 44790 base: 6; yourself) contents = '543210'.
	self assert: (ByteEncoder stream writeNumber: 800667 base: 7; yourself) contents = '6543210'.
	self assert: (ByteEncoder stream writeNumber: 16434824 base: 8; yourself) contents = '76543210'.
	self assert: (ByteEncoder stream writeNumber: 381367044 base: 9; yourself) contents = '876543210'.
	self assert: (ByteEncoder stream writeNumber: 9876543210 base: 10; yourself) contents = '9876543210'.
	self assert: (ByteEncoder stream writeNumber: 282458553905 base: 11; yourself) contents = 'A9876543210'.
	self assert: (ByteEncoder stream writeNumber: 8842413667692 base: 12; yourself) contents = 'BA9876543210'.
	self assert: (ByteEncoder stream writeNumber: 300771807240918 base: 13; yourself) contents = 'CBA9876543210'.
	self assert: (ByteEncoder stream writeNumber: 11046255305880158 base: 14; yourself) contents = 'DCBA9876543210'.
	self assert: (ByteEncoder stream writeNumber: 435659737878916215 base: 15; yourself) contents = 'EDCBA9876543210'.
	self assert: (ByteEncoder stream writeNumber: 18364758544493064720 base: 16; yourself) contents = 'FEDCBA9876543210'.

	self assert: (ByteEncoder stream writeNumber: -2 base: 2; yourself) contents = '-10'.
	self assert: (ByteEncoder stream writeNumber: -21 base: 3; yourself) contents = '-210'.
	self assert: (ByteEncoder stream writeNumber: -228 base: 4; yourself) contents = '-3210'.
	self assert: (ByteEncoder stream writeNumber: -2930 base: 5; yourself) contents = '-43210'.
	self assert: (ByteEncoder stream writeNumber: -44790 base: 6; yourself) contents = '-543210'.
	self assert: (ByteEncoder stream writeNumber: -800667 base: 7; yourself) contents = '-6543210'.
	self assert: (ByteEncoder stream writeNumber: -16434824 base: 8; yourself) contents = '-76543210'.
	self assert: (ByteEncoder stream writeNumber: -381367044 base: 9; yourself) contents = '-876543210'.
	self assert: (ByteEncoder stream writeNumber: -9876543210 base: 10; yourself) contents = '-9876543210'.
	self assert: (ByteEncoder stream writeNumber: -282458553905 base: 11; yourself) contents = '-A9876543210'.
	self assert: (ByteEncoder stream writeNumber: -8842413667692 base: 12; yourself) contents = '-BA9876543210'.
	self assert: (ByteEncoder stream writeNumber: -300771807240918 base: 13; yourself) contents = '-CBA9876543210'.
	self assert: (ByteEncoder stream writeNumber: -11046255305880158 base: 14; yourself) contents = '-DCBA9876543210'.
	self assert: (ByteEncoder stream writeNumber: -435659737878916215 base: 15; yourself) contents = '-EDCBA9876543210'.
	self assert: (ByteEncoder stream writeNumber: -18364758544493064720 base: 16; yourself) contents = '-FEDCBA9876543210'.! !

!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/29/2004 18:16'!
testIntegerPadding
	"self run: #testIntegerPadding"

	self assert: (1 printStringBase: 10 length: 0 padded: false) = '1'.
	self assert: (1 printStringBase: 10 length: 1 padded: false) = '1'.
	self assert: (1 printStringBase: 10 length: 2 padded: false) = ' 1'.
	self assert: (1024 printStringBase: 10 length: 19 padded: false) = '               1024'.
	self assert: (1024 printStringBase: 10 length: -1 padded: false) = '1024'.
	self assert: (1024 printStringBase: 10 length: 5 padded: false) =  ' 1024'.
	self assert: (-1024 printStringBase: 10 length: 5 padded: false) =   '-1024'.
	self assert: (-1024 printStringBase: 10 length: 19 padded: false) =  '              -1024'.

	self assert: (1 printStringBase: 10 length: 0 padded: true) = '1'.
	self assert: (1 printStringBase: 10 length: 1 padded: true) = '1'.
	self assert: (1 printStringBase: 10 length: 2 padded: true) = '01'.
	self assert: (1024 printStringBase: 10 length: 19 padded: true) = '0000000000000001024'.
	self assert: (1024 printStringBase: 10 length: -1 padded: true) = '1024'.
	self assert: (1024 printStringBase: 10 length: 5 padded: true) =  '01024'.
	self assert: (-1024 printStringBase: 10 length: 5 padded: true) =   '-1024'.
	self assert: (-1024 printStringBase: 10 length: 19 padded: true) =  '-000000000000001024'.

	self assert: (1 printStringBase: 16 length: 0 padded: false) = '1'.
	self assert: (1 printStringBase: 16 length: 1 padded: false) = '1'.
	self assert: (1 printStringBase: 16 length: 2 padded: false) = ' 1'.
	self assert: (2047 printStringBase: 16 length: 19 padded: false) =  '                7FF'.
	self assert: (2047 printStringBase: 16 length: -1 padded: false) =  '7FF'.
	self assert: (2047 printStringBase: 16 length: 4 padded: false) =  ' 7FF'.
	self assert: (-2047 printStringBase: 16 length: 4 padded: false) = '-7FF'.
	self assert: (-2047 printStringBase: 16 length: 19 padded: false) =  '               -7FF'.

	self assert: (1 printStringBase: 16 length: 0 padded: true) = '1'.
	self assert: (1 printStringBase: 16 length: 1 padded: true) = '1'.
	self assert: (1 printStringBase: 16 length: 2 padded: true) = '01'.
	self assert: (2047 printStringBase: 16 length: 19 padded: true) =  '00000000000000007FF'.
	self assert: (2047 printStringBase: 16 length: -1 padded: true) =  '7FF'.
	self assert: (2047 printStringBase: 16 length: 4 padded: true) =  '07FF'.
	self assert: (-2047 printStringBase: 16 length: 4 padded: true) = '-7FF'.
	self assert: (-2047 printStringBase: 16 length: 19 padded: true) =  '-0000000000000007FF'.

	self assert: (1 storeStringBase: 10 length: 0 padded: false) = '1'.
	self assert: (1 storeStringBase: 10 length: 1 padded: false) = '1'.
	self assert: (1 storeStringBase: 10 length: 2 padded: false) = ' 1'.
	self assert: (1024 storeStringBase: 10 length: 19 padded: false) = '               1024'.
	self assert: (1024 storeStringBase: 10 length: -1 padded: false) = '1024'.
	self assert: (1024 storeStringBase: 10 length: 5 padded: false) =  ' 1024'.
	self assert: (-1024 storeStringBase: 10 length: 5 padded: false) =   '-1024'.
	self assert: (-1024 storeStringBase: 10 length: 19 padded: false) =  '              -1024'.

	self assert: (1 storeStringBase: 10 length: 0 padded: true) = '1'.
	self assert: (1 storeStringBase: 10 length: 1 padded: true) = '1'.
	self assert: (1 storeStringBase: 10 length: 2 padded: true) = '01'.
	self assert: (1024 storeStringBase: 10 length: 19 padded: true) = '0000000000000001024'.
	self assert: (1024 storeStringBase: 10 length: -1 padded: true) = '1024'.
	self assert: (1024 storeStringBase: 10 length: 5 padded: true) =  '01024'.
	self assert: (-1024 storeStringBase: 10 length: 5 padded: true) =   '-1024'.
	self assert: (-1024 storeStringBase: 10 length: 19 padded: true) =  '-000000000000001024'.

	self assert: (1 storeStringBase: 16 length: 0 padded: false) = '16r1'.
	self assert: (1 storeStringBase: 16 length: 4 padded: false) = '16r1'.
	self assert: (1 storeStringBase: 16 length: 5 padded: false) = ' 16r1'.
	self assert: (2047 storeStringBase: 16 length: 19 padded: false) =  '             16r7FF'.
	self assert: (2047 storeStringBase: 16 length: -1 padded: false) =  '16r7FF'.
	self assert: (2047 storeStringBase: 16 length: 7 padded: false) =  ' 16r7FF'.
	self assert: (-2047 storeStringBase: 16 length: 7 padded: false) = '-16r7FF'.
	self assert: (-2047 storeStringBase: 16 length: 19 padded: false) =  '            -16r7FF'.

	self assert: (1 storeStringBase: 16 length: 0 padded: true) = '16r1'.
	self assert: (1 storeStringBase: 16 length: 4 padded: true) = '16r1'.
	self assert: (1 storeStringBase: 16 length: 5 padded: true) = '16r01'.
	self assert: (2047 storeStringBase: 16 length: 19 padded: true) =  '16r00000000000007FF'.
	self assert: (2047 storeStringBase: 16 length: -1 padded: true) =  '16r7FF'.
	self assert: (2047 storeStringBase: 16 length: 7 padded: true) =  '16r07FF'.
	self assert: (-2047 storeStringBase: 16 length: 7 padded: true) = '-16r7FF'.
	self assert: (-2047 storeStringBase: 16 length: 19 padded: true) =  '-16r0000000000007FF'.
! !

!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 14:20'!
testNegativeIntegerPrinting
	"self run: #testnegativeIntegerPrinting"

	self assert: (-2 printStringBase: 2) = '-10'.
	self assert: (-2 radix: 2) = '-10'.
	self assert: -2 printStringHex = '-2'.
	self assert: (-2 storeStringBase: 2) = '-2r10'.
	self assert: -2 storeStringHex = '-16r2'.
	self assert: (-21 printStringBase: 3) = '-210'.
	self assert: (-21 radix: 3) = '-210'.
	self assert: -21 printStringHex = '-15'.
	self assert: (-21 storeStringBase: 3) = '-3r210'.
	self assert: -21 storeStringHex = '-16r15'.
	self assert: (-228 printStringBase: 4) = '-3210'.
	self assert: (-228 radix: 4) = '-3210'.
	self assert: -228 printStringHex = '-E4'.
	self assert: (-228 storeStringBase: 4) = '-4r3210'.
	self assert: -228 storeStringHex = '-16rE4'.
	self assert: (-2930 printStringBase: 5) = '-43210'.
	self assert: (-2930 radix: 5) = '-43210'.
	self assert: -2930 printStringHex = '-B72'.
	self assert: (-2930 storeStringBase: 5) = '-5r43210'.
	self assert: -2930 storeStringHex = '-16rB72'.
	self assert: (-44790 printStringBase: 6) = '-543210'.
	self assert: (-44790 radix: 6) = '-543210'.
	self assert: -44790 printStringHex = '-AEF6'.
	self assert: (-44790 storeStringBase: 6) = '-6r543210'.
	self assert: -44790 storeStringHex = '-16rAEF6'.
	self assert: (-800667 printStringBase: 7) = '-6543210'.
	self assert: (-800667 radix: 7) = '-6543210'.
	self assert: -800667 printStringHex = '-C379B'.
	self assert: (-800667 storeStringBase: 7) = '-7r6543210'.
	self assert: -800667 storeStringHex = '-16rC379B'.
	self assert: (-16434824 printStringBase: 8) = '-76543210'.
	self assert: (-16434824 radix: 8) = '-76543210'.
	self assert: -16434824 printStringHex = '-FAC688'.
	self assert: (-16434824 storeStringBase: 8) = '-8r76543210'.
	self assert: -16434824 storeStringHex = '-16rFAC688'.
	self assert: (-381367044 printStringBase: 9) = '-876543210'.
	self assert: (-381367044 radix: 9) = '-876543210'.
	self assert: -381367044 printStringHex = '-16BB3304'.
	self assert: (-381367044 storeStringBase: 9) = '-9r876543210'.
	self assert: -381367044 storeStringHex = '-16r16BB3304'.
	self assert: (-9876543210 printStringBase: 10) = '-9876543210'.
	self assert: (-9876543210 radix: 10) = '-9876543210'.
	self assert: -9876543210 printStringHex = '-24CB016EA'.
	self assert: (-9876543210 storeStringBase: 10) = '-9876543210'.
	self assert: -9876543210 storeStringHex = '-16r24CB016EA'.
	self assert: (-282458553905 printStringBase: 11) = '-A9876543210'.
	self assert: (-282458553905 radix: 11) = '-A9876543210'.
	self assert: -282458553905 printStringHex = '-41C3D77E31'.
	self assert: (-282458553905 storeStringBase: 11) = '-11rA9876543210'.
	self assert: -282458553905 storeStringHex = '-16r41C3D77E31'.
	self assert: (-8842413667692 printStringBase: 12) = '-BA9876543210'.
	self assert: (-8842413667692 radix: 12) = '-BA9876543210'.
	self assert: -8842413667692 printStringHex = '-80AC8ECF56C'.
	self assert: (-8842413667692 storeStringBase: 12) = '-12rBA9876543210'.
	self assert: -8842413667692 storeStringHex = '-16r80AC8ECF56C'.
	self assert: (-300771807240918 printStringBase: 13) = '-CBA9876543210'.
	self assert: (-300771807240918 radix: 13) = '-CBA9876543210'.
	self assert: -300771807240918 printStringHex = '-1118CE4BAA2D6'.
	self assert: (-300771807240918 storeStringBase: 13) = '-13rCBA9876543210'.
	self assert: -300771807240918 storeStringHex = '-16r1118CE4BAA2D6'.
	self assert: (-11046255305880158 printStringBase: 14) = '-DCBA9876543210'.
	self assert: (-11046255305880158 radix: 14) = '-DCBA9876543210'.
	self assert: -11046255305880158 printStringHex = '-273E82BB9AF25E'.
	self assert: (-11046255305880158 storeStringBase: 14) = '-14rDCBA9876543210'.
	self assert: -11046255305880158 storeStringHex = '-16r273E82BB9AF25E'.
	self assert: (-435659737878916215 printStringBase: 15) = '-EDCBA9876543210'.
	self assert: (-435659737878916215 radix: 15) = '-EDCBA9876543210'.
	self assert: -435659737878916215 printStringHex = '-60BC6392F366C77'.
	self assert: (-435659737878916215 storeStringBase: 15) = '-15rEDCBA9876543210'.
	self assert: -435659737878916215 storeStringHex = '-16r60BC6392F366C77'.
	self assert: (-18364758544493064720 printStringBase: 16) = '-FEDCBA9876543210'.
	self assert: (-18364758544493064720 radix: 16) = '-FEDCBA9876543210'.
	self assert: -18364758544493064720 printStringHex = '-FEDCBA9876543210'.
	self assert: (-18364758544493064720 storeStringBase: 16) = '-16rFEDCBA9876543210'.
	self assert: -18364758544493064720 storeStringHex = '-16rFEDCBA9876543210'.
	self assert: (-824008854613343261192 printStringBase: 17) = '-GFEDCBA9876543210'.
	self assert: (-824008854613343261192 radix: 17) = '-GFEDCBA9876543210'.
	self assert: -824008854613343261192 printStringHex = '-2CAB6B877C1CD2D208'.
	self assert: (-824008854613343261192 storeStringBase: 17) = '-17rGFEDCBA9876543210'.
	self assert: -824008854613343261192 storeStringHex = '-16r2CAB6B877C1CD2D208'.
	self assert: (-39210261334551566857170 printStringBase: 18) = '-HGFEDCBA9876543210'.
	self assert: (-39210261334551566857170 radix: 18) = '-HGFEDCBA9876543210'.
	self assert: -39210261334551566857170 printStringHex = '-84D97AFCAE81415B3D2'.
	self assert: (-39210261334551566857170 storeStringBase: 18) = '-18rHGFEDCBA9876543210'.
	self assert: -39210261334551566857170 storeStringHex = '-16r84D97AFCAE81415B3D2'.
	self assert: (-1972313422155189164466189 printStringBase: 19) = '-IHGFEDCBA9876543210'.
	self assert: (-1972313422155189164466189 radix: 19) = '-IHGFEDCBA9876543210'.
	self assert: -1972313422155189164466189 printStringHex = '-1A1A75329C5C6FC00600D'.
	self assert: (-1972313422155189164466189 storeStringBase: 19) = '-19rIHGFEDCBA9876543210'.
	self assert: -1972313422155189164466189 storeStringHex = '-16r1A1A75329C5C6FC00600D'.
	self assert: (-104567135734072022160664820 printStringBase: 20) = '-JIHGFEDCBA9876543210'.
	self assert: (-104567135734072022160664820 radix: 20) = '-JIHGFEDCBA9876543210'.
	self assert: -104567135734072022160664820 printStringHex = '-567EF3C9636D242A8C68F4'.
	self assert: (-104567135734072022160664820 storeStringBase: 20) = '-20rJIHGFEDCBA9876543210'.
	self assert: -104567135734072022160664820 storeStringHex = '-16r567EF3C9636D242A8C68F4'.
	self assert: (-5827980550840017565077671610 printStringBase: 21) = '-KJIHGFEDCBA9876543210'.
	self assert: (-5827980550840017565077671610 radix: 21) = '-KJIHGFEDCBA9876543210'.
	self assert: -5827980550840017565077671610 printStringHex = '-12D4CAE2B8A09BCFDBE30EBA'.
	self assert: (-5827980550840017565077671610 storeStringBase: 21) = '-21rKJIHGFEDCBA9876543210'.
	self assert: -5827980550840017565077671610 storeStringHex = '-16r12D4CAE2B8A09BCFDBE30EBA'.
	self assert: (-340653664490377789692799452102 printStringBase: 22) = '-LKJIHGFEDCBA9876543210'.
	self assert: (-340653664490377789692799452102 radix: 22) = '-LKJIHGFEDCBA9876543210'.
	self assert: -340653664490377789692799452102 printStringHex = '-44CB61B5B47E1A5D8F88583C6'.
	self assert: (-340653664490377789692799452102 storeStringBase: 22) = '-22rLKJIHGFEDCBA9876543210'.
	self assert: -340653664490377789692799452102 storeStringHex = '-16r44CB61B5B47E1A5D8F88583C6'.
	self assert: (-20837326537038308910317109288851 printStringBase: 23) = '-MLKJIHGFEDCBA9876543210'.
	self assert: (-20837326537038308910317109288851 radix: 23) = '-MLKJIHGFEDCBA9876543210'.
	self assert: -20837326537038308910317109288851 printStringHex = '-1070108876456E0EF115B389F93'.
	self assert: (-20837326537038308910317109288851 storeStringBase: 23) = '-23rMLKJIHGFEDCBA9876543210'.
	self assert: -20837326537038308910317109288851 storeStringHex = '-16r1070108876456E0EF115B389F93'.
	self assert: (-1331214537196502869015340298036888 printStringBase: 24) = '-NMLKJIHGFEDCBA9876543210'.
	self assert: (-1331214537196502869015340298036888 radix: 24) = '-NMLKJIHGFEDCBA9876543210'.
	self assert: -1331214537196502869015340298036888 printStringHex = '-41A24A285154B026B6ED206C6698'.
	self assert: (-1331214537196502869015340298036888 storeStringBase: 24) = '-24rNMLKJIHGFEDCBA9876543210'.
	self assert: -1331214537196502869015340298036888 storeStringHex = '-16r41A24A285154B026B6ED206C6698'.
	self assert: (-88663644327703473714387251271141900 printStringBase: 25) = '-ONMLKJIHGFEDCBA9876543210'.
	self assert: (-88663644327703473714387251271141900 radix: 25) = '-ONMLKJIHGFEDCBA9876543210'.
	self assert: -88663644327703473714387251271141900 printStringHex = '-111374860A2C6CEBE5999630398A0C'.
	self assert: (-88663644327703473714387251271141900 storeStringBase: 25) = '-25rONMLKJIHGFEDCBA9876543210'.
	self assert: -88663644327703473714387251271141900 storeStringHex = '-16r111374860A2C6CEBE5999630398A0C'.
	self assert: (-6146269788878825859099399609538763450 printStringBase: 26) = '-PONMLKJIHGFEDCBA9876543210'.
	self assert: (-6146269788878825859099399609538763450 radix: 26) = '-PONMLKJIHGFEDCBA9876543210'.
	self assert: -6146269788878825859099399609538763450 printStringHex = '-49FBA7F30B0F48BD14E6A99BD8ADABA'.
	self assert: (-6146269788878825859099399609538763450 storeStringBase: 26) = '-26rPONMLKJIHGFEDCBA9876543210'.
	self assert: -6146269788878825859099399609538763450 storeStringHex = '-16r49FBA7F30B0F48BD14E6A99BD8ADABA'.
	self assert: (-442770531899482980347734468443677777577 printStringBase: 27) = '-QPONMLKJIHGFEDCBA9876543210'.
	self assert: (-442770531899482980347734468443677777577 radix: 27) = '-QPONMLKJIHGFEDCBA9876543210'.
	self assert: -442770531899482980347734468443677777577 printStringHex = '-14D1A80A997343640C1145A073731DEA9'.
	self assert: (-442770531899482980347734468443677777577 storeStringBase: 27) = '-27rQPONMLKJIHGFEDCBA9876543210'.
	self assert: -442770531899482980347734468443677777577 storeStringHex = '-16r14D1A80A997343640C1145A073731DEA9'.
	self assert: (-33100056003358651440264672384704297711484 printStringBase: 28) = '-RQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-33100056003358651440264672384704297711484 radix: 28) = '-RQPONMLKJIHGFEDCBA9876543210'.
	self assert: -33100056003358651440264672384704297711484 printStringHex = '-6145B6E6DACFA25D0E936F51D25932377C'.
	self assert: (-33100056003358651440264672384704297711484 storeStringBase: 28) = '-28rRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -33100056003358651440264672384704297711484 storeStringHex = '-16r6145B6E6DACFA25D0E936F51D25932377C'.
	self assert: (-2564411043271974895869785066497940850811934 printStringBase: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-2564411043271974895869785066497940850811934 radix: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -2564411043271974895869785066497940850811934 printStringHex = '-1D702071CBA4A1597D4DD37E95EFAC79241E'.
	self assert: (-2564411043271974895869785066497940850811934 storeStringBase: 29) = '-29rSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -2564411043271974895869785066497940850811934 storeStringHex = '-16r1D702071CBA4A1597D4DD37E95EFAC79241E'.
	self assert: (-205646315052919334126040428061831153388822830 printStringBase: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-205646315052919334126040428061831153388822830 radix: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -205646315052919334126040428061831153388822830 printStringHex = '-938B4343B54B550989989D02998718FFB212E'.
	self assert: (-205646315052919334126040428061831153388822830 storeStringBase: 30) = '-30rTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -205646315052919334126040428061831153388822830 storeStringHex = '-16r938B4343B54B550989989D02998718FFB212E'.
	self assert: (-17050208381689099029767742314582582184093573615 printStringBase: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-17050208381689099029767742314582582184093573615 radix: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -17050208381689099029767742314582582184093573615 printStringHex = '-2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
	self assert: (-17050208381689099029767742314582582184093573615 storeStringBase: 31) = '-31rUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -17050208381689099029767742314582582184093573615 storeStringHex = '-16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
	self assert: (-1459980823972598128486511383358617792788444579872 printStringBase: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-1459980823972598128486511383358617792788444579872 radix: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -1459980823972598128486511383358617792788444579872 printStringHex = '-FFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
	self assert: (-1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '-32rVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -1459980823972598128486511383358617792788444579872 storeStringHex = '-16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
	self assert: (-128983956064237823710866404905431464703849549412368 printStringBase: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-128983956064237823710866404905431464703849549412368 radix: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -128983956064237823710866404905431464703849549412368 printStringHex = '-584120A0328DE272AB055A8AA003CE4A559F223810'.
	self assert: (-128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '-33rWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -128983956064237823710866404905431464703849549412368 storeStringHex = '-16r584120A0328DE272AB055A8AA003CE4A559F223810'.
	self assert: (-11745843093701610854378775891116314824081102660800418 printStringBase: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-11745843093701610854378775891116314824081102660800418 radix: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -11745843093701610854378775891116314824081102660800418 printStringHex = '-1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
	self assert: (-11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '-34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -11745843093701610854378775891116314824081102660800418 storeStringHex = '-16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
	self assert: (-1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-1101553773143634726491620528194292510495517905608180485 radix: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -1101553773143634726491620528194292510495517905608180485 printStringHex = '-B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
	self assert: (-1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '-35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -1101553773143634726491620528194292510495517905608180485 storeStringHex = '-16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
	self assert: (-106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (-106300512100105327644605138221229898724869759421181854980 radix: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -106300512100105327644605138221229898724869759421181854980 printStringHex = '-455D441E55A37239AB4C303189576071AF5578FFCA80504'.
	self assert: (-106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '-36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: -106300512100105327644605138221229898724869759421181854980 storeStringHex = '-16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! !

!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 11:52'!
testPositiveIntegerPrinting
	"self run: #testPositiveIntegerPrinting"

	self assert: 0 printString = '0'.
	self assert: 0 printStringHex = '0'.
	self assert: 0 storeStringHex = '16r0'.

	self assert: (2 printStringBase: 2) = '10'.
	self assert: (2 radix: 2) = '10'.
	self assert: 2 printStringHex = '2'.
	self assert: (2 storeStringBase: 2) = '2r10'.
	self assert: 2 storeStringHex = '16r2'.
	self assert: (21 printStringBase: 3) = '210'.
	self assert: (21 radix: 3) = '210'.
	self assert: 21 printStringHex = '15'.
	self assert: (21 storeStringBase: 3) = '3r210'.
	self assert: 21 storeStringHex = '16r15'.
	self assert: (228 printStringBase: 4) = '3210'.
	self assert: (228 radix: 4) = '3210'.
	self assert: 228 printStringHex = 'E4'.
	self assert: (228 storeStringBase: 4) = '4r3210'.
	self assert: 228 storeStringHex = '16rE4'.
	self assert: (2930 printStringBase: 5) = '43210'.
	self assert: (2930 radix: 5) = '43210'.
	self assert: 2930 printStringHex = 'B72'.
	self assert: (2930 storeStringBase: 5) = '5r43210'.
	self assert: 2930 storeStringHex = '16rB72'.
	self assert: (44790 printStringBase: 6) = '543210'.
	self assert: (44790 radix: 6) = '543210'.
	self assert: 44790 printStringHex = 'AEF6'.
	self assert: (44790 storeStringBase: 6) = '6r543210'.
	self assert: 44790 storeStringHex = '16rAEF6'.
	self assert: (800667 printStringBase: 7) = '6543210'.
	self assert: (800667 radix: 7) = '6543210'.
	self assert: 800667 printStringHex = 'C379B'.
	self assert: (800667 storeStringBase: 7) = '7r6543210'.
	self assert: 800667 storeStringHex = '16rC379B'.
	self assert: (16434824 printStringBase: 8) = '76543210'.
	self assert: (16434824 radix: 8) = '76543210'.
	self assert: 16434824 printStringHex = 'FAC688'.
	self assert: (16434824 storeStringBase: 8) = '8r76543210'.
	self assert: 16434824 storeStringHex = '16rFAC688'.
	self assert: (381367044 printStringBase: 9) = '876543210'.
	self assert: (381367044 radix: 9) = '876543210'.
	self assert: 381367044 printStringHex = '16BB3304'.
	self assert: (381367044 storeStringBase: 9) = '9r876543210'.
	self assert: 381367044 storeStringHex = '16r16BB3304'.
	self assert: (9876543210 printStringBase: 10) = '9876543210'.
	self assert: (9876543210 radix: 10) = '9876543210'.
	self assert: 9876543210 printStringHex = '24CB016EA'.
	self assert: (9876543210 storeStringBase: 10) = '9876543210'.
	self assert: 9876543210 storeStringHex = '16r24CB016EA'.
	self assert: (282458553905 printStringBase: 11) = 'A9876543210'.
	self assert: (282458553905 radix: 11) = 'A9876543210'.
	self assert: 282458553905 printStringHex = '41C3D77E31'.
	self assert: (282458553905 storeStringBase: 11) = '11rA9876543210'.
	self assert: 282458553905 storeStringHex = '16r41C3D77E31'.
	self assert: (8842413667692 printStringBase: 12) = 'BA9876543210'.
	self assert: (8842413667692 radix: 12) = 'BA9876543210'.
	self assert: 8842413667692 printStringHex = '80AC8ECF56C'.
	self assert: (8842413667692 storeStringBase: 12) = '12rBA9876543210'.
	self assert: 8842413667692 storeStringHex = '16r80AC8ECF56C'.
	self assert: (300771807240918 printStringBase: 13) = 'CBA9876543210'.
	self assert: (300771807240918 radix: 13) = 'CBA9876543210'.
	self assert: 300771807240918 printStringHex = '1118CE4BAA2D6'.
	self assert: (300771807240918 storeStringBase: 13) = '13rCBA9876543210'.
	self assert: 300771807240918 storeStringHex = '16r1118CE4BAA2D6'.
	self assert: (11046255305880158 printStringBase: 14) = 'DCBA9876543210'.
	self assert: (11046255305880158 radix: 14) = 'DCBA9876543210'.
	self assert: 11046255305880158 printStringHex = '273E82BB9AF25E'.
	self assert: (11046255305880158 storeStringBase: 14) = '14rDCBA9876543210'.
	self assert: 11046255305880158 storeStringHex = '16r273E82BB9AF25E'.
	self assert: (435659737878916215 printStringBase: 15) = 'EDCBA9876543210'.
	self assert: (435659737878916215 radix: 15) = 'EDCBA9876543210'.
	self assert: 435659737878916215 printStringHex = '60BC6392F366C77'.
	self assert: (435659737878916215 storeStringBase: 15) = '15rEDCBA9876543210'.
	self assert: 435659737878916215 storeStringHex = '16r60BC6392F366C77'.
	self assert: (18364758544493064720 printStringBase: 16) = 'FEDCBA9876543210'.
	self assert: (18364758544493064720 radix: 16) = 'FEDCBA9876543210'.
	self assert: 18364758544493064720 printStringHex = 'FEDCBA9876543210'.
	self assert: (18364758544493064720 storeStringBase: 16) = '16rFEDCBA9876543210'.
	self assert: 18364758544493064720 storeStringHex = '16rFEDCBA9876543210'.
	self assert: (824008854613343261192 printStringBase: 17) = 'GFEDCBA9876543210'.
	self assert: (824008854613343261192 radix: 17) = 'GFEDCBA9876543210'.
	self assert: 824008854613343261192 printStringHex = '2CAB6B877C1CD2D208'.
	self assert: (824008854613343261192 storeStringBase: 17) = '17rGFEDCBA9876543210'.
	self assert: 824008854613343261192 storeStringHex = '16r2CAB6B877C1CD2D208'.
	self assert: (39210261334551566857170 printStringBase: 18) = 'HGFEDCBA9876543210'.
	self assert: (39210261334551566857170 radix: 18) = 'HGFEDCBA9876543210'.
	self assert: 39210261334551566857170 printStringHex = '84D97AFCAE81415B3D2'.
	self assert: (39210261334551566857170 storeStringBase: 18) = '18rHGFEDCBA9876543210'.
	self assert: 39210261334551566857170 storeStringHex = '16r84D97AFCAE81415B3D2'.
	self assert: (1972313422155189164466189 printStringBase: 19) = 'IHGFEDCBA9876543210'.
	self assert: (1972313422155189164466189 radix: 19) = 'IHGFEDCBA9876543210'.
	self assert: 1972313422155189164466189 printStringHex = '1A1A75329C5C6FC00600D'.
	self assert: (1972313422155189164466189 storeStringBase: 19) = '19rIHGFEDCBA9876543210'.
	self assert: 1972313422155189164466189 storeStringHex = '16r1A1A75329C5C6FC00600D'.
	self assert: (104567135734072022160664820 printStringBase: 20) = 'JIHGFEDCBA9876543210'.
	self assert: (104567135734072022160664820 radix: 20) = 'JIHGFEDCBA9876543210'.
	self assert: 104567135734072022160664820 printStringHex = '567EF3C9636D242A8C68F4'.
	self assert: (104567135734072022160664820 storeStringBase: 20) = '20rJIHGFEDCBA9876543210'.
	self assert: 104567135734072022160664820 storeStringHex = '16r567EF3C9636D242A8C68F4'.
	self assert: (5827980550840017565077671610 printStringBase: 21) = 'KJIHGFEDCBA9876543210'.
	self assert: (5827980550840017565077671610 radix: 21) = 'KJIHGFEDCBA9876543210'.
	self assert: 5827980550840017565077671610 printStringHex = '12D4CAE2B8A09BCFDBE30EBA'.
	self assert: (5827980550840017565077671610 storeStringBase: 21) = '21rKJIHGFEDCBA9876543210'.
	self assert: 5827980550840017565077671610 storeStringHex = '16r12D4CAE2B8A09BCFDBE30EBA'.
	self assert: (340653664490377789692799452102 printStringBase: 22) = 'LKJIHGFEDCBA9876543210'.
	self assert: (340653664490377789692799452102 radix: 22) = 'LKJIHGFEDCBA9876543210'.
	self assert: 340653664490377789692799452102 printStringHex = '44CB61B5B47E1A5D8F88583C6'.
	self assert: (340653664490377789692799452102 storeStringBase: 22) = '22rLKJIHGFEDCBA9876543210'.
	self assert: 340653664490377789692799452102 storeStringHex = '16r44CB61B5B47E1A5D8F88583C6'.
	self assert: (20837326537038308910317109288851 printStringBase: 23) = 'MLKJIHGFEDCBA9876543210'.
	self assert: (20837326537038308910317109288851 radix: 23) = 'MLKJIHGFEDCBA9876543210'.
	self assert: 20837326537038308910317109288851 printStringHex = '1070108876456E0EF115B389F93'.
	self assert: (20837326537038308910317109288851 storeStringBase: 23) = '23rMLKJIHGFEDCBA9876543210'.
	self assert: 20837326537038308910317109288851 storeStringHex = '16r1070108876456E0EF115B389F93'.
	self assert: (1331214537196502869015340298036888 printStringBase: 24) = 'NMLKJIHGFEDCBA9876543210'.
	self assert: (1331214537196502869015340298036888 radix: 24) = 'NMLKJIHGFEDCBA9876543210'.
	self assert: 1331214537196502869015340298036888 printStringHex = '41A24A285154B026B6ED206C6698'.
	self assert: (1331214537196502869015340298036888 storeStringBase: 24) = '24rNMLKJIHGFEDCBA9876543210'.
	self assert: 1331214537196502869015340298036888 storeStringHex = '16r41A24A285154B026B6ED206C6698'.
	self assert: (88663644327703473714387251271141900 printStringBase: 25) = 'ONMLKJIHGFEDCBA9876543210'.
	self assert: (88663644327703473714387251271141900 radix: 25) = 'ONMLKJIHGFEDCBA9876543210'.
	self assert: 88663644327703473714387251271141900 printStringHex = '111374860A2C6CEBE5999630398A0C'.
	self assert: (88663644327703473714387251271141900 storeStringBase: 25) = '25rONMLKJIHGFEDCBA9876543210'.
	self assert: 88663644327703473714387251271141900 storeStringHex = '16r111374860A2C6CEBE5999630398A0C'.
	self assert: (6146269788878825859099399609538763450 printStringBase: 26) = 'PONMLKJIHGFEDCBA9876543210'.
	self assert: (6146269788878825859099399609538763450 radix: 26) = 'PONMLKJIHGFEDCBA9876543210'.
	self assert: 6146269788878825859099399609538763450 printStringHex = '49FBA7F30B0F48BD14E6A99BD8ADABA'.
	self assert: (6146269788878825859099399609538763450 storeStringBase: 26) = '26rPONMLKJIHGFEDCBA9876543210'.
	self assert: 6146269788878825859099399609538763450 storeStringHex = '16r49FBA7F30B0F48BD14E6A99BD8ADABA'.
	self assert: (442770531899482980347734468443677777577 printStringBase: 27) = 'QPONMLKJIHGFEDCBA9876543210'.
	self assert: (442770531899482980347734468443677777577 radix: 27) = 'QPONMLKJIHGFEDCBA9876543210'.
	self assert: 442770531899482980347734468443677777577 printStringHex = '14D1A80A997343640C1145A073731DEA9'.
	self assert: (442770531899482980347734468443677777577 storeStringBase: 27) = '27rQPONMLKJIHGFEDCBA9876543210'.
	self assert: 442770531899482980347734468443677777577 storeStringHex = '16r14D1A80A997343640C1145A073731DEA9'.
	self assert: (33100056003358651440264672384704297711484 printStringBase: 28) = 'RQPONMLKJIHGFEDCBA9876543210'.
	self assert: (33100056003358651440264672384704297711484 radix: 28) = 'RQPONMLKJIHGFEDCBA9876543210'.
	self assert: 33100056003358651440264672384704297711484 printStringHex = '6145B6E6DACFA25D0E936F51D25932377C'.
	self assert: (33100056003358651440264672384704297711484 storeStringBase: 28) = '28rRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 33100056003358651440264672384704297711484 storeStringHex = '16r6145B6E6DACFA25D0E936F51D25932377C'.
	self assert: (2564411043271974895869785066497940850811934 printStringBase: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (2564411043271974895869785066497940850811934 radix: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 2564411043271974895869785066497940850811934 printStringHex = '1D702071CBA4A1597D4DD37E95EFAC79241E'.
	self assert: (2564411043271974895869785066497940850811934 storeStringBase: 29) = '29rSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 2564411043271974895869785066497940850811934 storeStringHex = '16r1D702071CBA4A1597D4DD37E95EFAC79241E'.
	self assert: (205646315052919334126040428061831153388822830 printStringBase: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (205646315052919334126040428061831153388822830 radix: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 205646315052919334126040428061831153388822830 printStringHex = '938B4343B54B550989989D02998718FFB212E'.
	self assert: (205646315052919334126040428061831153388822830 storeStringBase: 30) = '30rTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 205646315052919334126040428061831153388822830 storeStringHex = '16r938B4343B54B550989989D02998718FFB212E'.
	self assert: (17050208381689099029767742314582582184093573615 printStringBase: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (17050208381689099029767742314582582184093573615 radix: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 17050208381689099029767742314582582184093573615 printStringHex = '2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
	self assert: (17050208381689099029767742314582582184093573615 storeStringBase: 31) = '31rUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 17050208381689099029767742314582582184093573615 storeStringHex = '16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
	self assert: (1459980823972598128486511383358617792788444579872 printStringBase: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (1459980823972598128486511383358617792788444579872 radix: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 1459980823972598128486511383358617792788444579872 printStringHex = 'FFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
	self assert: (1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '32rVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 1459980823972598128486511383358617792788444579872 storeStringHex = '16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
	self assert: (128983956064237823710866404905431464703849549412368 printStringBase: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (128983956064237823710866404905431464703849549412368 radix: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 128983956064237823710866404905431464703849549412368 printStringHex = '584120A0328DE272AB055A8AA003CE4A559F223810'.
	self assert: (128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '33rWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 128983956064237823710866404905431464703849549412368 storeStringHex = '16r584120A0328DE272AB055A8AA003CE4A559F223810'.
	self assert: (11745843093701610854378775891116314824081102660800418 printStringBase: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (11745843093701610854378775891116314824081102660800418 radix: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 11745843093701610854378775891116314824081102660800418 printStringHex = '1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
	self assert: (11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 11745843093701610854378775891116314824081102660800418 storeStringHex = '16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
	self assert: (1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (1101553773143634726491620528194292510495517905608180485 radix: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 1101553773143634726491620528194292510495517905608180485 printStringHex = 'B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
	self assert: (1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 1101553773143634726491620528194292510495517905608180485 storeStringHex = '16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
	self assert: (106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: (106300512100105327644605138221229898724869759421181854980 radix: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 106300512100105327644605138221229898724869759421181854980 printStringHex = '455D441E55A37239AB4C303189576071AF5578FFCA80504'.
	self assert: (106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
	self assert: 106300512100105327644605138221229898724869759421181854980 storeStringHex = '16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! !

!IntegerTest methodsFor: 'tests - printing' stamp: 'fbs 2/9/2006 08:48'!
testPrintOnBaseShowRadix
	| s |
	s := ReadWriteStream on: ''.
	123 printOn: s base: 10 showRadix: false.
	self assert: (s contents = '123').
	
	s := ReadWriteStream on: ''.
	123 printOn: s base: 10 showRadix: true.
	self assert: (s contents = '10r123').
	
	s := ReadWriteStream on: ''.
	123 printOn: s base: 8 showRadix: false.
	self assert: (s contents = '173').
	
	s := ReadWriteStream on: ''.
	123 printOn: s base: 8 showRadix: true.
	self assert: (s contents = '8r173').! !

!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 09:23'!
testRomanPrinting
	self assert: 0 printStringRoman = ''. "No symbol for zero"
	self assert: 1 printStringRoman = 'I'.
	self assert: 2 printStringRoman = 'II'.
	self assert: 3 printStringRoman = 'III'.
	self assert: 4 printStringRoman = 'IV'.
	self assert: 5 printStringRoman = 'V'.
	self assert: 6 printStringRoman = 'VI'.
	self assert: 7 printStringRoman = 'VII'.
	self assert: 8 printStringRoman = 'VIII'.
	self assert: 9 printStringRoman = 'IX'.
	self assert: 10 printStringRoman = 'X'.
	self assert: 23 printStringRoman = 'XXIII'.
	self assert: 36 printStringRoman = 'XXXVI'.
	self assert: 49 printStringRoman = 'XLIX'.
	self assert: 62 printStringRoman = 'LXII'.
	self assert: 75 printStringRoman = 'LXXV'.
	self assert: 88 printStringRoman = 'LXXXVIII'.
	self assert: 99 printStringRoman = 'XCIX'.
	self assert: 100 printStringRoman = 'C'.
	self assert: 101 printStringRoman = 'CI'.
	self assert: 196 printStringRoman = 'CXCVI'.
	self assert: 197 printStringRoman = 'CXCVII'.
	self assert: 198 printStringRoman = 'CXCVIII'.
	self assert: 293 printStringRoman = 'CCXCIII'.
	self assert: 294 printStringRoman = 'CCXCIV'.
	self assert: 295 printStringRoman = 'CCXCV'.
	self assert: 390 printStringRoman = 'CCCXC'.
	self assert: 391 printStringRoman = 'CCCXCI'.
	self assert: 392 printStringRoman = 'CCCXCII'.
	self assert: 487 printStringRoman = 'CDLXXXVII'.
	self assert: 488 printStringRoman = 'CDLXXXVIII'.
	self assert: 489 printStringRoman = 'CDLXXXIX'.
	self assert: 584 printStringRoman = 'DLXXXIV'.
	self assert: 585 printStringRoman = 'DLXXXV'.
	self assert: 586 printStringRoman = 'DLXXXVI'.
	self assert: 681 printStringRoman = 'DCLXXXI'.
	self assert: 682 printStringRoman = 'DCLXXXII'.
	self assert: 683 printStringRoman = 'DCLXXXIII'.
	self assert: 778 printStringRoman = 'DCCLXXVIII'.
	self assert: 779 printStringRoman = 'DCCLXXIX'.
	self assert: 780 printStringRoman = 'DCCLXXX'.
	self assert: 875 printStringRoman = 'DCCCLXXV'.
	self assert: 876 printStringRoman = 'DCCCLXXVI'.
	self assert: 877 printStringRoman = 'DCCCLXXVII'.
	self assert: 972 printStringRoman = 'CMLXXII'.
	self assert: 973 printStringRoman = 'CMLXXIII'.
	self assert: 974 printStringRoman = 'CMLXXIV'.
	self assert: 1069 printStringRoman = 'MLXIX'.
	self assert: 1070 printStringRoman = 'MLXX'.
	self assert: 1071 printStringRoman = 'MLXXI'.
	self assert: 1166 printStringRoman = 'MCLXVI'.
	self assert: 1167 printStringRoman = 'MCLXVII'.
	self assert: 1168 printStringRoman = 'MCLXVIII'.
	self assert: 1263 printStringRoman = 'MCCLXIII'.
	self assert: 1264 printStringRoman = 'MCCLXIV'.
	self assert: 1265 printStringRoman = 'MCCLXV'.
	self assert: 1360 printStringRoman = 'MCCCLX'.
	self assert: 1361 printStringRoman = 'MCCCLXI'.
	self assert: 1362 printStringRoman = 'MCCCLXII'.
	self assert: 1457 printStringRoman = 'MCDLVII'.
	self assert: 1458 printStringRoman = 'MCDLVIII'.
	self assert: 1459 printStringRoman = 'MCDLIX'.
	self assert: 1554 printStringRoman = 'MDLIV'.
	self assert: 1555 printStringRoman = 'MDLV'.
	self assert: 1556 printStringRoman = 'MDLVI'.
	self assert: 1651 printStringRoman = 'MDCLI'.
	self assert: 1652 printStringRoman = 'MDCLII'.
	self assert: 1653 printStringRoman = 'MDCLIII'.
	self assert: 1748 printStringRoman = 'MDCCXLVIII'.
	self assert: 1749 printStringRoman = 'MDCCXLIX'.
	self assert: 1750 printStringRoman = 'MDCCL'.
	self assert: 1845 printStringRoman = 'MDCCCXLV'.
	self assert: 1846 printStringRoman = 'MDCCCXLVI'.
	self assert: 1847 printStringRoman = 'MDCCCXLVII'.
	self assert: 1942 printStringRoman = 'MCMXLII'.
	self assert: 1943 printStringRoman = 'MCMXLIII'.
	self assert: 1944 printStringRoman = 'MCMXLIV'.
	self assert: 2004 printStringRoman = 'MMIV'.

	self assert: -1 printStringRoman = '-I'.
	self assert: -2 printStringRoman = '-II'.
	self assert: -3 printStringRoman = '-III'.
	self assert: -4 printStringRoman = '-IV'.
	self assert: -5 printStringRoman = '-V'.
	self assert: -6 printStringRoman = '-VI'.
	self assert: -7 printStringRoman = '-VII'.
	self assert: -8 printStringRoman = '-VIII'.
	self assert: -9 printStringRoman = '-IX'.
	self assert: -10 printStringRoman = '-X'.
! !


!IntegerTest methodsFor: 'testing - arithmetic' stamp: 'mga 5/11/2006 15:41'!
testCrossSumBase
	"self run: #testCrossSumBase"

	self assert: (
		((-20 to: 20) collect: [:each | each crossSumBase: 10]) asArray = 
		#(2 10 9 8 7 6 5 4 3 2 1 9 8 7 6 5 4 3 2 1 0 1 2 3 4 5 6 7 8 9 1 2 3 4 5 6 7 8 9 10 2)).
	self assert: (
		((-20 to: 20) collect: [:each | each crossSumBase: 2]) asArray = 
		#(2 3 2 2 1 4 3 3 2 3 2 2 1 3 2 2 1 2 1 1 0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4 1 2 2 3 2)).
	self should: [10 crossSumBase: 1] raise: AssertionFailure! !
RectangleMorph subclass: #InterimSoundMorph
	instanceVariableNames: 'graphic sound'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'di 2/17/2000 20:30'!
addGraphic

	graphic _ SketchMorph withForm: self speakerGraphic.
	graphic position: bounds center - (graphic extent // 2).
	self addMorph: graphic.
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/18/97 15:02'!
sound

	^ sound
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/18/97 15:01'!
sound: aSound

	sound _ aSound.
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/18/97 15:20'!
speakerGraphic

	^ Form
		extent: 19@18
		depth: 8
		fromArray: #(0 0 1493172224 2816 0 0 0 1493172224 11 0 0 138 1493172224 184549376 184549376 0 35509 2315255808 720896 720896 0 9090522 2315255808 2816 720896 0 2327173887 2315255819 2816 720896 138 3051028442 2315255819 2816 2816 1505080590 4294957786 2315255808 184549387 2816 3053453311 4292532917 1493172224 184549387 2816 1505080714 3048584629 1493172224 184549387 2816 9079434 3048584629 1493172224 184549387 2816 138 2327164341 1493172235 2816 2816 0 2324346293 1493172235 2816 720896 0 9079477 1493172224 2816 720896 0 35466 1493172224 720896 720896 0 138 0 184549376 184549376 0 0 0 11 0 0 0 0 2816 0)
		offset: 0@0
! !


!InterimSoundMorph methodsFor: 'event handling' stamp: 'jm 9/18/97 15:26'!
handlesMouseDown: evt

	(graphic containsPoint: evt cursorPoint)
		ifTrue: [^ true]
		ifFalse: [^ super handlesMouseDown: evt].
! !

!InterimSoundMorph methodsFor: 'event handling' stamp: 'jm 9/18/97 18:56'!
mouseDown: evt

	(graphic containsPoint: evt cursorPoint)
		ifTrue: [sound copy play]
		ifFalse: [super mouseDown: evt].
! !


!InterimSoundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

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

!InterimSoundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:57'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self extent: 30 @ 30.
	self addGraphic.
	sound _ PluckedSound
				pitch: 880.0
				dur: 2.0
				loudness: 0.5! !
ThreadNavigationMorph subclass: #InternalThreadNavigationMorph
	instanceVariableNames: 'threadName preferredIndex'
	classVariableNames: 'CachedThumbnails KnownThreads'
	poolDictionaries: ''
	category: 'MorphicExtras-Navigators'!

!InternalThreadNavigationMorph methodsFor: 'accessing' stamp: 'dgd 11/29/2003 17:35'!
sizeRatio
	"answer the size ratio for the receiver"
	
	^ Preferences standardMenuFont height / 12! !


!InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 11/29/2003 17:35'!
addButtons

	| marginPt i sz data images pageNumber f m b1 b2 dot arrowWidth arrowCenter vertices arrowHeight nameMorph sizeRatio controlsColor |

	sizeRatio _ self sizeRatio.
	controlsColor _ Color orange lighter.

	self changeNoLayout.
	self hResizing: #rigid.
	self vResizing: #rigid.
	marginPt _ (4 @ 4 * sizeRatio) rounded..
	i _ self currentIndex.
	sz _ self myThumbnailSize.
	arrowWidth _ (14 * sizeRatio) rounded.
	arrowHeight _ (14 * sizeRatio) rounded.
	data _ {
		{i - 1. 'Previous:'. #previousPage. #leftCenter. arrowWidth. 'Prev'}.
		{i + 1. 'Next:'. #nextPage. #rightCenter. arrowWidth negated. 'Next'}
	}.
	images _ data collect: [ :tuple |
		pageNumber _ tuple first.
		(pageNumber between: 1 and: listOfPages size) ifTrue: [
			f _ self 
				makeThumbnailForPageNumber: pageNumber 
				scaledToSize: sz 
				default: tuple sixth.
			f _ f deepCopy.		"we're going to mess it up"
			arrowCenter _ f boundingBox perform: tuple fourth.
			vertices _ {
				arrowCenter + (tuple fifth @ arrowHeight negated).
				arrowCenter + (tuple fifth @ arrowHeight).
				arrowCenter.
			}.
			f getCanvas
				drawPolygon: vertices 
				color: controlsColor
				borderWidth: 0 
				borderColor: Color transparent.
			m _ ImageMorph new image: f.
			m setBalloonText: tuple second translated,' ',(listOfPages at: pageNumber) first.
			m addMouseUpActionWith: (
				MessageSend receiver: self selector: tuple third
			).
		] ifFalse: [
			f _ (Form extent: sz depth: 16) fillColor: Color lightGray.
			m _ ImageMorph new image: f.
		].
		m
	].
	b1 _ images first.
	b2 _ images second.
	dot _ EllipseMorph new extent: (18@18 * sizeRatio) rounded; color: controlsColor; borderWidth: 0.

	self addMorph: (b1 position: self position + marginPt).
	self addMorph: (b2 position: b1 topRight + (marginPt x @ 0)).

	self extent: (b1 bottomRight max: b2 bottomRight) - self position + marginPt.
	self addMorph: dot.
	dot align: dot center with: b1 bounds rightCenter + ((marginPt x @ 0) // 2).
	dot setBalloonText: threadName,'
more commands'.
	dot on: #mouseDown send: #moreCommands to: self.
	self fullBounds.
	self addMorph: (nameMorph _ SquishedNameMorph new).
	nameMorph
		target: self getSelector: #threadName setSelector: nil;
		color: Color transparent;
		width: self width;
		height: (15 * sizeRatio) rounded;
		align: nameMorph bottomLeft with: self bottomLeft.

! !

!InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 10/26/2003 19:06'!
defaultColor
	"answer the default color/fill style for the receiver"
	^(Color r: 0.27 g: 0.634 b: 0.365) alpha: 0.5! !

!InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 9/19/2003 15:30'!
ensureSuitableDefaults

	listOfPages ifNil: [
		listOfPages _ Project allMorphicProjects collect: [ :each | {each name}].
		threadName _ 'all (default)' translated.
		self class know: listOfPages as: threadName.
	].
	currentIndex ifNil: [currentIndex _ 0].
! !


!InternalThreadNavigationMorph methodsFor: 'menu' stamp: 'RAA 11/9/2000 17:49'!
showMenuFor: actionSelector event: evt

	self perform: actionSelector
! !


!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 11/10/2000 11:41'!
buttonForMenu

	^self makeButton: '?' balloonText: 'More commands' for: #moreCommands.
! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 11/9/2000 15:31'!
deleteCurrentPage

	"no-op here"! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'sw 3/3/2004 16:58'!
destroyThread
	"Manually destroy the thread"

	(self confirm: ('Destroy thread <{1}> ?' translated format:{threadName})) ifFalse: [^ self].
	self class knownThreads removeKey: threadName ifAbsent: [].
	self setProperty: #moribund toValue: true.  "In case pointed to in some other project"
	ActiveWorld keyboardNavigationHandler == self ifTrue:
		[self stopKeyboardNavigation]. 
	self delete! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 2/4/2001 11:41'!
editThisThread

	| sorter |

	sorter _ ProjectSorterMorph new.
	sorter navigator: self listOfPages: listOfPages.
	self currentWorld addMorphFront: sorter.
	sorter align: sorter center with: self currentWorld center.
	self delete.

! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 11/10/2000 11:51'!
getRecentThread

	self switchToThread: (
		ProjectHistory currentHistory mostRecentThread ifNil: [^self]
	)

! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 8/15/2001 12:00'!
insertNewProject

	| newProj |

	[newProj _ Project newMorphicOn: nil.]
		on: ProjectViewOpenNotification
		do: [ :ex | ex resume: false].	

	EToyProjectDetailsMorph 
		getFullInfoFor: newProj
		ifValid: [self insertNewProjectActionFor: newProj]
		expandedFormat: false.


! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dao 10/1/2004 13:36'!
insertNewProjectActionFor: newProj

	| me |

	me _ Project current name.
	listOfPages withIndexDo: [ :each :index |
		each first = me ifTrue: [
			listOfPages add: {newProj name} afterIndex: index.
			^self switchToThread: threadName.
		].
	].
	listOfPages add: {newProj name} afterIndex: listOfPages size.
	^self switchToThread: threadName
		
! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 11/10/2000 12:10'!
jumpToIndex: anInteger

	currentIndex _ anInteger.
	self loadPageWithProgress.! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dao 10/1/2004 13:36'!
jumpWithinThread

	| aMenu me weHaveOthers myIndex |

	me _ Project current name.
	aMenu _ MenuMorph new defaultTarget: self.
	weHaveOthers _ false.
	myIndex _ self currentIndex.
	listOfPages withIndexDo: [ :each :index |
		index = myIndex ifTrue: [
			aMenu add: 'you are here' translated action: #yourself.
			aMenu lastSubmorph color: Color red.
		] ifFalse: [
			weHaveOthers _ true.
			aMenu add: ('jump to <{1}>' translated format:{each first}) selector: #jumpToIndex: argument: index.
			myIndex = (index - 1) ifTrue: [
				aMenu lastSubmorph color: Color blue
			].
			myIndex = (index + 1) ifTrue: [
				aMenu lastSubmorph color: Color orange
			].
		].
	].
	weHaveOthers ifFalse: [^self inform: 'This is the only project in this thread' translated].
	aMenu popUpEvent: self world primaryHand lastEvent in: self world! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 4/4/2006 15:28'!
moreCommands
	"Put up a menu of options"

	| allThreads aMenu others target |
	allThreads _ self class knownThreads.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'navigation' translated.

	Preferences noviceMode ifFalse:[
		self flag: #deferred.  "Probably don't want that stay-up item, not least because the navigation-keystroke stuff is not dynamically handled"
		aMenu addStayUpItem
	].
	
	others _ (allThreads keys reject: [ :each | each = threadName]) asSortedCollection.
	others do: [ :each |
		aMenu add: ('switch to <{1}>' translated format:{each}) selector: #switchToThread: argument: each
	].

	aMenu addList: {
		{'switch to recent projects' translated.  #getRecentThread}.
		#-.
		{'create a new thread' translated.  #threadOfNoProjects}.
		{'edit this thread' translated.  #editThisThread}.
		{'create thread of all projects' translated.  #threadOfAllProjects}.
		#-.
		{'First project in thread' translated.  #firstPage}.
		{'Last project in thread' translated.  #lastPage}
	}.

	(target _ self currentIndex + 2) > listOfPages size ifFalse: [
		aMenu 
			add: ('skip over next project ({1})' translated format:{(listOfPages at: target - 1) first})
			action: #skipOverNext
	].

	aMenu addList: {
		{'jump within this thread' translated.  #jumpWithinThread}.
		{'insert new project' translated.  #insertNewProject}.
		#-.
		{'simply close this navigator' translated.  #delete}.
		{'destroy this thread' translated. #destroyThread}.
		#-
	}.

	(ActiveWorld keyboardNavigationHandler == self) ifFalse:[
		aMenu add: 'start keyboard navigation with this thread' translated action: #startKeyboardNavigation
	]
	ifTrue: [
		aMenu add: 'stop keyboard navigation with this thread' translated action: #stopKeyboardNavigation
	].

	aMenu popUpInWorld.
! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 11/29/2003 17:36'!
myThumbnailSize
	^ (52 @ 39 * self sizeRatio) rounded! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 6/1/2001 13:37'!
positionAppropriately

	| others otherRects overlaps |

	(self ownerThatIsA: HandMorph) ifNotNil: [^self].
	others _ self world submorphs select: [ :each | each ~~ self and: [each isKindOf: self class]].
	otherRects _ others collect: [ :each | each bounds].
	self align: self fullBounds bottomRight with: self world bottomRight.
	self setProperty: #previousWorldBounds toValue: self world bounds.

	[
		overlaps _ false.
		otherRects do: [ :r |
			(r intersects: bounds) ifTrue: [overlaps _ true. self bottom: r top].
		].
		self top < self world top ifTrue: [
			self bottom: self world bottom.
			self right: self left - 1.
		].
		overlaps
	] whileTrue.! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'nb 6/17/2003 12:25'!
skipOverNext
	
	| target |

	(target _ self currentIndex + 2) > listOfPages size ifTrue: [^Beeper beep].
	currentIndex _ target.
	self loadPageWithProgress.
! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'sw 3/18/2003 23:12'!
startKeyboardNavigation
	"Tell the active world to starting navigating via desktop keyboard navigation via me"

	ActiveWorld keyboardNavigationHandler: self! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'sw 3/18/2003 23:09'!
stopKeyboardNavigation
	"Cease navigating via the receiver in response to desktop keystrokes"

	ActiveWorld removeProperty: #keyboardNavigationHandler! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 11/9/2000 17:46'!
switchToThread: newName

	threadName _ newName.
	listOfPages _ self class knownThreads at: threadName.
	self removeAllMorphs.
	self addButtons.
	self currentIndex.
! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 11/9/2000 17:10'!
threadName

	^threadName! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 2/24/2001 13:15'!
threadName: aString index: anInteger

	threadName _ aString.
	preferredIndex _ anInteger.
	self currentIndex.! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 2/24/2001 13:15'!
threadOfAllProjects

	| nameList nav |

	nameList _ Project allMorphicProjects collect: [ :each | {each name}].
	nav _ self class basicNew.
	nav
		listOfPages: nameList;
		threadName: '' index: nil;
		initialize.
	nav editThisThread.
! !

!InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dao 10/1/2004 13:36'!
threadOfNoProjects

	| nameList nav |

	nameList _ { {Project current name} }.
	nav _ self class basicNew.
	nav
		listOfPages: nameList;
		threadName: '' index: nil;
		initialize.
	nav editThisThread.
! !


!InternalThreadNavigationMorph methodsFor: 'piano rolls' stamp: 'md 10/22/2003 15:25'!
triggerActionFromPianoRoll
	| proj |
	WorldState addDeferredUIMessage: 
			[self currentIndex >= listOfPages size 
				ifTrue: [Beeper beep]
				ifFalse: 
					[currentIndex := self currentIndex + 1.
					proj := Project named: ((listOfPages at: currentIndex) first).
					proj world setProperty: #letTheMusicPlay toValue: true.
					proj enter]]! !


!InternalThreadNavigationMorph methodsFor: 'sorting' stamp: 'dgd 9/19/2003 15:27'!
acceptSortedContentsFrom: aHolder
	"Update my page list from the given page sorter."

	| nameOfThisProject cachedData proj |

	threadName isEmpty ifTrue: [threadName _ 'I need a name' translated].
	threadName _ FillInTheBlank 
		request: 'Name this thread.' translated 
		initialAnswer: threadName.
	threadName isEmptyOrNil ifTrue: [^self].
	listOfPages _ OrderedCollection new.
	aHolder submorphs doWithIndex: [:m :i |
		(nameOfThisProject _ m valueOfProperty: #nameOfThisProject) ifNotNil: [
			cachedData _ {nameOfThisProject}.
			proj _ Project named: nameOfThisProject.
			(proj isNil or: [proj thumbnail isNil]) ifFalse: [
				cachedData _ cachedData, {proj thumbnail scaledToSize: self myThumbnailSize}.
			].
			listOfPages add: cachedData.
		].
	].
	self class know: listOfPages as: threadName.
	self removeAllMorphs; addButtons.
	self world ifNil: [
		self openInWorld; positionAppropriately.
	].
! !

!InternalThreadNavigationMorph methodsFor: 'sorting' stamp: 'RAA 2/4/2001 09:38'!
makeThumbnailForPageNumber: pageNumber scaledToSize: sz default: aString

	| cachedData proj tn label |
	cachedData _ listOfPages at: pageNumber.
	proj _ Project named: cachedData first.
	(proj isNil or: [proj thumbnail isNil]) ifTrue: [
		cachedData size >= 2 ifTrue: [^cachedData second].
		tn _ Form extent: sz depth: 8.
		tn fillColor: Color veryLightGray.
		label _ (StringMorph contents: aString) imageForm.
		label displayOn: tn at: tn center - (label extent // 2) rule: Form paint.
		^tn
	].
	tn _ proj thumbnail  scaledToSize: sz.
	cachedData size < 2 ifTrue: [
		cachedData _ cachedData,#(0).
		listOfPages at: pageNumber put: cachedData.
	].
	cachedData at: 2 put: tn.
	^tn
! !


!InternalThreadNavigationMorph methodsFor: 'stepping' stamp: 'RAA 6/1/2001 13:36'!
step

	super step.
	(self valueOfProperty: #previousWorldBounds) = self world bounds ifFalse: [
		self positionAppropriately.
	].
	self class knownThreads
		at: threadName
		ifPresent: [ :known |
			known == listOfPages ifFalse: [
				listOfPages _ known.
				self removeAllMorphs.
				self addButtons.
			].
		].
! !


!InternalThreadNavigationMorph methodsFor: 'private' stamp: 'dao 10/1/2004 13:36'!
currentIndex

	| currentName |

	currentName _ Project current name.
	listOfPages withIndexDo: [ :each :index |
		(each first = currentName and: [preferredIndex = index]) ifTrue: [^currentIndex _ index]
	].
	listOfPages withIndexDo: [ :each :index |
		each first = currentName ifTrue: [^currentIndex _ index]
	].
	
	currentIndex isNil
		ifTrue: [^ 1].

	^ currentIndex min: listOfPages size
! !

!InternalThreadNavigationMorph methodsFor: 'private' stamp: 'RAA 11/11/2000 19:11'!
listOfPages: aCollection

	listOfPages _ aCollection.
	currentIndex _ nil.
	self currentIndex
! !

!InternalThreadNavigationMorph methodsFor: 'private' stamp: 'dao 10/1/2004 13:31'!
loadPageWithProgress
	"Load the desired page, showing a progress indicator as we go"
	
	| projectInfo projectName beSpaceHandler |
	projectInfo _ listOfPages at: currentIndex.
	projectName _ projectInfo first.
	loadedProject _ Project named: projectName.
	self class know: listOfPages as: threadName.
	beSpaceHandler _ (ActiveWorld keyboardNavigationHandler == self).
	WorldState addDeferredUIMessage:
		[InternalThreadNavigationMorph openThreadNamed: threadName atIndex: currentIndex beKeyboardHandler: beSpaceHandler] fixTemps.

	loadedProject ifNil: [
		ComplexProgressIndicator new 
			targetMorph: self;
			historyCategory: 'project loading' translated;
			withProgressDo: [
				[
					loadedProject _ Project current 
							fromMyServerLoad: projectName
				] 
					on: ProjectViewOpenNotification
					do: [ :ex | ex resume: false]		
						"we probably don't want a project view morph in this case"
			].
	].
	loadedProject ifNil: [
		^self inform: 'I cannot find that project' translated
	].
	self delete.

	loadedProject enter.
! !

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

InternalThreadNavigationMorph class
	instanceVariableNames: ''!

!InternalThreadNavigationMorph class methodsFor: 'known threads' stamp: 'tetha 4/18/2005 01:38'!
clearKnownThreads

	KnownThreads _ nil! !

!InternalThreadNavigationMorph class methodsFor: 'known threads' stamp: 'RAA 11/9/2000 17:12'!
know: listOfPages as: nameOfThread

	self knownThreads at: nameOfThread put: listOfPages.
! !

!InternalThreadNavigationMorph class methodsFor: 'known threads' stamp: 'RAA 11/9/2000 15:53'!
knownThreads

	^KnownThreads ifNil: [KnownThreads _ Dictionary new].
! !

!InternalThreadNavigationMorph class methodsFor: 'known threads' stamp: 'RAA 2/24/2001 13:10'!
openThreadNamed: nameOfThread atIndex: anInteger

	| coll nav |

	coll _ self knownThreads at: nameOfThread ifAbsent: [^self].
	nav _ World 
		submorphThat: [ :each | (each isKindOf: self) and: [each threadName = nameOfThread]]
		ifNone: [
			nav _ self basicNew.
			nav
				listOfPages: coll;
				threadName: nameOfThread index: anInteger;
				initialize;
				openInWorld;
				positionAppropriately.
			^self
		].
	nav
		listOfPages: coll;
		threadName: nameOfThread index: anInteger;
		removeAllMorphs;
		addButtons.

! !

!InternalThreadNavigationMorph class methodsFor: 'known threads' stamp: 'sw 3/18/2003 23:12'!
openThreadNamed: nameOfThread atIndex: anInteger beKeyboardHandler: aBoolean
	"Activate the thread of the given name, from the given index; set it up to be navigated via desktop keys if indicated"

	| coll nav |

	coll _ self knownThreads at: nameOfThread ifAbsent: [^self].
	nav _ World 
		submorphThat: [ :each | (each isKindOf: self) and: [each threadName = nameOfThread]]
		ifNone:
			[nav _ self basicNew.
			nav
				listOfPages: coll;
				threadName: nameOfThread index: anInteger;
				initialize;
				openInWorld;
				positionAppropriately.
			aBoolean ifTrue: [ActiveWorld keyboardNavigationHandler: nav].
			^ self].
	nav
		listOfPages: coll;
		threadName: nameOfThread index: anInteger;
		removeAllMorphs;
		addButtons.
	aBoolean ifTrue: [ActiveWorld keyboardNavigationHandler: nav]

! !


!InternalThreadNavigationMorph class methodsFor: 'parts bin' stamp: 'sw 8/19/2001 21:15'!
descriptionForPartsBin
	^ self partName: 	'ThreadNavigator'
		categories:		#('Navigation')
		documentation:	'A tool that lets you navigate through a thread of projects.'! !


!InternalThreadNavigationMorph class methodsFor: 'sorter' stamp: 'RAA 5/10/2001 17:04'!
sorterFormForProject: aProject sized: ignored

	^(ProjectViewMorph on: aProject) imageForm scaledToSize: 80@60.
! !


!InternalThreadNavigationMorph class methodsFor: 'thumbnails' stamp: 'RAA 5/10/2001 17:06'!
cacheThumbnailFor: aProject

	| form |

	CachedThumbnails ifNil: [CachedThumbnails _ Dictionary new].
	CachedThumbnails
		at: aProject name
		put: (form _ self sorterFormForProject: aProject sized: nil).
	^form
	! !

!InternalThreadNavigationMorph class methodsFor: 'thumbnails' stamp: 'RAA 5/10/2001 17:09'!
clearThumbnailCache

	CachedThumbnails _ nil! !

!InternalThreadNavigationMorph class methodsFor: 'thumbnails' stamp: 'RAA 5/10/2001 17:07'!
getThumbnailFor: aProject

	CachedThumbnails ifNil: [CachedThumbnails _ Dictionary new].
	^CachedThumbnails
		at: aProject name
		ifAbsentPut: [self sorterFormForProject: aProject sized: nil]! !
Object subclass: #InternetConfiguration
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!

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

InternetConfiguration class
	instanceVariableNames: ''!

!InternetConfiguration class methodsFor: 'initialize-release' stamp: 'md 2/24/2006 15:22'!
initialize
	"self initialize"
	Smalltalk addToStartUpList: self.
	Smalltalk addToShutDownList: self.! !


!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:05'!
getArchiePreferred
	"Return the preferred Archie server"
	"InternetConfiguration getArchiePreferred"

	^self primitiveGetStringKeyedBy: 'ArchiePreferred'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:31'!
getDownloadPath
	"Return the download path"
	"InternetConfiguration getDownloadPath"

	^self primitiveGetStringKeyedBy: 'DownLoadPath'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:07'!
getEmail
	"Return the  email address of user"
	"InternetConfiguration getEmail"

	^self primitiveGetStringKeyedBy: 'Email'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:08'!
getFTPHost
	"Return the FTPHost"
	"InternetConfiguration getFTPHost"

	^self primitiveGetStringKeyedBy: 'FTPHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:09'!
getFTPProxyAccount
	"Return the second level FTP proxy authorisation"
	"InternetConfiguration getFTPProxyAccount"

	^self primitiveGetStringKeyedBy: 'FTPProxyAccount'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:00'!
getFTPProxyHost
	"Return the FTP proxy host"
	"InternetConfiguration getFTPProxyHost"

	^self primitiveGetStringKeyedBy: 'FTPProxyHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:02'!
getFTPProxyPassword
	"Return the FTP proxy password"
	"InternetConfiguration getFTPProxyPassword"

	^self primitiveGetStringKeyedBy: 'FTPProxyPassword'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:10'!
getFTPProxyUser
	"Return the first level FTP proxy authorisation"
	"InternetConfiguration getFTPProxyUser"

	^self primitiveGetStringKeyedBy: 'FTPProxyUser'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:10'!
getFingerHost
	"Return the default finger server"
	"InternetConfiguration getFingerHost"

	^self primitiveGetStringKeyedBy: 'FingerHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:11'!
getGopherHost
	"Return the default Gopher server"
	"InternetConfiguration getGopherHost"

	^self primitiveGetStringKeyedBy: 'GopherHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:11'!
getGopherProxy
	"Return the  Gopher proxy"
	"InternetConfiguration getGopherProxy"

	^self primitiveGetStringKeyedBy: 'GopherProxy'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'!
getHTTPProxyHost
	"Return the http proxy for this client."
	"InternetConfiguration getHTTPProxyHost"

	^self primitiveGetStringKeyedBy: 'HTTPProxyHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'!
getIRCHost
	"Return the Internet Relay Chat server"
	"InternetConfiguration getIRCHost"

	^self primitiveGetStringKeyedBy: 'IRCHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'!
getLDAPSearchbase
	"Return the LDAP thing"
	"InternetConfiguration getLDAPSearchbase"

	^self primitiveGetStringKeyedBy: 'LDAPSearchbase'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:15'!
getLDAPServer
	"Return the LDAP server"
	"InternetConfiguration getLDAPServer"

	^self primitiveGetStringKeyedBy: 'LDAPServer'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/5/2001 23:45'!
getMacintoshFileTypeAndCreatorFrom: aFileName
	"Return the application type and application signature for the file
	 for the macintosh file system based on the file ending, the file does not need to exist
	failure to find a signature based on the file ending, or because of primitive failure turns nil"
	"InternetConfiguration getMacintoshFileTypeAndCreatorFrom: 'test.jpg'"
	| string |

	string _ self primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName.
	string = '********' ifTrue: [^nil].
	^Array with: (string first: 4) with: (string last: 4)
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:07'!
getMailAccount
	"Return the mail account user@host.domain"
	"InternetConfiguration getMailAccount"

	^self primitiveGetStringKeyedBy: 'MailAccount'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:31'!
getMailPassword 
	"Return the mail account Password "
	"InternetConfiguration getMailPassword "

	^self primitiveGetStringKeyedBy: 'MailPassword'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:16'!
getNNTPHost
	"Return the NNTP server"
	"InternetConfiguration getNNTPHost"

	^self primitiveGetStringKeyedBy: 'NNTPHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:17'!
getNTPHost
	"Return the  Network Time Protocol (NTP)"
	"InternetConfiguration getNTPHost"

	^self primitiveGetStringKeyedBy: 'NTPHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:04'!
getNewsAuthPassword
	"Return the Password for the authorised news servers"
	"InternetConfiguration getNewsAuthPassword"

	^self primitiveGetStringKeyedBy: 'NewsAuthPassword'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:17'!
getNewsAuthUsername
	"Return the user name for authorised news servers"
	"InternetConfiguration getNewsAuthUsername"

	^self primitiveGetStringKeyedBy: 'NewsAuthUsername'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/5/2001 10:54'!
getNoProxyDomains
	"Return a comma seperated string of domains not to proxy"
	"InternetConfiguration getNoProxyDomains"

	^self primitiveGetStringKeyedBy: 'NoProxyDomains'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:36'!
getOrganization
	"Return the Organization"
	"InternetConfiguration getOrganization"

	^self primitiveGetStringKeyedBy: 'Organization'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:37'!
getPhHost
	"Return the PhHost server"
	"InternetConfiguration getPhHost"

	^self primitiveGetStringKeyedBy: 'PhHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:04'!
getRealName
	"Return the RealName"
	"InternetConfiguration getRealName"

	^self primitiveGetStringKeyedBy: 'RealName'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:19'!
getSMTPHost
	"Return the SMTP server"
	"InternetConfiguration getSMTPHost"

	^self primitiveGetStringKeyedBy: 'SMTPHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:19'!
getSocksHost
	"Return the Socks server"
	"InternetConfiguration getSocksHost"

	^self primitiveGetStringKeyedBy: 'SocksHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:20'!
getTelnetHost
	"Return the TelnetHost server"
	"InternetConfiguration getTelnetHost"

	^self primitiveGetStringKeyedBy: 'TelnetHost'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'!
getWAISGateway
	"Return the wais gateway"
	"InternetConfiguration getWAISGateway"

	^self primitiveGetStringKeyedBy: 'WAISGateway'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'!
getWWWHomePage
	"Return the WWW home page url"
	"InternetConfiguration getWWWHomePage"

	^self primitiveGetStringKeyedBy: 'WWWHomePage'
! !

!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:23'!
getWhoisHost
	"Return the WhoisHost server"
	"InternetConfiguration getWhoisHost"

	^self primitiveGetStringKeyedBy: 'WhoisHost'
! !


!InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 10/5/2001 23:44'!
primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName
	<primitive: 'primitiveGetMacintoshFileTypeAndCreatorFrom' module: 'InternetConfigPlugin'>
	^'********' copy ! !

!InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 9/26/2001 16:31'!
primitiveGetStringKeyedBy: aKey
	<primitive: 'primitiveGetStringKeyedBy' module: 'InternetConfigPlugin'>
	^String new.
! !


!InternetConfiguration class methodsFor: 'system startup' stamp: 'md 2/24/2006 15:22'!
shutDown
	(SmalltalkImage current platformName =  'Mac OS') ifTrue: [
	  		HTTPSocket stopUsingProxyServer]
	
! !

!InternetConfiguration class methodsFor: 'system startup' stamp: 'md 3/5/2006 16:25'!
startUp
	(SmalltalkImage current platformName =  'Mac OS') ifTrue: [
		self useHTTPProxy ifTrue: [
			 (self getHTTPProxyHost findTokens: ':') ifNotEmpty: [:p |
			 	HTTPSocket useProxyServerNamed: p first port: p second asInteger]]]! !


!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'!
useFTPProxy
	"Return true if UseFTPProxy"
	"InternetConfiguration useFTPProxy"

	^(self primitiveGetStringKeyedBy: 'UseFTPProxy') = '1'
! !

!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'!
useGopherProxy
	"Return true if UseGopherProxy"
	"InternetConfiguration useGopherProxy"

	^(self primitiveGetStringKeyedBy: 'UseGopherProxy') = '1'
! !

!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 9/26/2001 19:41'!
useHTTPProxy
	"Return true if UseHTTPProxy"
	"InternetConfiguration useHTTPProxy"

	^(self primitiveGetStringKeyedBy: 'UseHTTPProxy') = '1'
! !

!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 9/26/2001 19:42'!
usePassiveFTP
	"Return true if UsePassiveFTP"
	"InternetConfiguration usePassiveFTP"

	^(self primitiveGetStringKeyedBy: 'UsePassiveFTP') = '1'
! !

!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'!
useSocks
	"Return true if UseSocks"
	"InternetConfiguration useSocks"

	^(self primitiveGetStringKeyedBy: 'UseSocks') = '1'
! !
SequenceableCollection subclass: #Interval
	instanceVariableNames: 'start stop step'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!Interval commentStamp: '<historical>' prior: 0!
I represent a finite arithmetic progression.!


!Interval methodsFor: 'accessing'!
at: anInteger 
	"Answer the anInteger'th element."

	(anInteger >= 1 and: [anInteger <= self size])
		ifTrue: [^start + (step * (anInteger - 1))]
		ifFalse: [self errorSubscriptBounds: anInteger]! !

!Interval methodsFor: 'accessing'!
at: anInteger put: anObject 
	"Storing into an Interval is not allowed."

	self error: 'you can not store into an interval'! !

!Interval methodsFor: 'accessing' stamp: 'stp 8/19/2000 23:52'!
extent 
	"Answer the max - min of the receiver interval."
	"(10 to: 50) extent"

	^stop - start! !

!Interval methodsFor: 'accessing'!
first 
	"Refer to the comment in SequenceableCollection|first."

	^start! !

!Interval methodsFor: 'accessing' stamp: 'rpj 11/30/1999 11:04'!
includes: aNumber
	"Determine if aNumber is an element of this interval."
	^ (self rangeIncludes: aNumber) and: [ self valuesInclude: aNumber ]! !

!Interval methodsFor: 'accessing'!
increment
	"Answer the receiver's interval increment."

	^step! !

!Interval methodsFor: 'accessing'!
last 
	"Refer to the comment in SequenceableCollection|last."

	^stop - (stop - start \\ step)! !

!Interval methodsFor: 'accessing' stamp: 'di 12/6/1999 11:00'!
rangeIncludes: aNumber
	"Return true if the number lies in the interval between start and stop."

	step >= 0
		ifTrue: [^ aNumber between: start and: stop]
		ifFalse: [^ aNumber between: stop and: start]
! !

!Interval methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:38'!
size
	"Answer how many elements the receiver contains."

	step < 0
		ifTrue: [start < stop
				ifTrue: [^ 0]
				ifFalse: [^ stop - start // step + 1]]
		ifFalse: [stop < start
				ifTrue: [^ 0]
				ifFalse: [^ stop - start // step + 1]]! !


!Interval methodsFor: 'adding'!
add: newObject 
	"Adding to an Interval is not allowed."

	self shouldNotImplement! !


!Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:45'!
+ number

	^ start + number to: stop + number by: step! !

!Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:46'!
- number

	^ start - number to: stop - number by: step! !


!Interval methodsFor: 'comparing' stamp: 'rhi 8/14/2003 10:08'!
= anObject

	^ self == anObject
		ifTrue: [true]
		ifFalse: [anObject isInterval
			ifTrue: [start = anObject first
				and: [step = anObject increment
					and: [self last = anObject last]]]
			ifFalse: [super = anObject]]! !

!Interval methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^(((start hash bitShift: 2)
		bitOr: stop hash)
		bitShift: 1)
		bitOr: self size! !

!Interval methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !


!Interval methodsFor: 'copying'!
copy
	"Return a copy of me. Override the superclass because my species is
	Array and copy, as inherited from SequenceableCollection, uses
	copyFrom:to:, which creates a new object of my species."

	^self shallowCopy! !

!Interval methodsFor: 'copying' stamp: 'sma 3/3/2000 13:18'!
shallowCopy
	"Without this method, #copy would return an array instead of a new interval.
	The whole problem is burried in the class hierarchy and every fix will worsen
	the problem, so once the whole issue is resolved one should come back to this 
	method fix it."

	^ self class from: start to: stop by: step! !


!Interval methodsFor: 'enumerating'!
collect: aBlock
	| nextValue result |
	result _ self species new: self size.
	nextValue _ start.
	1 to: result size do:
		[:i |
		result at: i put: (aBlock value: nextValue).
		nextValue _ nextValue + step].
	^ result! !

!Interval methodsFor: 'enumerating'!
do: aBlock

	| aValue |
	aValue _ start.
	step < 0
		ifTrue: [[stop <= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue + step]]
		ifFalse: [[stop >= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue + step]]! !

!Interval methodsFor: 'enumerating' stamp: 'dtl 5/31/2003 16:45'!
permutationsDo: aBlock
	"Repeatly value aBlock with a single copy of the receiver. Reorder the copy
	so that aBlock is presented all (self size factorial) possible permutations."
	"(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]"

	self asArray permutationsDo: aBlock
! !

!Interval methodsFor: 'enumerating'!
reverseDo: aBlock 
	"Evaluate aBlock for each element of my interval, in reverse order."

	| aValue |
	aValue _ stop.
	step < 0
		ifTrue: [[start >= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue - step]]
		ifFalse: [[start <= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue - step]]! !


!Interval methodsFor: 'printing' stamp: 'sma 6/1/2000 09:50'!
printOn: aStream
	aStream nextPut: $(;
	 print: start;
	 nextPutAll: ' to: ';
	 print: stop.
	step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; print: step].
	aStream nextPut: $)! !

!Interval methodsFor: 'printing'!
storeOn: aStream 
	"This is possible because we know numbers store and print the same."

	self printOn: aStream! !


!Interval methodsFor: 'removing'!
remove: newObject 
	"Removing from an Interval is not allowed."

	self error: 'elements cannot be removed from an Interval'! !


!Interval methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 22:03'!
isSelfEvaluating
	^ self class == Interval! !


!Interval methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'!
isInterval

	^ true! !


!Interval methodsFor: 'private'!
setFrom: startInteger to: stopInteger by: stepInteger

	start _ startInteger.
	stop _ stopInteger.
	step _ stepInteger! !

!Interval methodsFor: 'private'!
species

	^Array! !

!Interval methodsFor: 'private' stamp: 'di 4/24/2000 13:56'!
valuesInclude: aNumber
	"Private - answer whether or not aNumber is one of the enumerated values in this interval."

	| val |
	val _ (aNumber - self first) asFloat / self increment.
	^ val fractionPart abs < (step * 1.0e-10)! !

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

Interval class
	instanceVariableNames: ''!

!Interval class methodsFor: 'instance creation'!
from: startInteger to: stopInteger 
	"Answer an instance of me, starting at startNumber, ending at 
	stopNumber, and with an interval increment of 1."

	^self new
		setFrom: startInteger
		to: stopInteger
		by: 1! !

!Interval class methodsFor: 'instance creation'!
from: startInteger to: stopInteger by: stepInteger 
	"Answer an instance of me, starting at startNumber, ending at 
	stopNumber, and with an interval increment of stepNumber."

	^self new
		setFrom: startInteger
		to: stopInteger
		by: stepInteger! !

!Interval class methodsFor: 'instance creation'!
new
	"Primitive. Create and answer with a new instance of the receiver
	(a class) with no indexable fields. Fail if the class is indexable. Override
	SequenceableCollection new. Essential. See Object documentation
	whatIsAPrimitive."

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

!Interval class methodsFor: 'instance creation' stamp: 'md 1/14/2004 11:42'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

    | newInterval n |

    (n := aCollection size) <= 1 ifTrue: [
		n = 0 ifTrue: [^self from: 1 to: 0].
		^self from: aCollection first to: aCollection last].
    	newInterval := self from: aCollection first to: aCollection last
	by: (aCollection last - aCollection first) // (n - 1).
	aCollection ~= newInterval
		ifTrue: [self error: 'The argument is not an arithmetic progression'].
	^newInterval

"	Interval newFrom: {1. 2. 3}
	{33. 5. -23} as: Interval
	{33. 5. -22} as: Interval    (an error)
	(-4 to: -12 by: -1) as: Interval
"! !
ClassTestCase subclass: #IntervalTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Sequenceable'!

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:23'!
testAdd
	self assert: (1 to: 10)
			+ 5
			= (6 to: 15)! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:15'!
testAt
	self assert: ((1 to: 10)
			at: 1)
			= 1.
	self assert: ((1 to: 10)
			at: 3)
			= 3.
	self assert: ((1 to: 10 by: 2)
			at: 1)
			= 1.
	self assert: ((1 to: 10 by: 2)
			at: 3)
			= 5! !

!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'!
testEquals

	self shouldnt: [
		self assert: (3 to: 5) = #(3 4 5).
		self deny: (3 to: 5) = #(3 5).
		self deny: (3 to: 5) = #().

		self assert: #(3 4 5) = (3 to: 5).
		self deny: #(3 5) = (3 to: 5).
		self deny: #() = (3 to: 5).
	] raise: MessageNotUnderstood.! !

!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'!
testEquals2

	self assert: (3 to: 5) = #(3 4 5).
	self deny: (3 to: 5) = #(3 5).
	self deny: (3 to: 5) = #().

	self assert: #(3 4 5) = (3 to: 5).
	self deny: #(3 5) = (3 to: 5).
	self deny: #() = (3 to: 5).! !

!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'!
testEquals3

	self assert: (3 to: 5 by: 2) first = (3 to: 6 by: 2) first.
	self assert: (3 to: 5 by: 2) last = (3 to: 6 by: 2) last.
	self assert: (3 to: 5 by: 2) = (3 to: 6 by: 2).! !

!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'!
testEquals4

	self assert: (3 to: 5 by: 2) = #(3 5).
	self deny: (3 to: 5 by: 2) = #(3 4 5).
	self deny: (3 to: 5 by: 2) = #().

	self assert: #(3 5) = (3 to: 5 by: 2).
	self deny: #(3 4 5) = (3 to: 5 by: 2).
	self deny: #() = (3 to: 5 by: 2).! !

!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:14'!
testEquals5

	self assert: (3 to: 5 by: 2) = (Heap withAll: #(3 5)).
	self deny: (3 to: 5 by: 2) = (Heap withAll: #(3 4 5)).
	self deny: (3 to: 5 by: 2) = Heap new.

	self assert: (Heap withAll: #(3 5)) = (3 to: 5 by: 2).
	self deny: (Heap withAll: #(3 4 5)) = (3 to: 5 by: 2).
	self deny: Heap new = (3 to: 5 by: 2).! !

!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:14'!
testEquals6

	self assert: #() = Heap new.
	self assert: #(3 5) = (Heap withAll: #(3 5)).
	self deny: (3 to: 5 by: 2) = (Heap withAll: #(3 4 5)).
	self deny: (3 to: 5 by: 2) = Heap new.

	self assert: Heap new = #().
	self assert: (Heap withAll: #(3 5)) = #(3 5).
	self deny: (Heap withAll: #(3 4 5)) = #(3 5).
	self deny: Heap new = #(3 5).! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:08'!
testExtent
	self assert: (1 to: 10) extent = 9.
	self assert: (1 to: 10 by: 2) extent = 9.
	self assert: (1 to:-1) extent = -2! !

!IntervalTest methodsFor: 'tests'!
testInvalid
	"empty, impossible ranges"
	self assert: (1 to: 0) = #().
	self assert: (1 to: -1) = #().
	self assert: (-1 to: -2) = #().
	self assert: (1 to: 5 by: -1) = #().
	
	"always contains only start value."
	self assert: (1 to: 1) = #(1).
	self assert: (1 to: 5 by: 10) = #(1).
	self assert: (1 to: 0 by: -2) = #(1).
! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:11'!
testIsEvaluating
	self assert: (1 to: 10) isSelfEvaluating.
	self assert: (1 to: 10 by: 2) isSelfEvaluating! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/7/2005 13:29'!
testIsInterval
	self assert: (1 to: 10) isInterval.
	self assert: (1 to: 10 by: 2) isInterval! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/7/2005 13:29'!
testLast

self assert: (1 to:10) last = 10.
self assert: (1 to:10 by:2) last = 9 ! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:28'!
testMinus
	self assert: (1 to: 10)
			- 5
			= (-4 to: 5)! !

!IntervalTest methodsFor: 'tests' stamp: 'md 1/14/2004 11:43'!
testNewFrom

	self shouldnt: [
		 self assert: ( (Interval newFrom: (1 to: 1)) = (1 to: 1)).
		 self assert: ( (Interval newFrom: #(1)) = (1 to: 1)).
		 self assert: ( (Interval newFrom: #()) =  ( 1 to: 0)) .
	] raise: Error.! !

!IntervalTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:17'!
testNumericTypes

	(3 asNumber) to: 5 = #(3 4 5).
	
	3.0 to: 5.0 = #(3.0 4.0 5.0).
	3.0 to: 5.0 by: 0.5 = #(3.0 3.5 4.0 4.5 5.0).
	
	3/1 to: 5/1 = #(3 4 5).
	1/2 to: 5/2 by: 1/2 = #(1/2 1 3/2 2 5/2).! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:03'!
testOtherNewFrom

	self assert: (Interval newFrom: #(1 2 3 )) = (1 to: 3).
	self assert: (Interval newFrom: #(33  5 -23 )) = (33 to: -23 by: -28).
	self should: [(Interval newFrom: #(33  5 -22 ))] raise: Error.
	self assert: (#(33  5 -23) as: Interval) = (33 to: -23 by: -28).
	self should: [( #(33  5 -22 ) as: Interval)] raise: Error.
	
	self assert: ( (-4 to: -12 by: -1) as: Interval) = (-4 to: -12 by: -1).
	self assert: ( Interval newFrom: (1 to: 1)) = (1 to: 1).
	self assert: ( Interval newFrom: (1 to: 0)) = (1 to: 0).
	self assert: (#(1) as: Interval) = (1 to: 1).
	self assert: (#() as: Interval) = (1 to: 0).! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:03'!
testPermutationsDo

	| i oc |
	i := (1.234 to: 4.234).
	oc := OrderedCollection new.
	i permutationsDo: [:e | oc add: e].
	self assert: (oc size == i size factorial).
	^ oc! !

!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:20'!
testRangeIncludes
	self
		assert: ((1 to: 10)
				rangeIncludes: 3).
	self
		assert: ((1 to: 10 by: 2)
				rangeIncludes: 3).
	self
		deny: ((1 to: 10)
				rangeIncludes: 0).
	self
		deny: ((1 to: 10)
				rangeIncludes: 11).
	self
		deny: ((1 to: 10 by: 2)
				rangeIncludes: 0).
	self
		deny: ((1 to: 10 by: 2)
				rangeIncludes: 11)! !
UtteranceVisitor subclass: #IntonationVisitor
	instanceVariableNames: 'functionWords'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!IntonationVisitor methodsFor: 'accessing' stamp: 'len 12/10/1999 02:45'!
functionWords
	^ functionWords! !

!IntonationVisitor methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
functionWords: aCollection
	functionWords := aCollection! !


!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 02:52'!
clause: aClause
	super clause: aClause.

	self isYesNoQuestionClause ifTrue: [^ clause accent: 'L- H%'].
	self isWHQuestionClause ifTrue: [^ clause accent: '%H H- L%'].
	clause accent: 'L- L%' "it's a declarative phrase"! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/12/1999 22:44'!
isQuestionClause
	^ clause string includes: $?! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:22'!
isWHQuestionClause
	| firstWordString |
	self isQuestionClause ifFalse: [^ false].
	firstWordString := clause phrases first words first string asLowercase.
	^ (firstWordString beginsWith: 'wh') or: [firstWordString = 'how']! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/12/1999 22:45'!
isYesNoQuestionClause
	^ self isQuestionClause and: [self isWHQuestionClause not]! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 03:16'!
phrase: aPhrase
	super phrase: aPhrase.

"	phrase == clause phrases last ifFalse: [phrase accent: 'L- H%']"! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:22'!
word: aWord
	| accent |
	super word: aWord.

	((self functionWords includes: word string asLowercase) and: [phrase words first ~~ word]) ifTrue: [^ self].
	self isYesNoQuestionClause ifTrue: [accent := 'L*'] ifFalse: [accent := 'H*'].
	(word syllables detect: [ :one | one stress > 0] ifNone: [word syllables first]) accent: accent! !

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

IntonationVisitor class
	instanceVariableNames: ''!

!IntonationVisitor class methodsFor: 'examples' stamp: 'len 12/13/1999 02:25'!
default
	^ self english! !

!IntonationVisitor class methodsFor: 'examples' stamp: 'len 12/10/1999 02:41'!
english
	^ self new functionWords: self englishFunctionWords! !

!IntonationVisitor class methodsFor: 'examples' stamp: 'len 12/10/1999 02:41'!
englishFunctionWords
	^ #('a' 'about' 'above' 'across' 'after' 'ago' 'all' 'along' 'although' 'am' 'among'
		'an' 'and' 'any' 'apart' 'are' 'aren''t' 'around' 'as' 'aside' 'at' 'away'
		'back' 'be' 'because' 'been' 'before' 'behind' 'below' 'between' 'both'
		'but' 'by' 'can' 'can''t' 'could' 'couldn''t' 'down' 'each' 'either' 'every'
		'few' 'for' 'forever' 'forward' 'fro' 'from' 'has' 'hasn''t' 'have' 'haven''t'
		'he' 'her' 'here' 'him' 'his' 'home' 'how' 'however' 'i' 'if' 'immediately'
		'in' 'inside' 'is' 'it' 'its' 'least' 'less' 'like' 'little' 'many' 'more' 'most' 'much'
		'my' 'neither' 'no' 'none' 'nor' 'not' 'now' 'of' 'off' 'on' 'once' 'only' 'or'
		'our' 'out' 'outside' 'over' 'part' 'plenty' 'right' 'round' 'several' 'she'
		'should' 'shouldn''t' 'since' 'so' 'some' 'than' 'that' 'the' 'their' 'theirs'
		'then' 'there' 'these' 'they' 'this' 'those' 'though' 'through' 'till' 'to' 'together'
		'unless' 'until' 'up' 'upon' 'was' 'wasn''t' 'we' 'were' 'weren''t' 'what'
		'whatever' 'when' 'where' 'whereas' 'whether' 'which' 'while' 'who' 'whom'
		'whose' 'why' 'will' 'with' 'without' 'would' 'wouldn''t' 'yet' 'you' 'your' 'yours'
	) asSet! !
Error subclass: #InvalidDirectoryError
	instanceVariableNames: 'pathName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:44'!
pathName
	^pathName! !

!InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:45'!
pathName: badPathName
	pathName _ badPathName! !


!InvalidDirectoryError methodsFor: 'exceptionDescription' stamp: 'ar 5/30/2001 20:49'!
defaultAction
	"Return an empty list as the default action of signaling the occurance of an invalid directory."
	^#()! !

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

InvalidDirectoryError class
	instanceVariableNames: ''!

!InvalidDirectoryError class methodsFor: 'exceptionInstantiator' stamp: 'ar 5/30/2001 20:49'!
pathName: badPathName
	^self new pathName: badPathName! !
Error subclass: #InvalidSocketStatusException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!InvalidSocketStatusException commentStamp: 'mir 5/12/2003 18:15' prior: 0!
Signals if an operation on a Socket found it in a state invalid for that operation.
!

TestCase subclass: #IslandVMTweaksTestCase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-VM'!
!IslandVMTweaksTestCase commentStamp: 'ls 7/10/2003 18:59' prior: 0!
Test case for some tweaks to the VM that Islands requires.  These tests are largely for documentation; with an un-tweaked VM, the tests mostly still succeed, albeit with possible memory corruption.!


!IslandVMTweaksTestCase methodsFor: 'miscellaneous' stamp: 'ls 7/10/2003 17:42'!
returnTwelve
	"this method is tweaked by testFlagInCompiledMethod"
	^12! !


!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:16'!
aaaREADMEaboutPrimitives
	"most of the Islands tweaks allow primitive methods to be located in places other than class Object.  Thus they are copied here for testing."
! !

!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:17'!
classOf: anObject
	<primitive: 111>
! !

!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:16'!
instVarOf: anObject at: index
	<primitive: 73>
	self primitiveFailed
! !

!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:17'!
instVarOf: anObject at: index put: anotherObject
	<primitive: 74>
	self primitiveFailed
! !

!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:18'!
nextInstanceAfter: anObject
	<primitive: 78>
! !

!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:18'!
nextObjectAfter: anObject
	<primitive: 139>
! !

!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:21'!
replaceIn: replacee  from: start  to: stop   with: replacer  startingAt: replStart
	<primitive: 105>
	self primitiveFailed! !

!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:19'!
someInstanceOf: aClass
	<primitive: 77>
	self primitiveFailed! !

!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:20'!
someObject
	<primitive: 138>
	self primitiveFailed! !


!IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 11:03'!
testEmptyReplace
	| array1 array2 |
	array1 := Array with: 1 with: 2 with: 3 with: 4.
	array2 := Array with: 5 with: 6 with: 7.

	self replaceIn: array1 from: 1 to: 0 with: array2 startingAt: 1.
	self should: [ array1 = #(1 2 3 4) ].
! !

!IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 18:53'!
testFlagInCompiledMethod
	"this tests that the flag in compiled methods is treated correctly"
	| method |
	method := self class compiledMethodAt: #returnTwelve.

	"turn off the flag"
	method objectAt: 1 put: (method header bitAnd: (1 << 29) bitInvert).
	self should: [ method flag not ].

	"turn on the flag"
	method objectAt: 1 put: (method header bitOr: (1 << 29)).
	self should: [ method flag ].

	"try running the method with the flag turned on"
	self should: [ self returnTwelve = 12 ].


	"make sure the flag bit isn't interpreted as a primitive"
	self should: [ method primitive = 0 ].! !

!IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 10:38'!
testForgivingPrims
	| aPoint anotherPoint array1 array2 |
	aPoint := Point x: 5 y: 6.
	anotherPoint := Point x: 7 y: 8.  "make sure there are multiple points floating around"
	anotherPoint.  "stop the compiler complaining about no uses"

	self should: [ (self classOf:  aPoint) = Point ].
	self should: [ (self instVarOf: aPoint at: 1) = 5 ].
	self instVarOf: aPoint at: 2 put: 10.
	self should: [ (self instVarOf: aPoint at: 2) = 10 ].

	self someObject.
	self nextObjectAfter: aPoint.

	self should: [ (self someInstanceOf: Point) class = Point ].
	self should: [ (self nextInstanceAfter: aPoint) class = Point ].


	array1 := Array with: 1 with: 2 with: 3.
	array2 := Array with: 4 with: 5 with: 6.

	self replaceIn: array1 from: 2 to: 3 with: array2 startingAt: 1.
	self should: [ array1 = #(1 4 5) ].

! !
EncodedCharSet subclass: #JISX0208
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Encodings'!
!JISX0208 commentStamp: 'yo 10/19/2004 19:52' prior: 0!
This class represents the domestic character encoding called JIS X 0208 used for Japanese.!


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

JISX0208 class
	instanceVariableNames: ''!

!JISX0208 class methodsFor: 'accessing - displaying' stamp: 'yo 3/18/2003 11:11'!
isBreakableAt: index in: text

	| prev |
	index = 1 ifTrue: [^ false].
	prev _ text at: index - 1.
	prev leadingChar ~= 1 ifTrue: [^ true].
	^ false
! !


!JISX0208 class methodsFor: 'character classification' stamp: 'yo 8/6/2003 05:30'!
isLetter: char

	| value leading |

	leading _ char leadingChar.
	value _ char charCode.

	leading = 0 ifTrue: [^ super isLetter: char].

	value _ value // 94 + 1.
	^ 1 <= value and: [value < 84].
! !


!JISX0208 class methodsFor: 'class methods' stamp: 'ar 4/9/2005 22:31'!
charAtKuten: anInteger

	| a b |
	a _ anInteger \\ 100.
	b _ anInteger // 100.
	(a > 94) | (b > 94) ifTrue: [
		self error: 'character code is not valid'.
	].
	^ Character leadingChar: self leadingChar code: ((b - 1) * 94) + a - 1.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 16:49'!
compoundTextSequence

	^ CompoundTextSequence.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 16:49'!
initialize
"
	self initialize
"

	CompoundTextSequence _ String streamContents: [:s |
		s nextPut: (Character value: 27).
		s nextPut: $$.
		s nextPut: $B
	].
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 17:38'!
leadingChar

	^ 1.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 11/24/2002 17:03'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	| c1 c2 |
	state charSize: 2.
	(state g0Leading ~= self leadingChar) ifTrue: [
		state g0Leading: self leadingChar.
		state g0Size: 2.
		aStream basicNextPutAll: CompoundTextSequence.
	].
	c1 _ ascii // 94 + 16r21.
	c2 _ ascii \\ 94 + 16r21.
	^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2).
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/4/2002 22:52'!
printingDirection

	^ #right.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'ar 4/12/2005 17:34'!
stringFromKutenArray: anArray

	| s |
	s _ WideString new: anArray size.
	1 to: anArray size do: [:i |
		s at: i put: (self charAtKuten: (anArray at: i)).
	].
	^s.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'!
ucsTable

	^ UCSTable jisx0208Table.
! !

!JISX0208 class methodsFor: 'class methods' stamp: 'yo 7/21/2004 18:36'!
unicodeLeadingChar

	^ JapaneseEnvironment leadingChar.
! !
Object subclass: #JPEGColorComponent
	instanceVariableNames: 'currentX currentY hSampleFactor vSampleFactor mcuBlocks widthInBlocks heightInBlocks dctSize mcuWidth mcuHeight priorDCValue id qTableIndex dcTableIndex acTableIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!
!JPEGColorComponent commentStamp: '<historical>' prior: 0!
I represent a single component of color in JPEG YCbCr color space.  I can accept a list of blocks in my component from the current MCU, then stream the samples from this block for use in color conversion.  I also store the running DC sample value for my component, used by the Huffman decoder.

The following layout is fixed for the JPEG primitives to work:
	currentX 		<SmallInteger>
	currentY 		<SmallInteger>
	hSampleFactor 	<SmallInteger>
	vSampleFactor 	<SmallInteger>
	mcuBlocks 		<Array of: <IntegerArray of: DCTSize2 * Integer>>
	widthInBlocks 	<SmallInteger>
	heightInBlocks 	<SmallInteger>
	dctSize 			<SmallInteger>
	mcuWidth 		<SmallInteger>
	mcuHeight 		<SmallInteger>
	priorDCValue 	<SmallInteger>
!


!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:21'!
acTableIndex

	^acTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:20'!
acTableIndex: anInteger

	acTableIndex _ anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:21'!
dcTableIndex

	^dcTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:20'!
dcTableIndex: anInteger

	dcTableIndex _ anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'!
heightInBlocks

	^heightInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:10'!
heightInBlocks: anInteger

	heightInBlocks _ anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:09'!
id

	^id! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:09'!
id: anObject

	id _ anObject! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'ar 3/4/2001 01:19'!
mcuWidth: mw mcuHeight: mh dctSize: ds

	mcuWidth _ mw.
	mcuHeight _ mh.
	dctSize _ ds.
	hSampleFactor _ mcuWidth // widthInBlocks.
	vSampleFactor _ mcuHeight // heightInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:15'!
priorDCValue: aNumber

	priorDCValue _ aNumber! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:43'!
qTableIndex
	^qTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'!
qTableIndex: anInteger

	qTableIndex _ anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:18'!
totalMcuBlocks

	^ heightInBlocks * widthInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:16'!
updateDCValue: aNumber

	priorDCValue _ priorDCValue + aNumber.
	^priorDCValue! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'!
widthInBlocks

	^widthInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:10'!
widthInBlocks: anInteger

	widthInBlocks _ anInteger! !


!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'tao 10/23/97 12:24'!
initializeSampleStreamBlocks: aCollection

	mcuBlocks _ aCollection.
	self resetSampleStream! !

!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'ar 3/4/2001 22:16'!
nextSample

	| dx dy blockIndex sampleIndex sample |
	dx _ currentX // hSampleFactor.
	dy _ currentY // vSampleFactor.
	blockIndex _ dy // dctSize * widthInBlocks + (dx // dctSize) + 1.
	sampleIndex _ dy \\ dctSize * dctSize + (dx \\ dctSize) + 1.
	sample _ (mcuBlocks at: blockIndex) at: sampleIndex.
	currentX _ currentX + 1.
	currentX < (mcuWidth * dctSize)
		ifFalse:
			[currentX _ 0.
			currentY _ currentY + 1].
	^ sample! !

!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'tao 10/23/97 12:24'!
resetSampleStream

	currentX _ 0.
	currentY _ 0! !
Object subclass: #JPEGHuffmanTable
	instanceVariableNames: 'bits values mincode maxcode valptr lookaheadBits lookaheadSymbol'
	classVariableNames: 'BitBufferSize Lookahead'
	poolDictionaries: ''
	category: 'Graphics-Files'!
!JPEGHuffmanTable commentStamp: '<historical>' prior: 0!
I represent the table of values used to decode Huffman entropy-encoded bitstreams.  From the JFIF file header entropy values, I build a derived table of codes and values for faster decoding.!


!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/20/97 14:27'!
bits: anObject

	bits _ anObject! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:31'!
lookaheadBits
	^lookaheadBits! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:38'!
lookaheadSymbol
	^lookaheadSymbol! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:59'!
maxcode
	^maxcode! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/20/97 14:27'!
values: anObject

	values _ anObject! !


!JPEGHuffmanTable methodsFor: 'computation' stamp: 'tao 10/24/97 12:28'!
makeDerivedTables

	| huffSize huffCode code si index lookbits |
	mincode _ Array new: 16.
	maxcode _ Array new: 17.
	valptr _ Array new: 17.
	huffSize _ OrderedCollection new.
	1 to: 16 do: [:l | 1 to: (bits at: l) do: [:i | huffSize add: l]].
	huffSize add: 0.
	code _ 0.
	huffCode _ Array new: huffSize size.
	si _ huffSize at: 1.
	index _ 1.
	[(huffSize at: index) ~= 0] whileTrue:
		[[(huffSize at: index) = si] whileTrue:
			[huffCode at: index put: code.
			index _ index + 1.
			code _ code + 1].
		code _ code << 1.
		si _ si + 1].

	index _ 1.
	1 to: 16 do:
		[:l |
		(bits at: l) ~= 0
			ifTrue:
				[valptr at: l put: index.
				mincode at: l put: (huffCode at: index).
				index _ index + (bits at: l).
				maxcode at: l put: (huffCode at: index-1)]
			ifFalse:
				[maxcode at: l put: -1]].
	maxcode at: 17 put: 16rFFFFF.

	lookaheadBits _ (Array new: 1 << Lookahead) atAllPut: 0.
	lookaheadSymbol _ Array new: 1 << Lookahead.
	index _ 1.
	1 to: Lookahead do:
		[:l |
		1 to: (bits at: l) do:
			[:i |
			lookbits _ (huffCode at: index) << (Lookahead - l) + 1.
			(1 << (Lookahead - l) to: 1 by: -1) do:
				[:ctr |
				lookaheadBits at: lookbits put: l.
				lookaheadSymbol at: lookbits put: (values at: index).
				lookbits _ lookbits + 1].
			index _ index + 1]]! !

!JPEGHuffmanTable methodsFor: 'computation' stamp: 'tao 10/21/97 22:44'!
valueForCode: code length: length

	^ values at: ((valptr at: length) + code - (mincode at: length))! !

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

JPEGHuffmanTable class
	instanceVariableNames: ''!

!JPEGHuffmanTable class methodsFor: 'constants' stamp: 'tao 10/21/97 22:15'!
lookahead

	^ Lookahead! !


!JPEGHuffmanTable class methodsFor: 'initialization' stamp: 'tao 10/21/97 11:06'!
initialize

	Lookahead _ 8.
	BitBufferSize _ 16! !
Object subclass: #JPEGMovieFile
	instanceVariableNames: 'file movieExtent frameRate frameOffsets currentFrameIndex soundtrackOffsets'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Kernel'!
!JPEGMovieFile commentStamp: '<historical>' prior: 0!
A JPEG movie file consists of a header followed by a sequence of JPEG-compressed images followed by one or more sound tracks. It responds to a subset of the protocol for MPEGFile so that a JPEG movie can be played by MPEGDisplayMorph as if it were an MPEG movie.
!


!JPEGMovieFile methodsFor: 'audio' stamp: 'jm 11/17/2001 09:49'!
audioPlayerForChannel: anInteger
	"Answer a streaming sound for playing the audio channel with the given index."

	((anInteger >= 1) & (anInteger <= soundtrackOffsets size)) ifFalse: [^ nil].
	^ StreamingMonoSound
		onFileNamed: file fullName
		headerStart: (soundtrackOffsets at: anInteger)
! !

!JPEGMovieFile methodsFor: 'audio' stamp: 'jm 11/16/2001 17:03'!
hasAudio
	"Answer true if this movie has at least one sound track."

	^ soundtrackOffsets size > 0
! !


!JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 11/14/2001 14:08'!
closeFile
	"Close my file stream."

	file ifNotNil: [file close].
! !

!JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 11/14/2001 14:13'!
fileHandle
	"Answer my file, or nil if the file is not open."

	file ifNil: [^ nil].
	file closed ifTrue: [^ nil].
	^ file
! !

!JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 11/15/2001 07:59'!
fileName
	"Answer the name of my file."

	file ifNil: [^ ''].
	^ file fullName
! !

!JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 2/11/2002 13:09'!
openFile: fileName
	"For compatability with MPEGFile."

	self openFileNamed: fileName.
! !

!JPEGMovieFile methodsFor: 'file ops' stamp: 'stephaneducasse 2/4/2006 20:48'!
openFileNamed: fileName
	"Open the JPEG movie file with the given name."

	file ifNotNil: [file finalize].
	file := nil.
	(FileDirectory default fileExists: fileName) ifFalse: [^ self].
	file := (FileStream readOnlyFileNamed: fileName) binary.
	self readHeader.
	currentFrameIndex := 1.
! !


!JPEGMovieFile methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
initialize

	file := nil.
	frameOffsets := #().
	currentFrameIndex := 1.
! !


!JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/20/2001 16:08'!
hasVideo
	"Answer true if I have one or more frames."

	^ frameOffsets size > 1  "note: the empty movie still has one frameOffset"
! !

!JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/14/2001 14:18'!
videoDropFrames: skipCount stream: streamIndex
	"Advance the index of the current frame by the given number of frames."

	self videoSetFrame: currentFrameIndex + skipCount stream: streamIndex.
! !

!JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 08:08'!
videoFrameHeight: ignored
	"Answer the height of this movie."

	^ movieExtent y
! !

!JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 07:37'!
videoFrameRate: ignored
	"Answer the frame rate of this movie."

	^ frameRate
! !

!JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 08:08'!
videoFrameWidth: ignored
	"Answer the width of this movie."

	^ movieExtent x
! !

!JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 07:34'!
videoFrames: ignored
	"Answer the number of video frames in this movie."

	^ (frameOffsets size - 1) max: 0
! !

!JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/14/2001 14:05'!
videoGetFrame: ignored
	"Answer the index of the current frame, or zero if the movie has no frames."

	^ currentFrameIndex
! !

!JPEGMovieFile methodsFor: 'video' stamp: 'stephaneducasse 2/4/2006 20:48'!
videoReadFrameInto: aForm stream: aStream
	"Read the next frame into the given 16-bit or 32-bit Form."

	| compressedBytes |
	compressedBytes := self bytesForFrame: currentFrameIndex.
	compressedBytes ifNil: [^ self].
	JPEGReadWriter2 new uncompress: compressedBytes into: aForm.
	currentFrameIndex := (currentFrameIndex + 1) min: (frameOffsets size - 1).
! !

!JPEGMovieFile methodsFor: 'video' stamp: 'stephaneducasse 2/4/2006 20:48'!
videoSetFrame: newIndex stream: ignored
	"Set the index of the current frame."

	currentFrameIndex := (newIndex asInteger max: 1) min: (frameOffsets size - 1).
! !


!JPEGMovieFile methodsFor: 'private' stamp: 'jm 11/15/2001 08:02'!
bytesForFrame: frameIndex
	"Answer a ByteArray containing the encoded bytes for the frame with the given index. Answer nil if the index is out of range or if my file is not open."

	frameIndex < 1 ifTrue: [^ nil].
	frameIndex >= frameOffsets size ifTrue: [^ nil].
	file ifNil: [^ nil].
	file closed ifTrue: [file ensureOpen; binary].
	file position: (frameOffsets at: frameIndex).
	^ file next: (frameOffsets at: frameIndex + 1) - (frameOffsets at: frameIndex)
! !

!JPEGMovieFile methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
readHeader
	"Read a JPEG movie header file."
	"Details: The file structures is:
		<header, including sequence frame offsets>
		<sequence of JPEG compressed images>
		<optional soundtracks>"

	| tag w h frameOffsetCount soundtrackCount |
	file position: 0.
	tag := (file next: 10) asString.
	tag = 'JPEG Movie' ifFalse: [self error: 'not a JPEG movie file'].
	w := file uint16.
	h := file uint16.
	movieExtent := w @ h.
	frameRate := file uint32 / 10000.0.
	frameOffsetCount := file uint32.
	frameOffsets := Array new: frameOffsetCount.
	1 to: frameOffsetCount do: [:i | frameOffsets at: i put: file uint32].
	soundtrackCount := file uint16.
	soundtrackOffsets := Array new: soundtrackCount.
	1 to: soundtrackCount do: [:i | soundtrackOffsets at: i put: file uint32].
! !

!JPEGMovieFile methodsFor: 'private' stamp: 'jm 12/13/2001 19:14'!
soundtrackOffsets
	"Answer the offsets for my soundtracks."

	^ soundtrackOffsets
! !

!JPEGMovieFile methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
testPlay
	"Performance benchmark. Decompress and display all my frames. Answer the frame rate achieved in frames/second. No sound is played."

	| frameForm frameCount t |
	frameForm := Form extent: movieExtent depth: (Display depth max: 16).
	frameCount := self videoFrames: 0.
	self videoSetFrame: 1 stream: 0.
	t := [
		frameCount timesRepeat: [
			self videoReadFrameInto: frameForm stream: 0.
			frameForm display].
	] timeToRun.
	^ ((1000.0 * frameCount) / t) roundTo: 0.01
! !

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

JPEGMovieFile class
	instanceVariableNames: ''!

!JPEGMovieFile class methodsFor: 'movie conversion' stamp: 'stephaneducasse 2/4/2006 20:48'!
convertFromFolderOfFramesNamed: folderName toJPEGMovieNamed: jpegFileName frameRate: frameRate quality: quality
	"Convert a folder of frames into a JPEG movie. The named folder is assumed to contain only image files, all of the same size, and whose alphabetical order (case-insensitive) is the sequence in which they will appear in in the movie. A useful convention is to make the image files end in zero-padded frame numbers, for example 'frame0001.bmp', 'frame0002.bmp', etc. The image files can be any format readable by Form>fromFileNamed:. The movie frame extent is taken from the first frame file."

	| jpegFile dir fileNames frameCount frameForm frameOffsets |
	(FileDirectory default directoryExists: folderName)
		ifFalse: [^ self inform: 'Folder not found: ', folderName].
	jpegFile := (FileStream newFileNamed: jpegFileName) binary.
	dir := FileDirectory default on: folderName.
	fileNames := self sortedByFrameNumber: dir fileNames.
	frameCount := fileNames size.
	frameForm := Form fromFileNamed: (dir fullNameFor: fileNames first).

	"write header"
	self writeHeaderExtent: frameForm extent
		frameRate: frameRate
		frameCount: frameCount
		soundtrackCount: 0
		on: jpegFile.

	"convert and write frames"
	frameOffsets := Array new: frameCount + 1.
	1 to: frameCount do: [:i |
		frameOffsets at: i put: jpegFile position.
		frameForm := Form fromFileNamed: (dir fullNameFor: (fileNames at: i)).
		self writeFrame: frameForm on: jpegFile quality: quality displayFlag: true].
	frameOffsets at: (frameCount + 1) put: jpegFile position.
	self updateFrameOffsets: frameOffsets on: jpegFile.

	jpegFile close.
	Display restore.
! !

!JPEGMovieFile class methodsFor: 'movie conversion' stamp: 'stephaneducasse 2/4/2006 20:48'!
convertMPEGFileNamed: mpegFileName toJPEGMovieNamed: jpegFileName quality: quality
	"Convert the MPEG movie with the given file name into a JPEG movie with the given file name."

	| mpegFile jpegFile soundtrackCount movieExtent frameOffsets soundTrackOffsets |
	(FileDirectory default fileExists: mpegFileName)
		ifFalse: [^ self inform: 'File not found: ', mpegFileName].
	(MPEGFile isFileValidMPEG: mpegFileName)
		ifFalse: [^ self inform: 'Not an MPEG file: ', mpegFileName].
	mpegFile := MPEGFile openFile: mpegFileName.
	mpegFile fileHandle ifNil: [^ self inform: 'Could not open ', mpegFileName].
	jpegFile := (FileStream newFileNamed: jpegFileName) binary.

	"write header"
	soundtrackCount := mpegFile hasAudio ifTrue: [1] ifFalse: [0].
	mpegFile hasVideo
		ifTrue: [
			movieExtent := (mpegFile videoFrameWidth: 0)@(mpegFile videoFrameHeight: 0).
			self writeHeaderExtent: movieExtent
				frameRate: (mpegFile videoFrameRate: 0)
				frameCount: (mpegFile videoFrames: 0)
				soundtrackCount: soundtrackCount
				on: jpegFile]
		ifFalse: [
			self writeHeaderExtent: 0@0
				frameRate: 0
				frameCount: 0
				soundtrackCount: soundtrackCount
				on: jpegFile].

	"convert and write frames"
	frameOffsets := self writeFramesFrom: mpegFile on: jpegFile quality: quality.
	self updateFrameOffsets: frameOffsets on: jpegFile.

	"convert and write sound tracks"
	jpegFile position: frameOffsets last.  "store sound tracks after the last frame"
	soundTrackOffsets := self writeSoundTracksFrom: mpegFile on: jpegFile.
	self updateSoundtrackOffsets: soundTrackOffsets frameOffsets: frameOffsets on: jpegFile.

	mpegFile closeFile.
	jpegFile close.
	Display restore.
! !

!JPEGMovieFile class methodsFor: 'movie conversion' stamp: 'stephaneducasse 2/4/2006 20:48'!
convertSqueakMovieNamed: squeakMovieFileName toJPEGMovieNamed: jpegFileName quality: quality
	"Convert the Squeak movie with the given file name into a JPEG movie with the given file name."

	| sqMovieFile jpegFile w h d frameCount mSecsPerFrame frameForm bytesPerFrame frameOffsets |
	(FileDirectory default fileExists: squeakMovieFileName)
		ifFalse: [^ self inform: 'File not found: ', squeakMovieFileName].
	sqMovieFile := (FileStream readOnlyFileNamed: squeakMovieFileName) binary.
	sqMovieFile ifNil: [^ self inform: 'Could not open ', squeakMovieFileName].
	jpegFile := (FileStream newFileNamed: jpegFileName) binary.

	sqMovieFile nextInt32.  "skip first word"
	w := sqMovieFile nextInt32.
	h := sqMovieFile nextInt32.
	d := sqMovieFile nextInt32.
	frameCount := sqMovieFile nextInt32.
	mSecsPerFrame := (sqMovieFile nextInt32) / 1000.0.

	"write header"
	self writeHeaderExtent: w@h
		frameRate: (1000.0 / mSecsPerFrame)
		frameCount: frameCount
		soundtrackCount: 0
		on: jpegFile.

	"convert and write frames"
	frameForm := Form extent: w@h depth: d.
	bytesPerFrame := 4 + (frameForm bits size * 4).
	frameOffsets := Array new: frameCount + 1.
	1 to: frameCount do: [:i |
		frameOffsets at: i put: jpegFile position.
		sqMovieFile position: 128 + ((i - 1) * bytesPerFrame) + 4.
		sqMovieFile next: frameForm bits size into: frameForm bits startingAt: 1.
		frameForm display.
		self writeFrame: frameForm on: jpegFile quality: quality displayFlag: false].
	frameOffsets at: (frameCount + 1) put: jpegFile position.
	self updateFrameOffsets: frameOffsets on: jpegFile.

	sqMovieFile close.
	jpegFile close.
	Display restore.
! !


!JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'stephaneducasse 2/4/2006 20:48'!
extractFrameNumberFrom: aString
	"Answer the integer frame number from the given file name string. The frame number is assumed to be the last contiguous sequence of digits in the given string. For example, 'take2 005.jpg' is frame 5 of the sequence 'take2'."
	"Assume: The given string contains at least one digit."

	| end start |
	end := aString size.
	[(aString at: end) isDigit not] whileTrue: [end := end - 1].
	start := end.
	[(start > 1) and: [(aString at: start - 1) isDigit]] whileTrue: [start := start - 1].
	^ (aString copyFrom: start to: end) asNumber
! !

!JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'stephaneducasse 2/4/2006 20:48'!
sortedByFrameNumber: fileNames
	"Sort the given collection of fileNames by frame number. The frame number is the integer value of the last contiguous sequence of digits in the file name. Omit filenames that do not contain at least one digit; this helps filter out extraneous non-frame files such as the invisible 'Icon' file that may be inserted by some file servers."

	| filtered pairs |
	"select the file names contain at least one digit"
	filtered := fileNames select: [:fn | fn anySatisfy: [:c | c isDigit]].

	"make array of number, name pairs"
	pairs := filtered asArray collect: [:fn |
		Array with: (self extractFrameNumberFrom: fn) with: fn].

	"sort the pairs, then answer a collection containing the second element of every pair"
	pairs sort: [:p1 :p2 | p1 first < p2 first].
	^ pairs collect: [:p | p last].
! !

!JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 11/17/2001 08:05'!
updateFrameOffsets: frameOffsets on: aBinaryStream
	"Update the JPEG movie file header on the given stream with the given collection of frame offsets."

	aBinaryStream position: 22.
	frameOffsets do: [:offset | aBinaryStream uint32: offset].
! !

!JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 11/17/2001 07:40'!
updateSoundtrackOffsets: soundtrackOffsetList frameOffsets: frameOffsets on: aBinaryStream
	"Update the JPEG movie file header on the given stream with the given sequence of sound track offsets."

	aBinaryStream position: 22 + (4 * frameOffsets size).
	aBinaryStream uint16: soundtrackOffsetList size.
	soundtrackOffsetList do: [:offset | aBinaryStream uint32: offset].
! !

!JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'stephaneducasse 2/4/2006 20:48'!
writeFrame: aForm on: aBinaryStream quality: quality displayFlag: displayFlag
	"Compress and the given Form on the given stream and answer its offset. If displayFlag is true, show the result of JPEG compression on the display."

	| offset compressed outForm |
	offset := aBinaryStream position.
	compressed := JPEGReadWriter2 new compress: aForm quality: quality.
	displayFlag ifTrue: [  "show decompressed frame"
		outForm := (JPEGReadWriter2 on: (ReadStream on: compressed)) nextImage.
		outForm display].
	aBinaryStream nextPutAll: compressed.
	^ offset
! !

!JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'stephaneducasse 2/4/2006 20:48'!
writeFramesFrom: mpegFile on: aBinaryStream quality: quality
	"Write the frames of the given MPEG movie on the given stream at the given JPEG quality level. Answer a collection of frame offsets. The size of this collection is one larger than the number of frames; it's final entry is the stream position just after the final frame. The byte count for any frame can thus be computed as the difference between two adjacent offsets."

	| frameCount frameOffsets frameForm |
	mpegFile hasVideo ifFalse: [^ Array with: aBinaryStream position].
	frameCount := mpegFile videoFrames: 0.
	frameOffsets := OrderedCollection new: frameCount + 1.
	frameForm := Form
		extent: (mpegFile videoFrameWidth: 0)@(mpegFile videoFrameHeight: 0)
		depth: 32.

	[(mpegFile videoGetFrame: 0) < (mpegFile videoFrames: 0)] whileTrue: [
		frameOffsets addLast: aBinaryStream position.
		mpegFile videoReadFrameInto: frameForm stream: 0.
		self writeFrame: frameForm on: aBinaryStream quality: quality displayFlag: true].

	frameOffsets addLast: aBinaryStream position.  "add final offset"
	^ frameOffsets
! !

!JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'stephaneducasse 2/4/2006 20:48'!
writeHeaderExtent: movieExtent frameRate: frameRate frameCount: frameCount soundtrackCount: soundtrackCount on: aBinaryStream
	"Write a header on the given stream for a JPEG movie file with the given specifications. Leave the stream positioned at the start of the first movie frame."

	| offsetCount |
	aBinaryStream position: 0.
	aBinaryStream nextPutAll: ('JPEG Movie') asByteArray.
	aBinaryStream uint16: movieExtent x.
	aBinaryStream uint16: movieExtent y.
	aBinaryStream uint32: (frameRate * 10000) rounded.
	offsetCount := frameCount + 1.
	aBinaryStream uint32: offsetCount.
	aBinaryStream skip: (offsetCount * 4).  "leave room for frame offsets"
	aBinaryStream uint16: soundtrackCount.
	aBinaryStream skip: (soundtrackCount * 4).  "leave room for sound track offsets"
! !

!JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'stephaneducasse 2/4/2006 20:48'!
writeSoundTracksFrom: mpegFile on: aBinaryStream
	"Convert and write the sound tracks from the given MPEG file to given stream. Answer a collection of sound track offsets."
	"Details: Currently converts at most one sound track; only the left channel of a stereo movie will be converted."

	| soundtrackCount soundTrackOffsets snd |
	soundtrackCount := mpegFile hasAudio ifTrue: [1] ifFalse: [0].
	soundTrackOffsets := Array new: soundtrackCount.
	1 to: soundtrackCount do: [:i |
		soundTrackOffsets at: i put: aBinaryStream position.
		snd := mpegFile audioPlayerForChannel: i.
		snd storeSunAudioOn: aBinaryStream compressionType: 'mulaw'.
		snd closeFile].
	^ soundTrackOffsets
! !


!JPEGMovieFile class methodsFor: 'movie soundtracks' stamp: 'stephaneducasse 2/4/2006 20:48'!
addSoundtrack: soundFileName toJPEGMovieNamed: jpegFileName compressionType: compressionTypeString
	"Append the given audio file as a soundtrack the given JPEG movie using the given compression type ('none', 'adpcm3', 'adpcm4', 'adpcm5', 'mulaw', or 'gsm')."
	"Note: While the Squeak JPEG movie format supports multiple soundtracks, the player currently plays only the first soundtrack."

	| snd jpegFile outFile frameCount newFrameOffsets buf inFile newSoundtrackOffsets oldMovieName |
	snd := StreamingMonoSound onFileNamed: soundFileName.
	jpegFile := JPEGMovieFile new openFileNamed: jpegFileName.
	outFile := (FileStream newFileNamed: 'movie.tmp') binary.
	frameCount := jpegFile videoFrames: 0.

	"write new header"
	self
		writeHeaderExtent: ((jpegFile videoFrameWidth: 0)@(jpegFile videoFrameHeight: 0))
		frameRate: (jpegFile videoFrameRate: 0)
		frameCount: frameCount
		soundtrackCount: (jpegFile soundtrackOffsets size + 1)
		on: outFile.

	"copy frames to new file"
	newFrameOffsets := Array new: frameCount + 1.
	1 to: frameCount do: [:i |
		newFrameOffsets at: i put: outFile position.
		buf := jpegFile bytesForFrame: i.
		outFile nextPutAll: buf].
	newFrameOffsets at: frameCount + 1 put: outFile position.

	"copy existing soundtracks, if any, to new file"
	jpegFile soundtrackOffsets size > 0 ifTrue: [
		inFile := jpegFile fileHandle.
		inFile position: jpegFile soundtrackOffsets first.
		buf := ByteArray new: 10000.
		[inFile atEnd] whileFalse: [
			buf := inFile next: buf size into: buf startingAt: 1.
			outFile nextPutAll: buf]].

	"adjust soundtrack offsets for header size increase and add new one:"
	newSoundtrackOffsets := jpegFile soundtrackOffsets collect: [:n | n + 4].
	newSoundtrackOffsets := newSoundtrackOffsets copyWith: outFile position.
	snd storeSunAudioOn: outFile compressionType: compressionTypeString.

	"update header:"
	self updateFrameOffsets: newFrameOffsets on: outFile.
	self updateSoundtrackOffsets: newSoundtrackOffsets frameOffsets: newFrameOffsets on: outFile.

	"close files"
	snd closeFile.
	jpegFile closeFile.
	outFile close.

	"replace the old movie with the new version"
	oldMovieName := (jpegFile fileName copyFrom: 1 to: (jpegFile fileName size - 4)), '.old'.
	FileDirectory default deleteFileNamed: oldMovieName.
	FileDirectory default rename: jpegFile fileName toBe: oldMovieName.
	FileDirectory default rename: 'movie.tmp' toBe: jpegFile fileName.
! !

!JPEGMovieFile class methodsFor: 'movie soundtracks' stamp: 'stephaneducasse 2/4/2006 20:48'!
removeSoundtrackFromJPEGMovieNamed: jpegFileName
	"Remove all soundtracks from the JPEG movie with the given name."

	| jpegFile outFile frameCount newFrameOffsets buf oldMovieName |
	jpegFile := JPEGMovieFile new openFileNamed: jpegFileName.
	outFile := (FileStream newFileNamed: 'movie.tmp') binary.
	frameCount := jpegFile videoFrames: 0.

	"write new header"
	self
		writeHeaderExtent: ((jpegFile videoFrameWidth: 0)@(jpegFile videoFrameHeight: 0))
		frameRate: (jpegFile videoFrameRate: 0)
		frameCount: frameCount
		soundtrackCount: 0
		on: outFile.

	"copy frames to new file"
	newFrameOffsets := Array new: frameCount + 1.
	1 to: frameCount do: [:i |
		newFrameOffsets at: i put: outFile position.
		buf := jpegFile bytesForFrame: i.
		outFile nextPutAll: buf].
	newFrameOffsets at: frameCount + 1 put: outFile position.

	"update header:"
	self updateFrameOffsets: newFrameOffsets on: outFile.

	"close files"
	jpegFile closeFile.
	outFile close.

	"replace the old movie with the new version"
	oldMovieName := (jpegFile fileName copyFrom: 1 to: (jpegFile fileName size - 4)), '.old'.
	FileDirectory default deleteFileNamed: oldMovieName.
	FileDirectory default rename: jpegFile fileName toBe: oldMovieName.
	FileDirectory default rename: 'movie.tmp' toBe: jpegFile fileName.
! !


!JPEGMovieFile class methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:48'!
isJPEGMovieFile: fileName
	"Answer true if the file with the given name appears to be a JPEG movie file."

	| f tag |
	(FileDirectory default fileExists: fileName) ifFalse: [^ false].
	f := (FileStream readOnlyFileNamed: fileName) binary.
	tag := (f next: 10) asString.
	f close.
	^ tag = 'JPEG Movie'
! !
ReadStream subclass: #JPEGReadStream
	instanceVariableNames: 'bitBuffer bitsInBuffer'
	classVariableNames: 'MaxBits'
	poolDictionaries: ''
	category: 'Graphics-Files'!
!JPEGReadStream commentStamp: '<historical>' prior: 0!
Encapsulates huffman encoded access to JPEG data.

The following layout is fixed for the JPEG primitives to work:

	collection	<ByteArray | String>
	position		<SmallInteger>
	readLimit	<SmallInteger>
	bitBuffer	<SmallInteger>
	bitsInBuffer	<SmallInteger>!


!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 20:42'!
fillBuffer

	| byte |
	[bitsInBuffer <= 16]
		whileTrue:[
			byte _ self next.
			(byte = 16rFF and: [(self peekFor: 16r00) not])
					ifTrue:
						[self position: self position - 1.
						^0].
			bitBuffer _ (bitBuffer bitShift: 8) bitOr: byte.
			bitsInBuffer _ bitsInBuffer + 8].
	^ bitsInBuffer! !

!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 18:43'!
getBits: requestedBits
	| value |
	requestedBits > bitsInBuffer ifTrue:[
		self fillBuffer.
		requestedBits > bitsInBuffer ifTrue:[
			self error: 'not enough bits available to decode']].
	value _ bitBuffer bitShift: (requestedBits - bitsInBuffer).
	bitBuffer _ bitBuffer bitAnd: (1 bitShift: (bitsInBuffer - requestedBits)) -1.
	bitsInBuffer _ bitsInBuffer - requestedBits.
	^ value! !

!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:34'!
nextByte
	^self next asInteger! !

!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:35'!
nextBytes: n
	^(self next: n) asByteArray! !

!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 17:40'!
reset
	super reset.
	self resetBitBuffer! !

!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 18:44'!
resetBitBuffer
	bitBuffer _ 0.
	bitsInBuffer _ 0.
! !


!JPEGReadStream methodsFor: 'huffman trees' stamp: 'ar 3/4/2001 21:06'!
buildLookupTable: values counts: counts
	| min max |
	min _ max _ nil.
	1 to: counts size do:[:i|
		(counts at: i) = 0 ifFalse:[
			min ifNil:[min _ i-1].
			max _ i]].
	^self
		createHuffmanTables: values 
		counts: {0},counts 
		from: min+1 
		to: max.! !

!JPEGReadStream methodsFor: 'huffman trees' stamp: 'ar 3/4/2001 18:46'!
createHuffmanTables: values counts: counts from: minBits to: maxBits
	"Create the actual tables"
	| table tableStart tableSize tableEnd 
	valueIndex tableStack numValues deltaBits maxEntries
	lastTable lastTableStart tableIndex lastTableIndex |

	table _ WordArray new: ((4 bitShift: minBits) max: 16).

	"Create the first entry - this is a dummy.
	It gives us information about how many bits to fetch initially."
	table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2"

	"Create the first table from scratch."
	tableStart _ 2. "See above"
	tableSize _ 1 bitShift: minBits.
	tableEnd _ tableStart + tableSize.
	"Store the terminal symbols"
	valueIndex _ (counts at: minBits+1).
	tableIndex _ 0.
	1 to: valueIndex do:[:i|
		table at: tableStart + tableIndex put: (values at: i).
		tableIndex _ tableIndex + 1].
	"Fill up remaining entries with invalid entries"
	tableStack _ OrderedCollection new: 10. "Should be more than enough"
	tableStack addLast: 
		(Array 
			with: minBits	"Number of bits (e.g., depth) for this table"
			with: tableStart	"Start of table"
			with: tableIndex "Next index in table"
			with: minBits	"Number of delta bits encoded in table"
			with: tableSize - valueIndex "Entries remaining in table").
	"Go to next value index"
	valueIndex _ valueIndex + 1.
	"Walk over remaining bit lengths and create new subtables"
	minBits+1 to: maxBits do:[:bits|
		numValues _ counts at: bits+1.
		[numValues > 0] whileTrue:["Create a new subtable"
			lastTable _ tableStack last.
			lastTableStart _ lastTable at: 2.
			lastTableIndex _ lastTable at: 3.
			deltaBits _ bits - (lastTable at: 1).
			"Make up a table of deltaBits size"
			tableSize _ 1 bitShift: deltaBits.
			tableStart _ tableEnd.
			tableEnd _ tableEnd + tableSize.
			[tableEnd > table size ]
				whileTrue:[table _ self growHuffmanTable: table].
			"Connect to last table"
			self assert:[(table at: lastTableStart + lastTableIndex) = 0]."Entry must be unused"
			table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart.
			lastTable at: 3 put: lastTableIndex+1.
			lastTable at: 5 put: (lastTable at: 5) - 1.
			self assert:[(lastTable at: 5) >= 0]. "Don't exceed tableSize"
			"Store terminal values"
			maxEntries _ numValues min: tableSize.
			tableIndex _ 0.
			1 to: maxEntries do:[:i|
				table at: tableStart + tableIndex put: (values at: valueIndex).
				valueIndex _ valueIndex + 1.
				numValues _ numValues - 1.
				tableIndex _ tableIndex+1].
			"Check if we have filled up the current table completely"
			maxEntries = tableSize ifTrue:[
				"Table has been filled. Back up to the last table with space left."
				[tableStack isEmpty not and:[(tableStack last at: 5) = 0]]
						whileTrue:[tableStack removeLast].
			] ifFalse:[
				"Table not yet filled. Put it back on the stack."
				tableStack addLast:
					(Array
						with: bits		"Nr. of bits in this table"
						with: tableStart	"Start of table"
						with: tableIndex "Index in table"
						with: deltaBits	"delta bits of table"
						with: tableSize - maxEntries "Unused entries in table").
			].
		].
	].
	 ^table copyFrom: 1 to: tableEnd-1! !

!JPEGReadStream methodsFor: 'huffman trees' stamp: 'ar 3/4/2001 18:44'!
decodeValueFrom: table
	"Decode the next value in the receiver using the given huffman table."
	| bits bitsNeeded tableIndex value |
	bitsNeeded _ (table at: 1) bitShift: -24.	"Initial bits needed"
	tableIndex _ 2.							"First real table"
	[bits _ self getBits: bitsNeeded.			"Get bits"
	value _ table at: (tableIndex + bits).		"Lookup entry in table"
	(value bitAnd: 16r3F000000) = 0] 			"Check if it is a non-leaf node"
		whileFalse:["Fetch sub table"
			tableIndex _ value bitAnd: 16rFFFF.	"Table offset in low 16 bit"
			bitsNeeded _ (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit"
			bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']].
	^value! !

!JPEGReadStream methodsFor: 'huffman trees' stamp: 'ar 3/4/2001 18:21'!
growHuffmanTable: table
	| newTable |
	newTable _ table species new: table size * 2.
	newTable replaceFrom: 1 to: table size with: table startingAt: 1.
	^newTable! !

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

JPEGReadStream class
	instanceVariableNames: ''!

!JPEGReadStream class methodsFor: 'class initialization' stamp: 'ar 3/4/2001 18:32'!
initialize
	"JPEGReadStream initialize"
	MaxBits _ 16.! !
ImageReadWriter subclass: #JPEGReadWriter
	instanceVariableNames: 'width height components currentComponents qTable hACTable hDCTable restartInterval restartsToGo mcuWidth mcuHeight mcusPerRow mcuRowsInScan mcuMembership mcuSampleBuffer mcuImageBuffer majorVersion minorVersion dataPrecision densityUnit xDensity yDensity ss se ah al sosSeen residuals ditherMask'
	classVariableNames: 'ConstBits DCTK1 DCTK2 DCTK3 DCTK4 DCTSize DCTSize2 DitherMasks FIXn0n298631336 FIXn0n34414 FIXn0n390180644 FIXn0n541196100 FIXn0n71414 FIXn0n765366865 FIXn0n899976223 FIXn1n175875602 FIXn1n40200 FIXn1n501321110 FIXn1n77200 FIXn1n847759065 FIXn1n961570560 FIXn2n053119869 FIXn2n562915447 FIXn3n072711026 FloatSampleOffset HuffmanTableSize JFIFMarkerParser JPEGNaturalOrder MaxSample Pass1Bits Pass1Div Pass2Div QTableScaleFactor QuantizationTableSize SampleOffset'
	poolDictionaries: ''
	category: 'Graphics-Files'!
!JPEGReadWriter commentStamp: '<historical>' prior: 0!
I am a subclass of ImageReadWriter that understands JFIF file streams, and can decode JPEG images.
This code is based upon the Independent Joint Photographic Experts Group (IJPEG) software, originally written in C by Tom Lane, Philip Gladstone, Luis Ortiz, Jim Boucher, Lee Crocker, Julian Minguillon, George Phillips, Davide Rossi, Ge' Weijers, and other members of the Independent JPEG Group.

!


!JPEGReadWriter methodsFor: 'accessing' stamp: 'tao 10/19/97 13:46'!
hACTable

	hACTable ifNil: [hACTable _ Array new: HuffmanTableSize].
	^ hACTable! !

!JPEGReadWriter methodsFor: 'accessing' stamp: 'tao 10/19/97 13:46'!
hDCTable

	hDCTable ifNil: [hDCTable _ Array new: HuffmanTableSize].
	^ hDCTable! !

!JPEGReadWriter methodsFor: 'accessing' stamp: 'tao 10/19/97 08:46'!
qTable

	qTable ifNil: [qTable _ Array new: QuantizationTableSize].
	^ qTable! !


!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:18'!
colorConvertFloatYCbCrMCU

	| ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits |
	ySampleStream _ currentComponents at: 1.
	cbSampleStream _ currentComponents at: 2.
	crSampleStream _ currentComponents at: 3.
	ySampleStream resetSampleStream.
	cbSampleStream resetSampleStream.
	crSampleStream resetSampleStream.
	bits _ mcuImageBuffer bits.
	1 to: bits size do:
		[:i |
		y _ ySampleStream nextSample.
		cb _ cbSampleStream nextSample - FloatSampleOffset.
		cr _ crSampleStream nextSample - FloatSampleOffset.
		red _ self sampleFloatRangeLimit: (y + (1.40200 * cr)).
		green _ self sampleFloatRangeLimit: (y - (0.34414 * cb) - (0.71414 * cr)).
		blue _ self sampleFloatRangeLimit: (y + (1.77200 * cb)).
		bits at: i put: 16rFF000000 + (red << 16) + (green << 8) + blue].
	! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:17'!
colorConvertGrayscaleMCU

	| ySampleStream y bits |
	ySampleStream _ currentComponents at: 1.
	ySampleStream resetSampleStream.
	bits _ mcuImageBuffer bits.
	1 to: bits size do:
		[:i |
		y _ (ySampleStream nextSample) + (residuals at: 2).
		y > MaxSample ifTrue: [y _ MaxSample].
		residuals at: 2 put: (y bitAnd: ditherMask).
		y _ y bitAnd: MaxSample - ditherMask.
		y < 1 ifTrue: [y _ 1].
		bits at: i put: 16rFF000000 + (y<<16) + (y<<8) + y].
	! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:18'!
colorConvertIntYCbCrMCU

	| ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits |
	ySampleStream _ currentComponents at: 1.
	cbSampleStream _ currentComponents at: 2.
	crSampleStream _ currentComponents at: 3.
	ySampleStream resetSampleStream.
	cbSampleStream resetSampleStream.
	crSampleStream resetSampleStream.
	bits _ mcuImageBuffer bits.
	1 to: bits size do:
		[:i |
		y _ ySampleStream nextSample.
		cb _ cbSampleStream nextSample - SampleOffset.
		cr _ crSampleStream nextSample - SampleOffset.
		red _ y + ((FIXn1n40200 * cr) // 65536) + (residuals at: 1).
		red > MaxSample
			ifTrue: [red _ MaxSample]
			ifFalse: [red < 0 ifTrue: [red _ 0]].
		residuals at: 1 put: (red bitAnd: ditherMask).
		red _ red bitAnd: MaxSample - ditherMask.
		red < 1 ifTrue: [red _ 1].
		green _ y - ((FIXn0n34414 * cb) // 65536) -
			((FIXn0n71414 * cr) // 65536) + (residuals at: 2).
		green > MaxSample
			ifTrue: [green _ MaxSample]
			ifFalse: [green < 0 ifTrue: [green _ 0]].
		residuals at: 2 put: (green bitAnd: ditherMask).
		green _ green bitAnd: MaxSample - ditherMask.
		green < 1 ifTrue: [green _ 1].
		blue _ y + ((FIXn1n77200 * cb) // 65536) + (residuals at: 3).
		blue > MaxSample
			ifTrue: [blue _ MaxSample]
			ifFalse: [blue < 0 ifTrue: [blue _ 0]].
		residuals at: 3 put: (blue bitAnd: ditherMask).
		blue _ blue bitAnd: MaxSample - ditherMask.
		blue < 1 ifTrue: [blue _ 1].
		bits at: i put: 16rFF000000 + (red bitShift: 16) + (green bitShift: 8) + blue].
	! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/7/2001 01:02'!
colorConvertMCU

	^ currentComponents size = 3
		ifTrue:
			[self useFloatingPoint
				ifTrue: [self colorConvertFloatYCbCrMCU]
				ifFalse: [self primColorConvertYCbCrMCU: currentComponents
								bits: mcuImageBuffer bits
								residuals: residuals
								ditherMask: ditherMask.]]
		ifFalse: [self primColorConvertGrayscaleMCU]! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:19'!
primColorConvertGrayscaleMCU
	self primColorConvertGrayscaleMCU: (currentComponents at: 1)
			bits: mcuImageBuffer bits
			residuals: residuals
			ditherMask: ditherMask.! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/15/2001 18:11'!
primColorConvertGrayscaleMCU: componentArray bits: bits residuals: residualArray ditherMask: mask
	<primitive: 'primitiveColorConvertGrayscaleMCU' module: 'JPEGReaderPlugin'>
	"JPEGReaderPlugin doPrimitive: #primitiveColorConvertGrayscaleMCU."
	^self colorConvertGrayscaleMCU! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'!
primColorConvertIntYCbCrMCU
	self primColorConvertYCbCrMCU: currentComponents
			bits: mcuImageBuffer bits
			residuals: residuals
			ditherMask: ditherMask.! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'!
primColorConvertYCbCrMCU: componentArray bits: bits residuals: residualArray ditherMask: mask
	<primitive: 'primitiveColorConvertMCU' module: 'JPEGReaderPlugin'>
	^self colorConvertIntYCbCrMCU! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 10/26/97 15:43'!
sampleFloatRangeLimit: aNumber

	^ (aNumber rounded max: 0) min: MaxSample! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'di 9/15/1998 14:30'!
sampleRangeLimit: aNumber

	aNumber < 0 ifTrue: [^ 0].
	aNumber > MaxSample ifTrue: [^ MaxSample].
	^ aNumber! !


!JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 15:16'!
dctFloatRangeLimit: value

	^ (value / 8.0) + FloatSampleOffset.! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 16:34'!
idctBlockFloat: anArray component: aColorComponent

	| t0 t1 t2 t3 t4 t5 t6 t7 t10 t11 t12 t13 z5 z10 z11 z12 z13 qt ws |
	qt _ self qTable at: (aColorComponent qTableIndex).
	ws _ Array new: DCTSize2.

	"Pass 1: process columns from input, store into work array"
	1 to: DCTSize do: [:i |
		t0 _ (anArray at: i) * (qt at: i).
		t1 _ (anArray at: (DCTSize*2 + i)) * (qt at: (DCTSize*2 + i)).
		t2 _ (anArray at: (DCTSize*4 + i)) * (qt at: (DCTSize*4 + i)).
		t3 _ (anArray at: (DCTSize*6 + i)) * (qt at: (DCTSize*6 + i)).
		t10 _ t0 + t2.
		t11 _ t0 - t2.
		t13 _ t1 + t3.
		t12 _ (t1 - t3) * DCTK1 - t13.
		t0 _ t10 + t13.
		t3 _ t10 - t13.
		t1 _ t11 + t12.
		t2 _ t11 - t12.
		t4 _ (anArray at: (DCTSize + i)) * (qt at: (DCTSize + i)).
		t5 _ (anArray at: (DCTSize*3 + i)) * (qt at: (DCTSize*3 + i)).
		t6 _ (anArray at: (DCTSize*5 + i)) * (qt at: (DCTSize*5 + i)).
		t7 _ (anArray at: (DCTSize*7 + i)) * (qt at: (DCTSize*7 + i)).
		z13 _ t6 + t5.
		z10 _ t6 - t5.
		z11 _ t4 + t7.
		z12 _ t4 - t7.
		t7 _ z11 + z13.
		t11 _ (z11 - z13) * DCTK1.
		z5 _ (z10 + z12) * DCTK2.
		t10 _ DCTK3 * z12 - z5.
		t12 _ DCTK4 * z10 + z5.
		t6 _ t12 - t7.
		t5 _ t11 - t6.
		t4 _ t10 + t5.
		ws at: i put: t0 + t7.
		ws at: (DCTSize*7 + i) put: t0 - t7.
		ws at: (DCTSize + i) put: t1 + t6.
		ws at: (DCTSize*6 + i) put: t1 - t6.
		ws at: (DCTSize*2 + i) put: t2 + t5.
		ws at: (DCTSize*5 + i) put: t2 - t5.
		ws at: (DCTSize*4 + i) put: t3 + t4.
		ws at: (DCTSize*3 + i) put: t3 - t4].

		"Pass 2: process rows from the workspace"
	(0 to: DCTSize2-DCTSize by: DCTSize) do: [:i |
		t10 _ (ws at: (i+1)) + (ws at: (i+5)).
		t11 _ (ws at: (i+1)) - (ws at: (i+5)).
		t13 _ (ws at: (i+3)) + (ws at: (i+7)).
		t12 _ ((ws at: (i+3)) - (ws at: (i+7))) * DCTK1 - t13.
		t0 _ t10 + t13.
		t3 _ t10 - t13.
		t1 _ t11 + t12.
		t2 _ t11 - t12.
		z13 _ (ws at: (i+6)) + (ws at: (i+4)).
		z10 _ (ws at: (i+6)) - (ws at: (i+4)).
		z11 _ (ws at: (i+2)) + (ws at: (i+8)).
		z12 _ (ws at: (i+2)) - (ws at: (i+8)).
		t7 _ z11 + z13.
		t11 _ (z11 - z13) * DCTK1.
		z5 _ (z10 + z12) * DCTK2.
		t10 _ DCTK3 * z12 - z5.
		t12 _ DCTK4 * z10 + z5.
		t6 _ t12 - t7.
		t5 _ t11 - t6.
		t4 _ t10 + t5.

		"final output stage: scale down by a factor of 8 and range-limit"
		anArray at: (i+1) put: (self dctFloatRangeLimit: (t0 + t7)).
		anArray at: (i+8) put: (self dctFloatRangeLimit: (t0 - t7)).
		anArray at: (i+2) put: (self dctFloatRangeLimit: (t1 + t6)).
		anArray at: (i+7) put: (self dctFloatRangeLimit: (t1 - t6)).
		anArray at: (i+3) put: (self dctFloatRangeLimit: (t2 + t5)).
		anArray at: (i+6) put: (self dctFloatRangeLimit: (t2 - t5)).
		anArray at: (i+5) put: (self dctFloatRangeLimit: (t3 + t4)).
		anArray at: (i+4) put: (self dctFloatRangeLimit: (t3 - t4))]


! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'!
idctBlockInt: anArray component: aColorComponent
	^self idctBlockInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:34'!
idctBlockInt: anArray qt: qt

	|  ws anACTerm dcval z1 z2 z3 z4 z5 t0 t1 t2 t3 t10 t11 t12 t13 shift |
	ws _ Array new: DCTSize2.

	"Pass 1: process columns from anArray, store into work array"
	shift _ 1 bitShift: ConstBits - Pass1Bits.
	1 to: DCTSize do:
		[:i |
		anACTerm _ nil.
		1 to: DCTSize-1 do:[:row|
			anACTerm ifNil:[
				(anArray at: row * DCTSize + i) = 0 ifFalse:[anACTerm _ row]]].
		anACTerm == nil
			ifTrue:
				[dcval _ (anArray at: i) * (qt at: 1) bitShift: Pass1Bits.
				0 to: DCTSize-1 do: [:j | ws at: (j * DCTSize + i) put: dcval]]
			ifFalse:
				[z2 _ (anArray at: (DCTSize * 2 + i)) * (qt at: (DCTSize * 2 + i)).
				z3 _ (anArray at: (DCTSize * 6 + i)) * (qt at: (DCTSize * 6 + i)).
				z1 _ (z2 + z3) * FIXn0n541196100.
				t2 _ z1 + (z3 * FIXn1n847759065 negated).
				t3 _ z1 + (z2 * FIXn0n765366865).
				z2 _ (anArray at: i) * (qt at: i).
				z3 _ (anArray at: (DCTSize * 4 + i)) * (qt at: (DCTSize * 4 + i)).
				t0 _ (z2 + z3) bitShift: ConstBits.
				t1 _ (z2 - z3) bitShift: ConstBits.
				t10 _ t0 + t3.
				t13 _ t0 - t3.
				t11 _ t1 + t2.
				t12 _ t1 - t2.
				t0 _ (anArray at: (DCTSize * 7 + i)) * (qt at: (DCTSize * 7 + i)).
				t1 _ (anArray at: (DCTSize * 5 + i)) * (qt at: (DCTSize * 5 + i)).
				t2 _ (anArray at: (DCTSize * 3 + i)) * (qt at: (DCTSize * 3 + i)).
				t3 _ (anArray at: (DCTSize + i)) * (qt at: (DCTSize + i)).
				z1 _ t0 + t3.
				z2 _ t1 + t2.
				z3 _ t0 + t2.
				z4 _ t1 + t3.
				z5 _ (z3 + z4) * FIXn1n175875602.
				t0 _ t0 * FIXn0n298631336.
				t1 _ t1 * FIXn2n053119869.
				t2 _ t2 * FIXn3n072711026.
				t3 _ t3 * FIXn1n501321110.
				z1 _ z1 * FIXn0n899976223 negated.
				z2 _ z2 * FIXn2n562915447 negated.
				z3 _ z3 * FIXn1n961570560 negated.
				z4 _ z4 * FIXn0n390180644 negated.
				z3 _ z3 + z5.
				z4 _ z4 + z5.
				t0 _ t0 + z1 + z3.
				t1 _ t1 +z2 +z4.
				t2 _ t2 + z2 + z3.
				t3 _ t3 + z1 + z4.
				ws at: i put: (t10 + t3) >> (ConstBits - Pass1Bits).
				ws at: (DCTSize * 7 + i) put: (t10 - t3) // shift.
				ws at: (DCTSize * 1 + i) put: (t11 + t2) // shift.
				ws at: (DCTSize * 6 + i) put: (t11 - t2) // shift.
				ws at: (DCTSize * 2 + i) put: (t12 + t1) // shift.
				ws at: (DCTSize * 5 + i) put: (t12 - t1) // shift.
				ws at: (DCTSize * 3 + i) put: (t13 + t0) // shift.
				ws at: (DCTSize * 4 + i) put: (t13 - t0) // shift]].

	"Pass 2: process rows from work array, store back into anArray"
	shift _ 1 bitShift: ConstBits + Pass1Bits + 3.
	0 to: DCTSize2-DCTSize by: DCTSize do:
		[:i |
		z2 _ ws at: i + 3.
		z3 _ ws at: i + 7.
		z1 _ (z2 + z3) * FIXn0n541196100.
		t2 _ z1 + (z3 * FIXn1n847759065 negated).
		t3 _ z1 + (z2 * FIXn0n765366865).
		t0 _ (ws at: (i + 1)) + (ws at: (i + 5)) bitShift: ConstBits.
		t1 _ (ws at: (i + 1)) - (ws at: (i + 5)) bitShift: ConstBits.
		t10 _ t0 + t3.
		t13 _ t0 - t3.
		t11 _ t1 + t2.
		t12 _ t1 -t2.
		t0 _ ws at: (i + 8).
		t1 _ ws at: (i + 6).
		t2 _ ws at: (i + 4).
		t3 _ ws at: (i + 2).
		z1 _ t0 + t3.
		z2 _ t1 + t2.
		z3 _ t0 + t2.
		z4 _ t1 + t3.
		z5 _ (z3 + z4) * FIXn1n175875602.
		t0 _ t0 * FIXn0n298631336.
		t1 _ t1 * FIXn2n053119869.
		t2 _ t2 * FIXn3n072711026.
		t3 _ t3 * FIXn1n501321110.
		z1 _ z1 * FIXn0n899976223 negated.
		z2 _ z2 * FIXn2n562915447 negated.
		z3 _ z3 * FIXn1n961570560 negated.
		z4 _ z4 * FIXn0n390180644 negated.
		z3 _ z3 + z5.
		z4 _ z4 + z5.
		t0 _ t0 + z1 + z3.
		t1 _ t1 + z2 + z4.
		t2 _ t2 + z2 + z3.
		t3 _ t3 + z1 + z4.
		anArray at: (i + 1) put: (self sampleRangeLimit: (t10 + t3) // shift + SampleOffset).
		anArray at: (i + 8) put: (self sampleRangeLimit: (t10 - t3) // shift + SampleOffset).
		anArray at: (i + 2) put: (self sampleRangeLimit: (t11 + t2) // shift + SampleOffset).
		anArray at: (i + 7) put: (self sampleRangeLimit: (t11 - t2) // shift + SampleOffset).
		anArray at: (i + 3) put: (self sampleRangeLimit: (t12 + t1) // shift + SampleOffset).
		anArray at: (i + 6) put: (self sampleRangeLimit: (t12 - t1) // shift + SampleOffset).
		anArray at: (i + 4) put: (self sampleRangeLimit: (t13 + t0) // shift + SampleOffset).
		anArray at: (i + 5) put: (self sampleRangeLimit: (t13 - t0) // shift + SampleOffset)].


! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/7/2001 00:58'!
idctMCU

	| comp fp ci |
	fp _ self useFloatingPoint.
	1 to: mcuMembership size do:[:i|
		ci _ mcuMembership at: i.
		comp _ currentComponents at: ci.
		fp ifTrue:[
			self idctBlockFloat: (mcuSampleBuffer at: i) component: comp.
		] ifFalse:[
			self primIdctInt: (mcuSampleBuffer at: i)
				qt: (qTable at: comp qTableIndex)]].! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:37'!
primIdctBlockInt: anArray component: aColorComponent
	^self primIdctInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'!
primIdctInt: anArray qt: qt
	<primitive: 'primitiveIdctInt' module: 'JPEGReaderPlugin'>
	^self idctBlockInt: anArray qt: qt! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 16:16'!
scaleQuantizationTable: table

	| index |

	index _ 1.
	1 to: DCTSize do:
		[:row |
		1 to: DCTSize do:
			[:col |
			table at: index
				put: ((table at: index) * (QTableScaleFactor at: row) *
					(QTableScaleFactor at: col)) rounded.
			index _ index + 1]].
	^ table
! !


!JPEGReadWriter methodsFor: 'error handling' stamp: 'tao 10/19/97 12:25'!
notSupported: aString

	self error: aString , ' is not currently supported'! !


!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 20:55'!
decodeBlockInto: anArray component: aColorComponent dcTable: huffmanDC acTable: huffmanAC

	| byte i zeroCount |
	byte _ stream decodeValueFrom: huffmanDC.
	byte ~= 0 ifTrue: [byte _ self scaleAndSignExtend: ( self getBits: byte) inFieldWidth: byte].
	byte _ aColorComponent updateDCValue: byte.
	anArray atAllPut: 0.
	anArray at: 1 put: byte.
	i _ 2.
	[i <= DCTSize2] whileTrue:
		[byte _ stream decodeValueFrom: huffmanAC.
		zeroCount _ byte >> 4.
		byte _ byte bitAnd: 16r0F.
		byte ~= 0
			ifTrue:
				[i _ i + zeroCount.
				byte _ self scaleAndSignExtend: ( self getBits: byte) inFieldWidth: byte.
				anArray at:	 (JPEGNaturalOrder at: i) put: byte]
			ifFalse:
				[zeroCount = 15 ifTrue: [i _ i + zeroCount] ifFalse: [^ self]].
		i _ i + 1]
		! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/7/2001 01:00'!
decodeMCU

	| comp ci |
	(restartInterval ~= 0 and: [restartsToGo = 0]) ifTrue: [self processRestart].
	1 to: mcuMembership size do:[:i|
		ci _ mcuMembership at: i.
		comp _ currentComponents at: ci.
		self
			primDecodeBlockInto: (mcuSampleBuffer at: i)
			component: comp
			dcTable: (hDCTable at: comp dcTableIndex)
			acTable: (hACTable at: comp acTableIndex)
			stream: stream.
	].
	restartsToGo _ restartsToGo - 1.! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 17:27'!
getBits: requestedBits
	^stream getBits: requestedBits! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 21:32'!
primDecodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable stream: jpegStream
	<primitive: 'primitiveDecodeMCU' module: 'JPEGReaderPlugin'>
	^self decodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 17:40'!
processRestart
	stream resetBitBuffer.
	self parseNextMarker.
	currentComponents do: [:c | c priorDCValue: 0].
	restartsToGo _ restartInterval.! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 01:17'!
scaleAndSignExtend: aNumber inFieldWidth: w

	aNumber < (1 bitShift: (w - 1))
		ifTrue: [^aNumber - (1 bitShift: w) + 1]
		ifFalse: [^aNumber]! !


!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/4/2001 18:38'!
initialSOSSetup

	mcuWidth _ (components detectMax: [:c | c widthInBlocks]) widthInBlocks.
	mcuHeight _ (components detectMax: [:c | c heightInBlocks]) heightInBlocks.
	components do:[:c |
		c mcuWidth: mcuWidth mcuHeight: mcuHeight dctSize: DCTSize].
	stream resetBitBuffer.! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'mir 6/13/2001 13:06'!
okToIgnoreMarker: aMarker

	^ (((16rE0 to: 16rEF) includes: aMarker) "unhandled APPn markers"
		or: [aMarker = 16rDC or: [aMarker = 16rFE]]) "DNL or COM markers"
		or: [aMarker = 16r99] "Whatever that is"! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/6/2001 22:28'!
parseAPPn

	| length buffer thumbnailLength markerStart |
	markerStart _ self position.
	length _ self nextWord.
	buffer _ self next: 4.
	(buffer asString = 'JFIF') ifFalse: [
		"Skip APPs that we're not interested in"
		stream next: length-6.
		^self].
	self next.
	majorVersion _ self next.
	minorVersion _ self next.
	densityUnit _ self next.
	xDensity _ self nextWord.
	yDensity _ self nextWord.
	thumbnailLength _ self next * self next * 3.
	length _ length - (self position - markerStart).
	length = thumbnailLength ifFalse: [self error: 'APP0 thumbnail length is incorrect.'].
	self next: length! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/20/97 13:36'!
parseDecoderRestartInterval

	| length |
	length _ self nextWord.
	length = 4 ifFalse: [self error: 'DRI length incorrect'].
	restartInterval _ self nextWord.! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'mir 6/12/2001 11:28'!
parseFirstMarker

	| marker |
	self next = 16rFF ifFalse: [self error: 'JFIF marker expected'].
	marker _ self next.
	marker = 16rD9
		ifTrue: [^self "halt: 'EOI encountered.'"].
	marker = 16rD8 ifFalse: [self error: 'SOI marker expected'].
	self parseStartOfInput.
! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/4/2001 18:36'!
parseHuffmanTable

	| length markerStart index bits count huffVal isACTable hTable |
	markerStart _ self position.
	length _ self nextWord.
	[self position - markerStart >= length] whileFalse:
		[index _ self next.
		isACTable _ (index bitAnd: 16r10) ~= 0.
		index _ (index bitAnd: 16r0F) + 1.
		index > HuffmanTableSize
			ifTrue: [self error: 'image has more than ', HuffmanTableSize printString,
				' quantization tables'].
		bits _ self next: 16.
		count _ bits sum.
		(count > 256 or: [(count > (length - (self position - markerStart)))])
			ifTrue: [self error: 'Huffman Table count is incorrect'].
		huffVal _ self next: count.
		hTable _ stream buildLookupTable: huffVal counts: bits.
		isACTable
			ifTrue:
				[self hACTable at: index put: hTable]
			ifFalse:
				[self hDCTable at: index put: hTable]].! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/24/97 17:32'!
parseNOP

	"don't need to do anything, here"! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'BG 3/16/2005 08:24'!
parseNextMarker
	"Parse the next marker of the stream"

	| byte discardedBytes |
	discardedBytes _ 0.
	[(byte _ self next) = 16rFF] whileFalse: [discardedBytes _ discardedBytes + 1].	
	[[(byte _ self next) = 16rFF] whileTrue. byte = 16r00] whileTrue:
		[discardedBytes _ discardedBytes + 2].
	discardedBytes > 0 ifTrue: [self "notifyWithLabel: 'warning: extraneous data discarded'"].
	self perform:
		(JFIFMarkerParser
			at: byte
			ifAbsent:
				[(self okToIgnoreMarker: byte)
					ifTrue: [#skipMarker]
					ifFalse: [self error: 'marker ', byte printStringHex , ' cannot be handled']])! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/3/2001 22:19'!
parseQuantizationTable

	| length markerStart n prec value table |
	markerStart _ self position.
	length _ self nextWord.
	[self position - markerStart >= length] whileFalse:
		[value _ self next.
		n _ (value bitAnd: 16r0F) + 1.
		prec _ (value >> 4) > 0.
		n > QuantizationTableSize
			 ifTrue: [self error: 'image has more than ',
				QuantizationTableSize printString,
				' quantization tables'].
		table _ IntegerArray new: DCTSize2.
		1 to: DCTSize2 do:
			[:i |
			value _ (prec
				ifTrue: [self nextWord]
				ifFalse: [self next]).
			table at: (JPEGNaturalOrder at: i) put: value].
		self useFloatingPoint ifTrue: [self scaleQuantizationTable: table].
		self qTable at: n put: table]! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/24/97 17:07'!
parseStartOfFile

	| length markerStart value n |
	markerStart _ self position.
	length _ self nextWord.
	dataPrecision _ self next.
	dataPrecision = 8
		ifFalse: [self error: 'cannot handle ', dataPrecision printString, '-bit components'].
	height _ self nextWord.
	width _ self nextWord.
	n _ self next.
	(height = 0) | (width = 0) | (n = 0) ifTrue: [self error: 'empty image'].
	(length - (self position - markerStart)) ~= (n * 3)
		ifTrue: [self error: 'component length is incorrect'].
	components _ Array new: n.
	1 to: components size do:
		[:i |
		components
			at: i
			put:
				(JPEGColorComponent new
					id: self next;
					"heightInBlocks: (((value _ self next) >> 4) bitAnd: 16r0F);
					widthInBlocks: (value bitAnd: 16r0F);"
					widthInBlocks: (((value _ self next) >> 4) bitAnd: 16r0F);
					heightInBlocks: (value bitAnd: 16r0F);

					qTableIndex: self next + 1)]! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/22/97 17:38'!
parseStartOfInput

	restartInterval _ 0.
	densityUnit _ 0.
	xDensity _ 1.
	yDensity _ 1
! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/26/97 21:53'!
parseStartOfScan

	| length n id value dcNum acNum comp |
	length _ self nextWord.
	n _ self next.
	(length ~= (n*2 + 6)) | (n < 1) ifTrue: [self error: 'SOS length is incorrect'].
	currentComponents _ Array new: n.
	1 to: n do: [:i |
		id _ self next.
		value _ self next.
		dcNum _ (value >> 4) bitAnd: 16r0F.
		acNum _ value bitAnd: 16r0F.
		comp _ components detect: [:c | c id = id].
		comp
			dcTableIndex: dcNum+1;
			acTableIndex: acNum+1.
		currentComponents at: i put: comp].
	ss _ self next.
	se _ self next.
	value _ self next.
	ah _ (value >> 4) bitAnd: 16r0F.
	al _ value bitAnd: 16r0F.
	self initialSOSSetup.
	self perScanSetup.
	sosSeen _ true! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/7/2001 01:01'!
perScanSetup

	mcusPerRow _ (width / (mcuWidth * DCTSize)) ceiling.
	mcuRowsInScan _ (height / (mcuHeight * DCTSize)) ceiling.
	(currentComponents size = 3 or: [currentComponents size = 1])
		ifFalse: [self error: 'JPEG color space not recognized'].
	mcuMembership _ OrderedCollection new.
	currentComponents withIndexDo:
		[:c :i |
		c priorDCValue: 0.
		mcuMembership addAll: ((1 to: c totalMcuBlocks) collect: [:b | i])].
	mcuMembership _ mcuMembership asArray.
	mcuSampleBuffer _ (1 to: mcuMembership size) collect: [:i | IntegerArray new: DCTSize2].
	currentComponents withIndexDo:
		[:c :i |
			c initializeSampleStreamBlocks:
				((1 to: mcuMembership size)
					select: [:j | i = (mcuMembership at: j)]
					thenCollect: [:j | mcuSampleBuffer at: j])].
	mcuImageBuffer _ Form
		extent: (mcuWidth @ mcuHeight) * DCTSize
		depth: 32.
	restartsToGo _ restartInterval.! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/22/97 16:27'!
skipMarker

	| length markerStart |
	markerStart _ self position.
	length _ self nextWord.
	self next: length - (self position - markerStart)
! !


!JPEGReadWriter methodsFor: 'preferences' stamp: 'tao 10/26/97 22:09'!
useFloatingPoint

	^ false! !


!JPEGReadWriter methodsFor: 'public access' stamp: 'ar 3/7/2001 00:18'!
decompressionTest
	"Test decompression; don't generate actual image"
	| xStep yStep x y |
MessageTally spyOn:[
	ditherMask _ DitherMasks at: 32.
	residuals _ WordArray new: 3.
	sosSeen _ false.
	self parseFirstMarker.
	[sosSeen] whileFalse: [self parseNextMarker].
	xStep _ mcuWidth * DCTSize.
	yStep _ mcuHeight * DCTSize.
	y _ 0.
	1 to: mcuRowsInScan do:
		[:row |
		x _ 0.
		1 to: mcusPerRow do:
			[:col |
			self decodeMCU.
			self idctMCU.
			self colorConvertMCU.
			x _ x + xStep].
		y _ y + yStep].
].! !

!JPEGReadWriter methodsFor: 'public access' stamp: 'tao 9/18/1998 08:53'!
nextImage

	^ self nextImageDitheredToDepth: Display depth
! !

!JPEGReadWriter methodsFor: 'public access' stamp: 'ar 10/28/2001 16:25'!
nextImageDitheredToDepth: depth

	| form xStep yStep x y bb |
	ditherMask _ DitherMasks
		at: depth
		ifAbsent: [self error: 'can only dither to display depths'].
	residuals _ WordArray new: 3.
	sosSeen _ false.
	self parseFirstMarker.
	[sosSeen] whileFalse: [self parseNextMarker].
	form _ Form extent: (width @ height) depth: depth.
	bb _ BitBlt current toForm: form.
	bb sourceForm: mcuImageBuffer.
	bb colorMap: (mcuImageBuffer colormapIfNeededFor: form).
	bb sourceRect: mcuImageBuffer boundingBox.
	bb combinationRule: Form over.
	xStep _ mcuWidth * DCTSize.
	yStep _ mcuHeight * DCTSize.
	y _ 0.
	1 to: mcuRowsInScan do:
		[:row |
		x _ 0.
		1 to: mcusPerRow do:
			[:col |
			self decodeMCU.
			self idctMCU.
			self colorConvertMCU.
			bb destX: x; destY: y; copyBits.
			x _ x + xStep].
		y _ y + yStep].
	^ form! !

!JPEGReadWriter methodsFor: 'public access' stamp: 'ar 3/4/2001 17:26'!
setStream: aStream
	"Feed it in from an existing source"
	stream _ JPEGReadStream on: aStream upToEnd.! !


!JPEGReadWriter methodsFor: 'testing' stamp: 'ar 3/4/2001 00:50'!
understandsImageFormat
	"Answer true if the image stream format is understood by this decoder."
	self next = 16rFF ifFalse: [^ false].
	self next = 16rD8 ifFalse: [^ false].
	^ true
! !


!JPEGReadWriter methodsFor: 'private' stamp: 'ar 3/4/2001 17:34'!
on: aStream
	super on: aStream.
	stream _ JPEGReadStream on: stream upToEnd.! !

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

JPEGReadWriter class
	instanceVariableNames: ''!

!JPEGReadWriter 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"
	^#('jpg' 'jpeg')! !

!JPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 18:54'!
understandsImageFormat: aStream
	(JPEGReadWriter2 understandsImageFormat: aStream) ifTrue:[^false].
	aStream reset.
	aStream next = 16rFF ifFalse: [^ false].
	aStream next = 16rD8 ifFalse: [^ false].
	^true! !


!JPEGReadWriter class methodsFor: 'initialization' stamp: 'ar 3/3/2001 23:07'!
initialize
	"JPEGReadWriter initialize"
	"general constants"
	DCTSize _ 8.
	MaxSample _ (2 raisedToInteger: DCTSize) - 1.
	SampleOffset _ MaxSample // 2.
	FloatSampleOffset _ SampleOffset asFloat.
	DCTSize2 _ DCTSize squared.
	QuantizationTableSize _ 4.
	HuffmanTableSize _ 4.

	"floating-point Inverse Discrete Cosine Transform (IDCT) constants"
	ConstBits _ 13.
	Pass1Bits _ 2.
	DCTK1 _ 2 sqrt.
	DCTK2 _ 1.847759065.
	DCTK3 _ 1.082392200.
	DCTK4 _ -2.613125930.
	Pass1Div _ 1 bitShift: ConstBits - Pass1Bits.
	Pass2Div _ 1 bitShift: ConstBits + Pass1Bits + 3.

	"fixed-point Inverse Discrete Cosine Transform (IDCT) constants"
	FIXn0n298631336 _ 2446.
	FIXn0n390180644 _ 3196.
	FIXn0n541196100 _ 4433.
	FIXn0n765366865 _ 6270.
	FIXn0n899976223 _ 7373.
	FIXn1n175875602 _ 9633.
	FIXn1n501321110 _ 12299.
	FIXn1n847759065 _ 15137.
	FIXn1n961570560 _ 16069.
	FIXn2n053119869 _ 16819.
	FIXn2n562915447 _ 20995.
	FIXn3n072711026 _ 25172.

	"fixed-point color conversion constants"
	FIXn0n34414 _ 22554.
	FIXn0n71414 _ 46802.
	FIXn1n40200 _ 91881.
	FIXn1n77200 _  116130.

	"reordering table from JPEG zig-zag order"
	JPEGNaturalOrder _ #(
		1 2 9 17 10 3 4 11
		18 25 33 26 19 12 5 6
		13 20 27 34 41 49 42 35
		28 21 14 7 8 15 22 29
		36 43 50 57 58 51 44 37
		30 23 16 24 31 38 45 52
		59 60 53 46 39 32 40 47
		54 61 62 55 48 56 63 64).

	"scale factors for the values in the Quantization Tables"
	QTableScaleFactor _ (0 to: DCTSize-1) collect:
		[:k | k = 0
			ifTrue: [1.0]
			ifFalse: [(k * Float pi / 16) cos * 2 sqrt]].

	"dithering masks"
	(DitherMasks _ Dictionary new)
		add: 0 -> 0;
		add: 1 -> 127;
		add: 2 -> 63;
		add: 4 -> 63;
		add: 8 -> 31;
		add: 16 -> 7;
		add: 32 -> 0.

	"dictionary of marker parsers"
	(JFIFMarkerParser _ Dictionary new)
		add: (16r01 -> #parseNOP);
		add: (16rC0 -> #parseStartOfFile);
		add: (16rC4 -> #parseHuffmanTable);
		addAll: ((16rD0 to: 16rD7) collect: [:m | Association key: m value: #parseNOP]);
		add: (16rD8 -> #parseStartOfInput);
		add: (16rD9 -> #parseEndOfInput);
		add: (16rDA -> #parseStartOfScan);
		add: (16rDB -> #parseQuantizationTable);
		add: (16rDD -> #parseDecoderRestartInterval);
		add: (16rE0 -> #parseAPPn);
		add: (16rE1 -> #parseAPPn)! !
ImageReadWriter subclass: #JPEGReadWriter2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!
!JPEGReadWriter2 commentStamp: '<historical>' prior: 0!
I provide fast JPEG compression and decompression. I require the VM pluginJPEGReadWriter2Plugin, which is typically stored in same directory as the Squeak virtual machine.

JPEGReadWriter2Plugin is based on LIBJPEG library. This sentence applies to the plugin:
   "This software is based in part on the work of the Independent JPEG Group".

The LIBJPEG license allows it to be used free for any purpose so long as its origin and copyright are acknowledged. You can read more about LIBJPEG and get the complete source code at www.ijg.org.
!


!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:34'!
primImageHeight: aJPEGCompressStruct

	<primitive: 'primImageHeight' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed
! !

!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'!
primImageWidth: aJPEGCompressStruct

	<primitive: 'primImageWidth' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed
! !

!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'!
primJPEGCompressStructSize

	<primitive: 'primJPEGCompressStructSize' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed
! !

!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'!
primJPEGDecompressStructSize

	<primitive: 'primJPEGDecompressStructSize' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed
! !

!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'!
primJPEGErrorMgr2StructSize

	<primitive: 'primJPEGErrorMgr2StructSize' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed
! !

!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'ar 11/27/2001 00:39'!
primJPEGPluginIsPresent
	<primitive: 'primJPEGPluginIsPresent' module: 'JPEGReadWriter2Plugin'>
	^false! !

!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'!
primJPEGReadHeader: aJPEGDecompressStruct fromByteArray: source errorMgr: aJPEGErrorMgr2Struct

	<primitive: 'primJPEGReadHeaderfromByteArrayerrorMgr' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed
! !

!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jmv 12/7/2001 13:45'!
primJPEGReadImage: aJPEGDecompressStruct fromByteArray: source onForm: form doDithering: ditherFlag errorMgr: aJPEGErrorMgr2Struct

	<primitive: 'primJPEGReadImagefromByteArrayonFormdoDitheringerrorMgr' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed
! !

!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'!
primJPEGWriteImage: aJPEGCompressStruct onByteArray: destination form: form quality: quality progressiveJPEG: progressiveFlag errorMgr: aJPEGErrorMgr2Struct

	<primitive: 'primJPEGWriteImageonByteArrayformqualityprogressiveJPEGerrorMgr' module: 'JPEGReadWriter2Plugin'>
	self primitiveFailed
! !


!JPEGReadWriter2 methodsFor: 'public access' stamp: 'JMM 1/11/2005 14:56'!
compress: aForm quality: quality
	"Encode the given Form and answer the compressed ByteArray. Quality goes from 0 (low) to 100 (high), where -1 means default."

	| sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount |
	aForm unhibernate.
	"odd width images of depth 16 give problems; avoid them."
	sourceForm _ (aForm depth = 32) | (aForm width even & (aForm depth = 16))
		ifTrue: [aForm]
		ifFalse: [aForm asFormOfDepth: 32].
	jpegCompressStruct _ ByteArray new: self primJPEGCompressStructSize.
	jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize.
	buffer _ ByteArray new: sourceForm width * sourceForm height + 1024.
	byteCount _ self primJPEGWriteImage: jpegCompressStruct 
		onByteArray: buffer
		form: sourceForm
		quality: quality
		progressiveJPEG: false
		errorMgr: jpegErrorMgr2Struct.
	byteCount = 0 ifTrue: [self error: 'buffer too small for compressed data'].
	^ buffer copyFrom: 1 to: byteCount
! !

!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/20/2001 10:01'!
imageExtent: aByteArray 
	"Answer the extent of the compressed image encoded in the given ByteArray."

	| jpegDecompressStruct jpegErrorMgr2Struct w h |
	jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize.
	jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize.
	self
		primJPEGReadHeader: jpegDecompressStruct 
		fromByteArray: aByteArray
		errorMgr: jpegErrorMgr2Struct.
	w _ self primImageWidth: jpegDecompressStruct.
	h _ self primImageHeight: jpegDecompressStruct.
	^ w @ h
! !

!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/20/2001 10:23'!
nextImage
	"Decode and answer a Form from my stream."

	^ self nextImageSuggestedDepth: Display depth
! !

!JPEGReadWriter2 methodsFor: 'public access' stamp: 'sd 1/30/2004 15:19'!
nextImageSuggestedDepth: depth
	"Decode and answer a Form of the given depth from my stream. Close the stream if it is a file stream. Possible depths are 16-bit and 32-bit."

	| bytes width height form jpegDecompressStruct jpegErrorMgr2Struct depthToUse |
	bytes _ stream upToEnd.
	stream close.
	jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize.
	jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize.
	self 
		primJPEGReadHeader: jpegDecompressStruct 
		fromByteArray: bytes
		errorMgr: jpegErrorMgr2Struct.
	width _ self primImageWidth: jpegDecompressStruct.
	height _ self primImageHeight: jpegDecompressStruct.
	"Odd width images of depth 16 gave problems. Avoid them (or check carefully!!)"
	depthToUse _ ((depth = 32) | width odd) ifTrue: [32] ifFalse: [16].
	form _ Form extent: width@height depth: depthToUse.
	(width = 0 or: [height = 0]) ifTrue: [^ form].
	self
		primJPEGReadImage: jpegDecompressStruct
		fromByteArray: bytes
		onForm: form
		doDithering: true
		errorMgr: jpegErrorMgr2Struct.
	^ form
! !

!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/20/2001 10:21'!
nextPutImage: aForm
	"Encode the given Form on my stream with default quality."

	^ self nextPutImage: aForm quality: -1 progressiveJPEG: false
! !

!JPEGReadWriter2 methodsFor: 'public access' stamp: 'JMM 1/11/2005 14:45'!
nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag
	"Encode the given Form on my stream with the given settings. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG."

	| sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount |
	aForm unhibernate.
	"odd width images of depth 16 give problems; avoid them."
	sourceForm _ (aForm depth = 32) | (aForm width even & (aForm depth = 16))
		ifTrue: [aForm]
		ifFalse: [aForm asFormOfDepth: 32].
	jpegCompressStruct _ ByteArray new: self primJPEGCompressStructSize.
	jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize.
	buffer _ ByteArray new: sourceForm width * sourceForm height + 1024.
	byteCount _ self primJPEGWriteImage: jpegCompressStruct 
		onByteArray: buffer
		form: sourceForm
		quality: quality
		progressiveJPEG: progressiveFlag
		errorMgr: jpegErrorMgr2Struct.
	byteCount = 0 ifTrue: [self error: 'buffer too small for compressed data'].
	stream next: byteCount putAll: buffer startingAt: 1.
	self close.
! !

!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jmv 12/7/2001 13:49'!
uncompress: aByteArray into: aForm
	"Uncompress an image from the given ByteArray into the given Form.
	Fails if the given Form has the wrong dimensions or depth.
	If aForm has depth 16, do ordered dithering."

	| jpegDecompressStruct jpegErrorMgr2Struct w h |
	aForm unhibernate.
	jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize.
	jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize.
	self 
		primJPEGReadHeader: jpegDecompressStruct 
		fromByteArray: aByteArray
		errorMgr: jpegErrorMgr2Struct.
	w _ self primImageWidth: jpegDecompressStruct.
	h _ self primImageHeight: jpegDecompressStruct.
	((aForm width = w) & (aForm height = h)) ifFalse: [
		^ self error: 'form dimensions do not match'].

	"odd width images of depth 16 give problems; avoid them"
	w odd
		ifTrue: [
			aForm depth = 32 ifFalse: [^ self error: 'must use depth 32 with odd width']]
		ifFalse: [
			((aForm depth = 16) | (aForm depth = 32)) ifFalse: [^ self error: 'must use depth 16 or 32']].

	self primJPEGReadImage: jpegDecompressStruct
		fromByteArray: aByteArray
		onForm: aForm
		doDithering: true
		errorMgr: jpegErrorMgr2Struct.
! !

!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jmv 12/7/2001 13:48'!
uncompress: aByteArray into: aForm doDithering: ditherFlag
	"Uncompress an image from the given ByteArray into the given Form. 
	Fails if the given Form has the wrong dimensions or depth.
	If aForm has depth 16 and ditherFlag = true, do ordered dithering."

	| jpegDecompressStruct jpegErrorMgr2Struct w h |
	aForm unhibernate.
	jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize.
	jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize.
	self 
		primJPEGReadHeader: jpegDecompressStruct 
		fromByteArray: aByteArray
		errorMgr: jpegErrorMgr2Struct.
	w _ self primImageWidth: jpegDecompressStruct.
	h _ self primImageHeight: jpegDecompressStruct.
	((aForm width = w) & (aForm height = h)) ifFalse: [
		^ self error: 'form dimensions do not match'].

	"odd width images of depth 16 give problems; avoid them"
	w odd
		ifTrue: [
			aForm depth = 32 ifFalse: [^ self error: 'must use depth 32 with odd width']]
		ifFalse: [
			((aForm depth = 16) | (aForm depth = 32)) ifFalse: [^ self error: 'must use depth 16 or 32']].

	self primJPEGReadImage: jpegDecompressStruct
		fromByteArray: aByteArray
		onForm: aForm
		doDithering: ditherFlag
		errorMgr: jpegErrorMgr2Struct.
! !


!JPEGReadWriter2 methodsFor: 'testing' stamp: 'ar 11/27/2001 00:40'!
isPluginPresent
	^self primJPEGPluginIsPresent! !

!JPEGReadWriter2 methodsFor: 'testing' stamp: 'ar 11/27/2001 00:39'!
understandsImageFormat
	"Answer true if the image stream format is understood by this decoder."
	self isPluginPresent ifFalse:[^false]. "cannot read it otherwise"
	self next = 16rFF ifFalse: [^ false].
	self next = 16rD8 ifFalse: [^ false].
	^ true
! !

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

JPEGReadWriter2 class
	instanceVariableNames: ''!

!JPEGReadWriter2 class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 18:54'!
primJPEGPluginIsPresent
	<primitive: 'primJPEGPluginIsPresent' module: 'JPEGReadWriter2Plugin'>
	^false! !

!JPEGReadWriter2 class methodsFor: 'image reading/writing' stamp: 'jm 12/22/2001 11:55'!
putForm: aForm quality: quality progressiveJPEG: progressiveFlag onFileNamed: fileName
	"Store the given Form as a JPEG file of the given name, overwriting any existing file of that name. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG."

	| writer |
	FileDirectory deleteFilePath: fileName.
	writer _ self on: (FileStream newFileNamed: fileName) binary.
	Cursor write showWhile: [
		writer nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag].
	writer close.
! !

!JPEGReadWriter2 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"
	^#('jpg' 'jpeg')! !
LanguageEnvironment subclass: #JapaneseEnvironment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Languages'!
!JapaneseEnvironment commentStamp: '<historical>' prior: 0!
This class provides the Japanese support.  Since it has been used most other than default 'latin-1' languages, this tends to be a good place to look at when you want to know what a typical subclass of LanguageEnvironment should do.
!



!JapaneseEnvironment methodsFor: 'utilities' stamp: 'KR 1/30/2006 22:28'!
setupSqueaklandSpecifics
	| server |
	ChangeSet current name: 'Unnamed' translated , '1'.
	ServerDirectory resetServers.
	server := SuperSwikiServer new type: #http;
				 server: 'squeakland.jp';
				 directory: '/super/SuperSwikiProj';
				 acceptsUploads: (Preferences eToyFriendly not);
				 encodingName: 'shift_jis'.
	ServerDirectory servers at: 'Squeakland.JP' put: server.
	Smalltalk garbageCollect! !

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

JapaneseEnvironment class
	instanceVariableNames: ''!

!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 8/3/2004 21:25'!
flapTabTextFor: aString in: aFlapTab

	| string |
	string _ super flapTabTextFor: aString.
	string isEmptyOrNil ifTrue: [^ self].
	string _ aFlapTab orientation == #vertical
				ifTrue: [string copyReplaceAll: 'ー' with: '｜']
				ifFalse: [string copyReplaceAll: '｜' with: 'ー'].

	^ string.
!]lang[(211 1 9 1 41 1 9 1 16)0,5,0,5,0,5,0,5,0! !

!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'ar 4/9/2005 22:31'!
fromJISX0208String: aString

	^ aString collect: [:each | Character leadingChar: JapaneseEnvironment leadingChar code: (each asUnicode)].
! !

!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/17/2004 21:54'!
scanSelector

	^ #scanJapaneseCharactersFrom:to:in:rightX:stopConditions:kern:
! !

!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/16/2004 14:49'!
traditionalCharsetClass

	^ JISX0208.
! !


!JapaneseEnvironment class methodsFor: 'public query' stamp: 'nk 7/30/2004 21:43'!
defaultEncodingName
	| platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8'].
	(#('Win32' 'ZaurusOS') includes: platformName) ifTrue: [^'shift-jis'].
	platformName = 'Mac OS' 
		ifTrue: 
			[^('10*' match: SmalltalkImage current osVersion) 
				ifTrue: ['utf-8']
				ifFalse: ['shift-jis']].
	^'unix' = platformName ifTrue: ['euc-jp'] ifFalse: ['mac-roman']! !


!JapaneseEnvironment class methodsFor: 'rendering support' stamp: 'yo 3/18/2005 08:00'!
isBreakableAt: index in: text

	| prev |
	index = 1 ifTrue: [^ false].
	prev _ text at: index - 1.
	prev leadingChar ~= JapaneseEnvironment leadingChar ifTrue: [^ true].
	^ (('、。，．・：；？！゛゜´｀¨＾―‐／\〜‖｜…‥’”）〕］｝〉》」』】°′″℃' includes: (text at: index)) or: ['‘“（〔［｛〈《「『【°′″℃＠§' includes: prev]) not.
!]lang[(176 11 1 1 1 4 1 16 1 3 36 11 1 4 25)0,5,0,5,0,5,0,5,0,5,0,5,0,5,0! !


!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'nk 7/30/2004 21:40'!
clipboardInterpreterClass
	| platformName osVersion |
	platformName := SmalltalkImage current  platformName.
	osVersion := SmalltalkImage current  getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) 
		ifTrue: [^NoConversionClipboardInterpreter].
	platformName = 'Win32' ifTrue: [^WinShiftJISClipboardInterpreter].
	platformName = 'Mac OS' ifTrue: [^MacShiftJISClipboardInterpreter].
	^platformName = 'unix' 
		ifTrue: 
			[(ShiftJISTextConverter encodingNames includes: X11Encoding getEncoding) 
				ifTrue: [MacShiftJISClipboardInterpreter]
				ifFalse: [UnixJPClipboardInterpreter]]
		ifFalse: [ NoConversionClipboardInterpreter ]! !

!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/15/2004 18:18'!
fileNameConverterClass

	^ self systemConverterClass.
! !

!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'tetha 7/13/2005 00:44'!
inputInterpreterClass
	| platformName osVersion encoding |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32'
			and: [osVersion = 'CE'])
		ifTrue: [^ MacRomanInputInterpreter].
	platformName = 'Win32'
		ifTrue: [^ WinShiftJISInputInterpreter].
	platformName = 'Mac OS'
		ifTrue: [^ (('10*' match: SmalltalkImage current osVersion)
					and: [(SmalltalkImage current getSystemAttribute: 3) isNil])
				ifTrue: [MacUnicodeInputInterpreter]
				ifFalse: [MacShiftJISInputInterpreter]].
	platformName = 'unix'
		ifTrue: [encoding := X11Encoding encoding.
			(EUCJPTextConverter encodingNames includes: encoding)
				ifTrue: [^ UnixEUCJPInputInterpreter].
			(UTF8TextConverter encodingNames includes: encoding)
				ifTrue: [^ UnixUTF8JPInputInterpreter].
			(ShiftJISTextConverter encodingNames includes: encoding)
				ifTrue: [^ MacShiftJISInputInterpreter]].
	^ MacRomanInputInterpreter! !

!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 21:55'!
leadingChar

	^ 5.
! !

!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/21/2004 19:09'!
supportedLanguages
	"Return the languages that this class supports. 
	Any translations for those languages will use this class as their environment."
	
	^#('ja' 'ja-etoys' )! !

!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'T2 2/3/2005 13:07'!
systemConverterClass
	| platformName osVersion encoding |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) 
		ifTrue: [^UTF8TextConverter].
	(#('Win32' 'ZaurusOS') includes: platformName) 
		ifTrue: [^ShiftJISTextConverter].
	platformName = 'Mac OS' 
		ifTrue: 
			[^('10*' match: SmalltalkImage current osVersion) 
				ifTrue: [UTF8TextConverter]
				ifFalse: [ShiftJISTextConverter]].
	platformName = 'unix' 
		ifTrue: 
			[encoding := X11Encoding encoding.
			encoding ifNil: [^EUCJPTextConverter].
			(encoding = 'utf-8') 
				ifTrue: [^UTF8TextConverter].				
			(encoding = 'shiftjis' | encoding = 'sjis') 
				ifTrue: [^ShiftJISTextConverter].				
			^EUCJPTextConverter].
	^MacRomanTextConverter! !
SketchMorph subclass: #JoystickMorph
	instanceVariableNames: 'handleMorph xScale yScale radiusScale lastAngle autoCenter realJoystickIndex lastRealJoystickValue button1 button2'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!JoystickMorph commentStamp: 'kfr 10/27/2003 16:25' prior: 0!
A widget that simulates a joystick. Mosly used in etoy scripting.!


!JoystickMorph methodsFor: 'accessing'!
amount

	^ (handleMorph center - self center) r * radiusScale! !

!JoystickMorph methodsFor: 'accessing'!
angle

	self center = handleMorph center ifTrue: [^ lastAngle].
	^ 360.0 - (handleMorph center - self center) theta radiansToDegrees! !

!JoystickMorph methodsFor: 'accessing' stamp: 'mir 9/4/2005 16:46'!
button1
	^button1 == true! !

!JoystickMorph methodsFor: 'accessing' stamp: 'mir 9/4/2005 16:46'!
button2
	^button2 == true! !

!JoystickMorph methodsFor: 'accessing'!
leftRight

	^ (handleMorph center x - self center x) * xScale
! !

!JoystickMorph methodsFor: 'accessing' stamp: 'jm 1/19/98 20:48'!
upDown

	^ (self center y - handleMorph center y) * yScale
! !


!JoystickMorph methodsFor: 'event handling' stamp: 'sw 5/11/1998 13:51'!
handlesMouseDown: evt

	self inPartsBin ifTrue: [^ false].

	true ifTrue: [^ true].  "5/7/98 jhm temporary fix to allow use when rotated"

	(handleMorph fullContainsPoint: evt cursorPoint)
		ifTrue: [^ true]
		ifFalse: [^ super handlesMouseDown: evt].
! !

!JoystickMorph methodsFor: 'event handling'!
mouseMove: evt
	"Make handle track the cursor within my bounds."

	| m r center |
	m _ handleMorph.
	center _ m center.
	r _ m owner innerBounds insetBy:
		((center - m fullBounds origin) corner: (m fullBounds corner - center)).
	m position: (evt cursorPoint adhereTo: r) - (m extent // 2).
! !

!JoystickMorph methodsFor: 'event handling' stamp: 'jm 11/18/97 14:26'!
mouseUp: evt

	lastAngle _ self angle.
	autoCenter ifTrue: [self moveHandleToCenter].
! !


!JoystickMorph methodsFor: 'halos and balloon help' stamp: 'sw 8/11/2004 18:10'!
isLikelyRecipientForMouseOverHalos
	"The automatic mouseover halos interere with the proper functioning of the joystick's knob"

	^ false! !


!JoystickMorph methodsFor: 'initialization' stamp: 'bf 9/5/2005 11:23'!
initialize

	super initialize.
	xScale _ 0.25.
	yScale _ 0.25.
	radiusScale _ 1.0.
	lastAngle _ 0.0.
	autoCenter _ true.
	self form: ((Form extent: 55@55 depth: 8) fillColor: (Color r: 0.3 g: 0.2 b: 0.2)).
	handleMorph _ EllipseMorph new.
	handleMorph color: Color red; extent: 15@15.
	self addMorph: handleMorph.
	self moveHandleToCenter.
	button1 := false.
	button2 := false.
! !


!JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 20:00'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add custom items to the menu"

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'set X range' translated action: #setXRange.
	aCustomMenu add: 'set Y range' translated action: #setYRange.
	aCustomMenu addLine.
	aCustomMenu addUpdating: #autoCenterString target: self action: #toggleAutoCenter.
	aCustomMenu balloonTextForLastItem: 'When auto-center is on, every time you let go of the Joystick knob, it springs back to the neutral position at the center of the device' translated. 
	aCustomMenu addUpdating: #realJoystickString target: self action: #toggleRealJoystick.
	aCustomMenu balloonTextForLastItem: 'Governs whether this joystick should track the motions of a real, physical joystick attached to the computer.' translated. 
	aCustomMenu addUpdating: #joystickNumberString enablementSelector: #realJoystickInUse target: self selector: #chooseJoystickNumber argumentList: #().
	aCustomMenu balloonTextForLastItem: 'Choose which physical device is associated with the joystick.' translated! !

!JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 18:30'!
autoCenterString
	"Answer a string characterizing whether or not I have auto-center on"

	^ (autoCenter == true	ifTrue: ['<yes>'] ifFalse: ['<no>']), ('auto-center' translated)! !

!JoystickMorph methodsFor: 'menu' stamp: 'yo 2/24/2005 17:44'!
chooseJoystickNumber
	"Allow the user to select a joystick number"

	| result aNumber str |
	str := self lastRealJoystickIndex asString.
	result := FillInTheBlank 
				request: ('Joystick device number (currently {1})' translated format: {str})
				initialAnswer: str.
	[aNumber := result asNumber] on: Error do: [:err | ^Beeper beep].
	(aNumber > 0 and: [aNumber <= 32]) 
		ifFalse: 
			["???"

			^Beeper beep].
	realJoystickIndex := aNumber.
	self setProperty: #lastRealJoystickIndex toValue: aNumber.
	self startStepping! !

!JoystickMorph methodsFor: 'menu' stamp: 'yo 2/11/2005 09:19'!
joystickNumberString
	"Answer a string characterizing the joystick number"

	^ 'set real joystick number (now {1})' translated format: {self lastRealJoystickIndex asString}.
! !

!JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 20:08'!
lastRealJoystickIndex
	"Answer the last remembered real joystick index.  Initialize it to 1 if need be"

	^ self valueOfProperty: #lastRealJoystickIndex ifAbsentPut: [1] ! !

!JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 19:57'!
realJoystickInUse
	"Answer whether a real joystick is in use"

	^ realJoystickIndex notNil! !

!JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 18:29'!
realJoystickString
	"Answer a string characterizing whether or not I am currenty tracking a real joystick"

	^ (realJoystickIndex ifNil: ['<no>'] ifNotNil: ['<yes>']), ('track real joystick' translated)! !

!JoystickMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:11'!
setXRange

	| range |
	range _ FillInTheBlank
		request:
'Type the maximum value for the X axis' translated
		initialAnswer: ((xScale * (self width - handleMorph width) / 2.0) roundTo: 0.01) printString.
	range isEmpty ifFalse: [
		xScale _ (2.0 * range asNumber asFloat) / (self width - handleMorph width)].
! !

!JoystickMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:11'!
setYRange

	| range |
	range _ FillInTheBlank
		request:
'Type the maximum value for the Y axis'  translated
		initialAnswer: ((yScale * (self width - handleMorph width) / 2.0) roundTo: 0.01) printString.
	range isEmpty ifFalse: [
		yScale _ (2.0 * range asNumber asFloat) / (self width - handleMorph width)].
! !

!JoystickMorph methodsFor: 'menu' stamp: 'jm 6/22/1998 17:24'!
stopTrackingJoystick

	realJoystickIndex _ nil.
	self stopStepping.
! !

!JoystickMorph methodsFor: 'menu' stamp: 'jm 11/18/97 14:33'!
toggleAutoCenter

	autoCenter _ autoCenter not.
	autoCenter ifTrue: [self moveHandleToCenter].
! !

!JoystickMorph methodsFor: 'menu' stamp: 'sw 8/11/2004 18:15'!
toggleRealJoystick
	"Toggle whether or not one is using a real joystick"

	realJoystickIndex
		ifNil:
			[realJoystickIndex _ self valueOfProperty: #lastRealJoystickIndex ifAbsentPut: [1].
			self startStepping]
		ifNotNil:
			[self stopTrackingJoystick]! !

!JoystickMorph methodsFor: 'menu' stamp: 'jm 6/22/1998 17:59'!
trackRealJoystick

	| s |
	s _ FillInTheBlank
		request: 'Number of joystick to track?'
		initialAnswer: '1'.
	s isEmpty ifTrue: [^ self].
	realJoystickIndex _ Number readFromString: s.
	self startStepping.
! !


!JoystickMorph methodsFor: 'other'!
moveHandleToCenter

	handleMorph position: self center - (handleMorph extent // 2).
! !


!JoystickMorph methodsFor: 'parts bin' stamp: 'sw 8/12/2001 17:26'!
initializeToStandAlone
	"Circumvent SketchMorph's implementation here"

	self initialize! !


!JoystickMorph methodsFor: 'stepping and presenter' stamp: 'bf 9/5/2005 11:19'!
step
	"Track the real joystick whose index is realJoystickIndex."
	"Details:
	  a. if realJoystickIndex is nil we're not tracking a joystick
	  b. [-joyMax..joyMax] is nominal range of joystick in both X and Y
	  c. [-threshold..threshold] is considered 0 to compensate for poor joystick centering"

	| threshold joyMax joyPt joyBtn m mCenter r scaledPt  |
	super step.  "Run ticking user-written scripts if any"
	realJoystickIndex ifNil: [^ self].
	threshold _ 30.
	joyMax _ 350.
	joyPt _ Sensor joystickXY: realJoystickIndex.
	joyBtn _ Sensor joystickButtons: realJoystickIndex.

	button1 := (joyBtn bitAnd: 1) > 0.
	button2 := (joyBtn bitAnd: 2) > 0.
	
	joyPt x abs < threshold ifTrue: [joyPt _ 0@joyPt y].
	joyPt y abs < threshold ifTrue: [joyPt _ joyPt x@0].
	lastRealJoystickValue = joyPt ifTrue: [^ self].
	lastRealJoystickValue _ joyPt.
	m _ handleMorph.
	mCenter _ m center.
	r _ m owner innerBounds insetBy:
		((mCenter - m fullBounds origin) corner: (m fullBounds corner - mCenter)).
	scaledPt _ r center + ((r extent * joyPt) / (joyMax * 2)) truncated.
	m position: (scaledPt adhereTo: r) - (m extent // 2).
! !

!JoystickMorph methodsFor: 'stepping and presenter' stamp: 'laza 6/8/2003 11:53'!
stepTime
	"Provide for as-fast-as-possible stepping in the case of a real joystick"

	^ realJoystickIndex
		ifNotNil:
			[0]  "fast as we can to track actual joystick"
		ifNil:
			[super stepTime]! !

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

JoystickMorph class
	instanceVariableNames: ''!

!JoystickMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:10'!
initialize

	self registerInFlapsRegistry.! !

!JoystickMorph class methodsFor: 'class initialization' stamp: 'asm 4/14/2003 20:32'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(JoystickMorph		authoringPrototype		'Joystick'	'A joystick-like control') 
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(JoystickMorph		authoringPrototype		'Joystick'	'A joystick-like control') 
						forFlapNamed: 'Scripting'.
						cl registerQuad: #(JoystickMorph		authoringPrototype		'Joystick'	'A joystick-like control') 
						forFlapNamed: 'Supplies']! !

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

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


!JoystickMorph class methodsFor: 'new-morph participation' stamp: 'sw 4/26/1999 16:02'!
includeInNewMorphMenu
	^ true! !


!JoystickMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:40'!
descriptionForPartsBin
	^ self partName: 	'Joystick'
		categories:		#('Useful')
		documentation:	'A joystick-like control'! !


!JoystickMorph class methodsFor: 'scripting' stamp: 'bf 9/5/2005 11:02'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((joystick (
(slot amount 'The amount of displacement' Number readOnly Player getAmount unused unused)
(slot angle 'The angular displacement' Number readOnly Player getAngle  unused  unused)
(slot leftRight  'The horizontal displacement' Number  readOnly Player getLeftRight  unused  unused)
(slot upDown 'The vertical displacement' Number  readOnly Player getUpDown unused unused)
(slot button1 'Button 1 pressed' Boolean  readOnly Player getButton1 unused unused)
(slot button2 'Button 2 pressed' Boolean  readOnly Player getButton2 unused unused)
)))


! !

!JoystickMorph class methodsFor: 'scripting' stamp: 'sw 11/5/97 12:04'!
authoringPrototype
	^ self new markAsPartsDonor! !

EncodedCharSet subclass: #KSX1001
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Encodings'!
!KSX1001 commentStamp: 'yo 10/19/2004 19:53' prior: 0!
This class represents the domestic character encoding called KS X 1001 used for Korean.!


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

KSX1001 class
	instanceVariableNames: ''!

!KSX1001 class methodsFor: 'character classification' stamp: 'yo 8/6/2003 05:30'!
isLetter: char

	| value leading |

	leading _ char leadingChar.
	value _ char charCode.

	leading = 0 ifTrue: [^ super isLetter: char].

	value _ value // 94 + 1.
	^ 1 <= value and: [value < 84].
! !


!KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:47'!
compoundTextSequence

	^ CompoundTextSequence.
! !

!KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:49'!
initialize
"
	KSX1001 initialize
"

	CompoundTextSequence _ String
				streamContents: 
					[:stream | 
					stream nextPut: Character escape.
					stream nextPut: $$.
					stream nextPut: $(.
					stream nextPut: $C]! !

!KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:49'!
leadingChar

	^ 3.
! !

!KSX1001 class methodsFor: 'class methods' stamp: 'yo 11/24/2002 17:03'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	| c1 c2 |
	state charSize: 2.
	(state g0Leading ~= self leadingChar) ifTrue: [
		state g0Leading: self leadingChar.
		state g0Size: 2.
		aStream basicNextPutAll: CompoundTextSequence.
	].
	c1 _ ascii // 94 + 16r21.
	c2 _ ascii \\ 94 + 16r21.
	^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2).
! !

!KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'!
ucsTable

	^ UCSTable ksx1001Table.
! !
TileMorph subclass: #KedamaAngleToTile
	instanceVariableNames: 'turtleTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaAngleToTile commentStamp: 'yo 6/18/2004 18:29' prior: 0!
I provide the special tile of 'angle to'.
!


!KedamaAngleToTile methodsFor: 'initialization support' stamp: 'yo 1/30/2005 10:57'!
addTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'thetaTo' translated font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Player.
	m1 addMorph: m2.
	desiredW _ m1 width.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	self addMorphBack: m1.
	self addMorphFront: label.
	turtleTile _ m1.
! !

!KedamaAngleToTile methodsFor: 'initialization support' stamp: 'yo 6/15/2004 18:43'!
setTurtleDefaultTo: aPlayer

	turtleTile submorphs first setToReferTo: aPlayer.
! !


!KedamaAngleToTile methodsFor: 'initialization' stamp: 'yo 6/17/2004 10:03'!
initialize

	super initialize.
	type _ #Player.
	operatorOrExpression _ #getAngleTo:.
	self addTile.
! !


!KedamaAngleToTile methodsFor: 'tile protocol' stamp: 'yo 1/30/2005 11:19'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: 'thetaTo' translated font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: turtleTile.
! !

!KedamaAngleToTile methodsFor: 'tile protocol' stamp: 'yo 10/9/2004 10:01'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"thetaTo"
	aStream nextPutAll: parts first.
	aStream space.
	turtleTile storeCodeOn: aStream indent: tabCount.
! !
Object subclass: #KedamaAttributeDictionary
	instanceVariableNames: 'dictionaries'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaAttributeDictionary methodsFor: 'all' stamp: 'yo 8/28/2004 00:45'!
getAttribute: aSymbol of: anObject

	| attributes |
	attributes _ dictionaries at: anObject ifAbsent: [^ nil].
	^ attributes at: aSymbol ifAbsent: [nil].
! !

!KedamaAttributeDictionary methodsFor: 'all' stamp: 'yo 8/28/2004 00:46'!
initialize

	dictionaries _ IdentityDictionary new.
! !

!KedamaAttributeDictionary methodsFor: 'all' stamp: 'yo 8/28/2004 00:46'!
setAttribute: aSymbol of: anObject to: value

	| attributes |
	attributes _ dictionaries at: anObject ifAbsentPut: [IdentityDictionary new].
	attributes at: aSymbol put: value.

! !
TileMorph subclass: #KedamaBounceOnColorTile
	instanceVariableNames: 'playerTile colorTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaBounceOnColorTile methodsFor: 'initalization support' stamp: 'yo 1/30/2005 10:56'!
addPlayerTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'bounce on' translated font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Player.
	m1 addMorph: m2.
	desiredW _ m1 width + 6.

	m2 _ ColorTileMorph new.

	"m3 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0.0 b: 0.0)."
	desiredW _ desiredW + m2 width.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	"m2 addMorph: m3."
	m2 position: ((bounds center x - (m2 width // 2)) + 3)@ (bounds top + 1).
	self addMorphBack: m2.
	self addMorphFront: m1.
	self addMorphFront: label.
	playerTile _ m1.
	colorTile _ m2.
! !

!KedamaBounceOnColorTile methodsFor: 'initalization support' stamp: 'yo 9/28/2004 18:23'!
updateLiteralLabel
! !


!KedamaBounceOnColorTile methodsFor: 'initialization' stamp: 'yo 9/28/2004 18:43'!
initialize

	super initialize.
	type _ #Player.
	operatorOrExpression _ #bounceOn:color:.
	self addPlayerTile.
! !


!KedamaBounceOnColorTile methodsFor: 'tile protocol' stamp: 'yo 1/30/2005 10:56'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: 'bounce on' translated font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: playerTile.
! !

!KedamaBounceOnColorTile methodsFor: 'tile protocol' stamp: 'yo 10/8/2004 11:42'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	aStream nextPutAll: 'bounceOn:'.
	aStream space.
	playerTile storeCodeOn: aStream indent: tabCount.
	aStream space.
	aStream nextPutAll: 'color:'.
	aStream space.
	colorTile kedamaStoreCodeAsPixelValueOn: aStream indent: tabCount.

	"aStream nextPutAll: submorphs third color printString."
! !
TileMorph subclass: #KedamaBounceOnTile
	instanceVariableNames: 'playerTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaBounceOnTile methodsFor: 'initialization support' stamp: 'yo 1/30/2005 10:58'!
addPlayerTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'bounce on' translated font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Player.
	m1 addMorph: m2.
	desiredW _ m1 width + 6.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	self addMorphBack: m1.
	self addMorphFront: label.
	playerTile _ m1.
! !


!KedamaBounceOnTile methodsFor: 'initialization' stamp: 'yo 9/27/2004 14:53'!
initialize

	super initialize.
	type _ #Player.
	operatorOrExpression _ #bounceOn:.
	self addPlayerTile.
! !


!KedamaBounceOnTile methodsFor: 'tile protocol' stamp: 'yo 1/30/2005 10:56'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: 'bounce on' translated font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: playerTile.
! !

!KedamaBounceOnTile methodsFor: 'tile protocol' stamp: 'yo 10/9/2004 10:02'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"bounceOn:"
	aStream nextPutAll: parts first.
	aStream space.
	playerTile storeCodeOn: aStream indent: tabCount.
! !

!KedamaBounceOnTile methodsFor: 'tile protocol' stamp: 'yo 9/27/2004 14:54'!
updateLiteralLabel
! !
CategoryViewer subclass: #KedamaCategoryViewer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaCategoryViewer methodsFor: 'support' stamp: 'yo 4/3/2005 23:14'!
booleanPhraseFromPhrase: phrase

	| outerPhrase |
	outerPhrase _ super booleanPhraseFromPhrase: phrase.
	outerPhrase replacePlayerInReadoutWith: scriptedPlayer.
	^ outerPhrase.
! !

!KedamaCategoryViewer methodsFor: 'support' stamp: 'yo 4/4/2005 14:30'!
replaceTargetWith: player

	self submorphs allButFirst do: [:m |
		(m isMemberOf: ViewerLine) ifFalse: [self halt].
		(#(#systemScript #userScript) includes: m entryType) ifTrue: [
			m replacePlayerWith: player.
		].
		(#(#systemSlot #userSlot) includes: m entryType) ifTrue: [
			m replacePlayerInReadoutWith: player.
		].
	].
! !


!KedamaCategoryViewer methodsFor: 'get/set slots' stamp: 'yo 4/4/2005 08:41'!
getterTilesFor: getterSelector type: aType

	| phrase |
	phrase _ super getterTilesFor: getterSelector type: aType.
	phrase replacePlayerInReadoutWith: scriptedPlayer.
	^ phrase.
! !

!KedamaCategoryViewer methodsFor: 'get/set slots' stamp: 'yo 4/3/2005 23:10'!
makeSetter: selectorAndTypePair event: evt from: aMorph 
	"Classic tiles: make a Phrase that comprises a setter of a slot, and hand it to the user."

	| argType m argTile selfTile argValue actualGetter |
	selectorAndTypePair first = #getPatchValueIn: ifTrue: [^ self makeSetterForGetPatchValue: selectorAndTypePair event: evt from: aMorph].
	selectorAndTypePair first = #getRedComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #red event: evt from: aMorph].
	selectorAndTypePair first = #getBlueComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #blue event: evt from: aMorph].
	selectorAndTypePair first = #getGreenComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #green event: evt from: aMorph].
	
	argType := selectorAndTypePair second.
	actualGetter := selectorAndTypePair first asSymbol.
	m := PhraseTileMorph new 
				setAssignmentRoot: (Utilities inherentSelectorForGetter: actualGetter)
				type: #command
				rcvrType: #Player
				argType: argType
				vocabulary: self currentVocabulary.
	argValue := self scriptedPlayer 
				perform: selectorAndTypePair first asSymbol.
	(argValue isKindOf: Player) 
		ifTrue: [argTile := argValue tileReferringToSelf]
		ifFalse: 
			[argTile := ScriptingSystem tileForArgType: argType.
			(argType == #Number and: [argValue isNumber]) 
				ifTrue: 
					[(scriptedPlayer decimalPlacesForGetter: actualGetter) 
						ifNotNilDo: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]].
			argTile
				setLiteral: argValue;
				updateLiteralLabel].
	argTile position: m lastSubmorph position.
	m lastSubmorph addMorph: argTile.
	selfTile := self tileForSelf bePossessive.
	selfTile position: m firstSubmorph position.
	m firstSubmorph addMorph: selfTile.
	m enforceTileColorPolicy.
	m replacePlayerInReadoutWith: scriptedPlayer.
	m openInHand! !
TileMorph subclass: #KedamaDistanceToTile
	instanceVariableNames: 'turtleTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaDistanceToTile commentStamp: 'yo 6/18/2004 18:30' prior: 0!
I provide the special tile of 'distance to'.
!


!KedamaDistanceToTile methodsFor: 'initalization support' stamp: 'yo 1/30/2005 10:59'!
addTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'distanceTo' translated font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Player.
	m1 addMorph: m2.
	desiredW _ m1 width.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	self addMorphBack: m1.
	self addMorphFront: label.
	turtleTile _ m1.
! !

!KedamaDistanceToTile methodsFor: 'initalization support' stamp: 'yo 6/15/2004 18:43'!
setTurtleDefaultTo: aPlayer

	turtleTile submorphs first setToReferTo: aPlayer.
! !


!KedamaDistanceToTile methodsFor: 'initialization' stamp: 'yo 6/14/2004 15:58'!
initialize

	super initialize.
	type _ #Player.
	operatorOrExpression _ #getDistanceTo:.
	self addTile.
! !


!KedamaDistanceToTile methodsFor: 'tile protocol' stamp: 'yo 1/30/2005 10:59'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: 'distanceTo' translated font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: turtleTile.
! !

!KedamaDistanceToTile methodsFor: 'tile protocol' stamp: 'yo 10/9/2004 10:00'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"distanceTo:"
	aStream nextPutAll: parts first.
	aStream space.
	turtleTile storeCodeOn: aStream indent: tabCount.
! !
Player subclass: #KedamaExamplerPlayer
	instanceVariableNames: 'kedamaWorld turtles sequentialStub'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaExamplerPlayer methodsFor: 'player protocol' stamp: 'yo 9/27/2004 16:24'!
addInstanceVarNamed: aName withValue: aValue

	self basicAddInstanceVarNamed: aName withValue: aValue.
	"turtles _ kedamaWorld turtlesOf: self."
	turtles addInstanceVarVectorNamed: aName withValue: aValue.
! !

!KedamaExamplerPlayer methodsFor: 'player protocol' stamp: 'yo 3/25/2005 11:45'!
chooseSlotTypeFor: aGetter
	"Let the user designate a type for the slot associated with the given getter"

	| typeChoices typeChosen slotName |
	slotName _ Utilities inherentSelectorForGetter: aGetter.
	typeChoices _ Vocabulary typeChoices.

	typeChosen _ (SelectionMenu labelList: (typeChoices collect: [:t | t translated]) lines: #() selections: typeChoices) startUpWithCaption: 
		('Choose the TYPE
for ' translated, slotName, '
(currently ' translated, (self slotInfoAt: slotName) type translated, ')').
	typeChosen isEmptyOrNil ifTrue: [^ self].
	(self typeForSlot: slotName) capitalized = typeChosen ifTrue: [^ self].

	(self slotInfoAt: slotName) type: typeChosen.
	self class allInstancesDo:   "allSubInstancesDo:"
		[:anInst | anInst instVarNamed: slotName asString put: 
			(anInst valueOfType: typeChosen from: (anInst instVarNamed: slotName))].
	turtles setVectorSlotTypeFor: slotName typeChosen: typeChosen.
	sequentialStub ifNotNil: [sequentialStub setScalarSlotTypeFor: slotName typeChosen: typeChosen].
	self updateAllViewers.	"does siblings too"
! !

!KedamaExamplerPlayer methodsFor: 'player protocol' stamp: 'yo 9/27/2004 16:26'!
removeSlotNamed: aSlotName

	self basicRemoveSlotNamed: aSlotName.
	turtles removeVectorSlotNamed: aSlotName.
! !

!KedamaExamplerPlayer methodsFor: 'player protocol' stamp: 'yo 10/27/2004 20:19'!
renameSlot: oldSlotName newSlotName: newSlotName

	self basicRenameSlot: oldSlotName newSlotName: newSlotName.
	turtles renameVectorSlot: oldSlotName newSlotName: newSlotName.
	self recompileAccessorsOf: oldSlotName to: newSlotName inPlayer: self.
! !


!KedamaExamplerPlayer methodsFor: 'subclass players management' stamp: 'yo 9/26/2004 10:49'!
clonedSequentialStub

	^ sequentialStub clone.
! !

!KedamaExamplerPlayer methodsFor: 'subclass players management' stamp: 'yo 9/27/2004 16:34'!
createSequenceStub

	| class |
	class _ self class createSequencialStubSubclass.
	sequentialStub _ class new.
	sequentialStub kedamaWorld: kedamaWorld.
	sequentialStub examplerPlayer: self.
	sequentialStub turtles: turtles.
! !

!KedamaExamplerPlayer methodsFor: 'subclass players management' stamp: 'yo 9/28/2004 14:03'!
createTurtles

	turtles _ self class createTurtleSubclass new.
	turtles kedamaWorld: kedamaWorld.
	turtles exampler: self.
	^ turtles.
! !

!KedamaExamplerPlayer methodsFor: 'subclass players management' stamp: 'yo 9/27/2004 16:28'!
turtles

	^ turtles.
! !


!KedamaExamplerPlayer methodsFor: 'player commands' stamp: 'yo 10/12/2004 22:25'!
colorFromPatch: aPatch
! !

!KedamaExamplerPlayer methodsFor: 'player commands' stamp: 'yo 10/12/2004 22:24'!
colorToPatch: aPatch
! !

!KedamaExamplerPlayer methodsFor: 'player commands' stamp: 'yo 10/12/2004 15:24'!
getBlueComponentIn: aPatch

	^ 0.
! !

!KedamaExamplerPlayer methodsFor: 'player commands' stamp: 'yo 10/12/2004 15:24'!
getGreenComponentIn: aPatch

	^ 0.
! !

!KedamaExamplerPlayer methodsFor: 'player commands' stamp: 'yo 10/12/2004 15:24'!
getRedComponentIn: aPatch

	^ 0.
! !

!KedamaExamplerPlayer methodsFor: 'player commands' stamp: 'yo 10/9/2004 15:41'!
getTurtleAt: aPlayer

	^ turtles getTurtleAt: aPlayer.

! !

!KedamaExamplerPlayer methodsFor: 'player commands' stamp: 'yo 3/7/2005 08:36'!
getTurtleOf: aBreedPlayer

	^ self.

! !


!KedamaExamplerPlayer methodsFor: 'method management' stamp: 'yo 9/27/2004 16:25'!
compileInstVarAccessorsFor: varName

	self basicCompileInstVarAccessorsFor: varName.
	"turtles _ kedamaWorld turtlesOf: self."
	turtles compileVectorInstVarAccessorsFor: varName.
	sequentialStub compileScalarInstVarAccessorsFor: varName.
! !

!KedamaExamplerPlayer methodsFor: 'method management' stamp: 'yo 9/27/2004 16:26'!
recompileAccessorsOf: oldSlotName to: newSlotName inPlayer: aPlayer
	"Note that aPlayer has renamed a slot formerly known as oldSlotName to be newSlotName"

	self isPrototypeTurtlePlayer ifTrue: [
		sequentialStub ifNotNil: [sequentialStub noteRenameOf: oldSlotName to: newSlotName inPlayer: aPlayer].
		turtles noteRenameOf: oldSlotName to: newSlotName inPlayer: aPlayer.
	].
! !


!KedamaExamplerPlayer methodsFor: 'debug support' stamp: 'yo 10/22/2004 07:26'!
copyAllMethodsAgain

	| c result |
	c _ turtles class.
	result _ (ClassBuilder new)
		name: c name
		inEnvironment: c environment
		subclassOf: c superclass
		type: c typeOfClass
		instanceVariableNames: KedamaTurtleVectorPlayer instanceVariablesString
		classVariableNames: KedamaTurtleVectorPlayer classVariablesString
		poolDictionaries: KedamaTurtleVectorPlayer sharedPoolsString
		category: c category.
	turtles class copyAllCategoriesUnobtrusivelyFrom: KedamaTurtleVectorPlayer.
	sequentialStub ifNotNil: [sequentialStub class copyAllCategoriesUnobtrusivelyFrom: KedamaSequenceExecutionStub].
! !


!KedamaExamplerPlayer methodsFor: 'deleting' stamp: 'yo 10/8/2004 11:06'!
delete

	| anInstance |
	turtles delete.
	sequentialStub delete.

	self class removeFromSystem: false.

	anInstance _ UnscriptedPlayer new.
	self become: anInstance.
! !


!KedamaExamplerPlayer methodsFor: 'command execution' stamp: 'yo 9/27/2004 16:26'!
doCommand: aBlock

	| ret |
	ret _ self doExamplerCommand: aBlock.
	turtles ifNotNil: [aBlock value: turtles].

	^ ret.
! !

!KedamaExamplerPlayer methodsFor: 'command execution' stamp: 'yo 9/27/2004 16:26'!
doDieCommand: aBlock

	| ret origSize |
	ret _ self doExamplerCommand: aBlock.
	turtles initializeDeletingIndex.
	origSize _ turtles size.
	1 to: origSize do: [:i |
		i > origSize ifTrue: [^ ret].
		sequentialStub index: (turtles nextDeletingIndex).
		aBlock value: sequentialStub.
	].

	^ ret.

! !

!KedamaExamplerPlayer methodsFor: 'command execution' stamp: 'yo 9/30/2004 14:51'!
doExamplerCommand: aBlock

	 "^ aBlock value: self."! !

!KedamaExamplerPlayer methodsFor: 'command execution' stamp: 'yo 9/28/2004 10:21'!
doSequentialCommand: aBlock

	| ret |
	ret _ self doExamplerCommand: aBlock.
	self getGrouped ifFalse: [
		1 to: turtles size do: [:i |
			sequentialStub index: i.
			aBlock value: sequentialStub.
		].
	] ifTrue: [
		aBlock value: turtles.
	].
	turtles invalidateTurtleMap.
	^ ret.

! !


!KedamaExamplerPlayer methodsFor: 'slot-accessing' stamp: 'yo 4/5/2005 11:06'!
getColorOpaque

	^ self getColor.
! !

!KedamaExamplerPlayer methodsFor: 'slot-accessing' stamp: 'yo 9/29/2004 09:07'!
getNormal

	^ 0.0.
! !

!KedamaExamplerPlayer methodsFor: 'slot-accessing' stamp: 'yo 9/14/2004 20:36'!
getVisible

	^ self costume renderedMorph visible
! !

!KedamaExamplerPlayer methodsFor: 'slot-accessing' stamp: 'yo 9/14/2004 20:35'!
getWho

	^ 1.
! !

!KedamaExamplerPlayer methodsFor: 'slot-accessing' stamp: 'yo 9/24/2004 14:33'!
setHeading: degree

! !

!KedamaExamplerPlayer methodsFor: 'slot-accessing' stamp: 'yo 9/29/2004 09:07'!
setNormal: degree

! !

!KedamaExamplerPlayer methodsFor: 'slot-accessing' stamp: 'yo 7/24/2005 19:53'!
setTurtleCount: aNumber

	"self allOpenViewers do: [:v | v resetWhoIfNecessary]."
	super setCostumeSlot: #turtleCount: toValue: aNumber.
! !

!KedamaExamplerPlayer methodsFor: 'slot-accessing' stamp: 'yo 9/14/2004 16:08'!
turn: degree

! !


!KedamaExamplerPlayer methodsFor: 'testing' stamp: 'yo 8/12/2004 11:21'!
isPrototypeTurtlePlayer

	^ true.
! !


!KedamaExamplerPlayer methodsFor: 'accessing' stamp: 'yo 9/23/2004 17:15'!
kedamaWorld

	^ kedamaWorld.
! !

!KedamaExamplerPlayer methodsFor: 'accessing' stamp: 'yo 9/23/2004 17:15'!
kedamaWorld: k

	kedamaWorld _ k.
! !

!KedamaExamplerPlayer methodsFor: 'accessing' stamp: 'yo 4/3/2005 17:56'!
nearestIDFor: aNumber

	| whoArray last next smaller bigger |
	whoArray _ turtles arrays first.
	whoArray isEmpty ifTrue: [^ nil].
	aNumber < whoArray first ifTrue: [^ whoArray first].

	last _ whoArray at: 1.
	2 to: whoArray size do: [:i |
		(last <= aNumber and: [aNumber < (next _ whoArray at: i)]) ifTrue: [
			smaller _ last.
			bigger _ next.
			(smaller - aNumber) abs <= (bigger - aNumber) abs ifTrue: [^ smaller] ifFalse: [^ bigger].
		].
		last _ next.
	].
	^ last.
! !

!KedamaExamplerPlayer methodsFor: 'accessing' stamp: 'yo 4/4/2005 13:59'!
whoAt: index

	| whoArray |
	whoArray _ turtles arrays first.
	index < 1 ifTrue: [^ 0].
	index > whoArray size ifTrue: [^ 0].

	^ whoArray at: index.
! !

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

KedamaExamplerPlayer class
	instanceVariableNames: ''!

!KedamaExamplerPlayer class methodsFor: 'compiling' stamp: 'yo 8/23/2004 11:30'!
wantsChangeSetLogging
	"Log changes for Player itself, but not for automatically-created subclasses like Player1, Player2, but *do* log it for uniclasses that have been manually renamed."

	^ (self == KedamaExamplerPlayer or:
		[(self name beginsWith: 'KedamaExamplerPlayer') not]) or:
			[Preferences universalTiles]! !
FloatArray variableWordSubclass: #KedamaFloatArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'!
primAddArray: rcvr and: other into: result

	<primitive: 'primitiveAddArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveAddArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) + (other at: i)
	].
	^ result.
! !

!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:15'!
primAddScalar: rcvr and: other into: result

	<primitive: 'primitiveAddScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveAddScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) + other.
	].
	^ result.
! !

!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'!
primDivArray: rcvr and: other into: result

	<primitive: 'primitiveDivArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveDivArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) / (other at: i)
	].
	^ result.
! !

!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'!
primDivScalar: rcvr and: other into: result

	<primitive: 'primitiveDivScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveDivScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) / other.
	].
	^ result.
! !

!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'!
primMulArray: rcvr and: other into: result

	<primitive: 'primitiveMulArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveMulArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) * (other at: i)
	].
	^ result.
! !

!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:38'!
primMulScalar: rcvr and: other into: result

	<primitive: 'primitiveMulScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveMulScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) * other.
	].
	^ result.
! !

!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'!
primSubArray: rcvr and: other into: result

	<primitive: 'primitiveSubArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveSubArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) - (other at: i)
	].
	^ result.
! !

!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:38'!
primSubScalar: rcvr and: other into: result

	<primitive: 'primitiveSubScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveSubScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) - other.
	].
	^ result.
! !


!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:40'!
* other

	| result |
	other isNumber ifTrue: [
		result _ KedamaFloatArray new: self size.
		^ self primMulScalar: self and: other into: result.
	].
	((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [	
		result _ KedamaFloatArray new: self size.
		^ self primMulArray: self and: other into: result.
	].
	^ super * other.
! !

!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:43'!
*= other

	other isNumber ifTrue: [
		^ self primMulScalar: self and: other asFloat into: self.
	].
	((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [	
		^ self primMulArray: self and: other into: self.
	].
	^ super *= other.
! !

!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:30'!
+ other

	| result |
	other isNumber ifTrue: [
		result _ KedamaFloatArray new: self size.
		^ self primAddScalar: self and: other into: result.
	].
	((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [	
		result _ KedamaFloatArray new: self size.
		^ self primAddArray: self and: other into: result.
	].
	^ super + other.
! !

!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:44'!
+= other

	other isNumber ifTrue: [
		^ self primAddScalar: self and: other into: self.
	].
	((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [	
		^ self primAddArray: self and: other into: self.
	].
	^ super += other.
! !

!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:40'!
- other

	| result |
	other isNumber ifTrue: [
		result _ KedamaFloatArray new: self size.
		^ self primSubScalar: self and: other into: result.
	].
	((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [	
		result _ KedamaFloatArray new: self size.
		^ self primSubArray: self and: other into: result.
	].
	^ super - other.
! !

!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:44'!
-= other

	other isNumber ifTrue: [
		^ self primSubScalar: self and: other into: self.
	].
	((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [	
		^ self primSubArray: self and: other into: self.
	].
	^ super -= other.
! !

!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:41'!
/ other

	| result |
	other isNumber ifTrue: [
		result _ KedamaFloatArray new: self size.
		^ self primDivScalar: self and: other into: result.
	].
	((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [	
		result _ KedamaFloatArray new: self size.
		^ self primDivArray: self and: other into: result.
	].
	^ super / other.
! !

!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:45'!
/= other

	other isNumber ifTrue: [
		^ self primDivScalar: self and: other into: self.
	].
	((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [	
		^ self primDivArray: self and: other into: self.
	].
	^ super /= other.
! !
TileMorph subclass: #KedamaGetColorComponentTile
	instanceVariableNames: 'patchTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaGetColorComponentTile commentStamp: '<historical>' prior: 0!
I provide the red, green or blue component getter tile.
!


!KedamaGetColorComponentTile methodsFor: 'initalization support' stamp: 'yo 10/12/2004 22:32'!
addPatchTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: (operatorOrExpression asString copyWithout: $:) font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Patch.
	m1 addMorph: m2.
	desiredW _ m1 width.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	self addMorphBack: m1.
	self addMorphFront: label.
	patchTile _ m1.
! !

!KedamaGetColorComponentTile methodsFor: 'initalization support' stamp: 'yo 10/12/2004 22:31'!
componentName: aSymbol

	aSymbol = #blue ifTrue: [
		operatorOrExpression _ #getBlueComponentIn:.
	].
	aSymbol = #green ifTrue: [
		operatorOrExpression _ #getGreenComponentIn:.
	].
	aSymbol = #red ifTrue: [
		operatorOrExpression _ #getRedComponentIn:.
	].
	self addPatchTile.

! !

!KedamaGetColorComponentTile methodsFor: 'initalization support' stamp: 'yo 10/12/2004 22:32'!
setPatchDefaultTo: aPlayer

	patchTile submorphs first setToReferTo: aPlayer.
! !


!KedamaGetColorComponentTile methodsFor: 'initialization' stamp: 'yo 10/12/2004 22:29'!
initialize

	super initialize.
	type _ #Patch.
	operatorOrExpression _ #getBlueComponentIn:.
	self addPatchTile.
	self line1: 'getBlueComponentIn:'.
! !


!KedamaGetColorComponentTile methodsFor: 'tile protocol' stamp: 'yo 10/12/2004 22:32'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: (operatorOrExpression asString copyWithout: $:) font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: patchTile.
! !

!KedamaGetColorComponentTile methodsFor: 'tile protocol' stamp: 'yo 10/12/2004 22:33'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"getPatchValueIn:"
	aStream nextPutAll: parts first.
	aStream space.
	patchTile storeCodeOn: aStream indent: tabCount.
! !
TileMorph subclass: #KedamaGetPixelValueTile
	instanceVariableNames: 'patchTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaGetPixelValueTile commentStamp: '<historical>' prior: 0!
I provide the patchValueIn getter tile.
!


!KedamaGetPixelValueTile methodsFor: 'initialization support' stamp: 'yo 1/30/2005 11:03'!
addPatchTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'getValueIn' translated font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Patch.
	m1 addMorph: m2.
	desiredW _ m1 width.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	self addMorphBack: m1.
	self addMorphFront: label.
	patchTile _ m1.
! !

!KedamaGetPixelValueTile methodsFor: 'initialization support' stamp: 'yo 1/30/2005 11:04'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: 'patchValueIn' translated font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: patchTile.
! !


!KedamaGetPixelValueTile methodsFor: 'initialization' stamp: 'yo 10/8/2004 07:45'!
initialize

	super initialize.
	type _ #Patch.
	operatorOrExpression _ #getPatchValueIn:.
	self addPatchTile.
	self line1: 'getPatchValueIn:'.
! !


!KedamaGetPixelValueTile methodsFor: 'tile protocol' stamp: 'yo 6/7/2004 21:19'!
setPatchDefaultTo: aPlayer

	patchTile submorphs first setToReferTo: aPlayer.
! !

!KedamaGetPixelValueTile methodsFor: 'tile protocol' stamp: 'yo 10/7/2004 21:58'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"getPatchValueIn:"
	aStream nextPutAll: parts first.
	aStream space.
	patchTile storeCodeOn: aStream indent: tabCount.
! !
Morph subclass: #KedamaMorph
	instanceVariableNames: 'dimensions wrapX wrapY pixelsPerPatch patchesToDisplay patchVarDisplayForm lastTurtleID turtleCount turtlesDict turtlesDictSemaphore turtlesToDisplay magnifiedDisplayForm autoChanged topEdgeMode bottomEdgeMode leftEdgeMode rightEdgeMode topEdgeModeMnemonic bottomEdgeModeMnemonic leftEdgeModeMnemonic rightEdgeModeMnemonic'
	classVariableNames: 'RandomSeed'
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaMorph commentStamp: 'yo 6/18/2004 18:29' prior: 0!
A tile-scriptable variant of StarSqueak.
!


!KedamaMorph methodsFor: 'event handling' stamp: 'ar 7/8/2006 20:25'!
acceptDroppingMorph: morphToDrop event: evt

	| f turtle |
	(morphToDrop renderedMorph isKindOf: SketchMorph) ifFalse: [
		^morphToDrop rejectDropMorphEvent: evt.
	].

	f _ morphToDrop renderedMorph rotatedForm.
	f _ f magnify: f boundingBox by: (1.0 / self pixelsPerPatch asFloat) smoothing: 1.

	turtle _ self player newTurtleSilently.
	turtle createTurtlesAsIn: f originAt: ((morphToDrop topLeft - self topLeft) / self pixelsPerPatch asFloat) asIntegerPoint.
	"turtle isGroup: true."
	turtle color: (self dominantColorWithoutTransparent: f).
! !

!KedamaMorph methodsFor: 'event handling' stamp: 'ar 7/8/2006 20:25'!
dominantColorWithoutTransparent: aForm
	| tally max maxi |
	aForm depth > 16 ifTrue:
		[^self dominantColorWithoutTransparent: (aForm asFormOfDepth: 16)].
	tally _ aForm tallyPixelValues.
	max _ maxi _ 0.
	tally withIndexDo: [:n :i | n > max ifTrue: [ i ~= 1 ifTrue: [max _ n. maxi _ i]]].
	^ Color colorFromPixelValue: maxi - 1 depth: aForm depth
! !

!KedamaMorph methodsFor: 'event handling' stamp: 'yo 8/10/2004 12:23'!
wantsDroppedMorph: aMorph event: anEvent

	^ aMorph isMemberOf: SketchMorph.
! !


!KedamaMorph methodsFor: 'setup' stamp: 'yo 9/9/2004 15:24'!
addToPatchDisplayList: p

	| a |
	a _ patchesToDisplay copyWithout: p.
	patchesToDisplay _ a copyWith: p.
! !

!KedamaMorph methodsFor: 'setup' stamp: 'yo 9/14/2004 20:24'!
addToTurtleDisplayList: p

	| a |
	(p isKindOf: KedamaExamplerPlayer) ifFalse: [^ self].
	a _ turtlesToDisplay copyWithout: p.
	turtlesToDisplay _ a copyWith: p.
! !

!KedamaMorph methodsFor: 'setup' stamp: 'yo 6/9/2004 11:09'!
cleanUp

	self extension actorState: nil.
	self extension player: nil.
	self initializeTurtlesDict.
! !

!KedamaMorph methodsFor: 'setup' stamp: 'yo 9/27/2004 10:26'!
clearAll
	"Reset this StarSqueak world. All patch variables are cleared, all turtles are removed, and all demons are turned off."

	patchVarDisplayForm _ Form extent: dimensions depth: 32.
	self initializePatch.
	self recreateMagnifiedDisplayForm.
	self initializeTurtlesDict.

	turtleCount _ 0.
	lastTurtleID _ 0.

	self color: Color black.

! !

!KedamaMorph methodsFor: 'setup' stamp: 'yo 6/1/2004 16:53'!
setup
	"Subclasses should override this to setup the initial conditions of this StarSqueak world. The method should start with 'self clearAll'."

	self clearAll.
! !


!KedamaMorph methodsFor: 'submorphs-accessing' stamp: 'yo 6/17/2004 19:45'!
allSubmorphNamesDo: aBlock

	super allSubmorphNamesDo: aBlock.
	aBlock value: self player getPatch externalName.
! !


!KedamaMorph methodsFor: 'drawing' stamp: 'yo 6/1/2004 16:53'!
areasRemainingToFill: aRectangle
	"Drawing optimization. Since I completely fill my bounds with opaque pixels, this method tells Morphic that it isn't necessary to draw any morphs covered by me."
	
	^ aRectangle areasOutside: self bounds
! !

!KedamaMorph methodsFor: 'drawing' stamp: 'yo 6/17/2004 17:56'!
display
	"Display this world on the Display. Used for debugging."

	| c |
	c _ FormCanvas extent: (dimensions * pixelsPerPatch) depth: 32.
	c _ c copyOffset: bounds origin negated.
	self drawOn: c.
	c form display.
! !

!KedamaMorph methodsFor: 'drawing' stamp: 'yo 9/27/2004 10:28'!
drawOn: aCanvas
	"Display this StarSqueak world."

	| result |
	"Time millisecondClockValue printString displayAt: 0@0."
	self player ifNil: [^ aCanvas fillRectangle: (self bounds) color: self color].
	patchVarDisplayForm fillColor: self color.
	patchesToDisplay do: [:p |
		p displayPatchVariableOn: patchVarDisplayForm.
	].
	self drawTurtlesOnForm: patchVarDisplayForm.
	pixelsPerPatch = 1 ifTrue: [
		aCanvas drawImage: patchVarDisplayForm at: bounds origin.
	] ifFalse: [
		result _ self zoom: patchVarDisplayForm into: magnifiedDisplayForm factor: pixelsPerPatch.
		result ifNil: [
			aCanvas warpImage: patchVarDisplayForm transform: (MatrixTransform2x3 withScale: pixelsPerPatch) at: self innerBounds origin.
		] ifNotNil: [
			aCanvas drawImage: magnifiedDisplayForm at: bounds origin.
		]
	].

	autoChanged ifTrue: [self changed].

! !

!KedamaMorph methodsFor: 'drawing' stamp: 'yo 9/27/2004 16:28'!
drawTurtlesOnForm: aForm

	turtlesToDisplay do: [:exampler |
		(self isVisible: exampler) ifTrue: [
			turtlesDictSemaphore critical: [
				exampler turtles drawOn: aForm.
			].
		].
	].
! !

!KedamaMorph methodsFor: 'drawing' stamp: 'yo 6/4/2004 18:13'!
patchesToDisplayAsString

	^ String streamContents: [:strm |
		strm nextPutAll: '#('.
		patchesToDisplay do: [:p |
			strm nextPutAll: p externalName.
			strm nextPut: Character space.
		].
		strm nextPutAll: ')'.
	].
! !

!KedamaMorph methodsFor: 'drawing' stamp: 'yo 9/9/2004 15:16'!
removeAllFromPatchDisplayList

	patchesToDisplay _ #().
! !

!KedamaMorph methodsFor: 'drawing' stamp: 'yo 9/9/2004 15:19'!
removeAllFromTurtleDisplayList

	turtlesToDisplay _ #().
! !

!KedamaMorph methodsFor: 'drawing' stamp: 'yo 9/9/2004 15:21'!
turtlesToDisplayAsString

	^ String streamContents: [:strm |
		strm nextPutAll: '#('.
		turtlesToDisplay do: [:p |
			strm nextPutAll: p externalName.
			strm nextPut: Character space.
		].
		strm nextPutAll: ')'.
	].
! !


!KedamaMorph methodsFor: 'accessing' stamp: 'yo 6/17/2004 09:51'!
bottomEdgeMode

	^ bottomEdgeMode.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 9/16/2004 18:59'!
bottomEdgeModeMnemonic

	^ bottomEdgeModeMnemonic.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 1/20/2005 19:52'!
bottomEdgeMode: aSymbol

	bottomEdgeMode _ aSymbol asSymbol.
	bottomEdgeMode == #wrap ifTrue: [
		bottomEdgeModeMnemonic _ 1.
		^ self
	].
	bottomEdgeMode == #stick ifTrue: [
		bottomEdgeModeMnemonic _ 2.
		^ self
	].
	(bottomEdgeMode == #bounce or: [bottomEdgeMode == #bouncing]) ifTrue: [
		bottomEdgeModeMnemonic _ 3.
		^ self
	].
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 4/6/2005 12:59'!
colorAt: aLocalPoint

	| pix |
	pix _ patchVarDisplayForm pixelValueAt: (aLocalPoint // pixelsPerPatch) asIntegerPoint.
	^ Color colorFromPixelValue: (pix bitOr: 16rFF000000) depth: 32.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 6/1/2004 16:53'!
dimensions

	^ dimensions
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 6/17/2004 09:51'!
leftEdgeMode

	^ leftEdgeMode.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 9/16/2004 18:59'!
leftEdgeModeMnemonic

	^ leftEdgeModeMnemonic.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 1/20/2005 19:52'!
leftEdgeMode: aSymbol

	leftEdgeMode _ aSymbol asSymbol.
	leftEdgeMode == #wrap ifTrue: [
		leftEdgeModeMnemonic _ 1.
		^ self
	].
	leftEdgeMode == #stick ifTrue: [
		leftEdgeModeMnemonic _ 2.
		^ self
	].
	(leftEdgeMode == #bounce or: [leftEdgeMode == #bouncing]) ifTrue: [
		leftEdgeModeMnemonic _ 3.
		^ self
	].
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 6/1/2004 16:53'!
pixelsPerPatch

	^ pixelsPerPatch
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 6/11/2004 01:06'!
pixelsPerPatch: anInteger
	"Set the width of one patch in pixels. Larger numbers scale up this StarSqueak world, but numbers larger than 2 or 3 result in a blocky look. The useful range is 1 to 10."

	pixelsPerPatch _ (anInteger rounded max: 1) min: 10.
	super extent: dimensions * pixelsPerPatch.
	self recreateMagnifiedDisplayForm
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 6/17/2004 09:51'!
rightEdgeMode

	^ rightEdgeMode.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 9/16/2004 18:59'!
rightEdgeModeMnemonic

	^ rightEdgeModeMnemonic.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 1/20/2005 19:52'!
rightEdgeMode: aSymbol

	rightEdgeMode _ aSymbol asSymbol.
	rightEdgeMode == #wrap ifTrue: [
		rightEdgeModeMnemonic _ 1.
		^ self
	].
	rightEdgeMode == #stick ifTrue: [
		rightEdgeModeMnemonic _ 2.
		^ self
	].
	(rightEdgeMode == #bounce or: [rightEdgeMode == #bouncing]) ifTrue: [
		rightEdgeModeMnemonic _ 3.
		^ self
	].
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 6/17/2004 09:52'!
topEdgeMode

	^ topEdgeMode.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 9/16/2004 18:59'!
topEdgeModeMnemonic

	^ topEdgeModeMnemonic.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 1/20/2005 19:53'!
topEdgeMode: aSymbol

	topEdgeMode _ aSymbol asSymbol.
	topEdgeMode == #wrap ifTrue: [
		topEdgeModeMnemonic _ 1.
		^ self
	].
	topEdgeMode == #stick ifTrue: [
		topEdgeModeMnemonic _ 2.
		^ self
	].
	(topEdgeMode == #bounce or: [topEdgeMode == #bouncing])  ifTrue: [
		topEdgeModeMnemonic _ 3.
		^ self
	].
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 9/9/2004 15:08'!
wrapX

	^ wrapX.
! !

!KedamaMorph methodsFor: 'accessing' stamp: 'yo 9/9/2004 15:08'!
wrapY

	^ wrapY.
! !


!KedamaMorph methodsFor: 'turtles' stamp: 'KR 4/14/2006 15:52'!
calcTurtlesCount

	turtleCount _ 0.
	turtlesDict do: [:a | turtleCount _ turtleCount + a size].

	SmalltalkImage current vmParameterAt: 5 put: ((turtleCount * 3) min: 16000 max: 4000).
	SmalltalkImage current vmParameterAt: 6 put: ((turtleCount * 6) min: 32000 max: 8000).
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/28/2004 14:12'!
deleteAllTurtlesOfExampler: examplerPlayer

	turtlesDict removeKey: examplerPlayer ifAbsent: [].
	self removeFromTurtleDisplayList: examplerPlayer.
	self calcTurtlesCount.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 7/20/2005 22:34'!
deleteTurtleID: who of: examplerPlayer
	"Delete the given turtle from this world."

	| array |
	array _ examplerPlayer turtles.
	array ifNil: [^ self].
	turtlesDictSemaphore critical: [
		array deleteTurtleID: who.
	].
	self calcTurtlesCount.
	examplerPlayer costume renderedMorph privateTurtleCount: array size.
	"examplerPlayer allOpenViewers do: [:v | v resetWhoIfNecessary]."
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/20/2004 09:28'!
lastWhoOf: exampler

	| turtles |
	turtles _ turtlesDict at: exampler ifAbsent: [nil].
	^ (turtles arrays first) at: turtles arrays first size.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/14/2004 18:39'!
makePrototypeOfExampler: examplerPlayer

	^ self makePrototypeOfExampler: examplerPlayer color: nil.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/27/2004 16:29'!
makePrototypeOfExampler: examplerPlayer color: cPixel

	| array inst info |
	array _ examplerPlayer turtles.
	info _ array info.
	array size > 0 ifTrue: [
		inst _ array makePrototypeFromFirstInstance.
		cPixel ifNotNil: [inst at: (info at: #color) put: cPixel].
		^ inst.
	].

	inst _ Array new: array instSize.
	info associationsDo: [:assoc |
		inst at: (assoc value) put: (examplerPlayer perform: (Utilities getterSelectorFor: assoc key)).
	].
	cPixel ifNotNil: [inst at: (info at: #color) put: cPixel] ifNil: [inst at: (info at: #color) put: ((examplerPlayer getColor pixelValueForDepth: 32) bitAnd: 16rFFFFFF)].
	inst at: (info at: #visible) put: ((inst at: (info at: #visible)) ifTrue: [1] ifFalse: [0]).
	^ inst.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/27/2004 16:29'!
makeReplicatedTurtles: count examplerPlayer: tp color: c ofPrototype: prototype randomize: randomizeFlag

	| array inst |
	array _ tp turtles.

	inst _ prototype ifNil: [self makePrototypeOfExampler: tp color: c].

	turtlesDictSemaphore critical: [
		array addTurtlesCount: count ofPrototype: inst for: self randomize: randomizeFlag.
	].
	self calcTurtlesCount.
	self changed.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/28/2004 14:16'!
makeTurtlesAtPositionsIn: positionAndColorArray examplerPlayer: tp ofPrototype: prototype

	| array inst |
	array _ tp turtles.

	inst _ prototype ifNil: [self makePrototypeOfExampler: tp].

	turtlesDictSemaphore critical: [array addTurtlesCount: positionAndColorArray first size ofPrototype: inst for: self positionAndColorArray: positionAndColorArray].
	self calcTurtlesCount.
	self changed.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/28/2004 14:13'!
makeTurtles: count examplerPlayer: tp color: c ofPrototype: prototype turtles: turtles randomize: randomizeFlag

	| array inst |
	array _ tp turtles.
	(turtlesDict keys includes: tp) ifFalse: [
		self addToTurtleDisplayList: tp.
		turtlesDict at: tp put: (array _ turtles).
	].

	inst _ prototype ifNil: [self makePrototypeOfExampler: tp color: c].

	turtlesDictSemaphore critical: [array setTurtlesCount: count prototype: inst for: self randomize: randomizeFlag].
	self calcTurtlesCount.
	self changed.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/14/2004 17:34'!
nextTurtleID

	^ lastTurtleID _ lastTurtleID + 1.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/14/2004 20:28'!
removeFromTurtleDisplayList: examplerPlayer

	turtlesToDisplay _ turtlesToDisplay copyWithout: examplerPlayer.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/27/2004 16:30'!
setTurtlesCount: count examplerPlayer: tp color: cPixel

	| prototype |
	prototype _ self makePrototypeOfExampler: tp color: cPixel.
	turtlesDictSemaphore critical: [(tp turtles) setTurtlesCount: count prototype: prototype for: self randomize: true].
	self calcTurtlesCount.
! !

!KedamaMorph methodsFor: 'turtles' stamp: 'yo 9/27/2004 16:30'!
turtlesCountOf: exampler

	| array |
	array _ exampler turtles.
	array ifNil: [^ 0].
	^ array size.
! !


!KedamaMorph methodsFor: 'etoys' stamp: 'yo 6/11/2004 11:20'!
categoriesForViewer
	"Answer a list of symbols representing the categories to offer in the viewer, in order"
	^ super categoriesForViewer.
"
	| aList |
	aList _ OrderedCollection new.
	aList addAllFirstUnlessAlreadyPresent: (self class additionsToViewerCategories collect:
				[:categorySpec | categorySpec first]).
	^ aList
"! !

!KedamaMorph methodsFor: 'etoys' stamp: 'yo 6/2/2004 16:36'!
turtleCount

	^ turtleCount.
! !


!KedamaMorph methodsFor: 'deleting' stamp: 'yo 10/8/2004 11:11'!
delete

	| c |
	super delete.
	turtlesDict keysDo: [:k |
		self deleteAllTurtlesOfExampler: k.
		c _ k costume.
		c ifNotNil: [c renderedMorph delete].
	].

! !


!KedamaMorph methodsFor: 'geometry' stamp: 'yo 6/1/2004 16:53'!
extent: aPoint
	"Do nothing; my extent is determined by my StarSqueak world dimensions and pixelsPerPatch."
! !


!KedamaMorph methodsFor: 'initialization' stamp: 'yo 9/17/2004 19:34'!
initialize

	super initialize.
	dimensions _ self class defaultDimensions.  "dimensions of this StarSqueak world in patches"
	wrapX _ dimensions x asFloat.
	wrapY _ dimensions y asFloat.
	pixelsPerPatch _ 2.
	super extent: dimensions * pixelsPerPatch.
	self assuredPlayer assureUniClass.
	self clearAll.  "be sure this is done once in case setup fails to do it"
	autoChanged _ true.
	self leftEdgeMode: #wrap.
	self rightEdgeMode: #wrap.
	self topEdgeMode: #wrap.
	self bottomEdgeMode: #wrap.

	turtlesDictSemaphore _ Semaphore forMutualExclusion.
! !

!KedamaMorph methodsFor: 'initialization' stamp: 'yo 9/9/2004 15:15'!
initializePatch

	| f |
	f _ self player addPatchVarNamed: #patch.
	patchesToDisplay _ Array new: 0.
	self addToPatchDisplayList: f.
	^ f.
! !

!KedamaMorph methodsFor: 'initialization' stamp: 'yo 9/28/2004 14:12'!
initializeTurtlesDict

	turtlesDict _ IdentityDictionary new.
	turtlesToDisplay _ Array new.
! !


!KedamaMorph methodsFor: 'private' stamp: 'yo 9/14/2004 18:47'!
isVisible: examplerPlayer

	| turtleMorph |
	turtleMorph _ examplerPlayer costume.
	turtleMorph visible ifFalse: [^ false].
	turtleMorph owner isRenderer ifFalse: [^ true].
	^ turtleMorph owner visible.
! !

!KedamaMorph methodsFor: 'private' stamp: 'yo 6/6/2004 23:25'!
recreateMagnifiedDisplayForm

	magnifiedDisplayForm _ Form extent: self dimensions * pixelsPerPatch depth: 32.
	self changed.
! !

!KedamaMorph methodsFor: 'private' stamp: 'yo 6/7/2004 12:04'!
zoom: src into: dst factor: f

	src unhibernate.
	dst unhibernate.
	^ self primZoom: src bits into: dst bits srcWidth: src width height: src height multX: f y: f.
! !


!KedamaMorph methodsFor: 'menu' stamp: 'yo 8/18/2005 12:09'!
offerCostumeViewerMenu: aMenu
	aMenu add: 'add a new patch variable' translated action: #newPatch.
	aMenu balloonTextForLastItem: 'Add a new patch variable' translated.
	aMenu add: 'add a new breed of turtle' translated action: #newTurtle.
	aMenu balloonTextForLastItem: 'Add a new turtle' translated.
	aMenu addLine.
! !

!KedamaMorph methodsFor: 'menu' stamp: 'yo 6/16/2004 08:56'!
setScale

	| reply |
	reply _ FillInTheBlank
		request: 'Set the number of pixels per patch (a number between 1 and 10)?'
		 initialAnswer: pixelsPerPatch printString.
	reply isEmpty ifTrue: [^ self].
	self pixelsPerPatch: reply asNumber.
! !


!KedamaMorph methodsFor: 'private-primitives' stamp: 'yo 3/7/2005 13:27'!
primSetRandomSeed: seed

	<primitive: 'kedamaSetRandomSeed' module: 'KedamaPlugin'>
	^ nil.
! !

!KedamaMorph methodsFor: 'private-primitives' stamp: 'yo 6/18/2004 15:18'!
primZoom: src into: dst srcWidth: sWidth height: sHeight multX: xFactor y: yFactor

	<primitive: 'zoomBitmap' module: 'KedamaPlugin'>
	"^ KedamaSqueakPlugin doPrimitive: #zoomBitmap."
	^ nil.
! !


!KedamaMorph methodsFor: 'utils' stamp: 'yo 8/18/2005 15:32'!
hasNoTurtleBreed

	^ turtlesDict isEmpty.
! !

!KedamaMorph methodsFor: 'utils' stamp: 'yo 3/23/2005 12:24'!
random: range
	"Answer a random integer between 0 and range."

	| r val |
	<primitive: 'randomRange' module: 'KedamaPlugin'>
	r _ range < 0 ifTrue: [range negated] ifFalse: [range].
	RandomSeed _ ((RandomSeed * 1309) + 13849) bitAnd: 65535.
	val _ (RandomSeed * (r + 1)) >> 16.
	^ range < 0 ifTrue: [val negated] ifFalse: [^ val].

! !

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

KedamaMorph class
	instanceVariableNames: ''!

!KedamaMorph class methodsFor: 'class initialization' stamp: 'yo 9/14/2004 20:27'!
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."
	^ #(

 	(kedama (
		(command addToPatchDisplayList: 'add patch to display list' Patch)
		(command removeAllFromPatchDisplayList 'clear the patch display list')
		(slot patchDisplayList 'patches to display' String readOnly Player getPatchesList unused unused)
		(command addToTurtleDisplayList: 'add turtle to display list' Player)
		(command removeAllFromTurtleDisplayList 'clear the turtle display list')
		(slot turtleDisplayList 'turtles to display' String readOnly Player getTurtlesList unused unused)
		(slot pixelsPerPatch 'the display scale' Number readWrite Player getPixelsPerPatch Player setPixelsPerPatch:)
		(slot color 'The color of the object' Color readWrite Player getColor  Player  setColor:)
		"(command makeTurtlesMap 'Internally create the map of turtles')"
		(slot leftEdgeMode 'the mode of left edge' EdgeMode readWrite Player getLeftEdgeMode Player setLeftEdgeMode:)
		(slot rightEdgeMode 'the mode of right edge' EdgeMode readWrite Player getRightEdgeMode Player setRightEdgeMode:)
		(slot topEdgeMode 'the mode of top edge' EdgeMode readWrite Player getTopEdgeMode Player setTopEdgeMode:)
		(slot bottomEdgeMode 'the mode of bottom edge' EdgeMode readWrite Player getBottomEdgeMode Player setBottomEdgeMode:)
	))
).
! !

!KedamaMorph class methodsFor: 'class initialization' stamp: 'yo 6/9/2004 11:09'!
cleanUp
"
	self cleanUp
"
	self allInstancesDo: [:e | e cleanUp].
! !

!KedamaMorph class methodsFor: 'class initialization' stamp: 'yo 6/17/2004 19:04'!
defaultDimensions

	"Answer the dimensions of this StarSqueak simulation. Subclasses can override this method to define their own world size."

	^ 100@100.
! !

!KedamaMorph class methodsFor: 'class initialization' stamp: 'yo 9/26/2005 22:58'!
defaultNameStemForInstances

	^ 'KedamaWorld' translated.
! !

!KedamaMorph class methodsFor: 'class initialization' stamp: 'yo 9/13/2005 22:09'!
descriptionForPartsBin
	^ self partName:	'KedamaWorld'
		categories:		#('Kedama')
		documentation:	'A tile scriptable particle system' translated! !

!KedamaMorph class methodsFor: 'class initialization' stamp: 'yo 9/2/2004 23:23'!
initialize
	"Kedama initialize"

	RandomSeed _ 17.
! !

!KedamaMorph class methodsFor: 'class initialization' stamp: 'yo 10/23/2005 20:33'!
newSet

	| k p t s w |
	k _ self new.
	p _ k assuredPlayer getPatch costume renderedMorph.
	t _ k assuredPlayer newTurtleForSet.

	s _ SelectionMorph new.

	w _ PasteUpMorph new.
	w extent: 400@400.
	p position: 275@50.
	t position: 300@175.
	k position: 25@25.
	w addMorph: k.
	w addMorph: t.
	w addMorph: p.
	w addMorph: s.
	s bounds: w bounds.
	s selectSubmorphsOf: w.
	^ s.
! !


!KedamaMorph class methodsFor: 'global primitive backup' stamp: 'yo 10/11/2004 11:47'!
degreesToRadians: degrees

	| deg q headingRadians |
	deg _ 90.0 - degrees.
	q _ (deg / 360.0) asInteger.
	deg < 0.0 ifTrue: [q _ q - 1].
	headingRadians _ (deg - (q * 360.0)) * 0.0174532925199433.
	^ headingRadians.
! !

!KedamaMorph class methodsFor: 'global primitive backup' stamp: 'yo 10/11/2004 12:45'!
radiansToDegrees: radians

	| degrees deg |
	degrees _ radians / 0.0174532925199433.
	deg _ 90.0 - degrees.
	deg > 0.0 ifFalse: [deg _ deg + 360.0].
	^ deg.

! !

!KedamaMorph class methodsFor: 'global primitive backup' stamp: 'yo 10/10/2004 09:07'!
scalarXAt: index xArray: xArray headingArray: headingArray value: val destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode

	| newX headingRadians |
	newX _ val.
	newX < 0.0 ifTrue: [
		leftEdgeMode = 1 ifTrue: [
			"wrap"
			newX _ newX + destWidth.
		].
		leftEdgeMode = 2 ifTrue: [
			"stick"
			newX _ 0.0.
		].
		leftEdgeMode = 3 ifTrue: [
			"bounce"
			newX _ 0.0 - newX.
			headingRadians _ headingArray at: index.
			headingRadians <  3.141592653589793
				ifTrue: [headingArray at: index put: 3.141592653589793 - headingRadians]
				ifFalse: [headingArray at: index put: 9.42477796076938 - headingRadians].
		].
	].

	newX >= destWidth ifTrue: [
		rightEdgeMode = 1 ifTrue: [
			newX _ newX - destWidth.
		].
		rightEdgeMode = 2 ifTrue: [
			newX _ destWidth - 0.000001.
		].
		rightEdgeMode = 3 ifTrue: [
			newX _ (destWidth - 0.000001) - (newX - destWidth).
			headingRadians _ headingArray at: index.
			headingRadians < 3.141592653589793
				ifTrue: [headingArray at: index put: (3.141592653589793 - headingRadians)]
				ifFalse: [headingArray at: index put: (9.42477796076938 - headingRadians)].
		]
	].
	xArray at: index put: newX.
! !

!KedamaMorph class methodsFor: 'global primitive backup' stamp: 'yo 10/10/2004 09:09'!
scalarYAt: index yArray: yArray headingArray: headingArray value: val destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode

	| newY |
	newY _ val.
	newY < 0.0 ifTrue: [
		topEdgeMode = 1 ifTrue: [
			"wrap"
			newY _ newY + destHeight.
		].
		topEdgeMode = 2 ifTrue: [
			"stick"
			newY _ 0.0.
		].
		topEdgeMode = 3 ifTrue: [
			"bounce"
			newY _ 0.0 - newY.
			headingArray at: index put: (6.283185307179586 - (headingArray at: index)).
		].
	].

	newY >= destHeight ifTrue: [
		bottomEdgeMode = 1 ifTrue: [
			newY _ newY - destHeight.
		].
		bottomEdgeMode = 2 ifTrue: [
			newY _ destHeight - 0.000001.
		].
		bottomEdgeMode = 3 ifTrue: [
			newY _ (destHeight - 0.000001) - (newY - destHeight).
			headingArray at: index put: (6.283185307179586 - (headingArray at: index)).
		]
	].
	yArray at: index put: newY.
! !
Morph subclass: #KedamaPatchMorph
	instanceVariableNames: 'form displayMax shiftAmount useLogDisplay displayForm diffusionRate scaledEvaporationRate sniffRange formChanged tmpForm autoChanged displayType'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaPatchMorph commentStamp: 'yo 6/18/2004 18:31' prior: 0!
I represent the patch variable.
!


!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/7/2004 10:21'!
autoChanged

	^ autoChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/7/2004 10:21'!
autoChanged: aBoolean

	autoChanged _ aBoolean.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 8/18/2005 10:56'!
basicPixelAtX: xPos y: yPos

	| x y i |
	x _ xPos truncated.
	y _ yPos truncated.
	((x < 0) or: [y < 0]) ifTrue: [^ 0].
	((x >= form width) or: [y >= form height]) ifTrue: [^ 0].
	i _ ((y * form width) + x) + 1.
	form bits class == ByteArray ifTrue: [form unhibernate].
	^ form bits at: i.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 11/30/2005 12:07'!
basicPixelAtX: xPos y: yPos put: value

	| x y i v |
	x _ xPos truncated.
	y _ yPos truncated.
	v _ value asInteger min: 16rFFFFFFFF max: 0.
	((x < 0) or: [y < 0]) ifTrue: [^ self].
	((x >= form width) or: [y >= form height]) ifTrue: [^ self].
	i _ ((y * form width) + x) + 1.
	form bits class == ByteArray ifTrue: [form unhibernate].
	form bits at: i put: v.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 9/30/2004 11:46'!
basicUphillForTurtleX: tX turtleY: tY turtleHeading: tH
	"Answer the heading the points in the direction of increasing value for the given patch variable. If there is no gradient, or if the turtle is outside the world bounds, answer the turtles current heading."

	| turtleX turtleY startX endX startY endY maxVal rowOffset thisVal maxValX maxValY |
	turtleX := tX truncated.
	turtleY := tY truncated.
	turtleX := turtleX max: 0.
	turtleY := turtleY max: 0.
	turtleX := turtleX min: form width - 1.
	turtleY := turtleY min: form height - 1.
	startX := turtleX - sniffRange max: 0.
	endX := (turtleX + sniffRange) min: (form width - 1).
	startY := (turtleY - sniffRange) max: 0.
	endY := (turtleY + sniffRange) min: (form height - 1).
	"form bits class == Bitmap ifFalse: [form unhibernate]."
	maxVal := form bits at: turtleY * form width + turtleX + 1.
	maxValX := nil.
	startY to: endY
		do: 
			[:y | 
			rowOffset := y * form width.
			startX to: endX
				do: 
					[:x | 
					thisVal := form bits at: rowOffset + x + 1.
					thisVal > maxVal 
						ifTrue: 
							[maxValX := x.
							maxValY := y.
							maxVal := thisVal]]].
	nil = maxValX ifTrue: [^ (90.0 - tH radiansToDegrees) \\ 360.0].
	^ (((maxValX - turtleX) @ (maxValY - turtleY)) degrees + 90.0) \\ 360.0
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 10/13/2004 01:59'!
blueComponentFrom: another

	| pix anotherPix |
	0 to: self height - 1 do: [:y |
		0 to: self width -1 do: [:x |
			pix _ self pixelAtX: x y: y.
			anotherPix _ (another pixelAtX: x y: y) bitAnd: 16rFF.
			pix _ (pix bitAnd: 16rFFFF00) bitOr: (anotherPix).
			self pixelAtX: x y: y put: pix.
		].
	].
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 10/13/2004 00:22'!
blueComponentInto: another

	0 to: self height - 1 do: [:y |
		0 to: self width -1 do: [:x |
			another pixelAtX: x y: y put: ((self pixelAtX: x y: y) bitAnd: 16rFF).
		].
	].
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 21:31'!
clear

	form fillColor: Color transparent.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 14:00'!
colorAtX: xPos y: yPos

	^ Color colorFromPixelValue: (self pixelAtX: xPos y: yPos) depth: 32.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 21:29'!
colorAtX: xPos y: yPos put: aColor

	| pixel |
	pixel _ aColor pixelValueForDepth: 32.
	self pixelAtX: xPos y: yPos put: pixel.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/5/2004 20:21'!
color: aColor

	super color: aColor.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 8/18/2005 10:54'!
diffuse

	| dim newV |
	dim _ form extent.
	form bits class == ByteArray ifTrue: [form unhibernate].
	newV _ Bitmap new: form bits size.
	self primDiffuseFrom: form bits
		to: newV
		width: dim x
		height: dim y
		delta: diffusionRate truncated.
	form bits: newV.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 20:48'!
diffusionRate

	^ diffusionRate.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 20:48'!
diffusionRate: newRate
	"Set the diffusion rate to an integer between 0 and 10. The diffusion rate gives the number of patches on one size of the area averaged to compute the next value of the variable for a given patch. Larger numbers cause faster diffusion. Zero means no diffusion."

	diffusionRate _ (newRate rounded max: 0) min: 10.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/15/2004 05:12'!
displayMax

	^ displayMax at: 1.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/16/2004 04:34'!
displayMax: anInteger

	displayMax _ WordArray with: (anInteger asInteger min: 16rFFFFFFFF max: 0).
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/14/2004 16:21'!
displayShiftAmount

	^ shiftAmount.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/14/2004 16:20'!
displayShiftAmount: anInteger

	shiftAmount _ anInteger min: 8 max: -32.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 3/7/2005 12:05'!
displayType

	^ displayType.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 4/5/2005 10:11'!
displayType: aSymbol

	displayType _ aSymbol asSymbol.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 8/18/2005 10:56'!
evaporate

	form bits class == ByteArray ifTrue: [form unhibernate].
	self primEvaporate: form bits rate: scaledEvaporationRate.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 20:50'!
evaporationRate

	^ 1024 - scaledEvaporationRate.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 20:50'!
evaporationRate: newRate
	"Set the evaporation rate. The useful range is 0 to 25 or so. Larger numbers cause faster evaporation. Zero means no evaporization."

	scaledEvaporationRate _ ((1024 - newRate truncated) max: 1) min: 1024.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 10/13/2004 01:06'!
greenComponentFrom: another

	| pix anotherPix |
	0 to: self height - 1 do: [:y |
		0 to: self width -1 do: [:x |
			pix _ self pixelAtX: x y: y.
			anotherPix _ (another pixelAtX: x y: y) bitAnd: 16rFF.
			pix _ (pix bitAnd: 16rFF00FF) bitOr: (anotherPix bitShift: 8).
			self pixelAtX: x y: y put: pix.
		].
	].
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 10/13/2004 00:22'!
greenComponentInto: another

	0 to: self height - 1 do: [:y |
		0 to: self width -1 do: [:x |
			another pixelAtX: x y: y put: (((self pixelAtX: x y: y) bitShift: -8) bitAnd: 16rFF).
		].
	].
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 8/18/2005 10:38'!
pixelAtX: xPos y: yPos

	| x y i |
	x _ xPos truncated.
	y _ yPos truncated.
	((x < 0) or: [y < 0]) ifTrue: [^ 0].
	((x >= form width) or: [y >= form height]) ifTrue: [^ 0].
	i _ ((y * form width) + x) + 1.
	form bits class == ByteArray ifTrue: [form unhibernate].
	^ form bits at: i.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 11/30/2005 12:07'!
pixelAtX: xPos y: yPos put: value

	| x y i v |
	x _ xPos truncated.
	y _ yPos truncated.
	v _ (value asInteger max: 0) bitAnd: 16rFFFFFFFF.
	((x < 0) or: [y < 0]) ifTrue: [^ self].
	((x >= form width) or: [y >= form height]) ifTrue: [^ self].
	i _ ((y * form width) + x) + 1.
	form bits class == ByteArray ifTrue: [form unhibernate].
	form bits at: i put: v.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 8/18/2005 10:55'!
pixelsAtXArray: xArray yArray: yArray into: aWordArray

	form bits class == ByteArray ifTrue: [form unhibernate].
	self primPixelsAtXArray: xArray yArray: yArray bits: form bits width: form width height: form height into: aWordArray.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 10/13/2004 01:05'!
redComponentFrom: another

	| pix anotherPix |
	0 to: self height - 1 do: [:y |
		0 to: self width -1 do: [:x |
			pix _ self pixelAtX: x y: y.
			anotherPix _ (another pixelAtX: x y: y) bitAnd: 16rFF.
			pix _ (pix bitAnd: 16r00FFFF) bitOr: (anotherPix bitShift: 16).
			self pixelAtX: x y: y put: pix.
		].
	].
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 10/13/2004 00:21'!
redComponentInto: another

	0 to: self height - 1 do: [:y |
		0 to: self width -1 do: [:x |
			another pixelAtX: x y: y put: (((self pixelAtX: x y: y) bitShift: -16) bitAnd: 16rFF).
		].
	].
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 8/18/2005 10:55'!
setPixelsAtXArray: xArray yArray: yArray value: value

	form bits class == ByteArray ifTrue: [form unhibernate].
	self primSetPixelsAtXArray: xArray yArray: yArray bits: form bits width: form width height: form height value: value.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/4/2004 01:37'!
sniffRange

	^ sniffRange.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 6/4/2004 01:36'!
sniffRange: aNumber

	sniffRange _ aNumber.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 8/18/2005 10:54'!
uphillForTurtleX: tX turtleY: tY turtleHeading: tH
	"Answer the heading the points in the direction of increasing value for the given patch variable. If there is no gradient, or if the turtle is outside the world bounds, answer the turtles current heading."

	| ret |
	form bits class == ByteArray ifTrue: [form unhibernate].
	ret _ self primUpHillX: tX y: tY heading: tH bits: form bits width: form width height: form height sniffRange: sniffRange.
	ret ifNotNil: [^ ret].
	^ self basicUphillForTurtleX: tX turtleY: tY turtleHeading: tH.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 3/7/2005 12:19'!
useLogDisplay

	^ displayType == #logScale.
! !

!KedamaPatchMorph methodsFor: 'commands and slots' stamp: 'yo 3/7/2005 12:20'!
useLogDisplay: aBoolean

	displayType _ aBoolean ifTrue: [#logScale] ifFalse: [#linear].
	self formChanged.
! !


!KedamaPatchMorph methodsFor: 'private' stamp: 'yo 3/7/2005 12:19'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	varDict at: 'useLogDisplay' ifPresent: [ :x | 
		displayType _ x ifTrue: [#logScale] ifFalse: [#linear].
	].
	displayType ifNil: [displayType _ #logScale].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !


!KedamaPatchMorph methodsFor: 'drawing' stamp: 'yo 8/18/2005 11:42'!
displayPatchVariableOn: aForm

	| patchVar pixelValue |
	form ifNil: [^self].

	formChanged ifTrue: [
		"displayForm fillColor: Color transparent."
		pixelValue _ (self color pixelValueForDepth: 32) bitAnd: 16rFFFFFF.
		form bits class == ByteArray ifTrue: [form unhibernate].
		patchVar _ form bits.
		displayForm bits class == ByteArray ifTrue: [displayForm unhibernate].
		displayType = #linear ifTrue: [
			self primMakeMaskOf: patchVar in: displayForm bits colorPixel: pixelValue shift: shiftAmount.
		].
		displayType = #logScale ifTrue: [
			self primMakeMaskOf: patchVar in: displayForm bits colorPixel: pixelValue max: displayMax.
		].
		displayType = #color ifTrue: [
			form displayOn: displayForm.
			displayForm fixAlpha.
		].
	].

	tmpForm fillColor: Color black.
	displayForm displayOn: tmpForm at: 0@0 rule: 24.
	aForm == tmpForm ifFalse: [
		displayForm displayOn: aForm at: 0@0 rule: 24.
	].
	formChanged _ false.

! !

!KedamaPatchMorph methodsFor: 'drawing' stamp: 'yo 3/7/2005 11:57'!
drawOn: aCanvas

	formChanged ifTrue: [
		self displayPatchVariableOn: tmpForm.
	].
	aCanvas drawImage: tmpForm at: self innerBounds origin.

	autoChanged ifTrue: [self changed].
! !

!KedamaPatchMorph methodsFor: 'drawing' stamp: 'yo 6/6/2004 23:23'!
formChanged

	formChanged _ true.
! !


!KedamaPatchMorph methodsFor: 'initialization' stamp: 'yo 3/7/2005 12:17'!
initialize

	super initialize.

	self evaporationRate: 6.
	self diffusionRate: 1.
	self sniffRange: 1.

	displayType _ #logScale.
	displayMax _ WordArray with: 1024.
	shiftAmount _ -2.

	autoChanged _ true.

	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'initialization' stamp: 'yo 2/2/2005 17:37'!
initializeForm: aForm 

	form _ aForm. 
	form fillColor: Color transparent.

	displayForm _ (Form extent: aForm extent depth: 32).
	tmpForm _ (Form extent: aForm extent depth: 32).
	tmpForm fillColor: Color black.

	super extent: form extent.
	self changed.
	self formChanged.
! !

!KedamaPatchMorph methodsFor: 'initialization' stamp: 'yo 2/2/2005 17:46'!
newExtent: aPoint

	self initializeForm: (Form extent: aPoint depth: 32).
! !

!KedamaPatchMorph methodsFor: 'initialization' stamp: 'yo 6/10/2004 13:41'!
startUp

	form unhibernate.
	displayForm unhibernate.
	tmpForm unhibernate.
! !


!KedamaPatchMorph methodsFor: 'primitives' stamp: 'yo 6/3/2004 20:45'!
primDiffuseFrom: srcBitmap to: dstBitmap width: width height: height delta: delta 
	"Diffuse the integer values of the source patch variable Bitmap into the output Bitmap. Each cell of the output is the average of the NxN area around it in the source, where N = (2 * delta) + 1."

	| area startY endY startX endX sum rowStart |
	<primitive: 'primitiveDiffuseFromToWidthHeightDelta' module: 'StarSqueakPlugin'>
	area := (2 * delta + 1) * (2 * delta + 1).
	1 to: height
		do: 
			[:y | 
			startY := y - delta.
			startY := startY max: 1.
			endY := y + delta.
			endY := endY min: height.
			1 to: width
				do: 
					[:x | 
					startX := x - delta.
					startX := startX max: 1.
					endX := x + delta.
					endX := endX min: width.
					sum := 0.
					startY to: endY
						do: 
							[:y2 | 
							rowStart := (y2 - 1) * width.
							startX to: endX do: [:x2 | sum := sum + (srcBitmap at: rowStart + x2)]].
					dstBitmap at: (y - 1) * width + x put: sum // area]]! !

!KedamaPatchMorph methodsFor: 'primitives' stamp: 'yo 6/3/2004 20:50'!
primEvaporate: aBitmap rate: rate
	"Evaporate the integer values of the source Bitmap at the given rate, an integer between 0 and 1024, where 1024 is a scale factor of 1.0 (i.e., no evaporation). That is, replace each integer element v with (rate * v) / 1024."

	<primitive: 'primitiveEvaporateRate' module: 'StarSqueakPlugin'>
	1 to: aBitmap size do: [:i |
		aBitmap at: i put: (((aBitmap at: i) * rate) bitShift: -10)].
! !

!KedamaPatchMorph methodsFor: 'primitives' stamp: 'yo 6/26/2004 20:07'!
primMakeMaskOf: dataBits in: maskBits colorPixel: pixel max: max

	| highMask alpha maxLog data |
	<primitive: 'makeMaskLog' module: 'KedamaPlugin'>
	"^ KedamaSqueakPlugin doPrimitive: #makeMaskLog."


	highMask _ 16rFF000000.
	"maxLog _ self cCode: 'log(max)' inSmalltalk: [max first ln]."
	maxLog _ max first ln.
	maxLog _ 255.0 / maxLog.

	1 to: dataBits size do: [:i |
		data _ dataBits at: i.
		data = 0 ifTrue: [alpha _ 0] ifFalse: [
			"alpha _ ((255.0 / maxLog) * (self cCode: 'log(data)' inSmalltalk: [data ln])) asInteger."
			alpha _ (maxLog * (data ln)) asInteger.

		].
		(alpha > 255) ifTrue: [alpha _ 255].
		maskBits at: i put: (((alpha << 24) bitAnd: highMask) bitOr: pixel).
	].
	^ self.
! !

!KedamaPatchMorph methodsFor: 'primitives' stamp: 'yo 6/18/2004 15:18'!
primMakeMaskOf: dataBits in: maskBits colorPixel: pixel shift: shift

	| highMask data alpha |
	<primitive: 'makeMask' module: 'KedamaPlugin'>
	"^ KedamaSqueakPlugin doPrimitive: #makeMask."

	highMask _ 16rFF000000.
	1 to: dataBits size do: [:i |
		data _ dataBits at: i.
		alpha _ data bitShift: shift.
		(alpha > 255) ifTrue: [alpha _ 255].
		maskBits at: i put: (((alpha << 24) bitAnd: highMask) bitOr: pixel).
	].

	^ self.
! !

!KedamaPatchMorph methodsFor: 'primitives' stamp: 'yo 8/19/2005 12:24'!
primPixelsAtXArray: xArray yArray: yArray bits: bits width: width height: height into: aWordArray
	| x y formIndex val |
	<primitive: 'primPixelsAtXY' module: 'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primPixelsAtXY."
	1 to: aWordArray size do: [:i |
		val _ nil.
		x _ (xArray at: i) truncated.
		y _ (yArray at: i) truncated.
		((x < 0) or: [y < 0]) ifTrue: [val _ 0].
		((x >= form width) or: [y >= form height]) ifTrue: [val _ 0].
		val ifNil: [
			formIndex _ ((y * form width) + x) + 1.
			val _ bits at: formIndex.
		].
		aWordArray at: i put: val.
	].
! !

!KedamaPatchMorph methodsFor: 'primitives' stamp: 'yo 10/25/2004 16:56'!
primSetPixelsAtXArray: xArray yArray: yArray bits: bits width: width height: height value: value

	| v |
	<primitive: 'primSetPixelsAtXY' module: 'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primSetPixelsAtXY."

	value isNumber ifTrue: [v _ value].
	1 to: xArray size do: [:i |
		value isNumber ifFalse: [
			v _ value at: i.
		].		
		self pixelAtX: (xArray at: i) y: (yArray at: i) put: v.
	].
! !

!KedamaPatchMorph methodsFor: 'primitives' stamp: 'yo 9/30/2004 10:35'!
primUpHillX: tX y: tY heading: tH bits: bits width: width height: height sniffRange: s

	<primitive: 'primUpHill' module: 'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primUpHill."
	^ nil
! !

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

KedamaPatchMorph class
	instanceVariableNames: ''!

!KedamaPatchMorph class methodsFor: 'scripting' stamp: 'yo 3/7/2005 12:22'!
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."

	^ #(

	(kedama (
		(slot evaporationRate 'evaporation rate' Number readWrite Patch getEvaporationRate Patch setEvaporationRate:)
		(slot diffusionRate 'diffusion rate' Number readWrite Patch getDiffusionRate Patch setDiffusionRate:)
		(slot sniffRange 'sniff range' Number readWrite Patch getSniffRange Patch setSniffRange:)
		(slot shiftAmount 'shift amount when log-based color conversion is not used' Number readWrite Player getDisplayShiftAmount Player setDisplayShiftAmount:)
		(slot scaleMax 'scale when log-based color conversion is used' Number readWrite Player getDisplayScaleMax Player setDisplayScaleMax:)
		"(slot useLogDisplay 'log-based color conversion' Boolean readWrite Player getUseLogDisplay Player setUseLogDisplay:)"
		(slot displayType 'how to map the value in cells to color' PatchDisplayMode readWrite Player getDisplayType Player setDisplayType:)
		(slot color 'The color of the object' Color readWrite Player getColor  Player  setColor:)

		"(slot autoUpdate 'Updating screen always' Boolean readWrite Player getAutoUpdate  Player setAutoUpdate:)"
		(command clear 'clear all patch')
		(command diffusePatchVariable 'diffuse')
		(command decayPatchVariable 'decay')

		(command redComponentInto: 'split red component into another patch' Patch)
		(command greenComponentInto: 'split green component into another patch' Patch)
		(command blueComponentInto: 'split blue component into another patch' Patch)

		(command redComponentFrom: 'merge red component from another patch' Patch)
		(command greenComponentFrom: 'merge green component from another patch' Patch)
		(command blueComponentFrom: 'merge blue component from another patch' Patch)

)))
! !

!KedamaPatchMorph class methodsFor: 'scripting' stamp: 'yo 1/20/2005 21:24'!
defaultNameStemForInstances

	^ 'patch' translated.
! !


!KedamaPatchMorph class methodsFor: 'accessing' stamp: 'yo 4/6/2005 14:17'!
classVersion

	^ 1.
! !


!KedamaPatchMorph class methodsFor: 'class initialization' stamp: 'yo 6/5/2004 23:30'!
initialize
"
	self initialize
"
	Smalltalk addToStartUpList: self.
	self startUp.
! !

!KedamaPatchMorph class methodsFor: 'class initialization' stamp: 'yo 6/10/2004 13:41'!
startUp
"
	self startUp
"
	self allInstancesDo: [:e | e startUp].
! !

!KedamaPatchMorph class methodsFor: 'class initialization' stamp: 'yo 10/11/2004 18:58'!
startUp: aBoolean
"
	self startUp
"

	self startUp.
! !


!KedamaPatchMorph class methodsFor: 'instance creation' stamp: 'yo 2/2/2005 17:45'!
newExtent: aPoint

	| inst |
	inst _ self new.
	inst newExtent: aPoint.
	^ inst.
! !
TileMorph subclass: #KedamaPatchTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaPatchTile commentStamp: 'yo 6/18/2004 18:32' prior: 0!
A special Tile that represents the Patch.
!


!KedamaPatchTile methodsFor: 'initialization' stamp: 'yo 6/7/2004 13:56'!
initialize

	super initialize.
	type _ #literal.
	self extent: 16@16.
! !


!KedamaPatchTile methodsFor: 'tile protocol' stamp: 'yo 6/5/2004 16:12'!
resultType
	"Answer the result type of the argument represented by the receiver"

	^ #Patch.
! !

!KedamaPatchTile methodsFor: 'tile protocol' stamp: 'yo 6/5/2004 16:11'!
setLiteral: anObject
	"Set the receiver's literal to be anObject. No readout morph here."

	type _ #literal.
	self setLiteralInitially: anObject.
! !

!KedamaPatchTile methodsFor: 'tile protocol' stamp: 'yo 6/5/2004 16:11'!
storeCodeOn: aStream indent: tabCount
	"Write code that will reconstitute the receiver"

	aStream nextPutAll: literal uniqueNameForReference! !


!KedamaPatchTile methodsFor: 'initialization support' stamp: 'yo 6/18/2004 16:02'!
usePatch: aPatch

	| aTile displayer |
	self removeAllMorphs.
	literal _ aPatch.


	aTile _ KedamaPatchType basicNew newReadoutTile.

	displayer _ UpdatingStringMorph new
		getSelector: #externalName;
		target: aPatch;
		growable: true;
		minimumWidth: 24;
		putSelector: nil.
	displayer stepTime: 1000.
	"Note that when typeSymbol = #number, the #target: call above will have dealt with floatPrecision details"

	displayer useStringFormat.
	aTile addMorphBack: displayer.
	aTile setLiteralInitially: (aPatch perform: #externalName).
	self addMorphBack: aTile.
! !
PlayerType subclass: #KedamaPatchType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaPatchType commentStamp: 'yo 6/18/2004 18:32' prior: 0!
EToys Patch type.
!


!KedamaPatchType methodsFor: 'tile protocol' stamp: 'yo 10/13/2004 04:16'!
defaultArgumentTile
	"Answer a tile to represent the type"
	| patch ks k p |
	patch _ KedamaPatchTile new typeColor: self typeColor.
	ks _ ActiveWorld allMorphs select: [:e | e isKindOf: KedamaMorph].
	ks isEmpty ifFalse: [
		k _ ks first.
		p _ k player getPatch.
	] ifTrue: [
		k _ KedamaPatchMorph new.
		k assuredPlayer.
		p _ k player.
	].
	patch usePatch: p.
	^ patch.
! !

!KedamaPatchType methodsFor: 'tile protocol' stamp: 'yo 10/13/2004 01:53'!
defaultArgumentTileFor: aPlayer
	"Answer a tile to represent the type"
	| patch morph |
	patch _ KedamaPatchTile new typeColor: self typeColor.
	morph _ aPlayer costume renderedMorph.
	(morph isKindOf: KedamaMorph) ifTrue: [
		patch usePatch: aPlayer costume renderedMorph player getPatch.
	].
	(morph isKindOf: KedamaPatchMorph) ifTrue: [
		patch usePatch: morph player.
	].
	^ patch.
! !

!KedamaPatchType methodsFor: 'tile protocol' stamp: 'yo 6/17/2004 19:44'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ aPlayer costume renderedMorph player getPatch.
! !

!KedamaPatchType methodsFor: 'tile protocol' stamp: 'yo 6/5/2004 16:19'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(0.806 1.0 0.806)	! !

!KedamaPatchType methodsFor: 'tile protocol' stamp: 'yo 9/13/2005 21:23'!
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter

	| aTile displayer actualSetter |
	actualSetter _ setter ifNotNil:
		[(#(none nil unused) includes: setter) ifTrue: [nil] ifFalse: [setter]].

	aTile _ self newReadoutTile.

	displayer _ UpdatingStringMorph new
		getSelector: #externalName;
		target: (aTarget perform: getter) costume renderedMorph;
		growable: true;
		minimumWidth: 24;
		putSelector: nil.
	displayer stepTime: 1000.
	"Note that when typeSymbol = #number, the #target: call above will have dealt with floatPrecision details"

	self setFormatForDisplayer: displayer.
	aTile addMorphBack: displayer.
	(actualSetter notNil and: [self wantsArrowsOnTiles]) ifTrue: [aTile addArrows].	
	getter numArgs == 0 ifTrue:
		[aTile setLiteralInitially: (aTarget perform: getter)].
	displayer useStringFormat.

	^ aTile
! !


!KedamaPatchType methodsFor: 'initialization' stamp: 'yo 6/5/2004 16:18'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	self vocabularyName: #Patch.
! !
KedamaExamplerPlayer subclass: #KedamaSequenceExecutionStub
	instanceVariableNames: 'who index arrays exampler'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/23/2004 18:51'!
basicGetAngleTo: player

	| ret i |
	i _ self index.
	ret _ ((player getX - ((turtles arrays at: 2) at: i))@(player getY - ((turtles arrays at: 3) at: i))) theta radiansToDegrees + 90.0.
	ret > 360.0 ifTrue: [^ ret - 360.0].
	^ ret.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/23/2004 18:07'!
basicGetDistanceTo: aPlayer

	| i |
	i _ self index.
	^ ((aPlayer getX - ((turtles arrays at: 2) at: i)) squared + (aPlayer getY - ((turtles arrays at: 3) at: i)) squared) sqrt.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/28/2004 18:40'!
bounceOnColor: aPlayer

	^ false.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/23/2004 23:47'!
bounceOn: aPlayer

	| aTurtle xy |
	aPlayer = exampler ifTrue: [^ false].
	xy _ self getXAndY.
	aTurtle _ aPlayer turtles aTurtleAtX: xy x y: xy y.
	aTurtle ifNil: [^ false].
	self doBounceOn: aTurtle of: aPlayer.
	^ true.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/23/2004 23:48'!
bounceOn: aPlayer color: c

	| aTurtle xy |
	aPlayer = exampler ifTrue: [^ false].
	xy _ self getXAndY.
	aTurtle _ aPlayer turtles aTurtleAtX: xy x y: xy y.
	aTurtle ifNil: [^ false].
	((aPlayer turtles arrays at: 5) at: aTurtle index) = c ifFalse: [^ false].
	self doBounceOn: aTurtle of: aPlayer.
	^ true.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 4/5/2005 11:04'!
colorFromPatch: aPatch

	| i |
	i _ self index.
	(turtles arrays at: 5) at: i put: ((aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i)) bitAnd: 16rFFFFFF).
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/12/2004 22:01'!
colorToPatch: aPatch

	| i |
	i _ self index.
	aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: ((turtles arrays at: 5) at: i).
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:33'!
color: cPixel

	(turtles arrays at: 5) at: self index put: cPixel.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 4/4/2005 17:43'!
die

	kedamaWorld deleteTurtleID: self getWho of: exampler.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/23/2004 23:48'!
doBounceOn: aTurtle of: aPlayer

	| bounceDir myHeading neg newHeading xy |
	aPlayer = exampler ifTrue: [^ false].
	bounceDir _ aTurtle getHeading.
	myHeading _ self getHeading.
	neg _ (myHeading + 180.0) \\ 360.0.

	newHeading _ (bounceDir - neg + bounceDir).
	self setHeading: newHeading.
	[xy _ self getXAndY. (aPlayer turtles aTurtleAtX: xy x y: xy y) ~= nil] whileTrue: [
		self forward: 0.5.
	].
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:35'!
forward: v

	^ self primForwardAt: self index xArray: (turtles arrays at: 2) yArray: (turtles arrays at: 3) headingArray: (turtles arrays at: 4) value: v asFloat destWidth: kedamaWorld wrapX destHeight: kedamaWorld wrapY leftEdgeMode: kedamaWorld leftEdgeModeMnemonic rightEdgeMode: kedamaWorld rightEdgeModeMnemonic topEdgeMode: kedamaWorld topEdgeModeMnemonic bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/23/2004 23:49'!
getAngleTo: aPlayer

	| i xy |
	i _ self index.
	xy _ aPlayer getXAndY.
	^ self primGetAngleToX: xy x toY: xy y fromX: ((turtles arrays at: 2) at: i) fromY: ((turtles arrays at: 3) at: i).
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/12/2004 15:24'!
getBlueComponentIn: aPatch

	| i pix |
	i _ self index.
	pix _ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
	^ pix bitAnd: 16rFF.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:33'!
getColor

	^ Color colorFromPixelValue: ((turtles arrays at: 5) at: self index) depth: 32.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 4/5/2005 11:07'!
getColorOpaque

	^ Color colorFromPixelValue: (((turtles arrays at: 5) at: self index) bitOr: 16rFF000000) depth: 32.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/23/2004 23:49'!
getDistanceTo: aPlayer

	| i xy |
	i _ self index.
	xy _ aPlayer getXAndY.
	^ self primGetDistanceToX: xy x toY: xy y fromX: ((turtles arrays at: 2) at: i) fromY: ((turtles arrays at: 3) at: i).
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/12/2004 15:24'!
getGreenComponentIn: aPatch

	| i pix |
	i _ self index.
	pix _ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
	^ (pix bitShift: -8) bitAnd: 16rFF.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/29/2004 15:11'!
getGrouped

	^ exampler getGrouped.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/11/2004 12:46'!
getHeading

	^ self primGetHeadingAt: self index headingArray: (turtles arrays at: 4).
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/29/2004 09:04'!
getNormal

	| headingRadians degrees |
	headingRadians _ (turtles arrays at: 7) at: self index.
	degrees _ 90.0 - headingRadians radiansToDegrees.
	^ degrees >= 0.0 ifTrue: [degrees] ifFalse: [degrees + 360.0].
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 18:16'!
getPatchValueIn: aPatch

	| i |
	i _ self index.
	^ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/12/2004 15:24'!
getRedComponentIn: aPatch

	| i pix |
	i _ self index.
	pix _ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
	^ (pix bitShift: -16) bitAnd: 16rFF.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:35'!
getReplicated

	| proto newWho n |
	proto _ (1 to: turtles arrays size) collect: [:i | (turtles arrays at: i) at: self index].
	kedamaWorld makeReplicatedTurtles: 1 examplerPlayer: exampler color: nil ofPrototype: proto randomize: false.
	exampler costume renderedMorph privateTurtleCount: (kedamaWorld turtlesCountOf: exampler).
	newWho _ (kedamaWorld lastWhoOf: exampler).
	n _ self clone.
	n who: newWho.
	^ n.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/23/2004 23:50'!
getTurtleAt: aPlayer

	| ret xy |
	xy _ aPlayer getXAndY.
	ret _ exampler turtles aTurtleAtX: xy x y: xy y.
	^ ret ifNil: [self].
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 3/7/2005 11:33'!
getTurtleOf: aBreedPlayer

	| ret xy |
	xy _ self getXAndY.
	ret _ aBreedPlayer turtles aTurtleAtX: xy x y: xy y.
	^ ret ifNil: [self].
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 3/7/2005 07:30'!
getTurtleVisible

	^ ((turtles arrays at: 6) at: self index) = 1.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/30/2004 11:42'!
getUphillIn: aPatch

	| i p |
	i _ self index.
	p _ aPatch costume renderedMorph.
	^ p
			uphillForTurtleX: ((turtles arrays at: 2) at: i)
			turtleY: ((turtles arrays at: 3) at: i)
			turtleHeading: ((turtles arrays at: 4) at: i).
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:33'!
getWho

	^ (turtles arrays at: 1) at: self index.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:34'!
getX

	^ (turtles arrays at: 2) at: self index.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:32'!
getY

	^ (turtles arrays at: 3) at: self index.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:35'!
hide

	(turtles arrays at: 6) at: self index put: 0.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/13/2004 06:42'!
setBlueComponentIn: aPatch to: value

	| i pix |
	i _ self index.
	pix _ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
	pix _ (pix bitAnd: 16rFFFF00) bitOr: ((value asInteger bitAnd: 16rFF) bitShift: 16).
	aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: pix.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 4/5/2005 10:59'!
setColor: aColor

	(turtles arrays at: 5) at: self index put: ((aColor pixelValueForDepth: 32) bitAnd: 16rFFFFFF).
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/13/2004 06:42'!
setGreenComponentIn: aPatch to: value

	| i pix |
	i _ self index.
	pix _ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
	pix _ (pix bitAnd: 16rFF00FF) bitOr: ((value asInteger bitAnd: 16rFF) bitShift: 8).
	aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: pix.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/11/2004 14:12'!
setHeading: degrees

	^ self primSetHeadingAt: self index headingArray: (turtles arrays at: 4) value: degrees asFloat.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/29/2004 09:05'!
setNormal: degrees

	| headingRadians |
	headingRadians _ ((90.0 - degrees) \\ 360.0) degreesToRadians.

	(turtles arrays at: 7) at: self index put: headingRadians.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 18:19'!
setPatchValueIn: aPatch to: value

	| i |
	i _ self index.
	aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: value.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 10/13/2004 06:42'!
setRedComponentIn: aPatch to: value

	| i pix |
	i _ self index.
	pix _ aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i).
	pix _ (pix bitAnd: 16rFFFF) bitOr: ((value asInteger bitAnd: 16rFF) bitShift: 16).
	aPatch costume renderedMorph pixelAtX: ((turtles arrays at: 2) at: i) y: ((turtles arrays at: 3) at: i) put: pix.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 3/7/2005 07:32'!
setTurtleVisible: aBoolean

	^ (turtles arrays at: 6) at: self index put: (aBoolean ifTrue: [1] ifFalse: [0])
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:33'!
setX: val

	^ self primSetX: (turtles arrays at: 2) xIndex: self index headingArray: (turtles arrays at: 4) value: val asFloat destWidth: kedamaWorld wrapX leftEdgeMode: kedamaWorld leftEdgeModeMnemonic rightEdgeMode: kedamaWorld rightEdgeModeMnemonic.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:33'!
setY: val

	^ self primSetY: (turtles arrays at: 3) yIndex: self index headingArray: (turtles arrays at: 4) value: val asFloat destHeight: kedamaWorld wrapY topEdgeMode: kedamaWorld topEdgeModeMnemonic bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/27/2004 16:34'!
show

	(turtles arrays at: 6) at: self index put: 1.
! !

!KedamaSequenceExecutionStub methodsFor: 'player commands' stamp: 'yo 9/16/2004 23:16'!
turn: degrees
	"Turn by the given number of degrees."

	self setHeading: (self getHeading + degrees).
! !


!KedamaSequenceExecutionStub methodsFor: 'method management' stamp: 'yo 9/29/2004 09:02'!
compileAllAccessors

	turtles info keys asArray do: [:k |
		(#(who x y heading color visible normal) includes: k) ifFalse: [
			self compileScalarInstVarAccessorsFor: k.
		].
	].
! !

!KedamaSequenceExecutionStub methodsFor: 'method management' stamp: 'yo 9/30/2004 13:13'!
compileScalarInstVarAccessorsFor: varName

	| nameString type setPhrase arrayIndex getPhrase |
	nameString _ varName asString capitalized.
	arrayIndex _ turtles info at: varName asSymbol.

	type _ turtles types at: arrayIndex.
	type = #Number ifTrue: [
		setPhrase _ 'setNumberVarAt:'.
		getPhrase _ 'getNumberVarOf:'.
	].
	type = #Boolean ifTrue: [
		setPhrase _ 'setBooleanVarAt:'.
		getPhrase _ 'getBooleanVarOf:'
	].
	type = #Color ifTrue: [
		setPhrase _ 'setColorVarAt:'.
		getPhrase _ 'getColorVarOf:'
	].
	setPhrase ifNil: [setPhrase _ 'setObjectVarAt:'].
	getPhrase ifNil: [getPhrase _ 'getObjectVarOf:'].

	self class compileSilently: ('get', nameString, '
	^ self ', getPhrase, '((turtles arrays at: ', arrayIndex printString, ') at: self index)')
		classified: 'access'.

	self class compileSilently: ('set', nameString, ': xxxArg
		self ', setPhrase, arrayIndex printString, ' at: self index put: xxxArg' )
		classified: 'access'! !


!KedamaSequenceExecutionStub methodsFor: 'deleting' stamp: 'yo 10/8/2004 11:03'!
delete

	| anInstance |
	arrays _ nil.
	exampler _ nil.
	self class removeFromSystem: false.
	anInstance := UnscriptedPlayer new.
	self become: anInstance.
! !


!KedamaSequenceExecutionStub methodsFor: 'command execution' stamp: 'yo 9/30/2004 14:28'!
doCommand: aBlock

	^ aBlock value: self.
! !

!KedamaSequenceExecutionStub methodsFor: 'command execution' stamp: 'yo 9/29/2004 09:02'!
doDieCommand: aBlock

	| ret |
	ret _ self doExamplerCommand: aBlock.
	sequentialStub index: index.
	aBlock value: sequentialStub.

	^ ret.

! !

!KedamaSequenceExecutionStub methodsFor: 'command execution' stamp: 'yo 9/17/2004 09:25'!
doExamplerCommand: aBlock
! !

!KedamaSequenceExecutionStub methodsFor: 'command execution' stamp: 'yo 9/30/2004 14:29'!
doSequentialCommand: aBlock

	^ aBlock value: self.
! !


!KedamaSequenceExecutionStub methodsFor: 'player protocol' stamp: 'yo 9/17/2004 17:15'!
examplerPlayer: e

	exampler _ e.
! !

!KedamaSequenceExecutionStub methodsFor: 'player protocol' stamp: 'yo 4/4/2005 08:09'!
getTurtleCount

	^ exampler getTurtleCount.
! !

!KedamaSequenceExecutionStub methodsFor: 'player protocol' stamp: 'yo 9/24/2004 10:03'!
noteRenameOf: oldSlotName to: newSlotName inPlayer: aPlayer

	self compileAllAccessors
! !

!KedamaSequenceExecutionStub methodsFor: 'player protocol' stamp: 'yo 9/24/2004 09:47'!
setScalarSlotTypeFor: slotName typeChosen: typeChosen

	self compileAllAccessors.
! !

!KedamaSequenceExecutionStub methodsFor: 'player protocol' stamp: 'yo 4/4/2005 20:12'!
setTurtleCount: aNumber

	^ exampler setTurtleCount: aNumber.
! !


!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 9/24/2004 10:25'!
getBooleanVarOf: val

	^ val ~= 0.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 9/24/2004 10:25'!
getColorVarOf: val

	^ Color colorFromPixelValue: val depth: 32.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 9/24/2004 10:25'!
getNumberVarOf: val

	^ val.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 9/28/2004 11:25'!
getObjectVarOf: var

	^ var.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 10/23/2004 23:44'!
getXAndY

	| i |
	i _ self index.
	^ ((turtles arrays at: 2) at: i)@((turtles arrays at: 3) at: i).
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 4/2/2005 17:41'!
noteDecimalPlaces: aNumber forGetter: aGetter
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 9/27/2004 16:35'!
setBooleanVarAt: arrayIndex at: i put: v

	(turtles arrays at: arrayIndex) at: i put: ((v == true or: [v isNumber and: [v ~= 0]]) ifTrue: [1] ifFalse: [0]).
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 9/27/2004 16:34'!
setColorVarAt: arrayIndex at: i put: v

	| val |
	val _ v isColor ifTrue: [v pixelValueForDepth: 32] ifFalse: [v].
	(turtles arrays at: arrayIndex) at: i put: val.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 9/27/2004 16:32'!
setNumberVarAt: arrayIndex at: i put: v

	(turtles arrays at: arrayIndex) at: i put: v.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing - private' stamp: 'yo 9/27/2004 16:32'!
setObjectVarAt: arrayIndex at: i put: v

	(turtles arrays at: arrayIndex) at: i put: v.
! !


!KedamaSequenceExecutionStub methodsFor: 'accessing' stamp: 'yo 9/27/2004 16:32'!
index

	who ifNil: [^ index].
	^ turtles indexOf: who.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing' stamp: 'yo 9/16/2004 10:41'!
index: i

	index _ i.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing' stamp: 'yo 9/28/2004 11:15'!
turtles: t

	turtles _ t.
! !

!KedamaSequenceExecutionStub methodsFor: 'accessing' stamp: 'yo 9/18/2004 15:34'!
who: w

	who _ w.
	index _ nil.
! !


!KedamaSequenceExecutionStub methodsFor: 'testing' stamp: 'yo 9/24/2004 06:08'!
isSequentialStub

	^ true.
! !


!KedamaSequenceExecutionStub methodsFor: 'primitives' stamp: 'yo 10/10/2004 09:14'!
primForwardAt: i xArray: xArray yArray: yArray headingArray: headingArray value: value destWidth: destWidth destHeight: destHeight leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode

	| dist newX newY |
	<primitive: 'primScalarForward' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primScalarForward."

	dist _ value.
	newX _ (xArray at: i) + (dist asFloat * (headingArray at: i) cos).
	newY _ (yArray at: i) - (dist asFloat * (headingArray at: i) sin).
	KedamaMorph scalarXAt: i xArray: xArray headingArray: headingArray value: newX destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode.
	KedamaMorph scalarYAt: i yArray: yArray headingArray: headingArray value: newY destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode.
! !

!KedamaSequenceExecutionStub methodsFor: 'primitives' stamp: 'yo 10/23/2004 18:55'!
primGetAngleToX: toX toY: toY fromX: fromX fromY: fromY

	| ret |
	<primitive: 'scalarGetAngleTo' module:'KedamaPlugin'>
	ret _ ((toX - fromX)@(toY - fromY)) theta radiansToDegrees + 90.0.
	ret > 360.0 ifTrue: [^ ret - 360.0].
	^ ret.
! !

!KedamaSequenceExecutionStub methodsFor: 'primitives' stamp: 'yo 10/22/2004 15:36'!
primGetDistanceToX: toX toY: toY fromX: fromX fromY: fromY

	<primitive: 'scalarGetDistanceTo' module:'KedamaPlugin'>
	^ ((fromX - toX) squared + (fromY - toY)) squared sqrt.
! !

!KedamaSequenceExecutionStub methodsFor: 'primitives' stamp: 'yo 10/11/2004 14:33'!
primGetHeadingAt: i headingArray: headingArray

	| heading |
	<primitive: 'getScalarHeading' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #getScalarHeading."

	heading _ headingArray at: i.
	^ heading _ KedamaMorph radiansToDegrees: heading.
! !

!KedamaSequenceExecutionStub methodsFor: 'primitives' stamp: 'yo 10/11/2004 14:07'!
primSetHeadingAt: i headingArray: headingArray value: heading

	| rad |
	<primitive: 'setScalarHeading' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #setScalarHeading."

	rad _ KedamaMorph degreesToRadians: heading.
	headingArray at: index put: rad.
! !

!KedamaSequenceExecutionStub methodsFor: 'primitives' stamp: 'yo 10/11/2004 11:15'!
primSetX: xArray xIndex: xIndex headingArray: headingArray value: value destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode

	<primitive: 'turtleScalarSetX' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #turtleScalarSetX."
	KedamaMorph scalarXAt: xIndex xArray: xArray headingArray: headingArray value: value destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode.
! !

!KedamaSequenceExecutionStub methodsFor: 'primitives' stamp: 'yo 10/11/2004 11:16'!
primSetY: yArray yIndex: yIndex headingArray: headingArray value: value destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode

	<primitive: 'turtleScalarSetY' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #turtleScalarSetY."
	KedamaMorph scalarYAt: yIndex yArray: yArray headingArray: headingArray value: value destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode.
! !


!KedamaSequenceExecutionStub methodsFor: 'printing' stamp: 'yo 3/31/2005 14:12'!
printOn: aStream

	aStream nextPutAll: 'KedamaExecutionStub for ('.
	super printOn: aStream.
	aStream nextPut: $).
! !

!KedamaSequenceExecutionStub methodsFor: 'printing' stamp: 'yo 4/4/2005 16:14'!
storeCodeOn: aStream indent: indent

	aStream nextPutAll: '(('.
	aStream nextPutAll: exampler uniqueNameForReference.
	aStream nextPutAll: ') clonedSequentialStub who: '.
	aStream nextPutAll: who printString.
	aStream nextPutAll: ')'.
! !
AssignmentTileMorph subclass: #KedamaSetColorComponentTile
	instanceVariableNames: 'patchTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaSetColorComponentTile commentStamp: '<historical>' prior: 0!
I provide the red, green or blue component setter tile.
!


!KedamaSetColorComponentTile methodsFor: 'initalization support' stamp: 'yo 1/30/2005 11:20'!
addPatchTile

	| m1 desiredW m2 label |
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: (operatorOrExpression asString upTo: $:) translated font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Patch.
	m1 addMorph: m2.

	desiredW _ m1 width + 6.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).

	self addMorphBack: m1.
	self addMorphFront: label.
	patchTile _ m1.
! !

!KedamaSetColorComponentTile methodsFor: 'initalization support' stamp: 'yo 10/12/2004 22:38'!
componentName: aSymbol

	aSymbol = #blue ifTrue: [
		operatorOrExpression _ #setBlueComponentIn:to:.
	].
	aSymbol = #green ifTrue: [
		operatorOrExpression _ #setGreenComponentIn:to:.
	].
	aSymbol = #red ifTrue: [
		operatorOrExpression _ #setRedComponentIn:to:.
	].
	self addPatchTile.

! !

!KedamaSetColorComponentTile methodsFor: 'initalization support' stamp: 'yo 10/12/2004 22:39'!
setPatchDefaultTo: aPlayer

	patchTile submorphs first setToReferTo: aPlayer.
! !

!KedamaSetColorComponentTile methodsFor: 'initalization support' stamp: 'yo 10/12/2004 22:40'!
updateLiteralLabel
	self computeOperatorOrExpression.
	"super basicUpdateLiteralLabel"
! !


!KedamaSetColorComponentTile methodsFor: 'initialization' stamp: 'yo 10/12/2004 22:36'!
initialize

	super initialize.
	type _ #Patch.
	operatorOrExpression _ #setBlueComponentIn:to:.
	self addPatchTile.
	self line1: 'setBlueComponent:'.
! !

!KedamaSetColorComponentTile methodsFor: 'initialization' stamp: 'yo 1/30/2005 11:20'!
line1: line1

	| chopped label label2 tail headIndex |
	(line1 select: [:e | e = $:]) size >= 2 ifTrue: [^ self].
	self removeAllMorphs.
	headIndex _ line1 indexOf: $: ifAbsent: [line1 indexOf: Character space ifAbsent: [0]].

	chopped _ line1 copyFrom: 1 to: headIndex - 1.
	tail _ line1 copyFrom: chopped size + 2 to: line1 size.
	label _ 	StringMorph contents: (chopped) translated font: ScriptingSystem fontForTiles.
	label2 _ StringMorph contents: tail translated font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: patchTile.
	self addMorphBack: label2.
! !

!KedamaSetColorComponentTile methodsFor: 'initialization' stamp: 'yo 10/12/2004 23:33'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| firstKeyword |
	(#('redComponentIn:' 'setRedComponentIn:') includes: assignmentRoot) ifTrue: [
		firstKeyword _ 'setRedComponentIn'.
	].
	(#('greenComponentIn:' 'setGreenComponentIn:') includes: assignmentRoot) ifTrue: [
		firstKeyword _ 'setGreenComponentIn'
	].
	(#('blueComponentIn:' 'setBlueComponentIn:') includes: assignmentRoot) ifTrue: [
		firstKeyword _ 'setBlueComponentIn'
	].

	aStream nextPutAll: firstKeyword.
	aStream nextPut: $:.
			aStream space."Simple assignment, don't need existing value"
	patchTile submorphs first storeCodeOn: aStream indent: tabCount.
	aStream nextPutAll: ' to: '.

	assignmentSuffix = ':' 
		ifFalse: 
			["Assignments that require that old values be retrieved"

			aStream nextPutAll: '( '.
			self assignmentReceiverTile storeCodeOn: aStream indent: tabCount.
			aStream space.
			aStream nextPutAll: 'getPatchValueIn:'.
			patchTile submorphs first storeCodeOn: aStream indent: tabCount.
			aStream nextPutAll: ')'.
			aStream space.
			aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix).
			aStream space]! !


!KedamaSetColorComponentTile methodsFor: 'tile protocol' stamp: 'yo 10/12/2004 22:39'!
setAssignmentSuffix: aString
	assignmentSuffix _ aString.
	self computeOperatorOrExpression.
	type _ #operator.
 	self addArrowsIfAppropriate; updateLiteralLabel.
! !
AssignmentTileMorph subclass: #KedamaSetPixelValueTile
	instanceVariableNames: 'patchTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaSetPixelValueTile commentStamp: 'yo 6/18/2004 18:32' prior: 0!
I provide the special tile of 'patchValueIn' setter.
!


!KedamaSetPixelValueTile methodsFor: 'initialization-support' stamp: 'yo 10/9/2004 17:59'!
addPatchTile

	| m1 desiredW m2 label |
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'setValueIn' font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Patch.
	m1 addMorph: m2.

	desiredW _ m1 width + 6.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).

	self addMorphBack: m1.
	self addMorphFront: label.
	patchTile _ m1.
! !

!KedamaSetPixelValueTile methodsFor: 'initialization-support' stamp: 'yo 6/7/2004 20:19'!
setPatchDefaultTo: aPlayer

	patchTile submorphs first setToReferTo: aPlayer.
! !


!KedamaSetPixelValueTile methodsFor: 'initialization' stamp: 'yo 10/8/2004 09:25'!
initialize

	super initialize.
	type _ #Patch.
	operatorOrExpression _ #setPatchValueIn:to:.
	self addPatchTile.
	self line1: 'setPatchValue:'.
! !


!KedamaSetPixelValueTile methodsFor: 'tile protocol' stamp: 'yo 10/8/2004 09:28'!
line1: line1

	| chopped label label2 tail headIndex |
	(line1 select: [:e | e = $:]) size >= 2 ifTrue: [^ self].
	self removeAllMorphs.
	headIndex _ line1 indexOf: $: ifAbsent: [line1 indexOf: Character space ifAbsent: [0]].

	chopped _ line1 copyFrom: 1 to: headIndex - 1.
	tail _ line1 copyFrom: chopped size + 2 to: line1 size.
	label _ 	StringMorph contents: (chopped) font: ScriptingSystem fontForTiles.
	label2 _ StringMorph contents: tail font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: patchTile.
	self addMorphBack: label2.
! !

!KedamaSetPixelValueTile methodsFor: 'tile protocol' stamp: 'yo 6/7/2004 21:01'!
setAssignmentSuffix: aString
	assignmentSuffix _ aString.
	self computeOperatorOrExpression.
	type _ #operator.
 	self addArrowsIfAppropriate; updateLiteralLabel! !

!KedamaSetPixelValueTile methodsFor: 'tile protocol' stamp: 'yo 6/7/2004 21:15'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

"	| parts |

	parts := operatorOrExpression keywords.
	aStream nextPutAll: parts first.
	aStream space.
	patchTile submorphs first storeCodeOn: aStream indent: tabCount.
	aStream space.
	aStream nextPutAll: ' to: '.
"

	aStream nextPutAll: 'setPatchValueIn:'.
			aStream space."Simple assignment, don't need existing value"
	patchTile submorphs first storeCodeOn: aStream indent: tabCount.
	aStream nextPutAll: ' to: '.

	assignmentSuffix = ':' 
		ifFalse: 
			["Assignments that require that old values be retrieved"

			aStream nextPutAll: '( '.
			self assignmentReceiverTile storeCodeOn: aStream indent: tabCount.
			aStream space.
			aStream nextPutAll: 'getPatchValueIn:'.
			patchTile submorphs first storeCodeOn: aStream indent: tabCount.
			aStream nextPutAll: ')'.
			aStream space.
			aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix).
			aStream space]! !

!KedamaSetPixelValueTile methodsFor: 'tile protocol' stamp: 'yo 6/9/2004 12:56'!
updateLiteralLabel
	self computeOperatorOrExpression.
	"super basicUpdateLiteralLabel"
! !
StandardViewer subclass: #KedamaStandardViewer
	instanceVariableNames: 'stub restrictedIndex restrictedWho'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaStandardViewer methodsFor: 'categories' stamp: 'yo 4/4/2005 15:19'!
categoryViewerFor: categoryInfo 
	"Answer a category viewer for the given category info"

	| aViewer |
	aViewer := ((categoryInfo isCollection) 
				and: [categoryInfo first == #search]) 
					ifFalse: [KedamaCategoryViewer new]
					ifTrue: [KedamaWhoSearchingViewer new].
	aViewer initializeFor: scriptedPlayer categoryChoice: categoryInfo.
	(aViewer isMemberOf: KedamaWhoSearchingViewer) ifTrue: [^ aViewer].
	restrictedWho = 0
		ifTrue: [aViewer replaceTargetWith: scriptedPlayer]
		ifFalse: [aViewer replaceTargetWith: stub].
	^aViewer.
! !


!KedamaStandardViewer methodsFor: 'initialization' stamp: 'yo 4/4/2005 18:14'!
initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean showCategories: categoryInfo

	stub _ aPlayer clonedSequentialStub.
	stub who: 0.
	restrictedWho _ 0.
	restrictedIndex _ 0.
	super initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean showCategories: categoryInfo.
! !


!KedamaStandardViewer methodsFor: 'turtle view' stamp: 'yo 4/4/2005 18:05'!
providePossibleRestrictedView: anInteger

	| who |
	restrictedIndex _ anInteger.
	who _ scriptedPlayer whoAt: anInteger.
	restrictedWho = who ifTrue: [^ self].
	restrictedWho _ who.
	stub who: who.
	who = 0 ifTrue: [self replaceTargetsWithExampler] ifFalse: [self replaceTargetsWithStub].
	self searchingViewerMorphs do: [:v | v updateWhoString].
! !

!KedamaStandardViewer methodsFor: 'turtle view' stamp: 'yo 4/4/2005 10:53'!
replaceTargetsWithExampler

	self submorphsDo: [:e |
		(e isMemberOf: KedamaCategoryViewer) ifTrue: [
			e replaceTargetWith: scriptedPlayer.
		].
	].
! !

!KedamaStandardViewer methodsFor: 'turtle view' stamp: 'yo 4/3/2005 17:25'!
replaceTargetsWithStub

	self submorphsDo: [:e |
		(e isMemberOf: KedamaCategoryViewer) ifTrue: [
			e replaceTargetWith: stub.
		].
	].
! !

!KedamaStandardViewer methodsFor: 'turtle view' stamp: 'yo 4/4/2005 17:48'!
resetWhoIfNecessary

	restrictedWho <= 0 ifTrue: [^ self].
	self providePossibleRestrictedView: 0.
! !

!KedamaStandardViewer methodsFor: 'turtle view' stamp: 'yo 4/4/2005 18:15'!
restrictedIndex

	^ restrictedIndex.
! !

!KedamaStandardViewer methodsFor: 'turtle view' stamp: 'yo 4/4/2005 18:01'!
restrictedWho

	^ restrictedWho.
! !

!KedamaStandardViewer methodsFor: 'turtle view' stamp: 'yo 4/4/2005 18:00'!
searchingViewerMorphs

	^ self submorphsSatisfying: [:m | m isKindOf: KedamaWhoSearchingViewer].! !
TileMorph subclass: #KedamaTurtleAtTile
	instanceVariableNames: 'turtleTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaTurtleAtTile methodsFor: 'initialization-support' stamp: 'yo 10/11/2004 15:49'!
addTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'turtle at' font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Player.
	m1 addMorph: m2.
	desiredW _ m1 width.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	self addMorphBack: m1.
	self addMorphFront: label.
	turtleTile _ m1.
! !

!KedamaTurtleAtTile methodsFor: 'initialization-support' stamp: 'yo 10/9/2004 10:35'!
setTurtleDefaultTo: aPlayer

	turtleTile submorphs first setToReferTo: aPlayer.
! !


!KedamaTurtleAtTile methodsFor: 'initialization' stamp: 'yo 10/9/2004 10:35'!
initialize

	super initialize.
	type _ #Player.
	operatorOrExpression _ #getTurtleAt:.
	self addTile.
! !


!KedamaTurtleAtTile methodsFor: 'tile protocol' stamp: 'yo 10/9/2004 10:35'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: 'turtleAt' font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: turtleTile.
! !

!KedamaTurtleAtTile methodsFor: 'tile protocol' stamp: 'yo 10/9/2004 15:37'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"turtleAt:"
	aStream nextPutAll: parts first.
	aStream space.
	turtleTile storeCodeOn: aStream indent: tabCount.
! !
Morph subclass: #KedamaTurtleMorph
	instanceVariableNames: 'kedamaWorld turtleCount isGroup'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaTurtleMorph commentStamp: 'yo 6/18/2004 18:33' prior: 0!
The exampler of turtles.
!


!KedamaTurtleMorph methodsFor: 'viewer access' stamp: 'yo 9/29/2004 15:13'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Include our modest command set in the ctrl-menu"

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self player ifNotNil: [
		aCustomMenu addLine.
		aCustomMenu add: 'copy methods' target: self player action: #copyAllMethodsAgain.
	].
! !

!KedamaTurtleMorph methodsFor: 'viewer access' stamp: 'yo 6/11/2004 11:18'!
categoriesForViewer
	"Answer a list of symbols representing the categories to offer in the viewer, in order"
	"^ super categoriesForViewer."

	| aList |
	aList _ OrderedCollection new.
	aList addAllFirstUnlessAlreadyPresent: (self class additionsToViewerCategories collect:
				[:categorySpec | categorySpec first]).
	^ aList
! !


!KedamaTurtleMorph methodsFor: 'initialization' stamp: 'yo 6/9/2004 12:51'!
cleanUp

	self player: nil.
	self actorState: nil.
! !

!KedamaTurtleMorph methodsFor: 'initialization' stamp: 'yo 10/8/2004 10:50'!
delete

	super delete.
	kedamaWorld deleteAllTurtlesOfExampler: self player.
	self player delete.
! !

!KedamaTurtleMorph methodsFor: 'initialization' stamp: 'ar 7/8/2006 20:26'!
initialize

	super initialize.
	turtleCount _ 1.
	self assuredPlayer assureUniClass.
	self extent: 40@40.

	isGroup _ false.
	self color: self saturatedRandomColor.

! !

!KedamaTurtleMorph methodsFor: 'initialization' stamp: 'yo 9/23/2004 18:38'!
install

	| t |
	self player kedamaWorld: kedamaWorld.
	t _ self player createTurtles.
	kedamaWorld makeTurtles: turtleCount examplerPlayer: self player color: ((self color pixelValueForDepth: 32) bitAnd: 16rFFFFFF) ofPrototype: nil turtles: t randomize: true.
	self player createSequenceStub.
! !

!KedamaTurtleMorph methodsFor: 'initialization' stamp: 'yo 9/17/2004 08:09'!
newPlayerInstance

	^ (KedamaExamplerPlayer newUserInstance).! !

!KedamaTurtleMorph methodsFor: 'initialization' stamp: 'ar 7/8/2006 20:26'!
saturatedRandomColor
	"Return a random color that isn't too dark or under-saturated."

	^ Color basicNew
		setHue: (360 atRandom)
		saturation: 1.0
		brightness: 1.0.
! !


!KedamaTurtleMorph methodsFor: 'group turtle creation' stamp: 'yo 10/11/2004 16:00'!
createTurtlesAsIn: aForm originAt: origin

	| c xArray yArray colorArray newX newY |
	xArray _ OrderedCollection new: aForm width * aForm height.
	yArray _ OrderedCollection new: aForm width * aForm height.
	colorArray _ OrderedCollection new: aForm width * aForm height.
	0 to: aForm height do: [:y |
		0 to: aForm width do: [:x |
			c _ aForm colorAt: (x@y).
			c isTransparent ifFalse: [
				newX _ x + origin x.
				newY _ y + origin y.
				((newX >= 0 and: [newX < kedamaWorld dimensions x]) and: [newY >= 0 and: [newY < kedamaWorld dimensions y]]) ifTrue: [
					xArray add: newX.
					yArray add: newY.
					colorArray add: (c pixelValueForDepth: 32).
				].
			].
		].
	].
	kedamaWorld makeTurtlesAtPositionsIn: {xArray asArray. yArray asArray. colorArray asArray} examplerPlayer: self player ofPrototype: nil.
	self privateTurtleCount: (kedamaWorld turtlesCountOf: self player).
! !


!KedamaTurtleMorph methodsFor: 'accessing' stamp: 'yo 9/14/2004 15:46'!
isGroup

	^ isGroup.
! !

!KedamaTurtleMorph methodsFor: 'accessing' stamp: 'yo 9/14/2004 15:46'!
isGroup: aBoolean

	isGroup _ aBoolean.
! !

!KedamaTurtleMorph methodsFor: 'accessing' stamp: 'yo 9/16/2004 18:49'!
kedamaWorld

	^ kedamaWorld.
! !

!KedamaTurtleMorph methodsFor: 'accessing' stamp: 'yo 9/16/2004 18:49'!
kedamaWorld: k

	kedamaWorld _ k.
! !

!KedamaTurtleMorph methodsFor: 'accessing' stamp: 'yo 6/5/2004 19:38'!
privateTurtleCount: c

	turtleCount _ c.
! !

!KedamaTurtleMorph methodsFor: 'accessing' stamp: 'yo 6/4/2004 01:18'!
turtleCount

	^ turtleCount.
! !

!KedamaTurtleMorph methodsFor: 'accessing' stamp: 'yo 4/4/2005 17:47'!
turtleCount: count

	| c |
	c _ count asInteger max: 0.
	kedamaWorld setTurtlesCount: c examplerPlayer: self player color: ((self color pixelValueForDepth: 32) bitAnd: 16rFFFFFF).
	turtleCount _ c.
	"turtleCount <= 0 ifTrue: [self player allOpenViewers do: [:v | v providePossibleRestrictedView: 0]]."! !


!KedamaTurtleMorph methodsFor: 'menus' stamp: 'yo 8/17/2005 16:53'!
wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph
	"Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)"

	(#(addDupHandle: addMakeSiblingHandle:) includes: aSelector) ifTrue:
		[^ false].

	^ super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph! !

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

KedamaTurtleMorph class
	instanceVariableNames: ''!

!KedamaTurtleMorph class methodsFor: 'scripting' stamp: 'yo 3/7/2005 08:46'!
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."
	"self halt."
	^ #(

	('kedama turtle' (
		(command die 'delete this turtle')

		(slot upHill 'uphill of the implicit at my location' Number readOnly Player getUphillIn: unspecified unspecified)
		(slot bounceOn 'detect collision and bounce back' Boolean readOnly Player bounceOn: unspecified unspecified)
		(slot bounceOnColor 'detect collision and bounce back on a color' Boolean readOnly Player bounceOnColor: unspecified unspecified)
		(slot patchValueIn 'get the value at this position' Number readWrite Number getPatchValueIn: Number setPatchValueIn:to:)
		(slot distanceTo 'The distance to another turtle' Number readOnly Player getDistanceTo: unused unused)
		(slot angleTo 'The angle to another turtle' Number readOnly Player getAngleTo: unused unused)

		(slot getReplicated 'returns a copy of this turtle' Player readOnly Player getReplicated unused unused)
		(slot x 'The x coordinate' Number readWrite Player getX Player setX:)
		(slot y  	'The y coordinate' Number readWrite Player 	getY Player setY:)
		(slot heading 'Which direction the object is facing.  0 is straight up' Number readWrite Player getHeading Player setHeading:)
		(command forward: 'Moves the object forward in the direction it is heading' Number)
		(command turn: 'Change the heading of the object by the specified amount' Number)
			(slot color 'The color of the object' Color readWrite Player getColor  Player  setColor:)
	"		(slot headingTheta 'The angle, in degrees, that my heading vector makes with the positive x-axis' Number readWrite Player getHeadingTheta Player setHeadingTheta:)

			(slot theta 'The angle between the positive x-axis and the vector connecting the origin to the object''s position' Number readWrite Player getTheta Player setTheta: )
"
		(slot turtleVisible 'The flag that governs the visibility of turtle' Boolean readWrite Player getTurtleVisible Player setTurtleVisible:)
			"(command turtleShow 'make the object visible')
			(command turtleHide 'make the object invisible')"

		(slot turtleOf 'returns a turtle of specified breed at my position.' Player readOnly Player getTurtleOf: unused unused)
		"(slot normal 'The normal for bouncing' Number readWrite Player getNormal Player  setNormal:)"


	))
	('kedama turtle breed' (
		(slot turtleCount 'set the number of turtles' Number readWrite Number getTurtleCount Number setTurtleCount:)
		(slot grouped 'turtles bahaves as one connected objects' Boolean readWrite Boolean getGrouped Boolean setGrouped:)
	))

	('kedama turtle color' (
		(slot redComponentIn 'The red component in specified patch.' Number readWrite Player getRedComponentIn: Player setRedComponentIn:to:)
		(slot greenComponentIn 'The green component in specified patch.' Number readWrite Player getGreenComponentIn: Player setGreenComponentIn:to:)
		(slot blueComponentIn 'The blue component in specified patch.' Number readWrite Player getBlueComponentIn: Player setBlueComponentIn:to:)
		(command colorFromPatch: 'make my color specified in the patch' Patch)
		(command colorToPatch: 'store my color into the patch' Patch)
	))

)

! !

!KedamaTurtleMorph class methodsFor: 'scripting' stamp: 'yo 10/22/2004 08:12'!
copyAllMethodsAgain
"
	KedamaTurtleMorph copyAllMethodsAgain.
"
	KedamaTurtleMorph allInstancesDo: [:e | e player ifNotNil: [e player copyAllMethodsAgain]].
! !

!KedamaTurtleMorph class methodsFor: 'scripting' stamp: 'yo 1/20/2005 21:24'!
defaultNameStemForInstances

	^ 'turtle' translated.
! !


!KedamaTurtleMorph class methodsFor: 'class initialization' stamp: 'yo 6/9/2004 12:50'!
cleanUp
"
	self cleanUp
"
	self allInstancesDo: [:e | e cleanUp].
! !

!KedamaTurtleMorph class methodsFor: 'class initialization' stamp: 'yo 10/24/2004 18:58'!
useKedamaFloatArray
"
	KedamaTurtleMorph useKedamaFloatArray.
"
	KedamaTurtleMorph allInstancesDo: [:e | e player ifNotNil: [e player turtles useKedamaFloatArray]].
! !
TileMorph subclass: #KedamaTurtleOfTile
	instanceVariableNames: 'turtleTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaTurtleOfTile methodsFor: 'initalization support' stamp: 'yo 3/7/2005 08:38'!
addTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'turtle of' font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Player.
	m1 addMorph: m2.
	desiredW _ m1 width.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	self addMorphBack: m1.
	self addMorphFront: label.
	turtleTile _ m1.
! !

!KedamaTurtleOfTile methodsFor: 'initalization support' stamp: 'yo 3/7/2005 08:38'!
setTurtleDefaultTo: aPlayer

	turtleTile submorphs first setToReferTo: aPlayer.
! !


!KedamaTurtleOfTile methodsFor: 'initialization' stamp: 'yo 3/7/2005 08:36'!
initialize

	super initialize.
	type _ #Player.
	operatorOrExpression _ #getTurtleOf:.
	self addTile.
! !


!KedamaTurtleOfTile methodsFor: 'tile protocol' stamp: 'yo 3/7/2005 08:38'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: 'turtleOf' font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: turtleTile.
! !

!KedamaTurtleOfTile methodsFor: 'tile protocol' stamp: 'yo 3/7/2005 08:38'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"getTurtleOf:"
	aStream nextPutAll: parts first.
	aStream space.
	turtleTile storeCodeOn: aStream indent: tabCount.
! !
Player subclass: #KedamaTurtlePlayer
	instanceVariableNames: 'world who x y headingRadians color visible'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaTurtlePlayer commentStamp: '<historical>' prior: 0!
A defunct class that represents the turtles in the KedamaWorld.  In this version, each turtle was represented as a full-fledged player.  Kept here to remember the alternative implementation.!


!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
asPoint

	^ x truncated @ y truncated
! !

!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
isInWorld

	^ world isInWorld.
! !

!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
owner

	^ world.
! !

!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
who

	^ who
! !

!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
who: anInteger

	who _ anInteger.
! !

!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
x

	^ x
! !

!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
x: aNumber

	x _ aNumber.
! !

!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
y

	^ y
! !

!KedamaTurtlePlayer methodsFor: 'accessing' stamp: 'yo 6/2/2004 22:36'!
y: aNumber

	y _ aNumber.
! !


!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/2/2004 22:39'!
color

	^ color.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/17/2004 07:26'!
color: aColor

	color _ aColor.


! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/14/2004 19:22'!
die
	"Delete this turtle at the end of the current cycle. The turtle will finish running all demons for the current cycle before it dies."

	world deleteTurtleID: self getScalarWho of: self class.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/17/2004 09:57'!
forward: dist

	self setX: (x + (dist asFloat * headingRadians cos)).
	self setY: (y - (dist asFloat * headingRadians sin)).
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/17/2004 09:59'!
getAngleTo: aPlayer

	| ret |
	ret _ ((aPlayer x - self x)@(aPlayer y - self y)) theta radiansToDegrees + 90.0.
	ret > 360.0 ifTrue: [^ ret - 360].
	^ ret.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/14/2004 16:09'!
getDistanceTo: aPlayer

	| dist |
	dist _ ((aPlayer x - self x) squared + (aPlayer y - self y) squared) sqrt.
	^ dist.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/6/2004 01:45'!
getHeading
	"Answer my heading in degrees."

	| degrees |
	degrees _ 90.0 - headingRadians radiansToDegrees.
	^ degrees >= 0.0 ifTrue: [degrees] ifFalse: [degrees + 360.0].
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/14/2004 19:56'!
getReplicated

	| newGuys theNewGuy |
	newGuys _ world makeTurtles: 1 turtlePlayerClass: self class color: self color ofPrototype: self.
	theNewGuy _ newGuys first.
	theNewGuy x: self x.
	theNewGuy y: self y.
	theNewGuy heading: self heading.
	(world prototypeOf: self class) privateTurtleCount: (world turtlesCountOf: self class).
	^ theNewGuy
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/7/2004 18:35'!
getUphillIn: aPatch

	^ aPatch costume renderedMorph uphillForTurtle: self.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 02:19'!
getX

	^ x.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/3/2004 02:16'!
getY

	^ y.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/2/2004 22:36'!
goto: aPoint
	"Jump to the given location."

	x _ aPoint x.
	y _ aPoint y.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/2/2004 22:36'!
heading
	"Answer my heading in degrees."

	| degrees |
	degrees _ 90.0 - headingRadians radiansToDegrees.
	^ degrees >= 0.0 ifTrue: [degrees] ifFalse: [degrees + 360.0].
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/2/2004 22:36'!
heading: angleInDegrees
	"Set my heading in degrees. Like a compass, up or north is 0 degrees and right or east is 90 degrees."

	headingRadians _ ((90.0 - angleInDegrees) \\ 360.0) degreesToRadians.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/9/2004 14:45'!
hide

	visible _ false
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/14/2004 15:43'!
isGroup: aBoolean
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/2/2004 22:36'!
random: range
	"Answer a random integer between 0 and range."

	^ world random: range
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/17/2004 07:26'!
setColor: aColor

	self color: (aColor pixelValueForDepth: 32).
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/4/2004 02:15'!
setHeading: newHeading

	^ self heading: newHeading.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/9/2004 13:14'!
setTurtleCount: aNumber
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/9/2004 15:09'!
setX: val

	| leftEdgeMode rightEdgeMode |
	x _ val.
	x < 0.0 ifTrue: [
		leftEdgeMode _ world leftEdgeMode.
		leftEdgeMode == #wrap ifTrue: [
			x _ x + world wrapX.
		].
		leftEdgeMode == #stick ifTrue: [
			x _ 0.0.
		].
		leftEdgeMode == #bounce ifTrue: [
			x _ val negated.
			headingRadians < Float pi
				ifTrue: [headingRadians _ Float pi - headingRadians]
				ifFalse: [headingRadians _ Float threePi - headingRadians]
		].
	].

	x >= world wrapX ifTrue: [
		rightEdgeMode _ world rightEdgeMode.
		rightEdgeMode == #wrap ifTrue: [
			x _ x - world wrapX.
		].
		rightEdgeMode == #stick ifTrue: [
			x _ world wrapX - 0.0000001.
		].
		rightEdgeMode == #bounce ifTrue: [
			x _ world wrapX - 0.0000001 - (x - world wrapX).
			headingRadians < Float pi
				ifTrue: [headingRadians _ Float pi - headingRadians]
				ifFalse: [headingRadians _ Float threePi - headingRadians]
		].
	].
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/9/2004 15:09'!
setY: val

	| topEdgeMode bottomEdgeMode |
	y _ val.
	y < 0.0 ifTrue: [
		topEdgeMode _ world topEdgeMode.
		topEdgeMode == #wrap ifTrue: [
			y _ y + world wrapY.
		].
		topEdgeMode == #stick ifTrue: [
			y _ 0.0.
		].
		topEdgeMode == #bounce ifTrue: [
			y _ val negated.
			headingRadians _ Float twoPi - headingRadians.
		].
	].

	y >= world wrapY ifTrue: [
		bottomEdgeMode _ world bottomEdgeMode.
		bottomEdgeMode == #wrap ifTrue: [
			y _ y - world wrapY.
		].
		bottomEdgeMode == #stick ifTrue: [
			y _ world wrapY - 0.0000001.
		].
		bottomEdgeMode == #bounce ifTrue: [
			y _ world wrapY - 0.0000001 - (y - world wrapY).
			headingRadians _ Float twoPi - headingRadians.
		].
	].
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/9/2004 14:44'!
show

	visible _ true.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 7/27/2004 17:04'!
triggerScript: aSymbol
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/2/2004 22:36'!
turnLeft: degrees
	"Turn left by the given number of degrees."

	self heading: (self heading - degrees).
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/2/2004 22:36'!
turnRight: degrees
	"Turn right by the given number of degrees."

	self heading: (self heading + degrees).
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 6/2/2004 23:43'!
turn: degrees

	self turnRight: degrees.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/9/2004 14:56'!
visible

	^ visible.
! !

!KedamaTurtlePlayer methodsFor: 'commands and slots' stamp: 'yo 9/9/2004 14:44'!
visible: aBoolean

	visible _ aBoolean.
! !


!KedamaTurtlePlayer methodsFor: 'patches' stamp: 'yo 6/7/2004 17:56'!
getPatchValueIn: aPatch

	^ aPatch costume renderedMorph pixelAtX: x y: y.
! !

!KedamaTurtlePlayer methodsFor: 'patches' stamp: 'yo 6/2/2004 22:36'!
patchBrightness: percent
	"Set the brightness of the patch below this turtle to the given value, where 0 is black and 100 is full brightness."

	world setPatchBrightnessAtX: x y: y to: percent.
! !

!KedamaTurtlePlayer methodsFor: 'patches' stamp: 'yo 6/7/2004 18:37'!
setPatchValueIn: aPatch to: value

	aPatch costume renderedMorph pixelAtX: x y: y put: value.
! !


!KedamaTurtlePlayer methodsFor: 'initialization' stamp: 'yo 9/16/2004 17:41'!
initializeWorld: aStarSqueakWorld who: anInteger color: cPixel

	| dims |
	dims _ aStarSqueakWorld dimensions.
	world _ aStarSqueakWorld.
	who _ anInteger.
	x _ world random: dims x - 1.
	y _ world random: dims y - 1.
	headingRadians _ ((self random: 36000) / 100.0) degreesToRadians.
	color _ cPixel.
	self isGroup: false.
	self show.
! !
KedamaExamplerPlayer subclass: #KedamaTurtleVectorPlayer
	instanceVariableNames: 'exampler info types arrays deletingIndex whoTable whoTableBase whoTableValid turtlesMap turtleMapValid lastWho lastWhoStub'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 10/24/2004 18:45'!
addInstanceVarNamed: aName withValue: aValue

	| newArray |
	(aValue isKindOf: Number) ifTrue: [
		newArray _ KedamaFloatArray new: self size.
	].
	(aValue isKindOf: Color) ifTrue: [
		newArray _ WordArray new: self size.
	].
	(aValue isKindOf: Player) ifTrue: [
		newArray _ Array new: self size.
	].

	arrays _ arrays, newArray.
	info at: aName asSymbol put: arrays size.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 10/24/2004 18:45'!
addInstanceVarVectorNamed: aName withValue: aValue

	| newArray |
	newArray _ KedamaFloatArray new: self size.
	arrays _ arrays, (Array with: newArray).
	newArray atAllPut: aValue.
	info at: aName asSymbol put: arrays size.
	types at: arrays size put: #Number.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 9/20/2004 12:10'!
compileAllAccessors

	info keys asArray do: [:k |
		(#(who x y heading color visible) includes: k) ifFalse: [
			self compileVectorInstVarAccessorsFor: k.
		].
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 9/20/2004 12:00'!
compileVectorInstVarAccessorsFor: varName

	| nameString index type setPhrase |
	nameString _ varName asString capitalized.
	index _ info at: varName asSymbol.
	self class compileSilently: ('get', nameString, '
	^ ', '(arrays at: ', index printString, ')')
		classified: 'access'.

	type _ types at: index.
	type = #Number ifTrue: [
		setPhrase _ 'setNumberVarAt:'.
	].
	type = #Boolean ifTrue: [
		setPhrase _ 'setBooleanVarAt:'.
	].
	type = #Color ifTrue: [
		setPhrase _ 'setColorVarAt:'.
	].
	setPhrase ifNil: [setPhrase _ 'setObjectVarAt:'].

	self class compileSilently: ('set', nameString, ': xxxArg
	self ', setPhrase, index printString, ' put: xxxArg')
		classified: 'access'! !

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 9/24/2004 10:03'!
noteRenameOf: oldSlotName to: newSlotName inPlayer: aPlayer

	self compileAllAccessors
! !

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 9/20/2004 12:20'!
removeSlotNamed: aSlotName

	| index newArrays |
	self basicRemoveSlotNamed: aSlotName.
	index _ info at: aSlotName asSymbol ifAbsent: [^ self].
	newArrays _ (arrays copyFrom: 1 to: index - 1), (arrays copyFrom: index + 1 to: arrays size).
	types replaceFrom: index to: types size with: types startingAt: index + 1.

	info removeKey: aSlotName asSymbol.
	arrays _ newArrays.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 9/20/2004 16:34'!
removeVectorSlotNamed: aSlotName

	| index newArrays |
	index _ info at: aSlotName asSymbol ifAbsent: [^ self].
	newArrays _ (arrays copyFrom: 1 to: index - 1), (arrays copyFrom: index + 1 to: arrays size).
	types replaceFrom: index to: types size - 1 with: types startingAt: index + 1.

	info removeKey: aSlotName asSymbol.
	arrays _ newArrays.
	self compileAllAccessors.

! !

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 10/27/2004 16:29'!
renameVectorSlot: oldSlotName newSlotName: newSlotName

	| index |
	index _ info at: oldSlotName asSymbol ifAbsent: [^ self].
	info removeKey: oldSlotName asSymbol.
	info at: newSlotName put: index.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player protocol' stamp: 'yo 9/20/2004 17:59'!
setVectorSlotTypeFor: slotName typeChosen: typeChosen

	| index initVar |
	index _ info at: slotName asSymbol.
	index = 0 ifTrue: [^ self].

	initVar _ self initialValueForSlotOfType: typeChosen.

	types at: index put: typeChosen.

	self compileAllAccessors.
	arrays at: index put: (self arrayForType: typeChosen).
	self perform: ('set', slotName capitalized, ':') asSymbol with: initVar.
! !


!KedamaTurtleVectorPlayer methodsFor: 'add turtles' stamp: 'yo 10/30/2004 18:56'!
addTurtlesCount: count ofPrototype: prototype for: aKedamaWorld positionAndColorArray: positionAndColorArray

	| index array defaultValue newArray oldCount |
	oldCount _ self size.
	info associationsDo: [:assoc |
		index _ info at: assoc key.
		array _ arrays at: (info at: assoc key).
		defaultValue _ prototype at: index.
		newArray _ array class new: count.
		(#(who x y heading color normal) includes: assoc key) ifFalse: [
			newArray atAllPut: defaultValue.
		].
		assoc key = #x ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray first startingAt: 1].
		assoc key = #y ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray second startingAt: 1].
		assoc key = #color ifTrue: [newArray replaceFrom: 1 to: newArray size with: positionAndColorArray third startingAt: 1].
		assoc key = #heading ifTrue: [newArray atAllPut: 1.57079631 "Float pi / 2.0"].
		assoc key = #normal ifTrue: [newArray atAllPut: 1.57079631 "Float pi / 2.0"].

		arrays at: (assoc value) put: array, newArray.
	].

	#(who) do: [:name |
		self setInitialValueOf: name from: oldCount + 1 to: self size for: aKedamaWorld.
	].
	whoTableValid _ false.
	turtleMapValid _ false.

	
! !

!KedamaTurtleVectorPlayer methodsFor: 'add turtles' stamp: 'yo 9/18/2004 15:27'!
addTurtlesCount: count ofPrototype: prototype for: aKedamaWorld randomize: randomizeFlag

	| index array defaultValue newArray oldCount |
	oldCount _ self size.
	info associationsDo: [:assoc |
		index _ info at: assoc key.
		array _ arrays at: index.
		defaultValue _ prototype at: index.
		newArray _ array class new: count.
		newArray atAllPut: defaultValue.
		arrays at: index put: (array, newArray).
	].

	self setInitialValueOf: #who from: oldCount + 1 to: self size for: aKedamaWorld.

	randomizeFlag ifTrue: [
		#(x y heading) do: [:name |
			self setInitialValueOf: name from: oldCount + 1 to: self size for: aKedamaWorld.
		].
	].
	whoTableValid _ false.
! !

!KedamaTurtleVectorPlayer methodsFor: 'add turtles' stamp: 'yo 9/14/2004 18:10'!
makePrototypeFromFirstInstance

	^ (1 to: arrays size) collect: [:index |
		(arrays at: index) first
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'add turtles' stamp: 'yo 9/27/2004 16:14'!
setTurtlesCount: count prototype: prototype for: aKedamaWorld randomize: rondomizeFlag

	| anInteger array |
	anInteger _ count.
	count < 0 ifTrue: [anInteger _ 0].

	self size > anInteger ifTrue: [
		info associationsDo: [:assoc |
			array _ (arrays at: assoc value).
			array _ array copyFrom: 1 to: anInteger.
			arrays at: assoc value put: array.
		].
		turtleMapValid _ false.
		whoTableValid _ false.
	].

	self size < anInteger ifTrue: [
		self addTurtlesCount: (anInteger - self size) ofPrototype: prototype for: aKedamaWorld randomize: rondomizeFlag.
		turtleMapValid _ false.
		whoTableValid _ false.

	].


! !


!KedamaTurtleVectorPlayer methodsFor: 'private' stamp: 'yo 10/24/2004 18:45'!
arrayForType: typeName

	| newArray |
	(typeName = #Number) ifTrue: [
		newArray _ KedamaFloatArray new: self size.
	].
	(typeName = #Color) ifTrue: [
		newArray _ WordArray new: self size.
	].
	(typeName = #Boolean) ifTrue: [
		newArray _ ByteArray new: self size.
	].

	newArray ifNil: [
		newArray _ Array new: self size.
	].

	^ newArray.
! !

!KedamaTurtleVectorPlayer methodsFor: 'private' stamp: 'yo 9/28/2004 17:16'!
groupForward: dist

	| x y headingRadians |
	self size = 0 ifTrue: [^ self].

	x _ (arrays at: 2) first.
	y _ (arrays at: 3) first.
	headingRadians _ (arrays at: 4) first.
	self groupSetX: (x + (dist asFloat * headingRadians cos)).
	self groupSetY: (y - (dist asFloat * headingRadians sin)).
! !

!KedamaTurtleVectorPlayer methodsFor: 'private' stamp: 'yo 9/29/2004 08:35'!
groupSetX: val

	| xArray headingArray origX origHeading leftEdgeMode rightEdgeMode newArray wrapX minX maxX |
	self size = 0 ifTrue: [^ self].
	xArray _ arrays at: 2.
	headingArray _ arrays at: 4.
	
	origX _ xArray first.
	origHeading _ headingArray first.

	leftEdgeMode _ kedamaWorld leftEdgeModeMnemonic.
	rightEdgeMode _ kedamaWorld rightEdgeModeMnemonic.

	newArray _ xArray collect: [:e | e + val - origX].
	wrapX _ kedamaWorld wrapX.
	minX _ newArray min.
	maxX _ newArray max.
	((minX < 0.0) not and: [(maxX >= wrapX) not]) ifTrue: [
		arrays at: 2 put: newArray.
		^ self.
	].

	minX < 0.0 ifTrue: [
		leftEdgeMode = 1 ifTrue: [
			newArray withIndexDo: [:e :i |
				e < 0.0 ifTrue: [newArray at: i put: e + wrapX].
			].
		].
		leftEdgeMode = 2 ifTrue: [
			newArray withIndexDo: [:e :i |
				newArray at: i put: e - minX.
			].
		].
		leftEdgeMode = 3 ifTrue: [
			newArray withIndexDo: [:e :i |
				newArray at: i put: e + (minX * -2.0).
			].
		].		
	].

	maxX >= wrapX ifTrue: [
		rightEdgeMode = 1 ifTrue: [
			newArray withIndexDo: [:e :i |
				e >= wrapX ifTrue: [newArray at: i put: e - wrapX].
			].
		].
		rightEdgeMode = 2 ifTrue: [
			newArray withIndexDo: [:e :i |
				newArray at: i put: e - (maxX - wrapX) - 2.35099e-038.
			].
		].
		rightEdgeMode = 3 ifTrue: [
			newArray withIndexDo: [:e :i |
				newArray at: i put: e - ((maxX - wrapX) * 2.0) - 2.35099e-038.
			].
		].
	].

	arrays at: 2 put: newArray.
! !

!KedamaTurtleVectorPlayer methodsFor: 'private' stamp: 'yo 9/28/2004 17:58'!
groupSetY: val

	| yArray headingArray origY origHeading topEdgeMode bottomEdgeMode newArray wrapY minY maxY |
	self size = 0 ifTrue: [^ self].
	yArray _ arrays at: 3.
	headingArray _ arrays at: 4.
	
	origY _ yArray first.
	origHeading _ headingArray first.

	topEdgeMode _ kedamaWorld topEdgeModeMnemonic.
	bottomEdgeMode _ kedamaWorld bottomEdgeModeMnemonic.

	newArray _ yArray collect: [:e | e + val - origY].
	wrapY _ kedamaWorld wrapY.
	minY _ newArray min.
	maxY _ newArray max.
	((minY < 0.0) not and: [(maxY >= wrapY) not]) ifTrue: [
		arrays at: 3 put: newArray.
		^ self.
	].

	minY < 0.0 ifTrue: [
		topEdgeMode = 1 ifTrue: [
			newArray withIndexDo: [:e :i |
				e < 0.0 ifTrue: [newArray at: i put: e + wrapY].
			].
		].
		topEdgeMode = 2 ifTrue: [
			newArray withIndexDo: [:e :i |
				newArray at: i put: e - minY.
			].
		].
		topEdgeMode = 3 ifTrue: [
			newArray withIndexDo: [:e :i |
				newArray at: i put: e + (minY * -2.0).
			].
		].		
	].

	maxY >= wrapY ifTrue: [
		bottomEdgeMode = 1 ifTrue: [
			newArray withIndexDo: [:e :i |
				e >= wrapY ifTrue: [newArray at: i put: e - wrapY].
			].
		].
		bottomEdgeMode = 2 ifTrue: [
			newArray withIndexDo: [:e :i |
				newArray at: i put: e - (maxY - wrapY) - 2.35099e-038.
			].
		].
		bottomEdgeMode = 3 ifTrue: [
			newArray withIndexDo: [:e :i |
				newArray at: i put: e - ((maxY - wrapY) * 2.0) - 2.35099e-038.
			].
		].
	].

	arrays at: 3 put: newArray.
! !

!KedamaTurtleVectorPlayer methodsFor: 'private' stamp: 'yo 10/25/2004 16:23'!
useKedamaFloatArray

	| newArray |
	arrays withIndexDo: [:array :index |
		(array isMemberOf: FloatArray) ifTrue: [
			newArray _ KedamaFloatArray new: array size.
			newArray replaceFrom: 1 to: array size with: array startingAt: 1.
			arrays at: index put: newArray.
		].
	].
! !


!KedamaTurtleVectorPlayer methodsFor: 'accessing' stamp: 'yo 9/16/2004 17:43'!
arrays

	^ arrays.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing' stamp: 'yo 9/28/2004 14:02'!
exampler: e

	exampler _ e.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing' stamp: 'yo 9/14/2004 18:13'!
info

	^ info.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing' stamp: 'yo 9/14/2004 18:13'!
instSize

	^ arrays size.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing' stamp: 'yo 9/14/2004 17:43'!
size

	^ arrays first size.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing' stamp: 'yo 9/23/2004 19:03'!
types

	^ types.
! !


!KedamaTurtleVectorPlayer methodsFor: 'turtle map' stamp: 'yo 10/22/2004 07:10'!
aTurtleAtX: xPos y: yPos

	| w x y index who stub |
	turtleMapValid ifFalse: [
		self makeTurtlesMap.
	].

	w _ kedamaWorld dimensions x.
	x _ xPos truncated.
	y _ yPos truncated.
	x < 0 ifTrue: [^ nil].
	x >= w ifTrue: [^ nil].
	y < 0 ifTrue: [^ nil].
	y >= kedamaWorld dimensions y ifTrue: [^ nil].
	index _ (w * y) + x + 1.
	who _ turtlesMap at: index.
	who = 0 ifTrue: [^ nil].
	who = lastWho ifTrue: [^ lastWhoStub].
	stub _ exampler clonedSequentialStub.
	stub who: who.
	lastWho _ who.
	^ lastWhoStub _ stub.
! !

!KedamaTurtleVectorPlayer methodsFor: 'turtle map' stamp: 'yo 9/29/2004 17:24'!
basicMakeTurtlesMap

	| x y xArray yArray width height mapIndex whoArray |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	whoArray _ arrays at: 1.
	width _ kedamaWorld dimensions x.
	height _ kedamaWorld dimensions y.
	turtlesMap atAllPut: 0.

	1 to: self size do: [:index |
		x _ (xArray at: index) truncated.
		y _ (yArray at: index) truncated.
		mapIndex _ (width * y) + x + 1.
		(0 < mapIndex and: [mapIndex <= turtlesMap size]) ifTrue: [
			turtlesMap at: mapIndex put: (whoArray at: index).
		].
	].

	turtleMapValid _ true.
! !

!KedamaTurtleVectorPlayer methodsFor: 'turtle map' stamp: 'yo 9/28/2004 10:21'!
invalidateTurtleMap

	turtleMapValid _ false.
! !

!KedamaTurtleVectorPlayer methodsFor: 'turtle map' stamp: 'yo 9/29/2004 17:31'!
makeTurtlesMap

	| xArray yArray width height whoArray ret |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	whoArray _ arrays at: 1.
	width _ kedamaWorld dimensions x.
	height _ kedamaWorld dimensions y.
	turtlesMap ifNil: [turtlesMap _ WordArray new: width * height].

	ret _ self primMakeTurtlesMap: turtlesMap whoArray: whoArray xArray: xArray yArray: yArray width: width height: height.

	ret ifNil: [self basicMakeTurtlesMap].

	turtleMapValid _ true.
! !


!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/24/2004 18:45'!
basicGetAngleTo: players

	| ret p xArray yArray result |
	players isCollection ifFalse: [
		p _ players
	].
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	result _ KedamaFloatArray new: self size.
	1 to: self size do: [:index |
		players isCollection ifTrue: [
			p _ players at: index.
		].
		ret _ ((p getX - (xArray at: index))@(p getY - (yArray at: index))) theta radiansToDegrees + 90.0.
		ret > 360.0 ifTrue: [ret _ ret - 360.0].
		result at: index put: ret.
	].
	^ result.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/24/2004 18:45'!
basicGetDistanceTo: players

	| p xArray yArray result |
	players isCollection ifFalse: [
		p _ players
	].
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	result _ KedamaFloatArray new: self size.
	1 to: self size do: [:index |
		players isCollection ifTrue: [
			p _ players at: index.
		].
		result at: index put: ((p getX - (xArray at: index)) squared + (p getY - (yArray at: index)) squared) sqrt.

	].
	^ result.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 4/5/2005 11:04'!
colorFromPatch: aPatch

	| xArray yArray cArray patch |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	cArray _ arrays at: 5.
	patch _ aPatch costume renderedMorph.
	1 to: self size do: [:i |
		cArray at: i put: ((patch pixelAtX: (xArray at: i) y: (yArray at: i)) bitAnd: 16rFFFFFF).
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/12/2004 23:14'!
colorToPatch: aPatch

	| xArray yArray cArray patch |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	cArray _ arrays at: 5.
	patch _ aPatch costume renderedMorph.
	1 to: self size do: [:i |
		patch pixelAtX: (xArray at: i) y: (yArray at: i) put: (cArray at: i).
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 4/5/2005 10:58'!
color: c

	c isColor ifTrue: [
		self setColorVarAt: 5 put: ((c pixelValueForDepth: 32) bitAnd: 16rFFFFFF).
	] ifFalse: [
		self setColorVarAt: 5 put: c.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/26/2004 11:34'!
deleteTurtleID: who

	| whoArray whoIndex newArray |
	whoArray _ arrays at: 1.
	whoIndex _ whoArray indexOf: who ifAbsent: [^ self].
	deletingIndex _ whoIndex - 1.
	arrays withIndexDo: [:array :index |
		newArray _ (array copyFrom: 1 to: whoIndex - 1), (array copyFrom: whoIndex + 1 to: array size).
		arrays at: index put: newArray.
	].
	whoTableValid _ false.
	turtleMapValid _ false.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/30/2004 11:13'!
forward: val

	exampler getGrouped ifFalse: [
		self primForwardXArray: (arrays at: 2) yArray: (arrays at: 3) headingArray: (arrays at: 4) value: (val isNumber ifTrue: [val asFloat] ifFalse: [val]) destWidth: kedamaWorld wrapX asFloat destHeight: kedamaWorld wrapY asFloat leftEdgeMode: kedamaWorld leftEdgeModeMnemonic rightEdgeMode: kedamaWorld rightEdgeModeMnemonic topEdgeMode: kedamaWorld topEdgeModeMnemonic bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic.
	] ifTrue: [
		self groupForward: val
	].
	turtleMapValid _ false.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/24/2004 18:45'!
getAngleTo: players

	| p xArray yArray result pX pY xy |
	players isCollection ifFalse: [
		p _ players
	].
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	result _ KedamaFloatArray new: self size.
	players isCollection ifTrue: [
		pX _ KedamaFloatArray new: players size.
		pY _ KedamaFloatArray new: players size.
		1 to: players size do: [:i |
			xy _ (players at: i) getXAndY.
			pX at: i put: xy x.
			pY at: i put: xy y.
		].
	] ifFalse: [
		xy _ p getXAndY.
		pX _ xy x.
		pY _ xy y.
	].
	^ self primGetAngleToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result.

! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/25/2004 11:34'!
getBlueComponentIn: aPatch

	| pix xArray yArray patch w |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	patch _ aPatch costume renderedMorph.
	w _ WordArray new: self size.
	1 to: self size do: [:i |
		pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
		w at: i put: (pix bitAnd: 16rFF).
	].
	^ w.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/20/2004 11:12'!
getColor

	^ self getVarAt: 5.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/24/2004 18:45'!
getDistanceTo: players

	| p xArray yArray result pX pY xy |
	players isCollection ifFalse: [
		p _ players
	].
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	result _ KedamaFloatArray new: self size.
	players isCollection ifTrue: [
		pX _ KedamaFloatArray new: players size.
		pY _ KedamaFloatArray new: players size.
		1 to: players size do: [:i |
			xy _ (players at: i) getXAndY.
			pX at: i put: xy x.
			pY at: i put: xy y.
		].
	] ifFalse: [
		xy _ p getXAndY.
		pX _ xy x.
		pY _ xy y.
	].
	^ self primGetDistanceToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/25/2004 11:34'!
getGreenComponentIn: aPatch

	| pix xArray yArray patch w |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	patch _ aPatch costume renderedMorph.
	w _ WordArray new: self size.
	1 to: self size do: [:i |
		pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
		w at: i put: ((pix bitShift: -8) bitAnd: 16rFF).
	].
	^ w.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/29/2004 15:11'!
getGrouped

	^ exampler getGrouped.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/24/2004 18:45'!
getHeading

	| heading result ret |
	heading _ (arrays at: 4).
	result _ KedamaFloatArray new: heading size.
	ret _ self primGetHeading: heading into: result.
	ret ifNotNil: [^ result].
	! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/24/2004 18:46'!
getNormal

	| result ret normal |
	normal _ (arrays at: 7).
	result _ KedamaFloatArray new: normal size.
	ret _ self primGetHeading: normal into: result.
	ret ifNotNil: [^ result].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/25/2004 16:44'!
getPatchValueIn: aPatch

	| w patch xArray yArray |
	w _ WordArray new: self size.
	patch _ aPatch costume renderedMorph.
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	patch pixelsAtXArray: xArray yArray: yArray into: w.
	^ w.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/25/2004 11:35'!
getRedComponentIn: aPatch

	| pix xArray yArray patch w |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	patch _ aPatch costume renderedMorph.
	w _ WordArray new: self size.
	1 to: self size do: [:i |
		pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
		w at: i put: ((pix bitShift: -16) bitAnd: 16rFF).
	].
	^ w.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 3/7/2005 08:22'!
getTurtleAt: aPlayer

	| xy |
	aPlayer isCollection ifTrue: [
		self error: 'should not happen'.
	].
	xy _ aPlayer getXAndY.
	^ (self aTurtleAtX: xy x y: xy y) ifNil: [^ aPlayer].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 3/7/2005 08:37'!
getTurtleOf: aBreedPlayer

	| xy |
	aBreedPlayer isCollection ifTrue: [
		"self error: 'should not happen'."
		^ aBreedPlayer.
	].
	xy _ aBreedPlayer getXAndY.
	^ (self aTurtleAtX: xy x y: xy y) ifNil: [^ aBreedPlayer].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 3/7/2005 07:32'!
getTurtleVisible

	^ (turtles arrays at: 6) collect: [:t | t = 1].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/24/2004 18:46'!
getUphillIn: aPatch

	| xArray yArray headingArray result patch |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	headingArray _ arrays at: 4.
	result _ KedamaFloatArray new: self size.
	patch _ aPatch costume renderedMorph.
	1 to: self size do: [:index |
		result at: index put: (patch
			uphillForTurtleX: (xArray at: index)
			turtleY: (yArray at: index)
			turtleHeading: (headingArray at: index)).
	].
	^ result.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/29/2004 14:21'!
getX

	| xArray |
	exampler getGrouped ifFalse: [
		^ arrays at: 2.
	] ifTrue: [
		xArray _ arrays at: 2.
		xArray size = 0 ifTrue: [^ exampler getX].
		^ xArray first.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/29/2004 14:22'!
getY

	| yArray |
	exampler getGrouped ifFalse: [
		^ arrays at: 3.
	] ifTrue: [
		yArray _ arrays at: 3.
		yArray size = 0 ifTrue: [^ exampler getY].
		^ yArray first.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/16/2004 22:59'!
heading

	^ self getHeading.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/16/2004 23:02'!
heading: degrees

	| deg |
	deg _ degrees isNumber ifTrue: [degrees asFloat] ifFalse: [degrees].
	self primSetHeading: (arrays at: 4) from: deg.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/17/2004 15:46'!
hide

	(arrays at: 6) atAllPut: 0.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/29/2004 09:06'!
normal: degrees

	| deg |
	deg _ degrees isNumber ifTrue: [degrees asFloat] ifFalse: [degrees].
	self primSetHeading: (arrays at: 7) from: deg.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/13/2004 06:41'!
setBlueComponentIn: aPatch to: value

	| pix xArray yArray patch component |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	patch _ aPatch costume renderedMorph.
	value isCollection ifFalse: [
		component _ value asInteger bitAnd: 16rFF.
	].
	(1 to: self size) do: [:i |
		value isCollection ifTrue: [
			component _ (value at: i) asInteger bitAnd: 16rFF.
		].
		pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
		pix _ (pix bitAnd: 16rFFFF00) bitOr: component.
		patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/20/2004 16:55'!
setColor: color

	^ self color: color.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/13/2004 06:40'!
setGreenComponentIn: aPatch to: value

	| pix xArray yArray patch component |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	patch _ aPatch costume renderedMorph.
	value isCollection ifFalse: [
		component _ (value asInteger bitAnd: 16rFF) bitShift: 8.
	].
	(1 to: self size) do: [:i |
		value isCollection ifTrue: [
			component _ ((value at: i) asInteger bitAnd: 16rFF) bitShift: 8.
		].
		pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
		pix _ (pix bitAnd: 16rFF00FF) bitOr: component.
		patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/16/2004 22:59'!
setHeading: degrees

	^ self heading: degrees.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 3/7/2005 13:41'!
setInitialValueOf: name from: from to: to for: aKedamaWorld

	| array max |
	array _ arrays at: (info at: name).
	name = #who ifTrue: [
		from to: to do: [:index |
			array at: index put: (aKedamaWorld nextTurtleID).
		].
		^ self.
	].
	name = #x ifTrue: [
		max _ aKedamaWorld dimensions x * 100.
		self primRandomRange: max from: from to: to intoFloatArray: array factor: 0.01.
		^ self.
	].
	name = #y ifTrue: [
		max _ aKedamaWorld dimensions y * 100.
		self primRandomRange: max from: from to: to intoFloatArray: array factor: 0.01.
		^ self.
	].
	name = #heading ifTrue: [
		self primRandomRange: 36000 from: from to: to intoFloatArray: array factor: (0.01 *  0.0174532925199433).
		^ self.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/29/2004 09:06'!
setNormal: degrees

	^ self normal: degrees.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/25/2004 16:57'!
setPatchValueIn: aPatch to: value

	| xArray yArray patchMorph |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	patchMorph _ aPatch costume renderedMorph.
	patchMorph setPixelsAtXArray: xArray yArray: yArray value: value.

! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 10/13/2004 06:40'!
setRedComponentIn: aPatch to: value

	| pix xArray yArray patch component |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	patch _ aPatch costume renderedMorph.
	value isCollection ifFalse: [
		component _ (value asInteger bitAnd: 16rFF) bitShift: 16.
	].
	(1 to: self size) do: [:i |
		value isCollection ifTrue: [
			component _ ((value at: i) asInteger bitAnd: 16rFF) bitShift: 16.
		].
		pix _ patch pixelAtX: (xArray at: i) y: (yArray at: i).
		pix _ (pix bitAnd: 16r00FFFF) bitOr: component.
		patch pixelAtX: (xArray at: i) y: (yArray at: i) put: pix.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 3/7/2005 07:34'!
setTurtleVisible: aBooleanArray

	1 to: self size do: [:i |
		(turtles arrays at: 6) at: i put: ((aBooleanArray at: i) ifTrue: [1] ifFalse: [0]).
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/29/2004 14:13'!
setX: v

	exampler getGrouped ifFalse: [
		self
			primSetX: (arrays at: 2)
			headingArray: (arrays at: 4)
			value: (v isNumber ifTrue: [v asFloat] ifFalse: [v])
			destWidth: kedamaWorld wrapX
			leftEdgeMode: kedamaWorld leftEdgeModeMnemonic
			rightEdgeMode: kedamaWorld rightEdgeModeMnemonic.
	] ifTrue: [
		self groupSetX: v
	].
	turtleMapValid _ false.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/29/2004 14:13'!
setY: v

	exampler getGrouped ifFalse: [
		self
			primSetY: (arrays at: 3)
			headingArray: (arrays at: 4)
			value: (v isNumber ifTrue: [v asFloat] ifFalse: [v])
			destHeight: kedamaWorld wrapY
			topEdgeMode: kedamaWorld topEdgeModeMnemonic
			bottomEdgeMode: kedamaWorld bottomEdgeModeMnemonic.
	] ifTrue: [
		self groupSetY: v.
	].
	turtleMapValid _ false.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/17/2004 15:46'!
show

	(arrays at: 6) atAllPut: 1.
! !

!KedamaTurtleVectorPlayer methodsFor: 'player commands' stamp: 'yo 9/16/2004 22:03'!
turn: degrees
	"Turn by the given number of degrees."

	self heading: (self heading + degrees).
! !


!KedamaTurtleVectorPlayer methodsFor: 'deleting' stamp: 'yo 10/8/2004 11:04'!
delete

	| anInstance |
	exampler _ nil.
	arrays _ nil.
	whoTable _ nil.
	turtlesMap _ nil.
	self class removeFromSystem: false.
	anInstance := UnscriptedPlayer new.
	self become: anInstance.
! !


!KedamaTurtleVectorPlayer methodsFor: 'command execution' stamp: 'yo 10/13/2004 06:49'!
doCommand: aBlock

	^ aBlock value: self.
! !

!KedamaTurtleVectorPlayer methodsFor: 'command execution' stamp: 'yo 9/28/2004 14:04'!
doDieCommand: aBlock

	^ exampler doDieCommand: aBlock.
! !

!KedamaTurtleVectorPlayer methodsFor: 'command execution' stamp: 'yo 9/17/2004 09:25'!
doExamplerCommand: aBlock
! !

!KedamaTurtleVectorPlayer methodsFor: 'command execution' stamp: 'yo 9/29/2004 15:15'!
doSequentialCommand: aBlock

	^ exampler doSequentialCommand: aBlock.
! !


!KedamaTurtleVectorPlayer methodsFor: 'displaying' stamp: 'yo 9/16/2004 21:40'!
drawOn: aForm

	| xArray yArray colorArray visibleArray bits x y visible bitsIndex dimX dimY ret |
	xArray _ arrays at: 2.
	yArray _ arrays at: 3.
	colorArray _ arrays at: 5.
	visibleArray _ arrays at: 6.
	bits _ aForm bits.
	dimX _ aForm width.
	dimY _ aForm height.

	ret _ self primDrawOn: bits destWidth: dimX destHeight: dimY xArray: xArray yArray: yArray colorArray: colorArray visibleArray: visibleArray.
	ret ifNotNil: [^ self].

	1 to: self size do: [:index |
		x _ (xArray at: index) truncated.
		y _ (yArray at: index) truncated.
		visible _ (visibleArray at: index) ~= 0.
		(visible and: [((x >= 0) and: [y >= 0]) and: [(x < dimX) and: [y < dimY]]]) ifTrue: [
			bitsIndex _ ((y * dimX) + x) + 1.
			bits at: bitsIndex put: (colorArray at: index).
		].
	].

! !


!KedamaTurtleVectorPlayer methodsFor: 'accessing - private' stamp: 'yo 9/20/2004 11:06'!
getBooleanVarAt: index

	^ arrays at: index.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing - private' stamp: 'yo 9/20/2004 11:04'!
getColorVarAt: index

	^ (arrays at: index) collect: [:c | Color colorFromPixelValue: c depth: 32].
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing - private' stamp: 'yo 9/20/2004 11:06'!
getVarAt: index

	^ arrays at: index.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing - private' stamp: 'yo 9/20/2004 11:20'!
setBooleanVarAt: index put: v

	(v == true or: [v == false]) ifTrue: [
		(arrays at: index) atAllPut: (v == true ifTrue: [1] ifFalse: [0]).
		^ self.
	].
	(arrays at: index) replaceFrom: 1 to: v size with: v startingAt: 1.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing - private' stamp: 'yo 4/5/2005 10:52'!
setColorVarAt: index put: cPixel

	cPixel isNumber ifTrue: [
		(arrays at: index) atAllPut: cPixel.
		^ self.
	].

	(arrays at: index) replaceFrom: 1 to: cPixel size with: cPixel startingAt: 1.
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing - private' stamp: 'yo 10/29/2004 19:35'!
setNumberVarAt: index put: v

	v isNumber ifTrue: [
		(arrays at: index) atAllPut: v.
		^ self.
	].
	(v isMemberOf: KedamaFloatArray) ifTrue: [
		(arrays at: index) replaceFrom: 1 to: v size with: v startingAt: 1.
		^ self.
	].
	(v isMemberOf: WordArray) ifTrue: [
		v primAddScalar: v and: 0.0 into: (arrays at: index).
		^ self.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'accessing - private' stamp: 'yo 9/20/2004 11:21'!
setObjectVarAt: index put: v

	(v isKindOf: Array) ifFalse: [
		(arrays at: index) atAllPut: v.
		^ self.
	].
	(arrays at: index) replaceFrom: 1 to: v size with: v startingAt: 1.
! !


!KedamaTurtleVectorPlayer methodsFor: 'enumeration' stamp: 'yo 9/27/2004 15:16'!
indexOf: who

	| whoArray |
	whoTableValid ifTrue: [^ whoTable at: (who - whoTableBase)].

	whoArray _ arrays at: 1.

	whoArray size = 0 ifTrue: [^ 0].

	whoTableBase _ whoArray first - 1.
	whoTable _ WordArray new: whoArray last - whoTableBase.
	1 to: whoArray size do: [:w |
		whoTable at: (whoArray at: w) - whoTableBase put: w.
	].
	whoTableValid _ true.

	^ whoTable at: (who - whoTableBase).

! !

!KedamaTurtleVectorPlayer methodsFor: 'enumeration' stamp: 'yo 9/18/2004 12:02'!
initializeDeletingIndex

	deletingIndex _ 0.
! !

!KedamaTurtleVectorPlayer methodsFor: 'enumeration' stamp: 'yo 9/18/2004 12:02'!
nextDeletingIndex

	^ deletingIndex _ deletingIndex + 1.
! !


!KedamaTurtleVectorPlayer methodsFor: 'initialization' stamp: 'yo 10/24/2004 18:46'!
initialize

	super initialize.
	info _ IdentityDictionary new.
	info at: #who put: 1.
	info at: #x put: 2.
	info at: #y put: 3.
	info at: #heading put: 4.
	info at: #color put: 5.
	info at: #visible put: 6.
	info at: #normal put: 7.

	arrays _ Array new: 7.
	arrays at: (info at: #who) put: (WordArray new: 0).
	arrays at: (info at: #x) put: (KedamaFloatArray new: 0).
	arrays at: (info at: #y) put: (KedamaFloatArray new: 0).
	arrays at: (info at: #heading) put: (KedamaFloatArray new: 0).
	arrays at: (info at: #color) put: (WordArray new: 0).
	arrays at: (info at: #visible) put: (ByteArray new: 0).
	arrays at: (info at: #normal) put: (KedamaFloatArray new: 0).

	types _ Array new: 64.

	types at: 1 put: #Integer.
	types at: 2 put: #Number.
	types at: 3 put: #Number.
	types at: 4 put: #Number.
	types at: 5 put: #Color.
	types at: 6 put: #Boolean.
	types at: 7 put: #Number.

	whoTableValid _ false.
	turtleMapValid _ false.


! !


!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 10/11/2004 11:49'!
primDrawOn: destBits destWidth: destWidth destHeight: destHeight xArray: xArray yArray: yArray colorArray: colorArray visibleArray: visibleArray

	| x y visible bitsIndex |
	<primitive: 'drawTurtlesInArray' module: 'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #drawTurtlesInArray."

	1 to: xArray size do: [:i |
		x _ (xArray at: i) asInteger.
		y _ (yArray at: i) asInteger.
		visible _ (visibleArray at: i).
		(visible ~= 0 and: [((x >= 0) and: [y >= 0]) and: [(x < destWidth) and: [y < destHeight]]]) ifTrue: [
			bitsIndex _ ((y * destWidth) + x) + 1.
			destBits at: bitsIndex put: (colorArray at: i).
		]
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 10/11/2004 11:04'!
primForwardXArray: xArray yArray: yArray headingArray: headingArray value: v destWidth: destWidth destHeight: destHeight leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode

	| dist newX newY |
	<primitive: 'primTurtlesForward' module: 'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primTurtlesForward."

	1 to: xArray size do: [:i |
		v isCollection ifTrue: [
			dist _ (v at: i) asFloat.
		] ifFalse: [
			dist _ v asFloat.
		].
		newX _ (xArray at: i) + (dist * (headingArray at: i) cos).
		newY _ (yArray at: i) - (dist * (headingArray at: i) sin).
		KedamaMorph scalarXAt: i xArray: xArray headingArray: headingArray value: newX destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode.
		KedamaMorph scalarYAt: i yArray: yArray headingArray: headingArray value: newY destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 10/23/2004 22:19'!
primGetAngleToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result

	| ppx ppy x y ret |
	<primitive: 'vectorGetAngleTo' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #vectorGetAngleTo."

	ppx _ pX.
	ppy _ pY.
	1 to: result size do: [:index |
		pX isCollection ifTrue: [
			ppx _ pX at: index.
			ppy _ pY at: index.
		].
		x _ ppx - (xArray at: index).
		y _ ppy - (yArray at: index).
		ret _ (x@y) theta radiansToDegrees + 90.0.
		ret > 360.0 ifTrue: [ret _ ret - 360.0].
		result at: index put: ret.
	].
	^ result.
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 10/23/2004 18:02'!
primGetDistanceToX: pX toY: pY xArray: xArray yArray: yArray resultInto: result

	| ppx ppy |
	<primitive: 'vectorGetDistanceTo' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #vectorGetDistanceTo."

	ppx _ pX.
	ppy _ pY.
	1 to: result size do: [:index |
		pX isCollection ifTrue: [
			ppx _ pX at: index.
			ppy _ pY at: index.
		].
		result at: index put: ((ppx - (xArray at: index)) squared + (ppy - (yArray at: index)) squared) sqrt.

	].
	^ result.
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 10/9/2004 17:29'!
primGetHeading: headingArray into: resultArray

	| heading |
	<primitive: 'getHeadingArrayInto' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #getHeadingArrayInto."

	1 to: headingArray size do: [:i |
		heading _ headingArray at: i.
		heading _ heading / 0.0174532925199433.
		heading _ 90.0 - heading.
		heading > 0.0 ifFalse: [heading _ heading + 360.0].
		resultArray at: i put: heading.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 9/29/2004 17:20'!
primMakeTurtlesMap: map whoArray: whoArray xArray: xArray yArray: yArray width: w height: h

	<primitive: 'makeTurtlesMap' module: 'KedamaPlugin'>
	^ nil.
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 3/7/2005 13:40'!
primRandomRange: range from: from to: to intoFloatArray: aFloatArray factor: factor

	<primitive: 'randomIntoFloatArray' module: 'KedamaPlugin'>

	from to: to do: [:index |
		aFloatArray at: index put: (kedamaWorld random: range) asFloat * factor.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 3/7/2005 13:30'!
primRandomRange: range from: from to: to intoIntegerArray: anIntegerArray factor: factor

	<primitive: 'randomIntoIntegerArray' module: 'KedamaPlugin'>

	from to: to do: [:index |
		anIntegerArray at: index put: ((kedamaWorld random: range) asFloat * factor) asInteger.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 10/11/2004 11:40'!
primSetHeading: headingArray from: val

	| heading |
	<primitive: 'setHeadingArrayFrom' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #setHeadingArrayFrom."

	val isCollection ifFalse: [
		heading _ val asFloat.
		heading _ KedamaMorph degreesToRadians: heading.
	].

	1 to: headingArray size do: [:i |
		val isCollection ifTrue: [
			heading _ val at: i.
			heading _ KedamaMorph degreesToRadians: heading.
		].
		headingArray at: i put: heading.
	].
! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 10/11/2004 11:19'!
primSetX: xArray headingArray: headingArray value: v destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode

	| val newX |
	<primitive: 'turtlesSetX' module: 'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #turtlesSetX."

	v isCollection ifFalse: [
		val _ v asFloat.
	].

	1 to: xArray size do: [:i |
		v isCollection ifTrue: [
			newX _ v at: i.
		] ifFalse: [
			newX _ val.
		].
		KedamaMorph scalarXAt: i xArray: xArray headingArray: headingArray value: newX destWidth: destWidth leftEdgeMode: leftEdgeMode rightEdgeMode: rightEdgeMode.
	].

! !

!KedamaTurtleVectorPlayer methodsFor: 'primitives' stamp: 'yo 10/11/2004 11:21'!
primSetY: yArray headingArray: headingArray value: v destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode

	| val newY |
	<primitive: 'turtlesSetY' module: 'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #turtlesSetY."

	v isCollection ifFalse: [
		val _ v asFloat.
	].

	1 to: yArray size do: [:i |
		v isCollection ifTrue: [
			newY _ v at: i.
		] ifFalse: [
			newY _ val.
		].
		KedamaMorph scalarYAt: i yArray: yArray headingArray: headingArray value: newY destHeight: destHeight topEdgeMode: topEdgeMode bottomEdgeMode: bottomEdgeMode.
	].
! !
TileMorph subclass: #KedamaUpHillTile
	instanceVariableNames: 'patchTile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!
!KedamaUpHillTile commentStamp: 'yo 6/18/2004 18:34' prior: 0!
I provide the special tile of 'upHill' setter.
!


!KedamaUpHillTile methodsFor: 'initialization-support' stamp: 'yo 4/5/2005 14:53'!
addPatchTile

	| m1 desiredW m2 label |
	self removeAllMorphs.
	m1 _ TilePadMorph new.
	label _ 	StringMorph contents: 'upHillIn' translated font: ScriptingSystem fontForTiles.

	m2 _ TileMorph new.
	m2 extent: 20@22.
	m2 minWidth: 20.
	m1 extent: (m2 extent + (2@2)).
	m1 setType: #Patch.
	m1 addMorph: m2.
	desiredW _ m1 width + 6.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	self addMorphBack: m1.
	self addMorphFront: label.
	patchTile _ m1.
! !

!KedamaUpHillTile methodsFor: 'initialization-support' stamp: 'yo 6/7/2004 21:56'!
setPatchDefaultTo: aPlayer

	patchTile submorphs first setToReferTo: aPlayer.
! !


!KedamaUpHillTile methodsFor: 'initialization' stamp: 'yo 6/7/2004 18:34'!
initialize

	super initialize.
	type _ #Patch.
	operatorOrExpression _ #getUphillIn:.
	self addPatchTile.
! !


!KedamaUpHillTile methodsFor: 'tile protocol' stamp: 'yo 4/5/2005 14:53'!
line1: line1

	| label |
	self removeAllMorphs.

	label _ 	StringMorph contents: 'upHillIn' translated font: ScriptingSystem fontForTiles.

	self addMorphBack: label.
	self addMorphBack: patchTile.
! !

!KedamaUpHillTile methodsFor: 'tile protocol' stamp: 'yo 10/9/2004 10:03'!
storeCodeOn: aStream indent: tabCount 
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts := operatorOrExpression keywords.	"getUphillIn:"
	aStream nextPutAll: parts first.
	aStream space.
	patchTile storeCodeOn: aStream indent: tabCount.
! !

!KedamaUpHillTile methodsFor: 'tile protocol' stamp: 'yo 6/18/2004 18:44'!
updateLiteralLabel
! !
Object subclass: #KedamaVectorizer
	instanceVariableNames: 'attributes root'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaVectorizer methodsFor: 'private' stamp: 'yo 9/24/2004 11:47'!
checkFirstPairFor: stmt in: obj

	^ self checkRequireVectorIn: stmt for: obj.
"

	| receiver selector ret |
	receiver _ Compiler evaluate: (self getReceiverFromStatement: stmt) name for: obj logged: false.
	selector _ (self getSelectorFromStatement: stmt) key.
	ret _ self isVectorizationRequiredWithPlayer: receiver andSelector: selector.
	attributes setAttribute: #firstTurtle of: stmt to: receiver.
	attributes setAttribute: #requireVector of: stmt to: ret.
	^ ret.
"! !

!KedamaVectorizer methodsFor: 'private' stamp: 'yo 2/14/2005 15:33'!
checkRequireVectorIn: aMessageNode for: obj

	| players playersSet sel playerNodes |
	"self halt."
	playerNodes _ self getAllPlayersIn: aMessageNode for: obj.
	players _ playerNodes collect: [:e | Compiler evaluate: e name for: obj logged: false.].
	playersSet _ players asSet.
	(playersSet select: [:e | e isPrototypeTurtlePlayer]) size = 0 ifTrue: [
		attributes setAttribute: #firstTurtle of: aMessageNode to: (Compiler evaluate: playerNodes first name for: obj logged: false).
		attributes setAttribute: #requireVector of: aMessageNode to: false.
		^ self.
	].
	(playersSet select: [:e | e isPrototypeTurtlePlayer]) size > 0 ifTrue: [	
		playerNodes with: players do: [:n :p |
			p isPrototypeTurtlePlayer ifTrue: [
				sel _ self getSelectorRootFor: p fromMessageNode: aMessageNode for: obj ignoreSelectors: #(beNotZero: setTurtleCount: getTurtleCount setGrouped: getGrouped).
				sel ifNotNil: [
					(self isVectorizationRequiredWithPlayer: p andSelector: sel) ifTrue: [
						attributes setAttribute: #requireVector of: aMessageNode to: true.
						attributes setAttribute: #firstTurtle of: aMessageNode to: p.
						attributes setAttribute: #firstNode of: aMessageNode to: n.
						^ self.
					].
				].
			].
		].
	].

	attributes setAttribute: #firstTurtle of: aMessageNode to: players first.
	attributes setAttribute: #requireVector of: aMessageNode to: false.
! !

!KedamaVectorizer methodsFor: 'private' stamp: 'yo 9/16/2004 10:20'!
isScalarizable: aPlayer andSelector: selector

	(aPlayer isKindOf: Player) ifFalse: [^ false].
	aPlayer isPrototypeTurtlePlayer ifFalse: [^ false].

	(#(getX getY getHeading getAngleTo: getDistanceTo: getUphillIn: getReplicated color) includes: selector) ifTrue: [^ true].

	^ ((aPlayer class organization listAtCategoryNamed: 'access') select: [:sel | sel beginsWith: 'get']) includes: selector.
! !

!KedamaVectorizer methodsFor: 'private' stamp: 'yo 9/29/2004 09:44'!
isVectorizationRequiredWithPlayer: aPlayer andSelector: selector

	(aPlayer isKindOf: Player) ifFalse: [^ false].
	aPlayer isPrototypeTurtlePlayer ifFalse: [^ false].

	^ (#(setTurtleCount: getTurtleCount setGrouped: getGrouped) includes: selector) not.
! !

!KedamaVectorizer methodsFor: 'private' stamp: 'yo 9/24/2004 12:11'!
vectorizeAt: index inMethodNode: aMethodNode

	| v encoder origReceiverName origReceiver aMessageNode |
	aMessageNode _ aMethodNode block statements at: index.
	(attributes getAttribute: #requireVector of: aMessageNode) ifFalse: [^ self].

	encoder _ aMethodNode encoder.
	encoder autoBind: 'xxxObj'.
	v _ encoder encodeVariable: 'xxxObj' sourceRange: nil ifUnknown: [].
	origReceiver _ attributes getAttribute: #firstNode of: aMessageNode.
	(origReceiver isMemberOf: VariableNode) ifTrue: [
		origReceiverName _ origReceiver name.
	] ifFalse: [
		origReceiverName _ 'self'.
	].

	self replaceRoot: origReceiverName with: v inMessageNode: aMessageNode.
	"self changeSelectorAt: index inMethodNode: aMethodNode."
	self insertTurtleCommandAt: index in: aMethodNode block statements variableNode: v from: encoder firstReceiverName: origReceiverName.

! !


!KedamaVectorizer methodsFor: 'player and selector look up' stamp: 'yo 10/8/2004 05:23'!
getAllPlayersInMethodNode: aMethodNode for: obj

	| aCollection |
	aCollection _ OrderedCollection new.
	aMethodNode block statements do: [:stmt |
		(stmt isMemberOf: MessageNode) ifTrue: [
			self getPlayersMessage: stmt for: obj into: aCollection.
		].
		(stmt isMemberOf: BlockNode) ifTrue: [
			self getPlayersBlock: stmt for: obj into: aCollection.
		].
	].
	^ aCollection.
! !

!KedamaVectorizer methodsFor: 'player and selector look up' stamp: 'yo 9/24/2004 11:13'!
getAllPlayersIn: aMessageNode for: obj

	| aCollection |
	aCollection _ OrderedCollection new.
	self getPlayersMessage: aMessageNode for: obj into: aCollection.
	^ aCollection.
! !

!KedamaVectorizer methodsFor: 'player and selector look up' stamp: 'yo 9/24/2004 11:08'!
getPlayersBlock: aBlockNode for: obj into: aCollection


	| statements |
	statements _ aBlockNode statements.
	statements do: [:stmt |
		(stmt isMemberOf: MessageNode) ifTrue: [
			self getPlayersMessage: stmt for: obj into: aCollection.
		].
		(stmt isMemberOf: BlockNode) ifTrue: [
			self getPlayersBlock: stmt for: obj into: aCollection..
		].
	].
! !

!KedamaVectorizer methodsFor: 'player and selector look up' stamp: 'yo 9/24/2004 12:02'!
getPlayersMessage: aMessageNode for: obj into: aCollection

	| thisPlayer |
	((Array with: aMessageNode receiver), aMessageNode arguments) do: [:stmt |
		(stmt isMemberOf: MessageNode) ifTrue: [
			self getPlayersMessage: stmt for: obj into: aCollection.
		].
		(stmt isMemberOf: BlockNode) ifTrue: [
			self getPlayersBlock: stmt for: obj into: aCollection..
		].
		(stmt isMemberOf: VariableNode) ifTrue: [
			thisPlayer _ Compiler evaluate: stmt name for: obj logged: false.
			(thisPlayer isKindOf: Player) ifTrue: [aCollection add: stmt].
		].
	].
! !

!KedamaVectorizer methodsFor: 'player and selector look up' stamp: 'yo 2/14/2005 15:22'!
getSelectorFor: receiver fromBlockNode: aBlockNode for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors

	root ifNotNil: [^ self].
	aBlockNode statements do: [:stmt |
		(stmt isMemberOf: MessageNode) ifTrue: [
			self getSelectorFor: receiver fromMessageNode: stmt for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors
		].
		(stmt isMemberOf: BlockNode) ifTrue: [
			self getSelectorFor: receiver fromBlockNode: stmt for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors
		].
	].
! !

!KedamaVectorizer methodsFor: 'player and selector look up' stamp: 'yo 2/14/2005 15:34'!
getSelectorFor: receiver fromMessageNode: aMessageNode for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors

	| thisPlayer key |
	root ifNotNil: [^ self].
	(Array with: aMessageNode receiver), aMessageNode arguments do: [:stmt |
		(stmt isMemberOf: VariableNode) ifTrue: [
			thisPlayer _ Compiler evaluate: stmt name for: obj logged: false.
			thisPlayer == receiver ifTrue: [
				key _  aMessageNode selector key.
				(ignoreSelectors includes: key) ifFalse: [aBlock value: key. ^ self]].
		].
		(stmt isMemberOf: MessageNode) ifTrue: [
			self getSelectorFor: receiver fromMessageNode: stmt for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors
		].
		(stmt isMemberOf: BlockNode) ifTrue: [
			self getSelectorFor: receiver fromBlockNode: stmt for: obj ifFoundDo: aBlock ignoreSelectors: ignoreSelectors
		].
	].
! !

!KedamaVectorizer methodsFor: 'player and selector look up' stamp: 'yo 2/14/2005 15:25'!
getSelectorRootFor: receiver fromMessageNode: aMessageNode for: obj ignoreSelectors: ignoreSelectors

	| val |
	root _ nil.
	self getSelectorFor: receiver fromMessageNode: aMessageNode for: obj ifFoundDo: [:sel | root _ sel] ignoreSelectors: ignoreSelectors.
	val _ root.
	root _ nil.
	^ val.
! !


!KedamaVectorizer methodsFor: 'entry point' stamp: 'yo 10/8/2004 05:33'!
includesTurtlePlayer: aMethodNode for: obj

	| players p |
	players _ self getAllPlayersInMethodNode: aMethodNode for: obj.
	players do: [:e |
		p _ Compiler evaluate: e name for: obj logged: false.
		(p isKindOf: KedamaExamplerPlayer) ifTrue: [^ true].
	].
	^ false.
! !

!KedamaVectorizer methodsFor: 'entry point' stamp: 'yo 2/14/2005 10:55'!
vectorize: aMethodNode object: obj

	aMethodNode block statements withIndexDo: [:stmt :index |
		(stmt isMemberOf: MessageNode) ifTrue: [
			self checkFirstPairFor: stmt in: obj.
			self traverseMessageRoot: stmt in: obj firstPlayer: (attributes getAttribute: #firstTurtle of: stmt).
		].

		(stmt isMemberOf: MessageNode) ifTrue: [
			self vectorizeAt: index inMethodNode: aMethodNode.
		].
	].

	^ aMethodNode.


! !


!KedamaVectorizer methodsFor: 'initialization' stamp: 'yo 8/28/2004 00:47'!
initialize

	attributes _ KedamaAttributeDictionary new initialize.
! !


!KedamaVectorizer methodsFor: 'insert block node' stamp: 'yo 9/18/2004 12:08'!
insertTurtleCommandAt: index in: statements variableNode: varNode from: encoder firstReceiverName: origName

	| messageNode blockNode newMessageNode selector |
	messageNode _ statements at: index.
	(attributes getAttribute: #requireVector of: messageNode) ifFalse: [^ self].
	blockNode _ BlockNode new arguments: (Array with: varNode) statements: (Array with: messageNode) returns: false from: encoder.
	selector _ (attributes getAttribute: #dieMessage of: messageNode) ifNotNil: [#doDieCommand:].
	selector ifNil: [
		selector _ (attributes getAttribute: #constant of: messageNode) ifTrue: [#doCommand:] ifFalse: [#doSequentialCommand:].
	].
		
	newMessageNode _ MessageNode new
				receiver: (encoder encodeVariable: origName)
				selector: selector
				arguments: (Array with: blockNode)
				precedence: 3
				from: encoder
				sourceRange: nil.

	statements at: index put: newMessageNode.
! !


!KedamaVectorizer methodsFor: 'replace receiver' stamp: 'yo 9/24/2004 09:30'!
replaceRoot: varName with: newNode inMessageNode: aMessageNode

	(attributes getAttribute: #requireVector of: aMessageNode) ifFalse: [^ self].

	(aMessageNode isMemberOf: MessageNode) ifTrue: [
		self replace: varName with: newNode inMessageNode: aMessageNode.
	].
	(aMessageNode isMemberOf: BlockNode) ifTrue: [
		self replace: varName with: newNode inBlockNode: aMessageNode.
	].
! !

!KedamaVectorizer methodsFor: 'replace receiver' stamp: 'yo 8/31/2004 18:34'!
replace: varName with: newNode inBlockNode: aBlockNode

	aBlockNode statements do: [:e |
		(e isMemberOf: MessageNode) ifTrue: [
			self replace: varName with: newNode inMessageNode: e.
		].
		(e isMemberOf: BlockNode) ifTrue: [
			self replace: varName with: newNode inBlockNode: e.
		].
	].
! !

!KedamaVectorizer methodsFor: 'replace receiver' stamp: 'yo 10/9/2004 15:56'!
replace: varName with: newNode inMessageNode: aMessageNode

	| receiver att |
	aMessageNode arguments withIndexDo: [:e :index |
		(e isMemberOf: MessageNode) ifTrue: [
			self replace: varName with: newNode inMessageNode: e.
		].
		(e isMemberOf: BlockNode) ifTrue: [
			self replace: varName with: newNode inBlockNode: e.
		].
		(e isMemberOf: VariableNode) ifTrue: [
			att _ attributes getAttribute: #isTurtle of: e.
			((att notNil & att) and: [e name = varName]) ifTrue: [aMessageNode arguments at: index put: newNode].
		].

	].

	receiver _ aMessageNode receiver.
	(receiver isMemberOf: MessageNode) ifTrue: [
		self replace: varName with: newNode inMessageNode: receiver.
	].

	(receiver isMemberOf: VariableNode) ifTrue: [
		att _ attributes getAttribute: #isTurtle of: receiver.
		((att notNil & att) and: [receiver name = varName]) ifTrue: [aMessageNode receiver: newNode].
	].
! !


!KedamaVectorizer methodsFor: 'vectorization attribute calculation' stamp: 'yo 9/17/2004 11:20'!
traverseBlock: aBlockNode in: obj firstPlayer: firstPlayer inCondition: inCondition

	| value statements |
	statements _ aBlockNode statements.
	statements do: [:stmt |
		(stmt isMemberOf: MessageNode)	ifTrue: [
			self traverseMessage: stmt in: obj firstPlayer: firstPlayer inCondition: inCondition.
		].
		(stmt isMemberOf: BlockNode) ifTrue: [
			self traverseBlock: stmt in: obj firstPlayer: firstPlayer inCondition: inCondition.
		].
		(stmt isMemberOf: VariableNode) ifTrue: [
			attributes setAttribute: #constant of: stmt to: false
		].
		(stmt isMemberOf: LiteralNode) ifTrue: [
			attributes setAttribute: #constant of: stmt to: true
		].
	].
	value _ statements collect: [:stmt | attributes getAttribute: #constant of: stmt].
	value _ value inject: true into: [:s :t | s & t].

	attributes setAttribute: #constant of: aBlockNode to: value.
! !

!KedamaVectorizer methodsFor: 'vectorization attribute calculation' stamp: 'yo 9/24/2004 09:20'!
traverseMessageRoot: aMessageNode in: obj firstPlayer: firstPlayer

	| inCondition |
	inCondition _ #(ifTrue: ifFalse: ifTrue:ifFalse:) includes: aMessageNode selector key.

	root _ aMessageNode.

	self traverseMessage: aMessageNode in: obj firstPlayer: firstPlayer inCondition: inCondition.
! !

!KedamaVectorizer methodsFor: 'vectorization attribute calculation' stamp: 'yo 3/7/2005 08:36'!
traverseMessage: aMessageNode in: obj firstPlayer: firstPlayer inCondition: inCondition

	| receiver thisPlayer ret constant proto |

	aMessageNode arguments do: [:argument |
		(argument isMemberOf: MessageNode) ifTrue: [
			self traverseMessage: argument in: obj firstPlayer: firstPlayer inCondition: inCondition.
		].
		(argument isMemberOf: BlockNode) ifTrue: [
			self traverseBlock: argument in: obj firstPlayer: firstPlayer inCondition: inCondition.
		].
		(argument isMemberOf: LiteralNode) ifTrue: [
			attributes setAttribute: #constant of: argument to: true.
		].
		(argument isMemberOf: VariableNode) ifTrue: [
			thisPlayer _ Compiler evaluate: argument name for: obj logged: false.
			ret _ (thisPlayer isKindOf: Player) and: [thisPlayer costume renderedMorph isKindOf: KedamaPatchMorph].
			attributes setAttribute: #constant of: argument to: ret.
		].
	].

	receiver _ aMessageNode receiver.
	(receiver isMemberOf: MessageNode) ifTrue: [
		self traverseMessage: receiver in: obj firstPlayer: firstPlayer inCondition: inCondition.
	].
	(receiver isMemberOf: BlockNode) ifTrue: [
		self traverseBlock: receiver in: obj firstPlayer: firstPlayer inCondition: inCondition.
	].
	(receiver isMemberOf: LiteralNode) ifTrue: [
		attributes setAttribute: #constant of: receiver to: true.
	].
	(receiver isMemberOf: VariableNode) ifTrue: [
		thisPlayer _ Compiler evaluate: receiver name for: obj logged: false.
		ret _ thisPlayer == firstPlayer.
		attributes setAttribute: #constant of: receiver to: ret.
		proto _ (thisPlayer isKindOf: Player) and: [thisPlayer isPrototypeTurtlePlayer].
		attributes setAttribute: #isTurtle of: receiver to: proto.
		attributes setAttribute: #scalar of: aMessageNode selector to:
		(ret not and: [(proto and: [self isScalarizable: thisPlayer andSelector: aMessageNode selector key])]).
	].

	"special cases..."
	(#(atRandom die getReplicated bounceOn: bounceOn:color: bounceOnColor: ifTrue: ifFalse: ifTrue:ifFalse: itFalse:ifTrue:
	setPatchValueIn:to: getTurtleAt: getTurtleOf:) includes: aMessageNode selector key) ifTrue: [
		attributes setAttribute: #constant of: aMessageNode to: false.
		aMessageNode selector key = #die ifTrue: [
			attributes setAttribute: #dieMessage of: root to: true.
		].

	] ifFalse: [
		constant _ (aMessageNode arguments copyWith: receiver) inject: true into: [:s :t | s _ s and: [attributes getAttribute: #constant of: t]].
		attributes setAttribute: #constant of: aMessageNode to: constant.
	].

! !
CategoryViewer subclass: #KedamaWhoSearchingViewer
	instanceVariableNames: 'searchString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-StarSqueak'!

!KedamaWhoSearchingViewer methodsFor: 'initialization' stamp: 'yo 4/4/2005 14:33'!
addNamePaneTo: header
	"Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer"

	| plugTextMor searchButton |
	namePane _ AlignmentMorph newRow vResizing: #spaceFill; height: 14.
	namePane hResizing: #spaceFill.
	namePane listDirection: #leftToRight.

	plugTextMor _ PluggableTextMorph on: self
					text: #searchString accept: #searchString:notifying:
					readSelection: nil menu: nil.
	plugTextMor setProperty: #alwaysAccept toValue: true.
	plugTextMor askBeforeDiscardingEdits: false.
	plugTextMor acceptOnCR: true.
	plugTextMor setTextColor: Color brown.
	plugTextMor setNameTo: 'Turtle' translated.
	plugTextMor vResizing: #spaceFill; hResizing: #spaceFill.
	plugTextMor hideScrollBarsIndefinitely.
	plugTextMor setTextMorphToSelectAllOnMouseEnter.

	searchButton _ SimpleButtonMorph new 
		target: self;
		beTransparent;
		label: 'Turtle' translated;
		actionSelector: #doSearchFrom:;
		arguments: {plugTextMor}.
	searchButton setBalloonText: 'Type a number into the pane to specify the individual turtle.' translated.

	namePane addMorphFront: searchButton.
	namePane addTransparentSpacerOfSize: 6@0.
	namePane addMorphBack: plugTextMor.
	header addMorphBack: namePane! !

!KedamaWhoSearchingViewer methodsFor: 'initialization' stamp: 'yo 4/3/2005 09:16'!
establishContents 
	"Perform any initialization steps that needed to wait until I am installed in my outer viewer"

	searchString isEmptyOrNil ifFalse: [self doSearchFrom: searchString interactive: false]! !

!KedamaWhoSearchingViewer methodsFor: 'initialization' stamp: 'sw 8/3/2005 11:16'!
initializeFor: aPlayer categoryChoice: aChoice
	"Initialize the receiver to be associated with the player and category specified"

	super initializeFor: aPlayer categoryChoice: #search.
	self clipSubmorphs: true.
	(namePane findA: PluggableTextMorph) setText: aChoice second asText.
	self setCategorySymbolFrom: aChoice! !

!KedamaWhoSearchingViewer methodsFor: 'initialization' stamp: 'yo 4/3/2005 09:16'!
setCategorySymbolFrom: aChoice
	"Set my category symbol"

	self chosenCategorySymbol: #search.
	self rawSearchString: aChoice second! !


!KedamaWhoSearchingViewer methodsFor: 'support' stamp: 'yo 4/3/2005 09:16'!
categoryRestorationInfo
	"Answer info needed to reincarnate myself"

	^ Array with: self chosenCategorySymbol with: self searchString! !

!KedamaWhoSearchingViewer methodsFor: 'support' stamp: 'md 3/17/2006 16:58'!
updateWhoString

	(self outerViewer restrictedWho = 0) ifTrue: [
		self rawSearchString: ''.
		self changed: #searchString.
	].
! !


!KedamaWhoSearchingViewer methodsFor: 'categories' stamp: 'yo 4/3/2005 09:16'!
categoryWording: aCategoryWording
	"okay, thanks"! !

!KedamaWhoSearchingViewer methodsFor: 'categories' stamp: 'yo 4/3/2005 09:16'!
currentCategory
	"Answer the symbol associated with the pane"

	^ #search! !

!KedamaWhoSearchingViewer methodsFor: 'categories' stamp: 'yo 4/3/2005 09:16'!
updateCategoryNameTo: aName
	"Update the category name, because of a language change."

	self doSearchFrom: (namePane findA: PluggableTextMorph) text interactive: false.
	self flag: #deferred.  "A nice touch would be to change the Button wording here"
! !


!KedamaWhoSearchingViewer methodsFor: 'search' stamp: 'yo 4/3/2005 09:16'!
doSearchFrom:  aSource
	"Perform the search operation"

	^ self doSearchFrom: aSource interactive: true! !

!KedamaWhoSearchingViewer methodsFor: 'search' stamp: 'yo 4/4/2005 18:03'!
doSearchFrom:  aSource interactive: isInteractive
	"Perform the search operation.  If interactive is true, this actually happened because a search button was pressed; if false, it was triggered some other way for which an informer would be inappropriate."

	| searchFor |
	searchString _ (aSource isKindOf: PluggableTextMorph)
		ifFalse:
			[aSource]
		ifTrue:
			[aSource text string].
	searchFor _ searchString asNumber asInteger.
	(self outerViewer isMemberOf: KedamaStandardViewer) ifTrue: [
		self outerViewer providePossibleRestrictedView: searchFor.
		self updateWhoString.
	].
! !

!KedamaWhoSearchingViewer methodsFor: 'search' stamp: 'yo 4/3/2005 09:16'!
rawSearchString: aString
	"Set the search string as indicated"

	searchString _ aString asString! !

!KedamaWhoSearchingViewer methodsFor: 'search' stamp: 'yo 4/3/2005 09:16'!
searchString
	"Answer the search string"

	^ searchString ifNil: [searchString _ '']! !

!KedamaWhoSearchingViewer methodsFor: 'search' stamp: 'yo 4/3/2005 09:16'!
searchString: aString notifying: znak
	"Set the search string as indicated and carry out a search"

	searchString _ aString asString.
	self doSearchFrom: searchString! !


!KedamaWhoSearchingViewer methodsFor: 'header pane' stamp: 'yo 4/3/2005 09:16'!
maybeAddArrowsTo: header
	"Maybe add up/down arrows to the header"

	header addTransparentSpacerOfSize: 5@5! !
SelectorNode subclass: #KeyWordNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!KeyWordNode commentStamp: '<historical>' prior: 0!
I am a part of a selector.   #at:put: is owned by a SelectorNode, and #put: within it is owned by a KeyWordNode.!

Object subclass: #KeyboardBuffer
	instanceVariableNames: 'event eventUsed'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/30/97 19:53'!
commandKeyPressed
	^ event commandKeyPressed! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/30/97 19:54'!
controlKeyPressed
	^ event controlKeyPressed! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/29/97 12:34'!
flushKeyboard
	eventUsed ifFalse: [^ eventUsed _ true].! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/29/97 12:34'!
keyboard
	eventUsed ifFalse: [eventUsed _ true.  ^ event keyCharacter].
	^ nil! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/29/97 12:34'!
keyboardPeek
	eventUsed ifFalse: [^ event keyCharacter].
	^ nil! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'ar 7/19/2002 17:44'!
keyboardPressed
	^eventUsed not! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/30/97 19:54'!
leftShiftDown
	^ event shiftPressed! !

!KeyboardBuffer methodsFor: 'as yet unclassified'!
startingEvent: evt
	event _ evt.
	eventUsed _ false! !
UserInputEvent subclass: #KeyboardEvent
	instanceVariableNames: 'keyValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!KeyboardEvent methodsFor: 'comparing' stamp: 'ar 10/24/2000 17:44'!
= aMorphicEvent
	super = aMorphicEvent ifFalse:[^false].
	buttons = aMorphicEvent buttons ifFalse: [^ false].
	keyValue = aMorphicEvent keyValue ifFalse: [^ false].
	^ true
! !

!KeyboardEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:50'!
hash
	^buttons hash + keyValue hash
! !


!KeyboardEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:13'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #keystroke ifTrue:[^anObject handleKeystroke: self].
	type == #keyDown ifTrue:[^anObject handleKeyDown: self].
	type == #keyUp ifTrue:[^anObject handleKeyUp: self].
	^super sentTo: anObject.! !


!KeyboardEvent methodsFor: 'initialize' stamp: 'ar 10/25/2000 22:08'!
type: eventType readFrom: aStream
	type _ eventType.
	timeStamp _ Integer readFrom: aStream.
	aStream skip: 1.
	buttons _ Integer readFrom: aStream.
	aStream skip: 1.
	keyValue _ Integer readFrom: aStream.! !


!KeyboardEvent methodsFor: 'keyboard' stamp: 'ar 9/13/2000 15:51'!
keyCharacter
	"Answer the character corresponding this keystroke. This is defined only for keystroke events."

	^ keyValue asCharacter! !

!KeyboardEvent methodsFor: 'keyboard' stamp: 'nk 10/13/2004 10:43'!
keyString
	"Answer the string value for this keystroke. This is defined only for keystroke events."

	^ String streamContents: [ :s | self printKeyStringOn: s ]! !

!KeyboardEvent methodsFor: 'keyboard' stamp: 'ar 9/13/2000 15:51'!
keyValue
	"Answer the ascii value for this keystroke. This is defined only for keystroke events."

	^ keyValue! !


!KeyboardEvent methodsFor: 'printing' stamp: 'tk 10/13/2004 15:19'!
printKeyStringOn: aStream
	"Print a readable string representing the receiver on a given stream"

	| kc inBrackets firstBracket keyString |
	kc := self keyCharacter.
	inBrackets := false.
	firstBracket := [ inBrackets ifFalse: [ aStream nextPut: $<. inBrackets := true ]].
	self controlKeyPressed ifTrue: [ 	firstBracket value. aStream nextPutAll: 'Ctrl-' ].
	self commandKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Cmd-' ].
	(buttons anyMask: 32) ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ].
	(self shiftPressed and: [ keyValue between: 1 and: 31 ])
		ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ].

	(self controlKeyPressed and: [ keyValue <= 26 ])
			ifTrue:
				[aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter]
			ifFalse: 
				[keyString := (kc caseOf: {
					[ Character space ] -> [ ' ' ].
					[ Character tab ] -> [ 'tab' ].
					[ Character cr ] -> [ 'cr' ].
					[ Character lf ] -> [ 'lf' ].
					[ Character enter ] -> [ 'enter' ].

					[ Character backspace ] -> [ 'backspace' ].
					[ Character delete ] -> [ 'delete' ].

					[ Character escape ] -> [ 'escape' ].

					[ Character arrowDown ] -> [ 'down' ].
					[ Character arrowUp ] -> [ 'up' ].
					[ Character arrowLeft ] -> [ 'left' ].
					[ Character arrowRight ] -> [ 'right' ].

					[ Character end ] -> [ 'end' ].
					[ Character home ] -> [ 'home' ].
					[ Character pageDown ] -> [ 'pageDown' ].
					[ Character pageUp ] -> [ 'pageUp' ].

					[ Character euro ] -> [ 'euro' ].
					[ Character insert ] -> [ 'insert' ].

				} otherwise: [ String with: kc ]).
				keyString size > 1 ifTrue: [ firstBracket value ].
				aStream nextPutAll: keyString].

	inBrackets ifTrue: [aStream nextPut: $> ]! !

!KeyboardEvent methodsFor: 'printing' stamp: 'nk 10/13/2004 10:42'!
printOn: aStream
	"Print the receiver on a stream"

	aStream nextPut: $[.
	aStream nextPutAll: type; nextPutAll: ' '''.
	self printKeyStringOn: aStream.
	aStream nextPut: $'.
	aStream nextPut: $]! !

!KeyboardEvent methodsFor: 'printing' stamp: 'ar 10/25/2000 22:07'!
storeOn: aStream

	aStream nextPutAll: type.
	aStream space.
	self timeStamp storeOn: aStream.
	aStream space.
	buttons storeOn: aStream.
	aStream space.
	keyValue storeOn: aStream.
! !


!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'!
isKeyDown
	^self type == #keyDown! !

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'!
isKeyUp
	^self type == #keyUp! !

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'!
isKeyboard
	^true! !

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'!
isKeystroke
	^self type == #keystroke! !

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 10/9/2000 00:43'!
isMouseMove
	^false! !


!KeyboardEvent methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 18:53'!
decodeFromStringArray: array 
	"decode the receiver from an array of strings"

	type := array first asSymbol.
	position := CanvasDecoder decodePoint: (array second).
	buttons := CanvasDecoder decodeInteger: (array third).
	keyValue := CanvasDecoder decodeInteger: array fourth! !

!KeyboardEvent methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ar 10/9/2000 00:14'!
encodedAsStringArray
	"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
	^{
		type.
		CanvasEncoder encodePoint: position.
		CanvasEncoder encodeInteger: buttons.
		CanvasEncoder encodeInteger: keyValue asInteger
	}! !


!KeyboardEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:54'!
setType: aSymbol buttons: anInteger position: pos keyValue: aValue hand: aHand stamp: stamp
	type _ aSymbol.
	buttons _ anInteger.
	position _ pos.
	keyValue _ aValue.
	source _ aHand.
	wasHandled _ false.
	timeStamp _ stamp.! !
Object subclass: #KeyboardInputInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'EventSensorConstants'
	category: 'Multilingual-TextConversion'!

!KeyboardInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 17:26'!
initialize

! !

!KeyboardInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 13:53'!
nextCharFrom: sensor firstEvt: evtBuf



	self subclassResponsibility.

! !

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

KeyboardInputInterpreter class
	instanceVariableNames: ''!

!KeyboardInputInterpreter class methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 16:24'!
new



	^ (self basicNew) initialize; yourself.

! !
PianoKeyboardMorph subclass: #KeyboardMorphForInput
	instanceVariableNames: 'pianoRoll duration durationModifier articulation buildingChord insertMode prevSelection startOfNextNote'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!KeyboardMorphForInput commentStamp: '<historical>' prior: 0!
This class adds state and controls to the basic PianoKeyboardMorph so that notes of reliable duration can be keyed into a score without the need for a real keyboard.

To try this out, execute...

	| n score | n _ 3.
	score _ (MIDIScore new tracks: ((1 to: n) collect: [:i | Array new]);
		trackInfo: ((1 to: n) collect: [:i | 'Instrument' , i printString]);
		tempoMap: nil; ticksPerQuarterNote: 96).
	ScorePlayerMorph openOn: score title: 'empty score'

Then open a pianoRoll and, from that, open a keyboard.  The rule is that the keyboard will append after the current selection.  If the current selection is muted or nil, then input will go to the end of the first non-muted track.!


!KeyboardMorphForInput methodsFor: 'events' stamp: 'stephaneducasse 2/4/2006 20:41'!
soundForEvent: noteEvent inTrack: trackIndex

	| sound player |
	player := pianoRoll scorePlayer.
	sound := MixedSound new.
	sound add: ((player instrumentForTrack: trackIndex)
					soundForMidiKey: noteEvent midiKey
					dur: noteEvent duration / (pianoRoll scorePlayer ticksForMSecs: 1000)
					loudness: (noteEvent velocity asFloat / 127.0))
			pan: (player panForTrack: trackIndex)
			volume: player overallVolume *
						(player volumeForTrack: trackIndex).
	^ sound
! !


!KeyboardMorphForInput methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
addRecordingControls
	| button switch playRow durRow articRow modRow |

	"Add chord, rest and delete buttons"
	playRow := AlignmentMorph newRow.
	playRow color: color; borderWidth: 0; layoutInset: 0.
	playRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	playRow addMorphBack: (switch label: 'chord' translated; actionSelector: #buildChord:).
	button := SimpleButtonMorph new target: self;
		borderColor: #raised; borderWidth: 2; color: color.
	playRow addMorphBack: (button label: '          rest          ' translated; actionSelector: #emitRest).
	button := SimpleButtonMorph new target: self;
		borderColor: #raised; borderWidth: 2; color: color.
	playRow addMorphBack: (button label: 'del' translated; actionSelector: #deleteNotes).
	self addMorph: playRow.
	playRow align: playRow fullBounds topCenter
			with: self fullBounds bottomCenter.

	"Add note duration buttons"
	durRow := AlignmentMorph newRow.
	durRow color: color; borderWidth: 0; layoutInset: 0.
	durRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	durRow addMorphBack: (switch label: 'whole' translated;
				actionSelector: #duration:onOff:; arguments: #(1)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	durRow addMorphBack: (switch label: 'half' translated;
				actionSelector: #duration:onOff:; arguments: #(2)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	durRow addMorphBack: (switch label: 'quarter' translated;
				actionSelector: #duration:onOff:; arguments: #(4)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	durRow addMorphBack: (switch label: 'eighth' translated;
				actionSelector: #duration:onOff:; arguments: #(8)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	durRow addMorphBack: (switch label: 'sixteenth' translated;
				actionSelector: #duration:onOff:; arguments: #(16)).
	self addMorph: durRow.
	durRow align: durRow fullBounds topCenter
			with: playRow fullBounds bottomCenter.

	"Add note duration modifier buttons"
	modRow := AlignmentMorph newRow.
	modRow color: color; borderWidth: 0; layoutInset: 0.
	modRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	modRow addMorphBack: (switch label: 'dotted' translated;
				actionSelector: #durMod:onOff:; arguments: #(dotted)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	modRow addMorphBack: (switch label: 'normal' translated;
				actionSelector: #durMod:onOff:; arguments: #(normal)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	modRow addMorphBack: (switch label: 'triplets' translated;
				actionSelector: #durMod:onOff:; arguments: #(triplets)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	modRow addMorphBack: (switch label: 'quints' translated;
				actionSelector: #durMod:onOff:; arguments: #(quints)).
	self addMorph: modRow.
	modRow align: modRow fullBounds topCenter
			with: durRow fullBounds bottomCenter.

	"Add articulation buttons"
	articRow := AlignmentMorph newRow.
	articRow color: color; borderWidth: 0; layoutInset: 0.
	articRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	articRow addMorphBack: (switch label: 'legato' translated;
				actionSelector: #articulation:onOff:; arguments: #(legato)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	articRow addMorphBack: (switch label: 'normal' translated;
				actionSelector: #articulation:onOff:; arguments: #(normal)).
	switch := SimpleSwitchMorph new target: self; borderWidth: 2;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false.
	articRow addMorphBack: (switch label: 'staccato' translated;
				actionSelector: #articulation:onOff:; arguments: #(staccato)).
	self addMorph: articRow.
	articRow align: articRow fullBounds topCenter
			with: modRow fullBounds bottomCenter.

	self bounds: (self fullBounds expandBy: (0@0 extent: 0@borderWidth))
! !

!KeyboardMorphForInput methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	buildingChord := false.
	self addRecordingControls.
	self duration: 4 onOff: true.
	self durMod: #normal onOff: true.
	self articulation: #normal onOff: true.
	insertMode := false! !

!KeyboardMorphForInput methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
pianoRoll: prMorph

	pianoRoll := prMorph! !


!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
articulation: artic onOff: ignored    "artic = eg, #legato, #normal, #staccato."
	"Set the articulation of notes to be emitted when a key is pressed."

	self allMorphsDo:
		[:m | ((m isMemberOf: SimpleSwitchMorph)
				and: [m actionSelector == #articulation:onOff:])
				ifTrue: [m setSwitchState: m arguments first == artic]].
	articulation := artic! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:20'!
backspaceNote

	self deleteNotes! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/18/1999 15:50'!
buildChord: onOff! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:20'!
deleteNotes

	pianoRoll deleteSelection! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
durMod: durMod onOff: ignored    "durMod = eg, #dotted, #normal, #triplets, #quints"
	"Set the duration of notes to be emitted when a key is pressed."

	self allMorphsDo:
		[:m | ((m isMemberOf: SimpleSwitchMorph)
				and: [m actionSelector == #durMod:onOff:])
				ifTrue: [m setSwitchState: m arguments first = durMod]].
	durationModifier := durMod! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration: denom onOff: ignored    "denom = eg, 1, 2, 4, 8, 16"
	"Set the duration of notes to be emitted when a key is pressed."

	self allMorphsDo:
		[:m | ((m isMemberOf: SimpleSwitchMorph)
				and: [m actionSelector == #duration:onOff:])
				ifTrue: [m setSwitchState: m arguments first = denom]].
	duration := denom.
	self durMod: #normal onOff: true! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
emitRest

	| sel noteEvent |

	"All this selection logic should be shared with mouseDown..."
	(sel := pianoRoll selection) ifNil: [^ self].
	insertMode ifTrue:
		[sel := pianoRoll selectionForInsertion.
		insertMode := false].
	sel = prevSelection ifFalse:
		["This is a new selection -- need to determine start time"
		sel third = 0
			ifTrue: [startOfNextNote := 0]
			ifFalse: [startOfNextNote := ((pianoRoll score tracks at: sel first)
										at: sel third) endTime.
					startOfNextNote := startOfNextNote + self fullDuration - 1
										truncateTo: self fullDuration]].
	noteEvent := NoteEvent new time: startOfNextNote; duration: self noteDuration;
			key: -1 "my flag for rest" velocity: self velocity channel: 1.
	pianoRoll appendEvent: noteEvent fullDuration: self fullDuration.
	soundPlaying ifNotNil: [soundPlaying stopGracefully].
	prevSelection := pianoRoll selection.
	startOfNextNote := startOfNextNote + self fullDuration.! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
fullDuration

	| num denom |
	num := denom := 1.
	durationModifier == #dotted ifTrue: [num := 3.  denom := 2].
	durationModifier == #triplets ifTrue: [num := 2.  denom := 3].
	durationModifier == #quints ifTrue: [num := 2.  denom := 5].
	^ pianoRoll score ticksPerQuarterNote * 4 * num // duration // denom! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:27'!
noteDuration

	articulation == #staccato ifTrue: [^ (self fullDuration * 0.65) asInteger].
	articulation == #normal ifTrue: [^ (self fullDuration * 0.8) asInteger].
	articulation == #legato ifTrue: [^ (self fullDuration * 0.95) asInteger].
! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/19/1999 23:13'!
velocity

	^ 80  "Later put a slider on the keyboard control"! !


!KeyboardMorphForInput methodsFor: 'simple keyboard' stamp: 'stephaneducasse 2/4/2006 20:41'!
mouseDownPitch: midiKey event: event noteMorph: keyMorph

	| sel noteEvent |
	event hand hasSubmorphs ifTrue: [^ self  "no response if drag something over me"].
	keyMorph color: playingKeyColor.
	(sel := pianoRoll selection) ifNil: [^ self].
	insertMode ifTrue:
		[sel := pianoRoll selectionForInsertion.
		insertMode := false].
	sel = prevSelection ifFalse:
		["This is a new selection -- need to determine start time"
		sel third = 0
			ifTrue: [startOfNextNote := 0]
			ifFalse: [startOfNextNote := ((pianoRoll score tracks at: sel first)
										at: sel third) endTime.
					startOfNextNote := startOfNextNote + self fullDuration - 1
										truncateTo: self fullDuration]].
	noteEvent := NoteEvent new time: startOfNextNote; duration: self noteDuration;
			key: midiKey + 23 velocity: self velocity channel: 1.
	pianoRoll appendEvent: noteEvent fullDuration: self fullDuration.
	soundPlaying ifNotNil: [soundPlaying stopGracefully].
	(soundPlaying := self soundForEvent: noteEvent inTrack: sel first) play.
	prevSelection := pianoRoll selection.
	startOfNextNote := startOfNextNote + self fullDuration.! !

!KeyboardMorphForInput methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:28'!
mouseUpPitch: pitch event: event noteMorph: noteMorph
	noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12)
					ifTrue: [whiteKeyColor]
					ifFalse: [blackKeyColor]).
! !
KeyedSet subclass: #KeyedIdentitySet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

!KeyedIdentitySet methodsFor: 'private' stamp: 'md 10/5/2005 15:43'!
scanFor: anObject
	"Same as super except change = to ==, and hash to identityHash"

	| element start finish |
	finish _ array size.
	start _ (anObject identityHash \\ finish) + 1.
	

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [(keyBlock value: element) == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [(keyBlock value: element) == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
Set subclass: #KeyedSet
	instanceVariableNames: 'keyBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!KeyedSet commentStamp: '<historical>' prior: 0!
Like Set except a key of every element is used for hashing and searching instead of the element itself.  keyBlock gets the key of an element.!


!KeyedSet methodsFor: 'accessing' stamp: 'ajh 9/5/2000 03:57'!
at: key 
	"Answer the value associated with the key."

	^ self at: key ifAbsent: [self errorKeyNotFound]! !

!KeyedSet methodsFor: 'accessing' stamp: 'ajh 10/6/2000 20:28'!
at: key ifAbsent: aBlock 
	"Answer the value associated with the key or, if key isn't found,
	answer the result of evaluating aBlock."

	| obj |
	obj _ array at: (self findElementOrNil: key).
	obj ifNil: [^ aBlock value].
	^ obj! !

!KeyedSet methodsFor: 'accessing' stamp: 'ajh 12/10/2000 15:42'!
at: key ifAbsentPut: aBlock 
	"Answer the value associated with the key or, if key isn't found,
	add the result of evaluating aBlock to self"

	^ self at: key ifAbsent: [self add: aBlock value]! !

!KeyedSet methodsFor: 'accessing' stamp: 'ajh 9/5/2000 03:58'!
at: key ifPresent: aBlock
	"Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."

	| v |
	v _ self at: key ifAbsent: [^ nil].
	^ aBlock value: v
! !

!KeyedSet methodsFor: 'accessing' stamp: 'ajh 7/3/2004 17:55'!
keys

	| keys |
	keys _ Set new.
	self keysDo: [:key | keys add: key].
	^ keys! !

!KeyedSet methodsFor: 'accessing' stamp: 'ajh 7/3/2004 17:54'!
keysDo: block

	self do: [:item | block value: (keyBlock value: item)]! !

!KeyedSet methodsFor: 'accessing' stamp: 'ajh 5/11/2002 13:28'!
keysSorted

	| keys |
	keys _ SortedCollection new.
	self do: [:item | keys add: (keyBlock value: item)].
	^ keys! !


!KeyedSet methodsFor: 'adding' stamp: 'md 3/14/2006 12:37'!
add: newObject
	"Include newObject as one of the receiver's elements, but only if
	not already present. Answer newObject."

	| index |
	newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
	index _ self findElementOrNil: (keyBlock value: newObject).
	(array at: index) ifNil: [self atNewIndex: index put: newObject].
	^ newObject! !

!KeyedSet methodsFor: 'adding' stamp: 'ajh 12/4/2001 05:27'!
addAll: aCollection 
	"Include all the elements of aCollection as the receiver's elements"

	(aCollection respondsTo: #associationsDo:)
		ifTrue: [aCollection associationsDo: [:ass | self add: ass]]
		ifFalse: [aCollection do: [:each | self add: each]].
	^ aCollection! !

!KeyedSet methodsFor: 'adding' stamp: 'ajh 6/3/2002 10:11'!
member: newObject
	"Include newObject as one of the receiver's elements, if already exists just return it"

	| index |
	newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
	index _ self findElementOrNil: (keyBlock value: newObject).
	(array at: index) ifNotNil: [^ array at: index].
	self atNewIndex: index put: newObject.
	^ newObject! !


!KeyedSet methodsFor: 'copying' stamp: 'ajh 9/5/2000 03:56'!
copy
	^super copy postCopyBlocks! !

!KeyedSet methodsFor: 'copying' stamp: 'ajh 9/5/2000 03:56'!
postCopyBlocks
	keyBlock _ keyBlock copy.
	"Fix temps in case we're referring to outside stuff"
	keyBlock fixTemps.! !


!KeyedSet methodsFor: 'initialize' stamp: 'ajh 9/5/2000 03:36'!
keyBlock: oneArgBlock
	"When evaluated return the key of the argument which will be an element of the set"

	keyBlock _ oneArgBlock! !


!KeyedSet methodsFor: 'removing' stamp: 'ajh 9/5/2000 03:47'!
remove: oldObject ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: (keyBlock value: oldObject).
	(array at: index) == nil ifTrue: [ ^ aBlock value ].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ oldObject! !

!KeyedSet methodsFor: 'removing' stamp: 'ajh 3/29/2001 19:03'!
removeKey: key 

	^ self removeKey: key ifAbsent: [self errorKeyNotFound]! !

!KeyedSet methodsFor: 'removing' stamp: 'ajh 3/29/2001 19:03'!
removeKey: key ifAbsent: aBlock

	| index obj |
	index _ self findElementOrNil: key.
	(obj _ array at: index) == nil ifTrue: [ ^ aBlock value ].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ obj! !


!KeyedSet methodsFor: 'testing' stamp: 'ajh 9/5/2000 03:45'!
includes: anObject 
	^ (array at: (self findElementOrNil: (keyBlock value: anObject))) ~~ nil! !

!KeyedSet methodsFor: 'testing' stamp: 'ajh 3/29/2001 23:56'!
includesKey: key

	^ (array at: (self findElementOrNil: key)) ~~ nil! !


!KeyedSet methodsFor: 'private' stamp: 'ajh 3/29/2001 19:04'!
errorKeyNotFound

	self error: 'key not found'! !

!KeyedSet methodsFor: 'private' stamp: 'ajh 9/5/2000 03:44'!
fixCollisionsFrom: index
	"The element at index has been removed and replaced by nil.
	This method moves forward from there, relocating any entries
	that had been placed below due to collisions with this one"
	| length oldIndex newIndex element |
	oldIndex _ index.
	length _ array size.
	[oldIndex = length
			ifTrue: [oldIndex _  1]
			ifFalse: [oldIndex _  oldIndex + 1].
	(element _ self keyAt: oldIndex) == nil]
		whileFalse: 
			[newIndex _ self findElementOrNil: (keyBlock value: element).
			oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! !

!KeyedSet methodsFor: 'private' stamp: 'nice 4/4/2006 22:09'!
initialize: n
	super initialize: n.
	keyBlock _ [:element | element key].
! !

!KeyedSet methodsFor: 'private' stamp: 'ajh 9/5/2000 03:46'!
noCheckAdd: anObject
	array at: (self findElementOrNil: (keyBlock value: anObject)) put: anObject.
	tally _ tally + 1! !

!KeyedSet methodsFor: 'private' stamp: 'ajh 12/13/2001 00:17'!
rehash
	| newSelf |
	newSelf _ self species new: self size.
	newSelf keyBlock: keyBlock.
	self do: [:each | newSelf noCheckAdd: each].
	array _ newSelf array! !

!KeyedSet methodsFor: 'private' stamp: 'md 10/5/2005 15:43'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	finish _ array size.
	start _ (anObject hash \\ finish) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [(keyBlock value: element) = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [(keyBlock value: element) = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

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

KeyedSet class
	instanceVariableNames: ''!

!KeyedSet class methodsFor: 'instance creation' stamp: 'ajh 10/23/2000 23:16'!
keyBlock: oneArgBlock
	"Create a new KeySet whose way to access an element's key is by executing oneArgBlock on the element"

	^ self new keyBlock: oneArgBlock! !
ProjectNavigationMorph subclass: #KidNavigationMorph
	instanceVariableNames: ''
	classVariableNames: 'PreExistingProjects'
	poolDictionaries: ''
	category: 'MorphicExtras-Navigators'!

!KidNavigationMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2003 18:39'!
balloonText
	^ ((mouseInside
			ifNil: [false])
		ifTrue: ['Click here to see FEWER buttons.']
		ifFalse: ['Click here to see MORE buttons.'])  translated! !


!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:41'!
addButtons

	(self addARow: {

		self inAColumn: {self buttonFind}.
		self transparentSpacerOfSize:6@6.
		self transparentSpacerOfSize:6@6.
		self inAColumn: {self buttonNewProject}.
	}) layoutInset: 6.
	self addARow: {
		self transparentSpacerOfSize:0@6.
	}.
	(self addARow: {
		self inAColumn: {self buttonPublish}.
	}) layoutInset: 6.
	self addARow: {
		self transparentSpacerOfSize:0@18.
	}.
	(self addARow: {
		self inAColumn: {self buttonQuit}.
	}) layoutInset: 6.

! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'mir 10/4/2000 14:12'!
amountToShowWhenSmall
	^49! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 13:56'!
colorForButtons

	^Color r: 0.613 g: 0.71 b: 1.0 ! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'nk 7/12/2003 08:46'!
fontForButtons

	^Preferences standardEToysFont! !


!KidNavigationMorph methodsFor: 'event handling' stamp: 'RAA 9/26/2000 12:29'!
handlesMouseDown: evt

	^true
	! !

!KidNavigationMorph methodsFor: 'event handling' stamp: 'RAA 9/26/2000 12:28'!
mouseEnter: evt

	"kid nav doesn't care"
	! !

!KidNavigationMorph methodsFor: 'event handling' stamp: 'RAA 9/26/2000 12:28'!
mouseLeave: evt

	"kid nav doesn't care"
	! !

!KidNavigationMorph methodsFor: 'event handling' stamp: 'RAA 9/26/2000 12:30'!
mouseUp: evt

	mouseInside _ (mouseInside ifNil: [false]) not.
	self positionVertically
	! !


!KidNavigationMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:35'!
defaultColor
	"answer the default color/fill style for the receiver"
	| result |
	result _ GradientFillStyle ramp: {0.0
					-> (Color
							r: 0.032
							g: 0.0
							b: 0.484). 1.0
					-> (Color
							r: 0.194
							g: 0.032
							b: 1.0)}.
	result origin: self bounds topLeft.
	result direction: 0 @ 200.
	result radial: false.
	^ result! !

!KidNavigationMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:35'!
initialize
	"initialize the state of the receiver"
	| |
	super initialize.
	""
	self layoutInset: 12.

	self removeAllMorphs.
	self addButtons! !


!KidNavigationMorph methodsFor: 'stepping and presenter' stamp: 'RAA 9/28/2000 18:27'!
step

	super step.
	PreExistingProjects ifNil: [PreExistingProjects _ WeakArray withAll: Project allProjects].! !


!KidNavigationMorph methodsFor: 'the actions' stamp: 'RAA 9/28/2000 19:00'!
quitSqueak

	| newProjects limit now msg response |

	Preferences checkForUnsavedProjects ifFalse: [^super quitSqueak].
	PreExistingProjects ifNil: [^super quitSqueak].
	limit _ 5 * 60.
	now _ Time totalSeconds.
	newProjects _ Project allProjects reject: [ :each | PreExistingProjects includes: each].
	newProjects _ newProjects reject: [ :each | 
		((each lastSavedAtSeconds ifNil: [0]) - now) abs < limit
	].
	newProjects isEmpty ifTrue: [^super quitSqueak].
	msg _ String streamContents: [ :strm |
		strm nextPutAll: 'There are some project(s)
that have not been saved recently:
----
'.
		newProjects do: [ :each | strm nextPutAll: each name; cr].
		strm nextPutAll: '----
What would you like to do?'
	].
	response _ PopUpMenu 
		confirm: msg
		trueChoice: 'Go ahead and QUIT'
		falseChoice: 'Wait, let me save them first'.
	response ifTrue: [^super quitSqueak].

! !
FloatArray variableWordSubclass: #KlattFrame
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!
!KlattFrame commentStamp: '<historical>' prior: 0!
My instances are frames of parameters which are inputs for KlattSynthesizers. See the class method category 'documentation' for more details.!


!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a1v
	^ self at: 47! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a1v: aNumber
	self at: 47 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a2f
	^ self at: 35! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a2f: aNumber
	self at: 35 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a2v
	^ self at: 48! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a2v: aNumber
	self at: 48 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a3f
	^ self at: 36! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a3f: aNumber
	self at: 36 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a3v
	^ self at: 49! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a3v: aNumber
	self at: 49 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a4f
	^ self at: 37! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a4f: aNumber
	self at: 37 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a4v
	^ self at: 50! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a4v: aNumber
	self at: 50 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a5f
	^ self at: 38! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a5f: aNumber
	self at: 38 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a6f
	^ self at: 39! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a6f: aNumber
	self at: 39 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
anv
	^ self at: 46! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
anv: aNumber
	self at: 46 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
aspiration
	^ self at: 10! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
aspiration: aNumber
	self at: 10 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
atv
	^ self at: 51! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
atv: aNumber
	self at: 51 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b1
	^ self at: 14! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b1: aNumber
	self at: 14 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b2
	^ self at: 18! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b2: aNumber
	self at: 18 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b2f
	^ self at: 41! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b2f: aNumber
	self at: 41 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b3
	^ self at: 20! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b3: aNumber
	self at: 20 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b3f
	^ self at: 42! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b3f: aNumber
	self at: 42 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b4
	^ self at: 22! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b4: aNumber
	self at: 22 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b4f
	^ self at: 43! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b4f: aNumber
	self at: 43 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b5
	^ self at: 24! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b5: aNumber
	self at: 24 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b5f
	^ self at: 44! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b5f: aNumber
	self at: 44 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b6
	^ self at: 26! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b6: aNumber
	self at: 26 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b6f
	^ self at: 45! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b6f: aNumber
	self at: 45 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bnp
	^ self at: 28! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bnp: aNumber
	self at: 28 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bnz
	^ self at: 30! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bnz: aNumber
	self at: 30 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
btp
	^ self at: 32! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
btp: aNumber
	self at: 32 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
btz
	^ self at: 34! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
btz: aNumber
	self at: 34 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bypass
	^ self at: 40! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bypass: aNumber
	self at: 40 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
db1
	^ self at: 16! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
db1: aNumber
	self at: 16 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
df1
	^ self at: 15! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
df1: aNumber
	self at: 15 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
diplophonia
	^ self at: 5! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
diplophonia: aNumber
	self at: 5 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f0
	^ self at: 1! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f0: aNumber
	self at: 1 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f1
	^ self at: 13! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f1: aNumber
	self at: 13 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f2
	^ self at: 17! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f2: aNumber
	self at: 17 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f3
	^ self at: 19! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f3: aNumber
	self at: 19 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f4
	^ self at: 21! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f4: aNumber
	self at: 21 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f5
	^ self at: 23! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f5: aNumber
	self at: 23 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f6
	^ self at: 25! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f6: aNumber
	self at: 25 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
flutter
	^ self at: 2! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
flutter: aNumber
	self at: 2 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
fnp
	^ self at: 27! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
fnp: aNumber
	self at: 27 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
fnz
	^ self at: 29! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
fnz: aNumber
	self at: 29 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
friction
	^ self at: 11! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
friction: aNumber
	self at: 11 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
ftp
	^ self at: 31! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
ftp: aNumber
	self at: 31 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
ftz
	^ self at: 33! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
ftz: aNumber
	self at: 33 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
gain
	^ self at: 52! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
gain: aNumber
	self at: 52 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
jitter
	^ self at: 3! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
jitter: aNumber
	self at: 3 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
ra
	^ self at: 8! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
ra: aNumber
	self at: 8 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
rk
	^ self at: 9! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
rk: aNumber
	self at: 9 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
ro
	^ self at: 7! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
ro: aNumber
	self at: 7 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
shimmer
	^ self at: 4! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
shimmer: aNumber
	self at: 4 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
turbulence
	^ self at: 12! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
turbulence: aNumber
	self at: 12 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
voicing
	^ self at: 6! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
voicing: aNumber
	self at: 6 put: aNumber! !


!KlattFrame methodsFor: 'editing' stamp: 'len 12/17/1999 03:35'!
edit
	^ KlattFrameMorph new
		frame: self;
		addTestButton;
		openInWorld! !


!KlattFrame methodsFor: 'playing' stamp: 'len 12/17/1999 03:33'!
play
	(KlattSynthesizer new cascade: 6; millisecondsPerFrame: 1000; soundFromFrames: {self}) play! !


!KlattFrame methodsFor: 'printing' stamp: 'len 9/1/1999 23:36'!
printOn: aStream
	self class parameterNames do: [ :each |
		aStream
			nextPutAll: each;
			nextPut: $=; 
			print: (self perform: each);
			space]! !

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

KlattFrame class
	instanceVariableNames: ''!

!KlattFrame class methodsFor: 'code generation' stamp: 'stephaneducasse 2/3/2006 22:23'!
generateAccessors
	"
	KlattFrame generateAccessors
	"
	| crtab getter setter |
	crtab := String with: Character cr with: Character tab.
	self parameterNames
		doWithIndex: [ :selector :i |
			getter := selector, crtab, '^ self at: ', i printString.
			setter := selector, ': aNumber', crtab, 'self at: ', i printString,' put: aNumber'.
			self compile: getter classified: 'accessing'.
			self compile: setter classified: 'accessing']! !


!KlattFrame class methodsFor: 'documentation' stamp: 'len 12/20/1999 01:49'!
defaultForParameter: aSymbol
	^ self default perform: aSymbol asSymbol! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 11/29/1999 02:10'!
descriptionForParameter: aSymbol
	^ (self parameterData detect: [ :one | one first = aSymbol]) at: 4! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 11/29/1999 02:10'!
maximumForParameter: aSymbol
	^ (self parameterData detect: [ :one | one first = aSymbol]) at: 3! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 11/29/1999 02:10'!
minimumForParameter: aSymbol
	^ (self parameterData detect: [ :one | one first = aSymbol]) at: 2! !

!KlattFrame class methodsFor: 'documentation' stamp: 'dd 10/31/2005 09:02'!
parameterData
	"This is a table describing the Klatt parameters. The columns are: parameter name, minimum value, maximum, parameter description, unit."
	^ #(
	"Excitation source (voice, aspiration and friction):"
		(f0 20 1000 'Fundamental frequency (hz)' hz)
		(flutter 0 1 'Amount of flutter' value)
		(jitter 0 1 'Amount of jitter' value)
		(shimmer 0 1 'Amount of shimmer' value)
		(diplophonia 0 1 'Amount of diplophonia' value)
		(voicing 0 80 'Amplitude of voicing' hz)
		(ro 0.01 1 'Relative duration of open phase of voicing waveform = Te/T0 (0.01 - 1)' value)
		(ra 0.01 0.2 'Relative duration of return phase of voicing waveform = Ta/T0 (0.01 - 1)' value)
		(rk 0.01 1 'Simmetry of the glottal pulse = (Te-Tp)/Tp (0.01 - 1)' value)
		(aspiration 0 80 'Amplitude of aspiration' dB)
		(friction 0 80 'Amplitude of friction' dB)
		(turbulence 0 80 'Amplitude of turbulence (in open glottal phase)' dB)

	"Formants frequencies and bandwidths:"	
		(f1 200 1300 'Frequency of 1st formant' hz)
		(b1 40 1000 'Bandwidth of 1st formant' hz)
		(df1 0 100 'Change in F1 during open portion of period' hz)
		(db1 0 400 'Change in B1 during open portion of period' hz)
		(f2 550 3000 'Frequency of 2nd formant' hz)
		(b2 40 1000 'Bandwidth of 2nd formant' hz)
		(f3 1200 4999 'Frequency of 3rd formant' hz)
		(b3 40 1000 'Bandwidth of 3rd formant' hz)
		(f4 1200 4999 'Frequency of 4th formant' hz)
		(b4 40 1000 'Bandwidth of 4th formant' hz)
		(f5 1200 4999 'Frequency of 5th formant' hz)
		(b5 40 1000 'Bandwidth of 5th formant' hz)
		(f6 1200 4999 'Frequency of 6th formant' hz)
		(b6 40 1000 'Bandwidth of 6th formant' hz)
		(fnp 248 528 'Frequency of nasal pole' hz)
		(bnp 40 1000 'Bandwidth of nasal pole' hz)
		(fnz 248 528 'Frequency of nasal zero' hz)
		(bnz 40 1000 'Bandwidth of nasal zero' hz)
		(ftp 300 3000 'Frequency of tracheal pole' hz)
		(btp 40 1000 'Bandwidth of tracheal pole' hz)
		(ftz 300 3000 'Frequency of tracheal zero' hz)
		(btz 40 2000 'Bandwidth of tracheal zero' hz)

	"Parallel Friction-Excited:"
		(a2f 0 80 'Amplitude of friction-excited parallel 2nd formant' dB)
		(a3f 0 80 'Amplitude of friction-excited parallel 3rd formant' dB)
		(a4f 0 80 'Amplitude of friction-excited parallel 4th formant' dB)
		(a5f 0 80 'Amplitude of friction-excited parallel 5th formant' dB)
		(a6f 0 80 'Amplitude of friction-excited parallel 6th formant' dB)
		(bypass 0 80 'Amplitude of friction-excited parallel bypass path' dB)
		(b2f 40 1000 'Bandwidth of friction-excited parallel 2nd formant' hz)
		(b3f 60 1000 'Bandwidth of friction-excited parallel 2nd formant' hz)
		(b4f 100 1000 'Bandwidth of friction-excited parallel 2nd formant' hz)
		(b5f 100 1500 'Bandwidth of friction-excited parallel 2nd formant' hz)
		(b6f 100 4000 'Bandwidth of friction-excited parallel 2nd formant' hz)

	"Parallel Voice-Excited:"
		(anv 0 80 'Amplitude of voice-excited parallel nasal formant' dB)
		(a1v 0 80 'Amplitude of voice-excited parallel 1st formant' dB)
		(a2v 0 80 'Amplitude of voice-excited parallel 2nd formant' dB)
		(a3v 0 80 'Amplitude of voice-excited parallel 3rd formant' dB)
		(a4v 0 80 'Amplitude of voice-excited parallel 4th formant' dB)
		(atv 0 80 'Amplitude of voice-excited parallel tracheal formant' dB)

	"Overall gain:"
		(gain 0 80 'Overall gain' dB))! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 9/27/1999 02:21'!
parameterNames
	^ self parameterData collect: [ :each | each first]! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 11/29/1999 02:10'!
unitForParameter: aSymbol
	^ (self parameterData detect: [ :one | one first = aSymbol]) at: 5! !


!KlattFrame class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
example1
	"
	KlattFrame example1.
	KlattFrame example2.
	KlattFrame example3
	"
	| frame |
	frame := self default
		voicing: 62;
		anv: 0; a1v: 0; a2v: 0; a3v: 0; a4v: 0;
		yourself.
	(KlattSynthesizer new cascade: 6; millisecondsPerFrame: 1000; soundFromFrames: {frame}) play! !

!KlattFrame class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
example2
	"
	KlattFrame example2
	"
	| frame |
	frame := self default
		voicing: 62;
		anv: 0; a1v: 62; a2v: 62; a3v: 62; a4v: 62;
		yourself.
	(KlattSynthesizer new cascade: 6; millisecondsPerFrame: 1000; soundFromFrames: {frame}) play! !

!KlattFrame class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
example3
	"
	KlattFrame example3
	"
	| frame |
	frame := self default
		voicing: 62;
		anv: 0; a1v: 62; a2v: 62; a3v: 62; a4v: 62;
		yourself.
	(KlattSynthesizer new cascade: 0; millisecondsPerFrame: 1000; soundFromFrames: {frame}) play! !


!KlattFrame class methodsFor: 'instance creation' stamp: 'len 12/17/1999 03:34'!
default
	"
	KlattFrame default edit
	"
	^ self new
		f0: 133;
		flutter: 0; jitter: 0; shimmer: 0; diplophonia: 0;
		voicing: 62;
		ro: 0.4; ra: 0.01; rk: 0.25;
		aspiration: 0;
		friction: 0;
		turbulence: 0;
		f1: 500;		b1: 60;
		df1: 0;		db1: 0;
		f2: 1500;		b2: 90;
		f3: 2800;	b3: 150;
		f4: 3250;	b4: 200;
		f5: 3700;	b5: 200;
		f6: 4990;	b6: 500;
		fnp: 280;	bnp: 90;
		fnz: 280;	bnz: 90;
		ftp: 2150;	btp: 180;
		ftz: 2150;	btz: 180;
		a2f: 52.5;	b2f: 200;
		a3f: 39.3;	b3f: 350;
		a4f: 25.4;	b4f: 500;
		a5f: 0;		b5f: 600;
		a6f: 0;		b6f: 800;
		bypass: 0;
		anv: 0;
		a1v: 60.3;
		a2v: 52.5;
		a3v: 39.3;
		a4v: 25.4;
		atv: 0;
		gain: 62! !

!KlattFrame class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/3/2006 22:23'!
fromArray: anArray
	| answer |
	answer := self new.
	anArray doWithIndex: [ :each :i | answer at: i put: each].
	^ answer! !

!KlattFrame class methodsFor: 'instance creation' stamp: 'hmm 5/7/1999 22:00'!
fromString: aString
	^ self fromArray: (aString substrings collect: [ :each | each asNumber])! !

!KlattFrame class methodsFor: 'instance creation' stamp: 'len 11/22/1999 02:38'!
new
	^ super new: 52! !
AlignmentMorph subclass: #KlattFrameMorph
	instanceVariableNames: 'frame lastSnapshot glottal'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 12/2/1999 02:57'!
addSliderForParameter: parameter target: target min: min max: max description: description
	self addMorphFront: (self newSliderForParameter: parameter target: target min: min max: max description: description)! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
addSlidersForParameters: params
	| left right container current slider |
	params size < 10
		ifTrue: [left := right := self]
		ifFalse: [container := AlignmentMorph new color: self color; listDirection: #leftToRight.
				left := container clone listDirection: #topToBottom.
				right := left clone.
				container addMorphBack: left; addMorphBack: right.
				self addMorphBack: container].
	params do: [ :each |
		current := current == left ifTrue: [right] ifFalse: [left].
		slider := self newSliderNamed: each min: (KlattFrame minimumForParameter: each) max: (KlattFrame maximumForParameter: each).
		slider setBalloonText: (KlattFrame descriptionForParameter: each).
		current addMorphBack: slider]! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 10/1/1999 01:25'!
addTestButton
	self addMorphBack: (SimpleButtonMorph new target: self; actWhen: #buttonDown; actionSelector:  #playTest; labelString: 'play')! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:35'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.452
		g: 0.935
		b: 0.548! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 9/27/1999 02:25'!
frame: aKlattFrame
	self frame: aKlattFrame edit: KlattFrame parameterNames! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
frame: aKlattFrame edit: params
	frame := aKlattFrame.
	self addSlidersForParameters: params.
	(params detect: [ :one | #(ro ra rk) includes: one] ifNone: []) notNil
		ifTrue: [glottal := GraphMorph new extent: 210 @ 100.
				glottal setBalloonText: 'Glottal pulse'.
				self addMorphBack: glottal]! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'nk 2/19/2004 16:55'!
initialize
	super initialize.
	self listDirection: #topToBottom.
	self layoutInset: 6; cellInset: 4.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
newSliderForParameter: parameter target: target min: min max: max description: description
	| r slider m |
	r := AlignmentMorph newRow.
	r color: self color; borderWidth: 0; layoutInset: 0.
	r hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@20; wrapCentering: #center; cellPositioning: #leftCenter; cellInset: 4@0.

	slider := SimpleSliderMorph new
		color: (Color r: 0.065 g: 0.548 b: 0.645);
		extent: 120@2;
		target: target;
		actionSelector: (parameter, ':') asSymbol;
		minVal: min;
		maxVal: max;
		adjustToValue: (target perform: parameter asSymbol).
	r addMorphBack: slider.

	m := StringMorph new contents: parameter, ': '; hResizing: #rigid.
	r addMorphBack: m.
	m := UpdatingStringMorph new
		target: target; getSelector: parameter asSymbol; putSelector: (parameter, ':') asSymbol;
		width: 60; growable: false; floatPrecision: (max - min / 100.0 min: 1.0); vResizing: #spaceFill; step.
	r addMorphBack: m.
	r setBalloonText: description.
	^ r! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 12/2/1999 02:59'!
newSliderNamed: name min: min max: max
	^ self newSliderForParameter: name target: frame min: min max: max description: ''! !


!KlattFrameMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/3/2006 22:22'!
playTest
	| synth |
	synth := KlattSynthesizer new.
	synth millisecondsPerFrame: 1000; cascade: 8.
	(SampledSound samples: (synth samplesFromFrames: {frame}) samplingRate: synth samplingRate) play! !


!KlattFrameMorph methodsFor: 'stepping and presenter' stamp: 'stephaneducasse 2/3/2006 22:22'!
step
	| lf |
	lastSnapshot = frame ifTrue: [^ self].
	lastSnapshot := frame clone.
	lf := LiljencrantsFant new
		t0: 1 / frame f0 ro: frame ro rk: frame rk ra: frame ra samplingRate: 44000.
	glottal data: lf init samples! !


!KlattFrameMorph methodsFor: 'testing' stamp: 'len 9/27/1999 02:51'!
stepTime
	^ 500! !
SharedPool subclass: #KlattResonatorIndices
	instanceVariableNames: ''
	classVariableNames: 'R1c R1vp R2c R2fp R2vp R3c R3fp R3vp R4c R4fp R4vp R5c R5fp R6c R6fp R7c R8c Rnpc Rnpp Rnz Rout Rtpc Rtpp Rtz'
	poolDictionaries: ''
	category: 'Speech-Klatt'!

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

KlattResonatorIndices class
	instanceVariableNames: ''!

!KlattResonatorIndices class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 20:17'!
initialize
	"KlattResonatorIndices initialize"
	Rnpp := 1.
	Rtpp := 2.
	R1vp := 3.
	R2vp := 4.
	R3vp := 5.
	R4vp := 6.
	R2fp := 7.
	R3fp := 8.
	R4fp := 9.
	R5fp := 10.
	R6fp := 11.
	R1c := 12.
	R2c := 13.
	R3c := 14.
	R4c := 15.
	R5c := 16.
	R6c := 17.
	R7c := 18.
	R8c := 19.
	Rnpc := 20.
	Rnz := 21.
	Rtpc := 22.
	Rtz := 23.
	Rout := 24.! !
Object subclass: #KlattSegment
	instanceVariableNames: 'name features rank duration parameters'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 23:58'!
addParameter: aKlattSegmentParameter
	^ self parameters at: aKlattSegmentParameter selector put: aKlattSegmentParameter! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 01:51'!
duration
	^ duration! !

!KlattSegment methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
duration: aNumber
	duration := aNumber! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 11/22/1999 01:07'!
features
	^ features! !

!KlattSegment methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
features: aCollection
	features := aCollection! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 02:56'!
name
	^ name! !

!KlattSegment methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
name: aString
	name := aString! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 01:50'!
parameters
	^ parameters! !

!KlattSegment methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
parameters: aDictionary
	parameters := aDictionary! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 01:49'!
rank
	^ rank! !

!KlattSegment methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
rank: aNumber
	rank := aNumber! !


!KlattSegment methodsFor: 'initialization' stamp: 'len 10/9/1999 02:14'!
initialize
	self parameters: Dictionary new! !


!KlattSegment methodsFor: 'message dispatching' stamp: 'stephaneducasse 2/3/2006 22:22'!
doesNotUnderstand: aMessage
	| sel |
	(parameters includesKey: (sel := (aMessage selector copyWith: $:) asSymbol))
		ifTrue: [^ parameters at: sel].
	^ super doesNotUnderstand: aMessage! !


!KlattSegment methodsFor: 'printing' stamp: 'stephaneducasse 2/3/2006 22:22'!
compileOn: aClass
	| stream |
	stream := WriteStream on: ''.
	self methodPrintOn: stream.
	aClass compile: stream contents classified: 'default segments'! !

!KlattSegment methodsFor: 'printing' stamp: 'stephaneducasse 2/3/2006 22:22'!
methodPrintOn: aStream
	| param |
	aStream print: self name; cr;
		tab; nextPutAll: '^ self segmentFromArray: '; cr;
		tab; tab; nextPutAll: '"name	rank	duration	features"'; cr;
		tab; tab; nextPutAll: '#('; print: self name; tab; tab; print: self rank; tab; tab; print: self duration; tab; tab; tab; print: (self features ifNil: [#()]); cr;
		tab; tab; nextPutAll: '"selector		steady	fixed	prop	extern	intern"'.
	KlattFrame parameterNames do: [ :each |
		(param := self parameters at: (each, ':') asSymbol ifAbsent: [])
			ifNotNil: [aStream cr; tab; tab.
					param methodPrintOn: aStream]].
	aStream nextPut: $)! !

!KlattSegment methodsFor: 'printing' stamp: 'stephaneducasse 2/3/2006 22:22'!
methodString
	| stream |
	stream := WriteStream on: ''.
	self methodPrintOn: stream.
	^ stream contents! !

!KlattSegment methodsFor: 'printing' stamp: 'len 12/6/1999 03:59'!
printOn: aStream
	aStream nextPutAll: self name! !


!KlattSegment methodsFor: 'processing' stamp: 'len 12/2/1999 01:55'!
cosine: a with: b time: time duration: dur
	time <= 0 ifTrue: [^ a].
	time >= dur ifTrue: [^ b].
	^ ((time / dur * Float pi) cos - 1 / -2.0) * (b - a) + a! !

!KlattSegment methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
interpolate: slope1 with: slope2 mid: mid time: time speed: speed
	| steady p1 p2 |
	steady := self duration * speed - (slope1 x + slope2 x).
	steady < 0 "steady state cannot be reached"
		ifTrue: [p1 := self linear: slope1 y with: mid time: time duration: slope1 x.
				p2 := self linear: slope2 y with: mid time: self duration * speed - time duration: slope2 x.
				^ p2 - p1 * time / (self duration * speed) + p1].
	time < slope1 x
		ifTrue: [^ self linear: slope1 y with: mid time: time duration: slope1 x].
	^ time - slope1 x <= steady "steady state reached"
		ifTrue: [mid]
		ifFalse: [self linear: mid with: slope2 y time: time - slope1 x - steady duration: slope2 x]! !

!KlattSegment methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
left: left right: right speed: speed pattern: patternFrame
	| frames leftSlope rightSlope value |
	frames := (1 to: self duration * speed) collect: [ :each | patternFrame clone].
	self parameters do: [ :each |
		leftSlope := self slopeWith: left selector: each selector speed: speed.
		rightSlope := self slopeWith: right selector: each selector speed: speed.
		0 to: self duration * speed - 1 do: [ :time |
			value := self interpolate: leftSlope with: rightSlope mid: each steady time: time speed: speed.
			(frames at: (time + 1) asInteger) perform: each selector with: value]].
	^ frames! !

!KlattSegment methodsFor: 'processing' stamp: 'len 12/6/1999 03:51'!
linear: a with: b time: time duration: dur
	time <= 0 ifTrue: [^ a].
	time >= dur ifTrue: [^ b].
	^ b - a * time / dur + a! !

!KlattSegment methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
slopeWith: aKlattSegment selector: selector speed: speed
	| me other |
	me := self parameters at: selector.
	other := aKlattSegment parameters at: selector.
	^ (self dominates: aKlattSegment)
		ifTrue: [me slopeWithDominated: other speed: speed]
		ifFalse: [me slopeWithDominant: other speed: speed]! !


!KlattSegment methodsFor: 'testing' stamp: 'len 10/12/1999 01:12'!
dominates: aKlattSegment
	"Answer true if the receiver dominates the argument,
	i.e. if the receiver has greater rank than the argument."

	^ self rank > aKlattSegment rank! !
Object subclass: #KlattSegmentParameter
	instanceVariableNames: 'selector steady fixed proportion internal external'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:09'!
external
	^ external! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
external: aNumber
	external := aNumber! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 12/5/1999 23:22'!
fixed
	^ fixed! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
fixed: aNumber
	fixed := aNumber! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:09'!
internal
	^ internal! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
internal: aNumber
	internal := aNumber! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:08'!
proportion
	^ proportion! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
proportion: aNumber
	proportion := aNumber! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 23:52'!
selector
	^ selector! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
selector: aSymbol
	selector := aSymbol asSymbol! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:08'!
steady
	^ steady! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
steady: aNumber
	steady := aNumber! !


!KlattSegmentParameter methodsFor: 'printing' stamp: 'len 12/5/1999 23:35'!
methodPrintOn: aStream
	aStream nextPut: $(; print: self selector; tab.
	self selector size < 4 ifTrue: [aStream tab].
	self selector size < 8 ifTrue: [aStream tab].
	aStream print: self steady; tab; tab; print: self fixed; tab; tab; print: self proportion; tab; tab; print: self external; tab; tab; print: self internal; nextPut: $)! !

!KlattSegmentParameter methodsFor: 'printing' stamp: 'len 10/10/1999 00:22'!
printOn: aStream
	aStream nextPutAll: self selector; space; print: self steady! !


!KlattSegmentParameter methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
slopeWith: parameter dominant: dominant speed: speed
	| dominated time value |
	dominated := self == dominant ifTrue: [parameter] ifFalse: [self].
	time := dominant == self ifTrue: [dominant internal] ifFalse: [dominant external].
	time := time * speed.
	value := time ~= 0
		ifTrue: [dominant proportion * dominated steady * 0.01 + dominant fixed]
		ifFalse: [dominated steady].
	^ time @ value! !

!KlattSegmentParameter methodsFor: 'processing' stamp: 'len 12/6/1999 03:15'!
slopeWithDominant: parameter speed: speed
	^ self slopeWith: parameter dominant: parameter speed: speed! !

!KlattSegmentParameter methodsFor: 'processing' stamp: 'len 12/6/1999 03:16'!
slopeWithDominated: parameter speed: speed
	^ self slopeWith: parameter dominant: self speed: speed! !
Object subclass: #KlattSegmentSet
	instanceVariableNames: 'phonemes segments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!
!KlattSegmentSet commentStamp: '<historical>' prior: 0!
My instances are sets of KlattSegments, and they map phonemes to actual KlattSegments. The default segments are adapted from rsynth 2.0, a public domain TTS.!


!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 10/12/1999 00:48'!
at: aPhoneme
	^ self segments at: aPhoneme! !

!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 10/12/1999 00:53'!
at: aPhoneme ifAbsent: aBlock
	^ self segments at: aPhoneme ifAbsent: aBlock! !

!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 10/12/1999 00:48'!
phonemes
	^ phonemes! !

!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 10/12/1999 00:48'!
segments
	^ segments! !

!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 12/6/1999 03:58'!
silence
	self phonemes do: [ :each | each isSilence ifTrue: [^ self at: each]].
	self error: 'silence segment not found'! !


!KlattSegmentSet methodsFor: 'accessing-private' stamp: 'stephaneducasse 2/3/2006 22:22'!
phonemes: aPhonemeSet
	phonemes := aPhonemeSet! !

!KlattSegmentSet methodsFor: 'accessing-private' stamp: 'stephaneducasse 2/3/2006 22:22'!
segments: aDictionary
	segments := aDictionary! !


!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
a
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(a		2		4			(cnt mdl unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1480		710.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		64.75		31.5		50		4		4)
		(a3f:		47.25		24.5		50		4		4)
		(a4f:		40.25		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		64.75		31.5		50		4		4)
		(a3v:		47.25		24.5		50		4		4)
		(a4v:		40.25		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
aa
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(aa		2		5			(fnt low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			790		410.0		50		4		4)
		(b1:			130		65.0		50		4		4)
		(f2:			1780		950.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		61.25		31.5		50		4		4)
		(a3f:		52.5		24.5		50		4		4)
		(a4f:		45.5		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		61.25		31.5		50		4		4)
		(a3v:		52.5		24.5		50		4		4)
		(a4v:		45.5		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ai
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ai		2		6			(fnt lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			640		290.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			1600		830.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		5		5)
		(a3f:		49		24.5		50		5		5)
		(a4f:		43.75		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		59.5		28.0		50		5		5)
		(a3v:		49		24.5		50		5		5)
		(a4v:		43.75		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
air
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(air		2		6			(fnt lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			640		350.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			2020		1070.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		5		5)
		(a3f:		52.5		24.5		50		5		5)
		(a4f:		45.5		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		56		28.0		50		5		5)
		(a3v:		52.5		24.5		50		5		5)
		(a4v:		45.5		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ar
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ar		2		15			(bck low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			790		410.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			880		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		63		31.5		50		4		4)
		(a3f:		43.75		21.0		50		4		4)
		(a4f:		36.75		17.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		63		31.5		50		4		4)
		(a3v:		43.75		21.0		50		4		4)
		(a4v:		36.75		17.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
aw
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(aw		2		10			(bck lmd rnd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			820		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		4		4)
		(a3f:		36.75		17.5		50		4		4)
		(a4f:		31.5		14.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		59.5		28.0		50		4		4)
		(a3v:		36.75		17.5		50		4		4)
		(a4v:		31.5		14.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
b
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(b		26		12			(blb stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			760		350.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2500		0.0		100		0		2)
		(b3:			150		0.0		100		0		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		0.0		100		0		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		38.5		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
by
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(by		29		1			(blb stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			760		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2500		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		63		0.0		100		0		0)
		(a3f:		57.25		0.0		100		0		0)
		(a4f:		52.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		38.5		0.0		100		0		0)
		(a2v:		63		0.0		100		0		0)
		(a3v:		57.25		0.0		100		0		0)
		(a4v:		52.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
bz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(bz		26		0			(blb stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		0)
		(b1:			60		30.0		50		2		0)
		(f2:			760		350.0		50		2		0)
		(b2:			90		45.0		50		2		0)
		(f3:			2500		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ch
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ch		23		4			(alv stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			1780		950.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2680		2680.0		0		2		2)
		(b3:			150		150.0		0		2		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		150.0		0		2		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ci
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ci		18		8			(frc pla vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			2020		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		45.5		0.0		100		0		0)
		(a3f:		56		0.0		100		0		0)
		(a4f:		45.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		45.5		0.0		100		0		0)
		(a3v:		56		0.0		100		0		0)
		(a4v:		45.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
d
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(d		26		8			(alv stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			1780		950.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2680		2680.0		0		2		2)
		(b3:			150		150.0		0		2		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		150.0		0		2		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		45.5		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/8/1999 22:08'!
dh
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(dh		20		4			(dnt frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	36		18.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1600		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		45.5		0.0		100		0		0)
		(a3f:		40.25		0.0		100		0		0)
		(a4f:		42		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:	54		27.0		50		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		45.5		0.0		100		0		0)
		(a3v:		40.25		0.0		100		0		0)
		(a4v:		42		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
di
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(di		20		4			(dnt frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1600		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		45.5		0.0		100		0		0)
		(a3f:		40.25		0.0		100		0		0)
		(a4f:		42		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		45.5		0.0		100		0		0)
		(a3v:		40.25		0.0		100		0		0)
		(a4v:		42		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
dy
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(dy		29		1			(alv stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1780		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2680		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		52.5		0.0		100		0		0)
		(a3f:		49		0.0		100		0		0)
		(a4f:		59.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		52.5		0.0		100		0		0)
		(a2v:		52.5		0.0		100		0		0)
		(a3v:		49		0.0		100		0		0)
		(a4v:		59.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
dz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(dz		26		1			(alv stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		0)
		(b1:			60		30.0		50		2		0)
		(f2:			1780		950.0		50		2		0)
		(b2:			90		45.0		50		2		0)
		(f3:			2680		2680.0		0		2		0)
		(b3:			150		150.0		0		2		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		42		0.0		100		0		0)
		(a3f:		38.5		0.0		100		0		0)
		(a4f:		49		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		0)
		(b3f:		150		150.0		0		2		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		52.5		0.0		100		0		0)
		(a2v:		42		0.0		100		0		0)
		(a3v:		38.5		0.0		100		0		0)
		(a4v:		49		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
e
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(e		2		4			(fnt lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			640		350.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			2020		1070.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		4		4)
		(a3f:		52.5		24.5		50		4		4)
		(a4f:		45.5		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		56		28.0		50		4		4)
		(a3v:		52.5		24.5		50		4		4)
		(a4v:		45.5		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ee
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ee		2		7			(fnt hgh unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			250		110.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			2320		1190.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			3200		1580.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		47.25		24.5		50		4		4)
		(a3f:		50.75		24.5		50		4		4)
		(a4f:		45.5		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		47.25		24.5		50		4		4)
		(a3v:		50.75		24.5		50		4		4)
		(a4v:		45.5		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/22/1999 03:07'!
end
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(end		31		5			(0 )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1480		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2500		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		3		3)
		(a2f:		-16		-10.5		100		3		0)
		(a3f:		-16		-10.5		100		3		0)
		(a4f:		-16		-10.5		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		-10.5		100		3		0)
		(a1v:		-16		-10.5		100		3		0)
		(a2v:		-16		-10.5		100		3		0)
		(a3v:		-16		-10.5		100		3		0)
		(a4v:		-16		-10.5		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
er
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(er		2		16			(cnt lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			580		290.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1420		710.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		4		4)
		(a3f:		47.25		24.5		50		4		4)
		(a4f:		40.25		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		59.5		28.0		50		4		4)
		(a3v:		47.25		24.5		50		4		4)
		(a4v:		40.25		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/8/1999 22:08'!
f
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(f		18		12			(frc lbd vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	32		16.0		50		0		0)
		(friction:	54		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1420		350.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		980.0		50		3		2)
		(b3:			150		75.0		50		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		14		0.0		100		0		0)
		(a3f:		14		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:	54		27.0		50		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		75.0		50		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		14		0.0		100		0		0)
		(a3v:		14		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
g
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(g		26		12			(stp vcd vel )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		3		3)
		(b1:			60		30.0		50		3		3)
		(f2:			1480		1550.0		50		3		3)
		(b2:			90		45.0		50		3		3)
		(f3:			2620		1580.0		50		3		3)
		(b3:			150		75.0		50		3		3)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		3)
		(b3f:		150		75.0		50		3		3)
		(anv:		-16		0.0		100		0		0)
		(a1v:		49		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
gy
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(gy		29		1			(stp vcd vel )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1480		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2620		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		0.0		100		0		0)
		(a3f:		54.25		0.0		100		0		0)
		(a4f:		38.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		49		0.0		100		0		0)
		(a2v:		59.5		0.0		100		0		0)
		(a3v:		54.25		0.0		100		0		0)
		(a4v:		38.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
gz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(gz		26		2			(stp vcd vel )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1480		1550.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2620		1580.0		50		3		2)
		(b3:			150		75.0		50		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		49		0.0		100		0		0)
		(a3f:		43.75		0.0		100		0		0)
		(a4f:		28		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		75.0		50		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		49		0.0		100		0		0)
		(a2v:		49		0.0		100		0		0)
		(a3v:		43.75		0.0		100		0		0)
		(a4v:		28		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
h
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(h		9		10			(apr glt )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			490		0.0		100		0		7)
		(b1:			60		0.0		100		0		7)
		(f2:			1480		0.0		100		0		7)
		(b2:			90		0.0		100		0		7)
		(f3:			2500		0.0		100		0		7)
		(b3:			150		0.0		100		0		7)
		(fnz:		270		135.0		50		0		0)
		(a2f:		50.75		-14.0		100		0		7)
		(a3f:		40.25		-7.0		100		0		7)
		(a4f:		36.75		-3.5		100		0		7)
		(a5f:		-16		0.0		100		0		7)
		(a6f:		-16		0.0		100		0		7)
		(bypass:		-16		0.0		100		0		7)
		(b2f:		90		0.0		100		0		7)
		(b3f:		150		0.0		100		0		7)
		(anv:		-16		0.0		100		0		7)
		(a1v:		49		-14.0		100		0		7)
		(a2v:		50.75		-14.0		100		0		7)
		(a3v:		40.25		-7.0		100		0		7)
		(a4v:		36.75		-3.5		100		0		7))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
i
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(i		2		6			(fnt smh unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			400		170.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			2080		1070.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2560		1340.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		50.75		24.5		50		4		4)
		(a3f:		49		24.5		50		4		4)
		(a4f:		43.75		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		50.75		24.5		50		4		4)
		(a3v:		49		24.5		50		4		4)
		(a4v:		43.75		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ia
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ia		2		6			(fnt smh unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			310		170.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			2200		1070.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2920		1460.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		49		24.5		50		5		5)
		(a3f:		50.75		24.5		50		5		5)
		(a4f:		45.5		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		49		24.5		50		5		5)
		(a3v:		50.75		24.5		50		5		5)
		(a4v:		45.5		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ib
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ib		2		6			(fnt low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1480		710.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		64.75		31.5		50		4		4)
		(a3f:		47.25		24.5		50		4		4)
		(a4f:		40.25		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		64.75		31.5		50		4		4)
		(a3v:		47.25		24.5		50		4		4)
		(a4v:		40.25		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ie
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ie		2		6			(cnt low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			790		410.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			880		470.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		63		31.5		50		5		5)
		(a3f:		43.75		21.0		50		5		5)
		(a4f:		36.75		17.5		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		63		31.5		50		5		5)
		(a3v:		43.75		21.0		50		5		5)
		(a4v:		36.75		17.5		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
j
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(j		26		4			(alv stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			1780		950.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2680		2680.0		0		2		2)
		(b3:			150		150.0		0		2		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		150.0		0		2		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		45.5		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
jy
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(jy		20		3			(frc pla vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			2020		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		50.75		0.0		100		0		0)
		(a4f:		40.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		50.75		0.0		100		0		0)
		(a4v:		40.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
k
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(k		23		8			(stp vel vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		3		3)
		(b1:			60		30.0		50		3		3)
		(f2:			1480		1550.0		50		3		3)
		(b2:			90		45.0		50		3		3)
		(f3:			2620		1580.0		50		3		3)
		(b3:			150		75.0		50		3		3)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		3)
		(b3f:		150		75.0		50		3		3)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ky
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ky		29		1			(stp vel vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1480		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2620		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		64.75		0.0		100		0		0)
		(a3f:		64.75		0.0		100		0		0)
		(a4f:		43.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		64.75		0.0		100		0		0)
		(a3v:		64.75		0.0		100		0		0)
		(a4v:		43.75		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
kz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(kz		23		4			(stp vel vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		3		3)
		(b1:			60		30.0		50		3		3)
		(f2:			1480		1550.0		50		3		3)
		(b2:			90		45.0		50		3		3)
		(f3:			2620		1580.0		50		3		3)
		(b3:			150		75.0		50		3		3)
		(fnz:		270		135.0		50		0		0)
		(a2f:		54.25		0.0		100		0		0)
		(a3f:		54.25		0.0		100		0		0)
		(a4f:		33.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		3)
		(b3f:		150		75.0		50		3		3)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		54.25		0.0		100		0		0)
		(a3v:		54.25		0.0		100		0		0)
		(a4v:		33.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
l
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(l		11		8			(alv lat vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			460		230.0		50		6		0)
		(b1:			60		30.0		50		6		0)
		(f2:			1480		710.0		50		6		0)
		(b2:			90		45.0		50		6		0)
		(f3:			2500		1220.0		50		6		0)
		(b3:			150		75.0		50		6		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		40.25		0.0		100		0		0)
		(a4f:		35		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		6		0)
		(b3f:		150		75.0		50		6		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		50.75		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		40.25		0.0		100		0		0)
		(a4v:		35		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ll
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ll		11		8			(alv lat vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			460		230.0		50		6		0)
		(b1:			60		30.0		50		6		0)
		(f2:			940		470.0		50		6		0)
		(b2:			90		45.0		50		6		0)
		(f3:			2500		1220.0		50		6		0)
		(b3:			150		75.0		50		6		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		40.25		0.0		100		0		0)
		(a4f:		35		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		6		0)
		(b3f:		150		75.0		50		6		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		50.75		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		40.25		0.0		100		0		0)
		(a4v:		35		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
m
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(m		15		8			(blb nas )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		2		0)
		(aspiration:	0		0.0		50		2		0)
		(friction:	0		0.0		50		2		0)
		(f1:			480		480.0		0		3		0)
		(b1:			40		20.0		50		3		0)
		(f2:			1000		350.0		50		3		0)
		(b2:			175		87.0		50		3		0)
		(f3:			2200		0.0		100		5		0)
		(b3:			120		0.0		100		5		0)
		(fnz:		360		360.0		0		3		0)
		(a2f:		44		-10.0		100		3		0)
		(a3f:		47		-10.0		100		3		0)
		(a4f:		-16		-10.0		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		175		87.0		50		3		0)
		(b3f:		120		0.0		100		5		0)
		(anv:		56		28.0		50		3		0)
		(a1v:		40		-10.0		100		3		0)
		(a2v:		44		-10.0		100		3		0)
		(a3v:		47		-10.0		100		3		0)
		(a4v:		-16		-10.0		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
n
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(n		15		8			(alv nas )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		2		0)
		(aspiration:	0		0.0		50		2		0)
		(friction:	0		0.0		50		2		0)
		(f1:			480		480.0		0		3		0)
		(b1:			40		20.0		50		3		0)
		(f2:			1780		950.0		50		3		3)
		(b2:			300		150.0		50		3		3)
		(f3:			2620		2680.0		0		3		0)
		(b3:			260		130.0		50		3		0)
		(fnz:		450		450.0		0		3		0)
		(a2f:		49		-10.0		100		3		0)
		(a3f:		49		-10.0		100		3		0)
		(a4f:		34		-10.0		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		300		150.0		50		3		3)
		(b3f:		260		130.0		50		3		0)
		(anv:		56		28.0		50		3		0)
		(a1v:		49		-10.0		100		3		0)
		(a2v:		49		-10.0		100		3		0)
		(a3v:		49		-10.0		100		3		0)
		(a4v:		34		-10.0		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ng
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ng		15		8			(nas vel )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	52		26.0		50		2		0)
		(aspiration:	0		0.0		50		2		0)
		(friction:	0		0.0		50		2		0)
		(f1:			480		480.0		0		3		0)
		(b1:			160		80.0		0		5		0)
		(f2:			820		1550.0		50		5		3)
		(b2:			150		75.0		50		5		3)
		(f3:			2800		1580.0		50		3		3)
		(b3:			100		50.0		50		3		0)
		(fnz:		360		360.0		0		3		0)
		(a2f:		44		0.0		100		3		0)
		(a3f:		49		0.0		100		3		0)
		(a4f:		14		0.0		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		150		75.0		50		5		3)
		(b3f:		100		50.0		50		3		0)
		(anv:		56		28.0		50		3		3)
		(a1v:		34		0.0		100		3		0)
		(a2v:		44		0.0		100		3		0)
		(a3v:		49		0.0		100		3		0)
		(a4v:		14		0.0		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
o
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(o		2		6			(bck low rnd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			610		290.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			880		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		61.25		31.5		50		4		4)
		(a3f:		36.75		17.5		50		4		4)
		(a4f:		29.75		14.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		61.25		31.5		50		4		4)
		(a3v:		36.75		17.5		50		4		4)
		(a4v:		29.75		14.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
oa
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(oa		2		6			(cnt mdl unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			1480		710.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		64.75		31.5		50		5		5)
		(a3f:		47.25		24.5		50		5		5)
		(a4f:		40.25		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		64.75		31.5		50		5		5)
		(a3v:		47.25		24.5		50		5		5)
		(a4v:		40.25		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
oi
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(oi		2		6			(bck rnd umd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			820		350.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		5		5)
		(a3f:		36.75		17.5		50		5		5)
		(a4f:		31.5		14.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		59.5		28.0		50		5		5)
		(a3v:		36.75		17.5		50		5		5)
		(a4v:		31.5		14.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
oo
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(oo		2		4			(bck rnd smh vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			370		170.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1000		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		4		4)
		(a3f:		42		21.0		50		4		4)
		(a4f:		36.75		17.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		56		28.0		50		4		4)
		(a3v:		42		21.0		50		4		4)
		(a4v:		36.75		17.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
oor
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(oor		2		6			(bck rnd smh vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			370		170.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			1000		470.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		5		5)
		(a3f:		42		21.0		50		5		5)
		(a4f:		36.75		14.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		56		28.0		50		5		5)
		(a3v:		42		21.0		50		5		5)
		(a4v:		36.75		14.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
or
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(or		2		6			(bck lmd rnd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			820		470.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		5		5)
		(a3f:		36.75		17.5		50		5		5)
		(a4f:		31.5		14.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		59.5		28.0		50		5		5)
		(a3v:		36.75		17.5		50		5		5)
		(a4v:		31.5		14.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ou
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ou		2		6			(cnt low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			790		410.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			1300		590.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		61.25		31.5		50		5		5)
		(a3f:		49		24.5		50		5		5)
		(a4f:		42		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		61.25		31.5		50		5		5)
		(a3v:		49		24.5		50		5		5)
		(a4v:		42		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ov
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ov		2		6			(bck rnd smh vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			370		170.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1000		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		4		4)
		(a3f:		42		21.0		50		4		4)
		(a4f:		36.75		17.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		56		28.0		50		4		4)
		(a3v:		42		21.0		50		4		4)
		(a4v:		36.75		17.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
p
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(p		23		8			(blb stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			760		350.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2500		0.0		100		0		2)
		(b3:			150		0.0		100		0		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		0.0		100		0		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
py
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(py		29		1			(blb stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			760		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2500		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		63		0.0		100		0		0)
		(a3f:		57.75		0.0		100		0		0)
		(a4f:		52.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		38.5		0.0		100		0		0)
		(a2v:		63		0.0		100		0		0)
		(a3v:		57.75		0.0		100		0		0)
		(a4v:		52.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
pz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(pz		23		2			(blb stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			760		350.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2500		0.0		100		2		2)
		(b3:			150		0.0		100		2		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		52.5		0.0		100		0		0)
		(a3f:		47.25		0.0		100		0		0)
		(a4f:		42		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		0.0		100		2		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		38.5		0.0		100		0		0)
		(a2v:		52.5		0.0		100		0		0)
		(a3v:		47.25		0.0		100		0		0)
		(a4v:		42		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
q
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(q		29		6			(0 )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		0.0		100		3		3)
		(b1:			60		0.0		100		3		3)
		(f2:			1480		0.0		100		3		3)
		(b2:			90		0.0		100		3		3)
		(f3:			2500		0.0		100		3		3)
		(b3:			150		0.0		100		3		3)
		(fnz:		270		135.0		50		3		3)
		(a2f:		-16		-10.5		100		3		0)
		(a3f:		-16		-10.5		100		3		0)
		(a4f:		-16		-10.5		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		90		0.0		100		3		3)
		(b3f:		150		0.0		100		3		3)
		(anv:		-16		-10.5		100		3		0)
		(a1v:		-16		-10.5		100		3		0)
		(a2v:		-16		-10.5		100		3		0)
		(a3v:		-16		-10.5		100		3		0)
		(a4v:		-16		-10.5		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
qq
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(qq		30		0			(frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1420		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2560		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		54.25		0.0		100		0		0)
		(a3f:		50.75		0.0		100		0		0)
		(a4f:		47.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		54.25		0.0		100		0		0)
		(a3v:		50.75		0.0		100		0		0)
		(a4v:		47.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
r
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(r		10		11			(alv apr )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		0.0		100		0		5)
		(b1:			60		0.0		100		0		5)
		(f2:			1180		590.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			1600		740.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		49		24.5		50		5		5)
		(a3f:		49		24.5		50		5		5)
		(a4f:		-16		7.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		56		28.0		50		5		5)
		(a2v:		49		24.5		50		5		5)
		(a3v:		49		24.5		50		5		5)
		(a4v:		-16		7.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
rx
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(rx		10		10			(rzd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	50		25.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		0.0		100		0		5)
		(b1:			60		30.0		50		0		5)
		(f2:			1180		0.0		100		0		5)
		(b2:			90		45.0		50		5		5)
		(f3:			1600		1600.0		0		5		5)
		(b3:			70		35.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		49		24.5		50		5		5)
		(a3f:		49		24.5		50		5		5)
		(a4f:		-16		7.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		70		35.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		56		28.0		50		5		5)
		(a2v:		49		24.5		50		5		5)
		(a3v:		49		24.5		50		5		5)
		(a4v:		-16		7.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
s
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(s		18		12			(alv frc vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	32		16.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			200		100.0		50		3		2)
		(f2:			1720		950.0		50		3		2)
		(b2:			96		48.0		50		3		2)
		(f3:			2620		0.0		100		3		2)
		(b3:			220		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		42		0.0		100		0		0)
		(a3f:		42		0.0		100		0		0)
		(a4f:		54.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		96		48.0		50		3		2)
		(b3f:		220		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		42		0.0		100		0		0)
		(a3v:		42		0.0		100		0		0)
		(a4v:		54.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
sh
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(sh		18		12			(frc pla vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			2200		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		45.5		0.0		100		0		0)
		(a3f:		56		0.0		100		0		0)
		(a4f:		45.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		45.5		0.0		100		0		0)
		(a3v:		56		0.0		100		0		0)
		(a4v:		45.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
t
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(t		23		6			(alv stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			1780		950.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2680		2680.0		0		0		2)
		(b3:			150		150.0		0		0		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		150.0		0		0		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
th
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(th		18		15			(dnt frc vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1780		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2680		2680.0		0		3		2)
		(b3:			150		150.0		0		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		42		0.0		100		0		0)
		(a4f:		36.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		150.0		0		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		42		0.0		100		0		0)
		(a4v:		36.75		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ty
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ty		29		1			(alv stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1780		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2680		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		52.5		0.0		100		0		0)
		(a4f:		64.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		52.5		0.0		100		0		0)
		(a4v:		64.75		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
tz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(tz		23		2			(alv stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		1)
		(b1:			60		30.0		50		2		1)
		(f2:			1780		950.0		50		2		1)
		(b2:			90		45.0		50		2		1)
		(f3:			2680		2680.0		0		2		0)
		(b3:			150		150.0		0		2		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		42		0.0		100		0		0)
		(a4f:		54.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		1)
		(b3f:		150		150.0		0		2		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		42		0.0		100		0		0)
		(a4v:		54.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
u
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(u		2		6			(bck lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			700		350.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1360		710.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		57.75		28.0		50		4		4)
		(a3f:		45.5		21.0		50		4		4)
		(a4f:		38.5		17.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		57.75		28.0		50		4		4)
		(a3v:		45.5		21.0		50		4		4)
		(a4v:		38.5		17.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
uu
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(uu		2		9			(bck hgh rnd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			250		110.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			880		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2200		1100.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		52.5		24.5		50		4		4)
		(a3f:		31.5		14.0		50		4		4)
		(a4f:		24.5		10.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		52.5		24.5		50		4		4)
		(a3v:		31.5		14.0		50		4		4)
		(a4v:		24.5		10.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
v
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(v		20		4			(frc lbd vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1420		350.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		980.0		50		3		2)
		(b3:			150		75.0		50		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		54.25		0.0		100		0		0)
		(a3f:		50.75		0.0		100		0		0)
		(a4f:		47.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		75.0		50		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		54.25		0.0		100		0		0)
		(a3v:		50.75		0.0		100		0		0)
		(a4v:		47.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
w
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(w		10		8			(apr lbv vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		50.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			760		350.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2020		980.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		42		21.0		50		4		4)
		(a3f:		35		17.5		50		4		4)
		(a4f:		-16		7.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		57.75		28.0		50		4		4)
		(a2v:		42		21.0		50		4		4)
		(a3v:		35		17.5		50		4		4)
		(a4v:		-16		7.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
x
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(x		18		12			(frc vel vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		3		3)
		(b1:			60		30.0		50		3		3)
		(f2:			1480		1550.0		50		3		3)
		(b2:			90		45.0		50		3		3)
		(f3:			2620		1580.0		50		3		3)
		(b3:			150		75.0		50		3		3)
		(fnz:		270		135.0		50		0		0)
		(a2f:		54.25		0.0		100		0		0)
		(a3f:		54.25		0.0		100		0		0)
		(a4f:		33.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		3)
		(b3f:		150		75.0		50		3		3)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		54.25		0.0		100		0		0)
		(a3v:		54.25		0.0		100		0		0)
		(a4v:		33.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
y
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(y		10		7			(apr pal vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			250		110.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			2500		1190.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2980		1460.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		47.25		24.5		50		4		4)
		(a3f:		52.5		24.5		50		4		4)
		(a4f:		45.5		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		47.25		24.5		50		4		4)
		(a3v:		52.5		24.5		50		4		4)
		(a4v:		45.5		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
z
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(z		20		4			(alv frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	40		20.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1720		950.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		38.5		0.0		100		0		0)
		(a3f:		38.5		0.0		100		0		0)
		(a4f:		50.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		38.5		0.0		100		0		0)
		(a3v:		38.5		0.0		100		0		0)
		(a4v:		50.75		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
zh
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(zh		20		4			(frc pla vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			2020		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		50.75		0.0		100		0		0)
		(a4f:		40.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		50.75		0.0		100		0		0)
		(a4v:		40.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
zz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(zz		20		4			(alv frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1720		950.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		38.5		0.0		100		0		0)
		(a3f:		38.5		0.0		100		0		0)
		(a4f:		50.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		38.5		0.0		100		0		0)
		(a3v:		38.5		0.0		100		0		0)
		(a4v:		50.75		0.0		100		0		0))! !


!KlattSegmentSet methodsFor: 'enumerating' stamp: 'len 11/28/1999 04:18'!
do: aBlock
	self segments do: [ :each | each do: aBlock]! !


!KlattSegmentSet methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initializeArpabet
	phonemes := PhonemeSet arpabet.
	segments := Dictionary new.
	#(('p'	(p py pz))
	('t'		(t ty tz))
	('k'		(k ky kz))
	('b'		(b by bz))
	('d'		(d dy dz))
	('g'		(g gy gz))
	('m'		(m))
	('n'		(n))
	('ng'	(ng))
	('f'		(f))
	('th'	(th))
	('s'		(s))
	('sh'	(sh))
	('hh'	(h))
	('v'		(v qq v))
	('dh'	(dh qq di))
	('z'		(z qq zz))
	('zh'	(zh qq zh))
	('ch'	(ch ci))
	('jh'	(j jy qq jy))
	('l'		(l))
	('r'		(r))
	('w'		(w))
	('q'		(qq)) "stop-ness - not quite glottal stop"
	('y'		(y))
	('ih'	(i))
	('eh'	(e))
	('ae'	(aa))
	('ah'	(u))
"	('oh'	(o))	????????????????????????"
	('uh'	(oo))
	('ax'	(a))
	('iy'	(ee))
	('er'	(er))
	('aa'	(ar))
	('ao'	(aw))
	('uw'	(uu))
	('ey'	(ai i))
	('ay'	(ie i))
	('oy'	(oi i))
	('aw'	(ou ov))
	('ow'	(oa ov))
	('ia'	(ia ib))
	('ea'	(air ib))
	('ua'	(oor ib))
	('sil'	(q))
	('ll'		(ll))
	('wh'	(w))
	('ix'		(a))
	('el'		(l))
	('rx'	(rx))) do: [ :each |
		segments at: (phonemes at: each first)
		put: (each last collect: [ :selector | self perform: selector])]! !


!KlattSegmentSet methodsFor: 'segments creation' stamp: 'stephaneducasse 2/3/2006 22:22'!
parameterFromArray: anArray
	| answer |
	answer := KlattSegmentParameter new.
	#(selector: steady: fixed: proportion: external: internal:)
		doWithIndex: [ :each :index | answer perform: each with: (anArray at: index)].
	^ answer! !

!KlattSegmentSet methodsFor: 'segments creation' stamp: 'stephaneducasse 2/3/2006 22:22'!
segmentFromArray: anArray
	| answer |
	answer := KlattSegment new.
	#(name: rank: duration: features:)
		doWithIndex: [ :each :index | answer perform: each with: (anArray at: index)].
	5 to: anArray size do: [ :each | answer addParameter: (self parameterFromArray: (anArray at: each))].
	^ answer! !

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

KlattSegmentSet class
	instanceVariableNames: ''!

!KlattSegmentSet class methodsFor: 'instance creation' stamp: 'len 10/12/1999 00:47'!
arpabet
	^ self new initializeArpabet! !
Object subclass: #KlattSynthesizer
	instanceVariableNames: 'resonators frame pitch t0 nper nopen nmod a1 a2 x1 x2 b1 c1 glast vlast nlast periodCount samplesCount seed cascade samplesPerFrame samplingRate'
	classVariableNames: 'Epsilon'
	poolDictionaries: 'KlattResonatorIndices'
	category: 'Speech-Klatt'!
!KlattSynthesizer commentStamp: '<historical>' prior: 0!
My instances are Klatt-style cascade/parallel formant synthesizers, first described by Dennis Klatt in [1]. An updated version of the model was described in [2]. This version implements the LF (Liljencrants-Fant) glottal pulse model from [3], and the jitter and shimmer parameters suggested in [4]. For a description of the Klatt parameters, see KlattFrame.

References:
	[1] Klatt,D.H. "Software for a cascade/parallel formant synthesizer", in the Journal of the Acoustical Society of America, pages 971-995, volume 67, number 3, March 1980.
	[2] Klatt,D.H. and Klatt, L.C. "Analysis, synthesis and perception of voice quality variations among female and male talkers". In the Journal of the Acoustical Society of America, pages 820-857, volume 87, number 2. February 1990.
	[3] Fant, G., Liljencrants, J., & Lin, Q. "A four-parameter model of glottal flow", Speech Transmission Laboratory Qurterly Progress Report 4/85, KTH.
	[4] Alwan, A., Bangayan, P., Kreiman, J., and Long, C. "Time and Frequency Synthesis Parameters of Severely Pathological Voice Qualities."!


!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 9/18/1999 00:50'!
cascade
	"Answer the number of formants in the cascade branch."
	^ cascade! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
cascade: anInteger
	"Set the number of formants in the cascade branch."
	cascade := anInteger! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 10/8/1999 02:09'!
millisecondsPerFrame
	^ 1000.0 / self samplingRate * self samplesPerFrame! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 9/3/1999 02:48'!
millisecondsPerFrame: aNumber
	self samplesPerFrame: (aNumber * self samplingRate / 1000) asInteger! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 8/24/1999 02:45'!
samplesPerFrame
	^ samplesPerFrame! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
samplesPerFrame: anInteger
	samplesPerFrame := anInteger! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 8/24/1999 02:45'!
samplingRate
	^ samplingRate! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
samplingRate: anInteger
	samplingRate := anInteger.
	self initializeState! !


!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'stephaneducasse 2/3/2006 22:22'!
antiResonator: index frequency: freq bandwidth: bw
	"Set up an anti-resonator"
	| arg r a b c |
	arg := 0.0 - Float pi / samplingRate * bw.
	r := arg exp.
	c := 0.0 - (r * r).
	arg := Float pi * 2.0 / samplingRate * freq.
	b := r * arg cos * 2.0.
	a := 1.0 - b - c.
	a := 1.0 / a.
	b := 0.0 - b * a.
	c := 0.0 - c * a.
	self resonatorA: index put: a.
	self resonatorB: index put: b.
	self resonatorC: index put: c! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'stephaneducasse 2/3/2006 22:22'!
antiResonator: index value: aFloat
	| answer p1 |
	answer := (self resonatorA: index) * aFloat
			+ ((self resonatorB: index) * (p1 := self resonatorP1: index))
			+ ((self resonatorC: index) * (self resonatorP2: index)).
	self resonatorP2: index put: p1.
	self resonatorP1: index put: aFloat.
	^ answer! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'stephaneducasse 2/3/2006 22:22'!
resonator: index frequency: freq bandwidth: bw
	"Convert formant frequencies and bandwidth into
	resonator difference equation coefficients."
	| arg r a b c |
	arg := 0.0 - Float pi / samplingRate * bw.
	r := arg exp.
	c := 0.0 - (r * r).
	arg := Float pi * 2.0 / samplingRate * freq.
	b := r * arg cos * 2.0.
	a := 1.0 - b - c.
	self resonatorA: index put: a.
	self resonatorB: index put: b.
	self resonatorC: index put: c! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 10/29/1999 01:32'!
resonator: index frequency: freq bandwidth: bw gain: gain
	"Convert formant frequencies and bandwidth into
	resonator difference equation coefficients."
	self resonator: index frequency: freq bandwidth: bw.
	self resonatorA: index put: (self resonatorA: index) * gain! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'stephaneducasse 2/3/2006 22:22'!
resonator: index value: aFloat
	| answer p1 |
	answer := (self resonatorA: index) * aFloat
			+ ((self resonatorB: index) * (p1 := self resonatorP1: index))
			+ ((self resonatorC: index) * (self resonatorP2: index)).
	self resonatorP2: index put: p1.
	self resonatorP1: index put: answer.
	^ answer! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:58'!
resonatorA: index
	^resonators at: index * 5 - 4! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:58'!
resonatorA: index put: aFloat
	resonators at: index*5-4 put: aFloat! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:58'!
resonatorB: index
	^resonators at: index*5-3! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorB: index put: aFloat
	resonators at: index*5-3 put: aFloat! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorC: index
	^resonators at: index*5-2! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorC: index put: aFloat
	resonators at: index*5-2 put: aFloat! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorP1: index
	^resonators at: index*5-1! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorP1: index put: aFloat
	resonators at: index*5-1 put: aFloat! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorP2: index
	^resonators at: index*5! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorP2: index put: aFloat
	resonators at: index*5 put: aFloat! !


!KlattSynthesizer methodsFor: 'initialization' stamp: 'len 9/2/1999 01:44'!
defaultMillisecondsPerFrame
	"Default is 10 milliseconds per frame."
	^ 10! !

!KlattSynthesizer methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	"Initialize the Klatt synthesizer."

	"Seed for noise generation:"
	seed := 17.
	"Sampling rate and millseconds per frame:"
	self samplingRate: 22025.
	self millisecondsPerFrame: self defaultMillisecondsPerFrame.
	"Number of formants in the cascade branch: (0 to 8)"
	self cascade: 0! !

!KlattSynthesizer methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initializeResonators
	resonators := FloatArray new: 24 * 5		"24 resonators, 5 floats each"! !

!KlattSynthesizer methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initializeState
	self initializeResonators.
	pitch := 110.0.
	t0 := (samplingRate / pitch) asInteger.
	nper := 0.
	nopen := 0.
	nmod := 0.
	periodCount := 0.
	samplesCount := 0.
	vlast := 0.0.
	glast := 0.0.
	nlast := 0.0.

	self ro: 0.25 ra: 0.01 rk: 0.25! !


!KlattSynthesizer methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
samplesFromFrames: aCollection
	| buffer index |
	buffer := SoundBuffer newMonoSampleCount: aCollection size * samplesPerFrame.
	index := 1.
	aCollection do: [ :each |
		self synthesizeFrame: each into: buffer startingAt: index.
		index := samplesPerFrame + index].
	^ buffer! !

!KlattSynthesizer methodsFor: 'processing' stamp: 'len 9/4/1999 00:20'!
soundFromFrames: aCollection
	^ SampledSound samples: (self samplesFromFrames: aCollection) samplingRate: samplingRate! !

!KlattSynthesizer methodsFor: 'processing' stamp: 'ar 3/21/2001 12:21'!
synthesizeFrame: aKlattFrame into: aSoundBuffer startingAt: index
	<primitive: 'primitiveSynthesizeFrameIntoStartingAt' module: 'Klatt'>
	^(Smalltalk at: #KlattSynthesizerPlugin ifAbsent:[^self primitiveFail])
		doPrimitive: 'primitiveSynthesizeFrameIntoStartingAt'! !


!KlattSynthesizer methodsFor: 'processing-LF' stamp: 'stephaneducasse 2/3/2006 22:22'!
qu: u phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| expuphi |
	expuphi := (u * phi) exp.
	^ expuphi * ((rphid * (u*u + 1.0) + u) * sinphi - cosphi) + 1.0! !

!KlattSynthesizer methodsFor: 'processing-LF' stamp: 'stephaneducasse 2/3/2006 22:22'!
ro: roNumber ra: raNumber rk: rkNumber
	| r d phi cosphi sinphi rphid u theta rho gamma gammapwr te ro ra rk |
	te := (t0 * roNumber) asInteger.
	ro := te asFloat / t0 asFloat.
	rk := rkNumber.
	ra := raNumber.

	ra <= 0.0
		ifTrue: [d := 1.0]
		ifFalse: [r := 1.0 - ro / ra.
				d := 1.0 - (r / (r exp - 1.0))].

	phi := Float pi * (rk + 1.0).
	cosphi := phi cos.
	sinphi := phi sin.
	rphid := ra / ro * phi * d.

	u := self zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
	theta := phi / te.
	rho := (u * theta) exp.
	a1 := 2.0 * theta cos * rho.
	a2 := 0.0 - (rho * rho).
	x2 := 0.0.
	x1 := rho * theta sin.

	gamma := (-1.0 / (ra * t0)) exp.
	gammapwr := gamma raisedTo: t0 - te.

	b1 := gamma.
	c1 := (1.0 - gamma) * gammapwr / (1.0 - gammapwr)! !

!KlattSynthesizer methodsFor: 'processing-LF' stamp: 'stephaneducasse 2/3/2006 22:22'!
zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| qzero ua ub qa qb uc qc |
	qzero := self qu: 0 phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.

	qzero > 0
		ifTrue: [ua := 0. ub := 1.
				qa := qzero. qb := self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
				[qb > 0]
					whileTrue: [ua := ub. qa := qb.
								ub := ub * 2. qb := self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]]
		ifFalse: [ua := -1. ub := 0.
				qa := self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid. qb := qzero.
				[qa < 0]
					whileTrue: [ub := ua. qb := qa.
								ua := ua * 2. qa := self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]].
	[ub - ua > Epsilon]
		whileTrue: [uc := ub + ua / 2. qc := self qu: uc phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
					qc > 0 ifTrue: [ua := uc. qa := qc] ifFalse: [ub := uc. qb := qc]].
	^ ub + ua / 2! !


!KlattSynthesizer methodsFor: 'testing' stamp: 'len 9/27/1999 01:06'!
isAllParallel
	"Answer true if the receiver is not using the cascade branch."
	^ self cascade = 0! !

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

KlattSynthesizer class
	instanceVariableNames: ''!

!KlattSynthesizer class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/3/2006 22:23'!
initialize
	"
	KlattSynthesizer initialize
	"
	Epsilon := 1.0e-04.
! !
Voice subclass: #KlattVoice
	instanceVariableNames: 'segments lastEvent lastEventTime left current right synthesizer patternFrame breathiness tract'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!
!KlattVoice commentStamp: '<historical>' prior: 0!
My instances are voices that play PhoneticEvents using a KlattSynthesizer and KlattSegments. There are many controls to change voice personalities, such as vocal tract length, breathiness, jitter, shimmer and glottal pulse shape.!


!KlattVoice methodsFor: 'accessing' stamp: 'len 12/6/1999 03:43'!
phonemes
	^ self segments phonemes! !

!KlattVoice methodsFor: 'accessing' stamp: 'len 9/6/1999 01:21'!
samplingRate
	^ self synthesizer samplingRate! !

!KlattVoice methodsFor: 'accessing' stamp: 'len 10/12/1999 00:41'!
segments
	^ segments! !

!KlattVoice methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
segments: aKlattSegmentSet
	segments := aKlattSegmentSet! !

!KlattVoice methodsFor: 'accessing' stamp: 'len 9/6/1999 01:21'!
synthesizer
	^ synthesizer! !


!KlattVoice methodsFor: 'accessing-private' stamp: 'len 9/27/1999 01:40'!
patternFrame
	^ patternFrame! !

!KlattVoice methodsFor: 'accessing-private' stamp: 'stephaneducasse 2/3/2006 22:22'!
patternFrame: aKlattFrame
	patternFrame isNil ifTrue: [patternFrame := aKlattFrame. ^ self].
	patternFrame replaceFrom: 1 to: patternFrame size with: aKlattFrame! !


!KlattVoice methodsFor: 'editing' stamp: 'len 12/2/1999 02:52'!
edit
	self editor openInWorld! !

!KlattVoice methodsFor: 'editing' stamp: 'len 12/6/1999 02:27'!
editor
	^ KlattFrameMorph new
		frame: self patternFrame edit: #(flutter jitter shimmer diplophonia ro rk ra turbulence gain);
		addSliderForParameter: #breathiness target: self min: 0.0 max: 1.0 description: 'Amount of breathiness';
		addSliderForParameter: #tract target: self min: 10.0 max: 20.0 description: 'Vocal tract length (average male=17.3, average female=14.4)'! !


!KlattVoice methodsFor: 'initialization' stamp: 'len 12/6/1999 03:43'!
defaultPatternFrame
	^ KlattFrame default clone
		f0: 133;
		flutter: 0; jitter: 0; shimmer: 0; diplophonia: 0;
		voicing: 60;
		aspiration: 0;
		friction: 0;
		bypass: 0;
		turbulence: 0;
		ro: 0.5; rk: 0.25; ra: 0.01;
		f1: 500;		b1: 60;
		f2: 1500;		b2: 90;
		f3: 2800;	b3: 150;
		f4: 3250;	b4: 200;
		f5: 3700;	b5: 200;
		f6: 4990;	b6: 500;
		fnz: 270;	bnz: 100;
		fnp: 270;	bnp: 100;
		b2f: 200;
		b3f: 350;
		b4f: 500;
		b5f: 600;
		b6f: 800;
		anv: 0;
		gain: 61! !

!KlattVoice methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	super initialize.
	synthesizer := KlattSynthesizer new cascade: 0.
	self segments: KlattSegmentSet arpabet.
	self patternFrame: self defaultPatternFrame.
	self breathiness: 0.0.
	self tract: 17.3. "Set a male vocal tract."
	self reset! !


!KlattVoice methodsFor: 'personality' stamp: 'len 11/30/1999 03:26'!
breathiness
	^ breathiness! !

!KlattVoice methodsFor: 'personality' stamp: 'stephaneducasse 2/3/2006 22:22'!
breathiness: aNumber
	breathiness := aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
diplophonia
	^ self patternFrame diplophonia! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
diplophonia: aNumber
	self patternFrame diplophonia: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
flutter
	^ self patternFrame flutter! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
flutter: aNumber
	self patternFrame flutter: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:15'!
jitter
	^ self patternFrame jitter! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:15'!
jitter: aNumber
	self patternFrame jitter: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
ra
	^ self patternFrame ra! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
ra: aNumber
	self patternFrame ra: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
rk
	^ self patternFrame rk! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:17'!
rk: aNumber
	self patternFrame rk: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
ro
	^ self patternFrame ro! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
ro: aNumber
	self patternFrame ro: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
shimmer
	^ self patternFrame shimmer! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:15'!
shimmer: aNumber
	self patternFrame shimmer: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 12/1/1999 03:37'!
tract
	^ tract! !

!KlattVoice methodsFor: 'personality' stamp: 'stephaneducasse 2/3/2006 22:22'!
tract: aNumber
	tract := aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
turbulence
	^ self patternFrame turbulence! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
turbulence: aNumber
	self patternFrame turbulence: aNumber! !


!KlattVoice methodsFor: 'playing' stamp: 'stephaneducasse 2/3/2006 22:22'!
flush
	"Play all the events in the queue, and then reset."
	| lastEventSegments |
	lastEvent isNil
		ifFalse: [lastEventSegments := self segments at: lastEvent phoneme ifAbsent: [self segments silence].
				self playEvent: lastEvent segments: lastEventSegments boundary: self segments end at: lastEventTime].
	super flush.
	self reset! !

!KlattVoice methodsFor: 'playing' stamp: 'stephaneducasse 2/3/2006 22:22'!
playPhoneticEvent: event at: time
	| lastEventSegments boundarySegment |
	"Play an event."
	lastEvent isNil
		ifFalse: [lastEventSegments := self segments at: lastEvent phoneme ifAbsent: [self segments silence].
				boundarySegment := (self segments at: event phoneme ifAbsent: [self segments silence]) first.
				self playEvent: lastEvent segments: lastEventSegments boundary: boundarySegment at: lastEventTime].
	lastEvent := event.
	lastEventTime := time! !

!KlattVoice methodsFor: 'playing' stamp: 'stephaneducasse 2/3/2006 22:22'!
reset
	"Reset the state of the receiver."
	super reset.
	lastEvent := lastEventTime := nil.
	current := right := left := self segments end! !


!KlattVoice methodsFor: 'playing-private' stamp: 'stephaneducasse 2/3/2006 22:22'!
currentFramesCount: n
	| answer |
	answer := current left: left right: right speed: n / current duration asFloat pattern: self patternFrame.
	answer size > 0 ifTrue: [self patternFrame: answer last].
	^ answer! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 9/30/1999 22:34'!
dBFromLinear: aNumber
	^ aNumber log / 2 log * 6.0 + 87.0! !

!KlattVoice methodsFor: 'playing-private' stamp: 'stephaneducasse 2/3/2006 22:22'!
durationsForEvent: event segments: segs
	| scale |
	scale := event duration / ((segs inject: 0 into: [ :result :each | result + each duration]) * 10 / 1000.0).
	^ segs collect: [ :each | (each duration * scale) rounded]! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 12/6/1999 03:48'!
formantScale
	self flag: #fixThis. "NOTE: this approximation is good only for vocal-tract lengths near 14.4 and 17.3 (and between them)... but it is certainly wrong for lengths such as 10 or 20."
	^ (17.3 - self tract) / (17.3 - 14.4) * 0.175 + 1.0! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 9/30/1999 22:34'!
linearFromdB: aNumber
	^ (2 raisedTo: (aNumber-87/6.0))! !

!KlattVoice methodsFor: 'playing-private' stamp: 'stephaneducasse 2/3/2006 22:22'!
playEvent: event frames: frames at: time
	| frame breathyAspiration formantScale |
	breathyAspiration := self dBFromLinear: (self linearFromdB: 68) * self breathiness.
	formantScale := self formantScale.
	1 to: frames size do: [ :each |
		frame := frames at: each.
		frame gain: (self dBFromLinear: (self linearFromdB: frame gain) * event loudness).
		frame f0: (event pitchAt: each - 1 * event duration / frames size).
		frame voicing: (self dBFromLinear: (self linearFromdB: frame voicing) * (1.0 - self breathiness)).
		frame aspiration: (frame aspiration max: breathyAspiration).
		frame
			f1: frame f1 * formantScale;
			f2: frame f2 * formantScale;
			f3: frame f3 * formantScale;
			f4: frame f4 * formantScale;
			f5: frame f5 * formantScale;
			f6: frame f6 * formantScale].
	"Transcript cr; show: (event duration * 1000 / frames size) printString."
	synthesizer millisecondsPerFrame: event duration * 1000 / frames size.
	self playBuffer: (synthesizer samplesFromFrames: frames) at: time! !

!KlattVoice methodsFor: 'playing-private' stamp: 'stephaneducasse 2/3/2006 22:22'!
playEvent: event segments: segs boundary: boundarySegment at: time
	| frames stream dur durations |
	frames := OrderedCollection new.
	stream := ReadStream on: segs.
	durations := ReadStream on: (self durationsForEvent: event segments: segs).
	[stream atEnd]
		whileFalse: [current := stream next.
					dur := durations next.
					dur > 0
						ifTrue: [right := stream atEnd ifTrue: [boundarySegment] ifFalse: [stream peek].
								frames addAll: (self currentFramesCount: dur)].
					left := current].
	frames isEmpty ifTrue: [^ self].
	self playEvent: event frames: frames at: time! !
LanguageEnvironment subclass: #KoreanEnvironment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Languages'!
!KoreanEnvironment commentStamp: '<historical>' prior: 0!
This class provides the Korean support.  Unfortunately, we haven't tested this yet.  We did have a working version in previous implementations, but not this new implementation. But as soon as we find somebody who understand the language, probably we can make it work in two days or so, as we have done for Czech support.!


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

KoreanEnvironment class
	instanceVariableNames: ''!

!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 21:45'!
clipboardInterpreterClass
	| platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) 
		ifTrue: [^NoConversionClipboardInterpreter].
	platformName = 'Win32' ifTrue: [^WinKSX1001ClipboardInterpreter].
	platformName = 'Mac OS' 
		ifTrue: 
			[('10*' match: SmalltalkImage current osVersion) 
				ifTrue: [^NoConversionClipboardInterpreter]
				ifFalse: [^WinKSX1001ClipboardInterpreter]].
	platformName = 'unix' 
		ifTrue: 
			[(ShiftJISTextConverter encodingNames includes: X11Encoding getEncoding) 
				ifTrue: [^WinKSX1001ClipboardInterpreter]
				ifFalse: [^NoConversionClipboardInterpreter]].
	^NoConversionClipboardInterpreter! !

!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 21:45'!
defaultEncodingName
	| platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy].
	(#('Win32' 'Mac OS' 'ZaurusOS') includes: platformName) 
		ifTrue: [^'euc-kr' copy].
	(#('unix') includes: platformName) ifTrue: [^'euc-kr' copy].
	^'mac-roman'! !

!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 21:46'!
inputInterpreterClass
	| platformName osVersion encoding |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) 
		ifTrue: [^MacRomanInputInterpreter].
	platformName = 'Win32' ifTrue: [^WinKSX1001InputInterpreter].
	platformName = 'Mac OS' 
		ifTrue: 
			[('10*' match: SmalltalkImage current osVersion) 
				ifTrue: [^MacUnicodeInputInterpreter]
				ifFalse: [^WinKSX1001InputInterpreter]].
	platformName = 'unix' 
		ifTrue: 
			[encoding := X11Encoding encoding.
			(EUCJPTextConverter encodingNames includes: encoding) 
				ifTrue: [^MacRomanInputInterpreter].
			(UTF8TextConverter encodingNames includes: encoding) 
				ifTrue: [^MacRomanInputInterpreter].
			(ShiftJISTextConverter encodingNames includes: encoding) 
				ifTrue: [^MacRomanInputInterpreter]].
	^MacRomanInputInterpreter! !

!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 3/16/2004 14:50'!
traditionalCharsetClass

	^ KSX1001.
! !


!KoreanEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:42'!
supportedLanguages
	"Return the languages that this class supports. 
	Any translations for those languages will use this class as their environment."
	^#('ko' )! !
Object subclass: #LRUCache
	instanceVariableNames: 'size factory calls hits values'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!LRUCache commentStamp: '<historical>' prior: 0!
I'm a cache of values, given a key I return a Value from the cache or from the factory!


!LRUCache methodsFor: 'accessing' stamp: 'dgd 2/6/2002 21:43'!
at: aKey 
	"answer the object for aKey, if not present in the cache creates it"
	| element keyHash |
	calls _ calls + 1.
	keyHash _ aKey hash.
	1
		to: size
		do: [:index | 
			element _ values at: index.
			(keyHash
						= (element at: 2)
					and: [aKey
							= (element at: 1)])
				ifTrue: ["Found!!"
					hits _ hits + 1.
					values
						replaceFrom: 2
						to: index
						with: (values first: index - 1).
					values at: 1 put: element.
					^ element at: 3]].
	"Not found!!"
	element _ {aKey. keyHash. factory value: aKey}.
	values
		replaceFrom: 2
		to: size
		with: values allButLast.
	values at: 1 put: element.
	^ element at: 3! !


!LRUCache methodsFor: 'initialization' stamp: 'dgd 3/28/2003 19:42'!
initializeSize: aNumber factory: aBlock 
	"initialize the receiver's size and factory"
	size := aNumber.
	values := Array new: aNumber withAll: {nil. nil. nil}.
	factory := aBlock.
	calls := 0.
	hits := 0! !


!LRUCache methodsFor: 'printing' stamp: 'dgd 3/28/2003 19:41'!
printOn: aStream 
	"Append to the argument, aStream, a sequence of characters  
	that identifies the receiver."
	aStream nextPutAll: self class name;
		 nextPutAll: ' size:';
		 nextPutAll: size asString;
		 nextPutAll: ', calls:';
		 nextPutAll: calls asString;
		 nextPutAll: ', hits:';
		 nextPutAll: hits asString;
		 nextPutAll: ', ratio:';
nextPutAll: 
	(hits / calls) asFloat asString! !

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

LRUCache class
	instanceVariableNames: ''!

!LRUCache class methodsFor: 'instance creation' stamp: 'dgd 3/26/2003 22:29'!
size: aNumber factory: aBlock 
	"answer an instance of the receiver"
	^ self new initializeSize: aNumber factory: aBlock! !


!LRUCache class methodsFor: 'testing' stamp: 'dgd 3/26/2003 22:22'!
test
	" 
	LRUCache test 
	"
	| c |
	c := LRUCache
				size: 5
				factory: [:key | key * 2].
	c at: 1.
	c at: 2.
	c at: 3.
	c at: 4.
	c at: 1.
	c at: 5.
	c at: 6.
	c at: 7.
	c at: 8.
	c at: 1.
	^ c! !

!LRUCache class methodsFor: 'testing' stamp: 'dgd 3/26/2003 22:22'!
test2
	" 
	LRUCache test2.  
	Time millisecondsToRun:[LRUCache test2]. 
	MessageTally spyOn:[LRUCache test2].  
	"
	| c |
	c := LRUCache
				size: 600
				factory: [:key | key * 2].
	1
		to: 6000
		do: [:each | c at: each].
	^ c! !
StringMorph subclass: #LabelStringMorph
	instanceVariableNames: 'mySystemWindow'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!LabelStringMorph commentStamp: '<historical>' prior: 0!
I am the stringMorph label for a system window. When a user   tries to edit me (shift-click's me) I call >>relabel in my SystemWindow.  In this way the SystemWindow is informed of the change.!


!LabelStringMorph methodsFor: 'accessing' stamp: 'fc 12/15/2004 15:27'!
mySystemWindow
	mySystemWindow! !

!LabelStringMorph methodsFor: 'accessing' stamp: 'fc 12/15/2004 15:27'!
mySystemWindow: aSystemWindow
	mySystemWindow := aSystemWindow.! !


!LabelStringMorph methodsFor: 'event handling' stamp: 'fc 12/15/2004 15:28'!
mouseDown: evt
	
	(evt shiftPressed) ifTrue: 
	 	[mySystemWindow relabel]! !
SystemWindow subclass: #LanguageEditor
	instanceVariableNames: 'translator selectedTranslation selectedTranslations selectedUntranslated translationsList untranslatedList translationText translationsFilter untranslatedFilter newerKeys'
	classVariableNames: 'CheckMethods'
	poolDictionaries: ''
	category: 'Multilingual-Editor'!
!LanguageEditor commentStamp: 'dgd 11/16/2003 15:02' prior: 0!
Editor for Babel's languages.

Open it from

	World Menu >> open... >> Language Editor			(to open on default language)
	World Menu >> open... >> Language Editor for...	(to choose the language)

Or click:

	LanguageEditor openOnDefault.
	LanguageEditor open.

See http://swiki.agro.uba.ar/small_land/191 for documentation
!


!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 19:13'!
selectedTranslation
	"answer the selectedTranslation"
	^ selectedTranslation! !

!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:56'!
selectedTranslation: anInteger 
	"change the receiver's selectedTranslation"
	selectedTranslation := anInteger.
	""
	self changed: #selectedTranslation.
	self changed: #translation! !

!LanguageEditor methodsFor: 'accessing' stamp: 'tak 11/28/2004 14:12'!
selectedTranslationsAt: index
	^ selectedTranslations includes: index! !

!LanguageEditor methodsFor: 'accessing' stamp: 'tak 11/28/2004 14:15'!
selectedTranslationsAt: index put: value 
	value = true
		ifTrue: [selectedTranslations add: index]
		ifFalse: [selectedTranslations
				remove: index
				ifAbsent: []]! !

!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:57'!
selectedUntranslated
	"answer the selectedUntranslated"
	^ selectedUntranslated! !

!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:57'!
selectedUntranslated: anInteger 
	"change the selectedUntranslated"
	selectedUntranslated := anInteger.
	""
	self changed: #selectedUntranslated! !

!LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'!
translation
	"answer the translation for the selected phrase"
	self selectedTranslation isZero
		ifTrue: [^ '<select a phrase from the upper list>' translated].
	""
	^ self translator
		translationFor: (self translations at: self selectedTranslation)! !

!LanguageEditor methodsFor: 'accessing' stamp: 'yo 3/1/2005 12:44'!
translation: aStringOrText 
	"change the translation for the selected phrase"
	| phrase |
	self selectedTranslation isZero
		ifTrue: [^ self].
	phrase _ self translations at: self selectedTranslation.
	translator
		phrase: phrase
		translation: aStringOrText asString.
	newerKeys add: phrase.
	^ true! !

!LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'!
translations
	"answet the translator's translations"
	| allTranslations filterString |
	allTranslations := self translator translations keys.
	""
	filterString := self translationsFilter.
	""
	filterString isEmpty
		ifFalse: [allTranslations := allTranslations
						select: [:each | ""
							('*' , filterString , '*' match: each)
								or: ['*' , filterString , '*'
										match: (self translator translationFor: each)]]].
""
	^ allTranslations asSortedCollection! !

!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 9/21/2003 12:00'!
translationsFilter
^translationsFilter ifNil:['']! !

!LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'!
untranslated
	"answer the translator's untranslated phrases"
	

| all filterString |
	all := self translator untranslated.
	""
	filterString := self untranslatedFilter.
	""
	filterString isEmpty
		ifFalse: [all := all
						select: [:each | ""
							('*' , filterString , '*' match: each)
								or: ['*' , filterString , '*'
										match: (self translator translationFor: each)]]].
	""
	^ all asSortedCollection! !

!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 9/21/2003 12:19'!
untranslatedFilter
	^ untranslatedFilter
		ifNil: ['']! !


!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:57'!
addTranslation
	"translate a phrase"
	| phrase |
	phrase := UIManager default
				request: 'enter the original:'
				initialAnswer: ''.

	(phrase isNil
			or: [phrase = ''])
		ifTrue: [""
			self beep.
			^ self].
	""
	self translatePhrase: phrase! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 7/21/2004 16:55'!
applyTranslations
	"private - try to apply the translations as much as possible all  
	over the image"
	Project current updateLocaleDependents! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 7/30/2004 22:25'!
browseMethodsWithTranslation
	| translation |
	self selectedTranslation isZero
		ifTrue: [""
			self beep.
			self inform: 'select the translation to look for' translated.
			^ self].
	""
	translation := self translations at: self selectedTranslation.
	self systemNavigation browseMethodsWithLiteral: translation! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 7/13/2004 10:19'!
browseMethodsWithUntranslated
	| untranslated |
	self selectedUntranslated isZero
		ifTrue: [""
			self beep.
			self inform: 'select the untranslated phrase to look for' translated.
			^ self].
	""
	untranslated := self untranslated at: self selectedUntranslated.
	SystemNavigation default browseMethodsWithLiteral: untranslated.
! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 15:01'!
codeSelectedTranslation
	| keys code |
	keys := selectedTranslations
				collect: [:key | self translations at: key].
	code := String
				streamContents: [:aStream | self translator fileOutOn: aStream keys: keys].
	(StringHolder new contents: code)
		openLabel: 'exported codes'! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 11/29/2005 11:20'!
codeSelectedTranslationAsMimeString
	| keys code tmpStream s2 gzs cont |
	keys := selectedTranslations
				collect: [:key | self translations at: key].
	code := String
				streamContents: [:aStream | self translator fileOutOn: aStream keys: keys].

	tmpStream _ MultiByteBinaryOrTextStream on: ''.
	tmpStream converter: UTF8TextConverter new.
	translator fileOutHeaderOn: tmpStream.
	tmpStream nextPutAll: code.
	s2 _ RWBinaryOrTextStream on: ''.
	gzs := GZipWriteStream on: s2.
	tmpStream reset.
	gzs nextPutAll: (tmpStream binary contentsOfEntireFile asString) contents.
	gzs close.
	s2 reset.

	cont _ String streamContents: [:strm |
		strm nextPutAll: '"Gzip+Base64 encoded translation for;'; cr.
		strm nextPutAll: '#('.
		keys do: [:each | strm  nextPutAll: '''', each, ''' '.].
		strm nextPutAll: ')"'; cr; cr.
		strm nextPutAll: 'NaturalLanguageTranslator loadForLocaleIsoString: '.
		strm nextPut: $'.
		strm nextPutAll: translator localeID isoString.
		strm nextPut: $'.
		strm nextPutAll: ' fromGzippedMimeLiteral: '.
		strm nextPut: $'.
		strm nextPutAll: (Base64MimeConverter mimeEncode: s2) contents.
		strm nextPutAll: '''.'.
		strm cr.
	].
	
	(StringHolder new contents: cont)
		openLabel: 'exported codes in Gzip+Base64 encoding'! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 14:27'!
deselectAllTranslation
	selectedTranslations := IdentitySet new.
	self changed: #allSelections! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:57'!
filterTranslations
	| filter |
	filter := UIManager default request: 'filter with
(empty string means no-filtering)' translated initialAnswer: self translationsFilter.
	""
	self filterTranslations: filter! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:12'!
filterTranslations: aString 
| filter |
filter := aString ifNil:[''].
""
	translationsFilter _ filter.
self update: #translations.
! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'!
filterUntranslated
	| filter |
	filter := UIManager default request: 'filter with
(empty string means no-filtering)' translated initialAnswer: self untranslatedFilter.
	""
	self filterUntranslated: filter! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:20'!
filterUntranslated: aString 
	| filter |
	filter := aString
				ifNil: [''].
	""
	untranslatedFilter := filter.
	self update: #untranslated! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'tak 1/4/2005 09:24'!
getTextExport
	(Smalltalk at: #GetTextExporter) new export: self model! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:56'!
loadFromFile
	| fileName |
	fileName := self selectTranslationFileName.
	fileName isNil
		ifTrue: [""
			self beep.
			^ self].
	""
	Cursor wait
		showWhile: [
			self translator loadFromFileNamed: fileName.
			self changed: #translations.
			self changed: #untranslated]! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:56'!
mergeFromFile
	| fileName |
	fileName := self selectTranslationFileName.
	fileName isNil
		ifTrue: [""
			self beep.
			^ self].
	""
	Cursor wait
		showWhile: [
			self translator loadFromFileNamed: fileName.
			self changed: #translations.
			self changed: #untranslated]! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:32'!
phrase: phraseString translation: translationString 
	"set the models's translation for phraseString"
	self translator phrase: phraseString translation: translationString.
	self changed: #translations.
	self changed: #untranslated.

	newerKeys add: phraseString.
! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'!
phraseToTranslate
	"answer a phrase to translate.  use the selected untranslated phrase or ask for a new one"
	^ self selectedUntranslated isZero
		ifTrue: [UIManager default
				multiLineRequest: 'new phrase to translate' translated
				centerAt: Sensor cursorPoint
				initialAnswer: ''
				answerHeight: 200]
		ifFalse: [self untranslated at: self selectedUntranslated]! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 1/14/2005 18:00'!
removeTranslation
	"remove the selected translation"
	| translation |
	self selectedTranslation isZero
		ifTrue: [""
			self beep.
			self inform: 'select the translation to remove' translated.
			^ self].
	""
	translation := self translations at: self selectedTranslation.
""
	(self
			confirm: ('Removing "{1}".
Are you sure you want to do this?' translated format: {translation}))
		ifFalse: [^ self].
""
	self translator removeTranslationFor: translation.
	self changed: #translations.
	self changed: #untranslated.! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:59'!
removeUntranslated
	"remove the selected untranslated phrase"
	| untranslated |
	self selectedUntranslated isZero
		ifTrue: [""
			self beep.
			self inform: 'select the untranslated phrase to remove' translated.
			^ self].
	""
	untranslated := self untranslated at: self selectedUntranslated.
	""
	(self
			confirm: ('Removing "{1}".
Are you sure you want to do this?' translated format: {untranslated}))
		ifFalse: [^ self].
	""
	self translator removeUntranslated: untranslated! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 7/21/2004 19:27'!
report
	self reportString openInWorkspaceWithTitle: 'report' translated! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:36'!
resetNewerKeys

	self initializeNewerKeys.
! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'!
saveToFile
	"save the translator to a file"
	| fileName |
	fileName := UIManager default request: 'file name' translated initialAnswer: translator localeID isoString , '.translation'.
	(fileName isNil
			or: [fileName isEmpty])
		ifTrue: [""
			self beep.
			^ self].
	""
Cursor wait
		showWhile: [
	self translator saveToFileNamed: fileName]! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'!
searchTranslation
	| search |
	search := UIManager default request: 'search for' translated initialAnswer: ''.
	(search isNil
			or: [search isEmpty])
		ifTrue: [""
			self beep.
			^ self].
""
self searchTranslation: search! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 09:24'!
searchTranslation: aString 
	| translations results index |
	translations := self translations.
	results := translations
				select: [:each | ""
					('*' , aString , '*' match: each)
						or: ['*' , aString , '*' match: (self translator translationFor: each)]].
	""
	results isEmpty
		ifTrue: [""
			self inform: 'no matches for' translated , ' ''' , aString , ''''.
			^ self].
	""
	results size = 1
		ifTrue: [""
			self selectTranslationPhrase: results first.
			^ self].
	""
	index := (UIManager default 
				chooseFrom: (results
						collect: [:each | ""
							(each copy replaceAll: Character cr with: $\)
								, ' -> '
								, ((self translator translationFor: each) copy replaceAll: Character cr with: $\)])
				title: 'select the translation...' translated).
	""
	index isZero
		ifTrue: [""
			self beep.
			^ self].
	""
	self
		selectTranslationPhrase: (results at: index)! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'!
searchUntranslated
	| search |
	search := UIManager default request: 'search for' translated initialAnswer: ''.
	(search isNil
			or: [search isEmpty])
		ifTrue: [""
			self beep.
			^ self].
	""
	self searchUntranslated: search! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 09:25'!
searchUntranslated: aString 
	| untranslateds results index |
	untranslateds := self untranslated.
	results := untranslateds
				select: [:each | '*' , aString , '*' match: each].
	""
	results isEmpty
		ifTrue: [""
			self inform: 'no matches for' translated , ' ''' , aString , ''''.
			^ self].
	""
	results size = 1
		ifTrue: [""
			self selectUntranslatedPhrase: results first.
			^ self].
	""
	index := (UIManager default 
				chooseFrom: (results
						collect: [:each | each copy replaceAll: Character cr with: $\])
				title: 'select the untranslated phrase...' translated).
	""
	index isZero
		ifTrue: [""
			self beep.
			^ self].
	""
	self
		selectUntranslatedPhrase: (results at: index)! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 14:26'!
selectAllTranslation
	selectedTranslations := (1 to: self translations size) asIdentitySet.
	self changed: #allSelections! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:40'!
selectNewerKeys

	| translations index |
	self deselectAllTranslation.
	translations _ self translations.
	newerKeys do: [:k |
		index _ translations indexOf: k ifAbsent: [0].
		index > 0 ifTrue: [
			self selectedTranslationsAt: index put: true
		].
	].
! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 22:15'!
selectTranslationFileName
	"answer a file with a translation"
	| file |
	file := (StandardFileMenu oldFileMenu: FileDirectory default withPattern: '*.translation')
				startUpWithCaption: 'Select the file...' translated.
	^ file isNil
		ifFalse: [file directory fullNameFor: file name]! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 22:49'!
selectTranslationPhrase: phraseString 
	self selectedTranslation: (self translations indexOf: phraseString)! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/27/2003 20:43'!
selectUntranslatedPhrase: phraseString 
	self
		selectedUntranslated: (self untranslated indexOf: phraseString)! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 10:00'!
status
	"answer a status string"
	| translationsSize untranslatedSize |
	translationsSize := self translator translations size.
	untranslatedSize := self translator untranslated size.
	^ 'ÆÀ {1} phrases ÆÀ {2} translated ÆÀ {3} untranslated ÆÀ' translated format: {translationsSize + untranslatedSize. translationsSize. untranslatedSize}! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 21:53'!
translate
	"translate a phrase"
	| phrase |
	phrase := self phraseToTranslate.
	""
	(phrase isNil
			or: [phrase = ''])
		ifTrue: [""
			self beep.
			^ self].
	""
	self translatePhrase: phrase! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'!
translatePhrase: aString 
	"translate aString"
	| translation |
	translation := UIManager default
				multiLineRequest: 'translation for: ' translated , '''' , aString , ''''
				centerAt: Sensor cursorPoint
				initialAnswer: aString
				answerHeight: 200.
	""
	(translation isNil
			or: [translation = ''])
		ifTrue: [""
			self beep.
			^ self].
	""
	self phrase: aString translation: translation! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:09'!
translationsFilterWording
	^ (self translationsFilter isEmpty
		ifTrue: ['filter' translated]
		ifFalse: ['filtering: {1}' translated format:{self translationsFilter}]) ! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'gm 8/30/2003 02:00'!
translationsKeystroke: aChar 
	"Respond to a Command key in the translations list."
	aChar == $x
		ifTrue: [^ self removeTranslation].
	aChar == $E
		ifTrue: [^ self browseMethodsWithTranslation]! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:49'!
translationsMenu: aMenu 
	^ aMenu add: 'remove (x)' translated action: #removeTranslation;
		 add: 'where (E)' translated action: #browseMethodsWithTranslation;
		 add: 'select all' translated action: #selectAllTranslation;
		 add: 'deselect all' translated action: #deselectAllTranslation;
		 add: 'select changed keys' translated action: #selectNewerKeys;
		 add: 'export selection' translated action: #codeSelectedTranslation;
		 add: 'export selection in do-it form' translated action: #codeSelectedTranslationAsMimeString;
		 add: 'reset changed keys' translated action: #resetNewerKeys;
		 yourself! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:19'!
untranslatedFilterWording
	^ self untranslatedFilter isEmpty
		ifTrue: ['filter' translated]
		ifFalse: ['filtering: {1}' translated format: {self untranslatedFilter}]! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'gm 8/30/2003 02:01'!
untranslatedKeystroke: aChar 
	"Respond to a Command key in the translations list."
	aChar == $t
		ifTrue: [^ self translate].
	aChar == $E
		ifTrue: [^ self browseMethodsWithUntranslated]! !

!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 10/13/2003 18:30'!
untranslatedMenu: aMenu 
	^ aMenu add: 'remove' translated action: #removeUntranslated;
		 add: 'translate (t)' translated action: #translate;
		 add: 'where (E)' translated action: #browseMethodsWithUntranslated;
		 yourself! !


!LanguageEditor methodsFor: 'initialization' stamp: 'yo 3/1/2005 12:33'!
initializeNewerKeys

	newerKeys _ Set new.
! !

!LanguageEditor methodsFor: 'initialization' stamp: 'yo 3/1/2005 12:33'!
initializeOn: aLanguage 
	"initialize the receiver on aLanguage"
	""
	selectedTranslation := 0.
	selectedUntranslated := 0.
	selectedTranslations := IdentitySet new.
	""
	translator := aLanguage.
	""
	self setLabel: 'Language editor for: ' translated , self translator name.
	""
	self initializeToolbars.
	self initializePanels.
	self initializeStatusbar.
	self initializeNewerKeys.
! !

!LanguageEditor methodsFor: 'initialization' stamp: 'tak 11/28/2004 14:12'!
initializePanels
	"initialize the receiver's panels"
	translationsList := PluggableListMorphOfMany
				on: self
				list: #translations
				primarySelection: #selectedTranslation
				changePrimarySelection: #selectedTranslation:
				listSelection: #selectedTranslationsAt:
				changeListSelection: #selectedTranslationsAt:put:
				menu: #translationsMenu:
				keystroke: #translationsKeystroke:.
	translationsList setBalloonText: 'List of all the translated phrases.' translated.
	""
	untranslatedList := PluggableListMorph
				on: self
				list: #untranslated
				selected: #selectedUntranslated
				changeSelected: #selectedUntranslated:
				menu: #untranslatedMenu:
				keystroke: #untranslatedKeystroke:.
	untranslatedList setBalloonText: 'List of all the untranslated phrases.' translated.
	""
	translationText := PluggableTextMorph
				on: self
				text: #translation
				accept: #translation:
				readSelection: nil
				menu: nil.
	translationText setBalloonText: 'Translation for the selected phrase in the upper list.' translated.
	""
	self
		addMorph: translationsList
		frame: (0 @ 0.18 corner: 0.5 @ 0.66).
	self
		addMorph: untranslatedList
		frame: (0.5 @ 0.18 corner: 1 @ 0.93).
	self
		addMorph: translationText
		frame: (0 @ 0.66 corner: 0.5 @ 0.93)! !


!LanguageEditor methodsFor: 'initialization - statusbar' stamp: 'tak 11/15/2004 12:15'!
createStatusbar
	"create the statusbar for the receiver"
	| statusbar |
	statusbar := self createRow.
	statusbar addMorph: ((UpdatingStringMorph on: self selector: #status) growable: true;
			 useStringFormat;
			 hResizing: #spaceFill;
			 stepTime: 2000).
	^ statusbar! !

!LanguageEditor methodsFor: 'initialization - statusbar' stamp: 'dgd 9/21/2003 11:39'!
initializeStatusbar
	"initialize the receiver's statusbar"
	self
		addMorph: self createStatusbar
		frame: (0 @ 0.93 corner: 1 @ 1)! !


!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'tak 11/16/2004 15:07'!
createButtonLabel: aString action: actionSelector help: helpString 
	"create a toolbar for the receiver"
	| button |
	button := SimpleButtonMorph new target: self;
				 label: aString translated "font: Preferences standardButtonFont";
				 actionSelector: actionSelector;
				 setBalloonText: helpString translated;
				 color: translator defaultBackgroundColor twiceDarker;
				 borderWidth: 2;
				 borderColor: #raised.
	""
	^ button! !

!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'mir 7/21/2004 18:01'!
createMainToolbar
	"create a toolbar for the receiver"
	| toolbar |
	toolbar := self createRow.
	""
"	toolbar
		addMorphBack: (self
				createUpdatingButtonWording: #debugWording
				action: #switchDebug
				help: 'Switch the debug flag')."
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	""
	toolbar
		addMorphBack: (self
				createButtonLabel: 'save'
				action: #saveToFile
				help: 'Save the translations to a file').
	toolbar
		addMorphBack: (self
				createButtonLabel: 'load'
				action: #loadFromFile
				help: 'Load the translations from a file').
	toolbar
		addMorphBack: (self
				createButtonLabel: 'merge'
				action: #mergeFromFile
				help: 'Merge the current translations with the translations in a file').
	""
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'apply'
				action: #applyTranslations
				help: 'Apply the translations as much as possible.').
	""
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'check translations'
				action: #check
				help: 'Check the translations and report the results.').
	toolbar
		addMorphBack: (self
				createButtonLabel: 'report'
				action: #report
				help: 'Create a report.').
	toolbar
		addMorphBack: (self
				createButtonLabel: 'gettext export'
				action: #getTextExport
				help: 'Exports the translations in GetText format.').
	""
	^ toolbar! !

!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'dgd 9/21/2003 11:46'!
createRow
	"create a row"
	| row |
	row := AlignmentMorph newRow.
	row layoutInset: 3;
		 wrapCentering: #center;
		 cellPositioning: #leftCenter.
	""
	^ row! !

!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'yo 2/17/2005 18:24'!
createTranslationsToolbar
	"create a toolbar for the receiver"
	| toolbar |
	toolbar := self createRow.
	""
	toolbar
		addMorphBack: (self
				createUpdatingButtonWording: #translationsFilterWording
				action: #filterTranslations
				help: 'Filter the translations list.').
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	""
	toolbar
		addMorphBack: (self
				createButtonLabel: 'search'
				action: #searchTranslation
				help: 'Search for a translation containing...').
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'remove'
				action: #removeTranslation
				help: 'Remove the selected translation.  If none is selected, ask for the one to remove.').
	""
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'where'
				action: #browseMethodsWithTranslation
				help: 'Launch a browser on all methods that contain the phrase as a substring of any literal String.').
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'r-unused'
				action: #removeTranslatedButUnusedStrings
				help: 'Remove all the strings that are not used by the system').
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'add '
				action: #addTranslation
				help: 'Add a new phrase').

	^ toolbar! !

!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'sd 12/18/2004 18:10'!
createUntranslatedToolbar
	"create a toolbar for the receiver"
	| toolbar |
	toolbar := self createRow.
	""
	toolbar
		addMorphBack: (self
				createUpdatingButtonWording: #untranslatedFilterWording
				action: #filterUntranslated
				help: 'Filter the untranslated list.').
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	""
	toolbar
		addMorphBack: (self
				createButtonLabel: 'search'
				action: #searchUntranslated
				help: 'Search for a untranslated phrase containing...').
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'remove'
				action: #removeUntranslated
				help: 'Remove the selected untranslated phrease.  If none is selected, ask for the one to remove.').
	""
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'translate'
				action: #translate
				help: 'Translate the selected untranslated phrase or a new phrase').
	""
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'where'
				action: #browseMethodsWithUntranslated
				help: 'Launch a browser on all methods that contain the phrase as a substring of any literal String.').
	toolbar addTransparentSpacerOfSize: 5 @ 0.
	toolbar
		addMorphBack: (self
				createButtonLabel: 'r-unused'
				action: #removeUntranslatedButUnusedStrings
				help: 'Remove all the strings that are not used by the system').
	^ toolbar! !

!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'tak 11/16/2004 15:06'!
createUpdatingButtonWording: wordingSelector action: actionSelector help: helpString 
	"create a toolbar for the receiver"
	| button |
	button := (UpdatingSimpleButtonMorph newWithLabel: '-') target: self;
				 wordingSelector: wordingSelector;
				 actionSelector: actionSelector;
				 setBalloonText: helpString translated;
				 color: translator defaultBackgroundColor twiceDarker;
				 borderWidth: 1;
				 borderColor: #raised; cornerStyle: #square.
	""
	^ button! !

!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'dgd 9/21/2003 11:27'!
initializeToolbars
	"initialize the receiver's toolbar"
	self
		addMorph: self createMainToolbar
		frame: (0 @ 0 corner: 1 @ 0.09).
	""
	self
		addMorph: self createTranslationsToolbar
		frame: (0 @ 0.09 corner: 0.5 @ 0.18).
	self
		addMorph: self createUntranslatedToolbar
		frame: (0.5 @ 0.09 corner: 1 @ 0.18)! !


!LanguageEditor methodsFor: 'message handling' stamp: 'gm 8/30/2003 01:54'!
perform: selector orSendTo: otherTarget 
	"I wish to intercept and handle selector myself"
	^ self perform: selector! !


!LanguageEditor methodsFor: 'open/close' stamp: 'dgd 8/26/2003 14:20'!
delete
	"Remove the receiver as a submorph of its owner"
	self model: nil.
	super delete ! !


!LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:24'!
asHtml: aString 
	| stream |
	stream := String new writeStream.

	aString
		do: [:each | 
			each caseOf: {
				[Character cr] -> [stream nextPutAll: '<br>'].
				[$&] -> [stream nextPutAll: '&amp;'].
				[$<] -> [stream nextPutAll: '&lt;'].
				[$>] -> [stream nextPutAll: '&gt;'].
				[$*] -> [stream nextPutAll: '&star;'].
				[$@] -> [stream nextPutAll: '&at;']}
				 otherwise: [stream nextPut: each]].

	^ stream contents! !

!LanguageEditor methodsFor: 'reporting' stamp: 'mir 8/11/2004 09:59'!
printHeaderReportOn: aStream 
	"append to aStream a header report of the receiver with swiki  
	format"
	aStream nextPutAll: '!!!!';
		
		nextPutAll: ('Language: {1}' translated format: {self translator localeID isoString});
		 cr.

	aStream nextPutAll: '- ';
		
		nextPutAll: ('{1} translated phrases' translated format: {self translator translations size});
		 cr.

	aStream nextPutAll: '- ';
		
		nextPutAll: ('{1} untranslated phrases' translated format: {self translator untranslated size});
		 cr.

	aStream cr; cr! !

!LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:25'!
printReportOn: aStream 
	"append to aStream a report of the receiver with swiki format"
	self printHeaderReportOn: aStream.
	self printUntranslatedReportOn: aStream.
	self printTranslationsReportOn: aStream! !

!LanguageEditor methodsFor: 'reporting' stamp: 'mir 8/11/2004 10:01'!
printTranslationsReportOn: aStream 
	"append to aStream a report of the receiver's translations"
	| originalPhrases |
	aStream nextPutAll: '!!';
		 nextPutAll: 'translations' translated;
		 cr.

	originalPhrases := self translator translations keys asSortedCollection.

	originalPhrases
		do: [:each | 
			aStream
				nextPutAll: ('|{1}|{2}|' format: {self asHtml: each. self
							asHtml: (self translator translationFor: each)});
				 cr].

	aStream cr; cr! !

!LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:26'!
printUntranslatedReportOn: aStream 
	"append to aStream a report of the receiver's translations"
	aStream nextPutAll: '!!';
		 nextPutAll: 'not translated' translated;
		 cr.

	self untranslated asSortedCollection
		do: [:each | 
			aStream
				nextPutAll: ('|{1}|' format: {self asHtml: each});
				 cr].

	aStream cr; cr! !

!LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:26'!
reportString
	"answer a string with a report of the receiver"
	| stream |
	stream := String new writeStream.
	self printReportOn: stream.
	^ stream contents! !


!LanguageEditor methodsFor: 'stef' stamp: 'ar 4/10/2005 18:48'!
identifyUnusedStrings
	"self new identifyUnusedStrings"
	translationsList getList
		do: [:each | 
			Transcript show: each.
			Transcript show: (Smalltalk
					allSelect: [:method | method
							hasLiteralSuchThat: [:lit | lit isString
									and: [lit includesSubstring: each caseSensitive: true]]]) size printString; cr]! !

!LanguageEditor methodsFor: 'stef' stamp: 'ar 4/10/2005 18:48'!
numberOfTimesStringIsUsed: aString

	^ (self systemNavigation allSelect: [:method | method
							hasLiteralSuchThat: [:lit | lit isString
									and: [lit includesSubstring: aString caseSensitive: true]]]) size! !

!LanguageEditor methodsFor: 'stef' stamp: 'tak 1/4/2005 09:26'!
removeTranslatedButUnusedStrings
	(self confirm: 'Are you sure that you want to remove unused strings?' translated)
		ifFalse: [^ self].
	translationsList getList
		do: [:each | 
			| timesUsed | 
			timesUsed := self numberOfTimesStringIsUsed: each.
			Transcript show: each.
			Transcript show: timesUsed printString;
				 cr.
			timesUsed isZero
				ifTrue: [self translator removeTranslationFor: each]]! !

!LanguageEditor methodsFor: 'stef' stamp: 'yo 1/14/2005 16:55'!
removeUntranslatedButUnusedStrings
	(self confirm: 'Are you sure that you want to remove unused strings?' translated)
		ifFalse: [^ self].
	untranslatedList getList
		do: [:each | 
			| timesUsed | 
			timesUsed := self numberOfTimesStringIsUsed: each.
			Transcript show: each.
			Transcript show: timesUsed printString;
				 cr.
			timesUsed isZero 
				ifTrue: [self translator removeUntranslated: each]].

	self update: #untranslated.
! !


!LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/28/2003 10:31'!
okToChange
	"Allows a controller to ask this of any model"
	self selectedTranslation isZero
		ifTrue: [^ true].
	""
	translationText hasUnacceptedEdits
		ifFalse: [^ true].
	^ (CustomMenu confirm: 'Discard the changes to currently selected translated phrase?' translated)
		and: [""
			translationText hasUnacceptedEdits: false.
			true]! !

!LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/27/2003 19:59'!
refreshTranslations
	"refresh the translations panel"
	self changed: #translations.
	self selectedTranslation: 0! !

!LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/27/2003 19:59'!
refreshUntranslated
"refresh the untranslated panel"
	self changed: #untranslated.
	self selectedUntranslated: 0! !

!LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/25/2003 20:11'!
update: aSymbol 
	"Receive a change notice from an object of whom the receiver  
	is a dependent."
	super update: aSymbol.
	""
	aSymbol == #untranslated
		ifTrue: [self refreshUntranslated].
	aSymbol == #translations
		ifTrue: [self refreshTranslations]! !


!LanguageEditor methodsFor: 'private' stamp: 'mir 8/11/2004 09:58'!
check
	"check the translations and answer a collection with the results"
	| results counter phrasesCount  untranslated translations checkMethod |
	results := OrderedCollection new.
	untranslated := self translator untranslated.
	translations := self translator translations.
	phrasesCount := translations size + untranslated size.
	counter := 0.
	checkMethod := self class checkMethods at: self translator localeID printString ifAbsent: [^results].
	
	translations
		keysAndValuesDo: [:phrase :translation | 
			| result | 
			result := self perform: checkMethod with: phrase with: translation.
			(result notNil
					and: [result notEmpty])
				ifTrue: [results add: {phrase. translation. result}].
		
			counter := counter + 1.
			(counter isDivisibleBy: 50)
				ifTrue: [| percent | 
					percent := counter / phrasesCount * 100 roundTo: 0.01.
					Transcript
						show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent});
						 cr]].

	untranslated
		do: [:phrase | 
			| result | 
			result := self checkUntranslatedPhrase: phrase.
			(result notNil
					and: [result notEmpty])
				ifTrue: [results add: {phrase. nil. result}].
		
			counter := counter + 1.
			(counter isDivisibleBy: 50)
				ifTrue: [| percent | 
					percent := counter / phrasesCount * 100 roundTo: 0.01.
					Transcript
						show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent});
						 cr]].

	^ results! !

!LanguageEditor methodsFor: 'private' stamp: 'mir 7/21/2004 18:58'!
checkPhrase: phraseString translation: translationString
	^nil! !

!LanguageEditor methodsFor: 'private' stamp: 'tak 12/26/2004 12:10'!
checkSpanishPhrase: phraseString translation: translationString 
	"check the translation an aswer a string with a comment or a  
	nil meaning no-comments"
	| superResult |
	superResult := self checkPhrase: phraseString translation: translationString.

	superResult isNil
		ifFalse: [^ superResult].
"For some reason, MCInstaller couldn't read Spanish character."
"	((translationString withBlanksTrimmed includes: $?)
			and: [(translationString withBlanksTrimmed includes: $é…) not])
		ifTrue: [^ 'é…OlvidƧ el signo de pregunta?'].
	((translationString withBlanksTrimmed includes: $!!)
			and: [(translationString withBlanksTrimmed includes: $éÄ) not])
		ifTrue: [^ 'é…OlvidƧ el signo de admiraciƧn?'].
"
	^ nil! !

!LanguageEditor methodsFor: 'private' stamp: 'mir 7/21/2004 18:57'!
checkUntranslatedPhrase: phraseString 
	"check the phrase an aswer a string with a comment or a nil  
	meaning no-comments"

	(self translations includes: phraseString)
		ifTrue: [^ 'possible double-translation' translated].

	^ nil! !

!LanguageEditor methodsFor: 'private' stamp: 'mir 8/11/2004 09:57'!
translator
	^translator! !

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

LanguageEditor class
	instanceVariableNames: ''!

!LanguageEditor class methodsFor: 'initialize-release' stamp: 'mir 7/21/2004 18:47'!
initCheckMethods
	"LanguageEditor initCheckMethods"

	| registry |
	registry := Dictionary new.
	registry
		at: 'es' put: #checkSpanishPhrase:translation:;
		yourself.
	^registry! !

!LanguageEditor class methodsFor: 'initialize-release' stamp: 'dgd 11/9/2003 14:27'!
initialize
	"initialize the receiver"
	(TheWorldMenu respondsTo: #registerOpenCommand:)
		ifTrue: [""
			TheWorldMenu registerOpenCommand: {'Language Editor'. {self. #openOnDefault}}.
			TheWorldMenu registerOpenCommand: {'Language Editor for...'. {self. #open}}]! !

!LanguageEditor class methodsFor: 'initialize-release' stamp: 'dgd 11/9/2003 14:27'!
unload
	"the receiver is being unloaded"
	(TheWorldMenu respondsTo: #registerOpenCommand:)
		ifTrue: [""
			TheWorldMenu unregisterOpenCommand: 'Language Editor'.
			TheWorldMenu unregisterOpenCommand: 'Language Editor for...'] ! !


!LanguageEditor class methodsFor: 'instance creation' stamp: 'mir 7/21/2004 17:00'!
on: aLanguage
	"answer an instance of the receiver on aLanguage"
	^ self new initializeOn: (NaturalLanguageTranslator localeID: aLanguage)! !

!LanguageEditor class methodsFor: 'instance creation' stamp: 'mir 8/11/2004 10:00'!
openOn: aLanguage 
	"open an instance on aLanguage"
	World submorphs
		do: [:each | ""
			((each isKindOf: LanguageEditor)
					and: [each translator == aLanguage])
				ifTrue: [""
					self ensureVisibilityOfWindow: each.
					^ self]].
	""
	^ (self on: aLanguage) openInWorld! !


!LanguageEditor class methodsFor: 'opening' stamp: 'mir 7/21/2004 16:57'!
open
	"open the receiver on any language"
	" 
	LanguageEditor open. 
	"
	| menu |
	menu := MenuMorph new defaultTarget: self.
	menu addTitle: 'Language Editor for...' translated.
	""
	(NaturalLanguageTranslator availableLanguageLocaleIDs
		asSortedCollection: [:x :y | x asString <= y asString])
		do: [:eachLanguage | ""
			menu
				add: eachLanguage name
				target: self
				selector: #openOn:
				argument: eachLanguage].
	""
	menu popUpInWorld! !

!LanguageEditor class methodsFor: 'opening' stamp: 'TN 4/8/2005 01:13'!
openOnDefault
	"open the receiver on the default language"
	self openOn: LocaleID current! !


!LanguageEditor class methodsFor: 'private' stamp: 'mir 7/21/2004 18:47'!
checkMethods
	^CheckMethods ifNil: [CheckMethods := self initCheckMethods]! !

!LanguageEditor class methodsFor: 'private' stamp: 'dgd 11/9/2003 15:39'!
ensureVisibilityOfWindow: aWindow 
	"private - activate the window"
	| |
	aWindow expand.
	aWindow comeToFront.
	""
	aWindow
		right: (aWindow right min: World right).
	aWindow
		bottom: (aWindow bottom min: World bottom).
	aWindow
		left: (aWindow left max: World left).
	aWindow
		top: (aWindow top max: World top).
	""
	aWindow flash; flash! !
Object subclass: #LanguageEnvironment
	instanceVariableNames: 'id'
	classVariableNames: 'ClipboardInterpreterClass Current FileNameConverterClass InputInterpreterClass KnownEnvironments SystemConverterClass'
	poolDictionaries: ''
	category: 'Multilingual-Languages'!
!LanguageEnvironment commentStamp: '<historical>' prior: 0!
The name multilingualized Squeak suggests that you can use multiple language at one time.  This is true, of course, but the system still how to manage the primary language; that provides the interpretation of data going out or coming in from outside world. It also provides how to render strings, as there rendering rule could be different in one language to another, even if the code points in a string is the same.

  Originally, LanguageEnvironment and its subclasses only has class side methods.  After merged with Diego's Babel work, it now has instance side methods.  Since this historical reason, the class side and instance side are not related well.

  When we talk about the interface with the outside of the Squeak world, there are three different "channels"; the keyboard input, clipboard output and input, and filename.  On a not-to-uncommon system such as a Unix system localized to Japan, all of these three can have (and does have) different encodings.  So we need to manage them separately.  Note that the encoding in a file can be anything.  While it is nice to provide a suggested guess for this 'default system file content encoding', it is not critical.

  Rendering support is limited basic L-to-R rendering so far.  But you can provide different line-wrap rule, at least.
!


!LanguageEnvironment methodsFor: 'accessing' stamp: 'tak 8/4/2005 11:02'!
fontEncodingName
	^ #Font , self class name! !

!LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:32'!
isoCountry
	^self localeID isoCountry! !

!LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:32'!
isoLanguage
	^self localeID isoLanguage! !

!LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 18:55'!
leadingChar
	^self class leadingChar! !

!LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:31'!
localeID
	^id! !


!LanguageEnvironment methodsFor: 'initialize-release' stamp: 'mir 7/15/2004 15:31'!
localeID: anID
	id := anID! !


!LanguageEnvironment methodsFor: 'utilities' stamp: 'mir 7/21/2004 18:05'!
checkPhrase: phrase translation: translation
	"check the translation.
	Answer a string with a comment or meaning no-comments"
	^nil! !

!LanguageEnvironment methodsFor: 'utilities' stamp: 'tak 11/28/2005 17:28'!
setupSqueaklandSpecifics
	"Write language specific settings here"! !


!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/5/2005 21:04'!
fontDownload
	"(Locale isoLanguage: 'ja') languageEnvironment fontDownload"
	| contents f |
	(FileDirectory default fileExists: self fontFullName)
		ifTrue: [^ self].
	Cursor read
		showWhile: [self fontDownloadUrls
				do: [:each | [contents := (each , '/' , self fontFileName) asUrl retrieveContents contents.
					(contents first: 2)
							= 'PK'
						ifTrue: [f := FileStream newFileNamed: self fontFullName.
							f binary.
							[f nextPutAll: contents]
								ensure: [f close].
							^ self]]
						on: NameLookupFailure
						do: [:e | e]]].
	self error: 'Fonts does not found (' , self fontFullName , ')'! !

!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/5/2005 21:05'!
fontDownloadUrls
	^ #('http://metatoys.org/pub/' )! !

!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/5/2005 20:46'!
fontFileName
	"(Locale isoLanguage: 'ja') languageEnvironment fontFileName"
	^ self fontEncodingName , '.sar'! !

!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/7/2005 12:27'!
fontFullName
	"(Locale isoLanguage: 'ja') languageEnvironment fontFullName"
	| dir |
	dir := FileDirectory on: SecurityManager default untrustedUserDirectory.
	"dir exists is needed if it is in restricted mode"
	dir exists
		ifFalse: [dir assureExistence].
	^ dir fullNameFor: self fontFileName! !

!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/5/2005 21:00'!
installFont
	"(Locale isoLanguage: 'ja') languageEnvironment installFont"
	self fontDownload.
	SARInstaller installSAR: self fontFullName! !

!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/4/2005 11:50'!
isFontAvailable
	| encoding |
	encoding := self leadingChar + 1.
	TextStyle defaultFont fontArray
		at: encoding
		ifAbsent: [^ false].
	^ true! !

!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/4/2005 11:08'!
removeFonts
	"(Locale isoLanguage: 'ja') languageEnvironment removeFonts"
	StrikeFontSet removeFontsForEncoding: self leadingChar encodingName: self fontEncodingName! !

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

LanguageEnvironment class
	instanceVariableNames: ''!

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'!
canBeGlobalVarInitial: char

	^ Unicode canBeGlobalVarInitial: char.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'!
canBeNonGlobalVarInitial: char

	^ Unicode canBeNonGlobalVarInitial: char.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 7/28/2004 21:34'!
currentPlatform

	^ Locale currentPlatform languageEnvironment.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'!
digitValue: char

	^ Unicode digitValue: char.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 12/2/2004 16:13'!
isCharset

	^ false.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'!
isDigit: char

	^ Unicode isDigit: char.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'!
isLetter: char

	^ Unicode isLetter: char.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'!
isLowercase: char

	^ Unicode isLowercase: char.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'!
isUppercase: char

	^ Unicode isUppercase: char.
! !

!LanguageEnvironment class methodsFor: 'accessing' stamp: 'mir 8/31/2005 17:19'!
localeID: localeID
	^self knownEnvironments at: localeID ifAbsent: [self localeID: (LocaleID isoLanguage: 'en')]! !


!LanguageEnvironment class methodsFor: 'class initialization' stamp: 'yo 3/15/2004 21:15'!
clearDefault

	ClipboardInterpreterClass _ nil.
	InputInterpreterClass _ nil.
	SystemConverterClass _ nil.
	FileNameConverterClass _ nil.
! !

!LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 15:54'!
initialize
	"LanguageEnvironment initialize"

	Smalltalk addToStartUpList: LanguageEnvironment after: FileDirectory.
	Smalltalk addToStartUpList: FileDirectory after: LanguageEnvironment.
! !

!LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 16:13'!
localeChanged
	self startUp! !

!LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/21/2004 19:10'!
resetKnownEnvironments
	"LanguageEnvironment resetKnownEnvironments"

	KnownEnvironments := nil! !

!LanguageEnvironment class methodsFor: 'class initialization' stamp: 'tak 8/4/2005 14:49'!
startUp

	self clearDefault.
	Clipboard startUp.
	HandMorph startUp.
! !


!LanguageEnvironment class methodsFor: 'language methods' stamp: 'yo 1/18/2005 15:56'!
scanSelector

	^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:
! !


!LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:56'!
defaultClipboardInterpreter

	ClipboardInterpreterClass ifNil: [ClipboardInterpreterClass _ self currentPlatform class clipboardInterpreterClass].
	^ ClipboardInterpreterClass new.

! !

!LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 3/15/2004 15:50'!
defaultEncodingName

	^ 'mac-roman'.
! !

!LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:56'!
defaultFileNameConverter
	FileNameConverterClass
		ifNil: [FileNameConverterClass := self currentPlatform class fileNameConverterClass].
	^ FileNameConverterClass new! !

!LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:36'!
defaultInputInterpreter

	InputInterpreterClass ifNil: [InputInterpreterClass _ self inputInterpreterClass].
	^ InputInterpreterClass new.
! !

!LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:56'!
defaultSystemConverter

	SystemConverterClass ifNil: [SystemConverterClass _ self currentPlatform class systemConverterClass].
	^ SystemConverterClass new.
! !


!LanguageEnvironment class methodsFor: 'rendering support' stamp: 'yo 7/2/2004 17:57'!
flapTabTextFor: aString

	"self subclassResponsibility."
	^ aString.

! !

!LanguageEnvironment class methodsFor: 'rendering support' stamp: 'yo 7/2/2004 17:57'!
flapTabTextFor: aString in: aFlapTab

	"self subclassResponsibility."
	^ aString.
! !

!LanguageEnvironment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 21:54'!
isBreakableAt: index in: text

	| char |
	char _ text at: index.
	char = Character space ifTrue: [^ true].
	char = Character cr ifTrue: [^ true].
	^ false.
! !


!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'!
clipboardInterpreterClass

	self subclassResponsibility.
	^ NoConversionClipboardInterpreter.
! !

!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'!
fileNameConverterClass

	self subclassResponsibility.
	^ Latin1TextConverter.
! !

!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'!
inputInterpreterClass

	self subclassResponsibility.
	^ MacRomanInputInterpreter.
! !

!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:11'!
leadingChar

	self subclassResponsibility.
	^ 0.
! !

!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 17:59'!
supportedLanguages
	"Return the languages that this class supports. 
	Any translations for those languages will use this class as their environment."
	self subclassResponsibility! !

!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'!
systemConverterClass

	self subclassResponsibility.
	^ Latin1TextConverter.
! !


!LanguageEnvironment class methodsFor: 'private' stamp: 'mir 7/28/2005 13:53'!
initKnownEnvironments
	"LanguageEnvironment initKnownEnvironments"

	| env known id |
	known := Dictionary new.
	self allSubclassesDo: [:subClass | 
		subClass supportedLanguages do: [:language | 
			env := subClass new.
			id _ LocaleID isoString: language.
			env localeID: id.
			known at: id put: env]].
	^known! !

!LanguageEnvironment class methodsFor: 'private' stamp: 'mir 7/15/2004 15:45'!
knownEnvironments
	"LanguageEnvironment knownEnvironments"
	"KnownEnvironments := nil"

	^KnownEnvironments ifNil: [KnownEnvironments := self initKnownEnvironments]! !
LargePositiveInteger variableByteSubclass: #LargeNegativeInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!LargeNegativeInteger commentStamp: '<historical>' prior: 0!
Just like LargePositiveInteger, but represents a negative number.!


!LargeNegativeInteger methodsFor: 'arithmetic'!
abs
	^ self negated! !

!LargeNegativeInteger methodsFor: 'arithmetic'!
negated
	^ self copyto: (LargePositiveInteger new: self digitLength)! !


!LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:10'!
highBit
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. Raise an error if the receiver is negative, since  
	negative integers are defined to have an infinite number of leading 1's 
	in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to  
	get the highest bit of the magnitude."

	^ self shouldNotImplement! !


!LargeNegativeInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:10'!
normalize
	"Check for leading zeroes and return shortened copy if so"
	| sLen val len oldLen minVal |
	<primitive: 'primNormalizeNegative' module:'LargeIntegers'>
	"First establish len = significant length"
	len _ oldLen _ self digitLength.
	[len = 0 ifTrue: [^0].
	(self digitAt: len) = 0]
		whileTrue: [len _ len - 1].

	"Now check if in SmallInteger range"
	sLen _ 4  "SmallInteger minVal digitLength".
	len <= sLen ifTrue:
		[minVal _ SmallInteger minVal.
		(len < sLen
			or: [(self digitAt: sLen) < minVal lastDigit])
			ifTrue: ["If high digit less, then can be small"
					val _ 0.
					len to: 1 by: -1 do:
						[:i | val _ (val *256) - (self digitAt: i)].
					^ val].
		1 to: sLen do:  "If all digits same, then = minVal"
			[:i | (self digitAt: i) = (minVal digitAt: i)
					ifFalse: ["Not so; return self shortened"
							len < oldLen
								ifTrue: [^ self growto: len]
								ifFalse: [^ self]]].
		^ minVal].

	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: [^ self growto: len]
		ifFalse: [^ self]! !


!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'!
negative
	"Answer whether the receiver is mathematically negative."

	^ true! !

!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:00'!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ false! !

!LargeNegativeInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'!
sign
	"Optimization. Answer -1 since receiver is less than 0."

	^ -1
! !

!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:03'!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ false! !

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

LargeNegativeInteger class
	instanceVariableNames: ''!

!LargeNegativeInteger class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 12:05'!
initializedInstance
	^ -9876543210987654321 copy! !
ClassTestCase subclass: #LargeNegativeIntegerTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!

!LargeNegativeIntegerTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:36'!
testEmptyTemplate
	"Check that an uninitialized instance behaves reasonably."

	| i |
	i := LargeNegativeInteger new: 4.
	self assert: i size == 4.
	self assert: i printString = '-0'.
	self assert: i normalize == 0! !
Integer variableByteSubclass: #LargePositiveInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!LargePositiveInteger commentStamp: '<historical>' prior: 0!
I represent positive integers of more than 30 bits (ie, >= 1073741824).  These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits.  Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger IS a SmallInteger (see normalize).

Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits.  This is a great help to the simulator.!


!LargePositiveInteger methodsFor: 'arithmetic'!
* anInteger 
	"Primitive. Multiply the receiver by the argument and answer with an
	Integer result. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive. "

	<primitive: 29>
	^super * anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
+ anInteger 
	"Primitive. Add the receiver to the argument and answer with an
	Integer result. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 21>
	^super + anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
- anInteger 
	"Primitive. Subtract the argument from the receiver and answer with an
	Integer result. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 22>
	^super - anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
/ anInteger 
	"Primitive. Divide the receiver by the argument and answer with the
	result if the division is exact. Fail if the result is not a whole integer.
	Fail if the argument is 0. Fail if either the argument or the result is not
	a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive. "

	<primitive: 30>
	^super / anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
// anInteger 
	"Primitive. Divide the receiver by the argument and return the result.
	Round the result down towards negative infinity to make it a whole
	integer. Fail if the argument is 0. Fail if either the argument or the
	result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824).
	Optional. See Object documentation whatIsAPrimitive. "

	<primitive: 32>
	^super // anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
\\ anInteger 
	"Primitive. Take the receiver modulo the argument. The result is the
	remainder rounded towards negative infinity, of the receiver divided
	by the argument. Fail if the argument is 0. Fail if either the argument
	or the result is not a SmallInteger or a LargePositiveInteger less than
	2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 31>
	^super \\ anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'RAA 5/31/2000 13:21'!
\\\ anInteger 
	"a faster modulo method for use in DSA. Be careful if you try to use this elsewhere"

	^(self digitDiv: anInteger neg: false) second! !

!LargePositiveInteger methodsFor: 'arithmetic'!
abs! !

!LargePositiveInteger methodsFor: 'arithmetic'!
negated 
	^ (self copyto: (LargeNegativeInteger new: self digitLength))
		normalize  "Need to normalize to catch SmallInteger minVal"! !

!LargePositiveInteger methodsFor: 'arithmetic'!
quo: anInteger 
	"Primitive. Divide the receiver by the argument and return the result.
	Round the result down towards zero to make it a whole integer. Fail if
	the argument is 0. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 33>
	^super quo: anInteger! !


!LargePositiveInteger methodsFor: 'bit manipulation'!
bitAnd: anInteger 
	"Primitive. Answer an Integer whose bits are the logical AND of the
	receiver's bits and those of the argument. Fail if the receiver or argument
	is greater than 32 bits. See Object documentation whatIsAPrimitive."
	<primitive: 14>
	^ super bitAnd: anInteger! !

!LargePositiveInteger methodsFor: 'bit manipulation'!
bitOr: anInteger 
	"Primitive. Answer an Integer whose bits are the logical OR of the
	receiver's bits and those of the argument. Fail if the receiver or argument
	is greater than 32 bits. See Object documentation whatIsAPrimitive."
	<primitive: 15>
	^ super bitOr: anInteger! !

!LargePositiveInteger methodsFor: 'bit manipulation'!
bitShift: anInteger 
	"Primitive. Answer an Integer whose value (in twos-complement 
	representation) is the receiver's value (in twos-complement
	representation) shifted left by the number of bits indicated by the
	argument. Negative arguments shift right. Zeros are shifted in from the
	right in left shifts. The sign bit is extended in right shifts.
	Fail if the receiver or result is greater than 32 bits.
	See Object documentation whatIsAPrimitive."
	<primitive: 17>
	^super bitShift: anInteger! !

!LargePositiveInteger methodsFor: 'bit manipulation'!
bitXor: anInteger 
	"Primitive. Answer an Integer whose bits are the logical XOR of the
	receiver's bits and those of the argument. Fail if the receiver or argument
	is greater than 32 bits. See Object documentation whatIsAPrimitive."
	<primitive: 16>
	^ super bitXor: anInteger! !

!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'SqR 9/18/2000 15:17'!
hashMultiply
	"Truncate to 28 bits and try again"

	^(self bitAnd: 16rFFFFFFF) hashMultiply! !

!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:11'!
highBit
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. Raise an error if the receiver is negative, since  
	negative integers are defined to have an infinite number of leading 1's 
	in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to  
	get the highest bit of the magnitude."
	^ self highBitOfMagnitude! !

!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:15'!
highBitOfMagnitude
	"Answer the index of the high order bit of the magnitude of the  
	receiver, or zero if the receiver is zero.  
	This method is used for LargeNegativeIntegers as well,  
	since Squeak's LargeIntegers are sign/magnitude."
	| realLength lastDigit |
	realLength _ self digitLength.
	[(lastDigit _ self digitAt: realLength) = 0]
		whileTrue: [(realLength _ realLength - 1) = 0 ifTrue: [^ 0]].
	^ lastDigit highBitOfPositiveReceiver + (8 * (realLength - 1))! !


!LargePositiveInteger methodsFor: 'comparing'!
< anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is less than the argument. Otherwise answer false. Fail if the
	argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824).
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 23>
	^super < anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
<= anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is less than or equal to the argument. Otherwise answer false.
	Fail if the argument is not a SmallInteger or a LargePositiveInteger less
	than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 25>
	^super <= anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
= anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is equal to the argument. Otherwise answer false. Fail if the
	receiver or argument is negative or greater than 32 bits.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 7>
	^ super = anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
> anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is greater than the argument. Otherwise answer false. Fail if
	the argument is not a SmallInteger or a LargePositiveInteger less than
	2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 24>
	^super > anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
>= anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is greater than or equal to the argument. Otherwise answer
	false. Fail if the argument is not a SmallInteger or a LargePositiveInteger
	less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 26>
	^super >= anInteger! !

!LargePositiveInteger methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'!
hash

	^ByteArray
		hashBytes: self
		startingWith: self species hash! !

!LargePositiveInteger methodsFor: 'comparing'!
~= anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is equal to the argument. Otherwise answer false. Fail if the
	receiver or argument is negative or greater than 32 bits.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 8>
	^ super ~= anInteger! !


!LargePositiveInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:28'!
as31BitSmallInt
	"This is only for 31 bit numbers.  Keep my 31 bits the same, but put them in a small int.  The small int will be negative since my 31st bit is 1.  We know my 31st bit is 1 because otherwise I would already be a positive small int."

	self highBit = 31 ifFalse: [self error: 'more than 31 bits can not fit in a SmallInteger'].

	^ self - 16r80000000! !

!LargePositiveInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:09'!
normalize
	"Check for leading zeroes and return shortened copy if so"
	| sLen val len oldLen |
	<primitive: 'primNormalizePositive' module:'LargeIntegers'>
	"First establish len = significant length"
	len _ oldLen _ self digitLength.
	[len = 0 ifTrue: [^0].
	(self digitAt: len) = 0]
		whileTrue: [len _ len - 1].

	"Now check if in SmallInteger range"
	sLen _ SmallInteger maxVal digitLength.
	(len <= sLen
		and: [(self digitAt: sLen) <= (SmallInteger maxVal digitAt: sLen)])
		ifTrue: ["If so, return its SmallInt value"
				val _ 0.
				len to: 1 by: -1 do:
					[:i | val _ (val *256) + (self digitAt: i)].
				^ val].

	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: [^ self growto: len]
		ifFalse: [^ self]! !

!LargePositiveInteger methodsFor: 'converting' stamp: 'RAA 3/2/2002 14:32'!
withAtLeastNDigits: desiredLength

	| new |

	self size >= desiredLength ifTrue: [^self].
	new _ self class new: desiredLength.
	new
		replaceFrom: 1 
		to: self size 
		with: self 
		startingAt: 1.
	^new! !


!LargePositiveInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'!
digitAt: index 
	"Primitive. Answer the value of an indexable field in the receiver.   LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256.  Fail if the argument (the index) is not an Integer or is out of bounds. Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 60>
	self digitLength < index
		ifTrue: [^0]
		ifFalse: [^super at: index]! !

!LargePositiveInteger methodsFor: 'system primitives'!
digitAt: index put: value 
	"Primitive. Store the second argument (value) in the indexable field of 
	the receiver indicated by index. Fail if the value is negative or is larger 
	than 255. Fail if the index is not an Integer or is out of bounds. Answer 
	the value that was stored. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 61>
	^super at: index put: value! !

!LargePositiveInteger methodsFor: 'system primitives'!
digitLength
	"Primitive. Answer the number of indexable fields in the receiver. This 
	value is the same as the largest legal subscript. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 62>
	self primitiveFailed! !

!LargePositiveInteger methodsFor: 'system primitives'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	^ super replaceFrom: start to: stop with: replacement startingAt: repStart! !


!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'!
negative
	"Answer whether the receiver is mathematically negative."

	^ false! !

!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:00'!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ true! !

!LargePositiveInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'!
sign
	"Optimization. Answer 1 since receiver is greater than 0."

	^ 1
! !

!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ true! !

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

LargePositiveInteger class
	instanceVariableNames: ''!

!LargePositiveInteger class methodsFor: 'testing' stamp: 'sw 5/8/2000 12:05'!
initializedInstance
	^ 12345678901234567 copy! !
ClassTestCase subclass: #LargePositiveIntegerTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!

!LargePositiveIntegerTest methodsFor: 'tests' stamp: 'md 3/17/2003 15:20'!
testBitShift

	"Check bitShift from and back to SmallInts"
	
	1 to: 257 do: [:i | self should: [((i bitShift: i) bitShift: 0-i) == i]].! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: 'dtl 5/26/2004 18:33'!
testEmptyTemplate

	"Check that an uninitialized instance behaves reasonably."

	| i |
	i _ LargePositiveInteger new: 4.
	self assert: i size == 4.
	self assert: i printString = '0'.
	self assert: i normalize == 0! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:52'!
testMultDicAddSub
	"self run: #testMultDicAddSub"

	| n f f1 |	
	n := 100.
	f := 100 factorial.
	f1 := f*(n+1).
	n timesRepeat: [f1 := f1 - f].
	self assert: (f1 = f). 

	n timesRepeat: [f1 := f1 + f].
	self assert: (f1 // f = (n+1)). 
	self assert: (f1 negated = (Number readFrom: '-' , f1 printString)).! !

!LargePositiveIntegerTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:53'!
testNormalize
	"self run: #testNormalize"
	"Check normalization and conversion to/from SmallInts"

	self assert: ((SmallInteger maxVal + 1 - 1) == SmallInteger maxVal).
	self assert: (SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3).
	self should: ((SmallInteger minVal - 1 + 1) == SmallInteger minVal).
	self assert: (SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3).! !
ImageMorph subclass: #LassoPatchMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!LassoPatchMorph commentStamp: 'sw 8/1/2004 13:27' prior: 0!
When dropped by the user, a cursor is presented, allowing the user to grab a rectangular patch from the screen.!


!LassoPatchMorph methodsFor: 'dropping' stamp: 'sw 4/6/2004 15:43'!
justDroppedInto: aPasteUpMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph"

	aPasteUpMorph isPartsBin ifFalse:
		[self delete.
		ActiveWorld displayWorldSafely; runStepMethods.
		^ aPasteUpMorph grabLassoFromScreen: anEvent].
	^ super justDroppedInto: aPasteUpMorph event: anEvent! !

!LassoPatchMorph methodsFor: 'dropping' stamp: 'sw 4/6/2004 13:19'!
wantsToBeDroppedInto: aMorph
	"Only into PasteUps that are not part bins"

	^ aMorph isPlayfieldLike! !


!LassoPatchMorph methodsFor: 'initialization' stamp: 'sw 7/5/2004 01:43'!
initialize
	"Initialize the receiver.  Sets its image to the lasso picture"

	super initialize.
	self image: (ScriptingSystem formAtKey: 'Lasso')! !

!LassoPatchMorph methodsFor: 'initialization' stamp: 'sw 7/5/2004 01:44'!
initializeToStandAlone
	"Initialize the receiver such that it can live on its own.  Sets its image to the lasso picture"

	super initializeToStandAlone.
	self image: (ScriptingSystem formAtKey: 'Lasso')! !


!LassoPatchMorph methodsFor: '*eToys-misc' stamp: 'sw 7/5/2004 01:50'!
isCandidateForAutomaticViewing
	"Answer whether the receiver is a candidate for automatic viewing.  Only relevant if a now-seldom-used feature, automaticViewing, is in play"

	^ self isPartsDonor not! !

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

LassoPatchMorph class
	instanceVariableNames: ''!

!LassoPatchMorph class methodsFor: 'instance creation' stamp: 'sw 7/5/2004 01:53'!
authoringPrototype
	"Answer a prototype  for use in a parts bin"

	^ self new image: (ScriptingSystem formAtKey: 'Lasso'); markAsPartsDonor; setBalloonText: 'Drop this on the desktop and you can then grab a patch from the screen with a lasso.'; yourself! !


!LassoPatchMorph class methodsFor: 'parts bin' stamp: 'sw 7/5/2004 01:46'!
descriptionForPartsBin
	"Answer a description of the receiver to be used in a parts bin"

	^ self partName:	'Lasso'
		categories:		#('Graphics')
		documentation:	'Drop this icon to grab a patch from the screen with a lasso.'! !
EncodedCharSet subclass: #Latin1
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Encodings'!
!Latin1 commentStamp: 'yo 10/19/2004 19:53' prior: 0!
This class represents the domestic character encoding called ISO-8859-1, also known as Latin-1 used for Most of the Western European Languages.!


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

Latin1 class
	instanceVariableNames: 'RightHalfSequence'!

!Latin1 class methodsFor: 'accessing - displaying' stamp: 'yo 8/18/2003 17:32'!
isBreakableAt: index in: text

	| char |
	char _ text at: index.
	char = Character space ifTrue: [^ true].
	char = Character cr ifTrue: [^ true].
	^ false.
! !

!Latin1 class methodsFor: 'accessing - displaying' stamp: 'yo 8/18/2003 17:32'!
printingDirection

	^ #right.
! !


!Latin1 class methodsFor: 'character classification' stamp: 'yo 8/28/2004 10:41'!
isLetter: char
	"Answer whether the receiver is a letter."

	^ Unicode isLetter: char.

! !


!Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:46'!
emitSequenceToResetStateIfNeededOn: aStream forState: state

	(state g0Leading ~= 0) ifTrue: [
		state charSize: 1.
		state g0Leading: 0.
		state g0Size: 1.
		aStream basicNextPutAll: CompoundTextSequence.
	].

	"Actually, G1 state should go back to ISO-8859-1, too."
! !

!Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:41'!
initialize
"
	self initialize
"


	CompoundTextSequence _ String streamContents: [:s |
		s nextPut: (Character value: 27).
		s nextPut: $(.
		s nextPut: $B.
	].

	RightHalfSequence _ String streamContents: [:s |
		s nextPut: (Character value: 27).
		s nextPut: $-.
		s nextPut: $A.
	].
! !

!Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:32'!
leadingChar

	^ 0.
! !

!Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:41'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	(ascii <= 16r7F and: [state g0Leading ~= 0]) ifTrue: [
		state charSize: 1.
		state g0Leading: 0.
		state g0Size: 1.
		aStream basicNextPutAll: CompoundTextSequence.
		aStream basicNextPut: (Character value: ascii).
		^ self.
	].

	((16r80 <= ascii and: [ascii <= 16rFF]) and: [state g1Leading ~= 0]) ifTrue: [
		^ self nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state.
	].

	aStream basicNextPut: (Character value: ascii).
	^ self.
! !


!Latin1 class methodsFor: 'private' stamp: 'yo 8/18/2003 17:41'!
nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	state charSize: 1.
	state g1Leading: 0.
	state g1Size: 1.
	aStream basicNextPutAll: RightHalfSequence.
	aStream basicNextPut: (Character value: ascii).
! !
LanguageEnvironment subclass: #Latin1Environment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Languages'!
!Latin1Environment commentStamp: '<historical>' prior: 0!
This class provides the support for the languages in 'Latin-1' category.  Although we could have different language environments for different languages in the category, so far nobody seriously needed it.
!


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

Latin1Environment class
	instanceVariableNames: ''!

!Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 10:00'!
nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	^ self traditionalCharsetClass nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state.
! !

!Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 10:00'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	^ self traditionalCharsetClass nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state.! !

!Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 09:59'!
traditionalCharsetClass

	^ Latin1.
! !


!Latin1Environment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 15:08'!
flapTabTextFor: aString

	^ aString.
! !

!Latin1Environment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 15:08'!
flapTabTextFor: aString in: aFlapTab

	^ aString.
! !

!Latin1Environment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 15:07'!
isBreakableAt: index in: text

	| char |
	char _ text at: index.
	char = Character space ifTrue: [^ true].
	char = Character cr ifTrue: [^ true].
	^ false.
! !


!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'bf 10/6/2004 19:13'!
clipboardInterpreterClass

	^ MacRomanClipboardInterpreter! !

!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'nk 7/30/2004 21:39'!
defaultEncodingName
	| platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current  getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy].
	(#('Win32' 'Mac OS' 'ZaurusOS') includes: platformName) 
		ifTrue: [^'iso8859-1' copy].
	(#('unix') includes: platformName) ifTrue: [^'iso8859-1' copy].
	^'mac-roman'! !

!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'!
fileNameConverterClass

	^ Latin1TextConverter
! !

!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'!
inputInterpreterClass

	^ MacRomanInputInterpreter.
! !

!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'!
leadingChar

	^ 0.
! !

!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 2/24/2005 20:41'!
supportedLanguages
	"Return the languages that this class supports. 
	Any translations for those languages will use this class as their environment."
	
	^#('fr' 'es' 'ca' 'eu' 'pt' 'it' 'sq' 'rm' 'nl' 'de' 'da' 'sv' 'no' 'fi' 'fo' 'is' 'ga' 'gd' 'en' 'af' 'sw')! !

!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'!
systemConverterClass

	^ Latin1TextConverter.
! !
TextConverter subclass: #Latin1TextConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!Latin1TextConverter commentStamp: '<historical>' prior: 0!
Text converter for ISO 8859-1.  An international encoding used in Western Europe.!


!Latin1TextConverter methodsFor: 'conversion' stamp: 'yo 12/28/2003 01:14'!
nextFromStream: aStream

	^ aStream basicNext.
! !

!Latin1TextConverter methodsFor: 'conversion' stamp: 'yo 7/12/2004 10:57'!
nextPut: aCharacter toStream: aStream 

	aStream basicNextPut: (Character value: aCharacter charCode).
! !


!Latin1TextConverter methodsFor: 'friend' stamp: 'yo 12/28/2003 01:14'!
currentCharSize

	^ 1.
! !

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

Latin1TextConverter class
	instanceVariableNames: ''!

!Latin1TextConverter class methodsFor: 'utilities' stamp: 'yo 12/28/2003 01:15'!
encodingNames 

	^ #('latin-1' 'latin1') copy.
! !
LanguageEnvironment subclass: #Latin2Environment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Languages'!
!Latin2Environment commentStamp: '<historical>' prior: 0!
This class provides the support for the languages in 'Latin-2' category.  Although we could have different language environments for different languages in the category, so far nobody seriously needed it.

  I (Yoshiki) don't have good knowledge in these language, so when Pavel Krivanek volunteered to implement the detail, it was a good test to see how flexible my m17n framework was.  There are a few glitches, but with several email conversations over a few days, we managed to make it work relatively painlessly.  I thought this went well.

  There seem that some source of headache, as Windows doesn't exactly use Latin-2 encoded characters, but a little modified version called 'code page 1250'.  Similar to Japanese support, the encode interpreters are swapped based on the type of platform it is running on.

!


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

Latin2Environment class
	instanceVariableNames: ''!


!Latin2Environment class methodsFor: 'rendering support' stamp: 'yo 1/18/2005 08:32'!
flapTabTextFor: aString

	^ aString.
! !

!Latin2Environment class methodsFor: 'rendering support' stamp: 'yo 1/18/2005 08:32'!
flapTabTextFor: aString in: aFlapTab

	^ aString.
! !

!Latin2Environment class methodsFor: 'rendering support' stamp: 'yo 1/18/2005 08:32'!
isBreakableAt: index in: text

	| char |
	char _ text at: index.
	char = Character space ifTrue: [^ true].
	char = Character cr ifTrue: [^ true].
	^ false.
! !


!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 16:00'!
clipboardInterpreterClass

	(#('Win32') includes: SmalltalkImage current platformName) 
		ifTrue: [^CP1250ClipboardInterpreter  ].

	^ ISO88592ClipboardInterpreter .
! !

!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 15:05'!
defaultEncodingName
	| platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current  getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy].
	(#('Win32') includes: platformName) 
		ifTrue: [^'cp-1250' copy].
	(#('unix') includes: platformName) ifTrue: [^'iso8859-2' copy].
	^'mac-roman'! !

!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 15:05'!
fileNameConverterClass

	(#('Win32') includes: SmalltalkImage current platformName) 
		ifTrue: [^CP1250TextConverter ].

	^ ISO88592TextConverter.

! !

!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 20:43'!
inputInterpreterClass

	(#('Win32') includes: SmalltalkImage current platformName) 
		ifTrue: [^CP1250InputInterpreter ].

	^ ISO88592InputInterpreter.

! !

!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 1/18/2005 15:53'!
leadingChar

	^ 14.
! !

!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 1/19/2005 09:16'!
supportedLanguages
	"Return the languages that this class supports. 
	Any translations for those languages will use this class as their environment."
	
	^#('cs' 'hu' 'ro' 'hr' 'sk' 'sl')  "Sorbian languages don't have two char code?"
! !

!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 15:04'!
systemConverterClass

	(#('Win32') includes: SmalltalkImage current platformName) 
		ifTrue: [^CP1250TextConverter ].

	^ ISO88592TextConverter.
! !
Object subclass: #LayoutCell
	instanceVariableNames: 'target cellSize extraSpace flags nextCell'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!LayoutCell commentStamp: '<historical>' prior: 0!
I am used in table layouts to hold temporary values while the layout is being computed.

Instance variables:
	target 		<Morph>		The morph contained in this cell
	cellSize 		<Point>		The size of the cell
	extraSpace 	<nil | Point>	Additional space to add after this cell
	nextCell 	<nil | LayoutCell>	The next cell in the arrangement.

Implementation note:
Both, cellSize and extraSpace contains points where
	x - represents the primary table direction
	y - represents the secondary table direction
!


!LayoutCell methodsFor: 'accessing' stamp: 'ar 11/2/2000 17:15'!
addExtraSpace: aPoint
	extraSpace 
		ifNil:[extraSpace _ aPoint]
		ifNotNil:[extraSpace _ extraSpace + aPoint]! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
cellSize
	^cellSize! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
cellSize: aPoint
	cellSize _ aPoint! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 11/10/2000 17:09'!
extraSpace
	^extraSpace ifNil:[0@0]! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 21:30'!
extraSpace: aPoint
	extraSpace _ aPoint! !

!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'!
flags
	^flags ifNil: [ 0 ]! !

!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'!
hSpaceFill
	^self flags anyMask: 1! !

!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'!
hSpaceFill: aBool
	flags _ aBool ifTrue:[self flags bitOr: 1] ifFalse:[self flags bitClear: 1].
! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
nextCell
	^nextCell! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
nextCell: aCell
	nextCell _ aCell! !

!LayoutCell methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:09'!
size
	| n cell |
	n := 0.
	cell := self.
	[cell isNil] whileFalse: 
			[n := n + 1.
			cell := cell nextCell].
	^n! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:11'!
target
	^target! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
target: newTarget
	target _ newTarget! !

!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'!
vSpaceFill
	^self flags anyMask: 2! !

!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'!
vSpaceFill: aBool
	flags _ aBool ifTrue:[self flags bitOr: 2] ifFalse:[self flags bitClear: 2].
! !


!LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 18:58'!
do: aBlock
	aBlock value: self.
	nextCell ifNotNil:[nextCell do: aBlock].! !

!LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 21:27'!
inject: thisValue into: binaryBlock 
	"Accumulate a running value associated with evaluating the argument, 
	binaryBlock, with the current value of the argument, thisValue, and the 
	receiver as block arguments. For instance, to sum the numeric elements 
	of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 
	next]."

	| nextValue |
	nextValue _ thisValue.
	self do: [:each | nextValue _ binaryBlock value: nextValue value: each].
	^nextValue! !
Object subclass: #LayoutFrame
	instanceVariableNames: 'leftFraction leftOffset topFraction topOffset rightFraction rightOffset bottomFraction bottomOffset'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!LayoutFrame commentStamp: '<historical>' prior: 0!
I define a frame for positioning some morph in a proportional layout.

Instance variables:
	leftFraction 
	topFraction 
	rightFraction 
	bottomFraction 	<Float>		The fractional distance (between 0 and 1) to place the morph in its owner's bounds
	leftOffset 
	topOffset 
	rightOffset 
	bottomOffset 	<Integer>	Fixed pixel offset to apply after fractional positioning (e.g., "10 pixel right of the center of the owner")!


!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomFraction
	^bottomFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomFraction: aNumber
	bottomFraction _ aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomFraction: aNumber offset: anInteger

	bottomFraction _ aNumber.
	bottomOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomOffset
	^bottomOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomOffset: anInteger
	bottomOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
leftFraction
	^leftFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
leftFraction: aNumber
	leftFraction _ aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
leftFraction: aNumber offset: anInteger

	leftFraction _ aNumber.
	leftOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
leftOffset
	^leftOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
leftOffset: anInteger
	leftOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightFraction
	^rightFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightFraction: aNumber
	rightFraction _ aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightFraction: aNumber offset: anInteger

	rightFraction _ aNumber.
	rightOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightOffset
	^rightOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightOffset: anInteger
	rightOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
topFraction
	^topFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
topFraction: aNumber
	topFraction _ aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'!
topFraction: aNumber offset: anInteger

	topFraction _ aNumber.
	topOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'!
topOffset
	^topOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'!
topOffset: anInteger
	topOffset _ anInteger! !


!LayoutFrame methodsFor: 'layout' stamp: 'JW 2/1/2001 13:04'!
layout: oldBounds in: newBounds
	"Return the proportional rectangle insetting the given bounds"
	| left right top bottom |
	leftFraction ifNotNil:[
		left _ newBounds left + (newBounds width * leftFraction).
		leftOffset ifNotNil:[left _ left + leftOffset]].
	rightFraction ifNotNil:[
		right _ newBounds right - (newBounds width * (1.0 - rightFraction)).
		rightOffset ifNotNil:[right _ right + rightOffset]].
	topFraction ifNotNil:[
		top _ newBounds top + (newBounds height * topFraction).
		topOffset ifNotNil:[top _ top + topOffset]].
	bottomFraction ifNotNil:[
		bottom _ newBounds bottom - (newBounds height * (1.0 - bottomFraction)).
		bottomOffset ifNotNil:[bottom _ bottom + bottomOffset]].
	left ifNil:[ right 
			ifNil:[left _ oldBounds left. right _ oldBounds right]
			ifNotNil:[left _ right - oldBounds width]].
	right ifNil:[right _ left + oldBounds width].
	top ifNil:[ bottom 
			ifNil:[top _ oldBounds top. bottom _ oldBounds bottom]
			ifNotNil:[top _ bottom - oldBounds height]].
	bottom ifNil:[bottom _ top + oldBounds height].
	^(left rounded @ top rounded) corner: (right rounded @ bottom rounded)! !

!LayoutFrame methodsFor: 'layout' stamp: 'ar 2/5/2002 20:05'!
minExtentFrom: minExtent
	"Return the minimal extent the given bounds can be represented in"
	| widthFraction heightFraction width height |
	widthFraction _ 1.0.
	leftFraction ifNotNil:[widthFraction _ widthFraction + leftFraction].
	rightFraction ifNotNil:[widthFraction _ widthFraction + rightFraction].
	heightFraction _ 1.0.
	topFraction ifNotNil:[heightFraction _ heightFraction + topFraction].
	bottomFraction ifNotNil:[heightFraction _ heightFraction + bottomFraction].
	width _ minExtent x * widthFraction.
	height _ minExtent y * heightFraction.
	leftOffset ifNotNil:[width _ width + leftOffset].
	rightOffset ifNotNil:[width _ width + rightOffset].
	topOffset ifNotNil:[height _ height + topOffset].
	bottomOffset ifNotNil:[height _ height + bottomOffset].
	^width truncated @ height truncated! !


!LayoutFrame methodsFor: 'objects from disk' stamp: 'JW 2/1/2001 13:33'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	| className oldClassVersion |

	"JW 2/1/2001"
	"Since class version isn't passed in varDict, look it up through smartRefSrm."
	className := varDict at: #ClassName.
	oldClassVersion := (smartRefStrm structures at: className) first.
	(oldClassVersion = 0) ifTrue: [ self negateBottomRightOffsets ].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !

!LayoutFrame methodsFor: 'objects from disk' stamp: 'JW 2/1/2001 14:37'!
negateBottomRightOffsets

	bottomOffset ifNotNil: [ bottomOffset := bottomOffset negated ].
	rightOffset ifNotNil: [ rightOffset := rightOffset negated ].

! !

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

LayoutFrame class
	instanceVariableNames: ''!

!LayoutFrame class methodsFor: 'accessing' stamp: 'JW 2/1/2001 12:48'!
classVersion
	^1 "changed treatment of bottomOffset and rightOffset"
! !


!LayoutFrame class methodsFor: 'instance creation' stamp: 'ar 2/5/2002 00:07'!
fractions: fractionsOrNil
	^self fractions: fractionsOrNil offsets: nil! !

!LayoutFrame class methodsFor: 'instance creation' stamp: 'RAA 1/8/2001 21:22'!
fractions: fractionsOrNil offsets: offsetsOrNil

	| fractions offsets |

	fractions _ fractionsOrNil ifNil: [0@0 extent: 0@0].
	offsets _ offsetsOrNil ifNil: [0@0 extent: 0@0].
	^self new
		topFraction: fractions top offset: offsets top;
		leftFraction: fractions left offset: offsets left;
		bottomFraction: fractions bottom offset: offsets bottom;
		rightFraction: fractions right offset: offsets right
! !

!LayoutFrame class methodsFor: 'instance creation' stamp: 'ar 2/5/2002 20:06'!
offsets: offsetsOrNil
	^self fractions: nil offsets: offsetsOrNil! !
Object subclass: #LayoutPolicy
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!LayoutPolicy commentStamp: '<historical>' prior: 0!
A LayoutPolicy defines how submorphs of some morph should be arranged. Subclasses of the receiver define concrete layout policies.!


!LayoutPolicy methodsFor: 'layout' stamp: 'ar 1/27/2001 14:39'!
flushLayoutCache
	"Flush any cached information associated with the receiver"! !

!LayoutPolicy methodsFor: 'layout' stamp: 'ar 10/28/2000 19:12'!
layout: aMorph in: newBounds
	"Compute the layout for the given morph based on the new bounds"
! !

!LayoutPolicy methodsFor: 'layout' stamp: 'ar 10/31/2000 19:59'!
minExtentOf: aMorph in: newBounds
	"Return the minimal size aMorph's children would require given the new bounds"
	^0@0! !


!LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'!
isProportionalLayout
	^false! !

!LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'!
isTableLayout
	^false! !


!LayoutPolicy methodsFor: 'utilities' stamp: 'ar 10/29/2000 17:31'!
indexForInserting: aMorph at: aPoint in: someMorph
	"Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion."
	^1 "front-most"! !
Object subclass: #LayoutProperties
	instanceVariableNames: 'hResizing vResizing disableLayout'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!LayoutProperties commentStamp: '<historical>' prior: 0!
This class provides a compact bit encoding for the most commonly used layout properties.!


!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
disableTableLayout
	^disableLayout! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
disableTableLayout: aBool
	disableLayout _ aBool! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
hResizing
	^hResizing! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
hResizing: aSymbol
	hResizing _ aSymbol! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
vResizing
	^vResizing! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:52'!
vResizing: aSymbol
	vResizing _ aSymbol! !


!LayoutProperties methodsFor: 'converting' stamp: 'ar 11/14/2000 17:52'!
asTableLayoutProperties
	^(TableLayoutProperties new)
		hResizing: self hResizing;
		vResizing: self vResizing;
		disableTableLayout: self disableTableLayout;
		yourself! !


!LayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:53'!
initialize
	hResizing _ vResizing _ #rigid.
	disableLayout _ false.! !

!LayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:56'!
initializeFrom: defaultProvider
	"Initialize the receiver from a default provider"
	self hResizing: defaultProvider hResizing.
	self vResizing: defaultProvider vResizing.
	self disableTableLayout: defaultProvider disableTableLayout.! !


!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:53'!
cellInset
	"Default"
	^0! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:50'!
cellPositioning
	^#center! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:55'!
cellSpacing
	"Default"
	^#none! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 16:38'!
layoutInset
	^0! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:58'!
listCentering
	"Default"
	^#topLeft! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'!
listDirection
	"Default"
	^#topToBottom! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'!
listSpacing
	"Default"
	^#none! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'!
maxCellSize
	^SmallInteger maxVal! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'!
minCellSize
	^0! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'!
reverseTableCells
	^false! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:01'!
rubberBandCells
	^false! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:02'!
wrapCentering
	^#topLeft! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:02'!
wrapDirection
	^#none! !


!LayoutProperties methodsFor: 'testing' stamp: 'ar 11/13/2000 18:34'!
includesTableProperties
	^false! !
Morph subclass: #LazyListMorph
	instanceVariableNames: 'listItems font selectedRow selectedRows listSource maxWidth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!LazyListMorph commentStamp: 'efc 8/6/2005 11:34' prior: 0!
The morph that displays the list in a PluggableListMorph.  It is "lazy" because it will only request the list items that it actually needs to display.

I will cache the maximum width of my items in maxWidth to avoid this potentially expensive and frequent computation.!


!LazyListMorph methodsFor: 'accessing' stamp: 'bf 4/21/2005 15:58'!
userString
	"Do I have a text string to be searched on?"

	^ String streamContents: [:strm |
		1 to: self getListSize do: [:i |
			strm nextPutAll: (self getListItem: i); cr]]! !


!LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/15/2001 22:13'!
adjustHeight
	"private.  Adjust our height to match the length of the underlying list"
	self height: (listItems size max: 1) * font height
! !

!LazyListMorph methodsFor: 'drawing' stamp: 'sps 3/9/2004 17:06'!
adjustWidth
	"private.  Adjust our height to match the length of the underlying list"
	self width: ((listSource width max: self hUnadjustedScrollRange) + 20). 
! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:57'!
bottomVisibleRowForCanvas: aCanvas
        "return the bottom visible row in aCanvas's clip rectangle"
        ^self rowAtLocation: aCanvas clipRect bottomLeft.
! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 10/11/2003 13:12'!
colorForRow: 	row
	^(selectedRow notNil and: [ row = selectedRow])
		ifTrue: [ Color red ]
		ifFalse: [ self color ].! !

!LazyListMorph methodsFor: 'drawing' stamp: 'nk 1/10/2004 16:17'!
display: item  atRow: row on: canvas
	"display the given item at row row"
	| drawBounds |
	drawBounds := self drawBoundsForRow: row.
	drawBounds := drawBounds intersect: self bounds.
	item isText
		ifTrue: [ canvas drawString: item in: drawBounds font: (font emphasized: (item emphasisAt: 1)) color: (self colorForRow: row) ]
		ifFalse: [ canvas drawString: item in: drawBounds font: font color: (self colorForRow: row) ].! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/10/2001 12:31'!
drawBackgroundForMulti: row on: aCanvas
	| selectionDrawBounds |
	"shade the background darker, if this row is selected"

	selectionDrawBounds := self drawBoundsForRow: row.
	selectionDrawBounds := selectionDrawBounds intersect: self bounds.
	aCanvas fillRectangle: selectionDrawBounds color:  self color muchLighter! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/22/2001 23:59'!
drawBackgroundForPotentialDrop: row on: aCanvas
	| selectionDrawBounds |
	"shade the background darker, if this row is a potential drop target"

	selectionDrawBounds := self drawBoundsForRow: row.
	selectionDrawBounds := selectionDrawBounds intersect: self bounds.
	aCanvas fillRectangle: selectionDrawBounds color:  self color muchLighter darker! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 12/6/2001 21:43'!
drawOn: aCanvas
	| |
	listItems size = 0 ifTrue: [ ^self ].
 
	self drawSelectionOn: aCanvas.

	(self topVisibleRowForCanvas: aCanvas) to: (self bottomVisibleRowForCanvas: aCanvas) do: [ :row |
		(listSource itemSelectedAmongMultiple:  row) ifTrue: [
			self drawBackgroundForMulti: row on: aCanvas. ].
		self display: (self item: row) atRow: row on: aCanvas.
	].

	listSource potentialDropRow > 0 ifTrue: [
		self highlightPotentialDropRow: listSource potentialDropRow on: aCanvas ].! !

!LazyListMorph methodsFor: 'drawing' stamp: 'nk 10/14/2003 15:18'!
drawSelectionOn: aCanvas
	| selectionDrawBounds |
	selectedRow ifNil: [ ^self ].
	selectedRow = 0 ifTrue: [ ^self ].
	selectionDrawBounds := self drawBoundsForRow: selectedRow.
	selectionDrawBounds := selectionDrawBounds intersect: self bounds.
	aCanvas fillRectangle: selectionDrawBounds color: (Color lightGray  alpha: 0.3)! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:37'!
font
	"return the font used for drawing.  The response is never nil"
	^font! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:04'!
font: newFont
	font := (newFont ifNil: [ TextStyle default defaultFont ]).
	self adjustHeight.
	self changed.! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/23/2001 00:13'!
highlightPotentialDropRow: row  on: aCanvas
	| drawBounds  |
	drawBounds := self drawBoundsForRow: row.
	drawBounds := drawBounds intersect: self bounds.
	aCanvas frameRectangle: drawBounds color: Color blue! !

!LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:57'!
topVisibleRowForCanvas: aCanvas
        "return the top visible row in aCanvas's clip rectangle"
        ^self rowAtLocation: aCanvas clipRect topLeft.
! !


!LazyListMorph methodsFor: 'initialization' stamp: 'nk 10/14/2003 15:24'!
initialize
	super initialize.
	self color: Color black.
	font := Preferences standardListFont.
	listItems := #().
	selectedRow := nil.
	selectedRows := PluggableSet integerSet.
	self adjustHeight.! !

!LazyListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:12'!
listSource: aListSource
	"set the source of list items -- typically a PluggableListMorph"
	listSource := aListSource.
	self listChanged! !


!LazyListMorph methodsFor: 'list access' stamp: 'ls 8/19/2001 14:07'!
getListItem: index
	"grab a list item directly from the model"
	^listSource getListItem: index! !

!LazyListMorph methodsFor: 'list access' stamp: 'ls 5/15/2001 22:11'!
getListSize
	"return the number of items in the list"
	listSource ifNil: [ ^0 ].
	^listSource getListSize! !

!LazyListMorph methodsFor: 'list access' stamp: 'efc 8/6/2005 11:23'!
item: index
	"return the index-th item, using the 'listItems' cache"
	| newItem itemWidth |
	(index between: 1 and: listItems size)
		ifFalse: [ "there should have been an update, but there wasn't!!"  ^self getListItem: index].
	(listItems at: index) ifNil: [ 
		newItem := self getListItem: index.
		"Update the width cache."
		maxWidth ifNotNil:[
			itemWidth := self widthToDisplayItem: newItem contents.
			itemWidth > maxWidth ifTrue:[
				maxWidth := itemWidth.
				self adjustWidth.
			]].
		listItems at: index put: newItem ].
	^listItems at: index! !


!LazyListMorph methodsFor: 'list management' stamp: 'ls 7/5/2000 18:21'!
drawBoundsForRow: row
	"calculate the bounds that row should be drawn at.  This might be outside our bounds!!"
	| topLeft drawBounds |
	topLeft := self topLeft x @ (self topLeft y + ((row - 1) * (font height))).
	drawBounds := topLeft extent: self width @ font height.
	^drawBounds! !

!LazyListMorph methodsFor: 'list management' stamp: 'sps 3/9/2004 17:06'!
listChanged
	"set newList to be the list of strings to display"
	listItems := Array new: self getListSize withAll: nil.
	selectedRow := nil.
	selectedRows := PluggableSet integerSet.
	self adjustHeight.
	self adjustWidth.
	self changed.
! !

!LazyListMorph methodsFor: 'list management' stamp: 'ls 10/20/2001 00:09'!
rowAtLocation: aPoint
	"return the number of the row at aPoint"
	| y |
	y := aPoint y.
	y < self top ifTrue: [ ^ 1 ].
	^((y - self top // (font height)) + 1) min: listItems size max: 0! !

!LazyListMorph methodsFor: 'list management' stamp: 'ls 7/13/2000 17:34'!
selectRow: index
	"select the index-th row"
	selectedRows add: index.
	self changed.! !

!LazyListMorph methodsFor: 'list management' stamp: 'ls 7/7/2000 10:38'!
selectedRow
	"return the currently selected row, or nil if none is selected"
	^selectedRow! !

!LazyListMorph methodsFor: 'list management' stamp: 'ls 7/5/2000 17:56'!
selectedRow: index
	"select the index-th row.  if nil, remove the current selection"
	selectedRow := index.
	self changed.! !

!LazyListMorph methodsFor: 'list management' stamp: 'ls 7/13/2000 17:35'!
unselectRow: index
	"unselect the index-th row"
	selectedRows remove: index ifAbsent: [].
	self changed.! !


!LazyListMorph methodsFor: 'scroll range' stamp: 'efc 8/6/2005 11:32'!
hUnadjustedScrollRange
"Ok, this is a bit messed up. We need to return the width of the widest item in the list. If we grab every item in the list, it defeats the purpose of LazyListMorph. If we don't, then we don't know the size. 

This is a compromise -- find the widest of the first 30 items, then double it, This width will be updated as new items are installed, so it will always be correct for the visible items. If you know a better way, please chime in."

	| itemsToCheck item index |
	"Check for a cached value"
	maxWidth ifNotNil:[^maxWidth].

	"Compute from scratch"
	itemsToCheck := 30 min: (listItems size).
	maxWidth := 0. 

	"Check the first few items to get a representative sample of the rest of the list."
	index := 1.
	[index < itemsToCheck] whileTrue:
		[ item := self getListItem: index. "Be careful not to actually install this item"
		maxWidth := maxWidth max: (self widthToDisplayItem: item contents).
		index:= index + 1.
		].

	"Add some initial fudge if we didn't check all the items."
	(itemsToCheck < listItems size) ifTrue:[maxWidth := maxWidth*2].

	^maxWidth
! !

!LazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:17'!
widthToDisplayItem: item
	^self font widthOfStringOrText: item
	! !


!LazyListMorph methodsFor: '*omnibrowser' stamp: 'cwp 2/28/2006 18:47'!
rectForRow: index
	"return a rectangle containing the row at index"
	
	| top |
	top _ self top + (index - 1 * font height).
	^ (self left @ top) extent: self width @ font height
! !
ParseNode subclass: #LeafNode
	instanceVariableNames: 'key code'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!LeafNode commentStamp: '<historical>' prior: 0!
I represent a leaf node of the compiler parse tree. I am abstract.
	
Types (defined in class ParseNode):
	1 LdInstType (which uses class VariableNode)
	2 LdTempType (which uses class VariableNode)
	3 LdLitType (which uses class LiteralNode)
	4 LdLitIndType (which uses class VariableNode)
	5 SendType (which uses class SelectorNode).

Note that Squeak departs slightly from the Blue Book bytecode spec.

In order to allow access to more than 63 literals and instance variables,
bytecode 132 has been redefined as DoubleExtendedDoAnything:
		byte2				byte3			Operation
(hi 3 bits)  (lo 5 bits)
	0		nargs			lit index			Send Literal Message 0-255
	1		nargs			lit index			Super-Send Lit Msg 0-255
	2		ignored			rcvr index		Push Receiver Variable 0-255
	3		ignored			lit index			Push Literal Constant 0-255
	4		ignored			lit index			Push Literal Variable 0-255
	5		ignored			rcvr index		Store Receiver Variable 0-255
	6		ignored			rcvr index		Store-pop Receiver Variable 0-255
	7		ignored			lit index			Store Literal Variable 0-255

	This has allowed bytecode 134 also to be redefined as a second extended send
	that can access literals up to 64 for nargs up to 3 without needing three bytes.
	It is just like 131, except that the extension byte is aallllll instead of aaalllll,
	where aaa are bits of argument count, and lll are bits of literal index.!


!LeafNode methodsFor: 'accessing'!
key

	^key! !


!LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:39'!
code

	^ code! !

!LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:41'!
code: aValue

	code := aValue! !

!LeafNode methodsFor: 'code generation'!
emitForEffect: stack on: strm

	^self! !

!LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:42'!
emitLong: mode on: aStream 
	"Emit extended variable access."
	| type index |
	self code < 256
		ifTrue:
			[self code < 16
			ifTrue: [type _ 0.
					index _ self code]
			ifFalse: [self code < 32
					ifTrue: [type _ 1.
							index _ self code - 16]
					ifFalse: [self code < 96
							ifTrue: [type _ self code // 32 + 1.
									index _ self code \\ 32]
							ifFalse: [self error: 
									'Sends should be handled in SelectorNode']]]]
		ifFalse: 
			[index _ self code \\ 256.
			type _ self code // 256 - 1].
	index <= 63 ifTrue:
		[aStream nextPut: mode.
		^ aStream nextPut: type * 64 + index].
	"Compile for Double-exetended Do-anything instruction..."
	mode = LoadLong ifTrue:
		[aStream nextPut: DblExtDoAll.
		aStream nextPut: (#(64 0 96 128) at: type+1).  "Cant be temp (type=1)"
		^ aStream nextPut: index].
	mode = Store ifTrue:
		[aStream nextPut: DblExtDoAll.
		aStream nextPut: (#(160 0 0 224) at: type+1).  "Cant be temp or const (type=1 or 2)"
		^ aStream nextPut: index].
	mode = StorePop ifTrue:
		[aStream nextPut: DblExtDoAll.
		aStream nextPut: (#(192 0 0 0) at: type+1).  "Can only be inst"
		^ aStream nextPut: index].
! !

!LeafNode methodsFor: 'code generation' stamp: 'ab 7/13/2004 13:52'!
reserve: encoder 
	"If this is a yet unused literal of type -code, reserve it."

	self code < 0 ifTrue: [self code: (self code: (encoder litIndex: self key) type: 0 - self code)]! !

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

	^0! !

!LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:40'!
sizeForValue: encoder
	self reserve: encoder.
	self code < 256 ifTrue: [^ 1].
	(self code \\ 256) <= 63 ifTrue: [^ 2].
	^ 3! !


!LeafNode methodsFor: 'copying' stamp: 'ab 7/13/2004 13:53'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
self key: (deepCopier references at: self key ifAbsent: [self key]).
! !

!LeafNode methodsFor: 'copying' stamp: 'ab 7/6/2004 17:42'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"key _ key.		Weakly copied"
self code: (self code veryDeepCopyWith: deepCopier).
! !


!LeafNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:51'!
key: object

	key _ object.
! !

!LeafNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:51'!
key: object code: byte

	self key: object.
	self code: byte! !

!LeafNode methodsFor: 'initialize-release'!
key: object index: i type: type

	self key: object code: (self code: i type: type)! !

!LeafNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:52'!
name: ignored key: object code: byte

	self key: object.
	self code: byte! !

!LeafNode methodsFor: 'initialize-release'!
name: literal key: object index: i type: type

	self key: object
		index: i
		type: type! !


!LeafNode methodsFor: 'private'!
code: index type: type

	index isNil 
		ifTrue: [^type negated].
	(CodeLimits at: type) > index 
		ifTrue: [^(CodeBases at: type) + index].
	^type * 256 + index! !
Morph subclass: #LedCharacterMorph
	instanceVariableNames: 'char highlighted'
	classVariableNames: 'BSegments CHSegmentOrigins CHSegments CVSegmentOrigins CVSegments DSegments TSegments'
	poolDictionaries: ''
	category: 'MorphicExtras-Leds'!
!LedCharacterMorph commentStamp: '<historical>' prior: 0!
char 36 is SPACE!


!LedCharacterMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 20:02'!
char

	 ^ char ! !

!LedCharacterMorph methodsFor: 'accessing' stamp: 'kfr 6/12/2000 15:13'!
char: aCharacter 
	char _ aCharacter digitValue.
	char >= 0 & (char <= 35) ifFalse: [char _ 36]! !

!LedCharacterMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 19:03'!
highlighted

	^ highlighted! !

!LedCharacterMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 19:03'!
highlighted: aBoolean

	highlighted _ aBoolean.
	self changed.! !


!LedCharacterMorph methodsFor: 'drawing' stamp: 'kfr 6/3/2000 21:29'!
drawOn: aCanvas 
	| foregroundColor backgroundColor thickness hThickness vThickness hOffset vOffset bOrigin i |
	i _ 0.
	foregroundColor _ highlighted
				ifTrue: [Color white]
				ifFalse: [color].
	backgroundColor _ color darker darker darker.
	hThickness _ self height * 0.1.
	vThickness _ self width * 0.1.
	thickness _ hThickness min: vThickness.
	vOffset _ hThickness - thickness // 2 max: 0.
	hOffset _ vThickness - thickness // 2 max: 0.
	aCanvas fillRectangle: self bounds color: backgroundColor.
	CHSegmentOrigins with: (CHSegments at: char + 1)
		do: [:o :isLit | aCanvas fillRectangle: (Rectangle origin: (self position + (0 @ vOffset) + (o * self extent)) rounded extent: (self width * 0.6 @ thickness) rounded)
				color: (isLit
						ifTrue: [foregroundColor]
						ifFalse: [backgroundColor])].
	CVSegmentOrigins with: (CVSegments at: char + 1)
		do: [:o :isLit | aCanvas fillRectangle: (Rectangle origin: (self position + (hOffset @ 0) + (o * self extent)) rounded extent: (thickness @ (self height * 0.25)) rounded)
				color: (isLit
						ifTrue: [foregroundColor]
						ifFalse: [backgroundColor])].
	TSegments with: (DSegments at: char + 1)
		do: 
			[:tOrigin :isLit | 
			i _ i + 1.
			bOrigin _ BSegments at: i.
			aCanvas
				line: self position x - hOffset + (self width * tOrigin x) @ (self position y - vOffset + (self height * tOrigin y))
				to: self position x + hOffset + (self width * bOrigin x) @ (self position y + vOffset + (self height * bOrigin y))
				width: thickness + 1 // 1.25
				color: (isLit
						ifTrue: [foregroundColor]
						ifFalse: [Color transparent])]! !

!LedCharacterMorph methodsFor: 'drawing' stamp: 'kfr 5/26/2000 19:03'!
drawOnFills: aRectangle

	^ true! !


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

!LedCharacterMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:55'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	highlighted _ false.
	char _ 0! !

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

LedCharacterMorph class
	instanceVariableNames: ''!

!LedCharacterMorph class methodsFor: 'class initialization' stamp: 'kfr 6/3/2000 21:32'!
initialize

	CHSegmentOrigins _ {0.2@0.1. 0.2@0.45. 0.2@0.8}.
	CVSegmentOrigins _ {0.1@0.2. 0.1@0.55. 0.8@0.2. 0.8@0.55}.
	TSegments _ { 0.25@0.25. 0.45@0.25. 0.55@0.25. 0.75@0.25. 0.25@0.6. 0.45@0.6. 0.55@0.6. 0.75@0.6. }.
	BSegments _ { 0.45@0.4. 0.25@0.4. 0.75@0.4. 0.55@0.4. 0.45@0.76. 0.25@0.76. 0.75@0.76. 0.55@0.76. }.

	DSegments  _ {
	{false. false. false. false. false. false. false. false. }."0"
	{false. false. false. false. false. false. false. false. }."1"
	{false. false. false. false. false. false. false. false. }."2"
	{false. false. false. false. false. false. false. false. }."3"
	{false. false. false. false. false. false. false. false. }."4"
	{false. false. false. false. false. false. false. false. }."5"
	{false. false. false. false. false. false. false. false. }."6"
	{false. false. false. false. false. false. false. false. }."7"
	{false. false. false. false. false. false. false. false. }."8"
	{false. false. false. false. false. false. false. false. }."9"
	{false. false. false. false. false. false. false. false. }."A"
	{false. false. false. false. false. false. false. false. }."B"
	{false. false. false. false. false. false. false. false. }."C"
	{false. false. false. false. false. false. false. false. }."D"
	{false. false. false. false. false. false. false. false. }."E"
	{false. false. false. false. false. false. false. false. }."F"
	{false. false. false. false. false. false. false. false. }."G"
	{false. false. false. false. false. false. false. false. }."H"
	{false. false. false. false. false. false. false. false. }."I"
	{false. false. false. false. false. false. false. false. }."J"
	{false. false. false. true. false. false. false. false. }."K"
	{false. false. false. false. false. false. false. false. }."L"
	{true. false. false. true. false. false. false. false. }."M"
	{true. false. false. false. false. false. true. false. }."N"
	{false. true. true. false. true. false. false. true.  }."O"
	{false. false. false. false. false. false. false. false. }."P"
	{false. false. false. false. false. false. true. false. }."Q"
	{false. false. false. false. false. false. true. false. }."R"
	{false. false. false. false. false. false. false. false. }."S"
	{false. false. false. false. false. false. false. false. }."T"
	{false. false. false. false. false. false. false. false. }."U"
	{false. false. false. false. true. false. false. true. }."V"
	{false. false. false. false. false. true. true. false. }."W"
	{true. false. false. true. false. true. true. false. }."X"
	{false. false. false. false. false. false. false. false. }."Y"
	{false. false. false. true. false. true. false. false. }."Z"
	{false. false. false. false. false. false. false. false. }}."SPACE"

	CHSegments _ {
		{true. false. true}."0"
		{false. false. false}."1"
		{true. true. true}."2"
		{true. true. true}."3"
		{false. true. false}."4"
		{true. true. true}."5"
		{true. true. true}."6"
		{true. false. false}."7"
		{true. true. true}."8"
		{true. true. true}."9"
		{true. true. false}."A"
		{true. true. true}."B"
		{true. false. true}."C"
		{true. false. true}."D"
		{true. true. true}."E"
		{true. true. false}."F"
		{true. true. true}."G"
		{false. true. false}."H"
		{false. false. false}."I"
		{false. false. true}."J"
		{false. true. false}."K"
		{false. false. true}."L"
		{false. false. false}."M"
		{false. false. false}."N"
		{false. false. false}."O"
		{true. true. false}."P"
		{true. false. true}."Q"
		{true. true. false}."R"
		{true. true. true}."S"
		{false. true. true}."t"
		{false. false. true}."U"
		{false. false. false}."V"
		{false. false. false}."W"
		{false. false. false}."X"
		{false. true. true}."Y"
		{true. false. true}."Z"
		{false. false. false.}}."SPACE"
	CVSegments _ {
		{true. true.  true. true}."0"
		{false. false. true. true}."1"
		{false. true. true. false}."2"
		{false. false. true. true}."3"
		{true. false. true. true}."4"
		{true. false. false. true}."5"
		{true. true. false. true}."6"
		{false. false. true. true}."7"
		{true. true. true. true}."8"
		{true. false. true. true}."9"
		{true. true. true. true}."A"
		{true. true. true. true}."B"
		{true. true. false. false}."C"
		{true. true. true. true}."D"
		{true. true. false. false}."E"
		{true. true. false. false}."F"
		{true. true. false. true}."G"
		{true. true. true. true}."H"
		{true. true. false. false}."I"
		{false. true. true. true}."J"
		{true. true. false. true}."K"
		{true. true. false. false}."L"
		{true. true.  true. true}."N"
		{true. true. true. true}."N"
		{false. false. false. false}."O"
		{true. true. true. false}."P"
		{true. true.  true. true}."q"
		{true. true. true. false}."R"
		{true. false. false. true}."S"
		{true. true. false. false}."t"
		{true. true. true. true}."U"
		{true. false. true. false}."V"
		{true. true.  true. true}."w"
		{false. false. false. false}."x"
		{true. false. true. true}."y"
		{false. false. false. false}."z"
		{false. false. false. false}}."SPACE"! !


!LedCharacterMorph class methodsFor: 'new-morph participation' stamp: 'kfr 5/26/2000 19:03'!
includeInNewMorphMenu

	^false! !
Morph subclass: #LedDigitMorph
	instanceVariableNames: 'digit highlighted'
	classVariableNames: 'HSegmentOrigins HSegments VSegmentOrigins VSegments'
	poolDictionaries: ''
	category: 'MorphicExtras-Leds'!
!LedDigitMorph commentStamp: '<historical>' prior: 0!
I am a 7-segment LED that can display a decimal digit!


!LedDigitMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:00'!
digit

	^ digit! !

!LedDigitMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:00'!
digit: anInteger

	digit _ anInteger \\ 10	"make sure it stays between 0 and 9"! !

!LedDigitMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 17:00'!
highlighted

	^ highlighted! !

!LedDigitMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 18:43'!
highlighted: aBoolean

	highlighted _ aBoolean.
	self changed.! !


!LedDigitMorph methodsFor: 'drawing' stamp: 'dew 1/16/2002 20:44'!
drawOn: aCanvas

	| foregroundColor backgroundColor thickness hThickness vThickness hOffset vOffset |
	foregroundColor _ highlighted ifTrue: [Color white] ifFalse: [color].
	backgroundColor _ color muchDarker.
	hThickness _ self height * 0.1.
	vThickness _ self width * 0.1.
	thickness _ hThickness min: vThickness.
	vOffset _ ((hThickness - thickness) // 2) max: 0.
	hOffset _ ((vThickness - thickness) // 2) max: 0.
	aCanvas fillRectangle: self bounds color: backgroundColor.
	"added to show the minus sign"
	(digit asString = '-') ifTrue: [digit _ 10].
	HSegmentOrigins with: (HSegments at: digit+1) do:
		[:o :isLit |
		aCanvas
			fillRectangle: (Rectangle
				origin: (self position + (0@vOffset) + (o * self extent)) rounded
				extent: ((self width * 0.6) @ thickness) rounded)
			color: (isLit ifTrue: [foregroundColor] ifFalse: [backgroundColor])].
	VSegmentOrigins with: (VSegments at: digit+1) do:
		[:o :isLit |
		aCanvas
			fillRectangle: (Rectangle
				origin: (self position + (hOffset@0) + (o * self extent)) rounded
				extent: (thickness @ (self height * 0.25)) rounded)
			color: (isLit ifTrue: [foregroundColor] ifFalse: [backgroundColor])].
! !

!LedDigitMorph methodsFor: 'drawing' stamp: 'tao 5/18/1998 13:58'!
drawOnFills: aRectangle

	^ true! !


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

!LedDigitMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:34'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	highlighted _ false.
	digit _ 0 ! !

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

LedDigitMorph class
	instanceVariableNames: ''!

!LedDigitMorph class methodsFor: 'class initialization' stamp: 'rjf 5/25/2000 00:16'!
initialize

	HSegmentOrigins _ {0.2@0.1. 0.2@0.45. 0.2@0.8}.
	VSegmentOrigins _ {0.1@0.2. 0.1@0.55. 0.8@0.2. 0.8@0.55}.
	HSegments _ {
		{true. false. true}.
		{false. false. false}.
		{true. true. true}.
		{true. true. true}.
		{false. true. false}.
		{true. true. true}.
		{true. true. true}.
		{true. false. false}.
		{true. true. true}.
		{true. true. true}.
		{false. true. false}}.
	VSegments _ {
		{true. true. true. true}.
		{false. false. true. true}.
		{false. true. true. false}.
		{false. false. true. true}.
		{true. false. true. true}.
		{true. false. false. true}.
		{true. true. false. true}.
		{false. false. true. true}.
		{true. true. true. true}.
		{true. false. true. true}.
		{false. false. false. false}}.! !


!LedDigitMorph class methodsFor: 'new-morph participation' stamp: 'di 1/16/2000 10:39'!
includeInNewMorphMenu

	^false! !
Morph subclass: #LedMorph
	instanceVariableNames: 'digits chars value flashing flash string scroller scrollLoop'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Leds'!
!LedMorph commentStamp: '<historical>' prior: 0!
I am a collection of LED digits that can display a decimal value.  The display can be set to flash by sending flash: true.

LedMorph can now display characters:

LedMorph new  string:'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'; openInWorld

Lowercase letters will be converted to Uppercase. Carachters not in the examle
above will be shown as SPACE which is char 36 in LedCharacterMorph.

LedMorph new  chars: 10; string:'           I must get a life';flash:true;scrollLoop:true; openInWorld

The number of letters is set by chars. 
If chars is not specified it will be set to the string size. 
When the string size is bigger than chars
the string will scroll across the led. WOW!!
scrollLoop let's you set the scrolling to start over once its finished.

Enjoy.

!


!LedMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 20:16'!
chars

	 ^ chars! !

!LedMorph methodsFor: 'accessing' stamp: 'kfr 6/3/2000 21:27'!
chars: aNumber 
	chars _ aNumber.
	self removeAllMorphs.
	1 to: chars do: [:i | self addMorph: (LedCharacterMorph new color: color)].
	self layoutChanged.
	self changed! !

!LedMorph methodsFor: 'accessing' stamp: 'dgd 2/14/2003 22:46'!
color: aColor 
	"set the receiver's color and the submorphs color"
	super color: aColor.
	self
		submorphsDo: [:m | m color: aColor]! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:42'!
digits

	^ digits! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:46'!
digits: aNumber

	digits _ aNumber.
	self removeAllMorphs.
	1 to: digits do: [:i | self addMorph: (LedDigitMorph new color: color)].
	self layoutChanged.
	self changed.! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 18:26'!
flash: aBoolean

	flash _ aBoolean.! !

!LedMorph methodsFor: 'accessing' stamp: 'djp 11/29/1999 17:27'!
highlighted: aBoolean

	self submorphsDo: [:m | m highlighted: aBoolean]! !

!LedMorph methodsFor: 'accessing' stamp: 'kfr 6/1/2000 18:50'!
scrollLoop	

	^ scrollLoop! !

!LedMorph methodsFor: 'accessing' stamp: 'kfr 6/1/2000 18:50'!
scrollLoop: aBoolean

	scrollLoop _ aBoolean.! !

!LedMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 20:25'!
string

	^ string! !

!LedMorph methodsFor: 'accessing' stamp: 'kfr 6/12/2000 15:29'!
string: aString 
	string _ aString.
	chars = 0
		ifTrue: 
			[chars _ string size.
			self chars: chars].
	self stringToLed! !

!LedMorph methodsFor: 'accessing' stamp: 'tk 4/19/2001 16:55'!
stringToLed
	| i k actualString |
	i _ scroller ifNil: [1].
	k _ 1.
	actualString _ String new: chars.
	actualString do: 
		[:m | 
		i > string size ifFalse: [actualString at: k put: (string at: i) asUppercase asCharacter].
		i _ i + 1.
		k _ k + 1].
	i _ 1.
	submorphs do: 
		[:m | 
		m char: (actualString at: i).
		i _ i + 1].
	self changed! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:42'!
value

	^ value! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:47'!
value: aNumber

	| val |
	value _ aNumber.
	val _ value.
	submorphs reverseDo:
		[:m |
		m digit: val \\ 10.
		val _ val // 10].
	self changed.! !


!LedMorph methodsFor: 'drawing' stamp: 'tao 5/18/1998 14:00'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds color: color darker darker.
! !


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

!LedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:36'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	flashing _ false.
	flash _ false.
	self scrollInit.
	self digits: 2.
	self value: 0! !

!LedMorph methodsFor: 'initialization' stamp: 'di 3/8/2001 23:44'!
scrollInit

	chars _ 0.
	scroller _ 1.
	string _ ''.
	scrollLoop _ false.
! !


!LedMorph methodsFor: 'layout' stamp: 'tao 5/18/1998 13:53'!
layoutChanged

	super layoutChanged.
	submorphs withIndexDo:
		[:m :i |
		m
			position: self position + (((i-1) * self width / digits) rounded @ 0);
			extent: (self width / digits) rounded @ self height]! !


!LedMorph methodsFor: 'macpal' stamp: 'tao 5/18/1998 18:26'!
flash

	^ flash! !


!LedMorph methodsFor: 'stepping and presenter' stamp: 'tk 4/19/2001 17:02'!
step
	(flash or: [flashing])
		ifTrue: 
			[flashing _ flashing not.
			self highlighted: flashing].
	scroller ifNil: [scroller _ 1].
	chars ifNil: [^ self].
	scroller + chars < (string size + 1)
		ifTrue: 
			[scroller _ scroller + 1.
			self stringToLed]
		ifFalse: [scrollLoop ifTrue: [scroller _ 1]]! !


!LedMorph methodsFor: 'testing' stamp: 'tao 5/18/1998 18:44'!
stepTime

	^ 500! !

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

LedMorph class
	instanceVariableNames: ''!

!LedMorph class methodsFor: 'new-morph participation' stamp: 'di 1/16/2000 10:39'!
includeInNewMorphMenu

	^false! !
LedMorph subclass: #LedTimerMorph
	instanceVariableNames: 'counting startSeconds'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Leds'!

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/31/1999 19:36'!
continue

	counting _ true! !

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/31/1999 21:58'!
pause

	counting ifTrue: [self updateTime].
	counting _ false! !

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/23/1999 21:46'!
reset

	startSeconds _ Time totalSeconds.
	self value: 0.! !

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/31/1999 19:02'!
resume

	counting ifFalse: [
		counting _ true.
		startSeconds _  (Time totalSeconds) - self value]! !


!LedTimerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:36'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	counting _ false.
	startSeconds _ Time totalSeconds! !


!LedTimerMorph methodsFor: 'stepping' stamp: 'djp 10/24/1999 01:12'!
updateTime

	self value:  Time totalSeconds - startSeconds.
	self changed! !


!LedTimerMorph methodsFor: 'stepping and presenter' stamp: 'djp 10/23/1999 21:35'!
start

	counting _ true! !

!LedTimerMorph methodsFor: 'stepping and presenter' stamp: 'djp 10/24/1999 01:12'!
step

	flash
		ifTrue: [super step]
		ifFalse: [
			counting ifTrue: [self updateTime]]! !

!LedTimerMorph methodsFor: 'stepping and presenter' stamp: 'djp 10/31/1999 21:44'!
stop

	counting ifTrue: [self updateTime].
	counting _ false.! !


!LedTimerMorph methodsFor: 'testing' stamp: 'djp 10/23/1999 21:27'!
stepTime

	^ 1000! !

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

LedTimerMorph class
	instanceVariableNames: ''!

!LedTimerMorph class methodsFor: 'new-morph participation' stamp: 'di 1/16/2000 10:39'!
includeInNewMorphMenu

	^false! !
ProtocolBrowser subclass: #Lexicon
	instanceVariableNames: 'currentVocabulary categoryList categoryListIndex targetClass limitClass currentQuery currentQueryParameter selectorsVisited'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Protocols'!
!Lexicon commentStamp: '<historical>' prior: 0!
An instance of Lexicon shows the a list of all the method categories known to an object or any of its superclasses, as a "flattened" list, and, within any selected category, shows all methods understood by the class's instances which are associated with that category, again as a "flattened" list.  A variant with a search pane rather than a category list is also implemented.

categoryList				the list of categories
categoryListIndex		index of currently-selected category
targetObject				optional -- an instance being viewed
targetClass				the class being viewed
lastSearchString			the last string searched for
lastSendersSearchSelector	the last senders search selector
limitClass				optional -- the limit class to search for
selectorsVisited			list of selectors visited
selectorsActive			not presently in use, subsumed by selectorsVisited
currentVocabulary		the vocabulary currently installed
currentQuery			what the query category relates to:
							#senders #selectorName #currentChangeSet!


!Lexicon methodsFor: 'basic operation' stamp: 'sd 11/20/2005 21:27'!
annotation
	"Provide a line of annotation material for a middle pane."

	| aCategoryName |
	self selectedMessageName ifNotNil: [^ super annotation].
	(aCategoryName := self selectedCategoryName) ifNil:
		[^ self hasSearchPane
			ifTrue:
				['type a message name or fragment in the top pane and hit RETURN or ENTER']
			ifFalse:
				[''  "currentVocabulary documentation"]].


	(aCategoryName = self class queryCategoryName) ifTrue:
		[^ self queryCharacterization].
		
	#(
	(allCategoryName			'Shows all methods, whatever other category they belong to')
	(viewedCategoryName		'Methods visited recently.  Use  "-" button to remove a method from this category.')
	(queryCategoryName		'Query results'))

		do:
			[:pair | (self categoryWithNameSpecifiedBy: pair first) = aCategoryName ifTrue: [^ pair second]].

	^ currentVocabulary categoryCommentFor: aCategoryName! !

!Lexicon methodsFor: 'basic operation' stamp: 'sd 11/20/2005 21:27'!
displaySelector: aSelector
	"Set aSelector to be the one whose source shows in the browser.  If there is a category list, make it highlight a suitable category"

	| detectedItem messageIndex |
	self chooseCategory: (self categoryDefiningSelector: aSelector).
	detectedItem := messageList detect:
		[:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ Beeper beep].
	messageIndex := messageList indexOf: detectedItem.
	self messageListIndex: messageIndex! !

!Lexicon methodsFor: 'basic operation' stamp: 'sd 11/20/2005 21:27'!
messageListIndex: anIndex
	"Set the message list index as indicated, and update the history list if appropriate"

	| newSelector current |
	current := self selectedMessageName.
	super messageListIndex: anIndex.
	anIndex = 0 ifTrue: [
		self editSelection: #newMessage.
		self contentsChanged].
	(newSelector := self selectedMessageName) ifNotNil: 
		[self updateSelectorsVisitedfrom: current to: newSelector]! !


!Lexicon methodsFor: 'category list' stamp: 'sw 3/7/2001 12:19'!
categoriesPane
	"If there is a pane defined by #categoryList in my containing window, answer it, else answer nil"

	^ self listPaneWithSelector: #categoryList! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
categoryDefiningSelector: aSelector
	"Answer a category in which aSelector occurs"

	| categoryNames |
	categoryNames := categoryList copyWithoutAll: #('-- all --').
	^ currentVocabulary categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: self targetObject ofClass: targetClass! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
categoryList
	"Answer the category list for the protcol, creating it if necessary, and prepending the -- all -- category, and appending the other special categories for search results, etc."

	| specialCategoryNames |
	categoryList ifNil:
		[specialCategoryNames := #(queryCategoryName  viewedCategoryName "searchCategoryName sendersCategoryName  changedCategoryName activeCategoryName")  collect:
			[:sym | self class perform: sym].
		categoryList :=
			(currentVocabulary categoryListForInstance: self targetObject ofClass: targetClass limitClass: limitClass),
			specialCategoryNames,
			(Array with: self class allCategoryName)].
	^ categoryList! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
categoryListIndex
	"Answer the index of the currently-selected item in in the category list"

	^ categoryListIndex ifNil: [categoryListIndex := 1]! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
categoryListIndex: anIndex
	"Set the category list index as indicated"

	| categoryName aList found existingSelector |
	existingSelector := self selectedMessageName.

	categoryListIndex := anIndex.
	anIndex > 0
		ifTrue:
			[categoryName := categoryList at: anIndex]
		ifFalse:
			[contents := nil].
	self changed: #categoryListIndex.

	found := false.
	#(	(viewedCategoryName		selectorsVisited)
		(queryCategoryName		selectorsRetrieved)) do:
			[:pair |
				categoryName = (self class perform: pair first)
					ifTrue:
						[aList := self perform: pair second.
						found := true]].
	found ifFalse:
		[aList := currentVocabulary allMethodsInCategory: categoryName forInstance: self targetObject ofClass: targetClass].
	categoryName = self class queryCategoryName ifFalse: [autoSelectString := nil].

	self initListFrom: aList highlighting: targetClass.

	messageListIndex := 0.
	self changed: #messageList.
	contents := nil.
	self contentsChanged.
	self selectWithinCurrentCategoryIfPossible: existingSelector.
	self adjustWindowTitle! !

!Lexicon methodsFor: 'category list' stamp: 'sw 12/12/2000 11:50'!
categoryListKey: aChar from: aView
	"The user hit a command-key while in the category-list.  Do something"

	(aChar == $f and: [self hasSearchPane not]) ifTrue:
		[^ self obtainNewSearchString].! !

!Lexicon methodsFor: 'category list' stamp: 'sw 12/12/2000 11:50'!
categoryListMenu: aMenu shifted: aBoolean
	"Answer the menu for the category list"

	^ aMenu labels: 'find...(f)' lines: #() selections: #(obtainNewSearchString)! !

!Lexicon methodsFor: 'category list' stamp: 'sw 12/1/2000 22:13'!
categoryListMenuTitle
	"Answer the menu title for the category list menu"

	^ 'categories'! !

!Lexicon methodsFor: 'category list' stamp: 'sw 12/13/2000 10:38'!
categoryWithNameSpecifiedBy: aSelector
	"Answer the category name obtained by sending aSelector to my class.  This provides a way to avoid hard-coding the wording of conventions such as '-- all --'"

	^ self class perform: aSelector! !

!Lexicon methodsFor: 'category list' stamp: 'nb 6/17/2003 12:25'!
chooseCategory: aCategory
	"Choose the category of the given name, if there is one"

	self categoryListIndex: (categoryList indexOf: aCategory ifAbsent: [^ Beeper beep])! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
newCategoryPane
	"Formulate a category pane for insertion into the receiver's pane list"

	| aListMorph |
	aListMorph := PluggableListMorph on: self list: #categoryList
			selected: #categoryListIndex changeSelected: #categoryListIndex:
			menu: #categoryListMenu:shifted:
			keystroke: #categoryListKey:from:.
	aListMorph setNameTo: 'categoryList'.
	aListMorph menuTitleSelector: #categoryListMenuTitle.
	^ aListMorph! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
reformulateCategoryList
	"Reformulate the category list"

	categoryList := nil.
	self categoryListIndex: 0.
	self changed: #categoryList.
	self contentsChanged! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
selectWithinCurrentCategoryIfPossible: aSelector
	"If the receiver's message list contains aSelector, navigate right to it without changing categories"
 
	| detectedItem messageIndex |
	aSelector ifNil: [^ self].
	detectedItem := messageList detect:
		[:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
	messageIndex := messageList indexOf: detectedItem.
	self messageListIndex: messageIndex
! !

!Lexicon methodsFor: 'category list' stamp: 'sw 12/12/2000 19:38'!
selectedCategoryName
	"Answer the selected category name"

	^ categoryList ifNotNil:
		[categoryList at: categoryListIndex ifAbsent: [nil]]! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
selectorsReferringToClassVar
	"Return a list of methods that refer to given class var that are in the 
	protocol of this object"
	| aList aClass nonMeta poolAssoc |
	nonMeta := targetClass theNonMetaClass.
	aClass := nonMeta classThatDefinesClassVariable: currentQueryParameter.
	aList := OrderedCollection new.
	poolAssoc := aClass classPool associationAt: currentQueryParameter asSymbol.
	(self systemNavigation allCallsOn: poolAssoc)
		do: [:elem | (nonMeta isKindOf: elem actualClass)
				ifTrue: [aList add: elem methodSymbol]].
	^ aList! !

!Lexicon methodsFor: 'category list' stamp: 'sd 11/20/2005 21:27'!
showCategoriesPane
	"Show the categories pane instead of the search pane"

	| aPane |
	(aPane := self searchPane) ifNil: [^ Beeper beep].
	self containingWindow replacePane: aPane with: self newCategoryPane.
	categoryList := nil.
	self changed: #categoryList.
	self changed: #messageList! !


!Lexicon methodsFor: 'contents' stamp: 'tk 9/14/2001 16:37'!
contents
	"We have a class, allow new messages to be defined"

	editSelection == #newMessage ifTrue: [^ targetClass sourceCodeTemplate].
	^ super contents! !


!Lexicon methodsFor: 'control buttons' stamp: 'sd 11/20/2005 21:27'!
customButtonRow
	"Answer a custom row of widgets, which pertain primarily to within-tool navigation"

	| aRow aButton aLabel |
	aRow := AlignmentMorph newRow.
	aRow setNameTo: 'navigation controls'.
	aRow beSticky.
	aRow hResizing: #spaceFill.
	aRow wrapCentering: #center; cellPositioning: #leftCenter.
	aRow clipSubmorphs: true.
	aRow cellInset: 3.

	self customButtonSpecs  do:
		[:triplet |
			aButton := PluggableButtonMorph
				on: self
				getState: nil
				action: triplet second.
			aButton 
				useRoundedCorners;
				hResizing: #spaceFill;
				vResizing: #spaceFill;
				onColor: Color transparent offColor: Color transparent.
			aLabel := Preferences abbreviatedBrowserButtons 
				ifTrue: [self abbreviatedWordingFor: triplet second]
				ifFalse: [nil].
			aButton label: (aLabel ifNil: [triplet first asString])
				" font: (StrikeFont familyName: 'Atlanta' size: 9)".
			triplet size > 2 ifTrue: [aButton setBalloonText: triplet third].
			triplet size > 3 ifTrue: [aButton triggerOnMouseDown: triplet fourth].
			aRow addMorphBack: aButton].

	aRow addMorphBack: self homeCategoryButton.
	aRow addMorphFront: (Morph new extent: (4@10)) beTransparent.
	aRow addMorphFront: self mostGenericButton.
	aRow addMorphFront: self menuButton.

	^ aRow! !

!Lexicon methodsFor: 'control buttons' stamp: 'sd 11/20/2005 21:27'!
customButtonSpecs
	"Answer a triplet defining buttons, in the format:

			button label
			selector to send
			help message"
	| aa |
	aa := contentsSymbol == #tiles ifTrue: [{   "Consult Ted Kaehler regarding this bit"
	{'tiles'.				#tilesMenu.					'tiles for assignment and constants'. 	true}.
	{'vars'.				#varTilesMenu.	'tiles for instance variables and a new temporary'. 	true}
		}] ifFalse: [#()].	"true in 4th place means act on mouseDown"

	^ aa, #(
	('follow'			seeAlso							'view a method I implement that is called by this method')
	('find'				obtainNewSearchString			'find methods by name search')
	('sent...'			setSendersSearch				'view the methods I implement that send a given message')

	('<'					navigateToPreviousMethod 		'view the previous active method')
	('>'					navigateToNextMethod 			'view the next active method')
	('-'					removeFromSelectorsVisited		'remove this method from my active list'))! !

!Lexicon methodsFor: 'control buttons' stamp: 'sw 10/8/2001 14:33'!
homeCategoryButton
	"Answer a button that brings up a menu.  Useful when adding new features, but at present is between uses"

	^ IconicButton new target: self;
		borderWidth: 0;
		labelGraphic: (ScriptingSystem formAtKey: #Cat);
		color: Color transparent; 
		actWhen: #buttonUp;
		actionSelector: #showHomeCategory;
		setBalloonText: 'show this method''s home category';
		yourself! !

!Lexicon methodsFor: 'control buttons' stamp: 'sd 11/20/2005 21:27'!
mostGenericButton
	"Answer a button that reports on, and allow the user to modify, the most generic class to show"

	| aButton |
	aButton := UpdatingSimpleButtonMorph newWithLabel: 'All'.
	aButton setNameTo: 'limit class'.
	aButton target: self; wordingSelector: #limitClassString; actionSelector: #chooseLimitClass.
	aButton setBalloonText: 
'Governs which classes'' methods should be shown.  If this is the same as the viewed class, then only methods implemented in that class will be shown.  If it is ProtoObject, then methods of all classes in the vocabulary will be shown.'.
	aButton actWhen: #buttonDown.
	aButton color: Color transparent.
	aButton borderColor: Color black.
	^ aButton! !

!Lexicon methodsFor: 'control buttons' stamp: 'sd 11/20/2005 21:27'!
searchToggleButton
	"Return a checkbox governing whether a search pane or a categories pane is used.  No senders at the moment, but this feature might be useful someday."

	|  outerButton aButton |
	outerButton := AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleSearch;
		getSelector: #hasSearchPane.
	outerButton addMorphBack: (StringMorph contents: 'search') lock.
	outerButton setBalloonText: 'If checked, then a search pane is used, if not, then a categories pane will be seen instead'.

	^ outerButton
! !


!Lexicon methodsFor: 'controls' stamp: 'md 2/24/2006 16:02'!
addOptionalButtonsTo: window at: fractions plus: verticalOffset
	"In this case we may actually add TWO rows of buttons."

	| delta buttons divider anOffset |
	anOffset := Preferences optionalButtons
		ifTrue:
			[super addOptionalButtonsTo: window at: fractions plus: verticalOffset]
		ifFalse:
			[verticalOffset].
	delta := self defaultButtonPaneHeight.
	buttons := self customButtonRow.
	buttons	 color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]);
		borderWidth: 0.
	buttons color: Color transparent.
	buttons submorphsDo:[:m | m borderWidth: 2; borderColor: #raised].
	divider := BorderedSubpaneDividerMorph forBottomEdge.
	divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2.
	window 
		addMorph: buttons
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@anOffset corner: 0@(anOffset + delta - 1))).
	window 
		addMorph: divider
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@(anOffset + delta - 1) corner: 0@(anOffset + delta))).
	^ anOffset + delta! !


!Lexicon methodsFor: 'history' stamp: 'sd 11/20/2005 21:27'!
navigateToNextMethod
	"Navigate to the 'next' method in the current viewing sequence"

	| anIndex aSelector |
	self selectorsVisited size == 0 ifTrue: [^ self].
	anIndex := (aSelector := self selectedMessageName) notNil ifTrue: [selectorsVisited indexOf: aSelector ifAbsent: [selectorsVisited size]] ifFalse: [1].
	self selectedCategoryName == self class viewedCategoryName 
		ifTrue:
			[self selectWithinCurrentCategory: (selectorsVisited atWrap: (anIndex + 1))]
		ifFalse:
			[self displaySelector: (selectorsVisited atWrap: (anIndex + 1))]! !

!Lexicon methodsFor: 'history' stamp: 'sd 11/20/2005 21:27'!
navigateToPreviousMethod
	"Navigate to the 'previous' method in the current viewing sequence"

	| anIndex aSelector |
	self selectorsVisited size == 0 ifTrue: [^ self].
	anIndex := (aSelector := self selectedMessageName) notNil
		ifTrue: [selectorsVisited indexOf: aSelector ifAbsent: [selectorsVisited size]]
		ifFalse: [selectorsVisited size].
	self selectedCategoryName == self class viewedCategoryName 
		ifTrue:
			[self selectWithinCurrentCategory: (selectorsVisited atWrap: (anIndex - 1))]
		ifFalse:
			[self displaySelector: (selectorsVisited atWrap: (anIndex - 1))]! !

!Lexicon methodsFor: 'history' stamp: 'sd 11/20/2005 21:27'!
navigateToRecentMethod
	"Put up a menu of recent selectors visited and navigate to the one chosen"

	| visited aSelector |
	(visited := self selectorsVisited) size > 1 ifTrue:
		[visited := visited copyFrom: 1 to: (visited size min: 20).
		aSelector := (SelectionMenu selections: visited) startUpWithCaption: 'Recent methods visited in this browser'.
		aSelector isEmptyOrNil ifFalse: [self displaySelector: aSelector]]! !

!Lexicon methodsFor: 'history' stamp: 'sd 11/20/2005 21:27'!
removeFromSelectorsVisited
	"Remove the currently-selected method from the active set"

	| aSelector |
	(aSelector := self selectedMessageName) ifNil: [^ self].
	self removeFromSelectorsVisited: aSelector.
	self chooseCategory: self class viewedCategoryName! !

!Lexicon methodsFor: 'history' stamp: 'sw 3/19/2001 07:43'!
removeFromSelectorsVisited: aSelector
	"remove aSelector from my history list"

	self selectorsVisited remove: aSelector ifAbsent: []! !

!Lexicon methodsFor: 'history' stamp: 'sd 11/20/2005 21:27'!
selectorsVisited
	"Answer the list of selectors visited in this tool"

	^ selectorsVisited ifNil: [selectorsVisited := OrderedCollection new]! !

!Lexicon methodsFor: 'history' stamp: 'sw 12/11/2000 08:49'!
updateSelectorsVisitedfrom: oldSelector to: newSelector
	"Update the list of selectors visited."

	newSelector == oldSelector ifTrue: [^ self].
	self selectorsVisited remove: newSelector ifAbsent: [].
		
	(selectorsVisited includes:  oldSelector)
		ifTrue:
			[selectorsVisited add: newSelector after: oldSelector]
		ifFalse:
			[selectorsVisited add: newSelector]
! !


!Lexicon methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
initListFrom: selectorCollection highlighting: aClass 
	"Make up the messageList with items from aClass in boldface.  Provide a final filtering in that only selectors whose implementations fall within my limitClass will be shown."

	| defClass item |
	messageList := OrderedCollection new.
	selectorCollection do: 
		[:selector |  defClass := aClass whichClassIncludesSelector: selector.
		(defClass notNil and: [defClass includesBehavior: self limitClass]) ifTrue:
			[item := selector, '     (' , defClass name , ')'.
			item := item asText.
			defClass == aClass ifTrue: [item allBold].
			"(self isThereAnOverrideOf: selector) ifTrue: [item addAttribute: TextEmphasis struckOut]."
			"The above has a germ of a good idea but could be very slow"
			messageList add: item]]! !

!Lexicon methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
openOnClass: aTargetClass inWorld: aWorld showingSelector: aSelector
	"Create and open a SystemWindow to house the receiver, showing the categories pane.  The target-object parameter is optional -- if nil, the browser will be associated with the class as a whole but not with any particular instance of it."

	| window aListMorph catListFraction |

	currentVocabulary ifNil: [currentVocabulary := Vocabulary fullVocabulary].
	targetClass := aTargetClass.
	self initialLimitClass.
	
	window := self windowWithLabel: self startingWindowTitle.

	catListFraction := 0.20.
	
	window addMorph: self newCategoryPane frame: (0 @ 0 corner: 0.5 @ catListFraction).

	aListMorph := PluggableListMorph new.
	aListMorph 	setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForLexiconString.
	aListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:shifted:
			keystroke: #messageListKey:from:.
	aListMorph setNameTo: 'messageList'.
	aListMorph menuTitleSelector: #messageListSelectorTitle.
	window addMorph: aListMorph frame: (0.5 @ 0 corner: 1 @ catListFraction).
		"side by side"

	self reformulateCategoryList.
	"needs to do this here because otherwise the following will break due to change 5738"

	self 
		addLowerPanesTo: window 
		at: (0 @ catListFraction  corner: 1@1) 
		with: nil.

	window changeAllBorderColorsFrom: Color black to: (self defaultBackgroundColor mixed: 0.5 with: Color black).
	window color: self defaultBackgroundColor.

	window openInWorld: aWorld.
	aSelector ifNotNil: [self selectSelectorItsNaturalCategory: aSelector] ifNil: [self categoryListIndex: 1].
	#(navigateToPreviousMethod	 navigateToNextMethod removeFromSelectorsVisited) do:
		[:sel |
			(self buttonWithSelector: sel) ifNotNilDo:
				[:aButton | aButton borderWidth: 0]].

	self adjustWindowTitle! !

!Lexicon methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
openWithSearchPaneOn: aTargetClass  inWorld: aWorld
	"Create and open a SystemWindow to house the receiver, search-pane variant.  Only sender is currently unsent; a disused branch but still for the moment retained"

	| window aListMorph aTextMorph baseline typeInPane |

	targetClass := aTargetClass.
	window := self windowWithLabel: 'Vocabulary of ', aTargetClass nameForViewer.

	window addMorph: self newSearchPane frame: (0@0 extent: 1@0.05).

	aListMorph := PluggableListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:shifted:
			keystroke: #messageListKey:from:.
	aListMorph menuTitleSelector: #messageListSelectorTitle.
	window addMorph: aListMorph frame: (0@0.05 extent: 1@0.25).

	 self wantsAnnotationPane
		ifFalse:
			[baseline  := 0.25]
		ifTrue:
			[aTextMorph := PluggableTextMorph on: self
					text: #annotation accept: nil
					readSelection: nil menu: nil.
			aTextMorph askBeforeDiscardingEdits: false.
			window addMorph: aTextMorph
				frame: (0@0.25 corner: 1@0.35).
			baseline := 0.35].
	self wantsOptionalButtons
		ifTrue:
			[window addMorph: self optionalButtonRow frame: ((0@baseline corner: 1 @ (baseline + 0.08))).
			baseline := baseline + 0.08].

	typeInPane := PluggableTextMorph on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	typeInPane retractable: false.
	window addMorph: typeInPane
		frame: (0 @ baseline corner: 1 @ 1).

	window setUpdatablePanesFrom: #(messageList).
	window openInWorld: aWorld.
	self flag: #deferred.

	"self initListFrom: aTargetClass allCategoriesInProtocol asSortedCollection highlighting: aTargetClass"
	
"(Lexicon new useProtocol: Protocol fullProtocol) openWithSearchPaneOn: TileMorph  inWorld: self currentWorld"

! !

!Lexicon methodsFor: 'initialization' stamp: 'sw 1/24/2001 21:25'!
wantsAnnotationPane
	"This kind of browser always wants annotation panes, so answer true"

	^ true! !

!Lexicon methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
windowWithLabel: aLabel
	"Answer a SystemWindow associated with the receiver, with appropriate border characteristics"

	| window |
	(window := SystemWindow labelled: aLabel) model: self.
	"window borderWidth: 1; borderColor: self defaultBackgroundColor darker."
	^ window
! !


!Lexicon methodsFor: 'limit class' stamp: 'sd 11/20/2005 21:27'!
chooseLimitClass
	"Put up a menu allowing the user to choose the most generic class to show"

	| aMenu |
	aMenu := MenuMorph new defaultTarget: self.
	targetClass withAllSuperclasses do:
		[:aClass | 
			aClass == ProtoObject
				ifTrue:
					[aMenu addLine].
			aMenu add: aClass name selector: #setLimitClass: argument: aClass.
			aClass == limitClass ifTrue:
				[aMenu lastItem color: Color red].
			aClass == targetClass ifTrue: [aMenu addLine]].
	aMenu addTitle: 'Show only methods
implemented at or above...'.  "heh heh -- somebody please find nice wording here!!"
	aMenu popUpInWorld: self currentWorld! !

!Lexicon methodsFor: 'limit class' stamp: 'sd 11/20/2005 21:27'!
initialLimitClass
	"Choose a plausible initial vlaue for the limit class, and answer it"

	| oneTooFar |
	limitClass := targetClass.
	(#('ProtoObject' 'Object' 'Behavior' 'ClassDescription' 'Class' 'ProtoObject class' 'Object class') includes: targetClass name asString) ifTrue: [^ targetClass].

	oneTooFar := (targetClass isKindOf: Metaclass)
		ifTrue:
			["use the fifth back from the superclass chain for Metaclasses, which is the immediate subclass of ProtoObject class.  Print <ProtoObject class allSuperclasses> to count them yourself."
			targetClass allSuperclasses at: (targetClass allSuperclasses size - 5)]
		ifFalse:
			[targetClass allSuperclasses at: targetClass allSuperclasses size].
	[limitClass superclass ~~ oneTooFar]
		whileTrue: [limitClass := limitClass superclass].
	^ limitClass! !

!Lexicon methodsFor: 'limit class' stamp: 'sw 10/12/2001 21:30'!
limitClass
	"Answer the most generic class to show in the browser.  By default, we go all the way up to ProtoObject"

	^ limitClass ifNil: [self initialLimitClass]! !

!Lexicon methodsFor: 'limit class' stamp: 'sd 11/20/2005 21:27'!
limitClass: aClass
	"Set the most generic class to show as indicated"

	limitClass := aClass! !

!Lexicon methodsFor: 'limit class' stamp: 'sd 11/20/2005 21:27'!
limitClassString
	"Answer a string representing the current choice of most-generic-class-to-show"

	| most |
	(most := self limitClass) == ProtoObject
		ifTrue:	[^ 'All'].
	most == targetClass
		ifTrue:	[^ most name].
	^ 'Only through ', most name! !

!Lexicon methodsFor: 'limit class' stamp: 'sd 11/20/2005 21:27'!
setLimitClass: aClass
	"Set aClass as the limit class for this browser"

	| currentClass currentSelector |
	currentClass := self selectedClassOrMetaClass.
	currentSelector := self selectedMessageName.

	self limitClass: aClass.
	categoryList := nil.
	self categoryListIndex: 0.
	self changed: #categoryList.
	self changed: #methodList.
	self changed: #contents.
	self adjustWindowTitle.
	self hasSearchPane
		ifTrue:
			[self setMethodListFromSearchString].

	self maybeReselectClass: currentClass selector: currentSelector

	! !


!Lexicon methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
offerMenu
	"Offer a menu to the user, in response to the hitting of the menu button on the tool pane"

	| aMenu |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Lexicon'.
	aMenu addStayUpItem.
	aMenu addList: #(

		('vocabulary...' 			chooseVocabulary)
		('what to show...'			offerWhatToShowMenu)
		-
		('inst var refs (here)'		setLocalInstVarRefs)
		('inst var defs (here)'		setLocalInstVarDefs)
		('class var refs (here)'		setLocalClassVarRefs)
		-

		('navigate to a sender...' 	navigateToASender)
		('recent...' 					navigateToRecentMethod)
		('show methods in current change set'
									showMethodsInCurrentChangeSet)
		('show methods with initials...'
									showMethodsWithInitials)
		-
		"('toggle search pane' 		toggleSearch)"

		-
		('browse full (b)' 			browseMethodFull)
		('browse hierarchy (h)'		classHierarchy)
		('browse method (O)'		openSingleMessageBrowser)
		('browse protocol (p)'		browseFullProtocol)
		-
		('fileOut'					fileOutMessage)
		('printOut'					printOutMessage)
		-
		('senders of... (n)'			browseSendersOfMessages)
		('implementors of... (m)'		browseMessages)
		('versions (v)' 				browseVersions)
		('inheritance (i)'			methodHierarchy)
		-
		('inst var refs' 				browseInstVarRefs)
		('inst var defs' 				browseInstVarDefs)
		('class var refs' 			browseClassVarRefs)
		-
		('more...'					shiftedYellowButtonActivity)).

	aMenu popUpInWorld: ActiveWorld! !

!Lexicon methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
removeMessage
	"Remove the selected message from the system."

	messageListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].

	super removeMessage.
	"my #reformulateList method, called from the super #removeMethod method, will however try to preserve the selection, so we take pains to clobber it by the below..."
	messageListIndex := 0.
	self changed: #messageList.
	self changed: #messageListIndex.
	contents := nil.
	self contentsChanged! !

!Lexicon methodsFor: 'menu commands' stamp: 'sw 10/18/2001 08:10'!
showCategory
	"A revectoring blamable on history.  Not sent in the image, but grandfathered buttons may still send this."

	^ self showHomeCategory! !

!Lexicon methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
showHomeCategory
	"Continue to show the current selector, but show it within the context of its primary category"

	| aSelector |
	(aSelector := self selectedMessageName) ifNotNil:
		[self preserveSelectorIfPossibleSurrounding:
			[self setToShowSelector: aSelector]]! !

!Lexicon methodsFor: 'menu commands' stamp: 'sw 10/8/2001 14:34'!
showMainCategory
	"Continue to show the current selector, but show it within the context of its primary category.  Preserved for backward compatibility with pre-existing buttons."

	^ self showHomeCategory! !


!Lexicon methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:25'!
canShowMultipleMessageCategories
	"Answer whether the receiver is capable of showing multiple message categories"

	^ true! !


!Lexicon methodsFor: 'message list menu' stamp: 'sw 4/20/2001 20:54'!
messageListKey: aChar from: view
	"Respond to a Command key"

	aChar == $f ifTrue: [^ self obtainNewSearchString].
	^ super messageListKey: aChar from: view! !


!Lexicon methodsFor: 'model glue' stamp: 'sw 3/20/2001 12:11'!
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.  Here, if the receiver is affiliated with a specific instance, we give give that primacy"

	^ self targetObject ifNil: [self selectedClass ifNil: [FakeClassPool new]]! !

!Lexicon methodsFor: 'model glue' stamp: 'sd 11/20/2005 21:27'!
okayToAccept
	"Answer whether it is okay to accept the receiver's input"

	| ok aClass reply |
	(ok := super okayToAccept) ifTrue:
		[((aClass := self selectedClassOrMetaClass) ~~ targetClass) ifTrue:
			[reply := UIManager default chooseFrom: 
	{'okay, no problem'. 
	'cancel - let me reconsider'. 
	'compile into ', targetClass name, ' instead'.
	'compile into a new uniclass'} title:
'Caution!!  This would be
accepted into class ', aClass name, '.
Is that okay?' .
			reply = 1 ifTrue: [^ true].
			reply ~~ 2 ifTrue:
				[self notYetImplemented].
			^ false]].
	^ ok! !

!Lexicon methodsFor: 'model glue' stamp: 'sw 3/20/2001 12:25'!
targetObject
	"Answer the object to which this tool is bound."

	^ nil! !


!Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/15/2003 16:12'!
browseClassVarRefs
	"Let the search pertain to the target class regardless of selection"

	self systemNavigation  browseClassVarRefs: targetClass theNonMetaClass ! !

!Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/16/2003 19:43'!
browseInstVarDefs
	"Let the search pertain to the target class regardless of selection"

	 self systemNavigation browseInstVarDefs: targetClass! !

!Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/15/2003 16:12'!
browseInstVarRefs
	"Let the search pertain to the target class regardless of selection"
	self systemNavigation  browseInstVarRefs: targetClass! !


!Lexicon methodsFor: 'search' stamp: 'sw 12/11/2000 15:26'!
hasSearchPane
	"Answer whether receiver has a search pane"

	^ self searchPane notNil! !

!Lexicon methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
lastSearchString
	"Answer the last search string, initializing it to an empty string if it has not been initialized yet"

	^ currentQueryParameter ifNil: [currentQueryParameter := 'contents']! !

!Lexicon methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
lastSearchString: aString
	"Make a note of the last string searched for in the receiver"

	currentQueryParameter := aString asString.
	currentQuery := #selectorName.
	autoSelectString := aString.
	self setMethodListFromSearchString.
	^ true! !

!Lexicon methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
lastSendersSearchSelector
	"Answer the last senders search selector, initializing it to a default value if it does not already have a value"

	^ currentQueryParameter ifNil: [currentQueryParameter := #flag:]! !

!Lexicon methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
methodListFromSearchString: fragment
	"Answer a method list of methods whose selectors match the given fragment"

	|  aList searchFor |
	currentQueryParameter := fragment.
	currentQuery := #selectorName.
	autoSelectString := fragment.
	searchFor := fragment asString asLowercase withBlanksTrimmed.

	aList := targetClass allSelectors select:
		[:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
	searchFor size > 0 ifTrue:
		[aList := aList select:
			[:aSelector | aSelector includesSubstring: searchFor caseSensitive: false]].
	^ aList asSortedArray
! !

!Lexicon methodsFor: 'search' stamp: 'rbb 3/1/2005 10:59'!
obtainNewSearchString
	"Put up a box allowing the user to enter a fresh search string"

	| fragment |
	
	fragment := UIManager default request: 'type method name or fragment: ' initialAnswer: self currentQueryParameter.
	fragment ifNil: [^ self].
	(fragment := fragment copyWithout: $ ) size == 0  ifTrue: [^ self].
	currentQueryParameter := fragment.
	fragment := fragment asLowercase.
	currentQuery := #selectorName.
	self showQueryResultsCategory.
	self messageListIndex: 0! !

!Lexicon methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
selectorsMatching
	"Anwer a list of selectors in the receiver that match the current search string"

	| fragment aList |
	fragment := self lastSearchString asLowercase.
	aList := targetClass allSelectors select:
		[:aSelector | (aSelector includesSubstring: fragment caseSensitive: false) and:
			[currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]].

	^ aList asSortedArray! !

!Lexicon methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
setMethodListFromSearchString
	"Set the method list of the receiver based on matches from the search string"

	| fragment aList |
	self okToChange ifFalse: [^ self].
	fragment := currentQueryParameter.
	fragment := fragment asString asLowercase withBlanksTrimmed.

	aList := targetClass allSelectors select:
		[:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
	fragment size > 0 ifTrue:
		[aList := aList select:
			[:aSelector | aSelector includesSubstring: fragment caseSensitive: false]].
	aList size == 0 ifTrue:
		[^ Beeper beep].
	self initListFrom: aList asSortedArray highlighting: targetClass.
	messageListIndex :=  messageListIndex min: messageList size.
	self changed: #messageList
! !

!Lexicon methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
showSearchPane
	"Given that the receiver is showing the categories pane, replace that with a search pane.  Though there is a residual UI for obtaining this variant, it is obscure and the integrity of the protocol-category-browser when there is no categories pane is not necessarily assured at the moment."

	| aPane |
	(aPane := self categoriesPane) ifNil: [^ Beeper beep].
	self containingWindow replacePane: aPane with: self newSearchPane.
	categoryList := nil.
	self changed: #categoryList.
	self changed: #messageList! !

!Lexicon methodsFor: 'search' stamp: 'sw 12/11/2000 14:46'!
toggleSearch
	"Toggle the determination of whether a categories pane or a search pane shows"

	self hasSearchPane
		ifTrue:	[self showCategoriesPane]
		ifFalse:	[self showSearchPane]! !


!Lexicon methodsFor: 'selection' stamp: 'sd 11/20/2005 21:27'!
categoryOfSelector: aSelector 
	"Answer the name of the defining category for aSelector, or nil if none"
	| classDefiningSelector |
	classDefiningSelector := targetClass whichClassIncludesSelector: aSelector.
	classDefiningSelector
		ifNil: [^ nil].
	"can happen for example if one issues this from a change-sorter for a 
	message that is recorded as having been removed"
	^ classDefiningSelector whichCategoryIncludesSelector: aSelector! !

!Lexicon methodsFor: 'selection' stamp: 'sd 11/20/2005 21:27'!
selectImplementedMessageAndEvaluate: aBlock
	"Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector.  If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any.  In this variant, only selectors "

	| selector method messages |
	(selector := self selectedMessageName) ifNil: [^ self].
	method := (self selectedClassOrMetaClass ifNil: [^ self])
		compiledMethodAt: selector
		ifAbsent: [].
	(method isNil or: [(messages := method messages) size == 0])
		 ifTrue: [^ aBlock value: selector].
	(messages size == 1 and: [messages includes: selector])
		ifTrue:
			[^ aBlock value: selector].  "If only one item, there is no choice"

	messages := messages select: [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
	self systemNavigation 
		showMenuOf: messages
		withFirstItem: selector
		ifChosenDo: [:sel | aBlock value: sel]! !

!Lexicon methodsFor: 'selection' stamp: 'sd 11/20/2005 21:27'!
selectSelectorItsNaturalCategory: aSelector
	"Make aSelector be the current selection of the receiver, with the category being its home category."

	| cat catIndex detectedItem |
	cat := self categoryOfSelector: aSelector.
	catIndex := categoryList indexOf: cat ifAbsent:
		["The method's own category is not seen in this browser; the method probably occurs in some other category not known directly to the class, but for now, we'll just use the all category"
		1].
	self categoryListIndex: catIndex.
	detectedItem := messageList detect:
		[:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
	self messageListIndex:  (messageList indexOf: detectedItem ifAbsent: [^ self])! !

!Lexicon methodsFor: 'selection' stamp: 'sd 11/20/2005 21:27'!
selectWithinCurrentCategory: aSelector
	"If aSelector is one of the selectors seen in the current category, select it"

	| detectedItem |
	detectedItem := self messageList detect:
		[:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
	self messageListIndex:  (messageList indexOf: detectedItem ifAbsent: [^ self])! !

!Lexicon methodsFor: 'selection' stamp: 'tk 9/15/2001 08:17'!
selectedClassOrMetaClass
	"Answer the currently selected class (or metaclass)."

	self setClassAndSelectorIn: [:c :s | ^c]! !

!Lexicon methodsFor: 'selection' stamp: 'md 2/20/2006 15:03'!
selectedMessage
	"Answer the source method for the currently selected message."

	(categoryList notNil and: [(categoryListIndex isNil or: [categoryListIndex == 0])])
		ifTrue:
			[^ '---'].

	self setClassAndSelectorIn: [:class :selector | 
		class ifNil: [^ 'here would go the documentation for the protocol category, if any.'].

		self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
		self showingDocumentation ifTrue: [^ self commentContents].

		currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil].
		^ self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: class]! !

!Lexicon methodsFor: 'selection' stamp: 'tk 9/15/2001 08:14'!
setClassAndSelectorIn: csBlock
	"Decode strings of the form    <selectorName> (<className> [class])"


	self selection ifNil: [^ csBlock value: targetClass value: nil].
	^ super setClassAndSelectorIn: csBlock! !

!Lexicon methodsFor: 'selection' stamp: 'sd 11/20/2005 21:27'!
setToShowSelector: aSelector
	"Set up the receiver so that it will show the given selector"

	| catName catIndex detectedItem messageIndex aList |
	catName := (aList := currentVocabulary categoriesContaining: aSelector  forClass: targetClass) size > 0
		ifTrue:
			[aList first]
		ifFalse:
			[self class allCategoryName].
	catIndex := categoryList indexOf: catName ifAbsent: [1].
	self categoryListIndex: catIndex.
	detectedItem := messageList detect:
		[:anItem | (anItem upTo: $ ) asString asSymbol == aSelector] ifNone: [^ self].
	messageIndex := messageList indexOf: detectedItem.
	self messageListIndex: messageIndex
! !


!Lexicon methodsFor: 'senders' stamp: 'sd 11/20/2005 21:27'!
navigateToASender
	"Present the user with a list of senders of the currently-selected 
	message, and navigate to the chosen one"
	| selectorSet chosen aSelector |
	aSelector := self selectedMessageName.
	selectorSet := Set new.
	(self systemNavigation allCallsOn: aSelector)
		do: [:anItem | selectorSet add: anItem methodSymbol].
	selectorSet := selectorSet
				select: [:sel | currentVocabulary
						includesSelector: sel
						forInstance: self targetObject
						ofClass: targetClass
						limitClass: limitClass].
	selectorSet size == 0
		ifTrue: [^ Beeper beep].
	self okToChange
		ifFalse: [^ self].
	chosen := (SelectionMenu selections: selectorSet asSortedArray) startUp.
	chosen isEmptyOrNil
		ifFalse: [self displaySelector: chosen]! !

!Lexicon methodsFor: 'senders' stamp: 'sd 11/20/2005 21:27'!
selectorsSendingSelectedSelector
	"Assumes lastSendersSearchSelector is already set"
	| selectorSet sel cl |
	autoSelectString := (self lastSendersSearchSelector upTo: $:) asString.
	selectorSet := Set new.
	(self systemNavigation allCallsOn: self lastSendersSearchSelector)
		do: [:anItem | 
			sel := anItem methodSymbol.
			cl := anItem actualClass.
			((currentVocabulary
						includesSelector: sel
						forInstance: self targetObject
						ofClass: targetClass
						limitClass: limitClass)
					and: [targetClass includesBehavior: cl])
				ifTrue: [selectorSet add: sel]].
	^ selectorSet asSortedArray! !

!Lexicon methodsFor: 'senders' stamp: 'rbb 3/1/2005 10:59'!
setSendersSearch
	"Put up a list of messages sent in the current message, find all methods 
	of the browsee which send the one the user chooses, and show that list 
	in the message-list pane, with the 'query results' item selected in the 
	category-list pane"
	| selectorSet aSelector aString |
	self selectedMessageName
		ifNil: [aString := UIManager default request: 'Type selector to search for' initialAnswer: 'flag:'.
			aString isEmptyOrNil
				ifTrue: [^ self].
			Symbol
				hasInterned: aString
				ifTrue: [:sel | aSelector := sel]]
		ifNotNil: [self
				selectMessageAndEvaluate: [:sel | aSelector := sel]].
	aSelector
		ifNil: [^ self].
	selectorSet := Set new.
	(self systemNavigation allCallsOn: aSelector)
		do: [:anItem | selectorSet add: anItem methodSymbol].
	selectorSet := selectorSet
				select: [:sel | currentVocabulary
						includesSelector: sel
						forInstance: self targetObject
						ofClass: targetClass
						limitClass: limitClass].
	selectorSet size > 0
		ifTrue: [currentQuery := #senders.
			currentQueryParameter := aSelector.
			self
				categoryListIndex: (categoryList indexOf: self class queryCategoryName).
			self messageListIndex: 0]! !


!Lexicon methodsFor: 'transition' stamp: 'sw 3/20/2001 12:11'!
maybeReselectClass: aClass selector: aSelector
	"The protocol or limitClass may have changed, so that there is a different categoryList.  Formerly, the given class and selector were selected; if it is possible to do so, reselect them now"

	aClass ifNil: [^ self].
	(currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass)
		ifTrue:
			[self selectSelectorItsNaturalCategory: aSelector]! !

!Lexicon methodsFor: 'transition' stamp: 'sw 3/20/2001 00:41'!
noteAcceptanceOfCodeFor: newSelector
	"The user has submitted new code for the given selector; take a note of it.  NB that the selectors-changed list gets added to here, but is not currently used in the system."

	(self selectorsVisited includes: newSelector) ifFalse: [selectorsVisited add: newSelector].! !

!Lexicon methodsFor: 'transition' stamp: 'sd 11/20/2005 21:27'!
preserveSelectorIfPossibleSurrounding: aBlock
	"Make a note of the currently-selected method; perform aBlock and then attempt to reestablish that same method as the selected one in the new circumstances"

	| aClass aSelector |
	aClass := self selectedClassOrMetaClass.
	aSelector := self selectedMessageName.
	aBlock value.
	
	self hasSearchPane
		ifTrue:
			[self setMethodListFromSearchString]
		ifFalse:
			[self maybeReselectClass: aClass selector: aSelector]! !

!Lexicon methodsFor: 'transition' stamp: 'sw 12/11/2000 02:00'!
reformulateList
	"Make the category list afresh, and reselect the current selector if appropriate"

	self preserveSelectorIfPossibleSurrounding:
		[super reformulateList.
		self categoryListIndex: categoryListIndex]! !

!Lexicon methodsFor: 'transition' stamp: 'sw 1/12/2001 00:33'!
reformulateListNoting: newSelector
	"A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so"

	super reformulateListNoting: newSelector.
	newSelector ifNotNil:
		[self displaySelector: newSelector]! !

!Lexicon methodsFor: 'transition' stamp: 'sd 11/20/2005 21:27'!
retainMethodSelectionWhileSwitchingToCategory: aCategoryName
	"retain method selection while switching the category-pane selection to show the category of the given name"

	| aSelectedName |
	aSelectedName := self selectedMessageName.
	self categoryListIndex: (categoryList indexOf: aCategoryName ifAbsent: [^ self]).
	aSelectedName ifNotNil: [self selectWithinCurrentCategory: aSelectedName]
! !


!Lexicon methodsFor: 'vocabulary' stamp: 'sd 11/20/2005 21:27'!
chooseVocabulary
	"Put up a dialog affording the user a chance to choose a different vocabulary to be installed in the receiver"

	| aMenu |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Choose a vocabulary
blue = current
red = imperfect' translated.
	aMenu addStayUpItem.
	Vocabulary allStandardVocabularies do:
		[:aVocabulary |
			(targetClass implementsVocabulary: aVocabulary)
				ifTrue:
					[aMenu add: aVocabulary vocabularyName selector: #switchToVocabulary: argument: aVocabulary.
					(targetClass fullyImplementsVocabulary: aVocabulary) ifFalse:
						[aMenu lastItem color: Color red].
					aVocabulary == currentVocabulary ifTrue:
						[aMenu lastItem color: Color blue]. 
					aMenu balloonTextForLastItem: aVocabulary documentation]].
	aMenu popUpInWorld: self currentWorld! !

!Lexicon methodsFor: 'vocabulary' stamp: 'sw 1/26/2001 19:40'!
switchToVocabulary: aVocabulary
	"Make aVocabulary be the current one in the receiver"

	self preserveSelectorIfPossibleSurrounding:
		[self useVocabulary: aVocabulary.
		self reformulateCategoryList.
		self adjustWindowTitle]
! !

!Lexicon methodsFor: 'vocabulary' stamp: 'sd 11/20/2005 21:27'!
useVocabulary: aVocabulary
	"Set up the receiver to use the given vocabulary"

	currentVocabulary := aVocabulary! !


!Lexicon methodsFor: 'window title' stamp: 'sw 3/19/2001 08:45'!
addModelItemsToWindowMenu: aMenu
	"Add model-related item to the window menu"

	super addModelItemsToWindowMenu: aMenu. 
	aMenu add: 'choose vocabulary...' target: self action: #chooseVocabulary! !

!Lexicon methodsFor: 'window title' stamp: 'sd 11/20/2005 21:27'!
adjustWindowTitle
	"Set the title of the receiver's window, if any, to reflect the current choices"

	| aWindow aLabel catName |
	(catName := self selectedCategoryName) ifNil: [^ self].
	(aWindow := self containingWindow) ifNil: [^ self].
	aLabel := nil.
	#(	(viewedCategoryName		'Messages already viewed - ')
		(allCategoryName			'All messages - ')) do:
			[:aPair | catName = (self categoryWithNameSpecifiedBy: aPair first) ifTrue: [aLabel := aPair second]].

	aLabel ifNil:
		[aLabel := catName = self class queryCategoryName
			ifTrue:
				[self queryCharacterization, ' - ']
			ifFalse:
				['Vocabulary of ']].
	aWindow setLabel: aLabel, (self targetObject ifNil: [targetClass]) nameForViewer! !

!Lexicon methodsFor: 'window title' stamp: 'sw 3/20/2001 12:18'!
startingWindowTitle
	"Answer the initial window title to apply"

	^ 'Vocabulary of ', targetClass nameForViewer! !


!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
currentQueryParameter
	"Answer the current query parameter"

	^ currentQueryParameter ifNil: [currentQueryParameter := 'contents']! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sw 11/21/2001 10:48'!
methodsWithInitials
	"Answer the list of method selectors within the scope of this tool whose time stamps begin with the initials designated by my currentQueryParameter"

	^ self methodsWithInitials: currentQueryParameter! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
methodsWithInitials: initials
	"Return a list of selectors representing methods whose timestamps have the given initials and which are in the protocol of this object and within the range dictated by my limitClass."

	| classToUse |
	classToUse := self targetObject ifNotNil: [self targetObject class] ifNil: [targetClass].  "In support of lightweight uniclasses"
	^ targetClass allSelectors select:
		[:aSelector | (currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: classToUse limitClass: limitClass) and:
			[Utilities doesMethod: aSelector forClass: classToUse bearInitials: initials]].

! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sw 7/23/2002 12:43'!
queryCharacterization
	"Answer a characterization of the most recent query"

	currentQuery == #selectorName
		ifTrue: [^ 'My methods whose names include "', self lastSearchString, '"'].
	currentQuery == #methodsWithInitials
		ifTrue: [^ 'My methods stamped with initials ', currentQueryParameter].
	currentQuery == #senders
		ifTrue: [^ 'My methods that send #', self lastSendersSearchSelector].
	currentQuery == #currentChangeSet
		ifTrue: [^ 'My methods in the current change set'].
	currentQuery == #instVarRefs
		ifTrue:	[^ 'My methods that refer to instance variable "', currentQueryParameter, '"'].
	currentQuery == #instVarDefs
		ifTrue:	[^ 'My methods that store into instance variable "', currentQueryParameter, '"'].
	currentQuery == #classVarRefs
		ifTrue:	[^ 'My methods that refer to class variable "', currentQueryParameter, '"'].
	^ 'Results of queries will show up here'! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'md 10/22/2003 16:14'!
seeAlso
	"Present a menu offering the selector of the currently selected message, as well as of all messages sent by it.  If the chosen selector is showable in the current browser, show it here, minding unsubmitted edits however"

	self selectImplementedMessageAndEvaluate:
		[:aSelector |
			((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass)  			 "i.e., is this aSelector available in this browser"
					and: [self okToChange])
				ifTrue:
					[self displaySelector: aSelector]
				ifFalse:
					[Beeper beep.  "SysttemNavigation new browseAllImplementorsOf: aSelector"]].
					"Initially I tried making this open an external implementors browser in this case, but later decided that the user model for this was unstable"! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'nb 6/17/2003 12:25'!
seeAlso: aSelector
	"If the requested selector is showable in the current browser, show it here, minding unsubmitted edits however"

	((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass)   "i.e., is aSelector available in this browser"
					and: [self okToChange])
		ifTrue:
			[self displaySelector: aSelector]
		ifFalse:
			[Beeper beep]! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
selectorsChanged
	"Return a list of methods in the current change set (or satisfying some 
	other such criterion) that are in the protocol of this object"
	| aList aClass targetedClass |
	targetedClass := self targetObject
				ifNil: [targetClass]
				ifNotNil: [self targetObject class].
	aList := OrderedCollection new.
	ChangeSet current methodChanges
		associationsDo: [:classChgAssoc | classChgAssoc value
				associationsDo: [:methodChgAssoc | (methodChgAssoc value == #change
							or: [methodChgAssoc value == #add])
						ifTrue: [(aClass := targetedClass whichClassIncludesSelector: methodChgAssoc key)
								ifNotNil: [aClass name = classChgAssoc key
										ifTrue: [aList add: methodChgAssoc key]]]]].
	^ aList! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
selectorsDefiningInstVar
	"Return a list of methods that define a given inst var that are in the protocol of this object"

	| aList  |
	aList := OrderedCollection new.
	targetClass withAllSuperclassesDo:
		[:aClass | 
			(aClass whichSelectorsStoreInto: currentQueryParameter asString) do: 
				[:sel | sel isDoIt ifFalse: [aList add: sel]
			]
		].
	^ aList! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
selectorsReferringToInstVar
	"Return a list of methods that refer to a given inst var that are in the protocol of this object"

	| aList  |
	aList := OrderedCollection new.
	targetClass withAllSuperclassesDo: [:aClass | 
		(aClass whichSelectorsAccess: currentQueryParameter asString) do: [:sel | 
			sel isDoIt ifFalse: [aList add: sel]
		]
	].
	^ aList! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sw 11/21/2001 10:53'!
selectorsRetrieved
	"Anwer a list of selectors in the receiver that have been retrieved for the query category.  This protocol is used when reformulating a list after, say, a limitClass change"

	currentQuery == #classVarRefs ifTrue: [^ self selectorsReferringToClassVar].
	currentQuery == #currentChangeSet ifTrue: [^ self selectorsChanged].
	currentQuery == #instVarDefs ifTrue: [^ self selectorsDefiningInstVar].
	currentQuery == #instVarRefs ifTrue: [^ self selectorsReferringToInstVar].
	currentQuery == #methodsWithInitials ifTrue: [^ self methodsWithInitials].
	currentQuery == #selectorName ifTrue: [^ self selectorsMatching].
	currentQuery == #senders ifTrue: [^ self selectorsSendingSelectedSelector].

	^ #()! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
setLocalClassVarRefs
	"Put up a list of the class variables in the viewed object, and when the user selects one, let the query results category show all the references to that class variable."

	| aName |

	(aName := targetClass theNonMetaClass chooseClassVarName) ifNil: [^ self].
	currentQuery := #classVarRefs.
	currentQueryParameter := aName.
	self showQueryResultsCategory! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
setLocalInstVarDefs
	"Put up a list of the instance variables in the viewed object, and when the user seletcts one, let the query results category show all the references to that instance variable."

	| instVarToProbe |

	targetClass chooseInstVarThenDo:
		[:aName | instVarToProbe := aName].
	instVarToProbe isEmptyOrNil ifTrue: [^ self].
	currentQuery := #instVarDefs.
	currentQueryParameter := instVarToProbe.
	self showQueryResultsCategory! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
setLocalInstVarRefs
	"Put up a list of the instance variables in the viewed object, and when the user seletcts one, let the query results category show all the references to that instance variable."

	| instVarToProbe |

	targetClass chooseInstVarThenDo:
		[:aName | instVarToProbe := aName].
	instVarToProbe isEmptyOrNil ifTrue: [^ self].
	currentQuery := #instVarRefs.
	currentQueryParameter := instVarToProbe.
	self showQueryResultsCategory! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
showMethodsInCurrentChangeSet
	"Set the current query to be for methods in the current change set"

	currentQuery := #currentChangeSet.
	autoSelectString := nil.
	self categoryListIndex: (categoryList indexOf: self class queryCategoryName).! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'rbb 3/1/2005 10:59'!
showMethodsWithInitials
	"Prompt the user for initials to scan for; then show, in the query-results category, all methods with those initials in their time stamps"

	| initials |
	initials := UIManager default request: 'whose initials? ' initialAnswer: Utilities authorInitials.
	initials isEmptyOrNil ifTrue: [^ self].
	self showMethodsWithInitials: initials


! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
showMethodsWithInitials: initials
	"Make the current query be for methods stamped with the given initials"

	currentQuery := #methodsWithInitials.
	currentQueryParameter := initials.
	self showQueryResultsCategory.
	autoSelectString := nil.
	self changed: #messageList.
	self adjustWindowTitle
! !

!Lexicon methodsFor: 'within-tool queries' stamp: 'sd 11/20/2005 21:27'!
showQueryResultsCategory
	"Point the receiver at the query-results category and set the search string accordingly"

	autoSelectString := self currentQueryParameter.
	self categoryListIndex: (categoryList indexOf: self class queryCategoryName).
	self messageListIndex: 0! !


!Lexicon methodsFor: '*eToys-tiles' stamp: 'nb 6/17/2003 12:25'!
acceptTiles
	| pp pq methodNode cls sel |
	"In complete violation of all the rules of pluggable panes, search dependents for my tiles, and tell them to accept."

	pp _ self dependents detect: [:pane | pane isKindOf: PluggableTileScriptorMorph] 
			ifNone: [^ Beeper beep].
	pq _ pp findA: TransformMorph.
	methodNode _ pq findA: SyntaxMorph.
	cls _ methodNode parsedInClass.
	sel _ cls compile: methodNode decompile classified: self selectedCategoryName
			notifying: nil.
	self noteAcceptanceOfCodeFor: sel.
	self reformulateListNoting: sel.! !

!Lexicon methodsFor: '*eToys-tiles' stamp: 'nk 4/28/2004 10:15'!
installTilesForSelection
	"Install universal tiles into the code pane."
	| source aSelector aClass tree syn tileScriptor aWindow codePane |
	(aWindow _ self containingWindow)
		ifNil: [self error: 'hamna dirisha'].
	aSelector _ self selectedMessageName.
	aClass _ self selectedClassOrMetaClass
				ifNil: [targetClass].
	aClass
		ifNotNil: [aSelector
				ifNil: [source _ SyntaxMorph sourceCodeTemplate]
				ifNotNil: [aClass _ self selectedClassOrMetaClass whichClassIncludesSelector: aSelector.
					source _ aClass sourceCodeAt: aSelector].
			tree _ Compiler new
						parse: source
						in: aClass
						notifying: nil.
			(syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass.
			tileScriptor _ syn inAPluggableScrollPane].
	codePane _ aWindow
				findDeepSubmorphThat: [:m | (m isKindOf: PluggableTextMorph)
						and: [m getTextSelector == #contents]]
				ifAbsent: [].
	codePane
		ifNotNil: [codePane hideScrollBars].
	codePane
		ifNil: [codePane _ aWindow
						findDeepSubmorphThat: [:m | m isKindOf: PluggableTileScriptorMorph]
						ifAbsent: [self error: 'no code pane']].
	tileScriptor color: aWindow paneColorToUse;
		 setProperty: #hideUnneededScrollbars toValue: true.
	aWindow replacePane: codePane with: tileScriptor.
	currentCompiledMethod _ aClass
				ifNotNil: [aClass
						compiledMethodAt: aSelector
						ifAbsent: []].
	tileScriptor owner clipSubmorphs: true.
	tileScriptor extent: codePane extent! !

!Lexicon methodsFor: '*eToys-tiles' stamp: 'tk 9/7/2001 10:15'!
tilesMenu
	"Offer a menu of tiles for assignment and constants"

	SyntaxMorph new offerTilesMenuFor: self targetObject in: self! !

!Lexicon methodsFor: '*eToys-tiles' stamp: 'tk 9/7/2001 10:24'!
varTilesMenu
	"Offer a menu of tiles for instance variables and a new temporary"

	SyntaxMorph new offerVarsMenuFor: self targetObject in: self! !

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

Lexicon class
	instanceVariableNames: ''!

!Lexicon class methodsFor: 'visible category names' stamp: 'sw 12/14/2000 14:15'!
activeCategoryName
	"Answer the name to be used for the active-methods category"

	true ifTrue: [^ #'-- current working set --'].

	'-- current working set --' asSymbol "Placed here so a message-strings-containing-it query will find this method"
! !

!Lexicon class methodsFor: 'visible category names' stamp: 'sw 12/13/2000 10:56'!
allCategoryName
	"Answer the name to be used for the all category"

	true ifTrue: [^ #'-- all --'].

	'-- all --' asSymbol  "Placed here so a message-strings-containing-it query will find this method"
! !

!Lexicon class methodsFor: 'visible category names' stamp: 'sw 3/19/2001 08:17'!
queryCategoryName
	"Answer the name to be used for the query-results category"

	true ifTrue: [^ #'-- query results --'].

	^ '-- query results --' asSymbol   "Placed here so a message-strings-containing-it query will find this method"! !

!Lexicon class methodsFor: 'visible category names' stamp: 'sw 12/13/2000 10:54'!
sendersCategoryName
	"Answer the name to be used for the senders-results category"

	true ifTrue: [^ #'-- "senders" results --'].

	^ '-- "senders" results --'.  "so methods-strings-containing will find this"! !

!Lexicon class methodsFor: 'visible category names' stamp: 'sw 3/19/2001 08:03'!
viewedCategoryName
	"Answer the name to be used for the previously-viewed-methods category"

	true ifTrue: [^ #'-- active --'].

	^ '-- active --' asSymbol	 "For benefit of method-strings-containing-it search"
! !


!Lexicon class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:35'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Lexicon' brightColor: #(0.878 1.000 0.878) pastelColor: #(0.925 1.000 0.925) helpMessage: 'A tool for browsing the full protocol of a class.'! !
Object subclass: #LiljencrantsFant
	instanceVariableNames: 'ro ra rk a1 a2 x1 x2 b1 c1 n0 ne'
	classVariableNames: 'Epsilon'
	poolDictionaries: ''
	category: 'Speech-Klatt'!
!LiljencrantsFant commentStamp: '<historical>' prior: 0!
This is the LF glottal-pulse model. Actually this is here only for pedagogical purposes. The LF model is again implemented in KlattSynthesizer (and as primitive in the KlattSynthesizerPluggin). For more details on the LF model see:
	Fant, G., Liljencrants, J., & Lin, Q. "A four-parameter model of glottal flow", Speech Transmission Laboratory Qurterly Progress Report 4/85, KTH.
!


!LiljencrantsFant methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
n0: anInteger
	n0 := anInteger! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
ne: anInteger
	ne := anInteger! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:02'!
ra
	^ ra! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
ra: aNumber
	ra := aNumber! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:02'!
rk
	^ rk! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
rk: aNumber
	rk := aNumber! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:36'!
ro
	^ ro! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
ro: aNumber
	ro := aNumber! !


!LiljencrantsFant methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
computeSamplesInto: aFloatArray
	| s0 s1 s2 |
	aFloatArray at: 1 put: x1.
	s2 := x1.
	aFloatArray at: 2 put: x2.
	s1 := x2.
	3 to: ne - 1 do: [ :each |
		s0 := a1 * s1 + (a2 * s2).
		aFloatArray at: each put: s0.
		s2 := s1.
		s1 := s0].
	ne to: n0 do: [ :each | aFloatArray at: each put: b1 * (aFloatArray at: each - 1) - c1]! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
d
	| r |
	ra <= 0.0 ifTrue: [^ 1.0].
	r := 1.0 - ro / ra.
	^ 1.0 - (r / (r exp - 1.0))! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/26/1999 22:12'!
example1
	"
	Utilities plot: LiljencrantsFant new example1
	"
	self t0: 1 / 133 * 4 ro: 0.25 rk: 0.25 ra: 0.01 samplingRate: 22025.
	self init.
	^ self samples! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
init
	| d phi cosphi sinphi rphid u theta rho gamma gammapwr |
	d := self d.
	phi := Float pi * (rk + 1.0).
	cosphi := phi cos.
	sinphi := phi sin.
	rphid := ra / ro * phi * d.

	u := self zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
	theta := phi / ne.
	rho := (u * theta) exp.
	a1 := 2.0 * theta cos * rho.
	a2 := 0.0 - (rho * rho).
	x1 := 0.0.
	x2 := rho * theta sin.

	gamma := (-1.0 / (ra * n0)) exp.
	gammapwr := gamma raisedTo: n0 - ne.

	b1 := gamma.
	c1 := (1.0 - gamma) * gammapwr / (1.0 - gammapwr)! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
qu: u phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| expuphi |
	expuphi := (u * phi) exp.
	^ expuphi * ((rphid * (u*u + 1.0) + u) * sinphi - cosphi) + 1.0! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
samples
	| answer |
	answer := FloatArray new: n0.
	self computeSamplesInto: answer.
	^ answer! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
t0: t0 ro: roNumber rk: rkNumber ra: raNumber samplingRate: samplingRate
	| doubleN0 |
	doubleN0 := samplingRate * t0.
	n0 := doubleN0 asInteger.
	ne := (doubleN0 * roNumber) asInteger.
	ro := ne asFloat / n0 asFloat.
	rk := rkNumber.
	ra := raNumber! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/15/1999 01:29'!
t0: t0 tp: tp te: te ta: ta samplingRate: samplingRate
	self t0: t0 ro: te / t0 rk: te - tp / tp ra: ta / t0 samplingRate: samplingRate! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'stephaneducasse 2/3/2006 22:22'!
zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| qzero ua ub qa qb uc qc |
	qzero := self qu: 0 phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.

	qzero > 0
		ifTrue: [ua := 0. ub := 1.
				qa := qzero. qb := self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
				[qb > 0]
					whileTrue: [ua := ub. qa := qb.
								ub := ub * 2. qb := self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]]
		ifFalse: [ua := -1. ub := 0.
				qa := self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid. qb := qzero.
				[qa < 0]
					whileTrue: [ub := ua. qb := qa.
								ua := ua * 2. qa := self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]].
	[ub - ua > Epsilon]
		whileTrue: [uc := ub + ua / 2. qc := self qu: uc phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
					qc > 0 ifTrue: [ua := uc. qa := qc] ifFalse: [ub := uc. qb := qc]].
	^ ub + ua / 2! !

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

LiljencrantsFant class
	instanceVariableNames: ''!

!LiljencrantsFant class methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/3/2006 22:23'!
initialize
	"
	LiljencrantsFant initialize
	"
	Epsilon := 1.0e-04! !
WriteStream subclass: #LimitedWriteStream
	instanceVariableNames: 'limit limitBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!LimitedWriteStream commentStamp: '<historical>' prior: 0!
A LimitedWriteStream is a specialized WriteStream that has a maximum size of the collection it streams over. When this limit is reached a special limitBlock is executed. This can for example be used to "bail out" of lengthy streaming operations before they have finished.  For a simple example take a look at the universal Object printString.

The message SequenceableCollection class streamContents:limitedTo: creates a LimitedWriteStream. In this case it prevents very large (or possibly recursive) object structures to "overdo" their textual representation. !
]style[(323 18 15 54 151)f1,f1LObject printString;,f1,f1LSequenceableCollection class streamContents:limitedTo:;,f1!


!LimitedWriteStream methodsFor: 'accessing' stamp: 'BG 3/13/2004 16:03'!
nextPut: anObject 
	"Ensure that the limit is not exceeded"

 position >= limit ifTrue: [limitBlock value]
    ifFalse: [super nextPut: anObject].
! !


!LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'BG 3/13/2004 13:18'!
nextPutAll: aCollection

	| newEnd |
	collection class == aCollection class ifFalse:
		[^ super nextPutAll: aCollection ].

	newEnd _ position + aCollection size.
	newEnd > limit ifTrue: [
		super nextPutAll: (aCollection copyFrom: 1 to: (limit - position max: 0)).
		^ limitBlock value.
	].
	newEnd > writeLimit ifTrue: [
		self growTo: newEnd + 10
	].

	collection replaceFrom: position+1 to: newEnd  with: aCollection startingAt: 1.
	position _ newEnd.! !

!LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 10/28/2001 12:49'!
pastEndPut: anObject
	collection size >= limit ifTrue: [limitBlock value].  "Exceptional return"
	^ super pastEndPut: anObject! !

!LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 6/20/97 09:07'!
setLimit: sizeLimit limitBlock: aBlock
	"Limit the numer of elements this stream will write..."
	limit _ sizeLimit.
	"Execute this (typically ^ contents) when that limit is exceded"
	limitBlock _ aBlock! !
Object subclass: #LimitingLineStreamWrapper
	instanceVariableNames: 'stream line limitingBlock position'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Collections-Streams'!
!LimitingLineStreamWrapper commentStamp: '<historical>' prior: 0!
I'm a wrapper for a stream optimized for line-by-line access using #nextLine. My instances can be nested.

I read one line ahead. Reading terminates when the stream ends, or if the limitingBlock evaluated with the line answers true. To skip the delimiting line for further reading use #skipThisLine.

Character-based reading (#next) is permitted, too. Send #updatePosition when switching from line-based reading.

See examples at the class side.

--bf 2/19/1999 12:52!


!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:25'!
delimiter: aString
	"Set limitBlock to check for a delimiting string. Be unlimiting if nil"

	self limitingBlock: (aString caseOf: {
		[nil] -> [[:aLine | false]].
		[''] -> [[:aLine | aLine size = 0]]
	} otherwise: [[:aLine | aLine beginsWith: aString]])
! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:08'!
lastLineRead
	"Return line last read. At stream end, this is the boundary line or nil"

	^ line! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 19:16'!
limitingBlock: aBlock
	"The limitingBlock is evaluated with a line to check if this line terminates the stream"

	limitingBlock _ aBlock fixTemps.
	self updatePosition! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 2/19/1999 11:45'!
linesUpToEnd

	| elements ln |
	elements _ OrderedCollection new.
	[(ln _ self nextLine) isNil] whileFalse: [ 
		elements add: ln].
	^elements! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:37'!
next
	"Provide character-based access"

	position isNil ifTrue: [^nil].
	position < line size ifTrue: [^line at: (position _ position + 1)].
	line _ stream nextLine.
	self updatePosition.
	^ Character cr! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:09'!
nextLine

	| thisLine |
	self atEnd ifTrue: [^nil].
	thisLine _ line.
	line _ stream nextLine.
	^thisLine
! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:04'!
peekLine

	self atEnd ifTrue: [^nil].
	^ line! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 16:53'!
skipThisLine

	line _ stream nextLine.
	self updatePosition.
! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 2/19/1999 11:47'!
upToEnd

	| ln |
	^String streamContents: [:strm |
		[(ln _ self nextLine) isNil] whileFalse: [ 
			strm nextPutAll: ln; cr]]! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:37'!
updatePosition
	"Call this before doing character-based access"

	position _ self atEnd ifFalse: [0]! !


!LimitingLineStreamWrapper methodsFor: 'printing' stamp: 'bf 11/24/1998 13:39'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' on '.
	stream printOn: aStream! !


!LimitingLineStreamWrapper methodsFor: 'stream protocol' stamp: 'bf 11/13/1998 17:00'!
close
	^stream close! !


!LimitingLineStreamWrapper methodsFor: 'testing' stamp: 'bf 11/13/1998 16:55'!
atEnd

	^line isNil or: [limitingBlock value: line]! !


!LimitingLineStreamWrapper methodsFor: 'private' stamp: 'bf 11/24/1998 14:30'!
setStream: aStream delimiter: aString

	stream _ aStream.
	line _ stream nextLine.
	self delimiter: aString.	"sets position"
! !

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

LimitingLineStreamWrapper class
	instanceVariableNames: ''!

!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 11:48'!
example1
	"LimitingLineStreamWrapper example1"
	"Separate chunks of text delimited by a special string"
	| inStream msgStream messages |
	inStream _ self exampleStream.
	msgStream _ LimitingLineStreamWrapper on: inStream delimiter: 'From '.
	messages _ OrderedCollection new.
	[inStream atEnd] whileFalse: [
		msgStream skipThisLine.
		messages add: msgStream upToEnd].
	^messages
			! !

!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 12:46'!
example2
	"LimitingLineStreamWrapper example2"
	"Demo nesting wrappers - get header lines from some messages"
	| inStream msgStream headers headerStream |
	inStream _ self exampleStream.
	msgStream _ LimitingLineStreamWrapper on: inStream delimiter: 'From '.
	headers _ OrderedCollection new.
	[inStream atEnd] whileFalse: [
		msgStream skipThisLine. "Skip From"
		headerStream _ LimitingLineStreamWrapper on: msgStream delimiter: ''.
		headers add: headerStream linesUpToEnd.
		[msgStream nextLine isNil] whileFalse. "Skip Body"
	].
	^headers
			! !

!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 12:44'!
exampleStream
	^ReadStream on:
'From me@somewhere
From: me
To: you
Subject: Test

Test

From you@elsewhere
From: you
To: me
Subject: Re: test

okay
'! !


!LimitingLineStreamWrapper class methodsFor: 'instance creation' stamp: 'bf 11/24/1998 14:31'!
on: aStream delimiter: aString

	^self new setStream: aStream delimiter: aString
! !
Path subclass: #Line
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Line commentStamp: '<historical>' prior: 0!
I represent the line segment specified by two points.!


!Line methodsFor: 'accessing'!
beginPoint
	"Answer the first end point of the receiver."

	^self first! !

!Line methodsFor: 'accessing'!
beginPoint: aPoint 
	"Set the first end point of the receiver to be the argument, aPoint. 
	Answer aPoint."

	self at: 1 put: aPoint.
	^aPoint! !

!Line methodsFor: 'accessing'!
endPoint
	"Answer the last end point of the receiver."

	^self last! !

!Line methodsFor: 'accessing'!
endPoint: aPoint 
	"Set the first end point of the receiver to be the argument, aPoint. 
	Answer aPoint."

	self at: 2 put: aPoint.
	^aPoint! !


!Line methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"The form associated with this Path will be displayed, according  
	to one of the sixteen functions of two logical variables (rule), at  
	each point on the Line. Also the source form will be first anded  
	with aForm as a mask. Does not effect the state of the Path."

	collectionOfPoints size < 2 ifTrue: [self error: 'a line must have two points'].
	aDisplayMedium
		drawLine: self form
		from: self beginPoint + aPoint
		to: self endPoint + aPoint
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

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

	| newPath newLine |
	newPath _ aTransformation applyTo: self.
	newLine _ Line new.
	newLine beginPoint: newPath firstPoint.
	newLine endPoint: newPath secondPoint.
	newLine form: self form.
	newLine
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

!Line methodsFor: 'displaying'!
displayOnPort: aPort at: aPoint 
	aPort sourceForm: self form; combinationRule: Form under; fillColor: nil.
	aPort drawFrom: collectionOfPoints first + aPoint
		to: collectionOfPoints last + aPoint! !

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

Line class
	instanceVariableNames: ''!

!Line class methodsFor: 'examples'!
example
	"Designate two places on the screen by clicking any mouse button. A
	straight path with a square black form will be displayed connecting the
	two selected points."

	| aLine aForm |  
	aForm _ Form extent: 20@20.		"make a form one quarter of inch square"
	aForm fillBlack.							"turn it black"
	aLine _ Line new.
	aLine form: aForm.						"use the black form for display"
	aLine beginPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aLine beginPoint.	
	aLine endPoint: Sensor waitButton.
	aLine displayOn: Display.				"display the line"

	"Line example"! !


!Line class methodsFor: 'instance creation'!
from: beginPoint to: endPoint withForm: aForm 
	"Answer an instance of me with end points begingPoint and endPoint; 
	the source form for displaying the line is aForm."

	| newSelf | 
	newSelf _ super new: 2.
	newSelf add: beginPoint.
	newSelf add: endPoint.
	newSelf form: aForm.
	^newSelf! !

!Line class methodsFor: 'instance creation'!
new

	| newSelf | 
	newSelf _ super new: 2.
	newSelf add: 0@0.
	newSelf add: 0@0.
	^newSelf! !
PolygonMorph subclass: #LineMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!LineMorph commentStamp: '<historical>' prior: 0!
This is really only a shell for creating single-segment straight-line Shapes.!


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

LineMorph class
	instanceVariableNames: ''!

!LineMorph class methodsFor: 'instance creation' stamp: 'di 8/20/2000 12:18'!
from: startPoint to: endPoint color: lineColor width: lineWidth

	^ PolygonMorph vertices: {startPoint. endPoint}
			color: Color black borderWidth: lineWidth borderColor: lineColor! !

!LineMorph class methodsFor: 'instance creation' stamp: 'di 8/20/2000 12:16'!
new
	^ self from: 0@0 to: 50@50 color: Color black width: 2! !


!LineMorph class methodsFor: 'new-morph participation' stamp: 'sw 11/13/2001 14:37'!
newStandAlone
	"Answer a suitable instance for use in a parts bin, for example"

	^ self new setNameTo: 'Line'! !


!LineMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'!
descriptionForPartsBin
	^ self partName:	'Line'
		categories:		#('Graphics' 'Basic')
		documentation:	'A straight line.  Shift-click to get handles and move the ends.'! !
Object subclass: #LineSegment
	instanceVariableNames: 'start end'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!
!LineSegment commentStamp: '<historical>' prior: 0!
This class represents a straight line segment between two points

Instance variables:
	start	<Point>	start point of the line
	end		<Point>	end point of the line
!


!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'!
bounds
	"Return the bounds containing the receiver"
	^(start min: end) corner: (start max: end)! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'!
degree
	^1! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 5/23/2001 19:11'!
direction
	^end - start! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'!
end
	"Return the end point"
	^end! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 6/7/2003 00:10'!
end: aPoint
	end := aPoint! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'!
start
	"Return the start point"
	^start! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 6/7/2003 00:10'!
start: aPoint
	start := aPoint! !


!LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/8/2003 00:06'!
bezierClipCurve: aCurve
	^self bezierClipCurve: aCurve epsilon: 1! !

!LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/8/2003 00:19'!
bezierClipCurve: aCurve epsilon: eps
	"Compute the intersection of the receiver (a line) with the given curve using bezier clipping."
	| tMin tMax clip newCurve |
	clip := self bezierClipInterval: aCurve.
	clip ifNil:[^#()]. "no overlap"
	tMin := clip at: 1.
	tMax := clip at: 2.
	newCurve := aCurve curveFrom: tMin to: tMax.
	newCurve length < eps ifTrue:[^Array with: (aCurve valueAt: tMin + tMax * 0.5)].
	(tMin < 0.001 and:[tMax > 0.999]) ifTrue:[
		"Need to split aCurve before proceeding"
		| curve1 curve2 |
		curve1 := aCurve curveFrom: 0.0 to: 0.5.
		curve2 := aCurve curveFrom: 0.5 to: 1.0.
		^(curve1 bezierClipCurve: self epsilon: eps),
			(curve2 bezierClipCurve: self epsilon: eps).
	].
	^newCurve bezierClipCurve: self epsilon: eps.! !

!LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:58'!
bezierClipInterval: aCurve
	"Compute the new bezier clip interval for the argument,
	based on the fat line (the direction aligned bounding box) of the receiver.
	Note: This could be modified so that multiple clip intervals are returned.
	The idea is that for a distance curve like

			x		x
	tMax----	--\-----/---\-------
				x		x
	tMin-------------------------

	all the intersections intervals with tMin/tMax are reported, therefore
	minimizing the iteration count. As it is, the process will slowly iterate
	against tMax and then the curve will be split.
	"
	| nrm tStep pts eps inside vValue vMin vMax tValue tMin tMax 
	last lastV lastT lastInside next nextV nextT nextInside |
	eps := 0.00001.					"distance epsilon"
	nrm := (start y - end y) @ (end x - start x). "normal direction for (end-start)"

	"Map receiver's control point into fat line; compute vMin and vMax"
	vMin := vMax := nil.
	self controlPointsDo:[:pt|
		vValue := (nrm x * pt x) + (nrm y * pt y). "nrm dotProduct: pt."
		vMin == nil	ifTrue:[	vMin := vMax := vValue]
					ifFalse:[vValue < vMin ifTrue:[vMin := vValue].
							vValue > vMax ifTrue:[vMax := vValue]]].
	"Map the argument into fat line; compute tMin, tMax for clip"
	tStep := 1.0 / aCurve degree.
	pts := aCurve controlPoints.
	last := pts at: pts size.
	lastV := (nrm x * last x) + (nrm y * last y). "nrm dotProduct: last."
	lastT := 1.0.
	lastInside := lastV+eps < vMin ifTrue:[-1] ifFalse:[lastV-eps > vMax ifTrue:[1] ifFalse:[0]].

	"Now compute new minimal and maximal clip boundaries"
	inside := false.	"assume we're completely outside"
	tMin := 2.0. tMax := -1.0. 	"clip interval"
	1 to: pts size do:[:i|
		next := pts at: i.
		nextV := (nrm x * next x) + (nrm y * next y). "nrm dotProduct: next."
		false ifTrue:[
			(nextV - vMin / (vMax - vMin)) printString displayAt: 0@ (i-1*20)].
		nextT := i-1 * tStep.
		nextInside := nextV+eps < vMin ifTrue:[-1] ifFalse:[nextV-eps > vMax ifTrue:[1] ifFalse:[0]].
		nextInside = 0 ifTrue:[
			inside := true.
			tValue := nextT.
			tValue < tMin ifTrue:[tMin := tValue].
			tValue > tMax ifTrue:[tMax := tValue].
		].
		lastInside = nextInside ifFalse:["At least one clip boundary"
			inside := true.
			"See if one is below vMin"
			(lastInside + nextInside <= 0) ifTrue:[
				tValue := lastT + ((nextT - lastT) * (vMin - lastV) / (nextV - lastV)).
				tValue < tMin ifTrue:[tMin := tValue].
				tValue > tMax ifTrue:[tMax := tValue].
			].
			"See if one is above vMax"
			(lastInside + nextInside >= 0) ifTrue:[
				tValue := lastT + ((nextT - lastT) * (vMax - lastV) / (nextV - lastV)).
				tValue < tMin ifTrue:[tMin := tValue].
				tValue > tMax ifTrue:[tMax := tValue].
			].
		].
		last := next.
		lastT := nextT.
		lastV := nextV.
		lastInside := nextInside.
	].
	inside
		ifTrue:[^Array with: tMin with: tMax]
		ifFalse:[^nil]! !


!LineSegment methodsFor: 'converting' stamp: 'ar 6/8/2003 04:19'!
asBezier2Points: error
	^Array with: start with: start with: end! !

!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'!
asBezier2Segment
	"Represent the receiver as quadratic bezier segment"
	^Bezier2Segment from: start to: end! !

!LineSegment methodsFor: 'converting' stamp: 'ar 6/8/2003 15:38'!
asBezier2Segments: error
	"Demote a cubic bezier to a set of approximating quadratic beziers."
	| pts |
	pts := self asBezier2Points: error.
	^(1 to: pts size by: 3) collect:[:i| 
		Bezier2Segment from: (pts at: i) via: (pts at: i+1) to: (pts at: i+2)].
! !

!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'!
asIntegerSegment
	"Convert the receiver into integer representation"
	^self species from: start asIntegerPoint to: end asIntegerPoint! !

!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'!
asLineSegment
	"Represent the receiver as a straight line segment"
	^self! !

!LineSegment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:57'!
asTangentSegment
	^LineSegment from: end-start to: end-start! !

!LineSegment methodsFor: 'converting' stamp: 'ar 6/7/2003 00:08'!
reversed
	^self class controlPoints: self controlPoints reversed! !


!LineSegment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:12'!
from: startPoint to: endPoint
	"Initialize the receiver"
	start := startPoint.
	end := endPoint.! !

!LineSegment methodsFor: 'initialize' stamp: 'ar 6/7/2003 00:09'!
initializeFrom: controlPoints
	controlPoints size = 2 ifFalse:[self error:'Wrong number of control points'].
	start := controlPoints at: 1.
	end := controlPoints at: 2.! !


!LineSegment methodsFor: 'printing' stamp: 'ar 11/2/1998 12:13'!
printOn: aStream
	"Print the receiver on aStream"
	aStream 
		nextPutAll: self class name;
		nextPutAll:' from: ';
		print: start;
		nextPutAll: ' to: ';
		print: end;
		space.! !


!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:12'!
hasZeroLength
	"Return true if the receiver has zero length"
	^start = end! !

!LineSegment methodsFor: 'testing' stamp: 'ar 6/8/2003 01:03'!
isArcSegment
	"Answer whether I approximate an arc segment reasonably well"
	| mid v1 v2 d1 d2 center |
	start = end ifTrue:[^false].
	mid := self valueAt: 0.5.
	v1 := (start + mid) * 0.5.
	v2 := (mid + end) * 0.5.
	d1 := mid - start. d1 := d1 y @ d1 x negated.
	d2 := end - mid.  d2 := d2 y @ d2 x negated.

	center := LineSegment
		intersectFrom: v1 with: d1 to: v2 with: d2.

	"Now see if the tangents are 'reasonably close' to the circle"
	d1 := (start - center) normalized dotProduct: self tangentAtStart normalized.
	d1 abs > 0.02 ifTrue:[^false].
	d1 := (end - center) normalized dotProduct: self tangentAtEnd normalized.
	d1 abs > 0.02 ifTrue:[^false].
	d1 := (mid - center) normalized dotProduct: self tangentAtMid normalized.
	d1 abs > 0.02 ifTrue:[^false].

	^true! !

!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:07'!
isBezier2Segment
	"Return true if the receiver is a quadratic bezier segment"
	^false! !

!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:07'!
isLineSegment
	"Return true if the receiver is a line segment"
	^true! !

!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:08'!
isStraight
	"Return true if the receiver represents a straight line"
	^true! !


!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:15'!
asBezier2Curves: err
	^Array with: self! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'!
controlPoints
	^{start. end}! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'!
controlPointsDo: aBlock
	aBlock value: start; value: end! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:48'!
curveFrom: parameter1 to: parameter2
	"Create a new segment like the receiver but starting/ending at the given parametric values"
	| delta |
	delta := end - start.
	^self clone from: delta * parameter1 + start to: delta * parameter2 + start! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:08'!
length
	"Return the length of the receiver"
	^start dist: end! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:08'!
lineSegmentsDo: aBlock
	"Evaluate aBlock with the receiver's line segments"
	aBlock value: start value: end! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'!
lineSegments: steps do: aBlock
	"Evaluate aBlock with the receiver's line segments"
	aBlock value: start value: end! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 5/23/2001 18:27'!
sideOfPoint: aPoint
	"Return the side of the receiver this point is on. The method returns
		-1: if aPoint is left
		 0: if aPoint is on
		+1: if a point is right
	of the receiver."
	| dx dy px py |
	dx := end x - start x.
	dy := end y - start y.
	px := aPoint x - start x.
	py := aPoint y - start y.
	^((dx * py) - (px * dy)) sign
"
	(LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@-50.
	(LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@50.
	(LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@0.
"
! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:54'!
tangentAtMid
	"Return the tangent for the last point"
	^(end - start)! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'!
tangentAt: parameter
	"Return the tangent at the given parametric value along the receiver"
	^end - start! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'!
tangentAtEnd
	"Return the tangent for the last point"
	^(end - start)! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'!
tangentAtStart
	"Return the tangent for the last point"
	^(end - start)! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'!
valueAt: parameter
	"Evaluate the receiver at the given parametric value"
	^start + (end - start * parameter)! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:10'!
valueAtEnd
	"Evaluate the receiver at it's end point (e.g., self valueAtEnd = (self valueAt: 1.0))"
	^end! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:10'!
valueAtStart
	"Evaluate the receiver at it's start point (e.g., self valueAtEnd = (self valueAt: 0.0))"
	^start! !


!LineSegment methodsFor: 'private' stamp: 'ar 6/7/2003 21:00'!
debugDraw
	^self debugDrawAt: 0@0.! !

!LineSegment methodsFor: 'private' stamp: 'ar 6/7/2003 21:00'!
debugDrawAt: offset
	| canvas |
	canvas := Display getCanvas.
	canvas translateBy: offset during:[:aCanvas|
		self lineSegmentsDo:[:p1 :p2|
			aCanvas line: p1 rounded to: p2 rounded width: 1 color: Color black.
		].
	].! !


!LineSegment methodsFor: 'intersection' stamp: 'nk 3/29/2002 22:30'!
intersectionWith: anotherSegment
	"Copied from LineIntersections>>intersectFrom:to:with:to:"
	| det deltaPt alpha beta pt1Dir pt2Dir |
	pt1Dir := end - start.
	pt2Dir := anotherSegment end - anotherSegment start.
	det := (pt1Dir x * pt2Dir y) - (pt1Dir y * pt2Dir x).
	deltaPt := anotherSegment start - start.
	alpha := (deltaPt x * pt2Dir y) - (deltaPt y * pt2Dir x).
	beta := (deltaPt x * pt1Dir y) - (deltaPt y * pt1Dir x).
	det = 0 ifTrue:[^nil]. "no intersection"
	alpha * det < 0 ifTrue:[^nil].
	beta * det < 0 ifTrue:[^nil].
	det > 0 
		ifTrue:[(alpha > det or:[beta > det]) ifTrue:[^nil]]
		ifFalse:[(alpha < det or:[beta < det]) ifTrue:[^nil]].
	"And compute intersection"
	^start + (alpha * pt1Dir / (det@det))! !

!LineSegment methodsFor: 'intersection' stamp: 'nk 12/27/2003 13:00'!
roundTo: quantum
	start := start roundTo: quantum.
	end := end roundTo: quantum.! !

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

LineSegment class
	instanceVariableNames: ''!

!LineSegment class methodsFor: 'instance creation' stamp: 'ar 6/7/2003 00:09'!
controlPoints: anArray
	"Create a new instance of the receiver from the given control points"
	anArray size = 2 ifTrue:[^LineSegment new initializeFrom: anArray].
	anArray size = 3 ifTrue:[^Bezier2Segment new initializeFrom: anArray].
	anArray size = 4 ifTrue:[^Bezier3Segment new initializeFrom: anArray].
	self error:'Unsupported'.! !

!LineSegment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:10'!
from: startPoint to: endPoint
	^self new from: startPoint to: endPoint! !


!LineSegment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 00:49'!
intersectFrom: startPt with: startDir to: endPt with: endDir
	"Compute the intersection of two lines, e.g., compute alpha and beta for
		startPt + (alpha * startDir) = endPt + (beta * endDir).
	Reformulating this yields
		(alpha * startDir) - (beta * endDir) = endPt - startPt.
	or
		(alpha * startDir) + (-beta * endDir) = endPt - startPt.
	or
		(alpha * startDir x) + (-beta * endDir x) = endPt x - startPt x.
		(alpha * startDir y) + (-beta * endDir y) = endPt y - startPt y.
	which is trivial to solve using Cramer's rule. Note that since
	we're really only interested in the intersection point we need only
	one of alpha or beta since the resulting intersection point can be
	computed based on either one."
	| det deltaPt alpha |
	det := (startDir x * endDir y) - (startDir y * endDir x).
	det = 0.0 ifTrue:[^nil]. "There's no solution for it"
	deltaPt := endPt - startPt.
	alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x).
	alpha := alpha / det.
	"And compute intersection"
	^startPt + (alpha * startDir)! !


!LineSegment class methodsFor: 'geometry' stamp: 'nk 8/19/2003 17:17'!
fromPoints: pts
	^self from: pts first to: pts third via: pts second! !

!LineSegment class methodsFor: 'geometry' stamp: 'nk 8/19/2003 17:15'!
from: startPoint to: endPoint via: via
	(startPoint = via or: [ endPoint = via ]) ifTrue: [ ^self new from: startPoint to: endPoint ].
	^Bezier2Segment from: startPoint to: endPoint via: via! !
Path subclass: #LinearFit
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!LinearFit commentStamp: '<historical>' prior: 0!
I represent a piece-wise linear approximation to a set of points in the plane.!


!LinearFit methodsFor: 'displaying' stamp: 'jrm 9/7/1999 22:16'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger
fillColor: aForm
 
	| line |
	line _ Line new.
	line form: self form.
	1 to: self size - 1 do: 
		[:i | 
		line beginPoint: (self at: i).
		line endPoint: (self at: i + 1).
		line displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!LinearFit methodsFor: 'displaying' stamp: 'jrm 9/7/1999 23:00'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox:
clipRect rule: anInteger fillColor: aForm 

	| transformedPath |
	"get the scaled and translated Path."
	transformedPath _ aTransformation applyTo: self.
	transformedPath
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

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

LinearFit class
	instanceVariableNames: ''!

!LinearFit class methodsFor: 'examples'!
example
	"Select points on a Path using the red button. Terminate by selecting
	any other button. Creates a Path from the points and displays it as a
	piece-wise linear approximation." 

	| aLinearFit aForm flag |
	aLinearFit _ LinearFit new.
	aForm _ Form extent: 1 @ 40.
	aForm  fillBlack.
	aLinearFit form: aForm.
	flag _ true.
	[flag] whileTrue:
		[Sensor waitButton.
		 Sensor redButtonPressed
			ifTrue: [aLinearFit add: Sensor waitButton. Sensor waitNoButton.
					aForm displayOn: Display at: aLinearFit last]
			ifFalse: [flag_false]].
	aLinearFit displayOn: Display

	"LinearFit example"! !
TTCFont subclass: #LinedTTCFont
	instanceVariableNames: 'emphasis lineGlyph contourWidth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/7/2004 12:49'!
computeForm: char

	| ttGlyph scale |

	char = Character tab ifTrue: [^ super computeForm: char].

	"char = $U ifTrue: [self doOnlyOnce: [self halt]]."
	scale _ self pixelSize asFloat / (ttcDescription ascender - ttcDescription descender).
	ttGlyph _ ttcDescription at: char.
	^ ttGlyph asFormWithScale: scale ascender: ttcDescription ascender descender: ttcDescription descender fgColor: foregroundColor bgColor: Color transparent depth: self depth replaceColor: false lineGlyph: lineGlyph lingGlyphWidth: contourWidth emphasis: emphasis! !

!LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/6/2004 19:56'!
emphasis

	^ emphasis.
! !

!LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/6/2004 19:18'!
emphasis: code

	emphasis _ code.
! !

!LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/7/2004 11:26'!
lineGlyph: aGlyph

	lineGlyph _ aGlyph.
	contourWidth _ aGlyph calculateWidth.
! !

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

LinedTTCFont class
	instanceVariableNames: ''!

!LinedTTCFont class methodsFor: 'as yet unclassified' stamp: 'yo 5/7/2004 07:32'!
fromTTCFont: aTTCFont emphasis: code

	| inst |
	inst _ self new.
	inst ttcDescription: aTTCFont ttcDescription.
	inst pointSize: aTTCFont pointSize.
	inst recreateCache.
	inst emphasis: (aTTCFont emphasis bitOr: code).
	inst lineGlyph: (aTTCFont ttcDescription at: $_).

	^ inst.
! !
Object subclass: #Link
	instanceVariableNames: 'nextLink'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!Link commentStamp: '<historical>' prior: 0!
An instance of me is a simple record of a pointer to another Link. I am an abstract class; my concrete subclasses, for example, Process, can be stored in a LinkedList structure.!


!Link methodsFor: 'accessing'!
nextLink
	"Answer the link to which the receiver points."

	^nextLink! !

!Link methodsFor: 'accessing'!
nextLink: aLink 
	"Store the argument, aLink, as the link to which the receiver refers. 
	Answer aLink."

	^nextLink _ aLink! !

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

Link class
	instanceVariableNames: ''!

!Link class methodsFor: 'instance creation' stamp: 'apb 10/3/2000 15:55'!
nextLink: aLink 
	"Answer an instance of me referring to the argument, aLink."

	^self new nextLink: aLink; yourself! !
SequenceableCollection subclass: #LinkedList
	instanceVariableNames: 'firstLink lastLink'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!LinkedList commentStamp: '<historical>' prior: 0!
I represent a collection of links, which are containers for other objects. Using the message sequence addFirst:/removeLast causes the receiver to behave as a stack; using addLast:/removeFirst causes the receiver to behave as a queue.!


!LinkedList methodsFor: 'accessing' stamp: 'ajh 8/6/2002 15:46'!
at: index

	| i |
	i _ 0.
	self do: [:link |
		(i _ i + 1) = index ifTrue: [^ link]].
	^ self errorSubscriptBounds: index! !

!LinkedList methodsFor: 'accessing'!
first
	"Answer the first link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^firstLink! !

!LinkedList methodsFor: 'accessing'!
last
	"Answer the last link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^lastLink! !


!LinkedList methodsFor: 'adding'!
add: aLink 
	"Add aLink to the end of the receiver's list. Answer aLink."

	^self addLast: aLink! !

!LinkedList methodsFor: 'adding' stamp: 'md 10/13/2004 13:50'!
add: link after: otherLink

	"Add otherLink  after link in the list. Answer aLink."

	| savedLink |

	savedLink := otherLink nextLink.
	otherLink nextLink: link.
	link nextLink:  savedLink.
	^link.! !

!LinkedList methodsFor: 'adding' stamp: 'ajh 8/22/2002 14:17'!
add: link before: otherLink

	| aLink |
	firstLink == otherLink ifTrue: [^ self addFirst: link].
	aLink _ firstLink.
	[aLink == nil] whileFalse: [
		aLink nextLink == otherLink ifTrue: [
			link nextLink: aLink nextLink.
			aLink nextLink: link.
			^ link
		].
		 aLink _ aLink nextLink.
	].
	^ self errorNotFound: otherLink! !

!LinkedList methodsFor: 'adding'!
addFirst: aLink 
	"Add aLink to the beginning of the receiver's list. Answer aLink."

	self isEmpty ifTrue: [lastLink _ aLink].
	aLink nextLink: firstLink.
	firstLink _ aLink.
	^aLink! !

!LinkedList methodsFor: 'adding'!
addLast: aLink 
	"Add aLink to the end of the receiver's list. Answer aLink."

	self isEmpty
		ifTrue: [firstLink _ aLink]
		ifFalse: [lastLink nextLink: aLink].
	lastLink _ aLink.
	^aLink! !


!LinkedList methodsFor: 'enumerating'!
do: aBlock

	| aLink |
	aLink _ firstLink.
	[aLink == nil] whileFalse:
		[aBlock value: aLink.
		 aLink _ aLink nextLink]! !

!LinkedList methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 16:39'!
species

	^ Array! !


!LinkedList methodsFor: 'removing'!
remove: aLink ifAbsent: aBlock  
	"Remove aLink from the receiver. If it is not there, answer the result of
	evaluating aBlock."

	| tempLink |
	aLink == firstLink
		ifTrue: [firstLink _ aLink nextLink.
				aLink == lastLink
					ifTrue: [lastLink _ nil]]
		ifFalse: [tempLink _ firstLink.
				[tempLink == nil ifTrue: [^aBlock value].
				 tempLink nextLink == aLink]
					whileFalse: [tempLink _ tempLink nextLink].
				tempLink nextLink: aLink nextLink.
				aLink == lastLink
					ifTrue: [lastLink _ tempLink]].
	aLink nextLink: nil.
	^aLink! !

!LinkedList methodsFor: 'removing'!
removeFirst
	"Remove the first element and answer it. If the receiver is empty, create 
	an error notification."

	| oldLink |
	self emptyCheck.
	oldLink _ firstLink.
	firstLink == lastLink
		ifTrue: [firstLink _ nil. lastLink _ nil]
		ifFalse: [firstLink _ oldLink nextLink].
	oldLink nextLink: nil.
	^oldLink! !

!LinkedList methodsFor: 'removing'!
removeLast
	"Remove the receiver's last element and answer it. If the receiver is 
	empty, create an error notification."

	| oldLink aLink |
	self emptyCheck.
	oldLink _ lastLink.
	firstLink == lastLink
		ifTrue: [firstLink _ nil. lastLink _ nil]
		ifFalse: [aLink _ firstLink.
				[aLink nextLink == oldLink] whileFalse:
					[aLink _ aLink nextLink].
				 aLink nextLink: nil.
				 lastLink _ aLink].
	oldLink nextLink: nil.
	^oldLink! !


!LinkedList methodsFor: 'testing'!
isEmpty

	^firstLink == nil! !
ClassTestCase subclass: #LinkedListTest
	instanceVariableNames: 'nextLink n list link1 link2 link3 link4'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Sequenceable'!
!LinkedListTest commentStamp: 'mk 8/3/2005 11:55' prior: 0!
A set of test cases which thoroughly test functionality of the LinkedList class.!


!LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:47'!
n
	^n! !

!LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:46'!
nextLink
	^nextLink! !

!LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:46'!
nextLink: aLink
	nextLink := aLink! !

!LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:47'!
n: number
	n := number.
	! !


!LinkedListTest methodsFor: 'running' stamp: 'zz 12/7/2005 19:07'!
setUp
	super setUp.
	list := LinkedList new.
	link1 := Link new.
	link2 := Link new.
	link3 := Link new.
	link4 := Link new! !

!LinkedListTest methodsFor: 'running' stamp: 'zz 12/7/2005 19:08'!
tearDown
	list := nil.
	link1 := nil.
	link2 := nil.
	link3 := nil.
	link4 := nil.
	^ super tearDown! !


!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'!
test01add
	self assert: list isEmpty.
	list add: link1.
	self assert: list size = 1.
	self assert: list first = link1.
	
	list add: link2.
	self assert: list size = 2.
	self assert: list first = link1.
	self assert: list second = link2.
	
	list add: link3.
	self assert: list size = 3.
	self assert: list first = link1.
	self assert: list second = link2.
	self assert: list third = link3.
	
	list add: link4.
	self assert: list size = 4.
	self assert: list first = link1.
	self assert: list second = link2.
	self assert: list third = link3.
	self assert: list fourth = link4! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'!
test02addLast
	self assert: list isEmpty.
	
	list addLast: link1.
	self assert: list size = 1.
	self assert: list first = link1.
	
	list addLast: link2.
	self assert: list size = 2.
	self assert: list first = link1.
	self assert: list second = link2.
	
	list addLast: link3.
	self assert: list size = 3.
	self assert: list first = link1.
	self assert: list second = link2.
	self assert: list third = link3.
	
	list addLast: link4.
	self assert: list size = 4.
	self assert: list first = link1.
	self assert: list second = link2.
	self assert: list third = link3.
	self assert: list fourth = link4! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'!
test03addFirst
	self assert: list isEmpty.
	
	list addFirst: link1.
	self assert: list size = 1.
	self assert: list first = link1.
	
	list addFirst: link2.
	self assert: list size = 2.
	self assert: list first = link2.
	self assert: list second = link1.
	
	list addFirst: link3.
	self assert: list size = 3.
	self assert: list first = link3.
	self assert: list second = link2.
	self assert: list third = link1.
	
	list addFirst: link4.
	self assert: list size = 4.
	self assert: list first = link4.
	self assert: list second = link3.
	self assert: list third = link2.
	self assert: list fourth = link1! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'!
test04addBefore
	self assert: list isEmpty.
	
	list add: link1.
	self assert: list size = 1.
	self assert: list first == link1.
	
	list add: link2 before: link1.
	self assert: list size = 2.
	self assert: list first == link2.
	self assert: list second == link1.
	
	list add: link3 before: link1.
	self assert: list size = 3.
	self assert: list first == link2.
	self assert: list second == link3.
	self assert: list third == link1.
	
	list add: link4 before: link1.
	self assert: list size = 4.
	self assert: list first == link2.
	self assert: list second == link3.
	self assert: list third == link4.
	self assert: list fourth == link1! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'!
test05addBefore
	self assert: list isEmpty.
	
	list add: link1.
	self assert: list size = 1.
	self assert: list first == link1.
	
	list add: link2 before: link1.
	self assert: list size = 2.
	self assert: list first == link2.
	self assert: list second == link1.
	
	list add: link3 before: link2.
	self assert: list size = 3.
	self assert: list first == link3.
	self assert: list second == link2.
	self assert: list third == link1.
	
	list add: link4 before: link3.
	self assert: list size = 4.
	self assert: list first == link4.
	self assert: list second == link3.
	self assert: list third == link2.
	self assert: list fourth == link1! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'!
test06addAfter
	self assert: list isEmpty.
	
	list add: link1.
	self assert: list size = 1.
	self assert: list first == link1.
	
	list add: link2 after: link1.
	self assert: list size = 2.
	self assert: list first == link1.
	self assert: list second == link2.
	
	list add: link3 after: link2.
	self assert: list size = 3.
	self assert: list first == link1.
	self assert: list second == link2.
	self assert: list third == link3.
	
	list add: link4 after: link3.
	self assert: list size = 4.
	self assert: list first == link1.
	self assert: list second == link2.
	self assert: list third == link3.
	self assert: list fourth == link4! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'!
test07addAfter
	self assert: list isEmpty.
	
	list add: link1.
	self assert: list size = 1.
	self assert: list first == link1.
	
	list add: link2 after: link1.
	self assert: list size = 2.
	self assert: list first == link1.
	self assert: list second == link2.
	
	list add: link3 after: link1.
	self assert: list size = 3.
	self assert: list first == link1.
	self assert: list second == link3.
	self assert: list third == link2.
	
	list add: link4 after: link1.
	self assert: list size = 4.
	self assert: list first == link1.
	self assert: list second == link4.
	self assert: list third == link3.
	self assert: list fourth == link2! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:09'!
test08addAfter
	| l first |
	l := LinkedList new.
	first := self class new n: 1.
	
	l add: first.
	l add: (self class new n: 3).

	self assert: (l collect:[:e | e n]) asArray  = #(1 3).
	
	l add: (self class new n: 2) after: first.

	self assert: (l collect:[:e | e n]) asArray  = #(1 2 3).! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:09'!
test09addAfter
	| l last |
	l := LinkedList new.
	last := self class new n: 2.
	l add: (self class new n: 1).
	l add: last.
	
	self assert: (l collect:[:e | e n]) asArray  = #(1 2).
	 
	l add: (self class new n: 3) after: last.

	self assert: (l collect:[:e | e n]) asArray  = #(1 2 3).! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'!
test10removeFirst
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.
	
	self assert: list size = 4.
	self assert: list first == link1.
	self assert: list second == link2.
	self assert: list third == link3.
	self assert: list fourth == link4.
	
	list removeFirst.
	self assert: list size = 3.
	self assert: list first == link2.
	self assert: list second == link3.
	self assert: list third == link4.
	
	list removeFirst.
	self assert: list size = 2.
	self assert: list first == link3.
	self assert: list second == link4.
	
	list removeFirst.
	self assert: list size = 1.
	self assert: list first == link4.
	
	list removeFirst.
	self assert: list isEmpty! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'!
test11removeLast
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.
	
	self assert: list size = 4.
	self assert: list first == link1.
	self assert: list second == link2.
	self assert: list third == link3.
	self assert: list fourth == link4.
	
	list removeLast.
	self assert: list size = 3.
	self assert: list first == link1.
	self assert: list second == link2.
	self assert: list third == link3.
	
	list removeLast.
	self assert: list size = 2.
	self assert: list first == link1.
	self assert: list second == link2.
	
	list removeLast.
	self assert: list size = 1.
	self assert: list first == link1.
	
	list removeFirst.
	self assert: list isEmpty! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:11'!
test12remove
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.
	
	self assert: list size = 4.
	self assert: list first == link1.
	self assert: list second == link2.
	self assert: list third == link3.
	self assert: list fourth == link4.
	
	list remove: link3.
	self assert: list size = 3.
	self assert: list first == link1.
	self assert: list second == link2.
	self assert: list third == link4.
	
	list remove: link2.
	self assert: list size = 2.
	self assert: list first == link1.
	self assert: list second == link4.
	
	list remove: link1.
	self assert: list size = 1.
	self assert: list first == link4.
	
	list remove: link4.
	self assert: list isEmpty! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:12'!
test13remove
	list add: link1.
	list add: link2.
	list add: link3.
	list add: link4.
	
	self assert: list size = 4.
	self assert: list first == link1.
	self assert: list second == link2.
	self assert: list third == link3.
	self assert: list fourth == link4.
	
	list remove: link1.
	self assert: list size = 3.
	self assert: list first == link2.
	self assert: list second == link3.
	self assert: list third == link4.
	
	list remove: link4.
	self assert: list size = 2.
	self assert: list first == link2.
	self assert: list second == link3.
	
	list remove: link2.
	self assert: list size = 1.
	self assert: list first == link3.
	
	list remove: link3.
	self assert: list isEmpty! !

!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:13'!
test14removeIfAbsent
	list add: link1.
	
	self assert: list size = 1.
	self assert: list first == link1.
	
	list remove: link1.
	self assert: list isEmpty.
	
	[list remove: link1]
		on: Error
		do: [^ self].
		
	"The execution should not get here. If yes, something went wrong."
	self assert: false! !

!LinkedListTest methodsFor: 'testing' stamp: 'zz 12/7/2005 19:08'!
test22addAll
	| link5 link6 link7 link8 listToBeAdded |
	link5 := Link new.
	link6 := Link new.
	link7 := Link new.
	link8 := Link new.
	
	list
		add: link1;
		add: link2;
		add: link3;
		add: link4.
		
	listToBeAdded := LinkedList new.
	listToBeAdded
		add: link5;
		add: link6;
		add: link7;
		add: link8.
		
	list addAll: listToBeAdded.
	
	self should: [(list at: 1) == link1].
	self should: [(list at: 2) == link2].
	self should: [(list at: 3) == link3].
	self should: [(list at: 4) == link4].
	self should: [(list at: 5) == link5].
	self should: [(list at: 6) == link6].
	self should: [(list at: 7) == link7].
	self should: [(list at: 8) == link8].! !


!LinkedListTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:20'!
testAddAfter

	| l first |
	l := LinkedList new.
	first := self class new n: 1.
	
	l add: first.
	l add: (self class new n: 3).
	self assert: (l collect:[:e | e n]) asArray  = #(1 3).
	l add: (self class new n: 2) after: first.
	self assert: (l collect:[:e | e n]) asArray  = #(1 2 3).! !

!LinkedListTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:20'!
testAddAfterLast

	| l last |
	l := LinkedList new.
	last := self class new n: 2.
	l add: (self class new n: 1).
	l add: last.
	self assert: (l collect:[:e | e n]) asArray  = #(1 2). 
	l add: (self class new n: 3) after: last.
	self assert: (l collect:[:e | e n]) asArray  = #(1 2 3).! !
PolygonMorph subclass: #LipsMorph
	instanceVariableNames: 'newVertices newScale'
	classVariableNames: 'PhoneticArticulations'
	poolDictionaries: ''
	category: 'Speech-Gestures'!

!LipsMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
verticesString
	| stream first |
	stream := WriteStream with: ''.
	stream nextPut: ${.
	first := true.
	vertices do: [ :each |
		first ifFalse: [stream nextPutAll: '. '].
		stream print: (each - self position) rounded.
		first := false].
	stream nextPut: $}.
	^ stream contents! !


!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 23:17'!
articulate: aPhoneme
	self newVerticesCentered: (PhoneticArticulations at: aPhoneme ifAbsent: [^ self]) scaled: 0.5! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/24/1999 01:13'!
grin
	self newVerticesCentered: {17@5. 30@7. 33@12. 16@14. 2@10. 5@2}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/24/1999 00:11'!
hideTongue
	self submorphs do: [ :each | each delete]! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:14'!
horror
	self newVerticesCentered: {21@3. 37@5. 36@19. 19@19. 3@19. 5@4}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:15'!
neutral
	self newVerticesCentered: {13@1. 22@4. 12@6. 1@4}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:34'!
newVerticesCentered: anArray
	self newVerticesCentered: anArray scaled: 0.5! !

!LipsMorph methodsFor: 'actions' stamp: 'stephaneducasse 2/3/2006 22:22'!
newVerticesCentered: anArray scaled: aNumber
	newVertices := anArray.
	newScale := aNumber! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 17:32'!
openness: amount
	self newVerticesCentered: {40@-3. 74@8. 59@ (21 * amount). 38@ (20 * amount). 22@ (21 * amount). 3@8}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:11'!
sad
	self newVerticesCentered: {26@4. 50@10. 41@4. 27@2. 14@3. 1@10}! !

!LipsMorph methodsFor: 'actions' stamp: 'stephaneducasse 2/3/2006 22:22'!
showTongue
	| tongue |
	self hideTongue.
	tongue := CurveMorph vertices: {10@2. 21@5. 16@23. 10@27. 5@23. 2@4} color: Color red borderWidth: 0 borderColor: Color black.
	tongue position: self center - (10 @ 0).
	self addMorphFront: tongue! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:12'!
smile
	self newVerticesCentered: {26@11. 43@7. 51@2. 44@12. 26@19. 8@14. 2@4. 12@9}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:34'!
surprise
	self newVerticesCentered:  {22@3. 38@7. 37@21. 20@26. 4@21. 6@6}! !

!LipsMorph methodsFor: 'actions' stamp: 'stephaneducasse 2/3/2006 22:22'!
updateShape
	| center median |
	newVertices isNil ifTrue: [^ self].
	median := 0 @ 0.
	newVertices do: [ :each | median := median + each].
	median := median / newVertices size.
	center := self center.
	self setVertices: (newVertices collect: [ :each | (each - median) * newScale + median]).
	self position: self position - self center + center.
	newVertices := nil! !


!LipsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color black! !

!LipsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

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

!LipsMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self beSmoothCurve.
	vertices := {11 @ 3. 35 @ 1. 60 @ 5. 67 @ 17. 34 @ 24. 3 @ 17}.
	
	closed := true.
	self neutral; updateShape! !

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

LipsMorph class
	instanceVariableNames: ''!

!LipsMorph class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/3/2006 22:23'!
initialize
	"
	LipsMorph initialize
	"
	| o u a e i m n p t s |
	a := {22@2. 39@4. 45@16. 23@23. 2@15. 9@4}.
	e := {23@2. 41@3. 45@15. 21@19. 2@14. 6@3}.
	i := {21@2. 40@4. 45@14. 23@16. 2@13. 8@4}.
	o := {18@1. 31@5. 31@20. 16@24. 3@19. 5@5}.
	u := {14@1. 23@6. 22@16. 11@20. 2@14. 3@4}.
	m := {17@2. 31@2. 27@4. 15@3. 2@4. 6@2}.
	n := {20@3. 33@2. 39@8. 19@9. 2@8. 7@2}.
	p := {7@1. 16@3. 12@5. 6@6. 1@4}.
	t := {14@2. 29@3. 21@7. 12@8. 1@3}.
	s := {19@2. 32@4. 35@10. 18@13. 2@10. 9@3}.
	PhoneticArticulations := Dictionary new.
	"Default"
	PhonemeSet arpabet do: [ :each | PhoneticArticulations at: each put: p].
	"Vowels"
	PhonemeSet arpabet do: [ :each |
		each name first = $a ifTrue: [PhoneticArticulations at: each put: a].
		each name first = $e ifTrue: [PhoneticArticulations at: each put: e].
		each name first = $i ifTrue: [PhoneticArticulations at: each put: i].
		each name first = $o ifTrue: [PhoneticArticulations at: each put: o].
		each name first = $u ifTrue: [PhoneticArticulations at: each put: u].
		each name first = $w ifTrue: [PhoneticArticulations at: each put: u]].
	"Particulars"
	PhoneticArticulations
		at: (PhonemeSet arpabet at: 'm') put: m;
		at: (PhonemeSet arpabet at: 'n') put: n;
		at: (PhonemeSet arpabet at: 't') put: t;
		at: (PhonemeSet arpabet at: 's') put: s;
		at: (PhonemeSet arpabet at: 'sh') put: s;
		at: (PhonemeSet arpabet at: 'sh') put: s;
		at: (PhonemeSet arpabet at: 'zh') put: s;
		at: (PhonemeSet arpabet at: 'th') put: s;
		at: (PhonemeSet arpabet at: 'jh') put: s;
		at: (PhonemeSet arpabet at: 'dh') put: s;
		at: (PhonemeSet arpabet at: 'd') put: s;
		at: (PhonemeSet arpabet at: 'z') put: s! !
PluggableListMorph subclass: #ListComponent
	instanceVariableNames: 'selectedItem setSelectionSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!ListComponent methodsFor: 'components' stamp: 'gm 2/27/2003 23:19'!
initFromPinSpecs
	| ioPin |
	getListSelector := pinSpecs first modelReadSelector.
	ioPin := pinSpecs second.
	getIndexSelector := ioPin isInput 
		ifTrue: [ioPin modelReadSelector]
		ifFalse: [nil].
	setIndexSelector := ioPin isOutput 
				ifTrue: [ioPin modelWriteSelector]
				ifFalse: [nil].
	setSelectionSelector := pinSpecs third modelWriteSelector! !

!ListComponent methodsFor: 'components' stamp: 'di 5/1/1998 13:38'!
initPinSpecs 
	pinSpecs _ Array
		with: (PinSpec new pinName: 'list' direction: #input
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: getListSelector modelWriteSelector: nil
				defaultValue: #(one two three) pinLoc: 1.5)
		with: (PinSpec new pinName: 'index' direction: #inputOutput
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: getIndexSelector modelWriteSelector: setIndexSelector
				defaultValue: 0 pinLoc: 2.5)
		with: (PinSpec new pinName: 'selectedItem' direction: #output
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: nil modelWriteSelector: setSelectionSelector
				defaultValue: nil pinLoc: 3.5)! !


!ListComponent methodsFor: 'initialization' stamp: 'di 5/6/1998 11:09'!
list: listOfItems
	super list: listOfItems.
	self selectionIndex: 0.
	selectedItem _ nil.
	setSelectionSelector ifNotNil:
		[model perform: setSelectionSelector with: selectedItem]! !


!ListComponent methodsFor: 'model access' stamp: 'ls 5/17/2001 23:07'!
changeModelSelection: anInteger
	"Change the model's selected item index to be anInteger."

	setIndexSelector
		ifNil: 	["If model is not hooked up to index, then we won't get
					an update, so have to do it locally."
				self selectionIndex: anInteger]
		ifNotNil: [model perform: setIndexSelector with: anInteger].
	selectedItem _ anInteger = 0 ifTrue: [nil] ifFalse: [self getListItem: anInteger].
	setSelectionSelector ifNotNil:
		[model perform: setSelectionSelector with: selectedItem]! !
ScrollController subclass: #ListController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!ListController commentStamp: '<historical>' prior: 0!
I am a kind of ScrollController that assumes that the view is a kind of ListView. Therefore, scrolling means moving the items in a textual list (menu) up or down. In addition, I provide the red button activity of determining when the red button is selecting an item in the list.!


!ListController methodsFor: 'control defaults' stamp: 'bf 4/14/1999 12:41'!
controlActivity
	self scrollByKeyboard ifTrue: [^self].
	self processKeyboard.
	super controlActivity.
! !


!ListController methodsFor: 'marker adjustment'!
computeMarkerRegion 
	"Refer to the comment in ScrollController|computeMarkerRegion."

	| viewList |
	viewList _ view list.
	viewList compositionRectangle height = 0
		ifTrue: [^ 0@0 extent: Preferences scrollBarWidth@scrollBar inside height].
	^ 0@0 extent: Preferences scrollBarWidth@
			((viewList clippingRectangle height asFloat /
						viewList compositionRectangle height *
							scrollBar inside height)
					rounded min: scrollBar inside height)! !

!ListController methodsFor: 'marker adjustment'!
markerDelta

	| viewList |
	viewList _ view list.
	viewList compositionRectangle height == 0 ifTrue: [
		^ (marker top - scrollBar inside top) - scrollBar inside height
	].
	^ (marker top - scrollBar inside top) -
		((viewList clippingRectangle top -
				viewList compositionRectangle top) asFloat /
			viewList compositionRectangle height asFloat *
			scrollBar inside height asFloat) rounded
! !


!ListController methodsFor: 'menu messages' stamp: 'acg 9/18/1999 14:09'!
processKeyboard
	"Derived from a Martin Pammer submission, 02/98"

     | keyEvent oldSelection nextSelection max min howMany |
	sensor keyboardPressed ifFalse: [^ self].

     keyEvent := sensor keyboard asciiValue.
     oldSelection := view selection.
     nextSelection := oldSelection.
     max := view maximumSelection.
     min := view minimumSelection.
     howMany := view clippingBox height // view list lineGrid.

     keyEvent == 31 ifTrue:
		["down-arrow; move down one, wrapping to top if needed"
		nextSelection := oldSelection + 1.
		nextSelection > max ifTrue: [nextSelection _ 1]].

     keyEvent == 30 ifTrue:
		["up arrow; move up one, wrapping to bottom if needed"
		nextSelection := oldSelection - 1.
		nextSelection < 1 ifTrue: [nextSelection _ max]].

     keyEvent == 1  ifTrue: [nextSelection := 1].  "home"
     keyEvent == 4  ifTrue: [nextSelection := max].   "end"
     keyEvent == 11 ifTrue: [nextSelection := min max: (oldSelection -
howMany)].  "page up"
     keyEvent == 12  ifTrue: [nextSelection := (oldSelection + howMany)
min: max].  "page down"
     nextSelection = oldSelection  ifFalse:
		[model okToChange
			ifTrue:
				[self changeModelSelection: nextSelection.
				self moveMarker]]
			! !


!ListController methodsFor: 'scrolling'!
scrollAmount 
	"Refer to the comment in ScrollController|scrollAmount."

	^sensor cursorPoint y - scrollBar inside top! !

!ListController methodsFor: 'scrolling'!
scrollView: anInteger 
	"Scroll the view and highlight the selection if it just came into view"
	| wasClipped |
	wasClipped _ view isSelectionBoxClipped.
	(view scrollBy: anInteger)
		ifTrue: [view isSelectionBoxClipped ifFalse:
					[wasClipped ifTrue:  "Selection came into view"
						[view displaySelectionBox]].
				^ true]
		ifFalse: [^ false]! !

!ListController methodsFor: 'scrolling'!
viewDelta 
	"Refer to the comment in ScrollController|viewDelta."

	| viewList |
	viewList _ view list.
	^(viewList clippingRectangle top -
			viewList compositionRectangle top -
			((marker top - scrollBar inside top) asFloat /
				scrollBar inside height asFloat *
				viewList compositionRectangle height asFloat))
		roundTo: viewList lineGrid! !


!ListController methodsFor: 'selecting' stamp: 'tk 4/1/98 10:33'!
redButtonActivity
	| noSelectionMovement oldSelection selection nextSelection pt scrollFlag firstTime |
	noSelectionMovement _ true.
	scrollFlag _ false.
	oldSelection _ view selection.
	firstTime _ true.
	[sensor redButtonPressed | firstTime]
		whileTrue: 
			[selection _ view findSelection: (pt _ sensor cursorPoint).
			firstTime _ false.
			selection == nil ifTrue:  "Maybe out of box - check for auto-scroll"
					[pt y < view insetDisplayBox top ifTrue:
						[self scrollView: view list lineGrid.
						scrollFlag _ true.
						selection _ view firstShown].
					pt y > view insetDisplayBox bottom ifTrue:
						[self scrollView: view list lineGrid negated.
						scrollFlag _ true.
						selection _ view lastShown]].
			selection == nil ifFalse:
					[view moveSelectionBox: (nextSelection _ selection).
					nextSelection ~= oldSelection
						ifTrue: [noSelectionMovement _ false]]].
	nextSelection ~~ nil & (nextSelection = oldSelection
			ifTrue: [noSelectionMovement]
			ifFalse: [true]) ifTrue: [self changeModelSelection: nextSelection].
	scrollFlag ifTrue: [self moveMarker]! !


!ListController methodsFor: 'private'!
changeModelSelection: anInteger
	model toggleListIndex: anInteger! !
Object subclass: #ListItemWrapper
	instanceVariableNames: 'item model'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!
!ListItemWrapper commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:13'!
acceptDroppingObject: anotherItem

	^item acceptDroppingObject: anotherItem! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:25'!
canBeDragged

	^true! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:24'!
handlesMouseOver: evt

	^false! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:15'!
hasEquivalentIn: aCollection

	aCollection detect: [ :each | 
		each withoutListWrapper = item withoutListWrapper
	] ifNone: [^false].
	^true! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 4/4/1999 17:58'!
sendSettingMessageTo: aModel

	aModel 
		perform: (self settingSelector ifNil: [^self])
		with: self withoutListWrapper
! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 21:31'!
settingSelector

	^nil! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:32'!
wantsDroppedObject: anotherItem

	^false! !


!ListItemWrapper methodsFor: 'converting' stamp: 'RAA 3/30/1999 18:17'!
asString

	^item asString! !

!ListItemWrapper methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'!
withoutListWrapper

	^item withoutListWrapper! !


!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 7/21/2000 10:59'!
balloonText

	^nil! !

!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/31/1999 16:32'!
contents

	^Array new! !

!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 4/1/1999 20:09'!
hasContents

	^self contents isEmpty not! !

!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 8/3/1999 09:40'!
highlightingColor

	^Color red! !

!ListItemWrapper methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:22'!
icon
	"Answer a form to be used as icon"
	^ nil! !

!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 4/2/1999 15:14'!
preferredColor

	^nil! !

!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/30/1999 18:27'!
setItem: anObject

	item _ anObject! !

!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/31/1999 16:44'!
setItem: anObject model: aModel

	item _ anObject.
	model _ aModel.! !

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

ListItemWrapper class
	instanceVariableNames: ''!

!ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:28'!
with: anObject

	^self new setItem: anObject! !

!ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:44'!
with: anObject model: aModel

	^self new setItem: anObject model: aModel! !
Paragraph subclass: #ListParagraph
	instanceVariableNames: ''
	classVariableNames: 'ListStyle'
	poolDictionaries: ''
	category: 'ST80-Support'!
!ListParagraph commentStamp: '<historical>' prior: 0!
I represent a special type of Paragraph that is used in the list panes of a browser.  I  avoid all the composition done by more general Paragraphs, because I know the structure of my Text.!


!ListParagraph methodsFor: 'composition'!
composeAll
	"No composition is necessary once the ListParagraph is created."
	
	lastLine isNil ifTrue: [lastLine _ 0].	
		"Because composeAll is called once in the process of creating the ListParagraph."
	^compositionRectangle width! !


!ListParagraph methodsFor: 'private'!
trimLinesTo: lastLineInteger
	"Since ListParagraphs are not designed to be changed, we can cut back the
		lines field to lastLineInteger."
	lastLine _ lastLineInteger.
	lines _ lines copyFrom: 1 to: lastLine! !

!ListParagraph methodsFor: 'private' stamp: 'di 7/13/97 16:56'!
withArray: anArray 
	"Modifies self to contain the list of strings in anArray"
	| startOfLine endOfLine lineIndex aString |
	lines _ Array new: 20.
	lastLine _ 0.
	startOfLine _ 1.
	endOfLine _ 1.
	lineIndex _ 0.
	anArray do: 
		[:item | 
		endOfLine _ startOfLine + item size.		"this computation allows for a cr after each line..."
												"...but later we will adjust for no cr after last line"
		lineIndex _ lineIndex + 1.
		self lineAt: lineIndex put:
			((TextLineInterval start: startOfLine stop: endOfLine
				internalSpaces: 0 paddingWidth: 0)
				lineHeight: textStyle lineGrid baseline: textStyle baseline).
		startOfLine _ endOfLine + 1].
	endOfLine _ endOfLine - 1.		"endOfLine is now the total size of the text"
	self trimLinesTo: lineIndex.
	aString _ String new: endOfLine.
	anArray with: lines do: 
		[:item :interval | 
		aString
			replaceFrom: interval first
			to: interval last - 1
			with: item asString
			startingAt: 1.
		interval last <= endOfLine ifTrue: [aString at: interval last put: Character cr]].
	lineIndex > 0 ifTrue: [(lines at: lineIndex) stop: endOfLine].	"adjust for no cr after last line"
	self text: aString asText.
	anArray with: lines do: 
		[:item :interval |  item isText ifTrue:
			[text replaceFrom: interval first to: interval last - 1 with: item]].
	self updateCompositionHeight! !

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

ListParagraph class
	instanceVariableNames: ''!

!ListParagraph class methodsFor: 'initialization' stamp: 'nk 9/1/2004 10:27'!
initialize 
	"ListParagraph initialize"
	| aFont |
	"Allow different line spacing for lists"
	aFont _ Preferences standardListFont.
	ListStyle _ TextStyle fontArray: { aFont }.
	ListStyle gridForFont: 1 withLead: 1! !


!ListParagraph class methodsFor: 'instance creation' stamp: 'jm 9/20/1998 17:10'!
withArray: anArray style: aTextStyleOrNil
	"Convert an array of strings into a ListParagraph using the given TextStyle."

	aTextStyleOrNil
		ifNil: [^ (super withText: Text new style: ListStyle) withArray: anArray]
		ifNotNil: [^ (super withText: Text new style: aTextStyleOrNil) withArray: anArray].
! !


!ListParagraph class methodsFor: 'style' stamp: 'sw 12/10/1999 10:43'!
standardListStyle
	^ ListStyle! !
WidgetStub subclass: #ListStub
	instanceVariableNames: 'list index'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!ListStub methodsFor: 'events' stamp: 'cwp 4/22/2005 22:35'!
eventAccessors
	^ #(list getIndex setIndex getSelected setSelected menu keyPress autoDeselect)! !

!ListStub methodsFor: 'events' stamp: 'cwp 5/26/2005 08:39'!
refresh
	self refreshList.
	self refreshIndex! !

!ListStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'!
refreshIndex
	| selector |
	selector := spec getIndex.
	index := selector
		ifNil: [self list indexOf: (self model perform: spec getSelected)]
		ifNotNil: [spec model perform: selector]
! !

!ListStub methodsFor: 'events' stamp: 'cwp 5/26/2005 08:32'!
refreshList
	list := self model perform: spec list! !

!ListStub methodsFor: 'events' stamp: 'cwp 5/26/2005 08:57'!
update: aSelector
	aSelector = spec list ifTrue: [^ self refreshList].
	aSelector = spec getSelected ifTrue: [^ self refreshIndex].
	aSelector = spec getIndex ifTrue: [^ self refreshIndex].
	^ super update: aSelector! !


!ListStub methodsFor: 'simulating' stamp: 'stephaneducasse 2/3/2006 22:32'!
clickItemAt: anInteger
	| selector |
	selector := spec setIndex.
	selector
		ifNil: [self model perform: spec setSelected with: (self list at: anInteger)]
		ifNotNil: [self model perform: selector with: anInteger]
! !

!ListStub methodsFor: 'simulating' stamp: 'cwp 5/27/2005 08:16'!
click: aString
	self clickItemAt: (self list indexOf: aString)! !

!ListStub methodsFor: 'simulating' stamp: 'cwp 5/26/2005 08:39'!
list
	^ list ifNil: [Array new]! !

!ListStub methodsFor: 'simulating' stamp: 'cwp 6/9/2005 08:15'!
menu
	^ MenuStub fromSpec:
		(self model 
			perform: spec menu 
			with: (PluggableMenuSpec withModel: self model))! !

!ListStub methodsFor: 'simulating' stamp: 'cwp 5/27/2005 08:22'!
selectedIndex
	^ index ifNil: [0]! !

!ListStub methodsFor: 'simulating' stamp: 'cwp 5/27/2005 08:27'!
selectedItem
	| items idx |
	(items  := self list) isEmpty ifTrue: [^ nil].
	(idx := self selectedIndex) = 0 ifTrue: [^ nil].
	^ items at: idx
	! !
View subclass: #ListView
	instanceVariableNames: 'list selection topDelimiter bottomDelimiter isEmpty textStyle'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!ListView commentStamp: '<historical>' prior: 0!
I am an abstract View of a list of items. I provide support for storing a selection of one item, as well as formatting the list for presentation on the screen. My instances' default controller is ListController.!


!ListView methodsFor: 'clipping box access'!
clippingBox
	"Answer the rectangle in which the model can be displayed--this is the 
	insetDisplayBox inset by the height of a line for an item."

	^self insetDisplayBox insetBy: 
		(Rectangle
			left: 0
			right: 0
			top: 0
			bottom: self insetDisplayBox height \\ list lineGrid)! !


!ListView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^ListController! !


!ListView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."
	^ self deEmphasizeSelectionBox! !

!ListView methodsFor: 'deEmphasizing'!
emphasizeView 
	"List emphasis is its own inverse."
	^ self deEmphasizeView! !


!ListView methodsFor: 'delimiters'!
bottomDelimiter
	"Answer the string used to indicate the bottom of the list."

	^bottomDelimiter! !

!ListView methodsFor: 'delimiters'!
bottomDelimiter: aString 
	"Set the string used to indicate the bottom of the list."

	bottomDelimiter _ aString! !

!ListView methodsFor: 'delimiters'!
noBottomDelimiter
	"Set the string used to indicate the bottom of the list to be nothing."

	bottomDelimiter _ nil! !

!ListView methodsFor: 'delimiters'!
noTopDelimiter
	"Set the string used to indicate the top of the list to be nothing."

	topDelimiter _ nil! !

!ListView methodsFor: 'delimiters'!
topDelimiter
	"Answer the string used to indicate the top of the list."

	^topDelimiter! !

!ListView methodsFor: 'delimiters'!
topDelimiter: aString 
	"Set the string used to indicate the top of the list."

	topDelimiter _ aString! !


!ListView methodsFor: 'display box access'!
boundingBox 
	"Refer to the comment in View|boundingBox."

	^list boundingBox! !

!ListView methodsFor: 'display box access' stamp: 'mkd 11/4/1999 14:31'!
isSelectionBoxClipped
        "Answer whether there is a selection and whether the selection is visible 
        on the screen."

        ^ selection ~= 0 and:
			[(self selectionBox intersects: 
                       (self clippingBox insetBy: (Rectangle left: 0 right: 0 top: 1 bottom: 0))) not]! !


!ListView methodsFor: 'displaying'!
deEmphasizeSelectionBox
	self displaySelectionBox! !

!ListView methodsFor: 'displaying'!
display 
	"Refer to the comment in View.display."
	(self isUnlocked and: [self clippingBox ~= list clippingRectangle])
		ifTrue:  "Recompose the list if the window changed"
			[selection isNil ifTrue: [selection _ 0].
			self positionList].
	super display! !

!ListView methodsFor: 'displaying'!
displaySelectionBox
	"If the receiver has a selection and that selection is visible on the display 
	screen, then highlight it."
	selection ~= 0 ifTrue:
		[Display reverse: (self selectionBox intersect: self clippingBox)]! !

!ListView methodsFor: 'displaying'!
displayView 
	"Refer to the comment in View|displayView."

	self clearInside.
	list foregroundColor: self foregroundColor
		backgroundColor: self backgroundColor.
	list displayOn: Display! !

!ListView methodsFor: 'displaying'!
scrollBy: anInteger 
	"Scroll up by this amount adjusted by lineSpacing and list limits"
	| maximumAmount minimumAmount amount wasClipped |
	maximumAmount _ 0 max:
		list clippingRectangle top - list compositionRectangle top.
	minimumAmount _ 0 min:
		list clippingRectangle bottom - list compositionRectangle bottom.
	amount _ (anInteger min: maximumAmount) max: minimumAmount.
	amount ~= 0
		ifTrue: [list scrollBy: amount negated.  ^ true]
		ifFalse: [^ false]  "Return false if no scrolling took place"! !

!ListView methodsFor: 'displaying'!
scrollSelectionIntoView
	"Selection is assumed to be on and clipped out of view.
	Uses controller scrollView to keep selection right"
	| delta |
	(delta _ self insetDisplayBox bottom - self selectionBox bottom) < 0
		ifTrue: [^ self controller scrollView: delta - (list lineGrid-1)]. "up"
	(delta _ self insetDisplayBox top - self selectionBox top) > 0
		ifTrue: [^ self controller scrollView: delta + 1] "down"! !


!ListView methodsFor: 'font access' stamp: 'sw 12/9/1999 18:07'!
font
	^ self assuredTextStyle fontNamed: textStyle fontNames first
! !

!ListView methodsFor: 'font access' stamp: 'jm 9/20/1998 19:44'!
font: aFontOrNil

	aFontOrNil
		ifNil: [textStyle _ nil]
		ifNotNil: [
			textStyle _ TextStyle fontArray: (Array with: aFontOrNil).
			textStyle gridForFont: 1 withLead: 1].
	self changed: #list.  "update display"
! !


!ListView methodsFor: 'initialize-release'!
initialize 
	"Refer to the comment in View|initialize."

	super initialize.
	topDelimiter _ '------------'.
	bottomDelimiter _ '------------'.
	isEmpty _ true.
	self list: Array new! !


!ListView methodsFor: 'list access' stamp: 'sw 12/10/1999 10:43'!
assuredTextStyle
	^ textStyle ifNil:
		[textStyle _  ListParagraph standardListStyle]
! !

!ListView methodsFor: 'list access'!
list
	"Answer the list of items the receiver displays."

	^list! !

!ListView methodsFor: 'list access' stamp: 'sw 12/9/1999 18:06'!
list: anArray 
	"Set the list of items the receiver displays to be anArray."
	| arrayCopy i |
	isEmpty _ anArray isEmpty.
	arrayCopy _ Array new: (anArray size + 2).
	arrayCopy at: 1 put: topDelimiter.
	arrayCopy at: arrayCopy size put: bottomDelimiter.
	i _ 2.
	anArray do: [:el | arrayCopy at: i put: el. i _ i+1].
	arrayCopy _ arrayCopy copyWithout: nil.
	list _ ListParagraph withArray: arrayCopy style: self assuredTextStyle.
	selection _ 0.
	self positionList.
! !

!ListView methodsFor: 'list access'!
reset
	"Set the list of items displayed to be empty."

	isEmpty _ true.
	self list: Array new! !

!ListView methodsFor: 'list access'!
resetAndDisplayView
	"Set the list of items displayed to be empty and redisplay the receiver."

	isEmpty
		ifFalse: 
			[self reset.
			self displayView]! !

!ListView methodsFor: 'list access'!
selection: selIndex
	selection _ selIndex! !


!ListView methodsFor: 'lock access'!
lock
	"Refer to the comment in view|lock.  Must do at least what display would do to lock the view."

	(self isUnlocked and: [self clippingBox ~= list clippingRectangle])
		ifTrue:  "Recompose the list if the window changed"
			[self positionList].
	super lock! !


!ListView methodsFor: 'selecting'!
deselect
	"If the receiver has a selection, then it is highlighted. Remove the 
	highlighting."

	selection ~= 0 ifTrue: [Display reverse: (self selectionBox intersect: self clippingBox)]! !

!ListView methodsFor: 'selecting'!
findSelection: aPoint 
	"Determine which selection is displayed in an area containing the point, 
	aPoint. Answer the selection if one contains the point, answer nil 
	otherwise."

	| trialSelection |
	(self clippingBox containsPoint: aPoint) ifFalse: [^nil].
	trialSelection _ aPoint y - list compositionRectangle top // list lineGrid + 1.
	topDelimiter == nil ifFalse: [trialSelection _ trialSelection - 1].
	(trialSelection < 1) | (trialSelection > self maximumSelection)
		ifTrue: [^ nil]
		ifFalse: [^ trialSelection]! !

!ListView methodsFor: 'selecting'!
maximumSelection
	"Answer which selection is the last possible one."
	^ list numberOfLines
		- (topDelimiter == nil ifTrue: [0] ifFalse: [1])
		- (bottomDelimiter == nil ifTrue: [0] ifFalse: [1])! !

!ListView methodsFor: 'selecting'!
minimumSelection
	"Answer which selection is the first possible one."
	^ 1! !

!ListView methodsFor: 'selecting'!
moveSelectionBox: anInteger 
	"Presumably the selection has changed to be anInteger. Deselect the 
	previous selection and display the new one, highlighted."

	selection ~= anInteger
		ifTrue: 
			[self deselect.
			selection _ anInteger.
			self displaySelectionBox].
	self isSelectionBoxClipped
		ifTrue: [self scrollSelectionIntoView]! !

!ListView methodsFor: 'selecting' stamp: 'di 5/22/1998 00:25'!
numSelectionsInView
	^ self clippingBox height // self list lineGrid! !

!ListView methodsFor: 'selecting'!
selection
	"Answer the receiver's current selection."

	^selection! !

!ListView methodsFor: 'selecting'!
selectionBox
	"Answer the rectangle in which the current selection is displayed."

	^(self insetDisplayBox left @ (list compositionRectangle top + self selectionBoxOffset) 
		extent: self insetDisplayBox width @ list lineGrid)
		insetBy: (Rectangle left: 1 right: 1 top: 1 bottom: 0)! !

!ListView methodsFor: 'selecting'!
selectionBoxOffset
	"Answer an integer that determines the y position for the display box of 
	the current selection."

	^ (selection - 1 + (topDelimiter == nil ifTrue: [0] ifFalse: [1]))
		* list lineGrid! !


!ListView methodsFor: 'updating'!
update: aSymbol 
	"Refer to the comment in View|update:."

	aSymbol == #list
		ifTrue: 
			[self list: model list.
			self displayView.
			^self].
	aSymbol == #listIndex
		ifTrue: 
			[self moveSelectionBox: model listIndex.
			^self]! !


!ListView methodsFor: 'private'!
firstShown
	"Return the index of the top item currently visible"
	| trial |
	trial _ self findSelection: self insetDisplayBox topLeft.
	^ trial == nil
		ifTrue: [1]
		ifFalse: [trial]! !

!ListView methodsFor: 'private'!
lastShown
	"Return the index of the bottom item currently visible"
	| trial bottomMargin |
	bottomMargin _ self insetDisplayBox height \\ list lineGrid.
	trial _ self findSelection: self insetDisplayBox bottomLeft - (0@bottomMargin).
	trial == nil
		ifTrue: [trial _ self findSelection: self insetDisplayBox bottomLeft
					- (0@(list lineGrid+bottomMargin))].
	^ trial == nil
		ifTrue: [list numberOfLines - 2]
		ifFalse: [trial]! !

!ListView methodsFor: 'private'!
positionList

	list wrappingBox: self wrappingBox clippingBox: self clippingBox ! !

!ListView methodsFor: 'private'!
wrappingBox

	| aRectangle |
	aRectangle _ self insetDisplayBox. 
	selection = 0
		ifTrue: [^aRectangle topLeft + (4 @ 0) extent: list compositionRectangle extent]
		ifFalse: [^aRectangle left + 4 @ 
					(aRectangle top - 
						(self selectionBoxOffset 
							min: ((list height - aRectangle height 
									+ list lineGrid truncateTo: list lineGrid)
							max: 0))) 
					extent: list compositionRectangle extent]! !
ObjectRepresentativeMorph subclass: #ListViewLine
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!

!ListViewLine methodsFor: 'e-toy support' stamp: 'sw 10/23/2000 18:27'!
listViewLineForFieldList: aFieldList
	"Answer a list view line containing data representing the items in aFieldList"

	^ objectRepresented == self
		ifFalse:
			[objectRepresented listViewLineForFieldList: aFieldList]
		ifTrue:
			[super listViewLineForFieldList: aFieldList]! !


!ListViewLine methodsFor: 'object represented' stamp: 'ar 11/1/2000 15:55'!
objectRepresented: anObject
	"Set the object represented by the receiver to be as requested"

	objectRepresented _ anObject.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self setNameTo: anObject name.
	self removeAllMorphs.
! !


!ListViewLine methodsFor: 'thumbnail' stamp: 'sw 10/6/2002 02:00'!
morphRepresented
	"Answer the morph that I actually represent"

	^ objectRepresented! !
Dictionary subclass: #LiteralDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Support'!
!LiteralDictionary commentStamp: '<historical>' prior: 0!
A LiteralDictionary, like an IdentityDictionary, has a special test for equality.  In this case it is simple equality between objects of like class.  This allows equal Float or String literals to be shared without the possibility of erroneously sharing, say, 1 and 1.0!


!LiteralDictionary methodsFor: 'as yet unclassified' stamp: 'yo 1/27/2001 05:06'!
arrayEquality: x and: y

	x size = y size ifFalse: [^ false].
	x with: y do: [:e1 :e2 | 
		(self literalEquality: e1 and: e2) ifFalse: [^ false]
	].
	^true.
! !

!LiteralDictionary methodsFor: 'as yet unclassified' stamp: 'yo 1/27/2001 05:13'!
literalEquality: x and: y

	^ (x class = Array and: [y class = Array]) ifTrue: [
		self arrayEquality: x and: y.
	] ifFalse: [
		(x class == y class) and: [x = y]
	].
! !

!LiteralDictionary methodsFor: 'as yet unclassified' stamp: 'md 10/5/2005 15:43'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	finish _ array size.
	start _ (anObject hash \\ finish) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil
					or: [self literalEquality: element key and: anObject])
					ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil
					or: [self literalEquality: element key and: anObject])
					ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
LeafNode subclass: #LiteralNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!LiteralNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a literal string or number.!


!LiteralNode methodsFor: 'code generation'!
emitForValue: stack on: strm

	code < 256
		ifTrue: [strm nextPut: code]
		ifFalse: [self emitLong: LoadLong on: strm].
	stack push: 1! !


!LiteralNode methodsFor: 'evaluation' stamp: 'tk 8/4/1999 17:35'!
eval
	"When everything in me is a constant, I can produce a value.  This is only used by the Scripting system (TilePadMorph tilesFrom:in:)"

	^ key! !


!LiteralNode methodsFor: 'printing' stamp: 'ar 8/16/2001 13:27'!
printOn: aStream indent: level

	(key isVariableBinding)
		ifTrue:
			[key key isNil
				ifTrue:
					[aStream nextPutAll: '###';
					 	nextPutAll: key value soleInstance name]
				ifFalse:
					[aStream nextPutAll: '##';
						nextPutAll: key key]]
		ifFalse:
			[aStream withStyleFor: #literal
					do: [key storeOn: aStream]]! !


!LiteralNode methodsFor: 'testing'!
isConstantNumber
	^ key isNumber! !

!LiteralNode methodsFor: 'testing' stamp: 'di 4/5/2000 11:13'!
isLiteral

	^ true! !

!LiteralNode methodsFor: 'testing'!
isSpecialConstant
	^ code between: LdTrue and: LdMinus1+3! !

!LiteralNode methodsFor: 'testing'!
literalValue

	^key! !


!LiteralNode methodsFor: '*eToys-tiles' stamp: 'tk 8/24/2001 15:43'!
asMorphicSyntaxIn: parent

	| row |

	row _ parent addRow: #literal on: self.
	(key isVariableBinding) ifFalse: [
		row layoutInset: 1.
		^ row addMorphBack: (row addString: key storeString special: false)].
	key key isNil ifTrue: [
		^ row addTextRow: ('###',key value soleInstance name)
	] ifFalse: [
		^ row addTextRow: ('##', key key)
	].	! !

!LiteralNode methodsFor: '*eToys-tiles' stamp: 'ar 8/16/2001 13:27'!
explanation

	(key isVariableBinding) ifFalse: [
		^'Literal ', key storeString
	].
	key key isNil ifTrue: [
		^'Literal ', ('###',key value soleInstance name) 
	] ifFalse: [
		^'Literal ', ('##', key key) 
	].	! !
VariableNode subclass: #LiteralVariableNode
	instanceVariableNames: 'splNode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!

!LiteralVariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:41'!
emitLoad: stack on: strm
	splNode ifNil:[^super emitLoad: stack on: strm].
	self code < 256
		ifTrue: [strm nextPut: self code]
		ifFalse: [self emitLong: LoadLong on: strm].
	stack push: 1.! !

!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/16/2001 12:12'!
emitStore: stack on: strm
	splNode ifNil:[^super emitStore: stack on: strm].
	splNode
			emit: stack
			args: 1
			on: strm
			super: false.! !

!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/16/2001 12:12'!
emitStorePop: stack on: strm
	splNode ifNil:[^super emitStorePop: stack on: strm].
	self emitStore: stack on: strm.
	strm nextPut: Pop.
	stack pop: 1.! !

!LiteralVariableNode methodsFor: 'code generation' stamp: 'ab 7/13/2004 13:52'!
sizeForStore: encoder
	| index |
	(self key isVariableBinding and:[self key isSpecialWriteBinding]) 
		ifFalse:[^super sizeForStore: encoder].
	self code < 0 ifTrue:[
		index _ self index.
		self code: (self code: index type: LdLitType)].
	splNode _ encoder encodeSelector: #value:.
	^ (splNode size: encoder args: 1 super: false) + (super sizeForValue: encoder)! !

!LiteralVariableNode methodsFor: 'code generation' stamp: 'ab 7/13/2004 13:52'!
sizeForStorePop: encoder
	| index |
	(self key isVariableBinding and:[self key isSpecialWriteBinding]) 
		ifFalse:[^super sizeForStorePop: encoder].
	self code < 0 ifTrue:[
		index _ self index.
		self code: (self code: index type: LdLitType)].
	splNode _ encoder encodeSelector: #value:.
	^ (splNode size: encoder args: 1 super: false) + (super sizeForValue: encoder) + 1! !
CodeModelExtension subclass: #LocalSends
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!
!LocalSends commentStamp: '<historical>' prior: 0!
This class provide the model extension describing local sends for a given class. These are described in the comment for SendInfo, which is the class that actually computes this information.!


!LocalSends methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 18:48'!
newCacheFor: aClass 
	"Creates an instance of SendCaches, assigns it to the instance variable sendCaches and fills it with all the self-sends class-sends and super-sends that occur in methods defined in this class (or by used traits)."

	| localSendCache info |
	localSendCache := SendCaches new.
	aClass selectorsAndMethodsDo: 
			[:sender :m | 
			info := (SendInfo on: m) collectSends.
			info selfSentSelectors 
				do: [:sentSelector | localSendCache addSelfSender: sender of: sentSelector].
			info superSentSelectors 
				do: [:sentSelector | localSendCache addSuperSender: sender of: sentSelector].
			info classSentSelectors 
				do: [:sentSelector | localSendCache addClassSender: sender of: sentSelector]].
	^localSendCache! !

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

LocalSends class
	instanceVariableNames: ''!
Object subclass: #Locale
	instanceVariableNames: 'id shortDate longDate time decimalSymbol digitGrouping currencySymbol currencyNotation measurement offsetLocalToUTC offsetVMToUTC dstActive'
	classVariableNames: 'Current CurrentPlatform KnownLocales LanguageSymbols LocaleChangeListeners PlatformEncodings'
	poolDictionaries: ''
	category: 'System-Localization'!
!Locale commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.



	http://www.w3.org/WAI/ER/IG/ert/iso639.htm
	http://www.oasis-open.org/cover/iso639a.html
	See also
	http://oss.software.ibm.com/cvs/icu/~checkout~/icuhtml/design/language_code_issues.html
	http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.10
	
ISO 3166
http://mitglied.lycos.de/buran/knowhow/codes/locales/
!


!Locale methodsFor: 'accessing' stamp: 'mir 8/31/2005 17:03'!
determineLocale
	self localeID: self determineLocaleID! !

!Locale methodsFor: 'accessing' stamp: 'mir 8/31/2005 16:32'!
determineLocaleID
	"Locale current determineLocaleID"
	| langCode isoLang countryCode isoCountry |
	langCode := self fetchISO2Language.
	isoLang := langCode
		ifNil: [^self localeID]
		ifNotNil: [langCode].
	countryCode := self primCountry.
	isoCountry := countryCode
		ifNil: [^LocaleID isoLanguage: isoLang]
		ifNotNil: [countryCode].
	^LocaleID isoLanguage: isoLang isoCountry: isoCountry! !

!Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'!
isoCountry
	^self localeID isoCountry! !

!Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'!
isoLanguage
	^self localeID isoLanguage! !

!Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:41'!
isoLocale
	"<language>-<country>"
	^self isoCountry
		ifNil: [self isoLanguage]
		ifNotNil: [self isoLanguage , '-' , self isoCountry]! !

!Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:52'!
languageEnvironment
	^LanguageEnvironment localeID: self localeID! !

!Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'!
localeID
	^id! !

!Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'!
localeID: anID
	id := anID! !

!Locale methodsFor: 'accessing' stamp: 'tak 8/4/2005 15:18'!
printOn: aStream 
	super printOn: aStream.
	aStream nextPutAll: '(' , id printString , ')'! !


!Locale methodsFor: 'system primitives' stamp: 'mir 8/31/2005 17:36'!
primCountry
	"Returns string with country tag according to ISO 639"
	<primitive: 'primitiveCountry' module: 'LocalePlugin'>
	^nil! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:45'!
primCurrencyNotation
	"Returns boolean if symbol is pre- (true) or post-fix (false)"
	<primitive: 'primitiveCurrencyNotation' module: 'LocalePlugin'>
	^true! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:47'!
primCurrencySymbol
	"Returns string with currency symbol"
	<primitive: 'primitiveCurrencySymbol' module:'LocalePlugin'>
	^'$'! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:48'!
primDST
	"Returns boolean if DST  (daylight saving time) is active or not"
	<primitive:'primitiveDaylightSavings' module: 'LocalePlugin'>
	^false! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:42'!
primDecimalSymbol
	"Returns string with e.g. '.' or ','"
	<primitive:'primitiveDecimalSymbol' module: 'LocalePlugin'>
	^'.'! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:42'!
primDigitGrouping
	"Returns string with e.g. '.' or ',' (thousands etc)"
	<primitive:'primitiveDigitGroupingSymbol' module: 'LocalePlugin'>
	^','! !

!Locale methodsFor: 'system primitives' stamp: 'mir 8/17/2005 15:53'!
primLanguage
	"returns string with language tag according to ISO 639"
	<primitive:'primitiveLanguage' module: 'LocalePlugin'>
	^nil! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:51'!
primLongDateFormat
	"Returns the long date format
	d day, m month, y year,
	double symbol is null padded, single not padded (m=6, mm=06)
	dddd weekday
	mmmm month name"
	<primitive:'primitiveLongDateFormat' module: 'LocalePlugin'>
! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:43'!
primMeasurement
	"Returns boolean denoting metric(true) or imperial(false)."
	<primitive:'primitiveMeasurementMetric' module: 'LocalePlugin'>
	^true
! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:53'!
primShortDateFormat
	"Returns the short date format
	d day, m month, y year,
	double symbol is null padded, single not padded (m=6, mm=06)
	dddd weekday
	mmmm month name"
	<primitive:'primitiveShortDateFormat' module: 'LocalePlugin'>
! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:54'!
primTimeFormat
	"Returns string time format
	Format is made up of 
	h hour (h 12, H 24), m minute, s seconds, x (am/pm String)
	double symbol is null padded, single not padded (h=6, hh=06)"
	<primitive:'primitiveTimeFormat' module: 'LocalePlugin'>

! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:43'!
primTimezone
	"The offset from UTC in minutes, with positive offsets being towards the east.
	(San Francisco is in UTC -08*60 and Paris is in GMT +01*60 (daylight savings is not in effect)."
	<primitive:'primitiveTimezoneOffset' module: 'LocalePlugin'>
	^0! !

!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:44'!
primVMOffsetToUTC
	"Returns the offset in minutes between the VM and UTC.
	If the VM does not support UTC times, this is 0.
	Also gives us backward compatibility with old VMs as the primitive will fail and we then can return 0."
	<primitive:'primitiveVMOffsetToUTC' module: 'LocalePlugin'>
	^0! !


!Locale methodsFor: 'private' stamp: 'mir 8/31/2005 17:36'!
fetchISO2Language
	"Locale current fetchISO2Language"
	| lang isoLang |
	lang := self primLanguage.
	lang ifNil: [^nil].
	lang := lang copyUpTo: 0 asCharacter.
	lang size == 2
		ifTrue: [^lang].
	isoLang := ISOLanguageDefinition iso3LanguageDefinition: lang.
	^isoLang
		ifNil: [nil]
		ifNotNil: [isoLang iso2]! !

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

Locale class
	instanceVariableNames: ''!

!Locale class methodsFor: 'accessing' stamp: 'mir 8/16/2003 16:02'!
clipboadInterpreter
	^NoConversionClipboardInterpreter new! !

!Locale class methodsFor: 'accessing' stamp: 'mir 8/31/2005 17:36'!
current
	"Current := nil"
	Current ifNil: [
		Current := self determineCurrentLocale.
		"Transcript show: 'Current locale: ' , Current localeID asString; cr"].
	^Current! !

!Locale class methodsFor: 'accessing' stamp: 'yo 7/28/2004 20:32'!
currentPlatform
	"CurrentPlatform := nil"
	CurrentPlatform ifNil: [CurrentPlatform := self determineCurrentLocale].
	^CurrentPlatform! !

!Locale class methodsFor: 'accessing' stamp: 'yo 7/28/2004 20:39'!
currentPlatform: locale
	CurrentPlatform := locale.
	LanguageEnvironment startUp.
! !

!Locale class methodsFor: 'accessing' stamp: 'tak 10/18/2005 22:33'!
currentPlatform: locale during: aBlock 
	"Alter current language platform during a block"
	| backupPlatform |
	backupPlatform := self currentPlatform.
	[self currentPlatform: locale.
	aBlock value]
		ensure: [self currentPlatform: backupPlatform]! !

!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:20'!
isoLanguage: isoLanguage
	^self isoLanguage: isoLanguage isoCountry: nil! !

!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:31'!
isoLanguage: isoLanguage isoCountry: isoCountry
	^self localeID: (LocaleID  isoLanguage: isoLanguage isoCountry: isoCountry)! !

!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:42'!
isoLocale: aString
	! !

!Locale class methodsFor: 'accessing' stamp: 'mir 7/13/2004 00:24'!
languageSymbol: languageSymbol
	"Locale languageSymbol: #Deutsch"

	^self isoLanguage: (LanguageSymbols at: languageSymbol)! !

!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:30'!
localeID: id
	^self knownLocales at: id ifAbsentPut: [Locale new localeID: id]! !

!Locale class methodsFor: 'accessing' stamp: 'dgd 10/7/2004 20:50'!
stringForLanguageNameIs: localeID 
	"Answer a string for a menu determining whether the given  
	symbol is the project's natural language"
	^ (self current localeID = localeID
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, localeID displayName! !

!Locale class methodsFor: 'accessing' stamp: 'tak 8/5/2005 21:11'!
switchAndInstallFontToID: localeID 
	"Locale switchAndInstallFontToID: (LocaleID isoLanguage: 'de')"
	| locale |
	locale := Locale localeID: localeID.
	locale languageEnvironment isFontAvailable
		ifFalse: [(self confirm: 'This language needs additional fonts.
Do you want to install the fonts?' translated)
				ifTrue: [locale languageEnvironment installFont]
				ifFalse: [^ self]].
	self
		switchTo: locale! !

!Locale class methodsFor: 'accessing' stamp: 'tak 8/4/2005 16:30'!
switchTo: locale 
	"Locale switchTo: Locale isoLanguage: 'de'"
	Current localeID = locale localeID
		ifFalse: [Current := locale.
			CurrentPlatform := locale.
			self localeChanged]! !

!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 19:07'!
switchToID: localeID
	"Locale switchToID: (LocaleID isoLanguage: 'de') "

	self switchTo: (Locale localeID: localeID)! !


!Locale class methodsFor: 'class initialization' stamp: 'mir 8/31/2005 17:00'!
initialize
	"Locale initialize"

	Smalltalk addToStartUpList: Locale.
	Preferences addPreference: #useLocale
		categories: #('general') default: false 
		balloonHelp: 'Use the system locale to set the system language etc at startup'.! !

!Locale class methodsFor: 'class initialization' stamp: 'nk 8/29/2004 13:21'!
initializePlatformEncodings
	"Locale initializePlatformEncodings"

	| platform |
	PlatformEncodings isNil ifTrue: [ PlatformEncodings := Dictionary new ].

	platform := PlatformEncodings at: 'default' ifAbsentPut: Dictionary new.
	platform
		at: 'default' put: 'iso8859-1';
		at: 'Win32 CE' put: 'utf-8';
		yourself.

	platform := PlatformEncodings at: 'ja' ifAbsentPut: Dictionary new.
	platform
		at: 'default' put: 'shift-jis';
		at: 'unix' put: 'euc-jp';
		at: 'Win32 CE' put: 'utf-8';
		yourself.

	platform := PlatformEncodings at: 'ko' ifAbsentPut: Dictionary new.
	platform
		at: 'default' put: 'euc-kr';
		at: 'Win32 CE' put: 'utf-8';
		yourself.

	platform := PlatformEncodings at: 'zh' ifAbsentPut: Dictionary new.
	platform
		at: 'default' put: 'gb2312';
		at: 'unix' put: 'euc-cn';
		at: 'Win32 CE' put: 'utf-8';
		yourself.
! !

!Locale class methodsFor: 'class initialization' stamp: 'nk 8/29/2004 13:20'!
platformEncodings
	PlatformEncodings isEmptyOrNil ifTrue: [ self initializePlatformEncodings ].
	^PlatformEncodings
! !


!Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'!
addLocalChangedListener: anObjectOrClass
	self localeChangedListeners add: anObjectOrClass! !

!Locale class methodsFor: 'notification' stamp: 'tak 8/4/2005 22:34'!
localeChanged
	#(#ParagraphEditor #BitEditor #FormEditor #StandardSystemController )
		do: [:key | Smalltalk
				at: key
				ifPresent: [:class | class initialize]].
	StrikeFont localeChanged.
	PartsBin localeChanged.
	Project localeChanged.
	PaintBoxMorph localeChanged.
	ColorPickerMorph localeChanged.
	Preferences localeChanged! !

!Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'!
localeChangedListeners
	^LocaleChangeListeners ifNil: [LocaleChangeListeners _ OrderedCollection new]! !


!Locale class methodsFor: 'platform specific' stamp: 'nk 7/30/2004 21:45'!
defaultEncodingName: languageSymbol 
	| encodings platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	encodings := self platformEncodings at: languageSymbol
				ifAbsent: [self platformEncodings at: #default].
	encodings at: platformName ifPresent: [:encoding | ^encoding].
	encodings at: platformName , ' ' , osVersion
		ifPresent: [:encoding | ^encoding].
	^encodings at: #default! !

!Locale class methodsFor: 'platform specific' stamp: 'nk 7/30/2004 21:45'!
defaultInputInterpreter
	| platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) 
		ifTrue: [^NoInputInterpreter new].
	platformName = 'Win32' ifTrue: [^MacRomanInputInterpreter new].
	^NoInputInterpreter new! !


!Locale class methodsFor: 'private' stamp: 'mir 7/28/2005 00:24'!
determineCurrentLocale
	"For now just return the default locale.
	A smarter way would be to determine the current platforms default locale."
	"Locale determineCurrentLocale"

	^self new determineLocale! !

!Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 19:44'!
initKnownLocales
	| locales |
	locales := Dictionary new.

	"Init the locales for which we have translations"
	NaturalLanguageTranslator availableLanguageLocaleIDs do: [:id |
		locales at: id put: (Locale new localeID: id)].
	^locales! !

!Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 16:44'!
knownLocales
	"KnownLocales := nil"
	^KnownLocales ifNil: [KnownLocales := self initKnownLocales]! !

!Locale class methodsFor: 'private' stamp: 'ka 2/18/2005 02:40'!
migrateSystem
	"Locale migrateSystem"
	"Do all the necessary operations to switch to the new Locale environment."

	LocaleChangeListeners _ nil.
	self
		addLocalChangedListener: HandMorph;
		addLocalChangedListener: Clipboard;
		addLocalChangedListener: Vocabulary;
		addLocalChangedListener: PartsBin;
		addLocalChangedListener: Project;
		addLocalChangedListener: PaintBoxMorph;
		yourself! !


!Locale class methodsFor: 'system startUp' stamp: 'mir 8/31/2005 17:03'!
startUp: resuming
	| newID |
	resuming ifFalse: [^self].
	(Preferences valueOfFlag: #useLocale)
		ifTrue: [
			newID := self current determineLocaleID.
			newID ~= LocaleID current
				ifTrue: [self switchToID: newID]]! !
Object subclass: #LocaleID
	instanceVariableNames: 'isoLanguage isoCountry'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Localization'!

!LocaleID methodsFor: 'accessing' stamp: 'mir 9/1/2005 14:17'!
displayCountry
	^(ISOLanguageDefinition iso2Countries at: self isoCountry asUppercase ifAbsent: [ self isoCountry ]) ! !

!LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 18:18'!
displayLanguage
	| language |
	language := (ISOLanguageDefinition iso2LanguageDefinition: self isoLanguage) language.
	^self isoCountry
		ifNil: [language]
		ifNotNil: [language , ' (' , self displayCountry , ')']! !

!LocaleID methodsFor: 'accessing' stamp: 'dgd 10/7/2004 21:16'!
displayName
	"Answer a proper name to represent the receiver in GUI. 
	 
	The wording is provided by translations of the magic value 
	'<language display name>'. 
	 
	'English' -> 'English'  
	'German' -> 'Deutsch'  
	"
	| magicPhrase translatedMagicPhrase |
	magicPhrase := '<language display name>'.
	translatedMagicPhrase := magicPhrase translatedTo: self.
	^ translatedMagicPhrase = magicPhrase
		ifTrue: [self displayLanguage]
		ifFalse: [translatedMagicPhrase]! !

!LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:43'!
isoCountry
	^isoCountry! !

!LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:43'!
isoLanguage
	^isoLanguage! !

!LocaleID methodsFor: 'accessing' stamp: 'mir 7/21/2004 19:17'!
isoString
	^self asString! !

!LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:34'!
parent
	^self class isoLanguage: self isoLanguage! !

!LocaleID methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:37'!
translator
	^ NaturalLanguageTranslator localeID: self ! !


!LocaleID methodsFor: 'comparing' stamp: 'mir 7/15/2004 14:23'!
= anotherObject
	self class == anotherObject class
		ifFalse: [^false].
	^self isoLanguage = anotherObject isoLanguage
		and: [self isoCountry = anotherObject isoCountry]! !

!LocaleID methodsFor: 'comparing' stamp: 'mir 7/15/2004 14:23'!
hash
	^self isoLanguage hash bitXor: self isoCountry hash! !


!LocaleID methodsFor: 'initialize' stamp: 'mir 7/15/2004 12:44'!
isoLanguage: langString isoCountry: countryStringOrNil
	isoLanguage := langString.
	isoCountry := countryStringOrNil! !


!LocaleID methodsFor: 'printing' stamp: 'mir 7/15/2004 12:45'!
printOn: stream
	"<language>-<country>"
	stream nextPutAll: self isoLanguage.
	self isoCountry
		ifNotNil: [stream nextPut: $-; nextPutAll: self isoCountry]! !

!LocaleID methodsFor: 'printing' stamp: 'tak 11/15/2004 12:45'!
storeOn: aStream 
	aStream nextPut: $(.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' isoString: '.
	aStream nextPutAll: '''' , self printString , ''''.
	aStream nextPut: $).
! !


!LocaleID methodsFor: 'testing' stamp: 'mir 7/15/2004 14:34'!
hasParent
	^self isoCountry notNil! !

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

LocaleID class
	instanceVariableNames: ''!

!LocaleID class methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:09'!
current
	^Locale current localeID! !


!LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 14:35'!
isoLanguage: langString
	^self isoLanguage: langString isoCountry: nil! !

!LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 12:46'!
isoLanguage: langString isoCountry: countryStringOrNil
	^self new isoLanguage: langString isoCountry: countryStringOrNil! !

!LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/21/2004 13:59'!
isoString: isoString
	"Parse the isoString (<language>-<country>) into its components and return the matching LocaleID"
	"LocaleID isoString: 'en' "
	"LocaleID isoString: 'en-us' "

	| parts language country |
	parts := isoString findTokens: #($- ).
	language := parts first.
	parts size > 1
		ifTrue: [country := parts second].
	^self isoLanguage: language isoCountry: country! !
TestCase subclass: #LocaleTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Localization'!
!LocaleTest commentStamp: 'tak 8/3/2005 18:24' prior: 0!
LocaleTest buildSuite run!


!LocaleTest methodsFor: 'testing' stamp: 'tak 8/4/2005 11:02'!
testEncodingName
	"self debug: #testEncodingName"
	| locale |
	locale := Locale isoLanguage: 'ja'.
	self assert: locale languageEnvironment fontEncodingName = #FontJapaneseEnvironment! !

!LocaleTest methodsFor: 'testing' stamp: 'tak 8/7/2005 12:25'!
testFontFullName
	"self debug: #testFontFullName"
	| env dir |
	env := (Locale isoLanguage: 'ja') languageEnvironment.
	dir := FileDirectory on: SecurityManager default untrustedUserDirectory.
	[dir recursiveDelete]
		on: Error
		do: [:e | e].
	env fontFullName.
	self assert: dir exists! !

!LocaleTest methodsFor: 'testing' stamp: 'tak 8/4/2005 14:42'!
testIsFontAvailable
	"self debug: #testIsFontAvailable"
	(Locale isoLanguage: 'ja') languageEnvironment removeFonts.
	self assert: (Locale isoLanguage: 'en') languageEnvironment isFontAvailable.
	"Next test should fail after installing Japanese font"
	self assert: (Locale isoLanguage: 'ja') languageEnvironment isFontAvailable not.
	(Locale isoLanguage: 'ja') languageEnvironment installFont.
	self assert: (Locale isoLanguage: 'ja') languageEnvironment isFontAvailable! !

!LocaleTest methodsFor: 'testing' stamp: 'tak 8/4/2005 14:48'!
testLocaleChanged
	"self debug: #testLocaleChanged"
	"LanguageEnvironment >> startUp is called from Prject >> localeChanged"
	Project current updateLocaleDependents.
	self assert: (ActiveHand instVarNamed: 'keyboardInterpreter') isNil.
	self assert: (Clipboard default instVarNamed: 'interpreter') isNil.
	Locale switchToID: (LocaleID isoLanguage: 'ja').
	self assert: Preferences useFormsInPaintBox.
	Locale switchToID: (LocaleID isoLanguage: 'en').
	self assert: Preferences useFormsInPaintBox not.
! !
Object subclass: #LocatedMethod
	instanceVariableNames: 'location selector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Composition'!
!LocatedMethod commentStamp: '<historical>' prior: 0!
I identify a method in the system by its selector and location (class or trait) where it is defined.!


!LocatedMethod methodsFor: 'accessing' stamp: 'al 1/23/2004 10:18'!
location
	^location! !

!LocatedMethod methodsFor: 'accessing' stamp: 'al 1/23/2004 10:07'!
location: aPureBehavior selector: aSymbol
	location _ aPureBehavior.
	selector _ aSymbol! !

!LocatedMethod methodsFor: 'accessing' stamp: 'al 1/23/2004 10:17'!
selector
	^selector! !


!LocatedMethod methodsFor: 'comparing' stamp: 'al 3/6/2004 18:53'!
argumentNames
	"Return an array with the argument names of the method's selector"

	| keywords stream argumentNames argumentName delimiters |
	delimiters _ {Character space. Character cr}.
	keywords _ self selector keywords.
	stream _ self source readStream.
	argumentNames _ OrderedCollection new.
	keywords do: [ :each |
		stream match: each.
		[stream peekFor: Character space] whileTrue.
		argumentName _ ReadWriteStream on: String new.
		[(delimiters includes: stream peek) or: [stream peek isNil]]
			whileFalse: [argumentName nextPut: stream next].
		argumentName isEmpty ifFalse: [
			argumentNames add: argumentName contents withBlanksTrimmed]].
	^(argumentNames copyFrom: 1 to: self method numArgs) asArray! !

!LocatedMethod methodsFor: 'comparing' stamp: 'NS 3/30/2004 16:12'!
hash
	^ self method identityHash! !

!LocatedMethod methodsFor: 'comparing' stamp: 'NS 3/30/2004 16:12'!
= aLocatedMethod
	^ self method == aLocatedMethod method ! !


!LocatedMethod methodsFor: 'convenience' stamp: 'al 3/9/2004 23:30'!
category
	^self location
		whichCategoryIncludesSelector: self selector! !

!LocatedMethod methodsFor: 'convenience' stamp: 'al 1/23/2004 10:17'!
method
	^self location >> self selector! !

!LocatedMethod methodsFor: 'convenience' stamp: 'al 2/16/2004 17:08'!
source
	^(self method
		getSourceFor: self selector
		in: self location) asString! !


!LocatedMethod methodsFor: 'testing' stamp: 'al 2/25/2004 11:20'!
isBinarySelector
	^self selector
		allSatisfy: [:each | each isSpecial]! !

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

LocatedMethod class
	instanceVariableNames: ''!

!LocatedMethod class methodsFor: 'instance creation' stamp: 'al 1/23/2004 10:07'!
location: aPureBehavior selector: aSymbol
	^self new
		location: aPureBehavior selector: aSymbol;
		yourself! !
TraitsTestCase subclass: #LocatedMethodTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!LocatedMethodTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:25'!
testArgumentNames

	self assert: (LocatedMethod location: self t1 selector: #+) argumentNames = #(aNumber).
	self assert: (LocatedMethod location: self t1 selector: #!!) argumentNames = #(aNumber).
	self assert: (LocatedMethod location: self t1 selector: #&&) argumentNames = #(anObject).
	self assert: (LocatedMethod location: self t1 selector: #@%+) argumentNames = #(anObject).
	
	self assert: (LocatedMethod location: self t1 selector: #mySelector) argumentNames = #().
	self assert: (LocatedMethod location: self t1 selector: #mySelector:) argumentNames = #(something).
	self assert: (LocatedMethod location: self t1 selector: #mySelector:and:) argumentNames = #(something somethingElse).
	
! !

!LocatedMethodTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:25'!
testBinarySelectors
	self assert: (LocatedMethod location: self t1 selector: #+) isBinarySelector.
	self assert: (LocatedMethod location: self t1 selector: #!!) isBinarySelector.
	self assert: (LocatedMethod location: self t1 selector: #&&) isBinarySelector.
	self assert: (LocatedMethod location: self t1 selector: #@%+) isBinarySelector.
	
	self deny: (LocatedMethod location: self t1 selector: #mySelector) isBinarySelector.
	self deny: (LocatedMethod location: self t1 selector: #mySelector:) isBinarySelector.
	self deny: (LocatedMethod location: self t1 selector: #mySelector:and:) isBinarySelector.
	
	! !

!LocatedMethodTest methodsFor: 'running' stamp: 'al 1/23/2004 17:16'!
testEquality
	| locatedMethod1 locatedMethod2 |
	locatedMethod1 _ LocatedMethod location: self class selector: #testEquality.
	locatedMethod2 _ LocatedMethod location: self class selector: #testEquality.
	self assert: locatedMethod1 = locatedMethod2.
	self assert: locatedMethod1 hash = locatedMethod2 hash! !


!LocatedMethodTest methodsFor: 'setUp' stamp: 'dvf 8/26/2005 14:21'!
setUp
	super setUp.
	self t1 compile: '+ aNumber ^aNumber + 17'.
	self t1 compile: '!!aNumber
		| temp |
		^aNumber + 17'.
	self t1 compile: '&& anObject'.
	self t1 compile: '@%+anObject'.
	self t1 compile: 'mySelector "a comment"'.
	self t1 compile: 'mySelector: something
		^17'.
	self t1 compile: 'mySelector: something and:somethingElse ^true'! !

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

LocatedMethodTest class
	instanceVariableNames: ''!
ProtocolClientError subclass: #LoginFailedException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!LoginFailedException commentStamp: 'mir 5/12/2003 17:57' prior: 0!
Exception for signaling login failures of protocol clients.
!


!LoginFailedException methodsFor: 'exceptionDescription' stamp: 'mir 2/15/2002 13:10'!
isResumable
	"Resumable so we can give the user another chance to login"

	^true! !
TestCase subclass: #LongTestCase
	instanceVariableNames: ''
	classVariableNames: 'DoNotRunLongTestCases'
	poolDictionaries: ''
	category: 'SUnit-Extensions'!

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

LongTestCase class
	instanceVariableNames: ''!

!LongTestCase class methodsFor: 'accessing' stamp: 'md 12/5/2004 21:36'!
allTestSelectors
	DoNotRunLongTestCases ifFalse: [
		^super testSelectors].
	^#().! !

!LongTestCase class methodsFor: 'accessing' stamp: 'sd 9/25/2004 12:57'!
doNotRunLongTestCases

	DoNotRunLongTestCases := true.! !

!LongTestCase class methodsFor: 'accessing' stamp: 'md 11/14/2004 21:31'!
runLongTestCases

	DoNotRunLongTestCases := false.! !


!LongTestCase class methodsFor: 'class initialization' stamp: 'sd 9/25/2004 12:57'!
initialize

	self doNotRunLongTestCases! !


!LongTestCase class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/3/2006 22:41'!
buildSuite
	| suite |
	suite := TestSuite new.
	DoNotRunLongTestCases ifFalse: [
		self addToSuiteFromSelectors: suite].
	^suite! !


!LongTestCase class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'!
isAbstract
	"Override to true if a TestCase subclass is Abstract and should not have
	TestCase instances built from it"

	^self name = #LongTestCase
			! !
TestCase subclass: #LongTestCaseTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Extensions'!

!LongTestCaseTest methodsFor: 'testing' stamp: 'sd 9/25/2004 14:12'!
testLongTestCaseDoNotRun
	"self debug: #testLongTestCaseDoNotRun"
	"self run: #testLongTestCaseDoNotRun"

	LongTestCase doNotRunLongTestCases.
	LongTestCaseTestUnderTest markAsNotRun.
	self deny: LongTestCaseTestUnderTest hasRun.
	LongTestCaseTestUnderTest suite run.
	self deny: LongTestCaseTestUnderTest hasRun.


	! !

!LongTestCaseTest methodsFor: 'testing' stamp: 'md 12/5/2004 21:28'!
testLongTestCaseRun
	"self debug: #testLongTestCaseRun"
	"self run: #testLongTestCaseRun"

	LongTestCase runLongTestCases.
	LongTestCaseTestUnderTest markAsNotRun.
	self deny: LongTestCaseTestUnderTest hasRun.
	LongTestCaseTestUnderTest suite run.
	self assert: LongTestCaseTestUnderTest hasRun.
	LongTestCase doNotRunLongTestCases.

	! !
LongTestCase subclass: #LongTestCaseTestUnderTest
	instanceVariableNames: ''
	classVariableNames: 'RunStatus'
	poolDictionaries: ''
	category: 'SUnit-Extensions'!

!LongTestCaseTestUnderTest methodsFor: 'testing' stamp: 'md 11/14/2004 21:30'!
testWhenRunMarkTestedToTrue


	RunStatus := true.! !

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

LongTestCaseTestUnderTest class
	instanceVariableNames: ''!

!LongTestCaseTestUnderTest class methodsFor: 'Accessing' stamp: 'sd 9/25/2004 14:02'!
hasRun

	^ RunStatus! !

!LongTestCaseTestUnderTest class methodsFor: 'Accessing' stamp: 'md 11/14/2004 21:37'!
markAsNotRun

	^ RunStatus := false! !
Magnitude subclass: #LookupKey
	instanceVariableNames: 'key'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!LookupKey commentStamp: '<historical>' prior: 0!
I represent a key for looking up entries in a data structure. Subclasses of me, such as Association, typically represent dictionary entries.!


!LookupKey methodsFor: 'accessing' stamp: 'ajh 9/12/2002 12:04'!
canAssign

	^ true! !

!LookupKey methodsFor: 'accessing'!
key
	"Answer the lookup key of the receiver."

	^key! !

!LookupKey methodsFor: 'accessing'!
key: anObject 
	"Store the argument, anObject, as the lookup key of the receiver."

	key _ anObject! !

!LookupKey methodsFor: 'accessing' stamp: 'ajh 3/24/2003 21:14'!
name

	^ self key isString
		ifTrue: [self key]
		ifFalse: [self key printString]! !


!LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:59'!
beBindingOfType: aClass announcing: aBool
	"Make the receiver a global binding of the given type"
	| old new |
	(Smalltalk associationAt: self key) == self
		ifFalse:[^self error:'Not a global variable binding'].
	self class == aClass ifTrue:[^self].
	old _ self.
	new _ aClass key: self key value: self value.
	old become: new.
	"NOTE: Now self == read-only (e.g., the new binding)"
	^self recompileBindingsAnnouncing: aBool! !

!LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:50'!
beReadOnlyBinding
	"Make the receiver (a global read-write binding) be a read-only binding"
	^self beReadOnlyBindingAnnouncing: true! !

!LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:50'!
beReadOnlyBindingAnnouncing: aBool
	"Make the receiver (a global read-write binding) be a read-only binding"
	^self beBindingOfType: ReadOnlyVariableBinding announcing: aBool! !

!LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:50'!
beReadWriteBinding
	"Make the receiver (a global read-only binding) be a read-write binding"
	^self beReadWriteBindingAnnouncing: true! !

!LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:51'!
beReadWriteBindingAnnouncing: aBool
	"Make the receiver (a global read-write binding) be a read-write binding"
	^self beBindingOfType: Association announcing: aBool! !

!LookupKey methodsFor: 'bindings' stamp: 'dvf 8/23/2003 11:50'!
recompileBindingsAnnouncing: aBool 
	"Make the receiver (a global read-write binding) be a read-only binding"

	aBool 
		ifTrue: 
			[Utilities informUserDuring: 
					[:bar | 
					(self systemNavigation allCallsOn: self) do: 
							[:mref | 
							bar value: 'Recompiling ' , mref asStringOrText.
							mref actualClass recompile: mref methodSymbol]]]
		ifFalse: 
			[(self systemNavigation allCallsOn: self) 
				do: [:mref | mref actualClass recompile: mref methodSymbol]]! !


!LookupKey methodsFor: 'comparing'!
< aLookupKey 
	"Refer to the comment in Magnitude|<."

	^key < aLookupKey key! !

!LookupKey methodsFor: 'comparing'!
= aLookupKey

	self species = aLookupKey species
		ifTrue: [^key = aLookupKey key]
		ifFalse: [^false]! !

!LookupKey methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^key hash! !

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

	^key hashMappedBy: map! !

!LookupKey methodsFor: 'comparing' stamp: 'di 9/27/97 20:45'!
identityHashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^ key identityHashMappedBy: map! !


!LookupKey methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 02:35'!
writeOnFilterStream: aStream

	aStream write:key.! !


!LookupKey methodsFor: 'printing'!
printOn: aStream

	key printOn: aStream! !


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

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

LookupKey class
	instanceVariableNames: ''!

!LookupKey class methodsFor: 'instance creation' stamp: 'md 6/29/2005 16:34'!
key: aKey 
	"Answer an instance of me with the argument as the lookup up."

	^self basicNew key: aKey! !
Object subclass: #LoopbackStringSocket
	instanceVariableNames: 'associate inArrays outArrays'
	classVariableNames: 'WRITESTRINGSIZES'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!LoopbackStringSocket commentStamp: '<historical>' prior: 0!
a string socket which is connected to another string sockt on the local computer.  Used mostly for testing.!


!LoopbackStringSocket methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
destroy

	associate := inArrays := outArrays := nil.! !


!LoopbackStringSocket methodsFor: 'I/O' stamp: 'ls 3/21/2000 23:40'!
flush! !

!LoopbackStringSocket methodsFor: 'I/O' stamp: 'ls 3/18/2000 13:27'!
isConnected
	^true! !

!LoopbackStringSocket methodsFor: 'I/O' stamp: 'RAA 7/22/2000 07:47'!
nextOrNil

	inArrays ifNil: [^nil].

	inArrays isEmpty 
		ifTrue: [ ^nil ]
		ifFalse: [
			^inArrays removeFirst. ]	! !

!LoopbackStringSocket methodsFor: 'I/O' stamp: 'sd 11/20/2005 21:25'!
nextPut: aStringArray

	inArrays ifNil: [^self].

	outArrays add: aStringArray.
	"WRITESTRINGSIZES ifNil: [WRITESTRINGSIZES := Bag new].
	aStringArray do: [ :each | WRITESTRINGSIZES add: each size]."! !

!LoopbackStringSocket methodsFor: 'I/O' stamp: 'RAA 7/22/2000 07:48'!
processIO

	inArrays ifNil: [^self].

	associate arraysFromAssociate: outArrays.
	outArrays := OrderedCollection new.! !


!LoopbackStringSocket methodsFor: 'initialization' stamp: 'ls 3/18/2000 13:28'!
associate: aLoopbackStringSocket
	associate := aLoopbackStringSocket.
	inArrays := OrderedCollection new.
	outArrays := OrderedCollection new.! !


!LoopbackStringSocket methodsFor: 'private' stamp: 'RAA 7/22/2000 07:47'!
arraysFromAssociate: arrays
	"new string-arrays have arrived from our associate"

	inArrays ifNil: [^self].
	inArrays addAll: arrays.! !

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

LoopbackStringSocket class
	instanceVariableNames: ''!

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

	WRITESTRINGSIZES := nil! !

!LoopbackStringSocket class methodsFor: 'as yet unclassified' stamp: 'RAA 7/22/2000 08:15'!
stats

	^WRITESTRINGSIZES! !


!LoopbackStringSocket class methodsFor: 'instance creation' stamp: 'ls 3/18/2000 13:24'!
newPair
	"create a connected pair of sockets"
	| a b |
	a := self new.
	b := self new.
	a associate: b.
	b associate: a.
	^{a. b}! !
AbstractSound subclass: #LoopedSampledSound
	instanceVariableNames: 'initialCount count releaseCount sampleCountForRelease leftSamples rightSamples originalSamplingRate perceivedPitch gain firstSample lastSample loopEnd scaledLoopLength scaledIndex scaledIndexIncr'
	classVariableNames: 'FloatLoopIndexScaleFactor LoopIndexFractionMask LoopIndexScaleFactor'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!LoopedSampledSound commentStamp: '<historical>' prior: 0!
I respresent a sequence of sound samples, often used to record a single note played by a real instrument. I can be pitch-shifted up or down, and can include a looped portion to allow a sound to be sustained indefinitely.
!


!LoopedSampledSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
beUnlooped

	scaledLoopLength := 0.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:26'!
duration
	"Answer the duration of this sound in seconds."

	^ initialCount asFloat / self samplingRate asFloat
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration: seconds

	super duration: seconds.
	count := initialCount := (seconds * self samplingRate) rounded.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:25'!
firstSample

	^ firstSample
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
firstSample: aNumber

	firstSample := (aNumber asInteger max: 1) min: lastSample.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/3/1998 18:52'!
gain

	^ gain
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
gain: aNumber

	gain := aNumber asFloat.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:26'!
isLooped

	^ scaledLoopLength ~= 0.  "zero loop length means unlooped"
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:14'!
isStereo

	^ leftSamples ~~ rightSamples
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'!
leftSamples

	^ leftSamples
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
leftSamples: aSampleBuffer

	leftSamples := aSampleBuffer.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 09:35'!
loopEnd

	^ loopEnd
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:12'!
loopLength

	^ scaledLoopLength / FloatLoopIndexScaleFactor
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 10/14/1998 16:26'!
originalSamplingRate

	^ originalSamplingRate
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:54'!
perceivedPitch

	^ perceivedPitch
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 09:08'!
pitch

	^ (scaledIndexIncr asFloat * perceivedPitch * self samplingRate asFloat) /
	  (originalSamplingRate * FloatLoopIndexScaleFactor)
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
pitch: p

	scaledIndexIncr :=
		((p asFloat * originalSamplingRate * FloatLoopIndexScaleFactor) /
		 (perceivedPitch * self samplingRate asFloat)) asInteger.

	sampleCountForRelease > 0
		ifTrue: [releaseCount := (sampleCountForRelease * LoopIndexScaleFactor) // scaledIndexIncr]
		ifFalse: [releaseCount := 0].
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'!
rightSamples

	^ rightSamples
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
rightSamples: aSampleBuffer

	rightSamples := aSampleBuffer.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'zz 3/2/2004 08:18'!
samples
	"For compatibility with SampledSound. Just return my left channel (which is the only channel if I am mono)."

	^ leftSamples
! !


!LoopedSampledSound methodsFor: 'disk i/o' stamp: 'stephaneducasse 2/4/2006 20:41'!
comeFullyUpOnReload: smartRefStream
	"Convert my sample buffers from ByteArrays into SampleBuffers after raw loading from a DataStream. Answer myself."

	leftSamples == rightSamples
		ifTrue: [
			leftSamples := SoundBuffer fromByteArray: self leftSamples.
			rightSamples := leftSamples]
		ifFalse: [
			leftSamples := SoundBuffer fromByteArray: self leftSamples.
			rightSamples := SoundBuffer fromByteArray: self rightSamples].

! !

!LoopedSampledSound methodsFor: 'disk i/o' stamp: 'tk 9/25/2000 12:06'!
objectForDataStream: refStrm
    "Answer an object to store on a data stream, a copy of myself whose SampleBuffers have been converted into ByteArrays."

	refStrm replace: leftSamples with: leftSamples asByteArray.
	refStrm replace: rightSamples with: rightSamples asByteArray.
	"substitution will be made in DataStream nextPut:"
	^ self
! !


!LoopedSampledSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:41'!
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)."

	| reverseBytes |
	(self isStereo or: [self samplingRate ~= originalSamplingRate]) ifTrue: [
		^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream].

	"optimization: if I'm not stereo and sampling rates match, just store my buffer"
	reverseBytes := bigEndianFlag ~= SmalltalkImage current  isBigEndian.
	reverseBytes ifTrue: [leftSamples reverseEndianness].
	(aBinaryStream isKindOf: StandardFileStream)
		ifTrue: [  "optimization for files: write sound buffer directly to file"
			aBinaryStream next: (leftSamples size // 2) putAll: leftSamples startingAt: 1]  "size in words"
		ifFalse: [  "for non-file streams:"
			1 to: leftSamples monoSampleCount do: [:i | aBinaryStream int16: (leftSamples at: i)]].
	reverseBytes ifTrue: [leftSamples reverseEndianness].  "restore to original endianness"
! !


!LoopedSampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
addReleaseEnvelope
	"Add a simple release envelope to this sound."

	| p env |
	p := OrderedCollection new.
	p add: 0@1.0; add: 10@1.0; add: 100@1.0; add: 120@0.0.
	env := (VolumeEnvelope points: p loopStart: 2 loopEnd: 3) target: self.
	envelopes size > 0 ifTrue: [  "remove any existing volume envelopes"
		envelopes copy do: [:e |
			(e isKindOf: VolumeEnvelope) ifTrue: [self removeEnvelope: e]]].
	self addEnvelope: env.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
computeSampleCountForRelease
	"Calculate the number of samples before the end of the note after which looping back will be be disabled. The units of this value, sampleCountForRelease, are samples at the original sampling rate. When playing a specific note, this value is converted to releaseCount, which is number of samples to be computed at the current pitch and sampling rate."
	"Details: For short loops, set the sampleCountForRelease to the loop length plus the number of samples between loopEnd and lastSample. Otherwise, set it to 1/10th of a second worth of samples plus the number of samples between loopEnd and lastSample. In this case, the trailing samples will be played only if the last loop-back occurs within 1/10th of a second of the total note duration, and the note may be shortened by up to 1/10th second. For long loops, this is the best we can do."

	(scaledLoopLength > 0 and: [lastSample > loopEnd])
		ifTrue: [
			sampleCountForRelease := (lastSample - loopEnd) +
				(self loopLength min: (originalSamplingRate / 10.0)) asInteger]
		ifFalse: [sampleCountForRelease := 0].

	releaseCount := sampleCountForRelease.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag
	"Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."

	| aiffFileReader |
	aiffFileReader := AIFFFileReader new.
	aiffFileReader readFromFile: fileName
		mergeIfStereo: mergeFlag
		skipDataChunk: false.
	aiffFileReader isLooped
		ifTrue: [
			self samples: aiffFileReader leftSamples
				loopEnd: aiffFileReader loopEnd
				loopLength: aiffFileReader loopLength
				pitch: aiffFileReader pitch
				samplingRate: aiffFileReader samplingRate]
		ifFalse: [
			self unloopedSamples: aiffFileReader leftSamples
				pitch: aiffFileReader pitch
				samplingRate: aiffFileReader samplingRate].

	"the following must be done second, since the initialization above sets
	 leftSamples and rightSamples to the same sample data"
	aiffFileReader isStereo
		ifTrue: [rightSamples := aiffFileReader rightSamples].

	initialCount := (leftSamples size * self samplingRate) // originalSamplingRate.
	self loudness: 1.0.

	self addReleaseEnvelope.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag
	"Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."

	aiffFileReader isLooped
		ifTrue: [
			self samples: aiffFileReader leftSamples
				loopEnd: aiffFileReader loopEnd
				loopLength: aiffFileReader loopLength
				pitch: aiffFileReader pitch
				samplingRate: aiffFileReader samplingRate]
		ifFalse: [
			self unloopedSamples: aiffFileReader leftSamples
				pitch: aiffFileReader pitch
				samplingRate: aiffFileReader samplingRate].

	"the following must be done second, since the initialization above sets
	 leftSamples and rightSamples to the same sample data"
	aiffFileReader isStereo
		ifTrue: [rightSamples := aiffFileReader rightSamples].

	initialCount := (leftSamples size * self samplingRate) // originalSamplingRate.
	self loudness: 1.0.

	self addReleaseEnvelope.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"This default initialization creates a loop consisting of a single cycle of a sine wave."
	"(LoopedSampledSound pitch: 440.0 dur: 1.0 loudness: 0.4) play"

	| samples |
	super initialize.
	samples := FMSound sineTable.
	self samples: samples
		loopEnd: samples size
		loopLength: samples size
		pitch: 1.0
		samplingRate: samples size.
	self addReleaseEnvelope.
	self setPitch: 440.0 dur: 1.0 loudness: 0.5.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz
	"Make this sound use the given samples array with a loop of the given length starting at the given index. The loop length may have a fractional part; this is necessary to achieve pitch accuracy for short loops."

	| loopStartIndex |
	super initialize.
	loopStartIndex := (loopEndIndex - loopSampleCount) truncated + 1.
	((1 <= loopStartIndex) and:
	 [loopStartIndex < loopEndIndex and:
	 [loopEndIndex <= aSoundBuffer size]])
		ifFalse: [self error: 'bad loop parameters'].

	leftSamples := rightSamples := aSoundBuffer.
	originalSamplingRate := samplingRateInHz asFloat.
	perceivedPitch := perceivedPitchInHz asFloat.
	gain := 1.0.
	firstSample := 1.
	lastSample := leftSamples size.
	lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [
		self error: 'cannot handle more than ',
			(SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples'].
	loopEnd := loopEndIndex.
	scaledLoopLength := (loopSampleCount * LoopIndexScaleFactor) asInteger.
	scaledIndexIncr := (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate.
	self computeSampleCountForRelease.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:09'!
setPitch: pitchNameOrNumber dur: d loudness: vol
	"(LoopedSampledSound pitch: 440.0 dur: 2.5 loudness: 0.4) play"

	super setPitch: pitchNameOrNumber dur: d loudness: vol.
	self pitch: (self nameOrNumberToPitch: pitchNameOrNumber).
	self reset.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz
	"Make this sound play the given samples unlooped. The samples have the given perceived pitch when played at the given sampling rate. By convention, unpitched sounds such as percussion sounds should specify a pitch of nil or 100 Hz."

	super initialize.
	leftSamples := rightSamples := aSoundBuffer.
	originalSamplingRate := samplingRateInHz asFloat.
	perceivedPitchInHz
		ifNil: [perceivedPitch := 100.0]
		ifNotNil: [perceivedPitch := perceivedPitchInHz asFloat].
	gain := 1.0.
	firstSample := 1.
	lastSample := leftSamples size.
	lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [
		self error: 'cannot handle more than ',
			(SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples'].
	loopEnd := leftSamples size.
	scaledLoopLength := 0.  "zero length means unlooped"
	scaledIndexIncr := (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate.
	self computeSampleCountForRelease.
! !


!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 08:19'!
copyDownSampledLowPassFiltering: doFiltering
	"Answer a copy of the receiver at half its sampling rate. The result consumes half the memory space, but has only half the frequency range of the original. If doFiltering is true, the original sound buffers are low-pass filtered before down-sampling. This is slower, but prevents aliasing of any high-frequency components of the original signal. (While it may be possible to avoid low-pass filtering when down-sampling from 44.1 kHz to 22.05 kHz, it is probably essential when going to lower sampling rates.)"

	^ self copy downSampleLowPassFiltering: doFiltering
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
edit
	"Open a WaveEditor on this sound."

	| loopLen ed |
	loopLen := scaledLoopLength asFloat / LoopIndexScaleFactor.
	ed := WaveEditor new
		data: leftSamples;
		samplingRate: originalSamplingRate;
		loopEnd: loopEnd;
		loopLength: loopLen;
		loopCycles: (loopLen / (originalSamplingRate asFloat / perceivedPitch)) rounded.
	ed openInWorld.
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
fftAt: startIndex
	"Answer the Fast Fourier Transform (FFT) of my samples (only the left channel, if stereo) starting at the given index."

	| availableSamples fftWinSize |
	availableSamples := (leftSamples size - startIndex) + 1.
	fftWinSize := 2 raisedTo: (((availableSamples - 1) log: 2) truncated + 1).
	fftWinSize := fftWinSize min: 4096.
	fftWinSize > availableSamples ifTrue: [fftWinSize := fftWinSize / 2].
	^ self fftWindowSize: fftWinSize startingAt: startIndex
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
findStartPointAfter: index
	"Answer the index of the last zero crossing sample before the given index."

	| i |
	i := index min: lastSample.

	"scan backwards to the last zero-crossing"
	(leftSamples at: i) > 0
		ifTrue: [
			[i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i := i - 1]]
		ifFalse: [
			[i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i := i - 1]].
	^ i
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
findStartPointForThreshold: threshold
	"Answer the index of the last zero crossing sample before the first sample whose absolute value (in either the right or left channel) exceeds the given threshold."

	| i |
	i := self indexOfFirstPointOverThreshold: threshold.
	i >= lastSample ifTrue: [^ self error: 'no sample exceeds the given threshold'].

	"scan backwards to the last zero-crossing"
	(leftSamples at: i) > 0
		ifTrue: [
			[i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i := i - 1]]
		ifFalse: [
			[i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i := i - 1]].
	^ i
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
highestSignificantFrequencyAt: startIndex
	"Answer the highest significant frequency in the sample window starting at the given index. The a frequency is considered significant if it's power is at least 1/50th that of the maximum frequency component in the frequency spectrum."

	| fft powerArray threshold indices |
	fft := self fftAt: startIndex.
	powerArray := self normalizedResultsFromFFT: fft.
	threshold := powerArray max / 50.0.
	indices := (1 to: powerArray size) select: [:i | (powerArray at: i) > threshold].
	^ originalSamplingRate / (fft samplesPerCycleForIndex: indices last)
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
indexOfFirstPointOverThreshold: threshold
	"Answer the index of the first sample whose absolute value exceeds the given threshold."

	| s |
	leftSamples == rightSamples
		ifTrue: [
			1 to: lastSample do: [:i |
				s := leftSamples at: i.
				s < 0 ifTrue: [s := 0 - s].
				s > threshold ifTrue: [^ i]]]
		ifFalse: [
			1 to: lastSample do: [:i |
				s := leftSamples at: i.
				s < 0 ifTrue: [s := 0 - s].
				s > threshold ifTrue: [^ i].
				s := rightSamples at: i.
				s < 0 ifTrue: [s := 0 - s].
				s > threshold ifTrue: [^ i]]].
	^ lastSample + 1
! !


!LoopedSampledSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy.  If a loop length is specified, then the index is looped back when the loopEnd index is reached until count drops below releaseCount. This allows a short sampled sound to be sustained indefinitely."
	"(LoopedSampledSound pitch: 440.0 dur: 5.0 loudness: 0.5) play"

	| lastIndex sampleIndex i s compositeLeftVol compositeRightVol nextSampleIndex m isInStereo rightVal leftVal |
	<primitive:'primitiveMixLoopedSampledSound' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #leftSamples declareC: 'short int *leftSamples'.
	self var: #rightSamples declareC: 'short int *rightSamples'.

	isInStereo := leftSamples ~~ rightSamples.
	compositeLeftVol := (leftVol * scaledVol) // ScaleFactor.
	compositeRightVol :=  (rightVol * scaledVol) // ScaleFactor.

	i := (2 * startIndex) - 1.
	lastIndex := (startIndex + n) - 1.
	startIndex to: lastIndex do: [:sliceIndex |
		sampleIndex := (scaledIndex := scaledIndex + scaledIndexIncr) // LoopIndexScaleFactor.
		((sampleIndex > loopEnd) and: [count > releaseCount]) ifTrue: [
			"loop back if not within releaseCount of the note end"
			"note: unlooped sounds will have loopEnd = lastSample"
			sampleIndex := (scaledIndex := scaledIndex - scaledLoopLength) // LoopIndexScaleFactor].
		(nextSampleIndex := sampleIndex + 1) > lastSample ifTrue: [
			sampleIndex > lastSample ifTrue: [count := 0. ^ nil].  "done!!"
			scaledLoopLength = 0
				ifTrue: [nextSampleIndex := sampleIndex]
				ifFalse: [nextSampleIndex := ((scaledIndex - scaledLoopLength) // LoopIndexScaleFactor) + 1]].

		m := scaledIndex bitAnd: LoopIndexFractionMask.
		rightVal := leftVal :=
			(((leftSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) +
			 ((leftSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor.
		isInStereo ifTrue: [
			rightVal :=
				(((rightSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) +
				 ((rightSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor].

		leftVol > 0 ifTrue: [
			s := (aSoundBuffer at: i) + ((compositeLeftVol * leftVal) // ScaleFactor).
			s >  32767 ifTrue: [s :=  32767].  "clipping!!"
			s < -32767 ifTrue: [s := -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
		i := i + 1.
		rightVol > 0 ifTrue: [
			s := (aSoundBuffer at: i) + ((compositeRightVol * rightVal) // ScaleFactor).
			s >  32767 ifTrue: [s :=  32767].  "clipping!!"
			s < -32767 ifTrue: [s := -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
		i := i + 1.

		scaledVolIncr ~= 0 ifTrue: [  "update volume envelope if it is changing"
			scaledVol := scaledVol + scaledVolIncr.
			((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
			 [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
				ifTrue: [  "reached the limit; stop incrementing"
					scaledVol := scaledVolLimit.
					scaledVolIncr := 0].
			compositeLeftVol := (leftVol * scaledVol) // ScaleFactor.
			compositeRightVol :=  (rightVol * scaledVol) // ScaleFactor]].

	count := count - n.
! !

!LoopedSampledSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset

	super reset.
	count := initialCount.
	scaledIndex := firstSample * LoopIndexScaleFactor.
! !

!LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 8/18/1998 09:31'!
samplesRemaining
	"Answer the number of samples remaining until the end of this sound."

	^ count
! !

!LoopedSampledSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds."

	count := (mSecs * self samplingRate) // 1000.
! !


!LoopedSampledSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
downSampleLowPassFiltering: doFiltering
	"Cut my sampling rate in half. Use low-pass filtering (slower) if doFiltering is true."
	"Note: This operation loses information, and modifies the receiver in place."

	| stereo newLoopLength |
	stereo := self isStereo.
	leftSamples := leftSamples downSampledLowPassFiltering: doFiltering.
	stereo
		ifTrue: [rightSamples := rightSamples downSampledLowPassFiltering: doFiltering]
		ifFalse: [rightSamples := leftSamples].
	originalSamplingRate := originalSamplingRate / 2.0.
	loopEnd odd
		ifTrue: [newLoopLength := (self loopLength / 2.0) + 0.5]
		ifFalse: [newLoopLength := self loopLength / 2.0].
	firstSample := (firstSample + 1) // 2.
	lastSample := (lastSample + 1) // 2.
	loopEnd := (loopEnd + 1) // 2.
	scaledLoopLength := (newLoopLength * LoopIndexScaleFactor) asInteger.
	scaledIndexIncr := scaledIndexIncr // 2.
! !

!LoopedSampledSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
fftWindowSize: windowSize startingAt: startIndex
	"Answer a Fast Fourier Transform (FFT) of the given number of samples starting at the given index (the left channel only, if stereo). The window size will be rounded up to the nearest power of two greater than the requested size. There must be enough samples past the given starting index to accomodate this window size."

	| nu n fft |
	nu := ((windowSize - 1) log: 2) truncated + 1.
	n := 2 raisedTo: nu.
	fft := FFT new nu: nu.
	fft realData: ((startIndex to: startIndex + n - 1) collect: [:i | leftSamples at: i]).
	^ fft transformForward: true.
! !

!LoopedSampledSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
normalizedResultsFromFFT: fft
	"Answer an array whose size is half of the FFT window size containing power in each frequency band, normalized to the average power over the entire FFT. A value of 10.0 in this array thus means that the power at the corresponding frequences is ten times the average power across the entire FFT."

	| r avg |
	r := (1 to: fft realData size // 2) collect:
		[:i | ((fft realData at: i) squared + (fft imagData at: i) squared) sqrt].
	avg := r sum / r size.
	^ r collect: [:v | v / avg].
! !

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

LoopedSampledSound class
	instanceVariableNames: ''!

!LoopedSampledSound class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"LoopedSampledSound initialize"

	LoopIndexScaleFactor := 512.
	FloatLoopIndexScaleFactor := LoopIndexScaleFactor asFloat.
	LoopIndexFractionMask := LoopIndexScaleFactor - 1.
! !


!LoopedSampledSound class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag
	"Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."

	| aiffFileReader |
	aiffFileReader := AIFFFileReader new.
	aiffFileReader readFromFile: fileName
		mergeIfStereo: mergeFlag
		skipDataChunk: false.
	self new fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag! !

!LoopedSampledSound class methodsFor: 'instance creation' stamp: 'jm 8/18/1998 07:40'!
samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz
	"See the comment in the instance method of this name."

	^ self basicNew
		samples: aSoundBuffer
		loopEnd: loopEndIndex
		loopLength: loopSampleCount
		pitch: perceivedPitchInHz
		samplingRate: samplingRateInHz
! !

!LoopedSampledSound class methodsFor: 'instance creation' stamp: 'jm 8/18/1998 07:41'!
unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz
	"See the comment in the instance method of this name."

	^ self basicNew
		unloopedSamples: aSoundBuffer
		pitch: perceivedPitchInHz
		samplingRate: samplingRateInHz
! !
MCPatchOperation subclass: #MCAddition
	instanceVariableNames: 'definition'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Patching'!

!MCAddition methodsFor: 'accessing' stamp: 'ab 5/24/2003 16:11'!
applyTo: anObject
	anObject addDefinition: definition! !

!MCAddition methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:09'!
baseDefinition
	^ nil! !

!MCAddition methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:32'!
definition
	^ definition! !

!MCAddition methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:45'!
fromSource
	^ ''! !

!MCAddition methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:39'!
sourceString
	^(self toSource asText)
		addAttribute: TextColor red;
		yourself! !

!MCAddition methodsFor: 'accessing' stamp: 'ab 5/13/2003 12:18'!
summary
	^ definition summary! !

!MCAddition methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:17'!
targetClass
	^definition actualClass ! !

!MCAddition methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:09'!
targetDefinition
	^ definition! !

!MCAddition methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:45'!
toSource
	^ definition source! !


!MCAddition methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 02:26'!
inverse
	^ MCRemoval of: definition! !

!MCAddition methodsFor: 'as yet unclassified' stamp: 'nk 2/25/2005 17:28'!
isClassPatch
	^definition isClassDefinition! !


!MCAddition methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
intializeWithDefinition: aDefinition
	definition := aDefinition! !


!MCAddition methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:22'!
isAddition
	^ true! !

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

MCAddition class
	instanceVariableNames: ''!

!MCAddition class methodsFor: 'as yet unclassified' stamp: 'cwp 11/27/2002 10:03'!
of: aDefinition
	^ self new intializeWithDefinition: aDefinition! !
Object subclass: #MCAncestry
	instanceVariableNames: 'ancestors stepChildren'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!
!MCAncestry commentStamp: '<historical>' prior: 0!
Abstract superclass of records of ancestry.!


!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'!
allAncestorsDo: aBlock
	self ancestors do:
		[:ea |
		aBlock value: ea.
		ea allAncestorsDo: aBlock]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'!
allAncestorsOnPathTo: aVersionInfo
	^ MCFilteredVersionSorter new
		target: aVersionInfo;
		addAllVersionInfos: self ancestors;
		sortedVersionInfos! !

!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'!
ancestorString
	^ String streamContents:
		[:s | self ancestors do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'!
ancestors
	^ ancestors ifNil: [#()]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'bf 12/22/2004 21:55'!
ancestorsDoWhileTrue: aBlock
	self ancestors do:
		[:ea |
		(aBlock value: ea) ifTrue: 
			[ea ancestorsDoWhileTrue: aBlock]]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/17/2005 16:03'!
breadthFirstAncestors
	^ Array streamContents: [:s | self breadthFirstAncestorsDo: [:ea | s nextPut: ea]]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'!
breadthFirstAncestorsDo: aBlock
	| seen todo next |
	seen := Set with: self.
	todo := OrderedCollection with: self.
	[todo isEmpty] whileFalse:
		[next := todo removeFirst.
		next ancestors do:
			[:ea |
			(seen includes: ea) ifFalse:
				[aBlock value: ea.
				seen add: ea.
				todo add: ea]]]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'!
commonAncestorsWith: aVersionInfo

	| sharedAncestors mergedOrder sorter |
	sorter := MCVersionSorter new
						addVersionInfo: self;
						addVersionInfo: aVersionInfo.
	mergedOrder := sorter sortedVersionInfos.
	sharedAncestors := (sorter allAncestorsOf: self) intersection: (sorter allAncestorsOf: aVersionInfo).
	^ mergedOrder select: [:ea | sharedAncestors includes: ea]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'!
commonAncestorWith: aNode
	| commonAncestors |
	commonAncestors := self commonAncestorsWith: aNode.
	^ commonAncestors at: 1 ifAbsent: [nil]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'jrp 7/12/2004 08:16'!
hasAncestor: aVersionInfo
	^ self
		hasAncestor: aVersionInfo
		alreadySeen: OrderedCollection new! !

!MCAncestry methodsFor: 'ancestry' stamp: 'jrp 7/12/2004 08:16'!
hasAncestor: aVersionInfo alreadySeen: aList
	(aList includes: self) ifTrue: [^ false].
	aList add: self.

	^ self = aVersionInfo or: [self ancestors anySatisfy: [:ea | ea hasAncestor: aVersionInfo alreadySeen: aList]]
! !

!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:58'!
isRelatedTo: aVersionInfo
	^ aVersionInfo timeStamp < self timeStamp
		ifTrue: [self hasAncestor: aVersionInfo]
		ifFalse: [aVersionInfo hasAncestor: self]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/11/2004 15:08'!
stepChildren
	^ stepChildren ifNil: [#()]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/14/2004 15:21'!
stepChildrenString
	^ String streamContents:
		[:s | self stepChildren do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! !

!MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'!
topologicalAncestors
	| frontier f |
	^ Array streamContents:
		[:s |
		frontier := MCFrontier frontierOn: self.
		[f := frontier frontier.
		s nextPutAll: f.
		frontier removeAll: f.
		f isEmpty] whileFalse] ! !

!MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/17/2005 16:03'!
withBreadthFirstAncestors
	^ (Array with: self), self breadthFirstAncestors! !


!MCAncestry methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	ancestors := #().
	stepChildren := #()! !

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

MCAncestry class
	instanceVariableNames: ''!

!MCAncestry class methodsFor: 'as yet unclassified' stamp: 'avi 2/12/2004 21:02'!
new
	^ self basicNew initialize! !
MCTestCase subclass: #MCAncestryTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCAncestryTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertCommonAncestorOf: leftName and: rightName in: options in: tree
	| left right ancestor |
	left := self versionForName: leftName in: tree.
	right := self versionForName: rightName in: tree.
	
	ancestor := left commonAncestorWith: right.
	
	self assert: (options includes: ancestor name)! !

!MCAncestryTest methodsFor: 'asserting' stamp: 'avi 9/17/2005 21:09'!
assertCommonAncestorOf: leftName and: rightName is: ancestorName in: tree
	self assertCommonAncestorOf: leftName and: rightName in: (Array with: ancestorName) in: tree! !

!MCAncestryTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertNamesOf: versionInfoCollection are: nameArray
	| names |
	names := versionInfoCollection collect: [:ea | ea name].
	
	self assert: names asArray = nameArray! !

!MCAncestryTest methodsFor: 'asserting' stamp: 'jf 8/16/2003 23:42'!
assertPathTo: aSymbol is: anArray
	self
		assertNamesOf: (self tree allAncestorsOnPathTo: (self treeFrom: {aSymbol}))
		are: anArray! !


!MCAncestryTest methodsFor: 'building' stamp: 'jf 8/16/2003 21:21'!
tree
	^ self treeFrom:
		#(c1
			((e2
				((e1
					((a1
						(('00')))))))
			(a2
				((a1
					(('00')))))
			(b3
				((b2
					((b1
						((b0
							(('00')))))))
				(a1
					(('00')))))
			(d1)))! !

!MCAncestryTest methodsFor: 'building' stamp: 'jf 8/16/2003 22:55'!
twoPersonTree
	^ self treeFrom:
		#(c1
			((a4
				((a1)
				(b3
					((b2
						((a1)))))))
			(b5
				((b2
					((a1)))))))! !

!MCAncestryTest methodsFor: 'building' stamp: 'jf 8/16/2003 23:14'!
versionForName: name in: tree
	(tree name = name) ifTrue: [^ tree].
	
	tree ancestors do: [:ea | (self versionForName: name in: ea) ifNotNilDo: [:v | ^ v]].
	
	^ nil! !


!MCAncestryTest methodsFor: 'tests' stamp: 'avi 9/17/2005 21:08'!
testCommonAncestors
	self assertCommonAncestorOf: #a2 and: #e2 is: #a1 in: self tree.
	self assertCommonAncestorOf: #e2 and: #b3 is: #a1 in: self tree.
	self assertCommonAncestorOf: #b2 and: #e2 is: #'00' in: self tree.
	
	self assertCommonAncestorOf: #a4 and: #b5 in: #(b2 a1) in: self twoPersonTree.
	self assertCommonAncestorOf: #b5 and: #b3 is: #b2 in: self twoPersonTree.
	self assertCommonAncestorOf: #b2 and: #a4 is: #b2 in: self twoPersonTree.
	self assertCommonAncestorOf: #b2 and: #b2 is: #b2 in: self twoPersonTree.
	self assertCommonAncestorOf: #b2 and: #a1 is: #a1 in: self twoPersonTree.
	self assertCommonAncestorOf: #a1 and: #b2 is: #a1 in: self twoPersonTree.! !

!MCAncestryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testDescendants
	| c1 a1 b3 q1 q2 c2 |
	c1 := self tree.
	a1 := self treeFrom: #(a1 (('00'))).
	b3 := self treeFrom: #(b3
				((b2
					((b1
						((b0
							(('00')))))))
				(a1
					(('00'))))).
	q1 := MCWorkingAncestry new addAncestor: a1.
	q2 := MCWorkingAncestry new addAncestor: q1.
	self assert: (q2 commonAncestorWith: b3) = a1.
	self assert: (b3 commonAncestorWith: q2) = a1.
	self assert: (q2 commonAncestorWith: c1) = a1.
	self assert: (c1 commonAncestorWith: q2) = a1.
	q1 addStepChild: c1.
	self assert: (q2 commonAncestorWith: c1) = q1.
	self assert: (c1 commonAncestorWith: q2) = q1.
	c2 := MCWorkingAncestry new addAncestor: c1.
	self assert: (q2 commonAncestorWith: c2) = q1.
	self assert: (c2 commonAncestorWith: q2) = q1.
! !

!MCAncestryTest methodsFor: 'tests' stamp: 'jf 8/16/2003 20:45'!
testLinearPath
	self assertPathTo: #b1 is: #(b3 b2)! !

!MCAncestryTest methodsFor: 'tests' stamp: 'jf 8/16/2003 20:42'!
testPathToMissingAncestor
	self assert: (self tree allAncestorsOnPathTo: MCVersionInfo new) isEmpty! !

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

MCAncestryTest class
	instanceVariableNames: ''!
MCDirectoryRepository subclass: #MCCacheRepository
	instanceVariableNames: 'packageCaches seenFiles'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'bf 3/23/2005 00:52'!
basicStoreVersion: aVersion
	(aVersion isCacheable and: [self allFileNames includes: aVersion fileName])
		ifFalse: [super basicStoreVersion: aVersion]
! !

!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
cacheForPackage: aPackage
	packageCaches ifNil: [packageCaches := Dictionary new].
	^ packageCaches at: aPackage ifAbsentPut: [MCPackageCache new]! !

!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:15'!
newFileNames 
	^ self allFileNames difference: self seenFileNames! !

!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 15:13'!
packageForFileNamed: aString
	^ self packageCache at: aString ifAbsentPut: [self versionReaderForFileNamed: aString do: [:r | r package]]! !

!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:29'!
rescan
	self newFileNames do:
		[:ea |
		self versionReaderForFileNamed: ea do:
			[:reader |
			(self cacheForPackage: reader package)
				recordVersionInfo: reader info
				forFileNamed: ea.
			self seenFileNames add: ea]]
		displayingProgress: 'Scanning cache...'! !

!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
seenFileNames
	^ seenFiles ifNil: [seenFiles := OrderedCollection new]! !

!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 15:05'!
versionInfoForFileNamed: aString
	^ self infoCache at: aString ifAbsentPut: [self versionReaderForFileNamed: aString do: [:r | r info]]! !

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

MCCacheRepository class
	instanceVariableNames: 'default'!

!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:46'!
cacheDirectory
	^ (FileDirectory default directoryNamed: 'package-cache')
		assureExistence;
		yourself! !

!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
checkCacheDirectory
	default notNil and: [default directory exists ifFalse: [default := nil]]! !

!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
default
	self checkCacheDirectory.
	^ default ifNil: [default := self new directory: self cacheDirectory]! !

!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:56'!
description
	^ nil! !

!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 16:21'!
initialize
	self checkCacheDirectory! !
MCTestCase subclass: #MCChangeNotificationTest
	instanceVariableNames: 'workingCopy'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCChangeNotificationTest methodsFor: 'events' stamp: 'cwp 11/6/2004 22:32'!
modifiedEventFor: aSelector ofClass: aClass
	| method |
	method := aClass compiledMethodAt: aSelector.
	^ ModifiedEvent 
				methodChangedFrom: method
				to: method
				selector: aSelector
				inClass: aClass.
! !


!MCChangeNotificationTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	workingCopy := MCWorkingCopy forPackage: self mockPackage.
	! !

!MCChangeNotificationTest methodsFor: 'running' stamp: 'bf 5/20/2005 17:02'!
tearDown
	workingCopy unregister! !


!MCChangeNotificationTest methodsFor: 'tests' stamp: 'bf 5/20/2005 19:54'!
testCoreMethodModified
	| event |
	workingCopy modified: false.
	event := self modifiedEventFor: #one ofClass: self mockClassA.
	MCWorkingCopy methodModified: event.
	self assert: workingCopy modified! !

!MCChangeNotificationTest methodsFor: 'tests' stamp: 'bf 5/20/2005 17:05'!
testExtMethodModified
	| event mref |
	workingCopy modified: false.
	mref := workingCopy packageInfo extensionMethods first.
	event := self modifiedEventFor: mref methodSymbol ofClass: mref actualClass.
	MCWorkingCopy methodModified: event.
	self assert: workingCopy modified! !

!MCChangeNotificationTest methodsFor: 'tests' stamp: 'bf 5/20/2005 17:00'!
testForeignMethodModified
	| event |
	workingCopy modified: false.
	event := self modifiedEventFor: #foreignMethod ofClass: self class.
	MCWorkingCopy methodModified: event.
	self deny: workingCopy modified! !


!MCChangeNotificationTest methodsFor: 'private' stamp: 'bf 5/20/2005 16:19'!
foreignMethod
	"see testForeignMethodModified"! !

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

MCChangeNotificationTest class
	instanceVariableNames: ''!
Notification subclass: #MCChangeSelectionRequest
	instanceVariableNames: 'patch label'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:01'!
defaultAction
	^ (MCChangeSelector new patch: patch; label: label) showModally! !

!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:02'!
label
	^ label! !

!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
label: aString
	label := aString! !

!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:12'!
patch
	^ patch! !

!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
patch: aPatch
	patch := aPatch! !

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

MCChangeSelectionRequest class
	instanceVariableNames: ''!
MCPatchBrowser subclass: #MCChangeSelector
	instanceVariableNames: 'kept'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:07'!
buttonSpecs
	^ #((Select select 'Select these changes')
		 (Cancel cancel 'Cancel the operation')
		)! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:26'!
cancel
	self answer: nil! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:01'!
defaultLabel
	^ 'Change Selector'! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:13'!
innerButtonRow
	^ self buttonRow:
		#(('Select All' selectAll 'select all changes')
		  ('Select None' selectNone 'select no changes'))! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
kept
	^ kept ifNil: [kept := Set new]! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:22'!
listSelectionAt: aNumber
	^ self kept includes: (self items at: aNumber)! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
listSelectionAt: aNumber put: aBoolean
	| item |
	item := self items at: aNumber.
	aBoolean
		ifTrue: [self kept add: item ]
		ifFalse: [self kept remove: item ifAbsent: []]! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:26'!
select
	self answer: (MCPatch operations: kept)! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:00'!
selectAll
	kept addAll: self items.
	self changed: #list! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
selectNone
	kept := Set new.
	self changed: #list! !

!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:25'!
widgetSpecs
	Preferences annotationPanes ifFalse: [ ^#(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((multiListMorph:selection:listSelection:menu: list selection listSelectionAt: methodListMenu:) (0 0 1 0.4) (0 30 0 0))
		((innerButtonRow) (0 0.4 1 0.4) (0 0 0 30))
		((textMorph: text) (0 0.4 1 1) (0 30 0 0))
		)].

	^ #(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((multiListMorph:selection:listSelection:menu: list selection listSelectionAt: methodListMenu:) (0 0 1 0.4) (0 30 0 0))
		((innerButtonRow) (0 0.4 1 0.4) (0 0 0 30))
		((textMorph: annotations) (0 0.4 1 0.4) (0 30 0 60))
		((textMorph: text) (0 0.4 1 1) (0 60 0 0))
		)! !

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

MCChangeSelector class
	instanceVariableNames: ''!
MCDefinition subclass: #MCClassDefinition
	instanceVariableNames: 'name superclassName variables category type comment commentStamp traitComposition classTraitComposition'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCClassDefinition methodsFor: 'accessing' stamp: 'nk 2/25/2005 09:49'!
actualClass
	^Smalltalk classNamed: self className! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/24/2002 06:23'!
category
	^ category! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:32'!
classInstVarNames
	^ self selectVariables: #isClassInstanceVariable! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:52'!
className
	^ name! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:07'!
classTraitComposition
	^classTraitComposition! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:55'!
classTraitCompositionString
	^self classTraitComposition ifNil: ['{}'].! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:33'!
classVarNames
	^ self selectVariables: #isClassVariable! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 1/15/2003 13:42'!
comment
	^ comment! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 8/10/2003 16:40'!
commentStamp
	^ commentStamp! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 12/5/2002 21:24'!
description
	^ Array with: name
! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:33'!
instVarNames
	^ self selectVariables: #isInstanceVariable! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:53'!
poolDictionaries
	^ self selectVariables: #isPoolImport! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:28'!
selectVariables: aSelector
	^ variables select: [:v | v perform: aSelector] thenCollect: [:v | v name]! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 7/19/2003 18:00'!
sortKey
	^ self className! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 17:41'!
superclassName
	^ superclassName! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:16'!
traitComposition
	^traitComposition! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:55'!
traitCompositionString
	^self traitComposition ifNil: ['{}'].! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/24/2002 22:35'!
type
	^ type! !

!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 06:51'!
variables
	^ variables! !


!MCClassDefinition methodsFor: 'annotations' stamp: 'nk 7/24/2003 16:05'!
printAnnotations: requests on: aStream
	"Add a string for an annotation pane, trying to fulfill the annotation requests.
	These might include anything that
		Preferences defaultAnnotationRequests 
	might return. Which includes anything in
		Preferences annotationInfo
	To edit these, use:"
	"Preferences editAnnotations"

	requests do: [ :aRequest |
		aRequest == #requirements ifTrue: [
			self requirements do: [ :req | aStream nextPutAll: req ] separatedBy: [ aStream space ]]
	] separatedBy: [ aStream space ].! !


!MCClassDefinition methodsFor: 'comparing' stamp: 'stephaneducasse 2/4/2006 20:47'!
hash
	| hash |
	hash := String stringHash: name initialHash: 0.
	hash := String stringHash: superclassName initialHash: hash.
	hash := String stringHash: self traitCompositionString initialHash: hash.
	hash := String stringHash: self classTraitComposition asString initialHash: hash.
	hash := String stringHash: (category ifNil: ['']) initialHash: hash.
	hash := String stringHash: type initialHash: hash.
	variables do: [
		:v |
		hash := String stringHash: v name initialHash: hash.
	].
	^ hash! !

!MCClassDefinition methodsFor: 'comparing' stamp: 'ab 5/24/2003 14:12'!
provisions
	^ Array with: name! !

!MCClassDefinition methodsFor: 'comparing' stamp: 'avi 2/17/2004 03:13'!
requirements
	^ (Array with: superclassName), self poolDictionaries! !


!MCClassDefinition methodsFor: 'initializing' stamp: 'cwp 7/7/2003 23:19'!
addVariables: aCollection ofType: aClass
	variables addAll: (aCollection collect: [:var | aClass name: var asString]).! !

!MCClassDefinition methodsFor: 'initializing' stamp: 'cwp 8/10/2003 17:39'!
defaultCommentStamp
	^ String new

	"The version below avoids stomping on stamps already in the image

	^ (Smalltalk at: name ifPresent: [:c | c organization commentStamp])
		ifNil: ['']
	"
! !


!MCClassDefinition methodsFor: 'installing' stamp: 'stephaneducasse 2/4/2006 20:47'!
createClass
	| superClass class |
	superClass := Smalltalk at: superclassName.
	class := (ClassBuilder new)
			name: name 
			inEnvironment: superClass environment 
			subclassOf: superClass
			type: type 
			instanceVariableNames: self instanceVariablesString 
			classVariableNames: self classVariablesString 
			poolDictionaries: self sharedPoolsString
			category: category.
	self traitComposition ifNotNil: [
		class setTraitComposition: (Compiler
			evaluate: self traitComposition) asTraitComposition ].
	self classTraitComposition ifNotNil: [
		class class setTraitComposition: (Compiler
			evaluate: self classTraitComposition) asTraitComposition ].
	^class.
! !

!MCClassDefinition methodsFor: 'installing' stamp: 'cwp 8/10/2003 17:03'!
load
	 self createClass ifNotNilDo:
		[:class |
		class class instanceVariableNames: self classInstanceVariablesString.
		self hasComment ifTrue: [class classComment: comment stamp: commentStamp]]! !

!MCClassDefinition methodsFor: 'installing' stamp: 'cwp 2/3/2004 21:35'!
stringForVariablesOfType: aSymbol
	^ String streamContents:
		[:stream |
		(self selectVariables: aSymbol) 
			do: [:ea | stream nextPutAll: ea]
			separatedBy: [stream space]]! !

!MCClassDefinition methodsFor: 'installing' stamp: 'ab 11/13/2002 19:39'!
unload
	Smalltalk removeClassNamed: name! !


!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:35'!
classInstanceVariablesString
	^ self stringForVariablesOfType: #isClassInstanceVariable! !

!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:36'!
classVariablesString
	^ self stringForVariablesOfType: #isClassVariable! !

!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 8/2/2003 02:03'!
definitionString
	^ String streamContents: [:stream | self printDefinitionOn: stream]! !

!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:35'!
instanceVariablesString
	^ self stringForVariablesOfType: #isInstanceVariable! !

!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 11/24/2002 22:16'!
kindOfSubclass
	type = #normal ifTrue: [^ ' subclass: '].
	type = #words ifTrue: [^ ' variableWordSubclass: '].
	type = #variable ifTrue: [^ ' variableSubclass: '].
	type = #bytes ifTrue: [^ ' variableByteSubclass: '].
	type = #weak ifTrue: [^ ' weakSubclass: ' ].
	type = #compiledMethod ifTrue: [^ ' variableByteSubclass: ' ].
	self error: 'Unrecognized class type'! !

!MCClassDefinition methodsFor: 'printing' stamp: 'al 3/28/2006 23:42'!
printDefinitionOn: stream
		stream 
			nextPutAll: self superclassName;
			nextPutAll: self kindOfSubclass;
			nextPut: $# ;
			nextPutAll: self className;
			cr; tab.
		self hasTraitComposition ifTrue: [
			stream 
				nextPutAll: 'uses: ';
		 		nextPutAll: self traitCompositionString;
				cr; tab ].
		stream
			nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString;
			cr; tab;
			nextPutAll: 'classVariableNames: ';
			store: self classVariablesString;
			cr; tab;
			nextPutAll: 'poolDictionaries: ';
			store: self sharedPoolsString;
			cr; tab;
			nextPutAll: 'category: ';
			store: self category asString! !

!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:54'!
sharedPoolsString
	^ self stringForVariablesOfType: #isPoolImport! !

!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/10/2003 01:29'!
source
	^ self definitionString! !

!MCClassDefinition methodsFor: 'printing' stamp: 'ab 11/16/2002 17:33'!
summary
	^ name! !


!MCClassDefinition methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithName: nameString
superclassName: superclassString
category: categoryString 
instVarNames: ivarArray
classVarNames: cvarArray
poolDictionaryNames: poolArray
classInstVarNames: civarArray
type: typeSymbol
comment: commentString
commentStamp: stampStringOrNil
	name := nameString asSymbol.
	superclassName := superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol].
	category := categoryString.
	name = #CompiledMethod ifTrue: [type := #compiledMethod] ifFalse: [type := typeSymbol].
	comment := commentString withSqueakLineEndings.
	commentStamp := stampStringOrNil ifNil: [self defaultCommentStamp].
	variables := OrderedCollection  new.
	self addVariables: ivarArray ofType: MCInstanceVariableDefinition.
	self addVariables: cvarArray ofType: MCClassVariableDefinition.
	self addVariables: poolArray ofType: MCPoolImportDefinition.
	self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.! !

!MCClassDefinition methodsFor: 'serializing' stamp: 'al 7/4/2006 10:14'!
storeDataOn: aDataStream
	| instVarSize |
	instVarSize := (self hasTraitComposition or: [ self hasClassTraitComposition ])
		ifTrue: [ self class instSize ]
		ifFalse: [ self class instSize - 2 ].
	aDataStream
		beginInstance: self class
		size: instVarSize.
	1 to: instVarSize do: [ :index |
		aDataStream nextPut: (self instVarAt: index) ].! !


!MCClassDefinition methodsFor: 'testing' stamp: 'cwp 8/2/2003 02:54'!
hasClassInstanceVariables
	^ (self selectVariables: #isClassInstanceVariable) isEmpty not! !

!MCClassDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 21:59'!
hasClassTraitComposition
	^self classTraitCompositionString ~= '{}'! !

!MCClassDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 20:13'!
hasComment
	^ comment isEmptyOrNil not! !

!MCClassDefinition methodsFor: 'testing' stamp: 'al 3/29/2006 00:27'!
hasTraitComposition
	^self traitCompositionString ~= '{}'! !

!MCClassDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:52'!
isClassDefinition
	^ true! !

!MCClassDefinition methodsFor: 'testing' stamp: 'ab 5/24/2003 13:49'!
isCodeDefinition
	^ true! !


!MCClassDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 19:33'!
accept: aVisitor
	aVisitor visitClassDefinition: self.
	(self hasClassInstanceVariables or: [self hasClassTraitComposition])
		ifTrue: [aVisitor visitMetaclassDefinition: self].
! !

!MCClassDefinition methodsFor: 'visiting' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithName: nameString
superclassName: superclassString
traitComposition: traitCompositionString
classTraitComposition: classTraitCompositionString
category: categoryString 
instVarNames: ivarArray
classVarNames: cvarArray
poolDictionaryNames: poolArray
classInstVarNames: civarArray
type: typeSymbol
comment: commentString
commentStamp: stampStringOrNil
	name := nameString asSymbol.
	superclassName := superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol].
	traitComposition := traitCompositionString.
	classTraitComposition := classTraitCompositionString.
	category := categoryString.
	name = #CompiledMethod ifTrue: [type := #compiledMethod] ifFalse: [type := typeSymbol].
	comment := commentString withSqueakLineEndings.
	commentStamp := stampStringOrNil ifNil: [self defaultCommentStamp].
	variables := OrderedCollection  new.
	self addVariables: ivarArray ofType: MCInstanceVariableDefinition.
	self addVariables: cvarArray ofType: MCClassVariableDefinition.
	self addVariables: poolArray ofType: MCPoolImportDefinition.
	self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.! !

!MCClassDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 22:02'!
= aDefinition
	^((super = aDefinition)
		and: [superclassName = aDefinition superclassName]
		and: [self traitCompositionString = aDefinition traitCompositionString]
		and: [self classTraitCompositionString = aDefinition classTraitCompositionString])
		and: [category = aDefinition category]
		and: [type = aDefinition type]
		and: [variables = aDefinition variables]
		and: [comment = aDefinition comment]
		! !

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

MCClassDefinition class
	instanceVariableNames: ''!

!MCClassDefinition class methodsFor: 'instance creation' stamp: 'al 10/9/2005 19:16'!
name: nameString
superclassName: superclassString
category: categoryString 
instVarNames: ivarArray
classVarNames: cvarArray
poolDictionaryNames: poolArray
classInstVarNames: civarArray
type: typeSymbol
comment: commentString
commentStamp: stampString
	^ self instanceLike:
		(self new initializeWithName: nameString
					superclassName: superclassString
					traitComposition: '{}'
					classTraitComposition: '{}'
					category: categoryString 
					instVarNames: ivarArray
					classVarNames: cvarArray
					poolDictionaryNames: poolArray
					classInstVarNames: civarArray
					type: typeSymbol
					comment: commentString
					commentStamp: stampString)! !

!MCClassDefinition class methodsFor: 'instance creation' stamp: 'al 10/10/2005 13:58'!
name: nameString
superclassName: superclassString
traitComposition: traitCompositionString
classTraitComposition: classTraitCompositionString
category: categoryString 
instVarNames: ivarArray
classVarNames: cvarArray
poolDictionaryNames: poolArray
classInstVarNames: civarArray
type: typeSymbol
comment: commentString
commentStamp: stampString
	
	^ self instanceLike:
		(self new initializeWithName: nameString
					superclassName: superclassString
					traitComposition: traitCompositionString
					classTraitComposition: classTraitCompositionString
					category: categoryString 
					instVarNames: ivarArray
					classVarNames: cvarArray
					poolDictionaryNames: poolArray
					classInstVarNames: civarArray
					type: typeSymbol
					comment: commentString
					commentStamp: stampString)! !


!MCClassDefinition class methodsFor: 'obsolete' stamp: 'ab 4/1/2003 01:22'!
name: nameString
superclassName: superclassString
category: categoryString 
instVarNames: ivarArray
classVarNames: cvarArray
poolDictionaryNames: poolArray
classInstVarNames: civarArray
comment: commentString
	^ self	name: nameString
			superclassName: superclassString
			category: categoryString 
			instVarNames: ivarArray
			classVarNames: cvarArray
			poolDictionaryNames: poolArray
			classInstVarNames: civarArray
			type: #normal
			comment: commentString
! !

!MCClassDefinition class methodsFor: 'obsolete' stamp: 'cwp 8/10/2003 16:33'!
name: nameString
superclassName: superclassString
category: categoryString 
instVarNames: ivarArray
classVarNames: cvarArray
poolDictionaryNames: poolArray
classInstVarNames: civarArray
type: typeSymbol
comment: commentString
	^ self 
		name: nameString
		superclassName: superclassString
		category: categoryString 
		instVarNames: ivarArray
		classVarNames: cvarArray
		poolDictionaryNames: poolArray
		classInstVarNames: civarArray
		type: typeSymbol
		comment: commentString
		commentStamp: nil! !

!MCClassDefinition class methodsFor: 'obsolete' stamp: 'ab 4/1/2003 01:22'!
name: nameString
superclassName: superclassString
category: categoryString 
instVarNames: ivarArray
comment: commentString
	^ self	name: nameString
			superclassName: superclassString
			category: categoryString 
			instVarNames: ivarArray
			classVarNames: #()
			poolDictionaryNames: #()
			classInstVarNames: #()
			comment: commentString
! !
MCTestCase subclass: #MCClassDefinitionTest
	instanceVariableNames: 'previousChangeSet'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:20'!
classAComment
	^ self class classAComment! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 17:17'!
creationMessage
	^ MessageSend
		receiver: MCClassDefinition
		selector: #name:superclassName:category:instVarNames:classVarNames:poolDictionaryNames:classInstVarNames:type:comment:commentStamp:! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 16:57'!
tearDown
	Smalltalk at: 'MCMockClassC' ifPresent: [:c | c removeFromSystem]! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testCannotLoad
	| d |
	d :=  self mockClass: 'MCMockClassC' super: 'NotAnObject'.
	self should: [d load] raise: Error.
	self deny: (Smalltalk hasClassNamed: 'MCMockClassC').! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testComparison
	| d1 d2 d3 d4 |
	d1 := self mockClass: 'A' super: 'X'.
	d2 := self mockClass: 'A' super: 'Y'.
	d3 := self mockClass: 'B' super: 'X'.
	d4 := self mockClass: 'B' super: 'X'.
	
	self assert: (d1 isRevisionOf: d2).
	self deny: (d1 isSameRevisionAs: d2).

	self assert: (d3 isRevisionOf: d4).
	self assert: (d3 isSameRevisionAs: d4).
	
	self deny: (d1 isRevisionOf: d3).
	self deny: (d4 isRevisionOf: d2).! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testCreation
	| d |
	d :=  self mockClassA asClassDefinition.
	self assert: d className = #MCMockClassA.
	self assert: d superclassName = #MCMock.
	self assert: d type = #normal.
	self assert: d category = self mockCategoryName.
	self assert: d instVarNames asArray = #('ivar').
	self assert: d classVarNames asArray = #('CVar').
	self assert: d classInstVarNames asArray = #().
	self assert: d comment isString.
	self assert: d comment = self classAComment.
	self assert: d commentStamp = self mockClassA organization commentStamp! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testDefinitionString
	| d |
	d := self mockClassA asClassDefinition.
	self assert: d definitionString = self mockClassA definition.! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testEquals
	| a b |
	a := self mockClass: 'ClassA' super: 'SuperA'.
	b := self mockClass: 'ClassA' super: 'SuperA'.
	self assert: a = b! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testEqualsSensitivity
	| message a b defA args defB |
	message := self creationMessage.
	a := #(ClassA SuperA CategoryA #(iVarA) #(CVarA) #(PoolA) #(ciVarA)
			typeA 'A comment' 'A').
	b := #(ClassB SuperB CategoryB #(iVarB) #(CVarB) #(PoolB) #(ciVarB)
			typeB 'B comment' 'B').
	
	defA := message valueWithArguments: a.
	1 to: 8 do: [:index |
				args := a copy.
				args at: index put: (b at: index).
				defB := message valueWithArguments: args.
				self deny: defA = defB.]! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testKindOfSubclass
	| classes d |
	classes := {self mockClassA. String. MethodContext. WeakArray. Float}.
	classes do: [:c |
		d :=  c asClassDefinition.
		self assert: d kindOfSubclass = c kindOfSubclass.
	].! !

!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testLoadAndUnload
	| d c |
	d :=  self mockClass: 'MCMockClassC' super: 'Object'.
	d load.
	self assert: (Smalltalk hasClassNamed: 'MCMockClassC').
	c := (Smalltalk classNamed: 'MCMockClassC').
	self assert: (c isKindOf: Class).
	self assert: c superclass = Object.
	self assert: c instVarNames isEmpty.
	self assert: c classVarNames isEmpty.
	self assert: c sharedPools isEmpty.
	self assert: c category = self mockCategoryName.
	self assert: c organization classComment = (self commentForClass: 'MCMockClassC').
	self assert: c organization commentStamp = (self commentStampForClass: 'MCMockClassC').
	d unload.
	self deny: (Smalltalk hasClassNamed: 'MCMockClassC').! !

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

MCClassDefinitionTest class
	instanceVariableNames: ''!

!MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:20'!
classAComment
	^ 'This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.'! !

!MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 17:59'!
classACommentStamp
	^  'cwp 8/10/2003 16:43'! !

!MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 18:01'!
restoreClassAComment
	Smalltalk 
		at: #MCMockClassA 
		ifPresent: [:a | a classComment: self classAComment stamp: self classACommentStamp]! !
MCVariableDefinition subclass: #MCClassInstanceVariableDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCClassInstanceVariableDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:31'!
isClassInstanceVariable
	^ true! !

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

MCClassInstanceVariableDefinition class
	instanceVariableNames: ''!

!MCClassInstanceVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'!
type
	^ #classInstance! !
MCDefinition subclass: #MCClassTraitDefinition
	instanceVariableNames: 'baseTrait classTraitComposition'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:23'!
baseTrait
	^baseTrait
! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 12/15/2005 11:31'!
className
	^self baseTrait! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:23'!
classTraitComposition
	^classTraitComposition

! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/10/2005 10:12'!
classTraitCompositionString
	^self classTraitComposition ifNil: ['{}'].

! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:59'!
definitionString
	^self baseTrait , ' classTrait
	uses: ' , self classTraitCompositionString.
! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:24'!
description
	^Array
		with: baseTrait
		with: classTraitComposition! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 6/5/2006 14:04'!
hash
	| hash |
	hash := String stringHash: baseTrait initialHash: 0.
	hash := String stringHash: self classTraitCompositionString initialHash: hash.
	^hash
! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:24'!
requirements
	^Array with: baseTrait! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'!
sortKey
	^ self baseTrait name , '.classTrait'! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'!
source
	^self definitionString! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'!
summary
	^self baseTrait , ' classTrait'
! !

!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:59'!
= aDefinition
	^ (super = aDefinition)
		and: [baseTrait = aDefinition baseTrait]
		and: [self classTraitCompositionString = aDefinition classTraitCompositionString]

! !


!MCClassTraitDefinition methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:23'!
accept: aVisitor
	^ aVisitor visitClassTraitDefinition: self.! !

!MCClassTraitDefinition methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:24'!
load	
	Compiler evaluate: self definitionString! !


!MCClassTraitDefinition methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithBaseTraitName: aTraitName classTraitComposition: aString
	baseTrait := aTraitName.
	classTraitComposition := aString.! !

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

MCClassTraitDefinition class
	instanceVariableNames: ''!

!MCClassTraitDefinition class methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:22'!
baseTraitName: aString classTraitComposition: classTraitCompositionString
	^self instanceLike: (
		self new
			initializeWithBaseTraitName: aString
			classTraitComposition: classTraitCompositionString).! !
MCDoItParser subclass: #MCClassTraitParser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCClassTraitParser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
addDefinitionsTo: aCollection
	| tokens  definition traitCompositionString |
	tokens := Scanner new scanTokens: source.
	traitCompositionString := ((ReadStream on: source)
		match: 'uses:';
		upToEnd) withBlanksTrimmed.
	definition := MCClassTraitDefinition
		baseTraitName: (tokens at: 1) 
		classTraitComposition: traitCompositionString.
	aCollection add: definition
! !

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

MCClassTraitParser class
	instanceVariableNames: ''!

!MCClassTraitParser class methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:43'!
pattern
	^ '*classTrait*uses:*'! !
MCVariableDefinition subclass: #MCClassVariableDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCClassVariableDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:32'!
isClassVariable
	^ true! !

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

MCClassVariableDefinition class
	instanceVariableNames: ''!

!MCClassVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:58'!
type
	^ #class! !
MCTool subclass: #MCCodeTool
	instanceVariableNames: 'items'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!
!MCCodeTool commentStamp: 'nk 11/10/2003 22:00' prior: 0!
MCCodeTool is an abstract superclass for those Monticello browsers that display code.
It contains copies of the various CodeHolder methods that perform the various menu operations in the method list.
!


!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 21:00'!
adoptMessageInCurrentChangeset
	"Add the receiver's method to the current change set if not already there"

	self selectedClassOrMetaClass ifNotNilDo: [ :cl |
		self selectedMessageName ifNotNilDo: [ :sel |
			ChangeSet current adoptSelector: sel forClass: cl.
			self changed: #annotations ]]
! !

!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'!
browseFullProtocol
	"Open up a protocol-category browser on the value of the receiver's current selection.    If in mvc, an old-style protocol browser is opened instead.  Someone who still uses mvc might wish to make the protocol-category-browser work there too, thanks."

	| aClass |

	(Smalltalk isMorphic and: [Smalltalk includesKey: #Lexicon]) ifFalse: [^ self spawnFullProtocol].
	(aClass := self selectedClassOrMetaClass) ifNotNil:
		[(Smalltalk at: #Lexicon) new openOnClass: aClass inWorld: ActiveWorld showingSelector: self selectedMessageName]! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 21:26'!
browseMessages
	"Present a menu of the currently selected message, as well as all messages sent by it.  Open a message set browser of all implementors of the selector chosen."

	self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [ ^nil ])! !

!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'!
browseMethodFull
	"Create and schedule a full Browser and then select the current class and message."

	| myClass |
	(myClass := self selectedClassOrMetaClass) ifNotNil:
		[Browser fullOnClass: myClass selector: self selectedMessageName]! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 20:54'!
browseSendersOfMessages
	"Present a menu of the currently selected message, as well as all messages sent by it.  Open a message set browser of all senders of the selector chosen."

	self systemNavigation browseAllCallsOn: (self selectedMessageName ifNil: [ ^nil ])! !

!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'!
browseVersions
	"Create and schedule a message set browser on all versions of the 
	currently selected message selector."

	| class selector compiledMethod |
	class := self selectedClassOrMetaClass.
	selector := self selectedMessageName.
	compiledMethod := class compiledMethodAt: selector ifAbsent: [ ^self ].
	VersionsBrowser
		browseVersionsOf: compiledMethod
		class: class theNonMetaClass
		meta: class isMeta
		category: self selectedMessageCategoryName
		selector: selector! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 7/30/2004 17:56'!
classHierarchy
	"Create and schedule a class list browser on the receiver's hierarchy."

	self systemNavigation  spawnHierarchyForClass: self selectedClassOrMetaClass
		selector: self selectedMessageName	"OK if nil"! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 6/12/2004 14:01'!
classListMenu: aMenu 

	aMenu addList: #(
		-
		('browse full (b)'			browseMethodFull)
		('browse hierarchy (h)'		classHierarchy)
		('browse protocol (p)'		browseFullProtocol)
"		-
		('printOut'					printOutClass)
		('fileOut'					fileOutClass)
"		-
		('show hierarchy'			methodHierarchy)
"		('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...'				findMethodInChangeSets)).
							
	^aMenu! !

!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'!
copySelector
	"Copy the selected selector to the clipboard"

	| selector |
	(selector := self selectedMessageName) ifNotNil:
		[Clipboard clipboardText: selector asString]! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 20:55'!
fileOutMessage
	"Put a description of the selected message on a file"

	self selectedMessageName ifNotNil:
		[Cursor write showWhile:
			[self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]]! !

!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'!
findMethodInChangeSets
	"Find and open a changeSet containing the current method."

	| aName |
	(aName := self selectedMessageName) ifNotNil: [
		ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass
					selector: aName]! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 7/30/2004 17:56'!
methodHierarchy
	"Create and schedule a method browser on the hierarchy of implementors."

	self systemNavigation methodHierarchyBrowserForClass: self selectedClassOrMetaClass
		selector: self selectedMessageName! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 2/16/2004 17:00'!
methodListKey: aKeystroke from: aListMorph 
	aKeystroke caseOf: {
		[$b] -> [self browseMethodFull].
		[$h] -> [self classHierarchy].
		[$O] -> [self openSingleMessageBrowser].
		[$p] -> [self browseFullProtocol].
		[$o] -> [self fileOutMessage].
		[$c] -> [self copySelector].
		[$n] -> [self browseSendersOfMessages].
		[$m] -> [self browseMessages].
		[$i] -> [self methodHierarchy].
		[$v] -> [self browseVersions]}
		 otherwise: []! !

!MCCodeTool methodsFor: 'menus' stamp: 'avi 4/17/2004 11:42'!
methodListMenu: aMenu
	"Build the menu for the selected method, if any."
	
	self selectedMessageName ifNotNil: [
	aMenu addList:#(
			('browse full (b)' 						browseMethodFull)
			('browse hierarchy (h)'					classHierarchy)
			('browse method (O)'					openSingleMessageBrowser)
			('browse protocol (p)'					browseFullProtocol)
			-
			('fileOut (o)'							fileOutMessage)
			('printOut'								printOutMessage)
			('copy selector (c)'						copySelector)).
		aMenu addList: #(
			-
			('browse senders (n)'						browseSendersOfMessages)
			('browse implementors (m)'					browseMessages)
			('inheritance (i)'						methodHierarchy)
			('versions (v)'							browseVersions)
		('change sets with this method'			findMethodInChangeSets)
"		('x revert to previous version'				revertToPreviousVersion)"
		('remove from current change set'		removeFromCurrentChanges)
"		('x revert & remove from changes'		revertAndForget)"
		('add to current change set'				adoptMessageInCurrentChangeset)
"		('x copy up or copy down...'				copyUpOrCopyDown)"
"		('x remove method (x)'					removeMessage)"
		"-"
		).
	].
"	aMenu addList: #(
			('x inst var refs...'						browseInstVarRefs)
			('x inst var defs...'						browseInstVarDefs)
			('x class var refs...'						browseClassVarRefs)
			('x class variables'						browseClassVariables)
			('x class refs (N)'							browseClassRefs)
	).
"
	^ aMenu
! !

!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'!
openSingleMessageBrowser
	| msgName mr |
	"Create and schedule a message list browser populated only by the currently selected message"

	(msgName := self selectedMessageName) ifNil: [^ self].

	mr := MethodReference new
		setStandardClass: self selectedClassOrMetaClass
		methodSymbol: msgName.

	self systemNavigation 
		browseMessageList: (Array with: mr)
		name: mr asStringOrText
		autoSelect: nil! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 20:55'!
perform: selector orSendTo: otherTarget 

	"Selector was just chosen from a menu by a user. If can respond, then  
	perform it on myself. If not, send it to otherTarget, presumably the  
	editPane from which the menu was invoked."

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

!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 20:58'!
printOutMessage
	"Write a file with the text of the selected message, for printing by a web browser"

	self selectedMessageName ifNotNil: [
		self selectedClassOrMetaClass fileOutMethod: self selectedMessageName
							asHtml: true]! !

!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 21:00'!
removeFromCurrentChanges
	"Tell the changes mgr to forget that the current msg was changed."

	ChangeSet current removeSelectorChanges: self selectedMessageName 
			class: self selectedClassOrMetaClass.
	self changed: #annotations! !


!MCCodeTool methodsFor: 'subclassResponsibility' stamp: 'nk 11/10/2003 22:01'!
annotations
	"Build an annotations string for the various browsers"
	^''! !

!MCCodeTool methodsFor: 'subclassResponsibility' stamp: 'nk 11/10/2003 22:02'!
selectedClass
	"Answer the class that is selected, or nil"
	self subclassResponsibility! !

!MCCodeTool methodsFor: 'subclassResponsibility' stamp: 'nk 11/10/2003 22:02'!
selectedClassOrMetaClass
	"Answer the class that is selected, or nil"
	self subclassResponsibility! !

!MCCodeTool methodsFor: 'subclassResponsibility' stamp: 'nk 11/10/2003 22:02'!
selectedMessageCategoryName
	"Answer the method category of the method that is selected, or nil"
	self subclassResponsibility! !

!MCCodeTool methodsFor: 'subclassResponsibility' stamp: 'nk 11/10/2003 22:02'!
selectedMessageName
	"Answer the name of the selected message"
	self subclassResponsibility! !

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

MCCodeTool class
	instanceVariableNames: ''!
Object subclass: #MCConfiguration
	instanceVariableNames: 'name dependencies repositories log'
	classVariableNames: 'DefaultLog'
	poolDictionaries: ''
	category: 'MonticelloConfigurations'!

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:32'!
dependencies
	^dependencies ifNil: [dependencies := OrderedCollection new]! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/21/2005 18:40'!
dependencies: aCollection
	dependencies := aCollection! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:22'!
fileName
	^ self name, '.', self writerClass extension
! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 6/9/2005 15:58'!
log
	^log ifNil: [Transcript]! !

!MCConfiguration methodsFor: 'accessing' stamp: 'ar 4/28/2005 11:55'!
log: aStream
	log := aStream.! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:23'!
name
	^name! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:23'!
name: aString
	name := aString! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:35'!
repositories
	^repositories ifNil: [repositories := OrderedCollection new]! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:36'!
repositories: aCollection
	repositories := aCollection! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 00:44'!
summary
	^String streamContents: [:stream |
		self dependencies
			do: [:ea | stream nextPutAll: ea versionInfo name; cr ]]! !

!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:50'!
writerClass
	^ MCMcmWriter ! !


!MCConfiguration methodsFor: 'actions' stamp: 'bf 3/22/2005 22:09'!
browse
	(MCConfigurationBrowser new configuration: self) show! !

!MCConfiguration methodsFor: 'actions' stamp: 'bf 3/22/2005 10:51'!
fileOutOn: aStream
	self writerClass fileOut: self on: aStream! !

!MCConfiguration methodsFor: 'actions' stamp: 'bf 4/22/2005 17:19'!
load
	^self depsSatisfying: [:dep | dep isCurrent not]
		versionDo: [:ver | ver load]
		displayingProgress: 'loading packages'
! !

!MCConfiguration methodsFor: 'actions' stamp: 'bf 4/22/2005 17:19'!
merge
	^self depsSatisfying: [:dep | dep isFulfilledByAncestors not]
		versionDo: [:ver | ver merge]
		displayingProgress: 'merging packages'
! !

!MCConfiguration methodsFor: 'actions' stamp: 'bf 5/23/2005 15:40'!
upgrade
	^self depsSatisfying: [:dep | dep isFulfilledByAncestors not]
		versionDo: [:ver | 
			(Preferences upgradeIsMerge and: [self mustMerge: ver])
				ifFalse: [ver load]
				ifTrue: [[ver merge]
					on: MCMergeResolutionRequest do: [:request |
						request merger conflicts isEmpty
							ifTrue: [request resume: true]
							ifFalse: [request pass]]]]
		displayingProgress: 'upgrading packages'
! !


!MCConfiguration methodsFor: 'faking' stamp: 'bf 3/24/2005 01:19'!
changes
	^MCPatch operations: #()! !

!MCConfiguration methodsFor: 'faking' stamp: 'bf 3/24/2005 01:17'!
info
	^MCVersionInfo new! !


!MCConfiguration methodsFor: 'initialize' stamp: 'ar 5/27/2005 17:28'!
initialize
	super initialize.
	log := DefaultLog.! !


!MCConfiguration methodsFor: 'testing' stamp: 'bf 3/22/2005 22:56'!
isCacheable
	^false! !


!MCConfiguration methodsFor: 'updating' stamp: 'bf 5/23/2005 17:43'!
updateFromImage
	self dependencies: (self dependencies collect: [:dep |
		dep package hasWorkingCopy
			ifTrue: [
				dep package workingCopy in: [:wc |
					MCVersionDependency package: wc package info: wc ancestors first]]
			ifFalse: [dep]]).
! !

!MCConfiguration methodsFor: 'updating' stamp: 'bf 5/30/2005 20:50'!
updateFromRepositories
	| oldInfos newNames sortedNames newDeps |
	oldInfos := self dependencies collect: [:dep | dep versionInfo].
	newNames := Dictionary new.
	self repositories
		do: [:repo | 
			ProgressNotification signal: '' extra: 'Checking ', repo description.
			(repo possiblyNewerVersionsOfAnyOf: oldInfos)
				do: [:newName | newNames at: newName put: repo]]
		displayingProgress: 'Searching new versions'.

	sortedNames := newNames keys asSortedCollection:
		[:a :b | a numericSuffix > b numericSuffix].

	newDeps := OrderedCollection new.
	self dependencies do: [:dep |
		| newName |
		newName := sortedNames
			detect: [:each | (each copyUpToLast: $-) = dep package name]
			ifNone: [nil].
		newDeps add: (newName
			ifNil: [dep]
			ifNotNil: [
				| repo ver  |
				repo := newNames at: newName.
				ver := self versionNamed: newName for: dep from: repo.
				ver ifNil: [dep]
					ifNotNil: [MCVersionDependency package: ver package info: ver info]
			])
	] displayingProgress: 'downloading new versions'.

	self dependencies: newDeps.
! !


!MCConfiguration methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
depsSatisfying: selectBlock versionDo: verBlock displayingProgress: progressString
	| repoMap count |
	repoMap := Dictionary new.
	self repositories do: [:repo |
		MCRepositoryGroup default addRepository: repo.
		repo allVersionNames
			ifEmpty: [self logWarning: 'cannot read from ', repo description]
			ifNotEmptyDo: [:all | all do: [:ver | repoMap at: ver put: repo]]].

	count := 0.
	self dependencies do: [:dep |
		| ver repo |
		ver := dep versionInfo name.
		repo := repoMap at: ver ifAbsent: [
			self logError: 'Version ', ver, ' not found in any repository'.
			self logError: 'Aborting'.
			^count].
		(selectBlock value: dep) ifTrue: [
			| new |
			new := self versionNamed: ver for: dep from: repo.
			new ifNil: [
					self logError: 'Could not download version ', ver, ' from ', repo description.
					self logError: 'Aborting'.
					^count]
				ifNotNil: [
					self logUpdate: dep package with: new.
					ProgressNotification signal: '' extra: 'Installing ', ver.
					verBlock value: new.
					count := count + 1.
				]
		].
		dep package workingCopy repositoryGroup addRepository: repo.
	] displayingProgress: progressString.

	^count! !

!MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 11:26'!
diffBaseFor: aDependency
	| wc |
	aDependency package hasWorkingCopy ifFalse: [^nil].
	wc := aDependency package workingCopy.
	wc ancestors ifEmpty: [^nil].
	^wc ancestors first name! !

!MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 16:07'!
logError: aString
	self log
		cr; nextPutAll: 'ERROR: ';
		nextPutAll: aString; cr;
		flush.
! !

!MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 15:59'!
logUpdate: aPackage with: aVersion
	self log
		cr; nextPutAll: '========== ', aVersion info name, ' =========='; cr;
		cr; nextPutAll: aVersion info message asString; cr;
		flush.

	aPackage hasWorkingCopy ifFalse: [^self].

	aPackage workingCopy ancestors do: [:each |
		(aVersion info hasAncestor: each)
			ifTrue: [(aVersion info allAncestorsOnPathTo: each)
				do: [:ver | self log cr; nextPutAll: '>>> ', ver name, ' <<<'; cr;
							nextPutAll: ver message; cr; flush]]]! !

!MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 16:08'!
logWarning: aString
	self log
		cr; nextPutAll: 'WARNING: ';
		nextPutAll: aString; cr;
		flush.
! !

!MCConfiguration methodsFor: 'private' stamp: 'bf 5/23/2005 14:47'!
mustMerge: aVersion
	"answer true if we have to do a full merge and false if we can simply load instead"
	
	| pkg wc current |
	(pkg := aVersion package) hasWorkingCopy ifFalse: [^false "no wc -> load"].
	(wc := pkg workingCopy) modified ifTrue: [^true "modified -> merge"].
	wc ancestors isEmpty ifTrue: [^true "no ancestor info -> merge"].
	current := wc ancestors first.
	(aVersion info hasAncestor: current) ifTrue: [^false "direct descendant of wc -> load"].
	"new branch -> merge"
	^true! !

!MCConfiguration methodsFor: 'private' stamp: 'md 9/18/2005 15:56'!
versionNamed: verName for: aDependency from: repo

	| baseName fileName ver |
	(repo filterFileNames: repo cachedFileNames forVersionNamed: verName) ifNotEmptyDo: [:cachedNames |
		fileName := cachedNames anyOne.
		ProgressNotification signal: '' extra: 'Using cached ', fileName.
		ver := repo versionFromFileNamed: fileName].
	ver ifNil: [
		baseName := self diffBaseFor: aDependency.
		(baseName notNil and: [baseName ~= verName and: [repo includesVersionNamed: baseName]]) ifTrue: [
			fileName := (MCDiffyVersion nameForVer: verName base: baseName), '.mcd'.
			ProgressNotification signal: '' extra: 'Downloading ', fileName.
			ver := repo versionFromFileNamed: fileName]].
	ver ifNil: [
		fileName := verName, '.mcz'.
		ProgressNotification signal: '' extra: 'Downloading ', fileName.
		ver := repo versionFromFileNamed: fileName].
	^ver! !

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

MCConfiguration class
	instanceVariableNames: ''!

!MCConfiguration class methodsFor: 'accessing' stamp: 'ar 5/27/2005 17:27'!
defaultLog
	"Answer the default configuration log"
	^DefaultLog! !

!MCConfiguration class methodsFor: 'accessing' stamp: 'ar 5/27/2005 17:27'!
defaultLog: aStream
	"Set the default configuration log"
	DefaultLog := aStream.! !


!MCConfiguration class methodsFor: 'class initialization' stamp: 'bf 4/20/2005 17:20'!
initialize
	"MCConfiguration initialize"

	Preferences addPreference: #upgradeIsMerge
		categories: #('updates') default: false 
		balloonHelp: 'When upgrading packages, use merge instead of load'.! !


!MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:43'!
dependencyFromArray: anArray
	^MCVersionDependency
		package: (MCPackage named: anArray first)
		info: (
			MCVersionInfo
			name: anArray second
			id: (UUID fromString: anArray third)
			message: nil
			date: nil
			time: nil
			author: nil
			ancestors: nil)! !

!MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:44'!
dependencyToArray: aDependency
	^ {
		aDependency package name . 
		aDependency versionInfo name . 
		aDependency versionInfo id asString }! !

!MCConfiguration class methodsFor: 'converting' stamp: 'bf 6/9/2005 14:25'!
repositoryFromArray: anArray
	^ MCRepositoryGroup default repositories
		detect: [:repo | repo description = anArray first]
		ifNone: [
			MCHttpRepository
				location: anArray first
				user: ''
				password: '']! !

!MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:51'!
repositoryToArray: aRepository
	^ {aRepository description}! !


!MCConfiguration class methodsFor: 'instance creation' stamp: 'bf 3/24/2005 01:51'!
fromArray: anArray
	| configuration |
	configuration := self new.
	anArray pairsDo: [:key :value |
		key = #repository
			ifTrue: [configuration repositories add: (self repositoryFromArray: value)].
		key = #dependency
			ifTrue: [configuration dependencies add: (self dependencyFromArray: value)].
	].
	^configuration! !
MCTool subclass: #MCConfigurationBrowser
	instanceVariableNames: 'configuration dependencyIndex repositoryIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MonticelloConfigurations'!

!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:03'!
configuration
	^configuration ifNil: [configuration := MCConfiguration new]! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 14:56'!
configuration: aConfiguration
	configuration := aConfiguration! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:35'!
dependencies
	^self configuration dependencies
! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 4/19/2005 16:02'!
dependencies: aCollection
	self configuration dependencies: aCollection.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:41'!
repositories
	^ self configuration repositories! !

!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/23/2005 21:15'!
repositories: aCollection
	^self configuration repositories: aCollection
! !


!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 22:08'!
add
	(self pickWorkingCopiesSatisfying: [:each | (self includesPackage: each package) not])
		do: [:wc |
			wc ancestors isEmpty
				ifTrue: [self inform: 'You must save ', wc packageName, ' first!!
Skipping this package']
				ifFalse: [
					self dependencies add: (MCVersionDependency
						package: wc package
						info: wc ancestors first)]].
	self changed: #dependencyList; changed: #description! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 21:01'!
down
	self canMoveDown ifTrue: [
		self list swap: self index with: self index + 1.
		self index: self index + 1.
		self changedList.
	].
! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
installMenu

	| menu |
	menu := MenuMorph new defaultTarget: self.
	menu add: 'load packages' action: #load.
	menu add: 'merge packages' action: #merge.
	menu add: 'upgrade packages' action: #upgrade.
	menu popUpInWorld.! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:42'!
load
	self configuration load.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadMenu

	| menu |
	menu := MenuMorph new defaultTarget: self.
	menu add: 'update from image' action: #updateFromImage.
	menu add: 'update from repositories' action: #updateFromRepositories.
	menu popUpInWorld.
! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:42'!
merge
	self configuration merge.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
post
	"Take the current configuration and post an update"
	| name update managers names choice |
	(self checkRepositories and: [self checkDependencies]) ifFalse: [^self].
	name := FillInTheBlank
		request: 'Update name (.cs) will be appended):'
		initialAnswer: (self configuration name ifNil: ['']).
	name isEmpty ifTrue:[^self].
	self configuration name: name.
	update := MCPseudoFileStream on: (String new: 100).
	update localName: name, '.cs'.
	update nextPutAll: '"Change Set:		', name.
	update cr; nextPutAll: 'Date:			', Date today printString.
	update cr; nextPutAll: 'Author:			Posted by Monticello'.
	update cr; cr; nextPutAll: 'This is a configuration map created by Monticello."'.

	update cr; cr; nextPutAll: '(MCConfiguration fromArray: #'.
	self configuration fileOutOn: update.
	update nextPutAll: ') upgrade.'.
	update position: 0.

	managers := Smalltalk at: #UpdateManager ifPresent:[:mgr| mgr allRegisteredManagers].
	managers ifNil:[managers := #()].
	managers size > 0 ifTrue:[
		| servers index |
		servers := ServerDirectory groupNames asSortedArray.
		names := (managers collect:[:each| each packageVersion]), servers.
		index := UIManager default chooseFrom: names lines: {managers size}.
		index = 0 ifTrue:[^self].
		index <= managers size ifTrue:[
			| mgr |
			mgr := managers at: index.
			^mgr publishUpdate: update.
		].
		choice := names at: index.
	] ifFalse:[
		names := ServerDirectory groupNames asSortedArray.
		choice := (SelectionMenu labelList: names selections: names) startUp.
		choice == nil ifTrue: [^ self].
	].
	(ServerDirectory serverInGroupNamed: choice) putUpdate: update.! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 21:05'!
remove
	self canRemove ifTrue: [
		self list removeAt: self index.
		self changedList.
		self updateIndex.
	].
! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 23:38'!
store
	(self checkRepositories and: [self checkDependencies]) ifFalse: [^self].
	self pickName ifNotNilDo: [:name |
		self configuration name: name.
		self pickRepository ifNotNilDo: [:repo |
			repo storeVersion: self configuration]].! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 20:53'!
up
	self canMoveUp ifTrue: [
		self list swap: self index with: self index - 1.
		self index: self index - 1.
		self changedList.
	].! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
updateMenu

	| menu |
	menu := MenuMorph new defaultTarget: self.
	menu add: 'update from image' action: #updateFromImage.
	menu add: 'update from repositories' action: #updateFromRepositories.
	menu popUpInWorld.! !

!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:43'!
upgrade
	self configuration upgrade.
	self changed: #dependencyList; changed: #description
! !


!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 3/23/2005 22:08'!
addDependency
	(self pickWorkingCopiesSatisfying: [:each | (self includesPackage: each package) not])
		do: [:wc |
			wc ancestors isEmpty
				ifTrue: [self inform: 'You must save ', wc packageName, ' first!!
Skipping this package']
				ifFalse: [
					self dependencies add: (MCVersionDependency
						package: wc package
						info: wc ancestors first)]].
	self changed: #dependencyList; changed: #description! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:36'!
checkDependencies
	^self checkModified and: [self checkMissing]! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:35'!
checkMissing
	| missing |
	missing := (self dependencies collect: [:ea | ea versionInfo name]) asSet.

	self repositories
		do: [:repo |
			repo allVersionNames
				do: [:found | missing remove: found ifAbsent: []]]
		displayingProgress: 'searching versions'.

	^missing isEmpty or: [
		self selectDependency: missing anyOne.
		self confirm: (String streamContents: [:strm |
			strm nextPutAll: 'No repository found for'; cr.
			missing do: [:r | strm nextPutAll: r; cr].
			strm nextPutAll: 'Do you still want to store?'])]
	! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:37'!
checkModified
	| modified |
	modified := self dependencies select: [:dep |
		dep isFulfilled and: [dep package workingCopy modified]].
	
	^modified isEmpty or: [
		self selectDependency: modified anyOne.
		self confirm: (String streamContents: [:strm |
			strm nextPutAll: 'These packages are modified:'; cr.
			modified do: [:dep | strm nextPutAll: dep package name; cr].
			strm nextPutAll: 'Do you still want to store?'])]
	! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:28'!
dependencyList
	^self dependencies collect: [:dep | 
		Text string: dep versionInfo name
			attributes: (Array streamContents: [:attr |
				dep isFulfilledByAncestors
					ifFalse: [attr nextPut: TextEmphasis bold]
					ifTrue: [dep isCurrent ifFalse: [attr nextPut: TextEmphasis italic]].
			])]
! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 3/23/2005 17:56'!
selectedDependency
	^ self dependencies at: self dependencyIndex ifAbsent: []! !

!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 3/21/2005 16:30'!
selectedPackage
	^ self selectedDependency ifNotNilDo: [:dep | dep package]! !


!MCConfigurationBrowser methodsFor: 'description' stamp: 'bf 4/14/2005 15:37'!
description
	self selectedDependency ifNotNilDo: [:dep | ^ ('Package: ', dep package name, String cr,
		dep versionInfo summary) asText].
	self selectedRepository ifNotNilDo: [:repo | ^repo creationTemplate
		ifNotNil: [repo creationTemplate asText]
		ifNil: [repo asCreationTemplate asText addAttribute: TextColor red]].
	^ ''
! !

!MCConfigurationBrowser methodsFor: 'description' stamp: 'bf 3/23/2005 22:49'!
description: aText

	self selectedRepository ifNotNilDo: [:repo | 
		| new | 
		new := MCRepository readFrom: aText asString.
		(new class = repo class 
			and: [new description = repo description])
				ifTrue: [
					repo creationTemplate: aText asString.
					self changed: #description]
				ifFalse: [
					self inform: 'This does not match the previous definition!!'
				]
	].

! !


!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 6/22/2005 12:26'!
buttonSpecs
	^ #(('Add' add 'Add a dependency')
		('Update' updateMenu 'Update dependencies')
		('Install' installMenu 'Load/Merge/Upgrade into image')
		('Up' up 'Move item up in list' canMoveUp)
		('Down' down 'Move item down in list' canMoveDown)
		('Remove' remove 'Remove item' canRemove)
		('Store' store 'store configuration')
		('Post' post 'Post this configuration to an update stream')
		)! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 4/19/2005 16:51'!
defaultExtent
	^ 350@500! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/24/2005 00:20'!
dependencyMenu: aMenu
	self fillMenu: aMenu fromSpecs: #(('add dependency...' addDependency)).
	self selectedDependency ifNotNil: [
		self fillMenu: aMenu fromSpecs: #(('remove dependency...' remove))].
	^aMenu
! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/22/2005 22:01'!
pickName
	| name |
	name := FillInTheBlank
		request: 'Name (.', self configuration writerClass extension, ' will be appended):'
		initialAnswer: (self configuration name ifNil: ['']).
	^ name isEmpty ifFalse: [name]! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/23/2005 21:11'!
pickRepository
	^self pickRepositorySatisfying: [:ea | true]
! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
pickRepositorySatisfying: aBlock
	| index list |
	list := MCRepositoryGroup default repositories select: aBlock.
	index := (PopUpMenu labelArray: (list collect: [:ea | ea description]))
		startUpWithCaption: 'Repository:'.
	^ index = 0 ifFalse: [list at: index]! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
pickWorkingCopiesSatisfying: aBlock
	| copies item |
	copies := (MCWorkingCopy allManagers select: aBlock)
		asSortedCollection: [:a :b | a packageName <= b packageName].
	item := (PopUpMenu labelArray: #('match ...'),(copies collect: [:ea | ea packageName]) lines: #(1))
				startUpWithCaption: 'Package:'.
	item = 1 ifTrue: [
		| pattern |
		pattern := FillInTheBlank request: 'Packages matching:' initialAnswer: '*'.
		^pattern isEmptyOrNil
			ifTrue: [#()]
			ifFalse: [
				(pattern includes: $*) ifFalse: [pattern := '*', pattern, '*'].
				copies select: [:ea | pattern match: ea packageName]]
	].
	^ item = 0
		ifTrue: [#()]
		ifFalse: [{copies at: item - 1}]! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/23/2005 21:27'!
repositoryMenu: aMenu
	^self fillMenu: aMenu fromSpecs: #(
		('add repository...' addRepository)
	)! !

!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/23/2005 22:01'!
widgetSpecs
	^ #(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((listMorph:selection:menu: dependencyList dependencyIndex dependencyMenu:) (0 0 1 1) (0 30 0 -180))
		((listMorph:selection:menu: repositoryList repositoryIndex repositoryMenu:) (0 1 1 1) (0 -180 0 -120))
		((textMorph: description) (0 1 1 1) (0 -120 0 0))
	 	)! !


!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/24/2005 00:17'!
addRepository
	(self pickRepositorySatisfying: [:ea | (self repositories includes: ea) not])
		ifNotNilDo: [:repo |
			(repo isKindOf: MCHttpRepository)
				ifFalse: [^self inform: 'Only HTTP repositories are supported'].
			self repositories add: repo.
			self changed: #repositoryList.
		]! !

!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/24/2005 00:45'!
checkRepositories
	| bad |
	bad := self repositories reject: [:repo | repo isKindOf: MCHttpRepository].
	^bad isEmpty or: [
		self selectRepository: bad first.
		self inform: (String streamContents: [:strm |
			strm nextPutAll: 'Please remove these repositories:'; cr.
			bad do: [:r | strm nextPutAll: r description; cr].
			strm nextPutAll: '(only HTTP repositories are supported)']).
		false].
! !

!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/24/2005 00:47'!
checkRepositoryTemplates
	"unused for now - we only do HTTP"
	| bad |
	bad := self repositories select: [:repo | repo creationTemplate isNil].
	^bad isEmpty or: [
		self selectRepository: bad first.
		self inform: (String streamContents: [:strm |
			strm nextPutAll: 'Creation template missing for'; cr.
			bad do: [:r | strm nextPutAll: r description; cr].
			strm nextPutAll: 'Please fill in the details first!!']).
		false].
! !

!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/23/2005 21:15'!
repositoryList
	^self repositories collect: [:ea | ea description]
! !

!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/23/2005 17:58'!
selectedRepository
	^ self repositories at: self repositoryIndex ifAbsent: []! !


!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:54'!
changedButtons
	self changed: #canMoveDown.
	self changed: #canMoveUp.
	self changed: #canRemove.! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:55'!
changedList
	self dependencyIndex > 0 ifTrue: [^self changed: #dependencyList].
	self repositoryIndex > 0 ifTrue: [^self changed: #repositoryList].
	self error: 'nothing selected'! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 17:56'!
dependencyIndex
	^dependencyIndex ifNil: [0]! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:55'!
dependencyIndex: anInteger
	dependencyIndex := anInteger.
	dependencyIndex > 0
		ifTrue: [self repositoryIndex: 0].
	self changed: #dependencyIndex; changed: #description.
	self changedButtons.! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:43'!
index
	^self dependencyIndex max: self repositoryIndex! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 21:00'!
index: anInteger
	self dependencyIndex > 0 ifTrue: [^self dependencyIndex: anInteger].
	self repositoryIndex > 0 ifTrue: [^self repositoryIndex: anInteger].
	anInteger > 0 ifTrue: [self error: 'cannot select']! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:51'!
list
	self dependencyIndex > 0 ifTrue: [^self dependencies].
	self repositoryIndex > 0 ifTrue: [^self repositories].
	^#()! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:52'!
maxIndex
	^ self list size! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 17:57'!
repositoryIndex
	^repositoryIndex ifNil: [0]! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:55'!
repositoryIndex: anInteger
	repositoryIndex := anInteger.
	repositoryIndex > 0
		ifTrue: [self dependencyIndex: 0].
	self changed: #repositoryIndex; changed: #description.
	self changedButtons.! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 23:16'!
selectDependency: aDependency
	self dependencyIndex: (self dependencies indexOf: aDependency)! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 23:15'!
selectRepository: aRepository
	self repositoryIndex: (self repositories indexOf: aRepository)! !

!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 21:00'!
updateIndex
	self index > 0 ifTrue: [self index: (self index min: self maxIndex)]! !


!MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:44'!
canMoveDown
	^self index between: 1 and: self maxIndex - 1 ! !

!MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:44'!
canMoveUp
	^self index > 1! !

!MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:45'!
canRemove
	^self index > 0! !

!MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/21/2005 17:15'!
includesPackage: aPackage
	^self dependencies anySatisfy: [:each | each package = aPackage]! !


!MCConfigurationBrowser methodsFor: 'updating' stamp: 'bf 5/23/2005 17:44'!
updateFromImage
	self configuration updateFromImage.
	self changed: #dependencyList; changed: #description
! !

!MCConfigurationBrowser methodsFor: 'updating' stamp: 'bf 5/23/2005 17:44'!
updateFromRepositories
	self configuration updateFromRepositories.
	self changed: #dependencyList; changed: #description
! !

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

MCConfigurationBrowser class
	instanceVariableNames: ''!

!MCConfigurationBrowser class methodsFor: 'class initialization' stamp: 'bf 3/21/2005 19:46'!
initialize
	TheWorldMenu registerOpenCommand: { 'Monticello Configurations' . { self . #open }. 'Monticello Configuration Browser' }.! !


!MCConfigurationBrowser class methodsFor: 'opening' stamp: 'bf 3/21/2005 19:50'!
open
	^self new show! !
Object subclass: #MCConflict
	instanceVariableNames: 'operation chooseRemote'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Merging'!

!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 11/10/2003 21:57'!
annotations
	^operation ifNotNilDo: [ :op | op annotations ]! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:04'!
applyTo: anObject
	self isResolved ifFalse: [self error: 'Cannot continue until this conflict has been resolved'].
	self remoteChosen ifTrue: [operation applyTo: anObject].! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
chooseLocal
	chooseRemote := false! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:16'!
chooseNewer
	self isLocalNewer ifTrue: [ self chooseLocal ]
		ifFalse: [ self isRemoteNewer ifTrue: [ self chooseRemote ]]! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:22'!
chooseOlder
	self isRemoteNewer ifTrue: [ self chooseLocal ]
		ifFalse: [ self isLocalNewer ifTrue: [ self chooseRemote ]]! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
chooseRemote
	chooseRemote := true! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
clearChoice
	chooseRemote := nil! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 11/10/2003 21:58'!
definition
	^operation ifNotNilDo: [ :op | op definition ]! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'dvf 8/10/2004 23:24'!
isConflict
	^true! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:11'!
isLocalNewer
	^ self localDefinition fullTimeStamp > self remoteDefinition fullTimeStamp! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:15'!
isRemoteNewer
	^ self localDefinition fullTimeStamp < self remoteDefinition fullTimeStamp! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:02'!
isResolved
	^ chooseRemote notNil! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:45'!
localChosen
	^ chooseRemote notNil and: [chooseRemote not]! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:10'!
localDefinition
	^ operation baseDefinition! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:19'!
operation
	^ operation! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
operation: anOperation
	operation := anOperation! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:45'!
remoteChosen
	^ chooseRemote notNil and: [chooseRemote]! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:10'!
remoteDefinition
	^ operation targetDefinition! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 16:47'!
source
	^ self localChosen
		ifTrue: [operation fromSource]
		ifFalse: [operation source]! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:48'!
status
	^ self isResolved
		ifFalse: ['']
		ifTrue: [self remoteChosen
					ifFalse: ['L']
					ifTrue: ['R']]! !

!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
summary
	| attribute |
	attribute := 
		self isResolved
			ifTrue: [self remoteChosen ifTrue: [#underlined] ifFalse: [#struckOut]]
			ifFalse: [#bold].
	^ Text string: operation summary attribute: (TextEmphasis perform: attribute)! !

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

MCConflict class
	instanceVariableNames: ''!

!MCConflict class methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:07'!
operation: anOperation
	^ self new operation: anOperation	! !
Object subclass: #MCDefinition
	instanceVariableNames: ''
	classVariableNames: 'Instances'
	poolDictionaries: ''
	category: 'Monticello-Base'!

!MCDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 14:12'!
provisions
	^ #()! !

!MCDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 14:12'!
requirements
	^ #()! !


!MCDefinition methodsFor: 'annotations' stamp: 'nk 7/24/2003 12:27'!
annotations
	^self annotations: Preferences defaultAnnotationRequests! !

!MCDefinition methodsFor: 'annotations' stamp: 'nk 7/24/2003 12:26'!
annotations: requests
	"Answer a string for an annotation pane, trying to fulfill the annotation requests.
	These might include anything that
		Preferences defaultAnnotationRequests 
	might return. Which includes anything in
		Preferences annotationInfo
	To edit these, use:"
	"Preferences editAnnotations"

	^String streamContents: [ :s | self printAnnotations: requests on: s ].! !

!MCDefinition methodsFor: 'annotations' stamp: 'nk 11/10/2003 21:46'!
printAnnotations: requests on: aStream
	"Add a string for an annotation pane, trying to fulfill the annotation requests.
	These might include anything that
		Preferences defaultAnnotationRequests 
	might return. Which includes anything in
		Preferences annotationInfo
	To edit these, use:"
	"Preferences editAnnotations"

	aStream nextPutAll: 'not yet implemented'! !


!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:14'!
description
	self subclassResponsibility! !

!MCDefinition methodsFor: 'comparing' stamp: 'nk 10/21/2003 23:18'!
fullTimeStamp
	^TimeStamp current! !

!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:14'!
hash
	^ self description hash! !

!MCDefinition methodsFor: 'comparing' stamp: 'ab 12/5/2002 21:24'!
isRevisionOf: aDefinition
	^ aDefinition description = self description! !

!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:25'!
isSameRevisionAs: aDefinition
	^ self = aDefinition! !

!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:04'!
sortKey
	self subclassResponsibility ! !

!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 17:59'!
<= other
	^ self sortKey <= other sortKey! !

!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:24'!
= aDefinition
	^ self isRevisionOf: aDefinition! !


!MCDefinition methodsFor: 'installing' stamp: 'ab 7/18/2003 21:31'!
load
	! !

!MCDefinition methodsFor: 'installing' stamp: 'avi 2/17/2004 13:19'!
loadOver: aDefinition
	self load
	! !

!MCDefinition methodsFor: 'installing' stamp: 'ab 7/18/2003 19:48'!
postload! !

!MCDefinition methodsFor: 'installing' stamp: 'avi 2/17/2004 13:19'!
postloadOver: aDefinition
	self postload! !

!MCDefinition methodsFor: 'installing' stamp: 'ab 11/14/2002 00:08'!
unload! !


!MCDefinition methodsFor: 'printing' stamp: 'ab 7/18/2003 19:43'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: '(', self summary, ')'! !

!MCDefinition methodsFor: 'printing' stamp: 'ab 7/19/2003 18:23'!
summary
	self subclassResponsibility ! !


!MCDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:51'!
isClassDefinition
	^false! !

!MCDefinition methodsFor: 'testing' stamp: 'bf 11/12/2004 14:46'!
isClassDefinitionExtension
	"Answer true if this definition extends the regular class definition"
	^false! !

!MCDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:51'!
isMethodDefinition
	^false! !

!MCDefinition methodsFor: 'testing' stamp: 'cwp 7/11/2003 01:32'!
isOrganizationDefinition
	^false! !

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

MCDefinition class
	instanceVariableNames: ''!

!MCDefinition class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
clearInstances
	WeakArray removeWeakDependent: Instances.
	Instances := nil! !

!MCDefinition class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
instanceLike: aDefinition
	Instances ifNil: [Instances := WeakSet new].
	^ (Instances like: aDefinition) ifNil: [Instances add: aDefinition]! !
Object subclass: #MCDefinitionIndex
	instanceVariableNames: 'definitions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Patching'!

!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:38'!
addAll: aCollection
	aCollection do: [:ea | self add: ea]! !

!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:38'!
add: aDefinition
	definitions at: aDefinition description put: aDefinition! !

!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
definitionLike: aDefinition ifPresent: foundBlock ifAbsent: errorBlock
	| definition |
	definition := definitions at: aDefinition description ifAbsent: [].
	^ definition
		ifNil: errorBlock
		ifNotNil: [foundBlock value: definition]! !

!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:42'!
definitions
	^ definitions values! !

!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	definitions := Dictionary new! !

!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:40'!
remove: aDefinition
	definitions removeKey: aDefinition description ifAbsent: []! !

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

MCDefinitionIndex class
	instanceVariableNames: ''!

!MCDefinitionIndex class methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:29'!
definitions: aCollection
	^ self new addAll: aCollection! !

!MCDefinitionIndex class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:03'!
new
	^ self basicNew initialize! !
Object subclass: #MCDependencySorter
	instanceVariableNames: 'required provided orderedItems'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Loading'!

!MCDependencySorter methodsFor: 'accessing' stamp: 'dvf 9/8/2004 00:49'!
externalRequirements
	| unloaded providedByUnloaded |
	unloaded := self itemsWithMissingRequirements.
	providedByUnloaded := (unloaded gather: [:e | e provisions]) asSet.
	^ required keys reject: [:ea | providedByUnloaded includes: ea ]! !

!MCDependencySorter methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
itemsWithMissingRequirements
	| items |
	items := Set new.
	required do: [:ea | items addAll: ea].
	^ items
! !


!MCDependencySorter methodsFor: 'building' stamp: 'bf 11/12/2004 14:50'!
addAll: aCollection
	aCollection asArray sort do: [:ea | self add: ea]! !

!MCDependencySorter methodsFor: 'building' stamp: 'avi 10/7/2004 22:47'!
addExternalProvisions: aCollection
	(aCollection intersection: self externalRequirements)
		do: [:ea | self addProvision: ea]! !

!MCDependencySorter methodsFor: 'building' stamp: 'stephaneducasse 2/4/2006 20:47'!
add: anItem
	| requirements |
	requirements := self unresolvedRequirementsFor: anItem.
	requirements isEmpty
		ifTrue: [self addToOrder: anItem]
		ifFalse: [self addRequirements: requirements for: anItem]! !


!MCDependencySorter methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	provided := Set new.
	required := Dictionary new.
	orderedItems := OrderedCollection new.! !


!MCDependencySorter methodsFor: 'sorting' stamp: 'ab 5/22/2003 23:25'!
orderedItems
	^ orderedItems! !


!MCDependencySorter methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
addProvision: anObject
	| newlySatisfied |
	provided add: anObject.
	newlySatisfied := required removeKey: anObject ifAbsent: [#()].
	self addAll: newlySatisfied.! !

!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:23'!
addRequirements: aCollection for: anObject
	aCollection do: [:ea | self addRequirement: ea for: anObject]! !

!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:24'!
addRequirement: reqObject for: itemObject
	(self itemsRequiring: reqObject) add: itemObject! !

!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:15'!
addToOrder: anItem
	orderedItems add: anItem.
	anItem provisions do: [:ea | self addProvision: ea].! !

!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:24'!
itemsRequiring: anObject
	^ required at: anObject ifAbsentPut: [Set new]! !

!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:22'!
unresolvedRequirementsFor: anItem
	^ anItem requirements difference: provided! !

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

MCDependencySorter class
	instanceVariableNames: ''!

!MCDependencySorter class methodsFor: 'as yet unclassified' stamp: 'ab 5/23/2003 14:17'!
items: aCollection
	^ self new addAll: aCollection! !

!MCDependencySorter class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:03'!
new
	^ self basicNew initialize! !

!MCDependencySorter class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
sortItems: aCollection
	| sorter |
	sorter := self items: aCollection.
	sorter externalRequirements do: [:req  | sorter addProvision: req].
	^ sorter orderedItems.! !
TestCase subclass: #MCDependencySorterTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCDependencySorterTest methodsFor: 'asserting' stamp: 'avi 10/7/2004 22:32'!
assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems
	self assertItems: anArray orderAs: depOrder withRequired: missingDeps  toLoad: unloadableItems  extraProvisions: #()! !

!MCDependencySorterTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems extraProvisions: provisions
	| order sorter items missing unloadable |
	items := anArray collect: [:ea | self itemWithSpec: ea].
	sorter := MCDependencySorter items: items.
	sorter addExternalProvisions: provisions.
	order := (sorter orderedItems collect: [:ea | ea name]) asArray.
	self assert: order = depOrder.
	missing := sorter externalRequirements.
	self assert: missing asSet = missingDeps asSet.
	unloadable := (sorter itemsWithMissingRequirements collect: [:ea | ea name]) asArray.
	self assert: unloadable asSet = unloadableItems asSet! !


!MCDependencySorterTest methodsFor: 'building' stamp: 'ab 5/24/2003 14:08'!
itemWithSpec: anArray
	^ MCMockDependentItem new
		name: anArray first;
		provides: anArray second;
		requires: anArray third! !


!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'!
testCascadingUnresolved
	self assertItems: #(
		(a (x) (z))
		(b () (x))
		(c () ()))
	orderAs: #(c)
	withRequired: #(z)
	toLoad: #(a b)	! !

!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'!
testCycle
	self assertItems: #(
		(a (x) (y))
		(b (y) (x)))
	orderAs: #()
	withRequired: #()
	toLoad: #(a b)	! !

!MCDependencySorterTest methodsFor: 'tests' stamp: 'avi 10/7/2004 22:35'!
testExtraProvisions
	self assertItems:
		#((a (x) (z))
		(b () (x)))
	orderAs: #(a b)
	withRequired: #()
	toLoad: #()	
	extraProvisions: #(x z)! !

!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'!
testMultiRequirementOrdering
	self assertItems: #(
		(a (x) (z))
		(b (y) ())
		(c (z) ())
		(d () (x y z)))
		orderAs: #(b c a d)
		withRequired: #()
		toLoad: #()! !

!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'!
testSimpleOrdering
	self assertItems: #((a (x) ())
								 (c () (y))
								 (b (y) (x)))
		orderAs: #(a b c)
		withRequired: #()
		toLoad: #()! !

!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:12'!
testSimpleUnresolved
	self assertItems: #(
		(a () (z)))
	orderAs: #()
	withRequired: #(z)
	toLoad: #(a)
		! !

!MCDependencySorterTest methodsFor: 'tests' stamp: 'avi 10/7/2004 22:12'!
testUnusedAlternateProvider
	self assertItems: #(
		(a (x) (z))
		(b () (x))
		(c (x) ()))
	orderAs: #(c b)
	withRequired: #(z)
	toLoad: #(a)	! !

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

MCDependencySorterTest class
	instanceVariableNames: ''!
ListItemWrapper subclass: #MCDependentsWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/14/2004 02:31'!
asString
	^item description! !

!MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'avi 9/10/2004 17:54'!
contents
	| list workingCopies |
	workingCopies := model unsortedWorkingCopies.
	list := item requiredPackages collect: 
					[:each | 
					workingCopies detect: [:wc | wc package = each] ifNone: [nil]]
				thenSelect: [:x | x notNil].
	^list collect: [:each | self class with: each model: model]! !

!MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/14/2004 02:31'!
hasContents
	^item requiredPackages isEmpty not! !

!MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/14/2004 02:41'!
item
	^item! !

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

MCDependentsWrapper class
	instanceVariableNames: ''!
MCRepository subclass: #MCDictionaryRepository
	instanceVariableNames: 'description dict'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 21:04'!
allVersionInfos
	^ dict values collect: [:ea | ea info]! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'!
basicStoreVersion: aVersion
	dict at: aVersion info put: aVersion! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
closestAncestorVersionFor: anAncestry ifNone: errorBlock
	| info |
	info := anAncestry breadthFirstAncestors
			detect: [:ea | self includesVersionWithInfo: ea]
			ifNone: [^ errorBlock value].
	^ self versionWithInfo: info! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:47'!
description

	^ description ifNil: ['cache']! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
description: aString

	description := aString ! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:47'!
dictionary

	^ dict! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
dictionary: aDictionary

	dict := aDictionary! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/21/2003 23:39'!
includesVersionNamed: aString
	^ dict anySatisfy: [:ea | ea info name = aString]! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 19:49'!
includesVersionWithInfo: aVersionInfo
	^ dict includesKey: aVersionInfo! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize

	dict := Dictionary new.
! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
morphicOpen: aWorkingCopy
	| names index infos |
	infos := self sortedVersionInfos.
	infos isEmpty ifTrue: [^ self inform: 'No versions'].
	names := infos collect: [:ea | ea name].
	index := (PopUpMenu labelArray: names) startUpWithCaption: 'Open version:'.
	index = 0 ifFalse: [(self versionWithInfo: (infos at: index)) open]! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
sortedVersionInfos
	| sorter |
	sorter := MCVersionSorter new.
	self allVersionInfos do: [:ea | sorter addVersionInfo: ea].
	^ sorter sortedVersionInfos
! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/16/2003 18:22'!
versionWithInfo: aVersionInfo ifAbsent: errorBlock
	^ dict at: aVersionInfo ifAbsent: errorBlock! !

!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:56'!
= other
	^ self == other! !

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

MCDictionaryRepository class
	instanceVariableNames: ''!
MCRepositoryTest subclass: #MCDictionaryRepositoryTest
	instanceVariableNames: 'dict'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCDictionaryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'ab 8/16/2003 17:53'!
addVersion: aVersion
	dict at: aVersion info put: aVersion! !

!MCDictionaryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 16:06'!
deleteNode: aNode
	dict removeKey: aNode! !

!MCDictionaryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
dictionary
	^ dict ifNil: [dict := Dictionary new]! !

!MCDictionaryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	repository :=  MCDictionaryRepository new dictionary: self dictionary! !

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

MCDictionaryRepositoryTest class
	instanceVariableNames: ''!
MCVersion subclass: #MCDiffyVersion
	instanceVariableNames: 'base patch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'!
baseInfo
	^ base! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:39'!
baseSnapshot
	^ (self workingCopy repositoryGroup versionWithInfo: base) snapshot! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'bf 5/23/2005 15:42'!
canOptimizeLoading
	"Answer wether I can provide a patch for the working copy without the usual diff pass"
	^ package hasWorkingCopy
		and: [package workingCopy modified not
			and: [package workingCopy ancestors includes: self baseInfo]]! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'bf 5/30/2005 17:39'!
fileName
	^ (self class nameForVer: info name base: base name), '.', self writerClass extension! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithPackage: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch: aPatch
	patch := aPatch.
	base := baseVersionInfo.
	super initializeWithPackage: aPackage info: aVersionInfo snapshot: nil dependencies: aCollection.
! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:24'!
isDiffy
	^ true! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'!
patch
	^ patch! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
snapshot
	^ snapshot ifNil: [snapshot := MCPatcher apply: patch to: self baseSnapshot]! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/19/2004 22:03'!
summary
	^ '(Diff against ', self baseInfo name, ')', String cr, super summary! !

!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'!
writerClass
	^ MCMcdWriter ! !

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

MCDiffyVersion class
	instanceVariableNames: ''!

!MCDiffyVersion class methodsFor: 'instance creation' stamp: 'avi 2/13/2004 23:07'!
package: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch:
aPatch
	^ self basicNew initializeWithPackage: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch:
aPatch! !

!MCDiffyVersion class methodsFor: 'instance creation' stamp: 'avi 2/13/2004 23:06'!
package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection baseVersion: aVersion
	^ self 
		package: aPackage
		info: aVersionInfo
		dependencies: aCollection
		baseInfo: aVersion info
		patch: (aSnapshot patchRelativeToBase: aVersion snapshot)! !


!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:45'!
baseNameFrom: diffName
	| baseId verName |
	baseId := (diffName copyAfter: $() copyUpTo: $).
	baseId ifEmpty: [^baseId].
	(baseId beginsWith: '@')
		ifTrue: [^baseId copyAfter: $@].
	verName := self verNameFrom: diffName.
	^(baseId includes: $.)
		ifTrue: [(verName copyUpToLast: $-), '-', baseId]
		ifFalse: [(verName copyUpToLast: $.), '.', baseId]
! !

!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:58'!
canonicalNameFor: aFileName
	^(self nameForVer: (self verNameFrom: aFileName)
		base: (self baseNameFrom: aFileName))
			, '.', MCMcdReader extension
! !

!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 17:39'!
nameForVer: versionName base: baseName
	| baseId |
	baseId := (versionName copyUpToLast: $.) = (baseName copyUpToLast: $.)
		ifTrue: [baseName copyAfterLast: $.]
		ifFalse: [(versionName copyUpToLast: $-) = (baseName copyUpToLast: $-)
			ifTrue: [baseName copyAfterLast: $-]
			ifFalse: ['@', baseName]].
	^ versionName, '(', baseId, ')'! !

!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:19'!
verNameFrom: diffName
	^diffName copyUpTo: $(! !
MCFileBasedRepository subclass: #MCDirectoryRepository
	instanceVariableNames: 'directory'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2003 15:28'!
allFileNames
	^ (directory entries sortBy: [:a :b | a modificationTime >= b modificationTime]) collect: [:ea | ea name]! !

!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:57'!
description
	^ directory pathName! !

!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 17:49'!
directory
	^ directory! !

!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
directory: aDirectory
	directory := aDirectory! !

!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	directory := FileDirectory default! !

!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'nk 11/2/2003 10:55'!
isValid
	^directory exists! !

!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
readStreamForFileNamed: aString do: aBlock
	| file val |
	file := FileStream readOnlyFileNamed: (directory fullNameFor: aString).
	val := aBlock value: file.
	file close.
	^ val! !

!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
writeStreamForFileNamed: aString replace: aBoolean do: aBlock
	| file sel |
	sel := aBoolean ifTrue: [#forceNewFileNamed:] ifFalse: [#newFileNamed:].
	file := FileStream perform: sel with: (directory fullNameFor: aString).
	aBlock value: file.
	file close.! !


!MCDirectoryRepository methodsFor: 'comparing' stamp: 'ab 7/19/2003 21:40'!
hash
	^ directory pathName hash! !

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

MCDirectoryRepository class
	instanceVariableNames: ''!

!MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'ab 7/24/2003 21:20'!
description
	^ 'directory'! !

!MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'ab 7/24/2003 21:01'!
morphicConfigure
	^ FileList2 modalFolderSelector ifNotNilDo:
		[:directory |
		self new directory: directory]! !
MCRepositoryTest subclass: #MCDirectoryRepositoryTest
	instanceVariableNames: 'directory'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCDirectoryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
addVersion: aVersion
	| file |
	file := FileStream newFileNamed: (directory fullNameFor: aVersion fileName).
	aVersion fileOutOn: file.
	file close.! !

!MCDirectoryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
directory
	directory ifNil:
		[directory := FileDirectory default directoryNamed: 'mctest'.
		directory assureExistence].
	^ directory! !

!MCDirectoryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	repository := MCDirectoryRepository new directory: self directory! !

!MCDirectoryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 12:53'!
tearDown
	self directory recursiveDelete! !

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

MCDirectoryRepositoryTest class
	instanceVariableNames: ''!
PackageInfo subclass: #MCDirtyPackageInfo
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

!MCDirtyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
classes
	^ Array new: 0.! !

!MCDirtyPackageInfo methodsFor: 'as yet unclassified' stamp: 'al 2/16/2006 09:53'!
methods
	^ MCMockClassA selectors
		select: [:ea | ea beginsWith: 'ordinal']
		thenCollect:
			[:ea | 
				MethodReference new 
					setStandardClass: MCMockClassA 
					methodSymbol: ea].! !

!MCDirtyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
packageName
	^ 'MCDirtyPackage'! !

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

MCDirtyPackageInfo class
	instanceVariableNames: ''!

!MCDirtyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:04'!
initialize
	[self new register] on: MessageNotUnderstood do: []! !

!MCDirtyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:45'!
wantsChangeSetLogging
	^ false! !
Object subclass: #MCDoItParser
	instanceVariableNames: 'source'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Chunk Format'!

!MCDoItParser methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:40'!
addDefinitionsTo: aCollection
	self subclassResponsibility ! !

!MCDoItParser methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:40'!
source
	^ source! !

!MCDoItParser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
source: aString
	source := aString! !

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

MCDoItParser class
	instanceVariableNames: ''!

!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:29'!
concreteSubclasses
	^ self allSubclasses reject: [:c | c isAbstract]! !

!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:40'!
forDoit: aString
	^ (self subclassForDoit: aString) ifNotNilDo: [:c | c new source: aString]! !

!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:51'!
isAbstract
	^ self pattern isNil! !

!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:30'!
pattern
	^ nil! !

!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:30'!
subclassForDoit: aString
	^ self concreteSubclasses detect: [:ea | ea pattern match: aString] ifNone: []! !
PackageInfo subclass: #MCEmptyPackageInfo
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

!MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
classes
	^ #()! !

!MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
methods
	^ #()! !

!MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
packageName
	^ 'MCEmptyPackage'! !

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

MCEmptyPackageInfo class
	instanceVariableNames: ''!

!MCEmptyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:04'!
initialize
	[self new register] on: MessageNotUnderstood do: []! !

!MCEmptyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:45'!
wantsChangeSetLogging
	^ false! !
MCRepository subclass: #MCFileBasedRepository
	instanceVariableNames: 'cache allFileNames'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:35'!
allFileNames
	self subclassResponsibility! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 20:01'!
allFileNamesForVersionNamed: aString
	^ self filterFileNames: self readableFileNames forVersionNamed: aString! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:40'!
allFileNamesOrCache
	^ allFileNames ifNil: [self allFileNames]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:40'!
allVersionNames
	^ self readableFileNames collect: [:ea | self versionNameFromFileName: ea]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
basicStoreVersion: aVersion
	self
		writeStreamForFileNamed: aVersion fileName
		do: [:s | aVersion fileOutOn: s].
	aVersion isCacheable ifTrue: [
		cache ifNil: [cache := Dictionary new].
		cache at: aVersion fileName put: aVersion].
! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
cache
	^ cache ifNil: [cache := Dictionary new]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
cacheAllFileNamesDuring: aBlock
	allFileNames := self allFileNames.
	^ aBlock ensure: [allFileNames := nil]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'bf 6/9/2005 15:47'!
cachedFileNames
	^cache == nil
		ifTrue: [#()]
		ifFalse: [cache keys]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
canReadFileNamed: aString
	| reader |
	reader := MCVersionReader readerClassForFileNamed: aString.
	^ reader notNil! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:40'!
closestAncestorVersionFor: anAncestry ifNone: errorBlock
	^ self cacheAllFileNamesDuring:
		[super closestAncestorVersionFor: anAncestry ifNone: errorBlock]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 20:01'!
filterFileNames: aCollection forVersionNamed: aString
	^ aCollection select: [:ea | (self versionNameFromFileName: ea) = aString] ! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
flushCache
	cache := nil! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:36'!
includesVersionNamed: aString
	^ self allVersionNames includes: aString! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 13:34'!
loadVersionFromFileNamed: aString
	^ self versionReaderForFileNamed: aString do: [:r | r version]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 18:37'!
loadVersionInfoFromFileNamed: aString
	^ self versionReaderForFileNamed: aString do: [:r | r info]
	! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:52'!
maxCacheSize
	^ 8! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 18:32'!
morphicOpen: aWorkingCopy
	(MCFileRepositoryInspector repository: self workingCopy: aWorkingCopy)
		show! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:34'!
notifyList
	| list |
	(self allFileNames includes: 'notify') ifFalse: [^ #()].
	^ self readStreamForFileNamed: 'notify' do:
		[:s |
		s upToEnd withSqueakLineEndings findTokens: (String with: Character cr)]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'bf 3/11/2005 18:01'!
possiblyNewerVersionsOfAnyOf: someVersions
	| pkgs |
	pkgs := Dictionary new.

	someVersions do: [:aVersionInfo |
		pkgs at: (aVersionInfo name copyUpToLast: $-)
			put: (aVersionInfo name copyAfterLast: $.) asNumber].

	^[self allVersionNames select: [:each |
		(pkgs at: (each copyUpToLast: $-) ifPresent: [:verNumber |
			verNumber < (each copyAfterLast: $.) asNumber
				or: [verNumber = (each copyAfterLast: $.) asNumber
					and: [someVersions noneSatisfy: [:v | v name = each]]]]) == true]
	] on: Error do: [:ex | ex return: #()]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:39'!
readableFileNames
	| all cached new |
	all := self allFileNamesOrCache.	"from repository"
	cached := self cachedFileNames.	"in memory"
	new := all difference: cached.
	^ (cached asArray, new)
		select: [:ea | self canReadFileNamed: ea]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/18/2005 22:43'!
resizeCache: aDictionary
	[aDictionary size <= self maxCacheSize] whileFalse:
		[aDictionary removeKey: aDictionary keys atRandom]! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 23:09'!
versionFromFileNamed: aString
	| v |
	v := self cache at: aString ifAbsent: [self loadVersionFromFileNamed: aString].
	self resizeCache: cache.
	(v notNil and: [v isCacheable]) ifTrue: [cache at: aString put: v].
	^ v! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 18:37'!
versionInfoFromFileNamed: aString
	self cache at: aString ifPresent: [:v | ^ v info].
	^ self loadVersionInfoFromFileNamed: aString! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'bf 5/30/2005 22:52'!
versionNameFromFileName: aString
	^ (aString copyUpToLast: $.) copyUpTo: $(! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'bf 3/23/2005 01:19'!
versionReaderForFileNamed: aString do: aBlock
	^ self
		readStreamForFileNamed: aString
		do: [:s |
			(MCVersionReader readerClassForFileNamed: aString) ifNotNilDo:
				[:class | aBlock value: (class on: s fileName: aString)]]
! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionWithInfo: aVersionInfo ifAbsent: errorBlock
	| version |
	(self allFileNamesForVersionNamed: aVersionInfo name) do:
		[:fileName |
		version := self versionFromFileNamed: fileName.
		version info = aVersionInfo ifTrue: [^ version]].
	^ errorBlock value! !

!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/31/2003 14:32'!
writeStreamForFileNamed: aString do: aBlock
	^ self writeStreamForFileNamed: aString replace: false do: aBlock! !

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

MCFileBasedRepository class
	instanceVariableNames: ''!

!MCFileBasedRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/3/2005 00:43'!
flushAllCaches
	self allSubInstancesDo: [:ea | ea flushCache]! !
MCTestCase subclass: #MCFileInTest
	instanceVariableNames: 'stream expected diff'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCFileInTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertNoChange
	| actual |
	actual := MCSnapshotResource takeSnapshot.
	diff := actual patchRelativeToBase: expected.
	self assert: diff isEmpty! !


!MCFileInTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	expected := self mockSnapshot.
	stream := RWBinaryOrTextStream on: String new.! !

!MCFileInTest methodsFor: 'running' stamp: 'cwp 8/10/2003 00:27'!
tearDown
	(diff isNil or: [diff isEmpty not])
		 ifTrue: [expected updatePackage: self mockPackage]! !


!MCFileInTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:08'!
alterInitialState
	self mockClassA touchCVar! !

!MCFileInTest methodsFor: 'testing' stamp: 'avi 2/17/2004 03:21'!
assertFileOutFrom: writerClass canBeFiledInWith: aBlock
	(writerClass on: stream) writeSnapshot: self mockSnapshot.
	self alterInitialState.
	self assertSuccessfulLoadWith: aBlock.
	self mockPackage unload.
	self assertSuccessfulLoadWith: aBlock.
! !

!MCFileInTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertInitializersCalled
	| cvar |
	cvar := self mockClassA cVar.
	self assert: cvar = #initialized! !

!MCFileInTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:30'!
assertSuccessfulLoadWith: aBlock
	stream reset.
	aBlock value.
	self assertNoChange.
	self assertInitializersCalled.! !

!MCFileInTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 00:13'!
testStWriter
	self
		assertFileOutFrom: MCStWriter
		canBeFiledInWith: [stream fileIn].
! !

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

MCFileInTest class
	instanceVariableNames: ''!
MCVersionInspector subclass: #MCFileRepositoryInspector
	instanceVariableNames: 'repository versions loaded newer inherited selectedPackage selectedVersion order versionInfo'
	classVariableNames: 'Order'
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/18/2005 10:54'!
load
	self hasVersion ifTrue:
		[self version isCacheable
			ifTrue: [version workingCopy repositoryGroup addRepository: repository].
		super load.
		self refresh].! !

!MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'bf 11/16/2004 11:56'!
merge
	super merge.
	self refresh.
! !

!MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'md 2/28/2006 12:10'!
refresh
	| packageNames name latest av |
	packageNames := Set new.
	versions := repository readableFileNames collect: [ :each |
		name := (each copyUpToLast: $.) copyUpTo: $(.
		name last isDigit ifFalse: [Array with: name with: '' with: '' with: each]
			ifTrue:
				[Array
					with: (packageNames add: (name copyUpToLast:  $-))		"pkg name"
					with: ((name copyAfterLast: $-) copyUpTo: $.)				"user"
					with: ((name copyAfterLast: $-) copyAfter: $.) asInteger	"version"
					with: each]].
	newer := Set new.
	inherited := Set new.
	loaded := Set new.
	(MCWorkingCopy allManagers 
"		select: [ :each | packageNames includes: each packageName]")
		do: [:each |
			each ancestors do: [ :ancestor |
				loaded add: ancestor name.
				ancestor ancestorsDoWhileTrue: [:heir |
					(inherited includes: heir name)
						ifTrue: [false]
						ifFalse: [inherited add: heir name. true]]].
			latest := (versions select: [:v | v first = each package name])	
				detectMax: [:v | v third].
			(latest notNil and: [
				each ancestors allSatisfy: [:ancestor |
					av := ((ancestor name copyAfterLast: $-) copyAfter: $.) asInteger.
					av < latest third or: [
						av = latest third and: [((ancestor name copyAfterLast: $-) copyUpTo: $.) ~= latest second]]]])
				ifTrue: [newer add: each package name ]].

	self changed: #packageList; changed: #versionList! !

!MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
setRepository: aFileBasedRepository workingCopy: aWorkingCopy
	order := self class order.
	repository := aFileBasedRepository.
	self refresh.
	aWorkingCopy
		ifNil: [selectedPackage := self packageList isEmpty ifFalse: [self packageList first]]
		ifNotNil: [ selectedPackage := aWorkingCopy ancestry ancestorString copyUpToLast: $- ].
	MCWorkingCopy addDependent: self.
! !


!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 11/10/2003 22:35'!
buttonSpecs
	^#(('Refresh' refresh 'refresh the version-list')) , super buttonSpecs! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 11/10/2003 22:37'!
defaultExtent
	^450@300! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:06'!
defaultLabel
	^'Repository: ' , repository description! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 9/17/2005 17:21'!
hasVersion
	^ selectedVersion notNil! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 21:26'!
orderSpecs
	^{
		'unchanged' -> nil.
		'order by package' -> [ :x :y | x first <= y first ].
		'order by author' -> [ :x :y | x second <= y second ].
		'order by version-string' -> [ :x :y | x third <= y third ].
		'order by version-number' -> [ :x :y | x third asNumber >= y third asNumber ].
		'order by filename' -> [ :x :y | x fourth <= y fourth ].
	}! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 21:07'!
orderString: anIndex
	^String streamContents: [ :stream |
		order = anIndex
			ifTrue: [ stream nextPutAll: '<yes>' ]
			ifFalse: [ stream nextPutAll: '<no>' ].
		stream nextPutAll: (self orderSpecs at: anIndex) key ]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
order: anInteger
	self class order: (order := anInteger).
	self changed: #versionList.! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'bf 2/24/2005 18:29'!
packageHighlight: aString

	newer ifNil: [newer := #()].
	^(loaded anySatisfy: [:each | (each copyUpToLast: $-) = aString])
		ifTrue: [
			Text string: aString
				attribute: (TextEmphasis new emphasisCode: (
					((newer includes: aString)
						ifTrue: [5] ifFalse: [4])))]
		ifFalse: [aString]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
packageList
	| result |
	result := versions
		inject: Set new
		into: [ :set :each | set add: each first; yourself ].

	"sort loaded packages first, then alphabetically"
	result := result asSortedCollection: [:a :b |
		| loadedA loadedB |
		loadedA := loaded anySatisfy: [:each | (each copyUpToLast: $-) = a].
		loadedB := loaded anySatisfy: [:each | (each copyUpToLast: $-) = b].
		loadedA = loadedB 
			ifTrue: [a < b]
			ifFalse: [loadedA]].

	^result collect: [:each | self packageHighlight: each]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 17:25'!
packageListMenu: aMenu
	^aMenu! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:17'!
packageSelection
	^self packageList indexOf: selectedPackage! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
packageSelection: aNumber
	selectedPackage := aNumber isZero
		ifFalse: [ (self packageList at: aNumber) asString ].
	self versionSelection: 0.
	self changed: #packageSelection; changed: #versionList! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
version
	^ version ifNil:
		[Cursor wait showWhile:
			[version := repository versionFromFileNamed: selectedVersion].
		version]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'bf 5/30/2005 19:10'!
versionHighlight: aString

	| verName |
	inherited ifNil: [inherited := #()].
	verName := (aString copyUpToLast: $.) copyUpTo: $(.
	^Text
		string: aString
		attribute: (TextEmphasis new emphasisCode: (
			((loaded includes: verName) ifTrue: [ 4 "underlined" ]
				ifFalse: [ (inherited includes: verName)
					ifTrue: [ 0 ]
					ifFalse: [ 1 "bold" ] ])))! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionInfo
	^ versionInfo ifNil: [versionInfo := repository versionInfoFromFileNamed: selectedVersion]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionList
	| result sortBlock |
	result := selectedPackage isNil
		ifTrue: [ versions ]
		ifFalse: [ versions select: [ :each | selectedPackage = each first ] ].
	sortBlock := (self orderSpecs at: order) value.
	sortBlock isNil ifFalse: [
		result := result asSortedCollection: [:a :b | [sortBlock value: a value: b] on: Error do: [true]]].
	^result := result 
		collect: [ :each | self versionHighlight: each fourth ]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 21:07'!
versionListMenu: aMenu
	1 to: self orderSpecs size do: [ :index |
		aMenu addUpdating: #orderString: target: self selector: #order: argumentList: { index } ].
	^aMenu! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:18'!
versionSelection
	^self versionList indexOf: selectedVersion! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionSelection: aNumber
	aNumber isZero 
		ifTrue: [ selectedVersion := version := versionInfo := nil ]
		ifFalse: [ 
			selectedVersion := (self versionList at: aNumber) asString.
			version := versionInfo := nil].
	self changed: #versionSelection; changed: #summary; changed: #hasVersion! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 9/17/2005 18:36'!
versionSummary
	^ version
		ifNotNil: [version summary]
		ifNil: [self versionInfo summary]! !

!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:26'!
widgetSpecs
	^#(	((buttonRow) (0 0 1 0) (0 0 0 30))
		((listMorph: package) (0 0 0.5 0.6) (0 30 0 0))
		((listMorph: version) (0.5 0 1 0.6) (0 30 0 0))
		((textMorph: summary) (0 0.6 1 1) (0 0 0 0)) )! !

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

MCFileRepositoryInspector class
	instanceVariableNames: ''!

!MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
order
	Order isNil
		ifTrue: [ Order := 5 ].
	^Order! !

!MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
order: anInteger
	Order := anInteger! !

!MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'lr 9/26/2003 20:09'!
repository: aFileBasedRepository workingCopy: aWorkingCopy
	^self new
		setRepository: aFileBasedRepository workingCopy: aWorkingCopy;
		yourself! !


!MCFileRepositoryInspector class methodsFor: 'class initialization' stamp: 'bf 3/16/2005 14:41'!
initialize
	"self initialize"

	self migrateInstances! !

!MCFileRepositoryInspector class methodsFor: 'class initialization' stamp: 'bf 3/16/2005 14:53'!
migrateInstances
	self allSubInstancesDo: [:inst |
		#(packageList versionList) do: [:each |
			[(inst findListMorph: each) highlightSelector: nil]
				on: Error do: [:ignore | ]]].! !
MCVersionSorter subclass: #MCFilteredVersionSorter
	instanceVariableNames: 'target'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCFilteredVersionSorter methodsFor: 'as yet unclassified' stamp: 'bf 5/28/2005 01:14'!
addVersionInfo: aVersionInfo
	(aVersionInfo hasAncestor: target)
		ifTrue: [super addVersionInfo: aVersionInfo]
! !

!MCFilteredVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
processVersionInfo: aVersionInfo
	| success |
	aVersionInfo = target ifTrue: [^ true].
	self pushLayer.
	success := (self knownAncestorsOf: aVersionInfo) anySatisfy:
				[:ea | self processVersionInfo: ea].
	self popLayer.
	success ifTrue: [self addToCurrentLayer: aVersionInfo].
	^ success	! !

!MCFilteredVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
target: aVersionInfo
	target := aVersionInfo! !

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

MCFilteredVersionSorter class
	instanceVariableNames: ''!
Object subclass: #MCFrontier
	instanceVariableNames: 'frontier bag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCFrontier methodsFor: 'accessing' stamp: 'avi 9/17/2005 22:02'!
frontier
	^frontier! !


!MCFrontier methodsFor: 'advancing' stamp: 'avi 9/17/2005 22:02'!
removeAll: collection
	collection do: [ :n | self remove: n]! !

!MCFrontier methodsFor: 'advancing' stamp: 'avi 9/17/2005 22:13'!
remove: aVersionInfo
	frontier remove: aVersionInfo.
	aVersionInfo ancestors  do:
		[ :ancestor |
			bag remove: ancestor.
			(bag occurrencesOf: ancestor) = 0
				ifTrue: [frontier add: ancestor]].
	^aVersionInfo! !


!MCFrontier methodsFor: 'initialization' stamp: 'avi 9/17/2005 22:11'!
frontier: f bag: remaining
	frontier := f asOrderedCollection.
	bag := remaining! !

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

MCFrontier class
	instanceVariableNames: ''!

!MCFrontier class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'!
frontierOnAll: aCollection
	| remaining  allVersions |
	remaining := Bag new.
	allVersions := (aCollection gather: [:ea | ea withBreadthFirstAncestors]) asSet.
	allVersions do: [:ea | remaining addAll: ea ancestors].
	^self new frontier: aCollection bag: remaining! !

!MCFrontier class methodsFor: 'instance creation' stamp: 'avi 9/17/2005 22:07'!
frontierOn: aVersionInfo
	^ self frontierOnAll: (Array with: aVersionInfo)! !

!MCFrontier class methodsFor: 'instance creation' stamp: 'avi 9/17/2005 22:07'!
frontierOn: aVersionInfo and: otherVersionInfo
	^ self frontierOnAll: (Array with: aVersionInfo with: otherVersionInfo)! !
MCFileBasedRepository subclass: #MCFtpRepository
	instanceVariableNames: 'host directory user password connection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
clientDo: aBlock
	| client |
	client := FTPClient openOnHostNamed: host.
	client loginUser: user password: password.
	directory isEmpty ifFalse: [client changeDirectoryTo: directory].
	^ [aBlock value: client] ensure: [client close]! !

!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
directory: dirPath
	directory := dirPath! !

!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
host: hostname
	host := hostname! !

!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
parseDirectoryListing: aString
	| stream files line tokens |
	stream := aString readStream.
	files := OrderedCollection new.
	[stream atEnd] whileFalse:
		[line := stream nextLine.
		tokens := line findTokens: ' '.
		tokens size > 2 ifTrue: [files add: tokens last]].
	^ files! !

!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
password: passwordString
	password := passwordString! !

!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
user: userString
	user := userString! !


!MCFtpRepository methodsFor: 'required' stamp: 'avi 9/16/2003 14:04'!
allFileNames
	^ self clientDo:
		[:client |
		self parseDirectoryListing: client getDirectory]! !

!MCFtpRepository methodsFor: 'required' stamp: 'avi 9/17/2003 12:52'!
description
	^ 'ftp://', user, '@', host, '/', directory! !

!MCFtpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'!
readStreamForFileNamed: aString do: aBlock
	| stream |
	^ self clientDo:
		[:client |
		client binary.
		stream := RWBinaryOrTextStream on: String new.
		stream nextPutAll: (client getFileNamed: aString).
		aBlock value: stream reset]! !

!MCFtpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'!
writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock
	| stream |
	stream := RWBinaryOrTextStream on: String new.
	aBlock value: stream.
	self clientDo:
		[:client |
		client binary.
		client putFileStreamContents: stream reset as: aString]! !

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

MCFtpRepository class
	instanceVariableNames: ''!

!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/16/2003 13:57'!
creationTemplate
	^
'MCFtpRepository
	host: ''modules.squeakfoundation.org''
	directory: ''mc''
	user: ''squeak''
	password: ''squeak'''
	! !

!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/16/2003 13:57'!
description
	^ 'FTP'! !

!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 21:02'!
fillInTheBlankRequest
	^ 'FTP Repository:'

	! !

!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/16/2003 13:57'!
host: host directory: directory user: user password: password
	^ self new
		host: host;
		directory: directory;
		user: user;
		password: password! !

!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 21:02'!
morphicConfigure
	^ self fillInTheBlankConfigure! !

!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:38'!
templateCreationSelector
	^ #host:directory:user:password: ! !
MCRepository subclass: #MCGOODSRepository
	instanceVariableNames: 'hostname port connection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'!
basicStoreVersion: aVersion
	self root at: aVersion info put: aVersion.
	self db commit.! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'md 9/6/2005 18:37'!
db
	(connection isNil or: [connection isConnected not]) ifTrue: [
		connection := Smalltalk at: #KKDatabase ifPresent: [:cl | 
			cl  onHost:hostname port: port
		]
	].
	^ connection! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:35'!
description
	^ 'goods://', hostname asString, ':', port asString! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
host: aString
	hostname := aString! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:10'!
morphicOpen: aWorkingCopy
	(MCRepositoryInspector repository: self workingCopy: aWorkingCopy) show! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:17'!
packages
	^ (self root collect: [:ea | ea package]) asSet asSortedCollection! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
port: aNumber
	port := aNumber! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 14:35'!
root
	self db root ifNil: [self db root: Dictionary new].
	^ self db root! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:18'!
versionsAvailableForPackage: aPackage
	^ self root asArray select: [:ea | ea package = aPackage] thenCollect: [:ea | ea info]! !

!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:21'!
versionWithInfo: aVersionInfo ifAbsent: errorBlock
	^ self root at: aVersionInfo ifAbsent: errorBlock! !

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

MCGOODSRepository class
	instanceVariableNames: ''!

!MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:36'!
creationTemplate
	^
'MCGOODSRepository
	host: ''localhost''
	port: 6100'! !

!MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 14:33'!
description
	^ 'GOODS'! !

!MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:33'!
fillInTheBlankRequest
	^ 'GOODS Repository:'! !

!MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:36'!
host: hostname port: portNumber
	^ self new
		host: hostname;
		port: portNumber! !

!MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:35'!
morphicConfigure
	^ self fillInTheBlankConfigure! !
MCFileBasedRepository subclass: #MCHttpRepository
	instanceVariableNames: 'location user password readerCache'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'bf 4/14/2005 17:49'!
asCreationTemplate
	^self class creationTemplateLocation: location user: user password: password! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 22:17'!
locationWithTrailingSlash
	^ (location endsWith: '/')
		ifTrue: [location]
		ifFalse: [location, '/']! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
location: aUrlString
	location := aUrlString! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
parseFileNamesFromStream: aStream
	| names fullName |
	names := OrderedCollection new.
	[aStream atEnd] whileFalse:
		[[aStream upTo: $<. {$a. $A. nil} includes: aStream next] whileFalse.
		aStream upTo: $".
		aStream atEnd ifFalse: [
			fullName := aStream upTo: $".
			names add: fullName unescapePercents]].
	^ names! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
password
	self userAndPasswordFromSettingsDo: [:usr :pwd | ^pwd].

	self user isEmpty ifTrue: [^password].

	[password isEmpty] whileTrue: [
		| answer |
		"Give the user a chance to change the login"
		answer := FillInTheBlank request: 'User name for ', String cr, location
			initialAnswer: self user.
		answer isEmpty
			ifTrue: [^password]
			ifFalse: [self user: answer].
		
		password := FillInTheBlank requestPassword: 'Password for "', self user, '" at ', String cr, location.
	].

	^ password! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
password: passwordString
	password := passwordString! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 13:08'!
urlForFileNamed: aString
	^ self locationWithTrailingSlash, aString encodeForHTTP! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'bf 1/10/2005 17:37'!
user
	self userAndPasswordFromSettingsDo: [:usr :pwd | ^usr].
	"not in settings"
	^user! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
userAndPasswordFromSettingsDo: aBlock
	"The mcSettings file in ExternalSettings preferenceDirectory should contain entries for each account:
	
		account1: *myhost.mydomain* user:password
		account2: *otherhost.mydomain/somerep* dXNlcjpwYXNzd29yZA==

	That is it must start with 'account', followed by anything to distinguish accounts, and a colon. Then comes a match expression for the repository url, and after a space the user:password string.
	
	To not have the clear text password on your disc, you can base64 encode it:
			(Base64MimeConverter mimeEncode: 'user:password' readStream) contents
	"

	| entry userAndPassword |
	Settings ifNotNil: [
		Settings keysAndValuesDo: [:key :value |
			(key asLowercase beginsWith: 'account') ifTrue: [
				entry := value findTokens: '	 '.
				(entry first match: location) ifTrue: [
					userAndPassword := entry second.
					(userAndPassword includes: $:) ifFalse: [
						userAndPassword := (Base64MimeConverter mimeDecodeToChars: userAndPassword readStream) contents].
					userAndPassword := userAndPassword findTokens: $:.
					^aBlock value: userAndPassword first 
						value: userAndPassword second 
					]
			]
		]
	].
	^nil! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
user: userString
	user := userString! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionReaderForFileNamed: aString
	readerCache ifNil: [readerCache := Dictionary new].
	^ readerCache at: aString ifAbsent:
		[self resizeCache: readerCache.
		super versionReaderForFileNamed: aString do:
			[:r |
			r ifNotNil: [readerCache at: aString put: r]]]
	! !

!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 23:06'!
versionReaderForFileNamed: aString do: aBlock
	^ (self versionReaderForFileNamed: aString) ifNotNilDo: aBlock! !


!MCHttpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'!
allFileNames
	| index |
	index := HTTPSocket httpGet: self locationWithTrailingSlash, '?C=M;O=D' args: nil user: self user passwd: self password.
	index isString ifTrue: [self error: 'Could not access ', location].
	^ self parseFileNamesFromStream: index	! !

!MCHttpRepository methodsFor: 'required' stamp: 'ab 7/24/2003 21:10'!
description
	^ location! !

!MCHttpRepository methodsFor: 'required' stamp: 'al 12/12/2005 11:06'!
flushCache
	super flushCache.
	readerCache := nil.! !

!MCHttpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'!
readStreamForFileNamed: aString do: aBlock
	| contents |
	contents := HTTPSocket httpGet: (self urlForFileNamed: aString) args: nil user: self user passwd: self password.
	^ contents isString ifFalse: [aBlock value: contents]! !

!MCHttpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'!
writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock
	| stream response |
	stream := RWBinaryOrTextStream on: String new.
	aBlock value: stream.
	response := HTTPSocket
					httpPut: stream contents
					to: (self urlForFileNamed: aString)
					user: self user
					passwd: self password.

	(#( 'HTTP/1.1 201 ' 'HTTP/1.1 200 ' 'HTTP/1.0 201 ' 'HTTP/1.0 200 ')
		anySatisfy: [:code | response beginsWith: code ])
			ifFalse: [self error: response].! !

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

MCHttpRepository class
	instanceVariableNames: ''!

!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'bf 4/14/2005 15:26'!
creationTemplate
	^self creationTemplateLocation: 'http://foo.com/bar'
		user: 'squeak'
		password: 'squeak'
! !

!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'bf 4/14/2005 15:27'!
creationTemplateLocation: location user: user password: password
	^
'MCHttpRepository
	location: {1}
	user: {2}
	password: {3}' format: {location printString. user printString. password printString}! !

!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 21:20'!
description
	^ 'HTTP'! !

!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 21:00'!
fillInTheBlankRequest
	^ 'HTTP Repository:'
			! !

!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 21:32'!
location: location user: user password: password
	^ self new
		location: location;
		user: user;
		password: password! !

!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 21:01'!
morphicConfigure
	^ self fillInTheBlankConfigure! !


!MCHttpRepository class methodsFor: 'class initialization' stamp: 'bf 7/28/2005 19:44'!
clearPasswords
	self allSubInstancesDo: [:ea | ea password: ''].
! !
MCTestCase subclass: #MCInitializationTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCInitializationTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/11/2003 23:06'!
tearDown
	(MCWorkingCopy forPackage: self mockPackage) unregister! !

!MCInitializationTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/11/2003 23:50'!
testWorkingCopy
	MczInstaller storeVersionInfo: self mockVersion.
	MCWorkingCopy initialize.
	MCWorkingCopy allManagers
						detect: [:man | man package name = self mockPackage name]
						ifNone: [self assert: false]! !

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

MCInitializationTest class
	instanceVariableNames: ''!

!MCInitializationTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 12:11'!
isAbstract
	^ (Smalltalk hasClassNamed: #MczInstaller) not
		! !
MCVariableDefinition subclass: #MCInstanceVariableDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCInstanceVariableDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:32'!
isInstanceVariable
	^ true! !

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

MCInstanceVariableDefinition class
	instanceVariableNames: ''!

!MCInstanceVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'!
type
	^ #instance! !
MCMczReader subclass: #MCMcdReader
	instanceVariableNames: 'baseInfo patch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/14/2004 21:33'!
baseInfo
	^ baseInfo ifNil: [self loadBaseInfo]! !

!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:41'!
basicVersion
	^ MCDiffyVersion
		package: self package
		info: self info
		dependencies: self dependencies
		baseInfo: self baseInfo
		patch: self patch! !

!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/14/2004 21:37'!
buildPatchFrom: oldDefinitions to: newDefinitions
	^ MCPatch
		fromBase: (MCSnapshot fromDefinitions: oldDefinitions)
		target: (MCSnapshot fromDefinitions: newDefinitions)! !

!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadBaseInfo
	^ baseInfo := self extractInfoFrom: (self parseMember: 'base')! !

!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadPatch
	| old new |
	(self zip memberNamed: 'patch.bin') ifNotNilDo:
		[:m | [^ patch := (DataStream on: m contentStream) next ]
			on: Error do: [:fallThrough ]].
	definitions := OrderedCollection new.
	(self zip membersMatching: 'old/*')
		do: [:m | self extractDefinitionsFrom: m].
	old := definitions asArray.
	definitions := OrderedCollection new.
	(self zip membersMatching: 'new/*')
		do: [:m | self extractDefinitionsFrom: m].
	new := definitions asArray.
	^ patch := self buildPatchFrom: old to: new.
	! !

!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/14/2004 21:34'!
patch
	^ patch ifNil: [self loadPatch]! !

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

MCMcdReader class
	instanceVariableNames: ''!

!MCMcdReader class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:09'!
extension
	^ 'mcd'! !
MCMczWriter subclass: #MCMcdWriter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
writeBaseInfo: aVersionInfo
	| string |
	string := self serializeVersionInfo: aVersionInfo.
	self addString: string at: 'base'.
! !

!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 01:48'!
writeDefinitions: aVersion
	self writeBaseInfo: aVersion baseInfo.
	self writePatch: aVersion patch.! !

!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:07'!
writeNewDefinitions: aCollection
	self addString: (self serializeDefinitions: aCollection) at: 'new/source.', self snapshotWriterClass extension.! !

!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:07'!
writeOldDefinitions: aCollection
	self addString: (self serializeDefinitions: aCollection) at: 'old/source.', self snapshotWriterClass extension.! !

!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
writePatch: aPatch
	| old new |
	old := OrderedCollection new.
	new := OrderedCollection new.
	aPatch operations do:
		[:ea |
		ea isRemoval ifTrue: [old add: ea definition].
		ea isAddition ifTrue: [new add: ea definition].
		ea isModification ifTrue: [old add: ea baseDefinition. new add: ea definition]].
	self writeOldDefinitions: old.
	self writeNewDefinitions: new.
	self addString: (self serializeInBinary: aPatch) at: 'patch.bin'.! !

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

MCMcdWriter class
	instanceVariableNames: ''!

!MCMcdWriter class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:09'!
readerClass
	^ MCMcdReader! !
MCVersionReader subclass: #MCMcmReader
	instanceVariableNames: 'fileName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MonticelloConfigurations'!

!MCMcmReader methodsFor: 'accessing' stamp: 'bf 3/23/2005 01:17'!
configurationName
	^fileName ifNotNil: [(fileName findTokens: '/\:') last copyUpToLast: $.]! !

!MCMcmReader methodsFor: 'accessing' stamp: 'bf 3/23/2005 01:17'!
fileName: aString
	fileName := aString! !

!MCMcmReader methodsFor: 'accessing' stamp: 'bf 3/23/2005 00:05'!
version
	| configuration |
	configuration := MCConfiguration fromArray: (MCScanner scan: stream).
	configuration name: self configurationName.
	^configuration! !

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

MCMcmReader class
	instanceVariableNames: ''!

!MCMcmReader class methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:47'!
extension
	^ 'mcm'! !


!MCMcmReader class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'!
on: aStream fileName: aFileName
	| reader |
	reader := self on: aStream.
	reader fileName: aFileName.
	^reader! !
MCWriter subclass: #MCMcmWriter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MonticelloConfigurations'!

!MCMcmWriter methodsFor: 'writing' stamp: 'bf 3/22/2005 18:00'!
close
	stream close! !

!MCMcmWriter methodsFor: 'writing' stamp: 'bf 3/24/2005 01:50'!
writeConfiguration: aConfiguration

	stream nextPut: $(.

	aConfiguration repositories do: [:ea | 
		stream cr.
		stream nextPutAll: 'repository '.
		(MCConfiguration repositoryToArray: ea) printElementsOn: stream].

	aConfiguration dependencies do: [:ea | 
		stream cr.
		stream nextPutAll: 'dependency '.
		(MCConfiguration dependencyToArray: ea) printElementsOn: stream].

	stream cr.
	stream nextPut: $).
	stream cr.! !

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

MCMcmWriter class
	instanceVariableNames: ''!

!MCMcmWriter class methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:49'!
readerClass
	^ MCMcmReader! !


!MCMcmWriter class methodsFor: 'writing' stamp: 'stephaneducasse 2/4/2006 20:47'!
fileOut: aConfiguration on: aStream
	| inst |
	inst := self on: aStream.
	inst writeConfiguration: aConfiguration.
	inst close.
	
! !
MCTestCase subclass: #MCMczInstallerTest
	instanceVariableNames: 'expected diff'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:11'!
assertDict: dict matchesInfo: info
	#(name id message date time author)
		do: [:sel |  (info perform: sel) ifNotNilDo: [:i | dict at: sel ifPresent: [:d | self assert: i = d]]].
	info ancestors 
			with: (dict at: #ancestors) 
			do: [:i :d | self assertDict: d matchesInfo: i]! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertNoChange
	| actual |
	actual := MCSnapshotResource takeSnapshot.
	diff := actual patchRelativeToBase: expected snapshot.
	self assert: diff isEmpty! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertVersionInfoPresent
	| dict info |
	dict := MczInstaller versionInfo at: self mockPackage name.
	info := expected info.
	self assertDict: dict matchesInfo: info.! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 18:18'!
deleteFile
	(FileDirectory default fileExists: self fileName)
		ifTrue: [FileDirectory default deleteFileNamed: self fileName]! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 18:15'!
fileName
	^ 'InstallerTest.mcz'! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 18:16'!
fileStream
	^ FileStream forceNewFileNamed: self fileName.! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	expected := self mockVersion.
	self change: #one toReturn: 2.! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 19:36'!
tearDown
	expected snapshot updatePackage: self mockPackage.
	self deleteFile.! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 16:25'!
testInstallFromFile
	MCMczWriter fileOut: expected on: self fileStream.
	MczInstaller installFileNamed: self fileName.
	self assertNoChange.! !

!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testInstallFromStream
	| stream |
	stream := RWBinaryOrTextStream on: String new.
	MCMczWriter fileOut: expected on: stream.
	MczInstaller installStream: stream reset.
	self assertNoChange.
	self assertVersionInfoPresent.
	! !

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

MCMczInstallerTest class
	instanceVariableNames: ''!

!MCMczInstallerTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 12:11'!
isAbstract
	^ (Smalltalk hasClassNamed: #MczInstaller) not
		! !

!MCMczInstallerTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 11:56'!
suite
	^ (Smalltalk hasClassNamed: #MczInstaller)
		ifTrue: [super suite]
		ifFalse: [TestSuite new name: self name asString]! !
MCVersionReader subclass: #MCMczReader
	instanceVariableNames: 'zip infoCache'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
associate: tokens
	| result |
	result := Dictionary new.
	tokens pairsDo: [:key :value | 
					value isString ifFalse: [value := value collect: [:ea | self associate: ea]].
					result at: key put: value].
	^ result! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
extractDefinitionsFrom: member
	| reader |
	(MCSnapshotReader readerClassForFileNamed: member fileName)
		ifNotNilDo: [:rc | reader := rc on: member contentStream text.
					definitions addAll: reader definitions]
! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'avi 1/19/2004 16:11'!
extractDependencyFrom: zipMember
	^ MCVersionDependency
		package: (MCPackage named: (zipMember fileName copyAfterLast: $/))
		info: (self extractInfoFrom: (self parseMember: zipMember fileName))! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 23:38'!
extractInfoFrom: dict
	^ self infoCache at: (dict at: #id) ifAbsentPut:
		[MCVersionInfo
			name: (dict at: #name ifAbsent: [''])
			id: (UUID fromString: (dict at: #id))
			message: (dict at: #message ifAbsent: [''])
			date: ([Date fromString: (dict at: #date) ] on: Error do: [ :ex | ex return: nil ])
			time: ([ Time fromString:(dict at: #time)] on: Error do: [ :ex | ex return: nil ])
			author: (dict at: #author ifAbsent: [''])
			ancestors: ((dict at: #ancestors) collect: [:ea | self extractInfoFrom: ea])
			stepChildren: ((dict at: #stepChildren ifAbsent: [#()]) collect: [:ea | self extractInfoFrom: ea])]! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
infoCache
	^ infoCache ifNil: [infoCache := Dictionary new]! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadDefinitions
	definitions := OrderedCollection new.
	(self zip memberNamed: 'snapshot.bin') ifNotNilDo:
		[:m | [^ definitions := (DataStream on: m contentStream) next definitions]
			on: Error do: [:fallThrough ]].
	"otherwise"
	(self zip membersMatching: 'snapshot/*')
		do: [:m | self extractDefinitionsFrom: m].
! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadDependencies
	dependencies := (self zip membersMatching: 'dependencies/*') collect: [:m | self extractDependencyFrom: m].
	dependencies := dependencies asArray.
! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadPackage
	| dict |
	dict := self parseMember: 'package'.
	package := MCPackage named: (dict at: #name)! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadVersionInfo
	info := self extractInfoFrom: (self parseMember: 'version')! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
parseMember: fileName
	| tokens |
	tokens := (self scanner scanTokens: (self zip contentsOf: fileName)) first.
	^ self associate: tokens! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:33'!
scanner
	^ MCScanner! !

!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
zip
	zip ifNil:
		[zip := ZipArchive new.
		zip readFrom: stream].
	^ zip! !

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

MCMczReader class
	instanceVariableNames: ''!

!MCMczReader class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 14:59'!
extension
	^ 'mcz'! !


!MCMczReader class methodsFor: 'testing' stamp: 'avi 1/19/2004 14:48'!
supportsDependencies
	^ true! !

!MCMczReader class methodsFor: 'testing' stamp: 'cwp 8/1/2003 12:19'!
supportsVersions
	^ true! !
MCWriter subclass: #MCMczWriter
	instanceVariableNames: 'zip infoWriter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCMczWriter methodsFor: 'accessing' stamp: 'avi 2/17/2004 01:54'!
format
	^ '1'! !

!MCMczWriter methodsFor: 'accessing' stamp: 'avi 2/17/2004 02:07'!
snapshotWriterClass
	^ MCStWriter! !

!MCMczWriter methodsFor: 'accessing' stamp: 'cwp 8/1/2003 00:06'!
zip
	^ zip! !


!MCMczWriter methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	zip := ZipArchive new.
! !


!MCMczWriter methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
serializeDefinitions: aCollection
	| writer s |
	s := RWBinaryOrTextStream on: String new.
	writer := self snapshotWriterClass on: s.
	writer writeDefinitions: aCollection.
	^ s contents! !

!MCMczWriter methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
serializeInBinary: aSnapshot
	| writer s |
	s := RWBinaryOrTextStream on: String new.
	writer := DataStream on: s.
	writer nextPut: aSnapshot.
	^ s contents! !

!MCMczWriter methodsFor: 'serializing' stamp: 'cwp 8/13/2003 01:06'!
serializePackage: aPackage
	^ '(name ''', aPackage name, ''')'! !

!MCMczWriter methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
serializeVersionInfo: aVersionInfo
	infoWriter ifNil: [infoWriter := MCVersionInfoWriter new].
	^ String streamContents:
		[:s |
		infoWriter stream: s.
		infoWriter writeVersionInfo: aVersionInfo]! !


!MCMczWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:48'!
writeDefinitions: aVersion
	self writeSnapshot: aVersion snapshot! !

!MCMczWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:56'!
writeFormat
"	self addString: self format at: 'format'."! !

!MCMczWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:48'!
writePackage: aPackage
	self addString: (self serializePackage: aPackage) at: 'package'! !

!MCMczWriter methodsFor: 'visiting' stamp: 'avi 9/28/2004 14:26'!
writeSnapshot: aSnapshot
	self addString: (self serializeDefinitions: aSnapshot definitions) at: 'snapshot/source.', self snapshotWriterClass extension.
	self addString: (self serializeInBinary: aSnapshot) at: 'snapshot.bin'! !

!MCMczWriter methodsFor: 'visiting' stamp: 'stephaneducasse 2/4/2006 20:47'!
writeVersionDependency: aVersionDependency
	| string |
	string := (self serializeVersionInfo: aVersionDependency versionInfo).
	self addString: string at: 'dependencies/', aVersionDependency package name! !

!MCMczWriter methodsFor: 'visiting' stamp: 'stephaneducasse 2/4/2006 20:47'!
writeVersionInfo: aVersionInfo
	| string |
	string := self serializeVersionInfo: aVersionInfo.
	self addString: string at: 'version'.
! !

!MCMczWriter methodsFor: 'visiting' stamp: 'avi 9/13/2004 16:49'!
writeVersion: aVersion
	self writeFormat.
	self writePackage: aVersion package.
	self writeVersionInfo: aVersion info.
	self writeDefinitions: aVersion.
	aVersion dependencies do: [:ea | self writeVersionDependency: ea]! !


!MCMczWriter methodsFor: 'writing' stamp: 'stephaneducasse 2/4/2006 20:47'!
addString: string at: path
	| member |
	member := zip addString: string as: path.
	member desiredCompressionMethod: ZipArchive compressionDeflated 
	! !

!MCMczWriter methodsFor: 'writing' stamp: 'avi 2/17/2004 02:17'!
flush
	zip writeTo: stream.
	stream close! !

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

MCMczWriter class
	instanceVariableNames: ''!

!MCMczWriter class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
fileOut: aVersion on: aStream
	| inst |
	inst := self on: aStream.
	inst writeVersion: aVersion.
	inst flush.
	
! !

!MCMczWriter class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:03'!
new
	^ self basicNew initialize! !

!MCMczWriter class methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 12:35'!
readerClass
	^ MCMczReader! !
MCPatchBrowser subclass: #MCMergeBrowser
	instanceVariableNames: 'conflicts merger ok'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:35'!
buttonSpecs
	^ #((Merge merge 'Proceed with the merge' canMerge)
		 (Cancel cancel 'Cancel the merge')
		('All Newer' chooseAllNewerConflicts 'Choose all newer conflict versions')
		('All Older' chooseAllOlderConflicts 'Choose all older conflict versions')
		('Rest Local' chooseAllUnchosenLocal 'Choose local versions of all remaining conflicts')
		('Rest Remote' chooseAllUnchosenRemote 'Choose remote versions of all remaining conflicts')
)! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 17:52'!
cancel
	self answer: false! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/22/2003 00:51'!
canMerge
	^ merger isMerged! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:21'!
chooseAllNewerConflicts
	conflicts do: [ :ea | ea chooseNewer ].
	self changed: #text; changed: #list.! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:22'!
chooseAllOlderConflicts
	conflicts do: [ :ea | ea chooseOlder ].
	self changed: #text; changed: #list.! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:34'!
chooseAllUnchosenLocal
	conflicts do: [ :ea | ea isResolved ifFalse: [ ea chooseLocal ] ].
	self changed: #text; changed: #list.! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:34'!
chooseAllUnchosenRemote
	conflicts do: [ :ea | ea isResolved ifFalse: [ ea chooseRemote ] ].
	self changed: #text; changed: #list.! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:41'!
chooseLocal
	self conflictSelectionDo:
		[selection chooseLocal.
		self changed: #text; changed: #list]! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:41'!
chooseRemote
	self conflictSelectionDo:
		[selection chooseRemote.
		self changed: #text; changed: #list]! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:41'!
clearChoice
	self conflictSelectionDo:
		[selection clearChoice.
		self changed: #text; changed: #list]! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:42'!
conflictSelectionDo: aBlock
	self selectionIsConflicted
		ifTrue: aBlock
		ifFalse: [self inform: 'You must have a conflict selected']! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 21:31'!
defaultLabel
	^ 'Merge Browser'! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:04'!
getConflictMenu: aMenu
	selection remoteChosen
		ifTrue: [aMenu add: 'undo keep change' target: self selector: #clearChoice]
		ifFalse: [aMenu add: 'keep change' target: self selector: #chooseRemote].
	selection localChosen
		ifTrue: [aMenu add: 'undo reject change' target: self selector: #clearChoice]	
		ifFalse: [aMenu add: 'reject change' target: self selector: #chooseLocal].
	^ aMenu! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:07'!
getMenu: aMenu
	selection ifNil: [^ aMenu].
	^ self selectionIsConflicted
		ifTrue: [self getConflictMenu: aMenu]
		ifFalse: [self getOperationMenu: aMenu]! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 16:37'!
getOperationMenu: aMenu
	^ aMenu! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/22/2003 00:49'!
innerButtonRow
	^ self buttonRow:
		#((Keep chooseRemote 'keep the selected change' selectionIsConflicted)
		  (Reject chooseLocal 'reject the selected change' selectionIsConflicted))! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 16:32'!
items
	^ conflicts, items! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 17:52'!
merge
	merger isMerged
		ifFalse: [self inform: 'You must resolve all the conflicts first']
		ifTrue: [self answer: true] ! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
merger: aMerger
	merger := aMerger.
	items := aMerger operations asSortedCollection.
	conflicts := aMerger conflicts.! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:07'!
selectionIsConflicted
	^ selection isKindOf: MCConflict! !

!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'nk 11/10/2003 22:08'!
widgetSpecs
	Preferences annotationPanes ifFalse: [ ^#(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 30 0 0))
		((innerButtonRow) (0 0.4 1 0.4) (0 0 0 30))
		((textMorph: text) (0 0.4 1 1) (0 30 0 0))
		)].

	^ #(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 30 0 0))
		((innerButtonRow) (0 0.4 1 0.4) (0 0 0 30))
		((textMorph: annotations) (0 0.4 1 0.4) (0 30 0 60))
		((textMorph: text) (0 0.4 1 1) (0 60 0 0))
		)! !

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

MCMergeBrowser class
	instanceVariableNames: ''!

!MCMergeBrowser class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
resolveConflictsInMerger: aMerger
	| inst |
	inst := self new merger: aMerger.
	^ inst showModally ifNil: [false]! !
Object subclass: #MCMergeRecord
	instanceVariableNames: 'version packageSnapshot ancestorInfo ancestor ancestorSnapshot imagePatch mergePatch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
ancestorInfo
	^ ancestorInfo ifNil: [ancestorInfo := version info commonAncestorWith: version workingCopy ancestry]! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
ancestorSnapshot
	^ ancestorSnapshot ifNil: [ancestorSnapshot := version workingCopy findSnapshotWithVersionInfo: self ancestorInfo]! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
imageIsClean
	| ancestors |
	ancestors := version workingCopy ancestors.
	^ ancestors size = 1
		and: [ancestors first = self ancestorInfo]	
		and: [self imagePatch isEmpty]! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
imagePatch
	^ imagePatch ifNil: [imagePatch := self packageSnapshot patchRelativeToBase: self ancestorSnapshot]! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithVersion: aVersion
	version := aVersion! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 17:14'!
isAncestorMerge
	^ version workingCopy ancestry hasAncestor: version info! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
mergePatch
	^ mergePatch ifNil: [mergePatch := version snapshot patchRelativeToBase: self ancestorSnapshot]! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
packageSnapshot
	^ packageSnapshot ifNil: [packageSnapshot := version package snapshot]! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 17:14'!
updateWorkingCopy
	self isAncestorMerge ifFalse:
		[self imageIsClean
			ifTrue: [version workingCopy loaded: version]
			ifFalse: [version workingCopy merged: version]]! !

!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 15:52'!
version
	^ version! !

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

MCMergeRecord class
	instanceVariableNames: ''!

!MCMergeRecord class methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 15:52'!
version: aVersion
	^ self basicNew initializeWithVersion: aVersion! !
Notification subclass: #MCMergeResolutionRequest
	instanceVariableNames: 'merger'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCMergeResolutionRequest methodsFor: 'as yet unclassified' stamp: 'bf 4/26/2005 14:25'!
defaultAction
	^ (MCMergeBrowser new
		merger: merger;
		label: messageText) showModally! !

!MCMergeResolutionRequest methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:19'!
merger
	^ merger! !

!MCMergeResolutionRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
merger: aMerger
	merger := aMerger! !

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

MCMergeResolutionRequest class
	instanceVariableNames: ''!
Object subclass: #MCMerger
	instanceVariableNames: 'conflicts'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Merging'!

!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:10'!
addConflictWithOperation: anOperation
	self conflicts add: (MCConflict operation: anOperation)! !

!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:01'!
applyTo: anObject
	self isMerged ifFalse: [self error: 'You must resolve all the conflicts first'].
	conflicts do: [:ea | ea applyTo: anObject]! !

!MCMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
conflicts
	^ conflicts ifNil: [conflicts := OrderedCollection new]! !

!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/5/2003 19:09'!
isMerged
	^ self conflicts allSatisfy: [:ea | ea isResolved]! !

!MCMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
load
	| loader |
	loader := MCPackageLoader new.
	loader provisions addAll: self provisions.
	self applyTo: loader.
	loader load! !

!MCMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadWithNameLike: baseName
	| loader |
	loader := MCPackageLoader new.
	loader provisions addAll: self provisions.
	self applyTo: loader.
	loader loadWithNameLike: baseName! !

!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:11'!
mergedSnapshot
	^ MCPatcher apply: self to: self baseSnapshot! !

!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 16:34'!
operations
	^ #()! !

!MCMerger methodsFor: 'as yet unclassified' stamp: 'avi 10/6/2004 15:19'!
provisions
	^ #()! !

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

MCMerger class
	instanceVariableNames: ''!
MCTestCase subclass: #MCMergingTest
	instanceVariableNames: 'conflictBlock conflicts'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCMergingTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertMerge: local with: remote base: ancestor gives: result conflicts: conflictResult
	| merger |
	conflicts := #().
	merger := MCThreeWayMerger
				base: (self snapshotWithElements: local)
				target: (self snapshotWithElements: remote)
				ancestor: (self snapshotWithElements: ancestor).
	merger conflicts do: [:ea | self handleConflict: ea].
	self assert: merger mergedSnapshot definitions hasElements: result.
	self assert: conflicts asSet = conflictResult asSet.! !

!MCMergingTest methodsFor: 'asserting' stamp: 'ab 1/15/2003 16:46'!
assert: aCollection hasElements: anArray
	self assert: (aCollection collect: [:ea | ea token]) asSet = anArray asSet! !


!MCMergingTest methodsFor: 'emulating' stamp: 'stephaneducasse 2/4/2006 20:47'!
handleConflict: aConflict	
	|l r|
	l := #removed.
	r := #removed.
	aConflict localDefinition ifNotNilDo: [:d | l := d token].
	aConflict remoteDefinition ifNotNilDo: [:d | r := d token].	
	conflicts := conflicts copyWith: (Array with: r with: l).
	(l = #removed or: [r = #removed])
		ifTrue: [aConflict chooseRemote]
		ifFalse:
			[l > r
				ifTrue: [aConflict chooseLocal]
				ifFalse: [aConflict chooseRemote]]
		! !

!MCMergingTest methodsFor: 'emulating' stamp: 'ab 7/6/2003 23:48'!
snapshotWithElements: anArray
	^ MCSnapshot
		fromDefinitions: (anArray collect: [:t | self mockToken: t])! !


!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:28'!
testAdditiveConflictlessMerge
	self
		assertMerge: #(a1 b1)
				with: #(a1 c1)
				base: #(a1)
			
				gives: #(a1 b1 c1)
				conflicts: #()! !

!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:27'!
testComplexConflictlessMerge
	self 
		assertMerge: #(a1 b1 d1)
				with: #(a2 c1)
				base: #(a1 c1 d1)
				
				gives: #(a2 b1)
				conflicts: #()! !

!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:28'!
testIdenticalModification
	self
		assertMerge: #(a2 b1)
				with: #(a2 b1)
				base: #(a1 b1)
				
				gives: #(a2 b1)
				conflicts: #()! !

!MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:44'!
testLocalModifyRemoteRemove
	self assertMerge: #(a2 b1)
				with: #(b1)
				base: #(a1 b1)
				
				gives: #(b1)
				conflicts: #((removed a2)).
				
	self assertMerge: #(a1 b1)
				with: #(b1)
				base: #(a2 b1)
				
				gives: #(b1)
				conflicts: #((removed a1)).! !

!MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:43'!
testLocalRemoveRemoteModify
	self assertMerge: #(b1)
				with: #(a1 b1)
				base: #(a2 b1)
				
				gives: #(a1 b1)
				conflicts: #((a1 removed)).

	self assertMerge: #(b1)
				with: #(a2 b1)
				base: #(a1 b1)
				
				gives: #(a2 b1)
				conflicts: #((a2 removed)).! !

!MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testMultiPackageMerge
	| merger |
	conflicts := #().
	merger := MCThreeWayMerger new.
	merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)).
	merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))).
	merger applyPatch: ((self snapshotWithElements: #(a2 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))).
	merger conflicts do: [:ea | self handleConflict: ea].
	self assert: merger mergedSnapshot definitions hasElements: #(a2 b1).
	self assert: conflicts isEmpty! !

!MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testMultiPackageMerge2
	| merger |
	conflicts := #().
	merger := MCThreeWayMerger new.
	merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)).
	merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))).
	merger applyPatch: ((self snapshotWithElements: #(a1 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))).
	merger conflicts do: [:ea | self handleConflict: ea].
	self assert: merger mergedSnapshot definitions hasElements: #(a1 b1).
	self assert: conflicts isEmpty! !

!MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testMultiPackageMerge3
	| merger |
	conflicts := #().
	merger := MCThreeWayMerger new.
	merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)).
	merger applyPatch: ((self snapshotWithElements: #(a1 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))).
	merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))).
	merger conflicts do: [:ea | self handleConflict: ea].
	self assert: merger mergedSnapshot definitions hasElements: #(a1 b1).
	self assert: conflicts isEmpty! !

!MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:38'!
testMultipleConflicts
	self assertMerge: #(a1 b3 c1)
				with: #(a1 b2 d1)
				base: #(a1 b1 c2)
				
				gives: #(a1 b3 d1)
				conflicts: #((removed c1) (b2 b3))
! !

!MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:38'!
testSimultaneousModification
	self assertMerge: #(a2)
				with: #(a3)
				base: #(a1)
				
				gives: #(a3)
				conflicts: #((a3 a2)).! !

!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 01:27'!
testSimultaneousRemove
	self assertMerge: #(a1)
				with: #(a1)
				base: #(a1 b1)
				
				gives: #(a1)
				conflicts: #()! !

!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 01:31'!
testSubtractiveConflictlessMerge
	self assertMerge: #(a1 b1)
				with: #()
				base: #(a1)
				
				gives: #(b1)
				conflicts: #()! !

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

MCMergingTest class
	instanceVariableNames: ''!
MCDefinition subclass: #MCMethodDefinition
	instanceVariableNames: 'classIsMeta source category selector className timeStamp'
	classVariableNames: 'Definitions'
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCMethodDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:10'!
actualClass
	^Smalltalk at: className
		ifPresent: [:class | classIsMeta ifTrue: [class classSide] ifFalse: [class]]! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:59'!
category
	^ category! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 07:26'!
classIsMeta
	^ classIsMeta! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/15/2002 01:12'!
className
	^className! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'nk 10/21/2003 23:08'!
fullTimeStamp
	^TimeStamp fromMethodTimeStamp: timeStamp! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'avi 1/24/2004 18:38'!
load
	self actualClass
		compile: source
		classified: category
		withStamp: timeStamp
		notifying: (SyntaxError new category: category)! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/15/2002 01:11'!
selector
	^selector! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:59'!
source
	^ source! !

!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 1/15/2003 13:42'!
timeStamp
	^ timeStamp! !


!MCMethodDefinition methodsFor: 'annotations' stamp: 'nk 7/24/2003 16:06'!
printAnnotations: requests on: aStream
	"Add a string for an annotation pane, trying to fulfill the annotation requests.
	These might include anything that
		Preferences defaultAnnotationRequests 
	might return. Which includes anything in
		Preferences annotationInfo
	To edit these, use:"
	"Preferences editAnnotations"

	requests do: [ :aRequest |
		aRequest == #timeStamp ifTrue: [ aStream nextPutAll: self timeStamp ].
		aRequest == #messageCategory ifTrue: [ aStream nextPutAll: self category ].
		aRequest == #requirements ifTrue: [
			self requirements do: [ :req |
				aStream nextPutAll: req ] separatedBy: [ aStream space ]].
	] separatedBy: [ aStream space ].! !


!MCMethodDefinition methodsFor: 'comparing' stamp: 'stephaneducasse 2/4/2006 20:47'!
hash
	| hash |
	hash := String stringHash: classIsMeta asString initialHash: 0.
	hash := String stringHash: source initialHash: hash.
	hash := String stringHash: category initialHash: hash.
	hash := String stringHash: className initialHash: hash.
	^ hash! !

!MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 5/24/2003 14:11'!
requirements
	^ Array with: className! !

!MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:01'!
sortKey
	^ self className, '.', (self classIsMeta ifTrue: ['meta'] ifFalse: ['nonmeta']), '.', self selector! !

!MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 8/22/2003 17:49'!
= aDefinition
	^(super = aDefinition)
		and: [aDefinition source = self source]
		and: [aDefinition category = self category]
		and: [aDefinition timeStamp = self timeStamp]! !


!MCMethodDefinition methodsFor: 'installing' stamp: 'avi 9/17/2003 22:27'!
isExtensionMethod
	^ category beginsWith: '*'! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'avi 11/10/2003 15:45'!
isOverrideMethod
	"this oughta check the package"
	^ self isExtensionMethod and: [category endsWith: '-override']! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'al 6/6/2006 09:32'!
postload
	(self isInitializer and: [ self actualClass isTrait not ]) ifTrue: [
		self actualClass theNonMetaClass initialize]! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'stephaneducasse 2/4/2006 20:47'!
scanForPreviousVersion
	| position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp method file methodCategory |
	method := self actualClass compiledMethodAt: selector ifAbsent: [^ nil].
	position := method filePosition.
	sourceFilesCopy := SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	[method fileIndex == 0 ifTrue: [^ nil].
	file := sourceFilesCopy at: method fileIndex.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  "Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble := file nextChunk].

		"Preamble is likely a linked method preamble, if we're in
			a changes file (not the sources file).  Try to parse it
			for prior source position and file index"
		prevPos := nil.
		stamp := ''.
		(preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [tokens := Scanner new scanTokens: preamble]
			ifFalse: [tokens := Array new  "ie cant be back ref"].
		((tokens size between: 7 and: 8)
			and: [(tokens at: tokens size-5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-3) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp := tokens at: tokens size-2.
						prevPos := tokens last.
						prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]
				ifFalse: ["Old format gives no stamp; prior pointer in two parts"
						prevPos := tokens at: tokens size-2.
						prevFileIndex := tokens last].
				(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]].
		((tokens size between: 5 and: 6)
			and: [(tokens at: tokens size-3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-1) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp := tokens at: tokens size]].
		methodCategory := tokens after: #methodsFor: ifAbsent: ['as yet unclassifed'].
		methodCategory = category ifFalse:
			[methodCategory = (Smalltalk 
									at: #Categorizer 
									ifAbsent: [Smalltalk at: #ClassOrganizer]) 
										default ifTrue: [methodCategory := methodCategory, ' '].
			^ ChangeRecord new file: file position: position type: #method
						class: className category: methodCategory meta: classIsMeta stamp: stamp].
		position := prevPos.
		prevPos notNil ifTrue:
			[file := sourceFilesCopy at: prevFileIndex]].
		^ nil]
			ensure: [sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]]
	! !

!MCMethodDefinition methodsFor: 'installing' stamp: 'stephaneducasse 2/4/2006 20:47'!
unload
	| previousVersion |
	self isOverrideMethod ifTrue: [previousVersion := self scanForPreviousVersion].
	previousVersion
		ifNil: [self actualClass ifNotNilDo: [:class | class removeSelector: selector]]
		ifNotNil: [previousVersion fileIn] ! !


!MCMethodDefinition methodsFor: 'printing' stamp: 'ab 12/5/2002 21:25'!
description
	^ Array	
		with: className
		with: selector
		with: classIsMeta! !

!MCMethodDefinition methodsFor: 'printing' stamp: 'al 12/3/2005 12:15'!
fullClassName
	"Using #class selector for classes for backwards compatibility"

	^ self classIsMeta
		ifFalse: [self className]
		ifTrue: [
			(self actualClass isNil or: [ self actualClass isTrait ])
				ifFalse: [self className, ' class']
				ifTrue: [self className, ' classSide']]! !

!MCMethodDefinition methodsFor: 'printing' stamp: 'ab 4/8/2003 18:04'!
summary
	^ self fullClassName , '>>' , selector! !


!MCMethodDefinition methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithClassName: classString
classIsMeta: metaBoolean
selector: selectorString
category: catString
timeStamp: timeString
source: sourceString
	className := classString asSymbol.
	selector := selectorString asSymbol.
	category := catString asSymbol.
	timeStamp := timeString.
	classIsMeta := metaBoolean.
	source := sourceString withSqueakLineEndings.
! !


!MCMethodDefinition methodsFor: 'testing' stamp: 'ab 5/24/2003 13:49'!
isCodeDefinition
	^ true! !

!MCMethodDefinition methodsFor: 'testing' stamp: 'ab 8/8/2003 17:05'!
isInitializer
	^ selector = #initialize and: [classIsMeta]
	! !

!MCMethodDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:52'!
isMethodDefinition
	^true! !


!MCMethodDefinition methodsFor: 'visiting' stamp: 'ab 7/18/2003 21:47'!
accept: aVisitor
	^ aVisitor visitMethodDefinition: self! !

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

MCMethodDefinition class
	instanceVariableNames: ''!

!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
cachedDefinitions
	Definitions ifNil: [Definitions := WeakIdentityKeyDictionary new.  WeakArray addWeakDependent: Definitions].
	^ Definitions! !

!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:05'!
className: classString
classIsMeta: metaBoolean
selector: selectorString
category: catString
timeStamp: timeString
source: sourceString
	^ self instanceLike:
		(self new initializeWithClassName: classString
					classIsMeta: metaBoolean
					selector: selectorString
					category: catString
					timeStamp: timeString
					source: sourceString)! !

!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 4/1/2003 01:40'!
className: classString
selector: selectorString
category: catString
timeStamp: timeString
source: sourceString
	^ self	className: classString
			classIsMeta: false
			selector: selectorString
			category: catString
			timeStamp: timeString
			source: sourceString! !

!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2004 00:20'!
forMethodReference: aMethodReference
	| definition |
	definition := self cachedDefinitions at: aMethodReference compiledMethod ifAbsent: [].
	(definition isNil
		or: [definition selector ~= aMethodReference methodSymbol]
		or: [definition className ~= aMethodReference classSymbol]
		or: [definition classIsMeta ~= aMethodReference classIsMeta]
		or: [definition category ~= aMethodReference category])
			ifTrue: [definition := self 
						className: aMethodReference classSymbol
						classIsMeta: aMethodReference classIsMeta
						selector: aMethodReference methodSymbol
						category: aMethodReference category
						timeStamp: aMethodReference timeStamp
						source: aMethodReference source.
					self cachedDefinitions at: aMethodReference compiledMethod put: definition].
	^ definition
	! !

!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 18:14'!
initialize
	Smalltalk addToShutDownList: self! !

!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
shutDown
	WeakArray removeWeakDependent: Definitions.
	Definitions := nil.! !
MCTestCase subclass: #MCMethodDefinitionTest
	instanceVariableNames: 'navigation isModified'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCMethodDefinitionTest methodsFor: 'mocks' stamp: 'al 2/16/2006 09:18'!
override ^ 1! !


!MCMethodDefinitionTest methodsFor: 'running' stamp: 'cwp 11/13/2003 14:15'!
ownPackage
	^ MCWorkingCopy forPackage: (MCPackage named: 'Monticello')! !

!MCMethodDefinitionTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	navigation := (Smalltalk hasClassNamed: #SystemNavigation)
		ifTrue: [(Smalltalk at: #SystemNavigation) new]
		ifFalse: [Smalltalk].
	isModified := self ownPackage modified.! !

!MCMethodDefinitionTest methodsFor: 'running' stamp: 'bf 5/20/2005 18:23'!
tearDown
	self restoreMocks.
	(MCWorkingCopy forPackage: (MCPackage named: 'FooBarBaz')) unregister.
	self class compile: 'override ^ 1' classified: 'mocks'.
	self ownPackage modified: isModified! !


!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testCannotLoad
	| definition |
	definition := self mockMethod: #kjahs87 class: 'NoSuchClass' source: 'kjahs87 ^self' meta: false.
	self should: [definition load] raise: Error.
	self assert: (navigation allImplementorsOf: #kjahs87) isEmpty! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testComparison
	|d1 d2 d3 d4 d5 |
	d1 := self mockMethod: #one class: 'A' source: '1' meta: false.
	d2 := self mockMethod: #one class: 'A' source: '2' meta: false.
	d3 := self mockMethod: #one class: 'A' source: '1' meta: true.
	d4 := self mockMethod: #two class: 'A' source: '1' meta: false.
	d5 := self mockMethod: #two class: 'A' source: '1' meta: false.
	
	self assert: (d1 isRevisionOf: d2).
	self deny: (d1 isSameRevisionAs: d2).
	
	self deny: (d1 isRevisionOf: d3).
	self deny: (d1 isRevisionOf: d4).
	
	self assert: (d4 isSameRevisionAs: d5).! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testLoadAndUnload
	|definition|
	definition := self mockMethod: #one class: 'MCMockClassA' source: 'one ^2' meta: false.
	self assert: self mockInstanceA one = 1.
	definition load.
	self assert: self mockInstanceA one = 2.
	definition unload.
	self deny: (self mockInstanceA respondsTo: #one)! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testPartiallyRevertOverrideMethod
	| definition |
	self class compile: 'override ^ 2' classified: '*foobarbaz'.
	self class compile: 'override ^ 3' classified: self mockOverrideMethodCategory.
	self class compile: 'override ^ 4' classified: self mockOverrideMethodCategory.
	definition := (MethodReference class: self class selector: #override) asMethodDefinition.
	self assert: definition isOverrideMethod.
	self assert: self override = 4.
	definition unload.
	self assert: self override = 2.
	self assert: (MethodReference class: self class selector: #override) category = '*foobarbaz'.
	! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testRevertOldMethod
	| definition changeRecord |
	Object compile: 'yourself ^ self' classified: MCMockPackageInfo new methodCategoryPrefix.
	definition := (MethodReference class: Object selector: #yourself) asMethodDefinition.
	changeRecord := definition scanForPreviousVersion.
	self assert: changeRecord notNil.
	self assert: changeRecord category = 'accessing'.
	changeRecord fileIn.! !

!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testRevertOverrideMethod
	| definition |
	self class compile: 'override ^ 2' classified: self mockOverrideMethodCategory.
	definition := (MethodReference class: self class selector: #override) asMethodDefinition.
	self assert: definition isOverrideMethod.
	self assert: self override = 2.
	definition unload.
	self assert: self override = 1.
	self assert: (MethodReference class: self class selector: #override) category = 'mocks'.
	! !

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

MCMethodDefinitionTest class
	instanceVariableNames: ''!
Object subclass: #MCMock
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

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

MCMock class
	instanceVariableNames: ''!

!MCMock class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:40'!
wantsChangeSetLogging
	^ false! !
SharedPool subclass: #MCMockAPoolDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

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

MCMockAPoolDictionary class
	instanceVariableNames: ''!
MCMockClassA subclass: #MCMockASubclass
	instanceVariableNames: 'x'
	classVariableNames: 'Y'
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

!MCMockASubclass methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
variables
	^ x + Y + MCMockClassA! !

!MCMockASubclass methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
variables2
	^ ivar + CVar! !

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

MCMockASubclass class
	instanceVariableNames: ''!
MCMock subclass: #MCMockClassA
	instanceVariableNames: 'ivar'
	classVariableNames: 'CVar'
	poolDictionaries: ''
	category: 'Monticello-Mocks'!
!MCMockClassA commentStamp: 'cwp 8/10/2003 16:43' prior: 0!
This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.!


!MCMockClassA methodsFor: 'as yet classified'!
d
	^ 'd'! !


!MCMockClassA methodsFor: 'boolean' stamp: 'cwp 7/13/2003 02:49'!
falsehood
	^ false! !

!MCMockClassA methodsFor: 'boolean' stamp: 'ab 7/7/2003 23:21'!
moreTruth

	^ true! !

!MCMockClassA methodsFor: 'boolean'!
truth
	^ true! !


!MCMockClassA methodsFor: 'drag''n''drop' stamp: 'avi 9/23/2003 17:14'!
q! !


!MCMockClassA methodsFor: 'numeric'!
a
	^ 'a2'! !

!MCMockClassA methodsFor: 'numeric'!
b
	^ 'b1'! !

!MCMockClassA methodsFor: 'numeric'!
c
	^ 'c1'! !

!MCMockClassA methodsFor: 'numeric' stamp: 'cwp 8/2/2003 17:26'!
one
	^ 1! !

!MCMockClassA methodsFor: 'numeric' stamp: 'avi 9/11/2004 15:59'!
two
	^ 2! !

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

MCMockClassA class
	instanceVariableNames: ''!

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 02:31'!
cVar
	^ CVar! !

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	CVar := #initialized! !

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
one

	^ 1! !

!MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
touchCVar
	CVar := #touched! !
MCMock subclass: #MCMockClassB
	instanceVariableNames: 'ivarb'
	classVariableNames: 'CVar'
	poolDictionaries: 'MCMockAPoolDictionary'
	category: 'Monticello-Mocks'!
!MCMockClassB commentStamp: '' prior: 0!
This comment has a bang!! Bang!! Bang!!!


!MCMockClassB methodsFor: 'numeric' stamp: 'ab 7/7/2003 23:21'!
two

	^ 2! !

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

MCMockClassB class
	instanceVariableNames: 'ciVar'!
Object subclass: #MCMockClassD
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

!MCMockClassD methodsFor: 'as yet unclassified' stamp: 'cwp 7/8/2003 21:21'!
one
	^ 1! !

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

MCMockClassD class
	instanceVariableNames: ''!
Object variableSubclass: #MCMockClassE
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

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

MCMockClassE class
	instanceVariableNames: ''!

!MCMockClassE class methodsFor: 'as yet unclassified' stamp: 'cwp 7/8/2003 21:22'!
two
	^ 2! !
Object subclass: #MCMockClassF
	instanceVariableNames: ''
	classVariableNames: 'Foo'
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

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

MCMockClassF class
	instanceVariableNames: ''!
Object variableWordSubclass: #MCMockClassG
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

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

MCMockClassG class
	instanceVariableNames: ''!
Object variableByteSubclass: #MCMockClassH
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

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

MCMockClassH class
	instanceVariableNames: ''!
Object weakSubclass: #MCMockClassI
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

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

MCMockClassI class
	instanceVariableNames: ''!
MCDefinition subclass: #MCMockDefinition
	instanceVariableNames: 'token'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
asString

	^ token! !

!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
description

	^ token first! !

!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
hash

	^ token hash! !

!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
printString

	^ token! !

!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
summary

	^ token! !

!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
token

	^ token! !

!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
token: aString

	token := aString! !

!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:25'!
= definition
	^definition token = token! !

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

MCMockDefinition class
	instanceVariableNames: ''!

!MCMockDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
token: aString

	^ self new token: aString! !

!MCMockDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:46'!
wantsChangeSetLogging
	^ false! !
Object subclass: #MCMockDependency
	instanceVariableNames: 'name children hasResolution'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

!MCMockDependency methodsFor: 'accessing' stamp: 'cwp 11/7/2004 14:43'!
children
	^ children collect: [:ea | self class fromTree: ea]! !

!MCMockDependency methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithTree: expr
	expr isSymbol
		ifTrue: [name := expr.
				children := Array new.
				hasResolution := true.]
		ifFalse: [name := expr first.
				expr second isSymbol
					ifTrue: [hasResolution := false.
							children := Array new]
					ifFalse: [hasResolution := true.
							children := expr second]]! !

!MCMockDependency methodsFor: 'accessing' stamp: 'cwp 11/7/2004 14:38'!
name
	^ name! !


!MCMockDependency methodsFor: 'comparing' stamp: 'cwp 11/7/2004 13:33'!
hash
	^ self name hash! !

!MCMockDependency methodsFor: 'comparing' stamp: 'cwp 11/7/2004 13:32'!
= other
	^ self name = other name! !


!MCMockDependency methodsFor: 'mocks' stamp: 'cwp 11/7/2004 14:41'!
mockVersionInfo
	^ MCVersionInfo
		name: self name
		id: (self uuidForName: name)
		message: ''
		date: nil
		time: nil
		author: ''
		ancestors: #()! !

!MCMockDependency methodsFor: 'mocks' stamp: 'nk 2/22/2005 21:17'!
uuidForName: aName 
	| nm id |
	nm := aName asString.
	id := '00000000-0000-0000-0000-0000000000' 
				, (nm size = 1 ifTrue: [nm , '0'] ifFalse: [nm]).
	^UUID fromString: id! !


!MCMockDependency methodsFor: 'resolving' stamp: 'cwp 11/7/2004 14:42'!
hasResolution
	^ hasResolution! !

!MCMockDependency methodsFor: 'resolving' stamp: 'cwp 11/7/2004 14:16'!
resolve
	^ self hasResolution
		ifTrue: [MCVersion new
					setPackage: MCSnapshotResource mockPackage
					info: self mockVersionInfo
					snapshot: MCSnapshotResource current snapshot
					dependencies: self children]
		ifFalse: [nil]! !

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

MCMockDependency class
	instanceVariableNames: ''!

!MCMockDependency class methodsFor: 'instance creation' stamp: 'cwp 11/7/2004 14:43'!
fromTree: anArray 
	^ self new initializeWithTree: anArray! !
MCMock subclass: #MCMockDependentItem
	instanceVariableNames: 'name provides requires'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
name

	^ name! !

!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
name: aString

	name := aString! !

!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
provides: anArray

	provides := anArray! !

!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
provisions

	^ provides ifNil: [#()]! !

!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'!
requirements

	^ requires ifNil: [#()]! !

!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
requires: anArray

	requires := anArray! !

!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'bf 5/20/2005 16:15'!
<= other
	^ self name <= other name! !

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

MCMockDependentItem class
	instanceVariableNames: ''!
PackageInfo subclass: #MCMockPackageInfo
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Mocks'!

!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:12'!
classes
	^ self classNames 
		select: [:name | Smalltalk hasClassNamed: name]
		thenCollect: [:name | Smalltalk at: name]! !

!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:09'!
classNames
	^ #(	MCMockClassA
		 	MCMockASubclass
			MCMockClassB
			MCMockClassD
			MCMockClassE
			MCMockClassF
			MCMockClassG
			MCMockClassH
			MCMockClassI
		)! !

!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 20:25'!
extensionMethods
	^ Array with: (MethodReference new 
					setStandardClass: MCSnapshotTest 
					methodSymbol: #mockClassExtension)! !

!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'bf 5/20/2005 16:54'!
includesClass: aClass
	^self classes includes: aClass! !

!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'bf 5/20/2005 17:18'!
includesSystemCategory: categoryName
	^self systemCategories anySatisfy: [:cat | cat sameAs: categoryName]! !

!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 20:31'!
packageName
	^ 'MonticelloMocks'! !

!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 7/31/2003 15:30'!
systemCategories
	^ Array with: 'Monticello-Mocks'! !

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

MCMockPackageInfo class
	instanceVariableNames: ''!

!MCMockPackageInfo class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:04'!
initialize
	[self new register] on: MessageNotUnderstood do: []! !
MCPatchOperation subclass: #MCModification
	instanceVariableNames: 'obsoletion modification'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Patching'!

!MCModification methodsFor: 'accessing' stamp: 'ab 5/24/2003 16:12'!
applyTo: anObject
	anObject modifyDefinition: obsoletion to: modification! !

!MCModification methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'!
baseDefinition
	^ obsoletion! !

!MCModification methodsFor: 'accessing' stamp: 'cwp 11/28/2002 06:55'!
definition
	^ modification! !

!MCModification methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'!
fromSource
	^ obsoletion source! !

!MCModification methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:46'!
modification
	^ modification! !

!MCModification methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:48'!
obsoletion
	^ obsoletion! !

!MCModification methodsFor: 'accessing' stamp: 'nk 10/21/2003 22:54'!
summarySuffix
	^self fromSource = self toSource
		ifTrue: [ ' (source same but rev changed)' ]
		ifFalse: [ ' (changed)' ]! !

!MCModification methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:18'!
targetClass
	^ obsoletion actualClass! !

!MCModification methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'!
targetDefinition
	^ modification! !

!MCModification methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'!
toSource
	^ modification source! !


!MCModification methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 02:27'!
inverse
	^ MCModification of: modification to: obsoletion! !

!MCModification methodsFor: 'as yet unclassified' stamp: 'nk 2/25/2005 17:29'!
isClassPatch
	^obsoletion isClassDefinition! !

!MCModification methodsFor: 'as yet unclassified' stamp: 'nk 11/10/2003 21:44'!
printAnnotations: request on: aStream
	aStream nextPutAll: 'old: '.
	obsoletion printAnnotations: request on: aStream.
	aStream cr.
	aStream nextPutAll: 'new: '.
	modification printAnnotations: request on: aStream.! !


!MCModification methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithBase: base target: target
	obsoletion := base.
	modification := target.! !


!MCModification methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:23'!
isModification
	^ true! !

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

MCModification class
	instanceVariableNames: ''!

!MCModification class methodsFor: 'as yet unclassified' stamp: 'cwp 11/28/2002 07:19'!
of: base to: target
	^ self new initializeWithBase: base target: target! !
Exception subclass: #MCNoChangesException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCNoChangesException methodsFor: 'as yet unclassified' stamp: 'jf 8/21/2003 19:49'!
defaultAction
	self inform: 'No changes'! !

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

MCNoChangesException class
	instanceVariableNames: ''!
MCDefinition subclass: #MCOrganizationDefinition
	instanceVariableNames: 'categories'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 21:47'!
accept: aVisitor
	^ aVisitor visitOrganizationDefinition: self! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 5/24/2003 13:51'!
categories
	^ categories! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
categories: anArray
	categories := anArray! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
commonPrefix
	| stream |
	categories isEmpty ifTrue: [^ ''].
	
	stream := String new writeStream.
	categories first withIndexDo:
		[:c :i|
		categories do:
			[:ea |
			(ea at: i ifAbsent: []) = c ifFalse: [^ stream contents]].
		stream nextPut: c].
	^ stream contents! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'avi 9/28/2004 14:53'!
description
	^ Array with: #organization with: self commonPrefix! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 7/11/2003 01:33'!
isOrganizationDefinition
	^ true! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 13:46'!
postloadOver: oldDefinition
	SystemOrganization categories:
		(self
			reorderCategories: SystemOrganization categories
			original: (oldDefinition ifNil: [#()] ifNotNil: [oldDefinition categories]))! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
reorderCategories: allCategories original: oldCategories
	| first |
	first := allCategories detect: [:ea | categories includes: ea] ifNone: [^ allCategories].
	^ 	((allCategories copyUpTo: first) copyWithoutAll: oldCategories, categories),
		categories,
		((allCategories copyAfter: first) copyWithoutAll: oldCategories, categories)
! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:01'!
sortKey
	^ '<organization>'! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/22/2003 01:14'!
source
	^ String streamContents:
		[:s |
		categories do: [:ea | s nextPutAll: ea] separatedBy: [s cr]]! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 5/24/2003 13:55'!
summary
	^ categories asArray printString! !

!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:25'!
= aDefinition
	^ (super = aDefinition)
		and: [categories = aDefinition categories]! !

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

MCOrganizationDefinition class
	instanceVariableNames: ''!

!MCOrganizationDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:06'!
categories: anArray
	^ self instanceLike: (self new categories: anArray)! !
MCTestCase subclass: #MCOrganizationTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCOrganizationTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testReordering
	|dec cats newCats |
	dec := MCOrganizationDefinition categories: #(A B C).
	cats := #(X Y B Z C A Q).
	newCats := dec reorderCategories: cats original: #(B C A).
	self assert: newCats asArray = #(X Y A B C Z Q).! !

!MCOrganizationTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testReorderingWithNoCategoriesInVersion
	|dec cats newCats |
	dec := MCOrganizationDefinition categories: #().
	cats := #(X Y B Z C A Q).
	newCats := dec reorderCategories: cats original: #().
	self assert: newCats asArray = cats.! !

!MCOrganizationTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testReorderingWithRemovals
	|dec cats newCats |
	dec := MCOrganizationDefinition categories: #(A B C).
	cats := #(X Y B Z C A Q).
	newCats := dec reorderCategories: cats original: #(Y B C A Q).
	self assert: newCats asArray = #(X A B C Z).! !

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

MCOrganizationTest class
	instanceVariableNames: ''!
TestCase subclass: #MCPTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Kernel'!

!MCPTest methodsFor: 'constants' stamp: 'dgd 2/14/2003 10:13'!
defaultBounds
	"the default bounds for morphs"
	^ 0 @ 0 corner: 50 @ 40 ! !

!MCPTest methodsFor: 'constants' stamp: 'dgd 2/14/2003 10:13'!
defaultTop
	"the default top for morphs"
	^ self defaultBounds top ! !


!MCPTest methodsFor: 'tests' stamp: 'gm 2/22/2003 12:58'!
testIsMorphicModel
	"test isMorphicModel"
	self deny: Object new isMorphicModel.
	self deny: Morph new isMorphicModel.
	self assert: MorphicModel new isMorphicModel.
! !

!MCPTest methodsFor: 'tests' stamp: 'gm 2/16/2003 20:42'!
testIsSystemWindow
	"test isSystemWindow"
	self deny: Object new isSystemWindow.
	self assert: SystemWindow new isSystemWindow.
	self assert: WorldWindow new isSystemWindow.! !

!MCPTest methodsFor: 'tests' stamp: 'dgd 2/14/2003 10:15'!
testTop
	"test the #top: messages and its consequences"

	| morph factor newTop newBounds |
	morph _ Morph new.
	""
	factor _ 10.
	newTop _ self defaultTop + factor.
	newBounds _ self defaultBounds translateBy: 0 @ factor.
	""
	morph top: newTop.
	""
	self assert: morph top = newTop;
		 assert: morph bounds = newBounds! !
Object subclass: #MCPackage
	instanceVariableNames: 'name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Base'!

!MCPackage methodsFor: 'as yet unclassified' stamp: 'ar 4/26/2005 21:57'!
hash
	^ name asLowercase hash! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'bf 4/19/2005 16:26'!
hasWorkingCopy
	^ MCWorkingCopy registry includesKey: self! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 00:57'!
name
	^ name! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
name: aString
	name := aString! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 13:33'!
packageInfo
	^ PackageInfo named: name! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'nk 7/28/2003 13:30'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: name;
		nextPut: $)! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'bf 3/17/2005 18:35'!
snapshot
	| packageInfo definitions categories |
	packageInfo := self packageInfo.
	definitions := OrderedCollection new.
	categories := packageInfo systemCategories.
	categories isEmpty ifFalse: [ definitions add: (MCOrganizationDefinition categories: categories) ].
	packageInfo methods do: [:ea | definitions add: ea asMethodDefinition] displayingProgress: 'Snapshotting methods...'.
	(packageInfo respondsTo: #overriddenMethods) ifTrue:
		[packageInfo overriddenMethods
			do: [:ea | definitions add:
					(packageInfo changeRecordForOverriddenMethod: ea) asMethodDefinition]
			displayingProgress: 'Searching for overrides...'].
	packageInfo classes do: [:ea | definitions addAll: ea classDefinitions] displayingProgress: 'Snapshotting classes...'.
	(packageInfo respondsTo: #hasPreamble) ifTrue: [
		packageInfo hasPreamble ifTrue: [definitions add: (MCPreambleDefinition from: packageInfo)].
		packageInfo hasPostscript ifTrue: [definitions add: (MCPostscriptDefinition from: packageInfo)].
		packageInfo hasPreambleOfRemoval ifTrue: [definitions add: (MCRemovalPreambleDefinition from: packageInfo)].
		packageInfo hasPostscriptOfRemoval ifTrue: [definitions add: (MCRemovalPostscriptDefinition from: packageInfo)]]. 
	^ MCSnapshot fromDefinitions: definitions
! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'ab 7/10/2003 01:13'!
storeOn: aStream
	aStream
		nextPutAll: 'MCPackage';
		space; nextPutAll: 'named: '; store: name.! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'cwp 11/13/2003 13:32'!
unload
	^ self workingCopy unload! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'cwp 11/13/2003 13:33'!
workingCopy
	^ MCWorkingCopy forPackage: self.! !

!MCPackage methodsFor: 'as yet unclassified' stamp: 'ar 4/26/2005 21:57'!
= other
	^ other species = self species and: [other name sameAs: name]! !

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

MCPackage class
	instanceVariableNames: ''!

!MCPackage class methodsFor: 'as yet unclassified' stamp: 'ab 7/10/2003 01:17'!
named: aString
	^ self new name: aString! !
Object subclass: #MCPackageCache
	instanceVariableNames: 'sorter fileNames'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCPackageCache methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	sorter := MCVersionSorter new.
	fileNames := Dictionary new.! !

!MCPackageCache methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:25'!
recordVersionInfo: aVersionInfo forFileNamed: aString
	Transcript cr; show: aString.
	fileNames at: aVersionInfo put: aString.
	sorter addVersionInfo: aVersionInfo! !

!MCPackageCache methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:21'!
versionInfos
	^ sorter sortedVersionInfos ! !

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

MCPackageCache class
	instanceVariableNames: ''!

!MCPackageCache class methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:12'!
new
	^ self basicNew initialize! !
Object subclass: #MCPackageLoader
	instanceVariableNames: 'requirements unloadableDefinitions obsoletions additions removals errorDefinitions provisions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Loading'!

!MCPackageLoader methodsFor: 'patch ops' stamp: 'ab 5/24/2003 16:13'!
addDefinition: aDefinition
	additions add: aDefinition! !

!MCPackageLoader methodsFor: 'patch ops' stamp: 'avi 2/17/2004 13:14'!
modifyDefinition: old to: new
	self addDefinition: new.
	obsoletions at: new put: old.! !

!MCPackageLoader methodsFor: 'patch ops' stamp: 'ab 5/24/2003 16:14'!
removeDefinition: aDefinition
	removals add: aDefinition! !


!MCPackageLoader methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'!
installSnapshot: aSnapshot
	| patch |
	patch := aSnapshot patchRelativeToBase: MCSnapshot empty.
	patch applyTo: self.
! !

!MCPackageLoader methodsFor: 'public' stamp: 'ab 8/24/2003 01:03'!
load
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useNewChangeSetDuring: [self basicLoad]! !

!MCPackageLoader methodsFor: 'public' stamp: 'nk 8/30/2004 08:39'!
loadWithNameLike: baseName
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useNewChangeSetNamedLike: baseName during: [self basicLoad]! !

!MCPackageLoader methodsFor: 'public' stamp: 'nk 2/23/2005 07:51'!
loadWithName: baseName
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useChangeSetNamed: baseName during: [self basicLoad]! !

!MCPackageLoader methodsFor: 'public' stamp: 'avi 10/5/2003 11:09'!
unloadPackage: aPackage
	self updatePackage: aPackage withSnapshot: MCSnapshot empty! !

!MCPackageLoader methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'!
updatePackage: aPackage withSnapshot: aSnapshot
	|  patch packageSnap |
	packageSnap := aPackage snapshot.
	patch := aSnapshot patchRelativeToBase: packageSnap.
	patch applyTo: self.
	packageSnap definitions do: [:ea | self provisions addAll: ea provisions]
! !


!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
analyze
	| sorter |
	sorter := self sorterForItems: additions.
	additions := sorter orderedItems.
	requirements := sorter externalRequirements.
	unloadableDefinitions := sorter itemsWithMissingRequirements asSortedCollection.
	
	sorter := self sorterForItems: removals.
	removals := sorter orderedItems reversed.! !

!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
basicLoad
	errorDefinitions := OrderedCollection new.
	[[additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Loading...'.
	removals do: [:ea | ea unload] displayingProgress: 'Cleaning up...'.
	self shouldWarnAboutErrors ifTrue: [self warnAboutErrors].
	errorDefinitions do: [:ea | ea loadOver: (self obsoletionFor: ea)] displayingProgress: 'Reloading...'.
	additions do: [:ea | ea postloadOver: (self obsoletionFor: ea)] displayingProgress: 'Initializing...']
		on: InMidstOfFileinNotification 
		do: [:n | n resume: true]]
			ensure: [self flushChangesFile]! !

!MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:24'!
dependencyWarning
	^ String streamContents:
		[:s |
		s nextPutAll: 'This package depends on the following classes:'; cr.
		requirements do: [:ea | s space; space; nextPutAll: ea; cr].
		s nextPutAll: 'You must resolve these dependencies before you will be able to load these definitions: '; cr.
		unloadableDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] ! !

!MCPackageLoader methodsFor: 'private' stamp: 'avi 1/24/2004 17:44'!
errorDefinitionWarning
	^ String streamContents:
		[:s |
		s nextPutAll: 'The following definitions had errors while loading.  Press Proceed to try to load them again (they may work on a second pass):'; cr.
		errorDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] ! !

!MCPackageLoader methodsFor: 'private' stamp: 'cwp 11/13/2003 02:01'!
flushChangesFile
	"The changes file is second in the SourceFiles array"

	(SourceFiles at: 2) flush! !

!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	additions := OrderedCollection new.
	removals := OrderedCollection new.
	obsoletions := Dictionary new.
! !

!MCPackageLoader methodsFor: 'private' stamp: 'avi 2/17/2004 13:15'!
obsoletionFor: aDefinition
	^ obsoletions at: aDefinition ifAbsent: [nil]! !

!MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:19'!
orderDefinitionsForLoading: aCollection
	^ (self sorterForItems: aCollection) orderedItems! !

!MCPackageLoader methodsFor: 'private' stamp: 'ab 5/24/2003 16:52'!
orderedAdditions
	^ additions! !

!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
provisions
	^ provisions ifNil: [provisions := Set withAll: Smalltalk keys]! !

!MCPackageLoader methodsFor: 'private' stamp: 'avi 1/25/2004 13:32'!
shouldWarnAboutErrors
	^ errorDefinitions isEmpty not and: [false "should make this a preference"]! !

!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
sorterForItems: aCollection
	| sorter |
	sorter := MCDependencySorter items: aCollection.
	sorter addExternalProvisions: self provisions.
	^ sorter! !

!MCPackageLoader methodsFor: 'private' stamp: 'avi 2/17/2004 13:15'!
tryToLoad: aDefinition
	[aDefinition loadOver: (self obsoletionFor: aDefinition)] on: Error do: [errorDefinitions add: aDefinition].! !

!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
useChangeSetNamed: baseName during: aBlock
	"Use the named change set, or create one with the given name."
	| changeHolder oldChanges newChanges |
	changeHolder := (ChangeSet respondsTo: #newChanges:)
						ifTrue: [ChangeSet]
						ifFalse: [Smalltalk].
	oldChanges := (ChangeSet respondsTo: #current)
						ifTrue: [ChangeSet current]
						ifFalse: [Smalltalk changes].

	newChanges := (ChangeSorter changeSetNamed: baseName) ifNil: [ ChangeSet new name: baseName ].
	changeHolder newChanges: newChanges.
	[aBlock value] ensure: [changeHolder newChanges: oldChanges].
! !

!MCPackageLoader methodsFor: 'private' stamp: 'nk 8/30/2004 08:38'!
useNewChangeSetDuring: aBlock
	^self useNewChangeSetNamedLike: 'MC' during: aBlock! !

!MCPackageLoader methodsFor: 'private' stamp: 'nk 2/23/2005 07:50'!
useNewChangeSetNamedLike: baseName during: aBlock
	^self useChangeSetNamed: (ChangeSet uniqueNameLike: baseName) during: aBlock! !

!MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:22'!
warnAboutDependencies 
	self notify: self dependencyWarning! !

!MCPackageLoader methodsFor: 'private' stamp: 'avi 1/24/2004 17:42'!
warnAboutErrors
	self notify: self errorDefinitionWarning.
! !

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

MCPackageLoader class
	instanceVariableNames: ''!

!MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:30'!
installSnapshot: aSnapshot
	self new
		installSnapshot: aSnapshot;
		load! !

!MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:03'!
new
	^ self basicNew initialize! !

!MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'bf 12/5/2004 12:00'!
unloadPackage: aPackage
	self new
		unloadPackage: aPackage;
		loadWithNameLike: aPackage name, '-unload'! !

!MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 12:11'!
updatePackage: aPackage withSnapshot: aSnapshot
	self new
		updatePackage: aPackage withSnapshot: aSnapshot;
		load! !
Object subclass: #MCPackageManager
	instanceVariableNames: 'package modified'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCPackageManager methodsFor: 'accessing' stamp: 'cwp 11/13/2003 14:12'!
modified
	^ modified! !

!MCPackageManager methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
modified: aBoolean
     modified = aBoolean ifTrue: [^ self].
	modified := aBoolean.
	self changed: #modified.
	
	modified ifFalse:
		[(((Smalltalk classNamed: 'SmalltalkImage') ifNotNilDo: [:si | si current]) ifNil: [Smalltalk])
			logChange: '"', self packageName, '"'].! !

!MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 16:47'!
package
	^ package! !

!MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 13:33'!
packageInfo
	^ package packageInfo! !

!MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 12:18'!
packageName
	^ package name! !

!MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/5/2003 23:18'!
packageNameWithStar
	^ modified
		ifTrue: ['* ', self packageName]
		ifFalse: [self packageName]! !


!MCPackageManager methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	modified := false.
	self registerForNotifications.! !

!MCPackageManager methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithPackage: aPackage
	package := aPackage.
	self initialize.! !


!MCPackageManager methodsFor: 'operations' stamp: 'ab 7/19/2003 23:30'!
unregister
	self class registry removeKey: package.
	self class changed: #allManagers! !


!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
classModified: anEvent
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
classMoved: anEvent
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
classRemoved: anEvent
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
methodModified: anEvent
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
methodMoved: anEvent 
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
methodRemoved: anEvent
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
registerForNotifications
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
registerForNotificationsFrom: aNotifier
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'!
systemChange: anEvent
	"obsolete - remove this later"! !

!MCPackageManager methodsFor: 'system changes' stamp: 'avi 11/11/2003 12:06'!
update: aSymbol
	InMidstOfFileinNotification signal ifFalse: [
	[((aSymbol = #recentMethodSubmissions)
		and: [self packageInfo
				includesMethodReference: Utilities recentMethodSubmissions last])
					ifTrue: [self modified: true]]
		on: Error do: []]! !

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

MCPackageManager class
	instanceVariableNames: 'registry'!

!MCPackageManager class methodsFor: 'as yet unclassified' stamp: 'ab 3/31/2003 20:45'!
allManagers
	^ self registry values! !

!MCPackageManager class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
forPackage: aPackage
	^ self registry at: aPackage ifAbsent:
		[|mgr|
		mgr := self new initializeWithPackage: aPackage.
		self registry at: aPackage put: mgr.
		self changed: #allManagers.
		mgr]! !

!MCPackageManager class methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2005 02:09'!
initialize
	"Remove this later"
	Smalltalk at: #SystemChangeNotifier ifPresent:[:cls|
		(cls uniqueInstance) noMoreNotificationsFor: self.
	].! !

!MCPackageManager class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
registry
	^ registry ifNil: [registry := Dictionary new]! !


!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/27/2005 14:28'!
classModified: anEvent
	self managersForClass: anEvent item do:[:mgr| mgr modified: true].! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:31'!
classMoved: anEvent
	self classModified: anEvent.
	self managersForCategory: anEvent oldCategory do:[:mgr| mgr modified: true].! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:31'!
classRemoved: anEvent
	self classModified: anEvent! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'md 3/14/2006 23:11'!
managersForCategory: aSystemCategory do: aBlock
	"Got to be careful here - we might get method categories where capitalization is problematic."
	| cat foundOne index |
	foundOne := false.
	cat := aSystemCategory ifNil:[^nil]. "yes this happens; for example in eToy projects"
	"first ask PackageInfos, their package name might not match the category"
	self registry do: [:mgr | 
		(mgr packageInfo includesSystemCategory: aSystemCategory)	ifTrue: [
			aBlock value: mgr.
			foundOne := true.
		]
	].
	foundOne ifTrue: [^self].
	["Loop over categories until we found a matching one"
	self registry at: (MCPackage named: cat) ifPresent:[:mgr|
		aBlock value: mgr.
		foundOne := true.
	].
	index := cat lastIndexOf: $-.
	index > 0]whileTrue:[
		"Step up to next level package"
		cat := cat copyFrom: 1 to: index-1.
	].
	foundOne ifFalse:[
		"Create a new (but only top-level)"
		aBlock value: (MCWorkingCopy forPackage: (MCPackage named: (aSystemCategory copyUpTo: $-) capitalized)).
	].! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/27/2005 14:11'!
managersForClass: aClass category: methodCategory do: aBlock
	(methodCategory isEmptyOrNil or:[methodCategory first ~= $*]) ifTrue:[
		"Not an extension method"
		^self managersForClass: aClass do: aBlock.
	].
	self managersForCategory: methodCategory allButFirst do: aBlock.! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'bf 5/20/2005 16:50'!
managersForClass: aClass do: aBlock

	self registry do: [:mgr |
		(mgr packageInfo includesClass: aClass)
			ifTrue: [aBlock value: mgr]]! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:40'!
managersForClass: aClass selector: aSelector do: aBlock
	^self managersForClass: aClass category: (aClass organization categoryOfElement: aSelector) do: aBlock! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:40'!
methodModified: anEvent
	^self managersForClass: anEvent itemClass selector: anEvent itemSelector do:[:mgr| mgr modified: true].! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:40'!
methodMoved: anEvent
	self managersForClass: anEvent itemClass category: anEvent oldCategory do:[:mgr| mgr modified: true].
	self methodModified: anEvent.! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:12'!
methodRemoved: anEvent
	self managersForClass: anEvent itemClass category: anEvent itemProtocol do:[:mgr| mgr modified: true].
! !

!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:18'!
registerForNotifications
	Smalltalk at: #SystemChangeNotifier ifPresent:[:cls|
	(cls uniqueInstance)
		noMoreNotificationsFor: self;
		notify: self ofSystemChangesOfItem: #class change: #Added using: #classModified:;
		notify: self ofSystemChangesOfItem: #class change: #Modified using: #classModified:;
		notify: self ofSystemChangesOfItem: #class change: #Renamed using: #classModified:;
		notify: self ofSystemChangesOfItem: #class change: #Commented using: #classModified:;
		notify: self ofSystemChangesOfItem: #class change: #Recategorized using: #classMoved:;
		notify: self ofSystemChangesOfItem: #class change: #Removed using: #classRemoved:;
		notify: self ofSystemChangesOfItem: #method change: #Added using: #methodModified:;
		notify: self ofSystemChangesOfItem: #method change: #Modified using: #methodModified:;
		notify: self ofSystemChangesOfItem: #method change: #Recategorized using: #methodMoved:;
		notify: self ofSystemChangesOfItem: #method change: #Removed using: #methodRemoved:
	].! !
MCTestCase subclass: #MCPackageTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCPackageTest methodsFor: 'running' stamp: 'cwp 8/9/2003 23:43'!
tearDown
	self mockSnapshot install! !


!MCPackageTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testUnload
	| mock |
	self mockPackage unload.
	self deny: (Smalltalk hasClassNamed: #MCMockClassA).
	self deny: (MCSnapshotTest includesSelector: #mockClassExtension).

	mock := (Smalltalk at: #MCMock).
	self assert: (mock subclasses detect: [:c | c name = #MCMockClassA] ifNone: []) isNil! !

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

MCPackageTest class
	instanceVariableNames: ''!
Object subclass: #MCPatch
	instanceVariableNames: 'operations'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Patching'!

!MCPatch methodsFor: 'accessing' stamp: 'ab 5/13/2003 12:18'!
operations
	^ operations! !


!MCPatch methodsFor: 'applying' stamp: 'ab 5/24/2003 16:12'!
applyTo: anObject
	operations do: [:ea | ea applyTo: anObject].
! !


!MCPatch methodsFor: 'intializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithBase: baseSnapshot target: targetSnapshot
	| base target |	
	operations := OrderedCollection new.
	base := MCDefinitionIndex definitions: baseSnapshot definitions.
	target := MCDefinitionIndex definitions: targetSnapshot definitions.
	
	target definitions do:
		[:t |
		base
			definitionLike: t
			ifPresent: [:b | (b isSameRevisionAs: t) ifFalse: [operations add: (MCModification of: b to: t)]]
			ifAbsent: [operations add: (MCAddition of: t)]]
		displayingProgress: 'Diffing...'.
		
	base definitions do:
		[:b |
		target
			definitionLike: b
			ifPresent: [:t]
			ifAbsent: [operations add: (MCRemoval of: b)]]		! !

!MCPatch methodsFor: 'intializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithOperations: aCollection
	operations := aCollection! !


!MCPatch methodsFor: 'querying' stamp: 'cwp 6/9/2003 11:53'!
isEmpty
	^ operations isEmpty! !


!MCPatch methodsFor: 'ui' stamp: 'cwp 8/2/2003 13:34'!
browse
	^ (MCPatchBrowser forPatch: self) show! !

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

MCPatch class
	instanceVariableNames: ''!

!MCPatch class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:49'!
fromBase: baseSnapshot target: targetSnapshot
	^ self new initializeWithBase: baseSnapshot target: targetSnapshot! !

!MCPatch class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:50'!
operations: aCollection
	^ self basicNew initializeWithOperations: aCollection! !
MCCodeTool subclass: #MCPatchBrowser
	instanceVariableNames: 'selection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCPatchBrowser methodsFor: 'accessing' stamp: 'ab 7/16/2003 14:36'!
items
	^ items! !

!MCPatchBrowser methodsFor: 'accessing' stamp: 'ab 7/16/2003 14:39'!
list
	^ self items collect: [:ea | ea summary]! !

!MCPatchBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
patch: aPatch
	items := aPatch operations asSortedCollection! !


!MCPatchBrowser methodsFor: 'as yet unclassified' stamp: 'nk 11/10/2003 21:41'!
annotations
	^selection ifNil: [ super annotations ]
		ifNotNil: [ selection annotations ]! !

!MCPatchBrowser methodsFor: 'as yet unclassified' stamp: 'nk 2/23/2005 08:04'!
changeSetNameForInstall
	"Answer the name of the change set into which my selection will be installed.
	Derive this from my label.
	If I have no label, use the current change set."

	| tokens |
	label ifNil: [ ^ChangeSet current name ].
	tokens := label findTokens: ' '.
	tokens removeAllFoundIn: { 'changes'. 'between'. 'and' }.
	(tokens size = 3 and: [ tokens second = '<working' ]) ifTrue: [ ^tokens first, '-to-working' ].
	tokens size = 2 ifFalse: [ ^'InstalledPatches' ].
	^'{1}-to-{2}' format: tokens ! !

!MCPatchBrowser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
installSelection
	| loader |
	selection ifNotNil:
		[loader := MCPackageLoader new.
		selection applyTo: loader.
		loader loadWithName: self changeSetNameForInstall ]! !


!MCPatchBrowser methodsFor: 'menus' stamp: 'avi 4/17/2004 11:46'!
methodListMenu: aMenu
	selection ifNotNil:
		[aMenu addList:#(('install'	 installSelection) -)].
	super methodListMenu: aMenu.
	^ aMenu
! !


!MCPatchBrowser methodsFor: 'morphic ui' stamp: 'ab 8/22/2003 02:21'!
buttonSpecs
	^ #((Invert invert 'Show the reverse set of changes')
		 (Export export 'Export the changes as a change set'))! !

!MCPatchBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 21:31'!
defaultLabel
	^ 'Patch Browser'! !

!MCPatchBrowser methodsFor: 'morphic ui' stamp: 'nk 11/10/2003 20:55'!
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]! !

!MCPatchBrowser methodsFor: 'morphic ui' stamp: 'nk 4/18/2004 09:46'!
widgetSpecs
	Preferences annotationPanes ifFalse: [ ^#(
		((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 0 0 0))
		((textMorph: text) (0 0.4 1 1))
		) ].

	^ {
		#((listMorph:selection:menu: list selection methodListMenu: ) (0 0 1 0.4) (0 0 0 0)).
		{ #(textMorph: annotations). #(0 0.4 1 0.4). { 0. 0. 0. self defaultAnnotationPaneHeight. } }.
		{ #(textMorph: text). #(0 0.4 1 1). { 0. self defaultAnnotationPaneHeight. 0. 0. } }.
		}! !


!MCPatchBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'!
invert
	items := items collect: [:ea | ea inverse].
	self changed: #list; changed: #text; changed: #selection! !

!MCPatchBrowser methodsFor: 'selecting' stamp: 'ab 7/16/2003 14:30'!
selection
	^ selection 
		ifNil: [0]
		ifNotNil: [self items indexOf: selection]! !

!MCPatchBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'!
selection: aNumber
	selection := aNumber = 0 ifFalse: [self items at: aNumber].
	self changed: #selection; changed: #text; changed: #annotations! !


!MCPatchBrowser methodsFor: 'subclassResponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'!
selectedClass
	| definition |
	selection ifNil: [ ^nil ].
	(definition := selection definition) ifNil: [ ^nil ].
	definition isMethodDefinition ifFalse: [ ^nil ].
	^Smalltalk at: definition className ifAbsent: [ ]! !

!MCPatchBrowser methodsFor: 'subclassResponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'!
selectedClassOrMetaClass
	| definition |
	selection ifNil: [ ^nil ].
	(definition := selection definition) ifNil: [ ^nil ].
	definition isMethodDefinition ifFalse: [ ^nil ].
	^definition actualClass! !

!MCPatchBrowser methodsFor: 'subclassResponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'!
selectedMessageCategoryName
	| definition |
	selection ifNil: [ ^nil ].
	(definition := selection definition) ifNil: [ ^nil ].
	definition isMethodDefinition ifFalse: [ ^nil ].
	^definition category! !

!MCPatchBrowser methodsFor: 'subclassResponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'!
selectedMessageName
	| definition |
	selection ifNil: [ ^nil ].
	(definition := selection definition) ifNil: [ ^nil ].
	definition isMethodDefinition ifFalse: [ ^nil ].
	^definition  selector! !


!MCPatchBrowser methodsFor: 'text' stamp: 'ab 7/16/2003 14:40'!
text
	^ selection ifNil: [''] ifNotNil: [selection source]! !

!MCPatchBrowser methodsFor: 'text' stamp: 'ab 7/16/2003 14:27'!
text: aTextOrString
	self changed: #text! !

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

MCPatchBrowser class
	instanceVariableNames: ''!

!MCPatchBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/16/2003 14:35'!
forPatch: aPatch
	^ self new patch: aPatch! !
Object subclass: #MCPatchOperation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Patching'!

!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:38'!
annotations
	^self annotations: Preferences defaultAnnotationRequests! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:39'!
annotations: requests
	"Answer a string for an annotation pane, trying to fulfill the annotation requests.
	These might include anything that
		Preferences defaultAnnotationRequests 
	might return. Which includes anything in
		Preferences annotationInfo
	To edit these, use:"
	"Preferences editAnnotations"

	^String streamContents: [ :s | self printAnnotations: requests on: s ].! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'cwp 11/28/2002 06:59'!
definition
	^ self subclassResponsibility ! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:26'!
inverse
	self subclassResponsibility! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'avi 8/31/2003 17:53'!
prefixForOperation: aSymbol
	aSymbol == #insert ifTrue: [^ '+'].
	aSymbol == #remove ifTrue: [^ '-'].
	^ ' '! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:40'!
printAnnotations: requests on: aStream
	"Add a string for an annotation pane, trying to fulfill the annotation requests.
	These might include anything that
		Preferences defaultAnnotationRequests 
	might return. Which includes anything in
		Preferences annotationInfo
	To edit these, use:"
	"Preferences editAnnotations"

	self definition printAnnotations: requests on: aStream.! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'avi 8/31/2003 17:55'!
source
	^ self sourceText! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:26'!
sourceString
	^self sourceText asString! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:29'!
sourceText
	| builder |
	builder := (Preferences diffsWithPrettyPrint and: [ self targetClass notNil and: [ self isClassPatch not ] ])
				ifTrue: 
					[PrettyTextDiffBuilder 
						from: self fromSource
						to: self toSource
						inClass: self targetClass]
				ifFalse: [TextDiffBuilder from: self fromSource to: self toSource].
	^builder buildDisplayPatch.! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'ab 7/6/2003 00:06'!
summary
	^ self definition summary, self summarySuffix! !

!MCPatchOperation methodsFor: 'accessing' stamp: 'ab 7/6/2003 00:06'!
summarySuffix
	^ ''! !


!MCPatchOperation methodsFor: 'as yet unclassified' stamp: 'nk 2/25/2005 17:28'!
isClassPatch
	^false! !

!MCPatchOperation methodsFor: 'as yet unclassified' stamp: 'nk 2/23/2005 18:17'!
targetClass
	self subclassResponsibility.! !


!MCPatchOperation methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:11'!
<= other
	^ self definition <= other definition! !


!MCPatchOperation methodsFor: 'testing' stamp: 'cwp 11/27/2002 09:30'!
isAddition
	^ false! !

!MCPatchOperation methodsFor: 'testing' stamp: 'cwp 11/27/2002 09:30'!
isModification
	^ false! !

!MCPatchOperation methodsFor: 'testing' stamp: 'cwp 11/27/2002 09:30'!
isRemoval
	^ false! !

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

MCPatchOperation class
	instanceVariableNames: ''!
MCTestCase subclass: #MCPatchTest
	instanceVariableNames: 'patch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCPatchTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	|rev1 rev2|
	rev1 :=  MCSnapshotResource takeSnapshot.
	self change: #one toReturn: 2.
	rev2 :=  MCSnapshotResource takeSnapshot.
	patch := rev2 patchRelativeToBase: rev1.
	self change: #one toReturn: 1.! !

!MCPatchTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/2/2003 17:24'!
tearDown
	self restoreMocks! !

!MCPatchTest methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:31'!
testPatchContents
	self assert: patch operations size = 1.
	self assert: patch operations first isModification.
	self assert: patch operations first definition selector = #one.
! !

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

MCPatchTest class
	instanceVariableNames: ''!
Object subclass: #MCPatcher
	instanceVariableNames: 'definitions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Patching'!

!MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:46'!
addDefinition: aDefinition
	definitions add: aDefinition! !

!MCPatcher methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithSnapshot: aSnapshot
	definitions := MCDefinitionIndex definitions: aSnapshot definitions! !

!MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 14:23'!
modifyDefinition: baseDefinition to: targetDefinition
	self addDefinition: targetDefinition! !

!MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'!
patchedSnapshot
	^ MCSnapshot fromDefinitions: definitions definitions! !

!MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:46'!
removeDefinition: aDefinition
	definitions remove: aDefinition! !

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

MCPatcher class
	instanceVariableNames: ''!

!MCPatcher class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
apply: aPatch to: aSnapshot
	| loader |
	loader := self snapshot: aSnapshot.
	aPatch applyTo: loader.
	^ loader patchedSnapshot! !

!MCPatcher class methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 14:22'!
snapshot: aSnapshot
	^ self new initializeWithSnapshot: aSnapshot! !
MCVariableDefinition subclass: #MCPoolImportDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCPoolImportDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:51'!
isPoolImport
	^ true! !

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

MCPoolImportDefinition class
	instanceVariableNames: ''!

!MCPoolImportDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'!
type
	^ #pool! !
MCScriptDefinition subclass: #MCPostscriptDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:18'!
accept: aWriter
	"do nothing"! !

!MCPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:16'!
postload
	self evaluate! !

!MCPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:16'!
sortKey
	^ 'zzz' "force to the end so it gets loaded late"! !

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

MCPostscriptDefinition class
	instanceVariableNames: ''!

!MCPostscriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'!
scriptSelector
	^ #postscript! !
MCScriptDefinition subclass: #MCPreambleDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'!
load
	super load.
	self evaluate! !

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

MCPreambleDefinition class
	instanceVariableNames: ''!

!MCPreambleDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'!
scriptSelector
	^ #preamble! !
RWBinaryOrTextStream subclass: #MCPseudoFileStream
	instanceVariableNames: 'localName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MonticelloConfigurations'!
!MCPseudoFileStream commentStamp: '<historical>' prior: 0!
A pseudo file stream which can be used for updates.!


!MCPseudoFileStream methodsFor: 'accessing' stamp: 'ar 4/14/2005 19:54'!
localName
	^localName! !

!MCPseudoFileStream methodsFor: 'accessing' stamp: 'ar 4/14/2005 19:54'!
localName: aString
	localName := aString! !
Object subclass: #MCReader
	instanceVariableNames: 'stream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
stream: aStream
	stream := aStream! !


!MCReader methodsFor: 'lifecycle' stamp: 'avi 1/24/2004 17:52'!
initialize! !

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

MCReader class
	instanceVariableNames: ''!

!MCReader class methodsFor: 'instance creation' stamp: 'avi 1/21/2004 19:02'!
new
	^ self basicNew initialize! !

!MCReader class methodsFor: 'instance creation' stamp: 'avi 1/21/2004 19:02'!
on: aStream
	^ self new stream: aStream! !

!MCReader class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'!
on: aStream name: aFileName
	| class |
	class := self readerClassForFileNamed: aFileName.
	^ class
		ifNil: [self error: 'Unsupported format: ', aFileName]
		ifNotNil: [class on: aStream]! !


!MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:00'!
canReadFileNamed: fileName
	^ (fileName endsWith: self extension)! !

!MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:01'!
concreteSubclasses
	^ self allSubclasses reject: [:c | c isAbstract]! !

!MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:01'!
isAbstract
	^ (self respondsTo: #extension) not! !

!MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:03'!
readerClassForFileNamed: fileName
	^ self concreteSubclasses
		detect: [:c | c canReadFileNamed: fileName]
		ifNone: [nil]! !
MCPatchOperation subclass: #MCRemoval
	instanceVariableNames: 'definition'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Patching'!

!MCRemoval methodsFor: 'accessing' stamp: 'ab 5/24/2003 16:11'!
applyTo: anObject
	anObject removeDefinition: definition! !

!MCRemoval methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'!
baseDefinition
	^ definition! !

!MCRemoval methodsFor: 'accessing' stamp: 'cwp 11/27/2002 10:02'!
definition
	^ definition! !

!MCRemoval methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'!
fromSource
	^ definition source! !

!MCRemoval methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:38'!
sourceString
	^self fromSource asText
		addAttribute: TextEmphasis struckOut;
		addAttribute: TextColor blue;
		yourself! !

!MCRemoval methodsFor: 'accessing' stamp: 'ab 5/13/2003 12:22'!
summary
	^ definition summary, ' (removed)'! !

!MCRemoval methodsFor: 'accessing' stamp: 'ab 7/6/2003 00:05'!
summarySuffix
	^ ' (removed)'! !

!MCRemoval methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:23'!
targetClass
	^ definition actualClass! !

!MCRemoval methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'!
targetDefinition
	^ nil! !

!MCRemoval methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'!
toSource
	^ ''! !


!MCRemoval methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 02:26'!
inverse
	^ MCAddition of: definition! !

!MCRemoval methodsFor: 'as yet unclassified' stamp: 'nk 2/25/2005 17:28'!
isClassPatch
	^definition isClassDefinition! !


!MCRemoval methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
intializeWithDefinition: aDefinition
	definition := aDefinition! !


!MCRemoval methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:24'!
isRemoval
	^ true! !

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

MCRemoval class
	instanceVariableNames: ''!

!MCRemoval class methodsFor: 'as yet unclassified' stamp: 'cwp 11/27/2002 10:03'!
of: aDefinition
	^ self new intializeWithDefinition: aDefinition! !
MCScriptDefinition subclass: #MCRemovalPostscriptDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCRemovalPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'!
unload
	super unload.
	self evaluate! !

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

MCRemovalPostscriptDefinition class
	instanceVariableNames: ''!

!MCRemovalPostscriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'!
scriptSelector
	^ #postscriptOfRemoval ! !
MCScriptDefinition subclass: #MCRemovalPreambleDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCRemovalPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:14'!
sortKey
	^ 'zzz' "force to the end so it gets unloaded early"! !

!MCRemovalPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'!
unload
	super unload.
	self evaluate! !

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

MCRemovalPreambleDefinition class
	instanceVariableNames: ''!

!MCRemovalPreambleDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'!
scriptSelector
	^ #preambleOfRemoval! !
Object subclass: #MCRepository
	instanceVariableNames: 'creationTemplate storeDiffs'
	classVariableNames: 'Settings'
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2004 01:08'!
alwaysStoreDiffs
	^ storeDiffs ifNil: [false]! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:48'!
asCreationTemplate
	^ self creationTemplate! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'!
basicStoreVersion: aVersion
	self subclassResponsibility! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:12'!
closestAncestorVersionFor: anAncestry ifNone: errorBlock
	anAncestry breadthFirstAncestorsDo:
		[:ancestorInfo |
		(self versionWithInfo: ancestorInfo) ifNotNilDo: [:v | ^ v]].
	^ errorBlock value! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:46'!
creationTemplate
	^ creationTemplate! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
creationTemplate: aString
	self creationTemplate ifNotNil: [ self error: 'Creation template already set for this MCRepository instance.' ].
	
	creationTemplate := aString.! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:53'!
description
	^ self class name! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
doAlwaysStoreDiffs
	storeDiffs := true! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
doNotAlwaysStoreDiffs
	storeDiffs := false! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:36'!
hash
	^ self description hash! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 20:13'!
initialize! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:27'!
notificationForVersion: aVersion
	^ MCVersionNotification version: aVersion repository: self! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:23'!
notifyList
	^ #()! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'bf 3/10/2005 23:01'!
possiblyNewerVersionsOfAnyOf: someVersions
	^#()! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2004 01:06'!
prepareVersionForStorage: aVersion
	^ self alwaysStoreDiffs
		ifTrue: [aVersion asDiffAgainst:
				 (self closestAncestorVersionFor: aVersion info ifNone: [^ aVersion])]
		ifFalse: [aVersion]! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'mas 9/24/2003 04:21'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self description;
		nextPut: $).! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
sendNotificationsForVersion: aVersion
	| notification notifyList |
	notifyList := self notifyList.
	notifyList isEmpty ifFalse:
		[notification := self notificationForVersion: aVersion.
		notifyList do: [:ea | notification notify: ea]]! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2004 01:05'!
storeVersion: aVersion
	self basicStoreVersion: (self prepareVersionForStorage: aVersion).
	self sendNotificationsForVersion: aVersion! !

!MCRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:36'!
= other
	^ other species = self species and: [other description = self description]! !


!MCRepository methodsFor: 'interface' stamp: 'ab 8/21/2003 12:40'!
includesVersionNamed: aString
	self subclassResponsibility! !

!MCRepository methodsFor: 'interface' stamp: 'lr 9/26/2003 20:03'!
morphicOpen
	self morphicOpen: nil! !

!MCRepository methodsFor: 'interface' stamp: 'lr 9/26/2003 20:03'!
morphicOpen: aWorkingCopy
	self subclassResponsibility ! !

!MCRepository methodsFor: 'interface' stamp: 'bf 4/14/2005 17:30'!
openAndEditTemplateCopy
	^ self class fillInTheBlankConfigure: (self asCreationTemplate ifNil: [^nil])! !

!MCRepository methodsFor: 'interface' stamp: 'avi 10/9/2003 12:42'!
versionWithInfo: aVersionInfo
	^ self versionWithInfo: aVersionInfo ifAbsent: [nil]! !

!MCRepository methodsFor: 'interface' stamp: 'ab 8/16/2003 18:22'!
versionWithInfo: aVersionInfo ifAbsent: aBlock
	self subclassResponsibility ! !


!MCRepository methodsFor: 'testing' stamp: 'nk 11/2/2003 10:55'!
isValid
	^true! !

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

MCRepository class
	instanceVariableNames: ''!

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:30'!
allConcreteSubclasses
	^ self withAllSubclasses reject: [:ea | ea isAbstract]! !

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:59'!
creationTemplate
	self subclassResponsibility.! !

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:29'!
description
	^ nil! !

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 21:05'!
fillInTheBlankConfigure
	^ self fillInTheBlankConfigure: self creationTemplate
			! !

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
fillInTheBlankConfigure: aTemplateString
	| chunk repo |
	
	aTemplateString ifNil: [ ^ false ].
	chunk := FillInTheBlankMorph 
			request: self fillInTheBlankRequest
			initialAnswer: aTemplateString
			centerAt: Sensor cursorPoint
			inWorld: World
			onCancelReturn: nil
			acceptOnCR: false
			answerExtent: 400@120.
			
	chunk 
		ifNotNil: [ 
			repo := self readFrom: chunk readStream.
			repo creationTemplate: chunk. 
	].

	^ repo! !

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:58'!
fillInTheBlankRequest
	self subclassResponsibility.! !

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:59'!
isAbstract
	^ self description isNil! !

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 21:01'!
morphicConfigure
	^ self new! !

!MCRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:03'!
new
	^ self basicNew initialize! !


!MCRepository class methodsFor: 'class initialization' stamp: 'bf 4/15/2005 10:19'!
initialize
	"self initialize"

	ExternalSettings registerClient: self.
! !


!MCRepository class methodsFor: 'external settings' stamp: 'stephaneducasse 2/4/2006 20:47'!
fetchExternalSettingsIn: aDirectory
	"Scan for settings file"
	"MCRepository fetchExternalSettingsIn: ExternalSettings preferenceDirectory"

	| stream |
	(aDirectory fileExists: self settingsFileName)
		ifFalse: [^self].
	stream := aDirectory readOnlyFileNamed: self settingsFileName.
	stream
		ifNotNil: [
			[Settings := ExternalSettings parseServerEntryArgsFrom: stream]
				ensure: [stream close]].
! !

!MCRepository class methodsFor: 'external settings' stamp: 'bf 12/17/2004 20:30'!
releaseExternalSettings
	Settings := nil.
! !

!MCRepository class methodsFor: 'external settings' stamp: 'bf 12/17/2004 20:36'!
settingsFileName
	^ 'mcSettings'! !
Object subclass: #MCRepositoryGroup
	instanceVariableNames: 'repositories'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!
!MCRepositoryGroup commentStamp: '<historical>' prior: 0!
A singleton class, holds the list of repositories. Can look for a requested VersionInfo among its repositories.!


!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'avi 1/27/2004 00:29'!
addRepository: aRepository
	((repositories includes: aRepository) or: [aRepository == MCCacheRepository default])
		ifFalse: [repositories add: aRepository.
				self class default addRepository: aRepository].
	self changed: #repositories! !

!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'abc 11/6/2004 20:32'!
includesVersionNamed: aString
	self repositoriesDo: [:ea | (ea includesVersionNamed: aString) ifTrue: [^ true]].
	^ false	! !

!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'avi 11/7/2003 00:20'!
includes: aRepository
	^ self repositories includes: aRepository! !

!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	repositories := OrderedCollection new! !

!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'ab 7/22/2003 00:11'!
removeRepository: aRepository
	repositories remove: aRepository ifAbsent: [].
	self changed: #repositories! !

!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'nk 11/2/2003 10:57'!
repositories
	^ ((Array with: MCCacheRepository default), repositories) select: [ :ea | ea isValid ]! !

!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'avi 11/7/2003 00:51'!
repositoriesDo: aBlock
	self repositories do: [:ea | [aBlock value: ea] on: Error do: []]! !

!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'dvf 8/10/2004 23:02'!
versionWithInfo: aVersionInfo
	^self versionWithInfo: aVersionInfo ifNone: [ self error: 'Could not find version ', aVersionInfo name printString,'. Maybe you need to add a repository?' ]! !

!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'nk 1/23/2004 18:15'!
versionWithInfo: aVersionInfo ifNone: aBlock
	self repositoriesDo: [:ea | (ea versionWithInfo: aVersionInfo) ifNotNilDo: [:v | ^ v]].
	^aBlock value! !

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

MCRepositoryGroup class
	instanceVariableNames: 'default'!

!MCRepositoryGroup class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
default
	^ default ifNil: [default := self new]! !

!MCRepositoryGroup class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:03'!
new
	^ self basicNew initialize! !
MCVersionInspector subclass: #MCRepositoryInspector
	instanceVariableNames: 'repository packages versions loaded selectedPackage selectedVersion'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:20'!
hasVersion
	^ selectedVersion notNil! !

!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:11'!
load
	self hasVersion ifTrue:
		[super load.
		self version workingCopy repositoryGroup addRepository: repository].! !

!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
refresh
	packages := repository packages.
	self changed: #packageList.
	self packageSelection: self packageSelection.
! !

!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
setRepository: aRepository workingCopy: aWorkingCopy
	repository := aRepository.
	aWorkingCopy isNil ifFalse: [ selectedPackage := aWorkingCopy package].
	self refresh! !

!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:20'!
summary
	^ selectedVersion
		ifNotNil: [selectedVersion summary]
		ifNil: ['']! !

!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
version
	^ version ifNil: [version := repository versionWithInfo: selectedVersion]! !


!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'!
buttonSpecs
	^#(('Refresh' refresh 'refresh the version-list')) , super buttonSpecs! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'!
defaultExtent
	^450@300! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'!
defaultLabel
	^'Repository: ' , repository description! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:09'!
packageList
	^ packages collect: [:ea | ea name]! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'!
packageListMenu: aMenu
	^aMenu! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:07'!
packageSelection
	^ packages indexOf: selectedPackage! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
packageSelection: aNumber
	selectedPackage := aNumber isZero ifFalse: [ packages at: aNumber ].
	versions := repository versionsAvailableForPackage: selectedPackage.
	self changed: #packageSelection; changed: #versionList! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
sortedVersions
	| sorter |
	sorter := MCVersionSorter new.
	sorter addAllVersionInfos: versions.
	^ sorter sortedVersionInfos select: [:ea | versions includes: ea]! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/29/2004 11:32'!
versionList
	^ self sortedVersions collect: [:ea | ea name]! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:57'!
versionListMenu: aMenu
	^aMenu! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:07'!
versionSelection
	^ versions indexOf: selectedVersion! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionSelection: aNumber
	aNumber isZero 
		ifTrue: [ selectedVersion := nil ]
		ifFalse: [ 
			selectedVersion := versions at: aNumber].
	self changed: #versionSelection; changed: #summary! !

!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'!
widgetSpecs
	^#(	((buttonRow) (0 0 1 0) (0 0 0 30))
		((listMorph: package) (0 0 0.5 0.6) (0 30 0 0))
		((listMorph: version) (0.5 0 1 0.6) (0 30 0 0))
		((textMorph: summary) (0 0.6 1 1) (0 0 0 0)) )! !

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

MCRepositoryInspector class
	instanceVariableNames: ''!

!MCRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 18:51'!
repository: aFileBasedRepository workingCopy: aWorkingCopy
	^self new
		setRepository: aFileBasedRepository workingCopy: aWorkingCopy;
		yourself! !
MCTestCase subclass: #MCRepositoryTest
	instanceVariableNames: 'repository ancestors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCRepositoryTest methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:32'!
snapshotAt: aVersionInfo
	^ (repository versionWithInfo: aVersionInfo) snapshot! !


!MCRepositoryTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
addVersionWithSnapshot: aSnapshot name: aString
	| version |
	version := self versionWithSnapshot: aSnapshot name: aString.
	self addVersion: version.
	^ version info! !

!MCRepositoryTest methodsFor: 'actions' stamp: 'ab 8/16/2003 17:46'!
addVersion: aVersion
	self subclassResponsibility ! !

!MCRepositoryTest methodsFor: 'actions' stamp: 'ab 7/19/2003 16:20'!
saveSnapshot1
	^ self saveSnapshot: self snapshot1 named: 'rev1'! !

!MCRepositoryTest methodsFor: 'actions' stamp: 'ab 7/19/2003 16:20'!
saveSnapshot2
	^ self saveSnapshot: self snapshot2 named: 'rev2'! !

!MCRepositoryTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
saveSnapshot: aSnapshot named: aString
	| version |
	version := self versionWithSnapshot: aSnapshot name: aString.
	repository storeVersion: version.
	^ version info
	! !


!MCRepositoryTest methodsFor: 'asserting' stamp: 'ab 7/19/2003 23:59'!
assertMissing: aVersionInfo
	self assert: (repository versionWithInfo: aVersionInfo) isNil! !

!MCRepositoryTest methodsFor: 'asserting' stamp: 'ab 8/16/2003 18:07'!
assertVersionInfos: aCollection
	self assert: repository allVersionInfos asSet = aCollection asSet! !


!MCRepositoryTest methodsFor: 'building' stamp: 'ab 7/10/2003 01:03'!
snapshot1
	^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('y'))))! !

!MCRepositoryTest methodsFor: 'building' stamp: 'ab 7/10/2003 01:03'!
snapshot2
	^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('x'))))! !

!MCRepositoryTest methodsFor: 'building' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionWithSnapshot: aSnapshot name: aString
	| info |
	info := self mockVersionInfo: aString. 
	^ MCVersion 
		package: (MCPackage new name: aString)
		info: info
		snapshot: aSnapshot! !


!MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testAddAndLoad
	| node |
	node := self addVersionWithSnapshot: self snapshot1 name: 'rev1'.
	self assert: (self snapshotAt: node) = self snapshot1.
! !

!MCRepositoryTest methodsFor: 'tests' stamp: 'avi 2/17/2004 03:24'!
testIncludesName
	self deny: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev1').
	self saveSnapshot1.
	self assert: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev1').
	self deny: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev2').
	self saveSnapshot2.
	self assert:  (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev2').! !

!MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testLoadMissingNode
	| node |
	node := MCVersionInfo new.
	self assertMissing: node! !

!MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testStoreAndLoad
	| node node2 |
	node := self saveSnapshot1.
	node2 := self saveSnapshot2.
	self assert: (self snapshotAt: node) = self snapshot1.
	self assert: (self snapshotAt: node2) = self snapshot2.! !

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

MCRepositoryTest class
	instanceVariableNames: ''!

!MCRepositoryTest class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 12:45'!
isAbstract
	^ self = MCRepositoryTest! !
MCFileBasedRepository subclass: #MCSMCacheRepository
	instanceVariableNames: 'smCache'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!
!MCSMCacheRepository commentStamp: 'nk 1/23/2004 09:57' prior: 0!
I am a Monticello repository that reflects the caching of SqueakMap v2.

I refer write attempts to the default MCCacheRepository.!


!MCSMCacheRepository methodsFor: 'accessing' stamp: 'nk 1/23/2004 09:46'!
allFileNames
	^self allFullFileNames collect: [ :ea | self directory localNameFor: ea ]! !

!MCSMCacheRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
allFullFileNames
	| cachedPackages |
	cachedPackages := smCache map installedPackages select: [ :ea | ea isCached ].
	^Array streamContents: [ :s |
		cachedPackages do: [ :ea | | d |
			d := ea cacheDirectory.
			(d fileNamesMatching: '*.mcz') do: [ :fn | s nextPut: (d fullNameFor: fn) ]]]! !

!MCSMCacheRepository methodsFor: 'accessing' stamp: 'nk 1/23/2004 09:40'!
description
	^ smCache directory pathName! !

!MCSMCacheRepository methodsFor: 'accessing' stamp: 'nk 1/23/2004 09:40'!
directory
	^ smCache directory! !

!MCSMCacheRepository methodsFor: 'accessing' stamp: 'nk 1/23/2004 09:40'!
directory: aDirectory
! !

!MCSMCacheRepository methodsFor: 'accessing' stamp: 'nk 1/23/2004 09:55'!
fullNameFor: aFileName
	^self allFullFileNames detect: [ :ffn | (self directory localNameFor: ffn) = aFileName ] ifNone: []! !

!MCSMCacheRepository methodsFor: 'accessing' stamp: 'nk 1/23/2004 09:37'!
smCache
	^smCache! !

!MCSMCacheRepository methodsFor: 'accessing' stamp: 'nk 1/23/2004 09:45'!
smCache: aSMFileCache
	| |
	smCache := aSMFileCache.
	self directory: aSMFileCache directory.
! !


!MCSMCacheRepository methodsFor: 'comparing' stamp: 'nk 1/23/2004 09:55'!
hash
	^ smCache hash! !


!MCSMCacheRepository methodsFor: 'file streaming' stamp: 'stephaneducasse 2/4/2006 20:47'!
readStreamForFileNamed: aString do: aBlock
	| file fileName |
	fileName := self fullNameFor: aString.
	fileName ifNil: [
		"assume that this will come from the cache."
		^MCCacheRepository default readStreamForFileNamed: aString do: aBlock ].
	file := FileStream readOnlyFileNamed: fileName.
	^[ aBlock value: file ] ensure: [ file close ].
! !

!MCSMCacheRepository methodsFor: 'file streaming' stamp: 'nk 1/23/2004 09:57'!
writeStreamForFileNamed: aString replace: aBoolean do: aBlock
	"Can't write into the SM cache, so..."
	^MCCacheRepository default writeStreamForFileNamed: aString replace: aBoolean do: aBlock! !


!MCSMCacheRepository methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	super initialize.
	smCache := SMSqueakMap default cache.! !


!MCSMCacheRepository methodsFor: 'testing' stamp: 'nk 1/23/2004 09:47'!
isValid
	^smCache notNil and: [ self directory exists ]! !

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

MCSMCacheRepository class
	instanceVariableNames: ''!

!MCSMCacheRepository class methodsFor: 'instance creation' stamp: 'nk 1/23/2004 10:04'!
description
	^ 'SqueakMap Cache'! !

!MCSMCacheRepository class methodsFor: 'instance creation' stamp: 'nk 1/23/2004 10:05'!
morphicConfigure
	^self new! !
MCWriteOnlyRepository subclass: #MCSMReleaseRepository
	instanceVariableNames: 'packageName user password'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
basicStoreVersion: aVersion
	| url |
	url := self uploadVersion: aVersion.
	self releaseVersion: aVersion url: url! !

!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:11'!
checkResult: resultString
(#( 'HTTP/1.1 201 ' 'HTTP/1.1 200 ' 'HTTP/1.0 201 ' 'HTTP/1.0 200 ')
		anySatisfy: [:code | resultString beginsWith: code ])
			ifFalse: [self error: resultString].
! !

!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:15'!
description
	^ 'sm://', packageName! !

!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithPackage: packageString user: userString password: passString
	packageName := packageString.
	user := userString.
	password := passString.
! !

!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
releaseVersion: aVersion url: urlString
	| result |
	result := HTTPSocket
		httpPost: self squeakMapUrl, '/packagebyname/', packageName, '/newrelease'
		args: {'version' -> {(aVersion info name copyAfter: $.) extractNumber asString}.
			   'note' -> {aVersion info message}.
			   'downloadURL' -> {urlString}}
		user: user
		passwd: password.
	result contents size > 4 ifTrue: [self error: result contents]
! !

!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:58'!
squeakMapUrl 
	^ 'http://localhost:9070/sm'
! !

!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
stringForVersion: aVersion
	| stream |
	stream := RWBinaryOrTextStream on: String new.
	aVersion fileOutOn: stream.
	^ stream contents! !

!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
uploadVersion: aVersion
	| result stream |
	result := HTTPSocket
		httpPut: (self stringForVersion: aVersion)
		to: self squeakMapUrl, '/upload/', aVersion fileName
		user: user
		passwd: password.
	self checkResult: result.
	stream := result readStream.
	stream upToAll: 'http://'.
	^ 'http://', stream upToEnd! !

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

MCSMReleaseRepository class
	instanceVariableNames: ''!

!MCSMReleaseRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:15'!
creationTemplate
	^
'MCSMReleaseRepository
	package: ''mypackage''
	user: ''squeak''
	password: ''squeak'''
	! !

!MCSMReleaseRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 13:42'!
description
	^ 'SqueakMap Release'! !

!MCSMReleaseRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 21:03'!
fillInTheBlankRequest
	^  'SqueakMap Release Repository:'
		! !

!MCSMReleaseRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 21:03'!
morphicConfigure
	^ self fillInTheBlankConfigure! !

!MCSMReleaseRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:14'!
package: packageString user: userString password: passString
	^ self basicNew initializeWithPackage: packageString user: userString password: passString! !
MCTool subclass: #MCSaveVersionDialog
	instanceVariableNames: 'name message'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'ab 8/24/2003 20:28'!
accept
	self answer:
		(Array
			with: (self findTextMorph: #versionName) text asString
			with: (self findTextMorph: #logMessage) text asString)
	! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'ab 8/24/2003 20:10'!
buttonSpecs
	^ #((Accept accept 'accept version name and log message')
		(Cancel cancel 'cancel saving version')
		) ! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'ab 8/24/2003 20:41'!
cancel
	self answer: nil! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'ab 8/24/2003 20:07'!
defaultExtent 
	^ 400@300! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'ab 8/24/2003 20:43'!
defaultLabel
	^ 'Edit Version Name and Message:'! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'ab 8/24/2003 20:41'!
logMessage
	^ message ifNil: ['empty log message']! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
logMessage: aString
	message := aString.
	self changed: #logMessage! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'ab 8/24/2003 20:37'!
versionName
	^ name! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionName: aString
	name := aString.
	self changed: #versionName! !

!MCSaveVersionDialog methodsFor: 'as yet unclassified' stamp: 'jrp 7/2/2005 10:33'!
widgetSpecs
	^ #(	
		((textMorph: versionName) (0 0 1 0) (0 0 0 30))
		((textMorph: logMessage) (0 0 1 1) (0 30 0 -30))
		((buttonRow) (0 1 1 1) (0 -40 0 0))
		)! !

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

MCSaveVersionDialog class
	instanceVariableNames: ''!
Object subclass: #MCScanner
	instanceVariableNames: 'stream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Chunk Format'!

!MCScanner methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
next
	| c |
	stream skipSeparators.
	c := stream peek.
	c = $# ifTrue: [c := stream next; peek].
	c = $' ifTrue: [^ self nextString].
	c = $( ifTrue: [^ self nextArray].
	c isAlphaNumeric ifTrue: [^ self nextSymbol].
	self error: 'Unknown token type'.	! !

!MCScanner methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:27'!
nextArray
	stream next. "("
	^ Array streamContents:
		[:s |
		[stream skipSeparators.
		(stream peek = $)) or: [stream atEnd]] whileFalse: [s nextPut: self next].
		stream next = $) ifFalse: [self error: 'Unclosed array']]! !

!MCScanner methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:09'!
nextString
	^ stream nextDelimited: $'! !

!MCScanner methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:16'!
nextSymbol
	^ (String streamContents:
		[:s |
		[stream peek isAlphaNumeric] whileTrue: [s nextPut: stream next]]) asSymbol
			! !

!MCScanner methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
stream: aStream
	stream := aStream! !

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

MCScanner class
	instanceVariableNames: ''!

!MCScanner class methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:32'!
scanTokens: aString
	"compatibility"
	^ Array with: (self scan: aString readStream)! !

!MCScanner class methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:14'!
scan: aStream
	^ (self new stream: aStream) next! !
MCTestCase subclass: #MCScannerTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCScannerTest methodsFor: 'asserting' stamp: 'avi 1/22/2004 20:23'!
assertScans: anArray
	self assert: (MCScanner scan: anArray printString readStream) = anArray! !


!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:19'!
test1
	self assertScans: #(a '23' (x))! !

!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:22'!
test2
	self assertScans: 'it''s alive'! !

!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:23'!
test3
	self assert: (MCScanner scan: '(a #b c)' readStream) = #(a #b c)! !

!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:23'!
test4
	self assertScans: #(a '23' (x () ')''q' y12)).! !

!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:26'!
test5
	self assertScans: #((a) b)! !

!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:28'!
test6
	self should: [MCScanner scan: '(a b' readStream] raise: Error! !

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

MCScannerTest class
	instanceVariableNames: ''!
MCDefinition subclass: #MCScriptDefinition
	instanceVariableNames: 'script packageName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:19'!
accept: aVisitor
	"do nothing for now - this means it won't appear in the .st file"! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:12'!
description
	^ Array with: packageName with: self scriptSelector! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:03'!
evaluate
	Compiler evaluate: script! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithScript: aString packageName: packageString
	script := aString.
	packageName := packageString! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:11'!
installScript
	self installScript: script! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'bf 10/25/2005 18:55'!
installScript: aString
	| sel pi |
	sel := (self scriptSelector, ':') asSymbol.
	pi := self packageInfo.
	(pi respondsTo: sel)
		ifTrue: [pi perform: sel with: aString]! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:12'!
load
	self installScript! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:22'!
packageInfo
	^ PackageInfo named: packageName! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 16:54'!
script
	^ script! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:10'!
scriptSelector
	^ self class scriptSelector! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'bf 10/25/2005 19:05'!
sortKey
	^ '!!', self scriptSelector "force to the front so it gets loaded first"! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'!
source
	^ script! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:12'!
summary
	^ packageName, ' ', self scriptSelector! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:12'!
unload
	self installScript: nil! !

!MCScriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 16:55'!
= aDefinition
	^ (super = aDefinition)
		and: [script = aDefinition script]! !

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

MCScriptDefinition class
	instanceVariableNames: ''!

!MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'bf 4/4/2005 12:20'!
from: aPackageInfo
	^ self script: (aPackageInfo perform: self scriptSelector) contents asString packageName: aPackageInfo name! !

!MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:00'!
scriptSelector
	self subclassResponsibility! !

!MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 16:59'!
script: aString packageName: packageString
	^ self instanceLike: (self new initializeWithScript: aString packageName: packageString)! !
MCTestCase subclass: #MCSerializationTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertClass: readerClass providesServices: labels
	| services suffix |
	suffix := readerClass extension.
	self assert: (FileList isReaderNamedRegistered: readerClass name).
	services := readerClass fileReaderServicesForFile: 'foo' suffix: suffix.
	self assert: ((services collect: [:service | service buttonLabel]) includesAllOf: labels)! !

!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertDependenciesMatchWith: writerClass
	| stream readerClass expected actual |
	readerClass := writerClass readerClass.
	expected := self mockVersionWithDependencies.
	stream := RWBinaryOrTextStream on: String new.
	writerClass fileOut: expected on: stream.
	actual := (readerClass on: stream reset) dependencies.
	self assert: actual = expected dependencies.! !

!MCSerializationTest methodsFor: 'asserting' stamp: 'cwp 8/1/2003 14:57'!
assertExtensionProvidedBy: aClass
	self shouldnt: [aClass readerClass extension] raise: Exception.! !

!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertSnapshotsMatchWith: writerClass
	| readerClass expected stream actual |
	readerClass := writerClass readerClass.
	expected := self mockSnapshot.
	stream := RWBinaryOrTextStream on: String new.
	(writerClass on: stream) writeSnapshot: expected.
	actual := readerClass snapshotFromStream: stream reset.
	self assertSnapshot: actual matches: expected.! !

!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertVersionInfosMatchWith: writerClass
	| stream readerClass expected actual |
	readerClass := writerClass readerClass.
	expected := self mockVersion.
	stream := RWBinaryOrTextStream on: String new.
	writerClass fileOut: expected on: stream.
	actual := readerClass versionInfoFromStream: stream reset.
	self assert: actual = expected info.! !

!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertVersionsMatchWith: writerClass
	| stream readerClass expected actual |
	readerClass := writerClass readerClass.
	expected := self mockVersion.
	stream := RWBinaryOrTextStream on: String new.
	writerClass fileOut: expected on: stream.
	actual := readerClass versionFromStream: stream reset.
	self assertVersion: actual matches: expected.! !


!MCSerializationTest methodsFor: 'mocks' stamp: 'stephaneducasse 2/4/2006 20:47'!
mockDiffyVersion
	| repos workingCopy base next |
	repos := MCDictionaryRepository new.
	workingCopy := MCWorkingCopy forPackage: self mockPackage.
	workingCopy repositoryGroup addRepository: repos.
	MCRepositoryGroup default removeRepository: repos.
	base := self mockVersion.
	repos storeVersion: base.
	self change: #a toReturn: 'a2'.
	next := self mockVersionWithAncestor: base.
	^ next asDiffAgainst: base	! !


!MCSerializationTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testMcdSerialization
	| stream expected actual |
	expected := self mockDiffyVersion.
	stream := RWBinaryOrTextStream on: String new.
	MCMcdWriter fileOut: expected on: stream.
	actual := MCMcdReader versionFromStream: stream reset.
	self assertVersion: actual matches: expected.! !

!MCSerializationTest methodsFor: 'testing' stamp: 'avi 1/19/2004 15:14'!
testMczSerialization
	self assertVersionsMatchWith: MCMczWriter.
	self assertExtensionProvidedBy: MCMczWriter.
	self assertVersionInfosMatchWith: MCMczWriter.
	self assertDependenciesMatchWith: MCMczWriter.! !

!MCSerializationTest methodsFor: 'testing' stamp: 'cwp 8/3/2003 18:43'!
testStSerialization
	self assertSnapshotsMatchWith: MCStWriter.! !

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

MCSerializationTest class
	instanceVariableNames: ''!
MCWriteOnlyRepository subclass: #MCSmtpRepository
	instanceVariableNames: 'email'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:21'!
basicStoreVersion: aVersion
	MailSender sendMessage: (self messageForVersion: aVersion)! !

!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 13:11'!
bodyForVersion: aVersion
	^ String streamContents:
		[ :s |
		s nextPutAll: 'from version info:'; cr; cr.
		s nextPutAll:  aVersion info summary]! !

!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:56'!
description
	^ 'mailto://', email! !

!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
emailAddress: aString
	email := aString	! !

!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
messageForVersion: aVersion
	| message data |
	message := MailMessage empty.
	message setField: 'from' toString: MailSender userName.
	message setField: 'to' toString: email.
	message setField: 'subject' toString: (self subjectForVersion: aVersion). 

	message body:
		(MIMEDocument
			contentType: 'text/plain'
			content: (self bodyForVersion: aVersion)).

	"Prepare the gzipped data"
	data := RWBinaryOrTextStream on: String new.
	aVersion fileOutOn: data.
	message addAttachmentFrom: data reset withName: aVersion fileName.
	^ message! !

!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 13:14'!
subjectForVersion: aVersion
	^ '[Package] ', aVersion info name! !

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

MCSmtpRepository class
	instanceVariableNames: ''!

!MCSmtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:56'!
description
	^ 'SMTP'! !

!MCSmtpRepository class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
morphicConfigure
	| address |
	address := FillInTheBlankMorph request: 'Email address:'.
	^ address isEmpty ifFalse: [self new emailAddress: address]! !
Object subclass: #MCSnapshot
	instanceVariableNames: 'definitions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Base'!

!MCSnapshot methodsFor: 'accessing' stamp: 'ab 12/4/2002 18:09'!
definitions
	^ definitions! !

!MCSnapshot methodsFor: 'accessing' stamp: 'ab 7/10/2003 01:05'!
hash
	^ definitions asArray hash! !

!MCSnapshot methodsFor: 'accessing' stamp: 'ab 7/10/2003 01:05'!
= other
	^ definitions asArray = other definitions asArray! !


!MCSnapshot methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithDefinitions: aCollection
	definitions := aCollection.! !


!MCSnapshot methodsFor: 'loading' stamp: 'ab 7/6/2003 23:31'!
install
	MCPackageLoader installSnapshot: self! !

!MCSnapshot methodsFor: 'loading' stamp: 'ab 7/7/2003 12:11'!
updatePackage: aPackage
	MCPackageLoader updatePackage: aPackage withSnapshot: self! !


!MCSnapshot methodsFor: 'patching' stamp: 'ab 7/7/2003 00:37'!
patchRelativeToBase: aSnapshot
	^ MCPatch fromBase: aSnapshot target: self! !

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

MCSnapshot class
	instanceVariableNames: ''!

!MCSnapshot class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'!
empty
	^ self fromDefinitions: #()! !

!MCSnapshot class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'!
fromDefinitions: aCollection
	^ self new initializeWithDefinitions: aCollection! !
MCCodeTool subclass: #MCSnapshotBrowser
	instanceVariableNames: 'categorySelection classSelection protocolSelection methodSelection switch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:47'!
allClassNames
	^ (items 
		select: [:ea | ea isOrganizationDefinition not] 
		thenCollect: [:ea | ea className]) asSet.
! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'cwp 7/10/2003 20:23'!
extensionClassNames
	^ (self allClassNames difference: self packageClassNames) asSortedCollection! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/5/2003 23:41'!
extensionsCategory
	^ '*Extensions'! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'!
methodsForSelectedClass
	^ items select: [:ea | (ea className = classSelection) 
									and: [ea isMethodDefinition]
									and: [ea classIsMeta = self switchIsClass]].! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
methodsForSelectedClassCategory
	| visibleClasses |
	visibleClasses := self visibleClasses.
	^ items select: [:ea | (visibleClasses includes: ea className) 
									and: [ea isMethodDefinition]
									and: [ea classIsMeta = self switchIsClass]].! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
methodsForSelectedProtocol
	| methods |
	protocolSelection ifNil: [^ Array new].
	methods := self methodsForSelectedClass asOrderedCollection.
	(protocolSelection = '-- all --') 
		ifFalse: [methods removeAllSuchThat: [:ea | ea category ~= protocolSelection]].
	^ methods 
	
								! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'!
packageClasses
	^ items select: [:ea | ea isClassDefinition]! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'!
packageClassNames
	^ self packageClasses collect: [:ea | ea className]! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 10/11/2003 16:53'!
selectedClass
	classSelection ifNil: [ ^nil ].
	^Smalltalk at: classSelection ifAbsent: [ nil ].
! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
selectedClassOrMetaClass
	| class |
	classSelection ifNil: [ ^nil ].
	class := Smalltalk at: classSelection ifAbsent: [ ^nil ].
	^self switchIsClass ifTrue: [ class class ]
		ifFalse: [ class ].! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:29'!
selectedMessageCategoryName
	^protocolSelection! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 10/11/2003 16:45'!
selectedMessageName
	^methodSelection ifNotNil: [^ methodSelection selector ].
! !

!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
snapshot: aSnapshot
	items := aSnapshot definitions asSortedCollection.
	self categorySelection: 0.! !


!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 18:33'!
categoryList
	^ self visibleCategories! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 20:20'!
classList
	^ self visibleClasses! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/13/2003 02:11'!
methodList
	^ self visibleMethods collect: [:ea | ea selector]! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 19:07'!
protocolList
	^ self visibleProtocols! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: 'ab 7/18/2003 15:48'!
visibleCategories
	^ (self packageClasses collect: [:ea | ea category]) 
			asSet asSortedCollection add: self extensionsCategory; yourself.! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: 'ab 7/18/2003 15:48'!
visibleClasses
	^ categorySelection = self extensionsCategory
		ifTrue: [self extensionClassNames]
		ifFalse: [self packageClasses
					select: [:ea | ea category = categorySelection]
					thenCollect: [:ea | ea className]].! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 19:46'!
visibleMethods
	^ classSelection 
		ifNil: [#()]
		ifNotNil: [self methodsForSelectedProtocol]! !

!MCSnapshotBrowser methodsFor: 'listing' stamp: 'stephaneducasse 2/4/2006 20:47'!
visibleProtocols
	| methods protocols |
	self switchIsComment ifTrue: [^ Array new].
	methods := self methodsForSelectedClass.
	protocols := (methods collect: [:ea | ea category]) asSet asSortedCollection.
	(protocols size > 1) ifTrue: [protocols add: '-- all --'].
	^ protocols ! !


!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:52'!
categoryListMenu: aMenu 
	categorySelection
		ifNotNil: [aMenu
				add: (categorySelection = '*Extensions'
						ifTrue: ['load all extension methods' translated]
						ifFalse: ['load class category {1}' translated format: {categorySelection}])
				action: #loadCategorySelection].
	^ aMenu! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 6/12/2004 14:01'!
classListMenu: aMenu 
	classSelection ifNil: [ ^aMenu ].

	super classListMenu: aMenu.

	aMenu
		addLine;
				add: ('load class {1}' translated format: {classSelection})
				action: #loadClassSelection.
	^ aMenu! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: 'cwp 7/10/2003 18:03'!
inspectSelection
	^ self methodSelection inspect! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:53'!
loadCategorySelection
	"Load the entire selected category"
	categorySelection ifNil: [ ^self ].
	self methodsForSelectedClassCategory do: [ :m | m load ].! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/30/2004 15:06'!
loadClassSelection
	classSelection ifNil: [ ^self ].
	(self packageClasses detect: [ :ea | ea className = classSelection ] ifNone: [ ^self ]) load.
	self methodsForSelectedClass do: [ :m | m load ].! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:45'!
loadMethodSelection
	methodSelection ifNil: [ ^self ].
	methodSelection load.! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:46'!
loadProtocolSelection
	protocolSelection ifNil: [ ^self ].
	self methodsForSelectedProtocol do: [ :m | m load ].! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:41'!
methodListMenu: aMenu 
	super methodListMenu: aMenu.
	self selectedMessageName
		ifNotNilDo: [:msgName | aMenu addLine; add: 'load method' translated action: #loadMethodSelection].
	^ aMenu! !

!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:43'!
protocolListMenu: aMenu 
	protocolSelection
		ifNotNil: [aMenu
				add: ('load protocol ''{1}''' translated format: {protocolSelection})
				action: #loadProtocolSelection ].
	^ aMenu! !


!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:33'!
buttonSpecs
	^ #(('instance' switchBeInstance 'show instance' buttonEnabled switchIsInstance)
		('?' switchBeComment 'show comment' buttonEnabled switchIsComment)
		('class' switchBeClass 'show class' buttonEnabled switchIsClass))! !

!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:29'!
defaultExtent
	^ 650@400.! !

!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 21:31'!
defaultLabel
	^ 'Snapshot Browser'! !

!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:13'!
widgetSpecs

	Preferences annotationPanes ifFalse: [ ^#(
		((listMorph: category) (0 0 0.25 0.4))
		((listMorph: class) (0.25 0 0.50 0.4) (0 0 0 -30))
		((listMorph: protocol) (0.50 0 0.75 0.4))
		((listMorph:selection:menu:keystroke:  methodList methodSelection methodListMenu: methodListKey:from:) (0.75 0 1 0.4))
		((buttonRow) (0.25 0.4 0.5 0.4) (0 -30 0 0))
		((textMorph: text) (0 0.4 1 1))
		) ].

	^#(
		((listMorph: category) (0 0 0.25 0.4))
		((listMorph: class) (0.25 0 0.50 0.4) (0 0 0 -30))
		((listMorph: protocol) (0.50 0 0.75 0.4))
		((listMorph:selection:menu:keystroke:  methodList methodSelection methodListMenu: methodListKey:from:) (0.75 0 1 0.4))

		((buttonRow) (0.25 0.4 0.5 0.4) (0 -30 0 0))

		((textMorph: annotations) (0 0.4 1 0.4) (0 0 0 30))
		((textMorph: text) (0 0.4 1 1) (0 30 0 0))
		)! !


!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 18:33'!
categorySelection
	^ categorySelection ifNil: [0] ifNotNil: [self visibleCategories indexOf: categorySelection]! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'!
categorySelection: aNumber
	categorySelection := aNumber = 0 ifFalse: [self visibleCategories at: aNumber].
	self classSelection: 0.
	self changed: #categorySelection;
		changed: #annotations;
		changed: #classList.
! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 18:28'!
classSelection
	^ classSelection ifNil: [0] ifNotNil: [self visibleClasses indexOf: classSelection]! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'!
classSelection: aNumber
	classSelection := aNumber = 0 ifFalse: [self visibleClasses at: aNumber].
	self protocolSelection: 0.
	self changed: #classSelection; 
		changed: #protocolList;
		changed: #annotations;
		changed: #methodList.
! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 20:26'!
methodSelection
	^ methodSelection
			ifNil: [0] 
			ifNotNil: [self visibleMethods indexOf: methodSelection]! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'!
methodSelection: aNumber
	methodSelection := aNumber = 0 ifFalse: [self visibleMethods at: aNumber].
	self changed: #methodSelection; changed: #text; changed: #annotations! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 19:35'!
protocolSelection
	^ protocolSelection 
		ifNil: [0]
		ifNotNil: [self visibleProtocols indexOf: protocolSelection]! !

!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'!
protocolSelection: anInteger
	protocolSelection := (anInteger = 0 ifFalse: [self visibleProtocols at: anInteger]).
	self methodSelection: 0.
	self changed: #protocolSelection;
		changed: #methodList;	
		changed: #annotations! !


!MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:57'!
signalSwitchChanged
	self protocolSelection: 0.
	self 
		changed: #switchIsInstance;
		changed: #switchIsComment;
		changed: #switchIsClass;
		changed: #protocolList;
		changed: #methodList;
		changed: #text.! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'!
switchBeClass
	switch := #class.
	self signalSwitchChanged.! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'!
switchBeComment
	switch := #comment.
	self signalSwitchChanged.! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'!
switchBeInstance
	switch := #instance.
	self signalSwitchChanged.! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:05'!
switchIsClass
	^ switch = #class! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:04'!
switchIsComment
	^ switch = #comment.! !

!MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'!
switchIsInstance
	switch ifNil: [switch := #instance].
	^ switch = #instance.! !


!MCSnapshotBrowser methodsFor: 'text' stamp: 'nk 7/24/2003 13:40'!
annotations
	methodSelection ifNotNil: [^ methodSelection annotations ].
	^ ''! !

!MCSnapshotBrowser methodsFor: 'text' stamp: 'nk 7/24/2003 13:41'!
annotations: stuff
	self changed: #annotations! !

!MCSnapshotBrowser methodsFor: 'text' stamp: 'ab 7/18/2003 15:48'!
classCommentString
	^ (items 
		detect: [:ea | ea isClassDefinition and: [ea className = classSelection]]
		ifNone: [^ '']) comment.! !

!MCSnapshotBrowser methodsFor: 'text' stamp: 'stephaneducasse 2/4/2006 20:47'!
classDefinitionString
	| defs |
	defs := items select: [:ea | (ea isClassDefinition or: [ea isClassDefinitionExtension])
			and: [ea className = classSelection]].

	defs isEmpty ifTrue: [^ 'This class is defined elsewhere.'].

	^ String streamContents: [:stream | 
		defs asArray sort 
			do: [:ea | ea printDefinitionOn: stream]
			separatedBy: [stream nextPut: $.; cr]
	].! !

!MCSnapshotBrowser methodsFor: 'text' stamp: 'cwp 7/13/2003 08:55'!
text
	self switchIsComment ifTrue: [^ self classCommentString].
	methodSelection ifNotNil: [^ methodSelection source].
	protocolSelection ifNotNil: [^ ''].
	classSelection ifNotNil: [^ self classDefinitionString].
	^ ''! !

!MCSnapshotBrowser methodsFor: 'text' stamp: 'cwp 7/11/2003 00:30'!
text: aTextOrString
	self changed: #text! !

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

MCSnapshotBrowser class
	instanceVariableNames: ''!

!MCSnapshotBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:03'!
forSnapshot: aSnapshot
	^ self new snapshot: aSnapshot! !
MCTestCase subclass: #MCSnapshotBrowserTest
	instanceVariableNames: 'model morph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 01:19'!
assertAListIncludes: anArrayOfStrings
	self listMorphs 
			detect: [:m | m getList includesAllOf: anArrayOfStrings]
			ifNone: [self assert: false].! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertAListMatches: strings
	| listMorphs list |
	listMorphs := self listMorphs.
	listMorphs 
		detect: [:m | list := m getList. (list size = strings size) and: [list includesAllOf: strings]]
		ifNone: [self assert: false].! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:12'!
assertButtonExists: aString
	self buttonMorphs detect: [:m | m label = aString] ifNone: [self assert: false].
				! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:26'!
assertButtonOn: aString
	self assert: (self findButtonWithLabel: aString) getModelState.
	! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 02:38'!
assertTextIs: aString
	self assert: self textMorph contents = aString.! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
denyAListHasSelection: aString
	| found |
	found := true.
	self listMorphs 
			detect: [:m | m selection = aString]
			ifNone: [found := false].
	self deny: found.! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
denyAListIncludesAnyOf: anArrayOfStrings
	| found |
	found := true.
	self listMorphs 
			detect: [:m | m getList includesAnyOf: anArrayOfStrings]
			ifNone: [found := false].
	self deny: found.! !

!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:27'!
denyButtonOn: aString
	self deny: (self findButtonWithLabel: aString) getModelState.
	! !


!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/28/2003 22:21'!
annotationTextMorph
	^ (self morphsOfClass: TextMorph) first! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 09:12'!
buttonMorphs
	^ self morphsOfClass: PluggableButtonMorph! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 09:19'!
findButtonWithLabel: aString
	^ self buttonMorphs detect: [:m | m label = aString]! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 01:28'!
findListContaining: aString
	^ self listMorphs detect: [:m | m getList includes: aString]! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 02:34'!
listMorphs
	^ self morphsOfClass: PluggableListMorph! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'stephaneducasse 2/4/2006 20:47'!
morphsOfClass: aMorphClass
	| morphs |
	morphs := OrderedCollection new.
	morph allMorphsDo: [:m | (m isKindOf: aMorphClass) ifTrue: [morphs add: m]].
	^ morphs! !

!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/28/2003 22:21'!
textMorph
	^ (self morphsOfClass: TextMorph) last! !


!MCSnapshotBrowserTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	model := MCSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot.
	morph := model buildWindow.! !


!MCSnapshotBrowserTest methodsFor: 'selecting' stamp: 'cwp 7/13/2003 13:04'!
selectMockClassA
	self clickOnListItem: self mockCategoryName.
	self clickOnListItem: 'MCMockClassA'.
	! !


!MCSnapshotBrowserTest methodsFor: 'simulating' stamp: 'cwp 7/13/2003 09:22'!
clickOnButton: aString
	(self findButtonWithLabel: aString) performAction.! !

!MCSnapshotBrowserTest methodsFor: 'simulating' stamp: 'stephaneducasse 2/4/2006 20:47'!
clickOnListItem: aString
	| listMorph |
	listMorph := self findListContaining: aString.
	listMorph changeModelSelection: (listMorph getList indexOf: aString).! !


!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testAnnotationPane
	| oldPref |
	oldPref := Preferences annotationPanes.

	Preferences disable: #annotationPanes.
	morph := model buildWindow.
	self assert: (self morphsOfClass: TextMorph) size = 1.

	Preferences enable: #annotationPanes.
	morph := model buildWindow.
	self assert: (self morphsOfClass: TextMorph) size = 2.

	Preferences setPreference: #annotationPanes toValue: oldPref! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:31'!
testButtonMutex
	self assertButtonOn: 'instance'.
	self denyButtonOn: '?'.
	self denyButtonOn: 'class'.
	
	self clickOnButton: '?'.
	self assertButtonOn: '?'.
	self denyButtonOn: 'instance'.
	self denyButtonOn: 'class'.
	
	self clickOnButton: 'class'.
	self assertButtonOn: 'class'.
	self denyButtonOn: '?'.
	self denyButtonOn: 'instance'.
! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:40'!
testCategorySelected
	self clickOnListItem: self mockCategoryName.
	
	self assertAListMatches: self allCategories.
	self assertAListMatches: self definedClasses.
	self denyAListIncludesAnyOf: self allProtocols.
	self denyAListIncludesAnyOf: self allMethods.
	self assertTextIs: ''.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 13:04'!
testClassSelected
	self selectMockClassA.
	
	self assertAListMatches: self allCategories.
	self assertAListMatches: self definedClasses.
	self assertAListMatches: self classAProtocols.
	self denyAListIncludesAnyOf: self allMethods.
	self assertTextIs: self classADefinitionString.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 13:06'!
testClassSideClassSelected
	self clickOnButton: 'class'.
	self selectMockClassA.
	
	self assertAListMatches: self allCategories.
	self assertAListMatches: self definedClasses.
	self assertAListMatches: self classAClassProtocols.
	self denyAListIncludesAnyOf: self allMethods.
	self assertTextIs: self classADefinitionString.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 12:52'!
testComment
	self clickOnButton: '?'.
	self assertTextIs: ''.
	
	self clickOnListItem: self mockCategoryName.
	self assertTextIs: ''.
	
	self clickOnListItem: 'MCMockClassA'.
	self assertTextIs: self classAComment.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:30'!
testFourColumns
	self assert: self listMorphs size = 4.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:00'!
testMethodIsCleared
	self clickOnListItem: self mockCategoryName.
	self clickOnListItem: 'MCMockClassA'.
	self clickOnListItem: 'boolean'.
	self clickOnListItem: 'falsehood'.
	self clickOnListItem: '-- all --'.
	
	self denyAListHasSelection: 'falsehood'.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:50'!
testMethodSelected
	self clickOnListItem: self mockCategoryName.
	self clickOnListItem: 'MCMockClassA'.
	self clickOnListItem: 'boolean'.
	self clickOnListItem: 'falsehood'.
	
	self assertAListMatches: self allCategories.
	self assertAListMatches: self definedClasses.
	self assertAListMatches: self classAProtocols.
	self assertAListMatches: self classABooleanMethods.
	self assertTextIs: self falsehoodMethodSource.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:39'!
testNoSelection
	self assertAListMatches: self allCategories.
	self denyAListIncludesAnyOf: self definedClasses.
	self denyAListIncludesAnyOf: self allProtocols.
	self denyAListIncludesAnyOf: self allMethods.
	self assertTextIs: ''.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 08:46'!
testProtocolIsCleared
	self clickOnListItem: self mockCategoryName.
	self clickOnListItem: 'MCMockASubclass'.
	self clickOnListItem: 'as yet unclassified'.
	self clickOnListItem: 'MCMockClassA'.
	
	self denyAListHasSelection: 'as yet unclassified'.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 08:52'!
testProtocolSelected
	self clickOnListItem: self mockCategoryName.
	self clickOnListItem: 'MCMockClassA'.
	self clickOnListItem: 'boolean'.
	
	self assertAListMatches: self allCategories.
	self assertAListMatches: self definedClasses.
	self assertAListMatches: self classAProtocols.
	self assertAListMatches: self classABooleanMethods.
	self assertTextIs: ''.		! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:37'!
testTextPane
	self shouldnt: [self textMorph] raise: Exception.! !

!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:14'!
testThreeButtons
	self assertButtonExists: 'instance'.
	self assertButtonExists: '?'.
	self assertButtonExists: 'class'.! !


!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:46'!
allCategories
	^ Array with: model extensionsCategory with: self mockCategoryName.! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:58'!
allMethods
	^ MCSnapshotResource current definitions
		select: [:def | def isMethodDefinition]
		thenCollect: [:def | def selector]		! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:58'!
allProtocols
	^ MCSnapshotResource current definitions
		select: [:def | def isMethodDefinition]
		thenCollect: [:def | def category]		! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/13/2003 02:23'!
classABooleanMethods
	^ #(falsehood moreTruth truth)! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'!
classAClassProtocols
	^ self protocolsForClass: self mockClassA class.! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'!
classAComment
	^ self mockClassA organization classComment.! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'!
classADefinitionString
	^ self mockClassA definition! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'!
classAProtocols
	^ self protocolsForClass: self mockClassA.! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:59'!
definedClasses
	^ MCSnapshotResource current definitions 
		select: [:def | def isClassDefinition] 
		thenCollect: [:def | def className].! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/13/2003 02:53'!
falsehoodMethodSource
	^ 'falsehood
	^ false'! !

!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
protocolsForClass: aClass
	| protocols |
	protocols := aClass organization categories.
	protocols size > 1 ifTrue: [protocols := protocols copyWith: '-- all --'].
	^ protocols.! !

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

MCSnapshotBrowserTest class
	instanceVariableNames: ''!

!MCSnapshotBrowserTest class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 14:59'!
resources
	^ Array with: MCSnapshotResource! !
MCReader subclass: #MCSnapshotReader
	instanceVariableNames: 'definitions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCSnapshotReader methodsFor: 'as yet unclassified' stamp: 'avi 1/21/2004 23:09'!
definitions
	definitions ifNil: [self loadDefinitions].
	^ definitions! !

!MCSnapshotReader methodsFor: 'as yet unclassified' stamp: 'avi 1/21/2004 23:10'!
snapshot
	^ MCSnapshot fromDefinitions: self definitions! !

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

MCSnapshotReader class
	instanceVariableNames: ''!

!MCSnapshotReader class methodsFor: 'as yet unclassified' stamp: 'avi 1/21/2004 22:56'!
snapshotFromStream: aStream
	^ (self on: aStream) snapshot! !
TestResource subclass: #MCSnapshotResource
	instanceVariableNames: 'snapshot'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCSnapshotResource methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 14:50'!
definitions
	^ snapshot definitions! !

!MCSnapshotResource methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	snapshot := self class takeSnapshot.! !

!MCSnapshotResource methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 14:51'!
snapshot
	^ snapshot! !

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

MCSnapshotResource class
	instanceVariableNames: ''!

!MCSnapshotResource class methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 20:18'!
mockPackage
	^ (MCPackage new name: self mockPackageName)! !

!MCSnapshotResource class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 13:54'!
mockPackageName
	^ MCMockPackageInfo new packageName! !

!MCSnapshotResource class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:19'!
takeSnapshot
	^ self mockPackage snapshot! !
MCTestCase subclass: #MCSnapshotTest
	instanceVariableNames: 'snapshot'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCSnapshotTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	snapshot :=  self mockSnapshot.! !


!MCSnapshotTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testCreation
	|d|
	d :=  self mockSnapshot definitions.
	self assert: (d anySatisfy: [:ea | ea isClassDefinition and: [ea className = #MCMockClassA]]).
	self assert: (d anySatisfy: [:ea | ea isMethodDefinition and: [ea selector = #mockClassExtension]]).
	self assert: (d allSatisfy: [:ea | ea isClassDefinition not or: [ea category endsWith: 'Mocks']]).
	! !

!MCSnapshotTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testInstanceReuse
	| x m n y |
	x := (MCPackage new name: self mockCategoryName) snapshot.
	Smalltalk garbageCollect.
	n := MCDefinition allSubInstances size.
	y := (MCPackage new name: self mockCategoryName) snapshot.
	Smalltalk garbageCollect.
	m := MCDefinition allSubInstances size.
	self assert: m = n! !


!MCSnapshotTest methodsFor: '*monticello-mocks' stamp: 'ab 7/7/2003 23:21'!
mockClassExtension! !

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

MCSnapshotTest class
	instanceVariableNames: ''!
TestCase subclass: #MCSortingTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCSortingTest methodsFor: 'actions' stamp: 'ab 7/19/2003 18:01'!
sortDefinitions: aCollection
	^ aCollection asSortedCollection asArray! !


!MCSortingTest methodsFor: 'building' stamp: 'ab 4/8/2003 17:56'!
classNamed: aSymbol
	^ MCClassDefinition
		name: aSymbol
		superclassName: #Object
		category: ''
		instVarNames: #()
		comment: ''! !

!MCSortingTest methodsFor: 'building' stamp: 'ab 4/8/2003 18:03'!
methodNamed: aSymbol class: className meta: aBoolean
	^ MCMethodDefinition
		className: className
		classIsMeta: aBoolean
		selector: aSymbol
		category: ''
		timeStamp: ''
		source: ''! !

!MCSortingTest methodsFor: 'building' stamp: 'ab 7/19/2003 17:56'!
sortKeyFor: aDefinition
	^ String streamContents:
		[:s |
		aDefinition description
			do: [:ea | s nextPutAll: ea asString]
			separatedBy: [s nextPut: $.]]! !


!MCSortingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testConsistentSorting
	| definitions shuffledAndSorted|
	definitions :=
		{self methodNamed: #a class: #A meta: false.
		self methodNamed: #a class: #A meta: true.
		self methodNamed: #a class: #B meta: false.
		self methodNamed: #b class: #A meta: false.
		self methodNamed: #b class: #B meta: false.
		self classNamed: #A.
		self classNamed: #B}.
	shuffledAndSorted :=
		(1 to: 100) collect: [:ea | self sortDefinitions: definitions shuffled].
	self assert: shuffledAndSorted asSet size = 1.
! !

!MCSortingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testSortOrder
	| aA aAm aB bA bB A B cA bAm cAm |
	aA := self methodNamed: #a class: #A meta: false.
	bA := self methodNamed: #b class: #A meta: false.
	cA := self methodNamed: #c class: #A meta: false.
	aAm := self methodNamed: #a class: #A meta: true.
	bAm := self methodNamed: #b class: #A meta: true.
	cAm := self methodNamed: #c class: #A meta: true.
	aB := self methodNamed: #a class: #B meta: false.
	bB := self methodNamed: #b class: #B meta: false.
	A := self classNamed: #A.
	B := self classNamed: #B.
	self assert: (self sortDefinitions: {aA. aAm. cAm. aB. bAm. bA. bB. A. cA. B})
					= {A. aAm. bAm. cAm. aA. bA. cA. B. aB.  bB}! !

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

MCSortingTest class
	instanceVariableNames: ''!
MCSnapshotReader subclass: #MCStReader
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Chunk Format'!

!MCStReader methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:52'!
addDefinitionsFromDoit: aString
	(MCDoItParser forDoit: aString) ifNotNilDo:
		[:parser |
		parser addDefinitionsTo: definitions]! !

!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
categoryFromDoIt: aString
	| tokens  |
	tokens := Scanner new scanTokens: aString.
	tokens size = 3 ifFalse: [self error: 'Unrecognized category definition'].
	^ tokens at: 3! !

!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
classDefinitionFrom: aPseudoClass
	| tokens traitCompositionString lastIndex classTraitCompositionString |
	tokens := Scanner new scanTokens: aPseudoClass definition.
	traitCompositionString := ((ReadStream on: aPseudoClass definition)
		match: 'uses:';
		upToAll: 'instanceVariableNames:') withBlanksTrimmed.
	classTraitCompositionString := ((ReadStream on: aPseudoClass metaClass definition asString)
		match: 'uses:';
		upToAll: 'instanceVariableNames:') withBlanksTrimmed.
	traitCompositionString isEmpty ifTrue: [traitCompositionString := '{}'].
	classTraitCompositionString isEmpty ifTrue: [classTraitCompositionString := '{}'].
	lastIndex := tokens size.
	^ MCClassDefinition
		name: (tokens at: 3)
		superclassName: (tokens at: 1)
		traitComposition: traitCompositionString
		classTraitComposition: classTraitCompositionString
		category: (tokens at: lastIndex)
		instVarNames: ((tokens at: lastIndex - 6) findTokens: ' ')
		classVarNames: ((tokens at: lastIndex - 4) findTokens: ' ')
		poolDictionaryNames: ((tokens at: lastIndex - 2) findTokens: ' ')
		classInstVarNames: (self classInstVarNamesFor: aPseudoClass)
		type: (self typeOfSubclass: (tokens at: 2))
		comment: (self commentFor: aPseudoClass)
		commentStamp: (self commentStampFor: aPseudoClass)! !

!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
classInstVarNamesFor: aPseudoClass
	| tokens |
	
	self flag: #traits.
	aPseudoClass metaClass hasDefinition ifFalse: [^ #()].
	tokens := Scanner new scanTokens: aPseudoClass metaClass definition.
	"tokens size = 4 ifFalse: [self error: 'Unrecognized metaclass definition']."
	^ tokens last findTokens: ' '! !

!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
commentFor: aPseudoClass
	| comment |
	comment := aPseudoClass organization classComment.
	^ comment asString = ''
		ifTrue: [comment]
		ifFalse: [comment string]! !

!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
commentStampFor: aPseudoClass
	| comment |
	comment := aPseudoClass organization classComment.
	^  [comment stamp] on: MessageNotUnderstood do: [nil]! !

!MCStReader methodsFor: 'as yet unclassified' stamp: 'avi 3/3/2004 15:23'!
methodDefinitionsFor: aPseudoClass
	^ aPseudoClass selectors collect: 
		[:ea |
		 MCMethodDefinition
			className: aPseudoClass name
			classIsMeta: aPseudoClass isMeta
			selector: ea
			category: (aPseudoClass organization categoryOfElement: ea)
			timeStamp: (aPseudoClass stampAt: ea)
			source: (aPseudoClass sourceCodeAt: ea)]! !

!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
systemOrganizationFromRecords: changeRecords
	| categories |
	categories := changeRecords
					select: [:ea | 'SystemOrganization*' match: ea string]
					thenCollect: [:ea | (self categoryFromDoIt: ea string)].
	^ categories isEmpty ifFalse: [MCOrganizationDefinition categories: categories asArray]! !

!MCStReader methodsFor: 'as yet unclassified' stamp: 'avi 1/19/2004 21:56'!
typeOfSubclass: aSymbol
	#(
		(subclass: normal)
		(variableSubclass: variable)
		(variableByteSubclass: bytes)
		(variableWordSubclass: words)
		(weakSubclass: weak)
		) do: [:ea | ea first = aSymbol ifTrue: [^ ea second]].
	self error: 'Unrecognized class definition'! !


!MCStReader methodsFor: 'evaluating' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadDefinitions
	| filePackage |
	filePackage :=
		FilePackage new
			fullName: 'ReadStream';
			fileInFrom: self readStream.
	definitions := OrderedCollection new.
	filePackage classes do:
		[:pseudoClass |
		pseudoClass hasDefinition
			ifTrue: [definitions add:
					(self classDefinitionFrom: pseudoClass)].
		definitions addAll: (self methodDefinitionsFor: pseudoClass).
		definitions addAll: (self methodDefinitionsFor: pseudoClass metaClass)].
	filePackage doIts do:
		[:ea |
		self addDefinitionsFromDoit: ea string].
	! !

!MCStReader methodsFor: 'evaluating' stamp: 'avi 1/21/2004 14:21'!
readStream
	^ ('!!!!

', stream contents) readStream! !

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

MCStReader class
	instanceVariableNames: ''!

!MCStReader class methodsFor: 'as yet unclassified' stamp: 'avi 1/20/2004 00:17'!
extension
	^ 'st'! !
MCTestCase subclass: #MCStReaderTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'ab 8/17/2003 16:52'!
commentWithoutStyle
	^ '
CharacterScanner subclass: #CanvasCharacterScanner
	instanceVariableNames: ''canvas fillBlt foregroundColor runX lineY ''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''Morphic-Support''!!

!!CanvasCharacterScanner commentStamp: ''<historical>'' prior: 0!!
A displaying scanner which draws its output to a Morphic canvas.!!

!!CanvasCharacterScanner methodsFor: ''stop conditions'' stamp: ''ar 12/15/2001 23:27''!!
setStopConditions
	"Set the font and the stop conditions for the current run."

	self setFont.
	stopConditions
		at: Space asciiValue + 1
		put: (alignment = Justified ifTrue: [#paddedSpace])!! !!'! !

!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/16/2003 23:35'!
commentWithStyle
	^ '!!AEDesc commentStamp: ''<historical>'' prior: 0!!
I represent an Apple Event Descriptor.  I am a low-level representation of Apple Event (and hence Applescript) information.  For further Information, see Apple''s Inside Macintosh: Interapplication Communications, at

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

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

!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/16/2003 23:07'!
methodWithStyle
	^ '!!EventHandler methodsFor: ''copying'' stamp: ''tk 1/22/2001 17:39''!!
veryDeepInner: deepCopier
	"ALL fields are weakly copied.  Can''t duplicate an object by duplicating a button that activates it.  See DeepCopier."

	super veryDeepInner: deepCopier.
	"just keep old pointers to all fields"
	clickRecipient _ clickRecipient.!!
]style[(25 108 10 111)f1b,f1,f1LDeepCopier Comment;,f1!! !!

'! !

!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testCommentWithoutStyle
	| reader |
	reader := MCStReader on: self commentWithoutStyle readStream.
	self assert: (reader definitions anySatisfy: [:ea | ea isMethodDefinition]).! !

!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testCommentWithStyle
	| reader |
	reader := MCStReader on: self commentWithStyle readStream.
	reader definitions! !

!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
testMethodWithStyle
	| reader |
	reader := MCStReader on: self methodWithStyle readStream.
	self assert: reader definitions first isMethodDefinition.! !

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

MCStReaderTest class
	instanceVariableNames: ''!
MCWriter subclass: #MCStWriter
	instanceVariableNames: 'initStream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Chunk Format'!

!MCStWriter methodsFor: 'visiting' stamp: 'cwp 8/2/2003 11:02'!
visitClassDefinition: definition
	self writeClassDefinition: definition.
	definition hasClassInstanceVariables ifTrue: [self writeMetaclassDefinition: definition].
	definition hasComment ifTrue: [self writeClassComment: definition].! !

!MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:52'!
visitClassTraitDefinition: definition
	self chunkContents: [:s | s
		nextPutAll: definition baseTrait;
		nextPutAll: ' classTrait';
		cr; tab;
		nextPutAll: 'uses: ';
		nextPutAll: (definition classTraitComposition ifNil: ['{}'])]
! !

!MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:40'!
visitMetaclassDefinition: definition
	self writeMetaclassDefinition: definition! !

!MCStWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 02:23'!
visitMethodDefinition: definition
	self writeMethodPreamble: definition.
	self writeMethodSource: definition.
	self writeMethodPostscript.
	self writeMethodInitializer: definition.! !

!MCStWriter methodsFor: 'visiting' stamp: 'cwp 8/2/2003 11:02'!
visitOrganizationDefinition: defintion
	defintion categories do: [:cat | self writeCategory: cat].
! !

!MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:40'!
visitTraitDefinition: definition
	self writeClassDefinition: definition.
	definition hasComment ifTrue: [self writeClassComment: definition].! !


!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 02:34'!
chunkContents: aBlock
	stream cr; nextChunkPut: (String streamContents: aBlock); cr! !

!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 01:46'!
writeCategory: categoryName
	stream
		nextChunkPut: 'SystemOrganization addCategory: ', categoryName printString;
		cr! !

!MCStWriter methodsFor: 'writing' stamp: 'ab 8/17/2003 17:09'!
writeClassComment: definition
	stream
		cr;
		nextPut: $!!;
		nextPutAll: definition className;
		nextPutAll: ' commentStamp: ';
		store: definition commentStamp;
		nextPutAll: ' prior: 0!!';
		cr;
		nextChunkPut: definition comment;
		cr.! !

!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 02:16'!
writeClassDefinition: definition
	self chunkContents: [:s | definition printDefinitionOn: stream]! !

!MCStWriter methodsFor: 'writing' stamp: 'dvf 9/8/2004 10:28'!
writeDefinitions: aCollection
	"initStream is an ugly hack until we have proper init defs"
	initStream := String new writeStream.

	(MCDependencySorter sortItems: aCollection)
		do: [:ea | ea accept: self]
		displayingProgress: 'Writing definitions...'.
	
	stream nextPutAll: initStream contents.! !

!MCStWriter methodsFor: 'writing' stamp: 'al 12/2/2005 15:17'!
writeMetaclassDefinition: definition
	self chunkContents: [:str |
		str	nextPutAll: definition className;
			nextPutAll: ' class';
			cr; tab.
			definition hasClassTraitComposition ifTrue: [
				str	nextPutAll: 'uses: ';
					nextPutAll: definition classTraitCompositionString;
					cr; tab].
			str	nextPutAll: 'instanceVariableNames: ''';
				nextPutAll: definition classInstanceVariablesString;
				nextPut: $']! !

!MCStWriter methodsFor: 'writing' stamp: 'avi 2/17/2004 02:24'!
writeMethodInitializer: aMethodDefinition
	aMethodDefinition isInitializer ifTrue:
		[initStream nextChunkPut: aMethodDefinition className, ' initialize'; cr]! !

!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 12:43'!
writeMethodPostscript
	stream
		space;
		nextPut: $!!;
		cr! !

!MCStWriter methodsFor: 'writing' stamp: 'avi 9/23/2003 17:42'!
writeMethodPreamble: definition
	stream
		cr;
		nextPut: $!!;
		nextPutAll: definition fullClassName;
		nextPutAll: ' methodsFor: ';
		nextPutAll: definition category asString printString;
		nextPutAll: ' stamp: ';
		nextPutAll: definition timeStamp asString printString;
		nextPutAll: '!!';
		cr! !

!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/4/2003 01:35'!
writeMethodSource: definition
	stream nextChunkPut: definition source! !

!MCStWriter methodsFor: 'writing' stamp: 'avi 2/17/2004 02:25'!
writeSnapshot: aSnapshot
	self writeDefinitions: aSnapshot definitions! !

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

MCStWriter class
	instanceVariableNames: ''!

!MCStWriter class methodsFor: 'as yet unclassified' stamp: 'avi 1/20/2004 00:16'!
readerClass
	^ MCStReader! !
MCTestCase subclass: #MCStWriterTest
	instanceVariableNames: 'stream writer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCStWriterTest methodsFor: 'asserting' stamp: 'cwp 8/2/2003 12:13'!
assertAllChunksAreWellFormed
	stream reset.
	stream 
		untilEnd: [self assertChunkIsWellFormed: stream nextChunk]
		displayingProgress: 'Checking syntax...'! !

!MCStWriterTest methodsFor: 'asserting' stamp: 'al 7/21/2006 22:14'!
assertChunkIsWellFormed: chunk
	self class parserClass new
		parse: chunk readStream 
		class: UndefinedObject 
		noPattern: true
		context: nil
		notifying: nil
		ifFail: [self assert: false]! !

!MCStWriterTest methodsFor: 'asserting' stamp: 'nk 2/22/2005 21:17'!
assertContentsOf: strm match: expected 
	| actual |
	actual := strm contents.
	self assert: actual size = expected size.
	actual with: expected do: [:a :e | self assert: a = e]! !

!MCStWriterTest methodsFor: 'asserting' stamp: 'al 7/21/2006 22:14'!
assertMethodChunkIsWellFormed: chunk
	self class parserClass new
		parse: chunk readStream 
		class: UndefinedObject 
		noPattern: false
		context: nil
		notifying: nil
		ifFail: [self assert: false]! !


!MCStWriterTest methodsFor: 'data' stamp: 'cwp 2/3/2004 21:39'!
expectedClassDefinitionA
 ^ '
MCMock subclass: #MCMockClassA
	instanceVariableNames: ''ivar''
	classVariableNames: ''CVar''
	poolDictionaries: ''''
	category: ''Monticello-Mocks''!!

!!MCMockClassA commentStamp: ''cwp 8/10/2003 16:43'' prior: 0!!
This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.!!
'! !

!MCStWriterTest methodsFor: 'data' stamp: 'avi 2/17/2004 03:23'!
expectedClassDefinitionB
 ^ '
MCMock subclass: #MCMockClassB
	instanceVariableNames: ''ivarb''
	classVariableNames: ''CVar''
	poolDictionaries: ''MCMockAPoolDictionary''
	category: ''Monticello-Mocks''!!

MCMockClassB class
	instanceVariableNames: ''ciVar''!!

!!MCMockClassB commentStamp: '''' prior: 0!!
This comment has a bang!!!! Bang!!!! Bang!!!!!!
'! !

!MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/2/2003 14:43'!
expectedClassMethodDefinition
	^ '
!!MCMockClassA class methodsFor: ''as yet unclassified'' stamp: ''ab 7/7/2003 23:21''!!
one

	^ 1!! !!
'! !

!MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/2/2003 17:27'!
expectedMethodDefinition
	^ '
!!MCMockClassA methodsFor: ''numeric'' stamp: ''cwp 8/2/2003 17:26''!!
one
	^ 1!! !!
'! !

!MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/9/2003 14:58'!
expectedMethodDefinitionWithBangs
	^ '
!!MCStWriterTest methodsFor: ''testing'' stamp: ''cwp 8/9/2003 14:55''!!
methodWithBangs
	^ ''
	^ ReadStream on: 
''''MCRevisionInfo packageName: ''''MonticelloCompatibilityTest''''!!!!!!!!
MCOrganizationDeclaration categories: 
  #(
  ''''Monticello-Mocks'''')!!!!!!!!

MCClassDeclaration
  name: #MCMockClassD
  superclassName: #Object
  category: #''''Monticello-Mocks''''
  instVarNames: #()
  comment: ''''''''!!!!!!!!

MCMethodDeclaration className: #MCMockClassD selector: #one category: #''''as yet unclassified'''' timeStamp: ''''cwp 7/8/2003 21:21'''' source: 
''''one
	^ 1''''!!!!!!!!
''''
''
!! !!
'! !

!MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/2/2003 12:14'!
expectedOrganizationDefinition
	^ 'SystemOrganization addCategory: ''Monticello-Mocks''!!
'! !


!MCStWriterTest methodsFor: 'testing' stamp: 'ab 8/8/2003 17:01'!
expectedInitializerA
	^ 'MCMockClassA initialize'! !

!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/9/2003 14:55'!
methodWithBangs
	^ '
	^ ReadStream on: 
''MCRevisionInfo packageName: ''MonticelloCompatibilityTest''!!!!
MCOrganizationDeclaration categories: 
  #(
  ''Monticello-Mocks'')!!!!

MCClassDeclaration
  name: #MCMockClassD
  superclassName: #Object
  category: #''Monticello-Mocks''
  instVarNames: #()
  comment: ''''!!!!

MCMethodDeclaration className: #MCMockClassD selector: #one category: #''as yet unclassified'' timeStamp: ''cwp 7/8/2003 21:21'' source: 
''one
	^ 1''!!!!
''
'
! !

!MCStWriterTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	stream := RWBinaryOrTextStream on: String new.
	writer := MCStWriter on: stream.
! !

!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:11'!
testClassDefinitionA
	writer visitClassDefinition: (self mockClassA asClassDefinition).
	self assertContentsOf: stream match: self expectedClassDefinitionA.
	stream reset.
	2 timesRepeat: [self assertChunkIsWellFormed: stream nextChunk]! !

!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 9/14/2003 19:39'!
testClassDefinitionB
	writer visitClassDefinition: (self mockClassB asClassDefinition).
	self assertContentsOf: stream match: self expectedClassDefinitionB.
	! !

!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:11'!
testClassMethodDefinition
	writer visitMethodDefinition: (MethodReference class: self mockClassA class selector: #one) 									asMethodDefinition.
	self assertContentsOf: stream match: self expectedClassMethodDefinition.
	stream reset.
	self assert: stream nextChunk isAllSeparators.
	self assertChunkIsWellFormed: stream nextChunk.
	self assertMethodChunkIsWellFormed: stream nextChunk.
	self assert: stream nextChunk isAllSeparators ! !

!MCStWriterTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testInitializerDefinition
	|chunk lastChunk|
	writer writeSnapshot: self mockSnapshot.
	stream reset.
	[stream atEnd] whileFalse:
		[chunk := stream nextChunk.
		chunk isAllSeparators ifFalse: [lastChunk := chunk]].
	self assertContentsOf: lastChunk readStream match: self expectedInitializerA! !

!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:11'!
testMethodDefinition
	writer visitMethodDefinition: (MethodReference class: self mockClassA selector: #one) 									asMethodDefinition.
	self assertContentsOf: stream match: self expectedMethodDefinition.
	stream reset.
	self assert: stream nextChunk isAllSeparators.
	self assertChunkIsWellFormed: stream nextChunk.
	self assertMethodChunkIsWellFormed: stream nextChunk.
	self assert: stream nextChunk isAllSeparators ! !

!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/9/2003 14:52'!
testMethodDefinitionWithBangs
	writer visitMethodDefinition: (MethodReference 
									class: self class 
									selector: #methodWithBangs) asMethodDefinition.
	self assertContentsOf: stream match: self expectedMethodDefinitionWithBangs.
	stream reset.
	self assert: stream nextChunk isAllSeparators.
	self assertChunkIsWellFormed: stream nextChunk.
	self assertMethodChunkIsWellFormed: stream nextChunk.
	self assert: stream nextChunk isAllSeparators ! !

!MCStWriterTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'!
testOrganizationDefinition
	| definition |
	definition := MCOrganizationDefinition categories: 
					(self mockPackage packageInfo systemCategories).
	writer visitOrganizationDefinition: definition.
	self assertContentsOf: stream match: self expectedOrganizationDefinition.
	self assertAllChunksAreWellFormed.! !

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

MCStWriterTest class
	instanceVariableNames: ''!
MCDirectoryRepository subclass: #MCSubDirectoryRepository
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!
!MCSubDirectoryRepository commentStamp: 'nk 6/11/2004 18:56' prior: 0!
A MCDirectoryRepository that looks in subdirectories too.!


!MCSubDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
findFullNameForReading: aBaseName
	"Answer the latest version of aBaseName"
	| possible |
	possible := SortedCollection sortBlock: [ :a :b | b first modificationTime < a first modificationTime ].
	self allDirectories
		do: [:dir | dir entries
				do: [:ent | ent isDirectory
						ifFalse: [
							(ent name = aBaseName) ifTrue: [ possible add: {ent. dir fullNameFor: ent name}]]]].
	^(possible at: 1 ifAbsent: [ ^nil ]) second
! !

!MCSubDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
findFullNameForWriting: aBaseName
	| possible split dirScore fileScore prefix fpattern parts now |
	split := directory splitNameVersionExtensionFor: aBaseName.
	fpattern := split first, '*'.
	possible := SortedCollection sortBlock: [ :a :b |
		a first = b first
			ifTrue: [ a second = b second
					ifFalse: [ a second < b second ]
					ifTrue: [ a third fullName size < b third fullName size ]]
			ifFalse: [ a first > b first ] ].
	now := Time totalSeconds.
	prefix := directory pathParts size.
	self allDirectories do: [:dir |
		parts := dir pathParts allButFirst: prefix.
		dirScore := (parts select: [ :part | fpattern match: part ]) size.
		fileScore := (dir entries collect: [ :ent |
			(ent isDirectory not and: [ fpattern match: ent name ])
				ifFalse: [ SmallInteger maxVal ]
				ifTrue: [ now - ent modificationTime ]]).	"minimum age"
		fileScore := fileScore isEmpty ifTrue: [ SmallInteger maxVal  ]
			ifFalse: [ fileScore min ].
		possible add: { dirScore. fileScore. dir } ].
	^ (possible first third) fullNameFor: aBaseName! !

!MCSubDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
readStreamForFileNamed: aString do: aBlock
	| file val |
	file := FileStream readOnlyFileNamed: (self findFullNameForReading: aString).
	val := aBlock value: file.
	file close.
	^ val! !

!MCSubDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'nk 6/11/2004 20:34'!
writeStreamForFileNamed: aString replace: aBoolean do: aBlock 
	| file |
	file := aBoolean
				ifTrue: [FileStream
						forceNewFileNamed: (self findFullNameForReading: aString)]
				ifFalse: [FileStream
						newFileNamed: (self findFullNameForWriting: aString)].
	aBlock value: file.
	file close! !


!MCSubDirectoryRepository methodsFor: 'enumeration' stamp: 'nk 6/11/2004 18:55'!
allDirectories
	| remaining dir dirs |
	remaining := OrderedCollection new.
	dirs := OrderedCollection new.
	remaining addLast: directory.
	[remaining isEmpty]
		whileFalse: [dir := remaining removeFirst.
			dirs add: dir.
			dir entries
				do: [:ent | ent isDirectory
						ifTrue: [remaining
								addLast: (dir directoryNamed: ent name)]]].
	^ dirs! !

!MCSubDirectoryRepository methodsFor: 'enumeration' stamp: 'nk 6/11/2004 20:25'!
allFileNames
	"sorting {entry. dirName. name}"

	| sorted |
	sorted := SortedCollection sortBlock: [:a :b |
		a first modificationTime >= b first modificationTime ].
	self allDirectories
		do: [:dir | dir entries
				do: [:ent | ent isDirectory
						ifFalse: [sorted add: {ent. dir fullName. ent name}]]].
	^ sorted
		collect: [:ea | ea third ]! !


!MCSubDirectoryRepository methodsFor: 'user interface' stamp: 'nk 6/11/2004 18:23'!
description
	^ directory pathName, '/*'! !

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

MCSubDirectoryRepository class
	instanceVariableNames: ''!

!MCSubDirectoryRepository class methodsFor: 'user interface' stamp: 'nk 6/11/2004 18:48'!
description
	^ 'directory with subdirectories'! !
MCDoItParser subclass: #MCSystemCategoryParser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Chunk Format'!

!MCSystemCategoryParser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
addDefinitionsTo: aCollection
	| definition |
	definition := aCollection detect: [:ea | ea isOrganizationDefinition ] ifNone: [aCollection add: (MCOrganizationDefinition categories: #())].
	definition categories: (definition categories copyWith: self category).! !

!MCSystemCategoryParser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
category
	| tokens  |
	tokens := Scanner new scanTokens: source.
	tokens size = 3 ifFalse: [self error: 'Unrecognized category definition'].
	^ tokens at: 3! !

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

MCSystemCategoryParser class
	instanceVariableNames: ''!

!MCSystemCategoryParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:41'!
pattern
	^ 'SystemOrganization*'! !
TestCase subclass: #MCTestCase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 14:58'!
assertPackage: actual matches: expected
	self assert: actual = expected
! !

!MCTestCase methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertSnapshot: actual matches: expected
	| diff |
	diff := actual patchRelativeToBase: expected.
	self assert: diff isEmpty
! !

!MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 15:50'!
assertVersionInfo: actual matches: expected
	self assert: actual name = expected name.
	self assert: actual message = expected message.
	self assert: actual ancestors size = expected ancestors size.
	actual ancestors with: expected ancestors do: [:a :e | self assertVersionInfo: a matches: e]
	! !

!MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 14:58'!
assertVersion: actual matches: expected
	self assertPackage: actual package matches: expected package.	
	self assertVersionInfo: actual info matches: expected info.
	self assertSnapshot: actual snapshot matches: expected snapshot.! !


!MCTestCase methodsFor: 'compiling' stamp: 'cwp 8/10/2003 02:12'!
change: aSelector toReturn: anObject
	self 
		compileClass: self mockClassA 
		source: aSelector, ' ^ ', anObject printString 
		category: 'numeric'! !

!MCTestCase methodsFor: 'compiling' stamp: 'abc 2/16/2006 09:24'!
compileClass: aClass source: source category: category
	aClass compileSilently: source classified: category! !

!MCTestCase methodsFor: 'compiling' stamp: 'cwp 8/2/2003 15:05'!
restoreMocks
	self mockSnapshot updatePackage: self mockPackage! !


!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:51'!
commentForClass: name
	^ 'This is a comment for ', name! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:53'!
commentStampForClass: name
	^ 'tester-', name,  ' 1/1/2000 00:00'! !

!MCTestCase methodsFor: 'mocks' stamp: 'ab 7/19/2003 15:43'!
mockCategoryName
	^ 'Monticello-Mocks'! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 02:05'!
mockClassA
	^ Smalltalk at: #MCMockClassA! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 9/14/2003 19:39'!
mockClassB
	^ Smalltalk at: #MCMockClassB! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:50'!
mockClass: className super: superclassName
	^ MCClassDefinition
		name:  className
		superclassName:  superclassName
		category: self mockCategoryName
		instVarNames: #()
		classVarNames: #()
		poolDictionaryNames: #()
		classInstVarNames: #()
		type: #normal
		comment: (self commentForClass: className)
		commentStamp: (self commentStampForClass: className)! !

!MCTestCase methodsFor: 'mocks' stamp: 'avi 1/19/2004 15:54'!
mockDependencies
	^ Array with: (MCVersionDependency package: self mockEmptyPackage info: (self mockVersionInfo: 'x'))! !

!MCTestCase methodsFor: 'mocks' stamp: 'avi 2/22/2004 14:08'!
mockEmptyPackage
	^ MCPackage named: (MCEmptyPackageInfo new packageName)! !

!MCTestCase methodsFor: 'mocks' stamp: 'avi 2/22/2004 13:56'!
mockExtensionMethodCategory
	^ MCMockPackageInfo new methodCategoryPrefix.! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 02:06'!
mockInstanceA
	^ self mockClassA new! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:24'!
mockMessageString
	^ 'A version generated for testing purposes.'! !

!MCTestCase methodsFor: 'mocks' stamp: 'ab 4/1/2003 02:02'!
mockMethod: aSymbol class: className source: sourceString meta: aBoolean
	^ MCMethodDefinition
		className: className
		classIsMeta: aBoolean
		selector:  aSymbol
		category: 'as yet unclassified'
		timeStamp: ''
		source: sourceString! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 11/13/2003 13:24'!
mockOverrideMethodCategory
	^ self mockExtensionMethodCategory, '-override'! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/1/2003 20:27'!
mockPackage
	^ MCSnapshotResource mockPackage! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/14/2003 15:07'!
mockSnapshot
	^ MCSnapshotResource current snapshot! !

!MCTestCase methodsFor: 'mocks' stamp: 'ab 1/15/2003 17:55'!
mockToken: aSymbol
	^ MCMockDefinition token: aSymbol! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:23'!
mockVersion
	^ MCVersion 
		package: self mockPackage
		info: self mockVersionInfo
		snapshot: self mockSnapshot! !

!MCTestCase methodsFor: 'mocks' stamp: 'avi 2/12/2004 19:58'!
mockVersionInfo
	^ self treeFrom: #(d ((b ((a))) (c)))! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 11/6/2004 16:06'!
mockVersionInfoWithAncestor: aVersionInfo 
	^ MCVersionInfo
		name: aVersionInfo name, '-child'
		id: UUID new
		message: self mockMessageString
		date: Date today
		time: Time now
		author: Utilities authorInitials 
		ancestors: {aVersionInfo}
! !

!MCTestCase methodsFor: 'mocks' stamp: 'avi 2/12/2004 21:01'!
mockVersionInfo: tag 
	^ MCVersionInfo
		name: self mockVersionName, '-', tag asString
		id: UUID new
		message: self mockMessageString, '-', tag asString
		date: Date today
		time: Time now
		author: Utilities authorInitials 
		ancestors: #()
! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:25'!
mockVersionName
	^ 'MonticelloTest-xxx.1'! !

!MCTestCase methodsFor: 'mocks' stamp: 'cwp 11/6/2004 16:03'!
mockVersionWithAncestor: aMCVersion 
	^ MCVersion
		package: self mockPackage
		info: (self mockVersionInfoWithAncestor: aMCVersion info)
		snapshot: self mockSnapshot! !

!MCTestCase methodsFor: 'mocks' stamp: 'avi 1/19/2004 15:15'!
mockVersionWithDependencies
	^ MCVersion 
		package: self mockPackage
		info: self mockVersionInfo
		snapshot: self mockSnapshot
		dependencies: self mockDependencies! !

!MCTestCase methodsFor: 'mocks' stamp: 'stephaneducasse 2/4/2006 20:47'!
treeFrom: anArray
	| name id |
	name := anArray first.
	id := '00000000-0000-0000-0000-0000000000', (name asString size = 1 ifTrue: [name asString, '0'] ifFalse: [name asString]).
	^ MCVersionInfo
		name: name
		id: (UUID fromString: id)
		message: ''
		date: nil
		time: nil
		author: ''
		ancestors: (anArray size > 1 ifTrue: [(anArray second collect: [:ea | self treeFrom: ea])] ifFalse: [#()])! !

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

MCTestCase class
	instanceVariableNames: ''!

!MCTestCase class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:12'!
isAbstract
	^ self = MCTestCase! !

!MCTestCase class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:05'!
resources
	^ Array with: MCSnapshotResource! !
MCMerger subclass: #MCThreeWayMerger
	instanceVariableNames: 'index operations provisions redundantAdds'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Merging'!

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 10/6/2004 15:18'!
addBaseSnapshot: aSnapshot
	aSnapshot definitions do:
		[:ea |
		index add: ea.
		provisions addAll: ea provisions]! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 03:23'!
addDefinition: aDefinition
	index
		definitionLike: aDefinition
		ifPresent: [:other |
			(self removalForDefinition: aDefinition)
				ifNotNilDo:
					[:op |
					self addOperation: (MCModification of: other to: aDefinition).
					self removeOperation: op.
					^ self].
			other = aDefinition
				ifFalse: [self addConflictWithOperation: (MCModification of: other to: aDefinition)]
				ifTrue: [self redundantAdds add: aDefinition]]
		ifAbsent: [self addOperation: (MCAddition of: aDefinition)]! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:30'!
addOperation: anOperation
	self operations add: anOperation! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:52'!
applyPatch: aPatch
	aPatch applyTo: self! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:32'!
applyTo: anObject
	super applyTo: anObject.
	self operations do: [:ea | ea applyTo: anObject]! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:49'!
baseSnapshot
	^ (MCSnapshot fromDefinitions: index definitions)! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	index := MCDefinitionIndex new.
	provisions := Set new! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:22'!
modificationConflictForDefinition: aDefinition
	^ conflicts ifNotNil:
		[conflicts detect:
			[:ea | (ea definition isRevisionOf: aDefinition) and:
				[ea operation isModification]] ifNone: []]! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:34'!
modifyDefinition: baseDefinition to: targetDefinition
	index
		definitionLike: baseDefinition
		ifPresent: [:other | other = baseDefinition
								ifTrue: [self addOperation: (MCModification of:  baseDefinition to: targetDefinition)]
								ifFalse: [other = targetDefinition
											ifFalse: [self addConflictWithOperation:
														(MCModification of: other to: targetDefinition)]]]
		ifAbsent: [self addConflictWithOperation: (MCAddition of: targetDefinition)]! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
operations
	^ operations ifNil: [operations := OrderedCollection new]! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 10/6/2004 15:19'!
provisions
	^ provisions! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
redundantAdds
	^ redundantAdds ifNil: [redundantAdds := Set new]! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:40'!
removalForDefinition: aDefinition
	^ operations ifNotNil:
		[operations
			detect: [:ea | (ea definition isRevisionOf: aDefinition) and: [ea isRemoval]]
			ifNone: []]! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:40'!
removeConflict: aConflict
	conflicts remove: aConflict! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 03:23'!
removeDefinition: aDefinition
	index
		definitionLike: aDefinition
		ifPresent: [:other | other = aDefinition
								ifTrue:
									[(self modificationConflictForDefinition: aDefinition)
										ifNotNilDo:
											[:c |
											self addOperation: c operation.
											self removeConflict: c.
											^ self]. 
									(self redundantAdds includes: aDefinition)
										ifFalse: [self addOperation: (MCRemoval of: aDefinition)]]
								ifFalse:
									[self addConflictWithOperation: (MCRemoval of: other)]]
		ifAbsent: []! !

!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:40'!
removeOperation: anOperation
	operations remove: anOperation! !

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

MCThreeWayMerger class
	instanceVariableNames: ''!

!MCThreeWayMerger class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:53'!
base: aSnapshot patch: aPatch
	aPatch isEmpty ifTrue: [MCNoChangesException signal].
	^ self new
		addBaseSnapshot: aSnapshot;
		applyPatch: aPatch;
		yourself
		! !

!MCThreeWayMerger class methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:09'!
base: aSnapshot target: targetSnapshot ancestor: ancestorSnapshot
	^ self base: aSnapshot patch: (targetSnapshot patchRelativeToBase: ancestorSnapshot)! !

!MCThreeWayMerger class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:52'!
new
	^ self basicNew initialize! !
Object subclass: #MCTool
	instanceVariableNames: 'morph label modal modalValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
answer: anObject
	modalValue := anObject.
	self close.! !

!MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 16:50'!
arrowKey: aCharacter from: aPluggableListMorph 
	"backstop"! !

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
buildWindow
	| window |
	window := SystemWindow labelled: self label.
	window model: self.
	self widgetSpecs do:
		[:pair | |send fractions offsets|
		send := pair first.
		fractions := pair at: 2 ifAbsent: [#(0 0 1 1)].
		offsets := pair at: 3 ifAbsent: [#(0 0 0 0)].
		window
			addMorph: (self perform: send first withArguments: send allButFirst )
			fullFrame:
				(LayoutFrame
					fractions: 
					((fractions first)@(fractions second) corner: 
						(fractions third)@(fractions fourth))
					offsets:
						((offsets first)@(offsets second)  corner:
							(offsets third)@(offsets fourth)))].
	^ window! !

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
buildWith: builder
	|  windowBuilder |

	windowBuilder := MCToolWindowBuilder builder: builder tool: self.
	self widgetSpecs do:
		[:spec | | send fractions offsets origin corner |
		send := spec first.
		fractions := spec at: 2 ifAbsent: [#(0 0 1 1)].
		offsets := spec at: 3 ifAbsent: [#(0 0 0 0)].
		origin := (offsets first @ offsets second) 
			/ self defaultExtent asFloatPoint
			+ (fractions first @ fractions second).
		corner := (offsets third @ offsets fourth) 
			/ self defaultExtent asFloatPoint
			+ (fractions third @ fractions fourth).
		windowBuilder frame: (origin corner: corner).
		windowBuilder perform: send first withArguments: send allButFirst].

	^ windowBuilder build
! !

!MCTool methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:19'!
buttonEnabled
	^ true! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 18:34'!
buttonRow
	^ self buttonRow: self buttonSpecs! !

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
buttonRow: specArray
	| aRow aButton state |
	aRow := AlignmentMorph newRow.
	aRow 
		color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]);
		borderWidth: 0.

	aRow hResizing: #spaceFill; vResizing: #spaceFill; rubberBandCells: true.
	aRow clipSubmorphs: true.
	aRow layoutInset:2@2; cellInset: 1; color: Color white.
	aRow wrapCentering: #center; cellPositioning: #leftCenter.
	specArray do:
		[:triplet |
			state := triplet at: 4 ifAbsent: [#buttonState].
			aButton := PluggableButtonMorph
				on: self
				getState: state
				action: #performButtonAction:enabled:.
			aButton
				hResizing: #spaceFill;
				vResizing: #spaceFill;
				label: triplet first asString;
				arguments: (Array with: triplet second with: state); 
				onColor: Color white offColor: Color white.
			aRow addMorphBack: aButton.
			aButton setBalloonText: triplet third].

	^ aRow! !

!MCTool methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:22'!
buttonSelected
	^ false! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:23'!
buttonSpecs
	^ #()! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 00:45'!
buttonState
	^ true! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:42'!
close
	self window delete! !

!MCTool methodsFor: 'morphic ui' stamp: 'nk 7/24/2003 13:31'!
defaultAnnotationPaneHeight 
	"Answer the receiver's preferred default height for new annotation panes."
	^ Preferences parameterAt: #defaultAnnotationPaneHeight ifAbsentPut: [25]! !

!MCTool methodsFor: 'morphic ui' stamp: 'avi 2/18/2004 19:56'!
defaultBackgroundColor 
	^ (Color r: 0.627 g: 0.69 b: 0.976)! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:22'!
defaultButtonPaneHeight
	"Answer the user's preferred default height for new button panes."

	^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:10'!
defaultExtent
	^ 500@500! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:11'!
defaultLabel
	^ self class name! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:33'!
fillMenu: aMenu fromSpecs: anArray
	anArray do:
		[:pair |
		aMenu add: pair first target: self selector: pair second].
	^ aMenu! !

!MCTool methodsFor: 'morphic ui' stamp: 'bf 3/16/2005 14:48'!
findListMorph: aSymbol
	^ morph submorphs detect: [:ea | (ea respondsTo: #getListSelector) and: [ea getListSelector = aSymbol]] ifNone: []! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 8/24/2003 20:15'!
findTextMorph: aSymbol
	^ morph submorphs detect: [:ea | (ea respondsTo: #getTextSelector) and: [ea getTextSelector = aSymbol]] ifNone: []! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:23'!
getMenu: aMenu
	^aMenu! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:36'!
label
	^ label ifNil: [self defaultLabel]! !

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
label: aString
	label := aString! !

!MCTool methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 17:30'!
listMorph: listSymbol
	^ self
		listMorph: (listSymbol, 'List') asSymbol
		selection: (listSymbol, 'Selection') asSymbol
		menu: (listSymbol, 'ListMenu:') asSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 17:03'!
listMorph: listSymbol keystroke: keystrokeSymbol
	^ (self
		listMorph: (listSymbol, 'List') asSymbol
		selection: (listSymbol, 'Selection') asSymbol
		menu: (listSymbol, 'ListMenu:') asSymbol)
		keystrokeActionSelector: keystrokeSymbol;
		yourself! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:46'!
listMorph: listSymbol selection: selectionSymbol
	^ PluggableListMorph
		on: self
		list: listSymbol
		selected: selectionSymbol
		changeSelected: (selectionSymbol, ':') asSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:46'!
listMorph: listSymbol selection: selectionSymbol menu: menuSymbol
	^ PluggableListMorph
		on: self
		list: listSymbol
		selected: selectionSymbol
		changeSelected: (selectionSymbol, ':') asSymbol
		menu: menuSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 16:50'!
listMorph: listSymbol selection: selectionSymbol menu: menuSymbol keystroke: keystrokeSymbol
	^ (PluggableListMorph
		on: self
		list: listSymbol
		selected: selectionSymbol
		changeSelected: (selectionSymbol, ':') asSymbol
		menu: menuSymbol)
		keystrokeActionSelector: keystrokeSymbol;
		yourself! !

!MCTool methodsFor: 'morphic ui' stamp: 'avi 9/11/2004 16:19'!
multiListMorph: listSymbol selection: selectionSymbol listSelection: listSelectionSymbol menu: menuSymbol
	^ PluggableListMorphOfMany
		on: self
		list: listSymbol
		primarySelection: selectionSymbol
		changePrimarySelection: (selectionSymbol, ':') asSymbol
		listSelection: listSelectionSymbol
		changeListSelection: (listSelectionSymbol, 'put:') asSymbol
		menu: menuSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: 'lr 10/5/2003 09:09'!
performButtonAction: anActionSelector enabled: anEnabledSelector
	(self perform: anEnabledSelector) 
		ifTrue: [ self perform: anActionSelector ]! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:18'!
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]! !

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
show
	modal := false.
	Smalltalk at: #ToolBuilder ifPresent: [:tb | tb open: self. ^ self].
	^self window openInWorldExtent: self defaultExtent; yourself! !

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
showLabelled: labelString
	modal := false.
	self label: labelString.
	^(self window)
		openInWorldExtent: self defaultExtent;
		yourself! !

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
showModally
	modal := true.
	self window openInWorldExtent: (400@400).
	[self window world notNil] whileTrue: [
		self window outermostWorldMorph doOneCycle.
	].
	morph := nil.
	^ modalValue! !

!MCTool methodsFor: 'morphic ui' stamp: 'nk 6/12/2004 14:11'!
step
! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:36'!
textMorph: aSymbol
	^ PluggableTextMorph on: self text: aSymbol accept: (aSymbol, ':') asSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:27'!
treeMorph: listSymbol
	^ self
		treeMorph: (listSymbol, 'Tree') asSymbol
		selection: (listSymbol, 'SelectionWrapper') asSymbol
		menu: (listSymbol, 'TreeMenu:') asSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:43'!
treeMorph: listSymbol selection: selectionSymbol menu: menuSymbol
	^ SimpleHierarchicalListMorph
		on: self
		list: listSymbol
		selected: selectionSymbol
		changeSelected: (selectionSymbol, ':') asSymbol
		menu: menuSymbol
		keystroke: nil! !

!MCTool methodsFor: 'morphic ui' stamp: 'avi 3/6/2005 22:31'!
treeOrListMorph: aSymbol
	^ self treeMorph: aSymbol! !

!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:40'!
widgetSpecs
	^ #()! !

!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
window
	^ morph ifNil: [morph := self buildWindow]! !

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

MCTool class
	instanceVariableNames: ''!
Object subclass: #MCToolWindowBuilder
	instanceVariableNames: 'builder window currentFrame tool'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:03'!
build
	^ builder build: window! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:04'!
buttonRow
	^ self buttonRow: tool buttonSpecs! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
buttonRow: specArray
	| panel button |
	panel := builder pluggablePanelSpec new.
	panel children: OrderedCollection new.
	specArray do:
		[:spec |
		
		button := builder pluggableButtonSpec new.
		button model: tool.
		button label: spec first asString.
		button action: spec second.
		button help: spec third.
		button enabled: (spec at: 4 ifAbsent: [#buttonEnabled]).
		button state: (spec at: 5 ifAbsent: [#buttonSelected]).
		panel children add: button].
	panel layout: #horizontal.
	panel frame: currentFrame.
	window children add: panel! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
frame: aLayoutFrame
	currentFrame := aLayoutFrame! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithBuilder: aBuilder tool: aTool
	builder := aBuilder.
	tool := aTool.
	window := builder pluggableWindowSpec new.
	window children: OrderedCollection new.
	window label: tool label asString.
	window model: tool.
	window extent: tool defaultExtent.! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:04'!
listMorph: listSymbol
	^ self
		listMorph: (listSymbol, 'List') asSymbol
		selection: (listSymbol, 'Selection') asSymbol
		menu: (listSymbol, 'ListMenu:') asSymbol! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:04'!
listMorph: listSymbol keystroke: keystrokeSymbol
	^ (self
		listMorph: (listSymbol, 'List') asSymbol
		selection: (listSymbol, 'Selection') asSymbol
		menu: (listSymbol, 'ListMenu:') asSymbol)
		keystrokeActionSelector: keystrokeSymbol;
		yourself! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:15'!
listMorph: listSymbol selection: selectionSymbol
	self listMorph: listSymbol selection: selectionSymbol menu: nil! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:16'!
listMorph: listSymbol selection: selectionSymbol menu: menuSymbol
	self listMorph: listSymbol selection: selectionSymbol menu: menuSymbol keystroke: nil! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2005 17:51'!
listMorph: listSymbol selection: selectionSymbol menu: menuSymbol keystroke: keystrokeSymbol
	| list |
	list := builder pluggableListSpec new.
	list 
		model: tool;
		list: listSymbol; 
		getIndex: selectionSymbol; 
		setIndex: (selectionSymbol, ':') asSymbol;
		frame: currentFrame.
	menuSymbol ifNotNil: [list menu: menuSymbol].
	keystrokeSymbol ifNotNil: [list keyPress: keystrokeSymbol].
	window children add: list
! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2005 17:52'!
multiListMorph: listSymbol selection: selectionSymbol listSelection: listSelectionSymbol menu: menuSymbol
	| list |
	list := builder pluggableMultiSelectionListSpec new.
	list 
		model: tool;
		list: listSymbol; 
		getIndex: selectionSymbol; 
		setIndex: (selectionSymbol, ':') asSymbol;
		getSelectionList: listSelectionSymbol;
		setSelectionList: (listSelectionSymbol, 'put:') asSymbol;
		frame: currentFrame.
	menuSymbol ifNotNil: [list menu: menuSymbol].
	window children add: list
! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2005 17:52'!
textMorph: aSymbol
	| text |
	text := builder pluggableTextSpec new.
	text 
		model: tool;
		getText: aSymbol; 
		setText: (aSymbol, ':') asSymbol;
		frame: currentFrame.
	window children add: text! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:05'!
treeMorph: listSymbol
	^ self
		treeMorph: (listSymbol, 'Tree') asSymbol
		selection: (listSymbol, 'SelectionWrapper') asSymbol
		menu: (listSymbol, 'TreeMenu:') asSymbol! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2005 17:52'!
treeMorph: listSymbol selection: selectionSymbol menu: menuSymbol
	self notYetImplemented! !

!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 3/6/2005 22:31'!
treeOrListMorph: listSymbol
	^ self listMorph: listSymbol! !

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

MCToolWindowBuilder class
	instanceVariableNames: ''!

!MCToolWindowBuilder class methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:02'!
builder: aBuilder tool: aTool
	^ self basicNew initializeWithBuilder: aBuilder tool: aTool! !
MCClassDefinition subclass: #MCTraitDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCTraitDefinition methodsFor: 'accessing' stamp: 'al 6/5/2006 14:05'!
classTraitCompositionString
	^self traitComposition ifNil: ['{}'].! !

!MCTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:29'!
traitComposition
	^traitComposition! !


!MCTraitDefinition methodsFor: 'comparing' stamp: 'al 6/5/2006 14:14'!
hash
	| hash |
	hash := String stringHash: name initialHash: 0.
	hash := String stringHash: self traitCompositionString initialHash: hash.
	hash := String stringHash: (category ifNil: ['']) initialHash: hash.
	^ hash
! !

!MCTraitDefinition methodsFor: 'comparing' stamp: 'al 6/5/2006 14:13'!
requirements
	"Assuming that traits in a composition can be identified by
	testing for the first character beeing an uppercase character
	(and thus not a special character such as {, # etc.)"

	| tokens traitNames |
	self hasTraitComposition ifFalse: [ ^Array new ].
	tokens := Scanner new scanTokens: self traitComposition.
	traitNames := tokens select: [:each | each first isUppercase].
	^traitNames asArray! !


!MCTraitDefinition methodsFor: 'initializing' stamp: 'al 6/5/2006 14:14'!
initializeWithName: classNameString 
	traitComposition:  traitCompositionString
	category:  categoryString
	comment:  commentString  
	commentStamp:   commentStampString
					
		name := classNameString asSymbol.
		traitComposition := traitCompositionString.
	     category := categoryString.
		comment := commentString withSqueakLineEndings.
		commentStamp :=  commentStampString ifNil: [self defaultCommentStamp]
! !


!MCTraitDefinition methodsFor: 'installing' stamp: 'al 10/9/2005 20:28'!
load
	 self createClass ifNotNilDo: [:trait |
		self hasComment ifTrue: [trait classComment: comment stamp: commentStamp]]! !


!MCTraitDefinition methodsFor: 'printing' stamp: 'al 6/5/2006 14:15'!
printDefinitionOn: stream
	stream nextPutAll: 'Trait named: #', self className;
		 cr;
		 tab;
		 nextPutAll: 'uses: ';
		 nextPutAll: self traitCompositionString;
		 cr;
		 tab;
		 nextPutAll: 'category: ';
		 store: self category asString
! !


!MCTraitDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 20:28'!
hasClassInstanceVariables
	^ false

! !

!MCTraitDefinition methodsFor: 'testing' stamp: 'al 6/5/2006 14:13'!
hasTraitComposition
	^self traitCompositionString ~= '{}'! !


!MCTraitDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 20:28'!
accept: aVisitor
	^ aVisitor visitTraitDefinition: self
! !

!MCTraitDefinition methodsFor: 'visiting' stamp: 'al 6/5/2006 14:15'!
createClass
	^Trait
		named: name
		uses: (Compiler evaluate: self traitCompositionString)
		category: category
		
! !

!MCTraitDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 21:58'!
= aDefinition
	self flag: #traits. "Ugly we harcoded the super superclass method.  We will have to refactor the definition hierarchy"
	
	^ (self isRevisionOf: aDefinition)
		and: [self traitCompositionString = aDefinition traitCompositionString]
		and: [category = aDefinition category]
		and: [comment = aDefinition comment]! !

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

MCTraitDefinition class
	instanceVariableNames: ''!

!MCTraitDefinition class methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:28'!
name: classNameString traitComposition:  traitCompositionString category:  categoryString comment:  commentString commentStamp:   commentStamp
	^ self instanceLike:
		(self new initializeWithName: classNameString 
			traitComposition:  traitCompositionString
			category:  categoryString
			comment:  commentString  
			commentStamp:   commentStamp)
! !
MCDoItParser subclass: #MCTraitParser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCTraitParser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
addDefinitionsTo: aCollection
	| tokens  definition traitCompositionString |
	tokens := Scanner new scanTokens: source.
	traitCompositionString := ((ReadStream on: source)
		match: 'uses:';
		upToAll: 'category:') withBlanksTrimmed.
	definition := MCTraitDefinition
		name: (tokens at: 3) 
		traitComposition: traitCompositionString
		category:  tokens last
		comment:  ''  
		commentStamp:   ''.
	aCollection add: definition.! !

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

MCTraitParser class
	instanceVariableNames: ''!

!MCTraitParser class methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 21:09'!
pattern
	^ 'Trait named:*'! !
Object subclass: #MCVariableDefinition
	instanceVariableNames: 'name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Modeling'!

!MCVariableDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 05:57'!
name
	^ name! !

!MCVariableDefinition methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
name: aString
	name := aString! !


!MCVariableDefinition methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 14:56'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(; nextPutAll: self name; nextPut: $)! !


!MCVariableDefinition methodsFor: 'comparing' stamp: 'cwp 7/7/2003 23:02'!
hash
	^ name hash! !

!MCVariableDefinition methodsFor: 'comparing' stamp: 'cwp 7/7/2003 23:02'!
= other
	^ (self species = other species)
		and: [self name = other name]! !


!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:31'!
isClassInstanceVariable
	^ false! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:08'!
isClassInstanceVariableDefinition
	^ false! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:30'!
isClassVariable
	^ false! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:31'!
isInstanceVariable
	^ false! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:10'!
isInstanceVariableDefinition
	^ false! !

!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:51'!
isPoolImport
	^ false! !

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

MCVariableDefinition class
	instanceVariableNames: ''!

!MCVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:18'!
name: aString
	^ self new name: aString
	! !
Object subclass: #MCVersion
	instanceVariableNames: 'package info snapshot dependencies'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCVersion methodsFor: 'accessing' stamp: 'avi 2/13/2004 22:42'!
changes
	^ self snapshot patchRelativeToBase: package snapshot! !

!MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 00:24'!
dependencies
	^ dependencies ifNil: [#()]! !

!MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 12:44'!
fileName
	^ info name, '.', self writerClass extension! !

!MCVersion methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:28'!
info
	^ info! !

!MCVersion methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:19'!
package
	^ package! !

!MCVersion methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:10'!
snapshot
	^ snapshot! !

!MCVersion methodsFor: 'accessing' stamp: 'avi 1/20/2004 16:07'!
summary
	^ String streamContents:
		[:s |
		s nextPutAll: info summaryHeader.
		(dependencies isNil or: [dependencies isEmpty]) ifFalse:
			[s cr; nextPutAll: 'Dependencies: '.
			dependencies
				do: [:ea | s nextPutAll: ea versionInfo name]
				separatedBy: [s nextPutAll: ', ']].
		s cr; cr; nextPutAll: info message]! !

!MCVersion methodsFor: 'accessing' stamp: 'avi 2/12/2004 19:38'!
workingCopy
	^ package workingCopy! !

!MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 12:44'!
writerClass
	^ MCMczWriter ! !


!MCVersion methodsFor: 'actions' stamp: 'avi 10/9/2003 13:00'!
addToCache
	MCCacheRepository default storeVersion: self! !

!MCVersion methodsFor: 'actions' stamp: 'avi 2/12/2004 19:37'!
adopt
	self workingCopy adopt: self! !

!MCVersion methodsFor: 'actions' stamp: 'bf 3/22/2005 22:12'!
browse
	(MCSnapshotBrowser forSnapshot: self snapshot)
		showLabelled: 'Snapshot of ', self fileName! !

!MCVersion methodsFor: 'actions' stamp: 'avi 1/22/2004 12:44'!
fileOutOn: aStream
	self writerClass fileOut: self on: aStream! !

!MCVersion methodsFor: 'actions' stamp: 'avi 1/24/2004 20:13'!
load
	MCVersionLoader loadVersion: self! !

!MCVersion methodsFor: 'actions' stamp: 'abc 2/13/2004 15:58'!
merge
	MCVersionMerger mergeVersion: self! !

!MCVersion methodsFor: 'actions' stamp: 'ab 7/12/2003 00:19'!
open
	(MCVersionInspector new version: self) show! !


!MCVersion methodsFor: 'converting' stamp: 'avi 2/19/2004 21:00'!
asDiffAgainst: aVersion
	aVersion info = self info ifTrue: [self error: 'Cannot diff against self!!'].
	^ MCDiffyVersion
		package: self package
		info: self info
		snapshot: self snapshot
		dependencies: self dependencies
		baseVersion: aVersion! !


!MCVersion methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'!
allAvailableDependenciesDo: aBlock
	| version |
	self dependencies do:
		[:ea |
		[version := ea resolve.
		version allAvailableDependenciesDo: aBlock.
		aBlock value: version]
			on: Error do: []]! !

!MCVersion methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 11:58'!
allDependenciesDo: aBlock
	self allDependenciesDo: aBlock ifUnresolved: [:ignored | true]! !

!MCVersion methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'!
allDependenciesDo: aBlock ifUnresolved: failBlock
	| dict |
	dict := Dictionary new.
	self allDependenciesNotIn: dict do: aBlock ifUnresolved: failBlock! !

!MCVersion methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 14:24'!
allDependenciesNotIn: aDictionary do: aBlock ifUnresolved: failBlock
	| version |
	self dependencies do: 
		[:ea | 
		version := aDictionary at: ea ifAbsent: [ea resolve].
		version 
			ifNil: [failBlock value: ea]
			ifNotNil: [(aDictionary includes: version) ifFalse:
						[aDictionary at: ea put: version.
						version 
							allDependenciesNotIn: aDictionary 
							do: aBlock
							ifUnresolved: failBlock.
						aBlock value: version]]]! !

!MCVersion methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 14:24'!
withAllDependenciesDo: aBlock
	self allDependenciesDo: aBlock ifUnresolved: [:ignored].
	aBlock value: self! !

!MCVersion methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'!
withAllDependenciesDo: aBlock ifUnresolved: failBlock
	| dict |
	dict := Dictionary new.
	self allDependenciesNotIn: dict do: aBlock ifUnresolved: failBlock.
	aBlock value: self! !


!MCVersion methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection
	package := aPackage.
	info := aVersionInfo.
	snapshot := aSnapshot.
	dependencies := aCollection.
	self addToCache.! !

!MCVersion methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
setPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection
	package := aPackage.
	info := aVersionInfo.
	snapshot := aSnapshot.
	dependencies := aCollection! !


!MCVersion methodsFor: 'printing' stamp: 'nk 3/8/2004 23:54'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: self info name.
	aStream nextPut: $).! !


!MCVersion methodsFor: 'testing' stamp: 'bf 5/23/2005 15:43'!
canOptimizeLoading
	"Answer wether I can provide a patch for the working copy without the usual diff pass"
	^false! !

!MCVersion methodsFor: 'testing' stamp: 'bf 3/22/2005 23:00'!
isCacheable
	^true! !

!MCVersion methodsFor: 'testing' stamp: 'avi 2/13/2004 23:24'!
isDiffy
	^ false! !

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

MCVersion class
	instanceVariableNames: ''!

!MCVersion class methodsFor: 'instance creation' stamp: 'ab 7/7/2003 16:13'!
package: aPackage
	^ self package: aPackage info: MCVersionInfo new! !

!MCVersion class methodsFor: 'instance creation' stamp: 'ab 7/7/2003 16:13'!
package: aPackage info: aVersionInfo
	^ self package: aPackage info: aVersionInfo snapshot: aPackage snapshot! !

!MCVersion class methodsFor: 'instance creation' stamp: 'cwp 11/7/2004 13:02'!
package: aPackage info: aVersionInfo snapshot: aSnapshot
	^ self package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: #()! !

!MCVersion class methodsFor: 'instance creation' stamp: 'avi 1/19/2004 13:11'!
package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection
	^ self new initializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection! !
Object subclass: #MCVersionDependency
	instanceVariableNames: 'package versionInfo'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCVersionDependency methodsFor: 'accessing' stamp: 'avi 1/19/2004 15:40'!
package
	^ package! !

!MCVersionDependency methodsFor: 'accessing' stamp: 'avi 2/12/2004 19:38'!
repositoryGroup
	^ self package workingCopy repositoryGroup! !

!MCVersionDependency methodsFor: 'accessing' stamp: 'avi 1/19/2004 15:40'!
versionInfo
	^ versionInfo! !


!MCVersionDependency methodsFor: 'comparing' stamp: 'avi 1/19/2004 16:06'!
hash
	^ versionInfo hash! !

!MCVersionDependency methodsFor: 'comparing' stamp: 'avi 1/19/2004 16:12'!
= other
	^ other species = self species
		and: [other versionInfo = versionInfo
				and: [other package = package]]! !


!MCVersionDependency methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithPackage: aPackage info: aVersionInfo
	package := aPackage.
	versionInfo := aVersionInfo! !


!MCVersionDependency methodsFor: 'resolving' stamp: 'nk 6/13/2004 19:21'!
resolve
	^ self repositoryGroup
		versionWithInfo: versionInfo
		ifNone: [ MCRepositoryGroup default versionWithInfo: versionInfo ifNone: []]! !


!MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'!
isCurrent
	^ package hasWorkingCopy
		and: [self isFulfilled
			and: [package workingCopy modified not]]! !

!MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'!
isFulfilled
	^package hasWorkingCopy
		and: [self isFulfilledBy: package workingCopy ancestry]! !

!MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'!
isFulfilledByAncestors
	^ package hasWorkingCopy
		and: [self isFulfilledByAncestorsOf: package workingCopy ancestry]! !

!MCVersionDependency methodsFor: 'testing' stamp: 'nk 7/13/2004 08:45'!
isFulfilledByAncestorsOf: anAncestry
	^ anAncestry hasAncestor: versionInfo! !

!MCVersionDependency methodsFor: 'testing' stamp: 'avi 3/4/2004 00:34'!
isFulfilledBy: anAncestry
	^ anAncestry ancestors includes: versionInfo! !

!MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'!
isOlder
	"Answer true if I represent an older version of a package that is loaded."
	^ package hasWorkingCopy
		and: [self isFulfilled not
			and: [ self isFulfilledByAncestors
				and: [package workingCopy modified not]]]! !

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

MCVersionDependency class
	instanceVariableNames: ''!

!MCVersionDependency class methodsFor: 'as yet unclassified' stamp: 'avi 1/19/2004 13:13'!
package: aPackage info: aVersionInfo
	^ self basicNew initializeWithPackage: aPackage info: aVersionInfo! !
MCTool subclass: #MCVersionHistoryBrowser
	instanceVariableNames: 'ancestry index repositoryGroup package infos'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
ancestry: anAncestry
	ancestry := anAncestry! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:10'!
baseSnapshot
	^ self snapshotForInfo: ancestry! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:41'!
index
	"Answer the value of index"

	^ index! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
index: anObject
	"Set the value of index"

	index := anObject! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
infos
	^ infos ifNil: [infos := ancestry withBreadthFirstAncestors]! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:10'!
list
	^ self infos collect: [:ea | ea name]! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
package: aMCPackage
	package := aMCPackage! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/7/2003 21:27'!
repositoryGroup
	^ MCRepositoryGroup default! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:09'!
selectedInfo
	^ self infos at: self selection ifAbsent: [nil]! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:39'!
selectedSnapshot
	^ self snapshotForInfo: self selectedInfo! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 7/11/2003 23:24'!
selection
	^ index ifNil: [0]! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
selection: aNumber
	index := aNumber.
	self changed: #selection; changed: #summary! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:38'!
snapshotForInfo: aVersionInfo
	^ (self repositoryGroup versionWithInfo: aVersionInfo) snapshot! !

!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
summary
	| selInfo |
	selInfo := self selectedInfo.
	^ selInfo 
		ifNil: ['']
		ifNotNil: [selInfo summary]! !


!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:41'!
defaultExtent
	^ 440@169.
	! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:09'!
defaultLabel
	^ ancestry name, ' History'! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:09'!
getMenu: aMenu
	index < 2 ifTrue: [^ aMenu].
	self fillMenu: aMenu fromSpecs: 
		(Array
			with: (Array with: 'view changes -> ', ancestry name with: #viewChanges)
			with: #('spawn history' spawnHistory)).
	^ aMenu! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:10'!
spawnHistory
	MCVersionHistoryBrowser new
		ancestry: self selectedInfo;
		package: package;
		show! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
viewChanges
	"Note that the patchLabel will be parsed in MCPatchBrowser>>installSelection, so don't translate it!!"
	| patch patchLabel |
	patchLabel := 'changes between {1} and {2}' format: { self selectedInfo name. ancestry name }.
	patch := self baseSnapshot patchRelativeToBase: self selectedSnapshot.
	(MCPatchBrowser forPatch: patch) label: patchLabel; show! !

!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'nk 7/28/2003 18:05'!
widgetSpecs
	^ #(
		((listMorph:selection:menu: list selection getMenu:) (0 0 0.3 1))
		((textMorph: summary) (0.3 0 1 1))
	 	)! !

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

MCVersionHistoryBrowser class
	instanceVariableNames: ''!
MCAncestry subclass: #MCVersionInfo
	instanceVariableNames: 'id name message date time author'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!
!MCVersionInfo commentStamp: '<historical>' prior: 0!
Adds to the record of ancestry, other identifying details.!


!MCVersionInfo methodsFor: 'accessing' stamp: 'ab 7/12/2003 00:04'!
message
	^ message ifNil: ['']! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'ab 7/11/2003 23:33'!
name
	^ name ifNil: ['<working copy>']! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'avi 1/20/2004 16:08'!
summary
	^ String streamContents:
		[:s |
		s
			nextPutAll: self summaryHeader; cr; cr;
			nextPutAll: self message.
		]! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'avi 9/14/2004 15:22'!
summaryHeader
	^ String streamContents:
		[:s |
		s
			nextPutAll: 'Name: '; nextPutAll: self name; cr.
		date ifNotNil:
			[s
				nextPutAll: 'Author: '; nextPutAll: author; cr;
				nextPutAll: 'Time: '; nextPutAll:  date asString, ', ', time asString; cr].
		id ifNotNil:
			[s nextPutAll: 'UUID: '; nextPutAll: id asString; cr].
		s
			nextPutAll: 'Ancestors: '; nextPutAll: self ancestorString.
		self stepChildren isEmpty ifFalse:
			[s cr; nextPutAll: 'Backported From: '; nextPutAll: self stepChildrenString].
		]! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'avi 1/22/2004 16:45'!
timeStamp
	^ TimeStamp date: date time: time! !

!MCVersionInfo methodsFor: 'accessing' stamp: 'avi 9/17/2003 11:24'!
timeString
	^ date asString, ', ', time asString! !


!MCVersionInfo methodsFor: 'comparing' stamp: 'ab 7/5/2003 14:09'!
hash
	^ id hash! !

!MCVersionInfo methodsFor: 'comparing' stamp: 'ab 7/5/2003 14:23'!
= other
	^ other species = self species
		and: [other hasID: id]! !


!MCVersionInfo methodsFor: 'converting' stamp: 'nk 1/23/2004 21:09'!
asDictionary
	^ Dictionary new
		at: #name put: name;
		at: #id put: id;
		at: #message put: message;
		at: #date put: date;
		at: #time put: time;
		at: #author put: author;
		at: #ancestors put: (self ancestors collect: [:a | a asDictionary]);
		yourself! !


!MCVersionInfo methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithName: vName id: aUUID message: aString date: aDate time: aTime author: initials ancestors: aCollection stepChildren: stepCollection
	name := vName.
	id := aUUID.
	message := aString.
	date := aDate.
	time := aTime.
	author := initials.
	ancestors :=  aCollection.
	stepChildren := stepCollection! !


!MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'!
author
	^ author! !

!MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'!
date
	^ date! !

!MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:24'!
id
	^ id ! !

!MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'!
time
	^ time! !


!MCVersionInfo methodsFor: 'printing' stamp: 'ab 7/5/2003 18:00'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(; nextPutAll: self name; nextPut: $)
	! !


!MCVersionInfo methodsFor: 'private' stamp: 'ab 7/5/2003 14:10'!
hasID: aUUID
	^ id = aUUID! !

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

MCVersionInfo class
	instanceVariableNames: ''!

!MCVersionInfo class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:44'!
name: vName id: id message: message date: date time: time author: author ancestors: ancestors
	^ self 
		name: vName
		id: id
		message: message
		date: date
		time: time
		author: author
		ancestors: ancestors
		stepChildren: #()! !

!MCVersionInfo class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:43'!
name: vName id: id message: message date: date time: time author: author ancestors: ancestors stepChildren: stepChildren
	^ self new
		initializeWithName: vName
		id: id
		message: message
		date: date
		time: time
		author: author
		ancestors: ancestors
		stepChildren: stepChildren! !
MCWriter subclass: #MCVersionInfoWriter
	instanceVariableNames: 'written'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCVersionInfoWriter methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 21:10'!
isWritten: aVersionInfo
	^ self written includes: aVersionInfo! !

!MCVersionInfoWriter methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 16:53'!
writeVersionInfo: aVersionInfo
	(self isWritten: aVersionInfo)
		ifTrue: [^ stream nextPutAll: '(id ', aVersionInfo id asString printString, ')'].
	stream nextPut: $(.
	#(name message id date time author) 
		do: [:sel | 
			stream nextPutAll: sel.
			stream nextPut: $ .
			((aVersionInfo perform: sel) ifNil: ['']) asString printOn: stream.
			stream nextPut: $ ].
	stream nextPutAll: 'ancestors ('.
	aVersionInfo ancestors do: [:ea | self writeVersionInfo: ea].
	stream nextPutAll: ') stepChildren ('.
	aVersionInfo stepChildren do: [:ea | self writeVersionInfo: ea].
	stream nextPutAll: '))'.
	self wrote: aVersionInfo! !

!MCVersionInfoWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
written
	^ written ifNil: [written := Set new]! !

!MCVersionInfoWriter methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 21:10'!
wrote: aVersionInfo
	self written add: aVersionInfo! !

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

MCVersionInfoWriter class
	instanceVariableNames: ''!
MCTool subclass: #MCVersionInspector
	instanceVariableNames: 'version'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:19'!
adopt
	(self confirm:
'Modifying ancestry can be dangerous unless you know
what you are doing.  Are you sure you want to adopt
',self version info name, ' as an ancestor of your working copy?')
		ifTrue: [self version adopt]! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'bf 3/22/2005 22:12'!
browse
	self version browse! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'nk 4/17/2004 10:05'!
changes
	(MCPatchBrowser forPatch: self version changes)
		showLabelled: 'Changes from ', self version info name! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
diff
	| ancestorVersion |
	self pickAncestor ifNotNilDo:
		[:ancestor |
		ancestorVersion := self version workingCopy repositoryGroup versionWithInfo: ancestor.
		(self version asDiffAgainst: ancestorVersion) open]! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'lr 9/26/2003 20:15'!
hasVersion
	^version notNil! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:14'!
history
	(MCVersionHistoryBrowser new ancestry: self versionInfo) show! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'bf 3/14/2005 15:32'!
load
	Cursor wait showWhile: [self version load]! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:19'!
merge
	self version merge! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:18'!
save
	self pickRepository ifNotNilDo:
		[:ea |
		ea storeVersion: self version]! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:16'!
summary
	^self hasVersion
		ifTrue: [ self versionSummary ]
		ifFalse: [ String new ]! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:19'!
version
	^ version! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:16'!
versionInfo
	^ self version info! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:16'!
versionSummary
	^ self version summary! !

!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
version: aVersion
	version := aVersion! !


!MCVersionInspector methodsFor: 'morphic ui' stamp: 'Rik 12/17/2004
06:07'!
buttonSpecs
       ^ #((Browse browse 'Browse this version' hasVersion)
               (History history 'Browse the history of this version' hasVersion)
               (Changes changes 'Browse the changes this version would make to the
image' hasVersion)
               (Load load 'Load this version into the image' hasVersion)
               (Merge merge 'Merge this version into the image' hasVersion)
               (Adopt adopt 'Adopt this version as an ancestor of your working copy'
hasVersion)
               (Copy save 'Copy this version to another repository' hasVersion)
               (Diff diff 'Create an equivalent version based on an earlier release'
hasVersion))! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 8/31/2003 00:45'!
defaultExtent
	^ 400@200! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:18'!
defaultLabel
	^ 'Version: ', self version info name! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
pickAncestor
	| index versions |
	versions := self version info breadthFirstAncestors.
	index := (PopUpMenu labelArray: (versions collect: [:ea | ea name]))
				startUpWithCaption: 'Ancestor:'.
	^ index = 0 ifFalse: [versions at: index]! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
pickRepository
	| index |
	index := (PopUpMenu labelArray: (self repositories collect: [:ea | ea description]))
				startUpWithCaption: 'Repository:'.
	^ index = 0 ifFalse: [self repositories at: index]! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 8/31/2003 00:44'!
repositories
	^ MCRepositoryGroup default repositories! !

!MCVersionInspector methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 18:43'!
widgetSpecs
	^ #(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((textMorph: summary) (0 0 1 1) (0 30 0 0))
		)! !

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

MCVersionInspector class
	instanceVariableNames: ''!
Object subclass: #MCVersionLoader
	instanceVariableNames: 'versions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Loading'!

!MCVersionLoader methodsFor: 'checking' stamp: 'stephaneducasse 2/4/2006 20:47'!
checkForModifications
	| modifications |
	modifications := versions select: [:ea | ea package workingCopy modified].
	modifications isEmpty ifFalse: [self warnAboutLosingChangesTo: modifications].! !

!MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:00'!
checkIfDepIsOlder: aDependency
	^ aDependency isOlder not 
		or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! !

!MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:06'!
confirmMissingDependency: aDependency
	| name |
	name := aDependency versionInfo name.
	(self confirm: 'Can''t find dependency ', name, '. ignore?')
		ifFalse: [self error: 'Can''t find dependency ', name]! !

!MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:02'!
depAgeIsOk: aDependency
	^ aDependency isOlder not 
		or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! !

!MCVersionLoader methodsFor: 'checking' stamp: 'avi 1/24/2004 20:17'!
warnAboutLosingChangesTo: versionCollection
	self notify: (String streamContents: [:s |
		s nextPutAll: 'You are about to load new versions of the following packages that have unsaved changes in the image.  If you continue, you will lose these changes.'; cr.
		versionCollection do:
			[:ea |
			s cr; space; space; nextPutAll: ea package name]])! !


!MCVersionLoader methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	versions := OrderedCollection new! !


!MCVersionLoader methodsFor: 'loading' stamp: 'cwp 11/7/2004 17:06'!
addDependency: aDependency
	| dep |
	aDependency isCurrent ifTrue: [^ self].
	(self depAgeIsOk: aDependency) ifFalse: [^ self].
	dep := aDependency resolve.
	dep
		ifNil: [self confirmMissingDependency: aDependency]
		ifNotNil: [(versions includes: dep) ifFalse: [self addVersion: dep]]! !

!MCVersionLoader methodsFor: 'loading' stamp: 'cwp 11/7/2004 17:04'!
addVersion: aVersion
	aVersion dependencies do: [ :ea | self addDependency: ea].
	versions add: aVersion.
! !

!MCVersionLoader methodsFor: 'loading' stamp: 'stephaneducasse 2/4/2006 20:47'!
load
	| loader |
	self checkForModifications.
	loader := MCPackageLoader new.
	versions do: [:ea |
		ea canOptimizeLoading
			ifTrue: [ea patch applyTo: loader]
			ifFalse: [loader updatePackage: ea package withSnapshot: ea snapshot]].
	loader loadWithNameLike: versions first info name.
	versions do: [:ea | ea workingCopy loaded: ea]! !

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

MCVersionLoader class
	instanceVariableNames: ''!

!MCVersionLoader class methodsFor: 'as yet unclassified' stamp: 'avi 1/24/2004 20:06'!
loadVersion: aVersion
	self new
		addVersion: aVersion;
		load! !

!MCVersionLoader class methodsFor: 'as yet unclassified' stamp: 'avi 1/24/2004 19:51'!
new
	^ self basicNew initialize! !
Object subclass: #MCVersionMerger
	instanceVariableNames: 'records merger'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
addVersion: aVersion
	| dep |
	records add: (MCMergeRecord version: aVersion).
	aVersion dependencies do:
		[:ea |
		dep := ea resolve.
		(records anySatisfy: [:r | r version = dep]) ifFalse: [self addVersion: dep]]! !

!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	records := OrderedCollection new.
	merger := MCThreeWayMerger new.! !

!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 17:15'!
merge
	records do: [:ea | merger addBaseSnapshot: ea packageSnapshot].
	records do: [:ea | merger applyPatch: ea mergePatch].
	self resolveConflicts ifTrue:
		[merger load.
		records do: [:ea | ea updateWorkingCopy]].! !

!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'bf 12/5/2004 12:32'!
mergeWithNameLike: baseName
	records do: [:ea | merger addBaseSnapshot: ea packageSnapshot].
	records do: [:ea | merger applyPatch: ea mergePatch].
	self resolveConflicts ifTrue:
		[merger loadWithNameLike: baseName.
		records do: [:ea | ea updateWorkingCopy]].! !

!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'bf 4/26/2005 14:29'!
resolveConflicts
	(records allSatisfy: [:ea | ea isAncestorMerge]) ifTrue: [MCNoChangesException signal. ^ false].
	^ ((MCMergeResolutionRequest new merger: merger)
		signal: 'Merging ', records first version info name) = true! !

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

MCVersionMerger class
	instanceVariableNames: ''!

!MCVersionMerger class methodsFor: 'as yet unclassified' stamp: 'bf 12/5/2004 12:35'!
mergeVersion: aVersion
	self new
		addVersion: aVersion;
		mergeWithNameLike: aVersion info name! !

!MCVersionMerger class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:41'!
new
	^ self basicNew initialize! !
Notification subclass: #MCVersionNameAndMessageRequest
	instanceVariableNames: 'suggestion'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'ab 8/24/2003 20:39'!
defaultAction
	^ MCSaveVersionDialog new
		versionName: suggestion;
		showModally! !

!MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'ab 7/10/2003 01:07'!
suggestedName
	^ suggestion! !

!MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
suggestedName: aString
	suggestion := aString! !

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

MCVersionNameAndMessageRequest class
	instanceVariableNames: ''!
Object subclass: #MCVersionNotification
	instanceVariableNames: 'version ancestor repository changes'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 15:13'!
fromAddress
	^ 'monticello@beta4.com'! !

!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initializeWithVersion: aVersion repository: aRepository
	version := aVersion.
	repository := aRepository.
	ancestor := repository closestAncestorVersionFor: version info ifNone: []. 
	changes := ancestor
				ifNil: [#()]
				ifNotNil: [(version snapshot patchRelativeToBase: ancestor snapshot) 							operations asSortedCollection]! !

!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 15:12'!
messageText
	^ String streamContents:
		[:s |
		s nextPutAll: 'Committed to repository: ', repository description; cr; cr.
		s nextPutAll: version summary.
		changes isEmpty ifFalse:
			[s cr; cr.
			s nextPutAll: '-----------------------------------------------------'; cr.
			s nextPutAll: 'Changes since ', ancestor info name, ':'; cr.
			changes do:
			[:ea |
			s cr; nextPutAll: ea summary; cr.
			s nextPutAll: ea sourceString]]]! !

!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
messageTo: aString
	| message |
	message := MailMessage empty.
	message setField: 'from' toString: self fromAddress.
	message setField: 'to' toString: aString.
	message setField: 'subject' toString: '[MC] ', version info name.
	message body: (MIMEDocument contentType: 'text/plain' content: self messageText).
	^ message! !

!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
notify: aString
	| message |
	message := self messageTo: aString.
	SMTPClient
		deliverMailFrom: message from
		to: (Array with: message to)
		text: message text
		usingServer: MailSender smtpServer! !

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

MCVersionNotification class
	instanceVariableNames: ''!

!MCVersionNotification class methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:27'!
version: aVersion repository: aRepository
	^ self basicNew initializeWithVersion: aVersion repository: aRepository! !
MCReader subclass: #MCVersionReader
	instanceVariableNames: 'package info definitions dependencies stepChildren'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCVersionReader methodsFor: 'accessing' stamp: 'avi 1/19/2004 16:52'!
basicVersion
	^ MCVersion
		package: self package
		info: self info
		snapshot: self snapshot
		dependencies: self dependencies! !

!MCVersionReader methodsFor: 'accessing' stamp: 'avi 1/21/2004 23:10'!
definitions
	definitions ifNil: [self loadDefinitions].
	^ definitions! !

!MCVersionReader methodsFor: 'accessing' stamp: 'avi 1/19/2004 14:50'!
dependencies
	dependencies ifNil: [self loadDependencies].
	^ dependencies! !

!MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:53'!
info
	info ifNil: [self loadVersionInfo].
	^ info! !

!MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:53'!
package
	package ifNil: [self loadPackage].
	^ package! !

!MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:54'!
snapshot
	^ MCSnapshot fromDefinitions: self definitions! !

!MCVersionReader methodsFor: 'accessing' stamp: 'avi 10/9/2003 12:38'!
version
	^ self basicVersion! !


!MCVersionReader methodsFor: 'lifecycle' stamp: 'cwp 8/3/2003 18:48'!
initialize! !


!MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'!
loadDefinitions
	self subclassResponsibility ! !

!MCVersionReader methodsFor: 'loading' stamp: 'avi 1/19/2004 14:50'!
loadDependencies
	self subclassResponsibility ! !

!MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'!
loadPackage
	self subclassResponsibility ! !

!MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'!
loadVersionInfo
	self subclassResponsibility! !

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

MCVersionReader class
	instanceVariableNames: ''!

!MCVersionReader class methodsFor: 'file services' stamp: 'avi 10/15/2003 02:01'!
fileReaderServicesForFile: fullName suffix: suffix
	self isAbstract ifTrue: [^ #()].
	^ ((suffix = self extension) or: [ suffix = '*' ])
		ifTrue: [self services]
		ifFalse: [Array new: 0]
		! !

!MCVersionReader class methodsFor: 'file services' stamp: 'avi 1/24/2004 19:01'!
initialize
	"MCVersionReader initialize"
	Smalltalk 
		at: #MczInstaller
		ifPresent: [:installer | FileList unregisterFileReader: installer].
	self concreteSubclasses do: [:aClass | FileList registerFileReader: aClass].

	"get rid of AnObsoleteMCMcReader and AnObsoleteMCMcvReader"
	(FileList registeredFileReaderClasses  select: [ :ea | ea isObsolete ]) do: 
		[ :ea | FileList unregisterFileReader: ea ]
! !

!MCVersionReader class methodsFor: 'file services' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadVersionFile: fileName
	| version |
	version := self versionFromFile: fileName.
	version workingCopy repositoryGroup addRepository:
		(MCDirectoryRepository new directory:
			(FileDirectory on: (FileDirectory dirPathFor: fileName))).
	version load.
! !

!MCVersionReader class methodsFor: 'file services' stamp: 'cwp 8/1/2003 14:46'!
mergeVersionFile: fileName
	(self versionFromFile: fileName) merge! !

!MCVersionReader class methodsFor: 'file services' stamp: 'cwp 8/1/2003 14:46'!
openVersionFile: fileName
	(self versionFromFile: fileName) open! !

!MCVersionReader class methodsFor: 'file services' stamp: 'avi 1/21/2004 22:55'!
services
	^ Array 
		with: self serviceLoadVersion
		with: self serviceMergeVersion
		with: self serviceOpenVersion! !

!MCVersionReader class methodsFor: 'file services' stamp: 'cwp 8/1/2003 14:33'!
unload
	FileList unregisterFileReader: self ! !


!MCVersionReader class methodsFor: 'reading' stamp: 'stephaneducasse 2/4/2006 20:47'!
file: fileName streamDo: aBlock
	| file |
	^ 	[file := FileStream readOnlyFileNamed: fileName.
		aBlock value: file]
			ensure: [file close]! !

!MCVersionReader class methodsFor: 'reading' stamp: 'bf 3/23/2005 01:20'!
on: s fileName: f
	^ self on: s! !

!MCVersionReader class methodsFor: 'reading' stamp: 'cwp 7/31/2003 23:03'!
versionFromFile: fileName
	^ self file: fileName streamDo: [:stream | self versionFromStream: stream]! !

!MCVersionReader class methodsFor: 'reading' stamp: 'avi 1/21/2004 22:58'!
versionFromStream: aStream
	^ (self on: aStream) version! !

!MCVersionReader class methodsFor: 'reading' stamp: 'avi 1/21/2004 22:59'!
versionInfoFromStream: aStream
	^ (self on: aStream) info! !


!MCVersionReader class methodsFor: 'testing' stamp: 'cwp 8/4/2003 00:32'!
canReadFileNamed: fileName
	^ (fileName endsWith: self extension)! !


!MCVersionReader class methodsFor: '*monticello-file services' stamp: 'stephaneducasse 2/4/2006 20:47'!
loadVersionStream: stream fromDirectory: directory
	| version |
	version := self versionFromStream: stream.
	directory isRemoteDirectory ifFalse: [
	version workingCopy repositoryGroup addRepository:
		(MCDirectoryRepository new directory: directory). ].
	version load.
! !

!MCVersionReader class methodsFor: '*monticello-file services' stamp: 'nk 2/25/2005 11:17'!
mergeVersionStream: stream
	(self versionFromStream: stream) merge! !

!MCVersionReader class methodsFor: '*monticello-file services' stamp: 'nk 2/25/2005 11:12'!
openVersionFromStream: stream
	(self versionFromStream: stream) open! !


!MCVersionReader class methodsFor: '*monticello-file services-override-override' stamp: 'nk 2/25/2005 11:15'!
serviceLoadVersion
	^ (SimpleServiceEntry
		provider: self
		label: 'load version'
		selector: #loadVersionStream:fromDirectory:
		description: 'load a package version'
		buttonLabel: 'load')
		argumentGetter: [ :fileList | { fileList readOnlyStream . fileList directory } ]! !

!MCVersionReader class methodsFor: '*monticello-file services-override-override' stamp: 'nk 2/25/2005 11:16'!
serviceMergeVersion
	^ (SimpleServiceEntry
		provider: self
		label: 'merge version'
		selector: #mergeVersionStream:
		description: 'merge a package version into the image'
		buttonLabel: 'merge')
		argumentGetter: [ :fileList | fileList readOnlyStream ]! !

!MCVersionReader class methodsFor: '*monticello-file services-override-override' stamp: 'nk 2/25/2005 11:16'!
serviceOpenVersion
	^ (SimpleServiceEntry
		provider: self
		label: 'open version'
		selector: #openVersionFromStream:
		description: 'open a package version'
		buttonLabel: 'open')
		argumentGetter: [ :fileList | fileList readOnlyStream ]! !
Object subclass: #MCVersionSorter
	instanceVariableNames: 'layers depthIndex depths stepparents roots'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 14:19'!
addAllAncestorsOf: aVersionInfo to: aSet
	(aSet includes: aVersionInfo) ifTrue: [^ self].
	aSet add: aVersionInfo.
	(self knownAncestorsOf: aVersionInfo) do:
		[:ea |
		self addAllAncestorsOf: ea to: aSet]! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2003 21:30'!
addAllVersionInfos: aCollection
	aCollection do: [:ea | self addVersionInfo: ea]! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
addToCurrentLayer: aVersionInfo
	| layer |
	layer := layers at: depthIndex.
	(layer includes: aVersionInfo) ifFalse:
		[depths at: aVersionInfo ifPresent:
			[:i |
			i < depthIndex
				ifTrue: [(layers at: i) remove: aVersionInfo]
				ifFalse: [^ false]].
		layer add: aVersionInfo.
		depths at: aVersionInfo put: depthIndex.
		^ true].
	^ false ! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:49'!
addVersionInfo: aVersionInfo
	roots add: aVersionInfo.
	self registerStepChildrenOf: aVersionInfo seen: Set new! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
allAncestorsOf: aVersionInfo
	| all |
	all := Set new.
	self addAllAncestorsOf: aVersionInfo to: all.
	^ all! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	stepparents := Dictionary new.
	roots := OrderedCollection new.! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 14:37'!
knownAncestorsOf: aVersionInfo
	^ aVersionInfo ancestors, (self stepParentsOf: aVersionInfo) asArray! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'ab 8/17/2003 15:53'!
layers
	^ layers! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
popLayer
	depthIndex := depthIndex - 1! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:39'!
processVersionInfo: aVersionInfo
	(self addToCurrentLayer: aVersionInfo) ifTrue:
		[self pushLayer.
		(self knownAncestorsOf: aVersionInfo) do: [:ea | self processVersionInfo: ea].
		self popLayer]
! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
pushLayer
	depthIndex := depthIndex + 1.
	depthIndex > layers size ifTrue: [layers add: OrderedCollection new].
	! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 14:34'!
registerStepChildrenOf: aVersionInfo seen: aSet
	(aSet includes: aVersionInfo) ifTrue: [^ self].
	aSet add: aVersionInfo.
	aVersionInfo stepChildren do: [:ea | (self stepParentsOf: ea) add: aVersionInfo].
	aVersionInfo ancestors do: [:ea | self registerStepChildrenOf: ea seen: aSet].! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
sortedVersionInfos
	layers := OrderedCollection with: OrderedCollection new.
	depthIndex := 1.
	depths := Dictionary new.
	roots do: [:ea | self processVersionInfo: ea].
	^ layers gather: [:ea | ea]! !

!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:40'!
stepParentsOf: aVersionInfo
	^ (stepparents at: aVersionInfo ifAbsentPut: [Set new])! !

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

MCVersionSorter class
	instanceVariableNames: ''!

!MCVersionSorter class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:03'!
new
	^ self basicNew initialize! !
MCTestCase subclass: #MCVersionTest
	instanceVariableNames: 'version visited'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCVersionTest methodsFor: 'asserting' stamp: 'cwp 11/7/2004 14:32'!
assert: aSelector orders: sexpr as: array
	| expected |
	expected := OrderedCollection new.
	version := self versionFromTree: sexpr.
	version perform: aSelector with: [:ea | expected add: ea info name].
	self assert: expected asArray = array! !

!MCVersionTest methodsFor: 'asserting' stamp: 'md 9/6/2005 18:41'!
assert: aSelector orders: sexpr as: expected unresolved: unresolved
	| missing |
	missing := OrderedCollection new.
	version := self versionFromTree: sexpr.
	version 
		perform: aSelector 
		with: [:ea | visited add: ea info name]
		with: [:ea | missing add: ea name].
	self assert: visited asArray = expected.
	self assert: missing asArray = unresolved.! !


!MCVersionTest methodsFor: 'building' stamp: 'cwp 11/7/2004 12:29'!
dependencyFromTree: sexpr
	^ MCMockDependency fromTree: sexpr! !

!MCVersionTest methodsFor: 'building' stamp: 'cwp 11/7/2004 12:40'!
versionFromTree: sexpr
	^ (self dependencyFromTree: sexpr) resolve! !


!MCVersionTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	visited := OrderedCollection new.! !


!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:53'!
testAllAvailablePostOrder
	self 
		assert: #allAvailableDependenciesDo: 
		orders: #(a ((b (d e)) c)) 
		as: #(d e b c)! !

!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:50'!
testAllMissing
	self 
		assert: #allDependenciesDo: 
		orders: #(a ((b (d e)) (c missing))) 
		as: #(d e b)! !

!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:47'!
testAllUnresolved
	self 
		assert: #allDependenciesDo:ifUnresolved: 
		orders: #(a ((b (d e)) (c missing)))
		as: #(d e b)
		unresolved: #(c)! !

!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 13:55'!
testDependencyOrder
	self 
		assert: #allDependenciesDo: 
		orders: #(a (b c)) 
		as: #(b c)! !

!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:25'!
testPostOrder
	self 
		assert: #allDependenciesDo: 
		orders: #(a ((b (d e)) c)) 
		as: #(d e b c)! !

!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:22'!
testWithAll
	self 
		assert: #withAllDependenciesDo: 
		orders: #(a ((b (d e)) c)) 
		as: #(d e b c a)! !

!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:56'!
testWithAllMissing
	self 
		assert: #withAllDependenciesDo: 
		orders: #(a ((b (d e)) (c missing))) 
		as: #(d e b a)! !

!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:29'!
testWithAllUnresolved
	self 
		assert: #withAllDependenciesDo:ifUnresolved: 
		orders: #(a ((b (d e)) (c missing)))
		as: #(d e b a)
		unresolved: #(c)! !

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

MCVersionTest class
	instanceVariableNames: ''!
MCAncestry subclass: #MCWorkingAncestry
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!
!MCWorkingAncestry commentStamp: '<historical>' prior: 0!
The interim record of ancestry for a working copy, gets merged version added to the ancestry, and is used to create the VersionInfo when the working copy becomes a version. !


!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
addAncestor: aNode
	ancestors := (self ancestors reject: [:each | aNode hasAncestor: each])
		copyWith: aNode! !

!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
addStepChild: aVersionInfo
	stepChildren := stepChildren copyWith: aVersionInfo! !

!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:31'!
infoWithName: nameString message: messageString
	^ MCVersionInfo
		name: nameString
		id: UUID new
		message: messageString
		date: Date today
		time: Time now
		author: Utilities authorInitials
		ancestors: ancestors asArray
		stepChildren: self stepChildren asArray! !

!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:14'!
name
	^ '<working copy>'! !

!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:14'!
summary
	^ 'Ancestors: ', self ancestorString! !

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

MCWorkingAncestry class
	instanceVariableNames: ''!
MCPackageManager subclass: #MCWorkingCopy
	instanceVariableNames: 'versionInfo ancestry counter repositoryGroup requiredPackages'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Versioning'!

!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:07'!
ancestors
	^ ancestry ancestors! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:13'!
ancestry
	^ ancestry! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
clearRequiredPackages
	requiredPackages := nil! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 20:01'!
currentVersionInfo
	^ (self needsSaving or: [ancestry ancestors isEmpty])
		ifTrue: [self newVersion info]
		ifFalse: [ancestry ancestors first]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:05'!
description
	^ self packageNameWithStar, ' (', ancestry ancestorString, ')'! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 20:02'!
needsSaving
	^ self modified or: [self requiredPackages anySatisfy: [:ea | ea workingCopy needsSaving]]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
requiredPackages
	^ requiredPackages ifNil: [requiredPackages := OrderedCollection new]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 1/20/2004 16:04'!
requirePackage: aPackage
	(self requiredPackages includes: aPackage) ifFalse: [requiredPackages add: aPackage]! !

!MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'!
versionInfo: aVersionInfo
	ancestry := MCWorkingAncestry new addAncestor: aVersionInfo! !


!MCWorkingCopy methodsFor: 'migration' stamp: 'stephaneducasse 2/4/2006 20:47'!
updateInstVars
	ancestry ifNil:
		[ancestry := MCWorkingAncestry new.
		versionInfo ifNotNil:
			[versionInfo ancestors do: [:ea | ancestry addAncestor: ea].
			versionInfo := nil]]! !


!MCWorkingCopy methodsFor: 'operations' stamp: 'avi 2/13/2004 01:07'!
adopt: aVersion
	ancestry addAncestor: aVersion info.
	self changed.! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'avi 9/14/2004 15:03'!
backportChangesTo: aVersionInfo
	| baseVersion fullPatch currentVersionInfo currentVersion newSnapshot newAncestry |
	currentVersionInfo := self currentVersionInfo.
	baseVersion := self repositoryGroup versionWithInfo: aVersionInfo.
	currentVersion := self repositoryGroup versionWithInfo: currentVersionInfo.
	fullPatch := currentVersion snapshot patchRelativeToBase: baseVersion snapshot.
	(MCChangeSelectionRequest new
		patch: fullPatch;
		label: 'Changes to Backport';
		signal ) ifNotNilDo:
		[:partialPatch |
		newSnapshot := MCPatcher apply: partialPatch to: baseVersion snapshot.
		newAncestry := MCWorkingAncestry new
							addAncestor: aVersionInfo;
							addStepChild: currentVersionInfo;
							yourself.
		MCPackageLoader updatePackage: package withSnapshot: newSnapshot.
		ancestry := newAncestry.
		self modified: false; modified: true]! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'!
changesRelativeToRepository: aRepository
	| ancestorVersion ancestorSnapshot |
	ancestorVersion := aRepository closestAncestorVersionFor: ancestry ifNone: [].
	ancestorSnapshot := ancestorVersion ifNil: [MCSnapshot empty] ifNotNil: [ancestorVersion snapshot].
	^ package snapshot patchRelativeToBase: ancestorSnapshot! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'!
loaded: aVersion
	ancestry := MCWorkingAncestry new addAncestor: aVersion info.
	requiredPackages := OrderedCollection withAll: (aVersion dependencies collect: [:ea | ea package]).
	self modified: false.
	self changed! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'abc 2/13/2004 15:57'!
merged: aVersion
	ancestry addAncestor: aVersion info.
	self changed! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'!
merge: targetVersion
	| ancestorInfo merger ancestorSnapshot packageSnapshot |
	targetVersion dependencies do: [:ea | ea resolve merge].
	ancestorInfo := targetVersion info commonAncestorWith: ancestry.
	
	ancestorInfo = targetVersion info ifTrue: [^ MCNoChangesException signal].
	
	packageSnapshot := package snapshot.
	ancestorSnapshot := ancestorInfo
							ifNotNil: [(self findSnapshotWithVersionInfo: ancestorInfo)]
							ifNil: [self notifyNoCommonAncestorWith: targetVersion.  MCSnapshot empty].
	
	(ancestry ancestors size = 1
		and: [ancestry ancestors first = ancestorInfo]
		and: [(packageSnapshot patchRelativeToBase: ancestorSnapshot) isEmpty])
				ifTrue: [^ targetVersion load].
	
	merger := MCThreeWayMerger 
				base: packageSnapshot
				target: targetVersion snapshot
				ancestor: ancestorSnapshot.
	((MCMergeResolutionRequest new merger: merger)
		signal: 'Merging ', targetVersion info name) = true ifTrue:
			[merger loadWithNameLike: targetVersion info name.
			ancestry addAncestor: targetVersion info].
	self changed! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'avi 1/19/2004 16:18'!
newVersion
	^ (self requestVersionNameAndMessageWithSuggestion: self uniqueVersionName) ifNotNilDo:
		[:pair |
		self newVersionWithName: pair first message: pair last].
! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'!
newVersionWithName: nameString message: messageString
	| info deps |
	info := ancestry infoWithName: nameString message: messageString.
	ancestry := MCWorkingAncestry new addAncestor: info.
	self modified: true; modified: false.
	
	deps := self requiredPackages collect:
		[:ea | 
		MCVersionDependency
			package: ea
			info: ea workingCopy currentVersionInfo].

	^ MCVersion
		package: package
		info: info
		snapshot: package snapshot
		dependencies: deps! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'avi 2/13/2004 01:07'!
notifyNoCommonAncestorWith: aVersion
	self notify:
'Could not find a common ancestor between (',
aVersion info name,
') and (',
ancestry ancestorString, ').
Proceeding with this merge may cause spurious conflicts.'! !

!MCWorkingCopy methodsFor: 'operations' stamp: 'avi 10/5/2003 11:09'!
unload
	MCPackageLoader unloadPackage: self package.
	self unregister.! !


!MCWorkingCopy methodsFor: 'repositories' stamp: 'stephaneducasse 2/4/2006 20:47'!
repositoryGroup
	^ repositoryGroup ifNil: [repositoryGroup := MCRepositoryGroup new]! !

!MCWorkingCopy methodsFor: 'repositories' stamp: 'stephaneducasse 2/4/2006 20:47'!
repositoryGroup: aRepositoryGroup
	repositoryGroup := aRepositoryGroup! !


!MCWorkingCopy methodsFor: 'private' stamp: 'avi 9/24/2004 12:15'!
findSnapshotWithVersionInfo: aVersionInfo
	^ aVersionInfo
		ifNil: [MCSnapshot empty]
		ifNotNil: [(self repositoryGroup versionWithInfo: aVersionInfo) snapshot]! !

!MCWorkingCopy methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
initialize
	super initialize.
	ancestry := MCWorkingAncestry new! !

!MCWorkingCopy methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
nextVersionName
	| branch oldName |
	ancestry ancestors isEmpty
		ifTrue: [counter ifNil: [counter := 0]. branch := package name]
		ifFalse:
			[oldName := ancestry ancestors first name.
			oldName last isDigit
				ifFalse: [branch := oldName]
				ifTrue: [branch := oldName copyUpToLast: $-].
			counter ifNil: [
				counter := (ancestry ancestors collect: [:each |
					each name last isDigit
						ifFalse: [0]
						ifTrue: [(each name copyAfterLast: $-) extractNumber]]) max]].

	counter := counter + 1.
	^ branch, '-',  Utilities authorInitials, '.', counter asString! !

!MCWorkingCopy methodsFor: 'private' stamp: 'bf 9/8/2005 10:58'!
possiblyNewerVersions

	^Array streamContents: [:strm |
		self repositoryGroup repositories do: [:repo |
			strm nextPutAll: (self possiblyNewerVersionsIn: repo)]]! !

!MCWorkingCopy methodsFor: 'private' stamp: 'bf 9/8/2005 10:58'!
possiblyNewerVersionsIn: aRepository

	^aRepository possiblyNewerVersionsOfAnyOf: self ancestors! !

!MCWorkingCopy methodsFor: 'private' stamp: 'ab 8/24/2003 20:38'!
requestVersionNameAndMessageWithSuggestion: aString
	^ (MCVersionNameAndMessageRequest new suggestedName: aString) signal! !

!MCWorkingCopy methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'!
uniqueVersionName
	|versionName|
	counter := nil.
	[versionName := self nextVersionName.
	self repositoryGroup includesVersionNamed: versionName] whileTrue.
	^ versionName! !

!MCWorkingCopy methodsFor: 'private' stamp: 'avi 2/4/2004 14:11'!
versionSeparator
	^ $_! !

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

MCWorkingCopy class
	instanceVariableNames: ''!

!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:00'!
adoptVersionInfoFrom: anInstaller
	|viCache|
	viCache := Dictionary new.
	anInstaller versionInfo keysAndValuesDo: [:packageName :info |
		(self forPackage: (MCPackage named: packageName))
			versionInfo: (self infoFromDictionary:  info cache: viCache)].
	[anInstaller clearVersionInfo] on: Error do: ["backwards compat"].! !

!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 01:23'!
ancestorsFromArray: anArray cache: aDictionary
	^ anArray ifNotNil: [anArray collect: [:dict | self infoFromDictionary: dict cache: aDictionary]]! !

!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
infoFromDictionary: aDictionary cache: cache
	| id |
	id := aDictionary at: #id.
	^ cache at: id ifAbsentPut:
		[MCVersionInfo
			name: (aDictionary at: #name)
			id: (aDictionary at: #id)
			message: (aDictionary at: #message)
			date: (aDictionary at: #date)
			time: (aDictionary at: #time)
			author: (aDictionary at: #author)
			ancestors: (self ancestorsFromArray: (aDictionary at: #ancestors) cache: cache)]! !

!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2005 02:09'!
initialize
	Smalltalk 
		at: #MczInstaller
		ifPresent: [:installer | self adoptVersionInfoFrom: installer].
	self updateInstVars.
	"Temporary conversion code -- remove later"
	registry ifNotNil:[registry rehash]. "changed #="
	self allInstancesDo:[:each| "moved notifications"
		Smalltalk at: #SystemChangeNotifier ifPresent:[:cls|
			cls uniqueInstance noMoreNotificationsFor: each.
		].
	].
	self registerForNotifications.! !

!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:36'!
updateInstVars
	self allInstances do: [:ea | ea updateInstVars]! !
MCTool subclass: #MCWorkingCopyBrowser
	instanceVariableNames: 'workingCopy workingCopyWrapper repository defaults'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bkv 2/18/2004 21:22'!
addRepository
	self newRepository ifNotNilDo:
		[:repos | self addRepository: repos ].
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
addRepositoryToPackage
	self repository ifNotNilDo:
		[:repos |
		(self pickWorkingCopySatisfying: [ :p | (p repositoryGroup includes: repos) not ]) ifNotNilDo:
			[:wc |
			workingCopy := wc.
			workingCopy repositoryGroup addRepository: repos.
			self repository: repos.	
			self
				changed: #workingCopySelection;
				changed: #repositoryList;
				changed: #repositorySelection.
			self changedButtons]]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/21/2005 15:57'!
addRepositoryToWorkingCopy
	workingCopy ifNotNilDo:
		[:wc |
			workingCopy repositoryGroup addRepository: self repository.
			self
				changed: #workingCopySelection;
				changed: #repositoryList;
				changed: #repositorySelection.
			self changedButtons]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/21/2005 15:58'!
addRepository: aRepository
	self repository: aRepository.
	self repositoryGroup addRepository: aRepository.
	self changed: #repositoryList; changed: #repositorySelection.
	self changedButtons.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:45'!
addRequiredPackage
	workingCopy ifNotNilDo:
		[:wc |
		self pickWorkingCopy ifNotNilDo:
			[:required |
			wc requirePackage: required package.
			self workingCopyListChanged]]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
addWorkingCopy
	|name|
	name := FillInTheBlankMorph request: 'Name of package:'.
	name isEmptyOrNil ifFalse:
		[PackageInfo registerPackageName: name.
		workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name).
		workingCopyWrapper := nil.
		self repositorySelection: 0].
	self workingCopyListChanged; changed: #workingCopySelection; changed: #repositoryList.
	self changedButtons.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/21/2005 15:38'!
backportChanges
	self canBackport ifFalse: [^self].
	workingCopy ifNotNil:
		[workingCopy needsSaving ifTrue: [^ self inform: 'You must save the working copy before backporting.'].
		self pickAncestorVersionInfo ifNotNilDo:
			[:baseVersionInfo |
			workingCopy backportChangesTo: baseVersionInfo]]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ab 7/19/2003 22:58'!
browseWorkingCopy
	workingCopy ifNotNil:
		[(MCSnapshotBrowser forSnapshot: workingCopy package snapshot)
			label: 'Snapshot Browser: ', workingCopy packageName;
			show]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 9/14/2004 14:57'!
canBackport
	^ self hasWorkingCopy and: [workingCopy needsSaving not]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
checkForNewerVersions
	| newer |
	newer := workingCopy possiblyNewerVersionsIn: self repository.
	^ newer isEmpty or: [
		self confirm: 'CAUTION!! These versions in the repository may be newer:', 
			String cr, newer asString, String cr,
			'Do you really want to save this version?'].! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:46'!
clearRequiredPackages
	workingCopy ifNotNilDo:
		[:wc |
		wc clearRequiredPackages.
		self workingCopyListChanged]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:46'!
deleteWorkingCopy
	workingCopy unregister.
	self workingCopySelection: 0.
	self workingCopyListChanged.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 4/14/2005 15:31'!
editRepository
	| newRepo |
	
	newRepo := self repository openAndEditTemplateCopy.
	newRepo ifNotNil: [ 
		newRepo class = self repository class
			ifTrue: [self repository copyFrom: newRepo]
			ifFalse: [self inform: 'Must not change repository type!!']]
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/3/2005 15:08'!
flushAllCaches
	| beforeBytes afterBytes beforeVersions afterVersions |
	Cursor wait showWhile: [
		beforeBytes := Smalltalk garbageCollect.
		beforeVersions := MCVersion allSubInstances size.
		MCFileBasedRepository flushAllCaches.
		afterBytes := Smalltalk garbageCollect.
		afterVersions := MCVersion allSubInstances size.
	].
	^self inform: (beforeVersions - afterVersions) asString, ' versions flushed', String cr,
 		(afterBytes - beforeBytes) asStringWithCommas, ' bytes reclaimed'! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 9/11/2004 15:32'!
inspectWorkingCopy
	workingCopy ifNotNil: [workingCopy inspect]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/21/2005 15:58'!
loadRepositories
	FileStream fileIn: 'MCRepositories.st'.
	self changed: #repositoryList.
	self changedButtons.
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
newRepository
	| types index |
	types := MCRepository allConcreteSubclasses asArray.
	index := (PopUpMenu labelArray: (types collect: [:ea | ea description]))
				startUpWithCaption: 'Repository type:'.
	^ index = 0 ifFalse: [(types at: index) morphicConfigure]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'lr 9/26/2003 20:04'!
openRepository
	self repository ifNotNilDo: [:repos | repos morphicOpen: workingCopy ]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'jf 1/25/2004 14:06'!
recompilePackage
	workingCopy package packageInfo methods
		do: [:ea | ea actualClass recompile: ea methodSymbol]
		displayingProgress: 'Recompiling...'! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/21/2005 15:58'!
removeRepository
	self repository ifNotNilDo:
		[:repos |
		self repositoryGroup removeRepository: repos.
		self repositorySelection: (1 min: self repositories size)].
	self changed: #repositoryList.
	self changedButtons.
! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
repository
	workingCopy ifNotNil: [repository := self defaults at: workingCopy ifAbsent: []].
	^ repository! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
repository: aRepository
	repository := aRepository.
	workingCopy ifNotNil: [self defaults at: workingCopy put: aRepository]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 5/11/2005 15:20'!
revertPackage
	self pickAncestorVersionInfo ifNotNilDo: [:info |
		(self repositoryGroup versionWithInfo: info
			ifNone: [^self inform: 'No repository found for ', info name]
		) load]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 9/10/2004 17:46'!
saveRepositories
	| f |
	f := FileStream forceNewFileNamed: 'MCRepositories.st'.
	MCRepositoryGroup default repositoriesDo: [:r |
		f nextPutAll: 'MCRepositoryGroup default addRepository: (', r asCreationTemplate, ')!!'; cr.]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'al 7/18/2006 15:49'!
saveVersion
	| repo |
	self canSave ifFalse: [^self].
	self checkForNewerVersions ifFalse: [^self].
	repo _ self repository.
	workingCopy newVersion ifNotNilDo:
		[:v |
		(MCVersionInspector new version: v) show.
		Cursor wait showWhile: [repo storeVersion: v].
		MCCacheRepository default cacheAllFileNamesDuring: 
			[repo cacheAllFileNamesDuring: 
				[v allAvailableDependenciesDo:
					[:dep |
					(repo includesVersionNamed: dep info name)
						ifFalse: [repo storeVersion: dep]]]]]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:46'!
unloadPackage
	workingCopy unload.
	self workingCopySelection: 0.
	self workingCopyListChanged.! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
viewChanges
	| patch |
	self canSave ifTrue:
		[patch := workingCopy changesRelativeToRepository: self repository.
		patch isNil ifTrue: [^ self].
		patch isEmpty
			ifTrue: [ workingCopy modified: false.
				self inform: 'No changes' ]
			ifFalse:
				[ workingCopy modified: true.
				(MCPatchBrowser forPatch: patch)
					label: 'Patch Browser: ', workingCopy description;
					show]]! !

!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 2/13/2004 01:13'!
viewHistory
	workingCopy ifNotNil:
		[(MCWorkingHistoryBrowser new
				ancestry: workingCopy ancestry;
				package: workingCopy package)
			label:  'Version History: ',  workingCopy packageName;
			show]! !


!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 2/28/2005 16:28'!
buttonSpecs
       ^ #(
               ('+Package' addWorkingCopy 'Add a new package and make it the working copy')
               (Browse browseWorkingCopy 'Browse the working copy of the selected package' hasWorkingCopy)
               (Scripts editLoadScripts 'Edit the load/unload scripts of this package' hasWorkingCopy)
               (History viewHistory 'View the working copy''s history' hasWorkingCopy)
               (Changes viewChanges 'View the working copy''s changes relative to the installed version from the repository' canSave)
               (Backport backportChanges 'Backport the working copy''s changes to an ancestor' canBackport)
               (Save saveVersion 'Save the working copy as a new version to the selected repository' canSave)
             ('+Repository' addRepository 'Add an existing repository to the list of those visible')
               (Open openRepository 'Open a browser on the selected repository' hasRepository)
               )! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:22'!
canSave
	^ self hasWorkingCopy and: [self hasRepository]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/21/2005 15:50'!
changedButtons
	self changed: #hasWorkingCopy.
	self changed: #canSave.
	self changed: #canBackport.
	self changed: #hasRepository.
! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 2/28/2005 16:28'!
defaultExtent
	^ 550@200! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 23:38'!
defaultLabel
	^ 'Monticello Browser'! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
defaults
	^ defaults ifNil: [defaults := Dictionary new]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
editLoadScripts

	| menu |
	self hasWorkingCopy ifFalse: [^self].
	menu := MenuMorph new defaultTarget: self.
	menu add: 'edit preamble' selector: #editScript: argument: #preamble.
	menu add: 'edit postscript' selector: #editScript: argument: #postscript.
	menu add: 'edit preambleOfRemoval' selector: #editScript: argument: #preambleOfRemoval.
	menu add: 'edit postscriptOfRemoval' selector: #editScript: argument: #postscriptOfRemoval.
	menu popUpInWorld.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
editScript: scriptSymbol

| script |
script := workingCopy packageInfo perform: scriptSymbol.
script openLabel: scriptSymbol asString, ' of the Package ', workingCopy package name.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 02:21'!
hasRepository
	^ self repository notNil! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 00:46'!
hasWorkingCopy
	^ workingCopy notNil! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 11/16/2003 20:21'!
initialize
	MCWorkingCopy addDependent: self.
	self workingCopies do: [:ea | ea addDependent: self].! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
pickAncestorVersionInfo
	| ancestors index |
	ancestors := workingCopy ancestry breadthFirstAncestors.
	index := (PopUpMenu labelArray: (ancestors collect: [:ea | ea name]))
				startUpWithCaption: 'Ancestor:'.
	^ index = 0 ifFalse: [ ancestors at: index]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'nk 3/9/2004 14:39'!
pickWorkingCopy
	^self pickWorkingCopySatisfying: [ :c | true ]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
pickWorkingCopySatisfying: aBlock
	| copies index |
	copies := self workingCopies select: aBlock.
	copies isEmpty ifTrue: [ ^nil ].
	index := (PopUpMenu labelArray: (copies collect: [:ea | ea packageName]))
				startUpWithCaption: 'Package:'.
	^ index = 0 ifFalse: [ copies at: index]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:32'!
repositories
	^ self repositoryGroup repositories! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:32'!
repositoryGroup
	^ workingCopy
		ifNil: [MCRepositoryGroup default]
		ifNotNil: [workingCopy repositoryGroup]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:04'!
repositoryList
	^ self repositories collect: [:ea | ea description]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/6/2005 13:20'!
repositoryListMenu: aMenu
	self repository ifNil: [^ aMenu].
	self fillMenu: aMenu fromSpecs:
		#(('open repository' #openRepository)
		    ('edit repository info' #editRepository)
		   ('add to package...' #addRepositoryToPackage)
		   ('remove repository' #removeRepository)	
		   ('load repositories' #loadRepositories)	
		   ('save repositories' #saveRepositories)
		   ('flush cached versions' #flushAllCaches)	
		).
		aMenu
		add: (self repository alwaysStoreDiffs
					ifTrue: ['store full versions']
					ifFalse: ['store diffs'])
		target: self
		selector: #toggleDiffs.
	^ aMenu
				! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 02:22'!
repositorySelection
	^ self repositories indexOf: self repository! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/21/2005 15:56'!
repositorySelection: aNumber
	aNumber = 0
		ifTrue: [self repository: nil]
		ifFalse: [self repository: (self repositories at: aNumber)].
	self changed: #repositorySelection.
	self changedButtons.
! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 8/31/2004 01:14'!
toggleDiffs
	self repository alwaysStoreDiffs
		ifTrue: [self repository doNotAlwaysStoreDiffs]
		ifFalse: [self repository doAlwaysStoreDiffs]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 9/10/2004 17:54'!
unsortedWorkingCopies
	^ MCWorkingCopy allManagers ! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 9/10/2004 17:54'!
update: aSymbol
	self unsortedWorkingCopies do: [:ea | ea addDependent: self].
	self workingCopyListChanged.! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 3/6/2005 22:30'!
widgetSpecs
	^ #(
		((buttonRow) (0 0 1 0) (0 0 0 30))
		((treeOrListMorph: workingCopy) (0 0 0.5 1) (0 30 0 0))
		((listMorph: repository) (0.5 0 1 1) (0 30 0 0))
		)! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 1/20/2004 16:09'!
workingCopies
	^ MCWorkingCopy allManagers asSortedCollection:
		[ :a :b | a package name <= b package name ]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 1/19/2004 16:41'!
workingCopyList
	^ self workingCopies collect:
		[:ea |
		(workingCopy notNil and: [workingCopy requiredPackages includes: ea package])
			ifTrue: [Text string: ea description emphasis: (Array with: TextEmphasis bold)]
			ifFalse: [ea description]]! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/21/2005 15:51'!
workingCopyListChanged
	self changed: #workingCopyList.
	self changed: #workingCopyTree.
	self changedButtons.
! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 5/11/2005 15:26'!
workingCopyListMenu: aMenu
	workingCopy ifNil: [^ aMenu].
	self fillMenu: aMenu fromSpecs:
		#(('add required package' #addRequiredPackage)
			('clear required packages' #clearRequiredPackages)
			('browse package' #browseWorkingCopy)
			('view changes' #viewChanges)
			('view history' #viewHistory)
			('recompile package' #recompilePackage)
			('revert package...' #revertPackage)
			('unload package' #unloadPackage)
			('delete working copy' #deleteWorkingCopy)).
	(Smalltalk includesKey: #SARMCPackageDumper) ifTrue: [
		aMenu add: 'make SAR' target: self selector: #fileOutAsSAR
	].
	^aMenu! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 23:11'!
workingCopyListMorph
	^ PluggableMultiColumnListMorph
		on: self
		list: #workingCopyList
		selected: #workingCopySelection
		changeSelected: #workingCopySelection:
		menu: #workingCopyListMenu:! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:05'!
workingCopySelection
	^ self workingCopies indexOf: workingCopy! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:38'!
workingCopySelectionWrapper
	^workingCopyWrapper! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:57'!
workingCopySelectionWrapper: aWrapper
	workingCopyWrapper := aWrapper.
	self changed: #workingCopySelectionWrapper.
	self workingCopy: (aWrapper ifNotNil:[aWrapper item])! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:48'!
workingCopySelection: aNumber
	self workingCopy: 
		(aNumber = 0 
			ifTrue:[nil]
			ifFalse:[self workingCopies at: aNumber]).	! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:30'!
workingCopyTree
	^ self workingCopies collect:[:each| MCDependentsWrapper with: each model: self].! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 5/11/2005 15:25'!
workingCopyTreeMenu: aMenu
	workingCopy ifNil: [^ aMenu].
	self fillMenu: aMenu fromSpecs:
		#(('add required package' #addRequiredPackage)
			('clear required packages' #clearRequiredPackages)
			('browse package' #browseWorkingCopy)
			('view changes' #viewChanges)
			('view history' #viewHistory)
			('recompile package' #recompilePackage)
			('revert package...' #revertPackage)
			('unload package' #unloadPackage)
			('delete working copy' #deleteWorkingCopy)
			('inspect working copy' #inspectWorkingCopy)).
	(Smalltalk includesKey: #SARMCPackageDumper) ifTrue: [
		aMenu add: 'make SAR' target: self selector: #fileOutAsSAR
	].
	^aMenu! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:24'!
workingCopyTreeMorph
	^ SimpleHierarchicalListMorph
		on: self
		list: #workingCopyTree
		selected: #workingCopyWrapper
		changeSelected: #workingCopyWrapper:
		menu: #workingCopyListMenu:! !

!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'!
workingCopy: wc
	workingCopy := wc.
	self changed: #workingCopyList; changed: #workingCopySelection; changed: #repositoryList.
	self changedButtons.
! !

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

MCWorkingCopyBrowser class
	instanceVariableNames: ''!

!MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 23:38'!
initialize
	 (TheWorldMenu respondsTo: #registerOpenCommand:)
         ifTrue: [TheWorldMenu registerOpenCommand: {'Monticello Browser'. {self. #open}}]! !

!MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:04'!
new
	^ self basicNew initialize! !

!MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 23:27'!
open
	self new show! !
MCTestCase subclass: #MCWorkingCopyTest
	instanceVariableNames: 'savedInitials workingCopy repositoryGroup versions versions2'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Tests'!

!MCWorkingCopyTest methodsFor: 'accessing' stamp: 'ab 7/7/2003 18:02'!
description
	^ self class name! !


!MCWorkingCopyTest methodsFor: 'actions' stamp: 'avi 2/13/2004 14:30'!
basicMerge: aVersion
	aVersion merge! !

!MCWorkingCopyTest methodsFor: 'actions' stamp: 'avi 1/24/2004 20:13'!
load: aVersion
	aVersion load! !

!MCWorkingCopyTest methodsFor: 'actions' stamp: 'jf 8/21/2003 20:22'!
merge: aVersion
	[[self basicMerge: aVersion]
		on: MCMergeResolutionRequest do: [:n | n resume: true]]
			on: MCNoChangesException do: [:n | ]! !

!MCWorkingCopyTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'!
snapshot
	| version |
	[version := workingCopy newVersion]
		on: MCVersionNameAndMessageRequest
		do: [:n | n resume: (Array with: n suggestedName with: '')].
	versions at: version info put: version.
	^ version! !


!MCWorkingCopyTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertNameWhenSavingTo: aRepository is: aString
	| name |
	name := nil.
	[aRepository storeVersion: workingCopy newVersion]
		on: MCVersionNameAndMessageRequest
		do: [:n | name := n suggestedName. n resume: (Array with: name with: '')].
	self assert: name = aString! !

!MCWorkingCopyTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'!
assertNumberWhenSavingTo: aRepository is: aNumber
	| name |
	name := nil.
	[aRepository storeVersion: workingCopy newVersion]
		on: MCVersionNameAndMessageRequest
		do: [:n | name := n suggestedName. n resume: (Array with: name with: '')].
	self assert: name = (self packageName, '-', Utilities authorInitials, '.', aNumber asString)! !


!MCWorkingCopyTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'!
clearPackageCache
	| dir |
	dir := MCCacheRepository default directory.
	(dir fileNamesMatching: 'MonticelloMocks*') do: [:ea | dir deleteFileNamed: ea].
	(dir fileNamesMatching: 'MonticelloTest*') do: [:ea | dir deleteFileNamed: ea].
	(dir fileNamesMatching: 'rev*') do: [:ea | dir deleteFileNamed: ea].
	(dir fileNamesMatching: 'foo-*') do: [:ea | dir deleteFileNamed: ea].
	(dir fileNamesMatching: 'foo2-*') do: [:ea | dir deleteFileNamed: ea].! !

!MCWorkingCopyTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'!
setUp
	| repos1 repos2 |
	self clearPackageCache.
	repositoryGroup := MCRepositoryGroup new.
	workingCopy := MCWorkingCopy forPackage: self mockPackage.
	versions := Dictionary new.
	versions2 := Dictionary new.
	repos1 := MCDictionaryRepository new dictionary: versions.
	repos2 := MCDictionaryRepository new dictionary: versions2.
	repositoryGroup addRepository: repos1.
	repositoryGroup addRepository: repos2.
	MCRepositoryGroup default removeRepository: repos1; removeRepository: repos2.
	workingCopy repositoryGroup: repositoryGroup.
	savedInitials := Utilities authorInitials.
	Utilities setAuthorInitials: 'abc'.! !

!MCWorkingCopyTest methodsFor: 'running' stamp: 'avi 2/10/2004 12:30'!
tearDown
	workingCopy unregister.
	self restoreMocks.
	self clearPackageCache.
	Utilities setAuthorInitials: savedInitials.! !


!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testAncestorMerge
	| base revA revB revC |

	base := self snapshot.
	self change: #a toReturn: 'a1'.
	revA :=  self snapshot.
	self change: #b toReturn: 'b1'.
	revB :=  self snapshot.	
	self change: #c toReturn: 'c1'.
	revC :=  self snapshot.	

	self should: [self basicMerge: revA] raise: MCNoChangesException.
	! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testBackport
	| inst base final backported |
	inst := self mockInstanceA.
	base :=  self snapshot.
	self assert: inst one = 1.
	self change: #one toReturn: 2.
	self change: #two toReturn: 3.
	final := self snapshot.
	[workingCopy backportChangesTo: base info]
		on: MCChangeSelectionRequest
		do: [:e | e resume: e patch].
	self assert: inst one = 2.
	self assert: inst two = 3.
	self assert: workingCopy ancestry ancestors size = 1.
	self assert: workingCopy ancestry ancestors first = base info.
	self assert: workingCopy ancestry stepChildren size = 1.
	self assert: workingCopy ancestry stepChildren first = final info.
	backported := self snapshot.
	[workingCopy backportChangesTo: base info]
		on: MCChangeSelectionRequest
		do: [:e | e resume: e patch].
	self assert: workingCopy ancestry ancestors size = 1.
	self assert: workingCopy ancestry ancestors first = base info.
	self assert: workingCopy ancestry stepChildren size = 1.
	self assert: workingCopy ancestry stepChildren first = backported info.
	! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testDoubleRepeatedMerge
	| base motherA1 motherA2 motherB1 motherB2 inst |

	base := self snapshot.
	self change: #a toReturn: 'a1'.
	motherA1 :=  self snapshot.
	self change: #c toReturn: 'c1'.
	motherA2 :=  self snapshot.	
	
	self load: base.
	self change: #b toReturn: 'b1'.
	motherB1 :=  self snapshot.
	self change: #d toReturn: 'd1'.
	motherB2 :=  self snapshot.
	
	self load: base.
	self merge: motherA1.
	self merge: motherB1.
	self change: #a toReturn: 'a2'.
	self change: #b toReturn: 'b2'.
	self snapshot.

	self shouldnt: [self merge: motherA2] raise: Error.
	self shouldnt: [self merge: motherB2] raise: Error.
	
	inst := self mockInstanceA.
	self assert: inst a = 'a2'.
	self assert: inst b = 'b2'.
	self assert: inst c = 'c1'.
	self assert: inst d = 'd1'.
	! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testMergeIntoImageWithNoChanges
	| base revB revA1 |

	self change: #a toReturn: 'a'.
	base := self snapshot.
	self change: #b toReturn: 'b'.
	revB := self snapshot.
	
	self load: base.
	self change: #a toReturn: 'a1'.
	revA1 := self snapshot.

	self change: #a toReturn: 'a'.
	self snapshot.
	self merge: revB.

	self assert: (workingCopy ancestors size = 2)
	! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testMergeIntoUnmodifiedImage
	| base revA |

	base := self snapshot.
	self change: #a toReturn: 'a1'.
	revA := self snapshot.
	
	self load: base.

	self merge: revA.

	self assert: (workingCopy ancestors size = 1)
	! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'bf 5/20/2005 18:25'!
testNaming
	| repos version |

	repos := MCDictionaryRepository new.
	self assertNameWhenSavingTo: repos is: self packageName, '-abc.1'.
	self assertNameWhenSavingTo: repos is: self packageName, '-abc.2'.
	repos := MCDictionaryRepository new.
	self assertNameWhenSavingTo: repos is: self packageName, '-abc.3'.
	version := self snapshot.
	version info instVarNamed: 'name' put: 'foo-jf.32'.
	version load.
	self assertNameWhenSavingTo: repos is: 'foo-abc.33'.
	self assertNameWhenSavingTo: repos is: 'foo-abc.34'.
	version info instVarNamed: 'name' put: 'foo-abc.35'.
	repos storeVersion: version.
	self assertNameWhenSavingTo: repos is: 'foo-abc.36'.
	self assertNameWhenSavingTo: repos is: 'foo-abc.37'.
	version info instVarNamed: 'name' put: 'foo-abc.10'.
	repos storeVersion: version.
	self assertNameWhenSavingTo: repos is: 'foo-abc.38'.
	version info instVarNamed: 'name' put: 'foo2-ab.40'.
	version load.
	self assertNameWhenSavingTo: repos is: 'foo2-abc.41'.! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testOptimizedLoad
	| inst base diffy |
	inst := self mockInstanceA.
	base := self snapshot.
	self change: #one toReturn: 2.
	self assert: inst one = 2.
	diffy := self snapshot asDiffAgainst: base.
	self deny: diffy canOptimizeLoading.
	self load: base.
	self assert: inst one = 1.
	self assert: diffy canOptimizeLoading.
	self load: diffy.
	self assert: inst one = 2.
! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testRedundantMerge
	| base |
	base :=  self snapshot.
	self merge: base.
	self shouldnt: [self merge: base] raise: Error.! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testRepeatedMerge
	| base mother1 mother2 inst |

	base :=  self snapshot.
	self change: #one toReturn: 2.
	mother1 :=  self snapshot.
	self change: #two toReturn: 3.
	mother2 :=  self snapshot.	
	
	self load: base.
	self change: #truth toReturn: false.
	self snapshot.

	inst := self mockInstanceA.
	self assert: inst one = 1.
	self assert: inst two = 2.	

	self merge: mother1.
	self assert: inst one = 2.
	self assert: inst two = 2.	
	
	self change: #one toReturn: 7.
	self assert: inst one = 7.
	self assert: inst two = 2.
	
	self shouldnt: [self merge: mother2] raise: Error.
	self assert: inst one = 7.
	self assert: inst two = 3.! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testRepositoryFallback
	| version |
	version := self snapshot.
	self assert: (repositoryGroup versionWithInfo: version info) == version.
	versions removeKey: version info.
	versions2 at: version info put: version.
	self assert: ( repositoryGroup versionWithInfo: version info) == version.
	versions2 removeKey: version info.
	self should: [repositoryGroup versionWithInfo: version info] raise: Error.! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testSelectiveBackport
	| inst base intermediate final patch selected |
	inst := self mockInstanceA.
	base :=  self snapshot.
	self assert: inst one = 1.
	self change: #one toReturn: 2.
	intermediate := self snapshot.
	self change: #two toReturn: 3.
	final := self snapshot.
	[workingCopy backportChangesTo: base info]
		on: MCChangeSelectionRequest
		do: [:e |
			patch := e patch.
			selected := patch operations select: [:ea | ea definition selector = #two].
			e resume: (MCPatch operations: selected)]. 
	self assert: inst one = 1.
	self assert: inst two = 3.
	self assert: workingCopy ancestry ancestors size = 1.
	self assert: workingCopy ancestry ancestors first = base info.
	self assert: workingCopy ancestry stepChildren size = 1.
	self assert: workingCopy ancestry stepChildren first = final info! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testSimpleMerge
	| mother base inst |
	inst := self mockInstanceA.
	base :=  self snapshot.
	self change: #one toReturn: 2.
	mother :=  self snapshot.
	self load: base.
	self change: #two toReturn: 3.
	self snapshot.
	self assert: inst one = 1.
	self assert: inst two = 3.
	
	self merge: mother.
	self assert: inst one = 2.
	self assert: inst two = 3.! !

!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'!
testSnapshotAndLoad
	| base inst |
	inst := self mockInstanceA.
	base :=  self snapshot.
	self change: #one toReturn: 2.
	self assert: inst one = 2.
	self load: base.
	self assert: inst one = 1.! !


!MCWorkingCopyTest methodsFor: 'private' stamp: 'cwp 8/2/2003 15:03'!
packageName
	^ self mockPackage name! !

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

MCWorkingCopyTest class
	instanceVariableNames: ''!
MCVersionHistoryBrowser subclass: #MCWorkingHistoryBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-UI'!

!MCWorkingHistoryBrowser methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 01:37'!
baseSnapshot
	^ package snapshot! !

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

MCWorkingHistoryBrowser class
	instanceVariableNames: ''!
MCRepository subclass: #MCWriteOnlyRepository
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Repositories'!

!MCWriteOnlyRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:52'!
includesVersionNamed: aString
	^ false! !

!MCWriteOnlyRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:53'!
morphicOpen: aWorkingCopy
	self inform: 'This repository is write-only'! !

!MCWriteOnlyRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:52'!
versionWithInfo: aVersionInfo ifAbsent: aBlock
	^ aBlock value! !

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

MCWriteOnlyRepository class
	instanceVariableNames: ''!
Object subclass: #MCWriter
	instanceVariableNames: 'stream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Monticello-Storing'!

!MCWriter methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 01:14'!
stream
	^ stream! !

!MCWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'!
stream: aStream
	stream := aStream! !

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

MCWriter class
	instanceVariableNames: ''!

!MCWriter class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 15:00'!
extension
	^ self readerClass extension! !

!MCWriter class methodsFor: 'accessing' stamp: 'cwp 7/28/2003 23:46'!
readerClass
	^ self subclassResponsibility ! !


!MCWriter class methodsFor: 'writing' stamp: 'cwp 8/1/2003 01:16'!
on: aStream
	^ self new stream: aStream! !
AlignmentMorph subclass: #MIDIControllerMorph
	instanceVariableNames: 'channel controller midiPort lastValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:35'!
channel

	^ channel
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:40'!
channel: anInteger

	channel _ anInteger.
	lastValue _ nil.
	self updateLabel.
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:35'!
controller

	^ controller
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:40'!
controller: anInteger

	controller _ anInteger.
	lastValue _ nil.
	self updateLabel.
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:54'!
midiPort

	^ midiPort
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:55'!
midiPort: anInteger

	midiPort _ anInteger.
! !


!MIDIControllerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:37'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 1! !

!MIDIControllerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:37'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.484
		g: 0.613
		b: 0.0! !

!MIDIControllerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:37'!
initialize
"initialize the state of the receiver"
	| slider |
	super initialize.
""
	self listDirection: #topToBottom.
	self wrapCentering: #center;
		 cellPositioning: #topCenter.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	channel _ 0.
	controller _ 7.
	"channel volume"
	slider _ SimpleSliderMorph new target: self;
				 actionSelector: #newSliderValue:;
				 minVal: 0;
				 maxVal: 127;
				 extent: 128 @ 10.
	self addMorphBack: slider.
	self
		addMorphBack: (StringMorph contents: 'Midi Controller').
	self updateLabel! !


!MIDIControllerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:50'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'set channel' translated action: #setChannel:.
	aCustomMenu add: 'set controller' translated action: #setController:.
! !

!MIDIControllerMorph methodsFor: 'menu' stamp: 'jm 9/29/1998 09:06'!
controllerList
	"Answer a list of controller name, number pairs to be used in the menu."

	^ #((1 modulation)
		(2 'breath control')
		(7 volume)
		(10 pan)
		(11 expression)
		(92 'tremolo depth')
		(93 'chorus depth')
		(94 'celeste depth')
		(95 'phaser depth'))
! !

!MIDIControllerMorph methodsFor: 'menu' stamp: 'jm 9/29/1998 09:09'!
controllerName: controllerNumber
	"Answer a name for the given controller. If no name is available, use the form 'CC5' (CC is short for 'continuous controller')."

	self controllerList do: [:pair |
		pair first = controllerNumber ifTrue: [^ pair last]].
	^ 'CC', controllerNumber asString
! !

!MIDIControllerMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:02'!
setChannel: evt
	| menu |
	menu _ MenuMorph new.
	1 to: 16 do: [:chan |
		menu add: chan printString
			target: self
			selector: #channel:
			argumentList: (Array with: chan - 1)].

	menu popUpEvent: evt in: self world! !

!MIDIControllerMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:02'!
setController: evt
	| menu |
	menu _ MenuMorph new.
	self controllerList do: [:pair |
		menu add: (pair last)
			target: self
			selector: #controller:
			argumentList: (Array with: pair first)].

	menu popUpEvent: evt in: self world! !


!MIDIControllerMorph methodsFor: 'other' stamp: 'jm 10/12/1998 16:02'!
newSliderValue: newValue
	"Send a control command out the MIDI port."

	| val |
	midiPort ifNil: [^ self].
	val _ newValue asInteger.
	lastValue = val ifTrue: [^ self].
	lastValue _ val.
	midiPort midiCmd: 16rB0 channel: channel byte: controller byte: val.
! !

!MIDIControllerMorph methodsFor: 'other' stamp: 'jm 9/29/1998 09:10'!
updateLabel

	| label |
	(label _ self findA: StringMorph) ifNil: [^ self].
	label contents: (self controllerName: controller), ', ch: ', (channel + 1) printString.
! !
Object subclass: #MIDIFileReader
	instanceVariableNames: 'stream fileType trackCount ticksPerQuarter tracks trackInfo tempoMap strings track trackStream activeEvents maxNoteTicks'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDIFileReader commentStamp: '<historical>' prior: 0!
A reader for Standard 1.0 format MIDI files.
MIDI File Types:
	type 0 -- one multi-channel track
	type 1 -- one or more simultaneous tracks
	type 2 -- a number on independent single-track patterns

Instance variables:
	stream			source of MIDI data
	fileType			MIDI file type
	trackCount		number of tracks in file
	ticksPerQuarter	number of ticks per quarter note for all tracks in this file
	tracks			collects track data for non-empty tracks
	strings			collects all strings in the MIDI file
	tempoMap		nil or a MIDITrack consisting only of tempo change events
	trackStream		stream on buffer containing track chunk
	track			track being read
	activeEvents 	notes that have been turned on but not off
!


!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 1/6/98 23:20'!
asScore

	^ MIDIScore new
		tracks: tracks;
		trackInfo: trackInfo;
		tempoMap: tempoMap;
		ticksPerQuarterNote: ticksPerQuarter
! !

!MIDIFileReader methodsFor: 'chunk reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
readHeaderChunk

	| chunkType chunkSize division |
	chunkType := self readChunkType.
	chunkType = 'RIFF' ifTrue:[chunkType := self riffSkipToMidiChunk].
	chunkType = 'MThd' ifFalse: [self scanForMIDIHeader].
	chunkSize := self readChunkSize.
	fileType := self next16BitWord.
	trackCount := self next16BitWord.
	division := self next16BitWord.
	(division anyMask: 16r8000)
		ifTrue: [self error: 'SMPTE time formats are not yet supported']
		ifFalse: [ticksPerQuarter := division].
	maxNoteTicks := 12 * 4 * ticksPerQuarter.
		"longest acceptable note; used to detect stuck notes"

	"sanity checks"
	((chunkSize < 6) or: [chunkSize > 100])
		ifTrue: [self error: 'unexpected MIDI header size ', chunkSize printString].
	(#(0 1 2) includes: fileType)
		ifFalse: [self error: 'unknown MIDI file type ', fileType printString].

	Transcript
		show: 'Reading Type ', fileType printString, ' MIDI File (';
		show: trackCount printString, ' tracks, ';
		show: ticksPerQuarter printString, ' ticks per quarter note)';
		cr.
! !

!MIDIFileReader methodsFor: 'chunk reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
readMIDIFrom: aBinaryStream
	"Read one or more MIDI tracks from the given binary stream."

	stream := aBinaryStream.
	tracks := OrderedCollection new.
	trackInfo := OrderedCollection new.
	self readHeaderChunk.
	trackCount timesRepeat: [self readTrackChunk].
	stream atEnd ifFalse: [self report: 'data beyond final track'].
	fileType = 0 ifTrue: [self splitIntoTracks].
	self guessMissingInstrumentNames.
! !

!MIDIFileReader methodsFor: 'chunk reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
readTrackChunk

	| chunkType chunkSize |
	chunkType := self readChunkType.
	[chunkType = 'MTrk'] whileFalse: [
		self report: 'skipping unexpected chunk type "', chunkType, '"'.
		stream skip: (self readChunkSize).  "skip it"
		chunkType := (stream next: 4) asString].
	chunkSize := self readChunkSize.
	chunkSize < 10000000 ifFalse: [
		self error: 'suspiciously large track chunk; this may not be MIDI file'].

	self readTrackContents: chunkSize.
! !


!MIDIFileReader methodsFor: 'track reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
endAllNotesAt: endTicks
	"End of score; end any notes still sounding."
	"Details: Some MIDI files have missing note-off events, resulting in very long notes. Truncate any such notes encountered."

	| dur |
	activeEvents do: [:e |
		dur := endTicks - e time.
		dur > maxNoteTicks ifTrue: [dur := ticksPerQuarter].  "truncate long note"
		e duration: dur].
	activeEvents := activeEvents species new.
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
endNote: midiKey chan: channel at: endTicks

	| evt |
	evt := activeEvents
		detect: [:e | (e midiKey = midiKey) and: [e channel = channel]]
		ifNone: [^ self].
	evt duration: (endTicks - evt time).
	activeEvents remove: evt ifAbsent: [].
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 1/3/98 09:45'!
isTempoTrack: anEventList
	"Return true if the given event list is non-empty and contains only tempo change events."

	anEventList isEmpty ifTrue: [^ false].
	anEventList do: [:evt | evt isTempoEvent ifFalse: [^ false]].
	^ true
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
metaEventAt: ticks
	"Read a meta event. Event types appear roughly in order of expected frequency."

	| type length tempo |
	type := trackStream next.
	length := self readVarLengthIntFrom: trackStream.

	type = 16r51 ifTrue: [  "tempo"
		tempo := 0.
		length timesRepeat: [tempo := (tempo bitShift: 8) + trackStream next].
		track add: (TempoEvent new tempo: tempo; time: ticks).
		^ self].

	type = 16r2F ifTrue: [  "end of track"
		length = 0 ifFalse: [self error: 'length of end-of-track chunk should be zero'].
		self endAllNotesAt: ticks.
		trackStream skip: length.
		^ self].

	type = 16r58 ifTrue: [  "time signature"
		length = 4 ifFalse: [self error: 'length of time signature chunk should be four'].
		trackStream skip: length.
		^ self].

	type = 16r59 ifTrue: [  "key signature"
		length = 2 ifFalse: [self error: 'length of key signature chunk should be two'].
		trackStream skip: length.
		^ self].

	((type >= 1) and: [type <= 7]) ifTrue: [  "string"
		strings add: (trackStream next: length) asString.
		^ self].

	(  type = 16r21 or:   "mystery; found in MIDI files but not in MIDI File 1.0 Spec"
	 [(type = 16r7F) or:  "sequencer specific meta event"
	 [(type = 16r00) or:  "sequence number"
	 [(type = 16r20)]]])  "MIDI channel prefix"
		ifTrue: [
			trackStream skip: length.
			^ self].

	type = 16r54 ifTrue: [
		"SMPTE offset"
		self report: 'Ignoring SMPTE offset'.
		trackStream skip: length.
		^ self].

	"skip unrecognized meta event"
	self report:
		'skipping unrecognized meta event: ', (type printStringBase: 16),
		' (', length printString, ' bytes)'.
	trackStream skip: length.
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
readTrackContents: byteCount

	| info |
	strings := OrderedCollection new.
	track := OrderedCollection new.
	trackStream := ReadStream on: (stream next: byteCount).
	activeEvents := OrderedCollection new.
	self readTrackEvents.
	(tracks isEmpty and: [self isTempoTrack: track])
		ifTrue: [tempoMap := track asArray]
		ifFalse: [
			"Note: Tracks without note events are currently not saved to
			 eliminate clutter in the score player. In control applications,
			 this can be easily changed by modifying the following test."
			(self trackContainsNotes: track) ifTrue: [
				tracks add: track asArray.
				info := WriteStream on: (String new: 100).
				strings do: [:s | info nextPutAll: s; cr].
				trackInfo add: info contents]].
	strings := track := trackStream := activeEvents := nil.
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
readTrackEvents
	"Read the events of the current track."

	| cmd chan key vel ticks byte length evt |
	cmd := #unknown.
	chan := key := vel := 0.
	ticks := 0.
	[trackStream atEnd] whileFalse: [
		ticks := ticks + (self readVarLengthIntFrom: trackStream).
		byte := trackStream next.
		byte >= 16rF0
			ifTrue: [  "meta or system exclusive event"
				byte = 16rFF ifTrue: [self metaEventAt: ticks].
				((byte = 16rF0) or: [byte = 16rF7]) ifTrue: [  "system exclusive data"
					length := self readVarLengthIntFrom: trackStream.
					trackStream skip: length].
				cmd := #unknown]
			ifFalse: [  "channel message event"
				byte >= 16r80
					ifTrue: [  "new command"
						cmd := byte bitAnd: 16rF0.
						chan := byte bitAnd: 16r0F.
						key := trackStream next]
					ifFalse: [  "use running status"
						cmd == #unknown
							ifTrue: [self error: 'undefined running status; bad MIDI file?'].
						key := byte].

				((cmd = 16rC0) or: [cmd = 16rD0]) ifFalse: [
					"all but program change and channel pressure have two data bytes"
					vel := trackStream next].

				cmd = 16r80 ifTrue: [  "note off"
					self endNote: key chan: chan at: ticks].

				cmd = 16r90 ifTrue: [  "note on"
					vel = 0
						ifTrue: [self endNote: key chan: chan at: ticks]
						ifFalse: [self startNote: key vel: vel chan: chan at: ticks]].

				"cmd = 16A0 -- polyphonic key pressure; skip"

				cmd = 16rB0 ifTrue: [
					evt := ControlChangeEvent new control: key value: vel channel: chan.
					evt time: ticks.
					track add: evt].

				cmd = 16rC0 ifTrue: [
					evt := ProgramChangeEvent new program: key channel: chan.
					evt time: ticks.
					track add: evt].

				"cmd = 16D0 -- channel aftertouch pressure; skip"

				cmd = 16rE0 ifTrue: [
					evt := PitchBendEvent new bend: key + (vel bitShift: 7) channel: chan.
					evt time: ticks.
					track add: evt]
	]].
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
startNote: midiKey vel: vel chan: chan at: startTicks
	"Record the beginning of a note."
	"Details: Some MIDI scores have missing note-off events, causing a note-on to be received for a (key, channel) that is already sounding. If the previous note is suspiciously long, truncate it."

	| newActiveEvents dur noteOnEvent |
	newActiveEvents := nil.
	activeEvents do: [:e |
		((e midiKey = midiKey) and: [e channel = chan]) ifTrue: [
			"turn off key already sounding"
			dur := startTicks - e time.
			dur > maxNoteTicks ifTrue: [dur := ticksPerQuarter].  "truncate"
			e duration: dur.
			newActiveEvents ifNil: [newActiveEvents := activeEvents copy].
			newActiveEvents remove: e ifAbsent: []]].
	newActiveEvents ifNotNil: [activeEvents := newActiveEvents].

	noteOnEvent := NoteEvent new key: midiKey velocity: vel channel: chan.
	noteOnEvent time: startTicks.
	track add: noteOnEvent.
	activeEvents add: noteOnEvent.
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/12/1998 17:15'!
trackContainsNotes: eventList
	"Answer true if the given track contains at least one note event."

	eventList do: [:e | e isNoteEvent ifTrue: [^ true]].
	^ false
! !


!MIDIFileReader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
guessMissingInstrumentNames
	"Attempt to guess missing instrument names from the first program change in that track."

	| progChange instrIndex instrName |
	1 to: tracks size do: [:i |
		(trackInfo at: i) isEmpty ifTrue: [
			progChange := (tracks at: i) detect: [:e | e isProgramChange] ifNone: [nil].
			progChange ifNotNil: [
				instrIndex := progChange program + 1.
				instrName := self class standardMIDIInstrumentNames at: instrIndex.
				trackInfo at: i put: instrName]]].
! !

!MIDIFileReader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
next16BitWord
	"Read a 16-bit positive integer from the input stream, most significant byte first."
	"Assume: Stream has at least two bytes left."

	| n |
	n := stream next.
	^ (n bitShift: 8) + stream next
! !

!MIDIFileReader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
next32BitWord: msbFirst
	"Read a 32-bit positive integer from the input stream."
	"Assume: Stream has at least four bytes left."

	| n |
	n := stream next: 4.
	^msbFirst
		ifTrue:[((n at: 1) bitShift: 24) + ((n at: 2) bitShift: 16) + ((n at: 3) bitShift: 8) + (n at: 4)]
		ifFalse:[((n at: 4) bitShift: 24) + ((n at: 3) bitShift: 16) + ((n at: 2) bitShift: 8) + (n at: 1)]
! !

!MIDIFileReader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
readChunkSize
	"Read a 32-bit positive integer from the next 4 bytes, most significant byte first."
	"Assume: Stream has at least four bytes left."

	| n |
	n := 0.
	1 to: 4 do: [:ignore | n := (n bitShift: 8) + stream next].
	^ n
! !

!MIDIFileReader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
readChunkType
	"Read a chunk ID string from the next 4 bytes."
	"Assume: Stream has at least four bytes left."

	| s |
	s := String new: 4.
	1 to: 4 do: [:i | s at: i put: (stream next) asCharacter].
	^ s
! !

!MIDIFileReader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
readVarLengthIntFrom: aBinaryStream
	"Read a one to four byte positive integer from the given stream, most significant byte first. Use only the lowest seven bits of each byte. The highest bit of a byte is set for all bytes except the last."

	| n byte |
	n := 0.
	1 to: 4 do: [:ignore |
		byte := aBinaryStream next.
		byte < 128 ifTrue: [
			n = 0
				ifTrue: [^ byte]  "optimization for one-byte lengths"
				ifFalse: [^ (n bitShift: 7) + byte]].
		n := (n bitShift: 7) + (byte bitAnd: 16r7F)].

	self error: 'variable length quantity must not exceed four bytes'.
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 12/30/97 06:36'!
report: aString

	Transcript show: aString; cr.
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 2/1/98 19:20'!
riffSkipToMidiChunk
	"This file is a RIFF file which may (or may not) contain a MIDI chunk. Thanks to Andreas Raab for this code."

	| dwLength fourcc |
	"Read length of all data"
	dwLength := self next32BitWord: false.
	"Get RIFF contents type "
	fourcc := self readChunkType.
	fourcc = 'RMID' ifFalse:[^fourcc]. "We can only read RMID files here"
	"Search for data"
	[[fourcc := self readChunkType.
	dwLength := self next32BitWord: false.
	fourcc = 'data'] whileFalse:[
		"Skip chunk - rounded to word boundary"
		stream skip: (dwLength + 1 bitAnd: 16rFFFFFFFE).
		stream atEnd ifTrue:[^'']].
	"Data chunk is raw - look into if it contains MIDI data and skip if not"
	fourcc := self readChunkType.
	fourcc = 'MThd'] whileFalse:[
		"Skip data (chunk - 4bytes) rounded to word boundary"
		stream skip: (dwLength - 3 bitAnd: 16rFFFFFFFE)].
	^fourcc! !

!MIDIFileReader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
scanForMIDIHeader
	"Scan the first part of this file in search of the MIDI header string 'MThd'. Report an error if it is not found. Otherwise, leave the input stream positioned to the first byte after this string."

	| asciiM p lastSearchPosition byte restOfHeader |
	asciiM := $M asciiValue.
	stream skip: -3.
	p := stream position.
	lastSearchPosition := p + 10000.  "search only the first 10000 bytes of the file"
	[p < lastSearchPosition and: [stream atEnd not]] whileTrue: [
		[(byte := stream next) ~= asciiM and: [byte ~~ nil]] whileTrue.  "find the next 'M' or file end"
		restOfHeader := (stream next: 3) asString.
		restOfHeader = 'Thd'
			ifTrue: [^ self]
			ifFalse: [restOfHeader size = 3 ifTrue: [stream skip: -3]].
		p := stream position].

	self error: 'MIDI header chunk not found'.
! !

!MIDIFileReader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
splitIntoTracks
	"Split a type zero MIDI file into separate tracks by channel number."

	| newTempoMap newTracks |
	tracks size = 1 ifFalse: [self error: 'expected exactly one track in type 0 file'].
	tempoMap ifNotNil: [self error: 'did not expect a tempo map in type 0 file'].
	newTempoMap := OrderedCollection new.
	newTracks := (1 to: 16) collect: [:i | OrderedCollection new].
	tracks first do: [:e |
		e isTempoEvent
			ifTrue: [newTempoMap addLast: e]
			ifFalse: [(newTracks at: e channel + 1) addLast: e]].
	newTempoMap size > 0 ifTrue: [tempoMap := newTempoMap asArray].
	newTracks := newTracks select: [:t | self trackContainsNotes: t].
	tracks := newTracks collect: [:t | t asArray].
	trackInfo := trackInfo, ((2 to: tracks size) collect: [:i | '']).
! !

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

MIDIFileReader class
	instanceVariableNames: ''!

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 2/1/98 19:48'!
playFileNamed: fileName

	ScorePlayerMorph
		openOn: (self scoreFromFileNamed: fileName)
		title: (FileDirectory localNameFor: fileName).
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'ls 8/8/1998 03:14'!
playStream: binaryStream

	ScorePlayerMorph
		openOn: (self scoreFromStream: binaryStream)
		title: 'a MIDI stream'
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
playURLNamed: urlString

	| titleString |
	titleString := urlString
		copyFrom: (urlString findLast: [:c | c=$/]) + 1
		to: urlString size.
	ScorePlayerMorph
		openOn: (self scoreFromURL: urlString)
		title: titleString.
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
scoreFromFileNamed: fileName

	| f score |
	f := (FileStream readOnlyFileNamed: fileName) binary.
	score := (self new readMIDIFrom: f) asScore.
	f close.
	^ score
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
scoreFromStream: binaryStream

	|  score |
	score := (self new readMIDIFrom: binaryStream) asScore.
	^ score
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
scoreFromURL: urlString

	| data |
	data := HTTPSocket httpGet: urlString accept: 'audio/midi'.
	data binary.
	^ (self new readMIDIFrom: data) asScore.
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 9/12/1998 19:57'!
standardMIDIInstrumentNames
	"Answer an array of Standard MIDI instrument names."

	^ #(
		'Grand Piano'
		'Bright Piano'
		'Electric Grand Piano'
		'Honky-tonk Piano'
		'Electric Piano 1'
		'Electric Piano 2'
		'Harpsichord'
		'Clavichord'
		'Celesta'
		'Glockenspiel'
		'Music Box'
		'Vibraphone'
		'Marimba'
		'Xylophone'
		'Tubular Bells'
		'Duclimer'
		'Drawbar Organ'
		'Percussive Organ'
		'Rock Organ'
		'Church Organ'
		'Reed Organ'
		'Accordion'
		'Harmonica'
		'Tango Accordion'
		'Nylon Guitar'
		'Steel Guitar'
		'Electric Guitar 1'
		'Electric Guitar 2'
		'Electric Guitar 3'
		'Overdrive Guitar'
		'Distorted Guitar'
		'Guitar Harmonics'
		'Acoustic Bass'
		'Electric Bass 1'
		'Electric Bass 2'
		'Fretless Bass'
		'Slap Bass 1'
		'Slap Bass 2'
		'Synth Bass 1'
		'Synth Bass 2'
		'Violin'
		'Viola'
		'Cello'
		'Contrabass'
		'Tremolo Strings'
		'Pizzicato Strings'
		'Orchestral Harp'
		'Timpani'
		'String Ensemble 1'
		'String Ensemble 2'
		'Synth Strings 1'
		'Synth Strings 2'
		'Choir Ahhs'
		'Choir Oohs'
		'Synth Voice'
		'Orchestra Hit'
		'Trumpet'
		'Trombone'
		'Tuba'
		'Muted Trumpet'
		'French Horn'
		'Brass Section'
		'Synth Brass 1'
		'Synth Brass 2'
		'Soprano Sax'
		'Alto Sax'
		'Tenor Sax'
		'Baritone Sax'
		'Oboe'
		'English Horn'
		'Bassoon'
		'Clarinet'
		'Piccolo'
		'Flute'
		'Recorder'
		'Pan Flute'
		'Blown Bottle'
		'Shakuhachi'
		'Whistle'
		'Ocarina'
		'Lead 1 (square)'
		'Lead 2 (sawtooth)'
		'Lead 3 (calliope)'
		'Lead 4 (chiff)'
		'Lead 5 (charang)'
		'Lead 6 (voice)'
		'Lead 7 (fifths)'
		'Lead 8 (bass+lead)'
		'Pad 1 (new age)'
		'Pad 2 (warm)'
		'Pad 3 (polysynth)'
		'Pad 4 (choir)'
		'Pad 5 (bowed)'
		'Pad 6 (metallic)'
		'Pad 7 (halo)'
		'Pad 8 (sweep)'
		'FX 1 (rain)'
		'FX 2 (soundtrack)'
		'FX 3 (crystals)'
		'FX 4 (atmosphere)'
		'FX 5 (brightness)'
		'FX 6 (goblins)'
		'FX 7 (echoes)'
		'FX 8 (sci-fi)'
		'Sitar'
		'Banjo'
		'Shamisen'
		'Koto'
		'Kalimba'
		'Bagpipe'
		'Fiddle'
		'Shanai'
		'Tinkle Bell'
		'Agogo'
		'Steel Drum'
		'Woodblock'
		'Taiko Drum'
		'Melodic Tom'
		'Synth Drum'
		'Reverse Cymbal'
		'Guitar Fret Noise'
		'Breath Noise'
		'Seashore'
		'Bird Tweet'
		'Telephone Ring'
		'Helicopter'
		'Applause'
		'Gunshot')
! !
Object subclass: #MIDIInputParser
	instanceVariableNames: 'cmdActionTable midiPort received rawDataBuffer sysExBuffer ignoreSysEx startTime timeNow state lastSelector lastCmdByte argByte1 argByte2'
	classVariableNames: 'DefaultMidiTable'
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDIInputParser commentStamp: '<historical>' prior: 0!
I am a parser for a MIDI data stream. I support:

	real-time MIDI recording,
	overdubbing (recording while playing),
	monitoring incoming MIDI, and
	interactive MIDI performances.

Note: MIDI controllers such as pitch benders and breath controllers generate large volumes of data which consume processor time. In cases where this information is not of interest to the program using it, it is best to filter it out as soon as possible. I support various options for doing this filtering, including filtering by MIDI channel and/or by command type.
!


!MIDIInputParser methodsFor: 'accessing' stamp: 'jm 1/6/1999 08:25'!
midiPort

	^ midiPort
! !

!MIDIInputParser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
midiPort: aMIDIPort
	"Use the given MIDI port."

	midiPort := aMIDIPort.
	self clearBuffers.
! !


!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:39'!
ignoreChannel: channel
	"Don't record any events arriving on the given MIDI channel (in the range 1-16)."

	((channel isInteger not) | (channel < 1) | (channel > 16))
		ifTrue: [^ self error: 'bad MIDI channel number', channel printString].

	"two-arg channel messages"
	#(128 144 160 176 224) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreTwo:].

	"one-arg channel messages"
	#(192 208) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreOne:].
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'stephaneducasse 2/4/2006 20:41'!
ignoreCommand: midiCmd
	"Don't record the given MIDI command on any channel."

	| cmd sel | 
	((midiCmd isInteger not) | (midiCmd < 128) | (midiCmd > 255))
		ifTrue: [^ self error: 'bad MIDI command'].

	midiCmd < 240 ifTrue: [  "channel commands; ignore on all channels"
		cmd := midiCmd bitAnd: 2r11110000.
		sel := (#(128 144 160 176 224) includes: cmd)
			ifTrue: [#ignoreTwo:]
			ifFalse: [#ignoreOne:].
		 1 to: 16 do: [:ch | cmdActionTable at: (cmd bitOr: ch - 1) put: sel].
		^ self].

	(#(240 241 244 245 247 249 253) includes: midiCmd) ifTrue: [
		^ self error: 'You can''t ignore the undefined MIDI command: ', midiCmd printString].

	midiCmd = 242 ifTrue: [  "two-arg command"
		cmdActionTable at: midiCmd put: #ignoreTwo:.
		 ^ self].

	midiCmd = 243 ifTrue: [  "one-arg command"
		cmdActionTable at: midiCmd put: #ignoreOne:.
		^ self].

	(#(246 248 250 251 252 254 255) includes: midiCmd) ifTrue:	[  "zero-arg command"
		cmdActionTable at: midiCmd put: #ignore.
		 ^ self].

	"we should not get here"
	self error: 'implementation error'.
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'stephaneducasse 2/4/2006 20:41'!
ignoreSysEx: aBoolean
	"If the argument is true, then ignore incoming system exclusive message."

	ignoreSysEx := aBoolean.
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/9/1998 07:46'!
ignoreTuneAndRealTimeCommands
	"Ignore tuning requests and real-time commands."

	cmdActionTable at: 246 put: #ignoreZero:.	"tune request"
	cmdActionTable at: 248 put: #ignoreZero:.	"timing clock"
	cmdActionTable at: 250 put: #ignoreZero:.	"start"
	cmdActionTable at: 251 put: #ignoreZero:.		"continue"
	cmdActionTable at: 252 put: #ignoreZero:.	"stop/Clock"
	cmdActionTable at: 254 put: #ignoreZero:.	"active sensing"
	cmdActionTable at: 255 put: #ignoreZero:.	"system reset"
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'stephaneducasse 2/4/2006 20:41'!
noFiltering
	"Revert to accepting all MIDI commands on all channels. This undoes any earlier request to filter the incoming MIDI stream."

	cmdActionTable := DefaultMidiTable deepCopy.
	ignoreSysEx := false.
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/9/1998 07:50'!
recordOnlyChannels: channelList
	"Record only MIDI data arriving on the given list of channel numbers (in the range 1-16)."

	channelList do: [:ch |
		((ch isInteger not) | (ch < 1) | (ch > 16))
			ifTrue: [^ self error: 'bad Midi channel specification: ', ch printString]].

	1 to: 16 do: [:ch | (channelList includes: ch) ifFalse: [self ignoreChannel: ch]].
! !


!MIDIInputParser methodsFor: 'midi monitor' stamp: 'jm 10/8/1998 21:22'!
monitor
	"Print MIDI messages to the transcript until any mouse button is pressed."

	self midiDoUntilMouseDown: [:cmd :arg1 :arg2 |
		self printCmd: cmd with: arg1 with: arg2].
! !

!MIDIInputParser methodsFor: 'midi monitor' stamp: 'stephaneducasse 2/4/2006 20:41'!
printCmd: cmdByte with: arg1 with: arg2
	"Print the given MIDI command."

	| cmd ch bend |
	cmdByte < 240
		ifTrue: [  "channel message" 
			cmd := cmdByte bitAnd: 2r11110000.
			ch := (cmdByte bitAnd: 2r00001111) + 1]
		ifFalse: [cmd := cmdByte].  "system message"

	cmd = 128 ifTrue: [
		^ Transcript show: ('key up ', arg1 printString, ' vel: ', arg2 printString, ' chan: ', ch printString); cr].
	cmd = 144 ifTrue: [
		^ Transcript show: ('key down: ', arg1 printString, ' vel: ', arg2 printString, ' chan: ', ch printString); cr].
	cmd = 160 ifTrue: [
		^ Transcript show: ('key pressure: ', arg1 printString, ' val: ', arg2 printString, ' chan: ', ch printString); cr].
	cmd = 176 ifTrue: [
		^ Transcript show: ('CC', arg1 printString, ': val: ', arg2 printString, ' chan: ', ch printString); cr].
	cmd = 192 ifTrue: [
		^ Transcript show: ('prog: ', (arg1 + 1) printString, ' chan: ', ch printString); cr].
	cmd = 208 ifTrue: [
		^ Transcript show: ('channel pressure ', arg1 printString, ' chan: ', ch printString); cr].
	cmd = 224 ifTrue: [
		bend := ((arg2 bitShift: 7) + arg1) - 8192.
		^ Transcript show: ('bend: ', bend printString, ' chan: ', ch printString); cr].

	cmd = 240 ifTrue: [
		^ Transcript show: ('system exclusive: ', (arg1 at: 1) printString, ' (', arg1 size printString, ' bytes)'); cr].

	Transcript show: 'cmd: ', cmd printString, ' arg1: ', arg1 printString, ' arg2: ', arg2 printString; cr.
! !


!MIDIInputParser methodsFor: 'real-time processing' stamp: 'jm 10/9/1998 07:53'!
midiDo: aBlock
	"Poll the incoming MIDI stream in real time and call the given block for each complete command that has been received. The block takes one argument, which is an array of the form (<time><cmd byte>[<arg1>[<arg2>]]). The number of arguments depends on the command byte. For system exclusive commands, the argument is a ByteArray containing the system exclusive message."

	self processMIDIData.
	[received isEmpty] whileFalse:
		[aBlock value: received removeFirst].
! !

!MIDIInputParser methodsFor: 'real-time processing' stamp: 'stephaneducasse 2/4/2006 20:41'!
midiDoUntilMouseDown: midiActionBlock
	"Process the incoming MIDI stream in real time by calling midiActionBlock for each MIDI event. This block takes three arguments: the MIDI command byte and two argument bytes. One or both argument bytes may be nil, depending on the MIDI command. If not nil, evaluatue idleBlock regularly whether MIDI data is available or not. Pressing any mouse button terminates the interaction."

	| time cmd arg1 arg2 |
	self clearBuffers.
	[Sensor anyButtonPressed] whileFalse: [
		self midiDo: [:item |
			time := item at: 1.
			cmd := item at: 2.
			arg1 := arg2 := nil.
			item size > 2 ifTrue: [
				arg1 := item at: 3.
				item size > 3 ifTrue: [arg2 := item at: 4]].
				midiActionBlock value: cmd value: arg1 value: arg2]].
! !


!MIDIInputParser methodsFor: 'recording' stamp: 'stephaneducasse 2/4/2006 20:41'!
clearBuffers
	"Clear the MIDI record buffers. This should be called at the start of recording or real-time MIDI processing."	

	received := received species new: 5000.
	rawDataBuffer := ByteArray new: 1000.
	sysExBuffer := WriteStream on: (ByteArray new: 100).
	midiPort ifNotNil: [midiPort ensureOpen; flushInput].
	startTime := Time millisecondClockValue.
	state := #idle.
! !

!MIDIInputParser methodsFor: 'recording' stamp: 'stephaneducasse 2/4/2006 20:41'!
processMIDIData
	"Process all MIDI data that has arrived since the last time this method was executed. This method should be called frequently to process, filter, and timestamp MIDI data as it arrives."

	| bytesRead |
	[(bytesRead := midiPort readInto: rawDataBuffer) > 0] whileTrue: [
		timeNow := (midiPort bufferTimeStampFrom: rawDataBuffer) - startTime.
		5 to: bytesRead do: [:i | self processByte: (rawDataBuffer at: i)]].
! !

!MIDIInputParser methodsFor: 'recording' stamp: 'jm 10/8/1998 20:24'!
received
	"Answer my current collection of all MIDI commands received. Items in this list have the form (<time><cmd byte>[<arg1>[<arg2>]]). Note that the real-time processing facility, midiDo:, removes items from this list as it processes them."

	^ received
! !


!MIDIInputParser methodsFor: 'private-other' stamp: 'stephaneducasse 2/4/2006 20:41'!
setMIDIPort: aMIDIPort
	"Initialize this instance for recording from the given MIDI port. Tune and real-time commands are filtered out by default; the client can send noFiltering to receive these messages."

	midiPort := aMIDIPort.
	received := OrderedCollection new.
	self noFiltering.  "initializes cmdActionTable"
	self ignoreTuneAndRealTimeCommands.
! !


!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 18:34'!
endSysExclusive: cmdByte
	"Error!! Received 'end system exclusive' command when not receiving system exclusive data."

	self error: 'unexpected ''End of System Exclusive'' command'.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'stephaneducasse 2/4/2006 20:41'!
ignoreOne: cmdByte
	"Ignore a one argument command."	

	lastCmdByte := cmdByte.
	lastSelector := #ignoreOne:.
	state := #ignore1.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'stephaneducasse 2/4/2006 20:41'!
ignoreTwo: cmdByte
	"Ignore a two argument command."	

	lastCmdByte := cmdByte.
	lastSelector := #ignoreTwo:.
	state := #ignore2.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 07:45'!
ignoreZero: cmdByte
	"Ignore a zero argument command, such as tune request or a real-time message. Stay in the current and don't change active status. Note that real-time messages can arrive between data bytes without disruption."	

	"do nothing"
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'stephaneducasse 2/4/2006 20:41'!
processByte: aByte
	"Process the given incoming MIDI byte and record completed commands."
	"Details: Because this must be fast, it has been hand-tuned. Be careful!!"

	aByte > 247 ifTrue: [  "real-time message; can arrive at any time"
		^ self perform: (cmdActionTable at: aByte) with: aByte].

	#idle = state ifTrue: [
		aByte >= 128
			ifTrue: [  "command byte in idle state: start new command"
				^ self perform: (cmdActionTable at: aByte) with: aByte]
			ifFalse: [  "data byte in idle state: use running status if possible"
				lastCmdByte ifNil: [^ self].  "running status unknown; skip byte"
				"process this data as if it had the last command byte in front of it"
				 self perform: lastSelector with: lastCmdByte.

				"the previous line put us into a new state; we now 'fall through'
				 to process the data byte given this new state."]].

	#ignore1 = state ifTrue: [^ state := #idle].
	#ignore2 = state ifTrue: [^ state := #ignore1].

	#want1of2 = state ifTrue: [
		argByte1 := aByte.
		^ state := #want2of2].

	#want2of2 = state ifTrue: [
		argByte2 := aByte.
		received addLast: (Array with: timeNow with: lastCmdByte with: argByte1 with: argByte2).
		^ state := #idle].

	#want1only = state ifTrue: [
		argByte1 := aByte.
		received addLast: (Array with: timeNow with: lastCmdByte with: argByte1).
		^ state := #idle].

	#sysExclusive = state ifTrue: [
		aByte < 128 ifTrue: [
			"record a system exclusive data byte"
			ignoreSysEx ifFalse: [sysExBuffer nextPut: aByte].
			^ self]
		ifFalse: [
			aByte < 248 ifTrue: [
				"a system exclusive message is terminated by any non-real-time command byte"
				ignoreSysEx ifFalse: [
					received addLast: (Array with: timeNow with: lastCmdByte with: sysExBuffer contents)].
				state := #idle.
				aByte = 247
					ifTrue: [^ self]							"endSysExclusive command, nothing left to do"
					ifFalse: [^ self processByte: aByte]]]].  	"no endSysExclusive; just start the next command"
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'stephaneducasse 2/4/2006 20:41'!
recordOne: cmdByte
	"Record a one argument command at the current time."	

	lastCmdByte := cmdByte.
	lastSelector := #recordOne:.
	state := #want1only.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'stephaneducasse 2/4/2006 20:41'!
recordTwo: cmdByte
	"Record a two argument command at the current time."	

	lastCmdByte := cmdByte.
	lastSelector := #recordTwo:.
	state := #want1of2.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 07:43'!
recordZero: cmdByte
	"Record a zero-byte message, such as tune request or a real-time message. Don't change active status. Note that real-time messages can arrive between data bytes without disruption."	

	received addLast: (Array with: timeNow with: cmdByte).
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'stephaneducasse 2/4/2006 20:41'!
startSysExclusive: cmdByte
	"The beginning of a variable length 'system exclusive' command."

	sysExBuffer resetContents.
	lastCmdByte := nil.  "system exclusive commands clear running status"
	lastSelector := nil.
	state := #sysExclusive.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 17:12'!
undefined: cmdByte
	"We have received an unexpected MIDI byte (e.g., a data byte when we were expecting a command). This should never happen."

	self error: 'unexpected MIDI byte ', cmdByte printString.
! !

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

MIDIInputParser class
	instanceVariableNames: ''!

!MIDIInputParser class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"Build the default MIDI command-byte action table. This table maps MIDI command bytes to the action to be performed when that is received. Note that MIDI data bytes (bytes whose value is < 128) are never used to index into this table."
	"MIDIInputParser initialize"

	DefaultMidiTable := Array new: 255 withAll: #undefined:.
	128 to: 143 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"key off"
	144 to: 159 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"key on"
	160 to: 175 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"polyphonic after-touch"
	176 to: 191 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"control change"
	192 to: 207 do: [:i | DefaultMidiTable at: i put: #recordOne:].		"program change"
	208 to: 223 do: [:i | DefaultMidiTable at: i put: #recordOne:].		"channel after-touch"
	224 to: 239 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"pitch bend"

	DefaultMidiTable at: 240 put: #startSysExclusive:.		"start a system exclusive block"
	DefaultMidiTable at: 241 put: #recordOne:.			"MIDI time code quarter frame"
	DefaultMidiTable at: 242 put: #recordTwo:.			"song position select"
	DefaultMidiTable at: 243 put: #recordOne:.			"song select"
	DefaultMidiTable at: 244 put: #undefined:.
	DefaultMidiTable at: 245 put: #undefined:.
	DefaultMidiTable at: 246 put: #recordZero:.			"tune request"
	DefaultMidiTable at: 247 put: #endSysExclusive:.		"end a system exclusive block"
	DefaultMidiTable at: 248 put: #recordZero:.			"timing clock"
	DefaultMidiTable at: 249 put: #undefined:.
	DefaultMidiTable at: 250 put: #recordZero:.			"start"
	DefaultMidiTable at: 251 put: #recordZero:.			"continue"
	DefaultMidiTable at: 252 put: #recordZero:.			"stop/Clock"
	DefaultMidiTable at: 253 put: #undefined:.
	DefaultMidiTable at: 254 put: #recordZero:.			"active sensing"
	DefaultMidiTable at: 255 put: #recordZero:.			"system reset"
! !


!MIDIInputParser class methodsFor: 'instance creation' stamp: 'jm 10/8/1998 20:29'!
on: aSimpleMIDIPort
	"Answer a new MIDI parser on the given port."

	^ super new setMIDIPort: aSimpleMIDIPort
! !
PianoKeyboardMorph subclass: #MIDIPianoKeyboardMorph
	instanceVariableNames: 'midiPort channel velocity'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!
!MIDIPianoKeyboardMorph commentStamp: '<historical>' prior: 0!
I implement a piano keyboard that can be played with the mouse. I can output to a MIDI port, if MIDI is supported on this platform. I can also spawn controllers for other MIDI parameters, such as pitch bend.
!


!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 15:57'!
closeMIDIPort

	midiPort _ nil.
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 18:11'!
makeMIDIController: evt

	self world activeHand attachMorph:
		(MIDIControllerMorph new midiPort: midiPort).
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 18:00'!
openMIDIPort

	| portNum |
	portNum _ SimpleMIDIPort outputPortNumFromUser.
	portNum ifNil: [^ self].
	midiPort _ SimpleMIDIPort openOnPortNumber: portNum.
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 15:44'!
turnOffNote

	midiPort notNil & soundPlaying notNil ifTrue: [
		soundPlaying isInteger ifTrue: [
			midiPort midiCmd: 16r90 channel: channel byte: soundPlaying byte: 0]].
	soundPlaying _ nil.
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 16:25'!
turnOnNote: midiKey

	midiPort midiCmd: 16r90 channel: channel byte: midiKey byte: velocity.
	soundPlaying _ midiKey.
! !


!MIDIPianoKeyboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:55'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	SimpleMIDIPort midiIsSupported
		ifTrue: [midiPort _ SimpleMIDIPort openDefault].
	channel _ 1.
	velocity _ 100! !


!MIDIPianoKeyboardMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:50'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	midiPort
		ifNil: [aCustomMenu add: 'play via MIDI' translated action: #openMIDIPort]
		ifNotNil: [
			aCustomMenu add: 'play via built in synth' translated action: #closeMIDIPort.
			aCustomMenu add: 'new MIDI controller' translated action: #makeMIDIController:].
! !


!MIDIPianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:40'!
mouseDownPitch: midiKey event: event noteMorph: noteMorph

	midiPort ifNil: [^ super mouseDownPitch: midiKey-1 event: event noteMorph: noteMorph].
	noteMorph color: playingKeyColor.
	soundPlaying
		ifNil: [midiPort ensureOpen]
		ifNotNil: [self turnOffNote].
	self turnOnNote: midiKey + 23.
! !

!MIDIPianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:41'!
mouseUpPitch: midiKey event: event noteMorph: noteMorph

	midiPort ifNil: [
		^ super mouseUpPitch: midiKey event: event noteMorph: noteMorph].

	noteMorph color:
		((#(0 1 3 5 6 8 10) includes: midiKey \\ 12)
			ifTrue: [whiteKeyColor]
			ifFalse: [blackKeyColor]).
	soundPlaying ifNotNil: [self turnOffNote].
! !
Object subclass: #MIDIScore
	instanceVariableNames: 'tracks trackInfo ambientTrack tempoMap ticksPerQuarterNote'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDIScore commentStamp: '<historical>' prior: 0!
A MIDIScore is a container for a number of MIDI tracks as well as an ambient track for such things as sounds, book page triggers and other related events.!


!MIDIScore methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
durationInTicks
	
	| t |
	t := 0.
	tracks, {self ambientTrack} do:
		[:track |
		track do:
			[:n | (n isNoteEvent)
				ifTrue: [t := t max: n endTime]
				ifFalse: [t := t max: n time]]].
	^ t
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/3/98 07:36'!
tempoMap

	^ tempoMap
! !

!MIDIScore methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
tempoMap: tempoEventList

	tempoEventList ifNil: [
		tempoMap := #().
		^ self].
	tempoMap := tempoEventList asArray.
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/3/98 07:37'!
ticksPerQuarterNote

	^ ticksPerQuarterNote
! !

!MIDIScore methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
ticksPerQuarterNote: anInteger

	ticksPerQuarterNote := anInteger.
! !

!MIDIScore methodsFor: 'accessing' stamp: 'di 10/21/2000 10:02'!
trackInfo

	^ trackInfo ifNil: [tracks collect: [:i | String new]]
! !

!MIDIScore methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
trackInfo: trackInfoList

	trackInfo := trackInfoList asArray.
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/3/98 08:15'!
tracks

	^ tracks
! !

!MIDIScore methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
tracks: trackList

	tracks := trackList asArray collect: [:trackEvents | trackEvents asArray].
	self ambientTrack.  "Assure it's not nil"! !


!MIDIScore methodsFor: 'ambient track' stamp: 'stephaneducasse 2/4/2006 20:41'!
addAmbientEvent: evt
	| i |
	i := ambientTrack findFirst: [:e | e time >= evt time].
	i = 0 ifTrue: [^ ambientTrack := ambientTrack , (Array with: evt)].
	ambientTrack := ambientTrack copyReplaceFrom: i to: i-1 with: (Array with: evt)! !

!MIDIScore methodsFor: 'ambient track' stamp: 'stephaneducasse 2/4/2006 20:41'!
ambientEventAfter: eventIndex ticks: scoreTicks
	| evt |
	(ambientTrack == nil or: [eventIndex > ambientTrack size]) ifTrue: [^ nil].
	evt := ambientTrack at: eventIndex.
	evt time <= scoreTicks ifTrue: [^ evt].
	^ nil! !

!MIDIScore methodsFor: 'ambient track' stamp: 'stephaneducasse 2/4/2006 20:41'!
ambientTrack
	^ ambientTrack ifNil: [ambientTrack := Array new]! !

!MIDIScore methodsFor: 'ambient track' stamp: 'md 12/12/2003 16:21'!
eventMorphsDo: aBlock
	"Evaluate aBlock for all morphs related to the ambient events."

	ambientTrack == nil ifTrue: [^ self].
	ambientTrack do: [:evt | evt morph ifNotNilDo: aBlock].
! !

!MIDIScore methodsFor: 'ambient track' stamp: 'di 10/25/2000 22:24'!
eventMorphsWithTimeDo: aBlock
	"Evaluate aBlock for all morphs and times related to the ambient events."

	ambientTrack == nil ifTrue: [^ self].
	ambientTrack do: [:evt | evt morph ifNotNil: [aBlock value: evt morph value: evt time]].
! !

!MIDIScore methodsFor: 'ambient track' stamp: 'stephaneducasse 2/4/2006 20:41'!
removeAmbientEventWithMorph: aMorph
	| i |
	i := ambientTrack findFirst: [:e | e morph == aMorph].
	i = 0 ifTrue: [^ self].
	ambientTrack := ambientTrack copyReplaceFrom: i to: i with: Array new! !


!MIDIScore methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:41'!
appendEvent: noteEvent fullDuration: fullDuration at: selection
	"It is assumed that the noteEvent already has the proper time"

	| track noteLoc |
	track := tracks at: selection first.
	noteLoc := selection third + 1.
	noteEvent midiKey = -1
		ifTrue: [noteLoc := noteLoc - 1]
		ifFalse: ["If not a rest..."
				track := track copyReplaceFrom: noteLoc to: noteLoc - 1
								with: (Array with: noteEvent)].
	track size >= (noteLoc + 1) ifTrue:
		["Adjust times of following events"
		noteLoc + 1 to: track size do:
			[:i | (track at: i) adjustTimeBy: fullDuration]].
	tracks at: selection first put: track! !

!MIDIScore methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:41'!
cutSelection: selection

	| track selStartTime delta |
	track := tracks at: selection first.
	selStartTime := (track at: selection second) time.
	track := track copyReplaceFrom: selection second to: selection third with: Array new.
	track size >=  selection second ifTrue:
		["Adjust times of following events"
		delta := selStartTime - (track at: selection second) time.
		selection second to: track size do:
			[:i | (track at: i) adjustTimeBy: delta]].
	tracks at: selection first put: track! !

!MIDIScore methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:41'!
eventForTrack: trackIndex after: eventIndex ticks: scoreTick

	| track evt |
	track := tracks at: trackIndex.
	eventIndex > track size ifTrue: [^ nil].
	evt := track at: eventIndex.
	evt time > scoreTick ifTrue: [^ nil].
	^ evt
! !

!MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 16:06'!
gridToNextQuarterNote: tickTime

	^ self gridToQuarterNote: tickTime + ticksPerQuarterNote! !

!MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 14:55'!
gridToQuarterNote: tickTime

	^ tickTime truncateTo: ticksPerQuarterNote! !

!MIDIScore methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:41'!
gridTrack: trackIndex toQuarter: quarterDelta at: indexInTrack

	| track selStartTime delta |
	track := tracks at: trackIndex.
	selStartTime := (track at: indexInTrack) time.
	delta := (self gridToQuarterNote: selStartTime + (quarterDelta*ticksPerQuarterNote))
				- selStartTime.
	indexInTrack to: track size do:
		[:i | (track at: i) adjustTimeBy: delta].
! !

!MIDIScore methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:41'!
insertEvents: events at: selection

	| track selStartTime delta |
	track := tracks at: selection first.
	selection second = 0
		ifTrue: [selStartTime := 0.
				selection at: 2 put: 1]
		ifFalse: [selStartTime := (track at: selection second) time].
	track := track copyReplaceFrom: selection second to: selection second - 1
				with: (events collect: [:e | e copy]).
	track size >=  (selection second + events size) ifTrue:
		["Adjust times of following events"
		delta := selStartTime - (track at: selection second) time.
		selection second to: selection second + events size - 1 do:
			[:i | (track at: i) adjustTimeBy: delta].
		delta := (self gridToNextQuarterNote: (track at: selection second + events size - 1) endTime)
					- (track at: selection second + events size) time.
		selection second + events size to: track size do:
			[:i | (track at: i) adjustTimeBy: delta].
		].
	tracks at: selection first put: track! !

!MIDIScore methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:41'!
jitterStartAndEndTimesBy: mSecs

	| r range halfRange oldEnd newEnd newStart |
	r := Random new.
	range := 2.0 * mSecs.
	halfRange := mSecs.
	tracks do: [:t |
		t do: [:e |
			e isNoteEvent ifTrue: [
				oldEnd := e time + e duration.
				newEnd := oldEnd + ((r next * range) asInteger - halfRange).
				newStart := e time + ((r next * range) asInteger - halfRange).
				e time: newStart.
				e duration: (newEnd - newStart)]]].

				! !


!MIDIScore methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	tracks := #().
	ambientTrack := Array new.
	tempoMap := #().
	ticksPerQuarterNote := 100.
! !


!MIDIScore methodsFor: 'playing' stamp: 'di 10/22/2000 12:40'!
pauseFrom: scorePlayer
	self eventMorphsDo: [:p | p pauseFrom: scorePlayer]! !

!MIDIScore methodsFor: 'playing' stamp: 'di 10/22/2000 12:40'!
resetFrom: scorePlayer
	self eventMorphsDo: [:p | p resetFrom: scorePlayer]! !

!MIDIScore methodsFor: 'playing' stamp: 'di 10/22/2000 12:39'!
resumeFrom: scorePlayer
	self eventMorphsDo: [:p | p resumeFrom: scorePlayer]! !
Object subclass: #MIDISynth
	instanceVariableNames: 'midiParser channels process'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDISynth commentStamp: '<historical>' prior: 0!
I implement a simple real-time MIDI synthesizer on platforms that support MIDI input. I work best on platforms that allow the sound buffer to be made very short--under 50 milliseconds is good and under 20 milliseconds is preferred (see below). The buffer size is changed by modifying the class initialization method of SoundPlayer and executing the do-it there to re-start the sound player.

Each instance of me takes input from a single MIDI input port. Multiple instances of me can be used to handle multiple MIDI input ports. I distribute incoming commands among my sixteen MIDISynthChannel objects. Most of the interpretation of the MIDI commands is done by these channel objects. 

Buffer size notes: At the moment, most fast PowerPC Macintosh computers can probably work with buffer sizes down to 50 milliseconds, and the Powerbook G3 works down to about 15 milliseconds. You will need to experiment to discover the minimum buffer size that does not result in clicking during sound output. (Hint: Be sure to turn off power cycling on your Powerbook. Other applications and extensions can steal cycles from Squeak, causing intermittent clicking. Experimentation may be necessary to find a configuration that works for you.)
!


!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 22:16'!
channel: i

	^ channels at: i
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:50'!
closeMIDIPort

	midiParser midiPort ifNil: [^ self].
	midiParser midiPort close.
	midiParser midiPort: nil.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	midiParser := MIDIInputParser on: nil.
	channels := (1 to: 16) collect: [:ch | MIDISynthChannel new initialize].
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:13'!
instrumentForChannel: channelIndex

	^ (channels at: channelIndex) instrument
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:14'!
instrumentForChannel: channelIndex put: aSoundProto

	(channels at: channelIndex) instrument: aSoundProto.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:27'!
isOn

	^ process notNil
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 21:52'!
midiParser

	^ midiParser
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:26'!
midiPort

	^ midiParser midiPort
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:32'!
midiPort: aMIDIPortOrNil

	midiParser midiPort: aMIDIPortOrNil.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/13/1998 12:09'!
midiTrackingLoop

	midiParser clearBuffers.
	[true] whileTrue: [
		self processMIDI ifFalse: [(Delay forMilliseconds: 5) wait]].
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 20:12'!
mutedForChannel: channelIndex put: aBoolean

	^ (channels at: channelIndex) muted: aBoolean
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 19:45'!
panForChannel: channelIndex

	^ (channels at: channelIndex) pan
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 19:45'!
panForChannel: channelIndex put: newPan

	(channels at: channelIndex) pan: newPan.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
processMIDI
	"Process some MIDI commands. Answer true if any commands were processed."

	| didSomething cmdByte byte1 byte2 cmd chan |
	didSomething := false.
	midiParser midiDo: [:item |
		didSomething := true.
		cmdByte := item at: 2.
		byte1 := byte2 := nil.
		item size > 2 ifTrue: [
			byte1 := item at: 3.
			item size > 3 ifTrue: [byte2 := item at: 4]].
		cmdByte < 240
			ifTrue: [  "channel message" 
				cmd := cmdByte bitAnd: 2r11110000.
				chan := (cmdByte bitAnd: 2r00001111) + 1.
				(channels at: chan) doChannelCmd: cmd byte1: byte1 byte2: byte2]
			ifFalse: [  "system message"
				"process system messages here"
			]].
	^ didSomething
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 14:14'!
processMIDIUntilMouseDown
	"Used for debugging. Do MIDI processing until the mouse is pressed."

	midiParser clearBuffers.
	[Sensor anyButtonPressed] whileFalse: [self processMIDI].
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
setAllChannelMasterVolumes: aNumber

	| vol |
	vol := (aNumber asFloat min: 1.0) max: 0.0.
	channels do: [:ch | ch masterVolume: vol].
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
startMIDITracking

	midiParser ifNil: [^ self].
	midiParser midiPort ifNil: [^ self].
	midiParser midiPort ensureOpen.
	self stopMIDITracking.
	SoundPlayer useShortBuffer.
	process := [self midiTrackingLoop] newProcess.
	process priority: Processor userInterruptPriority.
	process resume.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopMIDITracking

	process ifNotNil: [
		process terminate.
		process := nil].
	SoundPlayer shutDown; initialize.  "revert to normal buffer size"
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:40'!
volumeForChannel: channelIndex

	^  (channels at: channelIndex) masterVolume
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:40'!
volumeForChannel: channelIndex put: newVolume

	(channels at: channelIndex) masterVolume: newVolume.
! !

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

MIDISynth class
	instanceVariableNames: ''!

!MIDISynth class methodsFor: 'examples' stamp: 'stephaneducasse 2/4/2006 20:41'!
example
	"Here's one way to run the MIDI synth. It will get a nice Morphic UI later. Click the mouse to stop running it. (Mac users note: be sure you have MIDI interface adaptor plugged in, or Squeak will hang waiting for the external clock signal.)."
	"MIDISynth example"

	| portNum synth |
	portNum := SimpleMIDIPort inputPortNumFromUser.
	portNum ifNil: [^ self].
	SoundPlayer useShortBuffer.
	synth := MIDISynth new
		midiPort: (SimpleMIDIPort openOnPortNumber: portNum).
	synth midiParser ignoreCommand: 224.  "filter out pitch bends"
	1 to: 16 do: [:i |
		(synth channel: i) instrument:
 			 (AbstractSound soundNamed: 'oboe1')].
	1 to: 16 do: [:ch | synth volumeForChannel: ch put: 0.2].

	synth processMIDIUntilMouseDown.
	SoundPlayer shutDown; initialize.  "revert to normal buffer size"
! !
Object subclass: #MIDISynthChannel
	instanceVariableNames: 'channel instrument muted masterVolume channelVolume pan pitchBend activeSounds'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDISynthChannel commentStamp: '<historical>' prior: 0!
I implement one polyphonic channel of a 16-channel MIDI synthesizer. Many MIDI commands effect all the notes played on a particular channel, so I record the state for a single channel, including a list of notes currently playing.

This initial implementation is extremely spartan, having just enough functionality to play notes. Things that are not implemented include:

  1. program changes
  2. sustain pedal
  3. aftertouch (either kind)
  4. most controllers
  5. portamento
  6. mono-mode
!


!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 09:45'!
instrument

	^ instrument
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
instrument: aSound

	instrument := aSound.
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 09:47'!
masterVolume

	^ masterVolume
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
masterVolume: aNumber
	"Set the master volume the the given value (0.0 to 1.0)."

	masterVolume := aNumber asFloat.
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 20:10'!
muted

	^ muted
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
muted: aBoolean

	muted := aBoolean.
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 19:43'!
pan

	^ pan
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
pan: aNumber
	"Set the left-right pan to the given value (0.0 to 1.0)."

	pan := aNumber asFloat.
! !


!MIDISynthChannel methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	instrument := FMSound default.
	muted := false.
	masterVolume := 0.5.
	channelVolume := 1.0.
	pan := 0.5.
	pitchBend := 0.0.
	activeSounds := OrderedCollection new.
! !


!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 15:40'!
channelPressure: newPressure
	"Handle a channel pressure (channel aftertouch) change."

	self newVolume: newPressure.
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:48'!
control: control value: newValue
	"Handle a continuous controller change."

	control = 2 ifTrue: [self newVolume: newValue].  "breath controller"
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:44'!
doChannelCmd: cmdByte byte1: byte1 byte2: byte2
	"Dispatch a channel command with the given arguments."
	"Details: Cases appear in order of expected frequency, most frequent cases first."

	cmdByte = 144 ifTrue: [
		byte2 = 0
			ifTrue: [^ self keyUp: byte1 vel: 0]
			ifFalse: [^ self keyDown: byte1 vel: byte2]].
	cmdByte = 128 ifTrue: [^ self keyUp: byte1 vel: byte2].
	cmdByte = 224 ifTrue: [^ self pitchBend: ((byte2 bitShift: 7) + byte1) - 8192].
	cmdByte = 176 ifTrue: [^ self control: byte1 value: byte2].
	cmdByte = 208 ifTrue: [^ self channelPressure: byte1].
	cmdByte = 160 ifTrue: [^ self key: byte1 pressure: byte2].
	cmdByte = 192 ifTrue: [^ self programChange: byte1].
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:49'!
key: key pressure: press
	"Handle a key pressure (polyphonic aftertouch) change. Rarely implemented."

	"Do nothing for now."
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'stephaneducasse 2/4/2006 20:41'!
keyDown: key vel: vel
	"Handle a key down event with non-zero velocity."

	| pitch snd |
	muted ifTrue: [^ self].
	pitch := AbstractSound pitchForMIDIKey: key.
	snd := instrument
		soundForPitch: pitch
		dur: 10000.0  "sustain a long time, or until turned off"
		loudness: masterVolume * channelVolume * (self convertVelocity: vel).
	snd := (MixedSound new add: snd pan: pan) reset.
	SoundPlayer resumePlaying: snd quickStart: false.
	activeSounds add: (Array with: key with: snd with: pitch).
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'stephaneducasse 2/4/2006 20:41'!
keyUp: key vel: vel
	"Handle a key up event."

	| snd |
	activeSounds copy do: [:entry |
		(entry at: 1) = key ifTrue: [
			snd := entry at: 2.
			snd stopGracefully.
			activeSounds remove: entry]].
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 1/11/1999 11:32'!
pitchBend: bend
	"Handle a pitch-bend change."

	self adjustPitch: bend.
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:50'!
programChange: newProgram
	"Handle a program (instrument) change."

	"Do nothing for now."
! !


!MIDISynthChannel methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
adjustPitch: bend
	"Handle a pitch-bend change."

	| snd pitchAdj centerPitch |
	pitchBend := bend.
	pitchAdj := 2.0 raisedTo: (bend asFloat / 8192.0) / 6.0.
	activeSounds copy do: [:entry |
		snd := entry at: 2.
		centerPitch := entry at: 3.
		snd pitch: pitchAdj * centerPitch.
		snd internalizeModulationAndRatio].
! !

!MIDISynthChannel methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
convertVelocity: valueByte
	"Map a value in the range 0..127 to a volume in the range 0.0..1.0."
	"Details: A quadratic function seems to give a good keyboard feel."

	| r |
	r := (valueByte * valueByte) / 12000.0.
	r > 1.0 ifTrue: [^ 1.0].
	r < 0.08 ifTrue: [^ 0.08].
	^ r
! !

!MIDISynthChannel methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
newVolume: valueByte
	"Set the channel volume to the level given by the given number in the range 0..127."

	| snd newVolume |
	channelVolume := valueByte asFloat / 127.0.
	newVolume := masterVolume * channelVolume.
	activeSounds do: [:entry |
		snd := entry at: 2.
		snd adjustVolumeTo: newVolume overMSecs: 10].
! !
Object subclass: #MIMEDocument
	instanceVariableNames: 'mainType subType content url'
	classVariableNames: 'MIMEdatabase'
	poolDictionaries: ''
	category: 'Network-Url'!
!MIMEDocument commentStamp: '<historical>' prior: 0!
a MIME object, along with its type and the URL it was found at (if any)!


!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:49'!
content
	"Answer the receiver's raw data."

	^ content! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:46'!
contentStream
	"Answer a RWBinaryOrTextStream on the contents."

	^ (RWBinaryOrTextStream with: self content) reset! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'!
contentType
	"Answer the MIME contents type."

	^ self mainType , '/' , self subType! !

!MIMEDocument methodsFor: 'accessing' stamp: 'ar 8/23/2001 22:38'!
contents
	"Compatibility with stream protocol"
	^self content! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:47'!
mainType
	^ mainType! !

!MIMEDocument methodsFor: 'accessing' stamp: 'mdr 5/7/2001 11:47'!
parts

	"Return the parts of this message.  There is a far more reliable implementation of parts in MailMessage, but for now we are continuing to use this implementation"

	| parseStream currLine separator msgStream messages |
	self isMultipart ifFalse: [^ #()].
	parseStream _ ReadStream on: self content.
	currLine _ ''.
	['--*' match: currLine]
		whileFalse: [currLine _ parseStream nextLine].
	separator _ currLine copy.
	msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator.
	messages _ OrderedCollection new.
	[parseStream atEnd]
		whileFalse: 
			[messages add: msgStream upToEnd.
			msgStream skipThisLine].
	^ messages collect: [:e | MailMessage from: e]
! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:47'!
subType
	^ subType! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'!
type
	"Deprecated. Use contentType instead."

	^ self contentType! !


!MIMEDocument methodsFor: 'as yet unclassified' stamp: 'ls 4/30/2000 18:45'!
isMultipartAlternative
	"whether the document is in a multipart format where the parts are alternates"
	^ self contentType = 'multipart/alternative'
! !


!MIMEDocument methodsFor: 'converting' stamp: 'ls 6/1/2000 16:24'!
withUrl: newUrl
	"return an identical document except that the URL has been modified"
	^MIMEDocument contentType: self contentType  content: self content url: newUrl! !


!MIMEDocument methodsFor: 'printing' stamp: 'bolot 12/14/2000 17:56'!
printOn: aStream
	aStream nextPutAll: self class name;
		nextPutAll: ' (';
		nextPutAll: self contentType;
		nextPutAll: ', '.
	self content
		ifNotNil: [aStream
			nextPutAll: self content size printString;
			nextPutAll: ' bytes)']
		ifNil: [aStream nextPutAll: 'unknown size)'].! !


!MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:13'!
isGif
	^ self mainType = 'image'
		and: [self subType = 'gif']! !

!MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:15'!
isJpeg
	^ self mainType = 'image'
		and: [self subType = 'jpeg' | (self subType = 'jpg')]! !

!MIMEDocument methodsFor: 'testing' stamp: 'ls 4/30/2000 18:07'!
isMultipart
	^self mainType = 'multipart'! !

!MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:37'!
isPng
	^ self mainType = 'image'
		and: [self subType = 'png']! !

!MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:38'!
isPnm
	^ self mainType = 'image'
		and: [self subType = 'pnm']! !


!MIMEDocument methodsFor: '*MorphicExtras-accessing' stamp: 'sma 4/28/2000 14:48'!
url
	"Answer the URL the receiver was downloaded from.  It may legitimately be nil."

	^ url! !


!MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:11'!
privateContent: aString
	content _ aString! !

!MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:06'!
privateMainType: aString
	mainType _ aString! !

!MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:06'!
privateSubType: aString
	subType _ aString! !

!MIMEDocument methodsFor: 'private' stamp: 'ls 8/12/1998 00:25'!
privateUrl: aUrl
	url _ aUrl! !

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

MIMEDocument class
	instanceVariableNames: ''!

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'!
contentTypeFormData
	^'application/x-www-form-urlencoded'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'!
contentTypeHtml
	^'text/html'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'!
contentTypeMultipart
	^'multipart/form-data'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'!
contentTypePlainText
	^'text/plain'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'!
contentTypeXml
	^'text/xml'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 11/27/1999 14:26'!
guessTypeFromExtension: ext
	"guesses a content type from the extension"
	| extension |
	extension _ ext asString.
	(extension includes: $.) ifTrue: [ ^self defaultContentType].

	MIMEdatabase ifNil: [self resetMIMEdatabase].
	^ MIMEdatabase at: extension ifAbsent: [self defaultContentType].! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 11/27/1999 14:26'!
guessTypeFromName: url
	"guesses a content type from the url"
	| extension |
	extension _ url asString.
	(extension includes: $.) ifFalse: [ ^self defaultContentType].

	extension _ (extension findTokens: '.') last asLowercase.

	MIMEdatabase ifNil: [self resetMIMEdatabase].
	^ MIMEdatabase at: extension ifAbsent: [self defaultContentType].
! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 9/9/1999 15:21'!
linkExtension: ext toType: mimeType
	MIMEdatabase at: ext asString put: mimeType asString! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 11/27/1999 14:26'!
resetMIMEdatabase
	MIMEdatabase _ self extendedMIMEdatabase! !


!MIMEDocument class methodsFor: 'initialize-release' stamp: 'st 9/18/2004 23:36'!
defaultMIMEdatabase
	| d |
	(d _ Dictionary new)
	at: 'html' put: 'text/html';
	at: 'htm' put: 'text/html';
	at: 'xml' put: 'text/xml';
	at: 'txt' put: 'text/plain';
	at: 'c' put: 'text/plain';
	at: 'gif' put: 'image/gif';
	at: 'jpg' put: 'image/jpeg';
	at: 'jpeg' put: 'image/jpeg';
	at: 'gif' put: 'image/gif';
	at: 'png' put: 'image/png';
	at: 'pnm' put: 'image/pnm';
	at: 'xbm' put: 'image/x-xbitmap';
	at: 'mid' put: 'audio/midi';
	at: 'doc' put: 'application/ms-word-document'.
	^d! !

!MIMEDocument class methodsFor: 'initialize-release' stamp: 'ASF 4/30/2005 17:14'!
extendedMIMEdatabase
	| d |
	(d := self defaultMIMEdatabase) 
		 at: 'hqx' put: 'application/mac-binhex40';
		 at: 'cpt' put: 'application/mac-compactpro';
		 at: 'pdf' put: 'application/pdf';
		 at: 'ps' put: 'application/postscript';
		 at: 'ai' put: 'application/postscript';
		 at: 'eps' put: 'application/postscript';
		 at: 'rtf' put: 'text/rtf';
		 at: 'ics' put: 'text/calendar';
		 at: 'bin' put: 'application/octet-stream';
		 at: 'dms' put: 'application/octet-stream';
		 at: 'lha' put: 'application/octet-stream';
		 at: 'lzh' put: 'application/octet-stream';
		 at: 'exe' put: 'application/octet-stream';
		 at: 'class' put: 'application/octet-stream';
		 at: 'zip' put: 'application/zip';
		 at: 'gtar' put: 'application/x-gtar';
		 at: 'swf' put: 'application/x-shockwave-flash';
		 at: 'sit' put: 'application/x-stuffit';
		 at: 'tar' put: 'application/x-tar';
		 at: 'au' put: 'audio/basic';
		 at: 'snd' put: 'audio/basic';
		 at: 'mid' put: 'audio/midi';
		 at: 'midi' put: 'audio/midi';
		 at: 'mpga' put: 'audio/mpeg';
		 at: 'mp2' put: 'audio/mpeg';
		 at: 'mp3' put: 'audio/mpeg';
		 at: 'aiff' put: 'audio/x-aiff';
		 at: 'aif' put: 'audio/x-aiff';
		 at: 'aifc' put: 'audio/x-aiff';
		 at: 'rm' put: 'audio/x-pn-realaudio';
		 at: 'ram' put: 'audio/x-pn-realaudio';
		 at: 'rpm' put: 'audio/x-pn-realaudio-plugin';
		 at: 'ra' put: 'audio/x-realaudio';
		 at: 'wav' put: 'audio/x-wav';
		 at: 'css' put: 'text/css';
		 at: 'mpeg' put: 'video/mpeg';
		 at: 'mpg' put: 'video/mpeg';
		 at: 'mpe' put: 'video/mpeg';
		 at: 'qt' put: 'video/quicktime';
		 at: 'mov' put: 'video/quicktime';
		 at: 'avi' put: 'video/x-msvideo';
		 at: 'movie' put: 'video/x-sgi-movie'.
	^ d! !

!MIMEDocument class methodsFor: 'initialize-release' stamp: 'bolot 9/9/1999 16:48'!
readMIMEdatabaseFrom: someStream
	| d line tokens stream |
	"type/subtype    extension"
	"white spaces are separators"
	"apache conf file format: mime.types"

	"must normalize line endings"
	stream _ ReadStream on: someStream contentsOfEntireFile withSqueakLineEndings.

	d _ Dictionary new.
	[(line _ stream nextLine) isNil not]
		whileTrue: [tokens _ line findTokens: ' 	'.
			(tokens size = 2 and: [line first ~= $#])
				ifTrue: [d at: tokens second put: tokens first]].
	^d! !


!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 7/23/1998 22:59'!
content: aString
	^self contentType: self defaultContentType  content: aString! !

!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 8/5/1998 08:00'!
contentType: aString  content: content
	"create a MIMEObject with the given content-type and content"
	"MIMEObject contentType: 'text/plain' content: 'This is a test'"
	
	| ans idx |
	ans _ self new.
	ans privateContent: content.

	"parse the content-type"
	(aString isNil or: [
		idx _ aString indexOf: $/.
		idx = 0]) 
	ifTrue: [ 
		ans privateMainType: 'application'.  
		ans privateSubType: 'octet-stream' ]
	ifFalse: [ 
		ans privateMainType: (aString copyFrom: 1 to: idx-1).
		ans privateSubType: (aString copyFrom: idx+1 to: aString size) ].

	^ans
! !

!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 8/12/1998 00:26'!
contentType: aString  content: content  url: aUrl
	"create a MIMEObject with the given content-type and content"
	"MIMEObject contentType: 'text/plain' content: 'This is a test'"
	
	| ans idx |
	ans _ self new.
	ans privateContent: content.

	"parse the content-type"
	(aString isNil or: [
		idx _ aString indexOf: $/.
		idx = 0]) 
	ifTrue: [ 
		ans privateMainType: 'application'.  
		ans privateSubType: 'octet-stream' ]
	ifFalse: [ 
		ans privateMainType: (aString copyFrom: 1 to: idx-1).
		ans privateSubType: (aString copyFrom: idx+1 to: aString size) ].

	ans privateUrl: aUrl asUrl.

	^ans
! !

!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 7/23/1998 22:59'!
defaultContentType
	^'application/octet-stream'! !
Object subclass: #MIMEHeaderValue
	instanceVariableNames: 'mainValue parameters'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!MIMEHeaderValue commentStamp: '<historical>' prior: 0!
I contain the value portion of a MIME-compatible header.

I must be only initialized with the value and not the field name.  E.g. in processing
	Subject: This is the subject
the MIMEHeaderValue should be given only 'This is the subject'

For traditional non-MIME headers, the complete value returned for mainValue and paramaters returns an empty collection.

For MIME headers, both mainValue and parameters are used.!


!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:55'!
mainValue
	^mainValue! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:13'!
mainValue: anObject
	mainValue _ anObject! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: 'ls 2/10/2001 13:06'!
parameterAt: aParameter put: value
	parameters at: aParameter put: value! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:18'!
parameters
	^parameters! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:11'!
parameters: anObject
	parameters _ anObject! !


!MIMEHeaderValue methodsFor: 'printing' stamp: 'dvf 4/28/2000 02:48'!
asHeaderValue
	| strm |
	strm _ WriteStream on: (String new: 20).
	strm nextPutAll: mainValue.
	parameters associationsDo: [:e | strm nextPut: $; ; nextPutAll: e key;
		 nextPutAll: '="';
		 nextPutAll: e value , '"'].
	^ strm contents! !

!MIMEHeaderValue methodsFor: 'printing' stamp: 'ls 2/10/2001 12:37'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ': '.
	aStream nextPutAll: self asHeaderValue! !

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

MIMEHeaderValue class
	instanceVariableNames: ''!

!MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:19'!
forField: aFName fromString: aString
	"Create a MIMEHeaderValue from aString.  How it is parsed depends on whether it is a MIME specific field or a generic header field."

	(aFName beginsWith: 'content-') 
		ifTrue: [^self fromMIMEHeader: aString]
		ifFalse: [^self fromTraditionalHeader: aString]
! !

!MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 13:21'!
fromMIMEHeader: aString
	"This is the value of a MIME header field and so is parsed to extract the various parts"

	| parts newValue parms separatorPos parmName parmValue |

	newValue _ self new.

	parts _ ReadStream on: (aString findTokens: ';').
	newValue mainValue: parts next.
	parms _ Dictionary new.
	parts do: 
		[:e | 
		separatorPos _ e findAnySubStr: '=' startingAt: 1. 
		separatorPos <= e size
			ifTrue: 
				[parmName _ (e copyFrom: 1 to: separatorPos - 1) withBlanksTrimmed asLowercase.
				parmValue _ (e copyFrom: separatorPos + 1 to: e size) withBlanksTrimmed withoutQuoting.
				parms at: parmName put: parmValue]].
	newValue parameters: parms.
	^ newValue
! !

!MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:02'!
fromTraditionalHeader: aString
	"This is a traditional non-MIME header (like Subject:) and so should be stored whole"

	| newValue |

	newValue _ self new.
	newValue mainValue: aString.
	newValue parameters: #().
	^newValue.
! !
MIMEDocument subclass: #MIMELocalFileDocument
	instanceVariableNames: 'contentStream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!MIMELocalFileDocument commentStamp: '<historical>' prior: 0!
For local files, we do not read the entire contents unless we absolutely have to.!


!MIMELocalFileDocument methodsFor: 'accessing' stamp: 'ar 4/24/2001 16:28'!
content
	^content ifNil:[content _ contentStream contentsOfEntireFile].! !

!MIMELocalFileDocument methodsFor: 'accessing' stamp: 'ar 4/24/2001 16:27'!
contentStream
	^contentStream ifNil:[super contentStream]! !

!MIMELocalFileDocument methodsFor: 'accessing' stamp: 'ar 4/24/2001 16:27'!
contentStream: aFileStream
	contentStream _ aFileStream.
	content _ nil.! !

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

MIMELocalFileDocument class
	instanceVariableNames: ''!

!MIMELocalFileDocument class methodsFor: 'instance creation' stamp: 'ar 4/24/2001 16:31'!
contentType: aString contentStream: aStream
	^(self contentType: aString content: nil) contentStream: aStream! !
Morph subclass: #MPEGDisplayMorph
	instanceVariableNames: 'frameBuffer mpegFile running desiredFrameRate allowFrameDropping repeat soundTrack volume startMSecs startFrame stopFrame subtitles fullScreen subtitlesDisplayer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Player'!
!MPEGDisplayMorph commentStamp: '<historical>' prior: 0!
I am a simple display screen for an MPEG movie player. My step method advances the movie according to the current frame rate. If necessary, frames as skipped to maintain the desired frame rate. However, since even skipping frames takes time, it may not be possible to achieve fast frame rates with large frame sizes on slow machines.
!


!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
currentFrameScaled
	"Answer a Form containing the current frame scaled to my current size."

	| f |
	f := Form extent: self extent depth: 32.
	frameBuffer ifNil: [^ f fillColor: (Color gray: 0.75)].
	self drawScaledOn: ((FormCanvas on: f) copyOffset: self topLeft negated).
	^ f! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
extent: aPoint
	"Overridden to maintain movie aspect ratio."

	| scale |
	frameBuffer ifNil: [^ super extent: aPoint].
	scale := (aPoint x / frameBuffer width) max: (aPoint y / frameBuffer height).
	scale := scale max: (16 / frameBuffer width).
	super extent: (frameBuffer extent * scale) rounded.
! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 18:57'!
fullFileName
	"answer the receiver's fullFileName"
	^ mpegFile isNil
		ifTrue: ['']
		ifFalse: [mpegFile fileName]! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/7/2004 18:52'!
fullScreen
	"answer whatever the receiver is fullScreen

	Note: comparation with true to make it work with instances created before the introduccion of the variable"
	^ fullScreen == true! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/7/2004 18:56'!
fullScreen: aBoolean 
	"change the receiver's fullScreen"
	fullScreen := aBoolean! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:41'!
isRunning
	"answer whatever the receiver is running"
	^ running! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'mu 6/25/2003 02:41'!
moviePosition
	"Answer a number between 0.0 and 1.0 indicating the current position within the movie."

	mpegFile ifNil: [^ 0.0].
	mpegFile fileHandle ifNil: [^ 0.0].
	(FileStream isAFileNamed: mpegFile fileName) ifFalse: [^0.0].
	mpegFile hasVideo
		ifTrue: [^ ((mpegFile videoGetFrame: 0) asFloat / (mpegFile videoFrames: 0)) min: 1.0].
	soundTrack ifNotNil: [^ soundTrack soundPosition].
	^ 0.0
! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
moviePosition: fraction
	"Jump to the position the given fraction through the movie. The argument is a number between 0.0 and 1.0."

	| frameCount frameIndex |
	self mpegFileIsOpen ifFalse: [^ self].
	self stopPlaying.
	mpegFile hasVideo ifTrue: [
		frameCount := mpegFile videoFrames: 0.
		frameIndex := (frameCount * fraction) truncated - 1.
		frameIndex := (frameIndex max: 0) min: (frameCount - 3).
		mpegFile videoSetFrame: frameIndex stream: 0.
		^ self nextFrame].

	mpegFile hasAudio ifTrue: [
		soundTrack soundPosition: fraction].
! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
repeat
	"Answer the repeat flag."

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

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
repeat: aBoolean
	"Set the repeat flag. If true, the movie will loop back to the beginning when it gets to the end."

	repeat := aBoolean.
! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:13'!
subtitle
	"answer the subtitle for the current frame"
	self hasSubtitles
		ifFalse: [^ ''].
	self mpegFileIsOpen
		ifFalse: [^ ''].
	mpegFile hasVideo
		ifFalse:[^''].
""
^ subtitles
				subtitleForFrame: (mpegFile videoGetFrame: 0)! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:12'!
subtitlesFileShortName
	"answer the receiver's subtitlesFileShortName"
	| fileFull defaultDirFull fileShort |
	self hasSubtitles ifFalse:[^ ''].
	" 
	answer the shortest path to the file to make easier to move  
	morphs with references to files between different platforms"
	fileFull := subtitles fileName.
	""
	defaultDirFull := FileDirectory default fullName.
	fileShort := (fileFull beginsWith: defaultDirFull)
				ifTrue: [fileFull allButFirst: defaultDirFull size + 1]
				ifFalse: [fileFull].
	""
	^ fileShort! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:44'!
subtitlesFileShortName: aString 
	"change the receiver's subtitlesFileShortName, that means 
	open the subtitles file named aString"
	| fullName |
	self mpegFileIsOpen
		ifFalse: [^ self].
	mpegFile hasVideo
		ifFalse: [^ self].
	""
	fullName := FileDirectory default fullNameFor: aString.
	self openSubtitlesFileNamed: fullName! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 11:40'!
totalFrames
	"Answer the total number of frames in this movie."

	mpegFile ifNil: [^ 0].
	mpegFile fileHandle ifNil: [^ 0].
	(FileStream isAFileNamed: mpegFile fileName) ifFalse: [^ 0].
	mpegFile hasVideo ifFalse: [^ 0].
	^ mpegFile videoFrames: 0! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 11:40'!
totalSeconds
	"Answer the total number of seconds in this movie."

	mpegFile ifNil: [^ 0].
	mpegFile fileHandle ifNil: [^ 0].
	(FileStream isAFileNamed: mpegFile fileName) ifFalse: [^ 0].
	mpegFile hasVideo ifFalse: [^ 0].
	^ self totalFrames asFloat / (mpegFile videoFrameRate: 0)! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 21:47'!
videoFileShortName
	"answer the receiver's videoFileShortName"
	| fileFull defaultDirFull fileShort |
	mpegFile isNil
		ifTrue: [^ ''].
	" 
	answer the shortest path to the file to make easier to move  
	morphs with references to files between different platforms"
	fileFull := mpegFile fileName.
	""
	defaultDirFull := FileDirectory default fullName.
	fileShort := (fileFull beginsWith: defaultDirFull)
				ifTrue: [fileFull allButFirst: defaultDirFull size + 1]
				ifFalse: [fileFull].
	""
	^ fileShort! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:45'!
videoFileShortName: aString 
	"change the receiver's videoFileShortName, that means open 
	the video file named aString"
	| fullName |
	self stopPlaying.
	fullName := FileDirectory default fullNameFor: aString.
	self openFileNamed: fullName! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 6/3/2001 14:35'!
volume
	"Answer the sound playback volume."

	^ volume
! !

!MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jdl 3/28/2003 09:41'!
volume: aNumber 
	"Set the sound playback volume to the given level, between 0.0 and 1.0."

	volume := aNumber asFloat.
	volume := volume max: 0.0.
	volume := volume min: 1.0.
	soundTrack ifNotNil: [soundTrack volume: volume]! !


!MPEGDisplayMorph methodsFor: 'commands' stamp: 'jm 11/16/2001 15:39'!
nextFrame
	"Fetch the next frame into the frame buffer."

	mpegFile ifNil: [^ self].
	mpegFile videoReadFrameInto: frameBuffer stream: 0.
	self changed.
! !

!MPEGDisplayMorph methodsFor: 'commands' stamp: 'stephaneducasse 2/4/2006 20:48'!
playUntilPosition: finalPosition
	"Play the movie until the given position, then stop."

	| totalFrames |
	totalFrames := self totalFrames.
	(totalFrames > 0 and: [finalPosition > 0]) ifFalse: [^ self].  "do nothing"
	self startPlaying.
	stopFrame := (finalPosition * totalFrames) asInteger min: totalFrames! !

!MPEGDisplayMorph methodsFor: 'commands' stamp: 'stephaneducasse 2/4/2006 20:48'!
previousFrame
	"Go to the previous frame."

	| n |
	mpegFile ifNil: [^ self].
	running ifTrue: [^ self].
	n := (mpegFile videoGetFrame: 0) - 2.
	n := (n min: ((mpegFile videoFrames: 0) - 3)) max: 0.
	mpegFile videoSetFrame: n stream: 0.
	self nextFrame.
! !

!MPEGDisplayMorph methodsFor: 'commands' stamp: 'stephaneducasse 2/4/2006 20:48'!
rewindMovie
	"Rewind to the beginning of the movie."
	"Details: Seeking by percent or frame number both seem to have problems, so just re-open the file."

	| savedExtent savedRate |
	self mpegFileIsOpen ifFalse: [^ self].
	self stopPlaying.

	"re-open the movie, retaining current extent and frame rate"
	savedExtent := self extent.
	savedRate := desiredFrameRate.
	self openFileNamed: mpegFile fileName.  "recomputes rate and extent"
	self extent: savedExtent.
	desiredFrameRate := savedRate.
! !

!MPEGDisplayMorph methodsFor: 'commands' stamp: 'dgd 10/8/2003 19:10'!
setFrameRate
	"Ask the user to specify the desired frame rate."

	| rateString |
	rateString := FillInTheBlank request: 'Desired frames per second?' translated
				initialAnswer: desiredFrameRate printString.
	rateString isEmpty ifTrue: [^self].
	desiredFrameRate := rateString asNumber asFloat.
	desiredFrameRate := desiredFrameRate max: 0.1! !

!MPEGDisplayMorph methodsFor: 'commands' stamp: 'stephaneducasse 2/4/2006 20:48'!
startPlaying
	"Start playing the movie at the current position."

	| frameIndex |
	self stopPlaying.
	stopFrame := nil.
	self mpegFileIsOpen ifFalse: [^ self].

	(FileStream isAFileNamed: mpegFile fileName) ifFalse: [ | newFileResult newFileName |
		self inform: 'Path changed. Enter new one for: ', (FileDirectory localNameFor: mpegFile fileName).
		newFileResult := StandardFileMenu oldFile.
		newFileName := newFileResult directory fullNameFor: newFileResult name.	
		mpegFile openFile: newFileName].
	
	mpegFile hasAudio
		ifTrue:
			[mpegFile hasVideo ifTrue:
				["set movie frame position from soundTrack position"
				soundTrack reset.  "ensure file is open before positioning"
				soundTrack soundPosition: (mpegFile videoGetFrame: 0) asFloat / (mpegFile videoFrames: 0).
				"now set frame index from the soundtrack position for best sync"
				frameIndex := ((soundTrack millisecondsSinceStart * desiredFrameRate) // 1000).
				frameIndex := (frameIndex max: 0) min: ((mpegFile videoFrames: 0) - 3).
				mpegFile videoSetFrame: frameIndex stream: 0].

			SoundPlayer stopReverb.
			soundTrack volume: volume.
			soundTrack repeat: repeat.
			soundTrack resumePlaying.
			startFrame := startMSecs := 0]
		ifFalse:
			[soundTrack := nil.
			startFrame := mpegFile videoGetFrame: 0.
			startMSecs := Time millisecondClockValue].
	running := true! !

!MPEGDisplayMorph methodsFor: 'commands' stamp: 'stephaneducasse 2/4/2006 20:48'!
stopPlaying
	"Stop playing the movie."

	running := false.
	soundTrack ifNotNil: [soundTrack pause].
! !


!MPEGDisplayMorph methodsFor: 'drawing' stamp: 'jm 3/20/2001 15:57'!
areasRemainingToFill: aRectangle
	"Drawing optimization. Since I completely fill my bounds with opaque pixels, this method tells Morphic that it isn't necessary to draw any morphs covered by me."
	
	^ aRectangle areasOutside: self bounds
! !

!MPEGDisplayMorph methodsFor: 'drawing' stamp: 'jm 11/11/2001 15:49'!
drawOn: aCanvas
	"Draw the current frame image, if there is one. Otherwise, fill screen with gray."

	frameBuffer
		ifNil: [aCanvas fillRectangle: self bounds color: (Color gray: 0.75)]
		ifNotNil: [
			self extent = frameBuffer extent
				ifTrue: [aCanvas drawImage: frameBuffer at: bounds origin]
				ifFalse: [self drawScaledOn: aCanvas]].
! !

!MPEGDisplayMorph methodsFor: 'drawing' stamp: 'stephaneducasse 2/4/2006 20:48'!
drawScaledOn: aCanvas
	"Draw the current frame image scaled to my bounds."

	| outForm destPoint warpBlt |
	((aCanvas isKindOf: FormCanvas) and: [aCanvas form = Display])
		ifTrue: [  "optimization: when canvas is the Display, Warpblt directly to it"
			outForm := Display.
			destPoint := bounds origin + aCanvas origin]
		ifFalse: [
			outForm := Form extent: self extent depth: aCanvas form depth.
			destPoint := 0@0].
	warpBlt := (WarpBlt current toForm: outForm)
		sourceForm: frameBuffer;
		colorMap: (frameBuffer colormapIfNeededForDepth: outForm depth);
		cellSize: 1;  "installs a new colormap if cellSize > 1"
		combinationRule: Form over.
	outForm == Display ifTrue: [warpBlt clipRect: aCanvas clipRect].
	warpBlt
		copyQuad: frameBuffer boundingBox innerCorners
		toRect: (destPoint extent: self extent).
	outForm == Display ifFalse: [
		aCanvas drawImage: outForm at: bounds origin].

! !


!MPEGDisplayMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 20:06'!
handlesKeyboard: evt
	^ true! !

!MPEGDisplayMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 23:02'!
handlesMouseDown: evt 
	^ evt yellowButtonPressed! !

!MPEGDisplayMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 22:37'!
keyStroke: evt 
	| char asc |

	char := evt keyCharacter.
	asc := char asciiValue.
	(char = $o or:[ char = $O])
		ifTrue: 
			["open o/O" 
			self openMPEGFile. ^self].
	(char = $m or:[ char = $M])
		ifTrue: 
			["menu key m/M" 
			self invokeMenu. ^self].
	(char = $r or:[ char = $R])
		ifTrue: 
			["rewind r/R" 
			self rewindMovie. ^self].
	(char = $p or:[ char = $P])
		ifTrue: 
			["play p/P" 
			self startPlaying. ^self].
	(char = $s or:[ char = $S])
		ifTrue: 
			["stop s/S" 
			self stopPlaying. ^self].
	(asc = 28)
		ifTrue: 
			[ "left arrow key" 
			self previousFrame. ^self].
	(asc = 29)
		ifTrue: 
			[ "right arrow key" 
			self nextFrame. ^self].
	(char = $u or:[ char = $U])
		ifTrue: 
			["subtitles file u/U" 
			self openSubtitlesFile. ^self].! !

!MPEGDisplayMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 22:13'!
mouseDown: evt 
	evt yellowButtonPressed
		ifTrue: [^ self invokeMenu].
	super mouseDown: evt! !


!MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/8/2004 22:09'!
closeFile
	"Close my MPEG file, if any."

	mpegFile isNil
		ifFalse: [
			mpegFile closeFile.
			mpegFile := nil.
			frameBuffer := nil].

	subtitles := nil.
	self changed.
! !

!MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'stephaneducasse 2/4/2006 20:48'!
mpegFileIsOpen
	"Answer true if I have an open, valid MPEG file handle. If the handle is not valid, try to re-open the file."

	mpegFile ifNil: [^ false].
	mpegFile fileHandle ifNil: [
		"try to reopen the file, which may have been saved in a snapshot"
		mpegFile openFile: mpegFile fileName.
		mpegFile fileHandle ifNil: [mpegFile := nil]].
	^ mpegFile notNil
! !

!MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/7/2004 19:07'!
openFileNamed: mpegFileName
	"Try to open the MPEG file with the given name. Answer true if successful."

	| e |
	self closeFile.
	(FileDirectory default fileExists: mpegFileName)
		ifFalse: [self inform: ('File not found: {1}' translated format: {mpegFileName}). ^ false].

	(MPEGFile isFileValidMPEG: mpegFileName)
		ifTrue: [mpegFile := MPEGFile openFile: mpegFileName]
		ifFalse: [
			(JPEGMovieFile isJPEGMovieFile: mpegFileName)
				ifTrue: [mpegFile := JPEGMovieFile new openFileNamed: mpegFileName]
				ifFalse: [self inform: ('Not an MPEG or JPEG movie file: {1}' translated format: {mpegFileName}). ^ false]].
	mpegFile fileHandle ifNil: [^ false].

	"initialize soundTrack"
	mpegFile hasAudio
		ifTrue: [soundTrack := mpegFile audioPlayerForChannel: 1]
		ifFalse: [soundTrack := nil].

	mpegFile hasVideo
		ifTrue: [  "set screen size and display first frame"
			desiredFrameRate := mpegFile videoFrameRate: 0.
			soundTrack ifNotNil: [  "compute frame rate from length of audio track"
				desiredFrameRate := (mpegFile videoFrames: 0) / soundTrack duration].
			e := (mpegFile videoFrameWidth: 0)@(mpegFile videoFrameHeight: 0).
			frameBuffer := Form extent: e depth: (Display depth max: 16).
			super extent: e.
			self nextFrame]
		ifFalse: [  "hide screen for audio-only files"
			super extent: 250@0].
! !

!MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'stephaneducasse 2/4/2006 20:48'!
openMPEGFile
	"Invoked by the 'Open' button. Prompt for a file name and try to open that file as an MPEG file."

	| result |
	result := (FileList2 modalFileSelectorForSuffixes: #('mp3' 'mpg' 'mpeg' 'jmv')) .
	result ifNil: [^ self].
	self stopPlaying.
	self openFileNamed: (result fullName).
! !

!MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/8/2004 20:16'!
openSubtitlesFile
	"Invoked by the 'Subtitles' button. Prompt for a file name and 
	try to open that file as a subs file."
	| result |
	self mpegFileIsOpen
		ifFalse: [^ self].
	mpegFile hasVideo
		ifFalse: [self inform: 'select a video file' translated.
			^ self].
	result := FileList2 modalFileSelectorForSuffixes: #('sub' ).
	result
		ifNil: [^ self].
	self openSubtitlesFileNamed: result fullName! !

!MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/8/2004 22:58'!
openSubtitlesFileNamed: aString 
	"Try to open the subtitle file with the given name. Answer true  
	if successful."
	subtitles := nil.
	""
	"try to create the displayer.  it's useful for instances of mpegplayer older than the subtitles support"
	self subtitlesDisplayer.
	""
	(FileDirectory default fileExists: aString)
		ifFalse: [self
				inform: ('File not found: {1}' translated format: {aString}).
			^ false].
	Utilities
		informUser: 'opening the file, please wait' translated
		during: [subtitles := MPEGSubtitles fromFileNamed: aString]! !


!MPEGDisplayMorph methodsFor: 'initialization' stamp: 'dgd 3/8/2004 23:05'!
initialize
	"initialize the state of the receiver"
	super initialize.""
	super extent: 250 @ 0.
	frameBuffer := nil.
	mpegFile := nil.
	running := false.
	desiredFrameRate := 10.0.
	allowFrameDropping := true.
	repeat := false.
	soundTrack := nil.
	volume := 0.5.
	fullScreen := false.
""
self initializeSubtitlesDisplayer! !


!MPEGDisplayMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:48'!
addSoundtrack
	"Add a soundtrack to this JPEG movie."

	| result soundFileName menu compression |
	(mpegFile isKindOf: JPEGMovieFile) ifFalse: [^ self].  "do nothing if not a JPEG movie"

	result := StandardFileMenu oldFile.
	result ifNil: [^ self].
	soundFileName := result directory pathName, FileDirectory slash, result name.

	menu := CustomMenu new title: 'Compression type:'.
	menu addList: #(
		('none (353 kbps)' none)
		('mulaw (176 kbps)' mulaw)
		('adpcm5 (110 kbps)' adpcm5)
		('adpcm4 (88 kbps)' adpcm4)
		('adpcm3 (66 kbps)' adpcm3)
		('gsm (36 kbps)' gsm)).
	compression := menu startUp.
	compression ifNil: [^ self].

	mpegFile closeFile.
	JPEGMovieFile
		addSoundtrack: soundFileName
		toJPEGMovieNamed: mpegFile fileName
		compressionType: compression.
	self openFileNamed: mpegFile fileName.
! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'yo 2/20/2005 20:10'!
createJPEGfromFolderOfFrames
	"Create a new JPEG movie file from an folder of individual frames. Prompt the user for the folder and file names and the quality setting, then do the conversion."

	| result folderName jpegFileName q frameRate |
	result := StandardFileMenu oldFile.
	result ifNil: [^self].
	folderName := result directory pathName.
	jpegFileName := FillInTheBlank request: 'New movie name?' translated.
	jpegFileName isEmpty ifTrue: [^self].
	(jpegFileName asLowercase endsWith: '.jmv') 
		ifFalse: [jpegFileName := jpegFileName , '.jmv'].
	result := FillInTheBlank request: 'Quality level (1 to 100)?' translated.
	q := result ifNil: [50]
				ifNotNil: [(result asNumber rounded max: 1) min: 100].
	result := FillInTheBlank request: 'Frame rate?' translated.
	frameRate := result ifNil: [10]
				ifNotNil: [(result asNumber rounded max: 1) min: 100].
	JPEGMovieFile 
		convertFromFolderOfFramesNamed: folderName
		toJPEGMovieNamed: jpegFileName
		frameRate: frameRate
		quality: q! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'yo 2/20/2005 20:04'!
createJPEGfromMPEG
	"Create a new JPEG movie file from an MPEG movie. Prompt the user for the file names and the quality setting, then do the conversion."

	| result mpegFileName jpegFileName q |
	result := StandardFileMenu oldFile.
	result ifNil: [^self].
	mpegFileName := result directory pathName , FileDirectory slash 
				, result name.
	jpegFileName := FillInTheBlank request: 'New movie name?' translated.
	jpegFileName isEmpty ifTrue: [^self].
	(jpegFileName asLowercase endsWith: '.jmv') 
		ifFalse: [jpegFileName := jpegFileName , '.jmv'].
	result := FillInTheBlank request: 'Quality level (1 to 100)?' translated.
	q := result ifNil: [50]
				ifNotNil: [(result asNumber rounded max: 1) min: 100].
	JPEGMovieFile 
		convertMPEGFileNamed: mpegFileName
		toJPEGMovieNamed: jpegFileName
		quality: q! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'yo 2/20/2005 20:05'!
createJPEGfromSqueakMovie
	"Create a new JPEG movie file from an SqueakTime movie. Prompt the user for the file names and the quality setting, then do the conversion."

	| result squeakMovieFileName jpegFileName q |
	result := StandardFileMenu oldFile.
	result ifNil: [^self].
	squeakMovieFileName := result directory pathName , FileDirectory slash 
				, result name.
	jpegFileName := FillInTheBlank request: 'New movie name?' translated.
	jpegFileName isEmpty ifTrue: [^self].
	(jpegFileName asLowercase endsWith: '.jmv') 
		ifFalse: [jpegFileName := jpegFileName , '.jmv'].
	result := FillInTheBlank request: 'Quality level (1 to 100)?' translated.
	q := result ifNil: [50]
				ifNotNil: [(result asNumber rounded max: 1) min: 100].
	JPEGMovieFile 
		convertSqueakMovieNamed: squeakMovieFileName
		toJPEGMovieNamed: jpegFileName
		quality: q! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 13:34'!
doubleSize
	"change the receiver's extent to double of the normal size"
	self magnifyBy: 2! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 13:34'!
halfSize
	"change the receiver's extent to a half of the normal size"
	self magnifyBy: 1 / 2! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 21:05'!
invokeMenu
	"Invoke a menu of additonal functions."

	| aMenu |
	aMenu := MenuMorph new.
	aMenu defaultTarget: self.

	aMenu addList:	{
		{'open file (o)' translated.			#openMPEGFile}.
		#-.
		{'rewind (r)' translated.				#rewindMovie}.
		{'play (p)' translated.				#startPlaying}.
		{'stop (s)' translated.				#stopPlaying}.
		{'previous frame (<-)' translated.	#previousFrame}.
		{'next frame (->)' translated.		#nextFrame}.
		#-.
	}.

	aMenu addLine.
	aMenu add: 'zoom' translated subMenu: self zoomSubMenu.
	aMenu add: 'subtitles' translated subMenu: self subtitlesSubMenu.
	aMenu add: 'advanced' translated subMenu: self advancedSubMenu.

	aMenu popUpEvent: self world activeHand lastEvent in: self world
! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 13:34'!
normalSize
	"change the receiver's extent to the normal size"
	self magnifyBy: 1! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'jm 12/13/2001 20:48'!
removeAllSoundtracks
	"Remove all soundtracks from this JPEG movie."

	(mpegFile isKindOf: JPEGMovieFile) ifFalse: [^ self].  "do nothing if not a JPEG movie"

	mpegFile closeFile.
	JPEGMovieFile removeSoundtrackFromJPEGMovieNamed: mpegFile fileName.
	self openFileNamed: mpegFile fileName.
! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 22:57'!
setSubtitlesBackgroundColor
	"open a dialog to change the background color of the subtitles"
	self subtitlesDisplayer openAPropertySheet! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 22:57'!
setSubtitlesColor
	"open a dialog to change the color of the subtitles"
	self subtitlesDisplayer changeSubtitlesColor! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 22:57'!
setSubtitlesFont
	"change the subtitles font"
	self subtitlesDisplayer changeFont! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 14:13'!
toggleFullScreen
	"Toggle the fullScreen flag."
	mpegFile isNil
		ifTrue: [^ self].
	mpegFile hasVideo
		ifFalse: [^ self].
	""
	self fullScreen: self fullScreen not.
	""
	"set screen size"
	self fullScreen
		ifTrue: [""
			self extent: Display extent.
			World activeHand newMouseFocus: self.
			self comeToFront]
		ifFalse: [self extent: self normalExtent].
	""
	(self fullScreen
			and: [self owner isKindOf: MPEGMoviePlayerMorph])
		ifTrue: [self owner position: -6 @ -6]
		ifFalse: [self owner == self world
				ifFalse: [self owner position: 0 @ 0] ifTrue:[self position:0@0]].
	""
	self nextFrame! !

!MPEGDisplayMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:48'!
toggleRepeat
	"Toggle the repeat flag."

	repeat := repeat not.
! !


!MPEGDisplayMorph methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:48'!
advanceFrame
	"Advance to the next frame if it is time to do so, skipping frames if necessary."

	| msecs currentFrame desiredFrame framesToAdvance |
	mpegFile hasVideo ifFalse: [^ self].
	soundTrack
		ifNil: [msecs := Time millisecondClockValue - startMSecs]
		ifNotNil: [msecs := soundTrack millisecondsSinceStart - SoundPlayer bufferMSecs].
	desiredFrame := startFrame + ((msecs * desiredFrameRate) // 1000) + 1.
	desiredFrame := desiredFrame min: (mpegFile videoFrames: 0).
	currentFrame := mpegFile videoGetFrame: 0.
	stopFrame ifNotNil:
		[desiredFrame := desiredFrame min: stopFrame.
		currentFrame >= stopFrame ifTrue: [^ self stopPlaying]].
	framesToAdvance := desiredFrame - currentFrame.
	framesToAdvance <= 0 ifTrue: [^ self].
	(allowFrameDropping and: [framesToAdvance > 1]) ifTrue:
		[mpegFile videoDropFrames: framesToAdvance - 1 stream: 0].
	self nextFrame! !

!MPEGDisplayMorph methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:48'!
jpegMovieSize: quality
	"Convert all my frames to a JPEG and measure the total size."

	| jpegSize jpegDecodeTime jpegStream t outForm |
	mpegFile hasVideo ifFalse: [^ self error: 'movie has no video'].
	jpegSize := 0.
	jpegDecodeTime := 0.
	jpegStream := WriteStream on: (ByteArray new: 100000).
	self rewindMovie.

	[(mpegFile videoGetFrame: 0) < (mpegFile videoFrames: 0)] whileTrue: [
		jpegStream reset.
		(JPEGReadWriter2 on: jpegStream)
			nextPutImage: frameBuffer
			quality: quality
			progressiveJPEG: false.
		jpegSize := jpegSize + jpegStream position.
		t := [
			outForm := (JPEGReadWriter2 on: (ReadStream on: jpegStream contents)) nextImage
		] timeToRun.
		jpegDecodeTime := jpegDecodeTime + t.
		outForm display.
		frameBuffer displayAt: (outForm width + 10)@0.
		self nextFrame].

	^ Array with: jpegSize with: jpegDecodeTime with: (mpegFile videoFrames: 0)

! !

!MPEGDisplayMorph methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:48'!
measureMaxFrameRate
	"For testing. Play through the movie as fast as possible, updating the world each time, and report the frame rate."

	| oldFrameRate oldFrameDropping t |
	self rewindMovie.
	oldFrameRate := desiredFrameRate.
	oldFrameDropping := allowFrameDropping.
	desiredFrameRate := 1000.0.
	allowFrameDropping := false.

	self startPlaying.
	t := [[running] whileTrue: [self world doOneCycleNow]] timeToRun.

	desiredFrameRate := oldFrameRate.
	allowFrameDropping := oldFrameDropping.

	^ (mpegFile videoFrames: 0) / (t / 1000.0)
! !


!MPEGDisplayMorph methodsFor: 'stepping' stamp: 'jm 6/3/2001 18:38'!
step
	"If I'm running and the mpegFile is open and has video, advance to the next frame. Stop if we we hit the end of the video."

	running ifFalse: [^ self].
	mpegFile ifNil: [^ self].

	(mpegFile hasVideo and:
	 [(mpegFile videoGetFrame: 0) >= (mpegFile videoFrames: 0)])
		ifTrue: [  "end of video"
			self stopPlaying.
			repeat ifTrue: [
				self rewindMovie.
				self startPlaying]]
		ifFalse: [self advanceFrame].
! !

!MPEGDisplayMorph methodsFor: 'stepping' stamp: 'jm 4/6/2001 08:47'!
stepTime
	"Run my step method as often as possible. Step does very little work if it is not time to advance to the next frame."

	^ 0
! !


!MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 12:46'!
advancedSubMenu
	"private - create the advanced submenu"

	| subMenu |

	subMenu := MenuMorph new.
	subMenu defaultTarget: self.

	repeat
		ifTrue: [subMenu add: 'turn off repeat (now on)' translated action: #toggleRepeat]
		ifFalse: [subMenu add: 'turn on repeat (now off)' translated action: #toggleRepeat].

	subMenu addLine.

	subMenu addList:	{
		{'set frame rate' translated.									#setFrameRate}.
		#-.
		{'create JPEG movie from MPEG' translated.				#createJPEGfromMPEG}.
		{'create JPEG movie from SqueakMovie' translated.		#createJPEGfromSqueakMovie}.
		{'create JPEG movie from folder of frames' translated.	#createJPEGfromFolderOfFrames}
	}.

	(mpegFile isKindOf: JPEGMovieFile) ifTrue: [
		subMenu addLine.
		mpegFile hasAudio
			ifTrue: [subMenu add: 'remove all soundtracks' translated action: #removeAllSoundtracks]
			ifFalse: [subMenu add: 'add soundtrack' translated action: #addSoundtrack]].

	^ subMenu
! !

!MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 22:11'!
hasSubtitles
	"answer if the receiver has subtitles or not"
	^ mpegFile isNil not
		and: [subtitles isNil not]! !

!MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 23:03'!
initializeSubtitlesDisplayer
	"private - builds the subtitle displayer"
	subtitlesDisplayer := MPEGSubtitlesDisplayer on: self selector: #subtitle.
subtitlesDisplayer contents:''.
	self addMorphFront: subtitlesDisplayer.
	^ subtitlesDisplayer! !

!MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 14:12'!
magnifyBy: aNumber 
	"private - scale the video (if any) to a scale of the normalExtent"
	| ne |
	fullScreen := false.""
	ne := self normalExtent.
	ne isNil
		ifFalse: [self extent: (ne * aNumber) rounded]! !

!MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 13:30'!
normalExtent
	"private - answer the extent of the video, if any"
	(mpegFile isNil
			or: [mpegFile hasVideo not])
		ifTrue: [^ nil].
	""
	^ (mpegFile videoFrameWidth: 0)
		@ (mpegFile videoFrameHeight: 0)! !

!MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 22:59'!
subtitlesDisplayer
	"private - answer the receiver's subtitlesDisplayer. create one  
	if needed"
	^ subtitlesDisplayer
		ifNil: [self initializeSubtitlesDisplayer]! !

!MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 22:22'!
subtitlesSubMenu
	"private - create the subtitles submenu"

	| subMenu |

	subMenu := MenuMorph new.
	subMenu defaultTarget: self.
	subMenu add: 'open subtitles file (u)' translated action: #openSubtitlesFile.

	self hasSubtitles
		ifTrue: [
			subMenu addLine.
			subMenu add: 'set subtitles font' translated action: #setSubtitlesFont.
			subMenu add: 'set subtitles color' translated action: #setSubtitlesColor.
			subMenu add: 'set subtitles background color' translated action: #setSubtitlesBackgroundColor].

	^ subMenu
! !

!MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 21:08'!
zoomSubMenu
	"private - create the zoom submenu"

	| subMenu |

	subMenu := MenuMorph new.
	subMenu defaultTarget: self.

	self fullScreen
		ifTrue: [subMenu add: 'turn off full screen' translated action: #toggleFullScreen]
		ifFalse: [subMenu add: 'turn on full screen' translated action: #toggleFullScreen].

	subMenu addLine.
	subMenu add: '50%' action: #halfSize.
	subMenu add: '100%' action: #normalSize.
	subMenu add: '200%' action: #doubleSize.

	^ subMenu
! !
Object subclass: #MPEGFile
	instanceVariableNames: 'pathToFile fileBits fileIndex endianness buffer'
	classVariableNames: 'Registry'
	poolDictionaries: ''
	category: 'Movies-Kernel'!
!MPEGFile commentStamp: '<historical>' prior: 0!
* An interface to LibMPEG3
 * Author: Adam Williams <broadcast@earthling.net>
 * Page: heroine.linuxbox.com
 *
 * Changed for Squeak to work with Squeak and to work on the Macintosh
 * Sept 2000, by John M McIntosh johnmci@smalltalkconsulting.com
 * The smalltalk code and the C code it produces is released under the 
 * Squeak licence. The libmpeg3 C code is co-licenced under either the Squeak licence or
 * the GNU LGPL
!


!MPEGFile methodsFor: 'access' stamp: 'JMM 1/20/2006 18:12'!
buffer
	^buffer! !

!MPEGFile methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
endianness
	^endianness isNil 
		ifTrue: [endianness := SmalltalkImage current endianness] 
		ifFalse: [endianness]! !

!MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 19:04'!
fileHandle
	(Smalltalk externalObjects at: fileIndex ifAbsent: [^nil]) == fileBits 
		ifTrue: [^fileBits]
		ifFalse: [^nil].
! !

!MPEGFile methodsFor: 'access' stamp: 'JMM 9/18/2000 18:38'!
fileName
	^pathToFile! !

!MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 01:54'!
getPercentage
	"Return current location by percentage, 0.0-1.0"
	^self primGetPercentage: self fileHandle ! !

!MPEGFile methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
getTOC: timecode doStreams: streams
	| buffer |
	
	buffer := String new: 64*1024+1.
	self primGenerateToc: self fileHandle useSearch: timecode doStreams: streams buffer: buffer.
	^buffer! !

!MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 01:56'!
getTimeCode
	"Return time code, (float) "
	^self primGetTime: self fileHandle! !

!MPEGFile methodsFor: 'access' stamp: 'JMM 1/20/2006 23:15'!
isBufferBased
	^(buffer == nil) not ! !

!MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 01:53'!
seekPercentage: aFloat
	self primSeekPercentage: self fileHandle percentage: aFloat asFloat ! !

!MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 01:56'!
setMMX: aValue
	" true is set, false is off. May not be supported "
	self primSetMMX: self fileHandle useMMX: aValue  ! !


!MPEGFile methodsFor: 'audio' stamp: 'jm 11/17/2001 08:18'!
audioChannels: aStream
	"Returns -1 if error, otherwise returns audioChannels for stream aStream"
	self hasAudio ifFalse: [^ 0].
	^[self primAudioChannels: self fileHandle stream: aStream] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'!
audioGetSample: aStream
	"Returns number of current sample, or -1 if error"
	self hasAudio ifFalse: [^-1].
	^[(self primGetSample: self fileHandle stream: aStream) asInteger] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'audio' stamp: 'jm 11/17/2001 09:36'!
audioPlayerForChannel: channelNumber
	"Answer a streaming sound for playing the audio channel with the given index."
	"Note: The MP3 player can not yet isolate a single channel from a multi-channel audio stream."

	^ StreamingMP3Sound new initMPEGFile: self streamIndex: 0
! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'!
audioReReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber
	"Used to read other channels after first ReadBuffer 
	Returns -1 if error, otherwise 0"
	self hasAudio ifFalse: [^-1].
	^[self audioReReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber samples: (aBuffer size * aBuffer bytesPerElement // 2)] on: Error do: [-1]! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'!
audioReReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber samples: aSampleNumber
	"Used to read other channels after first ReadBuffer 
	Returns -1 if error, otherwise 0
	Note this call requires passing in the samples to read, ensure you get the number right"
	self hasAudio ifFalse: [^-1].
	^[self primAudioReReadBuffer: self fileHandle  buffer: aBuffer channel: aChannelNumber samples: aSampleNumber stream: aStreamNumber] on: Error do: [-1]! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'!
audioReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber 
	"Returns -1 if error, otherwise 0"
	self hasAudio ifFalse: [^-1].
	^[self audioReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber samples: (aBuffer size* aBuffer bytesPerElement)//2] on: Error do: [-1]! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'!
audioReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber samples: aSampleNumber
	"Returns -1 if error, otherwise 0
	Note this call requires passing in the samples to read, ensure you get the number right"
	self hasAudio ifFalse: [^-1].
	^[self primAudioReadBuffer: self fileHandle  buffer: aBuffer channel: aChannelNumber samples: aSampleNumber stream: aStreamNumber] on: Error do: [-1]! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'!
audioSampleRate: aStream
	"Returns sample rate, or -1 if error"
	self hasAudio ifFalse: [^-1].
	^[self primSampleRate: self fileHandle stream: aStream] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'!
audioSamples: aStream
	"Returns -1 if error, 
	otherwise returns audioSamples for stream aStream"
	self hasAudio ifFalse: [^-1].
	^[(self primAudioSamples: self fileHandle stream: aStream) asInteger] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'!
audioSetSample: aNumber stream: aStream
	"Set number of targeted sample, returns 0 if ok, -1 if failure"
	self hasAudio ifFalse: [^-1].
	^[self primSetSample: self fileHandle sample: aNumber asFloat stream: aStream] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 9/20/2000 01:57'!
endOfAudio: aStream
	"Returns true if end of Audio"
	self hasAudio ifFalse: [^true].
	^self primEndOfAudio: self fileHandle stream: aStream
! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 9/20/2000 01:56'!
hasAudio
	"Returns true if file has audio"
	^self primHasAudio: self fileHandle ! !

!MPEGFile methodsFor: 'audio' stamp: 'JMM 9/20/2000 01:53'!
totalAudioStreams
	"Returns total number of audio streams"
	^self primTotalAudioStreams: self fileHandle 
! !


!MPEGFile methodsFor: 'converting' stamp: 'stephaneducasse 2/4/2006 20:48'!
convertToSqueakMovieFileNamed: fileName 
	"convert the receiver to a squeak-format movie"
	" 
	(MPEGFile openFile:
	'/H/squeak/Small-Land/Demo/media/mazinger:=z:=spanish:=op.mpg') 
	convertToSqueakMovieFileNamed: 'MazingerZ.squeakmovie' 
	"
	| movieFile max w h d frameBuffer |
	movieFile := FileStream newFileNamed: fileName.
	[movieFile binary.
	"no idea what goes here..."
	movieFile nextInt32Put: 0.
	movieFile nextInt32Put: (w := self videoFrameWidth: 0).
	movieFile nextInt32Put: (h := self videoFrameHeight: 0).
	"Depth of form data stored"
	"we really don't know but try to preserve some space"
	movieFile nextInt32Put: (d := 16).
	movieFile nextInt32Put: (max := self videoFrames: 0).
	"min: 100"
	movieFile nextInt32Put: (1000 * 1000
			/ (self videoFrameRate: 0)) rounded.
	"Padding?"
	movieFile
		nextPutAll: (ByteArray new: 128 - movieFile position).
	frameBuffer := Form extent: w @ h depth: d.
	self videoSetFrame: 1 stream: 0.
	'Converting movie...'
		displayProgressAt: Sensor cursorPoint
		from: 1
		to: max
		during: [:bar | 1
				to: max
				do: [:i | 
					bar value: i.
					self videoReadFrameInto: frameBuffer stream: 0.
					frameBuffer display.
					movieFile nextInt32Put: i.
					movieFile nextPutAll: frameBuffer bits]]]
		ensure: [movieFile close]! !


!MPEGFile methodsFor: 'file ops' stamp: 'stephaneducasse 2/4/2006 20:48'!
finalize
	self fileHandle notNil ifTrue: [self primFileClose: self fileHandle].
	self fileHandle = fileBits ifTrue: [Smalltalk unregisterExternalObject: fileIndex].
	fileBits := nil.	
	fileIndex := 0.! !


!MPEGFile methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 01:59'!
closeFile
	self finalize.! !

!MPEGFile methodsFor: 'initialize-release' stamp: 'JMM 1/20/2006 18:11'!
openBuffer: aByteArray
	pathToFile := nil.
	buffer _ aByteArray.
	fileBits := self primFileOpenABuffer: aByteArray size: aByteArray size.
	fileBits notNil ifTrue: 
		[fileIndex := Smalltalk registerExternalObject: fileBits.
		self register.]
	! !

!MPEGFile methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:48'!
openFile: aPath
	pathToFile := aPath.
	fileBits := self primFileOpen: aPath.
	fileBits notNil ifTrue: 
		[fileIndex := Smalltalk registerExternalObject: fileBits.
		self register.]
	! !


!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:19'!
primAudioChannels: aHandle stream: aStream
	<primitive: 'primitiveMPEG3AudioChannels' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/19/2000 13:35'!
primAudioReReadBuffer: aFileHandle  buffer: aBuffer channel: aChannel samples: aSampleNumber stream: aStreamNumber
	<primitive: 'primitiveMPEG3ReReadAudio' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/19/2000 13:31'!
primAudioReadBuffer: aFileHandle  buffer: aBuffer channel: aChannel samples: aSampleNumber stream: aStreamNumber
	<primitive: 'primitiveMPEG3ReadAudio' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:23'!
primAudioSamples: aHandle stream: aStream
	<primitive: 'primitiveMPEG3AudioSamples' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 17:54'!
primDropFrame: aHandle frame: aNumberOfFrames stream: aStream
	<primitive: 'primitiveMPEG3DropFrames' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:50'!
primEndOfAudio: aHandle stream: aStream
	<primitive: 'primitiveMPEG3EndOfAudio' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:51'!
primEndOfVideo: aHandle stream: aStream
	<primitive: 'primitiveMPEG3EndOfVideo' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 13:58'!
primFileClose: aHandle
	"Close the file"
	<primitive: 'primitiveMPEG3Close' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 1/20/2006 17:52'!
primFileOpenABuffer: buffer size: aSize
	"Open the file"
	<primitive: 'primitiveMPEG3OpenABuffer' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 03:56'!
primFileOpen: aPath
	"Open the file"
	<primitive: 'primitiveMPEG3Open' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:52'!
primFrameRate: aHandle stream: aStream
	<primitive: 'primitiveMPEG3FrameRate' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/29/2000 17:29'!
primGenerateToc: fileHandle useSearch: timecode doStreams: streams buffer: aString
	<primitive: 'primitiveMPEG3GenerateToc' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:11'!
primGetFrame: aHandle stream: aStream
	<primitive: 'primitiveMPEG3GetFrame' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:37'!
primGetPercentage: aHandle
	<primitive: 'primitiveMPEG3TellPercentage' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:12'!
primGetSample: aHandle stream: aStream
	<primitive: 'primitiveMPEG3GetSample' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:15'!
primGetTime: aFileHandle
	<primitive: 'primitiveMPEG3GetTime' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:59'!
primHasAudio: aHandle
	<primitive: 'primitiveMPEG3HasAudio' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:59'!
primHasVideo: aHandle
	<primitive: 'primitiveMPEG3HasVideo' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:17'!
primPreviousFrame: aHandle stream: aStream
	<primitive: 'primitiveMPEG3PreviousFrame' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:19'!
primSampleRate: aHandle stream: aStream
	<primitive: 'primitiveMPEG3SampleRate' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:23'!
primSeekPercentage: aHandle percentage: aNumber
	<primitive: 'primitiveMPEG3SeekPercentage' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:27'!
primSetCPUs: aHandle number: aNumber
	"Not support on the macintosh below OS X"
	<primitive: 'primitiveMPEG3SetCpus' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:29'!
primSetFrame: aHandle frame: aFrameNumber stream: aStream
	<primitive: 'primitiveMPEG3SetFrame' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:31'!
primSetMMX: aFileHandle useMMX: aValue  
	<primitive: 'primitiveMPEG3SetMmx' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:35'!
primSetSample: aHandle sample: aSampleNumber stream: aStream
	<primitive: 'primitiveMPEG3SetSample' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:39'!
primTotalAudioStreams: aFileHandle 
	<primitive: 'primitiveMPEG3TotalAStreams' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:40'!
primTotalVideoStreams: aFileHandle 
	<primitive: 'primitiveMPEG3TotalVStreams' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:41'!
primVideoFrames: aFileHandle  stream: aStream
	<primitive: 'primitiveMPEG3VideoFrames' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:41'!
primVideoHeight: aFileHandle  stream: aStream
	<primitive: 'primitiveMPEG3VideoHeight' module: 'Mpeg3Plugin'>
	self primitiveFailed! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 2/26/2006 13:08'!
primVideoReadNextFrameFor: aFileHandle into: aFormBuffer offset: aBufferOffsetInBytes x: x y: y width: width height: height outWidth: aTargetWidth outHeight: aTargetHeight colorModel: colorModel stream: aStream bytesPerRow: aByteCount
	<primitive: 'primitiveMPEG3ReadFrameBufferOffset' module: 'Mpeg3Plugin'>

! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/19/2000 13:28'!
primVideoReadNextFrameFor: aFileHandle into: aFormBuffer x: x y: y width: width height: height outWidth: aTargetWidth outHeight: aTargetHeight colorModel: colorModel stream: aStream bytesPerRow: aByteCount
	<primitive: 'primitiveMPEG3ReadFrame' module: 'Mpeg3Plugin'>

! !

!MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 16:35'!
primVideoWidth: aFileHandle  stream: aStream
	<primitive: 'primitiveMPEG3VideoWidth' module: 'Mpeg3Plugin'>
	self primitiveFailed! !


!MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:54'!
endOfVideo: aStream
	"Returns true if end of video"
	self hasVideo ifFalse: [^true].
	^self primEndOfVideo: self fileHandle stream: aStream
! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:54'!
hasVideo
	"Returns true if file has video"
	^self primHasVideo: self fileHandle ! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:59'!
totalVideoStreams
	"Returns total number of video streams"
	^self primTotalVideoStreams: self fileHandle 
! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'!
videoDropFrames: aNumberOfFrames stream: aStream
	"Returns -1 if setFrame failed"
	self hasVideo ifFalse: [^-1].
	^[self primDropFrame: self fileHandle frame: aNumberOfFrames stream: aStream] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'!
videoFrameHeight: aStream
	"Returns video frame height, -1 if error "
	self hasVideo ifFalse: [^-1].
	^[self primVideoHeight: self fileHandle stream: aStream] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'!
videoFrameRate: aStream
	"Returns video frame rate (float), -1 if error"
	self hasVideo ifFalse: [^-1].
	^[self primFrameRate: self fileHandle stream: aStream] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'!
videoFrameWidth: aStream
	"Returns video frame width, -1 if error"
	self hasVideo ifFalse: [^-1].
	^[self primVideoWidth: self fileHandle stream: aStream] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:58'!
videoFrames: aStream
	"Total number of frames" 
	^(self primVideoFrames: self fileHandle stream: aStream) asInteger
! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'!
videoGetFrame: aStream
	"Returns frame number, or -1 if error"
	self hasVideo ifFalse: [^-1].
	^[(self primGetFrame: self fileHandle stream: aStream) asInteger] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:15'!
videoPreviousFrame: aStream
	"Returns 0 if ok"
	self hasVideo ifFalse: [^-1].
	^[self primPreviousFrame: self fileHandle stream: aStream] on: Error do: [-1]
! !

!MPEGFile methodsFor: 'video' stamp: 'stephaneducasse 2/4/2006 20:48'!
videoReadFrameInto: aForm stream: aStream
	"Read the next video frame from the given stream into the given 16- or 32-bit Form. The movie frame will be scaled to fit the Form if necessary."

	| colorModel bytesPerRow |
	((aForm depth = 16) | (aForm depth = 32)) ifFalse: [self error: 'must use 16- or 32-bit Form'].
	aForm depth = 16
		ifTrue: [
			colorModel := self endianness = #big ifTrue: [14] ifFalse: [16].
			bytesPerRow := 2 * (aForm width roundUpTo: 2)]
		ifFalse: [
			colorModel := self endianness = #big ifTrue: [13] ifFalse: [1].
			bytesPerRow := 4 * aForm width].
 	^ self
		videoReadNextFrameInto: aForm bits
		x: 0 y: 0
		width: (self videoFrameWidth: aStream)
		height: (self videoFrameHeight: aStream)
		outWidth: aForm width
		outHeight: aForm height
		colorModel: colorModel
		stream: aStream
		bytesPerRow: bytesPerRow
! !

!MPEGFile methodsFor: 'video' stamp: 'stephaneducasse 2/4/2006 20:48'!
videoReadNextFrameInto: aFormBuffer x: x y: y width: width height: height outWidth: aTargetWidth outHeight: aTargetHeight colorModel: colorModel stream: aStream bytesPerRow: aByteCount
	"return nonZero if failure "

	self hasVideo ifFalse: [^-1].
	^[self primVideoReadNextFrameFor: self fileHandle into: aFormBuffer x: x y: y width: width height: height outWidth: aTargetWidth outHeight: aTargetHeight colorModel: colorModel stream: aStream bytesPerRow: aByteCount] on: Error do: [-1]

"/* Supported color models for mpeg3:=read:=frame */
#define MPEG3:=RGB565 2
#define MPEG3:=RGB555 14  //JMM for mac
#define MPEG3:=RGBI555 16  //SVP for intel
#define MPEG3:=BGR888 0
#define MPEG3:=BGRA8888 1
#define MPEG3:=RGB888 3
#define MPEG3:=RGBA8888 4  
#define MPEG3:=ARGB8888 13  //JMM for mac
#define MPEG3:=RGBA16161616 5

/* Color models for the 601 to RGB conversion */
/* 601 not implemented for scalar code */
#define MPEG3:=601:=RGB565 11
#define MPEG3:=601:=RGB555 15 //JMM for Squeak
#define MPEG3:=601:=RGBI555 17 //SVP for intel
#define MPEG3:=601:=BGR888 7
#define MPEG3:=601:=BGRA8888 8
#define MPEG3:=601:=RGB888 9
#define MPEG3:=601:=RGBA8888 10
#define MPEG3:=601:=ARGB8888 12 //JMM for Squeak
"! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:58'!
videoSetCPUs: aNumber
	self primSetCPUs: self fileHandle number: aNumber! !

!MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:15'!
videoSetFrame: aFrameNumber stream: aStream
	"Returns -1 if setFrame failed"
	self hasVideo ifFalse: [^-1].
	^[self primSetFrame: self fileHandle frame: aFrameNumber asFloat stream: aStream] on: Error do: [-1]
! !


!MPEGFile methodsFor: 'private' stamp: 'JMM 9/17/2000 23:58'!
register
	^self class register: self! !

!MPEGFile methodsFor: 'private' stamp: 'JMM 9/17/2000 23:58'!
unregister
	^self class unregister: self! !

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

MPEGFile class
	instanceVariableNames: ''!

!MPEGFile class methodsFor: 'instance creation' stamp: 'JMM 1/20/2006 18:18'!
openBuffer: aBuffer 
	^self new openBuffer: aBuffer! !

!MPEGFile class methodsFor: 'instance creation' stamp: 'JMM 1/20/2006 23:05'!
openFileUseBuffer: aPath 
	| bar bytes |
	bar _ StandardFileStream oldFileNamed: aPath.
	bar binary.
	bytes _ bar contents.
	^self new openBuffer: bytes! !

!MPEGFile class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'!
openFile: aPath 
	^self new openFile: aPath! !


!MPEGFile class methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:27'!
primFileValidMPEG: aPath
	"Check to see if the file is valid"
	<primitive: 'primitiveMPEG3CheckSig' module: 'Mpeg3Plugin'>
	self primitiveFailed! !


!MPEGFile class methodsFor: 'registry' stamp: 'JMM 9/17/2000 23:56'!
register: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry add: anObject! !

!MPEGFile class methodsFor: 'registry' stamp: 'JMM 9/17/2000 23:56'!
registry
	WeakArray isFinalizationSupported ifFalse:[^nil].
	^Registry isNil
		ifTrue:[Registry := WeakRegistry new]
		ifFalse:[Registry].! !

!MPEGFile class methodsFor: 'registry' stamp: 'JMM 9/17/2000 23:56'!
unregister: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry remove: anObject ifAbsent:[]! !


!MPEGFile class methodsFor: 'testing' stamp: 'JMM 9/18/2000 14:28'!
isFileValidMPEG: path
	^self primFileValidMPEG: path! !
AlignmentMorph subclass: #MPEGMoviePlayerMorph
	instanceVariableNames: 'moviePlayer positionSlider volumeSlider'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Player'!
!MPEGMoviePlayerMorph commentStamp: '<historical>' prior: 0!
I provide the user-interface for playing MPEG movies, including play/stop/rewind buttons and volume and position sliders. To create an instance of me, evaluate:

  MPEGMoviePlayerMorph new openInWorld

Then use the "open" button to open an MPEG movie file. This class supplies the front panel; the real work is done by MPEGDisplayMorph and StreamingMP3Sound.

!


!MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:11'!
getPosition
	"answer the receiver's movie position"
	^ positionSlider getScaledValue! !

!MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:53'!
getVolume
	"answer the receiver's movie position"
	^ self volumeSlider isNil ifFalse:[self volumeSlider getScaledValue] ifTrue:[0.0]! !

!MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 20:23'!
guessVolumeSlider
	"private - look for a morph that is the receiver's volumeSlider"
	^ self allMorphs
		detect: [:each | "first look in my own morphs"
			each class == SimpleSliderMorph
				and: [each actionSelector == #volume:]]
		ifNone: [| w | 
			"second try, look all over the world (if any)"
			w := self world.
			w isNil
				ifFalse: [""
					w allMorphs
						detect: [:each | ""
							each class == SimpleSliderMorph
								and: [each actionSelector == #volume:]
								and: [each target == moviePlayer]]
						ifNone: []]]! !

!MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:11'!
setPosition: aNumber 
	"changes the receiver's movie position"
	| newPosition |
	newPosition := aNumber asFloat min: 1.0 max: 0.0.
	positionSlider value: newPosition.
	moviePlayer moviePosition: newPosition! !

!MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:57'!
setVolume: aNumber 
	"changes the receiver's movie position"
	| newVolume |
	newVolume := aNumber asFloat min: 1.0 max: 0.0.
	self volumeSlider isNil ifFalse:[self volumeSlider value: newVolume].
	moviePlayer volume: newVolume! !

!MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 11:31'!
totalFrames
	"Answer the total number of frames in this movie."

	^ moviePlayer totalFrames! !

!MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 11:31'!
totalSeconds
	"Answer the total number of seconds in this movie."

	^ moviePlayer totalSeconds! !

!MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 20:13'!
volumeSlider
	"answer the receiver's volumeSlider  
	 
	note: if the instance var is undefined, try to get the sliders  
	from the allMorphs chain. in this way an instance of the  
	receiver created before the instVars was added can works fine"
	^ volumeSlider
		ifNil: [volumeSlider := self guessVolumeSlider]! !


!MPEGMoviePlayerMorph methodsFor: 'drawing' stamp: 'jm 11/13/2001 09:12'!
drawOn: aCanvas
	"Optimization: Do not draw myself if the movie player is one of my submorphs and the only damage is contained within it. This avoids overdrawing while playing a movie."

	((moviePlayer owner == self) and:
	 [moviePlayer bounds containsRect: aCanvas clipRect])
		ifFalse: [super drawOn: aCanvas].
! !


!MPEGMoviePlayerMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 22:34'!
handlesKeyboard: evt
	^ moviePlayer handlesKeyboard: evt! !

!MPEGMoviePlayerMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 22:34'!
keyStroke: evt 
	moviePlayer keyStroke: evt ! !


!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 22:11'!
defaultFloatPrecisionFor: aGetSelector 
	"Answer a number indicating the default float precision to be  
	used in a numeric readout for which the receiver provides the 
	data. Individual morphs can override this. Showing fractional  
	values for readouts of getCursor was in response to an explicit 
	request from ack"
	aGetSelector == #getVolume
		ifTrue: [^ 0.01].
	aGetSelector == #getPosition 
		ifTrue: [^ 0.001].
	^ super defaultFloatPrecisionFor: aGetSelector! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'jm 9/28/2004 17:06'!
getCurrentFrameForm
	"Answer a Form containing the current frame scaled to the size of my display."

	^ moviePlayer currentFrameScaled
! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'jm 9/28/2004 16:59'!
getCurrentFrameImageMorph
	"Answer an ImageMorph containing the current frame scaled to the size of my display."

	^ ImageMorph new image: (moviePlayer currentFrameScaled)
! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 22:03'!
getIsRunning
	"answer whateve the receiver is running"
	^ moviePlayer isRunning! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 22:06'!
getRepeat
	"answer whateve the receiver is running"
	^ moviePlayer repeat! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 3/8/2004 21:42'!
getSubtitlesFileName
	"answer the receiver's subtitlesFileName"
	^ moviePlayer subtitlesFileShortName! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 3/8/2004 21:41'!
getVideoFileName
	"answer the receiver's videoFileName"
	^ moviePlayer videoFileShortName! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 21:30'!
play
	"play the receiver"
	moviePlayer startPlaying!
]style[(4 2 19 26)f3b,f3,f3c148046000,f3! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'jm 10/12/2004 11:14'!
playUntilPosition: finalPosition
	"Play the movie until the given position, then stop."

	moviePlayer playUntilPosition: finalPosition! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 21:31'!
rewind
	"rewind the receiver"
	moviePlayer rewindMovie! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 22:07'!
setRepeat: aBoolean
	"answer whateve the receiver is running"
	moviePlayer repeat: aBoolean! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 3/8/2004 21:42'!
setSubtitlesFileName: aString 
	"change the subtitlesFileName"
	moviePlayer subtitlesFileShortName: aString! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 3/8/2004 21:41'!
setVideoFileName: aString 
	"change the videoFileName"
	moviePlayer videoFileShortName: aString! !

!MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 21:31'!
stop
	"stop the receiver"
	moviePlayer stopPlaying! !


!MPEGMoviePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
defaultColor
	"answer the default color/fill style for the receiver"
		| fill |
	fill := GradientFillStyle ramp: {0.0
					-> (Color
							r: 0.355
							g: 0.548
							b: 1.0). 1.0
					-> (Color
							r: 0.774
							g: 0.935
							b: 1.0)}.
	fill origin: self bounds topLeft + (61 @ 7).
	fill direction: 33 @ 37.
	fill radial: false.
	^ fill! !

!MPEGMoviePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
initialize
"initialize the state of the receiver"
	super initialize.
	""
	self hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap.
	borderWidth := 2.
	self listDirection: #topToBottom.
	self cornerStyle: #rounded.
	self layoutInset: 4.
	moviePlayer := MPEGDisplayMorph new.
	self addMorphFront: moviePlayer.
	self addButtonRow.
	self addVolumeSlider.
	self addPositionSlider.
	self extent: 10 @ 10! !


!MPEGMoviePlayerMorph methodsFor: 'stepping' stamp: 'jm 4/6/2001 07:49'!
step
	"Update the position slider from the current movie position."

	positionSlider adjustToValue: moviePlayer moviePosition.
! !

!MPEGMoviePlayerMorph methodsFor: 'stepping' stamp: 'jm 5/30/2001 23:33'!
stepTime
	"Update the position slider a few times a second."

	^ 500
! !


!MPEGMoviePlayerMorph methodsFor: 'submorphs-add/remove' stamp: 'dgd 3/8/2004 20:40'!
delete
	"the receiver is being deleted"
	moviePlayer stopPlaying.
	moviePlayer closeFile.
	""
	super delete! !


!MPEGMoviePlayerMorph methodsFor: '*Tools-FileList-accessing' stamp: 'bkv 11/21/2002 11:24'!
moviePlayer 
    "Enables this Morph to offer services with the FileList."
     ^moviePlayer
! !


!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
addButtonRow
	"private - add the button row"

	| r |
	r := AlignmentMorph newRow vResizing: #shrinkWrap; color: Color transparent; listCentering: #center.
	r addMorphBack: (self buttonName: 'Menu' translated action: #invokeMenu).
	r addMorphBack: (Morph new extent: 3@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Open' translated action: #openMPEGFile).
	r addMorphBack: (Morph new extent: 3@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Rewind' translated action: #rewindMovie).
	r addMorphBack: (Morph new extent: 3@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Play' translated action: #startPlaying).
	r addMorphBack: (Morph new extent: 3@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' translated action: #stopPlaying).
	r addMorphBack: (Morph new extent: 3@1; color: Color transparent).
"
	r addMorphBack: (self buttonName: '<' action: #previousFrame).
	r addMorphBack: (Morph new extent: 3@1; color: Color transparent).
	r addMorphBack: (self buttonName: '>' action: #nextFrame).
	r addMorphBack: (Morph new extent: 3@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Subtitles' translated action: #openSubtitlesFile).
	r addMorphBack: (Morph new extent: 3@1; color: Color transparent).
"
	r addMorphBack: (self buildQuitButton).

	self addMorphBack: r.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
addPositionSlider
	"private - add the position slider"

	| r |
	positionSlider := SimpleSliderMorph new
		color: (Color r: 0.71 g: 0.871 b: 1.0);
		extent: 200@2;
		target: moviePlayer;
		actionSelector: #moviePosition:;
		adjustToValue: 0.
	r := AlignmentMorph newRow
		color: Color transparent;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter; listCentering: #center;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: 'start ' translated).
	r addMorphBack: positionSlider.
	r addMorphBack: (StringMorph contents: ' end' translated).
	self addMorphBack: r.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
addVolumeSlider
	"private - add the volume slider"

	| r |
	volumeSlider := SimpleSliderMorph new
		color: (Color r: 0.71 g: 0.871 b: 1.0);
		extent: 200@2;
		target: moviePlayer;
		actionSelector: #volume:;
		adjustToValue: 0.5.
	r := AlignmentMorph newRow
		color: Color transparent;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter; listCentering: #center;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '  soft ' translated).
	r addMorphBack: volumeSlider.
	r addMorphBack: (StringMorph contents: ' loud' translated).
	self addMorphBack: r.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:41'!
buildQuitButton
	"private - create the [quit] button"
	^ self
		buttonName: 'Quit' translated
		target: self
		action: #quit! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
buttonFillStyle

	| fill |
	fill := GradientFillStyle ramp: {
		0.0->(Color r: 0.742 g: 0.903 b: 1.0).
		1.0->(Color r: 0.516 g: 0.71 b: 1.0)
	}.
	fill origin: self bounds topLeft + (14@3).
	fill direction: 8@6.
	fill radial: false.
	^ fill
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/7/2004 19:22'!
buttonName: aString action: aSymbol

	^ self buttonName: aString target: moviePlayer action: aSymbol
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:41'!
buttonName: aString target: anObject action: selector
	"private - create a button"

	^ SimpleButtonMorph new
		target: anObject;
		label: aString;
		actionSelector: selector;
		color: (Color gray: 0.8);  "old color"
		fillStyle: self buttonFillStyle;
		borderWidth: 0;
		borderColor: #raised.
! !

!MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:39'!
quit
	"quit the receiver"
	self delete! !

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

MPEGMoviePlayerMorph class
	instanceVariableNames: ''!

!MPEGMoviePlayerMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:40'!
initialize 
    "MPEGMoviePlayerMorph initialize."

    FileList registerFileReader: self.

	self registerInFlapsRegistry.	! !

!MPEGMoviePlayerMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 19:17'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(MPEGMoviePlayerMorph	authoringPrototype		'Movie Player'		'A Player for MPEG movies') 
						forFlapNamed: 'Widgets']
! !

!MPEGMoviePlayerMorph class methodsFor: 'class initialization' stamp: 'ads 7/30/2003 16:07'!
unload
	"Unload the receiver from global registries"

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

	FileList unregisterFileReader: self.! !


!MPEGMoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:54'!
fileReaderServicesForFile: fullName suffix: suffix 

	^((MPEGPlayer registeredVideoFileSuffixes includes: suffix )
		or: [ (MPEGPlayer registeredAudioFileSuffixes includes: suffix)
			or: [ suffix = '*' ]] )
		ifTrue: [ self services ]
		ifFalse: [ #() ]! !

!MPEGMoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sw 9/7/2004 18:17'!
services 
	"Answer the receiver's services"

     ^ OrderedCollection with: self servicePlayInMPEGPlayer with: self serviceOpenInMPEGPlayer
! !


!MPEGMoviePlayerMorph class methodsFor: 'parts bin' stamp: 'jm 12/17/2001 14:58'!
descriptionForPartsBin
	^ self partName:	'MPEGPlayer'
		categories:		#('Multimedia')
		documentation:	'A player for MPEG and JPEG movies '! !


!MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'stephaneducasse 2/4/2006 20:48'!
openFile: aFileName
	"Open the given file (if not nil) in an instance of the receiver."

     | wrapper |
	aFileName ifNil: [^ Beeper beep].
     wrapper := self openOn: aFileName.
 	wrapper openInWorld.
     ^ wrapper! !

!MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'stephaneducasse 2/4/2006 20:48'!
playFile: aFileName
	"Play the given file (if not nil) in an MPEGMoviePlayerMorph"

     | wrapper |
	aFileName ifNil: [^ Beeper beep].
     wrapper := self openOn: aFileName.
     wrapper moviePlayer startPlaying. 
     "wrapper openInWindow."
	wrapper openInWorld.
     ^wrapper! !

!MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'sw 9/7/2004 18:17'!
serviceOpenInMPEGPlayer
	"Answer a service for opening a file in an MPEGMoviePlayer"

	^ SimpleServiceEntry 
		provider: self 
		label: 'open'
		selector: #openFile:
		description: 'open file in an MPEG player'
		buttonLabel: 'open'! !

!MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'bkv 11/21/2002 11:47'!
servicePlayInMPEGPlayer
	"Answer a service for opening in a MPEG player"

	^ SimpleServiceEntry
		provider: self
		label: 'play in MPEG player'
		selector: #playFile: 
		description: 'play in MPEG player'
		buttonLabel: 'play'! !


!MPEGMoviePlayerMorph class methodsFor: 'scripting' stamp: 'yo 1/14/2005 19:17'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(
	(basic
		(
			(command play 'Start playing the movie/sound')
			(command stop 'Stop playing the movie/sound')
			(command rewind 'Rewind the movie/sound')))

	(#'movie controls'
		(
			(slot videoFileName	'The name for the video file' 											String	readWrite Player getVideoFileName Player setVideoFileName:)
			(slot subtitlesFileName	'The name for the subtitles file' 										String	readWrite Player getSubtitlesFileName Player setSubtitlesFileName:)
			(slot position 			'A number representing the current position of the movie/sound.'	Number readWrite Player getPosition Player setPosition:)
			(slot volume 			'A number representing the volume of the movie.' 					Number readWrite Player getVolume Player setVolume:)

			(command play 'Start playing the movie/sound')
			(command playUntilPosition: 'Play until the given position, then stop' Number)			
			(command stop 'Stop playing the movie/sound')
			(command rewind 'Rewind the movie/sound')

			(slot isRunning 'Whether the movie/sound is being played' Boolean readOnly	Player getIsRunning unused unused)
			(slot repeat 'Whether the movie/sound will play in an endless loop' Boolean readWrite	Player getRepeat Player setRepeat:)
			(slot totalFrames 'Length of this movie in number of frames' Number readOnly	Player getTotalFrames unused unused)
			(slot totalSeconds 'Length of this movie in seconds' Number readOnly	Player getTotalSeconds unused unused)
			(slot frameGraphic 'A graphic for the current frame' Graphic readOnly Player getFrameGraphic unused unused)
		)
	)

)! !


!MPEGMoviePlayerMorph class methodsFor: '*Tools-FileList-registering' stamp: 'dgd 3/8/2004 20:37'!
openOn: fileNameString 
	"open a new instance of the receiver on a file named 
	fileNameString "
	| wrapper |
	wrapper := self new.
	wrapper moviePlayer openFileNamed: fileNameString.
	^ wrapper! !
Object subclass: #MPEGPlayer
	instanceVariableNames: 'external form startTime clockBias frameRate lastDelay noSound sampleRate audioPlayerProcess videoPlayerProcess playerProcessPriority soundQueue timeCheck semaphoreForSound errorForSoundStart morph volume buffer isBuffer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Kernel'!
!MPEGPlayer commentStamp: '<historical>' prior: 0!
V1.01 johnmci@smalltalkconsulting.com Nov 8th 2000
A Simple MPEG Player for playing MPEG3 audio or video 

| foo |
foo _ MpegPlayer playFile: 'my.mpg'.
foo playStream: 0. "To play both audio and video, stream #0 "

foo playAudioStream: 0 "To play audio stream".
foo playVideoStream: 0 "To play video stream"
foo playStreamWaitTilDone: 0 "To play audio/video as currrent process"

or 
	| foo |
	foo _ MPEGPlayer playFile: 'my.mpg' onForm: Display.
	foo playStream: 0.
	To play full screen.
!


!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:59'!
audioPlayerProcess
	^audioPlayerProcess ! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
audioPlayerProcess: aProcess
	audioPlayerProcess := aProcess! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:31'!
clockBias
	^clockBias! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
clockBias: aArray
	clockBias := aArray! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:31'!
clockBiasForStream: aStream
	^self clockBias at: aStream + 1.! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:32'!
clockBiasForStream: aStream put: aValue
	self clockBias at: aStream + 1 put: aValue! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:30'!
currentAudioSampleForStream: aStream
	^self external audioGetSample: aStream! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:31'!
currentAudioSampleForStream: aStream put: aNumber
	self external audioSetSample: aNumber stream: aStream! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:29'!
currentVideoFrameForStream: aStream
	^self external videoGetFrame: aStream! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:30'!
currentVideoFrameForStream: aStream put: aNumber
	self external videoSetFrame: aNumber stream: aStream! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
errorForSoundStart: aValueInMilliseconds
	errorForSoundStart := aValueInMilliseconds
! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 1/20/2006 18:10'!
external
	[external hasVideo] on: Error do: 
		[self isBuffer
			ifTrue:
			[external := MPEGFile openBuffer: external buffer]
			ifFalse: 
				[(MPEGFile isFileValidMPEG: external fileName) 
					ifFalse: [^self error: 'Mpeg File is invalid'].
				external := MPEGFile openFile: external fileName]].
	^external! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:31'!
fileName
	^self external fileName! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/17/2000 23:29'!
form
	form isNil ifTrue: 
		[self morph isNil ifTrue: [^nil].
		^self morph form].
	^form! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
form: aForm
	form := aForm! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:39'!
frameRate
	^frameRate! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
frameRate: aRate
	frameRate := aRate! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 1/20/2006 18:05'!
isBuffer
	^isBuffer == true! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:04'!
lastDelay
	^lastDelay! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
lastDelay: aNumber
	lastDelay := aNumber! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/17/2000 23:20'!
morph
	^morph! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
morph: aMorph	
	morph := aMorph.! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/20/2000 22:36'!
mpegFile
	^external! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:59'!
noSound
	^noSound! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
noSound: flag
	noSound := flag! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:59'!
playerProcessPriority
	^playerProcessPriority! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
playerProcessPriority: aNumber
	playerProcessPriority := aNumber! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:34'!
sampleRate
	^sampleRate! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
sampleRate: aRate
	sampleRate := aRate! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:01'!
soundQueue
	^soundQueue! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
soundQueue: aQueue
	soundQueue := aQueue! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:38'!
startTime
	^startTime! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
startTime: aArray
	startTime := aArray! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:12'!
startTimeForStream: aStream
	^self startTime at: aStream + 1! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:11'!
startTimeForStream: aStream put: aNumber
	^self startTime at: aStream + 1 put: aNumber! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:03'!
timeCheck
	^timeCheck! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
timeCheck: aNumber
	timeCheck := aNumber! !

!MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:58'!
videoPlayerProcess
	^videoPlayerProcess ! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
videoPlayerProcess: aProcess
	videoPlayerProcess := aProcess! !

!MPEGPlayer methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
volume: aVolume
	volume := aVolume! !


!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:29'!
audioChannels: aStream
	^self external audioChannels: aStream! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:31'!
audioSampleRate: aStream
	^self external audioSampleRate: aStream! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'!
audioSamples: aStream
	^self external audioSamples: aStream
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/13/2000 20:05'!
currentExternalLocationInPercent
	"Warning this might not return what you want, it gets percentage based on audio, or video stream based on last usage, because we buffer audio it may give incorrect information when playing mpeg movies"
	^self external getPercentage! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/13/2000 20:09'!
currentLocationInPercent: aStream

	self hasVideo ifTrue: [^ ((self currentVideoFrameForStream: aStream)/(self videoFrames: aStream)) asFloat].
	self hasAudio ifTrue: [^ ((self currentAudioSampleForStream: aStream)/(self audioSamples: aStream)) asFloat].

! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:32'!
endOfAudio: aStream
	^self external endOfAudio: aStream
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:30'!
endOfVideo: aStream
	^self external endOfVideo: aStream
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'!
getTOC: timecode doStreams: streams
	^self external getTOC: timecode doStreams: streams
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:31'!
getTimeCode
	^self external getTimeCode! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:31'!
hasAudio
	^self external hasAudio
	! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:30'!
hasVideo
	^self external hasVideo! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:31'!
setMMX: aBoolean
	self external setMMX: aBoolean! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'!
totalVideoStreams
	^self external totalVideoStreams
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:32'!
videoDropFrames: aNumberOfFrames stream: aStream
	^self external videoDropFrames: aNumberOfFrames stream: aStream! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:30'!
videoFrameHeight: aStream
	^self external videoFrameHeight: aStream
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:29'!
videoFrameRate: aStream
	^self external videoFrameRate: aStream! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:29'!
videoFrameWidth: aStream
	^self external videoFrameWidth: aStream
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'!
videoFrames: aStream
	^self external videoFrames: aStream
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'!
videoPreviousFrame: aStream
	^self external videoPreviousFrame: aStream
! !

!MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'!
videoSetCPUs: aNumber
	^self external videoSetCPUs: aNumber
! !


!MPEGPlayer methodsFor: 'audio' stamp: 'stephaneducasse 2/4/2006 20:48'!
createSoundFrom: aStream 
	| snds channels |
	
	snds := OrderedCollection new.
	channels := self audioChannels: 0.
	1 to: channels do: [:c | snds add: (self readSoundChannel: c - 1 stream: aStream)].
	channels = 1
		ifTrue:[^ MixedSound new
				add: (snds at: 1) pan: 0.5 volume: volume;
				
				yourself]
		ifFalse: [
			^ MixedSound new
				add: (snds at: 1) pan: 0.0 volume: volume;
				add: (snds at: 2) pan: 1.0 volume: volume;
				yourself].! !

!MPEGPlayer methodsFor: 'audio' stamp: 'stephaneducasse 2/4/2006 20:48'!
privatePlayAudioStream: aStream
	| number |

	number := 5.
	self soundQueue: (QueueSound new startTime: 0).
	[number + 2 timesRepeat: [self soundQueue add: (self createSoundFrom: aStream)].
	self soundQueue play.
	semaphoreForSound signal.
	[[self soundQueue sounds size > number] whileTrue: [(Delay forMilliseconds: 100) wait].
	self soundQueue add: (self createSoundFrom: aStream).
	(self endOfAudio: aStream) 
		ifTrue: 
			[self audioPlayerProcess: nil.
			^self]] repeat] on: Error do: 
				[self audioPlayerProcess: nil.
				^self]! !

!MPEGPlayer methodsFor: 'audio' stamp: 'fbs 2/13/2006 22:44'!
readSoundChannel: aChannel stream: aStream
	| buffer result samples |

	samples := (self sampleRate // 10)  min: 
		((self audioSamples: aStream) - (self currentAudioSampleForStream: aStream)).
	(samples = 0) ifTrue: [self error: 'Mpeg at end of stream, toss error, catch up high']. 
	buffer := SoundBuffer newMonoSampleCount: samples.
	aChannel = 0 
		ifTrue: [result := self external audioReadBuffer: buffer stream: 
					aStream channel: aChannel]
		ifFalse: [result := self external audioReReadBuffer: buffer stream: 
					aStream channel: aChannel].
	^SampledSound samples: buffer samplingRate: self sampleRate.
! !

!MPEGPlayer methodsFor: 'audio' stamp: 'JMM 11/8/2000 10:49'!
setupStream: aStream
	self sampleRate: (self audioSampleRate: aStream).
	SoundPlayer startPlayerProcessBufferSize:  8192 "(SoundPlayer bufferMSecs * self sampleRate) // 1000"
		rate: self sampleRate stereo: true.
! !

!MPEGPlayer methodsFor: 'audio' stamp: 'JMM 11/8/2000 10:33'!
setupStreamNoSeek: aStream
	self sampleRate: (self audioSampleRate: aStream).
	SoundPlayer startPlayerProcessBufferSize:  8192 "(SoundPlayer bufferMSecs * self sampleRate) // 1000"
		rate: self sampleRate stereo: ((self  audioChannels: aStream) > 1).
! !

!MPEGPlayer methodsFor: 'audio' stamp: 'JMM 9/20/2000 13:38'!
startAudioPlayerProcess: aStream
	self audioPlayerProcess: ([self privatePlayAudioStream: aStream] forkAt: Processor userInterruptPriority)! !

!MPEGPlayer methodsFor: 'audio' stamp: 'JMM 9/19/2000 16:59'!
updateSoundStream: aStream! !


!MPEGPlayer methodsFor: 'delay' stamp: 'stephaneducasse 2/4/2006 20:48'!
calculateDelayGivenFrame: frame stream: aStream
	| estimated current delta |

	current :=  Time millisecondClockValue  - (self startTimeForStream: aStream).
	estimated := ((frame asFloat / self frameRate) * 1000) asInteger  - (self clockBiasForStream: aStream).
	delta := estimated - current.
	delta > 33  ifTrue: 
		[self lastDelay: (delta + self lastDelay) // 2. 
		 (Delay forMilliseconds: self lastDelay) wait].
	delta < -33  ifTrue: 
		[self lastDelay: self lastDelay // 2.
		 self decideToSkipAFrame: delta averageWait: current//frame stream: aStream].
	! !

!MPEGPlayer methodsFor: 'delay' stamp: 'stephaneducasse 2/4/2006 20:48'!
calculateDelayToSoundGivenFrame: frame stream: aStream
	| current delta buffers estimatedAudio estimatedVideo |

	current :=  Time millisecondClockValue   - (self startTimeForStream: aStream) + (self clockBiasForStream: aStream).
	buffers := (self soundQueue sounds size - 1 ) max: 0.
	buffers = 0 ifTrue: [^self].
	estimatedAudio :=  ((self currentAudioSampleForStream: aStream) 
			- (buffers * self sampleRate // 10) 
			- self soundQueue currentSound samplesRemaining) * 1000 / self sampleRate.
	estimatedAudio := estimatedAudio - 0000.
	estimatedVideo := ((frame asFloat / self frameRate) * 1000) asInteger.
	delta := estimatedVideo - estimatedAudio.
	delta > 100  ifTrue: 
		[self lastDelay < delta ifTrue: [self lastDelay: self lastDelay + (((delta-self lastDelay)/10) max: 1)].
		(Delay forMilliseconds: self lastDelay) wait].
	delta < -100  ifTrue: 
		[self lastDelay: ((self lastDelay - 10) max: 1).
		 self decideToSkipAFrame: delta averageWait: current//frame stream: aStream].
! !

!MPEGPlayer methodsFor: 'delay' stamp: 'stephaneducasse 2/4/2006 20:48'!
decideToSkipAFrame: delta averageWait: aWaitTime stream: aStream
	| estimatedFrames |

	delta abs > aWaitTime ifTrue: 
		[estimatedFrames := ( delta abs / (1000 / self frameRate)) asInteger.
		self videoDropFrames:  estimatedFrames stream: aStream].! !


!MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 11/8/2000 10:31'!
close
	self external closeFile! !

!MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 1/20/2006 18:17'!
initializeWithBuffer: aBuffer form: aForm
	isBuffer := true.
	buffer := aBuffer.
	self initialize: aBuffer.
	self form: aForm.
	^self! !

!MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 1/20/2006 18:07'!
initializeWithBuffer: aBuffer morph: aMorphic
	isBuffer _ true.
	buffer _ aBuffer.
	self initialize: aBuffer.
	self morph: aMorphic.
	^self! !

!MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 1/20/2006 18:54'!
initialize: aPath

	self halt.
	self isBuffer ifTrue: 
		[external := MPEGFile openBuffer: buffer]
	 ifFalse: 
		[(MPEGFile isFileValidMPEG: aPath) ifFalse: [^nil].
		external := MPEGFile openFile: aPath.].
	self playerProcessPriority: Processor userSchedulingPriority.
	self lastDelay: 10.
	volume := 1.0.
	errorForSoundStart := 500.
	semaphoreForSound := Semaphore new.
	self startTime: (Array new: self totalVideoStreams).
	self clockBias: (Array new: self totalVideoStreams withAll: 0).! !

!MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 14:06'!
initializeWithFileName: aPath 
	self initialize: aPath.
	self form: nil.
	^self! !

!MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 14:06'!
initializeWithFileName: aPath form: aForm
	self initialize: aPath.
	self form: aForm.
	^self! !

!MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 10/17/2000 23:34'!
initializeWithFileName: aPath morph: aMorphic
	self initialize: aPath.
	self morph: aMorphic.
	^self! !

!MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 14:15'!
stopAndClose
	self stop.
	self close
! !


!MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'!
playAudioStream: aStream

	self hasAudio ifFalse: [^self].
	self setupStream: aStream.
	self startAudioPlayerProcess: aStream.! !

!MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'!
playAudioStreamNoSeek: aStream

	self hasAudio ifFalse: [^self].
	self setupStreamNoSeek: aStream.
	self startAudioPlayerProcess: aStream.! !

!MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'!
playAudioStreamWaitTilDone: aStream

	self hasAudio ifFalse: [^self].
	self setupStream: aStream.
	self privatePlayAudioStream: aStream.! !

!MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'!
playStream: aStream
	self noSound: self hasAudio not.
	self startVideoPlayerProcess: aStream
! !

!MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'!
playStreamWaitTilDone: aStream
	self noSound: self hasAudio not.
	self privatePlayVideoStream: aStream.! !

!MPEGPlayer methodsFor: 'play' stamp: 'JMM 9/20/2000 14:00'!
playVideoStream: aStream
	self noSound: true.
	self startVideoPlayerProcess: aStream

! !

!MPEGPlayer methodsFor: 'play' stamp: 'JMM 9/20/2000 14:00'!
playVideoStreamWaitTilDone: aStream
	self noSound: true.
	self privatePlayVideoStream: aStream

! !


!MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/8/2000 10:38'!
backAudio: aNumber forStream: aStream
	self forwardAudio: (0-aNumber) forStream: aStream! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/8/2000 10:39'!
backVideo: aNumber forStream: aStream
	self forwardVideo: (0-aNumber) forStream: aStream! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'stephaneducasse 2/4/2006 20:48'!
forwardAudio: aNumber forStream: aStream
	| newLocation |

	self hasAudio ifFalse: [^self].
	newLocation := (((self currentAudioSampleForStream: aStream) + aNumber) min: (self audioSamples: aStream)) max: 0 .
	self currentAudioSampleForStream: aStream put: newLocation! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'stephaneducasse 2/4/2006 20:48'!
forwardVideo: aNumber forStream: aStream
	| newLocation |

	self hasVideo ifFalse: [^self].
	newLocation := (((self currentVideoFrameForStream: aStream) + aNumber) min: (self videoFrames: aStream)) max: 0.
	self currentVideoFrameForStream: aStream put: newLocation.
! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/19/2000 12:50'!
isPlaying
	^((self audioPlayerProcess isNil) and: [self videoPlayerProcess isNil]) not! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'stephaneducasse 2/4/2006 20:48'!
recalculateNewSampleLocationForStream: aStream givenFrame: aFrame
	| estimated |

	self hasAudio ifFalse: [^self].
	estimated := (aFrame / (self videoFrames: aStream) * (self audioSampleRate: aStream)) asInteger.
	self currentAudioSampleForStream: aStream put: estimated.! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/8/2000 10:47'!
seekToHere: aPercentage forStream: aStream
	"Alternate method is to seek all video/audio for stream to a certain percentage using the primitive, but I think your mpeg must have timecodes!! otherwise endless loop"
	self external seekPercentage: aPercentage! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/19/2000 11:44'!
seekVideoAudioBasedOnFrame: aFrame forStream: aStream
	self external hasVideo ifTrue: 
		[self currentVideoFrameForStream: aStream put:  aFrame].
	self recalculateNewSampleLocationForStream: aStream givenFrame: aFrame! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/10/2000 00:19'!
setLocation: aPercentage forStream: aStream
	self hasAudio ifTrue: [self currentAudioSampleForStream: aStream put: ((self audioSamples: aStream) * aPercentage) asInteger]. 
	self hasVideo ifTrue: [self currentVideoFrameForStream: aStream put: ((self videoFrames: aStream) * aPercentage) asInteger].! !

!MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 9/20/2000 18:46'!
stop
	self videoPlayerProcess notNil ifTrue: 
		[self videoPlayerProcess terminate. 
		self videoPlayerProcess: nil].
	self audioPlayerProcess notNil ifTrue: 
		[self audioPlayerProcess terminate. 
		self audioPlayerProcess: nil.
		SoundPlayer stopPlayingAll]! !


!MPEGPlayer methodsFor: 'utility' stamp: 'JMM 10/17/2000 23:22'!
changed
	self morph notNil ifTrue: [self morph changed].! !

!MPEGPlayer methodsFor: 'utility' stamp: 'stephaneducasse 2/4/2006 20:48'!
checkForm: aStream
	| y x |

	self form notNil ifTrue: [^self].
	y := self videoFrameHeight: aStream.
	x := self videoFrameWidth: aStream.
	self form:  (Form extent: x@y depth: 32)
! !


!MPEGPlayer methodsFor: 'video' stamp: 'stephaneducasse 2/4/2006 20:48'!
privatePlayVideoStream: aStream
	
	| location |
	self hasVideo ifFalse: 
		[self timeCheck: 0@0.
		^self].
	self checkForm: aStream.
	self frameRate: (self videoFrameRate: aStream).
	location := self currentVideoFrameForStream: aStream.
	self clockBiasForStream: aStream 
		put: (1/self frameRate*location*1000) asInteger.
	self videoLoop: aStream.
	self timeCheck: ((Time millisecondClockValue + (self clockBiasForStream: aStream) - (self startTimeForStream: aStream))/1000.0) @ ((self videoFrames: aStream) / self frameRate).
	self videoPlayerProcess: nil! !

!MPEGPlayer methodsFor: 'video' stamp: 'JMM 9/20/2000 13:59'!
startVideoPlayerProcess: aStream
	self videoPlayerProcess: ([self privatePlayVideoStream: aStream] forkAt: self playerProcessPriority)! !

!MPEGPlayer methodsFor: 'video' stamp: 'stephaneducasse 2/4/2006 20:48'!
videoLoop: aStream
	| location oneTime | 

	oneTime := true.
	[self external videoReadFrameInto: self form stream: aStream.
	oneTime ifTrue: 
			[oneTime := false.
			self noSound ifFalse: 
				[self playAudioStreamNoSeek: aStream.
				semaphoreForSound wait.
				(Delay forMilliseconds: errorForSoundStart) wait].
			self startTimeForStream: aStream put: (Time millisecondClockValue)].
	self morph ifNil: 
			[self form == Display
				ifTrue: [Display forceToScreen]
				ifFalse: [self form displayOn: Display]].
	self changed.
		location := (self currentVideoFrameForStream: aStream)+1.
	true 
			ifTrue: [self calculateDelayGivenFrame: location stream: aStream]
			ifFalse: [self calculateDelayToSoundGivenFrame: location stream: aStream].
	(self endOfVideo: aStream)  ifTrue: [^self]] repeat.! !

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

MPEGPlayer class
	instanceVariableNames: ''!

!MPEGPlayer class methodsFor: 'file suffixes' stamp: 'bkv 11/21/2002 15:28'!
registeredAudioFileSuffixes
    "Answer the file extensions for which MPEGPlayer registers audio services with FileList."
     "MPEGPlayer registeredAudioFileSuffixes"

     ^{ 'mp3'.  }

	! !

!MPEGPlayer class methodsFor: 'file suffixes' stamp: 'bkv 11/21/2002 11:14'!
registeredVideoFileSuffixes
    "Answer the file extensions for which MPEGPlayer registers video services with FileList."
     "MPEGPlayer registeredVideoFileSuffixes"

     ^{ 'mpg'. 'mpeg'. 'jmv'. }

	! !


!MPEGPlayer class methodsFor: 'instance creation' stamp: 'JMM 1/20/2006 18:16'!
playBuffer: aBuffer onForm: aForm
	^self new initializeWithBuffer: aBuffer morph: aForm! !

!MPEGPlayer class methodsFor: 'instance creation' stamp: 'JMM 1/20/2006 18:06'!
playBuffer: aBuffer onMorph: aMorph
	^self new initializeWithBuffer: aBuffer morph: aMorph! !

!MPEGPlayer class methodsFor: 'instance creation' stamp: 'JMM 9/18/2000 19:02'!
playFile: aPath
	^self new initializeWithFileName: aPath ! !

!MPEGPlayer class methodsFor: 'instance creation' stamp: 'JMM 9/18/2000 18:32'!
playFile: aPath onForm: aForm
	^self new initializeWithFileName: aPath form: aForm! !

!MPEGPlayer class methodsFor: 'instance creation' stamp: 'JMM 10/17/2000 23:19'!
playFile: aPath onMorph: aMorph
	^self new initializeWithFileName: aPath morph: aMorph! !
Object subclass: #MPEGSubtitleElement
	instanceVariableNames: 'initialFrame endFrame subtitleLine contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Kernel'!
!MPEGSubtitleElement commentStamp: 'asm 7/31/2003 22:27' prior: 0!
an element of a subtitle file,

this has the form

{initialFrame}{endFrame} subtitle line[| next subtitle line]!


!MPEGSubtitleElement methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:17'!
contents
	"answer the receiver's contents"
	^ contents! !

!MPEGSubtitleElement methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:17'!
contents: aString 
	"change the receiver's contents"
	contents := aString replaceAll: $| with: Character cr! !


!MPEGSubtitleElement methodsFor: 'parsing' stamp: 'asm 7/30/2003 21:04'!
is: text in: aStream
	" Returns true if text is present in aStream.
	Advance the stream if present. "

	| position |
	(text isKindOf: Character) ifTrue: [
		^self is: (String with: text) in: aStream
	].
	position := aStream position.
	aStream skipSeparators.
	text = (aStream next: text size) ifFalse: [
		aStream position: position.
		^false
	].
	^true! !

!MPEGSubtitleElement methodsFor: 'parsing' stamp: 'asm 7/30/2003 21:01'!
mustBe: text in: aStream
	" Check text to be present in aStream. "

	(text isKindOf: Character) ifTrue: [
		^self is: (String with: text) in: aStream
	].
	(self is: text in: aStream) ifFalse: [
		^self error: 'Invalid token, must be: ',text
	].! !

!MPEGSubtitleElement methodsFor: 'parsing' stamp: 'asm 7/30/2003 21:05'!
nextIntegerFrom: aStream
	" Returns the next Integer present in aStream. "

	| sign result |
	sign := (self is: $- in: aStream) ifTrue: [-1] ifFalse: [1].
	result := 0.
	self skipBlanks: aStream.
	[aStream peek isDigit] whileTrue: [
		result := aStream next asciiValue - $0 asciiValue + (result * 10)
	].
	^result * sign! !

!MPEGSubtitleElement methodsFor: 'parsing' stamp: 'dgd 3/8/2004 20:17'!
readFrom: aStream 
	"Private - Read the receiver's contents from aStream."
	self mustBe: '{' in: aStream.
	initialFrame := self nextIntegerFrom: aStream.
	self mustBe: '}{' in: aStream.
	endFrame := self nextIntegerFrom: aStream.
	self mustBe: '}' in: aStream.
	""
	self contents: aStream nextLine isoToSqueak! !

!MPEGSubtitleElement methodsFor: 'parsing' stamp: 'asm 7/30/2003 21:42'!
skipBlanks: aStream
	" Advance aStream skipping all blank characters and comments. "

	aStream skipSeparators! !


!MPEGSubtitleElement methodsFor: 'printing' stamp: 'dgd 3/8/2004 20:50'!
printOn: aStream 
	"append to aStream a sequence of characters that identifies 
	the receiver."
	aStream nextPutAll: '{';
		 nextPutAll: initialFrame asString;
		 nextPutAll: '}{';
		 nextPutAll: endFrame asString;
		 nextPutAll: '}';
		 nextPutAll: contents asString! !


!MPEGSubtitleElement methodsFor: 'testing' stamp: 'dgd 3/8/2004 20:23'!
correspondsToFrame: aNumber
	"answer if the receiver corresponds to a given frame number"
	^ aNumber between:  initialFrame and:  endFrame! !

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

MPEGSubtitleElement class
	instanceVariableNames: ''!

!MPEGSubtitleElement class methodsFor: 'instance creation' stamp: 'asm 7/30/2003 21:26'!
fromStream: aStream
	"Returns an instance of the receiver read from aStream."

	^self new readFrom: aStream! !
Object subclass: #MPEGSubtitles
	instanceVariableNames: 'fileName elements'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Kernel'!
!MPEGSubtitles commentStamp: 'asm 7/31/2003 22:12' prior: 0!
a subtitle file

i can only read subtitle files with a format like this:

[..]
{1043}{1082}La gente siempre me pregunta|si conozco a Tyler Durden.
{1083}{1096}Tres minutos.
{1097}{1133}El momento de la verdad.|Punto cero.
[..]
from Fight Club

while reading, pipes(|) are replaced by carriage returns
!


!MPEGSubtitles methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:49'!
elementCorrespondingToFrame: frameNumber 
	"answer the element corresponding to frameNumber"
	^ elements
		detect: [:each | each correspondsToFrame: frameNumber]
		ifNone: []! !

!MPEGSubtitles methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:45'!
fileName
	"answer the receiver's fileName"
	^ fileName! !

!MPEGSubtitles methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:42'!
subtitleForFrame: frameNumber 
	"answer the subtitle for the given frame number"
	| element |
	element := self elementCorrespondingToFrame: frameNumber.
	^ element isNil
		ifTrue: ['']
		ifFalse: [element contents]! !


!MPEGSubtitles methodsFor: 'initialization' stamp: 'dgd 3/8/2004 22:24'!
initializeFromFileNamed: aString 
	"initialize the receiver from a file named aString"
	| file result |
fileName := aString.
	elements := OrderedCollection new.
	""
	file := CrLfFileStream readOnlyFileNamed: aString.
	[result := self readFrom: file]
		ensure: [file close].
	^ result! !

!MPEGSubtitles methodsFor: 'initialization' stamp: 'dgd 3/8/2004 22:04'!
readFrom: aStream 
	"private - Read the next definitions found in aStream onto the  
	receiver"
	[aStream atEnd]
		whileFalse: [| element | 
			element := MPEGSubtitleElement fromStream: aStream.
			elements add: element]! !

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

MPEGSubtitles class
	instanceVariableNames: ''!

!MPEGSubtitles class methodsFor: 'instance creation' stamp: 'dgd 3/8/2004 22:02'!
fromFileNamed: aString 
	"Returns an instance of the receiver read from file named  
	aString"
	^self new initializeFromFileNamed: aString ! !
UpdatingTextMorph subclass: #MPEGSubtitlesDisplayer
	instanceVariableNames: 'font'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Player'!

!MPEGSubtitlesDisplayer methodsFor: 'accessing' stamp: 'dgd 3/7/2004 21:18'!
font
	"answer the receiver's font"
	^ font
		ifNil: [TextStyle defaultFont] ! !

!MPEGSubtitlesDisplayer methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:33'!
font: aFont 
	"change the receiver's font"
	font := aFont.
	""
	self contents: ''.
	self contents: self contentsFromTarget! !


!MPEGSubtitlesDisplayer methodsFor: 'initialization' stamp: 'dgd 3/7/2004 21:16'!
initialize
	"initialiaze the receiver"
	super initialize.
	""
font := TextStyle defaultFont.""
	self
		backgroundColor: (Color black alpha: 0.4).
	""
	self margins: 4 @ 2.
	self textColor: Color white.
	self textStyle centered! !


!MPEGSubtitlesDisplayer methodsFor: 'menu' stamp: 'dgd 3/8/2004 20:42'!
changeFont
	"open a dialog to change the receiver's font"
	| newFont |
	newFont := StrikeFont fromUser: self font.
	""
	newFont isNil
		ifFalse: [self font: newFont]! !

!MPEGSubtitlesDisplayer methodsFor: 'menu' stamp: 'dgd 3/8/2004 20:10'!
changeSubtitlesColor
	"offer a ColorPicker to change the subtitles colors"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #textColor:;
		originalColor: self textColor;
		putUpFor: self currentHand near: self currentHand cursorBounds
! !


!MPEGSubtitlesDisplayer methodsFor: 'stepping and presenter' stamp: 'dgd 3/7/2004 20:59'!
step
	"update my position"
	super step.
	" 
	if my owner is the mpegplayer, i change my position to  
	bottomCenter"
	self owner == self target
		ifTrue: [| bc | 
			bc := self owner bottomCenter.
			self left: bc x - (self width // 2).
			self bottom: bc y]! !


!MPEGSubtitlesDisplayer methodsFor: 'target access' stamp: 'dgd 3/8/2004 20:36'!
contentsFromTarget
	"private - answer the contents from the receiver's target"
	| contentsAsText |
	contentsAsText := super contentsFromTarget asText.
	contentsAsText
		addAttribute: (TextFontReference toFont: self font).
	^ contentsAsText! !
MenuMorph subclass: #MVCMenuMorph
	instanceVariableNames: 'done mvcSelection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!MVCMenuMorph commentStamp: '<historical>' prior: 0!
I simulate the MVC menu classes PopUpMenu, SelectionMenu, and CustomMenu when running in a Morphic world. I am also used to implement Utilities>informUser:during:.!


!MVCMenuMorph methodsFor: 'initializing' stamp: 'laza 4/20/2004 10:41'!
initialize
	super initialize.
	self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber
! !


!MVCMenuMorph methodsFor: 'invoking' stamp: 'ar 3/17/2001 23:43'!
displayAt: aPoint during: aBlock
	"Add this menu to the Morphic world during the execution of the given block."

	Smalltalk isMorphic ifFalse: [^ self].

	ActiveWorld addMorph: self centeredNear: aPoint.
	self world displayWorld.  "show myself"
	aBlock value.
	self delete! !

!MVCMenuMorph methodsFor: 'invoking' stamp: 'nk 4/6/2002 22:33'!
informUserAt: aPoint during: aBlock
	"Add this menu to the Morphic world during the execution of the given block."

	| title w |
	Smalltalk isMorphic ifFalse: [^ self].

	title _ self allMorphs detect: [ :ea | ea hasProperty: #titleString ].
	title _ title submorphs first.
	self visible: false.
	w _ ActiveWorld.
	aBlock value:[:string|
		self visible ifFalse:[
			w addMorph: self centeredNear: aPoint.
			self visible: true].
		title contents: string.
		self setConstrainedPosition: Sensor cursorPoint hangOut: false.
		self changed.
		w displayWorld		 "show myself"
	]. 
	self delete.
	w displayWorld! !

!MVCMenuMorph methodsFor: 'invoking' stamp: 'ar 12/27/2001 22:46'!
invokeAt: aPoint in: aWorld
	"Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu."
	"Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."

	^ self invokeAt: aPoint in: aWorld allowKeyboard: Preferences menuKeyboardControl! !

!MVCMenuMorph methodsFor: 'invoking' stamp: 'KLC 4/11/2004 10:56'!
invokeAt: aPoint in: aWorld allowKeyboard: aBoolean
	"Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu."
	"Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." 
	| w originalFocusHolder |
	self flag: #bob.		"is <aPoint> global or local?"
	self flag: #arNote.	"<aPoint> is local to aWorld"
	originalFocusHolder _ aWorld primaryHand keyboardFocus.
	self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean.
	done _ false.
	w _ aWorld outermostWorldMorph. "containing hand"
	[self isInWorld & done not] whileTrue: [w doOneSubCycle].
	self delete.
	originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder].
	^ mvcSelection
! !


!MVCMenuMorph methodsFor: 'WiW support' stamp: 'laza 4/20/2004 10:38'!
morphicLayerNumber
	^self valueOfProperty: #morphicLayerNumber ifAbsent: [10].
! !


!MVCMenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 12:10'!
cancelValue: selectionOrNil
	"Set the value to be returned if the user cancels without making a selection."

	mvcSelection _ selectionOrNil.
! !

!MVCMenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 12:16'!
selectMVCItem: item
	"Called by the MenuItemMorph that the user selects.
	Record the selection and set the done flag to end this interaction."

	mvcSelection _ item.
	done _ true.
! !

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

MVCMenuMorph class
	instanceVariableNames: ''!

!MVCMenuMorph class methodsFor: 'instance creation' stamp: 'ar 9/18/2000 12:16'!
from: aPopupMenu title: titleStringOrNil
	"Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world."

	| menu items lines selections labelString j emphasis |
	menu _ self new.
	titleStringOrNil ifNotNil: [
		titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]].
	labelString _ aPopupMenu labelString.
	items _ labelString asString findTokens: String cr.
	labelString isText ifTrue:
		["Pass along text emphasis if present"
		j _ 1.
		items _ items collect:
			[:item | j _ labelString asString findString: item startingAt: j.
			emphasis _ TextEmphasis new emphasisCode: (labelString emphasisAt: j).
			item asText addAttribute: emphasis]].
	lines _ aPopupMenu lineArray.
	lines ifNil: [lines _ #()].
	menu cancelValue: 0.
	menu defaultTarget: menu.
	selections _ (1 to: items size) asArray.
	1 to: items size do: [:i |
		menu add: (items at: i) selector: #selectMVCItem: argument: (selections at: i).
		(lines includes: i) ifTrue: [menu addLine]].
	^ menu
! !
ToolBuilder subclass: #MVCToolBuilder
	instanceVariableNames: 'panes topSize widgets'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-MVC'!
!MVCToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0!
The MVC tool builder.!


!MVCToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 17:42'!
pluggableTreeSpec
	"We have no tree widget in MVC right now"
	^nil! !


!MVCToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:42'!
close: aWidget
	"Close a previously opened widget"
	aWidget controller closeAndUnschedule.! !

!MVCToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:41'!
open: anObject
	"Build and open the object. Answer the widget opened."
	| window |
	window := self build: anObject.
	window controller open.
	^window! !

!MVCToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:42'!
open: anObject label: aString
	"Build an open the object, labeling it appropriately.  Answer the widget opened."
	| window |
	window := self build: anObject.
	window label: aString.
	window controller open.
	^window! !

!MVCToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:46'!
runModal: aWidget
	"Run the (previously opened) widget modally, e.g., 
	do not return control to the sender before the user has responded."

	self error: 'Please implement me'.! !


!MVCToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:29'!
buildPluggableButton: aSpec
	| widget label state |
	label := aSpec label.
	state := aSpec state.
	widget := PluggableButtonView on: aSpec model
				getState: (state isSymbol ifTrue:[state])
				action: aSpec action
				label: (label isSymbol ifTrue:[label]).
	self register: widget id: aSpec name.
	(label isSymbol or:[label == nil]) ifFalse:[widget label: label].
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	^widget! !

!MVCToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:29'!
buildPluggableList: aSpec
	| widget listClass getIndex setIndex |
	aSpec getSelected ifNil:[
		listClass := PluggableListView.
		getIndex := aSpec getIndex.
		setIndex := aSpec setIndex.
	] ifNotNil:[
		listClass := PluggableListViewByItem.
		getIndex := aSpec getSelected.
		setIndex := aSpec setSelected.
	].
	widget := listClass on: aSpec model
				list: aSpec list
				selected: getIndex
				changeSelected: setIndex
				menu: aSpec menu
				keystroke: aSpec keyPress.
	self register: widget id: aSpec name.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	panes ifNotNil:[
		aSpec list ifNotNil:[panes add: aSpec list].
	].
	^widget! !

!MVCToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:29'!
buildPluggablePanel: aSpec
	| widget children |
	widget := View new model: aSpec model.
	self register: widget id: aSpec name.
	children := aSpec children.
	children isSymbol ifTrue:[
		"@@@@ FIXME: PluggablePanes need to remember their getChildrenSelector"
		"widget getChildrenSelector: children.
		widget update: children."
		children := #().
	].
	self buildAll: children in: widget.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	self setLayout: aSpec layout in: widget.
	^widget! !

!MVCToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:29'!
buildPluggableText: aSpec
	| widget |
	widget := PluggableTextView on: aSpec model
				text: aSpec getText 
				accept: aSpec setText
				readSelection: aSpec selection 
				menu: aSpec menu.
	self register: widget id: aSpec name.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	panes ifNotNil:[
		aSpec getText ifNotNil:[panes add: aSpec getText].
	].
	^widget! !

!MVCToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:30'!
buildPluggableWindow: aSpec
	| widget children |
	topSize := 0@0 corner: 640@480.
	aSpec layout == #proportional ifFalse:[
		"This needs to be implemented - probably by adding a single pane and then the rest"
		^self error: 'Not implemented'.
	].
	widget := StandardSystemView new.
	self register: widget id: aSpec name.
	widget model: aSpec model.
	children := aSpec children.
	children isSymbol ifTrue:[
		"This isn't implemented by StandardSystemView, so we fake it"
		children := widget model perform: children.
	].
	aSpec extent ifNotNil:[topSize :=  0@0 extent: aSpec extent].
	widget window: topSize.
	panes := OrderedCollection new.
	self buildAll: children in: widget.
	widget setUpdatablePanesFrom: panes.
	^widget! !


!MVCToolBuilder methodsFor: 'private' stamp: 'ar 2/10/2005 00:18'!
asWindow: aRectangle
	^(aRectangle origin * topSize extent) truncated
		corner: (aRectangle corner * topSize extent) truncated! !

!MVCToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:30'!
register: widget id: id
	id ifNil:[^self].
	widgets ifNil:[widgets := Dictionary new].
	widgets at: id put: widget.! !

!MVCToolBuilder methodsFor: 'private' stamp: 'ar 2/10/2005 00:17'!
setFrame: aRectangle in: widget
	| win |
	aRectangle ifNil:[^nil].
	win := self asWindow: aRectangle.
	widget window: win.! !

!MVCToolBuilder methodsFor: 'private' stamp: 'ar 2/10/2005 21:33'!
setLayout: layout in: widget
	layout == #proportional ifTrue:[^self].
	layout == #horizontal ifTrue:[
		| prev |
		prev := nil.
		widget subViews do:[:next|
			prev ifNotNil:[
				next align: next viewport topLeft with: prev viewport topRight.
			].
			prev := next.
		].
		^self].
	layout == #vertical ifTrue:[
		| prev |
		prev := nil.
		widget subViews do:[:next|
			prev ifNotNil:[
				next align: next viewport topLeft with: prev viewport bottomLeft.
			].
			prev := next.
		].
		^self].
	^self error: 'Unknown layout: ', layout.! !

!MVCToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:30'!
widgetAt: id ifAbsent: aBlock
	widgets ifNil:[^aBlock value].
	^widgets at: id ifAbsent: aBlock! !

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

MVCToolBuilder class
	instanceVariableNames: ''!

!MVCToolBuilder class methodsFor: 'accessing' stamp: 'ar 2/12/2005 18:49'!
isActiveBuilder
	"Answer whether I am the currently active builder"
	"This is really a way of answering whether 'Smalltalk isMVC'"
	ScheduledControllers ifNil:[^false].
	^ScheduledControllers activeControllerProcess == Processor activeProcess! !
ToolBuilderTests subclass: #MVCToolBuilderTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-MVC'!
!MVCToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0!
Tests for the MVC tool builder.!


!MVCToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:28'!
acceptWidgetText
	widget hasUnacceptedEdits: true.
	widget controller accept.! !

!MVCToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:22'!
changeListWidget
	widget changeModelSelection: widget getCurrentSelectionIndex + 1.! !

!MVCToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:16'!
fireButtonWidget
	widget performAction.! !

!MVCToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 14:46'!
setUp
	super setUp.
	builder := MVCToolBuilder new.! !
UIManager subclass: #MVCUIManager
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-MVC'!
!MVCUIManager commentStamp: 'ar 2/11/2005 21:53' prior: 0!
The MVC ui manager.!


!MVCUIManager methodsFor: 'ui requests' stamp: 'dtl 12/10/2005 16:36'!
chooseDirectory: label from: dir
	"Let the user choose a directory"
	^self notYetImplemented! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'dtl 12/10/2005 16:37'!
chooseFileMatching: patterns label: labelString
	"Let the user choose a file matching the given patterns"
	^self notYetImplemented! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/11/2005 15:43'!
chooseFrom: aList lines: linesArray title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	| menu |
	menu := PopUpMenu labelArray: aList lines: linesArray.
	^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:45'!
chooseFrom: labelList values: valueList lines: linesArray title: aString
	"Choose an item from the given list. Answer the selected item."
	| menu |
	menu := SelectionMenu labels: labelList lines: linesArray selections: valueList.
	^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/11/2005 15:43'!
confirm: queryString
	"Put up a yes/no menu with caption queryString. Answer true if the 
	response is yes, false if no. This is a modal question--the user must 
	respond yes or no."
	^PopUpMenu confirm: queryString! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/11/2005 15:43'!
confirm: aString orCancel: cancelBlock
	"Put up a yes/no/cancel menu with caption aString. Answer true if  
	the response is yes, false if no. If cancel is chosen, evaluate  
	cancelBlock. This is a modal question--the user must respond yes or no."
	^PopUpMenu confirm: aString orCancel: cancelBlock! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 6/25/2005 18:07'!
displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock
	"Display titleString as a caption over a progress bar while workBlock is evaluated."
	^ProgressInitiationException 
		display: titleString
		at: aPoint 
		from: minVal 
		to: maxVal 
		during: workBlock! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'dtl 12/10/2005 16:30'!
edit: aText label: labelString accept: anAction
	"Open an editor on the given string/text"

	Workspace new
		acceptContents: aText;
		acceptAction: anAction;
		openLabel: labelString
! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:07'!
informUserDuring: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUserDuring:[:bar|
			#(one two three) do:[:info|
				bar value: info.
				(Delay forSeconds: 1) wait]]"
	aBlock value:[:string| Transcript cr; show: string].! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 20:40'!
informUser: aString during: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait].
	"
	(SelectionMenu labels: '')
		displayAt: Sensor cursorPoint
		withCaption: aString
		during: [aBlock value]! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/11/2005 15:43'!
inform: aString
	"Display a message for the user to read and then dismiss"
	^PopUpMenu inform: aString! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:05'!
multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight
	"Create a multi-line instance of me whose question is queryString with
	the given initial answer. Invoke it centered at the given point, and
	answer the string the user accepts.  Answer nil if the user cancels.  An
	empty string returned means that the ussr cleared the editing area and
	then hit 'accept'.  Because multiple lines are invited, we ask that the user
	use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 
	submit; that way, the return key can be typed to move to the next line."
	^FillInTheBlank multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/11/2005 15:43'!
requestPassword: queryString
	"Create an instance of me whose question is queryString. Invoke it centered
	at the cursor, and answer the string the user accepts. Answer the empty 
	string if the user cancels."
	^FillInTheBlank requestPassword: queryString! !

!MVCUIManager methodsFor: 'ui requests' stamp: 'ar 2/11/2005 15:43'!
request: queryString initialAnswer: defaultAnswer 
	"Create an instance of me whose question is queryString with the given 
	initial answer. Invoke it centered at the given point, and answer the 
	string the user accepts. Answer the empty string if the user cancels."
	^FillInTheBlank request: queryString initialAnswer: defaultAnswer ! !

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

MVCUIManager class
	instanceVariableNames: ''!

!MVCUIManager class methodsFor: 'accessing' stamp: 'ar 2/13/2005 00:09'!
isActiveManager
	"Answer whether I should act as the active ui manager"
	"This is really a way of answering whether 'Smalltalk isMVC'"
	ScheduledControllers ifNil:[^false].
	^ScheduledControllers activeControllerProcess == Processor activeProcess! !
WiWPasteUpMorph subclass: #MVCWiWPasteUpMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-ST80'!
!MVCWiWPasteUpMorph commentStamp: '<historical>' prior: 0!
A subclass of WiWPasteUpMorph that supports Morphic worlds embedded in MVC Views.!


!MVCWiWPasteUpMorph methodsFor: 'activation' stamp: 'RAA 5/24/2000 10:30'!
becomeTheActiveWorldWith: evt

	worldState canvas: nil.	"safer to start from scratch"
	self installFlaps.

! !

!MVCWiWPasteUpMorph methodsFor: 'activation' stamp: 'RAA 11/25/1999 10:09'!
revertToParentWorldWithEvent: evt

">>unused, but we may want some of this later
	self damageRecorder reset.
	World _ parentWorld.
	World assuredCanvas.
	World installFlaps.
	owner changed.
	hostWindow setStripeColorsFrom: Color red.
	World restartWorldCycleWithEvent: evt.
<<<"

! !


!MVCWiWPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/13/2000 11:53'!
worldUnderCursor

        ^self! !


!MVCWiWPasteUpMorph methodsFor: 'change reporting' stamp: 'RAA 11/27/2000 10:35'!
invalidRect: damageRect from: aMorph

	worldState ifNil: [^self].
	worldState recordDamagedRect: damageRect
! !


!MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 11/25/1999 09:20'!
position: aPoint
	"Change the position of this morph and and all of its submorphs."

	| delta |
	delta _ aPoint - bounds topLeft.
	(delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"
	self changed.
	self privateFullMoveBy: delta.
	self changed.
! !

!MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 14:38'!
resetViewBox
	| c |
	(c := worldState canvas) isNil ifTrue: [^self resetViewBoxForReal].
	c form == Display ifFalse: [^self resetViewBoxForReal].
	c origin = (0 @ 0) ifFalse: [^self resetViewBoxForReal].
	c clipRect extent = self viewBox extent 
		ifFalse: [^self resetViewBoxForReal]! !

!MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/6/2000 17:15'!
resetViewBoxForReal

	self viewBox ifNil: [^self].
	worldState canvas: (
		(Display getCanvas)
			copyOffset:  0@0
			clipRect: self viewBox
	)! !


!MVCWiWPasteUpMorph methodsFor: 'project' stamp: 'di 11/16/2001 09:42'!
project
	^ Project current! !


!MVCWiWPasteUpMorph methodsFor: 'project state' stamp: 'dgd 2/22/2003 14:38'!
viewBox: newViewBox 
	| vb |
	worldState resetDamageRecorder.	"since we may have moved, old data no longer valid"
	((vb := self viewBox) isNil or: [vb ~= newViewBox]) 
		ifTrue: [worldState canvas: nil].
	worldState viewBox: newViewBox.
	self bounds: newViewBox.	"works better here than simply storing into bounds"
	worldState assuredCanvas.
	"Paragraph problem workaround; clear selections to avoid screen droppings:"
	self flag: #arNote.	"Probably unnecessary"
	worldState handsDo: [:h | h releaseKeyboardFocus].
	self fullRepaintNeeded! !
FileDirectory subclass: #MacFileDirectory
	instanceVariableNames: ''
	classVariableNames: 'TypeToMimeMappings'
	poolDictionaries: ''
	category: 'Files-Directories'!
!MacFileDirectory commentStamp: '<historical>' prior: 0!
I represent a Macintosh FileDirectory.
!


!MacFileDirectory methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'!
fullNameFor: fileName
	"Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name."
	"Details: Note that path relative to a directory, such as '../../foo' are disallowed by this algorithm.  Also note that this method is tolerent of a nil argument -- is simply returns nil in this case."
	"Fix by hmm: for a file in the root directory of a volume on MacOS, the filePath (name of the directory) is not  recognizable as an absolute path anymore (it has no delimiters). Therefore, the original fileName is tested for absoluteness, and the filePath is only made absolute if the original fileName was not absolute"

	| correctedLocalName prefix |
	fileName isEmptyOrNil ifTrue: [^ fileName].
	DirectoryClass splitName: fileName to:
		[:filePath :localName |
			correctedLocalName := localName isEmpty 
				ifFalse: [self checkName: localName fixErrors: true]
				ifTrue: [localName].
			prefix := (DirectoryClass isAbsolute: fileName)
						ifTrue: [filePath]
						ifFalse: [self fullPathFor: filePath]].
	prefix isEmpty
		ifTrue: [^correctedLocalName].
	prefix last = self pathNameDelimiter
		ifTrue:[^ prefix, correctedLocalName]
		ifFalse:[^ prefix, self slash, correctedLocalName]! !


!MacFileDirectory methodsFor: 'file operations' stamp: 'yo 12/19/2003 21:15'!
fullPathFor: path
	"Return the fully-qualified path name for the given file."
	path isEmptyOrNil ifTrue: [^ pathName asSqueakPathName].
	(self class isAbsolute: path) ifTrue: [^ path].
	pathName asSqueakPathName = ''			"Root dir?"
		ifTrue: [ ^path].
	^(path first = $:)
		ifTrue: [ pathName asSqueakPathName, path ]
		ifFalse: [pathName asSqueakPathName, ':' , path]! !

!MacFileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'!
mimeTypesFor: fileName
	"Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type"
	| typeCreator type | 
	typeCreator := self getMacFileTypeAndCreator: ((self fullNameFor: fileName)).
	type := (typeCreator at: 1) asLowercase.
	^TypeToMimeMappings at: type ifAbsent:[super mimeTypesFor: fileName]! !

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

MacFileDirectory class
	instanceVariableNames: ''!

!MacFileDirectory class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:32'!
initializeTypeToMimeMappings
	"MacFileDirectory initializeTypeToMimeMappings"
	TypeToMimeMappings := Dictionary new.
	#(
		"format"
		"(abcd		('image/gif'))"
	) do:[:spec|
		TypeToMimeMappings at: spec first asString put: spec last.
	].
! !

!MacFileDirectory class methodsFor: 'class initialization' stamp: 'nk 12/5/2002 11:17'!
isAbsolute: fileName
	"Return true if the given fileName is absolute. The rules are:

If a path begins with a colon, it is relative.
Otherwise,
  If it contains a colon anywhere, it is absolute and the first component is the volume name.
  Otherwise,
    It is relative."

	^fileName first ~= $:
		and: [ fileName includes: $: ]! !


!MacFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:06'!
isActiveDirectoryClass
	^ super isActiveDirectoryClass
		and: [(SmalltalkImage current getSystemAttribute: 1201) isNil
				or: [(SmalltalkImage current getSystemAttribute: 1201) asNumber <= 31]]! !

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'di 5/11/1999 08:53'!
isCaseSensitive
	"Mac OS ignores the case of file names"
	^ false! !

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'stephaneducasse 2/4/2006 20:32'!
makeAbsolute: path
	"Ensure that path looks like an absolute path"
	| absolutePath |
	(self isAbsolute: path)
		ifTrue: [ ^path ].
	"If a path begins with a colon, it is relative."
	absolutePath := (path first = $:)
		ifTrue: [ path copyWithoutFirst ]
		ifFalse: [ path ].
	(self isAbsolute: absolutePath)
		ifTrue: [ ^absolutePath ].
	"Otherwise, if it contains a colon anywhere, it is absolute and the first component is the volume name."
	^absolutePath, ':'! !

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:59'!
makeRelative: path
	"Ensure that path looks like an relative path"
	^path first = $:
		ifTrue: [ path ]
		ifFalse: [ ':', path ]! !

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'hg 9/28/2001 15:23'!
maxFileNameLength

	^31! !

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'jm 12/4/97 22:57'!
pathNameDelimiter

	^ $:
! !


!MacFileDirectory class methodsFor: '*network-uri' stamp: 'mir 3/24/2005 17:03'!
privateFullPathForURI: 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
! !
TestCase subclass: #MacFileDirectoryTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Tests'!

!MacFileDirectoryTest methodsFor: 'test' stamp: 'sd 10/27/2003 18:05'!
testMacFileDirectory
	"(self run: #testMacFileDirectory)"
	
	"This fails before the the fix if the Squeak directory is on the root
	directory like: 'HardDisk:Squeak'
	But should work both before and after the fix of John if there is several
	directories in the hieracry: HardDisk:User:Squeak"
	"If somebody can find a way to make the test failed all the time when the fix is not 
	present we should replace it"

	self assert: (FileDirectory default fullName) = (FileDirectory default fullNameFor: (FileDirectory default fullName))! !

!MacFileDirectoryTest methodsFor: 'test' stamp: 'nk 7/30/2004 17:54'!
testMacFileFullPathFor
	"(self run: #testMacFileFullPathFor)"

	SmalltalkImage current  platformName = 'Mac OS' 
		ifTrue: 
			[self 
				assert: (MacFileDirectory isAbsolute: (FileDirectory default 
								fullPathFor: FileDirectory default fullName)).
			self 
				deny: (MacFileDirectory isAbsolute: (FileDirectory on: 'Data') pathName)]! !

!MacFileDirectoryTest methodsFor: 'test' stamp: 'kfr 7/28/2004 15:06'!
testMacIsAbsolute
	"(self selector: #testMacIsAbsolute) run"
	
	
	self deny: (MacFileDirectory isAbsolute: 'Volumes').
	self assert: (MacFileDirectory isAbsolute: 'Volumes:Data:Stef').
	self deny: (MacFileDirectory isAbsolute: ':Desktop:test.st')! !

!MacFileDirectoryTest methodsFor: 'test' stamp: 'sd 10/27/2003 18:02'!
testMakeAbsolute

	self assert: (MacFileDirectory isAbsolute: (MacFileDirectory makeAbsolute: 'Data')).
	self assert: (MacFileDirectory isAbsolute: (MacFileDirectory makeAbsolute: ':Data')).
! !
MacFileDirectory subclass: #MacHFSPlusFileDirectory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Directories'!

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

MacHFSPlusFileDirectory class
	instanceVariableNames: ''!

!MacHFSPlusFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:06'!
isActiveDirectoryClass
	"Ok, lets see if we support HFS Plus file names, the long ones"

	^ (self pathNameDelimiter = self primPathNameDelimiter) and: [(SmalltalkImage current  getSystemAttribute: 1201) notNil and: [(SmalltalkImage current getSystemAttribute: 1201) asNumber > 31]]! !

!MacHFSPlusFileDirectory class methodsFor: 'platform specific' stamp: 'JMM 11/14/1935 00:02'!
maxFileNameLength

	^ 255! !
ClipboardInterpreter subclass: #MacRomanClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!MacRomanClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:10'!
fromSystemClipboard: aString

	^ aString macToSqueak.
! !

!MacRomanClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:05'!
toSystemClipboard: aString

	| result |
	aString isOctetString ifTrue: [^ aString asOctetString squeakToMac].

	result _ WriteStream on: (String new: aString size).
	aString do: [:each | each asciiValue < 256 ifTrue: [result nextPut: each squeakToMac]].
	^ result contents.
! !
KeyboardInputInterpreter subclass: #MacRomanInputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!MacRomanInputInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:10'!
nextCharFrom: sensor firstEvt: evtBuf

	| keyValue |
	keyValue := evtBuf third.
	^ keyValue asCharacter macToSqueak.
! !
TextConverter subclass: #MacRomanTextConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!MacRomanTextConverter commentStamp: '<historical>' prior: 0!
Text converter for Mac Roman.  An encoding used for the languages originated from Western Europe area.!


!MacRomanTextConverter methodsFor: 'conversion' stamp: 'ar 4/10/2005 16:10'!
nextFromStream: aStream 
	| character1 |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	character1 charCode = 165 ifTrue: [^ (Character value: 183)].
	^ character1 macToSqueak.
! !

!MacRomanTextConverter methodsFor: 'conversion' stamp: 'ar 4/5/2006 15:05'!
nextPut: aCharacter toStream: aStream 
	| ch |
	aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream].
	(ch := aCharacter squeakToMac) asciiValue > 255 
		ifTrue:[^self error: 'Cannot write wide characters'].
	aStream basicNextPut: ch.
! !


!MacRomanTextConverter methodsFor: 'friend' stamp: 'yo 8/5/2003 22:20'!
currentCharSize

	^ 1.
! !

!MacRomanTextConverter methodsFor: 'friend' stamp: 'yo 8/4/2003 12:33'!
leadingChar

	^ 0.
! !

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

MacRomanTextConverter class
	instanceVariableNames: ''!

!MacRomanTextConverter class methodsFor: 'utilities' stamp: 'yo 8/4/2003 12:33'!
encodingNames 

	^ #('mac-roman' ) copy
! !
ClipboardInterpreter subclass: #MacShiftJISClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!MacShiftJISClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'tetha 3/15/2004 08:38'!
fromSystemClipboard: aString
	^ aString convertFromWithConverter: ShiftJISTextConverter new! !

!MacShiftJISClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'tetha 3/15/2004 08:37'!
toSystemClipboard: text

	| string |
	"self halt."
	string _ text asString.
	string isAsciiString ifTrue: [^ string asOctetString].
	string isOctetString ifTrue: [^ string "hmm"].
	^ string convertToWithConverter: ShiftJISTextConverter new .
! !
KeyboardInputInterpreter subclass: #MacShiftJISInputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!MacShiftJISInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/13/2003 13:45'!
initialize

	converter _ ShiftJISTextConverter new.
! !

!MacShiftJISInputInterpreter methodsFor: 'as yet unclassified' stamp: 'sumim 8/29/2003 15:25'!
nextCharFrom: sensor firstEvt: evtBuf

	| firstChar secondChar peekEvent keyValue type stream multiChar |
	keyValue _ evtBuf third.
	evtBuf fourth = EventKeyChar ifTrue: [type _ #keystroke].
	peekEvent _ sensor peekEvent.
	(peekEvent notNil and: [peekEvent fourth = EventKeyDown]) ifTrue: [
		sensor nextEvent.
		peekEvent _ sensor peekEvent].

	(type == #keystroke
	and: [peekEvent notNil 
	and: [peekEvent first = EventTypeKeyboard
	and: [peekEvent fourth = EventKeyChar]]]) ifTrue: [
		firstChar _ keyValue asCharacter.
		secondChar _ (peekEvent third) asCharacter.
		stream _ ReadStream on: (String with: firstChar with: secondChar).
		multiChar _ converter nextFromStream: stream.
		multiChar isOctetCharacter ifFalse: [sensor nextEvent].
		^ multiChar].

	^ keyValue asCharacter! !
KeyboardInputInterpreter subclass: #MacUnicodeInputInterpreter
	instanceVariableNames: 'keyValueIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!MacUnicodeInputInterpreter methodsFor: 'initialization' stamp: 'ts 10/29/2005 10:22'!
initialize
	| satisfiesVersion |
	satisfiesVersion := self
				majorMinorBuildFrom: SmalltalkImage current vmVersion
				satisfies: [:major :minor :build | major >= 3
						and: [minor >= 8
								and: [build >= 7]]].
	satisfiesVersion
		ifTrue: [keyValueIndex := 6]
		ifFalse: [keyValueIndex := 3]! !


!MacUnicodeInputInterpreter methodsFor: 'conversion' stamp: 'tetha 11/22/2005 22:05'!
japaneseSpecialMark: anInteger 
	"For japanese special marks.
	This method converts 'YEN SIGN' (16rA5) to 'REVERSE SOLIDUS' (16r5C)
	and use Japanese leading characters instead of Unicode for below
	characters.
	'CENT SIGN' (16rA2)
	'POUND SIGN' (16rA3)
	'SECTION SIGN' (16rA7)
	'DIAERESIS' (16rA8)
	'NOT SIGN' (16rAC)
	'DEGREE SIGN' (16rB0)
	'PLUS-MINUS SIGN (16rB1)
	'ACUTE ACCENT' (16rB4)
	'PILCROW SIGN' (16rB6)
	'MULTIPLICATION SIGN' (16rD7)
	'DIVISION SIGN' (16rF7)
	"
	Project current localeID
			= (LocaleID isoLanguage: 'ja')
		ifTrue: [anInteger = 16rA5
				ifTrue: [^ Character value: 16r5C].
			(#(16rA2 16rA3 16rA7 16rA8 16rAC 16rB0 16rB1 16rB4 16rB6 16rD7 16rF7) includes: anInteger)
				ifTrue: [^ Character leadingChar: JapaneseEnvironment leadingChar code: anInteger]].
	^ nil! !


!MacUnicodeInputInterpreter methodsFor: 'accessing' stamp: 'ts 10/29/2005 10:23'!
keyValueIndex
	^ keyValueIndex! !


!MacUnicodeInputInterpreter methodsFor: 'version check' stamp: 'ts 10/29/2005 10:17'!
majorMinorBuildFrom: aString satisfies: aBlock 
	| v |
	v := aString
				ifNil: [^ false].
	v := ((v copyAfter: $])
				findTokens: $ ) last findTokens: $..
	v size = 3
		ifFalse: [^ false].
	v := v
				collect: [:s | s initialIntegerOrNil
						ifNil: [^ false]].
	^ aBlock valueWithArguments: v asArray! !


!MacUnicodeInputInterpreter methodsFor: 'keyboard' stamp: 'tetha 11/22/2005 21:49'!
nextCharFrom: sensor firstEvt: evtBuf 
	| keyValue mark |
	keyValue := evtBuf at: self keyValueIndex.
	mark := self japaneseSpecialMark: keyValue.
	mark notNil
		ifTrue: [^ mark].
	keyValue < 256
		ifTrue: [^ (Character value: keyValue) squeakToIso].
	"Smalltalk systemLanguage charsetClass charFromUnicode: keyValue."
	^ Unicode value: keyValue! !
SmallLandColorTheme subclass: #MagentaSmallLandColorTheme
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!MagentaSmallLandColorTheme methodsFor: 'initialization' stamp: 'dgd 3/12/2006 13:39'!
baseColors
	" 
	MagentaSmallLandColorTheme apply.
	"
	^ Array
		with: (Color fromArray: #(0.8 0.1 0.7 ))
		with: (Color fromArray: #(1.0 0.3 0.9 ))
		with: (Color fromArray: #(1.0 0.9 0.8 ))! !
BorderedMorph subclass: #MagnifierMorph
	instanceVariableNames: 'magnification trackPointer srcExtent showPointer'
	classVariableNames: 'RecursionLock'
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!MagnifierMorph commentStamp: '<historical>' prior: 0!
MagnifierMorph instances are magnifying lenses that magnify the morphs below them (if grabbed or if trackPointer is false) or the area around the mouse pointer.

Instance variables:

magnification	<Number> The magnification to use. If non-integer, smooths the magnified form.

trackPointer		<Boolean> If set, magnifies the area around the Hand. If not, magnfies the area underneath the magnifier center.

showPointer		<Boolean> If set, display a small reversed rectangle in the center of the lens. Also enables the display of Morphs in the Hand itself.

srcExtent		<Rectangle> The extent of the source rectangle.
		
Class variables:

RecursionLock	<MagnifierMorph|nil> Used to avoid infinite recursion when getting the source patch to display.!


!MagnifierMorph methodsFor: 'accessing' stamp: 'bf 9/21/1999 09:31'!
borderWidth: anInteger
	"Grow outwards preserving innerBounds"
	| c |  
	c _ self center.
	super borderWidth: anInteger.
	super extent: self defaultExtent.
	self center: c.! !

!MagnifierMorph methodsFor: 'accessing' stamp: 'bf 9/21/1999 08:51'!
hasTranslucentColor
	"I may show what's behind me, so tell the hand to don't cache"
	^self sourceRect intersects: self bounds! !

!MagnifierMorph methodsFor: 'accessing' stamp: 'nk 3/6/2004 10:14'!
showPointer: aBoolean
	"If aBoolean is true, display the current pointer position as a small square in the center of the lens."

	showPointer == aBoolean ifTrue: [ ^self ].
	showPointer _ aBoolean.
	self changed.! !


!MagnifierMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:06'!
drawOn: aCanvas
	super drawOn: aCanvas.		"border and fill"
	aCanvas isShadowDrawing ifFalse: [
		"Optimize because #magnifiedForm is expensive"
		aCanvas paintImage: self magnifiedForm at: self innerBounds origin]! !


!MagnifierMorph methodsFor: 'event handling' stamp: 'bf 9/18/1999 20:42'!
handlesMouseDown: evt
	^evt yellowButtonPressed
		or: [super handlesMouseDown: evt]! !

!MagnifierMorph methodsFor: 'event handling' stamp: 'bf 9/21/1999 10:45'!
mouseDown: evt
	evt yellowButtonPressed
		ifTrue: [self chooseMagnification: evt]
		ifFalse: [super mouseDown: evt]! !


!MagnifierMorph methodsFor: 'geometry' stamp: 'bf 9/21/1999 09:22'!
defaultExtent
	^(srcExtent * magnification) truncated + (2 * borderWidth)! !

!MagnifierMorph methodsFor: 'geometry' stamp: 'bf 9/21/1999 09:23'!
extent: aPoint
	"Round to multiples of magnification"
	srcExtent _ (aPoint - (2 * borderWidth)) // magnification.
	^super extent: self defaultExtent! !


!MagnifierMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

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

!MagnifierMorph methodsFor: 'initialization' stamp: 'nk 3/6/2004 10:47'!
initialize
	"initialize the state of the receiver"
	super initialize.

	trackPointer _ true.
	showPointer _ false.
	magnification _ 2.

	self extent: 128 @ 128! !


!MagnifierMorph methodsFor: 'magnifying' stamp: 'bf 9/21/1999 12:27'!
magnification: aNumber
	| c |  
	magnification _ aNumber min: 8 max: 0.5.
	magnification _ magnification roundTo:
		(magnification < 3 ifTrue: [0.5] ifFalse: [1]).
	srcExtent _ srcExtent min: (512@512) // magnification. "to prevent accidents"
	c _ self center.
	super extent: self defaultExtent.
	self center: c.! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'nk 3/17/2004 11:34'!
magnifiedForm
	"Answer the magnified form"
	| srcRect form exclusion magnified |
	srcRect := self sourceRectFrom: self sourcePoint.
	(RecursionLock isNil and: [ self showPointer or: [ srcRect intersects: self bounds ]])
		ifTrue: [RecursionLock := self.
			exclusion := self isRound
						ifTrue: [owner]
						ifFalse: [self].
			form := self currentWorld
						patchAt: srcRect
						without: exclusion
						andNothingAbove: false.
			RecursionLock := nil]
		ifFalse: ["cheaper method if the source is not occluded"
			form := Display copy: srcRect].
	"smooth if non-integer scale"
	magnified := form
				magnify: form boundingBox
				by: magnification
				smoothing: (magnification isInteger
						ifTrue: [1]
						ifFalse: [2]).
	"display the pointer rectangle if desired"
	self showPointer
		ifTrue: [magnified
				reverse: (magnified center - (2 @ 2) extent: 4 @ 4)
				fillColor: Color white].
	^ magnified! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'bf 11/1/2000 16:02'!
sourcePoint
	"If we are being dragged use our center, otherwise use pointer position"
	^(trackPointer not or: [owner notNil and: [owner isHandMorph]])
		ifTrue: [self center]
		ifFalse: [self currentHand position]! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'bf 9/21/1999 08:47'!
sourceRect
	^self sourceRectFrom: self sourcePoint
! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'di 12/17/1999 13:42'!
sourceRectFrom: aPoint
	^ (aPoint extent: srcExtent) translateBy: (srcExtent // -2) + 1.
! !


!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/6/2004 10:15'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu
		addLine;
		add: 'magnification...' translated action: #chooseMagnification;
		addUpdating: #trackingPointerString action: #toggleTrackingPointer;
		addUpdating: #showingPointerString action: #toggleShowingPointer;
		addUpdating: #toggleRoundString action: #toggleRoundness.! !

!MagnifierMorph methodsFor: 'menu' stamp: 'md 11/16/2003 15:14'!
chooseMagnification
	| result |
	result _ (SelectionMenu selections: #(1.5 2 4 8))
		startUpWithCaption: ('Choose magnification
(currently {1})' translated format:{magnification}).
	(result isNil or: [result = magnification]) ifTrue: [^ self].
	magnification _ result.
	self extent: self extent. "round to new magnification"
	self changed. "redraw even if extent wasn't changed"! !

!MagnifierMorph methodsFor: 'menu' stamp: 'di 8/24/2000 14:02'!
chooseMagnification: evt
	| handle origin aHand currentMag |
	currentMag _ magnification.
	aHand _ evt ifNil: [self currentHand] ifNotNil: [evt hand].
	origin _ aHand position y.
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | self magnification: (newPoint y - origin) / 8.0 + currentMag].
	aHand attachMorph: handle.
	handle startStepping.
	self changed. "Magnify handle"! !

!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/17/2004 11:34'!
showPointer
	^showPointer ifNil: [ showPointer _ false ].! !

!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/17/2004 11:34'!
showingPointerString
	^ (self showPointer
		ifTrue: ['stop showing pointer']
		ifFalse: ['start showing pointer']) translated! !

!MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/17/2004 11:35'!
toggleShowingPointer
	self showPointer: self showPointer not! !

!MagnifierMorph methodsFor: 'menu' stamp: 'bf 9/20/1999 15:48'!
toggleTrackingPointer
	trackPointer _ trackPointer not! !

!MagnifierMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:51'!
trackingPointerString
	^ (trackPointer
		ifTrue: ['stop tracking pointer']
		ifFalse: ['start tracking pointer']) translated! !


!MagnifierMorph methodsFor: 'round view' stamp: 'di 9/28/1999 23:01'!
isRound

	^ owner isMemberOf: ScreeningMorph! !

!MagnifierMorph methodsFor: 'round view' stamp: 'dgd 8/30/2003 21:51'!
toggleRoundString
	^ (self isRound
		ifTrue: ['be square']
		ifFalse: ['be round'])  translated! !

!MagnifierMorph methodsFor: 'round view' stamp: 'di 9/28/1999 23:16'!
toggleRoundness
	| sm w |
	w _ self world.
	self isRound
		ifTrue: [owner delete.
				w addMorph: self]
		ifFalse: [sm _ ScreeningMorph new position: self position.
				sm addMorph: self.
				sm addMorph: (EllipseMorph newBounds: self bounds).
				w addMorph: sm]! !


!MagnifierMorph methodsFor: 'stepping and presenter' stamp: 'di 9/28/1999 07:57'!
step
	self changed! !


!MagnifierMorph methodsFor: 'testing' stamp: 'di 9/28/1999 07:57'!
stepTime
	^ 0! !

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

MagnifierMorph class
	instanceVariableNames: ''!

!MagnifierMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:14'!
initialize

	self registerInFlapsRegistry.! !

!MagnifierMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:14'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(MagnifierMorph		newRound	'Magnifier'			'A magnifying glass') 
						forFlapNamed: 'Widgets']! !

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

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


!MagnifierMorph class methodsFor: 'instance creation' stamp: 'sw 6/25/2001 13:33'!
newRound
	"Answer a round Magnifier"

	| aMagnifier sm |
	aMagnifier _ self new.
	sm _ ScreeningMorph new position: aMagnifier position.
	sm addMorph: aMagnifier.
	sm addMorph: (EllipseMorph newBounds: aMagnifier bounds).
	sm setNameTo: 'Magnifier'.
	^ sm! !

!MagnifierMorph class methodsFor: 'instance creation' stamp: 'nk 3/6/2004 10:28'!
newShowingPointer
	"Answer a Magnifier that also displays Morphs in the Hand and the Hand position"

	^(self new)
		showPointer: true;
		setNameTo: 'HandMagnifier';
		yourself! !


!MagnifierMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 15:04'!
descriptionForPartsBin
	^ self partName:	'Magnifier'
		categories:		#('Useful')
		documentation:	'A magnifying glass'! !

!MagnifierMorph class methodsFor: 'parts bin' stamp: 'nk 3/6/2004 10:27'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'RoundGlass'
		categoryList: #(Useful)
		documentation: 'A round magnifying glass'
		globalReceiverSymbol: #MagnifierMorph
		nativitySelector: #newRound.
		
	DescriptionForPartsBin
		formalName: 'Hand Magnifier'
		categoryList: #(Useful)
		documentation: 'A magnifying glass that also shows Morphs in the Hand and displays the Hand position.'
		globalReceiverSymbol: #MagnifierMorph
		nativitySelector: #newShowingPointer }! !
Object subclass: #Magnitude
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Magnitude commentStamp: 'sd 9/4/2005 10:14' prior: 0!
I'm the abstract class Magnitude that provides common protocol for objects that have
the ability to be compared along a linear dimension, such as dates or times.
Subclasses of Magnitude include Date, ArithmeticValue, and Time, as well as
Character and LookupKey.
 
 
My subclasses should implement
  < aMagnitude 
  = aMagnitude 
  hash

Here are some example of my protocol:
     3 > 4
     5 = 6
     100 max: 9
	7 between: 5 and: 10 
!


!Magnitude methodsFor: 'comparing'!
< aMagnitude 
	"Answer whether the receiver is less than the argument."

	^self subclassResponsibility! !

!Magnitude methodsFor: 'comparing'!
<= aMagnitude 
	"Answer whether the receiver is less than or equal to the argument."

	^(self > aMagnitude) not! !

!Magnitude methodsFor: 'comparing'!
= aMagnitude 
	"Compare the receiver with the argument and answer with true if the 
	receiver is equal to the argument. Otherwise answer false."

	^self subclassResponsibility! !

!Magnitude methodsFor: 'comparing'!
> aMagnitude 
	"Answer whether the receiver is greater than the argument."

	^aMagnitude < self! !

!Magnitude methodsFor: 'comparing'!
>= aMagnitude 
	"Answer whether the receiver is greater than or equal to the argument."

	^(self < aMagnitude) not! !

!Magnitude methodsFor: 'comparing'!
between: min and: max 
	"Answer whether the receiver is less than or equal to the argument, max, 
	and greater than or equal to the argument, min."

	^self >= min and: [self <= max]! !

!Magnitude methodsFor: 'comparing'!
hash
	"Hash must be redefined whenever = is redefined."

	^self subclassResponsibility! !

!Magnitude methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !


!Magnitude methodsFor: 'testing'!
max: aMagnitude 
	"Answer the receiver or the argument, whichever has the greater 
	magnitude."

	self > aMagnitude
		ifTrue: [^self]
		ifFalse: [^aMagnitude]! !

!Magnitude methodsFor: 'testing'!
min: aMagnitude 
	"Answer the receiver or the argument, whichever has the lesser 
	magnitude."

	self < aMagnitude
		ifTrue: [^self]
		ifFalse: [^aMagnitude]! !

!Magnitude methodsFor: 'testing'!
min: aMin max: aMax 

	^ (self min: aMin) max: aMax! !

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

Magnitude class
	instanceVariableNames: ''!
Object subclass: #MailAddressParser
	instanceVariableNames: 'tokens addresses curAddrTokens'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RFC822'!
!MailAddressParser commentStamp: '<historical>' prior: 0!
Parse mail addresses.  The basic syntax is:

	addressList := MailAddressParser addressesIn: aString

This currently only returns the bare addresses, but it could also return a list of the address "source codes".  For example, if you give it "Joe <joe@foo>, <jane>", it will currently return a list ('joe@foo' 'jane').  It would be nice to also get a list ('Joe <joe@foo>'  '<jane>').!


!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:31'!
addToAddress
	"add the last token to the address.  removes the token from the collection"
	curAddrTokens addFirst: (tokens removeLast)! !

!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:30'!
finishAddress
	"we've finished one address.  Bundle it up and add it to the list of addresses"
	| address |

	address _ String streamContents: [ :str |
		curAddrTokens do: [ :tok | str nextPutAll: tok text ] ].

	addresses addFirst: address.

	curAddrTokens _ nil.! !

!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:30'!
startNewAddress
	"set up data structures to begin a new address"
	(curAddrTokens ~~ nil) ifTrue: [
		self error: 'starting new address before finishing the last one!!' ].

	curAddrTokens _ OrderedCollection new.
	! !


!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:08'!
grabAddressWithRoute
	"grad an address of the form 'Descriptive Text <real.address@c.d.e>"
	
	self startNewAddress.

	tokens removeLast.	"remove the >"

	"grab until we see a $<"
	[ 
		tokens isEmpty ifTrue: [
			self error: '<> are not matched' ].
		tokens last type = $<
	] whileFalse: [ self addToAddress ].

	tokens removeLast.  "remove the <"


	self removePhrase.

	self finishAddress! !

!MailAddressParser methodsFor: 'parsing' stamp: 'bf 3/12/2000 20:06'!
grabAddresses
	"grab all the addresses in the string"
	| token |
	"remove comments"
	tokens removeAllSuchThat: [:t | t type == #Comment].
	"grab one address or address group each time through this loop"
	[ 
		"remove commas"
		[
			tokens isEmpty not and: [ tokens last type = $, ]
		] whileTrue: [ tokens removeLast ].

		"check whether any tokens are left"
		tokens isEmpty 
	] whileFalse: [
		token _ tokens last.

		"delegate, depending on what form the address is in"
		"the from can be determined from the last token"

		token type = $> ifTrue: [
			self grabAddressWithRoute ]
		ifFalse: [ 
			(#(Atom DomainLiteral QuotedString) includes: token type)  ifTrue: [
				self grabBasicAddress ]
		ifFalse: [
			token type = $; ifTrue: [
				self grabGroupAddress ]
		ifFalse: [
			^self error: 'un-recognized address format' ] ] ]
	].

	^addresses! !

!MailAddressParser methodsFor: 'parsing' stamp: 'ls 10/23/1998 13:39'!
grabBasicAddress
	"grad an address of the form a.b@c.d.e"
	self startNewAddress.
	"grab either the domain if specified, or the domain if not"
	self addToAddress.
	[tokens isEmpty not and: [ tokens last type = $.] ] 
		whileTrue: 
			["add name-dot pairs of tokens"
			self addToAddress.
			(#(Atom QuotedString ) includes: tokens last type)
				ifFalse: [self error: 'bad token in address: ' , tokens last text].
			self addToAddress].
	(tokens isEmpty or: [tokens last type ~= $@])
		ifTrue: ["no domain specified"
			self finishAddress]
		ifFalse: 
			["that was the domain.  check that no QuotedString's slipped in"
			curAddrTokens do: [:tok | tok type = #QuotedString ifTrue: [self error: 'quote marks are not allowed within a domain name (' , tok text , ')']].
			"add the @ sign"
			self addToAddress.
			"add the local part"
			(#(Atom QuotedString ) includes: tokens last type)
				ifFalse: [self error: 'invalid local part for address: ' , tokens last text].
			self addToAddress.
			"add word-dot pairs if there are any"
			[tokens isEmpty not and: [tokens last type = $.]]
				whileTrue: 
					[self addToAddress.
					(tokens isEmpty not and: [#(Atom QuotedString ) includes: tokens last type])
						ifTrue: [self addToAddress]].
			self finishAddress]! !

!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:07'!
grabGroupAddress
	"grab an address of the form 'phrase : address, address, ..., address;'"
	"I'm not 100% sure what this format means, so I'm just returningthe list of addresses between the : and ;   -ls  (if this sounds right to someone, feel free to remove this comment :)"

	"remove the $; "
	tokens removeLast.

	"grab one address each time through this loop"
	[ 
		"remove commas"
		[
			tokens isEmpty not and: [ tokens last type = $, ]
		] whileTrue: [ tokens removeLast ].

		tokens isEmpty ifTrue: [
			"no matching :"
			^self error: 'stray ; in address list'. ].

		tokens last type = $:
	] whileFalse: [
		"delegate to either grabAddressWithRoute, or grabBasicAddress.  nested groups are not allowed"

		tokens last type = $> ifTrue: [
			self grabAddressWithRoute ]
		ifFalse: [ 
			(#(Atom DomainLiteral QuotedString) includes: tokens last type)  ifTrue: [
				self grabBasicAddress ]
		ifFalse: [
			^self error: 'un-recognized address format' ] ]
	].

	tokens removeLast.   "remove the :"

	self removePhrase.! !

!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:08'!
removePhrase
	"skip most characters to the left of this"

	[
		tokens isEmpty not and: [
			#(Atom QuotedString $. $@) includes: (tokens last type) ]
	] whileTrue: [ tokens removeLast ].
! !


!MailAddressParser methodsFor: 'private-initialization' stamp: 'ls 9/13/1998 01:25'!
initialize: tokenList
	tokens _ tokenList asOrderedCollection copy.
	addresses _ OrderedCollection new.! !

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

MailAddressParser class
	instanceVariableNames: ''!

!MailAddressParser class methodsFor: 'parsing' stamp: 'ls 9/13/1998 01:34'!
addressesIn: aString
	"return a collection of the bare addresses listed in aString"
	| tokens |
	tokens _ MailAddressTokenizer tokensIn: aString.
	^(self new initialize: tokens) grabAddresses! !
TestCase subclass: #MailAddressParserTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NetworkTests-RFC822'!
!MailAddressParserTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class MailAddressParser. 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!


!MailAddressParserTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:31'!
testAddressesIn

	| testString correctAnswer |

	testString := 'joe@lama.com, joe2@lama.com joe3@lama.com joe4 , Not an Address <joe5@address>, joe.(annoying (nested) comment)literal@[1.2.3.4], "an annoying" group : joe1@groupie, joe2@groupie, "Joey" joe3@groupy, "joe6"."joe8"@group.com;,  Lex''s email account <lex>'.

correctAnswer := #('joe@lama.com' 'joe2@lama.com' 'joe3@lama.com' 'joe4' 'joe5@address' 'joe.literal@[1.2.3.4]' 'joe1@groupie' 'joe2@groupie' '"Joey"' 'joe3@groupy' '"joe6"."joe8"@group.com' 'lex') asOrderedCollection.

	self assert: ((MailAddressParser addressesIn: testString) =  correctAnswer).! !
Object subclass: #MailAddressToken
	instanceVariableNames: 'type text'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RFC822'!
!MailAddressToken commentStamp: '<historical>' prior: 0!
a single token from an RFC822 mail address.  Used internally in MailAddressParser!


!MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'!
text
	^text! !

!MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'!
type
	^type! !


!MailAddressToken methodsFor: 'printing' stamp: 'ls 9/12/1998 20:40'!
printOn: aStream
	aStream nextPut: $[.
	aStream nextPutAll: self type asString.
	aStream nextPut: $|.
	aStream nextPutAll: self text.
	aStream nextPut: $].! !


!MailAddressToken methodsFor: 'private' stamp: 'ls 9/12/1998 20:24'!
type: type0  text: text0
	type _ type0.
	text _ text0.! !

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

MailAddressToken class
	instanceVariableNames: ''!

!MailAddressToken class methodsFor: 'instance creation' stamp: 'ls 9/12/1998 20:31'!
type: type  text: text
	^self new type: type text: text! !
Stream subclass: #MailAddressTokenizer
	instanceVariableNames: 'cachedToken text pos'
	classVariableNames: 'CSNonAtom CSNonSeparators CSParens CSSpecials'
	poolDictionaries: ''
	category: 'Network-RFC822'!
!MailAddressTokenizer commentStamp: '<historical>' prior: 0!
Divides an address into tokens, as specified in RFC 822.  Used by MailAddressParser.!


!MailAddressTokenizer methodsFor: 'initialization' stamp: 'ls 9/12/1998 20:13'!
initialize: aString
	text _ aString.
	pos _ 1.! !


!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:53'!
atEnd
	^self peek == nil! !

!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:51'!
next
	| ans |
	cachedToken ifNil: [ ^self nextToken ].
	ans _ cachedToken.
	cachedToken _ nil.
	^ans! !

!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:53'!
peek
	cachedToken ifNil: [ cachedToken _ self nextToken. ].
	
	^cachedToken	! !


!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:51'!
atEndOfChars
	^pos > text size! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:44'!
nextAtom
	| start end |
	start _ pos.
	pos _ text indexOfAnyOf: CSNonAtom startingAt: start ifAbsent: [ text size + 1].
	end _ pos - 1.
	^MailAddressToken
		type: #Atom
		text: (text copyFrom: start to: end)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:52'!
nextChar
	self atEndOfChars ifTrue: [ ^nil ].
	pos _ pos + 1.
	^text at: (pos-1)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'mas 2/8/2001 11:36'!
nextComment
	| start nestLevel paren |
	start _ pos.
	pos _ pos + 1.
	nestLevel _ 1.

	[ nestLevel > 0 ] whileTrue: [
		pos _ text indexOfAnyOf: CSParens startingAt: pos  ifAbsent: [ 0 ].
		pos = 0 ifTrue: [ 
			self error: 'unterminated comment.  ie, more (''s than )''s' ].

		paren _ self nextChar.
		paren = $( ifTrue: [ nestLevel _ nestLevel + 1 ] ifFalse: [ nestLevel _ nestLevel - 1 ]].
	^ MailAddressToken type: #Comment
		text: (text copyFrom: start to: pos - 1)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/13/1998 01:39'!
nextDomainLiteral
	| start end |
	start _ pos.
	end _ text indexOf: $] startingAt: start ifAbsent: [ 0 ].
	end = 0 ifTrue: [
		"not specified"
		self error: 'saw [ without a matching ]' ].

	pos _ end+1.

	^MailAddressToken
		type: #DomainLiteral
		text: (text copyFrom: start to: end)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:51'!
nextQuotedString
	| res c |
	res _ WriteStream on: String new.
	res nextPut: self nextChar.   "record the starting quote"
	[ self atEndOfChars ] whileFalse: [
		c _ self nextChar.
		c = $\ ifTrue: [
			res nextPut: c.
			res nextPut: self nextChar ]
		ifFalse: [
			c = $" ifTrue: [
				res nextPut: c.
				^MailAddressToken type: #QuotedString  text: res contents ]
			ifFalse: [
				res nextPut: c ] ] ].

	"hmm, never saw the final quote mark"
	^MailAddressToken type: #QuotedString  text: (res contents, '"')! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:44'!
nextSpecial
	| c |
	c _ self nextChar.
	^MailAddressToken type: c  text: c asString.! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'bf 3/12/2000 19:53'!
nextToken
	| c |
	self skipSeparators.
	c _ self peekChar.
	c ifNil: [ ^nil ].
	c = $( ifTrue: [ ^self nextComment ].
	c = $" ifTrue: [ ^self nextQuotedString ].
	c = $[ ifTrue: [ ^self nextDomainLiteral ].
	(CSSpecials includes: c) ifTrue: [ ^self nextSpecial ].
	^self nextAtom! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:15'!
peekChar
	^text at: pos ifAbsent: [ nil ]! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:14'!
skipSeparators
	pos _ text indexOfAnyOf: CSNonSeparators  startingAt: pos  ifAbsent: [ text size + 1 ].! !

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

MailAddressTokenizer class
	instanceVariableNames: ''!

!MailAddressTokenizer class methodsFor: 'class initialization' stamp: 'ls 12/2/2001 15:15'!
initialize
	"Initalize class variables using   MailAddressTokenizer initialize"

	| atomChars |

	CSParens _ CharacterSet empty.
	CSParens addAll: '()'.

	CSSpecials _ CharacterSet empty.
	CSSpecials addAll: '()<>@,;:\".[]'.

	CSNonSeparators _ CharacterSet separators complement.


	"(from RFC 2822)"
	atomChars := CharacterSet empty.
	atomChars addAll: ($A to: $Z).
	atomChars addAll: ($a to: $z).
	atomChars addAll: ($0 to: $9).
	atomChars addAll: '!!#$%^''*+-/=?^_`{|}~'.

	CSNonAtom :=  atomChars complement.! !


!MailAddressTokenizer class methodsFor: 'instance creation' stamp: 'ls 9/12/1998 20:54'!
forString: aString
	^super basicNew initialize: aString! !

!MailAddressTokenizer class methodsFor: 'instance creation' stamp: 'ls 9/13/1998 01:34'!
tokensIn: aString
	"return a collection of the tokens in aString"
	^(self forString: aString) upToEnd! !
Model subclass: #MailComposition
	instanceVariableNames: 'messageText textEditor morphicWindow mvcWindow'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-MailSending'!
!MailComposition commentStamp: '<historical>' prior: 0!
a message being composed.  When finished, it will be submitted via a Celeste.!


!MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:06'!
messageText
	"return the current text"
	^messageText.
! !

!MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:47'!
messageText: aText
	"change the current text"
	messageText _ aText.
	self changed: #messageText.
	^true! !

!MailComposition methodsFor: 'access' stamp: 'dvf 5/11/2002 00:24'!
smtpServer
	^MailSender smtpServer! !

!MailComposition methodsFor: 'access' stamp: 'mir 5/12/2003 16:04'!
submit
	| message |
	"submit the message"
	textEditor
		ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]].
	message := MailMessage from: messageText asString.
	self breakLinesInMessage: message.
	SMTPClient deliverMailFrom: message from to: (Array with: message to) text: message text usingServer: self smtpServer.

	morphicWindow ifNotNil: [morphicWindow delete].
	mvcWindow ifNotNil: [mvcWindow controller close]! !


!MailComposition methodsFor: 'interface' stamp: 'mdr 4/10/2001 14:27'!
addAttachment
	| file fileResult fileName |
	textEditor
		ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]].

	(fileResult _ StandardFileMenu oldFile)
		ifNotNil: 
			[fileName _ fileResult directory fullNameFor: fileResult name.
			file _ FileStream readOnlyFileNamed: fileName.
			file ifNotNil:
				[file binary.
				self messageText:
						((MailMessage from: self messageText asString)
							addAttachmentFrom: file withName: fileResult name; text).
				file close]] ! !

!MailComposition methodsFor: 'interface' stamp: 'fc 1/19/2005 18:56'!
menuGet: aMenu shifted: shifted
	
	aMenu addList: {
		{'find...(f)' translated.		#find}.
		{'find again (g)' translated.		#findAgain}.
		{'set search string (h)' translated.	#setSearchString}.
			#-.
		{'accept (s)' translated. #accept}.
		{'send message' translated.  #submit}}.

	^aMenu.! !

!MailComposition methodsFor: 'interface' stamp: 'ls 10/16/1998 09:11'!
open
	"open an interface"
	Smalltalk isMorphic
		ifTrue: [ self openInMorphic ]
		ifFalse: [ self openInMVC ]! !

!MailComposition methodsFor: 'interface' stamp: 'fc 1/19/2005 21:00'!
openInMorphic
	"open an interface for sending a mail message with the given initial 
	text "
	| textMorph buttonsList sendButton attachmentButton |
	morphicWindow _ SystemWindow labelled: 'Mister Postman'.
	morphicWindow model: self.
	textEditor _ textMorph _ PluggableTextMorph
						on: self
						text: #messageText
						accept: #messageText:
						readSelection: nil
						menu: #menuGet:shifted:.
	morphicWindow addMorph: textMorph frame: (0 @ 0.1 corner: 1 @ 1).
	buttonsList _ AlignmentMorph newRow.
	sendButton _ PluggableButtonMorph
				on: self
				getState: nil
				action: #submit.
	sendButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'send message';
		setBalloonText: 'Accept any unaccepted edits and add this to the queue of messages to be sent';
		onColor: Color white offColor: Color white.
	buttonsList addMorphBack: sendButton.
	
	attachmentButton _ PluggableButtonMorph
				on: self
				getState: nil
				action: #addAttachment.
	attachmentButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'add attachment';
		setBalloonText: 'Send a file with the message';
		onColor: Color white offColor: Color white.
	buttonsList addMorphBack: attachmentButton.
	
	morphicWindow addMorph: buttonsList frame: (0 @ 0 extent: 1 @ 0.1).
	morphicWindow openInMVC! !

!MailComposition methodsFor: 'interface' stamp: 'dvf 5/11/2002 01:23'!
sendMailMessage: aMailMessage
	self messageText: aMailMessage text! !


!MailComposition methodsFor: '*MorphicExtras-interface' stamp: 'ls 10/16/1998 09:17'!
openInMVC
	| textView sendButton  |

	mvcWindow _ StandardSystemView new
		label: 'Mister Postman';
		minimumSize: 400@250;
		model: self.

	textView _ PluggableTextView
		on: self
		text: #messageText
		accept: #messageText:.
	textEditor _ textView controller.

	sendButton _ PluggableButtonView 
		on: self
		getState: nil
		action: #submit.
	sendButton label: 'Send'.
	sendButton borderWidth: 1.

	sendButton window: (1@1 extent: 398@38).
	mvcWindow addSubView: sendButton.

	textView window: (0@40 corner: 400@250).
	mvcWindow addSubView: textView below: sendButton.

	mvcWindow controller open.

		
! !


!MailComposition methodsFor: 'private' stamp: 'ls 2/10/2001 13:57'!
breakLines: aString  atWidth: width
	"break lines in the given string into shorter lines"
	| result start end atAttachment |

	result _ WriteStream on: (String new: (aString size * 50 // 49)).

	atAttachment _ false.
	aString asString linesDo: [ :line | 
		(line beginsWith: '====') ifTrue: [ atAttachment _ true ].
		atAttachment ifTrue: [
			"at or after an attachment line; no more wrapping for the rest of the message"
			result nextPutAll: line.  result cr ]
		ifFalse: [
			(line beginsWith: '>') ifTrue: [
				"it's quoted text; don't wrap it"
				result nextPutAll: line. result cr. ]
			ifFalse: [
				"regular old line.  Wrap it to multiple lines"
				start _ 1.
					"output one shorter line each time through this loop"
				[ start + width <= line size ] whileTrue: [
	
					"find the end of the line"
					end _ start + width - 1.
					[end >= start and: [ (line at: (end+1)) isSeparator not ]] whileTrue: [
						end _ end - 1 ].
					end < start ifTrue: [
						"a word spans the entire width!!"
						end _ start + width - 1 ].

					"copy the line to the output"
					result nextPutAll: (line copyFrom: start to: end).
					result cr.

					"get ready for next iteration"
					start _ end+1.
					(line at: start) isSeparator ifTrue: [ start _ start + 1 ].
				].

				"write out the final part of the line"
				result nextPutAll: (line copyFrom: start to: line size).
				result cr.
			].
		].
	].

	^result contents! !

!MailComposition methodsFor: 'private' stamp: 'ls 2/10/2001 14:08'!
breakLinesInMessage: message
	"reformat long lines in the specified message into shorter ones"
	message body  mainType = 'text' ifTrue: [
		"it's a single-part text message.  reformat the text"
		| newBodyText |
		newBodyText := self breakLines: message bodyText  atWidth: 72.
		message body: (MIMEDocument contentType: message body contentType content: newBodyText).

		^self ].

	message body isMultipart ifTrue: [
		"multipart message; process the top-level parts.  HACK: the parts are modified in place"
		message parts do: [ :part |
			part body mainType = 'text' ifTrue: [
				| newBodyText |
				newBodyText := self breakLines: part bodyText atWidth: 72.
				part body: (MIMEDocument contentType: part body contentType content: newBodyText) ] ].
		message regenerateBodyFromParts. ].! !

!MailComposition methodsFor: 'private' stamp: 'fc 1/19/2005 20:53'!
perform: selector orSendTo: otherTarget

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

	! !

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

MailComposition class
	instanceVariableNames: ''!

!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'!
initialize
	super initialize.
	MailSender register: self.! !

!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 01:25'!
sendMailMessage: aMailMessage
	| newComposition |
	newComposition _ self new.
	newComposition messageText: aMailMessage text; open! !

!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'!
unload

	MailSender unregister: self ! !
Object subclass: #MailMessage
	instanceVariableNames: 'text body fields parts'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!MailMessage commentStamp: '<historical>' prior: 0!
I represent an Internet mail or news message.

	text - the raw text of my message
	body - the body of my message, as a MIMEDocument
	fields - a dictionary mapping lowercased field names into collections of MIMEHeaderValue's
	parts - if I am a multipart message, then this is a cache of my parts!


!MailMessage methodsFor: 'access' stamp: 'ls 1/3/1999 15:48'!
body
	"return just the body of the message"
	^body! !

!MailMessage methodsFor: 'access' stamp: 'ls 1/3/1999 15:52'!
bodyText
	"return the text of the body of the message"
	^body content! !

!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:34'!
cc

	^self fieldsNamed: 'cc' separatedBy: ', '! !

!MailMessage methodsFor: 'access' stamp: 'ls 2/10/2001 12:19'!
date
	"Answer a date string for this message."

	^(Date fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds) 
		printFormat: #(2 1 3 47 1 2)! !

!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:27'!
fields
	"return the internal fields structure.  This is private and subject to change!!"
	^ fields! !

!MailMessage methodsFor: 'access' stamp: 'mdr 3/21/2001 15:28'!
from

	^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! !

!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:26'!
name
	"return a default name for this part, if any was specified.  If not, return nil"
	| type nameField disposition |

	"try in the content-type: header"
	type _ self fieldNamed: 'content-type' ifAbsent: [nil].
	(type notNil and: [(nameField _ type parameters at: 'name' ifAbsent: [nil]) notNil])
		ifTrue: [^ nameField].

	"try in content-disposition:"
	disposition _ self fieldNamed: 'content-disposition' ifAbsent: [nil].
	(disposition notNil and: [(nameField _ disposition parameters at: 'filename' ifAbsent: [nil]) notNil])
		ifTrue: [^ nameField].

	"give up"
	^ nil! !

!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:24'!
subject

		^(self fieldNamed: 'subject' ifAbsent: [ ^'' ])  mainValue! !

!MailMessage methodsFor: 'access' stamp: 'ls 2/10/2001 12:49'!
text
	"the full, unprocessed text of the message"
	text ifNil: [ self regenerateText ].
	^text! !

!MailMessage methodsFor: 'access' stamp: 'mdr 4/7/2001 17:48'!
time
	| dateField |
	dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue.
	^ [self timeFrom: dateField] ifError: [:err :rcvr | Date today asSeconds].
! !

!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:35'!
to
	^self fieldsNamed: 'to' separatedBy: ', '! !


!MailMessage methodsFor: 'fields' stamp: 'bf 3/10/2000 15:22'!
canonicalFields
	"Break long header fields and escape those containing high-ascii characters according to RFC2047"

	self rewriteFields:
		[ :fName :fValue | 
			(fName size + fValue size < 72 and: [fValue allSatisfy: [:c | c asciiValue <= 128]])
				ifFalse: [RFC2047MimeConverter mimeEncode: fName, ': ', fValue]]
		append: [].

! !

!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:32'!
fieldNamed: aString ifAbsent: aBlock
	| matchingFields |
	"return the value of the field with the specified name.  If there is more than one field, then return the first one"
	matchingFields := fields at: aString asLowercase ifAbsent: [ ^aBlock value ].
	^matchingFields first! !

!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:21'!
fieldsNamed: aString ifAbsent: aBlock
	"return a list of all fields with the given name"
	^fields at: aString asLowercase ifAbsent: aBlock! !

!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:36'!
fieldsNamed: aString  separatedBy: separationString
	"return all fields with the specified name, concatenated together with separationString between each element.  Return an empty string if no fields with the specified name are present"
	| matchingFields |
	matchingFields := self fieldsNamed: aString ifAbsent: [ ^'' ].
	^String streamContents: [ :str |
		matchingFields
			do: [ :field | str nextPutAll: field mainValue ]
			separatedBy: [ str nextPutAll: separationString ]].
! !

!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:28'!
hasFieldNamed: aString
	^fields includesKey: aString asLowercase! !

!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:30'!
removeFieldNamed: name
	"remove all fields with the specified name"
	fields removeKey: name ifAbsent: []! !

!MailMessage methodsFor: 'fields' stamp: 'ls 2/10/2001 13:47'!
rewriteFields: aBlock append: appendBlock
	"Rewrite header fields. The body is not modified.
	Each field's key and value is reported to aBlock. The block's return value is the replacement for the entire header line. Nil means don't change the line, empty means delete it. After all fields are processed, evaluate appendBlock and append the result to the header."

	| old new result appendString |
	self halt: 'this method is out of date.  it needs to update body, at the very least.  do we really need this now that we have setField:to: and setField:toString: ?!!'.
	old _ ReadStream on: text.
	new _ WriteStream on: (String new: text size).
	self fieldsFrom: old do: [ :fName :fValue |
		result _ aBlock value: fName value: fValue.
		result ifNil: [new nextPutAll: fName, ': ', fValue; cr]
			ifNotNil: [result isEmpty
				ifFalse: [new nextPutAll: result.
					result last = Character cr ifFalse: [new cr]]]].
	appendString _ appendBlock value.
	appendString isEmptyOrNil ifFalse:
		[new nextPutAll: appendString.
		appendString last = Character cr ifFalse: [new cr]].
	new cr. "End of header"
	text _ new contents, old upToEnd.
! !


!MailMessage methodsFor: 'initialize-release' stamp: 'ls 2/10/2001 12:48'!
body: newBody
	"change the body"
	body := newBody.
	text := nil.! !

!MailMessage methodsFor: 'initialize-release' stamp: 'mdr 4/11/2001 11:58'!
from: aString 
	"Parse aString to initialize myself."

	| parseStream contentType bodyText contentTransferEncoding |

	text _ aString withoutTrailingBlanks, String cr.
	parseStream _ ReadStream on: text.
	contentType _ 'text/plain'.
	contentTransferEncoding _ nil.
	fields := Dictionary new.

	"Extract information out of the header fields"
	self fieldsFrom: parseStream do: 
		[:fName :fValue | 
		"NB: fName is all lowercase"

		fName = 'content-type' ifTrue: [contentType _ (fValue copyUpTo: $;) asLowercase].
		fName = 'content-transfer-encoding' ifTrue: [contentTransferEncoding _ fValue asLowercase].

		(fields at: fName ifAbsentPut: [OrderedCollection new: 1])
			add: (MIMEHeaderValue forField: fName fromString: fValue)].

	"Extract the body of the message"
	bodyText _ parseStream upToEnd.
	contentTransferEncoding = 'base64'
		ifTrue: 
			[bodyText _ Base64MimeConverter mimeDecodeToChars: (ReadStream on: bodyText).
			bodyText _ bodyText contents].
	contentTransferEncoding = 'quoted-printable' ifTrue: [bodyText _ bodyText decodeQuotedPrintable].
	body _ MIMEDocument contentType: contentType content: bodyText! !

!MailMessage methodsFor: 'initialize-release' stamp: 'ls 2/10/2001 12:15'!
initialize
	"initialize as an empty message"

	text _ String cr.
	fields := Dictionary new.
	body _ MIMEDocument contentType: 'text/plain' content: String cr! !

!MailMessage methodsFor: 'initialize-release' stamp: 'ls 3/18/2001 16:20'!
setField: fieldName to: aFieldValue
	"set a field.  If any field of the specified name exists, it will be overwritten"
	fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue).
	text := nil.! !

!MailMessage methodsFor: 'initialize-release' stamp: 'mdr 4/11/2001 11:59'!
setField: fieldName toString: fieldValue
	^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! !


!MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:04'!
addAttachmentFrom: aStream withName: aName
	"add an attachment, encoding with base64.  aName is the option filename to encode"
	| newPart |
	self makeMultipart.
	self parts.  "make sure parts have been parsed"

	"create the attachment as a MailMessage"
	newPart := MailMessage empty.
	newPart setField: 'content-type' toString: 'application/octet-stream'.
	newPart setField: 'content-transfer-encoding' toString: 'base64'.
	aName ifNotNil: [
		| dispositionField |
		dispositionField := MIMEHeaderValue fromMIMEHeader: 'attachment'.
		dispositionField parameterAt: 'filename' put: aName.
		newPart setField: 'content-disposition' to: dispositionField ].
	newPart body: (MIMEDocument contentType: 'application/octet-stream' content: aStream upToEnd).


	"regenerate our text"
	parts := parts copyWith: newPart.
	self regenerateBodyFromParts.
	text := nil.! !

!MailMessage methodsFor: 'multipart' stamp: 'mdr 5/7/2001 11:22'!
atomicParts
	"Answer all of the leaf parts of this message, including those of multipart included messages"

	self body isMultipart ifFalse: [^ OrderedCollection with: self].
	^ self parts inject: OrderedCollection new into: [:col :part | col , part atomicParts]! !

!MailMessage methodsFor: 'multipart' stamp: 'mdr 3/22/2001 09:06'!
attachmentSeparator
	^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters
		at: 'boundary' ifAbsent: [^nil]! !

!MailMessage methodsFor: 'multipart' stamp: 'ls 3/18/2001 16:26'!
decoderClass
	| encoding |
	encoding _ self fieldNamed: 'content-transfer-encoding' ifAbsent: [^ nil].
	encoding _ encoding mainValue.
	encoding asLowercase = 'base64' ifTrue: [^ Base64MimeConverter].
	encoding asLowercase = 'quoted-printable' ifTrue: [^ QuotedPrintableMimeConverter].
	^ nil! !

!MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:06'!
makeMultipart
	"if I am not multipart already, then become a multipart message with one part"

	| part multipartHeader |

	body isMultipart ifTrue: [ ^self ].

	"set up the new message part"
	part := MailMessage empty.
	part body: body.
	(self hasFieldNamed: 'content-type') ifTrue: [
		part setField: 'content-type' to: (self fieldNamed: 'content-type' ifAbsent: ['']) ].
	parts := Array with: part.

	"fix up our header"
	multipartHeader := MIMEHeaderValue fromMIMEHeader: 'multipart/mixed'.
	multipartHeader parameterAt: 'boundary' put: self class generateSeparator .
	self setField: 'content-type' to: multipartHeader.

	self setField: 'mime-version' to: (MIMEHeaderValue fromMIMEHeader: '1.0').
	self removeFieldNamed: 'content-transfer-encoding'.

	"regenerate everything"
	self regenerateBodyFromParts.
	text := nil.! !

!MailMessage methodsFor: 'multipart' stamp: 'mdr 3/23/2001 13:30'!
parseParts
	"private -- parse the parts of the message and store them into a collection"

	| parseStream msgStream messages separator |

	"If this is not multipart, store an empty collection"
	self body isMultipart ifFalse: [parts _ #().  ^self].

	"If we can't find a valid separator, handle it as if the message is not multipart"
	separator := self attachmentSeparator.
	separator ifNil: [Transcript show: 'Ignoring bad attachment separater'; cr. parts _ #(). ^self].

	separator := '--', separator withoutTrailingBlanks.
	parseStream _ ReadStream on: self bodyText.

	msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator.
	msgStream limitingBlock: [:aLine |
		aLine withoutTrailingBlanks = separator or:			"Match the separator"
		[aLine withoutTrailingBlanks = (separator, '--')]].	"or the final separator with --"

	"Throw away everything up to and including the first separator"
	msgStream upToEnd.
	msgStream skipThisLine.

	"Extract each of the multi-parts as strings"
	messages _ OrderedCollection new.
	[parseStream atEnd]
		whileFalse: 
			[messages add: msgStream upToEnd.
			msgStream skipThisLine].

	parts _ messages collect: [:e | MailMessage from: e]! !

!MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 18:22'!
parts
	parts ifNil: [self parseParts].
	^ parts! !

!MailMessage methodsFor: 'multipart' stamp: 'rbb 3/1/2005 10:59'!
save
	"save the part to a file"
	| fileName file |
	fileName := self name
				ifNil: ['attachment' , Utilities dateTimeSuffix].
	(fileName includes: $.) ifFalse: [
		#(isJpeg 'jpg' isGif 'gif' isPng 'png' isPnm 'pnm') pairsDo: [ :s :e |
			(self body perform: s) ifTrue: [fileName := fileName, '.', e]
		]
	].
	fileName := UIManager default request: 'File name for save?' initialAnswer: fileName.
	fileName isEmpty
		ifTrue: [^ nil].
	file := FileStream newFileNamed: fileName.
	file nextPutAll: self bodyText.
	file close! !


!MailMessage methodsFor: 'parsing' stamp: 'dvf 5/10/2002 21:43'!
fieldsFrom: aStream do: aBlock
	"Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body."

	| savedLine line s |
	savedLine _ self readStringLineFrom: aStream.
	[aStream atEnd] whileFalse: [
		line _ savedLine.
		(line isEmpty) ifTrue: [^self].  "quit when we hit a blank line"
		[savedLine _ self readStringLineFrom: aStream.
		 (savedLine size > 0) and: [savedLine first isSeparator]] whileTrue: [
			"lines starting with white space are continuation lines"
			s _ ReadStream on: savedLine.
			s skipSeparators.
			line _ line, ' ', s upToEnd].
		self reportField: line withBlanksTrimmed to: aBlock].

	"process final header line of a body-less message"
	(savedLine isEmpty) ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock].
! !

!MailMessage methodsFor: 'parsing' stamp: 'bf 3/10/2000 08:37'!
headerFieldsNamed: fieldName do: aBlock
	"Evalue aBlock once for each header field which matches fieldName.  The block is valued with one parameter, the value of the field"

	self fieldsFrom: (ReadStream on: text) do:
		[: fName : fValue |
			(fieldName sameAs: fName) ifTrue: [aBlock value: fValue]].
! !

!MailMessage methodsFor: 'parsing'!
readDateFrom: aStream
	"Parse a date from the given stream and answer nil if the date can't be parsed. The date may be in any of the following forms:
		<day> <monthName> <year>		(5 April 1982; 5-APR-82)
		<monthName> <day> <year>		(April 5, 1982)
		<monthNumber> <day> <year>		(4/5/82)
	In addition, the date may be preceded by the day of the week and an optional comma, such as:
		Tue, November 14, 1989"

	| day month year |
	self skipWeekdayName: aStream.
	aStream peek isDigit ifTrue: [day _ Integer readFrom: aStream].
	[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
	aStream peek isLetter
		ifTrue:		"month name or weekday name"
			[month _ WriteStream on: (String new: 10).
			 [aStream peek isLetter] whileTrue: [month nextPut: aStream next].
			 month _ month contents.
			 day isNil ifTrue:		"name/number..."
				[[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
				 (aStream peek isDigit) ifFalse: [^nil].
				 day _ Integer readFrom: aStream]]
		ifFalse:		"number/number..."
			[month _ Date nameOfMonth: day.
			 day _ Integer readFrom: aStream].
	[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
	(aStream peek isDigit) ifFalse: [^nil].
	year _ Integer readFrom: aStream.
	^Date newDay: day month: month year: year! !

!MailMessage methodsFor: 'parsing' stamp: 'dvf 5/10/2002 21:43'!
readStringLineFrom: aStream 
	"Read and answer the next line from the given stream. Consume the carriage return but do not append it to the string."

	| |

	^aStream upTo: Character cr! !

!MailMessage methodsFor: 'parsing' stamp: 'mdr 2/11/2001 17:58'!
reportField: aString to: aBlock
	"Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed."

	| s fieldName fieldValue |
	(aString includes: $:) ifFalse: [^self].
	s _ ReadStream on: aString.
	fieldName _ (s upTo: $:) asLowercase.	"fieldname must be lowercase"
	fieldValue _ s upToEnd withBlanksTrimmed.
	fieldValue isEmpty ifFalse: [aBlock value: fieldName value: fieldValue].
! !

!MailMessage methodsFor: 'parsing'!
skipWeekdayName: aStream
	"If the given stream starts with a weekday name or its abbreviation, advance the stream to the first alphaNumeric character following the weekday name."

	| position name abbrev |
	aStream skipSeparators.
	(aStream peek isDigit) ifTrue: [^self].
	(aStream peek isLetter) ifTrue:
		[position _ aStream position.
		 name _ WriteStream on: (String new: 10).
		 [aStream peek isLetter] whileTrue: [name nextPut: aStream next].
		 abbrev _ (name contents copyFrom: 1 to: (3 min: name position)).
		 abbrev _ abbrev asLowercase.
		 (#('sun' 'mon' 'tue' 'wed' 'thu' 'fri' 'sat') includes: abbrev asLowercase)
			ifTrue:
				["found a weekday; skip to the next alphanumeric character"
				 [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]]
			ifFalse:
				["didn't find a weekday so restore stream position"
				 aStream position: position]].! !

!MailMessage methodsFor: 'parsing' stamp: 'ajh 10/1/2001 17:10'!
timeFrom: aString 
	"Parse the date and time (rfc822) and answer the result as the number of seconds 
	since the start of 1980."

	| s t rawDelta delta plusOrMinus |
	s _ ReadStream on: aString.

	"date part"
	t _ ((self readDateFrom: s) ifNil: [Date today]) asSeconds.

	[s atEnd or: [s peek isAlphaNumeric]]
		whileFalse: [s next].

	"time part"
	s atEnd ifFalse: ["read time part (interpreted as local, regardless of sender's timezone)"
		(s peek isDigit) ifTrue: [t _ t + (Time readFrom: s) asSeconds].
		].
	s skipSeparators.

	"Check for a numeric time zone offset"
	('+-' includes: s peek) ifTrue: 
		[plusOrMinus _ s next.
		rawDelta _ (s peek isDigit) ifTrue: [Integer readFrom: s] ifFalse: [0].
		delta _ (rawDelta // 100 * 60 + (rawDelta \\ 100)) * 60.
		t _ plusOrMinus = $+ ifTrue: [t - delta] ifFalse: [t + delta]].

	"We ignore text time zone offsets like EST, GMT, etc..."

	^ t - (Date newDay: 1 year: 1980) asSeconds

"MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 -500'"
"MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 --500'"
"MailMessage new timeFrom: 'on, 04 apr 2001 14:57:32'"! !


!MailMessage methodsFor: 'printing/formatting' stamp: 'dvf 6/14/2000 00:29'!
asSendableText
	"break lines in the given string into shorter lines"
	| result start end pastHeader atAttachment width aString |
	width _ 72.
	aString _ self text.
	result _ WriteStream on: (String new: aString size * 50 // 49).
	pastHeader _ false.
	atAttachment _ false.
	aString asString
		linesDo: 
			[:line | 
			line isEmpty ifTrue: [pastHeader _ true].
			pastHeader
				ifTrue: 
					["(line beginsWith: '--==')
						ifTrue: [atAttachment _ true]."
					atAttachment
						ifTrue: 
							["at or after an attachment line; no more 
							wrapping for the rest of the message"
							result nextPutAll: line.
							result cr]
						ifFalse: [(line beginsWith: '>')
								ifTrue: 
									["it's quoted text; don't wrap it"
									result nextPutAll: line.
									result cr]
								ifFalse: 
									["regular old line.  Wrap it to multiple 
									lines "
									start _ 1.
									"output one shorter line each time 
									through this loop"
									[start + width <= line size]
										whileTrue: 
											["find the end of the line"
											end _ start + width - 1.
											[end >= start and: [(line at: end + 1) isSeparator not]]
												whileTrue: [end _ end - 1].
											end < start ifTrue: ["a word spans the entire 
												width!! "
												end _ start + width - 1].
											"copy the line to the output"
											result nextPutAll: (line copyFrom: start to: end).
											result cr.
											"get ready for next iteration"
											start _ end + 1.
											(line at: start) isSeparator ifTrue: [start _ start + 1]].
									"write out the final part of the line"
									result nextPutAll: (line copyFrom: start to: line size).
									result cr]]]
				ifFalse: 
					[result nextPutAll: line.
					result cr]].
	^ result contents! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'yo 7/26/2004 22:06'!
bodyTextFormatted
	"Answer a version of the text in my body suitable for display.  This will parse multipart forms, decode HTML, and other such things"

	"check for multipart"
	self body isMultipart ifTrue: [
		"check for alternative forms"
		self body isMultipartAlternative ifTrue: [
			"it's multipart/alternative.  search for a part that we can display, biasing towards nicer formats"
			#('text/html' 'text/plain') do: [ :format |
				self parts do: [ :part |
					part body contentType = format ifTrue: [ ^part bodyTextFormatted ] ] ].

			"couldn't find a desirable part to display; just display the first part"
			^self parts first bodyTextFormatted ].

		"not alternative parts.  put something for each part"
		^Text streamContents: [ :str |
			self parts do: [ :part |
				((#('text' 'multipart') includes: part body mainType) or: 
					[ part body contentType = 'message/rfc822'])
				ifTrue: [
					"try to inline the message part"
					str nextPutAll: part bodyTextFormatted. ]
				ifFalse: [ 
					|descript |
					str cr.
					descript := part name ifNil: [ 'attachment' ].
					str nextPutAll: (Text string: '[', descript, ']'  attribute: (TextMessageLink message: part)). ] ] ]. ].


	"check for HTML"
	(self body contentType = 'text/html') ifTrue: [
		Smalltalk at: #HtmlParser ifPresentAndInMemory: [ :htmlParser |
			^(htmlParser parse: (ReadStream on: body content)) formattedText
		]
	].

	"check for an embedded message"
	self body contentType = 'message/rfc822' ifTrue: [
		^(MailMessage from: self body content) formattedText ].

	"nothing special--just return the text"
	^body content.

! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'yo 7/26/2004 22:06'!
cleanedHeader
	"Reply with a cleaned up version email header.  First show fields people would normally want to see (in a regular order for easy browsing), and then any other fields not explictly excluded"

	| new priorityFields omittedFields |

	new _ WriteStream on: (String new: text size).

	priorityFields _ #('Date' 'From' 'Subject' 'To' 'Cc').
	omittedFields _ MailMessage omittedHeaderFields.

	"Show the priority fields first, in the order given in priorityFields"
	priorityFields do: [ :pField |
		"We don't check whether the priority field is in the omitted list!!"
		self headerFieldsNamed: pField do:
			[: fValue | new nextPutAll: pField, ': ', fValue decodeMimeHeader; cr]].

	"Show the rest of the fields, omitting the uninteresting ones and ones we have already shown"
	omittedFields _ omittedFields, priorityFields.
	self fieldsFrom: (ReadStream on: text) do:
		[: fName : fValue |
		((fName beginsWith: 'x-') or:
			[omittedFields anySatisfy: [: omitted | fName sameAs: omitted]])
				ifFalse: [new nextPutAll: fName, ': ', fValue; cr]].

	^new contents! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'mdr 5/7/2001 11:07'!
excerpt
	"Return a short excerpt of the text of the message"

	^ self bodyText withSeparatorsCompacted truncateWithElipsisTo: 60! !

!MailMessage methodsFor: 'printing/formatting'!
format
	"Replace the text of this message with a formatted version."
	"NOTE: This operation discards extra header fields."

	text _ self formattedText.! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'ls 4/30/2000 18:52'!
formattedText
	"Answer a version of my text suitable for display.  This cleans up the header, decodes HTML, and things like that"

	
	^ self cleanedHeader asText, String cr , self bodyTextFormatted! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'ls 11/11/2001 13:27'!
printOn: aStream 
	"For text parts with no filename show: 'text/plain: first line of text...'    
	for attachments/filenamed parts show: 'attachment: filename.ext'"

	| name |

	aStream nextPutAll: ((name _ self name) ifNil: ['Text: ' , self excerpt]
			ifNotNil: ['File: ' , name])! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'bkv 6/23/2003 14:17'!
regenerateBodyFromParts
	"regenerate the message body from the multiple parts"
	| bodyText |

	bodyText := String streamContents: [ :str |
		str cr.
		parts do: [ :part |
			str
				cr;
				nextPutAll: '--';
				nextPutAll: self attachmentSeparator;
				cr;
				nextPutAll: part text ].
	
		str
			cr;
			nextPutAll: '--';
			nextPutAll: self attachmentSeparator;
			nextPutAll: '--';
			cr ].

	body := MIMEDocument contentType: 'multipart/mixed' content: bodyText.
	text := nil.  "text needs to be reformatted"! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'ls 3/18/2001 16:27'!
regenerateText
	"regenerate the full text from the body and headers"
	| encodedBodyText |
	text := String streamContents: [ :str |
		"first put the header"
		fields keysAndValuesDo: [ :fieldName :fieldValues |
			fieldValues do: [ :fieldValue |
				str
					nextPutAll: fieldName capitalized ;
					nextPutAll: ': ';
					nextPutAll: fieldValue asHeaderValue;
					cr ]. ].
	
		"skip a line between header and body"
		str cr.

		"put the body, being sure to encode it according to the header"
		encodedBodyText := body content.
		self decoderClass ifNotNil: [
			encodedBodyText := (self decoderClass mimeEncode: (ReadStream on: encodedBodyText)) upToEnd ].
		str nextPutAll: encodedBodyText ].! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'sbw 1/21/2001 19:47'!
viewBody
	"open a viewer on the body of this message"
	self containsViewableImage
		ifTrue: [^ self viewImageInBody].
	(StringHolder new contents: self bodyTextFormatted;
		 yourself)
		openLabel: (self name
				ifNil: ['(a message part)'])! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'nk 6/12/2004 09:36'!
viewImageInBody
	| stream image |
	stream _ self body contentStream.
	image _ Form fromBinaryStream: stream.
	(World drawingClass withForm: image) openInWorld! !


!MailMessage methodsFor: 'testing' stamp: 'kfr 11/5/2004 17:32'!
containsViewableImage
	^self body isJpeg | self body isGif | self body isPng! !

!MailMessage methodsFor: 'testing' stamp: 'mdr 4/11/2001 19:44'!
selfTest
	"For testing only: Check that this instance is well formed and makes sense"

	self formattedText.

	[MailAddressParser addressesIn: self from] ifError:
		[ :err :rcvr | Transcript show: 'Error parsing From: (', self from, ') ', err].
	[MailAddressParser addressesIn: self to] ifError:
		[ :err :rcvr | Transcript show: 'Error parsing To: (', self to, ') ', err].
	[MailAddressParser addressesIn: self cc] ifError:
		[ :err :rcvr | Transcript show: 'Error parsing CC: (', self cc, ') ', err].
! !

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

MailMessage class
	instanceVariableNames: ''!

!MailMessage class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 18:08'!
empty
	"return a message with no text and no header"

	^self new! !

!MailMessage class methodsFor: 'instance creation'!
from: aString
	"Initialize a new instance from the given string."

	^(self new) from: aString! !


!MailMessage class methodsFor: 'preferences' stamp: 'mdr 7/9/2001 13:23'!
omittedHeaderFields
	"Reply a list of fields to omit when displaying a nice simple message"

	"Note that heads of the form
		X-something: value
	are filtered programatically.  This is done since we don't want any of them
	and it is impossible to predict them in advance."

	^ #(
			'comments'
			'priority'
			'disposition-notification-to'
			'content-id'
			'received'
			'return-path'
			'newsgroups'
			'message-id'
			'path'
			'in-reply-to'
			'sender'
			'fonts'
			'mime-version'
			'status'
			'content-type'
			'content-transfer-encoding'
			'errors-to'
			'keywords'
			'references'
			'nntp-posting-host'
			'lines'
			'return-receipt-to'
			'precedence'
			'originator'
			'distribution'
			'content-disposition'
			'importance'
			'resent-to'
			'resent-cc'
			'resent-message-id'
			'resent-date'
			'resent-sender'
			'resent-from'
			'delivered-to'
			'user-agent'
			'content-class'
			'thread-topic'
			'thread-index'
			'list-help',
			'list-post',
			'list-subscribe',
			'list-id',
			'list-unsubscribe',
			'list-archive'
		)
! !


!MailMessage class methodsFor: 'testing' stamp: 'mdr 3/21/2001 15:59'!
selfTest

	| msgText msg |

	msgText _ 
'Date: Tue, 20 Feb 2001 13:52:53 +0300
From: mdr@scn.rg (Me Ru)
Subject: RE: Windows 2000 on your laptop
To: "Greg Y" <to1@mail.com>
cc: cc1@scn.org, cc1also@test.org
To: to2@no.scn.org, to2also@op.org
cc: cc2@scn.org

Hmmm... Good.  I will try to swap my German copy for something in
English, and then do the deed.  Oh, and expand my RAM to 128 first.

Mike
'.

	msg _ self new from: msgText.

	[msg text = msgText] assert.
	[msg subject = 'RE: Windows 2000 on your laptop'] assert.
	[msg from = 'mdr@scn.rg (Me Ru)'] assert.
	[msg date = '2/20/01'] assert.
	[msg time = 667133573] assert.
	"[msg name] assert."
	[msg to = '"Greg Y" <to1@mail.com>, to2@no.scn.org, to2also@op.org'] assert.
	[msg cc = 'cc1@scn.org, cc1also@test.org, cc2@scn.org'] assert.

	"MailMessage selfTest"
! !


!MailMessage class methodsFor: 'utilities' stamp: 'mdr 2/18/1999 20:47'!
dateStampNow
	"Return the current date and time formatted as a email Date: line"
	"The result conforms to RFC822 with a long year, e.g.  'Thu, 18 Feb 1999 20:38:51'"

	^	(Date today weekday copyFrom: 1 to: 3), ', ',
		(Date today printFormat: #(1 2 3 $  2 1 1)), ' ',
		Time now print24! !

!MailMessage class methodsFor: 'utilities' stamp: 'ls 4/30/2000 22:58'!
generateSeparator
	"generate a separator usable for making MIME multipart documents.  A leading -- will *not* be included"
	^'==CelesteAttachment' , (10000 to: 99999) atRandom asString , '=='.! !
AppRegistry subclass: #MailSender
	instanceVariableNames: ''
	classVariableNames: 'SmtpServer UserName'
	poolDictionaries: ''
	category: 'System-Applications'!

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

MailSender class
	instanceVariableNames: ''!

!MailSender class methodsFor: 'accessing' stamp: 'dvf 5/11/2002 01:29'!
smtpServer
	"Answer the server for sending email"

	self isSmtpServerSet
		ifFalse: [self setSmtpServer].
	SmtpServer isEmpty ifTrue: [
		self error: 'no SMTP server specified' ].

	^SmtpServer! !

!MailSender class methodsFor: 'accessing' stamp: 'dvf 5/11/2002 00:49'!
userName
	"Answer the user name to be used in composing messages."

	(UserName isNil or: [UserName isEmpty])
		ifTrue: [self setUserName].

	UserName isEmpty ifTrue: [ self error: 'no user name specified' ].

	^UserName! !


!MailSender class methodsFor: 'communication' stamp: 'ads 5/11/2003 21:11'!
sendMessage: aMailMessage

	self default ifNotNil: [self default sendMailMessage: aMailMessage]! !


!MailSender class methodsFor: 'settings' stamp: 'rbb 3/1/2005 10:59'!
setSmtpServer
	"Set the SMTP server used to send outgoing messages via"
	SmtpServer ifNil: [SmtpServer := ''].
	SmtpServer := UIManager default
		request: 'What is your mail server for outgoing mail?'
		initialAnswer: SmtpServer.
! !

!MailSender class methodsFor: 'settings' stamp: 'rbb 3/1/2005 11:00'!
setUserName
	"Change the user's email name for use in composing messages."

	(UserName isNil) ifTrue: [UserName := ''].
	UserName := UIManager default
		request: 'What is your email address?\(This is the address other people will reply to you)' withCRs
		initialAnswer: UserName.
	UserName ifNotNil: [UserName := UserName]! !


!MailSender class methodsFor: 'testing' stamp: 'dvf 5/11/2002 01:31'!
isSmtpServerSet
	^ SmtpServer notNil and: [SmtpServer notEmpty]
! !
GenericUrl subclass: #MailtoUrl
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!MailtoUrl commentStamp: '<historical>' prior: 0!
a URL specifying a mailing address; activating it triggers a mail-sender to start up, if one is present.!


!MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 00:47'!
activate
	"Activate a Celeste window for the receiver"

	MailSender sendMessage: (MailMessage from: self composeText)! !

!MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 01:00'!
composeText
	"Answer the template for a new message."

	^ String streamContents: [:str |
		str nextPutAll: 'From: '.
		str nextPutAll: MailSender userName; cr.
		str nextPutAll: 'To: '.
		str nextPutAll: locator asString; cr.

		str nextPutAll: 'Subject: '; cr.

		str cr].! !
SequenceableCollection subclass: #MappedCollection
	instanceVariableNames: 'domain map'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!MappedCollection commentStamp: '<historical>' prior: 0!
I represent an access mechanism for a sequencable collection re-ordering or filtering its elements.!


!MappedCollection methodsFor: 'accessing'!
at: anIndex

	^domain at: (map at: anIndex)! !

!MappedCollection methodsFor: 'accessing'!
at: anIndex put: anObject

	^domain at: (map at: anIndex) put: anObject! !

!MappedCollection methodsFor: 'accessing'!
contents
	"Answer the receiver's domain for mapping, a Dictionary or 
	SequenceableCollection."

	^map collect: [:mappedIndex | domain at: mappedIndex]! !

!MappedCollection methodsFor: 'accessing'!
size

	^map size! !


!MappedCollection methodsFor: 'adding'!
add: newObject

	self shouldNotImplement! !


!MappedCollection methodsFor: 'copying' stamp: 'RvL 4/28/1999 10:31'!
copy
	"This returns another MappedCollection whereas copyFrom:to: will return
	an object like my domain."

	^self class collection: domain map: map! !


!MappedCollection methodsFor: 'enumerating'!
collect: aBlock 
	"Refer to the comment in Collection|collect:."

	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	self do:
		[:domainValue | 
		aStream nextPut: (aBlock value: domainValue)].
	^aStream contents! !

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

	map do:
		[:mapValue | aBlock value: (domain at: mapValue)]! !

!MappedCollection methodsFor: 'enumerating'!
select: aBlock 
	"Refer to the comment in Collection|select:."

	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	self do:
		[:domainValue | 
		(aBlock value: domainValue)
			ifTrue: [aStream nextPut: domainValue]].
	^aStream contents! !


!MappedCollection methodsFor: 'printing' stamp: 'sma 5/11/2000 19:53'!
storeOn: aStream
	aStream
		nextPut: $(;
		nextPutAll: self class name;
		nextPutAll: ' collection: ';
		store: domain;
		nextPutAll: ' map: ';
		store: map;
		nextPut: $)! !


!MappedCollection methodsFor: 'private'!
setCollection: aCollection map: aDictionary

	domain _ aCollection.
	map _ aDictionary! !

!MappedCollection methodsFor: 'private'!
species

	^domain species! !

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

MappedCollection class
	instanceVariableNames: ''!

!MappedCollection class methodsFor: 'instance creation'!
collection: aCollection map: aSequenceableCollection 
	"Answer an instance of me that maps aCollection by 
	aSequenceableCollection."

	^self basicNew setCollection: aCollection map: aSequenceableCollection! !

!MappedCollection class methodsFor: 'instance creation'!
new

	self error: 'MappedCollections must be created using the collection:map: message'! !

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

	^ self collection: aCollection map: (1 to: aCollection size)

"	MappedCollection newFrom: {1. 2. 3}
	{4. 3. 8} as: MappedCollection
"! !
BorderedMorph subclass: #MarqueeMorph
	instanceVariableNames: 'colors count'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWidgets'!
!MarqueeMorph commentStamp: '<historical>' prior: 0!
The MarqueeMorph is a subclass of the BorderedMorph which quickly cycles its border color.

The implementation could be simplified and generalized.  The color values and cycle speed are hard-coded for example.!


!MarqueeMorph methodsFor: 'initialization' stamp: 'RAA 9/25/1999 21:26'!
initialize

        super initialize.
        colors _ {Color red. Color white. Color blue}.
        count _ 0! !


!MarqueeMorph methodsFor: 'stepping and presenter' stamp: 'RAA 9/25/1999 21:27'!
step

        count _ count + 1.
        count > colors size ifTrue: [count _ 1].
        self borderColor: (colors at: count)! !


!MarqueeMorph methodsFor: 'testing' stamp: 'RAA 9/25/1999 21:30'!
stepTime
        "Answer the desired time between steps in milliseconds."

        ^ 200! !

!MarqueeMorph methodsFor: 'testing' stamp: 'RAA 9/25/1999 21:28'!
wantsSteps

        ^ true! !
Collection subclass: #Matrix
	instanceVariableNames: 'nrows ncols contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!Matrix commentStamp: '<historical>' prior: 0!
I represent a two-dimensional array, rather like Array2D.
There are three main differences between me and Array2D:
(1) Array2D inherits from ArrayedCollection, but isn't one.  A lot of things that should work
    do not work in consequence of this.
(2) Array2D uses "at: column at: row" index order, which means that nothing you write using
    it is likely to work either.  I use the almost universal "at: row at: column" order, so it is
    much easier to adapt code from other languages without going doolally.
(3) Array2D lets you specify the class of the underlying collection, I don't.

Structure:
  nrows : a non-negative integer saying how many rows there are.
  ncols : a non-negative integer saying how many columns there are.
  contents : an Array holding the elements in row-major order.  That is, for a 2x3 array
    the contents are (11 12 13 21 22 23).  Array2D uses column major order.

    You can specify the class of 'contents' when you create a new Array2D,
    but Matrix always gives you an Array.

    There is a reason for this.  In strongly typed languages like Haskell and Clean,
    'unboxed arrays' save you both space AND time.  But in Squeak, while
    WordArray and FloatArray and so on do save space, it costs time to use them.
    A LOT of time.  I've measured aFloatArray sum running nearly twice as slow as
    anArray sum.  The reason is that whenever you fetch an element from an Array,
    that's all that happens, but when you fetch an element from aFloatArray, a whole
    new Float gets allocated to hold the value.  This takes time and churns memory.
    So the paradox is that if you want fast numerical stuff, DON'T use unboxed arrays!!

    Another reason for always insisting on an Array is that letting it be something
    else would make things like #, and #,, rather more complicated.  Always using Array
    is the simplest thing that could possibly work, and it works rather well.

I was trying to patch Array2D to make more things work, but just couldn't get my head
around the subscript order.  That's why I made Matrix.

Element-wise matrix arithmetic works; you can freely mix matrices and numbers but
don't try to mix matrices and arrays (yet).
Matrix multiplication, using the symbol +* (derived from APL's +.x), works between
(Matrix or Array) +* (Matrix or Array).  Don't try to use a number as an argument of +*.
Matrix * Number and Number * Matrix work fine, so you don't need +* with numbers.

Still to come: oodles of stuff.  Gaussian elimination maybe, other stuff probably not.
!


!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'!
anyOne
	^contents anyOne! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'!
at: row at: column
	^contents at: (self indexForRow: row andColumn: column)! !

!Matrix methodsFor: 'accessing' stamp: 'raok 11/28/2002 14:14'!
at: r at: c ifInvalid: v
	"If r,c is a valid index for this matrix, answer the corresponding element.
	 Otherwise, answer v."

	(r between: 1 and: nrows) ifFalse: [^v].
	(c between: 1 and: ncols) ifFalse: [^v].
	^contents at: (r-1)*ncols + c
! !

!Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 12:37'!
at: row at: column incrementBy: value
	"Array2D>>at:at:add: was the origin of this method, but in Smalltalk add:
	 generally suggests adding an element to a collection, not doing a sum.
	 This method, and SequenceableCollection>>at:incrementBy: that supports
	 it, have been renamed to reveal their intention more clearly."

	^contents at: (self indexForRow: row andColumn: column) incrementBy: value! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:40'!
at: row at: column put: value
	^contents at: (self indexForRow: row andColumn: column) put: value! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:42'!
atAllPut: value
	contents atAllPut: value! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'!
atRandom
	^contents atRandom
! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'!
atRandom: aGenerator
	^contents atRandom: aGenerator! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'!
columnCount
	^ncols! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'!
identityIndexOf: anElement
	^self identityIndexOf: anElement ifAbsent: [0@0]
! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'!
identityIndexOf: anElement ifAbsent: anExceptionBlock
	^self rowAndColumnForIndex:
		 (contents identityIndexOf: anElement ifAbsent: [^anExceptionBlock value])
! !

!Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 13:13'!
indexOf: anElement
	"If there are integers r, c such that (self at: r at: c) = anElement,
	 answer some such r@c, otherwise answer 0@0.  This kind of perverse
	 result is provided by analogy with SequenceableCollection>>indexOf:.
	 The order in which the receiver are searched is UNSPECIFIED except
	 that it is the same as the order used by #indexOf:ifAbsent: and #readStream."

	^self indexOf: anElement ifAbsent: [0@0]
! !

!Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 13:10'!
indexOf: anElement ifAbsent: anExceptionBlock
	"If there are integers r, c such that (self at: r at: c) = anElement,
	 answer some such r@c, otherwise answer the result of anExceptionBlock."

	^self rowAndColumnForIndex:
		 (contents indexOf: anElement ifAbsent: [^anExceptionBlock value])
! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'!
replaceAll: oldObject with: newObject
	contents replaceAll: oldObject with: newObject! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'!
rowCount
	^nrows! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'!
size
	^contents size! !

!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:52'!
swap: r1 at: c1 with: r2 at: c2
	contents swap: (self indexForRow: r1 andColumn: c1)
			 with: (self indexForRow: r2 andColumn: c2)! !


!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/22/2002 12:41'!
atColumn: column
	|p|

	p _ (self indexForRow: 1 andColumn: column)-ncols.
	^(1 to: nrows) collect: [:row | contents at: (p _ p+ncols)]
! !

!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:21'!
atColumn: column put: aCollection
	|p|

	aCollection size = nrows ifFalse: [self error: 'wrong column size'].
	p _ (self indexForRow: 1 andColumn: column)-ncols.
	aCollection do: [:each | contents at: (p _ p+ncols) put: each].
	^aCollection
! !

!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/21/2002 23:32'!
atRow: row
	(row between: 1 and: nrows)
		ifFalse: [self error: '1st subscript out of range'].
	^contents copyFrom: (row-1)*ncols+1 to: row*ncols! !

!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/22/2002 12:42'!
atRow: row put: aCollection
	|p|

	aCollection size = ncols ifFalse: [self error: 'wrong row size'].
	p _ (self indexForRow: row andColumn: 1)-1.
	aCollection do: [:each | contents at: (p _ p+1) put: each].
	^aCollection! !

!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/23/2002 20:41'!
diagonal
	"Answer (1 to: (nrows min: ncols)) collect: [:i | self at: i at: i]"
	|i|

	i _ ncols negated.
	^(1 to: (nrows min: ncols)) collect: [:j | contents at: (i _ i + ncols + 1)]! !

!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:21'!
swapColumn: anIndex withColumn: anotherIndex
	|a b|

	a _ self indexForRow: 1 andColumn: anIndex.
	b _ self indexForRow: 1 andColumn: anotherIndex.
	nrows timesRepeat: [
		contents swap: a with: b.
		a _ a + ncols.
		b _ b + ncols].
! !

!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:22'!
swapRow: anIndex withRow: anotherIndex
	|a b|

	a _ self indexForRow: anIndex andColumn: 1.
	b _ self indexForRow: anotherIndex andColumn: 1.
	ncols timesRepeat: [
		contents swap: a with: b.
		a _ a + 1.
		b _ b + 1].
! !

!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/22/2002 00:13'!
transposed
	self assert: [nrows = ncols].
	^self indicesCollect: [:row :column | self at: column at: row]! !


!Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 13:09'!
atRows: rs columns: cs
	"Answer a Matrix obtained by slicing the receiver.
	 rs and cs should be sequenceable collections of positive integers."

	^self class rows: rs size columns: cs size tabulate: [:r :c |
		self at: (rs at: r) at: (cs at: c)]! !

!Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 12:30'!
atRows: r1 to: r2 columns: c1 to: c2
	"Answer a submatrix [r1..r2][c1..c2] of the receiver."
	|rd cd|

	rd _ r1 - 1.
	cd _ c1 - 1.
	^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd]
! !

!Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 13:05'!
atRows: r1 to: r2 columns: c1 to: c2 ifInvalid: element
	"Answer a submatrix [r1..r2][c1..c2] of the receiver.
	 Portions of the result outside the bounds of the original matrix
	 are filled in with element."
	|rd cd|

	rd _ r1 - 1.
	cd _ c1 - 1.
	^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd ifInvalid: element]
! !

!Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 12:32'!
atRows: r1 to: r2 columns: c1 to: c2 put: aMatrix
	"Set the [r1..r2][c1..c2] submatrix of the receiver
	 from the [1..r2-r1+1][1..c2-c1+1] submatrix of aMatrix.
	 As long as aMatrix responds to at:at: and accepts arguments in the range shown,
	 we don't care if it is bigger or even if it is a Matrix at all."
	|rd cd|

	rd _ r1 - 1.
	cd _ c1 - 1.
	r1 to: r2 do: [:r |
		c1 to: c2 do: [:c |
			self at: r at: c put: (aMatrix at: r-rd at: c-cd)]].
	^aMatrix
! !


!Matrix methodsFor: 'adding' stamp: 'raok 10/21/2002 22:53'!
add: newObject
	self shouldNotImplement! !


!Matrix methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:01'!
+* 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 preMultiplyByMatrix: self
! !

!Matrix methodsFor: 'arithmetic' stamp: 'raok 11/28/2002 14:22'!
preMultiplyByArray: a
	"Answer a +* self where a is an Array."

	nrows = 1 ifFalse: [self error: 'dimensions do not conform'].
	^Matrix rows: a size columns: ncols tabulate: [:row :col |
		(a at: row) * (contents at: col)]
! !

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

	nrows = m columnCount ifFalse: [self error: 'dimensions do not conform'].
	^Matrix rows: m rowCount columns: ncols tabulate: [:row :col |
		s _ 0.
		1 to: nrows do: [:k | s _ (m at: row at: k) * (self at: k at: col) + s].
		s]! !


!Matrix methodsFor: 'comparing' stamp: 'raok 11/22/2002 12:58'!
= aMatrix
	^aMatrix class == self class and: [
	 aMatrix rowCount = nrows and: [
	 aMatrix columnCount = ncols and: [
	 aMatrix privateContents = contents]]]! !

!Matrix methodsFor: 'comparing' stamp: 'raok 11/22/2002 13:14'!
hash
	"I'm really not sure what would be a good hash function here.
	 The essential thing is that it must be compatible with #=, and
	 this satisfies that requirement."

	^contents hash! !


!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'!
asArray
	^contents shallowCopy! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'!
asBag
	^contents asBag! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'!
asByteArray
	^contents asByteArray! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'!
asCharacterSet
	^contents asCharacterSet! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'!
asFloatArray
	^contents asFloatArray! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'!
asIdentitySet
	^contents asIdentitySet! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'!
asIntegerArray
	^contents asIntegerArray! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'!
asOrderedCollection
	^contents asOrderedCollection! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'!
asSet
	^contents asSet! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'!
asSortedArray
	^contents asSortedArray! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'!
asSortedCollection
	^contents asSortedCollection! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'!
asSortedCollection: aBlock
	^contents asSortedCollection: aBlock! !

!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'!
asWordArray
	^contents asWordArray! !

!Matrix methodsFor: 'converting' stamp: 'raok 11/22/2002 13:02'!
readStream
	"Answer a ReadStream that returns all the elements of the receiver
	 in some UNSPECIFIED order."

	^ReadStream on: contents! !


!Matrix methodsFor: 'copying' stamp: 'raok 11/22/2002 12:57'!
, aMatrix
	"Answer a new matrix having the same number of rows as the receiver and aMatrix,
	 its columns being the columns of the receiver followed by the columns of aMatrix."
	|newCont newCols anArray oldCols a b c|

	self assert: [nrows = aMatrix rowCount].
	newCont _ Array new: self size + aMatrix size.
	anArray _ aMatrix privateContents.
	oldCols _ aMatrix columnCount.
	newCols _ ncols + oldCols.
	a _ b _ c _ 1.
	1 to: nrows do: [:r |
		newCont replaceFrom: a to: a+ncols-1 with: contents startingAt: b.
		newCont replaceFrom: a+ncols to: a+newCols-1 with: anArray startingAt: c.
		a _ a + newCols.
		b _ b + ncols.
		c _ c + oldCols].
	^self class rows: nrows columns: newCols contents: newCont
		
! !

!Matrix methodsFor: 'copying' stamp: 'raok 11/22/2002 12:58'!
,, aMatrix
	"Answer a new matrix having the same number of columns as the receiver and aMatrix,
	 its rows being the rows of the receiver followed by the rows of aMatrix."

	self assert: [ncols = aMatrix columnCount].
	^self class rows: nrows + aMatrix rowCount columns: ncols
		contents: contents , aMatrix privateContents
! !

!Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:07'!
copy
	^self class rows: nrows columns: ncols contents: contents copy! !

!Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:07'!
shallowCopy
	^self class rows: nrows columns: ncols contents: contents shallowCopy! !

!Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'!
shuffled
	^self class rows: nrows columns: ncols contents: (contents shuffled)! !

!Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'!
shuffledBy: aRandom
	^self class rows: nrows columns: ncols contents: (contents shuffledBy: aRandom)! !


!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:41'!
collect: aBlock
	"Answer a new matrix with transformed elements; transformations should be independent."

	^self class rows: nrows columns: ncols contents: (contents collect: aBlock)! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'!
difference: aCollection
	"Union is in because the result is always a Set.
	 Difference and intersection are out because the result is like the receiver,
	 and with irregular seleection that cannot be."
	self shouldNotImplement! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:40'!
do: aBlock
	"Pass elements to aBlock one at a time in row-major order."
	contents do: aBlock! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/23/2002 20:57'!
indicesCollect: aBlock
	|r i|

	r _ Array new: nrows * ncols.
	i _ 0.
	1 to: nrows do: [:row |
		1 to: ncols do: [:column |
			r at: (i _ i+1) put: (aBlock value: row value: column)]].
	^self class rows: nrows columns: ncols contents: r! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:49'!
indicesDo: aBlock
	1 to: nrows do: [:row |
		1 to: ncols do: [:column |
			aBlock value: row value: column]].! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:51'!
indicesInject: start into: aBlock
	|current|

	current _ start.
	1 to: nrows do: [:row |
		1 to: ncols do: [:column |
			current _ aBlock value: current value: row value: column]].
	^current! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'!
intersection: aCollection
	"Union is in because the result is always a Set.
	 Difference and intersection are out because the result is like the receiver,
	 and with irregular seleection that cannot be."
	self shouldNotImplement! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'!
reject: aBlock
	self shouldNotImplement! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'!
select: aBlock
	self shouldNotImplement! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/22/2002 00:15'!
with: aCollection collect: aBlock
	"aCollection must support #at:at: and be at least as large as the receiver."

	^self withIndicesCollect: [:each :row :column |
		aBlock value: each value: (aCollection at: row at: column)]
! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:53'!
with: aCollection do: aBlock
	"aCollection must support #at:at: and be at least as large as the receiver."

	self withIndicesDo: [:each :row :column |
		aBlock value: each value: (aCollection at: row at: column)].
! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:55'!
with: aCollection inject: startingValue into: aBlock
	"aCollection must support #at:at: and be at least as large as the receiver."

	^self withIndicesInject: startingValue into: [:value :each :row :column |
		aBlock value: value value: each value: (aCollection at: row at: column)]! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'!
withIndicesCollect: aBlock
	|i r|

	i _ 0.
	r _ contents shallowCopy.
	1 to: nrows do: [:row |
		1 to: ncols do: [:column |
			i _ i+1.
			r at: i put: (aBlock value: (r at: i) value: row value: column)]].
	^self class rows: nrows columns: ncols contents: r
! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'!
withIndicesDo: aBlock
	|i|

	i _ 0.
	1 to: nrows do: [:row |
		1 to: ncols do: [:column |
			aBlock value: (contents at: (i _ i+1)) value: row value: column]].
! !

!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'!
withIndicesInject: start into: aBlock
	|i current|

	i _ 0.
	current _ start.
	1 to: nrows do: [:row |
		1 to: ncols do: [:column |
			current _ aBlock value: current value: (contents at: (i _ i+1)) 
							  value: row value: column]].
	^current! !


!Matrix methodsFor: 'printing' stamp: 'raok 10/21/2002 23:22'!
storeOn: aStream
	aStream nextPut: $(; nextPutAll: self class name;
		nextPutAll: ' rows: '; store: nrows;
		nextPutAll: ' columns: '; store: ncols;
		nextPutAll: ' contents: '; store: contents;
		nextPut: $)! !


!Matrix methodsFor: 'removing' stamp: 'raok 10/21/2002 22:54'!
remove: anObject ifAbsent: anExceptionBlock
	self shouldNotImplement! !


!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'!
identityIncludes: anObject
	^contents identityIncludes: anObject! !

!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:23'!
includes: anObject
	^contents includes: anObject! !

!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'!
includesAllOf: aCollection
	^contents includesAllOf: aCollection! !

!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'!
includesAnyOf: aCollection
	^contents includesAnyOf: aCollection! !

!Matrix methodsFor: 'testing' stamp: 'raok 11/22/2002 13:03'!
isSequenceable
	"LIE so that arithmetic on matrices will work.
	 What matters for arithmetic is not that there should be random indexing
	 but that the structure should be stable and independent of the values of
	 the elements.  #isSequenceable is simply the wrong question to ask."
	^true! !

!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:25'!
occurrencesOf: anObject
	^contents occurrencesOf: anObject! !


!Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 22:40'!
indexForRow: row andColumn: column
	(row between: 1 and: nrows)
		ifFalse: [self error: '1st subscript out of range'].
	(column between: 1 and: ncols)
		ifFalse: [self error: '2nd subscript out of range'].
	^(row-1) * ncols + column! !

!Matrix methodsFor: 'private' stamp: 'raok 11/22/2002 12:56'!
privateContents
	"Only used in #, #,, and #= so far.
	 It used to be called #contents, but that clashes with Collection>>contents."

	^contents! !

!Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 22:47'!
rowAndColumnForIndex: index
	|t|

	t _ index - 1.
	^(t // ncols + 1)@(t \\ ncols + 1)! !

!Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 23:05'!
rows: rows columns: columns contents: anArray
	self assert: [rows isInteger and: [rows >= 0]].
	self assert: [columns isInteger and: [columns >= 0]].
	self assert: [rows * columns = anArray size].
	nrows _ rows.
	ncols _ columns.
	contents _ anArray.
	^self! !

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

Matrix class
	instanceVariableNames: ''!

!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:58'!
column: aCollection
	"Should this be called #fromColumn:?"

	^self rows: aCollection size columns: 1 contents: aCollection asArray shallowCopy! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:09'!
diagonal: aCollection
	|r i|
	r _ self zeros: aCollection size.
	i _ 0.
	aCollection do: [:each | i _ i+1. r at: i at: i put: each].
	^r! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:59'!
identity: n
	|r|

	r _ self zeros: n.
	1 to: n do: [:i | r at: i at: i put: 1].
	^r! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:06'!
new: dim
	"Answer a dim*dim matrix.  Is this an abuse of #new:?  The argument is NOT a size."
	^self rows: dim columns: dim! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 11/25/2002 12:51'!
new: dim element: element
	"Answer a dim*dim matrix with all elements set to element.
	 Is this an abuse of #new:?  The argument is NOT a size."

	^self rows: dim columns: dim element: element! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 19:54'!
new: dim tabulate: aBlock
	"Answer a dim*dim matrix where it at: i at: j is aBlock value: i value: j."
	^self rows: dim columns: dim tabulate: aBlock! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:08'!
ones: n
	^self new: n element: 1
! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:59'!
row: aCollection
	"Should this be called #fromRow:?"

	^self rows: 1 columns: aCollection size contents: aCollection asArray shallowCopy! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:04'!
rows: rows columns: columns
	^self rows: rows columns: columns contents: (Array new: rows*columns)! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:10'!
rows: rows columns: columns element: element
	^self rows: rows columns: columns
		contents: ((Array new: rows*columns) atAllPut: element; yourself)! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 19:51'!
rows: rows columns: columns tabulate: aBlock
	"Answer a new Matrix of the given dimensions where
	 result at: i at: j     is   aBlock value: i value: j"
	|a i|

	a _ Array new: rows*columns.
	i _ 0.
	1 to: rows do: [:row |
		1 to: columns do: [:column |
			a at: (i _ i+1) put: (aBlock value: row value: column)]].
	^self rows: rows columns: columns contents: a
! !

!Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:09'!
zeros: n
	^self new: n element: 0! !


!Matrix class methodsFor: 'private' stamp: 'raok 10/21/2002 23:06'!
rows: rows columns: columns contents: contents
	^self new rows: rows columns: columns contents: contents! !
DisplayTransform variableWordSubclass: #MatrixTransform2x3
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Transformations'!
!MatrixTransform2x3 commentStamp: '<historical>' prior: 0!
This class represents a transformation for points, that is a combination of scale, offset, and rotation. It is implemented as a 2x3 matrix containing the transformation from the local coordinate system in the global coordinate system. Thus, transforming points from local to global coordinates is fast and cheap whereas transformations from global to local coordinate systems are relatively expensive.

Implementation Note: It is assumed that the transformation deals with Integer points. All transformations will return Integer coordinates (even though float points may be passed in here).!


!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
at: index
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
at: index put: value
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/18/1998 14:03'!
inverseTransformation
	"Return the inverse transformation of the receiver.
	The inverse transformation is computed by first calculating
	the inverse offset and then computing transformations
	for the two identity vectors (1@0) and (0@1)"
	| r1 r2 r3 m |
	r3 _ self invertPoint: 0@0.
	r1 _ (self invertPoint: 1@0) - r3.
	r2 _ (self invertPoint: 0@1) - r3.
	m _ self species new.
	m
		a11: r1 x; a12: r2 x; a13: r3 x;
		a21: r1 y; a22: r2 y; a23: r3 y.
	^m! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:19'!
offset
	^self a13 @ self a23! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:05'!
offset: aPoint
	self a13: aPoint x asFloat.
	self a23: aPoint y asFloat.! !


!MatrixTransform2x3 methodsFor: 'comparing' stamp: 'ar 5/3/2001 13:02'!
hash
	| result |
	<primitive: 'primitiveHashArray' module: 'FloatArrayPlugin'>
	result _ 0.
	1 to: self size do:[:i| result _ result + (self basicAt: i) ].
	^result bitAnd: 16r1FFFFFFF! !

!MatrixTransform2x3 methodsFor: 'comparing' stamp: 'ar 2/2/2001 15:47'!
= aMatrixTransform2x3 
	| length |
	<primitive: 'primitiveEqual' module: 'FloatArrayPlugin'>
	self class = aMatrixTransform2x3 class ifFalse: [^ false].
	length _ self size.
	length = aMatrixTransform2x3 size ifFalse: [^ false].
	1 to: self size do: [:i | (self at: i)
			= (aMatrixTransform2x3 at: i) ifFalse: [^ false]].
	^ true! !


!MatrixTransform2x3 methodsFor: 'composing' stamp: 'RAA 9/20/2000 13:10'!
composedWithLocal: aTransformation
	"Return the composition of the receiver and the local transformation passed in"
	aTransformation isMatrixTransform2x3 ifFalse:[^super composedWithLocal: aTransformation].
	^self composedWithLocal: aTransformation asMatrixTransform2x3 into: self class new! !

!MatrixTransform2x3 methodsFor: 'composing' stamp: 'ar 2/2/2001 15:47'!
composedWithLocal: aTransformation into: result
	"Return the composition of the receiver and the local transformation passed in.
	Store the composed matrix into result."
	| a11 a12 a13 a21 a22 a23 b11 b12 b13 b21 b22 b23 matrix |
	<primitive: 'primitiveComposeMatrix' module: 'Matrix2x3Plugin'>
	matrix _ aTransformation asMatrixTransform2x3.
	a11 _ self a11.		b11 _ matrix a11.
	a12 _ self a12.		b12 _ matrix a12.
	a13 _ self a13.		b13 _ matrix a13.
	a21 _ self a21.		b21 _ matrix a21.
	a22 _ self a22.		b22 _ matrix a22.
	a23 _ self a23.		b23 _ matrix a23.
	result a11: (a11 * b11) + (a12 * b21).
	result a12: (a11 * b12) + (a12 * b22).
	result a13: a13 + (a11 * b13) + (a12 * b23).
	result a21: (a21 * b11) + (a22 * b21).
	result a22: (a21 * b12) + (a22 * b22).
	result a23: a23 + (a21 * b13) + (a22 * b23).
	^result! !


!MatrixTransform2x3 methodsFor: 'converting' stamp: 'ar 11/2/1998 15:34'!
asMatrixTransform2x3
	^self! !


!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a11
	^self at: 1! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a11: value
	 self at: 1 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a12
	^self at: 2! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a12: value
	 self at: 2 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a13
	^self at: 3! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a13: value
	 self at: 3 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a21
	 ^self at: 4! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a21: value
	 self at: 4 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a22
	 ^self at: 5! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a22: value
	 self at: 5 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a23
	 ^self at: 6! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a23: value
	 self at: 6 put: value! !


!MatrixTransform2x3 methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:17'!
setIdentiy
	"Initialize the receiver to the identity transformation (e.g., not affecting points)"
	self
		a11: 1.0; a12: 0.0; a13: 0.0;
		a21: 0.0; a22: 1.0; a23: 0.0.! !


!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:06'!
byteSize
	^self basicSize * self bytesPerBasicElement! !

!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:04'!
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."
	^4! !

!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'yo 3/6/2004 12:57'!
bytesPerElement

	^ 4.
! !

!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'yo 3/6/2004 15:33'!
restoreEndianness
	"This word object was just read in from a stream.  It was stored in Big Endian (Mac) format.  Swap each pair of bytes (16-bit word), if the current machine is Little Endian.
	Why is this the right thing to do?  We are using memory as a byteStream.  High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory.  Different from a Bitmap."

	| w b1 b2 b3 b4 |
	SmalltalkImage current  isLittleEndian ifTrue: [
		1 to: self basicSize do: [:i |
			w _ self basicAt: i.
			b1 _ w digitAt: 1.
			b2 _ w digitAt: 2.
			b3 _ w digitAt: 3.
			b4 _ w digitAt: 4.
			w _ (b1 << 24) + (b2 << 16) + (b3 << 8) + b4.
			self basicAt: i put: w.
		]
	].

! !

!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'ar 8/6/2001 17:52'!
writeOn: aStream
	aStream nextWordsPutAll: self.! !


!MatrixTransform2x3 methodsFor: 'printing' stamp: 'ar 11/2/1998 23:11'!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPut: $(;
		cr; print: self a11; tab; print: self a12; tab; print: self a13;
		cr; print: self a21; tab; print: self a22; tab; print: self a23;
		cr; nextPut:$).! !


!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 2/2/2001 15:47'!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."
	<primitive: 'primitiveIsIdentity' module: 'Matrix2x3Plugin'>
	^self isPureTranslation and:[self a13 = 0.0 and:[self a23 = 0.0]]! !

!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 11/2/1998 23:15'!
isMatrixTransform2x3
	"Return true if the receiver is 2x3 matrix transformation"
	^true! !

!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 2/2/2001 15:47'!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	<primitive: 'primitiveIsPureTranslation' module: 'Matrix2x3Plugin'>
	^self a11 = 1.0 and:[self a12 = 0.0 and:[self a22 = 0.0 and:[self a21 = 1.0]]]! !


!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 2/2/2001 15:47'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	<primitive: 'primitiveInvertPoint' module: 'Matrix2x3Plugin'>
	^(self invertPoint: aPoint) rounded! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 11/16/1998 23:46'!
invertPoint: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	| x y det a11 a12 a21 a22 detX detY |
	x _ aPoint x asFloat - (self a13).
	y _ aPoint y asFloat - (self a23).
	a11 _ self a11.	a12 _ self a12.
	a21 _ self a21.	a22 _ self a22.
	det _ (a11 * a22) - (a12 * a21).
	det = 0.0 ifTrue:[^0@0]. "So we have at least a valid result"
	det _ 1.0 / det.
	detX _ (x * a22) - (a12 * y).
	detY _ (a11 * y) - (x * a21).
	^(detX * det) @ (detY * det)! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 2/2/2001 15:47'!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	<primitive: 'primitiveTransformPoint' module: 'Matrix2x3Plugin'>
	^(self transformPoint: aPoint) rounded! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 8/26/2001 20:54'!
transformDirection: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	| x y |
	x _ (aPoint x * self a11) + (aPoint y * self a12).
	y _ (aPoint x * self a21) + (aPoint y * self a22).
	^x @ y! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 11/2/1998 23:09'!
transformPoint: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	| x y |
	x _ (aPoint x * self a11) + (aPoint y * self a12) + self a13.
	y _ (aPoint x * self a21) + (aPoint y * self a22) + self a23.
	^x @ y! !


!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^self globalBounds: aRectangle toLocal: Rectangle new! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 2/2/2001 15:47'!
globalBounds: srcRect toLocal: dstRect
	"Transform aRectangle from global coordinates into local coordinates"
	<primitive: 'primitiveInvertRectInto' module: 'Matrix2x3Plugin'>
	^super globalBoundsToLocal: srcRect! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^self localBounds: aRectangle toGlobal: Rectangle new! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 2/2/2001 15:47'!
localBounds: srcRect toGlobal: dstRect
	"Transform aRectangle from local coordinates into global coordinates"
	<primitive: 'primitiveTransformRectInto' module: 'Matrix2x3Plugin'>
	^super localBoundsToGlobal: srcRect! !


!MatrixTransform2x3 methodsFor: '*MorphicExtras-*morphic-Postscript Canvases'!
encodePostscriptOn: aStream
	aStream writeMatrix:self.
! !


!MatrixTransform2x3 methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ls 10/9/1999 19:03'!
encodeForRemoteCanvas
	"encode this transform into a string for use by a RemoteCanvas"
	^String streamContents: [ :str |
		str nextPutAll: 'Matrix,'.
		1 to: 6 do: [ :i |
			str print: (self basicAt: i).
			str nextPut: $, ].
	]! !


!MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:17'!
setAngle: angle
	"Set the raw rotation angle in the receiver"
	| rad s c |
	rad := angle degreesToRadians.
	s := rad sin.
	c := rad cos.
	self a11: c.
	self a12: s negated.
	self a21: s.
	self a22: c.! !

!MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:17'!
setOffset: aPoint
	"Set the raw offset in the receiver"
	| pt |
	pt _ aPoint asPoint.
	self a13: pt x asFloat.
	self a23: pt y asFloat.! !

!MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:16'!
setScale: aPoint
	"Set the raw scale in the receiver"
	| pt |
	pt _ aPoint asPoint.
	self a11: pt x asFloat.
	self a22: pt y asFloat.! !

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

MatrixTransform2x3 class
	instanceVariableNames: ''!

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 22:50'!
identity
	^self new setScale: 1.0! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 7/9/1998 20:09'!
new
	^self new: 6! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'mir 6/12/2001 15:34'!
newFromStream: s
	"Only meant for my subclasses that are raw bits and word-like.  For quick unpack form the disk."
	self isPointers | self isWords not ifTrue: [^ super newFromStream: s].
		"super may cause an error, but will not be called."
	^ s nextWordsInto: (self new: 6)! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 01:25'!
transformFromLocal: localBounds toGlobal: globalBounds
	^((self withOffset: (globalBounds center)) composedWithLocal:
		(self withScale: (globalBounds extent / localBounds extent) asFloatPoint))
			composedWithLocal: (self withOffset: localBounds center negated)
"
	^(self identity)
		setScale: (globalBounds extent / localBounds extent) asFloatPoint;
		setOffset: localBounds center negated asFloatPoint;
		composedWithGlobal:(self withOffset: globalBounds center asFloatPoint)
"! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'!
withAngle: angle
	^self new setAngle: angle! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 02:52'!
withOffset: aPoint
	^self identity setOffset: aPoint! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 23:17'!
withRotation: angle
	^self new setAngle: angle! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'!
withScale: aPoint
	^self new setScale: aPoint! !


!MatrixTransform2x3 class methodsFor: '*nebraska-instance creation' stamp: 'sd 11/20/2005 21:25'!
fromRemoteCanvasEncoding: encoded
	"DisplayTransform fromRemoteCanvasEncoding:  'Matrix,1065353216,0,1137541120,0,1065353216,1131610112,'"
	| nums transform encodedNums |
	"split the numbers up"
	encodedNums := encoded findTokens: ','.

	"remove the initial 'Matrix' specification"
	encodedNums := encodedNums asOrderedCollection.
	encodedNums removeFirst.

	"parse the numbers"
	nums := encodedNums collect: [ :enum |
		Integer readFromString: enum ].

	"create an instance"
	transform := self new.

	"plug in the numbers"
	nums doWithIndex: [ :num :i |
		transform basicAt: i put: num ].

	^transform! !
Morph subclass: #MatrixTransformMorph
	instanceVariableNames: 'transform'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Balloon'!
!MatrixTransformMorph commentStamp: '<historical>' prior: 0!
MatrixTransformMorph is similar to TransformMorph but uses a MatrixTransform2x3 instead of a MorphicTransform. It is used by clients who want use the BalloonEngine for vector-based scaling instead of the standard WarpBlt pixel-based mechanism.!


!MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 21:51'!
transform: aMatrixTransform
	transform _ aMatrixTransform.
	self computeBounds.! !


!MatrixTransformMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:44'!
invalidRect: rect from: aMorph
	aMorph == self
		ifTrue:[super invalidRect: rect from: self]
		ifFalse:[super invalidRect: (self transform localBoundsToGlobal: rect) from: aMorph].! !


!MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 22:20'!
drawOn: aCanvas! !

!MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:01'!
drawSubmorphsOn: aCanvas
	aCanvas asBalloonCanvas transformBy: self transform
		during:[:myCanvas| super drawSubmorphsOn: myCanvas].! !

!MatrixTransformMorph methodsFor: 'drawing' stamp: 'md 2/27/2006 09:51'!
visible: aBoolean 
	"set the 'visible' attribute of the receiver to aBoolean"
	extension ifNil: [aBoolean ifTrue: [^ self]].
	self assureExtension visible: aBoolean! !


!MatrixTransformMorph methodsFor: 'event handling' stamp: 'ar 9/12/2000 01:22'!
transformFrom: uberMorph
	(owner isNil or:[self == uberMorph]) ifTrue:[^self transform].
	^(owner transformFrom: uberMorph) asMatrixTransform2x3 composedWithLocal: self transform! !


!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/16/1998 01:19'!
changeRotationCenter: evt with: rotHandle
	| pos |
	pos _ evt cursorPoint.
	rotHandle referencePosition: pos.
	self referencePosition: pos.! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:55'!
hasNoScaleOrRotation
	^true! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'fbs 11/26/2004 10:59'!
innerAngle
	^ (self transform a11 @ self transform a21) degrees! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
lastRotationDegrees
	^(self valueOfProperty: #lastRotationDegrees) ifNil:[0.0].! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
lastRotationDegrees: deg
	deg = 0.0 
		ifTrue:[self removeProperty: #lastRotationDegrees]
		ifFalse:[self setProperty: #lastRotationDegrees toValue: deg]! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
removeFlexShell
	"Do nothing"! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'mdr 12/19/2001 10:49'!
rotateBy: delta
	| pt m |
	delta = 0.0 ifTrue:[^self].
	self changed.
	pt _ self transformFromWorld globalPointToLocal: self referencePosition.
	m _ MatrixTransform2x3 withOffset: pt.
	m _ m composedWithLocal: (MatrixTransform2x3 withAngle: delta).
	m _ m composedWithLocal: (MatrixTransform2x3 withOffset: pt negated).
	self transform: (transform composedWithLocal: m).
	self changed.! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
rotationDegrees: degrees
	| last delta |
	last _ self lastRotationDegrees.
	delta _ degrees - last.
	self rotateBy: delta.
	self lastRotationDegrees: degrees.! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 9/11/2000 21:16'!
transform
	^ transform ifNil: [MatrixTransform2x3 identity]! !


!MatrixTransformMorph methodsFor: 'geometry' stamp: 'mdr 12/19/2001 10:48'!
boundsChangedFrom: oldBounds to: newBounds
	oldBounds extent = newBounds extent ifFalse:[
		transform _ transform composedWithGlobal:
			(MatrixTransform2x3 withOffset: oldBounds origin negated).
		transform _ transform composedWithGlobal:
			(MatrixTransform2x3 withScale: newBounds extent / oldBounds extent).
		transform _ transform composedWithGlobal:
			(MatrixTransform2x3 withOffset: newBounds origin).
	].
	transform offset: transform offset + (newBounds origin - oldBounds origin)! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 6/12/2001 06:18'!
computeBounds
	| subBounds box |
	(submorphs isNil or:[submorphs isEmpty]) ifTrue:[^self].
	box _ nil.
	submorphs do:[:m|
		subBounds _ self transform localBoundsToGlobal: m bounds.
		box 
			ifNil:[box _ subBounds]
			ifNotNil:[box _ box quickMerge: subBounds].
	].
	box ifNil:[box _ 0@0 corner: 20@20].
	fullBounds _ bounds _ box! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'!
extent: extent
	self handleBoundsChange:[super extent: extent]! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'!
handleBoundsChange: aBlock
	| oldBounds newBounds |
	oldBounds _ bounds.
	aBlock value.
	newBounds _ bounds.
	self boundsChangedFrom: oldBounds to: newBounds.! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 10/6/2000 15:37'!
transformedBy: aTransform
	self transform: (self transform composedWithGlobal: aTransform).! !


!MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 06:03'!
heading
	"Return the receiver's heading (in eToy terms)"
	^ self forwardDirection + self innerAngle! !

!MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:11'!
rotationCenter
	| pt |
	pt _ self transform localPointToGlobal: super rotationCenter.
	^pt - bounds origin / bounds extent asFloatPoint! !

!MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:07'!
rotationCenter: aPoint
	super rotationCenter: (self transform globalPointToLocal: bounds origin + (bounds extent * aPoint))! !

!MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:50'!
setDirectionFrom: aPoint
	| delta degrees |
	delta _ (self transformFromWorld globalPointToLocal: aPoint) - super rotationCenter.
	degrees _ delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.
! !


!MatrixTransformMorph methodsFor: 'geometry testing' stamp: 'ar 1/15/1999 16:34'!
containsPoint: aPoint
	self visible ifFalse:[^false].
	(bounds containsPoint: aPoint) ifFalse: [^ false].
	self hasSubmorphs
		ifTrue: [self submorphsDo: 
					[:m | (m fullContainsPoint: (self transform globalPointToLocal: aPoint))
							ifTrue: [^ true]].
				^ false]
		ifFalse: [^ true]! !

!MatrixTransformMorph methodsFor: 'geometry testing' stamp: 'ar 11/15/1998 21:52'!
fullContainsPoint: aPoint
	| p |
	self visible ifFalse:[^false].
	(self fullBounds containsPoint: aPoint) ifFalse:[^false].
	(self containsPoint: aPoint) ifTrue:[^true].
	p _ self transform globalPointToLocal: aPoint.
	submorphs do:[:m|
		(m fullContainsPoint: p) ifTrue:[^true].
	].
	^false! !


!MatrixTransformMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/15/1998 21:50'!
balloonHelpTextForHandle: aHandle
	aHandle eventHandler firstMouseSelector == #changeRotationCenter:with:
		ifTrue:[^'set center of rotation'].
	^super balloonHelpTextForHandle: aHandle! !


!MatrixTransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	transform _ MatrixTransform2x3 identity! !


!MatrixTransformMorph methodsFor: 'initialize' stamp: 'wiz 11/6/2005 16:58'!
asFlexOf: aMorph
	"Initialize me with position and bounds of aMorph,
	and with an offset that provides centered rotation."
	self addMorph: aMorph.
	self setRotationCenterFrom: aMorph center .
	self lastRotationDegrees: 0.0. 
	self computeBounds! !


!MatrixTransformMorph methodsFor: 'layout' stamp: 'ar 11/15/1998 21:52'!
fullBounds
	| subBounds |
	fullBounds ifNil:[
		fullBounds _ self bounds.
		submorphs do:[:m|
			subBounds _ (self transform localBoundsToGlobal: m fullBounds).
			fullBounds _ fullBounds quickMerge: subBounds.
		].
	].
	^fullBounds! !


!MatrixTransformMorph methodsFor: 'menus' stamp: 'jcg 11/1/2001 13:03'!
setRotationCenterFrom: aPoint

	super setRotationCenterFrom: (self transformFromWorld localPointToGlobal: aPoint)
! !


!MatrixTransformMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 21:55'!
addFlexShell
	"No flex shell necessary"
	self lastRotationDegrees: 0.0.! !


!MatrixTransformMorph methodsFor: 'updating' stamp: 'ar 11/12/2000 18:51'!
changed
	^self invalidRect: (self fullBounds insetBy: -1)! !


!MatrixTransformMorph methodsFor: '*eToys-geometry eToy' stamp: 'ar 6/12/2001 06:03'!
heading: newHeading
	"Set the receiver's heading (in eToy terms)"
	self rotateBy: ((newHeading - self forwardDirection) - self innerAngle).! !


!MatrixTransformMorph methodsFor: 'private' stamp: 'ar 6/12/2001 06:38'!
privateFullMoveBy: delta
	self privateMoveBy: delta.
	transform offset: transform offset + delta.! !
Object subclass: #MczInstaller
	instanceVariableNames: 'stream zip'
	classVariableNames: 'Versions'
	poolDictionaries: ''
	category: 'System-Support'!

!MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 01:58'!
extractPackageName
	^ (self parseMember: 'package') at: #name.
	! !

!MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 02:17'!
extractVersionInfo
	^ self extractInfoFrom: (self parseMember: 'version')! !

!MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/7/2003 19:18'!
recordVersionInfo
	Versions 
		at: self extractPackageName 
		put: self extractVersionInfo! !

!MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 02:04'!
scanner
	^ Scanner new! !

!MczInstaller methodsFor: 'accessing' stamp: 'avi 2/17/2004 02:55'!
stream: aStream
	stream _ aStream! !


!MczInstaller methodsFor: 'installation' stamp: 'avi 2/17/2004 02:56'!
install
	| sources |
	zip _ ZipArchive new.
	zip readFrom: stream.
	self checkDependencies ifFalse: [^false].
	self recordVersionInfo.
	sources _ (zip membersMatching: 'snapshot/*') 
				asSortedCollection: [:a :b | a fileName < b fileName].
	sources do: [:src | self installMember: src].! !

!MczInstaller methodsFor: 'installation' stamp: 'yo 8/17/2004 10:03'!
installMember: member
	 | str |
	self useNewChangeSetDuring:
		[str _ member contentStream text.
		str setConverterForCode.
		str fileInAnnouncing: 'loading ', member fileName]! !


!MczInstaller methodsFor: 'utilities' stamp: 'avi 1/20/2004 11:13'!
associate: tokens
	| result |
	result _ Dictionary new.
	tokens pairsDo: [:key :value | 
					value isString ifFalse: [value _ value collect: [:ea | self associate: ea]].
					value = 'nil' ifTrue: [value _ ''].
					result at: key put: value].
	^ result! !

!MczInstaller methodsFor: 'utilities' stamp: 'avi 2/17/2004 02:53'!
checkDependencies
	| dependencies unmet |
	dependencies _ (zip membersMatching: 'dependencies/*') 
			collect: [:member | self extractInfoFrom: (self parseMember: member)].
	unmet _ dependencies reject: [:dep |
		self versions: Versions anySatisfy: (dep at: #id)].
	^ unmet isEmpty or: [
		self confirm: (String streamContents: [:s|
			s nextPutAll: 'The following dependencies seem to be missing:'; cr.
			unmet do: [:each | s nextPutAll: (each at: #name); cr].
			s nextPutAll: 'Do you still want to install this package?'])]! !

!MczInstaller methodsFor: 'utilities' stamp: 'avi 2/17/2004 03:26'!
extractInfoFrom: dict
	dict at: #id put: (UUID fromString: (dict at: #id)).
	dict at: #date ifPresent: [:d | d isEmpty ifFalse: [dict at: #date put: (Date fromString: d)]].
	dict at: #time ifPresent: [:t | t isEmpty ifFalse: [dict at: #time put: (Time readFrom: t readStream)]].
	dict at: #ancestors ifPresent: [:a | dict at: #ancestors put: (a collect: [:ea | self extractInfoFrom: ea])].
	^ dict! !

!MczInstaller methodsFor: 'utilities' stamp: 'cwp 8/13/2003 01:58'!
parseMember: fileName
	| tokens |
	tokens _ (self scanner scanTokens: (zip contentsOf: fileName)) first.
	^ self associate: tokens! !

!MczInstaller methodsFor: 'utilities' stamp: 'bf 2/9/2004 13:56'!
useNewChangeSetDuring: aBlock
	| changeHolder oldChanges newChanges |
	changeHolder _ (ChangeSet respondsTo: #newChanges:)
						ifTrue: [ChangeSet]
						ifFalse: [Smalltalk].
	oldChanges _ (ChangeSet respondsTo: #current)
						ifTrue: [ChangeSet current]
						ifFalse: [Smalltalk changes].

	newChanges _ ChangeSet new name: (ChangeSet uniqueNameLike: self extractPackageName).
	changeHolder newChanges: newChanges.
	[aBlock value] ensure: [changeHolder newChanges: oldChanges].! !

!MczInstaller methodsFor: 'utilities' stamp: 'bf 2/9/2004 15:00'!
versions: aVersionList anySatisfy: aDependencyID
	^ aVersionList anySatisfy: [:version | 
			aDependencyID = (version at: #id)
				or: [self versions: (version at: #ancestors) anySatisfy: aDependencyID]]! !

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

MczInstaller class
	instanceVariableNames: ''!

!MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 18:13'!
installFileNamed: aFileName
	self installStream: (FileStream readOnlyFileNamed: aFileName)! !

!MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 17:56'!
installStream: aStream
	(self on: aStream) install! !


!MczInstaller class methodsFor: 'instance creation' stamp: 'cwp 8/7/2003 17:56'!
on: aStream
	^ self new stream: aStream! !


!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:49'!
extension
	^ 'mcz'! !

!MczInstaller class methodsFor: 'services' stamp: 'nk 6/8/2004 17:29'!
fileReaderServicesForFile: fileName suffix: suffix
	^({ self extension. '*' } includes: suffix)
		ifTrue: [ self services ]
		ifFalse: [#()].
! !

!MczInstaller class methodsFor: 'services' stamp: 'avi 3/7/2004 14:51'!
initialize
	self clearVersionInfo.
	self registerForFileList.! !

!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:54'!
loadVersionFile: fileName
	self installFileNamed: fileName
! !

!MczInstaller class methodsFor: 'services' stamp: 'avi 3/7/2004 14:49'!
registerForFileList
	Smalltalk at: #MCReader ifAbsent: [FileList registerFileReader: self]! !

!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:53'!
serviceLoadVersion
	^ SimpleServiceEntry
		provider: self
		label: 'load'
		selector: #loadVersionFile:
		description: 'load a package version'! !

!MczInstaller class methodsFor: 'services' stamp: 'ab 8/8/2003 18:01'!
services
	^ Array with: self serviceLoadVersion! !


!MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 1/19/2004 13:13'!
clearVersionInfo
	Versions _ Dictionary new! !

!MczInstaller class methodsFor: 'versionInfo' stamp: 'cwp 8/11/2003 23:49'!
storeVersionInfo: aVersion
	Versions 
		at: aVersion package name
		put: aVersion info asDictionary! !

!MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 3/7/2004 14:51'!
unloadMonticello
	"self unloadMonticello"
	Utilities breakDependents.
	
	Smalltalk at: #MCWorkingCopy ifPresent:
		[:wc | 
		wc allInstances do:
			[:ea | 
			Versions at: ea package name put: ea currentVersionInfo asDictionary.
			ea breakDependents.
			Smalltalk at: #SystemChangeNotifier ifPresent: [:scn | scn uniqueInstance noMoreNotificationsFor: ea]]
	displayingProgress: 'Saving version info...'].
	
	"keep things simple and don't unload any class extensions"
	(ChangeSet superclassOrder: ((PackageInfo named: 'Monticello') classes)) reverseDo:
		[:ea | 
		ea removeFromSystem].
	
	self registerForFileList.! !

!MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 2/17/2004 02:49'!
versionInfo
	^ Versions! !
Object subclass: #MenuIcons
	instanceVariableNames: ''
	classVariableNames: 'Icons TranslatedIcons'
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!MenuIcons commentStamp: 'sd 11/9/2003 14:09' prior: 0!
I represent a registry for icons.  You can see the icons I contain using the following script:

| dict methods |
dict := Dictionary new. 
methods := MenuIcons class selectors select: [:each | '*Icon' match: each asString].
methods do: [:each | dict at: each put: (MenuIcons perform: each)].
GraphicalDictionaryMenu openOn: dict withLabel: 'MenuIcons'!


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

MenuIcons class
	instanceVariableNames: ''!

!MenuIcons class methodsFor: 'accessing - icons' stamp: 'KR 5/4/2006 21:37'!
blankIcon
	^self blankIconOfWidth: 16.
! !


!MenuIcons class methodsFor: 'class initialization' stamp: 'dgd 9/22/2004 18:27'!
initialize
	"self initialize"
self initializeIcons.
	Smalltalk addToStartUpList: self! !

!MenuIcons class methodsFor: 'class initialization' stamp: 'dgd 9/22/2004 18:27'!
initializeIcons
	"self initialize"
	| methods |
	Icons := IdentityDictionary new.
	methods := self class selectors
				select: [:each | '*Icon' match: each asString].
	methods
		do: [:each | Icons
				at: each
				put: (MenuIcons perform: each)].
	self initializeTranslations.
! !

!MenuIcons class methodsFor: 'class initialization' stamp: 'nk 5/1/2004 16:49'!
initializeTranslations
	"Initialize the dictionary of <translated menu string>-><icon>"

	TranslatedIcons := Dictionary new.
	self itemsIcons do: [ :assoc |
		assoc key do: [ :str | TranslatedIcons at: str translated asLowercase put: assoc value ]
	]! !

!MenuIcons class methodsFor: 'class initialization' stamp: 'dgd 9/22/2004 18:32'!
startUp: resuming 
	resuming
		ifFalse: [^ self].
	self initializeTranslations! !


!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/9/2003 16:16'!
exportAllIconsAsGif
	"self exportAllIconsAsGif"

	| sels | 
	sels := self class selectors select: [:each |  '*Icon' match: each asString].
	sels do: [:each | self exportIcon: (MenuIcons perform: each) asGifNamed: each asString].
! !

!MenuIcons class methodsFor: 'import/export' stamp: 'nk 2/16/2004 13:38'!
exportAllIconsAsPNG
	"self exportAllIconsAsPNG"

	| sels | 
	sels := self class selectors select: [:each |  '*Icon' match: each asString].
	sels do: [:each | self exportIcon: (MenuIcons perform: each) asPNGNamed: each asString].
! !

!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/11/2003 11:36'!
exportIcon: image asGifNamed: aString
	"self exportIcon: self newIcon asGifNamed: 'newIcon'"

	| writer |
	writer := GIFReadWriter on: (FileStream newFileNamed: aString, '.gif').
	[ writer nextPutImage: image]	
		ensure: [writer close]! !

!MenuIcons class methodsFor: 'import/export' stamp: 'nk 2/16/2004 13:38'!
exportIcon: image asPNGNamed: aString
	"self exportIcon: self newIcon asPNGNamed: 'newIcon'"

	| writer |
	writer := PNGReadWriter on: (FileStream newFileNamed: aString, '.png').
	[ writer nextPutImage: image]	
		ensure: [writer close]! !

!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:04'!
importAllIconNamed: aString
	"self importIconNamed: 'Icons16:appearanceIcon'"

	
	| writer image stream |
	writer := GIFReadWriter on: (FileStream fileNamed: aString, '.gif').
	[ image := writer nextImage]	
		ensure: [writer close].
	stream := ReadWriteStream on: (String new).
	stream nextPutAll: aString ; cr.
	stream nextPutAll: (self methodStart: aString).
	image storeOn: stream.
	stream nextPutAll: self methodEnd.
	^ stream contents! !

!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 13:06'!
importAllIcons
	"self importAllIcons; initialize"

	| icons |
	icons := FileDirectory default fileNames select: [:each | '*Icon.gif' match: each ].
	icons do: [:icon | self importIconNamed: (icon upTo: $.)] ! !

!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:05'!
importIconNamed: aString
	"self importIconNamed: 'Icons16:appearanceIcon'"

	
	| writer image stream |
	writer := GIFReadWriter on: (FileStream fileNamed: aString, '.gif').
	[ image := writer nextImage]	
		ensure: [writer close].
	stream := ReadWriteStream on: (String new).
	stream nextPutAll: aString ; cr.
	stream nextPutAll: (self methodStart: aString).
	image storeOn: stream.
	stream nextPutAll: self methodEnd.
	MenuIcons class compile: stream contents classified: 'accessing - icons' notifying: nil.
	^ stream contents! !

!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/9/2003 23:49'!
methodEnd

	^ ']'! !

!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:04'!
methodStart: aString

	^'^ Icons
		at: #',  aString, 
		' ifAbsentPut: ['! !


!MenuIcons class methodsFor: 'menu decoration' stamp: 'dgd 4/3/2006 14:45'!
decorateMenu: aMenu 
	"decorate aMenu with icons"

	| maxWidth |

	Preferences menuWithIcons ifFalse: [^ self].
	Preferences tinyDisplay ifTrue:[^ self].

	maxWidth := 0.

	aMenu items do: [:item | 
		item icon isNil ifTrue: [
			| icon | 
			icon := self iconForMenuItem: item.
			icon isNil ifFalse: [
				item icon: icon.
				maxWidth := maxWidth max: item icon width.
			]
		]
		ifFalse: [
			maxWidth := maxWidth max: item icon width
		].

		item hasSubMenu ifTrue: [
			self decorateMenu: item subMenu.
		].
	].

	maxWidth isZero ifFalse: [
		aMenu addBlankIconsIfNecessary: (self blankIconOfWidth: maxWidth).
	].
! !

!MenuIcons class methodsFor: 'menu decoration' stamp: 'nk 5/1/2004 16:48'!
iconForMenuItem: anItem
	"Answer the icon (or nil) corresponding to the (translated) string."

	^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]! !

!MenuIcons class methodsFor: 'menu decoration' stamp: 'dgd 4/20/2006 12:33'!
itemsIcons
	"answer a collection of associations wordings -> icon to  
	decorate  
	the menus all over the image"
	| icons |
	icons := OrderedCollection new.
	" 
	world menu"
	icons add: #('previous project' ) -> self smallBackIcon.
	icons add: #('select' ) -> self smallSelectIcon.
	icons add: #('jump to project...' ) -> self smallForwardIcon.
	icons add: #('open...' ) -> self smallOpenIcon.
	icons add: #('appearance...' ) -> self smallConfigurationIcon.
	icons add: #('help...' ) -> self smallHelpIcon.
	icons add: #('windows...' ) -> self smallWindowIcon.
	icons add: #('print PS to file...' ) -> self smallPrintIcon.
	icons add: #('debug...' ) -> self smallDebugIcon.
	icons add: #('export...' ) -> self smallExportIcon.
	icons add: #('save' ) -> self smallSaveIcon.
	icons add: #('save project on file...' ) -> self smallPublishIcon.
	icons add: #('save as...' 'save as new version' ) -> self smallSaveAsIcon.
	icons add: #('quit' 'save and quit' ) -> self smallQuitIcon.
	icons add: #('load project from file...' ) -> self smallLoadProjectIcon.
	""
	icons add: #('do it (d)' ) -> self smallDoItIcon.
	icons add: #('inspect it (i)' 'explore it (I)' 'inspect world' 'explore world' 'inspect model' 'inspect morph' 'explore morph' 'inspect owner chain' 'explore' 'inspect' 'explore (I)' 'inspect (i)' 'basic inspect' ) -> self smallInspectItIcon.
	icons add: #('print it (p)' ) -> self smallPrintIcon.
	icons add: #('debug it' ) -> self smallDebugIcon.
	""
	icons add: #('copy (c)' 'copy to paste buffer' 'copy text' ) -> self smallCopyIcon.
	icons add: #('paste (v)' 'paste...' ) -> self smallPasteIcon.
	icons add: #('cut (x)' ) -> self smallCutIcon.
	""
	icons add: #('accept (s)' 'yes' 'Yes' ) -> self smallOkIcon.
	icons add: #('cancel (l)' 'no' 'No' ) -> self smallCancelIcon.
	""
	icons add: #('do again (j)' ) -> self smallRedoIcon.
	icons add: #('undo (z)' ) -> self smallUndoIcon.
	""
	icons add: #('find...(f)' 'find again (g)' 'find class... (f)' 'find method...' ) -> self smallFindIcon.
	""
	icons add: #('remove' 'remove class (x)' 'delete method from changeset (d)' 'remove method from system (x)' 'delete class from change set (d)' 'remove class from system (x)' 'destroy change set (X)' ) -> self smallDeleteIcon.
	icons add: #('add item...' 'new category...' 'new change set... (n)' ) -> self smallNewIcon.
	""
	icons add: #('new morph...' 'objects (o)' ) -> self smallObjectCatalogIcon.
	icons add: #('authoring tools...')  -> self smallAuthoringToolsIcon.
	""
	icons add: #('leftFlush' ) -> self smallLeftFlushIcon.
	icons add: #('rightFlush' ) -> self smallRightFlushIcon.
	icons add: #('centered' 'set alignment... (u)' ) -> self smallCenteredIcon.
	icons add: #('justified' ) -> self smallJustifiedIcon.
	""
	icons add: #('set font... (k)' 'list font...' 'set subtitles font' 'change font' 'system fonts...' 'change font...' ) -> self smallFontsIcon.
	icons add: #('full screen on' 'full screen off' ) -> self smallFullScreenIcon.
	""
	^ icons! !


!MenuIcons class methodsFor: '*MorphicExtras-accessing - icons' stamp: 'dgd 9/25/2004 22:59'!
backIcon
	"Private - Generated method"
	^ Icons
			at: #'back'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self backIconContents readStream) ].! !

!MenuIcons class methodsFor: '*MorphicExtras-accessing - icons' stamp: 'dgd 9/25/2004 22:59'!
forwardIcon
	"Private - Generated method"
	^ Icons
			at: #'forward'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self forwardIconContents readStream) ].! !

!MenuIcons class methodsFor: '*MorphicExtras-accessing - icons' stamp: 'dgd 9/25/2004 22:59'!
helpIcon
	"Private - Generated method"
	^ Icons
			at: #'help'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self helpIconContents readStream) ].! !

!MenuIcons class methodsFor: '*MorphicExtras-accessing - icons' stamp: 'dgd 9/22/2004 19:35'!
openIcon
	"Private - Generated method"
	^ Icons
			at: #'open'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self openIconContents readStream) ].! !


!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:37'!
backIconContents
	"Private - Method generated with the content of the file /home/dgd/back.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADRElEQVRIie3WW4hVVRgH8N/e+5y56aCizpnR
jJzUCNFqLhqEWGlQDz0mGEJBCSL1Ur1YZA9BSIZGZg9dVBoo0B5D6qGwOzVaairZiJiKZ0hs
1NE5c2bm7N3DmXF2zQyO5lv+YbFZa/2/77+/y9prcxNpNFnoHi3/xUU4LtYiszX5WGC/ULsW
m69XMLgqo8UzEhtRlVpNJJb62Tc3TnCxnH7bBR65sra0nt8vkC9Ah9Ay7U5d2Z+jUrUaoRqx
Hr/qGp9gk0cFPsB0UFfFugUsybH1N7YfS7O7UTE4/u2vgDze02ijXUrRCLFmzwtswwRhwGO3
Wb55tcWNzQ75g7+KfNmZtqhEZoyXz2IKlutSIe+LNCnQ7A08NxRVuKHVywvXWG+lDXZ5SRs9
A7Qd53g3pSQlG1GboTY7PKojNh/hXBFK+s0oC85XocoOrASzJ6p9+wE7c69I8K7PfKrdgBK4
XYNWc+VMFgwGlkgU9Svo06OooOiksw7u3MPrhwySVmVAlTasAAummPzWg16oXWGdD+13fESe
ulxSZ5I7zTJHg1tNVxIr6FNQ1KlLuw7fOkJ9dTqHDwWarBJoA7lqPlqiflJO58gGuz78cJZn
fxya/ZQRutdQKZY1MKlifGJJzEA/A32UUs+4NDhispVcjtMRdmeU7BBag8iJM5yOmDmPYIwj
2pXn5MGy2LhQl3pJF0O/2CuwBXzfS0cnR7+j9/IoUSWcPnINYuhNcRN/DnXpRFUOoFFNwKYa
wgJ1s2mYS1TuLedOceLAsIMwIsoSZEhC4oCBgD70xpzB9ktcGExr4PHhvLVqFPsaM02NeC2L
XjKVTJtVdp7vKNfufB1bznO2RLE03lhj5P5ZqBZ3SHyFnFsyrM+SFEaabqrm6CjrY6Mf79tn
7cjOaDVfbA+mmRzyajUVqXpGE3g6NQ88IXZYKFISCUVioUAfetDjolOOKZbpo6HV3WK70SCL
F2uZ0V3eOzCFd64cm8/t8/C1hDr29dSqXuwT3AfuyjIvy66etPVT9tp2YwShWRZvYu0ouydd
MG8oVePFyOspjbxY3m4znMD9hm/90xJPOuzYmLZj4Oq/GENYZKqS1QKxPlsdNMqX4Sb+D/gb
LOgMCUjhiw4AAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/13/2004 20:01'!
blankIconOfWidth: aNumber 
	^ Icons
		at: ('blankIcon-' , aNumber asString) asSymbol
		ifAbsentPut: [Form extent: aNumber @ 1 depth:8]! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
configurationIcon
	"Private - Generated method"
	^ Icons
			at: #'configuration'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self configurationIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:47'!
configurationIconContents
	"Private - Method generated with the content of the file /home/dgd/configuration.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAF30lEQVRIia2WfWyV1R3HP8/L7X3p09tCZRWx
oE2x4Es2CIMmjiVjtKSQ4R9ONzbrtgQMakI3EoWiA3QMssTF1U2zGhZsQ5buzQmdZJszULAd
ULTUYPClaKm7VLkwS2/v6/M897c/zn3u7a2VSNwvObnnOfec8znf3/n9zjkGn99M4HFgF3Az
oAGjgHMNc3xuuw04BciSJV+TjRs3S3X1TQKkgCPADuDrgP+LggxgC5AKBkvl2Wd/Lx9/nJHh
4bScPBmX/ftPyKZNe6S29naxrLAASeBVlCfuBHxTJzSvArsF6ADqGxvvoq3teSorZxKNOsRi
2XyngwdfYHj4HebOnc+OHXsDn3wSXXH6dO+KgYFeRkfPJ4Be4HCunNSmAWlAC7C7oqIy2NTU
SFNTE5HIKAMDQyxYsJRly77JkSMHaGtrJZNJsWrVvWzd+muCQatoov7+wzz66HdIJuNe0+yp
sBqgB5CHH26V4eGYjIyMyd69f5HFi5eLrusC5IthmLJu3SY5evSyHD8eLypbtjwjgUBI0HVB
17wx+RVpwIPAxMKFX5aenrckGrXlwoWMDAwk8pM89dSfJByeIYBoWn4S8fuDUl+/Ulpa9kh7
+yuyfPka9V+FJTz3YyHoFyCb4xACXgGkrKxcurr+JZFIQs6dS8uJEwrU1zcu69c/JrpuCCBr
1nxfDh36QHbt6pCGhnskFLImwQOqfus84W97hFPtgmkIEPOUVQEfTfZrIBCkrm4R9fUrqav7
Cp2dv+T06V6CwVIeeeRXrF79vaJ9iMfH2blzA6+99jIiApVh6N4DJSaIwFc3kmPMNoE4QMua
Ju667VYOHj/Bb4/1ZgcH+/TBwT7lb03Dssppbt7M0qUrimBDQ2fYvv2HvP/+WQUwDLCCqg5g
u17XmFfRAfnp3XeL+9KL4rzwOxm7eY50z75O7ijxSVlhw/OltvZ2aW7+iWzY8Lj4fH7VXjVD
6GwVZlUIc65TrjzVLvxxhzfuDVB5mDUgk3adEoU3CGgaDcEAu/VxYlnhyZnllOkaf0+k6Emm
ZWjojDY0dKYgc+kC2L0BKizwmeDkVP2zH36+v0ihCWBoWqoA1PPzOKJ+bzIN7rVCPBi2SIlo
R5Np9sXi/DWeVLDftBTGlZgwnoYnOqC7b7L3Jzx3YkIqbefOYKMA9LxfOmkRAU2jMRRgnRVS
DZXlRYskm4WxuIKV+GDj2iKFCqiRito2H7kuohsFoCiJljbdgeR1yh1zItD5D/gwqqC1c2D/
NmhYUqRQuRQtOWE7HE6m0W2bnktj3GMFsfMKrwZ04dIV2L4PTp7NecmAzlalcCjyaYUGJH2u
y1zTIKvrtI9PsPJClHczCnnOdpDPAl4cg+8+qWAVFtRVq+wuyV0Umfx1WdhDQ9OStuNwZ8DP
t8MWe2fNZGUwkL9Zf3Dxv9wyMkrr5Su8ns4UA8+eh7EJWLYQurbDl2YUohTAyQMnRynJtKs6
+TSN+8Kl3FcWYv7IKB86Lov8JQykMzx9JcbTV2LU+EwWewqCfvhREzQ3gKaptAC1t4YO/e8U
KTRzMhMpZ9JLQTfALbjxyA2ziDguXRMJuiYSvGs7DHtRPf9GuL+xMNY7YVIZaPszvHgM1FPk
aN6lpqYnku5koAoSR8DUwK9p1PhMts0I82b19fx7ThWrQwHVd2o8ecBNz3iwY8Bi4EweGHfd
6AfnR2g/cIALkUg+r1wES9OZaov8Pu4vK1Uf2SnhlEhDuBQGzwG0ASuYdDmYANFstoPx8ZqH
9nWsemhfh77AZ9oPhC2fLRC6WkqASgvPXn0Djr0JaTsOrAe6pnb3lt8PrEY9/372tu1c3Hx5
jJhINpkV6U2lPxvoZFXSt3fD1uchbb8H1E8Hu5oZwFrgZdQJJ/NMI/GLynKJzLtBUjU3yh+q
Kl1AmFclfGORdyO8BJRfC2g6qwaeAP4DiAHO2lAwvrm8zKZwZbnANj4dQl/IDOBbQDfqte3B
LgEN/0/QdFYN7AQOAXOvZeD/AIXZmm50KVY/AAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 13:33'!
confirmIcon
	"Private - Generated method"
	^ Icons
			at: #'confirm'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self confirmIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 13:33'!
confirmIconContents
	"Private - Method generated with the content of the file /home/dgd/confirm.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACsElEQVR4nK3WvW8URxjH8c+CDxtsYg6FCJDy
IqUIWKAUiCJFWuiRIqWCKn9AynRJnS4VShEpEimSBlGkiKBAGIkUWIoUBVtC4IvBb2BsH8fd
+fD5NsWM7VO43bXPPNJoZnafme/MPL95oT8r4RCS3TbcTYNSibEynw1xusXiKyp1FvAQT5G+
LeB7H/HdCFdwcLNRStri1gK/1HiMP7G+V+ChT7hd4vwRXMB+vIxpEs+pzvB1jakIzZzp/iLa
x3w/yKWL+DECP8cpLGEULxgqcXaZ8ZR6HEtfwOQkv51h8CqGun68E6ETgoJmKadM1HkmxLWn
7cujneCDhMNfZjiOYgzlWB/mUxzO6zMXOBpjfDTHp2xbJSlN1PoGTlFJmZ3K8XmCf2O5yTRW
+gZCm2s/d3XabY9wM+YbTC5yL8N1ywpVWma8zRe/8+5BDGAef+BbVNBhvca948yfYOFZUGpP
y9uH+87yVco3+HDT+f8bLMVGHHmCOpenuY5XvTodyKKdY6jF1UFB/idj5yuCKgZwTDhQ4Q5W
6cyyJgh4d8AJmmfwPq5FWBXLoWO1MBt/xe8v0WH6dVBqT1guMDLW2nG/JzgSU7fD/TjrFOs8
iMVMYJFKmxs5P+eF9VuO9Qb/hExms1xgQrOd839T/5vAaphh/xs/pZEHnLMtpA7z9VDMXM5C
oIIZLgliaduKH3uZIZpZt2kqXAkvYr0V4rdnYCMr+nMBshW/2g4UWghMc5Z0OubLwa+6wqyg
0E7fwDyVzgkbv4X2DpezEIhGqveQl2zHb22HgikEJuGYeuMZ1hH24GSoNle3H06LewLGG/yN
Y+MJxvEaq/xQDaC/QzXf8s5SKc0ElzCIAzE1hLVb48ZT7goamimC7QT4K2Yq4VkzkjDSYThh
uEO7wk/CZfEgr59u+w8LnvWEFNR9UgAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:34'!
forwardIconContents
	"Private - Method generated with the content of the file /home/dgd/forward.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADXUlEQVRIie3WX2iVZRwH8M97znv2f1o2Fy4r
hxMvhhCeTewmJcuEbiLLP0GECoJWEIlYUBoR3QTVhRRIXffvJupiBF4oRCZukq5Na4LhlKnT
6XE7c/P8ebs4O8fNlh3nVdEPHnif5/d8f9/3+33e53le/usRvyv0UknzzDXgQrmQ2IzJkt4V
6BT4xVJfWKa5HFgwI7J27fIOmerQmMBOnfbeGWGrChXmoVZeSlZKjzQisEyznA4s1lhFWwMd
Z4tZIh0SNjk8vc03CZO2Yzcap32R6WLLIrYt5sgl3jvOudFiZlBki6O+vxVSsKTNK9iLurLJ
4PkFLKy38YE1Wp5b7uT1P+hJEakV2KDJiAGHpipMSmAIdeoT7GwlGzGaJT2pjeUK49l8Aflw
HZtaqI57xwv22OhD33qj+2OZXYe5OFaYF/nIUTtMmB5ot0LeAbB5kSXbn9LqIRXCUksIBZOE
Dxl2RJ8T+ktjKy2x1RpN5lh7aY/Lr+6n71qR9EvjXtLjRijnyVKt+TVOOqtNiyc84kENQnGJ
Cef7XXLKgGtG9Ruc4u4B3Q7o1mKelxue9ennCYOv76fzMoENqmXxYiDpK6wD7y9ldVPZS3i7
mKPe0PAQ6w/etDfwTIjh0qx0mounuXEdAUFAECMekqgkrCCsJFFReA7+/twYMkx9guVz+W7C
+rwVIVKlWUGK/vPlSQgC5rfSuGD6fD7H6V76SvXGBPbFBJM2aCpTHhlEEQO/E+X/mhu+TO9B
jl3lxETNyG5dTsbdb1xgK+gaY3YdFdXkagiqCWuIVxFWEYbEYhMkUUFFWEntPYWimXHOdHO2
l5Fa3koVyQ5aaJteUYCYpAtoKFtdTYwd9zF/sGBtY3OBfOgcuSz5Wbw2zHgEXVilq7B0cUSa
jKEdNWURZiL6MqyMCkrTVxhNFZTnZ7MrzWgeesSt0ulKETr1GFviXjUqkJAVE8rLysnIqZKT
0SzmR1SCfXVEIzfxV+t5e4QbEZzCY7oMTKa48+sp6TNsAetn8fi1wvY4Vssnw8Vb41c8rcuZ
W+EzIVyNH0r99gT9Oc6XvtavZWx2XHo6+Mwu4DY/iTx6y2hO5E1HfXA76Ex/MTbh50n930RW
/xMZM1VYxLZZK2/MQh2+kbuLWv/Hvyj+BJaPHpqZ0oo8AAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
fullScreenIcon
	"Private - Generated method"
	^ Icons
			at: #'fullScreen'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self fullScreenIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
fullScreenIconContents
	"Private - Method generated with the content of the file /home/dgd/fullScreen.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHT0lEQVR4nL2WW2xc1RWGv7X3OWcutmfGYzuO
7TjBSYAAgaSQEGhRQVwU2pAgFQFC6iuKhBAvCEWVKtWPBCpVquhTq6pUBURFaVrUBmQuBRWh
FJELhIRQGi42SUx8HY9n5lz2Xn3whAZIipCq/tJ6Odr7/Gv9/1rrHPg/QwAeffTRjjiOK2EY
DotIRURKqpoXEauqAnhVTY0xdWDBWnu6VqtNDwwMzO3cubPxjQl37959jYgMqepaEbFAoKoB
gIio9x5jjPPeZyLi2nc90BSRaRE5HgTBJ0NDQ5/ddddd7jxcS4SqKo888siNwJWLycJlx04e
Gwisdb1dy+qD5aHaOe54EUmApqo2gWb7WR2Ycs69H4bh+IMPPjgtIvoVwtHR0c5CoXCtiNzw
i5d+dm881Ojr7a8yO1UjPpGkF5cueXfHxjve+i9Je2BBROZVNRYRFZF559wnxpj3G43Gx6Oj
o9mZw0GxWOxUVUSkM+5Y7Or+XoH+rirbe2/jqZeeCGtvLHSpqpwr2zYMUFbVsoi0VLWmqlZE
Kt77Ffl8/pOHH374aKvVmhgdHfV269atPara49VveKPx2tW5FYEsmjrHakeodvTw8ZsnuoYr
K5NKoWKNMREQyBL8OcgDoAOoiogXESMi/UC/MaZz27ZtdeO9j1Q1yLIs1EwlmcmIT6YkpzOG
+4e5+d7vhs8cfHLTqfmTZVUtAmWgV1UHgG4RyZ2n6hFVXd2uvt8YU0qSZMCISM5amw+D0LmT
mrp5pX4gxtU9B47up2ugg0t/uDb688Fn13/B/CUUgV6gH+g821fv/SKwQlU3GGM6RMSGYRgY
wKhqBPCt5VcfKr7ZM71Fr383edU2XcPzyqEXef/Nf1LMdcTn6xoRCUSkDPS1ZeWM5+1ZVmOM
zbIsDEQkExHnnOOWy249JiKzgLtk4NLTT4z9dlO9Wu8sz/fMb99y+wdf0zyISNSWcPosUmlX
bAETiEjmvY/PyOS9t8YY19PVl+y84f53Do0fWL6sUk7+Mbb34oWFhTBpNUwaxzZzqc3li3Gx
q9LsKlUa1d7l9eGRi2a7q1WstYalcfFtBTMRSVQ1DpxzznufGGMUEGst7S3TlQ/zZsvqa6de
fO6pVdtv/0Hf+g1XUSqXKZe76SpXSOJW/sg7B8uH336LI+8c5KU//cZJWJwdXHXhB+vWX3m8
r6/PAUZEUlVNRaQVGGMyVfUiknrvRUQCIC8ickaq2uxMfscd97BqZO1XZBwcWsH1N99ClrZo
LNbs88/t6X3290/27vndYxuGRi45ccWm644PDg6qiGTW2iVC5xze+xRw3vvIGCNnv7RWm8n3
9Q9w9MPj7NULmM1gLhGqkbImDyM5ZV2UYa1h623f56Zbb+bQ/v2Fpx5/fM3zz/xqsG/4osb6
jVuOr1y5shUkSVJvF7MgIqW21h1nBjtLU2NEomKxgw/mG7yRNVAEr8J4Aw4AXkNypsymYsh1
+ZTVEVy+cSOfjo9z9z33FH6068cXnTq1qjIyMtIyu3btqgGZiEyqqvPeN9udBUCzUbd9y5YD
ME9AybQoSYuyaVK2TUrSomSaRMQcXLT8fHoZT8/3YIzBWkso4FwWJEkSdnd3N4yIaBAEc977
yXanTra7C4B8scOlSQJAqhkV02J1IeXb3cKNvYZ1nY6KbS0lYmLKJuZwK2QqCwijCO8VkCRN
08WdO3emAYCqzojIbHv5ApwClouIhmHkp6dOKyCha7CuXGKgaFCWPnvdXYLxGXNJhkeWQoXx
1BJFEUmWoiIzaZqehqWdRxRFp9pj8VG7sEkR+UhVW6qKima1+TlK1jFUAPExxrcQHyMas6YI
ZRt/HhUbY8URBJZms4W10Wwcx5OfEz7wwAOxc+6kiBwTkRpLq2FeVY+r6qedpe7Fo4cP0dmc
J/ANAhpYbbajQZdNWNMB3bZJ5Yy3JiOwAfX6AibM1SYmJv5DCLBr164jwIfe+1eNMVPttZQB
05Vq3/hf9jzNhYOriHydnG8Q0SDSBpFvEmqTauC4oGDpC5d8rlrFinDi0xNokD8+MTEx9QVC
EdGHHnrosLX2befcq8BhVa0DfsXKtSde+Oseunv6qMYtCtKgSJMiDQrSIM8ieRbpNC0GcsoF
BaFkhcZinddff33OefMeEAPYL2+OsbGxuR07dow75+aBmjGmWe1bPntg32vrioV85zVbvkNO
Hfg6VhIio0TiyIknMo7IOMoIeQIO79/P3hdePjgxOffrNE0nz0kIsHfvXjc2NvbZnXfe+a8s
y8aByeUrVr33xC8f2/jZqROl9euvoJwrk8cQkpLDEZKRQ8mrUJQ8Rw6+zcz0FH/7+74/TM0u
7gUWOXvAvw6qKvfdd19l38t/vDdNWvevv+Ly4as2b+bKzZsZWbuWIAi+cH7fKy+ze/dPpw4c
PXl3Bq8A+o0Iv4w1VYadsk1FthuRS8uVSndPb09XoVg0C7V5NzMzMz0xWfvJbIMngXP9bv5v
0N9PB+exCuDf3d6HA+fU4WgAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:43'!
helpIconContents
	"Private - Method generated with the content of the file /home/dgd/help.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGoklEQVRIicWWeWxU1xWHv/fmzZvF4wF3AION
XXuKgSAT0yZhNaRKIMIToARSkbQJIVEw2CW0FRQEIoUUNWpLSCsFlECxUKpilsqCsFjESzFl
bGpsEG4DqUjBLRiN8W6P7Vk8753+ETCbIbSq2t8/V/e+q/vdc879HT34H0t5xH2PAbOByTfn
UeA68CngB/r+28COzXxt0GNYARDgLBEO08tFot3ANuAdIPxIQNmEejZAriK8BDhNCCkKn13r
4srmSrLqrvJqE2nEo953QD19rKCFUkLXgTnA+YcBVYBzDXwT4SeGsB6T1yIma1eWEFtyXN88
bNwzCzLRB4QBHKOXckJYNCXJEW/5aPpo68QTm9AeBNQAFJOAWGifuJMqwDrI49xvt+m+fXv3
2CyqlZ0VL6MMSwKLBSJRJNAEIvyUNt7Xe/ng19vx+XKUtetWZx49dqiyutbx98o8a9ctiICu
wF+jii2/n1y7jO01S8nxJLpLn587q7epuUlERM6cOSPzJk2TnvIqCZVXSaS8SowDx6T82RfF
6XRKZWWl3Klfbnk35ozXwpqDKXcAFX/eoC2V+YPe6weeWcqERU/FfTZufEYkEomIiEhnZ1CK
i0+I3e6Ro08vktIn5knFs6/I56+ukinDU6SwsFAG0sof5cfcHkeAIcTfOr9yuSvTn+eu/TK6
XJw75rHX7lLFX3lKRETa2jrkyJFyKSo6LpmZk2Q6HnkOj8zCI9PxSGKiV5qb2wYEBoNBSU0f
HhvscWzrB+a5X/HnufeoZ9/kceAvBZcGT16y+A2ZNjWbUCjMqVM1RKN9tLQ009p6PVqtB3tO
2robTurBi+fjo1esVvOfM2Y8E6upqb3vYbhcLpblrrAYhrkUcJ3Kd+eLQr6uGKuoyaXoD4t4
yxanSH39lZt1q5OiouPy4Ye/Mz2eYdfgdj3uVHZ2dlZqqjdYV1d3X5Tlf/SL7kTiB9tf8+e5
L/tXOJMAVAUyV1fQk5aWHktLS6ejo4tr1wIAbN26paG1tWkucHogoN/vr+vrCy3ZuHFj8N5v
4VAfSUkpjBo1ai7wZ0xLDoDWZ1A20mXd1Gpq2vz58zlXc562zhAOh4OOjmaVrzByIBA4Vlpa
epdJw+EI4XCE5KRkWtuax6jSN9vAeuJkvqtKnVLAb62XtZStjQoHVq6hOGMq7/U4yG4JEYtF
Enl4+1OAHaqq9t65eONGCwDd3d3YbHZt6keh68ARDUu2CiTOJ47nvGOwohDs6cWDhZt9UwOy
HgJ8B1jc29vrKSsr61/84ot/ICIEAg3YdL27arkjWRFllihGlQo0dWCACABxaSMB8GJFBWw2
2/cHAKlAHvD2ehJYb7hVn8/H7t27CQSa6Orqpr7+Ch2dHUxMsSWYivWoqLIme3v3BQDXHJxm
1DZWzOMnpenAMdmZ8Lh4cciECRNkxIgRoZkzZ751R2rnAFcAeYN4ieCVKF75ZEqOaCji8y2U
PXsOSY7vO6I7kVULx+fe11ttKCVX+brE3lwnV3ftk9R4j6xbt04Mw5Bdu3bJkCFDRNM0w+12
96iqagBSwgiJ3oTFXv6hGOVV8umLy2QobklISBbNZpXMrNEdD6rFwnnESbN9jEwdniKrV6+X
9vbOfk+1t7fLjh07ZMOGDeLz+QSQ0yRLVMuQ2HdXiFFeJe3FFXIkeYrsJl2ySBBQJGPMqIIH
AVWgJBlNdJsuP3/3fTl4sEQuXaqXWCx2l6EbGxsFkKJpPjH2HZVQeZU0Hi6Tkqzn5QBe+T3p
kkqc6DY9CiTcC7LcHAUo9gw2X4pqqsN/usLidLqx6S7q6xsIBnuIxQzC4QhWq87evfvxjh3H
2Kee5GpFNRd+9gHdl68CsI8uziidaBYtxzCMC/cC7/JYbS4Na/5EXk2jXhiJRl3Dhqay4IXv
MSP7aRTl9taCggL8pWVsiyVgl9s3LqSLw0ordrv9x6FQ6DcDpfJeYLtuwTv5YxzOePfHXcGu
maCQOCyVMRmZjExJxaJaaGtt4+DBT8jDzSTsXCBCMZ18rob6TNNcABx9UO3uUm0uLdU/wHNr
bnfx7SGJg0ptcYqhOxHdoYrVoYnVroui6mJHFwVNQDGBQ8Dor2Lc++9xwxojEWitXspoVcGn
0ll95BJLf1FLuhjm+NezePvkdcv+S4FIT1gYjVANHAYuPkpQd6X0bC7rTXgB6FXAA6xFwYuw
XCwswOQbirDliZ1kKl+W7d/WfY353OsMBfjWbpr7L7KM2WKyWBTCCvzqyZ387T+B/V/0L+bC
W2tds0/6AAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
homeIcon
	"Private - Generated method"
	^ Icons
			at: #'home'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self homeIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:33'!
homeIconContents
	"Private - Method generated with the content of the file /home/dgd/home.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHDklEQVRIic2WbXBUZxXHf8+9d1+y2WR3w5IQ
SOgmgIA2VECgUJuGIoJBapkBHKY6dFp1BMEPLVosY+WLWh2ZdkoHLP3QocN0SkY7CoJFQEBB
MLwk2YQEAqFJCCSbl33Nbu7u3nsfP2xgEiq+fHE8M3eemfuce35z7v885zzwPzbxsI1HYYkC
6wQEHuYjwQLSAtLW6Cqg14IOC05ehfC/Bc4HTwbeE7Bm8ee8uPJUslmLWNKgO6RT7LOjCEHG
sMhmLSLDBqoqyBqSrGFhGBY+n4OhcLpThZoG6HoocDo4XHAemLtlfRnLljoBOFOf4PSFBC+s
81NeagfAtCRvv9+Pv0jjuWcmAJCIw6kGky8vr+BA3U2OHOs+G4SnyP2JTwPnwB5FsKmsxElh
YW4rPmwSiZmUl9pRVXA5FfKcKh3dOjMCTtau9FHitxEJQ0OXytLqcgAsS/LTXzUQbAl/vQnq
PgWsyulVt3XtFJYs1kBA6w2dQ6fibHuxGLsmkEBs2OSN9waonGpngkfjdl+W3v4sNdVlLF8W
IJHI0tA8SPWSUrpuD/PyjgvNQXgsJzmo93Sz4M/Vs73OpxcqpFMG8WiWd34TYdMaD4phkU4Z
ZEYMDh6NUTXNwYpFLipKbVRVOshKN6u+Oh3TlPxsVyMNwRA1T5bhn+Ck45N4iexLBUPQBqAB
ZGFjoUPzLJupMPiJjlDgj006Cx+xkerLMCJACOgImYQHs6z4rJ1wt45QBNe7HSxfOw2Affuv
8Y0NGn6/jyPHuln7tQrWrA5wuXHwVeCj+0Bg02xPHof/GiOckSQNiGUkPb2Ci606Tk3gcQja
Iya10+z0XdNRhECKPMqeKiXfpfHxidt4vElWLYphCgfbXxuidnk5s2Z4CUwtmG91J+a0QFCt
gmqHovygRDfJT1lMzUAoK5mHoCIDJRko0CVtCQu3KegeMLh0x6DxTpZsgZvVayrouZPk98fa
eXNHFgUj97j9NDalmT3TSzJl0Hw1PNIPf1IUqHmsoICAaVI8mq4OFI0KbBtdDWABsABBDYKV
Ph/rnp+BaUrefreFva87UaV+v+KfXZbl+KkepJQ8sagEAc/VgKZImFeuafcdO4GAGN8P2qVk
+gPvqCqkdJKLgx918PL38/Fo45tKoRahqsrOlaYhiifmMb2ysCQM1RpgNo6M4Ha7MaUkbhio
isKglChAkc2GzGYpcblQAJtpYikKj68u42pbBKnGWDIrAVIZe74B2PxCHj/f1cP8z/t54vFJ
3LgV/4IGtN1KpQCsr6z0KN/eYCORFETjkqGIJBw2CfVDb1+c/v4skTgMDMHJX1xm7fpStr8U
wNIMkDIHlBKkBVhUuuB2bxcDgzqLFxSz/4P2uVoQfjwX9piwJTZs+1Hl1DzeOqxyN1lBYkTg
LbCjlEb4yYZLFHtACoW21JcomejA49FGO7iVO9djoAKJlBJXfojjp++wYK4fwKMBsgHuzoHg
pfowZv5iooZk5xtH2L17N1u3buXMycO092xj4mQN3bTjLyqnwOtAz5gMDSSJRXTiMZ1kIs3T
KwI5NpKbHRE6b8Wt7s6E+N0fOoWAa/erRcLVTMYikvHj8Wbp7OzE7XYzPDyMp2gKkU4/Vl4h
g4MW3jI/ll1l/6/PEn2/lYk2Gy5F4brdpOaZeaOZwocH6gHOmJbcISAwE+q0MRr3AAxE7eQX
ONm7dy/19fWcOHGCQCDAwkcmIp1e+iIxJuS5kEB7U4gVbvf9hlwwJR9LywMpicdSHKprBjjU
nJtA54OAco/WDBEgFY5DKiPYuXMnGzduZM+ePdTW1pKhEMtRRCgskIqJJSzirf3jxo3vM34s
AZYqOHm0DcuUSDg0tnIVxtudgcEMSd3A7XYTiUTwer34fD7chU6krZBY1MCyUoR6QxSmxh+D
yXP9WIxgSZ0Lp9sBWprh1lgfjfHW09sTnTF/wSy2b/smsWGNSCRCNBolv8COpTmxFJBSp725
h8n23DBuTSfxqTbmzc5HWkmkhCvnugAOPxB/PFBA/bu7/rJ0/YspXnlpKUPRDPvf+R4XG4d4
ZeujSEW9P0H7e4fxjHaoItVGVtGYNKUAgM4bYRKxNAKO/0tgE2yfY8qLH+67+NbRuubJ3321
hs3fmoeiqCAEEhM5WoFDoSTFqgrAJM1OS2YElzuXcbD+LsBIEv72IPBBDQnCb9MwKxbVd//y
hx9bzy/fx+Vz15FSx5JphMjpNtifxD0KBEjnq9xsHeTIwVYOf9AKcO4mpB+M/9BrIkAVzBfw
BvBk9cpKtrz2RS6d7WHV+tns3HyM8ps6Ybuka0Tnek+UTNq892lMwJYmOPBfAceAnxXwus2u
zvT584iFddK6MdalH7gC/B24kA9nzsPIP4v1HwEBakALw3ck1AroA1qAZqA5mAP+f9o/ACsL
HrLG8KKGAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
jumpIcon
	"Private - Generated method"
	^ Icons
			at: #'jump'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self jumpIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:34'!
jumpIconContents
	"Private - Method generated with the content of the file /home/dgd/jump.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACuElEQVRIie3WT2hcVRQG8N+dJtGkZiyiNpUs
0gZRqWhM1GihxU1BMLhx0UVFKiJqXAhuxJV0UxHcFCvuSjbqzo0LqxUXXWgFE5GAUmtTzWia
ltraZuwkk8kcFxOT+Zc0JSIU+sHl8c495/u++9479z5u4HpHuqbsfvdhQNIFwjRGjfnpvxXs
tzcl+9G7QsapCG8Z8+H6BAf0Jj7A7jUZ42jwilGnrl3wIbtSxhG0g2wr2zdxd1Z0tUu5v/ll
hvELzJarKwtR9qTvHVujSQzKpgGn04BID4vMgZ54v/hpTMR0XIx8vBEjIYYqY2pnpBdFGqgZ
pw3KNqPONA2WHESPTIo4+Ki333zXcOuQrTabVwKbbKwkb7lVvLZRPFtD0bPI0YANDZFH7BDe
gxi+Nw0//ZIDngMTpj1lv098bdb8cs3Mn2zOS5cwuRTt0+2oKblVV5gp21Px2FHs2LfdO55f
mtumyyEvN9qOyjuMPehswrWaYITHwWN3tj2TdrjFzTXzg+7Rrq22qFioXFuxrQnXaoKSLRAP
3GavJ0DO+aXpEV8qKC7nz12hkF8WqRL8l6saLQ2CS67Lsjqc8If7vWq3Pmf9Zay+xc5OIJbv
SysyriAYzki60/hFM0MFHzumZMFnRhur8xc4/1tNKE3UcdWh4ZGm5Btw/NzCifLvjjQTguIs
E6NE1equoEpwiasKDW0R3S6n8IKZUubHlpxCf6e8QuPKTh5nfq7W7GGqmyAyXq9vi8Y+nJLL
3KUHfZdGJ81tvclC72KTl+Y58zOT4yxUvazAF6SvqsQZie8cqqdvvpcOyqaSH9ADdt4u9nUS
uVqhikHpI5ysif4aLR70rctrE6SyeW/wuVhsxAy6KhbiDtKUyq5yTs1H6iqb99WPpzaHFe1a
NW8Z6zieqvG/HcCNwuv+xbiB6x//APor/zPsp+AoAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/22/2004 19:35'!
loadProjectIcon
	"Private - Generated method"
	^ Icons
			at: #'loadProject'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self loadProjectIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:31'!
loadProjectIconContents
	"Private - Method generated with the content of the file /home/dgd/loadProject.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGz0lEQVRIia2Ue3CUVxXAf/d+376TzeZB3oGQ
BgykpOQhD4sUMFIeLTpFKoq0RVBwRKodp1ZnWizSoTgWiuO0yNCBFoulaYUyUqnOAGGYQcCk
JjSmPBMCm3eyyZJsdr/v2+/6RyAWdNqBembOnHvnnHN/c8899wj+D1Iyd7nPiEVLRFyVIu2Y
QNSKHtnQ0FBl3B4rPg9o/KxvpUnL2IZgKSBvc8dQbI3qic83H9sd/dzACTMf+aZS/E7XZGDa
A5P6Tqc8GJOji7KJW3G7+WzQqq8esJvOTgQuIOUTH1dXnbxr4PgZS2ZIYVcX53vFr1dmiYLC
dDb0LeZwWzZL3LXsGZoGQLzpbLv51iZTWYZfU7Kk4URVy+1l+EwpL3/YK4W9Kz3gZNdTeaIg
0wmWSUWgCwmsGVVNgSsEgDZ2UqZrzctJCKHHhf06IO4YOOh1rAQKN383UyZ6JOgOzjgr+O35
Ig7lbMOjx3jA0zQSL5LT/XrlY63ArKIZix+6YyCI6VkpLntqcTJIjXPuEtY1zOJA9iskyTBY
Jve6O27JcExZMA6EgRDT7wJIeUmBRxyuy0VJBy1WGobSeOPifQSvZxAllZretFszpIbw+ltA
let3Acxwunyx37vnu+fZO/iqq4ajGWPY3jGP7SEgBLNHtbIl9Tij49dASIJmEs+keGVvpD/n
boB17zeYeYFZgbF2XKL1d7Mh+wOOdK3AsDVSnDF+M+bPiK5roBQABYBjsGcsij/ecUkVojbe
350ZsTVev1SKcnrpNnwYtgZAyHBhDUZBSGzhASFp7dPpCBlCCHVGu1Ngen7REIpV6npvS83E
ZYELwUSuDPipt3NHYuYmXcYRM1jUtJrgNRfP7ay7agyEXZqm/eSOb9h4/E/HlVCvxuuO5dnn
TvUf9Uxmr/HFEX+SwyDbe51oXKPbEeDN2o7gQPu1PFBPNxyrunhXk6a8/GHvoNd5AijVxk+5
6vj62jzh8jLKMcT+e3bijXQSDCkWbIkEjfaWHCGoajz+7qNwY7StLuMRJXkIRT4CTSiEAoFC
IhFCIWyQQiFu7hVohvBkhmVK+gVXuWX6MzsDuXn2NF9r9vmrA7KpIyKUsvuao9UfRu3eXmAd
NbSJNRWUuhMCtZXLniK/uJSEQACPz4fL40HTFJqEUF8XDoeL5OQAQmpIqWFEI7S3tPPm5p9x
6nx39XlXRQwoBWIgakHVXIwe0q3lzmcRTtjdvZsaVuhxuLdoSiULV60DFQZl3aJxy+DIoR0k
6W0kZkwmI3ccEybcg0tajCnwk146k3P/2ho5F79yBmhEUMM/2ANABW9xv4CCIjhtLqCmH10q
RhWUTAXV918wy4yx/pmneWLmRcblCqpO9lFSMQ2UweXWII9v2sqJ/kvwZGA+Y5iPLwZrh+rh
BhDSkDoE0iEvmA796Eqge7wJYJusf/UIORnpgAKlSPZFeGHzRvZsW8ulvhQamkJ8w+8G22TZ
Cy/x9+/0wugkSEwGXzJ0toBzyDPcWXhxi2JkHIHAHdUYAnTAoTkcoExyM9JYuqBypBvfeX8f
KJOyOd+jeGIBc5eYCIZvr1IdUDkVxCca/Uoz+EijnH1olPGD5Ezcktn2JI7V/y0GoKOQUgLK
INjZy4naj/5zgIqDMiiemA/KQAoLw4xSf6mJOTkFnLoUxl+YQZjIcLxHwcbEZAzrUZwm+DWS
s0pJOhXBDkWrbwKv9/d0gW3y/UX5GGYPqDidnT18eXYW2CYoi/BAmGX7ttHS2UdSkptUzYn3
tR4SNo1hEVP5A0ehcArETbBMnA4vX9EqmHglhS2/+CkotgNIBX2hjjZQFtlpLhyxMNXLn2dg
8XreXfQcweYgKBO/10EkFmXD/QtZNrqMjyJBVicU0nq8ERubFVTCgavI/e1k/dPNjJNZnN74
Di8t+XFEDZg/opb9ALqUhMI97cMzQBkc2X6Axxs7h0v0cTd7X/uAb/9yMZve3s/5riAH62q4
3N1Jjt/P175UzNuvvMfecYdx44AXz2LbalebXV/fJhHYNKKo4UO6br6STpxQf087oIFtMveH
C3jjbDP+5i7C+anMWz0bbJMnF85h/n1foDArhQS3Nvx19FR+Ps3NuqUvR6M+3Y2lDlLLyuE2
/9+ixwV9ofarKC0bYQ+RkZ3FYwd/xWAkhs/rBWWDiuH1DTF5XALYQ6BMEE7wTMLbe5QHB61n
/xKx6vBz9NNgAGLldFI0g/bRRWWOxJR0IuEQcctE0x1ITUfT9OG1/om1pg+rlJz5674hO24V
7aih5dNAI0CAVWWUS0kF4FUKTQjkTYu6oQIbRfx2a+u8t/M0TZ/BGZF/A2P54ZZvw1VGAAAA
AElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
objectCatalogIcon
	"Private - Generated method"
	^ Icons
			at: #'objectCatalog'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self objectCatalogIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
objectCatalogIconContents
	"Private - Method generated with the content of the file /home/dgd/objectCatalog.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAD5klEQVR4nN2VW2wUVRjH/+ecmdmd7c7e2qVb
uu1ulrZWoNUURYILSiKoBcRIN+gLUUKMifLiAzHEhHcVtInaxJQYY0g0Jo1CEBXaKBA3RhMp
0Ai10NpUbO32uu3u7GXO8QF6o7NLL5FE/8nJZL75n+/3zZn5zgH+S6r0s+cAVN4z4NqQfLE6
KLcDkBY6hy6D56oOSIVHDjjvC/hYI4BCACW3rznFlgh7oNTL3n5jr7ZuZ1i1MEYq/F62v6pc
fnV4nNfHE6J5iXnnyVnooH++/oI22P5psRBR/5yxdb21D0BFvgSLXdIxVSGHO25k9LLiuYtz
/NtEouN6+n0AXfkSzHzsNRE75ExRTienWVxq6euLGc19MeP8roND35xr8ganHrsd1AKA363i
GSDVG2pDgffKfN6kmTF68aoxDPhv317jQowCwMnzyURPvyEatqgFTo3tuTnE37ob9JZqdr7Y
9PkpMT4RNx2hp1/unm3fsFZpPxCxDwRLpEbNxp6tKpdaHQUkBsC6sDdcpG7GjJ4vziYP9Y8Y
pwAg3osvARAA4l8B9vYbu0zCeWHA8hp/SbrnwDlLeibanh4ajRtmxoSeUhaa1PMIHGlJeYJJ
dLshcHzinN42H8jR1tIa3dPSGjXPIpDIB7FvUlYTTupLKtyRVXUrHpKLJUrdDD80XrEDmAaS
hVadT1rYuu+x5+8/pvgtSExQ9FwbQurvNIrXSPijc0D/6/q4C6eRmvuGJrIBz/goi1AC5yBw
cswwPgaQvdPHCf/F7rEi2taD0Stjv/E0PyEovqMZ7ROtzuqfaNefiiP9VT6WJUDY94cs2shl
rVh0OXziQ9WdCFGpA8BKEz999HBVMniwUGhh676poD2svFnzUalw7bC1TMVMj6dyyj44qrq2
v2a121dQBg+heFhS5K2Sxfu1kdo4KvixO6aIuKJvKQ97QrFL8f50yDirlVqaJI1FhMxdkkZC
cZo6gj5kTdvCAbptt6LO26JWMxkPMjmAmT31ln+TpYnIvC4ukiAE6zVDXaf4pP361UzAVqtA
rVIsdkmpB8z7ULESknM/rCFygQRUT8M2WyrBySt6Z9YtNAHZy2pJlg/wDM+4nrRh4tcURs4k
khDEB5j/NOlRYeQ8Zi6LzGQW6Jyuzkj1Z51qrGhzQVHyRgaGLiih3GWM8HBiiG8EEQOqLX1i
+AImgRxtUUZZ87tW597dik2eHe/iWWybHPyp2zA2zI67HrcGeUbsAEU3Eakfxy5gJFfBuaSW
E/bzO6pzvNdRImLOleIzmye1irLfAQQXm2y28jU+8TD2khukQQDapOCnBzg/CkBfDvD/r38A
0MR5I7Mls/AAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
objectsIcon
	"Private - Generated method"
	^ Icons
			at: #'objects'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self objectsIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
objectsIconContents
	"Private - Method generated with the content of the file /home/dgd/objects.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADhElEQVR4nMWWW0wcVRzGv3POXHZhZdldoAud
RkzRQFsaxBpTNcUtIMZaTdoQBa+tsYRYS2mjD/riiyY2pkL6JulTaUgkaayJ8aUoohgfWlOl
GiNqTY1chr1Bmc7uzuX40E4i7A7Nsqt+yTzM+X///++cyXeSAf5n1Ycp+2gDoVcrCVUVwr4s
BXvxXyEFKO0NE5o8UxK05/zVXPdv5JO+Kr5bkBcrCZkAIBUNJgHbFcKSCX8N5+VK1nNYLtVC
oIPFYBEAqCbsq6GSwMN7RE9Ok845apdmr6vc3gxgoRAgBYA0+NZ2UXY1eQlBq+CxBKC5EJgD
FEWASjcP66o6yrwcUIoBNGxAi3J7TePXVlqjwFQxgCAE50+klnQ30xXLwPec2xsU5bZAr4Su
ynJ62Zm9WgwANM4//9k2D4Qo8TUzaYXxJ8vAXi26aFZv6tnSsr/zrsad2tWpb/9yA4Yr2ECk
WW5Sk7ag6Xx8rc2Fqwgbq6dC8nXZd+N9r998XPDEA4SqAtDumNq6+59q7e5/s6OzP5jrALU1
bMacVPj2OnEBwJbVhqykSMBWC2iWgJABfGcCFwHc+Kdn76FDJfpyaQ/n9sLYyOBZAPxWaf/B
J0o/PP1WIPjLNRN7jkdVRolOCBBdtMr0NHl17WjeRq1PH7snOj99LDE9ETRSyzt3NEieD476
KzZvFFb4/pg18eAr6rXZmL2tICAAhMrZ5P310gMfnwgyWcweZ1rAfS/Nx3741egAcClnkvJR
LGlFLk+nhx49Ek2qieyrNXR+2fhz3joN4BLgEt08lZmL2b0/zvgOtPUltNXFhlpR9HrJJue9
GEB0dr4tNbU935hOm1Fn7crvBgyTY1eTDNjY7bAE1yl5KC4lj1siTlGCl1MZjoPvJBa/uJie
ppTXtNzrkcMV9I6ZqLULwHjBsNauvp727iN3A4BSxeYb7hRioTJ6+FaZAHiopoINl/uEiLOw
QuGWF0ZlWWxyA+ipzG/qxJnHACDyXN+TDGTpwvDAOABUBdk5NW69i5t3N6eyPiljdNvUuYE6
t4bGfUcBAO3P9O+wLbvswsjAJ05NjVv73PocrSs0jzz7msKJHRkbGRzOtzd/IAdlnPYGzJmT
efeuB0gAJhH7vdHRUes/AXIC47Ozp5bWA1sXsFBlpTRjWJmuN07OuTVoeqq4wIV4rOPTb67n
/l8EAN3OFAL8G3xJPtRdAsoRAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:10'!
openIconContents
	"Private - Method generated with the content of the file /home/dgd/open.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGO0lEQVRIieWWW0wc5xXHf9/MzuwNFnNbYLFJ
ggFjgs1l1yYhqTExdlKlbpVA7FiK08qt3SqqJSt5cCu/9MVSq0qtKiupZNLkIU2bKoG0TsCY
RtTGhYLDGjvBxlAcQ1i8G67mzt5m+jDLxU6jKm3y1CMdndGMvu93/uc78+nA/4UdzcEM8DOQ
Dm9j2xE3+YD4OljiSCmnEPwYWATmEtPSUmVZZmzk9hzwV0nibVWm4VQnM18FUHZncNSW4Mjd
5PEo0xMTdmtcHAeOH2fnMzWqSVE2j/tGqhcXgy+6XTzkycD80AaGPxxh8b9WeNjNzwvKyo4f
e/lldF2nu6WF906fxpGcTM2xY7iys+lpb6ezsZGPWlsJh0IRBBfQqTNJvPvKhwS+lEKPC6ce
DVXv2rmAQCcjv4yKmn0oqsrvTpzA/0kfj3znacr37qVy/36cWVnS0vx89mQg8KSm6S+Wutjj
ySShOA1/d4Dp/6jwRx4KNZ2PT9W9gMooyDZIehxsm7h98ya/+uER8rcm84MTz4N1o+FCZWp0
lEtNTXQ2NjIyMGBsBl4N6pCpq71E/79V+K08JmdD/GTbrnLZ4ZAAHRb7IDxJfGYZkXCEno7L
PLbHCQt9MNMBwUGsFsgpLadi30FKKiux2O1M+P2u4Pz8LqFz1O3iGU8GE14/1+4Cnh9Ec7uo
ydq8OT0rOwEkFYQK0Rmw5ZGceT/v177Ojic9mG12EApE5iA4BDNdsHADR4JCwcM7qXruMLml
pUiyzJjP54yEwzUeF0VuF/VePxqADODOoNwSt66o9JEcAyYpxsamdVgTs7h64QIfdfyTnC3Z
2BMcse8qyCpoYQjdhrkriIUeUtITKK56mh3VzzLc38+Yz7cZnSWvn4srwFIXGxdnF/ZU7Xvc
OIlloK6BZQMFZWXc7LnBO789Q2BkBmucg+SMVISkGhVZdqIQDMBcN6oSpuypF+g8e5aFmRmH
10/tCnB7JmJxfv5Q1YFqFAUDJimgB0EyY0vMxLN7D+6qKob7B2n64wd8UN/JZ7dnQTaTlJaC
rFiMNZIaK/sdhKOUqdEx+q9cDXUHqAXChsIMAsBLuSVFijMzBSQTCJMRI1MQnQWixCWmsmXH
LnY/9zybPG6mJ6dpfa+Nd2qbCYUk8orzYqoVY73lPob7b9HTeSl4JWC+DNGADOD1o7ldVKhm
68aiRz0g5FWokEEPQ2TaOKvwOESXSEhNJW9bBTtqnmXrNx7l3Jv1jPnv8OD2wliJFTC7+LR/
kI/b2pe6A+YGUGVpuV11ON/V8neiugUk66rLNpBsqxEgMgkLAzDbBUtDrM/bxLFXTtPd1sut
vnGQ40COB0BRVQSYjIWaZRWo87el+XkG+3wgWe52eTnem4jFgIfGiE9KYvfB79LacAkkO8h2
QKBYLAhh9AogrQBfvUwnMNjRdH71X5TMhosYUHxBApEp0DXK936bXu91giHJgCKhqCoIlBhG
WwEaVeW1tjPvc2d8brXVhXlN639BApLRlWarle1PfBPvhStGIkIgm0xIKyWVgmuBaCZej0Yi
wT/88jdomrz6e4hlxWsTMN+dgLYIukbl/v10NLUa71cqufwQDt0FfLUTn65z4Grrxeipl36K
b+BTAypMsbg2AeXzFdDmSXQ6cSSnMDoyDmJle6HKyCCCMvfYZT833C56x3y+na3179oHr90g
dcN9JKZnGLeQEIBkbLbsyLGog1BJTE+nz9tN9pYtBIaG6Wpu5vqYqT4UFUPSvUCA017eBnLR
+XVPe3vkF4e+z8mD36PhtTcY+cQXK+Ma5ctXoTCBHuKBwkJ0YonFzCJjAvnzCpfN6yfo9XOu
bD21IY1r45+N09/V5bxYV2f9R0Mj47cDKGYr65wZSLJpVTWAkNB1QVJ6OoHBIbqamxmYMP15
Lqz2funJrLqAMllIT5lNeqVF1otUs2p+oLCQnOJicktLyN66FYvNhhbVAGg7c4bfnzzJ2ZuW
Q8N3lv70P42CrnhSHkyRn7CpekWcqhdZFD1fkaX49Xl55JaUkJWfT8tbb3Hreu/Cm1etBxej
i3/5KmdPO5jTi9J0jzNOe3idJVpgNbEhojE1OCWfa/eZLsJSy9cy7AIy2FMAJ2gOkOZBvQVT
0/8ClPo3sCGCJrEAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
paintIcon
	"Private - Generated method"
	^ Icons
			at: #'paint'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self paintIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
paintIconContents
	"Private - Method generated with the content of the file /home/dgd/paint.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAEK0lEQVR4nLXWW2xUdRoA8N85M53O2Av0Rgus
tJZCKASvUO+E3aBFN7IbWGNMdqMmPGlMdC/ZGB/U+GI0IfqiPigvGLImXtaYdReMAomu2TXB
FYGFRSUVSgstCKWdGTpzztmHKaQhiEaHLzk5+V++/M53/l9yTsqlibCHNS3kTjB8iYxKLKS1
my39c7JJX0Mm6eHFS+mF3ezYsLY7GXru2uTdh/qSK3PppJtl5zZUU5vPH3ovz65Yv34Nde2S
oMb1S2fBLVUHu+jC0w+t7aT9GtGZgiihrSUnYEnVwRRPLOnM1d7y81uJI6WxEyKhQqEMcVXB
Lhbhdw+u6WB2H2PfiGLKAvliCSarCqb4/fzZtambbr2e2kbGBsRxIBIaz5fgZNXAn5HDPf3L
ZjL3hsrkVIURJvJlAfurBmZYi8Zf9V9FXQeTp5k4WqkwCAwcGRezr2pgwAOLO3Nm9VxZmRjZ
DaKEdFA2li9FuWqB3czDL1Yvm0HTwilwVwWMA/l8Hv69h/GqgAH3Ibhz5aJKs0wMkx8Bcczg
0VMCtk7P+amv9N7u2bVauhZXRsd2nVuIksCufcclvF8V8Ao60XtTbz2N84hKjHxxbr1Yju3+
6tuxy/lXVcCQ1XDj4gZSGY7upFw4t35gaFyS2Lad8vS89I8FcUcQkCSJ/25/22XRqHmtKUFA
HLFt1yi8d4EH/dHRPP/qa3zWer+O324ycPUz/rS9x9YvSg6PTvpk38lCwuvnJ12wwn76WlmX
ITvI5q3nncNUDDe3t+vu7dXU3KwUxxb03ezz44u8smmjhDe/5tT3gneycCn/XEUqwB4eDvnN
P3jrvK3RgZ07fdLRJB1N+vqbQUE6LYoiA0fGinjhQsUEsJ7NXdz2Hx45zYcd/HUWc7NkM9Tt
5tPXWXE2qYdHc3W1G5bd2CXbkBEFjAyfduxI4tihwxNxFN31FdsuBKYRNLJ0Di37WXiKkSFe
Ha6c7ztbGOrnqrMJK0kf4vFV110hW5NRnqQcJrJtDUYPHRZH0RvfhZ0Fkw0sXUl9LS+sYktW
5QO2k+dv574t0w7/NEEYBE1zk6xykVKqApbDREdTncFD39Z9F8a0Lt3OeEDbBzz5N/5yBvdS
28Lm1dwNS6g/yfI4STaOHJ/QnE9pyodmFkKNxVAuDqH4g8DbWTHCuq08FfPnUVyGXxPW8NrN
/LHIwTDwcYqP3th7YHjGRKgtn9IydR05Oibg04uB07s03cqX/eyYw7XLpyZbsIbMOzy7sr3b
L8MOj536/OVEkJ03lnGmJlFIx947M+TgyMn/Zdl4MTCYPuhndT0vddLVgAbUIYMU/p6qiR+Z
sTxcUMgp1sSOZUt2ZE54+8SAwfzEjjQP7OfgDwbhScKPmR/SENIQVe71CTPRdpzriql0thCV
UzgcVH7lN33J3otBZ+P/SNx4XWnWkNMAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
projectIcon
	"Private - Generated method"
	^ Icons
			at: #'project'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self projectIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:21'!
projectIconContents
	"Private - Method generated with the content of the file /home/dgd/project.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAF3ElEQVRIid2Va2xcRxXHfzN37j7sZBs77+A8
nIcTu25M4jYRKU0qqMqjIlLNoxQhERFUoKhfKJACElQBqRRqHq1SIqcQ2hKwKKkEaYhkpaZp
aFJqgwN2E9dJGtO4iet4d+3dtb2Pe+fw4a7Xtkz7BVVCHOlo5s49M/9z/uecGfh/FzX9455G
yrSiXixVaMIihEQIKQgpRVggJMW5Cv45QAEooPFK82kqUEDRe6CD04AogN2bWOloDgI7AP0u
BdcDbDUARnNYoDFSHmNtw828Z+0NlMUqKI9VUharoCxWQSRaRigaIRQO4YZdXNfgGE0oEkEp
hVgP6xew1kesw1hqjPjQEK91nKS99VHGUol64AYDKIEN6zZv56v729HagmRAJkCKLEkB8EH8
4loOxHL3p79IU9NH+OQnPowSH40N7LQlfJ1PZcyyrn43S6prOfDNuxBNRN97E1VAeXX9VrTO
gVwBSYKMAxMg+QBEioBF4EQiwebqFO1HDzEwcHWaQ/5M20I/y1bXAaA9xOR9VmkFK2o3Mzh0
iWMv9YAIYAMtzufHIuzcvgYRj47OHlp+fpAH7hxj4TxNc/MDaMfl5N9Heeihr7OlsWYK0Eug
nQUA+AoxgAuwdNV6evsH6LmY5oNbG2Zl/BeHn+Oj25bTeFMT9zU5/PBzUBkzAOzdVaD3jSzj
1LGlcV2RdltKgXYCO60Q42gcEQiFwyCWmhVLuWVz7SzA1j+1YRz43W8fofnhR9i4Zpgtsan/
P302yqP7vjKNTlsajUMJUGNxAIxrQOw7VLWA+KxfV8X+lmaeen4uACOZYE/j2hy9ff+akedJ
1Y5Mo1SjETDGLQK+QxsWD9Mq8LrliKWjfxmxckV+7C0u/uYIG7//pSJQsWLF4mg7VTRYHBQ4
rhMYvB2gyAzPz/YXeP8HPsWBPTsAn1w2RyKZmk2p+EGrTUZoNUoJgGXenBBtp05zqqsroHCS
SmBORIrtERzU9tyPZ9AXDmmWLp5LNpflr+fO4xrYVrs6ACwmUSvEiCWjFIynR3hvzUIO/+CO
GQm3vsebb76F5xUo5HO4RpeoQnzyXp7O3vO82H2WVwsDxMMZoouiDHfGObHhfsDHcSJTgMAo
QGYkwcKFZTMO+/2vj3HoR63U5yyuQLcRtn9mB/ft+XgpR9892Mr5qkHGygyXX08ydnWCBRUT
pBel6ekfoH7lIpQbKVGqHUsKIJOMM/36On7sFF0PPs2zw5bvpeE7GXhmRGGe+DO/3HekdPvc
tqmOnO/RdaiHPbXbeOn+e9ld20jsuihPnjgNMi1CD9HKBhGmkvEZV9jTza08OKFnvl/Al/MO
xw+dKDl38/VriF9K48+3fOjGWlwHfN9n6G8p/ni1G98voJypCE22klQoDaPDw0F9TBZCtoA7
Cy4QnQ8c832PJ9teZPSNMaKrXF4+d4GW9r9w8pWLVN5Rhh8TjnedZ8etuVIO9a9eIAvk08lr
oCIlz2vet4EXlD8LrNd6VKxfAuLT2XeRr/3sGYYSKcIrDC+fe53qigoiqw1eyiL/EK6MeGQz
qdJ+UxxT6eS1BahIidJv7P0s97x6ie6zg9yZ04SV4nntcbh6Dk88tgvEp275YlZdX0ly/jjm
jEOoRvOTL+zk7tc2EjGahtWLccobuJpIzahSgNFM8toC9JxSr7kuHPzDt2k71sn+ox3kJnI0
3lpH611bcTSAz9yoobv5W4xkMswrD5daaduGqqnWMksYvHQOACt4pQiHBi5QYDFuWMBPgR0H
fG7/2E5u39kEyp1SscE7abMgOeaFcyBZsLngsVYmsAsth2gD/zz5OEAuPEqfKV4mg/Er/Ty8
6xZW1t2I7xVIxQfJjAyDUjjGxXFMMBoX/TbzSRttJtc68fKtnD76FAKdj10gFwAqWoDbLved
cS/3nfmPlflfyriCvQFUUT6/iWWOoU4Ly7A4aLS1aA0KhRZQCBpdHAUNuKKYfMRLqgQPRRJF
EiHhOrTve4X4uxHJ/578G1jL6Ak/aE7qAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
publishIcon
	"Private - Generated method"
	^ Icons
			at: #'publish'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self publishIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:26'!
publishIconContents
	"Private - Method generated with the content of the file /home/dgd/publish.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHJElEQVRIia2Ua2wU1xXHf/fOzK696/Uav7Fx
bIyhEIwDxgQETRojcEPd8gFCmwgRSKkKCh+oqFqllZJQWpK26iMvBAFUSkjSgEMaKESURsTm
EV7BaXEcnsbGxvb6xa5f693Zmbn9YENcR02x1CMd3TM6d+7/nv//3CP4P1hR2QqvGY0UCVvN
QDpRgagWXbK2trbCHLlX/M/TiimghyauEx2ZmvTIE6nSMl9G8DggR6SjKP4Y0X2/aKj8c+Te
AGeyG7/rSSwnTL/1G/LZTAU2wJSHl3xPKV7TNZk05xvTQueSvxmV903OwrZsp6Gm2bpY1efU
19wPXEPKVZerKk5/NeBMSoFjbJ2DPj0Na8812HnlBJb67iT3sgIpnKqpeR7x29VjRX5BOptC
SznSmsWyuGr2DMwBwK6vCcTeeTGmLDNRU7Ko9mRF40gaYCYTKGYV8ApSkF04gaPGr5jy/VLY
Oe8hUuPOWqrnzfQkF7s25Ij8TBdYMUqSOpDA2rQq8t1BALTx0zLda1/yI4RuC2c3IL6osIR5
KJ6hJKU8ZUmhiGTrDOQYOIk68bgoYwa1NHK99Qba09UcWLqM8lnpoBuc98zl2cuz2Zu5Db9r
gFdvf5tdoeK7R8fO/O2a9Y/dE1Es1gAoZhVx2vsLdjz9tcmrS8Wt3D56PJ2o/gCYYSxPAldo
5jZ94DNQhQnIQ/UsmX0/V+IfYM3nZRwZ9woJohcch7BI5mjfxLuAWlZBinViv4kQTToPkoLN
liUvrZfNhYqzgb3QchV64qHNDZMikJIz+KdtQVsdXO/mRvs4lDRotFIxlcYb1x+gPOM6KT6L
C7dT/1MmqSE8iY0q3D1Tx2KRGOf1+EpyOHt1MwRNeIEBWvr2oPqy+b23nEgvhNqg/SZ8Ek/S
Llt517wucD5gofsCH2Xksq3tUbYFgSCUprXwh5Tj3GffAiFpjvl5Jtkjb4e7s3VAL1o0j0+p
g3AIdhnQai/mEz6khMc4K8tJPAmtibDVUr52byAzrSwaTivMc+wjaN2dbMr6O8c6nsJ0NJJd
UX6XewjRcQuUAiAfMPq7xqP4i0RwMzjQTQ03wTsGdBsUPQAYHGZ/bwMbRTXPBX9ER+y+LPfs
vfT2ZIQdjd11M1AuD52mF9MZbIeg6cbqj4CQOCIehKQlpNMWNIUQ6rxOPscbq690Q5qfxDSY
Y8IZ8+vAOU4zAEwAy7krx8POX5US680Ptt98bfG63NqabLITvxhCCrhpppFhxlh6czXzw9Xs
33ewCUiTmnZIUoHNpdBbfNwO0X7IVaCYO0xyZ1jMpePvHVdCbbX/VZnjXDnb/VH8dN42Z93N
+w2TLE8vEVuj00jireq25r7ArRxQP62trLg+yEMqpzkeWEG87qMyAs3Wblo49aWhMGR5qQWV
MUMrt2s/zlOBhiYxsdgvdIM0Y4CDE3bg6Wsl1BvmzS2HmmOfn8kWgorLJ977CQyNtjXFLOkQ
PHEJZvnAnAZt2iA/EokQCuGAFApx59tGavVGYWaLXpCupLTxJbcljctx5nhbsq429cn6trBA
iZCj+PGVk+/uunNZsbaEGXEJSdULlm8gb+p0EvyJxHu9uOPj0KRC0xyCwU4Ml8GYpCSElEip
YUYGCDR1smXz85xqklW3tbFRYAYQBVEN6oKmye21lRWB4ezoNhROfnAB5avXgQqCssCJgRp0
24py7PB2/EYAX8Y0MrLzmTI5FzcxcvPG8MjCckJbnz224wKb/psEw01KRVp+0WxQoS+BWbEo
z/3s58wee4rvTL9BR/0pMjKSh/ZYEGvBcLmQIxrrq0xXAj3ekwDK4vmtlWRnpA89WMUYTy+b
f72RPS9voC6URG19iMf8cYNgQ5dyuXWUGgUgYGiGASrGuIw0Hv/WwrvJdw+/DU6M4vkrmTol
j7KlMQTWEOCgu9wSJVD3DqiQUgLKorm9i5PVnw1L26Aspk4ZDyqGFBZmLMLFugYy/PHkpCag
G8boKEXR293VAcrih4vHY8Y6QVm0t3fyUOnYu5X09PWyfN8WGtu78fvjyHS72Ld8BZruG1WF
UkEo2NYKyiYrNQ4j2kvVil/St3QT+xdvpLmhGZRFoscgHI2waW4Zy3Om8WlPM+3BIFL3jkpD
KSXBnq4AKAkqxrFtB1h5qZ35A4qVl7uo+tOHoGK8WPE+VztaOHjxn7xz/gLZjo+6QBemaY2S
Uptgd1cA0EBZlK0r543P6kms76AnL4VH15SCslhfXsqiokkUjE0iIU4b7FIthcrK0OiaxhaE
goEmlDYW4QyQkZXFkwc20x+O4PXEg3LAieDxeJk+MQGcAVAmCBd4iqmveRUBXfcMqNzc6myp
j73wVLnhS04n3BPEtmJouoHUdDRNH4z1YbGmD7o8z/mjeweUovJeAQXAD4qZKSUlgEcpNCGQ
d1bUkAscFPbI1dE5sPMc9fcK+G+8HDQjZjwS2gAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/10/2006 13:56'!
smallAuthoringToolsIcon
	"Private - Generated method"
	^ Icons
			at: #'smallAuthoringTools'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallAuthoringToolsIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/10/2006 13:56'!
smallAuthoringToolsIconContents
	"Private - Method generated with the content of the file /home/dgd/smallAuthoringTools.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0
RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAIDSURBVDiNpZM/aFNxEMc/v5fk
aWJrFJoY0iriM6KCODloF0HUQUtFCgbEQZTSsSChnaIOLqXQOlRw1CGgQwVJ/VcDlRgaMSDP
Dm2CMZDSajWIMU2IrXnnVhIMtuLBLcd973v35XtKRPif0P4VoJTaopQ6s1YQkQ1n21YuPLh+
uDwR9ghwU0Swb5C1JeC3jyfunjq5r+Ujb2YFwK2U2rQuK+ANnvB/+Pb8nMi4Rx7d2L/q3aYP
AbtFZP0Terv3ZgpPu2UpckDCl/Z8Bi4CrWsEfwNrmtZ/e2RY7t86b+1s2xwFjgK2hg2bAXVd
H/H5fDPt7e3vQ6FQDQgCnma9f4io6/qVyL1If8AIkM6myWQzAvhF5GtTgeuNpJQ6NDo8anad
7lKVaoVSpUTxR5H5xXnG7oxlTdPsE5GX9QPsdeDW3qu9r3rO9qiVXysAaJqGruv4dvgYHBg0
5tJzk06n82G1Wr0sIhWoc2Lnsc7H4Wvh7Q6Ho6kXRATDMHC5XAeBjoYNvF5vaPrF9HF3q5vK
zwoAllgsl5cploqYMybxeLycSqXelUqlCLCwNkApdSQWjQ0ZuwwK3wvkF/PkP+WZik+RSCS+
mKaZrNVqk0AMyItIuUEDl8sVtDlsRKIRos+iVjKZzOVyudfABPAWWBCR1aZ3AQro0DRtwLKs
KvAEmAWWZIN//hsvzWIyGWZzGQAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallBackIcon
	"Private - Generated method"
	^ Icons
			at: #'smallBack'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallBackIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:37'!
smallBackIconContents
	"Private - Method generated with the content of the file /home/dgd/smallBack.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABqklEQVQ4jb3Sv0uUARgH8M9792bHmZRJJYIt
tghFeW8HJSGBhNDY0tAQKbRWUA1tTg5lf0AtTREaERWEEE1BDRZEtQSZS3CdyqXe+eP03rfh
BClJsKAvPNPzfL/Pry//iPQfM0edsk9GwdTWJPNa5TwUSUQqcg5sVh781rVf4pa2bLNLnQx9
4Ef1O0YQowENEnMY885YXeCkUNkdiQvh2Q7DV4ZdC++p3n7PyCRhiu1pGkN2hNQSvsxXBfoC
kSweCYO+XYMn9PedN6HgsTcahLp1yunQKCMWKykbjV+Z6h1lfuV+IHITV904pPXMEQWlDXu2
aNJuD5hQMGeB0y8oLn0O0QYOZzeSi19ZmDWzWjWzuoKEVJp0yMIq1NLavMaAWiVjf4nG5npB
ucTEWxbnWK6wsrQWy1RSPFkk8bF+xC49Up673Jx1sMzOvVRK1DI8qFKMmY6ZrrIcr0+YuL7+
xi69Up4Z2J1xbJa4xngLd2cIDIp9E9iGUGJJYFKTl7/u3KVHpOhiNvG0KXE8SEQ+bWakjchr
Fxlfc2Is59zWBOoI5HXLy/8N+f/iJ/5OkGsa/+A/AAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallCancelIcon
	"Private - Generated method"
	^ Icons
			at: #'smallCancel'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCancelIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallCancelIconContents
	"Private - Method generated with the content of the file /home/dgd/smallCancel.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACC0lEQVR4nK2RX0hTYRjGf+d85882bWZMESIC
CSHOaYu6TIksRwRCXhgUOLqWsn9IlFAQ3YRSoFTQWEFGeFUXBd4FQVC3zrrJIOgiglzTOd12
tp23myY6XBfRe/XxPt/zvs/3++B/Vgx27oXdjfQ9EI5C+8aeXjs4kDhu8zVu8dmFvi2Gdx01
WThh892F85vELohctPHKvTFZfvVUxrYHSg4cqekuREe3mdnl6UnxBnrkWgDfgRiAAaCBlfOp
+Ok5U31ZYHTmiVUaTMzqK+W4D8X+sPnm6nSySfM89A/v+eWDArUpxT44fM6i6LUhK8k7svTy
sYwEVeFmi1VYev1McjMPpdyhZMTGdyBR82kbhzjQe8xmdqJFswr3pvA1DVpb0TMZAlcucDnr
+289hubhecOfcKHvko1X7VCSn7olq+PXpdSuy7BFxYVT9feN+oYG5i6FplerlMduoGmgTKhA
WYdvDTf/eUL//RAVaUN+NCPzBpJWSCaMFCLIWZN8FA40ij7wqIlqzZw2kCGDwoRNNa2QbBjJ
R5CEyVIU3PrNh1IbzPMGcsZgzYFuB05PBvDTClluQXIRZNBg8SCE1hlo0OoY6ItF+FmE21D4
WCH+Cd4BJIsErCAp8midYehU7JirEALW1lOcVKReNCODilUHurfgMzweQB4EkRjc3ZJDFHpc
iP4F8v6GEP+1fgOfrL0AYYB91QAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'!
smallCenteredIcon
	"Private - Generated method"
	^ Icons
			at: #'smallCentered'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCenteredIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'!
smallCenteredIconContents
	"Private - Method generated with the content of the file /home/dgd/smallCentered.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADNElEQVR4nHWT3U+bZRjGf8/bt+WjtNBC27e0
UFAyHZXpVnSKa2aWmbBlGyZ+m8XsQGEHSuKR/4dnoskO8CNZYswkWRyJmdMxjRnRNTi3FEpH
W/rdl0FbWmjfxwPYznaf3cmdX3Ld13UJnjCnTn3asqU0fCYVnyGlT0jplwIf0COl/PLm3MxN
ABUgfHbyCIJ3QQTtHdZ+l8vpt1vbHHa7lU67HbvNhs3Wga3DSj6X5dL3cyFgGECE37j4UqvZ
vDD98Xvq0IFnMVnaqdYNKvUmlZpBfdegYUiaTUnDgDOhTs58MC0tlbJtfn62otJk+Kkhnxp8
PsTDSoOd8g6lkk4hX6SglygVi+ilErV6DZPJzMlDU/i8bhFPGgeB26pQDKvH5UTXdS7NXkZR
FBxOB06Hkx6nk6HBAJ1dDiyWVhqGxJAw4NdIJNNB4LaKpIyAfm83n392EUNKarVd0tkc6+kc
0fv/kcnlqFa3+WTyAvY2E4E+L7/9+ffw/hNNerVao8WigJB8d3mO5HoGzeNC87g5FDzAxHiY
Pk8XZlUAEPBrgAjuA4yNSrWGxSRAwoX3z2FIyWa5SjaXp1DIc/1GlOR6lq1KlfNvjhPo8/LI
BVUKCg83y6gmwbXrf7Dw1x12dxt02q3093rw97p59cUR/L0n6bC2AbBdqyOEGAidnWxXq4aM
Z3JFAF4bO8Lrx4/SalEBSTpX5EEizZ1/l7ly7XeOv3KYl0PP0dbagrvHITLFjYPq4txMNXxu
KlMo6pq7xwnAtz/8TOTuMpq7m4Bf4+lBHyfCo7i6ux4nNeDXyOT0YXVvFbH1TF7zuPYA598a
f3wopSSVzrN0b4WVeJLVtTTTH72Dz+tCUe4G9wEylsrkxw6PPMNaKks0tsbyapJ4Ik2z2cSn
uRka9HPs6At8+PZpLBYz+sYWEtr3AJJYKl2g2TS4+sstAj6NE8dGGejzYjIpJNZzRGMJfl1Y
5OtvrhBdTaJvbKaFkF+pAEIoi/8s3SeVyTM2OsJKPMmPV2+wHE+y+iAl6zs7KxIRARlBKBFD
GJFbP83EACkeaQ1PTH2BZAKIg4yAEpHCiLRvby/Nz89WnlT7/wF5FV54cVgUugAAAABJRU5E
rkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallConfigurationIcon
	"Private - Generated method"
	^ Icons
			at: #'smallConfiguration'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallConfigurationIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:47'!
smallConfigurationIconContents
	"Private - Method generated with the content of the file /home/dgd/smallConfiguration.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAC1ElEQVQ4jY2TTWhUZxiFn++742TuTObHxNSJ
RqOjaMW2INWqVQjRqLVqIIhWhaKgiGm6KCqUulAs7cqVG7EtIq0BfwIRUYiShnQxgqKOSmkw
sU0hE03MD4bMDPfembn3dREiCoqe9TkHznnfY/BmVAB/RKNlhx3HmgtoYBAovIX/GurD4djQ
mTOt0ttrS2vr37J9e6PMn/+RV129IAX8CNQCAQD1ijACnKypWb+noaEey9IEg1XcvHmd9vYW
jh37jRUr1jE8/JRTp47S1nbeAb6dFNfOmpXov3IlKf39eblx4z/Zu/cHCQbDYhiGLFtWKwcP
npDm5tuybVujUFkuJGYI8J0OGOwGOlatWjPTcfJ0dT0jlbpFS8tpduxo4urVx9TVbaWj4zJN
TRtp6WqDc0cgPhUg4zNFV33/5QZV4Qxbh3atc554EguFIqxevZGVK9cTi02jWCzw6NF9nAVx
WPohxEohX5wwEMjOi8fZ+fFic9/De2aib4A68qT/as19c/1CifYHfI724Phu6EmD68HFTnj2
fMIApTK266IMg8lWNwdN6kNmyBZh8+DIcHLn2grqPoXuNPyZgkwOyiIAWS2QfWzbPCi6jLoe
nkBQTxwnoBQRpR1E4G43XOqEfAHOHwWf8TJCJiDC/65HTd8ABaDTclji91NuaATxuN8Dze2w
fBHEy2D61Jcd6ILrjk/xPBqiYXqrKylRkLQcEn0DbBoYYdBzSxjLwS+HoHYJeB6MjsNYdiJC
EbJ20QVtENWaKUrx6wdl/Du7ki2hADlXDD5bBJ8kwO+DkXH4+mdhPHccGPIVYPT3ZNIyHJu1
dt4UgZBSVBiaA5FSruWssZ6iOw2A9BDc+idDvvgV0Pbq/5dqOBDRqjuslfVTedQemjND7ESV
rDFLutnyubDnCwFSwNx3jWmpH86aSo01hMz+hX5fGp8hwNnJAb0vIkCjgjvA/reRXgAJIyij
02CJYQAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallCopyIcon
	"Private - Generated method"
	^ Icons
			at: #'smallCopy'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCopyIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallCopyIconContents
	"Private - Method generated with the content of the file /home/dgd/smallCopy.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACp0lEQVR4nHXRz29UVRjG8e977pk7HTpzOwPt
TFqbWGscWOiGuCCAhI1oMNYfCzcNCQuSmpCQ6ELiwsjCBX8BJl0YV6xYKQsSQgIETNCMxhJD
m7SRqdg6pUwLzHRm7r3nvC4KiLW+2/M8n/ckr/A/c+TIsf52tm8sMOZFDxXV5MLN7755vDVn
ATk0MfWBwoHKUGn30M7S+I7+3AuFfD6KogJRIU+jscKlKz+MAV9uBeSNiamPD+/f+/WxyY9w
kmWj52l1Hb1EcU5JvVIdSjlx6ouLcRJOhpl0TPDF63uHb3DmjLdA6eD+fXRdiPMer0pjaZF6
fZFmc41Op811El7dM350IMo/LEZ5lhoP8D/PTd2AaavQiwo5dmQNXuHylWs0lhf58N23KO4c
wqnQiZVO7EySKqlTImnyy+mz+4Bpa0R7Lk3IhZvAo0frvHf0TQqlMrED7xUj0JcxZAJwXqkU
B0GoAlhVE8e9Ln1PgNAGFAfym6AHr4r34HQTcwr9uQwDUX73E0BbrfYGWSt4hWwYoC4lmzGo
/gN4VQJjKOQCcqFhpDI4ePj940Ur+KXG/SbWCoKQzQTESfwMVBUA+kJDaOXZ+UZHytxZqFet
C+Teyuoa1gjGCGGYod1qY62AboZDaxD59/1HR8rgtWrC9fjPldUmgREEKO8q8tf9JtYINhCy
mf+WAUaHy6C8Yq5e/ba72lxfe/pQKe9iubGKESEw2zSf/4Fo1QIsNx7cvvnjzCHvPbWZWR63
Nrbd+vyUB0uAvGQBfNed/Pyrc59iZFnQmdf2vHweMFtLSZKycPces/N1btV+A5Xb2+55Z/KT
hXNnPxvv9GLm5uvMzdeZna/73/9YupOm7idUasZr7drrw7e2BQ5OTL0tymkMd5+GW6K/1r6f
3tia/RuMlS09PH8/SwAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallCutIcon
	"Private - Generated method"
	^ Icons
			at: #'smallCut'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCutIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallCutIconContents
	"Private - Method generated with the content of the file /home/dgd/smallCut.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABp0lEQVR4nI2RwWuScRjHP77vmq9TWzqb0+iw
dAahluhhQV42MDwogyBo/8JgEEF/QhA7BF3WZYe26tDJLjtIG4w13A4lMbaFF8UyTGKa5pyN
17fLa2w2X/2cfvye5/vheXhAm2fA0x49/xCBKKBrf8S81lzEO9ZUa+cinHpHH8T8q067OQFI
AIZB4ZLLIgwC1/sRbKV3s4eJF7Nxp928CYwaLggmz2UJwN+PoPwlV3u09Po9a0uxkG/CknbZ
DOL4iARws5ugc7fPH/fLoamg2fNkPmC2isDRCS93SlXgTTdJJ5YhScxur0wrrfR9pbA8rQCF
fsNtAqNWfSO/MKlkHvoU9xWjAoT7WaFNsd6Qj6N+W8R928GtiWHebhQCcot76jTZXgKAin1o
YC6ZKv5O7pZ/lSrNk8af1nNgEagBn7RWMAE7oqCTr9mkH+EblkUdvFNrd4CvnL3gf8wA24BR
Bwd6UYwDVeCuGqwDHoCBLoIwkALqCqSasuxTpa+AQ+A7kNES7KkBADeQANaBIHAVyGuND+AA
fgIfgG/AcK/AeYwBj4GLWk1/AX4ycm0mm5UYAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/10/2006 13:45'!
smallDebugIcon
	"Private - Generated method"
	^ Icons
			at: #'smallDebug'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallDebugIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/10/2006 13:45'!
smallDebugIconContents
	"Private - Method generated with the content of the file /home/dgd/smallDebug.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0
RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAIqSURBVDiNhZK9a1NhFMZ/5+bj
2pSmNmmixUiGCiFiRdRuNX47ODk4pAhKEUSHIuji4FZxkP4FDnaxpW4OCkWF2IrFdhFCIaSK
S2sJ/QjcxOaj8eY49FbSpOKBw8t5ed4fz3t4UFUaG/AB/Q3z2WZNY7tpKlUticiQiFwENoCj
wHSzbqdaACLyJBqN3kkmk/Vyucz4+LiKyLSqvt4LII7NncdB4Kff7ze9Xi8ul4tKpYJlWTmg
T1XX/+fgVgjq1woF4qEQnbUaacviLQS+wz1g5J8ORKT7isez8GxwMBxKJGQpFuOIKmQyFGZm
dGRysjpm2+dUda4FICISg7mxoaFThwcGDBOoqtIOyPZm+ZVKcXNiopiCXlVda/5C322R4+lA
wFjPZjkJeFTZAt4A51XpCAZ5BPtS8EBEHquq3Qg4c0xVwuk07T4feWA/YKpyEGhXZbNYpAie
MAysQg+w/BfQAXEfeEuzsxiRCE9FuApcVuU0QL3Oh+VlXgI9EFmFQ7sARchYUOrc3PSVslnu
AmERSk7SfgMJoB+4ACtA184ODOd8P+XAcsAXoKZKujPAEnDJuZ+FrTx8BaxdAFVdfAUv1qCy
wrYi4+/iefwEphiMAAXDZY9u204Di80OyMP9YXgnhlEZBqaivVr0mnzuPmDnzDb7Rt3+9ANG
gXlV3WgJkhMmAa7H4OE3w1Vzezxt7molX4IFYB74qKq5liDtVSJiACagQNXR1pt1fwBQXQnk
LaacTwAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallDeleteIcon
	"Private - Generated method"
	^ Icons
			at: #'smallDelete'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallDeleteIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallDeleteIconContents
	"Private - Method generated with the content of the file /home/dgd/smallDelete.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACrElEQVR4nG2TW0hTcRzHv+ecqdt0l1YT2pq3
NFyaLCK8RNiDdqMiBJFeDIogIujBtzB6ypcu0FsFgQ/ZBSEpUSu6EUo9RGltiCXihk7ntnbO
zjyX7Zz/v4fyMufv7f//ffj84ff7/hlsXkxpqasRhGsCsIXT9fsz4XBoU3D9wePx1LKgFytK
He3HWrzFh5urEIlLeDni1999mn4mqVpPKBQK5AhcLpc5j2Me1nq3d1w+f4DxmCQkZqYxNrGI
pmorEgYH6g414unAT/qo/9srUZZvhELhsbWX3e6rT2630fjUTTrx4gK93rmbFhZwFAC1mAy0
63QZ7b9WT6P+HhqZvEUvnWulHo+rAwA4ACg0m492nXIdDPv94HUjjrS3otq7E2yeAz5fJc50
tqCmwQdFA6yWAmQ0gpG3gVgqtTzEAIDNZmtx2GwD+/Y3FXWfVEBlEdaKXSjfuwdqhiApKrBa
jPg6HsbQFxnDzwdTwblIlyCIDwwAIAjCqLWoaPH773Rl+918lLnc6D4RhdO9hNcTKt6M5yFJ
TLC7mqGaNURjfYOCIA4DgOH/GBRQwnt99YCuQ0zyuNIXg/2jBmd5HfK3FoMzGCFQFvzCD2hE
nwUwt14AAiRWtmqx2mGx2gFHMdhtZdDWrU3hF0E1spoJdq1FEwQkKyQGY2FOcBRhAWldD+YI
KEGcEC0LZhkWG0sVY1RRlNlcAaVxoqezYF1dzhFkZDGVTqeFHIGayYz+mQ8QcNwarErZwowC
KT4XASCv3K3SsiwH5cT8lMwHG+w7aqwsGGRYApOzBHpaRjTwATPv7+n8UuixJMmDwL+BZX0m
ADCZTCV2m+1OVUNHG5NvZKTkAuK/xkRpOTWSFMVeSZI+A+BX+BzB/zI4nY6zBi7/ONH1ST6Z
7FVVdRaAthH8C1vLN+tQdL6MAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallDoItIcon
	"Private - Generated method"
	^ Icons
			at: #'smallDoIt'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallDoItIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/20/2006 12:19'!
smallDoItIconContents
	"Private - Method generated with the content of the file /home/dgd/smallDoIt.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0
RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAMRSURBVDiNfVNbaFRXFF3n3DNz
r3cm10nsaJxYMU5joon4QvGZYjUGtLZEBWkiRWwj+iEq4odIW6S0P/VXEIvFDzP4iB/6IRLR
ZDCjVpsJksekKsaQaXwlmceN9c6duWf7EQ0y2O6/zVqstdl7bUZE+L+qXzW3GEAFgM5QJJbK
x1m+wJ7ayl+IaCdj7HZ6TB4wvPyvJVWqO9qTyaRMuTYUif39IZ/nuW0JzhT7ThzzB5YtcG90
CYS/WqcXNW43iuo26MWJ11ZD/gQir896dEVyIdBQV6gvX2QHPyt1QzKG+AuZ0VVl457aygYC
Os0xWR+KxGzxznmmz+BnfAbH44GsJK5AuIHyOeP6BGDrJp82I+BetGKJh5+7nAy03jX3A/hN
AMBkQzn7XcMnqwt9ghV4OIgLXLgyaoXvmHYuR1hfbajbvixUv6hWOQAESzW15XZyHWPsuAAA
KVFaXu5h6jiOe1FTXmtLDjWFHx5kDP1ZZ86Piotvrts0RQ1HUnbTpZGRtq6hZgCCA4Ak+uHw
TwOJyL3XNnGBrphldT9NnJdE4Zwju3I2+/npgG0SF7BsBoDxpbOnDRNRlgPA7y09ZzIZ+qPj
wViGuILi6ZrqNyZNJ6IUAGgaX6npwkVcQU2N3/3rsbJpJVP104wxJgDg28/nba+c593d2Dir
gDjHmmq/cr8jvW13bVWh28Wl1yvW7tjx6WTiCgDAY3DQ+AXH1+w4pAZKJgmX5kIqnUVBgQtH
jlZ4e7rTX3s8AoESDZqm4OLFuNXaOpzjnLEnz9LNABwBAEQ4394+eijamSodTdjO0mVF7l3f
B/WqhVMmAkIA0mMSj4eSJyN9z05LIg7gCQeAUCSWMc3c4pY/48sfDiaPMs6zxBUMxi3s29vx
prk5niGuIFhmqH6fXuZI2UdEvUQkJ5IYisQcAL31q+Y6fb3pXGc0hZvX/3nT3T9yim5gQ9eD
ZMnwK8tq7xm6yhhTiMj56DO9S+ZCEnTk+ei/Zlv3YNM3KytuPXqemB/tf+mRRI+I6MV77kcF
JkDGBBHl/pMA4C2oHVtvUbiwmAAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallExpertIcon
	"Private - Generated method"
	^ Icons
			at: #'smallExpert'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallExpertIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallExpertIconContents
	"Private - Method generated with the content of the file /home/dgd/smallExpert.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACS0lEQVR4nJWRu09TcRTHP+1tL33QVkjB0lqN
QABRiiE6SDCEElJcYWbV4GRSw9zBP8BFSRwk6mCiI4Mp0dCQaHwwgQllACqlPEIfVOhte3vb
n4M0ImICZzq/c36f73lJnMHehJDfRiiLGW44nGRGfMj6swjU1qObfoSHNWJ2lcZ7z1B0p4W/
PsEraTR61yg7BWHFwsRKM3On5X0+Jx/uXiM3NYRYGuPTx4c0AvyvAxm4CnQDWeAxsNpgZrLX
w/eZH9ieB1GlFRZOgseQSNY214pWf6twd7oFIID3wOXDP9dDIfQCdMc7eMo5xj13PPR099Du
biefyBOdjyLbZcIvw0qlXLkFfyobjsCjyIxzG1wXXTTVNdFyvoWOng7Mo2ZiuzEKhYJl9vXs
K+AmoAIcPeMEV8BoNVJjrMEsm7Fb7HjqPbS526iz1jEwMoCl3uIDAlWoKmAAfDRAqVyiWCqS
V/NklSzxVJxoIkrqIIWiKji8DoDe4yNYARPy70fyZ5LN9CY2k428mscoGUntp4in4miSBuA8
LpAFVsjQghXWU+uYZBOlcomtvS0kvcR+fp+N9AaZRAbg80lLnGaVB1wAIQTLm8vs5fZwWBzo
9XqUosJ2bBttV8sB4Sp09IxmYJ4uOungXysAc0CW+8BkNSxVnVAopDcYDEs7iztdpa1SE4bD
7AEQB90XnXrJeWkqGAy+6+/vVyORSO4vgUAgYHe5XA19fX0LxXRxmzjFynJFsiVtCa/R+214
aPjF4ODgohBC1jRN8fv96UgkIn4BMVjYCuwVUJAAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/20/2006 12:32'!
smallExportIcon
	"Private - Generated method"
	^ Icons
			at: #'smallExport'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallExportIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/20/2006 12:32'!
smallExportIconContents
	"Private - Method generated with the content of the file /home/dgd/smallExport.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0
RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAJTSURBVDiNlZPNTxNhEMaf2d2y
29IWW6rAoiEhVRP5sBIlcqgHL0YTrScvePDEyZuJqf+BB2/ExHjxwFUTKtFEkyZgoySgpGCU
AEK4uKLUVtvdbbfd3fEgEChN0Oc4mfc3z8w7Q8yMRgrGFRnATQA5ADPFTOVbozxqBAjGlSE1
1vY0erpbbfepmExPlX4s564WM5WpAwGBC/K18EXfuO9UE9UKNkgU0NPVh6X0mvX17cYVAOsA
1ouZigsAQj1RbpdGPapA5moVuefmRz1b0RcWs1DOsexpE9NSRFglkR9t5+8BpNRwgLVatjhj
FQsvy7d/vSj3G/O1QfNzzdF/m4je6kTizmUIihjYfiPtKc/87MlqcxevUSSh6bVgXPGKIZpQ
opLoaRGhiAp0S4djuF/2OUip4WGJecBnO4cB3N0KH1KOSRFRITCAUq2E7EIWANJ7hphSw61g
XurN637ZdeUPkaAJolhCy68E48rxJlWY9g/IrXKnB/lX5uzmmD5Y7+BByLKNUNWWfbaLTsMy
wPwYAIqZykpVc0/8nLBGN8asudJy/yjFks07DsY7QlEAK5LjFgTABkAAxKoohABcSmj513Tm
3kMwj+yamUNE48x8Y7uFHgCeuh9lAIvXj4wMAZiMnT2P9o6jICLkNr9jdvoNAxiWACCh5T/V
78OOYskQAHRHT0IU/xrwB4KYm3nnOI7dsm+R/lf/AnABwND1nUC5bMJ1HQGA2/CYdotiSZlI
eM/s9nq9PgtEKJtGExFpzNx3IGAL4gcQBzCw5XoeQIaz9wt/AFR4+5g8QPOiAAAAAElFTkSu
QmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallFindIcon
	"Private - Generated method"
	^ Icons
			at: #'smallFind'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFindIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallFindIconContents
	"Private - Method generated with the content of the file /home/dgd/smallFind.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADIUlEQVR4nHWTXUybZRTHf8/zvOVted+2g20d
HyV0H7iNKoMQYjKH06BeYMZ0yW6MMUanWZZl3hgJ6hKN8cZ4R8zUeMPVxqZibJaiDk3N4iKR
6RrF+MGoVoLCaKFQSj/e9/GCQWLUk/wvzzn/nP/vCP67RE/fiVBJy0YhVFjjNCJkWGgdRlPj
ot+4Gnv3KoAB0H3kmcNCyMcQIlpftzWyvWbLjkDANoJ+P/5gEL9l4fdb2LZFavomQ8OXLaAH
wDh05NlD1T7v5/1nnpLhyG7KWrFadMivuRSKLhVXr8vRLLjQ+0A9Qxcut29YlUjRsjPSKJt2
7yVfEhRKLlqDaQjsakXAt66gZRCoVgSDQXw+s/a+3lN1AFKiq0PbavAogeVV2KbE8iosn2Il
M0NidJjxRAynsIjfpyg70Byuw5FOFEC6iGU0WKbCVyXxmZJyfonXB55mfPQMHdEUzduucenc
cUaG3sRraJqb6tBKRzeOmF1ZLeCtEiAk2tU81/8kL776MMuhEzj4MIHHD6aZ+Pg1Xn5pgAN3
9yC1WHeAq7OrqwU8SmIagtjIRY4dC5MLncTBt5lrtrydrwuPkk59QqmwhIbbAww9t5DNYSjw
GILkjevcdfAhXDz/AKNUqpDJFWnr7mF+Ng3QCiD9a97f5m5lXdd1MaSgUl5Debz/IiuzuLJO
mBnAUAKPYdTc03e6Qcbjg0XXdWf+mltASUHbgXZ+n/wK0JvNi0t5Pk18h1KS6esJOjs7CTeE
EKLYKm+Te3Pmz3mEgEeOHuWdt8aoL8eYncsQuzLBe+fHWM6vcXZlhCcyaWzbJtwQQmoZVQDN
d3Tee+e+XR37WyJYlsWelg7OPv8CkR23kB6TptoCkeIox5Vm1+EtDH14nsk5m+VC5QsJoKWY
mpmd37Tc1dXF8KUECykv375/kYkPPuLHSQ/3f5bm59A++nsjTI1fyJTKnrcNAIX48to339O6
dyeZbI5fp//gl+k0qfSsUy7X/gQ6mc2SrNq650Z737n9r5xqG3B0YWwiPpgTG1u7+06eBvdB
NFMgk+Am7Yr5Qzw+WPyflwfgb70YMA7AGG7WAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 20:58'!
smallFontsIcon
	"Private - Generated method"
	^ Icons
			at: #'smallFonts'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFontsIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 21:02'!
smallFontsIconContents
	"Private - Method generated with the content of the file /home/dgd/smallFonts.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABw0lEQVR4nNWRP0xTURTGv3vP+8Pro9CqQ1Pw
34tplIGYgIZASZogFWpinEy0mGCJiX+Cg4uM3R1MHNwMMwMrcRAGFhwaEjVRQTSS1DQMbaWN
0tf77r0OakUWWDnJGb58J79zvhzg0BftFuPj03an5/XHI6erpdK6OAiA7xYVXZ8KtXW+Vu3W
44Ne8B+AOM8BgON2TOz10ulbbipzP7YX0IqQzNxJCOEnORlHiYx4JBpb3Sp+WgOAgbHJR4Lo
2U6j1nPy3MUnXV7vZScRn69sbMjWFqnFvWr52wspmrMA4IQjd/96vt94U1xfzRaW5nIqCOYs
27kSqltT/yLk85wxlmqPHiuRZS0C0Kbjjnh9yRMAEA5HKt2J/pnBzO1lTubV33HJawGGCsUx
KcR3JnFzp1YdFU3/LQOzouHYNABIKWY58esfVhYegOnnAKC15gBgAIBSavLr58LDrS8f3wHA
hdHsiAn7le123AAwo5TcNsgwvd7hs8ToGgAwzttSqbxBA+mJrNbqkuse6S5tvl8AgONnzueC
ps8CIcqxUz3Jxo/6U61UFyPq+1krvwyk8Bnnoer22iYAMADmn97v5fY+M4exfgFP/5Zri/7V
SwAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallForwardIcon
	"Private - Generated method"
	^ Icons
			at: #'smallForward'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallForwardIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:34'!
smallForwardIconContents
	"Private - Method generated with the content of the file /home/dgd/smallForward.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABr0lEQVQ4jb3ST0uUcRTF8c/jPDPqlKORiqSt
JqSNRfM0LlqElkRtItAIa9HWF9DKXkCbIAQhIohoURQFtQ2iYDYZkpAEUS1CamOBjppmOvNr
MZRUi/5And2F+z33cO/ln6tXt6KBv4N365SYkwgKbivq+LElAnv1YUjQLrIkWEAdBrVkthnt
YfwFMx/nRM6YdGXDomifxIrBzcFwLjiaDQ5mgr500J8OxvIhE46FsfV7IR7vDopRkLjsuFQt
QeKiVDTSUhpyMtOvS6u02IJlT7z0yLRVaw7YZacu1x/eND9aYq161ycnIokJjalepSPqpW3X
ql7arLL3yj+tpV2z2TvPODcN52ORipUKryasVta9DlWiOuI0cYaGJjry3wxmlcnHtSJoigVv
wbs1mpdRJVQIYWNsNkeujdVl3jzn0nzNK3Y2kjiNq9/lbEixNaYjxUgjqSWyLSx+oJTl2mJZ
1YApk7UzJgqCHeo0qKqIfBZ0ilxwagv750ilub+JW/OLgkOeevzrR0pM6Y2CG7lguD5IzEgU
fg1+VcFhiRWJIPHAHm2/D2+kyEv0/Dn4v/QF8kyGaRoL4uEAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallFullScreenIcon
	"Private - Generated method"
	^ Icons
			at: #'smallFullScreen'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFullScreenIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallFullScreenIconContents
	"Private - Method generated with the content of the file /home/dgd/smallFullScreen.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADIklEQVR4nH2TTWhcVRzFz//e++7Me+1MxkxS
0jR0nJZSbI0am07c2OomI7HrilB0GVy5kJDtZJNVEHQTcONKF2otlGmUEhoQSUtClTAWalJp
Pmtik/l47828efM+/m6yiFA8cDaHw1n84BAAMDNNTU2ZWutjWmsrCALDNE3HNM3q+Ph4gP8R
TU9P90oprwHIARBHHBJRi5nrQog9rfVap9N5OjEx0fzPwMzMTG6nuvVp+dmPH/fnTiad9ebO
Bxc++uVIJwbgMbMNYJ+INpj5t8nJyS0iYjk6OnpybXf12vbQ6mU+7xvVf+rd/UFuP22mIyIC
AAagiShFRD1E1EtEpxcXF7PFYrEq4ji2rIRFkR3B3nBx7t08/dS4ddULvB4AJwD0AegCoABI
Zu6N4/jNOI4vM/NZRURGvuesnX80uOqppvXEezLgd1hpqWMAICIJ4DgzHwNgA3CJKH2YaUVE
YcJIBO+9+v5TIQQeri+5sd9OLMz9MAgiYZkWeW2/menudc9deH03ne5yD9n4YRiGKgzDkIg6
RGQws3Xp5YKz8uDeqTvz91PKMAAAraaLysoy5m5/f/Hu7Tsbr7w2sjmQO+MqpTxFRB0hhB/H
sRRCSAAwrWRi6VkVXzeycCKB00kTQ6cK+OSzM+LDG5v57779Jr8wd9MYLFwtKwCNKIr2AdSZ
uYuIglS6S246LsJAISUktpvAhkO4K9O4nu7D8PAw7IbTr5RqKc/zqpZl7QA4OKSuojDg4ypE
MRWhS0vUgwjL+y10AFTaBoa0xt+7e3YGmQNRKpXazLzGzAfM/JiZ9xzb9nuojazyICMbL8kW
BlM+BgwbGdmElBLr61vPZ2dn6woAMpnMSq1WSwohiswc1WqNR1lCIYyqiEmCmZBLCJyQIZIc
od1qot5w/wDAEgDK5XI8Pz+/OTY29lgI4Wid6Cz9eq9QvPK2UtyAZBeafJjko08aqCwt88KD
Sqlet/+iFz2sVCqpPysPz9vV7a9G3iqMvDF8SXZnMxBSI/Da+PLzL36/+fP9dwDYLxw4qouA
drK4EofIsYBBgPLauHXgYQcA/gWOnHIlydMKjQAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallHelpIcon
	"Private - Generated method"
	^ Icons
			at: #'smallHelp'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallHelpIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:43'!
smallHelpIconContents
	"Private - Method generated with the content of the file /home/dgd/smallHelp.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADJklEQVQ4jY2TbUxbdRTGn/+90K7ry9oyIEUs
ShVYOwgDKcrkLcHQZWZB3IzGBdnmFpeYoOI3jdHMGN3itsQR6Fg2TWbC0C0Qh+JMeJ0RQUow
XUlG6cJW6izhQgfclvbee/zEB11N9vv8O09OzsnDIzmpAEoBZANIAFj/Hw8MAKaaYSQ1chBH
qOQSFvOg8n8Gkw0AphGnfiYGJ2jjCIBfHgqgj8FNhtDFGK6O3sPTfav2JuvYX0+1J0xsUzqH
CD7SiauZuvjblxv0IwoPkjlJrPpqbZH/ZAh0rARFB3+1PdAV73/vm8s9tsDgTVba9Co462Po
Ds1hobUZfX0/qn135p+74Q1ZKzKiAq9wOw471S8DAL7djxOvvd4YlCSJxsen6UD5C3TJUUdf
l+2lw3sbaRNFUejFfa6wcfuWWgC4edxwhp88hnfO3Ctscl+4kuvzzcHrnZGv9PeEe8KB0I2V
UCiWwq+YzSa9w2FPYYzBbi/UjgwP7br2UkxUGM1wRMhNqEza9fUYgsH76OzsGAgEbj++srKU
LwiLRR7PeEFb27mrgiAAAMymdKyJYq6kIIdXJA/2PcG5v8h/Rukod1Edn0Fq9dbvk3zrg8HB
wTUioqmpW1RU4khU5sAyetzwJTd3l4+27nSy+p3FaJQ1YAxV/xk+4IDq04vu81pRjGJ+PgRh
ScDne7Y1MGK/cwuKHFieuwNTfSX+4GOoqakyOJ3OH9LS0hoYY54aaLoHkIV3F2W4nq3G0PAA
0reblyWOv/58R6QbALKOQK+cLqqgrq7viIiot7eXWlpaFIvFQjMpT1LijfdJ6OwityafLJyO
amurT2+uxwNY9avi0bHEg/KMTKtau3UbHA47XK49LBhcQFZdNWAwYvLUeXgjSxjeIsZmZ/31
AKTNAPx2CHKBeeNW+5A/r//nn4zhcITz+WYhywztJ8/COvonxsRlXFBHxDgpu2RZvv+vK40f
RfXkUbwCAIXFtuYCh82bbc1a1hl1kiZVI2k5laTX664BMCctk+cQ0pVUfAhClBj+5gADCH6F
g1LmxnUAawAoaR2TMfYmsifewu5Hcf8BgHpju8aEKUAAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/7/2004 13:43'!
smallHomeIcon
	"Private - Generated method"
	^ Icons
			at: #'smallHome'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallHomeIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:33'!
smallHomeIconContents
	"Private - Method generated with the content of the file /home/dgd/smallHome.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADD0lEQVQ4jXWT22ubBRiHn+/UHEiWZk3S1m/t
2jVtl6Wx29DMA4LTgbsQN8ThgXohDkEU9C/wRvGmN4oXXqqImzhExTPTC7vpaEVHsyahWddk
Tdo0TWPymWT5knwHb4zgxOfqfXlfnqvfT+A2ojCrgL+3m2AJ0LChZkHtEGgXwOzdhd4wA3f6
XPJbpx8MHm+0THJbLSZH3BgmFMo6g/193CzpNAyhls39eWwZMv8IjkDQ41FS9x/1BCTZJrfZ
JjLhAmyyhQ6PnehnJORidcfJ7EyIN+avZs+lq2HAkgCGBc6/9px6JD4rk17XOXvaz/SYQmJV
59RDXqoVk5Luxedzk0xXid8V8qcvFW+UICFFYfTk9N53jXpd+GqhTkCGeqnDz782mRwQUW4Z
FDU3R+/ZR625gX/AZOqASjpTjV0r6+/IIjzVyuvC9UyLBlDZMLgJlIBiAga8Ls68PsZPV9Z5
da6Ibnv44uIu9x0bCidT1TFxyOGYG2y36QoCByWJoCiiA3cDB2yIHFf5ZanIS3NVBNvEhYbW
rHJvPITDpZySPKb5dNK29z961o80rVAJinQUmT8EB1XJialKPD+n41M0wAZgSHWyUfDQbHYH
ZQUe7sL8s08GX/loMUYkruITN3g8/BkZLcJoeBxFsjEsC9MwkSWbtmHw4ccr3NINl/wbdGfh
xra+H8t9kHafiveOMNbeLYxugHJH5YMnPidgS6gvRnnkmRnen/+BxErlAQu2xL9zlM0V+5ia
nkSWZVYyO5h7InSkANl8m0OykxGHg+HD41RaDr6+kFpehsvXYF3uCTKZOk4jjbc/ysRoBMtl
YEkF8slNfKJAodPm8ISb36+sYVn2l70EiwAGXH/v7cvna+kFpoYX0XYXMBUnDqfNbmoHCQFd
sPHuMUksZQG+7wkkgDKYW6b9aWkx/+Olb5PxWMwX2jfuw7LaJM5l8DRMygMyBaPDN5+km7LW
fjkH1r/K1OMMSKvwgjrqezMcDfRnUxU289q2adlLNly04LskrP2njbcTA78IUQPWkrD9f39/
AVvbS1v83SMwAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallInspectItIcon
	"Private - Generated method"
	^ Icons
			at: #'smallInspectIt'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallInspectItIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallInspectItIconContents
	"Private - Method generated with the content of the file /home/dgd/smallInspectIt.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACX0lEQVR4nKWST08TURTFT2f6nyntlJbWAq2h
BYxUSAoblBg0rsTECiEkfgANSgyuXejaj2CMicaFhhhdINGYKAYQYjUYTG1EBIZph1JaSodO
W9uZqSvISAYT41299847v3fuzQP+szQHD3wNtf2+o9Yhu03frNUSBp6vrJZF6cnUNPtCDaBV
rG2dQef9sZFQX9/p5oLB6lmRqwa+xDMdk5OxS5IoR1bZ7eF4vJhQS0C1+unx188H+yr0ufdr
5LBBeYkqzZXq+YehkbFX62+mmB4A4p5GAgBNG++8fBo+L3kGp1lywHww5qZA10wu6G03wnnv
x4VkY3JTmNjTCADobHd2N3rdCY64YFHrsyLJBJu1GCVrx/LxFnuvUiMAWNpa6LqCxsuqmQFA
KPzSAcDiRqPJ5TI7AeiUAKfnCAVJY5IOA2R3BCMAVGQ9HLRZC8CqBKzMRzi+prrmUDOn0rwp
9oN1AUDAniww8VwKQPqPGURjmSW5lAlZq9Hd/b5FiYgtJ+xvZ7/6RVEm9ZDELvMXOs7ll5QP
kACQ48vR+chGz/WBYluy4E7PLPJNc5+WfCyXpiVJJkx6qXzv2ShVM/7ZzpxsIKKxbEQoivF9
AICdrUwpOheJnxnqSXV1eLitOqpYDjhyhXDw2+5F7yxtybnNuHqC6KV4K6MznF1niu+EUjl1
8CvbAs22260BOuRxU26djtRv7xQTCS4fJQnNsYkHV05RmTRZZRYrg4/XuZ+s0H7Y4PfSEYq9
sdVPP/o+c3NXmr8s3r3VnQoG611/A6iW02kaDff7P/iaaq/9s1mtfgOeOPMUwSrvxgAAAABJ
RU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallJumpIcon
	"Private - Generated method"
	^ Icons
			at: #'smallJump'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallJumpIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:34'!
smallJumpIconContents
	"Private - Method generated with the content of the file /home/dgd/smallJump.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABdklEQVQ4jcWSPUuCcRTFf/d51LSIgmfphSBo
iobCBx16oSUaApemgqCGQGhq6wNEn6ChrakIWlskiKgpqCdqqKkXSlJCibA3M/U2aFZaEDR4
xv8593DP/R+oNuRXxqYDxS6qHBzO/2Zg4xeXLJPV7jLlgSphHA6/Pptlw8MCO572RmtsYda0
Jnq49L8h6UclmmkVmKaFPeI/bRPEkiC3xlzT82p+W1/1TRd1Q306qjwNKEuo2KjYxAhifYwZ
JYMsIbxm3dT8nG9cBsmRZ41dXsiAYUIA6BWAZrKEKgwMIUBn/dOke4gkKby4aaC2QD4kAdBu
/dQW4fp+KDG8eOhiBh81XJMAVbiLFXitTF7aIK/sc5KqW8lskSBVHM7DxQE83hX8nS/ail9o
Iyo5wufRM/dzX6NJ+h6ujiGVKPC7IBEA4riY5YYXKO+BzbAIESwR7VdoAe5BjgROFSCnMILD
Zil1RSgbv9TLOg/a8f0+Pxfp31WuPt4BdGiFIfxoncEAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'!
smallJustifiedIcon
	"Private - Generated method"
	^ Icons
			at: #'smallJustified'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallJustifiedIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'!
smallJustifiedIconContents
	"Private - Method generated with the content of the file /home/dgd/smallJustified.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADOUlEQVR4nG2T22ubdQCGn9+XL8cmbdLm2BzX
Ve2Wbc5DFVmG4s3m2DoPqyC7cQg7XIgIgiBexCu98A9Q0QuZV1YEN9wEHegcKzoZmrUWNUkz
26RJviZp2ibN8ft50dWrvVfv5cvD8wruk6em37Sa2+1gT9FDik5QlzIkFIJSEhQIv0R+fuPS
x58ACIDDJ86/JIV82Wa2xMd3hyI+t8vhsA9gt9ux2QexWm3YbFYsFitKb5133/9o4+dHA06S
SV1NnDz7pMmofvXe2+cZDY+x2ZY02zqNlk6nq9PTJT1d0uhLSmtNXji0n6FBuyNxqxS7AVlV
kSIYDHjwh3ejrW2xWqlSqVapVKpUqzVqtRrtdgsQ2B1DHJ08TTTkZ20jHQeyKgird8RFp7XF
zMyXuJxOXMPD+L0jTDz4AENOJ6rRRL8vqdRqdDt9YuEAdxb+iQOXVV1S7/X7+IYdvHHhDGv1
dYqlVYpljfm5P9C0ChuNBooQ+DzD7I8cIRYOIGEvgCoEtUazhdkk+PSLr2k0tvB53Xg9biYf
2YfX6ybgHsRhNdDtdhAIoiE/SBEHUBGy1mxuYTQoXHh1GimhUquTXylT1kr8OT9HvqjRarUx
m428eOwZouEAwATJpKKaFLVUqdUxKHDl+5/49fYcLucQkaCXSNDHw3smGfV7sFrMAPT6fVSD
AavFbEvcKsW2PZg6V7988cPBgYEBAAyKQAgoaVUyuWUyuTzZu3nWN5vse2iMM68c5+xbH7CQ
zk2p92zKFkqrB3dFTFycuUru3wLtbhe/Z4SxWJADe8d5/rmncdht/9saC/n5K70YVwF0yOZX
tIMT41GeTTxGePQYJpMRXddZKpTJ5vL89vsCi0sFWu0Or782jc87AlLs2V4gyBaKGkIIMrk8
V67NslwoI6UkPOplLBrk0BMHOH3qKCaTkcKKxsLfiwAtFQAps4XiKgAOu42pIwlCAR/dbpfM
3QLpxSW+/eEm6Xs8Wq32soSbZoP6zvYCg/rjL7fne998d12tr29y9dos6dwyhRWtqetyDkQK
ZAr0VM+i35m99Fl1h4XYKYdPnjslJCekJAciJaRMXX88kCGZ1O93+Z38B+86X+e9hfCwAAAA
AElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallLanguageIcon
	"Private - Generated method"
	^ Icons
			at: #'smallLanguage'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLanguageIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallLanguageIconContents
	"Private - Method generated with the content of the file /home/dgd/smallLanguage.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABlElEQVR4nMWRv0sbARTHP+bulOCQwaQnauoF
rYGiDpa2Wtupg7q5Fsng/+CmODqUigouDuLg4L/goCBxiFkEtRXj0CVNuWhE6cn9MOZeB1NI
S07qlC+84T34fHnf96DRaqozawE+Aa8ikchLTdOaS6XSN+AY2ASsxwxTuq7/XFz8LPn8d/F9
V0Q8Mc28rK+vSSJh3AAzgXBvb49/eVkQEa9u2faNDA+/FWCu3tr24WE2EP5TppkXTdMEeA6g
Vg3eGUZ3uF9R+PVlCTXehZowqBQvENtG6ezAy2RRYlHaPrxndHSEvb30R2AjVDVwXNflLneO
1vcCpV2n+c1rymc5lK5OvEwWymWaWlupFAo4jgvg1EZQAHN3Z1tEPPHvbh9Wrjh/974r52cn
EgqFHKDt3zsM6fqz61zua2D+YvGHJJN9LjAe9AkjHA5nVleXxbKuxPddsawrOTjYl/n52fto
NLoF9AfBAKiqmj09PZJ0elcGBwcqwA4wCUQeBauKT0yM+anUlAesAPH/gWo1DSwAsaeCjdNv
pz0BrfQjq7kAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'!
smallLeftFlushIcon
	"Private - Generated method"
	^ Icons
			at: #'smallLeftFlush'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLeftFlushIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'!
smallLeftFlushIconContents
	"Private - Method generated with the content of the file /home/dgd/smallLeftFlush.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADHklEQVR4nHXSz2vbdRzH8ecn+TY/vvk2+Tam
sWmaJevqSjUtqDu4Yes6BanSjs5dxthJ2SaIBxF22cGd/Bd0DkRQL+Jg9rAqYqUbKMIc6cLK
RpPWNU2z/E7zw+bX5+MhsovzdXtfHofX+yV4Sl6eP6+7lAhKTQQtkqCCoFAElUUGUZaAQn11
+4fPrwJoADMLF89K1Kl+3TkxNhoK+bym4e7XMQw3TpeBrjtx6Tq604FsVbn86WfPA18ASnv1
5MVF3en4+sql9/EFDlDflzSaknpT0mpLOlLRkYpqV7FbrLN4bBKP2zBn5t+LrC5d29RQ6uBo
eBiPP0Sp2qJYrpDPFygUChSKJUrFIo1GHRDoLoMTU2cIjwwRq9aiwKaGEE6/b4B8Lst315cw
TROv14vX6+VgOITHHMDucCIldKTCqvURCQVYu78RBZY0IdUewHORYT7+8DxdKSmXq+SLJex2
B4MDBlKBVAqPruFz9xEeGUIpEe2VKCjtN1s4bRZu/rxCbG0dj8eNd8DkhYlxXA4rLrsFt27F
ahEAhEMBhJA9QClRbrba2DTBqbdmWZybpbHfZGc3Sz6fZ2XlF9K7WRCCSx+c6wEjQ4AYP378
E00TVrKVSg3NKvj2+jLx9Q0cdjuhYT+hYT+TE4eYO/EKPq/5ZCd+3wAOh93eVukxjWZzM/04
h0UIzp2eA8BqEQjxtIn1IoQgHHyWB8lHUe3WzS9z0wsXatVa3VAK/ow/YHsnw6PUY8p7Vd55
e5ajRyb/g4RDAR4mtqNa71TJdCY3ZbP10aj/zYvRwyy8OYPpNqjW6ty995DEXykSmylyxTLv
nlkgGBhECfkvIERyJ5Ofen36CIXSHvH1JDeWb1GqVPH0uxiNBBmLjPDa0ZcYfMak3e5wY3kV
ENYeoEimMzm6XUkqneXwoQPMvXEM021QKFXY2EyR2Nrhp1//ILGVYnsnIztdeU8qeVkDUELc
Xv3t7kfjY2GcDhu/34nzzfc/srGVolyp7gFrCmICEcNCrNGV8TtLVxsAT7qenr9wBcFJAUmJ
iglFTCBjq0vXtgD1fx/5B+BjSYe2EELYAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/22/2004 19:35'!
smallLoadProjectIcon
	"Private - Generated method"
	^ Icons
			at: #'smallLoadProject'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLoadProjectIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:32'!
smallLoadProjectIconContents
	"Private - Method generated with the content of the file /home/dgd/smallLoadProject.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADA0lEQVQ4jY2SW0zbZRjGf9+/358eKIUW6AE7
SlvcxiImc8PIlnmKkmAyt5ktWaYx8cAu1At3ockWZ2I27iDemHjjMTEsgnE6ncQsJrhMM2RM
kQnLQKRoS4GW0lJKD/T/eWe8EOJ7++b3vHne5xH8j2l56MjjhmF6QkBIYYwZQl2YunpxEsC0
JXnsmOke966+XU3Os/aO4w3r7SeahMvrZ+7O87X+7So5Nzm8pcBO1843nzpQ9/K7r3jNDTua
Xc/UjFf9WH/QW7r/iKN889vttf7wLW0LXjjsFafOnqgXCUuA8nKaVtsM+8wR0M0m/fgZuzC0
V+Wm1x8+HPDVWUV8zU2hsooLyd2YSgYRw0l7dYxFm9t7S4jWTQVM6InpeDH1UzbgOOoaw+w8
wBvZw/zQ8g5kkqTWFB0Wrbiphd+GBrLlYjFyfvKu+cvxe/l51c16WZIvCC7F7+N0v1peXS/1
b/UDBMaLhc96ymfGGmMFw0RX7QhmY5We79KR769P/1m2r3eLrr10un3B3lp/yOkNNEtzZaWm
61JomgCBSC8l1ODlQUatj2Y8TmtFKbfmmM1MDUdDE/VMr+2XUuqd574cbREqDarAYux3ZkY+
wtCqaXvkKLl8lmvRiJqc/XRgWtpkydZxkj23r9IVaOXQRKes99/dmFqJk1gpgTKwCI1CbgV7
jRldK/LYh29x4+mUoDF4snRlKc9zA130VgU0iwsDhHR5/N50ZpmNsg9QFFWUBw+dQlAklVnC
7HWit4cpsQHNixY+dxYIaTL8l5cpjT9kPpvJBX02ssk73P7gEpVtYYQnxLMfv41UGsFcgbkF
Mw2eMCPBLL7dbumPVDHR/fV17PwqkwuRGIZivG+QB3q+YnjvNrb1v8R8fIk2TxNWn5XZ3pny
L/tmTcb54aEo9EcVCzj4hiHyMp2Yj61mNmh74SA33DUE9+xAaE6uvNYNqgBaNXXj76Wvnbt4
GsEnjJL7d9RSCfpef3J/SJXLJqXUPwtNSqHrZk1WWEQuu/IFN3n/v7ryN/fUMc5/02mQAAAA
AElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallNewIcon
	"Private - Generated method"
	^ Icons
			at: #'smallNew'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallNewIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallNewIconContents
	"Private - Method generated with the content of the file /home/dgd/smallNew.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACb0lEQVR4nI2RzWsUaRCHn3r7ne6e7p5MPjTu
mMRE8bIOe9iFsKwiePAgQcGFBW+aYy7e/APyXwQPe9uL5CJIbnszgrCw7IQISr7Nl05kY9Rm
ZpJ53/LQKIgfWJeqQz1Vv1+V8I24dH2y98iVhowJhsXrsBcdBjmuav569GDmMYAtGqfGvNM/
EH6Kk2j05OCxU0kS1yppEvdkKZVKRpYlVLKUl81X3Lv/98/ABQD57erUkBVduHljov/X8XHS
ai/tQ8g7nrztyDuOI6c4p3Q9XK5H/H7rTuvhL7WM6WlvrLizfb2V/omJK7hSD/u5J+84nPNY
K1TigJ5yQDW1VJOAUlSmr1opn/9v53RhQSQ7MTiAKqRxgPeKU3Be8b7IH+quV7pOGRup8Xox
rwMrRpUDAZLQUA4N5ciQhIY0MiRRkbM4II0NQ/0hWRwwOlJD8fVCgdVm3moTlQxOQb3iFbwW
W70qcWioJpbQCgBjIzWAc8WAQ7uX5y1KgRBZQVUKWAVrhCQy2EA+ee/o8A8AdQAzPzfz+s3b
vCOilKxQskJoTXG8JPgMBhg7VQP4kelpYwA96naf/79/gDWCDYQ4NJTs5+CHGOirkibl+NK/
zTMGQGF9e7dJYArZ5uvsJyqcuroBEJWN7Rd7iIB8BwwwUhsEtBighvXt3VffR1J85uBtjogJ
LYBR1nde7H2xud3usLKxw/LaJkurmyyvbbG6sU27c9gQCf60AD5w/yw+W+0uPl2x7/IWK+tb
LK1usby2ydZOs6WqT0AXvNAQrw31dmF+7u4+wEfHF69NTSJ6G9hFpCHogvHaOB7vL83Ozrqv
2XkPgdkFGpcRD6AAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallObjectCatalogIcon
	"Private - Generated method"
	^ Icons
			at: #'smallObjectCatalog'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallObjectCatalogIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallObjectCatalogIconContents
	"Private - Method generated with the content of the file /home/dgd/smallObjectCatalog.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB9UlEQVR4nGNgIAxYGBgYuIlQhx2YqrNFR7hx
bcAlz4xHL6OiDKuZkQZbUUMynyM/N6MTEyNj0IMXf1cQZbOICINkuAvXpR+HpP//Py7z/9Q8
sY9OJuye6OpYGBgYGMzDC90EBHidYIJ//zIw7Tl7unvlnu1mJhqs5xJ9uDXff/7HdPvx/8dY
DZCWFvVZ0JSbCxO8dOshw57YS8sYGBgu7D714+/eUz/KmJmZ5MSF/hs+fslwBcMAfGDXqZ82
DAwMH3HJMxEyAJ9muAvevvt0o3ry0o0wwU9ffrAzMP9F1RjKwMz7gtPCwFk2+8e/X/qnDz3Q
ZzjA8IcRh8EcDAwMP5AFzBtVXnOKcIs8f/jxJ6vQX+an+94Gvt/1bQuKF5zZ2ELS2LhOVLDz
XvZg5VjAwMAAt+A/4//Hl3bf2nfz1AOeL/e+bWNXZS5kYEBNSMzBrFwLJ3EKmrqwcgipM7No
nfj748ar//+vCbow8P/48t+XRZxRk+kDM9M/1n9ZXCpssh/Yvnchu0BGg4lZHsbRY2ZlE2Fg
cWRgYGD4+4PN6zfLHxdGDiZJxn9/bzFzMj3+cu7nKr4PaHkkio1r2zt+qf9/BWT+t3HyvRVn
YFBiYGBgYDBmYOWz5YjhteO0YgjFm/wZ+GxZ2Ds9WdhXq7CyWuBTSDUAANeVnXOvNaMbAAAA
AElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallObjectsIcon
	"Private - Generated method"
	^ Icons
			at: #'smallObjects'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallObjectsIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallObjectsIconContents
	"Private - Method generated with the content of the file /home/dgd/smallObjects.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB/0lEQVR4nJWQXUgUURTH/zN3ZnMGbXcM+9AN
spaelETtQyLbsiWofAjspYwegggfpJ6KoqjH6KEEeyjDoBfFCvbBqChZiGJD7EMa66koQzPX
zf1o292ZuXN6aWSM2KYDl8s55///nXsuw+/wAfW1jO3LEsEGZvA/sVGSe64qgXm9YgXdVLTM
dubr92xeDmnrdTWQokCQnBNVl+VCjLV78YvVIsJ7JMXvLu6Uy1RNEHd5AiQEGn/LDcNdfG+b
dpZs/S96bUOtvGkRYIrz4cvFH09GedEiADo37bP5THzVga7pyMETDW5xS53v+Pq18i0AFU5N
cO56Ue5SBWzOEY3rttUDwAp3ngxJHI0kGyMjt69Rxw5lqO+M1tZ5YX6MCZT8PGu/8bImGuuq
hi8e0+bmHlYTxYNE8SDdOK1NhWqkFk8AAFq4SYl9uLfScgC7tyy5CwDMI6CwdF2EKoVPrYwJ
wkzSpi/frMLoO7NPWpA0tavgzLfIZso/MXHHiBzqbnv5YGhsIJc3++/nz3/PcL3KLx4GUOZ8
Iho6uqN7tzU3O3kqm2OPnr++tKay/IXAjcnHg70Jvx+r02l8dM9YeIHmL8epo/trnHzyawLP
XulBblM2Ntg7DQB/mgFALLW4ZSMfG7gyUUpTEkBE6VJ9wLXCbDIVbT1yLuVuZgrFp/8C/AKq
oMu3BdqijAAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallOkIcon
	"Private - Generated method"
	^ Icons
			at: #'smallOk'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallOkIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallOkIconContents
	"Private - Method generated with the content of the file /home/dgd/smallOk.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACF0lEQVR4nKWSz0sUYRjHP+/7jvuOuzMbq7uZ
lkJESlSHLoExkAmF0K+DLBV0S5I6SKf6EzpVHrpU0LFLaZeiLh6KOXjIS5FREpUIi9oiOuOu
M9vMdHANEYWy5/rw+T5fvt8H/nPEdiDb0XuAPuCJsQ24E3BlWhSiStwl/xHOAS8a9xmFQr8N
0PTXArajDeCZblP7m89YeBMrCMQjo748DlwGXntuMLKFxn1lyd7mcxbhfMTyZDDuu+G4tB1d
lFqMNXY2DMhG8dh2dGGT60MoBpvPZ5CmZGGsgkDcA5DA1ZaLWZU/a5E9ZmaB4ga4D7ibO5lG
7zJYdCvUZqNvwMiqgKRruO8hQwduYR02MfLqeh0UtqNvAM+tIyllHdRUp0K8d0ECXPHcIAJQ
ut3omcl/7ZpTJeaCEjLFzjhMssBN4FrmUMrI9Wb4tRQxP+pDxLDnBg/WHCrdYewu++VTXkcZ
gIYmg+VPYXcSJHuz3Sa5E2mIE+afekRe8gG4EE5H0ZqAsB3djmSqbXCHVunVVmvliCSGVEFB
DD9f+lS/1H4AjucGM+szUuF0tKTbjRZpyqOpVoWQApWWSFMghKD8yqf6uTYL9Hhu8H1jQ6Ie
WKtI8TFfzOSIBYgEoQT+REhlMlyow+83ew4J4LlBKQm5tPh2JZGmQCSSxTcrVCbDEnB6K/iP
g3Wd96uMuB1V4yqxGAXueG7gbwUD/AavXL0SoSTm+AAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallOpenIcon
	"Private - Generated method"
	^ Icons
			at: #'smallOpen'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallOpenIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:06'!
smallOpenIconContents
	"Private - Method generated with the content of the file /home/dgd/smallOpen.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAC0klEQVQ4jaWTW0xTdwCHv3P+/9NLegWhpV3n
hYvchIoWcAwjRKkm6oYmW4xvY1my12U+7XG6x/mqZpkONZkgmsUlbtrFZRrxgkXxFhCNupFW
RBARCj2n7fFBlxhN1MRf8r1+T98P3nPK1xHqAM9chkLAyOaIHbjKzLsKZM5k78Lq6qVCSiJt
bdyKx3WXo/dE1kj3qGl+33WNx28SiIb5ovWHA98tWRbdzOClK0ipio7t28sDi4o3zaSmtxWL
0eZIAEdjiJG+BNOvCeqKzLKWaGi1i/NUNDaTSju4eWo/a9sr+fiT9WpT+9YSZ37BhsmxR98u
tk1GlwfJqy3i9pUHpABEJIinakX91kK/Feb+JRjexPHOozQ0+1D1u9jNIcqq/bR8/plS19b+
ocVmjyZuDX4V9uX+6E8yKhpDzOUF5n9TEV4Ewo4i3di9Czi4s4vZWYUPihcgpQGz93BbR6iu
LyO4pM0Wj8UC8SRdoi/BVG0hHSs3rvIgrJB5QqC4lBWfbiE1I+k9cZnL5+4gLE58oQBkpymq
XM2RPZ3mwANHtwS4f3Owe+qpdZvb6wQzA3oSaf5HOJJPuKmDnPRzsvMXMrmHhD8qB9NAk5oF
MhUqQNbk2NULQyC9L5EHigR9DDV1nXVffEnf6SHQ5oFpIjSpAZoK8KSE3uOd3Y91Q4JwgXA/
R3qeI5xgjFPVtIp7w49AEQihakBWBTh8mOx4MvHjoZ0/kdYFCMcLnC+ELjANGqJruH7hBiga
miYlKGnxfxDxBGd8U8Pjf/f8tnJu1rB6/UFc+QWgCFA0UDVUoTAxNkmobDF//XpIP3fH2Cte
riqe5OIyt757oH/g9smuo5mLf8byJkbHnKq04S4oQmoWPAU+UFT+OdKTPTts7FHedpaWhZYK
ry2z3m5TW6tqKuvLl9b4gqWl7Pt+x8jPca31rYJX5qj1azXzbNmmkafy/vCEHnsGoAD3o8FK
4poAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallPaintIcon
	"Private - Generated method"
	^ Icons
			at: #'smallPaint'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPaintIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallPaintIconContents
	"Private - Method generated with the content of the file /home/dgd/smallPaint.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB60lEQVR4nJXQT0iTcRzH8ffze/5srT0zNvqr
KM42JTskoRJISVARCf0RCTp4KCMhELpJx4gQomNBl+jgtX8QnQorqIyg/5atpZmOlk62PXPP
9uCz5+kQ7bAObd/rh8+LD1+o8cJwIgzDgKi1S0Qw/Gi0wx0f3O62wAi1KG0Q6tu1/nLnnr3o
uh8JumoCXFmMjZze56eYxgYcyFQNNENTT7v/VKi1B4w5Vl0AFqoGBAwdP9IlIWuQX8SyS4hq
gV5QhMTJju6dsPwJcFk2TFyYrAr4AQd2tKzd4tkQhdQUpVVIpsylbxCvCpBgf19vM5hLkEtQ
tFzeTqfu/M2V/wKStNsQIV6+eMNWbN7FinxdyI3/AwyAvAbOBED9CFcfgw2gB4NqtP88iqZx
/d5dpiZuGrPwvAwcgnA9DM7Bg04YC4DPgM3AaBgiqrAablw6h+INkU1bzvRs9ixQKgNe8Ot/
kGPfYTIGFySYAVCFGDrYHq4reSQsJcur1x+exaE8H0Dcgvef4WIaMl7YdhSeKnA4At224yS0
lE1jRqHekPFpmlT5IwXAgTYVGppgXStIebjWHNy0uNGr1+krwowWPL77TpKcaV2pBGSAOHxp
hPwvMGMQL8D8z8KKFdACqt+W1du5+YmHyUT/DDypBH4Dwguh75kYJgEAAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallPasteIcon
	"Private - Generated method"
	^ Icons
			at: #'smallPaste'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPasteIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallPasteIconContents
	"Private - Method generated with the content of the file /home/dgd/smallPaste.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACpklEQVR4nHWTPWxTVxTHf/f6vuv3np/TJPaz
HTuJgdBEoqGoWyQEA4KBDRgYmECRYIxgR2Jh6sjEUlWt1KlrhRgqJlpEJQZEA0kAJxFfMSTg
b7883/c6OJiv8h+P7u937jnSEXyW+fn5g5lM5pxt29MbGxs/jl6/fkfBLgGTBu5checfv1cA
V8CO4BgwW33y5MzY7Oys7/u4CXGIE4fZu72GEHD7j7V7wClg7RMBgr/mznz7Q3uqyKI6guu6
NOrvKO8ZpyZyzEy0GC/nWfr71TRbweQXgnTePTBzssDLapu4dpNcGDJkG+IARFEQGkGjY9BT
JW+/nzk2vmfu7o0b14IPgpwTtbtGuo5kyulR2fS4VRmig490Clgpn1SQYXRhiLPN5uWffv5l
BLgEhApACiKtLXoGmoHi1uZxLl46jxGa7TAiNAAxQghy6Yhff/t9GhgGXiuAsBsZbWuCMCYO
FZMTExihAdCWRFsgdmZ2nSQ53y8DqY8EPaO1ImH1sIwkDgyulgPqPZyQAkdLypOlsR1Bfwet
t0EjmVSeshRJkyAyBlvLASwEOFoOamPFQtr2hjPd5jskQKe+XYnDGK0Ved/GmB62JbAtgZOU
DKfUAAYo5bMiW9w1A/QFAtZb1Q6ea1HMahr1GpaSaCVxtEQIPkmp4JNKj04BQvb3y1rrdZeR
b5IAxNtvUAmBpT4jd1IsZEkm3TLgvhesNzY6JGQfsKIt5P+zAAylPZR2soCrABKwWn1c63eP
wY3qNJpt0p4LQLPV5uHyKv8uV1hcqnD/waPq1qvVP4GugP4xxVKsFPeNjG+uNsLl4d1vChcW
xjzPYfHhSnP58dOVTqu+FLRr/1RfrN+ubz57BrwF2oNvXQH3NBxNwfdA6bu54wfzpb1zQAnw
vjbOfw2z5rrakfVdAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallPrintIcon
	"Private - Generated method"
	^ Icons
			at: #'smallPrint'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPrintIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallPrintIconContents
	"Private - Method generated with the content of the file /home/dgd/smallPrint.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACSklEQVR4nK2SS0iUURiGn19/RWcaL/xjVgs1
GoqZEhuHoSItFDFcVaDBhCGtrIUiWlEobrqtJMXLRIISgQUt0o0geNk52iKELMRAUsrFEOoo
+IvjnK+NTjoZtejZfJvzvuc5F9iLFfABz1NSUmZ0XX/DP3IM6HI6nWv19fUyPDwspmlKYWHh
JpAJJPwpGLc9z7a0tNweHBw8YBgGzc3NVFZW4na7E+x2+6LX610DavcriN+eZk5OTq2madTU
1ODxeDAMO4FAgNTUVG1iYlLf2NgoCwTG44Gx/YqOu1yuiN/vl4KCAgHEarVKY2OjhEIhUUpE
KZGioqIt4Ohv6bS0tO8NDXdEKZH5+QUZGRmVYDAoSimJRFS0oLW1TYCm2Hymz+eT2dkv0tXl
jy6ORJSEQqtyt6pKFuYXRCmR9vYOAV7GXmJufr4Hh8NBdnY2pmkCoGkaaysrWG02DLsdgHA4
DPAj1qBudHRMlBLZ3AxLf/9A1GK3TU9Pr5zKzRXgLZCx2+BIYmIiALqus76+vqd9aGiIB4+e
ojvc3Ot8Rd3jZ+Un8vIXgdfAuTigraKifGlubi6qaZomL7q7uf/wCcGkDPJKLmNkHgbg9PkL
eC+W6PG67gSSdza6brFYvlZXV0tpaalkZWVtJSVbVq/evCV949MyMP1N+sY/SVNHrxgHD5lA
J1AMpGu7jnISKAMswEcgBFzRNO3ameJLGavLS3z+8H4KaAcmgRkgslOwQwKQDiwDYcAGuIAb
gADvgClgKfYl/oYNcPDr6/8/fgJnMgqt6rM6ggAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallProjectIcon
	"Private - Generated method"
	^ Icons
			at: #'smallProject'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallProjectIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:21'!
smallProjectIconContents
	"Private - Method generated with the content of the file /home/dgd/smallProject.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACrElEQVQ4jaWTS0jUYRTFf9/3/2ZGzXfTu0zK
KIqemJC9oEiiBxUu3FQEvSmKQmjXokVtgigKolpEGSFFC6mkIgtLeroojB6YadiYOTrjTNbf
+c98t8UYEbTrwtncyz33nAMX/rMUwNZ5lBhNuVgKlUILKASNRilBWdBKUL9nkt4L+1wumV2l
LDSBrIeTZy80o4qmkFM4gpz8AvwZAYzfYBEcR+P3BdDaIKKIhrtpqD1PqK2lwFgoq9hUbdbu
PAASB/GGkATrUXftItHeLjZv3/unLwWMGH+CE3tWBA1QVDK3jFM19WRlBkAsAz9cKuYX8PZp
HbmpZmYX93D6yEtSOaXs37cZrEdmViYARgn+7Nw8MjKSVK1cDsDrDx38THzEMZrRWREmjrQM
L8ylasdGsAmQJMYJAKABn2M0iPyVrlYp1lVWceORovb5NDp7hFAoNGQjgTE2rUAURjvQ/iXE
1Vt3AaG7t5/KJXkgHsvWbmFR+SwQD7EeHV0hJo7MR+v0IYNlwP0e4+ju+SBJWt+38aTmAe3O
WErGlLOofCZ1L5qobW2isz9GIuByfeU2MnwThiwoIrFIL4jHl45Onm84zMYLDyk7dIXL1efA
Jvj4NcSnr984tmANk5L5nHx0D2Wy/xDEe9METTcaWN83iAKCKKTlM4hHNBznW3+Urr4+Hr9r
pb7nDclk2oMWSyQaDoNNsHprBWemDeezstzLNeSvmkkq6XKxsRGMEMwOsG7qDKqLFxOL/Uhn
oDWRSE836DyGZQ5ysP4wjfXNTJ8zmXHjgiAubWePo62LYpClM4rABLlz8ykIcWMVoWe3a3AH
4niDP3EHYijt0PLsFY7x/RtOO833r6MVDQpQ20up0kKJgB+FI4KjwbGglUIjpBBSKCxCSilS
Ak3nmrn7v9/ML585JOJNwHhVAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallPublishIcon
	"Private - Generated method"
	^ Icons
			at: #'smallPublish'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPublishIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:26'!
smallPublishIconContents
	"Private - Method generated with the content of the file /home/dgd/smallPublish.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADG0lEQVQ4jY2Sb2jUdQDGP9/fn7vN29+7tv2c
t5tenulsUd1miWlEFCjZzRdRVPiiEnohBBaLIiRIg9heDAuiFwVJONgcWrBilajlKlKU5cEa
zrlluzvnbfd/9/f3/fYiKgoOel4/z4cHnkfwP7Tl4X2PSanvEeBXyCkp1PC1705NA4h/Obfi
oMU8R6fLQzi5H/9Tl+6+rT7b3Nn4RK63Lxap73LZ878sVc6NNqhycWjmwtgx/e9wkG4cvM2T
vr5nB171zPiSL3gmbgeeeyjwzIcHLWf7XRvdzzddrf+hZa9V3ravwb48scnjvTOsE8R0Pej5
eus7oYH0675guUcn7IzTGLDE8tpE99D6dmFaXUTjgu1101wvdjAj12rC11WSV852GMChbe89
/ehZbRy+SkuUlCrkMlYSNxC/RVh0P0Kdqmd4+T70smRBNrO9McLSmlYrLES3galtDnsXYSxt
M5TowGsexrr8MhP2zc7JHkfh8M62QGUKZ/NO3sr2MbnlA0gvk8gpHq/RShoV+X08lgS30pFU
iJf7eS3h52jaVyM9M0em10XHY/dwJdNK3jYoFAVfxO7njRG1ksmXRzTyjKjha1FWAEEjk2T4
mRt/TiRfKp4ctN+c8kWKUueA5yJOmWHwTGrh/E+zN+26/FFxoIfdjpaOY7hb3Tu6g9Lpcmmm
oQtNEyCEmJu/pY5fiIqcozXV1lzrKK/mGlK50qlVQxyc+3Y0ZRiGufv98amNQiVAFliKzDJ3
8ThSr6d3VwhTt7HuOK8Ojcbay6vZ9tl15jzjJ+2/1jdavAFfIrlEPFkCVaFGGBTzaeoaHZh6
BWSB2lpd/f7jaB64/t+XGu42r5XKJKnYLYCipBbZFXoFoQokUnFqTYXDIWS1mxuFbHp1g+Ui
uzLHrx+fxtXrR7StZ/+nQxhK0NHkYgf3qmoAbfnWQgTg6okvCQ5+TnRgDGkXiMbiWKzBUIpS
SaveIBWPRjKpEr0vhrjU2syG4CaE3sQ3/e+CLIDWwEdHPslVBSjBif69D/iVbetK/dNUMwxh
mk7NcNSI1WzydDXAH4NwUmsvAPcyAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallQuitIcon
	"Private - Generated method"
	^ Icons
			at: #'smallQuit'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallQuitIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallQuitIconContents
	"Private - Method generated with the content of the file /home/dgd/smallQuit.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACkElEQVR4nIWSS0iUURTHf/fxfTNOPsZpzCxC
GWuqMSOn1yKIIIiIahPZoqiIilpFtAkiKIQ24aIWLTIICulBkG1s0SIsyB5aIkn0fmii1ZTm
aM5833y3jX4qBv1X9557zo9zz/8IxrR9eazIhOSVilgo6bqO1MJILQ2WzAklkFpBX8pTrR3D
vQgoyLNbShLdR/Q4IKOorz+7auuciCI3OsLAjzS/UmlSqWGG0g4AA20jtH/sjwAU5wcXL/Hm
vfcBlYvCydmzQuBmsLSiNBqgLAyy3MLJuKQGHV6+dsbT+ZUeVVnXqZXjAW1JxRQJ/2RbgrKo
zexIYEqG8dATACn5nzxjpsX8KimFmPaKmNLJP+onAEJNAhhwM55/zXmGxvtprFBkGsAfYmHB
DAFgPMPto4/oef6dDccWUb0+gpKCitICPn/xSCQSfvEMlUGchBoBl1RxaEl+vrLdPw7m5ygH
55dwb8Ahu0Cx7XScYL6m8a5L08s5PuBP75s2DZzZGLGTKzesw43OQvT3EmhrBWGoPbCHJzdv
cflQJ3svLMW2A1RVVfmAV4M9aAGlxdksv5ubMYAWYBQE1RBcPMdqren64dJ+p49AbCGJyokv
9HQ8Qgt4/TVDzagHxgNvbNILwxBU8GbAZSQaJLmllIdv84hNmsHDUB5awI0HDnND82auDEdV
MN0/TOzbMGIQtIRWW1GxfzUt3dWE42soKiqacMCy0KegCWi6eXz7s42bciv6nvbQuOMuEQte
WDblJ46xbPdhbDuAlBKlFHJs6dxsJuvb+OlDqqHlfigpdY2M7yumb8hhV10dM+Pxad4bz+NG
w/mhZx1dV6ds377Na3cWFoYPmEn78S+5bs48ft55rf1d9/W/IR3hO/1r6QwAAAAASUVORK5C
YII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallRedoIcon
	"Private - Generated method"
	^ Icons
			at: #'smallRedo'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallRedoIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallRedoIconContents
	"Private - Method generated with the content of the file /home/dgd/smallRedo.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACWElEQVR4nI2ST0hUURTGf/e+O/OqmXHEhLJs
FiItgoykEHGIiFoZtJCIoFYhhLSJCFoIrVtF5KooIoqCIqKkjUSboaTE/kApZYgzkjk4pr4c
fe/dd28LFYYi9Vtd7rnf73DO/RzWUCrrtroZddLNqOkgH039XRdrmNuB3vh2RVjU1oZcAbq9
nB+tvHFWA7gZdU/Vyu11p9Ik97rC+DYbTkZtbkY9D/LR4n8Bqazb6GZUF3B6Y0OMC0cvcaS+
nS/pAUStbSiPBIfdHephkI98UWESQAfQHa9Xe9wtDsm6BNRpYlWKvTX7aappprfwhMLwOFPP
yv1oe0gsm2uAPlUtm493dpDYupFPv97zY76ACS0yJhFyqVFMxglNgDe4yMyrhcvO8qzP3HS8
redqD31zvQyOv2VqokRQ1Oi5COkKZHyJYGyEtRYRE/z+6DepVNZtAQ6fu9jF/dHb5Atj6LkI
XbIsDIeoWgeVdlDJpXXp+YhgSrP4VSMQAwpolUmJqpYMvf6MKRtmXvrWePYJcFPPmBebdsWk
ThrCaY3xLfODPv5YNAycVQA7dzfyzRvGakswaTCeveXl/M7l/byz2rb4EwG6aJjtX0BE8gZw
3sv5ZQVMCCH4UBpAugKwAIWKX33kvfFb9Kz5aX3uCuQdL+cPrRQV0Pd9dMRsaa2STsJBVRuA
fRWA62HRDAC5ygSuSAAks/HctjPpNpkQLOQDSk/LnkBs9nJ+uFpSAeQSRVyb7isTlPTKvcMa
Mf9Hqaz7OHEgZlMH4zaVdR+s16cqziekkccwbAAerhfwB4uIABacJugRAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallRemoteOpenIcon
	"Private - Generated method"
	^ Icons
			at: #'smallRemoteOpen'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallRemoteOpenIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:12'!
smallRemoteOpenIconContents
	"Private - Method generated with the content of the file /home/dgd/smallRemoteOpen.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAYAAABWzo5XAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAD2klEQVQ4ja3T+0/VdRzH8efn+/18OTcOnJtc
zhFCg+EVD56BiYU4qQw1XdocttSt6VrL1fyh1vpBN7dq9mPZlv1Wm1OsDRZqU/DSkKkFelKS
wEsonANM1AOHw/d7Lt/TD9lWW2219f4DHnu/fnjC/3RidzkWIx+r1MkkLcxVBDcO9ZD6r5A0
8jiTY7XWyTzNrG9aq4TPnU/sDEXbEHwjspw81EPiX320K0T7gfbWtWORcc61tFBSWUnZwoX0
dnTQ09k5E4/FjitZvlYNjn/WR/yfIDUUYGFDrfpMyawEoRe3YySh5cAH7HpvG2t2vq2VLapa
kM2am8fHRvYsKcjU1BQjQ36GeqIYf4GWFuGrCC56uTjvEUz0UlBRzVRCYWqgk1JLmCJvhlBD
Hat3vCGL5lTMM/SZlx5Eo3uW+rO1NX76f4wwCqAuC5B2eArfXFw1G0QOZE0cpTV8d/QEoWXl
qGYCpm4jH1yixC956oXnWbl1l2pzuipvhsM7gn6zpXeECXVdhIfj7vQ79WtWaD/fy9AVjhET
RXiLA5w6doaxsQROtxun2w3pBEzexDJ1lYrqJVh88+T17ou23ijfyn1gNg/Hr2zeN1SXVG3k
BOZgvznKSH+E5cGNNK4OcPnCKUZb+ygpyadpQxCRTYE+wRPz5xM3RDnkeuXip7e6b9mM4Meb
illWW8prt5p5zjXBkChjuO0TPj38Awf3b0M4Z3O96zxHDrfSvH0lCAuqlAAapOcraWVm/871
flv9AgsXp5/kfVcb613XyAhJcMtb9EcFHae7IdLFouXLyS9dwODtSVCsKFKigAbZHMVplWub
an1i2l7EsbtzqbRH0UhimJCjKpStWMWFn6ZAOiA+QsOWV+i5fAe0PKQqEAIVMGU6K9xfjDey
t+AsxZ4Mtbfe5dlZD9jt78KuqkzmjjE0LDBMK5Z0EnuuxO4pQk/noKgqQkGCMJT4tNF3YsKj
p5IKm51XMYXCptyL+Geu4IqdJXZviEKvHc2WD5oD9Bh1GzYS7hlAVSWCx1AmlTo62XZwbN2d
1/loaAUAg7qLG/dtNHc3cvpKjODiEhRL7u/zEPgKvDg8hSjyD0hJqg8jg5dcroIN8TsD6fvl
q1xznLrY62sl/MtE9qtD7Y/kve5f49c6s+N3hx0zehprngdHfh4Ojw9D1+k40vIoPCq+FI9T
sZZWNXxoc3k3qtKSa5OmLZVMDURu931+/27/CWCkrkyr8lozTXY1Wx8I+JZWVi+ZZZom506e
/f7odeur4k/dCSCgaZovlUpJIAZE4e+Kz3dXFU5Xq6oouzGuDupp/fJvhgd0/Din8aMAAAAA
SUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'!
smallRightFlushIcon
	"Private - Generated method"
	^ Icons
			at: #'smallRightFlush'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallRightFlushIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'!
smallRightFlushIconContents
	"Private - Method generated with the content of the file /home/dgd/smallRightFlush.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADKElEQVR4nG2T3WtbdRzGP79zTlPzVro0yUl2
kmW2c140btjKRLaAKBt4sW6Iu3AFoaBYhheieL8/QEHwYsx6ORDGUDpXfJnOi1bxBVEaXecw
TVqb13OStE1fkrTn9/MivXPfq+/F93l4eJ7nK3jUXL2qZRZLptwXlqawFFhCExYKC1QYxcz8
F9dnAQxAnJmYnhLIs56+vpFjjydTg3owPJBJaYGAH18giN/vw+f14/N5aTVrfDjzaRqYBRCZ
iem34ubQR+9eeY2hWILOnmCn67Ldlux2JPtSsS8Vrqvo7LlcOBViYvJtuh0ZWpi71jQU6tiz
42kC4SStXclGq4Xj1KnX69QbTRqNBpsbG0gl8foCvDQ2hRWPkF8tjQILhlDCHw0fIr+c46tv
7hEMBAgNhTgUCvHkE8MMDo4TCA6glGBfKvZcRSoZo/BvOQ0sGCBbSkrGnjrOydHjSKXo7rnU
bIdyxWbpr0WqVZvG+jqaULx3ZZJUIo7i93TPREFzZ7eNr19jzwUlFTdvzeJKiRmNMHI0wdnM
OMPJMIauAXA0GUMoRg9S0Jpb27t4DA1NKJQSTF2+QLlWx7EdbMfmy6X7lGsOrit59eVzpBJx
EPQUCKHs5kaLPl3wyY3PKKyW0HWdw2aY5OEoRyyT555JE4+G0Q8UtDtdhBDhFydeNw0h5XK5
4qBpgjcmL2IYOrouEAed2tlts7pW4dsHv7CyViFuhjl/7gxmJES12hg1BCJfqtpoAvo9BuIA
OXf3B77/8Tf8Xi9HLJNUMs7zp8dIJWIHPsQp205aAGQm3ty8c+OD4EDQ/79WtztdlleK5PJr
5FaKlCo270xf5ubsd9y6c2/G6J2pfLFinwj4vWSXcuQKa/xTKFJzGjzW72E4ZTGSsnjl/AtY
sQgA65tbgPD0CIRYLlWcE1YsQvZBjpGUxelTJzEjIbZ32uQKa+QKRX79/G5vXynRbnce6q54
3wAQqJ/nf/rjYtwcIhGPcv9hgdtfz5MrFKnU6lsC/lSQRZFVusj2Cz07f/t6vYcFRi9d8oQ6
Qx+DfFqg/Q1qUSmySmrZhblreUA98u2B/wBi/FnBrgGW6wAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallSaveAsIcon
	"Private - Generated method"
	^ Icons
			at: #'smallSaveAs'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSaveAsIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallSaveAsIconContents
	"Private - Method generated with the content of the file /home/dgd/smallSaveAs.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADIklEQVR4nIWTXWibBRSGny9fm37pSFqTNOlP
6qJrsv5gpRR1izqmjG2oqxeWug2ZDiqKG4oMBS8mgqhMREFBdyOo4EAnliIrrpYWVjfT0NLQ
tU1nN7vVNj9t07RJ87O0X443Y8458b193/ecc/Eclf+RZ7OtwWoqU5bX1jK3WQqA4b+K9TVm
m7e24utGr22y2KRfcLvd2g3L9nhLS99bhw4lAZ96x60u+0Fv8wM/H3n3020vPpPEoCjW0ZE5
Z6mWN391Yv9gq0fzNOvVxh+DwdV/FJudzk3eWvv375z4SPojBekNi3zz3Unp626XA7srC7HB
V0WGn5Wp03tll8MRAfb9fbK70t16n2e8yz8hvWGR/ojIyOV5eelwuwS6jokEO0X66qT3451S
V1nSDewGHABsrbE/1vbUnkT/nznpDYsElkQG/QHpfL5duk52igxul/Fvt8vx/dViNhUPAT5A
AzB4XPaD9U3WX44dcZQruRR1Zrh09hSvvHac4hILwYsx3vxylc8HsmzZ0YzbdVeLzWxyAjkA
taK89L03Xm+td9+9icWpM5iNXhobm9hcaSGbvMDDOzSslWX8frmU5zpqqHVZ1KFArCmRyvYA
q6pBUUpyGf3pKodFefSRCkYCA0xMJri3+hxtT1SRSOj8Mf8QpWYnPT2jHH15K/6hqCMSSYeu
r29Mq5ncejS5sr5lz053Qzyexuez47knjtOh0TcQ4Up4G/HlBH6/n9jidYLBGQLD4auLycwZ
XRdNBdYyeX16MhRv69hbZTaaTWhaEd0/zTIwuIKqpBgdmyGRWGF5KUooFL04G1t9O5/XM8CS
ClAoFKIFnXRBlydd5TnFUevApBk49cM1Xjhg49yvM8zPhsmmU+dnY8n3Nzb0HHAJCN0kMZ3L
j0dj+cZ9PmPDxNQyTfe7sNtUPvxkjIVIXFJr2dPXoitfiEgOGAbmAG5FeSOvK+eDk/mOw7vW
LPnYFQLTJn7zzyUXljIfhOOps8AyEABuIqzc/gdGI/X2MstRrajoQUXFEF1KfZbOrS8AU8BV
QG7N/2vADZmBWsAK6MAYkL5T8C8m0GUZPNX0AAAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallSaveIcon
	"Private - Generated method"
	^ Icons
			at: #'smallSave'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSaveIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallSaveIconContents
	"Private - Method generated with the content of the file /home/dgd/smallSave.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAC40lEQVR4nIWSXWxTdRjGf+ecWlqWdlvPoWXZ
JiWyTwQEP7JMTCQhKJkChgSVhCgXJhAW0XDBHYGQ4EdMTORCE6/0QkVnDGkIDAlLUKQUljX7
KmaQsVr7tbXrej7WdT39ewOGwNDn9n1+7/u8yaPwP2pZpXb43LVS3jCspeby48D2Ro/a2rzi
m85WdfwJt/1HMBh0LeVTlrzapO1tXf/8hUMnv+h6b3cRWZJ8Q4OJQMGYD/1n3PWBQE1rs/bj
8U8+E5dTVXExKcS3Z74S2dsHxZauYGWl5u15LNweXBl8dl3L6C/hMXExKcTllBAJU4jpbEac
79snLvTtFmsa1dseUB95oa1R29K2YePAse+vPOmob6DOCZtU8C2D5TU19PffoGebk0TC8E0l
rfo5c+E8UAWQW5q0ve1rfb8eOeSvk0o6azzwnApuBQxD5+vTR9m1PQfAh4c34ldr3lE9y1+7
n0CWZd7av69TCWgO5qMfsBAfRQLGRqKEfujlzTcsdL3CiY9TOBSZ93ufcdZ5XSeBVQCKLEnL
Spa9s8HvlV7avILByADXI3/hcfzMi121jIwVuDb0NLKznlBokN4DbYSvp/2plBlbWKxMKFZp
MV0sLD71ysvBjlzOpLtbo2V1joDfxaWBFHeSXeTys4TDYTLTC0Sjk0RuJu9OF61zti1cCmBY
ZXtiPJbbsefVBo/T48blcnA2FGfgtwKKpDM0PMnsbIH8TJpYLD0Sz8wdK5dtC5hRAKrVarpq
Y1Zt0dNUV5L8zX7cLpnv+qZ4922VK79P8nc8ybypX41niqcqFbsE/AnE/m2iWSqPpjPlzte7
nR1jt/Ks3dCEpip8+vkw2VRO6Mb8T1PpwpdCiBJwE0g8XOVK2ZauRsfLe/ZvNbzlzB0iE26u
hRPF7Iz1UTKn9wN5IALM3YekhxvpdNKu1Xp7XQ7HC5KCnJ7RT5ulxSxwC7gLiAf9jyy4Jw/Q
DPgAGxgGzKWM/wCIojxGWb3q0gAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallSelectIcon
	"Private - Generated method"
	^ Icons
			at: #'smallSelect'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSelectIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallSelectIconContents
	"Private - Method generated with the content of the file /home/dgd/smallSelect.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABK0lEQVR4nKXOO0oEQRAG4L+6q2cfjojgBmJi
YmroEQwNBBPxFF7AzBt4DMHcyFwUE2MRPIDruuxMd9VvsKCbrOJOQVNNPT5KcHK7gTjdA2UH
MQzgnoCQIJ6AEAE3QFqQBSFk0DMcBaot1uxOobPjm/ODy/WhxrqvWvei1r35v1+FUIzM5mwz
PZt7a2Qx98eX9/Hp1cOFJpV0uD8aYUmkKJJixLBCXKxv1qmCSz/0VKtly79FEJlnjdBVgG+o
CljpgoVLJP499guQVFInIDtKJ6DJ3nQCPps86wTkgoYAVwYAycXYARAW8/8DKQZBgCgczdPr
x3h3azBwEtmc5qQZWZx0gsXJUpzFOe85+fw2mQCIgrPrbVg6AtFAQgHpAOznyTzTHRCDLNRt
ev8FfDedurn+q90AAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/7/2004 13:42'!
smallSqueakIcon
	"Private - Generated method"
	^ Icons
			at: #'smallSqueak'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSqueakIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:49'!
smallSqueakIconContents
	"Private - Method generated with the content of the file /home/dgd/smallSqueak.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACWklEQVQ4jcWSW0hTARzGv52zeXY25ub0eEFd
BBsztbYcC8PWhZEsctm6jFlEWkQRBT4U0ioiirSHMAgzijDqLeqlop60jGhGiEoaydKtXXWX
pmdubpN5eukhTKM3v8f/x//38v2A1Q75j05UpVNfy5NLbdFwzANgCgCZV5h3qLiMaZ2JsjSA
sZUA5Jb62uFae3Mju1FZM+cLH6eynENdvfbe4dPWMw1NJj3KGWPSG6KXBejqNHeNF47uejo1
zWP7R5AqZ0hJcr7x7PlmlUgioi6fuA6/qpQWpRfy+csBKtUbjoiHEqj7HoCsQIVMGYEhZ0Cq
3WNAgUCAm/YupL66QcokxQQAHgkcLAH/EgAZAFRVa4TvevvQcqAJ2dgcnHMp7LfVo292Ft1+
PwiSACWikQzFUoQExK1OMHceg7m6GULHTsv2jkg0QnBiGi6XC8FgEJkgiwabCYowi8EbT+Af
/wG5VsnFIzND/CoI1+8DU7QIHixEVilpaWwrUinw6dE0KIqCx+MBXVOCjJdEca4YW5UK8E9a
4B33JOIT/nYiBzn5I+AjCAoDQoLU1WkgpQRob7XhQ+Ab1pmNsO7ehp+RBE7Z7CHn6EQ0PDYZ
i/YPdwIY4FMQHOuAp4uleSrVOaucTWfIZDyB9HwabRetWOA4OD5OYtTnRTKZvvK858XD3/6k
AID3pziMVvlerKuoUGyqFNDy3Jzc0kL0vv3M7fAtcu5w8OXgs9d7ly7GW3owm82v9Hq9UV6Q
H7/dc/+Ly+3uzoZn3wBIrCDd3xYaDAa7yWR6AGDN/z6tXn4B2ljYZPClNw8AAAAASUVORK5C
YII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallUndoIcon
	"Private - Generated method"
	^ Icons
			at: #'smallUndo'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallUndoIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
smallUndoIconContents
	"Private - Method generated with the content of the file /home/dgd/smallUndo.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACOklEQVR4nI3RT4iUdRzH8dfzPDOzOynJ7tZu
sJBCQaBJQUXkSiZeIumghy4FHpJOnez/QXfwECHBHjrpKS+CmEEbUst62A6CSMialmsabZjr
5Li27rizMz3PPL8OjYttSn5uv9/v83l/f9/vN3IXfURfke2Bm1McPUL7bj6Il19UeKWLi6uL
DpQih9fyyb3C/9EeKgcK8uu9QuiPwrdlYQ/ND+n53x8MM/J82fCbvVHUt2MnXxw3UABdJfbv
5rm3KC4HRJ3Kn75Q9s7Lfd28sZPZGuPHtG7d8msoqmZcbaYutcxmjMR8VmEeot1seqxkYscq
dHXTai7RFzOKMYW+Xp561sLAoNGDh0zVW3Mx2ypMJJvZN1SybqBAnGdL4Xbg7A3+WGTu5qIw
/Yue6Snr331fc2am+3LtxrYhDiabePjP3NYH/iIPrCgQRdRTrqScuN1oynwjs/LMSY+/94Hv
x8a7s2Au2czpRvDEdPBkf6DWII5YyPgp5/fc21eDHy8G6x9NdM3W2wbb89Keh0xfqTaSCcJ3
HN1A9UJuS54oljMaKaeCdIHXP+bYS1ya47XBwCP1qnjoRZOT535bWuNe9sesuZDZ9WXmzKmY
ZjC2j3rHci0ESglJnln4YVJErXDnTitcwwhGKm1PJ1Rvv+U8sybhwU6ien5KYPRfgGWwyTvP
gY39KHcS51vSmG/uCViuiGIh4nqTnwO1ts/3Mn/fgMDo16lXY2SZyxnDHfD9q8KGnHUxX1X+
mZe/ASGg28UCHOe+AAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallUpdateIcon
	"Private - Generated method"
	^ Icons
			at: #'smallUpdate'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallUpdateIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallUpdateIconContents
	"Private - Method generated with the content of the file /home/dgd/smallUpdate.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACz0lEQVR4nI3SW2hTBwDG8f85iSdpEnIxR+01
0TlmbawOWy8PdXZYFRXLVHwYLt5ARMUXH0Rh0DxIq1jQl3irw6KCSMecKDiYVZEZ6+jEFsrs
apektsY2tWnNSU/S0+T45IMgxO/5+35Pn8CXRyqysRmROoOIVReJSDl+MeZbOcx85XaYL2/Z
tnV1bd16saKyGovVgZJ8z/ZNNQvzAYt27tja/dOe3UJfLEXwfhjloQqiAX+1i5JS75J8gDh/
/jzhbqifJxNejHIFVWUzmcxo9IR7sNrs5nzAlDqp6mFVEYQCAZ9nJovnyuR0nbe9r3n+Ovom
HzCazkzp5aUOwW1zM8tupvvvByhDL1lTs5Shwcg1sbzUsq92xcK++rqVI99VL+gvdnLLbWHZ
R6C9/VFkTbWXRF+IcPtF0rF/WVtTyc0r5yfC72gRdmypGzjbcrPsRU8vnuLZSKLGrbartN24
8bb/VeRoMsd/P9av+8vhchlNZhMDkQGms9ncLM/immAw+FS0O53uI40XOPnnMAdau/Cf/oNh
oZizF84VHjy0r1VVGej8p6szq88gqYgsqKhiND7aVVRUdALAKCLqU7qRVb5isjmdjl4DnUkd
57OX2O02Ach0vxpe2xe97isw4RlTuAcotRtzjwHEWGww7il0kZvWMBkNfF3oACClTDIxkcwC
aUBRNZ6NKbQBSiAQcEqSpAIYX3SGWv0HjwXu3G7BOnseGYsXr7uQ5XPLaAn+PgJMAjQ1NS0T
BEFOp9OqLMtHotHoJQABkDasXvLcv3evr6M7yrSWwfNNJb45Art37W86fDTwsyzLv42Pj49o
mpaSJMmUSCTuNTc33/kIUAUW/6njqY5QCKvNSmwwRkpNx1d+X7+npKTkQCKRaG9oaDjzuaMY
AGKgxYf+r9hU/0O5JBWIY2PvctGheOjbquWueDz+a2NjY2uew30SJ2D70vIHGPAd/9jj14AA
AAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallVolumeIcon
	"Private - Generated method"
	^ Icons
			at: #'smallVolume'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallVolumeIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallVolumeIconContents
	"Private - Method generated with the content of the file /home/dgd/smallVolume.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAQAAAC1+jfqAAAAAmJLR0QA/4ePzL8AAAE3SURB
VHjajdE/SJRxHMfxF/f8Hp/n7vLhlAKhyKRCOpccA6EbFEW0BsciyKWphiBoCRuiQXEJnIyG
ampyEppydy8wBOFEyPzHA0X1wNGggV0Ivbbv8h3eH44rKWkT/XUNqdhxgrjz5kBTA90SiVlD
h0+PdI6PvZhKwDmPVL13G4KaOqcuTL+6k3z8iis+Sd0175pxy0H91ss066g+SKo+Q68uq4Zd
9M5DyyUdE6dHzg7XIrmdM7XHPriq8NoNaxJdgRypA7/Ezo8e9NjDpgzfhMC+kp92FXZb++u+
KKPbd5S1Ak2xVJ+WH3nzqQE5Jq3IpPJgY2GOrDe+NxhCYUvZkkGXvHHfkuJPhkr/4pNiZlsD
dbPq+ryVHS9Zqc1c39JAJhF5Zqw9dsXzw7yIXBb/u0fUNt7/+A0ZzEdfNHX2/wAAAABJRU5E
rkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallWindowIcon
	"Private - Generated method"
	^ Icons
			at: #'smallWindow'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallWindowIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'!
smallWindowIconContents
	"Private - Method generated with the content of the file /home/dgd/smallWindow.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAA80lEQVR4nO2PMUvDUBhFz5c+IjFp0YJD0SWL
i6OL0FIQQUQo/gk3wcXN0X8hOvgHXFRo54qWLoogKC2Eoh26iOBQadP3XpeOBpJBXLzj5TuH
+8FfR6q1/XC3XL7TYRgIjhWbfKyVFbEwiHofT7f3282b065yPW9zY/RVikpFbGGRfM5LFAzG
n1hg2XXzzavLQ+BYjb5j019bpbKyAFhgmDzBnwOg/vCGnsQ+UFQAeztVAn8+/eNbcHZ+AYCT
nvo5/wJwxDHj59coE/TS6WGMjgFU7OrGwdHJteQkSCuwEzN87z62AGTWrQNLmWaABtoZmV/I
FJjvR0sUmC0hAAAAAElFTkSuQmCC'! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
squeakIcon
	"Private - Generated method"
	^ Icons
			at: #'squeak'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self squeakIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:49'!
squeakIconContents
	"Private - Method generated with the content of the file /home/dgd/squeak.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAFoklEQVRIie2VbXBU1RnHf/fu3ddsNrtsdmGT
QN5gk2wQsiFWYpMgWE2DLaVqU5sPpEVq0VZn0k+ttaVjKwQcmLF+YIoNji/pkKYyrYQWMYIE
quhEA+ElWRuTkLqbCNld9m6yy97N3tsPDLbTzmjkmzP+Pp455/mdeeb/nANf8kVHdxNnbi2v
8m63Zmc9Il+NuzVNOw8o/7On0Ol2/MjpdjwxIyeqNE2TgBEA4XOIxPzi/D/mL1l0R8PGNQs/
SCY5deBoZiZ0ZU6vZDbOyrNHAJ07z9UxI89+984NDXqHy6ELjoVi7554X0kkEl2ZdObReQuL
vIWvtDx8/73OTY08NzlJQlVBVYl1HEY9cHwmfiW6wrbA+pi/duVD7fu3WRa4F5CYTRJJp9l3
LkBv8xPx8FS4QZyn7xs+f1n94u838btgkISqkgnLpAZHydl8D6am1VlZDtvBHId9y479v7bo
DXqe/MkuGvKb+GbxtzgeGGVpa5MEbJTmYytctuTx5f7lrt1Pv0RuaR4fPvUCXFNQVZVYOoNx
w+1Cvn/ZigdbN4hOtwMlpZDJZIjHZgDQHRtg5jtrzSazoXE+PrF+Xd1MMBjUuru7Nbe/TNu9
Z4+2d+9erezer2kvv7VfW1JeqBX6SrTD57u0d9OntYDWr51Jva25PLkaoJlqyrWC489ouR7X
h/Npqanav8rQ399PIBBg0/r7+GlbG5s3b6alqp6uaJTOY7/HbsuipKKYE7EYAAevRslxZANg
yDajxhMg6eZuCPXAVhH+IMFOoPa/hKniolKpo6ODrq4uVvurOXnyJBUVFaSupXjtyD+wL3Li
XV6KKIq8Mj3NoXCYU1emCV6aul7cmYM6Febq5ciIBGTr4LXbMXs2YS2IoQrPEtsqoz4VRd0F
iJejV9R0Oq2zWq3U1dXR3t6O3W5ncHAQpwOCqRS/2fcLAJySxJFIBOG5wyRnkwBYbvORGRhJ
zqWUPhH4+XqyrG/gKWolW3qMHN2b5NtsiI97K0t6Vn6l8lJgeFhsbm7GarViNBqZmJigpaUF
t9uNUW8gMDBKPHo9IHUnL9Jf+zBvPNMFQG6eC92aKuS/nY4CJ3QCbPsLC312JEMCCQGwIzAp
qMaC1ru8e/7Unu2vrxRePXKakekpli7MI5lM0tnZiaqqDCw282BJDaF/higoX0RFVRlKSuGd
4/1Ysi1Ubt+KcnEsM3Wwbwh4UhIRDDI24wXMaDdSQgazIAvuskIAFrgd/HDbfXjluxjsvEBr
ayuBQIBFHg9n1now63TYbIv52cuHeGBpMT/+5RZubfBz4FqCM+NBIu2dMU3TfgVoUinmcDey
9ADmT1Iyi8jf9Wna71hFcDz0yfpah40ui8zY+DhtbW207N/NQ6ub+Pj1ECWLl3G055R2bvCF
i5U1Pl9BUZ4gjwX5uLs3PZdK7wJeB5DuxrntVcJ3p0FqIAeZDM8ziX9dDUtKC1BVlVQyRTw2
y/RUmB+0fp3u/vP0BMb43vYtbHK5mMgXGZ4YRRwNXRsZGq8vLC+6rfevJx6dvDQpz6XSHUDv
jUsLAN8m1ztEYk8KbUXcIlotDSvtu/+8Q7jFYiEWkVFSCiazEVOWBZ1ORKf7z/j2HX2PcouP
nvdP8/yLHQOX3xuu/rSh/v/Hu9i9UK+J54R11bkNj9wvrDMYKTeZyJH0uDy5GE0GkqrKcCJB
XyyG8dhHrPEs5bdP7wj3H33TA6Q/n/A6ea4Sz7OynLgn685V6my116i/pVjMynOhZDLIsVky
Z0fIfntIq01b1JH45UOjve80f5bs04QA1NTU9NbW1n41FAqlLv1rQhQknRqORMSP5EhAyahv
EZ3pQ1F6gNRnieaL3efzXdi5c2fi7NmzmizLWmNj4weA/WYLzusD9nq9651O51ZFUYShoaF9
iUTi0M0Kv+SLz78BjzNWmYcZV74AAAAASUVORK5CYII='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
volumeIcon
	"Private - Generated method"
	^ Icons
			at: #'volume'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self volumeIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
volumeIconContents
	"Private - Method generated with the content of the file /home/dgd/volume.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAQAAABKfvVzAAAABGdBTUEAALGOfPtRkwAAACBj
SFJNAAB6JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VGAAAAAmJLR0QA/4ePzL8A
AAAJcEhZcwAACxMAAAsTAQCanBgAAAHrSURBVDjLldTLahRBFMbx/xu02hEvm1mZIC4qovaA
LhoE142+QIMvILoRgjASdKEilSBxO5CFIhKbmUAQNWmD6KCQxCAMEi+JGGKISuETfC665uIM
DqRqd6hfn9Nd5zRidxsBV/jOH5rc5QhjJBDwnyUQ43xmix9ssMo8GRiygaBBg0dMM887FsCE
jvyfUwEZaRdY5CrDnOUyt8GE7pbaIKEEgEGYNnjpowmYIXdfeQfErJMAUCliArFMAJwEM+Sm
9V5r6iopIC+eXdDiK1lycux+90Qb2tavAlQxFxgBwwoAl8haIH+sTKN6oZ/6rW1ttjJYzEMO
QZUEKPnTgnxHmzqjHW3pm77ooxApEFC9QwoxVV+U8eCTmirrq9bU1KqWVNZBEewDe55JwGfM
iT1Y0hud0gct661ea1HndEzEQOUiUxzoBwt6quNq6JVyPdOcTuuwCE6AtUywpx/Mqq5RPdec
ZlVTTTjSBxBgp7gGCRYA136HG7qpYU2qrppqqou8VtxAcI8RyDBACddzD6GzbTAOFYIxjkLs
C6pQbYHWMqGbUF11kcNeH2OdEhDgiHsBmNBZzXRaI2XFN4YtWr4LREREYEJ3vQNKfpRSXNGh
PaBMBIb+ebA+Tz/wZPDE0ZMjgiAaBHb919jd/gvLk2YJrn7DBgAAAABJRU5ErkJggg=='! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
windowIcon
	"Private - Generated method"
	^ Icons
			at: #'window'
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self windowIconContents readStream) ].! !

!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'!
windowIconContents
	"Private - Method generated with the content of the file /home/dgd/window.png"
	^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB5UlEQVR4nO2WP2gTURzHP/fuEqMpZ1vUKBqq
FHFTB/+0XVSKRSxCBUVHQXHoUHeh4thFVwcnFwWdNFBErWgVVBIXBRGs1pZEjamtucvl7nKX
O4fkoPXPkHqCw32m977vz4f3ePB7EBEyUtDoGzrbLRDpMDeX63XjceZqDvCDTAHoP3HuwsHd
uy5uVNukuXQXruSR8ORlSaqyS6IuYwqX79MFfKG8mLx9pWeJcNv2HSOnx69Lq18+Z+zRJHmj
xNEt+5Al0ZJs3tZ4kM/SrW7ivZant7+Xzx9n9n79NHDkbfbeXcBRAN69eq3cHzzJ+sPHWGsn
SMopSvlCy6fz8NmqpOiwYgglxdybaWanpjArCzuBBeCpAmCZVZ4Uiwzs30NXpdRcXm5ZCLAO
AJ2U6/Iwl8N1nGCoA5pXGospjI0Oo7YllyX5E4cO9HD8zHlmF2UCYE1nuwhbBhCPx9ic3rAk
a+1VhEAkjISR8D8RGlXT9zzvnwjKuvGrsKxXStdujmPZtdBEtZrDrTsTfJgpUDMqepBLAH2D
p4aFiF+WJGlFaMYGvmVoz7ITNy4BDpAJvhirVibVoaTaqYZps23L1ue/BHXOATJKs2OahvbN
NDQrTOFPFGHRJwqQaRRJ6bfT/w6XRsWPCJ8feQeiSATBXJcAAAAASUVORK5CYII='! !


!MenuIcons class methodsFor: 'icons creation' stamp: 'dgd 9/22/2004 18:28'!
base64ContentsOfFileNamed: aString 
	"Private - convenient method"
	
	| file base64Contents |
	file := FileStream readOnlyFileNamed: aString.
	base64Contents := (Base64MimeConverter mimeEncode: file binary) contents.
	file close.
	^ base64Contents! !

!MenuIcons class methodsFor: 'icons creation' stamp: 'dgd 4/20/2006 12:31'!
createIconMethodsFromDirectory: directory 
	"
	Preferences disable: #showWorldMainDockingBar. 
	MenuIcons createIconMethodsFromDirectory: '/home/dgd/'. 
	Preferences enable: #showWorldMainDockingBar.
	"
	| iconContentsSourceTemplate iconSourceTemplate normalSize smallSize |
	iconContentsSourceTemplate := '{1}IconContents
	"Private - Method generated with the content of the file {2}"
	^ ''{3}'''.
	iconSourceTemplate := '{1}Icon
	"Private - Generated method"
	^ Icons
			at: #''{1}''
			ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self {1}IconContents readStream) ].'.
	""
	normalSize := #('back' 'configuration' 'confirm' 'forward' 'fullScreen' 'help' 'home' 'jump' 'objectCatalog' 'objects' 'paint' 'project' 'publish' 'squeak' 'volume' 'window' 'open' 'loadProject' ).
	smallSize := #('smallExport' 'smallAuthoringTools' 'smallDebug' 'smallBack' 'smallCancel' 'smallConfiguration' 'smallCopy' 'smallCut' 'smallDelete' 'smallDoIt' 'smallExpert' 'smallFind' 'smallForward' 'smallFullScreen' 'smallHelp' 'smallHome' 'smallInspectIt' 'smallJump' 'smallLanguage' 'smallNew' 'smallObjectCatalog' 'smallObjects' 'smallOk' 'smallOpen' 'smallPaint' 'smallPaste' 'smallPrint' 'smallProject' 'smallPublish' 'smallQuit' 'smallRedo' 'smallRemoteOpen' 'smallSave' 'smallSaveAs' 'smallSelect' 'smallSqueak' 'smallUndo' 'smallUpdate' 'smallVolume' 'smallWindow' 'smallLeftFlush' 'smallCentered' 'smallJustified' 'smallRightFlush' 'smallFonts' 'smallLoadProject' ).
	normalSize , smallSize
		do: [:each | 
			| png base64 contentsSelector selector | 
			png := directory , each , '.png'.
			base64 := self base64ContentsOfFileNamed: png.
			""
			contentsSelector := (each , 'IconContents') asSymbol.
			((self respondsTo: contentsSelector)
					and: [(self perform: contentsSelector)
							= base64])
				ifFalse: [| contentsSource | 
					contentsSource := iconContentsSourceTemplate format: {each. png. base64}.
					self class compile: contentsSource classified: 'private - icons'].
			""
			selector := (each , 'Icon') asSymbol.
			(self respondsTo: selector)
				ifFalse: [| source | 
					source := iconSourceTemplate format: {each}.
					self class compile: source classified: 'private - icons']].
	""
	self initializeIcons! !


!MenuIcons class methodsFor: '*omnibrowser-services' stamp: 'cwp 7/10/2006 22:32'!
tryIcons: anArray
	| selector |
	selector := anArray detect: [:ea | self respondsTo: ea] ifNone: [self blankIcon].
	^ MenuIcons perform: selector! !
StringMorph subclass: #MenuItemMorph
	instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon'
	classVariableNames: 'SubMenuMarker'
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!MenuItemMorph commentStamp: '<historical>' prior: 0!
I represent an item in a menu.

Instance variables:
	isEnabled 	<Boolean>	True if the menu item can be executed.
	subMenu 	<MenuMorph | nil>	The submenu to activate automatically when the user mouses over the item.
	isSelected 	<Boolean>	True if the item is currently selected.
	target 		<Object>		The target of the associated action.
	selector 		<Symbol>	The associated action.
	arguments 	<Array>		The arguments for the associated action.
	icon		<Form | nil>	An optional icon form to be displayed to my left.

If I have a dynamic marker, created by strings like <yes> or <no> in my contents, it will be installed as a submorph.!


!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 20:16'!
adaptToWorld: aWorld

	super adaptToWorld: aWorld.
	target _ target adaptedToWorld: aWorld.! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'sw 10/3/2002 20:50'!
allWordingsNotInSubMenus: verbotenSubmenuContentsList
	"Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in any submenu whose tag is in verbotenSubmenuContentsList"

	self isStayUpItem ifTrue:[^ #()].
	subMenu ifNotNil:
		[^ (verbotenSubmenuContentsList includes: self contents asString)
			ifTrue:
				[#()]
			ifFalse:
				[subMenu allWordingsNotInSubMenus: verbotenSubmenuContentsList]].

	^ Array with: self contents asString! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
arguments

	^ arguments
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
arguments: aCollection

	arguments _ aCollection.
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:58'!
contentString
	^self valueOfProperty: #contentString! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:51'!
contentString: aString 
	aString isNil 
		ifTrue: [self removeProperty: #contentString]
		ifFalse: [self setProperty: #contentString toValue: aString]! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/17/2000 18:32'!
contents: aString
	^self contents: aString withMarkers: true! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:57'!
contents: aString withMarkers: aBool
	^self contents: aString withMarkers: aBool inverse: false! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:55'!
contents: aString withMarkers: aBool inverse: inverse 
	"Set the menu item entry. If aBool is true, parse aString for embedded markers."

	| markerIndex marker |
	self contentString: nil.	"get rid of old"
	aBool ifFalse: [^super contents: aString].
	self removeAllMorphs.	"get rid of old markers if updating"
	self hasIcon ifTrue: [ self icon: nil ].
	(aString notEmpty and: [aString first = $<]) 
		ifFalse: [^super contents: aString].
	markerIndex := aString indexOf: $>.
	markerIndex = 0 ifTrue: [^super contents: aString].
	marker := (aString copyFrom: 1 to: markerIndex) asLowercase.
	(#('<on>' '<off>' '<yes>' '<no>') includes: marker) 
		ifFalse: [^super contents: aString].
	self contentString: aString.	"remember actual string"
	marker := (marker = '<on>' or: [marker = '<yes>']) ~= inverse 
				ifTrue: [self onImage]
				ifFalse: [self offImage].
	super contents:  (aString copyFrom: markerIndex + 1 to: aString size).
	"And set the marker"
	marker := ImageMorph new image: marker.
	marker position: self left @ (self top + 2).
	self addMorphFront: marker! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'!
hasIcon
	"Answer whether the receiver has an icon."
	^ icon notNil! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'!
hasIconOrMarker
	"Answer whether the receiver has an icon or a marker."
	^ self hasIcon or: [ submorphs isEmpty not ]! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:25'!
hasMarker
	"Answer whether the receiver has a marker morph."
	^ submorphs isEmpty not! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:40'!
hasSubMenu
	"Return true if the receiver has a submenu"
	^subMenu notNil! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:18'!
hasSubMenu: aMenuMorph
	subMenu ifNil:[^false].
	subMenu == aMenuMorph ifTrue:[^true].
	^subMenu hasSubMenu: aMenuMorph! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 3/22/2003 14:45'!
icon
	"answer the receiver's icon"
	^ icon! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 19:00'!
icon: aForm 
	"change the the receiver's icon"
	icon := aForm.
	self height: self minHeight.
self width: self minWidth! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
isEnabled

	^ isEnabled
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'hg 12/8/2001 13:22'!
isEnabled: aBoolean

	isEnabled = aBoolean ifTrue: [^ self].
	isEnabled _ aBoolean.
	self color: (aBoolean ifTrue: [Color black] ifFalse: [Color lightGray]).
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'RAA 1/18/2001 18:24'!
isStayUpItem

	^selector == #toggleStayUp: or: [selector == #toggleStayUpIgnore:evt:]! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:22'!
itemWithWording: wording
	"If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil."
	(self contents asString sameAs: wording) ifTrue:[^self].
	subMenu ifNotNil:[^subMenu itemWithWording: wording].
	^nil! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
selector

	^ selector
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
selector: aSymbol

	selector _ aSymbol.
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
subMenu

	^ subMenu
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
subMenu: aMenuMorph

	subMenu _ aMenuMorph.
	self changed.
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
target

	^ target! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
target: anObject

	target _ anObject.
! !


!MenuItemMorph methodsFor: 'copying' stamp: 'sw 9/25/2002 03:24'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

	super veryDeepFixupWith: deepCopier.
	target _ deepCopier references at: target ifAbsent: [target].
	arguments notNil ifTrue:
	[arguments _ arguments collect: [:each |
		deepCopier references at: each ifAbsent: [each]]]! !

!MenuItemMorph methodsFor: 'copying' stamp: 'dgd 3/22/2003 14:56'!
veryDeepInner: deepCopier 
	"Copy all of my instance variables. Some need to be not copied  
	at all, but shared. Warning!!!! Every instance variable defined in  
	this class must be handled. We must also implement  
	veryDeepFixupWith:. See DeepCopier class comment."
	super veryDeepInner: deepCopier.
	isEnabled := isEnabled veryDeepCopyWith: deepCopier.
	subMenu := subMenu veryDeepCopyWith: deepCopier.
	isSelected := isSelected veryDeepCopyWith: deepCopier.
	icon := icon veryDeepCopyWith: deepCopier.
	"target := target.		Weakly copied"
	"selector := selector.		a Symbol"
	arguments := arguments! !


!MenuItemMorph methodsFor: 'drawing' stamp: 'dgd 7/28/2005 13:13'!
drawOn: aCanvas 
	| stringColor stringBounds |
	isSelected & isEnabled
		ifTrue: [aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle.
			stringColor := color negated]
		ifFalse: [stringColor := color].
	stringBounds := bounds.
	self isInDockingBar
		ifTrue: [stringBounds := stringBounds left: stringBounds left
							+ (Preferences tinyDisplay
									ifTrue: [1]
									ifFalse: [4])].
	self hasIcon
		ifTrue: [| iconForm | 
			iconForm := self iconForm.
			aCanvas translucentImage: iconForm at: stringBounds left @ (self top + (self height - iconForm height // 2)).
			stringBounds := stringBounds left: stringBounds left + iconForm width + 2].
	self hasMarker
		ifTrue: [stringBounds := stringBounds left: stringBounds left + self submorphBounds width + 8].
	stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2.
	aCanvas
		drawString: contents
		in: stringBounds
		font: self fontToUse
		color: stringColor.
	self hasSubMenu
		ifTrue: [| subMenuMarker subMenuMarkerPosition | 
			subMenuMarker := self subMenuMarker.
			subMenuMarkerPosition := self right - subMenuMarker width @ (self top + self bottom - subMenuMarker height // 2).
			self isInDockingBar
				ifTrue: [subMenuMarkerPosition := subMenuMarkerPosition - (4 @ -1)].
			aCanvas paintImage: subMenuMarker at: subMenuMarkerPosition]! !


!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:38'!
activateOwnerMenu: evt
	"Activate our owner menu; e.g., pass control to it"
	owner ifNil:[^false]. "not applicable"
	(owner fullContainsPoint: evt position) ifFalse:[^false].
	owner activate: evt.
	^true! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:37'!
activateSubmenu: evt
	"Activate our submenu; e.g., pass control to it"
	subMenu ifNil:[^false]. "not applicable"
	(subMenu fullContainsPoint: evt position) ifFalse:[^false].
	subMenu activate: evt.
	self removeAlarm: #deselectTimeOut:.
	^true! !

!MenuItemMorph methodsFor: 'events' stamp: 'dgd 9/9/2004 21:09'!
deselectTimeOut: evt
	"Deselect timout. Now really deselect"
	owner selectedItem == self
		ifTrue:[
			evt hand newMouseFocus: nil.
			owner selectItem: nil event: evt].
! !

!MenuItemMorph methodsFor: 'events' stamp: 'sw 2/7/2001 00:03'!
doButtonAction
	"Called programattically, this should trigger the action for which the receiver is programmed"

	self invokeWithEvent: nil! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 22:45'!
handleMouseUp: anEvent
	"The handling of control between menu item requires them to act on mouse up even if not the current focus. This is different from the default behavior which really only wants to handle mouse ups when they got mouse downs before"
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand releaseMouseFocus: self.
	anEvent wasHandled: true.
	anEvent blueButtonChanged
		ifTrue:[self blueButtonUp: anEvent]
		ifFalse:[self mouseUp: anEvent].! !

!MenuItemMorph methodsFor: 'events' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

	^ true
! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 9/16/2000 14:40'!
handlesMouseOver: anEvent
	^true! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 9/18/2000 21:46'!
handlesMouseOverDragging: evt
	^true! !

!MenuItemMorph methodsFor: 'events' stamp: 'RAA 1/18/2001 18:21'!
invokeWithEvent: evt
	"Perform the action associated with the given menu item."

	| selArgCount w |
	self isEnabled ifFalse: [^ self].
	target class == HandMorph ifTrue: [(self notObsolete) ifFalse: [^ self]].
	owner ifNotNil:[self isStayUpItem ifFalse:[
		self flag: #workAround. "The tile system invokes menus straightforwardly so the menu might not be in the world."
		(w _ self world) ifNotNil:[
			owner deleteIfPopUp: evt.
			"Repair damage before invoking the action for better feedback"
			w displayWorldSafely]]].
	selector ifNil:[^self].
	Cursor normal showWhile: [  "show cursor in case item opens a new MVC window"
		(selArgCount _ selector numArgs) = 0
			ifTrue:
				[target perform: selector]
			ifFalse:
				[selArgCount = arguments size
					ifTrue: [target perform: selector withArguments: arguments]
					ifFalse: [target perform: selector withArguments: (arguments copyWith: evt)]]].! !

!MenuItemMorph methodsFor: 'events' stamp: 'dgd 9/9/2004 20:31'!
mouseDown: evt
	"Handle a mouse down event. Menu items get activated when the mouse is over them."

	evt shiftPressed ifTrue: [^ super mouseDown: evt].  "enable label editing" 

	(self isInDockingBar
			and:[isSelected]
			"and:[owner selectedItem == self]")
		ifTrue:[
			evt hand newMouseFocus: nil.
			owner selectItem: nil event: evt. ]
		ifFalse:[
			evt hand newMouseFocus: owner. "Redirect to menu for valid transitions"
			owner selectItem: self event: evt. ]
! !

!MenuItemMorph methodsFor: 'events' stamp: 'dgd 9/9/2004 20:37'!
mouseEnter: evt
	"The mouse entered the receiver"

	owner ifNotNil: [owner stayUp ifFalse: [self mouseEnterDragging: evt]].

	self isInDockingBar ifTrue:[
		(owner selectedItem notNil
				and:[owner selectedItem ~~ self])
			ifTrue:[owner selectItem: self event: evt.].
	].
! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 00:24'!
mouseEnterDragging: evt
	"The mouse entered the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
	evt hand mouseFocus == owner ifTrue:[owner selectItem: self event: evt]! !

!MenuItemMorph methodsFor: 'events' stamp: 'sw 5/5/2001 00:25'!
mouseLeave: evt
	"The mouse has left the interior of the receiver..."

	owner ifNotNil: [owner stayUp ifFalse: [self mouseLeaveDragging: evt]]! !

!MenuItemMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 14:52'!
mouseLeaveDragging: evt 
	"The mouse left the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."

	owner ifNil: [^self].
	evt hand mouseFocus == owner ifFalse: [^self].
	"If we have a submenu, make sure we've got some time to enter it before actually leaving the menu item"
	subMenu isNil 
		ifTrue: [owner selectItem: nil event: evt]
		ifFalse: 
			[self 
				addAlarm: #deselectTimeOut:
				with: evt
				after: 500]! !

!MenuItemMorph methodsFor: 'events' stamp: 'dgd 9/9/2004 21:20'!
mouseUp: evt
	"Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
	evt hand mouseFocus == owner ifFalse:[^self].
	self contentString ifNotNil:[
		self contents: self contentString withMarkers: true inverse: true.
		self refreshWorld.
		(Delay forMilliseconds: 200) wait].

	self isInDockingBar
		ifTrue:[ owner rootMenu selectItem: nil event: evt ]
		ifFalse:[ self deselect: evt ].

	self invokeWithEvent: evt.		
! !


!MenuItemMorph methodsFor: 'grabbing' stamp: 'spfa 3/13/2004 18:34'!
aboutToBeGrabbedBy: aHand
	"Don't allow the receiver to act outside a Menu"
	| menu box |
	(owner notNil and:[owner submorphs size = 1]) ifTrue:[
		"I am a lonely menuitem already; just grab my owner"
		owner stayUp: true.
		^owner 	aboutToBeGrabbedBy: aHand].
	box _ self bounds.
	menu _ MenuMorph new defaultTarget: nil.
	menu addMorphFront: self.
	menu bounds: box.
	menu stayUp: true.
	self isSelected: false.
	^menu! !

!MenuItemMorph methodsFor: 'grabbing' stamp: 'spfa 3/13/2004 18:32'!
duplicateMorph: evt
	"Make and return a duplicate of the receiver's argument"
	| dup menu |
	dup _ self duplicate isSelected: false.
	menu _ MenuMorph new defaultTarget: nil.
	menu addMorphFront: dup.
	menu bounds: self bounds.
	menu stayUp: true.
	evt hand grabMorph: menu from: owner. "duplicate was ownerless so use #grabMorph:from: here"
	^menu! !


!MenuItemMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 extent: 10 @ 10! !

!MenuItemMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 02:05'!
deleteIfPopUp: evt
	"Recurse up for nested pop ups"
	owner ifNotNil:[owner deleteIfPopUp: evt].! !

!MenuItemMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:43'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	contents _ ''.
	hasFocus _ false.
	isEnabled _ true.
	subMenu _ nil.
	isSelected _ false.
	target _ nil.
	selector _ nil.
	arguments _ nil.
	font _ Preferences standardMenuFont.
	self hResizing: #spaceFill;
		 vResizing: #shrinkWrap! !


!MenuItemMorph methodsFor: 'layout' stamp: 'dgd 9/4/2004 15:49'!
minHeight
	| iconHeight |
	iconHeight := self hasIcon
				ifTrue: [self icon height + 2]
				ifFalse: [0].
	^ self fontToUse height max: iconHeight ! !

!MenuItemMorph methodsFor: 'layout' stamp: 'dgd 7/28/2005 13:12'!
minWidth
	| subMenuWidth iconWidth markerWidth margin |
	subMenuWidth := self hasSubMenu
				ifTrue: [10]
				ifFalse: [0].
	iconWidth := self hasIcon
				ifTrue: [self icon width + 2]
				ifFalse: [0].
	markerWidth := self hasMarker
				ifTrue: [self submorphBounds width + 8]
				ifFalse: [0].
	margin := (self isInDockingBar)
				ifTrue: [Preferences tinyDisplay ifFalse:[10] ifTrue:[4]]
				ifFalse: [0].
	^ (self fontToUse widthOfString: contents)
		+ subMenuWidth + iconWidth + markerWidth + margin! !


!MenuItemMorph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:58'!
hResizing
	"Default to #spaceFill"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#spaceFill] ifNotNil:[props hResizing].! !

!MenuItemMorph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:59'!
vResizing
	"Default to #shrinkWrap"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#shrinkWrap] ifNotNil:[props vResizing].! !


!MenuItemMorph methodsFor: 'meta actions' stamp: 'ar 10/10/2000 02:13'!
wantsHaloFromClick
	"Only if I'm not a lonely submenu"
	^owner notNil and:[owner submorphs size > 1]! !


!MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/13/2004 20:29'!
adjacentTo
	self isInDockingBar
		ifFalse: [^ {self bounds topRight + (10 @ 0). self bounds topLeft}].
	""
	owner isFloating
		ifTrue: [^ {self bounds bottomLeft + (5 @ 5)}].
	owner isAdheringToTop
		ifTrue: [^ {self bounds bottomLeft + (5 @ 5)}].
	owner isAdheringToLeft
		ifTrue: [^ {self bounds topRight + (5 @ 5)}].
	""
	owner isAdheringToBottom
		ifTrue: [^ {self bounds topLeft + (5 @ 5)}].
	owner isAdheringToRight
		ifTrue: [^ {self bounds topLeft + (5 @ -5)}].
	""
	^ {self bounds bottomLeft + (3 @ 5)}! !

!MenuItemMorph methodsFor: 'selecting' stamp: 'ar 10/10/2000 01:39'!
deselect: evt
	self isSelected: false.
	subMenu ifNotNil: [
		owner ifNotNil:[owner activeSubmenu: nil].
		self removeAlarm: #deselectTimeOut:].! !

!MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/9/2004 21:26'!
isSelected
	^ isSelected ! !

!MenuItemMorph methodsFor: 'selecting' stamp: 'ar 9/18/2000 11:09'!
isSelected: aBoolean

	isSelected _ aBoolean.
	self changed.
! !

!MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/1/2004 18:52'!
select: evt
	self isSelected: true.
	owner activeSubmenu: subMenu.
	subMenu ifNotNil: [
		subMenu delete.
		subMenu
			popUpAdjacentTo: self adjacentTo
			forHand: evt hand
			from: self.
		subMenu selectItem: nil event: evt].! !



!MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:15'!
bottomArrow
	^ ColorForm
		mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 90) asFormOfDepth:8)! !

!MenuItemMorph methodsFor: 'private' stamp: 'hg 8/3/2000 15:21'!
deselectItem
	| item |
	self isSelected: false.
	subMenu ifNotNil: [subMenu deleteIfPopUp].
	(owner isKindOf: MenuMorph) ifTrue:
		[item _ owner popUpOwner.
		(item isKindOf: MenuItemMorph) ifTrue: [item deselectItem]].
! !

!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 17:10'!
iconForm
	"private - answer the form to be used as the icon"
	^ isEnabled
		ifTrue: [self icon]
		ifFalse: [self icon asGrayScale]! !

!MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:16'!
leftArrow
	^ ColorForm
		mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 180)asFormOfDepth: 8)! !

!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/18/2000 10:27'!
notObsolete
	"Provide backward compatibility with messages being sent to the Hand.  Remove this when no projects made prior to 2.9 are likely to be used.  If this method is removed early, the worst that can happen is a notifier when invoking an item in an obsolete menu."

	(HandMorph canUnderstand: (selector)) ifTrue: [^ true]. 	"a modern one"

	self inform: 'This world menu is obsolete.
Please dismiss the menu and open a new one.'.
	^ false
! !

!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/17/2000 18:36'!
offImage
	"Return the form to be used for indicating an '<off>' marker"
	| form |
	form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16.
	(form getCanvas)
		frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.9) 
			borderWidth: 1 borderColor: Color black.
	^form! !

!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/19/2000 09:34'!
onImage
	"Return the form to be used for indicating an '<off>' marker"
	| form |
	form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16.
	(form getCanvas)
		frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8) 
			borderWidth: 1 borderColor: Color black;
		fillRectangle: (form boundingBox insetBy: 2) fillStyle: Color black.
	^form! !

!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 18:07'!
rightArrow

	^ SubMenuMarker! !

!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 17:51'!
selectionFillStyle
	"answer the fill style to use with the receiver is the selected  
	element"
	| fill baseColor preferenced |
	Display depth <= 2
		ifTrue: [^ Color gray].

	preferenced := Preferences menuSelectionColor.
	preferenced notNil ifTrue:[^ preferenced].

	baseColor := owner color negated.
	Preferences gradientMenu
		ifFalse: [^ baseColor].
	fill := GradientFillStyle ramp: {0.0 -> baseColor twiceLighter . 1 -> baseColor twiceDarker}.
	fill origin: self topLeft.
	(self isInDockingBar
			and: [self owner isVertical not])
		ifTrue: [fill direction: 0 @ self height]
		ifFalse: [fill direction: self width @ 0].
	^ fill! !

!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 18:09'!
subMenuMarker
	"private - answer the form to be used as submenu marker"
	self isInDockingBar
		ifFalse: [^ self rightArrow].
	""
	owner isFloating
		ifTrue: [^ self bottomArrow].
	owner isAdheringToTop
		ifTrue: [^ self bottomArrow].
	owner isAdheringToBottom
		ifTrue: [^ self upArrow].
owner isAdheringToLeft ifTrue:[^ self rightArrow].
owner isAdheringToRight ifTrue:[^ self leftArrow].
	""
	^ self rightArrow! !

!MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:16'!
upArrow
	^ ColorForm
		mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 270)asFormOfDepth: 8)! !

!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 19:24'!
updateLayoutInDockingBar
	self isInDockingBar
		ifFalse: [^ self].
	""
	owner isVertical
		ifTrue: [""
			self hResizing: #spaceFill.
			self vResizing: #shrinkWrap]
		ifFalse: [""
			self hResizing: #shrinkWrap.
			self vResizing: #spaceFill].
	self extent: self minWidth @ self minHeight! !


!MenuItemMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/9/2004 20:25'!
noteNewOwner: aMorph 
	"I have just been added as a submorph of aMorph"
	super noteNewOwner: aMorph.

	self updateLayoutInDockingBar! !


!MenuItemMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 18:29'!
ownerChanged
	"The receiver's owner, some kind of a pasteup, has changed its 
	layout."
	super ownerChanged.
	self updateLayoutInDockingBar! !


!MenuItemMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:11'!
roundedCorners
	"Return a list of those corners to round"
	self isInDockingBar
		ifFalse: [^ super roundedCorners].
	""
	owner isFloating
		ifTrue: [^ #(1 4 )].
	owner isAdheringToTop
		ifTrue: [^ #(1 4 )].
	owner isAdheringToBottom
		ifTrue: [^ #(2 3 )].
	owner isAdheringToLeft
		ifTrue: [^ #(1 2 )].
	owner isAdheringToRight
		ifTrue: [^ #(3 4 )].
	""
	^ #(1 2 3 4 )! !

!MenuItemMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:11'!
wantsRoundedCorners
	^ self isInDockingBar
		ifTrue: [true]
		ifFalse: [super wantsRoundedCorners]! !

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

MenuItemMorph class
	instanceVariableNames: ''!

!MenuItemMorph class methodsFor: 'class initialization' stamp: 'jm 11/16/97 09:17'!
initialize
	"MenuItemMorph initialize"

	| f |
	f _ Form
		extent: 5@9
		fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648)
		offset: 0@0.
	SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f.
! !


!MenuItemMorph class methodsFor: '*eToys-scripting' stamp: 'sw 2/7/2001 00:04'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (
			(command fire 'trigger any and all of this object''s button actions'))))
! !
Morph subclass: #MenuLineMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!

!MenuLineMorph methodsFor: 'drawing' stamp: 'sd 11/8/2003 16:00'!
drawOn: aCanvas 
	| baseColor |
	baseColor := Preferences menuColorFromWorld
				ifTrue: [owner color twiceDarker]
				ifFalse: [Preferences menuAppearance3d
						ifTrue: [owner color]
						ifFalse: [Preferences menuLineColor]].
	Preferences menuAppearance3d
		ifTrue: [
			aCanvas
				fillRectangle: (bounds topLeft corner: bounds rightCenter)
				color: baseColor twiceDarker.
			
			aCanvas
				fillRectangle: (bounds leftCenter corner: bounds bottomRight)
				color: baseColor twiceLighter]
		ifFalse: [
			aCanvas
				fillRectangle: (bounds topLeft corner: bounds bottomRight)
				color: baseColor]! !


!MenuLineMorph methodsFor: 'initialization' stamp: 'ar 11/8/2000 23:09'!
initialize
	super initialize.
	self hResizing: #spaceFill; vResizing: #spaceFill.! !


!MenuLineMorph methodsFor: 'layout' stamp: 'dgd 9/1/2004 19:20'!
minHeight
	"answer the receiver's minHeight"
	^ self isInDockingBar
		ifTrue: [owner isVertical
				ifTrue: [2]
				ifFalse: [10]]
		ifFalse: [2]! !

!MenuLineMorph methodsFor: 'layout' stamp: 'dgd 9/1/2004 19:21'!
minWidth
	"answer the receiver's minWidth"
	^ self isInDockingBar
		ifTrue: [owner isVertical
				ifTrue: [10]
				ifFalse: [2]]
		ifFalse: [10]! !


!MenuLineMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/1/2004 19:12'!
noteNewOwner: aMorph 
	"I have just been added as a submorph of aMorph"
	super noteNewOwner: aMorph.
	self updateLayoutInDockingBar! !


!MenuLineMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 19:12'!
ownerChanged
	"The receiver's owner, some kind of a pasteup, has changed its 
	layout."
	super ownerChanged.
	self updateLayoutInDockingBar! !


!MenuLineMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 19:20'!
updateLayoutInDockingBar
	self isInDockingBar
		ifFalse: [^ self].
	""
	owner isVertical
		ifFalse: [""
			self hResizing: #shrinkWrap.
			self vResizing: #spaceFill]
		ifTrue: [""
			self hResizing: #spaceFill.
			self vResizing: #shrinkWrap].
	self extent: self minWidth @ self minHeight! !
AlignmentMorph subclass: #MenuMorph
	instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu activatorDockingBar'
	classVariableNames: 'CloseBoxImage PushPinImage'
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!MenuMorph commentStamp: '<historical>' prior: 0!
Instance variables:
	defaultTarget 	<Object>				The default target for creating menu items
	selectedItem		<MenuItemMorph> 	The currently selected item in the receiver
	stayUp 			<Boolean>			True if the receiver should stay up after clicks
	popUpOwner 	<MenuItemMorph>	The menu item that automatically invoked the receiver, if any.
	activeSubMenu 	<MenuMorph>		The currently active submenu.!


!MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 17:56'!
activatedFromDockingBar: aDockingBar 
	activatorDockingBar := aDockingBar! !

!MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 19:59'!
addBlankIconsIfNecessary: anIcon 
	"If any of my items have an icon, ensure that all do by using  
	anIcon for those that don't"
	self items
		reject: [:each | each hasIconOrMarker]
		thenDo: [:each | each icon: anIcon]! !

!MenuMorph methodsFor: 'accessing' stamp: 'sw 12/4/2001 21:22'!
commandKeyHandler
	"Answer the receiver's commandKeyHandler"

	^ self valueOfProperty: #commandKeyHandler ifAbsent: [nil]! !

!MenuMorph methodsFor: 'accessing' stamp: 'sw 12/4/2001 21:23'!
commandKeyHandler: anObject
	"Set the receiver's commandKeyHandler.  Whatever you set here needs to be prepared to respond to the message #commandKeyTypedIntoMenu: "

	self setProperty: #commandKeyHandler toValue: anObject! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 13:19'!
defaultTarget
	^defaultTarget! !

!MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 13:36'!
hasItems
	"Answer if the receiver has menu items"
	^ submorphs
		anySatisfy: [:each | each isKindOf: MenuItemMorph] ! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:18'!
hasSubMenu: aMenuMorph
	self items do: [:each | (each hasSubMenu: aMenuMorph) ifTrue:[^true]].
	^ false
! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:22'!
itemWithWording: wording
	"If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil."
	| found |
	self items do:[:anItem |
		found _ anItem itemWithWording: wording.
		found ifNotNil:[^found]].
	^ nil! !

!MenuMorph methodsFor: 'accessing' stamp: 'hg 8/3/2000 15:29'!
items

	^ submorphs select: [:m | m isKindOf: MenuItemMorph]
! !

!MenuMorph methodsFor: 'accessing' stamp: 'nk 6/8/2004 16:52'!
lastItem
	^ submorphs reverse
		detect: [ :m | m isKindOf: MenuItemMorph ]
		ifNone: [ submorphs last ]! !

!MenuMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 23:18'!
lastSelection
	"Return the label of the last selected item or nil."

	selectedItem isNil ifTrue: [^selectedItem selector] ifFalse: [^nil]! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 10:06'!
popUpOwner
	"Return the current pop-up owner that is the menu item that automatically initiated the receiver."
	^ popUpOwner
! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 10:07'!
popUpOwner: aMenuItemMorph
	"Set the current pop-up owner"
	popUpOwner _ aMenuItemMorph.
! !

!MenuMorph methodsFor: 'accessing' stamp: 'di 12/10/2001 22:11'!
rootMenu
	popUpOwner ifNil: [^ self].
	popUpOwner owner ifNil: [^ self].
	^ popUpOwner owner rootMenu! !

!MenuMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
stayUp

	^ stayUp
! !

!MenuMorph methodsFor: 'accessing' stamp: 'nk 3/31/2002 15:13'!
stayUp: aBoolean

	stayUp _ aBoolean.
	aBoolean ifTrue: [ self removeStayUpBox ].! !

!MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 17:57'!
wasActivatedFromDockingBar
	"answer true if the receiver was activated from a docking bar"
	^ activatorDockingBar notNil! !


!MenuMorph methodsFor: 'construction' stamp: 'dgd 10/1/2004 13:48'!
addAllFrom: aMenuMorph 
	aMenuMorph submorphs
		do: [:each | 
			(each isKindOf: MenuItemMorph)
				ifTrue: [self
						add: each contents
						target: each target
						selector: each selector
						argumentList: each arguments].
			(each isKindOf: MenuLineMorph)
				ifTrue: [self addLine]] ! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 13:35'!
addTitle: aString icon: aForm 
	"Add a title line at the top of this menu."
	self
		addTitle: aString
		icon: aForm
		updatingSelector: nil
		updateTarget: nil ! !

!MenuMorph methodsFor: 'construction' stamp: 'tbn 4/24/2006 19:59'!
addTitle: aString icon: aForm updatingSelector: aSelector updateTarget: aTarget 
	"Add a title line at the top of this menu Make aString its initial  
	contents.  
	If aSelector is not nil, then periodically obtain fresh values for  
	its  
	contents by sending aSelector to aTarget.."
	| title titleContainer |
	title := AlignmentMorph newColumn.
	self setTitleParametersFor: title.
	""
	aForm isNil
		ifTrue: [titleContainer := title]
		ifFalse: [| pair | 
			pair := AlignmentMorph newRow.

			pair color: Color transparent.
			pair hResizing: #shrinkWrap.
			pair layoutInset: 0.
			""
			pair addMorphBack: aForm asMorph.
			""
			titleContainer := AlignmentMorph newColumn.
			titleContainer color: Color transparent.
			titleContainer vResizing: #shrinkWrap.
			titleContainer wrapCentering: #center.
			titleContainer cellPositioning: #topCenter.
			titleContainer layoutInset: 0.
			pair addMorphBack: titleContainer.
			""
			title addMorphBack: pair].
	""
	aSelector
		ifNil: [""
			aString asString
				linesDo: [:line | titleContainer
						addMorphBack: (StringMorph contents: line font: Preferences standardMenuFont)]]
		ifNotNil: [| usm | 
			usm := UpdatingStringMorph on: aTarget selector: aSelector.
			usm font: Preferences standardMenuFont.
			usm useStringFormat.
			usm lock.
			titleContainer addMorphBack: usm].
	""
	title setProperty: #titleString toValue: aString.
	self addMorphFront: title.
	""
	title borderWidth: 1.
	title useSquareCorners.
	(self hasProperty: #needsTitlebarWidgets)
		ifTrue: [self addStayUpIcons]! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
add: aString action: aSymbol
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object."
	"Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action."

	self add: aString
		target: defaultTarget
		selector: aSymbol
		argumentList: EmptyArray.
! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/20/2004 14:25'!
add: wordingString help: helpString action: aSymbol 
	"Append a menu item with the given label. If the item is  
	selected, it will send the given selector to the default target  
	object."
	"Details: Note that the menu item added captures the default  
	target object at the time the item is added; the default target  
	can later be changed before added additional items without  
	affecting the targets of previously added entries. The model is 
	that each entry is like a button that knows everything it needs 
	to perform its action."
	self
		add: wordingString
		target: defaultTarget
		selector: aSymbol
		argumentList: EmptyArray.
self balloonTextForLastItem:helpString! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 18:58'!
add: wordingString icon: aForm help: helpString subMenu: aMenuMorph 
	"Append the given submenu with the given label."
	| item |
	item := MenuItemMorph new.

	item contents: wordingString.
	item subMenu: aMenuMorph.
	item icon: aForm.
	helpString isNil
		ifFalse: [item setBalloonText: helpString].
	self addMorphBack: item! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 14:01'!
add: wordingString icon: aForm subMenu: aMenuMorph 
	"Append the given submenu with the given label."
	^ self
		add: wordingString
		icon: aForm
		help: nil
		subMenu: aMenuMorph! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 5/1/1998 00:48'!
add: aString selector: aSymbol argument: arg

	self add: aString
		target: defaultTarget
		selector: aSymbol
		argumentList: (Array with: arg)
! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 14:01'!
add: aString subMenu: aMenuMorph 
	"Append the given submenu with the given label."
	self
		add: aString
		icon: nil
		subMenu: aMenuMorph! !

!MenuMorph methodsFor: 'construction' stamp: 'ar 12/16/2001 16:53'!
add: aString subMenu: aMenuMorph target: target selector: aSymbol argumentList: argList
	"Append the given submenu with the given label."

	| item |
	item _ MenuItemMorph new.
	item 
		contents: aString;
		target: target;
		selector: aSymbol;
		arguments: argList asArray;
		subMenu: aMenuMorph.
	self addMorphBack: item.
	^item! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 4/17/1998 22:45'!
add: aString target: aTarget action: aSymbol
	self add: aString
		target: aTarget
		selector: aSymbol
		argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
add: aString target: anObject selector: aSymbol
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object."

	self add: aString
		target: anObject
		selector: aSymbol
		argumentList: EmptyArray.
! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
add: aString target: target selector: aSymbol argument: arg
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument."

	self add: aString
		target: target
		selector: aSymbol
		argumentList: (Array with: arg)
! !

!MenuMorph methodsFor: 'construction' stamp: 'hg 8/3/2000 15:22'!
add: aString target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument."

	| item |
	item _ MenuItemMorph new
		contents: aString;
		target: target;
		selector: aSymbol;
		arguments: argList asArray.
	self addMorphBack: item.
! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 13:35'!
addLine
	"Append a divider line to this menu. Suppress duplicate lines."
	self hasItems
		ifFalse: [^ self].
	(self lastSubmorph isKindOf: MenuLineMorph)
		ifFalse: [self addMorphBack: MenuLineMorph new] ! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 2/27/2001 07:50'!
addList: aList
	"Add the given items to this menu, where each item is a pair (<string> <actionSelector>)..  If an element of the list is simply the symobl $-, add a line to the receiver.  The optional third element of each entry, if present, provides balloon help."

	aList do: [:tuple |
		(tuple == #-)
			ifTrue: [self addLine]
			ifFalse:
				[self add: tuple first action: tuple second.
				tuple size > 2 ifTrue:
					[self balloonTextForLastItem: tuple third]]]! !

!MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:19'!
addService: aService for: serviceUser
	"Append a menu item with the given service. If the item is selected, it will perform the given service."

	aService addServiceFor: serviceUser toMenu: self.! !

!MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:11'!
addServices2: services for: served extraLines: linesArray

	services withIndexDo: [:service :i |
		service addServiceFor: served toMenu: self.
		self lastItem setBalloonText: service description.
		(linesArray includes: i)  ifTrue: [self addLine] ]
! !

!MenuMorph methodsFor: 'construction' stamp: 'nk 11/26/2002 13:53'!
addServices: services for: served extraLines: linesArray

	services withIndexDo: [:service :i |
		self addService: service for: served.
		submorphs last setBalloonText: service description.
		(linesArray includes: i) | service useLineAfter 
			ifTrue: [self addLine]].
! !

!MenuMorph methodsFor: 'construction' stamp: 'jrp 6/19/2005 20:54'!
addStayUpIcons
	| title closeBox pinBox titleBarArea titleString |
	title _ submorphs
				detect: [:ea | ea hasProperty: #titleString]
				ifNone: [self setProperty: #needsTitlebarWidgets toValue: true.
					^ self].
	closeBox _ IconicButton new target: self;
				 actionSelector: #delete;
				 labelGraphic: self class closeBoxImage;
				 color: Color transparent;
				 extent: 14 @ 16;
				 borderWidth: 0.
	pinBox _ IconicButton new target: self;
				 actionSelector: #stayUp:;
				 arguments: {true};
				 labelGraphic: self class pushPinImage;
				 color: Color transparent;
				 extent: 14 @ 15;
				 borderWidth: 0.
	Preferences noviceMode
		ifTrue: [closeBox setBalloonText: 'close this menu'.
			pinBox setBalloonText: 'keep this menu up'].
	titleBarArea _  AlignmentMorph newRow vResizing: #shrinkWrap;
			 layoutInset: 3;
			 color: Preferences menuTitleColor;
			 addMorphBack: closeBox;
			 addMorphBack: title;
			 addMorphBack: pinBox.
	
	title color: Color transparent.

	titleString _ title 
		findDeepSubmorphThat: [:each | each respondsTo: #font: ]
		ifAbsent: [nil].
	titleString font: Preferences windowTitleFont.
	Preferences roundedMenuCorners
		ifTrue: [titleBarArea useRoundedCorners].
	
	self addMorphFront: titleBarArea.
	titleBarArea setProperty: #titleString toValue: (title valueOfProperty: #titleString).
	title removeProperty: #titleString.
	self setProperty: #hasTitlebarWidgets toValue: true.
	self removeProperty: #needsTitlebarWidgets.
	self removeStayUpItems! !

!MenuMorph methodsFor: 'construction' stamp: 'nk 4/6/2002 22:41'!
addStayUpItem
	"Append a menu item that can be used to toggle this menu's persistence."

	(self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ])
		ifTrue: [ ^self ].
	self addStayUpIcons.! !

!MenuMorph methodsFor: 'construction' stamp: 'nk 4/6/2002 22:41'!
addStayUpItemSpecial
	"Append a menu item that can be used to toggle this menu's persistent."

	"This variant is resistant to the MVC compatibility in #setInvokingView:"

	(self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ])
		ifTrue: [ ^self ].
	self addStayUpIcons.! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 6/19/1999 23:09'!
addTitle: aString
	"Add a title line at the top of this menu."

	self addTitle: aString updatingSelector: nil updateTarget: nil! !

!MenuMorph methodsFor: 'construction' stamp: 'dgd 4/3/2006 13:01'!
addTitle: aString updatingSelector: aSelector updateTarget: aTarget 
	"Add a title line at the top of this menu Make aString its initial  
	contents.  
	If aSelector is not nil, then periodically obtain fresh values for  
	its contents by sending aSelector to aTarget.."
	^ self
		addTitle: aString
		icon: nil
		updatingSelector: aSelector
		updateTarget: aTarget! !

!MenuMorph methodsFor: 'construction' stamp: 'nk 11/25/2003 09:59'!
addTranslatedList: aList
	"Add the given items to this menu, where each item is a pair (<string> <actionSelector>)..  If an element of the list is simply the symobl $-, add a line to the receiver.  The optional third element of each entry, if present, provides balloon help.
	The first and third items will be translated."

	aList do: [:tuple |
		(tuple == #-)
			ifTrue: [self addLine]
			ifFalse:
				[self add: tuple first translated action: tuple second.
				tuple size > 2 ifTrue:
					[self balloonTextForLastItem: tuple third translated ]]]! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 16:49'!
addUpdating: aWordingSelector action: aSymbol

	self addUpdating: aWordingSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 6/21/1999 11:34'!
addUpdating: aWordingSelector enablement: anEnablementSelector action: aSymbol

	self addUpdating: aWordingSelector enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 11/6/2000 13:39'!
addUpdating: wordingSelector enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument.  In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, and the optional enablementSelector determines whether or not the item should be enabled.  Answer the item itself."

	| item |
	item _ UpdatingMenuItemMorph new
		target: target;
		selector: aSymbol;
		wordingProvider: target wordingSelector: wordingSelector;
		enablementSelector: enablementSelector;
		arguments: argList asArray.
	self addMorphBack: item.
	^ item
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 17:26'!
addUpdating: aWordingSelector target: aTarget action: aSymbol

	self addUpdating: aWordingSelector target: aTarget selector: aSymbol argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 11/6/2000 13:43'!
addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument.  In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target,  Answer the item added."

	| item |
	item _ UpdatingMenuItemMorph new
		target: target;
		selector: aSymbol;
		wordingProvider: target wordingSelector: wordingSelector;
		arguments: argList asArray.
	self addMorphBack: item.
	^ item
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 8/28/2000 18:02'!
addWithLabel: aLabel enablement: anEnablementSelector action: aSymbol

	self addWithLabel: aLabel enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 8/28/2000 18:01'!
addWithLabel: aLabel enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument.  In this variant, the wording of the menu item is constant, and the optional enablementSelector determines whether or not the item should be enabled."

	| item |
	item _ UpdatingMenuItemMorph new
		target: target;
		selector: aSymbol;
		contents: aLabel;
		wordingProvider: target wordingSelector: nil;
		enablementSelector: enablementSelector;
		arguments: argList asArray.
	self addMorphBack: item.
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 11/5/1998 21:13'!
balloonTextForLastItem: balloonText
	submorphs last setBalloonText: balloonText! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
defaultTarget: anObject
	"Set the default target for adding menu items."

	defaultTarget _ anObject.
! !

!MenuMorph methodsFor: 'construction' stamp: 'yo 7/16/2003 15:15'!
labels: labelList lines: linesArray selections: selectionsArray 
	"This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."

	"Labels can be either a sting with embedded crs, or a collection of strings."

	| labelArray |
	labelArray := (labelList isString) 
				ifTrue: [labelList findTokens: String cr]
				ifFalse: [labelList]. 
	1 to: labelArray size
		do: 
			[:i | 
			self add: (labelArray at: i) action: (selectionsArray at: i).
			(linesArray includes: i) ifTrue: [self addLine]]! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 7/1/1999 22:21'!
title: aString
	"Add a title line at the top of this menu."

	self addTitle: aString! !


!MenuMorph methodsFor: 'control' stamp: 'dgd 9/1/2004 17:57'!
activeSubmenu: aSubmenu 
	activeSubMenu
		ifNotNil: [activeSubMenu delete].
	activeSubMenu := aSubmenu.
	aSubmenu
		ifNotNil: [
			activeSubMenu activatedFromDockingBar: nil.
]! !

!MenuMorph methodsFor: 'control' stamp: 'hg 8/3/2000 15:28'!
deleteIfPopUp
	"Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."

	stayUp ifFalse: [self topRendererOrSelf delete].
	(popUpOwner notNil and: [popUpOwner isKindOf: MenuItemMorph]) ifTrue: [
		popUpOwner isSelected: false.
		(popUpOwner owner isKindOf: MenuMorph)
			ifTrue: [popUpOwner owner deleteIfPopUp]].
! !

!MenuMorph methodsFor: 'control' stamp: 'ar 10/10/2000 00:54'!
deleteIfPopUp: evt
	"Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."

	stayUp ifFalse: [self topRendererOrSelf delete].
	(popUpOwner notNil) ifTrue: [
		popUpOwner isSelected: false.
		popUpOwner deleteIfPopUp: evt].
	evt ifNotNil:[evt hand releaseMouseFocus: self].! !

!MenuMorph methodsFor: 'control' stamp: 'dgd 3/21/2003 22:36'!
popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem 
	"Present this menu at the given point under control of the given  
	hand."
	| delta tryToPlace selectedOffset |
	hand world startSteppingSubmorphsOf: self.
	popUpOwner := sourceItem.
	self fullBounds.
self updateColor.
	"ensure layout is current"
	selectedOffset := (selectedItem
				ifNil: [self items first]) position - self position.
	tryToPlace := [:where :mustFit | 
			self position: where - selectedOffset.
			delta := self fullBoundsInWorld amountToTranslateWithin: sourceItem worldBounds.
			(delta x = 0
					or: [mustFit])
				ifTrue: [delta = (0 @ 0)
						ifFalse: [self position: self position + delta].
					sourceItem owner owner addMorphFront: self.
					^ self]].
	tryToPlace value: rightOrLeftPoint first value: false;
		 value: rightOrLeftPoint last - (self width @ 0) value: false;
		 value: rightOrLeftPoint first value: true! !

!MenuMorph methodsFor: 'control' stamp: 'ar 12/27/2001 22:46'!
popUpAt: aPoint forHand: hand in: aWorld
	"Present this menu at the given point under control of the given hand.  Allow keyboard input into the menu."

	^ self popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: Preferences menuKeyboardControl! !

!MenuMorph methodsFor: 'control' stamp: 'tak 1/6/2005 13:28'!
popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean 
	"Present this menu at the given point under control of the given  
	hand."
	| evt |
	aWorld submorphs
		select: [ :each | (each isKindOf: MenuMorph)
			and: [each stayUp not]]
		thenCollect: [ :menu | menu delete].

	self items isEmpty
		ifTrue: [^ self].

	MenuIcons decorateMenu: self.

	(self submorphs
		select: [:m | m isKindOf: UpdatingMenuItemMorph])
		do: [:m | m updateContents].
	"precompute width"
	self
		positionAt: aPoint
		relativeTo: (selectedItem
				ifNil: [self items first])
		inWorld: aWorld.
	aWorld addMorphFront: self.
	"Acquire focus for valid pop up behavior"
	hand newMouseFocus: self.
	aBoolean
		ifTrue: [hand newKeyboardFocus: self].
	evt := hand lastEvent.
	(evt isKeyboard
			or: [evt isMouse
					and: [evt anyButtonPressed not]])
		ifTrue: ["Select first item if button not down"
			self moveSelectionDown: 1 event: evt].
	self updateColor.
	self changed! !

!MenuMorph methodsFor: 'control' stamp: 'sw 4/24/2001 11:11'!
popUpEvent: evt in: aWorld
	"Present this menu in response to the given event."

	| aHand aPosition |
	aHand _ evt ifNotNil: [evt hand] ifNil: [ActiveHand].
	aPosition _ aHand position truncated.
	^ self popUpAt: aPosition forHand: aHand in: aWorld
! !

!MenuMorph methodsFor: 'control' stamp: 'ar 3/18/2001 00:33'!
popUpForHand: hand in: aWorld
	| p |
	"Present this menu under control of the given hand."

	p _ hand position truncated.
	^self popUpAt: p forHand: hand in: aWorld
! !

!MenuMorph methodsFor: 'control' stamp: 'sw 2/18/2001 00:52'!
popUpInWorld
	"Present this menu in the current World"

	^ self popUpInWorld: self currentWorld! !

!MenuMorph methodsFor: 'control' stamp: 'ar 10/5/2000 19:31'!
popUpInWorld: aWorld
	"Present this menu under control of the given hand."
	^self popUpAt: aWorld primaryHand position forHand: aWorld primaryHand in: aWorld
! !

!MenuMorph methodsFor: 'control' stamp: 'sw 12/17/2001 16:43'!
popUpNoKeyboard
	"Present this menu in the current World, *not* allowing keyboard input into the menu"

	^ self popUpAt: ActiveHand position forHand: ActiveHand in: ActiveWorld allowKeyboard: false! !

!MenuMorph methodsFor: 'control' stamp: 'ar 9/18/2000 12:16'!
selectItem: aMenuItem event: anEvent
	selectedItem ifNotNil:[selectedItem deselect: anEvent].
	selectedItem _ aMenuItem.
	selectedItem ifNotNil:[selectedItem select: anEvent].! !

!MenuMorph methodsFor: 'control' stamp: 'jrp 7/6/2005 21:23'!
updateColor
	| fill title |
	Preferences gradientMenu
		ifFalse: [^ self].
	""
	fill _ GradientFillStyle ramp: {0.0 -> Color white. 1 -> self color}.
	""
	fill
		radial: false;
		origin: self topLeft;
		direction: 0 @ self height.
	""
	self fillStyle: fill.
	" 
	update the title color"
	title _ self allMorphs
				detect: [:each | each hasProperty: #titleString]
				ifNone: [^ self].
	""
	fill _ GradientFillStyle ramp: {0.0 -> title color twiceLighter. 1 -> title color twiceDarker}.
	""
	fill
		origin: title topLeft;
		direction: title width @ 0.
	""
	title fillStyle: fill! !

!MenuMorph methodsFor: 'control' stamp: 'sw 2/7/2002 12:06'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph.  A single-item MenuMorph is in effect a button rather than a menu, and as such should not be reluctant to be dropped into another object."

	^ (aMorph isWorldMorph or: [submorphs size == 1]) or:
		[Preferences systemWindowEmbedOK]! !


!MenuMorph methodsFor: 'copying' stamp: 'ar 9/18/2000 09:34'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals."

super veryDeepFixupWith: deepCopier.
defaultTarget _ deepCopier references at: defaultTarget ifAbsent: [defaultTarget].
popUpOwner _ deepCopier references at: popUpOwner ifAbsent: [popUpOwner].
activeSubMenu _ deepCopier references at: activeSubMenu ifAbsent:[activeSubMenu].! !

!MenuMorph methodsFor: 'copying' stamp: 'dgd 9/1/2004 17:54'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"defaultTarget _ defaultTarget.		Weakly copied"
selectedItem _ selectedItem veryDeepCopyWith: deepCopier.
stayUp _ stayUp veryDeepCopyWith: deepCopier.
popUpOwner _ popUpOwner.		"Weakly copied"
activeSubMenu _ activeSubMenu. "Weakly copied"
activatorDockingBar _ activatorDockingBar.  "Weakly copied"
! !


!MenuMorph methodsFor: 'drawing' stamp: 'dgd 4/3/2006 10:37'!
drawOn: aCanvas 
	"Draw the menu. Add keyboard-focus feedback if appropriate"

	super drawOn: aCanvas.

	(ActiveHand notNil
			and: [ActiveHand keyboardFocus == self]
			and: [self rootMenu hasProperty: #hasUsedKeyboard])
		ifTrue: [
			aCanvas
				frameAndFillRectangle: self innerBounds
				fillColor: Color transparent
				borderWidth: Preferences menuBorderWidth
				borderColor: Preferences keyboardFocusColor
		].
! !


!MenuMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 14:23'!
justDroppedInto: aMorph event: evt
	| halo |
	super justDroppedInto: aMorph event: evt.
	halo _ evt hand halo.
	(halo notNil and:[halo target hasOwner: self]) ifTrue:[
		"Grabbed single menu item"
		self addHalo: evt.
	].
	stayUp ifFalse:[evt hand newMouseFocus: self].! !

!MenuMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:16'!
undoGrabCommand
	^nil! !


!MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:35'!
activate: evt
	"Receiver should be activated; e.g., so that control passes correctly."
	evt hand newMouseFocus: self.! !

!MenuMorph methodsFor: 'events' stamp: 'di 12/5/2001 10:26'!
handleFocusEvent: evt
	"Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children."
	self processEvent: evt.

	"Need to handle keyboard input if we have the focus."
	evt isKeyboard ifTrue: [^ self handleEvent: evt].

	"We need to handle button clicks outside and transitions to local popUps so throw away everything else"
	(evt isMouseOver or:[evt isMouse not]) ifTrue:[^self].
	"What remains are mouse buttons and moves"
	evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means"
	"Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first."
	selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]].
	"Note: The following does not traverse upwards but it's the best I can do for now"
	popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: evt) ifTrue:[^self]].! !

!MenuMorph methodsFor: 'events' stamp: 'ar 9/18/2000 10:13'!
handlesMouseDown: evt
	^true! !

!MenuMorph methodsFor: 'events' stamp: 'RAA 12/16/2000 11:20'!
mouseDown: evt
	"Handle a mouse down event."
	(stayUp or:[self fullContainsPoint: evt position]) 
		ifFalse:[^self deleteIfPopUp: evt]. "click outside"
	self isSticky ifTrue: [^self].
	"Grab the menu and drag it to some other place"
	evt hand grabMorph: self.! !

!MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:57'!
mouseUp: evt
	"Handle a mouse up event.
	Note: This might be sent from a modal shell."
	(self fullContainsPoint: evt position) ifFalse:[
		"Mouse up outside. Release eventual focus and delete if pop up."
		evt hand releaseMouseFocus: self.
		^self deleteIfPopUp: evt].
	stayUp ifFalse:[
		"Still in pop-up transition; keep focus"
		evt hand newMouseFocus: self].! !


!MenuMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 01:57'!
delete
	activeSubMenu ifNotNil:[activeSubMenu delete].
	^super delete! !

!MenuMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 12:33'!
initialize
	super initialize.

	bounds := 0 @ 0 corner: 40 @ 10.

	self setDefaultParameters.

	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	defaultTarget := nil.
	selectedItem := nil.
	stayUp := false.
	popUpOwner := nil.

	Preferences roundedMenuCorners
		ifTrue: [self useRoundedCorners].
! !

!MenuMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 11:04'!
setDefaultParameters
	"change the receiver's appareance parameters"

	| colorFromMenu worldColor menuColor |
	
	colorFromMenu := Preferences menuColorFromWorld
									and: [Display depth > 4]
									and: [(worldColor := self currentWorld color) isColor].

	menuColor := colorFromMenu
						ifTrue: [worldColor luminance > 0.7
										ifTrue: [worldColor mixed: 0.85 with: Color black]
										ifFalse: [worldColor mixed: 0.4 with: Color white]]
						ifFalse: [Preferences menuColor].

	self color: menuColor.
	self borderWidth: Preferences menuBorderWidth.

	Preferences menuAppearance3d ifTrue: [
		self borderStyle: BorderStyle thinGray.
		self
			addDropShadow;
			shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666);
			shadowOffset: 1 @ 1
	]
	ifFalse: [
		| menuBorderColor |
		menuBorderColor := colorFromMenu
										ifTrue: [worldColor muchDarker]
										ifFalse: [Preferences menuBorderColor].
		self borderColor: menuBorderColor.
	].


	self layoutInset: 3.
! !

!MenuMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 12:52'!
setTitleParametersFor: aMenuTitle 
	| menuTitleColor menuTitleBorderColor |
	Preferences roundedMenuCorners
		ifTrue: [aMenuTitle useRoundedCorners].

	menuTitleColor := Preferences menuColorFromWorld
				ifTrue: [self color darker]
				ifFalse: [Preferences menuTitleColor].

	menuTitleBorderColor := Preferences menuAppearance3d
				ifTrue: [#inset]
				ifFalse: [Preferences menuColorFromWorld
						ifTrue: [self color darker muchDarker]
						ifFalse: [Preferences menuTitleBorderColor]].

	aMenuTitle
		setColor: menuTitleColor
		borderWidth: Preferences menuTitleBorderWidth
		borderColor: menuTitleBorderColor;
		vResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #topCenter;
		layoutInset: 0.
! !


!MenuMorph methodsFor: 'keyboard control' stamp: 'cmm 3/26/2003 22:52'!
displayFiltered: evt
	| matchStr allItems isMatch matches feedbackMorph |
	matchStr _ self valueOfProperty: #matchString.
	allItems _ self submorphs select: [:m | m isKindOf: MenuItemMorph].
	matches _  allItems select: [:m | 
		isMatch _ 
			matchStr isEmpty or: [
				m contents includesSubstring: matchStr caseSensitive: false].
		m isEnabled: isMatch.
		isMatch].
	feedbackMorph _ self valueOfProperty: #feedbackMorph.
	feedbackMorph ifNil: [
		feedbackMorph _ 
			TextMorph new 
				autoFit: true;
				color: Color darkGray.
		self
			addLine;
			addMorphBack: feedbackMorph lock.
		self setProperty: #feedbackMorph toValue: feedbackMorph.
		self fullBounds.  "Lay out for submorph adjacency"].
	feedbackMorph contents: '<', matchStr, '>'.
	matchStr isEmpty ifTrue: [
		feedbackMorph delete.
		self submorphs last delete.
		self removeProperty: #feedbackMorph].
	matches size >= 1 ifTrue: [
		self selectItem: matches first event: evt]
! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:45'!
filterListWith: char 
	| matchString |
	matchString := self valueOfProperty: #matchString ifAbsentPut: [String new].
	matchString := char = Character backspace 
				ifTrue: 
					[matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]]
				ifFalse: [matchString copyWith: char].
	self setProperty: #matchString toValue: matchString! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'sw 12/4/2001 20:13'!
handlesKeyboard: evt
	"Answer whether the receiver handles the keystroke represented by the event"

	^ evt anyModifierKeyPressed not or: [evt commandKeyPressed and: [self commandKeyHandler notNil]]! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'laza 5/6/2004 13:59'!
keyStroke: evt 
	| matchString char asc selectable help |
	help _ BalloonMorph string: 'Enter text to\narrow selection down\to matching items ' withCRs for: self corner: #topLeft.
	help popUpForHand: self activeHand.
	(self rootMenu hasProperty: #hasUsedKeyboard) 
		ifFalse: 
			[self rootMenu setProperty: #hasUsedKeyboard toValue: true.
			self changed].
	(evt commandKeyPressed and: [self commandKeyHandler notNil]) 
		ifTrue: 
			[self commandKeyHandler commandKeyTypedIntoMenu: evt.
			^self deleteIfPopUp: evt].
	char := evt keyCharacter.
	asc := char asciiValue.
	char = Character cr 
		ifTrue: 
			[selectedItem ifNotNil: 
					[selectedItem hasSubMenu 
						ifTrue: 
							[evt hand newMouseFocus: selectedItem subMenu.
							^evt hand newKeyboardFocus: selectedItem subMenu]
						ifFalse: 
							["self delete."

							^selectedItem invokeWithEvent: evt]].
			(selectable := self items) size = 1 
				ifTrue: [^selectable first invokeWithEvent: evt].
			^self].
	asc = 27 
		ifTrue: 
			["escape key"

			self valueOfProperty: #matchString
				ifPresentDo: 
					[:str | 
					str isEmpty 
						ifFalse: 
							["If filtered, first ESC removes filter"

							self setProperty: #matchString toValue: String new.
							self selectItem: nil event: evt.
							^self displayFiltered: evt]].
			"If a stand-alone menu, just delete it"
			popUpOwner ifNil: [^self delete].
			"If a sub-menu, then deselect, and return focus to outer menu"
			self selectItem: nil event: evt.
			evt hand newMouseFocus: popUpOwner owner.
			^evt hand newKeyboardFocus: popUpOwner owner].
	(asc = 28 or: [asc = 29]) 
		ifTrue: 
			["left or right arrow key"

			(selectedItem notNil and: [selectedItem hasSubMenu]) 
				ifTrue: 
					[evt hand newMouseFocus: selectedItem subMenu.
					selectedItem subMenu moveSelectionDown: 1 event: evt.
					^evt hand newKeyboardFocus: selectedItem subMenu]].
	asc = 30 ifTrue: [^self moveSelectionDown: -1 event: evt].	"up arrow key"
	asc = 31 ifTrue: [^self moveSelectionDown: 1 event: evt].	"down arrow key"
	asc = 11 ifTrue: [^self moveSelectionDown: -5 event: evt].	"page up key"
	asc = 12 ifTrue: [^self moveSelectionDown: 5 event: evt].	"page down key"
	matchString := self valueOfProperty: #matchString ifAbsentPut: [String new].
	matchString := char = Character backspace 
				ifTrue: 
					[matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]]
				ifFalse: [matchString copyWith: evt keyCharacter].
	self setProperty: #matchString toValue: matchString.
	self displayFiltered: evt.
	help _ BalloonMorph string: 'Enter text to\narrow selection down\to matching items ' withCRs for: self corner: #topLeft.
	help popUpForHand: self activeHand.
! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'di 12/5/2001 11:41'!
keyboardFocusChange: aBoolean
	"Notify change due to green border for keyboard focus"

	self changed! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:41'!
moveDown: evt 
	^self moveSelectionDown: 1 event: evt! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:42'!
moveRightOrDown: evt 
	selectedItem ifNotNil: 
			[selectedItem hasSubMenu 
				ifTrue: 
					[self selectSubMenu: evt.
					selectedItem subMenu moveDown: evt]
				ifFalse: [self moveDown: evt]]! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'di 12/10/2001 22:52'!
moveSelectionDown: direction event: evt
	"Move the current selection up or down by one, presumably under keyboard control.
	direction = +/-1"

	| index m |
	index _ (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction.
	submorphs do: "Ensure finite"
		[:unused | m _ submorphs atWrap: index.
		((m isKindOf: MenuItemMorph) and: [m isEnabled]) ifTrue:
			[^ self selectItem: m event: evt].
		"Keep looking for an enabled item"
		index _ index + direction sign].
	^ self selectItem: nil event: evt! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:40'!
moveUp: evt 
	^self moveSelectionDown: -1 event: evt! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'dgd 9/9/2004 21:48'!
removeMatchString
	"Remove the matchString, if any."
	self setProperty: #matchString toValue: String new.
	self displayFiltered: nil! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/25/2004 12:14'!
selectCurrentItem: evt 
	| selectable |
	selectedItem ifNotNil: 
			[selectedItem hasSubMenu 
				ifTrue: [self selectSubMenu: evt]
				ifFalse: [selectedItem invokeWithEvent: evt]].
	(selectable := self items) size = 1 
		ifTrue: [selectable first invokeWithEvent: evt]! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 9/15/2005 16:24'!
selectMoreItem: evt
	| allItems more |
	allItems := self submorphs select: [:m | m isKindOf: MenuItemMorph].
	more := allItems detect: [:m | (m contents size >= 4) and: [(m contents first: 4) asString = 'more'.]] ifNone: [^ self flash].
	self selectItem: more event: evt.
	selectedItem invokeWithEvent: evt! !

!MenuMorph methodsFor: 'keyboard control' stamp: 'md 1/19/2006 18:02'!
unfilterOrEscape: evt 
	self valueOfProperty: #matchString
		ifPresentDo: 
			[:str | 
			
			str isEmpty 
				ifFalse: 
					["If filtered, first ESC removes filter"

					self setProperty: #matchString toValue: String new.
					self selectItem: nil event: evt.
					self displayFiltered: evt]].
	"If a stand-alone menu, just delete it"
	popUpOwner ifNil: [^self delete].
	"If a sub-menu, then deselect, and return focus to outer menu"
	self selectSuperMenu: evt! !


!MenuMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:52'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'add title...' translated action: #addTitle.
	aCustomMenu add: 'set target...' translated action: #setTarget:.
	defaultTarget ifNotNil: [
		aCustomMenu add: 'add item...' translated action: #addItem].
	aCustomMenu add: 'add line' translated action: #addLine.
	(self items count:[:any| any hasSubMenu]) > 0
		ifTrue:[aCustomMenu add: 'detach submenu' translated action: #detachSubMenu:].! !

!MenuMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
addItem

	| string sel |
	string _ FillInTheBlank request: 'Label for new item?'.
	string isEmpty ifTrue: [^ self].
	sel _ FillInTheBlank request: 'Selector?'.
	sel isEmpty ifFalse: [sel _ sel asSymbol].
	self add: string action: sel.
! !

!MenuMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
addTitle

	| string |
	string _ FillInTheBlank request: 'Title for this menu?'.
	string isEmpty ifTrue: [^ self].
	self addTitle: string.
! !

!MenuMorph methodsFor: 'menu' stamp: 'ar 9/18/2000 11:47'!
detachSubMenu: evt
	| possibleTargets item subMenu index |
	possibleTargets _ self items select:[:any| any hasSubMenu].
	possibleTargets size > 0 ifTrue:[
		index _ PopUpMenu 
				withCaption:'Which menu?' 
				chooseFrom: (possibleTargets collect:[:t| t contents asString]).
		index = 0 ifTrue:[^self]].
	item _ possibleTargets at: index.
	subMenu _ item subMenu.
	subMenu ifNotNil: [
		item subMenu: nil.
		item delete.
		subMenu stayUp: true.
		subMenu popUpOwner: nil.
		subMenu addTitle: item contents.
		evt hand attachMorph: subMenu].
! !

!MenuMorph methodsFor: 'menu' stamp: 'sw 3/17/2005 23:59'!
doButtonAction
	"Do the receiver's inherent button action.  Makes sense for the kind of MenuMorph that is a wrapper for a single menu-item -- pass it on the the item"

	(self findA: MenuItemMorph) ifNotNilDo: [:aMenuItem | aMenuItem doButtonAction]! !

!MenuMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:10'!
removeStayUpBox
	| box |
	submorphs isEmpty ifTrue: [^self].
	(submorphs first isAlignmentMorph) ifFalse: [^self].
	box := submorphs first submorphs last.
	(box isKindOf: IconicButton) 
		ifTrue: 
			[box
				labelGraphic: (Form extent: box extent depth: 8);
				shedSelvedge;
				borderWidth: 0;
				lock]! !

!MenuMorph methodsFor: 'menu' stamp: 'nk 3/31/2002 18:36'!
removeStayUpItems
	| stayUpItems |
	stayUpItems _ self items select: [ :item | item isStayUpItem ].
	stayUpItems do: [ :ea | ea delete ].
! !

!MenuMorph methodsFor: 'menu' stamp: 'efo 3/27/2003 23:32'!
setInvokingView: invokingView
	"Re-work every menu item of the form
		<target> perform: <selector>
	to the form
		<target> perform: <selector> orSendTo: <invokingView>.
	This supports MVC's vectoring of non-model messages to the editPane."
	self items do:
		[:item |
		item hasSubMenu 
			ifTrue: [ item subMenu setInvokingView: invokingView]
			ifFalse: [ item arguments isEmpty ifTrue:  "only the simple messages"
						[item arguments: (Array with: item selector with: invokingView).
						item selector: #perform:orSendTo:]]]! !

!MenuMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 21:40'!
setTarget: evt 
	"Set the default target object to be used for add item commands, and re-target all existing items to the new target or the the invoking hand."

	| oldDefaultTarget |
	oldDefaultTarget := defaultTarget .
	self sightTargets: evt. 
	oldDefaultTarget ~~ defaultTarget 
		ifTrue: [self updateItemsWithTarget: defaultTarget orWithHand: evt hand ].
	! !

!MenuMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 21:26'!
target: aMorph
"Set defaultTarget since thats what we got.
For the sake of targetSighting which assumes #target is a word we know."

defaultTarget := aMorph! !

!MenuMorph methodsFor: 'menu' stamp: 'RAA 1/18/2001 18:21'!
toggleStayUp: evt
	"Toggle my 'stayUp' flag and adjust the menu item to reflect its new state."

	self items do: [:item |
		item isStayUpItem ifTrue:
			[self stayUp: stayUp not.	
			 stayUp
				ifTrue: [item contents: 'dismiss this menu']
				ifFalse: [item contents: 'keep this menu up']]].
	evt hand releaseMouseFocus: self.
	stayUp ifFalse: [self topRendererOrSelf delete].
! !

!MenuMorph methodsFor: 'menu' stamp: 'RAA 1/19/2001 15:10'!
toggleStayUpIgnore: ignored evt: evt

	"This variant is resistant to the MVC compatibility in #setInvokingView:"

	self toggleStayUp: evt.
! !

!MenuMorph methodsFor: 'menu' stamp: 'wiz 3/14/2006 23:40'!
updateItemsWithTarget: aTarget orWithHand: aHand
	"re-target all existing items"
	self items do: 
			[:item | item target ifNotNil: [
			item target isHandMorph 
				ifTrue: [item target: aHand]
				ifFalse: [item target: aTarget] ] ]! !


!MenuMorph methodsFor: 'modal control' stamp: 'sw 2/3/2002 14:26'!
invokeModal
	"Invoke this menu and don't return until the user has chosen a value.
	See example below on how to use modal menu morphs."
	^ self invokeModal: Preferences menuKeyboardControl

	"Example:
	| menu sub entry |
	menu _ MenuMorph new.
	1 to: 3 do: [:i |
		entry _ 'Line', i printString.
		sub _ MenuMorph new.
		menu add: entry subMenu: sub.
		#('Item A' 'Item B' 'Item C')  do:[:subEntry|
			sub add: subEntry target: menu 
				selector: #modalSelection: argument: {entry. subEntry}]].
	menu invokeModal.
"

! !

!MenuMorph methodsFor: 'modal control' stamp: 'sw 2/3/2002 14:26'!
invokeModal: allowKeyboardControl
	"Invoke this menu and don't return until the user has chosen a value.  If the allowKeyboarControl boolean is true, permit keyboard control of the menu"

	^ self invokeModalAt: ActiveHand position in: ActiveWorld allowKeyboard: allowKeyboardControl! !

!MenuMorph methodsFor: 'modal control' stamp: 'KLC 4/11/2004 09:06'!
invokeModalAt: aPoint in: aWorld allowKeyboard: aBoolean
	"Invoke this menu and don't return until the user has chosen a value.
	See senders of this method for finding out how to use modal menu morphs."
	| w originalFocusHolder |
	originalFocusHolder _ aWorld primaryHand keyboardFocus.
	self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean.
	self isModalInvokationDone: false.
	w _ aWorld outermostWorldMorph. "containing hand"
	[self isInWorld & self isModalInvokationDone not] whileTrue: [w doOneSubCycle].
	self delete.
	originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder].
	^ self modalSelection! !

!MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:33'!
isModalInvokationDone
	^self valueOfProperty: #isModalInvokationDone ifAbsent:[false]! !

!MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'!
isModalInvokationDone: aBool
	self setProperty: #isModalInvokationDone toValue: aBool
! !

!MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'!
modalSelection
	^self valueOfProperty: #modalSelection ifAbsent:[nil]! !

!MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'!
modalSelection: anObject
	self setProperty: #modalSelection toValue: anObject.
	self isModalInvokationDone: true! !


!MenuMorph methodsFor: '*eToys-control' stamp: 'sw 6/30/1999 20:30'!
isCandidateForAutomaticViewing
	^ false! !


!MenuMorph methodsFor: '*MorphicExtras-accessing' stamp: 'dgd 8/30/2003 20:44'!
allWordings
	"Answer a collection of the wordings of all items and subitems, omitting the window-list in the embed... branch and (unless a certain hard-coded preference is set) also omitting items from the debug menu"

	| verboten |
	verboten _ OrderedCollection with: 'embed into'.
	Preferences debugMenuItemsInvokableFromScripts 
		ifFalse:	[verboten add: 'debug...' translated].
	^ self allWordingsNotInSubMenus: verboten! !

!MenuMorph methodsFor: '*MorphicExtras-accessing' stamp: 'sw 10/3/2002 20:11'!
allWordingsNotInSubMenus: verbotenSubmenuContentsList
	"Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in any submenu whose tag is in verbotenSubmenuContents"

	| aList |
	aList _ OrderedCollection new.
	self items do: [:anItem | aList addAll: (anItem allWordingsNotInSubMenus: verbotenSubmenuContentsList)].
	^ aList! !


!MenuMorph methodsFor: 'private' stamp: 'ar 10/7/2000 21:08'!
invokeMetaMenu: evt
	stayUp ifFalse:[^self]. "Don't allow this"
	^super invokeMetaMenu: evt! !

!MenuMorph methodsFor: 'private' stamp: 'ar 2/10/2001 00:37'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"
	^self valueOfProperty: #morphicLayerNumber  ifAbsent: [
		stayUp ifTrue:[100] ifFalse:[10]
	]! !

!MenuMorph methodsFor: 'private' stamp: 'sw 5/1/2002 01:39'!
positionAt: aPoint relativeTo: aMenuItem inWorld: aWorld
	"Note: items may not be laid out yet (I found them all to be at 0@0),  
	so we have to add up heights of items above the selected item."

	| i yOffset sub delta |	
	self fullBounds. "force layout"
	i _ 0.
	yOffset _ 0.
	[(sub _ self submorphs at: (i _ i + 1)) == aMenuItem]
		whileFalse: [yOffset _ yOffset + sub height].

	self position: aPoint - (2 @ (yOffset + 8)).

	"If it doesn't fit, show it to the left, not to the right of the hand."
	self right > aWorld worldBounds right
		ifTrue:
			[self right: aPoint x + 1].

	"Make sure that the menu fits in the world."
	delta _ self bounds amountToTranslateWithin:
		(aWorld worldBounds withHeight: ((aWorld worldBounds height - 18) max: (ActiveHand position y) + 1)).
	delta = (0 @ 0) ifFalse: [self position: self position + delta]! !

!MenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 12:12'!
selectedItem
	^selectedItem! !


!MenuMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:12'!
roundedCorners
	"Return a list of those corners to round"
	self wasActivatedFromDockingBar
		ifTrue: [""
			activatorDockingBar isFloating
				ifTrue: [^ #(2 3 )].
			activatorDockingBar isAdheringToTop
				ifTrue: [^ #(2 3 )].
			activatorDockingBar isAdheringToBottom
				ifTrue: [^ #(1 4 )].
			activatorDockingBar isAdheringToLeft
				ifTrue: [^ #(3 4 )].
			activatorDockingBar isAdheringToRight
				ifTrue: [^ #(1 2 )]].
	^ super roundedCorners! !

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

MenuMorph class
	instanceVariableNames: ''!

!MenuMorph class methodsFor: 'example' stamp: 'jm 11/4/97 07:46'!
example
	"MenuMorph example"

	| menu |
	menu _ MenuMorph new.
	menu addStayUpItem.
	menu add: 'apples' action: #apples.
	menu add: 'oranges' action: #oranges.
	menu addLine.
	menu addLine.  "extra lines ignored"
	menu add: 'peaches' action: #peaches.
	menu addLine.
	menu add: 'pears' action: #pears.
	menu addLine.
	^ menu
! !


!MenuMorph class methodsFor: 'images' stamp: 'jrp 7/27/2005 23:11'!
closeBoxImage
	"Supplied here because we don't necessarily have ComicBold"

	^ CloseBoxImage ifNil: [CloseBoxImage _ SystemWindow closeBoxImage]! !

!MenuMorph class methodsFor: 'images' stamp: 'nk 8/1/2002 17:03'!
pushPinImage
	"Answer the push-pin image, creating and caching it at this time if it is absent"

	^ PushPinImage ifNil: [PushPinImage _ ((ColorForm
	extent: 13@14
	depth: 8
	fromArray: #( 4294967295 4278387717 101187583 4278190080 4294967295 4278914061 235868177 4278190080 4294967295 303240213 370612249 4278190080 4294967295 454827294 522199330 587202560 4280624679 673786411 741158447 805306368 825373492 892745528 960117564 1023410176 1044332609 1111704645 1179076681 1241513984 1263291726 1330663762 1398035764 1442840576 1465407834 1532779870 1600151906 1660944384 1684366951 1751738987 1819148287 4278190080 4285559154 1937012086 2004418559 4278190080 2038070140 2101902975 2150891519 4278190080 2172814212 2240186248 327811071 4278190080 2324430732 2374930320 2449473535 4278190080)
	offset: 0@0)
	colorsFromArray: #(#(1.0 1.0 1.0) #(0.995 0.995 0.995) #(0.987 0.987 0.987) #(0.667 0.662 0.667) #(0.149 0.149 0.145) #(0.254 0.262 0.262) #(0.215 0.262 0.285) #(0.478 0.482 0.482) #(0.921 0.921 0.929) #(0.987 0.991 0.983) #(0.956 0.956 0.956) #(0.102 0.102 0.102) #(0.69 0.717 0.717) #(0.293 0.694 0.89) #(0.027 0.58 0.87) #(0.023 0.293 0.443) #(0.18 0.184 0.199) #(0.874 0.878 0.874) #(0.858 0.858 0.858) #(0.02 0.02 0.02) #(0.811 0.858 0.882) #(0.012 0.595 0.893) #(0.0 0.595 0.893) #(0.008 0.591 0.886) #(0.02 0.242 0.369) #(0.207 0.199 0.199) #(0.948 0.948 0.948) #(0.886 0.886 0.886) #(0.035 0.031 0.027) #(0.698 0.71 0.717) #(0.141 0.638 0.886) #(0.004 0.595 0.897) #(0.008 0.587 0.89) #(0.023 0.533 0.796) #(0.016 0.039 0.063) #(0.568 0.568 0.568) #(0.983 0.983 0.983) #(0.925 0.925 0.925) #(0.694 0.694 0.694) #(0.807 0.807 0.807) #(0.63 0.63 0.63) #(0.035 0.043 0.039) #(0.345 0.349 0.333) #(0.533 0.804 0.929) #(0.004 0.595 0.893) #(0.008 0.591 0.893) #(0.012 0.595 0.905) #(0.031 0.164 0.246) #(0.188 0.196 0.192) #(0.893 0.893 0.893) #(0.192 0.192 0.192) #(0.207 0.207 0.207) #(0.012 0.012 0.012) #(0.023 0.012 0.02) #(0.016 0.086 0.129) #(0.031 0.043 0.055) #(0.427 0.595 0.702) #(0.031 0.599 0.893) #(0.008 0.587 0.897) #(0.02 0.587 0.897) #(0.016 0.254 0.365) #(0.027 0.031 0.027) #(0.466 0.466 0.466) #(0.361 0.361 0.361) #(0.341 0.341 0.341) #(0.035 0.027 0.023) #(0.408 0.423 0.427) #(0.102 0.591 0.847) #(0.027 0.529 0.804) #(0.016 0.584 0.866) #(0.016 0.587 0.878) #(0.023 0.568 0.85) #(0.023 0.58 0.862) #(0.023 0.129 0.192) #(0.063 0.063 0.063) #(0.317 0.317 0.313) #(0.423 0.419 0.415) #(0.714 0.725 0.714) #(0.714 0.714 0.71) #(0.979 0.976 0.968) #(0.239 0.674 0.905) #(0.016 0.595 0.89) #(0.023 0.564 0.862) #(0.031 0.145 0.219) #(0.02 0.027 0.047) #(0.012 0.039 0.059) #(0.431 0.431 0.431) #(0.458 0.458 0.466) #(0.133 0.199 0.231) #(0.505 0.792 0.933) #(0.741 0.886 0.956) #(0.474 0.776 0.925) #(0.035 0.587 0.882) #(0.023 0.556 0.843) #(0.027 0.188 0.278) #(0.043 0.035 0.051) #(0.435 0.439 0.435) #(0.357 0.357 0.357) #(0.619 0.619 0.619) #(0.952 0.952 0.952) #(0.792 0.8 0.804) #(0.008 0.02 0.027) #(0.023 0.478 0.725) #(0.016 0.587 0.893) #(0.023 0.595 0.89) #(0.023 0.466 0.706) #(0.016 0.094 0.141) #(0.008 0.008 0.012) #(0.02 0.012 0.012) #(0.638 0.638 0.642) #(0.991 0.991 0.991) #(0.976 0.976 0.976) #(0.168 0.164 0.164) #(0.016 0.18 0.25) #(0.008 0.58 0.874) #(0.016 0.591 0.87) #(0.031 0.156 0.239) #(0.02 0.008 0.016) #(0.012 0.012 0.02) #(0.008 0.008 0.008) #(0.258 0.258 0.258) #(0.866 0.866 0.866) #(0.051 0.047 0.047) #(0.023 0.016 0.027) #(0.027 0.258 0.388) #(0.016 0.564 0.858) #(0.016 0.435 0.654) #(0.023 0.18 0.258) #(0.016 0.016 0.016) #(0.4 0.4 0.4) #(0.039 0.039 0.039) #(0.325 0.325 0.321) #(0.035 0.031 0.039) #(0.02 0.09 0.133) #(0.031 0.188 0.289) #(0.023 0.137 0.188) #(0.016 0.027 0.043) #(0.576 0.576 0.576) #(0.16 0.16 0.16) #(0.733 0.733 0.733) #(0.753 0.749 0.749) #(0.365 0.365 0.376) #(0.117 0.113 0.121) #(0.074 0.066 0.066) #(0.203 0.203 0.219) #(0.603 0.603 0.603) #(0.979 0.979 0.979) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #( )  )) ]! !


!MenuMorph class methodsFor: 'instance creation' stamp: 'jm 5/14/1998 17:21'!
entitled: aString
	"Answer a new instance of me with the given title."

	^ self new addTitle: aString
! !

!MenuMorph class methodsFor: 'instance creation' stamp: 'dgd 10/1/2004 11:56'!
fromArray: anArray 
	"Construct a menu from anArray. The elements of anArray  
	must be either:  
	* A pair of the form: <label> <selector>  
	or	* The 'dash' (or 'minus sign') symbol  
	 
	Refer to the example at the bottom of the method"
	| menu |

	menu := self new.

	anArray
		do: [:anElement |
			anElement size == 1
				ifTrue: [
					anElement == #- ifFalse: [^ self error: 'badly-formed menu constructor'].
					menu addLine.
				]
				ifFalse: [
					anElement size == 2 ifFalse: [^ self error: 'badly-formed menu constructor'].
					menu add: anElement first action: anElement second.
				]
		].

	^ menu! !

!MenuMorph class methodsFor: 'instance creation' stamp: 'jrp 7/23/2005 12:13'!
initialize

	"MenuMorph initialize"
	
	Preferences
		setParameter: #menuTitleBorderWidth to: 0;
		setParameter: #menuTitleColor to: (TranslucentColor r: 0.87 g: 0.8 b: 1 alpha: 0.65);
		setParameter: #menuColor to: (Color 
			r: (215/255) asFloat 
			g: (220/255) asFloat 
			b: (232/255) asFloat).

	CloseBoxImage _ nil
! !
WidgetStub subclass: #MenuStub
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!MenuStub methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2006 10:43'!
click: aString
	| item |
	item _ self items detect: [:ea | ea label = aString] ifNone: [^ self].
	item action isSymbol
		ifTrue: [self model perform: item action]
		ifFalse: [item action value]! !

!MenuStub methodsFor: 'as yet unclassified' stamp: 'cwp 6/9/2005 00:29'!
items
	^ spec items! !

!MenuStub methodsFor: 'as yet unclassified' stamp: 'cwp 6/9/2005 00:36'!
labels
	^ self items keys! !
TileMorph subclass: #MenuTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!MenuTile commentStamp: '<historical>' prior: 0!
A tile representing a menu item!


!MenuTile methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:28'!
resultType
	"Answer the result type of the receiver"

	^ #Menu! !


!MenuTile methodsFor: 'arrows' stamp: 'sw 11/22/1999 11:54'!
arrowAction: delta
	| phrase aPlayer newItem |
	(phrase _ self ownerThatIsA: PhraseTileMorph) ifNil: [^ self].
	aPlayer _ phrase associatedPlayer.
	newItem _ delta > 0
		ifTrue:
			[aPlayer menuItemAfter: literal]
		ifFalse:
			[aPlayer menuItemBefore: literal].
	self literal: newItem.
	self layoutChanged! !


!MenuTile methodsFor: 'event handling' stamp: 'sw 11/22/1999 12:15'!
handlesMouseDown: evt
	^ true! !

!MenuTile methodsFor: 'event handling' stamp: 'sw 10/3/2002 21:16'!
mouseDown: evt
	| aPoint aMenu reply |
	aPoint _ evt cursorPoint.
	nArrowTicks _ 0.
	((upArrow bounds containsPoint: aPoint) or: [downArrow bounds containsPoint: aPoint]) ifTrue: [^ self mouseStillDown: evt].
	aMenu _ SelectionMenu selections: (((self ownerThatIsA: PhraseTileMorph) associatedPlayer costume allMenuWordings) copyWithout: '').
	reply _ aMenu startUp.
	reply ifNotNil: [self literal: reply; layoutChanged]! !


!MenuTile methodsFor: 'events-processing' stamp: 'ar 9/12/2000 23:05'!
handlerForMouseDown: anEvent
	"Don't give anybody over me a chance"
	^self! !

!MenuTile methodsFor: 'events-processing' stamp: 'ar 10/9/2000 21:16'!
mouseDownPriority
	^100! !


!MenuTile methodsFor: 'initialization' stamp: 'dgd 9/6/2003 17:36'!
initialize
	"Initialize the menu tile"

	super initialize.
	self addArrows; setLiteral: 'send to back' translated.
	self labelMorph useStringFormat; putSelector: nil! !
DataType subclass: #MenuType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!
!MenuType commentStamp: 'sw 1/6/2005 03:45' prior: 0!
A type associated with menu-item values.  An imperfect thing thus far, only usable in the doMenuItem etoy scripting phrase.!


!MenuType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:24'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	self vocabularyName: #Menu! !


!MenuType methodsFor: 'tiles' stamp: 'sw 1/5/2005 22:27'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^false! !


!MenuType methodsFor: '*eToys-color' stamp: 'sw 9/27/2001 17:21'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(0.4 0.4 0.4)	! !


!MenuType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ MenuTile new typeColor: self typeColor! !
Object subclass: #Message
	instanceVariableNames: 'selector args lookupClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!Message commentStamp: '<historical>' prior: 0!
I represent a selector and its argument values.
	
Generally, the system does not use instances of Message for efficiency reasons. However, when a message is not understood by its receiver, the interpreter will make up an instance of me in order to capture the information involved in an actual message transmission. This instance is sent it as an argument with the message doesNotUnderstand: to the receiver.!


!Message methodsFor: 'accessing'!
argument
	"Answer the first (presumably sole) argument"

	^args at: 1! !

!Message methodsFor: 'accessing'!
argument: newValue
	"Change the first argument to newValue and answer self"

	args at: 1 put: newValue! !

!Message methodsFor: 'accessing'!
arguments
	"Answer the arguments of the receiver."

	^args! !

!Message methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:32'!
lookupClass

	^ lookupClass! !

!Message methodsFor: 'accessing'!
selector
	"Answer the selector of the receiver."

	^selector! !

!Message methodsFor: 'accessing'!
sends: aSelector
	"answer whether this message's selector is aSelector"

	^selector == aSelector! !


!Message methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 17:37'!
pushReceiver! !


!Message methodsFor: 'printing' stamp: 'ajh 10/9/2001 15:31'!
printOn: stream

	args isEmpty ifTrue: [^ stream nextPutAll: selector].
	args with: selector keywords do: [:arg :word |
		stream nextPutAll: word.
		stream space.
		arg printOn: stream.
		stream space.
	].
	stream skip: -1.
! !

!Message methodsFor: 'printing' stamp: 'sma 6/1/2000 10:01'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	aStream nextPut: $(;
	 nextPutAll: self class name;
	 nextPutAll: ' selector: ';
	 store: selector;
	 nextPutAll: ' arguments: ';
	 store: args;
	 nextPut: $)! !


!Message methodsFor: 'sending' stamp: 'ajh 1/22/2003 11:51'!
sendTo: receiver
	"answer the result of sending this message to receiver"

	^ receiver perform: selector withArguments: args! !

!Message methodsFor: 'sending' stamp: 'di 3/25/1999 21:54'!
sentTo: receiver
	"answer the result of sending this message to receiver"

	lookupClass == nil
		ifTrue: [^ receiver perform: selector withArguments: args]
		ifFalse: [^ receiver perform: selector withArguments: args inSuperclass: lookupClass]! !


!Message methodsFor: 'stub creation' stamp: 'ads 7/21/2003 17:33'!
createStubMethod
	| argNames aOrAn argName arg argClassName |
	argNames _ Set new.
	^ String streamContents: [ :s |
		self selector keywords doWithIndex: [ :key :i |
			s nextPutAll: key.
			((key last = $:) or: [self selector isInfix]) ifTrue: [
				arg _ self arguments at: i.
				argClassName _ (arg isKindOf: Class) ifTrue: ['Class'] ifFalse: [arg class name].
				aOrAn _ argClassName first isVowel ifTrue: ['an'] ifFalse: ['a'].
				argName _ aOrAn, argClassName.
				[argNames includes: argName] whileTrue: [argName _ argName, i asString].
				argNames add: argName.
				s nextPutAll: ' '; nextPutAll: argName; space
			].
		].
		s cr; tab.
		s nextPutAll: 'self shouldBeImplemented'
	]! !


!Message methodsFor: 'private' stamp: 'ajh 9/23/2001 04:59'!
lookupClass: aClass

	lookupClass _ aClass! !

!Message methodsFor: 'private' stamp: 'ajh 3/9/2003 19:25'!
setSelector: aSymbol

	selector _ aSymbol.
! !

!Message methodsFor: 'private'!
setSelector: aSymbol arguments: anArray

	selector _ aSymbol.
	args _ anArray! !

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

Message class
	instanceVariableNames: ''!

!Message class methodsFor: 'instance creation'!
selector: aSymbol
	"Answer an instance of me with unary selector, aSymbol."

	^self new setSelector: aSymbol arguments: (Array new: 0)! !

!Message class methodsFor: 'instance creation'!
selector: aSymbol argument: anObject 
	"Answer an instance of me whose selector is aSymbol and single 
	argument is anObject."

	^self new setSelector: aSymbol arguments: (Array with: anObject)! !

!Message class methodsFor: 'instance creation'!
selector: aSymbol arguments: anArray 
	"Answer an instance of me with selector, aSymbol, and arguments, 
	anArray."

	^self new setSelector: aSymbol arguments: anArray! !
MessageNode subclass: #MessageAsTempNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!MessageAsTempNode commentStamp: '<historical>' prior: 0!
This node represents accesses to temporary variables for do-its in the debugger.  Since they execute in another context, they must send a message to the original context to access the value of the temporary variable in that context.!


!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:38'!
asStorableNode: encoder
	"This node is a message masquerading as a temporary variable.
	It currently has the form {homeContext tempAt: offset}.
	We need to generate code for {expr storeAt: offset inTempFrame: homeContext},
	where the expr, the block argument, is already on the stack.
	This, in turn will get turned into {homeContext tempAt: offset put: expr}
	at runtime if nobody disturbs storeAt:inTempFrame: in Object (not clean)"
	^ MessageAsTempNode new
		receiver: nil  "suppress code generation for reciever already on stack"
		selector: #storeAt:inTempFrame:
		arguments: (arguments copyWith: receiver)
		precedence: precedence
		from: encoder! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 10/12/1999 17:29'!
code
	"Allow synthetic temp nodes to be sorted by code"
	^ arguments first literalValue! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
emitStorePop: stack on: codeStream
	"This node has the form {expr storeAt: offset inTempFrame: homeContext},
	where the expr, the block argument, is already on the stack."
	^ self emitForEffect: stack on: codeStream! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:35'!
isTemp
	"Masquerading for debugger access to temps."
	^ true! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
nowHasDef
	"For compatibility with temp scope protocol"
! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
nowHasRef
	"For compatibility with temp scope protocol"
! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
scope
	"For compatibility with temp scope protocol"
	^ -1! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
scope: ignored
	"For compatibility with temp scope protocol"
! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
sizeForStorePop: encoder
	"This node has the form {expr storeAt: offset inTempFrame: homeContext},
	where the expr, the block argument, is already on the stack."
	^ self sizeForEffect: encoder! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:40'!
store: expr from: encoder 
	"ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment).
	For assigning into temps of a context being debugged."

	selector key ~= #tempAt: 
		ifTrue: [^self error: 'cant transform this message'].
	^ MessageAsTempNode new
		receiver: receiver
		selector: #tempAt:put:
		arguments: (arguments copyWith: expr)
		precedence: precedence
		from: encoder! !
ProtoObject subclass: #MessageCatcher
	instanceVariableNames: 'accumulator'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Contexts'!
!MessageCatcher commentStamp: '<historical>' prior: 0!
Any message sent to me is returned as a Message object.

"Message catcher" creates an instance of me.
!


!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'!
doesNotUnderstand: aMessage

	accumulator ifNotNil: [accumulator add: aMessage].
	^ aMessage! !

!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'!
privAccumulator

	^ accumulator! !

!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'!
privAccumulator: collection

	accumulator _ collection! !

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

MessageCatcher class
	instanceVariableNames: ''!
MessageSet subclass: #MessageNames
	instanceVariableNames: 'searchString selectorList selectorListIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!

!MessageNames methodsFor: 'initialization' stamp: 'sw 7/28/2001 02:16'!
inMorphicWindowLabeled: labelString
	"Answer a morphic window with the given label that can display the receiver"
"MessageNames openMessageNames"

	^ self inMorphicWindowWithInitialSearchString: nil! !

!MessageNames methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
inMorphicWindowWithInitialSearchString: initialString
	"Answer a morphic window with the given initial search string, nil if none"

"MessageNames openMessageNames"

	| window selectorListView firstDivider secondDivider horizDivider typeInPane searchButton plugTextMor |
	window := (SystemWindow labelled: 'Message Names') model: self.
	firstDivider := 0.07.
	secondDivider := 0.5.
	horizDivider := 0.5.
	typeInPane := AlignmentMorph newRow vResizing: #spaceFill; height: 14.
	typeInPane hResizing: #spaceFill.
	typeInPane listDirection: #leftToRight.

	plugTextMor := PluggableTextMorph on: self
					text: #searchString accept: #searchString:notifying:
					readSelection: nil menu: nil.
	plugTextMor setProperty: #alwaysAccept toValue: true.
	plugTextMor askBeforeDiscardingEdits: false.
	plugTextMor acceptOnCR: true.
	plugTextMor setTextColor: Color brown.
	plugTextMor setNameTo: 'Search'.
	plugTextMor vResizing: #spaceFill; hResizing: #spaceFill.
	plugTextMor hideScrollBarsIndefinitely.
	plugTextMor setTextMorphToSelectAllOnMouseEnter.

	searchButton := SimpleButtonMorph new 
		target: self;
		color: Color white;
		label: 'Search';
		actionSelector: #doSearchFrom:;
		arguments: {plugTextMor}.
	searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below.  Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'.

	typeInPane addMorphFront: searchButton.
	typeInPane addTransparentSpacerOfSize: 6@0.
	typeInPane addMorphBack: plugTextMor.
	initialString isEmptyOrNil ifFalse:
		[plugTextMor setText: initialString].

	window addMorph: typeInPane frame: (0@0 corner: horizDivider @ firstDivider).

	selectorListView := PluggableListMorph on: self
		list: #selectorList
		selected: #selectorListIndex
		changeSelected: #selectorListIndex:
		menu: #selectorListMenu:
		keystroke: #selectorListKey:from:.
	selectorListView menuTitleSelector: #selectorListMenuTitle.
	window addMorph: selectorListView frame: (0 @ firstDivider corner: horizDivider @ secondDivider).

	window addMorph: self buildMorphicMessageList frame: (horizDivider @ 0 corner: 1@ secondDivider).

	self 
		addLowerPanesTo: window 
		at: (0 @ secondDivider corner: 1@1) 
		with: nil.

	initialString isEmptyOrNil ifFalse:
		[self searchString: initialString notifying: nil].
	^ window! !

!MessageNames methodsFor: 'initialization' stamp: 'sw 7/24/2001 01:35'!
selectorListKey: aChar from: view
	"Respond to a Command key in the message-list pane."

	aChar == $n ifTrue: [^ self browseSenders].
	aChar == $c ifTrue: [^ self copyName].
	aChar == $b ifTrue: [^ self browseMethodFull].
! !


!MessageNames methodsFor: 'message list menu' stamp: 'sd 11/20/2005 21:27'!
copyName
	"Copy the current selector to the clipboard"

	| selector |
	(selector := self selectorList at: selectorListIndex ifAbsent: [nil]) ifNotNil:
		[Clipboard clipboardText: selector asString asText]! !


!MessageNames methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
computeSelectorListFromSearchString
	"Compute selector list from search string"
	| raw sorted |
	searchString := searchString asString copyWithout: $ .
	selectorList := Cursor wait
				showWhile: [raw := Symbol selectorsContaining: searchString.
					sorted := raw as: SortedCollection.
					sorted
						sortBlock: [:x :y | x asLowercase <= y asLowercase].
					sorted asArray].
	selectorList size > 19
		ifFalse: ["else the following filtering is considered too expensive. This 19  
			should be a system-maintained Parameter, someday"
			selectorList := self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList].
	^ selectorList! !

!MessageNames methodsFor: 'search' stamp: 'sw 7/28/2001 00:32'!
doSearchFrom: aPane
	"The user hit the Search button -- treat it as a synonym for the user having hit the Return or Enter (or cmd-s) in the type-in pane"

	aPane accept.
	aPane selectAll! !

!MessageNames methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
searchString
	"Answer the current searchString, initializing it if need be"

	| pane |
	searchString isEmptyOrNil ifTrue:
		[searchString := 'type here, then hit Search'.
		pane := self containingWindow findDeepSubmorphThat:
			[:m | m knownName = 'Search'] ifAbsent: ["this happens during window creation" ^ searchString].
			pane setText: searchString.
			pane setTextMorphToSelectAllOnMouseEnter.
			pane selectAll].
	^ searchString! !

!MessageNames methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
searchString: aString notifying: aController
	"Take what the user typed and find all selectors containing it"

	searchString := aString asString copyWithout: $ .
	self containingWindow setLabel: 'Message names containing "', searchString asLowercase, '"'.
	selectorList := nil.
	self changed: #selectorList.
	self changed: #messageList.
	^ true! !

!MessageNames methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'!
showOnlyImplementedSelectors
	"Caution -- can be slow!! Filter my selector list down such that it only  
	shows selectors that are actually implemented somewhere in the system."
	self okToChange
		ifTrue: [Cursor wait
				showWhile: [selectorList := self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList.
					self changed: #selectorList.
					self changed: #messageList]]! !


!MessageNames methodsFor: 'selection' stamp: 'sw 7/24/2001 01:46'!
selection
	"Answer the item in the list that is currently selected, or nil if no selection is present"

	^ self messageList at: messageListIndex ifAbsent: [nil]! !


!MessageNames methodsFor: 'selector list' stamp: 'sd 11/20/2005 21:27'!
messageList
	"Answer the receiver's message list, computing it if necessary. The way 
	to force a recomputation is to set the messageList to nil"
	messageList
		ifNil: [messageList := selectorListIndex == 0
						ifTrue: [#()]
						ifFalse: [self systemNavigation
								allImplementorsOf: (selectorList at: selectorListIndex)].
			self
				messageListIndex: (messageList size > 0
						ifTrue: [1]
						ifFalse: [0])].
	^ messageList! !

!MessageNames methodsFor: 'selector list' stamp: 'sd 11/20/2005 21:27'!
selectorList
	"Answer the selectorList"

	selectorList ifNil:
		[self computeSelectorListFromSearchString.
		selectorListIndex :=  selectorList size > 0
			ifTrue:	[1]
			ifFalse: [0].
		messageList := nil].
	^ selectorList! !

!MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:55'!
selectorListIndex
	"Answer the selectorListIndex"

	^ selectorListIndex! !

!MessageNames methodsFor: 'selector list' stamp: 'sd 11/20/2005 21:27'!
selectorListIndex: anInteger 
	"Set the selectorListIndex as specified, and propagate consequences"

	selectorListIndex := anInteger.
	selectorListIndex = 0
		ifTrue: [^ self].
	messageList := nil.
	self changed: #selectorListIndex.
	self changed: #messageList! !

!MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:58'!
selectorListMenu: aMenu
	"Answer the menu associated with the selectorList"

	aMenu addList: #(
		('senders (n)'				browseSenders		'browse senders of the chosen selector')
		('copy selector to clipboard'	copyName			'copy the chosen selector to the clipboard, for subsequent pasting elsewhere')
		-
		('show only implemented selectors'	showOnlyImplementedSelectors		'remove from the selector-list all symbols that do not represent implemented methods')).

	^ aMenu! !

!MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:47'!
selectorListMenuTitle
	"Answer the title to supply for the menu belonging to the selector-list pane"

	^ 'Click on any item in the list
to see all implementors of it'! !

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

MessageNames class
	instanceVariableNames: ''!

!MessageNames class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
methodBrowserSearchingFor: searchString
	"Answer an method-browser window whose search-string is initially as indicated"

	| aWindow |
	aWindow := self new inMorphicWindowWithInitialSearchString: searchString.
	aWindow applyModelExtent.
	^ aWindow! !

!MessageNames class methodsFor: 'instance creation' stamp: 'sw 7/24/2001 18:03'!
openMessageNames
	"Open a new instance of the receiver in the active world"

	self new openAsMorphNamed: 'Message Names' inWorld: ActiveWorld

	"MessageNames openMessageNames"
! !

!MessageNames class methodsFor: 'instance creation' stamp: 'sw 7/28/2001 00:56'!
prototypicalToolWindow
	"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"

	^ self methodBrowserSearchingFor: nil! !


!MessageNames class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:35'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Message Names' brightColor: #(0.645 1.0 0.452) pastelColor: #(0.843 0.976 0.843) helpMessage: 'A tool finding, viewing, and editing all methods whose names contiane a given character sequence.'! !


!MessageNames class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/10/2003 12:53'!
initialize

	self registerInFlapsRegistry.	! !

!MessageNames class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/10/2003 12:53'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(MessageNames			prototypicalToolWindow		'Message Names'		'A tool for finding, viewing, and editing all methods whose names contain a given character sequence.')
						forFlapNamed: 'Tools']! !

!MessageNames class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:37'!
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] ! !
ParseNode subclass: #MessageNode
	instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode'
	classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers StdTypers ThenFlag'
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!MessageNode commentStamp: '<historical>' prior: 0!
I represent a receiver and its message.
	
Precedence codes:
	1 unary
	2 binary
	3 keyword
	4 other
	
If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.!


!MessageNode methodsFor: 'cascading'!
cascadeReceiver
	"Nil out rcvr (to indicate cascade) and return what it had been."

	| rcvr |
	rcvr _ receiver.
	receiver _ nil.
	^rcvr! !


!MessageNode methodsFor: 'code generation' stamp: 'tao 8/20/97 22:24'!
emitCase: stack on: strm value: forValue

	| braceNode sizeStream thenSize elseSize |
	forValue not
		ifTrue: [^super emitForEffect: stack on: strm].
	braceNode _ arguments first.
	sizeStream _ ReadStream on: sizes.
	receiver emitForValue: stack on: strm.
	braceNode casesForwardDo:
		[:keyNode :valueNode :last |
		thenSize _ sizeStream next.
		elseSize _ sizeStream next.
		last ifFalse: [strm nextPut: Dup. stack push: 1].
		keyNode emitForEvaluatedValue: stack on: strm.
		equalNode emit: stack args: 1 on: strm.
		self emitBranchOn: false dist: thenSize pop: stack on: strm.
		last ifFalse: [strm nextPut: Pop. stack pop: 1].
		valueNode emitForEvaluatedValue: stack on: strm.
		last ifTrue: [stack pop: 1].
		valueNode returns ifFalse: [self emitJump: elseSize on: strm]].
	arguments size = 2
		ifTrue:
			[arguments last emitForEvaluatedValue: stack on: strm] "otherwise: [...]"
		ifFalse:
			[NodeSelf emitForValue: stack on: strm.
			caseErrorNode emit: stack args: 0 on: strm]! !

!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:39'!
emitForEffect: stack on: strm
	"For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly."
	special > 0
		ifTrue: 
			[pc _ 0.
			self perform: (MacroEmitters at: special) with: stack with: strm with: false]
		ifFalse: 
			[super emitForEffect: stack on: strm]! !

!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:40'!
emitForValue: stack on: strm
	"For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly."
	special > 0
		ifTrue: 
			[pc _ 0.
			self perform: (MacroEmitters at: special) with: stack with: strm with: true]
		ifFalse: 
			[receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm].
			arguments do: [:argument | argument emitForValue: stack on: strm].
			selector
				emit: stack
				args: arguments size
				on: strm
				super: receiver == NodeSuper.
			pc _ strm position]! !

!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:23'!
emitIf: stack on: strm value: forValue
	| thenExpr thenSize elseExpr elseSize |
	thenSize _ sizes at: 1.
	elseSize _ sizes at: 2.
	(forValue not and: [(elseSize*thenSize) > 0])
		ifTrue:  "Two-armed IFs forEffect share a single pop"
			[^ super emitForEffect: stack on: strm].
	thenExpr _ arguments at: 1.
	elseExpr _ arguments at: 2.
	receiver emitForValue: stack on: strm.
	forValue
		ifTrue:  "Code all forValue as two-armed"
			[self emitBranchOn: false dist: thenSize pop: stack on: strm.
			pc _ strm position.
			thenExpr emitForEvaluatedValue: stack on: strm.
			stack pop: 1.  "then and else alternate; they don't accumulate"
			thenExpr returns not
				ifTrue:  "Elide jump over else after a return"
					[self emitJump: elseSize on: strm].
			elseExpr emitForEvaluatedValue: stack on: strm]
		ifFalse:  "One arm is empty here (two-arms code forValue)"
			[thenSize > 0
				ifTrue:
					[self emitBranchOn: false dist: thenSize pop: stack on: strm.
					pc _ strm position.
					thenExpr emitForEvaluatedEffect: stack on: strm]
				ifFalse:
					[self emitBranchOn: true dist: elseSize pop: stack on: strm.
					pc _ strm position.
					elseExpr emitForEvaluatedEffect: stack on: strm]]! !

!MessageNode methodsFor: 'code generation' stamp: 'ajh 7/31/2003 11:26'!
emitIfNil: stack on: strm value: forValue

	| theNode theSize theSelector |
	theNode _ arguments first.
	theSize _ sizes at: 1.
	theSelector _ #ifNotNil:.
	receiver emitForValue: stack on: strm.
	forValue ifTrue: [strm nextPut: Dup. stack push: 1].
	strm nextPut: LdNil. stack push: 1.
	equalNode emit: stack args: 1 on: strm.
	self 
		emitBranchOn: (selector key == theSelector)
		dist: theSize 
		pop: stack 
		on: strm.
	pc _ strm position.
	forValue 
		ifTrue: 
			[strm nextPut: Pop. stack pop: 1.
			theNode emitForEvaluatedValue: stack on: strm]	
		ifFalse: [theNode emitForEvaluatedEffect: stack on: strm].! !

!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:42'!
emitToDo: stack on: strm value: forValue 
	" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: "
	| loopSize initStmt limitInit test block incStmt blockSize |
	initStmt _ arguments at: 4.
	limitInit _ arguments at: 7.
	test _ arguments at: 5.
	block _ arguments at: 3.
	incStmt _ arguments at: 6.
	blockSize _ sizes at: 1.
	loopSize _ sizes at: 2.
	limitInit == nil
		ifFalse: [limitInit emitForEffect: stack on: strm].
	initStmt emitForEffect: stack on: strm.
	test emitForValue: stack on: strm.
	self emitBranchOn: false dist: blockSize pop: stack on: strm.
	pc _ strm position.
	block emitForEvaluatedEffect: stack on: strm.
	incStmt emitForEffect: stack on: strm.
	self emitJump: 0 - loopSize on: strm.
	forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! !

!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:36'!
emitWhile: stack on: strm value: forValue 
	" L1: ... Bfp(L2)|Btp(L2) ... Jmp(L1) L2: "
	| cond stmt stmtSize loopSize |
	cond _ receiver.
	stmt _ arguments at: 1.
	stmtSize _ sizes at: 1.
	loopSize _ sizes at: 2.
	cond emitForEvaluatedValue: stack on: strm.
	self emitBranchOn: (selector key == #whileFalse:)  "Bfp for whileTrue"
					dist: stmtSize pop: stack on: strm.   "Btp for whileFalse"
	pc _ strm position.
	stmt emitForEvaluatedEffect: stack on: strm.
	self emitJump: 0 - loopSize on: strm.
	forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! !

!MessageNode methodsFor: 'code generation' stamp: 'tao 8/20/97 22:25'!
sizeCase: encoder value: forValue

	| braceNode sizeIndex thenSize elseSize |
	forValue not
		ifTrue: [^super sizeForEffect: encoder].
	equalNode _ encoder encodeSelector: #=.
	braceNode _ arguments first.
	sizes _ Array new: 2 * braceNode numElements.
	sizeIndex _ sizes size.
	elseSize _ arguments size = 2
		ifTrue:
			[arguments last sizeForEvaluatedValue: encoder] "otherwise: [...]"
		ifFalse:
			[caseErrorNode _ encoder encodeSelector: #caseError.
			 1 + (caseErrorNode size: encoder args: 0 super: false)]. "self caseError"
	braceNode casesReverseDo:
		[:keyNode :valueNode :last |
		sizes at: sizeIndex put: elseSize.
		thenSize _ valueNode sizeForEvaluatedValue: encoder.
		last ifFalse: [thenSize _ thenSize + 1]. "Pop"
		valueNode returns ifFalse: [thenSize _ thenSize + (self sizeJump: elseSize)].
		sizes at: sizeIndex-1 put: thenSize.
		last ifFalse: [elseSize _ elseSize + 1]. "Dup"
		elseSize _ elseSize + (keyNode sizeForEvaluatedValue: encoder) +
			(equalNode size: encoder args: 1 super: false) +
			(self sizeBranchOn: false dist: thenSize) + thenSize.
		sizeIndex _ sizeIndex - 2].
	^(receiver sizeForValue: encoder) + elseSize
! !

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

	special > 0 
		ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: false].
	^super sizeForEffect: encoder! !

!MessageNode methodsFor: 'code generation'!
sizeForValue: encoder
	| total argSize |
	special > 0 
		ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true].
	receiver == NodeSuper
		ifTrue: [selector _ selector copy "only necess for splOops"].
	total _ selector size: encoder args: arguments size super: receiver == NodeSuper.
	receiver == nil 
		ifFalse: [total _ total + (receiver sizeForValue: encoder)].
	sizes _ arguments collect: 
					[:arg | 
					argSize _ arg sizeForValue: encoder.
					total _ total + argSize.
					argSize].
	^total! !

!MessageNode methodsFor: 'code generation'!
sizeIf: encoder value: forValue
	| thenExpr elseExpr branchSize thenSize elseSize |
	thenExpr _ arguments at: 1.
	elseExpr _ arguments at: 2.
	(forValue
		or: [(thenExpr isJust: NodeNil)
		or: [elseExpr isJust: NodeNil]]) not
			"(...not ifTrue: avoids using ifFalse: alone during this compile)"
		ifTrue:  "Two-armed IFs forEffect share a single pop"
			[^ super sizeForEffect: encoder].
	forValue
		ifTrue:  "Code all forValue as two-armed"
			[elseSize _ elseExpr sizeForEvaluatedValue: encoder.
			thenSize _ (thenExpr sizeForEvaluatedValue: encoder)
					+ (thenExpr returns
						ifTrue: [0]  "Elide jump over else after a return"
						ifFalse: [self sizeJump: elseSize]).
			branchSize _ self sizeBranchOn: false dist: thenSize]
		ifFalse:  "One arm is empty here (two-arms code forValue)"
			[(elseExpr isJust: NodeNil)
				ifTrue:
					[elseSize _ 0.
					thenSize _ thenExpr sizeForEvaluatedEffect: encoder.
					branchSize _ self sizeBranchOn: false dist: thenSize]
				ifFalse:
					[thenSize _ 0.
					elseSize _ elseExpr sizeForEvaluatedEffect: encoder.
					branchSize _ self sizeBranchOn: true dist: elseSize]].
	sizes _ Array with: thenSize with: elseSize.
	^ (receiver sizeForValue: encoder) + branchSize
			+ thenSize + elseSize! !

!MessageNode methodsFor: 'code generation' stamp: 'acg 1/28/2000 22:00'!
sizeIfNil: encoder value: forValue

	| theNode theSize theSelector |
	equalNode _ encoder encodeSelector: #==.
	sizes _ Array new: 1.
	theNode _ arguments first.
	theSelector _ #ifNotNil:.
	forValue
		ifTrue:
			[sizes at: 1 put: (theSize _ (1 "pop" + (theNode sizeForEvaluatedValue: encoder))).
			 ^(receiver sizeForValue: encoder) +
				2 "Dup. LdNil" +
				(equalNode size: encoder args: 1 super: false) +
				(self 
					sizeBranchOn: (selector key == theSelector) 
					dist: theSize) +
				theSize]
		ifFalse:
			[sizes at: 1 put: (theSize _ (theNode sizeForEvaluatedEffect: encoder)).
			 ^(receiver sizeForValue: encoder) +
				1 "LdNil" +
				(equalNode size: encoder args: 1 super: false) +
				(self 
					sizeBranchOn: (selector key == theSelector) 
					dist: theSize) +
				theSize]

! !

!MessageNode methodsFor: 'code generation'!
sizeToDo: encoder value: forValue 
	" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: "
	| loopSize initStmt test block incStmt blockSize blockVar initSize limitInit |
	block _ arguments at: 3.
	blockVar _ block firstArgument.
	initStmt _ arguments at: 4.
	test _ arguments at: 5.
	incStmt _ arguments at: 6.
	limitInit _ arguments at: 7.
	initSize _ initStmt sizeForEffect: encoder.
	limitInit == nil
		ifFalse: [initSize _ initSize + (limitInit sizeForEffect: encoder)].
	blockSize _ (block sizeForEvaluatedEffect: encoder)
			+ (incStmt sizeForEffect: encoder) + 2.  "+2 for Jmp backward"
	loopSize _ (test sizeForValue: encoder)
			+ (self sizeBranchOn: false dist: blockSize)
			+ blockSize.
	sizes _ Array with: blockSize with: loopSize.
	^ initSize + loopSize
			+ (forValue ifTrue: [1] ifFalse: [0])    " +1 for value (push nil) "! !

!MessageNode methodsFor: 'code generation'!
sizeWhile: encoder value: forValue 
	"L1: ... Bfp(L2) ... Jmp(L1) L2: nil (nil for value only);
	justStmt, wholeLoop, justJump."
	| cond stmt stmtSize loopSize branchSize |
	cond _ receiver.
	stmt _ arguments at: 1.
	stmtSize _ (stmt sizeForEvaluatedEffect: encoder) + 2.
	branchSize _ self sizeBranchOn: (selector key == #whileFalse:)  "Btp for whileFalse"
					dist: stmtSize.
	loopSize _ (cond sizeForEvaluatedValue: encoder)
			+ branchSize + stmtSize.
	sizes _ Array with: stmtSize with: loopSize.
	^ loopSize    " +1 for value (push nil) "
		+ (forValue ifTrue: [1] ifFalse: [0])! !


!MessageNode methodsFor: 'equation translation'!
arguments
	^arguments! !

!MessageNode methodsFor: 'equation translation' stamp: 'tk 10/27/2000 15:11'!
arguments: list
	arguments _ list! !

!MessageNode methodsFor: 'equation translation' stamp: 'tk 8/4/1999 17:33'!
eval
	"When everything in me is a constant, I can produce a value.  This is only used by the Scripting system (TilePadMorph tilesFrom:in:)"

	| rec args |
	(receiver isKindOf: VariableNode) ifFalse: [^ #illegal].
	rec _ receiver key value.
	args _ arguments collect: [:each | each eval].
	^ rec perform: selector key withArguments: args! !

!MessageNode methodsFor: 'equation translation'!
receiver
	^receiver! !

!MessageNode methodsFor: 'equation translation' stamp: 'RAA 2/14/2001 14:07'!
receiver: val
	"14 feb 2001 - removed return arrow"

	receiver _ val! !

!MessageNode methodsFor: 'equation translation'!
selector
	^selector! !


!MessageNode methodsFor: 'initialize-release' stamp: 'di 6/6/2000 23:24'!
receiver: rcvr selector: selNode arguments: args precedence: p 
	"Decompile."

	self receiver: rcvr
		arguments: args
		precedence: p.
	self noteSpecialSelector: selNode key.
	selector _ selNode.
	"self pvtCheckForPvtSelector: encoder"
	"We could test code being decompiled, but the compiler should've checked already. And where to send the complaint?"! !

!MessageNode methodsFor: 'initialize-release' stamp: 'md 10/20/2004 15:32'!
receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder 
	"Compile."

	| theSelector |
	self receiver: rcvr
		arguments: args
		precedence: p.
	aSelector = #':Repeat:do:'
		ifTrue: [theSelector _ #do:]
		ifFalse: [theSelector _ aSelector].
	self noteSpecialSelector: theSelector.
	(self transform: encoder)
		ifTrue: 
			[selector isNil
				ifTrue: [selector _ SelectorNode new 
							key: (MacroSelectors at: special)
							code: #macro]]
		ifFalse: 
			[selector _ encoder encodeSelector: theSelector.
			rcvr == NodeSuper ifTrue: [encoder noteSuper]].
	self pvtCheckForPvtSelector: encoder! !

!MessageNode methodsFor: 'initialize-release'!
receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range 
	"Compile."

	encoder noteSourceRange: range forNode: self.
	^self
		receiver: rcvr
		selector: selName
		arguments: args
		precedence: p
		from: encoder! !

!MessageNode methodsFor: 'initialize-release' stamp: 'tk 10/26/2000 15:37'!
selector: sel
	selector _ sel! !


!MessageNode methodsFor: 'macro transformations' stamp: 'di 6/11/2000 16:09'!
noteSpecialSelector: selectorSymbol
	" special > 0 denotes specially treated messages. "

	"Deconvert initial keywords from SQ2K"
	special _ #(:Test:Yes: :Test:No: :Test:Yes:No: :Test:No:Yes:
				and: or:
				:Until:do: :While:do: whileFalse whileTrue
				:Repeat:to:do: :Repeat:to:by:do:
				) indexOf: selectorSymbol.
	special > 0 ifTrue: [^ self].

	special _ MacroSelectors indexOf: selectorSymbol.
! !

!MessageNode methodsFor: 'macro transformations' stamp: 'sma 3/3/2000 13:37'!
toDoFromWhileWithInit: initStmt
	"Return nil, or a to:do: expression equivalent to this whileTrue:"
	| variable increment limit toDoBlock body test |
	(selector key == #whileTrue:
		and: [(initStmt isMemberOf: AssignmentNode) and:
				[initStmt variable isTemp]])
		ifFalse: [^ nil].
	body _ arguments last statements.
	variable _ initStmt variable.
	increment _ body last toDoIncrement: variable.
	(increment == nil or: [receiver statements size ~= 1])
		ifTrue: [^ nil].
	test _ receiver statements first.
	"Note: test chould really be checked that <= or >= comparison
	jibes with the sign of the (constant) increment"
	((test isMemberOf: MessageNode)
		and: [(limit _ test toDoLimit: variable) notNil])
		ifFalse: [^ nil].
	toDoBlock _ BlockNode statements: body allButLast returns: false.
	toDoBlock arguments: (Array with: variable).
	^ MessageNode new
		receiver: initStmt value
		selector: (SelectorNode new key: #to:by:do: code: #macro)
		arguments: (Array with: limit with: increment with: toDoBlock)
		precedence: precedence! !

!MessageNode methodsFor: 'macro transformations'!
transform: encoder
	special = 0 ifTrue: [^false].
	(self perform: (MacroTransformers at: special) with: encoder)
		ifTrue: 
			[^true]
		ifFalse: 
			[special _ 0. ^false]! !

!MessageNode methodsFor: 'macro transformations'!
transformAnd: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (arguments at: 1)
					with: (BlockNode withJust: NodeFalse).
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations'!
transformBoolean: encoder
	^self
		checkBlock: (arguments at: 1)
		as: 'argument'
		from: encoder! !

!MessageNode methodsFor: 'macro transformations'!
transformIfFalse: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (BlockNode withJust: NodeNil)
					with: (arguments at: 1).
			^true]
		ifFalse:
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 00:48'!
transformIfFalseIfTrue: encoder
	((self checkBlock: (arguments at: 1) as: 'False arg' from: encoder)
		and: [self checkBlock: (arguments at: 2) as: 'True arg' from: encoder])
		ifTrue: 
			[selector _ #ifTrue:ifFalse:.
			arguments swap: 1 with: 2.
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'di 4/24/2000 13:32'!
transformIfNil: encoder

	(self transformBoolean: encoder) ifFalse: [^ false].
	(MacroSelectors at: special) = #ifNotNil:
	ifTrue:
		[(self checkBlock: arguments first as: 'ifNotNil arg' from: encoder) ifFalse: [^ false].

		"Transform 'ifNotNil: [stuff]' to 'ifNil: [nil] ifNotNil: [stuff]'.
		Slightly better code and more consistent with decompilation."
		self noteSpecialSelector: #ifNil:ifNotNil:.
		selector _ SelectorNode new key: (MacroSelectors at: special) code: #macro.
		arguments _ {BlockNode withJust: NodeNil. arguments first}.
		(self transform: encoder) ifFalse: [self error: 'compiler logic error'].
		^ true]
	ifFalse:
		[^ self checkBlock: arguments first as: 'ifNil arg' from: encoder]
! !

!MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 21:49'!
transformIfNilIfNotNil: encoder
	((self checkBlock: (arguments at: 1) as: 'Nil arg' from: encoder)
		and: [self checkBlock: (arguments at: 2) as: 'NotNil arg' from: encoder])
		ifTrue: 
			[selector _ SelectorNode new key: #ifTrue:ifFalse: code: #macro.
			receiver _ MessageNode new
				receiver: receiver
				selector: #==
				arguments: (Array with: NodeNil)
				precedence: 2
				from: encoder.
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 21:50'!
transformIfNotNilIfNil: encoder
	((self checkBlock: (arguments at: 1) as: 'NotNil arg' from: encoder)
		and: [self checkBlock: (arguments at: 2) as: 'Nil arg' from: encoder])
		ifTrue: 
			[selector _ SelectorNode new key: #ifTrue:ifFalse: code: #macro.
			receiver _ MessageNode new
				receiver: receiver
				selector: #==
				arguments: (Array with: NodeNil)
				precedence: 2
				from: encoder.
			arguments swap: 1 with: 2.
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations'!
transformIfTrue: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (arguments at: 1)
					with: (BlockNode withJust: NodeNil).
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/27/2000 22:29'!
transformIfTrueIfFalse: encoder
	^(self checkBlock: (arguments at: 1) as: 'True arg' from: encoder)
		and: [self checkBlock: (arguments at: 2) as: 'False arg' from: encoder]! !

!MessageNode methodsFor: 'macro transformations'!
transformOr: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (BlockNode withJust: NodeTrue)
					with: (arguments at: 1).
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'hmm 7/15/2001 22:22'!
transformToDo: encoder
	" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] 
Jmp(L1) L2: "
	| limit increment block initStmt test incStmt limitInit blockVar myRange blockRange |
	"First check for valid arguments"
	((arguments last isMemberOf: BlockNode)
			and: [arguments last numberOfArguments = 1])
		ifFalse: [^ false].
	arguments last firstArgument isVariableReference
		ifFalse: [^ false]. "As with debugger remote vars"
	arguments size = 3
		ifTrue: [increment _ arguments at: 2.
				(increment isConstantNumber and:
					[increment literalValue ~= 0]) ifFalse: [^ false]]
		ifFalse: [increment _ encoder encodeLiteral: 1].
	arguments size < 3 ifTrue:   "transform to full form"
		[selector _ SelectorNode new key: #to:by:do: code: #macro].

	"Now generate auxiliary structures"
	myRange _ encoder rawSourceRanges at: self ifAbsent: [1 to: 0].
	block _ arguments last.
	blockRange _ encoder rawSourceRanges at: block ifAbsent: [1 to: 0].
	blockVar _ block firstArgument.
	initStmt _ AssignmentNode new variable: blockVar value: receiver.
	limit _ arguments at: 1.
	limit isVariableReference | limit isConstantNumber
		ifTrue: [limitInit _ nil]
		ifFalse:  "Need to store limit in a var"
			[limit _ encoder autoBind: blockVar key , 'LimiT'.
			limit scope: -2.  "Already done parsing block"
			limitInit _ AssignmentNode new
					variable: limit
					value: (arguments at: 1)].
	test _ MessageNode new receiver: blockVar
			selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=])
			arguments: (Array with: limit)
			precedence: precedence from: encoder
			sourceRange: (myRange first to: blockRange first).
	incStmt _ AssignmentNode new
			variable: blockVar
			value: (MessageNode new
				receiver: blockVar selector: #+
				arguments: (Array with: increment)
				precedence: precedence from: encoder)
			from: encoder
			sourceRange: (myRange last to: myRange last).
	arguments _ (Array with: limit with: increment with: block)
		, (Array with: initStmt with: test with: incStmt with: limitInit).
	^ true! !

!MessageNode methodsFor: 'macro transformations'!
transformWhile: encoder
	(self checkBlock: receiver as: 'receiver' from: encoder)
		ifFalse: [^ false].
	arguments size = 0   "transform bodyless form to body form"
		ifTrue: [selector _ SelectorNode new
					key: (special = 10 ifTrue: [#whileTrue:] ifFalse: [#whileFalse:])
					code: #macro.
				arguments _ Array with: (BlockNode withJust: NodeNil).
				^ true]
		ifFalse: [^ self transformBoolean: encoder]! !


!MessageNode methodsFor: 'printing' stamp: 'RAA 6/9/2000 18:06'!
asMorphicCaseOn: parent indent: ignored
	"receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"

	| braceNode otherwise |

	braceNode _ arguments first.
	otherwise _ arguments last.
	((arguments size = 1) or: [otherwise isJustCaseError]) ifTrue: [
		self morphFromKeywords: #caseOf: arguments: {braceNode} on: parent indent: nil.
		^parent
	].
	self morphFromKeywords: #caseOf:otherwise: arguments: arguments on: parent indent: nil.
	^parent
! !

!MessageNode methodsFor: 'printing' stamp: 'RAA 2/15/2001 19:25'!
macroPrinter

	special > 0 ifTrue: [^MacroPrinters at: special].
	^nil
! !

!MessageNode methodsFor: 'printing'!
precedence

	^precedence! !

!MessageNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:36'!
printCaseOn: aStream indent: level 
	"receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"
	| braceNode otherwise extra |
	braceNode _ arguments first.
	otherwise _ arguments last.
	(arguments size = 1 or: [otherwise isJustCaseError])
		ifTrue: [otherwise _ nil].
	receiver
		printOn: aStream
		indent: level
		precedence: 3.
	aStream nextPutAll: ' caseOf: '.
	braceNode isVariableReference ifTrue: [braceNode printOn: aStream indent: level]
		ifFalse: 
			[aStream nextPutAll: '{';
				 crtab: level + 1.
			braceNode
				casesForwardDo: 
					[:keyNode :valueNode :last | 
					keyNode printOn: aStream indent: level + 1.
					aStream nextPutAll: ' -> '.
					valueNode isComplex
						ifTrue: 
							[aStream crtab: level + 2.
							extra _ 1]
						ifFalse: [extra _ 0].
					valueNode printOn: aStream indent: level + 1 + extra.
					last ifTrue: [aStream nextPut: $}]
						ifFalse: [aStream nextPut: $.;
								 crtab: level + 1]]].
	otherwise isNil
		ifFalse: 
			[aStream crtab: level + 1;
			nextPutAll: ' otherwise: '.
			otherwise isComplex
				ifTrue: 
					[aStream crtab: level + 2.
					extra _ 1]
				ifFalse: [extra _ 0].
			otherwise printOn: aStream indent: level + 1 + extra.]! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:20'!
printIfNil: aStream indent: level

	self printReceiver: receiver on: aStream indent: level.

	^self printKeywords: selector key
		arguments: (Array with: arguments first)
		on: aStream indent: level! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:20'!
printIfNilNotNil: aStream indent: level

	self printReceiver: receiver ifNilReceiver on: aStream indent: level.

	(arguments first isJust: NodeNil) ifTrue:
		[^ self printKeywords: #ifNotNil:
				arguments: { arguments second }
				on: aStream indent: level].
	(arguments second isJust: NodeNil) ifTrue:
		[^ self printKeywords: #ifNil:
				arguments: { arguments first }
				on: aStream indent: level].
	^ self printKeywords: #ifNil:ifNotNil:
			arguments: arguments
			on: aStream indent: level! !

!MessageNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:37'!
printIfOn: aStream indent: level

	receiver ifNotNil: [
		receiver printOn: aStream indent: level + 1 precedence: precedence.
	].
	(arguments last isJust: NodeNil) ifTrue:
		[^ self printKeywords: #ifTrue: arguments: (Array with: arguments first)
					on: aStream indent: level].
	(arguments last isJust: NodeFalse) ifTrue:
		[^ self printKeywords: #and: arguments: (Array with: arguments first)
					on: aStream indent: level].
	(arguments first isJust: NodeNil) ifTrue:
		[^ self printKeywords: #ifFalse: arguments: (Array with: arguments last)
					on: aStream indent: level].
	(arguments first isJust: NodeTrue) ifTrue:
		[^ self printKeywords: #or: arguments: (Array with: arguments last)
					on: aStream indent: level].
	self printKeywords: #ifTrue:ifFalse: arguments: arguments
					on: aStream indent: level! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/11/2000 15:08'!
printKeywords: key arguments: args on: aStream indent: level

	^ self printKeywords: key arguments: args on: aStream indent: level prefix: false
! !

!MessageNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:40'!
printKeywords: key arguments: args on: aStream indent: level prefix: isPrefix
	| keywords indent arg kwd doCrTab |
	args size = 0 ifTrue: [aStream space; nextPutAll: key. ^ self].
	keywords _ key keywords.
	doCrTab _ args size > 2 or:
		[{receiver} , args
			inject: false
			into: [:was :thisArg |
				was or: [(thisArg isKindOf: BlockNode)
					or: [(thisArg isKindOf: MessageNode) and: [thisArg precedence >= 3]]]]].
	1 to: (args size min: keywords size) do:
		[:i | arg _ args at: i.  kwd _ keywords at: i.
		doCrTab
			ifTrue: [aStream crtab: level+1. indent _ 1] "newline after big args"
			ifFalse: [aStream space. indent _ 0].
		aStream nextPutAll: kwd; space.
		arg printOn: aStream indent: level + 1 + indent
			 	precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence]).
		]! !

!MessageNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:41'!
printOn: aStream indent: level

	| leadingKeyword |

"may not need this check anymore - may be fixed by the #receiver: change"
	special ifNil: [^aStream nextPutAll: '** MessageNode with nil special **'].


	(special > 0)
		ifTrue: [self perform: self macroPrinter with: aStream with: level]
		ifFalse: [selector key first = $:
				ifTrue: [leadingKeyword _ selector key keywords first.
						aStream nextPutAll: leadingKeyword; space.
						self printReceiver: receiver on: aStream indent: level.
						self printKeywords: (selector key allButFirst: leadingKeyword size + 1) arguments: arguments
							on: aStream indent: level]
				ifFalse: [self printReceiver: receiver on: aStream indent: level.
						self printKeywords: selector key arguments: arguments
						on: aStream indent: level]]! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/30/2000 23:17'!
printOn: strm indent: level precedence: outerPrecedence

	| parenthesize |
	parenthesize _ precedence > outerPrecedence
		or: [outerPrecedence = 3 and: [precedence = 3 "both keywords"]].
	parenthesize
		ifTrue: [strm nextPutAll: '('.
				self printOn: strm indent: level.
				strm nextPutAll: ')']
		ifFalse: [self printOn: strm indent: level]! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/7/2000 08:28'!
printParenReceiver: rcvr on: aStream indent: level
					
	(rcvr isKindOf: BlockNode) ifTrue:
		[^ rcvr printOn: aStream indent: level].
	aStream nextPutAll: '('.
	rcvr printOn: aStream indent: level.
	aStream nextPutAll: ')'
! !

!MessageNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:42'!
printReceiver: rcvr on: aStream indent: level
					
	rcvr ifNil: [^ self].

	"Force parens around keyword receiver of kwd message"
	 rcvr printOn: aStream indent: level precedence: precedence.
! !

!MessageNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:42'!
printToDoOn: aStream indent: level

	| limitNode |
	
	self printReceiver: receiver on: aStream indent: level.

	(arguments last == nil or: [(arguments last isMemberOf: AssignmentNode) not])
		ifTrue: [limitNode _ arguments first]
		ifFalse: [limitNode _ arguments last value].
	(selector key = #to:by:do:
			and: [(arguments at: 2) isConstantNumber
				and: [(arguments at: 2) key = 1]])
		ifTrue: [self printKeywords: #to:do:
					arguments: (Array with: limitNode with: (arguments at: 3))
					on: aStream indent: level prefix: true]
		ifFalse: [self printKeywords: selector key
					arguments: (Array with: limitNode) , arguments allButFirst
					on: aStream indent: level prefix: true]! !

!MessageNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:42'!
printWhileOn: aStream indent: level

	self printReceiver: receiver on: aStream indent: level.
			(arguments isEmpty not and: [ arguments first isJust: NodeNil]) ifTrue:
					[selector _ SelectorNode new
								key: (selector key == #whileTrue:
									ifTrue: [#whileTrue] ifFalse: [#whileFalse])
								code: #macro.
						arguments _ Array new].
				self printKeywords: selector key arguments: arguments
					on: aStream indent: level.! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/2/2000 00:16'!
test

	3 > 4 ifTrue: [4+5 between: 6 and: 7]
			ifFalse: [4 between: 6+5 and: 7-2]! !


!MessageNode methodsFor: 'testing'!
canCascade

	^(receiver == NodeSuper or: [special > 0]) not! !

!MessageNode methodsFor: 'testing'!
isComplex
	
	^(special between: 1 and: 10) or: [arguments size > 2 or: [receiver isComplex]]! !

!MessageNode methodsFor: 'testing' stamp: 'md 7/27/2006 19:09'!
isMessage
	^true! !

!MessageNode methodsFor: 'testing'!
isMessage: selSymbol receiver: rcvrPred arguments: argsPred
	"Answer whether selector is selSymbol, and the predicates rcvrPred and argsPred
	 evaluate to true with respect to receiver and the list of arguments.  If selSymbol or
	 either predicate is nil, it means 'don't care'.  Note that argsPred takes numArgs
	 arguments.  All block arguments are ParseNodes."

	^(selSymbol isNil or: [selSymbol==selector key]) and:
		[(rcvrPred isNil or: [rcvrPred value: receiver]) and:
			[(argsPred isNil or: [argsPred valueWithArguments: arguments])]]! !

!MessageNode methodsFor: 'testing'!
isReturningIf

	^(special between: 3 and: 4)
		and: [arguments first returns and: [arguments last returns]]! !

!MessageNode methodsFor: 'testing'!
toDoIncrement: variable
	(receiver = variable and: [selector key = #+]) 
		ifFalse: [^ nil].
	arguments first isConstantNumber
		ifTrue: [^ arguments first]
		ifFalse: [^ nil]! !

!MessageNode methodsFor: 'testing'!
toDoLimit: variable
	(receiver = variable and: [selector key = #<= or: [selector key = #>=]]) 
		ifTrue: [^ arguments first]
		ifFalse: [^ nil]! !


!MessageNode methodsFor: 'tiles' stamp: 'RAA 2/14/2001 22:26'!
morphFromKeywords: key arguments: args on: parent indent: ignored

	^parent
		messageNode: self 
		receiver: receiver 
		selector: selector 
		keywords: key 
		arguments: args
! !


!MessageNode methodsFor: '*eToys-tiles' stamp: 'RAA 2/15/2001 19:34'!
asMorphicSyntaxIn: parent

	^parent 
		vanillaMessageNode: self 
		receiver: receiver 
		selector: selector 
		arguments: arguments
! !


!MessageNode methodsFor: 'private' stamp: 'hg 10/2/2001 21:08'!
checkBlock: node as: nodeName from: encoder

	node canBeSpecialArgument ifTrue: [^node isMemberOf: BlockNode].
	((node isKindOf: BlockNode) and: [node numberOfArguments > 0])
		ifTrue:	[^encoder notify: '<- ', nodeName , ' of ' ,
					(MacroSelectors at: special) , ' must be a 0-argument block']
		ifFalse: [^encoder notify: '<- ', nodeName , ' of ' ,
					(MacroSelectors at: special) , ' must be a block or variable']! !

!MessageNode methodsFor: 'private' stamp: 'acg 1/28/2000 00:57'!
ifNilReceiver

	^receiver! !

!MessageNode methodsFor: 'private' stamp: 'tk 8/2/1999 18:40'!
pvtCheckForPvtSelector: encoder
	"If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder."

	selector isPvtSelector ifTrue:
		[receiver isSelfPseudoVariable ifFalse:
			[encoder notify: 'Private messages may only be sent to self']].! !

!MessageNode methodsFor: 'private'!
receiver: rcvr arguments: args precedence: p

	receiver _ rcvr.
	arguments _ args.
	sizes _ Array new: arguments size.
	precedence _ p! !

!MessageNode methodsFor: 'private'!
transformCase: encoder

	| caseNode |
	caseNode _ arguments first.
	(caseNode isKindOf: BraceNode)
		ifTrue:
			[^(caseNode blockAssociationCheck: encoder) and:
			 	[arguments size = 1 or:
					[self checkBlock: arguments last as: 'otherwise arg' from: encoder]]].
	(caseNode canBeSpecialArgument and: [(caseNode isMemberOf: BlockNode) not])
		ifTrue:
			[^false]. "caseOf: variable"
	^encoder notify: 'caseOf: argument must be a brace construct or a variable'! !

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

MessageNode class
	instanceVariableNames: ''!

!MessageNode class methodsFor: 'class initialization' stamp: 'acg 1/28/2000 21:58'!
initialize		"MessageNode initialize"
	MacroSelectors _ 
		#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:
			and: or:
			whileFalse: whileTrue: whileFalse whileTrue
			to:do: to:by:do:
			caseOf: caseOf:otherwise:
			ifNil: ifNotNil:  ifNil:ifNotNil: ifNotNil:ifNil:).
	MacroTransformers _ 
		#(transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue:
			transformAnd: transformOr:
			transformWhile: transformWhile: transformWhile: transformWhile:
			transformToDo: transformToDo:
			transformCase: transformCase:
			transformIfNil: transformIfNil:  transformIfNilIfNotNil: transformIfNotNilIfNil:).
	MacroEmitters _ 
		#(emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value:
			emitIf:on:value: emitIf:on:value:
			emitWhile:on:value: emitWhile:on:value: emitWhile:on:value: emitWhile:on:value:
			emitToDo:on:value: emitToDo:on:value:
			emitCase:on:value: emitCase:on:value:
			emitIfNil:on:value: emitIfNil:on:value: emitIf:on:value: emitIf:on:value:).
	MacroSizers _ 
		#(sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value:
			sizeIf:value: sizeIf:value:
			sizeWhile:value: sizeWhile:value: sizeWhile:value: sizeWhile:value:
			sizeToDo:value: sizeToDo:value:
			sizeCase:value: sizeCase:value:
			sizeIfNil:value: sizeIfNil:value: sizeIf:value: sizeIf:value: ).
	MacroPrinters _ 
		#(printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent:
			printIfOn:indent: printIfOn:indent:
			printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent:
			printToDoOn:indent: printToDoOn:indent:
			printCaseOn:indent: printCaseOn:indent:
			printIfNil:indent: printIfNil:indent: printIfNilNotNil:indent: printIfNilNotNil:indent:)! !
Error subclass: #MessageNotUnderstood
	instanceVariableNames: 'message receiver'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!MessageNotUnderstood commentStamp: '<historical>' prior: 0!
This exception is provided to support Object>>doesNotUnderstand:.!


!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:03'!
message: aMessage

	message := aMessage! !

!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'ab 8/22/2003 11:56'!
messageText
	"Return an exception's message text."

	^messageText == nil
		ifTrue:
			[message == nil
				ifTrue: [super messageText]
				ifFalse: [message lookupClass printString, '>>', message selector asString]]
		ifFalse: [messageText]! !

!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'ajh 10/9/2001 16:38'!
receiver: obj

	receiver _ obj! !


!MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 18:30'!
isResumable
	"Determine whether an exception is resumable."

	^true! !

!MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 18:27'!
message
	"Answer the selector and arguments of the message that failed."

	^message! !

!MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'ajh 10/9/2001 16:39'!
receiver
	"Answer the receiver that did not understand the message"

	^ receiver! !
MessageNode subclass: #MessagePartNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Tile Scriptors'!
Object subclass: #MessageSend
	instanceVariableNames: 'receiver selector arguments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!MessageSend commentStamp: 'DF 5/25/2006 19:54' prior: 0!
Instances of MessageSend encapsulate message sends to objects. Arguments can be either predefined or supplied when the message send is performed. 

Use #value to perform a message send with its predefined arguments and #valueWithArguments: if additonal arguments have to supplied.

Structure:
 receiver		Object -- object receiving the message send
 selector		Symbol -- message selector
 arguments		Array -- bound arguments!


!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
arguments
	^ arguments! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:40'!
arguments: anArray
	arguments _ anArray! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
receiver
	^ receiver! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
receiver: anObject
	receiver _ anObject! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
selector
	^ selector! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
selector: aSymbol
	selector _ aSymbol! !


!MessageSend methodsFor: 'comparing' stamp: 'sma 2/29/2000 20:43'!
= anObject
	^ anObject species == self species 
		and: [receiver == anObject receiver
		and: [selector == anObject selector
		and: [arguments = anObject arguments]]]! !

!MessageSend methodsFor: 'comparing' stamp: 'sma 3/11/2000 10:35'!
hash
	^ receiver hash bitXor: selector hash! !


!MessageSend methodsFor: 'converting' stamp: 'nk 12/20/2002 17:54'!
asMinimalRepresentation
	^self! !


!MessageSend methodsFor: 'evaluating' stamp: 'sw 2/20/2002 22:17'!
value
	"Send the message and answer the return value"

	arguments ifNil: [^ receiver perform: selector].

	^ receiver 
		perform: selector 
		withArguments: (self collectArguments: arguments)! !

!MessageSend methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 16:51'!
valueWithArguments: anArray

	^ receiver 
		perform: selector 
		withArguments: (self collectArguments: anArray)! !

!MessageSend methodsFor: 'evaluating' stamp: 'nk 3/11/2001 11:42'!
valueWithEnoughArguments: anArray
	"call the selector with enough arguments from arguments and anArray"
	| args |
	args _ Array new: selector numArgs.
	args replaceFrom: 1
		to: (arguments size min: args size)
		with: arguments
		startingAt: 1.
	args size > arguments size ifTrue: [
		args replaceFrom: arguments size + 1
			to: (arguments size + anArray size min: args size)
			with: anArray
			startingAt: 1.
	].
	^ receiver perform: selector withArguments: args! !


!MessageSend methodsFor: 'printing' stamp: 'SqR 7/14/2001 11:36'!
printOn: aStream

        aStream
                nextPutAll: self class name;
                nextPut: $(.
        selector printOn: aStream.
        aStream nextPutAll: ' -> '.
        receiver printOn: aStream.
        aStream nextPut: $)! !


!MessageSend methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'!
isMessageSend
	^true
! !

!MessageSend methodsFor: 'testing' stamp: 'nk 7/21/2003 15:16'!
isValid
	^true! !


!MessageSend methodsFor: '*eToys-tiles' stamp: 'tk 11/15/2000 15:19'!
asTilesIn: playerClass
	| code keywords num tree syn block phrase |
	"Construct SyntaxMorph tiles for me."

	"This is really cheating!!  Make a true parse tree later. -tk"
	code _ String streamContents: [:strm | 
		strm nextPutAll: 'doIt'; cr; tab.
		strm nextPutAll: (self stringFor: receiver).
		keywords _ selector keywords.
		strm space; nextPutAll: keywords first.
		(num _ selector numArgs) > 0 ifTrue: [strm space. 
					strm nextPutAll: (self stringFor: arguments first)].
		2 to: num do: [:kk |
			strm space; nextPutAll: (keywords at: kk).
			strm space; nextPutAll: (self stringFor: (arguments at: kk))]].
	"decompile to tiles"
	tree _ Compiler new 
		parse: code 
		in: playerClass
		notifying: nil.
	syn _ tree asMorphicSyntaxUsing: SyntaxMorph.
	block _ syn submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == BlockNode] ifFalse: [false]].
	phrase _ block submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == MessageNode] ifFalse: [false]].
	^ phrase

! !

!MessageSend methodsFor: '*eToys-tiles' stamp: 'tk 9/28/2001 13:41'!
asTilesIn: playerClass globalNames: makeSelfGlobal
	| code keywords num tree syn block phrase |
	"Construct SyntaxMorph tiles for me.  If makeSelfGlobal is true, name the receiver and use that name, else use 'self'.  (Note that this smashes 'self' into the receiver, regardless of what it was.)"

	"This is really cheating!!  Make a true parse tree later. -tk"
	code _ String streamContents: [:strm | 
		strm nextPutAll: 'doIt'; cr; tab.
		strm nextPutAll: 
			(makeSelfGlobal ifTrue: [self stringFor: receiver] ifFalse: ['self']).
		keywords _ selector keywords.
		strm space; nextPutAll: keywords first.
		(num _ selector numArgs) > 0 ifTrue: [strm space. 
					strm nextPutAll: (self stringFor: arguments first)].
		2 to: num do: [:kk |
			strm space; nextPutAll: (keywords at: kk).
			strm space; nextPutAll: (self stringFor: (arguments at: kk))]].
	"decompile to tiles"
	tree _ Compiler new 
		parse: code 
		in: playerClass
		notifying: nil.
	syn _ tree asMorphicSyntaxUsing: SyntaxMorph.
	block _ syn submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == BlockNode] ifFalse: [false]].
	phrase _ block submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == MessageNode] ifFalse: [false]].
	^ phrase

! !

!MessageSend methodsFor: '*eToys-tiles' stamp: 'sw 6/20/2001 14:17'!
stringFor: anObject
	"Return a string suitable for compiling.  Literal or reference from global ref dictionary.  self is always named via the ref dictionary."

	| generic aName |
	anObject isLiteral ifTrue: [^ anObject printString].
	anObject class == Color ifTrue: [^ anObject printString].
	anObject class superclass == Boolean ifTrue: [^ anObject printString].
	anObject class == BlockContext ifTrue: [^ '[''do nothing'']'].	"default block"
		"Real blocks need to construct tiles in a different way"
	anObject class isMeta ifTrue: ["a class" ^ anObject name].
	generic _ anObject knownName.	"may be nil or 'Ellipse' "
	aName _ anObject uniqueNameForReference.
	generic ifNil:
		[(anObject respondsTo: #renameTo:) 
			ifTrue: [anObject renameTo: aName]
			ifFalse: [aName _ anObject storeString]].	"for Fraction, LargeInt, etc"
	^ aName
! !


!MessageSend methodsFor: 'private' stamp: 'reThink 2/18/2001 17:33'!
collectArguments: anArgArray
	"Private"

    | staticArgs |
    staticArgs := self arguments.
    ^(anArgArray size = staticArgs size)
        ifTrue: [anArgArray]
        ifFalse:
            [(staticArgs isEmpty
                ifTrue: [ staticArgs := Array new: selector numArgs]
                ifFalse: [staticArgs copy] )
                    replaceFrom: 1
                    to: (anArgArray size min: staticArgs size)
                    with: anArgArray
                    startingAt: 1]! !


!MessageSend methodsFor: '*omnibrowser-evaluating' stamp: 'cwp 6/24/2006 18:19'!
valueWithPossibleArgs: anArray
	^ receiver 
		perform: selector 
		withArguments: (self collectArguments: anArray)! !

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

MessageSend class
	instanceVariableNames: ''!

!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'!
receiver: anObject selector: aSymbol
	^ self receiver: anObject selector: aSymbol arguments: #()! !

!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'!
receiver: anObject selector: aSymbol argument: aParameter
	^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)! !

!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:39'!
receiver: anObject selector: aSymbol arguments: anArray
	^ self new
		receiver: anObject;
		selector: aSymbol;
		arguments: anArray! !
Browser subclass: #MessageSet
	instanceVariableNames: 'messageList autoSelectString growable'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!MessageSet commentStamp: '<historical>' prior: 0!
I represent a query path of the retrieval result of making a query about methods in the system. The result is a set of methods, denoted by a message selector and the class in which the method was found. As a StringHolder, the string I represent is the source code of the currently selected method. I am typically viewed in a Message Set Browser consisting of a MessageListView and a BrowserCodeView.!


!MessageSet methodsFor: 'class list'!
metaClassIndicated
	"Answer the boolean flag that indicates whether
	this is a class method."

	^ self selectedClassOrMetaClass isMeta! !

!MessageSet methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'!
selectedClass 
	"Return the base class for the current selection.  1/17/96 sw fixed up so that it doesn't fall into a debugger in a msg browser that has no message selected"

	| aClass |
	^ (aClass := self selectedClassOrMetaClass) == nil
		ifTrue:
			[nil]
		ifFalse:
			[aClass theNonMetaClass]! !

!MessageSet methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'!
selectedClassName
	"Answer the name of class of the currently selected message. Answer nil if no selection 
	exists."

	| cls |
	(cls := self selectedClass) ifNil: [^ nil].
	^ cls name! !

!MessageSet methodsFor: 'class list'!
selectedClassOrMetaClass
	"Answer the currently selected class (or metaclass)."
	messageListIndex = 0 ifTrue: [^nil].
	self setClassAndSelectorIn: [:c :s | ^c]! !

!MessageSet methodsFor: 'class list'!
selectedMessageCategoryName 
	"Answer the name of the selected message category or nil."
	messageListIndex = 0 ifTrue: [^ nil].
	^ self selectedClassOrMetaClass organization categoryOfElement: self selectedMessageName! !


!MessageSet methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'!
contents
	"Answer the contents of the receiver"

	^ contents == nil
		ifTrue: [currentCompiledMethod := nil. '']
		ifFalse: [messageListIndex = 0 
			ifTrue: [currentCompiledMethod := nil. contents]
			ifFalse: [self showingByteCodes
				ifTrue: [self selectedBytecodes]
				ifFalse: [self selectedMessage]]]! !

!MessageSet methodsFor: 'contents' stamp: 'md 2/20/2006 15:04'!
selectedMessage
	"Answer the source method for the currently selected message."

	| source |
	self setClassAndSelectorIn: [:class :selector | 
		class ifNil: [^ 'Class vanished'].
		selector first isUppercase ifTrue:
			[selector == #Comment ifTrue:
				[currentCompiledMethod := class organization commentRemoteStr.
				^ class comment].
			selector == #Definition ifTrue:
				[^ class definitionST80].
			selector == #Hierarchy ifTrue: [^ class printHierarchy]].
		source := class sourceMethodAt: selector ifAbsent:
			[currentCompiledMethod := nil.
			^ 'Missing'].

		self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].

		currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil].
		self showingDocumentation ifTrue: [^ self commentContents].

	source := self sourceStringPrettifiedAndDiffed.
	^ source asText makeSelectorBoldIn: class]! !

!MessageSet methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'!
setContentsToForceRefetch
	"Set the receiver's contents such that on the next update the contents will be formulated afresh.  This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty.  By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more"

	contents := ''! !


!MessageSet methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:27'!
dragPassengerFor: item inMorph: dragSource 
	| transferType |
	transferType := self dragTransferTypeForMorph: dragSource.
	transferType == #messageList
		ifTrue: [^self selectedClassOrMetaClass->(item contents findTokens: ' ') second asSymbol].
	transferType == #classList
		ifTrue: [^self selectedClass].
	^nil! !


!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 16:47'!
augmentMessageList
	"Allow the user to add to the list of messages."

	self notYetImplemented
! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'!
filterFrom: aBlock
	"Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments."

	| newList |
	newList := messageList select:
		[:anElement |
			self class parse: anElement toClassAndSelector: [ :cls :sel | 
				(self class isPseudoSelector: sel) not and: [  aBlock value: cls value: sel ]]].
	self setFilteredList: newList! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'!
filterMessageList
	"Allow the user to refine the list of messages."

	| aMenu evt |
	Smalltalk isMorphic ifFalse: [^ self inform: 'sorry, morphic only at this time.'].
	messageList size <= 1 ifTrue: [^ self inform: 'this is not a propitious filtering situation'].

	"would like to get the evt coming in but thwarted by the setInvokingView: circumlocution"
	evt := self currentWorld activeHand lastEvent.
	aMenu := MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Filter by only showing...'.
	aMenu addStayUpItem.

	aMenu addList: #(
		('unsent messages'						filterToUnsentMessages		'filter to show only messages that have no senders')
		-
		('messages that send...'					filterToSendersOf			'filter to show only messages that send a selector I specify')
		('messages that do not send...'			filterToNotSendersOf		'filter to show only messages that do not send a selector I specify')
		-
		('messages whose selector is...'			filterToImplementorsOf		'filter to show only messages with a given selector I specify')
		('messages whose selector is NOT...'		filterToNotImplementorsOf	'filter to show only messages whose selector is NOT a seletor I specify')
		-
		('messages in current change set'		filterToCurrentChangeSet	'filter to show only messages that are in the current change set')
		('messages not in current change set'	filterToNotCurrentChangeSet	'filter to show only messages that are not in the current change set')
		-
		('messages in any change set'			filterToAnyChangeSet		'filter to show only messages that occur in at least one change set')
		('messages not in any change set'		filterToNotAnyChangeSet		'filter to show only messages that do not occur in any change set in the system')
		-
		('messages authored by me'				filterToCurrentAuthor		'filter to show only messages whose authoring stamp has my initials')
		('messages not authored by me'			filterToNotCurrentAuthor	'filter to show only messages whose authoring stamp does not have my initials')
		-
		('messages logged in .changes file'		filterToMessagesInChangesFile	'filter to show only messages whose latest source code is logged in the .changes file')
		('messages only in .sources file'			filterToMessagesInSourcesFile	'filter to show only messages whose latest source code is logged in the .sources file')
		-
		('messages with prior versions'			filterToMessagesWithPriorVersions	'filter to show only messages that have at least one prior version')
		('messages without prior versions'		filterToMessagesWithoutPriorVersions	'filter to show only messages that have no prior versions')
		-
		('uncommented messages' filterToUncommentedMethods 'filter to show only messages that do not have comments at the beginning')
		('commented messages' filterToCommentedMethods 'fileter to show only messages that have comments at the beginning')
		-
		('messages in hardened classes'			filterToMessagesWithHardenedClasses	'filter to show only messages of established classes (as opposed to Uniclasses such as Player23)')
		-
		('messages that...'						filterToMessagesThat			'let me type in a block taking a class and a selector, which will specify yea or nay concerning which elements should remain in the list')
			).

	aMenu popUpEvent: evt hand lastEvent in: evt hand world.! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 12:55'!
filterToAnyChangeSet
	"Filter down only to messages present in ANY change set"

	self filterFrom:
		[:aClass :aSelector |
			ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aSelector]
! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 8/10/2001 14:45'!
filterToCommentedMethods
	"Filter the receiver's list down to only those items which have comments"

	self filterFrom:
		[:aClass :aSelector |
			(aClass selectors includes: aSelector) and:
						[(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil not]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'!
filterToCurrentAuthor
	"Filter down only to messages with my initials as most recent author"

	| myInitials aMethod aTimeStamp |
	(myInitials := Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:			
				[aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil].
				aMethod notNil and:
					[(aTimeStamp := Utilities timeStampForMethod: aMethod) notNil and:
						[aTimeStamp beginsWith: myInitials]]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 5/23/2003 14:38'!
filterToCurrentChangeSet
	"Filter the receiver's list down to only those items in the current change set"

	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:
				[(ChangeSet current atSelector: aSelector class: aClass) ~~ #none]]! !

!MessageSet methodsFor: 'filtering' stamp: 'rbb 3/1/2005 11:00'!
filterToImplementorsOf
	"Filter the receiver's list down to only those items with a given selector"

	| aFragment inputWithBlanksTrimmed |

	aFragment := UIManager default request: 'type selector:' initialAnswer: ''.
	aFragment  isEmptyOrNil ifTrue: [^ self].
	inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
	Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
		[:aSymbol | 
			self filterFrom:
				[:aClass :aSelector |
					aSelector == aSymbol]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'!
filterToMessagesInChangesFile
	"Filter down only to messages whose source code risides in the Changes file.  This allows one to ignore long-standing methods that live in the .sources file."

	| cm |
	self filterFrom:
		[:aClass :aSelector |
			aClass notNil and: [aSelector notNil and:
				[(self class isPseudoSelector: aSelector) not and:
					[(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and:
					[cm fileIndex ~~ 1]]]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'!
filterToMessagesInSourcesFile
	"Filter down only to messages whose source code resides in the .sources file."

	| cm |
	self filterFrom: [:aClass :aSelector |
		(aClass notNil and: [aSelector notNil]) and:
			[(self class isPseudoSelector: aSelector) not and:
				[(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and:
					[cm fileIndex == 1]]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'rbb 3/1/2005 11:00'!
filterToMessagesThat
	"Allow the user to type in a block which will be"

	| reply |
	reply := UIManager default
		multiLineRequest: 'Type your block here'
		centerAt: Sensor cursorPoint
		initialAnswer: '[:aClass :aSelector |
	
	]'
		answerHeight: 200.
	reply isEmptyOrNil ifTrue: [^ self].
	self filterFrom: (Compiler evaluate: reply)
! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 2/13/2001 12:02'!
filterToMessagesWithHardenedClasses
	"Filter the receiver's list down to only those items representing methods of hardened classes, as opposed to uniclasses"

	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:
				[aClass isUniClass not]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 8/12/2001 22:25'!
filterToMessagesWithPriorVersions
	"Filter down only to messages which have at least one prior version"

	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:
				[(self class isPseudoSelector: aSelector) not and:
					[(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 15:12'!
filterToMessagesWithoutPriorVersions
	"Filter down only to messages which have no prior version stored"

	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:
				[(self class isPseudoSelector: aSelector) not and:
					[(VersionsBrowser versionCountForSelector: aSelector class: aClass) <= 1]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 13:07'!
filterToNotAnyChangeSet
	"Filter down only to messages present in NO change set"

	self filterFrom:
		[:aClass :aSelector |
			(ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aSelector) not]
! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'!
filterToNotCurrentAuthor
	"Filter down only to messages not stamped with my initials"

	| myInitials aMethod aTimeStamp |
	(myInitials := Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:			
				[aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil].
				aMethod notNil and:
					[(aTimeStamp := Utilities timeStampForMethod: aMethod) isNil or:
						[(aTimeStamp beginsWith: myInitials) not]]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 5/23/2003 14:38'!
filterToNotCurrentChangeSet
	"Filter the receiver's list down to only those items not in the current change set"

	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:
				[(ChangeSet current atSelector: aSelector class: aClass) == #none]]! !

!MessageSet methodsFor: 'filtering' stamp: 'rbb 3/1/2005 11:00'!
filterToNotImplementorsOf
	"Filter the receiver's list down to only those items whose selector is NOT one solicited from the user."

	| aFragment inputWithBlanksTrimmed |

	aFragment := UIManager default request: 'type selector: ' initialAnswer: ''.
	aFragment  isEmptyOrNil ifTrue: [^ self].
	inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
	Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
		[:aSymbol | 
			self filterFrom:
				[:aClass :aSelector |
					aSelector ~~ aSymbol]]! !

!MessageSet methodsFor: 'filtering' stamp: 'rbb 3/1/2005 11:00'!
filterToNotSendersOf
	"Filter the receiver's list down to only those items which do not send a given selector"

	| aFragment inputWithBlanksTrimmed aMethod |

	aFragment := UIManager default request: 'type selector:' initialAnswer: ''.
	aFragment  isEmptyOrNil ifTrue: [^ self].
	inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
	Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
		[:aSymbol | 
			self filterFrom:
				[:aClass :aSelector |
					(aMethod := aClass compiledMethodAt: aSelector) isNil or:
						[(aMethod hasLiteralThorough: aSymbol) not]]]! !

!MessageSet methodsFor: 'filtering' stamp: 'rbb 3/1/2005 11:01'!
filterToSendersOf
	"Filter the receiver's list down to only those items which send a given selector"

	| aFragment inputWithBlanksTrimmed aMethod |

	aFragment := UIManager default request: 'type selector:' initialAnswer: ''.
	aFragment  isEmptyOrNil ifTrue: [^ self].
	inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
	Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
		[:aSymbol | 
			self filterFrom:
				[:aClass :aSelector |
					(aMethod := aClass compiledMethodAt: aSelector) notNil and:
						[aMethod hasLiteralThorough: aSymbol]]]

! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 8/10/2001 14:43'!
filterToUncommentedMethods
	"Filter the receiver's list down to only those items which lack comments"

	self filterFrom:
		[:aClass :aSelector |
			(aClass selectors includes: aSelector) and:
						[(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sd 4/29/2003 12:24'!
filterToUnsentMessages
	"Filter the receiver's list down to only those items which have no  
	senders"
	self
		filterFrom: [:aClass :aSelector | (self systemNavigation allCallsOn: aSelector) isEmpty]! !


!MessageSet methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'!
canShowMultipleMessageCategories
	"Answer whether the receiver is capable of showing multiple message categories"

	^ false! !


!MessageSet methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:27'!
deleteFromMessageList: aMessage
	"Delete the given message from the receiver's message list"

	messageList := messageList copyWithout: aMessage! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 2/24/1999 18:31'!
methodCategoryChanged
	self changed: #annotation! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 12/1/2000 11:54'!
reformulateList
	"The receiver's messageList has been changed; rebuild it"

	super reformulateList.
	self initializeMessageList: messageList.
	self changed: #messageList.
	self changed: #messageListIndex.
	self contentsChanged
! !

!MessageSet methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:27'!
removeMessage
	"Remove the selected message from the system. 1/15/96 sw"
	| messageName confirmation |
	messageListIndex = 0
		ifTrue: [^ self].
	self okToChange
		ifFalse: [^ self].
	messageName := self selectedMessageName.
	confirmation := self systemNavigation  confirmRemovalOf: messageName on: self selectedClassOrMetaClass.
	confirmation == 3
		ifTrue: [^ self].
	self selectedClassOrMetaClass removeSelector: messageName.
	self deleteFromMessageList: self selection.
	self reformulateList.
	confirmation == 2
		ifTrue: [self systemNavigation browseAllCallsOn: messageName]! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 1/12/2001 00:19'!
removeMessageFromBrowser
	"Remove the selected message from the browser."

	messageListIndex = 0 ifTrue: [^ self].
	self deleteFromMessageList: self selection.
	self reformulateList.
	self adjustWindowTitleAfterFiltering
! !


!MessageSet methodsFor: 'message list' stamp: 'sw 7/28/2002 22:39'!
addExtraShiftedItemsTo: aMenu
	"The shifted selector-list menu is being built.  Add items specific to MessageSet"

	self growable ifTrue:
		[aMenu addList: #(
			-
			('remove from this browser'		removeMessageFromBrowser)
			('filter message list...'			filterMessageList)
			('add to message list...'			augmentMessageList))].
	aMenu add: 'sort by date' action: #sortByDate! !

!MessageSet methodsFor: 'message list' stamp: 'tk 5/1/2001 18:14'!
addItem: classAndMethod
	"Append a classAndMethod string to the list.  Select the new item."

	"Do some checks on the input?"
	self okToChange ifFalse: [^ self].
	messageList add: classAndMethod.
	self changed: #messageList.
	self messageListIndex: messageList size.! !

!MessageSet methodsFor: 'message list' stamp: 'sw 1/28/2001 20:56'!
growable
	"Answer whether the receiver is capable of growing/shrinking dynamically"

	^ growable ~~ false! !

!MessageSet methodsFor: 'message list' stamp: 'sd 11/20/2005 21:27'!
growable: aBoolean
	"Give or take away the growable trait; when a message set is growable, methods submitted within it will be added to its message list"

	growable := aBoolean! !

!MessageSet methodsFor: 'message list'!
messageList
	"Answer the current list of messages."

	^messageList! !

!MessageSet methodsFor: 'message list' stamp: 'sd 11/20/2005 21:27'!
messageListIndex: anInteger 
	"Set the index of the selected item to be anInteger."

	messageListIndex := anInteger.
	contents := 
		messageListIndex ~= 0
			ifTrue: [self selectedMessage]
			ifFalse: [''].
	self changed: #messageListIndex.	 "update my selection"
	self editSelection: #editMessage.
	self contentsChanged.
	(messageListIndex ~= 0 and: [autoSelectString notNil])
		ifTrue: [self changed: #autoSelect].
	self decorateButtons
! !

!MessageSet methodsFor: 'message list' stamp: 'sbw 12/30/1999 17:19'!
optionalButtonHeight

	^ 15! !

!MessageSet methodsFor: 'message list' stamp: 'sma 3/3/2000 11:17'!
selectedMessageName
	"Answer the name of the currently selected message."
	"wod 6/16/1998: answer nil if none are selected."

	messageListIndex = 0 ifTrue: [^ nil].
	^ self setClassAndSelectorIn: [:class :selector | ^ selector]! !

!MessageSet methodsFor: 'message list' stamp: 'sd 11/20/2005 21:27'!
sortByDate
	"Sort the message-list by date of time-stamp"

	| assocs aCompiledMethod aDate inOrder |
	assocs := messageList collect:
		[:aRef |
			aDate := aRef methodSymbol == #Comment
				ifTrue:
					[aRef actualClass organization dateCommentLastSubmitted]
				ifFalse:
					[aCompiledMethod := aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: [nil].
					aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]].
			aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])].  "The dawn of Squeak history"
	inOrder := assocs asSortedCollection:
		[:a :b | a value < b value].

	messageList := inOrder asArray collect: [:assoc | assoc key].
	self changed: #messageList! !


!MessageSet methodsFor: 'metaclass' stamp: 'nk 4/29/2004 12:20'!
classCommentIndicated
	"Answer true iff we're viewing the class comment."

	^ editSelection == #editComment or: [ self selectedMessageName == #Comment ]! !


!MessageSet methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:53'!
buildWith: builder
	| windowSpec max listSpec panelSpec textSpec |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'System Browser'.
	windowSpec children: OrderedCollection new.

	self wantsOptionalButtons ifTrue:[max := 0.3] ifFalse:[max := 0.2].
	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #messageList; 
		getIndex: #messageListIndex; 
		setIndex: #messageListIndex:; 
		menu: #messageListMenu:shifted:; 
		keyPress: #messageListKey:from:;
		frame: (0@0 corner: 1@0.2).
	windowSpec children add: listSpec.

	self wantsOptionalButtons ifTrue:[
		panelSpec := self buildOptionalButtonsWith: builder.
		panelSpec frame: (0@0.2 corner: 1@max).
		windowSpec children add: panelSpec.
	].

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		getText: #contents; 
		setText: #contents:notifying:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0@max corner: 1@1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !


!MessageSet methodsFor: '*services-base' stamp: 'rr 8/25/2005 15:42'!
browseReference: ref
	self okToChange ifTrue: [
	self initializeMessageList: (OrderedCollection with: ref).
	self changed: #messageList.
	self messageListIndex: 1.
	] ! !

!MessageSet methodsFor: '*services-base' stamp: 'rr 8/27/2005 13:01'!
selectReference: ref
	self okToChange ifTrue: [self messageListIndex: (self messageList indexOf: ref)]! !


!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
adjustWindowTitleAfterFiltering
	"Set the title of the receiver's window, if any, to reflect the just-completed filtering"

	| aWindow existingLabel newLabel |

	(aWindow := self containingWindow) ifNil: [^ self].
	(existingLabel := aWindow label) isEmptyOrNil ifTrue: [^ self].
	(((existingLabel size < 3) or: [existingLabel last ~~ $]]) or: [(existingLabel at: (existingLabel size - 1)) isDigit not]) ifTrue: [^ self].
	existingLabel size to: 1 by: -1 do:
		[:anIndex | ((existingLabel at: anIndex) == $[) ifTrue:
			[newLabel := (existingLabel copyFrom: 1 to: anIndex),
				'Filtered: ',
				messageList size printString,
				']'.
			^ aWindow setLabel: newLabel]]
			

! !

!MessageSet methodsFor: 'private'!
autoSelectString
	"Return the string to be highlighted when making new selections"
	^ autoSelectString! !

!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
autoSelectString: aString
	"Set the string to be highlighted when making new selections"
	autoSelectString := aString! !

!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
buildMorphicMessageList
	"Build my message-list object in morphic"

	| aListMorph |
	aListMorph := PluggableListMorph new.
	aListMorph
		setProperty: #highlightSelector toValue: #highlightMessageList:with:;
		setProperty: #itemConversionMethod toValue: #asStringOrText;
		setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForClassAndMethodString.
	aListMorph
		on: self list: #messageList
		selected: #messageListIndex changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	aListMorph enableDragNDrop: Preferences browseWithDragNDrop.
	aListMorph menuTitleSelector: #messageListSelectorTitle.
	^ aListMorph

! !

!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
contents: aString notifying: aController 
	"Compile the code in aString. Notify aController of any syntax errors. 
	Answer false if the compilation fails. Otherwise, if the compilation 
	created a new method, deselect the current selection. Then answer true."

	| category selector class oldSelector |
	self okayToAccept ifFalse: [^ false].
	self setClassAndSelectorIn: [:c :os | class := c.  oldSelector := os].
	class ifNil: [^ false].
	(oldSelector ~~ nil and: [oldSelector first isUppercase]) ifTrue:
		[oldSelector = #Comment ifTrue:
			[class comment: aString stamp: Utilities changeStamp.
			self changed: #annotation.
 			self clearUserEditFlag.
			^ false].
		oldSelector = #Definition ifTrue:
			["self defineClass: aString notifying: aController."
			class subclassDefinerClass
				evaluate: aString
				notifying: aController
				logged: true.
			self clearUserEditFlag.
 			^ false].
		oldSelector = #Hierarchy ifTrue:
			[self inform: 'To change the hierarchy, edit the class definitions'. 
			^ false]].
	"Normal method accept"
	category := class organization categoryOfElement: oldSelector.
	selector := class compile: aString
				classified: category
				notifying: aController.
	selector == nil ifTrue: [^ false].
	self noteAcceptanceOfCodeFor: selector.
	selector == oldSelector ifFalse:
		[self reformulateListNoting: selector].
	contents := aString copy.
	self changed: #annotation.
	^ true! !

!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
inMorphicWindowLabeled: labelString
	"Answer a morphic window with the given label that can display the receiver"

	| window listFraction |
	window := (SystemWindow labelled: labelString) model: self.
	listFraction := 0.2.
	window addMorph: self buildMorphicMessageList frame: (0@0 extent: 1@listFraction).
	self 
		addLowerPanesTo: window 
		at: (0@listFraction corner: 1@1) 
		with: nil.

	window setUpdatablePanesFrom: #(messageList).
	^ window! !

!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
initializeMessageList: anArray
	"Initialize my messageList from the given list of MethodReference or string objects.  NB: special handling for uniclasses."

	| s |
	messageList := OrderedCollection new.
	anArray do: [ :each |
		MessageSet 
			parse: each  
			toClassAndSelector: [ :class :sel |
				class ifNotNil:
					[class isUniClass
						ifTrue:
							[s := class typicalInstanceName, ' ', sel]
						ifFalse:
							[s := class name , ' ' , sel , ' {' , 
								((class organization categoryOfElement: sel) ifNil: ['']) , '}'].
					messageList add: (
						MethodReference new
							setClass: class  
							methodSymbol: sel 
							stringVersion: s)]]].
	messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1].
	contents := ''! !

!MessageSet methodsFor: 'private' stamp: 'yo 7/30/2004 16:36'!
openAsMorphNamed: labelString inWorld: aWorld
	"Open the receiver in a morphic window in the given world"

	(self inMorphicWindowLabeled: labelString) openInWorld: aWorld.
	self messageListIndex: 1.
! !

!MessageSet methodsFor: 'private' stamp: 'sw 12/28/2000 14:28'!
selection
	"Answer the item in the list that is currently selected, or nil if no selection is present"

	^ messageList at: messageListIndex ifAbsent: [nil]! !

!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
setClassAndSelectorIn: csBlock
	| sel |
	"Decode strings of the form <className> [class] <selectorName>."

	self flag: #mref.	"compatibility with pre-MethodReference lists"

	sel := self selection.
	^(sel isKindOf: MethodReference) ifTrue: [
		sel setClassAndSelectorIn: csBlock
	] ifFalse: [
		MessageSet parse: sel toClassAndSelector: csBlock
	]! !

!MessageSet methodsFor: 'private' stamp: 'sw 1/11/2001 09:18'!
setFilteredList: newList
	"Establish newList as the new list if appropriate, and adjust the window title accordingly; if the new list is of the same size as the old, warn and do nothing"

	newList size == 0
		ifTrue:
			[^ self inform: 'Nothing would be left in the list if you did that'].
	newList size == messageList size
		ifTrue:
			[^ self inform: 'That leaves the list unchanged'].
	self initializeMessageList: newList.
	self adjustWindowTitleAfterFiltering! !

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

MessageSet class
	instanceVariableNames: ''!

!MessageSet class methodsFor: 'instance creation'!
messageList: anArray 
	"Answer an instance of me with message list anArray."

	^self new initializeMessageList: anArray! !

!MessageSet class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
open: aMessageSet name: aString 
	"Create a standard system view for the messageSet, aMessageSet, whose label is aString."
	| topView aListView aBrowserCodeView aTextView underPane y buttonsView winWidth |

	Smalltalk isMorphic ifTrue: [^ self openAsMorph: aMessageSet name: aString].

	winWidth := 200.
	topView := (StandardSystemView new) model: aMessageSet.
	topView label: aString.
	topView minimumSize: winWidth @ 120.
	topView borderWidth: 1.

	aListView := PluggableListView on: aMessageSet
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	aListView  menuTitleSelector: #messageListSelectorTitle.
	aListView window: (0 @ 0 extent: winWidth @ 100).
	topView addSubView: aListView.

	aMessageSet  wantsAnnotationPane
		ifTrue:
			[aTextView := PluggableTextView on: aMessageSet 
			text: #annotation accept: nil
			readSelection: nil menu: nil.
			aTextView window: (0 @ 0 extent: winWidth @ 24).
			topView addSubView: aTextView below: aListView.
			underPane := aTextView.
			y := 300 - 24.
			aTextView askBeforeDiscardingEdits: false]
		ifFalse:
			[underPane := aListView.
			y := 300].

	aMessageSet wantsOptionalButtons ifTrue:
		[buttonsView := aMessageSet buildOptionalButtonsView.
		topView addSubView: buttonsView below: underPane.
		underPane := buttonsView.
		y := y - aMessageSet optionalButtonHeight].

	aBrowserCodeView := PluggableTextView on: aMessageSet 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	aBrowserCodeView window: (0 @ 0 extent: winWidth @ y).
	topView addSubView: aBrowserCodeView below: underPane.
	topView setUpdatablePanesFrom: #(messageList).
	topView controller open! !

!MessageSet class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:41'!
openAsMorph: aMessageSet name: labelString 
	"Create a SystemWindow aMessageSet, with the label labelString, in a Morphic project"
	^ self openAsMorph: aMessageSet name: labelString inWorld: self currentWorld! !

!MessageSet class methodsFor: 'instance creation' stamp: 'RAA 1/10/2001 11:07'!
openAsMorph: aMessageSet name: labelString inWorld: aWorld

	^aMessageSet openAsMorphNamed: labelString inWorld: aWorld
! !

!MessageSet class methodsFor: 'instance creation'!
openMessageList: anArray name: aString 
	"Create a standard system view for the message set on the list, anArray. 
	The label of the view is aString."

	self open: (self messageList: anArray) name: aString! !

!MessageSet class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
openMessageList: messageList name: labelString autoSelect: autoSelectString
	"Open a system view for a MessageSet on messageList. 
	 1/24/96 sw: the there-are-no msg now supplied by my sender"

	| messageSet |
	messageSet := self messageList: messageList.
	messageSet autoSelectString: autoSelectString.
	Smalltalk isMorphic ifTrue: [^ self openAsMorph: messageSet name: labelString].
	ScheduledControllers scheduleActive: (self open: messageSet name: labelString)! !


!MessageSet class methodsFor: 'utilities' stamp: 'RAA 5/29/2001 10:19'!
extantMethodsIn: aListOfMethodRefs
	"Answer the subset of the incoming list consisting only of those message markers that refer to methods actually in the current image"


	self flag: #mref.	"may be removed in second round"


	^ aListOfMethodRefs select: [:aToken |
		self 
			parse: aToken 
			toClassAndSelector: [ :aClass :aSelector |
				aClass notNil and: [aClass includesSelector: aSelector]
			]
	]! !

!MessageSet class methodsFor: 'utilities' stamp: 'sw 6/6/2001 15:09'!
isPseudoSelector: aSelector
	"Answer whether the given selector is a special marker"

	^ #(Comment Definition Hierarchy) includes: aSelector! !

!MessageSet class methodsFor: 'utilities' stamp: 'md 3/3/2006 09:25'!
parse: methodRef toClassAndSelector: csBlock
	"Decode strings of the form <className> [class] <selectorName>."

	| tuple cl |


	self flag: #mref.	"compatibility with pre-MethodReference lists"

	methodRef ifNil: [^ csBlock value: nil value: nil].
	(methodRef isKindOf: MethodReference) ifTrue: [
		^methodRef setClassAndSelectorIn: csBlock
	].
	methodRef isEmpty ifTrue: [^ csBlock value: nil value: nil].
	tuple := methodRef asString findTokens: ' .'.
	cl := Smalltalk at: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil].
	(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']])
		ifTrue: [^ csBlock value: cl value: (tuple at: 2) asSymbol]
		ifFalse: [^ csBlock value: cl class value: (tuple at: 3) asSymbol]! !


!MessageSet class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:37'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Message List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A list of messages (e.g. senders, implementors)'! !
Magnitude subclass: #MessageTally
	instanceVariableNames: 'class method tally receivers senders time gcStats maxClassNameSize maxClassPlusSelectorSize maxTabs'
	classVariableNames: 'DefaultPollPeriod ObservedProcess Timer'
	poolDictionaries: ''
	category: 'System-Tools'!
!MessageTally commentStamp: 'nk 3/8/2004 12:43' prior: 0!
My instances observe and report the amount of time spent in methods.

NOTE: a higher-level user interface (combining the MessageTally result tree with a method browser) is available from TimeProfileBrowser.

MessageTally provides two different strategies available for profiling:

* spyOn: and friends use a high-priority Process to interrupt the block or process being spied on at periodic intervals. The interrupted call stack is then examined for caller information.

* tallySends: and friends use the interpreter simulator to run the block, recording every method call.

The two give you different results:

* spyOn: gives you a view of where the time is being spent in your program, at least on a rough statistical level (assuming you've run the block for long enough and have a high enough poll rate). If you're trying to optimize your code, start here and optimize the methods where most of the time is being spent first.

* tallySends: gives you accurate counts of how many times methods get called, and by exactly which route. If you're debugging, or trying to figure out if a given method is getting called too many times, this is your tool.

You can change the printing format (that is, the whitespace and string compression) by using these instance methods: 
	maxClassNameSize:
	maxClassPlusSelectorSize:
	maxTabs:

You can change the default polling period (initially set to 1) by calling
	MessageTally defaultPollPeriod: numberOfMilliseconds

Q: How do you interpret MessageTally>>tallySends
A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format.  #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed.!


!MessageTally methodsFor: 'collecting leaves'!
bump: hitCount
	tally _ tally + hitCount! !

!MessageTally methodsFor: 'collecting leaves'!
bump: hitCount fromSender: senderTally
	"Add this hitCount to the total, and include a reference to the
	sender responsible for the increment"
	self bump: hitCount.
	senders == nil ifTrue: [senders _ OrderedCollection new].
	senderTally == nil
		ifFalse: [senders add: (senderTally copyWithTally: hitCount)]! !

!MessageTally methodsFor: 'collecting leaves'!
into: leafDict fromSender: senderTally
	| leafNode |
	leafNode _ leafDict at: method
		ifAbsent: [leafDict at: method
			put: (MessageTally new class: class method: method)].
	leafNode bump: tally fromSender: senderTally! !

!MessageTally methodsFor: 'collecting leaves'!
leavesInto: leafDict fromSender: senderTally
	| rcvrs |
	rcvrs _ self sonsOver: 0.
	rcvrs size = 0
		ifTrue: [self into: leafDict fromSender: senderTally]
		ifFalse: [rcvrs do:
				[:node |
				node isPrimitives
					ifTrue: [node leavesInto: leafDict fromSender: senderTally]
					ifFalse: [node leavesInto: leafDict fromSender: self]]]! !


!MessageTally methodsFor: 'comparing'!
< aMessageTally 
	"Refer to the comment in Magnitude|<."

	^tally > aMessageTally tally! !

!MessageTally methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:05'!
= aMessageTally

	self species == aMessageTally species ifFalse: [^ false].
	^ aMessageTally method == method! !

!MessageTally methodsFor: 'comparing'!
> aMessageTally 
	"Refer to the comment in Magnitude|>."

	^tally < aMessageTally tally! !

!MessageTally methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^method asOop! !

!MessageTally methodsFor: 'comparing'!
isPrimitives
	"Detect pseudo node used to carry tally of local hits"
	^ receivers == nil! !

!MessageTally methodsFor: 'comparing'!
sonsOver: threshold

	| hereTally last sons |
	(receivers == nil or: [receivers size = 0]) ifTrue: [^#()].
	hereTally _ tally.
	sons _ receivers select:  "subtract subNode tallies for primitive hits here"
		[:son |
		hereTally _ hereTally - son tally.
		son tally > threshold].
	hereTally > threshold
		ifTrue: 
			[last _ MessageTally new class: class method: method.
			^sons copyWith: (last primitives: hereTally)].
	^sons! !

!MessageTally methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:04'!
species
	^MessageTally! !


!MessageTally methodsFor: 'initialize-release'!
close

	(Timer isMemberOf: Process) ifTrue: [Timer terminate].
	Timer _ ObservedProcess _ nil.
	class _ method _ tally _ receivers _ nil! !

!MessageTally methodsFor: 'initialize-release' stamp: 'nk 3/8/2004 12:29'!
initialize
	maxClassNameSize _ self class defaultMaxClassNameSize.
	maxClassPlusSelectorSize _ self class defaultMaxClassPlusSelectorSize.
	maxTabs _ self class defaultMaxTabs.! !

!MessageTally methodsFor: 'initialize-release' stamp: 'md 1/20/2006 17:18'!
spyEvery: millisecs on: aBlock 
	"Create a spy and spy on the given block at the specified rate."

	| myDelay startTime time0 |
	(aBlock isMemberOf: BlockContext)
		ifTrue: [self class: aBlock receiver class method: aBlock method]
		ifFalse: [self class: aBlock class method: aBlock method].
		"set up the probe"
	ObservedProcess _ Processor activeProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	gcStats _ SmalltalkImage current getVMParameters.
	Timer :=
		[[true] whileTrue: 
			[startTime := Time millisecondClockValue.
			myDelay wait.
			self tally: ObservedProcess suspendedContext
				"tally can be > 1 if ran a long primitive"
				by: (Time millisecondClockValue - startTime) // millisecs].
		nil] newProcess.
	Timer priority: Processor userInterruptPriority.
		"activate the probe and evaluate the block"
	Timer resume.
	^ aBlock ensure:
		["Collect gc statistics"
		SmalltalkImage current getVMParameters keysAndValuesDo:
			[:idx :gcVal| gcStats at: idx put: (gcVal - (gcStats at: idx))].
		"cancel the probe and return the value"
		Timer terminate.
		time := Time millisecondClockValue - time0]! !

!MessageTally methodsFor: 'initialize-release' stamp: 'sd 9/30/2003 13:42'!
spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration 
	"Create a spy and spy on the given process at the specified rate."
	| myDelay time0 endTime sem |
	(aProcess isKindOf: Process)
		ifFalse: [self error: 'spy needs a Process here'].
	self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method.
	"set up the probe"
	ObservedProcess _ aProcess.
	myDelay _ Delay forMilliseconds: millisecs.
	time0 _ Time millisecondClockValue.
	endTime _ time0 + msecDuration.
	sem _ Semaphore new.
	gcStats _ SmalltalkImage current  getVMParameters.
	Timer _ [[| startTime | 
			startTime _ Time millisecondClockValue.
			myDelay wait.
			self tally: ObservedProcess suspendedContext by: Time millisecondClockValue - startTime // millisecs.
			startTime < endTime] whileTrue.
			sem signal]
				forkAt: (ObservedProcess priority + 1 min: Processor highestPriority).
	"activate the probe and wait for it to finish"
	sem wait.
	"Collect gc statistics"
	SmalltalkImage current  getVMParameters keysAndValuesDo:
		[:idx :gcVal| gcStats at: idx put: (gcVal - gcStats at: idx)].
	time _ Time millisecondClockValue - time0! !


!MessageTally methodsFor: 'printing' stamp: 'dew 3/15/2000 21:49'!
fullPrintOn: aStream tallyExact: isExact orThreshold: perCent
	| threshold |  
	isExact ifFalse: [threshold _ (perCent asFloat / 100 * tally) rounded].
	aStream nextPutAll: '**Tree**'; cr.
	self treePrintOn: aStream
		tabs: OrderedCollection new
		thisTab: ''
		total: tally
		totalTime: time
		tallyExact: isExact
		orThreshold: threshold.
	aStream nextPut: Character newPage; cr.
	aStream nextPutAll: '**Leaves**'; cr.
	self leavesPrintOn: aStream
		tallyExact: isExact
		orThreshold: threshold! !

!MessageTally methodsFor: 'printing' stamp: 'dew 3/22/2000 02:28'!
leavesPrintOn: aStream tallyExact: isExact orThreshold: threshold
	| dict |
	dict _ IdentityDictionary new: 100.
	self leavesInto: dict fromSender: nil.
	isExact ifTrue: 
		[dict asSortedCollection
			do: [:node |
				node printOn: aStream total: tally totalTime: nil tallyExact: isExact.
				node printSenderCountsOn: aStream]]
		ifFalse:
		[(dict asOrderedCollection
				select: [:node | node tally > threshold])
			asSortedCollection
			do: [:node |
				node printOn: aStream total: tally totalTime: time tallyExact: isExact]]! !

!MessageTally methodsFor: 'printing' stamp: 'md 2/17/2006 13:44'!
printOn: aStream 
	| className |
	(class isNil or: [method isNil]) ifTrue: [^super printOn: aStream].
	className := method methodClass name contractTo: self maxClassNameSize.
	aStream
		nextPutAll: className;
		nextPutAll: ' >> ';
		nextPutAll: (method selector contractTo: self maxClassPlusSelectorSize - className size)! !

!MessageTally methodsFor: 'printing' stamp: 'md 2/17/2006 13:43'!
printOn: aStream total: total totalTime: totalTime tallyExact: isExact 
	| aSelector className myTally aClass percentage |
	isExact 
		ifTrue: 
			[myTally := tally.
			receivers == nil 
				ifFalse: [receivers do: [:r | myTally := myTally - r tally]].
			aStream
				print: myTally;
				space]
		ifFalse: 
			[percentage := tally asFloat / total * 100.0 roundTo: 0.1.
			aStream
				print: percentage;
				nextPutAll: '% {';
				print: (percentage * totalTime / 100) rounded;
				nextPutAll: 'ms} '].
	receivers == nil 
		ifTrue: 
			[aStream
				nextPutAll: 'primitives';
				cr]
		ifFalse: 
			[aSelector := method selector.
			aClass := method methodClass.
			className := aClass name contractTo: self maxClassNameSize.
			aStream
				nextPutAll: class name;
				nextPutAll: (aClass = class 
							ifTrue: ['>>']
							ifFalse: ['(' , aClass name , ')>>']);
				nextPutAll: (aSelector 
							contractTo: self maxClassPlusSelectorSize - className size);
				cr]! !

!MessageTally methodsFor: 'printing' stamp: 'dew 3/22/2000 02:28'!
printSenderCountsOn: aStream
	| mergedSenders mergedNode |
	mergedSenders _ IdentityDictionary new.
	senders do:
		[:node |
		mergedNode _ mergedSenders at: node method ifAbsent: [nil].
		mergedNode == nil
			ifTrue: [mergedSenders at: node method put: node]
			ifFalse: [mergedNode bump: node tally]].
	mergedSenders asSortedCollection do:
		[:node | 
		10 to: node tally printString size by: -1 do: [:i | aStream space].
		node printOn: aStream total: tally totalTime: nil tallyExact: true]! !

!MessageTally methodsFor: 'printing' stamp: 'nk 3/8/2004 12:23'!
treePrintOn: aStream tabs: tabs thisTab: myTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold 
	| sons sonTab |
	tabs do: [:tab | aStream nextPutAll: tab].
	tabs size > 0 
		ifTrue: 
			[self 
				printOn: aStream
				total: total
				totalTime: totalTime
				tallyExact: isExact].
	sons := isExact ifTrue: [receivers] ifFalse: [self sonsOver: threshold].
	sons isEmpty 
		ifFalse: 
			[tabs addLast: myTab.
			sons := sons asSortedCollection.
			(1 to: sons size) do: 
					[:i | 
					sonTab := i < sons size ifTrue: ['  |'] ifFalse: ['  '].
					(sons at: i) 
						treePrintOn: aStream
						tabs: (tabs size < self maxTabs 
								ifTrue: [tabs]
								ifFalse: [(tabs select: [:x | x = '[']) copyWith: '['])
						thisTab: sonTab
						total: total
						totalTime: totalTime
						tallyExact: isExact
						orThreshold: threshold].
			tabs removeLast]! !


!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'!
maxClassNameSize
	^maxClassNameSize! !

!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'!
maxClassNameSize: aNumber
	maxClassNameSize := aNumber! !

!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'!
maxClassPlusSelectorSize
	^maxClassPlusSelectorSize! !

!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'!
maxClassPlusSelectorSize: aNumber
	maxClassPlusSelectorSize := aNumber! !

!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'!
maxTabs
	^maxTabs! !

!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'!
maxTabs: aNumber
	maxTabs := aNumber! !


!MessageTally methodsFor: 'reporting'!
report: strm 
	"Print a report, with cutoff percentage of each element of the tree 
	(leaves, roots, tree)=2, on the stream, strm."

	self report: strm cutoff: 2! !

!MessageTally methodsFor: 'reporting' stamp: 'spfa 6/1/2004 19:23'!
report: strm cutoff: threshold 
	tally = 0
		ifTrue: [strm nextPutAll: ' - no tallies obtained']
		ifFalse: 
			[strm nextPutAll: ' - '; print: tally; nextPutAll: ' tallies, ', time printString, ' msec.'; cr; cr.
			self fullPrintOn: strm tallyExact: false orThreshold: threshold].
		
	time isZero ifFalse:	
		[self reportGCStatsOn: strm].! !

!MessageTally methodsFor: 'reporting' stamp: 'ar 7/18/2001 22:12'!
reportGCStatsOn: str
	| oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount upTime rootOverflows |
	upTime _ time.
	oldSpaceEnd			_ gcStats at: 1.
	youngSpaceEnd		_ gcStats at: 2.
	memoryEnd			_ gcStats at: 3.
	fullGCs				_ gcStats at: 7.
	fullGCTime			_ gcStats at: 8.
	incrGCs				_ gcStats at: 9.
	incrGCTime			_ gcStats at: 10.
	tenureCount			_ gcStats at: 11.
	rootOverflows		_ gcStats at: 22.

	str cr.
	str	nextPutAll: '**Memory**'; cr.
	str	nextPutAll:	'	old			';
		nextPutAll: oldSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr.
	str	nextPutAll: '	young		';
		nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr.
	str	nextPutAll: '	used		';
		nextPutAll: youngSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr.
	str	nextPutAll: '	free		';
		nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr.

	str cr.
	str	nextPutAll: '**GCs**'; cr.
	str	nextPutAll: '	full			';
		print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms (';
		print: ((fullGCTime / upTime * 100) roundTo: 1.0);
		nextPutAll: '% uptime)'.
	fullGCs = 0 ifFalse:
		[str	nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms'].
	str	cr.
	str	nextPutAll: '	incr		';
		print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms (';
		print: ((incrGCTime / upTime * 100) roundTo: 1.0);
		nextPutAll: '% uptime)'.
	incrGCs = 0 ifFalse:
		[str nextPutAll:', avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms'].
	str cr.
	str	nextPutAll: '	tenures		';
		nextPutAll: tenureCount asStringWithCommas.
	tenureCount = 0 ifFalse:
		[str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)'].
	str	cr.
	str	nextPutAll: '	root table	';
		nextPutAll: rootOverflows asStringWithCommas; nextPutAll:' overflows'.
	str cr.
! !

!MessageTally methodsFor: 'reporting' stamp: 'stp 05/08/1999 12:06'!
tally
	"Answer the receiver's number of tally."

	^tally! !

!MessageTally methodsFor: 'reporting' stamp: 'stp 05/08/1999 11:47'!
time
	"Answer the receiver's run time."

	^time! !


!MessageTally methodsFor: 'tallying'!
bumpBy: count

	tally _ tally + count! !

!MessageTally methodsFor: 'tallying'!
tally: context by: count
	"Explicitly tally the specified context and its stack."
	| root |
	context method == method ifTrue: [^self bumpBy: count].
	(root _ context home sender) == nil
		ifTrue: [^ (self bumpBy: count) tallyPath: context by: count].
	^ (self tally: root by: count) tallyPath: context by: count! !

!MessageTally methodsFor: 'tallying' stamp: 'efc 8/27/2005 16:42'!
tallyPath: context by: count
	| aMethod path |
	aMethod _ context method.
	receivers do: 
		[:aMessageTally | 
		aMessageTally method == aMethod ifTrue: [path _ aMessageTally]].
	path == nil ifTrue: 
		[path _ MessageTally new class: context receiver class method: aMethod;
			maxClassNameSize: maxClassNameSize;
			maxClassPlusSelectorSize: maxClassPlusSelectorSize;
			maxTabs: maxTabs.
		receivers _ receivers copyWith: path].
	^ path bumpBy: count! !


!MessageTally methodsFor: 'private'!
class: aClass method: aMethod

	class _ aClass.
	method _ aMethod.
	tally _ 0.
	receivers _ Array new: 0! !

!MessageTally methodsFor: 'private'!
copyWithTally: hitCount
	^ (MessageTally new class: class method: method) bump: hitCount! !

!MessageTally methodsFor: 'private'!
method

	^method! !

!MessageTally methodsFor: 'private'!
primitives: anInteger

	tally _ anInteger.
	receivers _ nil! !

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

MessageTally class
	instanceVariableNames: ''!

!MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:27'!
defaultMaxClassNameSize
	"Return the default maximum width of the class name alone"
	^30! !

!MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:27'!
defaultMaxClassPlusSelectorSize
	"Return the default maximum width of the class plus selector together (not counting the '>>')"
	^60! !

!MessageTally class methodsFor: 'defaults' stamp: 'dew 4/2/2005 15:04'!
defaultMaxTabs
	"Return the default number of tabs after which leading white space is compressed"
	^40! !

!MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:41'!
defaultPollPeriod
	"Answer the number of milliseconds between interrupts for spyOn: and friends.
	This should be faster for faster machines."
	^DefaultPollPeriod ifNil: [ DefaultPollPeriod _ 1 ]! !

!MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:41'!
defaultPollPeriod: numberOfMilliseconds
	"Set the default number of milliseconds between interrupts for spyOn: and friends.
	This should be faster for faster machines."
	DefaultPollPeriod := numberOfMilliseconds! !


!MessageTally class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:34'!
spyOn: aBlock    "MessageTally spyOn: [100 timesRepeat: [3.14159 printString]]"
	| node result |
	node _ self new.
	result _ node spyEvery: self defaultPollPeriod on: aBlock.
	(StringHolder new contents: (String streamContents: [:s | node report: s; close]))
		openLabel: 'Spy Results'.
	^ result! !

!MessageTally class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:34'!
spyOn: aBlock toFileNamed: fileName 
	"Spy on the evaluation of aBlock. Write the data collected on a file
	named fileName."

	| file value node |
	node _ self new.
	value _ node spyEvery: self defaultPollPeriod on: aBlock.
	file _ FileStream newFileNamed: fileName.
	node report: file; close.
	file close.
	^value! !

!MessageTally class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:35'!
spyOnProcess: aProcess forMilliseconds: msecDuration 
	"| p |  
	p _ [100000 timesRepeat: [3.14159 printString]] fork.  
	(Delay forMilliseconds: 100) wait.  
	MessageTally spyOnProcess: p forMilliseconds: 1000"
	| node |
	node _ self new.
	node
		spyEvery: self defaultPollPeriod
		onProcess: aProcess
		forMilliseconds: msecDuration.
	(StringHolder new
		contents: (String
				streamContents: [:s | node report: s;
						 close]))
		openLabel: 'Spy Results'! !

!MessageTally class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:35'!
spyOnProcess: aProcess forMilliseconds: msecDuration toFileNamed: fileName 
	"Spy on the evaluation of aProcess. Write the data collected on a file  
	named fileName. Will overwrite fileName"
	| file node |
	node _ self new.
	node
		spyEvery: self defaultPollPeriod
		onProcess: aProcess
		forMilliseconds: msecDuration.
	file _ FileStream fileNamed: fileName.
	node report: file;
		 close.
	file close! !

!MessageTally class methodsFor: 'spying'!
tallySends: aBlock   "MessageTally tallySends: [3.14159 printString]"
	^ self tallySendsTo: nil inBlock: aBlock showTree: true! !

!MessageTally class methodsFor: 'spying' stamp: 'tk 5/4/1998 17:01'!
tallySendsTo: receiver inBlock: aBlock showTree: treeOption
	"MessageTally tallySends: [3.14159 printString]"
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. If receiver is not nil, then only sends
	to that receiver are tallied.
	Results are presented as leaves, sorted by frequency,
	preceded, optionally, by the whole tree."
	| prev tallies startTime totalTime |
	startTime _ Time millisecondClockValue.
	tallies _ MessageTally new class: aBlock receiver class
							method: aBlock method.
	prev _ aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: 
				["call or return"
				prev sender == nil ifFalse: 
					["call only"
					(receiver == nil or: [current receiver == receiver])
						ifTrue: [tallies tally: current by: 1]].
				prev _ current]].

	totalTime _ Time millisecondClockValue - startTime // 1000.0 roundTo: 0.01.
	(StringHolder new contents:
		(String streamContents:
			[:s |
			s nextPutAll: 'This simulation took ' , totalTime printString
							, ' seconds.'; cr.
			treeOption
				ifTrue: [tallies fullPrintOn: s tallyExact: true orThreshold: 0]
				ifFalse: [tallies leavesPrintOn: s tallyExact: true orThreshold: 0].
			tallies close]))
		openLabel: 'Spy Results'! !

!MessageTally class methodsFor: 'spying'!
time: aBlock

	^ Time millisecondsToRun: aBlock! !
ClassDescription subclass: #Metaclass
	uses: TApplyingOnClassSide
	instanceVariableNames: 'thisClass traitComposition localSelectors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!Metaclass commentStamp: '<historical>' prior: 0!
My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance.
	
[Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus,
	Integer superclass == Number, and
	Integer class superclass == Number class.
However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus,
	Object superclass == nil, and
	Object class superclass == Class.

[Subtle detail] A class is know by name to an environment.  Typically this is the SystemDictionary named Smalltalk.  If we ever make lightweight classes that are not in Smalltalk, they must be in some environment.  Specifically, the code that sets 'wasPresent' in name:inEnvironment:subclassOf:instanceVariableNames:variable:words:pointers:classVariableNames:poolDictionaries:category:comment:changed: must continue to work.!


!Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 08:14'!
allInstances
	thisClass class == self ifTrue:[^Array with: thisClass].
	^super allInstances! !

!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'!
basicLocalSelectors
	"Direct accessor for the instance variable localSelectors.
	Since localSelectors is lazily initialized, this may 
	return nil, which means that all selectors are local."

	^ localSelectors! !

!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'!
basicLocalSelectors: aSetOrNil
	localSelectors _ aSetOrNil! !

!Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:19'!
environment
	^thisClass environment! !

!Metaclass methodsFor: 'accessing' stamp: 'al 3/26/2006 11:32'!
hasTraitComposition
	^traitComposition notNil! !

!Metaclass methodsFor: 'accessing' stamp: 'tk 6/17/1998 09:48'!
isSystemDefined
	"Answer false if I am a UniClass (an instance-specific lightweight class)"

	^ true! !

!Metaclass methodsFor: 'accessing'!
name
	"Answer a String that is the name of the receiver, either 'Metaclass' or 
	the name of the receiver's class followed by ' class'."

	thisClass == nil
		ifTrue: [^'a Metaclass']
		ifFalse: [^thisClass name , ' class']! !

!Metaclass methodsFor: 'accessing'!
soleInstance
	"The receiver has only one instance. Answer it."

	^thisClass! !

!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'!
traitComposition
	traitComposition ifNil: [traitComposition _ TraitComposition new].
	^traitComposition! !

!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:38'!
traitComposition: aTraitComposition
	traitComposition _ aTraitComposition! !


!Metaclass methodsFor: 'accessing parallel hierarchy' stamp: 'sd 6/27/2003 22:51'!
theMetaClass
	"Sent to a class or metaclass, always return the metaclass"

	^self! !

!Metaclass methodsFor: 'accessing parallel hierarchy'!
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^thisClass! !


!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'!
addObsoleteSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'!
addSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'!
obsoleteSubclasses
	"Answer the receiver's subclasses."
	thisClass == nil ifTrue:[^#()].
	^thisClass obsoleteSubclasses 
		select:[:aSubclass| aSubclass isMeta not] 
		thenCollect:[:aSubclass| aSubclass class]

	"Metaclass allInstancesDo:
		[:m | Compiler evaluate: 'subclasses_nil' for: m logged: false]"! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'!
removeObsoleteSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'!
removeSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/14/1999 11:19'!
subclasses
	"Answer the receiver's subclasses."
	thisClass == nil ifTrue:[^#()].
	^thisClass subclasses 
		select:[:aSubclass| aSubclass isMeta not] 
		thenCollect:[:aSubclass| aSubclass class]

	"Metaclass allInstancesDo:
		[:m | Compiler evaluate: 'subclasses_nil' for: m logged: false]"! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/9/1999 14:11'!
subclassesDo: aBlock
	"Evaluate aBlock for each of the receiver's immediate subclasses."
	thisClass subclassesDo:[:aSubclass|
		"The following test is for Class class which has to exclude
		the Metaclasses being subclasses of Class."
		aSubclass isMeta ifFalse:[aBlock value: aSubclass class]].! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'tk 8/18/1999 17:37'!
subclassesDoGently: aBlock
	"Evaluate aBlock for each of the receiver's immediate subclasses."
	thisClass subclassesDo: [:aSubclass |
		"The following test is for Class class which has to exclude
			the Metaclasses being subclasses of Class."
		aSubclass isInMemory ifTrue: [
			aSubclass isMeta ifFalse: [aBlock value: aSubclass class]]].! !


!Metaclass methodsFor: 'compiling'!
acceptsLoggingOfCompilation
	"Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set.  The metaclass follows the rule of the class itself.  6/18/96 sw"

	^ thisClass acceptsLoggingOfCompilation! !

!Metaclass methodsFor: 'compiling' stamp: 'ar 5/18/2003 18:13'!
bindingOf: varName

	^thisClass classBindingOf: varName! !

!Metaclass methodsFor: 'compiling'!
possibleVariablesFor: misspelled continuedFrom: oldResults

	^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults
! !

!Metaclass methodsFor: 'compiling'!
wantsChangeSetLogging
	"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself.  7/12/96 sw"

	^ thisClass wantsChangeSetLogging! !

!Metaclass methodsFor: 'compiling' stamp: 'sw 7/31/2000 14:29'!
wantsRecompilationProgressReported
	"The metaclass follows the rule of the class itself."

	^ thisClass wantsRecompilationProgressReported! !



!Metaclass methodsFor: 'copying'!
copy
	"Make a copy of the receiver without a list of subclasses. Share the 
	reference to the sole instance."

	| copy t |
	t _ thisClass.
	thisClass _ nil.
	copy _ super copy.
	thisClass _ t.
	^copy! !

!Metaclass methodsFor: 'copying' stamp: 'tk 8/19/1998 16:16'!
veryDeepCopyWith: deepCopier
	"Return self.  Must be created, not copied.  Do not record me."! !


!Metaclass methodsFor: 'enumerating' stamp: 'ar 7/15/1999 16:43'!
allInstancesDo: aBlock
	"There should be only one"
	thisClass class == self ifTrue:[^aBlock value: thisClass].
	^super allInstancesDo: aBlock! !

!Metaclass methodsFor: 'enumerating' stamp: 'tk 11/12/1999 11:45'!
allInstancesEverywhereDo: aBlock
	"There should be only one"
	thisClass class == self ifTrue:[^ aBlock value: thisClass].
	^ super allInstancesEverywhereDo: aBlock! !


!Metaclass methodsFor: 'fileIn/Out' stamp: 'al 1/9/2006 18:04'!
definitionST80
	"Refer to the comment in ClassDescription|definition."

	^ String streamContents: 
		[:strm |
		strm print: self.
		(self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [
			strm
				crtab;
				nextPutAll: 'uses: ';
				print: self traitComposition].
		strm
			crtab;
			nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString]! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'!
fileOutInitializerOn: aStream
	(self methodDict includesKey: #initialize) ifTrue: 
		[aStream cr.
		aStream nextChunkPut: thisClass name , ' initialize'].! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:31'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
	^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'al 7/19/2004 18:28'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
	super fileOutOn: aFileStream
		moveSource: moveSource
		toFile: fileIndex.
	(aBool and:[moveSource not and: [self methodDict includesKey: #initialize]]) ifTrue: 
		[aFileStream cr.
		aFileStream cr.
		aFileStream nextChunkPut: thisClass name , ' initialize'.
		aFileStream cr]! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'al 3/26/2006 21:09'!
nonTrivial 
	"Answer whether the receiver has any methods or instance variables."

	^ self instVarNames size > 0 or: [self methodDict size > 0] or: [self hasTraitComposition]! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'tk 9/28/2000 15:44'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to a class in Smalltalk instead."

	(refStrm insideASegment and: [self isSystemDefined not]) ifTrue: [
		^ self].	"do trace me"
	dp _ DiskProxy global: self theNonMetaClass name selector: #class
			args: (Array new).
	refStrm replace: self with: dp.
	^ dp
! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'tk 9/27/2000 11:39'!
storeDataOn: aDataStream
	"I don't get stored.  Use a DiskProxy"

	(aDataStream insideASegment and: [self isSystemDefined not]) ifTrue: [
		^ super storeDataOn: aDataStream].	"do trace me"
	self error: 'use a DiskProxy to store a Class'! !


!Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/13/1999 04:52'!
adoptInstance: oldInstance from: oldMetaClass 
	"Recreate any existing instances of the argument, oldClass, as instances of 
	the receiver, which is a newly changed class. Permute variables as 
	necessary."
	thisClass class == self ifTrue:[^self error:'Metaclasses have only one instance'].
	oldMetaClass isMeta ifFalse:[^self error:'Argument must be Metaclass'].
	oldInstance class == oldMetaClass ifFalse:[^self error:'Not the class of argument'].
	^thisClass _ self 
		newInstanceFrom: oldInstance 
		variable: self isVariable 
		size: self instSize 
		map: (self instVarMappingFrom: oldMetaClass)! !

!Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/15/1999 18:56'!
instanceVariableNames: instVarString 
	"Declare additional named variables for my instance."
	^(ClassBuilder new)
		class: self
		instanceVariableNames: instVarString! !

!Metaclass methodsFor: 'initialize-release' stamp: 'al 7/19/2004 20:49'!
uses: aTraitCompositionOrArray instanceVariableNames: instVarString 
	| newComposition newMetaClass copyOfOldMetaClass |
	
	copyOfOldMetaClass _ self copy.
	newMetaClass _ self instanceVariableNames: instVarString.
	
	newComposition _ aTraitCompositionOrArray asTraitComposition.
	newMetaClass assertConsistantCompositionsForNew: newComposition.
	newMetaClass setTraitComposition: newComposition.
	
	SystemChangeNotifier uniqueInstance
		classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! !


!Metaclass methodsFor: 'instance creation' stamp: 'nk 11/9/2003 10:00'!
new
	"The receiver can only have one instance. Create it or complain that
	one already exists."

	thisClass class ~~ self
		ifTrue: [^thisClass _ self basicNew]
		ifFalse: [self error: 'A Metaclass should only have one instance!!']! !


!Metaclass methodsFor: 'instance variables'!
addInstVarName: aString 
	"Add the argument, aString, as one of the receiver's instance variables."

	| fullString |
	fullString _ aString.
	self instVarNames do: [:aString2 | fullString _ aString2 , ' ' , fullString].
	self instanceVariableNames: fullString! !

!Metaclass methodsFor: 'instance variables'!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance variables."

	| newArray newString |
	(self instVarNames includes: aString)
		ifFalse: [self error: aString , ' is not one of my instance variables'].
	newArray _ self instVarNames copyWithout: aString.
	newString _ ''.
	newArray do: [:aString2 | newString _ aString2 , ' ' , newString].
	self instanceVariableNames: newString! !


!Metaclass methodsFor: 'pool variables'!
classPool
	"Answer the dictionary of class variables."

	^thisClass classPool! !


!Metaclass methodsFor: 'testing' stamp: 'ar 9/10/1999 17:41'!
canZapMethodDictionary
	"Return true if it is safe to zap the method dictionary on #obsolete"
	thisClass == nil
		ifTrue:[^true]
		ifFalse:[^thisClass canZapMethodDictionary]! !

!Metaclass methodsFor: 'testing' stamp: 'dvf 9/27/2005 14:59'!
isMeta
	^ true! !

!Metaclass methodsFor: 'testing' stamp: 'ar 7/11/1999 07:27'!
isObsolete
	"Return true if the receiver is obsolete"
	^thisClass == nil "Either no thisClass"
		or:[thisClass class ~~ self "or I am not the class of thisClass"
			or:[thisClass isObsolete]] "or my instance is obsolete"! !


!Metaclass methodsFor: 'private' stamp: 'ar 3/3/2001 00:20'!
replaceObsoleteInstanceWith: newInstance
	thisClass class == self ifTrue:[^self error:'I am fine, thanks'].
	newInstance class == self ifFalse:[^self error:'Not an instance of me'].
	thisClass _ newInstance.! !


!Metaclass methodsFor: '*ob-standard-converting' stamp: 'cwp 10/23/2005 14:40'!
asClassSideNode
	^ OBMetaclassNode on: self theNonMetaClass! !

!Metaclass methodsFor: '*ob-standard-converting'!
asNode
	^ (OBMetaclassNode on: self)! !

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

Metaclass class
	uses: TApplyingOnClassSide classTrait
	instanceVariableNames: ''!

!Metaclass class methodsFor: 'anti-corruption' stamp: 'di 11/24/1999 13:30'!
isScarySelector: newbieSelector

	"Return true if newbieSelector is already a part of Metaclass protocol."
	(Metaclass includesSelector: newbieSelector) ifTrue: [^ true].
	(ClassDescription includesSelector: newbieSelector) ifTrue: [^ true].
	(Behavior includesSelector: newbieSelector) ifTrue: [^ true].
	^ false
! !
MessageSend subclass: #MethodCall
	instanceVariableNames: 'lastValue methodInterface timeStamp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!
!MethodCall commentStamp: '<historical>' prior: 0!
A MethodCall is a resendable message-send, complete with receiver, instantiated arguments, and a memory of when it was last evaluated and what the last value was.  

The methodInterface with which it is associated can furnish argument names, documentation, and other information.!


!MethodCall methodsFor: 'argument access' stamp: 'stephaneducasse 2/4/2006 20:39'!
setArgumentNamed: aName toValue: aValue
	"Set the argument of the given name to the given value"

	| anIndex |
	anIndex := self methodInterface argumentVariables findFirst:
		[:aVariable | aVariable variableName = aName].
	anIndex > 0
		ifTrue:
			[arguments at: anIndex put: aValue]
		ifFalse:
			[self error: 'argument missing'].
	self changed: #argumentValue! !


!MethodCall methodsFor: 'evaluation' stamp: 'stephaneducasse 2/4/2006 20:39'!
evaluate
	"Evaluate the receiver, and if value has changed, signal value-changed"

	| result |
	result := arguments isEmptyOrNil
		ifTrue: [self receiver perform: selector]
		ifFalse: [self receiver perform: selector withArguments: arguments asArray].
	timeStamp := Time dateAndTimeNow.
	result ~= lastValue ifTrue:
		[lastValue := result.
		self changed: #value]
	! !

!MethodCall methodsFor: 'evaluation' stamp: 'sw 11/20/2001 12:21'!
everEvaluated
	"Answer whether this method call has ever been evaluated"

	^ timeStamp notNil! !

!MethodCall methodsFor: 'evaluation' stamp: 'sw 11/20/2001 13:31'!
lastValue
	"Answer the last value I remember obtaining from an evaluation"

	^ lastValue! !


!MethodCall methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
receiver: aReceiver methodInterface: aMethodInterface
	"Initialize me to have the given receiver and methodInterface"

	| aResultType |
	receiver := aReceiver.
	selector := aMethodInterface selector.
	methodInterface := aMethodInterface.
	arguments := aMethodInterface defaultArguments.

	self flag: #noteToTed.
	"the below can't really survive, I know.  The intent is that if the method has a declared result type, we want the preferred readout type to be able to handle the initial #lastValue even if the MethodCall has not been evaluated yet; thus we'd rather have a boolean value such as true rather than a nil here if we're showing a boolean readout such as a checkbox, and likewise for color-valued and numeric-valued readouts etc, "

	(aResultType := methodInterface resultType) ~~ #unknown ifTrue:
		[lastValue := (Vocabulary vocabularyForType: aResultType) initialValueForASlotFor: aReceiver]        ! !

!MethodCall methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
receiver: aReceiver methodInterface: aMethodInterface initialArguments: initialArguments
	"Set up a method-call for the given receiver, method-interface, and initial arguments"

	receiver := aReceiver.
	selector := aMethodInterface selector.
	methodInterface := aMethodInterface.
	arguments := initialArguments ifNotNil: [initialArguments asArray]
! !

!MethodCall methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
valueOfArgumentNamed: aName
	"Answer the value of the given arguement variable"

	| anIndex |
	anIndex := self methodInterface argumentVariables findFirst:
		[:aVariable | aVariable variableName = aName].
	^ anIndex > 0
		ifTrue:
			[arguments at: anIndex]
		ifFalse:
			[self error: 'variable not found']! !


!MethodCall methodsFor: 'method interface'!
ephemeralMethodInterface
	"Answer a methodInterface for me. If I have one stored, answer it; if 
	not, conjure up an interface and answer it but do NOT store it 
	internally. You can call this directly if you need a method interface 
	for me but do not want any conjured-up interface to persist."
	^ methodInterface
		ifNil: [MethodInterface new
				conjuredUpFor: selector
				class: (self receiver class whichClassIncludesSelector: selector)]! !

!MethodCall methodsFor: 'method interface' stamp: 'stephaneducasse 2/4/2006 20:39'!
methodInterface
	"Answer the receiver's methodInterface, conjuring one up on the spot (and remembering) if not present"

	^ methodInterface ifNil:
		[methodInterface := self ephemeralMethodInterface]! !

!MethodCall methodsFor: 'method interface' stamp: 'stephaneducasse 2/4/2006 20:39'!
methodInterface: anInterface
	"Set my methodInterface"

	methodInterface := anInterface! !

!MethodCall methodsFor: 'method interface' stamp: 'sw 11/20/2001 12:40'!
methodInterfaceOrNil
	"Answer my methodInterface, whether it is nil or not"

	^ methodInterface! !
Object subclass: #MethodChangeRecord
	instanceVariableNames: 'changeType currentMethod infoFromRemoval'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Changes'!
!MethodChangeRecord commentStamp: '<historical>' prior: 0!
MethodChangeRecords are used to record method changes.  Here is a simple summary of the relationship between the changeType symbol and the recording of prior state

			|	prior == nil			|	prior not nil	
	---------	|----------------------------	|--------------------
	add		|	add					|	change
	---------	|----------------------------	|--------------------
	remove	|	addedThenRemoved	|	remove

Structure:
changeType			symbol -- as summarized above
currentMethod	method
				This is the current version of the method.
				It can be used to assert this change upon entry to a layer. 
infoFromRemoval -- an array of size 2.
				The first element is the source index of the last version of the method.
				The second element is the category in which it was defined, so it
				can be put back there if re-accepted from a version browser.

Note that the above states each have an associated revoke action:
	add --> remove
	change --> change back
	remove --> add back
	addedThenRemoved --> no change
However all of these are accomplished trivially by restoring the original method dictionary.!


!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'!
changeType

	^ changeType! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 3/28/2000 23:34'!
currentMethod

	^ currentMethod! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'!
methodInfoFromRemoval
	"Return an array with the source index of the last version of the method,
	and the category in which it was defined (so it can be put back there if
	re-accepted from a version browser)."

	(changeType == #remove or: [changeType == #addedThenRemoved])
		ifTrue: [^ infoFromRemoval]
		ifFalse: [^ nil]! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/4/2000 11:05'!
noteChangeType: newChangeType

	(changeType == #addedThenRemoved and: [newChangeType == #change])
		ifTrue: [changeType _ #add]
		ifFalse: [changeType _ newChangeType]! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 11:05'!
noteMethodInfoFromRemoval: info
	"Store an array with the source index of the last version of the method,
	and the category in which it was defined (so it can be put back there if
	re-accepted from a version browser)."

	infoFromRemoval _ info! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'ar 6/3/2005 17:01'!
noteNewMethod: newMethod
	"NEVER do this. It is evil."
	currentMethod _ nil.! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'!
printOn: strm

	super printOn: strm.
	strm nextPutAll: ' ('; print: changeType; nextPutAll: ')'! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 10:47'!
priorMethod: ignored

	"We do not save original versions of changed methods because we only
	revoke changes at the level of entire classes, and that is done by
	restoration of the entire methodDictionary."! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'ar 5/23/2001 16:16'!
storeDataOn: aDataStream
	| oldMethod |
	oldMethod _ currentMethod.
	currentMethod _ nil.
	super storeDataOn: aDataStream.
	currentMethod _ oldMethod.
! !
ContextPart variableSubclass: #MethodContext
	instanceVariableNames: 'method receiverMap receiver'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!MethodContext commentStamp: '<historical>' prior: 0!
My instances hold all the dynamic state associated with the execution of a CompiledMethod. In addition to their inherited state, this includes the receiver, a method, and temporary space in the variable part of the context.
	
MethodContexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed.

MethodContexts must only be created using the method newForMethod:.  Note that it is impossible to determine the real object size of a MethodContext except by asking for the frameSize of its method.  Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector.  Any store into stackp other than by the primitive method stackp: is potentially fatal.!


!MethodContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 16:55'!
blockHome
	"If executing closure, search senders for method containing my closure method.  If not found return nil."

	| m |
	self isExecutingBlock ifFalse: [^ self].
	self sender ifNil: [^ nil].
	m _ self method.
	^ self sender findContextSuchThat: [:c | c method hasLiteralThorough: m]! !

!MethodContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 23:29'!
finalBlockHome
	"If executing closure, search senders for original method containing my closure method.  If not found return nil."

	| h |
	self isExecutingBlock ifFalse: [^ self].
	^ (h _ self blockHome) ifNotNil: [h finalBlockHome]! !

!MethodContext methodsFor: 'accessing' stamp: 'md 4/27/2006 15:12'!
hasInstVarRef
	"Answer whether the receiver references an instance variable."

	^self method hasInstVarRef.! !

!MethodContext methodsFor: 'accessing'!
home 
	"Refer to the comment in ContextPart|home."

	^self! !

!MethodContext methodsFor: 'accessing' stamp: 'ajh 9/28/2001 02:16'!
isMethodContext

	^ true! !

!MethodContext methodsFor: 'accessing'!
method

	^method! !

!MethodContext methodsFor: 'accessing'!
receiver 
	"Refer to the comment in ContextPart|receiver."

	^receiver! !

!MethodContext methodsFor: 'accessing'!
removeSelf
	"Nil the receiver pointer and answer its former value."

	| tempSelf |
	tempSelf _ receiver.
	receiver _ nil.
	^tempSelf! !

!MethodContext methodsFor: 'accessing'!
tempAt: index 
	"Refer to the comment in ContextPart|tempAt:."

	^self at: index! !

!MethodContext methodsFor: 'accessing'!
tempAt: index put: value 
	"Refer to the comment in ContextPart|tempAt:put:."

	^self at: index put: value! !


!MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:17'!
asContext

	^ self! !

!MethodContext methodsFor: 'closure support' stamp: 'md 2/20/2006 20:38'!
capturedTempNames

	^ self methodNode scope capturedVars collect: [:var | var name]! !

!MethodContext methodsFor: 'closure support' stamp: 'ar 6/28/2003 00:15'!
contextTag
	"Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag."
	^self! !

!MethodContext methodsFor: 'closure support' stamp: 'md 2/20/2006 20:38'!
doItScope
	"scope (environment) for expressions executed within a method context. self will be the receiver of the do-it method. We want temp vars directly accessible"

	^ self methodNode scope asDoItScope! !

!MethodContext methodsFor: 'closure support' stamp: 'md 2/20/2006 20:38'!
freeNames

	^ self methodNode freeNames! !

!MethodContext methodsFor: 'closure support' stamp: 'md 2/20/2006 20:39'!
freeNamesAndValues

	| aStream eval |
	eval _ [:string |
		self class evaluatorClass new
			evaluate2: (ReadStream on: string)
			in: self
			to: nil
			notifying: nil	"fix this"
			ifFail: [self error: 'bug']
			logged: false].

	aStream _ '' writeStream.
	self freeNames doWithIndex: [:name :index |
		aStream nextPutAll: name; nextPut: $:; space; tab.
		(eval value: name) printOn: aStream.
		aStream cr].
	^ aStream contents! !

!MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:16'!
isClosureContext

	^ self isExecutingBlock! !

!MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:15'!
isExecutingBlock
	"Is this executing a block versus a method"

	^ self method isBlockMethod! !

!MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:21'!
myEnv

	^ receiverMap! !

!MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:22'!
myEnv: closureEnvironment

	receiverMap _ closureEnvironment! !

!MethodContext methodsFor: 'closure support' stamp: 'md 2/20/2006 20:37'!
tempsAndValues

	| string aStream |
	string _ super tempsAndValues.
	self myEnv ifNil: [^ string].

	aStream _ WriteStream on: (String new: 100).
	self capturedTempNames
		doWithIndex: [:title :index |
			aStream nextPutAll: title; nextPut: $:; space; tab.
			(self myEnv at: index) printOn: aStream.
			aStream cr].
	^ string, aStream contents! !


!MethodContext methodsFor: 'initialize-release' stamp: 'ajh 1/23/2003 20:27'!
privRefresh
	"Reinitialize the receiver so that it is in the state it was at its creation."

	pc _ method initialPC.
	self stackp: method numTemps.
	method numArgs+1 to: method numTemps
		do: [:i | self tempAt: i put: nil]! !

!MethodContext methodsFor: 'initialize-release' stamp: 'ajh 5/22/2003 16:28'!
privRefreshWith: aCompiledMethod 
	"Reinitialize the receiver as though it had been for a different method. 
	Used by a Debugger when one of the methods to which it refers is 
	recompiled."

	method _ aCompiledMethod.
	receiverMap _ nil.
	self privRefresh! !


!MethodContext methodsFor: 'printing' stamp: 'tk 10/19/2001 11:34'!
printDetails: strm
	"Put my class>>selector and instance variables and arguments and temporaries on the stream.  Protect against errors during printing."

	| pe str pos |
	self printOn: strm.
	strm cr.
	strm tab; nextPutAll: 'Receiver: '.
	pe _ '<<error during printing>>'.
	strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe]).

	strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr.
	str _ [(self tempsAndValuesLimitedTo: 80 indent: 2) 
				padded: #right to: 1 with: $x] ifError: [:err :rcvr | pe].
	strm nextPutAll: (str allButLast).

	strm cr; tab; nextPutAll: 'Receiver''s instance variables: '; cr.
	pos _ strm position.
	[receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [:err :rcvr | 
				strm nextPutAll: pe].
	pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)"
		strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe])].
	strm peekLast == Character cr ifFalse: [strm cr].! !

!MethodContext methodsFor: 'printing' stamp: 'ajh 1/31/2003 20:34'!
printOn: aStream

	| h |
	self isExecutingBlock ifFalse: [^ super printOn: aStream].
	h _ self blockHome.
	h ifNil: [^ aStream nextPutAll: '[]'].
	aStream nextPutAll: '[] from '.
	h printOn: aStream! !

!MethodContext methodsFor: 'printing' stamp: 'emm 5/30/2002 14:07'!
printString
	"Answer an emphasized string in case of a breakpoint method"

	^self method hasBreakpoint
		ifTrue:[(super printString , ' [break]') asText allBold]
		ifFalse:[super printString]! !


!MethodContext methodsFor: 'private' stamp: 'di 1/14/1999 22:30'!
instVarAt: index put: value
	index = 3 ifTrue: [self stackp: value. ^ value].
	^ super instVarAt: index put: value! !

!MethodContext methodsFor: 'private' stamp: 'ikp 12/23/1999 15:56'!
setSender: s receiver: r method: m arguments: args 
	"Create the receiver's initial state."

	sender _ s.
	receiver _ r.
	method _ m.
	receiverMap _ nil.
	pc _ method initialPC.
	self stackp: method numTemps.
	1 to: args size do: [:i | self at: i put: (args at: i)]! !

!MethodContext methodsFor: 'private' stamp: 'ajh 8/13/2002 13:34'!
startpc

	^ self method initialPC! !


!MethodContext methodsFor: 'private-debugger' stamp: 'tfei 3/19/2000 23:55'!
cachedStackTop
	"WARNING - this method depends on a very dirty trick, viz. snitching information off the variable stack of a particular CompiledMethod.  So if you add/remove a temp in BlockContext>>valueUninterruptably, this method will fail, probably with some horrible consequences I'd rather not think through just now ... assumption is that the variable declaration in that method looks like:
		| sendingContext result homeSender |"

	^self tempAt: 3! !

!MethodContext methodsFor: 'private-debugger' stamp: 'ajh 1/24/2003 23:38'!
cachesStack

	^ false
	"^self selector == #valueUninterruptably
		and: [self receiver class == BlockContext]"! !

!MethodContext methodsFor: 'private-debugger' stamp: 'tfei 3/20/2000 00:24'!
hideFromDebugger

	| sndr sndrHome |
	^self cachesStack
		or: [(sndr := self sender) ~~ nil
			and: [(sndrHome := sndr home) ~~ nil
				and: [sndrHome cachesStack]]]! !


!MethodContext methodsFor: 'private-exceptions' stamp: 'ar 9/27/2005 20:24'!
cannotReturn: result

	ToolSet
		debugContext: thisContext
		label: 'computation has been terminated'
		contents: nil! !

!MethodContext methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 22:05'!
isHandlerContext
"is this context for  method that is marked?"
	^method primitive = 199! !

!MethodContext methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 22:05'!
isUnwindContext
"is this context for  method that is marked?"
	^method primitive = 198! !

!MethodContext methodsFor: 'private-exceptions' stamp: 'tfei 3/23/1999 13:00'!
receiver: r

	receiver := r! !

!MethodContext methodsFor: 'private-exceptions' stamp: 'ar 6/28/2003 00:10'!
restartWithNewReceiver: obj

	self
		swapReceiver: obj;
		restart! !

!MethodContext methodsFor: 'private-exceptions' stamp: 'ajh 10/8/2001 23:56'!
swapReceiver: r

	receiver := r! !


!MethodContext methodsFor: '*39Deprecated' stamp: 'md 2/17/2006 10:04'!
answer: anObject
	"ar 3/6/2001: OBSOLETE. Must not be used. Will be removed VERY SOON."
	
	self deprecated: 'ar 3/6/2001: OBSOLETE. Must not be used. Will be removed VERY SOON.'.
	
	"Modify my code, from the current program counter value, to answer anObject."
	self push: anObject.
	(method at: pc) = 124 ifFalse: [
		method _ (
			(method clone)
				at: pc + 1 put: 124;
				yourself)]! !

!MethodContext methodsFor: '*39Deprecated' stamp: 'md 2/17/2006 12:02'!
who
	self deprecated: 'please use #methodClass and #selector'.
	
	self method ifNil: [^ #(unknown unkown)].
	^ {self methodClass . self selector}.
! !

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

MethodContext class
	instanceVariableNames: ''!

!MethodContext class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:06'!
sender: s receiver: r method: m arguments: args 
	"Answer an instance of me with attributes set to the arguments."

	^(self newForMethod: m) setSender: s receiver: r method: m arguments: args! !


!MethodContext class methodsFor: 'closure support' stamp: 'md 2/20/2006 20:41'!
myEnvFieldIndex

	^ self allInstVarNames indexOf: 'receiverMap'! !
TestCase subclass: #MethodContextTest
	instanceVariableNames: 'aCompiledMethod aReceiver aMethodContext aSender'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Methods'!
!MethodContextTest commentStamp: 'tlk 5/31/2004 16:07' prior: 0!
I am an SUnit Test of MethodContext and its super type, ContextPart. See also BlockContextTest.
See pages 430-437 of A. Goldberg and D. Robson's  Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. (The Squeak byte codes are not quite the same as Smalltalk-80.)
My fixtures are:
aReceiver         - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200"
aSender           - just some arbitrary object, thisContext
aCompiledMethod - just some arbitrary method, "Rectangle rightCenter".
aMethodContext   - just some arbitray context ...  

!


!MethodContextTest methodsFor: 'running' stamp: 'tlk 5/31/2004 16:18'!
setUp
	super setUp.
	aCompiledMethod _ Rectangle methodDict at: #rightCenter.
	aReceiver _ 100@100 corner: 200@200.
	aSender _ thisContext.
	aMethodContext _ MethodContext sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). ! !


!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/30/2004 13:35'!
testActivateReturnValue
	self assert:  ((aSender activateReturn: aMethodContext value: #()) isKindOf: MethodContext).
	self assert:  ((aSender activateReturn: aMethodContext value: #()) receiver = aMethodContext).! !

!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 17:09'!
testCopyStack
	self assert: aMethodContext copyStack printString = aMethodContext printString.! !

!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 17:10'!
testFindContextSuchThat
	self assert: (aMethodContext findContextSuchThat: [:each| true]) printString = aMethodContext printString.
	self assert: (aMethodContext hasContext: aMethodContext). ! !

!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/30/2004 10:57'!
testMethodContext
	self deny: aMethodContext isPseudoContext.
	self assert: aMethodContext home notNil.
	self assert: aMethodContext receiver notNil.
	self assert: (aMethodContext method isKindOf: CompiledMethod).! !

!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 17:08'!
testMethodIsBottomContext
	self assert: aMethodContext bottomContext = aSender.
	self assert: aMethodContext secondFromBottom = aMethodContext.! !

!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 16:55'!
testReturn
	"Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp."
	aMethodContext _ MethodContext sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #(). 
	self assert: (aMethodContext return: 5) = 5.! !

!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 16:52'!
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 assert: aMethodContext isMethodContext.
	self deny: aMethodContext isBlockClosure.
	self deny: aMethodContext isPseudoContext.
	self deny: aMethodContext isDead.
	"self assert: aMethodContext home = aReceiver."
	"self assert: aMethodContext blockHome = aReceiver."
	self assert: aMethodContext receiver = aReceiver.
	self assert: (aMethodContext method isKindOf: CompiledMethod).
	self assert: aMethodContext method = aCompiledMethod.
	self assert: aMethodContext methodNode selector = #rightCenter.
	self assert: (aMethodContext methodNodeFormattedAndDecorated: true) selector = #rightCenter.
	self assert: aMethodContext client printString = 'MethodContextTest>>#testSetUp'.
! !
Dictionary variableSubclass: #MethodDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!MethodDictionary commentStamp: '<historical>' prior: 0!
I am just like a normal Dictionary, except that I am implemented differently.  Each Class has an instances of MethodDictionary to hold the correspondence between selectors (names of methods) and methods themselves.

In a normal Dictionary, the instance variable 'array' holds an array of Associations.  Since there are thousands of methods in the system, these Associations waste space.  

Each MethodDictionary is a variable object, with the list of keys (selector Symbols) in the variable part of the instance.  The variable 'array' holds the values, which are CompiledMethods.!


!MethodDictionary methodsFor: 'accessing'!
add: anAssociation
	^ self at: anAssociation key put: anAssociation value! !

!MethodDictionary methodsFor: 'accessing'!
at: key ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: key.
	(self basicAt: index) == nil ifTrue: [ ^ aBlock value ].
	^ array at: index! !

!MethodDictionary methodsFor: 'accessing' stamp: 'ar 10/12/2000 17:25'!
at: key put: value
	"Set the value at key to be value."
	| index |
	index _ self findElementOrNil: key.
	(self basicAt: index) == nil
		ifTrue: 
			[tally _ tally + 1.
			self basicAt: index put: key]
		ifFalse:
			[(array at: index) flushCache].
	array at: index put: value.
	self fullCheck.
	^ value! !

!MethodDictionary methodsFor: 'accessing' stamp: 'raa 5/30/2001 15:04'!
at: key putNoBecome: value

	"Set the value at key to be value. Answer the resulting MethodDictionary"
	| index |
	index _ self findElementOrNil: key.
	(self basicAt: index) == nil
		ifTrue: 
			[tally _ tally + 1.
			self basicAt: index put: key]
		ifFalse:
			[(array at: index) flushCache].
	array at: index put: value.
	^self fullCheckNoBecome! !

!MethodDictionary methodsFor: 'accessing' stamp: 'tk 6/30/2000 00:14'!
includesKey: aSymbol
	"This override assumes that pointsTo is a fast primitive"

	aSymbol ifNil: [^ false].
	^ super pointsTo: aSymbol! !

!MethodDictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:17'!
keyAtIdentityValue: value ifAbsent: exceptionBlock
	"Answer the key whose value equals the argument, value. If there is
	none, answer the result of evaluating exceptionBlock."
	| theKey |
	1 to: self basicSize do:
		[:index |
		value == (array at: index)
			ifTrue:
				[(theKey _ self basicAt: index) == nil
					ifFalse: [^ theKey]]].
	^ exceptionBlock value! !

!MethodDictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:00'!
keyAtValue: value ifAbsent: exceptionBlock
	"Answer the key whose value equals the argument, value. If there is
	none, answer the result of evaluating exceptionBlock."
	| theKey |
	1 to: self basicSize do:
		[:index |
		value = (array at: index)
			ifTrue:
				[(theKey _ self basicAt: index) == nil
					ifFalse: [^ theKey]]].
	^ exceptionBlock value! !

!MethodDictionary methodsFor: 'accessing' stamp: 'NS 3/30/2004 13:42'!
keys
	"Since method all method selectors are symbols it is more efficient 
	to use an IdentitySet rather than a Set."
	| aSet |
	aSet _ IdentitySet new: self size.
	self keysDo: [:key | aSet add: key].
	^ aSet! !


!MethodDictionary methodsFor: 'enumeration'!
associationsDo: aBlock 
	| key |
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (key _ self basicAt: i) == nil ifFalse:
			[aBlock value: (Association key: key
									value: (array at: i))]]! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'to 1/14/98 10:13'!
do: aBlock 
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (self basicAt: i) == nil ifFalse:
			[aBlock value: (array at: i)]]
! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'ar 7/11/1999 08:05'!
keysAndValuesDo: aBlock 
	"Enumerate the receiver with all the keys and values passed to the block"
	| key |
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (key _ self basicAt: i) == nil ifFalse:
			[aBlock value: key value: (array at: i)]
		]! !

!MethodDictionary methodsFor: 'enumeration'!
keysDo: aBlock 
	| key |
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (key _ self basicAt: i) == nil
			ifFalse: [aBlock value: key]]! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'ar 7/11/1999 07:29'!
valuesDo: aBlock 
	| value |
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (value _ array at: i) == nil
			ifFalse: [aBlock value: value]]! !


!MethodDictionary methodsFor: 'removing'!
removeKey: key ifAbsent: errorBlock 
	"The interpreter might be using this MethodDict while
	this method is running!!  Therefore we perform the removal
	in a copy, and then atomically become that copy"
	| copy |
	copy _ self copy.
	copy removeDangerouslyKey: key ifAbsent: [^ errorBlock value].
	self become: copy! !

!MethodDictionary methodsFor: 'removing' stamp: 'raa 5/30/2001 15:19'!
removeKeyNoBecome: key

	"The interpreter might be using this MethodDict while
	this method is running!!  Therefore we perform the removal
	in a copy, and then return the copy for subsequent installation"

	| copy |
	copy _ self copy.
	copy removeDangerouslyKey: key ifAbsent: [^ self].
	^copy! !



!MethodDictionary methodsFor: 'private' stamp: 'tk 8/21/97 16:26'!
copy
	^ self shallowCopy withArray: array shallowCopy! !

!MethodDictionary methodsFor: 'private' stamp: 'raa 5/30/2001 15:03'!
fullCheckNoBecome

	"Keep array at least 1/4 free for decent hash behavior"
	array size - tally < (array size // 4 max: 1)
		ifTrue: [^self growNoBecome].
	^self
! !

!MethodDictionary methodsFor: 'private' stamp: 'di 11/4/97 20:11'!
grow 
	| newSelf key |
	newSelf _ self species new: self basicSize.  "This will double the size"
	1 to: self basicSize do:
		[:i | key _ self basicAt: i.
		key == nil ifFalse: [newSelf at: key put: (array at: i)]].
	self become: newSelf! !

!MethodDictionary methodsFor: 'private' stamp: 'raa 5/30/2001 15:02'!
growNoBecome
 
	| newSelf key |

	newSelf _ self species new: self basicSize.  "This will double the size"
	1 to: self basicSize do:
		[:i | key _ self basicAt: i.
		key == nil ifFalse: [newSelf at: key put: (array at: i)]].
	^newSelf! !

!MethodDictionary methodsFor: 'private'!
keyAt: index

	^ self basicAt: index! !

!MethodDictionary methodsFor: 'private'!
methodArray
	^ array! !

!MethodDictionary methodsFor: 'private'!
rehash 
	| newSelf key |
	newSelf _ self species new: self size.
	1 to: self basicSize do:
		[:i | key _ self basicAt: i.
		key == nil ifFalse: [newSelf at: key put: (array at: i)]].
	self become: newSelf! !

!MethodDictionary methodsFor: 'private' stamp: 'RAA 12/17/2000 11:11'!
rehashWithoutBecome
	| newSelf key |
	newSelf _ self species new: self size.
	1 to: self basicSize do:
		[:i | key _ self basicAt: i.
		key == nil ifFalse: [newSelf at: key put: (array at: i)]].
	^newSelf! !

!MethodDictionary methodsFor: 'private'!
removeDangerouslyKey: key ifAbsent: aBlock
	"This is not really dangerous.  But if normal removal
	were done WHILE a MethodDict were being used, the
	system might crash.  So instead we make a copy, then do
	this operation (which is NOT dangerous in a copy that is
	not being used), and then use the copy after the removal."

	| index element |
	index _ self findElementOrNil: key.
	(self basicAt: index) == nil ifTrue: [ ^ aBlock value ].
	element _ array at: index.
	array at: index put: nil.
	self basicAt: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ element! !

!MethodDictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:43'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	finish _ array size.
	start _ (anObject identityHash \\ finish) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ self basicAt: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ self basicAt: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!MethodDictionary methodsFor: 'private'!
swap: oneIndex with: otherIndex
	| element |
	element _ self basicAt: oneIndex.
	self basicAt: oneIndex put: (self basicAt: otherIndex).
	self basicAt: otherIndex put: element.
	super swap: oneIndex with: otherIndex.
! !

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

MethodDictionary class
	instanceVariableNames: ''!

!MethodDictionary class methodsFor: 'instance creation' stamp: 'RAA 5/29/2001 09:53'!
new
	"change the default size to be a bit bigger to help reduce the number of #grows while filing in"
	^self new: 16! !

!MethodDictionary class methodsFor: 'instance creation' stamp: 'nice 4/4/2006 22:09'!
new: nElements
	"Create a Dictionary large enough to hold nElements without growing.
	Note that the basic size must be a power of 2.
	It is VITAL (see grow) that size gets doubled if nElements is a power of 2"
	| size |
	size _ 1 bitShift: nElements highBit.
	^ (self basicNew: size) initialize: size! !
Object subclass: #MethodFinder
	instanceVariableNames: 'data answers selector argMap thisData mapStage mapList expressions cachedClass cachedArgNum cachedSelectorLists'
	classVariableNames: 'AddAndRemove Approved Blocks Dangerous'
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!MethodFinder commentStamp: '<historical>' prior: 0!
Find a method in the system from a set of examples.  Done by brute force, trying every possible selector.  Errors are skipped over using ( [3 + 'xyz'] ifError: [^ false] ).
Submit an array of the form ((data1 data2) answer  (data1 data2) answer).

	MethodFinder methodFor: #( (4 3) 7  (0 5) 5  (5 5) 10).

answer:  'data1 + data2'

More generally, use the brace notation to construct live examples.

The program tries data1 as the receiver, and
	tries all other permutations of the data for the receiver and args, and
	tries leaving out one argument, and
	uses all selectors data understands, and
	uses all selectors in all od data's superclasses.

Floating point values must be precise to 0.01 percent, or (X * 0.0001).

If you get an error, you have probably discovered a selector that needs to be removed from the Approved list.  See MethodFinder.initialize.  Please email the Squeak Team.

Only considers 0, 1, 2, and 3 argument messages.  The argument data may have 1 to 5 entries, but only a max of 4 used at a time.  For now, we only test messages that use given number of args or one fewer.  For example, this data (100 true 0.6) would test the receiver plus two args, and the receiver plus one arg, but not any other patterns.

Three sets of selectors:  Approved, AddAndRemove, and Blocks selectors.  When testing a selector in AddAndRemove, deepCopy the receiver.  We do not handle selectors that modify an argument (printOn: etc.).  Blocks is a set of (selector argNumber) where that argument must be a block.

For perform, the selector is tested.  It must be in the Approved list.

do: is not on the Approved list.  It does not produce a result that can be tested.  Type 'do' into the upper pane of the Selector Finder to find messages list that.

[Later, allow the user to supply a block that tests the answer, not just the literal answer.]
	MethodFinder methodFor: { { true. [3]. [4]}. 3}. 
Later allow this to work without the blocks around 3 and 4.!


!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:39'!
answers

	^ answers! !

!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:39'!
data

	^ data! !

!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:20'!
expressions
	^ expressions! !

!MethodFinder methodsFor: 'access' stamp: 'tk 1/4/2001 17:18'!
selectors
	"Note the inst var does not have an S on the end"

	^ selector! !


!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'!
argMap
	^ argMap ! !

!MethodFinder methodsFor: 'arg maps' stamp: 'tk 5/18/1999 14:46'!
makeAllMaps 
	"Make a giant list of all permutations of the args.  To find the function, we will try these permutations of the input data.  receiver, args."

	| ii |
	mapList _ Array new: argMap size factorial.
	ii _ 1.
	argMap permutationsDo: [:perm |
		mapList at: ii put: perm copy.
		ii _ ii + 1].
	mapStage _ 1.	"about to be bumped"! !

!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'!
mapData 
	"Force the data through the map (permutation) to create the data to test."

	thisData _ data collect: [:realData |
					argMap collect: [:ind | realData at: ind]].
		! !

!MethodFinder methodsFor: 'arg maps' stamp: 'tk 5/24/1999 16:31'!
permuteArgs 
	"Run through ALL the permutations.  First one was as presented."

	data first size <= 1 ifTrue: [^ false].	"no other way"
	mapList ifNil: [self makeAllMaps].
	mapStage _ mapStage + 1.
	mapStage > mapList size ifTrue: [^ false].
	argMap _ mapList at: mapStage.
	self mapData.
	^ true
	! !

!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'!
thisData
	^ thisData ! !


!MethodFinder methodsFor: 'find a constant' stamp: 'tk 12/29/2000 22:34'!
allNumbers
	"Return true if all answers and all data are numbers."

	answers do: [:aa | aa isNumber ifFalse: [^ false]].
	thisData do: [:vec |
			vec do: [:nn | nn isNumber ifFalse: [^ false]]].
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/18/2001 22:45'!
const
	| const |
	"See if (^ constant) is the answer"

	"quick test"
	((const _ answers at: 1) closeTo: (answers at: 2)) ifFalse: [^ false].
	3 to: answers size do: [:ii | (const closeTo: (answers at: ii)) ifFalse: [^ false]].
	expressions add: '^ ', const printString.
	selector add: #yourself.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:49'!
constDiv
	| const subTest got |
	"See if (data1 // C) is the answer"

	const _ ((thisData at: 1) at: 1) // (answers at: 1).  "May not be right!!"
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'md 11/14/2003 16:47'!
constEquiv
	| const subTest got jj |
	"See if (data1 = C) or (data1 ~= C) is the answer"

	"quick test"
	((answers at: 1) class superclass == Boolean) ifFalse: [^ false].
	2 to: answers size do: [:ii | 
		((answers at: ii) class superclass == Boolean) ifFalse: [^ false]].

	const _ (thisData at: 1) at: 1.
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: ["try other polarity for ~~ "
		(jj _ answers indexOf: (answers at: 1) not) > 0 ifTrue: [
		const _ (thisData at: jj) at: 1.
		got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not]]. 
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:47'!
constLinear
	| const subTest got denom num slope offset |
	"See if (data1 * C1) + C2 is the answer.  In the form  #(C2 C1) polynomialEval: data1 "

	denom _ ((thisData at: 2) at: 1) - ((thisData at: 1) at: 1).
	denom = 0 ifTrue: [^ false].   "will divide by it"
	num _ (answers at: 2) - (answers at: 1).

    slope := (num asFloat / denom) reduce.
    offset := ((answers at: 2) - (((thisData at: 2) at: 1) * slope)) reduce.

	const _ Array with: offset with: slope.
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/18/2001 22:46'!
constMod
	| subTest low |
	"See if mod, (data1 \\ C) is the answer"

	low _ answers max.
	low+1 to: low+20 do: [:const |
		subTest _ MethodFinder new copy: self addArg: const.
		(subTest testPerfect: #\\) ifTrue: [
			expressions add: 'data1 \\ ', const printString.
			selector add: #\\.
			^ true]].
	^ false! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:49'!
constMult
	| const subTest got |
	"See if (data1 * C) is the answer"

	((thisData at: 1) at: 1) = 0 ifTrue: [^ false].
	const _ ((answers at: 1) asFloat / ((thisData at: 1) at: 1)) reduce.
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:48'!
constPlus
	| const subTest got |
	"See if (data1 + C) is the answer"

	const _ (answers at: 1) - ((thisData at: 1) at: 1).
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 4/9/2001 17:59'!
constUsingData1Value
	| const subTest got |
	"See if (data1 <= C) or (data1 >= C) is the answer"

	"quick test"
	((answers at: 1) class superclass == Boolean) ifFalse: [^ false].
	2 to: answers size do: [:ii | 
		((answers at: ii) class superclass == Boolean) ifFalse: [^ false]].

	thisData do: [:datums | 
		const _ datums first.	"use data as a constant!!"
		got _ (subTest _ MethodFinder new copy: self addArg: const) 
					searchForOne isEmpty not.
		got ifTrue: [
			"replace data2 with const in expressions"
			subTest expressions do: [:exp |
				expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
			selector addAll: subTest selectors.
			^ true]].
	^ false! !


!MethodFinder methodsFor: 'initialize' stamp: 'tk 7/1/2000 23:11'!
cleanInputs: dataAndAnswerString
	"Find an remove common mistakes.  Complain when ill formed."

| fixed ddd rs places |
ddd _ dataAndAnswerString.
fixed _ false.

rs _ ReadStream on: ddd, ' '.
places _ OrderedCollection new.
[rs upToAll: '#true'.  rs atEnd] whileFalse: [places addFirst: rs position-4]. 
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
	fixed _ true]. 	"remove #"

rs _ ReadStream on: ddd.
places _ OrderedCollection new.
[rs upToAll: '#false'.  rs atEnd] whileFalse: [places addFirst: rs position-5]. 
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
	fixed _ true]. 	"remove #"

fixed ifTrue: [self inform: '#(true false) are Symbols, not Booleans.  
Next time use { true. false }.'].

fixed _ false.
rs _ ReadStream on: ddd.
places _ OrderedCollection new.
[rs upToAll: '#nil'.  rs atEnd] whileFalse: [places addFirst: rs position-3]. 
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
	fixed _ true]. 	"remove #"

fixed ifTrue: [self inform: '#nil is a Symbol, not the authentic UndefinedObject.  
Next time use nil instead of #nil'].

^ ddd
! !

!MethodFinder methodsFor: 'initialize' stamp: 'md 11/14/2003 16:47'!
copy: mthFinder addArg: aConstant
	| more |
	"Copy inputs and answers, add an additional data argument to the inputs.  The same constant for every example"

	more _ Array with: aConstant.
	data _ mthFinder data collect: [:argList | argList, more].
	answers _ mthFinder answers.
	self load: nil.
! !

!MethodFinder methodsFor: 'initialize' stamp: 'md 2/17/2006 12:00'!
initialize
	"The methods we are allowed to use.  (MethodFinder new initialize) "

	Approved _ Set new.
	AddAndRemove _ Set new.
	Blocks _ Set new.
	"These modify an argument and are not used by the MethodFinder: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom: printOn:format:"

"Object"  
	#("in class, instance creation" categoryForUniclasses chooseUniqueClassName initialInstance isSystemDefined newFrom: officialClass readCarefullyFrom:
"accessing" at: basicAt: basicSize bindWithTemp: in: size yourself 
"testing" basicType ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInMemory isInteger isMorph isNil isNumber isPoint isPseudoContext isText isTransparent isWebBrowser knownName notNil pointsTo: wantsSteps 
"comparing" = == closeTo: hash hashMappedBy: identityHash identityHashMappedBy: identityHashPrintString ~= ~~ 
"copying" clone copy shallowCopy 
"dependents access" canDiscardEdits dependents hasUnacceptedEdits 
"updating" changed changed: okToChange update: windowIsClosing 
"printing" fullPrintString isLiteral longPrintString printString storeString stringForReadout stringRepresentation 
"class membership" class isKindOf: isKindOf:orOf: isMemberOf: respondsTo: xxxClass 
"error handling" 
"user interface" addModelMenuItemsTo:forMorph:hand: defaultBackgroundColor defaultLabelForInspector fullScreenSize initialExtent modelWakeUp mouseUpBalk: newTileMorphRepresentative windowActiveOnFirstClick windowReqNewLabel: 
"system primitives" asOop instVarAt: instVarNamed: 
"private" 
"associating" -> 
"converting" as: asOrderedCollection asString 
"casing" caseOf: caseOf:otherwise: 
"binding" bindingOf: 
"macpal" contentsChanged currentEvent currentHand currentWorld flash instanceVariableValues scriptPerformer 
"flagging" flag: 
"translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel].
	#(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:"
"message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass: 
) do: [:sel | AddAndRemove add: sel].

"Boolean, True, False, UndefinedObject"  
	#("logical operations" & eqv: not xor: |
"controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or:
"copying" 
"testing" isEmptyOrNil) do: [:sel | Approved add: sel].

"Behavior" 
	#("initialize-release"
"accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass
"testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords
"copying"
"printing" defaultNameStemForInstances printHierarchy
"creating class hierarchy"
"creating method dictionary"
"instance creation" basicNew basicNew: new new:
"accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses
"accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent:
"accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames
"testing class hierarchy" inheritsFrom: kindOfSubclass
"testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto:
"enumerating"
"user interface"
"private" indexIfCompact) do: [:sel | Approved add: sel].

"ClassDescription"
	#("initialize-release" 
"accessing" classVersion isMeta name theNonMetaClass
"copying" 
"printing" classVariablesString instanceVariablesString sharedPoolsString
"instance variables" checkForInstVarsOK: 
"method dictionary" 
"organization" category organization whichCategoryIncludesSelector:
"compiling" acceptsLoggingOfCompilation wantsChangeSetLogging
"fileIn/Out" definition
"private" ) do: [:sel | Approved add: sel].

"Class"
	#("initialize-release" 
"accessing" classPool
"testing"
"copying" 
"class name" 
"instance variables" 
"class variables" classVarAt: classVariableAssociationAt:
"pool variables" 
"compiling" 
"subclass creation" 
"fileIn/Out" ) do: [:sel | Approved add: sel]. 

"Metaclass"
	#("initialize-release" 
"accessing" isSystemDefined soleInstance
"copying" "instance creation" "instance variables"  "pool variables" "class hierarchy"  "compiling"
"fileIn/Out"  nonTrivial ) do: [:sel | Approved add: sel].

"Context, BlockContext"
	#(receiver client method receiver tempAt: 
"debugger access" pc selector sender shortStack sourceCode tempNames tempsAndValues
"controlling"  "printing" "system simulation" 
"initialize-release" 
"accessing" hasMethodReturn home numArgs
"evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments:
"controlling"  "scheduling"  "instruction decoding"  "printing" "private"  "system simulation" ) do: [:sel | Approved add: sel].
	#(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel].

"Message"
	#("inclass, instance creation" selector: selector:argument: selector:arguments:
"accessing" argument argument: arguments sends:
"printing" "sending" ) do: [:sel | Approved add: sel].
	#("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel].

"Magnitude"
	#("comparing" < <= > >= between:and:
"testing" max: min: min:max: ) do: [:sel | Approved add: sel].

"Date, Time"
	#("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today
	"in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth:
"accessing" day leap monthIndex monthName weekday year
"arithmetic" addDays: subtractDate: subtractDays:
"comparing"
"inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous:
"converting" asSeconds
"printing"  mmddyyyy printFormat: 
"private" weekdayIndex 
	"in class, instance creation" fromSeconds: now 
	"in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds
"accessing" hours minutes seconds
"arithmetic" addTime: subtractTime:
"comparing"
"printing" intervalString print24 
"converting") do: [:sel | Approved add: sel].
	#("private" 
		 ) do: [:sel | AddAndRemove add: sel].

"Number"
	#("in class" readFrom:base: 
"arithmetic" * + - / // \\ abs negated quo: reciprocal rem:
"mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan
"truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated
"comparing"
"testing" even isDivisibleBy: isInf isInfinite isNaN isZero negative odd positive sign strictlyPositive
"converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees
"intervals" to: to:by: 
"printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel].

"Integer"
	#("in class" primesUpTo:
"testing" isPowerOfTwo
"arithmetic" alignedTo:
"comparing"
"truncation and round off" atRandom normalize
"enumerating" timesRepeat:
"mathematical functions" degreeCos degreeSin factorial gcd: lcm: take:
"bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask:
"converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit
"printing" asStringWithCommas hex hex8 radix:
"system primitives" lastDigit replaceFrom:to:with:startingAt:
"private" "benchmarks" ) do: [:sel | Approved add: sel].

"SmallInteger, LargeNegativeInteger, LargePositiveInteger"
	#("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing" 
"system primitives" digitAt: digitLength 
"private" fromString:radix: ) do: [:sel | Approved add: sel].
	#(digitAt:put: ) do: [:sel | AddAndRemove add: sel].

"Float"
	#("arithmetic"
"mathematical functions" reciprocalFloorLog: reciprocalLogBase2 timesTwoPower:
"comparing" "testing"
"truncation and round off" exponent fractionPart integerPart significand significandAsInteger
"converting" asApproximateFraction asIEEE32BitWord asTrueFraction
"copying") do: [:sel | Approved add: sel].

"Fraction, Random"
	#(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel].
	#(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel].

"Collection"
	#("accessing" anyOne
"testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf:
"enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect: intersection:
"converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection:
"printing"
"private" maxSize
"arithmetic"
"math functions" average max median min range sum) do: [:sel | Approved add: sel].
	#("adding" add: addAll: addIfNotPresent:
"removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel].

"SequenceableCollection"
	#("comparing" hasEqualElements:
"accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third
"removing"
"copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sortBy:
"enumerating" collectWithIndex: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval:
"converting" asArray asDictionary asFloatArray asIntegerArray asStringWithCr asWordArray reversed
"private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel].
	#( swap:with:) do: [:sel | AddAndRemove add: sel].

"ArrayedCollection, Bag"
	#("private" defaultElement 
"sorting" isSorted
"accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating" 
	) do: [:sel | Approved add: sel].
	#( mergeSortFrom:to:by: sort sort: add: add:withOccurrences:
"private" setDictionary ) do: [:sel | AddAndRemove add: sel].

"Other messages that modify the receiver"
	#(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with:  removeFirst removeLast) do: [:sel | AddAndRemove add: sel].

	self initialize2.

"
MethodFinder new initialize.
MethodFinder new organizationFiltered: Set
"

! !

!MethodFinder methodsFor: 'initialize' stamp: 'md 1/17/2006 17:57'!
initialize2
	"The methods we are allowed to use.  (MethodFinder new initialize) "

"Set"
	#("in class" sizeFor:
"testing" "adding" "removing" "enumerating"
"private" array findElementOrNil: 
"accessing" someElement) do: [:sel | Approved add: sel].

"Dictionary, IdentityDictionary, IdentitySet"
	#("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys
"testing" includesKey: ) do: [:sel | Approved add: sel].
	#(removeKey: removeKey:ifAbsent:
) do: [:sel | AddAndRemove add: sel].

"LinkedList, Interval, MappedCollection"
	#("in class"  from:to: from:to:by:
"accessing" contents) do: [:sel | Approved add: sel].
	#(
"adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel].

"OrderedCollection, SortedCollection"
	#("accessing" after: before:
"copying" copyEmpty
"adding"  growSize
"removing" "enumerating" "private" 
"accessing" sortBlock) do: [:sel | Approved add: sel].
	#("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast:
"removing" removeAt: removeFirst removeLast
"accessing" sortBlock:) do: [:sel | AddAndRemove add: sel].

"Character"
	#("in class, instance creation" allCharacters digitValue: new separators
	"accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab
	"constants" alphabet characterTable
"accessing" asciiValue digitValue
"comparing"
"testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish
"copying"
"converting" asIRCLowercase asLowercase asUppercase
	) do: [:sel | Approved add: sel].

"String"
	#("in class, instance creation" crlf fromPacked:
	"primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: 	"internet" valueOfHtmlEntity:
"accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubString: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit
"comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt:
"copying" copyReplaceTokens:with: padded:to:with:
"converting" asByteArray asDate asDisplayText asFileName asHtml asLegalSelector asPacked asParagraph asText asTime asUnHtml asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks
"displaying" "printing"
"system primitives" compare:with:collated: 
"Celeste" withCRs
"internet" decodeMimeHeader decodeQuotedPrintable unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting
"testing" isAllSeparators lastSpacePosition
"paragraph support" indentationIfBlank:
"arithmetic" ) do: [:sel | Approved add: sel].
	#(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel].

"Symbol"
	#("in class, private" hasInterned:ifTrue:
	"access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping:
"accessing" "comparing" "copying" "converting" "printing" 
"testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel].

"Array"
	#("comparing" "converting" evalStrings 
"printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel].

"Array2D"
	#("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel].
	#(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel].

"ByteArray"
	#("accessing" doubleWordAt: wordAt: 
"platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian: 
"converting") do: [:sel | Approved add: sel].
	#(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian:
	) do: [:sel | AddAndRemove add: sel].

"FloatArray"		"Dont know what happens when prims not here"
	false ifTrue: [#("accessing" "arithmetic" *= += -= /=
"comparing"
"primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar:
"primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to:
"converting" "private" "user interface") do: [:sel | Approved add: sel].
	].

"IntegerArray, WordArray"
"RunArray"
	#("in class, instance creation" runs:values: scanFrom:
"accessing" runLengthAt: 
"adding" "copying"
"private" runs values) do: [:sel | Approved add: sel].
	#(coalesce addLast:times: repeatLast:ifEmpty: repeatLastIfEmpty:
		) do: [:sel | AddAndRemove add: sel].

"Stream  -- many operations change its state"
	#("testing" atEnd) do: [:sel | Approved add: sel].
	#("accessing" next: nextMatchAll: nextMatchFor: upToEnd
next:put: nextPut: nextPutAll: "printing" print: printHtml:
	) do: [:sel | AddAndRemove add: sel].

"PositionableStream"
	#("accessing" contentsOfEntireFile originalContents peek peekFor: "testing"
"positioning" position ) do: [:sel | Approved add: sel].
	#(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel].
	"Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics.  We want to find the messages that convert Streams to other things."

"ReadWriteStream"
	#("file status" closed) do: [:sel | Approved add: sel].
	#("accessing" next: on: ) do: [:sel | AddAndRemove add: sel].

"WriteStream"
	#("in class, instance creation" on:from:to: with: with:from:to:
		) do: [:sel | Approved add: sel].
	#("positioning" resetToStart
"character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel].

"LookupKey, Association, Link"
	#("accessing" key nextLink) do: [:sel | Approved add: sel].
	#(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel].

"Point"
	#("in class, instance creation" r:degrees: x:y:
"accessing" x y "comparing" "arithmetic" "truncation and round off"
"polar coordinates" degrees r theta
"point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector
"converting" asFloatPoint asIntegerPoint corner: extent: rect:
"transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying"
"interpolating" interpolateTo:at:) do: [:sel | Approved add: sel].

"Rectangle"
	#("in class, instance creation" center:extent: encompassing: left:right:top:bottom: 
	merging: origin:corner: origin:extent: 
"accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight
"comparing"
"rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth:
"testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide
"truncation and round off"
"transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying"
	) do: [:sel | Approved add: sel].

"Color"
	#("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range:
	"named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow
	"other" colorNames indexedColors pixelScreenForDepth: quickHighLight:
"access" alpha blue brightness green hue luminance red saturation
"equality"
"queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor
"transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with:
"groups of shades" darkShades: lightShades: mix:shades: wheel:
"printing" shortPrintString
"other" colorForInsets rgbTriplet
"conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32
"private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying"
	) do: [:sel | Approved add: sel].

"	For each selector that requires a block argument, add (selector argNum) 
		to the set Blocks."
"ourClasses _ #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color).
ourClasses do: [:clsName | cls _ Smalltalk at: clsName.
	(cls selectors) do: [:aSel |
		((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
			(cls formalParametersAt: aSel) withIndexDo: [:tName :ind |
				(tName endsWith: 'Block') ifTrue: [
					Blocks add: (Array with: aSel with: ind)]]]]].
"
#((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 )  (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray |
	Blocks add: anArray].

self initialize3.

"
MethodFinder new initialize.
MethodFinder new organizationFiltered: TranslucentColor class 
"
"Do not forget class messages for each of these classes"
! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/1/2002 11:33'!
initialize3
	"additional selectors to consider"

#(asWords threeDigitName ) do: [:sel | Approved add: sel].! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 12/29/2000 13:22'!
load: dataWithAnswers
	"Find a function that takes the data and gives the answers.  Odd list entries are data for it, even ones are the answers.  nil input means data and answers were supplied already."
"  (MethodFinder new) load: #( (4 3) 7  (-10 5) -5  (-3 11) 8);
		findMessage  "

dataWithAnswers ifNotNil: [
	data _ Array new: dataWithAnswers size // 2.
	1 to: data size do: [:ii | data at: ii put: (dataWithAnswers at: ii*2-1)].
	answers _ Array new: data size.
	1 to: answers size do: [:ii | answers at: ii put: (dataWithAnswers at: ii*2)]].
data do: [:list | 
	(list isKindOf: SequenceableCollection) ifFalse: [
		^ self inform: 'first and third items are not Arrays'].
	].
argMap _ (1 to: data first size) asArray.
data do: [:list | list size = argMap size ifFalse: [
		self inform: 'data arrays must all be the same size']].
argMap size > 4 ifTrue: [self inform: 'No more than a receiver and 
three arguments allowed'].
	"Really only test receiver and three args." 
thisData _ data copy.
mapStage _ mapList _ nil.
! !

!MethodFinder methodsFor: 'initialize' stamp: 'md 2/22/2006 21:21'!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#()
		do: [:sel | Dangerous add: sel].

"Behavior"
	#(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: 
"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
   "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:)
		do: [:sel | Dangerous add: sel].

"CompiledMethod"
	#(defaultSelector)
		do: [:sel | Dangerous add: sel].

"Others "
	#("no tangible result" do: associationsDo:  
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
		do: [:sel | Dangerous add: sel].


	#(    fileOutPrototype addSpareFields makeFileOutFile )
		do: [:sel | Dangerous add: sel].
	#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/14/1999 11:16'!
organizationFiltered: aClass
	"Return the organization of the class with all selectors defined in superclasses removed.  (except those in Object)"

	| org str |
	org _ aClass organization deepCopy.
	Dangerous do: [:sel |
			org removeElement: sel].
	Approved do: [:sel |
			org removeElement: sel].
	AddAndRemove do: [:sel |
			org removeElement: sel].
	str _ org printString copyWithout: $(.
	str _ '(', (str copyWithout: $) ).
	str _ str replaceAll: $' with: $".
	^ str
! !

!MethodFinder methodsFor: 'initialize' stamp: 'ar 4/10/2005 18:48'!
test2: anArray
	"look for bad association"

	anArray do: [:sub |
		sub class == Association ifTrue: [
			(#('true' '$a' '2' 'false') includes: sub value printString) ifFalse: [
				self error: 'bad assn'].
			(#('3' '5.6' 'x' '''abcd''') includes: sub key printString) ifFalse: [
				self error: 'bad assn'].
		].
		sub class == Array ifTrue: [
			sub do: [:element | 
				element isString ifTrue: [element first asciiValue < 32 ifTrue: [
						self error: 'store into string in data']].
				element class == Association ifTrue: [
					element value class == Association ifTrue: [
						self error: 'bad assn']]]].
		sub class == Date ifTrue: [sub year isInteger ifFalse: [
				self error: 'stored into input date!!!!']].
		sub class == Dictionary ifTrue: [
				sub size > 0 ifTrue: [
					self error: 'store into dictionary']].
		sub class == OrderedCollection ifTrue: [
				sub size > 4 ifTrue: [
					self error: 'store into OC']].
		].! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/24/1999 19:34'!
test3
	"find the modification of the caracter table"

	(#x at: 1) asciiValue = 120 ifFalse: [self error: 'Character table mod'].! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 5/4/1999 20:18'!
testFromTuple: nth
	"verify that the methods allowed don't crash the system.  Try N of each of the fundamental types.  up to 4 of each kind." 

| objects nonRepeating even other aa cnt |
objects _ #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four')
	(x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3)
	).

objects _ objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}.
	{Point class. SmallInteger class. Association class. Array class}.
	"{ 4 blocks }."
	{Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}.
	{'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}.
	{Dictionary new. Dictionary new. Dictionary new. Dictionary new}.
	{#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. 
		#($a 3 d) asOrderedCollection. #() asOrderedCollection}.
	{3->true. 5.6->$a. #x->2. 'abcd'->false}.
	{9@3 extent: 5@4. 0@0 extent: 45@9. -3@-7 extent: 2@2. 4@4 extent: 16@16}.
	{Color red.  Color blue. Color black. Color gray}}.

self test2: objects.
"rec+0, rec+1, rec+2, rec+3 need to be tested.  " 
cnt _ 0.
nth to: 4 do: [:take |
	nonRepeating _ OrderedCollection new.
	objects do: [:each |
		nonRepeating addAll: (each copyFrom: 1 to: take)].
	"all combinations of take, from nonRepeating"
	even _ true.
	nonRepeating combinations: take atATimeDo: [:tuple |
		even ifTrue: [other _ tuple clone]
			ifFalse: [self load: (aa _ Array with: tuple with: 1 with: other with: 7).
				(cnt _ cnt+1) \\ 50 = 0 ifTrue: [
					Transcript cr; show: aa first printString].
				self search: true.
				self test2: aa.
				self test2: nonRepeating.
				"self test2: objects"].
		even _ even not].
	].! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 5/4/1999 20:19'!
testRandom
	"verify that the methods allowed don't crash the system.  Pick 3 or 4 from a mixed list of the fundamental types." 

| objects other aa cnt take tuple fName sss |
objects _ #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four')
	(x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3)
	).

objects _ objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}.
	{Point class. SmallInteger class. Association class. Array class}.
	"{ 4 blocks }."
	{Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}.
	{'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}.
	{Dictionary new. Dictionary new. Dictionary new. Dictionary new}.
	{#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. 
		#($a 3 d) asOrderedCollection. #() asOrderedCollection}.
	{3->true. 5.6->$a. #x->2. 'abcd'->false}.
	{9@3 extent: 5@4. 0@0 extent: 45@9. -3@-7 extent: 2@2. 4@4 extent: 16@16}.
	{Color red.  Color blue. Color black. Color gray}}.

self test2: objects.
"rec+0, rec+1, rec+2, rec+3 need to be tested.  " 
fName _ (FileDirectory default fileNamesMatching: '*.ran') first.
sss _ fName splitInteger first.
(Collection classPool at: #RandomForPicking) seed: sss.
cnt _ 0.
[take _ #(3 4) atRandom.
	tuple _ (1 to: take) collect: [:ind | (objects atRandom) atRandom].
	other _ (1 to: take) collect: [:ind | (objects atRandom) atRandom].
	self load: (aa _ Array with: tuple with: 1 with: other with: 7).
	((cnt _ cnt+1) \\ 10 = 0) " | (cnt > Skip)" ifTrue: [
		Transcript cr; show: cnt printString; tab; tab; show: aa first printString].
	cnt > (Smalltalk at: #StopHere) ifTrue: [self halt].		"stop just before crash"
	cnt > (Smalltalk at: #Skip) ifTrue: ["skip this many at start"
		self search: true.
		self test2: aa first.  self test2: (aa at: 3).
		"self test2: objects"
		].
	true] whileTrue.
	! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 5/18/2001 19:18'!
verify
	"Test a bunch of examples"
	"	MethodFinder new verify    "
Approved ifNil: [self initialize].	"Sets of allowed selectors"
(MethodFinder new load: #( (0) 0  (30) 0.5  (45) 0.707106  (90) 1)
	) searchForOne asArray = #('data1 degreeSin') ifFalse: [self error: 'should have found it'].
(MethodFinder new load:  { { true. [3]. [4]}. 3.  { false. [0]. [6]}. 6}
	) searchForOne asArray = #('data1 ifTrue: data2 ifFalse: data3') ifFalse: [
		self error: 'should have found it'].
(MethodFinder new load: {#(1). true. #(2). false. #(5). true. #(10). false}
	) searchForOne asArray = #('data1 odd') ifFalse: [self error: 'should have found it'].
		"will correct the date type of #true, and complain"
(MethodFinder new load: #((4 2) '2r100'   (255 16) '16rFF'    (14 8) '8r16')
	) searchForOne asArray = 
		#('data1 radix: data2' 'data1 printStringBase: data2' 'data1 storeStringBase: data2')
			  ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: {{Point x: 3 y: 4}. 4.  {Point x: 1 y: 5}. 5}
	) searchForOne asArray = #('data1 y') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #(('abcd') $a  ('TedK') $T)
	) searchForOne asArray = #('data1 asCharacter' 'data1 first' 'data1 anyOne')
		 ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #(('abcd' 1) $a  ('Ted ' 3) $d )
	) searchForOne asArray = #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2')
		ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #(((12 4 8)) 24  ((1 3 6)) 10 )
	) searchForOne asArray=  #('data1 sum') ifFalse: [self error: 'should have found it'].	
		"note extra () needed for an Array object as an argument"

(MethodFinder new load: #((14 3) 11  (-10 5) -15  (4 -3) 7)
	) searchForOne asArray = #('data1 - data2') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((4) 4  (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612)
	) searchForOne asArray = #('data1 abs') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: {#(4 3). true.  #(-7 3). false.  #(5 1). true.  #(5 5). false}
	) searchForOne asArray = #('data1 > data2') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((5) 0.2   (2) 0.5)
	) searchForOne asArray = #('data1 reciprocal') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((12 4 8) 2  (1 3 6) 2  (5 2 16) 8)
	) searchForOne asArray = #()     " '(data3 / data2) ' want to be able to leave out args"  
		ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((0.0) 0.0  (1.5) 0.997495  (0.75) 0.681639)
	) searchForOne asArray = #('data1 sin') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((7 5) 2   (4 5) 4   (-9 4) 3)
	) searchForOne asArray = #('data1 \\ data2') ifFalse: [self error: 'should have found it'].	

(MethodFinder new load: #((7) 2   (4) 2 )
	) searchForOne asArray = #('^ 2')  ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: {#(7). true.   #(4.1).  true.   #(1.5). false}
	) searchForOne asArray = #('data1 >= 4.1') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((35) 3   (17) 1   (5) 5)
	) searchForOne asArray = #('data1 \\ 8') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((36) 7   (50) 10 )
	) searchForOne asArray = #('data1 quo: 5' 'data1 // 5') ifFalse: [
		self error: 'should have found it'].	
(MethodFinder new load: #( ((2 3) 2) 8   ((2 3) 5) 17 )
	) searchForOne asArray = #('data1 polynomialEval: data2') ifFalse: [
		self error: 'should have found it'].	
(MethodFinder new load: #((2) 8   (5) 17 )
	) searchForOne asArray = #('#(2 3) polynomialEval: data1') ifFalse: [
		self error: 'should have found it'].	
! !


!MethodFinder methodsFor: 'search' stamp: 'ar 4/10/2005 22:20'!
exceptions
	"Handle some very slippery selectors.
	asSymbol -- want to be able to produce it, but do not want to make every string submitted into a Symbol!!" 

	| aSel |
	answers first isSymbol ifFalse: [^ self].
	thisData first first isString ifFalse: [^ self].
	aSel _ #asSymbol.
	(self testPerfect: aSel) ifTrue: [
		selector add: aSel.
		expressions add: (String streamContents: [:strm | 
			strm nextPutAll: 'data', argMap first printString.
			aSel keywords doWithIndex: [:key :ind |
				strm nextPutAll: ' ',key.
				(key last == $:) | (key first isLetter not)
					ifTrue: [strm nextPutAll: ' data', 
						(argMap at: ind+1) printString]]])].
! !

!MethodFinder methodsFor: 'search' stamp: 'ar 4/10/2005 18:48'!
findMessage
	"Control the search."

	data do: [:alist |
		(alist isKindOf: SequenceableCollection) ifFalse: [
			^ OrderedCollection with: 'first and third items are not Arrays']].
	Approved ifNil: [self initialize].	"Sets of allowed selectors"
	expressions _ OrderedCollection new.
	self search: true.	"multi"
	expressions isEmpty ifTrue: [^ OrderedCollection with: 'no single method does that function'].
	expressions isString ifTrue: [^ OrderedCollection with: expressions].
 	^ expressions! !

!MethodFinder methodsFor: 'search' stamp: 'tk 4/12/2001 10:47'!
insertConstants
	"see if one of several known expressions will do it. C is the constant we discover here."
	"C  data1+C  data1*C  data1//C  (data1*C1 + C2) (data1 = C) (data1 ~= C) (data1 <= C) (data1 >= C) 
 (data1 mod C)"

	thisData size >= 2 ifFalse: [^ false].	"need 2 examples"
	(thisData at: 1) size = 1 ifFalse: [^ false].	"only one arg, data1"

	self const ifTrue: [^ true].
	self constUsingData1Value ifTrue: [^ true].
		"(data1 ?? const), where const is one of the values of data1"
		" == ~~ ~= = <= >= "

	self allNumbers ifFalse: [^ false].
	self constMod ifTrue: [^ true].
	self constPlus ifTrue: [^ true].
	self constMult ifTrue: [^ true].
	self constDiv ifTrue: [^ true].
	self constLinear ifTrue: [^ true].
	^ false! !

!MethodFinder methodsFor: 'search' stamp: 'md 2/22/2006 21:23'!
search: multi
	"if Multi is true, collect all selectors that work."
	selector _ OrderedCollection new.	"list of them"
	self simpleSearch.
	multi not & (selector isEmpty not) ifTrue:[^ selector].

	[self permuteArgs] whileTrue:
		[self simpleSearch.
		multi not & (selector isEmpty not) ifTrue: [^ selector]].

	self insertConstants.
	"(selector isEmpty not) ifTrue: [^ selector]].    expression is the answer, not a selector"
	^ #()! !

!MethodFinder methodsFor: 'search' stamp: 'tk 1/8/2001 17:53'!
searchForOne
	"Look for and return just one answer"

	expressions _ OrderedCollection new.
	self search: false.	"non-multi"
	^ expressions
			! !

!MethodFinder methodsFor: 'search' stamp: 'tk 1/8/2001 18:17'!
simpleSearch
	"Run through first arg's class' selectors, looking for one that works."

| class supers listOfLists |
self exceptions.
class _ thisData first first class.
"Cache the selectors for the receiver class"
(class == cachedClass and: [cachedArgNum = ((argMap size) - 1)]) 
	ifTrue: [listOfLists _ cachedSelectorLists]
	ifFalse: [supers _ class withAllSuperclasses.
		listOfLists _ OrderedCollection new.
		supers do: [:cls |
			listOfLists add: (cls selectorsWithArgs: (argMap size) - 1)].
		cachedClass _ class.
		cachedArgNum _ (argMap size) - 1.
		cachedSelectorLists _ listOfLists].
listOfLists do: [:selectorList |
	selectorList do: [:aSel |
		(selector includes: aSel) ifFalse: [
			((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
				(self testPerfect: aSel) ifTrue: [
					selector add: aSel.
					expressions add: (String streamContents: [:strm | 
						strm nextPutAll: 'data', argMap first printString.
						aSel keywords doWithIndex: [:key :ind |
							strm nextPutAll: ' ',key.
							(key last == $:) | (key first isLetter not)
								ifTrue: [strm nextPutAll: ' data', 
									(argMap at: ind+1) printString]]])
					]]]]].
! !

!MethodFinder methodsFor: 'search' stamp: 'ar 4/10/2005 22:20'!
testPerfect: aSelector
	"Try this selector!! Return true if it answers every example perfectly.  Take the args in the order they are.  Do not permute them.  Survive errors.  later cache arg lists."

| sz argList val rec activeSel perform |
	"Transcript cr; show: aSelector.		debug"
perform _ aSelector beginsWith: 'perform:'.
sz _ argMap size.
1 to: thisData size do: [:ii | "each example set of args"
	argList _ (thisData at: ii) copyFrom: 2 to: sz.
	perform
		ifFalse: [activeSel _ aSelector]
		ifTrue: [activeSel _ argList first.	"what will be performed"
			((Approved includes: activeSel) or: [AddAndRemove includes: activeSel])
				ifFalse: [^ false].	"not approved"
			aSelector == #perform:withArguments: 
				ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error" 
							ifFalse: [^ false]]
				ifFalse: [activeSel numArgs = (aSelector numArgs - 1) 
							ifFalse: [^ false]]].
	1 to: sz do: [:num | 
		(Blocks includes: (Array with: activeSel with: num)) ifTrue: [
			(argList at: num) class == BlockContext ifFalse: [^ false]]].
	rec _ (AddAndRemove includes: activeSel) 
			ifTrue: [(thisData at: ii) first isSymbol ifTrue: [^ false].
						"vulnerable to modification"
				(thisData at: ii) first copyTwoLevel] 	"protect from damage"
			ifFalse: [(thisData at: ii) first].
	val _ [rec perform: aSelector withArguments: argList] 
				ifError: [:aString :aReceiver | 
							"self test3."
							"self test2: (thisData at: ii)."
							^ false].
	"self test3."
	"self test2: (thisData at: ii)."
	((answers at: ii) closeTo: val) ifFalse: [^ false].
	].
^ true! !

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

MethodFinder class
	instanceVariableNames: ''!

!MethodFinder class methodsFor: 'as yet unclassified' stamp: 'ar 9/27/2005 22:45'!
methodFor: dataAndAnswers
	"Return a Squeak expression that computes these answers.  (This method is called by the comment in the bottom pane of a MethodFinder.  Do not delete this method.)"

	| resultOC resultString |
	resultOC _ (self new) load: dataAndAnswers; findMessage.
	resultString _ String streamContents: [:strm |
		resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]].
	^ resultString! !
CodeHolder subclass: #MethodHolder
	instanceVariableNames: 'methodClass methodSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Base'!

!MethodHolder methodsFor: 'contents' stamp: 'md 2/20/2006 15:05'!
contents
	"Answer the contents, with due respect for my contentsSymbol"

	contents := methodClass sourceCodeAt: methodSelector ifAbsent: [''].
	currentCompiledMethod := methodClass compiledMethodAt: methodSelector ifAbsent: [nil].

	self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
	self showingDocumentation ifTrue: [^ self commentContents].
	^ contents := self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: methodClass! !

!MethodHolder methodsFor: 'contents' stamp: 'md 2/20/2006 18:46'!
contents: input notifying: aController 
	| selector |
	(selector := methodClass parserClass new parseSelector: input asText) ifNil:
		[self inform: 'Sorry - invalid format for the 
method name and arguments -- cannot accept.'.
		^ false].

	selector == methodSelector ifFalse:
		[self inform:
'You cannot change the name of
the method here -- it must continue
to be ', methodSelector.
		^ false].

	selector := methodClass
				compile: input asText
				classified: self selectedMessageCategoryName
				notifying: aController.
	selector == nil ifTrue: [^ false].
	contents := input asString copy.
	currentCompiledMethod := methodClass compiledMethodAt: methodSelector.
	^ true! !


!MethodHolder methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:54'!
addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph
	aCustomMenu addLine.
	aCustomMenu add: 'whose script is this?' translated target: self action: #identifyScript
	! !

!MethodHolder methodsFor: 'menu' stamp: 'sw 12/12/2001 21:27'!
doItReceiver
	"If there is an instance associated with me, answer it, for true mapping of self.  If not, then do what other code-bearing tools do, viz. give access to the class vars."

	(self dependents detect: [:m | m isKindOf: MethodMorph]) ifNotNilDo:
		[:mm | (mm owner isKindOf: ScriptEditorMorph) ifTrue:
			[^ mm owner playerScripted]].

	^ self selectedClass ifNil: [FakeClassPool new]! !


!MethodHolder methodsFor: 'miscellaneous' stamp: 'sd 11/20/2005 21:27'!
changeMethodSelectorTo: aSelector
	"Change my method selector as noted.  Reset currentCompiledMethod"

	methodSelector := aSelector.
	currentCompiledMethod := methodClass compiledMethodAt: aSelector ifAbsent: [nil]! !

!MethodHolder methodsFor: 'miscellaneous' stamp: 'tk 8/30/2000 13:07'!
compiledMethod

	^ methodClass compiledMethodAt: methodSelector! !

!MethodHolder methodsFor: 'miscellaneous' stamp: 'sd 11/20/2005 21:27'!
identifyScript
	| msg aPlayer |
	msg := methodClass isUniClass
		ifTrue:
			[aPlayer := methodClass someInstance.
			aPlayer costume
				ifNotNil:
					['This holds code for a script
named ', methodSelector, ' belonging
to an object named ', aPlayer externalName]
				ifNil:
					['This formerly held code for a script
named ', methodSelector, ' for a Player
who once existed but now is moribund.']]
		ifFalse:
			['This holds code for the method
named ', methodSelector, '
for class ', methodClass name].
	self inform: msg! !

!MethodHolder methodsFor: 'miscellaneous' stamp: 'sd 11/20/2005 21:27'!
methodClass: aClass methodSelector: aSelector
	methodClass := aClass.
	methodSelector := aSelector.
	currentCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]! !

!MethodHolder methodsFor: 'miscellaneous' stamp: 'tk 8/30/2000 13:08'!
versions
	"Return a VersionsBrowser (containing a list of ChangeRecords) of older versions of this method."

	^ VersionsBrowser new scanVersionsOf: self compiledMethod
			class: self selectedClass 
			meta: methodClass isMeta 
			category: self selectedMessageCategoryName
				"(classOfMethod whichCategoryIncludesSelector: selectorOfMethod)"
			selector: methodSelector! !


!MethodHolder methodsFor: 'selection' stamp: 'sw 10/21/1999 09:40'!
selectedClass
	^ methodClass theNonMetaClass! !

!MethodHolder methodsFor: 'selection' stamp: 'sw 10/27/1999 14:30'!
selectedClassOrMetaClass
	^ methodClass! !

!MethodHolder methodsFor: 'selection' stamp: 'sw 10/21/1999 10:16'!
selectedMessageCategoryName
	^ methodClass organization categoryOfElement: methodSelector! !

!MethodHolder methodsFor: 'selection' stamp: 'sw 10/21/1999 09:39'!
selectedMessageName
	^ methodSelector! !

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

MethodHolder class
	instanceVariableNames: ''!

!MethodHolder class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
isolatedCodePaneForClass: aClass selector: aSelector
	"Answer a MethodMorph on the given class and selector"

	| aCodePane aMethodHolder |

	aMethodHolder := self new.
	aMethodHolder methodClass: aClass methodSelector: aSelector.

	aCodePane := MethodMorph on: aMethodHolder text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	aMethodHolder addDependent: aCodePane.
	aCodePane borderWidth: 2; color: Color white.
	aCodePane scrollBarOnLeft: false.
	aCodePane width: 300.
	^ aCodePane! !

!MethodHolder class methodsFor: 'instance creation' stamp: 'sw 10/23/2000 18:55'!
makeIsolatedCodePaneForClass: aClass selector: aSelector
	"Create, and place in the morphic Hand, an isolated code pane bearing source code for the given class and selector"

	(self isolatedCodePaneForClass: aClass selector: aSelector) openInHand! !
ObjectWithDocumentation subclass: #MethodInterface
	instanceVariableNames: 'selector argumentVariables resultSpecification receiverType attributeKeywords defaultStatus'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!
!MethodInterface commentStamp: '<historical>' prior: 0!
A MethodInterface describes the interface for a single method.  The most generic form is not bound to any particular class or object but rather describes an idealized interface.

	selector					A symbol - the selector being described
	argumentSpecifications	A list of specifications for the formal arguments of the method
	resultSpecification 		A characterization of the return value of the method
	userLevel				
	attributeKeywords		A list of symbols, comprising keywords that the user wishes to
								see on the screen for this method
	defaultStatus			The status to apply to new instances of the class by default
							(#ticking, #paused, #normal, etc.)


!


!MethodInterface methodsFor: 'access' stamp: 'sw 3/8/2001 16:29'!
companionSetterSelector
	"If there is a companion setter selector, anwer it, else answer nil"

	^ resultSpecification ifNotNil:
		[resultSpecification companionSetterSelector]! !

!MethodInterface methodsFor: 'access' stamp: 'sw 9/13/2001 16:42'!
elementSymbol
	"Answer the element symbol, for the purposes of translation"

	^ selector! !

!MethodInterface methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:39'!
receiverType
	"Answer the receiver type"

	^ receiverType ifNil: [receiverType := #unknown]! !

!MethodInterface methodsFor: 'access' stamp: 'sw 3/10/2001 00:38'!
resultType
	"Answer the result type"

	^ resultSpecification
		ifNotNil:
			[resultSpecification type]
		ifNil:
			[#unknown]! !

!MethodInterface methodsFor: 'access' stamp: 'sw 1/23/2001 18:37'!
selector
	"Answer the receiver's selector"

	^ selector! !

!MethodInterface methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:39'!
typeForArgumentNumber: anArgumentNumber
	"Answer the data type for the given argument number"

	| aVariable |
	aVariable := self argumentVariables at: anArgumentNumber.
	^ aVariable variableType! !

!MethodInterface methodsFor: 'access' stamp: 'sw 5/3/2001 01:10'!
wantsReadoutInViewer
	"Answer whether the method represented by the receiver is one which should have a readout in a viewer"

	^ resultSpecification notNil and:
		[resultSpecification refetchFrequency notNil]! !


!MethodInterface methodsFor: 'attribute keywords' stamp: 'stephaneducasse 2/4/2006 20:39'!
attributeKeywords
	"Answer a list of attribute keywords associated with the receiver"

	^ attributeKeywords ifNil: [attributeKeywords := OrderedCollection new]! !

!MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 1/26/2001 16:32'!
flagAttribute: aSymbol
	"Mark the receiver as having the given category-keyword"

	(self attributeKeywords includes: aSymbol) ifFalse: [attributeKeywords add: aSymbol]! !

!MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 1/26/2001 16:33'!
flagAttributes: attributeSymbolList
	"Mark the receiver has being flagged with all the symbols in the list provided"

	attributeSymbolList do: [:aSym | self flagAttribute: aSym]! !

!MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 1/26/2001 16:34'!
isFlaggedAs: aSymbol
	"Answer whether the receiver is flagged with the given trait"

	^ self attributeKeywords includes: aSymbol! !

!MethodInterface methodsFor: 'attribute keywords' stamp: 'stephaneducasse 2/4/2006 20:39'!
selector: aSelector type: aType setter: aSetter
	"Set the receiver's fields as indicated.  Values of nil or #none for the result type and the setter indicate that there is none"

	selector := aSelector.
	(MethodInterface isNullMarker: aType) ifFalse:
		[resultSpecification := ResultSpecification new.
		resultSpecification resultType: aType.
		(MethodInterface isNullMarker: aSetter) ifFalse:
			[resultSpecification companionSetterSelector: aSetter]]! !


!MethodInterface methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
argumentVariables
	"Answer the list of argumentVariables of the interface"

	^ argumentVariables ifNil: [argumentVariables := OrderedCollection new]! !

!MethodInterface methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
argumentVariables: variableList
	"Set the argument variables"

	argumentVariables := variableList! !

!MethodInterface methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
conjuredUpFor: aSelector class: aClass
	"Initialize the receiver to have the given selector, obtaining whatever info one can from aClass.  This basically covers the situation where no formal definition has been made."

	| parts |
	self initializeFor: aSelector.
	self wording: aSelector.

	receiverType := #unknown.
	parts := aClass formalHeaderPartsFor: aSelector.
	argumentVariables := (1 to: selector numArgs) collect:
		[:anIndex | Variable new name: (parts at: (4 * anIndex)) type: #Object].
	parts last isEmptyOrNil ifFalse: [self documentation: parts last].
! !

!MethodInterface methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver"

	super initialize.
	attributeKeywords := OrderedCollection new.
	defaultStatus := #normal.
	argumentVariables := OrderedCollection new
! !

!MethodInterface methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initializeFor: aSelector
	"Initialize the receiver to have the given selector"

	selector := aSelector.
	attributeKeywords := OrderedCollection new.
	defaultStatus := #normal
! !

!MethodInterface methodsFor: 'initialization' stamp: 'fbs 2/13/2006 22:46'!
initializeFromEToyCommandSpec: tuple category: aCategorySymbol
	"tuple holds an old etoy command-item spec, of the form found in #additionsToViewerCategories methods.   Initialize the receiver to hold the same information"

	selector := tuple second.
	receiverType := #Player.
	selector numArgs = 1 ifTrue:
		[argumentVariables := OrderedCollection with:
			(Variable new name: (Player formalHeaderPartsFor: selector) fourth type: tuple fourth)].

	aCategorySymbol ifNotNil: [self flagAttribute: aCategorySymbol].
	self
		wording: (ScriptingSystem wordingForOperator: selector);
		helpMessage:  tuple third! !

!MethodInterface methodsFor: 'initialization' stamp: 'yo 3/7/2005 08:46'!
initializeFromEToySlotSpec: tuple
	"tuple holds an old etoy slot-item spec, of the form found in #additionsToViewerCategories methods.   Initialize the receiver to hold the same information"

	| setter |
	selector _ tuple seventh.
	self
		wording: (ScriptingSystem wordingForOperator: tuple second);
		helpMessage: tuple third.

	receiverType _ #Player.
	resultSpecification _ ResultSpecification new.
	resultSpecification resultType: tuple fourth.
	(#(getNewClone getTurtleAt: getTurtleOf: "seesColor: isOverColor:") includes: selector)
		ifTrue:
			[self setNotToRefresh]  "actually should already be nil"
		ifFalse:
			[self setToRefetch].

	((tuple fifth == #readWrite) and: [((tuple size >= 9) and: [(setter _ tuple at: 9) ~~ #unused])]) ifTrue:
		[resultSpecification companionSetterSelector: setter].
		
"An example of an old slot-item spec:
(slot numericValue 'A number representing the current position of the knob.' number readWrite Player getNumericValue Player setNumericValue:)
	1	#slot
	2	wording
	3	balloon help
	4	type
	5	#readOnly or #readWrite
	6	#Player (not used -- ignore)
	7	getter selector
	8	#Player (not used -- ignore)
	9	setter selector
"
	! !

!MethodInterface methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initializeSetterFromEToySlotSpec: tuple
	"tuple holds an old etoy slot-item spec, of the form found in #additionsToViewerCategories methods.   Initialize the receiver to represent the getter of this item"

	selector := tuple ninth.
	self
		wording: ('set ', tuple second);
		helpMessage: ('setter for', tuple third).
	receiverType := #Player.
	argumentVariables := Array with: (Variable new variableType: tuple fourth)
	! !

!MethodInterface methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
receiverType: aType
	"set the receiver type.  Whether the receiverType earns its keep here is not yet well understood.  At the moment, this is unsent"

	receiverType := aType! !

!MethodInterface methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
resultType: aType
	"Set the receiver's resultSpecification to be a ResultType of the given type"

	resultSpecification := ResultSpecification new.
	resultSpecification resultType: aType! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 5/26/2001 22:59'!
setNotToRefresh
	"Set the receiver up not to do periodic refresh."

	resultSpecification ifNotNil: [resultSpecification refetchFrequency: nil]! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 5/3/2001 15:59'!
setToRefetch
	"Set the receiver up to expect a refetch, assuming it has a result specification"

	resultSpecification ifNotNil: [resultSpecification refetchFrequency: 1]! !


!MethodInterface methodsFor: 'initialize-release' stamp: 'ar 3/3/2001 19:38'!
releaseCachedState
	"Sent by player"! !


!MethodInterface methodsFor: 'printing' stamp: 'nk 8/20/2004 09:38'!
printOn: aStream
	"print the receiver on a stream.  Overridden to provide details about wording, selector, result type, and companion setter."

	super printOn: aStream.
	aStream nextPutAll: ' - wording: ';
		print: self wording;
		nextPutAll: ' selector: ';
		print: selector.
	self argumentVariables size > 0 ifTrue:
		[aStream nextPutAll: ' Arguments: '.
		argumentVariables doWithIndex:
			[:aVariable :anIndex | 
				aStream nextPutAll: 'argument #', anIndex printString, ' name = ', aVariable variableName asString, ', type = ', aVariable variableType]].
	resultSpecification ifNotNil:
		[aStream nextPutAll: ' result type = ', resultSpecification resultType asString.
		resultSpecification companionSetterSelector ifNotNil:
			[aStream nextPutAll: ' setter = ', resultSpecification companionSetterSelector asString]]
	! !


!MethodInterface methodsFor: 'status' stamp: 'sw 1/23/2001 17:16'!
defaultStatus
	"Answer the receiver's default defaultStatus"

	^ defaultStatus! !

!MethodInterface methodsFor: 'status' stamp: 'stephaneducasse 2/4/2006 20:39'!
defaultStatus: aStatus
	"Set the receiver's defaultStatus as indicated"

	defaultStatus := aStatus! !

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

MethodInterface class
	instanceVariableNames: ''!

!MethodInterface class methodsFor: 'utilities' stamp: 'sw 7/17/2001 19:08'!
firingInterface
	"Answer an instance of the receiver representing #fire"

	^ self new selector: #fire type: nil setter: nil! !

!MethodInterface class methodsFor: 'utilities' stamp: 'gk 3/1/2005 10:43'!
isNullMarker: aMarker
	"Answer true if aMarker is nil or is one of the symbols in #(none #nil unused missing) -- to service a variety of historical conventions"

	^ aMarker isNil or: [#(none #nil unused missing) includes: aMarker]

"
MethodInterface isNullMarker: nil
MethodInterface isNullMarker: #nil
MethodInterface isNullMarker: #none
MethodInterface isNullMarker: #znak
"! !
PluggableTextMorph subclass: #MethodMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!

!MethodMorph methodsFor: 'as yet unclassified' stamp: 'tk 9/7/2000 22:07'!
installRollBackButtons: target
	| mine |
	"If I don't already have such a button, put one in at the upper right.  Set its target to the furtherest enclosing book.  Send chooseAndRevertToVersion when clicked.  Stay in place via scrollBar install."

	mine _ self submorphNamed: #chooseAndRevertToVersion ifNone: [nil].
	mine ifNil: [mine _ SimpleButtonMorph new.
		"mine height: mine height - 2."
		mine label: 'Roll Back'; cornerStyle: #square.
		mine color: Color white; borderColor: Color black.
		mine actionSelector: #chooseAndRevertToVersion.
		mine align: mine topRight with: (self findA: ScrollBar) topLeft +(1@1).
		self addMorphFront: mine.
		mine height: mine height - 5 "14"].
	mine target: target.! !


!MethodMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:25'!
initialize
	"initialize the state of the receiver"
	super initialize.
	self useRoundedCorners! !


!MethodMorph methodsFor: 'scrolling' stamp: 'nk 4/28/2004 10:23'!
showScrollBar
	"Copied down and modified to get rid of the ruinous comeToFront of the inherited version."

	| scriptor |
	(submorphs includes: scrollBar)
		ifTrue: [^ self].
	self vResizeScrollBar.
	self privateAddMorph: scrollBar atIndex: 1.
	retractableScrollBar
		ifTrue:
			["Bring the pane to the front so that it is fully visible"
			"self comeToFront. -- thanks but no thanks"
			(scriptor _ self ownerThatIsA: ScriptEditorMorph)
				ifNotNil:
					[scriptor comeToFront]]
		ifFalse: [self resetExtent]! !


!MethodMorph methodsFor: 'stepping and presenter' stamp: 'sw 10/21/1999 09:41'!
step
	model updateCodePaneIfNeeded! !


!MethodMorph methodsFor: 'testing' stamp: 'sw 10/23/1999 23:03'!
stepTime
	^ 3000! !

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

MethodMorph class
	instanceVariableNames: ''!

!MethodMorph class methodsFor: 'as yet unclassified' stamp: 'dgd 8/26/2004 12:11'!
defaultNameStemForInstances
	^ 'Method'! !


!MethodMorph class methodsFor: 'new-morph participation' stamp: 'kfr 5/3/2000 12:52'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
ParseNode subclass: #MethodNode
	instanceVariableNames: 'selectorOrFalse precedence arguments block literals primitive encoder temporaries properties sourceText'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!MethodNode commentStamp: '<historical>' prior: 0!
I am the root of the parse tree.!


!MethodNode methodsFor: 'code generation'!
encoder
	^ encoder! !

!MethodNode methodsFor: 'code generation' stamp: 'al 4/21/2006 17:25'!
generate
	"The receiver is the root of a parse tree. Answer a CompiledMethod. The
	argument, trailer, is the references to the source code that is stored with 
	every CompiledMethod."

	^self generate: #(0 0 0 0)! !

!MethodNode methodsFor: 'code generation' stamp: 'DF 4/18/2006 23:58'!
generateWith: trailer using: aCompiledMethodClass
	"The receiver is the root of a parse tree. Answer a CompiledMethod. The
	argument, trailer, is the references to the source code that is stored with 
	every CompiledMethod."

	| blkSize nLits stack strm nArgs method |
	self generate: trailer ifQuick: 
		[:m |  method _ m.
		method properties: properties.
		^ method].
	nArgs _ arguments size.
	blkSize _ block sizeForEvaluatedValue: encoder.
	literals _ encoder allLiterals.
	nLits _ literals size.
	method _ aCompiledMethodClass	"Dummy to allocate right size"
				newBytes: blkSize
				trailerBytes: trailer 
				nArgs: nArgs
				nTemps: encoder maxTemp
				nStack: 0
				nLits: nLits
				primitive: primitive.
	strm _ ReadWriteStream with: method.
	strm position: method initialPC - 1.
	stack _ ParseStack new init.
	block emitForEvaluatedValue: stack on: strm.
	stack position ~= 1 ifTrue: [^self error: 'Compiler stack
discrepancy'].
	strm position ~= (method size - trailer size) 
		ifTrue: [^self error: 'Compiler code size discrepancy'].
	method needsFrameSize: stack size.
	1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
	method properties: properties.
	^ method! !

!MethodNode methodsFor: 'code generation' stamp: 'al 4/21/2006 17:24'!
generate: trailer 
	^self generateWith: trailer using: CompiledMethod! !

!MethodNode methodsFor: 'code generation' stamp: 'di 5/25/2000 06:45'!
generate: trailer ifQuick: methodBlock
	| v |
	(primitive = 0 and: [arguments size = 0 and: [block isQuick]])
		ifFalse: [^ self].
	v _ block code.
	v < 0
		ifTrue: [^ self].
	v = LdSelf
		ifTrue: [^ methodBlock value: (CompiledMethod toReturnSelfTrailerBytes: trailer)].
	(v between: LdTrue and: LdMinus1 + 3)
		ifTrue: [^ methodBlock value: (CompiledMethod toReturnConstant: v - LdSelf trailerBytes: trailer)].
	v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType))
		ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v trailerBytes: trailer)].
	v // 256 = 1
		ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v \\ 256 trailerBytes: trailer)]! !

!MethodNode methodsFor: 'code generation' stamp: 'ajh 7/6/2003 15:25'!
parserClass
	"Which parser produces this class of parse node"

	^ Parser! !

!MethodNode methodsFor: 'code generation' stamp: 'lr 2/6/2006 23:24'!
properties
	^ properties! !

!MethodNode methodsFor: 'code generation' stamp: 'yo 8/30/2002 14:07'!
selector 
	"Answer the message selector for the method represented by the receiver."

	(selectorOrFalse isSymbol)
		ifTrue: [^selectorOrFalse].
	^selectorOrFalse key.
! !

!MethodNode methodsFor: 'code generation' stamp: 'md 2/13/2006 14:35'!
sourceMap
	"Answer a SortedCollection of associations of the form: pc (byte offset in me) -> sourceRange (an Interval) in source text."

	| methNode |
	methNode _ self.
	sourceText ifNil: [
		"No source, use decompile string as source to map from"
		methNode _ self parserClass new
			parse: self decompileString
			class: self methodClass
	].
	methNode generate.  "set bytecodes to map to"
	^ methNode encoder sourceMap! !


!MethodNode methodsFor: 'initialize-release' stamp: 'tk 8/3/1999 12:47'!
block
	^ block! !

!MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 17:37'!
selector: symbol

	selectorOrFalse _ symbol! !

!MethodNode methodsFor: 'initialize-release' stamp: 'ar 1/4/2002 00:23'!
selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict
	"Initialize the receiver with respect to the arguments given."

	encoder _ anEncoder.
	selectorOrFalse _ selOrFalse.
	precedence _ p.
	arguments _ args.
	temporaries _ temps.
	block _ blk.
	primitive _ prim.
	properties _ propDict.! !

!MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/22/2003 17:53'!
sourceText: stringOrText

	sourceText _ stringOrText! !


!MethodNode methodsFor: 'printing' stamp: 'md 2/20/2006 00:02'!
decompileString 
	"Answer a string description of the parse tree whose root is the receiver."

	^ self decompileText asString
! !

!MethodNode methodsFor: 'printing' stamp: 'md 2/20/2006 00:03'!
decompileText 
	"Answer a text description of the parse tree whose root is the receiver."

	^ ColoredCodeStream contents: [:strm | self printOn: strm]! !

!MethodNode methodsFor: 'printing' stamp: 'ajh 1/22/2003 17:39'!
methodClass

	^ encoder classEncoding! !

!MethodNode methodsFor: 'printing' stamp: 'lr 2/6/2006 21:54'!
printOn: aStream 
	precedence = 1
		ifTrue: 
			[aStream nextPutAll: self selector]
		ifFalse: 
			[self selector keywords with: arguments do: 
				[:kwd :arg | 
				aStream nextPutAll: kwd; space.
				aStream withStyleFor: #methodArgument
					do: [aStream nextPutAll: arg key].
				aStream space]].
	comment == nil ifFalse: 
			[aStream crtab: 1.
			self printCommentOn: aStream indent: 1].
	temporaries size > 0 ifTrue: 
			[aStream crtab: 1.
			aStream nextPutAll: '|'.
			aStream withStyleFor: #temporaryVariable
				do: [temporaries do: 
						[:temp | aStream space; nextPutAll: temp key]].
				aStream nextPutAll: ' |'].
	properties ifNotNil: [ 
		properties pragmas do: [ :each |
			"Don't decompile basic primitives that return self, i-vars, etc."
			each keyword = #primitive:
				ifFalse: [ aStream crtab: 1. each printOn: aStream ]
				ifTrue: [
					((each argumentAt: 1) between: 255 and: 519)
						ifFalse: [ aStream crtab: 1. self printPrimitiveOn: aStream ] ] ] ].
	aStream crtab: 1.
	^ block printStatementsOn: aStream indent: 0! !

!MethodNode methodsFor: 'printing' stamp: 'ar 2/13/2001 21:15'!
printPrimitiveOn: aStream 
	"Print the primitive on aStream"
	| primIndex primDecl |
	primIndex _ primitive.
	primIndex = 0
		ifTrue: [^ self].
	primIndex = 120
		ifTrue: ["External call spec"
			^ aStream print: encoder literals first].
	aStream nextPutAll: '<primitive: '.
	primIndex = 117
		ifTrue: [primDecl _ encoder literals at: 1.
			aStream nextPut: $';
				
				nextPutAll: (primDecl at: 2);
				 nextPut: $'.
			(primDecl at: 1) notNil
				ifTrue: [aStream nextPutAll: ' module:';
						 nextPut: $';
						
						nextPutAll: (primDecl at: 1);
						 nextPut: $']]
		ifFalse: [aStream print: primIndex].
	aStream nextPut: $>.
	Smalltalk at: #Interpreter ifPresent:[:cls|
		aStream nextPutAll: ' "'
				, ((cls classPool at: #PrimitiveTable)
						at: primIndex + 1) , '" '].! !

!MethodNode methodsFor: 'printing' stamp: 'ajh 1/24/2003 17:41'!
sourceText

	^ sourceText ifNil: [self printString]! !

!MethodNode methodsFor: 'printing'!
tempNames
	^ encoder tempNames! !


!MethodNode methodsFor: 'tiles' stamp: 'md 2/13/2006 14:36'!
rawSourceRanges

	self generate.
	^encoder rawSourceRanges! !


!MethodNode methodsFor: '*eToys-tiles' stamp: 'RAA 2/16/2001 15:44'!
asMorphicSyntaxIn: parent
	
	^parent
		methodNodeInner: self 
		selectorOrFalse: selectorOrFalse 
		precedence: precedence 
		arguments: arguments 
		temporaries: temporaries 
		primitive: primitive 
		block: block
! !

!MethodNode methodsFor: '*eToys-tiles' stamp: 'tk 8/5/2001 11:40'!
asMorphicSyntaxUsing: aClass
	
	^ Cursor wait showWhile: [
		(aClass methodNodeOuter: self) finalAppearanceTweaks]
		! !


!MethodNode methodsFor: 'accessing' stamp: 'md 7/27/2006 19:12'!
body
	^block! !
TestCase subclass: #MethodPragmaTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Methods'!

!MethodPragmaTest methodsFor: 'utilities' stamp: 'md 2/18/2006 19:39'!
assertPragma: aString givesKeyword: aSymbol arguments: anArray
	| pragma decompiled |
	pragma := self pragma: aString selector: #zork.
	self assert: pragma keyword = aSymbol.
	self assert: pragma arguments = anArray.
	decompiled := (self class>>#zork) decompile.
	self assert: (decompiled properties pragmas includes: pragma). 
	self assert: (decompiled asString includesSubString: pragma asString).! !

!MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 02:23'!
compile: aString selector: aSelector
	self class 
		compileSilently: aSelector , String lf , aString
		classified: self methodCategory.
	^ self class >> aSelector.! !

!MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 11:50'!
methodCategory
	^ #generated! !

!MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 2/6/2006 20:48'!
pragma: aString selector: aSelector
	^ (self compile: '<' , aString , '>' selector: aSelector)
		pragmas first.! !

!MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 08:11'!
pragma: aSymbol selector: aSelector times: anInteger
	^ (self 
		compile: (String streamContents: [ :stream | 
			(1 to: anInteger) asArray shuffled do: [ :each | 
				stream 
					nextPut: $<; nextPutAll: aSymbol; space;
					print: each; nextPut: $>; cr ] ])
		selector: aSelector)
			pragmas.! !


!MethodPragmaTest methodsFor: 'running' stamp: 'lr 1/20/2006 02:15'!
tearDown
	(self class organization listAtCategoryNamed: self methodCategory)
		do: [ :each | self class removeSelectorSilently: each ].
	self class organization removeCategory: self methodCategory.! !


!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:18'!
testAllNamedFromTo
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma allNamed: #foo: from: self class to: Object.
	self assert: pragmasDetected = pragmasCompiled.
	
	pragmasDetected := Pragma allNamed: #foo: from: Object to: Object.
	self assert: pragmasDetected isEmpty.! !

!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:17'!
testAllNamedFromToSortedByArgument
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma allNamed: #foo: from: self class to: Object sortedByArgument: 1.
	self assert: pragmasDetected = (pragmasCompiled 
		sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])! !

!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:17'!
testAllNamedFromToSortedUsing
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma 
		allNamed: #foo: from: self class to: Object 
		sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ].
	self assert: pragmasDetected = (pragmasCompiled 
		sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).! !

!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:19'!
testAllNamedIn
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma allNamed: #foo: in: self class.
	self assert: pragmasDetected = pragmasCompiled.
	
	pragmasDetected := Pragma allNamed: #foo: in: Object.
	self assert: pragmasDetected isEmpty.! !

!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:15'!
testAllNamedInSortedByArgument
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma allNamed: #foo: in: self class sortedByArgument: 1.
	self assert: pragmasDetected = (pragmasCompiled 
		sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])! !

!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/21/2006 13:01'!
testAllNamedInSortedUsing
	| pragmasCompiled pragmasDetected |
	pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
	pragmasDetected := Pragma 
		allNamed: #foo: in: self class 
		sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ].
	self assert: pragmasDetected = (pragmasCompiled 
		sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).! !


!MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:35'!
testArguments
	| pragma |
	pragma := Pragma keyword: #foo: arguments: #( 123 ).
	self assert: pragma arguments = #( 123 ).! !

!MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:35'!
testKeyword
	| pragma |
	pragma := Pragma keyword: #foo: arguments: #( 123 ).
	self assert: pragma keyword = #foo:.! !

!MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:36'!
testMessage
	| pragma message |
	pragma := Pragma keyword: #foo: arguments: #( 123 ).
	message := pragma message.
	
	self assert: message selector = #foo:.
	self assert: message arguments = #( 123 ).! !


!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'!
testCompileArray
	self assertPragma: 'foo: #()' givesKeyword: #foo: arguments: #( () ).
	self assertPragma: 'foo: #( foo )' givesKeyword: #foo: arguments: #( ( foo ) ).
	self assertPragma: 'foo: #( foo: )' givesKeyword: #foo: arguments: #( ( foo: ) ).
	self assertPragma: 'foo: #( 12 )' givesKeyword: #foo: arguments: #( ( 12 ) ).
	self assertPragma: 'foo: #( true )' givesKeyword: #foo: arguments: #( ( true ) ).
	! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'!
testCompileCharacter
	self assertPragma: 'foo: $a' givesKeyword: #foo: arguments: #( $a ).
	self assertPragma: 'foo: $ ' givesKeyword: #foo: arguments: #( $  ).! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'!
testCompileEmpty
	self assertPragma: 'foo' givesKeyword: #foo arguments: #().! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 07:39'!
testCompileFull
	self assertPragma: 'foo: 1' givesKeyword: #foo: arguments: #( 1 ).
	self assertPragma: 'foo: 1 bar: 2' givesKeyword: #foo:bar: arguments: #( 1 2 ).! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 7/9/2006 19:39'!
testCompileInvalid
	"Invalid pragmas should properly raise an error."

	self should: [ self compile: '<>' selector: #zork ] raise: SyntaxErrorNotification.
	self should: [ self compile: '<1>' selector: #zork ] raise: SyntaxErrorNotification.	
	self should: [ self compile: '<#123>' selector: #zork ] raise: SyntaxErrorNotification.
	
	self should: [ self compile: '<foo bar>' selector: #zork ] raise: SyntaxErrorNotification.
	self should: [ self compile: '<foo 1>' selector: #zork ] raise: SyntaxErrorNotification.
	self should: [ self compile: '<foo bar zork>' selector: #zork ] raise: SyntaxErrorNotification.
	self should: [ self compile: '<foo bar 1>' selector: #zork ] raise: SyntaxErrorNotification.
	
self should: [ self compile: '<foo: bar:>' selector: #zork ] raise: SyntaxErrorNotification.
	self should: [ self compile: '<foo: #bar: zork:>' selector: #zork ] raise: SyntaxErrorNotification.! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'!
testCompileNumber
	self assertPragma: 'foo: 123' givesKeyword: #foo: arguments: #( 123 ).
	self assertPragma: 'foo: -123' givesKeyword: #foo: arguments: #( -123 ).
	self assertPragma: 'foo: 12.3' givesKeyword: #foo: arguments: #( 12.3 ).
	self assertPragma: 'foo: -12.3' givesKeyword: #foo: arguments: #( -12.3 ).! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'!
testCompileString
	self assertPragma: 'foo: ''''' givesKeyword: #foo: arguments: #( '' ).
	self assertPragma: 'foo: ''bar''' givesKeyword: #foo: arguments: #( 'bar' ).! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'!
testCompileSymbol
	self assertPragma: 'foo: #bar' givesKeyword: #foo: arguments: #( bar ).
	self assertPragma: 'foo: #bar:' givesKeyword: #foo: arguments: #( bar: ).
	self assertPragma: 'foo: #bar:zork:' givesKeyword: #foo: arguments: #( bar:zork: ).! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 7/3/2006 15:00'!
testCompileTemps
	"Pragmas should be placeable before and after temps."
	
	self 
		shouldnt: [
			self assert: (self compile: '| temps | <foo>' selector: #zork) 
				pragmas notEmpty ]
		raise: SyntaxErrorNotification.
	self 
		shouldnt: [
			self assert: (self compile: '<foo> | temps |' selector: #zork) 
				pragmas notEmpty ]
		raise: SyntaxErrorNotification.! !

!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 2/6/2006 21:04'!
testCompileValue
	self assertPragma: 'foo: true' givesKeyword: #foo: arguments: #( true ).
	self assertPragma: 'foo: false' givesKeyword: #foo: arguments: #( false ).
	self assertPragma: 'foo: nil' givesKeyword: #foo: arguments: #( nil ).
	
	self assertPragma: 'foo: String' givesKeyword: #foo: arguments: { String }.
	self assertPragma: 'foo: Pragma' givesKeyword: #foo: arguments: { Pragma }.! !


!MethodPragmaTest methodsFor: 'testing-method' stamp: 'lr 1/20/2006 07:54'!
testMethod
	| pragma |
	pragma := self pragma: 'foo' selector: #bar.
	self assert: pragma method == (self class >> #bar).! !

!MethodPragmaTest methodsFor: 'testing-method' stamp: 'md 2/18/2006 19:59'!
testMethodClass
	| pragma |
	pragma := self pragma: 'foo' selector: #bar.
	self assert: pragma methodClass == self class.! !

!MethodPragmaTest methodsFor: 'testing-method' stamp: 'lr 1/20/2006 07:54'!
testSelector
	| pragma |
	pragma := self pragma: 'foo' selector: #bar.
	self assert: pragma selector == #bar.! !


!MethodPragmaTest methodsFor: 'testing-compiled' stamp: 'lr 2/6/2006 21:03'!
testNoPragma
	| method |
	method := self compile: '' selector: #foo.
	self assert: method pragmas = #().! !


!MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'lr 1/20/2006 02:31'!
testPrimitiveIndexed1
	"This test useses the #instVarAt: primitive."
	
	self compile: '<primitive: 74> ^ #inst' selector: #inst.
	self assert: self inst = #inst.! !

!MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'lr 1/20/2006 02:31'!
testPrimitiveIndexed2
	"This test useses the #asOop primitive."

	self compile: '<primitive: 75> ^ #oop' selector: #oop.
	self assert: self oop = self asOop.! !

!MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'lr 1/20/2006 02:42'!
testPrimitiveNamed1
	"This test useses the #primitiveDirectoryLookup primitive."

	self compile: '<primitive: ''primitiveDirectoryLookup'' module: ''FilePlugin''> ^ #lookup' selector: #lookup.
	self assert: self lookup = #lookup.
	
! !

!MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'lr 1/20/2006 02:41'!
testPrimitiveNamed2
	"This test useses the #primPathNameDelimiter primitive."

	self compile: '<primitive: ''primitiveDirectoryDelimitor'' module: ''FilePlugin''> ^ #delim' selector: #delim.
	self assert: self delim = FileDirectory primPathNameDelimiter.
	
! !
Object subclass: #MethodProperties
	instanceVariableNames: 'properties pragmas selector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!MethodProperties commentStamp: 'lr 2/6/2006 19:31' prior: 0!
I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this.

I am a compact class and optimized for size and speed, since every CompiledMethod points onto an instance of myself. I am mostly polymorphic to the protocol of an identity-dictionary, so that key-value pairs can be easily stored and retreived without the need to add new variables. However keep in mind that instantiating a dictionary consumes much more memory than adding an instance-variable, so it might be clever to add a new variable if the property is going to be used by every compiled method.!


!MethodProperties methodsFor: 'accessing' stamp: 'lr 2/6/2006 19:11'!
pragmas
	^ pragmas! !

!MethodProperties methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'!
selector
	^selector! !

!MethodProperties methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'!
selector: aSymbol
	selector := aSymbol! !


!MethodProperties methodsFor: 'initialization' stamp: 'lr 2/6/2006 19:12'!
initialize
	super initialize.
	pragmas := #().! !


!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:04'!
at: aKey
	"Answer the property value associated with aKey."
	
	^ self at: aKey ifAbsent: [ self error: 'Property not found' ].! !

!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 20:47'!
at: aKey ifAbsentPut: aBlock
	"Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."
	
	^ self at: aKey ifAbsent: [ self at: aKey put: aBlock value ].! !

!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:07'!
at: aKey ifAbsent: aBlock
	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
	
	properties isNil ifTrue: [ ^ aBlock value ].
	^ properties at: aKey ifAbsent: aBlock.! !

!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:06'!
at: aKey put: anObject
	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."

	properties ifNil: [ properties :=  IdentityDictionary new ].
	^ properties at: aKey put: anObject.! !

!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:11'!
includesKey: aKey
	"Test if the property aKey is present."
	
	^ properties notNil and: [ properties includesKey: aKey ].! !

!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 20:48'!
removeKey: aKey
	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."
	
	^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! !

!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:07'!
removeKey: aKey ifAbsent: aBlock
	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."
	
	| answer |
	properties isNil ifTrue: [ ^ aBlock value ].
	answer := properties removeKey: aKey ifAbsent: aBlock.
	properties isEmpty ifTrue: [ properties := nil ].
	^ answer.! !


!MethodProperties methodsFor: 'private' stamp: 'lr 2/6/2006 20:36'!
addPragma: aPragma
	pragmas := pragmas copyWith: aPragma.! !


!MethodProperties methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'!
isMethodProperties
	^true! !


!MethodProperties methodsFor: 'copying' stamp: 'md 3/1/2006 15:30'!
postCopy
	properties := properties copy.
	pragmas := pragmas copy.
! !

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

MethodProperties class
	instanceVariableNames: ''!

!MethodProperties class methodsFor: 'class initialization' stamp: 'lr 2/6/2006 22:06'!
initialize
	self becomeCompact.! !
TestCase subclass: #MethodPropertiesTest
	instanceVariableNames: 'method'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Methods'!

!MethodPropertiesTest methodsFor: 'private' stamp: 'lr 2/6/2006 20:43'!
propertyDictionaryFor: aMethod
	^ aMethod properties instVarNamed: 'properties'.! !


!MethodPropertiesTest methodsFor: 'running' stamp: 'lr 1/20/2006 19:16'!
setUp
	method := Object >> #halt.! !

!MethodPropertiesTest methodsFor: 'running' stamp: 'lr 1/20/2006 19:20'!
tearDown
	Object recompile: #halt from: Object.! !


!MethodPropertiesTest methodsFor: 'testing' stamp: 'kwl 7/26/2006 11:41'!
testAllMethodsHaveMethodClass
	Smalltalk garbageCollect.
	self assert: (CompiledMethod allInstances
			reject: [:cm | cm literals last isVariableBinding
					and: [cm literals last value isBehavior
							or: [cm literals last value isTrait]]]) isEmpty
			description: 'CompiledMethods must have methodClass literal'! !

!MethodPropertiesTest methodsFor: 'testing' stamp: 'kwl 7/26/2006 11:40'!
testAllMethodsHaveNewPropertyFormat
	Smalltalk garbageCollect.
	self assert: (CompiledMethod allInstances
			reject: [:cm | cm hasNewPropertyFormat]) isEmpty
		description: 'CompiledMethods must have new property format'! !

!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:21'!
testAt
	self should: [ method properties at: #zork ] raise: Error.
	self assert: (self propertyDictionaryFor: method) isNil.
	method properties at: #zork put: 'hello'.
	self assert: (method properties at: #zork) = 'hello'.! !

!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'!
testAtIfAbsent
	self assert: (method properties at: #zork ifAbsent: [ 'hello' ]) = 'hello'.
	self assert: (self propertyDictionaryFor: method) isNil.
	method properties at: #zork put: 'hi'.
	self assert: (method properties at: #zork ifAbsent: [ 'hello' ]) = 'hi'.! !

!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'!
testAtIfAbsentPut
	self assert: (method properties at: #zork ifAbsentPut: [ 'hello' ]) = 'hello'.
	self assert: (method properties at: #zork ifAbsentPut: [ 'hi' ]) = 'hello'.! !

!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'!
testAtPut
	self assert: (method properties at: #zork put: 'hello') = 'hello'.
	self assert: (method properties at: #zork) = 'hello'.! !

!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:19'!
testIncludesKey
	self deny: (method properties includesKey: #zork).
	self assert: (self propertyDictionaryFor: method) isNil.
	method properties at: #zork put: 123.
	self assert: (method properties includesKey: #zork).! !

!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'!
testRemoveKey
	method properties at: #zork put: 'hello'.
	self should: [ method properties removeKey: #halt ] raise: Error.
	self assert: (method properties removeKey: #zork) = 'hello'.
	self assert: (self propertyDictionaryFor: method) isNil.
	self should: [ method properties removeKey: #zork ] raise: Error.
	self assert: (self propertyDictionaryFor: method) isNil.! !

!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'!
testRemoveKeyifAbsent
	method properties at: #zork put: 'hello'.
	self assert: (method properties removeKey: #halt ifAbsent: [ 'hi' ]) = 'hi'.
	self assert: (method properties removeKey: #zork ifAbsent: [ 'hi' ]) = 'hello'.
	self assert: (self propertyDictionaryFor: method) isNil.
	self should: (method properties removeKey: #zork ifAbsent: [ 'hi' ]) = 'hi'.
	self assert: (self propertyDictionaryFor: method) isNil.! !
Object subclass: #MethodReference
	instanceVariableNames: 'classSymbol classIsMeta methodSymbol stringVersion'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Tools'!
!MethodReference commentStamp: 'tlk 5/9/2006 18:43' prior: 0!
A MethodReference is is a lightweight proxy for a CompiledMethod.  Has methods for pointed to the CompileMethod's source statements, byte codes. Is heavily used my Tools.

Instance Variables
	classIsMeta:		     Boolean class vs. instance
	classSymbol:		Symbol for method's class (without class keyword if meta)
	methodSymbol:		Symbol for method's selector
	stringVersion:		'Class>>selector:' format

!


!MethodReference methodsFor: 'comparisons' stamp: 'dgd 3/8/2003 11:54'!
hash
	"Answer a SmallInteger whose value is related to the receiver's  
	identity."
	^ (self species hash bitXor: self classSymbol hash)
		bitXor: self methodSymbol hash! !

!MethodReference methodsFor: 'comparisons' stamp: 'RAA 5/28/2001 11:56'!
<= anotherMethodReference

	classSymbol < anotherMethodReference classSymbol ifTrue: [^true].
	classSymbol > anotherMethodReference classSymbol ifTrue: [^false].
	classIsMeta = anotherMethodReference classIsMeta ifFalse: [^classIsMeta not].
	^methodSymbol <= anotherMethodReference methodSymbol
! !

!MethodReference methodsFor: 'comparisons' stamp: 'dgd 3/7/2003 13:18'!
= anotherMethodReference 
	"Answer whether the receiver and the argument represent the 
	same object."
	^ self species == anotherMethodReference species
		and: [self classSymbol = anotherMethodReference classSymbol]
		and: [self classIsMeta = anotherMethodReference classIsMeta]
		and: [self methodSymbol = anotherMethodReference methodSymbol]! !


!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 06:19'!
asStringOrText

	^stringVersion! !

!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:11'!
classIsMeta

	^classIsMeta! !

!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:10'!
classSymbol

	^classSymbol! !

!MethodReference methodsFor: 'queries' stamp: 'md 8/27/2005 17:17'!
isValid
	"Answer whether the receiver represents a current selector or Comment"

	| aClass |
	methodSymbol isDoIt ifTrue: [^ false].
	(aClass _ self actualClass) ifNil: [^ false].
	^ (aClass includesSelector: methodSymbol) or:
		[methodSymbol == #Comment]! !

!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:10'!
methodSymbol

	^methodSymbol! !

!MethodReference methodsFor: 'queries' stamp: 'sw 11/5/2001 00:53'!
printOn: aStream
	"Print the receiver on a stream"

	super printOn: aStream.
	aStream nextPutAll: ' ', self actualClass name, ' >> ', methodSymbol! !

!MethodReference methodsFor: 'queries' stamp: 'sr 6/4/2004 01:55'!
sourceString
	^ (self actualClass sourceCodeAt: self methodSymbol) asString! !


!MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 07:34'!
setClassAndSelectorIn: csBlock

	^csBlock value: self actualClass value: methodSymbol! !

!MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 06:04'!
setClassSymbol: classSym classIsMeta: isMeta methodSymbol: methodSym stringVersion: aString 

	classSymbol _ classSym.
	classIsMeta _ isMeta.
	methodSymbol _ methodSym.
	stringVersion _ aString.! !

!MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 08:06'!
setClass: aClass methodSymbol: methodSym stringVersion: aString 

	classSymbol _ aClass theNonMetaClass name.
	classIsMeta _ aClass isMeta.
	methodSymbol _ methodSym.
	stringVersion _ aString.! !

!MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 11:34'!
setStandardClass: aClass methodSymbol: methodSym

	classSymbol _ aClass theNonMetaClass name.
	classIsMeta _ aClass isMeta.
	methodSymbol _ methodSym.
	stringVersion _ aClass name , ' ' , methodSym.! !


!MethodReference methodsFor: 'string version' stamp: 'RAA 5/29/2001 14:44'!
stringVersion

	^stringVersion! !

!MethodReference methodsFor: 'string version' stamp: 'RAA 5/29/2001 14:44'!
stringVersion: aString

	stringVersion _ aString! !


!MethodReference methodsFor: '*fixUnderscores' stamp: 'cmm 5/1/2006 19:38'!
fixUnderscores
	"Replace underscores with :=. Answer true if fixed or no fix necessary, false if manual fix required"

	| src cm ts |
	"Check if we do need to do anything"
	src := self actualClass sourceCodeAt: methodSymbol.
	(src includes: $_) ifFalse: [^true].

	"Chicken out if there is a literal underscore"
	cm := self actualClass compiledMethodAt: methodSymbol.
	(cm hasLiteralSuchThat: [:lit | 
		lit = $_ or: [lit isString and: [lit includes: $_]]]) ifTrue: [^false].

	"Otherwise, replace underscores with :="
	src := src copyReplaceAll: '_' with: ':='.
	ts := self timeStamp.
	ts = '' ifTrue: [ts := nil].
	self actualClass 
		compile: src
		classified: ClassOrganizer default
		withStamp: ts 
		notifying: nil.

	^true
! !


!MethodReference methodsFor: '*Kernel-Traits' stamp: 'md 3/3/2006 09:25'!
actualClass 

	| actualClass |

	actualClass _ Smalltalk at: classSymbol ifAbsent: [^nil].
	classIsMeta ifTrue: [^actualClass classSide].
	^actualClass

! !


!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:55'!
asMethodDefinition
	^ MCMethodDefinition forMethodReference: self! !

!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:58'!
category
	^ self actualClass organization categoryOfElement: methodSymbol! !

!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:58'!
compiledMethod
	^ self actualClass compiledMethodAt: methodSymbol! !

!MethodReference methodsFor: '*monticello' stamp: 'al 10/9/2005 20:05'!
isLocalSelector
	^self actualClass
		includesLocalSelector: self methodSymbol! !

!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:59'!
source
	^ (self actualClass sourceCodeAt: methodSymbol) asString withSqueakLineEndings! !

!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:58'!
timeStamp
	^ self compiledMethod timeStamp! !


!MethodReference methodsFor: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58'!
sourceCode
	^ self actualClass sourceCodeAt: methodSymbol! !


!MethodReference methodsFor: '*OB-Standard' stamp: 'dvf 8/19/2005 17:16'!
asNode
	^OBMethodNode on: self! !

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

MethodReference class
	instanceVariableNames: ''!

!MethodReference class methodsFor: 'instance creation' stamp: 'ab 2/6/2005 16:22'!
class: aClass selector: aSelector
	^ self new setStandardClass: aClass methodSymbol: aSelector! !
ClassTestCase subclass: #MethodReferenceTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser-Tests'!

!MethodReferenceTest methodsFor: 'Running' stamp: 'sd 11/20/2005 21:27'!
testEquals
	| aMethodReference anotherMethodReference |
	aMethodReference := MethodReference new.
	anotherMethodReference := MethodReference new.
	" 
	two fresh instances should be equals between them"
	self
		should: [aMethodReference = anotherMethodReference].
	self
		should: [aMethodReference hash = anotherMethodReference hash].
	" 
	two instances representing the same method (same class and  
	same selector) should be equals"
	aMethodReference setStandardClass: String methodSymbol: #foo.
	anotherMethodReference setStandardClass: String methodSymbol: #foo.
	self
		should: [aMethodReference = anotherMethodReference].
	self
		should: [aMethodReference hash = anotherMethodReference hash] ! !

!MethodReferenceTest methodsFor: 'Running' stamp: 'sd 11/20/2005 21:27'!
testNotEquals
	| aMethodReference anotherMethodReference |
	aMethodReference := MethodReference new.
	anotherMethodReference := MethodReference new.
	""
	aMethodReference setStandardClass: String methodSymbol: #foo.
	anotherMethodReference setStandardClass: String class methodSymbol: #foo.
	" 
	differente classes, same selector -> no more equals"
	self
		shouldnt: [aMethodReference = anotherMethodReference].
	" 
	same classes, diferente selector -> no more equals"
	anotherMethodReference setStandardClass: String methodSymbol: #bar.
	self
		shouldnt: [aMethodReference = anotherMethodReference] ! !
ParseNode subclass: #MethodTempsNode
	instanceVariableNames: 'temporaries'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
MethodInterface subclass: #MethodWithInterface
	instanceVariableNames: 'playerClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!MethodWithInterface commentStamp: '<historical>' prior: 0!
A MethodInterface bound to an actual class.

	selector					A symbol - the selector being described
	argumentSpecifications	A list of specifications for the formal arguments of the method
	resultSpecification 		A characterization of the return value of the method
	userLevel				
	attributeKeywords		A list of symbols, comprising keywords that the user wishes to
								associate with this method
	defaultStatus			The status to apply to new instances of the class by default
	defaultFiresPerTick		How many fires per tick, by default, should be allowed if ticking.
	playerClass				The actual class with which this script is associated!


!MethodWithInterface methodsFor: 'access' stamp: 'sw 3/28/2001 16:25'!
playerClass
	"Answer the playerClass associated with the receiver.  Note: fixes up cases where the playerClass slot was a Playerxxx object because of an earlier bug"

	^ (playerClass isKindOf: Class)
		ifTrue:
			[playerClass]
		ifFalse:
			[playerClass _ playerClass class]! !


!MethodWithInterface methodsFor: 'initialization' stamp: 'sw 1/30/2001 11:37'!
convertFromUserScript: aUserScript
	"The argument represents an old UserScript object.  convert it over"

	defaultStatus _ aUserScript status.! !

!MethodWithInterface methodsFor: 'initialization' stamp: 'sw 1/26/2001 16:44'!
initialize
	"Initialize the receiver by setting its inst vars to default values"

	super initialize.
	defaultStatus _ #normal! !

!MethodWithInterface methodsFor: 'initialization' stamp: 'sw 2/20/2001 03:29'!
isTextuallyCoded
	"Answer whether the receiver is in a textually-coded state.  A leftover from much earlier times, this is a vacuous backstop"

	^ false! !

!MethodWithInterface methodsFor: 'initialization' stamp: 'sw 9/12/2001 11:59'!
playerClass: aPlayerClass selector: aSelector
	"Set the playerClass and selector of the receiver"

	playerClass _ aPlayerClass.
	selector _ aSelector.! !

!MethodWithInterface methodsFor: 'initialization' stamp: 'nk 7/2/2004 07:18'!
status
	^defaultStatus
! !


!MethodWithInterface methodsFor: 'rename' stamp: 'sw 2/17/2001 04:10'!
okayToRename
	"Answer whether the receiver is in a state to be renamed."

	^ true! !

!MethodWithInterface methodsFor: 'rename' stamp: 'sw 3/11/2003 00:01'!
renameScript: newSelector fromPlayer: aPlayer
	"The receiver's selector has changed to the new selector.  Get various things right, including the physical appearance of any Scriptor open on this method"

	self allScriptEditors do:
		[:aScriptEditor | aScriptEditor renameScriptTo: newSelector].

	(selector numArgs = 0 and: [newSelector numArgs = 1])
		ifTrue:
			[self argumentVariables: (OrderedCollection with:
				(Variable new name: #parameter type: #Number))].
	(selector numArgs = 1 and: [newSelector numArgs = 0])
		ifTrue:
			[self argumentVariables: OrderedCollection new].

	selector _ newSelector asSymbol.
	self bringUpToDate.
	self playerClass atSelector: selector putScript: self.
	self allScriptActivationButtons do:
		[:aButton | aButton bringUpToDate].

! !


!MethodWithInterface methodsFor: 'script editor' stamp: 'sw 3/10/2003 23:58'!
allScriptActivationButtons
	"Answer all the script-activation buttons that exist for this interface"

	^ ScriptActivationButton allInstances select: 
		[:aButton | aButton uniclassScript == self]! !

!MethodWithInterface methodsFor: 'script editor' stamp: 'sw 3/28/2001 16:26'!
allScriptEditors
	"Answer all the script editors that exist for the class and selector of this interface"

	^ ScriptEditorMorph allInstances select: 
		[:aScriptEditor | aScriptEditor playerScripted class == self playerClass and:
			[aScriptEditor scriptName == selector]]! !

!MethodWithInterface methodsFor: 'script editor' stamp: 'sw 2/17/2001 03:28'!
currentScriptEditor: anEditor
	"Set the receiver's currentScriptEditor as indicated, if I care.  MethodWithInterface does not care, since it does not hold on to a ScriptEditor.  A subclass of mine, however does, or did, care"! !

!MethodWithInterface methodsFor: 'script editor' stamp: 'sw 3/28/2001 16:26'!
instantiatedScriptEditorForPlayer: aPlayer
	"Return a new script editor for the player and selector"

	| aScriptEditor |
	aScriptEditor _ (self playerClass includesSelector: selector) 
			ifTrue: [ScriptEditorMorph new 
				fromExistingMethod: selector 
				forPlayer: aPlayer]
			ifFalse: [ScriptEditorMorph new
				setMorph: aPlayer costume
				scriptName: selector].
		defaultStatus == #ticking ifTrue:
			[aPlayer costume arrangeToStartStepping].
	
	^ aScriptEditor! !

!MethodWithInterface methodsFor: 'script editor' stamp: 'sw 7/28/2001 01:00'!
recompileScriptFromTilesUnlessTextuallyCoded
	"Recompile Script From Tiles Unless Textually Coded.  For the universal-tiles MethodWithInterface case, this is moot.  Used only in support of a reintegration of Open-school forked projects from Sept 2000 in 7/01"! !


!MethodWithInterface methodsFor: 'updating' stamp: 'sw 3/28/2001 16:26'!
bringUpToDate
	"Bring all scriptors related to this method up to date.  Note that this will not change the senders of this method if the selector changed -- that's something still ahead."

	(ScriptEditorMorph allInstances select:
		[:m | (m playerScripted isMemberOf: self playerClass) and: [m scriptName == selector]])
			do:
				[:m | m bringUpToDate]! !

!MethodWithInterface methodsFor: 'updating' stamp: 'sw 2/20/2001 03:43'!
revertToLastSavedTileVersionFor: anEditor
	"revert to the last saved tile version.  Only for universal tiles."

	anEditor removeAllButFirstSubmorph.
	anEditor insertUniversalTiles.
	anEditor showingMethodPane: false! !

!MethodWithInterface methodsFor: 'updating' stamp: 'sw 2/20/2001 03:41'!
saveScriptVersion: timeStamp
	"Save the tile script version if I do that sort of thing"! !
AlignmentMorph subclass: #MidiInputMorph
	instanceVariableNames: 'midiPortNumber midiSynth instrumentSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MidiInputMorph commentStamp: '<historical>' prior: 0!
I am the user interface for a simple software MIDI synthesizer that is driven by external MIDI input. I come with controls for a single MIDI channel (channel 1), but allow channel controls for additional MIDI channels to be added by the user. The volume, pan, and instrument of each channel can be controlled independently.
!


!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
addChannel
	"Add a set of controls for another channel. Prompt the user for the channel number."

	| menu existingChannels newChannel |
	menu := CustomMenu new.
	existingChannels := Set new.
	1 to: 16 do: [:ch | (instrumentSelector at: ch) ifNotNil: [existingChannels add: ch]].
	1 to: 16 do: [:ch |
		(existingChannels includes: ch) ifFalse: [
			menu add: ch printString action: ch]].
	newChannel := menu startUp.
	newChannel ifNotNil: [self addChannelControlsFor: newChannel].
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
addChannelControlsFor: channelIndex

	| r divider col |
	r := self makeRow
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	r addMorphBack: (self channelNumAndMuteButtonFor: channelIndex).
	r addMorphBack: (Morph new extent: 10@5; color: color).  "spacer"
	r addMorphBack: (self panAndVolControlsFor: channelIndex).

	divider := AlignmentMorph new
		extent: 10@1;
		borderWidth: 1;
		layoutInset: 0;
		borderColor: #raised;
		color: color;
		hResizing: #spaceFill;
		vResizing: #rigid.

	col := self lastSubmorph.
	col addMorphBack: divider.
	col addMorphBack: r.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'gm 2/28/2003 00:00'!
atChannel: channelIndex from: aPopUpChoice selectInstrument: selection 
	| oldSnd name snd instSelector |
	oldSnd := midiSynth instrumentForChannel: channelIndex.
	(selection beginsWith: 'edit ') 
		ifTrue: 
			[name := selection copyFrom: 6 to: selection size.
			aPopUpChoice contentsClipped: name.
			(oldSnd isKindOf: FMSound) | (oldSnd isKindOf: LoopedSampledSound) 
				ifTrue: [EnvelopeEditorMorph openOn: oldSnd title: name].
			(oldSnd isKindOf: SampledInstrument) 
				ifTrue: [EnvelopeEditorMorph openOn: oldSnd allNotes first title: name].
			^self].
	snd := nil.
	1 to: instrumentSelector size
		do: 
			[:i | 
			(channelIndex ~= i and: 
					[(instSelector := instrumentSelector at: i) notNil 
						and: [selection = instSelector contents]]) 
				ifTrue: [snd := midiSynth instrumentForChannel: i]].	"use existing instrument prototype"
	snd ifNil: 
			[snd := (selection = 'clink' 
						ifTrue: 
							[(SampledSound samples: SampledSound coffeeCupClink samplingRate: 11025)]
						ifFalse: [(AbstractSound soundNamed: selection) ])copy ].
	midiSynth instrumentForChannel: channelIndex put: snd.
	(instrumentSelector at: channelIndex) contentsClipped: selection! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
channelNumAndMuteButtonFor: channelIndex

	| muteButton instSelector r |
	muteButton := SimpleSwitchMorph new
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		offColor: color;
		color: color;
		label: 'Mute';
		target: midiSynth;
		actionSelector: #mutedForChannel:put:;
		arguments: (Array with: channelIndex).
	instSelector := PopUpChoiceMorph new
		extent: 95@14;
		contentsClipped: 'oboe1';
		target: self;
		actionSelector: #atChannel:from:selectInstrument:;
		getItemsSelector: #instrumentChoicesForChannel:;
		getItemsArgs: (Array with: channelIndex).
	instSelector arguments:
		(Array with: channelIndex with: instSelector).
	instrumentSelector at: channelIndex put: instSelector.

	r := self makeRow
		hResizing: #rigid;
		vResizing: #spaceFill;
		extent: 70@10.
	r addMorphBack:
		(StringMorph
			contents: channelIndex printString
			font: (TextStyle default fontOfSize: 24)).
	channelIndex < 10
		ifTrue: [r addMorphBack: (Morph new color: color; extent: 19@8)]  "spacer"
		ifFalse: [r addMorphBack: (Morph new color: color; extent: 8@8)].  "spacer"
	r addMorphBack: instSelector.
	r addMorphBack: (AlignmentMorph newRow color: color).  "spacer"
	r addMorphBack: muteButton.
	^ r
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/13/1999 07:33'!
closeMIDIPort

	midiSynth isOn ifTrue: [midiSynth stopMIDITracking].
	midiSynth closeMIDIPort.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 07:55'!
disableReverb: aBoolean

	aBoolean
		ifTrue: [SoundPlayer stopReverb]
		ifFalse: [SoundPlayer startReverb].
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
instrumentChoicesForChannel: channelIndex

	| names inst |
	names := AbstractSound soundNames asOrderedCollection.
	names := names collect: [:n |
		inst := AbstractSound soundNamed: n.
		(inst isKindOf: UnloadedSound)
			ifTrue: [n, '(out)']
			ifFalse: [n]].
	names add: 'clink'.
	names add: 'edit ', (instrumentSelector at: channelIndex) contents.
	^ names asArray
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
invokeMenu
	"Invoke a menu of additonal commands."

	| aMenu |
	aMenu := CustomMenu new.
	aMenu add: 'add channel' translated action: #addChannel.
	aMenu add: 'reload instruments' translated target: AbstractSound selector: #updateScorePlayers.
	midiSynth isOn ifFalse: [
		aMenu add: 'set MIDI port' translated action: #setMIDIPort.
		midiSynth midiPort
			ifNotNil: [aMenu add: 'close MIDI port' translated action: #closeMIDIPort]].	
	aMenu invokeOn: self defaultSelection: nil.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
makeControls

	| bb r reverbSwitch onOffSwitch |
	bb := SimpleButtonMorph new
		target: self;
		borderColor: #raised;
		borderWidth: 2;
		color: color.
	r := AlignmentMorph newRow.
	r color: bb color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (
		bb label: '<>';
			actWhen: #buttonDown;
			actionSelector: #invokeMenu).
	onOffSwitch := SimpleSwitchMorph new
		offColor: color;
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		borderWidth: 2;
		label: 'On';
		actionSelector: #toggleOnOff;
		target: self;
		setSwitchState: false.
	r addMorphBack: onOffSwitch.
	reverbSwitch := SimpleSwitchMorph new
		offColor: color;
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		borderWidth: 2;
		label: 'Reverb Disable';
		actionSelector: #disableReverb:;
		target: self;
		setSwitchState: SoundPlayer isReverbOn not.
	r addMorphBack: reverbSwitch.
	^ r
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:19'!
makeRow

	^ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
panAndVolControlsFor: channelIndex

	| volSlider panSlider c r middleLine |
	volSlider := SimpleSliderMorph new
		color: color;
		extent: 101@2;
		target: midiSynth;
		arguments: (Array with: channelIndex);
		actionSelector: #volumeForChannel:put:;
		minVal: 0.0;
		maxVal: 1.0;
		adjustToValue: (midiSynth volumeForChannel: channelIndex).
	panSlider := SimpleSliderMorph new
		color: color;
		extent: 101@2;
		target: midiSynth;
		arguments: (Array with: channelIndex);
		actionSelector: #panForChannel:put:;
		minVal: 0.0;
		maxVal: 1.0;		
		adjustToValue: (midiSynth panForChannel: channelIndex).
	c := AlignmentMorph newColumn
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap.
	middleLine := Morph new  "center indicator for pan slider"
		color: (Color r: 0.4 g: 0.4 b: 0.4);
		extent: 1@(panSlider height - 4);
		position: panSlider center x@(panSlider top + 2).
	panSlider addMorphBack: middleLine.
	r := self makeRow.
	r addMorphBack: (StringMorph contents: '0').
	r addMorphBack: volSlider.
	r addMorphBack: (StringMorph contents: '10').
	c addMorphBack: r.
	r := self makeRow.
	r addMorphBack: (StringMorph contents: 'L').
	r addMorphBack: panSlider.
	r addMorphBack: (StringMorph contents: 'R').
	c addMorphBack: r.
	^ c
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
setMIDIPort

	| portNum |
	portNum := SimpleMIDIPort outputPortNumFromUser.
	portNum ifNil: [^ self].
	midiPortNumber := portNum.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
toggleOnOff

	midiSynth isOn
		ifTrue: [
			midiSynth stopMIDITracking]
		ifFalse: [
			midiPortNumber ifNil: [self setMIDIPort].
			midiPortNumber ifNil: [midiPortNumber := 0].
			midiSynth midiPort: (SimpleMIDIPort openOnPortNumber: midiPortNumber).
			midiSynth startMIDITracking].
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateInstrumentsFromLibraryExcept: soundsBeingEdited
	"The instrument library has been modified. Update my instruments with the new versions from the library. Use a single instrument prototype for all parts with the same name; this allows the envelope editor to edit all the parts by changing a single sound prototype."

	"soundsBeingEdited is a collection of sounds being edited (by an EnvelopeEditor).  If any of my instruments share one of these, then they will be left alone so as not to disturb that dynamic linkage."

	| unloadPostfix myInstruments name displaysAsUnloaded isUnloaded |
	unloadPostfix := '(out)'.
	myInstruments := Dictionary new.
	1 to: instrumentSelector size do: [:i |
		name := (instrumentSelector at: i) contents.
		displaysAsUnloaded := name endsWith: unloadPostfix.
		displaysAsUnloaded ifTrue: [
			name := name copyFrom: 1 to: name size - unloadPostfix size].
		(myInstruments includesKey: name) ifFalse: [
			myInstruments at: name put:
				(name = 'clink'
					ifTrue: [
						(SampledSound
							samples: SampledSound coffeeCupClink
							samplingRate: 11025) copy]
					ifFalse: [
						(AbstractSound
							soundNamed: name
							ifAbsent: [
								(instrumentSelector at: i) contentsClipped: 'default'.
								FMSound default]) copy])].
		(soundsBeingEdited includes: (midiSynth instrumentForChannel: i)) ifFalse:
			["Do not update any instrument that is currently being edited"
			midiSynth instrumentForChannel: i put: (myInstruments at: name)].

		"update loaded/unloaded status in instrumentSelector if necessary"
		isUnloaded := (myInstruments at: name) isKindOf: UnloadedSound.
		(displaysAsUnloaded and: [isUnloaded not])
			ifTrue: [(instrumentSelector at: i) contentsClipped: name].
		(displaysAsUnloaded not and: [isUnloaded])
			ifTrue: [(instrumentSelector at: i) contentsClipped: name, unloadPostfix]].
! !


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

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

!MidiInputMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
	  wrapCentering: #center;
		 cellPositioning: #topCenter;
	  hResizing: #spaceFill;
	  vResizing: #spaceFill;
	  layoutInset: 3.
	midiPortNumber := nil.
	midiSynth := MIDISynth new.
	instrumentSelector := Array new: 16.
	self removeAllMorphs.
	self addMorphBack: self makeControls.
	self addMorphBack: (AlignmentMorph newColumn color: color;
			 layoutInset: 0).
	self addChannelControlsFor: 1.
	self extent: 20 @ 20! !
Object subclass: #MidiPrimTester
	instanceVariableNames: 'port'
	classVariableNames: 'CanSetClock CanUseSemaphore ClockTicksPerSec EchoOn EventsAvailable FlushDriver HasBuffer HasDurs HasInputClock Installed UseControllerCache Version'
	poolDictionaries: ''
	category: 'System-Serial Port'!
!MidiPrimTester commentStamp: '<historical>' prior: 0!
This class simply demonstrates and tests the MIDI primitives. MIDI applications should use Stephen Pope's MIDIPort class, which will replace this one.

The Macintosh, and perhaps some other platforms, can send and receive MIDI data over a serial port by using an external clock signal supplied by an external MIDI adapter to generate the correct MIDI baud rate. Typical clock speeds of such adapters are 1, 2, or 0.5 MHz. This clock speed can be specified when a MIDI port is opened. On other platforms, this clock speed parameter is ignored.
!


!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIClosePort: portNum

	<primitive: 'primitiveMIDIClosePort' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIGetClock

	<primitive: 'primitiveMIDIGetClock' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIGetPortCount

	<primitive: 'primitiveMIDIGetPortCount' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIGetPortDirectionality: portNum

	<primitive: 'primitiveMIDIGetPortDirectionality' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIGetPortName: portNum

	<primitive: 'primitiveMIDIGetPortName' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIOpenPort: portNum readSemaIndex: readSemaIndex interfaceClockRate: interfaceClockRate
	"Open the given MIDI port. If non-zero, readSemaIndex specifies the index in the external objects array of a semaphore to be signalled when incoming MIDI data is available. Not all platforms support signalling the read semaphore. InterfaceClockRate specifies the clock rate of the external MIDI interface adaptor on Macintosh computers; it is ignored on other platforms."

	<primitive: 'primitiveMIDIOpenPort' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIParameterGet: whichParameter

	<primitive: 'primitiveMIDIParameterGetOrSet' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIParameterSet: whichParameter to: newValue

	<primitive: 'primitiveMIDIParameterGetOrSet' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIReadPort: portNum into: byteArray

	<primitive: 'primitiveMIDIRead' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIWritePort: portNum from: byteArray at: midiClockValue

	<primitive: 'primitiveMIDIWrite' module: 'MIDIPlugin'>
	self primitiveFailed.
! !


!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 10:30'!
getDriverParameters
	"Return a string that describes this platform's MIDI parameters."
	"MidiPrimTester new getDriverParameters"

	| s parameterNames v |
	parameterNames _ #(Installed Version HasBuffer HasDurs CanSetClock CanUseSemaphore EchoOn UseControllerCache EventsAvailable FlushDriver ClockTicksPerSec HasInputClock).

	s _ WriteStream on: String new.
	s cr.
	1 to: parameterNames size do: [:i |
		v _ self primMIDIParameterGet: i.
		s nextPutAll: (parameterNames at: i).
		s nextPutAll: ' = '.
		s print: v; cr].

	s nextPutAll: 'MIDI Echoing is '.
	(self canTurnOnParameter: EchoOn)
		ifTrue: [s nextPutAll: 'supported.'; cr]
		ifFalse: [s nextPutAll: 'not supported.'; cr].

	s nextPutAll: 'Controller Caching is '.
	(self canTurnOnParameter: UseControllerCache)
		ifTrue: [s nextPutAll: 'supported.'; cr]
		ifFalse: [s nextPutAll: 'not supported.'; cr].

	^ s contents
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 15:33'!
getInputForSeconds: seconds onPort: portNum
	"Collect MIDI input from the given port for the given number of seconds, and answer a string describing the data read."
	"MidiPrimTester new getInputForSeconds: 5 onPort: 0"

	| buf bufList endTime n midiStartTime s t |
	"collect the data"
	self openPort: portNum andDo: [
		buf _ ByteArray new: 1000.
		bufList _ OrderedCollection new.
		midiStartTime _ self primMIDIGetClock.
		endTime _ Time millisecondClockValue + (seconds * 1000).
		[Time millisecondClockValue < endTime] whileTrue: [
			n _ self primMIDIReadPort: portNum into: buf.
			n > 0 ifTrue: [bufList add: (buf copyFrom: 1 to: n)].
			(Delay forMilliseconds: 5) wait]].

	"format the data into a string"
	s _ WriteStream on: String new.
	s cr.
	bufList do: [:b |
		t _ (self bufferTimeStampFrom: b) - midiStartTime.
		s print: t.
		s nextPutAll: ': '.
		5 to: b size do: [:i | s print: (b at: i); space].
		s cr].
	^ s contents
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 10:05'!
getPortList
	"Return a string that describes this platform's MIDI ports."
	"MidiPrimTester new getPortList"

	| s portCount dir directionString |
	s _ WriteStream on: String new.
	s cr; nextPutAll: 'MIDI Ports:'; cr.
	portCount _ self primMIDIGetPortCount.
	0 to: portCount - 1 do: [:i |
		s tab.
		s print: i; nextPutAll: ': '. 
		s nextPutAll: (self primMIDIGetPortName: i).
		dir _ self primMIDIGetPortDirectionality: i.
		directionString _ dir printString.  "default"
		dir = 1 ifTrue: [directionString _ '(in)'].
		dir = 2 ifTrue: [directionString _ '(out)'].
		dir = 3 ifTrue: [directionString _ '(in/out)'].
		s space; nextPutAll: directionString; cr].
	^ s contents
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 11:24'!
playDrumRoll: mSecsBetweenNotes count: tapCount onPort: portNum
	"MidiPrimTester new playDrumRoll: 75 count: 64 onPort: 0"
	"Play middle-C tapCount times with the given space between notes. This example works best with a short percussive voice, like a drum."
	"Details: This test can be used to investigate the real-time performance of your system. On a 110 MHz PowerPC Mac, this method can genererate very fast and smooth drum rolls up to about 100 beats/sec (10 mSecs between notes). However, many factors can prevent one from seeing this level of performance including a slow CPU, lack of a level-2 cache, networking or other background processes stealing chunks of processor time from Squeak, or a sluggish MIDI synthesizer."
	"Details: By default, this method does an incremental GC on every note. While not really needed for this example, it illustrates a useful technique for real-time processing in Squeak: do an incremental GC when you know you have a few milliseconds of idle time to avoid triggering one during a time-critical task. In this case, we're also using the GC time to provide a small delay between the note-on and note-off events. If the GC time is too short, as it could be on a fast machine, the note may not sound at all unless you add a few milliseconds of additional delay!!"
	"Note: This example works best if the VM's millisecond clock has 1 millisecond resolution."

	| gcDuringNote noteOn noteOff endTime waitTime |
	gcDuringNote _ true.
	"these events use running status, so the command byte is omitted"
	noteOn _ #(60 100) as: ByteArray.
	noteOff _ #(60 0) as: ByteArray.
	self primMIDIOpenPort: portNum readSemaIndex: 0 interfaceClockRate: 1000000.

	"send an initial event with command byte to initiate running status"
	self primMIDIWritePort: portNum from: (#(144 60 0) as: ByteArray) at: 0.

	1 to: tapCount do: [:i |
		endTime _ Time millisecondClockValue + mSecsBetweenNotes.
		self primMIDIWritePort: portNum from: noteOn at: 0.
		gcDuringNote
			ifTrue: [
				"do quick GC; takes a few milliseconds and provides the note-down time"
				"Note: if GC is too fast on your machine, you need to add a few mSecs delay!!"
				Smalltalk garbageCollectMost]
			ifFalse: [(Delay forMilliseconds: 3) wait].

		self primMIDIWritePort: portNum from: noteOff at: 0.
		waitTime _ endTime - Time millisecondClockValue.
		waitTime > 0 ifTrue: [(Delay forMilliseconds: waitTime) wait]].

	self primMIDIClosePort: portNum.
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 15:16'!
playNoteOnPort: portNum
	"MidiPrimTester new playNoteOnPort: 0"

	| noteOn noteOff bytesWritten |
	noteOn _ #(144 60 100) as: ByteArray.
	noteOff _ #(144 60 0) as: ByteArray.
	self openPort: portNum andDo: [
		bytesWritten _ self primMIDIWritePort: portNum from: noteOn at: 0.
		(Delay forMilliseconds: 500) wait.
		bytesWritten _ bytesWritten + (self primMIDIWritePort: portNum from: noteOff at: 0)].

	bytesWritten = 6 ifFalse: [self error: 'not all bytes were sent'].
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 15:17'!
playScale: mSecsPerNote onPort: portNum
	"MidiPrimTester new playScale: 130 onPort: 0"

	| noteOn noteOff |
	noteOn _ #(144 0 100) as: ByteArray.
	noteOff _ #(144 0 0) as: ByteArray.
	self openPort: portNum andDo: [
		#(60 62 64 65 67 69 71 72 74 72 71 69 67 65 64 62 60) do: [:midiKey | 
			noteOn at: 2 put: midiKey.
			noteOff at: 2 put: midiKey.
			self primMIDIWritePort: portNum from: noteOn at: 0.
			(Delay forMilliseconds: mSecsPerNote - 10) wait.
			self primMIDIWritePort: portNum from: noteOff at: 0.
			(Delay forMilliseconds: 10) wait]].
! !


!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 12:48'!
bufferTimeStampFrom: aByteArray
	"Return the timestamp from the given MIDI input buffer. Assume the given buffer is at least 4 bytes long."

	^ ((aByteArray at: 1) bitShift: 24) +
	  ((aByteArray at: 2) bitShift: 16) +
	  ((aByteArray at: 3) bitShift: 8) +
	   (aByteArray at: 4)
! !

!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 12:48'!
canTurnOnParameter: whichParameter
	"Return true if the given MIDI parameter can be turned on. Leave the parameter in its orginal state."

	| old canSet |
	old _ self primMIDIParameterGet: whichParameter.
	self primMIDIParameterSet: whichParameter to: 1.
	canSet _ (self primMIDIParameterGet: whichParameter) = 1.
	self primMIDIParameterSet: whichParameter to: old.
	^ canSet
! !

!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 15:32'!
openPort: portNum andDo: aBlock
	"Open the given MIDI port, evaluate the block, and close the port again. Answer the value of the block."

	| result |
	self primMIDIClosePort: portNum.
	self primMIDIOpenPort: portNum readSemaIndex: 0 interfaceClockRate: 1000000.
	result _ aBlock value.
	self primMIDIClosePort: portNum.
	^ result
! !

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

MidiPrimTester class
	instanceVariableNames: ''!

!MidiPrimTester class methodsFor: 'class initialization' stamp: 'yo 12/3/2004 17:05'!
initialize
	"Initialize the MIDI parameter constants."
	"MidiPrimTester initialize"

	Installed _ 1.
		"Read-only. Return 1 if a MIDI driver is installed, 0 if not.
		 On OMS-based MIDI drivers, this returns 1 only if the OMS
		 system is properly installed and configured."

	Version _ 2.
		"Read-only. Return the integer version number of this MIDI driver.
		 The version numbering sequence is relative to a particular driver.
		 That is, version 3 of the Macintosh MIDI driver is not necessarily
		 related to version 3 of the Win95 MIDI driver."

	HasBuffer _ 3.
		"Read-only. Return 1 if this MIDI driver has a time-stamped output
		 buffer, 0 otherwise. Such a buffer allows the client to schedule
		 MIDI output packets to be sent later. This can allow more precise
		 timing, since the driver uses timer interrupts to send the data
		 at the right time even if the processor is in the midst of a
		 long-running Squeak primitive or is running some other application
		 or system task."

	HasDurs _ 4.
		"Read-only. Return 1 if this MIDI driver supports an extended
		 primitive for note-playing that includes the note duration and
		 schedules both the note-on and the note-off messages in the
		 driver. Otherwise, return 0."

	CanSetClock _ 5.
		"Read-only. Return 1 if this MIDI driver's clock can be set
		 via an extended primitive, 0 if not."

	CanUseSemaphore _ 6.
		"Read-only. Return 1 if this MIDI driver can signal a semaphore
		 when MIDI input arrives. Otherwise, return 0. If this driver
		 supports controller caching and it is enabled, then incoming
		 controller messages will not signal the semaphore."

	EchoOn _ 7.
		"Read-write. If this flag is set to a non-zero value, and if
		 the driver supports echoing, then incoming MIDI events will
		 be echoed immediately. If this driver does not support echoing,
		 then queries of this parameter will always return 0 and
		 attempts to change its value will do nothing."

	UseControllerCache _ 8.
		"Read-write. If this flag is set to a non-zero value, and if
		 the driver supports a controller cache, then the driver will
		 maintain a cache of the latest value seen for each MIDI controller,
		 and control update messages will be filtered out of the incoming
		 MIDI stream. An extended MIDI primitive allows the client to
		 poll the driver for the current value of each controller. If
		 this driver does not support a controller cache, then queries
		 of this parameter will always return 0 and attempts to change
		 its value will do nothing."

	EventsAvailable _ 9.
		"Read-only. Return the number of MIDI packets in the input queue."

	FlushDriver _ 10.
		"Write-only. Setting this parameter to any value forces the driver
		 to flush its I/0 buffer, discarding all unprocessed data. Reading
		 this parameter returns 0. Setting this parameter will do nothing
		 if the driver does not support buffer flushing."

	ClockTicksPerSec _ 11.
		"Read-only. Return the MIDI clock rate in ticks per second."

	HasInputClock _ 12.
		"Read-only. Return 1 if this MIDI driver timestamps incoming
		 MIDI data with the current value of the MIDI clock, 0 otherwise.
		 If the driver does not support such timestamping, then the
		 client must read input data frequently and provide its own
		 timestamping."
! !
Object subclass: #MimeConverter
	instanceVariableNames: 'dataStream mimeStream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

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

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

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

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


!MimeConverter methodsFor: 'conversion' stamp: 'bf 11/12/1998 13:30'!
mimeDecode
	"Do conversion reading from mimeStream writing to dataStream"

	self subclassResponsibility! !

!MimeConverter methodsFor: 'conversion' stamp: 'bf 11/12/1998 13:31'!
mimeEncode
	"Do conversion reading from dataStream writing to mimeStream"

	self subclassResponsibility! !

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

MimeConverter class
	instanceVariableNames: ''!

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:47'!
forEncoding: encodingString
	"Answer a converter class for the given encoding or nil if unknown"
	encodingString ifNil: [^nil].
	^ encodingString asLowercase caseOf: 
		{ ['base64'] -> [Base64MimeConverter].
		  ['quoted-printable'] -> [QuotedPrintableMimeConverter]}
		otherwise: [].
! !

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:43'!
mimeDecode: aStringOrStream as: contentsClass
	^ contentsClass streamContents: [:out |
		self mimeDecode: aStringOrStream to: out]! !

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:40'!
mimeDecode: aStringOrStream to: outStream
	self new
		mimeStream: (aStringOrStream isStream
			ifTrue: [aStringOrStream]
			ifFalse: [ReadStream on: aStringOrStream]);
		dataStream: outStream;
		mimeDecode! !

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:40'!
mimeEncode: aCollectionOrStream
	^ String streamContents: [:out |
		self mimeEncode: aCollectionOrStream to: out]! !

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:40'!
mimeEncode: aCollectionOrStream to: outStream
	self new
		dataStream: (aCollectionOrStream isStream
			ifTrue: [aCollectionOrStream]
			ifFalse: [ReadStream on: aCollectionOrStream]);
		mimeStream: outStream;
		mimeEncode! !
PolygonMorph subclass: #MixedCurveMorph
	instanceVariableNames: 'slopeClamps'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic-NewCurve'!
!MixedCurveMorph commentStamp: '<historical>' prior: 0!
A MixedCurveMorph is Curve that can be broken up into separately curved segments. It allows for the creation of matching edges( e. g. for jigsaw puzzle pieces).

Instance Variables
	slopeClamps:		<Array>

slopeClamps
	- elements of array are either 0 or nil. Indicating whether slope for the corresponding vertex is 0@0 or unknown and therefore to be calculated. There is one element for each vertex.
	
	
!


!MixedCurveMorph methodsFor: 'access' stamp: 'wiz 2/8/2006 18:59'!
clamps
" Return a collection of clamps the same size as vertices.
	If necessary default to unclamped slopes.
"

slopeClamps 
	ifNil:   [ ^ slopeClamps := Array new: vertices size  ] .
slopeClamps size = vertices size
	ifFalse: [ ^ slopeClamps := Array new: vertices size  ] . 
	^ slopeClamps           ! !

!MixedCurveMorph methodsFor: 'access' stamp: 'wiz 2/8/2006 17:44'!
handleColorAt: vertIndex
      " clamped handles are cyan     and 
	unclamped handles are yellow."

(self clamps at: vertIndex ) ifNil: [ ^ Color yellow ] .
^ Color cyan 
! !


!MixedCurveMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 17:50'!
clickVertex: ix event: evt fromHandle: handle
" Toggle the state of the clamp. "
"Note: self clamps assures slopeClamps will be same size as vertices"

(self clamps at: ix) 
	ifNil:	 [ slopeClamps  at: ix put: 0 ]
	ifNotNil: [ slopeClamps  at: ix put: nil ] .
	self setVertices: vertices .
	
! !

!MixedCurveMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:01'!
deleteVertexAt: anIndex
			(slopeClamps :=
						slopeClamps
						copyReplaceFrom: anIndex
						to: anIndex
						with: Array new) .
			self
				setVertices: (vertices
						copyReplaceFrom: anIndex
						to: anIndex
						with: Array new).
						! !

!MixedCurveMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:29'!
insertVertexAt: anIndex put: aValue
	"New vertexs are unclamped."
	"Note: order is important. 
	The clamps array must match vertex size before setVertices: is performed."
	slopeClamps := slopeClamps 
		copyReplaceFrom: anIndex + 1 to: anIndex with: (Array with: nil).
	self setVertices: (vertices copyReplaceFrom: anIndex + 1 to: anIndex 
									with: (Array with: aValue)).! !


!MixedCurveMorph methodsFor: 'initialization' stamp: 'wiz 2/12/2006 05:59'!
initialize
"initialize the state of the receiver"
	super initialize.
	self extent: 32@20 .

	self rectOval.
	self clamps . "This initializes slopeClamps."
	slopeClamps at: 1 put: 0 .
	slopeClamps at: 4 put: 0 .
	
	closed _ true.
	smoothCurve _ true.
	arrows _ #none.
	self computeBounds! !


!MixedCurveMorph methodsFor: 'smoothing' stamp: 'wiz 2/18/2006 12:53'!
slopes: knots 
	"Choose slopes according to state of polygon and preferences"
	self isCurvy
		ifFalse: [^ knots segmentedSlopes].
	^ (closed
			and: [self isCurvier])
		ifTrue: [ knots closedCubicSlopes: self clamps ]
		ifFalse: [knots naturalCubicSlopes: self clamps ]! !

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

MixedCurveMorph class
	instanceVariableNames: ''!

!MixedCurveMorph class methodsFor: 'as yet unclassified' stamp: 'wiz 2/12/2006 17:12'!
descriptionForPartsBin
	^ self partName:	'Mixed'
		categories:		#('Graphics' 'Basic')
		documentation:	'A Curve with optional bends and segments. Shift click to get handles.
			Click handles to change bends. Move handles to move the points.'! !
AbstractSound subclass: #MixedSound
	instanceVariableNames: 'sounds leftVols rightVols soundDone'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!MixedSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration
	"Answer the duration of this sound in seconds."

	| dur |
	dur := 0.
	sounds do: [:snd | dur := dur max: snd duration].
	^ dur
! !

!MixedSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 20:23'!
isStereo

	^ true
! !

!MixedSound methodsFor: 'accessing' stamp: 'jm 2/4/98 13:37'!
sounds

	^ sounds
! !


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

	^ self add: aSound
! !

!MixedSound methodsFor: 'composition' stamp: 'jm 1/5/98 13:47'!
add: aSound
	"Add the given sound with a pan setting of centered and no attenuation."

	self add: aSound pan: 0.5 volume: 1.0.
! !

!MixedSound methodsFor: 'composition' stamp: 'jm 1/5/98 13:47'!
add: aSound pan: leftRightPan
	"Add the given sound with the given left-right panning and no attenuation."

	self add: aSound pan: leftRightPan volume: 1.0.
! !

!MixedSound methodsFor: 'composition' stamp: 'stephaneducasse 2/4/2006 20:41'!
add: aSound pan: leftRightPan volume: volume
	"Add the given sound with the given left-right pan, where 0.0 is full left, 1.0 is full right, and 0.5 is centered. The loudness of the sound will be scaled by volume, which ranges from 0 to 1.0."

	| pan vol |
	pan := ((leftRightPan * ScaleFactor) asInteger max: 0) min: ScaleFactor.
	vol := ((volume * ScaleFactor) asInteger max: 0) min: ScaleFactor.
	sounds := sounds copyWith: aSound.
	leftVols := leftVols copyWith: ((ScaleFactor - pan) * vol) // ScaleFactor.
	rightVols := rightVols copyWith: (pan * vol) // ScaleFactor.
! !


!MixedSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:13'!
copy
	"Copy my component sounds."

	^ super copy copySounds
! !

!MixedSound methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:41'!
copySounds
	"Private!! Support for copying. Copy my component sounds and settings array."

	sounds := sounds collect: [:s | s copy].
	leftVols := leftVols copy.
	rightVols := rightVols copy.
! !


!MixedSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	super initialize.
	sounds := Array new.
	leftVols := Array new.
	rightVols := Array new.
! !


!MixedSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:40'!
doControl

	super doControl.
	1 to: sounds size do: [:i | (sounds at: i) doControl].
! !

!MixedSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels."

	| snd left right |
	1 to: sounds size do: [:i |
		(soundDone at: i) ifFalse: [
			snd := sounds at: i.
			left := (leftVol * (leftVols at: i)) // ScaleFactor.
			right := (rightVol * (rightVols at: i)) // ScaleFactor.
			snd samplesRemaining > 0
				ifTrue: [
					snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right]
				ifFalse: [soundDone at: i put: true]]].
! !

!MixedSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset

	super reset.
	sounds do: [:snd | snd reset].
	soundDone := (Array new: sounds size) atAllPut: false.
! !

!MixedSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
samplesRemaining

	| remaining r |
	remaining := 0.
	1 to: sounds size do: [:i |
		r := (sounds at: i) samplesRemaining.
		r > remaining ifTrue: [remaining := r]].

	^ remaining
! !

!MixedSound methodsFor: 'sound generation' stamp: 'jm 1/10/1999 08:45'!
stopGracefully
	"End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes."

	super stopGracefully.
	sounds do: [:s | s stopGracefully].
! !
Stream subclass: #MockSocketStream
	instanceVariableNames: 'atEnd inStream outStream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NetworkTests-Kernel'!

!MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 12:51'!
atEnd: aBoolean
	atEnd := aBoolean.! !

!MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 13:29'!
inStream
	^inStream! !

!MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 13:08'!
outStream
	^outStream! !


!MockSocketStream methodsFor: 'initialize-release' stamp: 'fbs 3/22/2004 13:29'!
initialize
	self resetInStream.
	self resetOutStream.! !


!MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:10'!
nextLine
	^self nextLineCrLf! !

!MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'!
nextLineCrLf
	^(self upToAll: String crlf).! !

!MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:28'!
resetInStream
	inStream := WriteStream on: ''.! !

!MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'!
upToAll: delims
	^self inStream upToAll: delims.! !


!MockSocketStream methodsFor: 'stream out' stamp: 'fbs 3/22/2004 13:28'!
resetOutStream
	outStream := WriteStream on: ''.! !

!MockSocketStream methodsFor: 'stream out' stamp: 'fbs 3/22/2004 13:07'!
sendCommand: aString
	self outStream
		nextPutAll: aString;
		nextPutAll: String crlf.! !


!MockSocketStream methodsFor: 'testing' stamp: 'fbs 3/22/2004 13:08'!
atEnd
	^self inStream atEnd.! !

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

MockSocketStream class
	instanceVariableNames: ''!

!MockSocketStream class methodsFor: 'instance creation' stamp: 'fbs 3/22/2004 12:46'!
on: socket
	^self basicNew initialize! !
Controller subclass: #ModalController
	instanceVariableNames: 'modeActive'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Framework'!
!ModalController commentStamp: '<historical>' prior: 0!
I am a controller that puts the poor user into a mode by not relinquishing control. However, I do pass control onto my underlings. Some underling is expected to end the mode by sending me 'close'. Watch out Larry Tesler, the mode lives on...
!


!ModalController methodsFor: 'as yet unclassified' stamp: 'jm 5/1/1998 07:05'!
close
	"This is how we leave the mode." 

	modeActive _ false.
! !

!ModalController methodsFor: 'as yet unclassified' stamp: 'jm 5/1/1998 07:02'!
controlInitialize

	modeActive _ true.
	^ super controlInitialize
! !

!ModalController methodsFor: 'as yet unclassified' stamp: 'jm 5/1/1998 07:00'!
isControlActive

	^ modeActive
! !

!ModalController methodsFor: 'as yet unclassified' stamp: 'jm 5/1/1998 07:00'!
isControlWanted

	^ modeActive
! !
StandardSystemView subclass: #ModalSystemWindowView
	instanceVariableNames: 'modalBorder'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-FileList'!
!ModalSystemWindowView commentStamp: '<historical>' prior: 0!
I am a view for a Modal System Window.  I vary from StandardSystemView, of which I am a subclass in a few ways:

	(1) I use ModalController as my default controller;
	(2) When asked to update with the symbol #close, I direct the controller to close;
	(3) I display a slightly different title bar with no control boxes.!


!ModalSystemWindowView methodsFor: 'controller access' stamp: 'acg 2/9/2000 00:58'!
defaultControllerClass

	^ModalController! !


!ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/18/2000 20:24'!
display

	super display.
	self displayLabelBackground: false.
	self displayLabelText.
! !

!ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/19/2000 00:59'!
displayBorder
	"Display the receiver's border (using the receiver's borderColor)."

	modalBorder ifFalse: [^super displayBorder].

	Display
		border: self displayBox
		widthRectangle: (1@1 corner: 2@2)
		rule: Form over
		fillColor: Color black.
	Display
		border: (self displayBox insetBy: (1@1 corner: 2@2))
		widthRectangle: (4@4 corner: 3@3)
		rule: Form over
		fillColor: (Color r: 16rEA g: 16rEA b: 16rEA).
! !

!ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/9/2000 07:21'!
displayLabelBoxes
	"Modal dialogs don't have closeBox or growBox."
! !


!ModalSystemWindowView methodsFor: 'initialize-release' stamp: 'acg 2/18/2000 20:41'!
borderWidth: anObject

	modalBorder _ false.
	^super borderWidth: anObject! !

!ModalSystemWindowView methodsFor: 'initialize-release' stamp: 'acg 2/19/2000 00:50'!
initialize 
	"Refer to the comment in View|initialize."
	super initialize.
	self borderWidth: 5.
	self noLabel.
	modalBorder _ true.! !


!ModalSystemWindowView methodsFor: 'label access' stamp: 'acg 2/9/2000 08:35'!
backgroundColor
	^Color lightYellow! !


!ModalSystemWindowView methodsFor: 'modal dialog' stamp: 'BG 12/13/2002 11:33'!
doModalDialog

	| savedArea |
	self resizeInitially.
	self resizeTo: 
		((self windowBox)
			align: self windowBox center
			with: Display boundingBox aboveCenter).
	savedArea _ Form fromDisplay: self windowBox.
	self displayEmphasized.
	self controller startUp.
	self release.
	savedArea displayOn: Display at: self windowOrigin.
! !


!ModalSystemWindowView methodsFor: 'model access' stamp: 'acg 2/9/2000 00:57'!
update: aSymbol
	aSymbol = #close
		ifTrue: [^self controller close].
	^super update: aSymbol! !
Object subclass: #Model
	instanceVariableNames: 'dependents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!Model commentStamp: '<historical>' prior: 0!
Provides a superclass for classes that function as models.  The only behavior provided is fast dependents maintenance, which bypasses the generic DependentsFields mechanism.  1/23/96 sw!


!Model methodsFor: 'copying' stamp: 'tk 10/21/2002 12:59'!
veryDeepFixupWith: deepCopier 
	"See if the dependents are being copied also.  If so, point at the new copies.  (The dependent has self as its model.)
	Dependents handled in class Object, when the model is not a Model, are fixed up in Object veryDeepCopy."

	| originalDependents refs newDependent |
	super veryDeepFixupWith: deepCopier.
	originalDependents _ dependents.
	originalDependents ifNil: [
		^self.
		].
	dependents _ nil.
	refs _ deepCopier references.
	originalDependents
		do: [:originalDependent | 
			newDependent _ refs
						at: originalDependent
						ifAbsent: [].
			newDependent
				ifNotNil: [self addDependent: newDependent]]!
]style[(29 206 19 395)f1b,f1,f1LObject veryDeepCopy;,f1! !

!Model methodsFor: 'copying' stamp: 'RB 9/20/2001 16:25'!
veryDeepInner: deepCopier
	"Shallow copy dependents and fix them later"
! !


!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:26'!
canDiscardEdits
	"Answer true if none of the views on this model has unaccepted edits that matter."

	dependents ifNil: [^ true].
	^ super canDiscardEdits
! !

!Model methodsFor: 'dependents' stamp: 'sw 2/6/2001 04:13'!
containingWindow
	"Answer the window that holds the receiver.  The dependents technique is odious and may not be airtight, if multiple windows have the same model."

	^ self dependents detect:
		[:d | ((d isKindOf: SystemWindow orOf: StandardSystemView) or: [d isKindOf: MVCWiWPasteUpMorph]) and: [d model == self]] ifNone: [nil]! !

!Model methodsFor: 'dependents' stamp: 'jm 3/24/98 15:12'!
hasUnacceptedEdits
	"Answer true if any of the views on this model has unaccepted edits."

	dependents == nil ifTrue: [^ false].
	^ super hasUnacceptedEdits
! !

!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'!
myDependents
	^ dependents! !

!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'!
myDependents: aCollectionOrNil
	dependents _ aCollectionOrNil! !

!Model methodsFor: 'dependents' stamp: 'gm 2/16/2003 20:37'!
topView
	"Find the first top view on me. Is there any danger of their being two with the same model?  Any danger from ungarbage collected old views?  Ask if schedulled?"

	dependents ifNil: [^nil].
	Smalltalk isMorphic 
		ifTrue: 
			[dependents 
				do: [:v | ((v isSystemWindow) and: [v isInWorld]) ifTrue: [^v]].
			^nil].
	dependents do: [:v | v superView ifNil: [v model == self ifTrue: [^v]]].
	^nil! !


!Model methodsFor: 'keyboard' stamp: 'nk 6/29/2004 14:46'!
arrowKey: aChar from: view
	"backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys."
	^false! !


!Model methodsFor: 'menus' stamp: 'di 4/11/98 11:34'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 

	"default is that the editor does all"
	^ otherTarget perform: selector.! !

!Model methodsFor: 'menus' stamp: 'tk 4/17/1998 17:28'!
selectedClass
	"All owners of TextViews are asked this during a doIt"
	^ nil! !

!Model methodsFor: 'menus' stamp: 'zz 3/2/2004 23:49'!
step
	"Default for morphic models is no-op"! !

!Model methodsFor: 'menus' stamp: 'sw 12/15/2000 13:21'!
trash
	"What should be displayed if a trash pane is restored to initial state"

	^ ''! !

!Model methodsFor: 'menus' stamp: 'sw 12/15/2000 13:21'!
trash: ignored
	"Whatever the user submits to the trash, it need not be saved."

	^ true! !


!Model methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:54'!
requestor
	^ Requestor default! !


!Model methodsFor: '*Tools' stamp: 'ar 9/27/2005 20:59'!
addItem: classAndMethod
	"Make a linked message list and put this method in it"
	| list |

	self flag: #mref.	"classAndMethod is a String"

	MessageSet 
		parse: classAndMethod  
		toClassAndSelector: [ :class :sel |
			class ifNil: [^self].
			list := OrderedCollection with: (
				MethodReference new
					setClass: class  
					methodSymbol: sel 
					stringVersion: classAndMethod
			).
			MessageSet 
				openMessageList: list 
				name: 'Linked by HyperText'.
		]

! !

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

Model class
	instanceVariableNames: ''!

!Model class methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 16:26'!
buildWith: toolBuilder
	^self new buildWith: toolBuilder! !
Object subclass: #ModelExtension
	instanceVariableNames: 'interests lock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!

!ModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/14/2005 11:27'!
haveInterestsIn: aClass 
	lock critical: [^interests includes: aClass]
! !


!ModelExtension methodsFor: 'interests' stamp: 'dvf 9/14/2005 11:11'!
lostInterest: client inAll: classes
	lock critical: [interests removeAll: classes]! !

!ModelExtension methodsFor: 'interests' stamp: 'dvf 9/2/2005 11:43'!
lostInterest: client in: class
	self lostInterest: client inAll: {class}! !

!ModelExtension methodsFor: 'interests' stamp: 'dvf 9/14/2005 11:28'!
noteInterestOf: client inAll: classes
	lock critical: [interests addAll: classes].! !

!ModelExtension methodsFor: 'interests' stamp: 'dvf 9/2/2005 11:44'!
noteInterestOf: client in: class
	self noteInterestOf: client inAll: {class}! !


!ModelExtension methodsFor: 'invalidation' stamp: 'dvf 9/14/2005 11:11'!
initialize
	lock := Semaphore forMutualExclusion.  
	interests := IdentityBag new.
	SystemChangeNotifier uniqueInstance 
		notify: self
		ofSystemChangesOfItem: #class
		using: #classChanged:.
	SystemChangeNotifier uniqueInstance 
		notify: self
		ofSystemChangesOfItem: #method
		using: #classChanged:.
! !

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

ModelExtension class
	instanceVariableNames: 'current'!

!ModelExtension class methodsFor: 'accessing' stamp: 'dvf 9/1/2005 21:16'!
current
	^current! !

!ModelExtension class methodsFor: 'accessing' stamp: 'dvf 9/1/2005 21:16'!
current: anObject
	^current := anObject! !


!ModelExtension class methodsFor: 'initialize-release' stamp: 'dvf 9/2/2005 12:20'!
initialize
	self isAbstract not ifTrue:
		[self current: self new]! !

!ModelExtension class methodsFor: 'initialize-release' stamp: 'dvf 9/2/2005 12:20'!
isAbstract
	^self == ModelExtension! !


!ModelExtension class methodsFor: 'instance creation' stamp: 'dvf 9/1/2005 21:16'!
doWithTemporaryInstance: aBlock 
	| singleton |
	singleton := self current.
	
	[self current: self new.
	aBlock value] ensure: [self current: singleton]! !
ModifiedEvent subclass: #ModifiedClassDefinitionEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:30'!
classVarNames
	^ item classVarNames asSet! !

!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:29'!
instVarNames
	^ item instVarNames asSet! !

!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:30'!
oldClassVarNames
	^ oldItem classVarNames asSet! !

!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:29'!
oldInstVarNames
	^ oldItem instVarNames asSet! !

!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:31'!
oldSharedPools
	^ oldItem sharedPools! !

!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:28'!
oldSuperclass
	^ oldItem superclass! !

!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:31'!
sharedPools
	^ item sharedPools! !

!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:28'!
superclass
	^ item superclass! !


!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:31'!
areClassVarsModified
	^ self classVarNames ~= self oldClassVarNames! !

!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:30'!
areInstVarsModified
	^ self instVarNames ~= self oldInstVarNames! !

!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:32'!
areSharedPoolsModified
	^ self sharedPools ~= self oldSharedPools! !

!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:29'!
isSuperclassModified
	^ item superclass ~~ oldItem superclass! !


!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/17/2004 21:48'!
anyChanges
	^ self isSuperclassModified or: [self areInstVarsModified or: [self areClassVarsModified or: [self areSharedPoolsModified or: [self isTraitCompositionModified]]]]! !

!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/17/2004 21:59'!
isTraitCompositionModified
	^self traitComposition printString ~= self oldTraitComposition printString! !

!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/17/2004 21:50'!
oldTraitComposition
	^ oldItem traitComposition! !

!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/18/2004 10:47'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll: ' Super: ';
		print: self isSuperclassModified;
		nextPutAll: ' TraitComposition: ';
		print: self isTraitCompositionModified;
		nextPutAll: ' InstVars: ';
		print: self areInstVarsModified;
		nextPutAll: ' ClassVars: ';
		print: self areClassVarsModified;
		nextPutAll: ' SharedPools: ';
		print: self areSharedPoolsModified.! !

!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/17/2004 21:50'!
traitComposition
	^ item traitComposition! !

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

ModifiedClassDefinitionEvent class
	instanceVariableNames: ''!

!ModifiedClassDefinitionEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:26'!
supportedKinds
	"All the kinds of items that this event can take."
	
	^ Array with: self classKind! !


!ModifiedClassDefinitionEvent class methodsFor: 'instance creation' stamp: 'NS 1/20/2004 11:52'!
classDefinitionChangedFrom: oldClass to: newClass
	| instance |
	instance := self item: newClass kind: self classKind.
	instance oldItem: oldClass.
	^instance! !
AbstractEvent subclass: #ModifiedEvent
	instanceVariableNames: 'oldItem'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!ModifiedEvent methodsFor: 'accessing' stamp: 'NS 1/19/2004 15:08'!
oldItem
	^ oldItem! !


!ModifiedEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 15:10'!
printEventKindOn: aStream

	aStream nextPutAll: 'Modified'! !

!ModifiedEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:57'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll: ' oldItem: ';
		print: oldItem.! !


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

	^true! !


!ModifiedEvent methodsFor: 'private-accessing' stamp: 'NS 1/19/2004 15:08'!
oldItem: anItem
	oldItem _ anItem! !

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

ModifiedEvent class
	instanceVariableNames: ''!

!ModifiedEvent class methodsFor: 'accessing' stamp: 'NS 1/19/2004 15:10'!
changeKind

	^#Modified! !

!ModifiedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:25'!
supportedKinds
	"All the kinds of items that this event can take."
	
	^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! !


!ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/20/2004 19:37'!
classDefinitionChangedFrom: oldClass to: newClass
	^ ModifiedClassDefinitionEvent classDefinitionChangedFrom: oldClass to: newClass! !

!ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 11:40'!
methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass
	| instance |
	instance := self method: newMethod selector: aSymbol class: aClass.
	instance oldItem: oldMethod.
	^ instance! !

!ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 11:40'!
methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass requestor: requestor
	| instance |
	instance := self method: newMethod selector: aSymbol class: aClass requestor: requestor.
	instance oldItem: oldMethod.
	^ instance! !
ModifiedEvent subclass: #ModifiedTraitDefinitionEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!ModifiedTraitDefinitionEvent methodsFor: 'testing' stamp: 'al 7/18/2004 11:08'!
anyChanges
	^ self isTraitCompositionModified! !

!ModifiedTraitDefinitionEvent methodsFor: 'testing' stamp: 'al 7/18/2004 10:43'!
isTraitCompositionModified
	^self traitComposition printString ~= self oldTraitComposition printString! !


!ModifiedTraitDefinitionEvent methodsFor: 'accessing' stamp: 'al 7/18/2004 10:43'!
oldTraitComposition
	^ oldItem traitComposition! !

!ModifiedTraitDefinitionEvent methodsFor: 'accessing' stamp: 'al 7/18/2004 10:43'!
traitComposition
	^ item traitComposition! !


!ModifiedTraitDefinitionEvent methodsFor: 'printing' stamp: 'al 7/18/2004 10:47'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll: ' TraitComposition: ';
		print: self isTraitCompositionModified! !

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

ModifiedTraitDefinitionEvent class
	instanceVariableNames: ''!

!ModifiedTraitDefinitionEvent class methodsFor: 'accessing' stamp: 'al 7/18/2004 10:43'!
supportedKinds
	"All the kinds of items that this event can take."
	
	^ Array with: self classKind! !


!ModifiedTraitDefinitionEvent class methodsFor: 'instance creation' stamp: 'al 7/18/2004 10:50'!
traitDefinitionChangedFrom: oldTrait to: newTrait
	| instance |
	instance _ self item: newTrait kind: self classKind.
	instance oldItem: oldTrait.
	^instance! !
Object subclass: #Monitor
	instanceVariableNames: 'mutex ownerProcess nestingLevel defaultQueue queueDict queuesMutex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!Monitor commentStamp: 'md 3/3/2006 09:19' prior: 0!
A monitor provides process synchronization that is more high level than the one provided by a Semaphore. Similar to the classical definition of a Monitor it has the following properties:

1) At any time, only one process can execute code inside a critical section of a monitor.
2) A monitor is reentrant, which means that the active process in a monitor never gets blocked when it enters a (nested) critical section of the same monitor.
3) Inside a critical section, a process can wait for an event that may be coupled to a certain condition. If the condition is not fulfilled, the process leaves the monitor temporarily (in order to let other processes enter) and waits until another process signals the event. Then, the original process checks the condition again (this is often necessary because the state of the monitor could have changed in the meantime) and continues if it is fulfilled.
4) The monitor is fair, which means that the process that is waiting on a signaled condition the longest gets activated first.
5) The monitor allows you to define timeouts after which a process gets activated automatically.


Basic usage:

Monitor>>critical: aBlock
Critical section.
Executes aBlock as a critical section. At any time, only one process can execute code in a critical section.
NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!!

Monitor>>wait
Unconditional waiting for the default event.
The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed.

Monitor>>waitWhile: aBlock
Conditional waiting for the default event.
The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again...

Monitor>>waitUntil: aBlock
Conditional waiting for the default event.
See Monitor>>waitWhile: aBlock.

Monitor>>signal
One process waiting for the default event is woken up.

Monitor>>signalAll
All processes waiting for the default event are woken up.


Using non-default (specific) events:

Monitor>>waitFor: aSymbol
Unconditional waiting for the non-default event represented by the argument symbol.
Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event.

Monitor>>waitWhile: aBlock for: aSymbol
Confitional waiting for the non-default event represented by the argument symbol.
Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event.

Monitor>>waitUntil: aBlock for: aSymbol
Confitional waiting for the non-default event represented by the argument symbol.
See Monitor>>waitWhile:for: aBlock.

Monitor>>signal: aSymbol
One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed.

Monitor>>signalAll: aSymbol
All process waiting for the given event or the default event are woken up.

Monitor>>signalReallyAll
All processes waiting for any events (default or specific) are woken up.


Using timeouts

Monitor>>waitMaxMilliseconds: anInteger
Monitor>>waitFor: aSymbol maxMilliseconds: anInteger
Same as Monitor>>wait (resp. Monitor>>waitFor:), but the process gets automatically woken up when the specified time has passed.

Monitor>>waitWhile: aBlock maxMilliseconds: anInteger
Monitor>>waitWhile: aBlock for: aSymbol maxMilliseconds: anInteger
Same as Monitor>>waitWhile: (resp. Monitor>>waitWhile:for:), but the process gets automatically woken up when the specified time has passed.

Monitor>>waitUntil: aBlock maxMilliseconds: anInteger
Monitor>>waitUntil: aBlock for: aSymbol maxMilliseconds: anInteger
Same as Monitor>>waitUntil: (resp. Monitor>>waitUntil:for:), but the process gets automatically woken up when the specified time has passed.!


!Monitor methodsFor: 'accessing' stamp: 'NS 7/1/2002 20:02'!
cleanup
	self checkOwnerProcess.
	self critical: [self privateCleanup].! !


!Monitor methodsFor: 'initialize-release' stamp: 'NS 4/13/2004 16:12'!
initialize
	mutex _ Semaphore forMutualExclusion.
	queuesMutex _ Semaphore forMutualExclusion.
	nestingLevel _ 0.! !


!Monitor methodsFor: 'signaling-default' stamp: 'NS 7/1/2002 21:57'!
signal
	"One process waiting for the default event is woken up."

	^ self signal: nil! !

!Monitor methodsFor: 'signaling-default' stamp: 'NS 7/1/2002 21:57'!
signalAll
	"All processes waiting for the default event are woken up."

	^ self signalAll: nil! !


!Monitor methodsFor: 'signaling-specific' stamp: 'NS 4/13/2004 15:12'!
signal: aSymbolOrNil
	"One process waiting for the given event is woken up. If there is no process waiting 
	for this specific event, a process waiting for the default event gets resumed."

	| queue |
	self checkOwnerProcess.
	queue _ self queueFor: aSymbolOrNil.
	queue isEmpty ifTrue: [queue _ self defaultQueue].
	self signalQueue: queue.! !

!Monitor methodsFor: 'signaling-specific' stamp: 'NS 7/1/2002 22:02'!
signalAll: aSymbolOrNil
	"All process waiting for the given event or the default event are woken up."

	| queue |
	self checkOwnerProcess.
	queue _ self queueFor: aSymbolOrNil.
	self signalAllInQueue: self defaultQueue.
	queue ~~ self defaultQueue ifTrue: [self signalAllInQueue: queue].! !

!Monitor methodsFor: 'signaling-specific' stamp: 'NS 7/1/2002 22:02'!
signalReallyAll
	"All processes waiting for any events (default or specific) are woken up."

	self checkOwnerProcess.
	self signalAll.
	self queueDict valuesDo: [:queue |
		self signalAllInQueue: queue].! !


!Monitor methodsFor: 'synchronization' stamp: 'NS 4/14/2004 13:13'!
critical: aBlock
	"Critical section.
	Executes aBlock as a critical section. At any time, only one process can be executing code 
	in a critical section.
	NOTE: All the following synchronization operations are only valid inside the critical section 
	of the monitor!!"

	| result |
	[self enter.
	result _ aBlock value] ensure: [self exit].
	^ result.! !


!Monitor methodsFor: 'waiting-basic' stamp: 'NS 7/1/2002 21:55'!
wait
	"Unconditional waiting for the default event.
	The current process gets blocked and leaves the monitor, which means that the monitor
	allows another process to execute critical code. When the default event is signaled, the
	original process is resumed."

	^ self waitMaxMilliseconds: nil! !

!Monitor methodsFor: 'waiting-basic' stamp: 'NS 7/1/2002 21:56'!
waitUntil: aBlock
	"Conditional waiting for the default event.
	See Monitor>>waitWhile: aBlock."

	^ self waitUntil: aBlock for: nil! !

!Monitor methodsFor: 'waiting-basic' stamp: 'fbs 3/24/2004 14:39'!
waitWhile: aBlock
	"Conditional waiting for the default event.
	The current process gets blocked and leaves the monitor only if the argument block
	evaluates to true. This means that another process can enter the monitor. When the 
	default event is signaled, the original process is resumed, which means that the condition
	(argument block) is checked again. Only if it evaluates to false, does execution proceed.
	Otherwise, the process gets blocked and leaves the monitor again..."

	^ self waitWhile: aBlock for: nil! !


!Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 21:58'!
waitFor: aSymbolOrNil
	"Unconditional waiting for the non-default event represented by the argument symbol.
	Same as Monitor>>wait, but the process gets only reactivated by the specific event and 
	not the default event."

	^ self waitFor: aSymbolOrNil maxMilliseconds: nil! !

!Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 22:01'!
waitUntil: aBlock for: aSymbolOrNil
	"Confitional waiting for the non-default event represented by the argument symbol.
	See Monitor>>waitWhile:for: aBlock."

	^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: nil! !

!Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 22:01'!
waitWhile: aBlock for: aSymbolOrNil
	"Confitional waiting for the non-default event represented by the argument symbol.
	Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific 
	event and not the default event."

	^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: nil! !


!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:03'!
waitFor: aSymbolOrNil maxMilliseconds: anIntegerOrNil
	"Same as Monitor>>waitFor:, but the process gets automatically woken up when the 
	specified time has passed."

	self checkOwnerProcess.
	self waitInQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:04'!
waitFor: aSymbolOrNil maxSeconds: aNumber
	"Same as Monitor>>waitFor:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitFor: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:04'!
waitMaxMilliseconds: anIntegerOrNil
	"Same as Monitor>>wait, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitFor: nil maxMilliseconds: anIntegerOrNil! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'!
waitMaxSeconds: aNumber
	"Same as Monitor>>wait, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitMaxMilliseconds: (aNumber * 1000) asInteger! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'!
waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil
	"Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitWhile: [aBlock value not] for: aSymbolOrNil maxMilliseconds: anIntegerOrNil! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'!
waitUntil: aBlock for: aSymbolOrNil maxSeconds: aNumber
	"Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'!
waitUntil: aBlock maxMilliseconds: anIntegerOrNil
	"Same as Monitor>>waitUntil:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitUntil: aBlock for: nil maxMilliseconds: anIntegerOrNil! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'!
waitUntil: aBlock maxSeconds: aNumber
	"Same as Monitor>>waitUntil:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitUntil: aBlock maxMilliseconds: (aNumber * 1000) asInteger! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'!
waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil
	"Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the 
	specified time has passed."

	self checkOwnerProcess.
	self waitWhile: aBlock inQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'!
waitWhile: aBlock for: aSymbolOrNil maxSeconds: aNumber
	"Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'!
waitWhile: aBlock maxMilliseconds: anIntegerOrNil
	"Same as Monitor>>waitWhile:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitWhile: aBlock for: nil maxMilliseconds: anIntegerOrNil! !

!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'!
waitWhile: aBlock maxSeconds: aNumber
	"Same as Monitor>>waitWhile:, but the process gets automatically woken up when the 
	specified time has passed."

	^ self waitWhile: aBlock maxMilliseconds: (aNumber * 1000) asInteger! !


!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:40'!
checkOwnerProcess
	self isOwnerProcess
		ifFalse: [self error: 'Monitor access violation'].! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:06'!
defaultQueue
	defaultQueue ifNil: [defaultQueue _ OrderedCollection new].
	^ defaultQueue! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:37'!
enter
	self isOwnerProcess ifTrue: [
		nestingLevel _ nestingLevel + 1.
	] ifFalse: [
		mutex wait.
		ownerProcess _ Processor activeProcess.
		nestingLevel _ 1.
	].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:38'!
exit
	nestingLevel _ nestingLevel - 1.
	nestingLevel < 1 ifTrue: [
		ownerProcess _ nil.
		mutex signal
	].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:32'!
exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
	| lock delay |
	queuesMutex 
		critical: [lock _ anOrderedCollection addLast: Semaphore new].
	self exit.
	anIntegerOrNil isNil ifTrue: [
		lock wait
	] ifFalse: [
		delay _ MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection.
		lock wait.
		delay unschedule.
	].
	self enter.! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:42'!
isOwnerProcess
	^ Processor activeProcess == ownerProcess! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:14'!
privateCleanup
	queuesMutex critical: [
		defaultQueue isEmpty ifTrue: [defaultQueue _ nil].
		queueDict ifNotNil: [
			queueDict copy keysAndValuesDo: [:id :queue | 
				queue isEmpty ifTrue: [queueDict removeKey: id]].
			queueDict isEmpty ifTrue: [queueDict _ nil].
		].
	].! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:10'!
queueDict
	queueDict ifNil: [queueDict _ IdentityDictionary new].
	^ queueDict.! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:12'!
queueFor: aSymbol
	aSymbol ifNil: [^ self defaultQueue].
	^ self queueDict 
		at: aSymbol 
		ifAbsent: [self queueDict at: aSymbol put: OrderedCollection new].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:10'!
signalAllInQueue: anOrderedCollection
	queuesMutex critical: [
		anOrderedCollection do: [:lock | lock signal].
		anOrderedCollection removeAllSuchThat: [:each | true].
	].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:34'!
signalLock: aSemaphore inQueue: anOrderedCollection
	queuesMutex critical: [
		aSemaphore signal.
		anOrderedCollection remove: aSemaphore ifAbsent: [].
	].! !

!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:10'!
signalQueue: anOrderedCollection
	queuesMutex critical: [
		anOrderedCollection isEmpty ifTrue: [^ self].
		anOrderedCollection removeFirst signal.
	].! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'!
waitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
	self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil.! !

!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'!
waitWhile: aBlock inQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil
	[aBlock value] whileTrue: [self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil].! !

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

Monitor class
	instanceVariableNames: ''!
Delay subclass: #MonitorDelay
	instanceVariableNames: 'monitor queue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!MonitorDelay commentStamp: 'NS 4/13/2004 16:51' prior: 0!
This is a specialization of the class Delay that is used for the implementation of the class Monitor.!


!MonitorDelay methodsFor: 'private' stamp: 'NS 4/13/2004 16:26'!
setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection
	monitor _ aMonitor.
	queue _ anOrderedCollection.
	self setDelay: anInteger forSemaphore: aSemaphore.! !

!MonitorDelay methodsFor: 'private' stamp: 'NS 4/13/2004 16:22'!
signalWaitingProcess
	"The delay time has elapsed; signal the waiting process."

	beingWaitedOn _ false.
	monitor signalLock: delaySemaphore inQueue: queue.
! !

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

MonitorDelay class
	instanceVariableNames: ''!

!MonitorDelay class methodsFor: 'instance creation' stamp: 'NS 4/13/2004 16:25'!
signalLock: aSemaphore afterMSecs: anInteger inMonitor: aMonitor queue: anOrderedCollection
	anInteger < 0 ifTrue: [self error: 'delay times cannot be negative'].
	^ (self new setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection) schedule! !
TestCase subclass: #MonitorTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Processes'!

!MonitorTest methodsFor: 'examples' stamp: 'md 3/19/2006 21:15'!
testExample1

	| producer1 producer2  monitor goal work counter goalReached finished |
	goal _ (1 to: 1000) asOrderedCollection.
	work _ OrderedCollection new.
	counter := 0.
	goalReached := false.
	finished := Semaphore new.
	monitor := Monitor new.

	producer1 := [
       [monitor critical:
             [monitor waitUntil: [counter \\5 = 0].
              goalReached or: [work add: (counter := counter + 1)].
              goalReached := counter >= goal size.
              monitor signal
            ].
           goalReached
          ]
             whileFalse.
         finished signal.
	].

	producer2 := [
         [monitor critical:
                [monitor waitWhile: [counter \\5 = 0].
                 goalReached or: [work add: (counter := counter + 1)].
                 goalReached := counter >= goal size.
                 monitor signal].
         goalReached
       ] whileFalse.
     finished signal
	].

	producer1 forkAt: Processor userBackgroundPriority.
	producer2 forkAt: Processor userBackgroundPriority.

	finished wait; wait.
	self assert: goal = work! !

!MonitorTest methodsFor: 'examples' stamp: 'md 3/19/2006 21:19'!
testExample2
	"Here is a second version that does not use a semaphore to inform the 
	forking process about termination of both forked processes"

	| producer1 producer2  monitor goal work counter goalReached activeProducers|
	goal _ (1 to: 1000) asOrderedCollection.
	work _ OrderedCollection new.
	counter := 0.
	goalReached := false.
	activeProducers := 0.
	monitor := Monitor new.

  producer1 :=
      [ monitor critical: [activeProducers := activeProducers + 1].
  [monitor critical:
            [monitor waitUntil: [counter \\5 = 0].
      goalReached or: [work add: (counter := counter + 1)].
     " Transcript show: 'P1  '; show: counter printString; show: '  ';
       show: activeProducers printString; cr."
      goalReached := counter >= goal size.
      monitor signal
            ].
           goalReached
          ]
             whileFalse.
         monitor critical: [activeProducers := activeProducers - 1.
        monitor signal: #finish].
 ] .

 producer2 :=
    [monitor critical: [activeProducers := activeProducers + 1].

  [monitor critical:
          [monitor waitWhile: [counter \\5 = 0].
    goalReached or: [work add: (counter := counter + 1)].
    goalReached := counter >= goal size.
    monitor signal].
         goalReached ] whileFalse.
     monitor critical: [
		activeProducers := activeProducers - 1. 
		monitor signal: #finish].
	].

	producer1 forkAt: Processor userBackgroundPriority.
	producer2  forkAt: Processor userBackgroundPriority.


	monitor critical: [
		monitor waitUntil: [activeProducers = 0 & (goalReached)]
				for: #finish.
  	].

	self assert: goal = work
! !
Timespan subclass: #Month
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'ChronologyConstants'
	category: 'Kernel-Chronology'!
!Month commentStamp: 'brp 5/13/2003 09:48' prior: 0!
I represent a month.!


!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:04'!
asMonth

	^ self
! !

!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'!
daysInMonth

	^ self duration days.! !

!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'!
index

	^ self monthIndex
! !

!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'!
name


	^ self monthName
! !

!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'!
previous


	^ self class starting: (self start - 1)
! !

!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'!
printOn: aStream


	aStream nextPutAll: self monthName, ' ', self year printString.! !

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

Month class
	instanceVariableNames: ''!

!Month class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:27'!
daysInMonth: indexOrName forYear: yearInteger 

	| index |
	index _ indexOrName isInteger 
				ifTrue: [indexOrName]
				ifFalse: [self indexOfMonth: indexOrName].
	^ (DaysInMonth at: index)
			+ ((index = 2
					and: [Year isLeapYear: yearInteger])
						ifTrue: [1] ifFalse: [0])! !

!Month class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 09:29'!
indexOfMonth: aMonthName


	1 to: 12 do: [ :i |  (aMonthName, '*' match: (MonthNames at: i)) ifTrue: [^i] ].
	self error: aMonthName , ' is not a recognized month name'.! !

!Month class methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 09:02'!
nameOfMonth: anIndex

	^ MonthNames at: anIndex.! !


!Month class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:22'!
month: month year: year
	"Create a Month for the given <year> and <month>.
	<month> may be a number or a String with the
	name of the month. <year> should be with 4 digits."

	^ self starting: (DateAndTime year: year month: month day: 1)
! !

!Month class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:21'!
readFrom: aStream

	| m y c |
	m _ (ReadWriteStream with: '') reset.
	[(c _ aStream next) isSeparator] whileFalse: [m nextPut: c].
	[(c _ aStream next) isSeparator] whileTrue.
	y _ (ReadWriteStream with: '') reset.
	y nextPut: c.
	[aStream atEnd] whileFalse: [y nextPut: aStream next].

	^ self 
		month: m contents
		year: y contents

"Month readFrom: 'July 1998' readStream"
! !

!Month class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 13:59'!
starting: aDateAndTime duration: aDuration 
	"Override - a each month has a defined duration"
	| start adjusted days |
	start _ aDateAndTime asDateAndTime.
	adjusted _ DateAndTime
				year: start year
				month: start month
				day: 1.
	days _ self daysInMonth: adjusted month forYear: adjusted year.
	^ super
		starting: adjusted
		duration: (Duration days: days)! !
ClassTestCase subclass: #MonthTest
	instanceVariableNames: 'month'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!MonthTest commentStamp: 'brp 7/26/2003 22:44' prior: 0!
This is the unit test for the class Month.
!


!MonthTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:42'!
classToBeTested

	^ Month! !

!MonthTest methodsFor: 'Coverage' stamp: 'brp 7/26/2003 23:29'!
selectorsToBeIgnored

	| deprecated private special |
	deprecated := #().
	private := #( #printOn: ).
	special := #( #next ).

	^ super selectorsToBeIgnored, deprecated, private, special.! !


!MonthTest methodsFor: 'Running' stamp: 'brp 8/6/2003 19:37'!
setUp

	super setUp.
	month _ Month month: 7 year: 1998.! !

!MonthTest methodsFor: 'Running' stamp: 'brp 8/6/2003 19:37'!
tearDown

	super tearDown.
	month _ nil.! !


!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:52'!
testConverting

	self assert: month asDate = '1 July 1998' asDate! !

!MonthTest methodsFor: 'Tests' stamp: 'brp 1/30/2005 09:35'!
testEnumerating
	| weeks |
	weeks := OrderedCollection new.
	month weeksDo: [ :w | weeks add: w start ].
	0 to: 4 do: [ :i | weeks remove: (Week starting:  ('29 June 1998' asDate addDays: i * 7)) start ].
	self assert: weeks isEmpty! !

!MonthTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 16:08'!
testInquiries

	self 
		assert: month index = 7;
		assert: month name = #July;
		assert: month duration = (31 days).
! !

!MonthTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'!
testInstanceCreation
	| m1 m2 |
	m1 := Month starting:  '4 July 1998' asDate.
	m2 := Month month: #July year: 1998.
	self
		assert: month = m1;
		assert: month = m2! !

!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 23:02'!
testPreviousNext
	| n p |
	n := month next.
	p := month previous.

	self
		assert: n year = 1998;
		assert: n index = 8;
		assert: p year = 1998;
		assert: p index = 6.

! !

!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:50'!
testPrinting

	self 
		assert: month printString = 'July 1998'.
! !

!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:46'!
testReadFrom

	| m |
	m := Month readFrom: 'July 1998' readStream.
	self 
		assert: m = month! !
GesturalEvent subclass: #MoodGesturalEvent
	instanceVariableNames: 'state'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!MoodGesturalEvent methodsFor: 'accessing' stamp: 'len 9/7/1999 02:22'!
state
	^ state! !

!MoodGesturalEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
state: aSymbol
	state := aSymbol asSymbol! !


!MoodGesturalEvent methodsFor: 'playing' stamp: 'len 9/7/1999 02:23'!
actOn: aHeadMorph
	aHeadMorph face perform: self state! !


!MoodGesturalEvent methodsFor: 'printing' stamp: 'len 9/7/1999 02:26'!
printOn: aStream
	aStream nextPutAll: 'set ', self state, ' mood'! !
Object subclass: #Morph
	instanceVariableNames: 'bounds owner submorphs fullBounds color extension'
	classVariableNames: 'EmptyArray'
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!Morph commentStamp: 'efc 2/26/2003 20:01' prior: 0!
A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://minnow.cc.gatech.edu/squeak/30. 

Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method. 

The World (screen) coordinate system is used for most coordinates, but can be changed if there is a TransformMorph somewhere in the owner chain. 

My instance variables have accessor methods (e.g., #bounds, #bounds:). Most users should use the accessor methods instead of using the instance variables directly.

Structure:
instance var 	Type 			Description 
bounds 			Rectangle 		A Rectangle indicating my position and a size that will enclose 									me. 
owner 			Morph		 	My parent Morph, or nil for the top-level Morph, which is a
 				or nil			world, typically a PasteUpMorph.
submorphs 		Array 			My child Morphs. 
fullBounds 		Rectangle 		A Rectangle minimally enclosing me and my submorphs. 
color 			Color 			My primary color. Subclasses can use this in different ways. 
extension 		MorphExtension Allows extra properties to be stored without adding a
				or nil  				storage burden to all morphs. 

By default, Morphs do not position their submorphs. Morphs may position their submorphs directly or use a LayoutPolicy to automatically control their submorph positioning.

Although Morph has some support for BorderStyle, most users should use BorderedMorph if they want borders.!
]style[(2 5 130 37 59 12 325 14 209 12 2 4 4 11 1 11 9 90 5 123 5 35 9 66 5 78 14 209 12 91 11 24 13 22)f1,f1LMorph Hierarchy;,f1,f1Rhttp://minnow.cc.gatech.edu/squeak/30;,f1,f1LPasteUpMorph Comment;,f1,f1LTransformMorph Comment;,f1,f1u,f1,f1u,f1,f1u,f1i,f1,f1LRectangle Comment;,f1,f1LMorph Comment;,f1,f1LArray Comment;,f1,f1LRectangle Comment;,f1,f1LColor Comment;,f1,f1LMorphExtension Comment;,f1,f1LLayoutPolicy Comment;,f1,f1LBorderStyle Comment;,f1,f1LBorderedMorph Comment;,f1!


!Morph methodsFor: 'accessing' stamp: 'sw 8/11/1998 16:46'!
actorState
	"This method instantiates actorState as a side-effect.
	For simple queries, use actorStateOrNil"
	| state |
	state _ self actorStateOrNil.
	state ifNil:
		[state _ ActorState new initializeFor: self assuredPlayer.
		self actorState: state].
	^ state! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:51'!
actorStateOrNil
	"answer the redeiver's actorState"
	^ extension ifNotNil: [extension actorState]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:52'!
actorState: anActorState 
	"change the receiver's actorState"
	self assureExtension actorState: anActorState! !

!Morph methodsFor: 'accessing' stamp: 'ar 12/18/2001 20:09'!
adoptPaneColor: paneColor
	self submorphsDo:[:m| m adoptPaneColor: paneColor].! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:51'!
balloonText
	"Answer balloon help text or nil, if no help is available.  
	NB: subclasses may override such that they programatically  
	construct the text, for economy's sake, such as model phrases in 
	a Viewer"

	| text balloonSelector aString |
	extension ifNil: [^nil].
	(text := extension balloonText) ifNotNil: [^text].
	(balloonSelector := extension balloonTextSelector) ifNotNil: 
			[aString := ScriptingSystem helpStringOrNilFor: balloonSelector.
			(aString isNil and: [balloonSelector == #methodComment]) 
				ifTrue: [aString := self methodCommentAsBalloonHelp].
			((aString isNil and: [balloonSelector numArgs = 0]) 
				and: [self respondsTo: balloonSelector]) 
					ifTrue: [aString := self perform: balloonSelector]].
	^aString ifNotNil: 
			[aString asString 
				withNoLineLongerThan: Preferences maxBalloonHelpLineLength]! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:52'!
balloonTextSelector
	"Answer balloon text selector item in the extension, nil if none"
	^ extension ifNotNil: [extension balloonTextSelector]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:50'!
balloonTextSelector: aSelector 
	"change the receiver's balloonTextSelector"
	self assureExtension balloonTextSelector: aSelector! !

!Morph methodsFor: 'accessing' stamp: 'sw 10/31/2001 21:06'!
beFlap: aBool
	"Mark the receiver with the #flap property, or unmark it"

	aBool
		ifTrue:
			[self setProperty: #flap toValue: true.
			self hResizing: #rigid.
			self vResizing: #rigid]
		ifFalse:
			[self removeProperty: #flap]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57'!
beSticky
	"make the receiver sticky"
	self assureExtension sticky: true! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:52'!
beUnsticky
	"If the receiver is marked as sticky, make it now be unsticky"
	extension ifNotNil: [extension sticky: false]! !

!Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'!
borderColor
	^self borderStyle color! !

!Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 10:55'!
borderColor: aColorOrSymbolOrNil 
	"Unfortunately, the argument to borderColor could be more than 	just a color. 
	It could also be a symbol, in which case it is to be interpreted as a style identifier.
	But I might not be able to draw that kind of border, so it may have to be ignored.
	Or it could be nil, in which case I should revert to the default border."

	| style newStyle |
	style := self borderStyle.
	style baseColor = aColorOrSymbolOrNil
		ifTrue: [^ self].

	aColorOrSymbolOrNil isColor
		ifTrue: [style style = #none "default border?"
				ifTrue: [self borderStyle: (SimpleBorder width: 0 color: aColorOrSymbolOrNil)]
				ifFalse: [style baseColor: aColorOrSymbolOrNil.
					self changed].
			^ self].

	self
		borderStyle: ( ({ nil. #none } includes: aColorOrSymbolOrNil)
				ifTrue: [BorderStyle default]
				ifFalse: [ "a symbol"
					self doesBevels ifFalse: [ ^self ].
					newStyle := (BorderStyle perform: aColorOrSymbolOrNil)
								color: style color;
								width: style width;
								yourself.
					(self canDrawBorder: newStyle)
						ifTrue: [newStyle]
						ifFalse: [style]])! !

!Morph methodsFor: 'accessing' stamp: 'ar 11/26/2001 14:53'!
borderStyle
	^(self valueOfProperty: #borderStyle ifAbsent:[BorderStyle default]) trackColorFrom: self! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/26/2001 16:18'!
borderStyleForSymbol: aStyleSymbol
	"Answer a suitable BorderStyle for me of the type represented by a given symbol"

	| aStyle existing |
	aStyle _ BorderStyle borderStyleForSymbol: aStyleSymbol asSymbol.
	aStyle ifNil: [self error: 'bad style'].
	existing _ self borderStyle.
	aStyle width: existing width;
		baseColor: existing baseColor.
	^ (self canDrawBorder: aStyle)
		ifTrue:
			[aStyle]
		ifFalse:
			[nil]! !

!Morph methodsFor: 'accessing' stamp: 'ar 12/11/2001 22:14'!
borderStyle: newStyle
	newStyle = self borderStyle ifFalse:[
		(self canDrawBorder: newStyle) ifFalse:[
			"Replace the suggested border with a simple one"
			^self borderStyle: (BorderStyle width: newStyle width color: (newStyle trackColorFrom: self) color)].
		self setProperty: #borderStyle toValue: newStyle.
		self changed].! !

!Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'!
borderWidth
	^self borderStyle width! !

!Morph methodsFor: 'accessing' stamp: 'di 2/6/2001 14:02'!
borderWidthForRounding

	^ self borderWidth! !

!Morph methodsFor: 'accessing' stamp: 'nk 4/14/2004 17:48'!
borderWidth: aNumber
	| style |
	style _ self borderStyle.
	style width = aNumber ifTrue: [ ^self ].

	style style = #none
		ifTrue: [ self borderStyle: (SimpleBorder width: aNumber color: Color transparent) ]
		ifFalse: [ style width: aNumber. self changed ].
! !

!Morph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 16:10'!
clearArea
	"Answer the clear area of the receiver. It means the area free  
	of docking bars."
	| visTop visBottom visLeft visRight |

	visTop := self top.
	visBottom := self bottom.
	visLeft := self left.
	visRight := self right.

	self dockingBars
		do: [:each | 
			(each isAdheringToTop and: [each bottom > visTop])
				ifTrue: [visTop := each bottom].

			(each isAdheringToBottom and: [each top < visBottom])
				ifTrue: [visBottom := each top].

			(each isAdheringToLeft and: [each right > visLeft])
				ifTrue: [visLeft := each right].

			(each isAdheringToRight and: [each left < visRight])
				ifTrue: [visRight := each left]
		].

	^ Rectangle
		left: visLeft
		right: visRight
		top: visTop
		bottom: visBottom
! !

!Morph methodsFor: 'accessing' stamp: 'tk 2/15/2001 15:55'!
color

	^ color 	"has already been set to ((self valueOfProperty: #fillStyle) asColor)"! !

!Morph methodsFor: 'accessing' stamp: 'ar 8/15/2001 22:40'!
colorForInsets
	"Return the color to be used for shading inset borders.  The default is my own color, but it might want to be, eg, my owner's color.  Whoever's color ends up prevailing, the color itself gets the last chance to determine, so that when, for example, an InfiniteForm serves as the color, callers won't choke on some non-Color object being returned"
	(color isColor and:[color isTransparent and:[owner notNil]]) ifTrue:[^owner colorForInsets].
	^ color colorForInsets
! !

!Morph methodsFor: 'accessing' stamp: 'ar 8/6/2001 09:03'!
color: aColor
	"Set the receiver's color.  Directly set the color if appropriate, else go by way of fillStyle"

	(aColor isColor or: [aColor isKindOf: InfiniteForm]) ifFalse:[^ self fillStyle: aColor].
	color = aColor ifFalse:
		[self removeProperty: #fillStyle.
		color _ aColor.
		self changed]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 4/4/2006 17:14'!
connections
	"Empty method in absence of connectors"
	^ #()! !

!Morph methodsFor: 'accessing' stamp: 'ar 12/27/2001 17:56'!
couldHaveRoundedCorners
	^ true! !

!Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 07:50'!
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! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:53'!
eventHandler
	"answer the receiver's eventHandler"
	^ extension ifNotNil: [extension eventHandler] ! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:25'!
eventHandler: anEventHandler 
	"Note that morphs can share eventHandlers and all is OK. "
	self assureExtension eventHandler: anEventHandler! !

!Morph methodsFor: 'accessing' stamp: 'ar 9/22/2000 13:36'!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!Morph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:25'!
hasTranslucentColor
	"Answer true if this any of this morph is translucent but not transparent."

	^ color isColor and: [color isTranslucentColor]
! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'!
highlight
	"The receiver is being asked to appear in a highlighted state.  Mostly used for textual morphs"
	self color: self highlightColor! !

!Morph methodsFor: 'accessing' stamp: 'sw 3/6/1999 02:09'!
highlightColor
	
	| val |
	^ (val _ self valueOfProperty: #highlightColor)
		ifNotNil:
			[val ifNil: [self error: 'nil highlightColor']]
		ifNil:
			[owner ifNil: [self color] ifNotNil: [owner highlightColor]]! !

!Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'!
highlightColor: aColor
	self setProperty: #highlightColor toValue: aColor! !

!Morph methodsFor: 'accessing' stamp: 'tk 1/31/2002 10:25'!
insetColor
	owner ifNil:[^self color].
	^ self colorForInsets! !

!Morph methodsFor: 'accessing' stamp: 'sw 6/13/2001 01:04'!
isFlap
	"Answer whether the receiver claims to be a flap"

	^ self hasProperty: #flap! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:53'!
isLocked
	"answer whether the receiver is Locked"
	extension ifNil: [^ false].
	^ extension locked! !

!Morph methodsFor: 'accessing' stamp: 'sw 10/27/2000 17:42'!
isShared
	"Answer whether the receiver has the #shared property.  This property allows it to be treated as a 'background' item"

	^ self hasProperty: #shared! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:57'!
isSticky
	"answer whether the receiver is Sticky"
	extension ifNil: [^ false].
	^ extension sticky! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/4/97 12:05'!
lock
	self lock: true! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:58'!
lock: aBoolean 
	"change the receiver's lock property"
	(extension isNil and: [aBoolean not]) ifTrue: [^ self].
	self assureExtension locked: aBoolean! !

!Morph methodsFor: 'accessing' stamp: 'sw 6/20/2001 15:45'!
methodCommentAsBalloonHelp
	"Given that I am a morph that is associated with an object and a method, answer a suitable method comment relating to that object & method if possible"

	| inherentSelector actual |
	(inherentSelector _ self valueOfProperty: #inherentSelector)
		ifNotNil:
			[(actual _ (self ownerThatIsA: PhraseTileMorph orA: SyntaxMorph) actualObject) ifNotNil:
				[^ actual class precodeCommentOrInheritedCommentFor: inherentSelector]].
	^ nil! !

!Morph methodsFor: 'accessing' stamp: 'sw 10/23/1999 22:35'!
modelOrNil
	^ nil! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:54'!
player
	"answer the receiver's player"
	^ extension ifNotNil: [extension player]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 4/4/2006 17:18'!
playerRepresented
	"Answer the player represented by the receiver.  Morphs that serve as references to other morphs reimplement this; be default a morph represents its own player."

	^ self player! !

!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:53'!
player: anObject 
	"change the receiver's player"
	self assureExtension player: anObject! !

!Morph methodsFor: 'accessing' stamp: 'sw 3/3/1999 13:08'!
presenter
	^ owner ifNotNil: [owner presenter] ifNil: [self currentWorld presenter]! !

!Morph methodsFor: 'accessing' stamp: 'dgd 3/7/2003 15:24'!
raisedColor
	"Return the color to be used for shading raised borders. The 
	default is my own color, but it might want to be, eg, my 
	owner's color. Whoever's color ends up prevailing, the color 
	itself gets the last chance to determine, so that when, for 
	example, an InfiniteForm serves as the color, callers won't choke 
	on some non-Color object being returned"
	(color isColor
			and: [color isTransparent
					and: [owner notNil]])
		ifTrue: [^ owner raisedColor].
	^ color asColor raisedColor!
]style[(11 2 355 3 5 18 5 26 5 24 5 18 5 20)f2b,f2,f2c145043000,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2! !

!Morph methodsFor: 'accessing' stamp: 'sw 3/6/1999 02:09'!
regularColor
	
	| val |
	^ (val _ self valueOfProperty: #regularColor)
		ifNotNil:
			[val ifNil: [self error: 'nil regularColor']]
		ifNil:
			[owner ifNil: [self color] ifNotNil: [owner regularColor]]! !

!Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'!
regularColor: aColor
	self setProperty: #regularColor toValue: aColor! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/29/2000 14:56'!
rememberedColor
	"Answer a rememberedColor, or nil if none"

	^ self valueOfProperty: #rememberedColor ifAbsent: [nil]! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/29/2000 15:47'!
rememberedColor: aColor
	"Place aColor in a property so I can retrieve it later.  A tortuous but expedient flow of data"

	^ self setProperty: #rememberedColor toValue: aColor! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:33'!
resistsRemoval
	"Answer whether the receiver is marked as resisting removal"

	^ self hasProperty: #resistsRemoval! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:33'!
resistsRemoval: aBoolean
	"Set the receiver's resistsRemoval property as indicated"

	aBoolean
		ifTrue:
			[self setProperty: #resistsRemoval toValue: true]
		ifFalse:
			[self removeProperty: #resistsRemoval]! !

!Morph methodsFor: 'accessing' stamp: 'nk 9/4/2004 10:49'!
scaleFactor
	^self valueOfProperty: #scaleFactor ifAbsent: [ 1.0 ]
! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/26/2001 16:16'!
setBorderStyle: aSymbol
	"Set the border style of my costume"

	| aStyle |
	aStyle _ self borderStyleForSymbol: aSymbol.
	aStyle ifNil: [^ self].
	(self canDrawBorder: aStyle)
		ifTrue:
			[self borderStyle: aStyle]! !

!Morph methodsFor: 'accessing' stamp: 'tk 12/4/1998 13:06'!
sqkPage
	^ self valueOfProperty: #SqueakPage! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 08:33'!
sticky: aBoolean 
	"change the receiver's sticky property"
	extension sticky: aBoolean! !

!Morph methodsFor: 'accessing' stamp: 'RAA 2/19/2001 17:38'!
toggleLocked
	
	self lock: self isLocked not! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 12:21'!
toggleResistsRemoval
	"Toggle the resistsRemoval property"

	self resistsRemoval
		ifTrue:
			[self removeProperty: #resistsRemoval]
		ifFalse:
			[self setProperty: #resistsRemoval toValue: true]! !

!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 08:53'!
toggleStickiness
	"togle the receiver's Stickiness"
	extension ifNil: [^ self beSticky].
	extension sticky: extension sticky not! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'!
unHighlight
	self color: self regularColor! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 12:33'!
unlock
	self lock: false! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/15/97 23:59'!
unlockContents
	self submorphsDo:
		[:m | m unlock]! !

!Morph methodsFor: 'accessing' stamp: 'tk 2/17/1999 11:45'!
url
	"If I have been assigned a url, return it.  For PasteUpMorphs mostly."
	| sq |
	(sq _ self sqkPage) ifNotNil: [^ sq url].
	^ self valueOfProperty: #url
		! !

!Morph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:54'!
userString
	"Do I have a text string to be searched on?"

	^ nil! !

!Morph methodsFor: 'accessing' stamp: 'dgd 9/27/2004 11:45'!
viewBox
	^ self pasteUpMorph viewBox! !

!Morph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 16:14'!
visibleClearArea
	"Answer the receiver visible clear area. The intersection 
	between the clear area and the viewbox."
	^ self viewBox intersect: self clearArea! !

!Morph methodsFor: 'accessing' stamp: 'dgd 4/4/2006 17:14'!
wantsEmbeddingsVocabulary
	"Empty method in absence of connectors"
	^ false! !

!Morph methodsFor: 'accessing' stamp: 'ar 6/23/2001 16:06'!
wantsToBeCachedByHand
	"Return true if the receiver wants to be cached by the hand when it is dragged around.
	Note: The default implementation queries all submorphs since subclasses may have shapes that do not fill the receiver's bounds completely."
	self hasTranslucentColor ifTrue:[^false].
	self submorphsDo:[:m|
		m wantsToBeCachedByHand ifFalse:[^false].
	].
	^true! !

!Morph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 16:21'!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in its owner"
	^ self isFlapOrTab! !


!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:46'!
assureExtension
	"creates an extension for the receiver if needed"
	extension ifNil: [self initializeExtension].
	^ extension! !

!Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:22'!
extension
	"answer the recevier's extension"
	^ extension! !

!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:31'!
hasExtension
	"answer whether the receiver has extention"
	^ extension notNil! !

!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:35'!
initializeExtension
	"private - initializes the receiver's extension"
	extension := MorphExtension new! !

!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:46'!
privateExtension: aMorphExtension
	"private - change the receiver's extension"
	extension := aMorphExtension! !

!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:47'!
resetExtension
	"reset the extension slot if it is not needed"
	(extension notNil and: [extension isDefault]) ifTrue: [extension := nil] ! !


!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:47'!
hasProperty: aSymbol 
	"Answer whether the receiver has the property named aSymbol"
	extension ifNil: [^ false].
	^extension hasProperty: aSymbol! !

!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:47'!
otherProperties
	"answer the receiver's otherProperties"
	^ extension ifNotNil: [extension otherProperties]! !

!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:48'!
removeProperty: aSymbol 
	"removes the property named aSymbol if it exists"
	extension ifNil:  [^ self].
	extension removeProperty: aSymbol! !

!Morph methodsFor: 'accessing - properties' stamp: 'tk 10/9/2002 08:30'!
setProperties: aList
	"Set many properties at once from a list of prop, value, prop, value"

	1 to: aList size by: 2 do: [:ii |
		self setProperty: (aList at: ii) toValue: (aList at: ii+1)].! !

!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:48'!
setProperty: aSymbol toValue: anObject 
	"change the receiver's property named aSymbol to anObject"
	anObject ifNil: [^ self removeProperty: aSymbol].
	self assureExtension setProperty: aSymbol toValue: anObject! !

!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:53'!
valueOfProperty: aSymbol 
	"answer the value of the receiver's property named aSymbol"
	^ extension ifNotNil: [extension valueOfProperty: aSymbol]! !

!Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:55'!
valueOfProperty: aSymbol ifAbsentPut: aBlock 
	"If the receiver possesses a property of the given name, answer  
	its value. If not, then create a property of the given name, give 
	it the value obtained by evaluating aBlock, then answer that  
	value"
	^ self assureExtension valueOfProperty: aSymbol ifAbsentPut: aBlock! !

!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:50'!
valueOfProperty: aSymbol ifAbsent: aBlock 
	"if the receiver possesses a property of the given name, answer  
	its value. If not then evaluate aBlock and answer the result of  
	this block evaluation"
	^ extension 
		ifNotNil: [extension valueOfProperty: aSymbol ifAbsent: aBlock]
		ifNil: [aBlock value]! !

!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:49'!
valueOfProperty: aSymbol ifPresentDo: aBlock 
	"If the receiver has a property of the given name, evaluate  
	aBlock on behalf of the value of that property"
	extension ifNil:  [^ self].
	^ aBlock value: (extension valueOfProperty: aSymbol ifAbsent: [^ self])! !


!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:35'!
fullLoadCachedState
	"Load the cached state of the receiver and its full submorph tree."

	self allMorphsDo: [:m | m loadCachedState].
! !

!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:34'!
fullReleaseCachedState
	"Release the cached state of the receiver and its full submorph tree."

	self allMorphsDo: [:m | m releaseCachedState].
! !

!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:37'!
loadCachedState
	"Load the cached state of this morph. This method may be called to pre-load the cached state of a morph to avoid delays when it is first used. (Cached state can always be recompued on demand, so a morph should not rely on this method being called.) Implementations of this method should do 'super loadCachedState'. This default implementation does nothing."
! !

!Morph methodsFor: 'caching' stamp: 'md 4/3/2006 12:02'!
releaseCachedState
	"Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'."
	self borderStyle releaseCachedState. 
! !


!Morph methodsFor: 'card in a stack' stamp: 'sd 3/30/2005 22:04'!
abstractAModel
	"Find data-containing fields in me.  Make a new class, whose instance variables are named for my fields, and whose values are the values I am showing.  Use a CardPlayer for now.  Force the user to name the fields.  Make slots for text, Number Watchers, SketchMorphs, and ImageMorphs."

	| instVarNames unnamed ans player twoListsOfMorphs holdsSepData docks oldPlayer iVarName |
	(oldPlayer := self player) ifNotNil: 
			[oldPlayer belongsToUniClass 
				ifTrue: 
					["Player"

					oldPlayer class instVarNames notEmpty 
						ifTrue: 
							[self 
								inform: 'I already have a regular Player, so I can''t have a CardPlayer'.
							^true]]].
	twoListsOfMorphs := StackMorph discoverSlots: self.
	holdsSepData := twoListsOfMorphs first.
	instVarNames := ''.
	holdsSepData do: 
			[:ea | 
			iVarName := Scanner wellFormedInstanceVariableNameFrom: ea knownName.
			iVarName = ea knownName ifFalse: [ea name: iVarName].
			instVarNames := instVarNames , iVarName , ' '].
	unnamed := twoListsOfMorphs second.	"have default names"
	instVarNames isEmpty 
		ifTrue: 
			[self 
				inform: 'No named fields were found.
Please get a halo on each field and give it a name.
Labels or non-data fields should be named "shared xxx".'.
			^false].
	unnamed notEmpty 
		ifTrue: 
			[ans := PopUpMenu 
						confirm: 'Data fields are ' , instVarNames printString 
								, ('\Some fields are not named.  Are they labels or non-data fields?' 
										, '\Please get a halo on each data field and give it a name.') withCRs
						trueChoice: 'All other fields are non-data fields'
						falseChoice: 'Stop.  Let me give a name to some more fields'.
			ans ifFalse: [^false]].
	unnamed 
		withIndexDo: [:mm :ind | mm setName: 'shared label ' , ind printString].
	"Make a Player with instVarNames.  Make me be the costume"
	player := CardPlayer instanceOfUniqueClassWithInstVarString: instVarNames
				andClassInstVarString: ''.
	self player: player.
	player costume: self.
	"Fill in the instance values.  Make docks first."
	docks := OrderedCollection new.
	holdsSepData do: 
			[:morph | 
			morph setProperty: #shared toValue: true.	"in case it is deeply embedded"
			morph setProperty: #holdsSeparateDataForEachInstance toValue: true.
			player class compileInstVarAccessorsFor: morph knownName.
			morph isSyntaxMorph ifTrue: [morph setTarget: player].	"hookup the UpdatingString!!"
			docks addAll: morph variableDocks].
	player class newVariableDocks: docks.
	docks do: [:dd | dd storeMorphDataInInstance: player].
	"oldPlayer class mdict do: [:assoc | move to player].	move methods to new class?"
	"oldPlayer become: player."
	^true	"success"! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 11/2/2001 13:31'!
beAStackBackground
	"Transform the receiver into one that has stack-background behavior.  If just becoming a stack, allocate a uniclass to represent the cards (if one does not already exist"

	self assuredCardPlayer assureUniClass.
	self setProperty: #tabAmongFields toValue: true.
	self setProperty: #stackBackground toValue: true.
	"put my submorphs onto the background"
	submorphs do: [:mm | mm setProperty: #shared toValue: true].
	self reassessBackgroundShape! !

!Morph methodsFor: 'card in a stack' stamp: 'sw 11/8/2002 14:57'!
becomeSharedBackgroundField
	"Mark the receiver as holding separate data for each instance (i.e., like a 'background field') and reassess the shape of the corresponding background so that it will be able to accommodate this arrangement."

	((self hasProperty: #shared) and: [self hasProperty: #holdsSeparateDataForEachInstance])
		ifFalse: 
			[self setProperty: #shared toValue: true.
			self setProperty: #holdsSeparateDataForEachInstance toValue: true.
			self stack reassessBackgroundShape]! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 18:54'!
containsCard: aCard
	"Answer whether the given card belongs to the uniclass representing the receiver"

	^ self isStackBackground and: [aCard isKindOf: self player class baseUniclass]! !

!Morph methodsFor: 'card in a stack' stamp: 'sw 10/27/2000 17:36'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')"

	^ false! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:32'!
currentDataInstance
	"Answer the current data instance"

	^ self player! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:33'!
explainDesignations
	"Hand the user an object that contains explanations for the designation feedback used"

	StackMorph designationsExplainer openInHand

	"self currentWorld explainDesignations"! !

!Morph methodsFor: 'card in a stack' stamp: 'sw 10/23/2000 14:49'!
goToNextCardInStack
	"Tell my stack to advance to the next page"

	self stackDo: [:aStack | aStack goToNextCardInStack]! !

!Morph methodsFor: 'card in a stack' stamp: 'sw 10/23/2000 14:52'!
goToPreviousCardInStack
	"Tell my stack to advance to the previous card"
	
	self stackDo: [:aStack | aStack goToPreviousCardInStack]! !

!Morph methodsFor: 'card in a stack' stamp: 'sw 10/27/2000 17:41'!
holdsSeparateDataForEachInstance
	"Answer whether the receiver is currently behaving as a 'background field', i.e., whether it is marked as shared (viz. occurring on the background of a stack) *and* is marked as holding separate data for each instance"

	^ self isShared and: [self hasProperty: #holdsSeparateDataForEachInstance]! !

!Morph methodsFor: 'card in a stack' stamp: 'yo 2/17/2005 17:47'!
insertAsStackBackground
	"I am not yet in a stack.  Find a Stack that my reference point (center) overlaps, and insert me as a new background."

	| aMorph |
	self isStackBackground ifTrue: [^ Beeper beep].	
		"already in a stack.  Must clear flags when remove."
"	self potentialEmbeddingTargets do: [:mm |   No, force user to choose a stack.  
		(mm respondsTo: #insertAsBackground:resize:) ifTrue: [
			^ mm insertAsBackground: self resize: false]].
"
	"None found, ask user"
	self inform: 'Please click on a Stack' translated.
	Sensor waitNoButton.
	aMorph _ self world chooseClickTarget.
	aMorph ifNil: [^ self].
	(aMorph ownerThatIsA: StackMorph) insertAsBackground: self resize: false.! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:35'!
insertCard
	"Insert a new card in the stack, with the receiver as its background, and have it become the current card of the stack"

	self stackDo: [:aStack | aStack insertCardOfBackground: self]! !

!Morph methodsFor: 'card in a stack' stamp: 'sw 11/8/2002 15:16'!
installAsCurrent: anInstance
	"Install anInstance as the one currently viewed in the receiver.  Dock up all the morphs in the receiver which contain data rooted in the player instance to the instance data.  Run any 'opening' scripts that pertain."

	| fieldList itsFocus |
	self player == anInstance ifTrue: [^ self].
	fieldList _ self allMorphs select:
		[:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]].
	self currentWorld hands do:
		[:aHand | (itsFocus _ aHand keyboardFocus) notNil ifTrue:
			[(fieldList includes: itsFocus) ifTrue: [aHand newKeyboardFocus: nil]]].

	self player uninstallFrom: self.  "out with the old"

	anInstance installPrivateMorphsInto: self.
	self changed.
	anInstance costume: self.
	self player: anInstance.
	self player class variableDocks do:
		[:aVariableDock | aVariableDock dockMorphUpToInstance: anInstance].
	self currentWorld startSteppingSubmorphsOf: self! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:42'!
isStackBackground
	"Answer whether the receiver serves as a background of a stack"

	^ ((owner isKindOf: StackMorph) and: [owner currentPage == self]) or:
		[self hasProperty: #stackBackground]

	"This odd property-based check is because when a paste-up-morph is not the *current* background of a stack, it is maddeningly ownerlyess"! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 11/2/2001 13:38'!
makeHoldSeparateDataForEachInstance
	"Mark the receiver as holding separate data for each instance (i.e., like a 'background field') and reassess the shape of the corresponding background so that it will be able to accommodate this arrangement."

	self setProperty: #holdsSeparateDataForEachInstance toValue: true.
	self stack reassessBackgroundShape.! !

!Morph methodsFor: 'card in a stack' stamp: 'nb 6/17/2003 12:25'!
newCard
	"Create a new card for the receiver and return it"

	| aNewInstance |
	self isStackBackground ifFalse: [^ Beeper beep].  "bulletproof against deconstruction"
	aNewInstance _ self player class baseUniclass new.
	^ aNewInstance! !

!Morph methodsFor: 'card in a stack' stamp: 'md 10/22/2003 15:52'!
reassessBackgroundShape
	"A change has been made which may affect the instance structure of the Card uniclass that holds the instance state, which can also be thought of as the 'card data'."

	"Caution: still to be done: the mechanism so that when a new instance variable is added, it gets initialized in all subinstances of the receiver's player, which are the cards of this shape.  One needs to take into account here the instance variable names coming in; those that are unchanged should keep their values, but those that have newly arrived should obtain their default values from the morphs on whose behalf they are being maintained in the model"

	| takenNames uniqueName requestedName variableDocks docks sepDataMorphs sorted existing name1 name2 |
	self isStackBackground ifFalse: [^Beeper beep].	"bulletproof against deconstruction"
	Cursor wait showWhile: 
			[variableDocks := OrderedCollection new.	"This will be stored in the uniclass's 
			class-side inst var #variableDocks"
			takenNames := OrderedCollection new.
			sepDataMorphs := OrderedCollection new.	"fields, holders of per-card data"
			self submorphs do: 
					[:aMorph | 
					aMorph renderedMorph holdsSeparateDataForEachInstance 
						ifTrue: [sepDataMorphs add: aMorph renderedMorph]
						ifFalse: 
							["look for buried fields, inside a frame"

							aMorph renderedMorph isShared 
								ifTrue: 
									[aMorph allMorphs do: 
											[:mm | 
											mm renderedMorph holdsSeparateDataForEachInstance 
												ifTrue: [sepDataMorphs add: mm renderedMorph]]]]].
			sorted := SortedCollection new 
						sortBlock: [:a :b | (a valueOfProperty: #cardInstance) notNil].	"puts existing ones first"
			sorted addAll: sepDataMorphs.
			sorted do: 
					[:aMorph | 
					docks := aMorph variableDocks.
					"Each morph can request multiple variables.  
	This complicates matters somewhat but creates a generality for Fabrk-like uses.
	Each spec is an instance of VariableDock, and it provides a point of departure
	for the negotiation between the PasteUp and its constitutent morphs"
					docks do: 
							[:aVariableDock | 
							uniqueName := self player 
										uniqueInstanceVariableNameLike: (requestedName := aVariableDock 
														variableName)
										excluding: takenNames.
							uniqueName ~= requestedName 
								ifTrue: 
									[aVariableDock variableName: uniqueName.
									aMorph noteNegotiatedName: uniqueName for: requestedName].
							takenNames add: uniqueName].
					variableDocks addAll: docks].
			existing := self player class instVarNames.
			variableDocks := (variableDocks asSortedCollection: 
							[:dock1 :dock2 | 
							name1 := dock1 variableName.
							name2 := dock2 variableName.
							(existing indexOf: name1 ifAbsent: [0]) 
								< (existing indexOf: name2 ifAbsent: [variableDocks size])]) 
						asOrderedCollection.
			self player class setNewInstVarNames: (variableDocks 
						collect: [:info | info variableName asString]).
			"NB: sets up accessors, and removes obsolete ones"
			self player class newVariableDocks: variableDocks]! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:46'!
relaxGripOnVariableNames
	"Abandon any memory of specific variable names that should be preserved.  The overall situation here is not yet completely understood, and this relaxation is basically always done on each reassessment of the background shape nowadays.  But this doesn't feel quite right, because if the user has somehow intervened to specify certain name preference we should perhaps honored it.  Or perhaps that is no longer relevant.  ????"

	self submorphs do:
		[:m | m removeProperty: #variableName.
		m removeProperty: #setterSelector].
	self reassessBackgroundShape
! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:47'!
reshapeBackground
	"Abandon any memory of variable-name preferences, and reassess the shape of the background"

	self relaxGripOnVariableNames.
	"self reassessBackgroundShape.	already done there"! !

!Morph methodsFor: 'card in a stack' stamp: 'sw 10/24/2000 06:30'!
setAsDefaultValueForNewCard
	"Set the receiver's current value as the one to be used to supply the default value for a variable on a new card.  This implementation does not support multiple variables per morph, which is problematical"

	self setProperty: #defaultValue toValue: self currentDataValue deepCopy! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:48'!
showBackgroundObjects
	"Momentarily highlight just the background objects on the current playfield"

	self isStackBackground ifFalse: [^ self].
	self invalidRect: self bounds.
	self currentWorld doOneCycle.
	Display restoreAfter:
		[self submorphsDo:
			[:aMorph | (aMorph renderedMorph hasProperty: #shared)
				ifTrue:
					[Display border: (aMorph fullBoundsInWorld insetBy: -6) 
							width: 6 rule: Form over fillColor: Color blue]]]! !

!Morph methodsFor: 'card in a stack' stamp: 'aoy 2/15/2003 21:50'!
showDesignationsOfObjects
	"Momentarily show the designations of objects on the receiver"

	| colorToUse aLabel |
	self isStackBackground ifFalse: [^self].
	self submorphsDo: 
			[:aMorph | 
			aLabel :=aMorph renderedMorph holdsSeparateDataForEachInstance 
				ifTrue: 
					[colorToUse := Color orange.
					 aMorph externalName]
				ifFalse: 
					[colorToUse := aMorph isShared ifFalse: [Color red] ifTrue: [Color green].
					 nil].
			Display 
				border: (aMorph fullBoundsInWorld insetBy: -6)
				width: 6
				rule: Form over
				fillColor: colorToUse.
			aLabel ifNotNil: 
					[aLabel asString 
						displayOn: Display
						at: aMorph fullBoundsInWorld bottomLeft + (0 @ 5)
						textColor: Color blue]].
	Sensor anyButtonPressed 
		ifTrue: [Sensor waitNoButton]
		ifFalse: [Sensor waitButton].
	World fullRepaintNeeded! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:50'!
showForegroundObjects
	"Temporarily highlight the foreground objects"

	self isStackBackground ifFalse: [^ self].
	Display restoreAfter:
		[self submorphsDo:
			[:aMorph | aMorph renderedMorph isShared
				ifFalse:
					[Display border: (aMorph fullBoundsInWorld insetBy: -6) 
						width: 6 rule: Form over fillColor: Color orange]]]! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 11/2/2001 13:53'!
stack
	"Answer the nearest containing Stack, or, if none, a stack in the current project, and if still none, nil.  The extra messiness is because uninstalled backgrounds don't have an owner pointers to their stack."

	| aStack bkgnd |
	bkgnd _ self orOwnerSuchThat: [:oo | oo hasProperty: #myStack].
	bkgnd ifNotNil: [^ bkgnd valueOfProperty: #myStack].

	"fallbacks"
	(aStack _ self ownerThatIsA: StackMorph) ifNotNil: [^ aStack].
	^ Project current currentStack! !

!Morph methodsFor: 'card in a stack' stamp: 'sw 10/23/2000 14:38'!
stackDo: aBlock
	"If the receiver has a stack, evaluate aBlock on its behalf"

	| aStack |
	(aStack _ self ownerThatIsA: StackMorph) ifNotNil:
		[^ aBlock value: aStack]! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 11/2/2001 13:38'!
stopHoldingSeparateDataForEachInstance
	"Make the receiver no longer hold separate data for each instance"

	self removeProperty: #holdsSeparateDataForEachInstance.
	self stack reassessBackgroundShape.! !

!Morph methodsFor: 'card in a stack' stamp: 'dgd 8/28/2004 19:15'!
tabHitWithEvent: anEvent
	"The tab key was hit.  The keyboard focus has referred this event to me, though this perhaps seems rather backwards.  Anyway, the assumption is that I have the property #tabAmongFields, so now the task is to tab to the next field."

	| currentFocus fieldList anIndex itemToHighlight variableBearingMorphs otherAmenableMorphs |
	currentFocus _ anEvent hand keyboardFocus.
	fieldList _ self allMorphs select:
		[:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]].

	fieldList isEmpty ifTrue:[^ self].

	variableBearingMorphs _ self player isNil
										ifTrue:[#()]
										ifFalse:[self player class variableDocks collect: [:vd | vd definingMorph] thenSelect: [:m | m isInWorld]].
	otherAmenableMorphs _ (self allMorphs select:
		[:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]])
			copyWithoutAll: variableBearingMorphs.
	fieldList _ variableBearingMorphs, otherAmenableMorphs.

	anIndex _ fieldList indexOf: currentFocus ifAbsent: [nil].
	itemToHighlight _ fieldList atWrap: 
		(anIndex ifNotNil: [anEvent shiftPressed ifTrue: [anIndex - 1] ifFalse: [anIndex + 1]]
				ifNil: [1]).
	anEvent hand newKeyboardFocus: itemToHighlight. self flag: #arNote. "really???"
	itemToHighlight editor selectAll.
	itemToHighlight invalidRect: itemToHighlight bounds ! !

!Morph methodsFor: 'card in a stack' stamp: 'tk 11/4/2001 20:57'!
wrapWithAStack
	"Install me as a card inside a new stack.  The stack has no border or controls, so I my look is unchanged.  If I don't already have a CardPlayer, find my data fields and make one.  Be ready to make new cards in the stack that look like me, but hold different field data."

	self player class officialClass == CardPlayer ifFalse: [
		self abstractAModel ifFalse: [^ false]].
	StackMorph new initializeWith: self.
	self stack addHalo.	"Makes it easier for the user"! !


!Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 21:50'!
addedMorph: aMorph
	"Notify the receiver that the given morph was just added."
! !

!Morph methodsFor: 'change reporting' stamp: 'sw 9/10/1998 08:18'!
colorChangedForSubmorph: aSubmorph
	"The color associated with aSubmorph was changed through the UI; react if needed"! !

!Morph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:50'!
invalidRect: damageRect
	^self invalidRect: damageRect from: self! !

!Morph methodsFor: 'change reporting' stamp: 'md 4/3/2006 11:52'!
invalidRect: aRectangle from: aMorph
	| damageRect |
	aRectangle hasPositiveExtent ifFalse: [ ^self ].
	damageRect _ aRectangle.
	aMorph == self ifFalse:[
		"Clip to receiver's clipping bounds if the damage came from a child"
		self clipSubmorphs 
			ifTrue:[damageRect _ aRectangle intersect: self clippingBounds]].
	owner ifNotNil: [owner invalidRect: damageRect from: self].! !

!Morph methodsFor: 'change reporting' stamp: 'sw 7/8/1998 13:21'!
ownerChanged
	"The receiver's owner, some kind of a pasteup, has changed its layout."

	self snapToEdgeIfAppropriate! !

!Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 22:26'!
privateInvalidateMorph: aMorph
	"Private. Invalidate the given morph after adding or removing.
	This method is private because a) we're invalidating the morph 'remotely'
	and b) it forces a fullBounds computation which should not be necessary
	for a general morph c) the morph may or may not actually invalidate
	anything (if it's not in the world nothing will happen) and d) the entire
	mechanism should be rewritten."
	aMorph fullBounds.
	aMorph changed! !

!Morph methodsFor: 'change reporting' stamp: 'tk 8/24/2001 22:07'!
userSelectedColor: aColor
	"The user, via the UI, chose aColor to be the color for the receiver; set it, and tell my owner in case he wishes to react"
	self color: aColor.
	self world ifNotNil: [owner colorChangedForSubmorph: self]! !


!Morph methodsFor: 'classification' stamp: 'sw 2/26/2002 23:29'!
demandsBoolean
	"Answer whether the receiver will only accept a drop if it is boolean-valued.  Particular to tile-scripting."

	^ self hasProperty: #demandsBoolean! !

!Morph methodsFor: 'classification' stamp: 'di 5/7/1998 01:21'!
isAlignmentMorph

	^ false! !

!Morph methodsFor: 'classification' stamp: 'ar 9/15/2000 17:56'!
isBalloonHelp
	^false! !

!Morph methodsFor: 'classification' stamp: 'ar 9/28/2000 13:54'!
isFlapOrTab
	^self isFlap or:[self isFlapTab]! !

!Morph methodsFor: 'classification' stamp: 'ar 9/28/2000 13:53'!
isFlapTab
	^false! !

!Morph methodsFor: 'classification' stamp: 'jm 4/17/1998 00:44'!
isFlexMorph

	^ false
! !

!Morph methodsFor: 'classification'!
isHandMorph

	^ false! !

!Morph methodsFor: 'classification' stamp: 'ar 10/3/2000 18:11'!
isModalShell
	^false! !

!Morph methodsFor: 'classification' stamp: 'sw 1/29/98 21:51'!
isPlayfieldLike
	^ false! !

!Morph methodsFor: 'classification' stamp: 'jm 5/7/1998 13:45'!
isRenderer
	"A *renderer* morph transforms the appearance of its submorph in some manner. For example, it might supply a drop shadow or scale and rotate the morph it encases. Answer true if this morph acts as a renderer. This default implementation returns false."
	"Details: A renderer is assumed to have a single submorph. Renderers may be nested to concatenate their transformations. It is useful to be able to find the outer-most renderer. This can be done by ascending the owner chain from the rendered morph. To find the morph being rendered, one can descend through the (singleton) submorph lists of the renderer chain until a non-renderer is encountered."

	^ false
! !

!Morph methodsFor: 'classification' stamp: 'ar 6/30/2001 13:13'!
isStandardViewer
	^false! !

!Morph methodsFor: 'classification' stamp: 'di 11/2/2000 13:24'!
isSyntaxMorph
	^false! !

!Morph methodsFor: 'classification' stamp: 'ar 12/16/2001 18:28'!
isTextMorph
	^false! !

!Morph methodsFor: 'classification'!
isWorldMorph

	^ false! !

!Morph methodsFor: 'classification'!
isWorldOrHandMorph

	^ self isWorldMorph or: [self isHandMorph]! !


!Morph methodsFor: 'connectors-scripting' stamp: 'nk 9/10/2004 11:37'!
wantsConnectorVocabulary
	"Answer true if I want to show a 'connector' vocabulary"
	^false! !


!Morph methodsFor: 'converting'!
asDraggableMorph
	^self! !

!Morph methodsFor: 'converting' stamp: 'wiz 2/19/2006 19:01'!
asSnapshotThumbnail
	^(ThumbnailImageMorph new  newImage: self imageForm ) extent: 90 asPoint .! !


!Morph methodsFor: 'copying' stamp: 'tk 2/19/2001 18:21'!
copy

	^ self veryDeepCopy! !

!Morph methodsFor: 'copying' stamp: 'tk 2/14/2001 12:47'!
deepCopy

	self error: 'Please use veryDeepCopy'.
! !

!Morph methodsFor: 'copying' stamp: 'sw 4/19/2005 17:02'!
duplicate
	"Make and return a duplicate of the receiver"

	| newMorph aName w aPlayer topRend |
	((topRend _ self topRendererOrSelf) ~~ self) ifTrue: [^ topRend duplicate].

	self okayToDuplicate ifFalse: [^ self].
	aName _ (w _ self world) ifNotNil:
		[w nameForCopyIfAlreadyNamed: self].
	newMorph _ self veryDeepCopy.
	aName ifNotNil: [newMorph setNameTo: aName].

	newMorph arrangeToStartStepping.
	newMorph privateOwner: nil. "no longer in world"
	newMorph isPartsDonor: false. "no longer parts donor"
	(aPlayer _ newMorph player) belongsToUniClass ifTrue:
		[aPlayer class bringScriptsUpToDate].
	aPlayer ifNotNil: [ActiveWorld presenter flushPlayerListCache].
	^ newMorph! !

!Morph methodsFor: 'copying' stamp: 'nk 3/12/2001 17:07'!
duplicateMorphCollection: aCollection
	"Make and return a duplicate of the receiver"

	| newCollection names |

	names _ aCollection collect: [ :ea | | newMorph w |
		(w _ ea world) ifNotNil:
			[w nameForCopyIfAlreadyNamed: ea].
	].

	newCollection _ aCollection veryDeepCopy.

	newCollection with: names do: [ :newMorph :name |
		name ifNotNil: [ newMorph setNameTo: name ].
		newMorph arrangeToStartStepping.
		newMorph privateOwner: nil. "no longer in world"
		newMorph isPartsDonor: false. "no longer parts donor"
	].

	^newCollection! !

!Morph methodsFor: 'copying' stamp: 'sw 2/16/2001 16:30'!
fullCopy
	"Deprecated, but maintained for backward compatibility with existing code (no senders in the base 3.0 image).   Calls are revectored to #veryDeepCopy, but note that #veryDeepCopy does not do exactly the same thing that the original #fullCopy did, so beware!!"

	^ self veryDeepCopy! !

!Morph methodsFor: 'copying' stamp: 'md 2/27/2006 08:53'!
updateReferencesUsing: aDictionary 
	"Update intra-morph references within a composite morph that 
	has been copied. For example, if a button refers to morph X in 
	the orginal 
	composite then the copy of that button in the new composite 
	should refer to 
	the copy of X in new composite, not the original X. This default 
	implementation updates the contents of any morph-bearing slot. 
	It may be 
	overridden to avoid this behavior if so desired."
	| old |
	Morph instSize + 1
		to: self class instSize
		do: [:i | 
			old _ self instVarAt: i.
			old isMorph
				ifTrue: [self
						instVarAt: i
						put: (aDictionary
								at: old
								ifAbsent: [old])]].
	extension ifNotNil: [extension updateReferencesUsing: aDictionary]! !

!Morph methodsFor: 'copying' stamp: 'nk 10/11/2003 16:59'!
usableSiblingInstance
	"Return another similar morph whose Player is of the same class as mine.
	Do not open it in the world."

	| aName usedNames newPlayer newMorph topRenderer |
	(topRenderer := self topRendererOrSelf) == self 
		ifFalse: [^topRenderer usableSiblingInstance].
	self assuredPlayer assureUniClass.
	newMorph := self veryDeepCopySibling.
	newPlayer := newMorph player.
	newPlayer resetCostumeList.
	(aName := self knownName) isNil 
		ifTrue: [self player notNil ifTrue: [aName := newMorph innocuousName]].
	"Force a difference here"
	aName notNil 
		ifTrue: 
			[usedNames := (self world ifNil: [OrderedCollection new]
						ifNotNil: [self world allKnownNames]) copyWith: aName.
			newMorph setNameTo: (Utilities keyLike: aName
						satisfying: [:f | (usedNames includes: f) not])].
	newMorph privateOwner: nil.
	newPlayer assureEventHandlerRepresentsStatus.
	self presenter flushPlayerListCache.
	^newMorph! !

!Morph methodsFor: 'copying' stamp: 'tk 1/6/1999 17:27'!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  See veryDeepInner:, veryDeepFixupWith:"

	self prepareToBeSaved.
	^ super veryDeepCopyWith: deepCopier! !

!Morph methodsFor: 'copying' stamp: 'tk 2/3/2001 14:29'!
veryDeepFixupWith: deepCopier
	"If some fields were weakly copied, fix new copy here."

	"super veryDeepFixupWith: deepCopier.	Object has no fixups, so don't call it"

	"If my owner is being duplicated too, then store his duplicate.
	 If I am owned outside the duplicated tree, then I am no longer owned!!"
	owner _ deepCopier references at: owner ifAbsent: [nil].

! !

!Morph methodsFor: 'copying' stamp: 'md 2/27/2006 08:47'!
veryDeepInner: deepCopier 
	"The inner loop, so it can be overridden when a field should not  
	be traced."
	"super veryDeepInner: deepCopier.	know Object has no inst vars"
	bounds _ bounds clone.
	"Points are shared with original"
	"owner _ owner.	special, see veryDeepFixupWith:"
	submorphs _ submorphs veryDeepCopyWith: deepCopier.
	"each submorph's fixup will install me as the owner"
	"fullBounds _ fullBounds.	fullBounds is shared with original!!"
	color _ color veryDeepCopyWith: deepCopier.
	"color, if simple, will return self. may be complex"
	extension := (extension veryDeepCopyWith: deepCopier)! !


!Morph methodsFor: 'creation' stamp: 'tk 2/6/1999 22:43'!
asMorph
	^ self! !


!Morph methodsFor: 'debug and other' stamp: 'dgd 8/30/2003 20:36'!
addDebuggingItemsTo: aMenu hand: aHandMorph
	aMenu add: 'debug...' translated subMenu:  (self buildDebugMenu: aHandMorph)! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 1/19/2001 07:51'!
addMouseActionIndicatorsWidth: anInteger color: aColor

	self deleteAnyMouseActionIndicators.

	self changed.
	self hasRolloverBorder: true.
	self setProperty: #rolloverWidth toValue: anInteger@anInteger.
	self setProperty: #rolloverColor toValue: aColor.
	self layoutChanged.
	self changed.

! !

!Morph methodsFor: 'debug and other' stamp: 'gm 4/25/2004 14:23'!
addMouseUpAction
	| codeToRun oldCode |
	oldCode := self
				valueOfProperty: #mouseUpCodeToRun
				ifAbsent: [''].
	codeToRun := FillInTheBlank request: 'MouseUp expression:' translated initialAnswer: oldCode.
	self addMouseUpActionWith: codeToRun! !

!Morph methodsFor: 'debug and other' stamp: 'gm 2/22/2003 13:41'!
addMouseUpActionWith: codeToRun 
	((codeToRun isMessageSend) not and: [codeToRun isEmptyOrNil]) 
		ifTrue: [^self].
	self setProperty: #mouseUpCodeToRun toValue: codeToRun.
	self 
		on: #mouseUp
		send: #programmedMouseUp:for:
		to: self.
	self 
		on: #mouseDown
		send: #programmedMouseDown:for:
		to: self.
	self 
		on: #mouseEnter
		send: #programmedMouseEnter:for:
		to: self.
	self 
		on: #mouseLeave
		send: #programmedMouseLeave:for:
		to: self! !

!Morph methodsFor: 'debug and other' stamp: 'sw 1/3/2001 06:42'!
addViewingItemsTo: aMenu
	"Add viewing-related items to the given menu.  If any are added, this method is also responsible for adding a line after them"! !

!Morph methodsFor: 'debug and other' stamp: 'dgd 2/22/2003 14:27'!
allStringsAfter: aSubmorph 
	"return an OrderedCollection of strings of text in my submorphs.  If aSubmorph is non-nil, begin with that container."

	| list string ok |
	list := OrderedCollection new.
	ok := aSubmorph isNil.
	self allMorphsDo: 
			[:sub | 
			ok ifFalse: [ok := sub == aSubmorph].	"and do this one too"
			ok 
				ifTrue: 
					[(string := sub userString) ifNotNil: 
							[string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]].
	^list! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:27'!
altSpecialCursor0
	"an arrow"
	^(Form
	extent: 16@16
	depth: 8
	fromArray: #( 0 0 0 0 14869218 3806520034 3806520034 3791650816 14848144 2425393296 2425393378 0 14848144 2425393296 2425414144 0 14848144 2425393296 2430730240 0 14848144 2425393296 3791650816 0 14848144 2425393378 3791650816 0 14848144 2425414370 3806461952 0 14848144 2430788322 3806519808 0 14848144 3791651042 3806520034 0 14848226 0 3806520034 3791650816 14868992 0 14869218 3806461952 14811136 0 58082 3806519808 0 0 226 3806520034 0 0 0 3806520034 0 0 0 14869218)
	offset: 0@0)
! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:28'!
altSpecialCursor1
	"a star and an arrow"
	^(Form
	extent: 31@26
	depth: 8
	fromArray: #( 14417920 0 0 0 0 0 0 0 3705461980 3705461980 3705405440 0 0 0 0 0 3705461980 3705461980 3705461760 0 0 0 0 0 14474460 3705461980 3705405440 0 0 0 0 0 56540 3705461980 3690987520 0 0 3690987520 0 0 220 3705461980 3705461760 0 0 3690987520 0 0 220 3705405440 3705461980 0 0 3705405440 0 0 0 3705461760 56540 3690987520 220 3705405440 0 0 0 3705405440 220 3705461760 220 3705405440 0 0 0 0 0 14474460 220 3705461760 0 0 0 0 0 56540 3691044060 3705461760 0 0 0 0 0 220 3705461980 3705461760 0 0 0 0 56540 3705461980 3705461980 3705461980 3705461980 3705461760 0 0 220 3705461980 3705461980 3705461980 3705461980 3705461760 0 0 0 3705461980 3705461980 3705461980 3705461980 3705405440 0 0 0 14474460 3705461980 3705461980 3705461980 3690987520 0 0 0 56540 3705461980 3705461980 3705461760 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 0 3705461980 3705461980 3690987520 0 0 0 0 0 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 14474460 3705405440 0 0 0 0 220 3705405440 220 3705461760 0 0 0 0 56540 3690987520 0 3705461760 0 0 0 0 56540 0 0 14474240 0)
	offset: 0@0)! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:41'!
altSpecialCursor2
	| f |
	"a blue box with transparent center"
	f _ Form extent: 32@32 depth: 32.
	f offset: (f extent // 2) negated.
	f fill: f boundingBox rule: Form over fillColor: (Color blue alpha: 0.5).
	f fill: (f boundingBox insetBy: 4) rule: Form over fillColor: Color transparent.
	^f
! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:42'!
altSpecialCursor3
	
	^self altSpecialCursor3: Color blue! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:41'!
altSpecialCursor3: aColor
	| f box |
	"a bulls-eye pattern in this color"
	f _ Form extent: 32@32 depth: 32.
	f offset: (f extent // 2) negated.
	box _ f boundingBox.
	[ box width > 0] whileTrue: [
		f fill: box rule: Form over fillColor: aColor.
		f fill: (box insetBy: 2) rule: Form over fillColor: Color transparent.
		box _ box insetBy: 4.
	].
	^f
! !

!Morph methodsFor: 'debug and other' stamp: 'nk 6/14/2004 16:14'!
buildDebugMenu: aHand
	"Answer a debugging menu for the receiver.  The hand argument is seemingly historical and plays no role presently"

	| aMenu aPlayer |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	(self hasProperty: #errorOnDraw) ifTrue:
		[aMenu add: 'start drawing again' translated action: #resumeAfterDrawError.
		aMenu addLine].
	(self hasProperty: #errorOnStep) ifTrue:
		[aMenu add: 'start stepping again' translated action: #resumeAfterStepError.
		aMenu addLine].

	aMenu add: 'inspect morph' translated action: #inspectInMorphic:.
	aMenu add: 'inspect owner chain' translated action: #inspectOwnerChain.
	Smalltalk isMorphic ifFalse:
		[aMenu add: 'inspect morph (in MVC)' translated action: #inspect].

	self isMorphicModel ifTrue:
		[aMenu add: 'inspect model' translated target: self model action: #inspect].
	(aPlayer _ self player) ifNotNil:
		[aMenu add: 'inspect player' translated target: aPlayer action: #inspect].

     aMenu add: 'explore morph' translated target: self selector: #explore.

	aMenu addLine.
	aPlayer ifNotNil:
		[ aMenu add: 'viewer for Player' translated target: self player action: #beViewed.
	aMenu balloonTextForLastItem: 'Opens a viewer on my Player -- this is the same thing you get if you click on the cyan "View" halo handle' translated ].

	aMenu add: 'viewer for Morph' translated target: self action: #viewMorphDirectly.
	aMenu balloonTextForLastItem: 'Opens a Viewer on this Morph, rather than on its Player' translated.
	aMenu addLine.

	aPlayer ifNotNil:
		[aPlayer class isUniClass ifTrue: [
			aMenu add: 'browse player class' translated target: aPlayer action: #browseHierarchy]].
	aMenu add: 'browse morph class' translated target: self selector: #browseHierarchy.
	(self isMorphicModel)
		ifTrue: [aMenu
				add: 'browse model class'
				target: self model
				selector: #browseHierarchy].
	aMenu addLine.

	aPlayer ifNotNil:
		[aMenu add: 'player protocol (tiles)' translated target: aPlayer action: #openInstanceBrowserWithTiles
			"#browseProtocolForPlayer"].
	aMenu add: 'morph protocol (text)' translated target: self selector: #haveFullProtocolBrowsed.
	aMenu add: 'morph protocol (tiles)' translated target: self selector: #openInstanceBrowserWithTiles.
	aMenu addLine.

	self addViewingItemsTo: aMenu.
	aMenu 
		add: 'make own subclass' translated action: #subclassMorph;
		add: 'internal name ' translated action: #choosePartName;
		add: 'save morph in file' translated  action: #saveOnFile;
		addLine;
		add: 'call #tempCommand' translated action: #tempCommand;
		add: 'define #tempCommand' translated action: #defineTempCommand;
		addLine;

		add: 'control-menu...' translated target: self selector: #invokeMetaMenu:;
		add: 'edit balloon help' translated action: #editBalloonHelpText.

	^ aMenu! !

!Morph methodsFor: 'debug and other' stamp: 'ar 9/27/2005 20:29'!
defineTempCommand
	"To use this, comment out what's below here, and substitute your own code.
You will then be able to invoke it from the standard debugging menus.  If invoked from the world menu, you'll always get it invoked on behalf of the world, but if invoked from an individual morph's meta-menu, it will be invoked on behalf of that individual morph.

Note that you can indeed reimplement tempCommand in an individual morph's class if you wish"

	ToolSet browse: Morph
		selector: #tempCommand! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 1/19/2001 07:51'!
deleteAnyMouseActionIndicators

	self changed.
	(self valueOfProperty: #mouseActionIndicatorMorphs ifAbsent: [#()]) do: [ :each |
		each deleteWithSiblings		"one is probably enough, but be safe"
	].
	self removeProperty: #mouseActionIndicatorMorphs.
	self hasRolloverBorder: false.
	self removeProperty: #rolloverWidth.
	self removeProperty: #rolloverColor.
	self layoutChanged.
	self changed.

! !

!Morph methodsFor: 'debug and other' stamp: 'sw 7/17/2001 19:08'!
handMeTilesToFire 
	"Construct a phrase of tiles comprising a line of code that will 'fire' this object, and hand it to the user"

	ActiveHand attachMorph: (self assuredPlayer tilesToCall: MethodInterface firingInterface)! !

!Morph methodsFor: 'debug and other' stamp: 'ar 10/5/2000 17:38'!
inspectArgumentsPlayerInMorphic: evt
	evt hand attachMorph: ((Inspector openAsMorphOn: self player) extent: 300@200)! !

!Morph methodsFor: 'debug and other' stamp: 'sw 11/5/1998 20:31'!
inspectOwnerChain
	self ownerChain inspectWithLabel: 'Owner chain for ', self printString! !

!Morph methodsFor: 'debug and other'!
installModelIn: ignored
	"Simple morphs have no model"
	"See MorphicApp for other behavior"! !

!Morph methodsFor: 'debug and other' stamp: 'sw 2/6/2001 22:35'!
mouseUpCodeOrNil
	"If the receiver has a mouseUpCodeToRun, return it, else return nil"

	^ self valueOfProperty: #mouseUpCodeToRun ifAbsent: [nil]! !

!Morph methodsFor: 'debug and other' stamp: 'dgd 2/22/2003 19:05'!
ownerChain
	"Answer a list of objects representing the receiver and all of its owners.   The first element is the receiver, and the last one is typically the world in which the receiver resides"

	| c next |
	c := OrderedCollection with: self.
	next := self.
	[(next := next owner) notNil] whileTrue: [c add: next].
	^c asArray! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:16'!
programmedMouseDown: anEvent for: aMorph

	aMorph addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7).

! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:16'!
programmedMouseEnter: anEvent for: aMorph

	aMorph addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3).

! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:10'!
programmedMouseLeave: anEvent for: aMorph

	self deleteAnyMouseActionIndicators.
! !

!Morph methodsFor: 'debug and other' stamp: 'gm 2/22/2003 13:41'!
programmedMouseUp: anEvent for: aMorph 
	| aCodeString |
	self deleteAnyMouseActionIndicators.
	aCodeString := self valueOfProperty: #mouseUpCodeToRun ifAbsent: [^self].
	(self fullBounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
	
	[(aCodeString isMessageSend) 
		ifTrue: [aCodeString value]
		ifFalse: 
			[Compiler 
				evaluate: aCodeString
				for: self
				notifying: nil
				logged: false]] 
			on: ProgressTargetRequestNotification
			do: [:ex | ex resume: self]	"in case a save/load progress display needs a home"! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:43'!
removeMouseUpAction

	self primaryHand showTemporaryCursor: nil.
	self removeProperty: #mouseUpCodeToRun.
	#(mouseUp mouseEnter mouseLeave mouseDown) do: [ :sym |
		self
			on: sym 
			send: #yourself 
			to: nil.
	]

! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 5/24/2000 18:20'!
resumeAfterDrawError

	self changed.
	self removeProperty:#errorOnDraw.
	self changed.! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 5/24/2000 18:20'!
resumeAfterStepError
	"Resume stepping after an error has occured."

	self startStepping. "Will #step"
	self removeProperty:#errorOnStep. "Will remove prop only if #step was okay"
! !

!Morph methodsFor: 'debug and other' stamp: 'dgd 8/30/2003 20:43'!
tempCommand
	"Generic backstop.  If you care to, you can comment out what's below here, and substitute your own code, though the intention of design of the feature is that you leave this method as it is, and instead reimplement tempCommand in the class of whatever individual morph you care to.  In any case, once you have your own #tempCommand in place, you will then be able to invoke it from the standard debugging menus."

	self inform: 'Before calling tempCommand, you
should first give it a definition.  To
do this, choose "define tempCommand"
from the debug menu.' translated! !

!Morph methodsFor: 'debug and other' stamp: 'sw 8/4/2001 00:33'!
viewMorphDirectly
	"Open a Viewer directly on the Receiver, i.e. no Player involved"

	self presenter viewObjectDirectly: self renderedMorph

	! !


!Morph methodsFor: 'dispatching' stamp: 'nk 2/15/2004 09:16'!
disableSubmorphFocusForHand: aHandMorph
	"Check whether this morph or any of its submorph has the Genie focus.
	If yes, disable it."
! !


!Morph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:10'!
areasRemainingToFill: aRectangle
	"May be overridden by any subclasses with opaque regions"

	^ Array with: aRectangle! !

!Morph methodsFor: 'drawing' stamp: 'sw 6/4/2000 22:02'!
boundingBoxOfSubmorphs
	| aBox |
	aBox _ bounds origin extent: self minimumExtent.  "so won't end up with something empty"
	submorphs do:
		[:m | m visible ifTrue: [aBox _ aBox quickMerge: m fullBounds]].
	^ aBox
! !

!Morph methodsFor: 'drawing' stamp: 'di 2/15/2001 14:51'!
boundsWithinCorners

	^ CornerRounder rectWithinCornersOf: self bounds! !

!Morph methodsFor: 'drawing' stamp: 'ar 11/4/2000 23:39'!
changeClipSubmorphs
	self clipSubmorphs: self clipSubmorphs not.! !

!Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:02'!
clipLayoutCells
	"Drawing/layout specific. If this property is set, clip the  
	submorphs of the receiver by its cell bounds."
	^ self
		valueOfProperty: #clipLayoutCells
		ifAbsent: [false]! !

!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:22'!
clipLayoutCells: aBool
	"Drawing/layout specific. If this property is set, clip the submorphs of the receiver by its cell bounds."
	aBool == false
		ifTrue:[self removeProperty: #clipLayoutCells]
		ifFalse:[self setProperty: #clipLayoutCells toValue: aBool].
	self changed.! !

!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:16'!
clippingBounds
	"Return the bounds to which any submorphs should be clipped if the property is set"
	^self innerBounds! !

!Morph methodsFor: 'drawing' stamp: 'md 4/3/2006 11:53'!
clipSubmorphs
	"Drawing specific. If this property is set, clip the receiver's  
	submorphs to the receiver's clipping bounds."
	
	extension ifNil: [^false].
	^ self
		valueOfProperty: #clipSubmorphs
		ifAbsent: [false]! !

!Morph methodsFor: 'drawing' stamp: 'ar 11/12/2000 18:47'!
clipSubmorphs: aBool
	"Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds."
	self invalidRect: self fullBounds.
	aBool == false
		ifTrue:[self removeProperty: #clipSubmorphs]
		ifFalse:[self setProperty: #clipSubmorphs toValue: aBool].
	self invalidRect: self fullBounds.! !

!Morph methodsFor: 'drawing' stamp: 'tk 8/2/1998 14:33'!
doesOwnRotation
	"Some morphs don't want to TransformMorph to rotate their images, but we do"
	^ false! !

!Morph methodsFor: 'drawing' stamp: 'panda 4/28/2000 11:59'!
drawDropHighlightOn: aCanvas
	self highlightedForDrop ifTrue: [
		aCanvas frameRectangle: self fullBounds color: self dropHighlightColor].! !

!Morph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:17'!
drawDropShadowOn: aCanvas

	aCanvas 
		translateBy: self shadowOffset 
		during: [ :shadowCanvas |
			shadowCanvas shadowColor: self shadowColor.
			shadowCanvas roundCornersOf: self during: [ 
				(shadowCanvas isVisible: self bounds) ifTrue:[shadowCanvas drawMorph: self ]]
		].
! !

!Morph methodsFor: 'drawing' stamp: 'ar 4/2/1999 13:13'!
drawErrorOn: aCanvas
	"The morph (or one of its submorphs) had an error in its drawing method."
	aCanvas
		frameAndFillRectangle: bounds
		fillColor: Color red
		borderWidth: 1
		borderColor: Color yellow.
	aCanvas line: bounds topLeft to: bounds bottomRight width: 1 color: Color yellow.
	aCanvas line: bounds topRight to: bounds bottomLeft width: 1 color: Color yellow.! !

!Morph methodsFor: 'drawing' stamp: '   9/3/2000 13:55'!
drawMouseDownHighlightOn: aCanvas
	self highlightedForMouseDown ifTrue: [
		aCanvas frameRectangle: self fullBounds color: self color darker darker].! !

!Morph methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:31'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle.
! !

!Morph methodsFor: 'drawing' stamp: 'wiz 3/21/2006 20:44'!
drawRolloverBorderOn: aCanvas 
	| colorToUse offsetToUse myShadow newForm f |
	colorToUse := self
				valueOfProperty: #rolloverColor
				ifAbsent: [Color blue alpha: 0.5].
	offsetToUse := self
				valueOfProperty: #rolloverWidth
				ifAbsent: [10 @ 10].
	self hasRolloverBorder: false.
	myShadow := self shadowForm.
	self hasRolloverBorder: true.
	myShadow offset: 0 @ 0.
	f := ColorForm extent: myShadow extent depth: 1.
	myShadow displayOn: f.
	f colors: {Color transparent. colorToUse}.
	newForm := Form extent: offsetToUse * 2 + myShadow extent depth: 32.
	(WarpBlt current toForm: newForm) sourceForm: f;
		 cellSize: 1;
		 combinationRule: 3;
		 copyQuad: f boundingBox innerCorners toRect: newForm boundingBox.
	aCanvas
		translateBy: offsetToUse negated
		during: [:shadowCanvas | 
			shadowCanvas shadowColor: colorToUse.
			shadowCanvas paintImage: newForm at: self position]! !

!Morph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 14:31'!
drawSubmorphsOn: aCanvas 
	"Display submorphs back to front"

	| drawBlock |
	submorphs isEmpty ifTrue: [^self].
	drawBlock := [:canvas | submorphs reverseDo: [:m | canvas fullDrawMorph: m]].
	self clipSubmorphs 
		ifTrue: [aCanvas clipBy: self clippingBounds during: drawBlock]
		ifFalse: [drawBlock value: aCanvas]! !

!Morph methodsFor: 'drawing' stamp: 'RAA 1/6/2001 22:12'!
expandFullBoundsForDropShadow: aRectangle
	"Return an expanded rectangle for an eventual drop shadow"
	| delta box |

	box _ aRectangle.
	delta _ self shadowOffset.
	box _ delta x >= 0 
		ifTrue:[box right: aRectangle right + delta x]
		ifFalse:[box left: aRectangle left + delta x].
	box _ delta y >= 0
		ifTrue:[box bottom: aRectangle bottom + delta y]
		ifFalse:[box top: aRectangle top + delta y].
	^box! !

!Morph methodsFor: 'drawing' stamp: 'ar 11/8/2000 19:29'!
expandFullBoundsForRolloverBorder: aRectangle
	| delta |
	delta _ self valueOfProperty: #rolloverWidth ifAbsent: [10@10].
	^aRectangle expandBy: delta.

! !

!Morph methodsFor: 'drawing' stamp: 'sw 11/26/2003 17:43'!
flashBounds
	"Flash the receiver's bounds  -- does not use the receiver's color, thus works with StringMorphs and SketchMorphs, etc., for which #flash is useless.  No senders initially, but useful to send this from a debugger or inspector"

	5 timesRepeat:
		[Display flash: self boundsInWorld  andWait: 120]! !

!Morph methodsFor: 'drawing' stamp: 'ar 12/30/2001 15:22'!
fullDrawOn: aCanvas
	"Draw the full Morphic structure on the given Canvas"

	self visible ifFalse: [^ self].
	(aCanvas isVisible: self fullBounds) ifFalse:[^self].
	(self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas].
	"Note: At some point we should generalize this into some sort of 
	multi-canvas so that we can cross-optimize some drawing operations."
	"Pass 1: Draw eventual drop-shadow"
	self hasDropShadow ifTrue: [self drawDropShadowOn: aCanvas].
	(self hasRolloverBorder and: [(aCanvas seesNothingOutside: self bounds) not])
		ifTrue: [self drawRolloverBorderOn: aCanvas].

	"Pass 2: Draw receiver itself"
	aCanvas roundCornersOf: self during:[
		(aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self].
		self drawSubmorphsOn: aCanvas.
		self drawDropHighlightOn: aCanvas.
		self drawMouseDownHighlightOn: aCanvas].! !

!Morph methodsFor: 'drawing' stamp: 'dgd 8/30/2003 20:20'!
hasClipSubmorphsString
	"Answer a string that represents the clip-submophs checkbox"
	^ (self clipSubmorphs
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'provide clipping' translated! !

!Morph methodsFor: 'drawing' stamp: 'sw 10/30/1998 18:27'!
hide
	owner ifNil: [^ self].
	self visible ifTrue: [self visible: false.  self changed]! !

!Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:48'!
highlightedForMouseDown
	^(self valueOfProperty: #highlightedForMouseDown) == true! !

!Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:51'!
highlightForMouseDown
	self highlightForMouseDown: true! !

!Morph methodsFor: 'drawing' stamp: 'ar 3/17/2001 15:56'!
highlightForMouseDown: aBoolean
	aBoolean 
		ifTrue:[self setProperty: #highlightedForMouseDown toValue: aBoolean]
		ifFalse:[self removeProperty: #highlightedForMouseDown. self resetExtension].
	self changed! !

!Morph methodsFor: 'drawing' stamp: 'jm 6/11/97 17:21'!
imageForm

	^ self imageFormForRectangle: self fullBounds
! !

!Morph methodsFor: 'drawing' stamp: 'di 7/8/1998 12:42'!
imageFormDepth: depth

	^ self imageForm: depth forRectangle: self fullBounds
! !

!Morph methodsFor: 'drawing' stamp: 'di 9/9/1998 22:25'!
imageFormForRectangle: rect

	^ self imageForm: Display depth forRectangle: rect
! !

!Morph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:23'!
imageFormWithout: stopMorph andStopThere: stopThere
	"Like imageForm, except it does not display stopMorph,
	and it will not display anything above it if stopThere is true.
	Returns a pair of the imageForm and a boolean that is true
		if it has hit stopMorph, and display should stop."
	| canvas rect |
	rect _ self fullBounds.
	canvas _ ColorPatchCanvas extent: rect extent depth: Display depth.
	canvas stopMorph: stopMorph.
	canvas doStop: stopThere.
	canvas translateBy: rect topLeft negated during:[:tempCanvas| tempCanvas fullDrawMorph: self].
	^ Array with: (canvas form offset: rect topLeft)
			with: canvas foundMorph! !

!Morph methodsFor: 'drawing' stamp: 'nk 9/1/2004 15:08'!
imageForm: depth backgroundColor: aColor forRectangle: rect
	| canvas |
	canvas _ Display defaultCanvasClass extent: rect extent depth: depth.
	canvas translateBy: rect topLeft negated
		during:[:tempCanvas| 
			tempCanvas fillRectangle: rect color: aColor.
			tempCanvas fullDrawMorph: self].
	^ canvas form offset: rect topLeft! !

!Morph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:23'!
imageForm: depth forRectangle: rect
	| canvas |
	canvas _ Display defaultCanvasClass extent: rect extent depth: depth.
	canvas translateBy: rect topLeft negated
		during:[:tempCanvas| tempCanvas fullDrawMorph: self].
	^ canvas form offset: rect topLeft! !

!Morph methodsFor: 'drawing' stamp: 'sw 10/10/1999 23:25'!
refreshWorld
	| aWorld |
	(aWorld _ self world) ifNotNil: [aWorld displayWorldSafely]
! !

!Morph methodsFor: 'drawing' stamp: 'JW 7/12/2005 20:12'!
shadowForm
	"Return a form representing the 'shadow' of the receiver - e.g., all pixels that are occupied by the receiver are one, all others are zero."
	| canvas |
	canvas := (Display defaultCanvasClass extent: self fullBounds extent depth: 1)
				asShadowDrawingCanvas: Color black. "Color black represents one for 1bpp"
	canvas translateBy: bounds topLeft negated
		during:[:tempCanvas| tempCanvas fullDrawMorph: self].
	^ canvas form offset: bounds topLeft
! !

!Morph methodsFor: 'drawing' stamp: 'sw 10/22/1998 20:29'!
show
	"Make sure this morph is on-stage."
	self visible ifFalse: [self visible: true.  self changed]! !

!Morph methodsFor: 'drawing' stamp: 'md 2/27/2006 08:49'!
visible
	"answer whether the receiver is visible"
	extension ifNil: [^ true].
	^ extension visible! !

!Morph methodsFor: 'drawing' stamp: 'md 2/27/2006 08:49'!
visible: aBoolean 
	"set the 'visible' attribute of the receiver to aBoolean"
	(extension isNil and:[aBoolean]) ifTrue: [^ self].
	self visible == aBoolean ifTrue: [^ self].
	self assureExtension visible: aBoolean.
	self changed! !


!Morph methodsFor: 'drop shadows' stamp: 'RAA 1/19/2001 07:51'!
addDropShadow

	self hasDropShadow ifTrue:[^self].
	self changed.
	self hasDropShadow: true.
	self shadowOffset: 3@3.
	self layoutChanged.
	self changed.! !

!Morph methodsFor: 'drop shadows' stamp: 'dgd 8/30/2003 16:48'!
addDropShadowMenuItems: aMenu hand: aHand
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu
		addUpdating: #hasDropShadowString
		action: #toggleDropShadow.
	menu addLine.
	menu add: 'shadow color...' translated target: self selector: #changeShadowColor.
	menu add: 'shadow offset...' translated target: self selector: #setShadowOffset:.
	aMenu add: 'drop shadow' translated subMenu: menu.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:22'!
changeShadowColor
	"Change the shadow color of the receiver -- triggered, e.g. from a menu"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #shadowColor:;
		originalColor: self shadowColor;
		putUpFor: self near: self fullBoundsInWorld! !

!Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:42'!
hasDropShadow
	"answer whether the receiver has DropShadow"
	^ self
		valueOfProperty: #hasDropShadow
		ifAbsent: [false]! !

!Morph methodsFor: 'drop shadows' stamp: 'dgd 8/30/2003 16:49'!
hasDropShadowString
	^ (self hasDropShadow
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'show shadow' translated! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 19:03'!
hasDropShadow: aBool
	aBool
		ifTrue:[self setProperty: #hasDropShadow toValue: true]
		ifFalse:[self removeProperty: #hasDropShadow]! !

!Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:58'!
hasRolloverBorder
	"answer whether the receiver has RolloverBorder"
	^ self
		valueOfProperty: #hasRolloverBorder
		ifAbsent: [false]! !

!Morph methodsFor: 'drop shadows' stamp: 'RAA 11/7/2000 15:54'!
hasRolloverBorder: aBool
	aBool
		ifTrue:[self setProperty: #hasRolloverBorder toValue: true]
		ifFalse:[self removeProperty: #hasRolloverBorder]! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 18:57'!
removeDropShadow
	self hasDropShadow ifFalse:[^self].
	self changed.
	self hasDropShadow: false.
	fullBounds ifNotNil:[fullBounds _ self privateFullBounds].
	self changed.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:58'!
setShadowOffset: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | self shadowPoint: newPoint].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:59'!
shadowColor
	^self valueOfProperty: #shadowColor ifAbsent:[Color black]! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:22'!
shadowColor: aColor
	self shadowColor = aColor ifFalse:[self changed].
	self setProperty: #shadowColor toValue: aColor.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:57'!
shadowOffset
	"Return the current shadow offset"
	^self valueOfProperty: #shadowOffset ifAbsent:[0@0]! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 19:00'!
shadowOffset: aPoint
	"Set the current shadow offset"
	(aPoint isNil or:[(aPoint x isZero) & (aPoint y isZero)])
		ifTrue:[self removeProperty: #shadowOffset]
		ifFalse:[self setProperty: #shadowOffset toValue: aPoint].! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 18:58'!
shadowPoint: newPoint
	self changed.
	self shadowOffset: newPoint - self center // 5.
	fullBounds ifNotNil:[fullBounds _ self privateFullBounds].
	self changed.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:16'!
toggleDropShadow
	self hasDropShadow
		ifTrue:[self removeDropShadow]
		ifFalse:[self addDropShadow].! !


!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 20:00'!
aboutToBeGrabbedBy: aHand
	"The receiver is being grabbed by a hand.
	Perform necessary adjustments (if any) and return the actual morph
	that should be added to the hand."
	| extentToHandToHand cmd |
	self formerOwner: owner.
	self formerPosition: self position.
	cmd _ self undoGrabCommand.
	cmd ifNotNil:[self setProperty: #undoGrabCommand toValue: cmd].
	(extentToHandToHand _ self valueOfProperty: #expandedExtent)
			ifNotNil:
				[self removeProperty: #expandedExtent.
				self extent: extentToHandToHand].
	^self "Grab me"! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'!
disableDragNDrop
	self enableDragNDrop: false! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'!
dragEnabled
	"Get this morph's ability to add and remove morphs via drag-n-drop."
	^(self valueOfProperty: #dragEnabled) == true
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'!
dragEnabled: aBool
	^self enableDrag: aBool! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:20'!
dragNDropEnabled
	"Note: This method is only useful for dragEnabled == dropEnabled at all times"
	self separateDragAndDrop.
	^self dragEnabled and:[self dropEnabled]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:36'!
dragSelectionColor
	^ Color magenta! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'!
dropEnabled
	"Get this morph's ability to add and remove morphs via drag-n-drop."
	^(self valueOfProperty: #dropEnabled) == true
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'!
dropEnabled: aBool
	^self enableDrop: aBool! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:52'!
dropHighlightColor
	^ Color blue! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:08'!
dropSuccessColor
	^ Color blue! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'!
enableDragNDrop
	self enableDragNDrop: true! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:21'!
enableDragNDrop: aBoolean
	"Set both properties at once"
	self separateDragAndDrop.
	self enableDrag: aBoolean.
	self enableDrop: aBoolean.! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'!
enableDrag: aBoolean
	self setProperty: #dragEnabled toValue: aBoolean! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'!
enableDrop: aBoolean
	self setProperty: #dropEnabled toValue: aBoolean! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'!
formerOwner
	^self valueOfProperty: #formerOwner! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:31'!
formerOwner: aMorphOrNil 
	aMorphOrNil isNil 
		ifTrue: [self removeProperty: #formerOwner]
		ifFalse: [self setProperty: #formerOwner toValue: aMorphOrNil]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'!
formerPosition
	^self valueOfProperty: #formerPosition! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:31'!
formerPosition: formerPosition 
	formerPosition isNil 
		ifTrue: [self removeProperty: #formerPosition]
		ifFalse: [self setProperty: #formerPosition toValue: formerPosition]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/6/2000 15:13'!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:53'!
highlightedForDrop
	^(self valueOfProperty: #highlightedForDrop) == true! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 11:51'!
highlightForDrop
	self highlightForDrop: true! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:01'!
highlightForDrop: aBoolean
	self setProperty: #highlightedForDrop toValue: aBoolean.
	self changed! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 9/10/2004 13:42'!
justDroppedInto: aMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"

	| aWindow partsBinCase cmd aStack |
	(self formerOwner notNil and: [self formerOwner ~~ aMorph])
		ifTrue: [self removeHalo].
	self formerOwner: nil.
	self formerPosition: nil.
	cmd _ self valueOfProperty: #undoGrabCommand.
	cmd ifNotNil:[aMorph rememberCommand: cmd.
				self removeProperty: #undoGrabCommand].
	(partsBinCase _ aMorph isPartsBin) ifFalse:
		[self isPartsDonor: false].
	(aWindow _ aMorph ownerThatIsA: SystemWindow) ifNotNil:
		[aWindow isActive ifFalse:
			[aWindow activate]].
	(self isInWorld and: [partsBinCase not]) ifTrue:
		[self world startSteppingSubmorphsOf: self].
	"Note an unhappy inefficiency here:  the startStepping... call will often have already been called in the sequence leading up to entry to this method, but unfortunately the isPartsDonor: call often will not have already happened, with the result that the startStepping... call will not have resulted in the startage of the steppage."

	"An object launched by certain parts-launcher mechanisms should end up fully visible..."
	(self hasProperty: #beFullyVisibleAfterDrop) ifTrue:
		[aMorph == ActiveWorld ifTrue:
			[self goHome].
		self removeProperty: #beFullyVisibleAfterDrop].

	(self holdsSeparateDataForEachInstance and: [(aStack _ self stack) notNil])
		ifTrue:
			[aStack reassessBackgroundShape]
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 2/6/2001 22:12'!
justGrabbedFrom: formerOwner
	"The receiver was just grabbed from its former owner and is now attached to the hand. By default, we pass this message on if we're a renderer."
	(self isRenderer and:[self hasSubmorphs]) 
		ifTrue:[self firstSubmorph justGrabbedFrom: formerOwner].! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 3/27/2001 11:52'!
nameForUndoWording
	"Return wording appropriate to the receiver for use in an undo-related menu item (and perhaps elsewhere)"

	| aName |
	aName _ self knownName ifNil: [self renderedMorph class name].
	^ aName truncateTo: 24! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'di 12/12/2000 14:35'!
rejectDropMorphEvent: evt
	"The receiver has been rejected, and must be put back somewhere.  There are three cases:
	(1)  It remembers its former owner and position, and goes right back there
	(2)  It remembers its former position only, in which case it was torn off from a parts bin, and the UI is that it floats back to its donor position and then vanishes.
	(3)  Neither former owner nor position is remembered, in which case it is whisked to the Trash"

	self removeProperty: #undoGrabCommand.
	(self formerOwner notNil and: [self formerOwner isPartsBin not]) ifTrue:
		[^ self slideBackToFormerSituation: evt].

	self formerPosition ifNotNil:  "Position but no owner -- can just make it vanish"
		[^ self vanishAfterSlidingTo: self formerPosition event: evt].
		
	self slideToTrash: evt! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 1/11/1999 20:07'!
repelsMorph: aMorph event: ev
	^ false! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:02'!
resetHighlightForDrop
	self highlightForDrop: false! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:24'!
separateDragAndDrop
	"Conversion only. Separate the old #dragNDropEnabled into #dragEnabled and #dropEnabled and remove the old property."
	| dnd |
	(self hasProperty: #dragNDropEnabled) ifFalse:[^self].
	dnd _ (self valueOfProperty: #dragNDropEnabled) == true.
	self dragEnabled: dnd.
	self dropEnabled: dnd.
	self removeProperty: #dragNDropEnabled.
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 8/12/2003 23:35'!
slideBackToFormerSituation: evt 
	| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
	formerOwner := self formerOwner.
	formerPosition := self formerPosition.
	aWorld := evt hand world.
	trans := formerOwner transformFromWorld.
	slideForm := trans isPureTranslation 
				ifTrue: [self imageForm offset: 0 @ 0]
				ifFalse: 
					[((TransformationMorph new asFlexOf: self) transform: trans) imageForm 
						offset: 0 @ 0]. 
	startPoint := evt hand fullBounds origin.
	endPoint := trans localPointToGlobal: formerPosition.
	owner removeMorph: self.
	aWorld displayWorld.
	slideForm 
		slideFrom: startPoint
		to: endPoint
		nSteps: 12
		delay: 15.
	formerOwner addMorph: self.
	self position: formerPosition.
	self justDroppedInto: formerOwner event: evt! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 4/3/2006 14:12'!
slideToTrash: evt
	"Perhaps slide the receiver across the screen to a trash can and make it disappear into it.  In any case, remove the receiver from the screen."

	| aForm trash startPoint endPoint morphToSlide |
	((self renderedMorph == Utilities scrapsBook) or: [self renderedMorph isKindOf: TrashCanMorph]) ifTrue:
		[self dismissMorph.  ^ self].
	Preferences slideDismissalsToTrash ifTrue:
		[morphToSlide _ self representativeNoTallerThan: 200 norWiderThan: 200 thumbnailHeight: 100.
		aForm _ morphToSlide imageForm offset: (0@0).
		trash _ ActiveWorld
			findDeepSubmorphThat:
				[:aMorph | (aMorph isKindOf: TrashCanMorph) and:
					[aMorph topRendererOrSelf owner == ActiveWorld]]
			ifAbsent:
				[trash _ TrashCanMorph new.
				trash bottomLeft: ActiveWorld bottomLeft - (-10@10).
				trash openInWorld.
				trash].
		endPoint _ trash fullBoundsInWorld center.
		startPoint _ self topRendererOrSelf fullBoundsInWorld center - (aForm extent // 2)].
	self dismissMorph.
	ActiveWorld displayWorld.
	Preferences slideDismissalsToTrash ifTrue:
		[aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15].
	Utilities addToTrash: self! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'mir 1/4/2001 11:02'!
startDrag: anItem with: anObject
	self currentHand attachMorph: anObject! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:46'!
toggleDragNDrop
	"Toggle this morph's ability to add and remove morphs via drag-n-drop."

		self enableDragNDrop: self dragNDropEnabled not.
! !

!Morph methodsFor: 'dropping/grabbing'!
transportedMorph
	^self! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 8/26/2003 21:44'!
undoGrabCommand
	"Return an undo command for grabbing the receiver"

	| cmd |
	owner ifNil:
		[^ nil]. "no owner - no undo"
	^ (cmd _ Command new)
		cmdWording: 'move ' translated, self nameForUndoWording;
		undoTarget: self
		selector: #undoMove:redo:owner:bounds:predecessor:
		arguments: {cmd. false. owner. self bounds. (owner morphPreceding: self)};
		yourself! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'bf 1/5/2000 19:11'!
vanishAfterSlidingTo: aPosition event: evt

	| aForm aWorld startPoint endPoint |
	aForm _ self imageForm offset: 0@0.
	aWorld _ self world.
	startPoint _ evt hand fullBounds origin.
	self delete.
	aWorld displayWorld.
	endPoint _ aPosition.
	aForm slideFrom: startPoint  to: endPoint nSteps: 12 delay: 15.
	Preferences soundsEnabled ifTrue: [TrashCanMorph playDeleteSound].
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:24'!
wantsDroppedMorph: aMorph event: evt
	"Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. Note that for a successful drop operation both parties need to agree. The symmetric check is done automatically via aMorph wantsToBeDroppedInto: self."

	^self dropEnabled! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 9/18/2000 18:34'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph. This check is symmetric to #wantsDroppedMorph:event: to give both parties a chance of figuring out whether they like each other."
	^true! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 2/10/1999 05:44'!
wantsToBeOpenedInWorld
	"Return true if the receiver wants to be put into the World directly,
	rather than allowing the user to place it (e.g., prevent attaching me
	to the hand after choosing 'new morph' in the world menu)"
	^false! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 8/15/2000 16:58'!
willingToBeDiscarded
	^ true! !


!Morph methodsFor: 'event handling' stamp: 'tk 9/6/2000 12:42'!
click
	"Pretend the user clicked on me."

	(self handlesMouseDown: nil) ifTrue: [
		self mouseDown: nil.
		self mouseUp: nil].! !

!Morph methodsFor: 'event handling' stamp: 'LC 5/18/2000 09:54'!
click: evt
	"Handle a single-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing.
	LC 2/14/2000 08:32 - added: EventHandler notification"

	self eventHandler ifNotNil:
		[self eventHandler click: evt fromMorph: self].! !

!Morph methodsFor: 'event handling' stamp: 'sw 3/8/1999 00:17'!
cursorPoint
	^ self currentHand lastEvent cursorPoint! !

!Morph methodsFor: 'event handling' stamp: 'jcg 10/2/2001 09:26'!
doubleClickTimeout: evt
	"Handle a double-click timeout event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing."

	self eventHandler ifNotNil:
		[self eventHandler doubleClickTimeout: evt fromMorph: self].! !

!Morph methodsFor: 'event handling' stamp: 'LC 5/18/2000 09:54'!
doubleClick: evt
	"Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing.
	LC 2/14/2000 08:32 - added: EventHandler notification"

	self eventHandler ifNotNil:
		[self eventHandler doubleClick: evt fromMorph: self].! !

!Morph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:28'!
dropFiles: anEvent
	"Handle a number of files dropped from the OS"
! !

!Morph methodsFor: 'event handling' stamp: 'RAA 2/12/2001 15:26'!
firstClickTimedOut: evt
	"Useful for double-click candidates who want to know whether or not the click is a single or double. In this case, ignore the #click: and wait for either this or #doubleClick:"

! !

!Morph methodsFor: 'event handling' stamp: 'nk 3/10/2004 19:48'!
handlerForYellowButtonDown: anEvent 
	"Return the (prospective) handler for a mouse down event with the yellow button pressed.
	The 	handler is temporarily installed and can be used for morphs further 
	down the hierarchy to negotiate whether the inner or the outer 
	morph should finally handle the event."

	(self hasYellowButtonMenu or: [ self handlesMouseDown: anEvent ])
		ifFalse: [ ^ nil].	"Not interested."

	anEvent handler
		ifNil: [^ self].	"Nobody else was interested"

	"Same priority but I am innermost."
	^ self mouseDownPriority >= anEvent handler mouseDownPriority
		ifFalse: [nil ]
		ifTrue: [self]! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/28/2000 22:18'!
handlesKeyboard: evt
	"Return true if the receiver wishes to handle the given keyboard event"
	self eventHandler ifNotNil: [^ self eventHandler handlesKeyboard: evt].
	^ false
! !

!Morph methodsFor: 'event handling' stamp: 'nk 2/14/2004 18:42'!
handlesMouseDown: evt
	"Do I want to receive mouseDown events (mouseDown:, mouseMove:, mouseUp:)?"
	"NOTE: The default response is false, except if you have added sensitivity to mouseDown events using the on:send:to: mechanism.  Subclasses that implement these messages directly should override this one to return true." 

	self eventHandler ifNotNil: [^ self eventHandler handlesMouseDown: evt].
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:31'!
handlesMouseOverDragging: evt
	"Return true if I want to receive mouseEnterDragging: and mouseLeaveDragging: when the hand drags something over me (button up or button down), or when the mouse button is down but there is no mouseDown recipient.  The default response is false, except if you have added sensitivity to mouseEnterLaden: or mouseLeaveLaden:, using the on:send:to: mechanism."
	"NOTE:  If the hand state matters in these cases, it may be tested by constructs such as
		event anyButtonPressed
		event hand hasSubmorphs"

	self eventHandler ifNotNil: [^ self eventHandler handlesMouseOverDragging: evt].
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:31'!
handlesMouseOver: evt
	"Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty?  The default response is false, except if you have added sensitivity to mouseEnter: or mouseLeave:, using the on:send:to: mechanism." 

	self eventHandler ifNotNil: [^ self eventHandler handlesMouseOver: evt].
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:06'!
handlesMouseStillDown: evt
	"Return true if the receiver wants to get repeated #mouseStillDown: messages between #mouseDown: and #mouseUp"
	self eventHandler ifNotNil: [^ self eventHandler handlesMouseStillDown: evt].
	^ false
! !

!Morph methodsFor: 'event handling' stamp: 'sw 4/2/98 14:16'!
hasFocus
	^ false! !

!Morph methodsFor: 'event handling'!
keyboardFocusChange: aBoolean
	"The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing."! !

!Morph methodsFor: 'event handling' stamp: 'ar 9/14/2000 18:23'!
keyDown: anEvent
	"Handle a key down event. The default response is to do nothing."! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:05'!
keyStroke: anEvent
	"Handle a keystroke event.  The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler keyStroke: anEvent fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'KTT 6/1/2004 11:41'!
keyUp: anEvent
	"Handle a key up event. The default response is to do nothing."! !

!Morph methodsFor: 'event handling' stamp: 'dgd 9/19/2004 13:14'!
mouseDown: evt 
	"Handle a mouse down event. The default response is to let my 
	eventHandler, if any, handle it."
	evt yellowButtonPressed
		ifTrue: ["First check for option (menu) click"
			^ self yellowButtonActivity: evt shiftPressed].
	self eventHandler
		ifNotNil: [self eventHandler mouseDown: evt fromMorph: self]
! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:33'!
mouseEnterDragging: evt
	"Handle a mouseEnterDragging event, meaning the mouse just entered my bounds with a button pressed or laden with submorphs.  The default response is to let my eventHandler, if any, handle it, or else to do nothing."

	self eventHandler ifNotNil:
		[^ self eventHandler mouseEnterDragging: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:00'!
mouseEnter: evt
	"Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseEnter: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:38'!
mouseLeaveDragging: evt
	"Handle a mouseLeaveLaden event, meaning the mouse just left my bounds with a button pressed or laden with submorphs. The default response is to let my eventHandler, if any, handle it; else to do nothing."

	self eventHandler ifNotNil:
		[self eventHandler mouseLeaveDragging: evt fromMorph: self]! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:01'!
mouseLeave: evt
	"Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseLeave: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:04'!
mouseMove: evt
	"Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."
	self eventHandler ifNotNil:
		[self eventHandler mouseMove: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:02'!
mouseStillDownThreshold
	"Return the number of milliseconds after which mouseStillDown: should be sent"
	^200! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:08'!
mouseStillDown: evt
	"Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseStillDown: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:05'!
mouseUp: evt
	"Handle a mouse up event. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseUp: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 18:20'!
moveOrResizeFromKeystroke: anEvent 
	"move or resize the receiver based on a keystroke"
	| dir | 

	anEvent keyValue = 28 ifTrue: [dir := -1 @ 0].
	anEvent keyValue = 29 ifTrue: [dir := 1 @ 0].
	anEvent keyValue = 30 ifTrue: [dir := 0 @ -1].
	anEvent keyValue = 31 ifTrue: [dir := 0 @ 1].

	dir notNil
		ifTrue:[
			anEvent controlKeyPressed ifTrue: [dir := dir * 10].

			anEvent shiftPressed
				ifTrue: [self extent: self extent + dir]
				ifFalse: [self position: self position + dir].

			"anEvent wasHandled: true."
	]
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:01'!
on: eventName send: selector to: recipient
	self eventHandler ifNil: [self eventHandler: EventHandler new].
	self eventHandler on: eventName send: selector to: recipient! !

!Morph methodsFor: 'event handling' stamp: 'ar 3/18/2001 17:21'!
on: eventName send: selector to: recipient withValue: value
	"NOTE: selector must take 3 arguments, of which value will be the *** FIRST ***"

	self eventHandler ifNil: [self eventHandler: EventHandler new].
	self eventHandler on: eventName send: selector to: recipient withValue: value
! !

!Morph methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:43'!
preferredKeyboardBounds

	^ self bounds: self bounds in: World.
! !

!Morph methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:42'!
preferredKeyboardPosition

	^ (self bounds: self bounds in: World) topLeft.
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:02'!
removeLink: actionCode
	self eventHandler ifNotNil:
		[self eventHandler on: actionCode send: nil to: nil]! !

!Morph methodsFor: 'event handling' stamp: 'sw 11/16/1998 08:06'!
restoreSuspendedEventHandler
	| savedHandler |
	(savedHandler _ self valueOfProperty: #suspendedEventHandler) ifNotNil:
		[self eventHandler: savedHandler].
	submorphs do: [:m | m restoreSuspendedEventHandler]
! !

!Morph methodsFor: 'event handling' stamp: 'mir 5/23/2000 17:43'!
startDrag: evt
	"Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing."

	self eventHandler ifNotNil:
		[self eventHandler startDrag: evt fromMorph: self].! !

!Morph methodsFor: 'event handling' stamp: 'sw 11/16/1998 08:07'!
suspendEventHandler
	self eventHandler ifNotNil:
		[self setProperty: #suspendedEventHandler toValue: self eventHandler.
		self eventHandler: nil].
	submorphs do: [:m | m suspendEventHandler].  "All those rectangles"! !

!Morph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 18:42'!
tabAmongFields
	^ Preferences tabAmongFields
		or: [self hasProperty: #tabAmongFields] ! !

!Morph methodsFor: 'event handling' stamp: 'RAA 6/19/2000 07:13'!
transformFromOutermostWorld
	"Return a transform to map world coordinates into my local coordinates"

	"self isWorldMorph ifTrue: [^ MorphicTransform identity]."
	^ self transformFrom: self outermostWorldMorph! !

!Morph methodsFor: 'event handling'!
transformFromWorld
	"Return a transform to map world coordinates into my local coordinates"

	^ self transformFrom: nil! !

!Morph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 14:36'!
transformFrom: uberMorph 
	"Return a transform to be used to map coordinates in a morph above me into my childrens coordinates, or vice-versa. This is used to support scrolling, scaling, and/or rotation. This default implementation just returns my owner's transform or the identity transform if my owner is nil. 
	Note:  This method cannot be used to map into the receiver's coordinate system!!"

	(self == uberMorph or: [owner isNil]) ifTrue: [^IdentityTransform new].
	^owner transformFrom: uberMorph! !

!Morph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:28'!
wantsDropFiles: anEvent
	"Return true if the receiver wants files dropped from the OS."
	^false! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/2000 11:46'!
wantsEveryMouseMove
	"Unless overridden, this method allows processing to skip mouse move events
	when processing is lagging.  No 'significant' event (down/up, etc) will be skipped."

	^ false! !

!Morph methodsFor: 'event handling' stamp: 'sw 11/3/97 02:11'!
wantsKeyboardFocusFor: aSubmorph
	"Answer whether a plain mouse click on aSubmorph, a text-edit-capable thing, should result in a text selection there"
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'sw 5/6/1998 12:54'!
wouldAcceptKeyboardFocus
	"Answer whether a plain mouse click on the receiver should result in a text selection there"
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'sw 8/29/2000 14:57'!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver is in the running as the new keyboard focus if the tab key were hit at a meta level.  This provides the leverage for tabbing among fields of a card, for example."

	^ false! !

!Morph methodsFor: 'event handling' stamp: 'dgd 7/28/2005 13:02'!
yellowButtonActivity: shiftState 
	"Find me or my outermost owner that has items to add to a  
	yellow button menu.  
	shiftState is true if the shift was pressed.  
	Otherwise, build a menu that contains the contributions from  
	myself and my interested submorphs,  
	and present it to the user."
	| menu |
	self isWorldMorph
		ifFalse: [| outerOwner | 
			outerOwner := self outermostOwnerWithYellowButtonMenu.
			outerOwner
				ifNil: [^ self].
			outerOwner == self
				ifFalse: [^ outerOwner yellowButtonActivity: shiftState]].
	menu := self buildYellowButtonMenu: ActiveHand.
	menu
		addTitle: self externalName
		icon: (self iconOrThumbnailOfSize: (Preferences tinyDisplay ifTrue: [16] ifFalse: [28])).
	menu popUpInWorld: self currentWorld! !


!Morph methodsFor: 'events-accessing' stamp: 'rw 4/25/2002 07:18'!
actionMap
	"Answer an action map"

	| actionMap |
	actionMap := self valueOfProperty: #actionMap.
	actionMap ifNil:
		[actionMap _ self createActionMap].
	^ actionMap! !

!Morph methodsFor: 'events-accessing' stamp: 'rw 4/25/2002 07:17'!
updateableActionMap
	"Answer an updateable action map, saving it in my #actionMap property"
	
	| actionMap |
	actionMap := self valueOfProperty: #actionMap.
	actionMap ifNil:
		[actionMap _ self createActionMap.
		self setProperty: #actionMap toValue: actionMap].
	^ actionMap! !


!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector after: delayTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: #() after: delayTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector at: scheduledTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: #() at: scheduledTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector withArguments: args after: delayTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: args at: Time millisecondClockValue + delayTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:15'!
addAlarm: aSelector withArguments: args at: scheduledTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	| scheduler |
	scheduler _ self alarmScheduler.
	scheduler ifNotNil:[scheduler addAlarm: aSelector withArguments: args for: self at: scheduledTime].! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector with: arg1 after: delayTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: (Array with: arg1) after: delayTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector with: arg1 at: scheduledTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: (Array with: arg1) at: scheduledTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector with: arg1 with: arg2 after: delayTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) after: delayTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector with: arg1 with: arg2 at: scheduledTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) at: scheduledTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:34'!
alarmScheduler
	"Return the scheduler being responsible for triggering alarms"
	^self world! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:14'!
removeAlarm: aSelector
	"Remove the given alarm"
	| scheduler |
	scheduler _ self alarmScheduler.
	scheduler ifNotNil:[scheduler removeAlarm: aSelector for: self].! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:15'!
removeAlarm: aSelector at: scheduledTime
	"Remove the given alarm"
	| scheduler |
	scheduler _ self alarmScheduler.
	scheduler ifNotNil:[scheduler removeAlarm: aSelector at: scheduledTime for: self].! !


!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 17:58'!
containsPoint: aPoint event: anEvent
	"Return true if aPoint is considered to be inside the receiver for the given event.
	The default implementation treats locked children as integral part of their owners."
	(self fullBounds containsPoint: aPoint) ifFalse:[^false].
	(self containsPoint: aPoint) ifTrue:[^true].
	self submorphsDo:[:m|
		(m isLocked and:[m fullContainsPoint: 
			((m transformedFrom: self) globalPointToLocal: aPoint)]) ifTrue:[^true]].
	^false! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 14:51'!
defaultEventDispatcher
	"Return the default event dispatcher to use with events that are directly sent to the receiver"
	^MorphicEventDispatcher new! !

!Morph methodsFor: 'events-processing' stamp: 'ar 1/10/2001 21:35'!
handleDropFiles: anEvent
	"Handle a drop from the OS."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(self wantsDropFiles: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	self dropFiles: anEvent.
! !

!Morph methodsFor: 'events-processing' stamp: 'di 12/12/2000 14:39'!
handleDropMorph: anEvent
	"Handle a dropping morph."
	| aMorph localPt |
	aMorph _ anEvent contents.
	"Do a symmetric check if both morphs like each other"
	((self wantsDroppedMorph: aMorph event: anEvent)	"I want her"
		and: [aMorph wantsToBeDroppedInto: self])		"she wants me"
		ifFalse: [aMorph removeProperty: #undoGrabCommand.
				^ self].
	anEvent wasHandled: true.
	"Transform the morph into the receiver's coordinate frame. This is currently incomplete since it only takes the offset into account where it really should take the entire transform."
	localPt _ (self transformedFrom: anEvent hand world) "full transform down"
				globalPointToLocal: aMorph referencePosition.
	aMorph referencePosition: localPt.
	self acceptDroppingMorph: aMorph event: anEvent.
	aMorph justDroppedInto: self event: anEvent.
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 21:13'!
handleEvent: anEvent
	"Handle the given event"
	^anEvent sentTo: self.! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/4/2000 18:48'!
handleFocusEvent: anEvent
	"Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand."
	^self handleEvent: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 23:01'!
handleKeyDown: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	^self keyDown: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 23:01'!
handleKeyUp: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	^self keyUp: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'md 8/2/2006 18:57'!
handleKeystroke: anEvent 
	"System level event handling."
	
	anEvent wasHandled
		ifTrue: [^ self].
	(self handlesKeyboard: anEvent)
		ifFalse: [^ self].
	anEvent wasHandled: true.
	^ self keyStroke: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/16/2000 14:22'!
handleListenEvent: anEvent
	"Handle the given event. This message is sent if the receiver is a registered listener for the given event."
	^anEvent sentTo: self.! !

!Morph methodsFor: 'events-processing' stamp: 'dgd 9/10/2004 13:36'!
handleMouseDown: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand removePendingBalloonFor: self.
	anEvent hand removePendingHaloFor: self.
	anEvent wasHandled: true.

	(anEvent controlKeyPressed
			and: [Preferences cmdGesturesEnabled])
		ifTrue: [^ self invokeMetaMenu: anEvent].

	"Make me modal during mouse transitions"
	anEvent hand newMouseFocus: self event: anEvent.
	anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent].
	
	"this mouse down could be the start of a gesture, or the end of a gesture focus"
	(self isGestureStart: anEvent)
		ifTrue: [^ self gestureStart: anEvent].

	self mouseDown: anEvent.

	Preferences maintainHalos
		ifFalse:[ anEvent hand removeHaloFromClick: anEvent on: self ].

	(self handlesMouseStillDown: anEvent) ifTrue:[
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue + self mouseStillDownThreshold
			arguments: {anEvent copy resetHandlerFields}
			stepTime: self mouseStillDownStepRate ].
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 8/8/2001 15:29'!
handleMouseEnter: anEvent
	"System level event handling."
	(anEvent isDraggingEvent) ifTrue:[
		(self handlesMouseOverDragging: anEvent) ifTrue:[
			anEvent wasHandled: true.
			self mouseEnterDragging: anEvent].
		^self].
	self wantsHalo "If receiver wants halo and balloon, trigger balloon after halo"
		ifTrue:[anEvent hand triggerHaloFor: self after: self haloDelayTime]
		ifFalse:[self wantsBalloon
			ifTrue:[anEvent hand triggerBalloonFor: self after: self balloonHelpDelayTime]].
	(self handlesMouseOver: anEvent) ifTrue:[
		anEvent wasHandled: true.
		self mouseEnter: anEvent.
	].! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/6/2000 00:15'!
handleMouseLeave: anEvent
	"System level event handling."
	anEvent hand removePendingBalloonFor: self.
	anEvent hand removePendingHaloFor: self.
	anEvent isDraggingEvent ifTrue:[
		(self handlesMouseOverDragging: anEvent) ifTrue:[
			anEvent wasHandled: true.
			self mouseLeaveDragging: anEvent].
		^self].
	(self handlesMouseOver: anEvent) ifTrue:[
		anEvent wasHandled: true.
		self mouseLeave: anEvent.
	].
! !

!Morph methodsFor: 'events-processing' stamp: 'nk 6/13/2004 09:16'!
handleMouseMove: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	"Rules say that by default a morph gets #mouseMove iff
		* the hand is not dragging anything,
			+ and some button is down,
			+ and the receiver is the current mouse focus."
	(anEvent hand hasSubmorphs) ifTrue:[^self].
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
	anEvent wasHandled: true.
	self mouseMove: anEvent.
	(self handlesMouseStillDown: anEvent) ifTrue:[
		"Step at the new location"
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue
			arguments: {anEvent copy resetHandlerFields}
			stepTime: self mouseStillDownStepRate ].
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 4/23/2001 17:24'!
handleMouseOver: anEvent
	"System level event handling."
	anEvent hand mouseFocus == self ifTrue:[
		"Got this directly through #handleFocusEvent: so check explicitly"
		(self containsPoint: anEvent position event: anEvent) ifFalse:[^self]].
	anEvent hand noticeMouseOver: self event: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/22/2000 17:11'!
handleMouseStillDown: anEvent
	"Called from the stepping mechanism for morphs wanting continuously repeated 'yes the mouse is still down, yes it is still down, yes it has not changed yet, no the mouse is still not up, yes the button is down' etc messages"
	(anEvent hand mouseFocus == self) 
		ifFalse:[^self stopSteppingSelector: #handleMouseStillDown:].
	self mouseStillDown: anEvent.
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/22/2000 17:09'!
handleMouseUp: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand mouseFocus == self ifFalse:[^self]. "Not interested in other parties"
	anEvent hand releaseMouseFocus: self.
	anEvent wasHandled: true.
	anEvent blueButtonChanged
		ifTrue:[self blueButtonUp: anEvent]
		ifFalse:[self mouseUp: anEvent.
				self stopSteppingSelector: #handleMouseStillDown:].! !

!Morph methodsFor: 'events-processing' stamp: 'md 10/22/2003 15:55'!
handleUnknownEvent: anEvent
	"An event of an unknown type was sent to the receiver. What shall we do?!!"
	Beeper beep. 
	anEvent printString displayAt: 0@0.
	anEvent wasHandled: true.! !

!Morph methodsFor: 'events-processing' stamp: 'sw 10/5/2002 01:47'!
mouseDownPriority
	"Return the default mouse down priority for the receiver"

	^ (self isPartsDonor or: [self isPartsBin])
		ifTrue:	[50]
		ifFalse:	[0]

	"The above is a workaround for the complete confusion between parts donors and parts bins. Morphs residing in a parts bin may or may not have the parts donor property set; if they have they may or may not actually handle events. To work around this, parts bins get an equal priority to parts donors so that when a morph in the parts bin does have the property set but does not handle the event we still get a copy from picking it up through the parts bin. Argh. This just *cries* for a cleanup."
	"And the above comment is Andreas's from 10/2000, which was formerly retrievable by a #flag: call which however caused a problem when trying to recompile the method from decompiled source."! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 17:14'!
processEvent: anEvent
	"Process the given event using the default event dispatcher."
	^self processEvent: anEvent using: self defaultEventDispatcher! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/18/2000 19:14'!
processEvent: anEvent using: defaultDispatcher
	"This is the central entry for dispatching events in morphic. Given some event and a default dispatch strategy, find the right receiver and let him handle it.
	WARNING: This is a powerful hook. If you want to use a different event dispatcher from the default, here is the place to hook it in. Depending on how the dispatcher is written (e.g., whether it calls simply #processEvent: or #processEvent:using:) you can change the dispatch strategy for entire trees of morphs. Similarly, you can disable entire trees of morphs from receiving any events whatsoever. Read the documentation in class MorphicEventDispatcher before playing with it. "
	(self rejectsEvent: anEvent) ifTrue:[^#rejected].
	^defaultDispatcher dispatchEvent: anEvent with: self! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/5/2000 19:25'!
rejectDropEvent: anEvent
	"This hook allows the receiver to repel a drop operation currently executed. The method is called prior to checking children so the receiver must validate that the event was really designated for it.
	Note that the ordering of the tests below is designed to avoid a (possibly expensive) #fullContainsPoint: test. If the receiver doesn't want to repel the morph anyways we don't need to check after all."
	(self repelsMorph: anEvent contents event: anEvent) ifFalse:[^self]. "not repelled"
	(self fullContainsPoint: anEvent position) ifFalse:[^self]. "not for me"
	"Throw it away"
	anEvent wasHandled: true.
	anEvent contents rejectDropMorphEvent: anEvent.! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/12/2000 23:40'!
rejectsEvent: anEvent
	"Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it."
	^self isLocked or:[self visible not]! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 21:09'!
transformedFrom: uberMorph
	"Return a transform to map coordinates of uberMorph, a morph above me in my owner chain, into the coordinates of MYSELF not any of my children."
	self flag: #arNote. "rename this method"
	owner ifNil:[^IdentityTransform new].
	^ (owner transformFrom: uberMorph)! !


!Morph methodsFor: 'events-removing' stamp: 'rw 4/25/2002 07:18'!
releaseActionMap
	"Release the action map"
	
 	self removeProperty: #actionMap! !


!Morph methodsFor: 'fileIn/out' stamp: 'di 11/18/1999 08:35'!
attachToResource
	"Produce a morph from a file -- either a saved .morph file or a graphics file"

	| pathName |
	pathName _ Utilities chooseFileWithSuffixFromList: (#('.morph'), Utilities graphicsFileSuffixes)
			withCaption: 'Choose a file
to load'.
	pathName ifNil: [^ self].  "User made no choice"
	pathName == #none ifTrue: [^ self inform: 
'Sorry, no suitable files found
(names should end with .morph, .gif,
.bmp, .jpeg, .jpe, .jp, or .form)'].

	self setProperty: #resourceFilePath toValue: pathName! !

!Morph methodsFor: 'fileIn/out' stamp: 'tak 2/10/2006 02:24'!
prepareToBeSaved
	"Prepare this morph to be saved to disk. Subclasses should nil out any instance variables that holds state that should not be saved, such as cached Forms. Note that this operation may take more drastic measures than releaseCachedState; for example, it might discard the transcript of an interactive chat session."

	self releaseCachedState.
	self formerOwner: nil.
	self formerPosition: nil.
	self removeProperty: #undoGrabCommand.
	fullBounds _ nil! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 2/17/1999 17:50'!
reserveUrl: urlString
	"Write a dummy object to the server to hold a name and place for this object."

	| dummy ext str |
	dummy _ PasteUpMorph new.
	dummy borderWidth: 2.
	dummy setProperty: #initialExtent toValue: (ext _ 300@100).
	dummy topLeft: 50@50; extent: ext.	"reset when comes in"
	str _ (TextMorph new) topLeft: dummy topLeft + (10@10); 
		extent: dummy width - 15 @ 30.
	dummy addMorph: str.
	str contents: 'This is a place holder only.  Please \find the original page and choose \"send this page to server"' withCRs.
	str extent: dummy width - 15 @ 30.
	dummy saveOnURL: urlString.

	"Claim that url myself"
	self setProperty: #SqueakPage toValue: dummy sqkPage.
	(dummy sqkPage) contentsMorph: self; dirty: true.
	^ self url! !

!Morph methodsFor: 'fileIn/out' stamp: 'di 11/18/1999 08:52'!
saveAsResource

	| pathName |
	(self hasProperty: #resourceFilePath) ifFalse: [^ self].
	pathName _ self valueOfProperty: #resourceFilePath.
	(pathName asLowercase endsWith: '.morph') ifFalse:
		[^ self error: 'Can only update morphic resources'].
	(FileStream newFileNamed: pathName) fileOutClass: nil andObject: self.! !

!Morph methodsFor: 'fileIn/out' stamp: 'ar 9/27/2005 21:02'!
saveDocPane

	Smalltalk at: #DocLibrary ifPresent:[:dl| dl external saveDocCheck: self]! !

!Morph methodsFor: 'fileIn/out' stamp: 'yo 7/2/2004 13:14'!
saveOnFile
	"Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| aFileName fileStream ok |
	aFileName _ ('my {1}' translated format: {self class name}) asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name? (".morph" will be added to end)' translated 
			initialAnswer: aFileName.
	aFileName isEmpty ifTrue: [^ Beeper beep].
	self allMorphsDo: [:m | m prepareToBeSaved].

	ok _ aFileName endsWith: '.morph'.	"don't double them"
	ok _ ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName _ aFileName,'.morph'].
	fileStream _ FileStream newFileNamed: aFileName asFileName.
	fileStream fileOutClass: nil andObject: self.	"Puts UniClass definitions out anyway"! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 7/16/1999 13:03'!
saveOnURL
	"Ask the user for a url and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| um pg |
	(pg _ self saveOnURLbasic) == #cancel ifTrue: [^ self].
	um _ URLMorph newForURL: pg url.
	um setURL: pg url page: pg.
	pg isContentsInMemory ifTrue: [pg computeThumbnail].
	um isBookmark: true.
	um removeAllMorphs.
	um color: Color transparent.
	self primaryHand attachMorph: um.! !

!Morph methodsFor: 'fileIn/out' stamp: 'dgd 2/22/2003 14:35'!
saveOnURLbasic
	"Ask the user for a url and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| url pg stamp pol |
	(pg := self valueOfProperty: #SqueakPage) ifNil: [pg := SqueakPage new]
		ifNotNil: 
			[pg contentsMorph ~~ self 
				ifTrue: 
					[self inform: 'morph''s SqueakPage property is out of date'.
					pg := SqueakPage new]].
	(url := pg url) ifNil: 
			[url := ServerDirectory defaultStemUrl , '1.sp'.	"A new legal place"
			url := FillInTheBlank 
						request: 'url of a place to store this object.
Must begin with file:// or ftp://'
						initialAnswer: url.
			url isEmpty ifTrue: [^#cancel]].
	stamp := Utilities authorInitialsPerSe ifNil: ['*'].
	pg saveMorph: self author: stamp.
	SqueakPageCache atURL: url put: pg.	"setProperty: #SqueakPage"
	(pol := pg policy) ifNil: [pol := #neverWrite].
	pg
		policy: #now;
		dirty: true.
	pg write.	"force the write"
	pg policy: pol.
	^pg! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 11/20/1998 11:47'!
saveOnURL: suggestedUrlString
	"Save myself on a SmartReferenceStream file.  If I don't already have a url, use the suggested one.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| url pg stamp pol |
	(pg _ self valueOfProperty: #SqueakPage) ifNil: [pg _ SqueakPage new]
		ifNotNil: [pg contentsMorph ~~ self ifTrue: [
				self inform: 'morph''s SqueakPage property is out of date'.
				pg _ SqueakPage new]].
	(url _ pg url) ifNil: [url _ pg urlNoOverwrite: suggestedUrlString].
	stamp _ Utilities authorInitialsPerSe ifNil: ['*'].
	pg saveMorph: self author: stamp.
	SqueakPageCache atURL: url put: pg.	"setProperty: #SqueakPage"
	(pol _ pg policy) ifNil: [pol _ #neverWrite].
	pg policy: #now; dirty: true.  pg write.	"force the write"
	pg policy: pol.
	^ pg! !

!Morph methodsFor: 'fileIn/out' stamp: 'di 11/18/1999 09:15'!
updateAllFromResources

	self allMorphsDo: [:m | m updateFromResource]! !

!Morph methodsFor: 'fileIn/out' stamp: 'nk 1/6/2004 12:38'!
updateFromResource
	| pathName newMorph f |
	(pathName := self valueOfProperty: #resourceFilePath) ifNil: [^self].
	(pathName asLowercase endsWith: '.morph') 
		ifTrue: 
			[newMorph := (FileStream readOnlyFileNamed: pathName) fileInObjectAndCode.
			(newMorph isMorph) 
				ifFalse: [^self error: 'Resource not a single morph']]
		ifFalse: 
			[f := Form fromFileNamed: pathName.
			f ifNil: [^self error: 'unrecognized image file format'].
			newMorph := World drawingClass withForm: f].
	newMorph setProperty: #resourceFilePath toValue: pathName.
	self owner replaceSubmorph: self by: newMorph! !


!Morph methodsFor: 'filter streaming' stamp: 'ar 10/26/2000 19:55'!
drawOnCanvas: aCanvas
	^aCanvas fullDraw: self.
! !



!Morph methodsFor: 'geometry' stamp: 'di 7/24/97 11:55'!
align: aPoint1 with: aPoint2
	"Translate by aPoint2 - aPoint1."

	^ self position: self position + (aPoint2 - aPoint1)! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:17'!
bottom
	" Return the y-coordinate of my bottom side "

	^ bounds bottom! !

!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'!
bottomCenter

	^ bounds bottomCenter! !

!Morph methodsFor: 'geometry' stamp: 'tk 9/8/97 10:44'!
bottomLeft

	^ bounds bottomLeft! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:08'!
bottomLeft: aPoint
	" Move me so that my bottom left corner is at aPoint. My extent (width & height) are unchanged "

	self position: ((aPoint x) @ (aPoint y - self height)).
! !

!Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:17'!
bottomRight

	^ bounds bottomRight! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:09'!
bottomRight: aPoint
	" Move me so that my bottom right corner is at aPoint. My extent (width & height) are unchanged "

	self position: ((aPoint x - bounds width) @ (aPoint y - self height))
! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:14'!
bottom: aNumber
	" Move me so that my bottom is at the y-coordinate aNumber. My extent (width & height) are unchanged "

	self position: (bounds left @ (aNumber - self height))! !

!Morph methodsFor: 'geometry' stamp: 'jm 8/3/97 15:50'!
bounds
	"Return the bounds of this morph."
	"Note: It is best not to override this method because many methods in Morph and its subclasses use the instance variable directly rather than 'self bounds'. Instead, subclasses should be sure that the bounds instance variable is correct."

	^ bounds
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:05'!
boundsInWorld
	^self bounds: self bounds in: self world! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'!
boundsIn: referenceMorph
	"Return the receiver's bounds as seen by aMorphs coordinate frame"
	^self bounds: self bounds in: referenceMorph! !

!Morph methodsFor: 'geometry' stamp: 'ar 12/14/2000 13:48'!
bounds: newBounds
	| oldExtent newExtent |
	oldExtent _ self extent.
	newExtent _ newBounds extent.
	(oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[
		"We're growing. First move then resize."
		self position: newBounds topLeft; extent: newExtent.
	] ifFalse:[
		"We're shrinking. First resize then move."
		self extent: newExtent; position: newBounds topLeft.
	].! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'!
bounds: aRectangle from: referenceMorph
	"Return the receiver's bounds as seen by aMorphs coordinate frame"
	owner ifNil: [^ aRectangle].
	^(owner transformFrom: referenceMorph) globalBoundsToLocal: aRectangle
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'!
bounds: aRectangle in: referenceMorph
	"Return the receiver's bounds as seen by aMorphs coordinate frame"
	owner ifNil: [^ aRectangle].
	^(owner transformFrom: referenceMorph) localBoundsToGlobal: aRectangle
! !

!Morph methodsFor: 'geometry'!
center

	^ bounds center! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/11/1999 18:48'!
center: aPoint
	self position: (aPoint - (self extent // 2))! !

!Morph methodsFor: 'geometry'!
extent

	^ bounds extent! !

!Morph methodsFor: 'geometry' stamp: 'laza 3/25/2004 21:31'!
extent: aPoint

	bounds extent = aPoint ifTrue: [^ self].
	self changed.
	bounds _ (bounds topLeft extent: aPoint) rounded.
	self layoutChanged.
	self changed.
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'!
fullBoundsInWorld
	^self bounds: self fullBounds in: self world! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'!
globalPointToLocal: aPoint
	^self point: aPoint from: nil! !

!Morph methodsFor: 'geometry' stamp: 'ar 9/15/2000 14:21'!
griddedPoint: ungriddedPoint

	| griddingContext |
	self flag: #arNote. "Used by event handling - should transform to pasteUp for gridding"
	(griddingContext _ self pasteUpMorph) ifNil: [^ ungriddedPoint].
	^ griddingContext gridPoint: ungriddedPoint! !

!Morph methodsFor: 'geometry' stamp: 'di 8/25/2000 00:35'!
gridPoint: ungriddedPoint

	^ ungriddedPoint! !

!Morph methodsFor: 'geometry'!
height

	^ bounds height! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:22'!
height: aNumber
	" Set my height; my position (top-left corner) and width will remain the same "

	self extent: self width@aNumber asInteger.
! !

!Morph methodsFor: 'geometry' stamp: 'ar 12/22/2001 22:43'!
innerBounds
	"Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds."

	^ self bounds insetBy: self borderWidth! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'!
left
	" Return the x-coordinate of my left side "

	^ bounds left! !

!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'!
leftCenter

	^ bounds leftCenter! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:15'!
left: aNumber
	" Move me so that my left side is at the x-coordinate aNumber. My extent (width & height) are unchanged "

	self position: (aNumber @ bounds top)! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:07'!
localPointToGlobal: aPoint
	^self point: aPoint in: nil! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 21:59'!
minimumExtent
	| ext |
	"This returns the minimum extent that the morph may be shrunk to.  Not honored in too many places yet, but respected by the resizeToFit feature, at least.  copied up from SystemWindow 6/00"
	(ext _ self valueOfProperty: #minimumExtent)
		ifNotNil:
			[^ ext].
	^ 100 @ 80! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 22:00'!
minimumExtent: aPoint
	"Remember a minimumExtent, for possible future use"

	self setProperty: #minimumExtent toValue: aPoint
! !

!Morph methodsFor: 'geometry' stamp: 'sw 7/10/1999 17:26'!
nextOwnerPage
	"Tell my container to advance to the next page"
	| targ |
	targ _ self ownerThatIsA: BookMorph.
	targ ifNotNil: [targ nextPage]! !

!Morph methodsFor: 'geometry' stamp: 'ar 11/12/2000 22:06'!
outerBounds
	"Return the 'outer' bounds of the receiver, e.g., the bounds that need to be invalidated when the receiver changes."
	| box |
	box _ self bounds.
	self hasDropShadow ifTrue:[box _ self expandFullBoundsForDropShadow: box].
	self hasRolloverBorder ifTrue:[box _ self expandFullBoundsForRolloverBorder: box].
	^box! !

!Morph methodsFor: 'geometry' stamp: 'nk 5/19/2003 20:39'!
overlapsShadowForm: itsShadow bounds: itsBounds
	"Answer true if itsShadow and my shadow overlap at all"
	| andForm overlapExtent |
	overlapExtent _ (itsBounds intersect: self fullBounds) extent.
	overlapExtent > (0 @ 0)
		ifFalse: [^ false].
	andForm _ self shadowForm.
	overlapExtent ~= self fullBounds extent
		ifTrue: [andForm _ andForm
						contentsOfArea: (0 @ 0 extent: overlapExtent)].
	andForm _ andForm
				copyBits: (self fullBounds translateBy: itsShadow offset negated)
				from: itsShadow
				at: 0 @ 0
				clippingBox: (0 @ 0 extent: overlapExtent)
				rule: Form and
				fillColor: nil.
	^ andForm bits
		anySatisfy: [:w | w ~= 0]! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:02'!
pointFromWorld: aPoint
	^self point: aPoint from: self world! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:03'!
pointInWorld: aPoint
	^self point: aPoint in: self world! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'!
point: aPoint from: aReferenceMorph

	owner ifNil: [^ aPoint].
	^ (owner transformFrom: aReferenceMorph) globalPointToLocal: aPoint.
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'!
point: aPoint in: aReferenceMorph

	owner ifNil: [^ aPoint].
	^ (owner transformFrom: aReferenceMorph) localPointToGlobal: aPoint.
! !

!Morph methodsFor: 'geometry'!
position

	^ bounds topLeft! !

!Morph methodsFor: 'geometry' stamp: 'di 9/30/1998 12:11'!
positionInWorld

	^ self pointInWorld: self position.
! !

!Morph methodsFor: 'geometry' stamp: 'sw 10/9/1998 08:56'!
positionSubmorphs
	self submorphsDo:
		[:aMorph | aMorph snapToEdgeIfAppropriate]! !

!Morph methodsFor: 'geometry' stamp: 'wiz 11/25/2004 12:54'!
position: aPoint 
	"Change the position of this morph and and all of its
	submorphs. "
	| delta box |
	delta := aPoint asNonFractionalPoint - bounds topLeft.
	(delta x = 0
			and: [delta y = 0])
		ifTrue: [^ self].
	"Null change"
	box := self fullBounds.
	(delta dotProduct: delta)
			> 100
		ifTrue: ["e.g., more than 10 pixels moved"
			self invalidRect: box.
			self
				invalidRect: (box translateBy: delta)]
		ifFalse: [self
				invalidRect: (box
						merge: (box translateBy: delta))].
	self privateFullMoveBy: delta.
	owner
		ifNotNil: [owner layoutChanged]! !

!Morph methodsFor: 'geometry' stamp: 'sw 7/10/1999 17:27'!
previousOwnerPage
	"Tell my container to advance to the previous page"
	| targ |
	targ _ self ownerThatIsA: BookMorph.
	targ ifNotNil: [targ previousPage]! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'!
right
	" Return the x-coordinate of my right side "
	^ bounds right! !

!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'!
rightCenter

	^ bounds rightCenter! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:15'!
right: aNumber
	" Move me so that my right side is at the x-coordinate aNumber. My extent (width & height) are unchanged "

	self position: ((aNumber - bounds width) @ bounds top)! !

!Morph methodsFor: 'geometry' stamp: 'bf 1/5/2000 19:08'!
screenLocation
	"For compatibility only"

	^ self fullBounds origin! !

!Morph methodsFor: 'geometry' stamp: 'sma 2/5/2000 13:58'!
screenRectangle
	"For compatibility only"

	^ self fullBounds! !

!Morph methodsFor: 'geometry' stamp: 'tk 7/14/2001 11:11'!
setConstrainedPosition: aPoint hangOut: partiallyOutside
	"Change the position of this morph and and all of its submorphs to aPoint, but don't let me go outside my owner's bounds.  Let me go within two pixels of completely outside if partiallyOutside is true."

	| trialRect delta boundingMorph bRect |
	owner ifNil:[^self].
	trialRect _ aPoint extent: self bounds extent.
	boundingMorph _ self topRendererOrSelf owner.
	delta _ boundingMorph
			ifNil:    [0@0]
			ifNotNil: [
				bRect _ partiallyOutside 
					ifTrue: [boundingMorph bounds insetBy: 
								self extent negated + boundingMorph borderWidth + (2@2)]
					ifFalse: [boundingMorph bounds].
				trialRect amountToTranslateWithin: bRect].
	self position: aPoint + delta.
	self layoutChanged  "So that, eg, surrounding text will readjust"
! !

!Morph methodsFor: 'geometry' stamp: 'sw 2/16/1999 22:05'!
shiftSubmorphsOtherThan: listNotToShift by: delta
	| rejectList |
	rejectList _ listNotToShift ifNil: [OrderedCollection new].
	(submorphs copyWithoutAll: rejectList) do:
		[:m | m position: (m position + delta)]! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:17'!
top
	" Return the y-coordinate of my top side "

	^ bounds top! !

!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'!
topCenter

	^ bounds topCenter! !

!Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:07'!
topLeft

	^ bounds topLeft! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:10'!
topLeft: aPoint
	" Move me so that my top left corner is at aPoint. My extent (width & height) are unchanged "

	self position: aPoint
! !

!Morph methodsFor: 'geometry' stamp: 'sw 8/20/97 23:04'!
topRight

	^ bounds topRight! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:12'!
topRight: aPoint
	" Move me so that my top right corner is at aPoint. My extent (width & height) are unchanged "

	self position: ((aPoint x - bounds width) @ (aPoint y))
! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:14'!
top: aNumber
	" Move me so that my top is at the y-coordinate aNumber. My extent (width & height) are unchanged "

	self position: (bounds left @ aNumber)! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/22/2000 18:03'!
transformedBy: aTransform
	aTransform isIdentity ifTrue:[^self].
	aTransform isPureTranslation ifTrue:[
		^self position: (aTransform localPointToGlobal: self position).
	].
	^self addFlexShell transformedBy: aTransform! !

!Morph methodsFor: 'geometry'!
width

	^ bounds width! !

!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:22'!
width: aNumber
	" Set my width; my position (top-left corner) and height will remain the same "

	self extent: aNumber asInteger@self height.
! !

!Morph methodsFor: 'geometry' stamp: 'di 2/23/98 11:36'!
worldBounds
	^ self world bounds! !

!Morph methodsFor: 'geometry' stamp: 'dgd 9/10/2004 12:37'!
worldBoundsForHalo
	"Answer the rectangle to be used as the inner dimension of my halos.
	Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle."

	| r |
	r _ (Preferences haloEnclosesFullBounds)
		ifFalse: [ self boundsIn: nil ]
		ifTrue: [ self fullBoundsInWorld ].
	Preferences showBoundsInHalo ifTrue: [ ^r outsetBy: 2 ].
	^r! !


!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/23/1998 12:00'!
addTransparentSpacerOfSize: aPoint
	self addMorphBack: (self transparentSpacerOfSize: aPoint)! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/23/1998 12:01'!
beTransparent
	self color: Color transparent! !

!Morph methodsFor: 'geometry eToy' stamp: 'RAA 11/8/2000 18:29'!
cartesianBoundsTopLeft
	"Answer the origin of this morph relative to it's container's cartesian origin. 
	NOTE: y DECREASES toward the bottom of the screen"

	| w container |

	w _ self world ifNil: [^ bounds origin].
	container _ self referencePlayfield ifNil: [w].
	^ (bounds left - container cartesianOrigin x) @
		(container cartesianOrigin y - bounds top)! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 1/17/2000 20:55'!
cartesianXY: coords
	^ self x: coords x y: coords y
! !

!Morph methodsFor: 'geometry eToy' stamp: 'di 9/9/1998 22:49'!
colorUnder
	"Return the color of under the receiver's center."

	self isInWorld
		ifTrue: [^ self world colorAt: (self pointInWorld: self referencePosition) belowMorph: self]
		ifFalse: [^ Color black].
! !

!Morph methodsFor: 'geometry eToy' stamp: 'nk 7/7/2003 17:18'!
color: sensitiveColor sees: soughtColor 
	"Return true if any of my pixels of sensitiveColor intersect with pixels of soughtColor."

	"Make a mask with black where sensitiveColor is, white elsewhere"

	| myImage sensitivePixelMask map patchBelowMe tfm morphAsFlexed i1 pasteUp |
	pasteUp _ self world ifNil: [ ^false ].
	tfm := self transformFrom: pasteUp.
	morphAsFlexed := tfm isIdentity 
				ifTrue: [self]
				ifFalse: [TransformationMorph new flexing: self clone byTransformation: tfm].
	myImage := morphAsFlexed imageForm offset: 0 @ 0.
	sensitivePixelMask := Form extent: myImage extent depth: 1.
	"ensure at most a 16-bit map"
	map := Bitmap new: (1 bitShift: (myImage depth - 1 min: 15)).
	map at: (i1 := sensitiveColor indexInMap: map) put: 1.
	sensitivePixelMask 
		copyBits: sensitivePixelMask boundingBox
		from: myImage form
		at: 0 @ 0
		colorMap: map.

	"get an image of the world below me"
	patchBelowMe := pasteUp 
				patchAt: morphAsFlexed fullBounds
				without: self
				andNothingAbove: false.
	"
sensitivePixelMask displayAt: 0@0.
patchBelowMe displayAt: 100@0.
"
	"intersect world pixels of the color we're looking for with the sensitive pixels"
	map at: i1 put: 0.	"clear map and reuse it"
	map at: (soughtColor indexInMap: map) put: 1.
	sensitivePixelMask 
		copyBits: patchBelowMe boundingBox
		from: patchBelowMe
		at: 0 @ 0
		clippingBox: patchBelowMe boundingBox
		rule: Form and
		fillColor: nil
		map: map.
	"
sensitivePixelMask displayAt: 200@0.
"
	^(sensitivePixelMask tallyPixelValues second) > 0! !

!Morph methodsFor: 'geometry eToy' stamp: 'di 10/1/2000 11:54'!
degreesOfFlex
	"Return any rotation due to flexing"
	"NOTE: because renderedMorph, which is used by the halo to set heading, goes down through dropShadows as well as transformations, we need this method (and its other implems) to come back up through such a chain."
	^ 0.0! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 14:29'!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 9/8/2000 16:35'!
getIndexInOwner
	"Answer which position the receiver holds in its owner's hierarchy"

	"NB: There is some concern about submorphs that aren't really to be counted, such as a background morph of a playfield."

	| container topRenderer |
	container _ (topRenderer _ self topRendererOrSelf) owner.
	^ container submorphIndexOf: topRenderer.! !

!Morph methodsFor: 'geometry eToy' stamp: 'dgd 9/20/2004 14:15'!
goHome
	| box fb |
	owner isInMemory ifFalse: [^ self].
	owner isNil ifTrue: [^ self].
	self visible ifFalse: [^ self].

	box := owner visibleClearArea.
	fb := self fullBounds.

	fb left < box left
		ifTrue: [self left: box left - fb left + self left].
	fb right > box right
		ifTrue: [self right: box right - fb right + self right].

	fb top < box top
		ifTrue: [self top: box top - fb top + self top].
	fb bottom > box bottom
		ifTrue: [self bottom: box bottom - fb bottom + self bottom].
! !

!Morph methodsFor: 'geometry eToy' stamp: 'di 10/1/2000 11:50'!
heading
	"Return the receiver's heading (in eToy terms)"
	owner ifNil: [^ self forwardDirection].
	^ self forwardDirection + owner degreesOfFlex! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 13:37'!
heading: newHeading
	"Set the receiver's heading (in eToy terms)"
	self isFlexed ifFalse:[self addFlexShell].
	owner rotationDegrees: (newHeading - self forwardDirection).! !

!Morph methodsFor: 'geometry eToy'!
move: aMorph toPosition: aPointOrNumber
	"Support for e-toy demo. Move the given submorph to the given position. Allows the morph's owner to determine the policy for motion. For example, moving forward through a table might mean motion only in the x-axis with wrapping modulo the table size."

	aMorph position: aPointOrNumber asPoint.
! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 20:12'!
referencePosition
	"Return the current reference position of the receiver"
	| box |
	box _ self bounds.
	^box origin + (self rotationCenter * box extent).
! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/25/1999 16:49'!
referencePositionInWorld

	^ self pointInWorld: self referencePosition
! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/25/1999 23:33'!
referencePositionInWorld: aPoint
	| localPosition |
	localPosition _ owner
		ifNil: [aPoint]
		ifNotNil: [(owner transformFrom: self world) globalPointToLocal: aPoint].

	self referencePosition: localPosition
! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/27/2000 14:04'!
referencePosition: aPosition
	"Move the receiver to match its reference position with aPosition"
	| newPos intPos |
	newPos _ self position + (aPosition - self referencePosition).
	intPos _ newPos asIntegerPoint.
	newPos = intPos 
		ifTrue:[self position: intPos]
		ifFalse:[self position: newPos].! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 20:10'!
rotationCenter
	"Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	^self valueOfProperty: #rotationCenter ifAbsent:[0.5@0.5]
! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 20:11'!
rotationCenter: aPointOrNil
	"Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	aPointOrNil isNil
		ifTrue:[self removeProperty: #rotationCenter]
		ifFalse:[self setProperty: #rotationCenter toValue: aPointOrNil]
! !

!Morph methodsFor: 'geometry eToy' stamp: 'nk 9/4/2004 11:04'!
scaleFactor: newScale 
	"Backstop for morphs that don't have to do something special to set their 
	scale "
	| toBeScaled |
	toBeScaled := self.
	newScale = 1.0
		ifTrue: [(self heading isZero
					and: [self isFlexMorph])
				ifTrue: [toBeScaled := self removeFlexShell]]
		ifFalse: [self isFlexMorph
				ifFalse: [toBeScaled := self addFlexShellIfNecessary]].

	toBeScaled scale: newScale.

	toBeScaled == self ifTrue: [
		newScale = 1.0
			ifTrue: [ self removeProperty: #scaleFactor ]
			ifFalse: [ self setProperty: #scaleFactor toValue: newScale ]]! !

!Morph methodsFor: 'geometry eToy' stamp: 'nk 9/4/2004 11:00'!
scale: newScale
	"Backstop for morphs that don't have to do something special to set their scale"
! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:23'!
setDirectionFrom: aPoint
	| delta degrees |
	delta _ (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
	degrees _ delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.
! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 8/31/2000 11:18'!
setIndexInOwner: anInteger
	"Answer which position the receiver holds in its owner's hierarchy"

	"There is some concern about submorphs that aren't really to be counted, such as a background morph of a playfield."
	| container topRenderer indexToUse |
	container _ (topRenderer _ self topRendererOrSelf) owner.
	indexToUse _ (anInteger min: container submorphCount) max: 1.
	container addMorph: topRenderer asElementNumber: indexToUse! !

!Morph methodsFor: 'geometry eToy' stamp: 'wiz 11/6/2005 17:10'!
simplySetVisible: aBoolean
	"Set the receiver's visibility property.  This mild circumlocution is because my TransfomationMorph #visible: method would also set the visibility flag of my flexee, which in this case is pointless because it's the flexee that calls this.
	This appears in morph as a backstop for morphs that don't inherit from TFMorph"

	self visible: aBoolean! !

!Morph methodsFor: 'geometry eToy' stamp: 'nk 7/7/2003 17:19'!
touchesColor: soughtColor 
	"Return true if any of my pixels overlap pixels of soughtColor."

	"Make a shadow mask with black in my shape, white elsewhere"

	| map patchBelowMe shadowForm tfm morphAsFlexed pasteUp |
	pasteUp := self world ifNil: [ ^false ].

	tfm := self transformFrom: pasteUp.
	morphAsFlexed := tfm isIdentity 
				ifTrue: [self]
				ifFalse: [TransformationMorph new flexing: self clone byTransformation: tfm].
	shadowForm := morphAsFlexed shadowForm offset: 0 @ 0.

	"get an image of the world below me"
	patchBelowMe := (pasteUp 
				patchAt: morphAsFlexed fullBounds
				without: self
				andNothingAbove: false) offset: 0 @ 0.
	"
shadowForm displayAt: 0@0.
patchBelowMe displayAt: 100@0.
"
	"intersect world pixels of the color we're looking for with our shape."
	"ensure a maximum 16-bit map"
	map := Bitmap new: (1 bitShift: (patchBelowMe depth - 1 min: 15)).
	map at: (soughtColor indexInMap: map) put: 1.
	shadowForm 
		copyBits: patchBelowMe boundingBox
		from: patchBelowMe
		at: 0 @ 0
		clippingBox: patchBelowMe boundingBox
		rule: Form and
		fillColor: nil
		map: map.
	"
shadowForm displayAt: 200@0.
"
	^(shadowForm tallyPixelValues second) > 0! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/23/1998 11:50'!
transparentSpacerOfSize: aPoint
	^ (Morph new extent: aPoint) color: Color transparent! !

!Morph methodsFor: 'geometry eToy' stamp: 'tk 7/8/1998 23:47'!
wrap

	| myBox box newX newY wrapped |
	owner ifNil: [^ self].
	myBox _ self fullBounds.
	myBox corner < (50000@50000) ifFalse: [
		self inform: 'Who is trying to wrap a hidden object?'. ^ self].
	box _ owner bounds.
	newX _ self position x.
	newY _ self position y.
	wrapped _ false.
	((myBox right < box left) or: [myBox left > box right]) ifTrue: [
		newX _ box left + ((self position x - box left) \\ box width).
		wrapped _ true].
	((myBox bottom < box top) or: [myBox top > box bottom]) ifTrue: [
		newY _ box top + ((self position y - box top) \\ box height).
		wrapped _ true].
	self position: newX@newY.
	(wrapped and: [owner isPlayfieldLike])
		ifTrue: [owner changed].  "redraw all turtle trails if wrapped"

! !

!Morph methodsFor: 'geometry eToy' stamp: 'dgd 2/22/2003 14:37'!
x
	"Return my horizontal position relative to the cartesian origin of a relevant playfield"

	| aPlayfield |
	aPlayfield := self referencePlayfield.
	^aPlayfield isNil 
		ifTrue: [self referencePosition x]
		ifFalse: [self referencePosition x - aPlayfield cartesianOrigin x]! !

!Morph methodsFor: 'geometry eToy' stamp: 'aoy 2/17/2003 01:00'!
x: aNumber 
	"Set my horizontal position relative to the cartesian origin of the playfield or the world."

	| offset aPlayfield newX |
	aPlayfield := self referencePlayfield.
	offset := self left - self referencePosition x.
	newX := aPlayfield isNil
				ifTrue: [aNumber + offset]
				ifFalse: [aPlayfield cartesianOrigin x + aNumber + offset].
	self position: newX @ bounds top! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 1/17/2000 20:04'!
x: xCoord y: yCoord
	| aWorld xyOffset delta aPlayfield |
	(aWorld _ self world) ifNil: [^ self position: xCoord @ yCoord].
	xyOffset _ self topLeft - self referencePosition.
	delta _ (aPlayfield _ self referencePlayfield)
		ifNil:
			[xCoord @ (aWorld bottom - yCoord)]
		ifNotNil:
			[aPlayfield cartesianOrigin + (xCoord @ (yCoord negated))].
	self position: (xyOffset + delta)
! !

!Morph methodsFor: 'geometry eToy' stamp: 'dgd 2/22/2003 14:37'!
y
	"Return my vertical position relative to the cartesian origin of the playfield or the world. Note that larger y values are closer to the top of the screen."

	| w aPlayfield |
	w := self world.
	w ifNil: [^bounds top].
	aPlayfield := self referencePlayfield.
	^aPlayfield isNil 
		ifTrue: [w cartesianOrigin y - self referencePosition y]
		ifFalse: [aPlayfield cartesianOrigin y - self referencePosition y]! !

!Morph methodsFor: 'geometry eToy' stamp: 'aoy 2/17/2003 01:00'!
y: aNumber 
	"Set my vertical position relative to the cartesian origin of the playfield or the world. Note that larger y values are closer to the top of the screen."

	| w offset newY aPlayfield |
	w := self world.
	w ifNil: [^self position: bounds left @ aNumber].
	aPlayfield := self referencePlayfield.
	offset := self top - self referencePosition y.
	newY := aPlayfield isNil
				ifTrue: [w bottom - aNumber + offset]
				ifFalse: [aPlayfield cartesianOrigin y - aNumber + offset].
	self position: bounds left @ newY! !


!Morph methodsFor: 'geometry testing'!
containsPoint: aPoint

	^ self bounds containsPoint: aPoint! !

!Morph methodsFor: 'geometry testing' stamp: 'di 5/3/2000 19:05'!
fullContainsPoint: aPoint

	(self fullBounds containsPoint: aPoint) ifFalse: [^ false].  "quick elimination"
	(self containsPoint: aPoint) ifTrue: [^ true].  "quick acceptance"
	submorphs do: [:m | (m fullContainsPoint: aPoint) ifTrue: [^ true]].
	^ false
! !

!Morph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 14:33'!
obtrudesBeyondContainer
	"Answer whether the receiver obtrudes beyond the bounds of its container"

	| top |
	top := self topRendererOrSelf.
	(top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
	^(top owner bounds containsRect: top bounds) not! !


!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 18:57'!
addHalo
	"Invoke a halo programatically (e.g., not from a meta gesture)"
	^self addHalo: nil! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/10/2000 19:03'!
addHalo: evt
	| halo prospectiveHaloClass |
	prospectiveHaloClass _ Smalltalk at: self haloClass ifAbsent: [HaloMorph].
	halo _ prospectiveHaloClass new bounds: self worldBoundsForHalo.
	halo popUpFor: self event: evt.
	^halo! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 21:55'!
addHalo: evt from: formerHaloOwner
	"Transfer a halo from the former halo owner to the receiver"
	^self addHalo: evt! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 12/30/2004 02:53'!
addHandlesTo: aHaloMorph box: box
	"Add halo handles to the halo.  Apply the halo filter if appropriate"

	| wantsIt aSelector |
	aHaloMorph haloBox: box.
	Preferences haloSpecifications  do:
		[:aSpec | 
			aSelector _  aSpec addHandleSelector.
			wantsIt _ Preferences selectiveHalos
				ifTrue:
					[self wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph]
				ifFalse:
					[true].
			wantsIt ifTrue:
				[(#(addMakeSiblingHandle: addDupHandle:) includes: aSelector) ifTrue:
					[wantsIt _ self preferredDuplicationHandleSelector = aSelector].
			wantsIt ifTrue:
				[aHaloMorph perform: aSelector with: aSpec]]].

	aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 8/8/2001 17:31'!
addMagicHaloFor: aHand
	| halo prospectiveHaloClass |
	aHand halo ifNotNil:[
		aHand halo target == self ifTrue:[^self].
		aHand halo isMagicHalo ifFalse:[^self]].
	prospectiveHaloClass _ Smalltalk at: self haloClass ifAbsent: [HaloMorph].
	halo _ prospectiveHaloClass new bounds: self worldBoundsForHalo.
	halo popUpMagicallyFor: self hand: aHand.! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/22/2000 20:41'!
addOptionalHandlesTo: aHalo box: box
	aHalo addDirectionHandles! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 12/21/1999 17:52'!
addSimpleHandlesTo: aHaloMorph box: aBox
	^ aHaloMorph addSimpleHandlesTo: aHaloMorph box: aBox! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/26/2000 19:37'!
addWorldHandlesTo: aHaloMorph box: box
	aHaloMorph haloBox: box.
	Preferences haloSpecificationsForWorld do:
		[:aSpec | 
			aHaloMorph perform: aSpec addHandleSelector with: aSpec].
	aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:54'!
balloonColor
	^ self
		valueOfProperty: #balloonColor
		ifAbsent: [self defaultBalloonColor]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:55'!
balloonColor: aColor
	^ self
		setProperty: #balloonColor
		toValue: aColor! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:29'!
balloonFont
	^ self
		valueOfProperty: #balloonFont
		ifAbsent: [self defaultBalloonFont]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:30'!
balloonFont: aFont 
	^ self setProperty: #balloonFont toValue: aFont! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 2/7/2000 11:27'!
balloonHelpAligner
	"Answer the morph to which the receiver's balloon help should point"
	^ (self valueOfProperty: #balloonTarget) ifNil: [self]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 9/7/2004 18:35'!
balloonHelpDelayTime
	"Return the number of milliseconds before a balloon help should be put up on the receiver. The balloon help will only be put up if the receiver responds to #wantsBalloon by returning true."
	^ Preferences balloonHelpDelayTime! !

!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 4/3/2006 14:15'!
balloonHelpTextForHandle: aHandle
	"Answer a string providing balloon help for the given halo handle"

	|  itsSelector |
	itsSelector _ aHandle eventHandler firstMouseSelector.

	(itsSelector == #doRecolor:with:) ifTrue:
		[^ Preferences propertySheetFromHalo
			ifTrue: ['Open a property sheet.']
			ifFalse: ['Change color']].

	(itsSelector == #mouseDownInDimissHandle:with:) ifTrue:
		[^ Preferences preserveTrash
			ifTrue: ['Move to trash']
			ifFalse: ['Remove from screen']].

	#(	(addFullHandles							'More halo handles')
		(addSimpleHandles						'Fewer halo handles')
		(chooseEmphasisOrAlignment				'Emphasis & alignment')
		(chooseFont								'Change font')
		(chooseNewGraphicFromHalo				'Choose a new graphic')
		(chooseStyle								'Change style')
		(dismiss									'Remove')
		(doDebug:with:							'Debug')
		(doDirection:with:						'Choose forward direction')
		(doDup:with:							'Duplicate')
		(doMakeSibling:with: 					'Make a sibling')
		(doMenu:with:							'Menu')
		(doGrab:with:							'Pick up')
		(editButtonsScript						'See the script for this button')
		(editDrawing							'Repaint')
		(maybeDoDup:with:						'Duplicate')
		(makeNascentScript						'Make a scratch script')
		(makeNewDrawingWithin				'Paint new object')
		(mouseDownInCollapseHandle:with:		'Collapse')
		(mouseDownOnHelpHandle:				'Help')
		(openViewerForArgument				'Open a Viewer for me. Press shift for a snapshot.')
		(openViewerForTarget:with:				'Open a Viewer for me. Press shift for a snapshot.')
		(paintBackground						'Paint background')
		(prepareToTrackCenterOfRotation:with:	'Move object or set center of rotation')
		(presentViewMenu						'Present the Viewing menu')
		(startDrag:with:							'Move')
		(startGrow:with:							'Change size') 
		(startRot:with:							'Rotate')
		(startScale:with:							'Change scale') 
		(tearOffTile								'Make a tile representing this object')
		(tearOffTileForTarget:with:				'Make a tile representing this object')
		(trackCenterOfRotation:with:				'Set center of rotation')
	) 
	do:
		[:pair | itsSelector == pair first ifTrue: [^ pair last]].

	^ 'unknown halo handle'! !

!Morph methodsFor: 'halos and balloon help' stamp: 'RAA 7/21/2000 11:10'!
boundsForBalloon

	"some morphs have bounds that are way too big"
	^self boundsInWorld! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 3/1/2000 11:39'!
comeToFrontAndAddHalo
	self comeToFront.
	self addHalo! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 16:15'!
defaultBalloonColor
	^ Display depth <= 2
		ifTrue: [Color white]
		ifFalse: [BalloonMorph balloonColor]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:23'!
defaultBalloonFont
	^ BalloonMorph balloonFont! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/11/2000 18:24'!
defersHaloOnClickTo: aSubMorph
	"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
	"May want to add a way (via a property) for morphs to assert true here -- this would let certain kinds of morphs that are unusually reluctant to take the halo on initial click"

	^ false
	! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:03'!
deleteBalloon
	"If I am showing a balloon, delete it."
	| w |
	w _ self world ifNil:[^self].
	w deleteBalloonTarget: self.! !

!Morph methodsFor: 'halos and balloon help' stamp: 'em 3/24/2005 10:02'!
editBalloonHelpContent: aString
	| reply |
	reply _ FillInTheBlank
		multiLineRequest: 'Edit the balloon help text for ' translated, self externalName
		centerAt: Sensor cursorPoint
		initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString])
		answerHeight: 200.
	reply ifNil: [^ self].  "User cancelled out of the dialog"
	(reply isEmpty or: [reply asString = self noHelpString])
		ifTrue: [self setBalloonText: nil]
		ifFalse: [self setBalloonText: reply]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:24'!
editBalloonHelpText
	"Modify the receiver's balloon help text."

	self editBalloonHelpContent: self balloonText! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 3/17/2001 13:19'!
halo

	(self outermostWorldMorph ifNil: [^nil]) haloMorphs do: [:h | h target == self ifTrue: [^ h]].
	^ nil! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/15/2000 16:13'!
haloClass
	"Answer the name of the desired kind of HaloMorph to launch on behalf of the receiver"

	^ #HaloMorph
! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 8/8/2001 15:40'!
haloDelayTime
	"Return the number of milliseconds before a halo should be put up on the receiver. The halo will only be put up if the receiver responds to #wantsHalo by returning true."
	^800! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/15/2000 16:16'!
hasHalo
	^self hasProperty: #hasHalo.! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/28/2000 17:54'!
hasHalo: aBool
	aBool
		ifTrue:[self setProperty: #hasHalo toValue: true]
		ifFalse:[self removeProperty: #hasHalo]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 2/22/2003 19:05'!
isLikelyRecipientForMouseOverHalos
	^self player notNil! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:05'!
mouseDownOnHelpHandle: anEvent
	"The mouse went down in the show-balloon handle"
	
	| str |
	anEvent shiftPressed ifTrue: [^ self editBalloonHelpText].
	str _ self balloonText.
	str ifNil: [str _ self noHelpString].
	self showBalloon: str hand: anEvent hand.
! !

!Morph methodsFor: 'halos and balloon help' stamp: 'em 3/24/2005 10:05'!
noHelpString
	^ 'Help not yet supplied' translated! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/15/2001 12:23'!
okayToAddDismissHandle
	"Answer whether a halo on the receiver should offer a dismiss handle.  This provides a hook for making it harder to disassemble some strucures even momentarily"

	^ self holdsSeparateDataForEachInstance not  and:
		[self resistsRemoval not]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/26/2000 12:11'!
okayToAddGrabHandle
	"Answer whether a halo on the receiver should offer a grab handle.  This provides a hook for making it harder to deconstruct some strucures even momentarily"

	^ self holdsSeparateDataForEachInstance not ! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:50'!
okayToBrownDragEasily
	"Answer whether it it okay for the receiver to be brown-dragged easily -- i.e. repositioned within its container without extracting it.  At present this is just a hook -- nobody declines."

	^ true



"
	^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and:
		[self layoutPolicy isNil]"! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 15:02'!
okayToExtractEasily
	"Answer whether it it okay for the receiver to be extracted easily.  Not yet hooked up to the halo-permissions mechanism."

	^ self topRendererOrSelf owner dragNDropEnabled! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/29/2001 06:29'!
okayToResizeEasily
	"Answer whether it is appropriate to have the receiver be easily resized by the user from the halo"

	^ true

	"This one was too jarring, not that it didn't most of the time do the right  thing but because some of the time it didn't, such as in a holder.  If we pursue this path, the test needs to be airtight, obviously...
	^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and:
		[self layoutPolicy isNil]"! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:44'!
okayToRotateEasily
	"Answer whether it is appropriate for a rotation handle to be shown for the receiver.  This is a hook -- at present nobody declines."

	^ true! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 12/31/2004 03:30'!
preferredDuplicationHandleSelector
	"Answer the selector, either #addMakeSiblingHandle: or addDupHandle:, to be offered as the default in a halo open on me"

	Preferences oliveHandleForScriptedObjects ifFalse:
		[^ #addDupHandle:].
	^ self renderedMorph valueOfProperty: #preferredDuplicationHandleSelector ifAbsent:
		[self player class isUniClass
			ifTrue:
				[#addMakeSiblingHandle:]
			ifFalse:
				[#addDupHandle:]]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 9/9/2004 22:43'!
removeHalo
	"remove the surrounding halo (if any)"
	self halo isNil
		ifFalse: [self primaryHand removeHalo]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:32'!
setBalloonText: stringOrText
	"Set receiver's balloon help text. Pass nil to remove the help."

	self setBalloonText: stringOrText maxLineLength: Preferences maxBalloonHelpLineLength! !

!Morph methodsFor: 'halos and balloon help' stamp: 'md 2/27/2006 09:54'!
setBalloonText: stringOrText maxLineLength: aLength 
	"Set receiver's balloon help text. Pass nil to remove the help."
	(extension isNil and: [stringOrText isNil]) ifTrue: [^ self].
	self assureExtension balloonText: 
		(stringOrText ifNotNil: [stringOrText asString withNoLineLongerThan: aLength])! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/29/1999 17:38'!
setCenteredBalloonText: aString
	self setBalloonText: aString.
	self setProperty: #helpAtCenter toValue: true! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:06'!
showBalloon: msgString
	"Pop up a balloon containing the given string,
	first removing any existing BalloonMorphs in the world."
	| w |
	self showBalloon: msgString hand: ((w _ self world) ifNotNil:[w activeHand]).! !

!Morph methodsFor: 'halos and balloon help' stamp: 'bf 11/1/2000 15:58'!
showBalloon: msgString hand: aHand
	"Pop up a balloon containing the given string,
	first removing any existing BalloonMorphs in the world."

	| w balloon h |
	(w _ self world) ifNil: [^ self].
	h _ aHand.
	h ifNil:[
		h _ w activeHand].
	balloon _ BalloonMorph string: msgString for: self balloonHelpAligner.
	balloon popUpFor: self hand: h.! !

!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 9/10/2004 13:59'!
transferHalo: event from: formerHaloOwner
	"Progressively transfer the halo to the next likely recipient"
	| localEvt w target |

	self flag: #workAround. "For halo's distinction between 'target' and 'innerTarget' we need to bypass any renderers."
	(formerHaloOwner == self and:[self isRenderer and:[self wantsHaloFromClick not]]) ifTrue:[
		event shiftPressed ifTrue:[
			target _ owner.
			localEvt _ event transformedBy: (self transformedFrom: owner).
		] ifFalse:[
			target _ self renderedMorph.
			localEvt _ event transformedBy: (target transformedFrom: self).
		].
		^target transferHalo: localEvt from: target].

"	formerHaloOwner == self ifTrue:[^ self removeHalo]."

	"Never transfer halo to top-most world"
	(self isWorldMorph and:[owner isNil]) ifFalse:[
		(self wantsHaloFromClick and:[formerHaloOwner ~~ self]) 
			ifTrue:[^self addHalo: event from: formerHaloOwner]].

	event shiftPressed ifTrue:[
		"Pass it outwards"
		owner ifNotNil:[^owner transferHalo: event from: formerHaloOwner].
		"We're at the top level; throw the event back in to find recipient"
		formerHaloOwner removeHalo.
		^self processEvent: event copy resetHandlerFields.
	].
	self submorphsDo:[:m|
		localEvt _ event transformedBy: (m transformedFrom: self).
		(m fullContainsPoint: localEvt position) 
			ifTrue:[^m transferHalo: event from: formerHaloOwner].
	].
	"We're at the bottom most level; throw the event back up to the root to find recipient"
	formerHaloOwner removeHalo.

	Preferences maintainHalos ifFalse:[
		(w _ self world) ifNil: [ ^self ].
		localEvt _ event transformedBy: (self transformedFrom: w) inverseTransformation.
		^w processEvent: localEvt resetHandlerFields.
	].
! !

!Morph methodsFor: 'halos and balloon help' stamp: 'rhi 10/5/2001 20:49'!
wantsBalloon
	"Answer true if receiver wants to show a balloon help text is a few moments."

	^ (self balloonText notNil) and: [Preferences balloonHelpEnabled]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:50'!
wantsDirectionHandles
	^self valueOfProperty: #wantsDirectionHandles ifAbsent:[Preferences showDirectionHandles]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:52'!
wantsDirectionHandles: aBool
	aBool == Preferences showDirectionHandles
		ifTrue:[self removeProperty: #wantsDirectionHandles]
		ifFalse:[self setProperty: #wantsDirectionHandles toValue: aBool].
! !

!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 2/22/2003 19:06'!
wantsHalo
	| topOwner |
	^(topOwner := self topRendererOrSelf owner) notNil 
		and: [topOwner wantsHaloFor: self]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 4/8/98 13:26'!
wantsHaloFor: aSubMorph
	^ false! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/25/2000 17:43'!
wantsHaloFromClick
	^ true! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:49'!
wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph
	"Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)"

	(#(addDismissHandle:) includes: aSelector) ifTrue:
		[^ self resistsRemoval not].

	(#( addDragHandle: ) includes: aSelector) ifTrue:
		[^ self okayToBrownDragEasily].

	(#(addGrowHandle: addScaleHandle:) includes: aSelector) ifTrue:
		[^ self okayToResizeEasily].

	(#( addRotateHandle: ) includes: aSelector) ifTrue:
		[^ self okayToRotateEasily].

	(#(addRecolorHandle:) includes: aSelector) ifTrue:
		[^ self renderedMorph wantsRecolorHandle].

	true ifTrue: [^ true]
	! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/9/2000 16:56'!
wantsScriptorHaloHandle
	"Answer whether the receiver would like to have a Scriptor halo handle put up on its behalf.  Initially, only the ScriptableButton says yes"

	^ false! !

!Morph methodsFor: 'halos and balloon help' stamp: 'nk 6/12/2004 09:32'!
wantsSimpleSketchMorphHandles
	"Answer true if my halo's simple handles should include the simple sketch morph handles."
	^false! !


!Morph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:00'!
basicInitialize
	"Do basic generic initialization of the instance variables:  
	Set up the receiver, created by a #basicNew and now ready to  
	be initialized, by placing initial values in the instance variables  
	as appropriate"
owner _ nil.
	submorphs _ EmptyArray.
	bounds _ self defaultBounds.
	
	color _ self defaultColor! !

!Morph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:06'!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 corner: 50 @ 40! !

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

!Morph methodsFor: 'initialization' stamp: 'fbs 1/5/2005 09:17'!
inAScrollPane
	"Answer a scroll pane that allows the user to scroll the receiver in either direction.  It will have permanent scroll bars unless you take some special action."

	| widget |
	widget _ ScrollPane new.
	widget extent: ((self width min: 300 max: 100) @ (self height min: 150 max: 100));
		borderWidth: 0.
	widget scroller addMorph: self.
	widget setScrollDeltas.
	widget color: self color darker darker.
	^ widget! !

!Morph methodsFor: 'initialization' stamp: 'sw 6/26/2001 10:56'!
inATwoWayScrollPane
	"Answer a two-way scroll pane that allows the user to scroll the receiver in either direction.  It will have permanent scroll bars unless you take some special action."

	| widget |
	widget _ TwoWayScrollPane new.
	widget extent: ((self width min: 300 max: 100) @ (self height min: 150 max: 100));
		borderWidth: 0.
	widget scroller addMorph: self.
	widget setScrollDeltas.
	widget color: self color darker darker.
	^ widget! !

!Morph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 17:30'!
initialize
	"initialize the state of the receiver"
owner _ nil.
	submorphs _ EmptyArray.
	bounds _ self defaultBounds.
	
	color _ self defaultColor! !

!Morph methodsFor: 'initialization' stamp: 'ar 1/31/2001 13:57'!
intoWorld: aWorld
	"The receiver has just appeared in a new world. Note:
		* aWorld can be nil (due to optimizations in other places)
		* owner is already set
		* owner's submorphs may not include receiver yet.
	Important: Keep this method fast - it is run whenever morphs are added."
	aWorld ifNil:[^self].
	self wantsSteps ifTrue:[aWorld startStepping: self].
	self submorphsDo:[:m| m intoWorld: aWorld].
! !

!Morph methodsFor: 'initialization' stamp: 'RAA 10/18/2000 12:33'!
openCenteredInWorld

	self 
		fullBounds;
		position: Display extent - self extent // 2;
		openInWorld.! !

!Morph methodsFor: 'initialization' stamp: 'sw 3/21/2000 14:46'!
openInHand
	"Attach the receiver to the current hand in the current morphic world"

	self currentHand attachMorph: self! !

!Morph methodsFor: 'initialization' stamp: 'jm 7/5/1998 12:40'!
openInMVC

	MorphWorldView
		openWorldWith: self
		labelled: self defaultLabelForInspector.
! !

!Morph methodsFor: 'initialization' stamp: 'djp 10/24/1999 17:13'!
openInWindow

	^self openInWindowLabeled: self defaultLabelForInspector
! !

!Morph methodsFor: 'initialization' stamp: 'sma 4/22/2000 20:28'!
openInWindowLabeled: aString

	^self openInWindowLabeled: aString inWorld: self currentWorld! !

!Morph methodsFor: 'initialization' stamp: 'RAA 5/25/2000 08:12'!
openInWindowLabeled: aString inWorld: aWorld

	| window extent |

	window _ (SystemWindow labelled: aString) model: nil.
	window 
		" guess at initial extent"
		bounds:  (RealEstateAgent initialFrameFor: window initialExtent: self fullBounds extent world: aWorld);
		addMorph: self frame: (0@0 extent: 1@1);
		updatePaneColors.
	" calculate extent after adding in case any size related attributes were changed.  Use
	fullBounds in order to trigger re-layout of layout morphs"
	extent _ self fullBounds extent + 
			(window borderWidth@window labelHeight) + window borderWidth.
	window extent: extent.
	aWorld addMorph: window.
	window activate.
	aWorld startSteppingSubmorphsOf: window.
	^window
! !

!Morph methodsFor: 'initialization' stamp: 'RAA 6/14/2000 18:09'!
openInWorld
        "Add this morph to the world.  If in MVC, then provide a Morphic window for it."

        self couldOpenInMorphic
                ifTrue: [self openInWorld: self currentWorld]
                ifFalse: [self openInMVC]! !

!Morph methodsFor: 'initialization' stamp: 'dgd 9/1/2004 16:12'!
openInWorld: aWorld
	"Add this morph to the requested World."
	(aWorld visibleClearArea origin ~= (0@0) and: [self position = (0@0)]) ifTrue:
		[self position: aWorld visibleClearArea origin].
	aWorld addMorph: self.
	aWorld startSteppingSubmorphsOf: self! !

!Morph methodsFor: 'initialization' stamp: 'ar 1/31/2001 13:58'!
outOfWorld: aWorld
	"The receiver has just appeared in a new world. Notes:
		* aWorld can be nil (due to optimizations in other places)
		* owner is still valid
	Important: Keep this method fast - it is run whenever morphs are removed."
	aWorld ifNil:[^self].
	"ar 1/31/2001: We could explicitly stop stepping the receiver here but for the sake of speed I'm for now relying on the lazy machinery in the world itself."
	"aWorld stopStepping: self."
	self submorphsDo:[:m| m outOfWorld: aWorld].
! !

!Morph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:28'!
resourceJustLoaded
	"In case resource relates to me"
	self releaseCachedState.! !

!Morph methodsFor: 'initialization' stamp: 'sw 9/11/1998 11:13'!
standardPalette
	"Answer a standard palette forced by some level of enclosing presenter, or nil if none"
	| pal aPresenter itsOwner |
	(aPresenter _ self presenter) ifNil: [^ nil].
	^ (pal _ aPresenter ownStandardPalette)
		ifNotNil: [pal]
		ifNil:	[(itsOwner _ aPresenter associatedMorph owner)
					ifNotNil:
						[itsOwner standardPalette]
					ifNil:
						[nil]]! !


!Morph methodsFor: 'latter day support' stamp: 'sw 1/6/2005 01:26'!
isEtoyReadout
	"Answer whether the receiver can serve as an etoy readout"

	^ false! !


!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:33'!
acceptDroppingMorph: aMorph event: evt
	"This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. This default implementation just adds the given morph to the receiver."
	| layout |
	layout _ self layoutPolicy.
	layout ifNil:[^self addMorph: aMorph].
	self privateAddMorph: aMorph 
		atIndex: (layout indexForInserting: aMorph at: evt position in: self).! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:34'!
adjustLayoutBounds
	"Adjust the receivers bounds depending on the resizing strategy imposed"
	| hFit vFit box myExtent extent |
	hFit _ self hResizing.
	vFit _ self vResizing.
	(hFit == #shrinkWrap or:[vFit == #shrinkWrap]) ifFalse:[^self]. "not needed"
	box _ self layoutBounds.
	myExtent _ box extent.
	extent _ self submorphBounds corner - box origin.
	hFit == #shrinkWrap ifTrue:[myExtent _ extent x @ myExtent y].
	vFit == #shrinkWrap ifTrue:[myExtent _ myExtent x @ extent y].
	"Make sure we don't get smaller than minWidth/minHeight"
	myExtent x < self minWidth ifTrue:[
		myExtent _ (myExtent x max: 
			(self minWidth - self bounds width + self layoutBounds width)) @ myExtent y].
	myExtent y < self minHeight ifTrue:[
		myExtent _ myExtent x @ (myExtent y max:
			(self minHeight - self bounds height + self layoutBounds height))].
	self layoutBounds: (box origin extent: myExtent).! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:31'!
doLayoutIn: layoutBounds 
	"Compute a new layout based on the given layout bounds."

	"Note: Testing for #bounds or #layoutBounds would be sufficient to
	figure out if we need an invalidation afterwards but #outerBounds
	is what we need for all leaf nodes so we use that."

	| layout box priorBounds |
	priorBounds := self outerBounds.
	submorphs isEmpty ifTrue: [^fullBounds := priorBounds].
	"Send #ownerChanged to our children"
	submorphs do: [:m | m ownerChanged].
	layout := self layoutPolicy.
	layout ifNotNil: [layout layout: self in: layoutBounds].
	self adjustLayoutBounds.
	fullBounds := self privateFullBounds.
	box := self outerBounds.
	box = priorBounds 
		ifFalse: [self invalidRect: (priorBounds quickMerge: box)]! !

!Morph methodsFor: 'layout' stamp: 'ar 1/1/2002 20:00'!
fullBounds
	"Return the bounding box of the receiver and all its children. Recompute the layout if necessary."
	fullBounds ifNotNil:[^fullBounds].
	"Errors at this point can be critical so make sure we catch 'em all right"
	[self doLayoutIn: self layoutBounds] on: Error do:[:ex|
		"This should do it unless you don't screw up the bounds"
		fullBounds _ bounds.
		ex pass].
	^fullBounds! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 23:10'!
layoutBounds
	"Return the bounds for laying out children of the receiver"
	| inset box |
	inset _ self layoutInset.
	box _ self innerBounds.
	inset isZero ifTrue:[^box].
	^box insetBy: inset.! !

!Morph methodsFor: 'layout' stamp: 'ar 10/31/2000 21:09'!
layoutBounds: aRectangle
	"Set the bounds for laying out children of the receiver.
	Note: written so that #layoutBounds can be changed without touching this method"
	| outer inner |
	outer _ self bounds.
	inner _ self layoutBounds.
	bounds _ aRectangle origin + (outer origin - inner origin) corner:
				aRectangle corner + (outer corner - inner corner).! !

!Morph methodsFor: 'layout' stamp: 'ar 1/27/2001 14:41'!
layoutChanged
	| layout |
	fullBounds ifNil:[^self]. "layout will be recomputed so don't bother"
	fullBounds _ nil.
	layout _ self layoutPolicy.
	layout ifNotNil:[layout flushLayoutCache].
	owner ifNotNil: [owner layoutChanged].
	"note: does not send #ownerChanged here - we'll do this when computing the new layout"! !

!Morph methodsFor: 'layout' stamp: 'ar 8/6/2001 09:55'!
layoutInBounds: cellBounds
	"Layout specific. Apply the given bounds to the receiver after being layed out in its owner."
	| box aSymbol delta |
	fullBounds ifNil:["We are getting new bounds here but we haven't computed the receiver's layout yet. Although the receiver has reported its minimal size before the actual size it has may differ from what would be after the layout. Normally, this isn't a real problem, but if we have #shrinkWrap constraints then the receiver's bounds may be larger than the cellBounds. THAT is a problem because the centering may not work correctly if the receiver shrinks after the owner layout has been computed. To avoid this problem, we compute the receiver's layout now. Note that the layout computation is based on the new cell bounds rather than the receiver's current bounds."
		cellBounds origin = self bounds origin ifFalse:[
			box _ self outerBounds.
			delta _ cellBounds origin - self bounds origin.
			self invalidRect: (box merge: (box translateBy: delta)).
			self privateFullMoveBy: delta]. "sigh..."
		box _ cellBounds origin extent: "adjust for #rigid receiver"
			(self hResizing == #rigid ifTrue:[self bounds extent x] ifFalse:[cellBounds extent x]) @
			(self vResizing == #rigid ifTrue:[self bounds extent y] ifFalse:[cellBounds extent y]).
		"Compute inset of layout bounds"
		box _ box origin - (self bounds origin - self layoutBounds origin) corner:
					box corner - (self bounds corner - self layoutBounds corner).
		"And do the layout within the new bounds"
		self layoutBounds: box.
		self doLayoutIn: box].
	cellBounds = self fullBounds ifTrue:[^self]. "already up to date"
	cellBounds extent = self fullBounds extent "nice fit"
		ifTrue:[^self position: cellBounds origin].
	box _ bounds.
	"match #spaceFill constraints"
	self hResizing == #spaceFill 
		ifTrue:[box _ box origin extent: cellBounds width @ box height].
	self vResizing == #spaceFill
		ifTrue:[box _ box origin extent: box width @ cellBounds height].
	"align accordingly"
	aSymbol _ (owner ifNil:[self]) cellPositioning.
	box _ box align: (box perform: aSymbol) with: (cellBounds perform: aSymbol).
	"and install new bounds"
	self bounds: box.! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:35'!
layoutProportionallyIn: newBounds
	"Layout specific. Apply the given bounds to the receiver."
	| box frame |
	frame _ self layoutFrame ifNil:[^self].
	"before applying the proportional values make sure the receiver's layout is computed"
	self fullBounds. "sigh..."
	"compute the cell size the receiver has given its layout frame"
	box _ frame layout: self bounds in: newBounds.
	(box = self bounds) ifTrue:[^self]. "no change"
	^self layoutInBounds: box.! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'!
minExtent
	"Layout specific. Return the minimum size the receiver can be represented in.
	Implementation note: When this message is sent from an owner trying to lay out its children it will traverse down the morph tree and recompute the minimal arrangement of the morphs based on which the minimal extent is returned. When a morph with some layout strategy is encountered, the morph will ask its strategy to compute the new arrangement. However, since the final size given to the receiver is unknown at the point of the query, the assumption is made that the current bounds of the receiver are the base on which the layout should be computed. This scheme prevents strange layout changes when for instance, a table is contained in another table. Unless the inner table has been resized manually (which means its bounds are already enlarged) the arrangement of the inner table will not change here. Thus the entire layout computation is basically an iterative process which may have different results depending on the incremental changes applied."

	| layout minExtent extra hFit vFit |
	hFit := self hResizing.
	vFit := self vResizing.
	(hFit == #spaceFill or: [vFit == #spaceFill]) 
		ifFalse: 
			["The receiver will not adjust to parents layout by growing or shrinking,
		which means that an accurate layout defines the minimum size."

			^self fullBounds extent].

	"An exception -- a receiver with #shrinkWrap constraints but no children is being treated #rigid (the equivalent to a #spaceFill receiver in a non-layouting owner)"
	self hasSubmorphs 
		ifFalse: 
			[hFit == #shrinkWrap ifTrue: [hFit := #rigid].
			vFit == #shrinkWrap ifTrue: [vFit := #rigid]].
	layout := self layoutPolicy.
	layout isNil 
		ifTrue: [minExtent := 0 @ 0]
		ifFalse: [minExtent := layout minExtentOf: self in: self layoutBounds].
	hFit == #rigid 
		ifTrue: [minExtent := self fullBounds extent x @ minExtent y]
		ifFalse: 
			[extra := self bounds width - self layoutBounds width.
			minExtent := (minExtent x + extra) @ minExtent y].
	minExtent := vFit == #rigid 
				ifTrue: [minExtent x @ self fullBounds extent y]
				ifFalse: 
					[extra := self bounds height - self layoutBounds height.
					minExtent x @ (minExtent y + extra)].
	minExtent := minExtent max: self minWidth @ self minHeight.
	^minExtent! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:52'!
minHeight
	"answer the receiver's minHeight"
	^ self
		valueOfProperty: #minHeight
		ifAbsent: [2]! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'!
minHeight: aNumber 
	aNumber isNil 
		ifTrue: [self removeProperty: #minHeight]
		ifFalse: [self setProperty: #minHeight toValue: aNumber].
	self layoutChanged! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:54'!
minWidth
	"answer the receiver's minWidth"
	^ self
		valueOfProperty: #minWidth
		ifAbsent: [2]! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'!
minWidth: aNumber 
	aNumber isNil 
		ifTrue: [self removeProperty: #minWidth]
		ifFalse: [self setProperty: #minWidth toValue: aNumber].
	self layoutChanged! !

!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:33'!
privateFullBounds
	"Private. Compute the actual full bounds of the receiver"

	| box |
	submorphs isEmpty ifTrue: [^self outerBounds].
	box := self outerBounds copy.
	box := box quickMerge: (self clipSubmorphs 
						ifTrue: [self submorphBounds intersect: self clippingBounds]
						ifFalse: [self submorphBounds]).
	^box origin asIntegerPoint corner: box corner asIntegerPoint! !

!Morph methodsFor: 'layout' stamp: 'ar 11/2/2000 17:42'!
submorphBounds
	"Private. Compute the actual full bounds of the receiver"
	| box subBox |
	submorphs do: [:m | 
		(m visible) ifTrue: [
			subBox _ m fullBounds.
			box 
				ifNil:[box _ subBox copy]
				ifNotNil:[box _ box quickMerge: subBox]]].
	box ifNil:[^self bounds]. "e.g., having submorphs but not visible"
	^ box origin asIntegerPoint corner: box corner asIntegerPoint
! !


!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:57'!
addCellLayoutMenuItems: aMenu hand: aHand
	"Cell (e.g., child) related items"
	| menu sub |
	menu _ MenuMorph new defaultTarget: self.
		menu addUpdating: #hasDisableTableLayoutString action: #changeDisableTableLayout.
		menu addLine.

		sub _ MenuMorph new defaultTarget: self.
		#(rigid shrinkWrap spaceFill) do:[:sym|
			sub addUpdating: #hResizingString: target: self selector: #hResizing: argumentList: (Array with: sym)].
		menu add:'horizontal resizing' translated subMenu: sub.

		sub _ MenuMorph new defaultTarget: self.
		#(rigid shrinkWrap spaceFill) do:[:sym|
			sub addUpdating: #vResizingString: target: self selector: #vResizing: argumentList: (Array with: sym)].
		menu add:'vertical resizing' translated subMenu: sub.

	aMenu ifNotNil:[aMenu add: 'child layout' translated subMenu: menu].
	^menu! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:51'!
addLayoutMenuItems: topMenu hand: aHand
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addUpdating: #hasNoLayoutString action: #changeNoLayout.
	aMenu addUpdating: #hasProportionalLayoutString action: #changeProportionalLayout.
	aMenu addUpdating: #hasTableLayoutString action: #changeTableLayout.
	aMenu addLine.
	aMenu add: 'change layout inset...' translated action: #changeLayoutInset:.
	aMenu addLine.
	self addCellLayoutMenuItems: aMenu hand: aHand.
	self addTableLayoutMenuItems: aMenu hand: aHand.
	topMenu ifNotNil:[topMenu add: 'layout' translated subMenu: aMenu].
	^aMenu! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:07'!
addTableLayoutMenuItems: aMenu hand: aHand
	| menu sub |
	menu _ MenuMorph new defaultTarget: self.
	menu addUpdating: #hasReverseCellsString action: #changeReverseCells.
	menu addUpdating: #hasClipLayoutCellsString action: #changeClipLayoutCells.
	menu addUpdating: #hasRubberBandCellsString action: #changeRubberBandCells.
	menu addLine.
	menu add: 'change cell inset...' translated action: #changeCellInset:.
	menu add: 'change min cell size...' translated action: #changeMinCellSize:.
	menu add: 'change max cell size...' translated action: #changeMaxCellSize:.
	menu addLine.

	sub _ MenuMorph new defaultTarget: self.
	#(leftToRight rightToLeft topToBottom bottomToTop) do:[:sym|
		sub addUpdating: #listDirectionString: target: self selector: #changeListDirection: argumentList: (Array with: sym)].
	menu add: 'list direction' translated subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(none leftToRight rightToLeft topToBottom bottomToTop) do:[:sym|
		sub addUpdating: #wrapDirectionString: target: self selector: #wrapDirection: argumentList: (Array with: sym)].
	menu add: 'wrap direction' translated subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(center topLeft topRight bottomLeft bottomRight topCenter leftCenter rightCenter bottomCenter) do:[:sym|
		sub addUpdating: #cellPositioningString: target: self selector: #cellPositioning: argumentList: (Array with: sym)].
	menu add: 'cell positioning' translated subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(topLeft bottomRight center justified) do:[:sym|
		sub addUpdating: #listCenteringString: target: self selector: #listCentering: argumentList: (Array with: sym)].
	menu add: 'list centering' translated subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(topLeft bottomRight center justified) do:[:sym|
		sub addUpdating: #wrapCenteringString: target: self selector: #wrapCentering: argumentList: (Array with: sym)].
	menu add: 'wrap centering' translated subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(none equal) do:[:sym|
		sub addUpdating: #listSpacingString: target: self selector: #listSpacing: argumentList: (Array with: sym)].
	menu add: 'list spacing' translated subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(none localRect localSquare globalRect globalSquare) do:[:sym|
		sub addUpdating: #cellSpacingString: target: self selector: #cellSpacing: argumentList: (Array with: sym)].
	menu add: 'cell spacing' translated subMenu: sub.

	aMenu ifNotNil:[aMenu add: 'table layout' translated subMenu: menu].
	^menu! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:08'!
changeCellInset: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:[:newPoint |
		self cellInset: (newPoint - evt cursorPoint) asIntegerPoint // 5].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 18:54'!
changeClipLayoutCells
	self invalidRect: self fullBounds.
	self clipLayoutCells: self clipLayoutCells not.
	self invalidRect: self fullBounds.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'!
changeDisableTableLayout
	self disableTableLayout: self disableTableLayout not.
	self layoutChanged.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:09'!
changeLayoutInset: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:[:newPoint |
		self layoutInset: (newPoint - evt cursorPoint) asIntegerPoint // 5].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeListDirection: aSymbol
	| listDir wrapDir |
	self listDirection: aSymbol.
	(self wrapDirection == #none) ifTrue:[^self].
	"otherwise automatically keep a valid table layout"
	listDir _ self listDirection.
	wrapDir _ self wrapDirection.
	(listDir == #leftToRight or:[listDir == #rightToLeft]) ifTrue:[
		wrapDir == #leftToRight ifTrue:[^self wrapDirection: #topToBottom].
		wrapDir == #rightToLeft ifTrue:[^self wrapDirection: #bottomToTop].
	] ifFalse:[
		wrapDir == #topToBottom ifTrue:[^self wrapDirection: #leftToRight].
		wrapDir == #bottomToTop ifTrue:[^self wrapDirection: #rightToLeft].
	].
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeMaxCellSize: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:[:newPoint |
		self maxCellSize: (newPoint - evt cursorPoint) asIntegerPoint].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeMinCellSize: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:[:newPoint |
		self minCellSize: (newPoint - evt cursorPoint) asIntegerPoint].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'!
changeNoLayout
	self layoutPolicy ifNil:[^self]. "already no layout"
	self layoutPolicy: nil.
	self layoutChanged.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'!
changeProportionalLayout
	| layout |
	((layout _ self layoutPolicy) notNil and:[layout isProportionalLayout])
		ifTrue:[^self]. "already proportional layout"
	self layoutPolicy: ProportionalLayout new.
	self layoutChanged.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeReverseCells
	self reverseTableCells: self reverseTableCells not.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeRubberBandCells
	self rubberBandCells: self rubberBandCells not.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:20'!
changeTableLayout
	| layout |
	((layout _ self layoutPolicy) notNil and:[layout isTableLayout])
		ifTrue:[^self]. "already table layout"
	self layoutPolicy: TableLayout new.
	self layoutChanged.! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:09'!
hasClipLayoutCellsString
	^ (self clipLayoutCells
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'clip to cell size' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:58'!
hasDisableTableLayoutString
	^ (self disableTableLayout
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'disable layout in tables' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 10/8/2003 19:23'!
hasNoLayoutString
	^ (self layoutPolicy isNil
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'no layout' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:55'!
hasProportionalLayoutString
	| layout |
	^ (((layout := self layoutPolicy) notNil
			and: [layout isProportionalLayout])
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'proportional layout' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:08'!
hasReverseCellsString
	^ (self reverseTableCells
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'reverse table cells' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:09'!
hasRubberBandCellsString
	^ (self rubberBandCells
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'rubber band cells' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:59'!
hasTableLayoutString
	| layout |
	^ (((layout := self layoutPolicy) notNil
			and: [layout isTableLayout])
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'table layout' translated! !

!Morph methodsFor: 'layout-menu' stamp: 'dgd 10/19/2003 11:23'!
layoutMenuPropertyString: aSymbol from: currentSetting 
	| onOff wording |
	onOff := aSymbol == currentSetting
				ifTrue: ['<on>']
				ifFalse: ['<off>'].
	""
	wording := String
				streamContents: [:stream | 
					| index | 
					index := 1.
					aSymbol
						keysAndValuesDo: [:idx :ch | ch isUppercase
								ifTrue: [""stream nextPutAll: (aSymbol copyFrom: index to: idx - 1) asLowercase.
									stream nextPutAll: ' '.
									index := idx]].
					index < aSymbol size
						ifTrue: [stream nextPutAll: (aSymbol copyFrom: index to: aSymbol size) asLowercase]].
	""
	^ onOff , wording translated! !


!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:56'!
assureLayoutProperties
	| props |
	props _ self layoutProperties.
	props == self ifTrue:[props _ nil].
	props ifNil:[
		props _ LayoutProperties new initializeFrom: self.
		self layoutProperties: props].
	^props! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:57'!
assureTableProperties
	| props |
	props _ self layoutProperties.
	props == self ifTrue:[props _ nil].
	props ifNil:[
		props _ TableLayoutProperties new initializeFrom: self.
		self layoutProperties: props].
	props includesTableProperties 
		ifFalse:[self layoutProperties: (props _ props asTableLayoutProperties)].
	^props! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'!
cellInset
	"Layout specific. This property specifies an extra inset for each cell in the layout."
	| props |
	props _ self layoutProperties.
	^props ifNil:[0] ifNotNil:[props cellInset].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'!
cellInset: aNumber
	"Layout specific. This property specifies an extra inset for each cell in the layout."
	self assureTableProperties cellInset: aNumber.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'!
cellPositioning
	"Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are:
		#topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center 
	which align the receiver's bounds with the cell at the given point."
	| props |
	props _ self layoutProperties.
	^props ifNil:[#center] ifNotNil:[props cellPositioning].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:48'!
cellPositioningString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self cellPositioning! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:39'!
cellPositioning: aSymbol
	"Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are:
		#topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center 
	which align the receiver's bounds with the cell at the given point."
	self assureTableProperties cellPositioning: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:55'!
cellSpacing
	"Layout specific. This property describes how the cell size for each element in a list should be computed.
		#globalRect - globally equal rectangular cells
		#globalSquare - globally equal square cells
		#localRect - locally (e.g., per row/column) equal rectangular cells
		#localSquare - locally (e.g., per row/column) equal square cells
		#none - cells are sized based on available row/column constraints
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#none] ifNotNil:[props cellSpacing].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'!
cellSpacingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self cellSpacing! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:56'!
cellSpacing: aSymbol
	"Layout specific. This property describes how the cell size for each element in a list should be computed.
		#globalRect - globally equal rectangular cells
		#globalSquare - globally equal square cells
		#localRect - locally (e.g., per row/column) equal rectangular cells
		#localSquare - locally (e.g., per row/column) equal square cells
		#none - cells are sized based on available row/column constraints
	"
	self assureTableProperties cellSpacing: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:56'!
disableTableLayout
	"Layout specific. Disable laying out the receiver in table layout"
	| props |
	props _ self layoutProperties.
	^props ifNil:[false] ifNotNil:[props disableTableLayout].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'!
disableTableLayout: aBool
	"Layout specific. Disable laying out the receiver in table layout"
	self assureLayoutProperties disableTableLayout: aBool.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:57'!
hResizing
	"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
		#rigid			-	do not resize the receiver
		#spaceFill		-	resize to fill owner's available space
		#shrinkWrap	- resize to fit children
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#rigid] ifNotNil:[props hResizing].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/31/2000 20:45'!
hResizingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self hResizing! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'!
hResizing: aSymbol
	"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
		#rigid			-	do not resize the receiver
		#spaceFill		-	resize to fill owner's available space
		#shrinkWrap	- resize to fit children
	"
	self assureLayoutProperties hResizing: aSymbol.
	self layoutChanged.
! !

!Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 09:59'!
layoutFrame
	"Layout specific. Return the layout frame describing where the  
	receiver should appear in a proportional layout"
	^ extension ifNotNil: [extension layoutFrame]! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:20'!
layoutFrame: aLayoutFrame
	"Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout"
	self layoutFrame == aLayoutFrame ifTrue:[^self].
	self assureExtension layoutFrame: aLayoutFrame.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 16:38'!
layoutInset
	"Return the extra inset for layouts"
	| props |
	props _ self layoutProperties.
	^props ifNil:[0] ifNotNil:[props layoutInset].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 16:38'!
layoutInset: aNumber
	"Return the extra inset for layouts"
	self assureTableProperties layoutInset: aNumber.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 10:00'!
layoutPolicy
	"Layout specific. Return the layout policy describing how children 
	of the receiver should appear."
	^ extension ifNotNil: [ extension layoutPolicy]! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:21'!
layoutPolicy: aLayoutPolicy
	"Layout specific. Return the layout policy describing how children of the receiver should appear."
	self layoutPolicy == aLayoutPolicy ifTrue:[^self].
	self assureExtension layoutPolicy: aLayoutPolicy.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 09:58'!
layoutProperties
	"Return the current layout properties associated with the  
	receiver"
	^ extension ifNotNil: [ extension layoutProperties]! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:21'!
layoutProperties: newProperties
	"Return the current layout properties associated with the receiver"
	self layoutProperties == newProperties ifTrue:[^self].
	self assureExtension layoutProperties: newProperties.
! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:58'!
listCentering
	"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
		#topLeft - center at start of primary direction
		#bottomRight - center at end of primary direction
		#center - center in the middle of primary direction
		#justified - insert extra space inbetween rows/columns
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#topLeft] ifNotNil:[props listCentering].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'!
listCenteringString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listCentering! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:05'!
listCentering: aSymbol
	"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
		#topLeft - center at start of primary direction
		#bottomRight - center at end of primary direction
		#center - center in the middle of primary direction
		#justified - insert extra space inbetween rows/columns
	"
	self assureTableProperties listCentering: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'!
listDirection
	"Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are:
		#leftToRight
		#rightToLeft
		#topToBottom
		#bottomToTop
	indicating the direction in which any layout should take place"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#topToBottom] ifNotNil:[props listDirection].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'!
listDirectionString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listDirection! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
listDirection: aSymbol
	"Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are:
		#leftToRight
		#rightToLeft
		#topToBottom
		#bottomToTop
	indicating the direction in which any layout should take place"
	self assureTableProperties listDirection: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'!
listSpacing
	"Layout specific. This property describes how the heights for different rows in a table layout should be handled.
		#equal - all rows have the same height
		#none - all rows may have different heights
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#none] ifNotNil:[props listSpacing].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'!
listSpacingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listSpacing! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
listSpacing: aSymbol
	"Layout specific. This property describes how the heights for different rows in a table layout should be handled.
		#equal - all rows have the same height
		#none - all rows may have different heights
	"
	self assureTableProperties listSpacing: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'!
maxCellSize
	"Layout specific. This property specifies the maximum size of a table cell."
	| props |
	props _ self layoutProperties.
	^props ifNil:[SmallInteger maxVal] ifNotNil:[props maxCellSize].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
maxCellSize: aPoint
	"Layout specific. This property specifies the maximum size of a table cell."
	self assureTableProperties maxCellSize: aPoint.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:00'!
minCellSize
	"Layout specific. This property specifies the minimal size of a table cell."
	| props |
	props _ self layoutProperties.
	^props ifNil:[0] ifNotNil:[props minCellSize].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
minCellSize: aPoint
	"Layout specific. This property specifies the minimal size of a table cell."
	self assureTableProperties minCellSize: aPoint.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:01'!
reverseTableCells
	"Layout specific. This property describes if the cells should be treated in reverse order of submorphs."
	| props |
	props _ self layoutProperties.
	^props ifNil:[false] ifNotNil:[props reverseTableCells].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
reverseTableCells: aBool
	"Layout specific. This property describes if the cells should be treated in reverse order of submorphs."
	self assureTableProperties reverseTableCells: aBool.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:01'!
rubberBandCells
	"Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow."
	| props |
	props _ self layoutProperties.
	^props ifNil:[false] ifNotNil:[props rubberBandCells].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
rubberBandCells: aBool
	"Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow."
	self assureTableProperties rubberBandCells: aBool.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:02'!
spaceFillWeight
	"Layout specific. This property describes the relative weight that 
	should be given to the receiver when extra space is distributed 
	between different #spaceFill cells."

	^ self
		valueOfProperty: #spaceFillWeight
		ifAbsent: [1]! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/15/2000 14:16'!
spaceFillWeight: aNumber
	"Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells."
	aNumber = 1
		ifTrue:[self removeProperty: #spaceFillWeight]
		ifFalse:[self setProperty: #spaceFillWeight toValue: aNumber].
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'tk 10/30/2001 18:39'!
vResizeToFit: aBoolean
	aBoolean ifTrue:[
		self vResizing: #shrinkWrap.
	] ifFalse:[
		self vResizing: #rigid.
	].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'!
vResizing
	"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
		#rigid			-	do not resize the receiver
		#spaceFill		-	resize to fill owner's available space
		#shrinkWrap	- resize to fit children
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#rigid] ifNotNil:[props vResizing].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/31/2000 20:45'!
vResizingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self vResizing! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'!
vResizing: aSymbol
	"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
		#rigid			-	do not resize the receiver
		#spaceFill		-	resize to fill owner's available space
		#shrinkWrap	- resize to fit children
	"
	self assureLayoutProperties vResizing: aSymbol.
	self layoutChanged.
! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'!
wrapCentering
	"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
		#topLeft - center at start of secondary direction
		#bottomRight - center at end of secondary direction
		#center - center in the middle of secondary direction
		#justified - insert extra space inbetween rows/columns
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#topLeft] ifNotNil:[props wrapCentering].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 03:00'!
wrapCenteringString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self wrapCentering! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'!
wrapCentering: aSymbol
	"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
		#topLeft - center at start of secondary direction
		#bottomRight - center at end of secondary direction
		#center - center in the middle of secondary direction
		#justified - insert extra space inbetween rows/columns
	"
	self assureTableProperties wrapCentering: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'!
wrapDirection
	"Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are:
		#leftToRight
		#rightToLeft
		#topToBottom
		#bottomToTop
		#none
	indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa."
	| props |
	props _ self layoutProperties.
	^props ifNil:[#none] ifNotNil:[props wrapDirection].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 03:00'!
wrapDirectionString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self wrapDirection ! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'!
wrapDirection: aSymbol
	"Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are:
		#leftToRight
		#rightToLeft
		#topToBottom
		#bottomToTop
		#none
	indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa."
	self assureTableProperties wrapDirection: aSymbol.
	self layoutChanged.
! !


!Morph methodsFor: 'macpal' stamp: 'sw 5/17/2001 17:57'!
currentVocabulary
	"Answer the receiver's current vocabulary"

	| outer |
	^ (outer _ self ownerThatIsA: StandardViewer orA: ScriptEditorMorph) 
			ifNotNil:
				[outer currentVocabulary]
			ifNil:
				[super currentVocabulary]! !

!Morph methodsFor: 'macpal' stamp: 'sw 10/10/1999 10:23'!
flash
	| c w |
	c _ self color.
	self color: Color black.
	(w _ self world) ifNotNil: [w displayWorldSafely].
	self color: c
! !

!Morph methodsFor: 'macpal' stamp: 'sw 7/20/1999 08:13'!
scriptPerformer
	^ self topRendererOrSelf player ifNil: [self]! !


!Morph methodsFor: 'menu' stamp: 'sw 11/27/2001 15:21'!
addBorderStyleMenuItems: aMenu hand: aHandMorph
	"Probably one could offer border-style items even if it's not a borderedMorph, so this remains a loose end for the moment"
! !

!Morph methodsFor: 'menu' stamp: 'nk 2/15/2004 09:08'!
addGestureMenuItems: aMenu hand: aHandMorph
	"If the receiver wishes the Genie menu items, add a line to the menu and then those Genie items, else do nothing"! !

!Morph methodsFor: 'menu' stamp: 'nk 6/15/2004 07:11'!
addGraphModelYellowButtonItemsTo: aCustomMenu event: evt
	^aCustomMenu! !

!Morph methodsFor: 'menu' stamp: 'dgd 9/18/2004 17:47'!
addModelYellowButtonItemsTo: aCustomMenu event: evt 
	"Give my models a chance to add their context-menu items to  
	aCustomMenu."
	self model
		ifNotNilDo: [:mod |
			mod
				addModelYellowButtonMenuItemsTo: aCustomMenu
				forMorph: self
				hand: evt hand]! !

!Morph methodsFor: 'menu' stamp: 'nk 3/10/2004 19:49'!
addMyYellowButtonMenuItemsToSubmorphMenus
	"Answer true if I have items to add to the context menus of my submorphs"

	^true! !

!Morph methodsFor: 'menu' stamp: 'dgd 9/13/2004 19:23'!
addNestedYellowButtonItemsTo: aMenu event: evt 
	"Add items to aMenu starting with me and proceeding down 
	through my submorph chain, 
	letting any submorphs that include the event position 
	contribute their items to the bottom of the menu, separated by 
	a line."
	| underMouse |

	self addYellowButtonMenuItemsTo: aMenu event: evt.

	underMouse := self
				submorphThat: [:each | each containsPoint: evt position]
				ifNone: [^ self].

	(underMouse addMyYellowButtonMenuItemsToSubmorphMenus
			and: [underMouse hasYellowButtonMenu])
		ifTrue: [| submenu |
			aMenu addLine.
			submenu := MenuMorph new defaultTarget: underMouse.
			underMouse addNestedYellowButtonItemsTo: submenu event: evt.
			aMenu
				add: underMouse externalName
				icon: (underMouse iconOrThumbnailOfSize: 16)
				subMenu: submenu
		]
! !

!Morph methodsFor: 'menu' stamp: 'dgd 7/28/2005 13:02'!
addTitleForHaloMenu: aMenu 
	aMenu
		addTitle: self externalName
		icon: (self iconOrThumbnailOfSize: (Preferences tinyDisplay ifFalse:[28] ifTrue:[16]))! !

!Morph methodsFor: 'menu' stamp: 'dgd 10/13/2004 13:47'!
addYellowButtonMenuItemsTo: aMenu event: evt 
	"Populate aMenu with appropriate menu items for a  
	yellow-button (context menu) click."
	aMenu defaultTarget: self.
	""
	Preferences noviceMode
		ifFalse: [aMenu addStayUpItem].
	""
	self addModelYellowButtonItemsTo: aMenu event: evt.
	""
	Preferences generalizedYellowButtonMenu
		ifFalse: [^ self].
	""
	Preferences cmdGesturesEnabled
		ifTrue: [""
			aMenu addLine.
			aMenu add: 'inspect' translated action: #inspect].
	""
	aMenu addLine.
	self world selectedObject == self
		ifTrue: [aMenu add: 'deselect' translated action: #removeHalo]
		ifFalse: [aMenu add: 'select' translated action: #addHalo].
	""
	(self isWorldMorph
			or: [self mustBeBackmost]
			or: [self wantsToBeTopmost])
		ifFalse: [""
			aMenu addLine.
			aMenu add: 'send to back' translated action: #goBehind.
			aMenu add: 'bring to front' translated action: #comeToFront.
			self addEmbeddingMenuItemsTo: aMenu hand: evt hand].
	""
	self isWorldMorph
		ifFalse: [""
	Smalltalk
		at: #NCAAConnectorMorph
		ifPresent: [:connectorClass | 
			aMenu addLine.
			aMenu add: 'connect to' translated action: #startWiring.
			aMenu addLine].
	""

			self isFullOnScreen
				ifFalse: [aMenu add: 'move onscreen' translated action: #goHome]].
	""
	Preferences noviceMode
		ifFalse: [""
			self addLayoutMenuItems: aMenu hand: evt hand.
			(owner notNil
					and: [owner isTextMorph])
				ifTrue: [self addTextAnchorMenuItems: aMenu hand: evt hand]].
	""
	self isWorldMorph
		ifFalse: [""
			aMenu addLine.
			self addToggleItemsToHaloMenu: aMenu].
	""
	aMenu addLine.
	self isWorldMorph
		ifFalse: [aMenu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:].
	(self allStringsAfter: nil) isEmpty
		ifFalse: [aMenu add: 'copy text' translated action: #clipText].
	""
	self addExportMenuItems: aMenu hand: evt hand.
	""
	(Preferences noviceMode not
			and: [self isWorldMorph not])
		ifTrue: [""
			aMenu addLine.
			aMenu add: 'adhere to edge...' translated action: #adhereToEdge].
	""
	self addCustomMenuItems: aMenu hand: evt hand! !

!Morph methodsFor: 'menu' stamp: 'dgd 9/18/2004 17:23'!
buildYellowButtonMenu: aHand 
	"build the morph menu for the yellow button"
	| menu |
	menu := MenuMorph new defaultTarget: self.
	self addNestedYellowButtonItemsTo: menu event: ActiveEvent.
	MenuIcons decorateMenu: menu.
	^ menu! !

!Morph methodsFor: 'menu' stamp: 'dgd 4/4/2006 14:43'!
hasYellowButtonMenu
	"Answer true if I have any items at all for a context (yellow  
	button) menu."
	^ self wantsYellowButtonMenu
			or: [self models anySatisfy: [:each | each hasModelYellowButtonMenuItems]]! !

!Morph methodsFor: 'menu' stamp: 'tak 7/17/2004 18:20'!
offerCostumeViewerMenu: aMenu
	"do nothing"! !

!Morph methodsFor: 'menu' stamp: 'nk 3/10/2004 19:51'!
outermostOwnerWithYellowButtonMenu
	"Answer me or my outermost owner that is willing to contribute menu items to a context menu.
	Don't include the world."

	| outermost |
	outermost _ self outermostMorphThat: [ :ea |
		ea isWorldMorph not and: [ ea hasYellowButtonMenu ]].
	^outermost ifNil: [ self hasYellowButtonMenu ifTrue: [ self ] ifFalse: []] ! !

!Morph methodsFor: 'menu' stamp: 'dgd 9/29/2004 13:26'!
startWiring
	Smalltalk
		at: #NCAAConnectorMorph
		ifPresent: [:connectorClass | connectorClass newCurvyArrow startWiringFrom: self] ! !

!Morph methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:20'!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	self
		valueOfProperty: #wantsYellowButtonMenu
		ifPresentDo: [:value | ^ value].
	""
	self isInSystemWindow
		ifTrue: [^ false].""
	(Preferences noviceMode
			and: [self isInDockingBar])
		ifTrue: [^ false].""
	^ Preferences generalizedYellowButtonMenu! !

!Morph methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:35'!
wantsYellowButtonMenu: aBoolean 
	"Change the receiver to wants or not a yellow button menu"
	self setProperty: #wantsYellowButtonMenu toValue: aBoolean! !


!Morph methodsFor: 'menus' stamp: 'sw 10/6/2004 11:38'!
absorbStateFromRenderer: aRenderer 
	"Transfer knownName, actorState, visible, and player info over from aRenderer, which was formerly imposed above me as a transformation shell but is now going away."

	| current |
	(current _ aRenderer actorStateOrNil) ifNotNil:
		[self actorState: current.
		aRenderer actorState: nil].

	(current _ aRenderer knownName) ifNotNil:
		[self setNameTo: current.
		aRenderer setNameTo: nil].

	(current _ aRenderer player) ifNotNil:
		[self player: current.
		current rawCostume: self.
		aRenderer player: nil].

	self visible: aRenderer visible! !

!Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 14:36'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph
	"The former charter of this method was to add halo menu items that pertained specifically to the hand.  Over time this charter has withered, and most morphs reimplement this method simply to add their morph-specific menu items.  So in the latest round, all other implementors in the standard image have been removed.  However, this is left here as a hook for the benefit of existing code in client uses."

! !

!Morph methodsFor: 'menus' stamp: 'dgd 11/15/2003 19:25'!
addCopyItemsTo: aMenu
	"Add copy-like items to the halo menu"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:.
	subMenu add: 'copy text' translated action: #clipText.
	subMenu add: 'copy Postscript' translated action: #clipPostscript.
	subMenu add: 'print Postscript to file...' translated target: self selector: #printPSToFile.
	aMenu add: 'copy & print...' translated subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'sw 4/27/1998 03:44'!
addCustomHaloMenuItems: aMenu hand: aHandMorph
	"Add morph-specific items to the given menu which was invoked by the given hand from the halo.  To get started, we defer to the counterpart method used with the option-menu, but in time we can have separate menu choices for halo-menus and for option-menus"

	self addCustomMenuItems: aMenu hand: aHandMorph! !

!Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 07:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add morph-specific items to the given menu which was invoked by the given hand.  This method provides is invoked both from the halo-menu and from the control-menu regimes."
! !

!Morph methodsFor: 'menus' stamp: 'nk 2/16/2004 13:29'!
addExportMenuItems: aMenu hand: aHandMorph
	"Add export items to the menu"

	aMenu ifNotNil:
		[ | aSubMenu |
		aSubMenu _ MenuMorph new defaultTarget: self.
		aSubMenu add: 'BMP file' translated action: #exportAsBMP.
		aSubMenu add: 'GIF file' translated action: #exportAsGIF.
		aSubMenu add: 'JPEG file' translated action: #exportAsJPEG.
		aSubMenu add: 'PNG file' translated action: #exportAsPNG.
		aMenu add: 'export...' translated subMenu: aSubMenu]
! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 16:44'!
addFillStyleMenuItems: aMenu hand: aHand
	"Add the items for changing the current fill style of the Morph"
	| menu |
	self canHaveFillStyles ifFalse:[^aMenu add: 'change color...' translated target: self action: #changeColor].
	menu _ MenuMorph new defaultTarget: self.
	self fillStyle addFillStyleMenuItems: menu hand: aHand from: self.
	menu addLine.
	menu add: 'solid fill' translated action: #useSolidFill.
	menu add: 'gradient fill' translated action: #useGradientFill.
	menu add: 'bitmap fill' translated action: #useBitmapFill.
	menu add: 'default fill' translated action: #useDefaultFill.
	aMenu add: 'fill style' translated subMenu: menu.
	"aMenu add: 'change color...' translated action: #changeColor"! !

!Morph methodsFor: 'menus' stamp: 'sw 4/12/2005 23:13'!
addHaloActionsTo: aMenu
	"Add items to aMenu representing actions requestable via halo"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu addTitle: self externalName.
	subMenu addStayUpItemSpecial.
	subMenu addLine.
	subMenu add: 'delete' translated action: #dismissViaHalo.
	subMenu balloonTextForLastItem: 'Delete this object -- warning -- can be destructive!!' translated.

	self maybeAddCollapseItemTo: subMenu.
	subMenu add: 'grab' translated action: #openInHand.
	subMenu balloonTextForLastItem: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' translated.

	subMenu addLine.

	subMenu add: 'resize' translated action: #resizeFromMenu.
	subMenu balloonTextForLastItem: 'Change the size of this object' translated.

	subMenu add: 'duplicate' translated action: #maybeDuplicateMorph.
	subMenu balloonTextForLastItem: 'Hand me a copy of this object' translated.
	"Note that this allows access to the non-instancing duplicate even when this is a uniclass instance"

	self couldMakeSibling ifTrue:
		[subMenu add: 'make a sibling' translated action: #handUserASibling.
		subMenu balloonTextForLastItem: 'Make a new sibling of this object and hand it to me' translated].

	subMenu addLine.
	subMenu add: 'property sheet' translated target: self renderedMorph action: #openAPropertySheet.
	subMenu balloonTextForLastItem: 'Open a property sheet for me. Allows changing lots of stuff at once.' translated.

	subMenu add: 'set color' translated target: self renderedMorph action: #changeColor.
	subMenu balloonTextForLastItem: 'Change the color of this object' translated.

	subMenu add: 'viewer' translated target: self action: #beViewed.
	subMenu balloonTextForLastItem: 'Open a Viewer that will allow everything about this object to be seen and controlled.' translated.

	subMenu add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
	subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.

	subMenu add: 'hand me a tile' translated target: self action: #tearOffTile.
	subMenu balloonTextForLastItem: 'Hand me a tile represting this object' translated.
	subMenu addLine.

	subMenu add: 'inspect' translated target: self action: #inspect.
	subMenu balloonTextForLastItem: 'Open an Inspector on this object' translated.

	aMenu add: 'halo actions...' translated subMenu: subMenu
! !

!Morph methodsFor: 'menus' stamp: 'sw 3/2/2004 22:11'!
addMiscExtrasTo: aMenu
	"Add a submenu of miscellaneous extra items to the menu."

	| realOwner realMorph subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	(self isWorldMorph not and: [(self renderedMorph isSystemWindow) not])
		ifTrue: [subMenu add: 'put in a window' translated action: #embedInWindow].

	self isWorldMorph ifFalse:
		[subMenu add: 'adhere to edge...' translated action: #adhereToEdge.
		subMenu addLine].

	realOwner _ (realMorph _ self topRendererOrSelf) owner.
	(realOwner isKindOf: TextPlusPasteUpMorph) ifTrue:
		[subMenu add: 'GeeMail stuff...' translated subMenu: (realOwner textPlusMenuFor: realMorph)].

	subMenu
		add: 'add mouse up action' translated action: #addMouseUpAction;
		add: 'remove mouse up action' translated action: #removeMouseUpAction;
		add: 'hand me tiles to fire this button' translated action: #handMeTilesToFire.
	subMenu addLine.
	subMenu add: 'arrowheads on pen trails...' translated action: #setArrowheads.
	subMenu addLine.

	subMenu defaultTarget: self topRendererOrSelf.
	subMenu add: 'draw new path' translated action: #definePath.
	subMenu add: 'follow existing path' translated action: #followPath.
	subMenu add: 'delete existing path' translated action: #deletePath.
	subMenu addLine.

	self addGestureMenuItems: subMenu hand: ActiveHand.

	aMenu add: 'extras...' translated subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'nk 1/6/2004 12:53'!
addPaintingItemsTo: aMenu hand: aHandMorph 
	| subMenu movies |
	subMenu := MenuMorph new defaultTarget: self.
	subMenu add: 'repaint' translated action: #editDrawing.
	subMenu add: 'set rotation center' translated action: #setRotationCenter.
	subMenu add: 'reset forward-direction' translated
		action: #resetForwardDirection.
	subMenu add: 'set rotation style' translated action: #setRotationStyle.
	subMenu add: 'erase pixels of color' translated
		action: #erasePixelsOfColor:.
	subMenu add: 'recolor pixels of color' translated
		action: #recolorPixelsOfColor:.
	subMenu add: 'reduce color palette' translated action: #reduceColorPalette:.
	subMenu add: 'add a border around this shape...' translated
		action: #addBorderToShape:.
	movies := (self world rootMorphsAt: aHandMorph targetOffset) 
				select: [:m | (m isKindOf: MovieMorph) or: [m isSketchMorph]].
	movies size > 1 
		ifTrue: 
			[subMenu add: 'insert into movie' translated action: #insertIntoMovie:].
	aMenu add: 'painting...' translated subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'sw 4/12/2005 23:12'!
addPlayerItemsTo: aMenu
	"Add player-related items to the menu if appropriate"

	| aPlayer subMenu |
	self couldMakeSibling ifFalse: [^ self].
	aPlayer _ self topRendererOrSelf player.
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'make a sibling instance' translated target: self action: #makeNewPlayerInstance:.
	subMenu balloonTextForLastItem: 'Makes another morph whose player is of the same class as this one.  Both siblings will share the same scripts' translated.

	subMenu add: 'make multiple siblings...' translated target: self action: #makeMultipleSiblings:.
	subMenu balloonTextForLastItem: 'Make any number of sibling instances all at once' translated.

	(aPlayer belongsToUniClass and: [aPlayer class instanceCount > 1]) ifTrue:
		[subMenu addLine.
		subMenu add: 'make all siblings look like me' translated target: self action: #makeSiblingsLookLikeMe:.
		subMenu balloonTextForLastItem: 'make all my sibling instances look like me.' translated.

		subMenu add: 'bring all siblings to my location' translated target: self action: #bringAllSiblingsToMe:.
		subMenu balloonTextForLastItem: 'find all sibling instances and bring them to me' translated.

		subMenu add: 'apply status to all siblngs' translated target: self action: #applyStatusToAllSiblings:.
		subMenu balloonTextForLastItem: 'apply the current status of all of my scripts to the scripts of all my siblings' translated].

		subMenu add: 'indicate all siblings' translated target: self action: #indicateAllSiblings.
		subMenu balloonTextForLastItem: 'momentarily show, by flashing , all of my visible siblings.'.

		aMenu add: 'siblings...' translated subMenu: subMenu

! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:34'!
addStackItemsTo: aMenu
	"Add stack-related items to the menu"

	| stackSubMenu |
	stackSubMenu _ MenuMorph new defaultTarget: self.
	(owner notNil and: [owner isStackBackground]) ifTrue:
		[self isShared
			ifFalse:
				[self couldHoldSeparateDataForEachInstance
					ifTrue:
						[stackSubMenu add: 'Background field, shared value' translated target: self action: #putOnBackground.
						stackSubMenu add: 'Background field, individual values' translated target: self action: #becomeSharedBackgroundField]
					ifFalse:
						[stackSubMenu add: 'put onto Background' translated target: self action: #putOnBackground]]
			ifTrue:
				[stackSubMenu add: 'remove from Background' translated target: self action: #putOnForeground.
				self couldHoldSeparateDataForEachInstance ifTrue:
					[self holdsSeparateDataForEachInstance
						ifFalse:
							[stackSubMenu add: 'start holding separate data for each instance' translated target: self action: #makeHoldSeparateDataForEachInstance]
						ifTrue:
							[stackSubMenu add: 'stop holding separate data for each instance' translated target: self action: #stopHoldingSeparateDataForEachInstance].
							stackSubMenu add: 'be default value on new card' translated target: self action: #setAsDefaultValueForNewCard.
							(self hasProperty: #thumbnailImage)
								ifTrue:
									[stackSubMenu add: 'stop using for reference thumbnail' translated target: self action: #stopUsingForReferenceThumbnail]
								ifFalse:
									[stackSubMenu add: 'start using for reference thumbnail' translated target: self action: #startUsingForReferenceThumbnail]]].
				stackSubMenu addLine].

	(self isStackBackground) ifFalse:
		[stackSubMenu add: 'be a card in an existing stack...' translated action: #insertAsStackBackground].
	stackSubMenu add: 'make an instance for my data' translated action: #abstractAModel.
	(self isStackBackground) ifFalse:
		[stackSubMenu add: 'become a stack of cards' translated action: #wrapWithAStack].
	aMenu add: 'stacks and cards...' translated subMenu: stackSubMenu
! !

!Morph methodsFor: 'menus' stamp: 'nk 2/15/2004 08:19'!
addStandardHaloMenuItemsTo: aMenu hand: aHandMorph
	"Add standard halo items to the menu"

	| unlockables |

	self isWorldMorph ifTrue:
		[^ self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph].

	self mustBeBackmost ifFalse:
		[aMenu add: 'send to back' translated action: #goBehind.
		aMenu add: 'bring to front' translated action: #comeToFront.
		self addEmbeddingMenuItemsTo: aMenu hand: aHandMorph.
		aMenu addLine].

	self addFillStyleMenuItems: aMenu hand: aHandMorph.
	self addBorderStyleMenuItems: aMenu hand: aHandMorph.
	self addDropShadowMenuItems: aMenu hand: aHandMorph.
	self addLayoutMenuItems: aMenu hand: aHandMorph.
	self addHaloActionsTo: aMenu.
	owner isTextMorph ifTrue:[self addTextAnchorMenuItems: aMenu hand: aHandMorph].
	aMenu addLine.
	self addToggleItemsToHaloMenu: aMenu.
	aMenu addLine.
	self addCopyItemsTo: aMenu.
	self addPlayerItemsTo: aMenu.
	self addExportMenuItems: aMenu hand: aHandMorph.
	self addStackItemsTo: aMenu.
	self addMiscExtrasTo: aMenu.
	Preferences noviceMode ifFalse:
		[self addDebuggingItemsTo: aMenu hand: aHandMorph].

	aMenu addLine.
	aMenu defaultTarget: self.

	aMenu addLine.

	unlockables _ self submorphs select:
		[:m | m isLocked].
	unlockables size == 1 ifTrue:
		[aMenu
			add: ('unlock "{1}"' translated format: unlockables first externalName)
			action: #unlockContents].
	unlockables size > 1 ifTrue:
		[aMenu add: 'unlock all contents' translated action: #unlockContents.
		aMenu add: 'unlock...' translated action: #unlockOneSubpart].

	aMenu defaultTarget: aHandMorph.
! !

!Morph methodsFor: 'menus' stamp: 'dgd 4/3/2006 14:11'!
addToggleItemsToHaloMenu: aMenu
	"Add standard true/false-checkbox items to the memu"

	#(
		(resistsRemovalString toggleResistsRemoval 'whether I should be reistant to easy deletion via the pink X handle' true)
		(stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me' true)
		(lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions' true)
		(hasClipSubmorphsString changeClipSubmorphs 'whether the parts of objects within me that are outside my bounds should be masked.' false)
		(hasDirectionHandlesString changeDirectionHandles 'whether direction handles are shown with the halo' false)
		(hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me' false)
	)
		select:[:each | Preferences noviceMode not or:[each fourth]]
		thenDo:
		[:each |
			aMenu addUpdating: each first action: each second.
			aMenu balloonTextForLastItem: each third translated].

	self couldHaveRoundedCorners ifTrue:
		[aMenu addUpdating: #roundedCornersString action: #toggleCornerRounding.
		aMenu balloonTextForLastItem: 'whether my corners should be rounded' translated]! !

!Morph methodsFor: 'menus' stamp: 'wiz 2/14/2006 18:54'!
addWorldTargetSightingItems: aCustomMenu hand: aHandMorph
"Use cursor to select a point on screen.
Set target from all possible morphs under cursor sight." 
	
	aCustomMenu addLine.
	
	aCustomMenu add: 'sight target' translated action: #sightWorldTargets:.
	! !

!Morph methodsFor: 'menus' stamp: 'dgd 10/17/2003 22:51'!
adhereToEdge
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	#(top right bottom left - center - topLeft topRight bottomRight bottomLeft - none)
		do: [:each |
			each == #-
				ifTrue: [menu addLine]
				ifFalse: [menu add: each asString translated selector: #setToAdhereToEdge: argument: each]].
	menu popUpEvent: self currentEvent in: self world! !

!Morph methodsFor: 'menus' stamp: 'dgd 2/22/2003 14:26'!
adhereToEdge: edgeSymbol 
	(owner isNil or: [owner isHandMorph]) ifTrue: [^self].
	self perform: (edgeSymbol , ':') asSymbol
		withArguments: (Array with: (owner perform: edgeSymbol))! !

!Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:14'!
adjustedCenter
	"Provides a hook for objects to provide a reference point other than the receiver's center,for the purpose of centering a submorph under special circumstances, such as BalloonMorph"

	^ self center! !

!Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:12'!
adjustedCenter: c
	"Set the receiver's position based on the #adjustedCenter protocol for adhereToEdge.  By default this simply sets the receiver's center.   Though there are (at its inception anyway) no other implementors of this method, it is required in use with the #adhereToEdge when the centering of a submorph is to be with reference to a rectangle  other than the receiver's center."

	self center: c! !

!Morph methodsFor: 'menus' stamp: 'ar 10/5/2000 17:20'!
allMenuWordings
	| tempMenu |
	tempMenu _ self buildHandleMenu: self currentHand.
	tempMenu allMorphsDo: [:m | m step].  "Get wordings current"
	^ tempMenu allWordings! !

!Morph methodsFor: 'menus' stamp: 'sw 9/6/2000 18:45'!
changeColor
	"Change the color of the receiver -- triggered, e.g. from a menu"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #fillStyle:;
		originalColor: self color;
		putUpFor: self near: self fullBoundsInWorld! !

!Morph methodsFor: 'menus' stamp: 'ar 11/29/2001 19:57'!
changeDirectionHandles
	^self wantsDirectionHandles: self wantsDirectionHandles not! !

!Morph methodsFor: 'menus' stamp: 'ar 11/2/2000 15:04'!
changeDragAndDrop
	^self enableDragNDrop: self dragNDropEnabled not! !

!Morph methodsFor: 'menus' stamp: 'sw 12/17/1998 12:09'!
chooseNewGraphic
	"Used by any morph that can be represented by a graphic"
	self chooseNewGraphicCoexisting: false
! !

!Morph methodsFor: 'menus' stamp: 'nk 6/12/2004 09:58'!
chooseNewGraphicCoexisting: aBoolean 
	"Allow the user to choose a different form for her form-based morph"
	| replacee aGraphicalMenu |
	aGraphicalMenu := GraphicalMenu new
				initializeFor: self
				withForms: self reasonableForms
				coexist: aBoolean.
	aBoolean
		ifTrue: [self primaryHand attachMorph: aGraphicalMenu]
		ifFalse: [replacee := self topRendererOrSelf.
			replacee owner replaceSubmorph: replacee by: aGraphicalMenu]! !

!Morph methodsFor: 'menus' stamp: 'sw 10/27/2000 17:34'!
chooseNewGraphicFromHalo
	"Allow the user to select a changed graphic to replace the one in the receiver"

	self currentWorld abandonAllHalos.
	self chooseNewGraphicCoexisting: true
! !

!Morph methodsFor: 'menus' stamp: 'sw 2/21/2000 15:21'!
collapse
	CollapsedMorph new beReplacementFor: self! !

!Morph methodsFor: 'menus'!
defaultArrowheadSize
	
	^ self class defaultArrowheadSize! !

!Morph methodsFor: 'menus' stamp: 'ar 10/25/2000 23:17'!
doMenuItem: menuString
	| aMenu anItem aNominalEvent aHand |
	aMenu _ self buildHandleMenu: (aHand _ self currentHand).
	aMenu allMorphsDo: [:m | m step].  "Get wordings current"
	anItem _ aMenu itemWithWording: menuString.
	anItem ifNil:
		[^ self player scriptingError: 'Menu item not found: ', menuString].
	aNominalEvent _  MouseButtonEvent new
		setType: #mouseDown
		position: anItem bounds center
		which: 4 "red"
		buttons: 4 "red"
		hand: aHand
		stamp: nil.
	anItem invokeWithEvent: aNominalEvent! !

!Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 17:50'!
exportAsBMP
	| fName |
	fName _ FillInTheBlank request:'Please enter the name' translated initialAnswer: self externalName,'.bmp'.
	fName isEmpty ifTrue:[^self].
	self imageForm writeBMPfileNamed: fName.! !

!Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 17:50'!
exportAsGIF
	| fName |
	fName _ FillInTheBlank request:'Please enter the name' translated initialAnswer: self externalName,'.gif'.
	fName isEmpty ifTrue:[^self].
	GIFReadWriter putForm: self imageForm onFileNamed: fName.! !

!Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 17:51'!
exportAsJPEG
	"Export the receiver's image as a JPEG"

	| fName |
	fName _ FillInTheBlank request: 'Please enter the name' translated initialAnswer: self externalName,'.jpeg'.
	fName isEmpty ifTrue: [^ self].
	self imageForm writeJPEGfileNamed: fName! !

!Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 17:51'!
exportAsPNG
	| fName |
	fName _ FillInTheBlank request:'Please enter the name' translated initialAnswer: self externalName,'.png'.
	fName isEmpty ifTrue:[^self].
	PNGReadWriter putForm: self imageForm onFileNamed: fName.! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:23'!
hasDirectionHandlesString
	^ (self wantsDirectionHandles
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'direction handles' translated! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:24'!
hasDragAndDropEnabledString
	"Answer a string to characterize the drag & drop status of the  
	receiver"
	^ (self dragNDropEnabled
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'accept drops' translated! !

!Morph methodsFor: 'menus' stamp: 'dgd 4/3/2006 14:09'!
helpButton
	"Answer a button whose action would be to put up help concerning the receiver"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton
		target: self;
		color: ColorTheme current helpColor;
		borderColor: ColorTheme current helpColor muchDarker;
		borderWidth: 1;
		label: '?' translated font: Preferences standardButtonFont;
		actionSelector: #presentHelp;
		setBalloonText: 'click here for help' translated.
	^ aButton! !

!Morph methodsFor: 'menus' stamp: 'ar 9/27/2005 21:01'!
inspectInMorphic
	self currentHand attachMorph: ((ToolSet inspect: self) extent: 300@200)! !

!Morph methodsFor: 'menus' stamp: 'ar 9/27/2005 21:01'!
inspectInMorphic: evt
	evt hand attachMorph: ((ToolSet inspect: self) extent: 300@200)! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:20'!
lockedString
	"Answer the string to be shown in a menu to represent the 
	'locked' status"
	^ (self isLocked
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'be locked' translated! !

!Morph methodsFor: 'menus' stamp: 'sw 9/21/2000 22:50'!
lockUnlockMorph
	"If the receiver is locked, unlock it; if unlocked, lock it"

	self isLocked ifTrue: [self unlock] ifFalse: [self lock]! !

!Morph methodsFor: 'menus' stamp: 'sw 10/29/1999 15:34'!
makeNascentScript
	^ self notYetImplemented! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:15'!
maybeAddCollapseItemTo: aMenu
	"If appropriate, add a collapse item to the given menu"

	| anOwner |
	(anOwner _ self topRendererOrSelf owner) ifNotNil:
			[anOwner isWorldMorph ifTrue:
				[aMenu add: 'collapse' translated target: self action: #collapse]]! !

!Morph methodsFor: 'menus' stamp: 'sw 11/22/1999 12:13'!
menuItemAfter: menuString
	| allWordings |
	allWordings _ self allMenuWordings.
	^ allWordings atWrap: ((allWordings indexOf: menuString) + 1)! !

!Morph methodsFor: 'menus' stamp: 'sw 11/22/1999 12:14'!
menuItemBefore: menuString
	| allWordings |
	allWordings _ self allMenuWordings.
	^ allWordings atWrap: ((allWordings indexOf: menuString) - 1)! !

!Morph methodsFor: 'menus' stamp: 'dgd 9/22/2004 20:30'!
model
	^ nil ! !

!Morph methodsFor: 'menus' stamp: 'sw 6/12/2001 21:08'!
presentHelp
	"Present a help message if there is one available"

	self inform: 'Sorry, no help has been
provided here yet.'! !

!Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 18:03'!
printPSToFileNamed: aString 
	"Ask the user for a filename and print this morph as postscript."
	| fileName rotateFlag psCanvasType psExtension |
	fileName := aString asFileName.
	psCanvasType _ PostscriptCanvas defaultCanvasType.
	psExtension _ psCanvasType defaultExtension.
	fileName := FillInTheBlank request: (String streamContents: [ :s |
		s nextPutAll: ('File name? ("{1}" will be added to end)' translated format: {psExtension})])
			initialAnswer: fileName.
	fileName isEmpty
		ifTrue: [^ Beeper beep].
	(fileName endsWith: psExtension)
		ifFalse: [fileName := fileName , psExtension].
	rotateFlag := ((PopUpMenu labels: 'portrait (tall)
landscape (wide)' translated)
				startUpWithCaption: 'Choose orientation...' translated)
				= 2.
	((FileStream newFileNamed: fileName asFileName) converter: TextConverter defaultSystemConverter)
		nextPutAll: (psCanvasType morphAsPostscript: self rotated: rotateFlag);
		 close! !

!Morph methodsFor: 'menus' stamp: 'sw 10/27/2000 06:39'!
putOnBackground
	"Place the receiver, formerly private to its card, onto the shared background.  If the receiver needs data carried on its behalf by the card, such data will be represented on every card."

	(self hasProperty: #shared) ifTrue: [^ self].  "Already done"

	self setProperty: #shared toValue: true.
	self stack ifNotNil: [self stack reassessBackgroundShape]! !

!Morph methodsFor: 'menus' stamp: 'dgd 9/5/2003 18:25'!
putOnForeground
	"Place the receiver, formerly on the background, onto the foreground.  If the receiver needs data carried on its behalf by the card, those data will be lost, so in this case get user confirmation before proceeding."

	self holdsSeparateDataForEachInstance "later add the refinement of not putting up the following confirmer if only a single instance of the current background's uniclass exists"
		ifTrue:
			[self confirm: 'Caution -- every card of this background
formerly had its own value for this
item.  If you put it on the foreground,
the values  of this item on all other
cards will be lost' translated
				orCancel: [^ self]].

	self removeProperty: #shared.
	self stack reassessBackgroundShape.
	"still work to be done here!!"! !

!Morph methodsFor: 'menus' stamp: 'nk 6/12/2004 22:42'!
reasonableBitmapFillForms
	"Answer an OrderedCollection of forms that could be used to replace my bitmap fill, with my current form first."
	| reasonableForms myGraphic |
	reasonableForms := self class allSketchMorphForms.
	reasonableForms addAll: Imports default images.
	reasonableForms addAll: (BitmapFillStyle allSubInstances collect:[:f| f form]).
	reasonableForms
		remove: (myGraphic := self fillStyle form)
		ifAbsent: [].
	reasonableForms := reasonableForms asOrderedCollection.
	reasonableForms addFirst: myGraphic.
	^reasonableForms! !

!Morph methodsFor: 'menus' stamp: 'nk 6/12/2004 09:55'!
reasonableForms
	"Answer an OrderedCollection of forms that could be used to replace my form, with my current form first."
	| reasonableForms myGraphic |
	reasonableForms := self class allSketchMorphForms.
	reasonableForms addAll: Imports default images.
	reasonableForms
		remove: (myGraphic := self form)
		ifAbsent: [].
	reasonableForms := reasonableForms asOrderedCollection.
	reasonableForms addFirst: myGraphic.
	^reasonableForms! !

!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:36'!
resetForwardDirection
	self forwardDirection: 0.! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:18'!
resistsRemovalString
	"Answer the string to be shown in a menu to represent the 
	'resistsRemoval' status"
	^ (self resistsRemoval
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'resist being deleted' translated! !

!Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 16:58'!
setArrowheads
	"Let the user edit the size of arrowheads for this object"

	| aParameter result  |
	aParameter _ self renderedMorph valueOfProperty:  #arrowSpec ifAbsent:
		[Preferences parameterAt: #arrowSpec ifAbsent: [5 @ 4]].
	result _ Morph obtainArrowheadFor: 'Head size for arrowheads: ' translated defaultValue: aParameter asString.
	result ifNotNil:
			[self renderedMorph  setProperty: #arrowSpec toValue: result]
		ifNil:
			[Beeper beep]! !

!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:15'!
setRotationCenter
	| p |
	self world displayWorld.
	Cursor crossHair showWhile:
		[p _ Sensor waitButton].
	Sensor waitNoButton.
	self setRotationCenterFrom: (self transformFromWorld globalPointToLocal: p).

! !

!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:14'!
setRotationCenterFrom: aPoint
	self rotationCenter: (aPoint - self bounds origin) / self bounds extent asFloatPoint.! !

!Morph methodsFor: 'menus' stamp: 'di 12/21/2000 17:18'!
setToAdhereToEdge: anEdge
	anEdge ifNil: [^ self].
	anEdge == #none ifTrue: [^ self removeProperty: #edgeToAdhereTo].
	self setProperty: #edgeToAdhereTo toValue: anEdge.
! !

!Morph methodsFor: 'menus' stamp: 'sw 8/30/1998 09:42'!
snapToEdgeIfAppropriate
	| edgeSymbol oldBounds aWorld |
	(edgeSymbol _ self valueOfProperty: #edgeToAdhereTo) ifNotNil:
		[oldBounds _ bounds.
		self adhereToEdge: edgeSymbol.
		bounds ~= oldBounds ifTrue: [(aWorld _ self world) ifNotNil: [aWorld viewBox ifNotNil:
			[aWorld displayWorld]]]]! !

!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:19'!
stickinessString
	"Answer the string to be shown in a menu to represent the  
	stickiness status"
	^ (self isSticky
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'resist being picked up' translated! !

!Morph methodsFor: 'menus' stamp: 'sw 10/6/2004 12:16'!
transferStateToRenderer: aRenderer
	"Transfer knownName, actorState, visible, and player info over to aRenderer, which is being imposed above me as a transformation shell"

	| current |
	(current _ self actorStateOrNil) ifNotNil:
		[aRenderer actorState: current.
		self actorState: nil].

	(current _ self knownName) ifNotNil:
		[aRenderer setNameTo: current.
		self setNameTo: nil].

	(current _ self player) ifNotNil:
		[aRenderer player: current.
		self player rawCostume: aRenderer.
		"NB player is redundantly pointed to in the extension of both the renderer and the rendee; this is regrettable but many years ago occasionally people tried to make that clean but always ran into problems iirc"
		"self player: nil"].

	aRenderer simplySetVisible: self visible



 

		! !

!Morph methodsFor: 'menus' stamp: 'RAA 11/14/2000 13:46'!
uncollapseSketch

	| uncollapsedVersion w whomToDelete |

	(w _ self world) ifNil: [^self].
	uncollapsedVersion _ self valueOfProperty: #uncollapsedMorph.
	uncollapsedVersion ifNil: [^self].
	whomToDelete _ self valueOfProperty: #collapsedMorphCarrier.
	uncollapsedVersion setProperty: #collapsedPosition toValue: whomToDelete position.

	whomToDelete delete.
	w addMorphFront: uncollapsedVersion.

! !


!Morph methodsFor: 'meta-actions' stamp: 'dgd 9/18/2004 16:24'!
addEmbeddingMenuItemsTo: aMenu hand: aHandMorph
	"Construct a menu offerring embed targets for the receiver.  If the incoming menu is is not degenerate, add the constructed menu as a submenu; in any case, answer the embed-target menu"

	| menu potentialEmbeddingTargets |

	potentialEmbeddingTargets := self potentialEmbeddingTargets.
	potentialEmbeddingTargets size > 1 ifFalse:[^ self].

	menu := MenuMorph new defaultTarget: self.

	potentialEmbeddingTargets reverseDo: [:m | 
			menu
				add: (m knownName ifNil:[m class name asString])
				target: m
				selector: #addMorphFrontFromWorldPosition:
				argument: self topRendererOrSelf.

			menu lastItem icon: (m iconOrThumbnailOfSize: 16).

			self owner == m ifTrue:[menu lastItem emphasis: 1].
		].

	aMenu add:'embed into' translated subMenu: menu.

	^ menu! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 1/29/2001 02:50'!
applyStatusToAllSiblings: evt
	"Apply the statuses of all my scripts to the script status of all my siblings"

	| aPlayer |
	(aPlayer _ self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
	aPlayer instantiatedUserScriptsDo: 
		[:aScriptInstantiation | aScriptInstantiation assignStatusToAllSiblings]! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:51'!
beThisWorldsModel

	self world setModel: self.
	self model: nil slotName: nil.	"A world's model cannot have another model"! !

!Morph methodsFor: 'meta-actions' stamp: 'yo 3/15/2005 14:45'!
blueButtonDown: anEvent
	"Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph."
	| h tfm doNotDrag |
	h _ anEvent hand halo.
	"Prevent wrap around halo transfers originating from throwing the event back in"
	doNotDrag _ false.
	h ifNotNil:[
		(h innerTarget == self) ifTrue:[doNotDrag _ true].
		(h innerTarget hasOwner: self) ifTrue:[doNotDrag _ true].
		(self hasOwner: h target) ifTrue:[doNotDrag _ true]].

	tfm _ (self transformedFrom: nil) inverseTransformation.

	"cmd-drag on flexed morphs works better this way"
	h _ self addHalo: (anEvent transformedBy: tfm).
	h ifNil: [^ self].
	doNotDrag ifTrue:[^self].
	"Initiate drag transition if requested"
	anEvent hand 
		waitForClicksOrDrag: h
		event: (anEvent transformedBy: tfm)
		selectors: { nil. nil. nil. #dragTarget:. }
		threshold: 5.
	"Pass focus explicitly here"
	anEvent hand newMouseFocus: h.! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 9/15/2000 20:25'!
blueButtonUp: anEvent
	"Ignored. Theoretically we should never get here since control is transferred to the halo on #blueButtonDown: but subclasses may implement this differently."! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 1/19/2001 18:10'!
bringAllSiblingsToMe: evt
	"bring all siblings of the receiver's player found in the same container to the receiver's location."

	| aPlayer aPosition aContainer |
	(aPlayer _ self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
	aPosition _ self topRendererOrSelf position.
	aContainer _ self topRendererOrSelf owner.
	(aPlayer class allInstances copyWithout: aPlayer) do:
		[:each |
			(aContainer submorphs includes: each costume) ifTrue:
				[each costume  position: aPosition]]! !

!Morph methodsFor: 'meta-actions' stamp: 'dgd 9/18/2004 17:23'!
buildHandleMenu: aHand
	"Build the morph menu for the given morph's halo's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. This method allows the morph to decide which items should be included in the hand's section of the menu."

	| menu |

	(Preferences generalizedYellowButtonMenu
			and: [Preferences noviceMode])
		ifTrue: [^ self buildYellowButtonMenu: aHand].

	menu _ MenuMorph new defaultTarget: self.
	menu addStayUpItem.
	menu addLine.
	self addStandardHaloMenuItemsTo: menu hand: aHand.
	menu defaultTarget: aHand.
	self addAddHandMenuItemsForHalo: menu  hand: aHand.
	menu defaultTarget: self.
	self addCustomHaloMenuItems: menu hand: aHand.
	menu defaultTarget: aHand.
	^ menu
! !

!Morph methodsFor: 'meta-actions' stamp: 'dgd 11/15/2003 19:29'!
buildMetaMenu: evt
	"Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph."
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu addStayUpItem.
	menu add: 'grab' translated action: #grabMorph:.
	menu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:.
	self maybeAddCollapseItemTo: menu.
	menu add: 'delete' translated action: #dismissMorph:.
	menu addLine.
	menu add: 'copy text' translated action: #clipText.
	menu add: 'copy Postscript' translated action: #clipPostscript.
	menu add: 'print Postscript to file...' translated action: #printPSToFile.
	menu addLine.
	menu add: 'go behind' translated action: #goBehind.
	menu add: 'add halo' translated action: #addHalo:.
	menu add: 'duplicate' translated action: #maybeDuplicateMorph:.

	self addEmbeddingMenuItemsTo: menu hand: evt hand.

	menu add: 'resize' translated action: #resizeMorph:.
	"Give the argument control over what should be done about fill styles"
	self addFillStyleMenuItems: menu hand: evt hand.
	self addDropShadowMenuItems: menu hand: evt hand.
	self addLayoutMenuItems: menu hand: evt hand.
	menu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #().
	menu addLine.

	(self morphsAt: evt position) size > 1 ifTrue:
		[menu add: 'submorphs...' translated
			target: self
			selector: #invokeMetaMenuAt:event:
			argument: evt position].
	menu addLine.
	menu add: 'inspect' translated selector: #inspectAt:event: argument: evt position.
	menu add: 'explore' translated action: #explore.
	menu add: 'browse hierarchy' translated action: #browseHierarchy.
	menu add: 'make own subclass' translated action: #subclassMorph.
	menu addLine.
	menu add: 'set variable name...' translated action: #choosePartName.
	(self isMorphicModel) ifTrue:
		[menu add: 'save morph as prototype' translated action: #saveAsPrototype.
		(self ~~ self world modelOrNil) ifTrue:
			 [menu add: 'become this world''s model' translated action: #beThisWorldsModel]].
	menu add: 'save morph in file' translated action: #saveOnFile.
	(self hasProperty: #resourceFilePath)
		ifTrue: [((self valueOfProperty: #resourceFilePath) endsWith: '.morph')
				ifTrue: [menu add: 'save as resource' translated action: #saveAsResource].
				menu add: 'update from resource' translated action: #updateFromResource]
		ifFalse: [menu add: 'attach to resource' translated action: #attachToResource].
	menu add: 'show actions' translated action: #showActions.
	menu addLine.
	self addDebuggingItemsTo: menu hand: evt hand.

	self addCustomMenuItems: menu hand: evt hand.
	^ menu
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 18:54'!
changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand
	"Put up a color picker for changing some kind of color.  May be modal or modeless, depending on #modalColorPickers setting"
	self flag: #arNote. "Simplify this due to anObject == self for almost all cases"
	^ ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: aHand;
		target: anObject;
		selector: aSymbol;
		originalColor: aColor;
		putUpFor: anObject near: (anObject isMorph
					ifTrue:	 [Rectangle center: self position extent: 20]
					ifFalse: [anObject == self world
								ifTrue: [anObject viewBox bottomLeft + (20@-20) extent: 200]
								ifFalse: [anObject fullBoundsInWorld]]);
		yourself! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:44'!
copyToPasteBuffer: evt
	self okayToDuplicate ifTrue:[evt hand copyToPasteBuffer: self].! !

!Morph methodsFor: 'meta-actions' stamp: 'mir 3/17/2006 18:02'!
dismissMorph
	"This is called from an explicit halo destroy/delete action."

	| w |
	w _ self world ifNil:[^self].
	w abandonAllHalos; stopStepping: self.
	self delete! !

!Morph methodsFor: 'meta-actions' stamp: 'mir 3/17/2006 18:01'!
dismissMorph: evt
	self dismissMorph! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 2/19/2006 12:41'!
duplicateMorphImage: evt 
	"Make and return a imageMorph of the receiver's argument imageForm"
	| dup |
	dup := self asSnapshotThumbnail withSnapshotBorder.
	dup bounds: self bounds.
	evt hand grabMorph: dup from: owner.
	"duplicate was ownerless so use #grabMorph:from: here"
	^ dup! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 11/4/2000 17:56'!
duplicateMorph: evt
	"Make and return a duplicate of the receiver's argument"
	| dup |
	dup _ self duplicate.
	evt hand grabMorph: dup from: owner. "duplicate was ownerless so use #grabMorph:from: here"
	^dup! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/7/2000 20:53'!
embedInto: evt
	"Embed the receiver into some other morph"
	|  menu target |
	menu _ CustomMenu new.
	self potentialEmbeddingTargets  do: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) action: m].
	target _ menu startUpWithCaption: ('Place ', self externalName, ' in...').
	target ifNil:[^self].
	target addMorphFront: self fromWorldPosition: self positionInWorld.! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/6/2000 16:37'!
grabMorph: evt

	evt hand grabMorph: self! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/7/2000 18:44'!
handlerForBlueButtonDown: anEvent
	"Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event.
	Note: Halos handle blue button events themselves so we will only be asked if there is currently no halo on top of us."
	self wantsHaloFromClick ifFalse:[^nil].
	anEvent handler ifNil:[^self].
	anEvent handler isPlayfieldLike ifTrue:[^self]. "by default exclude playfields"
	(anEvent shiftPressed)
		ifFalse:[^nil] "let outer guy have it"
		ifTrue:[^self] "let me have it"
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/12/2000 17:07'!
handlerForMetaMenu: evt
	"Return the prospective handler for invoking the meta menu. By default, the top-most morph in the innermost world gets this menu"
	self isWorldMorph ifTrue:[^self].
	evt handler ifNotNil:[evt handler isWorldMorph ifTrue:[^self]].
	^nil! !

!Morph methodsFor: 'meta-actions' stamp: 'yo 2/12/2005 15:25'!
indicateAllSiblings
	"Indicate all the receiver and all its siblings by flashing momentarily."

	| aPlayer allBoxes |
	(aPlayer _ self topRendererOrSelf player) belongsToUniClass ifFalse: [^ self "error: 'not uniclass'"].
	allBoxes _ aPlayer class allInstances
		select: [:m | m costume world == ActiveWorld]
		thenCollect: [:m | m costume boundsInWorld].

	5 timesRepeat:
		[Display flashAll: allBoxes andWait: 120]! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/10/2000 14:09'!
inspectAt: aPoint event: evt
	| menu morphs target |
	menu _ CustomMenu new.
	morphs _ self morphsAt: aPoint.
	(morphs includes: self) ifFalse:[morphs _ morphs copyWith: self].
	morphs do: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) action: m].
	target _ menu startUpWithCaption: ('inspect whom?
(deepest at top)').
	target ifNil:[^self].
	target inspectInMorphic: evt! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/10/2000 14:26'!
invokeMetaMenuAt: aPoint event: evt
	| menu morphs target |
	menu _ CustomMenu new.
	morphs _ self morphsAt: aPoint.
	(morphs includes: self) ifFalse:[morphs _ morphs copyWith: self].
	morphs size = 1 ifTrue:[morphs first invokeMetaMenu: evt].
	morphs do: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) action: m].
	target _ menu startUp.
	target ifNil:[^self].
	target invokeMetaMenu: evt! !

!Morph methodsFor: 'meta-actions' stamp: 'fc 4/27/2004 21:54'!
invokeMetaMenu: evt
	| menu |
	menu _ self buildMetaMenu: evt.
	menu addTitle: self externalName.
	self world ifNotNil: [
		menu popUpEvent: evt in: self world
	]! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 4/12/2005 23:09'!
makeMultipleSiblings: evt
	"Make multiple siblings, first prompting the user for how many"

	| result |
	self topRendererOrSelf couldMakeSibling ifFalse: [^ Beeper beep].
	result _ FillInTheBlank request: 'how many siblings do you want?' translated initialAnswer: '2'.
	result isEmptyOrNil ifTrue: [^ self].
	result first isDigit ifFalse: [^ Beeper beep].
	self topRendererOrSelf makeSiblings: result asInteger.! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 19:20'!
makeNewPlayerInstance: evt
	"Make a duplicate of the receiver's argument.  This is called only where the argument has an associated Player as its costumee, and the intent here is to make another instance of the same uniclass as the donor Player itself.  Much works, but there are flaws so this shouldn't be used without recognizing the risks"

	evt hand attachMorph: self usableSiblingInstance! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 1/12/2001 22:47'!
makeSiblingsLookLikeMe: evt
	"Make all my siblings wear the same costume that I am wearing."

	| aPlayer |
	(aPlayer _ self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
	aPlayer class allInstancesDo:
		[:anInstance | anInstance == aPlayer ifFalse:
			[anInstance wearCostumeOf: aPlayer]]! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 1/29/2001 17:11'!
makeSiblings: count
	"Make multiple sibling, and return the list"

	| aPosition anInstance listOfNewborns |
	aPosition _ self position.
	listOfNewborns _ (1 to: count asInteger) asArray collect: 
		[:anIndex |
			anInstance _ self usableSiblingInstance.
			owner addMorphFront: anInstance.
			aPosition _ aPosition + (10@10).
			anInstance position: aPosition.
			anInstance].
	self currentWorld startSteppingSubmorphsOf: self topRendererOrSelf owner.
	^ listOfNewborns! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 4/19/2005 14:55'!
maybeDuplicateMorph
	"Maybe duplicate the morph"

	self okayToDuplicate ifTrue:
		[self topRendererOrSelf duplicate openInHand]! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 17:32'!
maybeDuplicateMorph: evt
	self okayToDuplicate ifTrue:[^self duplicateMorph: evt]! !

!Morph methodsFor: 'meta-actions' stamp: 'RAA 2/19/2001 16:52'!
openAPropertySheet

	ObjectPropertiesMorph basicNew
		targetMorph: self;
		initialize;
		openNearTarget! !

!Morph methodsFor: 'meta-actions' stamp: 'RAA 3/15/2001 12:56'!
openATextPropertySheet

	"should only be sent to morphs that are actually supportive"

	TextPropertiesMorph basicNew
		targetMorph: self;
		initialize;
		openNearTarget! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 1/2/2005 01:06'!
potentialEmbeddingTargets
	"Return the potential targets for embedding the receiver"

	| oneUp topRend |
	(oneUp _ (topRend _ self topRendererOrSelf) owner) ifNil:[^#()].
	^ (oneUp morphsAt: topRend referencePosition behind: topRend unlocked: true) select:
		[:m | m  isFlexMorph not]! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/17/2004 22:17'!
potentialTargets
	"Return the potential targets for the receiver.
	This is derived from Morph>>potentialEmbeddingTargets."
	owner ifNil:[^#()].
	^owner morphsAt: self referencePosition behind: self unlocked: true not! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/20/2004 02:46'!
potentialTargetsAt: aPoint 
	"Return the potential targets for the receiver.  
	This is derived from Morph>>potentialEmbeddingTargets."
	owner
		ifNil: [^ #()].
	^ owner
		morphsAt: aPoint
		! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 11/27/2001 14:59'!
resizeFromMenu
	"Commence an interaction that will resize the receiver"

	self resizeMorph: ActiveEvent! !

!Morph methodsFor: 'meta-actions' stamp: 'st 9/14/2004 12:30'!
resizeMorph: evt
	| handle |
	handle _ HandleMorph new forEachPointDo: [:newPoint | 
		self extent: (self griddedPoint: newPoint) - self bounds topLeft].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:50'!
saveAsPrototype
	(SelectionMenu confirm: 'Make this morph the prototype for ', self class printString, '?')
		ifFalse: [^ self].
	self class prototype: self.
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 9/27/2005 20:29'!
showActions
	"Put up a message list browser of all the code that this morph  
	would run for mouseUp, mouseDown, mouseMove, mouseEnter,  
	mouseLeave, and  
	mouseLinger. tk 9/13/97"
	| list cls selector adder |
	list := SortedCollection new.
	adder := [:mrClass :mrSel | list
				add: (MethodReference new setStandardClass: mrClass methodSymbol: mrSel)].
	"the eventHandler"
	self eventHandler
		ifNotNil: [list := self eventHandler methodRefList.
			(self eventHandler handlesMouseDown: nil)
				ifFalse: [adder value: HandMorph value: #grabMorph:]].
	"If not those, then non-default raw events"
	#(#keyStroke: #mouseDown: #mouseEnter: #mouseLeave: #mouseMove: #mouseUp: #doButtonAction )
		do: [:sel | 
			cls := self class whichClassIncludesSelector: sel.
			cls
				ifNotNil: ["want more than default behavior"
					cls == Morph
						ifFalse: [adder value: cls value: sel]]].
	"The mechanism on a Button"
	(self respondsTo: #actionSelector)
		ifTrue: ["A button"
			selector := self actionSelector.
			cls := self target class whichClassIncludesSelector: selector.
			cls
				ifNotNil: ["want more than default behavior"
					cls == Morph
						ifFalse: [adder value: cls value: selector]]].
	ToolSet openMessageList: list name: 'Actions of ' , self printString autoSelect: false! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 19:21'!
showHiders
	self allMorphsDo:[:m | m show]! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/13/2006 22:09'!
sightTargets: event 
	"Return the potential targets for the receiver.  
	This is derived from Morph>>potentialEmbeddingTargets."
	| bullseye |
	owner
		ifNil: [^ #()].
	bullseye := Point fromUserWithCursor: Cursor target.
	self targetFromMenu: (self potentialTargetsAt: bullseye) asKnownNameMenu popupAt: bullseye! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/13/2006 22:10'!
sightWorldTargets: event 
	"Return the potential targets for the receiver.  
	This is derived from Morph>>potentialEmbeddingTargets."
	| bullseye myWorld |
	myWorld := self world
		ifNil: [^ #()].
	bullseye := Point fromUserWithCursor: Cursor target.
	self targetFromMenu: ( myWorld morphsAt: bullseye) asKnownNameMenu popupAt: bullseye! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:50'!
subclassMorph
	"Create a new subclass of this morph's class and make this morph be an instance of it."

	| oldClass newClassName newClass newMorph |
	oldClass _ self class.
	newClassName _ FillInTheBlank
		request: 'Please give this new class a name'
		initialAnswer: oldClass name.
	newClassName = '' ifTrue: [^ self].
	(Smalltalk includesKey: newClassName)
		ifTrue: [^ self inform: 'Sorry, there is already a class of that name'].

	newClass _ oldClass subclass: newClassName asSymbol
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: oldClass category asString.
	newMorph _ self as: newClass.
	self become: newMorph.
! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/20/2004 01:25'!
targetFromMenu: aMenu 
	"Some other morph become target of the receiver"
	| newTarget |
	
	newTarget := aMenu startUpWithCaption: self externalName , ' targets...'.
	newTarget
		ifNil: [^ self].
	self target: newTarget! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/20/2004 12:22'!
targetFromMenu: aMenu popupAt: aPoint 
	"Some other morph become target of the receiver"
	| newTarget |
	newTarget := aMenu startUpWithCaption: self externalName , ' targets... '
	at: aPoint .
	"self halt ."
	newTarget
		ifNil: [^ self].
	self target: newTarget! !

!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/17/2004 23:27'!
targetWith: evt
	"Some other morph become target of the receiver"
	|  menu newTarget |
	menu _ CustomMenu new.
	self potentialTargets  do: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) action: m].
	newTarget _ menu startUpWithCaption: ( self externalName, ' targets...').
	newTarget ifNil:[^self].
	self target: newTarget.! !


!Morph methodsFor: 'miscellaneous' stamp: 'dgd 9/27/2004 12:12'!
roundUpStrays
	self submorphs
		do: [:each | each roundUpStrays]! !

!Morph methodsFor: 'miscellaneous' stamp: 'sw 7/20/2001 00:15'!
setExtentFromHalo: anExtent
	"The user has dragged the grow box such that the receiver's extent would be anExtent.  Do what's needed"

	self extent: anExtent! !

!Morph methodsFor: 'miscellaneous' stamp: 'sw 2/2/2006 00:43'!
setFlexExtentFromHalo: anExtent
	"The user has dragged the grow box such that the receiver's extent would be anExtent.  Do what's needed.  Set the extent of the top renderer as indicated."

	self addFlexShellIfNecessary.
	self topRendererOrSelf extent: anExtent! !


!Morph methodsFor: 'naming' stamp: 'fc 4/27/2004 21:58'!
choosePartName
	"Pick an unused name for this morph."
	| className |
	self world ifNil: [^nil].
	(self world model isKindOf: Component) ifTrue:
		[self knownName ifNil: [^ self nameMeIn: self world]
					ifNotNil: [^ self renameMe]].
	className _ self class name.
	(className size > 5 and: [className endsWith: 'Morph'])
		ifTrue: [className _ className copyFrom: 1 to: className size - 5].
	^ self world model addPartNameLike: className withValue: self! !

!Morph methodsFor: 'naming' stamp: 'sw 10/31/2000 09:28'!
downshiftedNameOfObjectRepresented
	"Answer the downshiped version of the external name of the object represented"

	^ self nameOfObjectRepresented asLowercase! !

!Morph methodsFor: 'naming' stamp: 'dgd 8/30/2003 15:52'!
innocuousName
	"Choose an innocuous name for the receiver -- one that does not end in the word Morph"

	| className allKnownNames |
	className _ self defaultNameStemForInstances.
	(className size > 5 and: [className endsWith: 'Morph'])
		ifTrue: [className _ className copyFrom: 1 to: className size - 5].
	className _ className asString translated.
	allKnownNames _ self world ifNil: [OrderedCollection new] ifNotNil: [self world allKnownNames].
	^ Utilities keyLike: className asString satisfying:
		[:aName | (allKnownNames includes: aName) not]! !

!Morph methodsFor: 'naming' stamp: 'sw 9/21/2000 13:18'!
nameForFindWindowFeature
	"Answer the name to show in a list of windows-and-morphs to represent the receiver"

	^ self knownName ifNil: [self class name]! !

!Morph methodsFor: 'naming' stamp: 'dgd 2/22/2003 14:33'!
nameInModel
	"Return the name for this morph in the underlying model or nil."

	| w |
	w := self world.
	w isNil ifTrue: [^nil] ifFalse: [^w model nameFor: self]! !

!Morph methodsFor: 'naming' stamp: 'sw 10/31/2000 09:24'!
nameOfObjectRepresented
	"Answer the external name of the object represented"

	^ self externalName! !

!Morph methodsFor: 'naming' stamp: 'gm 2/22/2003 13:16'!
name: aName 
	(aName isString) ifTrue: [self setNameTo: aName]! !

!Morph methodsFor: 'naming' stamp: 'dgd 2/16/2003 21:57'!
setNamePropertyTo: aName 
	"change the receiver's externalName"
	self assureExtension externalName: aName! !

!Morph methodsFor: 'naming' stamp: 'yo 12/3/2004 17:02'!
setNameTo: aName 
	| nameToUse nameString |
	nameToUse := aName ifNotNil: 
					[(nameString := aName asString) notEmpty ifTrue: [nameString] ifFalse: ['*']].
	self setNamePropertyTo: nameToUse	"no Texts here!!"! !

!Morph methodsFor: 'naming' stamp: 'gm 2/22/2003 13:16'!
specialNameInModel
	"Return the name for this morph in the underlying model or nil."

	"Not an easy problem.  For now, take the first part of the mouseDownSelector symbol in my eventHandler (fillBrushMouseUp:morph: gives 'fillBrush').  5/26/97 tk"

	| hh |
	(self isMorphicModel) 
		ifTrue: [^self slotName]
		ifFalse: 
			[self eventHandler ifNotNil: 
					[self eventHandler mouseDownSelector ifNotNil: 
							[hh := self eventHandler mouseDownSelector indexOfSubCollection: 'Mouse'
										startingAt: 1.
							hh > 0 
								ifTrue: [^self eventHandler mouseDownSelector copyFrom: 1 to: hh - 1]].
					self eventHandler mouseUpSelector ifNotNil: 
							[hh := self eventHandler mouseUpSelector indexOfSubCollection: 'Mouse'
										startingAt: 1.
							hh > 0 ifTrue: [^self eventHandler mouseUpSelector copyFrom: 1 to: hh - 1]]]].

	"	(self eventHandler mouseDownRecipient respondsTo: #nameFor:) ifTrue: [
					^ self eventHandler mouseDownRecipient nameFor: self]]].	"
	"myModel _ self findA: MorphicModel.
			myModel ifNotNil: [^ myModel slotName]"
	^self world specialNameInModelFor: self! !

!Morph methodsFor: 'naming' stamp: 'sw 10/27/2000 17:47'!
tryToRenameTo: aName
	"A new name has been submited; make sure it's appropriate, and react accordingly.  This circumlocution provides the hook by which the simple renaming of a field can result in a change to variable names in a stack, etc.  There are some problems to worry about here."

	| aStack |
	(self holdsSeparateDataForEachInstance and: [(aStack _ self stack) notNil])
		ifTrue:
			[self topRendererOrSelf setNameTo: aName.
			aStack reassessBackgroundShape]
		ifFalse:
			[self renameTo: aName]! !

!Morph methodsFor: 'naming' stamp: 'sw 1/29/2001 02:49'!
updateAllScriptingElements
	"A sledge-hammer sweep from the world down to make sure that all live scripting elements are up to date.  Presently in eclipse, not sent at the moment."

	| aPasteUp |
	(aPasteUp _ self topPasteUp) ifNotNil:
		[aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]]! !


!Morph methodsFor: 'objects from disk' stamp: 'tk 11/26/2004 06:02'!
convertToCurrentVersion: varDict refStream: smartRefStrm

	(varDict at: #ClassName) == #DropShadowMorph ifTrue: [
		varDict at: #ClassName put: #Morph.	"so we don't
repeat this"
		^ self convertNovember2000DropShadow: varDict using:
smartRefStrm
			"always returns a new object of a different class"
	].
	varDict at: 'costumee' ifPresent: [ :x |
		self convertAugust1998: varDict using: smartRefStrm].
		"never returns a different object"

	"5/18/2000"
	varDict at: 'openToDragNDrop' ifPresent: [ :x | self
enableDragNDrop: x ].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.


! !

!Morph methodsFor: 'objects from disk' stamp: 'dgd 2/22/2003 14:33'!
objectForDataStream: refStrm 
	"I am being written out on an object file"

	| dp |
	self sqkPage ifNotNil: 
			[refStrm rootObject == self | (refStrm rootObject == self sqkPage) 
				ifFalse: 
					[self url notEmpty 
						ifTrue: 
							[dp := self sqkPage copyForSaving.	"be careful touching this object!!"
							refStrm replace: self with: dp.
							^dp]]].
	self prepareToBeSaved.	"Amen"
	^self! !

!Morph methodsFor: 'objects from disk' stamp: 'tk 7/11/1998 18:53'!
storeDataOn: aDataStream
	"Let all Morphs be written out.  All owners are weak references.  They only go out if the owner is in the tree being written."
	| cntInstVars cntIndexedVars ti localInstVars |

	"block my owner unless he is written out by someone else"
	cntInstVars _ self class instSize.
	cntIndexedVars _ self basicSize.
	localInstVars _ Morph instVarNames.
	ti _ 2.  
	((localInstVars at: ti) = 'owner') & (Morph superclass == Object) ifFalse:
			[self error: 'this method is out of date'].
	aDataStream
		beginInstance: self class
		size: cntInstVars + cntIndexedVars.
	1 to: ti-1 do:
		[:i | aDataStream nextPut: (self instVarAt: i)].
	aDataStream nextPutWeak: owner.	"owner only written if in our tree"
	ti+1 to: cntInstVars do:
		[:i | aDataStream nextPut: (self instVarAt: i)].
	1 to: cntIndexedVars do:
		[:i | aDataStream nextPut: (self basicAt: i)]! !


!Morph methodsFor: 'other events' stamp: 'sw 8/1/2001 14:08'!
menuButtonMouseEnter: event
	"The mouse entered a menu-button area; show the menu cursor temporarily"

	event hand showTemporaryCursor: Cursor menu! !

!Morph methodsFor: 'other events' stamp: 'sw 8/1/2001 14:09'!
menuButtonMouseLeave: event
	"The mouse left a menu-button area; restore standard cursor"

	event hand showTemporaryCursor: nil! !


!Morph methodsFor: 'parts bin' stamp: 'sw 8/12/2001 02:07'!
initializeToStandAlone
	"Set up the receiver, created by a #basicNew and now ready to be initialized, as a fully-formed morph suitable for providing a graphic for a parts bin surrogate, and, when such a parts-bin surrogate is clicked on, for attaching to the hand as a viable stand-alone morph.  Because of historical precedent, #initialize has been expected to handle this burden, though a great number of morphs actually cannot stand alone.  In any case, by default we call the historical #initialize, though unhappily, so that all existing morphs will work no worse than before when using this protocol."

	self initialize! !

!Morph methodsFor: 'parts bin' stamp: 'di 11/13/2000 00:49'!
inPartsBin

	self isPartsDonor ifTrue: [^ true].
	self allOwnersDo: [:m | m isPartsBin ifTrue: [^ true]].
	^ false
! !

!Morph methodsFor: 'parts bin' stamp: 'sw 8/12/97 14:16'!
isPartsBin
	^ false! !

!Morph methodsFor: 'parts bin' stamp: 'md 2/27/2006 09:53'!
isPartsDonor
	"answer whether the receiver is PartsDonor"
	extension ifNil: [^ false].
	^ extension isPartsDonor! !

!Morph methodsFor: 'parts bin' stamp: 'md 2/27/2006 09:59'!
isPartsDonor: aBoolean 
	"change the receiver's isPartDonor property"
	(extension isNil and: [aBoolean not]) ifTrue: [^ self].
	self assureExtension isPartsDonor: aBoolean! !

!Morph methodsFor: 'parts bin' stamp: 'di 8/11/1998 13:02'!
markAsPartsDonor
	"Mark the receiver specially so that mouse actions on it are interpreted as 'tearing off a copy'"

	self isPartsDonor: true! !

!Morph methodsFor: 'parts bin' stamp: 'ar 10/6/2000 22:45'!
partRepresented
	^self! !

!Morph methodsFor: 'parts bin' stamp: 'sw 4/22/1998 14:45'!
residesInPartsBin
	"Answer true if the receiver is, or has some ancestor owner who is, a parts bin"
	^ owner ifNotNil: [owner residesInPartsBin] ifNil: [false]! !


!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
choosePenColor: evt
	self assuredPlayer choosePenColor: evt! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
choosePenSize
	self assuredPlayer choosePenSize! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:53'!
getPenColor
	^ self player ifNotNil: [self actorState getPenColor] ifNil: [Color green]! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:53'!
getPenDown
	self player ifNil: [^ false].
	^ self actorState getPenDown! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:53'!
getPenSize
	self player ifNil: [^ 1].
	^ self actorState getPenSize! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
liftPen
	self assuredPlayer liftPen! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
lowerPen
	self assuredPlayer lowerPen! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
penColor: aColor
	self assuredPlayer penColor: aColor! !

!Morph methodsFor: 'pen' stamp: 'di 9/3/1998 10:38'!
penUpWhile: changeBlock 
	"Suppress any possible pen trail during the execution of changeBlock"
	self getPenDown
		ifTrue: ["If this is a costume for a player with its pen down, suppress any line."
				self liftPen.
				changeBlock value.
				self lowerPen]
		ifFalse: ["But usually, just do it."
				changeBlock value]! !

!Morph methodsFor: 'pen' stamp: 'dgd 2/22/2003 14:36'!
trailMorph
	"You can't draw trails on me, but try my owner."

	owner isNil ifTrue: [^nil].
	^owner trailMorph! !


!Morph methodsFor: 'printing' stamp: 'bf 7/17/2003 12:53'!
clipText
	"Copy the text in the receiver or in its submorphs to the clipboard"
	| content |
	"My own text"
	content _ self userString.
	"Or in my submorphs"
	content ifNil: [
		| list |
		list _ self allStringsAfter: nil.
		list notEmpty ifTrue: [
			content _ String streamContents: [:stream |
				list do: [:each | stream nextPutAll: each; cr]]]].
	"Did we find something?"
	content
		ifNil: [self flash "provide feedback"]
		ifNotNil: [Clipboard clipboardText: content].! !

!Morph methodsFor: 'printing' stamp: 'dgd 2/22/2003 14:27'!
colorString: aColor 
	aColor isNil ifTrue: [^'nil'].
	Color colorNames 
		do: [:colorName | aColor = (Color perform: colorName) ifTrue: [^'Color ' , colorName]].
	^aColor storeString! !

!Morph methodsFor: 'printing'!
constructorString

	^ String streamContents: [:s | self printConstructorOn: s indent: 0].
! !

!Morph methodsFor: 'printing'!
fullPrintOn: aStream

	aStream nextPutAll: self class name , ' newBounds: (';
		print: bounds;
		nextPutAll: ') color: ' , (self colorString: color)! !

!Morph methodsFor: 'printing'!
initString

	^ String streamContents: [:s | self fullPrintOn: s]! !

!Morph methodsFor: 'printing' stamp: 'RAA 2/26/2001 07:22'!
morphReport

	^self morphReportFor: #(hResizing vResizing bounds)! !

!Morph methodsFor: 'printing' stamp: 'RAA 2/25/2001 17:47'!
morphReportFor: attributeList

	| s |

	s _ WriteStream on: String new.
	self
		morphReportFor: attributeList 
		on: s 
		indent: 0.
	StringHolder new contents: s contents; openLabel: 'morph report'! !

!Morph methodsFor: 'printing' stamp: 'RAA 2/25/2001 17:48'!
morphReportFor: attributeList on: aStream indent: anInteger

	anInteger timesRepeat: [aStream tab].
	aStream print: self; space.
	attributeList do: [ :a | aStream print: (self perform: a); space].
	aStream cr.
	submorphs do: [ :sub |
		sub morphReportFor: attributeList on: aStream indent: anInteger + 1
	].! !

!Morph methodsFor: 'printing' stamp: 'RAA 2/1/2001 17:42'!
pagesHandledAutomatically

	^false! !

!Morph methodsFor: 'printing'!
printConstructorOn: aStream indent: level

	^ self printConstructorOn: aStream indent: level nodeDict: IdentityDictionary new
! !

!Morph methodsFor: 'printing'!
printConstructorOn: aStream indent: level nodeDict: nodeDict
	| nodeString |
	(nodeString _ nodeDict at: self ifAbsent: [nil])
		ifNotNil: [^ aStream nextPutAll: nodeString].
	submorphs isEmpty ifFalse: [aStream nextPutAll: '('].
	aStream nextPutAll: '('.
	self fullPrintOn: aStream.
	aStream nextPutAll: ')'.
	submorphs isEmpty ifTrue: [^ self].
	submorphs size <= 4
	ifTrue:
		[aStream crtab: level+1;
			nextPutAll: 'addAllMorphs: (Array'.
		1 to: submorphs size do:
			[:i | aStream crtab: level+1; nextPutAll: 'with: '.
			(submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict].
		aStream nextPutAll: '))']
	ifFalse:
		[aStream crtab: level+1;
			nextPutAll: 'addAllMorphs: ((Array new: ', submorphs size printString, ')'.
		1 to: submorphs size do:
			[:i |
			aStream crtab: level+1; nextPutAll: 'at: ', i printString, ' put: '.
			(submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict.
			aStream nextPutAll: ';'].
		aStream crtab: level+1; nextPutAll: 'yourself))']! !

!Morph methodsFor: 'printing' stamp: 'dgd 2/22/2003 19:05'!
printOn: aStream 
	| aName |
	super printOn: aStream.
	(aName := self knownName) notNil 
		ifTrue: [aStream nextPutAll: '<' , aName , '>'].
	aStream nextPutAll: '('.
	aStream
		print: self identityHash;
		nextPutAll: ')'! !

!Morph methodsFor: 'printing' stamp: 'RAA 9/18/2000 10:22'!
printSpecs

	| printSpecs |

	printSpecs _ self valueOfProperty: #PrintSpecifications.
	printSpecs ifNil: [
		printSpecs _ PrintSpecifications defaultSpecs.
		self printSpecs: printSpecs.
	].
	^printSpecs! !

!Morph methodsFor: 'printing' stamp: 'RAA 9/18/2000 10:21'!
printSpecs: aPrintSecification

	self setProperty: #PrintSpecifications toValue: aPrintSecification.
! !

!Morph methodsFor: 'printing' stamp: 'jm 5/28/1998 18:00'!
printStructureOn: aStream indent: tabCount

	tabCount timesRepeat: [aStream tab].
	self printOn: aStream.
	aStream cr.
	self submorphsDo: [:m | m printStructureOn: aStream indent: tabCount + 1].
! !

!Morph methodsFor: 'printing' stamp: 'sw 10/27/2000 17:45'!
reportableSize
	"Answer a size worth reporting as the receiver's size in a list view"

	| total |
	total _ super reportableSize.
	submorphs do:
		[:m | total _ total + m reportableSize].
	^ total! !

!Morph methodsFor: 'printing' stamp: 'jm 5/28/1998 17:58'!
structureString
	"Return a string that showing this morph and all its submorphs in an indented list that reflects its structure."

	| s |
	s _ WriteStream on: (String new: 1000).
	self printStructureOn: s indent: 0.
	^ s contents
! !

!Morph methodsFor: 'printing' stamp: 'sw 10/27/2000 17:47'!
textToPaste
	"If the receiver has text to offer pasting, answer it, else answer nil"

	^ nil! !


!Morph methodsFor: 'rotate scale and flex' stamp: 'sw 3/30/2005 03:44'!
addFlexShell
	"Wrap a rotating and scaling shell around this morph."

	| oldHalo flexMorph myWorld anIndex |

	myWorld _ self world.
	oldHalo _ self halo.
	anIndex _ self owner submorphIndexOf: self.
	self owner addMorph: (flexMorph _ self newTransformationMorph asFlexOf: self)
		asElementNumber: anIndex.
	self transferStateToRenderer: flexMorph.
	oldHalo ifNotNil: [oldHalo setTarget: flexMorph].
	myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: flexMorph].

	^ flexMorph! !

!Morph methodsFor: 'rotate scale and flex' stamp: 'di 11/28/2001 18:22'!
addFlexShellIfNecessary
	"If this morph requires a flex shell to scale or rotate,
		then wrap it in one and return it.
	Polygons, eg, may override to return themselves."

	^ self addFlexShell! !

!Morph methodsFor: 'rotate scale and flex' stamp: 'ar 11/24/1998 14:19'!
keepsTransform
	"Return true if the receiver will keep it's transform while being grabbed by a hand."
	^false! !

!Morph methodsFor: 'rotate scale and flex' stamp: 'ar 2/16/1999 18:59'!
newTransformationMorph
	^TransformationMorph new! !

!Morph methodsFor: 'rotate scale and flex' stamp: 'mu 3/29/2004 17:33'!
removeFlexShell
	self isFlexed
		ifTrue: [self owner removeFlexShell]! !

!Morph methodsFor: 'rotate scale and flex' stamp: 'jm 4/25/1998 05:19'!
rotationDegrees
	"Default implementation."

	^ 0.0
! !


!Morph methodsFor: 'rounding' stamp: 'mk 8/7/2005 10:03'!
cornerStyle: aSymbol
	"This method makes it possible to set up desired corner style. aSymbol has to be one of:
		#square
		#rounded"

	aSymbol == #square
		ifTrue:[self removeProperty: #cornerStyle]
		ifFalse:[self setProperty: #cornerStyle toValue: aSymbol].
	self changed! !

!Morph methodsFor: 'rounding' stamp: 'mk 8/14/2005 13:31'!
roundedCorners
	"Return a list of those corners to round.

		1-4
		|  |
		2-3

	Returned array contains `codes' of those corners, which should be rounded.

	1 denotes top-left corner
	2 denotes bottom-left corner
	3 denotes bottom-right corner
	4 denotes top-right corner.

	Thus, if this method returned #(2 3) that would mean that bottom (left and right)
	corners would be rounded whereas top (left and right) corners wouldn't be rounded.

	This method returns #(1 2 3 4) and that means that all the corners should be rounded."

	^ #(1 2 3 4)! !

!Morph methodsFor: 'rounding' stamp: 'dgd 9/6/2003 18:27'!
roundedCornersString
	"Answer the string to put in a menu that will invite the user to 
	switch to the opposite corner-rounding mode"
	^ (self wantsRoundedCorners
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'round corners' translated! !

!Morph methodsFor: 'rounding' stamp: 'ar 12/25/2001 19:44'!
toggleCornerRounding
	self cornerStyle == #rounded
		ifTrue: [self cornerStyle: #square]
		ifFalse: [self cornerStyle: #rounded].
	self changed! !

!Morph methodsFor: 'rounding' stamp: 'ar 12/22/2001 22:45'!
wantsRoundedCorners
	"Return true if the receiver wants its corners rounded"
	^ self cornerStyle == #rounded! !






!Morph methodsFor: 'scripting' stamp: 'dgd 7/4/2004 12:41'!
arrowDeltaFor: aGetSelector 
	"Answer a number indicating the default arrow delta to be  
	used in a numeric readout with the given get-selector. This is  
	a hook that subclasses of Morph can reimplement."
	aGetSelector == #getScaleFactor
		ifTrue: [^ 0.1].
	^ 1! !

!Morph methodsFor: 'scripting' stamp: 'ar 1/25/2001 12:50'!
asEmptyPermanentScriptor
	"Answer a new empty permanent scriptor derived from info deftly secreted in the receiver.  Good grief"

	| aScriptor aPlayer |
	aPlayer _ self valueOfProperty: #newPermanentPlayer.
	aPlayer assureUniClass.
	aScriptor _  aPlayer newScriptorAround: nil.
	aScriptor position: (self world primaryHand position - (10 @ 10)).
	aPlayer updateAllViewersAndForceToShow: #scripts.
	^ aScriptor! !

!Morph methodsFor: 'scripting' stamp: 'sw 10/17/2001 09:46'!
bringTileScriptingElementsUpToDate
	"Send #bringUpToDate to every tile-scripting element of the receiver, including possibly the receiver itself"

	(self allMorphs select: [:s | s isTileScriptingElement]) do:
		[:el | el bringUpToDate]! !

!Morph methodsFor: 'scripting' stamp: 'RAA 3/9/2001 11:39'!
bringUpToDate

	(self buttonProperties ifNil: [^self]) bringUpToDate! !

!Morph methodsFor: 'scripting' stamp: 'sw 7/19/2005 01:55'!
defaultFloatPrecisionFor: aGetSelector
	"Answer a number indicating the default float precision to be used in a numeric readout for which the receiver provides the data.   Individual morphs can override this.  Showing fractional values for readouts of getCursor was in response to an explicit request from ack"

	(self renderedMorph decimalPlacesForGetter: aGetSelector) ifNotNilDo: [:places | ^ (Utilities floatPrecisionForDecimalPlaces: places)].

	(#(getCursor getNumericValue getNumberAtCursor getCursorWrapped getScaleFactor getUnitVector getAlpha) includes: aGetSelector)
		ifTrue:
			[^ 0.01].
	^ 1! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/12/2005 13:26'!
filterViewerCategoryDictionary: dict
	"dict has keys of categories and values of priority.
	You can re-order or remove categories here."

	self wantsConnectionVocabulary
		ifFalse: [ dict removeKey: #'connections to me' ifAbsent: [].
			dict removeKey: #connection ifAbsent: []].
	self wantsConnectorVocabulary
		ifFalse: [ dict removeKey: #connector ifAbsent: [] ].
	self wantsEmbeddingsVocabulary
		ifFalse: [dict removeKey: #embeddings ifAbsent: []].
	Preferences eToyFriendly
		ifTrue:
			[dict removeKey: #layout ifAbsent: []].
	(Preferences eToyFriendly or: [self isWorldMorph not]) ifTrue:
		[dict removeKey: #preferences ifAbsent: []].! !

!Morph methodsFor: 'scripting' stamp: 'tk 10/1/97 18:23'!
isTileLike
	"Cannot be dropped into a script"
	^ false! !

!Morph methodsFor: 'scripting' stamp: 'RAA 3/9/2001 11:47'!
isTileScriptingElement

	^ self hasButtonProperties and: [self buttonProperties isTileScriptingElement]! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/11/1998 16:53'!
jettisonScripts
	self player ifNotNil: [self player class jettisonScripts]! !

!Morph methodsFor: 'scripting' stamp: 'LC 9/28/1999 21:57'!
makeAllTilesColored
	self allMorphsDo: 
		[:m | m restoreTypeColor]! !

!Morph methodsFor: 'scripting' stamp: 'LC 9/28/1999 21:57'!
makeAllTilesGreen
	self allMorphsDo: 
		[:m | m useUniformTileColor]! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/11/1998 16:59'!
restoreTypeColor
	self player ifNotNil: [self player allScriptEditors do:
		[:anEditor | anEditor allMorphsDo:
			[:m | m restoreTypeColor]]]! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/11/1998 16:46'!
scriptEditorFor: aScriptName
	^ self assuredPlayer scriptEditorFor: aScriptName! !

!Morph methodsFor: 'scripting' stamp: 'sw 7/5/2005 00:31'!
tearOffTile
	"Tear off a tile representing the player associated with the receiver.  This is obtained from the top renderer"

	^ self topRendererOrSelf assuredPlayer tearOffTileForSelf! !

!Morph methodsFor: 'scripting' stamp: 'nk 8/21/2004 12:17'!
triggerScript: aSymbol
	"Have my player perform the script of the given name, which is guaranteed to exist."

	^self assuredPlayer triggerScript: aSymbol! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/11/1998 16:55'!
useUniformTileColor
	self player ifNotNil:
		[self player allScriptEditors do:
			[:anEditor | anEditor allMorphsDo:
				[:m | m useUniformTileColor]]]! !

!Morph methodsFor: 'scripting' stamp: 'sw 10/18/2000 10:32'!
viewAfreshIn: aPasteUp showingScript: aScriptName at: aPosition
	"Obtain a smartly updated ScriptEditor for the given script name and zap it into place at aPosition"

	| anEditor |
	self player updateAllViewersAndForceToShow: #scripts.
	anEditor _ self player scriptEditorFor: aScriptName.
	aPasteUp ifNotNil: [aPasteUp addMorph: anEditor].
	anEditor position: aPosition.
	anEditor currentWorld startSteppingSubmorphsOf: anEditor! !

!Morph methodsFor: 'scripting' stamp: 'nk 8/21/2004 08:39'!
wantsConnectionVocabulary
	submorphs ifNil: [ ^true ].	"called from EToyVocabulary>>initialize after basicNew"

	^ (Preferences valueOfFlag: #alwaysShowConnectionVocabulary)
		or: [ self connections isEmpty not ]! !



!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:27'!
arrangeToStartStepping
	"Arrange to start getting sent the 'step' message, but don't do that initial #step call that startStepping does"

	self arrangeToStartSteppingIn: self world! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:26'!
arrangeToStartSteppingIn: aWorld
	"Start getting sent the 'step' message in aWorld.  Like startSteppingIn:, but without the initial one to get started'"
	aWorld ifNotNil:
		[aWorld startStepping: self.
		self changed]! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:28'!
isStepping
	"Return true if the receiver is currently stepping in its world"
	| aWorld |
	^ (aWorld _ self world)
		ifNil:		[false]
		ifNotNil:	[aWorld isStepping: self]! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:43'!
isSteppingSelector: aSelector
	"Return true if the receiver is currently stepping in its world"
	| aWorld |
	^ (aWorld _ self world)
		ifNil:		[false]
		ifNotNil:	[aWorld isStepping: self selector: aSelector]! !

!Morph methodsFor: 'stepping and presenter'!
start
	"Start running my script. For ordinary morphs, this means start stepping."

	self startStepping.
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 1/31/2001 13:07'!
startStepping
	"Start getting sent the 'step' message."
	self startStepping: #stepAt: at: Time millisecondClockValue arguments: nil stepTime: nil.! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 7/19/1998 11:51'!
startSteppingIn: aWorld
	"Start getting sent the 'step' message in aWorld"

	self step.  "one to get started!!"
	aWorld ifNotNil: [aWorld startStepping: self].
	self changed! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:42'!
startSteppingSelector: aSelector
	"Start getting sent the 'step' message."
	self startStepping: aSelector at: Time millisecondClockValue arguments: nil stepTime: nil.! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:36'!
startStepping: aSelector at: scheduledTime arguments: args stepTime: stepTime
	"Start stepping the receiver"
	| w |
	w _ self world.
	w ifNotNil: [
		w startStepping: self at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.
		self changed].! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 2/12/2001 17:04'!
step
	"Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message.  The generic version dispatches control to the player, if any.  The nasty circumlocation about owner's transformation is necessitated by the flexing problem that the player remains in the properties dictionary both of the flex and the real morph.  In the current architecture, only the top renderer's pointer to the player should actually be honored for the purpose of firing."
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 2/12/2001 18:05'!
stepAt: millisecondClockValue
	"Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message.
	The millisecondClockValue parameter gives the value of the millisecond clock at the moment of dispatch.
	Default is to dispatch to the parameterless step method for the morph, but this protocol makes it possible for some morphs to do differing things depending on the clock value"
	self player ifNotNilDo:[:p| p stepAt: millisecondClockValue].
	self step
! !

!Morph methodsFor: 'stepping and presenter'!
stop
	"Stop running my script. For ordinary morphs, this means stop stepping."

	self stopStepping.
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 12/15/2000 00:00'!
stopStepping
	"Stop getting sent the 'step' message."

	| w |
	w _ self world.
	w ifNotNil: [w stopStepping: self].
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 12/15/2000 00:00'!
stopSteppingSelector: aSelector
	"Stop getting sent the given message."
	| w |
	w _ self world.
	w ifNotNil: [w stopStepping: self selector: aSelector].
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 10/11/1999 12:59'!
stopSteppingSelfAndSubmorphs
	self allMorphsDo: [:m | m stopStepping]
! !


!Morph methodsFor: 'structure' stamp: 'ar 3/18/2001 00:11'!
activeHand
	^ActiveHand! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 01:00'!
allOwners
	"Return the owners of the reciever"

	^ Array streamContents: [:strm | self allOwnersDo: [:m | strm nextPut: m]]! !

!Morph methodsFor: 'structure' stamp: 'ar 9/14/2000 16:47'!
allOwnersDo: aBlock
	"Evaluate aBlock with all owners of the receiver"
	owner ifNotNil:[^owner withAllOwnersDo: aBlock].! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:48'!
firstOwnerSuchThat: conditionBlock

	self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]].
	^ nil
! !

!Morph methodsFor: 'structure' stamp: 'ar 10/3/2000 15:36'!
hasOwner: aMorph
	"Return true if the receiver has aMorph in its owner chain"
	aMorph ifNil:[^true].
	self allOwnersDo:[:m| m = aMorph ifTrue:[^true]].
	^false! !

!Morph methodsFor: 'structure' stamp: 'dgd 9/1/2004 17:17'!
isInDockingBar
	"answer if the receiver is in a menu bar"
	^ (owner notNil) and: [owner isDockingBar]! !

!Morph methodsFor: 'structure' stamp: 'dgd 9/18/2004 15:56'!
isInSystemWindow
	"answer if the receiver is in a system window"
	^ owner isMorph and:[owner isSystemWindow or:[owner isInSystemWindow]]! !

!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:05'!
isInWorld
	"Return true if this morph is in a world."

	^self world notNil! !

!Morph methodsFor: 'structure' stamp: 'sw 8/29/2000 14:55'!
morphPreceding: aSubmorph
	"Answer the morph immediately preceding aSubmorph, or nil if none"

	| anIndex |
	anIndex _ submorphs indexOf: aSubmorph ifAbsent: [^ nil].
	^ anIndex > 1
		ifTrue:
			[submorphs at: (anIndex - 1)]
		ifFalse:
			[nil]! !

!Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:13'!
nearestOwnerThat: conditionBlock
	"Return the first enclosing morph for which aBlock evaluates to true, or nil if none"

	^ self firstOwnerSuchThat: conditionBlock
! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:49'!
orOwnerSuchThat: conditionBlock

	(conditionBlock value: self) ifTrue: [^ self].
	self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]].
	^ nil

! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:50'!
outermostMorphThat: conditionBlock
	"Return the outermost containing morph for which aBlock is true, or nil if none"

	| outermost |
	self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [outermost _ m]].
	^ outermost! !

!Morph methodsFor: 'structure' stamp: 'ar 3/18/2001 00:12'!
outermostWorldMorph

	| outer |
	World ifNotNil:[^World].
	self flag: #arNote. "stuff below is really only for MVC"
	outer _ self outermostMorphThat: [ :x | x isWorldMorph].
	outer ifNotNil: [^outer].
	self isWorldMorph ifTrue: [^self].
	^nil! !

!Morph methodsFor: 'structure'!
owner
	"Returns the owner of this morph, which may be nil."

	^ owner! !

!Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:18'!
ownerThatIsA: aClass
	"Return the first enclosing morph that is a kind of aClass, or nil if none"

	^ self firstOwnerSuchThat: [:m | m isKindOf: aClass]! !

!Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:20'!
ownerThatIsA: firstClass orA: secondClass
	"Return the first enclosing morph that is a kind of one of the two classes given, or nil if none"

	^ self firstOwnerSuchThat: [:m | (m isKindOf: firstClass) or: [m isKindOf: secondClass]]! !

!Morph methodsFor: 'structure' stamp: 'sw 7/1/1998 18:02'!
pasteUpMorph
	"Answer the closest containing morph that is a PasteUp morph"
	^ self ownerThatIsA: PasteUpMorph! !

!Morph methodsFor: 'structure' stamp: 'dgd 8/28/2004 18:43'!
pasteUpMorphHandlingTabAmongFields
	"Answer the nearest PasteUpMorph in my owner chain that has the tabAmongFields property, or nil if none"

	| aPasteUp |
	aPasteUp _ self owner.
	[aPasteUp notNil] whileTrue:
		[aPasteUp tabAmongFields ifTrue:
			[^ aPasteUp].
		aPasteUp _ aPasteUp owner].
	^ nil! !

!Morph methodsFor: 'structure' stamp: 'RAA 6/13/2000 15:01'!
primaryHand

        | outer |
        outer _ self outermostWorldMorph ifNil: [^ nil].
        ^ outer activeHand ifNil: [outer firstHand]! !

!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:34'!
renderedMorph
	"If the receiver is a renderer morph, answer the rendered morph. Otherwise, answer the receiver. A renderer morph with no submorphs answers itself. See the comment in Morph>isRenderer."

	self isRenderer ifFalse: [^self].
	submorphs isEmpty ifTrue: [^self].
	^self firstSubmorph renderedMorph! !

!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:34'!
root
	"Return the root of the composite morph containing the receiver. The owner of the root is either nil, a WorldMorph, or a HandMorph. If the receiver's owner is nil, the root is the receiver itself. This method always returns a morph."

	(owner isNil or: [owner isWorldOrHandMorph]) ifTrue: [^self].
	^owner root! !

!Morph methodsFor: 'structure' stamp: 'di 8/4/1999 15:41'!
rootAt: location
	"Just return myself, unless I am a WorldWindow.
	If so, then return the appropriate root in that world"

	^ self! !

!Morph methodsFor: 'structure' stamp: 'sw 8/30/1998 09:47'!
topPasteUp
	"If the receiver is in a world, return that; otherwise return the outermost pasteup morph"
	^ self outermostMorphThat: [:m | m isKindOf: PasteUpMorph]! !

!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:06'!
topRendererOrSelf
	"Answer the topmost renderer for this morph, or this morph itself if it has no renderer. See the comment in Morph>isRenderer."

	| top topsOwner |
	owner ifNil: [^self].
	self isWorldMorph ifTrue: [^self].	"ignore scaling of this world"
	top := self.
	topsOwner := top owner.
	[topsOwner notNil and: [topsOwner isRenderer]] whileTrue: 
			[top := topsOwner.
			topsOwner := top owner].
	^top! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:59'!
withAllOwners
	"Return the receiver and all its owners"

	^ Array streamContents: [:strm | self withAllOwnersDo: [:m | strm nextPut: m]]! !

!Morph methodsFor: 'structure' stamp: 'ar 9/14/2000 16:48'!
withAllOwnersDo: aBlock
	"Evaluate aBlock with the receiver and all of its owners"
	aBlock value: self.
	owner ifNotNil:[^owner withAllOwnersDo: aBlock].! !

!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:36'!
world
	^owner isNil ifTrue: [nil] ifFalse: [owner world]! !


!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 12:50'!
allKnownNames
	"Return a list of all known names based on the scope of the receiver.  Does not include the name of the receiver itself.  Items in parts bins are excluded.  Reimplementors (q.v.) can extend the list"

	^ Array streamContents:
		[:s | self allSubmorphNamesDo: [:n | s nextPut: n]]
! !

!Morph methodsFor: 'submorphs-accessing'!
allMorphs
	"Return a collection containing all morphs in this composite morph (including the receiver)."

	| all |
	all _ OrderedCollection new: 100.
	self allMorphsDo: [: m | all add: m].
	^ all! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:27'!
allMorphsDo: aBlock 
	"Evaluate the given block for all morphs in this composite morph (including the receiver)."

	submorphs do: [:m | m allMorphsDo: aBlock].
	aBlock value: self! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 10/31/97 20:05'!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy (put in primarily for bookmorphs)"

	^ OrderedCollection new! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 12:44'!
allSubmorphNamesDo: nameBlock
	"Return a list of all known names of submorphs and nested submorphs of the receiver, based on the scope of the receiver.  Items in parts bins are excluded"

	self isPartsBin ifTrue: [^ self]. "Don't report names from parts bins"
	self submorphsDo: 
		[:m | m knownName ifNotNilDo: [:n | nameBlock value: n].
		m allSubmorphNamesDo: nameBlock].
! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 8/31/2004 16:53'!
dockingBars
	"Answer the receiver's dockingBars"
	^ self submorphs
		select: [:each | each isDockingBar]
! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'rhi 9/10/2000 12:12'!
findA: aClass
	"Return the first submorph of the receiver that is descended from the given class. Return nil if there is no such submorph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."

	^self submorphs
		detect: [:p | p isKindOf: aClass]
		ifNone: [nil]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 1/9/2001 12:30'!
findDeeplyA: aClass
	"Return a morph in the submorph tree of the receiver that is descended from the given class. Return nil if there is no such morph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."

	^ (self allMorphs copyWithout: self)
		detect: [:p | p isKindOf: aClass]
		ifNone: [nil]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'LC 9/28/1999 19:12'!
findDeepSubmorphThat: block1 ifAbsent: block2 
	self
		allMorphsDo: [:m | (block1 value: m)
				== true ifTrue: [^ m]].
	^ block2 value! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 3/17/2001 15:32'!
findSubmorphBinary: aBlock
	"Use binary search for finding a specific submorph of the receiver. Caller must be certain that the ordering holds for the submorphs."
	^submorphs findBinary: aBlock ifNone:[nil].! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:31'!
firstSubmorph
	^submorphs first! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'!
hasSubmorphs
	^submorphs notEmpty! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 7/3/1998 17:11'!
hasSubmorphWithProperty: aSymbol
	submorphs detect: [:m | m hasProperty: aSymbol] ifNone: [^ false].
	^ true! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/31/2000 11:04'!
indexOfMorphAbove: aPoint
	"Return index of lowest morph whose bottom is above aPoint.
	Will return 0 if the first morph is not above aPoint."

	submorphs withIndexDo: [:mm :ii | 
		mm fullBounds bottom >= aPoint y ifTrue: [^ ii - 1]].
	^ submorphs size! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'!
lastSubmorph
	^submorphs last! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/6/2004 14:17'!
mainDockingBars
	"Answer the receiver's main dockingBars"
	^ self dockingBars
		select: [:each | each hasProperty: #mainDockingBarTimeStamp]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:40'!
morphsAt: aPoint
	"Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself.  The order is deepest embedding first."
	^self morphsAt: aPoint unlocked: false! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'!
morphsAt: aPoint behind: aMorph unlocked: aBool 
	"Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs."

	| isBack found all tfm |
	all := (aMorph isNil or: [owner isNil]) 
				ifTrue: 
					["Traverse down"

					(self fullBounds containsPoint: aPoint) ifFalse: [^#()].
					(aBool and: [self isLocked or: [self visible not]]) ifTrue: [^#()].
					nil]
				ifFalse: 
					["Traverse up"

					tfm := self transformedFrom: owner.
					all := owner 
								morphsAt: (tfm localPointToGlobal: aPoint)
								behind: self
								unlocked: aBool.
					WriteStream with: all].
	isBack := aMorph isNil.
	self submorphsDo: 
			[:m | 
			isBack 
				ifTrue: 
					[tfm := m transformedFrom: self.
					found := m 
								morphsAt: (tfm globalPointToLocal: aPoint)
								behind: nil
								unlocked: aBool.
					found notEmpty 
						ifTrue: 
							[all ifNil: [all := WriteStream on: #()].
							all nextPutAll: found]].
			m == aMorph ifTrue: [isBack := true]].
	(isBack and: [self containsPoint: aPoint]) 
		ifTrue: 
			[all ifNil: [^Array with: self].
			all nextPut: self].
	^all ifNil: [#()] ifNotNil: [all contents]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:40'!
morphsAt: aPoint unlocked: aBool
	"Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself.  The order is deepest embedding first."
	| mList |
	mList _ WriteStream on: #().
	self morphsAt: aPoint unlocked: aBool do:[:m| mList nextPut: m].
	^mList contents! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:37'!
morphsAt: aPoint unlocked: aBool do: aBlock
	"Evaluate aBlock with all the morphs starting at the receiver which appear at aPoint. If aBool is true take only visible, unlocked morphs into account."
	| tfm |
	(self fullBounds containsPoint: aPoint) ifFalse:[^self].
	(aBool and:[self isLocked or:[self visible not]]) ifTrue:[^self].
	self submorphsDo:[:m|
		tfm _ m transformedFrom: self.
		m morphsAt: (tfm globalPointToLocal: aPoint) unlocked: aBool do: aBlock].
	(self containsPoint: aPoint) ifTrue:[aBlock value: self].! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'!
morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
	"Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle. someMorph is either an immediate child of the receiver or nil (in which case all submorphs of the receiver are enumerated)."
	self submorphsDo:[:m|
		m == someMorph ifTrue:["Try getting out quickly"
			owner ifNil:[^self].
			^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock].
		(m fullBoundsInWorld intersects: aRectangle)
			ifTrue:[aBlock value: m]].
	owner ifNil:[^self].
	^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock.! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'!
morphsInFrontOverlapping: aRectangle
	"Return all top-level morphs in front of someMorph that overlap with the given rectangle."
	| morphList |
	morphList _ WriteStream on: Array new.
	self morphsInFrontOf: nil overlapping: aRectangle do:[:m | morphList nextPut: m].
	^morphList contents! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'!
morphsInFrontOverlapping: aRectangle do: aBlock
	"Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle."
	^self morphsInFrontOf: nil overlapping: aRectangle do: aBlock! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 8/13/2003 11:32'!
noteNewOwner: aMorph
	"I have just been added as a submorph of aMorph"! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'RAA 6/11/2000 20:41'!
rootMorphsAtGlobal: aPoint
	"Return the list of root morphs containing the given point, excluding the receiver.
	ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds"

	^ self rootMorphsAt: (self pointFromWorld: aPoint)! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:44'!
rootMorphsAt: aPoint
	"Return the list of root morphs containing the given point, excluding the receiver.
	ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds"
self flag: #arNote. "check this at some point"
	^ self submorphs select:
		[:m | (m fullContainsPoint: aPoint) and: [m isLocked not]]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:35'!
shuffleSubmorphs
	"Randomly shuffle the order of my submorphs.  Don't call this method lightly!!"

	| bg |
	self invalidRect: self fullBounds.
	(submorphs notEmpty and: [submorphs last mustBeBackmost]) 
		ifTrue: 
			[bg := submorphs last.
			bg privateDelete].
	submorphs := submorphs shuffled.
	bg ifNotNil: [self addMorphBack: bg].
	self layoutChanged! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/20/2000 13:12'!
submorphAfter
	"Return the submorph after (behind) me, or nil"
	| ii |
	owner ifNil: [^ nil].
	^ (ii _ owner submorphIndexOf: self) = owner submorphs size 
		ifTrue: [nil]
		ifFalse: [owner submorphs at: ii+1].
	
! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/20/2000 13:13'!
submorphBefore
	"Return the submorph after (behind) me, or nil"
	| ii |
	owner ifNil: [^ nil].
	^ (ii _ owner submorphIndexOf: self) = 1 
		ifTrue: [nil]
		ifFalse: [owner submorphs at: ii-1].
	
! !

!Morph methodsFor: 'submorphs-accessing'!
submorphCount

	^ submorphs size! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 4/9/98 14:26'!
submorphNamed: aName
	^ self submorphNamed: aName ifNone: [nil]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'gm 2/22/2003 13:16'!
submorphNamed: aName ifNone: aBlock 
	"Find the first submorph with this name, or a button with an action selector of that name"

	| sub args |
	self submorphs do: [:p | p knownName = aName ifTrue: [^p]].
	self submorphs do: 
			[:button | 
			(button respondsTo: #actionSelector) 
				ifTrue: [button actionSelector == aName ifTrue: [^button]].
			((button respondsTo: #arguments) and: [(args := button arguments) notNil]) 
				ifTrue: [(args at: 2 ifAbsent: [nil]) == aName ifTrue: [^button]].
			(button isAlignmentMorph) 
				ifTrue: [(sub := button submorphNamed: aName ifNone: [nil]) ifNotNil: [^sub]]].
	^aBlock value! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'rhi 9/10/2000 12:12'!
submorphOfClass: aClass

	^self findA: aClass! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'efc 8/6/2005 11:35'!
submorphs
	"This method returns my actual submorphs collection. Modifying the collection directly could be dangerous; make a copy if you need to alter it."
	^ submorphs ! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/4/97 14:30'!
submorphsBehind: aMorph do: aBlock
	| behind |
	behind _ false.
	submorphs do:
		[:m | m == aMorph ifTrue: [behind _ true]
						ifFalse: [behind ifTrue: [aBlock value: m]]].
! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:35'!
submorphsDo: aBlock 
	submorphs do: aBlock! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/4/97 14:29'!
submorphsInFrontOf: aMorph do: aBlock
	| behind |
	behind _ false.
	submorphs do:
		[:m | m == aMorph ifTrue: [behind _ true]
						ifFalse: [behind ifFalse: [aBlock value: m]]].
! !

!Morph methodsFor: 'submorphs-accessing'!
submorphsReverseDo: aBlock

	submorphs reverseDo: aBlock.! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 8/15/97 22:03'!
submorphsSatisfying: aBlock
	^ submorphs select: [:m | (aBlock value: m) == true]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 10/26/1999 23:42'!
submorphThat: block1 ifNone: block2
	^ submorphs detect: [:m | (block1 value: m) == true] ifNone: [block2 value]
	! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 7/3/1998 18:47'!
submorphWithProperty: aSymbol
	^ submorphs detect: [:aMorph | aMorph hasProperty: aSymbol] ifNone: [nil]! !


!Morph methodsFor: 'submorphs-add/remove' stamp: 'tk 12/15/1998 14:23'!
abandon
	"Like delete, but we really intend not to use this morph again.  Clean up a few things."

	self delete! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/28/2001 08:39'!
actWhen
	"Answer when the receiver, probably being used as a button, should have its action triggered"

	^ self valueOfProperty: #actWhen ifAbsentPut: [#buttonDown]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/25/2001 10:23'!
actWhen: aButtonPhase
	"Set the receiver's actWhen trait"

	self setProperty: #actWhen toValue: aButtonPhase! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:28'!
addAllMorphs: aCollection
	^self privateAddAllMorphs: aCollection atIndex: submorphs size! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:29'!
addAllMorphs: aCollection after: anotherMorph
	^self privateAddAllMorphs: aCollection 
			atIndex: (submorphs indexOf: anotherMorph ifAbsent: [submorphs size])! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:55'!
addMorphBack: aMorph
	^self privateAddMorph: aMorph atIndex: submorphs size+1! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/15/2000 19:34'!
addMorphCentered: aMorph

	aMorph position: bounds center - (aMorph extent // 2).
	self addMorphFront: aMorph.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 12/16/2001 21:08'!
addMorphFrontFromWorldPosition: aMorph
	^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'!
addMorphFront: aMorph
	^self privateAddMorph: aMorph atIndex: 1! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 11/15/1998 23:42'!
addMorphFront: aMorph fromWorldPosition: wp

	self addMorphFront: aMorph.
	aMorph position: (self transformFromWorld globalPointToLocal: wp)! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 2/22/2003 14:26'!
addMorphNearBack: aMorph 
	| bg |
	(submorphs notEmpty and: [submorphs last mustBeBackmost]) 
		ifTrue: 
			[bg := submorphs last.
			bg privateDelete].
	self addMorphBack: aMorph.
	bg ifNotNil: [self addMorphBack: bg]! !

!Morph methodsFor: 'submorphs-add/remove'!
addMorph: aMorph

	self addMorphFront: aMorph.! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'!
addMorph: newMorph after: aMorph
	"Add the given morph as one of my submorphs, inserting it after anotherMorph"
	^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph)+1! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/7/2000 08:29'!
addMorph: aMorph asElementNumber: aNumber
	"Add the given morph so that it becomes the aNumber'th element of my submorph list.  If aMorph is already one of my submorphs, reposition it"

	(submorphs includes: aMorph) ifTrue:
		[aMorph privateDelete].
	(aNumber <= submorphs size)
		ifTrue:
			[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
		ifFalse:
			[self addMorphBack: aMorph]
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:44'!
addMorph: newMorph behind: aMorph
	"Add a morph to the list of submorphs behind the specified morph"
	^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph) + 1.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'JW 2/1/2001 12:52'!
addMorph: aMorph fullFrame: aLayoutFrame

	aMorph layoutFrame: aLayoutFrame.
	aMorph hResizing: #spaceFill; vResizing: #spaceFill.
	self addMorph: aMorph.

! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:45'!
addMorph: newMorph inFrontOf: aMorph
	"Add a morph to the list of submorphs in front of the specified morph"
	^self privateAddMorph: newMorph atIndex: ((submorphs indexOf: aMorph) max: 1).! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 4/4/2006 17:17'!
allMorphsWithPlayersDo: aTwoArgumentBlock 
	"Evaluate the given block for all morphs in this composite morph that have non-nil players.
	Also evaluate the block for the receiver if it has a player."

	submorphs do: [:m | m allMorphsWithPlayersDo: aTwoArgumentBlock ].
	self playerRepresented ifNotNilDo: [ :p | aTwoArgumentBlock value: self value: p ].
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 2/22/2003 14:30'!
comeToFront
	| outerMorph |
	outerMorph := self topRendererOrSelf.
	(outerMorph owner isNil or: [outerMorph owner hasSubmorphs not]) 
		ifTrue: [^self].
	outerMorph owner firstSubmorph == outerMorph 
		ifFalse: [outerMorph owner addMorphFront: outerMorph]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'di 10/27/97 23:26'!
copyWithoutSubmorph: sub
	"Needed to get a morph to draw without one of its submorphs.
	NOTE:  This must be thrown away immediately after use."
	^ self clone privateSubmorphs: (submorphs copyWithout: sub)! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/10/2004 19:02'!
delete
	"Remove the receiver as a submorph of its owner and make its 
	new owner be nil."

	| aWorld |
	self removeHalo.
	aWorld := self world ifNil: [World].
	"Terminate genie recognition focus"
	"I encountered a case where the hand was nil, so I put in a little 
	protection - raa "
	" This happens when we are in an MVC project and open
	  a morphic window. - BG "
	aWorld ifNotNil:
	  [self disableSubmorphFocusForHand: self activeHand.
	  self activeHand releaseKeyboardFocus: self;
		  releaseMouseFocus: self.].
	owner ifNotNil:[ self privateDelete.
		self player ifNotNilDo: [ :player |
			"Player must be notified"
			player noteDeletionOf: self fromWorld: aWorld]].! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/1/2004 16:26'!
deleteDockingBars
	"Delete the receiver's docking bars"
	self dockingBars
		do: [:each | each delete]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 7/3/1998 11:02'!
deleteSubmorphsWithProperty: aSymbol
	submorphs copy do:
		[:m | (m hasProperty: aSymbol) ifTrue: [m delete]]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 2/2/2006 02:39'!
dismissViaHalo
	"The user has clicked in the delete halo-handle.  This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example."

	| cmd |
	self setProperty: #lastPosition toValue: self positionInWorld.
	self dismissMorph.
	Preferences preserveTrash ifTrue: [ 
		Preferences slideDismissalsToTrash
			ifTrue:[self slideToTrash: nil]
			ifFalse:[TrashCanMorph moveToTrash: self].
	].

	cmd _ Command new cmdWording: 'dismiss ' translated, self externalName.
	cmd undoTarget: ActiveWorld selector: #reintroduceIntoWorld: argument: self.
	cmd redoTarget: ActiveWorld selector: #onceAgainDismiss: argument: self.
	ActiveWorld rememberCommand: cmd! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 4/9/98 22:44'!
goBehind

	owner addMorphNearBack: self.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/10/2003 18:31'!
privateDelete
	"Remove the receiver as a submorph of its owner"
	owner ifNotNil:[owner removeMorph: self].! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/16/2003 14:08'!
removeAllMorphs
	| oldMorphs myWorld |
	myWorld _ self world.
	(fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds].
	submorphs do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil].
	oldMorphs _ submorphs.
	submorphs _ EmptyArray.
	oldMorphs do: [ :m | self removedMorph: m ].
	self layoutChanged.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/16/2003 14:02'!
removeAllMorphsIn: aCollection
	"greatly speeds up the removal of *lots* of submorphs"
	| set myWorld |
	set _ IdentitySet new: aCollection size * 4 // 3.
	aCollection do: [:each | each owner == self ifTrue: [ set add: each]].
	myWorld _ self world.
	(fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds].
	set do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil].
	submorphs _ submorphs reject: [ :each | set includes: each].
	set do: [ :m | self removedMorph: m ].
	self layoutChanged.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 22:01'!
removedMorph: aMorph
	"Notify the receiver that aMorph was just removed from its children"
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'di 10/18/2004 21:50'!
removeMorph: aMorph
	"Remove the given morph from my submorphs"
	| aWorld |
	aMorph owner == self ifFalse:[^self].
	aWorld := self world.
	aWorld ifNotNil:[
		aMorph outOfWorld: aWorld.
		self privateInvalidateMorph: aMorph.
	].
	self privateRemove: aMorph.
	aMorph privateOwner: nil.
	self removedMorph: aMorph.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/25/1999 23:34'!
replaceSubmorph: oldMorph by: newMorph
	| index itsPosition w |
	oldMorph stopStepping.
	itsPosition _ oldMorph referencePositionInWorld.
	index _ submorphs indexOf: oldMorph.
	oldMorph privateDelete.
	self privateAddMorph: newMorph atIndex: index.
	newMorph referencePositionInWorld: itsPosition.
	(w _ newMorph world) ifNotNil:
		[w startSteppingSubmorphsOf: newMorph]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/1/2000 10:16'!
submorphIndexOf: aMorph
	"Assuming aMorph to be one of my submorphs, answer where it occurs in my submorph list"

	^ submorphs indexOf: aMorph ifAbsent: [nil]! !


!Morph methodsFor: 'testing' stamp: 'RAA 12/4/2000 10:44'!
canDrawAtHigherResolution

	^false! !

!Morph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:14'!
canDrawBorder: aBorderStyle
	"Return true if the receiver can be drawn with the given border style."
	^true! !

!Morph methodsFor: 'testing' stamp: 'RAA 10/20/2000 14:47'!
completeModificationHash

"World completeModificationHash"

	| resultSize result here i |
	resultSize _ 10.
	result _ ByteArray new: resultSize.
	self allMorphsDo: [ :each | 
		here _ each modificationHash.
		here withIndexDo: [ :ch :index |
			i _ index \\ resultSize + 1.
			result at: i put: ((result at: i) bitXor: ch asciiValue)
		].
	].
	^result! !

!Morph methodsFor: 'testing' stamp: 'sw 3/30/2005 04:17'!
couldMakeSibling
	"Answer whether it is appropriate to ask the receiver to make a sibling"

	^ true! !

!Morph methodsFor: 'testing' stamp: 'dgd 8/31/2004 15:00'!
isDockingBar
	"Return true if the receiver is a docking bar"
	^ false! !

!Morph methodsFor: 'testing' stamp: 'ar 9/22/2000 13:44'!
isFlexed
	"Return true if the receiver is currently flexed"
	owner ifNil:[^false].
	^owner isFlexMorph! !

!Morph methodsFor: 'testing' stamp: 'dgd 9/20/2004 14:31'!
isFullOnScreen
	"Answer if the receiver is full contained in the owner visible  
	area."
	owner isInMemory
		ifFalse: [^ true].
	owner isNil
		ifTrue: [^ true].
	self visible
		ifFalse: [^ true].
	^ owner clearArea containsRect: self fullBounds! !

!Morph methodsFor: 'testing' stamp: 'nk 10/13/2003 18:36'!
isLineMorph
	^false! !

!Morph methodsFor: 'testing'!
isMorph

	^ true! !

!Morph methodsFor: 'testing' stamp: 'nk 6/12/2004 09:17'!
isSketchMorph
	^self class isSketchMorphClass! !

!Morph methodsFor: 'testing' stamp: 'md 2/27/2006 09:59'!
knownName
	"answer a name by which the receiver is known, or nil if none"
	^ extension ifNotNil: [extension externalName]! !

!Morph methodsFor: 'testing' stamp: 'RAA 10/20/2000 14:47'!
modificationHash

	^String 
		streamContents: [ :strm |
			self longPrintOn: strm
		]
		limitedTo: 25
! !

!Morph methodsFor: 'testing' stamp: 'tk 7/28/2005 04:46'!
renameInternal: aName 
	"Change the internal name (because of a conflict) but leave the external name unchanged.  Change Player class name, but do not change the names that appear in tiles.  When coming in from disk, and have name conflict, References will already have the new name. "

	self knownName = aName ifTrue: [^ aName].
	self topRendererOrSelf setNameTo: aName.
	
	"References dictionary already has key aName"

	"If this player has a viewer flap, it will remain present"

	"Tiles in scripts all stay the same"

	"Compiled methods for scripts have been fixed up because the same association was reused"
	
	^ aName! !

!Morph methodsFor: 'testing' stamp: 'dvf 8/23/2003 11:50'!
renameTo: aName 
	"Set Player name in costume. Update Viewers. Fix all tiles (old style). fix 
	References. New tiles: recompile, and recreate open scripts. If coming in 
	from disk, and have name conflict, References will already have new 
	name. "

	| aPresenter putInViewer aPasteUp renderer oldKey assoc classes oldName |
	oldName := self knownName.
	(renderer := self topRendererOrSelf) setNameTo: aName.
	putInViewer := false.
	((aPresenter := self presenter) isNil or: [renderer player isNil]) 
		ifFalse: 
			[putInViewer := aPresenter currentlyViewing: renderer player.
			putInViewer ifTrue: [renderer player viewerFlapTab hibernate]].
	"empty it temporarily"
	(aPasteUp := self topPasteUp) 
		ifNotNil: [aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]].
	"Fix References dictionary. See restoreReferences to know why oldKey is  
	already aName, but oldName is the old name."
	oldKey := References keyAtIdentityValue: renderer player ifAbsent: [].
	oldKey ifNotNil: 
			[assoc := References associationAt: oldKey.
			oldKey = aName 
				ifFalse: 
					["normal rename"

					assoc key: (renderer player uniqueNameForReferenceFrom: aName).
					References rehash]].
	putInViewer ifTrue: [aPresenter viewMorph: self].
	"recreate my viewer"
	oldKey ifNil: [^aName].
	"Force strings in tiles to be remade with new name. New tiles only."
	Preferences universalTiles ifFalse: [^aName].
	classes := (self systemNavigation allCallsOn: assoc) 
				collect: [:each | each classSymbol].
	classes asSet 
		do: [:clsName | (Smalltalk at: clsName) replaceSilently: oldName to: aName].
	"replace in text body of all methods. Can be wrong!!"
	"Redo the tiles that are showing. This is also done in caller in 
	unhibernate. "
	aPasteUp ifNotNil: 
			[aPasteUp allTileScriptingElements do: 
					[:mm | 
					"just ScriptEditorMorphs"

					nil.
					(mm isKindOf: ScriptEditorMorph) 
						ifTrue: 
							[((mm playerScripted class compiledMethodAt: mm scriptName) 
								hasLiteral: assoc) 
									ifTrue: 
										[mm
											hibernate;
											unhibernate]]]].
	^aName! !

!Morph methodsFor: 'testing' stamp: 'ar 12/3/2001 12:33'!
shouldDropOnMouseUp
	| former |
	former _ self formerPosition ifNil:[^false].
	^(former dist: self position) > 10! !

!Morph methodsFor: 'testing' stamp: 'RAA 1/16/2001 17:20'!
stepTime
	"Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second."

	^ self topRendererOrSelf player ifNotNil: [10] ifNil: [1000]! !

!Morph methodsFor: 'testing' stamp: 'sw 10/24/2004 15:28'!
wantsSteps
	"Return true if the receiver overrides the default Morph step method."
	"Details: Find first class in superclass chain that implements #step and return true if it isn't class Morph."

	| c |
	self isPartsDonor ifTrue: [^ false].
	(self == self topRendererOrSelf) ifTrue: [self player wantsSteps ifTrue: [^ true]].
	c _ self class.
	[c includesSelector: #step] whileFalse: [c _ c superclass].
	^ c ~= Morph! !


!Morph methodsFor: 'text-anchor' stamp: 'ar 12/17/2001 12:45'!
addTextAnchorMenuItems: topMenu hand: aHand
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addUpdating: #hasInlineAnchorString action: #changeInlineAnchor.
	aMenu addUpdating: #hasParagraphAnchorString action: #changeParagraphAnchor.
	aMenu addUpdating: #hasDocumentAnchorString action: #changeDocumentAnchor.
	topMenu ifNotNil:[topMenu add: 'text anchor' subMenu: aMenu].
	^aMenu! !

!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:47'!
changeDocumentAnchor
	"Change the anchor from/to document anchoring"

	| newType |
	newType := self textAnchorType == #document 
		ifTrue: [#paragraph]
		ifFalse: [ #document].
	owner isTextMorph 
		ifTrue: 
			[owner 
				anchorMorph: self
				at: self position
				type: newType]! !

!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48'!
changeInlineAnchor
	"Change the anchor from/to line anchoring"

	| newType |
	newType := self textAnchorType == #inline 
				ifTrue: [#paragraph]
				ifFalse: [#inline]. 
	owner isTextMorph 
		ifTrue: 
			[owner 
				anchorMorph: self
				at: self position
				type: newType]! !

!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48'!
changeParagraphAnchor
	"Change the anchor from/to paragraph anchoring"

	| newType |
	newType := self textAnchorType == #paragraph 
		ifTrue: [#document]
		ifFalse: [#paragraph].
	owner isTextMorph 
		ifTrue: 
			[owner 
				anchorMorph: self
				at: self position
				type: newType]! !

!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'!
hasDocumentAnchorString
	^ (self textAnchorType == #document
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'Document' translated! !

!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'!
hasInlineAnchorString
	^ (self textAnchorType == #inline
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'Inline' translated! !

!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'!
hasParagraphAnchorString
	^ (self textAnchorType == #paragraph
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'Paragraph' translated! !

!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:47'!
relativeTextAnchorPosition
	^self valueOfProperty: #relativeTextAnchorPosition! !

!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:22'!
relativeTextAnchorPosition: aPoint
	^self setProperty: #relativeTextAnchorPosition toValue: aPoint! !

!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:36'!
textAnchorType
	^self valueOfProperty: #textAnchorType ifAbsent:[#document]! !

!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:37'!
textAnchorType: aSymbol
	aSymbol == #document
		ifTrue:[^self removeProperty: #textAnchorType]
		ifFalse:[^self setProperty: #textAnchorType toValue: aSymbol].! !


!Morph methodsFor: 'thumbnail' stamp: 'sw 10/26/2000 08:32'!
demandsThumbnailing
	"Answer whether the receiver, if in a thumbnailable parts bin, wants to be thumbnailed whether or not size requires it"

	^ false! !

!Morph methodsFor: 'thumbnail' stamp: 'dgd 9/12/2004 21:12'!
icon
	"Answer a form with an icon to represent the receiver"
	^ self valueOfProperty: #icon! !

!Morph methodsFor: 'thumbnail' stamp: 'dgd 9/12/2004 20:33'!
iconOrThumbnail
	"Answer an appropiate form to represent the receiver"

	^ self icon
		ifNil: [ | maxExtent fb |maxExtent := 320 @ 240.
			fb := self fullBounds.
			fb area <= (maxExtent x * maxExtent y)
				ifTrue: [self imageForm]
				ifFalse: [self imageFormForRectangle: (fb topLeft extent: maxExtent)]
		]
! !

!Morph methodsFor: 'thumbnail' stamp: 'dgd 9/13/2004 12:43'!
iconOrThumbnailOfSize: aNumberOrPoint 
	"Answer an appropiate form to represent the receiver"

	^ self iconOrThumbnail scaledIntoFormOfSize: aNumberOrPoint
! !

!Morph methodsFor: 'thumbnail' stamp: 'sw 8/16/2000 17:40'!
morphRepresented
	"If the receiver is an alias, answer the morph it represents; else answer self"

	^ self! !

!Morph methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:29'!
permitsThumbnailing
	^ true! !

!Morph methodsFor: 'thumbnail' stamp: 'ar 11/9/2000 20:42'!
readoutForField: fieldSym
	"Provide a readout that will show the value of the slot/pseudoslot of the receiver generated by sending fieldSym to the receiver"

	| aContainer |
	"still need to get this right"
	aContainer _ AlignmentMorph newColumn.
	aContainer layoutInset: 0; hResizing: #rigid; vResizing: #shrinkWrap.
	aContainer addMorphBack: (StringMorph new contents: (self perform: fieldSym) asString).
	^ aContainer! !

!Morph methodsFor: 'thumbnail' stamp: 'sw 12/6/2000 21:28'!
representativeNoTallerThan: maxHeight norWiderThan: maxWidth thumbnailHeight: thumbnailHeight
	"Return a morph representing the receiver but which is no taller than aHeight.  If the receiver is already small enough, just return it, else return a MorphThumbnail companioned to the receiver, enforcing the maxWidth.  If the receiver personally *demands* thumbnailing, do it even if there is no size-related reason to do it."

	self demandsThumbnailing ifFalse:
		[self permitsThumbnailing ifFalse: [^ self].
		(self fullBounds height <= maxHeight and: [self fullBounds width <= maxWidth]) ifTrue: [^ self]].

	^ MorphThumbnail new extent: maxWidth @ (thumbnailHeight min: self fullBounds height); morphRepresented: self! !

!Morph methodsFor: 'thumbnail' stamp: 'tk 3/28/2000 11:08'!
updateThumbnailUrl
	"If I have a cached thumbnail, then update it's urls."
	| cachedThumbnail |

	(cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil:
		[(cachedThumbnail respondsTo: #computeThumbnail) 
			ifTrue: [cachedThumbnail pageMorph: self url inBook: owner url]
			ifFalse: [self removeProperty: #computeThumbnail]].
			"Test and removal are because the thumbnail is being replaced 
			by another Morph.  We don't know why.  Need to fix that at 
			the source."! !

!Morph methodsFor: 'thumbnail' stamp: 'tk 3/28/2000 21:55'!
updateThumbnailUrlInBook: bookUrl
	"If I have a cached thumbnail, then update it's urls."
	| cachedThumbnail |

	(cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil:
		[(cachedThumbnail respondsTo: #computeThumbnail) 
			ifTrue: [cachedThumbnail pageMorph: self url inBook: bookUrl]
			ifFalse: [self removeProperty: #computeThumbnail]].
			"Test and removal are because the thumbnail is being replaced 
			by another Morph.  We don't know why.  Need to fix that at 
			the source."! !


!Morph methodsFor: 'undo' stamp: 'ar 8/31/2000 23:15'!
commandHistory
	"Return the command history for the receiver"
	| w |
	(w _ self world) ifNotNil:[^w commandHistory].
	(w _ self currentWorld) ifNotNil:[^w commandHistory].
	^CommandHistory new. "won't really record anything but prevent breaking things"! !

!Morph methodsFor: 'undo' stamp: 'md 10/22/2003 15:56'!
undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor 
	"Handle undo and redo of move commands in morphic"

	self owner ifNil: [^Beeper beep].
	redo 
		ifFalse: 
			["undo sets up the redo state first"

			cmd 
				redoTarget: self
				selector: #undoMove:redo:owner:bounds:predecessor:
				arguments: { 
						cmd.
						true.
						owner.
						bounds.
						owner morphPreceding: self}].
	formerOwner ifNotNil: 
			[formerPredecessor ifNil: [formerOwner addMorphFront: self]
				ifNotNil: [formerOwner addMorph: self after: formerPredecessor]].
	self bounds: formerBounds.
	(self isSystemWindow) ifTrue: [self activate]! !


!Morph methodsFor: 'updating' stamp: 'ar 6/25/2001 19:46'!
changed
	"Report that the area occupied by this morph should be redrawn."
	^fullBounds 
		ifNil:[self invalidRect: self outerBounds]
		ifNotNil:[self invalidRect: fullBounds]! !


!Morph methodsFor: 'user interface' stamp: 'tak 3/15/2005 17:36'!
becomeModal
	self currentWorld
		ifNotNil: [self currentWorld modalWindow: self]! !

!Morph methodsFor: 'user interface' stamp: 'sw 5/29/2000 00:41'!
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."
	^ super printString truncateTo: 40! !

!Morph methodsFor: 'user interface' stamp: 'tak 3/15/2005 17:10'!
doCancel
	self delete! !

!Morph methodsFor: 'user interface' stamp: 'sw 10/2/97 23:08'!
initialExtent
	| ext |
	(ext _ self valueOfProperty: #initialExtent)
		ifNotNil:
			[^ ext].
	^ super initialExtent! !


!Morph methodsFor: 'viewer' stamp: 'sw 10/30/1998 14:46'!
externalName
	^ self knownName ifNil: [self innocuousName]! !


!Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:11'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^self class == Morph "no subclasses"! !

!Morph methodsFor: 'visual properties' stamp: 'mk 8/7/2005 10:02'!
cornerStyle
	"Returns one of the following symbols:
		#square
		#rounded
	according to the current corner style."

	^ self valueOfProperty: #cornerStyle ifAbsent: [#square]! !

!Morph methodsFor: 'visual properties' stamp: 'nk 8/28/2003 15:56'!
defaultBitmapFillForm
	^ImageMorph defaultForm.
! !

!Morph methodsFor: 'visual properties' stamp: 'dgd 2/16/2003 20:02'!
fillStyle
	"Return the current fillStyle of the receiver."
	^ self
		valueOfProperty: #fillStyle
		ifAbsent: ["Workaround already converted morphs"
			color
				ifNil: [self defaultColor]]! !

!Morph methodsFor: 'visual properties' stamp: 'ar 6/18/1999 07:05'!
fillStyle: aFillStyle
	"Set the current fillStyle of the receiver."
	self setProperty: #fillStyle toValue: aFillStyle.
	"Workaround for Morphs not yet converted"
	color _ aFillStyle asColor.
	self changed.! !

!Morph methodsFor: 'visual properties' stamp: 'dgd 1/7/2005 19:31'!
fillWithRamp: rampSpecsOrColor oriented: aRatio 
	rampSpecsOrColor isColor
		ifTrue: [self color: rampSpecsOrColor".
			self borderColor: rampSpecsOrColor muchDarker"]
		ifFalse: [| fill | 
			fill := GradientFillStyle ramp: rampSpecsOrColor.
			fill origin: self bounds topLeft.
			fill direction: (self bounds extent * aRatio) truncated.
			fill radial: false.
			self fillStyle: fill.
			self borderColor: (rampSpecsOrColor first value mixed: 0.5 with: rampSpecsOrColor last value) muchDarker]! !

!Morph methodsFor: 'visual properties' stamp: 'nk 8/28/2003 15:57'!
useBitmapFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	| fill |
	self fillStyle isBitmapFill ifTrue:[^self]. "Already done"
	fill _ BitmapFillStyle fromForm: self defaultBitmapFillForm.
	"Note: Must fix the origin due to global coordinates"
	fill origin: self bounds origin.
	self fillStyle: fill.! !

!Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:11'!
useDefaultFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	self fillStyle: self defaultColor.! !

!Morph methodsFor: 'visual properties' stamp: 'nk 2/27/2003 11:48'!
useGradientFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	| fill color1 color2 |
	self fillStyle isGradientFill ifTrue:[^self]. "Already done"
	color1 _ self color asColor.
	color2 _ color1 negated.
	fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
	fill origin: self topLeft.
	fill direction: 0 @ self bounds extent y.
	fill normal: self bounds extent x @ 0.
	fill radial: false.
	self fillStyle: fill! !

!Morph methodsFor: 'visual properties' stamp: 'ar 6/18/1999 06:57'!
useSolidFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	self fillStyle isSolidFill ifTrue:[^self]. "Already done"
	self fillStyle: self fillStyle asColor. "Try minimizing changes"! !


!Morph methodsFor: 'WiW support' stamp: 'RAA 2/16/2001 13:57'!
addMorphInFrontOfLayer: aMorph

	| targetLayer layerHere |

	targetLayer _ aMorph morphicLayerNumberWithin: self.
	submorphs do: [ :each |
		each == aMorph ifTrue: [^self].
		layerHere _ each morphicLayerNumberWithin: self.
		"the <= is the difference - it insures we go to the front of our layer"
		targetLayer <= layerHere ifTrue: [
			^self addMorph: aMorph inFrontOf: each
		].
	].
	self addMorphBack: aMorph.
! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 6/29/2000 10:49'!
addMorphInLayer: aMorph

	submorphs do: [ :each |
		each == aMorph ifTrue: [^self].
		aMorph morphicLayerNumber < each morphicLayerNumber ifTrue: [
			^self addMorph: aMorph inFrontOf: each
		].
	].
	self addMorphBack: aMorph
! !

!Morph methodsFor: 'WiW support' stamp: 'gk 5/24/2004 15:43'!
eToyRejectDropMorph: morphToDrop event: evt

	| tm am |

	tm _ TextMorph new 
		beAllFont: ((TextStyle named: Preferences standardEToysFont familyName) fontOfSize: 24);
		contents: 'GOT IT!!'.
	(am _ AlignmentMorph new)
		color: Color yellow;
		layoutInset: 10;
		useRoundedCorners;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		addMorph: tm;
		fullBounds;
		position: (self bounds center - (am extent // 2));
		openInWorld: self world.
	SoundService default playSoundNamed: 'yum' ifAbsentReadFrom: 'yum.aif'.
	morphToDrop rejectDropMorphEvent: evt.		"send it back where it came from"
	am delete
! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 7/19/2000 20:44'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^(owner isNil or: [owner isWorldMorph]) ifTrue: [
		self valueOfProperty: #morphicLayerNumber ifAbsent: [100]
	] ifFalse: [
		owner morphicLayerNumber
	].

	"leave lots of room for special things"! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 2/16/2001 13:54'!
morphicLayerNumberWithin: anOwner

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^(owner isNil or: [owner isWorldMorph or: [anOwner == owner]]) ifTrue: [
		self valueOfProperty: #morphicLayerNumber ifAbsent: [100]
	] ifFalse: [
		owner morphicLayerNumber
	].

	"leave lots of room for special things"! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 7/16/2000 13:54'!
randomBoundsFor: aMorph

	| trialRect |
	trialRect _ (
		self topLeft + 
			((self width * (15 + 75 atRandom/100)) rounded @
			(self height * (15 + 75 atRandom/100)) rounded)
	) extent: aMorph extent.
	^trialRect translateBy: (trialRect amountToTranslateWithin: self bounds)
! !

!Morph methodsFor: 'WiW support' stamp: 'ar 3/18/2001 00:14'!
shouldGetStepsFrom: aWorld
	^self world == aWorld! !







!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/24/2003 17:31'!
instantiatedUserScriptsDo: aBlock
	self actorStateOrNil ifNotNilDo: [ :aState | aState instantiatedUserScriptsDictionary do: aBlock]! !

!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/25/2003 11:36'!
removeAllEventTriggers
	"Remove all the event registrations for my Player.
	User custom events are triggered at the World,
	while system custom events are triggered on individual Morphs."

	| player |
	(player _ self player) ifNil: [ ^self ].
	self removeAllEventTriggersFor: player.
	self currentWorld removeAllEventTriggersFor: player.! !

!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/24/2003 17:46'!
removeAllEventTriggersFor: aPlayer
	"Remove all the event registrations for aPlayer.
	User custom events are triggered at the World,
	while system custom events are triggered on individual Morphs."

	self removeActionsSatisfying: 
			[:action | action receiver == aPlayer and: [(#(#doScript: #triggerScript:) includes: action selector) ]].! !

!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/25/2003 11:37'!
removeEventTrigger: aSymbol
	"Remove all the event registrations for my Player that are triggered by aSymbol.
	User custom events are triggered at the World,
	while system custom events are triggered on individual Morphs."

	| player |
	(player _ self player) ifNil: [ ^self ].
	self removeEventTrigger: aSymbol for: player.
	self currentWorld removeEventTrigger: aSymbol for: player.! !

!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/25/2003 11:24'!
removeEventTrigger: aSymbol for: aPlayer 
	"Remove all the event registrations for aPlayer that are triggered by 
	aSymbol. User custom events are triggered at the World, 
	while system custom events are triggered on individual Morphs."
	self removeActionsSatisfying: [:action | action receiver == aPlayer
				and: [(#(#doScript: #triggerScript: ) includes: action selector)
						and: [action arguments first == aSymbol]]]! !

!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/25/2003 11:11'!
renameScriptActionsFor: aPlayer from: oldSelector to: newSelector

	self updateableActionMap keysAndValuesDo: [ :event :sequence |
		sequence asActionSequence do: [ :action |
			((action receiver == aPlayer)
				and: [ (#(doScript: triggerScript:) includes: action selector)
					and: [ action arguments first == oldSelector ]])
						ifTrue: [ action arguments at: 1 put: newSelector ]]]
! !

!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 11/1/2004 11:00'!
triggerCustomEvent: aSymbol
	"Trigger whatever scripts may be connected to the custom event named aSymbol"

	self currentWorld triggerEtoyEvent: aSymbol from: self! !

!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 11/1/2004 10:54'!
triggerEtoyEvent: aSymbol
	"Trigger whatever scripts may be connected to the event named aSymbol.
	If anyone comes back to ask who sent it, return our player."

	[ self triggerEvent: aSymbol ]
		on: GetTriggeringObjectNotification do: [ :ex |
			ex isNested
				ifTrue: [ ex pass ]
				ifFalse: [ ex resume: self assuredPlayer ]]
! !

!Morph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 11/1/2004 10:58'!
triggerEtoyEvent: aSymbol from: aMorph
	"Trigger whatever scripts may be connected to the event named aSymbol.
	If anyone comes back to ask who sent it, return aMorph's player."

	[ self triggerEvent: aSymbol ]
		on: GetTriggeringObjectNotification do: [ :ex |
			ex isNested
				ifTrue: [ ex pass ]
				ifFalse: [ ex resume: aMorph assuredPlayer ]]
! !



















!Morph methodsFor: '*Flash-classification' stamp: 'ar 8/10/1998 18:50'!
isFlashMorph
	^false! !


!Morph methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'nk 9/11/2004 17:31'!
unfilteredCategoriesForViewer
	"Answer a list of symbols representing the categories to offer in the viewer, in order of:
	- masterOrderingOfCategorySymbols first
	- others last in order by translated wording"
	"
	Morph basicNew unfilteredCategoriesForViewer
	"
	^self renderedMorph class unfilteredCategoriesForViewer.
! !


!Morph methodsFor: '*MorphicExtras-accessing' stamp: 'dgd 1/7/2005 19:07'!
highlightOnlySubmorph: aMorph
	"Distinguish only aMorph with border highlighting (2-pixel wide red); make all my other submorphs have one-pixel-black highlighting.  This is a rather special-purpose and hard-coded highlighting regime, of course.  Later, if someone cared to do it, we could parameterize the widths and colors via properties, or some such."

	self submorphs do:
		[:m |
			m == aMorph
				ifTrue: [m borderWidth: 1; borderColor: Color red. m firstSubmorph color: Color red]
				ifFalse: [m borderWidth: 1; borderColor: Color black. m firstSubmorph color: Color black]
		].
! !











!Morph methodsFor: '*MorphicExtras-geometry' stamp: 'dgd 8/31/2004 16:22'!
shiftSubmorphsBy: delta
	self shiftSubmorphsOtherThan: (submorphs select: [:m | m wantsToBeTopmost]) by: delta! !







!Morph methodsFor: '*MorphicExtras-menus' stamp: 'dgd 4/3/2006 14:18'!
dismissButton
	"Answer a button whose action would be to dismiss the receiver, and whose action is to send #delete to the receiver"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton
		target: self topRendererOrSelf;
		color: ColorTheme current cancelColor;
		borderColor: ColorTheme current cancelColor muchDarker;
		borderWidth: 1;
		label: 'X' font: Preferences standardButtonFont;
		actionSelector: #delete;
		setBalloonText: 'dismiss' translated.
	^ aButton! !


















!Morph methodsFor: '*services-base' stamp: 'rr 6/10/2005 11:30'!
requestor
	^ owner ifNil: [super requestor] ifNotNil: [owner requestor]! !


!Morph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/11/2000 17:29'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	"a hack to allow for abitrary morphs to be dropped into piano roll"
	t > rightTime ifTrue: [^ self].  
	t < leftTime ifTrue: [^ self].
	morphList add: (self left: (pianoRoll xForTime: t)).
! !

!Morph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/11/2000 15:48'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	"a hack to allow for abitrary morphs to be dropped into piano roll"
	self triggerActionFromPianoRoll.! !

!Morph methodsFor: '*sound-piano rolls' stamp: 'stephaneducasse 2/4/2006 20:40'!
justDroppedIntoPianoRoll: pianoRoll event: evt
	
	| ambientEvent startTimeInScore |
	startTimeInScore := pianoRoll timeForX: self left.

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

	pianoRoll score addAmbientEvent: ambientEvent.

	"self endTime > pianoRoll scorePlayer durationInTicks ifTrue:
		[pianoRoll scorePlayer updateDuration]"
! !

!Morph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/11/2000 23:21'!
pauseFrom: scorePlayer

	"subclasses should take five"! !

!Morph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/11/2000 23:22'!
resetFrom: scorePlayer

	"subclasses should revert to their initial state"! !

!Morph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/11/2000 23:21'!
resumeFrom: scorePlayer

	"subclasses should continue from their current position"
	"a hack to allow for abitrary morphs to be dropped into piano roll"! !

!Morph methodsFor: '*sound-piano rolls' stamp: 'stephaneducasse 2/4/2006 20:40'!
triggerActionFromPianoRoll

	| evt |
	"a hack to allow for abitrary morphs to be dropped into piano roll"
	self world ifNil: [^self].
	evt := MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand.
	self programmedMouseUp: evt for: self.

! !


!Morph methodsFor: 'private' stamp: 'sw 10/25/2000 06:11'!
moveWithPenDownBy: delta
	"If this is a costume for a player with its pen down, draw a line."

	| trailMorph tfm start tfmEnd |
	(trailMorph _ self trailMorph) ifNotNil:
		[tfm _ self owner transformFrom: trailMorph.
		start _  self referencePosition.
		trailMorph batchPenTrails
			ifTrue: [trailMorph notePenDown: true
								forPlayer: self player
								at: (tfm localPointToGlobal: start)]
			ifFalse: [trailMorph drawPenTrailFor: self
								from: (tfm localPointToGlobal: start)
								to: (tfmEnd _ tfm localPointToGlobal: start + delta).
					trailMorph noteNewLocation: tfmEnd forPlayer: self player]]
! !

!Morph methodsFor: 'private' stamp: 'nk 10/11/2003 16:08'!
privateAddAllMorphs: aCollection atIndex: index
	"Private. Add aCollection of morphs to the receiver"
	| myWorld itsWorld otherSubmorphs |
	myWorld _ self world.
	otherSubmorphs _ submorphs copyWithoutAll: aCollection.
	(index between: 0 and: otherSubmorphs size)
		ifFalse: [^ self error: 'index out of range'].
	index = 0
		ifTrue:[	submorphs _ aCollection asArray, otherSubmorphs]
		ifFalse:[	index = otherSubmorphs size
			ifTrue:[	submorphs _ otherSubmorphs, aCollection]
			ifFalse:[	submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]].
	aCollection do: [:m | | itsOwner |
		itsOwner _ m owner.
		itsOwner ifNotNil: [
			itsWorld _ m world.
			(itsWorld == myWorld) ifFalse: [
				itsWorld ifNotNil: [self privateInvalidateMorph: m].
				m outOfWorld: itsWorld].
			(itsOwner ~~ self) ifTrue: [
				m owner privateRemove: m.
				m owner removedMorph: m ]].
		m privateOwner: self.
		myWorld ifNotNil: [self privateInvalidateMorph: m].
		(myWorld == itsWorld) ifFalse: [m intoWorld: myWorld].
		itsOwner == self ifFalse: [
			self addedMorph: m.
			m noteNewOwner: self ].
	].
	self layoutChanged.
! !

!Morph methodsFor: 'private' stamp: 'nk 10/11/2003 16:08'!
privateAddMorph: aMorph atIndex: index

	| oldIndex myWorld itsWorld oldOwner |
	((index >= 1) and: [index <= (submorphs size + 1)])
		ifFalse: [^ self error: 'index out of range'].
	myWorld _ self world.
	oldOwner _ aMorph owner.
	(oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue:[
		"aMorph's position changes within in the submorph chain"
		oldIndex < index ifTrue:[
			"moving aMorph to back"
			submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1.
			submorphs at: index-1 put: aMorph.
		] ifFalse:[
			"moving aMorph to front"
			oldIndex-1 to: index by: -1 do:[:i|
				submorphs at: i+1 put: (submorphs at: i)].
			submorphs at: index put: aMorph.
		].
	] ifFalse:[
		"adding a new morph"
		oldOwner ifNotNil:[
			itsWorld _ aMorph world.
			itsWorld ifNotNil: [self privateInvalidateMorph: aMorph].
			(itsWorld == myWorld) ifFalse: [aMorph outOfWorld: itsWorld].
			oldOwner privateRemove: aMorph.
			oldOwner removedMorph: aMorph.
		].
		aMorph privateOwner: self.
		submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph).
		(itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld].
	].
	myWorld ifNotNil:[self privateInvalidateMorph: aMorph].
	self layoutChanged.
	oldOwner == self ifFalse: [
		self addedMorph: aMorph.
		aMorph noteNewOwner: self ].
! !

!Morph methodsFor: 'private'!
privateBounds: boundsRect
	"Private!! Use position: and/or extent: instead."

	fullBounds _ nil.
	bounds _ boundsRect.! !

!Morph methodsFor: 'private' stamp: 'jm 5/29/1998 21:28'!
privateColor: aColor

	color _ aColor.
! !

!Morph methodsFor: 'private' stamp: 'RAA 5/23/2000 11:31'!
privateDeleteWithAbsolutelyNoSideEffects
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."
	"used to delete a morph from an inactive world"

	owner ifNil: [^self].
	owner privateRemoveMorphWithAbsolutelyNoSideEffects: self.
	owner _ nil.

! !

!Morph methodsFor: 'private' stamp: 'tk 8/30/1998 09:58'!
privateFullBounds: boundsRect
	"Private!! Computed automatically."

	fullBounds _ boundsRect.! !

!Morph methodsFor: 'private' stamp: 'ar 12/16/2001 21:47'!
privateFullMoveBy: delta
	"Private!! Relocate me and all of my subMorphs by recursion. Subclasses that implement different coordinate systems may override this method."

	self privateMoveBy: delta.
	1 to: submorphs size do: [:i |
		(submorphs at: i) privateFullMoveBy: delta].
	owner ifNotNil:[
		owner isTextMorph ifTrue:[owner adjustTextAnchor: self]].! !

!Morph methodsFor: 'private' stamp: 'md 2/27/2006 08:55'!
privateMoveBy: delta 
	"Private!! Use 'position:' instead."
	| fill |
	extension ifNotNil: [extension player
				ifNotNil: ["Most cases eliminated fast by above test"
					self getPenDown
						ifTrue: ["If this is a costume for a player with its 
							pen down, draw a line."
							self moveWithPenDownBy: delta]]].
	bounds _ bounds translateBy: delta.
	fullBounds ifNotNil: [fullBounds _ fullBounds translateBy: delta].
	fill _ self fillStyle.
	fill isOrientedFill ifTrue: [fill origin: fill origin + delta]! !

!Morph methodsFor: 'private'!
privateOwner: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	owner _ aMorph.! !

!Morph methodsFor: 'private' stamp: 'RAA 5/23/2000 11:30'!
privateRemoveMorphWithAbsolutelyNoSideEffects: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."
	"used to delete a morph from an inactive world"

	submorphs _ submorphs copyWithout: aMorph.

! !

!Morph methodsFor: 'private' stamp: 'di 10/18/2004 21:49'!
privateRemove: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	submorphs _ submorphs copyWithout: aMorph.
	self layoutChanged.! !

!Morph methodsFor: 'private'!
privateSubmorphs
	"Private!! Use 'submorphs' instead."

	^ submorphs! !

!Morph methodsFor: 'private'!
privateSubmorphs: aCollection
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	submorphs _ aCollection.! !


!Morph methodsFor: 'accessing-backstop' stamp: 'wiz 2/14/2006 19:02'!
target: aMorph
"Morphs with targets will override. This backstop does nothing."
"This is here because targeting meta-actions are taken at morph level. 
Do not remove."! !


!Morph methodsFor: 'translation' stamp: 'yo 1/27/2005 23:29'!
accumlatePlayersInto: aCollection andSelectorsInto: selectorsCollection

	submorphs do: [:tile |
		(tile isMemberOf: TileMorph) ifTrue: [
			(tile type = #objRef and: [tile actualObject isKindOf: Player]) ifTrue: [
				aCollection add: tile actualObject
			]
		].
		(tile isKindOf: AssignmentTileMorph) ifTrue: [
			(tile type = #operator) ifTrue: [
				selectorsCollection add: tile operatorOrExpression
			]
		].
		tile accumlatePlayersInto: aCollection andSelectorsInto: selectorsCollection
	].
! !

!Morph methodsFor: 'translation' stamp: 'sw 3/7/2004 13:03'!
isPlayer: aPlayer ofReferencingTile: tile
	"Answer whether the given player is the object referred to by the given tile, or a sibling of that object.  This theoretically is only sent to PhraseTileMorphs, so this version is theoretically never reached"

	^ false! !

!Morph methodsFor: 'translation' stamp: 'yo 1/27/2005 23:33'!
isTurtleRow

	| aCollection selectorCollection |
	aCollection _ Set new.
	selectorCollection _ Set new.
	self accumlatePlayersInto: aCollection andSelectorsInto: selectorCollection.
	#(turtleCount: turtleCount grouped: grouped) do: [:sel |
		(selectorCollection includes: sel) ifTrue: [^ false].
	].

	aCollection do: [:e |
		(e isKindOf: KedamaExamplerPlayer) ifTrue: [^ true].
	].
	^ false.
! !

!Morph methodsFor: 'translation' stamp: 'yo 1/18/2004 10:31'!
traverseRowTranslateSlotOld: oldSlotName of: aPlayer to: newSlotName
	"Traverse my submorphs, translating submorphs appropriately given the slot rename"

	submorphs do: [:tile |
		(tile isKindOf: AssignmentTileMorph) ifTrue:
			[tile assignmentRoot = oldSlotName ifTrue:
				[(self isPlayer: aPlayer ofReferencingTile: tile) ifTrue:
					[tile setRoot: newSlotName]]].
		(tile isMemberOf: TileMorph) ifTrue:
			[(tile operatorOrExpression = (Utilities getterSelectorFor: oldSlotName)) ifTrue:
				[(self isPlayer: aPlayer ofReferencingTile: tile) ifTrue:
					[tile setOperator: (Utilities getterSelectorFor: newSlotName)]]].
		tile traverseRowTranslateSlotOld: oldSlotName of: aPlayer to: newSlotName]! !

!Morph methodsFor: 'translation' stamp: 'yo 1/18/2004 10:32'!
traverseRowTranslateSlotOld: oldSlotName to: newSlotName
	"Traverse my submorphs, translating submorphs appropriately given the slot rename"

	submorphs do: [:tile |
		(tile isKindOf: AssignmentTileMorph) ifTrue: 
			[tile assignmentRoot = oldSlotName ifTrue: [tile setRoot: newSlotName]].
		(tile isMemberOf: TileMorph) ifTrue:
			[(tile operatorOrExpression = (Utilities getterSelectorFor: oldSlotName)) ifTrue:
				[tile setOperator: (Utilities getterSelectorFor: newSlotName)]].
		tile traverseRowTranslateSlotOld: oldSlotName to: newSlotName]! !


!Morph methodsFor: 'e-toy support' stamp: 'sw 2/9/1999 17:43'!
adaptToWorld: aWorld
	"The receiver finds itself operating in a possibly-different new world.  If any of the receiver's parts are world-dependent (such as a target of a SimpleButtonMorph, etc.), then have them adapt accordingly"
	submorphs do: [:m | m adaptToWorld: aWorld].
	self eventHandler ifNotNil:
		[self eventHandler adaptToWorld: aWorld]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 5/17/2001 12:47'!
adoptVocabulary: aVocabulary
	"Make aVocabulary be the one used by me and my submorphs"

	self submorphsDo: [:m | m adoptVocabulary: aVocabulary]! !

!Morph methodsFor: 'e-toy support' stamp: 'yo 1/9/2004 16:10'!
allMorphsAndBookPagesInto: aSet
	"Return a set of all submorphs.  Don't forget the hidden ones like BookMorph pages that are not showing.  Consider only objects that are in memory (see allNonSubmorphMorphs)." 

	submorphs do: [:m | m allMorphsAndBookPagesInto: aSet].
	self allNonSubmorphMorphs do: [:m | 
			(aSet includes: m) ifFalse: ["Stop infinite recursion"
				m allMorphsAndBookPagesInto: aSet]].
	aSet add: self.
	self player ifNotNil:
		[self player allScriptEditors do: [:e | e allMorphsAndBookPagesInto: aSet]].
	^ aSet! !

!Morph methodsFor: 'e-toy support' stamp: 'RAA 1/13/2001 11:27'!
appearsToBeSameCostumeAs: aMorph

	^false
! !

!Morph methodsFor: 'e-toy support'!
asNumber: aPointOrNumber
	"Support for e-toy demo."

	aPointOrNumber class = Point
		ifTrue: [^ aPointOrNumber r]
		ifFalse: [^ aPointOrNumber].
! !

!Morph methodsFor: 'e-toy support' stamp: 'nk 1/6/2004 12:37'!
asWearableCostume
	"Return a wearable costume for some player"
	^(World drawingClass withForm: self imageForm) copyCostumeStateFrom: self! !

!Morph methodsFor: 'e-toy support' stamp: 'mir 6/13/2001 14:34'!
asWearableCostumeOfExtent: extent
	"Return a wearable costume for some player"
	^self asWearableCostume! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 12/20/1999 17:36'!
automaticViewing
	"Backstop, in case this message gets sent to an owner that is not a playfield"
	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 5/18/2001 11:17'!
changeAllBorderColorsFrom: oldColor to: newColor
	"Set any occurrence of oldColor as a border color in my entire submorph tree to be newColor"

	(self allMorphs select: [:m | m respondsTo: #borderColor:]) do:
		[:aMorph | aMorph borderColor = oldColor ifTrue: [aMorph borderColor: newColor]]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/1/97 00:18'!
configureForKids
	submorphs ifNotNil:
		[submorphs do: [:m | m configureForKids]]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 2/6/2001 04:21'!
containingWindow
	"Answer a window or window-with-mvc that contains the receiver"

	^ self ownerThatIsA: SystemWindow orA: MVCWiWPasteUpMorph! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 9/23/2000 22:38'!
copyCostumeStateFrom: aMorph
	"Copy all state that should be persistant for costumes from aMorph"
	self rotationCenter: aMorph rotationCenter.
	self rotationStyle: aMorph rotationStyle.
	self referencePosition: aMorph referencePosition.
	self forwardDirection: aMorph forwardDirection.
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/22/1998 20:28'!
currentPlayerDo: aBlock
	"If the receiver is a viewer/scriptor associated with a current Player object, evaluate the given block against that object"! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/8/2000 16:34'!
cursor
	"vacuous backstop in case it gets sent to a morph that doesn't know what to do with it"

	^ 1! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/7/2000 09:28'!
cursor: aNumber
	"vacuous backstop in case it gets sent to a morph that doesn't know what to do with it"
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/13/2002 17:44'!
decimalPlacesForGetter: aGetter
	"Answer the decimal places I prefer for showing a slot with the given getter, or nil if none"

	| decimalPrefs |
	decimalPrefs _ self renderedMorph valueOfProperty: #decimalPlacePreferences ifAbsent: [^ nil].
	^ decimalPrefs at: aGetter ifAbsent: [nil]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/24/2000 05:52'!
defaultValueOrNil
	"If the receiver has a property named #defaultValue, return that property's value, else return nil"

	^ self valueOfProperty: #defaultValue ifAbsent: [nil]! !

!Morph methodsFor: 'e-toy support' stamp: 'sd 3/30/2005 22:04'!
defaultVariableName
	"If the receiver is of the sort that wants a variable maintained on its behalf in the 'card' data, then return a variable name to be used for that datum.  What is returned here is only a point of departure in the forthcoming negotiation"

	^ Scanner wellFormedInstanceVariableNameFrom: (self valueOfProperty: #variableName ifAbsent: [self externalName])! !

!Morph methodsFor: 'e-toy support' stamp: 'nb 6/17/2003 12:25'!
definePath
	| points lastPoint aForm offset currentPoint dwell ownerPosition |
	points _ OrderedCollection new: 70.
	lastPoint _ nil.
	aForm _ self imageForm.
	offset _ aForm extent // 2.
	ownerPosition _ owner position.
	Cursor move show.
	Sensor waitButton.
	[Sensor anyButtonPressed and: [points size < 100]] whileTrue:
		[currentPoint _ Sensor cursorPoint.
		dwell _ 0.
		currentPoint = lastPoint
			ifTrue:
				[dwell _ dwell + 1.
				((dwell \\ 1000) = 0) ifTrue:
					[Beeper beep]]
			ifFalse:
				[self position: (currentPoint - offset).
				self world displayWorld.
				(Delay forMilliseconds: 20) wait.
				points add: currentPoint.
				lastPoint _ currentPoint]].
	points size > 1
		ifFalse:
			[self inform: 'no path obtained']
		ifTrue:
			[points size = 100 ifTrue: [self playSoundNamed: 'croak'].

			Transcript cr; show: 'path defined with
', points size printString, ' points'.
			self renderedMorph setProperty: #pathPoints toValue: 
				(points collect: [:p | p - ownerPosition])].

	Cursor normal show
		! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 1/5/1999 10:05'!
deletePath
	self removeProperty: #pathPoints! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/26/1999 23:32'!
embeddedInMorphicWindowLabeled: labelString
	| window |
	window _ (SystemWindow labelled: labelString) model: nil.
	window setStripeColorsFrom: nil defaultBackgroundColor.
	window addMorph: self frame: (0@0 extent: 1@1).
	^ window! !

!Morph methodsFor: 'e-toy support' stamp: 'RAA 5/25/2000 09:06'!
embedInWindow

	| window worldToUse |

	worldToUse _ self world.		"I'm assuming we are already in a world"
	window _ (SystemWindow labelled: self defaultLabelForInspector) model: nil.
	window bounds: ((self position - ((0@window labelHeight) + window borderWidth))
						corner: self bottomRight + window borderWidth).
	window addMorph: self frame: (0@0 extent: 1@1).
	window updatePaneColors.
	worldToUse addMorph: window.
	window activate! !

!Morph methodsFor: 'e-toy support' stamp: 'dgd 2/22/2003 14:31'!
enclosingEditor
	"Return the next editor around the receiver"

	| tested |
	tested := owner.
	[tested isNil] whileFalse: 
			[tested isTileEditor ifTrue: [^tested].
			tested := tested owner].
	^nil! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 2/15/1999 19:38'!
enforceTileColorPolicy
	Preferences coloredTilesEnabled
		ifTrue:
			[self makeAllTilesColored]
		ifFalse:
			[self makeAllTilesGreen]! !

!Morph methodsFor: 'e-toy support' stamp: 'RAA 10/4/2000 08:29'!
fenceEnabled

	"in case a non-pasteUp is used as a container"

	^Preferences fenceEnabled! !

!Morph methodsFor: 'e-toy support' stamp: 'nb 6/17/2003 12:25'!
followPath
	| pathPoints offset |
	(pathPoints _ self renderedMorph valueOfProperty: #pathPoints) ifNil: [^ Beeper beep].
	offset _ owner position - (self extent // 2).
	pathPoints do:
		[:aPoint |
			self position: aPoint + offset.
			self world displayWorld.
			(Delay forMilliseconds: 20) wait]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 2/18/2003 02:54'!
getCharacters
	"obtain a string value from the receiver.  The default generic response is simply the name of the object."

	^ self externalName! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/1/2000 10:15'!
getNumericValue
	"Only certain kinds of morphs know how to deal with this frontally; here we provide support for a numeric property of any morph"

	^ self valueOfProperty: #numericValue ifAbsent: [0]! !

!Morph methodsFor: 'e-toy support' stamp: 'kfr 9/4/2004 15:22'!
gridFormOrigin: origin grid: smallGrid background: backColor line: lineColor

	| bigGrid gridForm gridOrigin |
	gridOrigin _ origin \\ smallGrid.
	bigGrid _ (smallGrid asPoint x) @ (smallGrid asPoint y).
	gridForm _ Form extent: bigGrid depth: Display depth.
	backColor ifNotNil: [gridForm fillWithColor: backColor].
	gridOrigin x to: gridForm width by: smallGrid x do:
		[:x | gridForm fill: (x@0 extent: 1@gridForm height) fillColor: lineColor].
	gridOrigin y to: gridForm height by: smallGrid y do:
		[:y | gridForm fill: (0@y extent: gridForm width@1) fillColor: lineColor].
	^ InfiniteForm with: gridForm
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 4/12/2005 23:07'!
handUserASibling
	"Make and hand the user a sibling instance.  Force the creation of a uniclass at this point if one does not already exist for the receiver."

	| topRend |
	topRend _ self topRendererOrSelf.
	topRend couldMakeSibling ifFalse: [^ Beeper beep].

	topRend assuredPlayer assureUniClass.
	(topRend makeSiblings: 1) first openInHand! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/21/1998 15:54'!
isAViewer
	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 6/30/1999 20:29'!
isCandidateForAutomaticViewing
	^ true! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 2/7/2001 17:58'!
isTileEditor
	"No, I'm not"
	^false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/9/2000 16:48'!
listViewLineForFieldList: aFieldList
	"Answer a ListLineView object which describes the receiver"

	| aLine |
	aLine _ ListViewLine new objectRepresented: self.
	aFieldList do:
		[:fieldSym | aLine addMorphBack: (self readoutForField: fieldSym).
		aLine addTransparentSpacerOfSize: (7 @ 0)].
	^ aLine! !

!Morph methodsFor: 'e-toy support' stamp: 'dgd 9/6/2003 18:10'!
makeGraphPaper
	| smallGrid backColor lineColor |
	smallGrid _ Compiler evaluate: (FillInTheBlank request: 'Enter grid size' translated initialAnswer: '16').
	smallGrid ifNil: [^ self].
	Utilities informUser: 'Choose a background color' translated during: [backColor _ Color fromUser].
	Utilities informUser: 'Choose a line color' translated during: [lineColor _ Color fromUser].
	self makeGraphPaperGrid: smallGrid background: backColor line: lineColor.! !

!Morph methodsFor: 'e-toy support' stamp: 'di 9/7/2000 20:44'!
makeGraphPaperGrid: smallGrid background: backColor line: lineColor

	| gridForm |
	gridForm _ self gridFormOrigin: 0@0 grid: smallGrid asPoint background: backColor line: lineColor.
	self color: gridForm.
	self world ifNotNil: [self world fullRepaintNeeded].
	self changed: #newColor.  "propagate to view"
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 4/16/1998 13:46'!
mustBeBackmost
	"Answer whether the receiver needs to be the backmost morph in its owner's submorph list"

	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/13/2002 17:45'!
noteDecimalPlaces: aNumber forGetter: aGetter
	"Make a mental note of the user's preference for a particular number of decimal places to be associated with the slot with the given getter"

	(self renderedMorph valueOfProperty: #decimalPlacePreferences ifAbsentPut: [IdentityDictionary new])
		at: aGetter put: aNumber! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/26/2000 11:37'!
noteNegotiatedName: uniqueName for: requestedName
	"This works, kind of, for morphs that have a single variable.  Still holding out for generality of morphs being able to have multiple variables, but need a driving example"

	self setProperty: #variableName toValue: uniqueName.
	self setProperty: #setterSelector toValue: (Utilities setterSelectorFor: uniqueName).
	self setNameTo: uniqueName! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/9/2000 06:43'!
objectViewed
	"Answer the morph associated with the player that the structure the receiver currently finds itself within represents."

	^ (self outermostMorphThat: [:o | o isKindOf: Viewer orOf: ScriptEditorMorph]) objectViewed! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 8/31/2004 14:11'!
pinkXButton
	"Answer a button with the old X on a pink background, targeted to self"

	| aButton |
	aButton _ IconicButton new labelGraphic: (ScriptingSystem formAtKey: #PinkX).
	aButton color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonUp.
	aButton target: self.
	^ aButton! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/11/2004 16:23'!
referencePlayfield
	"Answer the PasteUpMorph to be used for cartesian-coordinate reference"

	| former |
	owner ifNotNil:
		[(self topRendererOrSelf owner isHandMorph and: [(former _ self formerOwner) notNil])
			ifTrue:
				[former _ former renderedMorph.
				^ former isPlayfieldLike 
					ifTrue: [former]
					ifFalse: [former referencePlayfield]]].

	self allOwnersDo: [:o | o isPlayfieldLike ifTrue: [^ o]].
	^ ActiveWorld! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 9/23/2000 22:40'!
rotationStyle
	"Return the 'rotation style' of the receiver"
	^#normal! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 9/23/2000 22:40'!
rotationStyle: aSymbol
	"Set the 'rotation style' of the receiver; this is ignored for non-sketches"! !

!Morph methodsFor: 'e-toy support' stamp: 'RAA 3/9/2001 14:37'!
setAsActionInButtonProperties: buttonProperties

	^false	"means I don't know how to be set as a button action"! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/15/2000 06:26'!
setNumericValue: aValue
	"Set the receiver's contents to reflect the given numeric value.  Only certain kinds of morphs know what to do with this, the rest, for now, stash the number in a property, where it may not be visible but at least it won't be lost, and can be retrieved by the companion getter.  This code is never reached under normal circumstances, because the #numericValue slot is not shown in Viewers for most kinds of morphs, and those kinds of morphs that do show it also reimplement this method.  However, this code *could* be reached via a user script which sends #setNumericValue: but whose receiver has been changed, via tile-scripting drag and drop for example, to one that doesn't directly handle numbers"

	ScriptingSystem informScriptingUser: 'an unusual setNumericValue: call was made'.
	self renderedMorph setProperty: #numericValue toValue: aValue
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 7/21/1998 21:18'!
setStandardTexture
	| parms |
	parms _ self textureParameters.
	self makeGraphPaperGrid: parms first
		background: parms second
		line: parms third! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/27/2000 17:46'!
slotSpecifications
	"A once and possibly future feature; retained here for backward-compatibility bulletproofing."

	^ #()! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 8/11/1998 16:55'!
succeededInRevealing: aPlayer
	aPlayer == self player ifTrue: [^ true].
	submorphs do:
		[:m | (m succeededInRevealing: aPlayer) ifTrue: [^ true]].
	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 8/31/2004 14:06'!
tanOButton
	"Answer a button with the old O on a tan background, targeted to self"

	| aButton |
	aButton _ IconicButton new labelGraphic: (ScriptingSystem formAtKey: #TanO).
	aButton color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonUp.
	aButton target: self.
	^ aButton! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 7/21/1998 21:17'!
textureParameters
	"Answer a triplet giving the preferred grid size, background color, and line color.  The choices here are as suggested by Alan, 9/13/97"

	^ Array with: 16 with: Color lightYellow with: Color lightGreen lighter lighter! !

!Morph methodsFor: 'e-toy support' stamp: 'dgd 2/22/2003 14:35'!
topEditor
	"Return the top-most editor around the receiver"

	| found tested |
	tested := self.
	[tested isNil] whileFalse: 
			[tested isTileEditor ifTrue: [found := tested].
			tested := tested owner].
	^found! !

!Morph methodsFor: 'e-toy support' stamp: 'dgd 10/8/2003 19:30'!
unlockOneSubpart
	| unlockables aMenu reply |
	unlockables _ self submorphs select:
		[:m | m isLocked].
	unlockables size <= 1 ifTrue: [^ self unlockContents].
	aMenu _ SelectionMenu labelList: (unlockables collect: [:m | m externalName]) selections: unlockables.
	reply _ aMenu startUpWithCaption: 'Who should be be unlocked?' translated.
	reply isNil ifTrue: [^ self].
	reply unlock! !

!Morph methodsFor: 'e-toy support' stamp: 'tk 10/19/1999 07:16'!
updateCachedThumbnail
	"If I have a cached thumbnail, then update it.  Copied up from Dan's original version in PasteUpMorph so it can be used by all morphs."
	| cachedThumbnail |

	(cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil:
		[(cachedThumbnail respondsTo: #computeThumbnail) 
			ifTrue: [cachedThumbnail computeThumbnail]
			ifFalse: [self removeProperty: #computeThumbnail]].
		"Test and removal are because the thumbnail is being replaced by another Morph.  We don't know why.  Need to fix that at the source."! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 11/27/2001 14:52'!
wantsRecolorHandle
	"Answer whether the receiver would like a recoloring halo handle to be put up.  Since this handle also presently affords access to the property-sheet, it is presently always allowed, even though SketchMorphs don't like regular recoloring"

	^ true
	
! !

!Morph methodsFor: 'e-toy support' stamp: 'RAA 2/5/2001 15:35'!
wrappedInWindowWithTitle: aTitle
	| aWindow w2 |
	aWindow _ (SystemWindow labelled: aTitle) model: Model new.
	aWindow addMorph: self frame: (0@0 extent: 1@1).
	w2 _ aWindow borderWidth * 2.
	w2 _ 3.		"oh, well"
	aWindow extent: self fullBounds extent + (0 @ aWindow labelHeight) + (w2 @ w2).
	^ aWindow! !

!Morph methodsFor: 'e-toy support' stamp: 'tk 9/3/1999 11:46'!
wrappedInWindow: aSystemWindow
	| aWindow |
	aWindow _ aSystemWindow model: Model new.
	aWindow addMorph: self frame: (0@0 extent: 1@1).
	aWindow extent: self extent.
	^ aWindow! !


!Morph methodsFor: 'messenger' stamp: 'sw 11/3/2001 12:23'!
affiliatedSelector
	"Answer a selector affiliated with the receiver for the purposes of launching a messenger.   Reimplement this to plug into the messenger service"

	^ nil! !


!Morph methodsFor: 'geniestubs' stamp: 'nk 3/10/2004 09:58'!
allowsGestureStart: evt
	^false! !

!Morph methodsFor: 'geniestubs' stamp: 'nk 3/11/2004 17:45'!
isGestureStart: anEvent
	"This mouse down could be the start of a gesture, or the end of a gesture focus"

	anEvent hand isGenieEnabled
		ifFalse: [ ^false ].

	(self allowsGestureStart: anEvent)
		ifTrue: [^ true ].		"could be the start of a gesture"

	"otherwise, check for whether it's time to disable the Genie auto-focus"
	(anEvent hand isGenieFocused
		and: [anEvent whichButton ~= anEvent hand focusStartEvent whichButton])
			ifTrue: [anEvent hand disableGenieFocus].

	^false! !

!Morph methodsFor: 'geniestubs' stamp: 'nk 3/11/2004 17:30'!
mouseStillDownStepRate
	"At what rate do I want to receive #mouseStillDown: notifications?"
	^1! !

!Morph methodsFor: 'geniestubs' stamp: 'nk 3/10/2004 06:38'!
redButtonGestureDictionaryOrName: aSymbolOrDictionary! !

!Morph methodsFor: 'geniestubs' stamp: 'nk 3/10/2004 06:38'!
yellowButtonGestureDictionaryOrName: aSymbolOrDictionary! !


!Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'di 9/22/1999 08:45'!
asEPS

	^ EPSCanvas morphAsPostscript: self rotated: false.
! !

!Morph methodsFor: '*morphic-Postscript Canvases'!
asPostscript
	^self asEPS.
! !

!Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'di 9/22/1999 08:45'!
asPostscriptPrintJob

	^ DSCPostscriptCanvas morphAsPostscript: self rotated: false.
! !

!Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'ar 1/16/2001 17:06'!
clipPostscript
	^Clipboard clipboardText: self asPostscript.

! !

!Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'mpw 8/10/1930 05:21'!
drawPostscriptOn: aCanvas

	self drawOn:aCanvas.
! !

!Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'mpw 8/10/1930 05:25'!
fullDrawPostscriptOn: aCanvas

	self fullDrawOn:aCanvas.
! !

!Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'nk 12/29/2003 10:55'!
printPSToFile
	
	self printPSToFileNamed: self externalName! !


!Morph methodsFor: 'player' stamp: 'tk 10/30/2001 12:13'!
assuredCardPlayer
	"Answer the receiver's player, creating a new one if none currently exists"

	| aPlayer |
	(aPlayer _ self player) ifNotNil: [
		(aPlayer isKindOf: CardPlayer) 
				ifTrue: [^ aPlayer]
				ifFalse: [self error: 'Must convert to a CardPlayer']
					"later convert using as: and remove the error"].
	self assureExternalName.  "a default may be given if not named yet"
	self player: (aPlayer _ UnscriptedCardPlayer newUserInstance).
		"Force it to be a CardPlayer.  Morph class no longer dictates what kind of player"
	aPlayer costume: self.
	self presenter ifNotNil: [self presenter flushPlayerListCache].
	^ aPlayer! !

!Morph methodsFor: 'player' stamp: 'sw 2/19/1999 09:06'!
assuredPlayer
	"Answer the receiver's player, creating a new one if none currently exists"

	| aPlayer |
	(aPlayer _ self player) ifNil:
		[self assureExternalName.  "a default may be given if not named yet"
		self player: (aPlayer _ self newPlayerInstance).  
			"Different morphs may demand different player types"
		aPlayer costume: self.
		self presenter ifNotNil: [self presenter flushPlayerListCache]].
	^ aPlayer! !

!Morph methodsFor: 'player' stamp: 'sw 8/10/2000 00:06'!
assureExternalName
	| aName |
	^ (aName _ self knownName) ifNil:
		[self setNameTo: (aName _ self externalName).
		^ aName]! !

!Morph methodsFor: 'player' stamp: 'sw 10/27/2000 17:38'!
currentDataValue
	"Answer the data value associated with the receiver.  Useful in conjunction with default-value setting"

	^ nil! !

!Morph methodsFor: 'player' stamp: 'sw 9/15/1998 13:33'!
newPlayerInstance
	^ UnscriptedPlayer newUserInstance! !

!Morph methodsFor: 'player' stamp: 'sw 1/22/2001 14:25'!
okayToDuplicate
	"Formerly this protocol was used to guard against awkward situations when there were anonymous scripts in the etoy system.  Nowadays we just always allow duplication"

	^ true! !

!Morph methodsFor: 'player' stamp: 'mir 6/13/2001 14:45'!
shouldRememberCostumes
	^true! !

!Morph methodsFor: 'player' stamp: 'sw 8/11/1998 16:54'!
showPlayerMenu
	self player ifNotNil:
		[self player showPlayerMenu]! !

!Morph methodsFor: 'player' stamp: 'sw 10/6/2000 07:37'!
variableDocks
	"Answer a list of VariableDocker objects for docking up my data with an instance held in my containing playfield.  The simple presence of some objects on a Playfield will result in the maintenance of instance data on the corresponding Card.  This is a generalization of the HyperCard 'field' idea.  If there is already a cachedVariableDocks cached, use that.  For this all to work happily, one must be certain to invalidate the #cachedVariableDocks cache when that's appropriate."

	^ self valueOfProperty: #cachedVariableDocks ifAbsent: [#()]! !


!Morph methodsFor: 'player commands' stamp: 'nb 6/17/2003 12:25'!
beep: soundName

	self playSoundNamed: soundName
! !

!Morph methodsFor: 'player commands'!
jumpTo: aPoint
	"Let my owner decide how I move."

	owner move: self toPosition: aPoint.
! !

!Morph methodsFor: 'player commands' stamp: 'sw 2/16/1999 11:33'!
makeFenceSound
	Preferences soundsEnabled ifTrue:
		[self playSoundNamed: 'scratch'].
! !

!Morph methodsFor: 'player commands' stamp: 'gk 2/23/2004 21:08'!
playSoundNamed: soundName
	"Play the sound with the given name.
	Does nothing if this image lacks sound playing facilities."

	SoundService default playSoundNamed: soundName asString! !

!Morph methodsFor: 'player commands'!
set: aPointOrNumber
	"Set my position."

	self jumpTo: aPointOrNumber.
! !


!Morph methodsFor: 'button properties' stamp: 'RAA 3/8/2001 14:45'!
buttonProperties

	^self valueOfProperty: #universalButtonProperties! !

!Morph methodsFor: 'button properties' stamp: 'RAA 3/8/2001 14:45'!
buttonProperties: propertiesOrNil

	propertiesOrNil ifNil: [
		self removeProperty: #universalButtonProperties
	] ifNotNil: [
		self setProperty: #universalButtonProperties toValue: propertiesOrNil
	].! !

!Morph methodsFor: 'button properties' stamp: 'RAA 3/8/2001 07:49'!
ensuredButtonProperties

	self hasButtonProperties ifFalse: [
		self buttonProperties: (ButtonProperties new visibleMorph: self)
	].
	^self buttonProperties! !

!Morph methodsFor: 'button properties' stamp: 'RAA 3/8/2001 07:18'!
hasButtonProperties

	^self hasProperty: #universalButtonProperties! !


!Morph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 9/11/2004 17:12'!
categoriesForViewer
	"Answer a list of symbols representing the categories to offer in the 
	viewer, in order"
	| dict aList |
	dict := Dictionary new.
	self unfilteredCategoriesForViewer
		withIndexDo: [:cat :index | dict at: cat put: index].
	self filterViewerCategoryDictionary: dict.
	aList := SortedCollection
				sortBlock: [:a :b | (dict at: a)
						< (dict at: b)].
	aList addAll: dict keys.
	^ aList asArray! !

!Morph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 8/29/2004 17:09'!
selectorsForViewer
	"Answer a list of symbols representing all the selectors available in all my viewer categories"

	| aClass aList itsAdditions added addBlock |
	aClass := self renderedMorph class.
	aList := OrderedCollection new.
	added := Set new.
	addBlock := [ :sym | (added includes: sym) ifFalse: [ added add: sym. aList add: sym ]].

	[aClass == Morph superclass] whileFalse: 
			[(aClass hasAdditionsToViewerCategories) 
				ifTrue: 
					[itsAdditions := aClass allAdditionsToViewerCategories.
					itsAdditions do: [ :add | add do: [:aSpec |
									"the spec list"

									aSpec first == #command ifTrue: [ addBlock value: aSpec second].
									aSpec first == #slot 
										ifTrue: 
											[ addBlock value: (aSpec seventh).
											 addBlock value: aSpec ninth]]]].
			aClass := aClass superclass].

	^aList copyWithoutAll: #(#unused #dummy)

	"SimpleSliderMorph basicNew selectorsForViewer"! !

!Morph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 8/29/2004 17:14'!
selectorsForViewerIn: aCollection
	"Answer a list of symbols representing all the selectors available in all my viewer categories, selecting only the ones in aCollection"

	| aClass aList itsAdditions added addBlock |
	aClass := self renderedMorph class.
	aList := OrderedCollection new.
	added := Set new.
	addBlock := [ :sym |
		(added includes: sym) ifFalse: [ (aCollection includes: sym)
			ifTrue: [ added add: sym. aList add: sym ]]].

	[aClass == Morph superclass] whileFalse: 
			[(aClass hasAdditionsToViewerCategories) 
				ifTrue: 
					[itsAdditions := aClass allAdditionsToViewerCategories.
					itsAdditions do: [ :add | add do: [:aSpec |
									"the spec list"

									aSpec first == #command ifTrue: [ addBlock value: aSpec second].
									aSpec first == #slot 
										ifTrue: 
											[ addBlock value: (aSpec seventh).
											 addBlock value: aSpec ninth]]]].
			aClass := aClass superclass].

	^aList copyWithoutAll: #(#unused #dummy)

	"SimpleSliderMorph basicNew selectorsForViewerIn: 
	#(setTruncate: getColor setColor: getKnobColor setKnobColor: getWidth setWidth: getHeight setHeight: getDropEnabled setDropEnabled:)
	"! !

!Morph 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."
	^false! !


!Morph methodsFor: 'object fileIn' stamp: 'dgd 2/22/2003 14:30'!
convertAugust1998: varDict using: smartRefStrm 
	"These variables are automatically stored into the new instance 
	('bounds' 'owner' 'submorphs' 'fullBounds' 'color' ). 
	This method is for additional changes. Use statements like (foo _ 
	varDict at: 'foo')."

	"Be sure to to fill in ('extension' ) and deal with the information 
	in ('eventHandler' 'properties' 'costumee' )"

	"This method moves all property variables as well as 
	eventHandler, and costumee into a morphicExtension."

	"Move refs to eventhandler and costumee into extension"

	| propVal |
	(varDict at: 'eventHandler') isNil 
		ifFalse: [self eventHandler: (varDict at: 'eventHandler')].
	(varDict at: 'costumee') isNil 
		ifFalse: [self player: (varDict at: 'costumee')].
	(varDict at: 'properties') isNil 
		ifFalse: 
			[(varDict at: 'properties') keys do: 
					[:key | 
					"Move property extensions into extension"

					propVal := (varDict at: 'properties') at: key.
					propVal ifNotNil: 
							[key == #possessive 
								ifTrue: [propVal == true ifTrue: [self bePossessive]]
								ifFalse: 
									[key ifNotNil: [self assureExtension convertProperty: key toValue: propVal]]]]]! !

!Morph methodsFor: 'object fileIn' stamp: 'md 2/27/2006 09:56'!
convertNovember2000DropShadow: varDict using: smartRefStrm 
	"Work hard to eliminate the DropShadow. Inst vars are already  
	stored into."

	| rend |
	submorphs notEmpty 
		ifTrue: 
			[rend := submorphs first renderedMorph.
			"a text?"
			rend setProperty: #hasDropShadow toValue: true.
			rend setProperty: #shadowColor toValue: (varDict at: 'color').
			rend setProperty: #shadowOffset toValue: (varDict at: 'shadowOffset').
			"ds owner ifNotNil: [ds owner addAllMorphs: ds  
			submorphs]. ^rend does this"
			rend privateOwner: owner.
			extension ifNotNil: [
				extension actorState  ifNotNil: [rend actorState: self extension actorState].
				extension externalName ifNotNil: [rend setNameTo: self extension externalName].
				extension player ifNotNil: [
							rend player: extension player.
							extension player rawCostume: rend]].
			^rend].
	(rend := Morph new) color: Color transparent.
	^rend! !


!Morph methodsFor: 'system primitives' stamp: 'sw 10/27/2000 17:37'!
creationStamp
	"Answer the creation stamp stored within the receiver, if any"

	^ self valueOfProperty: #creationStamp ifAbsent: [super creationStamp]! !


!Morph methodsFor: 'button' stamp: 'sw 2/6/2001 23:09'!
doButtonAction
	"If the receiver has a button-action defined, do it now.  The default button action of any morph is, well, to do nothing.  Note that there are several ways -- too many ways -- for morphs to have button-like actions.  This one refers not to the #mouseUpCodeToRun feature, nor does it refer to the Player-scripting mechanism.  Instead it is intended for morph classes whose very nature is to be buttons -- this method provides glue so that arbitrary buttons on the UI can be 'fired' programatticaly from user scripts"! !

!Morph methodsFor: 'button' stamp: 'sw 2/6/2001 23:22'!
fire
	"If the receiver has any kind of button-action defined, fire that action now.   Any morph can have special, personal mouseUpCodeToRun, and that will be triggered by this.  Additionally, some morphs have specific buttonness, and these get sent the #doButtonAction message to carry out their firing.  Finally, some morphs have mouse behaviors associated with one or more Player scripts.
	For the present, we'll try out doing *all* the firings this object can do. "

	self firedMouseUpCode.   	"This will run the mouseUpCodeToRun, if any"

	self player ifNotNil:		
		[self player fireOnce].  "Run mouseDown and mouseUp scripts"

	self doButtonAction			"Do my native button action, if any"! !

!Morph methodsFor: 'button' stamp: 'dgd 2/22/2003 14:31'!
firedMouseUpCode
	"If the user has special mouseUpCodeToRun, then fire it once right now and return true, else return false"

	| evt |
	(self world isNil or: [self mouseUpCodeOrNil isNil]) ifTrue: [^false].
	evt := MouseEvent new 
				setType: nil
				position: self center
				buttons: 0
				hand: self world activeHand.
	self programmedMouseUp: evt for: self.
	^true! !


!Morph methodsFor: 'event handling-override' stamp: 'nk 3/10/2004 19:47'!
handlerForMouseDown: anEvent 
	"Return the (prospective) handler for a mouse down event. The handler is temporarily 
	installed and can be used for morphs further down the hierarchy to negotiate whether 
	the inner or the outer morph should finally handle the event."

	anEvent blueButtonPressed
		ifTrue: [^ self handlerForBlueButtonDown: anEvent].
	anEvent yellowButtonPressed
		ifTrue: [^ self handlerForYellowButtonDown: anEvent].
	anEvent controlKeyPressed
		ifTrue: [^ self handlerForMetaMenu: anEvent].
	(self handlesMouseDown: anEvent)
		ifFalse: [^ nil].	"not interested"

	anEvent handler
		ifNil: [^ self ].	"Same priority but I am innermost"

	"Nobody else was interested"
	^self mouseDownPriority >= anEvent handler mouseDownPriority
		ifTrue: [ self]
		ifFalse: [ nil]! !


!Morph methodsFor: 'texture support' stamp: 'dgd 2/16/2003 20:02'!
isValidWonderlandTexture
	"Return true if the receiver is a valid wonderland texture"
	^ self
		valueOfProperty: #isValidWonderlandTexture
		ifAbsent: [true]! !


!Morph methodsFor: 'model access' stamp: 'nk 3/10/2004 19:51'!
models
	"Answer a collection of whatever models I may have."

	self modelOrNil ifNil: [ ^EmptyArray ].
	^Array with: self modelOrNil! !


!Morph methodsFor: 'player viewer' stamp: 'wiz 1/1/2006 12:58'!
openViewerForArgument
	"Open up a viewer for a player associated with the morph in question. "
	self presenter viewMorph: self! !

!Morph methodsFor: 'player viewer' stamp: 'sw 3/13/98 17:40'!
updateLiteralLabel
	"Backstop -- updatingStringMorphs inform their owners with this message when they've changed; some Morphs care, others don't"! !


!Morph methodsFor: 'other' stamp: 'sw 10/30/2001 13:12'!
removeAllButFirstSubmorph
	"Remove all of the receiver's submorphs other than the first one."

	self submorphs allButFirst do: [:m | m delete]! !


!Morph methodsFor: 'selected object' stamp: 'dgd 8/28/2004 16:30'!
selectedObject
	"answer the selected object for the hand or nil is none"
	^ self primaryHand selectedObject! !


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

Morph class
	instanceVariableNames: ''!

!Morph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 16:43'!
initialize
	"Morph initialize"

	"this empty array object is shared by all morphs with no submorphs:"
	EmptyArray _ Array new.
	FileList registerFileReader: self! !


!Morph class methodsFor: 'connectors-scripting' stamp: 'nk 9/10/2004 11:34'!
additionsToViewerCategoryConnection
	"Answer viewer additions for the 'connection' category"
	"Vocabulary initialize"

	^{
		#'connections to me'.
		#(
		(command tellAllPredecessors: 'Send a message to all graph predecessors' ScriptName)
		(command tellAllSuccessors: 'Send a message to all graph predecessors' ScriptName)
		(command tellAllIncomingConnections: 'Send a message to all the connectors whose destination end is connected to me' ScriptName)
		(command tellAllOutgoingConnections: 'Send a message to all the connectors whose source end is connected to me' ScriptName)
		(slot incomingConnectionCount 'The number of connectors whose destination end is connected to me' Number readOnly Player getIncomingConnectionCount unused unused)
		(slot outgoingConnectionCount 'The number of connectors whose source end is connected to me' Number readOnly Player getOutgoingConnectionCount unused unused)
		)
	}
! !


!Morph class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:54'!
fileReaderServicesForFile: fullName suffix: suffix

	^({ 'morph'. 'morphs'. 'sp'. '*' } includes: suffix)
		ifTrue: [
			{SimpleServiceEntry 
				provider: self 
				label: 'load as morph'
				selector: #fromFileName:
				description: 'load as morph'}]
		ifFalse: [#()]! !

!Morph class methodsFor: 'fileIn/Out' stamp: 'yo 8/7/2003 11:02'!
fromFileName: fullName
	"Reconstitute a Morph from the file, presumed to be represent a Morph saved
	via the SmartRefStream mechanism, and open it in an appropriate Morphic world"

 	| aFileStream morphOrList |
	aFileStream _ (MultiByteBinaryOrTextStream with: ((FileStream readOnlyFileNamed: fullName) binary contentsOfEntireFile)) binary reset.
	morphOrList _ aFileStream fileInObjectAndCode.
	(morphOrList isKindOf: SqueakPage) ifTrue: [morphOrList _ morphOrList contentsMorph].
	Smalltalk isMorphic
		ifTrue: [ActiveWorld addMorphsAndModel: morphOrList]
		ifFalse:
			[morphOrList isMorph ifFalse: [self inform: 'Can only load a single morph
into an mvc project via this mechanism.'].
			morphOrList openInWorld]! !

!Morph class methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2002 02:43'!
serviceLoadMorphFromFile
	"Answer a service for loading a .morph file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'load as morph'
		selector: #fromFileName:
		description: 'load as morph'
		buttonLabel: 'load'! !

!Morph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:45'!
services

	^ Array with: self serviceLoadMorphFromFile! !


!Morph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'!
unload

	FileList unregisterFileReader: self ! !


!Morph class methodsFor: 'instance creation' stamp: 'efo 5/3/2002 14:59'!
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 class includesSelector: #descriptionForPartsBin)
		ifTrue:
			[self newStandAlone]
		ifFalse:
			[self new]! !

!Morph class methodsFor: 'instance creation'!
newBounds: bounds

	^ self new privateBounds: bounds! !

!Morph class methodsFor: 'instance creation' stamp: 'jm 5/29/1998 21:28'!
newBounds: bounds color: color

	^ (self new privateBounds: bounds) privateColor: color
! !

!Morph class methodsFor: 'instance creation' stamp: 'sw 8/4/97 12:05'!
newSticky

	^ self new beSticky! !


!Morph class methodsFor: 'misc' stamp: 'sw 8/4/1998 16:51'!
morphsUnknownToTheirOwners
	"Return a list of all morphs (other than HandMorphs) whose owners do not contain them in their submorph lists"
	"Morph morphsUnknownToTheirOwners"
	| problemMorphs itsOwner |
	problemMorphs _ OrderedCollection new.
	self allSubInstances do:
		[:m | (m isHandMorph not and: [((itsOwner _ m owner) ~~ nil and: [(itsOwner submorphs includes: m) not])])
			ifTrue:
				[problemMorphs add: m]].
	^ problemMorphs! !


!Morph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Return true for all classes that can be instantiated from the menu"
	^ true! !

!Morph class methodsFor: 'new-morph participation' stamp: 'sw 6/28/2001 11:33'!
newStandAlone
	"Answer an instance capable of standing by itself as a usable morph."

	^ self basicNew initializeToStandAlone! !

!Morph class methodsFor: 'new-morph participation' stamp: 'sw 8/2/2001 12:01'!
partName: aName categories: aList documentation: aDoc
	"Answer a DescriptionForPartsBin which will represent a launch of a new instance of my class via the #newStandAlone protocol sent to my class. Use the category-list and documentation provided"


	^ DescriptionForPartsBin new
		formalName: aName
		categoryList: aList
		documentation: aDoc
		globalReceiverSymbol: self name
		nativitySelector: #newStandAlone! !


!Morph class methodsFor: 'scripting' stamp: 'sw 7/20/2005 01:20'!
additionsToViewerCategoryColorAndBorder
	"Answer viewer additions for the 'color & border' category"

	^#(
		#'color & border' 
		(
			(slot color 'The color of the object' Color readWrite Player getColor  Player  setColor:)
			(slot opacity '0 means completely transparent, 1 means completely opaque' Number readWrite Player getAlpha Player setAlpha:)
			(slot borderStyle 'The style of the object''s border' BorderStyle readWrite Player getBorderStyle player setBorderStyle:)
			(slot borderColor 'The color of the object''s border' Color readWrite Player getBorderColor Player  setBorderColor:)
			(slot borderWidth 'The width of the object''s border' Number readWrite Player getBorderWidth Player setBorderWidth:)
			(slot roundedCorners 'Whether corners should be rounded' Boolean readWrite Player getRoundedCorners Player setRoundedCorners:)

			(slot gradientFill 'Whether a gradient fill should be used' Boolean readWrite Player getUseGradientFill Player setUseGradientFill:)
			(slot secondColor 'The second color used when gradientFill is in effect' Color readWrite Player getSecondColor Player setSecondColor:)

			(slot radialFill 'Whether the gradient fill, if used, should be radial' Boolean readWrite Player getRadialGradientFill Player setRadialGradientFill:)

			(slot dropShadow 'Whether a drop shadow is shown' Boolean readWrite Player getDropShadow Player setDropShadow:)
			(slot shadowColor 'The color of the drop shadow' Color readWrite Player getShadowColor Player setShadowColor:)
		)
	)

! !

!Morph class methodsFor: 'scripting' stamp: 'sw 8/11/97 13:17'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	^ self new markAsPartsDonor! !

!Morph class methodsFor: 'scripting' stamp: 'bf 9/11/2004 17:18'!
hasAdditionsToViewerCategories
	^ self class selectors
		anySatisfy: [:each | each == #additionsToViewerCategories
				or: [(each beginsWith: 'additionsToViewerCategory')
						and: [(each at: 26 ifAbsent: []) ~= $:]]]! !

!Morph class methodsFor: 'scripting' stamp: 'yo 3/15/2005 14:10'!
helpContributions
	"Answer a list of pairs of the form (<symbol> <help message> ) to contribute to the system help dictionary"
	
"NB: Many of the items here are not needed any more since they're specified as part of command definitions now.  Someone needs to take the time to go through the list and remove items no longer needed.  But who's got that kind of time?"

	^ #(
		(acceptScript:for:
			'submit the contents of the given script editor as the code defining the given selector')
		(actorState
			'return the ActorState object for the receiver, creating it if necessary')
		(addInstanceVariable
			'start the interaction for adding a new variable to the object')
		(addPlayerMenuItemsTo:hand:
			'add player-specific menu items to the given menu, on behalf of the given hand.  At present, these are only commands relating to the turtle')
		(addYesNoToHand
			'Press here to tear off a  TEST/YES/NO unit which you can drop into your script')
		(allScriptEditors
			'answer a list off the extant ScriptEditors for the receiver')
		(amount
			'The amount of displacement')
		(angle	
			'The angular displacement')
		(anonymousScriptEditorFor:
			'answer a new ScriptEditor object to serve as the place for scripting an anonymous (unnamed, unsaved) script for the receiver')
		(append:
			'add an object to this container')
		(prepend:
			'add an object to this container')
		(assignDecrGetter:setter:amt:
			'evaluate the decrement variant of assignment')
		(assignGetter:setter:amt:
			'evaluate the vanilla variant of assignment')
		(assignIncrGetter:setter:amt:
			'evalute the increment version of assignment')
		(assignMultGetter:setter:amt:
			'evaluate the multiplicative version of assignment')
		(assureEventHandlerRepresentsStatus
			'make certain that the event handler associated with my current costume is set up to conform to my current script-status')
		(assureExternalName
			'If I do not currently have an external name assigned, get one now')
		(assureUniClass
			'make certain that I am a member a uniclass (i.e. a unique subclass); if I am not, create one now and become me into an instance of it')
		(availableCostumeNames
			'answer a list of strings representing the names of all costumes currently available for me')
		(availableCostumesForArrows
			'answer a list of actual, instantiated costumes for me, which can be cycled through as the user hits a next-costume or previous-costume button in a viewer')
		(beep:
			'make the specified sound')
		(borderColor
			'The color of the object''s border')
		(borderWidth
			'The width of the object''s border')
		(bottom
			'My bottom edge, measured downward from the top edge of the world')
		(bounce:
			'If object strayed beyond the boundaries of its container, make it reflect back into it, making the specified noise while doing so.')
		(bounce
			'If object strayed beyond the boundaries of its container, make it reflect back into it')
		(chooseTrigger
'When this script should run.
"normal" means "only when called"')
		(clearTurtleTrails
			'Clear all the pen trails in the interior.')
		(clearOwnersPenTrails
			'Clear all the pen trails in my container.')
		(color	
			'The object''s interior color')
		(colorSees
			'Whether a given color in the object is over another given color')
		(colorUnder
			'The color under the center of the object')
		(copy
			'Return a new object that is very much like this one')
		(cursor	
			'The index of the chosen element')
		(deleteCard
			'Delete the current card.')
		(dismiss
			'Click here to dismiss me')
		(doMenuItem:
			'Do a menu item, the same way as if it were chosen manually')
		(doScript:
			'Perform the given script once, on the next tick.')
		(elementNumber
			'My element number as seen by my owner')
		(fire
			'Run any and all button-firing scripts of this object')
		(firstPage
			'Go to first page of book')
		(followPath
				'Retrace the path the object has memorized, if any.')
		(forward:
			'Moves the object forward in the direction it is heading') 
		(goto:
			'Go to the specfied book page')
		(goToNextCardInStack
			'Go to the next card')
		(goToPreviousCardInStack
			'Go to the previous card.')
		(goToRightOf:
			'Align the object just to the right of any specified object.')
		(heading
			'Which direction the object is facing.  0 is straight up') 
		(height	
			'The distance between the top and bottom edges of the object')
		(hide
			'Make the object so that it does not display and cannot handle input')
		(initiatePainting	
			'Initiate painting of a new object in the standard playfield.')
		(initiatePaintingIn:
			'Initiate painting of a new object in the given place.')
		(isOverColor
			'Whether any part of this object is directly over the specified color')
		(isUnderMouse
			'Whether any part of this object is beneath the current mouse-cursor position')
		(lastPage
			'Go to the last page of the book.')
		(left
			'My left edge, measured from the left edge of the World')
		(leftRight
			'The horizontal displacement')
		(liftAllPens
			'Lift the pens on all the objects in my interior.')
		(lowerAllPens
			'Lower the pens on all the objects in my interior.')
		(mouseX
			'The x coordinate of the mouse pointer')
		(mouseY
			'The y coordinate of the mouse pointer')
		(moveToward:
			'Move in the direction of another object.')
		(insertCard
			'Create a new card.')
		(nextPage
			'Go to next page.')
		(numberAtCursor
			'The number held by the object at the chosen element')
		(objectNameInHalo
			'Object''s name -- To change: click here, edit, hit ENTER')
		(obtrudes
			'Whether any part of the object sticks out beyond its container''s borders')
		(offerScriptorMenu
			'The Scriptee.
Press here to get a menu')
		(pauseScript:
			'Make a running script become paused.')
		(penDown
			'Whether the object''s pen is down (true) or up (false)')
		(penColor
			'The color of the object''s pen')
		(penSize	
			'The size of the object''s pen')
		(clearPenTrails
			'Clear all pen trails in the current playfield')
		(playerSeeingColorPhrase
			'The player who "sees" a given color')
		(previousPage
			'Go to previous page')

		(show
			'If object was hidden, make it show itself again.')
		(startScript:
			'Make a script start running.')
		(stopScript:
			'Make a script stop running.')
		(top
			'My top edge, measured downward from the top edge of the world')
		(right
			'My right edge, measured from the left edge of the world')
		(roundUpStrays
			'Bring all out-of-container subparts back into view.')
		(scaleFactor
			'The amount by which the object is scaled')
		(stopScript:
			'make the specified script stop running')
		(tellAllSiblings:
			'send a message to all of my sibling instances')
		(try
			'Run this command once.')
		(tryMe
			'Click here to run this script once; hold button down to run repeatedly')
		(turn:				
			'Change the heading of the object by the specified amount')
		(unhideHiddenObjects
			'Unhide all hidden objects.')
		(upDown
			'The vertical displacement')
		(userScript
			'This is a script defined by you.')
		(userSlot
			'This is a variable defined by you.  Click here to change its type')
		(valueAtCursor
			'The chosen element')
		(wearCostumeOf:
			'Wear the same kind of costume as the other object')
		(width	
			'The distance between the left and right edges of the object')
		(wrap
			'If object has strayed beond the boundaries of its container, make it reappear from the opposite edge.')
		(x
			'The x coordinate, measured from the left of the container')
		(y
			'The y-coordinate, measured upward from the bottom of the container')

		)
! !


!Morph class methodsFor: 'testing' stamp: 'nk 6/12/2004 09:20'!
allSketchMorphClasses
	"Morph allSketchMorphClasses"
	^ Array
		streamContents: [:s | self
				withAllSubclassesDo: [:cls | cls isSketchMorphClass
						ifTrue: [s nextPut: cls ]]]
! !

!Morph class methodsFor: 'testing' stamp: 'yo 3/17/2005 09:07'!
allSketchMorphForms
	"Answer a Set of forms of SketchMorph (sub) instances, except those 
	used as button images, ones being edited, and those with 0 extent."

	| reasonableForms form |
	reasonableForms := Set new.
	Morph allSketchMorphClasses do:
		[:cls | cls allInstances do:
			[:m | (m owner isKindOf: SketchEditorMorph orOf: IconicButton)
				ifFalse:
					[form _ m form.
					((form width > 0) and: [form height > 0]) ifTrue: [reasonableForms add: form]]]].
	^ reasonableForms! !

!Morph class methodsFor: 'testing' stamp: 'nk 6/12/2004 09:17'!
isSketchMorphClass
	^false! !


!Morph class methodsFor: '*eToys-customevents-user events' stamp: 'sw 6/16/2005 01:26'!
additionsToViewerCategoryUserEvents
	"Answer further viewer additions relating to user-defined events; these appear in the 'scripting' category"

	^ Preferences allowEtoyUserCustomEvents
		ifTrue: [ #(scripting (
			(command triggerCustomEvent: 'trigger a user-defined (global) event' CustomEvents)
			(slot triggeringObject 'the object that is triggering an event, either user-defined or pre-defined' Player readOnly Player getTriggeringObject unused unused)))]
		ifFalse: [#(scripting ())]! !


!Morph class methodsFor: '*eToys-new-morph participation' stamp: 'sw 10/24/2001 15:51'!
partName: aName categories: aList documentation: aDoc sampleImageForm: aForm
	"Answer a DescriptionForPartsBin which will represent a launch of a new instance of my class via the #newStandAlone protocol sent to my class. Use the category-list and documentation provided.  This variant allows an overriding image form to be provided, useful in cases where we don't want to launch a sample instance just to get the form"


	| descr |
	descr _ DescriptionForPartsBin new
		formalName: aName
		categoryList: aList
		documentation: aDoc
		globalReceiverSymbol: self name
		nativitySelector: #newStandAlone.
	descr sampleImageForm: aForm.
	^ descr
! !


!Morph class methodsFor: '*eToys-scripting' stamp: 'sw 9/27/2001 17:40'!
additionsToViewerCategoryBasic
	"Answer viewer additions for the 'basic' category"

	^#(
		basic 
		(
			(slot x 'The x coordinate' Number readWrite Player getX Player setX:)
			(slot y  	'The y coordinate' Number readWrite Player 	getY Player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' Number readWrite Player getHeading Player setHeading:)
			(command forward: 'Moves the object forward in the direction it is heading' Number)
			(command turn: 'Change the heading of the object by the specified amount' Number)
			(command beep: 'Make the specified sound' Sound)
		)
	)
! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'sw 4/20/2002 00:47'!
additionsToViewerCategoryDragAndDrop
	"Answer viewer additions for the 'drag & drop' category"

	^#(
		#'drag & drop'
 
		(
			(slot 'drop enabled' 'Whether drop is enabled' Boolean readWrite Player getDropEnabled Player setDropEnabled:)
			(slot 'resist being picked up' 'Whether a simple mouse-drag on this object should allow it to be picked up' Boolean readWrite Player getSticky Player setSticky:)
			(slot 'resist deletion' 'Whether this is resistant to easy removal via the pink X halo handle.' Boolean readWrite Player getResistsRemoval Player setResistsRemoval:)
			(slot 'be locked' 'Whether this object should be blind to all input' Boolean readWrite Player getIsLocked Player setIsLocked:)
		
		))! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'sw 9/17/2002 13:58'!
additionsToViewerCategoryGeometry
	"answer additions to the geometry viewer category"

	^ #(geometry 
		(
			(slot x   'The x coordinate' Number readWrite Player  getX   Player setX:)
			(slot y   'The y coordinate' Number readWrite Player  getY  Player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' Number readWrite Player getHeading  Player setHeading:)

			(slot  scaleFactor 'The factor by which the object is magnified' Number readWrite Player getScaleFactor Player setScaleFactor:)
			(slot  left   'The left edge' Number readWrite Player getLeft  Player  setLeft:)
			(slot  right  'The right edge' Number readWrite Player getRight  Player  setRight:)
			(slot  top  'The top edge' Number readWrite Player getTop  Player  setTop:) 
			(slot  bottom  'The bottom edge' Number readWrite Player getBottom  Player  setBottom:) 
			(slot  length  'The length' Number readWrite Player getLength  Player  setLength:) 
			(slot  width  'The width' Number readWrite Player getWidth  Player  setWidth:)

			(slot headingTheta 'The angle, in degrees, that my heading vector makes with the positive x-axis' Number readWrite Player getHeadingTheta Player setHeadingTheta:)

			(slot distance 'The length of the vector connecting the origin to the object''s position' Number readWrite Player getDistance Player setDistance:)
			(slot theta 'The angle between the positive x-axis and the vector connecting the origin to the object''s position' Number readWrite Player getTheta Player setTheta: )
		)
	)


! !

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

	^#(
		layout 
		(
			(slot clipSubmorphs 'Whether or not to clip my submorphs' Boolean readWrite Player getClipSubmorphs Player setClipSubmorphs:)

		))
! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'sw 7/8/2004 00:20'!
additionsToViewerCategoryMiscellaneous
	"Answer viewer additions for the 'miscellaneous' category"

	^#(
		miscellaneous 
		(
			(command doMenuItem: 'do the menu item' Menu)
			(command show 'make the object visible')
			(command hide 'make the object invisible')
			(command wearCostumeOf: 'wear the costume of...' Player)

			(command fire 'trigger any and all of this object''s button actions')
			(slot copy 'returns a copy of this object' Player readOnly Player getNewClone	 unused unused)
			(slot elementNumber 'my index in my container' Number readWrite Player getIndexInOwner Player setIndexInOwner:)
			(slot holder 'the object''s container' Player readOnly Player getHolder Player setHolder:)
			(command stamp 'add my image to the pen trails')
			(command erase 'remove this object from the screen')
			(command stampAndErase 'add my image to the pen trails and go away')
		)
	)

! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'dgd 8/8/2003 22:17'!
additionsToViewerCategoryMotion
	"Answer viewer additions for the 'motion' category"

	^#(
		motion 
		(
			(slot x 'The x coordinate' Number readWrite Player getX Player setX:)
			(slot y  	'The y coordinate' Number readWrite Player 	getY Player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' Number readWrite Player getHeading Player setHeading:)
			(command forward: 'Moves the object forward in the direction it is heading' Number)
			(slot obtrudes 'whether the object sticks out over its container''s edge' Boolean readOnly Player getObtrudes unused unused) 
			(command turnToward: 'turn toward the given object' Player) 
			(command moveToward: 'move toward the given object' Player) 
			(command turn: 'Change the heading of the object by the specified amount' Number)
			(command bounce: 'bounce off the edge if hit' Sound) 
			(command wrap 'wrap off the edge if appropriate') 
			(command followPath 'follow the yellow brick road') 
			(command goToRightOf: 'place this object to the right of another' Player)
		)
	)

! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'sw 12/9/2001 23:26'!
additionsToViewerCategoryObservation
	"Answer viewer additions for the 'observations' category"

	^#(
		observation
 
		(
			(slot colorUnder 'The color under the center of the object' Color readOnly Player getColorUnder unused  unused )
			(slot brightnessUnder 'The brightness under the center of the object' Number readOnly Player getBrightnessUnder unused unused)
			(slot luminanceUnder 'The luminance under the center of the object' Number readOnly Player getLuminanceUnder unused unused)
			(slot saturationUnder 'The saturation under the center of the object' Number readOnly Player getSaturationUnder unused unused)
		
		))
! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'sw 4/17/2003 12:05'!
additionsToViewerCategoryPenUse
	"Answer viewer additions for the 'pen use' category"

	^#(
		#'pen use' 
		(
			(slot penColor 'the color of ink used by the pen' Color readWrite Player getPenColor Player setPenColor:) 
			(slot penSize 'the width of the pen' Number readWrite Player getPenSize Player setPenSize:) 
			(slot penDown 'whether the pen is currently down' Boolean readWrite Player getPenDown Player setPenDown:)
			(slot trailStyle 'determines whether lines, arrows, arrowheads, or dots are used when I put down a pen trail' TrailStyle readWrite Player getTrailStyle Player setTrailStyle:)
			(slot dotSize 'diameter of dot to use when trailStyle is dots' Number readWrite Player getDotSize Player setDotSize:)
			(command clearOwnersPenTrails 'clear all pen trails in my containing playfield')
		)
	)
! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'sw 2/19/2003 18:04'!
additionsToViewerCategoryScripting
	"Answer viewer additions for the 'scripting' category"

	^#(
		scripting 
		(

			(command startScript: 'start the given script ticking' ScriptName)
			(command pauseScript: 'make the given script be "paused"' ScriptName)
			(command stopScript: 'make the given script be "normal"' ScriptName)

			(command startAll: 'start the given script ticking in the object and all of its siblings.' ScriptName)
			(command pauseAll: 'make the given script be "paused" in the object and all of its siblings' ScriptName)
			(command stopAll: 'make the given script be "normal" in the object and all of its siblings' ScriptName)

			(command doScript: 'run the given script once, on the next tick' ScriptName)
			(command tellSelfAndAllSiblings: 'run the given script in the object and in all of its siblings' ScriptName)
			(command tellAllSiblings: 'send a message to all siblings' ScriptName)))! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'RAA 5/18/2001 12:48'!
additionsToViewerCategoryScripts

	"note: if you change the thing below you also need to change #tileScriptCommands."

	^#(
		scripts 
		(
			(command emptyScript 'an empty script')
		)
	)

! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'nk 10/14/2004 10:59'!
additionsToViewerCategoryTests
	"Answer viewer additions for the 'tests' category."

"Note:  Because of intractable performance problems in continuously evaluating isOverColor in a Viewer, the isOverColor entry is not given a readout"

	^#(
		#tests 
		(
			(slot isOverColor 'whether any part of the object is over the given color' Boolean	readOnly Player seesColor: unused unused)
			(slot isUnderMouse 'whether the object is under the current mouse position' Boolean readOnly	Player getIsUnderMouse unused unused)
			(slot colorSees	'whether the given color sees the given color' Boolean readOnly	Player color:sees:	unused	unused)
			(slot overlaps    'whether I overlap a given object' Boolean readOnly Player overlaps: unused unused)
			(slot overlapsAny    'whether I overlap a given object or one of its siblings or similar objects' Boolean readOnly Player overlapsAny: unused unused)
			(slot touchesA	'whether I overlap any  Sketch that is showing the same picture as a particular prototype.' Boolean readOnly Player touchesA:	unused	unused)
			(slot obtrudes 'whether the object sticks out over its container''s edge' Boolean readOnly Player getObtrudes unused unused)
		)
	)
! !

!Morph class methodsFor: '*eToys-scripting' stamp: 'sw 9/17/2002 10:00'!
vectorAdditions
	"Answer slot/command definitions for the vector experiment"

	^ # (
(slot x   'The x coordinate' Number readWrite Player  getX   Player setX:)
(slot y   'The y coordinate' Number readWrite Player  getY  Player setY:)
(slot heading  'Which direction the object is facing.  0 is straight up' Number readWrite Player getHeading  Player setHeading:)
(slot distance 'The length of the vector connecting the origin to the object''s position' Number readWrite Player getDistance Player setDistance:)
(slot theta 'The angle between the positive x-axis and the vector connecting the origin to the object''s position' Number readWrite Player getTheta Player setTheta: )
(slot headingTheta 'The angle that my heading vector makes with the positive x-axis' Number readWrite Player getHeadingTheta Player setHeadingTheta:)

(command + 'Adds two players together, treating each as a vector from the origin.' Player)
(command - 'Subtracts one player from another, treating each as a vector from the origin.' Player)
(command * 'Multiply a player by a Number, treating the Player as a vector from the origin.' Number)
(command / 'Divide a player by a Number, treating the Player as a vector from the origin.' Number)

(command incr: 'Each Player is a vector from the origin.  Increase one by the amount of the other.' Player)
(command decr: 'Each Player is a vector from the origin.  Decrease one by the amount of the other.' Player)
(command multBy: 'A Player is a vector from the origin.  Multiply its length by the factor.' Number)
(command dividedBy: 'A Player is a vector from the origin.  Divide its length by the factor.' Number)
	)! !


!Morph class methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'nk 10/11/2003 18:17'!
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.

	This version factors each category definition into a separate method.

	Subclasses that have additions can either:
		- override this method, or
		- (preferably) define one or more additionToViewerCategory* methods.

	The advantage of the latter technique is that class extensions may be added
	by external packages without having to re-define additionsToViewerCategories.
	"
	^#()! !

!Morph class methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'nk 8/29/2004 16:35'!
additionsToViewerCategory: aCategoryName
	"Answer a list of viewer specs for items to be added to the given category on behalf of the receiver.  Each class in a morph's superclass chain is given the opportunity to add more things"

	aCategoryName == #vector ifTrue:
		[^ self vectorAdditions].
	^self allAdditionsToViewerCategories at: aCategoryName ifAbsent: [ #() ].! !

!Morph class methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'nk 10/11/2003 18:06'!
additionToViewerCategorySelectors
	"Answer the list of my selectors matching additionsToViewerCategory*"
	^self class organization allMethodSelectors select: [ :ea |
		(ea beginsWith: 'additionsToViewerCategory')
					and: [ (ea at: 26 ifAbsent: []) ~= $: ]]! !

!Morph class methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'nk 9/11/2004 16:56'!
allAdditionsToViewerCategories
	"Answer a Dictionary of (<categoryName> <list of category specs>) that 
	defines the phrases this kind of morph wishes to add to various Viewer categories. 
	 
	This version allows each category definition to be defined in one or more separate methods. 
	 
	Subclasses that have additions can either:
	- override #additionsToViewerCategories, or
	- (preferably) define one or more additionToViewerCategory* methods.

	The advantage of the latter technique is that class extensions may be added by
	external packages without having to re-define additionsToViewerCategories."

	"
	Morph allAdditionsToViewerCategories
	"
	| dict |
	dict := IdentityDictionary new.
	(self class includesSelector: #additionsToViewerCategories)
		ifTrue: [self additionsToViewerCategories
				do: [:group | group
						pairsDo: [:key :list | (dict
								at: key
								ifAbsentPut: [OrderedCollection new])
								addAll: list]]].
	self class selectors
		do: [:aSelector | ((aSelector beginsWith: 'additionsToViewerCategory')
					and: [(aSelector at: 26 ifAbsent: []) ~= $:])
				ifTrue: [(self perform: aSelector)
						pairsDo: [:key :list | (dict
								at: key
								ifAbsentPut: [OrderedCollection new])
								addAll: list]]].
	^ dict! !

!Morph class methodsFor: '*flexibleVocabularies-flexiblevocabularies-scripting' stamp: 'stephaneducasse 2/4/2006 20:33'!
unfilteredCategoriesForViewer
	"Answer a list of symbols representing the categories to offer in the viewer for one of my instances, in order of:
	- masterOrderingOfCategorySymbols first
	- others last in order by translated wording"
	"
	Morph unfilteredCategoriesForViewer
	"

	| aClass additions masterOrder |
	aClass := self.
	additions := OrderedCollection new.
	[aClass == Morph superclass ] whileFalse: [
		additions addAll: (aClass allAdditionsToViewerCategories keys
			asSortedCollection: [ :a :b | a translated < b translated ]).
		aClass := aClass superclass ]. 

	masterOrder := EToyVocabulary masterOrderingOfCategorySymbols.

	^(masterOrder intersection: additions), (additions difference: masterOrder).! !


!Morph class methodsFor: '*MorphicExtras-arrow head size'!
defaultArrowheadSize
	
	^ 5 @ 4! !

!Morph class methodsFor: '*MorphicExtras-arrow head size'!
obtainArrowheadFor: aPrompt defaultValue: defaultPoint
	"Allow the user to supply a point to serve as an arrowhead size.  Answer nil if we fail to get a good point"

	| result  |
	result := FillInTheBlank request: aPrompt initialAnswer: defaultPoint asString.
	result isEmptyOrNil ifTrue: [^ nil].
	^ [(Point readFrom: (ReadStream on: result))]
		on: Error do: [:ex |  nil].! !


!Morph class methodsFor: '*MorphicExtras-new-morph participation' stamp: 'sw 11/27/2001 13:20'!
addPartsDescriptorQuadsTo: aList if: aBlock
	"For each of the standard objects to be put into parts bins based on declarations in this class, add a parts-launching quintuplet to aList, provided that the boolean-valued-block-with-one-argument supplied evaluates to true when provided the DescriptionForPartsBin"

	| info more |
	(self class includesSelector: #descriptionForPartsBin) ifTrue:
		[info _ self descriptionForPartsBin.
		(aBlock value: info) ifTrue:
			[aList add:
				{info globalReceiverSymbol.
				info nativitySelector.
				info formalName.
				info documentation.
				info sampleImageFormOrNil}]].

	(self class includesSelector: #supplementaryPartsDescriptions)
		ifTrue:
			[more _ self supplementaryPartsDescriptions.
			(more isKindOf: DescriptionForPartsBin) ifTrue: [more _ Array with: more].
				"The above being a mild bit of forgiveness, so that in the usual only-one
				case, the user need not return a collection"
			more do:
				[:aPartsDescription |  (aBlock value: aPartsDescription) ifTrue:
					[aList add:
						{aPartsDescription globalReceiverSymbol.
						aPartsDescription nativitySelector.
						aPartsDescription formalName.
						aPartsDescription documentation.
						aPartsDescription sampleImageFormOrNil}]]]! !


!Morph class methodsFor: '*MorphicExtras-parts bin' stamp: 'sw 8/12/2001 14:26'!
supplementaryPartsDescriptions
	"Answer a list of DescriptionForPartsBin objects that characterize objects that this class wishes to contribute to Stationery bins *other* than by the standard default #newStandAlone protocol"

	^ {	DescriptionForPartsBin
			formalName: 'Status'
			categoryList: #(Scripting)
			documentation: 'Buttons to run, stop, or single-step scripts'
			globalReceiverSymbol: #ScriptingSystem
			nativitySelector: #scriptControlButtons.
		DescriptionForPartsBin
			formalName: 'Scripting'
			categoryList: #(Scripting)
			documentation: 'A confined place for drawing and scripting, with its own private stop/step/go buttons.'
			globalReceiverSymbol: #ScriptingSystem
			nativitySelector: #newScriptingSpace.
		DescriptionForPartsBin
			formalName: 'Random'
			categoryList: #(Scripting)
			documentation: 'A tile that will produce a random number in a given range'
			globalReceiverSymbol: #RandomNumberTile
			nativitySelector: #new.
		DescriptionForPartsBin
			formalName: 'ButtonDown?'
			categoryList: #(Scripting)
			documentation: 'Tiles for querying whether the mouse button is down'
			globalReceiverSymbol: #ScriptingSystem
			nativitySelector: #anyButtonPressedTiles.
		DescriptionForPartsBin
			formalName: 'ButtonUp?'
			categoryList: #(Scripting)
			documentation: 'Tiles for querying whether the mouse button is up'
			globalReceiverSymbol: #ScriptingSystem
			nativitySelector: #noButtonPressedTiles.
		DescriptionForPartsBin
			formalName: 'NextPage'
			categoryList: #(Presentation)
			documentation: 'A button which, when clicked, takes the reader to the next page of a book'
			globalReceiverSymbol: #BookMorph
			nativitySelector: #nextPageButton.
		DescriptionForPartsBin
			formalName: 'PreviousPage'
			categoryList: #(Presentation)
			documentation: 'A button which, when clicked, takes the reader to the next page of a book'
			globalReceiverSymbol: #BookMorph
			nativitySelector: #previousPageButton.},

	(Flaps quadsDefiningToolsFlap collect:
		[:aQuad | DescriptionForPartsBin fromQuad: aQuad categoryList: #(Tools)])! !



!Morph class methodsFor: '*flexibleVocabularies-flexibleVocabularies' stamp: 'al 11/28/2005 16:46'!
noteAddedSelector: aSelector meta: isMeta
	"Any change to an additionsToViewer... method can invalidate existing etoy vocabularies.
	The #respondsTo: test is to allow loading the FlexibleVocabularies change set without having to worry about method ordering."
	(isMeta
			and: [(aSelector beginsWith: 'additionsToViewer')
					and: [self respondsTo: #hasAdditionsToViewerCategories]])
		ifTrue: [Vocabulary changeMadeToViewerAdditions].
	super noteCompilationOf: aSelector meta: isMeta! !

!Morph class methodsFor: '*flexibleVocabularies-flexibleVocabularies' stamp: 'NS 4/15/2004 12:40'!
noteCompilationOf: aSelector meta: isMeta
	"This method does nothing and should be removed!!"

	^ super noteCompilationOf: aSelector meta: isMeta! !
RectangleMorph subclass: #MorphExample
	instanceVariableNames: 'phase ball star'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!MorphExample commentStamp: 'kfr 10/26/2003 18:38' prior: 0!
This is a example of how to use a morph. It consists of only two 
methods, initialize and step.

DoIt:
MorphExample new openInWorld.



!


!MorphExample methodsFor: 'initialization' stamp: 'dgd 2/21/2003 19:59'!
initialize
	"initialize the state of the receiver"
	super initialize.
	phase _ 1.
	self extent: 200 @ 200.
	ball _ EllipseMorph new extent: 30 @ 30.
	self
		addMorph: ((star _ StarMorph new extent: 150 @ 150) center: self center)! !


!MorphExample methodsFor: 'stepping and presenter' stamp: 'kfr 10/26/2003 18:33'!
step
	phase _ phase\\8 + 1.
	phase = 1 ifTrue: [^ ball delete].
	phase < 4 ifTrue:[^self].
	phase = 4 ifTrue: [self addMorph: ball].
	ball align: ball center with: (star vertices at: (phase-3*2)).! !
Object subclass: #MorphExtension
	instanceVariableNames: 'locked visible sticky balloonText balloonTextSelector externalName isPartsDonor actorState player eventHandler otherProperties'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!MorphExtension commentStamp: '<historical>' prior: 0!
MorphExtension provides access to extra instance state that is not required in most simple morphs.  This allows simple morphs to remain relatively lightweight while still admitting more complex structures as necessary.  The otherProperties field takes this policy to the extreme of allowing any number of additional named attributes, albeit at a certain cost in speed and space.!


!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:52'!
balloonText
	^ balloonText! !

!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:52'!
balloonTextSelector
	^ balloonTextSelector! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'!
balloonTextSelector: aSymbol 
	"change the receiver's balloonTextSelector"
	balloonTextSelector _ aSymbol! !

!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:55'!
balloonText: newValue
	balloonText _ newValue! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'!
eventHandler
	"answer the receiver's eventHandler"
	^ eventHandler ! !

!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:56'!
eventHandler: newValue
	eventHandler _ newValue! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57'!
externalName: aString 
	"change the receiver's externalName"
	externalName _ aString! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:38'!
locked
	"answer whether the receiver is Locked"
	^ locked! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:48'!
locked: aBoolean 
	"change the receiver's locked property"
	locked _ aBoolean! !

!MorphExtension methodsFor: 'accessing' stamp: 'di 8/14/1998 13:07'!
sticky
	^ sticky! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:47'!
sticky: aBoolean 
	"change the receiver's sticky property"
	sticky _ aBoolean! !

!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:41'!
visible
	"answer whether the receiver is visible"
	^ visible! !

!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:55'!
visible: newValue
	visible _ newValue! !


!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'ar 11/14/2000 17:17'!
layoutFrame
	^self valueOfProperty: #layoutFrame ifAbsent:[nil]! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32'!
layoutFrame: aLayoutFrame 
	aLayoutFrame isNil
		ifTrue: [self removeProperty: #layoutFrame]
		ifFalse: [self setProperty: #layoutFrame toValue: aLayoutFrame]! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'ar 11/14/2000 17:17'!
layoutPolicy
	^self valueOfProperty: #layoutPolicy ifAbsent:[nil]! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32'!
layoutPolicy: aLayoutPolicy 
	aLayoutPolicy isNil
		ifTrue: [self removeProperty: #layoutPolicy]
		ifFalse: [self setProperty: #layoutPolicy toValue: aLayoutPolicy]! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'ar 11/14/2000 17:18'!
layoutProperties
	^self valueOfProperty: #layoutProperties ifAbsent:[nil]! !

!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32'!
layoutProperties: newProperties 
	"Return the current layout properties associated with the receiver"

	newProperties isNil
		ifTrue: [self removeProperty: #layoutProperties]
		ifFalse: [self setProperty: #layoutProperties toValue: newProperties]! !


!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:41'!
assureOtherProperties
	"creates an otherProperties for the receiver if needed"
	otherProperties ifNil: [self initializeOtherProperties].
	^ otherProperties! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:36'!
hasOtherProperties
	"answer whether the receiver has otherProperties"
	^ otherProperties notNil! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:42'!
hasProperty: aSymbol 
	"Answer whether the receiver has the property named aSymbol"
	| property |
	otherProperties ifNil: [^ false].
	property := otherProperties at: aSymbol ifAbsent: [].
	property isNil ifTrue: [^ false].
	property == false ifTrue: [^ false].
	^ true! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:36'!
initializeOtherProperties
	"private - initializes the receiver's otherProperties"
	otherProperties :=  IdentityDictionary new! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:04'!
otherProperties
	"answer the receiver's otherProperties"
	^ otherProperties! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:20'!
privateOtherProperties: anIndentityDictionary 
	"private - change the receiver's otherProperties"
	otherProperties _ anIndentityDictionary ! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:37'!
removeOtherProperties
	"Remove the 'other' properties"
	otherProperties := nil! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:43'!
removeProperty: aSymbol 
	"removes the property named aSymbol if it exists"
	otherProperties ifNil: [^ self].
	otherProperties removeKey: aSymbol ifAbsent: [].
	otherProperties isEmpty ifTrue: [self removeOtherProperties]! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:49'!
setProperty: aSymbol toValue: abObject 
	"change the receiver's property named aSymbol to anObject"
	self assureOtherProperties at: aSymbol put: abObject! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:45'!
sortedPropertyNames
	"answer the receiver's property names in a sorted way"

	| props |
	props := WriteStream on: (Array new: 10).
	locked == true ifTrue: [props nextPut: #locked].
	visible == false ifTrue: [props nextPut: #visible].
	sticky == true ifTrue: [props nextPut: #sticky].
	balloonText isNil ifFalse: [props nextPut: #balloonText].
	balloonTextSelector isNil ifFalse: [props nextPut: #balloonTextSelector].
	externalName isNil ifFalse: [props nextPut: #externalName].
	isPartsDonor == true ifTrue: [props nextPut: #isPartsDonor].
	actorState isNil ifFalse: [props nextPut: #actorState].
	player isNil ifFalse: [props nextPut: #player].
	eventHandler isNil ifFalse: [props nextPut: #eventHandler].
	 otherProperties ifNotNil: [otherProperties associationsDo: [:a | props nextPut: a key]].
	^props contents sort: [:s1 :s2 | s1 <= s2]! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:00'!
valueOfProperty: aSymbol 
"answer the value of the receiver's property named aSymbol"
	^ self
		valueOfProperty: aSymbol
		ifAbsent: []! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:28'!
valueOfProperty: aSymbol ifAbsentPut: aBlock 
	"If the receiver possesses a property of the given name, answer  
	its value. If not, then create a property of the given name, give 
	it the value obtained by evaluating aBlock, then answer that  
	value"
	^self assureOtherProperties at: aSymbol ifAbsentPut: aBlock! !

!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:43'!
valueOfProperty: aSymbol ifAbsent: aBlock 
	"if the receiver possesses a property of the given name, answer  
	its value. If not then evaluate aBlock and answer the result of  
	this block evaluation"
	otherProperties ifNil: [^ aBlock value].
	^ otherProperties at: aSymbol ifAbsent: [^ aBlock value]! !


!MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:20'!
copyWeakly
	"list of names of properties whose values should be weak-copied when veryDeepCopying a morph.  See DeepCopier."

	^ #(formerOwner newPermanentPlayer logger graphModel gestureDictionaryOrName)
	"add yours to this list" 

	"formerOwner should really be nil at the time of the copy, but this will work just fine."! !

!MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:23'!
propertyNamesNotCopied
	"list of names of properties whose values should be deleted when veryDeepCopying a morph.
	See DeepCopier."

	^ #(connectedConstraints connectionHighlights highlightedTargets)
	"add yours to this list" 
! !

!MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:39'!
veryDeepFixupWith: deepCopier 
	"If target and arguments fields were weakly copied, fix them here.
	If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

	super veryDeepFixupWith: deepCopier.
	otherProperties ifNil: [ ^self ].

	"Properties whose values are only copied weakly replace those values if they were copied via another path"
	self copyWeakly do: [ :propertyName |
		otherProperties at: propertyName ifPresent: [ :property |
			otherProperties at: propertyName
				put: (deepCopier references at: property ifAbsent: [ property ])]].
! !

!MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:45'!
veryDeepInner: deepCopier 
	"Copy all of my instance variables.
	Some otherProperties need to be not copied at all, but shared. Their names are given by copyWeakly.
	Some otherProperties should not be copied or shared. Their names are given by propertyNamesNotCopied.
	This is special code for the dictionary. See DeepCopier, and veryDeepFixupWith:."

	| namesOfWeaklyCopiedProperties weaklyCopiedValues |
	super veryDeepInner: deepCopier.
	locked _ locked veryDeepCopyWith: deepCopier.
	visible _ visible veryDeepCopyWith: deepCopier.
	sticky _ sticky veryDeepCopyWith: deepCopier.
	balloonText _ balloonText veryDeepCopyWith: deepCopier.
	balloonTextSelector _ balloonTextSelector veryDeepCopyWith: deepCopier.
	externalName _ externalName veryDeepCopyWith: deepCopier.
	isPartsDonor _ isPartsDonor veryDeepCopyWith: deepCopier.
	actorState _ actorState veryDeepCopyWith: deepCopier.
	player _ player veryDeepCopyWith: deepCopier.		"Do copy the player of this morph"
	eventHandler _ eventHandler veryDeepCopyWith: deepCopier. 	"has its own restrictions"

	otherProperties ifNil: [ ^self ].

	otherProperties := otherProperties copy.
	self propertyNamesNotCopied do: [ :propName | otherProperties removeKey: propName ifAbsent: [] ].

	namesOfWeaklyCopiedProperties _ self copyWeakly.
	weaklyCopiedValues _ namesOfWeaklyCopiedProperties collect: [  :propName | otherProperties removeKey: propName ifAbsent: [] ].

	"Now copy all the others."
	otherProperties := otherProperties veryDeepCopyWith: deepCopier.

	"And replace the weak ones."
	namesOfWeaklyCopiedProperties with: weaklyCopiedValues do: [ :name :value | value ifNotNil: [ otherProperties at: name put: value ]].
! !


!MorphExtension methodsFor: 'initialization' stamp: 'di 8/16/1998 12:02'!
initialize
	"Init all booleans to default values"
	locked _ false.
	visible _ true.
	sticky _ false.
	isPartsDonor _ false.
! !


!MorphExtension methodsFor: 'object fileIn' stamp: 'dgd 2/16/2003 21:06'!
convertProperty: aSymbol toValue: anObject 
	"These special cases move old properties into named fields of the 
	extension"
	aSymbol == #locked
		ifTrue: [^ locked _ anObject].
	aSymbol == #visible
		ifTrue: [^ visible _ anObject].
	aSymbol == #sticky
		ifTrue: [^ sticky _ anObject].
	aSymbol == #balloonText
		ifTrue: [^ balloonText _ anObject].
	aSymbol == #balloonTextSelector
		ifTrue: [^ balloonTextSelector _ anObject].
	aSymbol == #actorState
		ifTrue: [^ actorState _ anObject].
	aSymbol == #player
		ifTrue: [^ player _ anObject].
	aSymbol == #name
		ifTrue: [^ externalName _ anObject].
	"*renamed*"
	aSymbol == #partsDonor
		ifTrue: [^ isPartsDonor _ anObject].
	"*renamed*"
	self assureOtherProperties at: aSymbol put: anObject! !


!MorphExtension methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 12:45'!
comeFullyUpOnReload: smartRefStream
	"inst vars have default booplean values."

	locked ifNil: [locked _ false].
	visible ifNil: [visible _ true].
	sticky ifNil: [sticky _ false].
	isPartsDonor ifNil: [isPartsDonor _ false].
	^ self! !


!MorphExtension methodsFor: 'other' stamp: 'md 2/27/2006 08:39'!
inspectElement
	"Create and schedule an Inspector on the otherProperties and the 
	named properties."
	| key obj |
	key _ (SelectionMenu selections: self sortedPropertyNames)
				startUpWithCaption: 'Inspect which property?'.
	key
		ifNil: [^ self].
	obj _ otherProperties
				at: key
				ifAbsent: ['nOT a vALuE'].
	obj = 'nOT a vALuE'
		ifTrue: [(self perform: key) inspect
			"named properties"]
		ifFalse: [obj inspect]! !

!MorphExtension methodsFor: 'other' stamp: 'md 2/27/2006 08:42'!
isDefault
	"Return true if the receiver is a default and can be omitted"
	locked == true
		ifTrue: [^ false].
	visible == false
		ifTrue: [^ false].
	sticky == true
		ifTrue: [^ false].
	balloonText isNil
		ifFalse: [^ false].
	balloonTextSelector isNil
		ifFalse: [^ false].
	externalName isNil
		ifFalse: [^ false].
	isPartsDonor == true
		ifTrue: [^ false].
	actorState isNil
		ifFalse: [^ false].
	player isNil
		ifFalse: [^ false].
	eventHandler isNil
		ifFalse: [^ false].
	otherProperties ifNotNil: [otherProperties isEmpty ifFalse: [^ false]].
	^ true! !


!MorphExtension methodsFor: 'printing' stamp: 'md 2/27/2006 08:45'!
printOn: aStream 
	"Append to the argument, aStream, a sequence of characters that 
	identifies the receiver." 
	super printOn: aStream.
	aStream nextPutAll: ' ' , self identityHashPrintString.
	locked == true
		ifTrue: [aStream nextPutAll: ' [locked] '].
	visible == false
		ifTrue: [aStream nextPutAll: '[not visible] '].
	sticky == true
		ifTrue: [aStream nextPutAll: ' [sticky] '].
	balloonText
		ifNotNil: [aStream nextPutAll: ' [balloonText] '].
	balloonTextSelector
		ifNotNil: [aStream nextPutAll: ' [balloonTextSelector: ' , balloonTextSelector printString , '] '].
	externalName
		ifNotNil: [aStream nextPutAll: ' [externalName = ' , externalName , ' ] '].
	isPartsDonor == true
		ifTrue: [aStream nextPutAll: ' [isPartsDonor] '].
	player
		ifNotNil: [aStream nextPutAll: ' [player = ' , player printString , '] '].
	eventHandler
		ifNotNil: [aStream nextPutAll: ' [eventHandler = ' , eventHandler printString , '] '].
	(otherProperties isNil or: [otherProperties isEmpty ]) ifTrue: [^ self].
	aStream nextPutAll: ' [other: '.
	self otherProperties
		keysDo: [:aKey | aStream nextPutAll: ' (' , aKey , ' -> ' , (self otherProperties at: aKey) printString , ')'].
	aStream nextPut: $]! !


!MorphExtension methodsFor: 'viewer' stamp: 'di 8/10/1998 14:47'!
externalName
	^ externalName! !


!MorphExtension methodsFor: '*eToys-accessing' stamp: 'dgd 2/16/2003 21:56'!
actorState
	"answer the redeiver's actorState"
	^ actorState ! !

!MorphExtension methodsFor: '*eToys-accessing' stamp: 'dgd 2/16/2003 21:53'!
actorState: anActorState 
"change the receiver's actorState"
	actorState _ anActorState! !

!MorphExtension methodsFor: '*eToys-accessing' stamp: 'dgd 2/16/2003 21:42'!
player
	"answer the receiver's player"
	^ player! !

!MorphExtension methodsFor: '*eToys-accessing' stamp: 'dgd 2/16/2003 21:53'!
player: anObject 
	"change the receiver's player"
	player _ anObject ! !


!MorphExtension methodsFor: '*MorphicExtras-accessing' stamp: 'dgd 2/16/2003 21:37'!
isPartsDonor
	"answer whether the receiver is PartsDonor"
	^ isPartsDonor! !

!MorphExtension methodsFor: '*MorphicExtras-accessing' stamp: 'dgd 2/16/2003 21:40'!
isPartsDonor: aBoolean 
	"change the receiver's isPartDonor property"
	isPartsDonor _ aBoolean! !


!MorphExtension methodsFor: '*MorphicExtras-copying' stamp: 'md 2/27/2006 08:44'!
updateReferencesUsing: aDictionary 
	"Update intra-morph references within a composite morph that  
	has been copied. For example, if a button refers to morph X in  
	the orginal  
	composite then the copy of that button in the new composite  
	should refer to  
	the copy of X in new composite, not the original X. This default  
	implementation updates the contents of any morph-bearing slot."

	| old |
	eventHandler isNil 
		ifFalse: 
			[self eventHandler: self eventHandler copy.
			1 to: self eventHandler class instSize
				do: 
					[:i | 
					old := eventHandler instVarAt: i.
					old isMorph 
						ifTrue: [eventHandler instVarAt: i put: (aDictionary at: old ifAbsent: [old])]]].
	otherProperties ifNotNil: [otherProperties associationsDo:  [:assn | 
					assn value: (aDictionary at: assn value ifAbsent: [assn value])]]! !
Object subclass: #MorphHierarchy
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!MorphHierarchy methodsFor: 'private' stamp: 'dgd 9/26/2004 18:28'!
asMorph
	"Answer the morph version of the receiver"
	| morph |
	morph := MorphHierarchyListMorph
				on: self
				list: #roots
				selected: nil
				changeSelected: #selected:.
	""
	^ morph inAContainer! !


!MorphHierarchy methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:29'!
roots
	"Answer the roots for the Object Hierarchy, that means answer the World"
	^ {MorphListItemWrapper with: World}! !

!MorphHierarchy methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:30'!
selected: aMorphListItemWrapper 
	"Change the selected object"
	| newSelection |
	aMorphListItemWrapper isNil
		ifTrue: [^ self].
	newSelection := aMorphListItemWrapper withoutListWrapper.
	newSelection == World selectedObject
		ifTrue: [newSelection removeHalo]
		ifFalse: [newSelection addHalo].
	self changed: #selected! !

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

MorphHierarchy class
	instanceVariableNames: ''!

!MorphHierarchy class methodsFor: 'opening' stamp: 'dgd 9/25/2004 21:50'!
openOrDelete
	| oldMorph |
	oldMorph := World submorphs
				detect: [:each | each hasProperty: #morphHierarchy]
				ifNone: [| newMorph | 
					newMorph := self new asMorph.
					newMorph bottomLeft: ActiveHand position.
					newMorph openInWorld.
					newMorph isFullOnScreen
						ifFalse: [newMorph goHome].
					^ self].
	""
	oldMorph delete! !
SimpleHierarchicalListMorph subclass: #MorphHierarchyListMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!MorphHierarchyListMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 18:57'!
createContainer
	"Private - Create a container"
	| container |
	container := BorderedMorph new.
	container extent: (World extent * (1 / 4 @ (2 / 3))) rounded.
	container layoutPolicy: TableLayout new.
	container hResizing: #rigid.
	container vResizing: #rigid.
	container
		setColor: Preferences menuColor
		borderWidth: Preferences menuBorderWidth
		borderColor: Preferences menuBorderColor.
	container layoutInset: 0.
	"container useRoundedCorners."
	""
	container setProperty: #morphHierarchy toValue: true.
	container setNameTo: 'Objects Hierarchy' translated.
	""
	^ container! !

!MorphHierarchyListMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 18:27'!
inAContainer
	"Answer the receiver contained in a proper container"
	| container |
	container := self createContainer.
	container addMorphBack: self.
	" 
	nasty hack to force the scroolbar recreation"
	self extent: container extent - container borderWidth.
	""
	^ container! !


!MorphHierarchyListMorph methodsFor: 'initialization' stamp: 'dgd 9/26/2004 18:18'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 
	super
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel.
	""
	self borderWidth: 0.
	self autoDeselect: false.
	self enableDrag: false.
	self enableDrop: true.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
self expandRoots! !


!MorphHierarchyListMorph methodsFor: 'selection' stamp: 'dgd 9/25/2004 21:28'!
setSelectedMorph: aMorph 
	super setSelectedMorph: aMorph.
self owner isNil ifFalse:[self owner delete]! !
ListItemWrapper subclass: #MorphListItemWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!MorphListItemWrapper methodsFor: 'converting' stamp: 'dgd 9/26/2004 18:26'!
asString
	"Answer the string representation of the receiver"
	^ item externalName! !


!MorphListItemWrapper methodsFor: 'accessing' stamp: 'dgd 1/7/2005 20:01'!
contents
	"Answer the receiver's contents"

	| tentative submorphs |
	tentative := item submorphs
				collect: [:each | each renderedMorph].

	submorphs := Preferences noviceMode
				ifTrue: [""
					tentative
						reject: [:each | ""
							each isSystemWindow
								or: [each isDockingBar]
								or: [each isKindOf: HaloMorph]
								or: [each hasProperty: #morphHierarchy]
								or: [each isFlapOrTab]
								or: [each isObjectsTool]]]
				ifFalse: [""
					tentative
						reject: [:each | each isKindOf: HaloMorph]].

	^ submorphs
		collect: [:each | self class with: each]! !

!MorphListItemWrapper methodsFor: 'accessing' stamp: 'dgd 7/28/2005 13:03'!
icon
	"Answer a form to be used as icon"
	^ item iconOrThumbnailOfSize: ((Preferences tinyDisplay ifTrue: [16] ifFalse: [28]))! !
ObjectOut subclass: #MorphObjectOut
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SqueakPage'!

!MorphObjectOut methodsFor: 'as yet unclassified' stamp: 'tk 4/6/1999 10:00'!
doesNotUnderstand: aMessage 
	"Bring in the object, install, then resend aMessage"
	| aMorph myUrl oldFlag response |
	"Transcript show: thisContext sender selector; cr." "useful for debugging"
	oldFlag _ recursionFlag.
	recursionFlag _ true.
	myUrl _ url.	"can't use inst vars after become"
	"fetch the object"
	aMorph _ self xxxFetch.		"watch out for the become!!"
			"Now we ARE a MORPH"
	oldFlag == true ifTrue: [
		response _ (PopUpMenu labels: 'proceed normally\debug' withCRs)
			startUpWithCaption: 'Object being fetched for a second time.
Should not happen, and needs to be fixed later.'.
		response = 2 ifTrue: [self halt]].	"We are already the new object"

	aMorph setProperty: #SqueakPage toValue: 
			(SqueakPageCache pageCache at: myUrl).
	"Can't be a super message, since this is the first message sent to this object"
	^ aMorph perform: aMessage selector withArguments: aMessage arguments
! !

!MorphObjectOut methodsFor: 'as yet unclassified' stamp: 'tk 10/22/1998 15:43'!
fullReleaseCachedState
	"do nothing, especially don't bring in my object!!"! !

!MorphObjectOut methodsFor: 'as yet unclassified' stamp: 'tk 2/24/1999 00:08'!
smallThumbnailForPageSorter

	^ self sqkPage thumbnail! !

!MorphObjectOut methodsFor: 'as yet unclassified' stamp: 'tk 2/24/1999 00:09'!
thumbnailForPageSorter

	^ self sqkPage thumbnail! !
TestCase subclass: #MorphTest
	instanceVariableNames: 'morph world'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Kernel'!
!MorphTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Morph. 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!


!MorphTest methodsFor: 'initialize-release' stamp: 'tak 1/21/2005 11:12'!
getWorld
	^ world
		ifNil: [world := Project newMorphic world]! !

!MorphTest methodsFor: 'initialize-release' stamp: 'tak 1/21/2005 11:12'!
setUp
	morph := Morph new! !

!MorphTest methodsFor: 'initialize-release' stamp: 'tak 1/21/2005 11:12'!
tearDown
	morph delete.
	world
		ifNotNil: [Project deletingProject: world project]! !


!MorphTest methodsFor: 'testing - classification' stamp: 'md 4/16/2003 17:11'!
testIsMorph
	self assert: (morph isMorph).! !


!MorphTest methodsFor: 'testing - etoys' stamp: 'tak 1/21/2005 11:31'!
testOverlapAny
	"self debug: #testOverlapAny"
	| p1 p2 |
	p1 _ Morph new assuredPlayer.
	p2 _ EllipseMorph new assuredPlayer.
	"Same position"
	p1 costume position: 0@0.
	p2 costume position: 0@0.
	self assert: (p1 overlapsAny: p2).
	"Different position"
	p1 costume position: 0@0.
	p2 costume position: 500@0.
	self assert: (p1 overlapsAny: p2) not.! !

!MorphTest methodsFor: 'testing - etoys' stamp: 'tak 1/21/2005 11:56'!
testOverlapAnyDeletedPlayer
	"self debug: #testOverlapAnyDeletedPlayer"
	| me friend sibling |
	me := Morph new assuredPlayer assureUniClass; yourself.
	friend := EllipseMorph new assuredPlayer assureUniClass; yourself.
	sibling := friend getNewClone.
	sibling costume delete.
	self getWorld addMorph: me costume.
	"Same position but deleted"
	me costume position: 0 @ 0.
	friend costume position: 0 @ 0.
	sibling costume position: 0 @ 0.
	self assert: (me overlapsAny: friend) not.
	self assert: (me overlapsAny: sibling) not! !

!MorphTest methodsFor: 'testing - etoys' stamp: 'tak 1/21/2005 11:40'!
testOverlapAnyScriptedPlayer
	"self debug: #testOverlapAnyScriptedPlayer"
	| me friend other sibling |
	me := Morph new assuredPlayer assureUniClass; yourself.
	friend := EllipseMorph new assuredPlayer assureUniClass; yourself.
	sibling := friend getNewClone.
	other := EllipseMorph new assuredPlayer assureUniClass; yourself.
	self getWorld addMorph: me costume;
		 addMorph: friend costume;
		 addMorph: other costume;
		 addMorph: sibling costume.
	"myself"
	self assert: (me overlapsAny: me) not.
	"Same position with sibling"
	me costume position: 0 @ 0.
	friend costume position: 500 @ 0.
	other costume position: 500 @ 0.
	sibling costume position: 0@0.
	self assert: (me overlapsAny: friend).
	"Different position with sibling but same class"
	me costume position: 0 @ 0.
	friend costume position: 500 @ 0.
	sibling costume position: 500@ 0.
	other costume position: 0 @ 0.
	self assert: (me overlapsAny: friend) not! !

!MorphTest methodsFor: 'testing - etoys' stamp: 'tak 1/21/2005 11:32'!
testOverlapAnyUnscriptedPlayer
	"self debug: #testOverlapAnyUnscriptedPlayer"
	| p1 p2 p3 |
	p1 := Morph new assuredPlayer.
	p2 := EllipseMorph new assuredPlayer.
	p3 := EllipseMorph new assuredPlayer.
	self getWorld addMorph: p1 costume;
		 addMorph: p2 costume;
		 addMorph: p3 costume.
	"Same class, same position"
	p1 costume position: 0 @ 0.
	p2 costume position: 500 @ 0.
	p3 costume position: 0 @ 0.
	self
		assert: (p1 overlapsAny: p2).
	"Same class, different position"
	p1 costume position: 0 @ 0.
	p2 costume position: 1000 @ 0.
	p3 costume position: 500 @ 0.
	self assert: (p1 overlapsAny: p2) not.
! !


!MorphTest methodsFor: 'testing - initialization' stamp: 'md 4/16/2003 17:10'!
testOpenInWorld
	self shouldnt: [morph openInWorld] raise: Error.! !


!MorphTest methodsFor: 'testing - into/outOf World' stamp: 'ar 8/4/2003 00:11'!
testIntoWorldCollapseOutOfWorld
	| m1 m2 collapsed |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	"add them to basic morph"
	morph addMorphFront: m1.
	m1 addMorphFront: m2.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	"open the guy"
	morph openInWorld.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	"collapse it"
	collapsed := 	CollapsedMorph new beReplacementFor: morph.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 1).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 1).

	"expand it"
	collapsed collapseOrExpand.
	self assert: (m1 intoWorldCount = 2).
	self assert: (m1 outOfWorldCount = 1).
	self assert: (m2 intoWorldCount = 2).
	self assert: (m2 outOfWorldCount = 1).

	"delete it"
	morph delete.
	self assert: (m1 intoWorldCount = 2).
	self assert: (m1 outOfWorldCount = 2).
	self assert: (m2 intoWorldCount = 2).
	self assert: (m2 outOfWorldCount = 2).
! !

!MorphTest methodsFor: 'testing - into/outOf World' stamp: 'ar 8/4/2003 00:12'!
testIntoWorldDeleteOutOfWorld
	| m1 m2 |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	morph addMorphFront: m1.
	m1 addMorphFront:  m2.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	morph openInWorld.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	morph delete.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 1).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 1).
	! !

!MorphTest methodsFor: 'testing - into/outOf World' stamp: 'ar 8/10/2003 18:30'!
testIntoWorldTransferToNewGuy
	| m1 m2 |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	morph addMorphFront: m1.
	m1 addMorphFront:  m2.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	morph openInWorld.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	morph addMorphFront: m2.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	morph addMorphFront: m1.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	m2 addMorphFront: m1.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	morph delete.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 1).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 1).
! !
SketchMorph subclass: #MorphThumbnail
	instanceVariableNames: 'morphRepresented'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Books'!
!MorphThumbnail commentStamp: '<historical>' prior: 0!
A morph whose appearance is a thumbnail of some other morph.!


!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 11/13/1998 09:53'!
computeThumbnail
	"Assumption on entry:
       The receiver's width represents the maximum width allowable.
       The receiver's height represents the exact height desired."

	| f scaleX scaleY |
	f _ morphRepresented imageForm.
	morphRepresented fullReleaseCachedState.
	scaleY _ self height / f height.  "keep height invariant"
	scaleX _ ((morphRepresented width * scaleY) <= self width)
		ifTrue:
			[scaleY]  "the usual case; same scale factor, to preserve aspect ratio"
		ifFalse:
			[self width / f width].
	self form: (f magnify: f boundingBox by: (scaleX @ scaleY) smoothing: 2).
	self extent: originalForm extent! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 22:08'!
grabOriginal
	self primaryHand attachMorph: morphRepresented! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'ar 10/7/2000 15:38'!
morphRepresented: aMorph

	morphRepresented _ aMorph.
	self computeThumbnail.
! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'md 10/22/2003 15:24'!
revealOriginal
	((owner isKindOf: PasteUpMorph) and: [owner alwaysShowThumbnail]) 
		ifTrue: [^Beeper beep].
	morphRepresented owner isNil 
		ifTrue: [^owner replaceSubmorph: self by: morphRepresented].
	Beeper beep! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 8/10/1998 07:05'!
smaller
	self form: (self form copy: (0@0 extent: self form extent // 2))! !


!MorphThumbnail methodsFor: 'copying' stamp: 'tk 1/8/1999 09:39'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
morphRepresented _ deepCopier references at: morphRepresented 
		ifAbsent: [morphRepresented].! !

!MorphThumbnail methodsFor: 'copying' stamp: 'tk 1/8/1999 09:39'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
morphRepresented _ morphRepresented.		"Weakly copied"! !


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

!MorphThumbnail methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:51'!
initialize
	"initialize the state of the receiver"
	| f |
	super initialize.
	""

	f _ Form extent: 60 @ 80 depth: Display depth.
	f fill: f boundingBox fillColor: color.
	self form: f! !


!MorphThumbnail methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:53'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'reveal original morph' translated action: #revealOriginal.
	aCustomMenu add: 'grab original morph' translated action: #grabOriginal.
! !


!MorphThumbnail methodsFor: 'naming' stamp: 'bf 3/31/1999 12:24'!
innocuousName
	^ morphRepresented isNil
		ifTrue: [super innocuousName]
		ifFalse: [morphRepresented innocuousName]! !


!MorphThumbnail methodsFor: 'parts bin' stamp: 'dgd 2/16/2003 21:37'!
isPartsDonor
	"answer whether the receiver is PartsDonor"
	^ self partRepresented isPartsDonor! !

!MorphThumbnail methodsFor: 'parts bin' stamp: 'dgd 2/16/2003 21:40'!
isPartsDonor: aBoolean
	"change the receiver's isPartDonor property"
	self partRepresented isPartsDonor: aBoolean! !

!MorphThumbnail methodsFor: 'parts bin' stamp: 'ar 10/6/2000 22:46'!
partRepresented
	^self morphRepresented! !


!MorphThumbnail methodsFor: 'thumbnail' stamp: 'jm 11/17/97 17:30'!
morphRepresented

	^ morphRepresented
! !

!MorphThumbnail methodsFor: 'thumbnail' stamp: 'bf 3/31/1999 07:54'!
representativeNoTallerThan: maxHeight norWiderThan: maxWidth thumbnailHeight: thumbnailHeight

	"Return a morph representing the receiver but which is no taller than aHeight.  If the receiver is already small enough, just return it, else return a MorphThumbnail companioned to the receiver, enforcing the maxWidth"

	(self height <= maxHeight and: [self width <= maxWidth]) ifTrue: [^ self].

	^ MorphThumbnail new
		extent: maxWidth @ (thumbnailHeight min: self height);
		morphRepresented: morphRepresented! !
ListItemWrapper subclass: #MorphWithSubmorphsWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!
!MorphWithSubmorphsWrapper commentStamp: 'ls 3/1/2004 17:32' prior: 0!
Display a morph in a SimpleHierarchicalListMorph, and arrange to recursively display the morph's submorphs.  The "item" that is wrapped is the morph to display.!


!MorphWithSubmorphsWrapper methodsFor: 'hierarchy' stamp: 'ls 3/1/2004 17:34'!
contents
	^item submorphs collect: [ :m |
		self class with: m ]! !
Controller subclass: #MorphWorldController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-ST80'!
!MorphWorldController commentStamp: '<historical>' prior: 0!
I am a controller for SceneViews. I support gestures for scrolling, click-selection, and area selection of scene glyphs. (See the class comment in GestureController for more details about gestures.) I also support construction operations such as inserting new glyphs and merging glyphs to make them share a common point.

The mapping of gestures to actions is as follows (see GestureController comment for more about gestures):

  Click:
	click on glyph				select glyph
	shift-click on glyph			toggle selection of that glyph
	click on background			clear selection
  Double click:
	double-click on glyph			inspect glyph
	double-click on background		select all
  Hold/Drag/Sweep:
	hold (no movement)			yellow-button menu
	drag (up/left movement)		scrolling hand
	sweep (down/right movement)	select glyphs in region
	shift-sweep					toggle selection of glyphs in region
!


!MorphWorldController methodsFor: 'basic control sequence' stamp: 'di 11/26/1999 10:00'!
controlInitialize
	"This window is becoming active."

	true ifTrue: [model becomeTheActiveWorldWith: nil].

	model canvas ifNil: [  "i.e., only on first entry"
		"In case of, eg, inspect during balloon help..."
		model submorphsDo: [:m |  "delete any existing balloons"
			(m isKindOf: BalloonMorph) ifTrue: [m delete]].

		model handsDo: [:h | h initForEvents].
		view displayView].  "initializes the WorldMorph's canvas"
! !

!MorphWorldController methodsFor: 'basic control sequence' stamp: 'di 11/16/2001 22:43'!
controlLoop 
	"Overridden to keep control active when the hand goes out of the view"

	| db |
	[self viewHasCursor  "working in the window"
		or: [Sensor noButtonPressed  "wandering with no button pressed"
		or: [model primaryHand submorphs size > 0  "dragging something outside"]]]
		whileTrue:   "... in other words anything but clicking outside"
			[self controlActivity.

			"Check for reframing since we hold control here"
			db _ view superView displayBox.
			view superView controller checkForReframe.
			db = view superView displayBox ifFalse:
				[self controlInitialize "reframe world if bounds changed"]].
! !

!MorphWorldController methodsFor: 'basic control sequence' stamp: 'di 11/16/2001 13:58'!
controlTerminate 
	"This window is becoming inactive; restore the normal cursor."

	Cursor normal show.
	ActiveWorld _ ActiveHand _ ActiveEvent _ nil! !


!MorphWorldController methodsFor: 'control defaults' stamp: 'jm 2/20/98 13:37'!
controlActivity
	"Do one step of the Morphic interaction loop. Called repeatedly while window is active."

	model doOneCycle.
! !

!MorphWorldController methodsFor: 'control defaults' stamp: 'jm 6/17/97 10:29'!
isControlActive

	^ sensor redButtonPressed or: [self viewHasCursor]! !
View subclass: #MorphWorldView
	instanceVariableNames: ''
	classVariableNames: 'FullColorWhenInactive'
	poolDictionaries: ''
	category: 'MorphicExtras-ST80'!
!MorphWorldView commentStamp: '<historical>' prior: 0!
I am a view used to display a Scene. I may be scrolled by adjusting my offset. My default controller is SceneController.

SceneViews encapsulate the notion of a changing foreground and a fixed background during interactive updates. During an interaction (such as dragging), some of the glyphs will not change location or appearance. These are part of the "background". All glyphs that may change (the "foreground" glyphs) are painted against this unchanging backdrop during the interaction.

Instance Variables:
	offset				the current offset of this view (used for scrolling)
	enclosingRect 		a rectangle large enough to contain all the objects in the scene, plus a small border (this is a cache that must be recomputed when glyphs are moved, added, or removed from the scene)
	backgroundForm		a <Form> containing the fixed background
	visibleForeground		the glyphs that are changing but not selected during an interaction
	selectedForeground	the selected glyphs that are changing during an interaction!


!MorphWorldView methodsFor: 'as yet unclassified' stamp: 'md 2/24/2006 21:24'!
updateSubWindowExtent
	"If this MorphWorldView represents a single Morphic SystemWindow, then update that window to match the size of the WorldView."

	| numMorphs subWindow |
	numMorphs := model submorphs size.
	"(Allow for the existence of an extra NewHandleMorph (for resizing).)"
	(numMorphs = 0 or: [numMorphs > 2]) ifTrue: [^self].
	subWindow := model submorphs detect: [:ea | ea respondsTo: #label]
				ifNone: [^self].
	superView label = subWindow label ifFalse: [^self].
	subWindow position: model position + (0 @ -16).	"adjust for WiW changes"
	subWindow extent: model extent - (0 @ -16).
	subWindow isActive ifFalse: [subWindow activate]! !


!MorphWorldView methodsFor: 'controller access'!
defaultControllerClass

	^ MorphWorldController! !


!MorphWorldView methodsFor: 'deEmphasizing' stamp: 'RAA 5/24/2000 10:34'!
deEmphasizeView 
	"This window is becoming inactive."

	Cursor normal show.    "restore the normal cursor"
	model deEmphasizeViewMVC: self topView cacheBitsAsTwoTone.
! !


!MorphWorldView methodsFor: 'displaying' stamp: 'dew 11/8/1999 02:01'!
displayView
	"This method is called by the system when the top view is framed or moved."
	| topView |
	model viewBox: self insetDisplayBox.
	self updateSubWindowExtent.
	topView _ self topView.
	(topView == ScheduledControllers scheduledControllers first view
		or: [topView cacheBitsAsTwoTone not])
		ifTrue: [model displayWorldSafely]
		ifFalse: [model displayWorldAsTwoTone].  "just restoring the screen"! !


!MorphWorldView methodsFor: 'updating' stamp: 'sw 9/26/97 20:56'!
update: symbol

	^ symbol == #newColor
		ifTrue: [self topView backgroundColor: model color dominantColor; uncacheBits; display]
		ifFalse: [super update: symbol].
! !


!MorphWorldView methodsFor: 'private' stamp: 'dew 11/8/1999 02:00'!
computeInsetDisplayBox
	"This overrides the same method in View.  (It avoids using displayTransform: because it can return inaccurate results, causing a MorphWorldView's inset display box to creep inward when resized.)"

	^superView insetDisplayBox insetBy: borderWidth! !

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

MorphWorldView class
	instanceVariableNames: ''!

!MorphWorldView class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:52'!
convertToMVCWiWPasteUpMorph
	"
MorphWorldView convertToMVCWiWPasteUpMorph
"

	| current w newModel topView |
	Smalltalk isMorphic ifTrue: [^self inform: 'do this in MVC'].
	current := self allInstances 
				select: [:each | each model class == PasteUpMorph].
	current do: 
			[:oldWorldView | 
			w := MVCWiWPasteUpMorph newWorldForProject: nil.
			w
				color: oldWorldView model color;
				addAllMorphs: oldWorldView model submorphs.
			newModel := CautiousModel new initialExtent: 300 @ 300.
			topView := self fullColorWhenInactive 
						ifTrue: [ColorSystemView new]
						ifFalse: [StandardSystemView new].
			topView
				model: newModel;
				label: oldWorldView topView label;
				borderWidth: 1;
				addSubView: (self new model: w);
				backgroundColor: w color.
			topView controller openNoTerminate.
			topView reframeTo: (oldWorldView topView expandedFrame 
						expandBy: (0 @ 0 extent: 0 @ topView labelHeight)).
			oldWorldView topView controller closeAndUnscheduleNoTerminate].
	ScheduledControllers restore.
	Processor terminateActive! !

!MorphWorldView class methodsFor: 'instance creation'!
fullColorWhenInactive

	FullColorWhenInactive ifNil: [FullColorWhenInactive _ true].
	^ FullColorWhenInactive
! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'di 2/26/98 09:17'!
fullColorWhenInactive: fullColor
	"MorphWorldView fullColorWhenInactive: true"
	"If FullColorWhenInactive is true then WorldMorphViews will created inside StandardSystemViews that cache their contents in full-color when the window is inactive. If it is false, only a half-tone gray approximation of the colors will be cached to save space."

	FullColorWhenInactive _ fullColor.

	"Retroactively convert all extant windows"
	((fullColor ifTrue: [StandardSystemView] ifFalse: [ColorSystemView])
		allInstances select:
			[:v | v subViews notNil and: [v subViews isEmpty not and: [v firstSubView isKindOf: MorphWorldView]]])
		do: [:v | v uncacheBits.
			v controller toggleTwoTone]! !

!MorphWorldView class methodsFor: 'instance creation'!
openOn: aMorphWorld
	"Open a view on the given WorldMorph."

	self openOn: aMorphWorld label: 'A Morphic World'.! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'sw 10/2/97 23:17'!
openOn: aWorldMorph label: aString
	"Open a view with the given label on the given WorldMorph."
	^ self openOn: aWorldMorph label: aString model: (CautiousModel new initialExtent: aWorldMorph initialExtent)! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'sw 9/21/1998 17:54'!
openOn: aWorldMorph label: aString cautionOnClose: aBoolean
	"Open a view with the given label on the given WorldMorph."
	| aModel |
	aModel _ aBoolean
		ifTrue:		[CautiousModel new]
		ifFalse:		[WorldViewModel new].
	^ self openOn: aWorldMorph label: aString model: (aModel initialExtent: aWorldMorph initialExtent)! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'jm 1/31/98 20:24'!
openOn: aWorldMorph label: aString extent: aPoint
	"Open a view with the given label and extent on the given WorldMorph."

	^ self openOn: aWorldMorph
		label: aString
		model: (CautiousModel new initialExtent: aPoint)
! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 22:37'!
openOn: aWorldMorph label: aString model: aModel 
	"Open a view with the given label on the given WorldMorph."

	| topView |
	topView := self fullColorWhenInactive 
				ifTrue: [topView := ColorSystemView new]
				ifFalse: [topView := StandardSystemView new].
	topView
		model: aModel;
		label: aString;
		borderWidth: 1;
		addSubView: (self new model: aWorldMorph);
		backgroundColor: aWorldMorph color.
	"minimumSize: aWorldMorph extent + (2@2); "	"add border width"
	topView controller open! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'di 11/26/1999 11:46'!
openWorld

	| w |
	(w _ MVCWiWPasteUpMorph newWorldForProject: nil).
	w bounds: (0@0 extent: 400@300).
	self openOn: w
		label: 'A Morphic World'
		extent: w fullBounds extent + 2.
! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'sma 6/12/2000 14:18'!
openWorldWith: aMorph labelled: labelString

	| w |
	(w _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: aMorph.
	w extent: aMorph fullBounds extent.
	w startSteppingSubmorphsOf: aMorph.
	self openOn: w
		label: labelString
		extent: w fullBounds extent + 2.
! !
MessageSend subclass: #MorphicAlarm
	instanceVariableNames: 'scheduledTime numArgs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MorphicAlarm methodsFor: 'accessing' stamp: 'ar 9/11/2000 16:44'!
scheduledTime
	"Return the time (in milliseconds) that the receiver is scheduled to be executed"
	^scheduledTime! !

!MorphicAlarm methodsFor: 'accessing' stamp: 'ar 9/11/2000 16:45'!
scheduledTime: msecs
	"Set the time (in milliseconds) that the receiver is scheduled to be executed"
	scheduledTime _ msecs! !


!MorphicAlarm methodsFor: 'evaluating' stamp: 'ar 10/22/2000 17:36'!
value: anArgument
	| nArgs |
	numArgs ifNil:[numArgs _ selector numArgs].
	nArgs _ arguments ifNil:[0] ifNotNil:[arguments size].
	nArgs = numArgs ifTrue:[
		"Ignore extra argument"
		^self value].
	^arguments isNil
		ifTrue: [receiver perform: selector with: anArgument]
		ifFalse: [receiver perform: selector withArguments: (arguments copyWith: anArgument)]! !

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

MorphicAlarm class
	instanceVariableNames: ''!

!MorphicAlarm class methodsFor: 'instance creation' stamp: 'ar 9/11/2000 16:44'!
scheduledAt: scheduledTime receiver: aTarget selector: aSelector arguments: argArray
	^(self receiver: aTarget selector: aSelector arguments: argArray)
		scheduledTime: scheduledTime.! !
Object subclass: #MorphicEvent
	instanceVariableNames: 'timeStamp source'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!
!MorphicEvent commentStamp: '<historical>' prior: 0!
This class represents the base for all events.

Instance variables:
	stamp	<Integer>	The millisecond clock time stamp (based on Time millisecondClock)
	source	<Hand | nil>	If non-nil the hand that generated the event.!


!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 21:28'!
cursorPoint
	"Backward compatibility. Use #position instead"
	^ self position! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:48'!
hand
	"Return the source that generated the event"
	^source! !

!MorphicEvent methodsFor: 'accessing' stamp: 'wiz 12/8/2004 23:13'!
position
	"Since cursorPoint is defined and refers to position it should be defined
	here as well"
	^ self subclassResponsibility! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:29'!
timeStamp
	"Return the millisecond clock value at which the event was generated"
	^timeStamp ifNil:[timeStamp _ Time millisecondClockValue]! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:34'!
type
	"Return a symbol indicating the type this event."
	^self subclassResponsibility! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 01:19'!
wasHandled
	"Return true if this event was handled. May be ignored for some types of events."
	^false! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 01:20'!
wasHandled: aBool
	"Determine if this event was handled. May be ignored for some types of events."! !


!MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'!
= anEvent
	anEvent isMorphicEvent ifFalse:[^false].
	^self type = anEvent type! !

!MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'!
hash
	^self type hash! !


!MorphicEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:12'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	^anObject handleUnknownEvent: self! !


!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
! !

!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"! !

!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/24/2000 16:21'!
type: eventType readFrom: aStream
	"Read a MorphicEvent from the given stream."
! !


!MorphicEvent methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 16:05'!
convertOctober2000: varDict using: smartRefStrm
	"ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
	"These are going away #('type' 'cursorPoint' 'buttons' 'keyValue' 'sourceHand').  Possibly store their info in another variable?"
	| type cursorPoint buttons keyValue sourceHand |
	type _ varDict at: 'type'.
	cursorPoint _ varDict at: 'cursorPoint'.
	buttons _ varDict at: 'buttons'.
	keyValue _ varDict at: 'keyValue'.
	sourceHand _ varDict at: 'sourceHand'.
	type == #mouseMove ifTrue:[
		^MouseMoveEvent new
			setType: #mouseMove 
			startPoint: cursorPoint
			endPoint: cursorPoint
			trail: #() 
			buttons: buttons 
			hand: sourceHand 
			stamp: nil].
	(type == #mouseDown) | (type == #mouseUp) ifTrue:[
			^MouseButtonEvent new
				setType: type
				position: cursorPoint
				which: 0
				buttons: buttons
				hand: sourceHand
				stamp: nil].
	(type == #keystroke) | (type == #keyDown) | (type == #keyUp) ifTrue:[
		^KeyboardEvent new
			setType: type
			buttons: buttons
			position: cursorPoint
			keyValue: keyValue
			hand: sourceHand
			stamp: nil].
	"All others will be handled there"
	^MorphicUnknownEvent new! !


!MorphicEvent methodsFor: 'objects from disk' stamp: 'RAA 12/21/2000 11:35'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	| answer |

	"ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
	varDict at: 'cursorPoint' ifPresent: [ :x | 
		answer _ self convertOctober2000: varDict using: smartRefStrm.
		varDict removeKey: 'cursorPoint'.	"avoid doing this again"
		^answer
	].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.


! !


!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/22/2000 10:36'!
isDraggingEvent
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:17'!
isDropEvent
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'!
isKeyboard
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 10/10/2000 21:27'!
isKeystroke
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'!
isMorphicEvent
	^true! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'!
isMouse
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/14/2000 18:21'!
isMouseOver
	^self type == #mouseOver! !


!MorphicEvent methodsFor: 'transforming' stamp: 'ar 9/13/2000 15:47'!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."
! !


!MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 21:26'!
setHand: aHand
	source _ aHand! !

!MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 20:53'!
setTimeStamp: stamp
	timeStamp _ stamp.! !

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

MorphicEvent class
	instanceVariableNames: ''!

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/26/2000 00:44'!
convertObsolete: anEvent
	"ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
	| type cursorPoint buttons keyValue sourceHand |
	type _ anEvent type.
	cursorPoint _ anEvent cursorPoint.
	buttons _ anEvent buttons.
	keyValue _ anEvent keyValue.
	sourceHand _ anEvent hand.
	type == #mouseMove ifTrue:[
		^MouseMoveEvent new
			setType: #mouseMove 
			startPoint: cursorPoint
			endPoint: cursorPoint
			trail: #() 
			buttons: buttons 
			hand: sourceHand 
			stamp: nil].
	(type == #mouseDown) | (type == #mouseUp) ifTrue:[
			^MouseButtonEvent new
				setType: type
				position: cursorPoint
				which: 0
				buttons: buttons
				hand: sourceHand
				stamp: nil].
	(type == #keystroke) | (type == #keyDown) | (type == #keyUp) ifTrue:[
		^KeyboardEvent new
			setType: type
			buttons: buttons
			position: cursorPoint
			keyValue: keyValue
			hand: sourceHand
			stamp: nil].
	^nil! !

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/26/2000 00:49'!
readFrom: aStream
	"Read a MorphicEvent from the given stream."
	| typeString c |
	typeString _ String streamContents:
		[:s |   [(c _ aStream next) isLetter] whileTrue: [s nextPut: c]].
	typeString = 'mouseMove' ifTrue:[^MouseMoveEvent type: #mouseMove readFrom: aStream].
	typeString = 'mouseDown' ifTrue:[^MouseButtonEvent type: #mouseDown readFrom: aStream].
	typeString = 'mouseUp' ifTrue:[^MouseButtonEvent type: #mouseUp readFrom: aStream].

	typeString = 'keystroke' ifTrue:[^KeyboardEvent type: #keystroke readFrom: aStream].
	typeString = 'keyDown' ifTrue:[^KeyboardEvent type: #keyDown readFrom: aStream].
	typeString = 'keyUp' ifTrue:[^KeyboardEvent type: #keyUp readFrom: aStream].

	typeString = 'mouseOver' ifTrue:[^MouseEvent type: #mouseOver readFrom: aStream].
	typeString = 'mouseEnter' ifTrue:[^MouseEvent type: #mouseEnter readFrom: aStream].
	typeString = 'mouseLeave' ifTrue:[^MouseEvent type: #mouseLeave readFrom: aStream].

	typeString = 'unknown' ifTrue:[^MorphicUnknownEvent type: #unknown readFrom: aStream].

	^nil
! !

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/25/2000 21:58'!
readFromObsolete: aStream
	"Read one of those old and now obsolete events from the stream"
	| type x y buttons keyValue typeString c |
	typeString _ String streamContents:
		[:s |   [(c _ aStream next) isLetter] whileTrue: [s nextPut: c]].
	typeString = 'mouseMove'
		ifTrue: [type _ #mouseMove  "fast treatment of common case"]
		ifFalse: [type _ typeString asSymbol].

	x _ Integer readFrom: aStream.
	aStream skip: 1.
	y _ Integer readFrom: aStream.
	aStream skip: 1.

	buttons _ Integer readFrom: aStream.
	aStream skip: 1.

	keyValue _ Integer readFrom: aStream.

	typeString = 'mouseMove' ifTrue:[
		^MouseMoveEvent new
			setType: #mouseMove 
			startPoint: x@y 
			endPoint: x@y 
			trail: #() 
			buttons: buttons 
			hand: nil 
			stamp: nil].
	(typeString = 'mouseDown') | (typeString = 'mouseUp') ifTrue:[
			^MouseButtonEvent new
				setType: type
				position: x@y
				which: 0
				buttons: buttons
				hand: nil
				stamp: nil].
	(typeString = 'keystroke') | (typeString = 'keyDown') | (typeString = 'keyUp') ifTrue:[
		^KeyboardEvent new
			setType: type
			buttons: buttons
			position: x@y
			keyValue: keyValue
			hand: nil
			stamp: nil].

	^nil! !

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/24/2000 16:32'!
type: eventType readFrom: aStream
	^self new type: eventType readFrom: aStream! !


!MorphicEvent class methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ar 10/25/2000 23:32'!
fromStringArray: array
	"decode an event that was encoded with encodedAsStringArray"
	| type |
	type := (array at: 1).
	(type = 'mouseMove')
		ifTrue:[^MouseMoveEvent new decodeFromStringArray: array].
	(type = 'mouseDown' or:[type = 'mouseUp']) 
		ifTrue:[^MouseButtonEvent new decodeFromStringArray: array].
	(type = 'keystroke' or:[type = 'keyDown' or:[type = 'keyUp']]) 
		ifTrue:[^KeyboardEvent new decodeFromStringArray: array].
	^nil! !
Object subclass: #MorphicEventDecoder
	instanceVariableNames: 'connection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!MorphicEventDecoder commentStamp: '<historical>' prior: 0!
decode messages sent via a MorphicEventEncoder.!


!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'RAA 11/8/2000 15:15'!
apply: aStringArray to: aHand
	"decode aStringArray, and apply the encoded command to aHand"

	aStringArray first = 'event' ifTrue: [
		^self applyEventMessage: aStringArray to: aHand
	].
	aStringArray first = 'viewExtent' ifTrue: [
		^self applyViewExtentMessage: aStringArray to: aHand
	].
	aStringArray first = 'beginBuffering' ifTrue: [
		^aHand convertRemoteClientToBuffered
	].

	^self error: 'unknown message type: ', aStringArray first! !

!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'ar 10/26/2000 01:55'!
applyEventMessage: aStringArray to: aHand
	| event |
	event := MorphicEvent fromStringArray: (aStringArray copyFrom: 2 to: aStringArray size).
	event ifNotNil:[aHand queueEvent: event].! !

!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'ls 3/25/2000 16:56'!
applyMessagesTo: aHand
	| msg |
	"apply all queued events to the given hand"
	"currently, there is no way to extract the rawmessages.  This is simply because I didn't feel like implementing individual classes for each message -lex"
	[ msg := connection nextOrNil.  msg notNil ] whileTrue: [
		self apply: msg to: aHand ].
! !

!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'ls 4/11/2000 19:00'!
applyViewExtentMessage: aStringArray to: aHand
	| newViewExtent |
	newViewExtent := CanvasDecoder decodePoint: aStringArray second.

	aHand setViewExtent: newViewExtent! !

!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'ls 3/24/2000 22:54'!
processIO
	connection processIO! !


!MorphicEventDecoder methodsFor: 'initialization' stamp: 'ls 3/24/2000 21:42'!
connection: aConnection
	connection := aConnection! !

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

MorphicEventDecoder class
	instanceVariableNames: ''!

!MorphicEventDecoder class methodsFor: 'instance creation' stamp: 'ls 3/24/2000 21:43'!
on: aStringArray
	^self basicNew connection: aStringArray! !
Object subclass: #MorphicEventDispatcher
	instanceVariableNames: 'lastType lastDispatch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!
!MorphicEventDispatcher commentStamp: '<historical>' prior: 0!
The class represents a strategy for dispatching events to some immediate child of a morph. It is used by morphs to delegate the somewhat complex action of dispatching events accurately. !


!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 01:20'!
dispatchDefault: anEvent with: aMorph
	"Dispatch the given event. The event will be passed to the front-most visible submorph that contains the position wrt. to the event."
	| localEvt index child morphs inside |
	"See if we're fully outside aMorphs bounds"
	(aMorph fullBounds containsPoint: anEvent position) ifFalse:[^#rejected]. "outside"
	"Traverse children"
	index _ 1.
	morphs _ aMorph submorphs.
	inside _ false.
	[index <= morphs size] whileTrue:[
		child _ morphs at: index.
		localEvt _ anEvent transformedBy: (child transformedFrom: aMorph).
		(child processEvent: localEvt using: self) == #rejected ifFalse:[
			"Not rejected. The event was in some submorph of the receiver"
			inside _ true.
			localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt].
			index _ morphs size. "break"
		].
		index _ index + 1.
	].

	"Check for being inside the receiver"
	inside ifFalse:[inside _ aMorph containsPoint: anEvent position event: anEvent].
	inside ifTrue:[^aMorph handleEvent: anEvent].
	^#rejected
! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:13'!
dispatchDropEvent: anEvent with: aMorph
	"Find the appropriate receiver for the event and let it handle it. The dispatch is similar to the default dispatch with one difference: Morphs are given the chance to reject an entire drop operation. If the operation is rejected, no drop will be executed."
	| inside index morphs child localEvt |
	"Try to get out quickly"
	(aMorph fullBounds containsPoint: anEvent cursorPoint)
		ifFalse:[^#rejected].
	"Give aMorph a chance to repel the dropping morph"
	aMorph rejectDropEvent: anEvent.
	anEvent wasHandled ifTrue:[^self].

	"Go looking if any of our submorphs wants it"
	index _ 1.
	inside _ false.
	morphs _ aMorph submorphs.
	[index <= morphs size] whileTrue:[
		child _ morphs at: index.
		localEvt _ anEvent transformedBy: (child transformedFrom: aMorph).
		(child processEvent: localEvt using: self) == #rejected ifFalse:[
			localEvt wasHandled ifTrue:[^anEvent wasHandled: true]. "done"
			inside _ true.
			index _ morphs size]. "break"
		index _ index + 1.
	].

	inside ifFalse:[inside _ aMorph containsPoint: anEvent cursorPoint event: anEvent].
	inside ifTrue:[^aMorph handleEvent: anEvent].
	^#rejected! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:43'!
dispatchEvent: anEvent with: aMorph
	"Dispatch the given event for a morph that has chosen the receiver to dispatch its events. The method implements a shortcut for repeated dispatches of events using the same dispatcher."
	anEvent type == lastType ifTrue:[^self perform: lastDispatch with: anEvent with: aMorph].
	"Otherwise classify"
	lastType _ anEvent type.
	anEvent isMouse ifTrue:[
		anEvent isMouseDown ifTrue:[
			lastDispatch _ #dispatchMouseDown:with:.
			^self dispatchMouseDown: anEvent with: aMorph]].
	anEvent type == #dropEvent ifTrue:[
		lastDispatch _ #dispatchDropEvent:with:.
		^self dispatchDropEvent: anEvent with: aMorph].
	lastDispatch _ #dispatchDefault:with:.
	^self dispatchDefault: anEvent with: aMorph! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:14'!
dispatchMouseDown: anEvent with: aMorph
	"Find the appropriate receiver for the event and let it handle it. Default rules:
	* The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event.
	* When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is.
	* When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed.
	* If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event.
"
	| globalPt localEvt index child morphs handler inside lastHandler |
	"Try to get out quickly"
	globalPt _ anEvent cursorPoint.
	(aMorph fullBounds containsPoint: globalPt) ifFalse:[^#rejected].

	"Install the prospective handler for the receiver"
	lastHandler _ anEvent handler. "in case the mouse wasn't even in the receiver"
	handler _ aMorph handlerForMouseDown: anEvent.
	handler ifNotNil:[anEvent handler: handler].

	"Now give our submorphs a chance to handle the event"
	index _ 1.
	morphs _ aMorph submorphs.
	[index <= morphs size] whileTrue:[
		child _ morphs at: index.
		localEvt _ anEvent transformedBy: (child transformedFrom: aMorph).
		(child processEvent: localEvt using: self) == #rejected ifFalse:[
			"Some child did contain the point so we're part of the top-most chain."
			inside _ false.
			localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt].
			index _ morphs size].
		index _ index + 1.
	].

	(inside == false or:[aMorph containsPoint: anEvent cursorPoint event: anEvent]) ifTrue:[
		"Receiver is in the top-most unlocked, visible chain."
		handler ifNotNil:[handler handleEvent: anEvent].
		"Note: Re-installing the handler is not really necessary but good style."
		anEvent handler: lastHandler.
		^self
	].
	"Mouse was not on receiver nor any of its children"
	anEvent handler: lastHandler.
	^#rejected! !
Object subclass: #MorphicEventEncoder
	instanceVariableNames: 'connection lastEventSent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!MorphicEventEncoder commentStamp: '<historical>' prior: 0!
A filter which translates MorphEvent's into StringArray's.!


!MorphicEventEncoder methodsFor: 'initialization' stamp: 'ls 3/24/2000 21:38'!
connection: aConnection
	connection := aConnection! !


!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'ls 3/24/2000 21:42'!
flush
	connection flush! !

!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'ls 3/24/2000 21:38'!
processIO
	connection processIO! !

!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'RAA 12/13/2000 08:19'!
requestBufferedConnection
	"request the opposite side to send complete screen updates rather than discrete drawing commands"
	
	connection nextPut: { 'beginBuffering' }
! !

!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'ls 3/26/2000 01:08'!
sendEvent: anEvent
	(anEvent isMouseMove and: [ anEvent = lastEventSent ]) ifTrue: [
		"save on network traffic--don't send duplicate mouse moves"
		^self ].
	lastEventSent := anEvent.
	connection nextPut: #('event'), anEvent encodedAsStringArray! !

!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'ls 4/11/2000 18:59'!
sendViewExtent: newExtent
	"inform the opposite side that our view extent has changed"
	
	connection nextPut: { 'viewExtent'. CanvasEncoder encodePoint: newExtent }
! !

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

MorphicEventEncoder class
	instanceVariableNames: ''!

!MorphicEventEncoder class methodsFor: 'instance creation' stamp: 'ls 3/24/2000 21:43'!
on: aStringArray
	^self basicNew connection: aStringArray! !
BorderedMorph subclass: #MorphicModel
	instanceVariableNames: 'model slotName open'
	classVariableNames: 'TimeOfError'
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!MorphicModel commentStamp: '<historical>' prior: 0!
MorphicModels are used to represent structures with state and behavior as well as graphical structure.  A morphicModel is usually the root of a morphic tree depicting its appearance.  The tree is constructed concretely by adding its consituent morphs to a world.

When a part is named in a world, it is given a new slot in the model.  When a part is sensitized, it is named, and a set of mouse-driven methods is also generated in the model.  These may be edited to induce particular behavior.  When a variable is added through the morphic world, it is given a slot in the model, along with a set of access methods.

In addition for public variables (and this is the default for now), methods are generated and called in any outer model in which this model gets embedded, thus propagating variable changes outward.!


!MorphicModel methodsFor: 'access'!
model 
	^ model! !

!MorphicModel methodsFor: 'access'!
slotName
	^ slotName! !

!MorphicModel methodsFor: 'access' stamp: '6/7/97 10:40 di'!
wantsSlot
	"Override this default for models that want to be installed in theri model"
	^ false! !


!MorphicModel methodsFor: 'accessing' stamp: 'sw 10/23/1999 22:36'!
modelOrNil
	^ model! !


!MorphicModel methodsFor: 'caching' stamp: 'sw 3/6/2001 11:22'!
releaseCachedState
	"Release cached state of the receiver"

	(model ~~ self and: [model respondsTo: #releaseCachedState]) ifTrue:
		[model releaseCachedState].
	super releaseCachedState! !


!MorphicModel methodsFor: 'classification' stamp: 'ar 10/5/2000 16:40'!
isMorphicModel
	^true! !


!MorphicModel methodsFor: 'compilation'!
addPartNameLike: className withValue: aMorph
	| otherNames i default partName stem |
	stem _ className first asLowercase asString , className allButFirst.
	otherNames _ self class allInstVarNames.
	i _ 1.
	[otherNames includes: (default _ stem, i printString)]
		whileTrue: [i _ i + 1].
	partName _ FillInTheBlank
		request: 'Please give this part a name'
		initialAnswer: default.
	(otherNames includes: partName)
		ifTrue: [self inform: 'Sorry, that name is already used'. ^ nil].
	self class addInstVarName: partName.
	self instVarAt: self class instSize put: aMorph.  "Assumes added as last field"
	^ partName! !

!MorphicModel methodsFor: 'compilation' stamp: 'tk 4/18/97'!
compileAccessForSlot: aSlotName
	"Write the method to get at this inst var.  "
	"Instead call the right thing to make this happen?"

	| s  |
	s _ WriteStream on: (String new: 2000).
	s nextPutAll: aSlotName; cr; tab; nextPutAll: '^', aSlotName.
	self class
		compile: s contents
		classified: 'public access'
		notifying: nil.
! !

!MorphicModel methodsFor: 'compilation'!
compilePropagationMethods
	| varName |
	(self class organization listAtCategoryNamed: 'private - propagation' asSymbol)
		do: [:sel | varName _ sel allButLast.
			model class compilePropagationForVarName: varName slotName: slotName]! !

!MorphicModel methodsFor: 'compilation'!
nameFor: aMorph
	"Return the name of the slot containing the given morph or nil if that morph has not been named."

	| allNames start |
	allNames _ self class allInstVarNames.
	start _ MorphicModel allInstVarNames size + 1.
	start to: allNames size do: [:i |
		(self instVarAt: i) == aMorph ifTrue: [^ allNames at: i]].
	^ nil
! !

!MorphicModel methodsFor: 'compilation'!
propagate: value as: partStoreSelector
	model ifNil: [^ self].
"
	Later we can cache this for more speed as follows...
	(partName == cachedPartName and: [slotName == cachedSlotName])
		ifFalse: [cachedPartName _ partName.
				cachedSlotName _ slotName.
				cachedStoreSelector _ (slotName , partStoreSelector) asSymbol].
	model perform: cachedStoreSelector with: value].
"
	model perform: (self slotSelectorFor: partStoreSelector) with: value! !

!MorphicModel methodsFor: 'compilation' stamp: 'tk 10/31/97 12:33'!
removeAll
	"Clear out all script methods and subpart instance variables in me.  Start over."
	"self removeAll"
	"MorphicModel2 removeAll"

self class == MorphicModel ifTrue: [^ self].	"Must be a subclass!!"
self class removeCategory: 'scripts'.
self class instVarNames do: [:nn | self class removeInstVarName: nn].! !

!MorphicModel methodsFor: 'compilation'!
slotSelectorFor: selectorBody
	| selector |
	model ifNil: [^ nil].
	"Make up selector from slotname if any"
	selector _ (slotName ifNil: [selectorBody]
					ifNotNil: [slotName , selectorBody]) asSymbol.
	(model canUnderstand: selector) ifFalse:
		[self halt: 'Compiling a null response for ' , model class name , '>>' , selector].
	^ selector! !

!MorphicModel methodsFor: 'compilation'!
use: cachedSelector orMakeModelSelectorFor: selectorBody in: selectorBlock
	| selector |
	model ifNil: [^ nil].
	cachedSelector ifNil:
			["Make up selector from slotname if any"
			selector _ (slotName ifNil: [selectorBody]
								ifNotNil: [slotName , selectorBody]) asSymbol.
			(model class canUnderstand: selector) ifFalse:
				[(self confirm: 'Shall I compile a null response for'
							, Character cr asString
							, model class name , '>>' , selector)
						ifFalse: [self halt].
				model class compile: (String streamContents:
								[:s | selector keywords doWithIndex:
										[:k :i | s nextPutAll: k , ' arg' , i printString].
								s cr; nextPutAll: '"Automatically generated null response."'.
								s cr; nextPutAll: '"Add code below for appropriate behavior..."'.])
							classified: 'input events'
							notifying: nil]]
		ifNotNil:
			[selector _ cachedSelector].
	^ selectorBlock value: selector! !


!MorphicModel methodsFor: 'debug and other' stamp: '6/7/97 10:43 di'!
installModelIn: aWorld

	self wantsSlot ifFalse: [^ self].  "No real need to install"
	slotName _ aWorld model addPartNameLike: self class name withValue: self.
	slotName ifNil: [^ self].  "user chose bad slot name"
	self model: aWorld model slotName: slotName.
	self compilePropagationMethods.
	aWorld model compileAccessForSlot: slotName.
! !


!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:17'!
allowSubmorphExtraction
	^ self isOpen
! !

!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:16'!
isOpen
	"Support drag/drop and other edits."
	^ open! !


!MorphicModel methodsFor: 'geometry'!
newBounds: newBounds
	self bounds: newBounds! !

!MorphicModel methodsFor: 'geometry'!
recomputeBounds

	| bnds |
	bnds _ submorphs first bounds.
	bounds _ bnds origin corner: bnds corner. "copy it!!"
	fullBounds _ nil.
	bounds _ self fullBounds.
! !


!MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color yellow! !

!MorphicModel methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 corner: 200 @ 100! !

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

!MorphicModel methodsFor: 'initialization' stamp: 'tk 4/15/97'!
duplicate: newGuy from: oldGuy
	"oldGuy has just been duplicated and will stay in this world.  Make sure all the MorphicModel requirements are carried out for the copy.  Ask user to rename it.  "

	newGuy installModelIn: oldGuy world.
	newGuy copySlotMethodsFrom: oldGuy slotName.! !

!MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:47'!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	open _ false! !

!MorphicModel methodsFor: 'initialization' stamp: 'jm
 8/20/1998 09:08'!
model: anObject
	"Set my model and make me me a dependent of the given object."

	model ifNotNil: [model removeDependent: self].
	anObject ifNotNil: [anObject addDependent: self].
	model _ anObject.
! !

!MorphicModel methodsFor: 'initialization' stamp: 'di 6/21/97 13:25'!
model: thang slotName: nameOfThisPart
	model _ thang.
	slotName _ nameOfThisPart.
	open _ false.! !


!MorphicModel methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:53'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	model ifNotNil: [model addModelMenuItemsTo: aCustomMenu forMorph: self hand: aHandMorph].
	self isOpen ifTrue: [aCustomMenu add: 'close editing' translated action: #closeToEdits]
			ifFalse: [aCustomMenu add: 'open editing' translated action: #openToEdits].
! !

!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'!
closeToEdits
	"Disable this morph's ability to add and remove morphs via drag-n-drop."

	open _ false
! !

!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'!
openToEdits
	"Enable this morph's ability to add and remove morphs via drag-n-drop."

	open _ true
! !


!MorphicModel methodsFor: 'naming' stamp: 'dgd 2/21/2003 23:00'!
choosePartName
	"When I am renamed, get a slot, make default methods, move any existing methods.  ** Does not clean up old inst var name or methods**  "

	| old |
	old := slotName.
	super choosePartName.
	slotName ifNil: [^self].	"user chose bad slot name"
	self model: self world model slotName: slotName.
	old isNil
		ifTrue: [self compilePropagationMethods]
		ifFalse: [self copySlotMethodsFrom: old]
	"old ones not erased!!"! !


!MorphicModel methodsFor: 'printing'!
initString

	^ String streamContents:
		[:s | s nextPutAll: self class name;
			nextPutAll: ' newBounds: (';
			print: bounds;
			nextPutAll: ') model: self slotName: ';
			print: slotName]! !


!MorphicModel methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 18:51'!
allKnownNames
	"Return a list of all known names based on the scope of the receiver.  If the receiver is a member of a uniclass, incorporate the original 1997 logic that queries the known names of the values of all the instance variables."

	| superNames |
	superNames := super allKnownNames.	"gather them from submorph tree"
	^self belongsToUniClass 
		ifTrue: 
			[superNames , (self instanceVariableValues 
						select: [:e | e notNil and: [e knownName notNil]]
						thenCollect: [:e | e knownName])]
		ifFalse: [superNames]! !


!MorphicModel methodsFor: 'submorphs-add/remove' stamp: 'gm 2/22/2003 12:51'!
delete
	(model isMorphicModel) ifFalse: [^super delete].
	slotName ifNotNil: 
			[(PopUpMenu confirm: 'Shall I remove the slot ' , slotName 
						, '
along with all associated methods?') 
				ifTrue: 
					[(model class selectors select: [:s | s beginsWith: slotName]) 
						do: [:s | model class removeSelector: s].
					(model class instVarNames includes: slotName) 
						ifTrue: [model class removeInstVarName: slotName]]
				ifFalse: 
					[(PopUpMenu 
						confirm: '...but should I at least dismiss this morph?
[choose no to leave everything unchanged]') 
							ifFalse: [^self]]].
	super delete! !


!MorphicModel methodsFor: '*MorphicExtras-compilation'!
compileInitMethods
	| s nodeDict varNames |
	nodeDict _ IdentityDictionary new.
	s _ WriteStream on: (String new: 2000).
	varNames _ self class allInstVarNames.
	s nextPutAll: 'initMorph'.
	3 to: self class instSize do:
		[:i | (self instVarAt: i) isMorph ifTrue:
			[s cr; tab; nextPutAll: (varNames at: i) , ' _ '.
			s nextPutAll: (self instVarAt: i) initString; nextPutAll: '.'.
			nodeDict at: (self instVarAt: i) put: (varNames at: i)]].
	submorphs do: 
		[:m | s cr; tab; nextPutAll: 'self addMorph: '.
		m printConstructorOn: s indent: 1 nodeDict: nodeDict.
		s nextPutAll: '.'].
	self class
		compile: s contents
		classified: 'initialization'
		notifying: nil.! !

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

MorphicModel class
	instanceVariableNames: 'prototype'!

!MorphicModel class methodsFor: 'compilation' stamp: 'tk 3/10/98 18:03'!
categoryForSubclasses
	^ 'Morphic-Models'! !

!MorphicModel class methodsFor: 'compilation' stamp: 'sw 5/23/2001 13:51'!
chooseNewName
	"Choose a new name for the receiver, persisting until an acceptable name is provided or until the existing name is resubmitted"

	| oldName newName |
	oldName _ self name.
		[newName _ (FillInTheBlank request: 'Please give this Model a name'
					initialAnswer: oldName) asSymbol.
		newName = oldName ifTrue: [^ self].
		Smalltalk includesKey: newName]
		whileTrue:
		[self inform: 'Sorry, that name is already in use.'].
	self rename: newName.! !

!MorphicModel class methodsFor: 'compilation'!
compileAccessorsFor: varName
	self compile: (
'&var
	"Return the value of &var"
	^ &var'
			copyReplaceAll: '&var' with: varName)
		classified: 'public access' notifying: nil.
	self compile: (
'&varPut: newValue
	"Assign newValue to &var.
	Add code below to update related graphics appropriately..."

	&var _ newValue.'
			copyReplaceAll: '&var' with: varName)
		classified: 'public access' notifying: nil.
	self compile: (
'&var: newValue
	"Assigns newValue to &var and updates owner"
	&var _ newValue.
	self propagate: &var as: ''&var:'''
			copyReplaceAll: '&var' with: varName)
		classified: 'private - propagation' notifying: nil.
! !

!MorphicModel class methodsFor: 'compilation'!
compilePropagationForVarName: varName slotName: slotName
	self compile: ((
'&slot&var: newValue
	"The value of &var in &slot has changed to newValue.
	This value can be read elsewhere in code with
		&slot &var
	and it can be stored into with
		&slot &varPut: someValue"

	"Add code for appropriate response here..."'
			copyReplaceAll: '&var' with: varName)
			copyReplaceAll: '&slot' with: slotName)
		classified: 'input events' notifying: nil.
! !


!MorphicModel class methodsFor: 'compiling' stamp: 'sw 5/13/1998 14:33'!
acceptsLoggingOfCompilation
	"Dont log sources for my automatically-generated subclasses.  Can easily switch this back when it comes to deal with Versions, etc."

	^ self == MorphicModel or: [(name last isDigit) not]! !

!MorphicModel class methodsFor: 'compiling' stamp: 'sw 8/4/97 17:16'!
wantsChangeSetLogging
	"Log changes for MorphicModel itself and for things like PlayWithMe2, but not for automatically-created subclasses like MorphicModel1, MorphicModel2, etc."

	^ self == MorphicModel or:
		[(self class name beginsWith: 'Morphic') not]! !


!MorphicModel class methodsFor: 'housekeeping' stamp: 'jm 7/30/97 16:40'!
removeUninstantiatedModels
	"With the user's permission, remove the classes of any models that have neither instances nor subclasses."
	"MorphicModel removeUninstantiatedModels"

	| candidatesForRemoval ok |
	Smalltalk garbageCollect.
	candidatesForRemoval _
		MorphicModel subclasses select: [:c |
			(c instanceCount = 0) and: [c subclasses size = 0]].
	candidatesForRemoval do: [:c |
		ok _ self confirm: 'Are you certain that you
want to delete the class ', c name, '?'.
		ok ifTrue: [c removeFromSystem]].
! !


!MorphicModel class methodsFor: 'instance creation' stamp: 'tk 8/13/1998 12:58'!
new
	"Return a copy of the prototype, if there is one.
	Otherwise create a new instance normally."

	self hasPrototype ifTrue: [^ prototype veryDeepCopy].
	^ super new
! !

!MorphicModel class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:27'!
newBounds: bounds model: thang slotName: nameOfThisPart
	^ (super new model: thang slotName: nameOfThisPart)
		newBounds: bounds! !


!MorphicModel class methodsFor: 'new-morph participation' stamp: 'di 2/21/98 11:01'!
includeInNewMorphMenu
	"Only include Models that are appropriate"
	^ false! !


!MorphicModel class methodsFor: 'prototype access'!
prototype
	"Return the prototype for this morph."

	^ prototype
! !

!MorphicModel class methodsFor: 'prototype access' stamp: 'gm 2/22/2003 19:13'!
prototype: aMorph
	"Store a copy of the given morph as a prototype to be copied to make new instances."

	aMorph ifNil: [prototype _ nil. ^ self].

	prototype _ aMorph veryDeepCopy.
	(prototype isMorphicModel) ifTrue: 
		[prototype model: nil slotName: nil].
! !


!MorphicModel class methodsFor: 'queries'!
hasPrototype
	"Return true if there is a prototype for this morph."

	^ prototype ~~ nil
! !


!MorphicModel class methodsFor: 'subclass creation'!
newSubclass
	| i className |
	i _ 1.
	[className _ (self name , i printString) asSymbol.
	 Smalltalk includesKey: className]
		whileTrue: [i _ i + 1].

	^ self subclass: className
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Morphic-Models'! !


!MorphicModel class methodsFor: 'testing' stamp: 'tk 3/15/98 20:13'!
officialClass
	"We want to make a new instance of the receiver, which is a subclass of MorphicModel.  Answer who to make a new subclass of.  Also used to tell if a given class is a UniClass, existing only for its single instance."

	^ self name last isDigit ifTrue: [MorphicModel] ifFalse: [self]
		"MorphicModel7 can not have subclasses, but Slider and SystemWindow may"! !


!MorphicModel class methodsFor: '*eToys-queries' stamp: 'sw 2/27/2002 14:58'!
baseUniclass
	"Answer the uniclass that new instances should be instances of.  This protocol is primarily intended for the Player lineage, but can get sent to a MorphicModel subclass when the project-loading mechanism is scrambling to fix up projects that have naming conflicts with the project being loaded."

	| curr |
	curr _ self.
	[curr theNonMetaClass superclass name endsWithDigit]
		whileTrue:
			[curr _ curr superclass].
	^ curr

"PlayWithMe1 baseUniclass"! !
AppRegistry subclass: #MorphicTextEditor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Applications'!
ToolBuilder subclass: #MorphicToolBuilder
	instanceVariableNames: 'widgets panes parentMenu'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!MorphicToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0!
The Morphic tool builder.!


!MorphicToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:40'!
close: aWidget
	"Close a previously opened widget"
	aWidget delete! !

!MorphicToolBuilder methodsFor: 'opening' stamp: 'ar 2/28/2006 17:39'!
open: anObject
	"Build and open the object. Answer the widget opened."
	| morph |
	morph := self build: anObject.
	(morph isKindOf: MenuMorph)
		ifTrue:[morph popUpInWorld: World].
	(morph isKindOf: SystemWindow)
		ifTrue:[morph openInWorldExtent: morph extent]
		ifFalse:[morph openInWorld].
	^morph! !

!MorphicToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:40'!
open: anObject label: aString
	"Build an open the object, labeling it appropriately.  Answer the widget opened."
	| window |
	window := self open: anObject.
	window setLabel: aString.
	^window! !

!MorphicToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:41'!
runModal: aWidget
	"Run the (previously opened) widget modally, e.g., 
	do not return control to the sender before the user has responded."
	[aWidget world notNil] whileTrue: [
		aWidget outermostWorldMorph doOneCycle.
	].
! !


!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 2/12/2005 14:22'!
buildPluggableActionButton: aSpec
	| button |
	button := self buildPluggableButton: aSpec.
	button beActionButton.
	^button! !

!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:27'!
buildPluggableButton: aSpec
	| widget label state action enabled |
	label := aSpec label.
	state := aSpec state.
	action := aSpec action.
	widget := PluggableButtonMorphPlus on: aSpec model
				getState: (state isSymbol ifTrue:[state])
				action: nil
				label: (label isSymbol ifTrue:[label]).
	self register: widget id: aSpec name.
	enabled := aSpec enabled.
	enabled isSymbol
		ifTrue:[widget getEnabledSelector: enabled]
		ifFalse:[widget enabled:enabled].
	widget action: action.
	widget getColorSelector: aSpec color.
	widget offColor: Color transparent.
	aSpec help ifNotNil:[widget setBalloonText: aSpec help].
	(label isSymbol or:[label == nil]) ifFalse:[widget label: label].
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[self add: widget to: parent].
	^widget! !

!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'md 8/15/2005 17:55'!
buildPluggableInputField: aSpec
	| widget |
	widget := self buildPluggableText: aSpec.
	widget acceptOnCR: true.
	widget hideScrollBarsIndefinitely.
	^widget! !

!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/15/2005 12:07'!
buildPluggableList: aSpec
	| widget listClass getIndex setIndex |
	aSpec getSelected ifNil:[
		listClass := PluggableListMorphPlus.
		getIndex := aSpec getIndex.
		setIndex := aSpec setIndex.
	] ifNotNil:[
		listClass := PluggableListMorphByItemPlus.
		getIndex := aSpec getSelected.
		setIndex := aSpec setSelected.
	].
	widget := listClass on: aSpec model
				list: aSpec list
				selected: getIndex
				changeSelected: setIndex
				menu: aSpec menu
				keystroke: aSpec keyPress.
	self register: widget id: aSpec name.
	widget dragItemSelector: aSpec dragItem.
	widget dropItemSelector: aSpec dropItem.
	widget wantsDropSelector: aSpec dropAccept.
	widget autoDeselect: aSpec autoDeselect.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[self add: widget to: parent].
	panes ifNotNil:[
		aSpec list ifNotNil:[panes add: aSpec list].
	].
	^widget! !

!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:27'!
buildPluggableMultiSelectionList: aSpec
	| widget listClass |
	aSpec getSelected ifNotNil:[^self error:'There is no PluggableListMorphOfManyByItem'].
	listClass := PluggableListMorphOfMany.
	widget := listClass on: aSpec model
		list: aSpec list
		primarySelection: aSpec getIndex
		changePrimarySelection: aSpec setIndex
		listSelection: aSpec getSelectionList
		changeListSelection: aSpec setSelectionList
		menu: aSpec menu.
	self register: widget id: aSpec name.
	widget keystrokeActionSelector: aSpec keyPress.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[self add: widget to: parent].
	panes ifNotNil:[
		aSpec list ifNotNil:[panes add: aSpec list].
	].
	^widget! !

!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:28'!
buildPluggablePanel: aSpec
	| widget children |
	widget := PluggablePanelMorph new.
	self register: widget id: aSpec name.
	widget model: aSpec model.
	widget color: Color transparent.
	widget clipSubmorphs: true.
	children := aSpec children.
	children isSymbol ifTrue:[
		widget getChildrenSelector: children.
		widget update: children.
		children := #().
	].
	self buildAll: children in: widget.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[self add: widget to: parent].
	self setLayout: aSpec layout in: widget.
	^widget! !

!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:28'!
buildPluggableText: aSpec
	| widget |
	widget := PluggableTextMorphPlus on: aSpec model
				text: aSpec getText 
				accept: aSpec setText
				readSelection: aSpec selection 
				menu: aSpec menu.
	self register: widget id: aSpec name.
	widget getColorSelector: aSpec color.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[self add: widget to: parent].
	panes ifNotNil:[
		aSpec getText ifNotNil:[panes add: aSpec getText].
	].
	^widget! !

!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/15/2005 12:10'!
buildPluggableTree: aSpec
	| widget |
	widget := PluggableTreeMorph new.
	self register: widget id: aSpec name.
	widget model: aSpec model.
	widget getSelectedPathSelector: aSpec getSelectedPath.
	widget setSelectedSelector: aSpec setSelected.
	widget getChildrenSelector: aSpec getChildren.
	widget hasChildrenSelector: aSpec hasChildren.
	widget getLabelSelector: aSpec label.
	widget getIconSelector: aSpec icon.
	widget getHelpSelector: aSpec help.
	widget getMenuSelector: aSpec menu.
	widget keystrokeActionSelector: aSpec keyPress.
	widget getRootsSelector: aSpec roots.
	widget autoDeselect: aSpec autoDeselect.
	widget dropItemSelector: aSpec dropItem.
	widget wantsDropSelector: aSpec dropAccept.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[self add: widget to: parent].
	panes ifNotNil:[
		aSpec roots ifNotNil:[panes add: aSpec roots].
	].
	^widget! !

!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 9/17/2005 21:07'!
buildPluggableWindow: aSpec
	| widget children label |
	aSpec layout == #proportional ifFalse:[
		"This needs to be implemented - probably by adding a single pane and then the rest"
		^self error: 'Not implemented'.
	].
	widget := PluggableSystemWindow new.
	self register: widget id: aSpec name.
	widget model: aSpec model.
	(label := aSpec label) ifNotNil:[
		label isSymbol 
			ifTrue:[widget getLabelSelector: label]
			ifFalse:[widget setLabel: label]].
	children := aSpec children.
	children isSymbol ifTrue:[
		widget getChildrenSelector: children.
		widget update: children.
		children := #().
	].
	widget closeWindowSelector: aSpec closeAction.
	panes := OrderedCollection new.
	self buildAll: children in: widget.
	aSpec extent ifNotNil:[widget extent: aSpec extent].
	widget setUpdatablePanesFrom: panes.
	^widget! !


!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 7/17/2005 00:00'!
add: aMorph to: aParent
	aParent addMorphBack: aMorph.
	aParent isSystemWindow ifTrue:[
		aParent addPaneMorph: aMorph.
	].! !

!MorphicToolBuilder methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:35'!
asFrame: aRectangle
	| frame |
	aRectangle ifNil:[^nil].
	frame := LayoutFrame new.
	frame 
		leftFraction: aRectangle left; 
		rightFraction: aRectangle right; 
		topFraction: aRectangle top; 
		bottomFraction: aRectangle bottom.
	^frame! !

!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:28'!
register: widget id: id
	id ifNil:[^self].
	widgets ifNil:[widgets := Dictionary new].
	widgets at: id put: widget.! !

!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 2/12/2005 19:20'!
setFrame: aRectangle in: widget
	| frame |
	aRectangle ifNil:[^nil].
	frame := self asFrame: aRectangle.
	widget layoutFrame: frame.
	widget hResizing: #spaceFill; vResizing: #spaceFill.
	(parent isSystemWindow) ifTrue:[
		widget borderWidth: 2; borderColor: #inset.
	].! !

!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 2/10/2005 22:28'!
setLayout: layout in: widget
	layout == #proportional ifTrue:[
		widget layoutPolicy: ProportionalLayout new.
		^self].
	layout == #horizontal ifTrue:[
		widget layoutPolicy: TableLayout new.
		widget listDirection: #leftToRight.
		widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill].
		"and then some..."
		^self].
	layout == #vertical ifTrue:[
		widget layoutPolicy: TableLayout new.
		widget listDirection: #topToBottom.
		widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill].
		"and then some..."
		^self].
	^self error: 'Unknown layout: ', layout.! !

!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:30'!
widgetAt: id ifAbsent: aBlock
	widgets ifNil:[^aBlock value].
	^widgets at: id ifAbsent: aBlock! !


!MorphicToolBuilder methodsFor: 'building' stamp: 'ar 2/28/2006 17:30'!
buildPluggableMenu: menuSpec 
	| prior menu |
	prior := parentMenu.
	parentMenu := menu := MenuMorph new.
	menuSpec label ifNotNil:[parentMenu addTitle: menuSpec label].
	menuSpec items do:[:each| each buildWith: self].
	parentMenu := prior.
	^menu! !

!MorphicToolBuilder methodsFor: 'building' stamp: 'ar 2/28/2006 17:37'!
buildPluggableMenuItem: itemSpec
	| item action label menu |
	item _ MenuItemMorph new.
	label := itemSpec label.
	itemSpec checked ifTrue:[label := '<on>', label] ifFalse:[label := '<off>', label].
	item contents: label.
	item isEnabled: itemSpec enabled.
	(action := itemSpec action) ifNotNil:[
		item 
			target: action receiver;
			selector: action selector;
			arguments: action arguments.
	].
	(menu := itemSpec subMenu) ifNotNil:[
		item subMenu: (menu buildWith: self).
	].
	parentMenu ifNotNil:[parentMenu addMorphBack: item].
	^item! !

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

MorphicToolBuilder class
	instanceVariableNames: ''!

!MorphicToolBuilder class methodsFor: 'accessing' stamp: 'ar 2/11/2005 15:24'!
isActiveBuilder
	"Answer whether I am the currently active builder"
	^Smalltalk isMorphic! !
ToolBuilderTests subclass: #MorphicToolBuilderTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!MorphicToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0!
Tests for the Morphic tool builder.!


!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:26'!
acceptWidgetText
	widget hasUnacceptedEdits: true.
	widget accept.! !

!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 6/21/2005 10:35'!
buttonWidgetEnabled
	"Answer whether the current widget (a button) is currently enabled"
	^widget enabled! !

!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:22'!
changeListWidget
	widget changeModelSelection: widget getCurrentSelectionIndex + 1.! !

!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:15'!
fireButtonWidget
	widget performAction.! !

!MorphicToolBuilderTests methodsFor: 'support' stamp: 'cwp 6/9/2005 00:11'!
fireMenuItemWidget
	(widget itemWithWording: 'Menu Item')
		ifNotNilDo: [:item | item doButtonAction]! !

!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 14:46'!
setUp
	super setUp.
	builder := MorphicToolBuilder new.! !

!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 21:43'!
widgetColor
	"Answer color from widget"
	^widget color! !


!MorphicToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/13/2005 13:52'!
testWindowDynamicLabel
	self makeWindow.
	self assert: (widget label = 'TestLabel').! !

!MorphicToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/13/2005 13:52'!
testWindowStaticLabel
	| spec |
	spec := builder pluggableWindowSpec new.
	spec model: self.
	spec children: #().
	spec label: 'TestLabel'.
	widget := builder build: spec.
	self assert: (widget label = 'TestLabel').! !
DisplayTransform subclass: #MorphicTransform
	instanceVariableNames: 'offset angle scale'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Transformations'!
!MorphicTransform commentStamp: '<historical>' prior: 0!
This class implements simple translation, scaling and rotation for points, as well as inverse transformations.  These transformations are used in TransformMorphs (clipping scrollers) and TransformationMorphs (general flex-morph wrappers) to map, eg, global mouse coords into local coords, and to invert, eg, local damage rectangles into global damage rectangles.!


!MorphicTransform methodsFor: 'accessing'!
angle
	^ angle! !

!MorphicTransform methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:33'!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^MorphicTransform
		offset: (self transform: 0@0) - (self transform: offset)
		angle: angle negated
		scale: scale reciprocal! !

!MorphicTransform methodsFor: 'accessing'!
offset
	^ offset
! !

!MorphicTransform methodsFor: 'accessing'!
scale
	^ scale! !

!MorphicTransform methodsFor: 'accessing'!
withAngle: a
	"Return a copy of me with a different Angle"
	^ self copy setAngle: a! !

!MorphicTransform methodsFor: 'accessing'!
withOffset: a
	"Return a copy of me with a different Offset"
	^ self copy setOffset: a! !

!MorphicTransform methodsFor: 'accessing'!
withScale: a
	"Return a copy of me with a different Scale"
	^ self copy setScale: a! !


!MorphicTransform methodsFor: 'composing' stamp: 'nk 3/9/2001 13:55'!
composedWithLocal: aTransform
	aTransform isIdentity ifTrue:[^self].
	self isIdentity ifTrue:[^aTransform].
	aTransform isMorphicTransform ifFalse:[^super composedWithLocal: aTransform].
	self isPureTranslation ifTrue:[
		^aTransform withOffset: aTransform offset + self offset].
	aTransform isPureTranslation ifTrue:[
		^self withOffset: (self localPointToGlobal: aTransform offset negated) negated].
	^super composedWithLocal: aTransform.! !


!MorphicTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:14'!
asMatrixTransform2x3
	^((MatrixTransform2x3 withRotation: angle radiansToDegrees negated) composedWithLocal:
		(MatrixTransform2x3 withScale: scale))
			offset: offset negated! !

!MorphicTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'!
asMorphicTransform

	^ self! !


!MorphicTransform methodsFor: 'initialize' stamp: 'ar 11/2/1998 20:58'!
setIdentiy
	scale _ 1.0.
	offset _ 0@0.
	angle _ 0.0.! !


!MorphicTransform methodsFor: 'printing' stamp: 'ar 5/19/1999 18:21'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(;
		nextPutAll:'angle = '; print: angle;
		nextPutAll:'; scale = '; print: scale;
		nextPutAll:'; offset = '; print: offset;
		nextPut:$).! !


!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."

	^ self isPureTranslation and: [offset = (0@0)]
! !

!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 19:51'!
isMorphicTransform
	^true! !

!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."

	^ angle = 0.0 and: [scale = 1.0]
! !


!MorphicTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:10'!
composedWith: aTransform
	"Return a new transform that has the effect of transforming points first by the receiver and then by the argument."

	self isIdentity ifTrue: [^ aTransform].
	aTransform isIdentity ifTrue: [^ self].
	^ CompositeTransform new globalTransform: self
							localTransform: aTransform! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/28/1999 09:10'!
invert: aPoint
	"Transform the given point from local to global coordinates."
	| p3 p2 |
	self isPureTranslation ifTrue: [^ aPoint - offset].
	p3 _  aPoint * scale.
	p2 _ ((p3 x * angle cos) + (p3 y * angle sin))
		@ ((p3 y * angle cos) - (p3 x * angle sin)).
	^ (p2 - offset)
! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/3/1998 00:18'!
invertBoundsRect: aRectangle
	"Return a rectangle whose coordinates have been transformed
	from local back to global coordinates.  NOTE: if the transformation
	is not just a translation, then it will compute the bounding box
	in global coordinates."
	| outerRect |
	self isPureTranslation
	ifTrue:
		[^ (self invert: aRectangle topLeft)
			corner: (self invert: aRectangle bottomRight)]
	ifFalse:
		[outerRect _ Rectangle encompassing:
			(aRectangle innerCorners collect: [:p | self invert: p]).
		"Following asymmetry due to likely subsequent truncation"
		^ outerRect topLeft - (1@1) corner: outerRect bottomRight + (2@2)]! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/2/1998 08:54'!
invertRect: aRectangle

	self error: 'method name changed to emphasize enclosing bounds'.
	^ self invertBoundsRect: aRectangle! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/28/1999 09:05'!
transform: aPoint
	"Transform the given point from global to local coordinates."
	| p2 p3 |
	self isPureTranslation ifTrue: [^ aPoint + offset].
	p2 _ aPoint + offset.
	p3 _ (((p2 x * angle cos) - (p2 y * angle sin))
		@ ((p2 y * angle cos) + (p2 x * angle sin)))
			/ scale.
	^ p3! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/3/1998 00:18'!
transformBoundsRect: aRectangle
	"Return a rectangle whose coordinates have been transformed
	from global to local coordinates.  NOTE: if the transformation
	is not just a translation, then it will compute the bounding box
	in global coordinates."
	| outerRect |
	self isPureTranslation
	ifTrue:
		[^ (self transform: aRectangle topLeft)
			corner: (self transform: aRectangle bottomRight)]
	ifFalse:
		[outerRect _ Rectangle encompassing:
			(aRectangle innerCorners collect: [:p | self transform: p]).
		"Following asymmetry due to likely subsequent truncation"
		^ outerRect topLeft - (1@1) corner: outerRect bottomRight + (2@2)]! !


!MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:13'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self transform: aPoint! !

!MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:32'!
localPointToGlobal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self invert: aPoint! !


!MorphicTransform methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ls 10/9/1999 19:06'!
encodeForRemoteCanvas
	"encode this transform into a string for use by a RemoteCanvas"
	^String streamContents: [ :str |
		str nextPutAll: 'Morphic,';
			print: offset x truncated;
			nextPut: $,;
			print: offset y truncated;
			nextPut: $,;
			print: scale;
			nextPut: $,;
			print: angle
	]! !


!MorphicTransform methodsFor: 'private'!
setAngle: aFloat

	angle _ aFloat.
! !

!MorphicTransform methodsFor: 'private'!
setOffset: aPoint

	offset _ aPoint.
! !

!MorphicTransform methodsFor: 'private'!
setOffset: aPoint angle: a scale: s

	offset _ aPoint.
	angle _ a.
	scale _ s! !

!MorphicTransform methodsFor: 'private'!
setScale: aFloat

	scale _ aFloat.
! !

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

MorphicTransform class
	instanceVariableNames: ''!

!MorphicTransform class methodsFor: 'instance creation'!
identity

	^ self offset: 0@0 angle: 0.0 scale: 1.0! !

!MorphicTransform class methodsFor: 'instance creation'!
new

	^ self offset: 0@0
! !

!MorphicTransform class methodsFor: 'instance creation'!
offset: aPoint

	^ self offset: aPoint angle: 0.0 scale: 1.0! !

!MorphicTransform class methodsFor: 'instance creation'!
offset: aPoint angle: a scale: s

	^ self basicNew setOffset: aPoint angle: a scale: s! !


!MorphicTransform class methodsFor: '*nebraska-instance creation' stamp: 'sd 11/20/2005 21:25'!
fromRemoteCanvasEncoding: encoded
	"DisplayTransform fromRemoteCanvasEncoding:  'Morphic,-88,-128,1.345165663873898,0.1352584843149221'"
	| type offsetXEnc offsetYEnc scaleEnc angleEnc offsetX offsetY angle scale rs |

	"separate the numbers"
	rs := ReadStream on: encoded.
	type := rs upTo: $,.
	offsetXEnc := rs upTo: $,.
	offsetYEnc := rs upTo: $,.
	scaleEnc := rs upTo: $,.
	angleEnc := rs upToEnd.

	"decode the numbers"
	offsetX := Integer readFromString: offsetXEnc.
	offsetY := Integer readFromString: offsetYEnc.

	scale := Number readFromString: scaleEnc.
	angle := Number readFromString: angleEnc.

	"create an instance"
	^self offset: offsetX@offsetY angle: angle scale: scale! !
UIManager subclass: #MorphicUIManager
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!MorphicUIManager commentStamp: 'ar 2/11/2005 21:52' prior: 0!
The Morphic ui manager.!


!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:37'!
chooseDirectory: label from: dir
	"Let the user choose a directory"
	^FileList2 modalFolderSelector: dir! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 7/17/2005 00:28'!
chooseFileMatching: patterns label: aString
	"Let the user choose a file matching the given patterns"
	| result |
	result := FileList2 modalFileSelectorForSuffixes: patterns.
	^result ifNotNil:[result fullName]! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 10:47'!
chooseFrom: aList lines: linesArray title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	| menu |
	menu := PopUpMenu labelArray: aList lines: linesArray.
	^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:44'!
chooseFrom: labelList values: valueList lines: linesArray title: aString
	"Choose an item from the given list. Answer the selected item."
	| menu |
	menu := SelectionMenu labels: labelList lines: linesArray selections: valueList.
	^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:45'!
confirm: queryString
	"Put up a yes/no menu with caption queryString. Answer true if the 
	response is yes, false if no. This is a modal question--the user must 
	respond yes or no."
	^PopUpMenu confirm: queryString! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 09:49'!
confirm: aString orCancel: cancelBlock
	"Put up a yes/no/cancel menu with caption aString. Answer true if  
	the response is yes, false if no. If cancel is chosen, evaluate  
	cancelBlock. This is a modal question--the user must respond yes or no."
	^PopUpMenu confirm: aString orCancel: cancelBlock! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:13'!
displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock
	"Display titleString as a caption over a progress bar while workBlock is evaluated."
	^ProgressInitiationException 
		display: titleString
		at: aPoint 
		from: minVal 
		to: maxVal 
		during: workBlock! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 7/17/2005 00:27'!
edit: aText label: labelString accept: anAction
	"Open an editor on the given string/text"
	| window holder text |
	holder := StringHolder new.
	holder contents: aText.
	text := PluggableTextMorphPlus 
		on: holder 
		text: #contents 
		accept: #acceptContents: 
		readSelection: nil 
		menu: nil.
	text acceptAction: anAction.
	window := SystemWindow new.
	labelString ifNotNil:[window setLabel: labelString].
	window addMorph: text frame: (0@0 extent: 1@1).
	window paneColor: Color gray.
	window openInWorld.
! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:07'!
informUserDuring: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUserDuring:[:bar|
			#(one two three) do:[:info|
				bar value: info.
				(Delay forSeconds: 1) wait]]"
	(MVCMenuMorph from: (SelectionMenu labels: '') title: '						')
		informUserAt: Sensor cursorPoint during: aBlock.! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:46'!
inform: aString
	"Display a message for the user to read and then dismiss"
	^PopUpMenu inform: aString! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:05'!
multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight
	"Create a multi-line instance of me whose question is queryString with
	the given initial answer. Invoke it centered at the given point, and
	answer the string the user accepts.  Answer nil if the user cancels.  An
	empty string returned means that the ussr cleared the editing area and
	then hit 'accept'.  Because multiple lines are invited, we ask that the user
	use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 
	submit; that way, the return key can be typed to move to the next line."
	^FillInTheBlank multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:47'!
requestPassword: queryString
	"Create an instance of me whose question is queryString. Invoke it centered
	at the cursor, and answer the string the user accepts. Answer the empty 
	string if the user cancels."
	^FillInTheBlank requestPassword: queryString! !

!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:46'!
request: queryString initialAnswer: defaultAnswer 
	"Create an instance of me whose question is queryString with the given 
	initial answer. Invoke it centered at the given point, and answer the 
	string the user accepts. Answer the empty string if the user cancels."
	^FillInTheBlank request: queryString initialAnswer: defaultAnswer ! !

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

MorphicUIManager class
	instanceVariableNames: ''!

!MorphicUIManager class methodsFor: 'accessing' stamp: 'ar 2/11/2005 15:41'!
isActiveManager
	"Answer whether I should act as the active ui manager"
	^Smalltalk isMorphic! !
MorphicEvent subclass: #MorphicUnknownEvent
	instanceVariableNames: 'type argument'
	classVariableNames: ''
	poolDictionaries: 'EventSensorConstants'
	category: 'Morphic-Events'!

!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 20:04'!
argument
	^argument! !

!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 20:04'!
argument: arg
	argument _ arg! !

!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 19:55'!
position
	^0@0! !

!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 19:55'!
type
	^type! !


!MorphicUnknownEvent methodsFor: 'initialize' stamp: 'ar 10/26/2000 01:20'!
type: eventType readFrom: aStream
	| typeAndArg |
	timeStamp _ Integer readFrom: aStream.
	aStream skip: 1.
	typeAndArg _ Object readFrom: aStream.
	type _ typeAndArg first.
	argument _ typeAndArg last.! !


!MorphicUnknownEvent methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:48'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	type ifNil: [type _ #startSound].
	source ifNil: [source _ varDict at: 'sourceHand'].
	argument ifNil: [argument _ varDict at: 'sound' ifAbsent: [nil]].	"???"
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!MorphicUnknownEvent methodsFor: 'printing' stamp: 'ar 10/26/2000 01:19'!
storeOn: aStream
	aStream nextPutAll: 'unknown'.
	aStream space.
	self timeStamp storeOn: aStream.
	aStream space.
	{type. argument} storeOn: aStream.! !


!MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/25/2000 19:59'!
setType: evtType argument: arg
	type _ evtType.
	argument _ arg.! !

!MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/25/2000 19:58'!
setType: evtType argument: arg hand: evtHand stamp: stamp
	type _ evtType.
	argument _ arg.
	source _ evtHand.
	timeStamp _ stamp.! !
Morph subclass: #MouseActionIndicatorMorph
	instanceVariableNames: 'siblings'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!MouseActionIndicatorMorph commentStamp: '<historical>' prior: 0!
I am used to highlight morphs which have a special mouseup action!


!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:49'!
deleteWithSiblings

	siblings do: [ :each | each delete]
! !

!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:49'!
siblings: aCollection

	siblings _ aCollection.
! !


!MouseActionIndicatorMorph methodsFor: 'event handling' stamp: 'RAA 7/12/2000 10:48'!
handlesMouseOver: evt

	^true! !

!MouseActionIndicatorMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:52'!
handlesMouseOverDragging: evt

	^true! !

!MouseActionIndicatorMorph methodsFor: 'event handling' stamp: 'RAA 7/12/2000 10:50'!
mouseEnter: evt

	self deleteWithSiblings
! !

!MouseActionIndicatorMorph methodsFor: 'event handling' stamp: 'RAA 7/17/2000 09:52'!
mouseEnterDragging: evt

	self deleteWithSiblings
! !


!MouseActionIndicatorMorph methodsFor: 'initialization' stamp: 'RAA 7/12/2000 10:48'!
initialize

	super initialize.
	siblings _ #().! !

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

MouseActionIndicatorMorph class
	instanceVariableNames: ''!

!MouseActionIndicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 11:08'!
world: aWorld inner: innerRectangle outer: outerRectangle color: aColor

	| allRects allMorphs |

	allRects _ outerRectangle areasOutside: innerRectangle.
	allMorphs _ allRects collect: [ :each |
		self new bounds: each; color: aColor
	].
	allMorphs do: [ :each |
		each siblings: allMorphs; openInWorld: aWorld
	].
	^allMorphs


! !
MouseEvent subclass: #MouseButtonEvent
	instanceVariableNames: 'whichButton'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:58'!
blueButtonChanged
	"Answer true if the blue mouse button has changed. This is the third mouse button or cmd+click on the Mac."

	^ whichButton anyMask: 1! !

!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:58'!
redButtonChanged
	"Answer true if the red mouse button has changed. This is the first mouse button."

	^ whichButton anyMask: 4! !

!MouseButtonEvent methodsFor: 'accessing' stamp: 'nk 3/11/2004 17:44'!
whichButton
	^whichButton! !

!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:59'!
yellowButtonChanged
	"Answer true if the yellow mouse button has changed. This is the second mouse button or option+click on the Mac."

	^ whichButton anyMask: 2! !


!MouseButtonEvent methodsFor: 'dispatching' stamp: 'ar 9/16/2000 13:05'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #mouseDown ifTrue:[^anObject handleMouseDown: self].
	type == #mouseUp ifTrue:[^anObject handleMouseUp: self].
	^super sentTo: anObject! !


!MouseButtonEvent methodsFor: 'initialize' stamp: 'ar 10/24/2000 16:29'!
type: eventType readFrom: aStream
	super type: eventType readFrom: aStream.
	aStream skip: 1.
	whichButton _ Integer readFrom: aStream.! !


!MouseButtonEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:29'!
storeOn: aStream
	super storeOn: aStream.
	aStream space.
	whichButton storeOn: aStream.! !


!MouseButtonEvent methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 19:00'!
decodeFromStringArray: array 
	"decode the receiver from an array of strings"

	type := array first asSymbol.
	position := CanvasDecoder decodePoint: (array second).
	buttons := CanvasDecoder decodeInteger: (array third).
	whichButton := CanvasDecoder decodeInteger: (array fourth)! !

!MouseButtonEvent methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ar 10/25/2000 23:24'!
encodedAsStringArray
	"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
	^{
		type.
		CanvasEncoder encodePoint: position.
		CanvasEncoder encodeInteger: buttons.
		CanvasEncoder encodeInteger: whichButton.
	}! !


!MouseButtonEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:55'!
setType: evtType position: evtPos which: button buttons: evtButtons hand: evtHand stamp: stamp
	type _ evtType.
	position _ evtPos.
	buttons _ evtButtons.
	source _ evtHand.
	wasHandled _ false.
	whichButton _ button.
	timeStamp _ stamp.! !
Object subclass: #MouseClickState
	instanceVariableNames: 'clickClient clickState firstClickDown firstClickUp firstClickTime clickSelector dblClickSelector dblClickTime dblClickTimeoutSelector dragSelector dragThreshold'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!MouseClickState commentStamp: '<historical>' prior: 0!
MouseClickState is a simple class managing the distinction between clicks, double clicks, and drag operations. It has been factored out of HandMorph due to the many instVars.

Instance variables:
	clickClient 	<Morph>		The client wishing to receive #click:, #dblClick:, or #drag messages
	clickState 	<Symbol>	The internal state of handling the last event (#firstClickDown, #firstClickUp, #firstClickTimedOut)
	firstClickDown 	<MorphicEvent>	The #mouseDown event after which the client wished to receive #click: or similar messages
	firstClickUp 	<MorphicEvent>	The first mouse up event which came in before the double click time out was exceeded (it is sent if there is a timout after the first mouse up event occured)
	firstClickTime 	<Integer>	The millisecond clock value of the first event
	clickSelector 	<Symbol>	The selector to use for sending #click: messages
	dblClickSelector 	<Symbol>	The selector to use for sending #doubleClick: messages
	dblClickTime 	<Integer>	Timout in milliseconds for a double click operation
	dragSelector 	<Symbol>	The selector to use for sending #drag: messages
	dragThreshold 	<Integer>	Threshold used for determining if a #drag: message is sent (pixels!!)
!


!MouseClickState methodsFor: 'as yet unclassified' stamp: 'nk 7/26/2004 09:13'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $[; print: clickState; nextPut: $]
! !


!MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:23'!
click

	clickSelector ifNotNil: [clickClient perform: clickSelector with: firstClickDown]! !

!MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:24'!
doubleClick

	dblClickSelector ifNotNil: [clickClient perform: dblClickSelector with: firstClickDown]! !

!MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 13:09'!
doubleClickTimeout

	dblClickTimeoutSelector ifNotNil: [
		clickClient perform: dblClickTimeoutSelector with: firstClickDown]! !

!MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:27'!
drag: event

	dragSelector ifNotNil: [clickClient perform: dragSelector with: event]! !

!MouseClickState methodsFor: 'event handling' stamp: 'nk 7/26/2004 10:21'!
handleEvent: evt from: aHand
	"Process the given mouse event to detect a click, double-click, or drag.
	Return true if the event should be processed by the sender, false if it shouldn't.
	NOTE: This method heavily relies on getting *all* mouse button events."
	| localEvt timedOut isDrag |
	timedOut _ (evt timeStamp - firstClickTime) > dblClickTime.
	localEvt _ evt transformedBy: (clickClient transformedFrom: aHand owner).
	isDrag _ (localEvt position - firstClickDown position) r > dragThreshold.
	clickState == #firstClickDown ifTrue: [
		"Careful here - if we had a slow cycle we may have a timedOut mouseUp event"
		(timedOut and:[localEvt isMouseUp not]) ifTrue:[
			"timeout before #mouseUp -> keep waiting for drag if requested"
			clickState _ #firstClickTimedOut.
			dragSelector ifNil:[
				aHand resetClickState.
				self doubleClickTimeout; click "***"].
			^true].
		localEvt isMouseUp ifTrue:[

			(timedOut or:[dblClickSelector isNil]) ifTrue:[
				self click.
				aHand resetClickState.
				^true].
			"Otherwise transfer to #firstClickUp"
			firstClickUp _ evt copy.
			clickState _ #firstClickUp.
			"If timedOut or the client's not interested in dbl clicks get outta here"
			self click.
			aHand handleEvent: firstClickUp.
			^false].
		isDrag ifTrue:["drag start"
			self doubleClickTimeout. "***"
			aHand resetClickState.
			dragSelector "If no drag selector send #click instead"
				ifNil: [self click]
				ifNotNil: [self drag: firstClickDown].
			^true].
		^false].

	clickState == #firstClickTimedOut ifTrue:[
		localEvt isMouseUp ifTrue:["neither drag nor double click"
			aHand resetClickState.
			self doubleClickTimeout; click. "***"
			^true].
		isDrag ifTrue:["drag start"
			aHand resetClickState.
			self doubleClickTimeout; drag: firstClickDown. "***"
			^true].
		^false].

	clickState = #firstClickUp ifTrue:[
		(timedOut) ifTrue:[
			"timed out after mouseUp - signal timeout and pass the event"
			aHand resetClickState.
			self doubleClickTimeout. "***"
			^true].
		localEvt isMouseDown ifTrue:["double click"
			clickState _ #secondClickDown.
			^false]].

	clickState == #secondClickDown ifTrue: [
		timedOut ifTrue:[
			"timed out after second mouseDown - pass event after signaling timeout"
			aHand resetClickState.
			self doubleClickTimeout. "***"
			^true].
		isDrag ifTrue: ["drag start"
			self doubleClickTimeout. "***"
			aHand resetClickState.
			dragSelector "If no drag selector send #click instead"
				ifNil: [self click]
				ifNotNil: [self drag: firstClickDown].
			^true].
		localEvt isMouseUp ifTrue: ["double click"
			aHand resetClickState.
			self doubleClick.
			^false]
	].

	^true
! !


!MouseClickState methodsFor: 'initialize' stamp: 'jcg 9/21/2001 13:08'!
client: aMorph click: aClickSelector dblClick: aDblClickSelector dblClickTime: timeOut dblClickTimeout: aDblClickTimeoutSelector drag: aDragSelector threshold: aNumber event: firstClickEvent
	clickClient _ aMorph.
	clickSelector _ aClickSelector.
	dblClickSelector _ aDblClickSelector.
	dblClickTime _ timeOut.
	dblClickTimeoutSelector _ aDblClickTimeoutSelector.
	dragSelector _ aDragSelector.
	dragThreshold _ aNumber.
	firstClickDown _ firstClickEvent.
	firstClickTime _ firstClickEvent timeStamp.
	clickState _ #firstClickDown.! !
UserInputEvent subclass: #MouseEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MouseEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'!
cursorPoint
	"Answer the location of the cursor's hotspot when this event occured."

	^ position! !


!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'!
anyButtonPressed
	"Answer true if any mouse button is being pressed."

	^ buttons anyMask: self class anyButton! !

!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'!
blueButtonPressed
	"Answer true if the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac."

	^ buttons anyMask: self class blueButton! !

!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'!
redButtonPressed
	"Answer true if the red mouse button is being pressed. This is the first mouse button."

	^ buttons anyMask: self class redButton! !

!MouseEvent methodsFor: 'button state' stamp: 'ar 9/15/2000 22:51'!
targetPoint
	"Answer the location of the cursor's hotspot, adjusted by the offset
	of the last mouseDown relative to the recipient morph."

	^ position - source targetOffset! !

!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'!
yellowButtonPressed
	"Answer true if the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac."

	^ buttons anyMask: self class yellowButton! !


!MouseEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:50'!
= aMorphicEvent
	super = aMorphicEvent ifFalse:[^false].
	position = aMorphicEvent position ifFalse: [^ false].
	buttons = aMorphicEvent buttons ifFalse: [^ false].
	^ true
! !

!MouseEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:47'!
hash
	^ position hash + buttons hash! !


!MouseEvent methodsFor: 'converting' stamp: 'ar 10/10/2000 21:17'!
asMouseEnter
	^self clone setType: #mouseEnter! !

!MouseEvent methodsFor: 'converting' stamp: 'ar 10/10/2000 21:17'!
asMouseLeave
	^self clone setType: #mouseLeave! !

!MouseEvent methodsFor: 'converting' stamp: 'ar 10/6/2000 18:59'!
asMouseMove
	"Convert the receiver into a mouse move"
	^MouseMoveEvent new setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: Time millisecondClockValue.! !

!MouseEvent methodsFor: 'converting' stamp: 'ar 9/25/2000 14:29'!
asMouseOver
	"Convert the receiver into a mouse over event"
	^MouseEvent new setType: #mouseOver position: position buttons: buttons hand: source! !


!MouseEvent methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:15'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #mouseOver ifTrue:[^anObject handleMouseOver: self].
	type == #mouseEnter ifTrue:[^anObject handleMouseEnter: self].
	type == #mouseLeave ifTrue:[^anObject handleMouseLeave: self].
	^super sentTo: anObject.! !


!MouseEvent methodsFor: 'initialize' stamp: 'ar 10/25/2000 22:08'!
type: eventType readFrom: aStream
	| x y |
	type _ eventType.
	timeStamp _ Integer readFrom: aStream.
	aStream skip: 1.
	x _ Integer readFrom: aStream.
	aStream skip: 1.
	y _ Integer readFrom: aStream.
	aStream skip: 1.
	buttons _ Integer readFrom: aStream.
	position _ x@y.
! !


!MouseEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 22:01'!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: self cursorPoint printString; space.
	aStream nextPutAll: type; space.
	aStream nextPutAll: self modifierString.
	aStream nextPutAll: self buttonString.
	aStream nextPutAll: timeStamp printString.
	aStream nextPut: $].! !

!MouseEvent methodsFor: 'printing' stamp: 'ar 10/25/2000 22:09'!
storeOn: aStream

	aStream nextPutAll: type.
	aStream space.
	self timeStamp storeOn: aStream.
	aStream space.
	position x storeOn: aStream.
	aStream space.
	position y storeOn: aStream.
	aStream space.
	buttons storeOn: aStream.! !


!MouseEvent methodsFor: 'testing' stamp: 'ar 10/5/2000 19:43'!
isDraggingEvent
	source ifNil:[^false].
	source hasSubmorphs ifTrue:[^true].
	self anyButtonPressed ifTrue:[^true].
	^false! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:30'!
isMouse
	^true! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseDown
	^self type == #mouseDown! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseEnter
	^self type == #mouseEnter! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseLeave
	^self type == #mouseLeave! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseMove
	^self type == #mouseMove! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseUp
	^self type == #mouseUp! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:29'!
isMove
	^false! !


!MouseEvent methodsFor: 'private' stamp: 'ar 10/10/2000 21:15'!
setType: aSymbol
	"For quick conversion between event types"
	type _ aSymbol.! !

!MouseEvent methodsFor: 'private' stamp: 'ar 9/15/2000 22:53'!
setType: evtType position: evtPos buttons: evtButtons hand: evtHand
	type _ evtType.
	position _ evtPos.
	buttons _ evtButtons.
	source _ evtHand.
	wasHandled _ false.! !

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

MouseEvent class
	instanceVariableNames: ''!

!MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'!
anyButton
	^ 7! !

!MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'!
blueButton
	^ 1! !

!MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'!
redButton
	^ 4! !

!MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'!
yellowButton
	^ 2! !
Controller subclass: #MouseMenuController
	instanceVariableNames: 'redButtonMenu redButtonMessages'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Kernel-Remnants'!
!MouseMenuController commentStamp: '<historical>' prior: 0!
I am a Controller that modifies the scheduling of user activities so that the three mouse buttons can be used to make selections or display menus. The menu items are unary messages to the value of sending my instance the message menuMessageReceiver.!


!MouseMenuController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:28'!
controlActivity
	"Refer to the comment in Controller|controlActivity."
	| cursorPoint |
	cursorPoint _ sensor cursorPoint.
	super controlActivity.
	(cursorPoint = sensor cursorPoint and: [self viewHasCursor])
		ifTrue: 
			[sensor redButtonPressed ifTrue: [^ self redButtonActivity].
			sensor yellowButtonPressed ifTrue: [^ self yellowButtonActivity].
			sensor blueButtonPressed ifTrue: [^ self blueButtonActivity]]! !

!MouseMenuController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 11:24'!
isControlActive 
	"In contrast to class Controller, only blue button but not yellow button
	events will end the receiver's control loop."

	^ self viewHasCursor and: [sensor blueButtonPressed not]! !


!MouseMenuController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 15:54'!
release
	super release.
	redButtonMenu release! !

!MouseMenuController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 15:54'!
reset
	"Eliminate references to all mouse button menus."

	redButtonMenu _ nil.
	redButtonMessages _ nil! !


!MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 15:01'!
blueButtonActivity
	"This normally opens the window menu. It is a no-op here
	as only the StandardSystemController deals with that kind
	of menus."! !

!MouseMenuController methodsFor: 'menu messages'!
performMenuMessage: aSelector
	"Perform a menu command by sending self the message aSelector.
	 Default does nothing special."

	^self perform: aSelector! !

!MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 14:56'!
redButtonActivity
	"Determine which item in the red button pop-up menu is selected. If one 
	is selected, then send the corresponding message to the object designated 
	as the menu message receiver."

	| index |
	redButtonMenu ~~ nil
		ifTrue: 
			[index _ redButtonMenu startUp.
			index ~= 0 
				ifTrue: [self perform: (redButtonMessages at: index)]]
		ifFalse: [super controlActivity]! !

!MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 14:59'!
yellowButtonActivity
	"This normally opens a popup menu. Determine the selected
	item and, if one is selected, then send the corresponding message
	to either the model or the receiver."

	^ self pluggableYellowButtonActivity: sensor leftShiftDown! !


!MouseMenuController methodsFor: 'menu setup'!
redButtonMenu: aSystemMenu redButtonMessages: anArray 
	"Initialize the pop-up menu that should appear when the user presses the 
	red mouse button to be aSystemMenu. The corresponding messages that 
	should be sent are listed in the array, anArray."

	redButtonMenu release.
	redButtonMenu _ aSystemMenu.
	redButtonMessages _ anArray! !


!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:36'!
getPluggableYellowButtonMenu: shiftKeyState
	^ view getMenu: shiftKeyState! !

!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sw 2/17/2002 04:35'!
pluggableYellowButtonActivity: shiftKeyState
	"Invoke the model's popup menu."

	| menu |
	(menu _ self getPluggableYellowButtonMenu: shiftKeyState)
		ifNil:
			[sensor waitNoButton]
		ifNotNil:
			[self terminateAndInitializeAround:
				[menu invokeOn: model orSendTo: self]]! !

!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sw 3/22/2001 12:03'!
shiftedTextPaneMenuRequest
	"The user chose the more... branch from the text-pane menu."

	^ self pluggableYellowButtonActivity: true! !

!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:37'!
shiftedYellowButtonActivity
	"Invoke the model's special popup menu."

	^ self pluggableYellowButtonActivity: true! !

!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:37'!
unshiftedYellowButtonActivity
	"Invoke the model's normal popup menu."

	^ self pluggableYellowButtonActivity: false! !
MouseEvent subclass: #MouseMoveEvent
	instanceVariableNames: 'startPoint trail'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'!
endPoint
	"Return the point where the movement ended."
	^position! !

!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:25'!
startPoint
	"Return the point where the movement started."
	^startPoint! !

!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 10/24/2000 16:33'!
trail
	"Return any immediate points that have been assembled along the move"
	^trail ifNil:[#()]! !


!MouseMoveEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:49'!
= aMorphicEvent
	super = aMorphicEvent ifFalse:[^false].
	position = aMorphicEvent position ifFalse: [^ false].
	startPoint = aMorphicEvent startPoint ifFalse: [^ false].
	buttons = aMorphicEvent buttons ifFalse: [^ false].
	^ true
! !

!MouseMoveEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:49'!
hash
	^ position hash + startPoint hash + buttons hash! !


!MouseMoveEvent methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:15'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #mouseMove ifTrue:[^anObject handleMouseMove: self].
	^super sentTo: anObject.
! !


!MouseMoveEvent methodsFor: 'initialize' stamp: 'ar 10/24/2000 16:31'!
type: eventType readFrom: aStream
	| x y |
	super type: eventType readFrom: aStream.
	aStream skip: 1.
	x _ Integer readFrom: aStream.
	aStream skip: 1.
	y _ Integer readFrom: aStream.
	startPoint _ x@y.! !


!MouseMoveEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 22:00'!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: self startPoint printString; space.
	aStream nextPutAll: self endPoint printString; space.
	aStream nextPutAll: self type; space.
	aStream nextPutAll: self modifierString.
	aStream nextPutAll: self buttonString.
	aStream nextPutAll: timeStamp printString.
	aStream nextPut: $].! !

!MouseMoveEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:30'!
storeOn: aStream
	super storeOn: aStream.
	aStream space.
	self startPoint x storeOn: aStream.
	aStream space.
	self startPoint y storeOn: aStream.
	aStream space.
	"trail storeOn: aStream."! !


!MouseMoveEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:29'!
isMove
	^true! !


!MouseMoveEvent methodsFor: 'transforming' stamp: 'ar 9/15/2000 22:52'!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position _  aMorphicTransform globalPointToLocal: position.
	startPoint _  aMorphicTransform globalPointToLocal: startPoint.! !

!MouseMoveEvent methodsFor: 'transforming' stamp: 'ar 9/15/2000 22:52'!
translateBy: delta
	"add delta to cursorPoint, and return the new event"
	position _ position + delta.
	startPoint _ startPoint + delta.! !


!MouseMoveEvent methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 19:01'!
decodeFromStringArray: array 
	"decode the receiver from an array of strings"

	type := array first asSymbol.
	position := CanvasDecoder decodePoint: (array second).
	buttons := CanvasDecoder decodeInteger: (array third).
	startPoint := CanvasDecoder decodePoint: (array fourth)! !

!MouseMoveEvent methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ar 10/25/2000 23:25'!
encodedAsStringArray
	"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
	^{
		type.
		CanvasEncoder encodePoint: position.
		CanvasEncoder encodeInteger: buttons.
		CanvasEncoder encodePoint: startPoint.
	}! !


!MouseMoveEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:55'!
setType: evtType startPoint: evtStart endPoint: evtEnd trail: evtTrail buttons: evtButtons hand: evtHand stamp: stamp
	type _ evtType.
	startPoint _ evtStart.
	position _ evtEnd.
	trail _ evtTrail.
	buttons _ evtButtons.
	source _ evtHand.
	wasHandled _ false.
	timeStamp _ stamp.! !
Object subclass: #MouseOverHandler
	instanceVariableNames: 'mouseOverMorphs enteredMorphs overMorphs leftMorphs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MouseOverHandler methodsFor: 'event handling' stamp: 'ar 9/28/2000 18:52'!
noticeMouseOver: aMorph event: anEvent
	"Remember that the mouse is currently over some morph"
	(leftMorphs includes: aMorph) 
		ifTrue:[leftMorphs remove: aMorph]
		ifFalse:[enteredMorphs nextPut: aMorph].
	overMorphs nextPut: aMorph.
! !

!MouseOverHandler methodsFor: 'event handling' stamp: 'dgd 2/21/2003 23:00'!
processMouseOver: anEvent 
	"Re-establish the z-order for all morphs wrt the given event"

	| hand localEvt focus evt |
	hand := anEvent hand.
	leftMorphs := mouseOverMorphs asIdentitySet.
	"Assume some coherence for the number of objects in over list"
	overMorphs := WriteStream on: (Array new: leftMorphs size).
	enteredMorphs := WriteStream on: #().
	"Now go looking for eventual mouse overs"
	hand handleEvent: anEvent asMouseOver.
	"Get out early if there's no change"
	(leftMorphs isEmpty and: [enteredMorphs position = 0]) 
		ifTrue: [^leftMorphs := enteredMorphs := overMorphs := nil].
	focus := hand mouseFocus.
	"Send #mouseLeave as appropriate"
	evt := anEvent asMouseLeave.
	"Keep the order of the left morphs by recreating it from the mouseOverMorphs"
	leftMorphs size > 1 
		ifTrue: [leftMorphs := mouseOverMorphs select: [:m | leftMorphs includes: m]].
	leftMorphs do: 
			[:m | 
			(m == focus or: [m hasOwner: focus]) 
				ifTrue: 
					[localEvt := evt transformedBy: (m transformedFrom: hand).
					m handleEvent: localEvt]
				ifFalse: [overMorphs nextPut: m]].
	"Send #mouseEnter as appropriate"
	evt := anEvent asMouseEnter.
	enteredMorphs ifNil: 
			["inform: was called in handleEvent:"

			^leftMorphs := enteredMorphs := overMorphs := nil].
	enteredMorphs := enteredMorphs contents.
	enteredMorphs reverseDo: 
			[:m | 
			(m == focus or: [m hasOwner: focus]) 
				ifTrue: 
					[localEvt := evt transformedBy: (m transformedFrom: hand).
					m handleEvent: localEvt]].
	"And remember the over list"
	overMorphs ifNil: 
			["inform: was called in handleEvent:"

			^leftMorphs := enteredMorphs := overMorphs := nil].
	mouseOverMorphs := overMorphs contents.
	leftMorphs := enteredMorphs := overMorphs := nil! !


!MouseOverHandler methodsFor: 'initialize-release' stamp: 'ar 9/28/2000 17:08'!
initialize
	mouseOverMorphs _ #().! !
MovieClipStartMorph subclass: #MovieClipEndMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Player'!
!MovieClipEndMorph commentStamp: '<historical>' prior: 0!
The idea is that soon we will show the soundtrack extending between the start cue and the end morph.!


!MovieClipEndMorph methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:48'!
movieFileName: movieFileName image: aForm player: aMoviePlayer frameNumber: n

	movieClipFileName := movieFileName.
	self image: aForm frameNumber: n.
	moviePlayerMorph := movieClipPlayer := aMoviePlayer.
	scoreEvent := AmbientEvent new morph: self.
! !


!MovieClipEndMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:42'!
thumbnailHeight

	^ 30! !


!MovieClipEndMorph methodsFor: 'piano rolls' stamp: 'di 10/26/2000 00:25'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	"Ignored -- all display is done by the starting morph -- see superclass"! !

!MovieClipEndMorph methodsFor: 'piano rolls' stamp: 'di 10/11/2000 23:06'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	movieClipPlayer ifNotNil:
		["If being shown as a clip, then tell the clipPlayer to stop showing this clip"
		movieClipPlayer stopRunning]! !

!MovieClipEndMorph methodsFor: 'piano rolls' stamp: 'di 10/22/2000 12:43'!
pauseFrom: scorePlayer

	"Ignored"! !

!MovieClipEndMorph methodsFor: 'piano rolls' stamp: 'di 10/22/2000 12:43'!
resetFrom: scorePlayer

	"Ignored"! !

!MovieClipEndMorph methodsFor: 'piano rolls' stamp: 'di 10/22/2000 12:43'!
resumeFrom: scorePlayer

	"Ignored"! !
MovieFrameSyncMorph subclass: #MovieClipStartMorph
	instanceVariableNames: 'movieClipPlayer movieClipFileName soundTrackFileName soundTrackPlayerReady soundTrackMorph soundTrackTimeScale scoreEvent endMorph clipColor colorMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Player'!
!MovieClipStartMorph commentStamp: '<historical>' prior: 0!
This class and its subclasses act to syncronize movie players with the progress of a MIDI score and further background can be found in the comment for MoviePlayerMorph.

MovieClipStartMorphs are used where you have a movie clip player plex.  You can create such a plex by opening a midi score, spawning a piano roll (by the button of that name), and then choosing 'add movie clip player' from the piano roll menu.  Much simpler, you can open a MoviePlayerMorph as a new morph, and then choose 'make a new movie' from its menu.  This plex then serves as a central editable score for composing movie clips.

To add a new movie clip to the score, open a movie from the fileList (or as a new morph followed by 'open a movie').  Play or otherwise position the clip to the desired starting position, and then tear off a thumbnail and drop it into the score at the desired time.  The starting thumbnail (MovieClipStartMorph) will appear in the score, tied to an endMorph by a colored stripe.  The ending time will be chosen based on the total length of the clip, a default starting clip length (200 frames), and possible interference with other clips that follow it.

To reposition a clip, you can pick up its clipStart with halo black handle, and drop it elsewhere.  The rest of the clip will follow as best it can.  To delete a clip, delete its clipStart.  To change the duration of a clip, play the composition up to some point in that clip, and pause it.  Then use the  controls on the central movie player to move forward or backward to the desired ending frame, and choose 'end clip here' from the player menu.!


!MovieClipStartMorph methodsFor: 'access' stamp: 'di 10/19/2000 14:27'!
endMorph

	^ endMorph! !

!MovieClipStartMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
frameNumber: newFrame

	frameNumber := newFrame! !

!MovieClipStartMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
movieClipPlayer: aMoviePlayerMorph
	"For now, these morphs work both as a sync point in a long movie, and
	as a cue point for a short clip in a longer score.
	To a cue point, this method provides a reference to the clip player."

	movieClipPlayer := aMoviePlayerMorph! !

!MovieClipStartMorph methodsFor: 'access' stamp: 'di 10/25/2000 22:02'!
relatedPlayer
 
	^ movieClipPlayer! !

!MovieClipStartMorph methodsFor: 'access' stamp: 'di 10/19/2000 12:24'!
scoreEvent
	^ scoreEvent! !


!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:46'!
colorMargin
	"How far the clip span color highlight extends outside the starting clip"

	^ 5! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'stephaneducasse 2/4/2006 20:48'!
colorMorph
	colorMorph ifNotNil: [^ colorMorph].

	"Make up a morph to highlight the span of this clip."
	ColorIndex := (ColorIndex ifNil: [0]) + 2 \\ 8 + 1.
	^ colorMorph := Morph newBounds: (0@0 extent: 9@9) color: ((Color wheel: 8) at: ColorIndex)
! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:23'!
soundTrackHeight

	^ 40! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:58'!
soundTrackOnBottom  "a local preference during test"

	^ false! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 12:32'!
thumbnailHeight

	^ 60! !


!MovieClipStartMorph methodsFor: 'dropping/grabbing' stamp: 'stephaneducasse 2/4/2006 20:48'!
justDroppedInto: newOwner event: evt
	| pianoRoll syncMorph |
	"When dropping this morph into a pianoRoll, add a corresponding
	event to the score so that it will always appear when played,
	in addition to possibly triggering other actions"

	(newOwner isKindOf: PianoRollScoreMorph)
	ifTrue:
		[pianoRoll := newOwner.
		pianoRoll movieClipPlayer ifNil:
			["This PianoRoll is not a clip player -- replace me by a SyncMorph"
			syncMorph := MovieFrameSyncMorph new
						image: image
						player: moviePlayerMorph
						frameNumber: frameNumber.
			pianoRoll replaceSubmorph: self by: syncMorph.
			"rewrite to use justDroppedInto:..."
			pianoRoll score removeAmbientEventWithMorph: self;
					addAmbientEvent: (scoreEvent
						morph: syncMorph;
						time: (pianoRoll timeForX: self left)).
			^ self].

		self movieClipPlayer: pianoRoll movieClipPlayer.
		self setTimeInScore: pianoRoll score
					near: (pianoRoll timeForX: self left).
		self endTime > newOwner scorePlayer durationInTicks ifTrue:
			[newOwner scorePlayer updateDuration]]
	ifFalse:
		["Dropped it somewhere else -- delete related morphs"
		endMorph ifNotNil: [endMorph delete].
		soundTrackMorph ifNotNil: [soundTrackMorph delete]].

	super justDroppedInto: newOwner event: evt
! !


!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/22/2000 20:24'!
endTime

	^ endMorph scoreEvent time! !

!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/22/2000 20:27'!
frameAtTick: time
	"Return the frame number corresponding to the given tick time"

	^ frameNumber +
		((time - self startTime) asFloat
			/ (self endTime - self startTime)
			* (endMorph frameNumber - frameNumber)) asInteger! !

!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/22/2000 20:24'!
startTime

	^ scoreEvent time! !


!MovieClipStartMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
image: aForm frameNumber: n

	self image: (aForm magnifyBy: self thumbnailHeight asFloat / aForm height).
	frameNumber := n.! !

!MovieClipStartMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
movieFileName: movieFileName soundTrackFileName: soundFileName
			image: aForm player: aMoviePlayer frameNumber: n
	movieClipFileName := movieFileName.
	soundTrackFileName := soundFileName.
	self image: aForm frameNumber: n.
	moviePlayerMorph := aMoviePlayer.
	soundTrackPlayerReady := moviePlayerMorph scorePlayer copy.
	scoreEvent := AmbientEvent new morph: self.
! !


!MovieClipStartMorph methodsFor: 'piano rolls' stamp: 'dgd 2/22/2003 14:09'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime 
	"This code handles both the start and end morphs."

	| startX endX h delta |
	self startTime > rightTime 
		ifTrue: [^self	"Start time has not come into view."].
	self endTime < leftTime ifTrue: [^self	"End time has passed out of view."].
	startX := pianoRoll xForTime: self startTime.
	endX := pianoRoll xForTime: self endTime.
	h := self colorMargin.	"Height of highlight bar over thumbnails."
	morphList add: (self align: self bottomLeft
				with: startX @ (pianoRoll bottom - pianoRoll borderWidth - h)).
	morphList 
		add: (endMorph align: endMorph bounds rightCenter with: endX @ self center y).
	morphList add: (self colorMorph 
				bounds: (self topLeft - (0 @ h) corner: endMorph right @ (self bottom + h))).
	(soundTrackMorph isNil and: [moviePlayerMorph scorePlayer isNil]) 
		ifFalse: 
			["Wants a sound track"

			(soundTrackMorph isNil or: [pianoRoll timeScale ~= soundTrackTimeScale]) 
				ifTrue: 
					["Needs a new sound track"

					self buildSoundTrackMorphFor: pianoRoll].
			morphList add: (soundTrackMorph align: soundTrackMorph bottomLeft
						with: colorMorph topLeft).
			self soundTrackOnBottom 
				ifTrue: 
					[soundTrackMorph align: soundTrackMorph bottomLeft with: self bottomLeft.
					delta := 0 @ self soundTrackHeight.
					self position: self position - delta.
					endMorph position: endMorph position - delta.
					colorMorph position: colorMorph position - delta]]! !

!MovieClipStartMorph methodsFor: 'piano rolls' stamp: 'di 10/26/2000 00:09'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	"If being shown as a clip, then tell the clipPlayer to start showing this clip"
	movieClipPlayer setCueMorph: self.
	movieClipPlayer openFileNamed: movieClipFileName
			withScorePlayer: soundTrackPlayerReady copy
			andPlayFrom: frameNumber.
! !

!MovieClipStartMorph methodsFor: 'piano rolls' stamp: 'dgd 2/22/2003 14:09'!
resetFrom: scorePlayer 
	(movieClipPlayer cueMorph isNil 
		or: [self startTime < movieClipPlayer cueMorph startTime]) 
			ifTrue: 
				[movieClipPlayer
					openFileNamed: movieClipFileName
						withScorePlayer: soundTrackPlayerReady copy
						andPlayFrom: frameNumber;
					setCueMorph: self;
					step;
					pauseFrom: scorePlayer]! !

!MovieClipStartMorph methodsFor: 'piano rolls' stamp: 'stephaneducasse 2/4/2006 20:48'!
resumeFrom: scorePlayer

	| time |
	"New movie clip style of use."
	time := scorePlayer ticksSinceStart.
	time < self startTime ifTrue: [^ self].  "It's not my time yet"
	time > self endTime ifTrue: [^ self].  "It's past my time"

	"The player is starting in the midst of this clip."
	movieClipPlayer openFileNamed: movieClipFileName
				withScorePlayer: soundTrackPlayerReady copy
				andPlayFrom: (self frameAtTick: time);
		setCueMorph: self.
! !


!MovieClipStartMorph methodsFor: 'submorphs-add/remove' stamp: 'di 10/23/2000 10:24'!
delete
	(owner isKindOf: PianoRollScoreMorph) ifTrue:
		[owner score removeAmbientEventWithMorph: self.
		endMorph ifNotNil: [owner score removeAmbientEventWithMorph: endMorph]].
	endMorph ifNotNil: [endMorph delete].
	soundTrackMorph ifNotNil: [soundTrackMorph delete].
	colorMorph ifNotNil: [colorMorph delete].
	super delete.
! !


!MovieClipStartMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
buildSoundTrackMorphFor: pianoRoll
	| stopTime soundTrackForm startTime samplesPerTick samplesPerMs |
	soundTrackTimeScale := pianoRoll timeScale.  "pixels per tick"
	samplesPerTick := moviePlayerMorph scorePlayer originalSamplingRate   "Samples per sec"
						* pianoRoll scorePlayer secsPerTick.  "secs per tick"
	samplesPerMs := moviePlayerMorph scorePlayer originalSamplingRate / 1000.0.
	startTime := frameNumber * moviePlayerMorph msPerFrame.  "ms"
	stopTime := endMorph frameNumber * moviePlayerMorph msPerFrame.
	soundTrackForm := moviePlayerMorph scorePlayer
		volumeForm: self soundTrackHeight
		from: (startTime * samplesPerMs) rounded
		to: (stopTime * samplesPerMs) rounded
		nSamplesPerPixel: samplesPerTick / soundTrackTimeScale.
	^ soundTrackMorph := ImageMorph new image: soundTrackForm! !

!MovieClipStartMorph methodsFor: 'private' stamp: 'di 10/29/2000 08:02'!
setEndFrameNumber: frame

	self setEndFrameNumber: frame tickTime: nil! !

!MovieClipStartMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
setEndFrameNumber: frameOrNil tickTime: timeOrNil
	"May be called with either time or frame being nil,
	in which case the other will br computed."

	| pianoRoll frame time |
	pianoRoll := movieClipPlayer pianoRoll.
	frame := frameOrNil ifNil:
		[frameNumber + 
			((timeOrNil - self startTime)
			* (pianoRoll scorePlayer secsPerTick*1000.0)
			/ moviePlayerMorph msPerFrame) asInteger - 1].
	time := timeOrNil ifNil:
		[self startTime +   "in ticks"
			(pianoRoll scorePlayer ticksForMSecs:
			(frameOrNil - frameNumber) * moviePlayerMorph msPerFrame)].
	endMorph ifNil:
		[endMorph := MovieClipEndMorph new
			movieFileName: movieClipFileName
			image: (moviePlayerMorph pageFormForFrame: frame)
			player: movieClipPlayer
			frameNumber: frame]
		ifNotNil:
		[endMorph image: (moviePlayerMorph pageFormForFrame: frame)
			frameNumber: frame].

	endMorph scoreEvent time: time.
	pianoRoll score removeAmbientEventWithMorph: endMorph;
		addAmbientEvent: endMorph scoreEvent.
	soundTrackMorph := nil.  "Force it to be recomputed."
	pianoRoll rebuildFromScore
! !

!MovieClipStartMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
setTimeInScore: score near: dropTime
	"Find a time to place this clip that does not overlap other clips.
	So, if I start in the middle of another clip, move me to the end of it,
	and if I start very soon after another clip, put me right at the end.
	Then, if my end goes beyond the start of another clip, shorten me
	so I end right before that clip."

	| startTime endTime delta endFrame |
	startTime := dropTime.
	endMorph ifNil: [endFrame := moviePlayerMorph frameCount]
			ifNotNil: [endFrame := endMorph frameNumber].
	endTime := startTime   "in ticks"
		+ (movieClipPlayer pianoRoll scorePlayer ticksForMSecs:
			(endFrame - frameNumber)
			* moviePlayerMorph msPerFrame).
	score eventMorphsDo:
		[:m | (m ~~ self and: [m isMemberOf: self class]) ifTrue:
				[((startTime between: m startTime and: m endTime)
					or: [startTime between: m endTime and: m endTime+50])
					ifTrue: ["If I start in the middle of another clip, or a little
							past its end, move me exactly to the end of it"
							delta := (m endTime + 1) - startTime.
							startTime := startTime + delta.
							endTime := endTime + delta].
				(endTime between: m startTime and: m endTime)
					ifTrue: ["If my end goes overlaps another clip, shorten me so I fit."
							endTime := m startTime - 1].
				]].
	scoreEvent time: startTime.
	score removeAmbientEventWithMorph: self;
			addAmbientEvent: scoreEvent.
	self setEndFrameNumber: endFrame tickTime: endTime.
! !
ImageMorph subclass: #MovieFrameSyncMorph
	instanceVariableNames: 'moviePlayerMorph frameNumber'
	classVariableNames: 'ColorIndex'
	poolDictionaries: ''
	category: 'Movies-Player'!
!MovieFrameSyncMorph commentStamp: '<historical>' prior: 0!
This class and its subclasses act to syncronize movie players with the progress of a MIDI score and further background can be found in the comment for MoviePlayerMorph.

There are two main forms of synchroniztion.

MovieFrameSyncMorphs are used where you have a MIDI score open with a piano roll, and a separate MoviePlayer Morph.  A MovieFrameSyncMorph can be torn off from the MoviePlayer with a shift-drag gesture or menu command, and can then be dropped into a MIDI score.  They are used to start a movie player at a given place in the score, and then to stretch or compress the movie frame rate so that certain frames are synchronized with the corresponding points in the score.

MovieClipStartMorphs (q.v.) and MovieClipEndMorphs are used for the other kind of synchronization, namely where you wish to assemble a number of movie clips in a sequence.!


!MovieFrameSyncMorph methodsFor: 'access' stamp: 'di 8/6/1998 14:13'!
frameNumber
	^ frameNumber! !

!MovieFrameSyncMorph methodsFor: 'access' stamp: 'di 10/11/2000 21:39'!
moviePlayerMorph
 
	^ moviePlayerMorph! !

!MovieFrameSyncMorph methodsFor: 'access' stamp: 'di 10/25/2000 22:02'!
relatedPlayer
 
	^ moviePlayerMorph! !


!MovieFrameSyncMorph methodsFor: 'dropping/grabbing' stamp: 'stephaneducasse 2/4/2006 20:48'!
justDroppedInto: newOwner event: evt 
	| pianoRoll |
	"When dropping this morph into a pianoRoll, add a corresponding
	event to the score so that it will always appear when played,
	in addition to possibly triggering other actions"

	(self isMemberOf: MovieFrameSyncMorph) ifFalse:
		[^ super justDroppedInto: newOwner event: evt].

	(newOwner isKindOf: PianoRollScoreMorph)
	ifTrue:
		["Legacy code for existing sync morphs"
		pianoRoll := newOwner.
		pianoRoll score
			removeAmbientEventWithMorph: self;
			addAmbientEvent: (AmbientEvent new
						morph: self;
						time: (pianoRoll timeForX: self left))].

	super justDroppedInto: newOwner event: evt
! !


!MovieFrameSyncMorph methodsFor: 'events' stamp: 'stephaneducasse 2/4/2006 20:48'!
nextSyncEventAfter: index inTrack: track
	| evt |
	index to: track size do:
		[:i | evt := track at: i.
		((evt morph isMemberOf: self class)
			and: [evt morph moviePlayerMorph == moviePlayerMorph])
			ifTrue: [^ evt]].
	^ nil! !


!MovieFrameSyncMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
image: aForm player: aMoviePlayer frameNumber: n
	self image: aForm.
	moviePlayerMorph := aMoviePlayer.
	frameNumber := n! !


!MovieFrameSyncMorph methodsFor: 'piano rolls' stamp: 'stephaneducasse 2/4/2006 20:48'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	| leftX |
	t > rightTime ifTrue: [^ self  "Start time has not come into view."].  
	leftX := pianoRoll xForTime: t.
	(leftX + self width) < pianoRoll left ifTrue: [^ self  "End time has passed out of view."].
	morphList add: 
		(self align: self bottomLeft
			with: leftX @ (pianoRoll bottom - pianoRoll borderWidth)).
! !

!MovieFrameSyncMorph methodsFor: 'piano rolls' stamp: 'dgd 2/21/2003 22:58'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick 
	"Set frame number and milliseconds since start in case of drift"

	| next |
	moviePlayerMorph frameNumber: frameNumber
		msSinceStart: scorePlayer millisecondsSinceStart.

	"If there is a later sync point, set the appropriate frame rate until then."
	(next := self nextSyncEventAfter: index inTrack: track) isNil 
		ifFalse: 
			[moviePlayerMorph msPerFrame: (next time - ticks) * secsPerTick * 1000.0 
						/ (next morph frameNumber - self frameNumber)]! !

!MovieFrameSyncMorph methodsFor: 'piano rolls' stamp: 'RAA 12/11/2000 22:58'!
justDroppedIntoPianoRoll: pianoRoll event: evt

	"since these morphs handle their own dropping, ignore"! !

!MovieFrameSyncMorph methodsFor: 'piano rolls' stamp: 'di 10/25/2000 22:03'!
pauseFrom: scorePlayer

	self relatedPlayer pauseFrom: scorePlayer! !

!MovieFrameSyncMorph methodsFor: 'piano rolls' stamp: 'di 10/25/2000 22:02'!
resetFrom: scorePlayer

	self relatedPlayer resetFrom: scorePlayer! !

!MovieFrameSyncMorph methodsFor: 'piano rolls' stamp: 'di 10/25/2000 22:03'!
resumeFrom: scorePlayer

	self relatedPlayer resumeFrom: scorePlayer! !
Morph subclass: #MovieMorph
	instanceVariableNames: 'playMode msecsPerFrame rotationDegrees scalePoint frameList currentFrameIndex dwellCount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!MovieMorph methodsFor: 'accessing'!
form

	^ self currentFrame form
! !

!MovieMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:05'!
scalePoint

	^ scalePoint
! !

!MovieMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:05'!
scalePoint: newScalePoint

	| frame |
	newScalePoint ~= scalePoint ifTrue: [
		self changed.
		scalePoint _ newScalePoint.
		frame _ self currentFrame.
		frame ifNotNil: [frame scalePoint: newScalePoint].
		self layoutChanged.
		self changed].
! !


!MovieMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 18:47'!
drawOn: aCanvas 
	| frame |
	frame := self currentFrame.
	frame notNil 
		ifTrue: [^frame drawOn: aCanvas]
		ifFalse: [^super drawOn: aCanvas]! !


!MovieMorph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 18:48'!
containsPoint: p 
	| frame |
	frame := self currentFrame.
	^ (frame notNil and: [playMode = #stop]) 
		ifTrue: [frame containsPoint: p]
		ifFalse: [super containsPoint: p]! !


!MovieMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 1
		g: 0
		b: 1! !

!MovieMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:47'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	playMode _ #stop.
	"#stop, #playOnce, or #loop"
	msecsPerFrame _ 200.
	rotationDegrees _ 0.
	scalePoint _ 1.0 @ 1.0.
	frameList _ EmptyArray.
	currentFrameIndex _ 1.
	dwellCount _ 0! !


!MovieMorph methodsFor: 'menu' stamp: 'nk 6/12/2004 09:59'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	| movies subMenu |
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	subMenu _ MenuMorph new defaultTarget: self.
	frameList size > 1 ifTrue: [
		subMenu add: 'repaint' translated action: #editDrawing.
		subMenu add: 'set rotation center' translated action: #setRotationCenter.
		subMenu add: 'play once' translated action: #playOnce.
		subMenu add: 'play loop' translated action: #playLoop.
		subMenu add: 'stop playing' translated action: #stopPlaying.
		currentFrameIndex > 1 ifTrue: [
			subMenu add: 'previous frame' translated action: #previousFrame].
		currentFrameIndex < frameList size ifTrue: [
			subMenu add: 'next frame' translated action: #nextFrame]].
	subMenu add: 'extract this frame' translated action: #extractFrame:.
	movies _
		(self world rootMorphsAt: aHandMorph targetOffset)
			select: [:m | (m isKindOf: MovieMorph) or:
						[m isSketchMorph]].
	(movies size > 1) ifTrue:
		[subMenu add: 'insert into movie' translated action: #insertIntoMovie:].
	aCustomMenu add: 'movie...' translated subMenu: subMenu
! !

!MovieMorph methodsFor: 'menu'!
advanceFrame

	currentFrameIndex < frameList size
		ifTrue: [self setFrame: currentFrameIndex + 1]
		ifFalse: [self setFrame: 1].
! !

!MovieMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:47'!
editDrawing
	| frame |
	frame := self currentFrame.
	frame notNil 
		ifTrue: [frame editDrawingIn: self pasteUpMorph forBackground: false]! !

!MovieMorph methodsFor: 'menu'!
extractFrame: evt

	| f |
	f _ self currentFrame.
	f ifNil: [^ self].
	frameList _ frameList copyWithout: f.
	frameList isEmpty
		ifTrue: [self position: f position]
		ifFalse: [self setFrame: currentFrameIndex].
	evt hand attachMorph: f.
! !

!MovieMorph methodsFor: 'menu' stamp: 'nk 6/12/2004 09:59'!
insertIntoMovie: evt

	| movies aTarget |
	movies _
		(self world rootMorphsAt: evt hand targetOffset)
			select: [:m | ((m isKindOf: MovieMorph) or:
						 [m isSketchMorph]) and: [m ~= self]].
	movies isEmpty ifTrue: [^ self].
	aTarget _ movies first.
	(aTarget isSketchMorph) ifTrue:
		[aTarget _ aTarget replaceSelfWithMovie].
	movies first insertFrames: frameList.
	self delete.
! !

!MovieMorph methodsFor: 'menu'!
nextFrame

	currentFrameIndex < frameList size
		ifTrue: [self setFrame: currentFrameIndex + 1].
! !

!MovieMorph methodsFor: 'menu'!
playLoop

	playMode _ #loop.
! !

!MovieMorph methodsFor: 'menu'!
playOnce

	self setFrame: 1.
	playMode _ #playOnce.
! !

!MovieMorph methodsFor: 'menu'!
previousFrame

	currentFrameIndex > 1
		ifTrue: [self setFrame: currentFrameIndex - 1].
! !

!MovieMorph methodsFor: 'menu'!
stopPlaying

	playMode _ #stop.
	self setFrame: 1.
! !


!MovieMorph methodsFor: 'rotate scale and flex'!
rotationDegrees

	^ rotationDegrees
! !


!MovieMorph methodsFor: 'stepping and presenter'!
step

	playMode = #stop ifTrue: [^ self].

	dwellCount > 0 ifTrue: [
		dwellCount _ dwellCount - 1.
		^ self].

	currentFrameIndex < frameList size
		ifTrue: [^ self setFrame: currentFrameIndex + 1].

	playMode = #loop
		ifTrue: [self setFrame: 1]
		ifFalse: [playMode _ #stop].
! !


!MovieMorph methodsFor: 'testing'!
stepTime

	^ msecsPerFrame
! !


!MovieMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 08:03'!
currentFrame
	frameList isEmpty ifTrue: [^nil].
     currentFrameIndex := currentFrameIndex min: (frameList size).
     currentFrameIndex := currentFrameIndex max: 1.
	^frameList at: currentFrameIndex! !

!MovieMorph methodsFor: 'private'!
insertFrames: newFrames
	"Insert the given collection of frames into this movie just after the currentrame."

	frameList isEmpty ifTrue: [
		frameList _ newFrames asArray copy.
		self setFrame: 1.
		^ self].

	frameList _
		frameList
			copyReplaceFrom: currentFrameIndex + 1  "insert before"
			to: currentFrameIndex
			with: newFrames.
! !

!MovieMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 08:08'!
setFrame: newFrameIndex 
	| oldFrame p newFrame |
	oldFrame := self currentFrame.
	oldFrame ifNil: [^self].
	self changed.
	p := oldFrame referencePosition.
	currentFrameIndex := newFrameIndex.
     currentFrameIndex :=  currentFrameIndex min: (frameList size). 
	currentFrameIndex := currentFrameIndex max: 1.
	newFrame := frameList at: currentFrameIndex.
	newFrame referencePosition: p.
	oldFrame delete.
	self addMorph: newFrame.
	dwellCount := newFrame framesToDwell.
	self layoutChanged.
	self changed! !
BookMorph subclass: #MoviePlayerMorph
	instanceVariableNames: 'movieFileName movieFile frameSize frameDepth frameNumber frameCount playDirection msSinceStart msAtStart msAtLastSync frameAtLastSync msPerFrame frameBufferIfScaled soundTrackFileName scorePlayer soundTrackForm soundTrackMorph pianoRoll cueMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Player'!
!MoviePlayerMorph commentStamp: '<historical>' prior: 0!
MoviePlayerMorph plays images from a file using async io.  The file format is simple but non-standard (see below).

The heart of the play logic is in the step method.  Note that play is driven by a simulated time since start.  For a movie with a sound score, this is the millisecondsSinceStart of the score player, whereas a movie by itself gets this from the millisecondClock minus msAtStart.

Movie players are designed to be used in three ways
	1.  Select a movie in the file list, 'open as movie', and play it.
	2.  As in (1), but drop thumbnails for various frames into a
		MIDI piano roll to synchronize video with music.
	3.  Open a MoviePlayerMorph as a 'new morph', and choose
		'make a new movie' from the menu.

In (1) and (2), a shift-drag is used to 'tear off' a thumbnail reference morph to the currently visible frame of this clips.  The thumbnail can then be dropped in a MIDI score player to either syncronize that frame with what point in the music, or to cause that clip to being playing in the shared player of a SqueakMovie plex.

When making a new movie, an empty score and piano roll are linked to the movie player, as a SqueakMovie plex. You can then open another movie as a clip, and drop a thumbnail morph into the score to start that clip playing at that frame in the shared player.  If you pause while playing that clip, you can manually play the clip forward and backward in the current clip.  if you stop at a given frame, you can choose 'end clip here' from the shared player menu to shorten or lengthen the clip.

Clips can be moved by picking up the starting thumbnail (use halo black handle), and dropping them elsewhere.  If you try to place one clip in the middle of another, it will slide to the end.  If you position one clip close to the end of another, it will sidle up to make them contiguous.

If you wish a soundtrack to be included with a clip, make sure it has been opened in the source clip player before tearing off the starting thumbnail.

About the .movie file format...
The following code was used to convert 27 files into a movie.  They were named
	'BalloonDrop10fps003.bmp' through 'BalloonDrop10fps081.bmp'
incrementing by 003.  Each was known to be a 320x240 image in 32-bit BMP format.
Note the 27 in the 5th line is the number of frames, = (3 to: 81 by: 3) size.

	| ps zps f32 out ff |
	out _ FileStream newFileNamed: 'BalloonDrop10fps.movie'.
	out binary.
	ff _ Form extent: 320@240 depth: 16.
	#(22 320 240 16 27 100000) , (7 to: 32)
		do: [:i | out nextInt32Put: i].
		
	3 to: 81 by: 3 do:
		[:i | ps _ i printString. zps _ ps padded: #left to: 3 with: $0.
		f32 _ Form fromFileNamed:
			'BalloonDrop10fps' , zps , '.bmp'.
		f32 displayOn: ff at: 0@0.  "Convert down to 16 bits"
		ff display; writeOnMovie: out].
	out close.
!


!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/26/2000 00:18'!
cueMorph
	^ cueMorph! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/4/2000 17:19'!
fileName
	^ movieFileName! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/22/2000 10:54'!
frameCount

	^ frameCount! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
frameNumber: n

	frameNumber := n! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
frameNumber: n msSinceStart: ms
	"Set the current frame number, and save the scorePlayer's simulated time for synchronization."

	frameAtLastSync := n.
	msAtLastSync := ms.
! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/19/2000 16:31'!
msPerFrame
	^ msPerFrame! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
msPerFrame: n
	"Set a new frame rate, base on, eg, score synchronization info."

	msPerFrame := n.
! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
pageFormForFrame: frameNo

	| f form oldFrame |
oldFrame := frameNumber.
self goToPage: frameNo.
form := currentPage image deepCopy.
self goToPage: oldFrame.
true ifTrue: [^ form].

	f := FileStream readOnlyFileNamed: movieFileName.
	form := Form extent: frameSize depth: frameDepth.

	"For some weird reason, the next line does not work..."
	f position: (self filePosForFrameNo: frameNo).
	"... but this line was found empirically to work instead."
	f position: (128 + ((frameNo-1)*(form bits size*4+4)) + 4).

	f nextInto: form bits.
	f close.
	^ form! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/15/2000 19:15'!
relativePosition

	^ frameNumber asFloat / frameCount! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/11/2000 12:13'!
scorePlayer

	^ scorePlayer! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
scorePlayer: aScorePlayer

	scorePlayer := aScorePlayer! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
setCueMorph: aMorph
	cueMorph := aMorph
! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/13/2000 11:51'!
soundTrackFileName
	^ soundTrackFileName! !


!MoviePlayerMorph methodsFor: 'controls and layout' stamp: 'stephaneducasse 2/4/2006 20:48'!
showHideSoundTrack

	soundTrackForm ifNotNil:
		[soundTrackMorph delete.
		^ soundTrackForm := soundTrackMorph := nil].

	soundTrackForm := scorePlayer volumeForm: 20 from: 1 to: scorePlayer samples size nSamplesPerPixel: 250.
	soundTrackMorph := ImageMorph new image: (Form extent: 140 @ soundTrackForm height).
	soundTrackMorph addMorph:
		(Morph newBounds: (soundTrackMorph bounds topCenter extent: 1@soundTrackMorph height)
					color: Color red).
	self addMorph: soundTrackMorph after: currentPage.
	self layoutChanged.
	self stepSoundTrack.
! !


!MoviePlayerMorph methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:48'!
duplicate
	| dup |
	playDirection ~= 0 ifTrue: [self stopPlay].
	dup := super duplicate.
	dup scorePlayer: scorePlayer copy.  "Share sound track if any."
	^ dup duplicateMore startStepping! !


!MoviePlayerMorph methodsFor: 'event handling' stamp: 'di 10/16/2000 13:27'!
handlesMouseDown: evt
	"We use shift drag to 'tear off' a thumbnail"

	evt shiftPressed ifTrue: [^ true].
	^ super handlesMouseDown: evt! !

!MoviePlayerMorph methodsFor: 'event handling' stamp: 'di 10/16/2000 13:32'!
mouseDown: evt
	"We use shift drag to 'tear off' a thumbnail"

	evt shiftPressed ifTrue: [^ self makeThumbnailInHand: evt hand].
	^ super mouseDown: evt
		! !


!MoviePlayerMorph methodsFor: 'geometry' stamp: 'stephaneducasse 2/4/2006 20:48'!
extent: newExtent

	| tlMargin brMargin pageExtent scale fullSizeImage |
	fullSizeImage := frameBufferIfScaled ifNil: [currentPage image].
	frameCount ifNil: [^ self].  "Not yet open"
	tlMargin := currentPage topLeft - self topLeft.
	brMargin := self bottomRight - currentPage bottomRight.
	pageExtent := newExtent - brMargin - tlMargin.
	scale := pageExtent x asFloat / frameSize x min: pageExtent y asFloat / frameSize y.
	(scale := scale max: 0.25) > 0.9 ifTrue: [scale := 1.0].

	pageExtent := (frameSize * scale) rounded.
	pageExtent = frameSize
		ifTrue: [currentPage image: fullSizeImage.
				frameBufferIfScaled := nil]
		ifFalse: [currentPage image: (Form extent: pageExtent depth: frameDepth).
				frameBufferIfScaled := fullSizeImage.
				(WarpBlt current toForm: currentPage image) sourceForm: fullSizeImage;
					combinationRule: 3;
					copyQuad: fullSizeImage boundingBox innerCorners
						toRect: currentPage image boundingBox].
	^ self layoutChanged
! !

!MoviePlayerMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 19:01'!
position: newPos 
	super position: newPos.
	(currentPage notNil and: [currentPage left odd]) 
		ifTrue: 
			["crude word alignment for depth = 16"

			super position: newPos + (1 @ 0)]! !


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

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

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
duplicateMore
	"Duplicate dies not replicate Forms, but MoviePlayers need this."

	frameBufferIfScaled := frameBufferIfScaled deepCopy.
	currentPage image: currentPage image deepCopy.
! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'di 10/8/2000 21:43'!
openFileNamed: fName 
	self pvtOpenFileNamed: fName.
	self goToPage: 1! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
openFileNamed: fName withScorePlayer: playerReady andPlayFrom: frameNo
	"Note: The plan is that the score player (a SampledSound) is already spaced
	forward to this frame number so it does not need to be reset as would normally
	happen in startRunning."

	self pvtOpenFileNamed: fName.
	scorePlayer := playerReady.
	frameNumber := frameNo.
	frameAtLastSync := frameNo.
	msAtLastSync := frameAtLastSync * msPerFrame.
	self playForward.! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
setInitialState
	super setInitialState.
""
	self layoutInset: 3.
	pageSize := frameSize := 200 @ 200.
	frameDepth := 8.
	self disableDragNDrop! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 13:22'!
stopSoundTrackIfAny
	scorePlayer isNil ifTrue: [^self].
	(scorePlayer isKindOf: SampledSound) 
		ifTrue: [scorePlayer endGracefully]
		ifFalse: [scorePlayer := nil]! !


!MoviePlayerMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 13:21'!
addSoundTrack
	| fileName |
	fileName := Utilities chooseFileWithSuffixFromList: #('.aif' '.wav')
				withCaption: 'Choose a sound track file'.
	fileName isNil ifTrue: [^self].
	soundTrackFileName := fileName.
	self tryToShareScoreFor: soundTrackFileName.
	scorePlayer ifNil: 
			[('*aif' match: fileName) 
				ifTrue: [scorePlayer := SampledSound fromAIFFfileNamed: fileName].
			('*wav' match: fileName) 
				ifTrue: [scorePlayer := SampledSound fromWaveFileNamed: fileName]].
	soundTrackForm ifNotNil: 
			["Compute new soundTrack if we're showing it."

			self
				showHideSoundTrack;
				showHideSoundTrack]! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 10/19/2000 17:07'!
endClipHere
	"Change set the termination time for this clip via the endMorph"

	cueMorph ifNil: [^ self].
	cueMorph setEndFrameNumber: frameNumber
! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:48'!
invokeBookMenu
	"Invoke the book's control panel menu."
	| aMenu |
	aMenu := MVCMenuMorph new defaultTarget: self.
	aMenu add:	'make a new movie' translated action: #makeAMovie.
	aMenu add:	'open movie file' translated action: #openMovieFile.
	aMenu add:	'add sound track' translated action: #addSoundTrack.
	aMenu addLine.
	scorePlayer ifNotNil:
		[soundTrackForm isNil
			ifTrue: [aMenu add:	'show sound track' translated action: #showHideSoundTrack]
			ifFalse: [aMenu add:	'hide sound track' translated action: #showHideSoundTrack]].
	aMenu add:	'make thumbnail' translated action: #thumbnailForThisPage.
	cueMorph ifNotNil:
		["Should check if piano roll and score already have a start event
		prior to this time."
		aMenu add:	'end clip here' translated action: #endClipHere].

	aMenu popUpEvent: self world activeHand lastEvent in: self world
! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:48'!
makeAMovie
	| scoreController score |
	frameSize := 640@480.  frameDepth := 16.  self makeMyPage; changed.

	(score := MIDIScore new initialize) "addAmbientEvent: (AmbientEvent new time: 200*60)".
	scoreController := ScorePlayerMorph new
			onScorePlayer: (ScorePlayer onScore: score) title: 'sMovie'.
	pianoRoll := PianoRollScoreMorph new on: scoreController scorePlayer.
	self pianoRoll: pianoRoll.  "back link"
	pianoRoll enableDragNDrop;
		useRoundedCorners;
		movieClipPlayer: self;
		borderWidth: 2;
		extent: self width @ 120;
		align: pianoRoll topLeft with: self bottomLeft - (0@2);
		openInWorld.
	scoreController extent: self width @ scoreController height;
		align: scoreController topLeft with: pianoRoll bottomLeft - (0@2);
		openInWorld.

! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:48'!
openMovieFile
	| fileName |
	fileName := Utilities chooseFileWithSuffixFromList: #('.movie')
					withCaption: 'Choose a movie file to open'.
	fileName ifNotNil:
		[self openFileNamed: fileName.
		self showMoreControls]! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:48'!
scanBySlider
	| scrollSlider handle |
	scrollSlider := SimpleSliderMorph new extent: 150@10;
		color: color; sliderColor: Color gray;
		target: self; actionSelector: #goToRelativePosition:;
		adjustToValue: self relativePosition.
	(handle := scrollSlider firstSubmorph) on: #mouseUp send: #delete to: scrollSlider.
	scrollSlider align: handle center with: self activeHand position.
	self world addMorph: scrollSlider.
	self activeHand targetOffset: (handle width // 2) @ 0.
	self activeHand newMouseFocus: handle! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 10/16/2000 13:31'!
thumbnailForThisPage
	"Overridden to make a MovieFrameSyncMorph"

	^ self makeThumbnailInHand: self activeHand
! !


!MoviePlayerMorph methodsFor: 'menu commands' stamp: 'di 7/6/1998 19:32'!
firstPage
	playDirection = 0 ifFalse: [^ self]. "No-op during play"
	self goToPage: 1
! !

!MoviePlayerMorph methodsFor: 'menu commands' stamp: 'di 7/6/1998 14:05'!
insertPage
	^ self makeMyPage! !


!MoviePlayerMorph methodsFor: 'movie clip player' stamp: 'di 10/19/2000 22:02'!
pianoRoll
	^ pianoRoll! !

!MoviePlayerMorph methodsFor: 'movie clip player' stamp: 'stephaneducasse 2/4/2006 20:48'!
pianoRoll: aPianoRollScoreMorph
	"Provides access also to the score and scorePlayer"

	pianoRoll := aPianoRollScoreMorph
! !


!MoviePlayerMorph methodsFor: 'navigation' stamp: 'stephaneducasse 2/4/2006 20:48'!
goToPage: i
	currentPage ifNil: [self makeMyPage].
	frameNumber := i.
	playDirection := 0.
	self startRunning; step.  "will stop after first step"
	soundTrackMorph ifNotNilDo: [:m | m image fillWhite].
	self stepSoundTrack.
! !

!MoviePlayerMorph methodsFor: 'navigation' stamp: 'di 7/6/1998 19:29'!
lastPage
	playDirection = 0 ifFalse: [^ self]. "No-op during play"
	self goToPage: frameCount
! !

!MoviePlayerMorph methodsFor: 'navigation' stamp: 'stephaneducasse 2/4/2006 20:48'!
nextPage
	playDirection = 0 ifFalse: [^ self]. "No-op during play"
	self goToPage: (frameNumber := frameNumber + 1 min: frameCount).
! !

!MoviePlayerMorph methodsFor: 'navigation' stamp: 'stephaneducasse 2/4/2006 20:48'!
previousPage
	playDirection = 0 ifFalse: [^ self]. "No-op during play"
	self goToPage: (frameNumber := frameNumber - 1 max: 1).
! !


!MoviePlayerMorph methodsFor: 'page controls' stamp: 'di 10/16/2000 13:20'!
fullControlSpecs
	^ #(	
			( '·'		invokeBookMenu 'Invoke menu')
			( '<--'		firstPage		'Go to first page')
			( '<<'		playReverse		'Play backward')
			( '<-' 		previousPage	'Back one frame')
			( '| |' 		stopPlay		'Stop playback')
			( '->'		nextPage		'Forward one frame')
			( '>>'		playForward	'Play forward')
			( '-->'		lastPage			'Go to final page')
			( '<->'		scanBySlider	'Scan by slider'  'menu')
		"Note extra spec 'menu' causes mousedown activation -- see makePageControlsFrom:"
	)! !

!MoviePlayerMorph methodsFor: 'page controls' stamp: 'di 10/24/2000 16:55'!
showPageControls
	self showPageControls: self fullControlSpecs.
! !

!MoviePlayerMorph methodsFor: 'page controls' stamp: 'stephaneducasse 2/4/2006 20:48'!
showPageControls: controlSpecs 
	| pageControls |
	self hidePageControls.

	pageControls := self makePageControlsFrom: controlSpecs.
	pageControls borderWidth: 0; layoutInset: 0; extent: pageControls width@14.
	pageControls  setProperty: #pageControl toValue: true.
	pageControls setNameTo: 'Page Controls'.
	pageControls eventHandler: (EventHandler new on: #mouseDown send: #move to: self).
	self addMorphBack: pageControls beSticky! !


!MoviePlayerMorph methodsFor: 'piano rolls' stamp: 'stephaneducasse 2/4/2006 20:48'!
pauseFrom: player

	playDirection := 0.
	self step.! !

!MoviePlayerMorph methodsFor: 'piano rolls' stamp: 'di 10/25/2000 22:06'!
resetFrom: player
	self pauseFrom: player.
	self firstPage! !

!MoviePlayerMorph methodsFor: 'piano rolls' stamp: 'stephaneducasse 2/4/2006 20:48'!
resumeFrom: player
	playDirection ~= 0 ifTrue: [^ self].  "Already running"
	playDirection := 1.
	pianoRoll ifNil:
		["Sync movie to score player if not a clip player"
		scorePlayer := player].
	self startRunning! !


!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 10/16/2000 11:02'!
goToRelativePosition: newPos

	movieFile ifNotNil: [^ self].
	self goToPage: ((newPos*frameCount) asInteger min: frameCount max: 1).
! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'stephaneducasse 2/4/2006 20:48'!
playForward
	(playDirection ~= 0 or: [frameNumber >= frameCount]) ifTrue:
		[^ self]. "No-op during play or at end"
	playDirection := 1.
	self startRunning! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'stephaneducasse 2/4/2006 20:48'!
playReverse
	(playDirection ~= 0 or: [frameNumber <= 1]) ifTrue:
		[^ self]. "No-op during play or at end"
	playDirection := -1.
	self startRunning! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'stephaneducasse 2/4/2006 20:48'!
stopPlay

	playDirection := 0.
	self step! !


!MoviePlayerMorph methodsFor: 'rounding' stamp: 'di 10/22/2000 23:41'!
wantsRoundedCorners
	^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! !


!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 9/5/2000 23:09'!
fileByteCountPerFrame
	
	^ (frameBufferIfScaled ifNil: [currentPage image]) bits size * 4
! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 5/27/1999 22:40'!
filePosForFrameNo: frameNo
	
	^ 128 + ((frameNo-1)*(4+self fileByteCountPerFrame)) + 4
! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'dgd 2/22/2003 13:22'!
startRunning
	| ms |
	(frameBufferIfScaled ifNil: [currentPage image]) unhibernate.
	movieFile := AsyncFile new 
				open: (FileDirectory default fullNameFor: movieFileName)
				forWrite: false.
	movieFile 
		primReadStart: movieFile fileHandle
		fPosition: (self filePosForFrameNo: frameNumber)
		count: self fileByteCountPerFrame.
	scorePlayer isNil 
		ifTrue: 
			[ms := Time millisecondClockValue.
			msAtStart := ms - ((frameNumber - 1) * msPerFrame).
			msAtLastSync := ms - msAtStart]
		ifFalse: 
			[(playDirection > 0 and: [scorePlayer isKindOf: SampledSound]) 
				ifTrue: 
					[scorePlayer
						reset;
						playSilentlyUntil: (frameNumber - 1) * msPerFrame / 1000.0;
						initialVolume: 1.0.
					
					[scorePlayer resumePlaying.
					msAtLastSync := scorePlayer millisecondsSinceStart] 
							forkAt: Processor userInterruptPriority].
			msAtLastSync := scorePlayer millisecondsSinceStart].
	frameAtLastSync := frameNumber! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'dgd 2/22/2003 13:22'!
step
	"NOTE:  The movie player has two modes of play, depending on whether scorePlayer is nil or not.  If scorePlayer is nil, then play runs according to the millisecond clock.  If scorePlayer is not nil, then the scorePlayer is consulted for synchronization.  If the movie is running ahead, then some calls on step will skip their  action until the right time.  If the movie is running behind, then the frame may advance by more than one to maintain synchronization."

	"ALSO: This player operates with overlapped disk i/o.  This means that while one frame is being displayed, the next frame in sequence is being read into a disk buffer.  The value of frameNumber corresponds to the frame currently visible."

	"This code may not work right for playing backwards right now.
	Single-step and backwards (dir <= 0) should just run open-loop."

	| byteCount simTime ms nextFrameNumber |
	movieFile isNil ifTrue: [^self].
	scorePlayer isNil 
		ifTrue: 
			[(ms := Time millisecondClockValue) < msAtStart 
				ifTrue: 
					["clock rollover"

					msAtStart := ms - (frameNumber * msPerFrame)].
			simTime := ms - msAtStart]
		ifFalse: [simTime := scorePlayer millisecondsSinceStart].
	playDirection > 0 
		ifTrue: 
			[nextFrameNumber := frameAtLastSync 
						+ ((simTime - msAtLastSync) // msPerFrame).
			nextFrameNumber = frameNumber 
				ifTrue: 
					[((scorePlayer isKindOf: AbstractSound) and: [scorePlayer isPlaying not]) 
						ifTrue: [^self stopRunning].
					^self]]
		ifFalse: 
			[nextFrameNumber := playDirection < 0 
						ifTrue: [frameNumber - 1]
						ifFalse: [frameNumber]].
	byteCount := self fileByteCountPerFrame.
	self stepSoundTrack.
	movieFile waitForCompletion.
	movieFile 
		primReadResult: movieFile fileHandle
		intoBuffer: (frameBufferIfScaled ifNil: [currentPage image]) bits
		at: 1
		count: byteCount // 4.
	frameBufferIfScaled ifNotNil: 
			["If this player has been shrunk, then we have to warp to the current page."

			(WarpBlt current toForm: currentPage image)
				sourceForm: frameBufferIfScaled;
				combinationRule: 3;
				cellSize: (playDirection = 0 
							ifTrue: 
								["Use smoothing if just stepping"

								2]
							ifFalse: [1]);
				copyQuad: frameBufferIfScaled boundingBox innerCorners
					toRect: currentPage image boundingBox].
	currentPage changed.
	frameNumber := nextFrameNumber.
	(playDirection = 0 or: 
			[(playDirection > 0 and: [frameNumber >= frameCount]) 
				or: [playDirection < 0 and: [frameNumber <= 1]]]) 
		ifTrue: [^self stopRunning].

	"Start the read operation for the next frame..."
	movieFile 
		primReadStart: movieFile fileHandle
		fPosition: (self filePosForFrameNo: frameNumber)
		count: byteCount! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'aoy 2/15/2003 21:45'!
stepSoundTrack
	| x image timeInMillisecs |
	scorePlayer ifNil: [^self].
	soundTrackForm ifNil: [^self].
	timeInMillisecs := playDirection = 0 
		ifTrue: 
			["Stepping forward or back"

			 (frameNumber - 1) * msPerFrame]
		ifFalse: 
			["Driven by sound track"

			 scorePlayer millisecondsSinceStart].
	x := timeInMillisecs / 1000.0 * scorePlayer originalSamplingRate // 250.
	image := soundTrackMorph image.
	image 
		copy: (image boundingBox translateBy: (x - (image width // 2)) @ 0)
		from: soundTrackForm
		to: 0 @ 0
		rule: Form over.
	soundTrackMorph changed! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'stephaneducasse 2/4/2006 20:48'!
stopRunning
	"Must only be called with no outstanding file read requests..."
	movieFile ifNotNil: [movieFile close.  movieFile := nil].
	playDirection := 0.
	self stopSoundTrackIfAny
! !


!MoviePlayerMorph methodsFor: 'testing' stamp: 'di 8/8/1998 11:57'!
stepTime
	^ 0  "step as fast as possible"! !


!MoviePlayerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
makeMyPage

	currentPage ifNotNil:
		[(currentPage isMemberOf: ImageMorph)
			ifTrue: ["currentPage is already an ImageMorph."
					(currentPage image extent = frameSize
						and: [currentPage image depth = frameDepth])
						ifTrue: [^ self  "page is already properly dimensioned."].
					^ currentPage image: (Form extent: frameSize depth: frameDepth)]
			ifFalse: [currentPage releaseCachedState; delete]].
	currentPage := ImageMorph new image: (Form extent: frameSize depth: frameDepth).
	currentPage lock.
	pages := OrderedCollection with: currentPage.
	self addMorphFront: currentPage! !

!MoviePlayerMorph methodsFor: 'private' stamp: 'di 10/25/2000 23:01'!
makeThumbnailInHand: aHand

	scorePlayer ifNotNil:
		["Position the soundTrack for this frameNumber"
		scorePlayer reset; playSilentlyUntil: frameNumber - 1 * msPerFrame / 1000.0].

	aHand attachMorph:
		(MovieClipStartMorph new
			movieFileName: movieFileName
			soundTrackFileName: soundTrackFileName
			image: currentPage image
			player: self
			frameNumber: frameNumber)
! !

!MoviePlayerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
pvtOpenFileNamed: fName
	"Private - open on the movie file iof the given name"

	| f w h d n m |
	self stopRunning.
	fName = movieFileName ifTrue: [^ self].  "No reopen necessary on same file"

	movieFileName := fName.
	"Read movie file parameters from 128-byte header...
		(records follow as {N=int32, N words}*)"
	f := (FileStream oldFileNamed: movieFileName) binary.
		f nextInt32.
		w := f nextInt32.
		h := f nextInt32.
		d := f nextInt32.
		n := f nextInt32.
		m := f nextInt32.
		f close.
	pageSize := frameSize := w@h.
	frameDepth := d.
	frameCount := n.
	frameNumber := 1.
	playDirection := 0.
	msAtLastSync := 0.
	msPerFrame := m/1000.0.
	self makeMyPage.
	(SmalltalkImage current platformName = 'Mac OS') ifTrue:[
		(SmalltalkImage current extraVMMemory < self fileByteCountPerFrame) ifTrue:
			[^ self inform:
'Playing movies in Squeak requires that extra memory be allocated
for asynchronous file IO.  This particular movie requires a buffer of
' ,
(self fileByteCountPerFrame printString) , ' bytes, but you only have ' , (SmalltalkImage current extraVMMemory printString) , ' allocated.
You can evaluate ''SmalltalkImage current extraVMMemory'' to check your allocation,
and ''SmalltalkImage current extraVMMemory: 485000'' or the like to increase your allocation.
Note that raising your allocation in this way only marks your image as
needing this much, so you must then save, quit, and start over again
before you can run this movie.  Good luck.']].
! !

!MoviePlayerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
tryToShareScoreFor: fileName

	scorePlayer := nil.
	self class allInstancesDo:
		[:mp | mp == self ifFalse:
			[mp soundTrackFileName = fileName ifTrue:
				["Found this score already open in another player
					-- return a copy that shares the same sound buffer."
				mp scorePlayer ifNotNil: [^ scorePlayer := mp scorePlayer copy reset]]]]! !

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

MoviePlayerMorph class
	instanceVariableNames: ''!

!MoviePlayerMorph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 16:59'!
initialize

	FileList registerFileReader: self! !


!MoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:36'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'movie') | (suffix = '*')
		ifTrue: [ self services]
		ifFalse: [#()]! !

!MoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'hg 8/3/2000 17:01'!
openAsMovie: fullFileName
	"Open a MoviePlayerMorph on the given file (must be in .movie format)."
 
	(self new openFileNamed: fullFileName) openInWorld! !

!MoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2002 01:23'!
serviceOpenAsMovie
	"Answer a service for opening a file as a movie"

	^ SimpleServiceEntry 
		provider: self 
		label: 'open as movie'
		selector: #openAsMovie:
		description: 'open file as movie'
		buttonLabel: 'open'! !

!MoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sw 9/7/2004 18:21'!
services
	"Formerly: answer a service for opening as a movie.  Nowadays... no services"

	^ #().
"
	^ Array with: self serviceOpenAsMovie"

	! !


!MoviePlayerMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'!
unload

	FileList unregisterFileReader: self ! !
EllipseMorph subclass: #MovingEyeMorph
	instanceVariableNames: 'inner iris'
	classVariableNames: 'IrisSize'
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!MovingEyeMorph methodsFor: 'as yet unclassified' stamp: 'yo 2/15/2001 15:24'!
irisPos: cp

	| a b theta x y |
	theta _ (cp - self center) theta.
	a _ inner width // 2.
	b _ inner height // 2.
	x _ a * (theta cos).
	y _ b * (theta sin).
	iris position: ((x@y) asIntegerPoint) + self center - (iris extent // 2).! !


!MovingEyeMorph methodsFor: 'geometry' stamp: 'yo 2/15/2001 15:59'!
extent: aPoint

	super extent: aPoint.
	inner extent: (self extent * ((1.0@1.0)-IrisSize)) asIntegerPoint.
	iris extent: (self extent * IrisSize) asIntegerPoint.
	inner position: (self center - (inner extent // 2)) asIntegerPoint.
! !


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

!MovingEyeMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:42'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	inner _ EllipseMorph new.
	inner color: self color.
	inner extent: (self extent * (1.0 @ 1.0 - IrisSize)) asIntegerPoint.
	inner borderColor: self color.
	inner borderWidth: 0.
""
	iris _ EllipseMorph new.
	iris color: Color white.
	iris extent: (self extent * IrisSize) asIntegerPoint.
""
	self addMorphCentered: inner.
	inner addMorphCentered: iris.
""
	self extent: 26 @ 33! !


!MovingEyeMorph methodsFor: 'stepping and presenter' stamp: 'di 2/18/2001 00:10'!
step
	| cp |
	cp _ self globalPointToLocal: World primaryHand position.
	(inner containsPoint: cp)
		ifTrue: [iris position: (cp - (iris extent // 2))]
		ifFalse: [self irisPos: cp].
	self changed "cover up gribblies if embedded in Flash"! !


!MovingEyeMorph methodsFor: 'testing' stamp: 'yo 2/15/2001 15:38'!
stepTime

	^ 100.! !

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

MovingEyeMorph class
	instanceVariableNames: ''!

!MovingEyeMorph class methodsFor: 'class initialization' stamp: 'yo 2/15/2001 16:04'!
initialize
"
	MovingEyeMorph initialize
"
	IrisSize _ (0.42@0.50).! !


!MovingEyeMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:51'!
descriptionForPartsBin
	^ self partName:	'MovingEye'
		categories:		#('Demo')
		documentation:	'An eye which follows the cursor'! !
SoundCodec subclass: #MuLawCodec
	instanceVariableNames: ''
	classVariableNames: 'DecodingTable'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!MuLawCodec commentStamp: '<historical>' prior: 0!
I represent a mu-law (u-law) codec. I compress sound data by a factor of 2:1 by encoding the most significant 12 bits of each 16-bit sample as a signed, exponentially encoded byte. The idea is to use more resolution for smaller lower sample values. This encoding was developed for the North American phone system and a variant of it, a-law, is a European phone standard. It is a popular sound encoding on Unix platforms (.au files).
!


!MuLawCodec methodsFor: 'external access' stamp: 'di 2/8/1999 22:28'!
uLawDecodeSample: byte
	"Decode a 16-bit signed sample from 8 bits using uLaw decoding"

	^ DecodingTable at: byte + 1! !

!MuLawCodec methodsFor: 'external access' stamp: 'stephaneducasse 2/4/2006 20:41'!
uLawEncodeSample: sample
	"Encode a 16-bit signed sample into 8 bits using uLaw encoding"

	| s |
	s := sample // 8.  "drop 3 least significant bits"
	s < 0 ifTrue: [^ (self uLawEncode12Bits: 0-s) + 16r80]
		ifFalse: [^ (self uLawEncode12Bits: s)].
! !


!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 09:15'!
bytesPerEncodedFrame
	"Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."

	^ 1
! !

!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'stephaneducasse 2/4/2006 20:41'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
	"Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	| dst |
	dst := dstIndex.
	srcIndex to: srcIndex + frameCount - 1 do: [:src |
		dstSoundBuffer at: dst put: (DecodingTable at: (srcByteArray at: src) + 1).
		dst := dst + 1].
	^ Array with: frameCount with: frameCount
! !

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

	srcIndex to: srcIndex + frameCount - 1 do: [:i |
		dstByteArray at: i put: (self uLawEncodeSample: (srcSoundBuffer at: i))].
	^ Array with: frameCount with: frameCount
! !

!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 09:11'!
samplesPerFrame
	"Answer the number of sound samples per compression frame."

	^ 1
! !


!MuLawCodec methodsFor: 'private' stamp: 'di 2/9/1999 13:25'!
uLawEncode12Bits: s
	"Encode a 12-bit unsigned sample (0-4095) into 7 bits using uLaw encoding.
	This gets called by a method that scales 16-bit signed integers down to a
		12-bit magnitude, and then ORs in 16r80 if they were negative.
	Detail: May get called with s >= 4096, and this works fine."

	s < 496 ifTrue: [
		s < 112 ifTrue: [
			s < 48 ifTrue: [
				s < 16
					ifTrue: [^ 16r70 bitOr: (15 - s)]
					ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]].
			^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))].
		s < 240
			ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))]
			ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]].

	s < 2032 ifTrue: [
		s < 1008
			ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))]
			ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]].

	s < 4080
		ifTrue: [^ 15 - ((s - 2032) bitShift: -7)]
		ifFalse: [^ 0].
! !

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

MuLawCodec class
	instanceVariableNames: ''!

!MuLawCodec class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"Build the 256 entry table to be used to decode 8-bit uLaw-encoded samples."
	"MuLawCodec initialize"

	| encoded codec lastEncodedPos lastEncodedNeg |
	DecodingTable := Array new: 256.
	codec := self new.
	lastEncodedPos := nil.
	lastEncodedNeg := nil.
	4095 to: 0 by: -1 do: [:s |
		encoded := codec uLawEncode12Bits: s.
		lastEncodedPos = encoded
			ifFalse: [
				DecodingTable at: (encoded + 1) put: (s bitShift: 3).
				lastEncodedPos := encoded].
		encoded := encoded bitOr: 16r80.
		lastEncodedNeg = encoded
			ifFalse: [
				DecodingTable at: (encoded + 1) put: (s bitShift: 3) negated.
				lastEncodedNeg := encoded]].
! !
ReadWriteStream subclass: #MultiByteBinaryOrTextStream
	instanceVariableNames: 'isBinary converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!MultiByteBinaryOrTextStream commentStamp: '<historical>' prior: 0!
It is similar to MultiByteFileStream, but works on in memory stream.!


!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'!
ascii
	isBinary _ false
! !

!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'!
binary
	isBinary _ true
! !

!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'nk 8/2/2004 17:02'!
converter

	converter ifNil: [converter _ self class defaultConverter].
	^ converter
! !

!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 8/7/2003 09:12'!
converter: aConverter

	converter _ aConverter.
! !

!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:25'!
isBinary
	^ isBinary! !

!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 16:33'!
text
	isBinary _ false
! !


!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:10'!
fileInObjectAndCodeForProject
	"This file may contain:
1) a fileIn of code  
2) just an object in SmartReferenceStream format 
3) both code and an object.
	File it in and return the object.  Note that self must be a FileStream or RWBinaryOrTextStream.  Maybe ReadWriteStream incorporate RWBinaryOrTextStream?"
	| refStream object |
	self text.
	self peek asciiValue = 4
		ifTrue: [  "pure object file"
			self binary.
			refStream _ SmartRefStream on: self.
			object _ refStream nextAndClose]
		ifFalse: [  "objects mixed with a fileIn"
			self fileInProject.  "reads code and objects, then closes the file"
			self binary.
			object _ SmartRefStream scannedObject].	"set by side effect of one of the chunks"
	SmartRefStream scannedObject: nil.  "clear scannedObject"
	^ object! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:46'!
fileInProject

	self setConverterForCodeForProject.
	super fileIn.
! !

!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:46'!
setConverterForCodeForProject

	self converter: UTF8TextConverter new.
! !


!MultiByteBinaryOrTextStream methodsFor: 'converting' stamp: 'yo 11/11/2002 13:16'!
asBinaryOrTextStream

	^ self
! !


!MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'yo 8/17/2004 10:02'!
fileIn

	self setConverterForCode.
	super fileIn.
! !

!MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'yo 11/11/2002 16:31'!
fileInObjectAndCode
	"This file may contain:
1) a fileIn of code  
2) just an object in SmartReferenceStream format 
3) both code and an object.
	File it in and return the object.  Note that self must be a FileStream or RWBinaryOrTextStream.  Maybe ReadWriteStream incorporate RWBinaryOrTextStream?"
	| refStream object |
	self text.
	self peek asciiValue = 4
		ifTrue: [  "pure object file"
			self binary.
			refStream _ SmartRefStream on: self.
			object _ refStream nextAndClose]
		ifFalse: [  "objects mixed with a fileIn"
			self fileIn.  "reads code and objects, then closes the file"
			self binary.
			object _ SmartRefStream scannedObject].	"set by side effect of one of the chunks"
	SmartRefStream scannedObject: nil.  "clear scannedObject"
	^ object! !

!MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'tak 1/12/2005 13:47'!
fileOutClass: extraClass andObject: theObject 
	UTF8TextConverter writeBOMOn: self.
	^ super fileOutClass: extraClass andObject: theObject! !

!MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'yo 8/18/2004 09:36'!
setConverterForCode

	| current |
	current _ converter saveStateOf: self.
	self position: 0.
	self binary.
	((self next: 3) = (ByteArray with: 16rEF with: 16rBB with: 16rBF)) ifTrue: [
		self converter: UTF8TextConverter new
	] ifFalse: [
		self converter: MacRomanTextConverter new.
	].
	converter restoreStateOf: self with: current.
	self text.
! !

!MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'yo 7/7/2004 09:43'!
setEncoderForSourceCodeNamed: streamName

	| l |
	l _ streamName asLowercase.
"	((l endsWith: FileStream multiCs) or: [
		(l endsWith: FileStream multiSt) or: [
			(l endsWith: (FileStream multiSt, '.gz')) or: [
				(l endsWith: (FileStream multiCs, '.gz'))]]]) ifTrue: [
					self converter: UTF8TextConverter new.
					^ self.
	].
"
	((l endsWith: FileStream cs) or: [
		(l endsWith: FileStream st) or: [
			(l endsWith: (FileStream st, '.gz')) or: [
				(l endsWith: (FileStream cs, '.gz'))]]]) ifTrue: [
					self converter: MacRomanTextConverter new.
					^ self.
	].

	self converter: UTF8TextConverter new.
! !


!MultiByteBinaryOrTextStream methodsFor: 'properties-setting' stamp: 'yo 11/14/2002 13:49'!
setFileTypeToObject
	"do nothing.  We don't have a file type"! !


!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 7/30/2004 06:59'!
contents

	| ret state |
	state _ converter saveStateOf: self.
	ret _ self upToEnd.
	converter restoreStateOf: self with: state.
	^ ret.
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:39'!
next

	| n |
	n _ self converter nextFromStream: self.
	n ifNil: [^ nil].
	isBinary and: [n isCharacter ifTrue: [^ n asciiValue]].
	^ n.
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'ar 4/12/2005 17:34'!
next: anInteger 

	| multiString |
	"self halt."
	self isBinary ifTrue: [^ (super next: anInteger) asByteArray].
	multiString _ WideString new: anInteger.
	1 to: anInteger do: [:index |
		| character |
		(character _ self next) ifNotNil: [
			multiString at: index put: character
		] ifNil: [
			multiString _ multiString copyFrom: 1 to: index - 1.
			^ multiString
		]
	].
	^ multiString.
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:05'!
nextDelimited: terminator

	| out ch pos |
	out _ WriteStream on: (String new: 1000).
	self atEnd ifTrue: [^ ''].
	pos _ self position.
	self next = terminator ifFalse: [
		"absorb initial terminator"
		self position: pos.
	].
	[(ch _ self next) == nil] whileFalse: [
		(ch = terminator) ifTrue: [
			self peek = terminator ifTrue: [
				self next.  "skip doubled terminator"
			] ifFalse: [
				^ out contents  "terminator is not doubled; we're done!!"
			].
		].
		out nextPut: ch.
	].
	^ out contents.
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'!
nextMatchAll: aColl

    | save |
    save _ converter saveStateOf: self.
    aColl do: [:each |
       (self next) = each ifFalse: [
            converter restoreStateOf: self with: save.
            ^ false.
		].
	].
    ^ true.
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/14/2002 13:54'!
nextPut: aCharacter

	aCharacter isInteger ifTrue: [^ super nextPut: aCharacter asCharacter].
	^ self converter nextPut: aCharacter toStream: self
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'!
nextPutAll: aCollection

	self isBinary ifTrue: [
		^ super nextPutAll: aCollection.
	].
	aCollection do: [:e | self nextPut: e].
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/14/2002 13:54'!
padToEndWith: aChar
	"We don't have pages, so we are at the end, and don't need to pad."! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:04'!
peek
	"Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil.  "

	| next pos |
	self atEnd ifTrue: [^ nil].
	pos _ self position.
	next _ self next.
	self position: pos.
	^ next.

! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:25'!
peekFor: item 

	| next state |
	"self atEnd ifTrue: [^ false]. -- SFStream will give nil"
	state _ converter saveStateOf: self.
	(next _ self next) == nil ifTrue: [^ false].
	item = next ifTrue: [^ true].
	converter restoreStateOf: self with: state.
	^ false.
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'nk 7/29/2004 12:02'!
reset

	super reset.
	isBinary ifNil: [isBinary _ false].
	collection class == ByteArray ifTrue: ["Store as String and convert as needed."
		collection _ collection asString.
		isBinary _ true].

	self converter. "ensure that we have a converter."! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:17'!
skipSeparators

	[self atEnd] whileFalse: [
		self basicNext isSeparator ifFalse: [
			^ self position: self position - 1]]

! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:04'!
skipSeparatorsAndPeekNext

	"A special function to make nextChunk fast"
	| peek pos |
	[self atEnd] whileFalse: [
		pos _ self position.
		(peek _ self next) isSeparator ifFalse: [
			self position: pos.
			^ peek.
		].
	].
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'!
upTo: delim 

	| out ch |
	out _ WriteStream on: (String new: 1000).
	self atEnd ifTrue: [^ ''].
	[(ch _ self next) isNil] whileFalse: [
		(ch = delim) ifTrue: [
			^ out contents  "terminator is not doubled; we're done!!"
		].
		out nextPut: ch.
	].
	^ out contents.
! !

!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:17'!
upToEnd

	| newStream element newCollection |
	newCollection _ self isBinary
				ifTrue: [ByteArray new: 100]
				ifFalse: [String new: 100].
	newStream _ WriteStream on: newCollection.
	[(element _ self next) notNil]
		whileTrue: [newStream nextPut: element].
	^ newStream contents
! !


!MultiByteBinaryOrTextStream methodsFor: 'private' stamp: 'nk 8/2/2004 17:01'!
guessConverter
	^ (self originalContents includesSubString: (ByteArray withAll: {27. 36}) asString)
		ifTrue: [CompoundTextConverter new]
		ifFalse: [self class defaultConverter ]! !


!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 16:01'!
basicNext

	^ super next 
! !

!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'md 10/20/2004 15:32'!
basicNext: anInteger

	^ super next: anInteger.
! !

!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'!
basicNext: n into: aString

	^ super next: n into: aString.
! !

!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'!
basicNextInto: aString

	^ super nextInto: aString.
! !

!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'!
basicNextPut: char

	^ super nextPut: char.
! !

!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'!
basicNextPutAll: aString

	^ super nextPutAll: aString.
! !

!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'!
basicPeek

	^ super peek
! !

!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'!
basicPosition

	^ super position.
! !

!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'!
basicPosition: pos

	^ super position: pos.
! !

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

MultiByteBinaryOrTextStream class
	instanceVariableNames: ''!

!MultiByteBinaryOrTextStream class methodsFor: 'defaults' stamp: 'yo 2/25/2005 20:04'!
defaultConverter
	^ Latin1TextConverter new.
! !


!MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'ykoubo 9/28/2003 19:59'!
on: aCollection encoding: encodingName 
	| aTextConverter |
	encodingName isNil
		ifTrue: [aTextConverter _ TextConverter default]
		ifFalse: [aTextConverter _ TextConverter newForEncoding: encodingName].
	^ (self on: aCollection)
		converter: aTextConverter! !

!MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'yo 11/23/2003 20:32'!
with: aCollection encoding: encodingName 
	| aTextConverter |
	encodingName isNil
		ifTrue: [aTextConverter _ TextConverter default]
		ifFalse: [aTextConverter _ TextConverter newForEncoding: encodingName].
	^ (self with: aCollection)
		converter: aTextConverter! !
StandardFileStream subclass: #MultiByteFileStream
	instanceVariableNames: 'converter lineEndConvention wantsLineEndConversion'
	classVariableNames: 'Cr CrLf Lf LineEndDefault LineEndStrings LookAheadCount'
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!MultiByteFileStream commentStamp: '<historical>' prior: 0!
The central class to access the external file.  The interface of this object is similar to good old StandardFileStream, but internally it asks the converter, which is a sub-instance of TextConverter, and do the text conversion.

  It also combined the good old CrLfFileStream.  CrLfFileStream class>>new now returns an instance of MultiByteFileStream.

  There are several pitfalls:

  * You always have to be careful about the binary/text distinction.  In #text mode, it usually interpret the bytes.
  * A few file pointer operations treat the file as uninterpreted byte no matter what.  This means that if you use 'fileStream skip: -1', 'fileStream position: x', etc. in #text mode, the file position can be in the middle of multi byte character.  If you want to implement some function similar to #peek for example, call the saveStateOf: and restoreStateOf: methods to be able to get back to the original state.
  * #lineEndConvention: and #wantsLineEndConversion: (and #binary) can cause some puzzling situation because the inst var lineEndConvention and wantsLineEndConversion are mutated.  If you have any suggestions to clean up the protocol, please let me know.!


!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 02:57'!
ascii

	super ascii.
	self detectLineEndConvention.
! !

!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 02:57'!
binary

	super binary.
	lineEndConvention _ nil.
! !

!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/18/2003 15:11'!
converter

	converter ifNil: [converter _ TextConverter defaultSystemConverter].
	^ converter
! !

!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/28/2002 11:09'!
converter: aConverter

	converter _ aConverter.
! !

!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/6/2003 11:56'!
fileInEncodingName: aString

	self converter: (TextConverter newForEncoding: aString).
	super fileIn.
! !

!MultiByteFileStream methodsFor: 'accessing' stamp: 'nk 9/5/2004 12:57'!
lineEndConvention

	^lineEndConvention! !

!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 02:59'!
lineEndConvention: aSymbol

	lineEndConvention _ aSymbol.
! !

!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 04:24'!
wantsLineEndConversion: aBoolean

	wantsLineEndConversion _ aBoolean.
	self detectLineEndConvention.! !


!MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:38'!
bareNext

	 ^ self converter nextFromStream: self.
! !

!MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 02:56'!
convertStringFromCr: aString 
	| inStream outStream |
	lineEndConvention ifNil: [^ aString].
	lineEndConvention == #cr ifTrue: [^ aString].
	lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Cr with: Lf].
	"lineEndConvention == #crlf"
	inStream _ ReadStream on: aString.
	outStream _ WriteStream on: (String new: aString size).
	[inStream atEnd]
		whileFalse: 
			[outStream nextPutAll: (inStream upTo: Cr).
			(inStream atEnd not or: [aString last = Cr])
				ifTrue: [outStream nextPutAll: CrLf]].
	^ outStream contents! !

!MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 02:56'!
convertStringToCr: aString 
	| inStream outStream |
	lineEndConvention ifNil: [^ aString].
	lineEndConvention == #cr ifTrue: [^ aString].
	lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Lf with: Cr].
	"lineEndConvention == #crlf"
	inStream _ ReadStream on: aString.
	outStream _ WriteStream on: (String new: aString size).
	[inStream atEnd]
		whileFalse: 
			[outStream nextPutAll: (inStream upTo: Cr).
			(inStream atEnd not or: [aString last = Cr])
				ifTrue: 
					[outStream nextPut: Cr.
					inStream peek = Lf ifTrue: [inStream next]]].
	^ outStream contents! !

!MultiByteFileStream methodsFor: 'crlf private' stamp: 'nk 9/5/2004 12:50'!
detectLineEndConvention
	"Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf."
	| char numRead state |
	self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams'].
	self wantsLineEndConversion ifFalse: [^ lineEndConvention _ nil.].
	self closed ifTrue: [^ lineEndConvention _ LineEndDefault.].

	"Default if nothing else found"
	numRead _ 0.
	state _ converter saveStateOf: self.
	lineEndConvention _ nil.
	[super atEnd not and: [numRead < LookAheadCount]]
		whileTrue: 
			[char _ self next.
			char = Lf
				ifTrue: 
					[converter restoreStateOf: self with: state.
					^ lineEndConvention _ #lf].
			char = Cr
				ifTrue: 
					[self peek = Lf
						ifTrue: [lineEndConvention _ #crlf]
						ifFalse: [lineEndConvention _ #cr].
					converter restoreStateOf: self with: state.
					^ lineEndConvention].
			numRead _ numRead + 1].
	converter restoreStateOf: self with: state.
	^ lineEndConvention _ LineEndDefault.
! !

!MultiByteFileStream methodsFor: 'crlf private' stamp: 'nk 9/5/2004 12:51'!
doConversion

	^self wantsLineEndConversion and: [ lineEndConvention notNil ]! !

!MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:44'!
next: n innerFor: aString

	| peekChar state |
	"if we just read a CR, and the next character is an LF, then skip the LF"
	aString size = 0 ifTrue: [^ aString].
	(aString last = Character cr) ifTrue: [
		state _ converter saveStateOf: self.
		peekChar _ self bareNext.		"super peek doesn't work because it relies on #next"
		(peekChar notNil and: [peekChar ~= Character lf]) ifTrue: [
			converter restoreStateOf: self with: state.
		].
	].
 
	^ aString withSqueakLineEndings.
! !

!MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 03:51'!
wantsLineEndConversion

	^ wantsLineEndConversion ifNil: [false].
! !


!MultiByteFileStream methodsFor: 'fileIn/Out' stamp: 'yo 8/17/2004 10:03'!
fileIn

	self setConverterForCode.
	super fileIn.
! !

!MultiByteFileStream methodsFor: 'fileIn/Out' stamp: 'ar 7/29/2005 22:33'!
fileInObjectAndCodeForProject
	"This file may contain:
1) a fileIn of code  
2) just an object in SmartReferenceStream format 
3) both code and an object.
	File it in and return the object.  Note that self must be a FileStream or RWBinaryOrTextStream.  Maybe ReadWriteStream incorporate RWBinaryOrTextStream?"
	| refStream object |
	self text.
	self peek asciiValue = 4
		ifTrue: [  "pure object file"
			self binary.
			refStream _ SmartRefStream on: self.
			object _ refStream nextAndClose]
		ifFalse: [  "objects mixed with a fileIn"
			self fileInProject.  "reads code and objects, then closes the file"
			self binary.
			object _ SmartRefStream scannedObject].	"set by side effect of one of the chunks"
	SmartRefStream scannedObject: nil.  "clear scannedObject"
	^ object! !

!MultiByteFileStream methodsFor: 'fileIn/Out' stamp: 'ar 7/29/2005 22:33'!
fileInProject

	self setConverterForCodeForProject.
	super fileIn.
! !

!MultiByteFileStream methodsFor: 'fileIn/Out' stamp: 'tak 1/12/2005 14:48'!
fileOutClass: extraClass andObject: theObject 
	self binary.
	UTF8TextConverter writeBOMOn: self.
	self text.
	^ super fileOutClass: extraClass andObject: theObject! !


!MultiByteFileStream methodsFor: 'open/close' stamp: 'md 7/20/2006 11:05'!
open: fileName forWrite: writeMode 
	| result |
	result := super open: fileName forWrite: writeMode.
	result ifNotNil: [
			converter ifNil: [converter := UTF8TextConverter new].
			self detectLineEndConvention].
	^result! !

!MultiByteFileStream methodsFor: 'open/close' stamp: 'yo 8/13/2003 13:51'!
reset

	super reset.
	converter ifNil: [
		converter _ UTF8TextConverter new.
	].
! !


!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/24/2004 13:49'!
next

	| char secondChar state |
	char _ self converter nextFromStream: self.
	self doConversion ifTrue: [
		char == Cr ifTrue: [
			state _ converter saveStateOf: self.
			secondChar _ self bareNext.
			secondChar ifNotNil: [secondChar == Lf ifFalse: [converter restoreStateOf: self with: state]].
		^Cr].
		char == Lf ifTrue: [^Cr].
	].
	^ char.

! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 7/31/2004 18:03'!
next: anInteger 

	| multiString |
	self isBinary ifTrue: [^ super next: anInteger].
	multiString _ String new: anInteger.
	1 to: anInteger do: [:index |
		| character |
		(character _ self next) ifNotNil: [
			multiString at: index put: character
		] ifNil: [
			multiString _ multiString copyFrom: 1 to: index - 1.
			self doConversion ifFalse: [
				^ multiString
			].
			^ self next: anInteger innerFor: multiString.
		]
	].
	self doConversion ifFalse: [
		^ multiString
	].

	multiString _ self next: anInteger innerFor: multiString.
	(multiString size = anInteger or: [self atEnd]) ifTrue: [ ^ multiString].
	^ multiString, (self next: anInteger - multiString size).
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 03:26'!
nextDelimited: terminator

	| out ch save |
	out _ WriteStream on: (String new: 1000).
	self atEnd ifTrue: [^ ''].
	save _ converter saveStateOf: self.

	self next = terminator ifFalse: [
		"absorb initial terminator"
		converter restoreStateOf: self with: save.
	].
	[(ch _ self next) == nil] whileFalse: [
		(ch = terminator) ifTrue: [
			self peek = terminator ifTrue: [
				self next.  "skip doubled terminator"
			] ifFalse: [
				^ out contents  "terminator is not doubled; we're done!!"
			].
		].
		out nextPut: ch.
	].
	^ out contents.
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:13'!
nextMatchAll: aColl

    | save |
    save _ converter saveStateOf: self.
    aColl do: [:each |
       (self next) = each ifFalse: [
            converter restoreStateOf: self with: save.
            ^ false.
		].
	].
    ^ true.
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 03:42'!
nextPut: aCharacter

	aCharacter isInteger ifTrue: [^ super nextPut: aCharacter].
	self doConversion ifTrue: [
		aCharacter = Cr ifTrue: [
			(LineEndStrings at: lineEndConvention) do: [:e | converter nextPut: e toStream: self].
		] ifFalse: [
			converter nextPut: aCharacter toStream: self
		].
		^ aCharacter
	].
	^ self converter nextPut: aCharacter toStream: self
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 5/23/2003 09:40'!
nextPutAll: aCollection

	(self isBinary or: [aCollection class == ByteArray]) ifTrue: [
		^ super nextPutAll: aCollection.
	].
	aCollection do: [:e | self nextPut: e].
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 04:00'!
peek
	"Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil.  "

	| next save |
	self atEnd ifTrue: [^ nil].
	save _ converter saveStateOf: self.
	next _ self next.
	converter restoreStateOf: self with: save.
	^ next.

! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:15'!
peekFor: item 

	| next state |
	"self atEnd ifTrue: [^ false]. -- SFStream will give nil"
	state _ converter saveStateOf: self.
	(next _ self next) == nil ifTrue: [^ false].
	item = next ifTrue: [^ true].
	converter restoreStateOf: self with: state.
	^ false.
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/24/2004 13:35'!
skipSeparators

	| state |
	[self atEnd] whileFalse: [
		state _ converter saveStateOf: self.
		self next isSeparator ifFalse: [
			^ converter restoreStateOf: self with: state]]


"	[self atEnd] whileFalse: [
		self next isSeparator ifFalse: [
			^ self position: self position - converter currentCharSize.
		].
	].
"
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 04:01'!
skipSeparatorsAndPeekNext

	"A special function to make nextChunk fast"
	| peek save |
	[self atEnd] whileFalse: [
		save _ converter saveStateOf: self.
		(peek _ self next) isSeparator ifFalse: [
			converter restoreStateOf: self with: save.
			^ peek.
		].
	].
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:17'!
upTo: delim 

	| out ch |
	out _ WriteStream on: (String new: 1000).
	self atEnd ifTrue: [^ ''].
	[(ch _ self next) isNil] whileFalse: [
		(ch = delim) ifTrue: [
			^ out contents  "terminator is not doubled; we're done!!"
		].
		out nextPut: ch.
	].
	^ out contents.
! !

!MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/30/2002 16:39'!
upToEnd

	| newStream element |
	collection _ self isBinary
				ifTrue: [ByteArray new: 100]
				ifFalse: [String new: 100].
	newStream _ WriteStream on: collection.
	[(element _ self next) notNil]
		whileTrue: [newStream nextPut: element].
	^ newStream contents
! !


!MultiByteFileStream methodsFor: 'remnant' stamp: 'yo 8/28/2002 11:06'!
accepts: aSymbol

 	^ converter accepts: aSymbol.
! !

!MultiByteFileStream methodsFor: 'remnant' stamp: 'yo 8/28/2002 11:09'!
filterFor: aFileStream

	| rw |
	name _ aFileStream name.
	rw _ aFileStream isReadOnly not.
	aFileStream close.
	self open: name forWrite: rw.
	^self.
! !


!MultiByteFileStream methodsFor: 'private' stamp: 'mir 8/25/2004 17:27'!
setConverterForCode

	| current |
	(SourceFiles at: 2)
		ifNotNil: [self fullName = (SourceFiles at: 2) fullName ifTrue: [^ self]].
	current _ self converter saveStateOf: self.
	self position: 0.
	self binary.
	((self next: 3) = (ByteArray with: 16rEF with: 16rBB with: 16rBF)) ifTrue: [
		self converter: UTF8TextConverter new
	] ifFalse: [
		self converter: MacRomanTextConverter new.
	].
	converter restoreStateOf: self with: current.
	self text.
! !

!MultiByteFileStream methodsFor: 'private' stamp: 'ar 7/29/2005 22:33'!
setConverterForCodeForProject

	self converter: UTF8TextConverter new.
! !


!MultiByteFileStream methodsFor: 'private basic' stamp: 'md 10/17/2004 16:09'!
basicNext: anInteger

	^ super next: anInteger.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'!
basicNext: n into: aString

	^ super next: n into: aString.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'!
basicNextInto: aString

	^ super nextInto: aString.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'!
basicNextPut: char

	^ super nextPut: char.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'!
basicNextPutAll: aString

	^ super nextPutAll: aString.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'!
basicPeek

	^ super peek
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'!
basicPosition

	^ super position.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'!
basicPosition: pos

	^ super position: pos.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'!
basicReadInto: byteArray startingAt: startIndex count: count

	^ super readInto: byteArray startingAt: startIndex count: count.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'!
basicSetToEnd

	^ super setToEnd.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'!
basicSkip: n

	^ super skip: n.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'!
basicUpTo: delim

	^ super upTo: delim.
! !

!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:09'!
basicVerbatim: aString

	^ super verbatim: aString.
! !

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

MultiByteFileStream class
	instanceVariableNames: ''!

!MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:45'!
defaultToCR

	"MultiByteFileStream defaultToCR"
	LineEndDefault := #cr.
! !

!MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:45'!
defaultToCRLF

	"MultiByteFileStream defaultToCRLF"
	LineEndDefault := #crlf.! !

!MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:46'!
defaultToLF

	"MultiByteFileStream defaultToLF"
	LineEndDefault := #lf.
! !

!MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:44'!
guessDefaultLineEndConvention

	"Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory."
	FileDirectory pathNameDelimiter = $: ifTrue:[^self defaultToCR].
	FileDirectory pathNameDelimiter = $/ ifTrue:[^self defaultToLF].
	FileDirectory pathNameDelimiter = $\ ifTrue:[^self defaultToCRLF].
	"in case we don't know"
	^self defaultToCR.
! !

!MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:44'!
initialize

	"MultiByteFileStream initialize"
	Cr := Character cr.
	Lf := Character lf.
	CrLf := String with: Cr with: Lf.
	LineEndStrings := Dictionary new.
	LineEndStrings at: #cr put: (String with: Character cr).
	LineEndStrings at: #lf put: (String with: Character lf).
	LineEndStrings at: #crlf put: (String with: Character cr with: Character lf).
	LookAheadCount := 2048.
	Smalltalk addToStartUpList: self.
	self startUp.
! !

!MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:44'!
startUp

	self guessDefaultLineEndConvention.
! !


!MultiByteFileStream class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 11:43'!
newFrom: aFileStream

	| rw n |
	n _ aFileStream name.
	rw _ aFileStream isReadOnly not.
	aFileStream close.
	^self new open: n forWrite: rw.
! !
PluggableCanvas subclass: #MultiCanvas
	instanceVariableNames: 'canvases extent depth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!MultiCanvas commentStamp: '<historical>' prior: 0!
A canvas which forwards drawing commands to sub-canvases.!


!MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'!
addCanvas: aCanvas
	canvases add: aCanvas! !

!MultiCanvas methodsFor: 'accessing' stamp: 'RAA 11/7/2000 17:46'!
clipRect
	
	^super clipRect ifNil: [
		0@0 extent: 5000@5000
	].! !

!MultiCanvas methodsFor: 'accessing' stamp: 'RAA 8/14/2000 10:27'!
contentsOfArea: aRectangle into: aForm

	self apply: [ :c |
		(c isKindOf: FormCanvas) ifTrue: [
			c contentsOfArea: aRectangle into: aForm.
			^aForm
		].
	].
	self apply: [ :c |
		c contentsOfArea: aRectangle into: aForm.
		^aForm.
	].
	^aForm! !

!MultiCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:35'!
depth
	^depth! !

!MultiCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:35'!
extent
	^extent! !

!MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'!
removeCanvas: aCanvas
	canvases remove: aCanvas ifAbsent: []! !


!MultiCanvas methodsFor: 'initialization' stamp: 'RAA 8/1/2000 13:50'!
allocateForm: extentPoint
	"Allocate a new form which is similar to the receiver and can be used for accelerated blts"
	^Form extent: extentPoint depth: self depth! !

!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:35'!
depth: newDepth
	"set the extent to be used with this canvas"
	depth := newDepth.! !

!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:34'!
extent: newExtent
	"set the extent to be used with this canvas"
	extent := newExtent.! !

!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:34'!
initialize
	canvases := Set new.
	extent := 600@400.
	depth := 32. ! !


!MultiCanvas methodsFor: 'private' stamp: 'RAA 11/6/2000 14:17'!
apply: aCommand

	self flag: #roundedRudeness.	
	"This rudeness is to help get rounded corners to work right on RemoteCanvases. Since the RemoteCanvas has no other way to read its bits, we are grabbing them from Display for now. To support this, we need to see that the Display is written before any RemoteCanvases"

	canvases do: [ :canvas | 
		(canvas isKindOf: FormCanvas) ifTrue: [aCommand value: canvas]
	].
	canvases do: [ :canvas | 
		(canvas isKindOf: FormCanvas) ifFalse: [aCommand value: canvas]
	].
! !
MultiCharacterScanner subclass: #MultiCanvasCharacterScanner
	instanceVariableNames: 'canvas fillBlt foregroundColor runX lineY'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Scanning'!

!MultiCanvasCharacterScanner methodsFor: 'accessing' stamp: 'yo 12/18/2002 13:55'!
canvas: aCanvas
	"set the canvas to draw on"
	canvas ifNotNil: [ self inform: 'initializing twice!!' ].
	canvas _ aCanvas! !


!MultiCanvasCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:55'!
displayLine: textLine  offset: offset  leftInRun: leftInRun
	|  nowLeftInRun done startLoc startIndex stopCondition |
	"largely copied from DisplayScanner's routine"

	line _ textLine.
	foregroundColor ifNil: [ foregroundColor _ Color black ].
	leftMargin _ (line leftMarginForAlignment: alignment) + offset x.

	rightMargin _ line rightMargin + offset x.
	lineY _ line top + offset y.
	lastIndex _ textLine first.
	leftInRun <= 0
		ifTrue: [self setStopConditions.  "also sets the font"
				nowLeftInRun _ text runLengthFor: lastIndex]
		ifFalse: [nowLeftInRun _ leftInRun].
	runX _ destX _ leftMargin.

	runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last.
	spaceCount _ 0.
	done _ false.

	[done] whileFalse: [
		"remember where this portion of the line starts"
		startLoc _ destX@destY.
		startIndex _ lastIndex.

		"find the end of this portion of the line"
		stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
						in: text string rightX: rightMargin stopConditions: stopConditions
						kern: kern "displaying: false".

		"display that portion of the line"
		canvas drawString: text string
			from: startIndex to: lastIndex
			at: startLoc
			font: font
			color: foregroundColor.

		"handle the stop condition"
		done _ self perform: stopCondition
	].

	^runStopIndex - lastIndex! !


!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	lastIndex_ lastIndex + 1.
	^false! !

!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'!
crossedX
	"This condition will sometimes be reached 'legally' during display, when, 
	for instance the space that caused the line to wrap actually extends over 
	the right boundary. This character is allowed to display, even though it 
	is technically outside or straddling the clipping ectangle since it is in 
	the normal case not visible and is in any case appropriately clipped by 
	the scanner."

	"self fillLeading."
	^ true ! !

!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'!
endOfRun
	"The end of a run in the display case either means that there is actually 
	a change in the style (run code) to be associated with the string or the 
	end of this line has been reached."
	| runLength |

	lastIndex = line last ifTrue: [^true].
	runX _ destX.
	runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
	runStopIndex _ lastIndex + (runLength - 1) min: line last.
	self setStopConditions.
	^ false! !

!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'!
paddedSpace
	"Each space is a stop condition when the alignment is right justified. 
	Padding must be added to the base width of the space according to 
	which space in the line this space is and according to the amount of 
	space that remained at the end of the line when it was composed."

	destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).

	lastIndex _ lastIndex + 1.
	^ false! !

!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (textStyle alignment = Justified ifTrue: [#paddedSpace]).
! !

!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'!
tab

	destX _ (alignment == Justified and: [self leadingTab not])
		ifTrue:		"imbedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse: 
			[textStyle nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin].

	lastIndex _ lastIndex + 1.
	^ false! !


!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:55'!
doesDisplaying
	^false   "it doesn't do displaying using copyBits"! !

!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 1/6/2005 23:00'!
setFont
	foregroundColor ifNil: [foregroundColor _ Color black].
	super setFont.
	baselineY _ lineY + line baseline.
	destY _ baselineY - font ascent.! !

!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:55'!
textColor: color
	foregroundColor _ color! !
MultiCharacterScanner subclass: #MultiCharacterBlockScanner
	instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Scanning'!

!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:56'!
characterBlockAtPoint: aPoint in: aParagraph
	"Answer a CharacterBlock for character in aParagraph at point aPoint. It 
	is assumed that aPoint has been transformed into coordinates appropriate 
	to the text's destination form rectangle and the composition rectangle."

	self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle.
	characterPoint _ aPoint.
	^self buildCharacterBlockIn: aParagraph! !

!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'nk 11/22/2004 14:36'!
characterBlockAtPoint: aPoint index: index in: textLine
	"This method is the Morphic characterBlock finder.  It combines
	MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:"
	| runLength lineStop done stopCondition |
	line := textLine.
	rightMargin := line rightMargin.
	lastIndex := line first.
	self setStopConditions.		"also sets font"
	characterIndex := index.  " == nil means scanning for point"
	characterPoint := aPoint.
	(characterPoint isNil or: [characterPoint y > line bottom])
		ifTrue: [characterPoint := line bottomRight].
	(text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left])
				or: [characterIndex notNil and: [characterIndex < line first]]])
		ifTrue:	[^ (CharacterBlock new stringIndex: line first text: text
					topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid)
					textLine: line].
	destX := leftMargin := line leftMarginForAlignment: alignment.
	destY := line top.
	runLength := text runLengthFor: line first.
	characterIndex
		ifNotNil:	[lineStop := characterIndex  "scanning for index"]
		ifNil:	[lineStop := line last  "scanning for point"].
	runStopIndex := lastIndex + (runLength - 1) min: lineStop.
	lastCharacterExtent := 0 @ line lineHeight.
	spaceCount := 0.

	done  := false.
	[done] whileFalse:
		[stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.
		"see setStopConditions for stopping conditions for character block 	operations."
		self lastCharacterExtentSetX: (specialWidth
			ifNil: [font widthOf: (text at: lastIndex)]
			ifNotNil: [specialWidth]).
		(self perform: stopCondition) ifTrue:
			[characterIndex
				ifNil: [
					"Result for characterBlockAtPoint: "
					(stopCondition ~~ #cr and: [ lastIndex == line last
						and: [ aPoint x > ((characterPoint x) + (lastCharacterExtent x / 2)) ]])
							ifTrue: [ "Correct for right half of last character in line"
								^ (CharacterBlock new stringIndex: lastIndex + 1
										text: text
										topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0)
										extent:  0 @ lastCharacterExtent y)
									textLine: line ].
						^ (CharacterBlock new stringIndex: lastIndex
							text: text topLeft: characterPoint + (font descentKern @ 0)
							extent: lastCharacterExtent - (font baseKern @ 0))
									textLine: line]
				ifNotNil: ["Result for characterBlockForIndex: "
						^ (CharacterBlock new stringIndex: characterIndex
							text: text topLeft: characterPoint + ((font descentKern) - kern @ 0)
							extent: lastCharacterExtent)
									textLine: line]]]! !

!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:56'!
characterBlockForIndex: targetIndex in: aParagraph 
	"Answer a CharacterBlock for character in aParagraph at targetIndex. The 
	coordinates in the CharacterBlock will be appropriate to the intersection 
	of the destination form rectangle and the composition rectangle."

	self 
		initializeFromParagraph: aParagraph 
		clippedBy: aParagraph clippingRectangle.
	characterIndex _ targetIndex.
	characterPoint _ 
		aParagraph rightMarginForDisplay @ 
			(aParagraph topAtLineIndex: 
				(aParagraph lineIndexOfCharacterIndex: characterIndex)).
	^self buildCharacterBlockIn: aParagraph! !

!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:56'!
indentationLevel: anInteger
	super indentationLevel: anInteger.
	nextLeftMargin _ leftMargin.
	indentationLevel timesRepeat: [
		nextLeftMargin _ textStyle nextTabXFrom: nextLeftMargin
					leftMargin: leftMargin
					rightMargin: rightMargin]! !

!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:56'!
placeEmbeddedObject: anchoredMorph
	"Workaround: The following should really use #textAnchorType"
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	specialWidth _ anchoredMorph width.
	^ true! !

!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 8/6/2003 05:55'!
scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| encoding f nextDestX maxAscii startEncoding char charValue |
	lastIndex _ startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
	startEncoding _ (sourceString at: startIndex) leadingChar.
	font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
	((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
		[f _ font fontArray at: startEncoding + 1]
			on: Exception do: [:ex | f _ font fontArray at: 1].
		f ifNil: [ f _ font fontArray at: 1].
		maxAscii _ f maxAscii.
		spaceWidth _ f widthOf: Space.
	] ifFalse: [
		maxAscii _ font maxAscii.
	].

	[lastIndex <= stopIndex] whileTrue: [
		encoding _ (sourceString at: lastIndex) leadingChar.
		encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
		char _ (sourceString at: lastIndex).
		charValue _ char charCode.
		charValue > maxAscii ifTrue: [charValue _ maxAscii].
		(encoding = 0 and: [(stopConditions at: charValue + 1) ~~ nil]) ifTrue: [
			^ stops at: charValue + 1
		].
		nextDestX _ destX + (self widthOf: char inFont: font).
		nextDestX > rightX ifTrue: [^ stops at: CrossedX].
		destX _ nextDestX + kernDelta.
		lastIndex _ lastIndex + 1.
	].
	lastIndex _ stopIndex.
	^ stops at: EndOfRun! !


!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 1/6/2005 22:55'!
cr 
	"Answer a CharacterBlock that specifies the current location of the mouse 
	relative to a carriage return stop condition that has just been 
	encountered. The ParagraphEditor convention is to denote selections by 
	CharacterBlocks, sometimes including the carriage return (cursor is at 
	the end) and sometimes not (cursor is in the middle of the text)."

	((characterIndex ~= nil
		and: [characterIndex > text size])
			or: [(line last = text size)
				and: [(destY + line lineHeight) < characterPoint y]])
		ifTrue:	["When off end of string, give data for next character"
				destY _ destY +  line lineHeight.
				baselineY _ line lineHeight.
				lastCharacter _ nil.
				characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ destY.
				lastIndex _ lastIndex + 1.
				self lastCharacterExtentSetX: 0.
				^ true].
		lastCharacter _ CR.
		characterPoint _ destX @ destY.
		self lastCharacterExtentSetX: rightMargin - destX.
		^true! !

!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'!
crossedX
	"Text display has wrapping. The scanner just found a character past the x 
	location of the cursor. We know that the cursor is pointing at a character 
	or before one."

	| leadingTab currentX |
	characterIndex == nil ifFalse: [
		"If the last character of the last line is a space,
		and it crosses the right margin, then locating
		the character block after it is impossible without this hack."
		characterIndex > text size ifTrue: [
			lastIndex _ characterIndex.
			characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight).
			^true]].
	characterPoint x <= (destX + (lastCharacterExtent x // 2))
		ifTrue:	[lastCharacter _ (text at: lastIndex).
				characterPoint _ destX @ destY.
				^true].
	lastIndex >= line last 
		ifTrue:	[lastCharacter _ (text at: line last).
				characterPoint _ destX @ destY.
				^true].

	"Pointing past middle of a character, return the next character."
	lastIndex _ lastIndex + 1.
	lastCharacter _ text at: lastIndex.
	currentX _ destX + lastCharacterExtent x + kern.
	self lastCharacterExtentSetX: (font widthOf: lastCharacter).
	characterPoint _ currentX @ destY.
	lastCharacter = Space ifFalse: [^ true].

	"Yukky if next character is space or tab."
	alignment = Justified ifTrue:
		[self lastCharacterExtentSetX:
			(lastCharacterExtent x + 	(line justifiedPadFor: (spaceCount + 1))).
		^ true].

	true ifTrue: [^ true].
	"NOTE:  I find no value to the following code, and so have defeated it - DI"

	"See tabForDisplay for illumination on the following awfulness."
	leadingTab _ true.
	line first to: lastIndex - 1 do:
		[:index | (text at: index) ~= Tab ifTrue: [leadingTab _ false]].
	(alignment ~= Justified or: [leadingTab])
		ifTrue:	[self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX
					leftMargin: leftMargin rightMargin: rightMargin) -
						currentX]
		ifFalse:	[self lastCharacterExtentSetX:  (((currentX + (textStyle tabWidth -
						(line justifiedTabDeltaFor: spaceCount))) -
							currentX) max: 0)].
	^ true! !

!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'!
endOfRun
	"Before arriving at the cursor location, the selection has encountered an 
	end of run. Answer false if the selection continues, true otherwise. Set 
	up indexes for building the appropriate CharacterBlock."

	| runLength lineStop |
	(((characterIndex ~~ nil and:
		[runStopIndex < characterIndex and: [runStopIndex < text size]])
			or:	[characterIndex == nil and: [lastIndex < line last]]) or: [
				((lastIndex < line last)
				and: [((text at: lastIndex) leadingChar ~= (text at: lastIndex+1) leadingChar)
					and: [lastIndex ~= characterIndex]])])
		ifTrue:	["We're really at the end of a real run."
				runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
				characterIndex ~~ nil
					ifTrue:	[lineStop _ characterIndex	"scanning for index"]
					ifFalse:	[lineStop _ line last			"scanning for point"].
				(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
					ifTrue: 	[runStopIndex _ lineStop].
				self setStopConditions.
				^false].

	lastCharacter _ text at: lastIndex.
	characterPoint _ destX @ destY.
	((lastCharacter = Space and: [alignment = Justified])
		or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]])
		ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent].
	characterIndex ~~ nil
		ifTrue:	["If scanning for an index and we've stopped on that index,
				then we back destX off by the width of the character stopped on
				(it will be pointing at the right side of the character) and return"
				runStopIndex = characterIndex
					ifTrue:	[self characterPointSetX: destX - lastCharacterExtent x.
							^true].
				"Otherwise the requested index was greater than the length of the
				string.  Return string size + 1 as index, indicate further that off the
				string by setting character to nil and the extent to 0."
				lastIndex _  lastIndex + 1.
				lastCharacter _ nil.
				self lastCharacterExtentSetX: 0.
				^true].

	"Scanning for a point and either off the end of the line or off the end of the string."
	runStopIndex = text size
		ifTrue:	["off end of string"
				lastIndex _  lastIndex + 1.
				lastCharacter _ nil.
				self lastCharacterExtentSetX: 0.
				^true].
	"just off end of line without crossing x"
	lastIndex _ lastIndex + 1.
	^true! !

!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'!
paddedSpace
	"When the line is justified, the spaces will not be the same as the font's 
	space character. A padding of extra space must be considered in trying 
	to find which character the cursor is pointing at. Answer whether the 
	scanning has crossed the cursor."

	| pad |
	pad _ 0.
	spaceCount _ spaceCount + 1.
	pad _ line justifiedPadFor: spaceCount.
	lastSpaceOrTabExtent _ lastCharacterExtent copy.
	self lastSpaceOrTabExtentSetX:  spaceWidth + pad.
	(destX + lastSpaceOrTabExtent x)  >= characterPoint x
		ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy.
				^self crossedX].
	lastIndex _ lastIndex + 1.
	destX _ destX + lastSpaceOrTabExtent x.
	^ false
! !

!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'!
setFont
	specialWidth _ nil.
	super setFont! !

!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:31'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]).
! !

!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'!
tab
	| currentX |
	currentX _ (alignment == Justified and: [self leadingTab not])
		ifTrue:		"imbedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse:
			[textStyle
				nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin].
	lastSpaceOrTabExtent _ lastCharacterExtent copy.
	self lastSpaceOrTabExtentSetX: (currentX - destX max: 0).
	currentX >= characterPoint x
		ifTrue: 
			[lastCharacterExtent _ lastSpaceOrTabExtent copy.
			^ self crossedX].
	destX _ currentX.
	lastIndex _ lastIndex + 1.
	^false! !


!MultiCharacterBlockScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:56'!
buildCharacterBlockIn: para
	| lineIndex runLength lineStop done stopCondition |
	"handle nullText"
	(para numberOfLines = 0 or: [text size = 0])
		ifTrue:	[^ CharacterBlock new stringIndex: 1  "like being off end of string"
					text: para text
					topLeft: (para leftMarginForDisplayForLine: 1 alignment: (alignment ifNil:[textStyle alignment]))
								@ para compositionRectangle top
					extent: 0 @ textStyle lineGrid].
	"find the line"
	lineIndex _ para lineIndexOfTop: characterPoint y.
	destY _ para topAtLineIndex: lineIndex.
	line _ para lines at: lineIndex.
	rightMargin _ para rightMarginForDisplay.

	(lineIndex = para numberOfLines and:
		[(destY + line lineHeight) < characterPoint y])
			ifTrue:	["if beyond lastLine, force search to last character"
					self characterPointSetX: rightMargin]
			ifFalse:	[characterPoint y < (para compositionRectangle) top
						ifTrue: ["force search to first line"
								characterPoint _ (para compositionRectangle) topLeft].
					characterPoint x > rightMargin
						ifTrue:	[self characterPointSetX: rightMargin]].
	destX _ (leftMargin _ para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])).
	nextLeftMargin_ para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]).
	lastIndex _ line first.

	self setStopConditions.		"also sets font"
	runLength _ (text runLengthFor: line first).
	characterIndex == nil
		ifTrue:	[lineStop _ line last  "characterBlockAtPoint"]
		ifFalse:	[lineStop _ characterIndex  "characterBlockForIndex"].
	(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
		ifTrue:	[runStopIndex _ lineStop].
	lastCharacterExtent _ 0 @ line lineHeight.
	spaceCount _ 0. done  _ false.
	self handleIndentation.

	[done]
	whileFalse:
	[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.

	"see setStopConditions for stopping conditions for character block 	operations."
	self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)).
	(self perform: stopCondition) ifTrue:
		[characterIndex == nil
			ifTrue: ["characterBlockAtPoint"
					^ CharacterBlock new stringIndex: lastIndex text: text
						topLeft: characterPoint + (font descentKern @ 0)
						extent: lastCharacterExtent]
			ifFalse: ["characterBlockForIndex"
					^ CharacterBlock new stringIndex: lastIndex text: text
						topLeft: characterPoint + ((font descentKern) - kern @ 0)
						extent: lastCharacterExtent]]]! !

!MultiCharacterBlockScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:56'!
characterPointSetX: xVal
	characterPoint _ xVal @ characterPoint y! !

!MultiCharacterBlockScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:56'!
lastCharacterExtentSetX: xVal
	lastCharacterExtent _ xVal @ lastCharacterExtent y! !

!MultiCharacterBlockScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:56'!
lastSpaceOrTabExtentSetX: xVal
	lastSpaceOrTabExtent _ xVal @ lastSpaceOrTabExtent y! !
Object subclass: #MultiCharacterScanner
	instanceVariableNames: 'destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks presentation presentationLine numOfComposition baselineY firstDestX'
	classVariableNames: 'DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition'
	poolDictionaries: 'TextConstants'
	category: 'Multilingual-Scanning'!

!MultiCharacterScanner methodsFor: 'initialize' stamp: 'yo 12/18/2002 13:53'!
initialize
	destX _ destY _ leftMargin _ 0.! !

!MultiCharacterScanner methodsFor: 'initialize' stamp: 'yo 12/18/2002 13:53'!
initializeStringMeasurer
	stopConditions _ Array new: 258.
	stopConditions at: CrossedX put: #crossedX.
	stopConditions at: EndOfRun put: #endOfRun.
! !

!MultiCharacterScanner methodsFor: 'initialize' stamp: 'yo 12/18/2002 13:53'!
wantsColumnBreaks: aBoolean

	wantsColumnBreaks _ aBoolean! !


!MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/3/2003 12:09'!
addCharToPresentation: char

! !

!MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 16:15'!
registerBreakableIndex

	"Record left x and character index of the line-wrappable point. 
	The default implementation here does nothing."

	^ false.
! !

!MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/23/2003 14:25'!
removeLastCharFromPresentation
! !

!MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/1/2003 10:43'!
widthOf: char inFont: aFont

	(char isMemberOf: CombinedChar) ifTrue: [
		^ aFont widthOf: char base.
	] ifFalse: [
		^ aFont widthOf: char.
	].


! !


!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/18/2002 13:53'!
basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
	"Primitive. This is the inner loop of text display--but see 
	scanCharactersFrom: to:rightX: which would get the string, 
	stopConditions and displaying from the instance. March through source 
	String from startIndex to stopIndex. If any character is flagged with a 
	non-nil entry in stops, then return the corresponding value. Determine 
	width of each character from xTable, indexed by map. 
	If dextX would exceed rightX, then return stops at: 258. 
	Advance destX by the width of the character. If stopIndex has been
	reached, then return stops at: 257. Optional. 
	See Object documentation whatIsAPrimitive."
	| ascii nextDestX char |
	<primitive: 103>
	lastIndex _ startIndex.
	[lastIndex <= stopIndex]
		whileTrue: 
			[char _ (sourceString at: lastIndex).
			ascii _ char asciiValue + 1.
			(stops at: ascii) == nil ifFalse: [^stops at: ascii].
			"Note: The following is querying the font about the width
			since the primitive may have failed due to a non-trivial
			mapping of characters to glyphs or a non-existing xTable."
			nextDestX _ destX + (font widthOf: char).
			nextDestX > rightX ifTrue: [^stops at: CrossedX].
			destX _ nextDestX + kernDelta.
			lastIndex _ lastIndex + 1].
	lastIndex _ stopIndex.
	^stops at: EndOfRun! !

!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/30/2002 22:59'!
combinableChar: char for: prevEntity

! !

!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/20/2002 11:46'!
isBreakableAt: index in: sourceString in: encodingClass

	^ encodingClass isBreakableAt: index in: sourceString.
! !

!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/16/2005 19:03'!
scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| ascii encoding f nextDestX maxAscii startEncoding |
	lastIndex _ startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
	startEncoding _ (sourceString at: startIndex) leadingChar.
	font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
	((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
		[f _ font fontArray at: startEncoding + 1]
			on: Exception do: [:ex | f _ font fontArray at: 1].
		f ifNil: [ f _ font fontArray at: 1].
		maxAscii _ f maxAscii.
		"xTable _ f xTable.
		maxAscii _ xTable size - 2."
		spaceWidth _ f widthOf: Space.
	] ifFalse: [
		(font isMemberOf: HostFont) ifTrue: [
			f _ font.
			maxAscii _ f maxAscii.
			spaceWidth _ f widthOf: Space.
		] ifFalse: [
			maxAscii _ font maxAscii.
		].
	].
	[lastIndex <= stopIndex] whileTrue: [
		"self halt."
		encoding _ (sourceString at: lastIndex) leadingChar.
		encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
		ascii _ (sourceString at: lastIndex) charCode.
		ascii > maxAscii ifTrue: [ascii _ maxAscii].
		(encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1].
		(self isBreakableAt: lastIndex in: sourceString in: (EncodedCharSet charsetAt: encoding)) ifTrue: [
			self registerBreakableIndex.
		].
		nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)).
		nextDestX > rightX ifTrue: [firstDestX ~= destX ifTrue: [^ stops at: CrossedX]].
		destX _ nextDestX + kernDelta.
		lastIndex _ lastIndex + 1.
	].
	lastIndex _ stopIndex.
	^ stops at: EndOfRun! !

!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/16/2005 19:09'!
scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| charCode encoding f maxAscii startEncoding combining combined combiningIndex c |
	lastIndex _ startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
	startEncoding _ (sourceString at: startIndex) leadingChar.
	font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
	((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
		[f _ font fontArray at: startEncoding + 1]
			on: Exception do: [:ex | f _ font fontArray at: 1].
		f ifNil: [ f _ font fontArray at: 1].
		maxAscii _ f maxAscii.
		spaceWidth _ font widthOf: Space.
	] ifFalse: [
		maxAscii _ font maxAscii.
		spaceWidth _ font widthOf: Space.
	].

	combining _ nil.
	[lastIndex <= stopIndex] whileTrue: [
		charCode _ (sourceString at: lastIndex) charCode.
		c _ (sourceString at: lastIndex).
		combining ifNil: [
			combining _ CombinedChar new.
			combining add: c.
			combiningIndex _ lastIndex.
			lastIndex _ lastIndex + 1.
		] ifNotNil: [
			(combining add: c) ifFalse: [
				self addCharToPresentation: (combined _ combining combined).
				combining _ CombinedChar new.
				combining add: c.
				charCode _ combined charCode.
				encoding _ combined leadingChar.
				encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1.
					(encoding = 0 and: [(stopConditions at: charCode + 1) ~~ nil]) ifTrue: [
						^ stops at: charCode + 1
					] ifFalse: [
						 ^ stops at: EndOfRun
					].
				].
				charCode > maxAscii ifTrue: [charCode _ maxAscii].
				""
				(encoding = 0 and: [(stopConditions at: charCode + 1) ~~ nil]) ifTrue: [
					combining ifNotNil: [
						self addCharToPresentation: (combining combined).
					].
					^ stops at: charCode + 1
				].
				(self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [
					self registerBreakableIndex.
				].		
				destX > rightX ifTrue: [
					destX ~= firstDestX ifTrue: [
						lastIndex _ combiningIndex.
						self removeLastCharFromPresentation.
						^ stops at: CrossedX]].
				combiningIndex _ lastIndex.
				lastIndex _ lastIndex + 1.
			] ifTrue: [
				lastIndex _ lastIndex + 1.
				numOfComposition _ numOfComposition + 1.
			].
		].
	].
	lastIndex _ stopIndex.
	combining ifNotNil: [
		combined _ combining combined.
		self addCharToPresentation: combined.
		"assuming that there is always enough space for at least one character".
		destX _ destX + (self widthOf: combined inFont: font).
	].
	^ stops at: EndOfRun! !

!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/16/2005 19:08'!
scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| ascii encoding f nextDestX maxAscii startEncoding |
	lastIndex _ startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
	startEncoding _ (sourceString at: startIndex) leadingChar.
	font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
	((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
		[f _ font fontArray at: startEncoding + 1]
			on: Exception do: [:ex | f _ font fontArray at: 1].
		f ifNil: [ f _ font fontArray at: 1].
		maxAscii _ f maxAscii.
		spaceWidth _ f widthOf: Space.
	] ifFalse: [
		maxAscii _ font maxAscii.
	].

	[lastIndex <= stopIndex] whileTrue: [
		encoding _ (sourceString at: lastIndex) leadingChar.
		encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
		ascii _ (sourceString at: lastIndex) charCode.
		ascii > maxAscii ifTrue: [ascii _ maxAscii].
		(encoding = 0 and: [ascii < stopConditions size and: [(stopConditions at: ascii + 1) ~~ nil]]) ifTrue: [^ stops at: ascii + 1].
		(self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [
			self registerBreakableIndex.
		].
		nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)).
		nextDestX > rightX ifTrue: [destX ~= firstDestX ifTrue: [^ stops at: CrossedX]].
		destX _ nextDestX + kernDelta.
		lastIndex _ lastIndex + 1.
	].
	lastIndex _ stopIndex.
	^ stops at: EndOfRun! !

!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/16/2005 19:08'!
scanMultiCharactersR2LFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	"Note that 'rightX' really means 'endX' in R2L context.  Ie.  rightX is usually smaller than destX."
	| ascii encoding f nextDestX maxAscii startEncoding |
	lastIndex _ startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
	startEncoding _ (sourceString at: startIndex) leadingChar.
	font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
	((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
		[f _ font fontArray at: startEncoding + 1]
			on: Exception do: [:ex | f _ font fontArray at: 1].
		f ifNil: [ f _ font fontArray at: 1].
		maxAscii _ f maxAscii.
		spaceWidth _ f widthOf: Space.
	] ifFalse: [
		maxAscii _ font maxAscii.
	].

	[lastIndex <= stopIndex] whileTrue: [
		encoding _ (sourceString at: lastIndex) leadingChar.
		encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
		ascii _ (sourceString at: lastIndex) charCode.
		ascii > maxAscii ifTrue: [ascii _ maxAscii].
		(encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1].
		(self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [
			self registerBreakableIndex.
		].
		nextDestX _ destX - (font widthOf: (sourceString at: lastIndex)).
		nextDestX < rightX ifTrue: [^ stops at: CrossedX].
		destX _ nextDestX - kernDelta.
		lastIndex _ lastIndex + 1.
	].
	lastIndex _ stopIndex.
	^ stops at: EndOfRun! !


!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'!
columnBreak

	^true! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'!
embeddedObject
	| savedIndex |
	savedIndex _ lastIndex.
	text attributesAt: lastIndex do:[:attr| 
		attr anchoredMorph ifNotNil:[
			"Following may look strange but logic gets reversed.
			If the morph fits on this line we're not done (return false for true) 
			and if the morph won't fit we're done (return true for false)"
			(self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^true]]].
	lastIndex _ savedIndex + 1. "for multiple(!!) embedded morphs"
	^false! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'!
handleIndentation
	self indentationLevel timesRepeat: [
		self plainTab]! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'!
indentationLevel
	"return the number of tabs that are currently being placed at the beginning of each line"
	^indentationLevel ifNil:[0]! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'!
indentationLevel: anInteger
	"set the number of tabs to put at the beginning of each line"
	indentationLevel _ anInteger! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'!
leadingTab
	"return true if only tabs lie to the left"
	line first to: lastIndex do:
		[:i | (text at: i) == Tab ifFalse: [^ false]].
	^ true! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 1/18/2005 08:08'!
measureString: aString inFont: aFont from: startIndex to: stopIndex
	"WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer"
	destX _ destY _ lastIndex _ 0.
	baselineY _ aFont ascent.
	xTable _ aFont xTable.
	font := aFont.  " added Dec 03, 2004 "
"	map _ aFont characterToGlyphMap."
	self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0.
	^destX! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'!
placeEmbeddedObject: anchoredMorph
	"Place the anchoredMorph or return false if it cannot be placed.
	In any event, advance destX by its width."
	| w |
	"Workaround: The following should really use #textAnchorType"
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	destX _ destX + (w _ anchoredMorph width).
	(destX > rightMargin and: [(leftMargin + w) <= rightMargin])
		ifTrue: ["Won't fit, but would on next line"
				^ false].
	lastIndex _ lastIndex + 1.
	self setFont.  "Force recalculation of emphasis for next run"
	^ true! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'!
plainTab
	"This is the basic method of adjusting destX for a tab."
	destX _ (alignment == Justified and: [self leadingTab not])
		ifTrue:		"embedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse: 
			[textStyle nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin]! !

!MultiCharacterScanner methodsFor: 'scanning' stamp: 'ar 4/12/2005 19:53'!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| startEncoding selector |
	(sourceString isByteString) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.].

	(sourceString isWideString) ifTrue: [
		startIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
		startEncoding _  (sourceString at: startIndex) leadingChar.
		selector _ (EncodedCharSet charsetAt: startEncoding) scanSelector.
		^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stopConditions with: kernDelta).
	].
	
	^ stops at: EndOfRun
! !


!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'!
addEmphasis: code
	"Set the bold-ital-under-strike emphasis."
	emphasisCode _ emphasisCode bitOr: code! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'!
addKern: kernDelta
	"Set the current kern amount."
	kern _ kern + kernDelta! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	text _ aParagraph text.
	textStyle _ aParagraph textStyle. 
! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'!
setActualFont: aFont
	"Set the basal font to an isolated font reference."

	font _ aFont! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'!
setAlignment: style
	alignment _ style.
	! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/19/2002 02:05'!
setConditionArray: aSymbol

	aSymbol == #paddedSpace ifTrue: [^stopConditions _ PaddedSpaceCondition "copy"].
	"aSymbol == #space ifTrue: [^stopConditions _ SpaceCondition copy]."
	aSymbol == nil ifTrue: [^stopConditions _ NilCondition "copy"].
	self error: 'undefined stopcondition for space character'.
! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'tak 12/19/2004 15:45'!
setFont
	| priorFont |
	"Set the font and other emphasis."
	priorFont _ font.
	text == nil ifFalse:[
		emphasisCode _ 0.
		kern _ 0.
		indentationLevel _ 0.
		alignment _ textStyle alignment.
		font _ nil.
		(text attributesAt: lastIndex forStyle: textStyle)
			do: [:att | att emphasizeScanner: self]].
	font == nil ifTrue:
		[self setFont: textStyle defaultFontIndex].
	font _ font emphasized: emphasisCode.
	priorFont ifNotNil: [destX _ destX + priorFont descentKern].
	destX _ destX - font descentKern.
	"NOTE: next statement should be removed when clipping works"
	leftMargin ifNotNil: [destX _ destX max: leftMargin].
	kern _ kern - font baseKern.

	"Install various parameters from the font."
	spaceWidth _ font widthOf: Space.
	xTable _ font xTable.
"	map _ font characterToGlyphMap."
	stopConditions _ DefaultStopConditions.! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'!
setFont: fontNumber
	"Set the font by number from the textStyle."

	self setActualFont: (textStyle fontAt: fontNumber)! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'!
text: t textStyle: ts
	text _ t.
	textStyle _ ts! !

!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'!
textColor: ignored
	"Overridden in DisplayScanner"! !

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

MultiCharacterScanner class
	instanceVariableNames: ''!

!MultiCharacterScanner class methodsFor: 'class initialization' stamp: 'yo 12/18/2002 14:09'!
initialize
"
	MultiCharacterScanner initialize
"
	| a |
	a _ Array new: 258.
	a at: 1 + 1 put: #embeddedObject.
	a at: Tab asciiValue + 1 put: #tab.
	a at: CR asciiValue + 1 put: #cr.
	a at: EndOfRun put: #endOfRun.
	a at: CrossedX put: #crossedX.
	NilCondition _ a copy.
	DefaultStopConditions _ a copy.

	PaddedSpaceCondition _ a copy.
	PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace.
	
	SpaceCondition _ a copy.
	SpaceCondition at: Space asciiValue + 1 put: #space.
! !
MultiCharacterScanner subclass: #MultiCompositionScanner
	instanceVariableNames: 'spaceX lineHeight baseline breakableIndex lineHeightAtBreak baselineAtBreak breakAtSpace lastWidth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Scanning'!

!MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 1/3/2003 02:33'!
presentation

	^ presentation.
! !

!MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 1/3/2003 02:33'!
presentationLine

	^ presentationLine.
! !

!MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 12/18/2002 14:56'!
rightX
	"Meaningful only when a line has just been composed -- refers to the 
	line most recently composed. This is a subtrefuge to allow for easy 
	resizing of a composition rectangle to the width of the maximum line. 
	Useful only when there is only one line in the form or when each line 
	is terminated by a carriage return. Handy for sizing menus and lists."

	breakAtSpace ifTrue: [^ spaceX].

	^ destX.
! !


!MultiCompositionScanner methodsFor: 'intialize-release' stamp: 'yo 12/18/2002 13:57'!
forParagraph: aParagraph
	"Initialize the receiver for scanning the given paragraph."

	self
		initializeFromParagraph: aParagraph
		clippedBy: aParagraph clippingRectangle.
! !


!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 2/10/2004 23:00'!
addCharToPresentation: char

	presentation nextPut: char.
	lastWidth _ self widthOf: char inFont: font.
	destX _ destX + lastWidth.
! !

!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/16/2003 17:38'!
getPresentation

	^ presentation contents.

! !

!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/16/2003 17:28'!
getPresentationLine

	^ presentationLine.
! !

!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 11:51'!
isBreakableAt: index in: sourceString in: encodingClass

	^ encodingClass isBreakableAt: index in: sourceString.
! !

!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 16:28'!
registerBreakableIndex

	"Record left x and character index of the line-wrappable point. 
	Used for wrap-around. Answer whether the character has crossed the 
	right edge of the composition rectangle of the paragraph."

	(text at: lastIndex) = Character space ifTrue: [
		breakAtSpace _ true.
		spaceX _ destX.
		spaceCount _ spaceCount + 1.
		lineHeightAtBreak _ lineHeight.
		baselineAtBreak _ baseline.
		breakableIndex _ lastIndex.
		destX > rightMargin ifTrue: 	[^self crossedX].
	] ifFalse: [
		breakAtSpace _ false.
		lineHeightAtBreak _ lineHeight.
		baselineAtBreak _ baseline.
		breakableIndex _ lastIndex - 1.
	].
	^ false.
! !

!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 2/10/2004 22:59'!
removeLastCharFromPresentation

	presentation ifNotNil: [
		presentation position: presentation position - 1.
	].
	destX _ destX - lastWidth.
! !


!MultiCompositionScanner methodsFor: 'scanning' stamp: 'ar 4/12/2005 17:34'!
composeFrom: startIndex inRectangle: lineRectangle
	firstLine: firstLine leftSide: leftSide rightSide: rightSide
	"Answer an instance of TextLineInterval that represents the next line in the paragraph."
	| runLength done stopCondition |
	"Set up margins"
	leftMargin _ lineRectangle left.
	leftSide ifTrue: [leftMargin _ leftMargin +
						(firstLine ifTrue: [textStyle firstIndent]
								ifFalse: [textStyle restIndent])].
	destX _ spaceX _ leftMargin.
	firstDestX _ destX.
	rightMargin _ lineRectangle right.
	rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent].
	lastIndex _ startIndex.	"scanning sets last index"
	destY _ lineRectangle top.
	lineHeight _ baseline _ 0.  "Will be increased by setFont"
	self setStopConditions.	"also sets font"
	runLength _ text runLengthFor: startIndex.
	runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
	line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
				rectangle: lineRectangle.
	presentationLine _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
				rectangle: lineRectangle.
	numOfComposition _ 0.
	spaceCount _ 0.
	self handleIndentation.
	leftMargin _ destX.
	line leftMargin: leftMargin.
	presentationLine leftMargin: leftMargin.

	presentation _ TextStream on: (Text fromString: (WideString new: text size)).

	done _ false.
	[done]
		whileFalse: 
			[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
				in: text string rightX: rightMargin stopConditions: stopConditions
				kern: kern.
			"See setStopConditions for stopping conditions for composing."
			(self perform: stopCondition)
				ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading
							baseline: baseline + textStyle leading.
						^ line lineHeight: lineHeight + textStyle leading
							baseline: baseline + textStyle leading]]! !

!MultiCompositionScanner methodsFor: 'scanning' stamp: 'ar 4/12/2005 17:34'!
composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph 
	"Answer an instance of TextLineInterval that represents the next line in the paragraph."
	| runLength done stopCondition |
	destX _ spaceX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex.
	destY _ 0.
	rightMargin _ aParagraph rightMarginForComposition.
	leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose'].
	lastIndex _ startIndex.	"scanning sets last index"
	lineHeight _ textStyle lineGrid.  "may be increased by setFont:..."
	baseline _ textStyle baseline.
	baselineY _ destY + baseline.
	self setStopConditions.	"also sets font"
	self handleIndentation.
	runLength _ text runLengthFor: startIndex.
	runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
	line _ TextLineInterval
		start: lastIndex
		stop: 0
		internalSpaces: 0
		paddingWidth: 0.
	presentationLine _ TextLineInterval
		start: lastIndex
		stop: 0
		internalSpaces: 0
		paddingWidth: 0.
	numOfComposition _ 0.
	presentation _ TextStream on: (Text fromString: (WideString new: text size)).
	spaceCount _ 0.
	done _ false.
	[done]
		whileFalse: 
			[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
				in: text string rightX: rightMargin stopConditions: stopConditions
				kern: kern.
			"See setStopConditions for stopping conditions for composing."
			(self perform: stopCondition)
				ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading
							baseline: baseline + textStyle leading.
						^line lineHeight: lineHeight + textStyle leading
							baseline: baseline + textStyle leading]]! !

!MultiCompositionScanner methodsFor: 'scanning' stamp: 'yo 1/3/2003 11:54'!
crossedX
	"There is a word that has fallen across the right edge of the composition 
	rectangle. This signals the need for wrapping which is done to the last 
	space that was encountered, as recorded by the space stop condition."

	(breakAtSpace) ifTrue: [
		spaceCount >= 1 ifTrue:
			["The common case. First back off to the space at which we wrap."
			line stop: breakableIndex.
			presentationLine stop: breakableIndex - numOfComposition.
			lineHeight _ lineHeightAtBreak.
			baseline _ baselineAtBreak.
			spaceCount _ spaceCount - 1.
			breakableIndex _ breakableIndex - 1.

			"Check to see if any spaces preceding the one at which we wrap.
				Double space after punctuation, most likely."
			[(spaceCount > 1 and: [(text at: breakableIndex) = Space])]
				whileTrue:
					[spaceCount _ spaceCount - 1.
					"Account for backing over a run which might
						change width of space."
					font _ text fontAt: breakableIndex withStyle: textStyle.
					breakableIndex _ breakableIndex - 1.
					spaceX _ spaceX - (font widthOf: Space)].
			line paddingWidth: rightMargin - spaceX.
			presentationLine paddingWidth: rightMargin - spaceX.
			presentationLine internalSpaces: spaceCount.
			line internalSpaces: spaceCount]
		ifFalse:
			["Neither internal nor trailing spaces -- almost never happens."
			lastIndex _ lastIndex - 1.
			[destX <= rightMargin]
				whileFalse:
					[destX _ destX - (font widthOf: (text at: lastIndex)).
					lastIndex _ lastIndex - 1].
			spaceX _ destX.
			line paddingWidth: rightMargin - destX.
			presentationLine paddingWidth: rightMargin - destX.
			presentationLine stop: (lastIndex max: line first).
			line stop: (lastIndex max: line first)].
		^true
	].

	(breakableIndex isNil or: [breakableIndex < line first]) ifTrue: [
		"Any breakable point in this line.  Just wrap last character."
		breakableIndex _ lastIndex - 1.
		lineHeightAtBreak _ lineHeight.
		baselineAtBreak _ baseline.
	].

	"It wasn't a space, but anyway this is where we break the line."
	line stop: breakableIndex.
	presentationLine stop: breakableIndex.
	lineHeight _ lineHeightAtBreak.
	baseline _ baselineAtBreak.
	^ true.
! !

!MultiCompositionScanner methodsFor: 'scanning' stamp: 'tak 12/22/2004 00:59'!
setActualFont: aFont
	"Keep track of max height and ascent for auto lineheight"
	| descent |
	super setActualFont: aFont.
	"'   ', lastIndex printString, '   ' displayAt: (lastIndex * 15)@0."
	lineHeight == nil
		ifTrue: [descent _ font descent.
				baseline _ font ascent.
				lineHeight _ baseline + descent]
		ifFalse: [descent _ lineHeight - baseline max: font descent.
				baseline _ baseline max: font ascent.
				lineHeight _ lineHeight max: baseline + descent]! !


!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 1/3/2003 11:56'!
columnBreak

	"Answer true. Set up values for the text line interval currently being 
	composed."

	line stop: lastIndex.
	presentationLine stop: lastIndex - numOfComposition.
	spaceX _ destX.
	line paddingWidth: rightMargin - spaceX.
	presentationLine paddingWidth: rightMargin - spaceX.
	^true! !

!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 1/3/2003 11:56'!
cr
	"Answer true. Set up values for the text line interval currently being 
	composed."

	line stop: lastIndex.
	presentationLine stop: lastIndex - numOfComposition.
	spaceX _ destX.
	line paddingWidth: rightMargin - spaceX.
	presentationLine paddingWidth: rightMargin - spaceX.
	^true! !

!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 2/10/2004 23:03'!
endOfRun
	"Answer true if scanning has reached the end of the paragraph. 
	Otherwise step conditions (mostly install potential new font) and answer 
	false."

	| runLength |
	lastIndex = text size
	ifTrue:	[line stop: lastIndex.
			presentationLine stop: lastIndex - numOfComposition.
			spaceX _ destX.
			line paddingWidth: rightMargin - destX.
			presentationLine paddingWidth: rightMargin - destX.
			^true]
	ifFalse:	[
			"(text at: lastIndex) charCode = 32 ifTrue: [destX _ destX + spaceWidth]."
			runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
			runStopIndex _ lastIndex + (runLength - 1).
			self setStopConditions.
			^false]
! !

!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 1/3/2003 11:56'!
placeEmbeddedObject: anchoredMorph
	| descent |
	"Workaround: The following should really use #textAnchorType"
	anchoredMorph relativeTextAnchorPosition ifNotNil:[^true].
	(super placeEmbeddedObject: anchoredMorph) ifFalse: ["It doesn't fit"
		"But if it's the first character then leave it here"
		lastIndex < line first ifFalse:[
			line stop: lastIndex-1.
			^ false]].
	descent _ lineHeight - baseline.
	lineHeight _ lineHeight max: anchoredMorph height.
	baseline _ lineHeight - descent.
	line stop: lastIndex.
	presentationLine stop: lastIndex - numOfComposition.
	^ true! !

!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 21:47'!
setFont
	super setFont.
	breakAtSpace _ false.
	wantsColumnBreaks == true ifTrue: [
		stopConditions _ stopConditions copy.
		stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak.
	].
! !

!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:57'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont! !

!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:57'!
tab
	"Advance destination x according to tab settings in the paragraph's 
	textStyle. Answer whether the character has crossed the right edge of 
	the composition rectangle of the paragraph."

	destX _ textStyle
				nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin.
	destX > rightMargin ifTrue:	[^self crossedX].
	lastIndex _ lastIndex + 1.
	^false
! !
MultiCharacterScanner subclass: #MultiDisplayScanner
	instanceVariableNames: 'bitBlt lineY runX foregroundColor backgroundColor fillBlt lineHeight paragraph paragraphColor morphicOffset ignoreColorChanges'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Scanning'!

!MultiDisplayScanner methodsFor: 'MVC-compatibility' stamp: 'yo 1/7/2005 12:15'!
displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle
	"The central display routine. The call on the primitive 
	(scanCharactersFrom:to:in:rightX:) will be interrupted according to an 
	array of stop conditions passed to the scanner at which time the code to 
	handle the stop condition is run and the call on the primitive continued 
	until a stop condition returns true (which means the line has 
	terminated)."
	| runLength done stopCondition leftInRun startIndex string lastPos |
	"leftInRun is the # of characters left to scan in the current run;
		when 0, it is time to call 'self setStopConditions'"
	morphicOffset _ 0@0.
	leftInRun _ 0.
	self initializeFromParagraph: aParagraph clippedBy: visibleRectangle.
	ignoreColorChanges _ false.
	paragraph _ aParagraph.
	foregroundColor _ paragraphColor _ aParagraph foregroundColor.
	backgroundColor _ aParagraph backgroundColor.
	aParagraph backgroundColor isTransparent
		ifTrue: [fillBlt _ nil]
		ifFalse: [fillBlt _ bitBlt copy.  "Blt to fill spaces, tabs, margins"
				fillBlt sourceForm: nil; sourceOrigin: 0@0.
				fillBlt fillColor: aParagraph backgroundColor].
	rightMargin _ aParagraph rightMarginForDisplay.
	lineY _ aParagraph topAtLineIndex: linesInterval first.
	bitBlt destForm deferUpdatesIn: visibleRectangle while: [
		linesInterval do: 
			[:lineIndex | 
			leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]).
			destX _ (runX _ leftMargin).
			line _ aParagraph lines at: lineIndex.
			lineHeight _ line lineHeight.
			fillBlt == nil ifFalse:
				[fillBlt destX: visibleRectangle left destY: lineY
					width: visibleRectangle width height: lineHeight; copyBits].
			lastIndex _ line first.
			leftInRun <= 0
				ifTrue: [self setStopConditions.  "also sets the font"
						leftInRun _ text runLengthFor: line first].
			baselineY _ lineY + line baseline.
			destY _ baselineY - font ascent.  "Should have happened in setFont"
			runLength _ leftInRun.
			runStopIndex _ lastIndex + (runLength - 1) min: line last.
			leftInRun _ leftInRun - (runStopIndex - lastIndex + 1).
			spaceCount _ 0.
			done _ false.
			string _ text string.
			self handleIndentation.
			[done] whileFalse:[
				startIndex _ lastIndex.
				lastPos _ destX@destY.
				stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
							in: string rightX: rightMargin stopConditions: stopConditions
							kern: kern.
				lastIndex >= startIndex ifTrue:[
					font displayString: string on: bitBlt 
						from: startIndex to: lastIndex at: lastPos kern: kern baselineY: baselineY].
				"see setStopConditions for stopping conditions for displaying."
				done _ self perform: stopCondition].
			fillBlt == nil ifFalse:
				[fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits].
			lineY _ lineY + lineHeight]]! !

!MultiDisplayScanner methodsFor: 'MVC-compatibility' stamp: 'yo 3/14/2005 06:48'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	super initializeFromParagraph: aParagraph clippedBy: clippingRectangle.
	bitBlt _ BitBlt asGrafPort toForm: aParagraph destinationForm.
	bitBlt sourceX: 0; width: 0.	"Init BitBlt so that the first call to a primitive will not fail"
	bitBlt combinationRule: Form paint.
	bitBlt colorMap:
		(Bitmap with: 0      "Assumes 1-bit deep fonts"
				with: (bitBlt destForm pixelValueFor: aParagraph foregroundColor)).
	bitBlt clipRect: clippingRectangle.
! !


!MultiDisplayScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 11:52'!
isBreakableAt: index in: sourceString in: encodingClass

	^ false.
! !

!MultiDisplayScanner methodsFor: 'multilingual scanning' stamp: 'yo 8/6/2003 05:57'!
scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta

	| encoding f nextDestX maxAscii startEncoding char charValue |
	lastIndex _ startIndex.
	lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun].
	startEncoding _ (sourceString at: startIndex) leadingChar.
	font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1].
	((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [
		[f _ font fontArray at: startEncoding + 1]
			on: Exception do: [:ex | f _ font fontArray at: 1].
		f ifNil: [ f _ font fontArray at: 1].
		maxAscii _ f maxAscii.
		spaceWidth _ f widthOf: Space.
	] ifFalse: [
		maxAscii _ font maxAscii.
	].

	[lastIndex <= stopIndex] whileTrue: [
		encoding _ (sourceString at: lastIndex) leadingChar.
		encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun].
		char _ (sourceString at: lastIndex).
		charValue _ char charCode.
		charValue > maxAscii ifTrue: [charValue _ maxAscii].
		(encoding = 0 and: [(stopConditions at: charValue + 1) ~~ nil]) ifTrue: [
			^ stops at: charValue + 1
		].
		nextDestX _ destX + (self widthOf: char inFont: font).
		nextDestX > rightX ifTrue: [^ stops at: CrossedX].
		destX _ nextDestX + kernDelta.
		lastIndex _ lastIndex + 1.
	].
	lastIndex _ stopIndex.
	^ stops at: EndOfRun! !


!MultiDisplayScanner methodsFor: 'scanning' stamp: 'yo 1/7/2005 12:15'!
displayLine: textLine offset: offset leftInRun: leftInRun
	"The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated).  leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions."
	| done stopCondition nowLeftInRun startIndex string lastPos |
	line _ textLine.
	morphicOffset _ offset.
	lineY _ line top + offset y.
	lineHeight _ line lineHeight.
	rightMargin _ line rightMargin + offset x.
	lastIndex _ line first.
	leftInRun <= 0 ifTrue: [self setStopConditions].
	leftMargin _ (line leftMarginForAlignment: alignment) + offset x.
	destX _ runX _ leftMargin.
	fillBlt == nil ifFalse:
		["Not right"
		fillBlt destX: line left destY: lineY
			width: line width left height: lineHeight; copyBits].
	lastIndex _ line first.
	leftInRun <= 0
		ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex]
		ifFalse: [nowLeftInRun _ leftInRun].
	baselineY _ lineY + line baseline.
	destY _ baselineY - font ascent.
	runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last.
	spaceCount _ 0.
	done _ false.
	string _ text string.
	[done] whileFalse:[
		startIndex _ lastIndex.
		lastPos _ destX@destY.
		stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
						in: string rightX: rightMargin stopConditions: stopConditions
						kern: kern.
		lastIndex >= startIndex ifTrue:[
			font displayString: string on: bitBlt 
				from: startIndex to: lastIndex at: lastPos kern: kern baselineY: baselineY].
		"see setStopConditions for stopping conditions for displaying."
		done _ self perform: stopCondition.
		"lastIndex > runStopIndex ifTrue: [done _ true]."
	].
	^ runStopIndex - lastIndex   "Number of characters remaining in the current run"! !

!MultiDisplayScanner methodsFor: 'scanning' stamp: 'lr 1/21/2006 16:01'!
placeEmbeddedObject: anchoredMorph
	anchoredMorph relativeTextAnchorPosition ifNotNil:[
		anchoredMorph position: 
			anchoredMorph relativeTextAnchorPosition +
			(anchoredMorph owner textBounds origin x @ 0)
			- (0@morphicOffset y) + (0@lineY).
		^true
	].
	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	anchoredMorph isMorph ifTrue: [
		anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset
	] ifFalse: [
		destY _ lineY.
		baselineY _ lineY + anchoredMorph height..
		runX _ destX.
		anchoredMorph 
			displayOn: bitBlt destForm 
			at: destX - anchoredMorph width @ destY
			clippingBox: bitBlt clipRect
			rule: Form blend
			fillColor: Color white 
	].
	^ true! !


!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	lastIndex_ lastIndex + 1.
	^false! !

!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'!
crossedX
	"This condition will sometimes be reached 'legally' during display, when, 
	for instance the space that caused the line to wrap actually extends over 
	the right boundary. This character is allowed to display, even though it 
	is technically outside or straddling the clipping ectangle since it is in 
	the normal case not visible and is in any case appropriately clipped by 
	the scanner."

	^ true ! !

!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'!
endOfRun
	"The end of a run in the display case either means that there is actually 
	a change in the style (run code) to be associated with the string or the 
	end of this line has been reached."
	| runLength |
	lastIndex = line last ifTrue: [^true].
	runX _ destX.
	runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
	runStopIndex _ lastIndex + (runLength - 1) min: line last.
	self setStopConditions.
	^ false! !

!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'!
paddedSpace
	"Each space is a stop condition when the alignment is right justified. 
	Padding must be added to the base width of the space according to 
	which space in the line this space is and according to the amount of 
	space that remained at the end of the line when it was composed."

	spaceCount _ spaceCount + 1.
	destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).
	lastIndex _ lastIndex + 1.
	^ false! !

!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'!
plainTab
	| oldX |
	oldX _ destX.
	super plainTab.
	fillBlt == nil ifFalse:
		[fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]! !

!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]).

"
	alignment = Justified ifTrue: [
		stopConditions == DefaultStopConditions 
			ifTrue:[stopConditions _ stopConditions copy].
		stopConditions at: Space asciiValue + 1 put: #paddedSpace]
"! !

!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'!
tab
	self plainTab.
	lastIndex _ lastIndex + 1.
	^ false! !


!MultiDisplayScanner methodsFor: 'private' stamp: 'yo 1/23/2003 14:40'!
presentationText: t

	text _ t.
! !

!MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'!
setDestForm: df
	bitBlt setDestForm: df.! !

!MultiDisplayScanner methodsFor: 'private' stamp: 'yo 1/6/2005 23:06'!
setFont 
	foregroundColor _ paragraphColor.
	super setFont.  "Sets font and emphasis bits, and maybe foregroundColor"
	font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent.
	text ifNotNil:[
		baselineY _ lineY + line baseline.
		destY _ baselineY - font ascent].
! !

!MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'!
setPort: aBitBlt
	"Install the BitBlt to use"
	bitBlt _ aBitBlt.
	bitBlt sourceX: 0; width: 0.	"Init BitBlt so that the first call to a primitive will not fail"
	bitBlt sourceForm: nil. "Make sure font installation won't be confused"
! !

!MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'!
text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode
	text _ t.
	textStyle _ ts. 
	foregroundColor _ paragraphColor _ foreColor.
	(backgroundColor _ backColor) isTransparent ifFalse:
		[fillBlt _ blt.
		fillBlt fillColor: backgroundColor].
	ignoreColorChanges _ shadowMode! !

!MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'!
textColor: textColor
	ignoreColorChanges ifTrue: [^ self].
	foregroundColor _ textColor! !

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

MultiDisplayScanner class
	instanceVariableNames: ''!

!MultiDisplayScanner class methodsFor: 'queries' stamp: 'yo 12/18/2002 13:58'!
defaultFont
	^ TextStyle defaultFont! !
NewParagraph subclass: #MultiNewParagraph
	instanceVariableNames: 'presentationText presentationLines'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Multilingual-Scanning'!

!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 16:09'!
displayOn: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"

	| visibleRectangle offset leftInRun line |
	visibleRectangle _ aCanvas clipRect.
	offset _ somePosition - positionWhenComposed.
	leftInRun _ 0.
	(self lineIndexForPoint: visibleRectangle topLeft)
		to: (self lineIndexForPoint: visibleRectangle bottomRight)
		do: [:i | line _ lines at: i.
			self displaySelectionInLine: line on: aCanvas.
			line first <= line last ifTrue:
				[leftInRun _ displayScanner displayLine: line
								offset: offset leftInRun: leftInRun]].
! !

!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 22:33'!
displayOnTest: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"

	| visibleRectangle offset leftInRun line |
	(presentationText isNil or: [presentationLines isNil]) ifTrue: [
		^ self displayOn: aCanvas using: displayScanner at: somePosition.
	].
	visibleRectangle _ aCanvas clipRect.
	offset _ somePosition - positionWhenComposed.
	leftInRun _ 0.
	(self lineIndexForPoint: visibleRectangle topLeft)
		to: (self lineIndexForPoint: visibleRectangle bottomRight)
		do: [:i | line _ presentationLines at: i.
			self displaySelectionInLine: line on: aCanvas.
			line first <= line last ifTrue:
				[leftInRun _ displayScanner displayLine: line
								offset: offset leftInRun: leftInRun]].
! !

!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 12:53'!
multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines
	atY: startingY
	"While the section from start to stop has changed, composition may ripple all the way to the end of the text.  However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values"

	| newResult composer presentationInfo |

	composer _ MultiTextComposer new.
	presentationLines _ nil.
	presentationText _ nil.
	newResult _ composer
		multiComposeLinesFrom: start 
		to: stop 
		delta: delta 
		into: lineColl 
		priorLines: priorLines
		atY: startingY
		textStyle: textStyle 
		text: text 
		container: container
		wantsColumnBreaks: wantsColumnBreaks == true.
	lines _ newResult first asArray.
	maxRightX _ newResult second.
	presentationInfo _ composer getPresentationInfo.
	presentationLines _ presentationInfo first asArray.
	presentationText _ presentationInfo second.
	"maxRightX printString displayAt: 0@0."
	^maxRightX
! !

!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 17:31'!
presentationLines

	^ presentationLines.
! !

!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 17:31'!
presentationText

	^ presentationText.
! !
FormCanvas subclass: #MultiResolutionCanvas
	instanceVariableNames: 'deferredMorphs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Support'!

!MultiResolutionCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 12/4/2000 12:00'!
deferredMorphs

	^deferredMorphs! !

!MultiResolutionCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 12/4/2000 11:58'!
deferredMorphs: aCollection

	deferredMorphs _ aCollection! !

!MultiResolutionCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 12/17/2000 13:25'!
initializeFrom: aFormCanvas

	origin _ aFormCanvas origin.
	clipRect _ aFormCanvas privateClipRect.
	form _ aFormCanvas form.
	port _ aFormCanvas privatePort.
	shadowColor _ aFormCanvas shadowColor.
! !


!MultiResolutionCanvas methodsFor: 'drawing-general' stamp: 'RAA 12/4/2000 12:00'!
fullDraw: aMorph

	aMorph canDrawAtHigherResolution ifTrue: [
		deferredMorphs ifNil: [deferredMorphs _ OrderedCollection new].
		deferredMorphs add: aMorph.
	] ifFalse: [
		super fullDraw: aMorph
	].! !
TTCFont subclass: #MultiTTCFont
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:08'!
access: char at: index

	| wcache entry |
	wcache _ self cache.
	entry _ wcache at: index.
	wcache replaceFrom: index to: wcache size - 1 with: wcache startingAt: index + 1.
	wcache at: wcache size put: entry.
! !

!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:09'!
at: char put: form

	| wcache |
	wcache _ self cache.
	wcache replaceFrom: 1 to: wcache size - 1 with: wcache startingAt: 2.
	wcache at: wcache size
		put: (Array with: char asciiValue with: foregroundColor with: form).
! !

!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:27'!
flushCache

	cache at: 1 put: ((1 to: 128) collect: [:i | Array with: -1 with: nil with: nil]).
! !

!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 21:04'!
formOf: char

	| newForm |
	self hasCached: char ifTrue: [:form :index |
		self access: char at: index.
		^ form.
	].

	newForm _ self computeForm: char.
	self at: char put: newForm.
	^ newForm.
! !

!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 1/7/2005 11:09'!
glyphInfoOf: char into: glyphInfoArray

	| newForm |
	self hasCached: char ifTrue: [:form :index |
		self access: char at: index.
		glyphInfoArray at: 1 put: form;
			at: 2 put: 0;
			at: 3 put: form width;
			at: 4 put: (self ascentOf: char);
			at: 5 put: self.
		^ glyphInfoArray.
	].

	newForm _ self computeForm: char.
	self at: char put: newForm.

	glyphInfoArray at: 1 put: newForm;
		at: 2 put: 0;
		at: 3 put: newForm width;
		at: 4 put: (self ascentOf: char);
		at: 5 put: self.
	^ glyphInfoArray.
! !

!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:39'!
hasCached: char ifTrue: twoArgBlock

	| value elem |
	value _ char asciiValue.

	self cache size to: 1 by: -1 do: [:i |
		elem _ self cache at: i.
		(elem first = value and: [elem second = foregroundColor]) ifTrue: [
			^ twoArgBlock value: elem third value: i.
		].
	].
	^ false.
! !

!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/29/2003 15:01'!
isTTCFont
	^true! !

!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:30'!
widthOf: char

	"This method cannot use #formOf: because formOf: discriminates the color and causes unnecessary bitmap creation."

	| newForm |
	self hasCached: char ifTrue: [:form :index |
		self access: char at: index.
		^ form width.
	].

	newForm _ self computeForm: char.
	self at: char put: newForm.
	^ newForm width.

! !

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

MultiTTCFont class
	instanceVariableNames: ''!

!MultiTTCFont class methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:34'!
cacheAllNil
"
	self cacheAllNil
"
	self allInstances do: [:inst |
		inst cache do: [:e |
			e third ifNotNil: [^ false].
		].
	].

	^ true.
! !
TextComposer subclass: #MultiTextComposer
	instanceVariableNames: 'presentation presentationLines'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Multilingual-Scanning'!

!MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 12:53'!
composeEachRectangleIn: rectangles

	| myLine lastChar |

	1 to: rectangles size do: [:i | 
		currCharIndex <= theText size ifFalse: [^false].
		myLine _ scanner 
			composeFrom: currCharIndex 
			inRectangle: (rectangles at: i)				
			firstLine: isFirstLine 
			leftSide: i=1 
			rightSide: i=rectangles size.
		lines addLast: myLine.
		presentationLines addLast: scanner getPresentationLine.
		presentation ifNil: [presentation _ scanner getPresentation]
			ifNotNil: [presentation _ presentation, scanner getPresentation].
		actualHeight _ actualHeight max: myLine lineHeight.  "includes font changes"
		currCharIndex _ myLine last + 1.
		lastChar _ theText at: myLine last.
		lastChar = Character cr ifTrue: [^#cr].
		wantsColumnBreaks ifTrue: [
			lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak].
		].
	].
	^false! !

!MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 12:53'!
getPresentationInfo

	^ Array with: presentationLines with: presentation.
! !

!MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'yo 1/16/2003 17:30'!
multiComposeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks

	wantsColumnBreaks _ argWantsColumnBreaks.
	lines _ argLinesCollection.
	presentationLines _ argLinesCollection copy.
	theTextStyle _ argTextStyle.
	theText _ argText.
	theContainer _ argContainer.
	deltaCharIndex _ argDelta.
	currCharIndex _ startCharIndex _ argStart.
	stopCharIndex _ argStop.
	prevLines _ argPriorLines.
	currentY _ argStartY.
	defaultLineHeight _ theTextStyle lineGrid.
	maxRightX _ theContainer left.
	possibleSlide _ stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle].
	nowSliding _ false.
	prevIndex _ 1.
	scanner _ MultiCompositionScanner new text: theText textStyle: theTextStyle.
	scanner wantsColumnBreaks: wantsColumnBreaks.
	isFirstLine _ true.
	self composeAllLines.
	isFirstLine ifTrue: ["No space in container or empty text"
		self 
			addNullLineWithIndex: startCharIndex
			andRectangle: (theContainer topLeft extent: 0@defaultLineHeight)
	] ifFalse: [
		self fixupLastLineIfCR
	].
	^{lines asArray. maxRightX}

! !
LazyListMorph subclass: #MulticolumnLazyListMorph
	instanceVariableNames: 'columnWidths'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!MulticolumnLazyListMorph commentStamp: '<historical>' prior: 0!
A variant of LazyListMorph that can display multi-column lists.!


!MulticolumnLazyListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/17/2001 21:23'!
getListItem: index
	^listSource getListRow: index! !

!MulticolumnLazyListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/18/2001 16:43'!
listChanged
	columnWidths := nil.
	super listChanged! !


!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'nk 1/10/2004 16:19'!
display: items atRow: row on: canvas 
	"display the specified item, which is on the specified row; for Multicolumn 
	lists, items will be a list of strings"
	| drawBounds |
	drawBounds := self drawBoundsForRow: row.
	drawBounds := drawBounds intersect: self bounds.
	items
		with: (1 to: items size)
		do: [:item :index | 
			"move the bounds to the right at each step"
			index > 1
				ifTrue: [drawBounds := drawBounds left: drawBounds left + 6
									+ (columnWidths at: index - 1)].
			item isText
				ifTrue: [canvas
						drawString: item
						in: drawBounds
						font: (font
								emphasized: (item emphasisAt: 1))
						color: (self colorForRow: row)]
				ifFalse: [canvas
						drawString: item
						in: drawBounds
						font: font
						color: (self colorForRow: row)]]! !

!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:58'!
drawOn: aCanvas
        self getListSize = 0 ifTrue:[ ^self ].

        self setColumnWidthsFor: aCanvas.

        super drawOn: aCanvas! !

!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'sps 3/23/2004 15:51'!
setColumnWidthsFor: aCanvas
        | row topRow bottomRow |
        "set columnWidths for drawing on the specified canvas"
		columnWidths ifNil: [
		columnWidths := (self item: 1) collect: [ :ignored | 0 ]. ].
	topRow := (self topVisibleRowForCanvas: aCanvas) max: 1.
	bottomRow :=  (self bottomVisibleRowForCanvas: aCanvas) max: 1.
	topRow > bottomRow ifTrue: [ ^ self ].
	topRow to: bottomRow do: [ :rowIndex |
                row := self item: rowIndex.
                columnWidths := columnWidths with: row collect: [ :currentWidth :item |
				| widthOfItem |
				widthOfItem := (font widthOfStringOrText: item).
				widthOfItem > currentWidth
					ifTrue: [ self changed.  widthOfItem ]
					ifFalse: [ currentWidth ] ] ]! !


!MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: 'sps 4/2/2004 12:16'!
hUnadjustedScrollRange
"multi column list morphs don't use hScrollbars"

	^0

! !

!MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:21'!
widthToDisplayItem: item
	| widths |
	widths := item collect: [ :each | super widthToDisplayItem: each ].
	^widths sum + (10 * (widths size - 1))   "add in space between the columns"
! !
SketchMorph subclass: #MultiuserTinyPaint
	instanceVariableNames: 'drawState'
	classVariableNames: 'LastMouseIndex PenColorIndex PenIndex PenSizeIndex'
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWidgets'!
!MultiuserTinyPaint commentStamp: '<historical>' prior: 0!
A very simple paint program that handles multiple users (hands).
Each user has their own brush size and color.
!


!MultiuserTinyPaint methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

	^ true
! !

!MultiuserTinyPaint methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
mouseDown: evt

	| state |
	(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
	state _ drawState at: evt hand.
	state at: LastMouseIndex put: evt cursorPoint.
! !

!MultiuserTinyPaint methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
mouseMove: evt

	| state lastP p pen |
	state _ drawState at: evt hand ifAbsent: [^ self].
	lastP _ state at: LastMouseIndex.
	p _ evt cursorPoint.
	p = lastP ifTrue: [^ self].

	pen _ state at: PenIndex.
	pen drawFrom: lastP - bounds origin to: p - bounds origin.
	self invalidRect: (
		((lastP min: p) - pen sourceForm extent) corner:
		((lastP max: p) + pen sourceForm extent)).
	state at: LastMouseIndex put: p.
! !


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

!MultiuserTinyPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:52'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	drawState _ IdentityDictionary new.
	self clear! !


!MultiuserTinyPaint methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:55'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'clear' translated action: #clear.
	aCustomMenu add: 'pen color' translated action: #setPenColor:.
	aCustomMenu add: 'pen size' translated action: #setPenSize:.
"	aCustomMenu add: 'fill' translated action: #fill:."
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
brushColor: aColor hand: hand

	| state |
	(drawState includesKey: hand) ifFalse: [self createDrawStateFor: hand].
	state _ drawState at: hand.
	(state at: PenIndex) color: aColor.
	state at: PenColorIndex put: aColor.
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
clear

	| newPen |
	self form: ((Form extent: 400@300 depth: 8) fillColor: color).
	drawState do: [:state |
		newPen _ Pen newOnForm: originalForm.
		newPen roundNib: (state at: PenSizeIndex).
		newPen color: (state at: PenColorIndex).
		state at: PenIndex put: newPen].
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'bf 1/5/2000 19:12'!
fill: evt

	| state fillPt |
	(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
	state _ drawState at: evt hand.

	Cursor blank show.
	Cursor crossHair showWhile:
		[fillPt _ Sensor waitButton - self position].
	originalForm shapeFill: (state at: PenColorIndex) interiorPoint: fillPt.
	self changed.
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/26/97 14:47'!
penSize: anInteger hand: hand

	| state |
	(drawState includesKey: hand) ifFalse: [self createDrawStateFor: hand].
	state _ drawState at: hand.
	state at: PenSizeIndex put: anInteger.
	(state at: PenIndex) roundNib: anInteger.
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'ar 10/5/2000 18:52'!
setPenColor: evt
	| state |
	(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
	state _ drawState at: evt hand.
	self changeColorTarget: self selector: #brushColor:hand: originalColor: (state at: PenColorIndex) hand: evt hand! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:07'!
setPenSize: evt

	| menu sizes |
	menu _ MenuMorph new.
	sizes _ (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
	sizes do: [:w |
		menu add: w printString
			target: self
			selector: #penSize:hand:
			argumentList: (Array with: w with: evt hand)].

	menu popUpEvent: evt in: self world! !


!MultiuserTinyPaint methodsFor: 'private' stamp: 'jm 11/4/97 07:15'!
createDrawStateFor: aHand

	| pen state |
	pen _ Pen newOnForm: originalForm.
	state _ Array new: 4.
	state at: PenIndex put: pen.
	state at: PenSizeIndex put: 3.
	state at: PenColorIndex put: Color red.
	state at: LastMouseIndex put: nil.
	drawState at: aHand put: state.
! !

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

MultiuserTinyPaint class
	instanceVariableNames: ''!

!MultiuserTinyPaint class methodsFor: 'class initialization' stamp: 'jm 11/4/97 07:15'!
initialize
	"MultiuserTinyPaint initialize"

	"indices into the state array for a given hand"
	PenIndex _ 1.
	PenSizeIndex _ 2.
	PenColorIndex _ 3.
	LastMouseIndex _ 4.
! !
Object subclass: #Mutex
	instanceVariableNames: 'semaphore owner'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!Mutex commentStamp: '<historical>' prior: 0!
A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested.

Instance variables:
	semaphore	<Semaphore>		The (primitive) semaphore used for synchronization.
	owner		<Process>		The process owning the mutex.!


!Mutex methodsFor: 'initialize' stamp: 'das 11/3/2005 22:53'!
initialize
	semaphore := Semaphore forMutualExclusion.! !


!Mutex methodsFor: 'mutual exclusion' stamp: 'das 11/3/2005 22:53'!
critical: aBlock
	"Evaluate aBlock protected by the receiver."
	| activeProcess |
	activeProcess := Processor activeProcess.
	activeProcess == owner ifTrue:[^aBlock value].
	^semaphore critical:[
		owner := activeProcess.
		aBlock ensure:[owner := nil]].! !

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

Mutex class
	instanceVariableNames: ''!
Object subclass: #MutexSet
	instanceVariableNames: 'array'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!MutexSet commentStamp: '<historical>' prior: 0!
A MutexSet helps with aquiring a set of mutexes.!


!MutexSet methodsFor: 'initialize' stamp: 'das 11/3/2005 22:54'!
withAll: mutexList
	array := mutexList.! !


!MutexSet methodsFor: 'mutual exclusion' stamp: 'das 11/3/2005 22:54'!
critical: aBlock
	"Evaluate aBlock aquiring all mutexes"
	^self pvtCritical: aBlock startingAt: 1! !


!MutexSet methodsFor: 'private' stamp: 'das 11/3/2005 22:54'!
pvtCritical: aBlock startingAt: index
	| mutex |
	index > array size ifTrue:[^aBlock value].
	mutex := array at: index.
	^mutex critical:[self pvtCritical: aBlock startingAt: index+1].! !

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

MutexSet class
	instanceVariableNames: ''!

!MutexSet class methodsFor: 'instance creation' stamp: 'das 11/3/2005 22:54'!
withAll: mutexList
	^self new withAll: mutexList! !
AppRegistry subclass: #MvcTextEditor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Applications'!
!MvcTextEditor commentStamp: 'tween 8/27/2004 12:24' prior: 0!
A subclass of AppRegistry which allows the user, or Browser add-ons, to control which class is used when creating the code editing view in mvc Browsers!

Error subclass: #MyResumableTestError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Tests'!

!MyResumableTestError methodsFor: 'exceptionDescription' stamp: 'tfei 6/13/1999 00:46'!
isResumable

	^true! !
Error subclass: #MyTestError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Tests'!
Notification subclass: #MyTestNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Tests'!
NetworkError subclass: #NameLookupFailure
	instanceVariableNames: 'hostName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!NameLookupFailure commentStamp: 'mir 5/12/2003 18:16' prior: 0!
Signals that a name lookup operation failed.

	hostName	hostName for which the name loopup failed
!


!NameLookupFailure methodsFor: 'accessing' stamp: 'rbb 2/18/2005 14:27'!
defaultAction
	"Backward compatibility"
	| response |
	response _ (UIManager default  chooseFrom: #( 'Retry' 'Give Up')
			title: self messageText).
	^ response = 2
		ifFalse: [self retry]! !

!NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'!
hostName
	^ hostName! !

!NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'!
hostName: aString
	hostName _ aString! !

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

NameLookupFailure class
	instanceVariableNames: ''!

!NameLookupFailure class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:57'!
hostName: aString
	^ self new hostName: aString! !
Object subclass: #NameOfSubclass
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Bugs'!
UpdatingStringMorph subclass: #NameStringInHalo
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!NameStringInHalo commentStamp: 'kfr 10/27/2003 16:29' prior: 0!
Shows the name of the morph in the halo. !


!NameStringInHalo methodsFor: 'accessing' stamp: 'sw 9/17/1999 13:17'!
interimContents: aString
	self contents: aString.
	self placeContents! !


!NameStringInHalo methodsFor: 'as yet unclassified' stamp: 'di 11/25/1999 23:40'!
placeContents
	| namePosition |
	(owner notNil and: [owner isInWorld]) ifTrue:
		[namePosition _ owner basicBox bottomCenter -
			((self width // 2) @ (owner handleSize negated // 2 - 1)).
		namePosition _ namePosition min: self world viewBox bottomRight - self extent y + 2.
		self bounds: (namePosition extent: self extent)]! !


!NameStringInHalo methodsFor: 'drawing' stamp: 'sw 9/7/1999 21:27'!
drawOn: aCanvas
	aCanvas fillRectangle: self bounds color: Color white.
	super drawOn: aCanvas.! !


!NameStringInHalo methodsFor: 'editing' stamp: 'sw 9/17/1999 13:41'!
cancelEdits
	self interimContents: target externalName.
	super cancelEdits! !
Object subclass: #NaturalLanguageFormTranslator
	instanceVariableNames: 'id generics'
	classVariableNames: 'CachedTranslations'
	poolDictionaries: ''
	category: 'System-Localization'!

!NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:15'!
generics
	^generics ifNil: [generics := Dictionary new]! !

!NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:27'!
localeID
	^id! !

!NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:26'!
localeID: anID
	id := anID! !

!NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:17'!
name: formName form: translatedForm 
	self generics at: formName put: translatedForm.
! !


!NaturalLanguageFormTranslator methodsFor: 'i/o' stamp: 'yo 1/13/2005 14:02'!
saveFormsOn: aStream

	| rr |
	rr _ ReferenceStream on: aStream.
	rr nextPut: {id isoString. generics}.
	rr close.
! !


!NaturalLanguageFormTranslator methodsFor: 'utilities' stamp: 'yo 1/13/2005 11:35'!
translate: aString

	^ (self generics
		at: aString ifAbsent: [nil]) deepCopy.

	"Do you like to write 'form ifNotNil: [form deepCopy]'?"
! !

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

NaturalLanguageFormTranslator class
	instanceVariableNames: ''!

!NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'!
cachedTranslations
	"CachedTranslations := nil" 
	^CachedTranslations ifNil: [CachedTranslations := Dictionary new]! !

!NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'!
isoLanguage: isoLanguage
	"Return the generic language translator as there is no information about the country code"

	^self isoLanguage: isoLanguage isoCountry: nil! !

!NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'!
isoLanguage: isoLanguage isoCountry: isoCountry
	^self localeID: (LocaleID  isoLanguage: isoLanguage isoCountry: isoCountry)! !

!NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'!
localeID: localeID 
	^ self cachedTranslations
		at: localeID
		ifAbsentPut: [self new localeID: localeID]! !


!NaturalLanguageFormTranslator class methodsFor: 'i/o' stamp: 'yo 1/13/2005 14:02'!
loadFormsFrom: aStream

	| rr pair inst |
	rr _ ReferenceStream on: aStream.
	pair _ rr next.
	inst _ self localeID: (LocaleID isoString: pair first).
	pair second associationsDo: [:assoc |
		inst name: assoc key form: assoc value.
	].
	^ inst.
! !
Object subclass: #NaturalLanguageTranslator
	instanceVariableNames: 'id generics contexts'
	classVariableNames: 'AllKnownPhrases CachedTranslations'
	poolDictionaries: ''
	category: 'System-Localization'!

!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'dgd 8/13/2004 21:12'!
displayLanguage
	^ id displayLanguage! !

!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'dgd 10/7/2004 20:50'!
displayName
	^ id displayName! !

!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:41'!
isoCountry
	^self localeID isoCountry! !

!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:42'!
isoLanguage
	^self localeID isoLanguage! !

!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:42'!
localeID
	^id! !

!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/21/2004 17:00'!
translations
	^self generics! !

!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/21/2004 17:03'!
untranslated
	| translations |
	translations := self translations.
	^self class allKnownPhrases reject: [:each | translations includesKey: each]! !


!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 11/16/2004 11:04'!
fileOutHeader
	^ '''Translation dictionary'''! !

!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 11/28/2004 14:50'!
fileOutHeaderOn: aStream 
	aStream nextChunkPut: self fileOutHeader;
		 cr.
	aStream timeStamp; cr.
	aStream nextPut: $!!.
	aStream nextChunkPut: '(' , self class name , ' localeID: ' , id storeString , ')'.
	aStream cr! !

!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'yo 11/29/2005 11:19'!
fileOutOn: aStream 
	"self current fileOutOn: Transcript. Transcript endEntry"
	self fileOutHeaderOn: aStream.
	self fileOutOn: aStream keys: nil! !

!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'yo 11/29/2005 11:19'!
fileOutOn: aStream keys: keys 
	"self current fileOutOn: Transcript. Transcript endEntry"
	(keys
		ifNil: [generics keys asSortedCollection])
		do: [:key | self
				nextChunkPut: (generics associationAt: key)
				on: aStream].
	keys
		ifNil: [self untranslated
				do: [:each | self nextChunkPut: each -> '' on: aStream]].
	aStream nextPut: $!!;
		 cr! !

!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 11/16/2004 09:26'!
nextChunkPut: anObject on: aStream 
	| i remainder terminator |
	terminator := $!!.
	remainder := anObject storeString.
	[(i := remainder indexOf: terminator) = 0]
		whileFalse: [aStream
				nextPutAll: (remainder copyFrom: 1 to: i).
			aStream nextPut: terminator.
			"double imbedded terminators"
			remainder := remainder copyFrom: i + 1 to: remainder size].
	aStream nextPutAll: remainder.
	aStream nextPut: terminator; cr.! !

!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 12/15/2004 16:07'!
scanFrom: aStream 
	"Read a definition of dictionary.  
	Make sure current locale corresponds my locale id"
	| aString newTranslations assoc currentPlatform |
	newTranslations := Dictionary new.
	currentPlatform := Locale currentPlatform.
	[Locale
		currentPlatform: (Locale localeID: id).
	[aString := aStream nextChunk withSqueakLineEndings.
	aString size > 0]
		whileTrue: [assoc := Compiler evaluate: aString.
			assoc value = ''
				ifTrue: [self class registerPhrase: assoc key]
				ifFalse: [newTranslations add: assoc]]]
		ensure: [Locale currentPlatform: currentPlatform].
	self mergeTranslations: newTranslations! !

!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'yo 2/25/2005 09:37'!
writeAsMimeString

	| fileName fileStream tmpStream s2 gzs |
	tmpStream _ MultiByteBinaryOrTextStream on: ''.
	tmpStream converter: UTF8TextConverter new.
	self fileOutOn: tmpStream.
	s2 _ RWBinaryOrTextStream on: ''.
	gzs := GZipWriteStream on: s2.
	tmpStream reset.
	gzs nextPutAll: (tmpStream binary contentsOfEntireFile asString) contents.
	gzs close.
	s2 reset.

	fileName _ id isoString, '.translation.gz.mime'.
	fileStream _ FileStream newFileNamed: fileName.
	fileStream nextPutAll: (Base64MimeConverter mimeEncode: s2) contents.
	fileStream close.
! !


!NaturalLanguageTranslator methodsFor: 'initialize-release' stamp: 'mir 7/15/2004 14:41'!
localeID: anID
	id := anID! !


!NaturalLanguageTranslator methodsFor: 'printing' stamp: 'nk 8/29/2004 10:51'!
printOn: aStream
	aStream nextPutAll: self class name; nextPut: $(; print: self localeID; nextPut: $)! !


!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 7/21/2004 18:02'!
checkPhrase: phrase translation: translation! !

!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 7/30/2004 13:03'!
phrase: phraseString translation: translationString 
	self generics at: phraseString put: translationString asString.
	self changed: #translations.
	self changed: #untranslated.! !

!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 8/2/2004 12:27'!
rawPhrase: phraseString translation: translationString 
	self generics at: phraseString put: translationString asString.
! !

!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 1/14/2005 16:25'!
rawRemoveUntranslated: untranslated

	self class allKnownPhrases removeKey: untranslated ifAbsent: [].
	self changed: #untranslated.! !

!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 8/1/2004 01:07'!
removeTranslationFor: phraseString
	self generics removeKey: phraseString ifAbsent: [].
	self changed: #translations.
	self changed: #untranslated.! !

!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 1/14/2005 16:25'!
removeUntranslated: untranslated

	self class allKnownPhrases removeKey: untranslated ifAbsent: [].
! !

!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'em 3/23/2005 12:08'!
translate: aString
	^self generics
		at: aString
		ifAbsent: [self class registeredPhraseFor: aString. 
					self changed: #untranslated. 
					self localeID hasParent
			ifTrue: [(self class localeID: self localeID parent) translate: aString]
			ifFalse: [aString]]! !

!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 6/30/2004 20:22'!
translate: aString in: aContext! !

!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 7/15/2004 14:58'!
translationFor: aString
	^self translate: aString! !


!NaturalLanguageTranslator methodsFor: 'user interface' stamp: 'dgd 8/13/2004 21:54'!
defaultBackgroundColor
	"answer the receiver's defaultBackgroundColor for views"
	^ Color cyan! !


!NaturalLanguageTranslator methodsFor: 'private' stamp: 'mir 6/30/2004 20:23'!
generics
	^generics ifNil: [generics := Dictionary new]! !


!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 7/30/2004 13:00'!
loadFromFileNamed: fileNameString 
	"Load translations from an external file"

	| stream |
	[stream := FileStream readOnlyFileNamed: fileNameString.
	self loadFromStream: stream]
		ensure: [stream close].
	self changed: #translations.
	self changed: #untranslated.
! !

!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'tak 11/16/2004 12:37'!
loadFromRefStream: stream 
	"Load translations from an external file"
	| loadedArray refStream |
	refStream := ReferenceStream on: stream.
	[loadedArray := refStream next]
		ensure: [refStream close].
	self processExternalObject: loadedArray ! !

!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'em 3/30/2005 14:32'!
loadFromStream: stream 
	"Load translations from an external file"
	| header isFileIn |
	header := '''Translation dictionary'''.
	isFileIn := (stream next: header size)
				= header.
	stream reset.
	isFileIn
		ifTrue: [stream fileInAnnouncing: 'Loading ' translated, stream localName]
		ifFalse: [self loadFromRefStream: stream]! !

!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 8/2/2004 12:27'!
mergeTranslations: newTranslations
	"Merge a new set of translations into the exiting table.
	Overwrites existing entries."

	newTranslations keysAndValuesDo: [:key :value |
		self rawPhrase: (self class registeredPhraseFor: key) translation: value].
	self changed: #translations.
	self changed: #untranslated.! !

!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'mir 7/15/2004 20:04'!
processExternalObject: anArray 
	"pivate - process the external object"

	"new format -> {translations. untranslated}"

	anArray second do: [:each | self class registerPhrase: each].

	self mergeTranslations: anArray first! !

!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 2/17/2005 15:45'!
saveToFileNamed: fileNameString 
	"save the receiver's translations to a file named fileNameString"
	| stream |
	"Set true if you need to save as binary"
	false
		ifTrue: [stream := ReferenceStream fileNamed: fileNameString.
			stream nextPut: {self translations. self untranslated}.
			stream close.
			^ self].
	stream := FileStream fileNamed: fileNameString.
	[self fileOutOn: stream]
		ensure: [stream close]! !

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

NaturalLanguageTranslator class
	instanceVariableNames: ''!

!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 20:20'!
availableLanguageLocaleIDs
	"Return the locale ids for the currently available languages.  
	Meaning those which either internally or externally have  
	translations available."
	"NaturalLanguageTranslator availableLanguageLocaleIDs"
	^ CachedTranslations values collect:[:each | each localeID]! !

!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:39'!
current
	^ LocaleID current translator

! !

!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'nk 8/29/2004 14:23'!
default
	^self localeID: (LocaleID default)
! !

!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:36'!
isoLanguage: isoLanguage
	"Return the generic language translator as there is no information about the country code"

	^self isoLanguage: isoLanguage isoCountry: nil! !

!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:36'!
isoLanguage: isoLanguage isoCountry: isoCountry
	^self localeID: (LocaleID  isoLanguage: isoLanguage isoCountry: isoCountry)! !

!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:18'!
localeID: localeID 
	^ self cachedTranslations
		at: localeID
		ifAbsentPut: [self new localeID: localeID]! !


!NaturalLanguageTranslator class methodsFor: 'class initialization' stamp: 'mir 8/11/2004 13:38'!
initialize
	"NaturalLanguageTranslator initialize"

	FileList registerFileReader: self.
	Smalltalk addToStartUpList: NaturalLanguageTranslator after: FileDirectory.
! !

!NaturalLanguageTranslator class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 19:48'!
resetCaches
	"NaturalLanguageTranslator resetCaches"

	CachedTranslations := nil.
! !

!NaturalLanguageTranslator class methodsFor: 'class initialization' stamp: 'mir 8/31/2005 23:37'!
startUp: resuming 
	| defaultID |
	resuming
		ifFalse: [^ self].
	""
	defaultID := LocaleID current.
	self cachedTranslations
		at: defaultID
		ifAbsent: [self localeID: defaultID].
	""
	self loadAvailableExternalLocales! !


!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 8/11/2004 10:52'!
fileReaderServicesForFile: fullName suffix: suffix 
	"Answer the file services associated with given file"
	^ (suffix = self translationSuffix) | (suffix = '*')
		ifTrue: [{self serviceMergeLanguageTranslations}]
		ifFalse: [#()]! !

!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'tak 3/14/2005 15:51'!
loadForLocaleIsoString: localeString fromGzippedMimeLiteral: mimeString 
	"merge the translation from the mime literal."
	| stream localeID translator gs rbStream s currentPlatform |
	s := Base64MimeConverter mimeDecodeToBytes: mimeString readStream.
	s reset.
	gs := GZipReadStream on: s.
	rbStream := MultiByteBinaryOrTextStream with: gs contents asString.
	rbStream converter: UTF8TextConverter new.
	rbStream reset.
	localeID := LocaleID isoString: localeString.
	currentPlatform := Locale currentPlatform.
	[Locale
		currentPlatform: (Locale localeID: localeID).
	stream := ReadStream on: rbStream contents]
		ensure: [Locale currentPlatform: currentPlatform].
	translator := self localeID: localeID.
	translator loadFromStream: stream.
	LanguageEnvironment resetKnownEnvironments! !

!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'yo 2/24/2005 21:04'!
mergeTranslationFileNamed: fileFullNameString 
	"merge the translation in the file named fileFullNameString"

	| stream localeID translator |
	stream := FileStream readOnlyFileNamed: fileFullNameString.
	[localeID := LocaleID isoString: stream localName sansPeriodSuffix.
	translator := self localeID: localeID.
	translator loadFromStream: stream]
		ensure: [stream close].
	LanguageEnvironment resetKnownEnvironments.

! !

!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 7/21/2004 13:45'!
serviceMergeLanguageTranslations
	"Answer a service for merging of translation files"
	^ SimpleServiceEntry
		provider: self
		label: 'merge the translation file'
		selector: #mergeTranslationFileNamed:
		description: 'merge the translation file into the language named like the file'
		buttonLabel: 'merge'! !

!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 7/21/2004 13:45'!
services
	"Answer potential file services associated with this class"
	^ {self serviceMergeLanguageTranslations}! !


!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/15/2004 19:58'!
allKnownPhrases
	^AllKnownPhrases ifNil: [AllKnownPhrases := Dictionary new: 2051]! !

!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/13/2004 00:06'!
cachedTranslations
	"CachedTranslations := nil" 
	^CachedTranslations ifNil: [CachedTranslations := Dictionary new]! !

!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 8/31/2005 16:55'!
cleanUpCache
	"NaturalLanguageTranslator cleanUpCache"

	self cachedTranslations keys do: [:key |
		key isoLanguage size > 2 ifTrue: [self cachedTranslations removeKey: key]]! !

!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/15/2004 20:02'!
registerPhrase: phrase
	"Using a Dictionary so we can lookup existing string instead of creating needless copies when loading a translation."
	self allKnownPhrases at: phrase put: phrase! !

!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/21/2004 14:18'!
registeredPhraseFor: phrase
	"Using a Dictionary so we can lookup existing string instead of creating needless copies when loading a translation."
	^self allKnownPhrases at: phrase ifAbsentPut: [phrase]! !

!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 8/11/2004 10:52'!
translationSuffix
	^'translation'! !


!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'nk 8/21/2004 13:03'!
directoryForLanguage: isoLanguage country: isoCountry create: createDir
	"Try to locate the <prefs>/locale/<language>{/<country>} folder.
	If createDir is set, create the path down to country or language, depending on wether it's specified..
	Return the directory for country or language depending on specification.
	If neither exists, nil"

	"NaturalLanguageTranslator directoryForLanguage: 'es' country: nil create: true"
	"NaturalLanguageTranslator directoryForLanguage: 'de' country: 'DE' create: true"
	"NaturalLanguageTranslator directoryForLanguage: 'en' country: 'US' create: false"
	"NaturalLanguageTranslator directoryForLanguage: 'en' country: nil create: true"

	"If this fails, there is nothing we can do about it here"
	| localeDir  countryDir languageDir |
	localeDir := self localeDirCreate: createDir.
	localeDir ifNil: [^nil].

	isoCountry ifNil: [
		languageDir := localeDir directoryNamed: isoLanguage.
		createDir
			ifTrue: [languageDir assureExistence].
		^languageDir exists
			ifTrue: [languageDir]
			ifFalse: [nil]].

	countryDir := languageDir directoryNamed: isoCountry.
	createDir
		ifTrue: [countryDir assureExistence].

	^countryDir exists
		ifTrue: [countryDir]
		ifFalse: [nil]! !

!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/11/2004 10:44'!
directoryForLocaleID: localeID create: createDir
	"Try to locate the <prefs>/locale/<language>{/<country>} folder.
	If createDir is set, create the path down to country or language, depending on locale.
	Return the directory for country or language depending on locale.
	If neither exists, nil"

	"NaturalLanguageTranslator directoryForLanguage: 'de' country: nil readOnly: true"
	"NaturalLanguageTranslator directoryForLanguage: 'de' country: 'DE' readOnly: true"
	"NaturalLanguageTranslator directoryForLanguage: 'en' country: 'US' readOnly: false"
	"NaturalLanguageTranslator directoryForLanguage: 'en' country: nil readOnly: true"

	^self directoryForLanguage: localeID isoLanguage country: localeID isoCountry create: createDir! !

!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 11:57'!
loadAvailableExternalLocales
	"private - register locales IDs based on the content of the <prefs>/locale/ directory"
	| localeDir |
	localeDir := self localeDirCreate: false.
	localeDir ifNil: [^ #()].

	localeDir directoryNames
		do: [:langDirName | 
			| langDir | 
			langDir := localeDir directoryNamed: langDirName.

			(langDir fileNamesMatching: '*.' , self translationSuffix)
				ifNotEmpty: [self loadTranslatorForIsoLanguage: langDirName isoCountry: nil].

			langDir directoryNames
				do: [:countryDirName | 
					| countryDir | 
					countryDir := langDirName directoryNamed: countryDirName.
					(countryDir fileNamesMatching: '*.' , self translationSuffix)
						ifNotEmpty: [self loadTranslatorForIsoLanguage: langDirName isoCountry: countryDirName]
			]
		].
! !

!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'nk 8/21/2004 13:00'!
loadExternalTranslationsFor: translator
	"Try to load translations from external external files.
	The files are located in the <prefs>/locale/<language>{/<country>} folder.
	There can be more than one file for each location, so applications can install their own partial translation tables. All files in the specific folder are loaded."

	| translationDir |
	translationDir := self directoryForLocaleID: translator localeID create: false.
	translationDir ifNil: [ ^nil ]. 
	(translationDir fileNamesMatching: '*.' , self translationSuffix)
		do: [:fileName | translator loadFromFileNamed: (translationDir fullNameFor: fileName)]! !

!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 11:59'!
loadTranslatorForIsoLanguage: isoLanguage isoCountry: isoCountry 
	"private - load the translations from <prefs>/locale/ directory  
	the procedure is to assure the existence of a translator for the  
	given language/country and then load the external translations for this translator"

	| translator |
	translator := self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry).

	self loadExternalTranslationsFor: translator! !

!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 12:03'!
localeDirCreate: createDir
	"Try to locate the <prefs>/locale/ folder.
	If createDir is set, try to create the path.
	If it doesn't exist, return nil"

	"If this fails, there is nothing we can do about it here"
	| prefDir  localeDir |
	(createDir not
			and: [ExternalSettings preferenceDirectory isNil])
		ifTrue: [^ nil].

	prefDir := ExternalSettings assuredPreferenceDirectory.
	prefDir exists
		ifFalse: [^nil].


	localeDir := prefDir directoryNamed: 'locale'.
	createDir
		ifTrue: [localeDir assureExistence].
	^localeDir exists
		ifTrue: [localeDir]
		ifFalse: [nil]! !
Object subclass: #NebraskaClient
	instanceVariableNames: 'connection encoder hand canvas'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!NebraskaClient commentStamp: '<historical>' prior: 0!
A client that has connected to a Nebraska server, seen from the server's point of view.!


!NebraskaClient methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 23:59'!
backlog

	^connection backlog! !

!NebraskaClient methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:30'!
currentStatusString

	(connection isNil or: [connection isConnected not]) ifTrue: [^'nada'].
	^(NetNameResolver stringFromAddress: connection remoteAddress),
		' - ',
		(self backlog // 1024) printString,'k'! !


!NebraskaClient methodsFor: 'attributes' stamp: 'ls 3/25/2000 22:27'!
canvas
	"return the hand this canvas that should be drawn on for this client"
	^canvas! !

!NebraskaClient methodsFor: 'attributes' stamp: 'ls 3/25/2000 22:27'!
hand
	"return the hand this client is controlling"
	^hand! !


!NebraskaClient methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
convertToBuffered

	canvas purgeOutputQueue.
	canvas := canvas asBufferedCanvas.! !

!NebraskaClient methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
destroy
	hand ifNotNil:[hand world ifNotNil:[hand world removeHand: hand]].
	connection ifNotNil:[connection destroy].
	encoder := canvas := hand := connection := nil.! !

!NebraskaClient methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize: aConnection

	| remoteAddress userPicture |

	connection := aConnection.
	hand := RemoteControlledHandMorph on: (MorphicEventDecoder on: aConnection).
	hand nebraskaClient: self.
	remoteAddress := connection remoteAddress.
	remoteAddress ifNotNil: [remoteAddress := NetNameResolver stringFromAddress: remoteAddress].
	userPicture := EToySenderMorph pictureForIPAddress: remoteAddress.
	hand
		userInitials: ((EToySenderMorph nameForIPAddress: remoteAddress) ifNil: ['???'])
		andPicture: (userPicture ifNotNil: [userPicture scaledToSize: 16@20]).
	encoder := CanvasEncoder on: aConnection.
	canvas := RemoteCanvas
		connection: encoder
		clipRect: NebraskaServer extremelyBigRectangle
		transform: MorphicTransform identity! !


!NebraskaClient methodsFor: 'network' stamp: 'ls 4/9/2000 14:43'!
extent: newExtent  depth: newDepth
	encoder extent: newExtent  depth: newDepth! !

!NebraskaClient methodsFor: 'network' stamp: 'ls 3/25/2000 22:25'!
isConnected
	^connection isConnected! !

!NebraskaClient methodsFor: 'network' stamp: 'ls 3/25/2000 22:25'!
processIO
	connection processIO.! !

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

NebraskaClient class
	instanceVariableNames: ''!

!NebraskaClient class methodsFor: 'instance creation' stamp: 'ls 3/25/2000 22:28'!
onConnection: aStringSocket
	^self new initialize: aStringSocket! !
Object subclass: #NebraskaDebug
	instanceVariableNames: ''
	classVariableNames: 'DEBUG Details'
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!NebraskaDebug commentStamp: '<historical>' prior: 0!
BufferedCanvas enabled: false.
BufferedCanvas enabled: true.

NebraskaDebug beginStats
NebraskaDebug showStats
NebraskaDebug stopAndShowAll
NebraskaDebug killStats
StringSocket showRatesSeen
StringSocket clearRatesSeen
NebraskaDebug showAndClearStats: #allStats
NebraskaDebug showAndClearStats: #queuedbufferSizes


CanvasEncoder beginStats
CanvasEncoder showStats
CanvasEncoder killStats
NebraskaDebug showStats: #peerBytesSent
NebraskaDebug showStats: #soundReductionTime
NebraskaDebug showStats: #FormEncodeTimes
NebraskaDebug showStats: #SendReceiveStats
NebraskaDebug showStats: #sendDeltas
NebraskaDebug showStats: #bigImage
NebraskaDebug showStats: #sketch
NebraskaDebug showStats: #addToOutBuf:
----
buffered off, painting 125kb/s, dragging 400kb/s
buffered on, painting 100kb/s, dragging 170kb/s!
]style[(62 142 14 78 17 3 73 415)f1cblue;,f1cblack;,f1,f1cblack;,f1cred;,f1cblack;,f1cblue;,f1cblack;!


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

NebraskaDebug class
	instanceVariableNames: ''!

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
at: queueName add: anArray

	| now |

	DEBUG ifNil: [
		queueName == #sketchZZZ ifFalse: [^self].
		"Details := OrderedCollection new."
		self beginStats.
	].
	(Details notNil and: [Details size < 20]) ifTrue: [
		Details add: thisContext longStack
	].
	now := Time millisecondClockValue.
	DEBUG add: {now},anArray,{queueName}.
! !

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

	DEBUG := OrderedCollection new! !

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

	DEBUG := nil.
! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
showAndClearStats: queueName

	DEBUG ifNil: [^Beeper beep].
	self 
		showStats: queueName 
		from: DEBUG.
	DEBUG := nil.! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
showStats

	DEBUG ifNil: [^Beeper beep].
	DEBUG explore.! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
showStats: queueName

	DEBUG ifNil: [^Beeper beep].
	self 
		showStats: queueName 
		from: DEBUG.
! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
showStats: queueName from: aCollection

	| xx answer prevTime currTime |

	prevTime := nil.
	answer := String streamContents: [ :s | 
		s nextPutAll: (aCollection last first - aCollection first first) asStringWithCommas,' ms';cr;cr.
		aCollection withIndexDo: [ :each :index | 
			(queueName == #allStats or: [queueName == each last]) ifTrue: [
				currTime := each first.
				xx := currTime printString.
				prevTime ifNil: [prevTime := currTime].
				s nextPutAll: index printString,'.  ',
					(xx allButLast: 3),'.',(xx last: 3),' ',(currTime - prevTime) printString,' '.
				s nextPutAll: each allButFirst printString; cr.
				prevTime := currTime.
			].
		]
	].
	StringHolder new 
		contents: answer;
		openLabel: queueName! !

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

	| prev |

self halt.	"not updated to new format"

	prev := DEBUG.
	DEBUG := nil.
	prev ifNil: [^Beeper beep].
	prev keysAndValuesDo: [ :k :v |
		self showStats: k from: v
	].! !
ProjectNavigationMorph subclass: #NebraskaNavigationMorph
	instanceVariableNames: 'nebraskaBorder nebraskaTerminal'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:49'!
addButtons

	self addARow: {
		self inAColumn: {self buttonScale}.
		self inAColumn: {self buttonQuit}.
		self inAColumn: {self buttonBuffered}.
	}.
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:26'!
bufferNebraska

	nebraskaTerminal requestBufferedConnection
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:23'!
buttonBuffered

	^self makeButton: 'B' balloonText: 'Request buffered Nebraska session' for: #bufferNebraska
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:34'!
buttonScale

	^self makeButton: '1x1' balloonText: 'Switch between 1x1 and scaled view' for: #toggleFullView
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:47'!
currentNavigatorVersion

	^1		"not particularly relevant here"! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'yo 11/4/2002 21:06'!
fontForButtons

	^ TextStyle defaultFont.
	"^Preferences standardButtonFont"! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
nebraskaBorder: aNebraskaBorder

	nebraskaBorder := aNebraskaBorder! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
nebraskaTerminal: aNebraskaTerminal

	nebraskaTerminal := aNebraskaTerminal! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
positionVertically

	| w |
	w := self world ifNil: [^self].
	self top < w top ifTrue: [self top: w top].
	self bottom > w bottom ifTrue: [self bottom: w bottom].! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:47'!
quitNebraska

	nebraskaBorder ifNotNil: [nebraskaBorder delete].
	self delete.! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:48'!
toggleFullView

	nebraskaBorder ifNotNil: [nebraskaBorder toggleFullView]! !


!NebraskaNavigationMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 11/8/2000 11:42'!
wantsToBeDroppedInto: aMorph

	"avoid difficulties in placement"
	^(aMorph isKindOf: NetworkTerminalMorph) not! !


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


!NebraskaNavigationMorph methodsFor: 'stepping and presenter' stamp: 'RAA 11/8/2000 11:37'!
step

	super step.
	(nebraskaBorder isNil or: [nebraskaBorder world isNil]) ifTrue: [self delete].! !


!NebraskaNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 11/8/2000 11:36'!
buttonQuit

	^self makeButton: 'Quit' balloonText: 'Quit this Nebraska session' for: #quitNebraska
! !
Model subclass: #NebraskaServer
	instanceVariableNames: 'worldDepth world clients listenQueue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!NebraskaServer commentStamp: '<historical>' prior: 0!
A Nebraska server has a private world and some collection of clients.  It associates a RemoteControlledHand for each client.  Redraw events in the world are broadcasted to all connected clients.  A Nebraska server can listen on a TCP/IP port and accept new clients. Current version has been modified so that the server serves the world in which it was launched. Other variations are certainly possible.

To start a server, execute the following code:
	NebraskaServerMorph serveWorld: World

To start a client, run the following in another image:
	NetworkTerminalMorph openAndConnectTo: 'servername'

Fill in your server's hostname for 'servername'. At this point, everything should be working!!

Before starting a server, you can tweak these:
BufferedCanvas enabled: false.
BufferedCanvas enabled: true.

At any time you can do these:
NebraskaDebug beginStats
NebraskaDebug showStats
NebraskaDebug showStats: #delays
NebraskaDebug showStats: #bigImage
NebraskaDebug showStats: #FormEncodeTimes
NebraskaDebug killStats

NOTE: if you want to have a local view of the server, you shouldn't use the TCP connections. The problem is that the server will occasionally do a #flush, and it won't work due to single threading. The better solution is to use a LoopBackStringSocket instead of a regular StringSocket, but there is no handy method for that right now....


!
]style[(266 136 49 39 56 53 96 46 1 62 29 525)f1,f1cred;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cred;,f1cblue;,f1!


!NebraskaServer methodsFor: 'accessing' stamp: 'ar 10/26/2000 14:23'!
clients
	^clients ifNil:[#()].! !


!NebraskaServer methodsFor: 'attributes' stamp: 'ls 4/11/2000 19:48'!
extent: newExtent  depth: newDepth
	"modify the extent and/or depth of the shared world"
	clients do: [ :client |
		client extent: newExtent depth: newDepth ].
	world extent: newExtent.

	worldDepth := newDepth.! !

!NebraskaServer methodsFor: 'attributes' stamp: 'ls 4/11/2000 18:41'!
numClients
	"return the number of connected clients"
	^clients size! !

!NebraskaServer methodsFor: 'attributes' stamp: 'ls 3/25/2000 23:13'!
sharedWorld
	^world! !


!NebraskaServer methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:02'!
destroy
	self stopListening.
	clients do:[:each| each destroy].
	self breakDependents.! !

!NebraskaServer methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:20'!
initialize
	clients := IdentitySet new.
	self extent: 800@600 depth: 16.! !

!NebraskaServer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initializeForWorld: aWorld

	world := aWorld.
	clients := IdentitySet new.
	self extent: world extent depth: Display depth.
	aWorld remoteServer: self.! !


!NebraskaServer methodsFor: 'menus' stamp: 'RAA 7/31/2000 22:28'!
step

	self processIO.

	"savedWorld := Processor activeProcess world.
	Processor activeProcess setWorld: world."

	self flag: #bob.		"in this version, world is THE WORLD, so it steps itself"
	"world doOneCycle."

	"Processor activeProcess setWorld: savedWorld."

	clients do: [ :each | each canvas apply: [ :ignore | ]].	"for modes that need a little push"
! !


!NebraskaServer methodsFor: 'networking' stamp: 'ls 3/25/2000 22:35'!
acceptNewConnections
	| connection |
	listenQueue ifNil: [ ^self ].
	[ clients size > 20 ifTrue: [ "too many connections!!" ^self ].
	  connection := listenQueue getConnectionOrNil.  
	  connection isNil ] 
	whileFalse: [
	  self addClientFromConnection: (StringSocket on: connection) ].! !

!NebraskaServer methodsFor: 'networking' stamp: 'sd 11/20/2005 21:25'!
acceptNullConnection

	| twins |

	twins := LoopbackStringSocket newPair.
	self addClientFromConnection: twins first.
	(NullTerminalMorph new connection: twins second) openInWorld.
! !

!NebraskaServer methodsFor: 'networking' stamp: 'sd 11/20/2005 21:25'!
acceptPhonyConnection

	| twins |

	twins := LoopbackStringSocket newPair.
	self addClientFromConnection: twins first.
	(NetworkTerminalMorph new connection: twins second) inspect "openInWorld".
! !

!NebraskaServer methodsFor: 'networking' stamp: 'RAA 7/20/2000 10:03'!
addClientFromConnection: connection
	| client |

	client := NebraskaClient onConnection: connection.
	clients add: client.
	client extent: world extent  depth: worldDepth.
	world addRemoteClient: client.
	self changed: #numClients.! !

!NebraskaServer methodsFor: 'networking' stamp: 'RAA 8/1/2000 00:01'!
backlog

	^clients inject: 0 into: [ :max :each | max max: each backlog]! !

!NebraskaServer methodsFor: 'networking' stamp: 'ls 3/25/2000 22:36'!
processIO
	self pruneDeadConnections.
	self acceptNewConnections.! !

!NebraskaServer methodsFor: 'networking' stamp: 'ar 10/26/2000 14:20'!
pruneDeadConnections
	| deadConnections |
	deadConnections := clients select: [ :client | client isConnected not ].
	deadConnections do: [ :client |
		world removeRemoteClient: client].

	deadConnections isEmpty ifTrue:[ ^self ].

	clients removeAll: deadConnections.
	self changed: #numClients.! !

!NebraskaServer methodsFor: 'networking' stamp: 'ls 3/25/2000 22:31'!
startListeningOnPort: portNumber
	Socket initializeNetwork.
	self stopListening.
	listenQueue := ConnectionQueue portNumber: portNumber  queueLength: 5.! !

!NebraskaServer methodsFor: 'networking' stamp: 'ls 3/25/2000 22:32'!
stopListening
	listenQueue ifNil: [ ^self ].
	listenQueue destroy.
	listenQueue := nil.! !

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

NebraskaServer class
	instanceVariableNames: ''!

!NebraskaServer class methodsFor: 'as yet unclassified' stamp: 'RAA 7/24/2000 12:06'!
defaultPort

	^9091! !

!NebraskaServer class methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 14:59'!
extremelyBigRectangle

	^(0@0 extent: 5000@5000)! !


!NebraskaServer class methodsFor: 'instance creation' stamp: 'mu 11/28/2003 19:38'!
newForWorld: aWorld

	^self basicNew initializeForWorld: aWorld! !

!NebraskaServer class methodsFor: 'instance creation' stamp: 'ar 10/26/2000 14:00'!
serveWorld: aWorld

	^self serveWorld: aWorld onPort: self defaultPort! !

!NebraskaServer class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:26'!
serveWorld: aWorld onPort: aPortNumber

	| server |

	Utilities authorName.	"since we will need it later"

	server := self newForWorld: aWorld.
	server startListeningOnPort: aPortNumber.
	^server
	"server acceptNullConnection"		"server acceptPhonyConnection."
! !
AlignmentMorphBob1 subclass: #NebraskaServerMorph
	instanceVariableNames: 'server slowCounter previousBacklog lastFullUpdateTime currentStatusString fullDisplay previousClients currentBacklogString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!NebraskaServerMorph commentStamp: '<historical>' prior: 0!
A cheezy morph that simply steps a Nebraska server instance over and over.!


!NebraskaServerMorph methodsFor: 'accessing' stamp: 'RAA 5/31/2001 15:03'!
currentBacklogString

	^currentBacklogString! !

!NebraskaServerMorph methodsFor: 'accessing' stamp: 'RAA 11/8/2000 16:07'!
currentStatusString

	^currentStatusString! !

!NebraskaServerMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 14:05'!
server
	^self world remoteServer! !


!NebraskaServerMorph methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:25'!
updateCurrentStatusString

	self server ifNil:[
		currentStatusString := '<Nebraska not active>' translated.
		currentBacklogString := ''.
	] ifNotNil:[
		currentStatusString := 
			' Nebraska: ' translated, 
			self server numClients printString, 
			' clients' translated.
		currentBacklogString := 'backlog: ' translated,
				((previousBacklog := self server backlog) // 1024) printString,'k'
	].
! !


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

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	fullDisplay := false.
	
	lastFullUpdateTime := 0.
	self listDirection: #topToBottom;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap! !

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
rebuild

	| myServer toggle closeBox font |

	font := StrikeFont familyName: #Palatino size: 14.
	self removeAllMorphs.
	self setColorsAndBorder.
	self updateCurrentStatusString.
	toggle := SimpleHierarchicalListMorph new perform: (
		fullDisplay ifTrue: [#expandedForm] ifFalse: [#notExpandedForm]
	).
	closeBox := SimpleButtonMorph new borderWidth: 0;
			label: 'X' font: Preferences standardButtonFont; color: Color transparent;
			actionSelector: #delete; target: self; extent: 14@14;
			setBalloonText: 'End Nebrasks session'.

	self addARow: {
		self inAColumn: {closeBox}.
		self inAColumn: {
			UpdatingStringMorph new
				useStringFormat;
				target:  self;
				font: font;
				getSelector: #currentStatusString;
				contents: self currentStatusString;
				stepTime: 2000;
				lock.
		}.
		self inAColumn: {
			toggle asMorph
				on: #mouseUp send: #toggleFull to: self;
				setBalloonText: 'Show more or less of Nebraska Status'
		}.
	}.
	myServer := self server.
	(myServer isNil or: [fullDisplay not]) ifTrue: [
		^World startSteppingSubmorphsOf: self
	].
	"--- the expanded display ---"
	self addARow: {
		self inAColumn: {
			UpdatingStringMorph new
				useStringFormat;
				target:  self;
				font: font;
				getSelector: #currentBacklogString;
				contents: self currentBacklogString;
				stepTime: 2000;
				lock.
		}.
	}.

	self addARow: {
		self inAColumn: {
			(StringMorph contents: '--clients--' translated) lock; font: font.
		}.
	}.

	myServer clients do: [ :each |
		self addARow: {
			UpdatingStringMorph new
				useStringFormat;
				target: each;
				font: font;
				getSelector: #currentStatusString;
				contents: each currentStatusString;
				stepTime: 2000;
				lock.
		}
	].
	World startSteppingSubmorphsOf: self.! !

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:35'!
setColorsAndBorder
	| worldColor c |
	c := ((Preferences menuColorFromWorld and: [Display depth > 4]) 
				and: [(worldColor := self currentWorld color) isColor]) 
					ifTrue: 
						[worldColor luminance > 0.7 
							ifTrue: [worldColor mixed: 0.8 with: Color black]
							ifFalse: [worldColor mixed: 0.4 with: Color white]]
					ifFalse: [Preferences menuColor]. 
	self color: c.
	self borderColor: #raised.
	self borderWidth: Preferences menuBorderWidth.
	self useRoundedCorners! !

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
toggleFull

	fullDisplay := fullDisplay not.
	self rebuild.
! !


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

	| now |

	self server ifNil: [ ^self ].
	self server step.
	now := Time millisecondClockValue.
	(now - lastFullUpdateTime) abs > 5000 ifTrue: [
		lastFullUpdateTime := now.
		(previousBacklog = self server backlog and: [self server clients = previousClients]) ifFalse: [
			previousClients := self server clients copy.
			self rebuild
		]
	].
! !


!NebraskaServerMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 10/26/2000 14:07'!
delete
	self server ifNotNil:[
		(self confirm:'Shutdown the server?') 
			ifTrue:[self world remoteServer: nil]].
	super delete.! !


!NebraskaServerMorph methodsFor: 'testing' stamp: 'RAA 11/8/2000 15:57'!
stepTime

	^10! !


!NebraskaServerMorph methodsFor: 'updating' stamp: 'RAA 11/8/2000 16:03'!
update: aSymbol

	self rebuild.! !

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

NebraskaServerMorph class
	instanceVariableNames: ''!

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/15/2000 14:49'!
killOldServers

	NebraskaServerMorph allInstances do: [ :each |
		each delete.
	].
	NebraskaServer allInstances do: [ :each |
		each stopListening.
		DependentsFields removeKey: each ifAbsent: [].
	].
! !

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'yo 12/17/2005 23:06'!
serveWorld

	^ self serveWorld: ActiveWorld.
! !

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'yo 12/17/2005 23:07'!
serveWorldButton

	| button |
	button _ ScriptableButton new.
	button target: NebraskaServerMorph.
	button actionSelector: #serveWorld.
	button arguments: #().
	button label: 'Share'.
	button color: Color yellow.
	^ button.
! !

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'wiz 1/9/2005 15:12'!
serveWorld: aWorld
	"Check to make sure things won't crash. See Mantis #0000519"
	aWorld isSafeToServe ifTrue:[
		^self serveWorld: aWorld onPort: NebraskaServer defaultPort]
	! !

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 10/26/2000 14:05'!
serveWorld: aWorld onPort: aPortNumber

	| server |
	server := NebraskaServer serveWorld: aWorld onPort: aPortNumber.
	(self new) openInWorld: aWorld.

	"server acceptNullConnection"		"server acceptPhonyConnection."
! !

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'yo 12/17/2005 23:08'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'NebraskaServer'
		categoryList: #('Collaborative')
		documentation: 'A button to start the Nebraska desktop sharing server' translated
		globalReceiverSymbol: #NebraskaServerMorph
		nativitySelector: #serveWorldButton
	}! !
Object subclass: #NetNameResolver
	instanceVariableNames: ''
	classVariableNames: 'DefaultHostName HaveNetwork ResolverBusy ResolverError ResolverMutex ResolverReady ResolverSemaphore ResolverUninitialized'
	poolDictionaries: ''
	category: 'Network-Kernel'!
!NetNameResolver commentStamp: '<historical>' prior: 0!
This class implements TCP/IP style network name lookup and translation facilities.

Attempt to keep track of whether there is a network available.
HaveNetwork	true if last attempt to contact the network was successful.
LastContact		Time of that contact (totalSeconds).
haveNetwork	returns true, false, or #expired.  True means there was contact in the last 30 minutes.  False means contact failed or was false last time we asked.  Get out of false state by making contact with a server in some way (FileList or updates).!


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

NetNameResolver class
	instanceVariableNames: ''!

!NetNameResolver class methodsFor: 'address string utils' stamp: 'jm 9/15/97 06:19'!
addressFromString: addressString
	"Return the internet address represented by the given string. The string should contain four positive decimal integers delimited by periods, commas, or spaces, where each integer represents one address byte. Return nil if the string is not a host address in an acceptable format."
	"NetNameResolver addressFromString: '1.2.3.4'"
	"NetNameResolver addressFromString: '1,2,3,4'"
	"NetNameResolver addressFromString: '1 2 3 4'"

	| newAddr s byte delimiter |
	newAddr _ ByteArray new: 4.
	s _ ReadStream on: addressString.
	s skipSeparators.
	1 to: 4 do: [:i |
		byte _ self readDecimalByteFrom: s.
		byte = nil ifTrue: [^ nil].
		newAddr at: i put: byte.
		i < 4 ifTrue: [
			delimiter _ s next.
			((delimiter = $.) or: [(delimiter = $,) or: [delimiter = $ ]])
				ifFalse: [^ nil]]].
	^ newAddr
! !

!NetNameResolver class methodsFor: 'address string utils' stamp: 'jm 9/15/97 16:52'!
stringFromAddress: addr
	"Return a string representing the given host address as four decimal bytes delimited with decimal points."
	"NetNameResolver stringFromAddress: NetNameResolver localHostAddress"

	| s |
	s _ WriteStream on: ''.
	1 to: 3 do: [ :i | (addr at: i) printOn: s. s nextPut: $.].
	(addr at: 4) printOn: s.
	^ s contents
! !


!NetNameResolver class methodsFor: 'class initialization' stamp: 'jm 9/17/97 16:18'!
initialize
	"NetNameResolver initialize"
	"Note: On the Mac, the name resolver is asynchronous (i.e., Squeak can do other things while it is working), but can only handle one request at a time. On other platforms, such as Unix, the resolver is synchronous; a call to, say, the name lookup primitive will block all Squeak processes until it returns."

	"Resolver Status Values"
	ResolverUninitialized _ 0.	"network is not initialized"
	ResolverReady _ 1.			"resolver idle, last request succeeded"
	ResolverBusy _ 2.			"lookup in progress"
	ResolverError _ 3.			"resolver idle, last request failed"

	DefaultHostName _ ''.
! !


!NetNameResolver class methodsFor: 'lookups' stamp: 'ls 9/5/1998 01:14'!
addressForName: aString
	^self addressForName: aString timeout: 60! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'mu 9/7/2003 22:53'!
addressForName: hostName timeout: secs
	"Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds."
	"NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30"
	"NetNameResolver addressForName: '100000jobs.de' timeout: 30"
	"NetNameResolver addressForName: '1.7.6.4' timeout: 30"
	"NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)"

	| deadline result |
	self initializeNetwork.
	"check if this is a valid numeric host address (e.g. 1.2.3.4)"
	result _ self addressFromString: hostName.
	result isNil ifFalse: [^result].

	"Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)"
	deadline _ Time millisecondClockValue + (secs * 1000).
	"Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction."
	self resolverMutex
		critical: [
			(self waitForResolverReadyUntil: deadline)
				ifTrue: [
					self primStartLookupOfName: hostName.
					(self waitForCompletionUntil: deadline)
						ifTrue: [result _ self primNameLookupResult]
						ifFalse: [(NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName]]
				ifFalse: [(NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName]].
	^result! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:52'!
localAddressString
	"Return a string representing the local host address as four decimal bytes delimited with decimal points."
	"NetNameResolver localAddressString"

	^ NetNameResolver stringFromAddress: NetNameResolver localHostAddress
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'mir 2/22/2002 15:50'!
localHostAddress
	"Return the local address of this host."
	"NetNameResolver localHostAddress"

	self initializeNetwork.
	^ self primLocalAddress
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'mir 2/22/2002 15:12'!
localHostName
	"Return the local name of this host."
	"NetNameResolver localHostName"

	| hostName |
	hostName _ NetNameResolver
		nameForAddress: self localHostAddress
		timeout: 5.
	^hostName
		ifNil: [self localAddressString]
		ifNotNil: [hostName]! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'nk 6/27/2003 10:51'!
nameForAddress: hostAddress timeout: secs
	"Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses."
	"NetNameResolver
		nameForAddress: (NetNameResolver addressFromString: '128.111.92.2')
		timeout: 30"

	| deadline result |
	self initializeNetwork.
	deadline _ Time millisecondClockValue + (secs * 1000).
	"Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction."
	self resolverMutex
		critical: [
			result _ (self waitForResolverReadyUntil: deadline)
				ifTrue: [
					self primStartLookupOfAddress: hostAddress.
					(self waitForCompletionUntil: deadline)
						ifTrue: [self primAddressLookupResult]
						ifFalse: [nil]]
				ifFalse: [nil]].
	^result
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/17/97 16:26'!
promptUserForHostAddress
	"Ask the user for a host name and return its address."
	"NetNameResolver promptUserForHostAddress"

	^ NetNameResolver promptUserForHostAddressDefault: ''
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'rbb 3/1/2005 11:01'!
promptUserForHostAddressDefault: defaultName
	"Ask the user for a host name and return its address. If the default name is the empty string, use the last host name as the default."
	"NetNameResolver promptUserForHostAddressDefault: ''"

	| default hostName serverAddr |
	defaultName isEmpty
		ifTrue: [default := DefaultHostName]
		ifFalse: [default := defaultName].
	hostName := UIManager default
		request: 'Host name or address?'
		initialAnswer: default.
	hostName isEmpty ifTrue: [^ 0].
	serverAddr := NetNameResolver addressForName: hostName timeout: 15.
	hostName size > 0 ifTrue: [DefaultHostName := hostName].
	^ serverAddr! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'!
resolverError
	^self primNameResolverError
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'!
resolverStatus
	^self primNameResolverStatus
! !


!NetNameResolver class methodsFor: 'network initialization' stamp: 'mir 2/22/2002 15:03'!
initializeNetwork
	"Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails."
	"NetNameResolver initializeNetwork"

	| semaIndex |
	self resolverStatus = ResolverUninitialized
		ifFalse: [^HaveNetwork _ true].  "network is already initialized"

	HaveNetwork _ false.	"in case abort"
	ResolverSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: ResolverSemaphore.

	"result is nil if network initialization failed, self if it succeeds"
	(self primInitializeNetwork: semaIndex)
		ifNil: [NoNetworkError signal: 'failed network initialization']
		ifNotNil: [HaveNetwork _ true].
! !

!NetNameResolver class methodsFor: 'network initialization' stamp: 'ar 2/2/2001 15:09'!
primInitializeNetwork: resolverSemaIndex
	"Initialize the network drivers on platforms that need it, such as the Macintosh, and return nil if network initialization failed or the reciever if it succeeds. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed."
	"Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests."

	<primitive: 'primitiveInitializeNetwork' module: 'SocketPlugin'>
	^ nil  "return nil if primitive fails"
! !


!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAbortLookup
	"Abort the current lookup operation, freeing the name resolver for the next query."

	<primitive: 'primitiveResolverAbortLookup' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAddressLookupResult
	"Return the host name found by the last host address lookup. Returns nil if the last lookup was unsuccessful."

	<primitive: 'primitiveResolverAddressLookupResult' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primLocalAddress
	"Return the local address of this host."

	<primitive: 'primitiveResolverLocalAddress' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primNameLookupResult
	"Return the host address found by the last host name lookup. Returns nil if the last lookup was unsuccessful."

	<primitive: 'primitiveResolverNameLookupResult' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primNameResolverError
	"Return an integer reflecting the error status of the last network name resolver request. Zero means no error."

	<primitive: 'primitiveResolverError' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primNameResolverStatus
	"Return an integer reflecting the status of the network name resolver. For a list of possible values, see the comment in the 'initialize' method of this class."

	<primitive: 'primitiveResolverStatus' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primStartLookupOfAddress: hostAddr
	"Look up the given host address in the Domain Name Server to find its name. This call is asynchronous. To get the results, wait for it to complete or time out and then use primAddressLookupResult."

	<primitive: 'primitiveResolverStartAddressLookup' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primStartLookupOfName: hostName
	"Look up the given host name in the Domain Name Server to find its address. This call is asynchronous. To get the results, wait for it to complete or time out and then use primNameLookupResult."

	<primitive: 'primitiveResolverStartNameLookup' module: 'SocketPlugin'>
	self primitiveFailed
! !


!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 13:57'!
readDecimalByteFrom: aStream
	"Read a positive, decimal integer from the given stream. Stop when a non-digit or end-of-stream is encountered. Return nil if stream is not positioned at a decimal digit or if the integer value read exceeds 255.
JMM - 000503 fixed didn't work correctly"

	| digitSeen value digit |
	digitSeen _ false.
	value _ 0.
	[aStream atEnd] whileFalse: 
		[digit _ aStream next digitValue.
		(digit < 0 or: [digit > 9]) ifTrue: [
			aStream skip: -1.
			(digitSeen not or: [value > 255]) ifTrue: [^ nil].
			^ value].
		digitSeen _ true.
		value _ (value * 10) + digit].
	(digitSeen not or: [value > 255]) ifTrue: [^ nil].
	^ value
! !

!NetNameResolver class methodsFor: 'private' stamp: 'mir 6/18/2001 21:05'!
resolverMutex
	ResolverMutex ifNil: [ResolverMutex _ Semaphore forMutualExclusion].
	^ResolverMutex! !

!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 11:35'!
waitForCompletionUntil: deadline
	"Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver does not become free within the given time period."

	| status |
	status _ self resolverStatus.
	[(status = ResolverBusy) and:
	 [Time millisecondClockValue < deadline]]
		whileTrue: [
			"wait for resolver to be available"
			ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
			status _ self resolverStatus].

	status = ResolverReady
		ifTrue: [^ true]
		ifFalse: [
			status = ResolverBusy ifTrue: [self primAbortLookup].
			^ false].
! !

!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 11:36'!
waitForResolverReadyUntil: deadline
	"Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver does not become free within the given time period."

	| status |
	status _ self resolverStatus.
	status = ResolverUninitialized ifTrue: [^ false].

	[(status = ResolverBusy) and:
	 [Time millisecondClockValue < deadline]]
		whileTrue: [
			"wait for resolver to be available"
			ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
			status _ self resolverStatus].

	^ status ~= ResolverBusy
! !
Error subclass: #NetworkError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!NetworkError commentStamp: 'mir 5/12/2003 18:12' prior: 0!
Abstract super class for all network related exceptions.!

EmbeddedWorldBorderMorph subclass: #NetworkTerminalBorderMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!

!NetworkTerminalBorderMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
toggleFullView
	"Toggle the full view for network terminal"
	| fullExtent priorExtent |
	fullExtent := self worldIEnclose extent + (2 * self borderWidth).
	priorExtent := self valueOfProperty: #priorExtent.
	priorExtent ifNil:[
		self setProperty: #priorExtent toValue: self extent.
		self extent: fullExtent.
		self position: self position + self borderWidth asPoint negated.
	] ifNotNil:[
		self removeProperty: #priorExtent.
		self extent: priorExtent.
		self position: (self position max: 0@0).
	].! !


!NetworkTerminalBorderMorph methodsFor: 'boxes' stamp: 'RAA 8/15/2000 12:21'!
boxesAndColorsAndSelectors

	^#()! !


!NetworkTerminalBorderMorph methodsFor: 'initialization' stamp: 'RAA 12/14/2000 14:12'!
initialize

	super initialize.
	self setBalloonText: nil.		"'I am a view on another Squeak'."
	self layoutInset: 0.
! !
Morph subclass: #NetworkTerminalMorph
	instanceVariableNames: 'connection decoder eventEncoder backgroundForm enteringHand'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!NetworkTerminalMorph commentStamp: '<historical>' prior: 0!
A morph used to communicate with a remote image.  It sends all mouse/keyboard events to the remote side, and it displays canvas commands that are sent back.!


!NetworkTerminalMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/29/2000 12:13'!
addScalingMenuItems: menu hand: aHandMorph

	"for comaptibility when in scaled frame"! !


!NetworkTerminalMorph methodsFor: 'drawing' stamp: 'RAA 7/25/2000 13:00'!
areasRemainingToFill: aRectangle
	"I assume that we are opaque"

	^ aRectangle areasOutside: self bounds! !

!NetworkTerminalMorph methodsFor: 'drawing' stamp: 'RAA 7/24/2000 11:43'!
drawOn: aCanvas

	backgroundForm ifNotNil: [
		aCanvas clipBy: bounds during: [ :c |
			c drawImage: backgroundForm at: bounds topLeft
		].
	].
! !

!NetworkTerminalMorph methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:25'!
forceToFront: aRegion
	| highQuality |
	"force the given region from the drawing form onto the background form"

	highQuality := false.		"highQuality is slower"

	self updateBackgroundForm.
	backgroundForm
		copy: aRegion
		from: aRegion topLeft
		in: decoder drawingForm
		rule: Form over.
	self invalidRect: (
		highQuality ifTrue: [
			bounds
		] ifFalse: [
			(aRegion expandBy: 4) translateBy: bounds topLeft	"try to remove gribblys"
		]
	)
! !

!NetworkTerminalMorph methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:26'!
updateBackgroundForm
	"make sure that our background form matches what the server has most recently requested"

	| drawingForm |

	drawingForm := decoder drawingForm.
	(drawingForm extent = backgroundForm extent and: [
		drawingForm depth = backgroundForm depth ]) ifTrue: [
			"they match just fine"
			^self ].

	backgroundForm := drawingForm deepCopy.		"need copy to capture the moment"
	self extent: backgroundForm extent.! !


!NetworkTerminalMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 11/5/2000 13:26'!
wantsDroppedMorph: aMorph event: evt

	^true.! !


!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'RAA 11/5/2000 13:23'!
commResult: anArrayOfAssociations

	"ignore for now"! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 15:25'!
handlesMouseOver: evt
	^true! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 15:24'!
mouseEnter: evt
	evt hand newKeyboardFocus: self.
	evt hand needsToBeDrawn ifTrue:[Cursor blank show].! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 15:25'!
mouseLeave: evt

	evt hand needsToBeDrawn ifTrue:[Cursor normal show].! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'RAA 8/15/2000 11:34'!
sendEvent: evt

	self sendEventAsIs: (evt translatedBy: bounds topLeft negated).! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'RAA 8/15/2000 11:33'!
sendEventAsIs: evt

	eventEncoder ifNil: [ ^self ].
	eventEncoder sendEvent: evt.! !


!NetworkTerminalMorph methodsFor: 'events-processing' stamp: 'ar 10/24/2000 18:02'!
handleKeyDown: anEvent
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'events-processing' stamp: 'ar 10/24/2000 18:02'!
handleKeyUp: anEvent
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'events-processing' stamp: 'ar 10/24/2000 18:11'!
handleKeystroke: anEvent
	anEvent wasHandled ifTrue:[^self].
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'events-processing' stamp: 'ar 10/24/2000 18:03'!
handleMouseDown: anEvent
	anEvent wasHandled ifTrue:[^self].
	anEvent hand removePendingBalloonFor: self.
	anEvent hand removePendingHaloFor: self.
	anEvent wasHandled: true.
	anEvent hand newMouseFocus: self event: anEvent.
	anEvent hand removeHaloFromClick: anEvent on: self.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'events-processing' stamp: 'ar 10/24/2000 18:04'!
handleMouseMove: anEvent
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(anEvent hand hasSubmorphs) ifTrue:[^self].
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus ~~ self]) ifTrue:[^self].
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'events-processing' stamp: 'ar 10/24/2000 18:03'!
handleMouseUp: anEvent
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand mouseFocus == self ifFalse:[^self]. "Not interested in other parties"
	anEvent hand releaseMouseFocus: self.
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'events-processing' stamp: 'ar 10/24/2000 18:06'!
handlerForMouseDown: anEvent
	^self! !


!NetworkTerminalMorph methodsFor: 'geometry' stamp: 'RAA 7/24/2000 11:35'!
extent: newExtent

	super extent: newExtent.
	eventEncoder sendViewExtent: self extent! !


!NetworkTerminalMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 12:06'!
connection: aConnection

	connection := aConnection.
	decoder := CanvasDecoder connection: aConnection.
	eventEncoder := MorphicEventEncoder on: aConnection.! !

!NetworkTerminalMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initialize
	super initialize.
	backgroundForm := (
		(StringMorph contents: '......' font: (TextStyle default fontOfSize: 24))
			color: Color white
	) imageForm.
	bounds := backgroundForm boundingBox.
! !

!NetworkTerminalMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 10:45'!
openInStyle: aSymbol

	aSymbol == #naked ifTrue: [
		self openInWorld.
	].
	aSymbol == #scaled ifTrue: [
		self openScaled.
	].
	aSymbol == #bordered ifTrue: [
		AlignmentMorph newColumn
			hResizing: 	#shrinkWrap;
			vResizing: 	#shrinkWrap;
			borderWidth: 8;
			borderColor: Color blue;
			addMorph: self;
			openInWorld.
	].

	[
		[self world isNil] whileFalse: [(Delay forSeconds: 2) wait].
		self disconnect.
	] fork.

! !

!NetworkTerminalMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
openScaled

	| window tm |
	window := NetworkTerminalBorderMorph new
		minWidth: 100;
		minHeight: 100;
		borderWidth: 8;
		borderColor: Color orange;
		bounds: (0@0 extent: Display extent * 3 // 4).
	tm := BOBTransformationMorph new.
	tm useRegularWarpBlt: true.		"try to reduce memory used"
	window addMorphBack: tm.
	tm addMorph: self.
	window openInWorld.
	NebraskaNavigationMorph new 
		nebraskaBorder: window;
		nebraskaTerminal: self;
		openInWorld.! !


!NetworkTerminalMorph methodsFor: 'layout' stamp: 'sd 11/20/2005 21:25'!
acceptDroppingMorph: morphToDrop event: evt

	| myCopy outData null |

	(morphToDrop isKindOf: NewHandleMorph) ifTrue: [			"don't send these"
		^morphToDrop rejectDropMorphEvent: evt.
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we don't really want it"

	"7 mar 2001 - remove #veryDeepCopy"
	myCopy := morphToDrop.	"gradient fills require doing this second"
	myCopy setProperty: #positionInOriginatingWorld toValue: morphToDrop position.

	outData := myCopy eToyStreamedRepresentationNotifying: nil.
	null := String with: 0 asCharacter.
	EToyPeerToPeer new 
		sendSomeData: {
			EToyIncomingMessage typeMorph,null. 
			Preferences defaultAuthorName,null.
			outData
		}
		to: (NetNameResolver stringFromAddress: connection remoteAddress)
		for: self.
! !


!NetworkTerminalMorph methodsFor: 'shutting down' stamp: 'ls 4/11/2000 18:36'!
disconnect
	connection ifNotNil: [ connection destroy ].
	eventEncoder := connection := decoder := nil.! !

!NetworkTerminalMorph methodsFor: 'shutting down' stamp: 'RAA 12/13/2000 08:21'!
requestBufferedConnection

	eventEncoder ifNotNil: [eventEncoder requestBufferedConnection].
! !


!NetworkTerminalMorph methodsFor: 'stepping and presenter' stamp: 'ar 10/25/2000 23:19'!
step

	decoder ifNil: [ ^self ].
	decoder processIOOnForce: [ :rectangle | self forceToFront: rectangle ].! !


!NetworkTerminalMorph methodsFor: 'testing' stamp: 'ls 3/25/2000 16:58'!
stepTime
	^10! !

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

NetworkTerminalMorph class
	instanceVariableNames: ''!

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'RAA 8/4/2000 15:13'!
connectTo: serverHost

	^self connectTo: serverHost port: NebraskaServer defaultPort

! !

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:26'!
connectTo: serverHost port: serverPort

	| stringSock |

	stringSock := self socketConnectedTo: serverHost port: serverPort.
	^self new connection: stringSock
! !

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'RAA 7/24/2000 12:08'!
openAndConnectTo: serverHost

	^self openAndConnectTo: serverHost port: NebraskaServer defaultPort

! !

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:26'!
openAndConnectTo: serverHost port: serverPort

	| stringSock me |

	stringSock := self socketConnectedTo: serverHost port: serverPort.
	me := self new connection: stringSock.
	^me openInStyle: #naked
! !

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:26'!
socketConnectedTo: serverHost  port: serverPort

	| sock |

	Socket initializeNetwork.
	sock := Socket new.
	[sock connectTo: (NetNameResolver addressForName: serverHost) port: serverPort]
		on: ConnectionTimedOut
		do: [:ex | self error: 'could not connect to server' ].
	^StringSocket on: sock

! !
HandleMorph subclass: #NewHandleMorph
	instanceVariableNames: 'hand offset waitingForClickInside'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!NewHandleMorph methodsFor: 'all' stamp: 'di 5/18/1998 15:27'!
followHand: aHand forEachPointDo: block1 lastPointDo: block2
	hand _ aHand.
	pointBlock _ block1.
	lastPointBlock _ block2.
	self position: hand lastEvent cursorPoint - (self extent // 2)! !

!NewHandleMorph methodsFor: 'all' stamp: 'ar 8/16/2001 15:48'!
followHand: aHand forEachPointDo: block1 lastPointDo: block2 withCursor: aCursor
	hand _ aHand.
	hand showTemporaryCursor: aCursor "hotSpotOffset: aCursor offset negated".
	borderWidth _ 0.
	color _ Color transparent.
	pointBlock _ block1.
	lastPointBlock _ block2.
	self position: hand lastEvent cursorPoint - (self extent // 2)! !

!NewHandleMorph methodsFor: 'all' stamp: 'RAA 4/19/2001 11:36'!
sensorMode

	"If our client is still addressing the Sensor directly, we need to do so as well"
	^self valueOfProperty: #sensorMode ifAbsent: [false].
! !

!NewHandleMorph methodsFor: 'all' stamp: 'RAA 4/19/2001 11:36'!
sensorMode: aBoolean

	"If our client is still addressing the Sensor directly, we need to do so as well"
	self setProperty: #sensorMode toValue: aBoolean.
! !


!NewHandleMorph methodsFor: 'dropping/grabbing' stamp: 'di 4/30/1999 14:06'!
justDroppedInto: aMorph event: anEvent
	"No dropping behavior because stepping will delete me.
	Moreover it needs to be done that way to evaluate lastPointBlock"
! !

!NewHandleMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:16'!
undoGrabCommand
	^nil! !


!NewHandleMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:29'!
initialize
"initialize the state of the receiver"

	super initialize.
""
	waitingForClickInside _ true.
	Preferences noviceMode
		ifTrue: [self setBalloonText: 'stretch']! !


!NewHandleMorph methodsFor: 'stepping and presenter' stamp: 'RAA 4/19/2001 11:37'!
step
	| eventSource |

	eventSource _ self sensorMode ifTrue: [
		Sensor
	] ifFalse: [
		hand lastEvent
	].
	eventSource anyButtonPressed
		ifTrue: [waitingForClickInside _ false.
				self position: eventSource cursorPoint - (self extent // 2).
				pointBlock value: self center]
		ifFalse: [waitingForClickInside
					ifTrue: [(self containsPoint: eventSource cursorPoint)
								ifFalse: ["mouse wandered out before clicked"
										^ self delete]]
					ifFalse: [lastPointBlock value: self center.
							^ self delete]]! !


!NewHandleMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/16/2001 15:38'!
delete
	hand ifNotNil:[
		hand showTemporaryCursor: nil.
	].
	super delete.! !


!NewHandleMorph methodsFor: 'WiW support' stamp: 'RAA 1/10/2001 10:15'!
morphicLayerNumber

	^1		"handles are very front-like - e.g. the spawn reframe logic actually asks if the first submorph of the world is one of us before deciding to create one"! !

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

NewHandleMorph class
	instanceVariableNames: ''!

!NewHandleMorph class methodsFor: 'new-morph participation' stamp: 'di 5/3/1998 10:08'!
includeInNewMorphMenu
	^ false! !
Object subclass: #NewParagraph
	instanceVariableNames: 'text textStyle firstCharacterIndex container lines positionWhenComposed offsetToEnd maxRightX selectionStart selectionStop wantsColumnBreaks focused'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!NewParagraph commentStamp: '<historical>' prior: 0!
A Paragraph represents text that has been laid out, or composed, in some container.
	text 		A Text with encoded per-character emphasis.
	textStyle	A TextStyle with font set, line height and horizontal alignment.
	firstCharacterIndex    The starting index in text for this paragraph, allowing
				composition of a long text into a number of containers.
	container	A Rectangle or TextContainer that determines where text can go.
	lines		An Array of TextLines comprising the final layout of the text
				after it has been composed within its container.
	positionWhenComposed   As its name implies.  Allows display at new locations
				without the need to recompose the text.
Lines are ordered vertically.  However, for a given y, there may be several lines in left to right order.  Lines must never be empty, even if text is empty.

Notes on yet another hack - 5 Feb 2001

We really need to clean up #composeLinesFrom:to:delta:into:priorLines:atY:!!!!!!

I added one more habdful of code to correct:

This is an annoying bug that's been around for a couple of years, but I finally figured out how to duplicate the problem, so I figured I'd just report it now.  (It doesn't necessarily have to be fixed for 3.0 if it looks messy, but if it's a simple fix, it would be worth it.)

In Morphic, if you have the following text in a workspace:

This is line 1
This is line 2

**and** you have a return character after line 2, you will normally be able to click the mouse two times below line 2 in order to select all the text.  If you edit line 2 (e.g. so that it reads "line number 2"), you can still select all the text by clicking below the second line.  However, if you edit line 1, you will not be able to select all the text from the bottom in the same way.  Things get messed up such that the last return character seems to be gone.  In this state, if you position the cursor immediately after the 2, and press the right arrow, the cursor jumps to the beginning of line 2... oof. (report by Doug Way)

While I don't have a very deep understanding of the above mentioned method, I was able to determine that text ending in a CR worked better in the editor when the last entry in <lines> had a start of text size + 1 and a stop of text size. I have accordingly added code near the end to ensure this. It seems to have fixed the problem, but we do need to clean this baby up some day. - Bob
!
]style[(830 38 127 1000 388)f1,f2cblue;,f1,f1cred;,f1!


!NewParagraph methodsFor: 'access' stamp: 'di 11/16/97 09:02'!
adjustedFirstCharacterIndex
	"Return the index in the text where this paragraph WOULD begin if nothing had changed, except the size of the text -- ie if there have only been an insertion of deletion in the preceding morphs"
	offsetToEnd ifNil: [^ -1].
	^ text size - offsetToEnd! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/24/97 17:38'!
extent
	^ container width @ (lines last bottom - lines first top)! !

!NewParagraph methodsFor: 'access' stamp: 'di 11/8/97 15:41'!
firstCharacterIndex
	^ firstCharacterIndex! !

!NewParagraph methodsFor: 'access' stamp: 'rr 3/22/2004 12:42'!
focused
	focused ifNil: [focused := false].
	^ focused! !

!NewParagraph methodsFor: 'access' stamp: 'rr 3/22/2004 12:41'!
focused: aBoolean
	focused := aBoolean! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/23/97 21:01'!
lastCharacterIndex
	^ lines last last! !

!NewParagraph methodsFor: 'access' stamp: 'sbw 10/13/1999 22:31'!
numberOfLines

	^lines size! !

!NewParagraph methodsFor: 'access' stamp: 'sw 1/13/98 21:31'!
string
	^ text string! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'!
text
	^ text! !

!NewParagraph methodsFor: 'access' stamp: 'jm 11/19/97 20:27'!
textOwner: ignored  "See TextOnCurve"! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'!
textStyle
	^ textStyle! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/23/97 19:33'!
textStyle: aTextStyle 
	"Set the style by which the receiver should display its text."
	textStyle _ aTextStyle! !

!NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:04'!
wantsColumnBreaks

	^wantsColumnBreaks! !

!NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:03'!
wantsColumnBreaks: aBoolean

	wantsColumnBreaks _ aBoolean! !


!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'!
centered 
	textStyle centered! !

!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'!
justified 
	textStyle justified! !

!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'!
leftFlush 
	textStyle leftFlush! !

!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'!
rightFlush 
	textStyle rightFlush! !


!NewParagraph methodsFor: 'composition' stamp: 'jm 2/25/2003 16:20'!
OLDcomposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY 
	"While the section from start to stop has changed, composition may ripple all the way to the end of the text.  However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values"

	| charIndex lineY lineHeight scanner line row firstLine lineHeightGuess saveCharIndex hitCR maybeSlide sliding bottom priorIndex priorLine |
	charIndex := start.
	lines := lineColl.
	lineY := startingY.
	lineHeightGuess := textStyle lineGrid.
	maxRightX := container left.
	maybeSlide := stop < text size and: [container isMemberOf: Rectangle].
	sliding := false.
	priorIndex := 1.
	bottom := container bottom.
	scanner := CompositionScanner new text: text textStyle: textStyle.
	firstLine := true.
	[charIndex <= text size and: [lineY + lineHeightGuess <= bottom]] 
		whileTrue: 
			[sliding 
				ifTrue: 
					["Having detected the end of rippling recoposition, we are only sliding old lines"

					priorIndex < priorLines size 
						ifTrue: 
							["Adjust and re-use previously composed line"

							priorIndex := priorIndex + 1.
							priorLine := (priorLines at: priorIndex) slideIndexBy: delta
										andMoveTopTo: lineY.
							lineColl addLast: priorLine.
							lineY := priorLine bottom.
							charIndex := priorLine last + 1]
						ifFalse: 
							["There are no more priorLines to slide."

							sliding := maybeSlide := false]]
				ifFalse: 
					[lineHeight := lineHeightGuess.
					saveCharIndex := charIndex.
					hitCR := false.
					row := container rectanglesAt: lineY height: lineHeight.
					1 to: row size
						do: 
							[:i | 
							(charIndex <= text size and: [hitCR not]) 
								ifTrue: 
									[line := scanner 
												composeFrom: charIndex
												inRectangle: (row at: i)
												firstLine: firstLine
												leftSide: i = 1
												rightSide: i = row size.
									lines addLast: line.
									(text at: line last) = Character cr ifTrue: [hitCR := true].
									lineHeight := lineHeight max: line lineHeight.	"includes font changes"
									charIndex := line last + 1]].

					lineY := lineY + lineHeight.
					row notEmpty 
						ifTrue: 
							[lineY > bottom 
								ifTrue: 
									["Oops -- the line is really too high to fit -- back out"

									charIndex := saveCharIndex.
									row do: [:r | lines removeLast]]
								ifFalse: 
									["It's OK -- the line still fits."

									maxRightX := maxRightX max: scanner rightX.
									1 to: row size - 1
										do: 
											[:i | 
											"Adjust heights across row if necess"

											(lines at: lines size - row size + i) lineHeight: lines last lineHeight
												baseline: lines last baseline].
									charIndex > text size 
										ifTrue: 
											["end of text"

											hitCR 
												ifTrue: 
													["If text ends with CR, add a null line at the end"

													lineY + lineHeightGuess <= container bottom 
														ifTrue: 
															[row := container rectanglesAt: lineY height: lineHeightGuess.
															row notEmpty 
																ifTrue: 
																	[line := (TextLine 
																				start: charIndex
																				stop: charIndex - 1
																				internalSpaces: 0
																				paddingWidth: 0)
																				rectangle: row first;
																				lineHeight: lineHeightGuess baseline: textStyle baseline.
																	lines addLast: line]]].
											lines := lines asArray.
											^maxRightX].
									firstLine := false]].
						
					(maybeSlide and: [charIndex > stop]) 
						ifTrue: 
							["Check whether we are now in sync with previously composed lines"

							
							[priorIndex < priorLines size 
								and: [(priorLines at: priorIndex) first < (charIndex - delta)]] 
									whileTrue: [priorIndex := priorIndex + 1].
							(priorLines at: priorIndex) first = (charIndex - delta) 
								ifTrue: 
									["Yes -- next line will have same start as prior line."

									priorIndex := priorIndex - 1.
									maybeSlide := false.
									sliding := true]
								ifFalse: 
									[priorIndex = priorLines size 
										ifTrue: 
											["Weve reached the end of priorLines,
								so no use to keep looking for lines to slide."

											maybeSlide := false]]]]].
	firstLine 
		ifTrue: 
			["No space in container or empty text"

			line := (TextLine 
						start: start
						stop: start - 1
						internalSpaces: 0
						paddingWidth: 0)
						rectangle: (container topLeft extent: 0 @ lineHeightGuess);
						lineHeight: lineHeightGuess baseline: textStyle baseline.
			lines := Array with: line]
		ifFalse: [self fixLastWithHeight: lineHeightGuess].
	"end of container"
	lines := lines asArray.
	^maxRightX! !

!NewParagraph methodsFor: 'composition' stamp: 'di 11/8/97 15:31'!
compose: t style: ts from: startingIndex in: textContainer
	text _ t.
	textStyle _ ts.
	firstCharacterIndex _ startingIndex.
	offsetToEnd _ text size - firstCharacterIndex.
	container _ textContainer.
	self composeAll! !

!NewParagraph methodsFor: 'composition' stamp: 'yo 12/20/2002 16:18'!
composeAll
	text string isOctetString ifTrue: [
		^ self composeLinesFrom: firstCharacterIndex to: text size delta: 0
			into: OrderedCollection new priorLines: Array new atY: container top.
	].

	^ self multiComposeLinesFrom: firstCharacterIndex to: text size delta: 0
		into: OrderedCollection new priorLines: Array new atY: container top.
! !

!NewParagraph methodsFor: 'composition' stamp: 'di 11/15/97 09:21'!
composeAllStartingAt: characterIndex
	firstCharacterIndex _ characterIndex.
	offsetToEnd _ text size - firstCharacterIndex.
	self composeAll! !

!NewParagraph methodsFor: 'composition' stamp: 'RAA 5/7/2001 10:58'!
composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines
	atY: startingY
	"While the section from start to stop has changed, composition may ripple all the way to the end of the text.  However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values"

	| newResult |

	newResult _ TextComposer new
		composeLinesFrom: start 
		to: stop 
		delta: delta 
		into: lineColl 
		priorLines: priorLines
		atY: startingY
		textStyle: textStyle 
		text: text 
		container: container
		wantsColumnBreaks: wantsColumnBreaks == true.
	lines _ newResult first asArray.
	maxRightX _ newResult second.
	^maxRightX
! !

!NewParagraph methodsFor: 'composition' stamp: 'di 10/22/97 11:13'!
compositionRectangle
	^ container! !

!NewParagraph methodsFor: 'composition' stamp: 'RAA 2/25/2001 15:02'!
fixLastWithHeight: lineHeightGuess
"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I coul;dn't figure out where to put it in the main logic."

	| oldLastLine newRectangle line |

	(text size > 1 and: [text last = Character cr]) ifFalse: [^self].

	oldLastLine _ lines last.
	oldLastLine last - oldLastLine first >= 0 ifFalse: [^self].
	oldLastLine last = text size ifFalse: [^self].

	newRectangle _ oldLastLine left @ oldLastLine bottom 
				extent: 0@(oldLastLine bottom - oldLastLine top).
	"Even though we may be below the bottom of the container,
	it is still necessary to compose the last line for consistency..."

	line _ TextLine start: text size+1 stop: text size internalSpaces: 0 paddingWidth: 0.
	line rectangle: newRectangle.
	line lineHeight: lineHeightGuess baseline: textStyle baseline.
	lines _ lines, (Array with: line).
! !

!NewParagraph methodsFor: 'composition' stamp: 'yo 1/3/2003 12:17'!
multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines
	atY: startingY
	"While the section from start to stop has changed, composition may ripple all the way to the end of the text.  However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values"

	| newResult |

	newResult _ MultiTextComposer new
		multiComposeLinesFrom: start 
		to: stop 
		delta: delta 
		into: lineColl 
		priorLines: priorLines
		atY: startingY
		textStyle: textStyle 
		text: text 
		container: container
		wantsColumnBreaks: wantsColumnBreaks == true.
	lines _ newResult first asArray.
	maxRightX _ newResult second.
	"maxRightX printString displayAt: 0@0."
	^maxRightX
! !

!NewParagraph methodsFor: 'composition' stamp: 'yo 12/20/2002 16:18'!
recomposeFrom: start to: stop delta: delta
	"Recompose this paragraph.  The altered portion is between start and stop.
	Recomposition may continue to the end of the text, due to a ripple effect.
	Delta is the amount by which the current text is longer than it was
	when its current lines were composed."
	| startLine newLines |
	"Have to recompose line above in case a word-break was affected."
	startLine _ (self lineIndexForCharacter: start) - 1 max: 1.
	[startLine > 1 and: [(lines at: startLine-1) top = (lines at: startLine) top]]
		whileTrue: [startLine _ startLine - 1].  "Find leftmost of line pieces"
	newLines _ OrderedCollection new: lines size + 1.
	1 to: startLine-1 do: [:i | newLines addLast: (lines at: i)].
	text string isOctetString ifTrue: [
		^ self composeLinesFrom: (lines at: startLine) first to: stop delta: delta
			into: newLines priorLines: lines
			atY: (lines at: startLine) top.
	].
	self multiComposeLinesFrom: (lines at: startLine) first to: stop delta: delta
		into: newLines priorLines: lines
		atY: (lines at: startLine) top.
! !

!NewParagraph methodsFor: 'composition' stamp: 'RAA 5/6/2001 15:09'!
testNewComposeAll
	| newResult |
	self 
		OLDcomposeLinesFrom: firstCharacterIndex 
		to: text size 
		delta: 0
		into: OrderedCollection new 
		priorLines: Array new 
		atY: container top.
	newResult _ TextComposer new
		composeLinesFrom: firstCharacterIndex 
		to: text size 
		delta: 0
		into: OrderedCollection new 
		priorLines: Array new 
		atY: container top
		textStyle: textStyle 
		text: text 
		container: container
		wantsColumnBreaks: false.
	newResult first with: lines do: [ :e1 :e2 |
		e1 longPrintString = e2 longPrintString ifFalse: [self halt].
	].
	newResult second = maxRightX ifFalse: [self halt].
	^{newResult. {lines. maxRightX}}
! !

!NewParagraph methodsFor: 'composition' stamp: 'yo 12/17/2002 14:48'!
testNewComposeAll2
	| newResult |
	newResult _ TextComposer new
		composeLinesFrom: firstCharacterIndex 
		to: text size 
		delta: 0
		into: OrderedCollection new 
		priorLines: Array new 
		atY: container top
		textStyle: textStyle 
		text: text 
		container: container
		wantsColumnBreaks: false.
	^{newResult. {lines. maxRightX}}
! !

!NewParagraph methodsFor: 'composition' stamp: 'yo 12/18/2002 15:00'!
testNewComposeAll3
	| newResult |
	newResult _ TextComposer new
		multiComposeLinesFrom: firstCharacterIndex 
		to: text size 
		delta: 0
		into: OrderedCollection new 
		priorLines: Array new 
		atY: container top
		textStyle: textStyle 
		text: text 
		container: (0@0 extent: 31@60)
		wantsColumnBreaks: false.
	^{newResult. {lines. maxRightX}}
! !


!NewParagraph methodsFor: 'copying' stamp: 'di 5/21/1998 21:45'!
deepCopy
	"Don't want to copy the container (etc) or fonts in the TextStyle."
	| new |
	new _ self copy.
	new textStyle: textStyle copy
		lines: lines copy
		text: text deepCopy.
	^ new! !


!NewParagraph methodsFor: 'display' stamp: 'di 8/13/2000 12:27'!
asParagraphForPostscript

	^ self! !

!NewParagraph methodsFor: 'display' stamp: 'lr 7/12/2006 09:27'!
caretWidth
	^ Preferences caretWidth! !

!NewParagraph methodsFor: 'display' stamp: 'nk 8/31/2004 11:10'!
displaySelectionInLine: line on: aCanvas 
	| leftX rightX w caretColor |
	selectionStart ifNil: [^self].	"No selection"
	aCanvas isShadowDrawing ifTrue: [ ^self ].	"don't draw selection with shadow"
	selectionStart = selectionStop 
		ifTrue: 
			["Only show caret on line where clicked"

			selectionStart textLine ~= line ifTrue: [^self]]
		ifFalse: 
			["Test entire selection before or after here"

			(selectionStop stringIndex < line first 
				or: [selectionStart stringIndex > (line last + 1)]) ifTrue: [^self].	"No selection on this line"
			(selectionStop stringIndex = line first 
				and: [selectionStop textLine ~= line]) ifTrue: [^self].	"Selection ends on line above"
			(selectionStart stringIndex = (line last + 1) 
				and: [selectionStop textLine ~= line]) ifTrue: [^self]].	"Selection begins on line below"
	leftX := (selectionStart stringIndex < line first 
				ifTrue: [line ]
				ifFalse: [selectionStart ])left.
	rightX := (selectionStop stringIndex > (line last + 1) or: 
					[selectionStop stringIndex = (line last + 1) 
						and: [selectionStop textLine ~= line]]) 
				ifTrue: [line right]
				ifFalse: [selectionStop left].
	selectionStart = selectionStop 
		ifTrue: 
			[rightX := rightX + 1.
			w := self caretWidth.
			caretColor := self insertionPointColor.
			1 to: w
				do: 
					[:i | 
					"Draw caret triangles at top and bottom"

					aCanvas fillRectangle: ((leftX - w + i - 1) @ (line top + i - 1) 
								extent: ((w - i) * 2 + 3) @ 1)
						color: caretColor.
					aCanvas fillRectangle: ((leftX - w + i - 1) @ (line bottom - i) 
								extent: ((w - i) * 2 + 3) @ 1)
						color: caretColor].
			aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom)
				color: caretColor]
		ifFalse: 
			[aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom)
				color: self selectionColor]! !

!NewParagraph methodsFor: 'display' stamp: 'rr 3/22/2004 19:56'!
insertionPointColor
	self focused ifFalse: [^ Color transparent].
	^ Display depth <= 2
		ifTrue: [Color black]
		ifFalse: [Preferences insertionPointColor]! !

!NewParagraph methodsFor: 'display' stamp: 'rr 3/23/2004 19:52'!
selectionColor
	| color |
	Display depth = 1 ifTrue: [^ Color veryLightGray].
	Display depth = 2 ifTrue: [^ Color gray].
	color := Preferences textHighlightColor.
	self focused ifFalse: [color := color alphaMixed: 0.2 with: Color veryVeryLightGray].
	^ color! !


!NewParagraph methodsFor: 'editing' stamp: 'mk 5/28/2005 11:15'!
clickAt: clickPoint for: model controller: editor
	"Give sensitive text a chance to fire.  Display flash: (100@100 extent: 100@100)."
	| startBlock action target range boxes box |
	action _ false.
	startBlock _ self characterBlockAtPoint: clickPoint.
	(text attributesAt: startBlock stringIndex forStyle: textStyle) 
		do: [:att | att mayActOnClick ifTrue:
				[(target _ model) ifNil: [target _ editor morph].
				range _ text rangeOf: att startingAt: startBlock stringIndex.
				boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) 
							to: (self characterBlockForIndex: range last+1).
				box _ boxes detect: [:each | each containsPoint: clickPoint] ifNone: [nil].
				box ifNotNil:
					[ box _ (editor transformFrom: nil) invertBoundsRect: box.
					editor morph allOwnersDo: [ :m | box _ box intersect: (m boundsInWorld) ].
					Utilities awaitMouseUpIn: box
						repeating: []
						ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action _ true]].
					Cursor currentCursor == Cursor webLink ifTrue:[Cursor normal show].
				]]].
	^ action! !

!NewParagraph methodsFor: 'editing' stamp: 'di 4/28/1999 10:14'!
replaceFrom: start to: stop with: aText displaying: displayBoolean 
	"Edit the text, and then recompose the lines." 
	text replaceFrom: start to: stop with: aText.
	self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop-start+1)! !


!NewParagraph methodsFor: 'fonts-display' stamp: 'nk 3/20/2004 11:13'!
displayOn: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"
	| visibleRectangle offset leftInRun line |
	visibleRectangle _ aCanvas clipRect.
	offset _ (somePosition - positionWhenComposed) truncated.
	leftInRun _ 0.
	(self lineIndexForPoint: visibleRectangle topLeft)
		to: (self lineIndexForPoint: visibleRectangle bottomRight)
		do: [:i | line _ lines at: i.
			self displaySelectionInLine: line on: aCanvas.
			line first <= line last ifTrue:
				[leftInRun _ displayScanner displayLine: line
								offset: offset leftInRun: leftInRun]].
! !


!NewParagraph methodsFor: 'initialize-release' stamp: 'tak 12/21/2004 13:29'!
initialize
	self positionWhenComposed: 0 @ 0! !


!NewParagraph methodsFor: 'selection' stamp: 'ar 4/12/2005 19:53'!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for the character in the text at aPoint."
	| line |
	line _ lines at: (self lineIndexForPoint: aPoint).
	^ ((text string isWideString) ifTrue: [
		MultiCharacterBlockScanner new text: text textStyle: textStyle
	] ifFalse: [CharacterBlockScanner new text: text textStyle: textStyle])
		characterBlockAtPoint: aPoint index: nil
		in: line! !

!NewParagraph methodsFor: 'selection' stamp: 'ar 4/12/2005 19:53'!
characterBlockForIndex: index 
	"Answer a CharacterBlock for the character in text at index."
	| line |
	line _ lines at: (self lineIndexForCharacter: index).
	^ ((text string isWideString) ifTrue: [
		MultiCharacterBlockScanner new text: text textStyle: textStyle
	] ifFalse: [
		CharacterBlockScanner new text: text textStyle: textStyle
	])
		characterBlockAtPoint: nil index: ((index max: line first) min: text size+1)
		in: line! !

!NewParagraph methodsFor: 'selection' stamp: 'jm 11/19/97 22:56'!
containsPoint: aPoint
	^ (lines at: (self lineIndexForPoint: aPoint)) rectangle
		containsPoint: aPoint! !

!NewParagraph methodsFor: 'selection' stamp: 'di 10/5/1998 12:59'!
defaultCharacterBlock
	^ (CharacterBlock new stringIndex: firstCharacterIndex text: text
			topLeft: lines first topLeft extent: 0 @ 0)
		textLine: lines first! !

!NewParagraph methodsFor: 'selection' stamp: 'di 11/30/97 12:10'!
selectionRects
	"Return an array of rectangles representing the selection region."
	selectionStart ifNil: [^ Array new].
	^ self selectionRectsFrom: selectionStart to: selectionStop! !

!NewParagraph methodsFor: 'selection' stamp: 'ls 11/2/2001 23:10'!
selectionRectsFrom: characterBlock1 to: characterBlock2 
	"Return an array of rectangles representing the area between the two character blocks given as arguments."
	| line1 line2 rects cb1 cb2 w |
	characterBlock1 <= characterBlock2
		ifTrue: [cb1 _ characterBlock1.  cb2 _ characterBlock2]
		ifFalse: [cb2 _ characterBlock1.  cb1 _ characterBlock2].
	cb1 = cb2 ifTrue:
		[w _ self caretWidth.
		^ Array with: (cb1 topLeft - (w@0) corner: cb1 bottomLeft + ((w+1)@0))].
	line1 _ self lineIndexForCharacter: cb1 stringIndex.
	line2 _ self lineIndexForCharacter: cb2 stringIndex.
	line1 = line2 ifTrue:
		[^ Array with: (cb1 topLeft corner: cb2 bottomRight)].
	rects _ OrderedCollection new.
	rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight).
	line1+1 to: line2-1 do: [ :i |
		| line |
		line := lines at: i.
		(line left = rects last left and: [ line right = rects last right ])
			ifTrue: [ "new line has same margins as old one -- merge them, so that the caller gets as few rectangles as possible"
					| lastRect |
					lastRect := rects removeLast.
					rects add: (lastRect bottom: line bottom) ]
			ifFalse: [ "differing margins; cannot merge"
					rects add: line rectangle ] ].

	rects addLast: ((lines at: line2) topLeft corner: cb2 bottomLeft).
	^ rects! !

!NewParagraph methodsFor: 'selection' stamp: 'di 12/2/97 19:57'!
selectionStart: startBlock selectionStop: stopBlock
	selectionStart _ startBlock.
	selectionStop _ stopBlock.! !


!NewParagraph methodsFor: 'private' stamp: 'di 11/8/97 15:47'!
adjustLineIndicesBy: delta
	firstCharacterIndex _ firstCharacterIndex + delta.
	lines do: [:line | line slide: delta].
! !

!NewParagraph methodsFor: 'private' stamp: 'di 10/26/97 15:57'!
adjustRightX
	| shrink |
	shrink _ container right - maxRightX.
	lines do: [:line | line paddingWidth: (line paddingWidth - shrink)].
	container _ container withRight: maxRightX! !

!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:17'!
fastFindFirstLineSuchThat: lineBlock
	"Perform a binary search of the lines array and return the index
	of the first element for which lineBlock evaluates as true.
	This assumes the condition is one that goes from false to true for
	increasing line numbers (as, eg, yval > somey or start char > somex).
	If lineBlock is not true for any element, return size+1."
	| index low high |
	low _ 1.
	high _ lines size.
	[index _ high + low // 2.
	low > high]
		whileFalse: 
			[(lineBlock value: (lines at: index))
				ifTrue: [high _ index - 1]
				ifFalse: [low _ index + 1]].
	^ low! !

!NewParagraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:30'!
indentationOfLineIndex: lineIndex ifBlank: aBlock
	"Answer the number of leading tabs in the line at lineIndex.  If there are
	 no visible characters, pass the number of tabs to aBlock and return its value.
	 If the line is word-wrap overflow, back up a line and recur."

	| arrayIndex first last cr |
	cr _ Character cr.
	arrayIndex _ lineIndex.
	[first _ (lines at: arrayIndex) first.
	 first > 1 and: [(text string at: first - 1) ~~ cr]] whileTrue: "word wrap"
		[arrayIndex _ arrayIndex - 1].
	last _ (lines at: arrayIndex) last.
	
	^(text string copyFrom: first to: last) indentationIfBlank: aBlock.
! !

!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:11'!
lineIndexForCharacter: index
	"Answer the index of the line in which to select the character at index."
	^ (self fastFindFirstLineSuchThat: [:line | line first > index]) - 1 max: 1! !

!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:13'!
lineIndexForPoint: aPoint
	"Answer the index of the line in which to select the character nearest to aPoint."
	| i py |
	py _ aPoint y truncated.

	"Find the first line at this y-value"
	i _ (self fastFindFirstLineSuchThat: [:line | line bottom > py]) min: lines size.

	"Now find the first line at this x-value"
	[i < lines size and: [(lines at: i+1) top = (lines at: i) top
				and: [aPoint x >= (lines at: i+1) left]]]
		whileTrue: [i _ i + 1].
	^ i! !

!NewParagraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:04'!
lineIndexOfCharacterIndex: characterIndex 
	"Answer the line index for a given characterIndex."
	"apparently the selector changed with NewParagraph"

	^self lineIndexForCharacter: characterIndex 
! !

!NewParagraph methodsFor: 'private' stamp: 'di 10/24/97 17:40'!
lines
	^ lines! !

!NewParagraph methodsFor: 'private' stamp: 'edc 6/18/2004 09:10'!
moveBy: delta
	lines do: [:line | line moveBy: delta].
	positionWhenComposed ifNotNil:[
	positionWhenComposed _ positionWhenComposed + delta].
	container _ container translateBy: delta! !

!NewParagraph methodsFor: 'private' stamp: 'di 10/21/97 21:36'!
positionWhenComposed: pos
	positionWhenComposed _ pos! !

!NewParagraph methodsFor: 'private' stamp: 'di 5/21/1998 21:47'!
textStyle: ts lines: l text: t
	"Private -- just a service for deepCopy"
	textStyle _ ts.
	lines _ l.
	text _ t.! !
SystemWindow subclass: #NewWorldWindow
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWorlds'!

!NewWorldWindow methodsFor: 'color' stamp: 'nb 6/17/2003 12:25'!
setWindowColor: incomingColor
	| existingColor aColor |

	incomingColor ifNil: [^ self].  "it happens"
	aColor _ incomingColor asNontranslucentColor.
	(aColor = ColorPickerMorph perniciousBorderColor 
		or: [aColor = Color black]) ifTrue: [^ self].
	existingColor _ self paneColorToUse.
	existingColor ifNil: [^ Beeper beep].
	self setStripeColorsFrom: aColor
		
! !


!NewWorldWindow methodsFor: 'initialization' stamp: 'ar 5/11/2001 23:48'!
openInWorld: aWorld
	| xxx |
	"This msg and its callees result in the window being activeOnlyOnTop"

	xxx _ RealEstateAgent initialFrameFor: self world: aWorld.

	"Bob say: 'opening in ',xxx printString,' out of ',aWorld bounds printString.
	6 timesRepeat: [Display flash: xxx andWait: 300]."

	self bounds: xxx.
	^self openAsIsIn: aWorld.! !


!NewWorldWindow methodsFor: 'label' stamp: 'sw 5/19/2001 10:44'!
setStripeColorsFrom: paneColor
	"Since our world may be *any* color, try to avoid really dark colors so title will show"

	| revisedColor |
	stripes ifNil: [^ self].
	revisedColor _ paneColor atLeastAsLuminentAs: 0.1 .
	self isActive ifTrue:
		[stripes second 
			color: revisedColor; 
			borderColor: stripes second color darker.
		stripes first 
			color: stripes second borderColor darker;
			borderColor: stripes first color darker.
		^ self].
	"This could be much faster"
	stripes second 
		color: revisedColor; 
		borderColor: revisedColor.
	stripes first 
		color: revisedColor; 
		borderColor: revisedColor! !


!NewWorldWindow methodsFor: 'panes' stamp: 'ar 11/9/2000 01:31'!
addMorph: aMorph frame: relFrame
	| cc |
	cc _ aMorph color.
	super addMorph: aMorph frame: relFrame.
	aMorph color: cc.! !

!NewWorldWindow methodsFor: 'panes' stamp: 'RAA 6/1/2000 18:21'!
updatePaneColors
	"Useful when changing from monochrome to color display"

	self setStripeColorsFrom: self paneColorToUse.

	"paneMorphs do: [:p | p color: self paneColorToUse]."	"since pane is a world, skip this"
! !


!NewWorldWindow methodsFor: 'stepping' stamp: 'RAA 6/1/2000 18:30'!
amendSteppingStatus! !


!NewWorldWindow methodsFor: 'testing' stamp: 'RAA 6/1/2000 18:33'!
wantsSteps
	
	^true! !
Controller subclass: #NoController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Framework'!
!NoController commentStamp: '<historical>' prior: 0!
I represent a controller that never wants control. I am the controller for views that are non-interactive.!


!NoController methodsFor: 'basic control sequence'!
startUp
	"I do nothing."

	^self! !


!NoController methodsFor: 'control defaults'!
isControlActive 
	"Refer to the comment in Controller|isControlActive."

	^false! !

!NoController methodsFor: 'control defaults'!
isControlWanted 
	"Refer to the comment in Controller|isControlWanted."

	^false! !
ClipboardInterpreter subclass: #NoConversionClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!NoConversionClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 19:03'!
fromSystemClipboard: aString

	^ aString.
! !

!NoConversionClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 21:06'!
toSystemClipboard: aString

	| result |
	aString isOctetString ifTrue: [^ aString asOctetString].

	result _ WriteStream on: (String new: aString size).
	aString do: [:each | each value < 256 ifTrue: [result nextPut: each]].
	^ result contents.
! !
KeyboardInputInterpreter subclass: #NoInputInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!NoInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 14:59'!
nextCharFrom: sensor firstEvt: evtBuf



	| keyValue |

	keyValue := evtBuf third.

	^ keyValue asCharacter.

! !
NetworkError subclass: #NoNetworkError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!NoNetworkError commentStamp: 'mir 5/12/2003 18:17' prior: 0!
Signals that no network was found. This could happen, e.g., on dial-up connection when no connection was established when Squeak tried to access it.

!

Error subclass: #NonBooleanReceiver
	instanceVariableNames: 'object'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'!
object
	^object! !

!NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'!
object: anObject
	object _ anObject! !


!NonBooleanReceiver methodsFor: 'signaledException' stamp: 'hmm 7/29/2001 21:37'!
isResumable

	^true! !
AbstractScoreEvent subclass: #NoteEvent
	instanceVariableNames: 'duration midiKey velocity channel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!NoteEvent commentStamp: '<historical>' prior: 0!
Represents a note on or off event in a MIDI score.
!


!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 22:02'!
channel

	^ channel
! !

!NoteEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
channel: midiChannel

	channel := midiChannel.
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/18/97 19:10'!
duration

	^ duration
! !

!NoteEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration: aNumber

	duration := aNumber.
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 8/27/1998 16:38'!
endTime

	^ time + duration
! !

!NoteEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
key: midiKeyNum velocity: midiVelocity channel: midiChannel

	midiKey := midiKeyNum.
	velocity := midiVelocity.
	channel := midiChannel.
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/18/97 20:58'!
midiKey

	^ midiKey
! !

!NoteEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
midiKey: midiKeyNum

	midiKey := midiKeyNum.
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 8/3/1998 17:06'!
pitch
	"Convert my MIDI key number to a pitch and return it."

	^ AbstractSound pitchForMIDIKey: midiKey
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 09:32'!
velocity

	^ velocity
! !

!NoteEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
velocity: midiVelocity

	velocity := midiVelocity.
! !


!NoteEvent methodsFor: 'classification' stamp: 'jm 12/31/97 11:48'!
isNoteEvent

	^ true
! !


!NoteEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 15:58'!
endNoteOnMidiPort: aMidiPort
	"Output a noteOff event to the given MIDI port. (Actually, output a noteOff event with zero velocity. This does the same thing, but allows running status to be used when sending a mixture of note on and off commands.)"

	aMidiPort
		midiCmd: 16r90
		channel: channel
		byte: midiKey
		byte: 0.
! !

!NoteEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 15:56'!
startNoteOnMidiPort: aMidiPort
	"Output a noteOn event to the given MIDI port."

	aMidiPort
		midiCmd: 16r90
		channel: channel
		byte: midiKey
		byte: velocity.
! !


!NoteEvent methodsFor: 'printing' stamp: 'stephaneducasse 2/4/2006 20:41'!
keyName
	"Return a note name for my pitch."

	| pitchName octave |
	pitchName := #(c cs d ef e f fs g af a bf b) at: (midiKey \\ 12) + 1.
	octave := (#(-1 0 1 2 3 4 5 6 7 8 9) at: (midiKey // 12) + 1) printString.
	^ pitchName, octave
! !

!NoteEvent methodsFor: 'printing' stamp: 'jm 1/3/98 08:59'!
printOn: aStream

	aStream nextPut: $(.
	time printOn: aStream.
	aStream nextPutAll: ': '.
	aStream nextPutAll: self keyName.
	aStream space.
	duration printOn: aStream.
	aStream nextPut: $).
! !
Exception subclass: #Notification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!Notification commentStamp: '<historical>' prior: 0!
A Notification is an indication that something interesting has occurred.  If it is not handled, it will pass by without effect.!


!Notification methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 15:04'!
defaultAction
	"No action is taken. The value nil is returned as the value of the message that signaled the exception."

	^nil! !

!Notification methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 18:17'!
isResumable
	"Answer true. Notification exceptions by default are specified to be resumable."

	^true! !
PluggableCanvas subclass: #NullCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!NullCanvas commentStamp: '<historical>' prior: 0!
A canvas which ignores all drawing commands.!


!NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:11'!
clipRect
	^1@1 extent: 99@99! !

!NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:11'!
extent
	^100@100! !

!NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:12'!
form
	^Form extent: self extent! !

!NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:13'!
origin
	^0@0! !


!NullCanvas methodsFor: 'copying' stamp: 'ls 3/20/2000 21:26'!
copyClipRect: clipRect
	"who cares what the clipping rectangle is?"
	^self! !


!NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:41'!
clipBy: region during: aBlock
	"do this in order that timing runs work better"
	aBlock value: self! !

!NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:39'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	"do this in order that timing runs work better"
	aBlock value: self! !

!NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:40'!
translateBy: delta during: aBlock
	"do this in order that timing runs work better"
	aBlock value: self! !
Object subclass: #NullEncoder
	instanceVariableNames: 'target filterSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!NullEncoder methodsFor: 'accessing' stamp: 'RAA 9/17/2000 11:53'!
close

	^target close.
! !

!NullEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 00:56'!
contents
	^target contents.
! !

!NullEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 00:16'!
target
	^target.! !


!NullEncoder methodsFor: 'initialization' stamp: 'MPW 1/1/1901 00:04'!
initWithTarget:aTarget
	target _ aTarget.
	filterSelector _ self class filterSelector.
	^self.
! !


!NullEncoder methodsFor: 'processing' stamp: 'MPW 1/1/1901 01:19'!
process:anObject
	self write:anObject.
	^self contents.! !


!NullEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:17'!
forward:anObject
	anObject ~= nil ifTrue:[target write:anObject].
! !

!NullEncoder methodsFor: 'writing' stamp: 'mpw 8/13/1999 10:54'!
write:anObject
	filterSelector  ifNil:[filterSelector_self class filterSelector].
	anObject ifNotNil: [anObject perform:filterSelector with:self].
! !

!NullEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:16'!
writeObject:anObject
	^self forward:anObject.
! !

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

NullEncoder class
	instanceVariableNames: ''!

!NullEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:02'!
defaultTarget
	^OrderedCollection new.
! !

!NullEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:02'!
filterSelector
	^#writeOnFilterStream:
! !


!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 00:55'!
stream
	^self streamOn:self defaultTarget. 
! !

!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 00:05'!
stream:newTarget
	^self new initWithTarget:newTarget.
! !

!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 01:15'!
streamOn:newTargetCollection
	^self new initWithTarget:newTargetCollection.
! !

!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 02:20'!
streamOnFile:fileName
	^self new initWithTarget:(FileStream newFileNamed: fileName).
! !


!NullEncoder class methodsFor: 'processing' stamp: 'MPW 1/1/1901 01:20'!
process:anObject
	^self stream process:anObject.

! !
NetworkTerminalMorph subclass: #NullTerminalMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!

!NullTerminalMorph methodsFor: 'drawing' stamp: 'RAA 7/22/2000 07:20'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds fillStyle: Color orange.
	aCanvas frameRectangle: self bounds color: Color black! !

!NullTerminalMorph methodsFor: 'drawing' stamp: 'RAA 7/22/2000 07:22'!
forceToFront: aRegion
	"force the given region from the drawing form onto the background form"
	self updateBackgroundForm.

! !


!NullTerminalMorph methodsFor: 'geometry' stamp: 'sd 11/20/2005 21:26'!
extent: newExtent

	| aPoint |
	aPoint := 50@50.
	bounds extent = aPoint ifFalse: [
		self changed.
		bounds := bounds topLeft extent: aPoint.
		self layoutChanged.
		self changed
	].
	eventEncoder sendViewExtent: newExtent! !
Magnitude subclass: #Number
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Number commentStamp: '<historical>' prior: 0!
Class Number holds the most general methods for dealing with numbers. Subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity.

All of Number's subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons.  It works as follows:  If
	self<typeA> op: arg<typeB>
fails because of incompatible types, then it is retried in the following guise:
	(arg adaptTypeA: self) op: arg adaptToTypeA.
This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved.  If self is more general, then arg will be converted, and viceVersa.  This mechanism is extensible to any new number classes that one might wish to add to Squeak.  The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number.!


!Number methodsFor: 'arithmetic'!
* aNumber 
	"Answer the result of multiplying the receiver by aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'arithmetic'!
+ aNumber 
	"Answer the sum of the receiver and aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'arithmetic'!
- aNumber 
	"Answer the difference between the receiver and aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'arithmetic'!
/ aNumber 
	"Answer the result of dividing the receiver by aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'arithmetic'!
// aNumber 
	"Integer quotient defined by division with truncation toward negative 
	infinity. 9//4 = 2, -9//4 = -3. -0.9//0.4 = -3. \\ answers the remainder 
	from this division."

	^(self / aNumber) floor! !

!Number methodsFor: 'arithmetic'!
\\ aNumber 
	"modulo. Remainder defined in terms of //. Answer a Number with the 
	same sign as aNumber. e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, 0.9\\0.4 = 0.1."

	^self - (self // aNumber * aNumber)! !

!Number methodsFor: 'arithmetic'!
abs
	"Answer a Number that is the absolute value (positive magnitude) of the 
	receiver."

	self < 0
		ifTrue: [^self negated]
		ifFalse: [^self]! !

!Number methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 21:00'!
arg
	"Answer the argument of the receiver (see Complex | arg)."
	
	self isZero ifTrue: [self error: 'Zero (0 + 0 i) does not have an argument.'].
	0 < self
		ifTrue: [^ 0]
		ifFalse: [^ Float pi]! !

!Number methodsFor: 'arithmetic'!
negated
	"Answer a Number that is the negation of the receiver."

	^0 - self! !

!Number methodsFor: 'arithmetic'!
quo: aNumber 
	"Integer quotient defined by division with truncation toward zero. -9 quo: 
	4 = -2, -0.9 quo: 0.4 = -2. rem: answers the remainder from this division."

	^(self / aNumber) truncated! !

!Number methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'!
reciprocal
	"Answer 1 divided by the receiver. Create an error notification if the 
	receiver is 0."
	#Numeric.
	"Changed 200/01/19 For ANSI <number> support."
	self = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"].
	^ 1 / self! !

!Number methodsFor: 'arithmetic'!
rem: aNumber 
	"Remainder defined in terms of quo:. Answer a Number with the same 
	sign as self. e.g. 9 rem: 4 = 1, -9 rem: 4 = -1. 0.9 rem: 0.4 = 0.1."

	^self - ((self quo: aNumber) * aNumber)! !


!Number methodsFor: 'comparing' stamp: 'tk 4/16/1999 18:26'!
closeTo: num
	"are these two numbers close?"

	| ans |
	num isFloat ifTrue: [^ num closeTo: self asFloat].
	[ans _ self = num] ifError: [:aString :aReceiver | ^ false].
	^ ans! !


!Number methodsFor: 'converting' stamp: 'avi 9/6/2005 22:07'!
printShowingDecimalPlaces: placesDesired
	"Print the receiver showing precisely the given number of places desired .  If the placesDesired provided is positive, a decimal point and that many digits after the decimal point will always be shown.  If the placesDesired is zero, a whole number will be shown, without a decimal point.  This method could probably be greatly optimized -- improvements welcomed."

	| precision rounded integerString fractionString |
	placesDesired <= 0 ifTrue: [^ self rounded printString].
	precision _ Utilities floatPrecisionForDecimalPlaces: placesDesired.
	rounded _ self roundTo: precision.
	integerString _ rounded integerPart asInteger asString.
	fractionString _ (rounded fractionPart abs / precision) asInteger asString.
	^ String streamContents:
		[:s |
		s nextPutAll: integerString.
		s nextPut: $..
		(placesDesired - fractionString size) timesRepeat: [s nextPut: $0].
		s nextPutAll: fractionString]
"
23 printShowingDecimalPlaces: 2
23.5698 printShowingDecimalPlaces: 2
-234.567 printShowingDecimalPlaces: 5
23.4567 printShowingDecimalPlaces: 0
100000000 printShowingDecimalPlaces: 1
"! !

!Number methodsFor: 'converting'!
@ y 
	"Primitive. Answer a Point whose x value is the receiver and whose y 
	value is the argument. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 18>
	^Point x: self y: y! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:43'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with a Collection, return a Collection of
	the results of each element combined with me in that expression."

	^ rcvr collect: [:element | element perform: selector with: self]! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:21'!
adaptToFloat: rcvr andSend: selector 
	"If I am involved in arithmetic with a Float, convert me to a Float."
	^ rcvr perform: selector with: self asFloat! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert us and evaluate exprBlock."
	^ self subclassResponsibility! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with a Integer, convert us and evaluate exprBlock."
	^ self subclassResponsibility! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'!
adaptToPoint: rcvr andSend: selector
	"If I am involved in arithmetic with a Point, convert me to a Point."
	^ rcvr perform: selector with: self@self! !

!Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector 
	"Do any required conversion and then the arithmetic. 
	receiverScaledDecimal arithmeticOpSelector self."
	#Numeric.
	"add 200/01/19 For ScaledDecimal support."
	^ self subclassResponsibility! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:45'!
adaptToString: rcvr andSend: selector
	"If I am involved in arithmetic with a String, convert it to a Number."
	^ rcvr asNumber perform: selector with: self! !

!Number methodsFor: 'converting' stamp: 'ar 5/20/2001 01:40'!
asB3DVector3
	^self@self@self! !

!Number methodsFor: 'converting' stamp: 'brp 5/13/2003 10:13'!
asDuration

	^ Duration nanoSeconds: self asInteger
! !

!Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asFloatD
	"Answer a d precision floating-point number approximating the receiver."
	#Numeric.
	"add 200/01/19 For ANSI <number> protocol."
	^ self asFloat! !

!Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asFloatE
	"Answer a floating-point number approximating the receiver."
	#Numeric.
	"add 200/01/19 For ANSI <number> protocol."
	^ self asFloat! !

!Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asFloatQ
	"Answer a floating-point number approximating the receiver."
	#Numeric.
	"add 200/01/19 For ANSI <number> protocol."
	^ self asFloat! !

!Number methodsFor: 'converting'!
asInteger
	"Answer an Integer nearest the receiver toward zero."

	^self truncated! !

!Number methodsFor: 'converting' stamp: 'sw 2/16/1999 18:15'!
asNumber
	^ self! !

!Number methodsFor: 'converting'!
asPoint
	"Answer a Point with the receiver as both coordinates; often used to 
	supply the same value in two dimensions, as with symmetrical gridding 
	or scaling."

	^self @ self! !

!Number methodsFor: 'converting' stamp: 'dtl 9/25/2004 11:47'!
asScaledDecimal
	"Answer a scaled decimal number approximating the receiver."
	#Numeric.

	^ self asScaledDecimal: 8
! !

!Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asScaledDecimal: scale 
	"Answer a scaled decimal number, with a fractional precision of scale, 
	approximating the receiver."
	#Numeric.
	"add 200/01/19 For number protocol."
	^ ScaledDecimal newFromNumber: self scale: scale! !

!Number methodsFor: 'converting' stamp: 'sw 9/8/97 16:30'!
asSmallAngleDegrees
	"Return the receiver normalized to lie within the range (-180, 180)"

	| pos |
	pos _ self \\ 360.
	pos > 180 ifTrue: [pos _ pos - 360].
	^ pos

"#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallAngleDegrees]"! !

!Number methodsFor: 'converting' stamp: 'sw 10/7/1999 12:24'!
asSmallPositiveDegrees
	"Return the receiver normalized to lie within the range (0, 360)"

	| result |
	result _ self.
	[result < 0] whileTrue: [result _ result + 360].
	^ result \\ 360

"#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallPositiveDegrees]"! !

!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:12'!
day

	^ self sign days! !

!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'!
days

	^ Duration days: self! !

!Number methodsFor: 'converting'!
degreesToRadians
	"The receiver is assumed to represent degrees. Answer the conversion to 
	radians."

	^self asFloat degreesToRadians! !

!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:28'!
hour

	^ self sign hours
! !

!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'!
hours

	^ Duration hours: self! !

!Number methodsFor: 'converting' stamp: 'mk 10/27/2003 18:17'!
i
	^ Complex real: 0 imaginary: self! !

!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:26'!
milliSecond

	^ self sign milliSeconds
! !

!Number methodsFor: 'converting' stamp: 'brp 9/25/2003 13:16'!
milliSeconds

	^ Duration milliSeconds: self
! !

!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:16'!
minute

	^ self sign minutes
! !

!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'!
minutes

	^ Duration minutes: self! !

!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:27'!
nanoSecond

	^ self sign nanoSeconds
! !

!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 08:52'!
nanoSeconds

	^ Duration nanoSeconds: self.! !

!Number methodsFor: 'converting'!
radiansToDegrees
	"The receiver is assumed to represent radians. Answer the conversion to 
	degrees."

	^self asFloat radiansToDegrees! !

!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:17'!
second

	^ self sign seconds
! !

!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:57'!
seconds

	^ Duration seconds: self! !

!Number methodsFor: 'converting' stamp: 'brp 5/21/2003 08:20'!
sign: aNumber
	"Return a Number with the same sign as aNumber"

	^ aNumber positive ifTrue: [self abs] ifFalse: [self abs negated].! !

!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:19'!
week

	^ self sign weeks
! !

!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:57'!
weeks

	^ Duration weeks: self! !


!Number methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:07'!
byteEncode:aStream
	^aStream writeNumber:self.
! !


!Number methodsFor: 'intervals'!
to: stop
	"Answer an Interval from the receiver up to the argument, stop, 
	incrementing by 1."

	^Interval from: self to: stop by: 1! !

!Number methodsFor: 'intervals'!
to: stop by: step
	"Answer an Interval from the receiver up to the argument, stop, 
	incrementing by step."

	^Interval from: self to: stop by: step! !

!Number methodsFor: 'intervals' stamp: 'tao 1/30/1999 08:58'!
to: stop by: step do: aBlock 
	"Normally compiled in-line, and therefore not overridable.
	Evaluate aBlock for each element of the interval (self to: stop by: 
step)."
	| nextValue |
	nextValue _ self.
	step = 0 ifTrue: [self error: 'step must be non-zero'].
	step < 0
		ifTrue: [[stop <= nextValue]
				whileTrue: 
					[aBlock value: nextValue.
					nextValue _ nextValue + step]]
		ifFalse: [[stop >= nextValue]
				whileTrue: 
					[aBlock value: nextValue.
					nextValue _ nextValue + step]]! !

!Number methodsFor: 'intervals'!
to: stop do: aBlock 
	"Normally compiled in-line, and therefore not overridable.
	Evaluate aBlock for each element of the interval (self to: stop by: 1)."
	| nextValue |
	nextValue _ self.
	[nextValue <= stop]
		whileTrue: 
			[aBlock value: nextValue.
			nextValue _ nextValue + 1]! !


!Number methodsFor: 'mathematical functions'!
arcCos 
	"The receiver is the cosine of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcCos! !

!Number methodsFor: 'mathematical functions'!
arcSin
	"The receiver is the sine of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcSin! !

!Number methodsFor: 'mathematical functions'!
arcTan
	"The receiver is the tangent of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcTan! !

!Number methodsFor: 'mathematical functions' stamp: 'jsp 2/24/1999 15:20'!
arcTan: denominator
	"The receiver is the tangent of an angle. Answer the angle measured in 
	radians."

	^(self asFloat) arcTan: denominator.! !

!Number methodsFor: 'mathematical functions'!
cos
	"The receiver represents an angle measured in radians. Answer its cosine."

	^self asFloat cos! !

!Number methodsFor: 'mathematical functions' stamp: 'sd 3/5/2004 10:04'!
degreeCos
	"Answer the cosine of the receiver taken as an angle in degrees."
	
	^ (90 + self) degreeSin! !

!Number methodsFor: 'mathematical functions' stamp: 'sd 3/5/2004 10:04'!
degreeSin
	"Answer the sine of the receiver taken as an angle in degrees."
	
	^ self asFloat degreesToRadians sin! !

!Number methodsFor: 'mathematical functions'!
exp
	"Answer the exponential of the receiver as a floating point number."

	^self asFloat exp! !

!Number methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:16'!
floorLog: radix
	"Answer the floor of the log base radix of the receiver."

	^ self asFloat floorLog: radix
! !

!Number methodsFor: 'mathematical functions' stamp: 'ar 8/31/2000 20:05'!
interpolateTo: aNumber at: param
	^self + (aNumber - self * param)! !

!Number methodsFor: 'mathematical functions'!
ln
	"Answer the natural log of the receiver."

	^self asFloat ln! !

!Number methodsFor: 'mathematical functions' stamp: 'di 9/8/1998 17:10'!
log
	"Answer the base-10 log of the receiver."

	^self asFloat log! !

!Number methodsFor: 'mathematical functions'!
log: aNumber 
	"Answer the log base aNumber of the receiver."

	^self ln / aNumber ln! !

!Number methodsFor: 'mathematical functions' stamp: 'RJ 3/15/1999 19:35'!
raisedTo: aNumber 
	"Answer the receiver raised to aNumber."

	aNumber isInteger ifTrue:
		["Do the special case of integer power"
		^ self raisedToInteger: aNumber].
	self < 0 ifTrue:
		[ self error: self printString, ' raised to a non-integer power' ].
	aNumber = 0 ifTrue: [^ 1].		"Special case of exponent=0"
	(self = 0) | (aNumber = 1) ifTrue:
		[^ self].						"Special case of exponent=1"
	^ (aNumber * self ln) exp		"Otherwise use logarithms"! !

!Number methodsFor: 'mathematical functions' stamp: 'RAH 4/25/2000 19:49'!
raisedToInteger: operand 
	"Answer the receiver raised to the power operand, an Integer."
	| count result |
	#Numeric.
	"Changed 200/01/19 For ANSI <number> support."
	operand isInteger ifFalse: [^ ArithmeticError signal: 'parameter is not an Integer'"<- Chg"].
	operand = 0 ifTrue: [^ self class one].
	operand = 1 ifTrue: [^ self].
	operand < 0 ifTrue: [^ (self raisedToInteger: operand negated) reciprocal].
	count := 1.
	[(count := count + count) < operand] whileTrue.
	result := self class one.
	[count > 0]
		whileTrue: 
			[result := result * result.
			(operand bitAnd: count)
				= 0 ifFalse: [result := result * self].
			count := count bitShift: -1].
	^ result! !

!Number methodsFor: 'mathematical functions'!
sin
	"The receiver represents an angle measured in radians. Answer its sine."

	^self asFloat sin! !

!Number methodsFor: 'mathematical functions'!
sqrt
	"Answer the square root of the receiver."

	^self asFloat sqrt! !

!Number methodsFor: 'mathematical functions'!
squared
	"Answer the receiver multipled by itself."

	^self * self! !

!Number methodsFor: 'mathematical functions'!
tan
	"The receiver represents an angle measured in radians. Answer its 
	tangent."

	^self asFloat tan! !


!Number methodsFor: 'printing'!
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."

	^ super defaultLabelForInspector, ': ', self printString! !

!Number methodsFor: 'printing' stamp: 'sw 6/29/1999 21:10'!
isOrAreStringWith: aNoun
	| result |
	result _ self = 1
		ifTrue:
			[' is one ']
		ifFalse:
			[self = 0
				ifTrue:
					[' are no ']
				ifFalse:
					[' are ', self printString, ' ']].
	result _ result, aNoun.
	self = 1 ifFalse: [result _ result, 's'].
	^ result

"#(0 1 2 98.6) do:
	[:num | Transcript cr; show: 'There', (num isOrAreStringWith: 'way'), ' to skin a cat']"! !

!Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:53'!
printOn: aStream
	self printOn: aStream base: 10! !

!Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:55'!
printOn: aStream base: base
	^self subclassResponsibility! !

!Number methodsFor: 'printing' stamp: 'laza 3/30/2004 10:50'!
printString
	^self printStringBase: 10! !

!Number methodsFor: 'printing'!
printStringBase: base
	^ String streamContents:
		[:strm | self printOn: strm base: base]! !

!Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:50'!
storeOn: aStream 
	self printOn: aStream! !

!Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:59'!
storeOn: aStream base: base
	self printOn: aStream base: base! !

!Number methodsFor: 'printing'!
storeStringBase: base
	^ String streamContents: [:strm | self storeOn: strm base: base]! !

!Number methodsFor: 'printing' stamp: 'sw 7/1/1998 12:33'!
stringForReadout
	^ self rounded printString! !


!Number methodsFor: 'testing' stamp: 'sw 9/27/2001 17:26'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	^ #Number! !

!Number methodsFor: 'testing'!
even
	"Answer whether the receiver is an even number."

	^self \\ 2 = 0! !

!Number methodsFor: 'testing' stamp: 'sw 12/30/1998 13:21'!
isDivisibleBy: aNumber
	aNumber = 0 ifTrue: [^ false].
	aNumber isInteger ifFalse: [^ false].
	^ (self \\ aNumber) = 0! !

!Number methodsFor: 'testing' stamp: 'tao 10/10/97 16:36'!
isInf
	^ false! !

!Number methodsFor: 'testing' stamp: 'tao 4/19/98 23:33'!
isInfinite

	^ false! !

!Number methodsFor: 'testing' stamp: 'tao 10/10/97 16:36'!
isNaN
	^ false! !

!Number methodsFor: 'testing'!
isNumber
	^ true! !

!Number methodsFor: 'testing'!
isZero
	^self = 0! !

!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'!
negative
	"Answer whether the receiver is mathematically negative."

	^ self < 0! !

!Number methodsFor: 'testing'!
odd
	"Answer whether the receiver is an odd number."

	^self even == false! !

!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:17'!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ self >= 0! !

!Number methodsFor: 'testing'!
sign
	"Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0."

	self > 0 ifTrue: [^1].
	self < 0 ifTrue: [^-1].
	^0! !

!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ self > 0! !


!Number methodsFor: 'truncation and round off'!
ceiling
	"Answer the integer nearest the receiver toward positive infinity."

	self <= 0.0
		ifTrue: [^self truncated]
		ifFalse: [^self negated floor negated]! !

!Number methodsFor: 'truncation and round off' stamp: 'di 2/19/98 21:58'!
detentBy: detent atMultiplesOf: grid snap: snap
	"Map all values that are within detent/2 of any multiple of grid to that multiple.  Otherwise, if snap is true, return self, meaning that the values in the dead zone will never be returned.  If snap is false, then expand the range between dead zones so that it covers the range between multiples of the grid, and scale the value by that factor."
	| r1 r2 |
	r1 _ self roundTo: grid.  "Nearest multiple of grid"
	(self roundTo: detent) = r1 ifTrue: [^ r1].  "Snap to that multiple..."
	snap ifTrue: [^ self].  "...or return self"

	r2 _ self < r1  "Nearest end of dead zone"
		ifTrue: [r1 - (detent asFloat/2)]
		ifFalse: [r1 + (detent asFloat/2)].
	"Scale values between dead zones to fill range between multiples"
	^ r1 + ((self - r2) * grid asFloat / (grid - detent))
"
	(170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: true] 	(170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: false]
	(3.9 to: 4.1 by: 0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: true] 	(-3.9 to: -4.1 by: -0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: false]
"! !

!Number methodsFor: 'truncation and round off'!
floor
	"Answer the integer nearest the receiver toward negative infinity."

	| truncation |
	truncation _ self truncated.
	self >= 0 ifTrue: [^truncation].
	self = truncation
		ifTrue: [^truncation]
		ifFalse: [^truncation - 1]! !

!Number methodsFor: 'truncation and round off' stamp: 'RAH 4/25/2000 19:49'!
fractionPart
	"Answer the fractional part of the receiver."
	#Numeric.
	"2000/03/04  Harmon R. Added ANSI <number> protocol"
	^ self - self truncated! !

!Number methodsFor: 'truncation and round off' stamp: 'RAH 4/25/2000 19:49'!
integerPart
	"Answer the integer part of the receiver."
	#Numeric.
	"2000/03/04  Harmon R. Added ANSI <number> protocol"
	^ self truncated! !

!Number methodsFor: 'truncation and round off'!
reduce
    "If self is close to an integer, return that integer"
    ^ self! !

!Number methodsFor: 'truncation and round off' stamp: 'di 10/4/1999 08:08'!
roundTo: quantum 
	"Answer the nearest number that is a multiple of quantum."

	^(self / quantum) rounded * quantum! !

!Number methodsFor: 'truncation and round off'!
roundUpTo: aNumber 
	"Answer the next multiple of aNumber toward infinity that is nearest the 
	receiver."

	^(self/aNumber) ceiling * aNumber! !

!Number methodsFor: 'truncation and round off'!
rounded
	"Answer the integer nearest the receiver."

	^(self + (self sign / 2)) truncated! !

!Number methodsFor: 'truncation and round off'!
truncateTo: aNumber 
	"Answer the next multiple of aNumber toward zero that is nearest the 
	receiver."

	^(self quo: aNumber)
		* aNumber! !

!Number methodsFor: 'truncation and round off'!
truncated
	"Answer an integer nearest the receiver toward zero."

	^self quo: 1! !


!Number methodsFor: '*eToys-printing' stamp: 'sw 10/31/97 13:54'!
newTileMorphRepresentative
	^ TileMorph new addArrows; setLiteral: self; addSuffixIfCan
! !


!Number methodsFor: '*eToys-vocabulary' stamp: 'sw 8/3/2001 13:43'!
vocabularyDemanded
	"Answer the vocabulary normally preferred by this object"

	^ Vocabulary numberVocabulary! !


!Number methodsFor: '*Morphic-NewCurve-testing' stamp: 'jmv 2/21/2006 13:15'!
isNonZero
	"Return true for numbers not zero and false for all other
	objects "
	^ self isZero not! !

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

Number class
	instanceVariableNames: ''!

!Number class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 21:46'!
readExactlyFrom: stringOrStream 
	"Answer a number as described on aStream. The number may
	include a leading radix specification, as in 16rFADE"
	
	^(SqNumberParser on: stringOrStream) nextNumber! !

!Number class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 22:40'!
readFrom: stringOrStream 
	"Answer a number as described on aStream.  The number may
	include a leading radix specification, as in 16rFADE"
	| value base aStream sign |
	aStream _ (stringOrStream isString)
		ifTrue: [ReadStream on: stringOrStream]
		ifFalse: [stringOrStream].
	(aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan].
	sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
	(aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign].
	base _ 10.
	value _ Integer readFrom: aStream base: base.
	(aStream peekFor: $r)
		ifTrue: 
			["<base>r<integer>"
			(base _ value) < 2 ifTrue: [^self error: 'Invalid radix'].
			(aStream peekFor: $-) ifTrue: [sign _ sign negated].
			value _ Integer readFrom: aStream base: base].
	^ self readRemainderOf: value from: aStream base: base withSign: sign.! !

!Number class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 22:41'!
readFrom: stringOrStream base: base
	"Answer a number as described on aStream in the given number base."

	| aStream sign |
	aStream _ (stringOrStream isString)
		ifTrue: [ReadStream on: stringOrStream]
		ifFalse: [stringOrStream].
	(aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan].
	sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
	(aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign].
	^ self readRemainderOf: (Integer readFrom: aStream base: base)
			from: aStream base: base withSign: sign! !


!Number class methodsFor: 'private' stamp: 'dtl 7/3/2006 17:41'!
readExponent: baseValue base: base from: aStream
	"Complete creation of a number, reading exponent from aStream. Answer the
	number, or nil if parsing fails.
	<number>(e|d|q)<exponent>>"

	| sign exp value |
	('edq' includes: aStream next) ifFalse: [^ nil].
	sign := ((aStream peek) == $-)
		ifTrue: [aStream next. -1]
		ifFalse: [1].
	(aStream atEnd or: [(aStream peek digitValue between: 0 and: 9) not])
		ifTrue: [^ nil]. "Avoid throwing an error"
	exp := (Integer readFrom: aStream base: 10) * sign.
	value := baseValue * (base raisedTo: exp).
	^ value
! !

!Number class methodsFor: 'private' stamp: 'dtl 7/4/2006 08:32'!
readRemainderOf: integerPart from: aStream base: base withSign: sign 
	"Read optional fractional part and exponent or decimal scale, and return the final result"
	"Changed 200/01/19 For ANSI Numeric Literals support."
	"Number readFrom: '3r-22.2'"

	| value fractionDigits fracpos fractionPart fraction pos v foundDecimal |
	#Numeric.
	value := integerPart.
	fractionDigits := 0.
	foundDecimal := false.
	(aStream peekFor: $.)
		ifTrue: ["<integer>.<fraction>"
			foundDecimal := true.
			(aStream atEnd not
					and: [aStream peek digitValue between: 0 and: base - 1])
				ifTrue: [fracpos := aStream position.
					fractionPart := Integer readFrom: aStream base: base.
					fraction := fractionPart asFloat
								/ (base raisedTo: aStream position - fracpos).
					fractionDigits := aStream position - fracpos.
					value := value asFloat + fraction]].

	pos := aStream position.
	(v := self readScaledDecimal: integerPart
			fractionPart: fractionPart
			digits: fractionDigits
			base: base
			sign: sign
			from: aStream)
		ifNil: [aStream position: pos]
		ifNotNil: [^ v "<number>s<scale>>"].

	pos := aStream position.
	(v := self readExponent: value base: base from: aStream)
		ifNil: [aStream position: pos.
			(foundDecimal and: [fractionDigits = 0])
				ifTrue: ["oops - just <integer>."
							aStream skip: -1.
							"un-gobble the period"
							^ value * sign]]
		ifNotNil: [value := v "<number>(e|d|q)<exponent>>"].

	(value isFloat
			and: [value = 0.0
					and: [sign = -1]])
		ifTrue: [^ Float negativeZero]
		ifFalse: [^ value * sign]! !

!Number class methodsFor: 'private' stamp: 'md 7/15/2006 18:00'!
readScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream 
	"Complete creation of a ScaledDecimal, reading scale from aStream. Answer
	a ScaledDecimal, or nil if parsing fails.
	<number>s[<scale>]"

	| scale decimalMultiplier decimalFraction |
	aStream atEnd ifTrue: [^ nil].
	(aStream next == $s) ifFalse: [^ nil].
	"<number>s<scale>"
	(aStream atEnd not and: [aStream peek digitValue between: 0 and: 9])
		ifTrue: [scale := Integer readFrom: aStream]
		ifFalse: [^ nil].
	scale isNil
		ifTrue: ["<number>s"
			fractionDigits = 0
				ifTrue: ["<integer>s"
					scale := 0]
				ifFalse: ["<integer>.<fraction>s"
					scale := fractionDigits]].
	fractionPart isNil
		ifTrue: [^ ScaledDecimal newFromNumber: integerPart * sign scale: scale]
		ifFalse: [decimalMultiplier := base raisedTo: fractionDigits.
			decimalFraction := integerPart * decimalMultiplier + fractionPart * sign / decimalMultiplier.
			^ ScaledDecimal newFromNumber: decimalFraction scale: scale]! !
TestCase subclass: #NumberParsingTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!
!NumberParsingTest commentStamp: 'dtl 11/24/2004 15:35' prior: 0!
Tests to verify parsing of numbers from streams and strings.

Note: ScaledDecimalTest contains related tests for parsing ScaledDecimal.!


!NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 14:29'!
testFloatFromStreamAsNumber
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs _ '10r-12.3456' readStream.
	aFloat _ Number readFrom: rs.
	self assert: -12.3456 = aFloat.
	self assert: rs atEnd.

	rs _ '10r-12.3456e2' readStream.
	aFloat _ Number readFrom: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs atEnd.

	rs _ '10r-12.3456e2e2' readStream.
	aFloat _ Number readFrom: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs upToEnd = 'e2'.

	rs _ '10r-12.3456d2' readStream.
	aFloat _ Number readFrom: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs atEnd.

	rs _ '10r-12.3456q2' readStream.
	aFloat _ Number readFrom: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs atEnd.

	rs _ '-12.3456q2' readStream.
	aFloat _ Number readFrom: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs atEnd.

	rs _ '12.3456q2' readStream.
	aFloat _ Number readFrom: rs.
	self assert: 1234.56 = aFloat.
	self assert: rs atEnd.

	rs _ '12.3456z2' readStream.
	aFloat _ Number readFrom: rs.
	self assert: 12.3456 = aFloat.
	self assert: rs upToEnd = 'z2'.
! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: 'nice 4/28/2006 01:20'!
testFloatFromStreamWithExponent
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs _ '1.0e-14' readStream.
	aFloat _ Number readFrom: rs.
	self assert: 1.0e-14 = aFloat.
	self assert: rs atEnd.

	rs _ '1.0e-14 1' readStream.
	aFloat _ Number readFrom: rs.
	self assert: 1.0e-14 = aFloat.
	self assert: rs upToEnd = ' 1'.

	rs _ '1.0e-14eee' readStream.
	aFloat _ Number readFrom: rs.
	self assert: 1.0e-14 = aFloat.
	self assert: rs upToEnd = 'eee'.

	rs _ '1.0e14e10' readStream.
	aFloat _ Number readFrom: rs.
	self assert: 1.0e14 = aFloat.
	self assert: rs upToEnd = 'e10'.

	rs _ '1.0e+14e' readStream. "Plus sign is not parseable"
	aFloat _ Number readFrom: rs.
	self assert: 1.0 = aFloat.
	self assert: rs upToEnd = 'e+14e'.

	rs _ '1.0e' readStream.
	aFloat _ Number readFrom: rs.
	self assert: 1.0 = aFloat.
	self assert: rs upToEnd = 'e'.! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 14:07'!
testFloatFromStringAsNumber
	"This covers parsing in Number>>readFrom:"

	| aFloat |
	aFloat _ '10r-12.3456' asNumber.
	self assert: -12.3456 = aFloat.
	aFloat _ '10r-12.3456e2' asNumber.
	self assert: -1234.56 = aFloat.
	aFloat _ '10r-12.3456d2' asNumber.
	self assert: -1234.56 = aFloat.
	aFloat _ '10r-12.3456q2' asNumber.
	self assert: -1234.56 = aFloat.
	aFloat _ '-12.3456q2' asNumber.
	self assert: -1234.56 = aFloat.
	aFloat _ '12.3456q2' asNumber.
	self assert: 1234.56 = aFloat.
! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 14:12'!
testFloatFromStringWithExponent
	"This covers parsing in Number>>readFrom:"

	| aFloat |
	aFloat _ '1.0e-14' asNumber.
	self assert: 1.0e-14 = aFloat.
	aFloat _ '1.0e-14 1' asNumber.
	self assert: 1.0e-14 = aFloat.
	aFloat _ '1.0e-14e' asNumber.
	self assert: 1.0e-14 = aFloat.
	aFloat _ '1.0e14e' asNumber.
	self assert: 1.0e14 = aFloat.
	aFloat _ '1.0e+14e' asNumber. "Plus sign is not parseable"
	self assert: 1.0 = aFloat.
! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: 'nice 4/28/2006 01:39'!
testFloatReadError
	"This covers parsing in Number>>readFrom:"

	| rs num |
	rs := '1e' readStream.
	num := Number readFrom: rs.
	self assert: 1 = num.
	self assert: rs upToEnd = 'e'.
	
	rs := '1s' readStream.
	num := Number readFrom: rs.
	self assert: 1 = num.
	self assert: rs upToEnd = 's'.

	rs := '1.' readStream.
	num := Number readFrom: rs.
	self assert: 1 = num.
	self assert: num isInteger.
	self assert: rs upToEnd = '.'.
	
	rs := '' readStream.
	self should: [Number readFrom: rs] raise: Error.
	
	rs := 'foo' readStream.
	self should: [Number readFrom: rs] raise: Error.

	rs := 'radix' readStream.
	self should: [Number readFrom: rs] raise: Error.
	
	rs := '.e0' readStream.
	self should: [Number readFrom: rs] raise: Error.
	
	rs := '-.e0' readStream.
	self should: [Number readFrom: rs] raise: Error.
	
	rs := '--1' readStream.
	self should: [Number readFrom: rs] raise: Error.! !

!NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 18:16'!
testFloatReadWithRadix
	"This covers parsing in Number>>readFrom:
	Note: In most Smalltalk dialects, the radix notation is not used for numbers
	with exponents. In Squeak, a string with radix and exponent can be parsed,
	and the exponent is always treated as base 10 (not the base indicated in the
	radix prefix). I am not sure if this is a feature, a bug, or both, but the
	Squeak behavior is documented in this test. -dtl"

	| aNumber rs |
	aNumber _ '2r1.0101e9' asNumber.
	self assert: 672.0 = aNumber.
	self assert: (Number readFrom: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)).
	rs _ ReadStream on: '2r1.0101e9e9'.
	self assert: (Number readFrom: rs) = 672.0.
	self assert: rs upToEnd = 'e9'
! !


!NumberParsingTest methodsFor: 'tests - Integer' stamp: 'dtl 11/24/2004 14:05'!
testIntegerFromString
	"This covers parsing in Number>>readFrom:
	Trailing decimal points should be ignored."

	self assert: ('123' asNumber == 123).
	self assert: ('-123' asNumber == -123).
	self assert: ('123.' asNumber == 123).
	self assert: ('-123.' asNumber == -123).
	self assert: ('123This is not to be read' asNumber == 123).
	self assert: ('123s could be confused with a ScaledDecimal' asNumber == 123).
	self assert: ('123e could be confused with a Float' asNumber == 123).
! !

!NumberParsingTest methodsFor: 'tests - Integer' stamp: 'tween 7/8/2006 12:31'!
testIntegerReadFrom
	"Ensure remaining characters in a stream are not lost when parsing an integer."

	| rs i s |
	rs _ ReadStream on: '123s could be confused with a ScaledDecimal'.
	i _ Number readFrom: rs.
	self assert: i == 123.
	s _ rs upToEnd.
	self assert: 's could be confused with a ScaledDecimal' = s.
	rs _ ReadStream on: '123.s could be confused with a ScaledDecimal'.
	i _ Number readFrom: rs.
	self assert: i == 123.
	s _ rs upToEnd.
	self assert: '.s could be confused with a ScaledDecimal' = s.
	rs _ ReadStream on: '123sA has unary message sA'.
	i _ Number readFrom: rs.
	self assert: i == 123.
	s _ rs upToEnd.
	self assert: 'sA has unary message sA' = s.	
	rs _ ReadStream on: '123sB has unary message sB'.
	i _ Number readFrom: rs.
	self assert: i == 123.
	s _ rs upToEnd.
	self assert: 'sB has unary message sB' = s.
! !

!NumberParsingTest methodsFor: 'tests - Integer' stamp: 'dtl 11/24/2004 18:18'!
testIntegerReadWithRadix
	"This covers parsing in Number>>readFrom:
	Note: In most Smalltalk dialects, the radix notation is not used for numbers
	with exponents. In Squeak, a string with radix and exponent can be parsed,
	and the exponent is always treated as base 10 (not the base indicated in the
	radix prefix). I am not sure if this is a feature, a bug, or both, but the
	Squeak behavior is documented in this test. -dtl"

	| aNumber rs |
	aNumber _ '2r1e26' asNumber.
	self assert: 67108864 = aNumber.
	self assert: (Number readFrom: '2r1e26') = (2 raisedTo: 26).
	rs _ '2r1e26eee' readStream.
	self assert: (Number readFrom: rs) = 67108864.
	self assert: rs upToEnd = 'eee'
! !
ClassTestCase subclass: #NumberTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!

!NumberTest methodsFor: 'tests' stamp: 'fbs 3/8/2006 11:24'!
testPrintShowingDecimalPlaces

	self assert: (111.2 printShowingDecimalPlaces: 2) = '111.20'.
	self assert: (111.2 printShowingDecimalPlaces: 0) = '111'.
	self assert: (111 printShowingDecimalPlaces: 0) = '111'.
	self assert: (111111111111111 printShowingDecimalPlaces: 2) = '111111111111111.00'.
	self assert: (10 printShowingDecimalPlaces: 20) ='10.00000000000000000000'.
! !

!NumberTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:56'!
testReadFrom
	
	self assert: 1.0e-14	= (Number readFrom: '1.0e-14').
	self assert: 2r1e26	= (Number readFrom: '2r1e26').! !
DataType subclass: #NumberType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!
!NumberType commentStamp: 'sw 10/3/2002 02:18' prior: 0!
NumberType is a data type representing a numeric value.!


!NumberType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:29'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ (1 to: 9) atRandom! !


!NumberType methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	| aMethodCategory aMethodInterface |
	super initialize.
	"Vocabulary replaceNumberVocabulary"
	"Vocabulary addVocabulary: Vocabulary newNumberVocabulary"

	self vocabularyName: #Number.
	self documentation: 'Numbers are things that can do arithmetic, have their magnitudes compared, etc.'.

#((comparing				'Determining which of two numbers is larger'
		(= < > <= >= ~= ~~))
(arithmetic 				'Basic numeric operation'
		(* + - / // \\ abs negated quo: rem:))
(testing 					'Testing a number'
		(even isDivisibleBy: negative odd positive sign))
(#'mathematical functions'	'Trigonometric and exponential functions'
		(cos exp ln log log: raisedTo: sin sqrt squared tan raisedToInteger:))
(converting 				'Converting a number to another form'
		(@ asInteger asPoint degreesToRadians radiansToDegrees asSmallAngleDegrees asSmallPositiveDegrees))
(#'truncation and round off' 'Making a real number (with a decimal point) into an integer'
		(ceiling floor roundTo: roundUpTo: rounded truncateTo: truncated))
) do:

		[:item | 
			aMethodCategory := ElementCategory new categoryName: item first.
			aMethodCategory documentation: item second.
			item third do:
				[:aSelector | 
					aMethodInterface := MethodInterface new conjuredUpFor: aSelector class: (Number whichClassIncludesSelector: aSelector).
					aMethodInterface argumentVariables do:
							[:var | var variableType: #Number].

					(#(* + - / // \\ abs negated quo: rem:
						cos exp ln log log: raisedTo: sin sqrt squared tan raisedToInteger:
						asInteger degreesToRadians radiansToDegrees asSmallAngleDegrees asSmallPositiveDegrees)
							includes: aSelector) ifTrue:
								[aMethodInterface resultType: #Number].

					(#( @  asPoint ) includes: aSelector) ifTrue:
						[aMethodInterface resultType: #Point].

					(#(= < > <= >= ~= ~~ even isDivisibleBy: negative odd positive) includes: aSelector) ifTrue:
						[aMethodInterface resultType: #Boolean].

					aMethodInterface setNotToRefresh.  
					self atKey: aSelector putMethodInterface: aMethodInterface.
					aMethodCategory elementAt: aSelector put: aMethodInterface].
			self addCategory: aMethodCategory].

"
(('truncation and round off' ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated)
('testing' basicType even isDivisibleBy: isInf isInfinite isNaN isNumber isZero negative odd positive sign strictlyPositive)
('converting' @ adaptToCollection:andSend: adaptToFloat:andSend: adaptToFraction:andSend: adaptToInteger:andSend: adaptToPoint:andSend: adaptToString:andSend: asInteger asNumber asPoint asSmallAngleDegrees asSmallPositiveDegrees degreesToRadians radiansToDegrees)
('intervals' to: to:by: to:by:do: to:do:)
('printing' defaultLabelForInspector isOrAreStringWith: newTileMorphRepresentative printOn: printStringBase: storeOn: storeOn:base: storeStringBase: stringForReadout)
('comparing' closeTo:)
('filter streaming' byteEncode:)
('as yet unclassified' reduce)"



! !


!NumberType methodsFor: '*eToys-color' stamp: 'sw 9/27/2001 17:21'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(0.8 0.4 0.2)! !


!NumberType methodsFor: '*eToys-tiles' stamp: 'dgd 9/6/2003 20:30'!
addExtraItemsToMenu: aMenu forSlotSymbol: slotSym
	"If the receiver has extra menu items to add to the slot menu, here is its chance to do it.  The defaultTarget of the menu is the player concerned."

	aMenu add: 'decimal places...' translated selector: #setPrecisionFor: argument: slotSym.
	aMenu balloonTextForLastItem: 'Lets you choose how many decimal places should be shown in readouts for this variable' translated! !

!NumberType methodsFor: '*eToys-tiles' stamp: 'sw 9/15/2002 16:50'!
addUserSlotItemsTo: aMenu slotSymbol: slotSym
	"Optionally add items to the menu that pertain to a user-defined slot of the given symbol"

	"aMenu add: 'decimal places...' selector: #setPrecisionFor: argument: slotSym
	NB: This item is now generically added for system as well as user slots, so the addition is now done in NubmerType.addExtraItemsToMenu:forSlotSymbol:"! !

!NumberType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 02:53'!
comparatorForSampleBoolean
	"Answer the comparator to use in tile coercions involving the receiver; normally, the equality comparator is used but NumberType overrides"

	^ #<! !

!NumberType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ 5 newTileMorphRepresentative typeColor: self typeColor! !

!NumberType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:37'!
newReadoutTile
	"Answer a tile that can serve as a readout for data of this type"

	^ NumericReadoutTile new typeColor: Color lightGray lighter! !

!NumberType methodsFor: '*eToys-tiles' stamp: 'sw 9/26/2001 03:11'!
wantsAssignmentTileVariants
	"Answer whether an assignment tile for a variable of this type should show variants to increase-by, decrease-by, multiply-by."

	^ true! !

!NumberType methodsFor: '*eToys-tiles' stamp: 'sw 9/26/2001 03:18'!
wantsSuffixArrow
	"Answer whether a tile showing data of this type would like to have a suffix arrow"

	^ true! !
TileMorph subclass: #NumericReadoutTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!NumericReadoutTile methodsFor: 'accessing' stamp: 'ar 9/15/2000 23:27'!
abandonLabelFocus
	| aLabel |
	"If the receiver's label has editing focus, abandon it"
	self flag: #arNote. "Probably unnecessary"
	(aLabel _ self labelMorph) ifNotNil:
		[aLabel hasFocus ifTrue:
			[aLabel contents: aLabel readFromTarget.
			aLabel handsWithMeForKeyboardFocus do:
				[:aHand | aHand releaseKeyboardFocus]]]! !

!NumericReadoutTile methodsFor: 'accessing' stamp: 'tak 12/6/2004 01:53'!
literalFromContents
	| label |
	label _ self labelMorph
				ifNil: [^ super literal].
	label step.
	^ literal _ label valueFromContents! !

!NumericReadoutTile methodsFor: 'accessing' stamp: 'tak 4/6/2005 14:10'!
literal: anObject 
	literal := anObject.
	self updateLiteralLabel.
	self labelMorph
		ifNotNilDo: [:label | label informTarget]! !


!NumericReadoutTile methodsFor: 'literal' stamp: 'sw 9/15/1999 15:14'!
setLiteralTo: anObject width: w
	"like literal:width: but does not inform the target"
	literal _ anObject.
	self updateLiteralLabel.
	submorphs last setWidth: w.
	self updateLiteralLabel! !


!NumericReadoutTile methodsFor: 'misc' stamp: 'sw 9/17/1999 08:01'!
basicWidth
	^ 26! !

!NumericReadoutTile methodsFor: 'misc' stamp: 'sw 9/17/1999 08:18'!
minimumWidth
	^ 40! !


!NumericReadoutTile methodsFor: 'mouse' stamp: 'ar 10/25/2000 18:07'!
handlesMouseMove: evt
	^true! !


!NumericReadoutTile methodsFor: 'parts bin' stamp: 'sw 11/15/2001 20:22'!
initializeToStandAlone
	"Enclose my prototype in a SyntaxMorph.  For the ObjectTool"

	| aWatcher aTile aLine aColor ms slotMsg |

	super initializeToStandAlone.
	aColor _ Color r: 0.387 g: 0.581 b: 1.0.
	aTile _ self typeColor: aColor.
	aWatcher _ UpdatingStringMorph new.
	aWatcher growable: true;
		getSelector: nil;
		putSelector: nil;
		setToAllowTextEdit.
	aWatcher target: nil.
	aTile addMorphBack: aWatcher.
	aTile addArrows.
	aTile setLiteralTo: 5 width: 30.

	ms _ MessageSend receiver: nil selector: #aNumber arguments: #().
	slotMsg _ ms asTilesIn: Player globalNames: false.
		"For CardPlayers, use 'aPlayer'.  For others, name it, and use its name."
	ms _ MessageSend receiver: 3 selector: #= asSymbol arguments: #(5).
	aLine _ ms asTilesIn: Player globalNames: false.
	aLine firstSubmorph delete.		"A little over-complicated?  Yes?"
	aLine addMorphFront: (slotMsg submorphs second) firstSubmorph.
	aLine addMorphFront: (Morph new transparentSpacerOfSize: 3@3).
	aLine lastSubmorph delete.
	aLine lastSubmorph delete.
	aLine color: aColor.
	aLine addMorphBack: (Morph new transparentSpacerOfSize: 3@3).
	aLine addMorphBack: aTile.
	aLine cellPositioning: #leftCenter.
	aWatcher step; fitContents.
	^ aLine markAsPartsDonor.! !


!NumericReadoutTile methodsFor: 'testing' stamp: 'tk 11/1/2001 12:41'!
basicType
	"Answer a symbol representing the inherent type I hold"

	"Number String Boolean player collection sound color etc"
	^ #Number! !


!NumericReadoutTile methodsFor: 'event handling' stamp: 'tak 8/2/2005 23:36'!
mouseStillDown: evt 
	(self labelMorph notNil
			and: [self labelMorph containsPoint: evt cursorPoint])
		ifTrue: [^ self labelMorph mouseDown: evt].
	^ super mouseStillDown: evt! !

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

NumericReadoutTile class
	instanceVariableNames: ''!

!NumericReadoutTile class methodsFor: 'instance creation' stamp: 'tk 12/14/2001 19:32'!
borderedPrototype
	"Just number and up/down arrows"

	| aWatcher aTile |

	aTile _ self new typeColor: (Color r: 0.387 g: 0.581 b: 1.0).
	aWatcher _ UpdatingStringMorph new.
	aWatcher growable: true; setNameTo: 'value'.
	aTile addMorphBack: aWatcher.
	aTile addArrows; setNameTo: 'Number (mid)'.
	aTile setLiteralTo: 5 width: 30.
	aWatcher step; fitContents; setToAllowTextEdit.
	^ aTile extent: 30@24; markAsPartsDonor! !

!NumericReadoutTile class methodsFor: 'instance creation' stamp: 'tk 12/14/2001 19:29'!
simplePrototype
	"Bare number readout.  Will keep up to data with a number once it has target, getterSelector, setterSelector."

	^ (UpdatingStringMorph new) contents: '5'; growable: true; setToAllowTextEdit; 
		step; fitContents; setNameTo: 'Number (bare)'; markAsPartsDonor! !

!NumericReadoutTile class methodsFor: 'instance creation' stamp: 'nk 8/23/2004 18:11'!
supplementaryPartsDescriptions
	"Answer additional items for the parts bin"

	Preferences universalTiles ifFalse: [^ #()].

	^ {DescriptionForPartsBin
		formalName: 'Number (fancy)'
		categoryList: #('Basic')
		documentation: 'A number readout for a Stack.  Shows current value.  Click and type the value.  Shift-click on title to edit.'
		globalReceiverSymbol: #NumericReadoutTile
		nativitySelector: #authoringPrototype.

	   DescriptionForPartsBin
		formalName: 'Number (bare)'
		categoryList: #('Basic')
		documentation: 'A number readout for a Stack.  Shows current value.  Click and type the value.'
		globalReceiverSymbol: #NumericReadoutTile
		nativitySelector: #simplePrototype.

	   DescriptionForPartsBin
		formalName: 'Number (mid)'
		categoryList: #('Basic')
		documentation: 'A number readout for a Stack.  Shows current value.  Click and type the value.'
		globalReceiverSymbol: #NumericReadoutTile
		nativitySelector: #borderedPrototype}! !


!NumericReadoutTile class methodsFor: 'scripting' stamp: 'tk 12/14/2001 19:30'!
authoringPrototype
	"Enclose my prototype in a SyntaxMorph."

	| aWatcher aTile aLine aColor ms slotMsg |

	aColor _ Color r: 0.387 g: 0.581 b: 1.0.
	aTile _ self new typeColor: aColor.
	aWatcher _ UpdatingStringMorph new.
	aWatcher growable: true;
		setToAllowTextEdit;
		getSelector: nil;
		putSelector: nil.
	aWatcher target: nil.
	aTile addMorphBack: aWatcher.
	aTile addArrows.
	aTile setLiteralTo: 5 width: 30.

	"This is the long way around to do this..."
	ms _ MessageSend receiver: nil selector: #aNumber arguments: #().
	slotMsg _ ms asTilesIn: Player globalNames: false.
		"For CardPlayers, use 'aPlayer'.  For others, name it, and use its name."
	ms _ MessageSend receiver: 3 selector: #= asSymbol arguments: #(5).
	aLine _ ms asTilesIn: Player globalNames: false.
	aLine firstSubmorph delete.	
	aLine addMorphFront: (slotMsg submorphs second) firstSubmorph.
	aLine firstSubmorph setNameTo: 'label'.
	aLine addMorphFront: (Morph new transparentSpacerOfSize: 3@3).
	aLine lastSubmorph delete.
	aLine lastSubmorph delete.
	aLine color: aColor; setNameTo: 'Number (fancy)'.
	aLine addMorphBack: (Morph new transparentSpacerOfSize: 3@3).
	aLine addMorphBack: aTile.
	aLine readOut setNameTo: 'value'.
	aLine cellPositioning: #leftCenter.
	aWatcher step; fitContents.
	^ aLine markAsPartsDonor.! !
OBAnnouncement subclass: #OBAboutToChange
	instanceVariableNames: 'veto'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBAboutToChange methodsFor: 'vetos' stamp: 'cwp 4/17/2006 22:18'!
isVetoed
	^ veto notNil! !

!OBAboutToChange methodsFor: 'vetos' stamp: 'cwp 4/17/2006 19:45'!
veto
	veto _ true! !
MessageSend subclass: #OBAction
	instanceVariableNames: 'announcer dispatcher label buttonLabel keystroke icon'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Services'!
!OBAction commentStamp: 'cwp 3/4/2004 20:52' prior: 0!
Actions represent commands for manipulating the graph domain. They can be made available through menus or buttons in the browser. They carry information on how they should be presented to the user, and are responsible for handling exceptions generated when they are triggered. Actions are created by Actors.

iVars: 

label 		a string which describes the action for the user.
monitor  	when the action is triggered, any notifications raised 
			will be passed to this object for processing!


!OBAction methodsFor: 'accessing' stamp: 'cwp 6/4/2006 00:25'!
announcer
	^ announcer! !

!OBAction methodsFor: 'accessing' stamp: 'cwp 6/4/2006 00:25'!
announcer: anAnnouncer
	announcer _ anAnnouncer! !

!OBAction methodsFor: 'accessing' stamp: 'cwp 3/10/2004 23:35'!
buttonLabel
	^ buttonLabel! !

!OBAction methodsFor: 'accessing' stamp: 'cwp 3/10/2004 23:35'!
buttonLabel: aString
	buttonLabel _ aString
	! !

!OBAction methodsFor: 'accessing' stamp: 'hpt 5/17/2004 16:42'!
icon
	^icon! !

!OBAction methodsFor: 'accessing' stamp: 'hpt 5/17/2004 16:42'!
icon: anIcon
	icon _ anIcon! !

!OBAction methodsFor: 'accessing' stamp: 'hpt 5/17/2004 14:16'!
keystroke
	^keystroke! !

!OBAction methodsFor: 'accessing' stamp: 'hpt 5/17/2004 14:16'!
keystroke: aChar
	keystroke _ aChar! !

!OBAction methodsFor: 'accessing' stamp: 'cwp 1/7/2004 09:11'!
label
	^ label! !

!OBAction methodsFor: 'accessing' stamp: 'cwp 1/7/2004 09:12'!
label: aString
	label _ aString! !

!OBAction methodsFor: 'accessing' stamp: 'cwp 3/10/2004 23:40'!
wantsButton
	^ buttonLabel notNil! !


!OBAction methodsFor: 'evaluating' stamp: 'cwp 1/7/2004 18:22'!
perform: aSelector orSendTo: anObject
	^ self perform: aSelector! !

!OBAction methodsFor: 'evaluating' stamp: 'cwp 6/4/2006 00:58'!
trigger
	[self value]
		on: OBAnnouncerRequest
		do: [:notification | notification resume: announcer].! !


!OBAction methodsFor: 'morphic' stamp: 'hpt 5/17/2004 17:00'!
addItemToMenu: aMenu
	aMenu
		add: self labelWithKeystroke
		target: self 
		selector: #trigger.
	Preferences menuWithIcons & self icon notNil
		ifTrue: [aMenu lastItem icon: self icon].
	aMenu addBlankIconsIfNecessary: MenuIcons blankIcon.! !

!OBAction methodsFor: 'morphic' stamp: 'cwp 7/8/2006 12:55'!
buttonLabelMorph
	^ StringMorph 
		contents: self buttonLabel 
		font: Preferences standardButtonFont! !

!OBAction methodsFor: 'morphic' stamp: 'cwp 7/8/2006 12:54'!
buttonMorph
	^ (PluggableButtonMorph
		on: self
		getState: nil
		action: #trigger
		label: #buttonLabelMorph)	
			onColor: Color lightGray lighter offColor: Color lightGray twiceLighter;
			borderWidth: 2;
			borderRaised;
			hResizing: #spaceFill;
			vResizing: #spaceFill;
			setBalloonText: label! !

!OBAction methodsFor: 'morphic' stamp: 'hpt 5/17/2004 14:17'!
labelWithKeystroke
	^keystroke
		ifNil: [label]
		ifNotNil: [label, ' (', keystroke asString, ')']! !

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

OBAction class
	instanceVariableNames: ''!

!OBAction class methodsFor: 'instance creation' stamp: 'cwp 3/10/2004 23:36'!
label: aString buttonLabel: aString2 receiver: anObject selector: aSelector arguments: anArray
	^ (self receiver: anObject selector: aSelector arguments: anArray) 
		label: aString;
		buttonLabel: aString2! !

!OBAction class methodsFor: 'instance creation' stamp: 'cwp 12/5/2004 18:49'!
label: aString buttonLabel: aString2 receiver: anObject selector: aSelector 
arguments: anArray keystroke: aChar icon: anIcon
	^ (self receiver: anObject selector: aSelector arguments: anArray) 
		label: aString;
		buttonLabel: aString2;
		keystroke: aChar;
		icon: anIcon! !

!OBAction class methodsFor: 'instance creation' stamp: 'cwp 1/7/2004 09:20'!
label: aString receiver: anObject selector: aSelector arguments: anArray
	^ (self receiver: anObject selector: aSelector arguments: anArray) label: aString! !

!OBAction class methodsFor: 'instance creation' stamp: 'hpt 5/17/2004 16:50'!
label: aString receiver: anObject selector: aSelector arguments: anArray icon: anIcon
	^ (self receiver: anObject selector: aSelector arguments: anArray) 
		label: aString;
		icon: anIcon! !

!OBAction class methodsFor: 'instance creation' stamp: 'hpt 5/17/2004 14:16'!
label: aString receiver: anObject selector: aSelector arguments: anArray keystroke: aChar
	^ (self receiver: anObject selector: aSelector arguments: anArray) 
		label: aString;
		keystroke: aChar! !

!OBAction class methodsFor: 'instance creation' stamp: 'hpt 5/17/2004 16:50'!
label: aString receiver: anObject selector: aSelector arguments: anArray keystroke: aChar icon: anIcon
	^ (self receiver: anObject selector: aSelector arguments: anArray) 
		label: aString;
		keystroke: aChar;
		icon: anIcon! !
Object subclass: #OBActor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Services'!
!OBActor commentStamp: 'cwp 1/7/2005 23:14' prior: 0!
Actors provide the basic units of domain-related functionality. They are attached to metanodes, and supply the Actions used to build context menus and buttons in the browser. Actors can be proxies for functionality supplied by other classes, as in OBFileRegistryActor, or they may supply the funtionality them selves. 

OBActor is an abstract class which defines the protocol Actors must implement. Actors need not be subclasses of OBActor, however.!


!OBActor methodsFor: 'accessing' stamp: 'cwp 9/16/2004 23:25'!
actionWithLabel: aString selector: aSymbol 
	self shouldBeImplemented! !


!OBActor methodsFor: 'public' stamp: 'cwp 2/4/2004 15:25'!
actionsForNode: aNode
	^#()! !

!OBActor methodsFor: 'public' stamp: 'cwp 2/5/2004 20:12'!
actionsForParent: aNode
	^#()! !


!OBActor methodsFor: 'icons' stamp: 'cwp 7/10/2006 22:30'!
deleteIcon
	^ MenuIcons tryIcons: #(deleteIcon smallDeleteIcon)! !

!OBActor methodsFor: 'icons' stamp: 'cwp 7/10/2006 22:31'!
findIcon
	^ MenuIcons tryIcons: #(findIcon smallFindIcon)! !

!OBActor methodsFor: 'icons' stamp: 'cwp 7/10/2006 22:31'!
newIcon
	^ MenuIcons tryIcons: #(newIcon smallNewIcon)! !
OBMethodCategoryNode subclass: #OBAllMethodCategoryNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBAllMethodCategoryNode commentStamp: 'cwp 1/8/2005 12:31' prior: 0!
OBAllMethodCategory implements the synthetic '-- all --' category, which contains all the methods in a class.!


!OBAllMethodCategoryNode methodsFor: 'accessing'!
category
	^ 'as yet unclassified'! !

!OBAllMethodCategoryNode methodsFor: 'accessing'!
methodReferences
	^ self theClass selectors asSortedArray 
		collect: [:ea | MethodReference new setStandardClass: self theClass methodSymbol: ea]! !

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

OBAllMethodCategoryNode class
	instanceVariableNames: ''!

!OBAllMethodCategoryNode class methodsFor: 'as yet unclassified'!
on: className
	^ self on: '-- all --' inClass: className! !
Object subclass: #OBAnnouncement
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!
Object subclass: #OBAnnouncer
	instanceVariableNames: 'subscriptions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBAnnouncer methodsFor: 'subscription' stamp: 'cwp 6/5/2006 00:39'!
announce: anObject

	| ann |
	ann _ anObject asAnnouncement.
	subscriptions keysAndValuesDo:
		[:class :action |
		(ann isKindOf: class) ifTrue: [action valueWithArguments: {ann}]].
	^ ann! !

!OBAnnouncer methodsFor: 'subscription' stamp: 'cwp 6/3/2006 21:21'!
observe: aClass do: aValuable 
	| actions |
	actions _ subscriptions at: aClass ifAbsent: [ActionSequence new].
	subscriptions at: aClass put: (actions copyWith: aValuable).! !

!OBAnnouncer methodsFor: 'subscription' stamp: 'cwp 6/3/2006 23:31'!
observe: aClass send: aSelector to: anObject
	self
		observe: aClass
		do: (MessageSend receiver: anObject selector: aSelector)! !

!OBAnnouncer methodsFor: 'subscription' stamp: 'cwp 6/10/2006 00:40'!
unsubscribe: anObject
	subscriptions keysAndValuesDo:
		[:class :actions |
		subscriptions at: class put: (actions reject: [:ea | ea receiver == anObject])].
	subscriptions keysAndValuesRemove: [:key :value | value isEmpty]! !


!OBAnnouncer methodsFor: 'initialize-release' stamp: 'cwp 4/17/2006 11:51'!
initialize
	subscriptions _ IdentityDictionary new.! !

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

OBAnnouncer class
	instanceVariableNames: ''!

!OBAnnouncer class methodsFor: 'instance creation' stamp: 'cwp 6/4/2006 00:55'!
current
	^ OBAnnouncerRequest signal! !

!OBAnnouncer class methodsFor: 'instance creation' stamp: 'cwp 4/17/2006 11:50'!
new
	^ self basicNew initialize! !
Notification subclass: #OBAnnouncerRequest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Notifications'!
OBInteractionRequest subclass: #OBBrowseRequest
	instanceVariableNames: 'browser'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Notifications'!
!OBBrowseRequest commentStamp: 'cwp 12/7/2004 00:10' prior: 0!
This notification is raised whenever a browser needs to be opened. The default action is to open a SystemWindow in Morphic, but it can be caught in situations where that's not appropriate. The OB test suite uses this extensively. !


!OBBrowseRequest methodsFor: 'accessing' stamp: 'cwp 10/17/2004 18:45'!
browser
	^ browser! !

!OBBrowseRequest methodsFor: 'accessing' stamp: 'cwp 10/17/2004 18:45'!
browser: aBrowser
	browser _ aBrowser! !

!OBBrowseRequest methodsFor: 'accessing' stamp: 'cwp 10/17/2004 21:27'!
defaultAction
	^ browser openInMorphic! !


!OBBrowseRequest methodsFor: 'testing' stamp: 'cwp 10/17/2004 19:32'!
isBrowseRequest
	^ true! !

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

OBBrowseRequest class
	instanceVariableNames: ''!

!OBBrowseRequest class methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2004 18:45'!
signal: aBrowser
	^ (self new browser: aBrowser) signal! !
Object subclass: #OBBrowser
	instanceVariableNames: 'panels announcer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Kernel'!
!OBBrowser commentStamp: 'cwp 1/7/2005 23:17' prior: 0!
OBBrowser is the core of OmniBrower. It's the root object for each browser and the model for the SystemWindows which display them. Its main responsibily is managing panels, particularly passing update messages between them.

On the class side, OBBrowser provides some default settings for creating and opening browsers. Subclasses can override these settings to acheive customized behavior.

iVars:

panels	- A collection of objects which manage submorphs of the browser's SystemWindow.

cVars:

MetaGraphs - A dictionary matching names to metagraphs!


!OBBrowser methodsFor: 'accessing' stamp: 'cwp 6/4/2006 00:36'!
addPanel: aPanel
	panels add: aPanel.
	aPanel browser: self.
! !

!OBBrowser methodsFor: 'accessing' stamp: 'cwp 4/17/2006 15:42'!
announcer
	^ announcer! !

!OBBrowser methodsFor: 'accessing' stamp: 'cwp 11/20/2004 21:00'!
currentNode
	^self navigationPanel currentNode! !

!OBBrowser methodsFor: 'accessing' stamp: 'cwp 11/20/2004 21:00'!
currentOrRootNode
	^self navigationPanel currentOrRootNode! !

!OBBrowser methodsFor: 'accessing' stamp: 'cwp 8/31/2004 13:04'!
defaultLabel
	^ self class titleForRoot: self root! !

!OBBrowser methodsFor: 'accessing' stamp: 'cwp 12/5/2004 16:25'!
navigationPanel
	^ panels 
		detect: [:ea | ea isNavigation] 
		ifNone: [self error: 'No navigation panel configured']! !

!OBBrowser methodsFor: 'accessing' stamp: 'cwp 9/17/2004 00:53'!
panels
	^ panels! !

!OBBrowser methodsFor: 'accessing' stamp: 'cwp 6/28/2006 00:44'!
requestor
	^ OBRequestor for: self! !

!OBBrowser methodsFor: 'accessing' stamp: 'dvf 9/5/2005 17:30'!
selectionPath
	^self navigationPanel selectionPath! !


!OBBrowser methodsFor: 'callbacks' stamp: 'cwp 11/20/2004 21:05'!
labelString
	| label |
	label := self navigationPanel labelString.
	^label 
		ifNil: [self defaultLabel]
		ifNotNil: [self defaultLabel , ': ' , label]! !

!OBBrowser methodsFor: 'callbacks' stamp: 'cwp 4/17/2006 19:52'!
okToChange
	^ (self announcer announce: OBAboutToChange) isVetoed not! !


!OBBrowser methodsFor: 'initializing' stamp: 'cwp 6/4/2006 14:09'!
initialize
	panels _ OrderedCollection new.
	announcer _ OBAnnouncer new.
	self subscribe! !

!OBBrowser methodsFor: 'initializing' stamp: 'cwp 12/5/2004 16:24'!
setMetaNode: aMetaNode node: aNode 
	self navigationPanel setMetaNode: aMetaNode node: aNode! !


!OBBrowser methodsFor: 'morphic' stamp: 'cwp 11/27/2004 22:21'!
defaultBackgroundColor
	^ Color gray veryMuchLighter! !

!OBBrowser methodsFor: 'morphic' stamp: 'cwp 12/5/2004 14:23'!
morph
	| window |
	window := SystemWindow labelled: self defaultLabel.
	window model: self.
	panels isEmpty ifFalse: [self morphicPanelLayout addMorphsTo: window].
	^window! !

!OBBrowser methodsFor: 'morphic' stamp: 'cwp 11/21/2004 00:31'!
morphicPanelLayout
	^ OBMorphicPanelLayout for: panels! !

!OBBrowser methodsFor: 'morphic' stamp: 'cwp 11/21/2004 00:30'!
openInMorphic
	^ self morph openInWorld! !


!OBBrowser methodsFor: 'navigating' stamp: 'cwp 11/20/2004 21:00'!
jumpToRoot
	^self navigationPanel jumpToRoot! !

!OBBrowser methodsFor: 'navigating' stamp: 'cwp 11/20/2004 21:00'!
jumpTo: aNode 
	self navigationPanel jumpTo: aNode! !

!OBBrowser methodsFor: 'navigating' stamp: 'cwp 9/17/2005 17:48'!
root
	^self navigationPanel root! !


!OBBrowser methodsFor: 'opening' stamp: 'cwp 10/17/2004 21:31'!
open
	^ OBBrowseRequest signal: self! !


!OBBrowser methodsFor: 'updating' stamp: 'cwp 6/9/2006 23:29'!
dontTranscribe
	self announcer unsubscribe: self.
	self subscribe.! !

!OBBrowser methodsFor: 'updating' stamp: 'cwp 4/24/2006 15:10'!
relabel: ann
	self changed: #relabel.
! !

!OBBrowser methodsFor: 'updating' stamp: 'cwp 6/4/2006 18:50'!
signalRefresh
	self announcer announce: OBRefreshRequired! !

!OBBrowser methodsFor: 'updating' stamp: 'cwp 6/6/2006 00:25'!
subscribe
	self announcer 
		observe: OBSelectionChanged send: #relabel: to: self! !

!OBBrowser methodsFor: 'updating' stamp: 'cwp 6/6/2006 00:26'!
transcribe
	self announcer observe: OBAnnouncement do: [:ann | Transcript cr; show: ann].! !

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

OBBrowser class
	instanceVariableNames: ''!

!OBBrowser class methodsFor: 'auto opening' stamp: 'cwp 12/6/2004 23:22'!
open
	^ self new open! !

!OBBrowser class methodsFor: 'auto opening' stamp: 'cwp 12/5/2004 17:03'!
openRoot: rootNode selection: selectedNode
	^ (self root: rootNode selection: selectedNode) open! !


!OBBrowser class methodsFor: 'configuration' stamp: 'avi 9/17/2005 01:10'!
defaultMetaNode
	self subclassResponsibility! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 12/6/2004 23:20'!
defaultRootNode
	self subclassResponsibility! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 8/31/2004 11:10'!
definitionPanel
	^ OBDefinitionPanel new! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 8/31/2004 11:01'!
maxPanes
	^ self paneCount! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 8/31/2004 11:00'!
minPanes
	^ self paneCount! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 12/5/2004 16:55'!
navigationPanel
	^ OBColumnPanel minPanes: self minPanes maxPanes: self maxPanes! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 11/26/2004 22:27'!
optionalButtonPanel
	| labels panel |
	labels _ self optionalButtons.
	(Preferences optionalButtons and: [labels isEmpty not]) ifTrue: 
		[panel _ OBFixedButtonPanel new.
		labels do: [:ea | panel addButtonWithLabel: ea]].
	^ panel! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 8/31/2004 11:07'!
optionalButtons
	^ #()! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 8/31/2004 11:01'!
paneCount
	^ 4! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 12/5/2004 15:06'!
panels
	^ {self navigationPanel. self optionalButtonPanel. self definitionPanel} 
		reject: [:ea | ea isNil]! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 8/31/2004 11:32'!
title
	^ 'OmniBrowser'! !

!OBBrowser class methodsFor: 'configuration' stamp: 'cwp 8/31/2004 13:02'!
titleForRoot: aNode
	^ self title! !


!OBBrowser class methodsFor: 'instance creation' stamp: 'cwp 12/5/2004 18:12'!
metaNode: metaNode node: rootNode 
	^ self metaNode: metaNode root: rootNode selection: nil panels: self panels! !

!OBBrowser class methodsFor: 'instance creation' stamp: 'avi 9/17/2005 01:16'!
metaNode: metaNode root: rootNode selection: selectedNode
	^ self metaNode: metaNode root: rootNode selection: selectedNode panels: self panels! !

!OBBrowser class methodsFor: 'instance creation' stamp: 'cwp 12/6/2004 21:59'!
metaNode: metaNode root: rootNode selection: selectedNode panels: panels
	| browser |
	browser _ self basicNew initialize.
	panels do: [:ea | browser addPanel: ea].
	browser setMetaNode: metaNode node: rootNode.
	selectedNode ifNotNil: [browser jumpTo: selectedNode].
	^ browser! !

!OBBrowser class methodsFor: 'instance creation' stamp: 'avi 9/16/2005 23:25'!
new
	^ self 
		metaNode: self defaultMetaNode
		root: self defaultRootNode
		selection: nil
		panels: self panels! !

!OBBrowser class methodsFor: 'instance creation' stamp: 'cwp 12/5/2004 15:26'!
root: aNode 
	^ self root: aNode selection: nil! !

!OBBrowser class methodsFor: 'instance creation' stamp: 'avi 9/16/2005 23:25'!
root: rootNode selection: selectedNode
	^ self metaNode: self defaultMetaNode root: rootNode selection: selectedNode panels: self panels! !

!OBBrowser class methodsFor: 'instance creation' stamp: 'cwp 12/6/2004 22:04'!
selection: selectedNode
	^ self root: self defaultRootNode selection: selectedNode! !

Object subclass: #OBButtonModel
	instanceVariableNames: 'bar label'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBButtonModel commentStamp: 'cwp 3/5/2004 12:15' prior: 0!
An OBButtonModel serves as a model for PluggableButtonMorphs used OBRadioButtonBar. OBRadioButtonBar cannot be a direct model for its PBMs, since it can contain a variable number of buttons.

iVars:

bar		- the OBRadioButton bar to which this button belongs
label	- the label of the button!


!OBButtonModel methodsFor: 'accessing' stamp: 'cwp 2/24/2004 18:29'!
bar: aRadioButtonBar
	bar _ aRadioButtonBar! !

!OBButtonModel methodsFor: 'accessing' stamp: 'cwp 3/2/2004 21:46'!
label
	^ label! !

!OBButtonModel methodsFor: 'accessing' stamp: 'cwp 2/24/2004 18:29'!
label: aString
	label _ aString! !

!OBButtonModel methodsFor: 'accessing' stamp: 'cwp 11/27/2004 00:50'!
selectionChanged
	self changed: #isSelected.
	self changed: #labelMorph! !


!OBButtonModel methodsFor: 'callbacks' stamp: 'cwp 2/24/2004 18:42'!
isSelected
	^ bar isSelected: self! !

!OBButtonModel methodsFor: 'callbacks' stamp: 'cwp 2/28/2006 10:45'!
labelMorph
	^ (StringMorph 
		contents: self label 
		font: TextStyle defaultFont)
			color: (self isEnabled ifTrue: [Color black] ifFalse: [Color gray]);
			yourself! !

!OBButtonModel methodsFor: 'callbacks' stamp: 'cwp 2/24/2004 19:30'!
push
	bar push: self.! !


!OBButtonModel methodsFor: 'morphs' stamp: 'lr 3/23/2006 18:08'!
morph
	| morph |
	morph := PluggableButtonMorph
		on: self
		getState: #isSelected
		action: #push
		label: #labelMorph.
	morph 
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	^ morph! !


!OBButtonModel methodsFor: 'testing' stamp: 'cwp 11/27/2004 19:09'!
isEnabled
	^ bar isEnabled: self! !

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

OBButtonModel class
	instanceVariableNames: ''!

!OBButtonModel class methodsFor: 'as yet unclassified' stamp: 'cwp 8/29/2004 13:31'!
offColor
	^ Color lightGray twiceLighter! !

!OBButtonModel class methodsFor: 'as yet unclassified' stamp: 'cwp 8/29/2004 13:30'!
onColor
	^ Color lightGray lighter! !

!OBButtonModel class methodsFor: 'as yet unclassified' stamp: 'cwp 2/24/2004 18:35'!
withLabel: aString inBar: aRadioButtonBar
	^ self new label: aString; bar: aRadioButtonBar! !
OBActor subclass: #OBCategoryActor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Services'!
!OBCategoryActor commentStamp: 'cwp 1/7/2005 23:43' prior: 0!
OBCategory actor implements a number of actions useful for manipulating both class and method categories.!


!OBCategoryActor methodsFor: 'public' stamp: 'cwp 7/10/2006 21:33'!
actionsForNode: aNode
	^ Array
		with: (OBAction
				label: 'remove'
				receiver: self
				selector: #remove:
				arguments: {aNode}
				keystroke: $x
				icon: self deleteIcon)
		with: (OBAction
				label: 'rename...'
				receiver: self
				selector: #rename:
				arguments: {aNode})! !

!OBCategoryActor methodsFor: 'public' stamp: 'cwp 1/9/2005 11:30'!
actionsForParent: aNode
	| actions |
	actions _ self stdActionsForParent: aNode.
	aNode organization 
			isClassOrganizer ifTrue: [actions _ actions copyWith: (self categorizeActionFor: aNode)].
	^ actions! !


!OBCategoryActor methodsFor: 'actions' stamp: 'cwp 9/18/2005 19:20'!
alphabetizeCategoriesIn: aNode 
	aNode organization sortCategories.
	aNode signalChildrenChanged! !

!OBCategoryActor methodsFor: 'actions' stamp: 'cwp 9/18/2004 22:53'!
categorizeIn: aClassOrganizer 
	"Categorize methods by looking in parent classes for a method category."
	| organizers |
	organizers := aClassOrganizer subject withAllSuperclasses collect: [:ea | ea organization].
	(aClassOrganizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found |
		found := (organizers collect: [ :org | org categoryOfElement: sel])
			detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]]
			ifNone: [].
		found ifNotNil: [aClassOrganizer classify: sel under: found]]! !

!OBCategoryActor methodsFor: 'actions' stamp: 'cwp 9/20/2005 08:40'!
createIn: aNode
	| catName organization |
	organization := aNode organization.
	catName := OBTextRequest 
					prompt: 'Please type new category name' 
					template: (self categoryTemplateFor: organization).
	catName ifNotNil:	[organization addCategory: catName.
						(aNode categoryNodeNamed: catName) signalSelection].! !

!OBCategoryActor methodsFor: 'actions' stamp: 'cwp 9/18/2004 21:55'!
removeEmptyCategoriesIn: anOrganizer 
	anOrganizer removeEmptyCategories! !

!OBCategoryActor methodsFor: 'actions' stamp: 'cwp 9/19/2004 00:11'!
remove: aNode
	| list choice |
	list := aNode container organization listAtCategoryNamed: aNode name.
	list isEmpty ifTrue: [^ aNode remove].
	choice := OBConfirmationRequest prompt: 'Are you sure you want to
remove this category 
and all its elements?' confirm: 'Remove'.
	choice ifTrue: [^ aNode remove]! !

!OBCategoryActor methodsFor: 'actions' stamp: 'cwp 9/18/2005 18:51'!
rename: aNode
	| category |
	category := OBTextRequest
				prompt: 'Please type new category name' 
				template: aNode name.
	category ifNotNil:	
		[aNode container organization renameCategory: aNode name toBe: category.
		aNode signalChanged]! !

!OBCategoryActor methodsFor: 'actions' stamp: 'cwp 6/4/2006 18:56'!
reorganizeCategoriesIn: anOrganizer
	| definition |
	definition _ OBOrganizationDefinition on: anOrganizer.
	definition signalChange.! !


!OBCategoryActor methodsFor: 'private' stamp: 'cwp 9/18/2004 23:52'!
categorizeActionFor: aNode
	^ OBAction
		label: 'categorize automatically'
		receiver: self
		selector: #categorizeIn:
		arguments: (Array with: aNode organization)! !

!OBCategoryActor methodsFor: 'private' stamp: 'cwp 6/25/2006 17:36'!
categoryTemplateFor: anOrganization
	^ anOrganization isClassOrganizer
		ifTrue: ['category name']
		ifFalse: ['Category-Name']! !

!OBCategoryActor methodsFor: 'private' stamp: 'cwp 7/10/2006 21:49'!
stdActionsForParent: aNode
	^ Array
		with: (OBAction 
				label: 'create category...'
				receiver: self
				selector: #createIn:
				arguments: (Array with: aNode)
				icon: self newIcon)
		with: (OBAction
				label: 'alphabetize categories'
				receiver: self
				selector: #alphabetizeCategoriesIn:
				arguments: (Array with: aNode))
		with: (OBAction
				label: 'remove empty categories'
				receiver: self
				selector: #removeEmptyCategoriesIn:
				arguments: (Array with: aNode organization))
		with: (OBAction
				label: 'reorganize categories'
				receiver: self
				selector: #reorganizeCategoriesIn:
				arguments: (Array with: aNode organization))
! !
Object subclass: #OBCategoryServant
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Services'!

!OBCategoryServant methodsFor: 'private' stamp: 'cwp 6/25/2006 17:32'!
categoryTemplateFor: anOrganization
	^ anOrganization isClassOrganizer
		ifTrue: ['category name']
		ifFalse: ['Category-Name']! !


!OBCategoryServant methodsFor: 'actions' stamp: 'cwp 6/29/2006 00:13'!
createCategory: aRequestor
	| catName organization node |
	node _ aRequestor requestCurrentNode.
	organization _ node organization.
	catName _ OBTextRequest 
					prompt: 'Please type new category name' 
					template: (self categoryTemplateFor: organization).
	catName ifNotNil:	[organization addCategory: catName.
						aRequestor select: (node categoryNodeNamed: catName)].! !


!OBCategoryServant methodsFor: 'accessing' stamp: 'cwp 6/25/2006 17:25'!
services
	| selectors |
	selectors _ self class organization listAtCategoryNamed: 'services'.
	^ selectors collect: [:ea | self perform: ea].
	! !


!OBCategoryServant methodsFor: 'services' stamp: 'cwp 6/30/2006 00:51'!
svcCreateCategory
	^ (OBService action: (MessageSend receiver: self selector: #createCategory:))
		condition: [:req | req requestNode hasOrganization];
		label: 'create category...'! !
OBAnnouncement subclass: #OBChildrenChanged
	instanceVariableNames: 'node'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBChildrenChanged methodsFor: 'as yet unclassified' stamp: 'cwp 6/5/2006 00:49'!
node
	^ node! !

!OBChildrenChanged methodsFor: 'as yet unclassified' stamp: 'cwp 6/5/2006 00:49'!
node: aNode
	node _ aNode! !

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

OBChildrenChanged class
	instanceVariableNames: ''!

!OBChildrenChanged class methodsFor: 'as yet unclassified' stamp: 'cwp 6/5/2006 00:49'!
node: aNode
	^ self new node: aNode! !
OBInteractionRequest subclass: #OBChoiceRequest
	instanceVariableNames: 'prompt labels values lines'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Notifications'!
!OBChoiceRequest commentStamp: 'cwp 3/5/2004 12:26' prior: 0!
This notification is used to ask the user for to choose from a list of alternatives. Its defaultAction is to open a PopUpMenu. Test cases an intercept the notification and respond programmatically.

prompt	- A string describing the choice the user is asked to make.
labels	- A list of strings describing the alternatives.
values	- When the user chooses an alternative, the corresponding item from this list is returned!


!OBChoiceRequest methodsFor: 'initializing' stamp: 'cwp 7/9/2006 00:05'!
setPrompt: aString labels: labelArray values: valueArray lines: lineArray
	prompt _ aString.
	labels _ labelArray.
	values _ valueArray.
	lines _ lineArray.! !


!OBChoiceRequest methodsFor: 'signaling' stamp: 'cwp 7/9/2006 00:09'!
defaultAction
	^ values 
		at: ((PopUpMenu labelArray: labels lines: lines) startUpWithCaption: prompt)
		ifAbsent: [nil]! !


!OBChoiceRequest methodsFor: 'accessing' stamp: 'cwp 7/8/2006 23:45'!
labels
	^ labels! !

!OBChoiceRequest methodsFor: 'accessing' stamp: 'cwp 7/9/2006 00:11'!
lines
	^ lines! !

!OBChoiceRequest methodsFor: 'accessing' stamp: 'cwp 7/8/2006 23:45'!
prompt
	^ prompt! !

!OBChoiceRequest methodsFor: 'accessing' stamp: 'cwp 7/8/2006 23:45'!
values
	^ values! !

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

OBChoiceRequest class
	instanceVariableNames: ''!

!OBChoiceRequest class methodsFor: 'signalling' stamp: 'cwp 7/9/2006 00:07'!
labels: anArray
	^ self
		prompt: nil
		labels: anArray
		values: anArray
		lines: #()! !

!OBChoiceRequest class methodsFor: 'signalling' stamp: 'cwp 7/9/2006 00:08'!
labels: labelArray lines: lineArray
	^ self
		prompt: nil
		labels: labelArray
		values: labelArray
		lines: lineArray! !

!OBChoiceRequest class methodsFor: 'signalling' stamp: 'cwp 7/9/2006 00:06'!
prompt: aString labels: labelArray values: valueArray
	^ self
		prompt: aString
		labels: labelArray
		 values: valueArray
		lines: #()! !

!OBChoiceRequest class methodsFor: 'signalling' stamp: 'cwp 7/9/2006 00:05'!
prompt: aString labels: labelArray values: valueArray lines: lineArray
	^ (self new 
		setPrompt: aString 
		labels: labelArray 
		values: valueArray 
		lines: lineArray) 
			signal! !
OBActor subclass: #OBClassActor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Services'!
!OBClassActor commentStamp: 'cwp 1/7/2005 23:44' prior: 0!
OBClassActor provides basic actions for manipulating classes.!


!OBClassActor methodsFor: 'querying' stamp: 'cwp 7/10/2006 22:35'!
actionsForNode: aClassNode
	^ {OBAction
			label: 'remove' 
			receiver: self
			selector: #remove:
			arguments: {aClassNode}
			keystroke: $x 
			icon: self deleteIcon.
		OBAction
			label: 'rename...' 
			receiver: self
			selector: #rename:
			arguments: {aClassNode}.
		OBAction
			label: 'copy...' 
			receiver: self
			selector: #copy:
			arguments: {aClassNode}.
		OBAction
			label: 'subclass template'
			receiver: self
			selector: #subclassTemplate:
			arguments: {aClassNode}.
		OBAction
			label: 'browse references'
			receiver: self
			selector: #browseReferences:
			arguments: {aClassNode}
	}! !


!OBClassActor methodsFor: 'private' stamp: 'lr 3/28/2006 12:05'!
browseObsoleteRefs: aClassNode as: oldName 
	| binding |
	binding := aClassNode theNonMetaClass environment 
				associationAt: aClassNode theNonMetaClass name.
	(SystemNavigation default allCallsOn: binding) isEmpty 
		ifFalse: [OBReferencesBrowser
					browseRoot: aClassNode
					title: 'Obsolete references to']! !

!OBClassActor methodsFor: 'private' stamp: 'cwp 7/8/2006 13:59'!
copyClass: oldClass as: newName
	| oldDefinition newDefinition newClass |
	(oldClass environment hasClassNamed: newName)
		ifTrue: [^self error: newName, ' already exists'].
	oldDefinition := oldClass definition.
	newDefinition := oldDefinition 
						copyReplaceAll: '#' , oldClass name asString 
						with: '#' , newName asString.
	Cursor wait 
		showWhile: [newClass := Compiler evaluate: newDefinition logged: true.
					newClass copyAllCategoriesFrom: oldClass.
					newClass class copyAllCategoriesFrom: oldClass class].
	^ newClass! !


!OBClassActor methodsFor: 'actions' stamp: 'lr 3/28/2006 12:10'!
browseReferences: aClassNode 
	OBReferencesBrowser browseRoot: aClassNode theNonMetaClass asNode! !

!OBClassActor methodsFor: 'actions' stamp: 'dvf 8/31/2005 13:11'!
copy: aClassNode
	| newName newClass |
	newName := OBTextRequest
			prompt: 'Please type new class name'
			template: aClassNode theNonMetaClassName asString.
	newName ifNotNil:	[newClass := self
										copyClass: aClassNode theNonMetaClass 
										as: newName asSymbol.
						(newClass asNode) signalSelection].! !

!OBClassActor methodsFor: 'actions' stamp: 'lr 3/28/2006 12:04'!
remove: aClassNode
	(OBConfirmationRequest
		prompt: 'Are you certain that you 
want to REMOVE the class ', aClassNode theNonMetaClassName, ' from the system?'
		confirm: 'Remove')
			ifTrue: [aClassNode theNonMetaClass removeFromSystem.
					aClassNode signalDeletion]! !

!OBClassActor methodsFor: 'actions' stamp: 'lr 3/28/2006 12:05'!
rename: aClassNode
	| newName |
	newName := OBTextRequest
					prompt: 'Please type new class name' 
					template: aClassNode theNonMetaClassName asString.
	newName ifNotNil:	[ | oldName |
						oldName := aClassNode theNonMetaClass name.
						aClassNode theNonMetaClass environment 
							renameClassNamed: oldName
							as: newName asSymbol.
						self browseObsoleteRefs: aClassNode as: oldName].
	! !

!OBClassActor methodsFor: 'actions' stamp: 'cwp 6/4/2006 18:53'!
subclassTemplate: aClassNode 
	| class definition |
	class _ aClassNode theNonMetaClass.
	definition _ (OBClassDefinition 
					environment: class environment 
					template: (Class 
								templateForSubclassOf: class 
								category: class category)).
	definition signalChange.! !
OBCodeNode subclass: #OBClassAwareNode
	instanceVariableNames: 'theClass superior'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBClassAwareNode commentStamp: 'cwp 1/8/2005 11:23' prior: 0!
OBClassAware node models program elements that are part of a class. It provides methods for manipulating the class, as well as methods relating to sorting according to class hierarchy.

iVars

theClass 	- the class that this node is part of
superior 	- during hierarchical sorting this refers to the nearest superclass
			  that belongs to the group being sorted!


!OBClassAwareNode methodsFor: 'superiors' stamp: 'cwp 12/11/2004 22:04'!
adoptSuperior: other 
	| descent |
	descent := self theClass allSuperclasses reversed.
	(descent indexOf: other theClass) > (descent indexOf: self superiorClass) 
		ifTrue: [superior := other]! !

!OBClassAwareNode methodsFor: 'superiors' stamp: 'cwp 12/11/2004 22:04'!
sortsBefore: aClassNode
	| own other |
	own := self withSuperiors.
	other := aClassNode withSuperiors.
	1 	to: (own size min: other size)
		do: [:i | (own at: i) == (other at: i) ifFalse: 
				[^ (own at: i) theClassName <= (other at: i) theClassName]].
	^ other includes: self
	! !

!OBClassAwareNode methodsFor: 'superiors' stamp: 'cwp 12/11/2004 22:03'!
superior
	^ superior! !

!OBClassAwareNode methodsFor: 'superiors' stamp: 'cwp 12/11/2004 22:03'!
superiorClass
	^superior ifNotNil: [superior theClass]! !

!OBClassAwareNode methodsFor: 'superiors' stamp: 'cwp 12/11/2004 22:03'!
superiors
	| result |
	result := OrderedCollection new.
	self superiorsDo: [:ea | result add: ea].
	^ result asArray reversed! !

!OBClassAwareNode methodsFor: 'superiors' stamp: 'cwp 12/11/2004 22:03'!
superiorsDo: aBlock
	| cursor |
	cursor := superior.
	[cursor isNil] whileFalse:
		[aBlock value: cursor.
		cursor := cursor superior]! !

!OBClassAwareNode methodsFor: 'superiors' stamp: 'dvf 8/16/2005 17:23'!
superior: other 
	superior := other! !

!OBClassAwareNode methodsFor: 'superiors' stamp: 'cwp 12/11/2004 22:03'!
withSuperiors
	| result |
	result := OrderedCollection new.
	result add: self.
	self superiorsDo: [:ea | result add: ea].
	^ result asArray reversed! !


!OBClassAwareNode methodsFor: 'actions' stamp: 'lr 3/6/2006 19:24'!
browse
	OBSystemBrowser openOnClass: self theNonMetaClass! !

!OBClassAwareNode methodsFor: 'actions' stamp: 'lr 3/6/2006 19:22'!
browseHierarchically
	OBHierarchyBrowser openOnClass: self theNonMetaClass! !

!OBClassAwareNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 23:10'!
browseHierarchyAction
	^ self 
		action: #browseHierarchically 
		buttonLabel: 'hierarchy' 
		menuLabel: 'browse hierarchy'.
! !

!OBClassAwareNode methodsFor: 'actions' stamp: 'avi 9/17/2005 01:34'!
chaseVars
	OBVariablesBrowser browseRoot: self classNode! !


!OBClassAwareNode methodsFor: 'nodes' stamp: 'dvf 8/31/2005 13:11'!
classNode
	^self theClass asNode! !


!OBClassAwareNode methodsFor: 'displaying' stamp: 'dvf 8/17/2005 14:59'!
indent
	| size indent |
	size := 0.
	self superiorsDo: [:ea | size := size + 1].
	indent := Text new: size * 2.
	indent atAllPut: $ .
	^ indent! !

!OBClassAwareNode methodsFor: 'displaying' stamp: 'cwp 1/7/2005 22:21'!
indentedName
	^ self indent, self name! !


!OBClassAwareNode methodsFor: 'ancestry' stamp: 'cwp 12/5/2004 12:56'!
isDescendantOfClassCat: aClassCategoryNode

	"optimized version: sending #category to the class is slow"
	^ (self theNonMetaClass environment organization 
		listAtCategoryNamed: aClassCategoryNode name)
			includes: self theNonMetaClassName

! !

!OBClassAwareNode methodsFor: 'ancestry'!
isDescendantOfClass: aClassNode
	^ self theClassName = aClassNode theClassName! !


!OBClassAwareNode methodsFor: 'accessing'!
theClass
	^ theClass! !

!OBClassAwareNode methodsFor: 'accessing'!
theClassName
	^ self theClass name! !

!OBClassAwareNode methodsFor: 'accessing'!
theClass: aClass
	theClass := aClass! !

!OBClassAwareNode methodsFor: 'accessing'!
theMetaClass
	^ self theClass theMetaClass! !

!OBClassAwareNode methodsFor: 'accessing'!
theNonMetaClass
	^ self theClass theNonMetaClass! !

!OBClassAwareNode methodsFor: 'accessing'!
theNonMetaClassName
	^ self theNonMetaClass name! !

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

OBClassAwareNode class
	instanceVariableNames: ''!

!OBClassAwareNode class methodsFor: 'sorting' stamp: 'cwp 12/12/2004 22:13'!
sortHierarchically: nodes
	nodes do: [:a | nodes do: [:b | a adoptSuperior: b]].
	nodes sort: [:a : b | a sortsBefore: b].
	^ nodes! !
OBCodeNode subclass: #OBClassCategoryNode
	instanceVariableNames: 'environment name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBClassCategoryNode commentStamp: 'cwp 1/8/2005 12:58' prior: 0!
OBClassCategory represents a system category in the image's SystemOrganization.!


!OBClassCategoryNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 22:40'!
actions
	^ {
		self action: #fileOut withLabel: 'file out'.
		self browseAction.
	}
! !

!OBClassCategoryNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 21:44'!
browse
	OBSystemBrowser openOnEnvironment: environment category: name! !

!OBClassCategoryNode methodsFor: 'actions'!
fileOut
	environment organization fileOutCategory: name.! !

!OBClassCategoryNode methodsFor: 'actions'!
printOut
	environment organization fileOutCategory: name asHtml: true! !

!OBClassCategoryNode methodsFor: 'actions' stamp: 'cwp 9/19/2004 00:11'!
remove
	environment organization removeSystemCategory: name.
	self signalDeletion! !


!OBClassCategoryNode methodsFor: 'ancestry'!
ancestrySelector
	^ #isDescendantOfClassCat:! !

!OBClassCategoryNode methodsFor: 'ancestry'!
isDescendantOfClassCat: other
	^ other name = name! !


!OBClassCategoryNode methodsFor: 'navigating' stamp: 'dvf 8/15/2005 17:31'!
classes
	^ self classNames collect: [:ea | (environment at: ea) asNode]! !

!OBClassCategoryNode methodsFor: 'navigating' stamp: 'cwp 12/12/2004 22:12'!
classesHierarchically
	^ OBClassAwareNode sortHierarchically: self classes! !

!OBClassCategoryNode methodsFor: 'navigating' stamp: 'dvf 8/17/2005 17:25'!
comments
	^ self classNames collect: [:ea | (environment at: ea) asCommentNode ]! !

!OBClassCategoryNode methodsFor: 'navigating' stamp: 'cwp 12/12/2004 22:19'!
commentsHierarchically
	^ OBClassAwareNode sortHierarchically: self comments! !

!OBClassCategoryNode methodsFor: 'navigating' stamp: 'dvf 8/15/2005 17:52'!
metaclasses
	^self classNames collect: [:ea | (environment at: ea) asClassSideNode]! !

!OBClassCategoryNode methodsFor: 'navigating' stamp: 'cwp 12/12/2004 22:19'!
metaclassesHierarchically
	^ OBClassAwareNode sortHierarchically: self metaclasses! !


!OBClassCategoryNode methodsFor: 'private'!
classNames
	^ environment organization listAtCategoryNamed: name! !


!OBClassCategoryNode methodsFor: 'accessing' stamp: 'cwp 9/22/2004 22:13'!
container
	^ environment! !


!OBClassCategoryNode methodsFor: 'displaying'!
definition
	^ OBClassDefinition 
		environment: environment 
		template: ((environment at: #Class) template: name)! !

!OBClassCategoryNode methodsFor: 'displaying'!
name
	^ name! !

!OBClassCategoryNode methodsFor: 'displaying'!
text
	^ 'Object subclass: #NameOfSubclass
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''', self name, ''''! !


!OBClassCategoryNode methodsFor: 'drag and drop'!
dropSelector
	^ #dropOnClassCategory:! !


!OBClassCategoryNode methodsFor: 'class creation'!
isRedefinedBy: definition
	"No class is selected, so the definition can't be a redefinition."
	
	^ false! !


!OBClassCategoryNode methodsFor: 'initializing'!
setName: aString
	self setName: aString environment: self class environment! !

!OBClassCategoryNode methodsFor: 'initializing'!
setName: aString environment: anEnvironment
	name := aString asSymbol.
	environment := anEnvironment! !


!OBClassCategoryNode methodsFor: 'testing' stamp: 'cwp 6/30/2006 00:42'!
hasOrganization
	^ true! !

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

OBClassCategoryNode class
	instanceVariableNames: ''!

!OBClassCategoryNode class methodsFor: 'actions'!
actionsForParent: aNode
	^ Array with: (OBAction
						label: 'find class...'
						receiver: self
						selector: #findClassIn:
						arguments: (Array with: aNode environment)
						keystroke: $f)
! !

!OBClassCategoryNode class methodsFor: 'actions' stamp: 'dvf 8/31/2005 11:33'!
findClassIn: anEnvironment
	| pattern class |
	pattern := OBTextRequest 
					prompt: 'Please type the name or fragment to look for' 
					template: ''.
	pattern ifNil: [^self].
	class := self findClassIn: anEnvironment pattern: pattern.
	class ifNotNil: [(class asNode) signalSelection].! !

!OBClassCategoryNode class methodsFor: 'actions' stamp: 'cwp 7/14/2006 14:37'!
findClassIn: anEnvironment pattern: pattern
	| classNames className toMatch potentialClassNames |
	toMatch := (pattern copyWithout: $.) asLowercase.
	potentialClassNames := (anEnvironment classNames , anEnvironment traitNames) asArray.
	classNames := (pattern endsWith: '.')
					ifTrue: [potentialClassNames
							select: [:nm | nm asLowercase = toMatch]]
					ifFalse: [potentialClassNames
							select: [:n | n includesSubstring: toMatch caseSensitive: false]].
	classNames size = 0 ifTrue: [^ nil].
	classNames size = 1 ifTrue: [^ anEnvironment at: classNames first asSymbol].
	className := self userSelectionOf: classNames for: toMatch.
	^ className ifNotNil: [anEnvironment at: className asSymbol]
! !

!OBClassCategoryNode class methodsFor: 'actions' stamp: 'cwp 7/9/2006 00:10'!
userSelectionOf: classNames for: toMatch 
	| exactMatch labels lines |
	exactMatch := classNames detect: [:ea | ea asLowercase = toMatch] ifNone: [nil].
	exactMatch 
		ifNil: [labels _ classNames. lines _ #()]
		ifNotNil: [labels _ classNames copyWithFirst: exactMatch. lines _ #(1)].
	^ OBChoiceRequest labels: labels lines: lines.! !


!OBClassCategoryNode class methodsFor: 'instance creation'!
on: aString
	^ self new setName: aString! !

!OBClassCategoryNode class methodsFor: 'instance creation'!
on: aString inEnvironment: anEnvironment
	^ self new setName: aString environment: anEnvironment! !
OBClassAwareNode subclass: #OBClassCommentNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBClassCommentNode commentStamp: 'cwp 1/8/2005 11:24' prior: 0!
OBClassCommentNode represents the comment attached to a particular class. !


!OBClassCommentNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 23:03'!
actions
	^ {
		self browseAction.
		self browseHierarchyAction.
		self action: #chaseVars buttonLabel: 'variables' menuLabel: 'chase variables'
	}! !


!OBClassCommentNode methodsFor: 'public' stamp: 'cwp 12/13/2004 00:51'!
name
	^ self theClass name! !


!OBClassCommentNode methodsFor: 'initializing'!
setClass: aClass
	self theClass: aClass! !


!OBClassCommentNode methodsFor: 'definition'!
text
	^ self theClass comment! !

!OBClassCommentNode methodsFor: 'definition'!
text: aText
	self theClass comment: aText stamp: Utilities changeStamp.
	^ true! !

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

OBClassCommentNode class
	instanceVariableNames: ''!

!OBClassCommentNode class methodsFor: 'as yet unclassified'!
on: classRef
	^ self new setClass: classRef! !
OBDefinition subclass: #OBClassDefinition
	instanceVariableNames: 'environment template'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Definitions'!
!OBClassDefinition commentStamp: 'cwp 1/8/2005 13:13' prior: 0!
OBClassDefinition presents a textual interface for examining, modifying and creating classes. Given a class, it knows how to display the definition expression that reflects it's current state, and knows how to create or modify a class given a definition expression.

OBClassDefinition implements a number of safety checks when defining or redefining classes, to ensure that existing classes are not accidentally overwritten.!


!OBClassDefinition methodsFor: 'callbacks'!
accept: aText notifying: aController
	^ self defineClass: aText notifying: aController! !

!OBClassDefinition methodsFor: 'callbacks'!
selection
	^ 1 to: 0! !

!OBClassDefinition methodsFor: 'callbacks'!
text
	^ template! !


!OBClassDefinition methodsFor: 'confirmation'!
confirmDefinition: definition
	"Check to make sure the user isn't accidentally over-writing an existing class."
	
	(((self isRedefinition: definition) not) and: [self definedClassExists: definition])
		ifTrue: [^ self confirmRedefinition: definition]
		ifFalse: [^ true]! !

!OBClassDefinition methodsFor: 'confirmation'!
confirmRedefinition: definition
	| newName prompt |
	newName := self nameOfClassDefinedBy: definition.
	prompt := (newName, ' is an existing class in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText.
	^ OBConfirmationRequest
		prompt: prompt
		confirm: 'Redefine'! !

!OBClassDefinition methodsFor: 'confirmation'!
definedClassExists: definition
	^ environment hasClassNamed: (self nameOfClassDefinedBy: definition)! !

!OBClassDefinition methodsFor: 'confirmation'!
isRedefinition: aDefinition
	^ (self nameOfClassDefinedBy: aDefinition) = (self nameOfClassDefinedBy: template)! !

!OBClassDefinition methodsFor: 'confirmation'!
nameOfClassDefinedBy: definition
	^ (Scanner new scanTokens: definition) third! !

!OBClassDefinition methodsFor: 'confirmation' stamp: 'cwp 10/18/2004 00:13'!
selectedClass
	^ environment at: (self nameOfClassDefinedBy: template) ifAbsent: [nil]! !


!OBClassDefinition methodsFor: 'class definition'!
defineClass: definition notifying: aController
	| evaluator newClass |
	(self confirmDefinition: definition) ifFalse: [^ false].
	evaluator := self evaluatorForDefinition: definition.
	newClass := evaluator
				evaluate: definition
				notifying: aController
				logged: true.
	newClass ifNil: [^ false].
	self signalSelectionOf: newClass.
	^ true
! !

!OBClassDefinition methodsFor: 'class definition'!
evaluatorForDefinition: definition
	| tokens |
	tokens := Scanner new scanTokens: definition.
	^ (environment at: tokens first ifAbsent: [nil]) subclassDefinerClass! !

!OBClassDefinition methodsFor: 'class definition' stamp: 'cwp 10/23/2005 14:42'!
signalSelectionOf: aClass
	aClass asNode demandSelection! !


!OBClassDefinition methodsFor: 'initializing'!
setEnvironment: anEnvironment template: aText
	environment := anEnvironment.
	template := aText.! !

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

OBClassDefinition class
	instanceVariableNames: ''!

!OBClassDefinition class methodsFor: 'instance creation'!
environment: anEnvironment template: aString 
	^ self new setEnvironment: anEnvironment template: aString! !
OBClassAwareNode subclass: #OBClassNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBClassNode commentStamp: 'cwp 1/8/2005 11:27' prior: 0!
OBClassNode wraps a class for display in various types of code browsers. It provides many navigation methods for the different types of browsers where classes may appear.!


!OBClassNode methodsFor: 'actions' stamp: 'cwp 7/10/2006 22:33'!
actions
	^ {
		self action: #findMethod 
			withLabel: 'find method...' 
			withKeystroke: $f 
			withIcon: (MenuIcons tryIcons: #(findIcon smallFindIcon)).
		self action: #fileOut withLabel: 'file out'.
		self browseAction.
		self browseHierarchyAction.
		self action: #chaseVars buttonLabel: 'variables' menuLabel: 'chase variables'.
		self action: #inspectInstances withLabel: 'inspect instances'.
		self action: #inspectSubInstances withLabel: 'inspect subinstances'
	}! !

!OBClassNode methodsFor: 'actions' stamp: 'cwp 10/26/2004 00:49'!
fileOut
	self theNonMetaClass fileOut! !

!OBClassNode methodsFor: 'actions'!
findMethod
	| selectors selection |
	selectors := self theClass selectors asSortedArray.
	selectors isEmpty ifTrue: [^nil].
	selection := OBChoiceRequest labels: selectors.
	selection ifNotNil: [(OBMethodNode 
									on: selection
									inClass: self theClass) signalSelection].! !

!OBClassNode methodsFor: 'actions'!
inspectInstances
	self theNonMetaClass inspectAllInstances! !

!OBClassNode methodsFor: 'actions'!
inspectSubInstances
	self theNonMetaClass inspectSubInstances! !


!OBClassNode methodsFor: 'navigating' stamp: 'cwp 1/7/2005 23:05'!
allCategory
	^ Array with: (OBAllMethodCategoryNode on: self theClass)! !

!OBClassNode methodsFor: 'navigating' stamp: 'cwp 1/7/2005 23:06'!
categories
	^ self theClass organization categories
		collect: [:cat | OBMethodCategoryNode on: cat inClass: self theClass]
			! !

!OBClassNode methodsFor: 'navigating' stamp: 'cwp 12/12/2004 23:31'!
classHierarchy
	^ self nodeHierarchyWithClass: OBClassNode! !

!OBClassNode methodsFor: 'navigating'!
classVariables
	^ self theClass allClassVarNames asArray sort
		collect: [:ea | OBClassVariableNode on: ea inClass: self theClass]! !

!OBClassNode methodsFor: 'navigating' stamp: 'cwp 12/12/2004 23:31'!
commentHierarchy
	^ self nodeHierarchyWithClass: OBClassCommentNode! !

!OBClassNode methodsFor: 'navigating'!
instanceVariables
	^ self theClass allInstVarNames asArray sort
		collect: [:ea | OBInstanceVariableNode on: ea inClass: self theClass]! !

!OBClassNode methodsFor: 'navigating' stamp: 'cwp 12/12/2004 23:30'!
metaclassHierarchy
	^ self nodeHierarchyWithClass: OBMetaclassNode! !

!OBClassNode methodsFor: 'navigating' stamp: 'cwp 12/12/2004 23:30'!
nodeHierarchyWithClass: aClass
	^ OBClassAwareNode sortHierarchically: 
		(self surroundingHierarchy collect: [:ea | aClass on: ea])! !

!OBClassNode methodsFor: 'navigating' stamp: 'cwp 12/8/2004 23:45'!
users
	^ (SystemNavigation default allCallsOn: (theClass environment associationAt: theClass name))
		collect: [:ref | OBClassRefNode on: self name inMethod: ref]! !


!OBClassNode methodsFor: 'ancestry'!
ancestrySelector
	^ #isDescendantOfClass:! !


!OBClassNode methodsFor: 'nodes' stamp: 'cwp 9/20/2005 08:42'!
categoryNodeNamed: aString 
	^ OBMethodCategoryNode on: aString inClass: theClass! !

!OBClassNode methodsFor: 'nodes'!
classCategoryNode
	^ OBClassCategoryNode 
		on: self theNonMetaClass category
		inEnvironment: self theClass environment! !


!OBClassNode methodsFor: 'accessing'!
definition
	^ OBClassDefinition 
		environment: self theClass environment 
		template: self theClass definition! !

!OBClassNode methodsFor: 'accessing'!
organization
	^ self theClass organization! !

!OBClassNode methodsFor: 'accessing' stamp: 'cwp 12/12/2004 23:27'!
surroundingHierarchy
	 ^ (self theClass withAllSuperclasses union: self theClass allSubclasses)
		asArray! !

!OBClassNode methodsFor: 'accessing' stamp: 'cwp 12/12/2004 22:45'!
= other
	self species = other species ifFalse: [^ false].
	^ self theClass = other theClass! !


!OBClassNode methodsFor: 'drag and drop' stamp: 'lr 3/28/2006 18:29'!
dropOnClassCategory: aNode
	self theNonMetaClass category: aNode name.
	self signalSelection.
	^ true! !

!OBClassNode methodsFor: 'drag and drop' stamp: 'lr 4/6/2006 11:31'!
dropSelector
	^ #dropOnClass:! !


!OBClassNode methodsFor: 'displaying' stamp: 'cwp 12/13/2004 00:51'!
name
	^ self theClass name! !

!OBClassNode methodsFor: 'displaying'!
title
	^ self name! !


!OBClassNode methodsFor: 'printing' stamp: 'cwp 12/10/2004 23:53'!
printOn: aStream
	aStream
		print: self class;
		nextPut: $<;
		print: self theClass;
		nextPut: $>! !


!OBClassNode methodsFor: 'initializing'!
setClass: aClass
	self theClass: aClass! !


!OBClassNode methodsFor: 'testing' stamp: 'cwp 6/30/2006 00:57'!
hasOrganization
	^ true! !

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

OBClassNode class
	instanceVariableNames: ''!

!OBClassNode class methodsFor: 'instance creation' stamp: 'cwp 11/30/2004 21:06'!
on: aClass 
	^ self new setClass: aClass ! !
OBMethodNode subclass: #OBClassRefNode
	instanceVariableNames: 'className'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBClassRefNode commentStamp: 'cwp 1/8/2005 12:38' prior: 0!
Each instance of OBClassRefNode refers to a reference to a particular class from the source code of a method. It's used in the OBListBrowser created by the 'browse references' class action.!


!OBClassRefNode methodsFor: 'accessing' stamp: 'cwp 12/8/2004 22:14'!
name
	^ className! !

!OBClassRefNode methodsFor: 'accessing' stamp: 'cwp 12/1/2004 01:16'!
selection
	| start parser |
	(parser _ Compiler parserClass new) parseSelector: self source.
	start := parser endOfLastToken.
	start := (self source asString findString: className startingAt: start).
	^ start to: start + className size - 1! !


!OBClassRefNode methodsFor: 'initialize-release' stamp: 'cwp 12/1/2004 01:10'!
setClassName: theName reference: aMethodRef
	self setReference: aMethodRef.
	className := theName.
! !

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

OBClassRefNode class
	instanceVariableNames: ''!

!OBClassRefNode class methodsFor: 'as yet unclassified' stamp: 'cwp 12/1/2004 00:50'!
on: aClassName inMethod: aMethodRef
	^ self new setClassName: aClassName reference: aMethodRef! !
Object subclass: #OBClassReference
	instanceVariableNames: 'name isMeta'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Utilities'!
!OBClassReference commentStamp: 'cwp 1/8/2005 13:15' prior: 0!
OBClassReference provides a way to refer to classes that may or may not be loaded into the image. It refers to the class indirectly, via name, rather than with a direct pointer to the class object. It also provides a number of convenience methods, which makes it more convenient than using the class name directly.!


!OBClassReference methodsFor: 'accessing'!
beMeta
	isMeta := true! !

!OBClassReference methodsFor: 'accessing'!
beNonMeta
	isMeta := false! !

!OBClassReference methodsFor: 'accessing'!
name
	^ isMeta
		ifTrue: [name, ' class']
		ifFalse: [name]! !

!OBClassReference methodsFor: 'accessing'!
theClass
	| theClass |
	theClass := self theNonMetaClass ifNil: [^ nil].
	^ isMeta
		ifFalse: [theClass]
		ifTrue: [theClass class]! !

!OBClassReference methodsFor: 'accessing'!
theNonMetaClass
	^ Smalltalk at: name ifAbsent: [].! !

!OBClassReference methodsFor: 'accessing'!
theNonMetaName
	^ name! !

!OBClassReference methodsFor: 'accessing'!
theNonMetaName: aSymbol
	name := aSymbol! !


!OBClassReference methodsFor: 'comparing'!
hash
	^ isMeta
		ifTrue: [name hash bitInvert]
		ifFalse: [name hash]! !

!OBClassReference methodsFor: 'comparing'!
<= other
	^ self name <= other name! !

!OBClassReference methodsFor: 'comparing'!
= other
	^ (other isKindOf: self class) 
		and: [name = other theNonMetaName] 
		and: [isMeta = other isMeta]! !


!OBClassReference methodsFor: 'testing'!
isMeta
	^ isMeta! !


!OBClassReference methodsFor: 'printing'!
printOn: aStream
	aStream nextPutAll: 'OBClassReference'.
	aStream nextPut: $<.
	aStream nextPutAll: name.
	isMeta ifTrue: [aStream nextPutAll: ' class'].
	aStream nextPut: $>.! !


!OBClassReference methodsFor: 'converting'!
referenceToMethod: aSelector
	| ref |
	ref := MethodReference new.
	ref setClassSymbol: name classIsMeta: isMeta  methodSymbol: aSelector stringVersion: ''.
	^ ref! !


!OBClassReference methodsFor: 'initializing'!
setName: aSymbol
	name := (aSymbol copyUpTo: $ ) asSymbol.
	isMeta := aSymbol endsWith: ' class'.! !

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

OBClassReference class
	instanceVariableNames: ''!

!OBClassReference class methodsFor: 'instance creation'!
metaNamed: aSymbol
	^ (self named: aSymbol) beMeta! !

!OBClassReference class methodsFor: 'instance creation'!
named: aSymbol
	^ self new setName: aSymbol! !

!OBClassReference class methodsFor: 'instance creation'!
to: aClass
	^ self named: aClass name! !
OBVariableNode subclass: #OBClassVariableNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBClassVariableNode commentStamp: 'cwp 1/8/2005 12:51' prior: 0!
OBClassVariable provides a method for finding methods which refer to a shared variable, ie, by searching for an association in the literal frame rather than for bytecodes refering to an instance variable.!


!OBClassVariableNode methodsFor: 'navigating' stamp: 'cwp 12/8/2004 23:47'!
accessors
	| literal |
	literal := (self theClass withAllSuperclasses 
				gather: [:ea | ea classPool associations])
					detect: [:ea | ea key = name].
	^ ((self systemNavigation allCallsOn: literal) asArray sort)
		collect: [:ref | OBMethodNode on: ref]! !
OBBrowser subclass: #OBCodeBrowser
	instanceVariableNames: 'hasChanges'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!
!OBCodeBrowser commentStamp: 'cwp 1/7/2005 23:45' prior: 0!
OBCodeBrowser is a superclass for all browsers which active code in the image. It provides methods for registering with the SystemChangeNotifier and updating it's display when it receives notification of system changes.!


!OBCodeBrowser methodsFor: 'morphic' stamp: 'cwp 1/8/2005 21:55'!
addModelItemsToWindowMenu: aMenu
	Smalltalk 
		at: #SystemBrowser 
		ifPresent: [:class | class 
								addRegistryMenuItemsTo: aMenu 
								inAccountOf: OBSystemBrowserAdaptor new].! !

!OBCodeBrowser methodsFor: 'morphic'!
initialExtent
	hasChanges := false.
	self register.
	^ super initialExtent! !

!OBCodeBrowser methodsFor: 'morphic' stamp: 'cwp 6/4/2006 18:51'!
stepAt: milliseconds in: aSystemWindow
	hasChanges ifTrue: [self signalRefresh].
	self clearChanges! !

!OBCodeBrowser methodsFor: 'morphic'!
wantsStepsIn: aSystemWindow
	^ true! !

!OBCodeBrowser methodsFor: 'morphic'!
windowIsClosing
	self unregister! !


!OBCodeBrowser methodsFor: 'updating' stamp: 'cwp 1/7/2005 23:47'!
clearChanges
	hasChanges := false! !

!OBCodeBrowser methodsFor: 'updating'!
event: anEvent
	hasChanges := true! !

!OBCodeBrowser methodsFor: 'updating' stamp: 'cwp 3/1/2006 19:48'!
register
	SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #event:! !

!OBCodeBrowser methodsFor: 'updating' stamp: 'cwp 3/1/2006 19:48'!
unregister
	SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self! !

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

OBCodeBrowser class
	instanceVariableNames: ''!

!OBCodeBrowser class methodsFor: 'configuration' stamp: 'lr 3/28/2006 12:00'!
addTo: root class: classSel comment: commentSel metaclass: metaclassSel 
	| class metaclass comment methodCategory method allMethodCategory |
	class := OBMetaNode named: 'Class'.
	comment := OBMetaNode named: 'ClassComment'.
	metaclass := OBMetaNode named: 'Metaclass'.
	allMethodCategory := OBMetaNode named: 'AllMethodCategory'.
	methodCategory := OBMetaNode named: 'MethodCategory'.
	method := OBMetaNode named: 'Method'.
	root
		childAt: classSel
			labeled: 'instance'
			put: class;
		childAt: commentSel
			labeled: '?'
			put: comment;
		childAt: metaclassSel
			labeled: 'class'
			put: metaclass;
		addActor: (OBNodeActor onNodeClass: OBClassCategoryNode);
		addActor: OBCategoryActor new;
		filterClass: OBModalFilter.
	class
		displaySelector: #indentedName;
		childAt: #allCategory put: allMethodCategory;
		childAt: #categories put: methodCategory;
		addActor: OBNodeActor new;
		addActor: OBClassActor new.
	comment 
		displaySelector: #indentedName;
		addActor: OBNodeActor new.
	metaclass
		displaySelector: #indentedName;
		childAt: #allCategory put: allMethodCategory;
		childAt: #categories put: methodCategory;
		addActor: OBNodeActor new;
		addActor: OBClassActor new.
	allMethodCategory
		childAt: #methods put: method;
		addActor: (OBNodeActor onNodeClass: OBMethodCategoryNode).
	methodCategory
		childAt: #methods put: method;
		addActor: OBCategoryActor new;
		addActor: (OBNodeActor onNodeClass: OBMethodCategoryNode).
	method addActor: OBNodeActor new.
	^ root! !

!OBCodeBrowser class methodsFor: 'configuration' stamp: 'cwp 12/15/2004 22:52'!
optionalButtons
	^ #('browse' 'variables' 'hierarchy' 'inheritance' 'senders' 'implementors' 'versions')! !
OBNode subclass: #OBCodeNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBCodeNode commentStamp: 'cwp 1/8/2005 11:12' prior: 0!
OBCodeNode is an abstract superclass for node classes that represent program elements active in the image. Though it provides little functionality, it exists for structural purposes.!


!OBCodeNode methodsFor: 'actions' stamp: 'cwp 7/14/2006 14:24'!
browseAction
	^ self 
		action: #browse
		withMenuLabel: 'browse'
		withButtonLabel: 'browse'
		withKeystroke: $b
		withIcon: (MenuIcons tryIcons: #(windowIcon smallWindowIcon)).
! !


!OBCodeNode methodsFor: 'testing' stamp: 'cwp 6/30/2006 00:37'!
hasOrganization
	^ false! !
OBNode subclass: #OBCollectionNode
	instanceVariableNames: 'collection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Nodes'!
!OBCollectionNode commentStamp: 'cwp 1/7/2005 23:31' prior: 0!
OBCollectionNode is a trivial wrapper for a collection of nodes. It is typically used as an artificial root node for metagraphs that have no natural root.!


!OBCollectionNode methodsFor: 'displaying' stamp: 'cwp 3/15/2004 23:19'!
name
	^ collection species name! !


!OBCollectionNode methodsFor: 'initalizing' stamp: 'cwp 3/15/2004 23:18'!
setCollection: aCollection
	collection _ aCollection! !


!OBCollectionNode methodsFor: 'navigating' stamp: 'cwp 3/15/2004 23:19'!
children
	^ collection! !

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

OBCollectionNode class
	instanceVariableNames: ''!

!OBCollectionNode class methodsFor: 'as yet unclassified' stamp: 'cwp 3/15/2004 23:17'!
on: aCollection
	^ self new setCollection: aCollection! !
Object subclass: #OBColumn
	instanceVariableNames: 'panel filter children selection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Kernel'!
!OBColumn commentStamp: 'cwp 1/7/2005 23:19' prior: 0!
An OBColumn manages a list of nodes, which it displays in a PluggableListMorph in the pane scroller at the top of the browser. All instances of OBColumn belong to an OBColumnPanel. It's main responsibility is keeping its list - and those of its neighbours - up to date. Each column has a MetaNode, which provides the list contents. It uses a filter to meditate between its self and the MetaNode.

iVars:

panel		- the panel which owns the column
filter		- the filter which manages the column's MetaNode.
parent		- the node selected in the column to the left of this column
children 	- the nodes which make up this column's list
selection 	- the index of the node selected by the user!


!OBColumn methodsFor: 'accessing' stamp: 'cwp 4/17/2006 15:52'!
announcer
	^ panel announcer! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 11/16/2004 21:49'!
basicNext
	^panel columnAfter: self! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 11/17/2004 00:18'!
browser
	^ panel browser! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 2/9/2004 20:58'!
filter
	^ filter! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 2/12/2004 18:47'!
filter: aFilter
	filter _ aFilter monitor: self.
	self changed: #filter.! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 2/28/2006 08:27'!
isEmpty
	^ children isEmpty! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 2/9/2004 20:59'!
metaNode
	^ self filter metaNode! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 2/12/2004 20:50'!
next
	^ self basicNext
		ifNil: [(self hasSelection and: [self shouldBeLast not])
				ifTrue: [self createNext]]
	! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 9/24/2005 22:45'!
parent
	^ panel parentNodeForColumn: self! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 6/8/2006 01:32'!
parent: aNode
	
	self filter: aNode metaNode filter.
	self getChildren.
	self clearSelection.
	self changed: #list.
	panel clearAfter: self! !

!OBColumn methodsFor: 'accessing' stamp: 'cwp 6/28/2006 00:53'!
requestor
	^ self browser requestor node: (self selectedNode ifNil: [self parent])! !


!OBColumn methodsFor: 'actions' stamp: 'cwp 9/24/2005 22:23'!
actionSetsForParentNode
	^ self filter children gather: [:child | child actionSetsForParent: self parent].	! !

!OBColumn methodsFor: 'actions' stamp: 'cwp 9/14/2004 19:08'!
actionSetsForSelectedNode
	| node |
	node _ self selectedNode ifNil: [^ #()].
	^ node metaNode actionSetsForNode: node	! !

!OBColumn methodsFor: 'actions' stamp: 'hpt 5/17/2004 14:19'!
actionsForKeystroke: aChar
	^self actionsForParentNode, self actionsForSelectedNode
		select: [:anAction | anAction keystroke == aChar]! !

!OBColumn methodsFor: 'actions' stamp: 'cwp 9/24/2005 22:23'!
actionsForParentNode
	^ self filter children gather: [:child | child actionsForParent: self parent].	! !

!OBColumn methodsFor: 'actions' stamp: 'avi 3/6/2004 16:26'!
actionsForSelectedNode
	| node |
	node _ self selectedNode ifNil: [^ #()].
	^ node metaNode actionsForNode: node	! !

!OBColumn methodsFor: 'actions' stamp: 'cwp 6/25/2006 00:22'!
addActionsToMenu: aMenu
	self actionSetsForParentNode, self actionSetsForSelectedNode
		do: 
			[:set 
			|set do: 
				[:action | 
				action announcer: self announcer.
				action addItemToMenu: aMenu]]
		separatedBy: [aMenu addLine]! !

!OBColumn methodsFor: 'actions' stamp: 'cwp 6/28/2006 00:24'!
addServicesToMenu: aMenu
	| scan |
	scan _ self announcer announce: OBServiceScan.
	aMenu 
		addServices: scan services
		for: self requestor
		extraLines: #().
	! !

!OBColumn methodsFor: 'actions' stamp: 'cwp 6/25/2006 13:55'!
servicesForKeystroke: aChar
	| scan |
	scan _ self announcer announce: OBServiceScan.
	^ scan services select: [:ea | ea keystroke == aChar]! !


!OBColumn methodsFor: 'callbacks' stamp: 'cwp 6/28/2006 00:50'!
keystroke: aChar from: aMorph
	self isEmpty ifTrue: [^ self].
	(self actionsForKeystroke: aChar)
		do: [:action | 
			action announcer: self announcer.
			action trigger].
	(self servicesForKeystroke: aChar)
		do: [:service | service condExecuteFor: self requestor]! !

!OBColumn methodsFor: 'callbacks' stamp: 'cwp 12/8/2004 21:21'!
list
	^ children 
		ifNil: [#()]
		ifNotNil: [children collect: [:ea | ea displayString]]! !

!OBColumn methodsFor: 'callbacks' stamp: 'cwp 12/8/2004 21:22'!
listAt: index
	^ (children at: index ifAbsent: [^ '']) displayString! !

!OBColumn methodsFor: 'callbacks' stamp: 'cwp 2/29/2004 21:48'!
listSize
	^ children
		ifNil: [0]
		ifNotNil: [children size]! !

!OBColumn methodsFor: 'callbacks' stamp: 'cwp 6/25/2006 00:24'!
menu: aMenu
	self isEmpty ifFalse:
		[self addActionsToMenu: aMenu.
		self addServicesToMenu: aMenu].
	^ aMenu! !

!OBColumn methodsFor: 'callbacks' stamp: 'cwp 4/18/2006 00:25'!
okToChange
	^ (self announcer announce: OBAboutToChange) isVetoed not! !

!OBColumn methodsFor: 'callbacks' stamp: 'cwp 11/5/2003 19:01'!
selection
	^ selection ifNil: [0]! !

!OBColumn methodsFor: 'callbacks' stamp: 'cwp 6/5/2006 23:37'!
selection: anInteger
	selection _ anInteger.
	self signalSelectionChanged.
	self changed: #selection.
! !


!OBColumn methodsFor: 'drag and drop' stamp: 'cwp 6/4/2006 00:37'!
acceptDroppingMorph: transferMorph event: evt inMorph: listMorph
	^ [(self nodeForDroppedMorph: transferMorph event: evt inMorph: listMorph)
		acceptDroppedNode: transferMorph passenger]
			on: OBAnnouncerRequest
			do: [:notification | notification resume: self announcer]
! !

!OBColumn methodsFor: 'drag and drop' stamp: 'avi 2/20/2004 13:45'!
dragEnabled
	^ true! !

!OBColumn methodsFor: 'drag and drop' stamp: 'avi 2/20/2004 14:35'!
dragPassengerFor: item inMorph: listMorph
	^ self nodeForItem: item inMorph: listMorph! !

!OBColumn methodsFor: 'drag and drop' stamp: 'avi 2/20/2004 14:37'!
dragTransferType
	^ #OmniBrowser! !

!OBColumn methodsFor: 'drag and drop' stamp: 'avi 2/20/2004 14:36'!
dragTransferTypeForMorph: listMorph
	^ self dragTransferType! !

!OBColumn methodsFor: 'drag and drop' stamp: 'avi 2/20/2004 14:30'!
dropEnabled
	^ true! !

!OBColumn methodsFor: 'drag and drop' stamp: 'cwp 3/3/2004 02:23'!
nodeForDroppedMorph: transferMorph event: evt inMorph: pluggableListMorph
	| index item |
	index _ pluggableListMorph rowAtLocation: evt position.
	index = 0 ifTrue: [^ nil].
	item _ pluggableListMorph listMorph item: index.
	^ self nodeForItem: item inMorph: pluggableListMorph! !

!OBColumn methodsFor: 'drag and drop' stamp: 'cwp 6/10/2006 21:59'!
nodeForItem: item inMorph: pluggableListMorph
	^ children 
		detect: [:child | child displayString = item contents asString]
		ifNone: [item contents]! !

!OBColumn methodsFor: 'drag and drop' stamp: 'cwp 2/25/2004 21:26'!
wantsDroppedMorph: transferMorph event: evt inMorph: listMorph
	| node |
	(transferMorph isKindOf: TransferMorph) ifFalse: [^ false].
	transferMorph dragTransferType == self dragTransferType ifFalse: [^ false].
	node _ self nodeForDroppedMorph: transferMorph event: evt inMorph: listMorph.
	^ node notNil and: [node wantsDroppedNode: transferMorph passenger]! !


!OBColumn methodsFor: 'initializing' stamp: 'cwp 6/3/2006 23:38'!
setPanel: aPanel 
	panel := aPanel.
	self subscribe.
	children := #().
	self clearSelection! !

!OBColumn methodsFor: 'initializing' stamp: 'cwp 6/3/2006 23:39'!
setPanel: aPanel metaNode: aMetaNode node: aNode 
	panel := aPanel.
	self subscribe.
	filter := aMetaNode filter monitor: self.
	children _ self filter nodesForParent: aNode.
	self clearSelection! !


!OBColumn methodsFor: 'morphic' stamp: 'cwp 12/14/2003 22:15'!
buttonHeight
	^ 20! !

!OBColumn methodsFor: 'morphic' stamp: 'cwp 2/9/2004 21:06'!
columnWithHeader
	| col bh |
	col _ BorderedMorph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		clipSubmorphs: true;
		color: Color transparent;
		cellInset: 0;
		borderWidth: 0;
		layoutPolicy: ProportionalLayout new.
	
	bh _ self buttonHeight negated.
	col
		addMorph: self listMorph
		fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@0 corner: 0@bh)).
	col
		addMorph: self filter buttonMorph
		fullFrame: (LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@bh corner: 0@0)).
		

	^ col! !

!OBColumn methodsFor: 'morphic' stamp: 'cwp 2/28/2006 08:37'!
listMorph
	^ (PluggableListMorph
		on: self
		list: #list
		selected: #selection
		changeSelected: #selection:
		menu: #menu:
		keystroke: #keystroke:from:)
			getListElementSelector: #listAt:;
			getListSizeSelector: #listSize;
			dragEnabled: self dragEnabled;
			dropEnabled: self dropEnabled;
			borderWidth: 0;
			autoDeselect: false;
			adoptPaneColor: panel defaultBackgroundColor;
			yourself! !

!OBColumn methodsFor: 'morphic' stamp: 'cwp 2/12/2004 19:17'!
morph
	^ self isEmpty 
		ifTrue: [self simplePane]
		ifFalse: [self filter wantsButton
							ifTrue: [self paneWithHeader]
							ifFalse: [self simplePane]]! !

!OBColumn methodsFor: 'morphic' stamp: 'cwp 2/12/2004 18:11'!
paneWithHeader
	^ OBPane forColumn: self withFilter: self filter! !

!OBColumn methodsFor: 'morphic' stamp: 'cwp 2/12/2004 18:10'!
simplePane
	^ OBPane forColumn: self! !


!OBColumn methodsFor: 'nodes' stamp: 'cwp 9/24/2005 22:29'!
getChildren
	children _ self filter nodesForParent: self parent.
	^ children! !

!OBColumn methodsFor: 'nodes' stamp: 'cwp 3/3/2004 00:11'!
nextMetaNode
	^ self selectedNode metaNode! !

!OBColumn methodsFor: 'nodes' stamp: 'cwp 9/26/2005 00:14'!
selectAncestorOf: aNode
	| ancestor |
	ancestor _ self filter selectAncestorOf: aNode withParent: self parent.
	ancestor ifNotNil:
		[self 
			getChildren; 
			changed: #list;
			select: ancestor.
		panel selected: self].
	^ ancestor! !


!OBColumn methodsFor: 'printing' stamp: 'avi 3/6/2004 16:23'!
descriptor
	self isEmpty ifTrue: [^ 'empty'].
	self hasSelection ifTrue: [^ self selectedNode name].
	^ ''! !

!OBColumn methodsFor: 'printing' stamp: 'cwp 2/11/2004 23:31'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	aStream nextPutAll: self descriptor.
	aStream nextPut: $)! !


!OBColumn methodsFor: 'selecting' stamp: 'avi 3/6/2004 18:05'!
clearSelection
	selection _ 0! !

!OBColumn methodsFor: 'selecting' stamp: 'cwp 2/2/2004 21:54'!
selectedNode
	^ children at: self selection ifAbsent: [].! !

!OBColumn methodsFor: 'selecting' stamp: 'cwp 7/14/2006 12:50'!
selectSilently: aNode
	| match |
	aNode ifNil: [selection := 0. ^ self].
	match := children 
				detect: [:ea | ea correspondsWith: aNode] 
				ifNone: [selection := 0. ^ self].
	selection _ children indexOf: match.! !

!OBColumn methodsFor: 'selecting' stamp: 'cwp 12/8/2004 22:10'!
select: aNode
	self selection: (children indexOf: (children detect: [:ea | ea = aNode] ifNone: []))! !


!OBColumn methodsFor: 'testing' stamp: 'avi 3/6/2004 23:07'!
hasSelection
	^ self selection > 0! !

!OBColumn methodsFor: 'testing' stamp: 'cwp 12/20/2004 22:09'!
includesNode: aNode
	^ children includes: aNode! !

!OBColumn methodsFor: 'testing' stamp: 'avi 3/6/2004 16:27'!
shouldBeLast
	^ self hasSelection not or: [self nextMetaNode hasChildren not]! !

!OBColumn methodsFor: 'testing' stamp: 'cwp 2/12/2004 20:18'!
wantsButton
	^ self filter notNil and: [self filter wantsButton]! !


!OBColumn methodsFor: 'updating' stamp: 'cwp 6/9/2006 22:35'!
childrenChanged: announcement
	(self parent = announcement node) ifTrue:
		[self refresh]! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 9/25/2005 23:56'!
clear
	filter _ nil.
	children _ #().
	self clearSelection.
	self changed: #list.
	self changed: #selection.
	self changed: #filter.! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 9/24/2005 22:56'!
createNext
	| nextMetaNode created |
	nextMetaNode := self nextMetaNode.
	created := nextMetaNode columnInPanel: panel node: self selectedNode.
	panel pushColumn: created.
	^created! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/9/2006 23:17'!
listChanged
	self refreshAndSignal: true! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/9/2006 23:19'!
nodeChanged: ann
	(children includes: ann node) ifTrue: [self changed: #list]! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/4/2006 12:03'!
nodeDeleted: announcement 
	"This gets called if an action causes the currently selected node to be deleted."

	self selectedNode = announcement node
		ifTrue: 
			[self getChildren.
			self changed: #list.
			self selection: 0]! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/9/2006 23:08'!
refresh
	self refreshAndSignal: false! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/9/2006 23:08'!
refresh: ann
	self refreshAndSignal: false! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/9/2006 23:08'!
refreshAndSignal: aBoolean
	| node oldChildren shouldSignal |
	shouldSignal _ aBoolean.
	self isEmpty ifTrue: [^self].
	node := self selectedNode.
	oldChildren := children.
	self getChildren.
	children = oldChildren ifFalse: 
		[self selectSilently: node.
		self hasSelection ifFalse: 
			[shouldSignal _ true]].
	shouldSignal ifTrue: [self signalSelectionChanged].
	self changed: #list! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/8/2006 00:27'!
selectionChanged: ann
	! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/5/2006 23:31'!
signalSelectionChanged
	self announcer announce: (OBSelectionChanged column: self)! !

!OBColumn methodsFor: 'updating' stamp: 'cwp 6/10/2006 00:18'!
subscribe
	self announcer 
		observe: OBRefreshRequired send: #refresh: to: self;
		observe: OBNodeChanged send: #nodeChanged: to: self;
		observe: OBNodeDeleted send: #nodeDeleted: to: self;
		observe: OBChildrenChanged send: #childrenChanged: to: self;
		observe: OBSelectionChanged send: #selectionChanged: to: self.! !

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

OBColumn class
	instanceVariableNames: ''!

!OBColumn class methodsFor: 'instance creation' stamp: 'cwp 9/18/2005 13:26'!
inPanel: aBrowser
	^ self new setPanel: aBrowser! !

!OBColumn class methodsFor: 'instance creation' stamp: 'cwp 9/18/2005 13:25'!
inPanel: aPanel metaNode: aMetaNode node: aNode
	^ self new
			setPanel: aPanel
			metaNode: aMetaNode
			node: aNode! !
OBPanel subclass: #OBColumnPanel
	instanceVariableNames: 'root columns minPanes maxPanes'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Panels'!
!OBColumnPanel commentStamp: 'cwp 12/6/2004 23:50' prior: 0!
OBColumnPanel handles navigation around the nodes of the object graph. It maintains a list of columns, which track the user's path through the node tree. As nodes are selected, additional columns are added to the list, which appear as panes on the right of the panel. 

iVars:

columns	- A collection of OBColumns, each of which manages a single pane in the scroller.
minPanes - The minimum number of panes that should ever be visible.
maxPanes - The maximum number of panes that should ever be visible.
!


!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 11/16/2004 21:46'!
columns
	^columns! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 11/16/2004 21:46'!
columns: anObject
	columns := anObject! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 11/16/2004 22:22'!
currentNode
	^ self currentColumn ifNotNilDo: [:column | column selectedNode]! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 11/16/2004 22:23'!
currentOrRootNode
	^(self columns reversed detect: [:ea | ea hasSelection]
		ifNone: [^self columns first parent]) selectedNode! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 6/5/2006 23:10'!
hasSelection
	^ false! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 11/16/2004 23:51'!
labelString
	| label |
	self columns reversed do: 
		[:ea | 
		label := ea selectedNode ifNotNilDo: [:node | node title].
		label ifNotNil: [^ label]].
	^ nil
! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 11/16/2004 23:29'!
maxPanes
	^maxPanes! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 11/16/2004 22:54'!
minPanes
	^ minPanes! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'cwp 2/28/2006 09:59'!
parentNodeForColumn: aColumn
	^ [(columns before: aColumn) selectedNode]
		on: Error
		do: [:err | ^ root]! !

!OBColumnPanel methodsFor: 'accessing' stamp: 'dvf 9/5/2005 18:08'!
selectionPath
	^(self columns 
		collect: [:e | e parent] 
		thenSelect: [:e | e notNil]) allButFirst! !


!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 9/25/2005 23:58'!
clearAfter: aColumn 
	| start |
	start _ (columns indexOf: aColumn) + 1.
	start to: columns size do: [:i | (columns at: i) clear]! !

!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 2/28/2006 18:12'!
columnAfter: aColumn 
	^ [self columns after: aColumn]
		on: Error
		do: [:err | nil]
! !

!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 2/28/2006 19:07'!
columnBefore: aColumn 
	^ self columnBefore: aColumn ifAbsent: [nil]

! !

!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 2/28/2006 19:07'!
columnBefore: aColumn ifAbsent: aBlock
	^ [self columns before: aColumn]
		on: Error
		do: [:err | aBlock value]


! !

!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 11/16/2004 22:22'!
currentColumn
	^self columns reversed detect: [:ea | ea hasSelection] ifNone: []! !

!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 11/16/2004 23:01'!
emptyColumn
	^ OBColumn inPanel: self! !

!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 6/4/2006 00:39'!
popColumn
	self announcer unsubscribe: self columns removeLast.
! !

!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 6/4/2006 00:40'!
pushColumn: aColumn 
	self columns addLast: aColumn.
	self changed: #panes.
! !

!OBColumnPanel methodsFor: 'accessing columns' stamp: 'cwp 6/8/2006 01:35'!
selected: aColumn 
	aColumn next ifNotNilDo: 
		[:next | 
		next parent: aColumn selectedNode].! !


!OBColumnPanel methodsFor: 'callbacks' stamp: 'cwp 11/26/2004 21:55'!
defaultBackgroundColor
	^ browser defaultBackgroundColor! !

!OBColumnPanel methodsFor: 'callbacks' stamp: 'cwp 11/23/2004 00:52'!
okToReclaimPane
	columns size > minPanes ifFalse: [^ false].
	^ columns last isEmpty or: [(columns at: columns size - 1) shouldBeLast].
! !

!OBColumnPanel methodsFor: 'callbacks' stamp: 'cwp 11/17/2004 22:48'!
panes
	^ columns collect: [:ea | ea morph]! !

!OBColumnPanel methodsFor: 'callbacks' stamp: 'cwp 9/18/2005 11:49'!
reclaimPanes
	| old |
	old := columns size.
	[self okToReclaimPane] whileTrue: [self popColumn].
	^ old - columns size! !

!OBColumnPanel methodsFor: 'callbacks' stamp: 'cwp 11/18/2004 00:00'!
sizing
	^ (columns size max: minPanes) min: maxPanes! !


!OBColumnPanel methodsFor: 'constructing' stamp: 'cwp 11/17/2004 23:24'!
buildScroller
	^ (OBPaneScroller withModel: self)
		name: 'scroller';
		yourself! !

!OBColumnPanel methodsFor: 'constructing' stamp: 'cwp 11/20/2004 22:22'!
morph
	^ (OBPaneScroller withModel: self)
		name: 'scroller';
		yourself! !

!OBColumnPanel methodsFor: 'constructing' stamp: 'cwp 11/20/2004 22:26'!
morphHeight
	^ 0! !


!OBColumnPanel methodsFor: 'initializing' stamp: 'cwp 9/24/2005 22:45'!
setMetaNode: aMetaNode node: aNode 
	root _ aNode.
	root metaNode: aMetaNode.
	self pushColumn: (aMetaNode columnInPanel: self node: root).
	minPanes - self columns size 
		timesRepeat: [self pushColumn: self emptyColumn]! !

!OBColumnPanel methodsFor: 'initializing' stamp: 'cwp 12/5/2004 16:54'!
setMinPanes: min maxPanes: max
	columns _ OrderedCollection new.
	minPanes _ min.
	maxPanes _ max! !


!OBColumnPanel methodsFor: 'navigating' stamp: 'cwp 6/9/2006 23:18'!
hopTo: aNode 
	| column |
	column := self columns last.
	[column refreshAndSignal: false; includesNode: aNode]
		whileFalse: [column := self 
						columnBefore: column 
						ifAbsent: [^ self jumpTo: aNode]].
	column select: aNode! !

!OBColumnPanel methodsFor: 'navigating' stamp: 'cwp 11/16/2004 23:34'!
jumpToRoot
	^ self columns first selection: 0! !

!OBColumnPanel methodsFor: 'navigating' stamp: 'cwp 6/10/2006 00:11'!
jumpTo: aNode 
	| column ancestor |
	column := self columns first.
	
	[ancestor := column selectAncestorOf: aNode.
	ancestor = aNode or: [ancestor isNil]] whileFalse:
		[column := self columns after: column].
	
	self announcer announce: (OBSelectionChanged column: column)! !

!OBColumnPanel methodsFor: 'navigating' stamp: 'cwp 9/24/2005 22:47'!
root
	^ root! !


!OBColumnPanel methodsFor: 'testing' stamp: 'cwp 11/20/2004 21:10'!
isNavigation
	^ true! !


!OBColumnPanel methodsFor: 'updating' stamp: 'cwp 6/5/2006 23:52'!
nodeDeleted: ann
	ann node = self root 
		ifTrue: 
			[self columns first clear.
			self announcer announce: (OBSelectionChanged column: self)]! !

!OBColumnPanel methodsFor: 'updating' stamp: 'cwp 6/4/2006 01:03'!
selectNode: announcement
	^ self hopTo: announcement node! !

!OBColumnPanel methodsFor: 'updating' stamp: 'cwp 6/5/2006 01:33'!
selectionChanged: ann
	ann column hasSelection
		ifTrue: [self selected: ann column]
		ifFalse: [self clearAfter: ann column]
! !

!OBColumnPanel methodsFor: 'updating' stamp: 'cwp 6/5/2006 01:32'!
subscribe
	self announcer
		observe: OBSelectingNode send: #selectNode: to: self;
		observe: OBSelectionChanged send: #selectionChanged: to: self;
		observe: OBNodeCreated send: #selectNode: to: self;
		observe: OBNodeDeleted send: #nodeDeleted: to: self.! !

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

OBColumnPanel class
	instanceVariableNames: ''!

!OBColumnPanel class methodsFor: 'instance creation' stamp: 'cwp 12/5/2004 16:56'!
minPanes: min maxPanes: max
	^ self basicNew setMinPanes: min maxPanes: max! !

!OBColumnPanel class methodsFor: 'instance creation' stamp: 'cwp 12/5/2004 16:56'!
new
	^ self minPanes: 1 maxPanes: 1! !
OBInteractionRequest subclass: #OBConfirmationRequest
	instanceVariableNames: 'prompt confirm cancel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Notifications'!
!OBConfirmationRequest commentStamp: 'cwp 3/5/2004 12:30' prior: 0!
This notification is used to ask the user to confirm some kind potentially dangerous operation. Its default action is to open a PopUpMenu.

iVars:

prompt		- a string describing the situation the user is asked to confirm
confirm		- a string describing the action that will be taken if the user confirms
cancel		- a string describing the action that will be taken if the user does not confirm!


!OBConfirmationRequest methodsFor: 'initalizing' stamp: 'cwp 2/28/2004 12:00'!
setPrompt: promptString confirm: confirmString cancel: cancelString
	prompt _ promptString.
	confirm _ confirmString.
	cancel _ cancelString! !


!OBConfirmationRequest methodsFor: 'responding' stamp: 'cwp 2/28/2004 12:11'!
cancel
	self resume: false! !

!OBConfirmationRequest methodsFor: 'responding' stamp: 'cwp 2/28/2004 12:11'!
ok
	self resume: true! !


!OBConfirmationRequest methodsFor: 'user interaction' stamp: 'cwp 6/4/2006 14:17'!
defaultAction
	(prompt beginsWith: 'BogusD') ifTrue: [self halt].
	^ PopUpMenu confirm: prompt trueChoice: confirm falseChoice: cancel! !

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

OBConfirmationRequest class
	instanceVariableNames: ''!

!OBConfirmationRequest class methodsFor: 'as yet unclassified' stamp: 'cwp 2/28/2004 12:09'!
newPrompt: prompt confirm: confirm cancel: cancel
	^ self new setPrompt: prompt confirm: confirm cancel: cancel! !

!OBConfirmationRequest class methodsFor: 'as yet unclassified' stamp: 'cwp 2/28/2004 12:13'!
prompt: prompt
	^ self prompt: prompt confirm: 'Ok'! !

!OBConfirmationRequest class methodsFor: 'as yet unclassified' stamp: 'cwp 2/28/2004 12:12'!
prompt: prompt confirm: confirm
	^ self prompt: prompt confirm: confirm cancel: 'Cancel'! !

!OBConfirmationRequest class methodsFor: 'as yet unclassified' stamp: 'cwp 2/28/2004 12:02'!
prompt: prompt confirm: confirm cancel: cancel
	^ (self newPrompt: prompt confirm: confirm cancel: cancel) signal! !
Object subclass: #OBDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Utilities'!
!OBDefinition commentStamp: 'cwp 1/7/2005 23:38' prior: 0!
The responsibility of a definition is to express a node's composition textually and respond to changes in the text by updating the node it represents. For example,a file browser might use a file definition to allow editing of a files contents.!



!OBDefinition methodsFor: 'callbacks' stamp: 'cwp 3/22/2004 20:51'!
accept: aText notifying: aController
	^ self text: aText! !

!OBDefinition methodsFor: 'callbacks' stamp: 'cwp 3/23/2004 00:08'!
doItContext
	^ nil! !

!OBDefinition methodsFor: 'callbacks' stamp: 'cwp 2/28/2005 23:23'!
doItReceiver
	| class |
	class _ self selectedClass.
	^ class
		ifNotNil: [class theNonMetaClass]
		ifNil: [FakeClassPool new]! !

!OBDefinition methodsFor: 'callbacks' stamp: 'cwp 3/23/2004 22:16'!
selection
	^ 1 to: 0! !

!OBDefinition methodsFor: 'callbacks' stamp: 'cwp 3/22/2004 20:52'!
text
	^ ''! !

!OBDefinition methodsFor: 'callbacks' stamp: 'cwp 3/23/2004 22:16'!
textSelection
	^ self selection! !

!OBDefinition methodsFor: 'callbacks' stamp: 'cwp 3/22/2004 20:52'!
text: aText
	^ false! !


!OBDefinition methodsFor: 'updating' stamp: 'cwp 6/4/2006 18:53'!
signalChange
	OBAnnouncer current announce: (OBDefinitionChanged definition: self)! !
OBAnnouncement subclass: #OBDefinitionChanged
	instanceVariableNames: 'definition node'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBDefinitionChanged methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:25'!
definition
	^ definition! !

!OBDefinitionChanged methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:26'!
definition: aDefinition
	definition _ aDefinition! !

!OBDefinitionChanged methodsFor: 'as yet unclassified' stamp: 'cwp 6/5/2006 00:47'!
node
	^ node! !

!OBDefinitionChanged methodsFor: 'as yet unclassified' stamp: 'cwp 6/5/2006 00:47'!
node: aNode
	node _ aNode! !

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

OBDefinitionChanged class
	instanceVariableNames: ''!

!OBDefinitionChanged class methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:28'!
definition: aDefinition
	^ self new
		definition: aDefinition;
		yourself! !

!OBDefinitionChanged class methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:27'!
node: aNode definition: aDefinition
	^ self new
		node: aNode;
		definition: aDefinition;
		yourself! !
OBPanel subclass: #OBDefinitionPanel
	instanceVariableNames: 'definition'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Panels'!
!OBDefinitionPanel commentStamp: 'cwp 1/7/2005 23:35' prior: 0!
OBDefinition serves as the model for the text pane of a typical browser. It's main responsibility is to act as a relay between a PluggableTextMorph and a Definition supplied by the currently selected node.

iVars:

browser - The browser of which this panel is a part.
!


!OBDefinitionPanel methodsFor: 'accessing' stamp: 'cwp 9/17/2004 00:56'!
definition: aDefinition
	definition _ aDefinition.
	self changed: #text! !

!OBDefinitionPanel methodsFor: 'accessing' stamp: 'cwp 3/22/2004 20:06'!
getDefinition
	^ browser currentNode ifNotNilDo: [:node | node definition]! !

!OBDefinitionPanel methodsFor: 'accessing' stamp: 'cwp 3/22/2004 20:41'!
withDefinitionDo: workBlock ifNil: nilBlock
	definition ifNil: [ ^ nilBlock value].
	^ workBlock value: definition! !


!OBDefinitionPanel methodsFor: 'callbacks' stamp: 'cwp 6/4/2006 00:41'!
accept: aText notifying: aController
	^ self 
		withDefinitionDo: [:def | [def accept: aText notifying: aController]
									on: OBAnnouncerRequest
									do: [:notification | notification resume: self announcer]]
		ifNil: [true]! !

!OBDefinitionPanel methodsFor: 'callbacks' stamp: 'cwp 3/23/2004 00:23'!
doItContext
	^ self 
		withDefinitionDo: [:def | (def respondsTo: #doItContext) ifTrue: [def doItContext]]
		ifNil: [nil]! !

!OBDefinitionPanel methodsFor: 'callbacks' stamp: 'cwp 3/23/2004 00:23'!
doItReceiver
	^ self 
		withDefinitionDo: [:def | (def respondsTo: #doItReceiver) ifTrue: [def doItReceiver]]
		ifNil: [nil]! !

!OBDefinitionPanel methodsFor: 'callbacks' stamp: 'cwp 10/24/2004 09:16'!
menu: aMenu shifted: aBoolean
	| items |
	items _  aBoolean 
		ifTrue: [self shiftedYellowButtonMenu] 
		ifFalse: [self yellowButtonMenu].
	items do: [:ea |
			  ea = #-
				ifFalse: [aMenu add: ea first action: ea second]
				ifTrue: [aMenu addLine]].
	^ aMenu ! !

!OBDefinitionPanel methodsFor: 'callbacks' stamp: 'cwp 10/24/2004 09:27'!
perform: aSelector orSendTo: anObject
	| receiver |
	receiver  _ (self respondsTo: aSelector) ifTrue: [self] ifFalse: [anObject].
	receiver perform: aSelector! !

!OBDefinitionPanel methodsFor: 'callbacks' stamp: 'cwp 3/23/2004 00:22'!
selectedClass
	^ self 
		withDefinitionDo: [:def | (def respondsTo: #selectedClass) ifTrue: [def selectedClass]] 
		ifNil: [nil]! !

!OBDefinitionPanel methodsFor: 'callbacks' stamp: 'cwp 3/22/2004 21:15'!
selection
	^ self withDefinitionDo: [:def | def textSelection] ifNil: [1 to: 0]! !

!OBDefinitionPanel methodsFor: 'callbacks' stamp: 'cwp 3/22/2004 20:42'!
text
	^ self withDefinitionDo: [:def | def text] ifNil: ['']! !


!OBDefinitionPanel methodsFor: 'constructing' stamp: 'cwp 10/30/2004 22:03'!
morph
	^ (OBPluggableTextMorph
		on: self
		text: #text
		accept: #accept:notifying:
		readSelection: #selection
		menu: #menu:shifted:)
			font: Preferences standardCodeFont;
			yourself
			
	"see CodeHolder>>buildMorphicCodePaneWith:"! !

!OBDefinitionPanel methodsFor: 'constructing' stamp: 'cwp 3/9/2004 21:35'!
morphHeight
	^ 0! !

!OBDefinitionPanel methodsFor: 'constructing' stamp: 'cwp 7/14/2006 01:17'!
shiftedYellowButtonMenu
	^ {
		{'explain' translated.						#explain}.
		#-.
		{'selectors containing it (W)' translated.		#methodNamesContainingIt}.
		{'method strings with it (E)' translated.		#methodStringsContainingit}.
		{'method source with it' translated.			#methodSourceContainingIt}.
		{'class names containing it' translated.		#classNamesContainingIt}.
		{'class comments with it' translated.			#classCommentsContainingIt}.
		{'change sets with it' translated.				#browseChangeSetsWithSelector}.
		#-.
		{'save contents to file...' translated.			#saveContentsInFile}.
		#-.
		{'more...' translated.							#yellowButtonActivity}.
	}
! !

!OBDefinitionPanel methodsFor: 'constructing' stamp: 'cwp 10/24/2004 23:28'!
yellowButtonMenu
	^ {
		{'find...(f)' translated.				#find}.			     
		{'find again (g)' translated.			#findAgain}.		     
		{'set search string (h)' translated.	#setSearchString}.
		#-.	     
		{'do again (j)' translated.			#again}.		     
		{'undo (z)' translated.				#undo}.			     
		#-.	     
		{'copy (c)' translated.				#copySelection}.	     
		{'cut (x)' translated.					#cut}.			     
		{'paste (v)' translated.				#paste}.		     
		{'paste...' translated.					#pasteRecent}.		     
		#-.	     
		{'accept (s)' translated.				#accept}.		     
		{'cancel (l)' translated.				#cancel}.		     
		#-.	     
		{'do it (d)' translated.				#doIt}.			     
		{'print it (p)' translated.				#printIt}.		     
		{'inspect it (i)' translated.			#inspectIt}.		     
		{'explore it (I)' translated.			#exploreIt}.		     
		{'debug it' translated.				#debugIt}.		     
		#-.	     
		{'browse it (b)' translated.					#browseIt}.
		{'senders of it (n)' translated.				#sendersOfIt}.
		{'implementors of it (m)' translated.			#implementorsOfIt}.
		{'references to it (N)' translated.				#referencesToIt}.
		#-.
		{'more...' translated.					#shiftedTextPaneMenuRequest}.
	}
! !



!OBDefinitionPanel methodsFor: 'updating' stamp: 'cwp 4/18/2006 21:31'!
aboutToChange: ann
	| ok |
	self canDiscardEdits ifTrue: [^ true].
	ok _ OBConfirmationRequest
			prompt: 'Changes have not been saved.
Is it OK to discard those changes?'
			confirm: 'Discard changes'.
	ok
		ifTrue: [self changed: #clearUserEdits]
		ifFalse: [ann veto]! !

!OBDefinitionPanel methodsFor: 'updating' stamp: 'cwp 6/4/2006 11:31'!
definitionChanged: ann
	definition _ ann definition.
	self changed: #text! !

!OBDefinitionPanel methodsFor: 'updating' stamp: 'cwp 6/3/2006 21:55'!
refresh: announcement
	| oldDefinition |
	definition ifNil: [^ self].
	oldDefinition _ definition.
	definition _ self getDefinition.
	definition text = oldDefinition text ifTrue: [^ self].
	self canDiscardEdits
			ifTrue: [self changed: #text]
			ifFalse: [self changed: #codeChangedElsewhere]! !

!OBDefinitionPanel methodsFor: 'updating' stamp: 'cwp 4/24/2006 16:06'!
selectionChanged: ann
	self definition: self getDefinition! !

!OBDefinitionPanel methodsFor: 'updating' stamp: 'cwp 6/4/2006 11:30'!
subscribe
	self announcer 
		observe: OBAboutToChange
		send: #aboutToChange:
		to: self;
		
		observe: OBSelectionChanged
		send: #selectionChanged:
		to: self;
		
		observe: OBRefreshRequired
		send: #refresh:
		to: self;
				
		observe: OBDefinitionChanged
		send: #definitionChanged: 
		to: self.! !


!OBDefinitionPanel methodsFor: '*ob-standard-cmds' stamp: 'pmm 7/6/2006 20:49'!
browseIt: aSymbol
	| entry |
	entry := self selectedClass environment at: aSymbol ifAbsent: [nil].
	entry ifNil: [^ self implementorsOfIt: aSymbol].
	(entry isBehavior or: [entry isTrait ])
		ifFalse: [entry := entry class].
	OBSystemBrowser openOnClass: entry.
	^ true
	! !

!OBDefinitionPanel methodsFor: '*ob-standard-cmds' stamp: 'avi 9/17/2005 01:36'!
implementorsOfIt: aSelector 
	OBImplementorsBrowser browseRoot: (OBSelectorNode on: aSelector).
	^true! !

!OBDefinitionPanel methodsFor: '*ob-standard-cmds' stamp: 'avi 9/17/2005 01:36'!
referencesToIt: aClassName 
	| class |
	class := self selectedClass environment at: aClassName ifAbsent: [^false].
	class isBehavior ifFalse: [^false].
	OBReferencesBrowser browseRoot: (OBClassNode on: class).
	^true! !

!OBDefinitionPanel methodsFor: '*ob-standard-cmds' stamp: 'avi 9/17/2005 01:36'!
sendersOfIt: aSelector 
	OBSendersBrowser browseRoot: (OBSelectorNode on: aSelector).
	^true! !
Notification subclass: #OBDispatcherRequest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Notifications'!
OBCodeNode subclass: #OBEnvironmentNode
	instanceVariableNames: 'environment'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBEnvironmentNode commentStamp: 'cwp 1/8/2005 13:01' prior: 0!
OBEnvironmentNode wraps an instance of SystemDictionary. In current Squeak images, there is only one such instance, but OB-Standard is coded so as to use rely on this assumption as little as possible. Thus OBEnvironmentNode typically serves as the root of the standard browser, and passes its environment on to other nodes in the tree.!


!OBEnvironmentNode methodsFor: 'navigating'!
categories
	^ environment organization categories collect: [:cat | OBClassCategoryNode 
															on: cat
															inEnvironment: environment]! !

!OBEnvironmentNode methodsFor: 'navigating' stamp: 'cwp 9/20/2005 08:43'!
categoryNodeNamed: aString 
	^ OBClassCategoryNode on: aString! !


!OBEnvironmentNode methodsFor: 'accessing'!
environment
	^ environment! !

!OBEnvironmentNode methodsFor: 'accessing'!
organization
	^ self environment organization! !


!OBEnvironmentNode methodsFor: 'displaying'!
name 
	^ 'Squeak'! !


!OBEnvironmentNode methodsFor: 'initializing'!
setEnvironment: anEnvironment
	environment := anEnvironment! !


!OBEnvironmentNode methodsFor: 'testing' stamp: 'cwp 6/30/2006 00:54'!
hasOrganization
	^ true! !

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

OBEnvironmentNode class
	instanceVariableNames: ''!

!OBEnvironmentNode class methodsFor: 'as yet unclassified'!
forImage
	^ self on: Smalltalk! !

!OBEnvironmentNode class methodsFor: 'as yet unclassified'!
on: anEnvironment
	^ self new setEnvironment: anEnvironment! !
Object subclass: #OBFilter
	instanceVariableNames: 'metaNode monitor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Kernel'!
!OBFilter commentStamp: 'cwp 3/4/2004 21:53' prior: 0!
A browser's metagraph defines the way in which the user may traverse the graph of objects which make up the browser's domain. But it's not always desirable to have all the nodes made available by the metagraph to be visible in the browser. An filter provides a strategy for filtering out some of the nodes from the display. 

OBFilter provides a "null" filter - one that does no filtering at all - and serves as a superclass for other filters. !


!OBFilter methodsFor: 'accessing' stamp: 'cwp 2/11/2004 23:48'!
metaNode
	^ metaNode! !

!OBFilter methodsFor: 'accessing' stamp: 'cwp 2/9/2004 20:56'!
monitor: aMonitor
	monitor _ aMonitor! !


!OBFilter methodsFor: 'initalizing' stamp: 'cwp 2/9/2004 20:54'!
setMetaNode: aMetaNode
	metaNode _ aMetaNode! !


!OBFilter methodsFor: 'public' stamp: 'cwp 2/9/2004 20:50'!
children
	^ metaNode children! !

!OBFilter methodsFor: 'public' stamp: 'cwp 2/9/2004 20:52'!
nodesForParent: aNode
	^ metaNode nodesForParent: aNode! !

!OBFilter methodsFor: 'public' stamp: 'cwp 2/29/2004 14:34'!
selectAncestorOf: aNode withParent: parentNode
	^ (metaNode nodesForParent: parentNode)
		detect: [:child | child isAncestorOf: aNode] 
		ifNone: [nil]! !


!OBFilter methodsFor: 'queries' stamp: 'cwp 2/9/2004 21:06'!
wantsButton
	^ false! !

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

OBFilter class
	instanceVariableNames: ''!

!OBFilter class methodsFor: 'as yet unclassified' stamp: 'cwp 2/9/2004 20:54'!
forMetaNode: aMetaNode
	^ self new setMetaNode: aMetaNode! !
OBPanel subclass: #OBFixedButtonPanel
	instanceVariableNames: 'models actions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Panels'!
!OBFixedButtonPanel commentStamp: 'cwp 1/7/2005 23:35' prior: 0!
OBFixedButtonPanel displays a horizontal row of buttons. In contrast to OBVarButtonPanel, the buttons do not change as nodes are selected in the navigation panel; instead they are enabled and disabled according to whether the actions they represent are applicable to the selected node.!


!OBFixedButtonPanel methodsFor: 'accessing' stamp: 'cwp 11/26/2004 22:53'!
buttonModels
	^ models! !


!OBFixedButtonPanel methodsFor: 'callbacks' stamp: 'cwp 11/27/2004 19:20'!
isEnabled: aModel
	^ (actions at: aModel) notNil! !

!OBFixedButtonPanel methodsFor: 'callbacks' stamp: 'cwp 11/27/2004 19:20'!
isSelected: aModel
	^ true! !

!OBFixedButtonPanel methodsFor: 'callbacks' stamp: 'cwp 8/29/2004 11:28'!
push: aModel
	(actions at: aModel) ifNotNilDo: [:action | action trigger]! !

!OBFixedButtonPanel methodsFor: 'callbacks' stamp: 'cwp 6/3/2006 22:15'!
selectionChanged: ann
	| node nodeActions |
	node _ browser currentNode ifNil: [^ self].
	nodeActions _ (node metaNode actionsForNode: node) select: [:ea | ea wantsButton].
	actions keys do: 
		[:model | 
		actions at: model put: nil.
		nodeActions do: 
			[:action | model label = action buttonLabel ifTrue: [actions at: model put: action]]].
	actions keys do: [:ea | ea selectionChanged].! !

!OBFixedButtonPanel methodsFor: 'callbacks' stamp: 'cwp 6/3/2006 22:14'!
subscribe
	self announcer
		observe: OBSelectionChanged
		send: #selectionChanged:
		to: self! !


!OBFixedButtonPanel methodsFor: 'constructing' stamp: 'lr 3/23/2006 18:14'!
createMorph
	^(RectangleMorph new)
		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		borderWidth: 0;
		wrapCentering: #center;
		cellPositioning: #leftCenter;
		rubberBandCells: true;
		layoutInset: 2;
		cellInset: 2;
		yourself! !

!OBFixedButtonPanel methodsFor: 'constructing' stamp: 'cwp 11/27/2004 21:24'!
morph
	| morph |
	morph := self createMorph.
	self buttonModels do: [:ea | morph addMorphBack: (self morphForModel: ea)].
	^morph! !

!OBFixedButtonPanel methodsFor: 'constructing' stamp: 'cwp 11/27/2004 21:25'!
morphForModel: aModel
	| morph paneColor |
	morph _ aModel morph.
	paneColor _ browser defaultBackgroundColor.
	morph onColor: paneColor darker offColor: paneColor lighter.
	^ morph! !

!OBFixedButtonPanel methodsFor: 'constructing' stamp: 'lr 3/23/2006 18:15'!
morphHeight
	^ 30! !


!OBFixedButtonPanel methodsFor: 'initializing' stamp: 'cwp 11/26/2004 22:53'!
initialize
	models _ OrderedCollection new.
	actions _ Dictionary new.! !


!OBFixedButtonPanel methodsFor: 'public' stamp: 'cwp 11/26/2004 22:52'!
addButtonWithLabel: label
	| model |
	model _ OBButtonModel withLabel: label inBar: self.
	models add: model.
	actions at: model put: nil! !

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

OBFixedButtonPanel class
	instanceVariableNames: ''!

!OBFixedButtonPanel class methodsFor: 'as yet unclassified' stamp: 'cwp 2/28/2006 10:41'!
new
	^ self basicNew initialize! !
OBCodeBrowser subclass: #OBHierarchyBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!
!OBHierarchyBrowser commentStamp: 'cwp 1/7/2005 23:50' prior: 0!
OBHierarchyBrowser provides a three-pane browers that displays a class within it's surrounding hierarchy - both superclasses and subclasses!


!OBHierarchyBrowser methodsFor: 'as yet unclassified' stamp: 'cwp 12/13/2004 00:40'!
defaultBackgroundColor
	^ Color lightGreen! !

!OBHierarchyBrowser methodsFor: 'as yet unclassified' stamp: 'cwp 12/13/2004 01:00'!
defaultLabel
	^ self root name, ' Hierarchy'! !

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

OBHierarchyBrowser class
	instanceVariableNames: ''!

!OBHierarchyBrowser class methodsFor: 'configuration' stamp: 'avi 9/17/2005 01:06'!
defaultMetaNode
	^ self 
		addTo: (OBMetaNode named: 'RootClass')
		class: #classHierarchy 
		comment: #commentHierarchy 
		metaclass: #metaclassHierarchy.
! !

!OBHierarchyBrowser class methodsFor: 'configuration' stamp: 'cwp 12/13/2004 00:37'!
paneCount
	^ 3! !

!OBHierarchyBrowser class methodsFor: 'configuration' stamp: 'cwp 12/13/2004 01:00'!
titleForRoot: aNode
	^ aNode name, ' Hierarchy'! !


!OBHierarchyBrowser class methodsFor: 'instance creation' stamp: 'lr 3/6/2006 19:28'!
onClass: aClass 
	^self root: aClass asNode selection: aClass asNode! !


!OBHierarchyBrowser class methodsFor: 'opening' stamp: 'cwp 12/15/2004 22:49'!
openOnClass: aClass
	^ (self onClass: aClass) open! !
OBListBrowser subclass: #OBImplementorsBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!

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

OBImplementorsBrowser class
	instanceVariableNames: ''!

!OBImplementorsBrowser class methodsFor: 'as yet unclassified' stamp: 'cwp 3/2/2006 15:35'!
chaseImplementorsNav: navSelector
	| message implementor |
	message := OBMetaNode named: 'Message'.
	implementor := OBMetaNode named: 'Implementor'.
	implementor
		displaySelector: #indentedFullName;
		childAt: #messages put: message;
		addActor: OBNodeActor new.
	message
		childAt: navSelector labeled: 'implementors' put: implementor;
		addActor: OBNodeActor new.
	^ implementor! !

!OBImplementorsBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:24'!
defaultMetaNode
	^ self hierarchicalImplementors! !

!OBImplementorsBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:24'!
hierarchicalImplementors
	^ self implementorsNav: #implementorsHierarchically! !

!OBImplementorsBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:24'!
implementorsNav: navSelector
	| selector implementors |
	selector := OBMetaNode named: 'Selector'.
	implementors := OBMetaNode named: 'Implementors'.
	
	selector 
		childAt: navSelector labeled: 'list' put: implementors;
		childAt: navSelector labeled: 'chase' put: (self chaseImplementorsNav: navSelector);
		filterClass: OBModalFilter.
	implementors 
		displaySelector: #indentedFullName;
		addActor: OBNodeActor new.

	^ selector! !

!OBImplementorsBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:36'!
title
	^ 'Implementors of'! !
OBActor subclass: #OBImplementorsViewActor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Services'!

!OBImplementorsViewActor methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2006 14:28'!
actionsForParent: aNode
	^{OBAction
			label: 'add implementor' 
			receiver: self
			selector: #addImplementor:
			arguments: {aNode}
			keystroke: $a
			icon: self newIcon}! !

!OBImplementorsViewActor methodsFor: 'as yet unclassified' stamp: 'dvf 9/12/2005 16:34'!
addImplementor: aNode 
	| class sel |
	sel := aNode selector.
	class := self getClassForNewImplementationOf: sel.
	class ifNil: [^self].
	(class selectors includes: sel) 
		ifTrue: [^self inform: class name , ' already implements #' , sel].
	class compile: aNode selector , '
	self shouldBeImplemented'.
	(OBMethodNode on: sel inClass: class) signalSelection! !

!OBImplementorsViewActor methodsFor: 'as yet unclassified' stamp: 'dvf 9/12/2005 16:14'!
getClassForNewImplementationOf: sel 
	| className |
	className := (OBTextRequest 
				prompt: 'Please type class name in which to implement ' , sel
				template: '') ifNil: [''].
	^(Smalltalk classNamed: className withBlanksTrimmed) ifNil: 
			[self inform: 'Class ' , className , ' not found'.
			nil]! !
OBCodeBrowser subclass: #OBInheritanceBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!
!OBInheritanceBrowser commentStamp: 'cwp 1/7/2005 23:51' prior: 0!
OBInheritanceBrowser shows the inheritance hierarchy of a method, both superclass implementations which it overrides, and subclass implementations which override it.!


!OBInheritanceBrowser methodsFor: 'morphic' stamp: 'avi 11/29/2004 21:52'!
defaultBackgroundColor
	^ Color lightGreen! !

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

OBInheritanceBrowser class
	instanceVariableNames: ''!

!OBInheritanceBrowser class methodsFor: 'configuration' stamp: 'avi 9/17/2005 01:08'!
defaultMetaNode
	| method root |
	method := OBMetaNode named: 'Method'.
	root := OBMetaNode named: 'Root'.
	root
		childAt: #children put: method.
	method
		displaySelector: #fullName;
		childAt: #overrides put: method;
		addActor: OBNodeActor new.
	^ root! !

!OBInheritanceBrowser class methodsFor: 'configuration'!
title
	^ 'Inheritance'! !

!OBInheritanceBrowser class methodsFor: 'configuration' stamp: 'cwp 11/25/2004 22:05'!
titleForRoot: aCollectionNode
	^ 'Inheritance of ', aCollectionNode children first selector printString! !
OBVariableNode subclass: #OBInstanceVariableNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBInstanceVariableNode commentStamp: 'cwp 1/8/2005 12:50' prior: 0!
OBClassVariable provides a method for finding methods which refer to an instance, ie, by searching for instance variable access bytecodes rather than for an association in the literal frame.!


!OBInstanceVariableNode methodsFor: 'navigating' stamp: 'cwp 12/8/2004 23:48'!
accessors
	| accessors |
	accessors := OrderedCollection new.
	self theClass withAllSubAndSuperclassesDo: [:class |
		(class whichSelectorsAccess: name) asSortedCollection
			do: [:ea | ea = #DoIt ifFalse: [accessors add: 
					(self referenceForMethod: ea ofClass: class name)]]].
	^ accessors asArray	collect: [:ref | OBMethodNode on: ref]! !
Notification subclass: #OBInteractionRequest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Notifications'!
!OBInteractionRequest commentStamp: 'cwp 12/7/2004 00:13' prior: 0!
OBInteractionRequest is an abstract superclass for notifications that request some interaction with the user. It's useful for catching such notifications in an exception handler, while allowing other notifications to operate normally.!


!OBInteractionRequest methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2004 19:31'!
isBrowseRequest
	^ false! !
OBCodeBrowser subclass: #OBListBrowser
	instanceVariableNames: 'labelPrefix'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!
!OBListBrowser commentStamp: 'cwp 1/7/2005 23:53' prior: 0!
OBListBrowsers are used to display simple lists of methods, such as senders or implementors.!


!OBListBrowser methodsFor: 'morphic' stamp: 'avi 11/29/2004 21:58'!
defaultBackgroundColor
	^ Color lightBlue! !


!OBListBrowser methodsFor: 'accessing' stamp: 'cwp 11/25/2004 22:21'!
defaultLabel
	^ self labelPrefix, ' ', self root name printString! !

!OBListBrowser methodsFor: 'accessing' stamp: 'cwp 11/25/2004 22:18'!
labelPrefix
	^ labelPrefix ifNil: [labelPrefix _ self root metaNode edges first label capitalized, ' of']! !

!OBListBrowser methodsFor: 'accessing' stamp: 'cwp 10/17/2004 20:54'!
labelPrefix: aString
	labelPrefix _ aString! !

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

OBListBrowser class
	instanceVariableNames: ''!

!OBListBrowser class methodsFor: 'opening' stamp: 'avi 9/17/2005 01:34'!
browseRoot: aNode
	self browseRoot: aNode title: self title! !

!OBListBrowser class methodsFor: 'opening' stamp: 'avi 9/17/2005 01:21'!
browseRoot: aNode title: aString 
	(self metaNode: self defaultMetaNode root: aNode selection: nil)
		labelPrefix: aString;
		open
	! !


!OBListBrowser class methodsFor: 'configuration' stamp: 'cwp 12/5/2004 17:54'!
maxPanes
	^ 2! !

!OBListBrowser class methodsFor: 'configuration' stamp: 'cwp 12/5/2004 17:54'!
minPanes
	^ 1! !
OBMethodNode subclass: #OBMessageNode
	instanceVariableNames: 'message'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBMessageNode commentStamp: 'cwp 1/8/2005 12:40' prior: 0!
An OBMessageNode refers to a message send in the source code of a method. They are typically used in the 'senders' browser.!


!OBMessageNode methodsFor: 'navigating'!
implementors
	^ self implementorsOf: message! !

!OBMessageNode methodsFor: 'navigating'!
sendersOfMessage
	^ self sendersOf: message! !


!OBMessageNode methodsFor: 'displaying' stamp: 'cwp 12/8/2004 21:26'!
name
	^ message! !


!OBMessageNode methodsFor: 'accessing'!
selection
	| methodNode assoc |
	methodNode := Parser new 
					parse: self source
					class: self theClass.
	assoc := (methodNode encoder rawSourceRanges) 
			associations detect: [:ea | ea key isMessage: message receiver: nil arguments: nil]
						ifNone: [nil -> (1 to: 0)].
						"Some messages are generated by the compiler."
	^ assoc value! !


!OBMessageNode methodsFor: 'initializing'!
setMessage: aSelector selector: aSelector2 class: aClass
	message := aSelector.
	selector := aSelector2.
	self theClass: aClass! !

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

OBMessageNode class
	instanceVariableNames: ''!

!OBMessageNode class methodsFor: 'instance creation'!
fromMethodNode: aMethodNode
	^ self new 
		setMessage: aMethodNode selector
		selector: aMethodNode selector
		class: aMethodNode theClass! !

!OBMessageNode class methodsFor: 'instance creation'!
on: aSelector inMethodNode: aNode
	^ self 
		on: aSelector 
		inMethod: aNode selector 
		inClass: aNode theClass! !

!OBMessageNode class methodsFor: 'instance creation' stamp: 'cwp 12/8/2004 23:46'!
on: aSelector inMethodReference: ref
	^ self 
		on: aSelector 
		inMethod: ref methodSymbol
		inClass: ref actualClass! !

!OBMessageNode class methodsFor: 'instance creation'!
on: aSelector inMethod: aSelector2 inClass: classRef
	^ self new setMessage: aSelector selector: aSelector2 class: classRef! !
Object subclass: #OBMetaEdge
	instanceVariableNames: 'label selector metaNode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Kernel'!
!OBMetaEdge commentStamp: 'cwp 1/7/2005 23:20' prior: 0!
An OBMetaEdge is an edge in the browser's metagraph. It represents a message sent to a node to obtain further nodes. It is refered to by the "parent" metanode, and refers to the "child" metanode.

iVars:

label 		-  a string describing the metaNode, for filters which allow the user 
			   to choose which edges to follow
selector	- when a node is selected by the user, this message will be 
			  sent to it to obtain its children
metaNode 	- a MetaNode corresponding to the nodes answered by the above message
		!


!OBMetaEdge methodsFor: 'accessing' stamp: 'cwp 2/7/2004 22:40'!
label
	^ label! !

!OBMetaEdge methodsFor: 'accessing' stamp: 'cwp 2/7/2004 22:40'!
metaNode
	^ metaNode! !

!OBMetaEdge methodsFor: 'accessing' stamp: 'cwp 3/3/2004 00:12'!
nodesForParent: aNode
	^ (aNode perform: selector) do: [:ea | ea metaNode: metaNode]
! !

!OBMetaEdge methodsFor: 'accessing' stamp: 'cwp 2/7/2004 22:40'!
selector
	^ selector! !


!OBMetaEdge methodsFor: 'initializing' stamp: 'cwp 2/7/2004 22:36'!
setLabel: aString selector: aSelector metaNode: aMetaNode
	label _ aString.
	selector _ aSelector.
	metaNode _ aMetaNode! !


!OBMetaEdge methodsFor: 'printing' stamp: 'dvf 8/16/2005 10:03'!
printOn: aStream
	aStream nextPutAll: selector printString, '->'. 
	metaNode shortPrintOn: aStream.! !

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

OBMetaEdge class
	instanceVariableNames: ''!

!OBMetaEdge class methodsFor: 'as yet unclassified' stamp: 'cwp 2/7/2004 22:35'!
label: aString selector: aSelector metaNode: aMetaNode
	^ self new setLabel: aString selector: aSelector metaNode: aMetaNode! !

!OBMetaEdge class methodsFor: 'as yet unclassified' stamp: 'cwp 2/9/2004 22:32'!
selector: aSelector metaNode: aMetaNode
	^ self new setLabel: aSelector asString selector: aSelector metaNode: aMetaNode! !
Object subclass: #OBMetaNode
	instanceVariableNames: 'name filterClass columnClass edges actors displaySelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Kernel'!
!OBMetaNode commentStamp: 'cwp 1/7/2005 23:23' prior: 0!
A MetaNode represents a hypothetical node in the browser's domain graph.

iVars:

filterClass			- the class used to filter this hypothetical node's children
columnClass		- the class of column used to display this node's children
edges				- messages that could be sent to the node to obtain children
actors				- providers of functionality for manipulating the node
displaySelector		- the message used to retreive a nodes display name!


!OBMetaNode methodsFor: 'accessing' stamp: 'cwp 12/8/2004 21:41'!
displaySelector
	^ displaySelector ifNil: [displaySelector _ #name]! !

!OBMetaNode methodsFor: 'accessing' stamp: 'cwp 12/8/2004 21:42'!
displaySelector: aSelector
	displaySelector _ aSelector! !

!OBMetaNode methodsFor: 'accessing' stamp: 'cwp 3/6/2004 21:54'!
name
	^ name ifNil: ['MetaNode']! !

!OBMetaNode methodsFor: 'accessing' stamp: 'cwp 3/6/2004 21:05'!
name: aString
	name _ aString! !


!OBMetaNode methodsFor: 'actors' stamp: 'cwp 9/14/2004 18:59'!
actionSetsForNode: aNode
	^ actors collect: [:actor | actor actionsForNode: aNode]! !

!OBMetaNode methodsFor: 'actors' stamp: 'cwp 9/14/2004 19:01'!
actionSetsForParent: aNode
	^ actors collect: [:actor | actor actionsForParent: aNode]! !

!OBMetaNode methodsFor: 'actors' stamp: 'cwp 9/14/2004 19:00'!
actionsForNode: aNode
	^ (self actionSetsForNode: aNode) gather: [:ea | ea]! !

!OBMetaNode methodsFor: 'actors' stamp: 'cwp 9/14/2004 19:02'!
actionsForParent: aNode
	^ (self actionSetsForParent: aNode) gather: [:ea | ea]! !

!OBMetaNode methodsFor: 'actors' stamp: 'cwp 3/3/2004 22:48'!
addActor: anActor
	actors add: anActor.! !


!OBMetaNode methodsFor: 'children' stamp: 'cwp 2/9/2004 20:28'!
childAt: aSelector labeled: aString put: aMetaNode
	edges add: (OBMetaEdge label: aString selector: aSelector metaNode: aMetaNode)! !

!OBMetaNode methodsFor: 'children' stamp: 'cwp 2/7/2004 22:35'!
childAt: aSelector put: aMetaNode
	edges add: (OBMetaEdge selector: aSelector metaNode: aMetaNode)! !

!OBMetaNode methodsFor: 'children' stamp: 'cwp 2/7/2004 22:44'!
children
	^ edges collect: [:edge | edge metaNode]! !

!OBMetaNode methodsFor: 'children' stamp: 'cwp 2/7/2004 22:38'!
hasChildren
	^ edges isEmpty not! !


!OBMetaNode methodsFor: 'columns' stamp: 'avi 3/4/2004 03:11'!
columnClass: aClass
	columnClass _ aClass! !

!OBMetaNode methodsFor: 'columns' stamp: 'cwp 11/16/2004 22:03'!
columnInPanel: aBrowser node: aNode
	columnClass ifNil: [columnClass _ OBColumn].
	^ columnClass
		inPanel: aBrowser
		metaNode: self
		node: aNode! !


!OBMetaNode methodsFor: 'filtering' stamp: 'cwp 2/9/2004 21:26'!
filter
	filterClass ifNil: [filterClass _ OBFilter].
	^ filterClass forMetaNode: self! !

!OBMetaNode methodsFor: 'filtering' stamp: 'cwp 2/9/2004 21:02'!
filterClass: aClass
	filterClass _ aClass! !

!OBMetaNode methodsFor: 'filtering' stamp: 'cwp 2/9/2004 21:00'!
metaNode
	^ self! !


!OBMetaNode methodsFor: 'initializing' stamp: 'cwp 12/8/2004 20:06'!
initialize
	edges _ OrderedCollection new.
	actors _ OrderedCollection new.! !


!OBMetaNode methodsFor: 'metagraph' stamp: 'cwp 2/9/2004 21:12'!
edges
	^ edges! !


!OBMetaNode methodsFor: 'nodes' stamp: 'cwp 3/3/2004 00:22'!
nodesForParent: aNode
	^ edges gather: [:edge | edge nodesForParent: aNode]! !


!OBMetaNode methodsFor: 'printing' stamp: 'dvf 8/16/2005 10:01'!
printOn: aStream
	aStream nextPutAll: self name;cr.
	edges do: [:e | e printOn: aStream. aStream cr].! !

!OBMetaNode methodsFor: 'printing' stamp: 'dvf 8/16/2005 10:01'!
shortPrintOn: aStream
	aStream nextPutAll: self name.! !

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

OBMetaNode class
	instanceVariableNames: ''!

!OBMetaNode class methodsFor: 'instance creation' stamp: 'cwp 3/6/2004 21:06'!
named: aString
	^ self new name: aString! !

!OBMetaNode class methodsFor: 'instance creation' stamp: 'cwp 3/3/2004 23:08'!
new
	^ self basicNew initialize! !
OBClassNode subclass: #OBMetaclassNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBMetaclassNode commentStamp: 'cwp 1/8/2005 11:29' prior: 0!
OBMetaclassNode is essentially the same as an OBClassNode, but overrides a few methods to work properly with metaclasses.!


!OBMetaclassNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 21:57'!
browse
	^ OBSystemBrowser openOnClass: self theNonMetaClass ! !


!OBMetaclassNode methodsFor: 'displaying' stamp: 'cwp 12/13/2004 00:56'!
name 
	^ self nonMetaName! !

!OBMetaclassNode methodsFor: 'displaying'!
nonMetaName
	^ self theNonMetaClass name! !


!OBMetaclassNode methodsFor: 'initializing'!
setClass: aClass
	super setClass: aClass theMetaClass
		! !
OBClassAwareNode subclass: #OBMethodCategoryNode
	instanceVariableNames: 'name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBMethodCategoryNode commentStamp: 'cwp 1/8/2005 12:29' prior: 0!
OBMethodCategory represents a category within a ClassOrganization. Instead of an organization definition, OBMethodCategory presents a MethodDefinition with the class' default method template.!


!OBMethodCategoryNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 23:04'!
actions
	^ {
		self action: #fileOut withLabel: 'file out'.
		self browseAction.
		self browseHierarchyAction.
		self action: #chaseVars buttonLabel: 'variables' menuLabel: 'chase variables'
	}
! !

!OBMethodCategoryNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 21:50'!
browse
	OBSystemBrowser openOnClass: self theClass category: name! !

!OBMethodCategoryNode methodsFor: 'actions'!
fileOut
	self theClass fileOutCategory: name! !

!OBMethodCategoryNode methodsFor: 'actions' stamp: 'cwp 9/19/2004 00:11'!
remove
	self theClass removeCategory: name.
	self signalDeletion! !


!OBMethodCategoryNode methodsFor: 'ancestry'!
ancestrySelector
	^ #isDescendantOfMethodCat:! !

!OBMethodCategoryNode methodsFor: 'ancestry'!
isDescendantOfMethodCat: other
	^ (other theClassName = self theClassName) and: [other name = name]! !


!OBMethodCategoryNode methodsFor: 'accessing'!
category
	^ name! !

!OBMethodCategoryNode methodsFor: 'accessing'!
container
	^ self theClass! !

!OBMethodCategoryNode methodsFor: 'accessing' stamp: 'cwp 9/14/2005 09:06'!
methodReferences
	^ (self theClass organization listAtCategoryNamed: name)
		collect: [:ea | MethodReference new
						setClassSymbol: self theNonMetaClassName
						classIsMeta: self theClass isMeta
						methodSymbol: ea
						stringVersion: '']
! !

!OBMethodCategoryNode methodsFor: 'accessing' stamp: 'dvf 8/16/2005 17:47'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $<.
	self name printOn: aStream.
	aStream nextPut: $>.! !


!OBMethodCategoryNode methodsFor: 'public'!
definition
	^ OBMethodDefinition inCategory: self category inClass: self theClass! !

!OBMethodCategoryNode methodsFor: 'public'!
name
	^ name! !


!OBMethodCategoryNode methodsFor: 'drag and drop' stamp: 'lr 4/6/2006 11:46'!
dropOnClass: aNode
	self methods do: [ :each | each dropOnClass: aNode ].
	aNode signalChildrenChanged.
	^ true! !

!OBMethodCategoryNode methodsFor: 'drag and drop'!
dropSelector
	^ #dropOnMethodCategory:! !


!OBMethodCategoryNode methodsFor: 'comparing' stamp: 'cwp 12/20/2004 00:53'!
hash
	^ self name hash! !

!OBMethodCategoryNode methodsFor: 'comparing' stamp: 'cwp 12/20/2004 00:50'!
= other
	self species = other species ifFalse: [^ false].	
	self theClass = other theClass ifFalse: [^ false].
	^ self name = other name! !


!OBMethodCategoryNode methodsFor: 'navigating' stamp: 'dvf 8/19/2005 17:16'!
methods
	^ self methodReferences collect: [:ref | ref asNode]! !


!OBMethodCategoryNode methodsFor: 'initializing'!
setName: aString class: aClass
	name := aString.
	self theClass: aClass! !


!OBMethodCategoryNode methodsFor: 'testing' stamp: 'cwp 6/30/2006 00:48'!
hasOrganization
	^ true! !

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

OBMethodCategoryNode class
	instanceVariableNames: ''!

!OBMethodCategoryNode class methodsFor: 'actions' stamp: 'cwp 9/18/2004 22:58'!
actionsForParent: aNode
	^ #()! !


!OBMethodCategoryNode class methodsFor: 'instance creation'!
on: aString inClass: aClassReference
	^ self new setName: aString class: aClassReference! !
OBDefinition subclass: #OBMethodDefinition
	instanceVariableNames: 'theClass category source selection callback'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Definitions'!
!OBMethodDefinition commentStamp: 'cwp 1/8/2005 13:20' prior: 0!
OBMethodDefinition knows how to present method source in the browser's text pane and compile a new CompiledMethod when the source changes. It implements several safety checks to ensure that methods are not accidentally overwritten.!


!OBMethodDefinition methodsFor: 'callbacks' stamp: 'cwp 9/18/2005 14:53'!
accept: aText notifying: aController
	| newSelector |
	newSelector := self compileMethod: aText notifying: aController.
	newSelector ifNil: [^ false].
	(self nodeFor: newSelector) demandSelection.
	^ true! !

!OBMethodDefinition methodsFor: 'callbacks' stamp: 'cwp 10/17/2004 23:16'!
redefineSource: aText selector: newSelector
	newSelector = self selector 
		ifTrue: [source := aText]
		ifFalse: [(self methodNodeFor: newSelector) signalSelection].
! !

!OBMethodDefinition methodsFor: 'callbacks'!
selectedClass
	^ self theClass! !

!OBMethodDefinition methodsFor: 'callbacks'!
selection
	^ selection ifNil: [1 to: (source ifNil: [self text size] ifNotNil: [0])]! !

!OBMethodDefinition methodsFor: 'callbacks' stamp: 'cwp 11/29/2004 21:21'!
text
	^ source 
		ifNotNil: [source asText makeSelectorBold]
		ifNil: [self theClass sourceCodeTemplate]! !


!OBMethodDefinition methodsFor: 'accessing' stamp: 'cwp 10/17/2004 23:36'!
callback: aBlockContext 
	callback _ aBlockContext! !

!OBMethodDefinition methodsFor: 'accessing'!
category
	^ category ifNil: [category := self theClass whichCategoryIncludesSelector: self selector]! !

!OBMethodDefinition methodsFor: 'accessing'!
selector
	^ source ifNotNil: [Parser new parseSelector: source]! !

!OBMethodDefinition methodsFor: 'accessing'!
theClass
	^ theClass! !


!OBMethodDefinition methodsFor: 'compiling'!
compileMethod: aText notifying: aController
	^ (self confirmMethod: aText)
		ifTrue: [self theClass 
					compile: aText 
					classified: self category 
					notifying: aController]
		ifFalse: [nil]! !

!OBMethodDefinition methodsFor: 'compiling' stamp: 'cwp 10/17/2004 23:33'!
nodeFor: aSelector
	^ callback value: aSelector! !


!OBMethodDefinition methodsFor: 'confirming' stamp: 'cwp 10/17/2004 22:42'!
confirmMethod: aText
	| sel |
	sel _ Parser new parseSelector: aText.
	^ (self theClass isMeta 
			and: [(self selectorAlreadyDefined: sel) not] 
			and: [Metaclass isScarySelector: sel])
				ifTrue: [self confirmScarySelector: sel]
				ifFalse: [^ true]! !

!OBMethodDefinition methodsFor: 'confirming'!
confirmScarySelector: aSelector
	| prompt |
	prompt := aSelector, ' is used in the existing class system.
Overriding it could cause serious problems.
Is this really what you want to do?'.

	^ OBConfirmationRequest
		prompt: prompt
		confirm: 'Override'! !

!OBMethodDefinition methodsFor: 'confirming'!
selectorAlreadyDefined: aSelector
	^ self theClass selectors includes: aSelector! !


!OBMethodDefinition methodsFor: 'initializing' stamp: 'cwp 10/17/2004 23:33'!
setClass: aClass category: aString source: aText selection: anInterval
	theClass := aClass.
	category := aString.
	source := aText.
	selection := anInterval.
	callback := [:sel | OBMethodNode on: sel inClass: theClass]! !

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

OBMethodDefinition class
	instanceVariableNames: ''!

!OBMethodDefinition class methodsFor: 'instance creation' stamp: 'cwp 10/17/2004 23:07'!
inCategory: aString inClass: aClass
	^ self 
		selection: nil
		source: nil
		inCategory: aString
		inClass: aClass! !

!OBMethodDefinition class methodsFor: 'instance creation' stamp: 'cwp 10/17/2004 23:07'!
selection: anInterval source: aText inCategory: aCategory inClass: aClass
	^ self new
		setClass: aClass
		category: aCategory
		source: aText
		selection: anInterval! !

!OBMethodDefinition class methodsFor: 'instance creation' stamp: 'cwp 10/17/2004 23:07'!
selection: anInterval source: aText inClass: aClass
	^ self 
		selection: anInterval
		source: aText
		inCategory: nil
		inClass: aClass	! !

!OBMethodDefinition class methodsFor: 'instance creation' stamp: 'cwp 10/17/2004 23:03'!
source: aText inClass: aClass
	^ self 
		selection: nil
		source: aText
		inCategory: nil
		inClass: aClass! !
OBClassAwareNode subclass: #OBMethodNode
	instanceVariableNames: 'selector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBMethodNode commentStamp: 'cwp 1/8/2005 12:37' prior: 0!
OBMethodNode wraps a method in a particular class. It supplies an OBMethodDefinition for displaying and editing the source code of the method, and various actions for manipulating the method. It has two roles: first it appears in the right most pane of a standard system browser. Second, it often serves as the root node for an OBListBrowser, and has navigation methods for senders, implementors etc.

OBMethodNode also serves as the superclass for nodes that represent *parts* of a method, such as sends of a particular message, references to a class, accesses to a instance variable, etc.!


!OBMethodNode methodsFor: 'actions' stamp: 'cwp 7/12/2006 15:36'!
actions
	^{ 
		self action: #fileOut withLabel: 'file out'.
		self browseAction.
		self browseHierarchyAction.
		self 
			action: #browseSenders
			withMenuLabel: 'senders'
			withButtonLabel: 'senders'
			withKeystroke: $n
			withIcon: (MenuIcons tryIcons: #(findIcon smallFindIcon)).
		self 
			action: #browseImplementors
			withMenuLabel: 'implementors'
			withButtonLabel: 'implementors'
			withKeystroke: $m
			withIcon: (MenuIcons tryIcons: #(findIcon smallFindIcon)).
		self 
			action: #browseVersions
			buttonLabel: 'versions'
			menuLabel: 'versions'.
		self 
			action: #browseInheritance
			buttonLabel: 'inheritance'
			menuLabel: 'inheritance'.
		self 
			action: #chaseVars
			buttonLabel: 'variables'
			menuLabel: 'chase variables'.
		self 
			action: #remove
			withLabel: 'remove'
			withKeystroke: $x
			withIcon: (MenuIcons tryIcons: #(deleteIcon smallDeleteIcon)).
		self moveToPackageAction
	}
! !

!OBMethodNode methodsFor: 'actions' stamp: 'cwp 12/5/2004 18:35'!
browse
	OBSystemBrowser openOnClass: self theClass selector: selector! !

!OBMethodNode methodsFor: 'actions' stamp: 'avi 9/17/2005 01:29'!
browseClass: aClass
	aClass browseRoot: self copy! !

!OBMethodNode methodsFor: 'actions' stamp: 'avi 9/17/2005 01:28'!
browseImplementors
	self browseClass: OBImplementorsBrowser! !

!OBMethodNode methodsFor: 'actions' stamp: 'cwp 12/5/2004 18:03'!
browseInheritance
	OBInheritanceBrowser openRoot: self inheritanceRoot selection: self! !

!OBMethodNode methodsFor: 'actions' stamp: 'avi 9/17/2005 01:28'!
browseSenders
	self browseClass: OBSendersBrowser! !

!OBMethodNode methodsFor: 'actions' stamp: 'cwp 12/5/2004 15:42'!
browseVersions
	OBVersionBrowser openOn: self copy! !

!OBMethodNode methodsFor: 'actions'!
fileOut
	self theClass fileOutMethod: selector! !

!OBMethodNode methodsFor: 'actions' stamp: 'cwp 7/11/2006 02:43'!
moveToPackage
	| packagesNames selection packages |
	packages := PackageOrganizer default packages 
					asSortedCollection: [:a :b | a packageName <= b packageName].
	packagesNames := packages collect: [:ea | ea packageName].
	selection := OBChoiceRequest prompt: nil labels: packagesNames values: packages.
	selection ifNotNil: [selection addMethod: self reference].! !

!OBMethodNode methodsFor: 'actions' stamp: 'cwp 7/12/2006 15:37'!
moveToPackageAction
	^ self 
		action: #moveToPackage
		withMenuLabel: 'move to package...'
		withButtonLabel: 'move method'
		withKeystroke: $p
		withIcon: (MenuIcons tryIcons: #(windowIcon smallWindowIcon)).
! !

!OBMethodNode methodsFor: 'actions' stamp: 'cwp 10/18/2004 00:30'!
remove
	| senders choice |
	senders _ SystemNavigation default allCallsOn: self selector.
	senders isEmpty ifTrue: [^ self doRemove].
	choice _ OBChoiceRequest
				prompt: 'This message has ', senders size asString, ' senders.'
				labels: #('Remove it' 
						'Remove, then browse senders' 
						'Don''t remove, but show me those senders' 
						'Forget it -- do nothing -- sorry I asked')
				values: #(doRemove removeAndBrowse simpleBrowseSenders nil).
	choice ifNotNil: [^ self perform: choice]
! !

!OBMethodNode methodsFor: 'actions'!
selectMessage
	| messages sel |
	messages := self messageSelectors copyWithFirst: selector.
	sel := (OBChoiceRequest labels: messages).
	^ sel ifNotNil: [OBMessageNode on: sel inMethodNode: self]! !

!OBMethodNode methodsFor: 'actions' stamp: 'cwp 12/1/2004 00:36'!
source
	^ (self theClass sourceCodeAt: self selector ifAbsent: [^ '']) 
		asText makeSelectorBold! !


!OBMethodNode methodsFor: 'private'!
addOverridersOf: aSelector inClass: aClass to: aCollection
	aClass subclasses do: 
		[:ea | (ea includesSelector: aSelector)
					ifTrue: [aCollection add: ea]
					ifFalse: [self addOverridersOf: aSelector inClass: ea to: aCollection]]! !

!OBMethodNode methodsFor: 'private' stamp: 'cwp 10/18/2004 00:29'!
doRemove
	self theClass removeSelector: self selector.
	self signalDeletion! !

!OBMethodNode methodsFor: 'private' stamp: 'cwp 12/8/2004 23:48'!
implementorsOf: aSelector
	^ (SystemNavigation default allImplementorsOf: aSelector) asSortedArray
			collect: [:ref | OBMethodNode on: ref]! !

!OBMethodNode methodsFor: 'private' stamp: 'cwp 12/8/2004 23:49'!
inheritanceRoot
	| rootClass |
	rootClass := (self theClass withAllSuperclasses asArray
					select: [:ea | ea includesSelector: self selector]) last.
	^ OBCollectionNode on: {OBMethodNode 
								on: self selector 
								inClass: rootClass}! !

!OBMethodNode methodsFor: 'private'!
messageSelectors
	^ ((self theClass compiledMethodAt: self selector ifAbsent: [^ #()]) messages) asSortedArray! !

!OBMethodNode methodsFor: 'private'!
removeAndBrowse
	self simpleBrowseSenders.
	self theClass removeSelector: self selector.
	self signalDeletion! !

!OBMethodNode methodsFor: 'private'!
sendersOf: aSelector
	^ (SystemNavigation default allCallsOn: aSelector) asSortedArray
			collect: [:ref | OBMessageNode on: aSelector inMethodReference: ref]! !

!OBMethodNode methodsFor: 'private' stamp: 'avi 9/17/2005 01:29'!
simpleBrowseSenders
	OBSendersBrowser browseRoot: self! !

!OBMethodNode methodsFor: 'private'!
sourcePointer
	^ (self theClass compiledMethodAt: self selector) sourcePointer! !


!OBMethodNode methodsFor: 'ancestry'!
ancestrySelector
	^ #isDescendantOfMethod: ! !

!OBMethodNode methodsFor: 'ancestry' stamp: 'cwp 12/2/2004 23:28'!
isDescendantOfMethodCat: aMethodCatNode
	^ (self theClass organization categoryOfElement: self selector) = aMethodCatNode name! !

!OBMethodNode methodsFor: 'ancestry' stamp: 'cwp 10/17/2004 23:55'!
isDescendantOfMethodVersion: anOBMethodVersionNode 
	^ false! !

!OBMethodNode methodsFor: 'ancestry' stamp: 'cwp 11/28/2004 10:37'!
isDescendantOfMethod: other
	^ other selector = selector
		and: [self theClass withAllSuperclasses includes: other theClass].
	! !


!OBMethodNode methodsFor: 'accessing' stamp: 'cwp 12/1/2004 00:36'!
definition
	^ OBMethodDefinition
		selection: self selection
		source: self source
		inClass: self theClass! !

!OBMethodNode methodsFor: 'accessing'!
reference
	^ self referenceForMethod: selector ofClass: self theClassName! !

!OBMethodNode methodsFor: 'accessing' stamp: 'cwp 12/1/2004 00:37'!
selection
	^ 1 to: 0! !

!OBMethodNode methodsFor: 'accessing'!
selector
	^ selector! !

!OBMethodNode methodsFor: 'accessing'!
sourceFiles
	^ OBSourceFilesRequest signal! !


!OBMethodNode methodsFor: 'drag and drop' stamp: 'lr 4/18/2006 08:55'!
dropOnClass: aNode
	aNode theClass 
		compile: self source
		classified: (self theClass organization 
			categoryOfElement: self selector).
	InputSensor default shiftPressed
		ifFalse: [ self theClass removeSelector: self selector ].
	aNode signalChildrenChanged.
	^ true! !

!OBMethodNode methodsFor: 'drag and drop' stamp: 'cwp 9/18/2005 19:01'!
dropOnMethodCategory: aNode

	"We don't support dropping on another class yet."
	aNode theClass = self theClass ifFalse: [^ false].
	
	self theClass organization classify: self selector under: aNode name.
	aNode signalChildrenChanged.
	
	^ true! !


!OBMethodNode methodsFor: 'displaying' stamp: 'lr 3/29/2006 12:08'!
displayString
	^ (self theClass respondsTo: #includesLocalSelector:) 
		ifFalse: [ super displayString ]
		ifTrue: [
			(self theClass includesLocalSelector: selector)
				ifTrue: [ super displayString  ]
				ifFalse: [ 
					super displayString asText 
						addAttribute: TextEmphasis italic ] ]! !

!OBMethodNode methodsFor: 'displaying' stamp: 'cwp 12/8/2004 21:08'!
fullName
	^ self theClassName, '>>', selector! !

!OBMethodNode methodsFor: 'displaying' stamp: 'cwp 12/20/2004 23:13'!
indentedFullName
	^ self indent, self fullName! !

!OBMethodNode methodsFor: 'displaying' stamp: 'cwp 12/8/2004 21:08'!
name
	^ selector! !


!OBMethodNode methodsFor: 'comparing' stamp: 'cwp 12/8/2004 22:07'!
hash
	^ theClass hash bitXor: selector hash! !

!OBMethodNode methodsFor: 'comparing' stamp: 'cwp 12/8/2004 22:07'!
= other
	^ (self species = other species)
		and: [self theClass = other theClass] 
		and: [self selector = other selector]! !


!OBMethodNode methodsFor: 'navigating' stamp: 'cwp 1/2/2005 23:12'!
implementors
	^ self implementorsOf: selector! !

!OBMethodNode methodsFor: 'navigating' stamp: 'cwp 1/7/2005 22:35'!
implementorsHierarchically
	^ OBClassAwareNode sortHierarchically: self implementors! !

!OBMethodNode methodsFor: 'navigating'!
messages
	^ (((self theClass
				compiledMethodAt: self selector 
				ifAbsent: [^ #()]) messages) asSortedArray)
					collect: [:sel | OBMessageNode 
									on: sel 
									inMethod: selector 
									inClass: self theClass]! !

!OBMethodNode methodsFor: 'navigating' stamp: 'cwp 12/8/2004 23:49'!
overrides
	| classes |
	classes := OrderedCollection new.
	self addOverridersOf: self selector inClass: self theClass to: classes.
	^ classes collect: [:ea | OBMethodNode on: selector inClass: ea] ! !

!OBMethodNode methodsFor: 'navigating'!
selectorAndMessages
	^ self messages copyWithFirst: self messageNode! !

!OBMethodNode methodsFor: 'navigating'!
senders
	^ self sendersOf: selector! !

!OBMethodNode methodsFor: 'navigating'!
versions
	^ (OBMethodVersion scan: self sourceFiles from: self sourcePointer)
		collect: [:ea | OBMethodVersionNode on: ea]! !


!OBMethodNode methodsFor: 'nodes'!
messageNode
	^ OBMessageNode fromMethodNode: self! !


!OBMethodNode methodsFor: 'printing' stamp: 'cwp 12/8/2004 21:59'!
printOn: aStream
	aStream
		nextPutAll: self class name;
		nextPut: $<;
		nextPutAll: self theClass name;
		nextPut: $#;
		nextPutAll: self selector;
		nextPut: $>! !


!OBMethodNode methodsFor: 'initializing'!
setReference: aMethodReference
	self 
		setSelector: aMethodReference methodSymbol
		class: (aMethodReference actualClass)! !

!OBMethodNode methodsFor: 'initializing'!
setSelector: aSelector class: aClass
	selector := aSelector.
	self theClass: aClass
! !

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

OBMethodNode class
	instanceVariableNames: ''!

!OBMethodNode class methodsFor: 'instance creation'!
on: aMethodReference
	^ self new setReference: aMethodReference! !

!OBMethodNode class methodsFor: 'instance creation'!
on: aSelector inClass: aClassReference
	^ self new setSelector: aSelector class: aClassReference! !
Object subclass: #OBMethodVersion
	instanceVariableNames: 'sources pointer classRef className category stamp prior selector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Utilities'!
!OBMethodVersion commentStamp: 'cwp 1/8/2005 13:25' prior: 0!
OBMethodVerison represents a version of a method found in the .sources or .changes files. It provides methods for parsing the method definition referenced by a source pointer, and for filing in the source to replace the current version of the method.!


!OBMethodVersion methodsFor: 'accessing'!
category
	^ category! !

!OBMethodVersion methodsFor: 'accessing'!
classSymbol
	^ classRef name! !

!OBMethodVersion methodsFor: 'accessing' stamp: 'cwp 10/17/2004 23:51'!
latest
	^ self class 
			fromSources: sources 
			andPointer: (classRef theClass compiledMethodAt: selector) sourcePointer! !

!OBMethodVersion methodsFor: 'accessing' stamp: 'cwp 10/17/2004 23:42'!
pointer
	^ pointer! !

!OBMethodVersion methodsFor: 'accessing'!
selector
	^ selector ifNil: [self setSelector]! !

!OBMethodVersion methodsFor: 'accessing'!
source
	| file |
	file := sources at: (sources fileIndexFromSourcePointer: pointer).
	file position: (sources filePositionFromSourcePointer: pointer).
	^ file nextChunk asText makeSelectorBold! !

!OBMethodVersion methodsFor: 'accessing'!
stamp
	^ stamp! !

!OBMethodVersion methodsFor: 'accessing'!
theClass
	^ classRef theClass! !

!OBMethodVersion methodsFor: 'accessing'!
theClassName
	^ classRef name! !


!OBMethodVersion methodsFor: 'compiling'!
fileIn
	(self theClass) ifNotNilDo: [:class | class
						 				compile: self source 
										classified: self category 
										withStamp: self stamp 
										notifying: nil]
						
						! !


!OBMethodVersion methodsFor: 'comparing' stamp: 'cwp 10/17/2004 23:45'!
hash
	^ pointer hash! !

!OBMethodVersion methodsFor: 'comparing' stamp: 'cwp 10/17/2004 23:45'!
= other
	^ self species = other species and: [self pointer = other pointer]! !


!OBMethodVersion methodsFor: 'initializing' stamp: 'cwp 11/6/2004 23:14'!
parseChunk: aString
	| tokens |
	tokens := Scanner new scanTokens: aString.
	classRef := OBClassReference named: tokens first.
	tokens second = #class
		ifTrue: [classRef beMeta.
				category := tokens fourth.
				stamp := tokens sixth]
		ifFalse: [category := tokens third.
				tokens size > 3 ifTrue: [stamp := tokens fifth]].
	tokens size > 6 ifTrue: [prior := tokens last].! !

!OBMethodVersion methodsFor: 'initializing'!
parseSource
	| file position chunk |
	file := sources at: (sources fileIndexFromSourcePointer: pointer).
	position := sources filePositionFromSourcePointer: pointer.
	position > file size ifTrue: [self error: 'Invalid source pointer'].
	
	file position: (0 max: position-150).  	"Skip back to before the preamble"
		[file position < (position-1)]  	"then pick it up from the front"
			whileTrue: [chunk := file nextChunk].
	
	self parseChunk: chunk.! !

!OBMethodVersion methodsFor: 'initializing'!
previous
	^ prior ifNotNil: [self class fromSources: sources andPointer: prior]! !

!OBMethodVersion methodsFor: 'initializing'!
setSelector
	| file |
	file := sources at: (sources fileIndexFromSourcePointer: pointer).
	file position: (sources filePositionFromSourcePointer: pointer).
	^ selector := Parser new parseSelector: file nextChunk.! !

!OBMethodVersion methodsFor: 'initializing'!
setSources: aSourceFileArray pointer: aSourcePointer
	sources := aSourceFileArray.
	pointer := aSourcePointer.
	self parseSource.! !

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

OBMethodVersion class
	instanceVariableNames: ''!

!OBMethodVersion class methodsFor: 'instance creation'!
fromSources: sources andPointer: pointer
	^ self new setSources: sources pointer: pointer! !


!OBMethodVersion class methodsFor: 'scanning'!
scan: sources from: pointer 
	| versions current |
	
	versions := OrderedCollection new.
	current := OBMethodVersion fromSources: sources andPointer: pointer.
	[current notNil]
		whileTrue: [versions add: current.
					current := current previous].
	^ versions! !

!OBMethodVersion class methodsFor: 'scanning'!
versionsOfMethod: methodReference 
	| class selector |
	class := methodReference actualClass.
	selector := methodReference methodSymbol.
	^ self scan: SourceFiles from: (class compiledMethodAt: selector) sourcePointer! !
OBClassAwareNode subclass: #OBMethodVersionNode
	instanceVariableNames: 'version'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBMethodVersionNode commentStamp: 'cwp 1/8/2005 12:41' prior: 0!
OBMethodVersions refer to OBMethodVersions, and are used by the VersionBrowser.!


!OBMethodVersionNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 22:38'!
actions
	^ {
		self browseAction.
	  	self action: #revert buttonLabel: 'revert' menuLabel: 'revert to selected version'
	}! !

!OBMethodVersionNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 21:51'!
browse
	OBSystemBrowser openOnClass: self theClass selector: version selector! !

!OBMethodVersionNode methodsFor: 'actions'!
revert
	version fileIn! !


!OBMethodVersionNode methodsFor: 'ancestry' stamp: 'cwp 10/17/2004 23:41'!
ancestrySelector
	^ #isDescendantOfMethodVersion:! !

!OBMethodVersionNode methodsFor: 'ancestry' stamp: 'cwp 10/17/2004 23:43'!
isDescendantOfMethodVersion: aNode
	^ (version = aNode version)! !


!OBMethodVersionNode methodsFor: 'accessing' stamp: 'cwp 10/17/2004 23:57'!
category
	^ self theClass organization categoryOfElement: version selector! !

!OBMethodVersionNode methodsFor: 'accessing'!
reference
	^ self referenceForMethod: version selector ofClass: self theClassName.! !

!OBMethodVersionNode methodsFor: 'accessing' stamp: 'cwp 10/17/2004 23:44'!
version
	^ version! !


!OBMethodVersionNode methodsFor: 'compiling' stamp: 'cwp 10/17/2004 23:53'!
definition
	^ (OBMethodDefinition source: version source inClass: self theClass)
		callback: [:sel | 
					version selector = sel
						ifTrue: [self class on: version latest]
						ifFalse: [OBMethodNode on: sel inClass: self theClass]]! !


!OBMethodVersionNode methodsFor: 'displaying' stamp: 'cwp 11/27/2004 21:38'!
name
	| stamp |
	stamp := version stamp ifNil: ['<timestamp missing>'].
	^ version theClassName, '>>', version selector, ' ', stamp! !


!OBMethodVersionNode methodsFor: 'initializing'!
setVersion: aMethodVersion
	version := aMethodVersion.
	self theClass: version theClass! !

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

OBMethodVersionNode class
	instanceVariableNames: ''!

!OBMethodVersionNode class methodsFor: 'instance creation'!
on: aMethodVersion 
	^ self new setVersion: aMethodVersion! !
OBFilter subclass: #OBModalFilter
	instanceVariableNames: 'selection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Utilities'!
!OBModalFilter commentStamp: 'cwp 1/7/2005 23:39' prior: 0!
OBModalFilter is used to implement the 'instance/?/class' buttons in a standard class browser. In functional terms it filters the nodes of a column according to the edge of the metagraph that they correspond to. OBModalFilter displays an OBRadioButtonBar in its column's pane, with one button per edge. Only nodes from the currently selected edge are allowed in the column.

iVars:

selection	- the currently selected edge!


!OBModalFilter methodsFor: 'callbacks' stamp: 'cwp 2/25/2004 00:28'!
list
	^ metaNode edges collect: [:edge | edge label]! !

!OBModalFilter methodsFor: 'callbacks' stamp: 'cwp 2/9/2004 21:10'!
selection
	^ selection ifNil: [selection _ 1]! !

!OBModalFilter methodsFor: 'callbacks' stamp: 'cwp 6/6/2006 00:20'!
selection: anInteger
	selection _ anInteger.
	self changed: #selection.
	monitor listChanged.
! !


!OBModalFilter methodsFor: 'morphs' stamp: 'cwp 11/27/2004 18:01'!
buttonMorph
	^ OBRadioButtonBar
		on: self
		list: #list
		selected: #selection
		changeSelected: #selection:! !


!OBModalFilter methodsFor: 'public' stamp: 'cwp 3/3/2004 00:23'!
nodesForParent: aNode
	^ self selectedEdge nodesForParent: aNode! !

!OBModalFilter methodsFor: 'public' stamp: 'cwp 2/29/2004 14:35'!
selectAncestorOf: aNode withParent: parentNode
	| ancestor |
	1 	to: metaNode edges size 
	  	do: [:i | selection _ i.
			ancestor _ (self nodesForParent: parentNode)
				detect: [:child | child isAncestorOf: aNode] 
				ifNone: [nil].
			ancestor ifNotNil: [self changed: #selection. ^ ancestor]].
	^ nil! !


!OBModalFilter methodsFor: 'queries' stamp: 'cwp 2/9/2004 21:08'!
wantsButton
	^ true! !


!OBModalFilter methodsFor: 'selection' stamp: 'cwp 2/9/2004 21:11'!
incrementSelection
	selection _ selection + 1.
	(selection > metaNode edges size) ifTrue: [selection _ 1].! !

!OBModalFilter methodsFor: 'selection' stamp: 'cwp 2/9/2004 21:11'!
selectedEdge
	^ metaNode edges at: self selection ! !
Object subclass: #OBMorphicPanelLayout
	instanceVariableNames: 'panels'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBMorphicPanelLayout commentStamp: 'cwp 1/7/2005 23:42' prior: 0!
OBMorphicPanelLayout implements a somewhat hairy algorithm for layoung out panels in a morphic SystemWindow. It is the default layout strategy used by OBBrowser. Subclasses of OBBrowser may use other layout strategies to customize their appearance.!


!OBMorphicPanelLayout methodsFor: 'initializing' stamp: 'cwp 11/21/2004 00:23'!
setPanels: aCollection 
	panels := aCollection! !


!OBMorphicPanelLayout methodsFor: 'public' stamp: 'cwp 11/21/2004 00:26'!
addMorphsTo: aMorph
	self addNavMorphTo: aMorph.
	(panels size > 1) ifTrue: [self addOtherMorphsTo: aMorph].
	! !


!OBMorphicPanelLayout methodsFor: 'private' stamp: 'cwp 11/21/2004 00:25'!
addNavMorphTo: aMorph
	aMorph 
		addMorph: self navigationPanel buildScroller
		fullFrame: (LayoutFrame fractions: (0 @ 0 extent: 1 @ self columnProportion)).
! !

!OBMorphicPanelLayout methodsFor: 'private' stamp: 'cwp 11/21/2004 00:37'!
addOtherMorphsTo: aMorph
	| heights variableCount fraction offset vExtent h nonNavPanels |
	nonNavPanels := panels reject: [:ea | ea isNavigation].
	nonNavPanels isEmpty ifTrue: [^ self].
	heights _ nonNavPanels collect: [:ea | ea morphHeight].
	variableCount _ heights 
						inject: 0 
						into: [:count :ea | ea = 0 ifTrue: [count + 1] ifFalse: [count]].
	fraction _ self columnProportion.
	offset _ 0.
	vExtent _  1- fraction / variableCount.
	nonNavPanels with: heights do:  [:panel :height | 
		h _ height = 0 ifTrue: [vExtent] ifFalse: [0].
		aMorph 
			addMorph: panel morph
			fullFrame: (LayoutFrame
							fractions: (0@fraction extent: 1@h)
							offsets: (0@offset corner: 0@height)).
		height = 0 
			ifTrue: 	[offset _ 0.
					fraction _ fraction + vExtent]
			ifFalse: 	[offset _ offset + height]]
						
		
						! !

!OBMorphicPanelLayout methodsFor: 'private' stamp: 'cwp 11/21/2004 00:26'!
columnProportion
	^ panels size = 1
		ifTrue: [1]
		ifFalse: [0.4]! !

!OBMorphicPanelLayout methodsFor: 'private' stamp: 'cwp 11/21/2004 00:28'!
navigationPanel
	^ panels detect: [:ea | ea isNavigation]! !

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

OBMorphicPanelLayout class
	instanceVariableNames: ''!

!OBMorphicPanelLayout class methodsFor: 'intance creation' stamp: 'cwp 11/20/2004 23:32'!
for: aCollection
	^ self new setPanels: aCollection! !
Object subclass: #OBNode
	instanceVariableNames: 'metaNode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Kernel'!
!OBNode commentStamp: 'cwp 3/4/2004 22:20' prior: 0!
A node is a wrapper for an object in the browser's domain graph. OBNode is an abstract superclass for concrete nodes which might appear in the browser.

iVars:

metaNode - the MetaNode which produced this node!


!OBNode methodsFor: 'accessing' stamp: 'cwp 3/3/2004 23:24'!
metaNode
	^ metaNode! !

!OBNode methodsFor: 'accessing' stamp: 'cwp 3/3/2004 23:24'!
metaNode: aMetaNode
	metaNode _ aMetaNode! !


!OBNode methodsFor: 'ancestry' stamp: 'cwp 3/3/2004 00:44'!
ancestrySelector
	^ #isDescendantOf: ! !

!OBNode methodsFor: 'ancestry' stamp: 'cwp 3/3/2004 01:47'!
isAncestorOf: aNode
	^ aNode perform: self ancestrySelector with: self! !

!OBNode methodsFor: 'ancestry' stamp: 'cwp 3/3/2004 00:44'!
isDescendantOf: aNode
	^ false! !


!OBNode methodsFor: 'comparing' stamp: 'cwp 7/14/2006 12:37'!
correspondsWith: aNode
	^ self displayString = aNode displayString! !

!OBNode methodsFor: 'comparing' stamp: 'cwp 1/31/2004 14:57'!
hash
	^ self name hash! !

!OBNode methodsFor: 'comparing' stamp: 'cwp 1/31/2004 14:57'!
= other
	^ self class = other class and: [self name = other name]! !


!OBNode methodsFor: 'displaying' stamp: 'cwp 12/8/2004 21:36'!
displayString
	^ self perform: metaNode displaySelector! !

!OBNode methodsFor: 'displaying' stamp: 'cwp 8/28/2004 00:14'!
title
	^ nil! !


!OBNode methodsFor: 'drag and drop' stamp: 'cwp 3/2/2004 21:28'!
acceptDroppedNode: aNode
 	^ aNode perform: self dropSelector with: self
! !

!OBNode methodsFor: 'drag and drop' stamp: 'avi 2/20/2004 14:00'!
asDraggableMorph
	^(StringMorph contents: self name)
		color: Color white;
		yourself! !

!OBNode methodsFor: 'drag and drop' stamp: 'cwp 3/2/2004 21:29'!
dropSelector
	"Override in subclasses"
	
	^ #dropOnNode: ! !

!OBNode methodsFor: 'drag and drop' stamp: 'cwp 3/2/2004 21:28'!
wantsDroppedNode: aNode
	^ aNode respondsTo: self dropSelector! !



!OBNode methodsFor: 'public' stamp: 'cwp 2/29/2004 13:49'!
accept: aText notifying: aController
	^ self text: aText! !

!OBNode methodsFor: 'public' stamp: 'cwp 1/7/2004 09:25'!
actions
	^ #()! !

!OBNode methodsFor: 'public' stamp: 'cwp 3/22/2004 20:48'!
definition
	^ self! !

!OBNode methodsFor: 'public' stamp: 'dvf 8/17/2005 13:57'!
displayName
	"expected to return a decorated text (rather than string) version of name"
	^self name asText! !

!OBNode methodsFor: 'public' stamp: 'cwp 12/10/2003 22:27'!
name
	self subclassResponsibility! !

!OBNode methodsFor: 'public' stamp: 'cwp 12/7/2003 19:27'!
text
	^ ''! !

!OBNode methodsFor: 'public' stamp: 'cwp 2/29/2004 18:30'!
textSelection
	^ 1 to: 0! !

!OBNode methodsFor: 'public' stamp: 'cwp 3/14/2004 14:09'!
text: aText
	^ false! !


!OBNode methodsFor: 'utility' stamp: 'cwp 3/10/2004 00:29'!
action: aSelector buttonLabel: buttonString menuLabel: menuString
	^ OBAction
		label: menuString
		buttonLabel: buttonString
		receiver: self
		selector: aSelector
		arguments: #()! !

!OBNode methodsFor: 'utility' stamp: 'cwp 2/3/2004 22:29'!
action: aSelector withLabel: aString
	^ OBAction
		label: aString
		receiver: self
		selector: aSelector
		arguments: #()! !

!OBNode methodsFor: 'utility' stamp: 'hpt 5/17/2004 16:51'!
action: aSelector withLabel: aString withIcon: anIcon
	^ OBAction
		label: aString
		receiver: self
		selector: aSelector
		arguments: #()
		icon: anIcon! !

!OBNode methodsFor: 'utility' stamp: 'hpt 5/17/2004 14:28'!
action: aSelector withLabel: aString withKeystroke: aChar
	^ OBAction
		label: aString
		receiver: self
		selector: aSelector
		arguments: #()
		keystroke: aChar! !

!OBNode methodsFor: 'utility' stamp: 'hpt 5/17/2004 16:51'!
action: aSelector withLabel: aString withKeystroke: aChar withIcon: anIcon
	^ OBAction
		label: aString
		receiver: self
		selector: aSelector
		arguments: #()
		keystroke: aChar
		icon: anIcon! !

!OBNode methodsFor: 'utility' stamp: 'cwp 12/5/2004 20:11'!
action: aSelector withMenuLabel: aString withButtonLabel: aString2 withKeystroke: aChar withIcon: anIcon 
	^OBAction 
		label: aString
		buttonLabel: aString2
		receiver: self
		selector: aSelector
		arguments: #()
		keystroke: aChar
		icon: anIcon! !

!OBNode methodsFor: 'utility' stamp: 'cwp 2/7/2004 21:29'!
referenceForMethod: selector ofClass: className
	| classIsMeta symbol |
	classIsMeta _ className endsWith: ' class'.
	symbol _ classIsMeta ifTrue: [(className allButLast: 6) asSymbol] ifFalse: [className].
	^ MethodReference new 
		setClassSymbol: symbol
		classIsMeta: classIsMeta
		methodSymbol: selector
		stringVersion: symbol, '>>', selector! !


!OBNode methodsFor: 'updating' stamp: 'cwp 6/4/2006 12:18'!
announce: anObject
	^ OBAnnouncer current ifNotNilDo: [:announcer | announcer announce: anObject]! !

!OBNode methodsFor: 'updating' stamp: 'cwp 6/4/2006 01:06'!
demandSelection
	^ OBAnnouncer current announce: (OBNodeCreated node: self)! !

!OBNode methodsFor: 'updating' stamp: 'cwp 6/4/2006 12:15'!
signalChanged
	self announce: (OBNodeChanged node: self)! !

!OBNode methodsFor: 'updating' stamp: 'cwp 6/4/2006 12:15'!
signalChildrenChanged
	self announce: (OBChildrenChanged node: self)! !

!OBNode methodsFor: 'updating' stamp: 'cwp 6/4/2006 12:15'!
signalDeletion
	self announce: (OBNodeDeleted node: self)
! !

!OBNode methodsFor: 'updating' stamp: 'cwp 6/4/2006 13:59'!
signalSelection
	(self announce: OBAboutToChange)
		isVetoed ifFalse: [self announce: (OBSelectingNode node: self)]! !

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

OBNode class
	instanceVariableNames: ''!

!OBNode class methodsFor: 'as yet unclassified' stamp: 'cwp 2/5/2004 20:25'!
actionsForParent: aNode
	^ #()! !

!OBNode class methodsFor: 'as yet unclassified' stamp: 'cwp 12/18/2003 22:11'!
fromAssociation: anAssociationNode
	^ self on: anAssociationNode value! !
OBActor subclass: #OBNodeActor
	instanceVariableNames: 'nodeClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Actors'!
!OBNodeActor commentStamp: 'cwp 3/5/2004 12:23' prior: 0!
For simplicity, many actions are implemented by the nodes themselves. When the contextual menu for a node is displayed, this Actor gathers those actions and makes them available in to the user.

If a node class is specified, the OBNodeActor will also make available any class side actions provided by the node class. This is convenient for the user, since it makes it possible to invoke an action without first selecting a node. Many 'create' actions are implemented in this way.

iVars:

nodeClass - if not nil, this class's class-side actions will be available to the user as well.!


!OBNodeActor methodsFor: 'public' stamp: 'cwp 1/23/2004 23:24'!
actionsForNode: aNode
	^ aNode actions! !

!OBNodeActor methodsFor: 'public' stamp: 'cwp 3/3/2004 22:46'!
actionsForParent: aNode
	^ nodeClass 
		ifNotNil: [nodeClass actionsForParent: aNode]
		ifNil: [#()]! !

!OBNodeActor methodsFor: 'public' stamp: 'cwp 3/3/2004 22:42'!
nodeClass: aClass
	nodeClass _ aClass! !

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

OBNodeActor class
	instanceVariableNames: ''!

!OBNodeActor class methodsFor: 'as yet unclassified' stamp: 'cwp 3/3/2004 22:51'!
onNodeClass: aClass
	^ self new nodeClass: aClass! !
OBAnnouncement subclass: #OBNodeChanged
	instanceVariableNames: 'node'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBNodeChanged methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:17'!
node
	^ node! !

!OBNodeChanged methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:17'!
node: aNode
	node _ aNode! !

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

OBNodeChanged class
	instanceVariableNames: ''!

!OBNodeChanged class methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:17'!
node: aNode
	^ self new node: aNode! !
OBAnnouncement subclass: #OBNodeCreated
	instanceVariableNames: 'node'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBNodeCreated methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 00:53'!
node
	^ node! !

!OBNodeCreated methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 00:53'!
node: aNode
	node _ aNode! !

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

OBNodeCreated class
	instanceVariableNames: ''!

!OBNodeCreated class methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 01:09'!
node: aNode
	^ self new node: aNode! !
OBAnnouncement subclass: #OBNodeDeleted
	instanceVariableNames: 'node'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBNodeDeleted methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:56'!
node
	^ node! !

!OBNodeDeleted methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:56'!
node: aNode
	node _ aNode! !

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

OBNodeDeleted class
	instanceVariableNames: ''!

!OBNodeDeleted class methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 11:56'!
node: aNode
	^ self new node: aNode! !
OBDefinition subclass: #OBOrganizationDefinition
	instanceVariableNames: 'organizer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Definitions'!
!OBOrganizationDefinition commentStamp: 'cwp 1/8/2005 13:31' prior: 0!
OBOrganizationDefinition knows how to display and edit the organization of classes or methods by a Categorizer.!


!OBOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 9/22/2004 21:21'!
organizer: anOrganizer
	organizer _ anOrganizer! !

!OBOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 9/22/2004 21:18'!
text
	^ organizer asString! !

!OBOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 1/9/2005 11:45'!
text: aText
	organizer changeFromString: aText asString.
	^ true! !

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

OBOrganizationDefinition class
	instanceVariableNames: ''!

!OBOrganizationDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 9/22/2004 21:20'!
on: anOrganizer
	^ self new organizer: anOrganizer! !
RectangleMorph subclass: #OBPane
	instanceVariableNames: 'model list button'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBPane commentStamp: 'cwp 1/7/2005 23:24' prior: 0!
An OBPane is the visual representation of a column in a browser. It contains a morph to display nodes (typically a PluggableListMorph) and (optionally) a morph for communicating with the column's filter. It's main responsibility is to lay out its submorphs as the filter controls are added and removed.

iVars:

model	- the OBColumn that controls the node list displayed in this pane
list		- the morph which displays the node list, usually a PluggableListMorph
button	- the morph which controls the column's filter, usually an OBRadioButtonBar.!


!OBPane methodsFor: 'constructing' stamp: 'cwp 11/2/2004 00:57'!
buttonHeight
	^ self hasButton
		ifTrue: [button height]
		ifFalse: [self defaultButtonHeight]
! !

!OBPane methodsFor: 'constructing' stamp: 'cwp 11/2/2004 01:10'!
defaultButtonHeight
	^ 23! !

!OBPane methodsFor: 'constructing' stamp: 'cwp 11/27/2004 21:19'!
noteNewOwner: aMorph
	self containingWindow ifNotNilDo: [:window | self adoptPaneColor: window paneColor]! !


!OBPane methodsFor: 'geometry' stamp: 'cwp 2/12/2004 18:32'!
bounds: aRectangle
	super bounds: aRectangle.
	self adjustList.
	self adjustButton.! !


!OBPane methodsFor: 'initialization' stamp: 'cwp 2/12/2004 18:26'!
initGeometry
	self	
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		clipSubmorphs: true;
		color: Color transparent;
		cellInset: 0;
		borderWidth: 0;
		layoutPolicy: ProportionalLayout new.
		
	self addMorph: list.
	list bounds: self innerBounds.
		! !

!OBPane methodsFor: 'initialization' stamp: 'cwp 2/12/2004 18:44'!
model: anObject
	"Set my model and make me me a dependent of the given object."

	model ifNotNil: [model removeDependent: self].
	anObject ifNotNil: [anObject addDependent: self].
	model _ anObject.
! !

!OBPane methodsFor: 'initialization' stamp: 'cwp 2/12/2004 19:17'!
setColumn: aColumn filter: aFilter
	self model: aColumn.
	list _ aColumn listMorph.
	self initGeometry.
	aFilter ifNotNil: [self addButton: aFilter buttonMorph].! !


!OBPane methodsFor: 'testing' stamp: 'cwp 2/12/2004 18:35'!
hasButton
	^ button notNil! !


!OBPane methodsFor: 'updating' stamp: 'cwp 11/2/2004 00:53'!
addButton: aButton
	self hasButton ifTrue: [self removeMorph: button].
	button _ aButton.
	button height: self defaultButtonHeight.
	self 
		addMorph: button;
		adjustList;
		adjustButton! !

!OBPane methodsFor: 'updating' stamp: 'cwp 11/2/2004 00:50'!
adjustButton
	| inner |
	self hasButton ifTrue: 
		[inner _ self innerBounds.
		button bounds: (inner withTop: inner bottom - self buttonHeight)]! !

!OBPane methodsFor: 'updating' stamp: 'cwp 2/12/2004 18:35'!
adjustList
	self hasButton
			ifFalse: [list bounds: self innerBounds]
			ifTrue: [list bounds: (self innerBounds withHeight: (self height - self buttonHeight))]! !

!OBPane methodsFor: 'updating' stamp: 'cwp 2/12/2004 20:29'!
removeButton
	self hasButton 
		ifTrue: [self removeMorph: button.
				button _ nil.
				self adjustList]! !

!OBPane methodsFor: 'updating' stamp: 'cwp 2/12/2004 20:23'!
update: aSelector
	aSelector = #filter ifFalse: [^ self].
	(model wantsButton)
			ifTrue: [self addButton: model filter buttonMorph]
			ifFalse: [self removeButton]! !

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

OBPane class
	instanceVariableNames: ''!

!OBPane class methodsFor: 'instance creation' stamp: 'cwp 2/12/2004 18:11'!
forColumn: aColumn
	^ self forColumn: aColumn withFilter: nil! !

!OBPane class methodsFor: 'instance creation' stamp: 'cwp 2/12/2004 18:12'!
forColumn: aColumn withFilter: aFilter
	^ self new setColumn: aColumn filter: aFilter! !
RectangleMorph subclass: #OBPaneScroller
	instanceVariableNames: 'model sizing panes transform scrollBar'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBPaneScroller commentStamp: 'cwp 3/5/2004 12:13' prior: 0!
Instances of OBPaneScroller contain the panes which represent columns in a browser. Their primary responsibilities are laying out panes to fit the space available and scrolling them horizontally when there isn't sufficient space. 

iVars:

sizing		- The number of panes which should exactly fit the available space.
		   	   During layout, the  width of the panes is determined accordingly.
transform	- A TransformMorph used for scrolling
scrollBar	- An OBHorizontalScrollBar used for scrolling!


!OBPaneScroller methodsFor: 'accessing' stamp: 'cwp 11/17/2004 22:03'!
model
	^model! !

!OBPaneScroller methodsFor: 'accessing' stamp: 'cwp 11/17/2004 22:11'!
model: anObject
	model ifNotNil: [model removeDependent: self].
	anObject ifNotNil: [anObject addDependent: self].
	model := anObject! !

!OBPaneScroller methodsFor: 'accessing' stamp: 'cwp 11/17/2004 23:09'!
panes
	^ panes ifNil: [self updatePanes. panes]! !

!OBPaneScroller methodsFor: 'accessing' stamp: 'cwp 11/22/2004 23:19'!
sizing
	^ sizing ifNil: [self updateSizing]! !


!OBPaneScroller methodsFor: 'defaults' stamp: 'cwp 8/24/2003 15:13'!
separatorWidth
	^ 4! !


!OBPaneScroller methodsFor: 'initialization' stamp: 'cwp 11/23/2004 01:28'!
initialize
	super initialize.
	self 
		color: Color red;
		borderWidth: 0;
		vResizing: #spaceFill;
		hResizing: #spaceFill.
	self 
		initializeTransform;
		initializeScrollbar.
	self startStepping.! !

!OBPaneScroller methodsFor: 'initialization' stamp: 'cwp 2/8/2004 11:01'!
initializeScrollbar
	scrollBar _ OBScrollBar new model: self slotName: 'scrollBar'.
	scrollBar 
		borderWidth: 0;
		borderColor: #inset;
		height: self scrollBarHeight.
	self resizeScrollBar.
! !

!OBPaneScroller methodsFor: 'initialization' stamp: 'cwp 2/8/2004 10:52'!
initializeTransform
	transform _ TransformMorph new.
	transform
		color: Color transparent;
		borderWidth: 0;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		disableTableLayout;
		bounds: super innerBounds.
	self addMorphBack: transform.
! !


!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/8/2004 11:10'!
adjustPaneHeight
	"This gets called after the scrollbar has been shown or hidden, to move the bottom
	of the panes to the right place."
	
	transform bounds: self innerBounds.
	transform submorphsDo: [:m | m bounds: (m bounds withHeight: self paneHeight)]
		! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 11/21/2004 23:45'!
bounds: aRectangle
	super bounds: aRectangle.
	self layoutWidgets.
	self layoutPanes.
	self setScrollDeltas.
! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/26/2004 23:14'!
computeMorphWidths
	| paneWidths widths |
	paneWidths _ self paneWidthsToFit: self totalPaneWidth.
	widths _ OrderedCollection new.
	paneWidths do: [:w | widths add: w] separatedBy: [widths add: self separatorWidth].
	^ widths asArray
! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/8/2004 11:06'!
doLayout
	self layoutWidgets.
	self layoutPanes.
	self hideOrShowScrollBar.
	self setScrollDeltas.
	self scrollToRight.! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/8/2004 10:54'!
innerBounds
	| rect |
	rect _ super innerBounds.
	^ self scrollBarIsVisible
		ifTrue: [rect withHeight: rect height - self scrollBarHeight - 1]
		ifFalse: [rect]! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/8/2004 01:22'!
layoutPanes
	| widths rect |
	widths _ self computeMorphWidths.
	rect _ 0@0 extent: (0 @ self paneHeight).
	transform submorphs 
					with: widths 
					do: [:m :w | 
						rect _ rect withWidth: w.
						m bounds: rect.
						rect _ rect translateBy: (w@0)]
						
! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 8/25/2003 22:13'!
layoutWidgets
	| inner outer |
	outer _ super innerBounds.
	inner _ self innerBounds.
	transform bounds: inner.
	scrollBar bounds: ((inner left @ inner bottom + 1)
						corner: outer bottomRight)! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 11/17/2004 23:09'!
paneCount
	^ self panes size! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 12/6/2003 17:08'!
paneHeight
	^ transform bounds height! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/26/2004 23:14'!
paneWidthsToFit: limit
	| padded |
	padded _ Array new: self paneCount.
	padded atAllPut: (limit / self sizing) floor.
	(1 to: limit - padded sum) do: [:i | padded at: i put: (padded at: i) + 1].
	^ padded
	
	! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/8/2004 11:03'!
resizeScrollBar
	| inner outer |
	outer _ super innerBounds.
	inner _ outer withHeight: outer height - self scrollBarHeight - 1.
	scrollBar bounds: ((inner left @ inner bottom + 1)
						corner: outer bottomRight)! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 8/24/2003 14:29'!
scrollBarHeight
	^ 12! !

!OBPaneScroller methodsFor: 'layout' stamp: 'cwp 2/25/2004 20:23'!
totalPaneWidth
	^ self innerBounds width - ((self sizing - 1) * self separatorWidth)! !


!OBPaneScroller methodsFor: 'panes' stamp: 'cwp 12/6/2003 17:06'!
clearPanes
	transform removeAllMorphs! !

!OBPaneScroller methodsFor: 'panes' stamp: 'cwp 11/23/2004 01:22'!
popPanes: count
	count * 2 timesRepeat: [transform removeMorph: transform lastSubmorph].
	panes removeLast: count! !

!OBPaneScroller methodsFor: 'panes' stamp: 'cwp 11/17/2004 22:46'!
pushPane: aMorph
	aMorph 
		borderWidth: 0;
		hResizing: #rigid;
		vResizing: #rigid;
		layoutInset: 0.
	transform hasSubmorphs ifTrue: [transform addMorphBack: self separator].
	transform addMorphBack: aMorph.
! !

!OBPaneScroller methodsFor: 'panes' stamp: 'cwp 11/27/2004 01:03'!
separator
	^ BorderedSubpaneDividerMorph vertical 
		borderWidth: self separatorWidth / 2;
		color: model defaultBackgroundColor duller;
		borderRaised.! !


!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 10:44'!
hideOrShowScrollBar
	self isScrollable ifTrue: [self showScrollBar] ifFalse: [self hideScrollBar]! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 11:10'!
hideScrollBar
	self removeMorph: scrollBar.
	self adjustPaneHeight.! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 10:42'!
isScrollable
	^ self leftoverScrollRange > 0! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 8/25/2003 21:04'!
leftoverScrollRange
	^ (self totalScrollRange - self innerBounds width roundTo: self scrollDeltaWidth) max: 0
! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 10:56'!
scrollBarIsVisible
	^ submorphs includes: scrollBar! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 8/23/2003 16:21'!
scrollDeltaWidth
	^ 1! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 12/8/2003 21:42'!
scrollToRight
	^ scrollBar setValue: 1.! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 8/25/2003 21:14'!
setScrollDeltas
	| range interval value |
	transform hasSubmorphs ifFalse: [scrollBar interval: 1.0. ^ self].
	range _ self leftoverScrollRange.
	range = 0 ifTrue: [^ scrollBar interval: 1.0; setValue: 0].
	interval _ ((self innerBounds width) / self totalScrollRange) asFloat.
	value _ (transform offset x / range min: 1.0) asFloat.
	scrollBar interval: interval.
	scrollBar setValue: value.! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 2/8/2004 11:11'!
showScrollBar
	self scrollBarIsVisible ifTrue: [^ self].
	self resizeScrollBar.
	self addMorphFront: scrollBar.
	self adjustPaneHeight.
	! !

!OBPaneScroller methodsFor: 'scrolling' stamp: 'cwp 8/25/2003 19:27'!
totalScrollRange
	| submorphBounds |
	submorphBounds := transform localSubmorphBounds ifNil: [^ 0].
	^ submorphBounds width
! !


!OBPaneScroller methodsFor: 'stepping' stamp: 'cwp 11/21/2004 15:38'!
step
	self reclaimPanes! !

!OBPaneScroller methodsFor: 'stepping' stamp: 'cwp 11/24/2004 22:29'!
stepTime
	^ 250! !


!OBPaneScroller methodsFor: 'updating' stamp: 'cwp 11/23/2004 01:23'!
reclaimPanes
	| reclaimed |
	reclaimed := model reclaimPanes.
	reclaimed isZero	ifFalse: 
		[self 
		 	popPanes: reclaimed;
			basicUpdateSizing;
			layoutPanes;
			hideOrShowScrollBar;
			setScrollDeltas]! !

!OBPaneScroller methodsFor: 'updating' stamp: 'cwp 11/21/2004 13:51'!
scrollBarValue: value
	transform hasSubmorphs ifFalse: [^ self].
	transform offset: (self leftoverScrollRange * value) rounded @ 0.! !

!OBPaneScroller methodsFor: 'updating' stamp: 'cwp 11/23/2004 01:34'!
updatePanes
	| count |
	model ifNil: [panes := Array new. ^ self].
	count := panes ifNotNil: [panes size] ifNil: [0].
	self basicUpdatePanes.
	self basicUpdateSizing.	
	self layoutPanes.
	panes size = count
		ifFalse: [self hideOrShowScrollBar.
				self setScrollDeltas].
	panes size > count ifTrue: [self scrollToRight].
	^ panes! !

!OBPaneScroller methodsFor: 'updating' stamp: 'cwp 11/23/2004 01:14'!
updateSizing
	| old |
	old := sizing.
	self basicUpdateSizing.
	sizing = old ifFalse: [self layoutPanes].
	^sizing! !

!OBPaneScroller methodsFor: 'updating' stamp: 'cwp 11/17/2004 22:40'!
update: aSymbol
	aSymbol = #sizing ifTrue: [^ self updateSizing].
	aSymbol = #panes ifTrue: [^ self updatePanes].! !


!OBPaneScroller methodsFor: 'private' stamp: 'cwp 11/23/2004 01:31'!
basicUpdatePanes
	panes := model ifNotNil: [model panes] ifNil: [Array new].		
	self clearPanes.
	panes do: [:ea | self pushPane: ea].
! !

!OBPaneScroller methodsFor: 'private' stamp: 'cwp 11/23/2004 01:14'!
basicUpdateSizing
	model ifNil: [sizing := 1] ifNotNil: [sizing := model sizing]! !

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

OBPaneScroller class
	instanceVariableNames: ''!

!OBPaneScroller class methodsFor: 'as yet unclassified' stamp: 'cwp 11/17/2004 22:01'!
withModel: aModel
	^ self new model: aModel! !
Object subclass: #OBPanel
	instanceVariableNames: 'browser'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Kernel'!
!OBPanel commentStamp: 'cwp 1/7/2005 23:23' prior: 0!
A panel is an object that manages part of the browser's window. It provides a protocol for receiving notifications when the current domain node changes, and reacts to these changes.!


!OBPanel methodsFor: 'accessing' stamp: 'cwp 4/17/2006 15:52'!
announcer
	^ browser announcer! !

!OBPanel methodsFor: 'accessing' stamp: 'cwp 11/16/2004 21:58'!
browser
	^ browser! !

!OBPanel methodsFor: 'accessing' stamp: 'cwp 4/17/2006 22:17'!
browser: aBrowser
	browser _ aBrowser.
	self subscribe! !


!OBPanel methodsFor: 'testing' stamp: 'cwp 11/20/2004 21:09'!
isNavigation
	^ false! !


!OBPanel methodsFor: 'updating' stamp: 'cwp 4/17/2006 19:36'!
subscribe! !

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

OBPanel class
	instanceVariableNames: ''!

!OBPanel class methodsFor: 'instance creation' stamp: 'cwp 8/31/2004 10:46'!
inBrowser: aBrowser
	^ self new browser: aBrowser! !
PluggableTextMorph subclass: #OBPluggableTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBPluggableTextMorph commentStamp: 'cwp 12/7/2004 00:04' prior: 0!
This is a trivial subclass of PluggableTextMorph. It overrides initialization methods to use an OBTextMorph rather than a regular TextMorph!


!OBPluggableTextMorph methodsFor: 'event handling' stamp: 'cwp 10/30/2004 23:07'!
keyStroke: evt
	^ textMorph keyStroke: evt! !


!OBPluggableTextMorph methodsFor: 'model access' stamp: 'cwp 10/30/2004 22:57'!
setText: aText
	scrollBar setValue: 0.0.
	textMorph
		ifNil: [textMorph _ OBTextMorph new
						contents: aText wrappedTo: self innerBounds width-6.
				textMorph setEditView: self.
				scroller addMorph: textMorph]
		ifNotNil: [textMorph newContents: aText].
	self hasUnacceptedEdits: false.
	self setScrollDeltas.! !
RectangleMorph subclass: #OBRadioButtonBar
	instanceVariableNames: 'model buttons selection getListSelector getSelectionSelector setSelectionSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBRadioButtonBar commentStamp: 'cwp 1/7/2005 23:27' prior: 0!
An OBRadioButtonBar is similar to a PluggableListMorph except that it displays a row of buttons rather than a vertical list. Clicking on a button selects it.

model				- the model for this button bar
buttons			- a collection of OBButtonModels, which are derived from the model's list
selection			- the index of the currently selected button
getListSelector	 	- the message for getting the list of labels for the buttons
getSelectionSelector	- the message for getting the index of the currently selected item
setSelectionSelector	- the message for informing the model that a button has been clicked!


!OBRadioButtonBar methodsFor: 'accessing' stamp: 'cwp 11/27/2004 02:09'!
list
	buttons ifNil: 
			[| labels |
			labels := model perform: getListSelector.
			buttons := Array new: labels size.
			labels withIndexDo: 
					[:label :index | 
					buttons at: index put: (OBButtonModel withLabel: label inBar: self)].
			selection := self getSelectionIndex.
			self].
	^buttons collect: [:b | b label]! !


!OBRadioButtonBar methodsFor: 'callbacks' stamp: 'cwp 11/27/2004 19:18'!
isEnabled: aButton
	^ true! !

!OBRadioButtonBar methodsFor: 'callbacks' stamp: 'cwp 2/24/2004 18:54'!
isSelected: aButton
	^ (buttons at: selection ifAbsent: [^ false]) == aButton! !

!OBRadioButtonBar methodsFor: 'callbacks' stamp: 'cwp 2/24/2004 18:47'!
push: aButton
	| index |
	index _ buttons indexOf: aButton.
	model perform: setSelectionSelector with: index.! !


!OBRadioButtonBar methodsFor: 'constructing' stamp: 'cwp 11/27/2004 20:58'!
adoptPaneColor: aColor
	self submorphs do: [:ea | ea onColor: aColor darker offColor: aColor lighter]! !

!OBRadioButtonBar methodsFor: 'constructing' stamp: 'cwp 11/27/2004 21:02'!
noteNewOwner: aMorph
	| window |
	window := aMorph containingWindow.
	window ifNotNil: [self adoptPaneColor: window paneColor]! !


!OBRadioButtonBar methodsFor: 'initialize-release' stamp: 'lr 3/23/2006 18:10'!
initGeometry
	self
		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		rubberBandCells: true;
		color: Color transparent;
		borderWidth: 0;
		layoutInset: 2;
		cellInset: 2
! !

!OBRadioButtonBar methodsFor: 'initialize-release' stamp: 'cwp 2/22/2004 16:51'!
model: aModel
	model ifNotNil: [model removeDependent: self].
	model _ aModel.
	model addDependent: self.! !

!OBRadioButtonBar methodsFor: 'initialize-release' stamp: 'cwp 2/25/2004 00:36'!
on: aModel list: listSelector selected: selectionGetter changeSelected: selectionSetter 
	self model: aModel.
	selection _ 0.
	getListSelector _ listSelector.
	getSelectionSelector _ selectionGetter.
	setSelectionSelector _ selectionSetter.
	self initGeometry.
	self updateList.! !


!OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/24/2004 18:53'!
getSelectionIndex
	^ model perform: getSelectionSelector! !

!OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 11/27/2004 17:58'!
updateButtons
	| labels |
	labels := model perform: getListSelector.
	buttons := Array new: labels size.
	labels withIndexDo: 
			[:label :index | 
			buttons at: index put: (OBButtonModel withLabel: label inBar: self)].
	selection := self getSelectionIndex! !

!OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 11/27/2004 17:58'!
updateList
	self 
		updateButtons; 
		updateMorphs! !

!OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 11/2/2004 01:09'!
updateMorphs
	self removeAllMorphs.
	buttons do: [:button | self addMorphBack: button morph].
	self bounds: (self bounds withHeight: submorphs first height)! !

!OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/24/2004 19:39'!
updateSelection
	| oldSelection |
	oldSelection _ selection.
	selection _ self getSelectionIndex.
	self withButtonAt: oldSelection do: [:button | button selectionChanged].
	self withSelectedButtonDo: [:button | button selectionChanged]! !

!OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/25/2004 00:35'!
update: aSymbol
	aSymbol = getListSelector ifTrue: [self updateList. ^ self].
	aSymbol = getSelectionSelector ifTrue: [self updateSelection]! !

!OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/24/2004 19:38'!
withButtonAt: index do: aBlock
	^ (buttons at: index ifAbsent: [nil]) ifNotNilDo: aBlock! !

!OBRadioButtonBar methodsFor: 'updating' stamp: 'cwp 2/24/2004 19:38'!
withSelectedButtonDo: aBlock
	^ self withButtonAt: selection do: aBlock! !

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

OBRadioButtonBar class
	instanceVariableNames: ''!

!OBRadioButtonBar class methodsFor: 'as yet unclassified' stamp: 'cwp 2/22/2004 16:44'!
on: aModel list: listSelector selected: selectionSelector changeSelected: changedSelector 
	^ self new
			on: aModel
			list: listSelector
			selected: selectionSelector
			changeSelected: changedSelector! !
OBListBrowser subclass: #OBReferencesBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!

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

OBReferencesBrowser class
	instanceVariableNames: ''!

!OBReferencesBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:22'!
defaultMetaNode
	| class method |
	class := OBMetaNode named: 'Class'.
	method := OBMetaNode named: 'References'.
	
	class
		childAt: #users put: method;
		addActor: OBNodeActor new.
	method
		displaySelector: #fullName;
		addActor: OBNodeActor new.
		
	^ class! !

!OBReferencesBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:34'!
title
	^ 'References to'! !
OBAnnouncement subclass: #OBRefreshRequired
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!
Object subclass: #OBRequestor
	instanceVariableNames: 'node browser'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Services'!

!OBRequestor methodsFor: 'as yet unclassified' stamp: 'cwp 6/29/2006 00:12'!
announce: anObject
	^ browser announcer announce: anObject! !

!OBRequestor methodsFor: 'as yet unclassified' stamp: 'cwp 6/28/2006 00:41'!
browser: aBrowser
	browser _ aBrowser! !

!OBRequestor methodsFor: 'as yet unclassified' stamp: 'cwp 6/28/2006 00:43'!
doesNotUnderstand: aMessage
	^ aMessage sendTo: browser! !

!OBRequestor methodsFor: 'as yet unclassified' stamp: 'cwp 6/28/2006 00:43'!
node: aNode
	node _ aNode! !

!OBRequestor methodsFor: 'as yet unclassified' stamp: 'cwp 6/28/2006 00:38'!
requestNode
	^ node! !

!OBRequestor methodsFor: 'as yet unclassified' stamp: 'cwp 6/29/2006 00:12'!
select: aNode
	(self announce: OBAboutToChange)
		isVetoed ifFalse: [self announce: (OBSelectingNode node: aNode)]! !

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

OBRequestor class
	instanceVariableNames: ''!

!OBRequestor class methodsFor: 'as yet unclassified' stamp: 'cwp 6/28/2006 00:40'!
for: aBrowser
	^ self new browser: aBrowser! !
Slider subclass: #OBScrollBar
	instanceVariableNames: 'upButton downButton pagingArea scrollDelta pageDelta interval menuSelector timeOfMouseDown timeOfLastScroll nextPageDirection currentScrollDelay'
	classVariableNames: 'CachedImages UpArrow UpArrow8Bit'
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBScrollBar commentStamp: 'cwp 3/5/2004 12:01' prior: 0!
This class is a relic. It was originally created to work around bugs in ScrollBar which prevented it from working correctly in horizontal orientation. At some point the bugs should be fixed, and ScrollBar should be used instead.!


!OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'!
interval: d
	"Supply an optional floating fraction so slider can expand to indicate range"
	interval _ d min: 1.0.
	self expandSlider.
	self computeSlider.! !

!OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'!
pagingArea
	^pagingArea! !

!OBScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 21:25'!
roundedScrollbarLook
	"Rounded look currently only shows up in flop-out mode"
	^false and: [self class alwaysShowFlatScrollbarForAlternativeLook not]
! !

!OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'!
scrollDelta
	^ scrollDelta! !

!OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'!
scrollDelta: d1 pageDelta: d2
	"Supply optional increments for better scrolling of, eg, text"
	scrollDelta _ d1.
	pageDelta _ d2.! !

!OBScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 16:26'!
sliderColor: aColor
	"Change the color of the scrollbar to go with aColor."
	| buttonColor |
	super sliderColor: aColor.
	buttonColor _ self thumbColor.
	upButton color: buttonColor.
	downButton color: buttonColor.
	slider color: buttonColor.
	self roundedScrollbarLook
			ifTrue:
				[self color: Color transparent.
				pagingArea color: aColor muchLighter.
				self borderStyle style == #simple 
					ifTrue:[self borderColor: aColor darker darker]
					ifFalse:[self borderStyle baseColor: aColor]]
			ifFalse:
				[pagingArea color: (aColor alphaMixed: 0.3 with: Color white).
				self borderWidth: 0]
! !

!OBScrollBar methodsFor: 'access' stamp: 'cwp 11/23/2003 18:06'!
sliderShadowColor
	^ self roundedScrollbarLook
		ifTrue: [self sliderColor darker]
		ifFalse: [super sliderShadowColor]
! !

!OBScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 16:27'!
thumbColor
	"Problem: Part of the ScrollBar/Slider code uses 'slider' to mean the entire scrollbar/slider widget, and part of it uses 'slider' to mean only the draggable 'thumb'.  This should be cleaned up so that 'thumb' is used instead of 'slider' where appropriate.  For now, the meaning of thumbColor is clear, at least."

	^self sliderColor alphaMixed: 0.7 with: (Color gray: 0.95).! !


!OBScrollBar methodsFor: 'accessing' stamp: 'md 2/24/2006 16:12'!
adoptPaneColor: aColor
	"Adopt the given pane color"
	aColor ifNil:[^self].
	self sliderColor: aColor.! !

!OBScrollBar methodsFor: 'accessing' stamp: 'cwp 11/23/2003 18:06'!
cachedImageAt: aKey ifAbsentPut: aBlock

	CachedImages ifNil: [CachedImages _ Dictionary new].
	^CachedImages at: aKey ifAbsentPut: aBlock! !


!OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:06'!
buttonExtent
	^ bounds isWide
		ifTrue: [11 @ self innerBounds height]
		ifFalse: [self innerBounds width @ 11]! !

!OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:06'!
expandSlider
	"Compute the new size of the slider (use the old sliderThickness as a minimum)."
	| r |
	r _ self totalSliderArea.
	slider extent: (bounds isWide
		ifTrue: [((r width * interval) asInteger max: self sliderThickness) @ slider height]
		ifFalse: [slider width @ ((r height * interval) asInteger max: self sliderThickness)])! !

!OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:06'!
extent: p
        p x > p y
                ifTrue: [super extent: (p max: 42@8)]
                ifFalse: [super extent: (p max: 8@42)]! !

!OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:06'!
sliderExtent
	"The sliderExtent is now stored in the slider itself, not hardcoded as it is in the superclass."
	^slider extent! !

!OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:07'!
sliderThickness
	^ self roundedScrollbarLook ifTrue:[15] ifFalse:[super sliderThickness]! !

!OBScrollBar methodsFor: 'geometry' stamp: 'cwp 11/23/2003 18:07'!
totalSliderArea
	| upperBoundsButton |
	upperBoundsButton _ upButton.
	upButton bottom > upperBoundsButton bottom
		ifTrue: [upperBoundsButton _ upButton].
	^ bounds isWide
		ifTrue: [upperBoundsButton bounds topRight corner: downButton bounds bottomLeft]
		ifFalse: [upperBoundsButton bounds bottomLeft corner: downButton bounds topRight].
! !


!OBScrollBar methodsFor: 'initialization' stamp: 'cwp 11/23/2003 18:07'!
initialize
	super initialize.
	scrollDelta _ 0.02.
	pageDelta _ 0.2.
	self roundedScrollbarLook ifTrue:[
		self borderStyle: ((BorderStyle complexFramed width: 2) "baseColor: Color gray")].! !


!OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'!
initializeDownButton
	downButton := RectangleMorph
		newBounds: (self innerBounds bottomRight - self buttonExtent extent: self buttonExtent)
		color: self thumbColor.
	downButton on: #mouseDown send: #scrollDownInit to: self.
	downButton on: #mouseUp send: #finishedScrolling to: self.
	downButton addMorphCentered: (ImageMorph new image: 
		(self 
			cachedImageAt: (bounds isWide ifTrue: ['right'] ifFalse: ['down']) 
			ifAbsentPut: [
				self upArrow8Bit
					rotateBy: (bounds isWide ifTrue: [#right] ifFalse: [#pi])
					centerAt: 0@0
			]
		)
	).
	self roundedScrollbarLook ifTrue:[
		downButton color: Color veryLightGray.
		downButton borderStyle: (BorderStyle complexRaised width: 3).
	] ifFalse:[
		downButton setBorderWidth: 1 borderColor: #raised.
	].
	self addMorph: downButton.
! !

!OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'!
initializeEmbedded: aBool
	"aBool == true => inboard scrollbar
	aBool == false => flop-out scrollbar"
	self roundedScrollbarLook ifFalse:[^self].
	aBool ifTrue:[
		self borderStyle: (BorderStyle inset width: 2).
		self cornerStyle: #square.
	] ifFalse:[
		self borderStyle: (BorderStyle width: 1 color: Color black).
		self cornerStyle: #rounded.
	].
	self removeAllMorphs.
	self initializeSlider.! !

!OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'!
initializePagingArea
	pagingArea := RectangleMorph newBounds: self totalSliderArea
								color: (Color r: 0.6 g: 0.6 b: 0.8).
	pagingArea borderWidth: 0.
	pagingArea on: #mouseDown send: #scrollPageInit: to: self.
	pagingArea on: #mouseUp send: #finishedScrolling to: self.
	self addMorph: pagingArea.
	self roundedScrollbarLook 
		ifTrue:[pagingArea color: (Color gray: 0.9)].! !

!OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'!
initializeSlider
	self roundedScrollbarLook ifTrue:[
		self 
			initializeUpButton;
			initializeDownButton;
			initializePagingArea.
	] ifFalse:[
		self initializeUpButton; 
			initializeDownButton; 
			initializePagingArea.
	].
	super initializeSlider.
	self roundedScrollbarLook ifTrue:[
		slider cornerStyle: #rounded.
		slider borderStyle: (BorderStyle complexRaised width: 3).
		sliderShadow cornerStyle: #rounded.
	].
	self sliderColor: self sliderColor.! !

!OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'!
initializeUpButton
	upButton := self roundedScrollbarLook 
				ifTrue:  
					[RectangleMorph 
						newBounds: (self innerBounds topLeft extent: self buttonExtent)]
				ifFalse: 
					[RectangleMorph 
						newBounds: ((self innerBounds topLeft) extent: self buttonExtent)].
	upButton color: self thumbColor.
	upButton 
		on: #mouseDown
		send: #scrollUpInit
		to: self.
	upButton 
		on: #mouseUp
		send: #finishedScrolling
		to: self.
	upButton 
		addMorphCentered: (ImageMorph new image: (self 
						cachedImageAt: (bounds isWide ifTrue: ['left'] ifFalse: ['up'])
						ifAbsentPut: 
							[bounds isWide 
								ifTrue: [self upArrow8Bit rotateBy: #left centerAt: 0 @ 0]
								ifFalse: [self upArrow8Bit]])).
	self roundedScrollbarLook 
		ifTrue: 
			[upButton color: Color veryLightGray.
			upButton borderStyle: (BorderStyle complexRaised width: 3)]
		ifFalse: [upButton setBorderWidth: 1 borderColor: #raised].
	self addMorph: upButton! !

!OBScrollBar methodsFor: 'initialize' stamp: 'cwp 11/23/2003 18:06'!
upArrow8Bit

	"convert to 8-bit and convert white to transparent to avoid gratuitous conversion every time we put one in an ImageMorph"

	^UpArrow8Bit ifNil: [
		UpArrow8Bit _ (ColorForm mappingWhiteToTransparentFrom: UpArrow) asFormOfDepth: 8
	]! !


!OBScrollBar methodsFor: 'model access' stamp: 'cwp 11/23/2003 18:06'!
setValue: newValue
	"Using roundTo: instead of truncateTo: ensures that scrollUp will scroll the same distance as scrollDown."
	^ super setValue: (newValue roundTo: scrollDelta)! !


!OBScrollBar methodsFor: 'other events' stamp: 'cwp 11/23/2003 18:06'!
menuButtonMouseDown: event
	event hand showTemporaryCursor: nil.
	self use: menuSelector orMakeModelSelectorFor: 'MenuButtonPressed:'
		in: [:sel | menuSelector _ sel.  model perform: sel with: event]! !

!OBScrollBar methodsFor: 'other events' stamp: 'cwp 11/23/2003 18:06'!
mouseDownInSlider: event
	interval = 1.0 ifTrue:
		["make the entire scrollable area visible if a full scrollbar is clicked on"
		self setValue: 0.
		self model hideOrShowScrollBar].
	super mouseDownInSlider: event! !


!OBScrollBar methodsFor: 'scroll timing' stamp: 'cwp 11/23/2003 18:07'!
resetTimer
	timeOfMouseDown _ Time millisecondClockValue.
	timeOfLastScroll _ timeOfMouseDown - 1000 max: 0.
	nextPageDirection _ nil.
	currentScrollDelay _ nil! !

!OBScrollBar methodsFor: 'scroll timing' stamp: 'cwp 11/23/2003 18:07'!
waitForDelay1: delay1 delay2: delay2 
	"Return true if an appropriate delay has passed since the last scroll operation.
	The delay decreases exponentially from delay1 to delay2."

	| now scrollDelay |
	timeOfLastScroll isNil ifTrue: [self resetTimer].	"Only needed for old instances"
	now := Time millisecondClockValue.
	(scrollDelay := currentScrollDelay) isNil 
		ifTrue: [scrollDelay := delay1	"initial delay"].
	currentScrollDelay := scrollDelay * 9 // 10 max: delay2.	"decrease the delay"
	timeOfLastScroll := now.
	^true! !


!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
doScrollByPage
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 300 delay2: 100) ifFalse: [^ self].
	nextPageDirection
		ifTrue: [self setValue: (value + pageDelta min: 1.0)]
		ifFalse: [self setValue: (value - pageDelta max: 0.0)]
! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
doScrollDown
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 200 delay2: 40) ifFalse: [^ self].
	self setValue: (value + scrollDelta + 0.000001 min: 1.0)! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
doScrollUp
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 200 delay2: 40) ifFalse: [^ self].
	self setValue: (value - scrollDelta - 0.000001 max: 0.0)! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
finishedScrolling
	self stopStepping.
	self scrollBarAction: nil.
	self roundedScrollbarLook ifTrue:[
		upButton borderStyle: (BorderStyle complexRaised width: upButton borderWidth).
		downButton borderStyle: (BorderStyle complexRaised width: downButton borderWidth).
	] ifFalse:[
		downButton borderRaised.
		upButton borderRaised.
	].

! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollBarAction
	^self valueOfProperty: #scrollBarAction! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollBarAction: aSymbol
	self setProperty: #scrollBarAction toValue: aSymbol! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollDown
	self flag: #obsolete.
	downButton eventHandler: nil.
	downButton on: #mouseDown send: #scrollDownInit to: self.
	downButton on: #mouseUp send: #finishedScrolling to: self.
	^self scrollDownInit! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollDownInit
	downButton borderInset.
	self resetTimer.
	self scrollBarAction: #doScrollDown.
	self startStepping.! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollDown: count
	self setValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollPageInit: evt
	self resetTimer.
	self setNextDirectionFromEvent: evt.
	self scrollBarAction: #doScrollByPage.
	self startStepping.! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollUp
	self flag: #obsolete.
	upButton eventHandler: nil.
	upButton on: #mouseDown send: #scrollUpInit to: self.
	upButton on: #mouseUp send: #finishedScrolling to: self.
	^self scrollUpInit! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollUpInit
	upButton borderInset.
	self resetTimer.
	self scrollBarAction: #doScrollUp.
	self startStepping.! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
scrollUp: count
	self setValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! !

!OBScrollBar methodsFor: 'scrolling' stamp: 'cwp 11/23/2003 18:06'!
setNextDirectionFromEvent: event

	nextPageDirection _ bounds isWide ifTrue: [
		event cursorPoint x >= slider center x
	]
	ifFalse: [
		event cursorPoint y >= slider center y
	]

! !


!OBScrollBar methodsFor: 'stepping and presenter' stamp: 'cwp 11/23/2003 18:07'!
step
	| action |
	action _ self scrollBarAction.
	action ifNotNil:[self perform: action].! !


!OBScrollBar methodsFor: 'testing' stamp: 'cwp 11/23/2003 18:06'!
stepTime
	^ currentScrollDelay ifNil: [300]! !

!OBScrollBar methodsFor: 'testing' stamp: 'cwp 11/23/2003 18:06'!
wantsSteps
	^self scrollBarAction notNil! !

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

OBScrollBar class
	instanceVariableNames: ''!

!OBScrollBar class methodsFor: 'as yet unclassified' stamp: 'cwp 11/23/2003 18:07'!
alwaysShowFlatScrollbarForAlternativeLook
	"Set this value to true, if you want to see the flat scrollbar look in flop-out mode as well as inboard.  Otherwise the flop-out scrollbar will be rounded and inboard will be flat."
	^ false! !


!OBScrollBar class methodsFor: 'class initialization' stamp: 'cwp 11/23/2003 18:07'!
initialize "ScrollBar initialize"

	UpArrow _ Form
		extent: 6@3
		fromArray: #(2r11e28 2r1111e27 2r111111e26)
		offset: 0@0.! !
OBAnnouncement subclass: #OBSelectingNode
	instanceVariableNames: 'node'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBSelectingNode methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 13:58'!
node
	^ node! !

!OBSelectingNode methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 13:58'!
node: aNode
	node _ aNode! !

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

OBSelectingNode class
	instanceVariableNames: ''!

!OBSelectingNode class methodsFor: 'as yet unclassified' stamp: 'cwp 6/4/2006 13:58'!
node: aNode
	^ self new node: aNode! !
OBAnnouncement subclass: #OBSelectionChanged
	instanceVariableNames: 'node column'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBSelectionChanged methodsFor: 'accessing' stamp: 'cwp 4/19/2006 00:53'!
column
	^ column! !

!OBSelectionChanged methodsFor: 'accessing' stamp: 'cwp 4/19/2006 00:52'!
column: aColumn
	column _ aColumn! !

!OBSelectionChanged methodsFor: 'accessing' stamp: 'cwp 6/4/2006 12:19'!
node
	^ column 
		ifNil: [node]
		ifNotNil: [column selectedNode]! !

!OBSelectionChanged methodsFor: 'accessing' stamp: 'cwp 6/4/2006 12:20'!
node: aNode
	node _ aNode! !

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

OBSelectionChanged class
	instanceVariableNames: ''!

!OBSelectionChanged class methodsFor: 'instance creation' stamp: 'cwp 4/19/2006 00:51'!
column: aColumn 
	^ self new column: aColumn! !


!OBSelectionChanged class methodsFor: 'as yet unclassified' stamp: 'cwp 4/19/2006 00:31'!
node: aNode
	^ self new node: aNode! !
OBCodeNode subclass: #OBSelectorNode
	instanceVariableNames: 'selector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBSelectorNode commentStamp: 'cwp 1/8/2005 13:03' prior: 0!
OBSelectorNode wraps an instance of Symbol. It typically serves as the root of a senders or implementors OBListBrowser, and is used when cmd-n or cmd-m is invoke from the definition panel, and so no OBMethodNode is available.!


!OBSelectorNode methodsFor: 'navigating' stamp: 'cwp 12/8/2004 23:48'!
implementors
	^ (SystemNavigation default allImplementorsOf: self selector) asSortedArray
			collect: [:ref | OBMethodNode on: ref]! !

!OBSelectorNode methodsFor: 'navigating' stamp: 'cwp 1/7/2005 22:35'!
implementorsHierarchically
	^ OBClassAwareNode sortHierarchically: self implementors! !

!OBSelectorNode methodsFor: 'navigating' stamp: 'cwp 10/31/2004 01:12'!
name
	^ selector printString! !

!OBSelectorNode methodsFor: 'navigating' stamp: 'cwp 10/31/2004 01:12'!
selectorAndMessages
	^ Array with: self! !

!OBSelectorNode methodsFor: 'navigating' stamp: 'cwp 11/1/2004 02:22'!
senders
	^ (SystemNavigation default allCallsOn: self selector) asSortedArray
			collect: [:ref | OBMessageNode on: self selector inMethodReference: ref]! !

!OBSelectorNode methodsFor: 'navigating' stamp: 'cwp 10/31/2004 01:48'!
sendersOfMessage
	^ (SystemNavigation default allCallsOn: self selector) asSortedArray
			collect: [:ref | OBMessageNode on: self selector inMethodReference: ref]! !


!OBSelectorNode methodsFor: 'accessing' stamp: 'cwp 10/31/2004 01:11'!
selector
	^ selector! !

!OBSelectorNode methodsFor: 'accessing' stamp: 'cwp 10/31/2004 01:10'!
selector: aSelector
	selector := aSelector! !

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

OBSelectorNode class
	instanceVariableNames: ''!

!OBSelectorNode class methodsFor: 'instance creation' stamp: 'cwp 10/31/2004 01:11'!
on: aSelector
	^ self new selector: aSelector! !
OBListBrowser subclass: #OBSendersBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!

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

OBSendersBrowser class
	instanceVariableNames: ''!

!OBSendersBrowser class methodsFor: 'as yet unclassified' stamp: 'cwp 3/2/2006 15:31'!
defaultMetaNode
	| selector list chase |
	list := OBMetaNode named: 'Senders'.
	list 
		displaySelector: #fullName;
		addActor: OBNodeActor new.

	chase := OBMetaNode named: 'Send'.
	chase
		displaySelector: #fullName;
		childAt: #senders put: chase;
		addActor: OBNodeActor new.

	selector := OBMetaNode named: 'Selector'.	
	selector 
		childAt: #senders labeled: 'list' put: list;
		childAt: #senders labeled: 'chase' put: chase;
		filterClass: OBModalFilter.

	^ selector! !

!OBSendersBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:36'!
title
	^ 'Senders of'! !
Object subclass: #OBService
	instanceVariableNames: 'action condition announcer label keystroke icon buttonLabel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Services'!

!OBService methodsFor: 'accessing' stamp: 'cwp 6/18/2006 18:53'!
action
	^ action! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/18/2006 18:53'!
action: aValuable
	action _ aValuable! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 15:34'!
announcer
	^ announcer! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 15:33'!
announcer: anAnnouncer
	announcer _ anAnnouncer! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 19:38'!
buttonLabel
	^ buttonLabel! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 19:39'!
buttonLabel: aString
	buttonLabel _ aString! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 15:40'!
condition
	^ condition! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 15:40'!
condition: aValuable
	condition _ aValuable! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/25/2006 00:41'!
description
	^ 'description'! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 19:24'!
icon
	^ icon! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 19:24'!
icon: anIcon
	icon _ anIcon! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 19:04'!
keystroke
	^ keystroke! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 19:04'!
keystroke: aCharacter
	keystroke _ aCharacter! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 19:04'!
label
	^ label! !

!OBService methodsFor: 'accessing' stamp: 'cwp 6/24/2006 18:58'!
label: aString
	label _ aString! !


!OBService methodsFor: 'morphic' stamp: 'cwp 6/24/2006 18:46'!
addServiceFor: aRequestor toMenu: aMenu
	aMenu
		add: self labelWithKeystroke
		target: self 
		selector: #executeFor:
		argument: aRequestor.
	aMenu lastItem isEnabled: self isEnabled.
	Preferences menuWithIcons & self icon notNil
		ifTrue: [aMenu lastItem icon: self icon].
	aMenu addBlankIconsIfNecessary: MenuIcons blankIcon.! !

!OBService methodsFor: 'morphic' stamp: 'cwp 6/24/2006 19:41'!
buttonLabelMorph
	^ StringMorph 
		contents: self buttonLabel 
		font: Preferences standardButtonFont! !

!OBService methodsFor: 'morphic' stamp: 'cwp 6/24/2006 19:41'!
buttonMorph
	^ (PluggableButtonMorph
		on: self
		getState: nil
		action: #trigger
		label: #buttonLabelMorph)	
			onColor: Color lightGray lighter offColor: Color lightGray twiceLighter;
			borderWidth: 2;
			borderRaised;
			hResizing: #spaceFill;
			vResizing: #spaceFill;
			setBalloonText: label! !

!OBService methodsFor: 'morphic' stamp: 'cwp 6/24/2006 19:05'!
labelWithKeystroke
	^keystroke
		ifNil: [label]
		ifNotNil: [label, ' (', keystroke asString, ')']! !


!OBService methodsFor: 'execute' stamp: 'cwp 6/29/2006 01:12'!
condExecuteFor: aRequestor
	^ (self isEnabledFor: aRequestor)
		 ifTrue: [self executeFor: aRequestor]! !

!OBService methodsFor: 'execute' stamp: 'cwp 6/24/2006 18:15'!
execute
	^ self executeFor: nil! !

!OBService methodsFor: 'execute' stamp: 'cwp 6/24/2006 18:13'!
executeFor: aRequestor
	action valueWithPossibleArgs: {aRequestor}! !

!OBService methodsFor: 'execute' stamp: 'cwp 6/24/2006 15:42'!
trigger
	^ self isEnabled ifTrue: [self execute]! !


!OBService methodsFor: 'initialize-release' stamp: 'cwp 6/24/2006 19:05'!
initialize
	action _ [].
	condition _ [true].
	label _ 'a service'.! !


!OBService methodsFor: 'testing' stamp: 'cwp 6/29/2006 01:11'!
isEnabled
	^ self isEnabledFor: nil! !

!OBService methodsFor: 'testing' stamp: 'cwp 6/29/2006 01:07'!
isEnabledFor: aRequestor
	^ condition valueWithPossibleArgs: {aRequestor}! !

!OBService methodsFor: 'testing' stamp: 'cwp 6/25/2006 00:43'!
useLineAfter
	^ false! !

!OBService methodsFor: 'testing' stamp: 'cwp 6/24/2006 19:46'!
wantsButton
	^ self buttonLabel notNil! !

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

OBService class
	instanceVariableNames: ''!

!OBService class methodsFor: 'as yet unclassified' stamp: 'cwp 6/18/2006 18:53'!
action: aValuable
	^ self new action: aValuable! !

!OBService class methodsFor: 'as yet unclassified' stamp: 'cwp 6/24/2006 15:40'!
action: aValuable condition: cValuable
	^ self new 
		action: aValuable;
		condition: cValuable;
		yourself! !

!OBService class methodsFor: 'as yet unclassified' stamp: 'cwp 6/24/2006 15:43'!
new
	^ self basicNew initialize! !
OBAnnouncement subclass: #OBServiceScan
	instanceVariableNames: 'services'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Announcements'!

!OBServiceScan methodsFor: 'as yet unclassified' stamp: 'cwp 6/25/2006 00:31'!
addService: aService
	services add: aService! !

!OBServiceScan methodsFor: 'as yet unclassified' stamp: 'cwp 6/25/2006 00:31'!
initialize
	services _ OrderedCollection new! !

!OBServiceScan methodsFor: 'as yet unclassified' stamp: 'cwp 6/25/2006 00:30'!
services
	^ services! !
Notification subclass: #OBSourceFilesRequest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Utilities'!
!OBSourceFilesRequest commentStamp: 'cwp 1/8/2005 13:09' prior: 0!
OBSourceFilesRequest is used to work around the fact that Squeak's source files are stored in a global array called SourceFiles. When testing OBMethodVersion and OBVersionBrowser, we don't want to use the real source files, as they are too unpredictable. Instead the test cases supply a source file array with known contents.

Therefore, OBMethodVersion never refers directly to the SourceFiles global. Instead it raises an OBSourceFiles request. If this occurs during a test, the test catches the notification and resumes using the test source files. Otherwise, the default action resumes using the global source file array.!


!OBSourceFilesRequest methodsFor: 'exceptionDescription'!
defaultAction
	^ SourceFiles! !

!OBSourceFilesRequest methodsFor: 'exceptionDescription' stamp: 'cwp 11/27/2004 22:49'!
isBrowseRequest
	^ false! !
OBCodeBrowser subclass: #OBSystemBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!
!OBSystemBrowser commentStamp: 'cwp 1/7/2005 23:56' prior: 0!
This is the basic system browser that is the work-horse of Smalltalk development tools. It presents four panes showing class categories, classes, method categories and methods.!


!OBSystemBrowser methodsFor: 'morphic' stamp: 'avi 11/29/2004 21:52'!
defaultBackgroundColor
	^ Color lightGreen

! !

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

OBSystemBrowser class
	instanceVariableNames: ''!

!OBSystemBrowser class methodsFor: 'configuration' stamp: 'avi 9/17/2005 01:13'!
alphabeticalMetaNode
	^ self
		imageClass: #classes
		comment: #comments
		metaclass: #metaclasses
! !

!OBSystemBrowser class methodsFor: 'configuration' stamp: 'avi 9/17/2005 01:54'!
defaultMetaNode
	^self hierarchicalMetaNode! !

!OBSystemBrowser class methodsFor: 'configuration' stamp: 'cwp 12/6/2004 22:02'!
defaultRootNode
	^ OBEnvironmentNode forImage! !

!OBSystemBrowser class methodsFor: 'configuration' stamp: 'avi 9/17/2005 01:54'!
hierarchicalMetaNode
	^self 
		imageClass: #classesHierarchically
		comment: #commentsHierarchically
		metaclass: #metaclassesHierarchically! !

!OBSystemBrowser class methodsFor: 'configuration' stamp: 'avi 9/17/2005 01:09'!
imageClass: classSel comment: commentSel metaclass: metaclassSel 
	| env classCategory |
	env := OBMetaNode named: 'Environment'.
	classCategory := OBMetaNode named: 'ClassCategory'.
	env childAt: #categories put: classCategory.
	self addTo: classCategory class: classSel comment: commentSel metaclass: metaclassSel.
	^env! !

!OBSystemBrowser class methodsFor: 'configuration'!
title
	^ 'System Browser'! !


!OBSystemBrowser class methodsFor: 'initializing'!
initialize
	self registerInOpenMenu! !

!OBSystemBrowser class methodsFor: 'initializing'!
registerInOpenMenu
	TheWorldMenu registerOpenCommand: {'Image Browser'. {self. #open}}.
! !


!OBSystemBrowser class methodsFor: 'instance creation' stamp: 'dvf 8/31/2005 13:17'!
onClass: aClass 
	^self selection: aClass asNode! !

!OBSystemBrowser class methodsFor: 'instance creation' stamp: 'cwp 12/15/2004 21:42'!
onClass: aClass category: aSymbol
	^ self selection: (OBMethodCategoryNode on: aSymbol inClass: aClass)! !

!OBSystemBrowser class methodsFor: 'instance creation' stamp: 'cwp 12/5/2004 17:38'!
onClass: aClass selector: aSelector
	^ self selection: (OBMethodNode on: aSelector inClass: aClass)! !

!OBSystemBrowser class methodsFor: 'instance creation' stamp: 'cwp 12/15/2004 21:45'!
onEnvironment: anEnvironment category: aSymbol
	^ self selection: (OBClassCategoryNode 
						on: aSymbol 
						inEnvironment: anEnvironment)! !


!OBSystemBrowser class methodsFor: 'opening' stamp: 'cwp 12/5/2004 18:32'!
openOnClass: aClass
	^ (self onClass: aClass) open! !

!OBSystemBrowser class methodsFor: 'opening' stamp: 'cwp 12/15/2004 21:47'!
openOnClass: aClass category: aSymbol
	^ (self onClass: aClass category: aSymbol) open! !

!OBSystemBrowser class methodsFor: 'opening' stamp: 'cwp 12/5/2004 17:38'!
openOnClass: aClass selector: aSelector
	^ (self onClass: aClass selector: aSelector) open! !

!OBSystemBrowser class methodsFor: 'opening' stamp: 'cwp 12/15/2004 21:54'!
openOnEnvironment: anEnvironment category: aSymbol
	^ (self onEnvironment: anEnvironment category: aSymbol) open! !
Object subclass: #OBSystemBrowserAdaptor
	instanceVariableNames: 'class selector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Utilities'!
!OBSystemBrowserAdaptor commentStamp: 'cwp 1/8/2005 13:35' prior: 0!
OBSystemBrowserAdaptor implements the protocol expected by the SystemBrowser app registry, and thus allows OmniBrowser to be chosen as the default system browser. 

Caveat: because the required protocol is a little ...odd.... it can't be implemented well by OBSystemBrowser directly. OBSystemBrowserAdaptor does this reasonably well, but it has no way to provide a more natural name than its class name to the app registry menu.!


!OBSystemBrowserAdaptor methodsFor: 'registry protocol' stamp: 'cwp 12/5/2004 21:50'!
labelString
	^ 'System Browser'! !

!OBSystemBrowserAdaptor methodsFor: 'registry protocol' stamp: 'cwp 12/5/2004 21:49'!
openEditString: anUndefinedObject 
	^ self! !

!OBSystemBrowserAdaptor methodsFor: 'registry protocol' stamp: 'cwp 12/5/2004 21:49'!
setClass: aClass selector: aSelector 
	class _ aClass.
	selector _ aSelector! !


!OBSystemBrowserAdaptor methodsFor: 'accessing' stamp: 'cwp 12/5/2004 21:55'!
selector
	^ selector! !

!OBSystemBrowserAdaptor methodsFor: 'accessing' stamp: 'cwp 12/5/2004 21:55'!
targetClass
	^ class! !

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

OBSystemBrowserAdaptor class
	instanceVariableNames: ''!

!OBSystemBrowserAdaptor class methodsFor: 'initializing' stamp: 'cwp 12/5/2004 22:01'!
initialize
	self register! !

!OBSystemBrowserAdaptor class methodsFor: 'initializing' stamp: 'cwp 1/8/2005 21:52'!
register
	Smalltalk at: #SystemBrowser ifPresent: [:class | class register: self]! !

!OBSystemBrowserAdaptor class methodsFor: 'initializing' stamp: 'cwp 1/8/2005 21:53'!
unregister
	Smalltalk at: #SystemBrowser ifPresent: [:class | class unregister: self]! !


!OBSystemBrowserAdaptor class methodsFor: 'registry protocol' stamp: 'lr 4/20/2006 08:48'!
fullOnClass: aClass selector: aSelector
	^ OBSystemBrowser 
		openOnClass: aClass
		selector: aSelector! !

!OBSystemBrowserAdaptor class methodsFor: 'registry protocol' stamp: 'lr 3/28/2006 09:10'!
open
	OBSystemBrowser open! !

!OBSystemBrowserAdaptor class methodsFor: 'registry protocol' stamp: 'cwp 12/5/2004 21:59'!
openBrowser
	OBSystemBrowser open! !

!OBSystemBrowserAdaptor class methodsFor: 'registry protocol' stamp: 'cwp 12/5/2004 21:56'!
openBrowserView: adaptor label: ignored 
	^ OBSystemBrowser 
		openOnClass: adaptor targetClass 
		selector: adaptor selector! !
TextMorphForEditView subclass: #OBTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBTextMorph commentStamp: 'cwp 12/7/2004 00:07' prior: 0!
This is a trivial subclass of TextMorph. It overrides editor creation to use OBTextMorphEditor rather than a regular TextMorphEditor.!


!OBTextMorph methodsFor: 'private' stamp: 'cwp 10/30/2004 23:06'!
installEditorToReplace: priorEditor
	"Install an editor for my paragraph.  This constitutes 'hasFocus'.
	If priorEditor is not nil, then initialize the new editor from its state.
	We may want to rework this so it actually uses the prior editor."

	| stateArray |
	priorEditor ifNotNil: [stateArray _ priorEditor stateArray].
	editor _ OBTextMorphEditor new morph: self.
	editor changeParagraph: self paragraph.
	priorEditor ifNotNil: [editor stateArrayPut: stateArray].
	self selectionChanged.
	^ editor! !
TextMorphEditor subclass: #OBTextMorphEditor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Morphic'!
!OBTextMorphEditor commentStamp: 'cwp 1/7/2005 23:27' prior: 0!
OBTextMorphEditor overrides the TextMorphEditors handling of command keys, passing them along to its model for processing, rather than hard-coding their implementations.!


!OBTextMorphEditor methodsFor: 'actions' stamp: 'cwp 10/31/2004 01:52'!
browseIt
	| symbol |
	self lineSelectAndEmptyCheck: [^ self].
	(symbol _ self selectedSymbol) isNil ifTrue: [^ view flash].

	self send: #browseIt: toModelWith: {symbol} orDo: [super browseIt]! !

!OBTextMorphEditor methodsFor: 'actions' stamp: 'cwp 10/31/2004 00:40'!
implementorsOfIt
	"Open a senders browser on the selected selector"

	| selector |
	self lineSelectAndEmptyCheck: [^ self].
	(selector _ self selectedSelector) == nil ifTrue: [^ view flash].
	self send: #implementorsOfIt: toModelWith: {selector} orDo: [super sendersOfIt]! !

!OBTextMorphEditor methodsFor: 'actions' stamp: 'cwp 10/31/2004 01:10'!
referencesToIt

	| selector |
	self lineSelectAndEmptyCheck: [^ self].
	(selector _ self selectedSelector) == nil ifTrue: [^ view flash].
	self send: #referencesToIt: toModelWith: {selector} orDo: [super referencesToIt]! !

!OBTextMorphEditor methodsFor: 'actions' stamp: 'cwp 10/31/2004 00:26'!
sendersOfIt
	"Open a senders browser on the selected selector"

	| selector |
	self lineSelectAndEmptyCheck: [^ self].
	(selector _ self selectedSelector) == nil ifTrue: [^ view flash].
	self send: #sendersOfIt: toModelWith: {selector} orDo: [super sendersOfIt]! !


!OBTextMorphEditor methodsFor: 'model access' stamp: 'cwp 10/31/2004 00:24'!
send: aSelector toModelWith: args orDo: aBlock
	self terminateAndInitializeAround:
		[(model respondsTo: aSelector)
			ifTrue: [(model perform: aSelector withArguments: args)
						ifFalse: [view flash]]
			ifFalse: aBlock]! !
OBInteractionRequest subclass: #OBTextRequest
	instanceVariableNames: 'prompt template'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Notifications'!
!OBTextRequest commentStamp: 'cwp 3/5/2004 12:35' prior: 0!
This notification is used to ask the user to supply a short piece of text. Its defaultAction is to open a FillInTheBlank.

iVars:

prompt		- a string describing the text the user is asked to supply
template	- a default reply !


!OBTextRequest methodsFor: 'accessing' stamp: 'cwp 2/2/2004 21:24'!
prompt
	^ prompt! !

!OBTextRequest methodsFor: 'accessing' stamp: 'cwp 2/2/2004 21:23'!
prompt: aString
	prompt _ aString! !

!OBTextRequest methodsFor: 'accessing' stamp: 'cwp 2/2/2004 21:00'!
template
	^ template! !

!OBTextRequest methodsFor: 'accessing' stamp: 'cwp 2/2/2004 20:59'!
template: aString
	template _ aString! !


!OBTextRequest methodsFor: 'user interaction' stamp: 'cwp 2/2/2004 21:27'!
defaultAction
	self resume: self requestText! !

!OBTextRequest methodsFor: 'user interaction' stamp: 'cwp 2/2/2004 21:27'!
requestText
	^ FillInTheBlankMorph 
		request: prompt
		initialAnswer: template
		centerAt: Sensor cursorPoint
		inWorld: World
		onCancelReturn: nil
		acceptOnCR: true! !

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

OBTextRequest class
	instanceVariableNames: ''!

!OBTextRequest class methodsFor: 'as yet unclassified' stamp: 'cwp 2/2/2004 21:30'!
prompt: aString
	^ self new prompt: aString; template: ''! !

!OBTextRequest class methodsFor: 'as yet unclassified' stamp: 'cwp 2/5/2004 20:31'!
prompt: promptString template: templateString
	^ (self new prompt: promptString; template: templateString) signal! !
OBPanel subclass: #OBVarButtonPanel
	instanceVariableNames: 'morph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OmniBrowser-Panels'!
!OBVarButtonPanel commentStamp: 'cwp 12/7/2004 00:21' prior: 0!
OBVarButtonPanel displays a horizontal row of buttons. In contrast to OBFixedButtonPanel, the buttons on display are updated to reflect the actions appropriate to the currently selected node.!


!OBVarButtonPanel methodsFor: 'constructing' stamp: 'cwp 11/27/2004 18:16'!
morph
	^ morph _ (RectangleMorph new)
					layoutPolicy: TableLayout new;
					listDirection: #leftToRight;
					hResizing: #spaceFill;
					vResizing: #spaceFill;
					borderWidth: 0;
					wrapCentering: #center;
					cellPositioning: #leftCenter;
					rubberBandCells: true;
					yourself! !

!OBVarButtonPanel methodsFor: 'constructing' stamp: 'cwp 11/26/2004 22:41'!
morphHeight
	^ 25! !


!OBVarButtonPanel methodsFor: 'updating' stamp: 'cwp 7/8/2006 12:54'!
selectionChanged: ann
	| node actions |
	morph removeAllMorphs.
	node _ browser currentNode ifNil: [^ self].
	actions _ (node metaNode actionsForNode: node) select: [:ea | ea wantsButton].
	actions do: [:ea | morph addMorphBack: ea buttonMorph]! !

!OBVarButtonPanel methodsFor: 'updating' stamp: 'cwp 6/3/2006 22:30'!
subscribe
	self announcer
		observe: OBSelectionChanged
		send: #selectionChanged:
		to: self! !
OBClassAwareNode subclass: #OBVariableNode
	instanceVariableNames: 'name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Nodes'!
!OBVariableNode commentStamp: 'cwp 1/8/2005 12:46' prior: 0!
OBVariableNode is an abstract superclass for the two types of variables a class can contain - class variables and instance variables. The only difference between the two subclasses is how they search for methods that refer to them.!


!OBVariableNode methodsFor: 'actions' stamp: 'cwp 12/15/2004 22:38'!
actions
	^ {self browseAction}! !


!OBVariableNode methodsFor: 'displaying'!
name
	^ name! !


!OBVariableNode methodsFor: 'initializing'!
setName: aString class: aClass
	name := aString.
	self theClass: aClass! !

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

OBVariableNode class
	instanceVariableNames: ''!

!OBVariableNode class methodsFor: 'instance creation'!
on: instVarName inClass: aClassReference 
	^ self new setName: instVarName class: aClassReference! !
OBListBrowser subclass: #OBVariablesBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!

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

OBVariablesBrowser class
	instanceVariableNames: ''!

!OBVariablesBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:22'!
defaultMetaNode
	| class method message var |
	class := OBMetaNode named: 'Class'.
	var := OBMetaNode named: 'Variable'.
	method := OBMetaNode named: 'Method'.
	message := OBMetaNode named: 'Message'.
	class
		addActor: OBNodeActor new;
		childAt: #instanceVariables labeled: 'instance' put: var;
		childAt: #classVariables labeled: 'class' put: var;
		filterClass: OBModalFilter.
	var
		childAt: #accessors put: method;
		addActor: OBNodeActor new;
		filterClass: OBModalFilter.
	method
		displaySelector: #fullName;
		addActor: OBNodeActor new;
		childAt: #senders put: message;
		filterClass: OBModalFilter.
	message
		displaySelector: #fullName;
		addActor: OBNodeActor new;
		childAt: #senders put: message;
		filterClass: OBModalFilter.
	
	^ class! !

!OBVariablesBrowser class methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 01:35'!
title
	^ 'Variables of'! !
OBCodeBrowser subclass: #OBVersionBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'OB-Standard-Browsers'!
!OBVersionBrowser commentStamp: 'cwp 1/7/2005 23:58' prior: 0!
OBVersionBrowser displays a list of OBMethodVersions, which represent versions of a method present in the source or changes files. !


!OBVersionBrowser methodsFor: 'morphic' stamp: 'avi 11/29/2004 21:52'!
defaultBackgroundColor
	^ Color lightMagenta! !


!OBVersionBrowser methodsFor: 'accessing' stamp: 'cwp 11/27/2004 22:28'!
defaultLabel
	^ 'Versions of ', self root name printString! !

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

OBVersionBrowser class
	instanceVariableNames: ''!

!OBVersionBrowser class methodsFor: 'configuration' stamp: 'avi 9/17/2005 01:09'!
defaultMetaNode
	| version |
	version := OBMetaNode named: 'Version'.
	version addActor: OBNodeActor new.
	^ (OBMetaNode named: 'Method') 
		childAt: #versions put: version.! !

!OBVersionBrowser class methodsFor: 'configuration' stamp: 'cwp 11/27/2004 22:32'!
maxPanes
	^ 1! !

!OBVersionBrowser class methodsFor: 'configuration' stamp: 'cwp 11/27/2004 22:32'!
minPanes
	^ 1! !

!OBVersionBrowser class methodsFor: 'configuration' stamp: 'cwp 11/27/2004 22:34'!
optionalButtons
	^ #('browse' 'revert')! !


!OBVersionBrowser class methodsFor: 'opening' stamp: 'cwp 12/5/2004 15:42'!
openOn: aMethodVersionNode
	^ (self root: aMethodVersionNode) open! !
ProtoObject subclass: #Object
	instanceVariableNames: ''
	classVariableNames: 'DependentsFields'
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!Object commentStamp: '<historical>' prior: 0!
Object is the root class for almost all of the other classes in the class hierarchy. The exceptions are ProtoObject (the superclass of Object) and its subclasses.

Class Object provides default behavior common to all normal objects, such as access, copying, comparison, error handling, message sending, and reflection. Also utility messages that all objects should respond to are defined here.

Object has no instance variables, nor should any be added. This is due to several classes of objects that inherit from Object that have special implementations (SmallInteger and UndefinedObject for example) or the VM knows about and depends on the structure and layout of certain standard classes.

Class Variables:
	DependentsFields		an IdentityDictionary
		Provides a virtual 'dependents' field so that any object may have one
		or more dependent views, synchronized by the changed:/update: protocol.
		Note that class Model has a real slot for its dependents, and overrides
		the associated protocol with more efficient implementations.
	EventsFields			an IdentityDictionary that maps each object to its dependents.
		Registers a message send (consisting of a selector and a receiver object)
		which should be performed when anEventSymbol is triggered by the receiver.
		Part of a new event notification framework which could eventually replace
		the existing changed/update mechanism.  It is intended to be compatible
		with Dolphin Smalltalk and VSE as much as possible.

Because Object is the root of the inheritance tree, methods are often defined in Object to give all objects special behaviors needed by certain subsystems or applications, or to respond to certain general test messages such as isMorph.!


!Object methodsFor: 'accessing' stamp: 'sw 4/30/1998 12:18'!
addInstanceVarNamed: aName withValue: aValue
	"Add an instance variable named aName and give it value aValue"
	self class addInstVarName: aName asString.
	self instVarAt: self class instSize put: aValue! !

!Object methodsFor: 'accessing' stamp: 'yo 6/29/2004 11:39'!
at: index 
	"Primitive. Assumes receiver is indexable. Answer the value of an 
	indexable element in the receiver. Fail if the argument index is not an 
	Integer or is out of bounds. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 60>
	index isInteger ifTrue:
		[self class isVariable
			ifTrue: [self errorSubscriptBounds: index]
			ifFalse: [self errorNotIndexable]].
	index isNumber
		ifTrue: [^self at: index asInteger]
		ifFalse: [self errorNonIntegerIndex]! !

!Object methodsFor: 'accessing'!
at: index modify: aBlock
	"Replace the element of the collection with itself transformed by the block"
	^ self at: index put: (aBlock value: (self at: index))! !

!Object methodsFor: 'accessing' stamp: 'yo 6/29/2004 13:08'!
at: index put: value 
	"Primitive. Assumes receiver is indexable. Store the argument value in 
	the indexable element of the receiver indicated by index. Fail if the 
	index is not an Integer or is out of bounds. Or fail if the value is not of 
	the right type for this kind of collection. Answer the value that was 
	stored. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 61>
	index isInteger ifTrue:
		[self class isVariable
			ifTrue: [(index >= 1 and: [index <= self size])
					ifTrue: [self errorImproperStore]
					ifFalse: [self errorSubscriptBounds: index]]
			ifFalse: [self errorNotIndexable]].
	index isNumber
		ifTrue: [^self at: index asInteger put: value]
		ifFalse: [self errorNonIntegerIndex]! !

!Object methodsFor: 'accessing' stamp: 'yo 9/20/2004 10:22'!
basicAddInstanceVarNamed: aName withValue: aValue
	"Add an instance variable named aName and give it value aValue"
	self class addInstVarName: aName asString.
	self instVarAt: self class instSize put: aValue! !

!Object methodsFor: 'accessing'!
basicAt: index 
	"Primitive. Assumes receiver is indexable. Answer the value of an 
	indexable element in the receiver. Fail if the argument index is not an 
	Integer or is out of bounds. Essential. Do not override in a subclass. See 
	Object documentation whatIsAPrimitive."

	<primitive: 60>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber
		ifTrue: [^self basicAt: index asInteger]
		ifFalse: [self errorNonIntegerIndex]! !

!Object methodsFor: 'accessing'!
basicAt: index put: value 
	"Primitive. Assumes receiver is indexable. Store the second argument 
	value in the indexable element of the receiver indicated by index. Fail 
	if the index is not an Integer or is out of bounds. Or fail if the value is 
	not of the right type for this kind of collection. Answer the value that 
	was stored. Essential. Do not override in a subclass. See Object 
	documentation whatIsAPrimitive."

	<primitive: 61>
	index isInteger
		ifTrue: [(index >= 1 and: [index <= self size])
					ifTrue: [self errorImproperStore]
					ifFalse: [self errorSubscriptBounds: index]].
	index isNumber
		ifTrue: [^self basicAt: index asInteger put: value]
		ifFalse: [self errorNonIntegerIndex]! !

!Object methodsFor: 'accessing'!
basicSize
	"Primitive. Answer the number of indexable variables in the receiver. 
	This value is the same as the largest legal subscript. Essential. Do not 
	override in any subclass. See Object documentation whatIsAPrimitive."

	<primitive: 62>
	"The number of indexable fields of fixed-length objects is 0"
	^0	! !

!Object methodsFor: 'accessing'!
bindWithTemp: aBlock
	^ aBlock value: self value: nil! !

!Object methodsFor: 'accessing' stamp: 'md 10/7/2004 15:43'!
ifNil: nilBlock ifNotNilDo: aBlock 
	"Evaluate aBlock with the receiver as its argument."

	^ aBlock value: self
! !

!Object methodsFor: 'accessing' stamp: 'di 11/8/2000 21:04'!
ifNotNilDo: aBlock
	"Evaluate the given block with the receiver as its argument."

	^ aBlock value: self
! !

!Object methodsFor: 'accessing' stamp: 'md 10/7/2004 15:43'!
ifNotNilDo: aBlock ifNil: nilBlock
	"Evaluate aBlock with the receiver as its argument."

	^ aBlock value: self
! !

!Object methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:59'!
in: aBlock
	"Evaluate the given block with the receiver as its argument."

	^ aBlock value: self
! !

!Object methodsFor: 'accessing' stamp: 'sw 10/17/2000 11:15'!
presenter
	"Answer the presenter object associated with the receiver.  For morphs, there is in effect a clear containment hierarchy of presenters (accessed via their association with PasteUpMorphs); for arbitrary objects the hook is simply via the current world, at least at present."

	^ self currentWorld presenter! !

!Object methodsFor: 'accessing'!
readFromString: aString
	"Create an object based on the contents of aString."

	^self readFrom: (ReadStream on: aString)! !

!Object methodsFor: 'accessing' stamp: 'di 3/29/1999 13:10'!
size
	"Primitive. Answer the number of indexable variables in the receiver. 
	This value is the same as the largest legal subscript. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 62>
	self class isVariable ifFalse: [self errorNotIndexable].
	^ 0! !

!Object methodsFor: 'accessing' stamp: 'md 5/16/2006 12:34'!
yourself
	"Answer self."
	^self! !


!Object methodsFor: 'associating' stamp: 'md 7/22/2005 16:03'!
-> anObject
	"Answer an Association between self and anObject"

	^Association basicNew key: self value: anObject! !



!Object methodsFor: 'binding'!
bindingOf: aString
	^nil! !


!Object methodsFor: 'casing'!
caseOf: aBlockAssociationCollection
	"The elements of aBlockAssociationCollection are associations between blocks.
	 Answer the evaluated value of the first association in aBlockAssociationCollection
	 whose evaluated key equals the receiver.  If no match is found, report an error."

	^ self caseOf: aBlockAssociationCollection otherwise: [self caseError]

"| z | z _ {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z"
"| z | z _ {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z"
"The following are compiled in-line:"
"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}"
"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}"! !

!Object methodsFor: 'casing'!
caseOf: aBlockAssociationCollection otherwise: aBlock
	"The elements of aBlockAssociationCollection are associations between blocks.
	 Answer the evaluated value of the first association in aBlockAssociationCollection
	 whose evaluated key equals the receiver.  If no match is found, answer the result
	 of evaluating aBlock."

	aBlockAssociationCollection associationsDo:
		[:assoc | (assoc key value = self) ifTrue: [^assoc value value]].
	^ aBlock value

"| z | z _ {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]"
"| z | z _ {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]"
"The following are compiled in-line:"
"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"
"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"! !


!Object methodsFor: 'class membership'!
class
	"Primitive. Answer the object which is the receiver's class. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 111>
	self primitiveFailed! !

!Object methodsFor: 'class membership' stamp: 'sw 9/27/2001 15:51'!
inheritsFromAnyIn: aList
	"Answer whether the receiver inherits from any class represented by any element in the list.  The elements of the list can be classes, class name symbols, or strings representing possible class names.  This allows speculative membership tests to be made even when some of the classes may not be known to the current image, and even when their names are not interned symbols."

	| aClass |
	aList do:
		[:elem | Symbol hasInterned: elem asString ifTrue: 
			[:elemSymbol | (((aClass _ Smalltalk at: elemSymbol ifAbsent: [nil]) isKindOf: Class)
						and: [self isKindOf: aClass])
				ifTrue:
					[^ true]]].
	^ false


"
{3.  true. 'olive'} do:
	[:token |
		 {{#Number. #Boolean}. {Number.  Boolean }.  {'Number'. 'Boolean'}} do:
			[:list |
				Transcript cr; show: token asString, ' list element provided as a ', list first class name, ' - ', (token inheritsFromAnyIn: list) asString]]
"! !

!Object methodsFor: 'class membership'!
isKindOf: aClass 
	"Answer whether the class, aClass, is a superclass or class of the receiver."

	self class == aClass
		ifTrue: [^true]
		ifFalse: [^self class inheritsFrom: aClass]! !

!Object methodsFor: 'class membership' stamp: 'sw 2/16/98 02:08'!
isKindOf: aClass orOf: anotherClass
	"Answer whether either of the classes, aClass or anotherClass,, is a superclass or class of the receiver.  A convenience; could be somewhat optimized"
	^ (self isKindOf: aClass) or: [self isKindOf: anotherClass]! !

!Object methodsFor: 'class membership'!
isMemberOf: aClass 
	"Answer whether the receiver is an instance of the class, aClass."

	^self class == aClass! !

!Object methodsFor: 'class membership'!
respondsTo: aSymbol 
	"Answer whether the method dictionary of the receiver's class contains 
	aSymbol as a message selector."

	^self class canUnderstand: aSymbol! !

!Object methodsFor: 'class membership' stamp: 'tk 10/21/1998 12:38'!
xxxClass
	"For subclasses of nil, such as ObjectOut"
	^ self class! !


!Object methodsFor: 'comparing' stamp: 'tk 4/16/1999 18:26'!
closeTo: anObject
	"Answer whether the receiver and the argument represent the same
	object. If = is redefined in any subclass, consider also redefining the
	message hash."

	| ans |
	[ans _ self = anObject] ifError: [:aString :aReceiver | ^ false].
	^ ans! !

!Object methodsFor: 'comparing'!
hash
	"Answer a SmallInteger whose value is related to the receiver's identity.
	May be overridden, and should be overridden in any classes that define = "

	^ self identityHash! !

!Object methodsFor: 'comparing' stamp: 'pm 9/23/97 09:36'!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^map newHashFor: self! !

!Object methodsFor: 'comparing' stamp: 'di 9/27/97 20:23'!
identityHashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^map newHashFor: self! !

!Object methodsFor: 'comparing' stamp: 'sw 8/20/1998 12:34'!
identityHashPrintString
	"'fred' identityHashPrintString"

	^ '(', self identityHash printString, ')'! !

!Object methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:02'!
literalEqual: other

	^ self class == other class and: [self = other]! !

!Object methodsFor: 'comparing'!
= anObject 
	"Answer whether the receiver and the argument represent the same 
	object. If = is redefined in any subclass, consider also redefining the 
	message hash."

	^self == anObject! !

!Object methodsFor: 'comparing'!
~= anObject 
	"Answer whether the receiver and the argument do not represent the 
	same object."

	^self = anObject == false! !


!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'!
adaptToFloat: rcvr andSend: selector
	"If no method has been provided for adapting an object to a Float,
	then it may be adequate to simply adapt it to a number."
	^ self adaptToNumber: rcvr andSend: selector! !

!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:14'!
adaptToFraction: rcvr andSend: selector
	"If no method has been provided for adapting an object to a Fraction,
	then it may be adequate to simply adapt it to a number."
	^ self adaptToNumber: rcvr andSend: selector! !

!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'!
adaptToInteger: rcvr andSend: selector
	"If no method has been provided for adapting an object to a Integer,
	then it may be adequate to simply adapt it to a number."
	^ self adaptToNumber: rcvr andSend: selector! !

!Object methodsFor: 'converting' stamp: 'rw 4/27/2002 07:48'!
asActionSequence

	^WeakActionSequence with: self! !

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

	^WeakActionSequenceTrappingErrors with: self! !

!Object methodsFor: 'converting' stamp: 'svp 5/16/2000 18:14'!
asDraggableMorph
	^(StringMorph contents: self printString)
		color: Color white;
		yourself! !

!Object methodsFor: 'converting' stamp: 'sma 5/12/2000 17:39'!
asOrderedCollection
	"Answer an OrderedCollection with the receiver as its only element."

	^ OrderedCollection with: self! !

!Object methodsFor: 'converting'!
asString
	"Answer a string that represents the receiver."

	^ self printString ! !

!Object methodsFor: 'converting' stamp: 'ajh 3/11/2003 10:27'!
asStringOrText
	"Answer a string that represents the receiver."

	^ self printString ! !

!Object methodsFor: 'converting'!
as: aSimilarClass
	"Create an object of class aSimilarClass that has similar contents to the receiver."

	^ aSimilarClass newFrom: self! !

!Object methodsFor: 'converting' stamp: 'RAA 8/2/1999 12:41'!
complexContents

	^self! !

!Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:37'!
mustBeBoolean
	"Catches attempts to test truth of non-Booleans.  This message is sent from the VM.  The sending context is rewound to just before the jump causing this exception."

	^ self mustBeBooleanIn: thisContext sender! !

!Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:40'!
mustBeBooleanIn: context
	"context is the where the non-boolean error occurred. Rewind context to before jump then raise error."

	| proceedValue |
	context skipBackBeforeJump.
	proceedValue _ NonBooleanReceiver new
		object: self;
		signal: 'proceed for truth.'.
	^ proceedValue ~~ false! !

!Object methodsFor: 'converting' stamp: 'sw 3/26/2001 12:12'!
printDirectlyToDisplay
	"For debugging: write the receiver's printString directly to the display at (0, 100); senders of this are detected by the check-for-slips mechanism."

	self asString displayAt: 0@100

"StringMorph someInstance printDirectlyToDisplay"! !

!Object methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'!
withoutListWrapper

	^self! !


!Object methodsFor: 'copying'!
clone

	<primitive: 148>
	self primitiveFailed! !

!Object methodsFor: 'copying' stamp: 'ajh 8/18/2001 21:25'!
copy
	"Answer another instance just like the receiver. Subclasses typically override postCopy; they typically do not override shallowCopy."

	^self shallowCopy postCopy! !

!Object methodsFor: 'copying' stamp: 'tk 8/20/1998 16:01'!
copyAddedStateFrom: anotherObject
	"Copy over the values of instance variables added by the receiver's class from anotherObject to the receiver.  These will be remapped in mapUniClasses, if needed."

	self class superclass instSize + 1 to: self class instSize do:
		[:index | self instVarAt: index put: (anotherObject instVarAt: index)]! !

!Object methodsFor: 'copying' stamp: 'tpr 2/14/2004 21:53'!
copyFrom: anotherObject
	"Copy to myself all instance variables I have in common with anotherObject.  This is dangerous because it ignores an object's control over its own inst vars.  "

	| mine his |
	<primitive: 168>
	mine _ self class allInstVarNames.
	his _ anotherObject class allInstVarNames.
	1 to: (mine size min: his size) do: [:ind |
		(mine at: ind) = (his at: ind) ifTrue: [
			self instVarAt: ind put: (anotherObject instVarAt: ind)]].
	self class isVariable & anotherObject class isVariable ifTrue: [
		1 to: (self basicSize min: anotherObject basicSize) do: [:ind |
			self basicAt: ind put: (anotherObject basicAt: ind)]].! !

!Object methodsFor: 'copying' stamp: 'ajh 5/23/2002 00:38'!
copySameFrom: otherObject
	"Copy to myself all instance variables named the same in otherObject.
	This ignores otherObject's control over its own inst vars."

	| myInstVars otherInstVars match |
	myInstVars _ self class allInstVarNames.
	otherInstVars _ otherObject class allInstVarNames.
	myInstVars doWithIndex: [:each :index |
		(match _ otherInstVars indexOf: each) > 0 ifTrue:
			[self instVarAt: index put: (otherObject instVarAt: match)]].
	1 to: (self basicSize min: otherObject basicSize) do: [:i |
		self basicAt: i put: (otherObject basicAt: i)].
! !

!Object methodsFor: 'copying' stamp: 'tk 4/20/1999 14:44'!
copyTwoLevel
	"one more level than a shallowCopy"

	| newObject class index |
	class _ self class.
	newObject _ self clone.
	newObject == self ifTrue: [^ self].
	class isVariable
		ifTrue: 
			[index _ self basicSize.
			[index > 0]
				whileTrue: 
					[newObject basicAt: index put: (self basicAt: index) shallowCopy.
					index _ index - 1]].
	index _ class instSize.
	[index > 0]
		whileTrue: 
			[newObject instVarAt: index put: (self instVarAt: index) shallowCopy.
			index _ index - 1].
	^newObject! !

!Object methodsFor: 'copying'!
deepCopy
	"Answer a copy of the receiver with its own copy of each instance 
	variable."

	| newObject class index |
	class _ self class.
	(class == Object) ifTrue: [^self].
	class isVariable
		ifTrue: 
			[index _ self basicSize.
			newObject _ class basicNew: index.
			[index > 0]
				whileTrue: 
					[newObject basicAt: index put: (self basicAt: index) deepCopy.
					index _ index - 1]]
		ifFalse: [newObject _ class basicNew].
	index _ class instSize.
	[index > 0]
		whileTrue: 
			[newObject instVarAt: index put: (self instVarAt: index) deepCopy.
			index _ index - 1].
	^newObject! !

!Object methodsFor: 'copying' stamp: 'hg 11/23/1999 13:43'!
initialDeepCopierSize
	"default value is 4096; other classes may override this, esp. for smaller (=faster) sizes"

	^4096! !

!Object methodsFor: 'copying' stamp: 'ajh 1/27/2003 18:45'!
postCopy
	"self is a shallow copy, subclasses should copy fields as necessary to complete the full copy"

	^ self! !

!Object methodsFor: 'copying' stamp: 'jm 11/14/97 11:08'!
shallowCopy
	"Answer a copy of the receiver which shares the receiver's instance variables."
	| class newObject index |
	<primitive: 148>
	class _ self class.
	class isVariable
		ifTrue: 
			[index _ self basicSize.
			newObject _ class basicNew: index.
			[index > 0]
				whileTrue: 
					[newObject basicAt: index put: (self basicAt: index).
					index _ index - 1]]
		ifFalse: [newObject _ class basicNew].
	index _ class instSize.
	[index > 0]
		whileTrue: 
			[newObject instVarAt: index put: (self instVarAt: index).
			index _ index - 1].
	^ newObject! !

!Object methodsFor: 'copying' stamp: 'tk 3/11/2003 13:58'!
veryDeepCopy
	"Do a complete tree copy using a dictionary.  An object in the tree twice is only copied once.  All references to the object in the copy of the tree will point to the new copy."

	| copier new |
	copier _ DeepCopier new initialize: self initialDeepCopierSize.
	new _ self veryDeepCopyWith: copier.
	copier mapUniClasses.
	copier references associationsDo: [:assoc | 
		assoc value veryDeepFixupWith: copier].
	copier fixDependents.
	^ new! !

!Object methodsFor: 'copying' stamp: 'tk 3/11/2003 13:58'!
veryDeepCopySibling
	"Do a complete tree copy using a dictionary.  Substitute a clone of oldPlayer for the root.  Normally, a Player or non systemDefined object would have a new class.  We do not want one this time.  An object in the tree twice, is only copied once.  All references to the object in the copy of the tree will point to the new copy."

	| copier new |
	copier _ DeepCopier new initialize: self initialDeepCopierSize.
	copier newUniClasses: false.
	new _ self veryDeepCopyWith: copier.
	copier mapUniClasses.
	copier references associationsDo: [:assoc | 
		assoc value veryDeepFixupWith: copier].
	copier fixDependents.
	^ new! !

!Object methodsFor: 'copying' stamp: 'tk 5/13/2003 19:39'!
veryDeepCopyUsing: copier
	"Do a complete tree copy using a dictionary.  An object in the tree twice is only copied once.  All references to the object in the copy of the tree will point to the new copy.
	Same as veryDeepCopy except copier (with dictionary) is supplied.
	** do not delete this method, even if it has no callers **"

	| new refs newDep newModel |
	new _ self veryDeepCopyWith: copier.
	copier mapUniClasses.
	copier references associationsDo: [:assoc | 
		assoc value veryDeepFixupWith: copier].
	"Fix dependents"
	refs _ copier references.
	DependentsFields associationsDo: [:pair |
		pair value do: [:dep | 
			(newDep _ refs at: dep ifAbsent: [nil]) ifNotNil: [
				newModel _ refs at: pair key ifAbsent: [pair key].
				newModel addDependent: newDep]]].
	^ new! !

!Object methodsFor: 'copying' stamp: 'tk 3/11/2003 14:12'!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
	| class index sub subAss new uc sup has mine |
	deepCopier references at: self ifPresent: [:newer | ^ newer]. 	"already did him"
	class _ self class.
	class isMeta ifTrue: [^ self].		"a class"
	new _ self clone.
	(class isSystemDefined not and: [deepCopier newUniClasses "allowed"]) ifTrue: [
		uc _ deepCopier uniClasses at: class ifAbsent: [nil].
		uc ifNil: [
			deepCopier uniClasses at: class put: (uc _ self copyUniClassWith: deepCopier).
			deepCopier references at: class put: uc].	"remember"
		new _ uc new.
		new copyFrom: self].	"copy inst vars in case any are weak"
	deepCopier references at: self put: new.	"remember"
	(class isVariable and: [class isPointers]) ifTrue: 
		[index _ self basicSize.
		[index > 0] whileTrue: 
			[sub _ self basicAt: index.
			(subAss _ deepCopier references associationAt: sub ifAbsent: [nil])
				ifNil: [new basicAt: index put: (sub veryDeepCopyWith: deepCopier)]
				ifNotNil: [new basicAt: index put: subAss value].
			index _ index - 1]].
	"Ask each superclass if it wants to share (weak copy) any inst vars"
	new veryDeepInner: deepCopier.		"does super a lot"

	"other superclasses want all inst vars deep copied"
	sup _ class.  index _ class instSize.
	[has _ sup compiledMethodAt: #veryDeepInner: ifAbsent: [nil].
	has _ has ifNil: [class isSystemDefined not "is a uniClass"] ifNotNil: [true].
	mine _ sup instVarNames.
	has ifTrue: [index _ index - mine size]	"skip inst vars"
		ifFalse: [1 to: mine size do: [:xx |
				sub _ self instVarAt: index.
				(subAss _ deepCopier references associationAt: sub ifAbsent: [nil])
						"use association, not value, so nil is an exceptional value"
					ifNil: [new instVarAt: index put: 
								(sub veryDeepCopyWith: deepCopier)]
					ifNotNil: [new instVarAt: index put: subAss value].
				index _ index - 1]].
	(sup _ sup superclass) == nil] whileFalse.
	new rehash.	"force Sets and Dictionaries to rehash"
	^ new
! !

!Object methodsFor: 'copying' stamp: 'tk 1/6/1999 17:39'!
veryDeepFixupWith: deepCopier
	"I have no fields and no superclass.  Catch the super call."
! !

!Object methodsFor: 'copying' stamp: 'tk 9/4/2001 10:30'!
veryDeepInner: deepCopier
	"No special treatment for inst vars of my superclasses.  Override when some need to be weakly copied.  Object>>veryDeepCopyWith: will veryDeepCopy any inst var whose class does not actually define veryDeepInner:"
! !


!Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:33'!
asMorph
	"Open a morph, as best one can, on the receiver"

	^ self asStringMorph

	"
234 asMorph
(ScriptingSystem formAtKey: #TinyMenu) asMorph
'fred' asMorph
"

! !

!Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:35'!
asStringMorph
	"Open a StringMorph, as best one can, on the receiver"

	^ self asStringOrText asStringMorph
! !

!Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:35'!
asTextMorph
	"Open a TextMorph, as best one can, on the receiver"

	^ TextMorph new contentsAsIs: self asStringOrText
! !

!Object methodsFor: 'creation' stamp: 'sw 1/29/2002 21:45'!
openAsMorph
	"Open a morph, as best one can, on the receiver"

	^ self asMorph openInHand

"
234 openAsMorph
(ScriptingSystem formAtKey: #TinyMenu) openAsMorph
'fred' openAsMorph
"! !


!Object methodsFor: 'debugging' stamp: 'md 11/24/2004 11:45'!
haltIf: condition
	"This is the typical message to use for inserting breakpoints during 
	debugging.  Param can be a block or expression, halt if true.
	If the Block has one arg, the receiver is bound to that.
 	If the condition is a selector, we look up in the callchain. Halt if
      any method's selector equals selector."
	| cntxt |

	condition isSymbol ifTrue:[
		"only halt if a method with selector symbol is in callchain"
		cntxt := thisContext.
		[cntxt sender isNil] whileFalse: [
			cntxt := cntxt sender. 
			(cntxt selector = condition) ifTrue: [Halt signal].
			].
		^self.
	].
	(condition isBlock 
			ifTrue: [condition valueWithPossibleArgument: self] 
			ifFalse: [condition] 
	) ifTrue: [
		Halt signal
	].! !

!Object methodsFor: 'debugging'!
needsWork! !


!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:26'!
checkHaltCountExpired
	| counter |
	counter _ Smalltalk at: #HaltCount ifAbsent: [0].
	^counter = 0! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:04'!
clearHaltOnce
	"Turn on the halt once flag."
	Smalltalk at: #HaltOnce put: false! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:30'!
decrementAndCheckHaltCount
	self decrementHaltCount.
	^self checkHaltCountExpired! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:28'!
decrementHaltCount
	| counter |
	counter := Smalltalk
				at: #HaltCount
				ifAbsent: [0].
	counter > 0 ifTrue: [
		counter _ counter - 1.
		self setHaltCountTo: counter]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:42'!
doExpiredHaltCount
	self clearHaltOnce.
	self removeHaltCount.
	self halt! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:44'!
doExpiredHaltCount: aString
	self clearHaltOnce.
	self removeHaltCount.
	self halt: aString! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:45'!
doExpiredInspectCount
	self clearHaltOnce.
	self removeHaltCount.
	self inspect! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:43'!
haltOnCount: int 
	self haltOnceEnabled
		ifTrue: [self hasHaltCount
				ifTrue: [self decrementAndCheckHaltCount
						ifTrue: [self doExpiredHaltCount]]
				ifFalse: [int = 1
						ifTrue: [self doExpiredHaltCount]
						ifFalse: [self setHaltCountTo: int - 1]]]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:05'!
haltOnce
	"Halt unless we have already done it once."
	self haltOnceEnabled
		ifTrue: [self clearHaltOnce.
			^ self halt]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:04'!
haltOnceEnabled
	^ Smalltalk
		at: #HaltOnce
		ifAbsent: [false]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:05'!
haltOnce: aString 
	"Halt unless we have already done it once."
	self haltOnceEnabled
		ifTrue: [self clearHaltOnce.
			^ self halt: aString]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:45'!
halt: aString onCount: int 
	self haltOnceEnabled
		ifTrue: [self hasHaltCount
				ifTrue: [self decrementAndCheckHaltCount
						ifTrue: [self doExpiredHaltCount: aString]]
				ifFalse: [int = 1
						ifTrue: [self doExpiredHaltCount: aString]
						ifFalse: [self setHaltCountTo: int - 1]]]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:36'!
hasHaltCount
	^Smalltalk
				includesKey: #HaltCount! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:46'!
inspectOnCount: int 
	self haltOnceEnabled
		ifTrue: [self hasHaltCount
				ifTrue: [self decrementAndCheckHaltCount
						ifTrue: [self doExpiredInspectCount]]
				ifFalse: [int = 1
						ifTrue: [self doExpiredInspectCount]
						ifFalse: [self setHaltCountTo: int - 1]]]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:05'!
inspectOnce
	"Inspect unless we have already done it once."
	self haltOnceEnabled
		ifTrue: [self clearHaltOnce.
			^ self inspect]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 13:20'!
inspectUntilCount: int 
	self haltOnceEnabled
		ifTrue: [self hasHaltCount
				ifTrue: [self decrementAndCheckHaltCount
						ifTrue: [self doExpiredInspectCount]
						ifFalse: [self inspect]]
				ifFalse: [int = 1
						ifTrue: [self doExpiredInspectCount]
						ifFalse: [self setHaltCountTo: int - 1]]]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:49'!
removeHaltCount
	(Smalltalk includesKey: #HaltCount) ifTrue: [
		Smalltalk removeKey: #HaltCount]! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:25'!
setHaltCountTo: int
	Smalltalk at: #HaltCount put: int! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:04'!
setHaltOnce
	"Turn on the halt once flag."
	Smalltalk at: #HaltOnce put: true! !

!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:04'!
toggleHaltOnce
	self haltOnceEnabled
		ifTrue: [self clearHaltOnce]
		ifFalse: [self setHaltOnce]! !


!Object methodsFor: 'dependents access' stamp: 'ar 2/11/2001 01:55'!
addDependent: anObject
	"Make the given object one of the receiver's dependents."

	| dependents |
	dependents _ self dependents.
	(dependents includes: anObject) ifFalse:
		[self myDependents: (dependents copyWithDependent: anObject)].
	^ anObject! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:53'!
breakDependents
	"Remove all of the receiver's dependents."

	self myDependents: nil! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:26'!
canDiscardEdits
	"Answer true if none of the views on this model has unaccepted edits that matter."

	self dependents
		do: [:each | each canDiscardEdits ifFalse: [^ false]]
		without: self.
	^ true! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:58'!
dependents
	"Answer a collection of objects that are 'dependent' on the receiver;
	 that is, all objects that should be notified if the receiver changes."

	^ self myDependents ifNil: [#()]! !

!Object methodsFor: 'dependents access'!
evaluate: actionBlock wheneverChangeIn: aspectBlock
	| viewerThenObject objectThenViewer |
	objectThenViewer _ self.
	viewerThenObject _ ObjectViewer on: objectThenViewer.
	objectThenViewer become: viewerThenObject.
	"--- Then ---"
	objectThenViewer xxxViewedObject: viewerThenObject
			evaluate: actionBlock
			wheneverChangeIn: aspectBlock! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:59'!
hasUnacceptedEdits
	"Answer true if any of the views on this object has unaccepted edits."

	self dependents
		do: [:each | each hasUnacceptedEdits ifTrue: [^ true]]
		without: self.
	^ false! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:55'!
myDependents
	"Private. Answer a list of all the receiver's dependents."

	^ DependentsFields at: self ifAbsent: []! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:52'!
myDependents: aCollectionOrNil
	"Private. Set (or remove) the receiver's dependents list."

	aCollectionOrNil
		ifNil: [DependentsFields removeKey: self ifAbsent: []]
		ifNotNil: [DependentsFields at: self put: aCollectionOrNil]! !

!Object methodsFor: 'dependents access' stamp: 'reThink 2/18/2001 17:06'!
release
	"Remove references to objects that may refer to the receiver. This message 
	should be overridden by subclasses with any cycles, in which case the 
	subclass should also include the expression super release."

	self releaseActionMap! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 20:23'!
removeDependent: anObject
	"Remove the given object as one of the receiver's dependents."

	| dependents |
	dependents _ self dependents reject: [:each | each == anObject].
	self myDependents: (dependents isEmpty ifFalse: [dependents]).
	^ anObject! !


!Object methodsFor: 'drag and drop' stamp: 'bh 9/16/2001 18:10'!
acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph 
	
	^false.! !

!Object methodsFor: 'drag and drop' stamp: 'mir 5/16/2000 11:35'!
dragAnimationFor: item transferMorph: transferMorph 
	"Default do nothing"! !

!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:20'!
dragPassengerFor: item inMorph: dragSource 
	^item! !

!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:11'!
dragTransferType
	^nil! !

!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:05'!
dragTransferTypeForMorph: dragSource 
	^nil! !

!Object methodsFor: 'drag and drop' stamp: 'mir 5/8/2000 17:19'!
wantsDroppedMorph: aMorph event: anEvent inMorph: destinationLM 
	^false! !


!Object methodsFor: 'error handling' stamp: 'sma 5/6/2000 19:35'!
assert: aBlock
	"Throw an assertion error if aBlock does not evaluates to true."

	aBlock value ifFalse: [AssertionFailure signal: 'Assertion failed']! !

!Object methodsFor: 'error handling' stamp: 'nk 1/15/2004 10:54'!
assert: aBlock descriptionBlock: descriptionBlock
	"Throw an assertion error if aBlock does not evaluate to true."

	aBlock value ifFalse: [AssertionFailure signal: descriptionBlock value asString ]! !

!Object methodsFor: 'error handling' stamp: 'nk 10/25/2003 16:47'!
assert: aBlock description: aString
	"Throw an assertion error if aBlock does not evaluates to true."

	aBlock value ifFalse: [AssertionFailure signal: aString ]! !

!Object methodsFor: 'error handling' stamp: 'md 10/13/2004 15:59'!
backwardCompatibilityOnly: anExplanationString
	"Warn that the sending method has been deprecated. Methods that are tagt with #backwardCompatibility:
	 are kept for compatibility."

	Preferences showDeprecationWarnings ifTrue:
		[Deprecation signal: thisContext sender printString, ' has been deprecated (but will be kept for compatibility). ', anExplanationString]! !

!Object methodsFor: 'error handling'!
caseError
	"Report an error from an in-line or explicit case statement."

	self error: 'Case not found, and no otherwise clause'! !

!Object methodsFor: 'error handling' stamp: 'rbb 3/1/2005 09:26'!
confirm: queryString
	"Put up a yes/no menu with caption queryString. Answer true if the 
	response is yes, false if no. This is a modal question--the user must 
	respond yes or no."

	"nil confirm: 'Are you hungry?'"

	^ UIManager default confirm: queryString! !

!Object methodsFor: 'error handling' stamp: 'rbb 3/1/2005 09:27'!
confirm: aString orCancel: cancelBlock
	"Put up a yes/no/cancel menu with caption aString. Answer true if  
	the response is yes, false if no. If cancel is chosen, evaluate  
	cancelBlock. This is a modal question--the user must respond yes or no."

	^ UIManager default confirm: aString orCancel: cancelBlock! !

!Object methodsFor: 'error handling' stamp: 'dew 10/6/2003 18:20'!
deprecated: anExplanationString
	"Warn that the sending method has been deprecated."

	Preferences showDeprecationWarnings ifTrue:
		[Deprecation signal: thisContext sender printString, ' has been deprecated. ', anExplanationString]! !

!Object methodsFor: 'error handling' stamp: 'dew 10/7/2003 00:26'!
deprecated: anExplanationString block: aBlock 
	 "Warn that the sender has been deprecated.  Answer the value of aBlock on resumption.  (Note that #deprecated: is usually the preferred method.)"

	Preferences showDeprecationWarnings ifTrue:
		[Deprecation
			signal: thisContext sender printString, ' has been deprecated. ', anExplanationString].
	^ aBlock value.
! !

!Object methodsFor: 'error handling' stamp: 'md 2/22/2006 21:21'!
doesNotUnderstand: aMessage 
	 "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)."
	"Testing: (3 activeProcess)"

	MessageNotUnderstood new 
		message: aMessage;
		receiver: self;
		signal.
	^ aMessage sentTo: self.
! !

!Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 16:47'!
dpsTrace: reportObject  
	Transcript myDependents isNil ifTrue: [^self].
	self dpsTrace: reportObject levels: 1 withContext: thisContext
		
" nil dpsTrace: 'sludder'. "! !

!Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 16:49'!
dpsTrace: reportObject levels: anInt
	self dpsTrace: reportObject levels: anInt withContext: thisContext

"(1 to: 3) do: [:int | nil dpsTrace: int levels: 5.]"! !

!Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 17:02'!
dpsTrace: reportObject levels: anInt withContext: currentContext
	| reportString context displayCount |
	reportString := (reportObject respondsTo: #asString) 
			ifTrue: [reportObject asString] ifFalse: [reportObject printString].
	(Smalltalk at: #Decompiler ifAbsent: [nil]) 
	ifNil: 
		[Transcript cr; show: reportString]
	ifNotNil:
		[context := currentContext.
		displayCount := anInt > 1.
		1 to: anInt do:
			[:count |
			Transcript cr.
			displayCount
				ifTrue: [Transcript show: count printString, ': '].
			
			reportString notNil
			ifTrue:
				[Transcript show: context home class name 
			, '/' , context sender selector,  ' (' , reportString , ')'.
				context := context sender.
				reportString := nil]
			ifFalse:
				[(context notNil and: [(context := context sender) notNil])
				ifTrue: [Transcript show: context receiver class name , '/' , context selector]]].
		"Transcript cr"].! !

!Object methodsFor: 'error handling' stamp: 'md 8/2/2005 22:17'!
error
	"Throw a generic Error exception."

	^self error: 'Error!!'.! !

!Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:55'!
error: aString 
	"Throw a generic Error exception."

	^Error new signal: aString! !

!Object methodsFor: 'error handling' stamp: 'al 9/16/2005 14:12'!
explicitRequirement
	self error: 'Explicitly required method'! !

!Object methodsFor: 'error handling' stamp: 'al 2/13/2006 22:20'!
halt
	"This is the typical message to use for inserting breakpoints during 
	debugging. It behaves like halt:, but does not call on halt: in order to 
	avoid putting this message on the stack. Halt is especially useful when 
	the breakpoint message is an arbitrary one."

	Halt signal! !

!Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:59'!
halt: aString 
	"This is the typical message to use for inserting breakpoints during 
	debugging. It creates and schedules a Notifier with the argument, 
	aString, as the label."
	
	Halt new signal: aString! !

!Object methodsFor: 'error handling' stamp: 'md 1/20/2006 16:24'!
handles: exception
	"This method exists in case a non exception class is the first arg in an on:do: (for instance using a exception class that is not loaded). We prefer this to raising an error during error handling itself. Also, semantically it makes sense that the exception handler is not active if its exception class is not loaded"

	^ false! !

!Object methodsFor: 'error handling' stamp: 'ar 9/27/2005 20:24'!
notifyWithLabel: aString 
	"Create and schedule a Notifier with aString as the window label as well as the contents of the window, in  order to request confirmation before a process can proceed."

	ToolSet
		debugContext: thisContext
		label: aString
		contents: aString

	"nil notifyWithLabel: 'let us see if this works'"! !

!Object methodsFor: 'error handling' stamp: 'hg 10/2/2001 20:49'!
notify: aString 
	"Create and schedule a Notifier with the argument as the message in 
	order to request confirmation before a process can proceed."

	Warning signal: aString

	"nil notify: 'confirmation message'"! !

!Object methodsFor: 'error handling'!
notify: aString at: location
	"Create and schedule a Notifier with the argument as the message in 
	order to request confirmation before a process can proceed. Subclasses can
	override this and insert an error message at location within aString."

	self notify: aString

	"nil notify: 'confirmation message' at: 12"! !

!Object methodsFor: 'error handling'!
primitiveFailed
	"Announce that a primitive has failed and there is no appropriate 
	Smalltalk code to run."

	self error: 'a primitive has failed'! !

!Object methodsFor: 'error handling' stamp: 'al 9/16/2005 14:12'!
requirement
	self error: 'Implicitly required method'! !

!Object methodsFor: 'error handling' stamp: 'AFi 2/8/2003 22:52'!
shouldBeImplemented
	"Announce that this message should be implemented"

	self error: 'This message should be implemented'! !

!Object methodsFor: 'error handling'!
shouldNotImplement
	"Announce that, although the receiver inherits this message, it should 
	not implement it."

	self error: 'This message is not appropriate for this object'! !

!Object methodsFor: 'error handling' stamp: 'md 2/17/2006 12:02'!
subclassResponsibility
	"This message sets up a framework for the behavior of the class' subclasses.
	Announce that the subclass should have implemented this message."

	self error: 'My subclass should have overridden ', thisContext sender selector printString! !

!Object methodsFor: 'error handling' stamp: 'al 12/16/2003 16:16'!
traitConflict
	self error: 'A class or trait does not properly resolve a conflict between multiple traits it uses.'! !


!Object methodsFor: 'evaluating' stamp: 'reThink 3/12/2001 18:14'!
value

	^self! !

!Object methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 15:23'!
valueWithArguments: aSequenceOfArguments

	^self! !


!Object methodsFor: 'events-accessing' stamp: 'nk 12/20/2002 17:48'!
actionForEvent: anEventSelector
    "Answer the action to be evaluated when <anEventSelector> has been triggered."

	| actions |
	actions := self actionMap
		at: anEventSelector asSymbol
		ifAbsent: [nil].
	actions ifNil: [^nil].
	^ actions asMinimalRepresentation! !

!Object methodsFor: 'events-accessing' stamp: 'nk 12/20/2002 17:48'!
actionForEvent: anEventSelector
ifAbsent: anExceptionBlock
    "Answer the action to be evaluated when <anEventSelector> has been triggered."

	| actions |
	actions := self actionMap
		at: anEventSelector asSymbol
		ifAbsent: [nil].
	actions ifNil: [^anExceptionBlock value].
	^ actions asMinimalRepresentation! !

!Object methodsFor: 'events-accessing' stamp: 'reThink 2/18/2001 14:43'!
actionMap

	^EventManager actionMapFor: self! !

!Object methodsFor: 'events-accessing' stamp: 'rw 4/27/2002 08:35'!
actionSequenceForEvent: anEventSelector

    ^(self actionMap
        at: anEventSelector asSymbol
        ifAbsent: [^WeakActionSequence new])
            asActionSequence! !

!Object methodsFor: 'events-accessing' stamp: 'SqR 6/28/2001 13:19'!
actionsDo: aBlock

	self actionMap do: aBlock! !

!Object methodsFor: 'events-accessing' stamp: 'rw 2/10/2002 13:05'!
createActionMap

	^IdentityDictionary new! !

!Object methodsFor: 'events-accessing' stamp: 'SqR 2/19/2001 14:04'!
hasActionForEvent: anEventSelector
    "Answer true if there is an action associated with anEventSelector"

    ^(self actionForEvent: anEventSelector) notNil! !

!Object methodsFor: 'events-accessing' stamp: 'reThink 2/18/2001 15:29'!
setActionSequence: actionSequence
forEvent: anEventSelector

    | action |
    action := actionSequence asMinimalRepresentation.
    action == nil
        ifTrue:
            [self removeActionsForEvent: anEventSelector]
        ifFalse:
            [self updateableActionMap
                at: anEventSelector asSymbol
                put: action]! !

!Object methodsFor: 'events-accessing' stamp: 'reThink 2/25/2001 08:50'!
updateableActionMap

	^EventManager updateableActionMapFor: self! !


!Object methodsFor: 'events-registering' stamp: 'reThink 2/18/2001 15:04'!
when: anEventSelector evaluate: anAction 

	| actions |
	actions := self actionSequenceForEvent: anEventSelector.
	(actions includes: anAction)
		ifTrue: [^ self].
	self 
		setActionSequence: (actions copyWith: anAction)
		forEvent: anEventSelector! !

!Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'!
when: anEventSelector
send: aMessageSelector
to: anObject
 
    self
        when: anEventSelector
        evaluate: (WeakMessageSend
            receiver: anObject
            selector: aMessageSelector)! !

!Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'!
when: anEventSelector
send: aMessageSelector
to: anObject
withArguments: anArgArray
 
    self
        when: anEventSelector
        evaluate: (WeakMessageSend
            receiver: anObject
            selector: aMessageSelector
		arguments: anArgArray)! !

!Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'!
when: anEventSelector
send: aMessageSelector
to: anObject
with: anArg
 
    self
        when: anEventSelector
        evaluate: (WeakMessageSend
            receiver: anObject
            selector: aMessageSelector
		arguments: (Array with: anArg))! !


!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:33'!
releaseActionMap

	EventManager releaseActionMapFor: self! !

!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:33'!
removeActionsForEvent: anEventSelector

    | map |
    map := self actionMap.
    map removeKey: anEventSelector asSymbol ifAbsent: [].
    map isEmpty
        ifTrue: [self releaseActionMap]! !

!Object methodsFor: 'events-removing' stamp: 'nk 8/25/2003 21:46'!
removeActionsSatisfying: aBlock

	self actionMap keys do:
		[:eachEventSelector |
			self
   				removeActionsSatisfying: aBlock
				forEvent: eachEventSelector
		]! !

!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'!
removeActionsSatisfying: aOneArgBlock 
forEvent: anEventSelector

    self
        setActionSequence:
            ((self actionSequenceForEvent: anEventSelector)
                reject: [:anAction | aOneArgBlock value: anAction])
        forEvent: anEventSelector! !

!Object methodsFor: 'events-removing' stamp: 'rw 7/29/2003 17:18'!
removeActionsWithReceiver: anObject

	self actionMap copy keysDo:
		[:eachEventSelector |
			self
   				removeActionsSatisfying: [:anAction | anAction receiver == anObject]
				forEvent: eachEventSelector
		]! !

!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:36'!
removeActionsWithReceiver: anObject
forEvent: anEventSelector

    self
        removeActionsSatisfying:
            [:anAction |
            anAction receiver == anObject]
        forEvent: anEventSelector! !

!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'!
removeAction: anAction
forEvent: anEventSelector

    self
        removeActionsSatisfying: [:action | action = anAction]
        forEvent: anEventSelector! !


!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:22'!
triggerEvent: anEventSelector
	"Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action."

    ^(self actionForEvent: anEventSelector) value! !

!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 17:09'!
triggerEvent: anEventSelector
ifNotHandled: anExceptionBlock
	"Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action."

    ^(self 
		actionForEvent: anEventSelector
		ifAbsent: [^anExceptionBlock value]) value
! !

!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'!
triggerEvent: anEventSelector
withArguments: anArgumentList

    ^(self actionForEvent: anEventSelector)
        valueWithArguments: anArgumentList! !

!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'!
triggerEvent: anEventSelector
withArguments: anArgumentList
ifNotHandled: anExceptionBlock

    ^(self 
		actionForEvent: anEventSelector
		ifAbsent: [^anExceptionBlock value])
        valueWithArguments: anArgumentList! !

!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'!
triggerEvent: anEventSelector
with: anObject

    ^self 
		triggerEvent: anEventSelector
		withArguments: (Array with: anObject)! !

!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'!
triggerEvent: anEventSelector
with: anObject
ifNotHandled: anExceptionBlock

    ^self 
		triggerEvent: anEventSelector
		withArguments: (Array with: anObject)
		ifNotHandled: anExceptionBlock! !


!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:42'!
byteEncode:aStream
	self flattenOnStream:aStream.
! !

!Object methodsFor: 'filter streaming'!
drawOnCanvas:aStream
	self flattenOnStream:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:31'!
elementSeparator
	^nil.! !

!Object methodsFor: 'filter streaming'!
encodePostscriptOn:aStream
	self byteEncode:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:07'!
flattenOnStream:aStream
	self writeOnFilterStream:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'mpw 6/22/1930 22:56'!
fullDrawPostscriptOn:aStream
	^aStream fullDraw:self.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:51'!
printOnStream:aStream
	self byteEncode:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:49'!
putOn:aStream
	^aStream nextPut:self.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:53'!
storeOnStream:aStream
	self printOnStream:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:06'!
writeOnFilterStream:aStream
	aStream writeObject:self.
! !


!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:26'!
actAsExecutor
	"Prepare the receiver to act as executor for any resources associated with it"
	self breakDependents! !

!Object methodsFor: 'finalization' stamp: 'ar 3/20/98 22:19'!
executor
	"Return an object which can act as executor for finalization of the receiver"
	^self shallowCopy actAsExecutor! !

!Object methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:10'!
finalizationRegistry
	"Answer the finalization registry associated with the receiver."
	^WeakRegistry default! !

!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:27'!
finalize
	"Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority."! !

!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 18:38'!
retryWithGC: execBlock until: testBlock
	"Retry execBlock as long as testBlock returns false. Do an incremental GC after the first try, a full GC after the second try."
	| blockValue |
	blockValue := execBlock value.
	(testBlock value: blockValue) ifTrue:[^blockValue].
	Smalltalk garbageCollectMost.
	blockValue := execBlock value.
	(testBlock value: blockValue) ifTrue:[^blockValue].
	Smalltalk garbageCollect.
	^execBlock value.! !

!Object methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:14'!
toFinalizeSend: aSelector to: aFinalizer with: aResourceHandle
	"When I am finalized (e.g., garbage collected) close the associated resource handle by sending aSelector to the appropriate finalizer (the guy who knows how to get rid of the resource).
	WARNING: Neither the finalizer nor the resource handle are allowed to reference me. If they do, then I will NEVER be garbage collected. Since this cannot be validated here, it is up to the client to make sure this invariant is not broken."
	self == aFinalizer ifTrue:[self error: 'I cannot finalize myself'].
	self == aResourceHandle ifTrue:[self error: 'I cannot finalize myself'].
	^self finalizationRegistry add: self executor:
		(ObjectFinalizer new
			receiver: aFinalizer
			selector: aSelector
			argument: aResourceHandle)! !


!Object methodsFor: 'flagging' stamp: 'sw 8/4/97 16:49'!
isThisEverCalled
	^ self isThisEverCalled: thisContext sender printString! !

!Object methodsFor: 'flagging'!
isThisEverCalled: msg
	"Send this message, with some useful printable argument, from methods or branches of methods which you believe are never reached.  2/5/96 sw"

	self halt: 'This is indeed called: ', msg printString! !

!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'!
logEntry

	Transcript show: 'Entered ', thisContext sender printString; cr.
! !

!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'!
logExecution

	Transcript show: 'Executing ', thisContext sender printString; cr.
! !

!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:22'!
logExit

	Transcript show:  'Exited ', thisContext sender printString; cr.
! !


!Object methodsFor: 'graph model' stamp: 'dgd 9/18/2004 15:07'!
addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph 
	"The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items"
	Preferences cmdGesturesEnabled ifTrue: [ "build mode"
		aCustomMenu add: 'inspect model' translated target: self action: #inspect.
	].

	^aCustomMenu
! !

!Object methodsFor: 'graph model' stamp: 'nk 1/23/2004 14:35'!
hasModelYellowButtonMenuItems
	^Preferences cmdGesturesEnabled! !


!Object methodsFor: 'locales' stamp: 'tak 8/4/2005 14:55'!
localeChanged
	self shouldBeImplemented! !


!Object methodsFor: 'macpal' stamp: 'sw 5/7/1998 23:00'!
codeStrippedOut: messageString
	"When a method is stripped out for external release, it is replaced by a method that calls this"

	self halt: 'Code stripped out -- ', messageString, '-- do not proceed.'! !

!Object methodsFor: 'macpal' stamp: 'sw 1/28/1999 17:31'!
contentsChanged
	self changed: #contents! !

!Object methodsFor: 'macpal' stamp: 'ar 3/18/2001 00:03'!
currentEvent
	"Answer the current Morphic event.  This method never returns nil."
	^ActiveEvent ifNil:[self currentHand lastEvent]! !

!Object methodsFor: 'macpal' stamp: 'nk 9/1/2004 10:41'!
currentHand
	"Return a usable HandMorph -- the one associated with the object's current environment.  This method will always return a hand, even if it has to conjure one up as a last resort.  If a particular hand is actually handling events at the moment (such as a remote hand or a ghost hand), it will be returned."

	^ActiveHand ifNil: [ self currentWorld primaryHand ]! !

!Object methodsFor: 'macpal' stamp: 'sw 5/17/2001 12:08'!
currentVocabulary
	"Answer the currently-prevailing default vocabulary."

	^ Smalltalk isMorphic ifTrue:
			[ActiveWorld currentVocabulary]
		ifFalse:
			[Vocabulary fullVocabulary]! !

!Object methodsFor: 'macpal' stamp: 'ar 3/18/2001 00:08'!
currentWorld
	"Answer a morphic world that is the current UI focus.
		If in an embedded world, it's that world.
		If in a morphic project, it's that project's world.  
		If in an mvc project, it is the topmost morphic-mvc-window's worldMorph. 
		If in an mvc project that has no morphic-mvc-windows, then it's just some existing worldmorph instance.
		If in an mvc project in a Squeak that has NO WorldMorph instances, one is created.

	This method will never return nil, it will always return its best effort at returning a relevant world morph, but if need be -- if there are no worlds anywhere, it will create a new one."

	| aView aSubview |
	ActiveWorld ifNotNil:[^ActiveWorld].
	World ifNotNil:[^World].
	aView _ ScheduledControllers controllerSatisfying:
		[:ctrl | (aSubview _ ctrl view firstSubView) notNil and:
			[aSubview model isMorph and: [aSubview model isWorldMorph]]].
	^aView
		ifNotNil:
			[aSubview model]
		ifNil:
			[MVCWiWPasteUpMorph newWorldForProject: nil].! !

!Object methodsFor: 'macpal' stamp: 'jm 5/6/1998 22:35'!
flash
	"Do nothing."
! !

!Object methodsFor: 'macpal' stamp: 'sw 6/16/1998 15:07'!
instanceVariableValues
	"Answer a collection whose elements are the values of those instance variables of the receiver which were added by the receiver's class"
	| c |
	c _ OrderedCollection new.
	self class superclass instSize + 1 to: self class instSize do:
		[:i | c add: (self instVarAt: i)].
	^ c! !

!Object methodsFor: 'macpal' stamp: 'sw 3/20/2001 13:29'!
isUniversalTiles
	"Return true if I (my world) uses universal tiles.  This message can be called in places where the current World is not known, such as when writing out a project.  For more information about the project-writing subtlety addressed by this protocol, kindly contact Ted Kaehler."

	^ Preferences universalTiles! !

!Object methodsFor: 'macpal' stamp: 'sw 10/24/2000 07:04'!
objectRepresented
	"most objects represent themselves; this provides a hook for aliases to grab on to"

	^ self! !

!Object methodsFor: 'macpal' stamp: 'sw 5/22/2001 18:31'!
refusesToAcceptCode
	"Answer whether the receiver is a code-bearing instrument which at the moment refuses to allow its contents to be submitted"

	^ false
	! !

!Object methodsFor: 'macpal' stamp: 'jm 2/24/1999 12:40'!
scriptPerformer

	^ self
! !

!Object methodsFor: 'macpal' stamp: 'sw 3/20/2001 13:40'!
slotInfo
	"Answer a list of slot-information objects.  Initally only provides useful info for players"

	^ Dictionary new! !


!Object methodsFor: 'message handling' stamp: 'md 1/20/2006 16:28'!
executeMethod: compiledMethod
	"Execute compiledMethod against the receiver with no args"

	"<primitive: 189>" "uncomment once prim 189 is in VM"
	^ self withArgs: #() executeMethod: compiledMethod! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'!
perform: aSymbol 
	"Send the unary selector, aSymbol, to the receiver.
	Fail if the number of arguments expected by the selector is not zero.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol withArguments: (Array new: 0)! !

!Object methodsFor: 'message handling' stamp: 'sw 10/30/1998 18:27'!
perform: selector orSendTo: otherTarget
	"If I wish to intercept and handle selector myself, do it; else send it to otherTarget"
	^ otherTarget perform: selector! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:55'!
perform: selector withArguments: argArray 
	"Send the selector, aSymbol, to the receiver with arguments in argArray.
	Fail if the number of arguments expected by the selector 
	does not match the size of argArray.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 84>
	^ self perform: selector withArguments: argArray inSuperclass: self class! !

!Object methodsFor: 'message handling' stamp: 'ar 4/25/2005 13:35'!
perform: selector withArguments: argArray inSuperclass: lookupClass
	"NOTE:  This is just like perform:withArguments:, except that
	the message lookup process begins, not with the receivers's class,
	but with the supplied superclass instead.  It will fail if lookupClass
	cannot be found among the receiver's superclasses.
	Primitive. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 100>
	(selector isSymbol)
		ifFalse: [^ self error: 'selector argument must be a Symbol'].
	(selector numArgs = argArray size)
		ifFalse: [^ self error: 'incorrect number of arguments'].
	(self class == lookupClass or: [self class inheritsFrom: lookupClass])
		ifFalse: [^ self error: 'lookupClass is not in my inheritance chain'].
	self primitiveFailed! !

!Object methodsFor: 'message handling' stamp: 'nk 4/11/2002 14:13'!
perform: selector withEnoughArguments: anArray
	"Send the selector, aSymbol, to the receiver with arguments in argArray.
	Only use enough arguments for the arity of the selector; supply nils for missing ones."
	| numArgs args |
	numArgs _ selector numArgs.
	anArray size == numArgs
		ifTrue: [ ^self perform: selector withArguments: anArray asArray ].

	args _ Array new: numArgs.
	args replaceFrom: 1
		to: (anArray size min: args size)
		with: anArray
		startingAt: 1.

	^ self perform: selector withArguments: args! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'!
perform: aSymbol with: anObject 
	"Send the selector, aSymbol, to the receiver with anObject as its argument.
	Fail if the number of arguments expected by the selector is not one.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol withArguments: (Array with: anObject)! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'!
perform: aSymbol with: firstObject with: secondObject 
	"Send the selector, aSymbol, to the receiver with the given arguments.
	Fail if the number of arguments expected by the selector is not two.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol withArguments: (Array with: firstObject with: secondObject)! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:51'!
perform: aSymbol with: firstObject with: secondObject with: thirdObject 
	"Send the selector, aSymbol, to the receiver with the given arguments.
	Fail if the number of arguments expected by the selector is not three.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol
		withArguments: (Array with: firstObject with: secondObject with: thirdObject)! !

!Object methodsFor: 'message handling' stamp: 'NS 1/28/2004 11:19'!
withArgs: argArray executeMethod: compiledMethod
	"Execute compiledMethod against the receiver and args in argArray"

	| selector |
	<primitive: 188>
	selector _ Symbol new.
	self class addSelectorSilently: selector withMethod: compiledMethod.
	^ [self perform: selector withArguments: argArray]
		ensure: [self class basicRemoveSelector: selector]! !

!Object methodsFor: 'message handling' stamp: 'md 1/20/2006 16:28'!
with: arg1 executeMethod: compiledMethod
	"Execute compiledMethod against the receiver and arg1"

	"<primitive: 189>" "uncomment once prim 189 is in VM"
	^ self withArgs: {arg1} executeMethod: compiledMethod! !

!Object methodsFor: 'message handling' stamp: 'md 1/20/2006 16:28'!
with: arg1 with: arg2 executeMethod: compiledMethod
	"Execute compiledMethod against the receiver and arg1 & arg2"

	"<primitive: 189>" "uncomment once prim 189 is in VM"
	^ self withArgs: {arg1. arg2} executeMethod: compiledMethod! !

!Object methodsFor: 'message handling' stamp: 'md 1/20/2006 16:28'!
with: arg1 with: arg2 with: arg3 executeMethod: compiledMethod
	"Execute compiledMethod against the receiver and arg1, arg2, & arg3"

	"<primitive: 189>" "uncomment once prim 189 is in VM"
	^ self withArgs: {arg1. arg2. arg3} executeMethod: compiledMethod! !

!Object methodsFor: 'message handling' stamp: 'md 1/20/2006 16:28'!
with: arg1 with: arg2 with: arg3 with: arg4 executeMethod: compiledMethod
	"Execute compiledMethod against the receiver and arg1, arg2, arg3, & arg4"

	"<primitive: 189>" "uncomment once prim 189 is in VM"
	^ self withArgs: {arg1. arg2. arg3. arg4} executeMethod: compiledMethod! !


!Object methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 12:46'!
comeFullyUpOnReload: smartRefStream
	"Normally this read-in object is exactly what we want to store. 7/26/96 tk"

	^ self! !

!Object methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 16:51'!
convertToCurrentVersion: varDict refStream: smartRefStrm

	"subclasses should implement if they wish to convert old instances to modern ones"! !

!Object methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 15:04'!
fixUponLoad: aProject seg: anImageSegment
	"change the object due to conventions that have changed on
the project level.  (sent to all objects in the incoming project).
Specific classes should reimplement this."! !

!Object methodsFor: 'objects from disk' stamp: 'RAA 1/10/2001 14:02'!
indexIfCompact

	^0		"helps avoid a #respondsTo: in publishing"! !

!Object methodsFor: 'objects from disk' stamp: 'tk 2/24/1999 11:08'!
objectForDataStream: refStrm
    "Return an object to store on an external data stream."

    ^ self! !

!Object methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 12:05'!
readDataFrom: aDataStream size: varsOnDisk
	"Fill in the fields of self based on the contents of aDataStream.  Return self.
	 Read in the instance-variables written by Object>>storeDataOn:.
	 NOTE: This method must send beginReference: before reading any objects from aDataStream that might reference it.
	 Allow aDataStream to have fewer inst vars.  See SmartRefStream."
	| cntInstVars cntIndexedVars |

	cntInstVars _ self class instSize.
	self class isVariable
		ifTrue: [cntIndexedVars _ varsOnDisk - cntInstVars.
				cntIndexedVars < 0 ifTrue: [
					self error: 'Class has changed too much.  Define a convertxxx method']]
		ifFalse: [cntIndexedVars _ 0.
				cntInstVars _ varsOnDisk]. 	"OK if fewer than now"

	aDataStream beginReference: self.
	1 to: cntInstVars do:
		[:i | self instVarAt: i put: aDataStream next].
	1 to: cntIndexedVars do:
		[:i | self basicAt: i put: aDataStream next].
	"Total number read MUST be equal to varsOnDisk!!"
	^ self	"If we ever return something other than self, fix calls 
			on (super readDataFrom: aDataStream size: anInteger)"! !

!Object methodsFor: 'objects from disk' stamp: 'CdG 10/17/2005 20:32'!
saveOnFile
	"Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  Does not file out the class of the object.  tk 6/26/97 13:48"

	| aFileName fileStream |
	aFileName := self class name asFileName.	"do better?"
	aFileName := UIManager default 
				request: 'File name?' translated initialAnswer: aFileName.
	aFileName size == 0 ifTrue: [^ Beeper beep].

	fileStream := FileStream newFileNamed: aFileName asFileName.
	fileStream fileOutClass: nil andObject: self.! !

!Object methodsFor: 'objects from disk' stamp: 'tk 8/9/2001 15:40'!
storeDataOn: aDataStream
	"Store myself on a DataStream.  Answer self.  This is a low-level DataStream/ReferenceStream method. See also objectToStoreOnDataStream.  NOTE: This method must send 'aDataStream beginInstance:size:' and then (nextPut:/nextPutWeak:) its subobjects.  readDataFrom:size: reads back what we write here."
	| cntInstVars cntIndexedVars |

	cntInstVars _ self class instSize.
	cntIndexedVars _ self basicSize.
	aDataStream
		beginInstance: self class
		size: cntInstVars + cntIndexedVars.
	1 to: cntInstVars do:
		[:i | aDataStream nextPut: (self instVarAt: i)].

	"Write fields of a variable length object.  When writing to a dummy 
		stream, don't bother to write the bytes"
	((aDataStream byteStream class == DummyStream) and: [self class isBits]) ifFalse: [
		1 to: cntIndexedVars do:
			[:i | aDataStream nextPut: (self basicAt: i)]].
! !


!Object methodsFor: 'parts bin' stamp: 'sw 10/24/2001 16:34'!
descriptionForPartsBin
	"If the receiver is a member of a class that would like to be represented in a parts bin, answer the name by which it should be known, and a documentation string to be provided, for example, as balloon help.  When the 'nativitySelector' is sent to the 'globalReceiver', it is expected that some kind of Morph will result.  The parameters used in the implementation below are for documentation purposes only!!"

	^ DescriptionForPartsBin
		formalName: 'PutFormalNameHere'
		categoryList: #(PutACategoryHere MaybePutAnotherCategoryHere)
		documentation: 'Put the balloon help here'
		globalReceiverSymbol: #PutAGlobalHere
		nativitySelector: #PutASelectorHere! !


!Object methodsFor: 'printing' stamp: 'di 6/20/97 08:57'!
fullPrintString
	"Answer a String whose characters are a description of the receiver."

	^ String streamContents: [:s | self printOn: s]! !

!Object methodsFor: 'printing'!
isLiteral
	"Answer whether the receiver has a literal text form recognized by the 
	compiler."

	^false! !

!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:28'!
longPrintOn: aStream
	"Append to the argument, aStream, the names and values of all 
	of the receiver's instance variables."

	self class allInstVarNames doWithIndex:
		[:title :index |
		aStream nextPutAll: title;
		 nextPut: $:;
		 space;
		 tab;
		 print: (self instVarAt: index);
		 cr]! !

!Object methodsFor: 'printing' stamp: 'tk 10/19/2001 11:18'!
longPrintOn: aStream limitedTo: sizeLimit indent: indent
	"Append to the argument, aStream, the names and values of all of the receiver's instance variables.  Limit is the length limit for each inst var."

	self class allInstVarNames doWithIndex:
		[:title :index |
		indent timesRepeat: [aStream tab].
		aStream nextPutAll: title;
		 nextPut: $:;
		 space;
		 tab;
		 nextPutAll: 
			((self instVarAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1));
		 cr]! !

!Object methodsFor: 'printing' stamp: 'tk 10/16/2001 19:41'!
longPrintString
	"Answer a String whose characters are a description of the receiver."
	
	| str |
	str _ String streamContents: [:aStream | self longPrintOn: aStream].
	"Objects without inst vars should return something"
	^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! !

!Object methodsFor: 'printing' stamp: 'BG 11/7/2004 13:39'!
longPrintStringLimitedTo: aLimitValue
	"Answer a String whose characters are a description of the receiver."
	
	| str |
	str _ String streamContents: [:aStream | self longPrintOn: aStream limitedTo: aLimitValue indent: 0].
	"Objects without inst vars should return something"
	^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! !

!Object methodsFor: 'printing' stamp: 'sw 3/7/2001 13:14'!
nominallyUnsent: aSelectorSymbol
	"From within the body of a method which is not formally sent within the system, but which you intend to have remain in the system (for potential manual invocation, or for documentation, or perhaps because it's sent by commented-out-code that you anticipate uncommenting out someday, send this message, with the selector itself as the argument.

This will serve two purposes:

	(1)  The method will not be returned by searches for unsent selectors (because it, in a manner of speaking, sends itself).
	(2)	You can locate all such methods by browsing senders of #nominallyUnsent:"

	false ifTrue: [self flag: #nominallyUnsent:]    "So that this method itself will appear to be sent"
! !

!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:31'!
printOn: aStream
	"Append to the argument, aStream, a sequence of characters that  
	identifies the receiver."

	| title |
	title _ self class name.
	aStream
		nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']);
		nextPutAll: title! !

!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:22'!
printString
	"Answer a String whose characters are a description of the receiver. 
	If you want to print without a character limit, use fullPrintString."

	^ self printStringLimitedTo: 50000! !

!Object methodsFor: 'printing' stamp: 'tk 5/7/1999 16:20'!
printStringLimitedTo: limit
	"Answer a String whose characters are a description of the receiver.
	If you want to print without a character limit, use fullPrintString."
	| limitedString |
	limitedString _ String streamContents: [:s | self printOn: s] limitedTo: limit.
	limitedString size < limit ifTrue: [^ limitedString].
	^ limitedString , '...etc...'! !

!Object methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:30'!
propertyList
	"Answer a String whose characters are a property-list description of the receiver."

	^ PropertyListEncoder process:self.
! !

!Object methodsFor: 'printing' stamp: 'sw 10/17/2000 11:16'!
reportableSize
	"Answer a string that reports the size of the receiver -- useful for showing in a list view, for example"

	^ (self basicSize + self class instSize) printString! !

!Object methodsFor: 'printing'!
storeOn: aStream 
	"Append to the argument aStream a sequence of characters that is an 
	expression whose evaluation creates an object similar to the receiver."

	aStream nextPut: $(.
	self class isVariable
		ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: ';
					store: self basicSize;
					nextPutAll: ') ']
		ifFalse: [aStream nextPutAll: self class name, ' basicNew'].
	1 to: self class instSize do:
		[:i |
		aStream nextPutAll: ' instVarAt: ';
			store: i;
			nextPutAll: ' put: ';
			store: (self instVarAt: i);
			nextPut: $;].
	1 to: self basicSize do:
		[:i |
		aStream nextPutAll: ' basicAt: ';
			store: i;
			nextPutAll: ' put: ';
			store: (self basicAt: i);
			nextPut: $;].
	aStream nextPutAll: ' yourself)'
! !

!Object methodsFor: 'printing' stamp: 'di 6/20/97 09:12'!
storeString
	"Answer a String representation of the receiver from which the receiver 
	can be reconstructed."

	^ String streamContents: [:s | self storeOn: s]! !

!Object methodsFor: 'printing' stamp: 'sw 5/2/1998 13:55'!
stringForReadout
	^ self stringRepresentation! !

!Object methodsFor: 'printing'!
stringRepresentation
	"Answer a string that represents the receiver.  For most objects this is simply its printString, but for strings themselves, it's themselves.  6/12/96 sw"

	^ self printString ! !


!Object methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:11'!
adaptedToWorld: aWorld
	"If I refer to a world or a hand, return the corresponding items in the new world."
	^self! !

!Object methodsFor: 'scripting' stamp: 'sw 3/10/2000 13:57'!
defaultFloatPrecisionFor: aGetSelector
	"Answer a number indicating the default float precision to be used in a numeric readout for which the receiver is the model."

	^ 1! !

!Object methodsFor: 'scripting' stamp: 'RAA 3/9/2001 17:08'!
evaluateUnloggedForSelf: aCodeString

	^Compiler evaluate:
		aCodeString
		for: self
		logged: false! !

!Object methodsFor: 'scripting' stamp: 'yo 12/25/2003 16:43'!
methodInterfacesForCategory: aCategorySymbol inVocabulary: aVocabulary limitClass: aLimitClass
	"Return a list of methodInterfaces for the receiver in the given category, given a vocabulary.  aCategorySymbol is the inherent category symbol, not necessarily the wording as expressed in the vocabulary."

	| categorySymbol |
	categorySymbol _ aCategorySymbol asSymbol.

	(categorySymbol == ScriptingSystem nameForInstanceVariablesCategory) ifTrue: [
		"user-defined instance variables"
		^ self methodInterfacesForInstanceVariablesCategoryIn: aVocabulary].
	(categorySymbol == ScriptingSystem nameForScriptsCategory) ifTrue: [
		"user-defined scripts"
		^ self methodInterfacesForScriptsCategoryIn: aVocabulary].
	"all others"
	^ self usableMethodInterfacesIn: (aVocabulary methodInterfacesInCategory: categorySymbol
		forInstance: self
		ofClass: self class
		limitClass: aLimitClass)
! !

!Object methodsFor: 'scripting' stamp: 'sw 8/3/2001 13:54'!
methodInterfacesForInstanceVariablesCategoryIn: aVocabulary
	"Return a collection of methodInterfaces for the instance-variables category.  The vocabulary parameter, at present anyway, is not used.  And for non-players, the method is at present vacuous in any case"

	^  OrderedCollection new! !

!Object methodsFor: 'scripting' stamp: 'sw 8/3/2001 13:53'!
methodInterfacesForScriptsCategoryIn: aVocabulary
	"Answer a list of method interfaces for the category #scripts, as seen in a viewer or other tool.  The vocabulary argument is not presently used.  Also, at present, only Players really do anyting interesting here."

	^ OrderedCollection new! !

!Object methodsFor: 'scripting' stamp: 'RAA 2/16/2001 19:37'!
selfWrittenAsIll

	^self! !

!Object methodsFor: 'scripting' stamp: 'RAA 2/16/2001 19:38'!
selfWrittenAsIm

	^self! !

!Object methodsFor: 'scripting' stamp: 'RAA 2/16/2001 19:37'!
selfWrittenAsMe

	^self! !

!Object methodsFor: 'scripting' stamp: 'RAA 2/16/2001 19:37'!
selfWrittenAsMy

	^self! !

!Object methodsFor: 'scripting' stamp: 'RAA 2/16/2001 19:38'!
selfWrittenAsThis

	^self! !


!Object methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:47'!
isSelfEvaluating
	^ self isLiteral! !


!Object methodsFor: 'system primitives'!
asOop
	"Primitive. Answer a SmallInteger whose value is half of the receiver's 
	object pointer (interpreting object pointers as 16-bit signed quantities). 
	Fail if the receiver is a SmallInteger. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 75>
	self primitiveFailed! !

!Object methodsFor: 'system primitives' stamp: 'di 1/9/1999 15:19'!
becomeForward: otherObject 
	"Primitive. All variables in the entire system that used to point
	to the receiver now point to the argument.
	Fails if either argument is a SmallInteger."

	(Array with: self)
		elementsForwardIdentityTo:
			(Array with: otherObject)! !

!Object methodsFor: 'system primitives' stamp: 'zz 3/3/2004 23:53'!
becomeForward: otherObject copyHash: copyHash
	"Primitive. All variables in the entire system that used to point to the receiver now point to the argument.
	If copyHash is true, the argument's identity hash bits will be set to those of the receiver.
	Fails if either argument is a SmallInteger."

	(Array with: self)
		elementsForwardIdentityTo:
			(Array with: otherObject)
				copyHash: copyHash! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 10:59'!
className
	"Answer a string characterizing the receiver's class, for use in list views for example"

	^ self class name asString! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 11:04'!
creationStamp
	"Answer a string which reports the creation particulars of the receiver.  Intended perhaps for list views, but this is presently a feature not easily accessible"

	^ '<no creation stamp>'! !

!Object methodsFor: 'system primitives'!
instVarAt: index 
	"Primitive. Answer a fixed variable in an object. The numbering of the 
	variables corresponds to the named instance variables. Fail if the index 
	is not an Integer or is not the index of a fixed variable. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 73>
	"Access beyond fixed variables."
	^self basicAt: index - self class instSize		! !

!Object methodsFor: 'system primitives'!
instVarAt: anInteger put: anObject 
	"Primitive. Store a value into a fixed variable in the receiver. The 
	numbering of the variables corresponds to the named instance variables. 
	Fail if the index is not an Integer or is not the index of a fixed variable. 
	Answer the value stored as the result. Using this message violates the 
	principle that each object has sovereign control over the storing of 
	values into its instance variables. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 74>
	"Access beyond fixed fields"
	^self basicAt: anInteger - self class instSize put: anObject! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 11:09'!
instVarNamed: aString
	"Return the value of the instance variable in me with that name.  Slow and unclean, but very useful. "

	^ self instVarAt: (self class allInstVarNames indexOf: aString asString)


! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 11:10'!
instVarNamed: aString put: aValue
	"Store into the value of the instance variable in me of that name.  Slow and unclean, but very useful. "

	^ self instVarAt: (self class allInstVarNames indexOf: aString asString) put: aValue
! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/17/2000 11:12'!
oopString
	"Answer a string that represents the oop of the receiver"

	^ self asOop printString! !

!Object methodsFor: 'system primitives' stamp: 'ar 3/2/2001 01:34'!
primitiveChangeClassTo: anObject
	"Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have.
	Note: The primitive will fail in most cases that you think might work. This is mostly because of a) the difference between compact and non-compact classes, and b) because of differences in the format. As an example, '(Array new: 3) primitiveChangeClassTo: Morph basicNew' would fail for three of the reasons mentioned above. Array is compact, Morph is not (failure #1). Array is variable and Morph is fixed (different format - failure #2). Morph is a fixed-field-only object and the array is too short (failure #3).
	The facility is really provided for certain, very specific applications (mostly related to classes changing shape) and not for casual use."

	<primitive: 115>
	self primitiveFailed! !

!Object methodsFor: 'system primitives' stamp: 'di 3/27/1999 12:21'!
rootStubInImageSegment: imageSegment

	^ ImageSegmentRootStub new
		xxSuperclass: nil
		format: nil
		segment: imageSegment! !

!Object methodsFor: 'system primitives'!
someObject
	"Primitive. Answer the first object in the enumeration of all
	 objects."

	<primitive: 138>
	self primitiveFailed.! !


!Object methodsFor: 'testing' stamp: 'sw 9/26/2001 11:58'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	^ #Object! !

!Object methodsFor: 'testing' stamp: 'sw 5/3/2001 16:19'!
beViewed
	"Open up a viewer on the receiver.  The Presenter is invited to decide just how to present this viewer"

	self uniqueNameForReference.  "So the viewer will have something nice to refer to"
	self presenter viewObject: self! !

!Object methodsFor: 'testing' stamp: 'sw 10/16/2000 11:01'!
costumes
	"Answer a list of costumes associated with the receiver.  The appearance of this method in class Object serves only as a backstop, probably only transitionally"

	^ nil! !

!Object methodsFor: 'testing' stamp: 'sw 1/12/98 18:09'!
haltIfNil! !

!Object methodsFor: 'testing' stamp: 'md 1/20/2006 17:09'!
hasLiteralSuchThat: testBlock
	"This is the end of the imbedded structure path so return false."

	^ false! !

!Object methodsFor: 'testing' stamp: 'md 1/20/2006 17:10'!
hasLiteralThorough: literal
	"Answer true if literal is identical to any literal in this array, even if imbedded in further structures.  This is the end of the imbedded structure path so return false."

	^ false! !

!Object methodsFor: 'testing' stamp: 'sw 1/30/2001 22:24'!
haveFullProtocolBrowsed
	"Open up a Lexicon on the receiver"

	^ self haveFullProtocolBrowsedShowingSelector: nil

	"(2@3) haveFullProtocolBrowsed"
! !

!Object methodsFor: 'testing' stamp: 'ar 9/27/2005 21:04'!
haveFullProtocolBrowsedShowingSelector: aSelector
	"Open up a Lexicon on the receiver, having it open up showing aSelector, which may be nil"

	| aBrowser |
	aBrowser := (Smalltalk at: #InstanceBrowser ifAbsent:[^nil]) new useVocabulary: Vocabulary fullVocabulary.
	aBrowser openOnObject: self inWorld: ActiveWorld showingSelector: aSelector

	"(2@3) haveFullProtocolBrowsed"! !

!Object methodsFor: 'testing' stamp: 'md 7/30/2005 21:21'!
isArray
	^false! !

!Object methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'!
isBehavior
	"Return true if the receiver is a behavior.
	Note: Do not override in any class except behavior."
	^false! !

!Object methodsFor: 'testing' stamp: 'ajh 1/21/2003 13:15'!
isBlock

	^ false! !

!Object methodsFor: 'testing' stamp: 'md 11/21/2003 12:14'!
isBlockClosure

	^ false! !

!Object methodsFor: 'testing' stamp: 'yo 8/28/2002 13:41'!
isCharacter

	^ false.
! !

!Object methodsFor: 'testing' stamp: 'ar 8/17/1999 19:43'!
isCollection
	"Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:"
	^false! !

!Object methodsFor: 'testing'!
isColor
	"Answer true if receiver is a Color. False by default."

	^ false
! !

!Object methodsFor: 'testing' stamp: 'nk 4/17/2004 19:43'!
isColorForm
	^false! !

!Object methodsFor: 'testing' stamp: 'md 11/21/2003 12:14'!
isCompiledMethod

	^ false! !

!Object methodsFor: 'testing' stamp: 'mk 10/27/2003 17:33'!
isComplex
	"Answer true if receiver is a Complex number. False by default."

	^ false
! !

!Object methodsFor: 'testing' stamp: 'md 8/11/2005 16:45'!
isDictionary
	^false! !

!Object methodsFor: 'testing' stamp: 'di 11/9/1998 09:38'!
isFloat
	"Overridden to return true in Float, natch"
	^ false! !

!Object methodsFor: 'testing' stamp: 'ar 10/30/2000 23:22'!
isForm
	^false! !

!Object methodsFor: 'testing' stamp: 'len 1/13/98 21:18'!
isFraction
	"Answer true if the receiver is a Fraction."

	^ false! !

!Object methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'!
isHeap

	^ false! !

!Object methodsFor: 'testing'!
isInteger
	"Overridden to return true in Integer."

	^ false! !

!Object methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'!
isInterval

	^ false! !

!Object methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'!
isMessageSend
	^false
! !

!Object methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'!
isMethodProperties
	^false! !

!Object methodsFor: 'testing'!
isMorph

	^ false! !

!Object methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'!
isMorphicEvent
	^false! !

!Object methodsFor: 'testing' stamp: 'gm 2/22/2003 12:56'!
isMorphicModel
	"Return true if the receiver is a morphic model"
	^false
! !

!Object methodsFor: 'testing'!
isNumber
	"Overridden to return true in Number, natch"
	^ false! !

!Object methodsFor: 'testing' stamp: 'di 11/6/1998 08:04'!
isPoint
	"Overridden to return true in Point."

	^ false! !

!Object methodsFor: 'testing' stamp: 'ikp 9/26/97 14:45'!
isPseudoContext
	^false! !

!Object methodsFor: 'testing' stamp: 'md 10/2/2005 21:52'!
isRectangle
	^false! !

!Object methodsFor: 'testing' stamp: 'nk 6/14/2004 16:49'!
isSketchMorph
	^false! !

!Object methodsFor: 'testing' stamp: 'ar 12/23/1999 15:43'!
isStream
	"Return true if the receiver responds to the stream protocol"
	^false
! !

!Object methodsFor: 'testing' stamp: 'sma 6/15/2000 15:48'!
isString
	"Overridden to return true in String, natch"
	^ false! !

!Object methodsFor: 'testing' stamp: 'md 4/30/2003 15:30'!
isSymbol
	^ false ! !

!Object methodsFor: 'testing' stamp: 'jam 3/9/2003 15:10'!
isSystemWindow
"answer whatever the receiver is a SystemWindow"
	^ false! !

!Object methodsFor: 'testing'!
isText
	^ false! !

!Object methodsFor: 'testing' stamp: 'pmm 7/6/2006 20:46'!
isTrait
	"Return true if the receiver is a trait.
	Note: Do not override in any class except TraitBehavior."
	^false! !

!Object methodsFor: 'testing' stamp: 'tk 10/21/97 12:45'!
isTransparent
	^ false! !

!Object methodsFor: 'testing' stamp: 'ar 8/14/2001 23:19'!
isVariableBinding
	"Return true if I represent a literal variable binding"
	^false
	! !

!Object methodsFor: 'testing' stamp: 'ls 7/14/1998 21:45'!
isWebBrowser
	"whether this object is a web browser.  See class: Scamper"
	^false! !

!Object methodsFor: 'testing' stamp: 'sw 10/27/2000 06:58'!
knownName
	"If a formal name has been handed out for this object, answer it, else nil"
	
	^ Preferences capitalizedReferences
		ifTrue:
			[References keyAtValue: self ifAbsent: [nil]]
		ifFalse:
			[nil]! !

!Object methodsFor: 'testing' stamp: 'sw 9/27/96'!
name
	"Answer a name for the receiver.  This is used generically in the title of certain inspectors, such as the referred-to inspector, and specificially by various subsystems.  By default, we let the object just print itself out..  "

	^ self printString! !

!Object methodsFor: 'testing' stamp: 'sw 11/19/2001 13:28'!
nameForViewer
	"Answer a name to be shown in a Viewer that is viewing the receiver"

	| aName |
	(aName _ self uniqueNameForReferenceOrNil) ifNotNil: [^ aName].
	(aName _ self knownName) ifNotNil: [^ aName].

	^ [(self asString copyWithout: Character cr) truncateTo:  27] ifError:
		[:msg :rcvr | ^ self class name printString]! !

!Object methodsFor: 'testing'!
notNil
	"Coerces nil to false and everything else to true."

	^true! !

!Object methodsFor: 'testing' stamp: 'tk 9/6/2001 19:15'!
openInstanceBrowserWithTiles
	"Open up an instance browser on me with tiles as the code type, and with the search level as desired."

	| aBrowser |
	aBrowser _ InstanceBrowser new.
	aBrowser useVocabulary: Vocabulary fullVocabulary.
	aBrowser limitClass: self class.
	aBrowser contentsSymbol: #tiles.		"preset it to make extra buttons (tile menus)"
	aBrowser openOnObject: self inWorld: ActiveWorld showingSelector: nil.
	aBrowser contentsSymbol: #source.
	aBrowser toggleShowingTiles.

	"
(2@3) openInstanceBrowserWithTiles.
WatchMorph new openInstanceBrowserWithTiles
"! !

!Object methodsFor: 'testing' stamp: 'tk 7/28/2005 04:50'!
renameInternal: newName 
	"Change the internal name (because of a conflict) but leave the external name unchanged.  Change Player class name, but do not change the names that appear in tiles.  Any object that might be pointed to in the References dictionary might get this message sent to it upon reload"

	^ nil	"caller will renameTo:.  new name may be different"! !

!Object methodsFor: 'testing' stamp: 'sw 2/27/2002 14:55'!
renameTo: newName
	"If the receiver has an inherent idea about its own name, it should take action here.  Any object that might be pointed to in the References dictionary might get this message sent to it upon reload"! !

!Object methodsFor: 'testing' stamp: 'sw 1/18/2001 13:43'!
showDiffs
	"Answer whether the receiver, serving as the model of a text-bearing entity, is 'showing differences' -- if it is, the editor may wish to show special feedback"

	^ false! !

!Object methodsFor: 'testing' stamp: 'sw 10/20/1999 14:52'!
stepAt: millisecondClockValue in: aWindow

	^ self stepIn: aWindow! !

!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:16'!
stepIn: aWindow

	^ self step! !

!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:21'!
stepTime
	
	^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! !

!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:22'!
stepTimeIn: aSystemWindow
	
	^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! !

!Object methodsFor: 'testing' stamp: 'sw 5/3/2001 18:22'!
vocabularyDemanded
	"Answer a vocabulary that the receiver insists be used when it is looked at in a Viewer.  This allows specific classes to insist on specific custom vocabularies"

	^ nil! !

!Object methodsFor: 'testing' stamp: 'sw 11/13/2001 07:26'!
wantsDiffFeedback
	"Answer whether the receiver, serving as the model of a text-bearing entity, would like for 'diffs' green pane-border feedback to be shown"

	^ false! !

!Object methodsFor: 'testing' stamp: 'di 1/8/1999 15:04'!
wantsSteps
	"Overridden by morphic classes whose instances want to be stepped,
	or by model classes who want their morphic views to be stepped."

	^ false! !

!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:26'!
wantsStepsIn: aSystemWindow
	
	^ self wantsSteps! !


!Object methodsFor: 'translation support'!
inline: inlineFlag
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support'!
var: varSymbol declareC: declString
	"For translation only; noop when running in Smalltalk."! !


!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:32'!
capturedState
	"May be overridden in subclasses."

	^ self shallowCopy
! !

!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:29'!
commandHistory
	"Return the command history for the receiver"
	| w |
	(w _ self currentWorld) ifNotNil: [^ w commandHistory].
	^ CommandHistory new. "won't really record anything but prevent breaking things"! !

!Object methodsFor: 'undo' stamp: 'di 12/12/2000 15:01'!
purgeAllCommands
	"Purge all commands for this object"
	Preferences useUndo ifFalse: [^ self]. "get out quickly"
	self commandHistory purgeAllCommandsSuchThat: [:cmd | cmd undoTarget == self].
! !

!Object methodsFor: 'undo' stamp: 'di 9/12/2000 08:15'!
redoFromCapturedState: st 
	"May be overridden in subclasses.  See also capturedState"

	self undoFromCapturedState: st  "Simple cases are symmetric"
! !

!Object methodsFor: 'undo' stamp: 'sw 11/16/2000 14:42'!
refineRedoTarget: target selector: aSymbol arguments: arguments in: refineBlock 
	"Any object can override this method to refine its redo specification"

	^ refineBlock
		value: target
		value: aSymbol
		value: arguments! !

!Object methodsFor: 'undo' stamp: 'sw 11/16/2000 14:42'!
refineUndoTarget: target selector: aSymbol arguments: arguments in: refineBlock 
	"Any object can override this method to refine its undo specification"

	^ refineBlock
		value: target
		value: aSymbol
		value: arguments! !

!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:30'!
rememberCommand: aCommand
	"Remember the given command for undo"
	Preferences useUndo ifFalse: [^ self]. "get out quickly"
	^ self commandHistory rememberCommand: aCommand! !

!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:30'!
rememberUndoableAction: actionBlock named: caption
	| cmd result |
	cmd _ Command new cmdWording: caption.
	cmd undoTarget: self selector: #undoFromCapturedState: argument: self capturedState.
	result _ actionBlock value.
	cmd redoTarget: self selector: #redoFromCapturedState: argument: self capturedState.
	self rememberCommand: cmd.
	^ result! !

!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:32'!
undoFromCapturedState: st 
	"May be overridden in subclasses.  See also capturedState"

	self copyFrom: st
! !


!Object methodsFor: 'updating'!
changed
	"Receiver changed in a general way; inform all the dependents by 
	sending each dependent an update: message."

	self changed: self! !

!Object methodsFor: 'updating'!
changed: aParameter 
	"Receiver changed. The change is denoted by the argument aParameter. 
	Usually the argument is a Symbol that is part of the dependent's change 
	protocol. Inform all of the dependents."

	self dependents do: [:aDependent | aDependent update: aParameter]! !

!Object methodsFor: 'updating' stamp: 'nk 2/17/2004 11:12'!
changed: anAspect with: anObject
	"Receiver changed. The change is denoted by the argument anAspect. 
	Usually the argument is a Symbol that is part of the dependent's change 
	protocol. Inform all of the dependents. Also pass anObject for additional information."

	self dependents do: [:aDependent | aDependent update: anAspect with: anObject]! !

!Object methodsFor: 'updating' stamp: 'sw 10/12/1999 18:15'!
handledListVerification
	"When a self-updating PluggableListMorph lazily checks to see the state of affairs, it first gives its model an opportunity to handle the list verification itself (this is appropriate for some models, such as VersionsBrowser); if a list's model has indeed handled things itself, it returns true here"

	^ false! !

!Object methodsFor: 'updating' stamp: 'sw 10/31/1999 00:15'!
noteSelectionIndex: anInteger for: aSymbol
	"backstop"! !

!Object methodsFor: 'updating'!
okToChange
	"Allows a controller to ask this of any model"
	^ true! !

!Object methodsFor: 'updating' stamp: 'sw 10/19/1999 14:39'!
updateListsAndCodeIn: aWindow
	self canDiscardEdits ifFalse: [^ self].
	aWindow updatablePanes do: [:aPane | aPane verifyContents]! !

!Object methodsFor: 'updating' stamp: 'sma 2/29/2000 20:05'!
update: aParameter 
	"Receive a change notice from an object of whom the receiver is a 
	dependent. The default behavior is to do nothing; a subclass might want 
	to change itself in some way."

	^ self! !

!Object methodsFor: 'updating' stamp: 'nk 2/17/2004 11:13'!
update: anAspect with: anObject
	"Receive a change notice from an object of whom the receiver is a 
	dependent. The default behavior is to call update:,
	which by default does nothing; a subclass might want 
	to change itself in some way."

	^ self update: anAspect! !

!Object methodsFor: 'updating' stamp: 'jm 8/20/1998 18:26'!
windowIsClosing
	"This message is used to inform a models that its window is closing. Most models do nothing, but some, such as the Debugger, must do some cleanup. Note that this mechanism must be used with care by models that support multiple views, since one view may be closed while others left open."
! !


!Object methodsFor: 'user interface' stamp: 'sw 10/4/1999 08:13'!
addModelItemsToWindowMenu: aMenu
	"aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic window.  Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself."! !

!Object methodsFor: 'user interface' stamp: 'sw 10/5/1998 14:39'!
addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph 
	"The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items"
! !

!Object methodsFor: 'user interface' stamp: 'sma 11/12/2000 11:43'!
asExplorerString
	^ self printString! !

!Object methodsFor: 'user interface' stamp: 'sw 7/13/1999 15:53'!
defaultBackgroundColor
	"Answer the color to be used as the base window color for a window whose model is an object of the receiver's class"
	
	^ Preferences windowColorFor: self class name! !

!Object methodsFor: 'user interface'!
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."

	^ self class name! !

!Object methodsFor: 'user interface' stamp: 'RAA 7/10/2000 08:11'!
eToyStreamedRepresentationNotifying: aWidget

	| outData |
	[ outData _ SmartRefStream streamedRepresentationOf: self ] 
		on: ProgressInitiationException
		do: [ :ex | 
			ex sendNotificationsTo: [ :min :max :curr |
				aWidget ifNotNil: [aWidget flashIndicator: #working].
			].
		].
	^outData
! !

!Object methodsFor: 'user interface' stamp: 'ar 9/27/2005 20:29'!
explore
	^ToolSet explore: self! !

!Object methodsFor: 'user interface' stamp: 'sw 8/15/97 17:25'!
fullScreenSize
	"Answer the size to which a window displaying the receiver should be set"
	| adj |
	adj _ (3 * Preferences scrollBarWidth) @ 0.
	^ Rectangle origin: adj extent: (DisplayScreen actualScreenSize - adj)! !

!Object methodsFor: 'user interface' stamp: 'RAA 6/21/1999 11:27'!
hasContentsInExplorer

	^self basicSize > 0 or: [self class allInstVarNames isEmpty not]
! !

!Object methodsFor: 'user interface' stamp: 'rbb 3/1/2005 09:28'!
inform: aString
	"Display a message for the user to read and then dismiss. 6/9/96 sw"

	aString isEmptyOrNil ifFalse: [UIManager default inform: aString]! !

!Object methodsFor: 'user interface'!
initialExtent
	"Answer the desired extent for the receiver when a view on it is first opened on the screen. 
	5/22/96 sw: in the absence of any override, obtain from RealEstateAgent"

	^ RealEstateAgent standardWindowExtent! !

!Object methodsFor: 'user interface' stamp: 'ar 9/27/2005 20:30'!
inspectWithLabel: aLabel
	"Create and schedule an Inspector in which the user can examine the receiver's variables."
	^ToolSet inspect: self label: aLabel! !

!Object methodsFor: 'user interface' stamp: 'sw 6/12/2001 11:09'!
launchPartVia: aSelector
	"Obtain a morph by sending aSelector to self, and attach it to the morphic hand.  This provides a general protocol for parts bins"

	| aMorph |
	aMorph _ self perform: aSelector.
	aMorph setProperty: #beFullyVisibleAfterDrop toValue: true.
	aMorph openInHand! !

!Object methodsFor: 'user interface' stamp: 'sw 6/17/2004 01:47'!
launchPartVia: aSelector label: aString
	"Obtain a morph by sending aSelector to self, and attach it to the morphic hand.  This provides a general protocol for parts bins"

	| aMorph |
	aMorph _ self perform: aSelector.
	aMorph setNameTo: (ActiveWorld unusedMorphNameLike: aString).
	aMorph setProperty: #beFullyVisibleAfterDrop toValue: true.
	aMorph openInHand! !

!Object methodsFor: 'user interface' stamp: 'sw 10/16/2000 11:11'!
launchTileToRefer
	"Create a tile to reference the receiver, and attach it to the hand"

	self currentHand attachMorph: self tileToRefer! !

!Object methodsFor: 'user interface' stamp: 'di 5/11/1999 22:26'!
modelSleep
	"A window with me as model is being exited or collapsed or closed.
	Default response is no-op" ! !

!Object methodsFor: 'user interface' stamp: 'di 5/11/1999 22:01'!
modelWakeUp
	"A window with me as model is being entered or expanded.  Default response is no-op" ! !

!Object methodsFor: 'user interface' stamp: 'sw 10/16/1999 22:45'!
modelWakeUpIn: aWindow
	"A window with me as model is being entered or expanded.  Default response is no-op" 
	self modelWakeUp! !

!Object methodsFor: 'user interface' stamp: 'sw 3/8/1999 15:27'!
mouseUpBalk: evt
	"A button I own got a mouseDown, but the user moved out before letting up.  Certain kinds of objects (so-called 'radio buttons', for example, and other structures that must always have some selection, e.g. PaintBoxMorph) wish to take special action in this case; this default does nothing."
! !

!Object methodsFor: 'user interface' stamp: 'sw 8/22/97 13:14'!
newTileMorphRepresentative
	^ TileMorph new setLiteral: self! !

!Object methodsFor: 'user interface' stamp: 'jcg 11/1/2001 13:13'!
notYetImplemented
	self inform: 'Not yet implemented (', thisContext sender printString, ')'! !

!Object methodsFor: 'user interface' stamp: 'di 6/10/1998 15:06'!
windowActiveOnFirstClick
	"Return true if my window should be active on first click."

	^ false! !

!Object methodsFor: 'user interface' stamp: 'di 6/10/1998 15:06'!
windowReqNewLabel: labelString
	"My window's title has been edited.
	Return true if this is OK, and override for further behavior."

	^ true! !


!Object methodsFor: 'world hacking' stamp: 'ar 3/17/2001 23:45'!
couldOpenInMorphic

        "is there an obvious morphic world in which to open a new morph?"

        ^World notNil or: [ActiveWorld notNil]! !


!Object methodsFor: '*39Deprecated' stamp: 'gk 2/24/2004 08:49'!
beep
	"Deprecated."
	
	self deprecated: 'Use Beeper class>>beep instead.'.
	Beeper beep! !

!Object methodsFor: '*39Deprecated' stamp: 'gk 2/24/2004 08:50'!
beepPrimitive
	"Deprecated. Beep in the absence of sound support."
	
	self deprecated: 'Use Beeper class>>beep or Beeper class>>beepPrimitive instead.'.
	Beeper beepPrimitive! !

!Object methodsFor: '*39Deprecated' stamp: 'md 12/12/2003 17:02'!
beep: soundName
	"Make the given sound, unless the making of sound is disabled in Preferences."

	self deprecated: 'Use SampledSound>>playSoundNamed: instead.'.
	Preferences soundsEnabled
		ifTrue: [self playSoundNamed: soundName]
! !

!Object methodsFor: '*39Deprecated' stamp: 'sd 11/19/2004 16:57'!
contentsGetz: x
	self deprecated: 'there is no method named contents in object and in addition only one sender in a method not called'. 
	self contents: x! !

!Object methodsFor: '*39Deprecated' stamp: 'sd 11/13/2003 21:10'!
deprecatedExplanation: aString
     "This method is OBSOLETE.  Use #deprecated: instead."
	self deprecated: 'Use Object>>deprecated: instead of deprecatedExplanation:.'.

	Preferences showDeprecationWarnings ifTrue:
		[Deprecation signal: ('{1} has been deprecated. {2}' translated format: {thisContext sender printString. aString})]! !

!Object methodsFor: '*39Deprecated' stamp: 'sd 11/13/2003 21:11'!
deprecated: aBlock explanation: aString 
	 "This method is OBSOLETE.  Use #deprecated:block: instead."
	self deprecated: 'Use Object>>deprecated:block: instead of deprecated:explanation:.'.

	Preferences showDeprecationWarnings ifTrue:
		[Deprecation
			signal: ('{1} has been deprecated. {2}' translated format: {thisContext sender printString. aString})].
	^ aBlock value.
! !

!Object methodsFor: '*39Deprecated' stamp: 'md 12/12/2003 16:25'!
doIfNotNil: aBlock
	self deprecated: 'use ifNotNilDo:'.
	^ self ifNotNilDo: aBlock
! !

!Object methodsFor: '*39Deprecated' stamp: 'md 11/27/2004 12:20'!
ifKindOf: aClass thenDo: aBlock
	self deprecated: 'Deprecated. Just use #isKindOf:'.
	^ (self isKindOf: aClass) ifTrue: [aBlock value: self]! !

!Object methodsFor: '*39Deprecated' stamp: 'gk 2/23/2004 20:51'!
playSoundNamed: soundName
	"Deprecated.
	Play the sound with the given name."

	self deprecated: 'Use "SoundService default playSoundNamed: aName" instead.'.
	SoundService default playSoundNamed: soundName! !












!Object methodsFor: '*monticello' stamp: 'dvf 8/10/2004 23:25'!
isConflict
	^false! !


!Object methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:54'!
requestor
	"returns the focused window's requestor"

	"SystemWindow focusedWindow ifNotNilDo: [:w | ^ w requestor]."

	"triggers an infinite loop"

	^ Requestor default! !


!Object methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:27'!
systemNavigation

	^ SystemNavigation default! !


!Object methodsFor: '*Tools-Explorer' stamp: 'stephaneducasse 9/17/2005 21:52'!
exploreAndYourself
	"i.e. explore; yourself. Thisway i can peek w/o typing all the parentheses"
	self explore. 
     ^self! !

!Object methodsFor: '*Tools-Explorer' stamp: 'stephaneducasse 9/17/2005 21:48'!
exploreWithLabel: label

	^ ObjectExplorer new openExplorerFor: self withLabel:
label! !





!Object methodsFor: '*tools-browser' stamp: 'mu 3/6/2004 15:13'!
browse
	self systemNavigation browseClass: self class! !

!Object methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 16:00'!
browseHierarchy
	self systemNavigation browseHierarchy: self class! !


!Object methodsFor: 'private'!
errorImproperStore
	"Create an error notification that an improper store was attempted."

	self error: 'Improper store into indexable object'! !

!Object methodsFor: 'private'!
errorNonIntegerIndex
	"Create an error notification that an improper object was used as an index."

	self error: 'only integers should be used as indices'! !

!Object methodsFor: 'private' stamp: 'yo 6/29/2004 11:37'!
errorNotIndexable
	"Create an error notification that the receiver is not indexable."

	self error: ('Instances of {1} are not indexable' translated format: {self class name})! !

!Object methodsFor: 'private'!
errorSubscriptBounds: index 
	"Create an error notification that an improper integer was used as an index."

	self error: 'subscript is out of bounds: ' , index printString! !

!Object methodsFor: 'private' stamp: 'ar 2/6/2004 14:47'!
primitiveError: aString 
	"This method is called when the error handling results in a recursion in 
	calling on error: or halt or halt:."

	| context |
	(String
		streamContents: 
			[:s |
			s nextPutAll: '***System error handling failed***'.
			s cr; nextPutAll: aString.
			context _ thisContext sender sender.
			20 timesRepeat: [context == nil ifFalse: [s cr; print: (context _ context sender)]].
			s cr; nextPutAll: '-------------------------------'.
			s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'.
			s cr; nextPutAll: 'Type any other character to restart.'])
		displayAt: 0 @ 0.
	[Sensor keyboardPressed] whileFalse.
	Sensor keyboard = Character cr ifTrue: [Transcripter emergencyEvaluator].
	Smalltalk isMorphic
		ifTrue: [World install "init hands and redisplay"]
		ifFalse: [ScheduledControllers searchForActiveController]! !

!Object methodsFor: 'private'!
species
	"Answer the preferred class for reconstructing the receiver.  For example, 
	collections create new collections whenever enumeration messages such as 
	collect: or select: are invoked.  The new kind of collection is determined by 
	the species of the original collection.  Species and class are not always the 
	same.  For example, the species of Interval is Array."

	^self class! !

!Object methodsFor: 'private'!
storeAt: offset inTempFrame: aContext
	"This message had to get sent to an expression already on the stack
	as a Block argument being accessed by the debugger.
	Just re-route it to the temp frame."
	^ aContext tempAt: offset put: self! !


!Object methodsFor: '*Morphic-NewCurve-testing''' stamp: 'wiz 12/31/2005 21:31'!
isNonZero
"Overriden in Number. This returns the backstop answer for non-numbers"
^false.! !


!Object methodsFor: 'events' stamp: 'nk 8/27/2003 16:23'!
actionsWithReceiver: anObject forEvent: anEventSelector

	^(self actionSequenceForEvent: anEventSelector)
                select: [:anAction | anAction receiver == anObject ]! !

!Object methodsFor: 'events' stamp: 'nk 8/27/2003 17:45'!
renameActionsWithReceiver: anObject forEvent: anEventSelector toEvent: newEvent

	| oldActions newActions |
	oldActions _ Set new.
	newActions _ Set new.
	(self actionSequenceForEvent: anEventSelector) do: [ :action |
		action receiver == anObject
			ifTrue: [ oldActions add: anObject ]
			ifFalse: [ newActions add: anObject ]].
	self setActionSequence: (ActionSequence withAll: newActions) forEvent: anEventSelector.
	oldActions do: [ :act | self when: newEvent evaluate: act ].! !


!Object methodsFor: 'viewer' stamp: 'sw 10/16/2000 10:35'!
assureUniClass
	"If the receiver is not yet an instance of a uniclass, create a uniclass for it and make the receiver become an instance of that class."

	| anInstance |
	self belongsToUniClass ifTrue: [^ self].
	anInstance _ self class instanceOfUniqueClass.
	self become: (self as: anInstance class).
	^ anInstance! !

!Object methodsFor: 'viewer' stamp: 'sw 10/16/2000 10:41'!
belongsToUniClass
	"Answer whether the receiver belongs to a uniclass.  For the moment (this is not entirely satisfactory) this is precisely equated with the classname ending in a digit"

	^ self class name endsWithDigit! !

!Object methodsFor: 'viewer' stamp: 'sw 12/11/2000 15:37'!
browseOwnClassSubProtocol
	"Open up a ProtocolBrowser on the subprotocol of the receiver"

	ProtocolBrowser openSubProtocolForClass: self class
! !

!Object methodsFor: 'viewer' stamp: 'sw 8/4/2001 00:51'!
categoriesForViewer: aViewer
	"Answer a list of categories to offer in the given viewer"

	^ aViewer currentVocabulary categoryListForInstance: self ofClass: self class limitClass: aViewer limitClass! !

!Object methodsFor: 'viewer' stamp: 'sw 8/3/2001 22:08'!
categoriesForVocabulary: aVocabulary limitClass: aLimitClass
	"Answer a list of categories of methods for the receiver when using the given vocabulary, given that one considers only methods that are implemented not further away than aLimitClass"

	^ aVocabulary categoryListForInstance: self ofClass: self class limitClass: aLimitClass! !

!Object methodsFor: 'viewer' stamp: 'sw 10/25/2000 07:20'!
chooseNewNameForReference
	"Offer an opportunity for the receiver, presumed already to be known in the References registry, to be renamed"

	|  nameSym current newName |
	current _ References keyAtValue: self ifAbsent: [^ self error: 'not found in References'].

	newName _ FillInTheBlank request: 'Please enter new name' initialAnswer: current.
	"Want to user some better way of determining the validity of the chosen identifier, and also want to give more precise diagnostic if the string the user types in is not acceptable.  Work to be done here."

	newName isEmpty ifTrue: [^ nil].
	((Scanner isLiteralSymbol: newName) and: [(newName includes: $:) not])
		ifTrue:
			[nameSym _ newName capitalized asSymbol.
			(((References includesKey:  nameSym) not and:
				[(Smalltalk includesKey: nameSym) not]) and:
						[(ScriptingSystem allKnownClassVariableNames includes: nameSym) not])
					ifTrue:
						[(References associationAt: current) key: nameSym.
						References rehash.
						^ nameSym]].
	self inform: 'Sorry, that name is not available.'.
	^ nil! !

!Object methodsFor: 'viewer' stamp: 'sw 8/3/2001 21:22'!
defaultLimitClassForVocabulary: aVocabulary
	"Answer the class to use, by default, as the limit class on a protocol browser or viewer opened up on the receiver, within the purview of the Vocabulary provided"

	^ (aVocabulary isKindOf: FullVocabulary)
		ifTrue:
			 [self class superclass == Object
				ifTrue:
					[self class]
				ifFalse:
					[self class superclass]]
		ifFalse:
			[ProtoObject]! !

!Object methodsFor: 'viewer' stamp: 'sw 2/14/2000 14:24'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver.  The default is to let the class specify, but certain instances will want to override.  (PasteUpMorphs serving as Worlds come to mind"

	^ self class defaultNameStemForInstances! !

!Object methodsFor: 'viewer' stamp: 'sw 5/22/2001 16:53'!
elementTypeFor: aStringOrSymbol vocabulary: aVocabulary
	"Answer a symbol characterizing what kind of element aStringOrSymbol represents.  Realistically, at present, this always just returns #systemScript; a prototyped but not-incorporated architecture supported use of a leading colon to characterize an inst var of a system class, and for the moment we still see its remnant here."

	self flag: #deferred.  "a loose end in the non-player case"
	^ #systemScript! !

!Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 07:04'!
externalName
	"Answer an external name by which the receiver is known.  Generic implementation here is a transitional backstop. probably"

	^ self nameForViewer! !

!Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 07:06'!
graphicForViewerTab
	"When a Viewer is open on the receiver, its tab needs some graphic to show to the user.  Answer a form or a morph to serve that purpose.  A generic image is used for arbitrary objects, but note my reimplementors"
	
	^ ScriptingSystem formAtKey: 'Image'! !

!Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 07:08'!
hasUserDefinedSlots
	"Answer whether the receiver has any user-defined slots, in the omniuser sense of the term.  This is needed to allow Viewers to look at any object, not just at Players."

	^ false! !

!Object methodsFor: 'viewer' stamp: 'sw 8/22/2002 14:07'!
infoFor: anElement inViewer: aViewer
	"The user made a gesture asking for info/menu relating to me.  Some of the messages dispatched here are not yet available in this image"

	| aMenu elementType |
	elementType _ self elementTypeFor: anElement vocabulary: aViewer currentVocabulary.
	((elementType = #systemSlot) | (elementType == #userSlot))
		ifTrue:	[^ self slotInfoButtonHitFor: anElement inViewer: aViewer].
	self flag: #deferred.  "Use a traditional MenuMorph, and reinstate the pacify thing"
	aMenu _ MenuMorph new defaultTarget: aViewer.
	#(	('implementors'			browseImplementorsOf:)
		('senders'				browseSendersOf:)
		('versions'				browseVersionsOf:)
		-
		('browse full'			browseMethodFull:)
		('inheritance'			browseMethodInheritance:)
		-
		('about this method'		aboutMethod:)) do:

			[:pair |
				pair = '-'
					ifTrue:
						[aMenu addLine]
					ifFalse:
						[aMenu add: pair first target: aViewer selector: pair second argument: anElement]].
	aMenu addLine.
	aMenu defaultTarget: self.
	#(	('destroy script'		removeScript:)
		('rename script'		renameScript:)
		('pacify script'		pacifyScript:)) do:
			[:pair |
				aMenu add: pair first target: self selector: pair second argument: anElement].

	aMenu addLine.
	aMenu  add: 'show categories....' target: aViewer selector: #showCategoriesFor: argument: anElement.
	aMenu items size == 0 ifTrue:  "won't happen at the moment a/c the above"
		[aMenu add: 'ok' action: nil].  "in case it was a slot -- weird, transitional"

	aMenu addTitle: anElement asString, ' (', elementType, ')'.

	aMenu popUpInWorld: self currentWorld.
 ! !

!Object methodsFor: 'viewer' stamp: 'sw 9/26/2001 11:58'!
initialTypeForSlotNamed: aName
	"Answer the initial type to be ascribed to the given instance variable"

	^ #Object! !

!Object methodsFor: 'viewer' stamp: 'ar 5/26/2001 16:13'!
isPlayerLike
	"Return true if the receiver is a player-like object"
	^false! !

!Object methodsFor: 'viewer' stamp: 'nk 9/11/2004 16:53'!
methodInterfacesInPresentationOrderFrom: interfaceList forCategory: aCategory 
	"Answer the interface list sorted in desired presentation order, using a 
	static master-ordering list, q.v. The category parameter allows an 
	escape in case one wants to apply different order strategies in different 
	categories, but for now a single master-priority-ordering is used -- see 
	the comment in method EToyVocabulary.masterOrderingOfPhraseSymbols"

	| masterOrder ordered unordered index |
	masterOrder := Vocabulary eToyVocabulary masterOrderingOfPhraseSymbols.
	ordered := SortedCollection sortBlock: [:a :b | a key < b key].
	unordered := SortedCollection sortBlock: [:a :b | a wording < b wording].

	interfaceList do: [:interface | 
		index := masterOrder indexOf: interface elementSymbol.
		index isZero
			ifTrue: [unordered add: interface]
			ifFalse: [ordered add: index -> interface]].

	^ Array
		streamContents: [:stream | 
			ordered do: [:assoc | stream nextPut: assoc value].
			stream nextPutAll: unordered]! !

!Object methodsFor: 'viewer' stamp: 'sw 10/24/2000 11:36'!
newScriptorAround: aPhraseTileMorph
	"Sprout a scriptor around aPhraseTileMorph, thus making a new script.  This is where generalized scriptors will be threaded in"

	^ nil! !

!Object methodsFor: 'viewer' stamp: 'sw 10/25/2000 17:42'!
offerViewerMenuForEvt: anEvent morph: aMorph
	"Offer the viewer's primary menu to the user.  aMorph is some morph within the viewer itself, the one within which a mousedown triggered the need for this menu, and it is used only to retrieve the Viewer itself"

	self offerViewerMenuFor: (aMorph ownerThatIsA: StandardViewer) event: anEvent! !

!Object methodsFor: 'viewer' stamp: 'sw 8/11/2002 02:03'!
offerViewerMenuFor: aViewer event: evt
	"Offer the primary Viewer menu to the user.  Copied up from Player code, but most of the functions suggested here don't work for non-Player objects, many aren't even defined, some relate to exploratory sw work not yet reflected in the current corpus.  We are early in the life cycle of this method..."

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	aMenu title: '**CAUTION -- UNDER CONSTRUCTION!!**
Many things may not work!!
', self nameForViewer.
	(aViewer affordsUniclass and: [self belongsToUniClass not]) ifTrue:
		[aMenu add: 'give me a Uniclass' action: #assureUniClass.
		aMenu addLine].
	aMenu add: 'choose vocabulary...' target: aViewer action: #chooseVocabulary.
	aMenu add: 'choose limit class...' target: aViewer action: #chooseLimitClass.
	aMenu add: 'add search pane' target: aViewer action: #addSearchPane.
	aMenu balloonTextForLastItem: 'Specify which class should be the most generic one to have its methods shown in this Viewer'.
	aMenu addLine.

	self belongsToUniClass ifTrue:
		[aMenu add: 'add a new instance variable' target: self selector: #addInstanceVariableIn: argument: aViewer.
		aMenu add: 'add a new script' target: aViewer selector: #newPermanentScriptIn: argument: aViewer.
		aMenu addLine.
		aMenu add: 'make my class be first-class' target: self selector: #makeFirstClassClassIn: argument: aViewer.
		aMenu add: 'move my changes up to my superclass' target: self action: #promoteChangesToSuperclass.
		aMenu addLine].

	aMenu add: 'tear off a tile' target: self selector: #launchTileToRefer.
	aMenu addLine.

	aMenu add: 'inspect me' target: self selector: #inspect.
	aMenu add: 'inspect my class' target: self class action: #inspect.
	aMenu addLine.

	aMenu add: 'browse vocabulary' action: #haveFullProtocolBrowsed.
	aMenu add: 'inspect this Viewer' target: aViewer action: #inspect.

	aMenu popUpEvent: evt in: aViewer currentWorld

"
	aMenu add: 'references to me' target: aViewer action: #browseReferencesToObject.
	aMenu add: 'toggle scratch pane' target: aViewer selector: #toggleScratchPane.
	aMenu add: 'make a nascent script for me' target: aViewer selector: #makeNascentScript.
	aMenu add: 'rename me' target: aViewer selector: #chooseNewNameForReference.
	aMenu add: 'browse full' action: #browseOwnClassFull.
	aMenu add: 'browse hierarchy' action: #browseOwnClassHierarchy.
	aMenu add: 'set user level...' target: aViewer action: #setUserLevel.
	aMenu add: 'browse sub-protocol' action: #browseOwnClassSubProtocol.
	aMenu addLine.

"! !

!Object methodsFor: 'viewer' stamp: 'sw 1/22/2001 15:20'!
renameScript: oldSelector
	"prompt the user for a new selector and apply it.  Presently only works for players"

	self notYetImplemented! !

!Object methodsFor: 'viewer' stamp: 'sw 8/10/2004 11:53'!
tilePhrasesForCategory: aCategorySymbol inViewer: aViewer
	"Return a collection of phrases for the category."

	| interfaces |
	interfaces _ self methodInterfacesForCategory: aCategorySymbol inVocabulary: aViewer currentVocabulary limitClass: aViewer limitClass.
	interfaces _ self methodInterfacesInPresentationOrderFrom: interfaces forCategory: aCategorySymbol.
	^ self tilePhrasesForMethodInterfaces: interfaces inViewer: aViewer! !

!Object methodsFor: 'viewer' stamp: 'sw 8/10/2004 11:53'!
tilePhrasesForMethodInterfaces: methodInterfaceList inViewer: aViewer
	"Return a collection of ViewerLine objects corresponding to the method-interface list provided.   The resulting list will be in the same order as the incoming list, but may be smaller if the viewer's vocbulary suppresses some of the methods, or if, in classic tiles mode, the selector requires more arguments than can be handled."

	| toSuppress interfaces resultType itsSelector |
	toSuppress _ aViewer currentVocabulary phraseSymbolsToSuppress.
	interfaces _ methodInterfaceList reject: [:int | toSuppress includes: int selector].
	Preferences universalTiles ifFalse:  "Classic tiles have their limitations..."
		[interfaces _ interfaces select:
			[:int |
				itsSelector _ int selector.
				itsSelector numArgs < 2 or:
					"The lone two-arg loophole in classic tiles"
					[#(color:sees:) includes: itsSelector]]].

	^ interfaces collect:
		[:aMethodInterface |
			((resultType _ aMethodInterface resultType) notNil and: [resultType ~~ #unknown]) 
				ifTrue:
					[aViewer phraseForVariableFrom: aMethodInterface]
				ifFalse:
					[aViewer phraseForCommandFrom: aMethodInterface]]! !

!Object methodsFor: 'viewer' stamp: 'sw 8/10/2004 12:23'!
tilePhrasesForSelectorList: aList inViewer: aViewer
	"Particular to the search facility in viewers.  Answer a list, in appropriate order, of ViewerLine objects to put into the viewer."

	| interfaces aVocab |
	aVocab _ aViewer currentVocabulary.
	interfaces _ self
		methodInterfacesInPresentationOrderFrom:
			(aList collect: [:aSel | aVocab methodInterfaceForSelector: aSel class: self class])
		forCategory: #search.
	^ self tilePhrasesForMethodInterfaces: interfaces inViewer: aViewer! !

!Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 04:51'!
tileToRefer
	"Answer a reference tile that comprises an alias to me"

	^ TileMorph new setToReferTo: self! !

!Object methodsFor: 'viewer' stamp: 'sd 3/30/2005 22:04'!
uniqueInstanceVariableNameLike: aString excluding: takenNames
	"Answer a nice instance-variable name to be added to the receiver which resembles aString, making sure it does not coincide with any element in takenNames"

	| okBase uniqueName usedNames |
	usedNames _ self class allInstVarNamesEverywhere.
	usedNames removeAllFoundIn: self class instVarNames.
	usedNames addAll: takenNames.
	okBase _ Scanner wellFormedInstanceVariableNameFrom: aString.

	uniqueName _ Utilities keyLike: okBase satisfying: 
		[:aKey | (usedNames includes: aKey) not].

	^ uniqueName! !

!Object methodsFor: 'viewer' stamp: 'sw 11/21/2001 15:16'!
uniqueNameForReference
	"Answer a nice name by which the receiver can be referred to by other objects.  At present this uses a global References dictionary to hold the database of references, but in due course this will need to acquire some locality"

	| aName nameSym stem knownClassVars |
	(aName _ self uniqueNameForReferenceOrNil) ifNotNil: [^ aName].
	(stem _ self knownName) ifNil:
		[stem _ self defaultNameStemForInstances asString].
	stem _ stem select: [:ch | ch isLetter or: [ch isDigit]].
	stem size == 0 ifTrue: [stem _ 'A'].
	stem first isLetter ifFalse:
		[stem _ 'A', stem].
	stem _ stem capitalized.
	knownClassVars _ ScriptingSystem allKnownClassVariableNames.
	aName _ Utilities keyLike:  stem satisfying:
		[:jinaLake |
			nameSym _ jinaLake asSymbol.
			 ((References includesKey:  nameSym) not and:
				[(Smalltalk includesKey: nameSym) not]) and:
						[(knownClassVars includes: nameSym) not]].

	References at: (aName _ aName asSymbol) put: self.
	^ aName! !

!Object methodsFor: 'viewer' stamp: 'md 1/17/2006 17:58'!
uniqueNameForReferenceFrom: proposedName
	"Answer a satisfactory symbol, similar to the proposedName but obeying the rules, to represent the receiver"

	| aName nameSym stem okay |
	proposedName = self uniqueNameForReferenceOrNil 
		ifTrue: [^ proposedName].  "No change"

	stem _ proposedName select: [:ch | ch isLetter or: [ch isDigit]].
	stem size == 0 ifTrue: [stem _ 'A'].
	stem first isLetter ifFalse:
		[stem _ 'A', stem].
	stem _ stem capitalized.
	aName _ Utilities keyLike: stem satisfying:
		[:jinaLake |
			nameSym _ jinaLake asSymbol.
			okay _ true.
			(self class bindingOf: nameSym) ifNotNil: [okay _ false "don't use it"].
			okay].
	^ aName asSymbol! !

!Object methodsFor: 'viewer' stamp: 'sw 3/15/2004 23:01'!
uniqueNameForReferenceOrNil
	"If the receiver has a unique name for reference, return it here, else return nil"

	^ References keyAtValue: self ifAbsent: [nil]! !

!Object methodsFor: 'viewer' stamp: 'ar 5/16/2001 01:40'!
updateThresholdForGraphicInViewerTab
	"When a Viewer is open on the receiver, its tab needs some graphic to show to the user. Computing this graphic can take quite some time so we want to make the update frequency depending on how long it takes to compute the thumbnail. The threshold returned by this method defines that the viewer will update at most every 'threshold * timeItTakesToDraw' milliseconds. Thus, if the time for computing the receiver's thumbnail is 200 msecs and the the threshold is 10, the viewer will update at most every two seconds."
	^20 "seems to be a pretty good general choice"! !

!Object methodsFor: 'viewer' stamp: 'sw 3/9/2001 13:48'!
usableMethodInterfacesIn: aListOfMethodInterfaces
	"Filter aList, returning a subset list of apt phrases"

	^ aListOfMethodInterfaces
! !


!Object methodsFor: 'inspecting' stamp: 'ar 9/27/2005 18:31'!
basicInspect
	"Create and schedule an Inspector in which the user can examine the 
	receiver's variables. This method should not be overriden."
	^ToolSet basicInspect: self! !

!Object methodsFor: 'inspecting' stamp: 'md 1/18/2006 19:09'!
inspect
	"Create and schedule an Inspector in which the user can examine the receiver's variables."
	ToolSet inspect: self! !

!Object methodsFor: 'inspecting' stamp: 'apb 7/14/2004 12:19'!
inspectorClass
	"Answer the class of the inspector to be used on the receiver.  Called by inspect; 
	use basicInspect to get a normal (less useful) type of inspector."

	^ Inspector! !


!Object methodsFor: 'thumbnail' stamp: 'dgd 9/25/2004 23:17'!
iconOrThumbnailOfSize: aNumberOrPoint 
	"Answer an appropiate form to represent the receiver"
	^ nil! !


!Object methodsFor: 'scripts-kernel' stamp: 'nk 10/14/2004 10:55'!
universalTilesForGetterOf: aMethodInterface
	"Return universal tiles for a getter on the given method interface."

	| ms argTile argArray itsSelector |
	itsSelector _ aMethodInterface selector.
	argArray _ #().

	"Four gratuituous special cases..."

	(itsSelector == #color:sees:) ifTrue:
		[argTile _ ScriptingSystem tileForArgType: #Color.
		argArray _ Array with: argTile colorSwatch color with: argTile colorSwatch color copy].

	itsSelector == #seesColor: ifTrue:
		[argTile _ ScriptingSystem tileForArgType: #Color.
		argArray _  Array with: argTile colorSwatch color].

	(#(touchesA: overlaps: overlapsAny:) includes: itsSelector) ifTrue:
		[argTile _ ScriptingSystem tileForArgType: #Player.
		argArray _ Array with: argTile actualObject].

	ms _ MessageSend receiver: self selector: itsSelector arguments: argArray.
	^ ms asTilesIn: self class globalNames: (self class officialClass ~~ CardPlayer)
			"For CardPlayers, use 'self'.  For others, name it, and use its name."! !

!Object methodsFor: 'scripts-kernel' stamp: 'tk 9/28/2001 13:30'!
universalTilesForInterface: aMethodInterface
	"Return universal tiles for the given method interface.  Record who self is."

	| ms argTile itsSelector aType argList |
	itsSelector _ aMethodInterface selector.
	argList _ OrderedCollection new.
	aMethodInterface argumentVariables doWithIndex:
		[:anArgumentVariable :anIndex | 
			argTile _ ScriptingSystem tileForArgType: (aType _ aMethodInterface typeForArgumentNumber: anIndex).
			argList add: (aType == #Player 
				ifTrue: [argTile actualObject]
				ifFalse: [argTile literal]).	"default value for each type"].

	ms _ MessageSend receiver: self selector: itsSelector arguments: argList asArray.
	^ ms asTilesIn: self class globalNames: (self class officialClass ~~ CardPlayer)
			"For CardPlayers, use 'self'.  For others, name it, and use its name."! !


!Object methodsFor: 'breakpoint' stamp: 'bkv 7/1/2003 12:33'!
break
	"This is a simple message to use for inserting breakpoints during debugging.
	The debugger is opened by sending a signal. This gives a chance to restore
	invariants related to multiple processes."

	BreakPoint signal.

	"nil break."! !



!Object methodsFor: '*omnibrowser-converting' stamp: 'cwp 4/17/2006 12:16'!
asAnnouncement
	^ self! !

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

Object class
	instanceVariableNames: ''!

!Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 02:00'!
flushDependents
	DependentsFields keysAndValuesDo:[:key :dep|
		key ifNotNil:[key removeDependent: nil].
	].
	DependentsFields finalizeValues.! !

!Object class methodsFor: 'class initialization' stamp: 'rw 2/10/2002 13:09'!
flushEvents
	"Object flushEvents"

	EventManager flushEvents. ! !

!Object class methodsFor: 'class initialization' stamp: 'rww 10/2/2001 07:35'!
initialize
	"Object initialize"
	DependentsFields ifNil:[self initializeDependentsFields].! !

!Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:41'!
initializeDependentsFields
	"Object initialize"
	DependentsFields _ WeakIdentityKeyDictionary new.
! !

!Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:45'!
reInitializeDependentsFields
	"Object reInitializeDependentsFields"
	| oldFields |
	oldFields _ DependentsFields.
	DependentsFields _ WeakIdentityKeyDictionary new.
	oldFields keysAndValuesDo:[:obj :deps|
		deps do:[:d| obj addDependent: d]].
! !


!Object class methodsFor: 'documentation'!
howToModifyPrimitives
	"You are allowed to write methods which specify primitives, but please use 
	caution.  If you make a subclass of a class which contains a primitive method, 
	the subclass inherits the primitive.  The message which is implemented 
	primitively may be overridden in the subclass (E.g., see at:put: in String's 
	subclass Symbol).  The primitive behavior can be invoked using super (see 
	Symbol string:). 
	 
	A class which attempts to mimic the behavior of another class without being 
	its subclass may or may not be able to use the primitives of the original class.  
	In general, if the instance variables read or written by a primitive have the 
	same meanings and are in the same fields in both classes, the primitive will 
	work.  

	For certain frequently used 'special selectors', the compiler emits a 
	send-special-selector bytecode instead of a send-message bytecode.  
	Special selectors were created because they offer two advantages.  Code 
	which sends special selectors compiles into fewer bytes than normal.  For 
	some pairs of receiver classes and special selectors, the interpreter jumps 
	directly to a primitive routine without looking up the method in the class.  
	This is much faster than a normal message lookup. 
	 
	A selector which is a special selector solely in order to save space has a 
	normal behavior.  Methods whose selectors are special in order to 
	gain speed contain the comment, 'No Lookup'.  When the interpreter 
	encounters a send-special-selector bytecode, it checks the class of the 
	receiver and the selector.  If the class-selector pair is a no-lookup pair, 
	then the interpreter swiftly jumps to the routine which implements the 
	corresponding primitive.  (A special selector whose receiver is not of the 
	right class to make a no-lookup pair, is looked up normally).  The pairs are 
	listed below.  No-lookup methods contain a primitive number specification, 
	<primitive: xx>, which is redundant.  Since the method is not normally looked 
	up, deleting the primitive number specification cannot prevent this 
	primitive from running.  If a no-lookup primitive fails, the method is looked 
	up normally, and the expressions in it are executed. 
	 
	No Lookup pairs of (class, selector) 
	 
	SmallInteger with any of		+ - * /  \\  bitOr: bitShift: bitAnd:  // 
	SmallInteger with any of		=  ~=  >  <  >=  <= 
	Any class with					== 
	Any class with 					@ 
	Point with either of				x y 
	ContextPart with					blockCopy: 
	BlockContext with either of 		value value:
	"

	self error: 'comment only'! !

!Object class methodsFor: 'documentation'!
whatIsAPrimitive
	"Some messages in the system are responded to primitively. A primitive   
	response is performed directly by the interpreter rather than by evaluating   
	expressions in a method. The methods for these messages indicate the   
	presence of a primitive response by including <primitive: xx> before the   
	first expression in the method.   
	  
	Primitives exist for several reasons. Certain basic or 'primitive' 
	operations cannot be performed in any other way. Smalltalk without 
	primitives can move values from one variable to another, but cannot add two 
	SmallIntegers together. Many methods for arithmetic and comparison 
	between numbers are primitives. Some primitives allow Smalltalk to 
	communicate with I/O devices such as the disk, the display, and the keyboard. 
	Some primitives exist only to make the system run faster; each does the same 
	thing as a certain Smalltalk method, and its implementation as a primitive is 
	optional.  
	  
	When the Smalltalk interpreter begins to execute a method which specifies a 
	primitive response, it tries to perform the primitive action and to return a 
	result. If the routine in the interpreter for this primitive is successful, 
	it will return a value and the expressions in the method will not be evaluated. 
	If the primitive routine is not successful, the primitive 'fails', and the 
	Smalltalk expressions in the method are executed instead. These 
	expressions are evaluated as though the primitive routine had not been 
	called.  
	  
	The Smalltalk code that is evaluated when a primitive fails usually 
	anticipates why that primitive might fail. If the primitive is optional, the 
	expressions in the method do exactly what the primitive would have done (See 
	Number @). If the primitive only works on certain classes of arguments, the 
	Smalltalk code tries to coerce the argument or appeals to a superclass to find 
	a more general way of doing the operation (see SmallInteger +). If the 
	primitive is never supposed to fail, the expressions signal an error (see 
	SmallInteger asFloat).  
	  
	Each method that specifies a primitive has a comment in it. If the primitive is 
	optional, the comment will say 'Optional'. An optional primitive that is not 
	implemented always fails, and the Smalltalk expressions do the work 
	instead.  
	 
	If a primitive is not optional, the comment will say, 'Essential'. Some 
	methods will have the comment, 'No Lookup'. See Object 
	howToModifyPrimitives for an explanation of special selectors which are 
	not looked up.  
	  
	For the primitives for +, -, *, and bitShift: in SmallInteger, and truncated 
	in Float, the primitive constructs and returns a 16-bit 
	LargePositiveInteger when the result warrants it. Returning 16-bit 
	LargePositiveIntegers from these primitives instead of failing is 
	optional in the same sense that the LargePositiveInteger arithmetic 
	primitives are optional. The comments in the SmallInteger primitives say, 
	'Fails if result is not a SmallInteger', even though the implementor has the 
	option to construct a LargePositiveInteger. For further information on 
	primitives, see the 'Primitive Methods' part of the chapter on the formal 
	specification of the interpreter in the Smalltalk book."

	self error: 'comment only'! !


!Object class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:41'!
fileReaderServicesForDirectory: aFileDirectory
	"Backstop"
	^#()! !

!Object class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:30'!
fileReaderServicesForFile: fullName suffix: suffix
	"Backstop"
	^#()! !

!Object class methodsFor: 'file list services' stamp: 'md 2/15/2006 17:20'!
services
	"Backstop"
	^#()! !


!Object class methodsFor: 'instance creation' stamp: 'sw 1/23/2003 09:45'!
categoryForUniclasses
	"Answer the default system category into which to place unique-class instances"

	^ 'UserObjects'! !

!Object class methodsFor: 'instance creation' stamp: 'sw 7/28/97 15:56'!
chooseUniqueClassName
	| i className |
	i _ 1.
	[className _ (self name , i printString) asSymbol.
	 Smalltalk includesKey: className]
		whileTrue: [i _ i + 1].
	^ className! !

!Object class methodsFor: 'instance creation' stamp: 'tk 8/22/1998 08:22'!
initialInstance
	"Answer the first instance of the receiver, generate an error if there is one already"
	"self instanceCount > 0 ifTrue: [self error: 'instance(s) already exist.']."
		"Debugging test that is very slow"
	^ self new! !

!Object class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 09:30'!
initializedInstance
	^ self new! !

!Object class methodsFor: 'instance creation' stamp: 'sw 10/16/2000 10:58'!
instanceOfUniqueClass
	"Answer an instance of a unique subclass of the receiver"

	^ self instanceOfUniqueClassWithInstVarString: '' andClassInstVarString: ''! !

!Object class methodsFor: 'instance creation' stamp: 'tk 8/22/1998 08:27'!
instanceOfUniqueClassWithInstVarString: instVarString andClassInstVarString: classInstVarString
	"Create a unique class for the receiver, and answer an instance of it"

	^ (self newUniqueClassInstVars: instVarString 
		classInstVars: classInstVarString) initialInstance! !

!Object class methodsFor: 'instance creation' stamp: 'sw 10/23/1999 22:51'!
isUniClass
	^ false! !

!Object class methodsFor: 'instance creation' stamp: 'ajh 5/23/2002 00:35'!
newFrom: aSimilarObject
	"Create an object that has similar contents to aSimilarObject.
	If the classes have any instance varaibles with the same names, copy them across.
	If this is bad for a class, override this method."

	^ (self isVariable
		ifTrue: [self basicNew: aSimilarObject basicSize]
		ifFalse: [self basicNew]
	  ) copySameFrom: aSimilarObject! !

!Object class methodsFor: 'instance creation' stamp: 'tk 6/29/1998 12:11'!
newUniqueClassInstVars: instVarString classInstVars: classInstVarString
	"Create a unique class for the receiver"

	| aName aClass |
	self isSystemDefined ifFalse:
		[^ superclass newUniqueClassInstVars: instVarString classInstVars: classInstVarString].
	aName _ self chooseUniqueClassName.
	aClass _ self subclass: aName instanceVariableNames: instVarString 
		classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses.
	classInstVarString size > 0 ifTrue:
		[aClass class instanceVariableNames: classInstVarString].
	^ aClass! !

!Object class methodsFor: 'instance creation' stamp: 'sw 7/28/97 15:56'!
newUserInstance
	"Answer an instance of an appropriate class to serve as a user object in the containment hierarchy"

	^ self instanceOfUniqueClass! !

!Object class methodsFor: 'instance creation' stamp: 'nk 8/30/2004 07:57'!
readCarefullyFrom: textStringOrStream
	"Create an object based on the contents of textStringOrStream.  Return an error instead of putting up a SyntaxError window."

	| object |
	(Compiler couldEvaluate: textStringOrStream)
		ifFalse: [^ self error: 'expected String, Stream, or Text'].
	object _ Compiler evaluate: textStringOrStream for: nil 
				notifying: #error: "signal we want errors" logged: false.
	(object isKindOf: self) ifFalse: [self error: self name, ' expected'].
	^object! !

!Object class methodsFor: 'instance creation' stamp: 'nk 8/30/2004 07:57'!
readFrom: textStringOrStream
	"Create an object based on the contents of textStringOrStream."

	| object |
	(Compiler couldEvaluate: textStringOrStream)
		ifFalse: [^ self error: 'expected String, Stream, or Text'].
	object _ Compiler evaluate: textStringOrStream.
	(object isKindOf: self) ifFalse: [self error: self name, ' expected'].
	^object! !


!Object class methodsFor: 'objects from disk' stamp: 'tk 1/8/97'!
createFrom: aSmartRefStream size: varsOnDisk version: instVarList
	"Create an instance of me so objects on the disk can be read in.  Tricky part is computing the size if variable.  Inst vars will be filled in later.  "

	^ self isVariable
		ifFalse: [self basicNew]
		ifTrue: ["instVarList is names of old class's inst vars plus a version number" 
				self basicNew: (varsOnDisk - (instVarList size - 1))]
! !


!Object class methodsFor: 'window color' stamp: 'nk 6/10/2004 08:10'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference.
	This is a backstop for classes that don't otherwise define a preference."

	^ WindowColorSpec classSymbol: self name
		wording: 'Default' brightColor: #white
		pastelColor: #white
		helpMessage: 'Other windows without color preferences.'! !


!Object class methodsFor: 'private' stamp: 'mir 8/22/2001 15:20'!
releaseExternalSettings
	"Do nothing as a default"! !
AbstractHierarchicalList subclass: #ObjectExplorer
	instanceVariableNames: 'rootObject inspector monitorList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!ObjectExplorer commentStamp: '<historical>' prior: 0!
ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like:

World explore

and enjoy.!
]style[(101 13 12)f1,f3cblue;,f1!


!ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:11'!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	^ 1 to: 0  "null selection"! !

!ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:15'!
doItContext
	"Answer the context in which a text selection can be evaluated."

	^nil! !

!ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:19'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a
	text selection."

	currentSelection ifNil: [^rootObject].
	^currentSelection withoutListWrapper
! !

!ObjectExplorer methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
explorerFor: anObject
	| window listMorph |
	rootObject := anObject.
	window := (SystemWindow labelled: self label) model: self.
	window addMorph: (listMorph := SimpleHierarchicalListMorph 
			on: self
			list: #getList
			selected: #getCurrentSelection
			changeSelected: #noteNewSelection:
			menu: #genericMenu:
			keystroke: #explorerKey:from:)
		frame: (0@0 corner: 1@0.8).
	window addMorph: ((PluggableTextMorph on: self text: #trash accept: #trash:
				readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
					askBeforeDiscardingEdits: false)
		frame: (0@0.8 corner: 1@1).
	listMorph
		autoDeselect: false.
     ^ window! !

!ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:16'!
getList

	^Array with: (ObjectExplorerWrapper with: rootObject name: 'root' model: self parent: nil)
! !

!ObjectExplorer methodsFor: 'accessing' stamp: 'hg 9/7/2001 12:12'!
label

	^ rootObject printStringLimitedTo: 32! !

!ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:43'!
object
	^currentSelection ifNotNilDo: [ :cs | cs withoutListWrapper ]! !

!ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 10:02'!
parentObject
	currentSelection ifNil: [ ^nil ].
	currentSelection parent ifNil: [ ^rootObject ].
	^currentSelection parent withoutListWrapper! !

!ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:47'!
selector
	^currentSelection ifNotNilDo: [ :cs | cs selector ]! !


!ObjectExplorer methodsFor: 'error handling' stamp: 'nk 7/24/2003 09:29'!
doesNotUnderstand: aMessage
	inspector ifNotNil: [ (inspector respondsTo: aMessage selector) ifTrue: [ ^inspector perform: aMessage selector withArguments: aMessage arguments ]].
	^super doesNotUnderstand: aMessage! !


!ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'!
chasePointers
	"Open a PointerFinder on the selected item"
	| path sel savedRoot saved |
	path := OrderedCollection new.
	sel := currentSelection.
	[ sel isNil ] whileFalse: [ path addFirst: sel asString. sel := sel parent ].
	path addFirst: #openPath.
	path := path asArray.
	savedRoot := rootObject.
	saved := self object.
	[ rootObject := nil.
	self changed: #getList.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [PointerFinder on: saved]
		ifFalse: [self objectReferencesToSelection ]]
		ensure: [ rootObject := savedRoot.
			self changed: #getList.
			self changed: path.
		]! !

!ObjectExplorer methodsFor: 'menus' stamp: 'RAA 9/23/1999 13:22'!
codePaneMenu: aMenu shifted: shifted
	"Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items"
	^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted
! !

!ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'!
defsOfSelection
	"Open a browser on all defining references to the selected instance variable, if that's what's currently selected."
	| aClass sel |

	(aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash].
	sel := self selector.
	self systemNavigation  browseAllStoresInto: sel from: aClass! !

!ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'!
explorerKey: aChar from: view

	"Similar to #genericMenu:..."
	| insideObject parentObject |
	currentSelection ifNotNil: [
		insideObject := self object.
		parentObject := self parentObject.
		inspector ifNil: [inspector := Inspector new].
		inspector
			inspect: parentObject;
			object: insideObject.

		aChar == $i ifTrue: [^ self inspectSelection].
		aChar == $I ifTrue: [^ self exploreSelection].

		aChar == $b ifTrue:	[^ inspector browseMethodFull].
		aChar == $h ifTrue:	[^ inspector classHierarchy].
		aChar == $c ifTrue: [^ inspector copyName].
		aChar == $p ifTrue: [^ inspector browseFullProtocol].
		aChar == $N ifTrue: [^ inspector browseClassRefs].
		aChar == $t ifTrue: [^ inspector tearOffTile].
		aChar == $v ifTrue: [^ inspector viewerForValue]].

	^ self arrowKey: aChar from: view! !

!ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'!
exploreSelection
	"Open an ObjectExplorer on the current selection"
	self object explore! !

!ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'!
genericMenu: aMenu 
	"Borrow a menu from my inspector"
	| insideObject menu parentObject |
	currentSelection
		ifNil: [menu := aMenu.
			menu
				add: '*nothing selected*'
				target: self
				selector: #yourself]
		ifNotNil: [insideObject := self object.
			parentObject := self parentObject.
			inspector
				ifNil: [inspector := Inspector new].
			inspector inspect: parentObject;
				 object: insideObject.
			aMenu defaultTarget: inspector.
			inspector fieldListMenu: aMenu.
			aMenu items
				do: [:i | (#(#inspectSelection #exploreSelection #referencesToSelection #defsOfSelection #objectReferencesToSelection #chasePointers ) includes: i selector)
						ifTrue: [i target: self]].
			aMenu addLine;
				add: 'monitor changes'
				target: self
				selector: #monitor:
				argument: currentSelection].
	monitorList isEmptyOrNil
		ifFalse: [aMenu addLine;
				add: 'stop monitoring all'
				target: self
				selector: #stopMonitoring].
	^ aMenu! !

!ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'!
inspectSelection
	"Open an Inspector on the current selection"
	self object inspect! !

!ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:00'!
objectReferencesToSelection
	"Open a browser on all references to the selected instance variable, if that's what currently selected. "
	self systemNavigation
		browseAllObjectReferencesTo: self object
		except: (Array with: self parentObject with: currentSelection with: inspector)
		ifNone: [:obj | self changed: #flash].
! !

!ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'!
referencesToSelection
	"Open a browser on all references to the selected instance variable, if that's what's currently selected."
	| aClass sel |

	(aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash].
	sel := self selector.
	self systemNavigation browseAllAccessesTo: sel from: aClass! !

!ObjectExplorer methodsFor: 'menus' stamp: 'RAA 9/23/1999 13:19'!
selectedClass
	"Answer the class of the receiver's current selection"

	^self doItReceiver class
! !

!ObjectExplorer methodsFor: 'menus' stamp: 'RAA 9/23/1999 13:10'!
trash
	"What goes in the bottom pane"
	^ ''! !

!ObjectExplorer methodsFor: 'menus' stamp: 'RAA 9/23/1999 13:10'!
trash: newText
	"Don't save it"
	^ true! !


!ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'!
monitorList
	^monitorList ifNil: [ monitorList := WeakIdentityKeyDictionary new ].! !

!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:02'!
monitor: anObjectExplorerWrapper
	"Start stepping and watching the given wrapper for changes."
	anObjectExplorerWrapper ifNil: [ ^self ].
	self world ifNil: [ ^self ].
	self monitorList at: anObjectExplorerWrapper put: anObjectExplorerWrapper asString.
	self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 200.! !

!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'!
release
	self world ifNotNil: [ self world stopStepping: self selector: #step ].
	super release.! !

!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 17:55'!
shouldGetStepsFrom: aWorld
	^self monitorList notEmpty! !

!ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'!
step
	"If there's anything in my monitor list, see if the strings have changed."
	| string changes |
	changes := false.
	self monitorList keysAndValuesDo: [ :k :v |
		k ifNotNil: [
			k refresh.
			(string := k asString) ~= v ifTrue: [ self monitorList at: k put: string. changes := true ].
		]
	].
	changes ifTrue: [ | sel |
		sel := currentSelection.
		self changed: #getList.
		self noteNewSelection: sel.
	].
	self monitorList isEmpty ifTrue: [ ActiveWorld stopStepping: self selector: #step ].! !

!ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'!
stopMonitoring
	monitorList := nil.
	self world stopStepping: self selector: #step! !

!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'!
world
	^ActiveWorld! !


!ObjectExplorer methodsFor: 'user interface' stamp: 'stephaneducasse 9/17/2005 21:50'!
explorerFor: anObject withLabel: label 
	| window listMorph |
	rootObject := anObject.
	window := (SystemWindow labelled: label) 
				model: self.
	window
		addMorph: (listMorph := SimpleHierarchicalListMorph
						on: self
						list: #getList
						selected: #getCurrentSelection
						changeSelected: #noteNewSelection:
						menu: #genericMenu:
						keystroke: nil)
		frame: (0 @ 0 corner: 1 @ 0.8).
	window
		addMorph: ((PluggableTextMorph
				on: self
				text: #trash
				accept: #trash:
				readSelection: #contentsSelection
				menu: #codePaneMenu:shifted:)
				askBeforeDiscardingEdits: false)
		frame: (0 @ 0.8 corner: 1 @ 1).
	listMorph autoDeselect: false.
	^ window! !

!ObjectExplorer methodsFor: 'user interface' stamp: 'RAA 6/2/2000 16:23'!
initialExtent

	^300@500! !

!ObjectExplorer methodsFor: 'user interface' stamp: 'ar 9/27/2005 20:31'!
openBrowser: aClass

	ToolSet browse: aClass selector: nil! !

!ObjectExplorer methodsFor: 'user interface' stamp: 'RAA 6/2/2000 16:24'!
openExplorerFor: anObject
"
ObjectExplorer new openExplorerFor: Smalltalk
"

    (self explorerFor: anObject) openInWorld.
    ^ self
! !

!ObjectExplorer methodsFor: 'user interface' stamp: 'stephaneducasse 9/17/2005 21:51'!
openExplorerFor: anObject withLabel: label 
     "ObjectExplorer new openExplorerFor: Smalltalk withLabel: 'Smalltalk'"

	(self explorerFor: anObject withLabel: label)
openInWorld! !

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

ObjectExplorer class
	instanceVariableNames: ''!

!ObjectExplorer class methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:55'!
about

	StringHolder new textContents: self comment; openLabel: 'about ',self asString! !
ListItemWrapper subclass: #ObjectExplorerWrapper
	instanceVariableNames: 'itemName parent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!
!ObjectExplorerWrapper commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:48'!
canBeDragged

	^false! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'!
parent
	^parent! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'!
parent: anObject
	parent _ anObject! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:49'!
selector
	parent ifNil: [ ^nil ].
	^(parent withoutListWrapper class allInstVarNames includes: itemName) ifTrue: [ itemName asSymbol ]! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 10:49'!
setItem: anObject name: aString model: aModel

	item _ anObject.
	model _ aModel.
	itemName _ aString.! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'!
setItem: anObject name: aString model: aModel parent: itemParent
	parent _ itemParent.
	self setItem: anObject name: aString model: aModel! !


!ObjectExplorerWrapper methodsFor: 'converting' stamp: 'edt 5/26/2003 12:36'!
asString
	| explorerString string |
	explorerString _ 
		[item asExplorerString]
			on: Error 
			do: ['<error: ', item class name, ' in asExplorerString: evaluate "' , itemName , ' asExplorerString" to debug>'].
	string _ (itemName ifNotNil: [itemName , ': '] ifNil: ['']) , explorerString.
	(string includes: Character cr)
		ifTrue: [^ string withSeparatorsCompacted].
	^ string! !

!ObjectExplorerWrapper methodsFor: 'converting' stamp: 'nk 7/24/2003 10:16'!
itemName
	^itemName! !


!ObjectExplorerWrapper methodsFor: 'monitoring' stamp: 'nk 7/12/2003 18:28'!
refresh
	"hack to refresh item given an object and a string that is either an index or an instance variable name."
	[ | index |
		(model class allInstVarNames includes: itemName)
			ifTrue: [ item _ model instVarNamed: itemName ]
			ifFalse: [ index _ itemName asNumber.
				(index between: 1 and: model basicSize) ifTrue: [ item _ model basicAt: index]]
	] on: Error do: [ :ex | item _ nil ]! !


!ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:17'!
contents

	(item respondsTo: #explorerContents) ifTrue: [^item explorerContents].
	"For all others, show named vars first, then indexed vars"
	^(item class allInstVarNames asOrderedCollection withIndexCollect: [:each :index |
		self class
			with: (item instVarAt: index)
			name: each
			model: item
			parent: self]) ,
	((1 to: item basicSize) collect: [:index |
		self class
			with: (item basicAt: index)
			name: index printString
			model: item
			parent: self])! !

!ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'RAA 6/21/1999 11:27'!
hasContents

	^item hasContentsInExplorer
	
! !

!ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:34'!
icon
	"Answer a form to be used as icon"
	^ Preferences visualExplorer
		ifTrue: [item iconOrThumbnailOfSize: 16]
		ifFalse: [nil]! !

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

ObjectExplorerWrapper class
	instanceVariableNames: ''!

!ObjectExplorerWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 10:50'!
with: anObject name: aString model: aModel

	^self new 
		setItem: anObject name: aString model: aModel! !

!ObjectExplorerWrapper class methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:16'!
with: anObject name: aString model: aModel parent: aParent

	^self new 
		setItem: anObject name: aString model: aModel parent: aParent
! !
Object subclass: #ObjectFinalizer
	instanceVariableNames: 'receiver selector arguments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Finalization'!

!ObjectFinalizer methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:13'!
finalize
	"Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority."
	[receiver perform: selector withArguments: arguments] 
		on: Error do:[:ex| ex return].
! !


!ObjectFinalizer methodsFor: 'initialize' stamp: 'ar 5/19/2003 20:12'!
receiver: aReceiver selector: aSelector argument: anObject
	receiver := aReceiver.
	selector := aSelector.
	arguments := Array with: anObject! !
TestCase subclass: #ObjectFinalizerTests
	instanceVariableNames: 'log'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Finalization'!

!ObjectFinalizerTests methodsFor: 'finalization handling' stamp: 'apb 9/14/2005 08:33'!
finalize: anObject
	log addLast: anObject asString, ' ', 'finalized'.! !


!ObjectFinalizerTests methodsFor: 'running' stamp: 'apb 9/14/2005 08:39'!
setUp
	super setUp.
	log := OrderedCollection new.! !


!ObjectFinalizerTests methodsFor: 'tests' stamp: 'stephaneducasse 10/28/2005 21:15'!
testFinalization
	"self run: #testFinalization"
	
	| repetitions |
	repetitions := 100.
	1 to: repetitions
		do: [:i | 
			log addLast: 'o' , i asString , ' created'.
			Object new
				toFinalizeSend: #finalize:
				to: self
				with: 'o' , i asString].
	Smalltalk garbageCollect.
	self finalizationRegistry finalizeValues.
	1 to: repetitions
		do: [:i | 
			self assert: (log includes: 'o' , i asString , ' created').
			self assert: (log includes: 'o' , i asString , ' finalized')]! !

!ObjectFinalizerTests methodsFor: 'tests' stamp: 'stephaneducasse 10/28/2005 21:15'!
testFinalizationOfEquals
	"self run: #testFinalizationOfEquals"
	
	| bag o |
	bag := IdentityBag new.
	1 to: 5 do: [:n | o := n asString copy. bag add: n. o toFinalizeSend: #remove: to: bag with: n].
	1 to: 5 do: [:n | o := n asString copy. bag add: n. o toFinalizeSend: #remove: to: bag with: n].
	Smalltalk garbageCollect.
	1 to: 5 do: [:n | self deny: (bag includes: n)]
! !
ProtoObject subclass: #ObjectOut
	instanceVariableNames: 'url page recursionFlag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!ObjectOut commentStamp: '<historical>' prior: 0!
I am a stand-in for an object that is out on the disk.  The object that is out on the disk is the head of a tree of objects that are out.  See SqueakPage.

When any message is sent to me, I don't understand it, and bring in my true object.  I become myself with the objects and resend the message.  

I may not represent the object nil.  
The file is represented as a url, and that url may point at any file on the net.  

page is a SqueakPage.
If the cache already has an object, widely in use, that claims to be the object for my url, what do I do?  I can't become him, since others believe that he is the true object.  Run through memory and replace refs to me with refs to him.  Be careful not to trigger a fault.  Become me to a string, then find pointers and replace?

[[[They don't want to end up holding an ObjectOut.  (would oscillate back and forth)  This is a problem.  A user could bring in two trees that both refer to a 3rd url.  (check with cache before installing any new ObjectOut) Two trees could be written to the same url.
Or, I remain an ObjectOut, and keep getting notUnderstood, and keep returning the other guy.
Or I smash the cache, and install MY page and object.  Other guy is a copy -- still in, but with no place in the cache.  When we both write to the same url, there will be trouble.]  No -- search and replace.]]]
!


!ObjectOut methodsFor: 'access' stamp: 'tk 1/15/1999 11:43'!
url: aString

	url _ aString! !

!ObjectOut methodsFor: 'access' stamp: 'tk 12/18/1998 21:29'!
xxxReset
	"mark as never brought in"
	recursionFlag _ nil! !


!ObjectOut methodsFor: 'basics' stamp: 'tk 10/30/1998 15:11'!
isInMemory
	"We are a place holder for an object that is out."
	^ false! !

!ObjectOut methodsFor: 'basics' stamp: 'tk 10/21/1998 12:28'!
xxxClass
	"Primitive. Answer the object which is the receiver's class. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 111>
	self primitiveFailed! !

!ObjectOut methodsFor: 'basics' stamp: 'tk 10/22/1998 15:31'!
xxxClone

	<primitive: 148>
	self primitiveFailed! !

!ObjectOut methodsFor: 'basics' stamp: 'tk 10/22/1998 15:19'!
xxxInstVarAt: index 
	"Primitive. Answer a fixed variable in an object. The numbering of the 
	variables corresponds to the named instance variables. Fail if the index 
	is not an Integer or is not the index of a fixed variable. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 73>
	self primitiveFailed ! !

!ObjectOut methodsFor: 'basics' stamp: 'tk 10/22/1998 14:39'!
xxxInstVarAt: anInteger put: anObject 
	"Primitive. Store a value into a fixed variable in the receiver. The 
	numbering of the variables corresponds to the named instance variables. 
	Fail if the index is not an Integer or is not the index of a fixed variable. 
	Answer the value stored as the result. Using this message violates the 
	principle that each object has sovereign control over the storing of 
	values into its instance variables. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 74>
	self primitiveFailed ! !


!ObjectOut methodsFor: 'fetch from disk' stamp: 'rbb 2/18/2005 14:55'!
doesNotUnderstand: aMessage 
	"Bring in the object, install, then resend aMessage"
	| realObject oldFlag response |
	oldFlag _ recursionFlag.
	recursionFlag _ true.
	"fetch the object"
	realObject _ self xxxFetch.		"watch out for the become!!"
			"Now we ARE the realObject"
	oldFlag == true ifTrue: [
		response _ (UIManager default chooseFrom: #('proceed normally' 'debug')
			title: 'Object being fetched for a second time.
Should not happen, and needs to be fixed later.').
		response = 2 ifTrue: [self halt]].	"We are already the new object"

	"Can't be a super message, since this is the first message sent to this object"
	^ realObject perform: aMessage selector withArguments: aMessage arguments! !

!ObjectOut methodsFor: 'fetch from disk' stamp: 'tk 11/16/1998 09:57'!
xxxFetch
	"Bring in my object and replace all references to me with references to him.  First try looking up my url in the pageCache.  Then try the page (and install it, under its url).  Then start from scratch with the url."

	| truePage object existing |
	existing _ SqueakPageCache pageCache at: url ifAbsent: [nil].
	existing ifNotNil: [existing isContentsInMemory
		ifTrue: [page _ truePage _ existing]].	"This url already has an object in this image"
	truePage ifNil: [
		truePage _ SqueakPageCache atURL: url oldPage: page].
	object _ truePage isContentsInMemory 
		ifTrue: [truePage contentsMorph]
		ifFalse: [truePage fetchInformIfError].	"contents, not the page"
			"Later, collect pointers to object and fix them up.  Not scan memory"
	object ifNil: [^ 'Object could not be fetched.'].
	"recursionFlag _ false."  	"while I still have a pointer to myself"
	truePage contentsMorph: object.
	page _ truePage.
	self xxxFixup.
	^ object	"the final object!!"
 ! !

!ObjectOut methodsFor: 'fetch from disk' stamp: 'ar 9/27/2005 18:03'!
xxxFixup
	"There is already an object in memory for my url.  All pointers to me need to be pointers to him.  Can't use become, because other pointers to him must stay valid."

	| real temp list |
	real := page contentsMorph.
	real == self ifTrue: [page error: 'should be converted by now'].
	temp := self.
	list := (Utilities pointersTo: temp) asOrderedCollection.
	list add: thisContext.  list add: thisContext sender.
	list do: [:holder |
		1 to: holder class instSize do:
			[:i | (holder instVarAt: i) == temp ifTrue: [holder instVarAt: i put: real]].
		1 to: holder basicSize do:
			[:i | (holder basicAt: i) == temp ifTrue: [holder basicAt: i put: real]].
		].
	^ real! !

!ObjectOut methodsFor: 'fetch from disk' stamp: 'tk 10/21/1998 13:01'!
xxxSetUrl: aString page: aSqkPage

	url _ aString.
	page _ aSqkPage.! !


!ObjectOut methodsFor: 'object storage' stamp: 'tk 2/17/2000 22:21'!
comeFullyUpOnReload: smartRefStream
	"Normally this read-in object is exactly what we want to store.  Try to dock first.  If it is here already, use that one."

	| sp |
	"Transcript show: 'has ref to: ', url; cr."
	(sp _ SqueakPageCache pageCache at: page ifAbsent: [nil]) ifNotNil: [
		sp isContentsInMemory ifTrue: [^ sp contentsMorph]].
	^ self! !

!ObjectOut methodsFor: 'object storage' stamp: 'tk 2/24/1999 11:14'!
objectForDataStream: refStrm
    "Return an object to store on a data stream (externalize myself)."

    ^ self! !

!ObjectOut methodsFor: 'object storage' stamp: 'tk 10/22/1998 14:37'!
readDataFrom: aDataStream size: varsOnDisk
	"Make self be an object based on the contents of aDataStream, which was generated by the object's storeDataOn: method. Return self."
	| cntInstVars |
	cntInstVars _ self xxxClass instSize.
	self xxxClass isVariable
		ifTrue: [self xxxClass error: 'needs updating']	"assume no variable subclasses"
		ifFalse: [cntInstVars _ varsOnDisk].

	aDataStream beginReference: self.
	1 to: cntInstVars do:
		[:i | self xxxInstVarAt: i put: aDataStream next].
"	1 to: cntIndexedVars do:
		[:i | self basicAt: i put: aDataStream next].
"
	^ self! !

!ObjectOut methodsFor: 'object storage' stamp: 'tk 10/22/1998 15:18'!
storeDataOn: aDataStream
	"Store myself on a DataStream. See also objectToStoreOnDataStream.
	must send 'aDataStream beginInstance:size:'"
	| cntInstVars |

	cntInstVars _ self class instSize.
	"cntIndexedVars _ self basicSize."
	aDataStream
		beginInstance: self xxxClass
		size: cntInstVars "+ cntIndexedVars".
	1 to: cntInstVars do:
		[:i | aDataStream nextPut: (self xxxInstVarAt: i)].
"	1 to: cntIndexedVars do:
		[:i | aDataStream nextPut: (self basicAt: i)]
"! !

!ObjectOut methodsFor: 'object storage' stamp: 'tk 10/22/1998 15:29'!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
	| class index sub subAss new absent |
	new _ deepCopier references at: self ifAbsent: [absent _ true].
	absent ifNil: [^ new].	"already done"
	class _ self xxxClass.
	class isMeta ifTrue: [^ self].		"a class"
	new _ self xxxClone.
	"not a uniClass"
	deepCopier references at: self put: new.	"remember"
	"class is not variable"
	index _ class instSize.
	[index > 0] whileTrue: 
		[sub _ self xxxInstVarAt: index.
		(subAss _ deepCopier references associationAt: sub ifAbsent: [nil])
			ifNil: [new xxxInstVarAt: index put: (sub veryDeepCopyWith: deepCopier)]
			ifNotNil: [new xxxInstVarAt: index put: subAss value].
		index _ index - 1].
	new rehash.	"force Sets and Dictionaries to rehash"
	^ new
! !


!ObjectOut methodsFor: '*MorphicExtras-access' stamp: 'tk 12/4/1998 13:01'!
sqkPage
	^ page! !

!ObjectOut methodsFor: '*MorphicExtras-access' stamp: 'tk 12/4/1998 13:01'!
url
	^ url! !

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

ObjectOut class
	instanceVariableNames: ''!
GenericPropertiesMorph subclass: #ObjectPropertiesMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:04'!
adjustTargetBorderWidth: aFractionalPoint

	| n |

	myTarget borderWidth: (n _ (aFractionalPoint x * 10) rounded max: 0).
	self showSliderFeedback: n.! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:02'!
adjustTargetGradientDirection: aFractionalPoint

	| fs p |

	(fs _ myTarget fillStyle) isGradientFill ifFalse: [^self].
	fs direction: (p _ (aFractionalPoint * myTarget extent) rounded).
	self showSliderFeedback: p.
	myTarget changed.
! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:05'!
adjustTargetGradientOrigin: aFractionalPoint

	| fs p |

	(fs _ myTarget fillStyle) isGradientFill ifFalse: [^self].
	fs origin: (p _ myTarget topLeft + (aFractionalPoint * myTarget extent) rounded).
	self showSliderFeedback: p.
	myTarget changed.
! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'!
adjustTargetShadowOffset: aFractionalPoint

	| n |

	myTarget changed; layoutChanged.
	myTarget shadowOffset: (n _ (aFractionalPoint * 4) rounded).
	self showSliderFeedback: n.
	myTarget changed; layoutChanged.
! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'!
doEnables

	| itsName fs |

	fs _ myTarget fillStyle.
	self allMorphsDo: [ :each |
		itsName _ each knownName.
		itsName == #pickerForColor ifTrue: [
			self enable: each when: fs isSolidFill | fs isGradientFill
		].
		itsName == #pickerForBorderColor ifTrue: [
			self enable: each when: (myTarget respondsTo: #borderColor:)
		].
		itsName == #pickerForShadowColor ifTrue: [
			self enable: each when: myTarget hasDropShadow
		].
		itsName == #pickerFor2ndGradientColor ifTrue: [
			self enable: each when: fs isGradientFill
		].
	].
! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'!
makeTargetGradientFill

	myTarget useGradientFill! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:02'!
makeTargetSolidFill

	myTarget useSolidFill! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:04'!
numberOneColor

	myTarget fillStyle isGradientFill ifFalse: [^myTarget color].
	^myTarget fillStyle colorRamp first value
! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'gm 2/16/2003 20:36'!
numberOneColor: aColor 
	myTarget fillStyle isGradientFill 
		ifFalse: 
			[^(myTarget isSystemWindow) 
				ifTrue: [myTarget setWindowColor: aColor]
				ifFalse: [myTarget fillStyle: aColor]].
	myTarget fillStyle 
		firstColor: aColor
		forMorph: myTarget
		hand: nil! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 19:35'!
rebuild

	self removeAllMorphs.
	self addARow: {
		self lockedString: ('Properties for {1}' translated format: {myTarget name}).
	}.
	self addARow: {
		self inAColumn: {
			self paneForCornerRoundingToggle.
			self paneForStickinessToggle.
			self paneForLockedToggle.
		}.
	}.

	self addARow: {
		self paneForMainColorPicker.
		self paneFor2ndGradientColorPicker.
	}.
	self addARow: {
		self paneForBorderColorPicker.
		self paneForShadowColorPicker.
	}.

	self addARow: {
		self 
			buttonNamed: 'Accept' translated action: #doAccept color: color lighter 
			help: 'keep changes made and close panel' translated.
		self 
			buttonNamed: 'Cancel' translated action: #doCancel color: color lighter 
			help: 'cancel changes made and close panel' translated.
	}, self rebuildOptionalButtons.

	thingsToRevert _ Dictionary new.
	"thingsToRevert at: #fillStyle: put: myTarget fillStyle."
	myTarget isSystemWindow ifTrue: [
		thingsToRevert at: #setWindowColor: put: myTarget paneColorToUse
	].
	thingsToRevert at: #hasDropShadow: put: myTarget hasDropShadow.
	thingsToRevert at: #shadowColor: put: myTarget shadowColor.
	(myTarget respondsTo: #borderColor:) ifTrue: [
		thingsToRevert at: #borderColor: put: myTarget borderColor.
	].

	thingsToRevert at: #borderWidth: put: myTarget borderWidth.
	thingsToRevert at: #cornerStyle: put: myTarget cornerStyle.
	thingsToRevert at: #sticky: put: myTarget isSticky.
	thingsToRevert at: #lock: put: myTarget isLocked.
! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'wiz 9/21/2005 22:42'!
rebuildOptionalButtons

	| answer |

	answer _ #() .
	
	myTarget isTextMorph ifTrue: [
		answer _ answer, {
			self 
				buttonNamed: 'Text' translated action: #doTextProperties color: color lighter 
				help: 'open a text properties panel for the morph' translated.
		}.
	].
	^answer! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/25/2001 18:30'!
targetBorderColor
	^myTarget borderStyle baseColor! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/26/2001 15:29'!
targetBorderColor: aColor
	"Need to replace the borderStyle or BorderedMorph will not 'feel' the change"
	myTarget borderStyle: (myTarget borderStyle copy baseColor: aColor).! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:04'!
targetHasGradientFill

	^myTarget fillStyle isGradientFill! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:01'!
targetHasSolidFill

	^myTarget fillStyle isSolidFill! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'!
targetRadial

	myTarget fillStyle isGradientFill ifFalse: [^false].
	^myTarget fillStyle radial! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'!
tgt2ndGradientColor

	myTarget fillStyle isGradientFill ifFalse: [^Color black].
	^myTarget fillStyle colorRamp last value! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'!
tgt2ndGradientColor: aColor

	myTarget fillStyle lastColor: aColor forMorph: myTarget hand: nil
! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:45'!
toggleTargetGradientFill

	self targetHasGradientFill ifTrue: [
		self makeTargetSolidFill
	] ifFalse: [
		self makeTargetGradientFill
	].
	self doEnables! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:02'!
toggleTargetRadial

	| fs |

	(fs _ myTarget fillStyle) isGradientFill ifFalse: [^self].
	fs radial: fs radial not.
	myTarget changed.
	self doEnables.! !

!ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:48'!
toggleTargetSolidFill

	self targetHasSolidFill ifTrue: [
		self makeTargetGradientFill
	] ifFalse: [
		self makeTargetSolidFill
	].
	self doEnables! !


!ObjectPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:44'!
defaultBorderColor
"answer the default border color/fill style for the receiver"
	^ self defaultColor darker! !

!ObjectPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:44'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.548
		g: 0.839
		b: 0.452! !

!ObjectPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:44'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	myTarget
		ifNil: [myTarget _ RectangleMorph new openInWorld].
	self rebuild! !


!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'sd 11/13/2003 21:03'!
borderPrototype: aBorderStyle help: helpString
	| selector proto |
	selector _ BorderedMorph new.
	selector borderWidth: 0.
	selector color: Color transparent.
	proto _ Morph new extent: 16@16.
	proto color:  Color transparent.
	proto borderStyle: aBorderStyle.
	selector extent: proto extent + 4.
	selector addMorphCentered: proto.
	(myTarget canDrawBorder: aBorderStyle) ifTrue:[
		selector setBalloonText: helpString.
		selector on: #mouseDown send: #toggleBorderStyle:with:from: to: self withValue: proto.
		(myTarget borderStyle species == aBorderStyle species and:[
			myTarget borderStyle style == aBorderStyle style]) ifTrue:[selector borderWidth: 1].
	] ifFalse:[
		selector setBalloonText: 'This border style cannot be used here' translated.
		selector on: #mouseDown send: #beep to: Beeper.
		selector addMorphCentered: ((Morph new) color: (Color black alpha: 0.5); extent: selector extent).
	].
	^selector! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:21'!
paneFor2ndGradientColorPicker

	^self 
		inAColumn: {
			(self inAColumn: {
				self colorPickerFor: self getter: #tgt2ndGradientColor setter: #tgt2ndGradientColor:.
				self lockedString: '2nd gradient color' translated.
				self paneForRadialGradientToggle hResizing: #shrinkWrap.
				(
					self inARow: {self paneForGradientOrigin. self paneForGradientDirection}
				) hResizing: #shrinkWrap.
			}
			named: #pickerFor2ndGradientColor) layoutInset: 0.
			self paneForGradientFillToggle hResizing: #shrinkWrap 
		}
! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:23'!
paneForBorderColorPicker

	^self 
		inAColumn: {
			self 
				colorPickerFor: self
				getter: #targetBorderColor
				setter: #targetBorderColor:.
			self lockedString: 'Border Color' translated.
			(self paneForBorderStyle) hResizing: #shrinkWrap; layoutInset: 5.
			self lockedString: 'Border style' translated.
			self paneForBorderWidth.
		} 
		named: #pickerForBorderColor.

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:25'!
paneForBorderStyle

	^self inARow: {
		self borderPrototype: (BorderStyle width: 4 color: Color black)
			help:'Click to select a simple colored border' translated.
		self borderPrototype: (BorderStyle raised width: 4)
			help:'Click to select a simple raised border' translated.
		self borderPrototype: (BorderStyle inset width: 4)
			help:'Click to select a simple inset border' translated.
		self borderPrototype: (BorderStyle complexFramed width: 4)
			help:'Click to select a complex framed border' translated.
		self borderPrototype: (BorderStyle complexRaised width: 4)
			help:'Click to select a complex raised border' translated.
		self borderPrototype: (BorderStyle complexInset width: 4)
			help:'Click to select a complex inset border' translated.
		self borderPrototype: (BorderStyle complexAltFramed width: 4)
			help:'Click to select a complex framed border' translated.
		self borderPrototype: (BorderStyle complexAltRaised width: 4)
			help:'Click to select a complex raised border' translated.
		self borderPrototype: (BorderStyle complexAltInset width: 4)
			help:'Click to select a complex inset border' translated.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:29'!
paneForBorderWidth

	^(self inARow: {
		self
			buildFakeSlider: 'Border width' translated
			selector: #adjustTargetBorderWidth:
			help: 'Drag in here to change the border width' translated
	}) hResizing: #shrinkWrap

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:18'!
paneForCornerRoundingToggle

	^self inARow: {
		self
			directToggleButtonFor: myTarget 
			getter: #wantsRoundedCorners setter: #toggleCornerRounding
			help: 'Turn rounded corners on or off' translated.
		self lockedString: ' Rounded corners' translated.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:40'!
paneForDropShadowToggle

	^self inARow: {
		self
			directToggleButtonFor: myTarget 
			getter: #hasDropShadow setter: #toggleDropShadow
			help: 'Turn drop shadows on or off' translated.
		self lockedString: ' Drop shadow color' translated.
	}
! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:22'!
paneForGradientDirection

	^(self inARow: {
		self
			buildFakeSlider: 'Direction' translated
			selector: #adjustTargetGradientDirection:
			help: 'Drag in here to change the direction of the gradient' translated
	}) hResizing: #shrinkWrap

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:22'!
paneForGradientFillToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetHasGradientFill
			setter: #toggleTargetGradientFill
			help: 'Turn gradient fill on or off' translated.
		self lockedString: ' Gradient fill' translated.
	}
! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:21'!
paneForGradientOrigin

	^(self inARow: {
		self
			buildFakeSlider: 'Origin' translated
			selector: #adjustTargetGradientOrigin:
			help: 'Drag in here to change the origin of the gradient' translated
	}) hResizing: #shrinkWrap

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:19'!
paneForLockedToggle

	^self inARow: {
		self
			directToggleButtonFor: myTarget 
			getter: #isLocked setter: #toggleLocked
			help: 'Turn lock on or off' translated.
		self lockedString: ' Lock' translated.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:20'!
paneForMainColorPicker

	^self 
		inAColumn: {
			self 
				colorPickerFor: self 
				getter: #numberOneColor 
				setter: #numberOneColor:.
			self lockedString: 'Color' translated.
			(self paneForSolidFillToggle)  hResizing: #shrinkWrap.
		} 
		named: #pickerForColor.

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:21'!
paneForRadialGradientToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetRadial setter: #toggleTargetRadial
			help: 'Turn radial gradient on or off' translated.
		self lockedString: ' Radial gradient' translated.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'RAA 3/8/2001 18:03'!
paneForShadowColorPicker

	^self 
		inAColumn: {
			(self inAColumn: {
				self colorPickerFor: myTarget getter: #shadowColor setter: #shadowColor:.
				self paneForShadowOffset.
			}
			named: #pickerForShadowColor) layoutInset: 0.
			self paneForDropShadowToggle hResizing: #shrinkWrap.
		}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:36'!
paneForShadowOffset

	^(self inARow: {
		self
			buildFakeSlider: 'Offset' translated
			selector: #adjustTargetShadowOffset:
			help: 'Drag in here to change the offset of the shadow' translated
	}) hResizing: #shrinkWrap

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:20'!
paneForSolidFillToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetHasSolidFill
			setter: #toggleTargetSolidFill
			help: 'Turn solid fill on or off' translated.
		self lockedString: ' Solid fill' translated.
	}
! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:18'!
paneForStickinessToggle

	^self inARow: {
		self
			directToggleButtonFor: myTarget 
			getter: #isSticky setter: #toggleStickiness
			help: 'Turn stickiness on or off' translated.
		self lockedString: ' Sticky' translated.
	}

! !

!ObjectPropertiesMorph methodsFor: 'panes' stamp: 'ar 8/25/2001 18:35'!
toggleBorderStyle: provider with: arg1 from: arg2
	| oldStyle newStyle |
	oldStyle _ myTarget borderStyle.
	newStyle _ provider borderStyle copy.
	oldStyle width = 0 
		ifTrue:[newStyle width: 2]
		ifFalse:[newStyle width: oldStyle width].
	newStyle baseColor: oldStyle baseColor.
	myTarget borderStyle: newStyle.
	provider owner owner submorphsDo:[:m| m borderWidth: 0].
	provider owner borderWidth: 1.! !
AlignmentMorph subclass: #ObjectRepresentativeMorph
	instanceVariableNames: 'objectRepresented'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!

!ObjectRepresentativeMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/1/2000 15:55'!
objectRepresented: anObject
	"Set the receiver's representee.  This clears out any preexisting state in the receiver"

	objectRepresented _ anObject.
	self removeAllMorphs.
	self hResizing: #shrinkWrap.  
	self vResizing: #shrinkWrap.
	self addMorphBack: (StringMorph new contents: anObject name asString).
	self setNameTo: anObject name
	! !

!ObjectRepresentativeMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/1/2000 15:55'!
objectRepresented: anObject labelString: aLabel
	"Set the receiver's representee as indicated, and use the given label to tag it"

	objectRepresented _ anObject.
	self removeAllMorphs.
	self hResizing: #shrinkWrap.  
	self vResizing: #shrinkWrap.
	self addMorphBack: (StringMorph new contents: aLabel asString).
	self setNameTo: aLabel asString
	! !


!ObjectRepresentativeMorph methodsFor: 'macpal' stamp: 'sw 10/17/2000 11:42'!
objectRepresented
	"Answer the object represented by the receiver"

	^ objectRepresented! !


!ObjectRepresentativeMorph methodsFor: 'naming' stamp: 'sw 10/31/2000 09:22'!
nameOfObjectRepresented
	"Answer the external name of the object represented"

	^ objectRepresented externalName! !


!ObjectRepresentativeMorph methodsFor: 'scripting' stamp: 'sw 10/17/2000 11:35'!
categoriesForViewer
	"Answer a list of symbols representing the categories to offer in the viewer, in order"

	^ objectRepresented class organization categories
! !
Object subclass: #ObjectScanner
	instanceVariableNames: 'pvt3SmartRefStrm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Storage'!
!ObjectScanner commentStamp: '<historical>' prior: 0!
An instance of this class is the compiler's context for filing in a SmartRefStream containing instance-specific classes.  When the old name of a new object's class conflicts with an existing class name, install a class var in me.  It has the old name but points at the new class.  The compiler uses it when compiling the code in the fileIn.  Fill the SmartRefStream's renamed class dictionary.

An object fileout:
!!ObjectScanner new initialize!!      "allow me to take control with scanFrom:"

Player subclass: Player23 instanceVariableNames: 'foo' classVariableNames: '' 
	poolDictionaries: nil category: 'Instance Specific'!!
	"I prescan this and (self rename: #Player23 toBe: #Player30)"

!!Player23 methodsFor: 'all' stamp: 'tk 3/9/98 18:58'!!	"actually sent to Player30"
foo
	^ foo!! !!

!!self smartRefStream!!<binary representation of the objects>!!


!


!ObjectScanner methodsFor: 'accessing' stamp: 'tk 3/15/98 19:33'!
smartRefStream

	^ pvt3SmartRefStrm! !


!ObjectScanner methodsFor: 'initialize-release' stamp: 'tk 3/15/98 20:17'!
clear
	"remove all old class vars.  They were UniClasses being remapped to aviod a name conflict."

	self class classPool keys do: [:key |
		self class classPool removeKey: key].	"brute force"! !

!ObjectScanner methodsFor: 'initialize-release' stamp: 'tk 8/15/1998 15:26'!
initialize
	"remove all old class vars that are not instance-specific classes being renamed"

	self clear.
	"Most importantly, return self, so a fileIn will let ObjectScanner seize control.  So UniClasses can be remapped.  See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! !


!ObjectScanner methodsFor: 'scanning' stamp: 'yo 11/11/2002 10:27'!
lookAhead: aChunk
	"See if this chunk is a class Definition, and if the new class name already exists and is instance-specific.  Modify the chunk, and record the rename in the SmartRefStream and in me."

	| pieces sup oldName existing newName newDefn |
	aChunk size < 90 ifTrue: [^ aChunk].		"class defn is big!!"
	(aChunk at: 1) == $!! ifTrue: [^ aChunk].	"method def, fast exit"
	pieces _ (aChunk copyFrom: 1 to: (300 min: aChunk size)) findTokens: ' #	\' withCRs.
	pieces size < 3 ifTrue: [^ aChunk].	"really bigger, but just took front"
	(pieces at: 2) = 'subclass:' ifFalse: [^ aChunk].
	sup _ Smalltalk at: (pieces at: 1) asSymbol ifAbsent: [^ aChunk].
	sup class class == Metaclass ifFalse: [^ aChunk].
	((oldName _ pieces at: 3) at: 1) canBeGlobalVarInitial ifFalse: [^ aChunk].
	oldName _ oldName asSymbol.
	(Smalltalk includesKey: oldName) ifFalse: [^ aChunk].	"no conflict"
	existing _ Smalltalk at: oldName.
	(existing isKindOf: Class) ifFalse: [^ aChunk].	"Write over non-class global"
	existing isSystemDefined ifTrue: [^ aChunk].	"Go ahead and redefine it!!"
	"Is a UniClass"
	newName _ sup chooseUniqueClassName.
	newDefn _ aChunk copyReplaceAll: oldName with: newName.
	Compiler evaluate: newDefn for: self logged: true.	"Create the new class"
	self rename: oldName toBe: newName.
	^ newName asString		"to be evaluated"
! !

!ObjectScanner methodsFor: 'scanning' stamp: 'tk 3/15/98 20:22'!
scanFrom: aByteStream
	"Sieze control of the fileIn.  Put myself in as the context.  If any UniClasses (for just one instance) are defined, they will do it through me, and I will look for conflicting class names.  If so, install the old name as a class var of me, so the compile will work.  Tell my SmartRefStream about renaming the class."

	| valWithOddName47 scannerNamed53 chunkNamed117 |
	pvt3SmartRefStrm _ SmartRefStream on: aByteStream.
	aByteStream ascii.
	[aByteStream atEnd] whileFalse:
		[aByteStream skipSeparators.
		valWithOddName47 _ (aByteStream peekFor: $!!)
			ifTrue: [chunkNamed117 _ aByteStream nextChunk.	"debug"
					scannerNamed53 _ Compiler evaluate: chunkNamed117
							for: self logged: false.
					scannerNamed53 class == self class 
						ifTrue: ["I already am the scanner for this file"]
						ifFalse: [scannerNamed53 scanFrom: aByteStream]]
			ifFalse: [chunkNamed117 _ aByteStream nextChunk.
					chunkNamed117 _ self lookAhead: chunkNamed117.
					Compiler evaluate: chunkNamed117 for: self logged: true].
		aByteStream skipStyleChunk].
	^ valWithOddName47! !


!ObjectScanner methodsFor: 'utilities' stamp: 'tk 3/15/98 20:21'!
rename: existingName toBe: newName
	"See if there is a conflict between what the fileIn wants to call the new UniClass (Player23) and what already exists for another unique instance.  If conflict, make a class variable to intercept the existingName and direct it to class newName."

	existingName = newName ifFalse: [
		self class ensureClassPool.	"create the dictionary"
		"can't use addClassVarName: because it checks for conflicts with Smalltalk"
		(self class classPool includesKey: existingName) ifFalse: 
			["Pick up any refs in Undeclared"
			self class classPool declare: existingName from: Undeclared].
		self class classPool at: existingName put: (Smalltalk at: newName).
		pvt3SmartRefStrm renamed at: existingName put: newName]! !
Stream subclass: #ObjectSocket
	instanceVariableNames: 'socket outBuf outBufIndex outBufSize inBuf inBufIndex inBufLastIndex outObjects inObjects'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Network-ObjectSocket'!
!ObjectSocket commentStamp: 'ls 2/10/2005 21:27' prior: 0!
This is a socket which exchanges medium-level packets instead of low-level bytes.  This class is abstract; see the subclasses for particular kinds of medium-level packets which can be used.!


!ObjectSocket methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
destroy
	socket destroy.
	socket := nil.! !

!ObjectSocket methodsFor: 'as yet unclassified' stamp: 'RAA 7/20/2000 15:10'!
isConnected

	^socket notNil and: [socket isConnected]! !

!ObjectSocket methodsFor: 'as yet unclassified' stamp: 'ls 1/8/1999 16:14'!
processIO
	"do some as much network IO as possible"

	self processOutput.
	self processInput.! !

!ObjectSocket methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 15:38'!
remoteAddress

	self isConnected ifFalse: [^nil].
	^socket remoteAddress! !


!ObjectSocket methodsFor: 'encoding/decoding' stamp: 'sd 11/20/2005 21:26'!
addToInBuf: aString

	| newAlloc |
	newAlloc := aString size * 2 max: 8000.
	inBuf ifNil: [
		inBuf := String new: newAlloc.
		inBufIndex := 1.
		inBufLastIndex := 0.
	].
	aString size > (inBuf size - inBufLastIndex) ifTrue: [
		inBuf := inBuf , (String new: newAlloc)
	].
	inBuf 
		replaceFrom: inBufLastIndex + 1 
		to: inBufLastIndex + aString size
		with: aString 
		startingAt: 1.
	inBufLastIndex := inBufLastIndex + aString size.
! !

!ObjectSocket methodsFor: 'encoding/decoding' stamp: 'sd 11/20/2005 21:26'!
processOutput
	"loop sending data as long as there is data to send, and the socket is ready to receive more data"
	[ socket sendDone and: [ outBuf notNil or: [ outObjects isEmpty not ] ] ] whileTrue: [
		| amountSent |

		outBuf isNil ifTrue: [
			| nextSize |
			"no data in the current buffer; make a new buffer and encode some more"
			outBuf := String new: ((self spaceToEncode: outObjects first) max: 8000).
			outBufIndex := 1.
			outBufSize := 0.

			[	outObjects isEmpty not and: [
					nextSize := self spaceToEncode: outObjects first.
					nextSize <= (outBuf size - outBufSize + 1) ]
			] whileTrue: [
				self encodeObject: outObjects first into: outBuf startingAt: outBufSize+1.
				outBufSize := outBufSize + nextSize.
				outObjects removeFirst ] ].

		"at this point, the buffer definitely has data in it to send.  Send some"
		amountSent := socket sendSomeData: outBuf startIndex: outBufIndex count: (outBufSize - outBufIndex + 1).
		outBufIndex := outBufIndex + amountSent.
		outBufIndex > outBufSize ifTrue: [ outBuf := nil ]  ].

! !

!ObjectSocket methodsFor: 'encoding/decoding' stamp: 'sd 11/20/2005 21:26'!
shrinkInBuf

	inBuf ifNil: [^self].
	inBufLastIndex < inBufIndex ifTrue: [
		inBufLastIndex := 0.
		inBufIndex := 1.
		inBuf size > 20000 ifTrue: [inBuf := nil].	"if really big, kill it"
		^self
	].
	inBuf := inBuf copyFrom: inBufIndex to: inBufLastIndex.
	inBufLastIndex := inBuf size.
	inBufIndex := 1.

! !


!ObjectSocket methodsFor: 'stream protocol' stamp: 'ls 4/25/2000 18:48'!
next
	^inObjects removeFirst	! !

!ObjectSocket methodsFor: 'stream protocol' stamp: 'ls 4/25/2000 18:48'!
nextOrNil
	inObjects isEmpty
		ifTrue: [ ^nil ]
		ifFalse: [ ^inObjects removeFirst ]! !

!ObjectSocket methodsFor: 'stream protocol' stamp: 'ls 4/25/2000 18:48'!
nextPut: anObject
	outObjects addLast: anObject! !


!ObjectSocket methodsFor: 'private-initialization' stamp: 'sd 11/20/2005 21:26'!
initialize: aSocket
	socket := aSocket.
	inBuf := String new: 1000.
	inBufIndex := 1.
	inBufLastIndex := 0.

	outBuf := nil.

	inObjects := OrderedCollection new.
	outObjects := OrderedCollection new.
! !

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

ObjectSocket class
	instanceVariableNames: ''!

!ObjectSocket class methodsFor: 'as yet unclassified' stamp: 'RAA 7/20/2000 15:47'!
on: aSocket

	^self basicNew initialize: aSocket! !
ClassTestCase subclass: #ObjectTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Objects'!

!ObjectTest methodsFor: 'tests' stamp: 'md 11/26/2004 16:37'!
testBecome
	"self debug: #testBecome"
	"this test should that all the variables pointing to an object are pointing now to another one, and all
      object pointing to the other are pointing to the object"

	| pt1 pt2 pt3 |
	pt1 := 0@0.
	pt2 := pt1.
	pt3 := 100@100.

	pt1 become: pt3.
	self assert: pt2 = (100@100).
	self assert: pt3 = (0@0).
	self assert: pt1 = (100@100).! !

!ObjectTest methodsFor: 'tests' stamp: 'md 11/26/2004 16:36'!
testBecomeForward
	"self debug: #testBecomeForward"
	"this test should that all the variables pointing to an object are pointing now to another one.
	Not that this inverse is not true. This kind of become is called oneWayBecome in VW"

	| pt1 pt2 pt3 |
	pt1 := 0@0.
	pt2 := pt1.
	pt3 := 100@100.
	pt1 becomeForward: pt3.
	self assert: pt2 = (100@100).
	self assert: pt3 == pt2.
	self assert: pt1 = (100@100)! !


!ObjectTest methodsFor: 'tests - debugging' stamp: 'sd 6/5/2005 09:05'!
testAssert

	self shouldnt: [Object assert: [true]] raise: Error.
	self shouldnt: [Object assert: true] raise: Error.
	self should: [Object assert: [false]] raise: AssertionFailure.
	self should: [Object assert: false] raise: AssertionFailure.! !

!ObjectTest methodsFor: 'tests - debugging' stamp: 'sd 6/5/2005 09:05'!
testHaltIf

	self should: [self haltIf: true] raise: Halt.
	self shouldnt: [self haltIf: false] raise: Halt.

	self should: [self haltIf: [true]] raise: Halt.
	self shouldnt: [self haltIf: [false]] raise: Halt.

	self should: [self haltIf: #testHaltIf.] raise: Halt.
	self shouldnt: [self haltIf: #teadfasdfltIf.] raise: Halt.

	self should: [self a] raise: Halt.
	self shouldnt: [self a1] raise: Halt.

	self should: [self haltIf: [:o | o class = self class]] raise: Halt.
	self shouldnt: [self haltIf: [:o | o class ~= self class]] raise: Halt.
! !


!ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'!
a
	self b.! !

!ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'!
a1
	self b1.! !

!ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'!
b
	self haltIf: #testHaltIf.! !

!ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'!
b1
	self haltIf: #testasdasdfHaltIf.! !
ProtoObject subclass: #ObjectTracer
	instanceVariableNames: 'tracedObject recursionFlag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'.
ObjectTracer superclass: nil!
!ObjectTracer commentStamp: '<historical>' prior: 0!
An ObjectTracer can be wrapped around another object, and then give you a chance to inspect it whenever it receives messages from the outside.  For instance...
	(ObjectTracer on: Display) flash: (50@50 extent: 50@50)
will give control to a debugger just before the message flash is sent.
Obviously this facility can be embellished in many useful ways.
See also the even more perverse subclass, ObjectViewer, and its example.
!


!ObjectTracer methodsFor: 'very few messages' stamp: 'ar 9/27/2005 20:24'!
doesNotUnderstand: aMessage 
	"All external messages (those not caused by the re-send) get trapped here"
	"Present a dubugger before proceeding to re-send the message"

	ToolSet debugContext: thisContext
				label: 'About to perform: ', aMessage selector
				contents: nil.
	^ aMessage sentTo: tracedObject.
! !

!ObjectTracer methodsFor: 'very few messages'!
xxxUnTrace

	tracedObject become: self! !

!ObjectTracer methodsFor: 'very few messages'!
xxxViewedObject
	"This message name must not clash with any other (natch)."
	^ tracedObject! !

!ObjectTracer methodsFor: 'very few messages'!
xxxViewedObject: anObject
	"This message name must not clash with any other (natch)."
	tracedObject _ anObject! !

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

ObjectTracer class
	instanceVariableNames: ''!

!ObjectTracer class methodsFor: 'instance creation'!
on: anObject
	^ self new xxxViewedObject: anObject! !
ObjectTracer subclass: #ObjectViewer
	instanceVariableNames: 'valueBlock lastValue changeBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!ObjectViewer commentStamp: '<historical>' prior: 0!
ObjectViewers offers the same kind of interception of messages (via doesnotUnderstand:) as ObjectTracers, but instead of just being wrappers, they actually replace the object being viewed.  This makes them a lot more dangerous to use, but one can do amazing things.  For instance, the example below actually intercepts the InputSensor object, and prints the mouse coordinates asynchronously, every time they change:
	Sensor evaluate: [Sensor cursorPoint printString displayAt: 0@0]
		wheneverChangeIn: [Sensor cursorPoint].
To exit from this example, execute:
	Sensor xxxUnTrace
!


!ObjectViewer methodsFor: 'very few messages'!
doesNotUnderstand: aMessage 
	"Check for change after sending aMessage"
	| returnValue newValue |
	recursionFlag ifTrue: [^ aMessage sentTo: tracedObject].
	recursionFlag _ true.
	returnValue _ aMessage sentTo: tracedObject.
	newValue _ valueBlock value.
	newValue = lastValue ifFalse:
		[changeBlock value.
		lastValue _ newValue].
	recursionFlag _ false.
	^ returnValue! !

!ObjectViewer methodsFor: 'very few messages'!
xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2
	"This message name must not clash with any other (natch)."
	tracedObject _ viewedObject.
	valueBlock _ block2.
	changeBlock _ block1.
	recursionFlag _ false! !

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

ObjectViewer class
	instanceVariableNames: ''!

!ObjectViewer class methodsFor: 'instance creation'!
on: viewedObject evaluate: block1 wheneverChangeIn: block2
	^ self new xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2! !
Object subclass: #ObjectWithDocumentation
	instanceVariableNames: 'authoringStamp properties elementSymbol naturalLanguageTranslations'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!
!ObjectWithDocumentation commentStamp: '<historical>' prior: 0!
ObjectWithDocumentation - an abstract superclass for objects that allows maintenance of an authoring stamp, a body of documentation, and a properties dictionary.
The Properties implementation has not happened yet -- it would closely mirror the implemenation of properties in the MorphExtension, for example.!


!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:21'!
documentation
	"Answer the receiver's documentation"

	^self helpMessage! !

!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 19:33'!
documentation: somethingUsefulHopefully
	"Set the receiver's documentation, in the current langauge"

	self helpMessage: somethingUsefulHopefully! !

!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'sw 8/18/2004 20:23'!
helpMessage
	"Check if there is a getterSetterHelpMessage. 
	Otherwise try the normal help message or return nil."

	^ self getterSetterHelpMessage
		ifNil: [(self propertyAt: #helpMessage ifAbsent:
			[self legacyHelpMessage ifNil: [^ nil]]) translated]! !

!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 19:32'!
helpMessage: somethingUsefulHopefully
	"Set the receiver's documentation, in the current langauge"

	self propertyAt: #helpMessage put: somethingUsefulHopefully! !

!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'!
legacyHelpMessage
	"If I have a help message stashed in my legacy naturalTranslations slot, answer its translated rendition, else answer nil.  If I *do* come across a legacy help message, transfer it to my properties dictionary."

	| untranslated |
	naturalLanguageTranslations isEmptyOrNil  "only in legacy (pre-3.8) projects"
		ifTrue: [^ nil].
	untranslated := naturalLanguageTranslations first helpMessage ifNil: [^ nil].
	self propertyAt: #helpMessage put: untranslated.
	naturalLanguageTranslations removeFirst.
	naturalLanguageTranslations isEmpty ifTrue: [naturalLanguageTranslations := nil].
	^ untranslated translated! !

!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 23:57'!
untranslatedHelpMessage
	"Check if there is a getterSetterHelpMessage. 
	Otherwise try the normal help message or return nil."

	^(self propertyAt: #getterSetterHelpMessage ifAbsent: [nil])
		ifNil: [(self propertyAt: #helpMessage ifAbsent: [nil])]! !

!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 23:56'!
untranslatedWording
	"Answer the receiver's wording"

	^self propertyAt: #wording ifAbsent: [nil]! !

!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:34'!
wording
	"Answer the receiver's wording"

	| wording |
	(wording := self propertyAt: #wording ifAbsent: [nil])
		ifNotNil: [^wording translated].

	self initWordingAndDocumentation.
	^self propertyAt: #wording ifAbsent: ['']! !

!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:39'!
wording: aString
	"Set the receiver's wording, in the current langauge"

	self propertyAt: #wording put: aString! !


!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'rbb 3/1/2005 11:02'!
editDescription
	"Allow the user to see and edit the documentation for this object"
	| reply helpMessage |
	helpMessage := self documentation isNil
				ifTrue: [String new]
				ifFalse: [self documentation].
	reply := UIManager default
				multiLineRequest: 'Kindly edit the description' translated
				centerAt: Sensor cursorPoint
				initialAnswer: helpMessage
				answerHeight: 200.
	reply isEmptyOrNil
		ifFalse: [self documentation: reply]! !


!ObjectWithDocumentation methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	authoringStamp := Utilities changeStampPerSe
! !


!ObjectWithDocumentation methodsFor: 'migration' stamp: 'mir 7/12/2004 23:45'!
migrateWordAndHelpMessage
	"Migrate the English wording and help message to the new structure"

	| englishElement |
	self initWordingAndDocumentation.
	(self properties includes: #wording)
		ifFalse: [
			englishElement := self naturalLanguageTranslations
				detect: [:each | each language == #English] ifNone: [^nil].
			self wording: englishElement wording.
			self helpMessage: englishElement helpMessage]! !


!ObjectWithDocumentation methodsFor: 'miscellaneous' stamp: 'sw 9/12/2001 23:03'!
elementSymbol
	"Answer the receiver's element symbol"

	^ elementSymbol! !

!ObjectWithDocumentation methodsFor: 'miscellaneous' stamp: 'mir 7/12/2004 23:20'!
naturalLanguageTranslations
	^naturalLanguageTranslations ifNil: [OrderedCollection new]! !


!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:28'!
getterSetterHelpMessage
	"Returns a helpMessage that has been computed previously and needs to be translated and then formatted with the elementSymbol.
	'get value of {1}' translated format: {elSym}"

	^(self propertyAt: #getterSetterHelpMessage ifAbsent: [^nil])
		translated format: {self elementSymbol}! !

!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:29'!
getterSetterHelpMessage: aString
	"Sets a helpMessage that needs to be translated and then formatted with the elementSymbol.
	'get value of {1}' translated format: {elSym}"

	self propertyAt: #getterSetterHelpMessage put: aString! !

!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:31'!
initWordingAndDocumentation
	"Initialize wording and documentation (helpMessage) for getters and setters"

	| elSym |
	elSym := self elementSymbol.
	elSym
		ifNil: [^self].

	((elSym beginsWith: 'get')
		and: [elSym size > 3])
		ifTrue: [
			self wording: (elSym allButFirst: 3) withFirstCharacterDownshifted.
			self getterSetterHelpMessage: 'get value of {1}']
		ifFalse: [
			((elSym beginsWith: 'set')
				and: [elSym size > 4])
				ifTrue: [
					self wording: (elSym allButFirst: 3) withFirstCharacterDownshifted.
					self getterSetterHelpMessage: 'set value of {1}']]! !

!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:30'!
properties
	^properties ifNil: [properties := Dictionary new]! !

!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:30'!
propertyAt: key
	^self propertyAt: key ifAbsent: [nil]! !

!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:29'!
propertyAt: key ifAbsent: aBlock
	^properties
		ifNil: aBlock
		ifNotNil: [properties at: key ifAbsent: aBlock]! !

!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:29'!
propertyAt: key put: aValue
	self properties at: key put: aValue! !
AbstractObjectsAsMethod subclass: #ObjectsAsMethodsExample
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-ObjectsAsMethods'!

!ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2003 20:16'!
add: a with: b
	^a + b! !

!ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2003 20:16'!
answer42
	^42! !

!ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 19:37'!
run: oldSelector with: arguments in: aReceiver
	^self perform: oldSelector withArguments: arguments! !
AlignmentMorph subclass: #ObjectsTool
	instanceVariableNames: 'searchString modeSymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-PartsBin'!
!ObjectsTool commentStamp: '<historical>' prior: 0!
I am a Master Parts Bin that allows the user to drag out a new Morph from a voluminous iconic list.

Choose "objects" from the world menu, or type Alt-o (Cmd-o on the Mac).

To add a new kinds of Morphs:
In the class of the Morph, implement the message:

descriptionForPartsBin
	^ self partName:	'Rectangle'
		categories:		#('Graphics' ' Basic 1 ')
		documentation:	'A rectangular shape, with border and fill style'

The partName is the title that will show in the lower pane of the Object Tool.
When is categories mode, an object can be seen in more than one category.  The list above tells which ones.
Documentation is what will show in the balloon help for each object thumbnail.
The message #initializeToStandAlone creates the actual instance.

To make a second variant object prototype coming from the same class, implement #supplementaryPartsDescriptions.  In it, you get to specify the nativitySelector.  It is sent to the class to get the variant objects.  Often it is #authoringPrototype.  (A class may supply supplementaryPartsDescriptions without implementing descriptionForPartsBin.  This gives you better control.)

!


!ObjectsTool methodsFor: 'alphabetic' stamp: 'dgd 4/4/2006 16:43'!
alphabeticTabs
	"Answer a list of buttons which, when hit, will trigger the choice of a morphic category"

	| buttonList aButton tabLabels |

	self flag: #todo. "includes non-english characters"
	tabLabels _ (($a to: $z) collect: [:ch | ch asString]) asOrderedCollection.

	buttonList _ tabLabels collect:
		[:catName |
			aButton _ SimpleButtonMorph new label: catName.
			aButton actWhen: #buttonDown.
			aButton target: self; actionSelector: #showAlphabeticCategory:fromButton:; arguments: {catName. aButton}].
	^ buttonList

"ObjectsTool new tabsForMorphicCategories"! !

!ObjectsTool methodsFor: 'alphabetic' stamp: 'nk 9/3/2004 13:47'!
installQuads: quads fromButton: aButton
	"Install items in the bottom pane that correspond to the given set of quads, as triggered from the given button"

	| aPartsBin sortedQuads oldResizing |
	aPartsBin _ self partsBin.
	oldResizing := aPartsBin vResizing.
	aPartsBin removeAllMorphs.
	sortedQuads _ (PartsBin translatedQuads: quads)
							asSortedCollection: [:a :b | a third < b third].
	aPartsBin listDirection: #leftToRight quadList: sortedQuads.
	aButton ifNotNil: [self tabsPane highlightOnlySubmorph: aButton].
	aPartsBin vResizing: oldResizing.
	aPartsBin layoutChanged; fullBounds.
	self isFlap ifFalse: [ self minimizePartsBinSize ].! !

!ObjectsTool methodsFor: 'alphabetic' stamp: 'nk 9/3/2004 12:13'!
showAlphabeticTabs
	"Switch to the mode of showing alphabetic tabs"

	modeSymbol == #alphabetic ifTrue: [ ^self ].
	self partsBin removeAllMorphs.
	self initializeWithTabs: self alphabeticTabs.
	self modeSymbol: #alphabetic.
	self tabsPane submorphs first doButtonAction! !


!ObjectsTool methodsFor: 'categories' stamp: 'nk 9/3/2004 13:43'!
showCategories
	"Set the receiver up so that it shows tabs for each of the standard categories"

	modeSymbol == #categories ifTrue: [ ^self ].

	self partsBin removeAllMorphs.
	self initializeWithTabs: self tabsForCategories.
	self modeSymbol: #categories.
	self tabsPane submorphs first doButtonAction.
! !

!ObjectsTool methodsFor: 'categories' stamp: 'nk 9/3/2004 13:51'!
showCategory: aCategoryName fromButton: aButton 
	"Project items from the given category into my lower pane"
	| quads |
	self partsBin removeAllMorphs.
	Cursor wait
		showWhile: [quads := OrderedCollection new.
			Morph withAllSubclasses
				do: [:aClass | aClass theNonMetaClass
						addPartsDescriptorQuadsTo: quads
						if: [:aDescription | aDescription translatedCategories includes: aCategoryName]].
			quads := quads
						asSortedCollection: [:q1 :q2 | q1 third <= q2 third].
			self installQuads: quads fromButton: aButton]! !

!ObjectsTool methodsFor: 'categories' stamp: 'nk 8/23/2004 18:18'!
tabsForCategories
	"Answer a list of buttons which, when hit, will trigger the choice of a category"

	| buttonList aButton classes categoryList basic |
	classes _ Morph withAllSubclasses.
	categoryList _ Set new.
	classes do: [:aClass |
		(aClass class includesSelector: #descriptionForPartsBin) ifTrue:
			[categoryList addAll: aClass descriptionForPartsBin translatedCategories].
		(aClass class includesSelector: #supplementaryPartsDescriptions) ifTrue:
			[aClass supplementaryPartsDescriptions do:
				[:aDescription | categoryList addAll: aDescription translatedCategories]]].

	categoryList _ OrderedCollection withAll: (categoryList asSortedArray).
	
	basic := categoryList remove: ' Basic' translated ifAbsent: [ ].
	basic ifNotNil: [ categoryList addFirst: basic ].

	basic := categoryList remove: 'Basic' translated ifAbsent: [ ].
	basic ifNotNil: [ categoryList addFirst: basic ].

	buttonList _ categoryList collect:
		[:catName |
			aButton _ SimpleButtonMorph new label: catName.
			aButton actWhen: #buttonDown.
			aButton target: self; actionSelector: #showCategory:fromButton:; arguments: {catName. aButton}].
	^ buttonList

"ObjectsTool new tabsForCategories"! !


!ObjectsTool methodsFor: 'initialization' stamp: 'nk 9/3/2004 13:46'!
initializeForFlap
	"Initialize the receiver to operate in a flap at the top of the screen."

	"
	Flaps newObjectsFlap openInWorld
	"

	| buttonPane aBin aColor heights tabsPane |
	self basicInitialize.

	self layoutInset: 0;
		layoutPolicy: ProportionalLayout new;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		borderWidth: 2; borderColor: Color darkGray;
		extent: (self minimumWidth @ self minimumHeight).

	"mode buttons"
	buttonPane := self paneForTabs: self modeTabs.
	buttonPane
		vResizing: #shrinkWrap;
		setNameTo: 'ButtonPane';
		color: (aColor := buttonPane color) darker;
		layoutInset: 6;
		wrapDirection: nil;
		width: self width;
		layoutChanged; fullBounds.

	"Place holder for a tabs or text pane"
	tabsPane := Morph new
		setNameTo: 'TabPane';
		hResizing: #spaceFill;
		yourself.

	heights := { buttonPane height. 40 }.

	buttonPane vResizing: #spaceFill.
	self
		addMorph: buttonPane
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 0)
				offsets: (0 @ 0 corner: 0 @ heights first)).

	self
		addMorph: tabsPane
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 0)
				offsets: (0 @ heights first corner: 0 @ (heights first + heights second))).

	aBin := (PartsBin newPartsBinWithOrientation: #leftToRight from: #())
		listDirection: #leftToRight;
		wrapDirection: #topToBottom;
		color: aColor lighter lighter;
		setNameTo: 'Parts';
		dropEnabled: false;
		vResizing: #spaceFill;
		yourself.

	self
		addMorph: aBin
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 1)
				offsets: (0 @ (heights first + heights second) corner: 0 @ 0)).

	aBin color: (Color orange muchLighter);
		setNameTo: 'Objects' translated.

	self color: (Color orange muchLighter);
		setNameTo: 'Objects' translated.
! !

!ObjectsTool methodsFor: 'initialization' stamp: 'dgd 4/4/2006 16:47'!
initializeToStandAlone
	"Initialize the receiver so that it can live as a stand-alone morph"
	| buttonPane aBin aColor heights tabsPane |
	self basicInitialize.

	self layoutInset: 0;
		layoutPolicy: ProportionalLayout new;
		useRoundedCorners;
		hResizing: #rigid;
		vResizing: #rigid;
		extent: (self minimumWidth @ self minimumHeight).

	"mode buttons"
	buttonPane := self paneForTabs: self modeTabs.
	buttonPane color: ColorTheme current dialogColor.
	buttonPane
		vResizing: #shrinkWrap;
		setNameTo: 'ButtonPane';
		addMorphFront: self dismissButton;
		addMorphBack: self helpButton;
		color: (aColor := buttonPane color) darker;
		layoutInset: 5;
		wrapDirection: nil;
		width: self width;
		layoutChanged; fullBounds.

	"Place holder for a tabs or text pane"
	tabsPane := Morph new.
	tabsPane
		color: ColorTheme current dialogColor;
		setNameTo: 'TabPane';
		hResizing: #spaceFill.

	heights := { buttonPane height. 40 }.

	buttonPane vResizing: #spaceFill.
	self
		addMorph: buttonPane
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 0)
				offsets: (0 @ 0 corner: 0 @ heights first)).

	self
		addMorph: tabsPane
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 0)
				offsets: (0 @ heights first corner: 0 @ (heights first + heights second))).

	aBin := (PartsBin newPartsBinWithOrientation: #leftToRight from: #())
		listDirection: #leftToRight;
		wrapDirection: #topToBottom;
		color: aColor lighter lighter;
		setNameTo: 'Parts';
		dropEnabled: false;
		vResizing: #spaceFill;
		yourself.

	self
		addMorph: aBin
		fullFrame: (LayoutFrame
				fractions: (0 @ 0 corner: 1 @ 1)
				offsets: (0 @ (heights first + heights second) corner: 0 @ 0)).

	self
		borderWidth: ColorTheme current dialogBorderWidth;
		borderColor: ColorTheme current dialogBorderColor;
		color: ColorTheme current dialogColor;
		setNameTo: 'Objects' translated;
		showCategories.
! !

!ObjectsTool methodsFor: 'initialization' stamp: 'dgd 4/4/2006 16:45'!
tweakAppearanceAfterModeShift
	"After the receiver has been put into a given mode, make an initial selection of category, if appropriate, and highlight the mode button."

	self buttonPane submorphs do:
		[:aButton | 
			| aColor |
			"aButton borderWidth: 1."
			aColor := (aButton valueOfProperty: #modeSymbol) = modeSymbol
				ifTrue: [Color red]
				ifFalse: [Color black].

			aButton firstSubmorph color: aColor.
			aButton borderColor: aColor.
		].! !


!ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 12:35'!
extent: anExtent
	"The user has dragged the grow box such that the receiver's extent would be anExtent.  Do what's needed"
	self extent = anExtent ifTrue: [ ^self ].
	super extent: anExtent.
	self fixLayoutFrames.! !

!ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 13:44'!
fixLayoutFrames
	"Adjust the boundary between the tabs or search pane and the parts bin, giving preference to the tabs."

	| oldY newY tp tpHeight |
	oldY := ((tp := self tabsPane
						ifNil: [self searchPane])
				ifNil: [^ self]) layoutFrame bottomOffset.
	tpHeight := tp hasSubmorphs
				ifTrue: [(tp submorphBounds outsetBy: tp layoutInset) height]
				ifFalse: [tp height].
	newY := (self buttonPane
				ifNil: [^ self]) height + tpHeight.
	oldY = newY
		ifTrue: [^ self].
	tp layoutFrame bottomOffset: newY.
	(self partsBin
		ifNil: [^ self]) layoutFrame topOffset: newY.
	submorphs
		do: [:m | m layoutChanged ]! !

!ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 13:47'!
minimizePartsBinSize
	self layoutChanged; fullBounds.
	self fixLayoutFrames.
	self setExtentFromHalo: (self minimumWidth @ self minimumHeight) ! !

!ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 10:35'!
minimumBottom
	| iconsBottom partsBin |
	partsBin := self partsBin ifNil: [ ^self bottom ].
	iconsBottom := partsBin submorphs isEmpty
		ifTrue: [ partsBin top + 60 ]
		ifFalse: [ partsBin submorphBounds bottom + partsBin layoutInset ].

	^iconsBottom + self layoutInset + self borderWidth! !

!ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 11:53'!
minimumHeight
	^(self minimumBottom - self top) max: 280! !

!ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 12:06'!
minimumWidth
	"Answer a width that assures that the alphabet fits in two rows"

	^ 300! !

!ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 12:40'!
position: aPoint
	"The user has dragged the grow box such that the receiver's extent would be anExtent.  Do what's needed"
	self position = aPoint ifTrue: [ ^self ].
	super position: aPoint.
	self fixLayoutFrames.! !

!ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 12:44'!
setExtentFromHalo: anExtent
	"The user has dragged the grow box such that the receiver's extent would be anExtent.  Do what's needed"
	super setExtentFromHalo: ((anExtent x max: self minimumWidth) @ (anExtent y max: self minimumHeight)).
! !


!ObjectsTool methodsFor: 'major modes' stamp: 'sw 8/12/2001 16:30'!
modeSymbol
	"Answer the modeSymbol"

	^ modeSymbol! !

!ObjectsTool methodsFor: 'major modes' stamp: 'nk 9/3/2004 13:32'!
modeSymbol: aSymbol
	"Set the receiver's modeSymbol as indicated"

	modeSymbol _ aSymbol.
	self tweakAppearanceAfterModeShift.
! !

!ObjectsTool methodsFor: 'major modes' stamp: 'dgd 4/4/2006 16:47'!
modeTabs
	"Answer a list of buttons which, when hit, will trigger the choice of mode of the receiver"

	| buttonList aButton tupleList |
	tupleList _  #(
		('alphabetic'		alphabetic	showAlphabeticTabs	'A separate tab for each letter of the alphabet')
		('find'				search			showSearchPane			'Provides a type-in pane allowing you to match')
		('categories'		categories	showCategories			'Grouped by category')

		"('standard'		standard		showStandardPane		'Standard Squeak tools supplies for building')"
	).
				
	buttonList _ tupleList collect:
		[:tuple |
			aButton _ SimpleButtonMorph new label: tuple first translated.
			aButton actWhen: #buttonUp.
			aButton setProperty: #modeSymbol toValue: tuple second.
			aButton target: self; actionSelector: tuple third.
			aButton setBalloonText: tuple fourth translated.
			aButton borderWidth: 0.
			aButton].
	^ buttonList

"ObjectsTool new modeTabs"! !


!ObjectsTool methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:22'!
addCustomMenuItems: aMenu hand: aHand
	"Add items to the given halo-menu, given a hand"

	super addCustomMenuItems: aMenu hand: aHand.
	aMenu addLine.
	aMenu add: 'alphabetic' translated target: self selector: #showAlphabeticTabs.
	aMenu add: 'find' translated target: self selector: #showSearchPane.
	aMenu add: 'categories' translated target: self selector: #showCategories.
	aMenu addLine.
	aMenu add: 'reset thumbnails' translated target: self selector: #resetThumbnails.! !

!ObjectsTool methodsFor: 'menu' stamp: 'nk 9/7/2003 07:42'!
resetThumbnails
	"Reset the thumbnail cache"

	PartsBin clearThumbnailCache.
	modeSymbol == #categories ifTrue: [self showCategories] ifFalse: [self showAlphabeticTabs]! !


!ObjectsTool methodsFor: 'search' stamp: 'nk 9/3/2004 11:20'!
newSearchPane
	"Answer a type-in pane for searches"

	| aTextMorph |
	aTextMorph _ TextMorph new
		setProperty: #defaultContents toValue: ('' asText allBold addAttribute: (TextFontChange font3));
		setTextStyle: (TextStyle fontArray: { Preferences standardEToysFont });
		setDefaultContentsIfNil;
		on: #keyStroke send: #searchPaneCharacter: to: self;
		setNameTo: 'SearchPane';
		setBalloonText: 'Type here and all entries that match will be shown.' translated;
		vResizing: #shrinkWrap;
		hResizing: #spaceFill;
		margins: 4@6;
		backgroundColor: Color white.
	^ aTextMorph! !

!ObjectsTool methodsFor: 'search' stamp: 'sw 6/30/2001 14:26'!
searchPaneCharacter: evt
	"A character represented by the event handed in was typed in the search pane by the user"

	^ self showMorphsMatchingSearchString

"	| char |  *** The variant below only does a new search if RETURN or ENTER is hit ***
	char _ evt keyCharacter.
	(char == Character enter or: [char == Character cr]) ifTrue:
		[self showMorphsMatchingSearchString]"! !

!ObjectsTool methodsFor: 'search' stamp: 'nk 9/3/2004 10:39'!
setSearchStringFromSearchPane
	"Set the search string by obtaining its contents from the search pane, and doing a certain amount of munging"

	searchString _ self searchPane text string asLowercase withBlanksTrimmed.
	searchString _ searchString copyWithoutAll: {Character enter. Character cr}! !

!ObjectsTool methodsFor: 'search' stamp: 'nk 9/3/2004 13:51'!
showMorphsMatchingSearchString
	"Put items matching the search string into my lower pane"
	| quads |
	self setSearchStringFromSearchPane.
	self partsBin removeAllMorphs.
	Cursor wait
		showWhile: [quads := OrderedCollection new.
			Morph withAllSubclasses
				do: [:aClass | aClass
						addPartsDescriptorQuadsTo: quads
						if: [:info | info formalName translated includesSubstring: searchString caseSensitive: false]].
			self installQuads: quads fromButton: nil]! !

!ObjectsTool methodsFor: 'search' stamp: 'nk 9/3/2004 12:13'!
showSearchPane
	"Set the receiver up so that it shows the search pane"

	| tabsPane aPane frame |
	modeSymbol == #search ifTrue: [ ^self ].

	self partsBin removeAllMorphs.

	tabsPane := self tabsPane.
	aPane _ self newSearchPane.
	aPane layoutChanged; fullBounds.

	aPane layoutFrame: (frame := tabsPane layoutFrame copy).
	frame bottomOffset: (frame topOffset + aPane height).
	self replaceSubmorph: tabsPane by: aPane.
	self partsBin layoutFrame topOffset: frame bottomOffset.

	self modeSymbol: #search.
	self showMorphsMatchingSearchString.
	ActiveHand newKeyboardFocus: aPane! !


!ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 08:06'!
buttonPane
	"Answer the receiver's button pane, nil if none"

	^ self submorphNamed: 'ButtonPane' ifNone: [].! !

!ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 08:09'!
partsBin
	^self findDeeplyA: PartsBin.! !

!ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 10:40'!
searchPane
	"Answer the receiver's search pane, nil if none"

	^ self submorphNamed: 'SearchPane' ifNone: [].! !

!ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 13:51'!
showAlphabeticCategory: aString fromButton: aButton 
	"Blast items beginning with a given letter into my lower pane"
	| eligibleClasses quads uc |
	self partsBin removeAllMorphs.
	uc := aString asUppercase asCharacter.
	Cursor wait
		showWhile: [eligibleClasses := Morph withAllSubclasses.
			quads := OrderedCollection new.
			eligibleClasses
				do: [:aClass | aClass theNonMetaClass
						addPartsDescriptorQuadsTo: quads
						if: [:info | info formalName translated asUppercase first = uc]].
			self installQuads: quads fromButton: aButton]! !

!ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 08:06'!
tabsPane
	"Answer the receiver's tabs pane, nil if none"

	^ self submorphNamed: 'TabPane' ifNone: [].! !


!ObjectsTool methodsFor: 'tabs' stamp: 'nk 9/3/2004 13:47'!
initializeWithTabs: tabList
	"Initialize the receiver to have the given tabs"
	| oldPane newPane |
	oldPane := self tabsPane ifNil: [ self searchPane ].
	newPane := (self paneForTabs: tabList)
		setNameTo: 'TabPane';
		yourself.
	newPane layoutFrame: oldPane layoutFrame.
	self replaceSubmorph: oldPane by: newPane.
	newPane layoutChanged; fullBounds.
	self fixLayoutFrames.

! !

!ObjectsTool methodsFor: 'tabs' stamp: 'dgd 4/4/2006 16:44'!
paneForTabs: tabList 
	"Answer a pane bearing tabs for the given list"
	| aPane |
	tabList do: [:t |
			t color: Color transparent.
			t borderWidth: 1;
				borderColor: Color black].

	aPane := AlignmentMorph newRow
				color: ColorTheme current dialogColor;
				listDirection: #leftToRight;
				wrapDirection: #topToBottom;
				vResizing: #spaceFill;
				hResizing: #spaceFill;
				cellInset: 6;
				layoutInset: 4;
				listCentering: #center;
				listSpacing: #equal;
				addAllMorphs: tabList;
				yourself.

	aPane width: self layoutBounds width.

	^ aPane! !

!ObjectsTool methodsFor: 'tabs' stamp: 'dgd 8/30/2003 16:09'!
presentHelp
	"Sent when a Help button is hit; provide the user with some form of help for the tool at hand"

'The Objects tool allows you to browse through, and obtain copies of, many kinds of objects.  

You can obtain an Objects tool by choosing "Objects" from the world menu, or by the shortcut of typing alt-o (cmd-o) any time the cursor is over the desktop.

There are three ways to use Objects, corresponding to the three tabs seen at the top:

alphabetic - gives you separate tabs for a, b, c, etc.  Click any tab, and you will see the icons of all the objects whose names begin with that letter

search - gives you a type-in pane for a search string.  Type any letters there, and icons of all the objects whose names match what you have typed will appear in the bottom pane.

categories - provides tabs representing categories of related items.  Click on any tab to see the icons of all the objects in the category.

When the cursor lingers over the icon of any object, you will get balloon help for the item.

When you drag an icon from Objects, it will result in a new copy of it in your hand; the new object will be deposited wherever you next click.' translated

	openInWorkspaceWithTitle: 'About Objects' translated! !


!ObjectsTool methodsFor: 'thumbnail' stamp: 'dgd 9/22/2004 19:28'!
icon
	"Answer a form with an icon to represent the receiver"
	^ MenuIcons objectCatalogIcon! !

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

ObjectsTool class
	instanceVariableNames: ''!

!ObjectsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:45'!
initialize

	self registerInFlapsRegistry.	! !

!ObjectsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:47'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(ObjectsTool			newStandAlone				'Object Catalog'		'A tool that lets you browse the catalog of objects')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(ObjectsTool		newStandAlone				'Object Catalog'		'A tool that lets you browse the catalog of objects')
						forFlapNamed: 'Widgets'.]! !

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

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


!ObjectsTool class methodsFor: 'parts bin' stamp: 'sw 8/11/2001 20:16'!
descriptionForPartsBin
	^ self partName:	'Objects'
		categories:		#('Useful')
		documentation:	'A place to obtain many kinds of objects'! !
OldSocket subclass: #OldSimpleClientSocket
	instanceVariableNames: 'buffer bufferPos'
	classVariableNames: 'CR CrLf LF'
	poolDictionaries: ''
	category: 'Network-Kernel'!
!OldSimpleClientSocket commentStamp: '<historical>' prior: 0!
This class supports client for simple network protocols based on sending textual commands and responses. Examples of such protocols include POP3 (mail retrieval), SMTP (mail posting), HTTP (web browsing), and NTTP (network news). Some simple examples are presented as class methods, but a full-service client of some service should be implemented as a subclass.

The basic services provided by this class are:
	sendCommand:			-- sends a command line terminate with <CR><LF>
	getResponse				-- gets a single-line response to a command
	getMultilineResponse	-- gets a multiple line response terminated by a period
							-- on a line by itself

There are variants of the getResponse commands that display lines on the screen as they are being received. Linefeeds are stripped out of all responses.

The 'get' commands above make use of an internal buffer.  So intermixing these two commands and regular Socket recieve commands can cause problems.!


!OldSimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'di 4/13/1999 14:43'!
displayString: aString
	"Display the given string on the Display. Used for testing."

	| s |
	aString isEmpty ifTrue: [^ self].
	aString size > 60
		ifTrue: [s _ aString copyFrom: 1 to: 60]  "limit to 60 characters"
		ifFalse: [s _ aString].

	s displayOn: Display.
! !

!OldSimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/15/97 15:43'!
getMultilineResponse
	"Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character."

	^ self getMultilineResponseShowing: false.
! !

!OldSimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 03:34'!
getMultilineResponseShowing: showFlag
	"Get a multiple line response to the last command. A multiple line response ends with a line containing only a single period (.) character. Linefeed characters are filtered out. If showFlag is true, each line is shown in the upper-left corner of the Display as it is received."

	| response done chunk |
	response _ WriteStream on: ''.
	done _ false.
	[done] whileFalse: [
		showFlag
			ifTrue: [chunk _ self getResponseShowing: true]
			ifFalse: [chunk _ self getResponse].
		(chunk beginsWith: '.')
			ifTrue: [ response nextPutAll: (chunk copyFrom: 2 to: chunk size) ]
			ifFalse: [ response nextPutAll: chunk ].
		done _ (chunk = ('.', String cr)) ].

	^ response contents
! !

!OldSimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 02:10'!
getResponse
	"Get a one-line response from the server.  The final LF is removed from the line, but the CR is left, so that the line is in Squeak's text format"

	^ self getResponseShowing: false
! !

!OldSimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 03:27'!
getResponseShowing: showFlag

	| line idx |
	line _ WriteStream on: String new.

	buffer ifNil: [
		buffer _ String new.
		bufferPos _ 0 ].

	[
		"look for a LF in the buffer"
		idx _ buffer indexOf: Character lf startingAt: bufferPos+1 ifAbsent: [ 0 ].
		idx > 0 ifTrue: [
			"found it!! we have a line"
			line nextPutAll: (buffer copyFrom: bufferPos+1 to: idx-1).
			bufferPos _ idx.
			^line contents ].
		
		"didn't find it.  add the whole buffer to the line, and retrieve some more data"
		line nextPutAll: (buffer copyFrom: bufferPos+1 to: buffer size).
		bufferPos _ 0.
		buffer _ String new.
		self waitForDataQueryingUserEvery: 30.
		buffer _ self getData.

		true
	] whileTrue.! !

!OldSimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/17/97 16:00'!
sendCommand: commandString
	"Send the given command as a single line followed by a <CR><LF> terminator."

	self sendData: commandString, CrLf.
! !

!OldSimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/16/1998 14:37'!
waitForDataQueryingUserEvery: seconds
	"Wait for data to arrive, asking the user periodically if they wish to keep waiting. If they don't wish to keep waiting, destroy the socket and raise an error."

	| gotData |
	gotData _ false.
	[gotData]
		whileFalse: [
			gotData _ self waitForDataUntil: (Socket deadlineSecs: seconds).
			gotData ifFalse: [
				self isConnected ifFalse: [
					self destroy.
					self error: 'server closed connection'].
				(self confirm: 'server not responding; keep trying?')
					ifFalse: [
						self destroy.
						self error: 'no response from server']]].
! !

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

OldSimpleClientSocket class
	instanceVariableNames: ''!

!OldSimpleClientSocket class methodsFor: 'class initialization' stamp: 'jm 9/15/97 11:42'!
initialize
	"SimpleClientSocket initialize"

	CR _ Character cr.
	LF _ Character linefeed.

	"string for command line termination:"
	CrLf _ String with: CR with: LF.
! !


!OldSimpleClientSocket class methodsFor: 'net news example' stamp: 'mir 5/13/2003 10:45'!
nntpTest
	"SimpleClientSocket nntpTest"

	| addr s headers msgs header allNewsGroups |
	addr _ NetNameResolver promptUserForHostAddress.
	s _ OldSimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: addr port: 119.  "119 is the NNTP port number"
	s waitForConnectionUntil: self standardDeadline.
	Transcript show: s getResponse.
	s sendCommand: 'group comp.lang.smalltalk'.
	Transcript show: s getResponse.

	"get all the message headers for the current newsgroup"
	s sendCommand: 'xover 1-1000000'.
	headers _ s getMultilineResponseShowing: true.

	"print the headers of the first 10 messages of comp.lang.smalltalk"
	s sendCommand: 'listgroup comp.lang.smalltalk'.
	msgs _ self parseIntegerList: s getMultilineResponse.
	msgs ifNotNil: [
		1 to: 5 do: [:i |
			s sendCommand: 'head ', (msgs at: i) printString.
			header _ s getMultilineResponse.
			Transcript show: (self extractDateFromAndSubjectFromHeader: header); cr]].

	"get a full list of usenet newsgroups"
	s sendCommand: 'newgroups 010101 000000'.
	allNewsGroups _ s getMultilineResponse.
	Transcript show: allNewsGroups size printString, ' bytes in full newsgroup list'; cr.

	Transcript show: 'Sending quit...'; cr.
	s sendCommand: 'QUIT'.
	Transcript show: s getResponse.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.

	(headers ~~ nil and:
	 [self confirm: 'show article headers from comp.lang.smalltalk?'])
		ifTrue: [
			(StringHolder new contents: (self parseHeaderList: headers))
				openLabel: 'Newsgroup Headers'].

	(allNewsGroups ~~ nil and:
	 [self confirm: 'show list of all newsgroups available on your server?'])
		ifTrue: [
			(StringHolder new contents: allNewsGroups)
				openLabel: 'All Usenet Newsgroups'].
! !

!OldSimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:25'!
parseHeaderList: aString
	"Parse a list of newsgroup headers."

	| results s lineStart |
	results _ WriteStream on: (String new: aString size).
	s _ ReadStream on: aString.
	[s atEnd]
		whileFalse: [
			lineStart _ s position + 1.
			3 timesRepeat: [s skipTo: Character tab].  "find fourth tab"
			lineStart to: s position - 1 do: [:i | results nextPut: (aString at: i)].
			results cr.
			s skipTo: Character cr].
	^ results contents
! !

!OldSimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:26'!
parseIntegerList: aString
	"Parse a list of integers, each on a line by itself."

	| s out |
	s _ ReadStream on: aString.
	s skipTo: Character cr.  "skip the first line"
	out _ OrderedCollection new.
	[s atEnd]
		whileFalse: [
			out addLast: (Integer readFrom: s).
			s skipTo: Character cr].
	^ out asArray
! !

!OldSimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:26'!
parseNTTPMsgList: aString
	"Parse a list of integers, each on a line by itself."

	| s out |
	s _ ReadStream on: aString.
	s skipTo: Character cr.  "skip the first line"
	out _ OrderedCollection new.
	[s atEnd]
		whileFalse: [
			out addLast: (Integer readFrom: s).
			s skipTo: Character cr].
	^ out asArray
! !


!OldSimpleClientSocket class methodsFor: 'other examples' stamp: 'mir 5/13/2003 10:45'!
finger: userName
	"OldSimpleClientSocket finger: 'stp'"

	| addr s |
	addr _ NetNameResolver promptUserForHostAddress.
	s _ OldSimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: addr port: 79.  "finger port number"
	s waitForConnectionUntil: self standardDeadline.
	s sendCommand: userName.
	Transcript show: s getResponse.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
! !

!OldSimpleClientSocket class methodsFor: 'other examples' stamp: 'mir 5/13/2003 10:45'!
httpTestHost: hostName port: port url: url
	"This test fetches a URL from the given host and port."
	"SimpleClientSocket httpTestHost: 'www.disney.com' port: 80 url: '/'"
	"Tests URL fetch through a local HTTP proxie server:
		(SimpleClientSocket
			httpTestHost: '127.0.0.1'
			port: 8080
			url: 'HTTP://www.exploratorium.edu/index.html')"

	| hostAddr s result buf bytes totalBytes t |
	Transcript cr; show: 'starting http test'; cr.
	Socket initializeNetwork.
	hostAddr _ NetNameResolver addressForName: hostName timeout: 10.
	hostAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', hostName].

	s _ OldSimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: hostAddr port: port.
	s waitForConnectionUntil: "self standardDeadline" (Socket deadlineSecs: 10).
	(s isConnected) ifFalse: [
		s destroy.
		^ self inform: 'could not connect'].
	Transcript show: 'connection open; waiting for data'; cr.

	s sendCommand: 'GET ', url, ' HTTP/1.0'.
	s sendCommand: 'User-Agent: Squeak 1.19'.
	s sendCommand: 'ACCEPT: text/html'.	"always accept plain text"
	s sendCommand: 'ACCEPT: application/octet-stream'.  "also accept binary data"
	s sendCommand: ''.  "blank line"

	result _ WriteStream on: (String new: 10000).
	buf _ String new: 10000.
	totalBytes _ 0.
	t _ Time millisecondsToRun: [
		[s isConnected] whileTrue: [
			s waitForDataUntil: (Socket deadlineSecs: 5).
			bytes _ s receiveDataInto: buf.
			1 to: bytes do: [:i | result nextPut: (buf at: i)].
			totalBytes _ totalBytes + bytes.
			Transcript show: totalBytes printString, ' bytes received'; cr]].

	s destroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
	Transcript show: 'http test done; ', totalBytes printString, ' bytes read in '.
	Transcript show: ((t / 1000.0) roundTo: 0.01) printString, ' seconds'; cr.
	Transcript show: ((totalBytes asFloat / t) roundTo: 0.01) printString, ' kBytes/sec'; cr.
	Transcript endEntry.
	(StringHolder new contents: (result contents))
		openLabel: 'HTTP Test Result: URL Contents'.
! !

!OldSimpleClientSocket class methodsFor: 'other examples' stamp: 'mir 5/13/2003 10:45'!
timeTest
	"SimpleClientSocket timeTest"

	| addr s |
	addr _ NetNameResolver promptUserForHostAddress.
	s _ OldSimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: addr port: 13.  "time port number"
	s waitForConnectionUntil: self standardDeadline.
	Transcript show: s getResponse.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
! !


!OldSimpleClientSocket class methodsFor: 'POP mail example' stamp: 'jm 9/15/97 14:47'!
extractDateFromAndSubjectFromHeader: headerString

	| date from subject s lineBuf c line i |
	date _ from _ subject _ ''.
	s _ ReadStream on: headerString.
	lineBuf _ WriteStream on: ''.
	[s atEnd] whileFalse: [
		c _ s next.
		c = CR
			ifTrue: [
				line _ lineBuf contents.
				(line beginsWith: 'Date: ')	ifTrue: [date _ line copyFrom: 7 to: line size].
				(line beginsWith: 'From: ')	ifTrue: [from _ line copyFrom: 7 to: line size].
				(line beginsWith: 'Subject: ')	ifTrue: [subject _ line copyFrom: 10 to: line size].
				lineBuf _ WriteStream on: '']
			ifFalse: [lineBuf nextPut: c]].

	i _ date indexOf: $' ifAbsent: [0].
	date _ date copyFrom: i + 1 to: date size.
	^ (self simpleDateString: date), ', ', from, ':
  ', subject
! !

!OldSimpleClientSocket class methodsFor: 'POP mail example' stamp: 'rbb 3/1/2005 11:02'!
popTest
	"SimpleClientSocket popTest"

	| addr userName userPassword s msgs header |
	addr := NetNameResolver promptUserForHostAddress.
	userName := UIManager default
		request: 'What is your email name?'
		initialAnswer: 'johnm'.
	userPassword := UIManager default
		request: 'What is your email password?'.

	s := OldSimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: addr port: 110.  "110 is the POP3 port number"
	s waitForConnectionUntil: self standardDeadline.
	Transcript show: s getResponse.
	s sendCommand: 'USER ', userName.
	Transcript show: s getResponse.
	s sendCommand: 'PASS ', userPassword.
	Transcript show: s getResponse.
	s sendCommand: 'LIST'.

	"the following should be tweaked to handle an empy mailbox:"
	msgs := self parseIntegerList: s getMultilineResponse.

	1 to: (msgs size min: 5) do: [ :i |
		s sendCommand: 'TOP ', (msgs at: i) printString, ' 0'.
		header := s getMultilineResponse.
		Transcript show: (self extractDateFromAndSubjectFromHeader: header); cr].

	msgs size > 0 ifTrue: [
		"get the first message"
		s sendCommand: 'RETR 1'.
		Transcript show: s getMultilineResponse].

	Transcript show: 'closing connection'; cr.
	s sendCommand: 'QUIT'.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
! !

!OldSimpleClientSocket class methodsFor: 'POP mail example' stamp: 'tk 4/10/1998 06:47'!
simpleDateString: dateString

	| s |
	s _ ReadStream on: dateString.
	s skipTo: $,.  "scan thru first comma"
	s atEnd ifTrue: [s reset].  "no comma found; reset s"
	s skipSeparators.
	^ (Date readFrom: s) mmddyyyy
! !


!OldSimpleClientSocket class methodsFor: 'queries' stamp: 'jm 2/26/98 09:50'!
crLf

	^ CrLf
! !


!OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'mir 5/13/2003 10:45'!
forkingRemoteCursorSender
	"This is the client side of a test that sends samples of the local input sensor state to the server, which may be running on a local or remote host. This method opens the connection, then forks a process to send the cursor data. Data is sent continuously until the user clicks in a 20x20 pixel square at the top-left corner of the display. The server should be started first. Note the server's address, since this method will prompt you for it."
	"SimpleClientSocket forkingRemoteCursorSender"

	| sock addr stopRect |
	Transcript show: 'starting remote cursor sender'; cr.
	Transcript show: 'initializing network'; cr.
	Socket initializeNetwork.
	addr _ NetNameResolver promptUserForHostAddress.
	Transcript show: 'opening connection'; cr.
	sock _ OldSimpleClientSocket new.
	sock connectTo: addr port: 54323.
	sock waitForConnectionUntil: self standardDeadline.
	(sock isConnected) ifFalse: [self error: 'sock not connected'].
	Transcript show: 'connection established'; cr.

	stopRect _ 0@0 corner: 20@20.  "click in this rectangle to stop sending"
	Display reverse: stopRect.
	["the sending process"
		[(stopRect containsPoint: Sensor cursorPoint) and:
		 [Sensor anyButtonPressed]]
			whileFalse: [
				sock sendCommand: self sensorStateString.
				(Delay forMilliseconds: 20) wait].

		sock waitForSendDoneUntil: self standardDeadline.
		sock destroy.
		Transcript show: 'remote cursor sender done'; cr.
		Display reverse: stopRect.
	] fork.
! !

!OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/15/97 14:49'!
parseSensorStateString: aString
	"Parse the given sensor stat string and return an array whose first element is the cursor point and whose second is the cursor button state."
	"SimpleClientSocket parseSensorStateString: SimpleClientSocket sensorStateString"

	| s buttons x y |
	s _ ReadStream on: aString.
	x _ Integer readFrom: s.
	s skipSeparators.
	y _ Integer readFrom: s.
	s skipSeparators.
	buttons _ Integer readFrom: s.
	^ Array with: x@y with: buttons
! !

!OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'mir 5/13/2003 10:45'!
remoteCursorReceiver
	"Wait for a connection, then display data sent by the client until the client closes the stream. This server process is usually started first (optionally in a forked process), then the sender process is started (optionally on another machine). Note this machine's address, which is printed in the transcript, since the sender process will ask for it."
	"[SimpleClientSocket remoteCursorReceiver] fork"

	| sock response |
	Transcript show: 'starting remote cursor receiver'; cr.
	Transcript show: 'initializing network'; cr.
	Socket initializeNetwork.
	Transcript show: 'my address is ', NetNameResolver localAddressString; cr.
	Transcript show: 'opening connection'; cr.
	sock _ OldSimpleClientSocket new.
	sock listenOn: 54323.
	sock waitForConnectionUntil: (Socket deadlineSecs: 60).
	sock isConnected
		ifFalse: [
			 sock destroy.
			Transcript show: 'remote cursor receiver did not receive a connection in 60 seconds; aborting.'.
			^ self].
	Transcript show: 'connection established'; cr.

	[sock isConnected]
		whileTrue: [
			sock dataAvailable
				ifTrue: [
					response _ sock getResponse.
					response displayOn: Display at: 10@10]
				ifFalse: [
					"if no data available, let other processes run for a while"
					(Delay forMilliseconds: 20) wait]].

	sock destroy.
	Transcript show: 'remote cursor receiver done'; cr.
! !

!OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'mir 5/13/2003 10:45'!
remoteCursorTest
	"This version of the remote cursor test runs both the client and the server code in the same loop."
	"SimpleClientSocket remoteCursorTest"

	| sock1 sock2 samplesToSend samplesSent done t |
	Transcript show: 'starting remote cursor test'; cr.
	Transcript show: 'initializing network'; cr.
	Socket initializeNetwork.
	Transcript show: 'opening connection'; cr.
	sock1 _ OldSimpleClientSocket new.
	sock2 _ OldSimpleClientSocket new.
	sock1 listenOn: 54321.
	sock2 connectTo: (NetNameResolver localHostAddress) port: 54321.
	sock1 waitForConnectionUntil: self standardDeadline.
	sock2 waitForConnectionUntil: self standardDeadline.
	(sock1 isConnected) ifFalse: [self error: 'sock1 not connected'].
	(sock2 isConnected) ifFalse: [self error: 'sock2 not connected'].
	Transcript show: 'connection established'; cr.

	samplesToSend _ 100.
	t _ Time millisecondsToRun: [
		samplesSent _ 0.
		done _ false.
		[done]
			whileFalse: [
				(sock1 sendDone and: [samplesSent < samplesToSend]) ifTrue: [
					sock1 sendCommand: self sensorStateString.
					samplesSent _ samplesSent + 1].
				sock2 dataAvailable ifTrue: [
					sock2 getResponse displayOn: Display at: 10@10].
				done _ samplesSent = samplesToSend]].
	sock1 destroy.
	sock2 destroy.
	Transcript show: 'remote cursor test done'; cr.
	Transcript show:
		samplesSent printString, ' samples sent in ',
		t printString, ' milliseconds'; cr.
	Transcript show: ((samplesSent * 1000) // t) printString, ' samples/sec'; cr.
! !

!OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/15/97 13:11'!
sensorStateString
	"SimpleClientSocket sensorStateString"

	| pt buttons s |
	pt _ Sensor cursorPoint.
	buttons _ Sensor primMouseButtons.
	s _ WriteStream on: (String new: 100).
	s nextPutAll: pt x printString.
	s space.
	s nextPutAll: pt y printString.
	s space.
	s nextPutAll: buttons printString.
	^ s contents
! !
Object subclass: #OldSocket
	instanceVariableNames: 'semaphore socketHandle readSemaphore writeSemaphore primitiveOnlySupportsOneSemaphore'
	classVariableNames: 'Connected DeadServer InvalidSocket OtherEndClosed Registry RegistryThreshold TCPSocketType ThisEndClosed UDPSocketType Unconnected WaitingForConnection'
	poolDictionaries: ''
	category: 'Network-Kernel'!
!OldSocket commentStamp: '<historical>' prior: 0!
A Socket represents a network connection point. Current sockets are designed to support the TCP/IP and UDP protocols

Subclasses of socket provide support for network protocols such as POP, NNTP, HTTP, and FTP. Sockets also allow you to implement your own custom services and may be used to support Remote Procedure Call or Remote Method Invocation some day.

JMM June 2nd 2000 Macintosh UDP support was added if you run open transport.
!
]style[(196 4 6 3 228)f1,f1LHTTPSocket Comment;,f1,f1LFTPSocket Comment;,f1!


!OldSocket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'!
address
	"Shortcut"
	^self localAddress! !

!OldSocket methodsFor: 'accessing' stamp: 'nk 2/24/2005 14:37'!
localAddress
	self waitForConnectionUntil: self class standardDeadline.
	self isConnected ifFalse: [^ByteArray new: 4].
	^self primSocketLocalAddress: socketHandle! !

!OldSocket methodsFor: 'accessing' stamp: 'nk 2/24/2005 14:37'!
localPort
	self waitForConnectionUntil: self class standardDeadline.
	self isConnected ifFalse: [^0].
	^self primSocketLocalPort: socketHandle! !

!OldSocket methodsFor: 'accessing' stamp: 'jm 3/13/98 12:11'!
peerName
	"Return the name of the host I'm connected to, or nil if its name isn't known to the domain name server or the request times out."
	"Note: Slow. Calls the domain name server, taking up to 20 seconds to time out. Even when sucessful, delays of up to 13 seconds have been observed during periods of high network load." 

	^ NetNameResolver
		nameForAddress: self remoteAddress
		timeout: 20
! !

!OldSocket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'!
port
	"Shortcut"
	^self localPort! !

!OldSocket methodsFor: 'accessing' stamp: 'JMM 6/5/2000 10:12'!
primitiveOnlySupportsOneSemaphore
	^primitiveOnlySupportsOneSemaphore! !

!OldSocket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'!
readSemaphore
	primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore].
	^readSemaphore! !

!OldSocket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!
remoteAddress

	^ self primSocketRemoteAddress: socketHandle
! !

!OldSocket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!
remotePort

	^ self primSocketRemotePort: socketHandle
! !

!OldSocket methodsFor: 'accessing' stamp: 'JMM 5/9/2000 15:32'!
semaphore
	^semaphore! !

!OldSocket methodsFor: 'accessing' stamp: 'ar 7/16/1999 17:22'!
socketHandle
	^socketHandle! !

!OldSocket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'!
writeSemaphore
	primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore].
	^writeSemaphore! !


!OldSocket methodsFor: 'connection open/close' stamp: 'nk 2/24/2005 14:37'!
accept
	"Accept a connection from the receiver socket.
	Return a new socket that is connected to the client"

	^self class acceptFrom: self! !

!OldSocket methodsFor: 'connection open/close' stamp: 'jm 9/11/97 20:29'!
close
	"Close this connection gracefully. For TCP, this sends a close request, but the stream remains open until the other side also closes it."

	self primSocketCloseConnection: socketHandle.  "close this end"
! !

!OldSocket methodsFor: 'connection open/close' stamp: 'jm 11/4/97 07:15'!
closeAndDestroy
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	self closeAndDestroy: 20.

! !

!OldSocket methodsFor: 'connection open/close' stamp: 'nk 2/24/2005 14:37'!
closeAndDestroy: timeoutSeconds 
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle = nil 
		ifFalse: 
			[self isConnected 
				ifTrue: 
					[self close.	"close this end"
					(self waitForDisconnectionUntil: (self class deadlineSecs: timeoutSeconds)) 
						ifFalse: 
							["if the other end doesn't close soon, just abort the connection"

							self primSocketAbortConnection: socketHandle]].
			self destroy]! !

!OldSocket methodsFor: 'connection open/close'!
connectTo: hostAddress port: port
	"Initiate a connection to the given port at the given host address. This operation will return immediately; follow it with waitForConnectionUntil: to wait until the connection is established."

	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [self error: 'Socket status must Unconnected before opening a new connection'].

	self primSocket: socketHandle connectTo: hostAddress port: port.
! !

!OldSocket methodsFor: 'connection open/close' stamp: 'jm 3/10/98 11:56'!
disconnect
	"Break this connection, no matter what state it is in. Data that has been sent but not received will be lost."

	self primSocketAbortConnection: socketHandle.
! !

!OldSocket methodsFor: 'connection open/close'!
listenOn: port
	"Listen for a connection on the given port. This operation will return immediately; follow it with waitForConnectionUntil: to wait until a connection is established."

	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [self error: 'Socket status must Unconnected before listening for a new connection'].

	self primSocket: socketHandle listenOn: port.
! !

!OldSocket methodsFor: 'connection open/close' stamp: 'ar 7/16/1999 18:26'!
listenOn: portNumber backlogSize: backlog
	"Listen for a connection on the given port.
	If this method succeeds, #accept may be used to establish a new connection"
	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [self error: 'Socket status must Unconnected before listening for a new connection'].
	self primSocket: socketHandle listenOn: portNumber backlogSize: backlog.
! !

!OldSocket methodsFor: 'connection open/close' stamp: 'ikp 9/1/2003 20:47'!
listenOn: portNumber backlogSize: backlog interface: ifAddr
	"Listen for a connection on the given port.
	If this method succeeds, #accept may be used to establish a new connection"
	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [self error: 'Socket status must Unconnected before listening for a new connection'].
	self primSocket: socketHandle listenOn: portNumber backlogSize: backlog interface: ifAddr.
! !


!OldSocket methodsFor: 'datagrams' stamp: 'JMM 6/7/2000 14:58'!
receiveDataInto: aStringOrByteArray fromHost: hostAddress port: portNumber
	| datagram |
	"Receive a UDP packet from the given hostAddress/portNumber, storing the data in the given buffer, and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	primitiveOnlySupportsOneSemaphore ifTrue:
		[self setPeer: hostAddress port: portNumber.
		^self receiveDataInto: aStringOrByteArray].
	[true] whileTrue: 
		[datagram _ self receiveUDPDataInto: aStringOrByteArray.
		((datagram at: 2) = hostAddress and: [(datagram at: 3) = portNumber]) 
			ifTrue: [^datagram at: 1]
			ifFalse: [^0]]! !

!OldSocket methodsFor: 'datagrams' stamp: 'JMM 6/3/2000 21:54'!
receiveUDPDataInto: aStringOrByteArray
	"Receive UDP data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data. What is returned is an array, the first element is the bytes read, the second the sending bytearray address, the third the senders port, the fourth, true if more of the datagram awaits reading"

	^ self primSocket: socketHandle
		receiveUDPDataInto: aStringOrByteArray
		startingAt: 1
		count: aStringOrByteArray size
! !

!OldSocket methodsFor: 'datagrams' stamp: 'JMM 5/25/2000 00:05'!
sendData: aStringOrByteArray toHost: hostAddress port: portNumber
	"Send a UDP packet containing the given data to the specified host/port."

	primitiveOnlySupportsOneSemaphore ifTrue:
		[self setPeer: hostAddress port: portNumber.
		^self sendData: aStringOrByteArray].
	^self sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber! !

!OldSocket methodsFor: 'datagrams' stamp: 'nk 2/24/2005 14:37'!
sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber 
	"Send a UDP packet containing the given data to the specified host/port."

	| bytesToSend bytesSent count |
	bytesToSend := aStringOrByteArray size.
	bytesSent := 0.
	[bytesSent < bytesToSend] whileTrue: 
			[(self waitForSendDoneUntil: (self class deadlineSecs: 20)) 
				ifFalse: [self error: 'send data timeout; data not sent'].
			count := self 
						primSocket: socketHandle
						sendUDPData: aStringOrByteArray
						toHost: hostAddress
						port: portNumber
						startIndex: bytesSent + 1
						count: bytesToSend - bytesSent.
			bytesSent := bytesSent + count].
	^bytesSent! !

!OldSocket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'!
setPeer: hostAddress port: port
	"Set the default send/recv address."

	self primSocket: socketHandle connectTo: hostAddress port: port.
! !

!OldSocket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'!
setPort: port
	"Associate a local port number with a UDP socket.  Not applicable to TCP sockets."

	self primSocket: socketHandle setPort: port.
! !


!OldSocket methodsFor: 'finalization' stamp: 'JMM 5/22/2000 22:52'!
finalize
	self primSocketDestroyGently: socketHandle.
	Smalltalk unregisterExternalObject: semaphore.
	Smalltalk unregisterExternalObject: readSemaphore.
	Smalltalk unregisterExternalObject: writeSemaphore.
! !


!OldSocket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:47'!
acceptFrom: aSocket
	"Initialize a new socket handle from an accept call"
	| semaIndex readSemaIndex writeSemaIndex |

	primitiveOnlySupportsOneSemaphore _ false.
	semaphore _ Semaphore new.
	readSemaphore _ Semaphore new.
	writeSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	readSemaIndex _ Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore.
	socketHandle _ self primAcceptFrom: aSocket socketHandle
						receiveBufferSize: 8000
						sendBufSize: 8000
						semaIndex: semaIndex
						readSemaIndex: readSemaIndex
						writeSemaIndex: writeSemaIndex.
	socketHandle = nil ifTrue: [  "socket creation failed"
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		readSemaphore _ writeSemaphore _ semaphore _ nil
	] ifFalse:[self register].
! !

!OldSocket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:54'!
destroy
	"Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle = nil ifFalse: 
		[self isValid ifTrue: [self primSocketDestroy: socketHandle].
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		socketHandle _ nil.
		readSemaphore _ writeSemaphore _ semaphore _ nil.
		self unregister].
! !

!OldSocket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 23:04'!
initialize: socketType
	"Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil."
	| semaIndex readSemaIndex writeSemaIndex |

	primitiveOnlySupportsOneSemaphore _ false.
	semaphore _ Semaphore new.
	readSemaphore _ Semaphore new.
	writeSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	readSemaIndex _ Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore.
	socketHandle _
		self primSocketCreateNetwork: 0
			type: socketType
			receiveBufferSize: 8000
			sendBufSize: 8000
			semaIndex: semaIndex
			readSemaIndex: readSemaIndex
			writeSemaIndex: writeSemaIndex.

	socketHandle = nil ifTrue: [  "socket creation failed"
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		readSemaphore _ writeSemaphore _ semaphore _ nil
	] ifFalse:[self register].
! !


!OldSocket methodsFor: 'other' stamp: 'JMM 6/3/2000 19:39'!
getOption: aName 
	"Get options on this socket, see Unix man pages for values for 
	sockets, IP, TCP, UDP. IE SO_KEEPALIVE
	returns an array, element one is an status number (0 ok, -1 read only option)
	element two is the resulting of the requested option"

	(socketHandle == nil or: [self isValid not])
		ifTrue: [self error: 'Socket status must valid before getting an option'].
	^self primSocket: socketHandle getOption: aName

"| foo options |
Socket initializeNetwork.
foo _ Socket newTCP.
foo connectTo: (NetNameResolver addressFromString: '192.168.1.1') port: 80.
foo waitForConnectionUntil: (Socket standardDeadline).

options _ {
'SO_DEBUG'. 'SO_REUSEADDR'. 'SO_REUSEPORT'. 'SO_DONTROUTE'.
'SO_BROADCAST'. 'SO_SNDBUF'. 'SO_RCVBUF'. 'SO_KEEPALIVE'.
'SO_OOBINLINE'. 'SO_PRIORITY'. 'SO_LINGER'. 'SO_RCVLOWAT'.
'SO_SNDLOWAT'. 'IP_TTL'. 'IP_HDRINCL'. 'IP_RCVOPTS'.
'IP_RCVDSTADDR'. 'IP_MULTICAST_IF'. 'IP_MULTICAST_TTL'.
'IP_MULTICAST_LOOP'. 'UDP_CHECKSUM'. 'TCP_MAXSEG'.
'TCP_NODELAY'. 'TCP_ABORT_THRESHOLD'. 'TCP_CONN_NOTIFY_THRESHOLD'. 
'TCP_CONN_ABORT_THRESHOLD'. 'TCP_NOTIFY_THRESHOLD'.
'TCP_URGENT_PTR_TYPE'}.

1 to: options size do: [:i | | fum |
	fum _foo getOption: (options at: i).
	Transcript show: (options at: i),fum printString;cr].

foo _ Socket newUDP.
foo setPeer: (NetNameResolver addressFromString: '192.168.1.9') port: 7.
foo waitForConnectionUntil: (Socket standardDeadline).

1 to: options size do: [:i | | fum |
	fum _foo getOption: (options at: i).
	Transcript show: (options at: i),fum printString;cr].
"! !

!OldSocket methodsFor: 'other' stamp: 'nk 2/24/2005 14:37'!
getResponseNoLF
	"Get the response to the last command."

	| buf response bytesRead c lf |
	(self waitForDataUntil: (self class deadlineSecs: 20)) 
		ifFalse: [self error: 'getResponse timeout'].
	lf := Character lf.
	buf := String new: 1000.
	response := WriteStream on: ''.
	[self dataAvailable] whileTrue: 
			[bytesRead := self 
						primSocket: socketHandle
						receiveDataInto: buf
						startingAt: 1
						count: buf size.
			1 to: bytesRead
				do: [:i | (c := buf at: i) ~= lf ifTrue: [response nextPut: c]]].
	^response contents! !

!OldSocket methodsFor: 'other' stamp: 'JMM 6/3/2000 19:39'!
setOption: aName value: aValue 
	| value |
	"setup options on this socket, see Unix man pages for values for 
	sockets, IP, TCP, UDP. IE SO_KEEPALIVE
	returns an array, element one is the error number
	element two is the resulting of the negotiated value.
	See getOption for list of keys"

	(socketHandle == nil or: [self isValid not])
		ifTrue: [self error: 'Socket status must valid before setting an option'].
	value _ aValue asString.
	aValue == true ifTrue: [value _ '1'].
	aValue == false ifTrue: [value _ '0'].
	^ self primSocket: socketHandle setOption: aName value: value! !


!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex
	"Create and return a new socket handle based on accepting the connection from the given listening socket"
	<primitive: 'primitiveSocketAccept' module: 'SocketPlugin'>
	^self primitiveFailed! !

!OldSocket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:55'!
primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	"Create and return a new socket handle based on accepting the connection from the given listening socket"
	<primitive: 'primitiveSocketAccept3Semaphores' module: 'SocketPlugin'>
	primitiveOnlySupportsOneSemaphore _ true.
	^self primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex ! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID connectTo: hostAddress port: port
	"Attempt to establish a connection to the given port of the given host. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."

	<primitive: 'primitiveSocketConnectToPort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 21:48'!
primSocket: socketID getOption: aString 
	"Get some option information on this socket. Refer to the UNIX 
	man pages for valid SO, TCP, IP, UDP options. In case of doubt
	refer to the source code.
	TCP_NODELAY, SO_KEEPALIVE are valid options for example
	returns an array containing the error code and the option value"

	<primitive: 'primitiveSocketGetOptions' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID listenOn: port
	"Listen for a connection on the given port. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."

	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: aHandle listenOn: portNumber backlogSize: backlog
	"Primitive. Set up the socket to listen on the given port.
	Will be used in conjunction with #accept only."
	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self destroy. "Accept not supported so clean up"! !

!OldSocket methodsFor: 'primitives' stamp: 'ikp 9/1/2003 20:55'!
primSocket: aHandle listenOn: portNumber backlogSize: backlog interface: ifAddr
	"Primitive. Set up the socket to listen on the given port.
	Will be used in conjunction with #accept only."
	<primitive: 'primitiveSocketListenOnPortBacklogInterface' module: 'SocketPlugin'>
	self destroy. "Accept not supported so clean up"! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID receiveDataInto: aStringOrByteArray startingAt: startIndex count: count
	"Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available."

	<primitive: 'primitiveSocketReceiveDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'JMM 5/24/2000 17:19'!
primSocket: socketID receiveUDPDataInto: aStringOrByteArray startingAt: startIndex count: count
	"Receive data from the given socket into the given array starting at the given index. 
	Return an Array containing the amount read, the host address byte array, the host port, and the more flag"

	<primitive: 'primitiveSocketReceiveUDPDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID sendData: aStringOrByteArray startIndex: startIndex count: count
	"Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."
	"Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."

	<primitive: 'primitiveSocketSendDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 00:08'!
primSocket: socketID sendUDPData: aStringOrByteArray toHost: hostAddress  port: portNumber startIndex: startIndex count: count
	"Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."
	"Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."

	<primitive:  'primitiveSocketSendUDPDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed

! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 7/18/2000 11:42'!
primSocket: socketID setOption: aString value: aStringValue
	"Set some option information on this socket. Refer to the UNIX 
	man pages for valid SO, TCP, IP, UDP options. In case of doubt
	refer to the source code.
	TCP_NODELAY, SO_KEEPALIVE are valid options for example
	returns an array containing the error code and the negotiated value"

	<primitive: 'primitiveSocketSetOptions' module: 'SocketPlugin'>
	^nil! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID setPort: port
	"Set the local port associated with a UDP socket.
	Note: this primitive is overloaded.  The primitive will not fail on a TCP socket, but
	the effects will not be what was desired.  Best solution would be to split Socket into
	two subclasses, TCPSocket and UDPSocket."

	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketAbortConnection: socketID
	"Terminate the connection on the given port immediately without going through the normal close sequence. This is an asynchronous call; query the socket status to discover if and when the connection is actually terminated."

	<primitive: 'primitiveSocketAbortConnection' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketCloseConnection: socketID
	"Close the connection on the given port. The remote end is informed that this end has closed and will do no further sends. This is an asynchronous call; query the socket status to discover if and when the connection is actually closed."

	<primitive: 'primitiveSocketCloseConnection' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketConnectionStatus: socketID
	"Return an integer reflecting the connection status of this socket. For a list of possible values, see the comment in the 'initialize' method of this class. If the primitive fails, return a status indicating that the socket handle is no longer valid, perhaps because the Squeak image was saved and restored since the socket was created. (Sockets do not survive snapshots.)"

	<primitive: 'primitiveSocketConnectionStatus' module: 'SocketPlugin'>
	^ InvalidSocket
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex
	"Return a new socket handle for a socket of the given type and buffer sizes. Return nil if socket creation fails.
	The netType parameter is platform dependent and can be used to encode both the protocol type (IP, Xerox XNS, etc.) and/or the physical network interface to use if this host is connected to multiple networks. A zero netType means to use IP protocols and the primary (or only) network interface.
	The socketType parameter specifies:
		0	reliable stream socket (TCP if the protocol is IP)
		1	unreliable datagram socket (UDP if the protocol is IP)
	The buffer size parameters allow performance to be tuned to the application. For example, a larger receive buffer should be used when the application expects to be receiving large amounts of data, especially from a host that is far away. These values are considered requests only; the underlying implementation will ensure that the buffer sizes actually used are within allowable bounds. Note that memory may be limited, so an application that keeps many sockets open should use smaller buffer sizes. Note the macintosh implementation ignores this buffer size. Also see setOption to get/set socket buffer sizes which allows you to set/get the current buffer sizes for reading and writing.
 	If semaIndex is > 0, it is taken to be the index of a Semaphore in the external objects array to be associated with this socket. This semaphore will be signalled when the socket status changes, such as when data arrives or a send completes. All processes waiting on the semaphore will be awoken for each such event; each process must then query the socket state to figure out if the conditions they are waiting for have been met. For example, a process waiting to send some data can see if the last send has completed."

	<primitive: 'primitiveSocketCreate' module: 'SocketPlugin'>
	^ nil  "socket creation failed"
! !

!OldSocket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:48'!
primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	"See comment in primSocketCreateNetwork: with one semaIndex. However you should know that some implementations
	ignore the buffer size and this interface supports three semaphores,  one for open/close/listen and the other two for
	reading and writing"

	<primitive: 'primitiveSocketCreate3Semaphores' module: 'SocketPlugin'>
	primitiveOnlySupportsOneSemaphore _ true.
	^ self primSocketCreateNetwork: netType
			type: socketType
			receiveBufferSize: rcvBufSize
			sendBufSize: sendBufSize
			semaIndex: semaIndex! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketDestroy: socketID
	"Release the resources associated with this socket. If a connection is open, it is aborted."

	<primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketDestroyGently: socketID
	"Release the resources associated with this socket. If a connection is open, it is aborted.
	Do not fail if the receiver is already closed."

	<primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'>
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketError: socketID
	"Return an integer encoding the most recent error on this socket. Zero means no error."

	<primitive: 'primitiveSocketError' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketLocalAddress: socketID
	"Return the local host address for this socket."

	<primitive: 'primitiveSocketLocalAddress' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketLocalPort: socketID
	"Return the local port for this socket, or zero if no port has yet been assigned."

	<primitive: 'primitiveSocketLocalPort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketReceiveDataAvailable: socketID
	"Return true if data may be available for reading from the current socket."

	<primitive: 'primitiveSocketReceiveDataAvailable' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketRemoteAddress: socketID
	"Return the remote host address for this socket, or zero if no connection has been made."

	<primitive: 'primitiveSocketRemoteAddress' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketRemotePort: socketID
	"Return the remote port for this socket, or zero if no connection has been made."

	<primitive: 'primitiveSocketRemotePort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!OldSocket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketSendDone: socketID
	"Return true if there is no send in progress on the current socket."

	<primitive: 'primitiveSocketSendDone' module: 'SocketPlugin'>
	self primitiveFailed
! !


!OldSocket methodsFor: 'printing' stamp: 'jm 11/23/1998 11:57'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '[', self statusString, ']'.
! !


!OldSocket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'!
dataAvailable
	"Return true if this socket has unread received data."

	socketHandle == nil ifTrue: [^ false].
	^ self primSocketReceiveDataAvailable: socketHandle
! !

!OldSocket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'!
isConnected
	"Return true if this socket is connected."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Connected
! !

!OldSocket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:15'!
isOtherEndClosed
	"Return true if this socket had the other end closed."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == OtherEndClosed
! !

!OldSocket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:17'!
isThisEndClosed
	"Return true if this socket had the this end closed."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == ThisEndClosed
! !

!OldSocket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isUnconnected
	"Return true if this socket's state is Unconnected."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Unconnected
! !

!OldSocket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isUnconnectedOrInvalid
	"Return true if this socket is completely disconnected or is invalid."

	| status |
	socketHandle == nil ifTrue: [^ true].
	status _ self primSocketConnectionStatus: socketHandle.
	^ (status = Unconnected) | (status = InvalidSocket)
! !

!OldSocket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:51'!
isValid
	"Return true if this socket contains a valid, non-nil socket handle."

	| status |
	socketHandle == nil ifTrue: [^ false].
	status _ self primSocketConnectionStatus: socketHandle.
	^ status ~= InvalidSocket
! !

!OldSocket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isWaitingForConnection
	"Return true if this socket is waiting for a connection."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == WaitingForConnection
! !

!OldSocket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
sendDone
	"Return true if the most recent send operation on this socket has completed."

	socketHandle == nil ifTrue: [^ false].
	^ self primSocketSendDone: socketHandle
! !

!OldSocket methodsFor: 'queries' stamp: 'JMM 5/8/2000 23:24'!
socketError
	^self primSocketError: socketHandle! !

!OldSocket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:56'!
statusString
	"Return a string describing the status of this socket."

	| status |
	socketHandle == nil ifTrue: [^ 'destroyed'].
	status _ self primSocketConnectionStatus: socketHandle.
	status = InvalidSocket ifTrue: [^ 'invalidSocketHandle'].
	status = Unconnected ifTrue: [^ 'unconnected'].
	status = WaitingForConnection ifTrue: [^ 'waitingForConnection'].
	status = Connected ifTrue: [^ 'connected'].
	status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd'].
	status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd'].
	^ 'unknown socket status'
! !


!OldSocket methodsFor: 'registry' stamp: 'ar 3/21/98 17:40'!
register
	^self class register: self! !

!OldSocket methodsFor: 'registry' stamp: 'ar 3/21/98 17:41'!
unregister
	^self class unregister: self! !


!OldSocket methodsFor: 'sending-receiving' stamp: 'jm 9/15/97 12:22'!
discardReceivedData
	"Discard any data received up until now, and return the number of bytes discarded."

	| buf totalBytesDiscarded |
	buf _ String new: 10000.
	totalBytesDiscarded _ 0.
	[self isConnected and: [self dataAvailable]] whileTrue: [
		totalBytesDiscarded _
			totalBytesDiscarded + (self receiveDataInto: buf)].
	^ totalBytesDiscarded
! !

!OldSocket methodsFor: 'sending-receiving' stamp: 'nk 2/24/2005 14:37'!
getData
	"Get some data"

	| buf bytesRead |
	(self waitForDataUntil: self class standardDeadline) 
		ifFalse: [self error: 'getData timeout'].
	buf := String new: 4000.
	bytesRead := self 
				primSocket: socketHandle
				receiveDataInto: buf
				startingAt: 1
				count: buf size.
	^buf copyFrom: 1 to: bytesRead! !

!OldSocket methodsFor: 'sending-receiving' stamp: 'nk 2/24/2005 14:37'!
readInto: aStringOrByteArray startingAt: aNumber 
	"Read data into the given buffer starting at the given index and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	(self waitForDataUntil: self class standardDeadline) 
		ifFalse: [self error: 'receive timeout'].
	^self 
		primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size - aNumber + 1! !

!OldSocket methodsFor: 'sending-receiving' stamp: 'jm 9/15/97 12:21'!
receiveDataInto: aStringOrByteArray
	"Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	^ self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: 1
		count: aStringOrByteArray size
! !

!OldSocket methodsFor: 'sending-receiving' stamp: 'tak 3/16/2005 16:51'!
sendData: aStringOrByteArray
	"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent."

	"An experimental version use on slow lines: Longer timeout and smaller writes to try to avoid spurious timeouts."

	| bytesSent bytesToSend count |
	bytesToSend _ aStringOrByteArray size.
	bytesSent _ 0.
	[bytesSent < bytesToSend] whileTrue: [
		(self waitForSendDoneUntil: (Socket deadlineSecs: 60))
			ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent'].
		count _ self primSocket: socketHandle
			sendData: aStringOrByteArray
			startIndex: bytesSent + 1
			count: (bytesToSend - bytesSent min: 5000).
		bytesSent _ bytesSent + count].

	^ bytesSent
! !

!OldSocket methodsFor: 'sending-receiving' stamp: 'ar 7/20/1999 17:23'!
sendData: buffer count: n
	"Send the amount of data from the given buffer"
	| sent |
	sent _ 0.
	[sent < n] whileTrue:[
		sent _ sent + (self sendSomeData: buffer startIndex: sent+1 count: (n-sent))].! !

!OldSocket methodsFor: 'sending-receiving' stamp: 'ls 1/5/1999 15:05'!
sendSomeData: aStringOrByteArray
	"Send as much of the given data as possible and answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self
		sendSomeData: aStringOrByteArray
		startIndex: 1
		count: aStringOrByteArray size! !

!OldSocket methodsFor: 'sending-receiving' stamp: 'ls 3/3/1999 18:59'!
sendSomeData: aStringOrByteArray startIndex: startIndex
	"Send as much of the given data as possible starting at the given index. Answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self
		sendSomeData: aStringOrByteArray
		startIndex: startIndex
		count: (aStringOrByteArray size - startIndex + 1)! !

!OldSocket methodsFor: 'sending-receiving' stamp: 'nk 2/24/2005 14:37'!
sendSomeData: aStringOrByteArray startIndex: startIndex count: count 
	"Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent."

	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	| bytesSent |
	(self waitForSendDoneUntil: (self class deadlineSecs: 20)) 
		ifTrue: 
			[bytesSent := self 
						primSocket: socketHandle
						sendData: aStringOrByteArray
						startIndex: startIndex
						count: count]
		ifFalse: [self error: 'send data timeout; data not sent'].
	^bytesSent! !


!OldSocket methodsFor: 'waiting' stamp: 'ar 7/20/1999 17:21'!
waitForAcceptUntil: deadLine
	"Wait and accept an incoming connection"
	self waitForConnectionUntil: deadLine.
	^self isConnected
		ifTrue:[self accept]
		ifFalse:[nil]! !

!OldSocket methodsFor: 'waiting' stamp: 'jm 3/2/98 18:15'!
waitForConnectionUntil: deadline
	"Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not."

	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	[(status = WaitingForConnection) and: [Time millisecondClockValue < deadline]]
		whileTrue: [
			semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
			status _ self primSocketConnectionStatus: socketHandle].

	^ status = Connected
! !

!OldSocket methodsFor: 'waiting' stamp: 'JMM 5/22/2000 22:04'!
waitForDataUntil: deadline
	"Wait up until the given deadline for data to arrive. Return true if data arrives by the deadline, false if not."

	| dataArrived |
	[self isConnected & 
	 (dataArrived _ self primSocketReceiveDataAvailable: socketHandle) not
			"Connection end and final data can happen fast, so test in this order"
		and: [Time millisecondClockValue < deadline]] whileTrue: [
			self readSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)].

	^ dataArrived
! !

!OldSocket methodsFor: 'waiting' stamp: 'JMM 5/17/2000 14:52'!
waitForDisconnectionUntil: deadline
	"Wait up until the given deadline for the the connection to be broken. Return true if it is broken by the deadline, false if not."
	"Note: The client should know the the connect is really going to be closed (e.g., because he has called 'close' to send a close request to the other end) before calling this method.
JMM 00/5/17 note that other end can close which will terminate wait"

	| extraBytes status |
	extraBytes _ 0.
	status _ self primSocketConnectionStatus: socketHandle.
	[((status = Connected) or: [(status = ThisEndClosed)]) and:
	 [Time millisecondClockValue < deadline]] whileTrue: [
		self dataAvailable
			ifTrue: [extraBytes _ extraBytes + self discardReceivedData].
		semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
		status _ self primSocketConnectionStatus: socketHandle].

	extraBytes > 0
		ifTrue: [self inform: 'Discarded ', extraBytes printString, ' bytes while closing connection.'].

	^ status ~= Connected
! !

!OldSocket methodsFor: 'waiting' stamp: 'JMM 5/22/2000 22:05'!
waitForSendDoneUntil: deadline
	"Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not."

	| sendDone |
	[self isConnected & (sendDone _ self primSocketSendDone: socketHandle) not
			"Connection end and final data can happen fast, so test in this order"
		and: [Time millisecondClockValue < deadline]] whileTrue: [
			self writeSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)].

	^ sendDone! !

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

OldSocket class
	instanceVariableNames: ''!

!OldSocket class methodsFor: 'class initialization' stamp: 'ar 12/12/2001 19:12'!
initialize
	"Socket initialize"

	"Socket Types"
	TCPSocketType _ 0.
	UDPSocketType _ 1.

	"Socket Status Values"
	InvalidSocket _ -1.
	Unconnected _ 0.
	WaitingForConnection _ 1.
	Connected _ 2.
	OtherEndClosed _ 3.
	ThisEndClosed _ 4.

	RegistryThreshold _ 100. "# of sockets"! !


!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
clientServerTestUDP
	"Socket clientServerTestUDP"

	"Performa 6400/200, Linux-PPC 2.1.24:
		client/server UDP test done; time = 2820
		2500 packets, 10000000 bytes sent (3546 kBytes/sec)
		2500 packets, 10000000 bytes received (3546 kBytes/sec)
		4000 bytes/packet, 886 packets/sec, 0 packets dropped"

	| sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t |
	Transcript
		show: 'starting client/server UDP test';
		cr.
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	Transcript
		show: 'creating endpoints';
		cr.
	sock1 := self newUDP.	"the sender"
	sock2 := self newUDP.	"the recipient"
	sock2 setPort: 54321.
	sock1 setPeer: NetNameResolver localHostAddress port: sock2 port.
	Transcript
		show: 'endpoints created';
		cr.
	bytesToSend := 10000000.
	sendBuf := String new: 4000 withAll: $x.
	receiveBuf := String new: 50000.
	done := false.
	bytesSent := bytesReceived := packetsSent := packetsReceived := 0.
	t := Time millisecondsToRun: 
					[[done] whileFalse: 
							[(sock1 sendDone and: [bytesSent < bytesToSend]) 
								ifTrue: 
									[packetsSent := packetsSent + 1.
									bytesSent := bytesSent + (sock1 sendData: sendBuf)].
							sock2 dataAvailable 
								ifTrue: 
									[packetsReceived := packetsReceived + 1.
									bytesReceived := bytesReceived + (sock2 receiveDataInto: receiveBuf)].
							done := bytesSent >= bytesToSend].
					sock1 waitForSendDoneUntil: self standardDeadline.
					bytesReceived := bytesReceived + sock2 discardReceivedData].
	Transcript
		show: 'closing endpoints';
		cr.
	sock1 close.
	sock2 close.
	sock1 destroy.
	sock2 destroy.
	Transcript
		show: 'client/server UDP test done; time = ' , t printString;
		cr.
	Transcript
		show: packetsSent printString , ' packets, ' , bytesSent printString 
					, ' bytes sent (' , (bytesSent * 1000 // t) printString 
					, ' Bytes/sec)';
		cr.
	Transcript
		show: packetsReceived printString , ' packets, ' 
					, bytesReceived printString , ' bytes received (' 
					, (bytesReceived * 1000 // t) printString , ' Bytes/sec)';
		cr.
	Transcript
		show: (bytesSent // packetsSent) printString , ' bytes/packet, ' 
					, (packetsReceived * 1000 // t) printString , ' packets/sec, ' 
					, (packetsSent - packetsReceived) printString , ' packets dropped';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
clientServerTestUDP2
	"Socket clientServerTestUDP2"

	| sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t datagramInfo |
	Transcript
		show: 'starting client/server UDP test';
		cr.
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	Transcript
		show: 'creating endpoints';
		cr.
	sock1 := self newUDP.	"the sender"
	sock2 := self newUDP.	"the recipient"
	sock2 setPort: 54321.
	Transcript
		show: 'endpoints created';
		cr.
	bytesToSend := 100000000.
	sendBuf := String new: 4000 withAll: $x.
	receiveBuf := String new: 2000.
	done := false.
	bytesSent := bytesReceived := packetsSent := packetsReceived := 0.
	t := Time millisecondsToRun: 
					[[done] whileFalse: 
							[(sock1 sendDone and: [bytesSent < bytesToSend]) 
								ifTrue: 
									[packetsSent := packetsSent + 1.
									bytesSent := bytesSent + (sock1 
														sendData: sendBuf
														toHost: NetNameResolver localHostAddress
														port: sock2 port)].
							sock2 dataAvailable 
								ifTrue: 
									[packetsReceived := packetsReceived + 1.
									datagramInfo := sock2 receiveUDPDataInto: receiveBuf.
									bytesReceived := bytesReceived + (datagramInfo at: 1)].
							done := bytesSent >= bytesToSend].
					sock1 waitForSendDoneUntil: self standardDeadline.
					bytesReceived := bytesReceived + sock2 discardReceivedData].
	Transcript
		show: 'closing endpoints';
		cr.
	sock1 close.
	sock2 close.
	sock1 destroy.
	sock2 destroy.
	Transcript
		show: 'client/server UDP test done; time = ' , t printString;
		cr.
	Transcript
		show: packetsSent printString , ' packets, ' , bytesSent printString 
					, ' bytes sent (' , (bytesSent * 1000 // t) printString 
					, ' Bytes/sec)';
		cr.
	Transcript
		show: packetsReceived printString , ' packets, ' 
					, bytesReceived printString , ' bytes received (' 
					, (bytesReceived * 1000 // t) printString , ' Bytes/sec)';
		cr.
	Transcript
		show: (bytesSent // packetsSent) printString , ' bytes/packet, ' 
					, (packetsReceived * 1000 // t) printString , ' packets/sec, ' 
					, (packetsSent - packetsReceived) printString , ' packets dropped';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'rbb 3/1/2005 11:02'!
remoteTestClientTCP
	"FIRST start up another image, and execute: Socket remoteTestServerTCP.
	THEN come back to this image and execute:"

	"Socket remoteTestClientTCP"

	"Performa 6400/200, Linux-PPC 2.1.24, both images on same CPU:
		remoteClient TCP test done; time = 5680
		250 packets, 1000000 bytes sent (176 kBytes/sec)
		60 packets, 1000000 bytes received (176 kBytes/sec)"

	| socket bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t serverName |
	Transcript
		show: 'starting client/server TCP test';
		cr.
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	socket := self newTCP.
	serverName := UIManager default request: 'What is your remote Test Server?'
				initialAnswer: ''.
	socket connectTo: (NetNameResolver addressFromString: serverName)
		port: 54321.
	socket waitForConnectionUntil: self standardDeadline.
	Transcript
		show: 'client endpoint created';
		cr.
	bytesToSend := 1000000.
	sendBuf := String new: 4000 withAll: $x.
	receiveBuf := String new: 50000.
	done := false.
	bytesSent := bytesReceived := packetsSent := packetsReceived := 0.
	t := Time millisecondsToRun: 
					[[done] whileFalse: 
							[(socket sendDone and: [bytesSent < bytesToSend]) 
								ifTrue: 
									[packetsSent := packetsSent + 1.
									bytesSent := bytesSent + (socket sendData: sendBuf)].
							socket dataAvailable 
								ifTrue: 
									[packetsReceived := packetsReceived + 1.
									bytesReceived := bytesReceived + (socket receiveDataInto: receiveBuf)].
							done := bytesSent >= bytesToSend].
					[bytesReceived < bytesToSend] whileTrue: 
							[socket dataAvailable 
								ifTrue: 
									[packetsReceived := packetsReceived + 1.
									bytesReceived := bytesReceived + (socket receiveDataInto: receiveBuf)]]].
	socket closeAndDestroy.
	Transcript
		show: 'remoteClient TCP test done; time = ' , t printString;
		cr.
	Transcript
		show: packetsSent printString , ' packets, ' , bytesSent printString 
					, ' bytes sent (' , (bytesSent * 1000 // t) printString 
					, ' bytes/sec)';
		cr.
	Transcript
		show: packetsReceived printString , ' packets, ' 
					, bytesReceived printString , ' bytes received (' 
					, (bytesReceived * 1000 // t) printString , ' bytes/sec)';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'rbb 3/1/2005 11:02'!
remoteTestClientTCPOpenClose1000
	"Socket remoteTestClientTCPOpenClose1000"

	| number t1 socket serverName |
	Transcript
		show: 'starting client/server TCP test';
		cr.
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	number := 1000.
	serverName := UIManager default request: 'What is your remote Test Server?'
				initialAnswer: ''.
	t1 := Time millisecondsToRun: 
					[number timesRepeat: 
							[socket := self newTCP.
							socket connectTo: (NetNameResolver addressFromString: serverName)
								port: 54321.
							socket waitForConnectionUntil: self standardDeadline.
							socket closeAndDestroy]].
	Transcript
		cr;
		show: 'connects/close per second ' , (number / t1 * 1000.0) printString;
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'rbb 3/1/2005 11:03'!
remoteTestClientTCPOpenClosePutGet
	"Socket remoteTestClientTCPOpenClosePutGet"

	| checkLength number bytesExpected sendBuf receiveBuf t1 socket bytesReceived serverName |
	Transcript
		show: 'starting client/server TCP test';
		cr.
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	serverName := UIManager default request: 'What is your remote Test Server?'
				initialAnswer: ''.
	number := 1000.
	bytesExpected := 20000.
	sendBuf := String new: 80 withAll: $x.
	receiveBuf := String new: 50000.
	t1 := Time millisecondsToRun: 
					[number timesRepeat: 
							[socket := self newTCP.
							socket connectTo: (NetNameResolver addressFromString: serverName)
								port: 54321.
							socket waitForConnectionUntil: self standardDeadline.
							socket sendData: sendBuf.
							socket waitForSendDoneUntil: (self deadlineSecs: 5).
							socket waitForDataUntil: (self deadlineSecs: 5).
							bytesReceived := 0.
							[bytesReceived < bytesExpected] whileTrue: 
									[checkLength := socket receiveDataInto: receiveBuf.
									bytesReceived := bytesReceived + checkLength].
							socket closeAndDestroy]].
	Transcript
		cr;
		show: 'connects/get/put/close per second ' 
					, (number / t1 * 1000.0) printString;
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'rbb 3/1/2005 11:03'!
remoteTestClientUDP
	"FIRST start up another image, and execute: Socket remoteTestServerUDP.
	THEN come back to this image and execute:"

	"Socket remoteTestClientUDP"

	"Performa 6400/200, Linux-PPC 2.1.24:
		remoteClient UDP test done; time = 4580
		2500 packets, 10000000 bytes sent (2183 kBytes/sec)
		180 packets, 720000 bytes received (157 kBytes/sec)
		4000 bytes/packet, 39 packets/sec, 2320 packets dropped"

	| socket bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t serverName |
	Transcript
		show: 'starting client/server UDP test';
		cr.
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	serverName := UIManager default request: 'What is your remote Test Server?'
				initialAnswer: ''.
	socket := self newUDP.
	socket setPeer: (NetNameResolver addressFromString: serverName) port: 54321.
	Transcript
		show: 'client endpoint created';
		cr.
	bytesToSend := 10000000.
	sendBuf := String new: 4000 withAll: $x.
	receiveBuf := String new: 4000.
	done := false.
	bytesSent := bytesReceived := packetsSent := packetsReceived := 0.
	t := Time millisecondsToRun: 
					[[done] whileFalse: 
							[(socket sendDone and: [bytesSent < bytesToSend]) 
								ifTrue: 
									[packetsSent := packetsSent + 1.
									bytesSent := bytesSent + (socket sendData: sendBuf)].
							socket dataAvailable 
								ifTrue: 
									[packetsReceived := packetsReceived + 1.
									bytesReceived := bytesReceived + (socket receiveDataInto: receiveBuf)].
							done := bytesSent >= bytesToSend].
					
					[socket waitForDataUntil: (self deadlineSecs: 1).
					socket dataAvailable] 
							whileTrue: 
								[packetsReceived := packetsReceived + 1.
								bytesReceived := bytesReceived + (socket receiveDataInto: receiveBuf)]].
	socket closeAndDestroy.
	Transcript
		show: 'remoteClient UDP test done; time = ' , t printString;
		cr.
	Transcript
		show: packetsSent printString , ' packets, ' , bytesSent printString 
					, ' bytes sent (' , (bytesSent * 1000 // t) printString 
					, ' bytes/sec)';
		cr.
	Transcript
		show: packetsReceived printString , ' packets, ' 
					, bytesReceived printString , ' bytes received (' 
					, (bytesReceived * 1000 // t) printString , ' bytes/sec)';
		cr.
	Transcript
		show: (bytesSent // packetsSent) printString , ' bytes/packet, ' 
					, (packetsReceived * 1000 // t) printString , ' packets/sec, ' 
					, (packetsSent - packetsReceived) printString , ' packets dropped';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
remoteTestServerTCP
	"See remoteTestClientTCP for instructions on running this method."

	"OldSocket remoteTestServerTCP"

	| socket client buffer n |
	Transcript show: 'initializing network ... '.
	self initializeNetwork.
	Transcript
		show: 'ok';
		cr.
	socket := OldSocket newTCP.
	socket 
		listenOn: 54321
		backlogSize: 5
		interface: (NetNameResolver addressFromString: '127.0.0.1').	"or: 0.0.0.0"
	Transcript
		show: 'server endpoint created -- run client test in other image';
		cr.
	buffer := String new: 4000.
	socket waitForConnectionUntil: self standardDeadline.
	client := socket accept.
	[client isConnected] whileTrue: 
			[client dataAvailable 
				ifTrue: 
					[n := client receiveDataInto: buffer.
					client sendData: buffer count: n]].
	client closeAndDestroy.
	socket closeAndDestroy.
	Transcript
		cr;
		show: 'server endpoint destroyed';
		cr.
	^socket! !

!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
remoteTestServerTCPOpenClose1000
	"The version of #remoteTestServerTCPOpenClose1000 using the BSD style accept() mechanism."

	"Socket remoteTestServerTCPOpenClose1000"

	| socket server |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	server := self newTCP.
	server listenOn: 54321 backlogSize: 20.
	server isValid ifFalse: [self error: 'Accept() is not supported'].
	Transcript
		show: 'server endpoint created -- run client test in other image';
		cr.
	1000 timesRepeat: 
			[socket := server waitForAcceptUntil: (self deadlineSecs: 300).
			socket closeAndDestroy].
	server closeAndDestroy.
	Transcript
		cr;
		show: 'server endpoint destroyed';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
remoteTestServerTCPOpenClosePutGet
	"The version of #remoteTestServerTCPOpenClosePutGet using the BSD style accept() mechanism."

	"Socket remoteTestServerTCPOpenClosePutGet"

	| socket server bytesIWantToSend bytesExpected receiveBuf sendBuf checkLength |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	server := self newTCP.
	server listenOn: 54321 backlogSize: 20.
	server isValid ifFalse: [self error: 'Accept() is not supported'].
	Transcript
		show: 'server endpoint created -- run client test in other image';
		cr.
	bytesIWantToSend := 20000.
	bytesExpected := 80.
	receiveBuf := String new: 40000.
	sendBuf := String new: bytesIWantToSend withAll: $x.
	1000 timesRepeat: 
			[socket := server waitForAcceptUntil: (self deadlineSecs: 300).
			socket waitForDataUntil: (self deadlineSecs: 5).
			checkLength := socket receiveDataInto: receiveBuf.
			checkLength ~= bytesExpected ifTrue: [self halt].
			socket sendData: sendBuf.
			socket waitForSendDoneUntil: (self deadlineSecs: 5).
			socket closeAndDestroy].
	server closeAndDestroy.
	Transcript
		cr;
		show: 'server endpoint destroyed';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
remoteTestServerTCPUsingAccept
	"The version of #remoteTestServer using the BSD style accept() mechanism."

	"Socket remoteTestServerTCPUsingAccept"

	| socket buffer n server |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	server := self newTCP.
	server listenOn: 54321 backlogSize: 4.
	server isValid ifFalse: [self error: 'Accept() is not supported'].
	Transcript
		show: 'server endpoint created -- run client test in other image';
		cr.
	buffer := String new: 40000.
	10 timesRepeat: 
			[socket := server waitForAcceptUntil: (self deadlineSecs: 300).
			[socket isConnected] whileTrue: 
					[socket dataAvailable 
						ifTrue: 
							[n := socket receiveDataInto: buffer.
							socket sendData: buffer count: n]]].
	socket closeAndDestroy.
	server closeAndDestroy.
	Transcript
		cr;
		show: 'server endpoint destroyed';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
remoteTestServerUDP
	"See remoteTestClientUDP for instructions on running this method."

	"Socket remoteTestServerUDP"

	| socket buffer n |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	socket := self newUDP.
	socket setPort: 54321.
	Transcript
		show: 'server endpoint created -- run client test in other image';
		cr.
	buffer := String new: 4000.
	[true] whileTrue: 
			[socket dataAvailable 
				ifTrue: 
					[n := socket receiveDataInto: buffer.
					socket sendData: buffer count: n]]! !

!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
remoteTestServerUDP2
	"See remoteTestClientUDP for instructions on running this method."

	"Socket remoteTestServerUDP2"

	| socket buffer datagramInfo |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	socket := self newUDP.
	socket setPort: 54321.
	Transcript
		show: 'server endpoint created -- run client test in other image';
		cr.
	buffer := String new: 65000.
	[true] whileTrue: 
			[socket dataAvailable 
				ifTrue: 
					[datagramInfo := socket receiveUDPDataInto: buffer.
					Transcript
						show: datagramInfo printString;
						cr.
					socket sendData: buffer count: (datagramInfo at: 1)]]! !

!OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'!
remoteTestSinkTCP
	"See sendTest for instructions on running this method."

	"Socket remoteTestSinkTCP"

	| socket buffer n |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	socket := self newTCP.
	socket listenOn: 9.
	Transcript
		show: 'server endpoint created -- run client test in other image';
		cr.
	buffer := String new: 64000.
	socket waitForConnectionUntil: self standardDeadline.
	[socket isConnected] whileTrue: 
			[socket dataAvailable ifTrue: [n := socket receiveDataInto: buffer]].
	socket closeAndDestroy.
	Transcript
		cr;
		show: 'sink endpoint destroyed';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'rbb 3/1/2005 11:03'!
timeTest
	"OldSocket timeTest"

	| serverName serverAddr s |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	serverName := UIManager default request: 'What is your time server?'
				initialAnswer: 'localhost'.
	serverName isEmpty 
		ifTrue: 
			[^Transcript
				show: 'never mind';
				cr].
	serverAddr := NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil 
		ifTrue: [self error: 'Could not find the address for ' , serverName].
	s := self new.
	Transcript
		show: '---------- Connecting ----------';
		cr.
	s connectTo: serverAddr port: 13.	"13 is the 'daytime' port number"
	s waitForConnectionUntil: (self deadlineSecs: 1).
	Transcript show: 'the time server reports: ' , s getResponseNoLF.
	s closeAndDestroy.
	Transcript
		show: '---------- Connection Closed ----------';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'rbb 3/1/2005 11:03'!
timeTestUDP
	"Socket timeTestUDP"

	| serverName serverAddr s |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	serverName := UIManager default request: 'What is your time server?'
				initialAnswer: 'localhost'.
	serverName isEmpty 
		ifTrue: 
			[^Transcript
				show: 'never mind';
				cr].
	serverAddr := NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil 
		ifTrue: [self error: 'Could not find the address for ' , serverName].
	s := self newUDP.	"a 'random' port number will be allocated by the system"
	"Send a packet to the daytime port and it will reply with the current date."
	Transcript
		show: '---------- Sending datagram from port ' , s port printString 
					, ' ----------';
		cr.
	s 
		sendData: '!!'
		toHost: serverAddr
		port: 13.	"13 is the daytime service"
	Transcript show: 'the time server reports: ' , s getResponseNoLF.
	s closeAndDestroy.
	Transcript
		show: '---------- Socket closed ----------';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'rbb 3/1/2005 11:03'!
timeTestUDP2
	"Socket timeTestUDP2"

	| serverName serverAddr s |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	serverName := UIManager default request: 'What is your time server?'
				initialAnswer: 'localhost'.
	serverName isEmpty 
		ifTrue: 
			[^Transcript
				show: 'never mind';
				cr].
	serverAddr := NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil 
		ifTrue: [self error: 'Could not find the address for ' , serverName].
	s := self newUDP.
	"The following associates a port with the UDP socket, but does NOT create a connectable endpoint"
	s setPort: 54321.
	"Send a packet to the daytime port and it will reply with the current date."
	Transcript
		show: '---------- Sending datagram from port ' , s port printString 
					, ' ----------';
		cr.
	s 
		sendData: '!!'
		toHost: serverAddr
		port: 13.
	Transcript show: 'the time server reports: ' , s getResponseNoLF.
	s closeAndDestroy.
	Transcript
		show: '---------- Socket closed ----------';
		cr! !

!OldSocket class methodsFor: 'examples' stamp: 'rbb 3/1/2005 11:03'!
timeTestUDP3
	"Socket timeTestUDP3"

	| serverName serverAddr s |
	Transcript show: 'initializing network ... '.
	self initializeNetworkIfFail: [^Transcript show: 'failed'].
	Transcript
		show: 'ok';
		cr.
	serverName := UIManager default request: 'What is your time server?'
				initialAnswer: 'localhost'.
	serverName isEmpty 
		ifTrue: 
			[^Transcript
				show: 'never mind';
				cr].
	serverAddr := NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil 
		ifTrue: [self error: 'Could not find the address for ' , serverName].
	s := self newUDP.
	"The following associates a port with the UDP socket, but does NOT create a connectable endpoint"
	s setPort: self wildcardPort.	"explicitly request a default port number"
	"Send a packet to the daytime port and it will reply with the current date."
	Transcript
		show: '---------- Sending datagram from port ' , s port printString 
					, ' ----------';
		cr.
	s 
		sendData: '!!'
		toHost: serverAddr
		port: 13.
	Transcript show: 'the time server reports: ' , s getResponseNoLF.
	s closeAndDestroy.
	Transcript
		show: '---------- Socket closed ----------';
		cr! !


!OldSocket class methodsFor: 'instance creation' stamp: 'ls 9/24/1999 09:45'!
acceptFrom: aSocket
	^[ super new acceptFrom: aSocket ]
		repeatWithGCIf: [ :sock | sock isValid not ]! !

!OldSocket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:15'!
createIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."
	"Note: The default creates a TCP socket"
	^self tcpCreateIfFail: failBlock! !

!OldSocket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:13'!
new
	"Return a new, unconnected Socket. Note that since socket creation may fail, it is safer to use the method createIfFail: to handle such failures gracefully; this method is primarily for backward compatibility and may be disallowed in a future release."
	"Note: The default creates a TCP socket - this is also backward compatibility."
	^self newTCP! !

!OldSocket class methodsFor: 'instance creation' stamp: 'ls 9/24/1999 10:19'!
newTCP
	"Create a socket and initialise it for TCP"
	^[ super new initialize: TCPSocketType ]
		repeatWithGCIf: [ :socket | socket isValid not ]! !

!OldSocket class methodsFor: 'instance creation' stamp: 'ls 9/24/1999 09:44'!
newUDP
	"Create a socket and initialise it for UDP"
	^[ super new initialize: UDPSocketType ]
		repeatWithGCIf: [ :socket | socket isValid not ]! !

!OldSocket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:14'!
tcpCreateIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."

	| sock |
	sock _ super new initialize: TCPSocketType.
	sock isValid ifFalse: [^ failBlock value].
	^ sock
! !

!OldSocket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:14'!
udpCreateIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."

	| sock |
	sock _ super new initialize: UDPSocketType.
	sock isValid ifFalse: [^ failBlock value].
	^ sock
! !


!OldSocket class methodsFor: 'network initialization' stamp: 'nk 2/24/2005 14:38'!
ensureNetworkConnected
	"Try to ensure that an intermittent network connection, such as a dialup or ISDN line, is actually connected. This is necessary to make sure a server is visible in order to accept an incoming connection."

	"Socket ensureNetworkConnected"

	self initializeNetwork.
	Utilities informUser: 'Contacting domain name server...'
		during: 
			[NetNameResolver addressForName: 'bogusNameToForceDNSToBeConsulted.org'
				timeout: 30]! !

!OldSocket class methodsFor: 'network initialization' stamp: 'mir 11/14/2002 19:36'!
initializeNetwork
	"Initialize the network drivers and the NetNameResolver. Do nothing if the network is already initialized."
	"Note: The network must be re-initialized every time Squeak starts up, so applications that persist across snapshots should be prepared to re-initialize the network as needed. Such applications should call 'Socket initializeNetwork' before every network transaction. "

	NetNameResolver initializeNetwork! !

!OldSocket class methodsFor: 'network initialization' stamp: 'mir 11/14/2002 19:36'!
initializeNetworkIfFail: failBlock
	"Initialize the network drivers. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails, perhaps because this computer isn't currently connected to a network."

	NetNameResolver initializeNetwork! !


!OldSocket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'!
register: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry add: anObject! !

!OldSocket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'!
registry
	WeakArray isFinalizationSupported ifFalse:[^nil].
	^Registry isNil
		ifTrue:[Registry := WeakRegistry new]
		ifFalse:[Registry].! !

!OldSocket class methodsFor: 'registry' stamp: 'ar 12/12/2001 19:12'!
registryThreshold
	"Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails."
	^RegistryThreshold! !

!OldSocket class methodsFor: 'registry' stamp: 'ar 12/12/2001 19:12'!
registryThreshold: aNumber
	"Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails."
	RegistryThreshold _ aNumber! !

!OldSocket class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:22'!
unregister: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry remove: anObject ifAbsent:[]! !



!OldSocket class methodsFor: 'utilities' stamp: 'tk 4/9/98 15:54'!
deadServer

	^ DeadServer! !

!OldSocket class methodsFor: 'utilities' stamp: 'tk 4/9/98 15:56'!
deadServer: aStringOrNil
	"Keep the machine name of the most recently encoutered non-responding machine.  Next time the user can move it to the last in a list of servers to try."

	DeadServer _ aStringOrNil! !

!OldSocket class methodsFor: 'utilities' stamp: 'jm 9/15/97 06:56'!
deadlineSecs: secs
	"Return a deadline time the given number of seconds from now."

	^ Time millisecondClockValue + (secs * 1000)
! !

!OldSocket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 12:13'!
nameForWellKnownTCPPort: portNum
	"Answer the name for the given well-known TCP port number. Answer a string containing the port number if it isn't well-known."

	| portList entry |
	portList _ #(
		(7 'echo') (9 'discard') (13 'time') (19 'characterGenerator')
		(21 'ftp') (23 'telnet') (25 'smtp')
		(80 'http') (110 'pop3') (119 'nntp')).
	entry _ portList detect: [:pair | pair first = portNum] ifNone: [^ 'port-', portNum printString].
	^ entry last
! !

!OldSocket class methodsFor: 'utilities' stamp: 'nk 2/24/2005 14:38'!
ping: hostName 
	"Ping the given host. Useful for checking network connectivity. The host must be running a TCP echo server."

	"Socket ping: 'squeak.cs.uiuc.edu'"

	| tcpPort sock serverAddr startTime echoTime |
	tcpPort := 7.	"7 = echo port, 13 = time port, 19 = character generator port"
	self initializeNetwork.
	serverAddr := NetNameResolver addressForName: hostName timeout: 10.
	serverAddr = nil 
		ifTrue: [^self inform: 'Could not find an address for ' , hostName].
	sock := self new.
	sock connectTo: serverAddr port: tcpPort.
	
	[sock waitForConnectionUntil: (self deadlineSecs: 10).
	sock isConnected] 
			whileFalse: 
				[(self confirm: 'Continue to wait for connection to ' , hostName , '?') 
					ifFalse: 
						[sock destroy.
						^self]].
	sock sendData: 'echo!!'.
	startTime := Time millisecondClockValue.
	
	[sock waitForDataUntil: (self deadlineSecs: 15).
	sock dataAvailable] 
			whileFalse: 
				[(self confirm: 'Packet sent but no echo yet; keep waiting?') 
					ifFalse: 
						[sock destroy.
						^self]].
	echoTime := Time millisecondClockValue - startTime.
	sock destroy.
	self inform: hostName , ' responded in ' , echoTime printString 
				, ' milliseconds'! !

!OldSocket class methodsFor: 'utilities' stamp: 'nk 2/24/2005 14:38'!
pingPorts: portList on: hostName timeOutSecs: timeOutSecs 
	"Attempt to connect to each of the given sockets on the given host. Wait at most timeOutSecs for the connections to be established. Answer an array of strings indicating the available ports."

	"Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: 'squeak.cs.uiuc.edu' timeOutSecs: 15"

	| serverAddr sockets sock deadline done unconnectedCount connectedCount waitingCount result |
	self initializeNetwork.
	serverAddr := NetNameResolver addressForName: hostName timeout: 10.
	serverAddr = nil 
		ifTrue: 
			[self inform: 'Could not find an address for ' , hostName.
			^#()].
	sockets := portList collect: 
					[:portNum | 
					sock := self new.
					sock connectTo: serverAddr port: portNum].
	deadline := self deadlineSecs: timeOutSecs.
	done := false.
	[done] whileFalse: 
			[unconnectedCount := 0.
			connectedCount := 0.
			waitingCount := 0.
			sockets do: 
					[:s | 
					s isUnconnectedOrInvalid 
						ifTrue: [unconnectedCount := unconnectedCount + 1]
						ifFalse: 
							[s isConnected ifTrue: [connectedCount := connectedCount + 1].
							s isWaitingForConnection ifTrue: [waitingCount := waitingCount + 1]]].
			waitingCount = 0 ifTrue: [done := true].
			connectedCount = sockets size ifTrue: [done := true].
			Time millisecondClockValue > deadline ifTrue: [done := true]].
	result := (sockets select: [:s | s isConnected]) 
				collect: [:s | self nameForWellKnownTCPPort: s remotePort].
	sockets do: [:s | s destroy].
	^result! !

!OldSocket class methodsFor: 'utilities' stamp: 'nk 2/24/2005 14:38'!
pingPortsOn: hostName 
	"Attempt to connect to a set of well-known sockets on the given host, and answer the names of the available ports."

	"Socket pingPortsOn: 'www.disney.com'"

	^self 
		pingPorts: #(7 13 19 21 23 25 80 110 119)
		on: hostName
		timeOutSecs: 20! !

!OldSocket class methodsFor: 'utilities' stamp: 'jm 9/15/97 06:56'!
standardDeadline
	"Return a default deadline time some seconds into the future."

	^ self deadlineSecs: 45
! !

!OldSocket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'!
wildcardAddress
	"Answer a don't-care address for use with UDP sockets."

	^ByteArray new: 4		"0.0.0.0"! !

!OldSocket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'!
wildcardPort
	"Answer a don't-care port for use with UDP sockets.  (The system will allocate an
	unused port number to the socket.)"

	^0! !
Switch subclass: #OneOnSwitch
	instanceVariableNames: 'connection'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Menus'!
!OneOnSwitch commentStamp: '<historical>' prior: 0!
I am a kind of Switch that can be connected to some related object, typically to a collection of my instances. When my instance is created, its connection is set to a particular object. When the object changes because an Switch it refers to is turned on, an update message is broadcasted. All the connected OneOnSwitches, except the changed one, turn off. This allows OneOnSwitches to maintain the constraint that at most one of them will be on at any time. OneOnSwitches can thus be made to act like "car radio" switches.!


!OneOnSwitch methodsFor: 'connection'!
connection
	"Answer the object that connects the receiver to other Switches."

	^connection! !

!OneOnSwitch methodsFor: 'connection'!
connection: anObject 
	"Set anObject to be the connection among two or more Switches. Make the 
	receiver a dependent of the argument, anObject."

	connection _ anObject.
	connection addDependent: self! !

!OneOnSwitch methodsFor: 'connection'!
isConnectionSet
	"Answer whether the receiver is connected to an object that coordinates 
	updates among switches."

	connection == nil
		ifTrue: [^false]
		ifFalse: [^true]! !

!OneOnSwitch methodsFor: 'connection'!
notifyConnection
	"Send the receiver's connection (if it exists) the message 'changed: self' in 
	order for the connection to broadcast the change to other objects 
	connected by the connection."
	
	self isConnectionSet ifTrue: [self connection changed: self]! !


!OneOnSwitch methodsFor: 'initialize-release'!
release

	super release.
	self isConnectionSet ifTrue: [connection removeDependent: self]! !


!OneOnSwitch methodsFor: 'state'!
turnOn
	"Does nothing if it is already on. If it is not, it is set to 'on', its
	dependents are 	notified of the change, its connection is notified, and
	its action is executed."

	self isOff
		ifTrue: 
			[on _ true.
			self changed.
			self notifyConnection.
			self doAction: onAction]! !


!OneOnSwitch methodsFor: 'updating'!
update: aOneOnSwitch 
	"Does nothing if aOneOnSwitch is identical to this object. If it is not, this 
	object is turned off. This message is sent by the connection (an Object)
	when some related OneOnSwitch (possibly this one) has changed. This
	allows a group of related OneOnSwitches to maintain the constraint that
	at most one will be on at any time."

	self ~~ aOneOnSwitch ifTrue: [self turnOff]! !
URI subclass: #OpaqueURI
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-URI'!

!OpaqueURI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'!
isOpaque
	^true! !
SmallLandColorTheme subclass: #OrangeSmallLandColorTheme
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!OrangeSmallLandColorTheme methodsFor: 'initialization' stamp: 'dgd 3/12/2006 13:25'!
baseColors
"
OrangeSmallLandColorTheme apply.
"
	^ Array
		with: (Color fromArray: #(0.8 0.4 0.0 ))
		with: (Color fromArray: #(1.0 0.8 0.0 ))
		with: (Color fromArray: #(1.0 1.0 0.8 ))! !
SequenceableCollection subclass: #OrderedCollection
	instanceVariableNames: 'array firstIndex lastIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!OrderedCollection commentStamp: '<historical>' prior: 0!
I represent a collection of objects ordered by the collector.!


!OrderedCollection methodsFor: 'accessing'!
at: anInteger 
	"Answer my element at index anInteger. at: is used by a knowledgeable
	client to access an existing element"

	(anInteger < 1 or: [anInteger + firstIndex - 1 > lastIndex])
		ifTrue: [self errorNoSuchElement]
		ifFalse: [^ array at: anInteger + firstIndex - 1]! !

!OrderedCollection methodsFor: 'accessing'!
at: anInteger put: anObject 
	"Put anObject at element index anInteger. at:put: cannot be used to
	append, front or back, to an ordered collection; it is used by a
	knowledgeable client to replace an element."

	| index |
	index _ anInteger asInteger.
	(index < 1 or: [index + firstIndex - 1 > lastIndex])
		ifTrue: [self errorNoSuchElement]
		ifFalse: [^array at: index + firstIndex - 1 put: anObject]! !

!OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:42'!
capacity
	"Answer the current capacity of the receiver."

	^ array size! !

!OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:39'!
size
	"Answer how many elements the receiver contains."

	^ lastIndex - firstIndex + 1! !


!OrderedCollection methodsFor: 'adding'!
add: newObject

	^self addLast: newObject! !

!OrderedCollection methodsFor: 'adding'!
add: newObject after: oldObject 
	"Add the argument, newObject, as an element of the receiver. Put it in 
	the sequence just succeeding oldObject. Answer newObject."
	
	| index |
	index _ self find: oldObject.
	self insert: newObject before: index + 1.
	^newObject! !

!OrderedCollection methodsFor: 'adding' stamp: 'di 3/15/1999 14:01'!
add: newObject afterIndex: index 
	"Add the argument, newObject, as an element of the receiver. Put it in 
	the sequence just after index. Answer newObject."

	self insert: newObject before: firstIndex + index.
	^ newObject! !

!OrderedCollection methodsFor: 'adding'!
add: newObject before: oldObject 
	"Add the argument, newObject, as an element of the receiver. Put it in 
	the sequence just preceding oldObject. Answer newObject."
	
	| index |
	index _ self find: oldObject.
	self insert: newObject before: index.
	^newObject! !

!OrderedCollection methodsFor: 'adding' stamp: 'BG 1/9/2004 12:30'!
add: newObject beforeIndex: index 
 "Add the argument, newObject, as an element of the receiver. Put it in 
 the sequence just before index. Answer newObject."

 self add: newObject afterIndex: index - 1.
 ^ newObject! !

!OrderedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 11:26'!
addAll: aCollection 
	"Add each element of aCollection at my end. Answer	aCollection."

	^ self addAllLast: aCollection! !

!OrderedCollection methodsFor: 'adding'!
addAllFirst: anOrderedCollection 
	"Add each element of anOrderedCollection at the beginning of the 
	receiver. Answer anOrderedCollection."

	anOrderedCollection reverseDo: [:each | self addFirst: each].
	^anOrderedCollection! !

!OrderedCollection methodsFor: 'adding' stamp: 'sw 3/1/2001 11:03'!
addAllFirstUnlessAlreadyPresent: anOrderedCollection 
	"Add each element of anOrderedCollection at the beginning of the receiver, preserving the order, but do not add any items that are already in the receiver.  Answer anOrderedCollection."

	anOrderedCollection reverseDo:
		[:each | (self includes: each) ifFalse: [self addFirst: each]].
	^ anOrderedCollection! !

!OrderedCollection methodsFor: 'adding'!
addAllLast: anOrderedCollection 
	"Add each element of anOrderedCollection at the end of the receiver. 
	Answer anOrderedCollection."

	anOrderedCollection do: [:each | self addLast: each].
	^anOrderedCollection! !

!OrderedCollection methodsFor: 'adding'!
addFirst: newObject 
	"Add newObject to the beginning of the receiver. Answer newObject."

	firstIndex = 1 ifTrue: [self makeRoomAtFirst].
	firstIndex _ firstIndex - 1.
	array at: firstIndex put: newObject.
	^ newObject! !

!OrderedCollection methodsFor: 'adding'!
addLast: newObject 
	"Add newObject to the end of the receiver. Answer newObject."

	lastIndex = array size ifTrue: [self makeRoomAtLast].
	lastIndex _ lastIndex + 1.
	array at: lastIndex put: newObject.
	^ newObject! !

!OrderedCollection methodsFor: 'adding' stamp: 'ajh 5/22/2003 12:03'!
at: index ifAbsentPut: block
	"Return value at index, however, if value does not exist (nil or out of bounds) then add block's value at index (growing self if necessary)"

	| v |
	index <= self size ifTrue: [
		^ (v _ self at: index)
			ifNotNil: [v]
			ifNil: [self at: index put: block value]
	].
	[self size < index] whileTrue: [self add: nil].
	^ self at: index put: block value! !

!OrderedCollection methodsFor: 'adding'!
grow
	"Become larger. Typically, a subclass has to override this if the subclass
	adds instance variables."
	| newArray |
	newArray _ Array new: self size + self growSize.
	newArray replaceFrom: 1 to: array size with: array startingAt: 1.
	array _ newArray! !

!OrderedCollection methodsFor: 'adding'!
growSize
	^ array size max: 2! !


!OrderedCollection methodsFor: 'copying'!
copyEmpty
	"Answer a copy of the receiver that contains no elements."

	^self species new! !

!OrderedCollection methodsFor: 'copying' stamp: 'di 12/12/2000 10:15'!
copyFrom: startIndex to: endIndex 
	"Answer a copy of the receiver that contains elements from position
	startIndex to endIndex."

	| targetCollection |
	endIndex < startIndex ifTrue: [^self species new: 0].
	targetCollection _ self species new: endIndex + 1 - startIndex.
	startIndex to: endIndex do: [:index | targetCollection addLast: (self at: index)].
	^ targetCollection! !

!OrderedCollection methodsFor: 'copying'!
copyReplaceFrom: start to: stop with: replacementCollection 
	"Answer a copy of the receiver with replacementCollection's elements in
	place of the receiver's start'th to stop'th elements. This does not expect
	a 1-1 map from replacementCollection to the start to stop elements, so it
	will do an insert or append."

	| newOrderedCollection delta startIndex stopIndex |
	"if start is less than 1, ignore stop and assume this is inserting at the front. 
	if start greater than self size, ignore stop and assume this is appending. 
	otherwise, it is replacing part of me and start and stop have to be within my 
	bounds. "
	delta _ 0.
	startIndex _ start.
	stopIndex _ stop.
	start < 1
		ifTrue: [startIndex _ stopIndex _ 0]
		ifFalse: [startIndex > self size
				ifTrue: [startIndex _ stopIndex _ self size + 1]
				ifFalse: 
					[(stopIndex < (startIndex - 1) or: [stopIndex > self size])
						ifTrue: [self errorOutOfBounds].
					delta _ stopIndex - startIndex + 1]].
	newOrderedCollection _ 
		self species new: self size + replacementCollection size - delta.
	1 to: startIndex - 1 do: [:index | newOrderedCollection add: (self at: index)].
	1 to: replacementCollection size do: 
		[:index | newOrderedCollection add: (replacementCollection at: index)].
	stopIndex + 1 to: self size do: [:index | newOrderedCollection add: (self at: index)].
	^newOrderedCollection! !

!OrderedCollection methodsFor: 'copying'!
copyWith: newElement 
	"Answer a copy of the receiver that is 1 bigger than the receiver and 
	includes the argument, newElement, at the end."

	| newCollection |
	newCollection _ self copy.
	newCollection add: newElement.
	^newCollection! !

!OrderedCollection methodsFor: 'copying' stamp: 'sw 1/26/96'!
reversed
	"Answer a copy of the receiver with element order reversed.  "
	| newCol |
	newCol _ self species new.
	self reverseDo:
		[:elem | newCol addLast: elem].
	^ newCol

"#(2 3 4 'fred') reversed"! !


!OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'!
collect: aBlock 
	"Evaluate aBlock with each of my elements as the argument. Collect the 
	resulting values into a collection that is like me. Answer the new 
	collection. Override superclass in order to use addLast:, not at:put:."

	| newCollection |
	newCollection _ self species new: self size.
	firstIndex to: lastIndex do:
		[:index |
		newCollection addLast: (aBlock value: (array at: index))].
	^ newCollection! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'bf 5/18/2000 17:34'!
collect: aBlock from: fromIndex to: toIndex
	"Override superclass in order to use addLast:, not at:put:."
	| result |
	(fromIndex < 1 or:[toIndex + firstIndex - 1 > lastIndex])
		ifTrue: [^self errorNoSuchElement].
	result _ self species new: toIndex - fromIndex + 1.
	firstIndex + fromIndex - 1 to: firstIndex + toIndex - 1 do:
		[:index | result addLast: (aBlock value: (array at: index))].
	^ result
! !

!OrderedCollection methodsFor: 'enumerating'!
do: aBlock 
	"Override the superclass for performance reasons."
	| index |
	index _ firstIndex.
	[index <= lastIndex]
		whileTrue: 
			[aBlock value: (array at: index).
			index _ index + 1]! !

!OrderedCollection methodsFor: 'enumerating'!
reverseDo: aBlock 
	"Override the superclass for performance reasons."
	| index |
	index _ lastIndex.
	[index >= firstIndex]
		whileTrue: 
			[aBlock value: (array at: index).
			index _ index - 1]! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:13'!
select: aBlock 
	"Evaluate aBlock with each of my elements as the argument. Collect into
	a new collection like the receiver, only those elements for which aBlock
	evaluates to true."

	| newCollection element |
	newCollection _ self copyEmpty.
	firstIndex to: lastIndex do:
		[:index |
		(aBlock value: (element _ array at: index))
			ifTrue: [newCollection addLast: element]].
	^ newCollection! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'!
with: otherCollection collect: twoArgBlock 
	"Collect and return the result of evaluating twoArgBlock with 
	corresponding elements from this collection and otherCollection."
	| result |
	otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
	result _ self species new: self size.
	1 to: self size do:
		[:index | result addLast: (twoArgBlock value: (self at: index)
									value: (otherCollection at: index))].
	^ result! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'bf 5/16/2000 16:30'!
withIndexCollect: elementAndIndexBlock 
	"Just like with:collect: except that the iteration index supplies the second argument to the block. Override superclass in order to use addLast:, not at:put:."

	| newCollection |
	newCollection _ self species new: self size.
	firstIndex to: lastIndex do:
		[:index |
		newCollection addLast: (elementAndIndexBlock
			value: (array at: index)
			value: index - firstIndex + 1)].
	^ newCollection! !


!OrderedCollection methodsFor: 'removing'!
remove: oldObject ifAbsent: absentBlock

	| index |
	index _ firstIndex.
	[index <= lastIndex]
		whileTrue: 
			[oldObject = (array at: index)
				ifTrue: 
					[self removeIndex: index.
					^ oldObject]
				ifFalse: [index _ index + 1]].
	^ absentBlock value! !

!OrderedCollection methodsFor: 'removing' stamp: 'raok 4/27/2001 15:35'!
removeAllSuchThat: aBlock 
	"Remove each element of the receiver for which aBlock evaluates to true.
	The method in Collection is O(N^2), this is O(N)."

	| n |
	n _ firstIndex.
	firstIndex to: lastIndex do: [:index |
	    (aBlock value: (array at: index)) ifFalse: [
			array at: n put: (array at: index).
			n _ n + 1]].
	n to: lastIndex do: [:index | array at: index put: nil].
	lastIndex _ n - 1! !

!OrderedCollection methodsFor: 'removing' stamp: 'ar 5/22/2000 12:19'!
removeAt: index
	| removed |
	removed _ self at: index.
	self removeIndex: index + firstIndex - 1.
	^removed! !

!OrderedCollection methodsFor: 'removing'!
removeFirst
	"Remove the first element of the receiver and answer it. If the receiver is 
	empty, create an error notification."
	| firstObject |
	self emptyCheck.
	firstObject _ array at: firstIndex.
	array at: firstIndex put: nil.
	firstIndex _ firstIndex + 1.
	^ firstObject! !

!OrderedCollection methodsFor: 'removing' stamp: 'ajh 6/22/2003 14:37'!
removeFirst: n
	"Remove first n object into an array"

	| list |
	list _ Array new: n.
	1 to: n do: [:i |
		list at: i put: self removeFirst].
	^ list! !

!OrderedCollection methodsFor: 'removing'!
removeLast
	"Remove the last element of the receiver and answer it. If the receiver is 
	empty, create an error notification."
	| lastObject |
	self emptyCheck.
	lastObject _ array at: lastIndex.
	array at: lastIndex put: nil.
	lastIndex _ lastIndex - 1.
	^ lastObject! !

!OrderedCollection methodsFor: 'removing' stamp: 'ajh 6/22/2003 14:36'!
removeLast: n
	"Remove last n object into an array with last in last position"

	| list |
	list _ Array new: n.
	n to: 1 by: -1 do: [:i |
		list at: i put: self removeLast].
	^ list! !


!OrderedCollection methodsFor: 'testing' stamp: 'bf 8/20/1999 15:08'!
hasContentsInExplorer

	^self isEmpty not! !


!OrderedCollection methodsFor: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:33'!
inspectorClass 
	"Answer the class of the inspector to be used on the receiver.  Called by inspect; 
	use basicInspect to get a normal (less useful) type of inspector."

	^OrderedCollectionInspector! !


!OrderedCollection methodsFor: 'private'!
collector  "Private"
	^ array! !

!OrderedCollection methodsFor: 'private'!
errorConditionNotSatisfied

	self error: 'no element satisfies condition'! !

!OrderedCollection methodsFor: 'private'!
errorNoSuchElement

	self error: 'attempt to index non-existent element in an ordered collection'! !

!OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:26'!
find: oldObject
  "  This method answers an index in the range firstIndex .. lastIndex, which is meant for internal use only.
     Never use this method in your code, the methods for public use are:
        #indexOf:
        #indexOf:ifAbsent: "

	| index |
	index _ firstIndex.
	[index <= lastIndex]
		whileTrue:
			[(array at: index) = oldObject ifTrue: [^ index].
			index _ index + 1].
	self errorNotFound: oldObject! !

!OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:29'!
insert: anObject before: spot

  "  spot is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection. 
     Never use this method in your code, it is meant for private use by OrderedCollection only.
     The methods for use are:
        #add:before:   to insert an object before another object
        #add:beforeIndex:   to insert an object before a given position. "
	| "index" delta spotIndex|
	spotIndex _ spot.
	delta _ spotIndex - firstIndex.
	firstIndex = 1
		ifTrue: 
			[self makeRoomAtFirst.
			spotIndex _ firstIndex + delta].
	firstIndex _ firstIndex - 1.
	array
		replaceFrom: firstIndex
		to: spotIndex - 2
		with: array
		startingAt: firstIndex + 1.
	array at: spotIndex - 1 put: anObject.
"	index _ firstIndex _ firstIndex - 1.
	[index < (spotIndex - 1)]
		whileTrue: 
			[array at: index put: (array at: index + 1).
			index _ index + 1].
	array at: index put: anObject."
	^ anObject! !

!OrderedCollection methodsFor: 'private'!
makeRoomAtFirst
	| delta index |
	delta _ array size - self size.
	delta = 0 ifTrue: 
			[self grow.
			delta _ array size - self size].
	lastIndex = array size ifTrue: [^ self]. "just in case we got lucky"
	index _ array size.
	[index > delta]
		whileTrue: 
			[array at: index put: (array at: index - delta + firstIndex - 1).
			array at: index - delta + firstIndex - 1 put: nil.
			index _ index - 1].
	firstIndex _ delta + 1.
	lastIndex _ array size! !

!OrderedCollection methodsFor: 'private'!
makeRoomAtLast
	| newLast delta |
	newLast _ self size.
	array size - self size = 0 ifTrue: [self grow].
	(delta _ firstIndex - 1) = 0 ifTrue: [^ self].
	"we might be here under false premises or grow did the job for us"
	1 to: newLast do:
		[:index |
		array at: index put: (array at: index + delta).
		array at: index + delta put: nil].
	firstIndex _ 1.
	lastIndex _ newLast! !

!OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:28'!
removeIndex: removedIndex
  "  removedIndex is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection.
    Never use this method in your code, it is meant for private use by OrderedCollection only.
     The method for public use is:
        #removeAt: "

	array 
		replaceFrom: removedIndex 
		to: lastIndex - 1 
		with: array 
		startingAt: removedIndex+1.
	array at: lastIndex put: nil.
	lastIndex _ lastIndex - 1.! !

!OrderedCollection methodsFor: 'private' stamp: 'di 11/14/97 12:54'!
reset
	firstIndex _ array size // 3 max: 1.
	lastIndex _ firstIndex - 1! !

!OrderedCollection methodsFor: 'private' stamp: 'ar 4/16/1999 07:59'!
resetTo: index
	firstIndex _ index.
	lastIndex _ firstIndex - 1! !

!OrderedCollection methodsFor: 'private' stamp: 'di 11/14/97 12:54'!
setCollection: anArray
	array _ anArray.
	self reset! !

!OrderedCollection methodsFor: 'private' stamp: 'apb 10/15/2000 18:10'!
setContents: anArray
	array _ anArray.
	firstIndex _ 1.
	lastIndex _ array size.! !

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

OrderedCollection class
	instanceVariableNames: ''!

!OrderedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:41'!
new
	^ self new: 10! !

!OrderedCollection class methodsFor: 'instance creation' stamp: 'md 7/5/2005 15:16'!
new: anInteger 
	^ super basicNew setCollection: (Array new: anInteger)! !

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

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

"	OrderedCollection newFrom: {1. 2. 3}
	{1. 2. 3} as: OrderedCollection
	{4. 2. 7} as: SortedCollection
"! !

!OrderedCollection class methodsFor: 'instance creation' stamp: 'apb 10/15/2000 22:02'!
ofSize: n
	"Create a new collection of size n with nil as its elements.
	This method exists because OrderedCollection new: n creates an
	empty collection,  not one of size n."
	| collection |
	collection _ self new: n.
	collection setContents: (collection collector).
	^ collection
! !
Inspector subclass: #OrderedCollectionInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'dew 9/19/2001 03:27'!
fieldList
	object ifNil: [ ^ OrderedCollection new].
	^ self baseFieldList ,
		(object size <= (self i1 + self i2)
			ifTrue: [(1 to: object size)
						collect: [:i | i printString]]
			ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size)
						collect: [:i | i printString]])
"
OrderedCollection new inspect
(OrderedCollection newFrom: #(3 5 7 123)) inspect
(OrderedCollection newFrom: (1 to: 1000)) inspect
"! !

!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sw 9/16/97 22:38'!
replaceSelectionValue: anObject 
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. The value of the selected variable is set to the value, anObject."

	(selectionIndex - 2) <= object class instSize
		ifTrue: [^ super replaceSelectionValue: anObject].
	object at: self selectedObjectIndex put: anObject! !

!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
selectedObjectIndex
	"Answer the index of the inspectee's collection that the current selection refers to."

	| basicIndex |
	basicIndex := selectionIndex - 2 - object class instSize.
	^ (object size <= (self i1 + self i2)  or: [basicIndex <= self i1])
		ifTrue: [basicIndex]
		ifFalse: [object size - (self i1 + self i2) + basicIndex]! !

!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sw 9/16/97 22:39'!
selection
	"The receiver has a list of variables of its inspected object.
	One of these is selected. Answer the value of the selected variable."

	(selectionIndex - 2) <= object class instSize
		ifTrue: [^ super selection].
	^ object at: self selectedObjectIndex! !
ClassTestCase subclass: #OrderedCollectionTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Sequenceable'!
!OrderedCollectionTest commentStamp: 'BG 1/10/2004 22:07' prior: 0!
These test cases demonstrate addition of items into an OrderedCollection as well as item removal.

Some of the assertions are quite complicated and use a lot of collection protocol. Such methods do not test one single method, but protocol in general.!



!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 19:00'!
testAdd
	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l add: 88.
	self assert: (l =  #(1 2 3 4 88) asOrderedCollection).
	l add: 99.
	self assert: (l =  #(1 2 3 4 88 99) asOrderedCollection). 

! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 18:52'!
testAddAfter

	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l add: 88 after: 1.
	self assert: (l =  #(1 88 2 3 4) asOrderedCollection).
	l add: 99 after: 2.
	self assert: (l =  #(1 88 2 99 3 4) asOrderedCollection). 

! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 18:56'!
testAddAfterIndex

	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l add: 88 afterIndex: 1.
	self assert: (l =  #(1 88 2 3 4) asOrderedCollection).
	l add: 99 afterIndex: 2.
	self assert: (l =  #(1 88 99 2 3 4) asOrderedCollection). 

! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'sd 3/21/2006 22:36'!
testAddAll
	"Allows one to add each element of an orderedCollection at the end of another
	orderedCollection "
	"self run:#testAddAll" 
	
	| c1 c2 |
	c1 := #(1 2 3 4 ) asOrderedCollection.
	c2 := #(5 6 7 8 9 ) asOrderedCollection.
	c1 addAll: c2.
	self assert: c1 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'sd 3/21/2006 22:36'!
testAddAllFirst
	"Allows one to add each element of an orderedCollection at the beginning of another
	orderedCollection "
	"self run:#testAddAllFirst" 
	
	| c1 c2 |
	c1 := #(1 2 3 4 ) asOrderedCollection.
	c2 := #(5 6 7 8 9 ) asOrderedCollection.
	c2 addAllFirst: c1.
	self assert: c2 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'sd 3/21/2006 22:36'!
testAddAllFirstUnlessAlreadyPresent
	"Allows one to add each element of an orderedCollection at the beginning of
	another orderedCollection preserving the order but no duplicate element"
	"self run:#testAddAllFirstUnlessAlreadyPresent" 
	
	| c1 c2 c3 |
	c1 := #(1 2 3 4 ) asOrderedCollection.
	c2 := #(5 6 7 8 9 ) asOrderedCollection.
	c3 := #(0 1 ) asOrderedCollection.
	c2 addAllFirstUnlessAlreadyPresent: c1.
	self assert: c2 = #(1 2 3 4 5 6 7 8 9 ) asOrderedCollection.
	c1 addAllFirstUnlessAlreadyPresent: c3.
	self deny: c1 = #(0 1 1 2 3 4 ) asOrderedCollection.
	self assert: c1 = #(0 1 2 3 4 ) asOrderedCollection.
	! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'sd 3/21/2006 22:36'!
testAddAllLast
	"Allows one to add each element of an orderedCollection at the beginning of another
	orderedCollection "
	"self run:#testAddAllLast" 
	
	| c1 c2 |
	c1 := #(1 2 3 4 ) asOrderedCollection.
	c2 := #(5 6 7 8 9 ) asOrderedCollection.
	c1 addAllLast: c2.
	self assert: c1 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 18:57'!
testAddBefore

	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l add: 88 before: 1.
	self assert: (l =  #(88 1 2 3 4) asOrderedCollection).
	l add: 99 before: 2.
	self assert: (l =  #(88 1 99 2 3 4) asOrderedCollection). 

! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 13:42'!
testAddBeforeAndRemove

	| l initialCollection |
	l := #(1 2 3 4) asOrderedCollection.
	initialCollection := l shallowCopy.
	l add: 88 before: 1.
	self assert: (l =  #(88 1 2 3 4) asOrderedCollection).
	l add: 99 before: 2.
	self assert: (l =  #(88 1 99 2 3 4) asOrderedCollection). 
	l remove: 99.
	l remove: 88.
	self assert: l = initialCollection.

! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 18:57'!
testAddBeforeIndex

	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l add: 88 beforeIndex: 1.
	self assert: (l =  #(88 1 2 3 4) asOrderedCollection).
	l add: 99 beforeIndex: 2.
	self assert: (l =  #(88 99 1 2 3 4) asOrderedCollection). 

! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 13:43'!
testAddDuplicateItem1
	| collection |
	collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection.
	collection add: 'John' before: 'John'.
	self
		assert: ((collection asBag occurrencesOf: 'John')
					= 2
				and: [(collection at: (collection indexOf: 'John')
							+ 1)
						= (collection
								at: (collection indexOf: 'John'))])! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 18:58'!
testAddFirst
	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l addFirst: 88.
	self assert: (l =  #(88 1 2 3 4) asOrderedCollection).
	l addFirst: 99.
	self assert: (l =  #(99 88 1 2 3 4) asOrderedCollection). 

! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'sd 6/5/2005 09:21'!
testAddItem1

   | collection size |
   collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection.
   size := collection size.
   collection add: 'James' before: 'Jim'.
   collection add: 'Margaret' before: 'Andrew'.
   self assert: size + 2 = collection size.
! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 19:07'!
testAddItem2
	| collection |
	collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection.
	collection add: 'James' before: 'Jim'.
	collection add: 'Margaret' before: 'Andrew'.
	self assert: (collection indexOf: 'James')
			+ 1
			= (collection indexOf: 'Jim').
	self assert: (collection indexOf: 'Margaret')
			+ 1
			= (collection indexOf: 'Andrew')! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'zz 12/7/2005 18:59'!
testAddLast
	| l |
	l := #(1 2 3 4) asOrderedCollection.
	l addLast: 88.
	self assert: (l =  #(1 2 3 4 88) asOrderedCollection).
	l addLast: 99.
	self assert: (l =  #(1 2 3 4 88 99) asOrderedCollection). 

! !

!OrderedCollectionTest methodsFor: 'testsAdding' stamp: 'sd 3/21/2006 22:37'!
testAtIfAbsentPut
	"Allows one to add an element at an index if no element exist at this index"
	"self run:#testAtIfAbsentPut" 
	
	| c |
	c := #(1 2 3 4 ) asOrderedCollection.
	self
		shouldnt: [c at: 2 ifAbsentPut: [5]]
		raise: Error.
	self assert: c = #(1 2 3 4 ) asOrderedCollection.
	c at: 5 ifAbsentPut: [5].
	self assert: c = #(1 2 3 4 5 ) asOrderedCollection.
	c at: 7 ifAbsentPut: [7].
	self assert: c = #(1 2 3 4 5 nil 7 ) asOrderedCollection! !


!OrderedCollectionTest methodsFor: 'testsAccessing' stamp: 'zz 12/7/2005 18:50'!
testAt
	| collection |
	collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection.
	self assert: (collection at:1) = 'Jim'.
	self assert: (collection at:2) = 'Mary'! !

!OrderedCollectionTest methodsFor: 'testsAccessing' stamp: 'sd 3/21/2006 22:38'!
testAtPut
	"Allows one to replace an element but not at an off range index"
	"self run:#testAtPut"
	| c |
	c := #(1 2 3 4 ) asOrderedCollection.
	c at: 2 put: 5.
	self assert: c = #(1 5 3 4 ) asOrderedCollection.
	self
		should: [c at: 5 put: 8]
		raise: Error.
	self deny: c = #(1 5 3 4 8 ) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'testsAccessing' stamp: 'sd 3/21/2006 22:39'!
testCapacity
	"Allows one to check the current capacity of an Ordered collection"
	"self run:#testCapacity"
	
	| c1 c2 c3 |
	c1 := #(1 2 ) asOrderedCollection.
	self assert: (c1 capacity =  2).
	c2 := OrderedCollection new: 10.
	c2 add: 3.
	self assert: (c2 capacity = 10).	
	c3 := OrderedCollection new.
	self deny: (c3 capacity =  0).
	! !

!OrderedCollectionTest methodsFor: 'testsAccessing' stamp: 'sd 3/21/2006 22:38'!
testSize
	"Allows one to check the size of an Ordered collection"
	"self run:#testSize"
	
	| c1 c2 |
	c1 := #(1 2 ) asOrderedCollection.
	self assert: (c1 size =  2).
	
	c2 := OrderedCollection new.
	self assert: (c2 size = 0)
	! !


!OrderedCollectionTest methodsFor: 'testsEnumerating' stamp: 'sd 3/21/2006 22:41'!
testCollect
	"Allows one to collect some element of a collection into another collection"
	"self run: #testCollect"
	 
	| c1 c2 res |
	c1 := #(-1 2 -3 4) asOrderedCollection.
	c2 := #(1 2 3 4) asOrderedCollection.
	res := c1 collect: [:each | each abs].
	self assert: (c2 = res).! !

!OrderedCollectionTest methodsFor: 'testsEnumerating' stamp: 'cm 3/8/2006 09:09'!
testCollectFromTo
	"Allows one to collect some element of a collection into another collection between a first index and an end index for the collect"
	"self run: #testCollectFromTo"
	
	| c1 res |
	c1 := #(-1 2 -3 4 -5 6 -7 8) asOrderedCollection.
	res := c1 collect: [:each | each abs] from: 1 to: 3.
	self assert: (res = #(1 2 3) asOrderedCollection).
	self should: [c1 collect: [:each | each abs] from: 10 to: 13] raise: Error.
	self should: [c1 collect: [:each | each abs] from: 5 to: 2] raise: Error.! !

!OrderedCollectionTest methodsFor: 'testsEnumerating' stamp: 'zz 12/7/2005 19:06'!
testIndexOf
	| collection indices |
	collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection.
	indices := collection
				collect: [:item | collection indexOf: item].
	self assert: (1 to: 4) asOrderedCollection = indices! !

!OrderedCollectionTest methodsFor: 'testsEnumerating' stamp: 'sd 6/5/2005 09:21'!
testIndexOfWithDuplicates

   | collection indices bagOfIndices |
   collection := #('Jim' 'Mary' 'John' 'Andrew' 'Mary' 'John' 'Jim' 'Micheal') asOrderedCollection.
   indices := collection collect: [:item | collection indexOf: item].
   self assert: indices asSet size = collection asSet size.
   bagOfIndices := indices asBag.
   self assert: (indices asSet 
                    allSatisfy: [:index | (bagOfIndices occurrencesOf: index)
	                                       = (collection occurrencesOf: (collection at: index))]).

  "  indexOf:  returns the index of the first occurrence of an item.
     For an item with n occurrences, the index of its first occurrence
     is found  n  times. "! !

!OrderedCollectionTest methodsFor: 'testsEnumerating' stamp: 'cm 3/8/2006 10:02'!
testWithCollect
	"Allows one to collect some element of two collections into another collection with element corresponding to the condition in the blocks"
	"self run: #testWithCollect"
	
	| c1 c2 res |
	c1 := #(-1 2 -3 4 -5 6 -7 8) asOrderedCollection.
	c2 := #(-9 10 -11 12 -13 14 -15 16) asOrderedCollection.
	res := c1 with: c2 collect: [:each1 :each2 | each1 < each2
		ifTrue: [each1]
		ifFalse: [each2]].
	self assert: (res = #(-9 2 -11 4 -13 6 -15 8) asOrderedCollection).
	! !


!OrderedCollectionTest methodsFor: 'testsCopying' stamp: 'sd 3/21/2006 22:40'!
testCopyEmpty
	"Allows one to create a copy of the receiver that contains no elements"
	"self run:#testCopyEmpty"
	
	| c1 c2 |
	c1 := #(1 2 3 4 ) asOrderedCollection.
	c2 := c1 copyEmpty.
	self assert: (c2 size = 0).! !

!OrderedCollectionTest methodsFor: 'testsCopying' stamp: 'sd 3/21/2006 22:41'!
testCopyFromTo
	"Allows one to create a copy of the receiver that contains elements from position start to end"
	"self run: #testCopyFromTo"
	
	| c1 c2 c3 | 
	c1 := #(1 2 3 4) asOrderedCollection.
	c2 := (c1 copyFrom: 1 to: 2).
	self assert: c2 = #(1 2) asOrderedCollection.
	self should: [c1 copyFrom: 10 to: 20] raise: Error.
	
	c3 := c1 copyFrom: 4 to: 2.
	self assert: c3 isEmpty.
	
	self should: [c1 copyFrom: 4 to: 5 ] raise: Error.
	
	
	
! !

!OrderedCollectionTest methodsFor: 'testsCopying' stamp: 'sd 3/21/2006 22:41'!
testCopyReplaceFromToWith
	"Allows one to create a copy from the receiver which elements between start and end of the 	receiver being replace by 	element of the collection after with:"
	"self run:#testCopyReplaceFromToWith"

	| c1 c2 c3 c4 |
	c1 := #(1 2 3 4) asOrderedCollection.
	c2 := #(5 6 7 8 9) asOrderedCollection.
	c3 := (c2 copyReplaceFrom: 1 to: 2 with: c1).
	self assert: c3 = #(1 2 3 4 7 8 9) asOrderedCollection.
	self should: [c2 copyReplaceFrom: 3 to: 1 with: c1] raise: Error.
	
	c4 := (c2 copyReplaceFrom: 10 to: 25 with: c1).
	self assert: c4 = #(5 6 7 8 9 1 2 3 4) asOrderedCollection.
	
	! !

!OrderedCollectionTest methodsFor: 'testsCopying' stamp: 'sd 3/21/2006 22:41'!
testCopyWith
	"Allows one to create a copy of the receiver that contains the new element at the end"
	"self run: #testCopyWith"
	
	| c1 | 
	c1 := #(1 2 3 4) asOrderedCollection.
	c1 := c1 copyWith: 6.
	self assert: c1 = #(1 2 3 4 6) asOrderedCollection.
	
	

	
	
	
! !

!OrderedCollectionTest methodsFor: 'testsCopying' stamp: 'zz 12/7/2005 13:47'!
testReversed
	| collection1 collection2 |
	collection1 := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection.
	collection2 := collection1 reversed.
	self assert: collection2 first = 'Andrew'.
	self assert: collection2 last = 'Jim'! !


!OrderedCollectionTest methodsFor: 'testsRemoving' stamp: 'zz 12/7/2005 19:05'!
testRemoveAllSuchThat
	| collection |
	collection := (1 to: 10) asOrderedCollection.
	collection
		removeAllSuchThat: [:e | e even].
	self assert: collection = (1 to: 10 by: 2) asOrderedCollection! !

!OrderedCollectionTest methodsFor: 'testsRemoving' stamp: 'sd 3/21/2006 22:39'!
testRemoveAt
	"Allows one to remove an element from a collection at an index"
	"self run:#testRemoveAt" 
	
	| c1 |
	c1 := #(2 3 4 6) asOrderedCollection.
	c1 removeAt: 2.
	self assert: (c1 = #(2 4 6) asOrderedCollection).
	self should: [c1 removeAt: 10] raise: Error.
	self should: [c1 removeAt: -1] raise: Error.
	! !

!OrderedCollectionTest methodsFor: 'testsRemoving' stamp: 'sd 3/21/2006 22:39'!
testRemoveFirst
	"Allows one to remove n element of a collection at the first"
	"self run:#testRemoveFirst" 
	
	| c1 |
	c1 := #(2 3 4 6) asOrderedCollection.
	c1 removeFirst: 1.
	self assert: (c1 = #(3 4 6) asOrderedCollection).
	c1 removeFirst: 2.
	self assert: (c1 = #(6) asOrderedCollection).
	self should: [c1 removeFirst: 10] raise: Error.
	
	! !

!OrderedCollectionTest methodsFor: 'testsRemoving' stamp: 'sd 3/21/2006 22:39'!
testRemoveIfAbsent
	"Allows one to remove an element from a collection and to copy it in another collection."
	"If the element isn't in the first collection, the second collection copy the element after ifAbsent"
	"self run:#testRemoveIfAbsent"
	
	| c1 c2 |
	c1 := #(1 2 3 4) asOrderedCollection.
	c2 := OrderedCollection new.
	
	c2 add: (c1 remove: 2 ifAbsent: [6]).
	self assert: (c1 = #(1 3 4) asOrderedCollection).
	self assert: (c2 = #(2) asOrderedCollection).
	
	c2 add: (c1 remove: 18 ifAbsent: [6]).
	self assert: (c1 = #(1 3 4) asOrderedCollection).
	self assert: (c2 = #(2 6) asOrderedCollection).! !

!OrderedCollectionTest methodsFor: 'testsRemoving' stamp: 'sd 3/21/2006 22:39'!
testRemoveLast
	"Allows one to remove n element of a collection at the end"
	"self run:#testRemoveLast" 
	
	| c1 |
	c1 := #(2 3 4 6) asOrderedCollection.
	c1 removeLast: 1.
	self assert: (c1 = #(2 3 4) asOrderedCollection).
	c1 removeLast: 2.
	self assert: (c1 = #(2) asOrderedCollection).
	self should: [c1 removeLast: 10] raise: Error.! !
FillStyle subclass: #OrientedFillStyle
	instanceVariableNames: 'origin direction normal'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!
!OrientedFillStyle commentStamp: '<historical>' prior: 0!
OrientedFill is an abstract superclass for fills which can be aligned appropriately.

Instance variables:
	origin	<Point>	The point at which to align the fill.
	direction <Point>	The direction in which the fill is defined
	normal	<Point>	Typically, just the direction rotated by 90 degrees.!


!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:03'!
direction
	^direction ifNil:[direction := normal y @ normal x negated]! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'!
direction: aPoint
	direction := aPoint! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:31'!
normal
	^normal ifNil:[normal := direction y negated @ direction x]! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'!
normal: aPoint
	normal := aPoint! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'!
origin
	^origin! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'!
origin: aPoint
	origin := aPoint.! !


!OrientedFillStyle methodsFor: 'testing' stamp: 'ar 6/18/1999 07:57'!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^true! !


!OrientedFillStyle methodsFor: '*Morphic-Balloon' stamp: 'dgd 10/17/2003 22:35'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'change origin' translated target: self selector: #changeOriginIn:event: argument: aMorph.
	aMenu add: 'change orientation' translated target: self selector: #changeOrientationIn:event: argument: aMorph.! !

!OrientedFillStyle methodsFor: '*Morphic-Balloon' stamp: 'ar 6/18/1999 07:41'!
changeOrientationIn: aMorph event: evt
	"Interactively change the origin of the receiver"
	| handle |
	handle _ HandleMorph new forEachPointDo:[:pt|
		self direction: pt - self origin.
		self normal: nil.
		aMorph changed].
	evt hand attachMorph: handle.
	handle startStepping.! !

!OrientedFillStyle methodsFor: '*Morphic-Balloon' stamp: 'ar 6/18/1999 07:28'!
changeOriginIn: aMorph event: evt
	"Interactively change the origin of the receiver"
	| handle |
	handle _ HandleMorph new forEachPointDo:[:pt|
		self origin: pt.
		aMorph changed].
	evt hand attachMorph: handle.
	handle startStepping.! !
Notification subclass: #OutOfScopeNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!OutOfScopeNotification methodsFor: 'as yet unclassified' stamp: 'RAA 2/5/2001 10:41'!
defaultAction

	self resume: false! !
PBPreferenceView subclass: #PBBooleanPreferenceView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!
!PBBooleanPreferenceView commentStamp: '<historical>' prior: 0!
I am responsible for building the visual representation of a preference that accepts true and false values. This view is aimed to be used inside a PreferenceBrowser panel.!


!PBBooleanPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:23'!
enabledButton
	| aButton aLabel |
	aButton := UpdatingThreePhaseButtonMorph checkBox
		target: self preference;
		actionSelector: #togglePreferenceValue;
		getSelector: #preferenceValue;
		yourself.
	aLabel := (StringMorph contents: 'enabled' translated
				font: (StrikeFont familyName: TextStyle defaultFont familyName
							size: TextStyle defaultFont pointSize - 1)).
	^self horizontalPanel
		addMorphBack: aButton;
		addMorphBack: aLabel;
		yourself.! !

!PBBooleanPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:27'!
localToProjectButton
	| aButton aLabel |
	aButton := UpdatingThreePhaseButtonMorph checkBox
		target: self preference;
		actionSelector: #toggleProjectLocalness;
		getSelector: #localToProject;
		yourself.
	aLabel := (StringMorph contents: 'local' translated
				font: (StrikeFont familyName: TextStyle defaultFont familyName
							size: TextStyle defaultFont pointSize - 1)).		
	^self horizontalPanel
		addMorphBack: aButton;
		addMorphBack: aLabel;
		yourself.! !

!PBBooleanPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:25'!
representativeButtonWithColor: aColor inPanel: aPreferencesPanel
	^self horizontalPanel
		layoutInset: 2;
		cellInset: 7;
		color: aColor;
		addMorphBack: (StringMorph contents: self preference name);
		addMorphBack: self horizontalFiller; 
		addMorphBack: self enabledButton;
		addMorphBack: self localToProjectButton;
		yourself.! !

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

PBBooleanPreferenceView class
	instanceVariableNames: ''!

!PBBooleanPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:47'!
initialize
	PreferenceViewRegistry ofBooleanPreferences register: self.
! !

!PBBooleanPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:47'!
unload
	PreferenceViewRegistry ofBooleanPreferences unregister: self.! !
PBPreferenceView subclass: #PBColorPreferenceView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!

!PBColorPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/6/2004 21:24'!
colorSwatch
	^UpdatingRectangleMorph new
		target: self preference;
		getSelector: #preferenceValue;
		putSelector: #preferenceValue:;
		extent: 22@22;
		setBalloonText: 'click here to change the color' translated;
		yourself.! !

!PBColorPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/6/2004 21:12'!
representativeButtonWithColor: aColor inPanel: aPreferenceBrowser
	^self horizontalPanel
		layoutInset: 2;
		color: aColor;
		cellInset: 20;
		cellPositioning: #center;
		addMorphBack: (StringMorph contents: self preference name);
		addMorphBack: self horizontalFiller;
		addMorphBack: self colorSwatch;
		yourself! !

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

PBColorPreferenceView class
	instanceVariableNames: ''!

!PBColorPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/6/2004 20:49'!
initialize
	PreferenceViewRegistry ofColorPreferences register: self.! !

!PBColorPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/6/2004 20:49'!
unload
	PreferenceViewRegistry ofColorPreferences unregister: self.! !
PBPreferenceView subclass: #PBHaloThemePreferenceView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!
!PBHaloThemePreferenceView commentStamp: '<historical>' prior: 0!
I am responsible for building the button for the Halo Theme preference!


!PBHaloThemePreferenceView methodsFor: 'initialization' stamp: 'hpt 12/8/2004 18:12'!
initialize
	self addActionTitled: 'edit custom halos' 
		target: Preferences 
		selector:  #editCustomHalos 
		arguments: {} 
		balloonText: 'Click here to edit the method that defines the custom halos' translated.! !


!PBHaloThemePreferenceView methodsFor: 'user interface' stamp: 'hpt 12/8/2004 18:18'!
haloThemeRadioButtons
	"Answer a column of butons representing the choices of halo theme"

	| buttonColumn aRow aRadioButton aLabel |
	buttonColumn := self verticalPanel.
	#(	(iconicHaloSpecifications iconic iconicHalosInForce	'circular halos with icons inside')
		(classicHaloSpecs	classic	classicHalosInForce		'plain circular halos')
		(simpleFullHaloSpecifications		simple	simpleHalosInForce	'fewer, larger halos')
		(customHaloSpecs	custom	customHalosInForce		'customizable halos')) do:

		[:quad |
			aRadioButton := UpdatingThreePhaseButtonMorph radioButton
				target: Preferences;
				setBalloonText: quad fourth;
				actionSelector: #installHaloTheme:;
				getSelector: quad third;
				arguments: (Array with: quad first);
				yourself.
			aLabel := (StringMorph contents: quad second asString)
						setBalloonText: quad fourth;
						yourself.
			aRow := self horizontalPanel
				cellInset: 4;
				addMorphBack: aRadioButton;
				addMorphBack: aLabel.
			buttonColumn addMorphBack: aRow].
	^ buttonColumn

	"(Preferences preferenceAt: #haloTheme) view tearOffButton"! !

!PBHaloThemePreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:45'!
representativeButtonWithColor: aColor inPanel: aPreferencesPanel
	| innerPanel |
	innerPanel := self horizontalPanel
		addMorphBack: (self blankSpaceOf: 10@0);
		addMorphBack: self haloThemeRadioButtons;
		yourself.
	^self verticalPanel
		color: aColor;
		layoutInset: 2;
		addMorphBack: (StringMorph contents: self preference name);
		addMorphBack: innerPanel.! !

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

PBHaloThemePreferenceView class
	instanceVariableNames: ''!

!PBHaloThemePreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:48'!
initialize
	PreferenceViewRegistry ofHaloThemePreferences register: self.! !

!PBHaloThemePreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:48'!
unload
	PreferenceViewRegistry ofHaloThemePreferences unregister: self.! !
PBPreferenceView subclass: #PBNumericPreferenceView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!

!PBNumericPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/9/2004 22:23'!
preferenceValue
	^self preference preferenceValue asString! !

!PBNumericPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/10/2004 22:53'!
preferenceValue: aTextOrString
	(aTextOrString notEmpty and: [aTextOrString asString isAllDigits])
		ifFalse: [^false].
	self preference preferenceValue: aTextOrString asNumber.
	^true.! !

!PBNumericPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/9/2004 22:19'!
representativeButtonWithColor: aColor inPanel: aPreferenceBrowser
	^self horizontalPanel
		layoutInset: 2;
		color: aColor;
		cellInset: 20;
		cellPositioning: #center;
		addMorphBack: (StringMorph contents: self preference name);
		addMorphBack: self textField;
		yourself.! !

!PBNumericPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/9/2004 22:19'!
textField
	^(PluggableTextMorph
		on: self
		text: #preferenceValue
		accept: #preferenceValue:)
			hideVScrollBarIndefinitely: true;
			borderColor: #inset;
			acceptOnCR: true;
			color: Color gray veryMuchLighter;
			vResizing: #rigid;
			hResizing: #spaceFill;
			height: TextStyle defaultFont height + 6;
			yourself.! !

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

PBNumericPreferenceView class
	instanceVariableNames: ''!

!PBNumericPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/9/2004 22:21'!
initialize
	PreferenceViewRegistry ofNumericPreferences register: self.! !

!PBNumericPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/9/2004 22:21'!
unload
	PreferenceViewRegistry ofNumericPreferences unregister: self.! !
Morph subclass: #PBPreferenceButtonMorph
	instanceVariableNames: 'moreButton model preference preferenceMorphicView preferenceView'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!

!PBPreferenceButtonMorph methodsFor: 'accessing' stamp: 'hpt 12/8/2004 15:34'!
model
	^model! !


!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 12/8/2004 18:15'!
actionButtons
	^self preferenceView actions collect: [:aTuple |
		self basicButton
				label: aTuple first;
				target: aTuple second;
				actionSelector: aTuple third;
				arguments: aTuple fourth;
				setBalloonText: aTuple fifth ]! !

!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 8/24/2005 20:33'!
addExtraControls
	| m |
	m := self horizontalPanel
		cellInset: 3;
		addAllMorphs: self actionButtons;
		addMorphBack: self horizontalFiller;
		addMorphBack: self moreButton;
		yourself.
	self 
		addMorphBack: (self blankSpaceOf: 2@2);
		addMorphBack: self preferenceHelpTextMorph;
		fullBounds; "to force a layout compute needed by the textMorphs's autoFit"
		addMorphBack: m
! !

!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 12/8/2004 17:16'!
advancedOptionsSelected
	self preferenceView offerPreferenceNameMenu: self model! !

!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 12/8/2004 18:17'!
moreButton
	^moreButton ifNil: 
		[moreButton := self basicButton 
						label: 'more' translated; 
						setBalloonText: 
							'Click here for advanced options'translated;
						actionSelector: #advancedOptionsSelected]! !

!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'stephaneducasse 2/4/2006 20:39'!
preferenceHelpTextMorph
	| text tm |
	text := self preferenceHelpText.
	tm := TextMorph new
		contents: text;
		wrapOnOff;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		lock: true;
		visible: text notEmpty;
		yourself. "we don't want an empty textmorph showing"
	tm isAutoFit
		ifFalse: [tm autoFitOnOff].
	^tm.! !

!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 12/8/2004 16:40'!
removeExtraControls
	self submorphs copyWithoutFirst do: [:ea | ea delete]! !


!PBPreferenceButtonMorph methodsFor: 'highlighting' stamp: 'hpt 12/8/2004 15:55'!
highlightOff
	self beTransparent.
	self label color: Color black.
	self removeExtraControls.! !

!PBPreferenceButtonMorph methodsFor: 'highlighting' stamp: 'hpt 12/8/2004 17:25'!
highlightOn
	self color: (Color gray alpha: 0.1).
	self label color: Color red.
	self addExtraControls.! !


!PBPreferenceButtonMorph methodsFor: 'initialization' stamp: 'hpt 12/8/2004 15:38'!
initializeLayout
	self layoutPolicy: TableLayout new;
		beTransparent;
		layoutInset: 0;
		cellInset: 0;
		listCentering: #topLeft;
		cellPositioning: #topLeft;
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap.		! !

!PBPreferenceButtonMorph methodsFor: 'initialization' stamp: 'hpt 12/8/2004 15:38'!
initializeWithPreference: aPreference model: aModel
	preference := aPreference.
	model := aModel.
	self initializeLayout.
	self addMorphBack: self preferenceMorphicView.
	self highlightOff.! !


!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:42'!
label
	^self preferenceMorphicView firstSubmorph! !

!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:13'!
preference
	^preference! !

!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:56'!
preferenceHelp
	| help name |
	help := self preference helpString withBlanksTrimmed.
	name := self preference name.
	(self caseInsensitiveBeginsWith: name  in: help)
		ifTrue: [help := help allButFirst: name size].
	(help notEmpty and: [help first = $:])
		ifTrue: [help := help allButFirst].
	^help withBlanksTrimmed.
! !

!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:25'!
preferenceHelpText
	^self preferenceHelp asText
		addAttribute: TextEmphasis italic;
		yourself.! !

!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:48'!
preferenceMorphicView
	^preferenceMorphicView
		ifNil: 
			[preferenceMorphicView := self preferenceView
				representativeButtonWithColor: Color transparent inPanel: self model.
			preferenceMorphicView hResizing: #spaceFill.
			^preferenceMorphicView]! !

!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'stephaneducasse 2/4/2006 20:39'!
preferenceView
	^preferenceView
		ifNil: [preferenceView := self preference viewForPanel: self model.]! !


!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 17:06'!
basicButton
	| button |
	button := SimpleButtonMorph new.
	button
		borderWidth: 1;
		borderColor: self paneColor;
		on: #mouseEnter send: #value to: [button borderWidth: 2];
		on: #mouseLeave send: #value to: [button borderWidth: 1];
		vResizing: #rigid;
		height: (TextStyle defaultFont height + 4);
		useSquareCorners;
		clipSubmorphs: true;
		color: self paneColor muchLighter;
		target: self.
	^button! !

!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 15:59'!
basicPanel
	^BorderedMorph new
		beTransparent;
		extent: 0@0;
		borderWidth: 0;
		layoutInset: 0;
		cellInset: 0;
		layoutPolicy: TableLayout new;
		listCentering: #topLeft;
		cellPositioning: #center;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		yourself! !

!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 15:29'!
blankSpaceOf: aPoint
	^Morph new 
		beTransparent;
		extent: aPoint; 
		yourself! !

!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 15:43'!
caseInsensitiveBeginsWith: prefix in: string
	^(string findString: prefix startingAt: 1 caseSensitive: false) = 1! !

!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 16:42'!
horizontalFiller
	^self horizontalPanel
		hResizing: #spaceFill;
		yourself.! !

!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 16:42'!
horizontalPanel
	^self basicPanel
		cellPositioning: #center;
		listDirection: #leftToRight;
		yourself.! !

!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'stephaneducasse 2/4/2006 20:39'!
paneColor
	| browser |
	browser := (self ownerChain 
		detect: [:ea | ea isKindOf: PreferenceBrowserMorph] 
		ifNone: [^Color black]) .
	^browser paneColor! !

!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 15:27'!
verticalPanel
	^self basicPanel
		cellPositioning: #topLeft;
		listDirection: #topToBottom;
		yourself.! !

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

PBPreferenceButtonMorph class
	instanceVariableNames: ''!

!PBPreferenceButtonMorph class methodsFor: 'instance creation' stamp: 'hpt 12/8/2004 15:20'!
preference: aPreference
	^self preference: aPreference model: nil! !

!PBPreferenceButtonMorph class methodsFor: 'instance creation' stamp: 'hpt 12/8/2004 15:19'!
preference: aPreference model: aModel
	^self new
		initializeWithPreference: aPreference model: aModel;
		yourself.! !
PreferenceView subclass: #PBPreferenceView
	instanceVariableNames: 'actions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!
!PBPreferenceView commentStamp: '<historical>' prior: 0!
I am just a refactor of all the common method of the PreferenceBrowser preference views!


!PBPreferenceView methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:39'!
actions
	^actions ifNil: [actions := OrderedCollection new.]! !

!PBPreferenceView methodsFor: 'actions' stamp: 'hpt 12/8/2004 18:13'!
addActionTitled: aTitle target: aTarget selector: aSelector arguments: aCollection balloonText: aText
	self actions add: { aTitle. aTarget. aSelector. aCollection. aText }! !


!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:42'!
basicPanel
	^BorderedMorph new
		beTransparent;
		extent: 0@0;
		borderWidth: 0;
		layoutInset: 0;
		cellInset: 2;
		layoutPolicy: TableLayout new;
		listCentering: #topLeft;
		cellPositioning: #center;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		yourself! !

!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:15'!
blankSpaceOf: aPoint
	^Morph new 
		beTransparent;
		extent: aPoint; 
		yourself! !

!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:13'!
horizontalFiller
	^self horizontalPanel
		hResizing: #spaceFill;
		yourself.! !

!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:43'!
horizontalPanel
	^self basicPanel
		cellPositioning: #center;
		listDirection: #leftToRight;
		yourself.! !

!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:48'!
offerPreferenceNameMenu: aPreferenceBrowser
	"the user clicked on a preference name -- put up a menu"

	| aMenu |			
	aMenu := MenuMorph new 
		defaultTarget: self preference;
		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' translated 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: aPreferenceBrowser 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! !

!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:43'!
verticalPanel
	^self basicPanel
		cellPositioning: #topLeft;
		listDirection: #topToBottom;
		yourself.! !

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

PBPreferenceView class
	instanceVariableNames: ''!

!PBPreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:09'!
handlesPanel: aPreferencePanel
	^aPreferencePanel isKindOf: PreferenceBrowser! !
PBPreferenceView subclass: #PBTextPreferenceView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!

!PBTextPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/10/2004 22:46'!
preferenceValue
	^self preference preferenceValue ifNil: ['']! !

!PBTextPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:38'!
preferenceValue: aTextOrString
	self preference preferenceValue: aTextOrString asString.
	^true.! !

!PBTextPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:41'!
representativeButtonWithColor: aColor inPanel: aPreferenceBrowser
	^self horizontalPanel
		layoutInset: 2;
		color: aColor;
		cellInset: 20;
		cellPositioning: #center;
		addMorphBack: (StringMorph contents: self preference name);
		addMorphBack: self textField;
		yourself.! !

!PBTextPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:41'!
textField
	^(PluggableTextMorph
		on: self
		text: #preferenceValue
		accept: #preferenceValue:)
			hideVScrollBarIndefinitely: true;
			borderColor: #inset;
			acceptOnCR: true;
			color: Color gray veryMuchLighter;
			vResizing: #rigid;
			hResizing: #spaceFill;
			height: TextStyle defaultFont height + 6;
			yourself.! !

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

PBTextPreferenceView class
	instanceVariableNames: ''!

!PBTextPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 17:01'!
initialize
	PreferenceViewRegistry ofTextPreferences register: self.! !

!PBTextPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 17:01'!
unload
	PreferenceViewRegistry ofTextPreferences unregister: self.! !
PBColorPreferenceView subclass: #PBWindowColorPreferenceView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!

!PBWindowColorPreferenceView methodsFor: 'initialization' stamp: 'hpt 12/8/2004 18:38'!
initialize
	super initialize.
	self addActionTitled: 'Bright' target: Preferences selector: #installBrightWindowColors arguments: {} balloonText: 'Use standard bright colors for all windows' translated.
	self addActionTitled: 'Pastel' target: Preferences selector: #installPastelWindowColors arguments: {} balloonText: 'Use standard pastel colors for all windows' translated.	
	self addActionTitled: 'White' target: Preferences selector: #installUniformWindowColors arguments: {} balloonText: 'Use white backgrounds for all standard windows' translated.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PBWindowColorPreferenceView class
	instanceVariableNames: ''!

!PBWindowColorPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/8/2004 18:40'!
initialize
	self viewRegistry register: self.! !

!PBWindowColorPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/8/2004 18:40'!
unload
	self viewRegistry unregister: self.! !

!PBWindowColorPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/8/2004 18:40'!
viewRegistry
	^(PreferenceViewRegistry registryOf: #windowColorPreferences)
		viewOrder: 6;
		yourself.! !
PrimCallControllerAbstract subclass: #PCCByCompilation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-PrimCallController'!
!PCCByCompilation commentStamp: 'sr 6/16/2004 09:00' prior: 0!
This class is for switching external prim calls (primitiveExternalCall) on and off.

It is best suited for permanently switching plugin calls off while preserving the possibility to switch them on later. For plugin testing purposes you probably should use PCCByLiterals for temporarily switch on/off them instead.

It works on a source code basis by compilation:
	Disabling works by putting an enabled prim call into a special comment followed by a recompile to transform it into a disabled one.
	Enabling works by pulling the disabled prim call out of the special comment followed by a recompile to transform it into an enabled one.

As a consequence, enabling of prims only works with method sources containing the mentioned special comment, which normally has been generated by this tool for disabling the corresponding prim.

Please look into superclass PrimCallControllerAbstract for more info and the user interface.

Structure:
 No instVars here: look into superclass.

Implementation note:
To harden it for sunit testing purposes some special accessing of the source code has been necessary: to avoid accessing different processes a sources file at once, followed by generating garbage, the process priority of actions leading to these accesses has been increased (sunit tests run in the background). A better solution would be to introduce a source file locking mechanism.!
]style[(107 11 138 13 5 11 62 14 3 9 124 8 245 9 36 9 26 28 26 93 20 384)f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2LPCCByLiterals Comment;,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2,f2FAccuny#12,f3FAccuny#12,f2FAccuny#12,f2,f2LPrimCallControllerAbstract Comment;,f2,FAccuny#15uf2,f2!


!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:30'!
comment
	^ '{prim disabled by ', self className, '} '! !

!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'!
disabledPrimStartString
	^ '"', self comment, self enabledPrimStartString! !

!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'!
disabledPrimStopChar
	"end of disabling comment"
	^ $"! !

!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'!
enabledPrimStartString
	^ '<primitive:'! !

!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'!
enabledPrimStopChar
	^ $>! !


!PCCByCompilation methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:33'!
extractCallModuleNames: aMethodRef 
	^ (self existsCompiledCallIn: aMethodRef)
		ifTrue: [self extractCallModuleNamesFromLiterals: aMethodRef]
		ifFalse: [| src | 
			"try source"
			"higher priority to avoid source file accessing errors"
			[src := aMethodRef sourceString]
				valueAt: self higherPriority.
			self extractCallNamesFromPrimString: ((self extractDisabledPrimStringFrom: src)
					ifNil: ["no disabled prim string found"
						^ nil]) first]! !

!PCCByCompilation methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:38'!
methodsWithCall
	"Expensive!! For just querying the system unaffected by an instance of 
	this class use PCCByLiterals instead."
	^ self methodsWithCompiledCall , self methodsWithDisabledCall! !

!PCCByCompilation methodsFor: 'ui querying' stamp: 'md 8/27/2005 17:17'!
methodsWithDisabledCall
	"Answer a SortedCollection of all the methods that contain, in source  
	code, the substring indicating a disabled prim."
	"The alternative implementation  
		^ SystemNavigation new allMethodsWithSourceString: self disabledPrimStartString
									matchCase: true  
	also searches in class comments."
	| list classCount string |
	string := self disabledPrimStartString.
	list := Set new.
	'Searching all method source code...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: Smalltalk classNames size * 2 "classes with their metaclasses"
		during: [:bar |
			classCount := 0.
			SystemNavigation default
				allBehaviorsDo: [:class | 
					bar value: (classCount := classCount + 1).
					class
						selectorsDo: [:sel | 
							| src | 
							"higher priority to avoid source file accessing  
							errors"
							[src := class sourceCodeAt: sel]
								valueAt: self higherPriority.
							(src
								findString: string
								startingAt: 1
								caseSensitive: true) > 0
								ifTrue: [sel isDoIt ifFalse: [
											list add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]].
	^ list asSortedCollection! !


!PCCByCompilation methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:26'!
existsCallIn: aMethodRef 
	"Here existsCompiledCallIn: (see also comment there) is sufficient to 
	query for enabled and failed, but not for disabled prim calls: so check 
	for disabled ones in sources, too."
	^ (self existsCompiledCallIn: aMethodRef)
		or: [self existsDisabledCallIn: aMethodRef]! !

!PCCByCompilation methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:07'!
existsDisabledCallIn: aMethodRef 
	| src |
	^ (self existsCompiledCallIn: aMethodRef) not
		and: ["higher priority to avoid source file accessing errors"
			[src := aMethodRef sourceString]
				valueAt: self higherPriority.
			self methodSourceContainsDisabledCall: src]! !


!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:26'!
disabled2EnabledPrimMethodString: aSourceString 
	| start stop primString extract |
	extract := self extractDisabledPrimStringFrom: aSourceString.
	primString := extract at: 1.
	start := extract at: 2.
	stop := start + primString size - 1.
	^ aSourceString
		copyReplaceFrom: start
		to: stop
		with: (self disabled2EnabledPrimString: primString)! !

!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:26'!
disabled2EnabledPrimString: aDisabledPrimString
	"remove comment quotes and comment after first comment quote"
	| enabledPrimString |
	enabledPrimString := aDisabledPrimString copyFrom: self comment size + 2 to: aDisabledPrimString size - 1.
	^ enabledPrimString! !

!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:28'!
enabled2DisabledPrimMethodString: aSourceString 
	| start stop primString extract |
	extract := self extractEnabledPrimStringFrom: aSourceString.
	primString := extract at: 1.
	start := extract at: 2.
	stop := start + primString size - 1.
	^ aSourceString
		copyReplaceFrom: start
		to: stop
		with: (self enabled2DisabledPrimString: primString)! !

!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:28'!
enabled2DisabledPrimString: anEnabledPrimString 
	| disabledPrimString |
	disabledPrimString := '"' , self comment , anEnabledPrimString , '"'.
	^ disabledPrimString! !

!PCCByCompilation methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'!
extractCallNamesFromPrimString: aString
	"method works for both enabled and disabled prim strings"
	"<primitive: 'doSomething' module:'ModuleFoo'"
	| tokens |
	tokens := aString findTokens: ''''.
	^ (tokens at: 2) -> (tokens at: 4 ifAbsent: [nil])! !

!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/11/2004 07:10'!
extractDisabledPrimStringFrom: aSourceString 
	| startString start stop |
	startString := self disabledPrimStartString.
	start := aSourceString findString: startString.
	start = 0
		ifTrue: [^ nil].
	stop := aSourceString indexOf: self disabledPrimStopChar startingAt: start + startString size.
	stop = 0
		ifTrue: [^ nil].
	^ {aSourceString copyFrom: start to: stop. start}! !

!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:29'!
extractEnabledPrimStringFrom: aSourceString 
	| startString start stop |
	startString := self enabledPrimStartString.
	start := aSourceString findString: startString.
	start = 0
		ifTrue: [^ nil].
	stop := aSourceString indexOf: self enabledPrimStopChar startingAt: start + startString size.
	stop = 0
		ifTrue: [^ nil].
	^ {aSourceString copyFrom: start to: stop. start}! !

!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:29'!
higherPriority
	"this priority seems to be necessary to avoid source file accessing errors"
	^ Processor userSchedulingPriority + 1! !

!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/11/2004 07:06'!
methodSourceContainsDisabledCall: methodSource 
	^ (methodSource findString: self disabledPrimStartString)
		~= 0! !


!PCCByCompilation methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:37'!
privateDisableCallIn: aMethodRef 
	"Disables enabled or failed external prim call by recompiling method 
	with prim call commented out, will be called by superclass."
	| src newMethodSource |
	"higher priority to avoid source file accessing errors"
	[src := aMethodRef sourceString]
		valueAt: self higherPriority.
	newMethodSource := self enabled2DisabledPrimMethodString: src.
	"higher priority to avoid source file accessing errors"
	[aMethodRef actualClass
		compile: newMethodSource
		classified: (aMethodRef actualClass whichCategoryIncludesSelector: aMethodRef methodSymbol)
		notifying: nil]
		valueAt: self higherPriority! !

!PCCByCompilation methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:10'!
privateEnableCallIn: aMethodRef 
	"Enables disabled external prim call by recompiling method with prim  
	call taken from disabling comment, will be called by superclass."
	| src newMethodSource |
	"higher priority to avoid source file accessing errors"
	[src := aMethodRef sourceString]
		valueAt: self higherPriority.
	newMethodSource := self disabled2EnabledPrimMethodString: src.
	"higher priority to avoid source file accessing errors"
	[aMethodRef actualClass
		compile: newMethodSource
		classified: (aMethodRef actualClass whichCategoryIncludesSelector: aMethodRef methodSymbol)
		notifying: nil]
		valueAt: self higherPriority! !
PrimCallControllerAbstractTest subclass: #PCCByCompilationTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-PrimCallController'!
!PCCByCompilationTest commentStamp: 'sr 6/14/2004 22:05' prior: 0!
PCCByCompilation tests.

Tests are in the superclass and inherited from there.!


!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/11/2004 05:22'!
classToBeTested
	^ PCCByCompilation! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:36'!
disabledCallSelectors
	^ #(#cDisabledRealExternalCall #cDisabledRealExternalCallNaked #cDisabledRealExternalCallOrPrimitiveFailed #cDisabledExternalCallWithoutModule )! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:34'!
enabledCallSelectors
	^ #(#cRealExternalCall #cRealExternalCallNaked #cRealExternalCallOrPrimitiveFailed #cExternalCallWithoutModule )! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:44'!
exampleModuleName
	^ 'CPCCT'! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/15/2004 02:42'!
failModuleName
	^ 'CFailModule'! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:14'!
failedCallSelector
	^ #cFailedCall! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:40'!
methodSelectorsToExampleModule
	^ #(#cExternalCall1 #cExternalCall2 )! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'!
moduleNameNotWithSingularCallName
	^ 'CNotOne'! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'!
moduleNameWithSingularCallName
	^ 'COne'! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 09:52'!
noExternalCallSelector
	^ #cNoExternalCall! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:28'!
realExternalCallOrPrimitiveFailedSelector
	^ #cRealExternalCallOrPrimitiveFailed! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:54'!
singularCallName
	"occurrs exactly once as prim call name in >>cSingularExternalCall"
	^ 'cSingularExternalCall'! !

!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:33'!
singularCallSelector
	^ #cSingularExternalCall! !


!PCCByCompilationTest methodsFor: 'example module' stamp: 'md 9/6/2005 19:39'!
cExternalCall1
	<primitive: 'prim1' module: 'CPCCT'>
! !

!PCCByCompilationTest methodsFor: 'example module' stamp: 'md 9/6/2005 19:39'!
cExternalCall2
		<primitive:'prim2'module:'CPCCT'>
		self primitiveFailed! !


!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/11/2004 05:36'!
cDisabledExternalCallWithoutModule
	"{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName'>"
	^ 'Hello World!!'! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'!
cDisabledRealExternalCall
	"{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>"
	^ 'Hello World!!'! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'!
cDisabledRealExternalCallNaked
	"{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>"! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'!
cDisabledRealExternalCallOrPrimitiveFailed
	"{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>"
	self primitiveFailed! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:48'!
cExternalCallWithoutModule
	<primitive: 'primGetModuleName'>
	^ 'Hello World!!'! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'md 9/6/2005 19:39'!
cFailedCall
	<primitive: 'primGetModuleName' module:'CFailModule'>
	^ 'failed call'! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:48'!
cNoExternalCall
	^ 'Hello World!!'! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'!
cRealExternalCall
	<primitive: 'primGetModuleName' module:'LargeIntegers'>
	^ 'Hello World!!'! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'!
cRealExternalCallNaked
	<primitive: 'primGetModuleName' module:'LargeIntegers'>! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'md 9/6/2005 19:39'!
cRealExternalCallOrPrimitiveFailed
	<primitive: 'primGetModuleName' module:'LargeIntegers'>
	self primitiveFailed! !

!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/15/2004 04:35'!
cSingularExternalCall
	<primitive: 'cSingularExternalCall' module:'COne'>
	^ 'Hello World!!'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PCCByCompilationTest class
	instanceVariableNames: ''!

!PCCByCompilationTest class methodsFor: 'Testing' stamp: 'sr 6/7/2004 12:01'!
isAbstract
	^ false! !
PrimCallControllerAbstract subclass: #PCCByLiterals
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-PrimCallController'!
!PCCByLiterals commentStamp: 'sr 6/16/2004 09:14' prior: 0!
This class is for switching external prim calls (primitiveExternalCall) on and off.

It is best suited for plugin testing purposes with temporarily switching plugin calls off and on. For permanently switching plugin calls off while preserving the possibility to switch them on later, you should use PCCByCompilation instead.

It works by manipulating literals in the CompiledMethods:
	Disabling works by changing the function index in the first literal of the CompiledMethod to a negative value (-2). This leads to a fast fail (value -2 is used for disabling to make a difference to the standard failed value of -1).
	Enabling works by changing the function index in the first literal of the CompiledMethod to 0, followed by flushing the method cache. This enforces a fresh lookup.

Please look into superclass PrimCallControllerAbstract for more info and the user interface.

Structure:
 No instVars here: look into superclass.!
]style[(136 11 40 11 101 16 10 1 9 2 14 8 26 9 224 8 157 28 26 91)f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2LPCCByCompilation Comment;,f2FAccuny#12,f2,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2,f2LPrimCallControllerAbstract Comment;,f2!


!PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/11/2004 07:04'!
extractCallModuleNames: aMethodRef 
	^ (self existsCallIn: aMethodRef)
		ifTrue: [self extractCallModuleNamesFromLiterals: aMethodRef]! !

!PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/11/2004 07:05'!
methodsWithCall
	^ self methodsWithCompiledCall! !

!PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:24'!
methodsWithDisabledCall
	^ self methodsWithCompiledCall
		select: [:mRef | (mRef compiledMethod literals first at: 4)
				= -2]! !


!PCCByLiterals methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:04'!
existsCallIn: aMethodRef 
	"Here >>existsCompiledCallIn: (see also comment there) is sufficient to 
	query for all enabled, failed and disabled prim calls; for the by 
	compiler version it is not sufficient for disabled ones."
	^ self existsCompiledCallIn: aMethodRef! !

!PCCByLiterals methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:30'!
existsDisabledCallIn: aMethodRef 
	^ (self existsCompiledCallIn: aMethodRef)
		and: [(aMethodRef compiledMethod literals first at: 4)
				= -2]! !


!PCCByLiterals methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:35'!
privateDisableCallIn: aMethodRef 
	"Disables enabled or failed external prim call by filling function ref 
	literal with special fail value, will be called by superclass."
	aMethodRef compiledMethod literals first at: 4 put: -2! !

!PCCByLiterals methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:07'!
privateEnableCallIn: aMethodRef
	"Enables disabled external prim call."
	self privateEnableViaLiteralIn: aMethodRef! !
PrimCallControllerAbstractTest subclass: #PCCByLiteralsTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-PrimCallController'!
!PCCByLiteralsTest commentStamp: 'sr 6/14/2004 22:05' prior: 0!
PCCByLiterals tests.

Tests are in the superclass and inherited from there.!


!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/11/2004 05:23'!
classToBeTested
	^ PCCByLiterals! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:37'!
disabledCallSelectors
	^ #(#lDisabledRealExternalCall #lDisabledRealExternalCallNaked #lDisabledRealExternalCallOrPrimitiveFailed #lDisabledExternalCallWithoutModule )! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:34'!
enabledCallSelectors
	^ #(#lRealExternalCall #lRealExternalCallNaked #lRealExternalCallOrPrimitiveFailed #lExternalCallWithoutModule )! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:45'!
exampleModuleName
	^ 'LPCCT'! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/15/2004 02:42'!
failModuleName
	^ 'LFailModule'! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:12'!
failedCallSelector
	^ #lFailedCall! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:41'!
methodSelectorsToExampleModule
	^ #(#lExternalCall1 #lExternalCall2 )! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'!
moduleNameNotWithSingularCallName
	^ 'LNotOne'! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'!
moduleNameWithSingularCallName
	^ 'LOne'! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:16'!
noExternalCallSelector
	^ #lNoExternalCall! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:29'!
realExternalCallOrPrimitiveFailedSelector
	^ #lRealExternalCallOrPrimitiveFailed! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:54'!
singularCallName
	"occurrs exactly once as prim call name in >>lSingularExternalCall"
	^ 'lSingularExternalCall'! !

!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:32'!
singularCallSelector
	^ #lSingularExternalCall! !


!PCCByLiteralsTest methodsFor: 'example module' stamp: 'sr 6/7/2004 08:39'!
lExternalCall1
	<primitive: 'prim1' module: 'LPCCT'>
! !

!PCCByLiteralsTest methodsFor: 'example module' stamp: 'sr 6/7/2004 08:39'!
lExternalCall2
		<primitive:'prim2'module:'LPCCT'>
		self primitiveFailed! !


!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 08:51'!
lDisabledExternalCallWithoutModule
	<primitive: 'primGetModuleName'>
	^ 'Hello World!!'! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'!
lDisabledRealExternalCall
	<primitive: 'primGetModuleName' module:'LargeIntegers'>
	^ 'Hello World!!'! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'!
lDisabledRealExternalCallNaked
	<primitive: 'primGetModuleName' module:'LargeIntegers'>! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'!
lDisabledRealExternalCallOrPrimitiveFailed
	<primitive: 'primGetModuleName' module:'LargeIntegers'> "primitiveExternalCall" 
	self primitiveFailed! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:59'!
lExternalCallWithoutModule
	<primitive: 'primGetModuleName'> "primitiveExternalCall" 
	^ 'Hello World!!'! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/15/2004 02:41'!
lFailedCall
	<primitive: 'primGetModuleName' module:'LFailModule'>
	^ 'failed call'! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:57'!
lNoExternalCall
	^ 'Hello World!!'! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'!
lRealExternalCall
	<primitive: 'primGetModuleName' module:'LargeIntegers'>
	^ 'Hello World!!'! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'!
lRealExternalCallNaked
	<primitive: 'primGetModuleName' module:'LargeIntegers'>! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'!
lRealExternalCallOrPrimitiveFailed
	<primitive: 'primGetModuleName' module:'LargeIntegers'>
	self primitiveFailed! !

!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 10:52'!
lSingularExternalCall
	<primitive: 'lSingularExternalCall' module:'LOne'>
	^ 'Hello World!!'! !


!PCCByLiteralsTest methodsFor: 'tests' stamp: 'sr 6/7/2004 11:30'!
setUp
	super setUp.
	"disable external calls"
	(self class selectors
		select: [:sel | sel beginsWith: 'lDisabled'])
		do: [:sel | (self class >> sel) literals first at: 4 put: -2]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PCCByLiteralsTest class
	instanceVariableNames: ''!

!PCCByLiteralsTest class methodsFor: 'Testing' stamp: 'sr 6/7/2004 12:01'!
isAbstract
	^ false! !
ImageReadWriter subclass: #PCXReadWriter
	instanceVariableNames: 'version encoding colorPlanes isGrayScale width height bitsPerPixel colorPalette rowByteSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!

!PCXReadWriter methodsFor: 'accessing' stamp: 'tao 10/6/97 10:11'!
nextImage
	"Read in the next PCX image from the stream."

	| bytes form |
	self readHeader.
	bytes _ self readBody.
	colorPalette _ self readPalette.
	self close.
	form _ ColorForm extent: width@height depth: bitsPerPixel.
	(Form new hackBits: bytes) displayOn: (Form new hackBits: form bits).
	form colors: colorPalette.
	^ form
! !


!PCXReadWriter methodsFor: 'private-decoding' stamp: 'tao 10/6/97 08:38'!
nextWord
	^self next + (self next bitShift: 8)! !

!PCXReadWriter methodsFor: 'private-decoding' stamp: 'tao 10/6/97 10:07'!
readBody

	| array scanLine rowBytes position byte count pad |
	pad _ #(0 3 2 1) at: (width \\ 4 + 1).
	array _ ByteArray new: ((width + pad) * height * bitsPerPixel) // 8.
	scanLine _ ByteArray new: rowByteSize.
	position _ 1.
	1 to: height do:
		[:line |
		rowBytes _ 0.
		[rowBytes < rowByteSize] whileTrue:
			[byte _ self next.
			byte < 16rC0
				ifTrue:
					[rowBytes _ rowBytes + 1.
					scanLine at: rowBytes put: byte]
				ifFalse:
					[count _ byte - 16rC0.
					byte _ self next.
					1 to: count do: [:i | scanLine at: rowBytes + i put: byte].
					rowBytes _ rowBytes + count]].
		array
			replaceFrom: position
			to: position + width - 1
			with: scanLine
			startingAt: 1.
		position _ position + width + pad].
	^ array
! !

!PCXReadWriter methodsFor: 'private-decoding' stamp: 'md 11/14/2003 16:51'!
readHeader

	| xMin xMax yMin yMax |
	self next.	"skip over manufacturer field"
	version _ self next.
	encoding _ self next.
	bitsPerPixel _ self next.
	xMin _ self nextWord.
	yMin _ self nextWord.
	xMax _ self nextWord.
	yMax _ self nextWord.
	width _ xMax - xMin + 1.
	height _ yMax - yMin + 1.
	self next: 4. "skip over device resolution"
	self next: 49. "skip over EGA color palette"
	colorPlanes _ self next.
	rowByteSize _ self nextWord.
	isGrayScale _ (self next: 2) = 2.
	self next: 58. "skip over filler"



! !

!PCXReadWriter methodsFor: 'private-decoding' stamp: 'tao 10/6/97 08:29'!
readPalette

	| r g b array |
	self next = 12 ifFalse: [self error: 'no Color Palette!!'].
	array _ Array new: (1 bitShift: bitsPerPixel).
	1 to: array size do:
		[:i |
		r _ self next.  g _ self next.  b _ self next.
		array at: i put: (Color r: r g: g b: b range: 255)].
	^ array.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PCXReadWriter class
	instanceVariableNames: ''!

!PCXReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:57'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('pcx')! !
Object subclass: #PHOReader
	instanceVariableNames: 'stream phonemes events pitches time'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Support'!
!PHOReader commentStamp: '<historical>' prior: 0!
My instances read PHO files with lines of the form 'phoneme duration time0 pitch0 time1 pitch1 ...'. Time is in milliseconds, and pitch is in hertz. Files on this format are used as inputs for the MBROLA synthesizer, and there are lots of them available on the web. Here's an example:

_  120 0 105
m  60 33 105
E  70 42 102
r  50 20 108
I  50 20 125 100 142
k  100
r  50 80 137
I  50 80 121
s  70
m  50
@  90 33 111 88 108
s  90
!


!PHOReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
addPitches
	| offset |
	offset := 0.0.
	events do: [ :each |
		each pitchPoints: (self pitchesBetween: offset and: offset + each duration).
		offset := offset + each duration].! !

!PHOReader methodsFor: 'accessing' stamp: 'len 8/29/1999 02:16'!
events
	^ CompositeEvent new addAll: events; yourself! !

!PHOReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
nextEvent
	| line phonemeName phoneme duration answer ptime pitch |
	line := ReadStream on: stream nextLine.
	phonemeName := line upTo: Character space.
	phoneme := phonemes at: phonemeName.
	[line peek isSeparator] whileTrue: [line next].
	duration := (line upTo: Character space) asNumber / 1000.0.
	answer := PhoneticEvent new phoneme: phoneme; duration: duration; loudness: 1.0.
	[line atEnd]
		whileFalse: [ptime := (line upTo: Character space) asNumber * duration / 100.0.
					pitch := (line upTo: Character space) asNumber asFloat.
					pitches add: time + ptime @ pitch].
	time := time + duration.
	^ answer! !

!PHOReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
pitchAt: t
	"Answer the pitch of the receiver at a given time. (Do linear interpolation.)"
	| xVal count x1 x2 y1 y2 |
	xVal := pitches first x.
	count := 1.
	[xVal < t]
		whileTrue: [count := count + 1.
					count > pitches size ifTrue: [^ pitches last y].
					xVal := (pitches at: count) x].
	xVal = t ifTrue: [^ (pitches at: count) y].
	count = 1 ifTrue: [^ pitches first y].
	x1 := (pitches at: count - 1) x.
	x2 := (pitches at: count) x.
	y1 := (pitches at: count - 1) y.
	y2 := (pitches at: count) y.
	^ (t - x1) / (x2 - x1) * (y2 - y1) + y1! !

!PHOReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
pitchesBetween: t1 and: t2
	| step |
	step := (t2 - t1 / 0.035) asInteger + 1. "step small enough"
	^ (t1 to: t2 by: t2 - t1 / step) collect: [ :each | each - t1 @ (self pitchAt: each)]! !

!PHOReader methodsFor: 'accessing' stamp: 'len 6/17/1999 01:45'!
plotPitch
	Utilities plot: ((0 to: time by: 0.050) collect: [ :each | self pitchAt: each])! !

!PHOReader methodsFor: 'accessing' stamp: 'len 6/15/1999 00:40'!
read
	stream reset.
	[stream atEnd] whileFalse: [events add: self nextEvent].
	self addPitches! !

!PHOReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
stream: aStream
	stream := aStream! !


!PHOReader methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	events := OrderedCollection new.
	pitches := OrderedCollection new.
	time := 0.0.
	phonemes := PhonemeSet sampaToArpabet! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PHOReader class
	instanceVariableNames: ''!

!PHOReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
aliceExample
	| events |
	events := self eventsFromString: self aliceExampleString.
	events do: [ :each | each pitchBy: 0.63489].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
aliceExampleFemale
	| events |
	events := self eventsFromString: self aliceExampleString.
	events do: [ :each | each pitchBy: 1.3].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
aliceExampleMale
	| events |
	events := self eventsFromString: self aliceExampleString.
	events do: [ :each | each pitchBy: 0.63489].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
aliceShortExample
	| events |
	events := self eventsFromString: self aliceShortExampleString.
	events do: [ :each | each pitchBy: 1.3].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
aliceShortExampleMale
	| events |
	events := self eventsFromString: self aliceShortExampleString.
	events do: [ :each | each pitchBy: 0.4].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'len 7/27/1999 01:47'!
mbrolaExample
	^ self eventsFromString:
'_ 50
E 40 0 102
m 50
b 50
r 30
@U 80 5 119 35 126 70 140
l 50
@ 50 50 173
w 100 75 133
V 30 85 114
z 60 75 101
d 60
@ 40
v 40 85 105
E 60 75 121
l 50 70 121
@ 60 60 150
p 50
d 70
b 70 0 90
AI 130 85 101
T 70
j 50 0 180
E 120 0 185 95 131
r 40
i 90 85 135
d 80 60 134
@ 50 0 119 50 114
t 70
w 70 10 117 65 127 85 115
A 180 0 102 55 91 95 85
_ 100
_ 100
I 80 18 111
t 80
s 50
@ 30
s 70
p 80
i 80 25 171 85 200
tS 110
s 70
I 30 35 112
n 40
T 80
@ 40 85 108
s 80
AI 130 80 115
z 70 90 125
r= 120 75 111
b 80
EI 80 95 133
z 70
d 50
A 40
n 30
D 60
@ 30 65 121
k 90
A 30
n 30 100 140
k 80
{ 70 5 170
t 70
@ 40 50 186
n 40 75 163
EI 100 90 173
S 130
@ 40
n 30 65 153
V 40
v 70 0 148
d 60
AI 130 5 112 80 109
f 110
@U 160 87 88
n 70
z 210 88 82
_ 80
_ 100
I 40 0 140
t 50
t 100
EI 60 50 221
k 70
s 80
@ 30 0 190
l 50
I 30 65 180
s 110
t 70
V 50 20 171
v 50
f 90
@U 140 25 157
n 30
i 60 66 160
m 50 60 130
z 80
@ 40 62 78
z 80
I 70 78 134
n 50 70 163
p 120
U 90 15 119 75 98
t 90
_ 140
_ 100
t 60 0 111
u 50 80 119
g 70
E 50 90 145
D 50
r= 50 40 139 90 163
w 90
I 30 15 114
D 50
_ 40
p 50
r 30 0 102
@ 30 65 110
s 120
A 50 90 148
d 80
I 50 50 178
k 80
I 50 66 167
n 60
f 50
r= 50 90 125
m 50
EI 140 95 96
S 140
@ 80 35 168
n 100 95 142
_ 190
{ 90 0 133
n 30
d 30
p 80
r 40
@ 40 0 97 65 103
d 70
j 20
u 60 65 150
s 90
I 30 50 210
z 50
s 140
p 70
i 130 0 138 95 98
tS 160
{ 70 0 127
t 50
D 50
@ 30 15 93
s 140
{ 30 35 127
m 50
p 70
l 50
I 30 35 184
N 70
f 70
r 60
i 90 30 125
k 40
w 30
@ 30 15 185
n 30
s 100
i 50 20 148 70 142
V 30 5 148
v 40
D 80
@ 40 25 106
d 80
AI 150 95 115
f 90
@U 130 95 114
n 70
d 80
EI 80 80 137
4 50
@ 30
b 100
EI 120 95 78
s 210
_ 80'! !

!PHOReader class methodsFor: 'examples' stamp: 'len 7/27/1999 01:48'!
pushExample
	^ self eventsFromString:
'_  60 0 137
p  50 100 137
u  110 90 137
S  100 10 121
D  90
@  70 57 114 100 102
s  70
t  50
A 100 57 121 64 121
r 40
t  50
b  110
V  140 21 117 57 100 92 100
_ 3
n  130 25 102 50 105
t  60
u  70 28 129 71 111
b  70
i  70 50 102
g  20 10 100 80 102
i  130 25 117 66 114
n  260 3 111 23 105 42 97 61 93 73 93
_  140 92 93 100 100'! !

!PHOReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
pushExampleFemale
	| events |
	events := self pushExample.
	events do: [ :each | each pitchBy: 1.93489].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
pushShortExample
	^ self eventsFromString:
'i  70 50 102
g  20 10 100 80 102
i  130 25 117 66 114
n  260 3 111 23 105 42 97 61 93 73 93'.
"
':= 3
n  130 25 102 50 105
t  60
u  70 28 129 71 111
b  70
i  70 50 102
g  20 10 100 80 102
i  130 25 117 66 114
n  260 3 111 23 105 42 97 61 93 73 93
:=  140 92 93 100 100'"! !

!PHOReader class methodsFor: 'examples' stamp: 'len 7/27/1999 01:48'!
xmasExample
	^ self eventsFromString:
'_  120 0 105
m  60 33 105
E  70 42 102
r  50 20 108
I  50 20 125 100 142
k  100
r  50 80 137
I  50 80 121
s  70
m  50
@  90 33 111 88 108
s  90
{  70
n  100 50 105 100 97
d  50 80 93
h  50 20 93
{  50 20 102 60 114
p  50
i  50 100 125
n  60 83 121
u 100
j  130 7 121 23 121 100 108
r=  250 41 102 83 97
_  210 95 86 100 100'
! !

!PHOReader class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
xmasKidExample
	| events |
	events := self xmasExample.
	events do: [ :each | each pitchBy: 1.6].
	^ events! !


!PHOReader class methodsFor: 'examples-private' stamp: 'len 7/27/1999 01:45'!
aliceExampleString
	^ '_ 48 0 222
{ 80 40 222 90 235
l 72 44 250 66 250
I 80
s 88
w 40 80 235
@ 40 80 210
z 64 12 210 50 181 75 181
b 72 33 173 88 181
I 56 71 181
g 56 28 153 100 166
I 64 62 160
n 40 60 160
I 88 27 166
N 40 100 166
t 80 20 160
U 40 40 181 80 166
g 48 100 166
E 104 38 153 76 137
t 56
v 48
E 72 11 166 66 153
r 88 18 160 63 166
i 112.8 14 166 49 173 77 173
t 104.8 98 137
AI 178.4 21 148 70 148 92 137
r= 108 25 137 62 133 98 129
d 49
@ 59.2 6 137 73 133
v 46
s 89
I 40 40 173
t 40 40 166
I 64 62 166
N 72 22 160 77 153
b 40 40 142 100 153
AI 136 29 142
h 80 30 142 100 148
r= 64 62 153 100 153
s 125
I 64 37 210 100 190
s 72 11 190
t 72
r= 104 30 160 69 142
O 72
n 40 40 142
D 40 40 153
@ 40 40 160
b 40 40 153 100 160
{ 216 18 166 51 166 70 153 88 137 100 133
n 40
k 56
_ 144 94 129 100 100
_ 100 0 137
{ 40
n 88 9 137 36 137 72 142
t 40 40 137 60 133
@ 48 16 148 100 148
h 40 100 142
{ 48 83 148
v 48 16 142
I 56 14 148 85 137
N 56 71 137
n 64 37 137 100 142
O 96 41 137 83 153 100 153
T 64
I 56 42 166
N 64 12 160 75 153
t 80 30 142
@ 56 28 166 100 148
d 56 71 137
u 160 15 160 45 160 70 153 95 142
w 136 23 137 58 137 88 148
A 112 21 153 57 160 92 173
n 64 50 166 62 153
s 56
O 48 50 153
r 40 40 142 100 133
t 130
w 56 57 166
AI 168 9 173 33 166 57 153 80 148 100 148
s 88
_ 300
S 92
i 48 50 235
h 40 40 235 100 250
@ 40 60 210 100 210
d 40
p 40
i 150
k 56
d 56
I 72 44 222 100 210
n 40 80 210
t 56
@ 48 83 181
D 40 39 173 99 173
@ 39.2 100 160
b 104 30 153 100 153
U 112 35 153 85 153 100 153
k 72
h 56
r= 48 50 200
s 136 5 181
I 64 25 166 87 142
s 56 14 137
t 56
r= 56 28 173 100 173
w 56 71 166
@ 56 42 181
z 48 16 181 50 173
r 120 73 181
i 104 7 190 69 190 100 181
d 40
I 112 7 166 50 137 85 129
N 80 30 114 50 111
_ 56 83 111 100 100
_ 140 0 153
b 40 60 153 100 153
U 64 75 148
4 40 80 148 100 142
I 40
t 40 40 148
h 40 40 142
{ 48 33 137
d 136 5 133 11 129 88 148
n 48 66 148
@U 144 16 160 44 173 72 190 100 210
p 80
I 96 75 190 100 181
k 56
tS 96
r= 104 30 190 69 181
z 72 11 181 33 173
O 40 60 173
r 64 37 160 100 153
k 72 11 153
O 152 63 190 89 200
n 40 60 181
v 40 60 166
r= 40 60 160
s 104 15 142
EI 120 20 190 53 190 86 210
S 104 7 210
@ 56 28 181 100 160
n 64 62 153 100 137
z 40
I 56 14 148 85 133
n 40 100 133
I 96 41 129 83 125
t 80
_ 64 85 125 100 100
_ 140 0 222
{ 56 14 222 28 220 42 235 85 235 100 220
n 96 33 222 75 235 100 235
w 48 33 222 66 250
O 90
4 48 50 222 66 252
I 48 33 250
z 64 12 235 62 210
D 56
@ 56 71 190
j 104 23 166 61 166 100 181
u 112 35 190 42 210 71 210 100 210
s 150
@ 56 42 200
v 40 20 160 60 148
@ 64 25 153 87 142
b 136 23 133 47 137
U 96 8 160 50 173 91 181 100 181
k 56
_ 56
T 56
O 119.2 20 166 53 142 80 137
4 40 20 133
{ 136 5 137 35 129 64 125
l 48 16 125 100 133
I 80 50 153 100 181
s 120
_ 40
_ 40
w 88 9 166 54 142
I 40 40 142
D 40 40 137
aU 62.4 38 137 63 133
t 80
p 55
I 72 16 210 38 210
k 40
tS 75.2 99 173
r= 136 29 160 64 160 76 166
z 48
O 44 90 185
r 60 6 198 46 200 72 190
k 40
O 81.6 12 148 61 133
n 40 20 133
v 48 33 133
r= 56 28 181 100 181
s 120 6 173
EI 136 11 222 41 210 94 210
S 120
@ 128 12 190 43 148 75 137
n 64 12 129 50 125
_ 80 88 125 100 100'! !

!PHOReader class methodsFor: 'examples-private' stamp: 'len 7/27/1999 01:46'!
aliceShortExampleString
	^ '_ 48 0 222
{ 80 40 222 90 235
l 72 44 250 66 250
I 80
s 88
w 40 80 235
@ 40 80 210
z 64 12 210 50 181 75 181
b 72 33 173 88 181
I 56 71 181
g 56 28 153 100 166
I 64 62 160
n 40 60 160
I 88 27 166
N 40 100 166
t 80 20 160
U 40 40 181 80 166
g 48 100 166
E 104 38 153 76 137
t 56
v 48
E 72 11 166 66 153
r 88 18 160 63 166
i 112.8 14 166 49 173 77 173
t 104.8 98 137
AI 178.4 21 148 70 148 92 137
r= 108 25 137 62 133 98 129
d 49
@ 59.2 6 137 73 133
v 46
s 89
I 40 40 173
t 40 40 166
I 64 62 166
N 72 22 160 77 153
b 40 40 142 100 153
AI 136 29 142
h 80 30 142 100 148
@ 60 50 150
r= 64 62 153 100 153
s 125
I 64 37 210 100 190
s 72 11 190
t 72
r= 104 30 160 69 142
O 72
n 40 40 142
D 40 40 153
@ 40 40 160
b 40 40 153 100 160
{ 216 18 166 51 166 70 153 88 137 100 133
n 40
k 56
_ 144 94 129 100 100'! !


!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/15/1999 00:48'!
eventsFromStream: aStream
	^ self new stream: aStream; read; events! !

!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/15/1999 00:49'!
eventsFromString: aString
	^ self eventsFromStream: (ReadStream on: aString)! !

!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/17/1999 01:47'!
plotPitchFromStream: aStream
	^ self new stream: aStream; read; plotPitch! !

!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/17/1999 01:47'!
plotPitchFromString: aString
	^ self plotPitchFromStream: (ReadStream on: aString)! !
ImageReadWriter subclass: #PNGReadWriter
	instanceVariableNames: 'chunk form width height depth backColor bitsPerChannel colorType interlaceMethod bitsPerPixel bytesPerScanline thisScanline prevScanline rowSize globalDataChunk unknownChunks palette transparentPixelValue filtersSeen swizzleMap cachedDecoderMap bigEndian'
	classVariableNames: 'BPP BlockHeight BlockWidth Debugging StandardColors StandardSwizzleMaps'
	poolDictionaries: ''
	category: 'Graphics-Files'!
!PNGReadWriter commentStamp: '<historical>' prior: 0!
I am a subclass of ImageReadWriter that decodes Portable Network Graphics
(PNG) images.

Submitted by Duane Maxwell!


!PNGReadWriter methodsFor: 'accessing' stamp: 'RAA 11/7/2000 09:20'!
debugging

	^Debugging == true! !

!PNGReadWriter methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:51'!
nextImage
	bigEndian := SmalltalkImage current isBigEndian.
	filtersSeen := Bag new.
	globalDataChunk := nil.
	transparentPixelValue := nil.
	unknownChunks := Set new.
	stream reset.
	stream binary.
	stream skip: 8.
	[stream atEnd] whileFalse: [self processNextChunk].
	"Set up our form"
	palette ifNotNil: 
			["Dump the palette if it's the same as our standard palette"

			palette = (StandardColors copyFrom: 1 to: palette size) 
				ifTrue: [palette := nil]].
	(depth <= 8 and: [palette notNil]) 
		ifTrue: 
			[form := ColorForm extent: width @ height depth: depth.
			form colors: palette]
		ifFalse: [form := Form extent: width @ height depth: depth].
	backColor ifNotNil: [form fillColor: backColor].
	chunk := globalDataChunk ifNil: [self error: 'image data is missing'].
	chunk ifNotNil: [self processIDATChunk].
	unknownChunks isEmpty 
		ifFalse: 
			["Transcript show: ' ',unknownChunks asSortedCollection asArray printString."

			].
	self debugging 
		ifTrue: 
			[Transcript
				cr;
				show: 'form = ' , form printString.
			Transcript
				cr;
				show: 'colorType = ' , colorType printString.
			Transcript
				cr;
				show: 'interlaceMethod = ' , interlaceMethod printString.
			Transcript
				cr;
				show: 'filters = ' , filtersSeen sortedCounts asArray printString].
	^form! !

!PNGReadWriter methodsFor: 'accessing' stamp: 'DSM 3/24/2000 01:12'!
understandsImageFormat
	#(137 80 78 71 13 10 26 10) do: [ :byte |
		stream next = byte ifFalse: [^ false]].
	^ true
! !


!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/10/2004 23:55'!
processBackgroundChunk

	| val red green blue max |

	"Transcript show: '  BACKGROUND: ',chunk printString."
	colorType = 3 ifTrue: [
		backColor := palette at: chunk first + 1.
		^self
	].
	max _ (2 raisedTo: bitsPerChannel) - 1.
	(colorType = 0 or: [colorType = 4]) ifTrue: [
		val _ chunk unsignedShortAt: 1 bigEndian: true.
		backColor := Color gray: val / max.
		^self
	].
	(colorType = 2 or: [colorType = 6]) ifTrue: [
		red _ chunk unsignedShortAt: 1 bigEndian: true.
		green _ chunk unsignedShortAt: 3 bigEndian: true.
		blue _ chunk unsignedShortAt: 5 bigEndian: true.
		backColor := Color r: red/max g: green/max b: blue/max.
		^self
	].
"self halt."

"====
The bKGD chunk specifies a default background color to present the image against. Note that viewers are not bound to honor this chunk; a viewer can choose to use a different background. 

For color type 3 (indexed color), the bKGD chunk contains: 


   Palette index:  1 byte

The value is the palette index of the color to be used as background. 

For color types 0 and 4 (grayscale, with or without alpha), bKGD contains: 


   Gray:  2 bytes, range 0 .. (2^bitdepth)-1

(For consistency, 2 bytes are used regardless of the image bit depth.) The value is the gray level to be used as background. 

For color types 2 and 6 (truecolor, with or without alpha), bKGD contains: 


   Red:   2 bytes, range 0 .. (2^bitdepth)-1
   Green: 2 bytes, range 0 .. (2^bitdepth)-1
   Blue:  2 bytes, range 0 .. (2^bitdepth)-1

(For consistency, 2 bytes per sample are used regardless of the image bit depth.) This is the RGB color to be used as background. 

When present, the bKGD chunk must precede the first IDAT chunk, and must follow the PLTE chunk, if any. 
==="
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 17:00'!
processIDATChunk

	interlaceMethod = 0
		ifTrue: [ self processNonInterlaced ]
		ifFalse: [ self processInterlaced ]
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/10/2004 23:55'!
processIHDRChunk
	width _ chunk longAt: 1 bigEndian: true.
	height _ chunk longAt: 5 bigEndian: true.
	bitsPerChannel _ chunk at: 9.
	colorType _ chunk at: 10.
	"compression _ chunk at: 11." "TODO - validate compression"
	"filterMethod _ chunk at: 12." "TODO - validate filterMethod"
	interlaceMethod _ chunk at: 13. "TODO - validate interlace method"
	(#(2 4 6) includes: colorType)
		ifTrue: [depth _ 32].
	(#(0 3) includes: colorType) ifTrue: [
		depth _ bitsPerChannel min: 8.
		colorType = 0 ifTrue: [ "grayscale"
			palette := self grayColorsFor: depth.
		].
	].
	bitsPerPixel _ (BPP at: colorType+1) at: bitsPerChannel highBit.
	bytesPerScanline _ width * bitsPerPixel + 7 // 8.
	rowSize _ width * depth + 31 >> 5.
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/29/2004 04:19'!
processInterlaced
	| z filter bytesPerPass startingCol colIncrement rowIncrement startingRow cx sc temp |
	startingCol _ #(0 4 0 2 0 1 0 ).
	colIncrement _ #(8 8 4 4 2 2 1 ).
	rowIncrement _ #(8 8 8 4 4 2 2 ).
	startingRow _ #(0 0 4 0 2 0 1 ).
	z _ ZLibReadStream on: chunk from: 1 to: chunk size.
	1 to: 7 do: [:pass |
		(self doPass: pass)
			ifTrue:
				[cx _ colIncrement at: pass.
				sc _ startingCol at: pass.
				bytesPerPass _ width - sc + cx - 1 // cx * bitsPerPixel + 7 // 8.
				prevScanline _ ByteArray new: bytesPerPass.
				thisScanline _ ByteArray new: bytesPerScanline.
				(startingRow at: pass)
					to: height - 1
					by: (rowIncrement at: pass)
					do: [:y |
						filter _ z next.
						filtersSeen add: filter.
						(filter isNil or: [(filter between: 0 and: 4) not])
							ifTrue: [^ self].
						thisScanline _ z next: bytesPerPass into: thisScanline startingAt: 1.
						self filterScanline: filter count: bytesPerPass.
						self copyPixels: y at: sc by: cx.
						temp := prevScanline.
						prevScanline := thisScanline.
						thisScanline := temp.
					]
				]
	].
	z atEnd ifFalse:[self error:'Unexpected data'].! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/11/2004 12:14'!
processNextChunk

	| length chunkType crc chunkCrc |

	length _ self nextLong.

	chunkType _ (self next: 4) asString.
	chunk _ self next: length.
	chunkCrc := self nextLong bitXor: 16rFFFFFFFF.
	crc := self updateCrc: 16rFFFFFFFF from: 1 to: 4 in: chunkType.
	crc := self updateCrc: crc from: 1 to: length in: chunk.
	crc = chunkCrc ifFalse:[
		self error: 'PNGReadWriter crc error in chunk ', chunkType.
	].

	chunkType = 'IEND' ifTrue: [^self	"*should* be the last chunk"].
	chunkType = 'sBIT' ifTrue: [^self processSBITChunk "could indicate unusual sample depth in original"].
	chunkType = 'gAMA' ifTrue: [^self 	"indicates gamma correction value"].
	chunkType = 'bKGD' ifTrue: [^self processBackgroundChunk].
	chunkType = 'pHYs' ifTrue: [^self processPhysicalPixelChunk].
	chunkType = 'tRNS' ifTrue: [^self processTransparencyChunk].

	chunkType = 'IHDR' ifTrue: [^self processIHDRChunk].
	chunkType = 'PLTE' ifTrue: [^self processPLTEChunk].
	chunkType = 'IDAT' ifTrue: [
		"---since the compressed data can span multiple
		chunks, stitch them all together first. later,
		if memory is an issue, we need to figure out how
		to do this on the fly---"
		globalDataChunk _ globalDataChunk ifNil: [chunk] ifNotNil:
			[globalDataChunk,chunk].
		^self
	].
	unknownChunks add: chunkType.
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/29/2004 04:19'!
processNonInterlaced
	| z filter temp copyMethod debug |
	debug := self debugging.
	copyMethod _ #(copyPixelsGray: nil copyPixelsRGB: copyPixelsIndexed:
		  copyPixelsGrayAlpha: nil copyPixelsRGBA:) at: colorType+1.
	debug ifTrue: [ Transcript cr; nextPutAll: 'NI chunk size='; print: chunk size ].
	z _ ZLibReadStream on: chunk from: 1 to: chunk size.
	prevScanline _ ByteArray new: bytesPerScanline.
	thisScanline := ByteArray new: bytesPerScanline.
	0 to: height-1 do: [ :y |
		filter _ (z next: 1) first.
		debug ifTrue:[filtersSeen add: filter].
		thisScanline _ z next: bytesPerScanline into: thisScanline startingAt: 1.
		(debug and: [ thisScanline size < bytesPerScanline ]) ifTrue: [ Transcript nextPutAll: ('wanted {1} but only got {2}' format: { bytesPerScanline. thisScanline size }); cr ].
		filter = 0 ifFalse:[self filterScanline: filter count: bytesPerScanline].
		self perform: copyMethod with: y.
		temp := prevScanline.
		prevScanline := thisScanline.
		thisScanline := temp.
		].
	z atEnd ifFalse:[self error:'Unexpected data'].
	debug ifTrue: [Transcript  nextPutAll: ' compressed size='; print: z position  ].
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/11/2004 01:02'!
processPLTEChunk

	| colorCount i |

	colorCount _ chunk size // 3. "TODO - validate colorCount against depth"
	palette _ Array new: colorCount.
	0 to: colorCount-1 do: [ :index |
		i _ index * 3 + 1.
		palette at: index+1 put:
			(Color r: (chunk at: i)/255.0 g: (chunk at: i+1)/255.0 b: (chunk at: i+2)/255.0)
		].! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/5/2000 11:24'!
processPhysicalPixelChunk

	"Transcript show: '  PHYSICAL: ',chunk printString."
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 12/12/2003 18:33'!
processSBITChunk
	| rBits gBits bBits aBits |
	colorType = 6 ifFalse:[^self].
	rBits := chunk at: 1.
	gBits := chunk at: 2.
	bBits := chunk at: 3.
	aBits := chunk at: 4.
	(rBits = 5 and:[gBits = 5 and:[bBits = 5 and:[aBits = 1]]]) ifTrue:[
		depth := 16.
	].! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 16:22'!
processTransparencyChunk

	| red green blue |

	"Transcript show: '  TRANSPARENCY ',chunk printString."
	colorType = 0 ifTrue: [
		transparentPixelValue _ chunk unsignedShortAt: 1 bigEndian: true.
		^self
	].
	colorType = 2 ifTrue: [
		red _ chunk at: 2.
		green _ chunk at: 2.
		blue _ chunk at: 2.
		transparentPixelValue _ 16rFF00 + red << 8 + green << 8 + blue.
		^self
	].
	colorType = 3 ifTrue: [
		chunk withIndexDo: [ :alpha :index |
			palette at: index put: ((palette at: index) alpha: alpha/255)
		].
		^self
	].
! !


!PNGReadWriter methodsFor: 'filtering' stamp: 'RAA 11/7/2000 09:43'!
filterAverage: count
	"Use the average of the pixel to the left and the pixel above as a predictor"

	| delta |
	delta _ bitsPerPixel // 8 max: 1.
	1 to: delta do: [:i |
		thisScanline at: i put: ((thisScanline at: i) + ((prevScanline at: i) // 2) bitAnd: 255)].
	delta + 1 to: count do: [:i |
		thisScanline at: i put:
			((thisScanline at: i)
			+ ((prevScanline at: i)
			+ (thisScanline at: i - delta) // 2) bitAnd: 255)]! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:54'!
filterHorizontal: count
	"Use the pixel to the left as a predictor"

	| delta |
	delta _ bitsPerPixel // 8 max: 1.
	delta+1 to: count do: [ :i |
		thisScanline at: i put: (((thisScanline at: i) +
(thisScanline at: i-delta)) bitAnd: 255) ]


! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:55'!
filterNone: count
! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'RAA 11/7/2000 09:45'!
filterPaeth: count
	"Select one of (the pixel to the left, the pixel above and the pixel to above left) to
	predict the value of this pixel"

	| delta |
	delta _ bitsPerPixel // 8 max: 1.
	1 to: delta do: [ :i |
		thisScanline at: i put:
			(((thisScanline at: i) + (prevScanline at: i)) bitAnd: 255)].
	delta+1 to: count do: [ :i |
		thisScanline
			at: i
			put: (((thisScanline at: i) + (self
				paethPredictLeft: (thisScanline at: i-delta)
				above: (prevScanline at: i)
				aboveLeft: (prevScanline at: i-delta)))
					bitAnd: 255)]

! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'eat 9/11/2000 20:08'!
filterScanline: filterType count: count

	self
		perform: (
			#(filterNone: filterHorizontal: filterVertical: filterAverage: filterPaeth:)
				at: filterType+1)
		with: count.

! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:54'!
filterVertical: count
	"Use the pixel above as a predictor"

	1 to: count do: [ :i |
		thisScanline at: i put: (((thisScanline at: i) +
(prevScanline at: i)) bitAnd: 255) ]

! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'eat 9/11/2000 20:05'!
paethPredictLeft: a above: b aboveLeft: c
	"Predicts the value of a pixel based on nearby pixels, based on
Paeth (GG II, 1991)"

	| pa pb pc |
	pa _ b > c ifTrue: [b - c] ifFalse: [c - b].
	pb _ a > c ifTrue: [a - c] ifFalse: [c - a].
	pc _ a + b - c - c.
	pc < 0 ifTrue: [
		pc := pc * -1].
	((pa <= pb) and: [pa <= pc]) ifTrue: [^ a].
	(pb <= pc) ifTrue: [^ b].
	^ c
! !


!PNGReadWriter methodsFor: 'miscellaneous' stamp: 'DSM 4/27/2000 13:09'!
doPass: pass
	"Certain interlace passes are skipped with certain small image
dimensions"

	pass = 1 ifTrue: [ ^ true ].
	((width = 1) and: [height = 1]) ifTrue: [ ^ false ].
	pass = 2 ifTrue: [ ^ width >= 5 ].
	pass = 3 ifTrue: [ ^ height >= 5 ].
	pass = 4 ifTrue: [ ^ (width >=3 ) or: [height >= 5] ].
	pass = 5 ifTrue: [ ^ height >=3 ].
	pass = 6 ifTrue: [ ^ width >=2 ].
	pass = 7 ifTrue: [ ^ height >=2 ].

! !

!PNGReadWriter methodsFor: 'miscellaneous' stamp: 'ar 2/11/2004 01:27'!
grayColorsFor: d
	"return a color table for a gray image"

	palette _ Array new: 1<<d.
	d = 1 ifTrue: [
		palette at: 1 put: Color black.
		palette at: 2 put: Color white.
		^ palette,{Color transparent}
		].
	d = 2 ifTrue: [
		palette at: 1 put: Color black.
		palette at: 2 put: (Color gray: 85.0 / 255.0).
		palette at: 3 put: (Color gray: 170.0 / 255.0).
		palette at: 4 put: Color white.
		^ palette,{Color transparent}.
		].
	d = 4 ifTrue: [
		0 to: 15 do: [ :g |
			palette at: g+1 put: (Color gray: (g/15) asFloat) ].
		^ palette,{Color transparent}
		].
	d = 8 ifTrue: [
		0 to: 255 do: [ :g |
			palette at: g+1 put: (Color gray: (g/255) asFloat) ].
		^ palette		"??transparent??"
		].
! !


!PNGReadWriter methodsFor: 'pixel copies' stamp: 'DSM 3/26/2000 21:32'!
copyPixels: y
	"Handle non-interlaced pixels of supported colorTypes"

	| s |
	s _ #(copyPixelsGray: nil copyPixelsRGB: copyPixelsIndexed:
		  copyPixelsGrayAlpha: nil copyPixelsRGBA:) at: colorType+1.
	self perform: s asSymbol with: y
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:08'!
copyPixels: y at: startX by: incX
	"Handle interlaced pixels of supported colorTypes"

	| s |
	s _ #(copyPixelsGray:at:by: nil copyPixelsRGB:at:by: copyPixelsIndexed:at:by:
		  copyPixelsGrayAlpha:at:by: nil copyPixelsRGBA:at:by:) at: colorType+1.
	self perform: s asSymbol with: y with: startX with: incX
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:12'!
copyPixelsGray: y 
	"Handle non-interlaced grayscale color mode (colorType = 0)"
	| blitter pixPerByte mask shifts pixelNumber rawByte pixel transparentIndex |
	blitter _ BitBlt current bitPokerToForm: form.
	transparentIndex _ form colors size.
	bitsPerChannel = 16
		ifTrue: [0
				to: width - 1
				do: [:x | blitter pixelAt: x @ y put: 255
							- (thisScanline at: x << 1 + 1)].
			^ self]
		ifFalse: [bitsPerChannel = 8
				ifTrue: [1
						to: width
						do: [:x | blitter
								pixelAt: x - 1 @ y
								put: (thisScanline at: x)].
					^ self].
			bitsPerChannel = 1
				ifTrue: [pixPerByte _ 8.
					mask _ 1.
					shifts _ #(7 6 5 4 3 2 1 0 )].
			bitsPerChannel = 2
				ifTrue: [pixPerByte _ 4.
					mask _ 3.
					shifts _ #(6 4 2 0 )].
			bitsPerChannel = 4
				ifTrue: [pixPerByte _ 2.
					mask _ 15.
					shifts _ #(4 0 )].
			pixelNumber _ 0.
			0 to: width - 1 do: [:x | 
				rawByte _ thisScanline at: pixelNumber // pixPerByte + 1.
				pixel _ rawByte
							>> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask.
				pixel = transparentPixelValue ifTrue: [pixel _ transparentIndex].
				blitter pixelAt: x @ y put: pixel.
				pixelNumber _ pixelNumber + 1
			]
		]! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:09'!
copyPixelsGray: y at: startX by: incX
	"Handle interlaced grayscale color mode (colorType = 0)"

	| b offset bits w pixel mask blitter pixelNumber pixPerByte rawByte
shifts |
	bitsPerChannel = 16
		ifTrue: [
			b _ BitBlt current bitPokerToForm: form.
			startX to: width-1 by: incX do: [ :x |
				b pixelAt: x@y put: 255 - (thisScanline at: (x//incX<<1)+1).
				].
			^ self
			].
	offset _ y*rowSize+1.
	bits _ form bits.
	bitsPerChannel = 8 ifTrue: [
		startX to: width-1 by: incX do: [ :x |
			w _ offset + (x>>2).
			b _ 3- (x \\ 4) * 8.
			pixel _ (thisScanline at: x // incX + 1)<<b.
			mask _ (255<<b) bitInvert32.
			bits at: w put: (((bits at: w) bitAnd: mask) bitOr: pixel)
		].
		^ self
	].
	bitsPerChannel = 1 ifTrue: [
		pixPerByte _ 8.
		mask _ 1.
		shifts _ #(7 6 5 4 3 2 1 0).
	].
	bitsPerChannel = 2 ifTrue: [
		pixPerByte _ 4.
		mask _ 3.
		shifts _ #(6 4 2 0).
	].
	bitsPerChannel = 4 ifTrue: [
		pixPerByte _ 2.
		mask _ 15.
		shifts _ #(4 0).
	].

	blitter _ BitBlt current bitPokerToForm: form.
	pixelNumber _ 0.
	startX to: width-1 by: incX do: [ :x |
		rawByte _ thisScanline at: (pixelNumber // pixPerByte) + 1.
		pixel _ (rawByte >> (shifts at: (pixelNumber \\ pixPerByte) + 1)) bitAnd: mask.
		blitter pixelAt: (x@y) put: pixel.
		pixelNumber _ pixelNumber + 1.
	].
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:09'!
copyPixelsGrayAlpha: y
	"Handle non-interlaced grayscale with alpha color mode (colorType = 4)"

	| i pixel gray b |
	b _ BitBlt current bitPokerToForm: form.
	bitsPerChannel = 8
		ifTrue: [
			0 to: width-1 do: [ :x |
				i _ (x << 1) + 1.
				gray _ thisScanline at: i.
				pixel _ ((thisScanline at: i+1)<<24) + (gray<<16) + (gray<<8) + gray.
				b pixelAt: x@y put: pixel.
				]
			]
		ifFalse: [
			0 to: width-1 do: [ :x |
				i _ (x << 2) + 1.
				gray _ thisScanline at: i.
				pixel _ ((thisScanline at: i+2)<<24) + (gray<<16) + (gray<<8) + gray.
				b pixelAt: x@y put: pixel.
				]
			]
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:09'!
copyPixelsGrayAlpha: y at: startX by: incX
	"Handle interlaced grayscale with alpha color mode (colorType = 4)"

	| i pixel gray b |
	b _ BitBlt current bitPokerToForm: form.
	bitsPerChannel = 8
		ifTrue: [
			startX to: width-1 by: incX do: [ :x |
				i _ (x // incX << 1) + 1.
				gray _ thisScanline at: i.
				pixel _ ((thisScanline at: i+1)<<24) + (gray<<16) + (gray<<8) + gray.
				b pixelAt: x@y put: pixel.
				]
			]
		ifFalse: [
			startX to: width-1 by: incX do: [ :x |
				i _ (x // incX << 2) + 1.
				gray _ thisScanline at: i.
				pixel _ ((thisScanline at: i+2)<<24) + (gray<<16) + (gray<<8) + gray.
				b pixelAt: x@y put: pixel.
				]
			]
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 1/1/1970 21:00'!
copyPixelsIndexed: y
	"Handle non-interlaced indexed color mode (colorType = 3)"
	| hack hackBlt swizzleHack swizzleBlt scanline hackDepth |
	scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4.
	scanline replaceFrom: 1 to: thisScanline size with: thisScanline startingAt: 1.
	hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated].
	hack := Form extent: width@1 depth: hackDepth bits: scanline.
	hackBlt := BitBlt toForm: form.
	hackBlt sourceForm: hack.
	hackBlt combinationRule: Form over.
	hackBlt destOrigin: 0@y.
	hackBlt width: width; height: 1.

	(form depth < 8 and:[bigEndian not]) ifTrue:[
		swizzleHack := Form new hackBits: scanline.
		swizzleBlt := BitBlt toForm: swizzleHack.
		swizzleBlt sourceForm: swizzleHack.
		swizzleBlt combinationRule: Form over.
		swizzleBlt colorMap: (StandardSwizzleMaps at: form depth).
		swizzleBlt copyBits.
	].

	hackBlt copyBits.! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:23'!
copyPixelsIndexed: y at: startX by: incX
	"Handle interlaced indexed color mode (colorType = 3)"

	| offset b bits w pixel mask pixPerByte shifts blitter pixelNumber rawByte |
	offset _ y*rowSize+1.
	bits _ form bits.
	bitsPerChannel = 8
		ifTrue: [
			startX to: width-1 by: incX do: [ :x |
				w _ offset + (x>>2).
				b _ 3 - (x \\ 4) * 8.
				pixel _ (thisScanline at: x // incX + 1)<<b.
				mask _ (255<<b) bitInvert32.
				bits at: w put: (((bits at: w) bitAnd: mask) bitOr: pixel)].
			^ self ].
	bitsPerChannel = 1 ifTrue: [
		pixPerByte _ 8.
		mask _ 1.
		shifts _ #(7 6 5 4 3 2 1 0).
	].
	bitsPerChannel = 2 ifTrue: [
		pixPerByte _ 4.
		mask _ 3.
		shifts _ #(6 4 2 0).
	].
	bitsPerChannel = 4 ifTrue: [
		pixPerByte _ 2.
		mask _ 15.
		shifts _ #(4 0).
	].

	blitter _ BitBlt current bitPokerToForm: form.
	pixelNumber _ 0.
	startX to: width-1 by: incX do: [ :x |
		rawByte _ thisScanline at: (pixelNumber // pixPerByte) + 1.
		pixel _ (rawByte >> (shifts at: (pixelNumber \\ pixPerByte) + 1)) bitAnd: mask.
		blitter pixelAt: (x@y) put: pixel.
		pixelNumber _ pixelNumber + 1.
	].
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/7/2000 09:30'!
copyPixelsRGB: y
	"Handle non-interlaced RGB color mode (colorType = 2)"

	| i pixel tempForm tempBits |

	tempForm _ Form extent: width@1 depth: 32.
	tempBits _ tempForm bits.
	pixel := LargePositiveInteger new: 4.
	pixel at: 4 put: 16rFF.
	bitsPerChannel = 8 ifTrue: [
		i := 1.
		1 to: width do: [ :x |
			pixel
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+1);
				at: 1 put: (thisScanline at: i+2).
			tempBits at: x put: pixel.
			i _ i + 3.
		]
	] ifFalse: [
		i := 1.
		1 to: width do: [ :x |
			pixel
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+2);
				at: 1 put: (thisScanline at: i+4).
			tempBits at: x put: pixel.
			i _ i + 6.
		]
	].
	transparentPixelValue ifNotNil: [
		1 to: width do: [ :x |
			(tempBits at: x) = transparentPixelValue ifTrue: [
				tempBits at: x put: 0.
			].
		].
	].
	tempForm displayOn: form at: 0@y rule: Form paint.
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'nk 7/27/2004 17:18'!
copyPixelsRGB: y at: startX by: incX
	"Handle interlaced RGB color mode (colorType = 2)"

	| i pixel tempForm tempBits xx loopsToDo |

	tempForm _ Form extent: width@1 depth: 32.
	tempBits _ tempForm bits.
	pixel := LargePositiveInteger new: 4.
	pixel at: 4 put: 16rFF.
	loopsToDo _ width - startX + incX - 1 // incX.
	bitsPerChannel = 8 ifTrue: [
		i _ (startX // incX * 3) + 1.
		xx _ startX+1.
		1 to: loopsToDo do: [ :j |
			pixel
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+1);
				at: 1 put: (thisScanline at: i+2).
			tempBits at: xx put: pixel.
			i _ i + 3.
			xx _ xx + incX.
		]
	] ifFalse: [
		i _ (startX // incX * 6) + 1.
		xx _ startX+1.
		1 to: loopsToDo do: [ :j |
			pixel
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+2);
				at: 1 put: (thisScanline at: i+4).
			tempBits at: xx put: pixel.
			i _ i + 6.
			xx _ xx + incX.
		].
	].
	transparentPixelValue ifNotNil: [
		startX to: width-1 by: incX do: [ :x |
			(tempBits at: x+1) = transparentPixelValue ifTrue: [
				tempBits at: x+1 put: 0.
			].
		].
	].
	tempForm displayOn: form at: 0@y rule: Form paint.

! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 2/18/2004 23:58'!
copyPixelsRGBA: y
	"Handle non-interlaced RGBA color modes (colorType = 6)"

	| i pixel tempForm tempBits ff |
	bitsPerChannel = 8 ifTrue: [
		ff := Form extent: width@1 depth: 32 bits: thisScanline.
		cachedDecoderMap 
			ifNil:[cachedDecoderMap := self rgbaDecoderMapForDepth: depth].
		(BitBlt toForm: form)
			sourceForm: ff;
			destOrigin: 0@y;
			combinationRule: Form over;
			colorMap: cachedDecoderMap;
			copyBits.
		^self.
	].
	tempForm _ Form extent: width@1 depth: 32.
	tempBits _ tempForm bits.
	pixel := LargePositiveInteger new: 4.
	i := -7.
	0 to: width-1 do: [ :x |
			i := i + 8.
			pixel at: 4 put: (thisScanline at: i+6);
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+2);
				at: 1 put: (thisScanline at: i+4).
			tempBits at: x+1 put: pixel.
	].
	tempForm displayOn: form at: 0@y rule: Form over.
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'nk 7/27/2004 17:57'!
copyPixelsRGBA: y at: startX by: incX
	"Handle interlaced RGBA color modes (colorType = 6)"

	| i pixel tempForm tempBits |

	tempForm _ Form extent: width@1 depth: 32.
	tempBits _ tempForm bits.
	pixel := LargePositiveInteger new: 4.
	bitsPerChannel = 8 ifTrue: [
		i _ (startX // incX << 2) + 1.
		startX to: width-1 by: incX do: [ :x |
			pixel at: 4 put: (thisScanline at: i+3);
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+1);
				at: 1 put: (thisScanline at: i+2).
			tempBits at: x+1 put: pixel.
			i _ i + 4.
		]
	] ifFalse: [
		i _ (startX // incX << 3) +1.
		startX to: width-1 by: incX do: [ :x |
			pixel at: 4 put: (thisScanline at: i+6);
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+2);
				at: 1 put: (thisScanline at: i+4).
			tempBits at: x+1 put: pixel.
			i _ i + 8.
		].
	].
	tempForm displayOn: form at: 0@y rule: Form paintAlpha.

! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 2/19/2004 00:10'!
rgbaDecoderMapForDepth: decoderDepth
	bigEndian ifTrue:[
		depth = 16 ifTrue:[
			"Big endian, 32 -> 16 color mapping."
			^ColorMap
				shifts: #(-17 -14 -11 0)
				masks: #(16rF8000000 16rF80000 16rF800 16r00)
		] ifFalse:[
			"Big endian, 32 -> 32 color mapping"
			^ColorMap 
				shifts: #(-8 -8 -8 24) 
				masks: #(16rFF000000 16rFF0000 16rFF00 16rFF).
		].
	].
	depth = 16 ifTrue:[
		"Little endian, 32 -> 16 color mapping."
		^ColorMap
			shifts: #(7 -6 -19 0)
			masks: #(16rF8 16rF800 16rF80000 0)
	] ifFalse:[
		"Little endian, 32 -> 32 color mapping"
		^ColorMap 
			shifts: #(-16 0 16 0) 
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000).
	].! !


!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 16:37'!
nextPutImage: aForm
	"Write out the given form. We're keeping it simple here, no interlacing, no filters."
	^self nextPutImage: aForm interlace: 0 filter: 0. "no filtering"! !

!PNGReadWriter methodsFor: 'writing' stamp: 'nk 7/30/2004 17:51'!
nextPutImage: aForm interlace: aMethod filter: aFilterType 
	"Note: For now we keep it simple - interlace and filtering are simply ignored"

	| crcStream |
	bigEndian := SmalltalkImage current isBigEndian.
	form := aForm.
	width := aForm width.
	height := aForm height.
	aForm depth <= 8 
		ifTrue: 
			[bitsPerChannel := aForm depth.
			colorType := 3.
			bytesPerScanline := (width * aForm depth + 7) // 8]
		ifFalse: 
			[bitsPerChannel := 8.
			colorType := 6.
			bytesPerScanline := width * 4].
	self writeFileSignature.
	crcStream := WriteStream on: (ByteArray new: 1000).
	crcStream resetToStart.
	self writeIHDRChunkOn: crcStream.
	self writeChunk: crcStream.
	form depth <= 8 
		ifTrue: 
			[crcStream resetToStart.
			self writePLTEChunkOn: crcStream.
			self writeChunk: crcStream.
			form isColorForm 
				ifTrue: 
					[crcStream resetToStart.
					self writeTRNSChunkOn: crcStream.
					self writeChunk: crcStream]].
	form depth = 16 
		ifTrue: 
			[crcStream resetToStart.
			self writeSBITChunkOn: crcStream.
			self writeChunk: crcStream].
	crcStream resetToStart.
	self writeIDATChunkOn: crcStream.
	self writeChunk: crcStream.
	crcStream resetToStart.
	self writeIENDChunkOn: crcStream.
	self writeChunk: crcStream! !

!PNGReadWriter methodsFor: 'writing' stamp: 'nk 2/17/2004 16:51'!
updateCrc: oldCrc from: start to: stop in: aCollection
	^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! !

!PNGReadWriter methodsFor: 'writing' stamp: 'BG 3/16/2005 08:26'!
writeChunk: crcStream
	| bytes length crc debug |
	debug _ self debugging.
	bytes := crcStream originalContents.
	length := crcStream position.
	crc := self updateCrc: 16rFFFFFFFF from: 1 to: length in: bytes.
	crc := crc bitXor: 16rFFFFFFFF.
	debug ifTrue: [ Transcript cr;
		print: stream position; space;
		nextPutAll: (bytes copyFrom: 1 to: 4) asString;
		nextPutAll: ' len='; print: length;
		nextPutAll: ' crc=0x'; nextPutAll: crc printStringHex  ].
	stream nextNumber: 4 put: length-4. "exclude chunk name"
	stream next: length putAll: bytes startingAt: 1.
	stream nextNumber: 4 put: crc.
	debug ifTrue: [ Transcript nextPutAll: ' afterPos='; print: stream position ].
	crcStream resetToStart.! !

!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 16:40'!
writeFileSignature
	stream nextPutAll: #(16r89 16r50 16r4E  16r47 16r0D 16r0A 16r1A 16r0A) asByteArray! !

!PNGReadWriter methodsFor: 'writing' stamp: 'nk 2/17/2004 14:57'!
writeIDATChunkOn: aStream
	"Write the IDAT chunk"
	| z |
	aStream nextPutAll: 'IDAT' asByteArray.
	z _ ZLibWriteStream on: aStream.
	form depth <= 8 
		ifTrue:[self writeType3DataOn: z]
		ifFalse:[ self writeType6DataOn: z].
	self debugging ifTrue: [
		Transcript cr;
			nextPutAll: 'compressed size=';
			print: aStream position;
			nextPutAll: ' uncompressed size=';
			print: z position  ]
! !

!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:08'!
writeIENDChunkOn: aStream
	"Write the IEND chunk"
	aStream nextPutAll: 'IEND' asByteArray.! !

!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:21'!
writeIHDRChunkOn: aStream
	"Write the IHDR chunk"
	aStream nextPutAll: 'IHDR' asByteArray.
	aStream nextInt32Put: width.
	aStream nextInt32Put: height.
	aStream nextNumber: 1 put: bitsPerChannel.
	aStream nextNumber: 1 put: colorType.
	aStream nextNumber: 1 put: 0. "compression"
	aStream nextNumber: 1 put: 0. "filter method"
	aStream nextNumber: 1 put: 0. "interlace method"
! !

!PNGReadWriter methodsFor: 'writing' stamp: 'nk 4/17/2004 19:44'!
writePLTEChunkOn: aStream
	"Write the PLTE chunk"
	| r g b colors |
	aStream nextPutAll: 'PLTE' asByteArray.
	(form isColorForm) 
		ifTrue:[colors := form colors]
		ifFalse:[colors := Color indexedColors copyFrom: 1 to: (1 bitShift: form depth)].
	colors do:[:aColor|
		r := (aColor red * 255) truncated.
		g := (aColor green * 255) truncated.
		b := (aColor blue * 255) truncated.
		aStream nextPut: r; nextPut: g; nextPut: b.
	].! !

!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 18:29'!
writeSBITChunkOn: aStream
	"Write the IDAT chunk"
	aStream nextPutAll: 'sBIT' asByteArray.
	form depth = 16 ifFalse:[self error: 'Unimplemented feature'].
	aStream nextPut: 5.
	aStream nextPut: 5.
	aStream nextPut: 5.
	aStream nextPut: 1.! !

!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:34'!
writeTRNSChunkOn: aStream
	"Write out tRNS chunk"
	aStream nextPutAll: 'tRNS' asByteArray.
	form colors do:[:aColor|
		aStream nextPut: (aColor alpha * 255) truncated.
	].! !

!PNGReadWriter methodsFor: 'writing' stamp: 'ar 1/1/1970 20:58'!
writeType3DataOn: zStream
	"Write color indexed data."
	| scanline hack hackBlt swizzleBlt swizzleHack hackDepth |
	scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4.
	hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated].
	hack := Form extent: width@1 depth: hackDepth bits: scanline.
	hackBlt := BitBlt toForm: hack.
	hackBlt sourceForm: form.
	hackBlt combinationRule: Form over.
	hackBlt destOrigin: 0@0.
	hackBlt width: width; height: 1.
	(form depth < 8 and:[bigEndian not]) ifTrue:[
		swizzleHack := Form new hackBits: scanline.
		swizzleBlt := BitBlt toForm: swizzleHack.
		swizzleBlt sourceForm: swizzleHack.
		swizzleBlt combinationRule: Form over.
		swizzleBlt colorMap: (StandardSwizzleMaps at: form depth).
	].
	0 to: height-1 do:[:i|
		hackBlt sourceOrigin: 0@i; copyBits.
		swizzleBlt ifNotNil:[swizzleBlt copyBits].
		zStream nextPut: 0. "filterType"
		zStream next: bytesPerScanline putAll: scanline startingAt: 1.
	].
	zStream close.! !

!PNGReadWriter methodsFor: 'writing' stamp: 'ar 2/19/2004 00:10'!
writeType6DataOn: zStream
	"Write RGBA data."
	| scanline hack hackBlt cm miscBlt |
	scanline := ByteArray new: bytesPerScanline.
	hack := Form extent: width@1 depth: 32 bits: scanline.
	form depth = 16 ifTrue:[
		"Expand 16 -> 32"
		miscBlt := BitBlt toForm: hack.
		miscBlt sourceForm: form.
		miscBlt combinationRule: Form over.
		miscBlt destOrigin: 0@0.
		miscBlt width: width; height: 1.
	].
	hackBlt := BitBlt toForm: hack.
	hackBlt sourceForm: (miscBlt ifNil:[form] ifNotNil:[hack]).
	hackBlt combinationRule: Form over.
	hackBlt destOrigin: 0@0.
	hackBlt width: width; height: 1.
	bigEndian ifTrue:[
		cm := ColorMap 
			shifts: #(8 8 8 -24) 
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000).
	] ifFalse:[
		cm := ColorMap 
			shifts: #(-16 0 16 0) 
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000).
	].
	hackBlt colorMap: cm.
	0 to: height-1 do:[:i|
		miscBlt ifNil:[
			hackBlt sourceOrigin: 0@i; copyBits.
		] ifNotNil:[
			miscBlt sourceOrigin: 0@i; copyBits.
			hack fixAlpha.
			hackBlt copyBits.
		].
		zStream nextPut: 0. "filterType"
		zStream nextPutAll: scanline.
	].
	zStream close.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PNGReadWriter class
	instanceVariableNames: ''!

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'ar 2/11/2004 00:54'!
computeSwizzleMapForDepth: depth
	"Answer a map that maps pixels in a word to their opposite location. Used for 'middle-endian' forms where the byte-order is different from the bit order (good joke, eh?)."
	| map swizzled |
	map := Bitmap new: 256.
	depth = 4 ifTrue:[
		0 to: 255 do:[:pix|
			swizzled := 0.
			swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 15) bitShift: 4).
			swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 15) bitShift: 0).
			map at: pix+1 put: swizzled.
		].
		^ColorMap colors: map
	].

	depth = 2 ifTrue:[
		0 to: 255 do:[:pix|
			swizzled := 0.
			swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 3) bitShift: 6).
			swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 3) bitShift: 4).
			swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 3) bitShift: 2).
			swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 3) bitShift: 0).
			map at: pix+1 put: swizzled.
		].
		^ColorMap colors: map
	].

	depth = 1 ifTrue:[
		0 to: 255 do:[:pix|
			swizzled := 0.
			swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 1) bitShift: 7).
			swizzled := swizzled bitOr: (((pix bitShift: -1) bitAnd: 1) bitShift: 6).
			swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 1) bitShift: 5).
			swizzled := swizzled bitOr: (((pix bitShift: -3) bitAnd: 1) bitShift: 4).
			swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 1) bitShift: 3).
			swizzled := swizzled bitOr: (((pix bitShift: -5) bitAnd: 1) bitShift: 2).
			swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 1) bitShift: 1).
			swizzled := swizzled bitOr: (((pix bitShift: -7) bitAnd: 1) bitShift: 0).
			map at: pix+1 put: swizzled.
		].
		^ColorMap colors: map
	].
	self error: 'Unrecognized depth'! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 09:22'!
createAFormFrom: data

	| error f |

	error _ ''.
	f _ [
		self formFromStream: (RWBinaryOrTextStream with: data)
	] ifError: [ :a :b |
		error _ a printString,'  ',b printString.
		(StringMorph contents: error) color: Color red; imageForm
	].
	^{f. error}! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 09:20'!
debugging: aBoolean

	Debugging _ aBoolean! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'ar 2/11/2004 00:55'!
initialize
	"
	PNGReadWriter initialize
	"

	BPP _ {	#(1 2 4 8 16).
			#(0 0 0 0 0).
			#(0 0 0 24 48).
			#(1 2 4 8 0).
			#(0 0 0 16 32).
			#(0 0 0 0 0).
			#(0 0 0 32 64).
			#(0 0 0 0 0) }.

	BlockHeight _ #(8 8 4 4 2 2 1).
	BlockWidth _ #(8 4 4 2 2 1 1).

	StandardColors := Color indexedColors collect:[:aColor|
		Color 
			r: (aColor red * 255) truncated / 255
			g: (aColor green * 255) truncated / 255
			b: (aColor blue * 255) truncated / 255.
	].

	StandardSwizzleMaps := Array new: 4.
	#(1 2 4) do:[:i| StandardSwizzleMaps at: i put: (self computeSwizzleMapForDepth: i)].! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 09:15'!
insertMorph: aMorph named: aString into: aBook

	| newPage |

	aBook ifNil: [^self].
	newPage _ aBook insertPageLabel: aString morphs: {aMorph}.
	newPage color: Color lightYellow.
	newPage extent: (
		newPage submorphs inject: 10@10 into: [ :ex :m |
			m left: 10.
			ex max: m width @ m bottom
		]
	) + (20@20).
! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 12/10/2000 10:11'!
test1
"PNGReadWriter test1"
	| data t error d0 d1 f fileInfo book result d2 |

	Debugging _ true.
	1 = 1 ifTrue: [
		book _ BookMorph new.
		book setProperty: #transitionSpec toValue: {'silence'. #none. #none}.
	].
	d0 _ FileDirectory default.
	d1 _ d0 directoryNamed: 'PngSuite Folder'.
	d2 _ d0 directoryNamed: 'BIG PNG'.
	{d0. d1. d2}.		"keep compiler quiet"
"==
citrus_none_sub.png
citrus_adm7_adap.png
citrus_adm7_aver.png
citrus_adm7_non.png
citrus_adm7_paeth.png
pngs-img-ie5mac.png
=="
	fileInfo _ {
		d2. {'citrus_adm7_adap.png'}.
		"d1. d1 fileNames."
	}.
	fileInfo pairsDo: [ :dir :fileNames |
		fileNames do: [ :each |
			Transcript cr; show: each.
			data _ (dir fileNamed: each) contentsOfEntireFile.
			error _ ''.
			MessageTally spyOn: [
				t _ [
					result _ self createAFormFrom: data.
					f_ result first.
					error _ result second.
				] timeToRun.].
			self insertMorph: f asMorph named: each into: book.
			Transcript show: each,'  ',data size printString,' = ',t printString,' ms',error; cr.
		].
	].
	book ifNotNil: [book openInWorld].
	Debugging _ false.! !


!PNGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:57'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('png')! !
TestCase subclass: #PNGReadWriterTest
	instanceVariableNames: 'fileName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'GraphicsTests-Files'!

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/11/2004 00:42'!
drawStuffOn: aForm
	"Draw stuff on aForm. Avoid any symmetry."
	| canvas |
	canvas := FormCanvas on: aForm.
	canvas frameAndFillRectangle: (1@1 corner: aForm extent - 15) fillColor: Color red borderWidth: 3 borderColor: Color green.
	canvas fillOval: (aForm boundingBox topRight - (15@-5) extent: 20@20) color: Color blue borderWidth: 1 borderColor: Color white.
	^aForm
	"(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/11/2004 00:42'!
drawTransparentStuffOn: aForm
	"Draw stuff on aForm. Avoid any symmetry."
	| canvas |
	canvas := FormCanvas on: aForm.
	canvas frameAndFillRectangle: (1@1 corner: aForm extent - 15) fillColor: (Color red alpha: 0.25) borderWidth: 3 borderColor: (Color green alpha: 0.5).
	canvas fillOval: (aForm boundingBox topRight - (15@-5) extent: 20@20) color: (Color white alpha: 0.75) borderWidth: 1 borderColor: Color blue.
	^aForm
	"(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 4/17/2004 19:45'!
encodeAndDecode: original
	"Make sure that the given form is encoded and decoded correctly"
	| stream bytes decoded maxErr |
	"encode"
	stream := ByteArray new writeStream.
	(PNGReadWriter on: stream) nextPutImage: original; close.
	bytes := stream contents.

	self writeEncoded: bytes.

	"decode"
	stream := self readEncoded: bytes.
	decoded := (PNGReadWriter new on: stream) nextImage.
	decoded display.

	"compare"
	self assert: original width = decoded width.
	self assert: original height = decoded height.
	self assert: original depth = decoded depth.
	self assert: original bits = decoded bits.
	self assert: original class == decoded class.
	(original isColorForm) ifTrue:[
		original colors with: decoded colors do:[:c1 :c2|
			"we must round here due to encoding errors"
			maxErr := 1. "max. error for 8bit rgb component"
			self assert: ((c1 red * 255) truncated - (c2 red * 255) truncated) abs <= maxErr.
			self assert: ((c1 green * 255) truncated - (c2 green * 255) truncated) abs <= maxErr.
			self assert: ((c1 blue * 255) truncated - (c2 blue * 255) truncated) abs <= maxErr.
			self assert: ((c1 alpha * 255) truncated - (c2 alpha * 255) truncated) abs <= maxErr.
		].
	].! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:49'!
encodeAndDecodeAlpha: original
	fileName := 'testAlpha', original depth printString,'.png'.
	self encodeAndDecode: original.! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/18/2004 23:49'!
encodeAndDecodeColor: aColor depth: aDepth
	| aForm |
	fileName := 'testColor', aColor name, aDepth printString,'.png'.
	aForm := Form extent: 32@32 depth: aDepth.
	aForm fillColor: aColor.
	self encodeAndDecode: aForm.
! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:02'!
encodeAndDecodeDisplay: depth
	| form |
	fileName := 'testDisplay', depth printString,'.png'.
	form := Form extent: (Display extent min: 560@560) depth: depth.
	Smalltalk isMorphic 
		ifTrue:[World fullDrawOn: form getCanvas]
		ifFalse:[Display displayOn: form].
	self encodeAndDecode: form.! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:50'!
encodeAndDecodeForm: original
	fileName := 'testForm', original depth printString,'.png'.
	self encodeAndDecode: original.! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 4/17/2004 19:45'!
encodeAndDecodeReverse: original
	"Make sure that the given form is encoded and decoded correctly"
	| stream bytes decoded maxErr reversed |
	fileName := 'testReverse', original depth printString,'.png'.
	self assert: original class == Form. "won't work with ColorForm"
	"Switch pixel order"
	reversed := Form extent: original extent depth: original depth negated.
	original displayOn: reversed.
	self assert: original width = reversed width.
	self assert: original height = reversed height.
	self assert: original depth = reversed depth.
	self deny: original nativeDepth = reversed nativeDepth.
	original depth = 32
		ifTrue:[self assert: original bits = reversed bits]
		ifFalse:[self deny: original bits = reversed bits].

	"encode"
	stream := ByteArray new writeStream.
	(PNGReadWriter on: stream) nextPutImage: reversed; close.
	bytes := stream contents.
	self writeEncoded: bytes.

	"decode"
	stream := bytes readStream.
	decoded := (PNGReadWriter new on: stream) nextImage.
	decoded display.

	"compare"
	self assert: original width = decoded width.
	self assert: original height = decoded height.
	self assert: original depth = decoded depth.
	self assert: original bits = decoded bits.
	self assert: original class == decoded class.
	(original isColorForm) ifTrue:[
		original colors with: decoded colors do:[:c1 :c2|
			"we must round here due to encoding errors"
			maxErr := 1. "max. error for 8bit rgb component"
			self assert: ((c1 red * 255) truncated - (c2 red * 255) truncated) abs <= maxErr.
			self assert: ((c1 green * 255) truncated - (c2 green * 255) truncated) abs <= maxErr.
			self assert: ((c1 blue * 255) truncated - (c2 blue * 255) truncated) abs <= maxErr.
			self assert: ((c1 alpha * 255) truncated - (c2 alpha * 255) truncated) abs <= maxErr.
		].
	].! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 18:18'!
encodeAndDecodeStream: file
	| aForm |
	file reset.
	(PNGReadWriter new on: file) understandsImageFormat ifFalse:[^self error: 'don''t understand format!!' ].
	file reset.
	aForm := (PNGReadWriter new on: file) nextImage.
	aForm ifNil:[^self error: 'nil form' ].
	aForm display.
	self encodeAndDecode: aForm.
! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:36'!
encodeAndDecodeWithColors: aColorForm
	"Screw around with aColorForm colors"
	| colors nColors indexedColors max myRandom |
	fileName := 'testColors', aColorForm depth printString,'.png'.
	indexedColors := Color indexedColors.
	nColors := 1 bitShift: aColorForm depth.
	colors := WriteStream on: Array new.

	"Make first half translucent"
	max := nColors // 2.
	1 to: max do:[:i|
		colors nextPut: ((indexedColors at: i) alpha: i / max asFloat).
	].

	"Make random choices for second half"
	myRandom := Random seed: 42315.
	max to: nColors do:[:i|
		colors nextPut: (indexedColors atRandom: myRandom).
	].
! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/29/2004 03:55'!
encodeAndDecodeWithError: aStream
	self should:[self encodeAndDecodeStream: aStream] raise: Error! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:10'!
readEncoded: bytes
	"Answer a ReadStream on the file named by fileName, if possible; else a ReadStream on bytes"

	fileName ifNil:[^ bytes readStream ].
	^(FileStream oldFileOrNoneNamed: fileName) ifNil: [ 
		Transcript nextPutAll: 'can''t open ', fileName; cr.
		bytes readStream ].
! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:45'!
setUp
	fileName := nil.! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:29'!
tearDown
	World changed.! !

!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:51'!
writeEncoded: bytes
	| file |
	fileName ifNil:[^self].
	false ifTrue:[^self].
	file := FileStream forceNewFileNamed: fileName.
	[file nextPutAll: bytes] ensure:[file close].! !


!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'!
test16Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 16))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'!
test16BitDisplay
	self encodeAndDecodeDisplay: 16! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'!
test16BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 16))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'!
test1Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:43'!
test1BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'!
test1BitDisplay
	self encodeAndDecodeDisplay: 1! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'!
test1BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 1))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'!
test2Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:43'!
test2BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'!
test2BitDisplay
	self encodeAndDecodeDisplay: 2! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'!
test2BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 2))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'!
test32Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'!
test32BitDisplay
	self encodeAndDecodeDisplay: 32! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'!
test32BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'!
test4Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:44'!
test4BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'!
test4BitDisplay
	self encodeAndDecodeDisplay: 4! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'!
test4BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 4))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'!
test8Bit
	self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:44'!
test8BitColors
	self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'!
test8BitDisplay
	self encodeAndDecodeDisplay: 8! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'!
test8BitReversed
	self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 8))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:49'!
testAlphaCoding
	self encodeAndDecodeAlpha: (self drawTransparentStuffOn: (Form extent: 33@33 depth: 32))! !

!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/29/2004 03:55'!
testPngSuite
	"Requires the suite from 
		ftp://swrinde.nde.swri.edu/pub/png/images/suite/PngSuite.zip
	to be present as PngSuite.zip"
	| file zip entries |
	[file := FileStream readOnlyFileNamed: 'PngSuite.zip'] on: Error do:[:ex| ex return].
	file ifNil:[^self].
	[zip := ZipArchive new readFrom: file.
	entries := zip members select:[:mbr| mbr fileName asLowercase endsWith: '.png'].
	entries do:[:mbr| 
		(mbr fileName asLowercase first = $x)
			ifTrue: [self encodeAndDecodeWithError: mbr contentStream ]
			ifFalse: [self encodeAndDecodeStream: mbr contentStream ] ].
	] ensure:[file close].! !


!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'!
testBlack16
	self encodeAndDecodeColor: Color blue depth: 16! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'!
testBlack32
	self encodeAndDecodeColor: Color blue depth: 32! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'!
testBlack8
	self encodeAndDecodeColor: Color blue depth: 8! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'!
testBlue16
	self encodeAndDecodeColor: Color blue depth: 16! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'!
testBlue32
	self encodeAndDecodeColor: Color blue depth: 32! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'!
testBlue8
	self encodeAndDecodeColor: Color blue depth: 8! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'!
testGreen16
	self encodeAndDecodeColor: Color green depth: 16! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'!
testGreen32
	self encodeAndDecodeColor: Color green depth: 32! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'!
testGreen8
	self encodeAndDecodeColor: Color green depth: 8! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'!
testRed16
	self encodeAndDecodeColor: Color red depth: 16! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:48'!
testRed32
	self encodeAndDecodeColor: Color red depth: 32! !

!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'!
testRed8
	self encodeAndDecodeColor: Color red depth: 8! !


!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:25'!
coloredFiles16
	"Created by
		{Color red. Color green. Color blue. Color black} collect:[:fillC|
			| ff bytes |
			ff := Form extent: 32@32 depth: 16.
			ff fillColor: fillC.
			bytes := WriteStream on: ByteArray new.
			PNGReadWriter putForm: ff onStream: bytes.
			fillC ->
				(Base64MimeConverter mimeEncode: (bytes contents readStream)) contents
		].
	"
	^{Color red-> 
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADZJ
REFUeF7lziEBAAAMAjD6J8b9MRAT80uT65Af8AN+wA/4AT/gB/yAH/ADfsAP+AE/4AfmgQdc
z9xqBS2pdAAAAABJRU5ErkJggg=='.
	Color green->
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ
REFUeF7lziEBAAAMAjD6J77jMRAT80sunfIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA68HyT
3Gqf2I6NAAAAAElFTkSuQmCC'.
		Color blue->
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ
REFUeF7lziEBAAAMAjD6J77jMRAT80ty3fIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA48JxX
3GpYhihrAAAAAElFTkSuQmCC'.
	Color black->
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ
REFUeF7lziEBAAAMAjDk+xfmMRAT80ty3fIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA48LbT
HD3MKH3GAAAAAElFTkSuQmCC'
}! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:24'!
coloredFiles32
	"Created by
		{Color red. Color green. Color blue. Color black} collect:[:fillC|
			| ff bytes |
			ff := Form extent: 32@32 depth: 32.
			ff fillColor: fillC.
			bytes := WriteStream on: ByteArray new.
			PNGReadWriter putForm: ff onStream: bytes.
			fillC ->
				(Base64MimeConverter mimeEncode: (bytes contents readStream)) contents
		].
	"
	^{
		Color red -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANUlEQVR4XuXOIQEAAAwEoe9f
+hZjAoFnbfVo+QE/4Af8gB/wA37AD/gBP+AH/IAf8AN+4DlwVA34ajP6EEoAAAAASUVORK5C
YII='.
		Color green -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAAM0lEQVR4XuXOMQ0AAAACIPuX
1hgejAIkPfMDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA7MFfR+Grvv2BdAAAAAElFTkSuQmCC'.

	Color blue->
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANElEQVR4XuXOIQEAAAACIP+f
1hkGAp0k7Zcf8AN+wA/4AT/gB/yAH/ADfsAP+AE/4AfOgQFblfhqnnPWHAAAAABJRU5ErkJg
gg=='.
		Color black -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANUlEQVR4XuXOMQEAAAwCINc/
tIvhwcFPkuuWH/ADfsAP+AE/4Af8gB/wA37AD/gBP+AHxoEH95UAPU59TTMAAAAASUVORK5C
YII='
}! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:19'!
coloredFiles8
	"Created by
		{Color red. Color green. Color blue. Color black} collect:[:fillC|
			| ff bytes |
			ff := Form extent: 32@32 depth: 8.
			ff fillColor: fillC.
			bytes := WriteStream on: ByteArray new.
			PNGReadWriter putForm: ff onStream: bytes.
			fillC ->
				(Base64MimeConverter mimeEncode: (bytes contents readStream)) contents
		].
	"
	^{Color red->
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3//
AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH
R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA
AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA
AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y
AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy
AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l
AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl
AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y
AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY
AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L
AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL
AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L////
AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/
AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E
CiHUAAAAGklEQVR4XmO4cwc/YLgz8hWMfAUjX8EIVQAAbnlwLukXXkcAAAAASUVORK5CYII='.

	Color green->
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3//
AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH
R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA
AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA
AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y
AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy
AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l
AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl
AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y
AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY
AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L
AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL
AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L////
AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/
AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E
CiHUAAAAGUlEQVR4XmPQ1cUPGHRHvoKRr2DkKxihCgBZ3bQBCq5u/AAAAABJRU5ErkJggg=='.

	Color blue->
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3//
AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH
R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA
AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA
AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y
AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy
AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l
AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl
AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y
AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY
AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L
AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL
AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L////
AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/
AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E
CiHUAAAAGUlEQVR4XmNwc8MPGNxGvoKRr2DkKxihCgCl7xgQRbPxcwAAAABJRU5ErkJggg=='.

	Color black->
'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3//
AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH
R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA
AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA
AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y
AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy
AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l
AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl
AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y
AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY
AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L
AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL
AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L////
AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/
AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E
CiHUAAAAGUlEQVR4XmNgZMQPGBhHvoKRr2DkKxihCgBEmAQBphO0cAAAAABJRU5ErkJggg=='
}! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:25'!
decodeColors: colorsAndFiles depth: requiredDepth
	| color bytes form |
	colorsAndFiles do:[:assoc|
		color := assoc key.
		bytes := Base64MimeConverter mimeDecodeToBytes: assoc value readStream.
		form := PNGReadWriter formFromStream: bytes.
		self assert: form depth = requiredDepth.
		self assert: (form pixelValueAt: 1@1) = (color pixelValueForDepth: requiredDepth).
	].! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:30'!
encodeColors: colorsAndFiles depth: requiredDepth
	| color original ff encoded |
	colorsAndFiles do:[:assoc|
		color := assoc key.
		original := Base64MimeConverter mimeDecodeToBytes: assoc value readStream.
		ff := Form extent: 32@32 depth: requiredDepth.
		ff fillColor: color.
		encoded := WriteStream on: ByteArray new.
		PNGReadWriter putForm: ff onStream: encoded.
		self assert: (encoded contents = original contents).
	].! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'!
testPngDecodingColors16
	self decodeColors: self coloredFiles16 depth: 16.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'!
testPngDecodingColors32
	self decodeColors: self coloredFiles32 depth: 32.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'!
testPngDecodingColors8
	self decodeColors: self coloredFiles8 depth: 8.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'!
testPngEncodingColors16
	self encodeColors: self coloredFiles16 depth: 16.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'!
testPngEncodingColors32
	self encodeColors: self coloredFiles32 depth: 32.! !

!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'!
testPngEncodingColors8
	self encodeColors: self coloredFiles8 depth: 8.! !
ImageReadWriter subclass: #PNMReadWriter
	instanceVariableNames: 'first type origin cols rows depth maxValue tupleType pragma'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!
!PNMReadWriter commentStamp: 'jdr 10/20/2003 17:08' prior: 0!
I am a subclass of ImageReadWriter that decodes portable anymap file formats
(pbm, pgm, ppm and  pam) images.

I accept the #origin pragma for SE files as described in:
Algoritms For Image Processing And Computer Vision. J. R. Parker

Don't work with 2 bytes samples (16 bit grays, > 32 bits color, etc...), 
pam files preliminary support.

f _ ImageReadWriter formFromFileNamed: 'Tools:Squeak3.4:Carmen.ppm'.
f morphEdit

Submitted by Javier Diaz Reinoso, Oct/2003!
]style[(361 18 2 26 3 11 1 43)f1,cblack;f1,f1b,f1,f1b,f1,f1b,f1!


!PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/16/2003 14:52'!
origin
	^origin! !

!PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/15/2003 15:35'!
pragma: s
	pragma _ s! !

!PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/10/2003 18:04'!
stream: s
	stream _ s! !

!PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/16/2003 14:53'!
tupleType
	^tupleType! !


!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 17:19'!
cleanLine
	"upTo LF or CR, tab as space"

	| line loop b |
	line _ WriteStream with: ''.
	loop _ true.
	[loop] whileTrue: [
		b _ stream next.
		b ifNil:[
			loop _ false		"EOS"
		]
		ifNotNil: [
			(b = (Character cr) or:[b = Character lf]) ifTrue:[
				loop _ false.
			]
			ifFalse:[
				b = (Character tab) ifTrue:[b _ Character space].
				line nextPut: b.
			]
		]
	].
	^line contents! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 12:20'!
getTokenPbm: aCollection
	"get a number, return rest of collection"
	| line tokens token |
	tokens _ aCollection.
	tokens size = 0 ifTrue:[
		[
			line _ self pbmGetLine.
			line ifNil:[^{nil . nil}].
			tokens _ line findTokens: ' '.
			tokens size = 0
		] whileTrue:[].
	].
	"Transcript cr; show: tokens asString."
	token _ tokens removeFirst.
	^{token asInteger . tokens}
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 16:39'!
nextImage
	"read one image"
	| data p |
	first ifNil:[
		first _ false.
		data _ stream contentsOfEntireFile.
		stream _ (RWBinaryOrTextStream with: data) reset.
	]
	ifNotNil:[
		type < 4 ifTrue:[
			self error:'Plain PBM, PGM or PPM have only one image'
		].
	].
	stream ascii.
	p _ stream next.
	type _ (stream next) asInteger - 48.
	(p = $P and:[type > 0 and:[type < 8]]) ifFalse:[
		self error:'Not a PNM file'
	].
	type = 7 ifTrue:[
		self readHeaderPAM
	]
	ifFalse: [
		self readHeader
	].
	type caseOf: {
		[1] 	->	[^self readPlainBW].
		[2] 	->	[^self readPlainGray].
		[3] 	->	[^self readPlainRGB].
		[4] 	->	[^self readBWreverse: false].
		[5] 	->	[^self readGray].
		[6] 	->	[^self readRGB].
		[7] 	->	[	"PAM"
					(tupleType asUppercase) caseOf: {
						['BLACKANDWHITE'] 		-> [^self readBWreverse: true].
						['GRAYSCALE'] 			-> [^self readGray].
						['RGB'] 					-> [^self readRGB].
						['RGB_ALPHA'] 			-> [^self error:'Not implemented'].
						['GRAYSCALE_ALPHA'] 	-> [^self error:'Not implemented'].
					} otherwise: [^self readData].
				]
	}! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/10/2003 15:09'!
pbmGetLine
	"Get the next non-comment line from the PBM stream
	Look for 'pragmas' - commands hidden in the comments"
	
 	| line |
	[
		line _ self cleanLine.
		line ifNil: [^nil].
		(line size > 0 and:[(line at: 1) = $#]) ifTrue:[
			self pbmParam: line.
		].
		(line size = 0) or:[(line at: 1) = $#]
	]
 	whileTrue: [].
	^line! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/10/2003 15:11'!
pbmParam: line
	"Look for a parameter hidden in a comment"
	| key tokens |
	tokens _ line findTokens: ' '.
	key _ (tokens at: 1) asLowercase.
	(key = '#origin' and:[tokens size = 3]) ifTrue:[	"ORIGIN key word"
		"This is for SE files as described in:
		Algoritms For Image Processing And Computer Vision. J. R. Parker"
		origin _ ((tokens at: 2) asInteger) @ ((tokens at: 3) asInteger)
	].
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 7/18/2005 17:02'!
r: r g: g b: b for: aDepth
	"integer value according depth"
	| val |
	aDepth = 16 ifTrue: [
		val := (1 << 15) + (r << 10) + (g << 5) + b.
	]
	ifFalse:[
		val := (16rFF << 24) + (r << 16) + (g << 8) + b.
	].
	^val
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 15:49'!
readBWreverse: flagXor
	"B&W for PAM"
	| val form bytesRow nBytes |
	stream binary.
	form _ Form extent: cols@rows depth: 1.
	nBytes _ (cols/8) ceiling.
	bytesRow _ (cols/32) ceiling * 4.
	0 to: rows-1 do: [:y | | i |
		i _ 1 + (bytesRow*y).
		0 to: nBytes-1 do: [:x |
			val _ stream next.
			flagXor ifTrue:[val _ val bitXor: 16rFF].
			form bits byteAt: i put: val.
			i _ i+1.
		]
	].
	^form
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'md 10/20/2004 15:45'!
readData
	"generic data"
	| data nBits nBytes val sample |
	stream binary.
	data _ OrderedCollection new.
	nBits _ maxValue floorLog:2.
	nBytes _ (nBits+1) >> 3.
	(nBits+1 rem: 8) > 0 ifTrue:[nBytes _ nBytes+1].

	0 to: rows-1 do: [:y |
		0 to: cols-1 do: [:x |
			val _ 0.
			1 to: nBytes do: [:n |
				sample _ stream next.
				val _ val << 8 + sample.
			].
			data add: val.
		]
	].
	^data

! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 15:44'!
readGray
	"gray form"
	| val form poker |
	maxValue > 255 ifTrue:[self error:'Gray value > 8 bits not supported in Squeak'].
	stream binary.
	form _ Form extent: cols@rows depth: depth.
	poker _ BitBlt current bitPokerToForm: form.
	0 to: rows-1 do: [:y |
		0 to: cols-1 do: [:x |
			val _ stream next.
			poker pixelAt: x@y put: val.
		]
	].
	^form
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 15:44'!
readHeader
	"read header for pbm, pgm or ppm"
	| tokens aux d c  |
	tokens _ OrderedCollection new.
	aux _ self getTokenPbm: tokens.
	cols _ aux at: 1. tokens _ aux at: 2.
	aux _ self getTokenPbm: tokens.
	rows _ aux at: 1. tokens _ aux at: 2.

	(type = 1 or:[type = 4]) ifTrue:[
		maxValue _ 1
	]
	ifFalse: [
		aux _ self getTokenPbm: tokens.
		maxValue _ aux at: 1. tokens _ aux at: 2.
	].
	d _ {1 . 2 . 4 . 	8 . 		16 . 32}.
	c _ {2 . 4 . 16 . 256 . 32768 . 16777216}. 
	(type = 3 or:[type = 6]) ifTrue: [
		maxValue >= 65536 ifTrue:[
			self error:'Pixmap > 48 bits not supported in PPM'
		].
		maxValue >= 256 ifTrue:[
			self error:'Pixmap > 32 bits are not supported in Squeak'
		].
		maxValue < 32 ifTrue:[depth _ 16] ifFalse:[depth _ 32].
	]
	ifFalse: [
		depth _ nil.
		1 to: c size do:[:i| ((c at: i) > maxValue and:[depth = nil]) ifTrue:[depth_d at: i]].
	].
	Transcript cr; show: 'PBM file class ', type asString, ' size ', cols asString, ' x ', 
		rows asString, ' maxValue =', maxValue asString, ' depth=', depth asString.
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 12:35'!
readHeaderPAM
	"read pam header, not tested"
	| loop line tokens key val |
	tupleType _ ''.
	loop _ true.
	loop whileTrue:[
		line _ self pbmGetLine.
		tokens _ line findTokens: ' '.
		tokens size = 2 ifTrue:[
			key _ tokens at: 1 asUppercase.
			val _ tokens at: 2.
			key caseOf: {
				['WIDTH'] 		-> [cols _ val asInteger].
				['HEIGHT'] 		-> [rows _ val asInteger].
				['DEPTH'] 		-> [depth _ val asInteger].
				['MAXVAL']		-> [maxValue _ val asInteger].
				['TUPLETYPE']	-> [tupleType _ tupleType, ' ', val].
				['ENDHDR']		-> [loop _ false].
			}
		]
	].
	Transcript cr; show: 'PAM file class ', type asString, ' size ', cols asString, ' x ', 
		rows asString, ' maxValue =', maxValue asString, ' depth=', depth asString.
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 16:03'!
readPlainBW
	"plain BW"
	| val form poker |
	form _ Form extent: cols@rows depth: depth.
	poker _ BitBlt current bitPokerToForm: form.
	0 to: rows-1 do: [:y |
		0 to: cols-1 do: [:x |
			[val _ stream next. (val = $0 or:[val = $1])] whileFalse:[
				val ifNil:[self error:'End of file reading PBM'].
			].
			poker pixelAt: x@y put: (val asInteger).
		]
	].
	^form
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 15:44'!
readPlainGray
	"plain gray"
	| val form poker aux tokens |
	form _ Form extent: cols@rows depth: depth.
	poker _ BitBlt current bitPokerToForm: form.
	tokens _ OrderedCollection new.
	0 to: rows-1 do: [:y |
		0 to: cols-1 do: [:x |
			aux _ self getTokenPbm: tokens.
			val _ aux at: 1. tokens _ aux at: 2.
			poker pixelAt: x@y put: val.
		]
	].
	^form
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 12:49'!
readPlainRGB
	"RGB form, use 32 bits"
	| val form poker tokens aux |
	maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not supported in Squeak'].
	form _ Form extent: cols@rows depth: 32.
	poker _ BitBlt current bitPokerToForm: form.
	tokens _ OrderedCollection new.
	0 to: rows-1 do: [:y |
		0 to: cols-1 do: [:x | | r g b|
			aux _ self getTokenPbm: tokens. r _ aux at: 1. tokens _ aux at: 2.
			aux _ self getTokenPbm: tokens. g _ aux at: 1. tokens _ aux at: 2.
			aux _ self getTokenPbm: tokens. b _ aux at: 1. tokens _ aux at: 2.
			val _ self r: r g: g b: b for: depth.
			poker pixelAt: x@y put: val.
		]
	].
	^form
! !

!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 7/18/2005 16:58'!
readRGB
	"RGB form, use 16/32 bits"
	| val form poker sample shift |
	maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not supported in Squeak'].
	stream binary.
	form := Form extent: cols@rows depth: depth.
	poker := BitBlt current bitPokerToForm: form.
	depth = 32 ifTrue:[shift := 8] ifFalse:[shift := 5].
	0 to: rows-1 do: [:y |
		0 to: cols-1 do: [:x |
			val := 16rFF.	"no transparency"
			1 to: 3 do: [:i |
				sample := stream next.
				val := val << shift + sample.
			].
			poker pixelAt: x@y put: val.
		]
	].
	^form
! !


!PNMReadWriter methodsFor: 'testing' stamp: 'jdr 10/11/2003 14:52'!
understandsImageFormat
	"P1 to P7"
	| p  |
	p _ stream next asCharacter.
	type _ stream next - 48.
	^(p = $P and:[type > 0 and:[type < 8]])
	! !


!PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 16:08'!
nextPutBW: aForm reverse: flagXor
	| myType val nBytes bytesRow |
	cols _ aForm width.
	rows _ aForm height.
	depth _ aForm depth.
	"stream position: 0."
	aForm depth = 1 ifTrue:[myType _ $4] ifFalse:[myType _ $5].
	self writeHeader: myType.
	stream binary.
	nBytes _ (cols/8) ceiling.
	bytesRow _ (cols/32) ceiling * 4.
	0 to: rows-1 do: [:y | | i |
		i _ 1 + (bytesRow*y).
		0 to: nBytes-1 do: [:x |
			val _ aForm bits byteAt: i.
			flagXor ifTrue:[val _ val bitXor: 16rFF].
			stream nextPut: val.
			i _ i+1.
		]
	].
! !

!PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 16:08'!
nextPutGray: aForm
	| myType peeker val |
	cols _ aForm width.
	rows _ aForm height.
	depth _ aForm depth.
	"stream position: 0."
	aForm depth = 1 ifTrue:[myType _ $4] ifFalse:[myType _ $5].
	self writeHeader: myType.
	peeker _ BitBlt current bitPeekerFromForm: aForm.
	0 to: rows-1 do: [:y |
		0 to: cols-1 do: [:x |
			val _ peeker pixelAt: x@y.
			stream nextPut: val.
		]
	].
! !

!PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 14:22'!
nextPutImage: aForm
	aForm unhibernate.
	aForm depth	 caseOf: {
		[1] 		-> [self nextPutBW: aForm reverse: false].
		[16] 	-> [self nextPutRGB: aForm].
		[32] 	-> [self nextPutRGB: aForm].
	} otherwise: [
		(aForm respondsTo: #colors) ifTrue:[
			aForm colors ifNil: [
				self nextPutGray: aForm
			]
			ifNotNil: [
				self nextPutRGB: aForm
			]
		]
		ifFalse:[
			self nextPutGray: aForm
		]
	]! !

!PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 16:08'!
nextPutRGB: aForm
	| myType peeker f shift mask |
	cols _ aForm width.
	rows _ aForm height.
	depth _ aForm depth.
	f _ aForm.
	depth < 16 ifTrue:[
		f _ aForm asFormOfDepth: 32.
		depth _ 32.
	].
	myType _ $6.
	"stream position: 0."
	self writeHeader: myType.
	depth = 32 ifTrue:[shift _ 8. mask _ 16rFF] ifFalse:[shift _ 5. mask _ 16r1F].
	peeker _ BitBlt current bitPeekerFromForm: f.
	0 to: rows-1 do: [:y |
		0 to: cols-1 do: [:x | | p r g b |
			p _ peeker pixelAt: x@y.
			b _ p bitAnd: mask. p _ p >> shift.
			g _ p bitAnd: mask. p _ p >> shift.
			r _ p bitAnd: mask.
			stream nextPut: r.
			stream nextPut: g.
			stream nextPut: b.
		]
	].
! !

!PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/15/2003 15:48'!
writeHeader: myType
	"this is ascii"
	stream nextPut: ($P asciiValue).
	stream nextPut: (myType asciiValue).
	stream nextPut: 10.		"nl"
	pragma ifNotNil:[
		stream nextPutAll: (pragma asByteArray).
	].
	stream nextPutAll: (cols printString) asByteArray.
	stream nextPut: 32.		" "
	stream nextPutAll: (rows printString) asByteArray.
	stream nextPut: 10.		"nl"
	depth > 1 ifTrue: [| d c maxV |
		d _ {1 . 2 . 4  . 8   . 16 . 32}.
		c _ {1 . 3 . 15 . 255 . 31 . 255}. 
		maxV _ nil.
		1 to: d size do:[:i| ((d at: i) = depth and:[maxV = nil]) ifTrue:[maxV _ c at: i]].
		stream nextPutAll: (maxV printString) asByteArray.
		stream nextPut: 10.		"nl"
	]
	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PNMReadWriter class
	instanceVariableNames: ''!

!PNMReadWriter class methodsFor: 'image reading/writing' stamp: 'jdr 7/18/2005 16:25'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('pbm' 'pnm' 'ppm' 'pam')! !


!PNMReadWriter class methodsFor: 'testing' stamp: 'jdr 10/11/2003 14:49'!
testFromSEFile: filename
	"read SE file, check origin
		PNMReadWriter testFromSEFile: 'Tools:Squeak3.4:eliseSE.pbm'.
	"
	| prw f |
	prw _ self new.
	prw stream: (FileStream readOnlyFileNamed: filename).
	f _ prw nextImage.
	f morphEdit.
	prw inspect! !

!PNMReadWriter class methodsFor: 'testing' stamp: 'jdr 10/16/2003 17:22'!
testFromString
	"read SE file from string
		PNMReadWriter testFromString
	"
	| prw f s |
	prw _ self new.
	s _ 
'P1
#origin 1 0
3 1
1	01'.
	prw stream: (ReadStream on: s from: 1 to: (s size)).
	f _ prw nextImage.
	f morphEdit.
	Transcript cr;show:'Origin=', prw origin asString; cr.! !

!PNMReadWriter class methodsFor: 'testing' stamp: 'jdr 7/18/2005 17:03'!
testMultiFile: filename
	"write two files from user, then read
		PNMReadWriter testMultiFile: 'Tools:Squeak3.6:outMulti.pbm'.
	"
	| prw f |
	prw := self new.
	prw stream: ((FileStream newFileNamed: filename) binary).
	prw pragma: '#Squeak test', String lf.
	f := Form fromUser. prw nextPutImage: f. 
	f := Form fromUser.prw nextPutImage: f.	
	prw close.
	prw stream: (StandardFileStream readOnlyFileNamed: filename).
	f := prw nextImage. (SketchMorph withForm: f) openInWorld.
	f := prw nextImage. (SketchMorph withForm: f) openInWorld.
! !

!PNMReadWriter class methodsFor: 'testing' stamp: 'jdr 10/15/2003 15:43'!
testToSEFile: filename
	"write SE file with origin
		PNMReadWriter testToSEFile: 'Tools:Squeak3.4:outSE.pbm'.
	"
	| prw f |
	prw _ self new.
	prw stream: ((FileStream newFileNamed: filename) binary).
	prw pragma: '#origin 10 10', String lf.
	f _ Form fromUser.
	prw nextPutImage: f! !
ProtocolClient subclass: #POP3Client
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!POP3Client commentStamp: 'mir 5/12/2003 17:57' prior: 0!
This class implements POP3 (Post Office Protocol 3) as specified in RFC 1939.  (see http://www.ietf.org/rfc.html)

You can use it to download email from the mail server to your personal mail program.

To see an example of it's use, see POPSocket class>>example.!


!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:58'!
apopLoginUser: userName password: password

	self loginUser: userName password: password loginMethod: #APOP! !

!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:35'!
deleteMessage: num
	"delete the numbered message"

	self ensureConnection.
	self sendCommand: 'DELE ', num printString.
	self checkResponse.
	self logProgress: self lastResponse! !

!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:57'!
loginUser: userName password: password

	self loginUser: userName password: password loginMethod: #clearText! !

!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/8/2002 11:40'!
loginUser: userName password: password loginMethod: aLoginMethod

	self user: userName.
	self password: password.
	self loginMethod: aLoginMethod.
	self login! !

!POP3Client methodsFor: 'public protocol' stamp: 'mir 4/7/2003 17:17'!
messageCount
	"Query the server and answer the number of messages that are in the user's mailbox."

	| answerString numMessages |
	self ensureConnection.
	self sendCommand: 'STAT'.
	self checkResponse.
	self logProgress: self lastResponse.

	[answerString _ (self lastResponse findTokens: Character separators) second.
	numMessages _ answerString asNumber asInteger]
		on: Error
		do: [:ex | (ProtocolClientError protocolInstance: self) signal: 'Invalid STAT response.'].
	^numMessages! !

!POP3Client methodsFor: 'public protocol' stamp: 'len 12/14/2002 17:50'!
quit
	"QUIT <CRLF>"

	self sendCommand: 'QUIT'.
	self checkResponse.! !

!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:35'!
retrieveMessage: number
	"retrieve the numbered message"

	self ensureConnection.
	self sendCommand: 'RETR ', number printString.
	self checkResponse.
	self logProgress: self lastResponse.

	^self getMultilineResponse! !


!POP3Client methodsFor: 'private' stamp: 'mir 11/11/2002 16:20'!
loginMethod
	^self connectionInfo at: #loginMethod ifAbsent: [nil]! !

!POP3Client methodsFor: 'private' stamp: 'mir 3/8/2002 11:41'!
loginMethod: aSymbol
	^self connectionInfo at: #loginMethod put: aSymbol! !


!POP3Client methodsFor: 'private protocol' stamp: 'BG 3/16/2005 08:27'!
apopLogin

	"Attempt to authenticate ourselves to the server without sending the password as cleartext."

	"For secure authentication, we look for a timestamp in the initial response string we get from the server, and then try the APOP command as specified in RFC 1939.  If the initial response from the server is
	+OK POP3 server ready <1896.697170952@dbc.mtview.ca.us>
we extract the timestamp
	<1896.697170952@dbc.mtview.ca.us>
then form a string of the form
	<1896.697170952@dbc.mtview.ca.us>USERPASSWORD
and then send only the MD5 hash of that to the server.  Thus the password never hits the wire"

	| timestamp hash |

	[
	"Look for a timestamp in the response we received from the server"
	timestamp _ self lastResponse findTokens: '<>' includes: '@'.
	timestamp
		ifNil: [(POP3LoginError protocolInstance: self) signal: 'APOP not supported.'].

	(Smalltalk includesKey: #MD5)
		ifTrue: [
			hash _ ((Smalltalk at: #MD5) hashMessage: ('<', timestamp, '>', self password)) storeStringHex asLowercase.
			"trim starting 16r and zero pad it to 32 characters if needed"
			hash _ hash  padded: #left to: 32 with: $0]
		ifFalse: [(POP3LoginError protocolInstance: self) signal: 'APOP (MD5) not supported.'].

	self sendCommand: 'APOP ', self user, ' ', hash.
	self checkResponse.
	self logProgress: self lastResponse]
		on: ProtocolClientError
		do: [:ex |
			self close.
			(LoginFailedException protocolInstance: self) signal: 'Login failed.']! !

!POP3Client methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:38'!
clearTextLogin

	[self sendCommand: 'USER ', self user.
	self checkResponse.
	self logProgress: self lastResponse.

	self sendCommand: 'PASS ', self password.
	self checkResponse.
	self logProgress: self lastResponse]
		on: TelnetProtocolError
		do: [:ex |
			"Neither authentication worked.  Indicate an error and close up"
			self close.
			ex resignalAs: ((LoginFailedException protocolInstance: self) signal: 'Login failed.')]! !

!POP3Client methodsFor: 'private protocol' stamp: 'mir 11/14/2002 17:40'!
getMultilineResponse
	"Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character."

	| response done chunk |
	response _ WriteStream on: ''.
	done _ false.
	[done] whileFalse: [
		chunk _ self stream nextLine.
		(chunk beginsWith: '.')
			ifTrue: [response nextPutAll: (chunk copyFrom: 2 to: chunk size); cr ]
			ifFalse: [response nextPutAll: chunk; cr ].
		done _ (chunk = '.') ].

	^ response contents
! !

!POP3Client methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:39'!
login
	self loginMethod
		ifNil: [^self].
	self loginMethod == #clearText
		ifTrue: [^self clearTextLogin].
	self loginMethod == #APOP
		ifTrue: [^self apopLogin].
	(POP3LoginError protocolInstance: self) signal: 'Unsupported login procedure.'! !


!POP3Client methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:43'!
responseIsError
	^self lastResponse beginsWith: '-'! !

!POP3Client methodsFor: 'private testing' stamp: 'mir 11/11/2002 15:44'!
responseIsWarning
	^self lastResponse beginsWith: '-'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

POP3Client class
	instanceVariableNames: ''!

!POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:51'!
defaultPortNumber
	^110! !

!POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:52'!
logFlag
	^#pop! !


!POP3Client class methodsFor: 'example' stamp: 'rbb 3/1/2005 11:05'!
example
	"POP3Client example"
	"download a user's messages into an OrderedCollection and inspect the OrderedCollection"

	| ps messages userName password |
	userName := (UIManager default request: 'POP username').
	password := (UIManager default request: 'POP password').
	ps := POP3Client openOnHostNamed: (UIManager default request: 'POP server').
	[
	ps loginUser: userName password: password.
	ps logProgressToTranscript.

	messages := OrderedCollection new.
	1 to: ps messageCount do: [ :messageNr |
		messages add: (ps retrieveMessage: messageNr) ]]
		ensure: [ps close].

	messages inspect.! !
ProtocolClientError subclass: #POP3LoginError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!POP3LoginError commentStamp: 'mir 5/12/2003 17:58' prior: 0!
Exception for signaling POP3 login failures.!

Object subclass: #PRServerDirectory
	instanceVariableNames: 'server directories'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RemoteDirectory'!
!PRServerDirectory commentStamp: 'md 1/26/2004 12:40' prior: 0!
Add support to publish or download projects from Small-Land Project
Repository (SLPR).

The SLPR has virtual folders where the projects appears.  The SLPR can
be acceded from the FileList or from the web interface at
http://repository.small-land.org:8080

Basically it's a type of superswiki (but better ;)).

The features in SMPR not present in SuperSwiki are:

- Both the web interface and the squeak-side interface are full
translatable.   The server has translations for English and Spanish just
now, but it's almost trivial to include other translations... Stef?
Marcus? ;)

- The projects are categorized in "virtual" folder.  These folders (By
Category, By Author, By Language, Alphabetical, etc) give us good
searching behaviour just using the FileList and mouse clicks.

- The web interface (also full translatable) has a search a la google.

- All the urls to query the web interface are "clean enough" so google
can make a good job indexing our content in .pr files.


It's planned to add "editing" features to the web interface to
re-categorize, remove, etc projects.


Enjoy it,

-- 
Diego Gomez Deck
http://www.small-land.org!


!PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 07:35'!
directories
	"answer the receiver's directories"
	^ directories! !

!PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 20:44'!
directory
	"answer the receiver's directory"
	| result |
	result := String new writeStream.
	self directories
		do: [:each | result nextPutAll: each]
		separatedBy: [result nextPutAll: self slash].
	^ result contents! !

!PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 21:01'!
directoryWrapperClass
	"answer the class to be used as a wrapper in FileList2"
	^ FileDirectoryWrapper! !

!PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 20:44'!
downloadUrl
	"The url under which files will be accessible."
	^ (self urlFromServer: self server directories: {'programmatic'})
		, self slash! !

!PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/27/2003 11:06'!
moniker
	"a plain language name for this directory"
	^ self server! !

!PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 20:53'!
realUrl
	"a fully expanded version of the url we represent."
	^self urlFromServer: self server directories: self directories! !

!PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 07:40'!
server
	"answer the receiver's server"
	^ server! !


!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:25'!
createDirectory: localName 
	"Create a new sub directory within the current one"
	^ self inform: 'operation not supported' translated! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:24'!
deleteFileNamed: localFileName 
	"Delete the file with the given name in this directory."
	^ self inform: 'operation not supported' translated! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:45'!
directoryNamed: aString 
	"Return the subdirectory of this directory with the given name."
	^ self class server: self server directory: self directory , self slash, aString! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 21:30'!
directoryNames
	"Return a collection of names for the subdirectories of this 
	directory. "
	^ self entries
		select: [:entry | entry isDirectory]
		thenCollect: [:entry | entry name]! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:40'!
entries
	"Return a collection of directory entries for the files and 
	directories in this directory."
	| lines |
	lines := self getLines.
	^ lines isNil
		ifTrue: [#()] ifFalse:[
	
	self parseLines: lines]! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 21:30'!
fileNames
	"Return a collection of names for the files (but not directories) in this directory."
	^ self entries
		select: [:entry | entry isDirectory not]
		thenCollect: [:entry | entry name]! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:30'!
fullNameFor: aString 
"Return a corrected, fully-qualified name for the given file name."
	^ self urlFromServer: self server directories: self directories , {aString}! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/27/2003 12:36'!
getOnly: numberOfBytes from: fileNameOnServer 
	"Just capture the first numberOfBytes of the file.  
	 
	Goes faster for long files. Return the contents, not a stream."
	| fileName |
	self flag: #todo.
	"use LRUCache"
	fileName := fileNameOnServer
				allButFirst: (fileNameOnServer lastIndexOf: self pathNameDelimiter).
	""
	^ self getOnly: numberOfBytes ofProjectContents: fileName! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:33'!
oldFileNamed: aName "Open the existing file with the given name in this directory."
	^ self oldFileOrNoneNamed: aName! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/27/2003 11:35'!
oldFileOrNoneNamed: fullName 
	"If the file exists, answer a read-only FileStream on it. If it  
	doesn't, answer nil."
	| fileName contents |
	fileName := fullName
				allButFirst: (fullName lastIndexOf: self pathNameDelimiter).
	""
	contents := self getFullProjectContents: fileName.
	contents isNil
		ifTrue: [^ nil].
	""
	^ (SwikiPseudoFileStream with: contents) directory: self;
		 localName: fileName;
		 reset;
		 yourself! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 07:58'!
on: fullName 
	"Answer another ServerDirectory on the partial path name.  
	fullName is directory path, and does include the name of the  
	server."
	^ self class fullPath: fullName!
]style[(4 8 3 133 4 4 17 8)f3b,f3cblue;b,f3,f3c146044000,f3,f3cmagenta;,f3,f3cblue;i! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:39'!
pathName"Path name as used in reading the file. "
	^ self urlFromServer: self server directories: self directories! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 08:08'!
pathParts
	"Return the path from the root of the file system to this  
	directory as an array of directory names. On a remote server."
	^ (OrderedCollection with: self server) addAll: self directories;
		 yourself! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:34'!
readOnlyFileNamed: aName 
"Open the existing file with the given name in this directory for read-only access."
	^ self oldFileNamed: aName! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:26'!
rename: fullName toBe: newName 
	"Rename a remote file. fullName is just be a fileName, or can 
	be directory path that includes name of the server. newName 
	is just a fileName"
	^ self inform: 'operation not supported' translated! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:37'!
sleep"Leave the FileList window. Do nothing. "
	^ self! !

!PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:32'!
wakeUp"Entering a FileList window. Do nothing."
	^ self! !


!PRServerDirectory methodsFor: 'initialization' stamp: 'dgd 12/22/2003 20:46'!
initializeServer: serverString directories: directoriesCollection 
	"initialize the receiver's server and directories"
	server := serverString withBlanksTrimmed.
	server last = self pathNameDelimiter
		ifTrue: [server := server allButLast withBlanksTrimmed].
	""
	directories := directoriesCollection! !


!PRServerDirectory methodsFor: 'path access' stamp: 'dgd 12/22/2003 20:41'!
pathNameDelimiter"Return the delimiter character for this kind of directory."
	^ $/! !

!PRServerDirectory methodsFor: 'path access' stamp: 'dgd 12/22/2003 20:44'!
slash
"answer the recevier 'slash'"
	^ self pathNameDelimiter asString! !


!PRServerDirectory methodsFor: 'squeaklets' stamp: 'dgd 3/8/2006 17:38'!
writeProject: aProject inFileNamed: fileNameString fromDirectory: localDirectory 
	"write aProject (a file version can be found in the file named  
	fileNameString in localDirectory)"
	| url arguments answer string |
	url := self urlFromServer: self server directories: {'programmatic'. 'uploadproject'}.
	arguments := self
				getPostArgsFromProject: aProject
				fileNamed: fileNameString
				fromDirectory: localDirectory.
	""
	Cursor read
		showWhile: [""
			answer := HTTPClient httpPostDocument: url args: arguments.
			"answer := HTTPSocket httpGetDocument: url args: arguments."
			string := answer contents.
			(string beginsWith: '--OK--')
				ifTrue: [^ true]].
	""
	self
		inform: ('Server responded: {1}' translated format: {string}).
	^ false! !


!PRServerDirectory methodsFor: 'testing' stamp: 'dgd 12/22/2003 20:39'!
acceptsUploads
	"answer whatever the receiver accepts uploads"
	^ true! !

!PRServerDirectory methodsFor: 'testing' stamp: 'dgd 12/22/2003 00:42'!
isProjectSwiki
	"answer whatever the receiver is a project swiki"
	^ true! !

!PRServerDirectory methodsFor: 'testing' stamp: 'dgd 12/27/2003 11:04'!
isRemoteDirectory
	"answer whatever the receiver is a remote directory"
	^ true! !

!PRServerDirectory methodsFor: 'testing' stamp: 'dgd 12/21/2003 23:31'!
isSearchable
	"answer whatever the receiver is searchable"
	^ true! !

!PRServerDirectory methodsFor: 'testing' stamp: 'dgd 8/17/2004 22:14'!
queryProjectsAndShow: thingsToSearchForCollection 
	"query the server for all the projects that match  
	thingsToSearchForCollection"
	| url arguments answer string |
	url := self urlFromServer: self server directories: {'programmatic'. 'queryprojects'}.
	arguments := self getPostArgsFromThingsToSearchFor: thingsToSearchForCollection.
	""
	Cursor read
		showWhile: [""
			"answer := HTTPClient httpPostDocument: url args:  
			args."
			answer := HTTPSocket httpGetDocument: url args: arguments.
			string := answer contents.
			(string beginsWith: '--OK--')
				ifTrue: [^ true]].
	""
	self
		inform: ('Server responded: {1}' translated format: {string}).
	^ false! !


!PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/27/2003 11:34'!
getFullProjectContents: aString 
	"private - get the project content from the server"
	^ self getOnly: nil ofProjectContents: aString! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 8/17/2004 22:23'!
getLines
	"private - answer a collection of lines with the server response"
	| url answer string lines |
	url := self urlFromServer: self server directories: {'programmatic'} , self directories.
	url := url , self slash.
	""
	Cursor read
		showWhile: [""
			answer := HTTPClient httpGetDocument: url.
			string := answer contents.
			(string beginsWith: '--OK--')
				ifFalse: [^ nil]].
	""
	lines := OrderedCollection new.
	(string allButFirst: 6)
		linesDo: [:line | lines add: line squeakToIso].
	""
	^ lines! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/27/2003 12:37'!
getOnly: numberOfBytes ofProjectContents: aString 
	"private - get numberOfBytes of the project contents"
	| url answer contents args |
	self flag: #todo.
	"use an LRUCache"
	url := self urlFromServer: self server directories: {'programmatic'. aString}.
	""
	args := numberOfBytes isNil
				ifFalse: ['numberOfBytes=' , numberOfBytes asString].
	""
	Cursor read
		showWhile: [""
			answer := HTTPSocket httpGetDocument: url args: args.
			contents := answer contents].""
	(contents beginsWith: '--OK--')
		ifFalse: [^ nil].
	""
	^ contents allButFirst: 6! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 4/3/2006 13:27'!
getPostArgsFromProject: aProject fileNamed: fileNameString fromDirectory: localDirectory 
	| args thumbnail uploader |
	args := Dictionary new.

	"args at: 'contents' put: {(localDirectory oldFileNamed: fileNameString) contentsOfEntireFile}."
	args at: 'contents' put: {(StandardFileStream
			readOnlyFileNamed: (localDirectory fullNameFor: fileNameString)) contentsOfEntireFile}.

	args at: 'name' put: {aProject name isoToSqueak}.
	args at: 'version' put: {(Project parseProjectFileName: fileNameString) second asString}.
	args at: 'language' put: {aProject naturalLanguage asString}.

	uploader := Utilities authorNamePerSe.
	uploader isEmptyOrNil
		ifTrue: [uploader := Utilities authorInitialsPerSe].
	uploader isEmptyOrNil
		ifFalse: [args at: 'uploader' put: {uploader}].

	self putSmalltalkInfoInto: args.

	thumbnail := self getProjectThumbnail: aProject.
	thumbnail isNil
		ifFalse: [args at: 'thumbnailcontents' put: {thumbnail}].

	self putProjectDetailsFrom: aProject to: args.

	^ args! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 8/17/2004 22:14'!
getPostArgsFromThingsToSearchFor: thingsToSearchForCollection 
	| args |
	args := Dictionary new.
	""
	thingsToSearchForCollection
		do: [:each | 
			| pos | 
			pos := each indexOf: $:.
			pos isZero
				ifFalse: [| key value | 
					key := (each first: pos - 1) withBlanksTrimmed.
					value := (each allButFirst: pos) withBlanksTrimmed.
					(value beginsWith: '*')
						ifTrue: [value := value allButFirst].
					(value endsWith: '*')
						ifTrue: [value := value allButLast].
					""
					args at: key put: {value}]].
	""
	^ args! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/24/2003 11:33'!
getProjectThumbnail: aProject 
	"private - answer a stream with the aProject's thumbnail or nil if none"
	| form stream |
	form := aProject thumbnail.
	form isNil
		ifTrue: [^ nil].
	""
	form unhibernate.
	form := form colorReduced.
	""
	self flag: #todo.
	"use a better image format than GIF"
	stream := RWBinaryOrTextStream on: String new.
	GIFReadWriter putForm: form onStream: stream.
	stream reset.
	""
	^ stream contents asString! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/22/2003 20:34'!
parseLine: aString 
"private - parse a line from a server response"
	| tokens |
	tokens := aString findTokens: '|'.
	""
	^ tokens first = 'D'
		ifTrue: [""
			DirectoryEntry
				name: tokens second
				creationTime: 0
				modificationTime: 0
				isDirectory: true
				fileSize: 0]
		ifFalse: [""
			DirectoryEntry
				name: tokens second
				creationTime: tokens third asInteger
				modificationTime: tokens fourth asInteger
				isDirectory: false
				fileSize: tokens fifth asInteger]! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/22/2003 20:38'!
parseLines: aCollection 
"private - parse aCollection of lines from a server response"
	^ aCollection
		collect: [:each | self parseLine: each]! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 9/7/2004 12:16'!
putProjectDetailsFrom: aProject to: args 
	| projectDetails |
	projectDetails := aProject world
				valueOfProperty: #ProjectDetails
				ifAbsent: [^ self].
	""
	self flag: #todo.
	"projectname ?"
	projectDetails
		at: 'projectdescription'
		ifPresent: [:value | args at: 'description' put: {value isoToSqueak}].
	projectDetails
		at: 'projectauthor'
		ifPresent: [:value | args at: 'author' put: {value isoToSqueak}].
	projectDetails
		at: 'projectcategory'
		ifPresent: [:value | args at: 'category' put: {value isoToSqueak}].
	projectDetails
		at: 'projectsubcategory'
		ifPresent: [:value | args at: 'subcategory' put: {value isoToSqueak}].
	projectDetails
		at: 'projectkeywords'
		ifPresent: [:value | args at: 'keywords' put: {value isoToSqueak}]! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 9/7/2004 12:13'!
putSmalltalkInfoInto: args 
	"private - fills args with information from Smalltalk"
	self flag: #todo.
	" 
	lastest small-land changeset / small-land version  
	"
	#(#datedVersion #osVersion #platformName #platformSubtype #vmPath #vmVersion #imageName #changesName #sourcesName #listBuiltinModules #listLoadedModules #getVMParameters )
		do: [:each | 
			| value | 
			value := SmalltalkImage current perform: each.
			args at: 'extra-' , each asString put: {value asString isoToSqueak}]! !

!PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/22/2003 20:47'!
urlFromServer: serverString directories: aCollection 
	"private - builds an url for server/directories"
	| result |
	result := String new writeStream.
	""
	{serverString} , aCollection
		do: [:each | ""
			result
				nextPutAll: (each copyReplaceAll: ' ' with: '+')]
		separatedBy: [result nextPutAll: self slash].
	""
	^ result contents! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PRServerDirectory class
	instanceVariableNames: ''!

!PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 20:43'!
fullPath: fullNameString
	"answer an instance of the receiver on fullName"
	| pathParts |
	pathParts := self pathParts: fullNameString.
	^ self server: pathParts first directories: pathParts allButFirst! !

!PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 20:43'!
pathParts: fullName 
	"private - parse fullName in server and directory"
	| url slashPos server directory |
	url := fullName.
	(url beginsWith: 'http://')
		ifTrue: [url := url allButFirst: 7].
	url last = $/
		ifTrue: [url := url allButLast].
	""
	slashPos := url indexOf: $/.
	slashPos isZero
		ifTrue: [^ {'http://' , url}].
	""
	server := url first: slashPos - 1.
	directory := url allButFirst: slashPos.
	""
	^ {'http://' , server. directory}! !

!PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 07:57'!
server: serverString 
	"answer a new instance of the receiver on server aString"
	^ self server: serverString directories: #()! !

!PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 07:56'!
server: serverString directories: aCollection 
	"answer a new instance of the receiver on server aString"
	^ self new initializeServer: serverString directories: aCollection! !

!PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 07:58'!
server: serverString directory: directoryString 
	"answer a new instance of the receiver on server aString"
	^ self new
		initializeServer: serverString
		directories: (directoryString findTokens: '/')!
]style[(8 12 12 15 3 57 4 4 25 12 17 15 13 3 1)f3b,f3cblue;b,f3b,f3cblue;b,f3,f3c146044000,f3,f3cmagenta;,f3,f3cblue;i,f3,f3cblue;i,f3,f3c255146000b,f3! !
Object subclass: #PackageInfo
	instanceVariableNames: 'packageName methodCategoryPrefix'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PackageInfo-Base'!
!PackageInfo commentStamp: '<historical>' prior: 0!
Subclass this class to create new Packages.!


!PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 14:20'!
hash
	^ packageName hash! !

!PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 00:09'!
= other
	^ other species = self species and: [other packageName = self packageName]! !


!PackageInfo methodsFor: 'dependencies' stamp: 'ab 11/18/2002 01:16'!
externalCallers
	^ self 
		externalRefsSelect: [:literal | literal isKindOf: Symbol] 
		thenCollect: [:l | l].! !

!PackageInfo methodsFor: 'dependencies' stamp: 'stephaneducasse 2/4/2006 20:40'!
externalClasses
	| myClasses |
	myClasses := self classesAndMetaClasses.
	^ Array streamContents:
		[:s |
		ProtoObject withAllSubclassesDo:
			[:class |
			(myClasses includes: class) ifFalse: [s nextPut: class]]]! !

!PackageInfo methodsFor: 'dependencies' stamp: 'stephaneducasse 2/4/2006 20:40'!
externalRefsSelect: selBlock thenCollect: colBlock
	| pkgMethods dependents refs extMethods otherClasses otherMethods classNames |

	classNames := self classes collect: [:c | c name].
	extMethods := self extensionMethods collect: [:mr | mr methodSymbol].
	otherClasses := self externalClasses difference: self externalSubclasses.
	otherMethods :=  otherClasses gather: [:c | c selectors].
	pkgMethods := self methods asSet collect: [:mr | mr methodSymbol].
	pkgMethods removeAllFoundIn: otherMethods.

	dependents := Set new.
	otherClasses do: [:c |
		c selectorsAndMethodsDo:
			[:sel :compiled |
			(extMethods includes: sel) ifFalse: 
				[refs := compiled literals select: selBlock thenCollect: colBlock.
				refs do: [:ea |
					((classNames includes: ea) or: [pkgMethods includes: ea])
							ifTrue: [dependents add: (self referenceForMethod: sel ofClass: c) -> ea]]]]].
	^ dependents! !

!PackageInfo methodsFor: 'dependencies' stamp: 'stephaneducasse 2/4/2006 20:40'!
externalSubclasses
	| pkgClasses subClasses |
	pkgClasses := self classes.
	subClasses := Set new.
	pkgClasses do: [:c | subClasses addAll: (c allSubclasses)].
	^ subClasses difference: pkgClasses
! !

!PackageInfo methodsFor: 'dependencies' stamp: 'ab 11/18/2002 01:15'!
externalUsers
	^ self 
		externalRefsSelect: [:literal | literal isVariableBinding] 
		thenCollect: [:l | l key]! !


!PackageInfo methodsFor: 'listing' stamp: 'ac 5/14/2003 16:23'!
classes
	^(self systemCategories gather:
		[:cat |
		(SystemOrganization listAtCategoryNamed: cat)
			collect: [:className | Smalltalk at: className]])
				sortBy: [:a :b | a className <= b className]! !

!PackageInfo methodsFor: 'listing' stamp: 'al 12/14/2005 18:06'!
classesAndMetaClasses
	| baseClasses |
	baseClasses := self classes.
	^baseClasses , (baseClasses collect: [:c | c classSide])! !

!PackageInfo methodsFor: 'listing' stamp: 'ab 11/13/2002 01:23'!
coreMethods
	^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]! !

!PackageInfo methodsFor: 'listing' stamp: 'al 3/1/2006 21:51'!
extensionClasses
	^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty]! !

!PackageInfo methodsFor: 'listing' stamp: 'al 3/1/2006 21:51'!
extensionMethods
	^ self externalBehaviors gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]! !

!PackageInfo methodsFor: 'listing' stamp: 'stephaneducasse 2/4/2006 20:40'!
foreignClasses
	| s |
	s := IdentitySet new.
	self foreignSystemCategories
		do: [:c | (SystemOrganization listAtCategoryNamed: c)
				do: [:cl | 
					| cls | 
					cls := Smalltalk at: cl. 
					s add: cls;
					  add: cls class]].
	^ s! !

!PackageInfo methodsFor: 'listing' stamp: 'ab 12/3/2002 14:34'!
foreignSystemCategories
	^ SystemOrganization categories
		reject: [:cat | self includesSystemCategory: cat] ! !

!PackageInfo methodsFor: 'listing' stamp: 'al 10/9/2005 20:00'!
methods
	^ (self extensionMethods, self coreMethods) select: [:method |
		method isValid
			and: [method isLocalSelector]
			and: [method methodSymbol isDoIt not]]! !

!PackageInfo methodsFor: 'listing' stamp: 'avi 11/10/2003 15:35'!
overrideMethods
	^ self extensionMethods select: [:ea | self isOvverideMethod: ea]! !

!PackageInfo methodsFor: 'listing' stamp: 'ab 11/14/2002 18:39'!
selectors
	^ self methods collect: [:ea | ea methodSymbol]! !

!PackageInfo methodsFor: 'listing' stamp: 'ab 11/11/2002 21:51'!
systemCategories
	^ SystemOrganization categories select: [:cat | self includesSystemCategory: cat]! !


!PackageInfo methodsFor: 'modifying' stamp: 'stephaneducasse 2/4/2006 20:40'!
addCoreMethod: aMethodReference
	| category |
	category := self baseCategoryOfMethod: aMethodReference.
	aMethodReference actualClass organization
		classify: aMethodReference methodSymbol
		under: category
		suppressIfDefault: false! !

!PackageInfo methodsFor: 'modifying' stamp: 'stephaneducasse 2/4/2006 20:40'!
addExtensionMethod: aMethodReference
	| category |
	category := self baseCategoryOfMethod: aMethodReference.
	aMethodReference actualClass organization
		classify: aMethodReference methodSymbol
		under: self methodCategoryPrefix, '-', category! !

!PackageInfo methodsFor: 'modifying' stamp: 'avi 10/11/2003 15:16'!
addMethod: aMethodReference
	(self includesClass: aMethodReference class)
		ifTrue: [self addCoreMethod: aMethodReference]
		ifFalse: [self addExtensionMethod: aMethodReference]! !

!PackageInfo methodsFor: 'modifying' stamp: 'stephaneducasse 2/4/2006 20:40'!
baseCategoryOfMethod: aMethodReference
	| oldCat oldPrefix tokens | 
	oldCat := aMethodReference category.
	({ 'as yet unclassified'. 'all' } includes: oldCat) ifTrue: [ oldCat := '' ].
	tokens := oldCat findTokens: '*-' keep: '*'.

	"Strip off any old prefixes"
	((tokens at: 1 ifAbsent: [ '' ]) = '*') ifTrue: [
		[ ((tokens at: 1 ifAbsent: [ '' ]) = '*') ]
			whileTrue: [ tokens removeFirst ].
		oldPrefix := tokens removeFirst asLowercase.
		[ (tokens at: 1 ifAbsent: [ '' ]) asLowercase = oldPrefix ]
			whileTrue: [ tokens removeFirst ].
	].

	tokens isEmpty ifTrue: [^ 'as yet unclassified'].
	^ String streamContents:
		[ :s |
		tokens
			do: [ :tok | s nextPutAll: tok ]
			separatedBy: [ s nextPut: $- ]]! !

!PackageInfo methodsFor: 'modifying' stamp: 'al 3/1/2006 21:42'!
externalBehaviors
	^self externalClasses , self externalTraits! !

!PackageInfo methodsFor: 'modifying' stamp: 'al 3/1/2006 22:08'!
externalTraits
	| behaviors |
	
	^ Array streamContents: [:s |
		behaviors := self classesAndMetaClasses.
		Smalltalk allTraits do: [:trait |
			(behaviors includes: trait) ifFalse: [s nextPut: trait].
			(behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]].			! !

!PackageInfo methodsFor: 'modifying' stamp: 'avi 10/11/2003 15:14'!
removeMethod: aMethodReference! !


!PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'!
categoryName
	|category|
	category := self class category.
	^ (category endsWith: '-Info')
		ifTrue: [category copyUpToLast: $-]
		ifFalse: [category]! !

!PackageInfo methodsFor: 'naming' stamp: 'ab 10/16/2002 21:22'!
externalName
	^ self packageName! !

!PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'!
methodCategoryPrefix
	^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase]! !

!PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'!
packageName
	^ packageName ifNil: [packageName := self categoryName]! !

!PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'!
packageName: aString
	packageName := aString! !

!PackageInfo methodsFor: 'naming' stamp: 'ab 10/28/2002 10:38'!
systemCategoryPrefix
	^ self packageName! !


!PackageInfo methodsFor: 'registering' stamp: 'avi 11/12/2003 23:12'!
register
	PackageOrganizer default registerPackage: self! !


!PackageInfo methodsFor: 'testing' stamp: 'avi 3/9/2004 15:53'!
category: categoryName matches: prefix
	^ categoryName notNil and: [categoryName = prefix or: [categoryName beginsWith: prefix, '-']]! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:18'!
coreCategoriesForClass: aClass
	^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:22'!
coreMethodsForClass: aClass
	^ (aClass selectors difference:
		((self foreignExtensionMethodsForClass: aClass) collect: [:r | r methodSymbol]))
			asArray collect: [:sel | self referenceForMethod: sel ofClass: aClass]! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:20'!
extensionCategoriesForClass: aClass
	^ aClass organization categories select: [:cat | self isYourClassExtension: cat]! !

!PackageInfo methodsFor: 'testing' stamp: 'avi 4/6/2004 15:16'!
extensionMethodsForClass: aClass
	^ (self extensionCategoriesForClass: aClass)
		gather: [:cat | ((aClass organization listAtCategoryNamed: cat) ifNil: [#()])
							collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! !

!PackageInfo methodsFor: 'testing' stamp: 'dvf 10/18/2002 23:22'!
extensionMethodsFromClasses: classes
	^classes
		gather: [:class | self extensionMethodsForClass: class]! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:22'!
foreignExtensionCategoriesForClass: aClass
	^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'!
foreignExtensionMethodsForClass: aClass
	^ (self foreignExtensionCategoriesForClass: aClass)
		gather: [:cat | (aClass organization listAtCategoryNamed: cat)
						  collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! !

!PackageInfo methodsFor: 'testing' stamp: 'dvf 7/23/2003 14:08'!
includesClassNamed: aClassName
	^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false])! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'!
includesClass: aClass
	^ self includesSystemCategory: aClass theNonMetaClass category! !

!PackageInfo methodsFor: 'testing' stamp: 'dvf 7/23/2003 14:06'!
includesMethodCategory: categoryName ofClassNamed: aClass
	^ (self isYourClassExtension: categoryName)
		or: [(self includesClassNamed: aClass)
				and: [(self isForeignClassExtension: categoryName) not]]! !

!PackageInfo methodsFor: 'testing' stamp: 'dvf 9/17/2002 00:18'!
includesMethodCategory: categoryName ofClass: aClass
	^ (self isYourClassExtension: categoryName)
		or: [(self includesClass: aClass)
				and: [(self isForeignClassExtension: categoryName) not]]! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/14/2002 18:06'!
includesMethodReference: aMethodRef
	^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 12/5/2002 00:16'!
includesMethod: aSymbol ofClass: aClass
	aClass ifNil: [^ false].
	^ self
		includesMethodCategory: ((aClass organization categoryOfElement: aSymbol)
										ifNil: [' '])
		ofClass: aClass! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'!
includesSystemCategory: categoryName
	^ self category: categoryName matches: self systemCategoryPrefix! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'!
isForeignClassExtension: categoryName
	^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! !

!PackageInfo methodsFor: 'testing' stamp: 'avi 11/10/2003 15:42'!
isOverrideMethod: aMethodReference
	^ aMethodReference category endsWith: '-override'! !

!PackageInfo methodsFor: 'testing' stamp: 'avi 3/10/2004 12:37'!
isYourClassExtension: categoryName
	^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! !

!PackageInfo methodsFor: 'testing' stamp: 'dvf 10/18/2002 23:22'!
outsideClasses
	^ProtoObject withAllSubclasses difference: self classesAndMetaClasses! !

!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:25'!
referenceForMethod: aSymbol ofClass: aClass
	^ MethodReference new setStandardClass: aClass methodSymbol: aSymbol! !



"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PackageInfo class
	instanceVariableNames: ''!

!PackageInfo class methodsFor: 'class initialization' stamp: 'avi 2/18/2004 00:46'!
initialize
	self allSubclassesDo: [:ea | ea new register]! !


!PackageInfo class methodsFor: 'compatibility' stamp: 'avi 3/9/2004 16:28'!
default
	^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register]! !


!PackageInfo class methodsFor: 'packages access' stamp: 'nk 3/9/2004 10:49'!
allPackages
	^PackageOrganizer default packages! !

!PackageInfo class methodsFor: 'packages access' stamp: 'avi 11/12/2003 23:00'!
named: aString
	^ PackageOrganizer default packageNamed: aString ifAbsent: [(self new packageName: aString) register]! !

!PackageInfo class methodsFor: 'packages access' stamp: 'avi 11/11/2003 17:19'!
registerPackageName: aString
	^ PackageOrganizer default registerPackageNamed: aString! !
Object subclass: #PackageOrganizer
	instanceVariableNames: 'packages'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PackageInfo-Base'!

!PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'!
packageNames
	^ packages keys! !

!PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'!
packages
	^ packages values! !


!PackageOrganizer methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:40'!
initialize
	packages := Dictionary new! !


!PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 23:01'!
registerPackage: aPackageInfo
	packages at: aPackageInfo packageName put: aPackageInfo.
	self changed: #packages; changed: #packageNames.
! !

!PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:08'!
registerPackageNamed: aString
	^ self registerPackage: (PackageInfo named: aString)! !

!PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 23:08'!
unregisterPackage: aPackageInfo
	packages removeKey: aPackageInfo packageName ifAbsent: [].	
	self changed: #packages; changed: #packageNames.
! !

!PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:10'!
unregisterPackageNamed: aString
	self unregisterPackage: (self packageNamed: aString ifAbsent: [^ self])! !


!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'!
noPackageFound
	self error: 'No package found'! !

!PackageOrganizer methodsFor: 'searching' stamp: 'avi 11/12/2003 23:08'!
packageNamed: aString ifAbsent: errorBlock
	^ packages at: aString ifAbsent: errorBlock! !

!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'!
packageOfClass: aClass
	^ self packageOfClass: aClass ifNone: [self noPackageFound]! !

!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:22'!
packageOfClass: aClass ifNone: errorBlock
	^ self packages detect: [:ea | ea includesClass: aClass] ifNone: errorBlock! !

!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'!
packageOfMethod: aMethodReference
	^ self packageOfMethod: aMethodReference ifNone: [self noPackageFound]! !

!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:22'!
packageOfMethod: aMethodReference ifNone: errorBlock
	^ self packages detect: [:ea | ea includesMethodReference: aMethodReference] ifNone: errorBlock! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PackageOrganizer class
	instanceVariableNames: 'default'!

!PackageOrganizer class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:40'!
default
	^ default ifNil: [default := self new]! !

!PackageOrganizer class methodsFor: 'as yet unclassified' stamp: 'avi 10/13/2003 15:25'!
new
	^ self basicNew initialize! !
Browser subclass: #PackagePaneBrowser
	instanceVariableNames: 'package packageListIndex packageList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!PackagePaneBrowser commentStamp: '<historical>' prior: 0!
A package browser represents a hierarchical query path through an organization of class and method information.   It parses class categories into a two-level hierarchy on the first '-' character, giving "packages" (e.g.,  Magnitude, Collections, Graphics, etc.), and "categories" (e.g., Magnitude-General and Magnitude-Number).

Instance Variables:
	package  <Symbol> the "category header," e.g., #Magnitudes or #Collections
	packageListIndex <Integer> The index in the package list
	packageList  <OrderedCollection of String> the list of package names
!


!PackagePaneBrowser methodsFor: 'class list' stamp: 'JF 7/30/2003 12:26'!
classList
	"Answer an array of the class names of the selected category. Answer an 
	empty array if no selection exists."

	^ self hasSystemCategorySelected 
		ifFalse:
			[self packageClasses]
		ifTrue: [systemOrganizer listAtCategoryNumber:
			(systemOrganizer categories indexOf: self selectedSystemCategoryName asSymbol)]! !

!PackagePaneBrowser methodsFor: 'class list' stamp: 'JF 7/30/2003 12:36'!
packageClasses
	^ self categoryExistsForPackage
		ifFalse: [Array new]
		ifTrue:
			[systemOrganizer listAtCategoryNumber:
				(systemOrganizer categories indexOf: self package asSymbol)]! !

!PackagePaneBrowser methodsFor: 'class list' stamp: 'md 3/3/2006 11:04'!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	| name envt |
	(name := self selectedClassName) ifNil: [^ nil].
	"(envt := self selectedEnvironment) ifNil: [^ nil]."
	envt:= Smalltalk.
	^ envt at: name! !


!PackagePaneBrowser methodsFor: 'dragNDrop' stamp: 'sd 11/20/2005 21:27'!
changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag 
	"only move semantic"
	| newClassCategory success |
	self flag: #stringSymbolProblem.
	success := copyFlag not ifFalse: [^ false].
	newClassCategory := self dstCategoryDstListMorph: dstListMorph internal: internal.
	(success := newClassCategory notNil & (newClassCategory ~= class category))
		ifTrue: 
			[class category: newClassCategory.
			self changed: #classList.
			internal ifFalse: [self selectClass: class]].
	^ success! !


!PackagePaneBrowser methodsFor: 'dragNDrop util' stamp: 'sd 11/20/2005 21:27'!
dstCategoryDstListMorph: dstListMorph internal: internal 
	| dropItem |
	^ internal & (dstListMorph getListSelector == #systemCategoryList)
		ifTrue: [(dropItem := dstListMorph potentialDropItem) ifNotNil: [(self package , '-' , dropItem) asSymbol]]
		ifFalse: [self selectedSystemCategoryName]! !


!PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'sw 1/13/2000 16:45'!
defaultBrowserTitle
	^ 'Package Browser'! !

!PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
openAsMorphEditing: editString 
	"Create a pluggable version of all the views for a Browser, including 
	views and controllers."
	"PackagePaneBrowser openBrowser"

	| listHeight window |
	listHeight := 0.4.
	(window := SystemWindow labelled: 'later') model: self.
	window
		addMorph: (PluggableListMorph
				on: self
				list: #packageList
				selected: #packageListIndex
				changeSelected: #packageListIndex:
				menu: #packageMenu:
				keystroke: #packageListKey:from:)
		frame: (0 @ 0 extent: 0.15 @ listHeight).
	window
		addMorph: self buildMorphicSystemCatList
		frame: (0.15 @ 0 extent: 0.2 @ listHeight).
	self
		addClassAndSwitchesTo: window
		at: (0.35 @ 0 extent: 0.25 @ listHeight)
		plus: 0.
	window
		addMorph: self buildMorphicMessageCatList
		frame: (0.6 @ 0 extent: 0.15 @ listHeight).
	window
		addMorph: self buildMorphicMessageList
		frame: (0.75 @ 0 extent: 0.25 @ listHeight).
	self
		addLowerPanesTo: window
		at: (0 @ listHeight corner: 1 @ 1)
		with: editString.
	window setUpdatablePanesFrom: #(#packageList #systemCategoryList #classList #messageCategoryList #messageList ).
	^ window! !

!PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'stp 10/06/1998 22:02'!
systemOrganizer: aSystemOrganizer 
	"Initialize the receiver as a perspective on the system organizer, 
	aSystemOrganizer. Typically there is only one--the system variable 
	SystemOrganization."

	super systemOrganizer: aSystemOrganizer .
	packageListIndex := 0! !


!PackagePaneBrowser methodsFor: 'package list' stamp: 'JF 7/30/2003 12:35'!
categoryExistsForPackage
	^ self hasPackageSelected
		and: [(systemOrganizer categories indexOf: self package asSymbol) ~= 0]
! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'JF 7/30/2003 12:24'!
hasPackageSelected

	^ packageListIndex ~= 0! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'sd 11/20/2005 21:27'!
openEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	"PackageBrowser openBrowser"

	| packageListView systemCategoryListView classListView messageCategoryListView
	  messageListView browserCodeView topView switchView annotationPane underPane y optionalButtonsView |

	self couldOpenInMorphic ifTrue: [^ self openAsMorphEditing: aString].

	topView := StandardSystemView new model: self.
	topView borderWidth: 1.  "label and minSize taken care of by caller"

	packageListView := PluggableListView on: self
		list: #packageList
		selected: #packageListIndex
		changeSelected: #packageListIndex:
		menu: #packageMenu:.
	packageListView window: (0 @ 0 extent: 20 @ 70).
	topView addSubView: packageListView.

	systemCategoryListView := PluggableListView on: self
		list: #systemCategoryList
		selected: #systemCategoryListIndex
		changeSelected: #systemCategoryListIndex:
		menu: #systemCategoryMenu:.
	systemCategoryListView window: (20 @ 0 extent: 30 @ 70).
	topView addSubView: systemCategoryListView.

	classListView := PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: #classListMenu:shifted:.
	classListView window: (0 @ 0 extent: 50 @ 62).
	topView addSubView: classListView toRightOf: systemCategoryListView.

	switchView := self buildInstanceClassSwitchView.
	switchView borderWidth: 1.
	topView addSubView: switchView below: classListView.

	messageCategoryListView := PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageCategoryListView toRightOf: classListView.

	messageListView := PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	self wantsAnnotationPane
		ifTrue:
			[annotationPane := PluggableTextView on: self
				text: #annotation accept: nil
				readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: packageListView.
			underPane := annotationPane.
			y := 110 - self optionalAnnotationHeight]
		ifFalse:
			[underPane := packageListView.
			y := 110].

	self wantsOptionalButtons ifTrue:
		[optionalButtonsView := self buildOptionalButtonsView.
		optionalButtonsView borderWidth: 1.
		topView addSubView: optionalButtonsView below: underPane.
		underPane := optionalButtonsView.
		y := y - self optionalButtonHeight].

	browserCodeView := MvcTextEditor default on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'JF 7/30/2003 12:25'!
package
	"Answer the receiver's 'package'."

	^ self hasPackageSelected
		ifFalse: [nil]
		ifTrue: [self packageList at: packageListIndex]
! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 10/05/1998 20:36'!
packageList
	"Answer a list of the packages in the current system organization."

	| str cats stream |
	str := Set new: 100.
	stream := WriteStream on: (Array new: 100).
	systemOrganizer categories do:
		[ :categ | 
		cats := categ asString copyUpTo: $-.
		(str includes: cats) ifFalse: 
			[str add: cats.
			stream nextPut: cats]].
	^stream contents! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 10/05/1998 19:48'!
packageListIndex
	"Answer the index of the current package selection."

	^packageListIndex! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 12/01/1998 02:46'!
packageListIndex: anInteger 
	"Set anInteger to be the index of the current package selection."

	packageListIndex := anInteger.
	anInteger = 0
		ifFalse: [package := self packageList at: packageListIndex].
	messageCategoryListIndex := 0.
	systemCategoryListIndex := 0.
	messageListIndex := 0.
	classListIndex := 0.
	self setClassOrganizer.
	self changed: #packageSelectionChanged.
	self changed: #packageListIndex.	"update my selection"
	self changed: #systemCategoryList.	"update the category list"
	self systemCategoryListIndex: 0.	"update category list selection"
! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 10/06/1998 19:59'!
packageMenu: aMenu
	"Answer a Menu of operations on class packages to be 
	displayed when the operate menu button is pressed."

	^aMenu
			labels: 'find class...\recent classes...\reorganize\update' withCRs
			lines: #(2)
			selections: #(#findClass #recent #editSystemCategories #updatePackages)! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'nk 2/14/2004 15:09'!
updatePackages
	"Update the contents of the package list."

	self editSelection: #none.
	self changed: #packageList.
	self changed: #package.
	self packageListIndex: 0 ! !


!PackagePaneBrowser methodsFor: 'system category list' stamp: 'JF 7/30/2003 12:23'!
hasSystemCategorySelected
	^ systemCategoryListIndex ~= 0! !

!PackagePaneBrowser methodsFor: 'system category list' stamp: 'stp 01/13/2000 12:59'!
selectCategoryForClass: theClass
	"Set the package and category lists to display the given class."

	| cat |
	cat := theClass category.
	self packageListIndex: (self packageList indexOf: (cat copyUpTo: $-)).	
	self systemCategoryListIndex: (self systemCategoryList indexOf: 
			(cat copyFrom: ((cat indexOf: $- ifAbsent: [0]) + 1) to: cat size)).! !

!PackagePaneBrowser methodsFor: 'system category list' stamp: 'di 12/20/1999 20:16'!
selectedSystemCategoryName
	"Answer the name of the selected system category or nil."

	systemCategoryListIndex = 0
		ifTrue: [^nil].
	packageListIndex = 0
		ifTrue: [^ self systemCategoryList at: systemCategoryListIndex].
	^ self package , '-' , (self systemCategoryList at: systemCategoryListIndex)! !

!PackagePaneBrowser methodsFor: 'system category list' stamp: 'di 12/16/1999 16:14'!
systemCategoryList
	"Answer the sequenceable collection containing the class categories that 
	the receiver accesses."

	| prefix |
	packageListIndex = 0 ifTrue: [^ systemOrganizer categories].
	prefix := self package, '-'.
	^ Array streamContents:
		[:strm |
		systemOrganizer categories do: 
			[ :cat | (cat beginsWith: prefix) ifTrue:
				[strm nextPut: (cat copyFrom: prefix size + 1 to: cat size)]]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PackagePaneBrowser class
	instanceVariableNames: ''!

!PackagePaneBrowser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 20:12'!
registerInAppRegistry
	"Register the receiver in the SystemBrowser AppRegistry"
	SystemBrowser register: self.! !


!PackagePaneBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
prototypicalToolWindow
	"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"

	| aWindow |
	aWindow := self new openAsMorphEditing: nil.
	aWindow setLabel: 'Package Browser'.
	aWindow applyModelExtent.
	^ aWindow
! !


!PackagePaneBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:39'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Package Browser' brightColor: #(1.0 1.0 0.6)	 pastelColor: #(0.976 0.976 0.835) helpMessage: 'A system browser with an extra pane at top-left for module.'! !


!PackagePaneBrowser class methodsFor: '*MorphicExtras-class initialization' stamp: 'hpt 8/5/2004 20:12'!
initialize

	self registerInFlapsRegistry;
		registerInAppRegistry.! !

!PackagePaneBrowser class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/10/2003 13:15'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(PackagePaneBrowser	prototypicalToolWindow		'Packages'			'Package Browser:  like a System Browser, except that if has extra level of categorization in the top-left pane, such that class-categories are further organized into groups called "packages"') 
						forFlapNamed: 'Tools']! !

!PackagePaneBrowser class methodsFor: '*MorphicExtras-class initialization' stamp: 'hpt 8/5/2004 20:12'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self].
	SystemBrowser unregister: self.! !
Object subclass: #PackageServices
	instanceVariableNames: ''
	classVariableNames: 'ServiceClasses'
	poolDictionaries: ''
	category: 'PackageInfo-Base'!

!PackageServices methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 14:06'!
seeClassSide! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PackageServices class
	instanceVariableNames: ''!

!PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 13:01'!
allServices
	^ ServiceClasses gather: [:ea | ea services]! !

!PackageServices class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:40'!
initialize
	ServiceClasses := Set new! !

!PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 12:59'!
register: aClass
	ServiceClasses add: aClass! !

!PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 12:59'!
unregister: aClass
	ServiceClasses remove: aClass! !
ImageMorph subclass: #PaintBoxColorPicker
	instanceVariableNames: 'currentColor locOfCurrent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Support'!
!PaintBoxColorPicker commentStamp: 'JMM 9/13/2004 07:37' prior: 0!
A pop-up, 32-bit color palette used as part of a PaintBoxMorph.
!


!PaintBoxColorPicker methodsFor: 'accessing' stamp: 'jm 4/29/1998 20:07'!
currentColor

	^ currentColor
! !

!PaintBoxColorPicker methodsFor: 'accessing' stamp: 'jm 4/29/1998 20:18'!
currentColor: aColor
	"Force me to select the given color."

	currentColor _ aColor.
	locOfCurrent _ nil.  "remove the marker"
! !


!PaintBoxColorPicker methodsFor: 'drawing' stamp: 'jm 4/29/1998 20:00'!
drawOn: aCanvas
	"Image plus circles for currently selected color."

	| c |
	super drawOn: aCanvas.
	locOfCurrent ifNotNil: [
		c _ self ringColor.
		aCanvas
			fillOval: (Rectangle center: locOfCurrent + self topLeft extent: 9@9)
			color: Color transparent
			borderWidth: 1
			borderColor: c].
! !

!PaintBoxColorPicker methodsFor: 'drawing' stamp: 'jm 4/29/1998 20:00'!
ringColor
	"Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green"

	currentColor isTransparent ifTrue: [^ Color red].
	currentColor red < 0.5 ifTrue: [^ Color red].
	currentColor red > (currentColor green + (currentColor blue * 0.5))
		ifTrue: [^ Color green]
		ifFalse: [^ Color red].
! !


!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'ar 10/5/2000 16:01'!
endColorSelection: evt
	"Update current color and report it to paint box."

	self selectColor: evt.
	"restore mouseLeave handling"
	self on: #mouseLeave send: #delete to: self.
! !

!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'ar 10/25/2000 17:49'!
initMouseHandlers

	self on: #mouseDown send: #startColorSelection: to: self.
	self on: #mouseMove send: #selectColor: to: self.
	self on: #mouseUp send: #endColorSelection: to: self.
	self on: #mouseLeave send: #delete to: self.
! !

!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'JMM 9/13/2004 09:08'!
selectColor: evt 
	"Update the receiver from the given event. Constrain locOfCurrent's center to lie within the color selection area. If it is partially in the transparent area, snap it entirely into it vertically."

	| r |

	locOfCurrent := evt cursorPoint - self topLeft.
	r := Rectangle center: locOfCurrent extent: 9 @ 9.
	locOfCurrent := locOfCurrent 
				+ (r amountToTranslateWithin: (8 @ 11 corner: (self image width-6) @ (self image height-6))).
	locOfCurrent x > (self image width-(12+7))  ifTrue: [locOfCurrent := (self image width - 12) @ locOfCurrent y].	"snap into grayscale"
	currentColor := locOfCurrent y < 19
				ifTrue:  
					[locOfCurrent := locOfCurrent x @ 11.	"snap into transparent"
					Color transparent]
				ifFalse: [image colorAt: locOfCurrent].
	(owner isKindOf: PaintBoxMorph) 
		ifTrue: [owner takeColorEvt: evt from: self].
	self changed! !

!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 4/29/1998 21:21'!
startColorSelection: evt
	"Start color selection. Make me stay up as long as the mouse is down."

	self on: #mouseLeave send: nil to: nil.
	self selectColor: evt.
! !


!PaintBoxColorPicker methodsFor: 'initialization' stamp: 'RAA 8/15/2000 14:57'!
beStatic

	"an aid for Nebraska: make the color chart a static image to reduce traffic"
	image isStatic ifFalse: [
		image _ image as: StaticForm
	].! !

!PaintBoxColorPicker methodsFor: 'initialization' stamp: 'jm 4/29/1998 21:24'!
initialize

	super initialize.
	currentColor _ Color black.
	locOfCurrent _ nil.
	self initMouseHandlers.
! !
ImageMorph subclass: #PaintBoxMorph
	instanceVariableNames: 'action tool currentCursor thumbnail currentColor currentBrush colorMemory colorPatch stampHolder rotationTabForm scaleTabForm colorMemoryThin brushes focusMorph weakDependents recentColors'
	classVariableNames: 'AllOffImage AllOnImage AllPressedImage ColorChart OriginalBounds Prototype RecentColors'
	poolDictionaries: ''
	category: 'MorphicExtras-Support'!

!PaintBoxMorph methodsFor: 'actions' stamp: 'laza 3/24/2000 17:58'!
action
	^ action	! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:35'!
actionCursor
	"Return the cursor to use with this painting action/tool. Offset of the form must be set."

	^self
		cursorFor: action
		oldCursor: currentCursor
		currentNib: self getNib
		color: currentColor
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'!
brush: brushButton action: aSelector nib: aMask evt: evt 
	"Set the current tool and action for the paintBox.  "

	currentBrush 
		ifNotNil: [currentBrush == brushButton ifFalse: [currentBrush state: #off]].
	currentBrush := brushButton.	"A ThreePhaseButtonMorph"

	"currentBrush state: #on.	already done"
	"aSelector is like brush3:.  Don't save it.  Can always say (currentBrush arguments at: 2)
	aMask is the brush shape.  Don't save it.  Can always say (currentBrush arguments at: 3)"
	self notifyWeakDependentsWith: { 
				#currentNib.
				evt.
				currentBrush arguments third}.
	self brushable ifFalse: [self setAction: #paint: evt: evt]	"User now thinking of painting"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 10/19/97 11:12'!
brushable
	"Return true if the current tool uses a brush."
	^ (#("non-brushable" eyedropper: fill: pickup: stamp:) indexOf: action) = 0! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:34'!
clear: clearButton with: clearSelector evt: evt

	| ss |
	(ss _ self focusMorph) 
		ifNotNil: [ss clearPainting: self]
		ifNil: [self notCurrentlyPainting].
	clearButton state: #off.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/15/97 13:35'!
colorable
	"Return true if the current tool uses a color."
	^ (#("These use no color" erase: eyedropper: "fill: does" pickup: stamp:) indexOf: action) = 0! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/17/2000 17:06'!
currentColor: aColor evt: evt
	"Accept a color from the outside.  (my colorMemoryMorph must call takeColorEvt: evt from: colorPicker instead)"

	currentColor _ aColor.
	colorMemory currentColor: aColor.
	self notifyWeakDependentsWith: {#currentColor. evt. currentColor}.
	self showColor.
	self colorable ifFalse: [self setAction: #paint: evt: evt].	"User now thinking of painting"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:37'!
cursorFor: anAction oldCursor: oldCursor currentNib: aNibForm color: aColor 
	"Return the cursor to use with this painting action/tool. Offset of the 
	form must be set."

	| ff width co larger c box |

	anAction == #paint:
		ifTrue: ["Make a cursor from the brush and the color"
			width _ aNibForm width.
			c _ self ringColorFor: aColor.
			co _ oldCursor offset - (width // 4 @ 34 - (width // 6)) min: 0 @ 0.
			larger _ width negated + 10 @ 0 extent: oldCursor extent + (width @ width).
			ff _ oldCursor copy: larger.
			ff colors at: 1 put: Color transparent.
			ff colors at: 2 put: Color transparent.
			ff offset: co - (width @ width // 2).
			ff getCanvas
				fillOval: (Rectangle center: ff offset negated extent: width @ width)
				color: Color transparent
				borderWidth: 1
				borderColor: c.
			^ ff].
	anAction == #erase:
		ifTrue: ["Make a cursor from the cursor and the color"
			width _ aNibForm width.
			co _ oldCursor offset + (width // 2 @ 4) min: 0 @ 0.
			larger _ 0 @ 0 extent: oldCursor extent + (width @ width).
			ff _ oldCursor copy: larger.
			ff offset: co - (width @ width // 2).
			ff
				fill: (box _ co negated extent: width @ width)
				fillColor: (Color r: 0.5 g: 0.5 b: 1.0).
			ff
				fill: (box insetBy: 1 @ 1)
				fillColor: Color transparent.
			^ ff].
	^ oldCursor! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'!
deleteCurrentStamp: evt 
	"The trash is telling us to delete the currently selected stamp"

	(tool arguments second) == #stamp: 
		ifTrue: 
			[stampHolder remove: tool.
			self setAction: #paint: evt: evt]	"no use stamping with a blank stamp"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'JMM 9/13/2004 09:47'!
eyedropper: aButton action: aSelector cursor: aCursor evt: evt 
	"Take total control and pick up a color!!!!"

	| pt feedbackColor delay |
	delay _ Delay forMilliseconds: 10.
	aButton state: #on.
	tool ifNotNil: [tool state: #off].
	currentCursor := aCursor.
	evt hand showTemporaryCursor: currentCursor
		hotSpotOffset: 6 negated @ 4 negated.
	"<<<< the form was changed a bit??"
	feedbackColor := Display colorAt: Sensor cursorPoint.
	colorMemory align: colorMemory bounds topRight
		with: colorMemoryThin bounds topRight.
	self addMorphFront: colorMemory.

	"Full color picker"
	[Sensor anyButtonPressed] whileFalse: 
			[pt := Sensor cursorPoint.
			"deal with the fact that 32 bit displays may have garbage in the 
			alpha bits"
			feedbackColor := Display depth = 32 
						ifTrue: 
							[Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 4278190080)
								depth: 32]
						ifFalse: [Display colorAt: pt].
			"the hand needs to be drawn"
			evt hand position: pt.
			currentColor ~= feedbackColor ifTrue: [
				currentColor _ feedbackColor.
				self showColor ].
			self world displayWorldSafely.
			delay wait].

	"Now wait for the button to be released."
	[Sensor anyButtonPressed] whileTrue:
		[ pt := Sensor cursorPoint.
		"the hand needs to be drawn"
		evt hand position: pt.
		self world displayWorldSafely.
		delay wait].

	evt hand showTemporaryCursor: nil hotSpotOffset: 0 @ 0.
	self currentColor: feedbackColor evt: evt.
	colorMemory delete.
	tool ifNotNil: 
			[tool state: #on.
			currentCursor := tool arguments third].
	aButton state: #off
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 12:52'!
getColor
	^ currentColor! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'!
getNib
	^currentBrush arguments third! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 13:02'!
getSpecial
	^ action		"a selector like #paint:"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/21/2003 23:17'!
grabFromScreen: evt 
	"Allow the user to grab a picture from the screen OUTSIDE THE PAINTING AREA and install it in a blank stamp.  To get a stamp in the painting area, click on the stamp tool in a blank stamp."

	"scroll to blank stamp"

	| stampButton form |
	stampButton := stampHolder stampButtons first.
	[(stampHolder stampFormFor: stampButton) isNil] 
		whileFalse: [stampHolder scroll: 1].
	form := Form fromUser.
	tool state: #off.
	tool := stampHolder otherButtonFor: stampButton.
	stampHolder stampForm: form for: tool.	"install it"
	stampButton state: #on.
	stampButton doButtonAction: evt.
	evt hand showTemporaryCursor: (focusMorph getCursorFor: evt)! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'sw 8/29/2000 15:31'!
indicateColorUnderMouse
	"Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color."

	| pt feedbackColor |
	pt _ Sensor cursorPoint.
	"deal with the fact that 32 bit displays may have garbage in the alpha bits"
	feedbackColor _ Display depth = 32
		ifTrue: [ Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 16rFF000000) depth: 32] 		ifFalse: [Display colorAt: pt].

	self activeHand position: pt.
	self world displayWorldSafely.
	Display fill: colorPatch bounds fillColor: feedbackColor.
	^ feedbackColor	! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:48'!
keep: keepButton with: keepSelector evt: evt
	"Showing of the corrent palette (viewer or noPalette) is done by the block submitted to the SketchMorphEditor, see (EToyHand makeNewDrawing) and (SketchMorph editDrawingInWorld:forBackground:)."
	| ss |
	owner ifNil: [^ self].
	keepButton ifNotNil: [keepButton state: #off].
	(ss _ self focusMorph) 
		ifNotNil: [ss savePainting: self evt: evt]
		ifNil:
		[keepSelector == #silent ifTrue: [^ self].
		self notCurrentlyPainting].! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'sw 5/3/1998 18:22'!
notCurrentlyPainting
	self inform: 'You are not currently painting'! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:04'!
pickup: actionButton action: aSelector cursor: aCursor evt: evt 
	"Special version for pickup: and stamp:, because of these tests"

	| ss picker old map stamper |
	self 
		tool: actionButton
		action: aSelector
		cursor: aCursor
		evt: evt.
	aSelector == #stamp: 
		ifTrue: 
			[(stampHolder pickupButtons includes: actionButton) 
				ifTrue: 
					[stamper := stampHolder otherButtonFor: actionButton.
					^self 
						pickup: stamper
						action: #stamp:
						cursor: (stamper arguments third)
						evt: evt].
			(stampHolder stampFormFor: actionButton) ifNil: 
					["If not stamp there, go to pickup mode"

					picker := stampHolder otherButtonFor: actionButton.
					picker state: #on.
					^self 
						pickup: picker
						action: #pickup:
						cursor: (picker arguments third)
						evt: evt]
				ifNotNil: 
					[old := stampHolder stampFormFor: actionButton.
					currentCursor := ColorForm extent: old extent depth: 8.
					old displayOn: currentCursor.
					map := Color indexedColors copy.
					map at: 1 put: Color transparent.
					currentCursor colors: map.
					currentCursor offset: currentCursor extent // -2.
					"Emphisize the stamp button"
					actionButton owner borderColor: (Color 
								r: 0.65
								g: 0.599
								b: 0.8)	"layoutMorph"	"color: (Color r: 1.0 g: 0.645 b: 0.419);"]].
	aSelector == #pickup: 
		ifTrue: 
			[ss := self focusMorph.
			ss ifNotNil: [currentCursor := aCursor]
				ifNil: 
					[self notCurrentlyPainting.
					self setAction: #paint: evt: evt]]! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/2/97 22:13'!
pickupForm: stampForm
	"Install the new picture in this stamp"

	| stampButton |
	stampHolder stampForm: stampForm for: tool.
	stampButton _ action == #pickup: 
		ifTrue: [stampHolder otherButtonFor: tool]
		ifFalse: [tool].	"was a nil stampForm"
	stampButton state: #on.
	stampButton doButtonAction.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/17/2000 14:59'!
pickupForm: stampForm evt: evt
	"Install the new picture in this stamp"

	| stampButton |
	stampHolder stampForm: stampForm for: tool.
	stampButton _ action == #pickup: 
		ifTrue: [stampHolder otherButtonFor: tool]
		ifFalse: [tool].	"was a nil stampForm"
	stampButton state: #on.
	stampButton doButtonAction: evt.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:40'!
plainCursor
	"Return the cursor to use with this painting action/tool. Offset of the form must be set."

	^currentCursor
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 10/10/2000 16:38'!
plainCursor: aCursor event: anEvent
	"Set the cursor to use with this painting action/tool. Offset of the form must be set."

	currentCursor _ aCursor.
	anEvent hand showTemporaryCursor: aCursor.
	self notifyWeakDependentsWith: {#currentCursor. anEvent. currentCursor}.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:30'!
ringColor
	"Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green"

	^self ringColorFor: currentColor
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:29'!
ringColorFor: aColor
	"Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green"

	aColor isTransparent ifTrue: [^ Color red].
	aColor red < 0.5 ifTrue: [^ Color red].
	aColor red > (aColor green + (aColor blue * 0.5))
		ifTrue: [^ Color green]
		ifFalse: [^ Color red].
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:44'!
scrollStamps: actionButton action: aSelector evt: evt
	"Move the stamps over"

	aSelector == #prevStamp:
		ifTrue: [stampHolder scroll: -1]
		ifFalse: [stampHolder scroll: 1].
	actionButton state: #off.
	action == #stamp: ifTrue: ["reselect the stamp and compute the cursor"
		self stampForm 
			ifNil: [self setAction: #paint: evt: evt]
			ifNotNil: [tool doButtonAction: evt]].
		! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/22/2000 11:57'!
setAction: aSelector evt: evt
	"Find this button and turn it on.  Does not work for stamps or pickups"

	| button |
	button _ self submorphNamed: aSelector.
 
	button ifNotNil: [
		button state: #on.
		button doButtonAction: evt].	"select it!!"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:04'!
showColor
	"Display the current color in all brushes, both on and off."

	| offIndex onIndex center |
	currentColor ifNil: [^self].
	"colorPatch color: currentColor.	May delete later"
	(brushes isNil or: [brushes first owner ~~ self]) 
		ifTrue: 
			[brushes := OrderedCollection new.
			#(#brush1: #brush2: #brush3: #brush4: #brush5: #brush6:) 
				do: [:sel | brushes addLast: (self submorphNamed: sel)]].
	center := (brushes sixth) offImage extent // 2.
	offIndex := (brushes sixth) offImage pixelValueAt: center.
	onIndex := (brushes sixth) onImage pixelValueAt: center.
	brushes do: 
			[:bb | 
			bb offImage colors at: offIndex + 1 put: currentColor.
			bb offImage clearColormapCache.
			bb onImage colors at: onIndex + 1 put: currentColor.
			bb onImage clearColormapCache.
			bb invalidRect: bb bounds].
	self invalidRect: (brushes first topLeft rect: brushes last bottomRight)! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 12/19/2000 19:16'!
showColorPalette: evt

	| w box |
	self comeToFront.
	colorMemory align: colorMemory bounds topRight 
			with: colorMemoryThin bounds topRight.
	"make sure color memory fits or else align with left"
	w _ self world.
	box _ self bounds: colorMemory fullBounds in: w.
	box left < 0 ifTrue:[
		colorMemory align: colorMemory bounds topLeft
			with: colorMemoryThin bounds topLeft].
	self addMorphFront: colorMemory.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/22/2000 11:58'!
stampCursorBeCursorFor: anAction
	"User just chose a stamp.  Take that stamp picture and make it be the cursor for the tool named."
	"self stampCursorBeCursorFor: #star:.
	currentCursor offset: -9@-3.			Has side effect on the saved cursor."

	(self submorphNamed: anAction) arguments at: 3 put: currentCursor.
		"Already converted to 8 bits and in the right form"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'di 5/6/1998 21:08'!
stampDeEmphasize
	"Turn off an emphasized stamp.  Was turned on in pickup:action:cursor:"

	tool owner class == AlignmentMorph ifTrue: [
		tool "actionButton" owner "layoutMorph" color: Color transparent; 
					borderColor: Color transparent].! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/2/97 14:02'!
stampForm
	"Return the selected stamp"

	^ stampHolder stampFormFor: tool.
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/17/97 11:47'!
stampHolder

	^ stampHolder! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/17/97 11:48'!
stampHolder: newOne

	stampHolder _ newOne! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 9/23/2000 20:00'!
takeColor: aColor event: evt
	"Accept the given color programmatically"
	currentColor _ aColor.
	self notifyWeakDependentsWith: {#currentColor. evt. currentColor}.
	self showColor.
	self colorable ifFalse: [self setAction: #paint: evt: evt].	"User now thinking of painting"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 9/23/2000 20:39'!
takeColorEvt: evt from: colorPicker
	"Accept a new color from the colorMemory.  Programs use currentColor: instead.  Do not do this before the picker has a chance to set its own color!!"
	^self takeColor: colorPicker currentColor event: evt! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/21/2000 16:06'!
toggleShapes
	| tab sh stamps |
	"The sub panel that has the shape tools on it.  Rect, line..."
	stamps _ self submorphNamed: 'stamps'.
	tab _ self submorphNamed: 'shapeTab'.
	(sh _ self submorphNamed: 'shapes') visible
		ifTrue: [sh hide.  tab top: stamps bottom-1]
		ifFalse: [sh comeToFront.  sh top: stamps bottom-9.  
				sh show.  tab top: sh bottom - tab height + 10].
	self layoutChanged.
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/21/2000 15:57'!
toggleStamps
	| tab otherTab st shapes |
	"The sub panel that has the stamps in it.  For saving and moving parts of an image."
	shapes _ self submorphNamed: 'shapes'.
	otherTab _ self submorphNamed: 'shapeTab'.
	tab _ self submorphNamed: 'stampTab'.
	(st _ self submorphNamed: 'stamps') visible
		ifTrue: [st hide.  st bottom: self bottom.  tab top: self bottom-1.
				shapes top: self bottom-9.
				otherTab top: (shapes visible ifTrue: [shapes bottom - otherTab height + 10] 
									ifFalse: [self bottom-1])]
		ifFalse: [st top: self bottom-10.  st show.  tab top: st bottom-0.
				shapes top: st bottom-9.
				otherTab top: (shapes visible ifTrue: [shapes bottom - otherTab height + 10] 
									ifFalse: [st bottom-0])].
	self layoutChanged.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 12:09'!
tool
	^ tool! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 12:38'!
tool: actionButton action: aSelector cursor: aCursor evt: evt
	"Set the current tool and action for the paintBox.  "

	tool ifNotNil: [
		tool == actionButton ifFalse: [
			tool state: #off.
			action == #stamp: ifTrue: [self stampDeEmphasize]]].
	tool _ actionButton.		"A ThreePhaseButtonMorph"
	"tool state: #on.	already done"
	action _ aSelector.		"paint:"
	currentCursor _ aCursor.
	self notifyWeakDependentsWith: {#action. evt. action}.
	self notifyWeakDependentsWith: {#currentCursor. evt. currentCursor}.
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:45'!
toss: cancelButton with: cancelSelector evt: evt
	"Reject the painting.  Showing noPalette is done by the block submitted to the SketchEditorMorph"

	| focus |
	owner ifNil: ["it happens"  ^ self].
	(focus _ self focusMorph) 
		ifNotNil: [focus cancelPainting: self evt: evt]
		ifNil:
			[self delete].
	cancelButton state: #off.
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 11:15'!
undo: undoButton with: undoSelector evt: evt
	| ss |
	(ss _ self focusMorph) 
		ifNotNil: [ss undoPainting: self evt: evt]
		ifNil: [self notCurrentlyPainting].
	undoButton state: #off.! !


!PaintBoxMorph methodsFor: 'copying' stamp: 'di 10/14/97 10:13'!
updateReferencesUsing: aDictionary
	"Fix up stampHolder which is a ScrollingToolHolder, which is not a Morph"

	super updateReferencesUsing: aDictionary.
	stampHolder updateReferencesUsing: aDictionary.
	colorMemory updateReferencesUsing: aDictionary.! !


!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 16:47'!
addWeakDependent: anObject

	weakDependents ifNil: [^weakDependents _ WeakArray with: anObject].
	weakDependents _ weakDependents,{anObject} reject: [ :each | each isNil].! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 14:59'!
beStatic

	colorMemory ifNotNil: [colorMemory beStatic].! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:53'!
createButtons
	"Create buttons one at a time and let the user place them over the background.  Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph.
	self createButtons.	"

	| rect button nib |
	#(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: pickup: "pickup: pickup: pickup:" stamp: "stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel |
		(self submorphNamed: sel) ifNil:
			[self inform: 'Rectangle for ',sel.
			rect _ Rectangle fromUser.
			button _ ThreePhaseButtonMorph new.
			button onImage: nil; bounds: rect.
			self addMorph: button.
			button actionSelector: #tool:action:cursor:evt:; arguments: (Array with: button with: sel with: nil).
			button actWhen: #buttonUp; target: self]].
	#(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind |
		(self submorphNamed: sel) ifNil:
			[self inform: 'Rectangle for ',sel.
			rect _ Rectangle fromUser.
			button _ ThreePhaseButtonMorph new.
			button onImage: nil; bounds: rect.
			self addMorph: button.
			nib _ Form dotOfSize: (#(1 2 3 6 11 26) at: ind).
			button actionSelector: #brush:action:nib:evt:; 
					arguments: (Array with: button with: sel with: nib).
			button actWhen: #buttonUp; target: self]].
	"stamp:  Stamps are held in a ScrollingToolHolder.  Pickups and stamps and brushes are id-ed by the button == with item from a list."


! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 19:39'!
fixupButtons
	| changes answer newSelector |
	changes := Dictionary new.
	changes
		at: #brush:action:nib: put: #brush:action:nib:evt:;
		at: #tool:action:cursor: put: #tool:action:cursor:evt:;
		at: #pickup:action:cursor: put: #pickup:action:cursor:evt:;
		at: #keep:with: put: #keep:with:evt:;
		at: #undo:with: put: #undo:with:evt:;
		at: #scrollStamps:action: put: #scrollStamps:action:evt:;
		at: #toss:with: put: #toss:with:evt:;
		at: #eyedropper:action:cursor: put: #eyedropper:action:cursor:evt:;
		at: #clear:with: put: #clear:with:evt:.
	answer := WriteStream on: String new.
	self allMorphsDo: 
			[:each | 
			(each isKindOf: ThreePhaseButtonMorph) 
				ifTrue: 
					[answer nextPutAll: each actionSelector.
					(changes includesKey: each actionSelector) 
						ifTrue: 
							[each actionSelector: (newSelector := changes at: each actionSelector).
							answer nextPutAll: ' <-- ' , newSelector].
					answer cr]].
	^answer contents
	"StringHolder new
		contents: answer contents;
		openLabel: 'button fixups'"! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 19:03'!
init3
	"Just a record of how we loaded in the latest paintbox button images"

	| bb rect lay pic16Bit aa blt on thin |
	self loadoffImage: 'etoy_default.gif'.
	self allMorphsDo: 
			[:button | 
			(button isKindOf: ThreePhaseButtonMorph) 
				ifTrue: [button offImage: nil]
				ifFalse: [button position: button position + (100 @ 0)]].
	(bb := self submorphNamed: #keep:) position: bb position + (100 @ 0).
	(bb := self submorphNamed: #toss:) position: bb position + (100 @ 0).
	(bb := self submorphNamed: #undo:) position: bb position + (100 @ 0).
	"Transparent is (Color r: 1.0 g: 0 b: 1.0)"
	self moveButtons.
	self loadOnImage: 'etoy_in.gif'.
	AllOnImage := nil.
	'save space'.
	self loadPressedImage: 'etoy_in.gif'.
	AllPressedImage := nil.
	'save space'.
	self loadCursors.

	"position the stamp buttons"
	stampHolder stampButtons owner last delete.
	stampHolder pickupButtons last delete.
	stampHolder stampButtons: (stampHolder stampButtons copyFrom: 1 to: 3).
	stampHolder pickupButtons: (stampHolder pickupButtons copyFrom: 1 to: 3).
	"| rect |"
	stampHolder pickupButtons do: 
			[:button | 
			"PopUpMenu notify: 'Rectangle for ',sel."

			rect := Rectangle fromUser.
			button bounds: rect	"image is nil"].
	"| rect lay |"
	stampHolder clear.
	stampHolder stampButtons do: 
			[:button | 
			button
				offImage: nil;
				pressedImage: nil.
			lay := button owner.
			"PopUpMenu notify: 'Rectangle for ',sel."
			rect := Rectangle fromUser.
			button image: (Form fromDisplay: (rect insetBy: 2)).
			lay borderWidth: 2.
			lay bounds: rect	"image is nil"].
	"| pic16Bit blt aa on |"
	pic16Bit := GIFReadWriter formFromFileNamed: 'etoy_in.gif'.	"really 8"
	aa := Form extent: OriginalBounds extent depth: 8.
	blt := BitBlt current toForm: aa.
	blt
		sourceForm: pic16Bit;
		combinationRule: Form over;
		sourceRect: OriginalBounds;
		destOrigin: 0 @ 0;
		copyBits.
	"Collect all the images for the buttons in the on state"
	stampHolder pickupButtons do: 
			[:button | 
			on := ColorForm extent: button extent depth: 8.
			on colors: pic16Bit colors.
			on 
				copy: (0 @ 0 extent: button extent)
				from: button topLeft - self topLeft
				in: aa
				rule: Form over.
			button
				image: on;
				pressedImage: on;
				offImage: nil].
	self invalidRect: bounds.
	((self submorphNamed: #erase:) arguments third) offset: 12 @ 35.
	((self submorphNamed: #eyedropper:) arguments third) offset: 0 @ 0.
	((self submorphNamed: #fill:) arguments third) offset: 10 @ 44.
	((self submorphNamed: #paint:) arguments third) offset: 3 @ 3.	"unused"
	((self submorphNamed: #rect:) arguments third) offset: 6 @ 17.
	((self submorphNamed: #ellipse:) arguments third) offset: 5 @ 4.
	((self submorphNamed: #polygon:) arguments third) offset: 5 @ 4.
	((self submorphNamed: #line:) arguments third) offset: 5 @ 17.
	((self submorphNamed: #star:) arguments third) offset: 2 @ 5.
	thumbnail delete.
	thumbnail := nil.
	(submorphs select: [:e | e class == RectangleMorph]) first 
		bounds: Rectangle fromUser.
	((submorphs select: [:e | e class == RectangleMorph]) first)
		borderWidth: 1;
		borderColor: Color black.
	"| thin |"
	submorphs do: [:ss | ss class == ImageMorph ifTrue: [thin := ss	"first"]].
	colorMemoryThin := thin! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/2000 11:56'!
init4
	"Just a record of how Ted loaded in the paintbox button images, Feb 98"
| bb im pp newImage pic24Bit picNewBit blt |

"self loadoffImage: 'roundedPalette3.bmp'."
pic24Bit _ GIFReadWriter formFromServerFile: 'updates/137roundedPalette3.bmp'.
picNewBit _ Form extent: pic24Bit extent depth: 16.
pic24Bit displayOn: picNewBit.
OriginalBounds _ picNewBit boundingBox.
AllOffImage _ Form extent: OriginalBounds extent depth: 16.
blt _ BitBlt current toForm: AllOffImage.
blt sourceForm: picNewBit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.

AllOffImage mapColor: Color transparent to: Color black.
self image: AllOffImage.
self invalidRect: bounds.

self submorphsDo: [:button | button position: button position + (10@10)].
(im _ submorphs at: 28) class == ImageMorph ifTrue: [
	im position: im position + (2@0)].	"color picker"
"exercise it once"

(bb _ self submorphNamed: #keep:) position: bb position + (0@25).
(bb _ self submorphNamed: #toss:) position: bb position + (0@25).
(bb _ self submorphNamed: #undo:) position: bb position + (0@-25).
(bb _ self submorphNamed: #clear:) position: bb position + (0@-25).
(bb _ self submorphNamed: #undo:) position: bb position + (0@-69).
(bb _ self submorphNamed: #clear:) position: bb position + (0@-69).
self submorphsDo: [:button | 
	button class == AlignmentMorph ifTrue: [
		button position: button position + (0@25)].
	(button printString includesSubString: 'stamp:') ifTrue: [
		button position: button position + (0@25)]].
(bb _ self submorphNamed: #prevStamp:) position: bb position + (0@25).
(bb _ self submorphNamed: #nextStamp:) position: bb position + (0@25).

bb _ self submorphNamed: #keep:.
newImage _ bb pressedImage copy: (0@4 corner: (bb pressedImage boundingBox extent)).
bb onImage: newImage.  bb pressedImage: newImage.  bb extent: newImage extent.
bb position: bb position + (4@1).

pp _ (bb _ self submorphNamed: #toss:) pressedImage.
newImage _ pp copy: (0@4 corner: (bb pressedImage extent - (3@0))).
bb onImage: newImage.  bb pressedImage: newImage.  
bb extent: newImage extent.
bb position: bb position + (3@1).

pp _ (bb _ self submorphNamed: #undo:) pressedImage.
newImage _ pp copy: (0@0 corner: (bb pressedImage extent - (3@5))).
bb onImage: newImage.  bb pressedImage: newImage.  
bb extent: newImage extent.
bb position: bb position + (3@-1).

pp _ (bb _ self submorphNamed: #clear:) pressedImage.
newImage _ pp copy: (0@0 corner: (bb pressedImage extent - (0@5))).
bb onImage: newImage.  bb pressedImage: newImage.  
bb extent: newImage extent.
bb position: bb position + (3@-1).

pic24Bit _ GIFReadWriter formFromServerFile: 'updates/137pencil.bmp'.
picNewBit _ Form extent: pic24Bit extent depth: 16.
pic24Bit displayOn: picNewBit.
newImage _ picNewBit as8BitColorForm.
newImage transparentColor: (Color r: 0 g: 0 b: 0).
(bb _ self submorphNamed: #erase:) pressedImage: newImage; onImage: newImage;
	extent: newImage extent.

bb position: bb position + (-11@-1).
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 7/28/2000 23:26'!
initialize
	super initialize.
	colorMemory ifNotNil: [colorMemory on: #mouseDown send: #takeColorEvt:from: to: self].! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'jm 6/18/1999 18:58'!
loadColorChooser
	"Load Forms for ColorMemoryMorph."

	| doc closedForm openForm |
	doc _ Utilities objectStrmFromUpdates: 'colorPalClosed.obj'.
	closedForm _ doc fileInObjectAndCode mapColor: Color transparent to: Color black.
	doc _ Utilities objectStrmFromUpdates: 'colorPalOpen.obj'.
	openForm _ doc fileInObjectAndCode mapColor: Color transparent to: Color black.

	colorMemoryThin image: closedForm.
	colorMemoryThin position: self position + (0@140).

	colorMemory delete.	"delete old one"
	colorMemory _ PaintBoxColorPicker new image: openForm.
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:54'!
loadCursors
	"Display the form containing the cursors.  Transparent is (Color r: 1.0 g: 0 b: 1.0).  Grab the forms one at a time, and they are stored away.
	self loadCursors.	"

	| button transp cursor map |
	transp _ Color r: 1.0 g: 0 b: 1.0.
	map _ Color indexedColors copy.	"just in case"
	1 to: 256 do: [:ind | (map at: ind) = transp ifTrue: 
				[map at: ind put: Color transparent]].

	#(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: ) do: [:sel |
		self inform: 'Rectangle for ',sel.
		cursor _ ColorForm fromUser.
		cursor colors: map.	"share it"
		button _ self submorphNamed: sel.
		button arguments at: 3 put: cursor].
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 1/13/2005 12:20'!
loadJapanesePaintBoxBitmaps
"
	PaintBoxMorph new loadJapanesePaintBoxBitmaps.
"

	| formTranslator form bb |
	self position: 0@0.
	formTranslator _ NaturalLanguageFormTranslator localeID: (LocaleID isoString: 'ja').
	form _ Form fromFileNamed: 'offPaletteJapanese(children).form'.

	#('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label |
		bb _ (self submorphs detect: [:e | e externalName = extName]) bounds.
		formTranslator name: label, '-off' form: (form copy: bb)
	].


	form _ Form fromFileNamed: 'pressedPaletteJapanese(children).form'.
	#('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label |
		bb _ (self submorphs detect: [:e | e externalName = extName]) bounds.
		formTranslator name: label, '-pressed' form: (form copy: bb)
	].
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 11/4/2002 21:20'!
loadOffForm: pic16Bit 
	"Prototype loadOffForm: (Smalltalk imageImports at: #offPaletteJapanese)"

	| blt |
	OriginalBounds _ pic16Bit boundingBox.
	AllOffImage _ Form extent: OriginalBounds extent depth: 16.
	blt _ BitBlt current toForm: AllOffImage.
	blt sourceForm: pic16Bit;
		 combinationRule: Form over;
		 sourceRect: OriginalBounds;
		 destOrigin: 0 @ 0;
		 copyBits.
	AllOffImage mapColor: Color blue to: Color transparent.
	self image: AllOffImage.
	AllOffImage _ nil.
	self invalidRect: bounds
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'ar 5/28/2000 12:10'!
loadOnImage: fileName
	"Read in and convert the image for the paintBox with the buttons
on.  A .bmp 24-bit image.  For each button, cut that chunk out and save it."
	"	self loadOnImage: 'NoSh_on.bmp'.
		AllOnImage _ nil.	'save space'.	"

	| pic16Bit blt aa on type |
	type _ 'gif'.  "   gif or bmp  "
type = 'gif' ifTrue: [
	pic16Bit "really 8" _ GIFReadWriter formFromFileNamed: fileName.
	pic16Bit display.
	aa _ AllOnImage _ Form extent: OriginalBounds extent depth: 8.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	].
type = 'bmp' ifTrue: [
	pic16Bit _ (Form fromBMPFileNamed: fileName) asFormOfDepth: 16.
	pic16Bit display.
	aa _ AllOnImage _ Form extent: OriginalBounds extent depth: 16.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	aa mapColor: Color transparent to: Color black.
	].
	"Collect all the images for the buttons in the on state"
	self allMorphsDo: [:button |
		(button isKindOf: ThreePhaseButtonMorph) ifTrue: [
			type = 'gif' ifTrue: [on _ ColorForm extent: button extent depth: 8.
					 on colors: pic16Bit colors]
				ifFalse: [on _ Form extent: button extent depth: 16].
			on copy: (0@0 extent: button extent)
				from: (button topLeft - self topLeft) in: aa rule: Form over.
			button onImage: on]].
	self invalidRect: bounds.

	! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 11/4/2002 21:20'!
loadPressedForm: pic16Bit 
	"Prototype loadPressedForm: (Smalltalk imageImports at: #pressedPaletteJapanese)"

	| blt on |
	AllPressedImage _ AllPressedImage _ Form extent: OriginalBounds extent depth: 16.
	blt _ BitBlt current toForm: AllPressedImage.
	blt sourceForm: pic16Bit;
		 combinationRule: Form over;
		 sourceRect: OriginalBounds;
		 destOrigin: 0 @ 0;
		 copyBits.
	AllPressedImage mapColor: Color black to: Color transparent.
	self
		allMorphsDo: [:button | (button isKindOf: ThreePhaseButtonMorph)
				ifTrue: [on _ Form extent: button extent depth: 16.
					on
						copy: (0 @ 0 extent: button extent)
						from: button topLeft - self topLeft
						in: AllPressedImage
						rule: Form over.
					button pressedImage: on]].
	AllPressedImage _ nil.
	self invalidRect: bounds
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'ar 5/28/2000 12:10'!
loadPressedImage: fileName
	"Read in and convert the image for the paintBox with the buttons
on.  A .bmp 24-bit image.  For each button, cut that chunk out and save it."
	"	self loadPressedImage: 'NoSh_on.bmp'.
		AllPressedImage _ nil.	'save space'.	"

	| pic16Bit blt aa on type |
	type _ 'gif'.  "   gif or bmp  "
type = 'gif' ifTrue: [
	pic16Bit "really 8" _ GIFReadWriter formFromFileNamed: fileName.
	pic16Bit display.
	aa _ AllPressedImage _ Form extent: OriginalBounds extent depth: 8.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	].
type = 'bmp' ifTrue: [
	pic16Bit _ (Form fromBMPFileNamed: fileName) asFormOfDepth: 16.
	pic16Bit display.
	aa _ AllPressedImage _ Form extent: OriginalBounds extent depth: 16.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	aa mapColor: Color transparent to: Color black.
	].
	"Collect all the images for the buttons in the on state"
	self allMorphsDo: [:button |
		(button isKindOf: ThreePhaseButtonMorph) ifTrue: [
			type = 'gif' ifTrue: [on _ ColorForm extent: button extent depth: 8.
					 on colors: pic16Bit colors]
				ifFalse: [on _ Form extent: button extent depth: 16].
			on copy: (0@0 extent: button extent)
				from: (button topLeft - self topLeft) in: aa rule: Form over.
			button pressedImage: on]].
	self invalidRect: bounds.

	! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'md 11/14/2003 16:52'!
loadoffImage: fileName
	"Read in and convert the background image for the paintBox.  All
buttons off.  A .bmp 24-bit image."
	"	Prototype loadoffImage: 'roundedPalette3.bmp'	"

	| pic16Bit blt type getBounds |
	type _ 'bmp'.  " gif or bmp  "
	getBounds _ 'fromPic'.	"fromUser = draw out rect of paintbox on image"
		"fromOB = just read in new bits, keep same size and place as last time."
		"fromPic = picture is just the PaintBox, use its bounds"
type = 'gif' ifTrue: [
	pic16Bit "really 8" _ GIFReadWriter formFromFileNamed: fileName.
	getBounds = 'fromUser' ifTrue: ["Just first time, collect the bounds"
			pic16Bit display.
			OriginalBounds _ Rectangle fromUser].
	getBounds = 'fromPic' ifTrue: [OriginalBounds _ pic16Bit boundingBox].
	].
		"Use OriginalBounds as it was last time"
type = 'bmp' ifTrue: [
	pic16Bit _ (Form fromBMPFileNamed: fileName) asFormOfDepth: 16.
	getBounds = 'fromUser' ifTrue: ["Just first time, collect the bounds"
			pic16Bit display.
			OriginalBounds _ Rectangle fromUser].
		"Use OriginalBounds as it was last time"
	(getBounds = 'fromPic') ifTrue: [OriginalBounds _ pic16Bit boundingBox].
	AllOffImage _ Form extent: OriginalBounds extent depth: 16.
	].

type = 'gif' ifTrue: [
	AllOffImage _ ColorForm extent: OriginalBounds extent depth: 8.
	AllOffImage colors: pic16Bit colors].

	blt _ BitBlt current toForm: AllOffImage.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.

type = 'bmp' ifTrue: [AllOffImage mapColor: Color transparent to: Color black].
	self image: AllOffImage.
	self invalidRect: bounds.

	! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:54'!
moveButtons
	"Move buttons one at a time and let the user place them over the background.  Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph.
	self createButtons.	"

	| rect button |
	#(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: "pickup: pickup: pickup: pickup:" "stamp: stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel |
			self inform: 'Rectangle for ',sel.
			rect _ Rectangle fromUser.
			button _ self submorphNamed: sel.
			button bounds: rect.	"image is nil"].
	#(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind |
			self inform: 'Rectangle for ',sel.
			rect _ Rectangle fromUser.
			button _ self submorphNamed: sel.
			button bounds: rect.	"image is nil"].
	"stamp:  Stamps are held in a ScrollingToolHolder.  Pickups and stamps and brushes are id-ed by the button == with item from a list."

	"
	"
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/97 15:57'!
noVeneer
	"For a palette with a background (off) image, clear that image.
But first, for each button, cut that chunk out and save it in the offImage
part."
	"	self noVeneer.
		AllOffImage _ nil.	'save space.  irreversible'.	"

	| aa on |
	AllOffImage ifNil: [AllOffImage _ image].
	aa _ AllOffImage.
	"Collect all the images for the buttons in the on state"
	self allMorphsDo: [:button |
		(button isKindOf: ThreePhaseButtonMorph) ifTrue: [
			on _ Form extent: button extent depth: 16.
			on copy: (0@0 extent: button extent)
				from: (button topLeft - self topLeft) in:
aa rule: Form over.
			button offImage: on]].
	self image: (Form extent: AllOffImage extent depth: 1).
	self invalidRect: bounds.


	! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/16/2000 11:12'!
notifyWeakDependentsWith: arguments

	weakDependents ifNil: [^self].
	weakDependents do: [ :each |
		each ifNotNil: [
			each paintBoxChanged: arguments.
			each paintBoxChanged: {#changed. arguments second. true}.
		].
	].! !


!PaintBoxMorph methodsFor: 'other' stamp: 'dgd 8/30/2003 21:55'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	"super addCustomMenuItems: aCustomMenu hand: aHandMorph."
		"don't want the ones from ImageMorph"
	aCustomMenu add: 'grab stamp from screen' translated action: #grabFromScreen:.

! !

!PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 14:08'!
addGraphicLabels
	"translate button labels"

	| formTranslator ext pos newForm |
	formTranslator _ NaturalLanguageFormTranslator localeID: (Locale current localeID).

	#('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:label |
		(formTranslator translate: label, '-off') ifNil: [^ false].
		(formTranslator translate: label, '-pressed') ifNil: [^ false].
	].
	
	#('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label |
		| button |
		button _ submorphs detect: [:m | m externalName = extName] ifNone: [nil].
		button ifNotNil: [
			button removeAllMorphs.
			ext _ button extent.
			pos _ button position.
			(newForm _ formTranslator translate: label, '-off') ifNotNil: [
				button offImage: newForm.

			].
			(newForm _ formTranslator translate: label, '-pressed') ifNotNil: [
				button pressedImage: newForm.
			].
			button extent: ext.
			button position: pos.
		].
	].

	^ true.
! !

!PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 14:08'!
addLabels

	Preferences useFormsInPaintBox ifFalse: [
		self addTextualLabels.
	] ifTrue: [
		self addGraphicLabels ifFalse: [self addTextualLabels].
	].
! !

!PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 11:06'!
addTextualLabels
	"translate button labels"

	#('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label |
		| button |
		button _ submorphs detect: [:m | m externalName = extName] ifNone: [nil].
		button ifNotNil: [
			button removeAllMorphs.
			button addMorph: (TextMorph new 
				contentsWrapped: (Text string: label translated
					attributes: {
						TextAlignment centered. 
						TextEmphasis bold.
						TextFontReference toFont:
							(Preferences standardPaintBoxButtonFont)});
				bounds: (button bounds translateBy: 0@3);
				lock)]]! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 10/31/97 13:38'!
colorMemory

	^ colorMemory! !

!PaintBoxMorph methodsFor: 'other' stamp: 'di 10/14/97 10:15'!
colorMemory: aMorph

	colorMemory _ aMorph! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 10/31/97 13:35'!
colorPatch
	^ colorPatch! !

!PaintBoxMorph methodsFor: 'other' stamp: 'ar 3/23/2000 14:18'!
focusMorph
	"Note: For backward compatibility we search the world for a SketchEditorMorph if the current focus morph is nil"
	^focusMorph ifNil:[focusMorph _ self world findA: SketchEditorMorph]! !

!PaintBoxMorph methodsFor: 'other' stamp: 'ar 3/23/2000 14:20'!
focusMorph: newFocus
	"Set the new focus morph"
	focusMorph ifNotNil:[focusMorph paletteDetached: self]. "In case the morph is interested"
	focusMorph _ newFocus.
	focusMorph ifNotNil:[focusMorph paletteAttached: self]. "In case the morph is interested"! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 8/22/2000 11:57'!
maxBounds
	| rr |
	"fullBounds if all flop-out parts of the paintBox were showing."

	rr _ bounds merge: colorMemory bounds.
	rr _ rr merge: (self submorphNamed: 'stamps') bounds.
	rr _ rr origin corner: rr corner + (0@ (self submorphNamed: 'shapes') height 
				+ 10 "what is showing of (self submorphNamed: #toggleShapes) height").
	^ rr! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 8/22/2000 23:48'!
offsetFromMaxBounds
	"location of normal PaintBox within maxBounds."

	^ self left - colorMemory left @ 0! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 7/17/97 16:26'!
rotationTabForm
	^ rotationTabForm! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 7/17/97 16:26'!
scaleTabForm
	^ scaleTabForm! !


!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 7/8/2006 20:33'!
fixUpColorPicker
	| chart picker |
	chart _ ColorChart ifNil:[Cursor wait showWhile:[ColorChart _ (ColorPickerMorph colorPaletteForDepth: 16 extent: 120@89)]].
	chart getCanvas frameRectangle: chart boundingBox color: Color black.
	picker _ Form extent: (chart extent + (14@12)) depth: 16.
	picker fillWhite.
	"top"
	picker copy: (0@0 extent: picker width@6)
			from: (colorMemory image width - picker width)@0 
			in: colorMemory image rule: Form over.
	"bottom"
	picker copy: (0@ (picker height-6) extent: picker width@6) 
			from: (colorMemory image width - picker width)@(colorMemory image height - 7)
			in: colorMemory image rule: Form over.
	"left"
	picker copy: (0@6 corner: 8@(picker height - 6))
			from: (colorMemory image boundingBox topLeft + (0@6)) 
			in: colorMemory image rule: Form over.
	"right"
	picker copy: (picker width-6@6 corner: picker width@(picker height - 6))
			from: (colorMemory image boundingBox topRight - (6@-6)) 
			in: colorMemory image rule: Form over.
	chart displayOn: picker at: 8@6.
	picker getCanvas frameRectangle: picker boundingBox color: Color black.
	colorMemory image: picker.
! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'dgd 2/21/2003 23:17'!
fixUpRecentColors
	| inner outer border box form newImage canvas morph |
	self fixUpColorPicker.
	recentColors := WriteStream on: Array new.
	form := image.
	newImage := Form extent: form extent + (0 @ 41) depth: form depth.
	form displayOn: newImage.
	newImage 
		copy: (0 @ (form height - 10) 
				extent: form width @ (newImage height - form height + 10))
		from: 0 @ (form height - (newImage height - form height + 10))
		in: form
		rule: Form over.
	canvas := newImage getCanvas.
	canvas 
		line: 12 @ (form height - 10)
		to: 92 @ (form height - 10)
		width: 1
		color: Color black.
	canvas := canvas copyOffset: 12 @ (form height - 9).
	inner := Color 
				r: 0.677
				g: 0.71
				b: 0.968.
	outer := inner darker darker.
	border := Color 
				r: 0.194
				g: 0.258
				b: 0.194.
	0 to: 1
		do: 
			[:y | 
			0 to: 3
				do: 
					[:x | 
					box := (x * 20) @ (y * 20) extent: 20 @ 20.
					morph := BorderedMorph new 
								bounds: ((box insetBy: 1) translateBy: canvas origin + bounds origin).
					morph
						borderWidth: 1;
						borderColor: border.
					morph color: Color white.
					morph 
						on: #mouseDown
						send: #mouseDownRecent:with:
						to: self.
					morph 
						on: #mouseMove
						send: #mouseStillDownRecent:with:
						to: self.
					morph 
						on: #mouseUp
						send: #mouseUpRecent:with:
						to: self.
					self addMorphFront: morph.
					recentColors nextPut: morph.
					canvas fillRectangle: box color: Color white.
					canvas frameRectangle: (box insetBy: 1) color: border.
					canvas frameRectangle: box color: inner.
					box := box insetBy: 1.
					canvas 
						line: box topRight
						to: box bottomRight
						width: 1
						color: outer.
					canvas 
						line: box bottomLeft
						to: box bottomRight
						width: 1
						color: outer]].
	recentColors := recentColors contents.
	(RecentColors isNil or: [RecentColors size ~= recentColors size]) 
		ifTrue: [RecentColors := recentColors collect: [:each | each color]]
		ifFalse: 
			[RecentColors 
				keysAndValuesDo: [:idx :aColor | (recentColors at: idx) color: aColor]].
	self image: newImage.
	self toggleStamps.
	self toggleStamps! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 19:54'!
mouseDownRecent: evt with: aMorph
	aMorph borderColor: Color white.
! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 20:01'!
mouseStillDownRecent: evt with: aMorph
	(aMorph containsPoint: evt cursorPoint)
		ifTrue:[aMorph borderColor: Color white]
		ifFalse:[aMorph borderColor: (Color r: 0.194 g: 0.258 b: 0.194)]
! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 19:59'!
mouseUpRecent: evt with: aMorph
	aMorph borderColor: (Color r: 0.194 g: 0.258 b: 0.194).
	(aMorph containsPoint: evt cursorPoint) ifTrue:[
		self takeColor: aMorph color event: evt.
	].! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'dgd 2/21/2003 23:17'!
recentColor: aColor 
	"Remember the color as one of our recent colors"

	(recentColors anySatisfy: [:any | any color = aColor]) ifTrue: [^self].	"already remembered"
	recentColors size to: 2
		by: -1
		do: 
			[:i | 
			(recentColors at: i) color: (recentColors at: i - 1) color.
			RecentColors at: i put: (RecentColors at: i - 1)].
	(recentColors first) color: aColor.
	RecentColors at: 1 put: aColor! !


!PaintBoxMorph methodsFor: 'user interface' stamp: 'tk 7/2/97 08:10'!
mouseUpBalk: evt
	"A button I own got a mouseDown, but the user moved out before letting up.  Prevent this for the current tool.  Some tool must stay selected."

	tool state: #on.	"keep current one, even if user balked on it"
	currentBrush ifNotNil: [currentBrush state: #on].! !


!PaintBoxMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 6/30/1999 20:33'!
isCandidateForAutomaticViewing
	^ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PaintBoxMorph class
	instanceVariableNames: ''!

!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 8/21/2000 12:52'!
fixUpPrototype
	"PaintBoxMorph fixUpPrototype"
self error: 'who uses this?'.
	Prototype eventHandler: nil! !

!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'ar 7/8/2006 20:33'!
initializeColorChart
	"PaintBoxMorph initializeColorChart"
	ColorChart _ (ColorPickerMorph colorPaletteForDepth: 32 extent: (360+10)@(180+10))! !

!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 10/12/97 11:01'!
prototype
	"Later we will be a subclass of Model, and it will have a general version of this"
	^ Prototype! !


!PaintBoxMorph class methodsFor: 'class initialization' stamp: 'tk 8/21/2000 12:58'!
initialize
	"PaintBoxMorph initialize"

	Prototype eventHandler: nil.
	Prototype focusMorph: nil.
	Prototype stampHolder clear.  "clear stamps"
	Prototype delete.  "break link to world, if any"

	AllOnImage _ AllOffImage _ AllPressedImage _ nil.
	OriginalBounds _ nil.

! !


!PaintBoxMorph class methodsFor: 'instance creation' stamp: 'bf 10/11/2004 13:37'!
new

	| pb button dualUse formCanvas rect |
	pb _ Prototype veryDeepCopy.
		"Assume that the PaintBox does not contain any scripted Players!!"
	pb stampHolder normalize.	"Get the stamps to show"
	"Get my own copies of the brushes so I can modify them"
	#(brush1: brush2: brush3: brush4: brush5: brush6:) do: [:sel |
		button _ pb submorphNamed: sel.
		button offImage: button offImage deepCopy.
		dualUse _ button onImage == button pressedImage.	"sometimes shared"
		button onImage: button onImage deepCopy.
		dualUse
			ifTrue: [button pressedImage: button onImage]
			ifFalse: [button pressedImage: button pressedImage deepCopy].
		"force color maps for later mapping"
		button offImage.
		button onImage.
		button pressedImage.
		formCanvas _ button onImage getCanvas.
		formCanvas _ formCanvas
			copyOrigin: 0@0
			clipRect: (rect _ 0@0 extent: button onImage extent).
		(#(brush1: brush3:) includes: sel) ifTrue: [
			rect _ rect origin corner: rect corner - (2@2)].
		(#brush2: == sel) ifTrue: [
			rect _ rect origin corner: rect corner - (2@4)].
		formCanvas frameAndFillRectangle: rect fillColor: Color transparent
			borderWidth: 2 borderColor: (Color r: 0.599 g: 0.8 b: 1.0).
		].
	pb showColor.
	pb fixUpRecentColors.
	pb addLabels.
	^ pb! !


!PaintBoxMorph class methodsFor: 'notification' stamp: 'ar 7/8/2006 20:33'!
localeChanged
	| caption |
	caption := ColorPickerMorph noColorCaption.
	caption displayOn: ColorChart at: ColorChart boundingBox topCenter - (caption width // 2 @ 0)! !
ImageMorph subclass: #PaintInvokingMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!PaintInvokingMorph commentStamp: '<historical>' prior: 0!
When this is dropped inside some appropriate place, then painting is invoked for that place.!


!PaintInvokingMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 4/3/2006 14:19'!
justDroppedInto: aPasteUpMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph"
	aPasteUpMorph isPartsBin ifFalse:[
		self removeHalo.
		self delete.
		^aPasteUpMorph makeNewDrawing: anEvent].
	^super justDroppedInto: aPasteUpMorph event: anEvent! !

!PaintInvokingMorph methodsFor: 'dropping/grabbing' stamp: 'ar 3/3/2001 20:40'!
wantsToBeDroppedInto: aMorph
	"Only into PasteUps that are not part bins"
	^aMorph isPlayfieldLike! !


!PaintInvokingMorph methodsFor: 'initialization' stamp: 'sw 7/16/1998 00:02'!
initialize
	super initialize.
	self image: (ScriptingSystem formAtKey: 'Painting')! !


!PaintInvokingMorph methodsFor: 'parts bin' stamp: 'sw 8/12/2001 17:19'!
initializeToStandAlone
	super initializeToStandAlone.
	self image: (ScriptingSystem formAtKey: 'Painting')! !


!PaintInvokingMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 6/30/1999 20:31'!
isCandidateForAutomaticViewing
	^ self isPartsDonor not! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PaintInvokingMorph class
	instanceVariableNames: ''!

!PaintInvokingMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:16'!
initialize

	self registerInFlapsRegistry.! !

!PaintInvokingMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:09'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(PaintInvokingMorph	new	'Paint'	'Drop this into an area to start making a fresh painting there')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(PaintInvokingMorph	new	'Paint'	'Drop this into an area to start making a fresh painting there')
						forFlapNamed: 'Widgets'.
						cl registerQuad: #(PaintInvokingMorph	new	'Paint'	'Drop this into an area to start making a fresh painting there')
						forFlapNamed: 'Scripting']! !

!PaintInvokingMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:38'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!PaintInvokingMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'!
descriptionForPartsBin
	^ self partName:	'Paint'
		categories:		#('Basic' 'Graphics')
		documentation:	'Drop this icon to start painting a new object.'! !


!PaintInvokingMorph class methodsFor: 'scripting' stamp: 'sw 5/6/2000 02:28'!
authoringPrototype
	^ self new image: (ScriptingSystem formAtKey: 'Painting'); markAsPartsDonor; setBalloonText: 'drop this into any playfield or book page to make a new painting there'; yourself! !
CompositeStub subclass: #PanelStub
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!
DisplayText subclass: #Paragraph
	instanceVariableNames: 'clippingRectangle compositionRectangle destinationForm rule mask marginTabsLevel lines lastLine'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'ST80-Support'!
!Paragraph commentStamp: '<historical>' prior: 0!
I represent displayable text that has been decoraged with margin alignment, line leading, and tab settings.!


!Paragraph methodsFor: 'accessing'!
backgroundColor
	backColor == nil ifTrue: [^ Color white].
	^ backColor! !

!Paragraph methodsFor: 'accessing'!
clippingRectangle 
	"Answer the rectangle, defined in absolute coordinates, whose 
	intersection with the destinationForm is the area in which the characters 
	are constrained to display."

	^clippingRectangle! !

!Paragraph methodsFor: 'accessing' stamp: 'di 10/5/97 15:33'!
clippingRectangle: clipRect 
	clippingRectangle _ clipRect! !

!Paragraph methodsFor: 'accessing'!
compositionRectangle
	"Answer the rectangle whose width is the dimension, modified by 
	indents and tabsLevels, against which line wraparound is measured. The 
	height of the compositionRectangle is reset each time recomposition is 
	required."

	^compositionRectangle! !

!Paragraph methodsFor: 'accessing'!
compositionRectangle: compRectangle 
	"Set the rectangle whose width is the dimension, modified by indents and 
	tabsLevels, against which line wraparound is measured."

	compositionRectangle _ compRectangle.
	self composeAll! !

!Paragraph methodsFor: 'accessing'!
destinationForm 
	 "Answer the Form into which the characters are scanned."

	^destinationForm! !

!Paragraph methodsFor: 'accessing'!
fillColor 
	"Answer the Form with which each character is combined by the scanner 
	before applying the rule for display."

	^mask! !

!Paragraph methodsFor: 'accessing'!
fillColor: maskForm 
	"Set the argument, maskForm, to be the form with which each character 
	is combined by the scanner before applying the rule for display."

	mask _ maskForm! !

!Paragraph methodsFor: 'accessing'!
height 
	"Answer the height of the composition rectangle."

	^compositionRectangle height! !

!Paragraph methodsFor: 'accessing'!
indentationOfLineIndex: lineIndex ifBlank: aBlock
	"Answer the number of leading tabs in the line at lineIndex.  If there are
	 no visible characters, pass the number of tabs to aBlock and return its value.
	 If the line is word-wrap overflow, back up a line and recur."

	| arrayIndex first last reader leadingTabs lastSeparator cr tab ch |
	cr _ Character cr.
	tab _ Character tab.
	arrayIndex _ lineIndex.
	[first _ (lines at: arrayIndex) first.
	 first > 1 and: [(text string at: first - 1) ~~ cr]] whileTrue: "word wrap"
		[arrayIndex _ arrayIndex - 1].
	last _ (lines at: lastLine) last.
	reader _ ReadStream on: text string from: first to: last.
	leadingTabs _ 0.
	[reader atEnd not and: [(ch _ reader next) == tab]]
		whileTrue: [leadingTabs _ leadingTabs + 1].
	lastSeparator _ first - 1 + leadingTabs.
	[reader atEnd not and: [ch isSeparator and: [ch ~~ cr]]]
		whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next].
	lastSeparator = last | (ch == cr)
		ifTrue: [^aBlock value: leadingTabs].
	^leadingTabs! !

!Paragraph methodsFor: 'accessing'!
mask 
	"Answer the Form with which each character is combined by the scanner 
	before applying the rule for display."

	^mask! !

!Paragraph methodsFor: 'accessing'!
numberOfLines 
	"Answer the number of lines of text in the receiver."

	^lastLine! !

!Paragraph methodsFor: 'accessing' stamp: 'ar 5/18/2000 18:34'!
replaceFrom: start to: stop with: aText displaying: displayBoolean
	"Replace the receiver's text starting at position start, stopping at stop, by 
	the characters in aText. It is expected that most requirements for 
	modifications to the receiver will call this code. Certainly all cut's or 
	paste's." 

	| compositionScanner obsoleteLines obsoleteLastLine firstLineIndex lastLineIndex
	startLine stopLine replacementRange visibleRectangle startIndex newLine done
	newStop obsoleteY newY moveRectangle |

	text replaceFrom: start to: stop with: aText.		"Update the text."
	lastLine = 0 ifTrue:
		["if lines have never been set up, measure them and display
		all the lines falling in the visibleRectangle"
		self composeAll.
		displayBoolean ifTrue: [^ self displayLines: (1 to: lastLine)]].

	"save -- things get pretty mashed as we go along"
	obsoleteLines _ lines copy.
	obsoleteLastLine _ lastLine.

	"find the starting and stopping lines"
	firstLineIndex _ startLine _ self lineIndexOfCharacterIndex: start.
	stopLine _ self lineIndexOfCharacterIndex: stop.

	"how many characters being inserted or deleted
		-- negative if aText size is < characterInterval size."
	replacementRange _ aText size - (stop - start + 1).
	"Give ourselves plenty of elbow room."
	compositionRectangle _ compositionRectangle withHeight: (textStyle lineGrid * 9999).
	"build a boundingBox of the actual screen space in question -- we'll need it later"
	visibleRectangle _ (clippingRectangle intersect: compositionRectangle)
							intersect: destinationForm boundingBox.
	compositionScanner _ CompositionScanner new forParagraph: self.		"Initialize a scanner."

	"If the starting line is not also the first line, then measuring must commence from line preceding the one in which characterInterval start appears.  For example, deleting a line with only a carriage return may move characters following the deleted portion of text into the line preceding the deleted line."
	startIndex _ (lines at: firstLineIndex) first.
	startLine > 1
		ifTrue: 	[newLine _ compositionScanner composeLine: startLine - 1
						fromCharacterIndex: (lines at: startLine - 1) first
						inParagraph: self.
				(lines at: startLine - 1) = newLine
					ifFalse:	["start in line preceding the one with the starting character"
							startLine _ startLine - 1.
							self lineAt: startLine put: newLine.
							startIndex _ newLine last + 1]].
	startIndex > text size ifTrue:
		["nil lines after a deletion -- remeasure last line below"
		self trimLinesTo: (firstLineIndex - 1 max: 0).
		text size = 0 ifTrue:
			["entire text deleted -- clear visibleRectangle and return."
			displayBoolean ifTrue: [destinationForm fill: visibleRectangle rule: rule fillColor: self backgroundColor].
			self updateCompositionHeight.
			^self]].

	"Now we really get to it."
	done _ false.
	lastLineIndex _ stopLine.
	[done or: [startIndex > text size]]
		whileFalse: 
		[self lineAt: firstLineIndex put:
			(newLine _ compositionScanner composeLine: firstLineIndex
							fromCharacterIndex: startIndex inParagraph: self).
		[(lastLineIndex > obsoleteLastLine
			or: ["no more old lines to compare with?"
				newLine last <
					(newStop _ (obsoleteLines at: lastLineIndex) last + replacementRange)])
			  	or: [done]]
			whileFalse: 
			[newStop = newLine last
				ifTrue:	["got the match"
						"get source and dest y's for moving the unchanged lines"
						obsoleteY _ self topAtLineIndex: lastLineIndex + 1
									using: obsoleteLines and: obsoleteLastLine.
						newY _ self topAtLineIndex: firstLineIndex + 1.
						stopLine _ firstLineIndex.
						done _ true.
							"Fill in the new line vector with the old unchanged lines.
							Update their starting and stopping indices on the way."
						((lastLineIndex _ lastLineIndex + 1) to: obsoleteLastLine) do:
							[:upDatedIndex | 
							self lineAt: (firstLineIndex _ firstLineIndex + 1) 
								put: ((obsoleteLines at: upDatedIndex)
							  		slide: replacementRange)].
							"trim off obsolete lines, if any"
						self trimLinesTo: firstLineIndex]
				ifFalse:	[lastLineIndex _ lastLineIndex + 1]].
		startIndex _ newLine last + 1.
		firstLineIndex _ firstLineIndex + 1].

	"Now the lines are up to date -- Whew!!.  What remains is to move
	the 'unchanged' lines and display those which have changed."
	displayBoolean   "Not much to do if not displaying"
		ifFalse: [^ self updateCompositionHeight].
	startIndex > text size ifTrue:
		["If at the end of previous lines simply display lines from the line in
		which the first character of the replacement occured through the
		end of the paragraph."
		self updateCompositionHeight.
		self displayLines:
			(startLine to: (stopLine _ firstLineIndex min: lastLine)).
		destinationForm  "Clear out area at the bottom"
			fill: ((visibleRectangle left @ (self topAtLineIndex: lastLine + 1)
						extent: visibleRectangle extent)
					intersect: visibleRectangle)
			rule: rule fillColor: self backgroundColor]
		ifFalse:
		[newY ~= obsoleteY ifTrue:
			["Otherwise first move the unchanged lines within
			the visibleRectangle with a good old bitblt."
			moveRectangle _
				visibleRectangle left @ (obsoleteY max: visibleRectangle top)
					corner: visibleRectangle corner.
			destinationForm copyBits: moveRectangle from: destinationForm
				at: moveRectangle origin + (0 @ (newY-obsoleteY))
				clippingBox: visibleRectangle
				rule: Form over fillColor: nil].

		"Then display the altered lines."
		self displayLines: (startLine to: stopLine).

		newY < obsoleteY
			ifTrue:
			[(self topAtLineIndex: obsoleteLastLine+1 using: obsoleteLines and: obsoleteLastLine) > visibleRectangle bottom
				ifTrue:
				["A deletion may have 'pulled' previously undisplayed lines
				into the visibleRectangle.  If so, display them."
				self displayLines:
					((self lineIndexOfTop: visibleRectangle bottom - (obsoleteY - newY))
						to: (self lineIndexOfTop: visibleRectangle bottom))].
			"Clear out obsolete material at the bottom of the visibleRectangle."
			destinationForm
				fill: ((visibleRectangle left @ ((self bottomAtLineIndex: lastLine) + 1)
						extent: visibleRectangle extent)
					intersect: visibleRectangle)  "How about just corner: ??"
				rule: rule fillColor: self backgroundColor].

		(newY > obsoleteY and: [obsoleteY < visibleRectangle top])
			ifTrue:
				["An insertion may have 'pushed' previously undisplayed lines
				into the visibleRectangle.  If so, display them."
				self displayLines:
					((self lineIndexOfTop: visibleRectangle top)
						to: (self lineIndexOfTop: visibleRectangle top + (newY-obsoleteY)))].

		self updateCompositionHeight]! !

!Paragraph methodsFor: 'accessing'!
rule 
	"Answer the rule according to which character display behaves. For 
	example, rule may equal over, under, reverse."

	^rule! !

!Paragraph methodsFor: 'accessing'!
rule: ruleInteger 
	"Set the rule according to which character display behaves."

	rule _ ruleInteger! !

!Paragraph methodsFor: 'accessing' stamp: 'sw 10/29/1999 18:11'!
stringAtLineNumber: aNumber
	(aNumber > lastLine or: [aNumber < 1]) ifTrue: [^ nil].
	^ (text string copyFrom: (lines at: aNumber) first to: (lines at: aNumber) last) copyWithout: Character cr! !

!Paragraph methodsFor: 'accessing'!
text: aText 
	"Set the argument, aText, to be the text for the receiver."

	text _ aText.
	self composeAll! !


!Paragraph methodsFor: 'alignment'!
centered 
	"Set the alignment for the style with which the receiver displays its text 
	so that text is centered in the composition rectangle."

	textStyle alignment: Centered! !

!Paragraph methodsFor: 'alignment'!
justified 
	"Set the alignment for the style with which the receiver displays its text 
	so that the characters in each of text end on an even border in the 
	composition rectangle."

	textStyle alignment: Justified! !

!Paragraph methodsFor: 'alignment'!
leftFlush 
	"Set the alignment for the style with which the receiver displays its text 
	so that the characters in each of text begin on an even border in the 
	composition rectangle. This is also known as ragged-right."

	textStyle alignment: LeftFlush! !

!Paragraph methodsFor: 'alignment'!
rightFlush 
	"Set the alignment for the style with which the receiver displays its text 
	so that the characters in each of text end on an even border in the 
	composition rectangle but the beginning of each line does not. This is 
	also known as ragged-left."

	textStyle alignment: RightFlush! !

!Paragraph methodsFor: 'alignment'!
toggleAlignment 
	"Set the alignment for the style with which the receiver displays its text 
	so that it moves from centered to justified to leftFlush to rightFlush and 
	back to centered again."

	textStyle alignment: textStyle alignment + 1! !


!Paragraph methodsFor: 'character location' stamp: 'ar 5/18/2000 18:33'!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for characters in the text at point aPoint. It is 
	assumed that aPoint has been transformed into coordinates appropriate to 
	the receiver's destinationForm rectangle and the compositionRectangle."

	^CharacterBlockScanner new characterBlockAtPoint: aPoint in: self! !

!Paragraph methodsFor: 'character location' stamp: 'ar 5/18/2000 18:33'!
characterBlockForIndex: targetIndex 
	"Answer a CharacterBlock for character in the text at targetIndex. The 
	coordinates in the CharacterBlock will be appropriate to the intersection 
	of the destinationForm rectangle and the compositionRectangle."

	^CharacterBlockScanner new characterBlockForIndex: targetIndex in: self! !

!Paragraph methodsFor: 'character location' stamp: 'di 10/5/1998 12:59'!
defaultCharacterBlock
	^ CharacterBlock new stringIndex: 1 text: text
			topLeft: compositionRectangle topLeft extent: 0 @ 0! !


!Paragraph methodsFor: 'composition' stamp: 'yo 1/23/2003 22:47'!
composeAll
	"Compose a collection of characters into a collection of lines."

	| startIndex stopIndex lineIndex maximumRightX compositionScanner |
	lines _ Array new: 32.
	lastLine _ 0.
	maximumRightX _ 0.
	text size = 0
		ifTrue:
			[compositionRectangle _ compositionRectangle withHeight: 0.
			^maximumRightX].
	startIndex _ lineIndex _ 1.
	stopIndex _ text size.
	compositionScanner _ MultiCompositionScanner new forParagraph: self.
	[startIndex > stopIndex] whileFalse: 
		[self lineAt: lineIndex 
				put: (compositionScanner composeLine: lineIndex 
										fromCharacterIndex: startIndex 
										inParagraph: self).
		 maximumRightX _ compositionScanner rightX max: maximumRightX.
		 startIndex _ (lines at: lineIndex) last + 1.
		 lineIndex _ lineIndex + 1].
	self updateCompositionHeight.
	self trimLinesTo: lineIndex - 1.
	^ maximumRightX! !

!Paragraph methodsFor: 'composition'!
wrappingBox: compositionRect clippingBox: clippingRect 
	"Set the composition rectangle for the receiver so that the lines wrap 
	within the rectangle, compositionRect, and the display of the text is 
	clipped by the rectangle, clippingRect."

	self compositionRectangle: compositionRect copy
				text: text
				style: textStyle
				offset: offset.
	clippingRectangle _ clippingRect copy! !


!Paragraph methodsFor: 'converting' stamp: 'yo 6/23/2003 19:05'!
asForm
	"Answer a Form made up of the bits that represent the receiver's displayable text."
	| theForm oldBackColor oldForeColor |
	textStyle isTTCStyle ifTrue: [
		theForm _  (Form extent: compositionRectangle extent depth: 32)
		offset: offset.
	] ifFalse: [
		theForm _ (ColorForm extent: compositionRectangle extent)
			offset: offset;
			colors: (Array
				with: (backColor == nil ifTrue: [Color transparent] ifFalse: [backColor])
				with: (foreColor == nil ifTrue: [Color black] ifFalse: [foreColor])).
	].
	oldBackColor _ backColor.
	oldForeColor _ foreColor.
	backColor _ Color white.
	foreColor _ Color black.
	self displayOn: theForm
		at: 0@0
		clippingBox: theForm boundingBox
		rule: Form over
		fillColor: nil.
	backColor _ oldBackColor.
	foreColor _ oldForeColor.
	^ theForm

"Example:
| p |
p _ 'Abc' asParagraph.
p foregroundColor: Color red backgroundColor: Color black.
p asForm displayOn: Display at: 30@30 rule: Form over"
! !

!Paragraph methodsFor: 'converting'!
asString
	"Answer the string of characters of the receiver's text."

	^text string! !

!Paragraph methodsFor: 'converting'!
asText
	"Answer the receiver's text."

	^text! !


!Paragraph methodsFor: 'display box access'!
boundingBox

	^offset extent: compositionRectangle extent! !

!Paragraph methodsFor: 'display box access'!
computeBoundingBox

	^offset extent: compositionRectangle extent! !


!Paragraph methodsFor: 'displaying'!
displayOn: aDisplayMedium
	"Because Paragraphs cache so much information, computation is avoided
	and displayAt: 0@0 is not appropriate here."

	self displayOn: aDisplayMedium
		at: compositionRectangle topLeft
		clippingBox: clippingRectangle
		rule: rule
		fillColor: mask! !

!Paragraph methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint
	"Use internal clippingRect; destination cliping is done during actual display."

	self displayOn: aDisplayMedium at: aPoint
		clippingBox: (clippingRectangle translateBy: aPoint - compositionRectangle topLeft)
		rule: rule fillColor: mask! !

!Paragraph methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"Default display message when aDisplayPoint is in absolute screen
	coordinates."

	rule _ ruleInteger.
	mask _ aForm.
	clippingRectangle _ clipRectangle.
	compositionRectangle _ aDisplayPoint extent: compositionRectangle extent.
	(lastLine == nil or: [lastLine < 1]) ifTrue: [self composeAll].
	self displayOn: aDisplayMedium lines: (1 to: lastLine)! !

!Paragraph methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 

	self				"Assumes offset has been set!!!!!!!!!!"
	  displayOn: aDisplayMedium
	  at: (offset 
			+ (displayTransformation applyTo: relativePoint) 
			- alignmentPoint) rounded
	  clippingBox: clipRectangle
	  rule: ruleInteger
	  fillColor: aForm.
	! !


!Paragraph methodsFor: 'indicating'!
flash 
	"Complement twice the visible area in which the receiver displays."

	Display flash: clippingRectangle! !

!Paragraph methodsFor: 'indicating'!
outline 
	"Display a border around the visible area in which the receiver presents 
	its text."

	clippingRectangle bottom <= compositionRectangle bottom
	  ifTrue: [Display 
				border: (clippingRectangle intersect: compositionRectangle) 
				width: 2]
	  ifFalse: [Display 
				border: (clippingRectangle intersect: destinationForm boundingBox)
				width: 2].
	! !


!Paragraph methodsFor: 'scrolling'!
scrollBy: heightToMove 
	^ self scrollBy: heightToMove withSelectionFrom: nil to: nil! !

!Paragraph methodsFor: 'scrolling' stamp: 'hmm 9/16/2000 21:30'!
scrollBy: heightToMove withSelectionFrom: startBlock to: stopBlock 
	"Translate the composition rectangle up (dy<0) by heightToMove.
	Repainting text as necessary, and selection if blocks not nil.
	Return true unless scrolling limits have been reached."
	| max min amount |
	max _ 0 max: "cant scroll up more than dist to (top of) bottom line"
		compositionRectangle bottom - textStyle lineGrid - clippingRectangle top.
	min _ 0 min: "cant scroll down more than top is above clipRect"
		compositionRectangle top - clippingRectangle top.
	amount _ ((heightToMove truncateTo: textStyle lineGrid) min: max) max: min.
	amount ~= 0
		ifTrue: [destinationForm deferUpdatesIn: clippingRectangle while: [
					self scrollUncheckedBy: amount
						withSelectionFrom: startBlock to: stopBlock].
				^ true]
		ifFalse: [^ false]! !

!Paragraph methodsFor: 'scrolling'!
scrollDelta
	"By comparing this before and after, you know if scrolling happened"
	^ clippingRectangle top - compositionRectangle top! !

!Paragraph methodsFor: 'scrolling'!
scrollUncheckedBy: heightToMove withSelectionFrom: startBlock to: stopBlock 
	"Scroll by the given amount.  Copy bits where possible, display the rest.
	If selection blocks are not nil, then select the newly visible text as well."
	| savedClippingRectangle delta |
	delta _ 0 @ (0 - heightToMove).
	compositionRectangle _ compositionRectangle translateBy: delta.
	startBlock == nil ifFalse:
		[startBlock moveBy: delta.
		stopBlock moveBy: delta].
	savedClippingRectangle _ clippingRectangle.
	clippingRectangle _ clippingRectangle intersect: Display boundingBox.
	heightToMove abs >= clippingRectangle height
	  ifTrue: 
		["Entire visible region must be repainted"
		self displayLines: (1 to: lastLine) affectedRectangle: clippingRectangle]
	  ifFalse:
		["Copy bits where possible / display the rest"
		destinationForm
			copyBits: clippingRectangle from: destinationForm
			at: clippingRectangle topLeft + delta
			clippingBox: clippingRectangle
			rule: Form over fillColor: nil.
		"Set clippingRectangle to 'vacated' area for lines 'pulled' into view."
		clippingRectangle _ heightToMove < 0
			ifTrue:  "On the top"
				[clippingRectangle topLeft corner: clippingRectangle topRight + delta]
			ifFalse:  "At the bottom"
				[clippingRectangle bottomLeft + delta corner: clippingRectangle bottomRight].
		self displayLines: (1 to: lastLine)   "Refresh vacated region"
			affectedRectangle: clippingRectangle].
	startBlock == nil ifFalse:
		[self reverseFrom: startBlock to: stopBlock].
	"And restore the clippingRectangle to its original value. "
	clippingRectangle _ savedClippingRectangle! !


!Paragraph methodsFor: 'selecting' stamp: 'ar 5/28/2000 12:10'!
caretFormForDepth: depth
	"Return a caret form for the given depth."
	"(Paragraph new caretFormForDepth: Display depth) displayOn: Display at: 0@0 rule: Form reverse"

	| box f bb map |
	box _ CaretForm boundingBox.
	f _ Form extent: box extent depth: depth.
	map _ (Color cachedColormapFrom: CaretForm depth to: depth) copy.
	map at: 1 put: (Color transparent pixelValueForDepth: depth).
	map at: 2 put: (Color quickHighLight: depth) first.  "pixel value for reversing"
	bb _ BitBlt current toForm: f.
	bb
		sourceForm: CaretForm;
		sourceRect: box;
		destOrigin: 0@0;
		colorMap: map;
 		combinationRule: Form over;
		copyBits.
	^ f! !

!Paragraph methodsFor: 'selecting' stamp: 'dvf 10/1/2003 13:28'!
clickAt: clickPoint for: model controller: aController
	"Give sensitive text a chance to fire.  Display flash: (100@100 extent: 100@100)."
	| startBlock action range box boxes |
	action _ false.
	startBlock _ self characterBlockAtPoint: clickPoint.
	(text attributesAt: startBlock stringIndex forStyle: textStyle) 
		do: [:att | att mayActOnClick ifTrue:
				[range _ text rangeOf: att startingAt: startBlock stringIndex.
				boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) 
							to: (self characterBlockForIndex: range last+1).
				box _ boxes detect: [:each | each containsPoint: clickPoint]
							ifNone: [^ action].
				Utilities awaitMouseUpIn: box repeating: []
					ifSucceed: [aController terminateAndInitializeAround:
								[(att actOnClickFor: model in: self at: clickPoint editor: aController) ifTrue: [action _ true]]]]].
	^ action! !

!Paragraph methodsFor: 'selecting'!
extendSelectionAt: beginBlock endBlock: endBlock 
	"Answer with an Array of two CharacterBlocks that represent the text 
	selection that the user makes."
	
	(self characterBlockAtPoint: Sensor cursorPoint) <= beginBlock
		ifTrue: [^self mouseMovedFrom: beginBlock 
					pivotBlock: endBlock
					showingCaret: (beginBlock = endBlock)]
		ifFalse: [^self mouseMovedFrom: endBlock 
					pivotBlock: beginBlock
					showingCaret: (beginBlock = endBlock)]
! !

!Paragraph methodsFor: 'selecting' stamp: 'th 9/19/2002 17:27'!
extendSelectionMark: markBlock pointBlock: pointBlock 
	"Answer with an Array of two CharacterBlocks that represent the text 
	selection that the user makes."
	true 
		ifTrue:[^self mouseMovedFrom: pointBlock
					pivotBlock: markBlock
					showingCaret:(pointBlock = markBlock)]
		ifFalse:
		[	| beginBlock endBlock |
			beginBlock _ markBlock min: pointBlock.
			endBlock _ markBlock max: endBlock.
	
			(self characterBlockAtPoint: Sensor cursorPoint) <= beginBlock
				ifTrue: [^self mouseMovedFrom: beginBlock 
							pivotBlock: endBlock
							showingCaret: (beginBlock = endBlock)]
				ifFalse: [^self mouseMovedFrom: endBlock 
							pivotBlock: beginBlock
							showingCaret: (beginBlock = endBlock)]
		]
! !

!Paragraph methodsFor: 'selecting' stamp: 'jm 7/1/1999 12:31'!
hiliteRect: rect

	| highlightColor |
	highlightColor _ Color quickHighLight: destinationForm depth.
	rect ifNotNil: [
		destinationForm
			fill: rect
			rule: Form reverse
			fillColor: highlightColor.
		"destinationForm
			fill: (rect translateBy: 1@1)
			rule: Form reverse
			fillColor: highlightColor" ].
! !

!Paragraph methodsFor: 'selecting' stamp: 'jm 7/8/97 12:25'!
mouseMovedFrom: beginBlock pivotBlock: pivotBlock showingCaret: caretOn 
	| startBlock stopBlock showingCaret |
	stopBlock _ startBlock _ beginBlock.
	showingCaret _ caretOn.
	[Sensor redButtonPressed]
		whileTrue: 
			[stopBlock _ self characterBlockAtPoint: Sensor cursorPoint.
			stopBlock = startBlock
				ifFalse: 
					[showingCaret
						ifTrue: 
							[showingCaret _ false.
							self reverseFrom: pivotBlock to: pivotBlock].
			((startBlock >= pivotBlock and: [stopBlock >= pivotBlock])
				or: [startBlock <= pivotBlock and: [stopBlock <= pivotBlock]])
				ifTrue: 
					[self reverseFrom: startBlock to: stopBlock.
					startBlock _ stopBlock]
				ifFalse: 
					[self reverseFrom: startBlock to: pivotBlock.
					self reverseFrom: pivotBlock to: stopBlock.
					startBlock _ stopBlock].
			(clippingRectangle containsRect: stopBlock) ifFalse:
				[stopBlock top < clippingRectangle top
				ifTrue: [self scrollBy: stopBlock top - clippingRectangle top
						withSelectionFrom: pivotBlock to: stopBlock]
				ifFalse: [self scrollBy: stopBlock bottom + textStyle lineGrid - clippingRectangle bottom
						withSelectionFrom: pivotBlock to: stopBlock]]]].
	pivotBlock = stopBlock ifTrue:
		[showingCaret ifFalse:  "restore caret"
			[self reverseFrom: pivotBlock to: pivotBlock]].
	^ Array with: pivotBlock with: stopBlock! !

!Paragraph methodsFor: 'selecting'!
mouseSelect
	"Answer with an Array of two CharacterBlocks that represent the text 
	selection that the user makes.  Return quickly if the button is noticed up
	to make double-click more responsive."

	| pivotBlock startBlock stopBlock origPoint stillDown |
	stillDown _ Sensor redButtonPressed.
	pivotBlock _ startBlock _ stopBlock _
		self characterBlockAtPoint: (origPoint _ Sensor cursorPoint).
	stillDown _ stillDown and: [Sensor redButtonPressed].
	self reverseFrom: startBlock to: startBlock.
	[stillDown and: [Sensor cursorPoint = origPoint]] whileTrue:
		[stillDown _ Sensor redButtonPressed].
	(stillDown and: [clippingRectangle containsPoint: Sensor cursorPoint])
		ifFalse: [^Array with: pivotBlock with: stopBlock].
	^ self mouseMovedFrom: startBlock 
		pivotBlock: pivotBlock
		showingCaret: true! !

!Paragraph methodsFor: 'selecting'!
mouseSelect: clickPoint 
	"Track text selection and answer with an Array of two CharacterBlocks."
	| startBlock |
	startBlock _ self characterBlockAtPoint: clickPoint.
	self reverseFrom: startBlock to: startBlock.
	^ self mouseMovedFrom: startBlock 
		pivotBlock: startBlock
		showingCaret: true! !

!Paragraph methodsFor: 'selecting'!
reverseFrom: characterBlock1 to: characterBlock2 
	"Reverse area between the two character blocks given as arguments."
	| visibleRectangle initialRectangle interiorRectangle finalRectangle lineNo baseline caret |
	characterBlock1 = characterBlock2 ifTrue:
		[lineNo _ self lineIndexOfCharacterIndex: characterBlock1 stringIndex.
		baseline _ lineNo = 0 ifTrue: [textStyle baseline]
							ifFalse: [(lines at: lineNo) baseline].
		caret _ self caretFormForDepth: Display depth.
		^ caret  "Use a caret to indicate null selection"
				displayOn: destinationForm
				at: characterBlock1 topLeft + (-3 @ baseline)
				clippingBox: clippingRectangle
				rule: (false "Display depth>8" ifTrue: [9 "not-reverse"]
									ifFalse: [Form reverse])
				fillColor: nil].
	visibleRectangle _ 
		(clippingRectangle intersect: compositionRectangle)
			"intersect: destinationForm boundingBox" "not necessary".
	characterBlock1 top = characterBlock2 top
		ifTrue: [characterBlock1 left < characterBlock2 left
					ifTrue: 
						[initialRectangle _ 
							(characterBlock1 topLeft corner: characterBlock2 bottomLeft)
								intersect: visibleRectangle]
					ifFalse: 
						[initialRectangle _ 
							(characterBlock2 topLeft corner: characterBlock1 bottomLeft)
								intersect: visibleRectangle]]
		ifFalse: [characterBlock1 top < characterBlock2 top
					ifTrue: 
						[initialRectangle _ 
							(characterBlock1 topLeft 
								corner: visibleRectangle right @ characterBlock1 bottom)
								intersect: visibleRectangle.
						characterBlock1 bottom = characterBlock2 top
							ifTrue: 
								[finalRectangle _ 
									(visibleRectangle left @ characterBlock2 top 
										corner: characterBlock2 bottomLeft)
										intersect: visibleRectangle]
							ifFalse: 
								[interiorRectangle _ 
									(visibleRectangle left @ characterBlock1 bottom
										corner: visibleRectangle right 
														@ characterBlock2 top)
										intersect: visibleRectangle.
								finalRectangle _ 
									(visibleRectangle left @ characterBlock2 top 
										corner: characterBlock2 bottomLeft)
										intersect: visibleRectangle]]
				ifFalse: 
					[initialRectangle _ 
						(visibleRectangle left @ characterBlock1 top 
							corner: characterBlock1 bottomLeft)
							intersect: visibleRectangle.
					characterBlock1 top = characterBlock2 bottom
						ifTrue: 
							[finalRectangle _ 
								(characterBlock2 topLeft 
									corner: visibleRectangle right 
												@ characterBlock2 bottom)
									intersect: visibleRectangle]
						ifFalse: 
							[interiorRectangle _ 
								(visibleRectangle left @ characterBlock2 bottom 
									corner: visibleRectangle right @ characterBlock1 top)
									intersect: visibleRectangle.
							finalRectangle _ 
								(characterBlock2 topLeft 
									corner: visibleRectangle right 
												@ characterBlock2 bottom)
									intersect: visibleRectangle]]].
	self hiliteRect: initialRectangle.
	self hiliteRect: interiorRectangle.
	self hiliteRect: finalRectangle.! !

!Paragraph methodsFor: 'selecting' stamp: 'di 12/1/97 04:43'!
selectionRectsFrom: characterBlock1 to: characterBlock2 
	"Return an array of rectangles representing the area between the two character blocks given as arguments."
	| visibleRectangle initialRectangle interiorRectangle finalRectangle lineNo baseline |
	characterBlock1 = characterBlock2 ifTrue:
		[lineNo _ self lineIndexOfCharacterIndex: characterBlock1 stringIndex.
		baseline _ lineNo = 0 ifTrue: [textStyle baseline]
							ifFalse: [(lines at: lineNo) baseline].
		^ Array with: (characterBlock1 topLeft extent: 1 @ baseline)].
	visibleRectangle _ clippingRectangle intersect: compositionRectangle.
	characterBlock1 top = characterBlock2 top
		ifTrue: [characterBlock1 left < characterBlock2 left
					ifTrue: 
						[initialRectangle _ 
							(characterBlock1 topLeft corner: characterBlock2 bottomLeft)
								intersect: visibleRectangle]
					ifFalse: 
						[initialRectangle _ 
							(characterBlock2 topLeft corner: characterBlock1 bottomLeft)
								intersect: visibleRectangle]]
		ifFalse: [characterBlock1 top < characterBlock2 top
					ifTrue: 
						[initialRectangle _ 
							(characterBlock1 topLeft 
								corner: visibleRectangle right @ characterBlock1 bottom)
								intersect: visibleRectangle.
						characterBlock1 bottom = characterBlock2 top
							ifTrue: 
								[finalRectangle _ 
									(visibleRectangle left @ characterBlock2 top 
										corner: characterBlock2 bottomLeft)
										intersect: visibleRectangle]
							ifFalse: 
								[interiorRectangle _ 
									(visibleRectangle left @ characterBlock1 bottom
										corner: visibleRectangle right 
														@ characterBlock2 top)
										intersect: visibleRectangle.
								finalRectangle _ 
									(visibleRectangle left @ characterBlock2 top 
										corner: characterBlock2 bottomLeft)
										intersect: visibleRectangle]]
				ifFalse: 
					[initialRectangle _ 
						(visibleRectangle left @ characterBlock1 top 
							corner: characterBlock1 bottomLeft)
							intersect: visibleRectangle.
					characterBlock1 top = characterBlock2 bottom
						ifTrue: 
							[finalRectangle _ 
								(characterBlock2 topLeft 
									corner: visibleRectangle right 
												@ characterBlock2 bottom)
									intersect: visibleRectangle]
						ifFalse: 
							[interiorRectangle _ 
								(visibleRectangle left @ characterBlock2 bottom 
									corner: visibleRectangle right @ characterBlock1 top)
									intersect: visibleRectangle.
							finalRectangle _ 
								(characterBlock2 topLeft 
									corner: visibleRectangle right 
												@ characterBlock2 bottom)
									intersect: visibleRectangle]]].
	^ (Array with: initialRectangle with: interiorRectangle with: finalRectangle)
			select: [:rect | rect notNil]! !


!Paragraph methodsFor: 'utilities'!
clearVisibleRectangle 
	"Display the area in which the receiver presents its text so that the area 
	is all one tone--in this case, all white."

	destinationForm
	  fill: clippingRectangle
	  rule: rule
	  fillColor: self backgroundColor! !

!Paragraph methodsFor: 'utilities'!
deepCopy
	"Don't want to copy the destForm (Display) or fonts in the TextStyle.  9/13/96 tk"

	| new |
	new _ self copy.
	new textStyle: textStyle copy.
	new destinationForm: destinationForm.
	new lines: lines copy.
	new text: text deepCopy.
	^ new! !

!Paragraph methodsFor: 'utilities'!
destinationForm: destForm
	destinationForm _ destForm! !

!Paragraph methodsFor: 'utilities'!
fit
	"Make the bounding rectangle of the receiver contain all the text without 
	changing the width of the receiver's composition rectangle."

	[(self lineIndexOfTop: clippingRectangle top) = 1]
		whileFalse: [self scrollBy: (0-1)*textStyle lineGrid].
	self updateCompositionHeight.
	clippingRectangle _ clippingRectangle withBottom: compositionRectangle bottom! !

!Paragraph methodsFor: 'utilities'!
lines: lineArray
	lines _ lineArray! !

!Paragraph methodsFor: 'utilities'!
visibleRectangle 
	"May be less than the clippingRectangle if text ends part way down.
	Also some fearful history includes Display intersection;
	it shouldn't be necessary"

	^ (clippingRectangle intersect: compositionRectangle)
		intersect: destinationForm boundingBox! !


!Paragraph methodsFor: 'private'!
bottomAtLineIndex: lineIndex 
	"Answer the bottom y of given line."
	| y |
	y _ compositionRectangle top.
	lastLine = 0 ifTrue: [^ y + textStyle lineGrid].
	1 to: (lineIndex min: lastLine) do:
		[:i | y _ y + (lines at: i) lineHeight].
	^ y
! !

!Paragraph methodsFor: 'private' stamp: 'tk 9/30/96'!
compositionRectangle: compositionRect text: aText style: aTextStyle offset: aPoint

	compositionRectangle _ compositionRect copy.
	text _ aText.
	textStyle _ aTextStyle.
	rule _ DefaultRule.
	mask _ nil.		"was DefaultMask "
	marginTabsLevel _ 0.
	destinationForm _ Display.
	offset _ aPoint.
	^self composeAll! !

!Paragraph methodsFor: 'private'!
compositionRectangleDelta
	"A handy number -- mostly for scrolling."

	^compositionRectangle top - clippingRectangle top! !

!Paragraph methodsFor: 'private'!
displayLines: linesInterval 
	^ self displayLines: linesInterval
		affectedRectangle: self visibleRectangle! !

!Paragraph methodsFor: 'private' stamp: 'yo 1/23/2003 22:48'!
displayLines: linesInterval affectedRectangle: affectedRectangle
	"This is the first level workhorse in the display portion of the TextForm routines.
	It checks to see which lines in the interval are actually visible, has the
	CharacterScanner display only those, clears out the areas in which display will
	occur, and clears any space remaining in the visibleRectangle following the space
	occupied by lastLine."

	| lineGrid topY firstLineIndex lastLineIndex lastLineIndexBottom |

	"Save some time by only displaying visible lines"
	firstLineIndex _ self lineIndexOfTop: affectedRectangle top.
	firstLineIndex < linesInterval first ifTrue: [firstLineIndex _ linesInterval first].
	lastLineIndex _ self lineIndexOfTop: affectedRectangle bottom - 1.
	lastLineIndex > linesInterval last ifTrue:
			[linesInterval last > lastLine
		 		ifTrue: [lastLineIndex _ lastLine]
		  		ifFalse: [lastLineIndex _ linesInterval last]].
	lastLineIndexBottom _ (self bottomAtLineIndex: lastLineIndex).
	((Rectangle 
		origin: affectedRectangle left @ (topY _ self topAtLineIndex: firstLineIndex) 
		corner: affectedRectangle right @ lastLineIndexBottom)
	  intersects: affectedRectangle)
		ifTrue: [ " . . . (skip to clear-below if no lines displayed)"
				MultiDisplayScanner new
					displayLines: (firstLineIndex to: lastLineIndex)
					in: self clippedBy: affectedRectangle].
	lastLineIndex = lastLine ifTrue: 
		 [destinationForm  "Clear out white space below last line"
		 	fill: (affectedRectangle left @ (lastLineIndexBottom max: affectedRectangle top)
				corner: affectedRectangle bottomRight)
		 	rule: rule fillColor: self backgroundColor]! !

!Paragraph methodsFor: 'private'!
displayOn: aDisplayMedium lines: lineInterval

	| saveDestinationForm |
	saveDestinationForm _ destinationForm.
	destinationForm _ aDisplayMedium.
	self displayLines: lineInterval.
	destinationForm _ saveDestinationForm! !

!Paragraph methodsFor: 'private'!
leftMarginForCompositionForLine: lineIndex 
	"Build the left margin for composition of a line. Depends upon
	marginTabsLevel and the indent."

	| indent |
	lineIndex = 1
		ifTrue: [indent _ textStyle firstIndent]
		ifFalse: [indent _ textStyle restIndent].
	^indent + (textStyle leftMarginTabAt: marginTabsLevel)! !

!Paragraph methodsFor: 'private' stamp: 'ar 12/15/2001 23:29'!
leftMarginForDisplayForLine: lineIndex alignment: alignment
	"Build the left margin for display of a line. Depends upon
	leftMarginForComposition, compositionRectangle left and the alignment."

	| pad |
	(alignment = LeftFlush or: [alignment = Justified])
		ifTrue: 
			[^compositionRectangle left 
				+ (self leftMarginForCompositionForLine: lineIndex)].
	"When called from character location code and entire string has been cut,
	there are no valid lines, hence following nil check."
	(lineIndex <= lines size and: [(lines at: lineIndex) notNil])
		ifTrue: 
			[pad _ (lines at: lineIndex) paddingWidth]
		ifFalse: 
			[pad _ 
				compositionRectangle width - textStyle firstIndent - textStyle rightIndent].
	alignment = Centered 
		ifTrue: 
			[^compositionRectangle left 
				+ (self leftMarginForCompositionForLine: lineIndex) + (pad // 2)].
	alignment = RightFlush 
		ifTrue:
			[^compositionRectangle left 
				+ (self leftMarginForCompositionForLine: lineIndex) + pad].
	self error: ['no such alignment']! !

!Paragraph methodsFor: 'private'!
lineAt: indexInteger put: aTextLineInterval 
	"Store a line, track last, and grow lines if necessary."
	indexInteger > lastLine ifTrue: [lastLine _ indexInteger].
	lastLine > lines size ifTrue: [lines _ lines , (Array new: lines size)].
	^lines at: indexInteger put: aTextLineInterval! !

!Paragraph methodsFor: 'private'!
lineIndexOfCharacterIndex: characterIndex 
	"Answer the line index for a given characterIndex."

	1 to: lastLine do: 
		[:lineIndex | 
		(lines at: lineIndex) last >= characterIndex ifTrue: [^lineIndex]].
	^lastLine! !

!Paragraph methodsFor: 'private'!
lineIndexOfTop: top 
	"Answer the line index at a given top y."
	| y line |
	lastLine = 0 ifTrue: [^ 1].
	y _ compositionRectangle top.
	1 to: lastLine do:
		[:i | line _ lines at: i.
		(y _ y + line lineHeight) > top ifTrue: [^ i]].
	^ lastLine
! !

!Paragraph methodsFor: 'private'!
lines

	^lines! !

!Paragraph methodsFor: 'private'!
moveBy: delta
	compositionRectangle _ compositionRectangle translateBy: delta.
	clippingRectangle _ clippingRectangle translateBy: delta.
! !

!Paragraph methodsFor: 'private'!
rightMarginForComposition
	"Build the right margin for a line. Depends upon compositionRectangle
	width, marginTabsLevel, and right indent."

	^compositionRectangle width 
		- (textStyle rightMarginTabAt: marginTabsLevel) 
		- textStyle rightIndent! !

!Paragraph methodsFor: 'private'!
rightMarginForDisplay 
	"Build the right margin for a line. Depends upon compositionRectangle
	rightSide, marginTabsLevel, and right indent."

	^compositionRectangle right - 
		textStyle rightIndent - (textStyle rightMarginTabAt: marginTabsLevel)! !

!Paragraph methodsFor: 'private'!
setWithText: aText style: aTextStyle 
	"Set text and adjust bounding rectangles to fit."

	| shrink compositionWidth unbounded |
	unbounded _ Rectangle origin: 0 @ 0 extent: 9999@9999.
	compositionWidth _ self
		setWithText: aText style: aTextStyle compositionRectangle: unbounded clippingRectangle: unbounded.
	compositionRectangle _ compositionRectangle withWidth: compositionWidth.
	clippingRectangle _ compositionRectangle copy.
	shrink _ unbounded width - compositionWidth.
	"Shrink padding widths accordingly"
	1 to: lastLine do:
		[:i | (lines at: i) paddingWidth: (lines at: i) paddingWidth - shrink]! !

!Paragraph methodsFor: 'private'!
setWithText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect 
	"Set text and using supplied parameters. Answer max composition width."

	clippingRectangle _ clipRect copy.
	^self
		compositionRectangle: compRect
		text: aText
		style: aTextStyle
		offset: 0 @ 0! !

!Paragraph methodsFor: 'private'!
setWithText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect foreColor: cf backColor: cb
	"Set text and using supplied parameters. Answer max composition width."

	clippingRectangle _ clipRect copy.
	self foregroundColor: cf backgroundColor: cb.
	^ self
		compositionRectangle: compRect
		text: aText
		style: aTextStyle
		offset: 0 @ 0! !

!Paragraph methodsFor: 'private'!
topAtLineIndex: lineIndex 
	"Answer the top y of given line."
	| y |
	y _ compositionRectangle top.
	lastLine = 0 ifTrue: [lineIndex > 0 ifTrue: [^ y + textStyle lineGrid]. ^ y].
	1 to: (lineIndex-1 min: lastLine) do:
		[:i | y _ y + (lines at: i) lineHeight].
	^ y
! !

!Paragraph methodsFor: 'private'!
topAtLineIndex: lineIndex using: otherLines and: otherLastLine
	"Answer the top y of given line."
	| y |
	y _ compositionRectangle top.
	otherLastLine = 0 ifTrue: [^ y].
	1 to: (lineIndex-1 min: otherLastLine) do:
		[:i | y _ y + (otherLines at: i) lineHeight].
	^ y
! !

!Paragraph methodsFor: 'private'!
trimLinesTo: lastLineInteger

	(lastLineInteger + 1 to: lastLine) do: [:i | lines at: i put: nil].
	(lastLine _ lastLineInteger) < (lines size // 2) 
		ifTrue: [lines _ lines copyFrom: 1 to: lines size - (lines size // 2)]! !

!Paragraph methodsFor: 'private'!
updateCompositionHeight
	"Mainly used to insure that intersections with compositionRectangle work." 

	compositionRectangle _ compositionRectangle withHeight:
		(self bottomAtLineIndex: lastLine) - compositionRectangle top.
	(text size ~= 0 and: [(text at: text size) = CR])
		ifTrue: [compositionRectangle _ compositionRectangle withHeight:
					compositionRectangle height + (lines at: lastLine) lineHeight]! !

!Paragraph methodsFor: 'private' stamp: 'di 8/30/97 11:14'!
withClippingRectangle: clipRect do: aBlock
	| saveClip |
	saveClip _ clippingRectangle.
	clippingRectangle _ clipRect.
		aBlock value.
	clippingRectangle _ saveClip! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Paragraph class
	instanceVariableNames: ''!

!Paragraph class methodsFor: 'examples' stamp: 'tk 9/30/96'!
example
	"This simple example illustrates how to display a few lines of text on the screen at the current cursor point.  
	Fixed. "

	| para point |
	point _ Sensor waitButton.
	para _ 'This is the first line of characters
and this is the second line.' asParagraph.
	para displayOn: Display at: point.

	"Paragraph example"! !


!Paragraph class methodsFor: 'instance creation'!
new
	"Do not allow an uninitialized view. Create with text that has no
	characters."

	^self withText: '' asText! !

!Paragraph class methodsFor: 'instance creation'!
withText: aText 
	"Answer an instance of me with text set to aText and style set to the 
	system's default text style."

	^self withText: aText style: DefaultTextStyle copy! !

!Paragraph class methodsFor: 'instance creation'!
withText: aText style: aTextStyle 
	"Answer an instance of me with text set to aText and style set to 
	aTextStyle."

	^super new setWithText: aText style: aTextStyle! !

!Paragraph class methodsFor: 'instance creation'!
withText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect foreColor: c1 backColor: c2
	"Answer an instance of me with text set to aText and style set to 
	aTextStyle, composition rectangle is compRect and the clipping rectangle 
	is clipRect."
	| para |
	para _ super new.
	para setWithText: aText
		style: aTextStyle
		compositionRectangle: compRect
		clippingRectangle: clipRect
		foreColor: c1 backColor: c2.
	^para! !
ScrollController subclass: #ParagraphEditor
	instanceVariableNames: 'paragraph startBlock stopBlock beginTypeInBlock emphasisHere initialText selectionShowing otherInterval lastParentLocation'
	classVariableNames: 'ChangeText CmdActions FindText Keyboard ShiftCmdActions UndoInterval UndoMessage UndoParagraph UndoSelection Undone'
	poolDictionaries: 'TextConstants'
	category: 'Kernel-ST80 Remnants'!
!ParagraphEditor commentStamp: '<historical>' prior: 0!
I am a Controller for editing a Paragraph. I am a kind of ScrollController, so that more text can be created for the Paragraph than can be viewed on the screen. Editing messages are sent by issuing commands from a yellow button menu or from keys on the keyboard. My instances keep control as long as the cursor is within the view when the red or yellow mouse button is pressed; they give up control if the blue button is pressed.!


!ParagraphEditor methodsFor: 'accessing' stamp: 'tk 4/21/1998 09:55'!
initialText
	^ initialText! !

!ParagraphEditor methodsFor: 'accessing'!
replace: oldInterval with: newText and: selectingBlock 
	"Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection.  Create an undoAndReselect:redoAndReselect: undoer to allow perfect undoing."

	| undoInterval |
	undoInterval _ self selectionInterval.
	undoInterval = oldInterval ifFalse: [self selectInterval: oldInterval].
	UndoSelection _ self selection.
	self zapSelectionWith: newText.
	selectingBlock value.
	otherInterval _ self selectionInterval.
	self undoer: #undoAndReselect:redoAndReselect: with: undoInterval with: otherInterval! !

!ParagraphEditor methodsFor: 'accessing'!
replaceSelectionWith: aText
	"Remember the selection text in UndoSelection.
	 Deselect, and replace the selection text by aText.
	 Remember the resulting selectionInterval in UndoInterval and PriorInterval.
	 Set up undo to use UndoReplace."

	beginTypeInBlock ~~ nil ifTrue: [^self zapSelectionWith: aText]. "called from old code"
	UndoSelection _ self selection.
	self zapSelectionWith: aText.
	self undoer: #undoReplace! !

!ParagraphEditor methodsFor: 'accessing'!
setSearch: aString
	"Set the FindText and ChangeText to seek aString; except if already seeking aString, leave ChangeText alone so again will repeat last replacement."

	FindText string = aString
		ifFalse: [FindText _ ChangeText _ aString asText]! !

!ParagraphEditor methodsFor: 'accessing'!
text
	"Answer the text of the paragraph being edited."

	^paragraph text! !

!ParagraphEditor methodsFor: 'accessing' stamp: 'jm 3/18/98 20:38'!
userHasEdited
	"Note that the user has edited my text. Here it is just a noop so that the Character Recognizer won't fail when used with a vanilla ParagrahEditor."
! !


!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:22'!
hasCaret
	^self markBlock = self pointBlock! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:22'!
hasSelection
	^self hasCaret not! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:13'!
mark
	^ self markBlock stringIndex! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'!
markBlock
	^ stopBlock! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'!
markBlock: aCharacterBlock
	stopBlock _ aCharacterBlock.
! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 12:31'!
markIndex
	^ self markBlock stringIndex! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'!
pointBlock
	^ startBlock! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'!
pointBlock: aCharacterBlock
	startBlock _ aCharacterBlock.
! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 12:31'!
pointIndex
	^ self pointBlock stringIndex! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'yo 7/31/2004 16:27'!
selection
	"Answer the text in the paragraph that is currently selected."

	| t |
	t _ paragraph text copyFrom: self startIndex to: self stopIndex - 1.
	t string isOctetString ifTrue: [t asOctetStringText].
	^ t.
! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:10'!
selectionAsStream
	"Answer a ReadStream on the text in the paragraph that is currently 
	selected."

	^ReadWriteStream
		on: paragraph string
		from: self startIndex
		to: self stopIndex - 1! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 16:18'!
selectionInterval
	"Answer the interval that is currently selected."

	^self startIndex to: self stopIndex - 1 ! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:02'!
setMark: anIndex
	self markBlock: (paragraph characterBlockForIndex: anIndex)
! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:02'!
setPoint: anIndex
	self pointBlock: (paragraph characterBlockForIndex: anIndex)
! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:10'!
startBlock
	^ self pointBlock min: self markBlock! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:10'!
startBlock: aCharacterBlock
	self markBlock: aCharacterBlock! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 14:27'!
startIndex
	^ self startBlock stringIndex! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:14'!
stopBlock
	^ self pointBlock max: self markBlock! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:10'!
stopBlock: aCharacterBlock
	self pointBlock: aCharacterBlock! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 14:27'!
stopIndex
	^ self stopBlock stringIndex! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:23'!
unselect
	self markBlock: self pointBlock copy.! !

!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:12'!
zapSelectionWith: aText
	"Deselect, and replace the selection text by aText.
	 Remember the resulting selectionInterval in UndoInterval and otherInterval.
	 Do not set up for undo."

	| start stop |
	self deselect.
	start _ self startIndex.
	stop _ self stopIndex.
	(aText isEmpty and: [stop > start]) ifTrue:
		["If deleting, then set emphasisHere from 1st character of the deletion"
		emphasisHere _ (paragraph text attributesAt: start forStyle: paragraph textStyle)
					select: [:att | att mayBeExtended]].
	(start = stop and: [aText size = 0]) ifFalse:
		[paragraph
			replaceFrom: start
			to: stop - 1
			with: aText
			displaying: true.
		self computeIntervalFrom: start to: start + aText size - 1.
		UndoInterval _ otherInterval _ self selectionInterval]! !


!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'dvf 7/28/2003 14:54'!
activateTextActions
	(paragraph text attributesAt: startBlock stringIndex) 
		do: [:att | att actOnClickFor: model in: paragraph]! !

!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'BG 6/1/2003 09:43'!
offerMenuFromEsc: aStream
   sensor keyboard. " consume the character "
   self yellowButtonActivity.
  ^true "tell the caller that the character was processed "! !

!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:40'!
totalTextHeight

	^paragraph boundingBox height! !

!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:33'!
visibleHeight

	^paragraph clippingRectangle height! !


!ParagraphEditor methodsFor: 'controlling'!
controlInitialize

	super controlInitialize.
	self recomputeInterval.
	self initializeSelection.
	beginTypeInBlock _ nil! !

!ParagraphEditor methodsFor: 'controlling'!
controlTerminate

	self closeTypeIn.  "Must call to establish UndoInterval"
	super controlTerminate.
	self deselect! !

!ParagraphEditor methodsFor: 'controlling' stamp: 'sma 3/11/2000 15:17'!
normalActivity
	self processKeyboard.
	self processMouseButtons! !


!ParagraphEditor methodsFor: 'current selection'!
deselect
	"If the text selection is visible on the screen, reverse its highlight."

	selectionShowing ifTrue: [self reverseSelection]! !

!ParagraphEditor methodsFor: 'current selection'!
initializeSelection
	"Do the initial activity when starting up the receiver. For example, in the 
	ParagraphEditor highlight the current selection."

	self select! !

!ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/20/2002 11:41'!
recomputeInterval
	"The same characters are selected but their coordinates may have changed."

	self computeIntervalFrom: self mark to: self pointIndex - 1! !

!ParagraphEditor methodsFor: 'current selection'!
recomputeSelection
	"Redetermine the selection according to the start and stop block indices; 
	do not highlight."

	self deselect; recomputeInterval! !

!ParagraphEditor methodsFor: 'current selection' stamp: 'BG 12/12/2003 12:50'!
reverseSelection
	"Reverse the valence of the current selection highlighting."
	selectionShowing _ selectionShowing not.
	paragraph reverseFrom: self pointBlock to: self markBlock! !

!ParagraphEditor methodsFor: 'current selection'!
select
	"If the text selection is visible on the screen, highlight it."

	selectionShowing ifFalse: [self reverseSelection]! !

!ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/19/2002 18:47'!
selectAndScroll
	"Scroll until the selection is in the view and then highlight it."
	| lineHeight deltaY clippingRectangle endBlock |
	self select.
	endBlock _ self stopBlock.
	lineHeight _ paragraph textStyle lineGrid.
	clippingRectangle _ paragraph clippingRectangle.
	deltaY _ endBlock top - clippingRectangle top.
	deltaY >= 0 
		ifTrue: [deltaY _ endBlock bottom - clippingRectangle bottom max: 0].
						"check if stopIndex below bottom of clippingRectangle"
	deltaY ~= 0 
		ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight)
									* deltaY sign]! !

!ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/19/2002 18:48'!
selectAndScrollToTop
	"Scroll until the selection is in the view and then highlight it."
	| lineHeight deltaY clippingRectangle |
	self select.
	lineHeight _ paragraph textStyle lineGrid.
	clippingRectangle _ paragraph clippingRectangle.
	deltaY _ self stopBlock top - clippingRectangle top.
	deltaY ~= 0 
		ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight)
									* deltaY sign]! !


!ParagraphEditor methodsFor: 'displaying'!
display
	"Redisplay the paragraph."

	| selectionState |
	selectionState _ selectionShowing.
	self deselect.
	paragraph foregroundColor: view foregroundColor
			backgroundColor: view backgroundColor;
			displayOn: Display.
	selectionState ifTrue: [self select]! !

!ParagraphEditor methodsFor: 'displaying'!
flash
	"Causes the view of the paragraph to complement twice in succession."

	paragraph flash! !


!ParagraphEditor methodsFor: 'do-its' stamp: 'md 2/13/2006 14:36'!
compileSelectionFor: anObject in: evalContext

	| methodNode method |
	methodNode _ [Compiler new
		compileNoPattern: self selectionAsStream
		in: anObject class
		context: evalContext
		notifying: self
		ifFail: [^nil]]
			on: OutOfScopeNotification
			do: [:ex | ex resume: true].
	method _ methodNode generate.
	^method copyWithTempNames: methodNode tempNames! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'di 5/10/1998 21:38'!
doIt
	"Set the context to include pool vars of the model.  Then evaluate."
	^ self evaluateSelection.
! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'gk 3/3/2004 17:15'!
evaluateSelection
	"Treat the current selection as an expression; evaluate it and return the result"
	| result rcvr ctxt |
	self lineSelectAndEmptyCheck: [^ ''].

	(model respondsTo: #doItReceiver) 
		ifTrue: [FakeClassPool adopt: model selectedClass.  "Include model pool vars if any"
				rcvr _ model doItReceiver.
				ctxt _ model doItContext]
		ifFalse: [rcvr _ ctxt _ nil].
	result _ [
		rcvr class evaluatorClass new 
			evaluate: self selectionAsStream
			in: ctxt
			to: rcvr
			notifying: self
			ifFail: [FakeClassPool adopt: nil. ^ #failedDoit]
			logged: true.
	] 
		on: OutOfScopeNotification 
		do: [ :ex | ex resume: true].
	FakeClassPool adopt: nil.
	^ result! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'acg 12/7/1999 07:53'!
exploreIt
	| result |
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [view flash]
			ifFalse: [result explore].
! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'di 9/7/1999 11:25'!
inspectIt
	"1/13/96 sw: minor fixup"
	| result |
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [view flash]
			ifFalse: [result inspect].
! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'sd 4/16/2003 11:41'!
objectsReferencingIt
	"Open a list inspector on all objects that reference the object that results when the current selection is evaluated.  "
	| result |
	self terminateAndInitializeAround: [
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or: [result == #failedDoit])
		ifTrue: [view flash]
		ifFalse: [self systemNavigation
					browseAllObjectReferencesTo: result
					except: #()
					ifNone: [:obj | view topView flash]].
	]! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'di 5/10/1998 21:52'!
printIt
	"Treat the current text selection as an expression; evaluate it. Insert the 
	description of the result of evaluation after the selection and then make 
	this description the new text selection."
	| result |
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [view flash]
			ifFalse: [self afterSelectionInsertAndSelect: result printString]! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'ab 3/23/2005 16:49'!
tallyIt

	^ self tallySelection! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'ab 3/23/2005 16:49'!
tallySelection
	"Treat the current selection as an expression; evaluate it and return the time took for this evaluation"
	| result rcvr ctxt cm v valueAsString |
	self lineSelectAndEmptyCheck: [^ -1].

	(model respondsTo: #doItReceiver) 
		ifTrue: [FakeClassPool adopt: model selectedClass.  "Include model pool vars if any"
				rcvr _ model doItReceiver.
				ctxt _ model doItContext]
		ifFalse: [rcvr _ ctxt _ nil].
	result _ [
		cm := rcvr class evaluatorClass new 
			compiledMethodFor: self selectionAsStream
			in: ctxt
			to: rcvr
			notifying: self
			ifFail: [FakeClassPool adopt: nil. ^ #failedDoit]
			logged: false.
		Time millisecondsToRun: 
			[v := cm valueWithReceiver: rcvr arguments: (Array with: ctxt)].
	] 
		on: OutOfScopeNotification 
		do: [ :ex | ex resume: true].
	FakeClassPool adopt: nil.

	"We do not want to have large result displayed"
	valueAsString := v printString.
	(valueAsString size > 30) ifTrue: [valueAsString := (valueAsString copyFrom: 1 to: 30), '...'].
	PopUpMenu 
		inform: 'Time to compile and execute: ', result printString, 'ms res: ', valueAsString.
! !


!ParagraphEditor methodsFor: 'editing keys'!
align: characterStream 
	"Triggered by Cmd-u;  cycle through alignment alternatives.  8/11/96 sw"

	sensor keyboard.		"flush character"
	self align.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'hpt 8/5/2004 20:21'!
browseIt: characterStream 
	"Triggered by Cmd-B; browse the thing represented by the current selection, if plausible.  1/18/96 sw"

	sensor keyboard.		"flush character"
	self browseIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
browseItHere: characterStream 
	"Triggered by Cmd-shift-B; browse the thing represented by the current selection, if plausible, in the receiver's own window.  3/1/96 sw"

	sensor keyboard.		"flush character"
	self browseItHere.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:40'!
cancel: characterStream 
	"Cancel unsubmitted changes.  Flushes typeahead.  1/12/96 sw
	 1/22/96 sw: put in control terminate/init"

	sensor keyboard.
	self terminateAndInitializeAround: [self cancel].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'dgd 4/4/2006 15:46'!
changeEmphasis: characterStream 
	"Change the emphasis of the current selection or prepare to
	accept characters with the change in emphasis. Emphasis
	change amounts to a font change. Keeps typeahead."
	
	| keyCode attribute oldAttributes index thisSel colors extras |

	"control 0..9 -> 0..9"
	keyCode := ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1.

	oldAttributes := paragraph text attributesAt: self pointIndex forStyle: paragraph textStyle.
	thisSel := self selection.

	"Decipher keyCodes for Command 0-9..."
	(keyCode between: 1 and: 5) ifTrue: [
		attribute := TextFontChange fontNumber: keyCode
	].

	keyCode = 6 ifTrue: [
		| labels lines | 
		colors := #(#black #magenta #red #yellow #green #blue #cyan #white ).
		extras := (self class name = #TextMorphEditor and: [(self morph isKindOf: TextMorphForEditView) not])
						ifTrue: ["not a system window" #()]
						ifFalse: [#('Link to comment of class' 'Link to definition of class' 'Link to hierarchy of class' 'Link to method' )].

		Preferences noviceMode ifTrue: [
			labels := colors , #('choose color...' ).
			lines := #()
		]
		ifFalse: [
			labels := colors , #('choose color...' 'Do it' 'Print it' ) , extras , #('be a web URL link' 'Edit hidden info' 'Copy hidden info' ).
			lines := Array with: colors size + 1
		].

		"index _ (PopUpMenu labelArray: labels lines: lines) startUp. "
		index := UIManager default chooseFrom: labels lines: lines.
		index = 0
			ifTrue: [ ^ true].
			
		index <= colors size ifTrue: [
			attribute := TextColor color: (Color perform: (colors at: index))
		]
		ifFalse: [
			index := index - colors size - 1. "Re-number!!!!!!"

			index = 0 ifTrue: [
				attribute := self chooseColor
			].

			index = 1 ifTrue: [
				attribute := TextDoIt new.
				thisSel := attribute analyze: self selection asString
			].

			index = 2 ifTrue: [
				attribute := TextPrintIt new.
				thisSel := attribute analyze: self selection asString
			].

			extras size = 0 & (index > 2) ifTrue: [
				index := index + 4 "skip those"
			].

			index = 3 ifTrue: [
				attribute := TextLink new.
				thisSel := attribute analyze: self selection asString with: 'Comment'
			].

			index = 4 ifTrue: [
				attribute := TextLink new.
				thisSel := attribute analyze: self selection asString with: 'Definition'
			].

			index = 5 ifTrue: [
				attribute := TextLink new.
				thisSel := attribute analyze: self selection asString with: 'Hierarchy'
			].

			index = 6 ifTrue: [
				attribute := TextLink new.
				thisSel := attribute analyze: self selection asString
			].
		
			index = 7 ifTrue: [
				attribute := TextURL new.
				thisSel := attribute analyze: self selection asString
			].
		
			index = 8 ifTrue: [
				"Edit hidden info"
				thisSel := self hiddenInfo. "includes selection"
				attribute := TextEmphasis normal
			].

			index = 9 ifTrue: [
				"Copy hidden info"
				self copyHiddenInfo.
				^ true
			].
		
			"no other action"
			thisSel
				ifNil: [ ^ true ]
		]
	].

	(keyCode between: 7 and: 11) ifTrue: [
		sensor leftShiftDown ifTrue: [
			keyCode = 10 ifTrue: [
				attribute := TextKern kern: -1
			].
			keyCode = 11 ifTrue: [
				attribute := TextKern kern: 1
			]
		]
		ifFalse: [
			attribute := TextEmphasis perform: (#(#bold #italic #narrow #underlined #struckOut ) at: keyCode - 6).
			oldAttributes
						do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]
		]
	].

	keyCode = 0
		ifTrue: [attribute := TextEmphasis normal].

	beginTypeInBlock ~~ nil ifTrue: [
		"only change emphasisHere while typing"
		self insertTypeAhead: characterStream.
		emphasisHere := Text addAttribute: attribute toArray: oldAttributes.
		^ true
	].

	self
		replaceSelectionWith: (thisSel asText addAttribute: attribute).
		
	^ true
! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 11:58'!
changeLfToCr: characterStream 
	"Replace all LFs by CRs.
	Triggered by Cmd-U -- useful when getting code from FTP sites"
	| cr lf |
	sensor keyboard.		"flush the triggering cmd-key character"
	cr _ Character cr.  lf _ Character linefeed.
	self replaceSelectionWith: (Text fromString:
			(self selection string collect: [:c | c = lf ifTrue: [cr] ifFalse: [c]])).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'tk 5/7/2001 09:11'!
chooseColor
	"Make a new Text Color Attribute, let the user pick a color, and return the attribute.  This is the non-Morphic version."

	^ TextColor color: (Color fromUser)! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:31'!
compareToClipboard: characterStream 
	"Compare the receiver to the text on the clipboard.  Flushes typeahead.  5/1/96 sw"

	sensor keyboard.	
	self terminateAndInitializeAround: [self compareToClipboard].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'tk 5/7/2001 08:47'!
copyHiddenInfo
	"In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden
info.  Copy that to the clipboard.  You can paste it and see what it is.
Usually enclosed in <>."

	^ self clipboardTextPut: self hiddenInfo asText! !

!ParagraphEditor methodsFor: 'editing keys'!
copySelection: characterStream 
	"Copy the current text selection.  Flushes typeahead."

	sensor keyboard.		"flush character"
	self copySelection.
	^true! !

!ParagraphEditor methodsFor: 'editing keys'!
cut: characterStream 
	"Cut out the current text selection.  Flushes typeahead."

	sensor keyboard.		"flush character"
	self cut.
	^true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:23'!
doIt: characterStream 
	"Called when user hits cmd-d.  Select the current line, if relevant, then evaluate and execute.  2/1/96 sw.
	2/29/96 sw: don't call selectLine; it's done by doIt now"

	sensor keyboard.	
	self terminateAndInitializeAround: [self doIt].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/20/2002 11:41'!
duplicate: characterStream
	"Paste the current selection over the prior selection, if it is non-overlapping and
	 legal.  Flushes typeahead.  Undoer & Redoer: undoAndReselect."

	sensor keyboard.
	self closeTypeIn.
	(self hasSelection and: [self isDisjointFrom: otherInterval])
		ifTrue: "Something to duplicate"
			[self replace: otherInterval with: self selection and:
				[self selectAt: self pointIndex]]
		ifFalse:
			[view flash].
	^true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/19/2002 18:01'!
enclose: characterStream
	"Insert or remove bracket characters around the current selection.
	 Flushes typeahead."

	| char left right startIndex stopIndex oldSelection which text |
	char _ sensor keyboard.
	self closeTypeIn.
	startIndex _ self startIndex.
	stopIndex _ self stopIndex.
	oldSelection _ self selection.
	which _ '([<{"''' indexOf: char ifAbsent: [ ^true ].
	left _ '([<{"''' at: which.
	right _ ')]>}"''' at: which.
	text _ paragraph text.
	((startIndex > 1 and: [stopIndex <= text size])
		and:
		[(text at: startIndex-1) = left and: [(text at: stopIndex) = right]])
		ifTrue:
			["already enclosed; strip off brackets"
			self selectFrom: startIndex-1 to: stopIndex.
			self replaceSelectionWith: oldSelection]
		ifFalse:
			["not enclosed; enclose by matching brackets"
			self replaceSelectionWith:
				(Text string: (String with: left), oldSelection string ,(String with: right)
					emphasis: emphasisHere).
			self selectFrom: startIndex+1 to: stopIndex].
	^true! !

!ParagraphEditor methodsFor: 'editing keys'!
exchange: characterStream
	"Exchange the current and prior selections.  Keeps typeahead."

	sensor keyboard.	 "Flush character"
	self closeTypeIn: characterStream.
	self exchange.
	^true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'acg 12/7/1999 07:56'!
exploreIt: characterStream 
	"Explore the selection -- invoked via cmd-shift-I.  If there is no current selection, use the current line."

	sensor keyboard.		"flush character"
	self terminateAndInitializeAround: [self exploreIt].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 4/24/2001 12:28'!
fileItIn: characterStream 
	"File in the selection; invoked via a keyboard shortcut, -- for now, cmd-shift-G."

	sensor keyboard.		"flush character"
	self terminateAndInitializeAround: [self fileItIn].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:31'!
hiddenInfo
	"In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info.  Return the entire string that was used by Cmd-6 to create this text attribute.  Usually enclosed in < >."

	| attrList |
	attrList _ paragraph text attributesAt: (self pointIndex +
self markIndex)//2 forStyle: paragraph textStyle.
	attrList do: [:attr |
		(attr isKindOf: TextAction) ifTrue:
			[^ self selection asString, '<', attr info, '>']].
	"If none of the above"
	attrList do: [:attr |
		attr class == TextColor ifTrue:
			[^ self selection asString, '<', attr color printString, '>']].
	^ self selection asString, '[No hidden info]'! !

!ParagraphEditor methodsFor: 'editing keys'!
implementorsOfIt: characterStream 
	"Triggered by Cmd-m; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"

	sensor keyboard.		"flush character"
	self implementorsOfIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'pk 9/10/2005 22:53'!
inOutdent: characterStream delta: delta
	"Add/remove a tab at the front of every line occupied by the selection. Flushes typeahead.  Derived from work by Larry Tesler back in December 1985.  Now triggered by Cmd-L and Cmd-R.  2/29/96 sw"

	| cr realStart realStop lines startLine stopLine start stop adjustStart indentation size numLines inStream newString outStream |
	
	sensor keyboard.  "Flush typeahead"
	cr := Character cr.

	"Operate on entire lines, but remember the real selection for re-highlighting later"
	realStart := self startIndex.
	realStop := self stopIndex - 1.

	"Special case a caret on a line of its own, including weird case at end of paragraph"
	(realStart > realStop and:
				[realStart < 2 or: [(paragraph string at: realStart - 1) == cr]])
		ifTrue:
			[delta < 0
				ifTrue:
					[view flash]
				ifFalse:
					[self replaceSelectionWith: Character tab asSymbol asText.
					self selectAt: realStart + 1].
			^ true].

	lines := paragraph lines.
	startLine := paragraph lineIndexOfCharacterIndex: realStart.
	stopLine := paragraph lineIndexOfCharacterIndex: (realStart max: realStop).
	start := (lines at: startLine) first.
	stop := (lines at: stopLine) last.
	
	"Pin the start of highlighting unless the selection starts a line"
	adjustStart := realStart > start.

	"Find the indentation of the least-indented non-blank line; never outdent more"
	indentation := (startLine to: stopLine) inject: 1000 into:
		[:m :l |
		m := m min: (paragraph indentationOfLineIndex: l ifBlank: [:tabs | 1000])].			

	size :=  stop + 1 - start.
	numLines := stopLine + 1 - startLine.
	inStream := ReadStream on: paragraph string from: start to: stop.

	newString := WideString new: size + ((numLines * delta) max: 0).
	outStream := ReadWriteStream on: newString.

	"This subroutine does the actual work"
	self indent: delta fromStream: inStream toStream: outStream.

	"Adjust the range that will be highlighted later"
	adjustStart ifTrue: [realStart := (realStart + delta) max: start].
	realStop := realStop + outStream position - size.

	"Prepare for another iteration"
	indentation := indentation + delta.
	size := outStream position.
	inStream := outStream setFrom: 1 to: size.

	outStream == nil
		ifTrue: 	"tried to outdent but some line(s) were already left flush"
			[view flash]
		ifFalse:
			[self selectInvisiblyFrom: start to: stop.
			size = newString size ifFalse: [newString _ outStream contents].
			self replaceSelectionWith: newString asText].
	self selectFrom: realStart to: realStop. 	"highlight only the original range"
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
indent: characterStream
	"Add a tab at the front of every line occupied by the selection. Flushes typeahead.  Invoked from keyboard via cmd-shift-R.  2/29/96 sw"

	^ self inOutdent: characterStream delta: 1! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:25'!
inspectIt: characterStream 
	"Inspect the selection -- invoked via cmd-i.  If there is no current selection, use the current line.  1/17/96 sw
	 2/29/96 sw: don't call selectLine; it's done by inspectIt now"

	sensor keyboard.		"flush character"
	self terminateAndInitializeAround: [self inspectIt].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'md 1/18/2006 23:42'!
makeCapitalized: characterStream 
	"Force the current selection to be capitalized. Triggered by Cmd-Z."
	| prev |
	sensor keyboard.		"Flush the triggering cmd-key character"
	prev _ $-.  "not a letter"
	self replaceSelectionWith: (Text fromString:
			(self selection string collect:
				[:c | prev _ prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]])).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 12:00'!
makeLowercase: characterStream 
	"Force the current selection to lowercase.  Triggered by Cmd-X."

	sensor keyboard.		"flush the triggering cmd-key character"
	self replaceSelectionWith: (Text fromString: (self selection string asLowercase)).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:21'!
makeProjectLink: characterStream 
	""

	| attribute oldAttributes thisSel |
	
	sensor keyboard.
	oldAttributes _ paragraph text attributesAt: self pointIndex forStyle: paragraph textStyle.
	thisSel _ self selection.

	attribute _ TextSqkProjectLink new. 
	thisSel _ attribute analyze: self selection asString.

	thisSel ifNil: [^ true].
	beginTypeInBlock ~~ nil
		ifTrue:  "only change emphasisHere while typing"
			[self insertTypeAhead: characterStream.
			emphasisHere _ Text addAttribute: attribute toArray: oldAttributes.
			^ true].
	self replaceSelectionWith: (thisSel asText addAttribute: attribute).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'ls 11/10/2002 12:11'!
makeUppercase: characterStream 
	"Force the current selection to uppercase.  Triggered by Cmd-Y."

	sensor keyboard.		"flush the triggering cmd-key character"
	self replaceSelectionWith: (Text fromString: (self selection string asUppercase)).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 8/1/97 15:18'!
methodNamesContainingIt: characterStream 
	"Browse methods whose selectors containing the selection in their names"

	sensor keyboard.		"flush character"
	self methodNamesContainingIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 9/9/97 16:44'!
methodStringsContainingIt: characterStream 
	"Invoked from cmd-E -- open a browser on all methods holding string constants containing it.  Flushes typeahead. "

	sensor keyboard.	
	self methodStringsContainingit.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
noop: characterStream 
	"Unimplemented keyboard command; just ignore it."

	sensor keyboard.	  "flush character"
	^ true
! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 1/19/2000 11:14'!
offerFontMenu
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.  
	Use only names of Fonts of this paragraph  "

	| aList reply |
	aList _ paragraph textStyle fontNamesWithPointSizes.
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ~~ nil ifTrue:
		[self replaceSelectionWith:
			(Text string: self selection asString 
				attribute: (TextFontChange fontNumber: (aList indexOf: reply)))] ! !

!ParagraphEditor methodsFor: 'editing keys'!
offerFontMenu: characterStream 
	"The user typed the command key that requests a font change; Offer the font menu.  5/27/96 sw
	 Keeps typeahead.  (?? should flush?)"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self offerFontMenu.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
outdent: characterStream
	"Remove a tab from the front of every line occupied by the selection. Flushes typeahead.  Invoked from keyboard via cmd-shift-L.  2/29/96 sw"

	^ self inOutdent: characterStream delta: -1! !

!ParagraphEditor methodsFor: 'editing keys'!
paste: characterStream 
	"Replace the current text selection by the text in the shared buffer.
	 Keeps typeahead."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self paste.
	^true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/19/2002 18:48'!
pasteInitials: characterStream 
	"Replace the current text selection by an authorship name/date stamp; invoked by cmd-shift-v, easy way to put an authorship stamp in the comments of an editor.
	 Keeps typeahead."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self replace: self selectionInterval with: (Text fromString: Utilities changeStamp) and: [self selectAt: self stopIndex].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:25'!
printIt: characterStream 
	"Print the results of evaluting the selection -- invoked via cmd-p.  If there is no current selection, use the current line.  1/17/96 sw
	 2/29/96 sw: don't call selectLine now, since it's called by doIt"

	sensor keyboard.		"flush character"
	self terminateAndInitializeAround: [self printIt].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
referencesToIt: characterStream 
	"Triggered by Cmd-N; browse references to the current selection"

	sensor keyboard.		"flush character"
	self referencesToIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:43'!
save: characterStream
	"Submit the current text.  Equivalent to 'accept' 1/18/96 sw
	 Keeps typeahead."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self terminateAndInitializeAround: [self accept].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
sendersOfIt: characterStream 
	"Triggered by Cmd-n; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"

	sensor keyboard.		"flush character"
	self sendersOfIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'yo 5/27/2004 13:56'!
setEmphasis: emphasisSymbol
	"Change the emphasis of the current selection."

	| oldAttributes attribute |
	oldAttributes _ paragraph text attributesAt: self selectionInterval first forStyle: paragraph textStyle.

	attribute _ TextEmphasis perform: emphasisSymbol.
	(emphasisSymbol == #normal) 
		ifFalse:	[oldAttributes do:	
			[:att | (att dominates: attribute) ifTrue: [attribute turnOff]]].
	self replaceSelectionWith: (self selection addAttribute: attribute)! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:20'!
shiftEnclose: characterStream
	"Insert or remove bracket characters around the current selection.
	 Flushes typeahead."

	| char left right startIndex stopIndex oldSelection which text |
	char _ sensor keyboard.
	char = $9 ifTrue: [ char _ $( ].
	char = $, ifTrue: [ char _ $< ].
	char = $[ ifTrue: [ char _ ${ ].
	char = $' ifTrue: [ char _ $" ].
	char asciiValue = 27 ifTrue: [ char _ ${ ].	"ctrl-["

	self closeTypeIn.
	startIndex _ self startIndex.
	stopIndex _ self stopIndex.
	oldSelection _ self selection.
	which _ '([<{"''' indexOf: char ifAbsent: [1].
	left _ '([<{"''' at: which.
	right _ ')]>}"''' at: which.
	text _ paragraph text.
	((startIndex > 1 and: [stopIndex <= text size])
		and:
		[(text at: startIndex-1) = left and: [(text at: stopIndex) = right]])
		ifTrue:
			["already enclosed; strip off brackets"
			self selectFrom: startIndex-1 to: stopIndex.
			self replaceSelectionWith: oldSelection]
		ifFalse:
			["not enclosed; enclose by matching brackets"
			self replaceSelectionWith:
				(Text string: (String with: left), oldSelection string ,(String with: right)
					emphasis: emphasisHere).
			self selectFrom: startIndex+1 to: stopIndex].
	^true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:43'!
spawnIt: characterStream
	"Triggered by Cmd-o; spawn a new code window, if it makes sense."

	sensor keyboard.
	self terminateAndInitializeAround: [self spawn].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/19/2002 18:00'!
swapChars: characterStream 
	"Triggered byCmd-Y;.  Swap two characters, either those straddling the insertion point, or the two that comprise the selection.  Suggested by Ted Kaehler.  "

	| currentSelection aString chars |
	sensor keyboard.		"flush the triggering cmd-key character"
	(chars _ self selection) size == 0
		ifTrue:
			[currentSelection _ self pointIndex.
			self selectMark: currentSelection - 1 point: currentSelection]
		ifFalse:
			[chars size == 2
				ifFalse:
					[view flash.  ^ true]
				ifTrue:
					[currentSelection _ self pointIndex - 1]].
	aString _ self selection string.
	self replaceSelectionWith: (Text string: aString reversed emphasis: emphasisHere).
	self selectAt: currentSelection + 1.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 11/2/1998 15:50'!
tempCommand: characterStream 
	"Experimental.  Triggered by Cmd-t; put trial cmd-key commands here to see how they work, before hanging them on their own cmd accelerators."
	Sensor keyboard.
	self experimentalCommand.
	^ true

	"sensor keyboard.
	self spawnWorkspace.
	^ true"! !

!ParagraphEditor methodsFor: 'editing keys'!
undo: characterStream 
	"Undo the last edit.  Keeps typeahead, so undo twice is a full redo."

	sensor keyboard. 	"flush character"
	self closeTypeIn: characterStream.
	self undo.
	^true! !


!ParagraphEditor methodsFor: 'explain' stamp: 'nk 6/26/2003 22:02'!
explainAnySel: symbol 
	"Is this any message selector?"

	| list reply |
	list _ self systemNavigation allClassesImplementing: symbol.
	list size = 0 ifTrue: [^nil].
	list size < 12
		ifTrue: [reply _ ' is a message selector which is defined in these classes ' , list printString]
		ifFalse: [reply _ ' is a message selector which is defined in many classes'].
	^'"' , symbol , reply , '."' , '\' withCRs, 'SystemNavigation new browseAllImplementorsOf: #' , symbol! !

!ParagraphEditor methodsFor: 'explain' stamp: 'di 1/30/2002 21:09'!
explainChar: string
	"Does string start with a special character?"

	| char |
	char _ string at: 1.
	char = $. ifTrue: [^'"Period marks the end of a Smalltalk statement.  A period in the middle of a number means a decimal point.  (The number is an instance of class Float)."'].
	char = $' ifTrue: [^'"The characters between two single quotes are made into an instance of class String"'].
	char = $" ifTrue: [^'"Double quotes enclose a comment.  Smalltalk ignores everything between double quotes."'].
	char = $# ifTrue: [^'"The characters following a hash mark are made into an instance of class Symbol.  If parenthesis follow a hash mark, an instance of class Array is made.  It contains literal constants."'].
	(char = $( or: [char = $)]) ifTrue: [^'"Expressions enclosed in parenthesis are evaluated first"'].
	(char = $[ or: [char = $]]) ifTrue: [^'"The code inside square brackets is an unevaluated block of code.  It becomes an instance of BlockContext and is usually passed as an argument."'].
	(char = ${ or: [char = $}]) ifTrue: [^ '"A sequence of expressions separated by periods, when enclosed in curly braces, are evaluated to yield the elements of a new Array"'].
	(char = $< or: [char = $>]) ifTrue: [^'"<primitive: xx> means that this method is usually preformed directly by the virtual machine.  If this method is primitive, its Smalltalk code is executed only when the primitive fails."'].
	char = $^ ifTrue: [^'"Uparrow means return from this method.  The value returned is the expression following the ^"'].
	char = $| ifTrue: [^'"Vertical bars enclose the names of the temporary variables used in this method.  In a block, the vertical bar separates the argument names from the rest of the code."'].
	char = $_ ifTrue: [^'"Left arrow means assignment.  The value of the expression after the left arrow is stored into the variable before it."'].
	char = $; ifTrue: [^'"Semicolon means cascading.  The message after the semicolon is sent to the same object which received the message before the semicolon."'].
	char = $: ifTrue: [^'"A colon at the end of a keyword means that an argument is expected to follow.  Methods which take more than one argument have selectors with more than one keyword.  (One keyword, ending with a colon, appears before each argument).', '\\' withCRs, 'A colon before a variable name just inside a block means that the block takes an agrument.  (When the block is evaluated, the argument will be assigned to the variable whose name appears after the colon)."'].
	char = $$ ifTrue: [^'"The single character following a dollar sign is made into an instance of class Character"'].
	char = $- ifTrue: [^'"A minus sign in front of a number means a negative number."'].
	char = $e ifTrue: [^'"An e in the middle of a number means that the exponent follows."'].
	char = $r ifTrue: [^'"An r in the middle of a bunch of digits is an instance of Integer expressed in a certain radix.  The digits before the r denote the base and the digits after it express a number in that base."'].
	char = Character space ifTrue: [^'"the space Character"'].
	char = Character tab ifTrue: [^'"the tab Character"'].
	char = Character cr ifTrue: [^'"the carriage return Character"'].
	^nil! !

!ParagraphEditor methodsFor: 'explain' stamp: 'nk 6/10/2004 07:02'!
explainClass: symbol 
	"Is symbol a class variable or a pool variable?"
	| class reply classes |
	(model respondsTo: #selectedClassOrMetaClass)
		ifFalse: [^ nil].
	(class _ model selectedClassOrMetaClass) ifNil: [^ nil].
	"no class is selected"
	(class isKindOf: Metaclass)
		ifTrue: [class _ class soleInstance].
	classes _ (Array with: class)
				, class allSuperclasses.
	"class variables"
	reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name]
					ifNone: [])
					~~ nil]
				ifNone: [].
	reply == nil ifFalse: [^ '"is a class variable, defined in class ' , reply printString , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (' , reply printString , ' classPool associationAt: #' , symbol , ').'].
	"pool variables"
	classes do: [:each | (each sharedPools
			detect: [:pool | (pool includesKey: symbol)
					and: 
						[reply _ pool.
						true]]
			ifNone: [])
			~~ nil].
	reply
		ifNil: [(Undeclared includesKey: symbol)
				ifTrue: [^ '"is an undeclared variable.' , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (Undeclared associationAt: #' , symbol , ').']]
		ifNotNil: 
			[classes _ WriteStream on: Array new.
			self systemNavigation
				allBehaviorsDo: [:each | (each sharedPools
						detect: 
							[:pool | 
							pool == reply]
						ifNone: [])
						~~ nil ifTrue: [classes nextPut: each]].
			"Perhaps not print whole list of classes if too long. (unlikely)"
			^ '"is a pool variable from the pool ' , (Smalltalk keyAtIdentityValue: reply) asString , ', which is used by the following classes ' , classes contents printString , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (' , (Smalltalk keyAtIdentityValue: reply) asString , ' bindingOf: #' , symbol , ').'].
	^ nil! !

!ParagraphEditor methodsFor: 'explain' stamp: 'sw 5/3/1998 14:32'!
explainCtxt: symbol 
	"Is symbol a context variable?"

	| reply classes text cls |
	symbol = #nil ifTrue: [reply _ '"is a constant.  It is the only instance of class UndefinedObject.  nil is the initial value of all variables."'].
	symbol = #true ifTrue: [reply _ '"is a constant.  It is the only instance of class True and is the receiver of many control messages."'].
	symbol = #false ifTrue: [reply _ '"is a constant.  It is the only instance of class False and is the receiver of many control messages."'].
	symbol = #thisContext ifTrue: [reply _ '"is a context variable.  Its value is always the MethodContext which is executing this method."'].
	(model respondsTo: #selectedClassOrMetaClass) ifTrue: [
		cls _ model selectedClassOrMetaClass].
	cls ifNil: [^ reply].	  "no class known"
	symbol = #self ifTrue: 
			[classes _ cls withAllSubclasses.
			classes size > 12
				ifTrue: [text _ cls printString , ' or a subclass']
				ifFalse: 
					[classes _ classes printString.
					text _ 'one of these classes' , (classes copyFrom: 4 to: classes size)].
			reply _ '"is the receiver of this message; an instance of ' , text , '"'].
	symbol = #super ifTrue: [reply _ '"is just like self.  Messages to super are looked up in the superclass (' , cls superclass printString , ')"'].
	^reply! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tpr 5/29/2003 20:07'!
explainGlobal: symbol 
	"Is symbol a global variable?"
	| reply classes |
	reply _ Smalltalk at: symbol ifAbsent: [^nil].
	(reply class == Dictionary or:[reply isKindOf: SharedPool class])
		ifTrue: 
			[classes _ Set new.
			self systemNavigation allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply]
					ifNone: [])
					~~ nil ifTrue: [classes add: each]].
			classes _ classes printString.
			^'"is a global variable.  It is a pool which is used by the following classes ' , (classes allButFirst: 5) , '"'].
	(reply isKindOf: Behavior)
		ifTrue: [^'"is a global variable.  ' , symbol , ' is a class in category ', reply category,
			'."', '\' withCRs, 'Browser newOnClass: ' , symbol , '.'].
	symbol == #Smalltalk ifTrue: [^'"is a global.  Smalltalk is the only instance of SystemDictionary and holds all global variables."'].
	^'"is a global variable.  ' , symbol , ' is ' , reply printString , '"'! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tpr 5/12/2004 16:22'!
explainInst: string 
	"Is string an instance variable of this class?"
	| classes cls |

	(model respondsTo: #selectedClassOrMetaClass) ifTrue: [
		cls _ model selectedClassOrMetaClass].
	cls ifNil: [^ nil].	  "no class known"
	classes _ (Array with: cls)
				, cls allSuperclasses.
	classes _ classes detect: [:each | (each instVarNames
			detect: [:name | name = string] ifNone: [])
			~~ nil] ifNone: [^nil].
	classes _ classes printString.
	^ '"is an instance variable of the receiver; defined in class ' , classes , 
		'"\' withCRs , classes , ' systemNavigation browseAllAccessesTo: ''' , string , ''' from: ', classes, '.'! !

!ParagraphEditor methodsFor: 'explain' stamp: 'nb 5/6/2003 16:54'!
explainMySel: symbol 
	"Is symbol the selector of this method?  Is it sent by this method?  If 
	not, then expalin will call (explainPartSel:) to see if it is a fragment of a 
	selector sent here.  If not, explain will call (explainAnySel:) to catch any 
	selector. "

	| lits classes msg |
	(model respondsTo: #selectedMessageName) ifFalse: [^ nil].
	(msg _ model selectedMessageName) ifNil: [^nil].	"not in a message"
	classes _ self systemNavigation allClassesImplementing: symbol.
	classes size > 12
		ifTrue: [classes _ 'many classes']
		ifFalse: [classes _ 'these classes ' , classes printString].
	msg = symbol
		ifTrue: [^ '"' , symbol , ' is the selector of this very method!!  It is defined in ',
			classes , '.  To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']
		ifFalse: 
			[lits _ (model selectedClassOrMetaClass compiledMethodAt:
				msg) messages.
			(lits detect: [:each | each == symbol]
				ifNone: [])
				== nil ifTrue: [^nil].
			^ '"' , symbol , ' is a message selector which is defined in ', classes , '.  To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].! !

!ParagraphEditor methodsFor: 'explain' stamp: 'apb 1/5/2000 16:56'!
explainNumber: string 
	"Is string a Number?"

	| strm c |
	(c _ string at: 1) isDigit ifFalse: [(c = $- and: [string size > 1 and: [(string at: 2) isDigit]])
			ifFalse: [^nil]].
	strm _ ReadStream on: string.
	c _ Number readFrom: strm.
	strm atEnd ifFalse: [^nil].
	c printString = string
		ifTrue: [^'"' , string , ' is a ' , c class name , '"']
		ifFalse: [^'"' , string , ' (= ' , c printString , ') is a ' , c class name , '"']! !

!ParagraphEditor methodsFor: 'explain' stamp: 'nb 5/6/2003 16:54'!
explainPartSel: string 
	"Is this a fragment of a multiple-argument selector sent in this method?"
	| lits whole reply classes s msg |

	(model respondsTo: #selectedMessageName) ifFalse: [^ nil].
	(msg _ model selectedMessageName) ifNil: [^ nil].  "not in a message"
	string last == $: ifFalse: [^ nil].
	"Name of this method"
	lits _ Array with: msg.
	(whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]
					ifNone: []) ~~ nil]
				ifNone: []) ~~ nil
		ifTrue: [reply _ ', which is the selector of this very method!!'.
			s _ '.  To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']
		ifFalse: 
			["Selectors called from this method"
			lits _ (model selectedClassOrMetaClass compiledMethodAt:
				msg) messages.
			(whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]
							ifNone: []) ~~ nil]
						ifNone: []) ~~ nil
				ifFalse: [string = 'primitive:'
					ifTrue: [^self explainChar: '<']
					ifFalse: [^nil]].
			reply _ '.'.
			s _ '.  To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].
	classes _ self systemNavigation allClassesImplementing: whole.
	classes size > 12
		ifTrue: [classes _ 'many classes']
		ifFalse: [classes _ 'these classes ' , classes printString].
	^ '"' , string , ' is one part of the message selector ' , whole, reply , '  It is defined in ' , classes , s! !

!ParagraphEditor methodsFor: 'explain'!
explainScan: string 
	"Remove beginning and trailing space, tab, cr.
	 1/15/96 sw: copied intact from BrowserCodeController"

	| c beg end |
	beg _ 1.
	end _ string size.
	
	[beg = end ifTrue: [^string copyFrom: 1 to: 1].
	"if all blank, tell about the first"
	c _ string at: beg.
	c = Character space or: [c = Character tab or: [c = Character cr]]]
		whileTrue: [beg _ beg + 1].
	
	[c _ string at: end.
	c = Character space or: [c = Character tab or: [c = Character cr]]]
		whileTrue: [end _ end - 1].
	^string copyFrom: beg to: end	"Return purely visible characters"! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/1/98 14:19'!
explainTemp: string 
	"Is string the name of a temporary variable (or block argument variable)?"

	| selectedClass tempNames i reply methodNode method msg |
	(model respondsTo: #selectedMessageName) ifFalse: [^ nil].
	(msg _ model selectedMessageName) ifNil: [^nil].	"not in a message"
	selectedClass _ model selectedClassOrMetaClass.
	tempNames _ selectedClass parserClass new 
			parseArgsAndTemps: model selectedMessage notifying: nil.
	method _ selectedClass compiledMethodAt: msg.
	(i _ tempNames findFirst: [:each | each = string]) = 0 ifTrue: [
		(method numTemps > tempNames size)
			ifTrue: 
				["It must be an undeclared block argument temporary"
				methodNode _ selectedClass compilerClass new
							parse: model selectedMessage
							in: selectedClass
							notifying: nil.
				tempNames _ methodNode tempNames]
			ifFalse: [^nil]].
	(i _ tempNames findFirst: [:each | each = string]) > 0 ifTrue: [i > method numArgs
			ifTrue: [reply _ '"is a temporary variable in this method"']
			ifFalse: [reply _ '"is an argument to this method"']].
	^reply! !


!ParagraphEditor methodsFor: 'initialize-release'!
changeParagraph: aParagraph 
	"Install aParagraph as the one to be edited by the receiver."

	UndoParagraph == paragraph ifTrue: [UndoParagraph _ nil].
	paragraph _ aParagraph.
	self resetState! !

!ParagraphEditor methodsFor: 'initialize-release' stamp: 'th 10/21/2003 15:49'!
resetState 
	"Establish the initial conditions for editing the paragraph: place caret 
	before first character, set the emphasis to that of the first character,
	and save the paragraph for purposes of canceling."

	stopBlock _ paragraph defaultCharacterBlock.
	self pointBlock: stopBlock copy.
	beginTypeInBlock _ nil.
	UndoInterval _ otherInterval _ 1 to: 0.
	self setEmphasisHere.
	selectionShowing _ false.
	initialText _ paragraph text copy! !

!ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 5/15/2000 13:51'!
stateArray
	^ {ChangeText.
		FindText.
		UndoInterval.
		UndoMessage.
		UndoParagraph.
		UndoSelection.
		Undone.
		self selectionInterval.
		self startOfTyping.
		emphasisHere}! !

!ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 10/5/1998 17:03'!
stateArrayPut: stateArray
	| sel |
	ChangeText _ stateArray at: 1.
	FindText _ stateArray at: 2.
	UndoInterval _ stateArray at: 3.
	UndoMessage _ stateArray at: 4.
	UndoParagraph _ stateArray at: 5.
	UndoSelection _ stateArray at: 6.
	Undone _ stateArray at: 7.
	sel _ stateArray at: 8.
	self selectFrom: sel first to: sel last.
	beginTypeInBlock _ stateArray at: 9.
	emphasisHere _ stateArray at: 10.! !


!ParagraphEditor methodsFor: 'menu messages' stamp: 'jm 5/3/1998 19:19'!
accept
	"Save the current text of the text being edited as the current acceptable version for purposes of canceling."

	initialText _ paragraph text copy.
! !

!ParagraphEditor methodsFor: 'menu messages'!
again
	"Text substitution. If the left shift key is down, the substitution is made 
	throughout the entire Paragraph. Otherwise, only the next possible 
	substitution is made.
	Undoer & Redoer: #undoAgain:andReselect:typedKey:."

	"If last command was also 'again', use same keys as before"
	self againOrSame: (UndoMessage sends: #undoAgain:andReselect:typedKey:)! !

!ParagraphEditor methodsFor: 'menu messages'!
align
	"Align text according to the next greater alignment value--cycling among 
	left flush, right flush, center, justified.  No effect on the undoability of the pre
	preceding command."

	paragraph toggleAlignment.
	paragraph displayOn: Display.
	self recomputeInterval! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'md 8/2/2005 20:53'!
browseClassFromIt
	"Launch a browser for the class indicated by the current selection. 
	If multiple classes matching the selection exist, let the user choose among them."
	| aBrow aClass |
	self
		lineSelectAndEmptyCheck: [^ self].
	aClass := Utilities
				classFromPattern: (self selection string copyWithout: Character cr)
				withCaption: 'choose a class to browse...'.
	aClass
		ifNil: [^ view flash].
	self
		terminateAndInitializeAround: 
			[aBrow := SystemBrowser default new.
			aBrow setClass: aClass selector: nil.
			aBrow class
				openBrowserView: (aBrow openEditString: nil) label: 'System Browser'].! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'pmm 7/6/2006 20:50'!
browseIt
	"Launch a browser for the current selection, if appropriate"

	| aSymbol anEntry |
	self flag: #yoCharCases.

	Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt].

	self lineSelectAndEmptyCheck: [^ self].
	(aSymbol _ self selectedSymbol) isNil ifTrue: [^ view flash].

	self terminateAndInitializeAround:
		[aSymbol first isUppercase
			ifTrue:
				[anEntry _ (Smalltalk
					at: aSymbol
					ifAbsent:
						[ self systemNavigation browseAllImplementorsOf: aSymbol.
						^ nil]).
				anEntry isNil ifTrue: [^ view flash].
				(anEntry isBehavior or: [ anEntry isTrait ])
					ifFalse: [ anEntry := anEntry class ].
				ToolSet browse: anEntry selector: nil.
		] ifFalse:[ self systemNavigation browseAllImplementorsOf: aSymbol]]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 1/15/98 12:57'!
cancel 
	"Restore the text of the paragraph to be the text saved since initialization 
	or the last accept.  Undoer & Redoer: undoAndReselect:redoAndReselect:.
	This used to call controlTerminate and controlInitialize but this seemed illogical.
	Sure enough, nobody overrode them who had cancel in the menu, and if
	anybody really cared they could override cancel."

	UndoSelection _ paragraph text.
	self undoer: #undoAndReselect:redoAndReselect: with: self selectionInterval with: (1 to: 0).
	view ifNotNil: [view clearInside].
	self changeParagraph: (paragraph text: initialText).
	UndoParagraph _ paragraph.
	otherInterval _ UndoInterval _ 1 to: initialText size. "so undo will replace all"
	paragraph displayOn: Display.
	self selectAt: 1.
	self scrollToTop
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'yo 2/17/2005 17:53'!
changeAlignment
	| aList reply  |
	aList _ #(leftFlush centered justified rightFlush).
	reply _ (SelectionMenu labelList: (aList collect: [:t | t translated]) selections: aList) startUp.
	reply ifNil:[^self].
	self setAlignment: reply.
	paragraph composeAll.
	self recomputeSelection.
	self mvcRedisplay.
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'yo 3/14/2005 13:03'!
changeEmphasis
	| aList reply  |
	aList _ #(normal bold italic narrow underlined struckOut).
	reply _ (SelectionMenu labelList: (aList collect: [:t | t translated]) selections: aList) startUp.
	reply ~~ nil ifTrue:
		[self setEmphasis: reply.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'fc 2/19/2004 22:09'!
changeEmphasisOrAlignment
	| aList reply  |
	aList _ #(normal bold italic narrow underlined struckOut leftFlush centered rightFlush justified).
	reply _ (SelectionMenu labelList: aList lines: #(6) selections: aList) startUp.
	reply ~~ nil ifTrue:
		[(#(leftFlush centered rightFlush justified) includes: reply)
			ifTrue:
				[paragraph perform: reply.
				self recomputeInterval]
			ifFalse:
				[self setEmphasis: reply.
				paragraph composeAll.
				self recomputeSelection.
				self mvcRedisplay]].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'md 10/22/2003 15:27'!
changeStyle
	"Let user change styles for the current text pane  
	 Moved from experimentalCommand to its own method  "

	| aList reply style |
	aList _ StrikeFont actualFamilyNames.
	aList addFirst: 'DefaultTextStyle'.
	reply _ (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp.
	reply ifNotNil:
		[(style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true].
		paragraph textStyle: style copy.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'RAA 3/15/2001 12:10'!
changeStyleTo: aNewStyle

	paragraph textStyle: aNewStyle.
	paragraph composeAll.
	self recomputeSelection.
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 9/27/1999 11:54'!
chooseAlignment
	self changeAlignment! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/15/2003 22:40'!
classCommentsContainingIt
	"Open a browser class comments which contain the current selection somewhere in them."

	self lineSelectAndEmptyCheck: [^ self].
	self terminateAndInitializeAround: [
		self systemNavigation browseClassCommentsWithString: self selection string]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'dvf 8/23/2003 11:51'!
classNamesContainingIt
	"Open a browser on classes whose names contain the selected string"

	self lineSelectAndEmptyCheck: [^self].
	self systemNavigation 
		browseClassesWithNamesContaining: self selection string
		caseSensitive: Sensor leftShiftDown! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:37'!
clipboardText

	^ Clipboard clipboardText! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:38'!
clipboardText: text

	^ Clipboard clipboardText: text! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:38'!
clipboardTextPut: text

	^ Clipboard clipboardText: text! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 11/23/1998 15:21'!
compareToClipboard
	"Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user."
	| s1 s2 |
	s1 _ self clipboardText string.
	s2 _ paragraph text string.
	s1 = s2 ifTrue: [^ self inform: 'Exact match'].

	(StringHolder new textContents:
		(TextDiffBuilder buildDisplayPatchFrom: s1 to: s2))
		openLabel: 'Comparison to Clipboard Text'! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 15:09'!
copySelection
	"Copy the current selection and store it in the paste buffer, unless a caret.  Undoer & Redoer: undoCutCopy"

	self lineSelectAndEmptyCheck: [^ self].

	"Simulate 'substitute: self selection' without locking the controller"
	UndoSelection _ self selection.
	self undoer: #undoCutCopy: with: self clipboardText.
	UndoInterval _ self selectionInterval.
	self clipboardTextPut: UndoSelection! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 16:33'!
cut
	"Cut out the current selection and redisplay the paragraph if necessary.  Undoer & Redoer: undoCutCopy:"

	self lineSelectAndEmptyCheck: [^ self].

	self replaceSelectionWith: self nullText. 
	self undoer: #undoCutCopy: with: self clipboardText.
	self clipboardTextPut: UndoSelection! !

!ParagraphEditor methodsFor: 'menu messages'!
exchange
	"See comment in exchangeWith:"

	self exchangeWith: otherInterval! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:34'!
experimentalCommand
	"Use for experimental command-key implementation.  Using this, 
	you can try things out without forever needing to reinitialize the 
	ParagraphEditor."

	self prettyPrint.
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ls 10/10/1999
11:36'!
explain
	"Try to shed some light on what kind of entity the current selection
is. 
	The selection must be a single token or construct. Insert the answer
after 
	the selection. Send private messages whose names begin with 'explain' 
	that return a string if they recognize the selection, else nil."

	| string tiVars cgVars selectors delimitors numbers sorry reply symbol
|
Cursor execute showWhile: 
			[sorry _ '"Sorry, I can''t explain that.  Please select a single
token, construct, or special character.'.
			sorry _ sorry , (view canDiscardEdits
							ifFalse: ['  Also, please cancel or accept."']
							ifTrue: ['"']).
			(string _ self selection asString) isEmpty
				ifTrue: [reply _ '']
				ifFalse: [string _ self explainScan: string.
					"Remove space, tab, cr"
					"Temps and Instance vars need only test strings that are all
letters"
					(string detect: [:char | (char isLetter or: [char isDigit]) not]
						ifNone: []) ifNil: 
							[tiVars _ self explainTemp: string.
							tiVars == nil ifTrue: [tiVars _ self explainInst: string]].
					(tiVars == nil and: [model respondsTo: #explainSpecial:])
						ifTrue: [tiVars _ model explainSpecial: string].
					tiVars == nil
						ifTrue: [tiVars _ '']
						ifFalse: [tiVars _ tiVars , '\' withCRs].
					"Context, Class, Pool, and Global vars, and Selectors need 
					only test symbols"
					(Symbol hasInterned: string ifTrue: [:s | symbol _ s])
						ifTrue: [cgVars _ self explainCtxt: symbol.
							cgVars == nil
								ifTrue: [cgVars _ self explainClass: symbol.
									cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]].
							"See if it is a Selector (sent here or not)"
							selectors _ self explainMySel: symbol.
							selectors == nil
								ifTrue: 
									[selectors _ self explainPartSel: string.
									selectors == nil ifTrue: [
										selectors _ self explainAnySel: symbol]]]
						ifFalse: [selectors _ self explainPartSel: string].
					cgVars == nil
						ifTrue: [cgVars _ '']
						ifFalse: [cgVars _ cgVars , '\' withCRs].
					selectors == nil
						ifTrue: [selectors _ '']
						ifFalse: [selectors _ selectors , '\' withCRs].
					string size = 1
						ifTrue: ["single special characters"
							delimitors _ self explainChar: string]
						ifFalse: ["matched delimitors"
							delimitors _ self explainDelimitor: string].
					numbers _ self explainNumber: string.
					numbers == nil ifTrue: [numbers _ ''].
					delimitors == nil ifTrue: [delimitors _ ''].
					reply _ tiVars , cgVars , selectors , delimitors , numbers].
			reply size = 0 ifTrue: [reply _ sorry].
			self afterSelectionInsertAndSelect: reply]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 9/7/1999 08:41'!
fileItIn
	"Make a Stream on the text selection and fileIn it.
	 1/24/96 sw: moved here from FileController; this function can be useful from any text window that shows stuff in chunk format"

	| selection |
	selection _ self selection.
	self terminateAndInitializeAround:
		[(ReadWriteStream on: selection string from: 1 to: selection size) fileIn].
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'CdG 10/17/2005 20:49'!
find
	"Prompt the user for a string to search for, and search the receiver from the current selection onward for it.  1/26/96 sw"

	| reply |
	reply := UIManager default request: 'Find what? ' translated initialAnswer: ''.
	reply size == 0 ifTrue: [^ self].
	self setSearch: reply.
	ChangeText := FindText.  "Implies no replacement to againOnce: method"
	self againOrSame: true
	
! !

!ParagraphEditor methodsFor: 'menu messages'!
findAgain
	"Find the text-to-find again.  1/24/96 sw"

	self againOrSame: true! !

!ParagraphEditor methodsFor: 'menu messages'!
fit
	"Make the bounding rectangle of the paragraph contain all the text while 
	 not changing the width of the view of the paragraph.  No effect on undoability
	 of the preceding command."

	paragraph clearVisibleRectangle.
	paragraph fit.
	paragraph displayOn: Display; outline.
	self recomputeInterval! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 09:42'!
implementorsOfIt
	"Open an implementors browser on the selected selector"

	| aSelector |
	self lineSelectAndEmptyCheck: [^ self].
	(aSelector _ self selectedSelector) == nil ifTrue: [^ view flash].
	self terminateAndInitializeAround: [ self systemNavigation browseAllImplementorsOf: aSelector]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/19/2002 18:12'!
lineSelectAndEmptyCheck: returnBlock
	"If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this."

	self selectLine.  "if current selection is an insertion point, then first select the entire line in which occurs before proceeding"
	self hasSelection ifFalse: [self flash.  ^ returnBlock value]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'dgd 11/25/2004 18:03'!
makeProjectLink
	
	| attribute thisSel |
	
	thisSel := self selection.

	attribute := TextSqkProjectLink new. 
	thisSel := attribute analyze: self selection asString.

	thisSel ifNil: [^ true].
	self replaceSelectionWith: (thisSel asText addAttribute: attribute).
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:31'!
methodNamesContainingIt
	"Open a browser on methods names containing the selected string"

	self lineSelectAndEmptyCheck: [^ self].
	Cursor wait showWhile:
		[self terminateAndInitializeAround: [self systemNavigation browseMethodsWhoseNamesContain: self selection string withBlanksTrimmed]].
	Cursor normal show! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'md 9/6/2005 18:45'!
methodSourceContainingIt
	"Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source). Slow!!"

	self lineSelectAndEmptyCheck: [^ self].
	self systemNavigation browseMethodsWithSourceString: self selection string! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:28'!
methodStringsContainingit
	"Open a browser on methods which contain the current selection as part of a string constant."

	self lineSelectAndEmptyCheck: [^ self].
	self terminateAndInitializeAround: [self systemNavigation browseMethodsWithString: self selection string]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:34'!
mvcRedisplay
	"Overridable by subclasses that do their own display"
	Display fill: paragraph clippingRectangle 
			fillColor: view backgroundColor.	"very brute force"
	self display! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/20/2002 11:21'!
paste
	"Paste the text from the shared buffer over the current selection and 
	redisplay if necessary.  Undoer & Redoer: undoAndReselect."

	self replace: self selectionInterval with: self clipboardText and:
		[self selectAt: self pointIndex]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:36'!
pasteRecent
	"Paste an item chose from RecentClippings."

	| clipping |
	(clipping _ Clipboard chooseRecentClipping) ifNil: [^ self].
	Clipboard clipboardText: clipping.
	^ self paste! !

!ParagraphEditor methodsFor: 'menu messages'!
performMenuMessage: aSelector
	"If a menu command is invoked, typeIn must be closed first, the selection
	 must be unhighlighted before and rehighlighted after, and the marker
	 must be updated."

	self closeTypeIn.
	self deselect.
	super performMenuMessage: aSelector.
	self selectAndScroll.
	self updateMarker! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'rbb 2/16/2005 16:49'!
presentSpecialMenu
	"Present a list of expressions, and if the user chooses one, evaluate it in the context of the receiver, a ParagraphEditor.  Primarily for debugging, this provides a convenient way to talk to the various views, controllers, and models associated with any text pane"

	| reply items |
	self terminateAndInitializeAround:
		[reply _ (UIManager default chooseFrom: (items _ self specialMenuItems) lines: #()).
		reply = 0 ifTrue: [^ self].
		Compiler new evaluate: (items at: reply) in: [] to: self]
	! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:40'!
prettyPrint
	self prettyPrint: false! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'md 7/13/2006 16:00'!
prettyPrint: decorated
	"Reformat the contents of the receiver's view (a Browser)."

	| selectedClass newText |
	model selectedMessageCategoryName ifNil: [^ view flash].
	selectedClass _ model selectedClassOrMetaClass.
	newText _ selectedClass prettyPrinterClass
		format: self text
		in: selectedClass
		notifying: self
		decorated: decorated.
	newText ifNotNil:
		[self deselect; selectInvisiblyFrom: 1 to: paragraph text size.
		self replaceSelectionWith: (newText asText makeSelectorBoldIn: selectedClass).
		self selectAt: 1]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:40'!
prettyPrintWithColor
	self prettyPrint: true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'dew 3/7/2000 21:06'!
printerSetup
	
	TextPrinter defaultTextPrinter inspect
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 11:47'!
referencesToIt
	"Open a references browser on the selected symbol"

	| aSymbol |
	self selectLine.
	((aSymbol _ self selectedSymbol) == nil or:
		[(Smalltalk includesKey: aSymbol) not])
			ifTrue: [^ view flash].

	self terminateAndInitializeAround: [self systemNavigation browseAllCallsOn: (Smalltalk associationAt: self selectedSymbol)]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'CdG 10/17/2005 20:47'!
saveContentsInFile
	"Save the receiver's contents string to a file, prompting the user for a file-name.  Suggest a reasonable file-name."

	| fileName stringToSave parentWindow labelToUse suggestedName lastIndex |
	stringToSave := paragraph text string.
	stringToSave size == 0 ifTrue: [^ self inform: 'nothing to save.'].
	parentWindow := self model dependents
						detect: [:dep | dep isKindOf: SystemWindow orOf: StandardSystemView]
						ifNone: [nil].
	labelToUse := parentWindow
		ifNil: 		['Untitled']
		ifNotNil: 	[parentWindow label].
	suggestedName := nil.
	#(('Decompressed contents of: '		'.gz')) do:  "can add more here..."
		[:leaderTrailer |
			(labelToUse beginsWith: leaderTrailer first) ifTrue:
				[suggestedName := labelToUse copyFrom: leaderTrailer first size + 1 to: labelToUse size.
				(labelToUse endsWith: leaderTrailer last)
					ifTrue:
						[suggestedName := suggestedName copyFrom: 1 to: suggestedName size - leaderTrailer last size]
					ifFalse:
						[lastIndex := suggestedName lastIndexOf: $. ifAbsent: [0].
						(lastIndex = 0 or: [lastIndex = 1]) ifFalse:
							[suggestedName := suggestedName copyFrom: 1 to: lastIndex - 1]]]].

	suggestedName ifNil:
		[suggestedName := labelToUse, '.text'].
			
	fileName := UIManager default request: 'File name?' translated
			initialAnswer: suggestedName.
	fileName isEmptyOrNil ifFalse:
		[(FileStream newFileNamed: fileName) nextPutAll: stringToSave; close]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'bf 10/13/1999 09:09'!
selectedSelector
	"Try to make a selector out of the current text selection"
	^self selection string findSelector! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'yo 7/5/2004 16:38'!
selectedSymbol
	"Return the currently selected symbol, or nil if none.  Spaces, tabs and returns are ignored"

	| aString |
	self hasCaret ifTrue: [^ nil].
	aString _ self selection string.
	aString isOctetString ifTrue: [aString _ aString asOctetString].
	aString _ aString copyWithoutAll:
		{Character space.  Character cr.  Character tab}.
	aString size == 0 ifTrue: [^ nil].
	Symbol hasInterned: aString  ifTrue: [:sym | ^ sym].

	^ nil! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 2/23/2001 09:26'!
selectionAsTiles
	"Try to make new universal tiles from the selected text"
	| selection tiles |

	selection _ self selection.
	self terminateAndInitializeAround:
		[self currentHand attachMorph: (tiles _ Player tilesFrom: selection).
		Preferences tileTranslucentDrag
			ifTrue: [tiles lookTranslucent]
			ifFalse: [tiles align: tiles topLeft 
			 			with: self currentHand position + tiles cursorBaseOffset]].! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'gm 2/16/2003 20:38'!
sendContentsToPrinter
	| textToPrint printer parentWindow |
	textToPrint := paragraph text.
	textToPrint size == 0 ifTrue: [^self inform: 'nothing to print.'].
	printer := TextPrinter defaultTextPrinter.
	parentWindow := self model dependents 
				detect: [:dep | dep isSystemWindow]
				ifNone: [nil].
	parentWindow isNil 
		ifTrue: [printer documentTitle: 'Untitled']
		ifFalse: [printer documentTitle: parentWindow label].
	printer printText: textToPrint! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:30'!
sendersOfIt
	"Open a senders browser on the selected selector"

	| aSelector |
	self lineSelectAndEmptyCheck: [^ self].
	(aSelector _ self selectedSelector) == nil ifTrue: [^ view flash].
	self terminateAndInitializeAround: [self systemNavigation browseAllCallsOn: aSelector]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/18/2002 17:28'!
setAlignment: aSymbol
	| attr interval |
	attr _ TextAlignment perform: aSymbol.
	interval _ self encompassLine: self selectionInterval.
	paragraph replaceFrom: interval first to: interval last with:
		((paragraph text copyFrom: interval first to: interval last) addAttribute: attr) displaying: true.
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/19/2002 18:27'!
setSearchString
	"Make the current selection, if any, be the current search string."
	self hasCaret ifTrue: [view flash. ^ self].
	self setSearch:  self selection string! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'dgd 8/28/2004 13:59'!
spawn
	"Create and schedule a message browser for the code of the model's 
	selected message. Retain any edits that have not yet been accepted."
	| code |
	code _ paragraph text string.
	self cancel.
	model notNil ifTrue:[model spawn: code].
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 9/7/1999 08:44'!
spawnWorkspace
	| toUse |
	self selectLine.
	toUse _ self selection asString.
	toUse size > 0 ifFalse:
		[toUse _ paragraph text string.
		toUse size > 0 ifFalse: [^ self flash]].
	"NB: BrowserCodeController's version does a cancel here"
	self terminateAndInitializeAround:
		[Utilities openScratchWorkspaceLabeled: 'Untitled' contents: toUse]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 4/29/96'!
specialMenuItems
	"Refer to comment under #presentSpecialMenu.  .
	 : added objectsReferencingIt,"

	^ #(	'Transcript cr; show: ''testing'''
			'view superView model inspect'
			'view superView model browseObjClass'
			'view display'
			'self inspect'
			'view backgroundColor: Color fromUser'
			'view topView inspect'
			'self compareToClipboard'
			'view insideColor: Form white'
			'self objectsReferencingIt'
		) ! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'SqR 11/14/2000 12:15'!
undo
	"Reset the state of the paragraph prior to the previous edit.
	 If another ParagraphEditor instance did that edit, UndoInterval is invalid;
	 just recover the contents of the undo-buffer at the start of the paragraph."

	sensor flushKeyboard. "a way to flush stuck keys"
	self closeTypeIn.

	UndoParagraph == paragraph ifFalse: "Can't undo another paragraph's edit"
		[UndoMessage _ Message selector: #undoReplace.
		UndoInterval _ 1 to: 0.
		Undone _ true].
	UndoInterval ~= self selectionInterval ifTrue: "blink the actual target"
		[self selectInterval: UndoInterval; deselect].

	"Leave a signal of which phase is in progress"
	UndoParagraph _ Undone ifTrue: [#redoing] ifFalse: [#undoing].
	UndoMessage sentTo: self.
	UndoParagraph _ paragraph! !


!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:37'!
adjustSelection: directionBlock
	"Helper function for Cursor movement. Always moves point thus allowing selections to shrink. "
	"See also expandSelection:"
	"Accepts a one argument Block that computes the new postion given an old one."
	| newPosition |
	newPosition _ directionBlock value: self pointIndex.
	self selectMark: self markIndex point: newPosition.
	^true.! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 10/28/2003 12:11'!
afterSelectionInsertAndSelect: aString

	self insertAndSelect: aString at: self stopIndex ! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/17/2002 16:11'!
computeIntervalFrom: start to: stop
	"Select the designated characters, inclusive.  Make no visual changes."

	self setMark: start.
	self setPoint: stop + 1.! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/6/1998 15:21'!
correctFrom: start to: stop with: aString
	"Make a correction in the model that the user has authorised from somewhere else in the system (such as from the compilier).  The user's selection is not changed, only corrected."
	| wasShowing userSelection delta loc |
	aString = '#insert period' ifTrue:
		[loc _ start.
		[(loc _ loc-1)>0 and: [(paragraph text string at: loc) isSeparator]]
			whileTrue: [loc _ loc-1].
		^ self correctFrom: loc+1 to: loc with: '.'].
	(wasShowing _ selectionShowing) ifTrue: [ self reverseSelection ].
	userSelection _ self selectionInterval.

	self selectInvisiblyFrom: start to: stop.
	self replaceSelectionWith: aString asText.

	delta _ aString size - (stop - start + 1).
	self selectInvisiblyFrom:
		userSelection first + (userSelection first > start ifFalse: [ 0 ] ifTrue: [ delta ])
		to: userSelection last + (userSelection last > start ifFalse: [ 0 ] ifTrue: [ delta ]).
	wasShowing ifTrue: [ self reverseSelection ].
! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 17:21'!
encompassLine: anInterval
	"Return an interval that encompasses the entire line"
	| string left right |
	string _ paragraph text string.
	left _ (string lastIndexOf: Character cr startingAt: anInterval first - 1 ifAbsent:[0]) + 1.
	right _ (string indexOf: Character cr startingAt: anInterval last + 1 ifAbsent: [string size + 1]) - 1.
	^left to: right! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 12/17/1998 09:41'!
insertAndSelect: aString at: anInteger

	self replace: (anInteger to: anInteger - 1)
		with: (Text string: (' ' , aString)
					attributes: emphasisHere)
		and: [self selectAndScroll]! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/6/1998 15:25'!
nextTokenFrom: start direction: dir
	"simple token-finder for compiler automated corrections"
	| loc str |
	loc _ start + dir.
	str _ paragraph text string.
	[(loc between: 1 and: str size) and: [(str at: loc) isSeparator]]
		whileTrue: [loc _ loc + dir].
	^ loc! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/20/1998 08:31'!
notify: aString at: anInteger in: aStream 
	"The compilation of text failed. The syntax error is noted as the argument, 
	aString. Insert it in the text at starting character position anInteger."

	self insertAndSelect: aString at: (anInteger max: 1)! !

!ParagraphEditor methodsFor: 'new selection'!
selectAt: characterIndex 
	"Deselect, then place the caret before the character at characterIndex.
	 Be sure it is in view."

	self selectFrom: characterIndex to: characterIndex - 1! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 16:50'!
selectFrom: start to: stop
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	(start = self startIndex and: [stop + 1 = self stopIndex]) ifFalse:
		[self deselect.
		self selectInvisiblyFrom: start to: stop].
	self selectAndScroll! !

!ParagraphEditor methodsFor: 'new selection'!
selectInterval: anInterval
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	self selectFrom: anInterval first to: anInterval last! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/9/1998 20:59'!
selectInvisiblyFrom: start to: stop
	"Select the designated characters, inclusive.  Make no visual changes."

	^ self computeIntervalFrom: start to: stop! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:17'!
selectInvisiblyMark: mark point: point
	"Select the designated characters, inclusive.  Make no visual changes."

	^ self computeIntervalFrom: mark to: point! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 17:17'!
selectLine
	"Make the receiver's selection, if it currently consists of an insertion point only, encompass the current line."
	self hasSelection ifTrue:[^self].
	self selectInterval: (self encompassLine: self selectionInterval)! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:18'!
selectMark: mark point: point
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	(mark =  self markIndex and: [point + 1 = self pointIndex]) ifFalse:
		[self deselect.
		self selectInvisiblyMark: mark point: point].
	self selectAndScroll! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 18:49'!
selectPrecedingIdentifier
	"Invisibly select the identifier that ends at the end of the selection, if any."

	| string sep stop tok |
	tok _ false.
	string _ paragraph text string.
	stop _ self stopIndex - 1.
	[stop > 0 and: [(string at: stop) isSeparator]] whileTrue: [stop _ stop - 1].
	sep _ stop.
	[sep > 0 and: [(string at: sep) tokenish]] whileTrue: [tok _ true. sep _ sep - 1].
	tok ifTrue: [self selectInvisiblyFrom: sep + 1 to: stop]! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 16:51'!
selectWord
	"Select delimited text or word--the result of double-clicking."

	| openDelimiter closeDelimiter direction match level leftDelimiters rightDelimiters
	string here hereChar start stop |
	string _ paragraph text string.
	here _ self pointIndex.
	(here between: 2 and: string size)
		ifFalse: ["if at beginning or end, select entire string"
			^self selectFrom: 1 to: string size].
	leftDelimiters _ '([{<''"
'.
	rightDelimiters _ ')]}>''"
'.
	openDelimiter _ string at: here - 1.
	match _ leftDelimiters indexOf: openDelimiter.
	match > 0
		ifTrue: 
			["delimiter is on left -- match to the right"
			start _ here.
			direction _ 1.
			here _ here - 1.
			closeDelimiter _ rightDelimiters at: match]
		ifFalse: 
			[openDelimiter _ string at: here.
			match _ rightDelimiters indexOf: openDelimiter.
			match > 0
				ifTrue: 
					["delimiter is on right -- match to the left"
					stop _ here - 1.
					direction _ -1.
					closeDelimiter _ leftDelimiters at: match]
				ifFalse: ["no delimiters -- select a token"
					direction _ -1]].
	level _ 1.
	[level > 0 and: [direction > 0
			ifTrue: [here < string size]
			ifFalse: [here > 1]]]
		whileTrue: 
			[hereChar _ string at: (here _ here + direction).
			match = 0
				ifTrue: ["token scan goes left, then right"
					hereChar tokenish
						ifTrue: [here = 1
								ifTrue: 
									[start _ 1.
									"go right if hit string start"
									direction _ 1]]
						ifFalse: [direction < 0
								ifTrue: 
									[start _ here + 1.
									"go right if hit non-token"
									direction _ 1]
								ifFalse: [level _ 0]]]
				ifFalse: ["bracket match just counts nesting level"
					hereChar = closeDelimiter
						ifTrue: [level _ level - 1"leaving nest"]
						ifFalse: [hereChar = openDelimiter 
									ifTrue: [level _ level + 1"entering deeper nest"]]]].

	level > 0 ifTrue: ["in case ran off string end"	here _ here + direction].
	direction > 0
		ifTrue: [self selectFrom: start to: here - 1]
		ifFalse: [self selectFrom: here + 1 to: stop]! !


!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:51'!
comment
	"All key actions that are neither editing nor typing actions have to
	send closeTypeIn at first. See comment in openTypeIn closeTypeIn"! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:08'!
cursorDown: characterStream 

	"Private - Move cursor from position in current line to same position in
	next line. If next line too short, put at end. If shift key down,
	select."
	self closeTypeIn: characterStream.
	self 
		moveCursor:[:position | self
				sameColumn: position
				newLine:[:line | line + 1]
				forward: true]
		forward: true
		specialBlock:[:dummy | dummy].
	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 10/28/2003 10:47'!
cursorEnd: characterStream 

	"Private - Move cursor end of current line."
	| string |
	self closeTypeIn: characterStream.
	string _ paragraph text string.
	self
		moveCursor:
			[:position | Preferences wordStyleCursorMovement
				ifTrue:[| targetLine |
					targetLine _ paragraph lines at:(paragraph lineIndexOfCharacterIndex: position).
					targetLine = paragraph lines last
						ifTrue:[targetLine last + 1]
						ifFalse:[targetLine last]]
				ifFalse:[
					string
						indexOf: Character cr
						startingAt: position
						ifAbsent:[string size + 1]]]
		forward: true
		specialBlock:[:dummy | string size + 1].
	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/20/2002 12:14'!
cursorHome: characterStream 

	"Private - Move cursor from position in current line to beginning of
	current line. If control key is pressed put cursor at beginning of text"

	| string |

	string _ paragraph text string.
	self
		moveCursor: [ :position | Preferences wordStyleCursorMovement
				ifTrue:[
					(paragraph lines at:(paragraph lineIndexOfCharacterIndex: position)) first]
				ifFalse:[
					(string
						lastIndexOf: Character cr
						startingAt: position - 1
						ifAbsent:[0]) + 1]]
		forward: false
		specialBlock: [:dummy | 1].
	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/19/2002 20:07'!
cursorLeft: characterStream 
	"Private - Move cursor left one character if nothing selected, otherwise 
	move cursor to beginning of selection. If the shift key is down, start 
	selecting or extending current selection. Don't allow cursor past 
	beginning of text"

	self closeTypeIn: characterStream.
	self
		moveCursor:[:position | position - 1 max: 1]
		forward: false
		specialBlock:[:position | self previousWord: position].
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:09'!
cursorPageDown: characterStream 

	self closeTypeIn: characterStream.
	self 
		moveCursor: [:position |
			self
				sameColumn: position
				newLine:[:lineNo | lineNo + self pageHeight]
				forward: true]
		forward: true
		specialBlock:[:dummy | dummy].
	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:09'!
cursorPageUp: characterStream 

	self closeTypeIn: characterStream.
	self 
		moveCursor: [:position |
			self
				sameColumn: position
				newLine:[:lineNo | lineNo - self pageHeight]
				forward: false]
		forward: false
		specialBlock:[:dummy | dummy].
	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/19/2002 20:01'!
cursorRight: characterStream 
	"Private - Move cursor right one character if nothing selected, 
	otherwise move cursor to end of selection. If the shift key is down, 
	start selecting characters or extending already selected characters. 
	Don't allow cursor past end of text"

	self closeTypeIn: characterStream.
	self
		moveCursor: [:position | position + 1]
		forward: true
		specialBlock:[:position | self nextWord: position].
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:15'!
cursorUp: characterStream 

"Private - Move cursor from position in current line to same position in
prior line. If prior line too short, put at end"

	self closeTypeIn: characterStream.
	self
		moveCursor: [:position | self
				sameColumn: position
				newLine:[:line | line - 1]
				forward: false]
		forward: false
		specialBlock:[:dummy | dummy].
	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'di 12/3/2001 21:49'!
escapeToDesktop: characterStream 
	"Pop up a morph to field keyboard input in the context of the desktop"

	Smalltalk isMorphic ifTrue: [ActiveWorld putUpWorldMenuFromEscapeKey].
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'dvf 12/8/2001 00:46'!
raiseContextMenu: characterStream 
	"AFAIK, this is never called in morphic, because a subclass overrides it. Which is good, because a ParagraphEditor doesn't know about Morphic and thus duplicates the text-editing actions that really belong in the specific application, not the controller. So the context menu this would raise is likely to be out of date."
	self yellowButtonActivity.
	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'!
selectCurrentTypeIn: characterStream 
	"Select what would be replaced by an undo (e.g., the last typeIn)."

	| prior |

	self closeTypeIn: characterStream.
	prior _ otherInterval.
	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self selectInterval: UndoInterval.
	otherInterval _ prior.
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'sma 12/15/1999 11:46'!
selectWord: characterStream
	sensor keyboard.
	self closeTypeIn: characterStream.
	self selectWord.
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'!
setSearchString: characterStream
	"Establish the current selection as the current search string."

	| aString |
	self closeTypeIn: characterStream.
	sensor keyboard.
	self lineSelectAndEmptyCheck: [^ true].
	aString _  self selection string.
	aString size == 0
		ifTrue:
			[self flash]
		ifFalse:
			[self setSearch: aString].
	^ true! !


!ParagraphEditor methodsFor: 'parenblinking' stamp: 'mir 8/3/2004 13:31'!
blinkParenAt: parenLocation 
	self text
		addAttribute: TextEmphasis bold
		from: parenLocation
		to: parenLocation.
	lastParentLocation _ parenLocation.! !

!ParagraphEditor methodsFor: 'parenblinking' stamp: 'AB 1/7/2002 04:03'!
blinkPrevParen
	| openDelimiter closeDelimiter level string here hereChar |
	string _ paragraph text string.
	here _ startBlock stringIndex.
	openDelimiter _ sensor keyboardPeek.
	closeDelimiter _ '([{' at: (')]}' indexOf: openDelimiter).
	level _ 1.
	[level > 0 and: [here > 2]]
		whileTrue:
			[hereChar _ string at: (here _ here - 1).
			hereChar = closeDelimiter
				ifTrue:
					[level _ level - 1.
					level = 0
						ifTrue: [^ self blinkParenAt: here]]
				ifFalse:
					[hereChar = openDelimiter
						ifTrue: [level _ level + 1]]].! !

!ParagraphEditor methodsFor: 'parenblinking' stamp: 'mir 8/3/2004 13:31'!
clearParens
	lastParentLocation ifNotNil:
		[self text string size >= lastParentLocation ifTrue: [
			self text
				removeAttribute: TextEmphasis bold
				from: lastParentLocation
				to: lastParentLocation]]
! !

!ParagraphEditor methodsFor: 'parenblinking' stamp: 'mikki 1/5/2005 14:10'!
dispatchOnCharacter: char with: typeAheadStream
	"Carry out the action associated with this character, if any.
	Type-ahead is passed so some routines can flush or use it."

	| honorCommandKeys |
	self clearParens.
  
	"mikki 1/3/2005 21:31 Preference for auto-indent on return added."
	char asciiValue = 13 ifTrue: [
		^Preferences autoIndent 
			ifTrue: [
				sensor controlKeyPressed
					ifTrue: [self normalCharacter: typeAheadStream]
					ifFalse: [self crWithIndent: typeAheadStream]]
			ifFalse: [
				sensor controlKeyPressed
					ifTrue: [self crWithIndent: typeAheadStream]
					ifFalse: [self normalCharacter: typeAheadStream]]].

	((honorCommandKeys _ Preferences cmdKeysInText) and: [char = Character enter])
		ifTrue: [^ self dispatchOnEnterWith: typeAheadStream].
		
	"Special keys overwrite crtl+key combinations - at least on Windows. To resolve this
	conflict, assume that keys other than cursor keys aren't used together with Crtl." 
	((self class specialShiftCmdKeys includes: char asciiValue) and: [char asciiValue < 27])
		ifTrue: [^ sensor controlKeyPressed
			ifTrue: [self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream]
			ifFalse: [self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]].

	"backspace, and escape keys (ascii 8 and 27) are command keys"
	((honorCommandKeys and: [sensor commandKeyPressed]) or: [self class specialShiftCmdKeys includes: char asciiValue]) ifTrue:
		[^ sensor leftShiftDown
			ifTrue:
				[self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream]
			ifFalse:
				[self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]].

	"the control key can be used to invoke shift-cmd shortcuts"
	(honorCommandKeys and: [sensor controlKeyPressed])
		ifTrue:
			[^ self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream].

	(')]}' includes: char)
		ifTrue: [self blinkPrevParen].

	^ self perform: #normalCharacter: with: typeAheadStream! !


!ParagraphEditor methodsFor: 'scrolling'!
computeMarkerRegion 
	"Refer to the comment in ScrollController|computeMarkerRegion."

	paragraph compositionRectangle height = 0
		ifTrue:	[^0@0 extent: Preferences scrollBarWidth @ scrollBar inside height]
		ifFalse:	[^0@0 extent:
					Preferences scrollBarWidth 
						@ ((paragraph clippingRectangle height asFloat /
							self scrollRectangleHeight * scrollBar inside height) rounded
							min: scrollBar inside height)]! !

!ParagraphEditor methodsFor: 'scrolling'!
markerDelta

	^marker top - scrollBar top - ((paragraph clippingRectangle top -
		paragraph compositionRectangle top) asFloat /
			(self scrollRectangleHeight max: 1) asFloat *
				scrollBar height asFloat) rounded! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollAmount 
	"Refer to the comment in ScrollController|scrollAmount."

	^sensor cursorPoint y - scrollBar top! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollBar
	^ scrollBar! !

!ParagraphEditor methodsFor: 'scrolling' stamp: 'BG 12/12/2003 15:31'!
scrollBy: heightToMove
	"Move the paragraph by heightToMove, and reset the text selection."
	^ paragraph scrollBy: heightToMove withSelectionFrom: self pointBlock to: self markBlock! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollRectangleHeight

	^paragraph compositionRectangle height 
		+ paragraph lineGrid! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollToBottom
	"Scroll so that the tail end of the text is visible in the view.  5/6/96 sw"

	self scrollView: (paragraph clippingRectangle bottom 
		- paragraph compositionRectangle bottom)! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollToTop
	"Scroll so that the paragraph is at the top of the view."

	self scrollView: (paragraph clippingRectangle top 
		- paragraph compositionRectangle top)! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollView: anInteger 
	"Paragraph scrolling uses opposite polarity"
	^ self scrollBy: anInteger negated! !

!ParagraphEditor methodsFor: 'scrolling'!
updateMarker
	"A variation of computeMarkerRegion--only redisplay the marker in the scrollbar if an actual change has occurred in the positioning of the paragraph."
	self moveMarkerTo: self computeMarkerRegion! !

!ParagraphEditor methodsFor: 'scrolling'!
viewDelta 
	"Refer to the comment in ScrollController|viewDelta."

	^paragraph clippingRectangle top 
		- paragraph compositionRectangle top 
		- ((marker top - scrollBar inside top) asFloat 
				/ scrollBar inside height asFloat * self scrollRectangleHeight asFloat)
			roundTo: paragraph lineGrid! !


!ParagraphEditor methodsFor: 'sensor access'!
processBlueButton
	"The user pressed the blue button on the mouse. Determine what action 
	to take."

	^self! !

!ParagraphEditor methodsFor: 'sensor access'!
processKeyboard
	"Determine whether the user pressed the keyboard. If so, read the keys."

	sensor keyboardPressed ifTrue: [self readKeyboard]! !

!ParagraphEditor methodsFor: 'sensor access'!
processMouseButtons
	"Determine whether the user pressed any mouse button. For each possible 
	button, determine what actions to take."

	sensor redButtonPressed ifTrue: [self processRedButton].
	sensor yellowButtonPressed ifTrue: [self processYellowButton].
	sensor blueButtonPressed ifTrue: [self processBlueButton]! !

!ParagraphEditor methodsFor: 'sensor access' stamp: 'th 9/19/2002 18:24'!
processRedButton
	"The user pressed a red mouse button, meaning create a new text 
	selection. Highlighting the selection is carried out by the paragraph 
	itself. Double clicking causes a selection of the area between the nearest 
	enclosing delimitors."

	|  selectionBlocks clickPoint oldDelta oldInterval previousMarkBlock previousPointBlock |

	clickPoint _ sensor cursorPoint.
	(view containsPoint: clickPoint) ifFalse: [^ self].
	(paragraph clickAt: clickPoint for: model controller: self) ifTrue: [^ self].
	oldInterval _ self selectionInterval.
	previousMarkBlock _ self markBlock.
	previousPointBlock _ self pointBlock.
	oldDelta _ paragraph scrollDelta.
	sensor leftShiftDown
		ifFalse:
			[self deselect.
			self closeTypeIn.
			selectionBlocks _ paragraph mouseSelect: clickPoint]
		ifTrue:
			[selectionBlocks _ paragraph extendSelectionMark: self markBlock pointBlock: self pointBlock.
			self closeTypeIn].
	selectionShowing _ true.
	self markBlock: (selectionBlocks at: 1).
	self pointBlock: (selectionBlocks at: 2).
	(self hasCaret
		and: [previousMarkBlock = self markBlock and: [previousPointBlock = self pointBlock]])
		ifTrue: [self selectWord].
	oldDelta ~= paragraph scrollDelta "case of autoscroll"
			ifTrue: [self updateMarker].
	self setEmphasisHere.
	(self isDisjointFrom: oldInterval) ifTrue:
		[otherInterval _ oldInterval]! !

!ParagraphEditor methodsFor: 'sensor access'!
processYellowButton
	"User pressed the yellow button on the mouse. Determine what actions to 
	take."

	self yellowButtonActivity! !


!ParagraphEditor methodsFor: 'typing support' stamp: 'yo 3/16/2004 13:05'!
backTo: startIndex
	"During typing, backspace to startIndex.  Deleted characters fall into three
	 clusters, from left to right in the text: (1) preexisting characters that were
	 backed over; (2) newly typed characters that were backed over (excluding
	 typeahead, which never even appears); (3) preexisting characters that
	 were highlighted before typing began.  If typing has not yet been opened,
	 open it and watch for the first and third cluster.  If typing has been opened,
	 watch for the first and second cluster.  Save characters from the first and third
	 cluster in UndoSelection.  Tally characters from the first cluster in UndoMessage's parameter.
	 Delete all the clusters.  Do not alter Undoer or UndoInterval (except via
	 openTypeIn).  The code is shorter than the comment."

	| saveLimit newBackovers |
	saveLimit _ beginTypeInBlock == nil
		ifTrue: [self openTypeIn. UndoSelection _ self nullText. self stopIndex]
		ifFalse: [self startOfTyping].
	self setMark: startIndex.
	startIndex < saveLimit ifTrue:
		[newBackovers _ self startOfTyping - startIndex.
		beginTypeInBlock _ self startIndex.
		UndoSelection replaceFrom: 1 to: 0 with:
			(paragraph text copyFrom: startIndex to: saveLimit - 1).
		UndoMessage argument: (UndoMessage argument ifNil: [1]) + newBackovers].
	self zapSelectionWith: self nullText.
	self unselect! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/19/2002 17:40'!
closeTypeIn
	"See comment in openTypeIn.  It is important to call closeTypeIn before executing
	 any non-typing key, making a new selection, etc.  It is called automatically for
	 menu commands.
	 Typing commands can call 'closeTypeIn: aCharacterStream' instead of this to
	 save typeahead.  Undoer & Redoer: undoAndReselect:redoAndReselect:."

	| begin stop |
	beginTypeInBlock == nil ifFalse:
		[(UndoMessage sends: #noUndoer) ifTrue: "should always be true, but just in case..."
			[begin _ self startOfTyping.
			stop _ self stopIndex.
			self undoer: #undoAndReselect:redoAndReselect:
				with: (begin + UndoMessage argument to: begin + UndoSelection size - 1)
				with: (stop to: stop - 1).
			UndoInterval _ begin to: stop - 1].
		beginTypeInBlock _ nil]! !

!ParagraphEditor methodsFor: 'typing support'!
closeTypeIn: characterStream
	"Call instead of closeTypeIn when you want typeahead to be inserted before the
	 control character is executed, e.g., from Ctrl-V."

	self insertTypeAhead: characterStream.
	self closeTypeIn! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 9/7/1999 11:26'!
dispatchOnEnterWith: typeAheadStream
	"Enter key hit.  Treat is as an 'accept', viz a synonym for cmd-s.  If cmd key is down, treat is as a synonym for print-it. "

	sensor keyboard.  "consume enter key"
	self terminateAndInitializeAround: [
	sensor commandKeyPressed
		ifTrue:
			[self printIt.]
		ifFalse: 
			[self closeTypeIn: typeAheadStream.
			self accept].
	].
	^ true! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 6/14/1998 13:08'!
doneTyping
	beginTypeInBlock _ nil! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/17/2002 16:23'!
insertTypeAhead: typeAhead
	typeAhead position = 0 ifFalse:
		[self zapSelectionWith: (Text string: typeAhead contents emphasis: emphasisHere).
		typeAhead reset.
		self unselect]! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/18/2002 16:48'!
openTypeIn
	"Set up UndoSelection to null text (to be added to by readKeyboard and backTo:),
	 beginTypeInBlock to keep track of the leftmost backspace, and UndoParameter to tally
	 how many deleted characters were backspaced over rather than 'cut'.
	 You can't undo typing until after closeTypeIn."

	beginTypeInBlock == nil ifTrue:
		[UndoSelection _ self nullText.
		self undoer: #noUndoer with: 0.
		beginTypeInBlock _ self startIndex]! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/19/2002 18:26'!
readKeyboard
	"Key struck on the keyboard. Find out which one and, if special, carry 
	out the associated special action. Otherwise, add the character to the 
	stream of characters.  Undoer & Redoer: see closeTypeIn."

	| typeAhead char |
	typeAhead _ WriteStream on: (String new: 128).
	[sensor keyboardPressed] whileTrue: 
		[self deselect.
		 [sensor keyboardPressed] whileTrue: 
			[char _ sensor keyboardPeek.
			(self dispatchOnCharacter: char with: typeAhead) ifTrue:
				[self doneTyping.
				self setEmphasisHere.
				^self selectAndScroll; updateMarker].
			self openTypeIn].
		self hasSelection ifTrue: "save highlighted characters"
			[UndoSelection _ self selection]. 
		self zapSelectionWith: 
			(Text string: typeAhead contents emphasis: emphasisHere).
		typeAhead reset.
		self unselect.
		sensor keyboardPressed ifFalse: 
			[self selectAndScroll.
			sensor keyboardPressed
				ifFalse: [self updateMarker]]]! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/18/2002 16:49'!
setEmphasisHere

	emphasisHere _ (paragraph text attributesAt: (self pointIndex - 1 max: 1) forStyle: paragraph textStyle)
					select: [:att | att mayBeExtended]! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/17/2002 16:23'!
simulatedKeystroke: char
	"Accept char as if it were struck on the keyboard.  This version does not yet deal with command keys, and achieves update in the receiver's typically inactive window via the sledge-hammer of uncache-bits."

	self deselect.
	self openTypeIn.
	self markBlock = self pointBlock ifFalse: [UndoSelection _ self selection].
	self zapSelectionWith:
		(Text string: char asString emphasis: emphasisHere).
	self userHasEdited.
	self unselect.
	self selectAndScroll.
	self updateMarker.
	view ifNotNil:
		[view topView uncacheBits
		"in mvc, this makes sure the recognized character shows up in the pane right now; in morphic, a different mechanism is used for the same effect -- see TextMorphEditor method #recognizeCharactersWhileMouseIn:"]
! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:45'!
startOfTyping
	"Compatibility during change from characterBlock to integer"
	beginTypeInBlock == nil ifTrue: [^ nil].
	beginTypeInBlock isNumber ifTrue: [^ beginTypeInBlock].
	"Last line for compatibility during change from CharacterBlock to Integer."
	^ beginTypeInBlock stringIndex
	! !


!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/20/2002 11:22'!
argAdvance: characterStream
	"Invoked by Ctrl-a.  Useful after Ctrl-q.
	 Search forward from the end of the selection for a colon followed by
		a space.  Place the caret after the space.  If none are found, place the
		caret at the end of the text.  Does not affect the undoability of the 
	 	previous command."

	| start |
	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	start _ paragraph text findString: ': ' startingAt: self stopIndex.
	start = 0 ifTrue: [start _ paragraph text size + 1].
	self selectAt: start + 2.
	^true! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 10/21/2003 15:46'!
backWord: characterStream 
	"If the selection is not a caret, delete it and leave it in the backspace buffer.
	 Else if there is typeahead, delete it.
	 Else, delete the word before the caret."

	| startIndex |
	sensor keyboard.
	characterStream isEmpty
		ifTrue:
			[self hasCaret
				ifTrue: "a caret, delete at least one character"
					[startIndex _ 1 max: self markIndex - 1.
					[startIndex > 1 and:
						[(paragraph text at: startIndex - 1) asCharacter tokenish]]
						whileTrue:
							[startIndex _ startIndex - 1]]
				ifFalse: "a non-caret, just delete it"
					[startIndex _ self markIndex].
			self backTo: startIndex]
		ifFalse:
			[characterStream reset].
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/19/2002 18:23'!
backspace: characterStream 
	"Backspace over the last character."

	| startIndex |
	sensor leftShiftDown ifTrue: [^ self backWord: characterStream].
	characterStream isEmpty
		ifTrue:
			[startIndex _ self markIndex +
				(self hasCaret ifTrue: [0] ifFalse: [1]).
			[sensor keyboardPressed and:
			 [sensor keyboardPeek asciiValue = 8]] whileTrue: [
				"process multiple backspaces"
				sensor keyboard.
				startIndex _ 1 max: startIndex - 1.
			].
			self backTo: startIndex]
		ifFalse:
			[sensor keyboard.
			characterStream skip: -1].
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
changeStyle: characterStream 
	"Put up the style-change menu"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self changeStyle.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/20/2002 11:25'!
crWithIndent: characterStream 
	"Replace the current text selection with CR followed by as many tabs
	as on the current line (+/- bracket count) -- initiated by Shift-Return."
	| char s i tabCount |
	sensor keyboard.		"flush character"
	s _ paragraph string.
	i _ self stopIndex.
	tabCount _ 0.
	[(i _ i-1) > 0 and: [(char _ s at: i) ~= Character cr]]
		whileTrue:  "Count tabs and brackets (but not a leading bracket)"
		[(char = Character tab and: [i < s size and: [(s at: i+1) ~= $[ ]]) ifTrue: [tabCount _ tabCount + 1].
		char = $[ ifTrue: [tabCount _ tabCount + 1].
		char = $] ifTrue: [tabCount _ tabCount - 1]].
	characterStream crtab: tabCount.  "Now inject CR with tabCount tabs"
	^ false! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sw 4/30/2001 21:20'!
cursorTopHome: characterStream 
	"Put cursor at beginning of text -- invoked from cmd-H shortcut, useful for keyboards that have no home key."
	
	sensor keyboard.
	self selectAt: 1.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
displayIfFalse: characterStream 
	"Replace the current text selection with the text 'ifFalse:'--initiated by 
	ctrl-f."

	sensor keyboard.		"flush character"
	characterStream nextPutAll: 'ifFalse:'.
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
displayIfTrue: characterStream 
	"Replace the current text selection with the text 'ifTrue:'--initiated by 
	ctrl-t."

	sensor keyboard.		"flush character"
	characterStream nextPutAll: 'ifTrue:'.
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
doAgainMany: characterStream 
	"Do the previous thing again repeatedly. 1/26/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self againOrSame: (UndoMessage sends: #undoAgain:andReselect:typedKey:) many: true.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
doAgainOnce: characterStream 
	"Do the previous thing again once. 1/26/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self again.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
find: characterStream
	"Prompt the user for what to find, then find it, searching from the current selection onward.  1/24/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self find.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
findAgain: characterStream 
	"Find the desired text again.  1/24/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self findAgain.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/18/2002 11:39'!
forwardDelete: characterStream
	"Delete forward over the next character.
	  Make Undo work on the whole type-in, not just the one char.
	wod 11/3/1998: If there was a selection use #zapSelectionWith: rather than #backspace: which was 'one off' in deleting the selection. Handling of things like undo or typeIn area were not fully considered."
	| startIndex usel upara uinterval ind stopIndex |
	startIndex _ self mark.
	startIndex > paragraph text size ifTrue:
		[sensor keyboard.
		^ false].
	self hasSelection ifTrue:
		["there was a selection"
		sensor keyboard.
		self zapSelectionWith: self nullText.
		^ false].
	"Null selection - do the delete forward"
	beginTypeInBlock == nil	"no previous typing.  openTypeIn"
		ifTrue: [self openTypeIn. UndoSelection _ self nullText].
	uinterval _ UndoInterval deepCopy.
	upara _ UndoParagraph deepCopy.
	stopIndex := startIndex.
	(sensor keyboard asciiValue = 127 and: [sensor leftShiftDown])
		ifTrue: [stopIndex := (self nextWord: stopIndex) - 1].
	self selectFrom: startIndex to: stopIndex.
	self replaceSelectionWith: self nullText.
	self selectFrom: startIndex to: startIndex-1.
	UndoParagraph _ upara.  UndoInterval _ uinterval.
	UndoMessage selector == #noUndoer ifTrue: [
		(UndoSelection isText) ifTrue: [
			usel _ UndoSelection.
			ind _ startIndex. "UndoInterval startIndex"
			usel replaceFrom: usel size + 1 to: usel size with:
				(UndoParagraph text copyFrom: ind to: ind).
			UndoParagraph text replaceFrom: ind to: ind with:
self nullText]].
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
normalCharacter: characterStream 
	"A nonspecial character is to be added to the stream of characters."

	characterStream nextPut: sensor keyboard.
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/19/2002 18:25'!
querySymbol: characterStream
	"Invoked by Ctrl-q to query the Symbol table and display alternate symbols.
	 See comment in completeSymbol:lastOffering: for details."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.	"keep typeahead"
	self hasCaret
		ifTrue: "Ctrl-q typed when a caret"
			[self perform: #completeSymbol:lastOffering: withArguments:
				((UndoParagraph == paragraph and: [UndoMessage sends: #undoQuery:lastOffering:])
					ifTrue: [UndoMessage arguments] "repeated Ctrl-q"
					ifFalse: [Array with: nil with: nil])] "initial Ctrl-q"
		ifFalse: "Ctrl-q typed when statements were highlighted"
			[view flash].
	^true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
search: characterStream
	"Invoked by Ctrl-S.  Same as 'again', but always uses the existing FindText
	 and ChangeText regardless of the last edit."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self againOrSame: true. "true means use same keys"
	^true! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sw 8/29/2000 14:58'!
selectAll
	"Make the selection be all the characters of the receiver"

	self selectFrom: 1 to: paragraph text string size! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
selectAll: characterStream 
	"select everything, invoked by cmd-a.  1/17/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self selectFrom: 1 to: paragraph text string size.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/19/2002 17:34'!
simulatedBackspace
	"Backspace over the last character, derived from hand-char recognition.  2/5/96 sw"

	| startIndex |
	startIndex _ self markIndex + (self hasSelection ifTrue: [1] ifFalse: [0]).

	startIndex _ 1 max: startIndex - 1.
	self backTo: startIndex.
	^ false! !


!ParagraphEditor methodsFor: 'undo support'!
isDoing
	"Call from a doer/undoer/redoer any time to see which it is."

	^(self isUndoing | self isRedoing) not! !

!ParagraphEditor methodsFor: 'undo support'!
isRedoing
	"Call from a doer/undoer/redoer any time to see which it is."

	^UndoParagraph == #redoing! !

!ParagraphEditor methodsFor: 'undo support'!
isUndoing
	"Call from a doer/undoer/redoer any time to see which it is."

	^UndoParagraph == #undoing! !

!ParagraphEditor methodsFor: 'undo support'!
noUndoer
	"The Undoer to use when the command can not be undone.  Checked for
	 specially by readKeyboard."

	UndoMessage _ Message selector: #noUndoer! !

!ParagraphEditor methodsFor: 'undo support'!
undoMessage: aMessage forRedo: aBoolean
	"Call this from an undoer/redoer to set up UndoMessage as the
	 corresponding redoer/undoer.  Also set up UndoParagraph, as well
	 as the state variable Undone.  It is assumed that UndoInterval has been
	 established (generally by zapSelectionWith:) and that UndoSelection has been
	 saved (generally by replaceSelectionWith: or replace:With:and:)."

	self isDoing ifTrue: [UndoParagraph _ paragraph].
	UndoMessage _ aMessage.
	Undone _ aBoolean! !

!ParagraphEditor methodsFor: 'undo support'!
undoer: aSelector
	"See comment in undoMessage:.  Use this version when aSelector has no arguments, and you are doing or redoing and want to prepare for undoing."

	self undoMessage: (Message selector: aSelector) forRedo: false! !

!ParagraphEditor methodsFor: 'undo support'!
undoer: aSelector with: arg1
	"See comment in undoMessage:.  Use this version when aSelector has one argument, and you are doing or redoing and want to prepare for undoing."

	self undoMessage: (Message selector: aSelector argument: arg1) forRedo: false! !

!ParagraphEditor methodsFor: 'undo support'!
undoer: aSelector with: arg1 with: arg2
	"See comment in undoMessage:.  Use this version when aSelector has two arguments, and you are doing or redoing and want to prepare for undoing."

	self undoMessage: (Message selector: aSelector arguments: (Array with: arg1 with: arg2)) forRedo: false! !

!ParagraphEditor methodsFor: 'undo support'!
undoer: aSelector with: arg1 with: arg2 with: arg3
	"See comment in undoMessage:.  Use this version when aSelector has three arguments, and you are doing or redoing and want to prepare for undoing."

	self undoMessage: (Message selector: aSelector arguments: (Array with: arg1 with: arg2 with: arg3)) forRedo: false! !


!ParagraphEditor methodsFor: 'undoers'!
undoAgain: indices andReselect: home typedKey: wasTypedKey
	"The last command was again.  Undo it. Redoer: itself."

	| findSize substText index subject |
	(self isRedoing & wasTypedKey) ifTrue: "redelete search key"
		[self selectInterval: home.
		self zapSelectionWith: self nullText].

	findSize _ (self isRedoing ifTrue: [FindText] ifFalse: [ChangeText]) size.
	substText _ self isUndoing ifTrue: [FindText] ifFalse: [ChangeText].
	(self isUndoing ifTrue: [indices size to: 1 by: -1] ifFalse: [1 to: indices size]) do:
		[:i |
		index _ indices at: i.
		(subject _ index to: index + findSize - 1) = self selectionInterval ifFalse:
			[self selectInterval: subject].
		FindText == ChangeText ifFalse: [self zapSelectionWith: substText]].

	self isUndoing
		ifTrue:  "restore selection to where it was when 'again' was invoked"
			[wasTypedKey
				ifTrue: "search started by typing key at a caret; restore it"
					[self selectAt: home first.
					self zapSelectionWith: FindText.
					self selectAt: home last + 1]
				ifFalse: [self selectInterval: home]].

	self undoMessage: UndoMessage forRedo: self isUndoing! !

!ParagraphEditor methodsFor: 'undoers'!
undoAndReselect: undoHighlight redoAndReselect: redoHighlight
	"Undo typing, cancel, paste, and other operations that are like replaces
	 but the selection is not the whole restored text after undo, redo, or both.
	 undoHighlight is selected after this phase and redoHighlight after the next phase.
	Redoer: itself."

	self replace: self selectionInterval with: UndoSelection and:
		[self selectInterval: undoHighlight].
	self undoMessage: (UndoMessage argument: redoHighlight) forRedo: self isUndoing
! !

!ParagraphEditor methodsFor: 'undoers'!
undoCutCopy: oldPasteBuffer
	"Undo of a cut, copy, or any edit that changed CurrentSelection.  Be sure
	 undo-copy does not lock the model.  Redoer: itself, so never isRedoing."

	| recentCut |
	recentCut _ self clipboardText.	
	UndoSelection size = UndoInterval size
		ifFalse: [self replaceSelectionWith: UndoSelection].
	self clipboardTextPut: oldPasteBuffer.
	self undoer: #undoCutCopy: with: recentCut! !

!ParagraphEditor methodsFor: 'undoers' stamp: 'th 9/19/2002 18:46'!
undoQuery: hintText lastOffering: selectorOrNil
	"Undo ctrl-q.  selectorOrNil (if not nil) is the previously offered selector.
	 hintText is the original hint.  Redoer: completeSymbol."

	self zapSelectionWith: UndoSelection.
	self undoMessage: (Message selector: #completeSymbol:lastOffering: arguments: UndoMessage arguments) forRedo: true.
	self selectAt: self stopIndex! !

!ParagraphEditor methodsFor: 'undoers'!
undoReplace
	"Undo of any command that replaced a selection by other text that it left
	 highlighted, and that is undone and redone by simple reversal of the
	 operation.  This is the most common Undoer; call replaceSelectionWith:
	 to get this setup.  Redoer: itself, so never isRedoing."

	self replaceSelectionWith: UndoSelection! !


!ParagraphEditor methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
browseChangeSetsWithSelector
	"Determine which, if any, change sets have at least one change for the selected selector, independent of class"

	| aSelector |
	self lineSelectAndEmptyCheck: [^ self].
	(aSelector := self selectedSelector) == nil ifTrue: [^ view flash].
	self terminateAndInitializeAround: [ChangeSorter browseChangeSetsWithSelector: aSelector]! !

!ParagraphEditor methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
browseItHere
	"Retarget the receiver's window to look at the selected class, if appropriate.  3/1/96 sw"
	| aSymbol foundClass b |
	(((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass])
		ifFalse: [^ view flash].
	model okToChange ifFalse: [^ view flash].
	self selectionInterval isEmpty ifTrue: [self selectWord].
	(aSymbol := self selectedSymbol) isNil ifTrue: [^ view flash].

	self terminateAndInitializeAround:
		[foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]).
			foundClass isNil ifTrue: [^ view flash].
			(foundClass isKindOf: Class)
				ifTrue:
					[model systemCategoryListIndex: 
						(model systemCategoryList indexOf: foundClass category).
		model classListIndex: (model classList indexOf: foundClass name)]]! !

!ParagraphEditor methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
debugIt

	| method receiver context |
	(model respondsTo: #doItReceiver) 
		ifTrue: 
			[FakeClassPool adopt: model selectedClass.
			receiver := model doItReceiver.
			context := model doItContext]
		ifFalse:
			[receiver := context := nil].
	self lineSelectAndEmptyCheck: [^self].
	method := self compileSelectionFor: receiver in: context.
	method notNil ifTrue:
		[self debug: method receiver: receiver in: context].
	FakeClassPool adopt: nil! !

!ParagraphEditor methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
debug: aCompiledMethod receiver: anObject in: evalContext

	| selector guineaPig debugger context |
	selector := evalContext isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:].
	anObject class addSelectorSilently: selector withMethod: aCompiledMethod.
	guineaPig := evalContext isNil
		ifTrue: [[anObject DoIt] newProcess]
		ifFalse: [[anObject DoItIn: evalContext] newProcess].
	context := guineaPig suspendedContext.
	debugger := Debugger new
		process: guineaPig
		controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess])
				ifTrue: [ScheduledControllers activeController]
				ifFalse: [nil])
		context: context
		isolationHead: nil.
	debugger openFullNoSuspendLabel: 'Debug it'.
	[debugger interruptedContext method == aCompiledMethod]
		whileFalse: [debugger send].
	anObject class basicRemoveSelector: selector! !


!ParagraphEditor methodsFor: 'private' stamp: 'th 9/19/2002 18:48'!
againOnce: indices
	"Find the next occurrence of FindText.  If none, answer false.
	Append the start index of the occurrence to the stream indices, and, if
	ChangeText is not the same object as FindText, replace the occurrence by it.
	Note that the search is case-sensitive for replacements, otherwise not."

	| where |
	where _ paragraph text findString: FindText startingAt: self stopIndex
				caseSensitive: ((ChangeText ~~ FindText) or: [Preferences caseSensitiveFinds]).
	where = 0 ifTrue: [^ false].
	self deselect; selectInvisiblyFrom: where to: where + FindText size - 1.
	ChangeText ~~ FindText ifTrue: [self zapSelectionWith: ChangeText].
	indices nextPut: where.
	self selectAndScroll.
	^ true! !

!ParagraphEditor methodsFor: 'private'!
againOrSame: useOldKeys
	"Subroutine of search: and again.  If useOldKeys, use same FindText and ChangeText as before.
	 1/26/96 sw: real worked moved to againOrSame:many:"

	^ self againOrSame: useOldKeys many: sensor leftShiftDown! !

!ParagraphEditor methodsFor: 'private' stamp: 'th 9/18/2002 16:53'!
againOrSame: useOldKeys many: many
	"Subroutine of search: and again.  If useOldKeys, use same FindText and ChangeText as before.  If many is true, do it repeatedly.  Created 1/26/96 sw by adding the many argument to #againOrSame."

	|  home indices wasTypedKey |

	home _ self selectionInterval.  "what was selected when 'again' was invoked"

	"If new keys are to be picked..."
	useOldKeys ifFalse: "Choose as FindText..."
		[FindText _ UndoSelection.  "... the last thing replaced."
		"If the last command was in another paragraph, ChangeText is set..."
		paragraph == UndoParagraph ifTrue: "... else set it now as follows."
			[UndoInterval ~= home ifTrue: [self selectInterval: UndoInterval]. "blink"
			ChangeText _ ((UndoMessage sends: #undoCutCopy:) and: [self hasSelection])
				ifTrue: [FindText] "== objects signal no model-locking by 'undo copy'"
				ifFalse: [self selection]]]. "otherwise, change text is last-replaced text"

	(wasTypedKey _ FindText size = 0)
		ifTrue: "just inserted at a caret"
			[home _ self selectionInterval.
			self replaceSelectionWith: self nullText.  "delete search key..."
			FindText _ ChangeText] "... and search for it, without replacing"
		ifFalse: "Show where the search will start"
			[home last = self selectionInterval last ifFalse:
				[self selectInterval: home]].

	"Find and Change, recording start indices in the array"
	indices _ WriteStream on: (Array new: 20). "an array to store change locs"
	[(self againOnce: indices) & many] whileTrue. "<-- this does the work"
	indices isEmpty ifTrue:  "none found"
		[self flash.
		wasTypedKey ifFalse: [^self]].

	(many | wasTypedKey) ifFalse: "after undo, select this replacement"
		[home _ self startIndex to:
			self startIndex + UndoSelection size - 1].

	self undoer: #undoAgain:andReselect:typedKey: with: indices contents with: home with: wasTypedKey! !

!ParagraphEditor methodsFor: 'private' stamp: 'th 9/19/2002 18:16'!
completeSymbol: hintText lastOffering: selectorOrNil
	"Invoked by Ctrl-q when there is only a caret.
		Do selector-completion, i.e., try to replace the preceding identifier by a
		selector that begins with those characters & has as many keywords as possible.
	 	Leave two spaces after each colon (only one after the last) as space for
		arguments.  Put the caret after the space after the first keyword.  If the
		user types Ctrl-q again immediately, choose a different selector.
	 Undoer: #undoQuery:lastOffering:; Redoer: itself.
	If redoing, just redisplay the last offering, selector[OrNil]."

	| firstTime input prior caret newStart sym kwds outStream |
	firstTime _ self isRedoing
		ifTrue: [prior _ sym _ selectorOrNil. true]
		ifFalse: [hintText isNil].
	firstTime
		ifTrue: "Initial Ctrl-q (or redo)"					
			[caret _ self startIndex.
			self selectPrecedingIdentifier.
			input _ self selection]
		ifFalse: "Repeated Ctrl-q"
			[caret _ UndoInterval first + hintText size.
			self selectInvisiblyFrom: UndoInterval first to: UndoInterval last.
			input _ hintText.
			prior _ selectorOrNil].
	(input size ~= 0 and: [sym ~~ nil or:
			[(sym _ Symbol thatStarts: input string skipping: prior) ~~ nil]])
		ifTrue: "found something to offer"
			[newStart _ self startIndex.
			outStream _ WriteStream on: (String new: 2 * sym size).
			1 to: (kwds _ sym keywords) size do:
				[:i |
				outStream nextPutAll: (kwds at: i).
				i = 1 ifTrue: [caret _ newStart + outStream contents size + 1].
				outStream nextPutAll:
					(i < kwds size ifTrue: ['  '] ifFalse: [' '])].
			UndoSelection _ input.
			self deselect; zapSelectionWith: outStream contents asText.
			self undoer: #undoQuery:lastOffering: with: input with: sym]
		ifFalse: "no more matches"
			[firstTime ifFalse: "restore original text & set up for a redo"
				[UndoSelection _ self selection.
				self deselect; zapSelectionWith: input.
				self undoer: #completeSymbol:lastOffering: with: input with: prior.
				Undone _ true].
			view flash].
	self selectAt: caret! !

!ParagraphEditor methodsFor: 'private' stamp: 'th 9/18/2002 16:49'!
exchangeWith: prior
	"If the prior selection is non-overlapping and legal, exchange the text of
	 it with the current selection and leave the currently selected text selected
	 in the location of the prior selection (or leave a caret after a non-caret if it was
	 exchanged with a caret).  If both selections are carets, flash & do nothing.
	 Don't affect the paste buffer.  Undoer: itself; Redoer: Undoer."

	| start stop before selection priorSelection delta altInterval |
	start _ self startIndex.
	stop _ self stopIndex - 1.
	((prior first <= prior last) | (start <= stop) "Something to exchange" and:
			[self isDisjointFrom: prior])
		ifTrue:
			[before _ prior last < start.
			selection _ self selection.
			priorSelection _ paragraph text copyFrom: prior first to: prior last.

			delta _ before ifTrue: [0] ifFalse: [priorSelection size - selection size].
			self zapSelectionWith: priorSelection.
			self selectFrom: prior first + delta to: prior last + delta.

			delta _ before ifTrue: [stop - prior last] ifFalse: [start - prior first].
			self zapSelectionWith: selection.
			altInterval _ prior first + delta to: prior last + delta.
			self undoer: #exchangeWith: with: altInterval.
			"If one was a caret, make it otherInterval & leave the caret after the other"
			prior first > prior last ifTrue: [self selectAt: UndoInterval last + 1].
			otherInterval _ start > stop
				ifTrue: [self selectAt: altInterval last + 1. UndoInterval]
				ifFalse: [altInterval]]
		ifFalse:
			[view flash]! !

!ParagraphEditor methodsFor: 'private' stamp: 'raok 11/15/2001 14:01'!
explainDelimitor: string
	"Is string enclosed in delimitors?"

	| str |
	(string at: 1) isLetter ifTrue: [^nil].  "only special chars"
	(string first = string last) ifTrue:
			[^ self explainChar: (String with: string first)]
		ifFalse:
			[(string first = $( and: [string last = $)]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $[ and: [string last = $]]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = ${ and: [string last = $}]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $< and: [string last = $>]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $# and: [string last = $)]) ifTrue:
				[^'"An instance of class Array.  The Numbers, Characters, or Symbols between the parenthesis are the elements of the Array."'].
			string first = $# ifTrue:
				[^'"An instance of class Symbol."'].
			(string first = $$ and: [string size = 2]) ifTrue:
				[^'"An instance of class Character.  This one is the character ', (String with: string last), '."'].
			(string first = $:) ifTrue:
				[str _ string allButFirst.
				(self explainTemp: str) ~~ nil ifTrue:
					[^'"An argument to this block will be bound to the temporary variable ',
						str, '."']]].
	^ nil! !

!ParagraphEditor methodsFor: 'private' stamp: 'tk 7/14/2000 12:15'!
getPluggableYellowButtonMenu: shiftKeyState
	| customMenu |
	^ ((view ~~ nil) and: [(customMenu _ view getMenu: shiftKeyState) notNil])
		ifTrue: [customMenu]
		ifFalse:
			[shiftKeyState
				ifTrue: [self class shiftedYellowButtonMenu]
				ifFalse: [self class yellowButtonMenu]]! !

!ParagraphEditor methodsFor: 'private'!
indent: delta fromStream: inStream toStream: outStream
	"Append the contents of inStream to outStream, adding or deleting delta or -delta
	 tabs at the beginning, and after every CR except a final CR.  Do not add tabs
	 to totally empty lines, and be sure nothing but tabs are removed from lines."

	| ch skip cr tab prev atEnd |
	cr _ Character cr.
	tab _ Character tab.
	delta > 0
		ifTrue: "shift right"
			[prev _ cr.
			 [ch _ (atEnd _ inStream atEnd) ifTrue: [cr] ifFalse: [inStream next].
			  (prev == cr and: [ch ~~ cr]) ifTrue:
				[delta timesRepeat: [outStream nextPut: tab]].
			  atEnd]
				whileFalse:
					[outStream nextPut: ch.
					prev _ ch]]
		ifFalse: "shift left"
			[skip _ delta. "a negative number"
			 [inStream atEnd] whileFalse:
				[((ch _ inStream next) == tab and: [skip < 0]) ifFalse:
					[outStream nextPut: ch].
				skip _ ch == cr ifTrue: [delta] ifFalse: [skip + 1]]]! !

!ParagraphEditor methodsFor: 'private' stamp: 'cmm 4/9/2004 14:00'!
isDisjointFrom: anInterval
	"Answer true if anInterval is a caret not touching or within the current
	 interval, or if anInterval is a non-caret that does not overlap the current
	 selection."

	| fudge |
	fudge _ anInterval size = 0 ifTrue: [1] ifFalse: [0].
	^(anInterval last + fudge < self startIndex or:
			[anInterval first - fudge >= self stopIndex])
! !

!ParagraphEditor methodsFor: 'private' stamp: 'th 11/24/2002 17:13'!
lines
	"Other than my member paragraph i compute lines based on logical
	line breaks, not optical (which may change due to line wrapping of the editor)"
	| lines string index lineIndex stringSize |
	string _ paragraph text string.
	"Empty strings have no lines at all. Think of something."
	string isEmpty ifTrue:[^{#(1 0 0)}].
	stringSize _ string size.
	lines _ OrderedCollection new: (string size // 15).
	index _ 0.
	lineIndex _ 0.
	string linesDo:[:line |
		lines addLast: (Array
			with: (index _ index + 1)
			with: (lineIndex _ lineIndex + 1)
			with: (index _ index + line size min: stringSize))].
	"Special workaround for last line empty."
	string last == Character cr
	"lines last last < stringSize" ifTrue:[lines addLast:{stringSize +1. lineIndex+1. stringSize}].
	^lines! !

!ParagraphEditor methodsFor: 'private' stamp: 'th 9/19/2002 19:57'!
moveCursor: directionBlock forward: forward specialBlock: specialBlock
	"Private - Move cursor.
	directionBlock is a one argument Block that computes the new Position from a given one.
	specialBlock is a one argumentBlock that computes the new position from a given one under the alternate semantics.
	Note that directionBlock always is evaluated first."
	| shift indices newPosition |
	shift _ sensor leftShiftDown.
	indices _ self setIndices: shift forward: forward.
	newPosition _ directionBlock value: (indices at: #moving).
	(sensor commandKeyPressed or:[sensor controlKeyPressed])
		ifTrue: [newPosition _ specialBlock value: newPosition].
	sensor keyboard.
	shift
		ifTrue: [self selectMark: (indices at: #fixed) point: newPosition - 1]
		ifFalse: [self selectAt: newPosition]! !

!ParagraphEditor methodsFor: 'private' stamp: 'sma 12/15/1999 11:32'!
nextWord: position
	| string index |
	string _ paragraph text string.
	index _ position.
	[(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]]
		whileTrue: [index _ index + 1].
	[(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]]
		whileTrue: [index _ index + 1].
	^ index! !

!ParagraphEditor methodsFor: 'private'!
nullText

	^Text string: '' emphasis: emphasisHere! !

!ParagraphEditor methodsFor: 'private' stamp: 'th 9/20/2002 11:09'!
pageHeight
	| howManyLines visibleHeight totalHeight ratio |
	howManyLines _ paragraph numberOfLines.
	visibleHeight _ self visibleHeight.
	totalHeight _ self totalTextHeight.
	ratio _ visibleHeight / totalHeight.
	^(ratio * howManyLines) rounded - 2! !

!ParagraphEditor methodsFor: 'private' stamp: 'sma 12/15/1999 11:33'!
previousWord: position
	| string index |
	string _ paragraph text string.
	index _ position.
	[(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]]
		whileTrue: [index _ index - 1].
	[(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]]
		whileTrue: [index _ index - 1].
	^ index + 1! !

!ParagraphEditor methodsFor: 'private' stamp: 'BG 4/29/2004 11:19'!
sameColumn: start newLine: lineBlock forward: isForward
	"Private - Compute the index in my text
	with the line number derived from lineBlock,"
	" a one argument block accepting the old line number.
	The position inside the line will be preserved as good as possible"
	"The boolean isForward is used in the border case to determine if
	we should move to the beginning or the end of the line."
	| wordStyle column currentLine offsetAtTargetLine targetEOL lines numberOfLines currentLineNumber targetLineNumber |
	wordStyle _ Preferences wordStyleCursorMovement.
	wordStyle
		ifTrue: [
			lines _ paragraph lines.
			numberOfLines := paragraph numberOfLines.
			currentLineNumber  _ paragraph lineIndexOfCharacterIndex: start.
			currentLine _ lines at: currentLineNumber]
		ifFalse: [
			lines _ self lines.
			numberOfLines := lines size.
			currentLine _ lines
				detect:[:lineInterval | lineInterval last >= start]
				ifNone:[lines last].
			currentLineNumber _ currentLine second].
	column _ start - currentLine first.
	targetLineNumber _ ((lineBlock value: currentLineNumber) max: 1) min: numberOfLines.
	offsetAtTargetLine _ (lines at: targetLineNumber) first.
	targetEOL _ (lines at: targetLineNumber) last + (targetLineNumber == numberOfLines ifTrue:[1]ifFalse:[0]).
	targetLineNumber == currentLineNumber
	"No movement or movement failed. Move to beginning or end of line."
		ifTrue:[^isForward
			ifTrue:[targetEOL]
			ifFalse:[offsetAtTargetLine]].
	^offsetAtTargetLine + column min: targetEOL.! !

!ParagraphEditor methodsFor: 'private' stamp: 'md 2/22/2006 21:17'!
setIndices: shiftPressed forward: forward
	"Little helper method that sets the moving and fixed indices according to some flags."
	| indices |
	indices _ Dictionary new.
	shiftPressed ifTrue: [
			indices at: #moving put: self pointIndex.
			indices at: #fixed put: self markIndex
		] ifFalse: [
			forward
				ifTrue:[
					indices at: #moving put: self stopIndex.
					indices at: #fixed put: self startIndex.
				] ifFalse: [
					indices at: #moving put: self startIndex.
					indices at: #fixed put: self stopIndex.
				]
		].
	^indices! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ParagraphEditor class
	instanceVariableNames: ''!

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'sw 5/27/2000 00:03'!
abandonChangeText
	"Call this to get out of the maddening situation in which the system keeps aggressively trying to do a replacement that you no longer wish to make, every time you make choose a new method in a list."
	ChangeText _ FindText

	"ParagraphEditor abandonChangeText"
! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 10/1/2004 11:00'!
initialize
	"Initialize the keyboard shortcut maps and the shared buffers 
	for copying text across views and managing again and undo. 
	Marked this method changed to trigger reinit"
	"ParagraphEditor initialize"
	UndoSelection := FindText := ChangeText := Text new.
	UndoMessage := Message selector: #halt.
	self initializeCmdKeyShortcuts.
	self initializeShiftCmdKeyShortcuts.! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 4/4/2006 16:07'!
shiftedYellowButtonMenu
	"Answer the menu to be presented when the yellow button is pressed while the shift key is down"

	^ MenuMorph fromArray: {
		{'explain' translated.						#explain}.
		{'pretty print' translated.					#prettyPrint}.
		{'pretty print with color' translated.		#prettyPrintWithColor}.
		{'file it in (G)' translated.					#fileItIn}.
		{'tiles from it' translated.					#selectionAsTiles}.
		{'spawn (o)' translated.						#spawn}.
		#-.
		{'browse it (b)' translated.					#browseIt}.
		{'senders of it (n)' translated.				#sendersOfIt}.
		{'implementors of it (m)' translated.		#implementorsOfIt}.
		{'references to it (N)' translated.			#referencesToIt}.
		#-.
		{'selectors containing it (W)' translated.	#methodNamesContainingIt}.
		{'method strings with it (E)' translated.	#methodStringsContainingit}.
		{'method source with it' translated.		#methodSourceContainingIt}.
		{'class names containing it' translated.	#classNamesContainingIt}.
		{'class comments with it' translated.		#classCommentsContainingIt}.
		{'change sets with it' translated.			#browseChangeSetsWithSelector}.
		#-.
		{'save contents to file...' translated.		#saveContentsInFile}.
		{'send contents to printer' translated.	#sendContentsToPrinter}.
		{'printer setup' translated.					#printerSetup}.
		#-.
		{'special menu...' translated.				#presentSpecialMenu}.
		{'more...' translated.						#yellowButtonActivity}.
	}
! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 9/1/2005 12:35'!
yellowButtonExpertMenu

	^ MenuMorph fromArray: {
			{'set font... (k)' translated.				#offerFontMenu}.
			{'set style... (K)' translated.				#changeStyle}.
			{'set alignment... (u)' translated.		#chooseAlignment}.
			#-.
			{'make project link (P)' translated.	#makeProjectLink}.
			#-.
			{'find...(f)' translated.					#find}.
			{'find again (g)' translated.				#findAgain}.
			{'set search string (h)' translated.		#setSearchString}.
			#-.
			{'do again (j)' translated.				#again}.
			{'undo (z)' translated.					#undo}.
			#-.
			{'copy (c)' translated.					#copySelection}.
			{'cut (x)' translated.						#cut}.
			{'paste (v)' translated.					#paste}.
			{'paste...' translated.					#pasteRecent}.
			#-.
			{'do it (d)' translated.					#doIt}.
			{'print it (p)' translated.				#printIt}.
			{'inspect it (i)' translated.				#inspectIt}.
			{'explore it (I)' translated.				#exploreIt}.
			{'debug it' translated.					#debugIt}.
			#-.
			{'accept (s)' translated.					#accept}.
			{'cancel (l)' translated.					#cancel}.
			#-.
			{'show bytecodes' translated.			#showBytecodes}.
			#-.
			{'copy html' translated.					#copyHtml}.
			#-.
			{'more...' translated.					#shiftedTextPaneMenuRequest}.
		}.
! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 10/1/2004 10:59'!
yellowButtonMenu

	^ Preferences noviceMode
			ifTrue: [self yellowButtonNoviceMenu]
			ifFalse: [self yellowButtonExpertMenu]
! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 11/25/2004 17:33'!
yellowButtonNoviceMenu

	^ MenuMorph fromArray: {
			{'set font... (k)' translated.				#offerFontMenu}.
			{'set style... (K)' translated.				#changeStyle}.
			{'set alignment... (u)' translated.		#chooseAlignment}.
			#-.
			{'make project link (P)' translated.	#makeProjectLink}.
			#-.
			{'find...(f)' translated.					#find}.
			{'find again (g)' translated.				#findAgain}.
			{'set search string (h)' translated.		#setSearchString}.
			#-.
			{'do again (j)' translated.				#again}.
			{'undo (z)' translated.					#undo}.
			#-.
			{'copy (c)' translated.					#copySelection}.
			{'cut (x)' translated.						#cut}.
			{'paste (v)' translated.					#paste}.
			{'paste...' translated.					#pasteRecent}.
			#-.
			{'accept (s)' translated.					#accept}.
			{'cancel (l)' translated.					#cancel}.
		}.
! !


!ParagraphEditor class methodsFor: 'instance creation' stamp: 'nk 9/3/2004 14:10'!
new
	"Answer a new instance of me with a null Paragraph to be edited."

	| aParagraphEditor |
	aParagraphEditor _ super new.
	aParagraphEditor changeParagraph: '' asParagraph.
	^aParagraphEditor! !

!ParagraphEditor class methodsFor: 'instance creation'!
newParagraph: aParagraph 
	"Answer an instance of me with aParagraph as the text to be edited."

	| aParagraphEditor |
	aParagraphEditor _ super new.
	aParagraphEditor initialize.
	aParagraphEditor changeParagraph: aParagraph.
	^aParagraphEditor! !


!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'dgd 4/4/2006 16:04'!
initializeCmdKeyShortcuts
	"Initialize the (unshifted) command-key (or alt-key) shortcut table."

	"NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"

	"ParagraphEditor initialize"

	| cmdMap |

	cmdMap := Array new: 256 withAll: #noop:.	"use temp in case of a crash"

	cmdMap at: 1 + 1 put: #cursorHome:.			"home key"
	cmdMap at: 4 + 1 put: #cursorEnd:.				"end key"
	cmdMap at: 8 + 1 put: #backspace:.				"ctrl-H or delete key"
	cmdMap at: 11 + 1 put: #cursorPageUp:.		"page up key"
	cmdMap at: 12 + 1 put: #cursorPageDown:.	"page down key"
	cmdMap at: 13 + 1 put: #crWithIndent:.			"cmd-Return"
	cmdMap at: 27 + 1 put: #offerMenuFromEsc:.	"escape key"
	cmdMap at: 28 + 1 put: #cursorLeft:.			"left arrow key"
	cmdMap at: 29 + 1 put: #cursorRight:.			"right arrow key"
	cmdMap at: 30 + 1 put: #cursorUp:.				"up arrow key"
	cmdMap at: 31 + 1 put: #cursorDown:.			"down arrow key"
	cmdMap at: 32 + 1 put: #selectWord:.			"space bar key"
	cmdMap at: 127 + 1 put: #forwardDelete:.		"del key"

	'0123456789-=' 
		do: [:char | cmdMap at: char asciiValue + 1 put: #changeEmphasis:].

	'([{''"<' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:].

	cmdMap at: $, asciiValue + 1 put: #shiftEnclose:.

	"triplet = {character. comment selector. novice appropiated}"
	#(
		($a		#selectAll:				true)
		($b		#browseIt:				false)
		($c		#copySelection:			true)
		($d		#doIt:						false)
		($e		#exchange:				true)
		($f		#find:						true)
		($g		#findAgain:				true)
		($h		#setSearchString:		true)
		($i		#inspectIt:				false)
		($j		#doAgainOnce:			true)
		($k		#offerFontMenu:		true)
		($l		#cancel:					true)
		($m	#implementorsOfIt:		false)
		($n		#sendersOfIt:			false)
		($o		#spawnIt:				false)
		($p		#printIt:					false)
		($q		#querySymbol:			false)
		($s		#save:					true)
		($t		#tempCommand:		false)
		($u		#align:					true)
		($v		#paste:					true)
		($w	#backWord:				true)
		($x		#cut:						true)
		($y		#swapChars:				true)
		($z		#undo:					true)
	)
		select:[:triplet | Preferences noviceMode not or:[triplet third]]
		thenDo:[:triplet | cmdMap at: triplet first asciiValue + 1 put: triplet second].

	CmdActions := cmdMap.
! !

!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'dgd 10/4/2004 13:53'!
initializeShiftCmdKeyShortcuts 
	"Initialize the shift-command-key (or control-key) shortcut table."
	"NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
	"wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the 
	capitalized versions of the letters.
	TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values."

	| cmdMap |

	"shift-command and control shortcuts"
	cmdMap _ Array new: 256 withAll: #noop:.  "use temp in case of a crash"

	cmdMap at: ( 1 + 1) put: #cursorHome:.				"home key"
	cmdMap at: ( 4 + 1) put: #cursorEnd:.				"end key"
	cmdMap at: ( 8 + 1) put: #forwardDelete:.			"ctrl-H or delete key"
	cmdMap at: (11 + 1) put: #cursorPageUp:.			"page up key"
	cmdMap at: (12 + 1) put: #cursorPageDown:.		"page down key"
	cmdMap at: (13 + 1) put: #crWithIndent:.			"ctrl-Return"
	cmdMap at: (27 + 1) put: #offerMenuFromEsc:.	"escape key"
	cmdMap at: (28 + 1) put: #cursorLeft:.				"left arrow key"
	cmdMap at: (29 + 1) put: #cursorRight:.				"right arrow key"
	cmdMap at: (30 + 1) put: #cursorUp:.				"up arrow key"
	cmdMap at: (31 + 1) put: #cursorDown:.			"down arrow key"
	cmdMap at: (32 + 1) put: #selectWord:.				"space bar key"
	cmdMap at: (45 + 1) put: #changeEmphasis:.		"cmd-sh-minus"
	cmdMap at: (61 + 1) put: #changeEmphasis:.		"cmd-sh-plus"
	cmdMap at: (127 + 1) put: #forwardDelete:.		"del key"

	"Note: Command key overrides shift key, so, for example, cmd-shift-9 produces $9 not $("
	'9[,''' do: [ :char | cmdMap at: (char asciiValue + 1) put: #shiftEnclose: ].	"({< and double-quote"
	"Note: Must use cmd-9 or ctrl-9 to get '()' since cmd-shift-9 is a Mac FKey command."

	"NB: sw 12/9/2001 commented out the idiosyncratic line just below, which was grabbing shift-esc in the text editor and hence which argued with the wish to have shift-esc be a universal gesture for escaping the local context and calling up the desktop menu."  
	"cmdMap at: (27 + 1) put: #shiftEnclose:." 	"ctrl-["

	"'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]."

	"triplet = {character. comment selector. novice appropiated}"
	#(
		($a		argAdvance:						false)
		($b		browseItHere:					false)
		($c		compareToClipboard:			false)
		($d		duplicate:							true)
		($e		methodStringsContainingIt:	false)
		($f		displayIfFalse:					false)
		($g		fileItIn:							false)
		($h		cursorTopHome:					true)
		($i		exploreIt:							false)
		($j		doAgainMany:					true)
		($k		changeStyle:						true)
		($l		outdent:							true)
		($m	selectCurrentTypeIn:			true)
		($n		referencesToIt:					false)
		($p		makeProjectLink:				true)
		($r		indent:							true)
		($s		search:							true)
		($t		displayIfTrue:					false)
		($u		changeLfToCr:					false)
		($v		pasteInitials:						false)
		($w	methodNamesContainingIt:	false)
		($x		makeLowercase:					true)
		($y		makeUppercase:					true)
		($z		makeCapitalized:				true)
	)
		select:[:triplet | Preferences noviceMode not or:[triplet third]]
		thenDo:[:triplet |
			cmdMap at: (triplet first asciiValue         + 1) put: triplet second.		"plain keys"
			cmdMap at: (triplet first asciiValue - 32 + 1) put: triplet second.		"shifted keys"
			cmdMap at: (triplet first asciiValue - 96 + 1) put: triplet second.		"ctrl keys"
		].

	ShiftCmdActions _ cmdMap! !

!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sps 7/24/2003 17:25'!
multiRedoOverride
"Call this to set meta-r to perform the multilevel redo (or tweak the code below to have it bound to some other key sequence)."

"
ParagraphEditor multiRedoOverride.
"
	CmdActions at: $r asciiValue + 1 put: #multiRedo: 
! !

!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sbw 10/8/1999 21:42'!
specialShiftCmdKeys

"Private - return array of key codes that represent single keys acting
as if shift-command were also being pressed"

^#(
	1	"home"
	3	"enter"
	4	"end"
	8	"backspace"
	11	"page up"
	12	"page down"
	27	"escape"
	28	"left arrow"
	29	"right arrow"
	30	"up arrow"
	31	"down arrow"
	127	"delete"
	)! !
TileMorph subclass: #ParameterTile
	instanceVariableNames: 'scriptEditor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!ParameterTile commentStamp: '<historical>' prior: 0!
Represents a parameter in a user-defined script in "classic" tile-scripting.  The type of a script's parameter is declared in the ScriptEditor for the script, and a parameter tile gets its type from the script.  But because the user can change the parameter type *after* having created parameter tiles, we can later have type mismatches.  Which however we at least deal with reasonably cleverly.!


!ParameterTile methodsFor: 'access' stamp: 'sw 3/15/2005 21:45'!
isBoolean 
	"Answer whether the receiver's type is inherently boolean"

	^ self scriptEditor typeForParameter == #Boolean! !

!ParameterTile methodsFor: 'access' stamp: 'sw 3/15/2005 22:36'!
rowOfRightTypeFor: aLayoutMorph forActor: aPlayer
	"Answer a phrase of the right type for the putative container"

	| aTemporaryViewer aPhrase |
	aLayoutMorph demandsBoolean ifTrue:
		[aTemporaryViewer _ CategoryViewer new invisiblySetPlayer: aPlayer.
		aPhrase _ aTemporaryViewer booleanPhraseFromPhrase: self.
		aPhrase justGrabbedFromViewer: false.
		^ aPhrase].
	^ self! !

!ParameterTile methodsFor: 'access' stamp: 'sw 1/18/2004 22:12'!
scriptEditor
	"Answer the receiver's script editor.  The slightly strange code here is in order to contend with the unusual situation where a parameter tile obtained from one script editor is later dropped into a different script editor.  As long as the parameter tile is *in* a script editor, that containing scriptEditor is the one; if it is *not*, then we use the last known one"

	| aScriptEditor |
	^ (aScriptEditor _ self outermostMorphThat: [:m | m isKindOf: ScriptEditorMorph])
		ifNotNil:
			[scriptEditor _ aScriptEditor]
		ifNil:
			[scriptEditor]! !


!ParameterTile methodsFor: 'accessing' stamp: 'sw 7/18/2002 02:45'!
resultType
	"Answer the result type of the receiver"

	^ self scriptEditor typeForParameter! !


!ParameterTile methodsFor: 'code generation' stamp: 'yo 12/20/2003 02:49'!
storeCodeOn: aStream indent: tabCount
	"Store code on the stream"
 
	| myTypeString |
	myTypeString _ self resultType.
	(self scriptEditor hasParameter and: [self scriptEditor typeForParameter = myTypeString])
		ifTrue:
			[aStream nextPutAll: 'parameter']
		ifFalse:
			["This script no longer bears a parameter, yet there's an orphaned Parameter tile in it"
			aStream nextPutAll: '(self defaultValueOfType: #', myTypeString, ')']! !


!ParameterTile methodsFor: 'initialization' stamp: 'yo 3/14/2005 08:01'!
forScriptEditor: aScriptEditor
	"Make the receiver be associated with the given script editor"

	scriptEditor _ aScriptEditor.
	self line1: aScriptEditor typeForParameter translated.! !

!ParameterTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self typeColor: Color red! !


!ParameterTile methodsFor: 'miscellaneous' stamp: 'sw 3/15/2005 21:55'!
associatedPlayer
	"Answer the player with which the receiver is associated"

	^ self scriptEditor playerScripted! !

!ParameterTile methodsFor: 'miscellaneous' stamp: 'sw 3/15/2005 22:37'!
booleanComparatorPhrase
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase rel retrieverType |
	retrieverType _ self resultType.

	rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean.
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType.
	outerPhrase firstSubmorph addMorph: self.
	outerPhrase submorphs last addMorph: (ScriptingSystem tileForArgType: retrieverType).

	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!ParameterTile methodsFor: 'miscellaneous' stamp: 'sw 3/15/2005 22:41'!
tileRows
	"Answer a list of tile rows -- in this case exactly one row -- representing the receiver."

	^ Array with: (Array with: self)! !


!ParameterTile methodsFor: 'type' stamp: 'sw 7/22/2002 17:48'!
assureTypeStillValid
	"Consider the possibility that the parameter type of my surrounding method has changed and that hence I no longer represent a possible value for the parameter of the script.  If this condition obtains, then banish me in favor of a default literal tile of the correct type"

	(self ownerThatIsA: TilePadMorph) ifNotNilDo:
		[:aPad | aPad type = self scriptEditor typeForParameter ifFalse:
			[aPad setToBearDefaultLiteral]]! !
Object subclass: #ParseNode
	instanceVariableNames: 'comment pc'
	classVariableNames: 'Bfp BtpLong CodeBases CodeLimits DblExtDoAll Dup EndMethod EndRemote Jmp JmpLimit JmpLong LdFalse LdInstLong LdInstType LdLitIndType LdLitType LdMinus1 LdNil LdSelf LdSuper LdTempType LdThisContext LdTrue LoadLong LongLongDoAll NodeFalse NodeNil NodeSelf NodeSuper NodeThisContext NodeTrue Pop Send SendLimit SendLong SendLong2 SendPlus SendType ShortStoP StdLiterals StdSelectors StdVariables Store StorePop'
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!ParseNode commentStamp: '<historical>' prior: 0!
This superclass of most compiler/decompiler classes declares common class variables, default messages, and the code emitters for jumps. Some of the class variables are initialized here; the rest are initialized in class VariableNode.!


!ParseNode methodsFor: 'code generation'!
emitBranchOn:
condition dist: dist pop: stack on: strm
	stack pop: 1.
	dist = 0 ifTrue: [^ strm nextPut: Pop].
	condition
		ifTrue: [self emitLong: dist code: BtpLong on: strm]
		ifFalse: [self emitShortOrLong: dist code: Bfp on: strm]! !

!ParseNode methodsFor: 'code generation'!
emitForEffect: stack on: strm

	self emitForValue: stack on: strm.
	strm nextPut: Pop.
	stack pop: 1! !

!ParseNode methodsFor: 'code generation'!
emitForReturn: stack on: strm

	self emitForValue: stack on: strm.
	strm nextPut: EndMethod! !

!ParseNode methodsFor: 'code generation'!
emitJump: dist on: strm

	dist = 0 ifFalse: [self emitShortOrLong: dist code: Jmp on: strm]! !

!ParseNode methodsFor: 'code generation'!
emitLong: dist code: longCode on: aStream 
	"Force a two-byte jump."
	| code distance |
	code _ longCode.
	distance _ dist.
	distance < 0
		ifTrue: 
			[distance _ distance + 1024.
			code _ code - 4]
		ifFalse: 
			[distance > 1023 ifTrue: [distance _ -1]].
	distance < 0
		ifTrue: 
			[self error: 'A block compiles more than 1K bytes of code']
		ifFalse: 
			[aStream nextPut: distance // 256 + code.
			aStream nextPut: distance \\ 256]! !

!ParseNode methodsFor: 'code generation'!
emitShortOrLong: dist code: shortCode on: strm
	(1 <= dist and: [dist <= JmpLimit])
		ifTrue: [strm nextPut: shortCode + dist - 1]
		ifFalse: [self emitLong: dist code: shortCode + (JmpLong-Jmp) on: strm]! !

!ParseNode methodsFor: 'code generation' stamp: 'nk 7/10/2004 10:04'!
pc
	"Used by encoder source mapping."

	^pc ifNil: [ 0 ]
! !

!ParseNode methodsFor: 'code generation'!
sizeBranchOn: condition dist: dist
	dist = 0 ifTrue: [^1].
	^ condition
		ifTrue: [2]  "Branch on true is always 2 bytes"
		ifFalse: [self sizeShortOrLong: dist]! !

!ParseNode methodsFor: 'code generation'!
sizeForEffect: encoder

	^(self sizeForValue: encoder) + 1! !

!ParseNode methodsFor: 'code generation'!
sizeForReturn: encoder

	^(self sizeForValue: encoder) + 1! !

!ParseNode methodsFor: 'code generation'!
sizeJump: dist

	dist = 0 ifTrue: [^0].
	^self sizeShortOrLong: dist! !

!ParseNode methodsFor: 'code generation'!
sizeShortOrLong: dist

	(1 <= dist and: [dist <= JmpLimit])
		ifTrue: [^1].
	^2! !


!ParseNode methodsFor: 'comment'!
comment

	^comment! !

!ParseNode methodsFor: 'comment'!
comment: newComment

	comment _ newComment! !


!ParseNode methodsFor: 'converting'!
asReturnNode

	^ReturnNode new expr: self! !


!ParseNode methodsFor: 'encoding'!
encodeSelector: selector

	^nil! !


!ParseNode methodsFor: 'printing' stamp: 'tk 10/16/2000 13:57'!
nodePrintOn: aStrm indent: nn
	| var aaStrm myLine |
	"Show just the sub nodes and the code."

	(aaStrm _ aStrm) ifNil: [aaStrm _ WriteStream on: (String new: 500)].
	nn timesRepeat: [aaStrm tab].
	aaStrm nextPutAll: self class name; space.
	myLine _ self printString copyWithout: Character cr.
	myLine _ myLine copyFrom: 1 to: (myLine size min: 70).
	aaStrm nextPutAll: myLine; cr.
	1 to: self class instSize do: [:ii | 
		var _ self instVarAt: ii.
		(var respondsTo: #asReturnNode) ifTrue: [var nodePrintOn: aaStrm indent: nn+1]].
	1 to: self class instSize do: [:ii | 
		var _ self instVarAt: ii.
		(var isKindOf: SequenceableCollection) ifTrue: [
				var do: [:aNode | 
					(aNode respondsTo: #asReturnNode) ifTrue: [
						aNode nodePrintOn: aaStrm indent: nn+1]]]].
	^ aaStrm
! !

!ParseNode methodsFor: 'printing' stamp: 'ab 7/13/2004 13:46'!
printCommentOn: aStream indent: indent 
	| thisComment |
	self comment == nil ifTrue: [^ self].
	aStream withStyleFor: #comment
		do: [1 to: self comment size do: 
				[:index | 
				index > 1 ifTrue: [aStream crtab: indent].
				aStream nextPut: $".
				thisComment _ self comment at: index.
				self printSingleComment: thisComment
					on: aStream
					indent: indent.
				aStream nextPut: $"]].
	self comment: nil! !

!ParseNode methodsFor: 'printing' stamp: 'md 8/15/2005 11:02'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	aStream nextPutAll: '{'.
	aStream nextPutAll: ((ColoredCodeStream contents: [:strm | self printOn: strm indent: 0])
							asString).
	aStream nextPutAll: '}'! !

!ParseNode methodsFor: 'printing'!
printOn: aStream indent: anInteger 
	"If control gets here, avoid recursion loop."

	super printOn: aStream! !

!ParseNode methodsFor: 'printing'!
printOn: aStream indent: level precedence: p

	self printOn: aStream indent: level! !

!ParseNode methodsFor: 'printing' stamp: 'ms 8/1/2006 16:47'!
shortPrintOn: aStream 
	self printOn: aStream indent: 0! !


!ParseNode methodsFor: 'testing'!
assignmentCheck: encoder at: location
	"For messageNodes masquerading as variables for the debugger.
	For now we let this through - ie we allow stores ev
	into args.  Should check against numArgs, though."
	^ -1! !

!ParseNode methodsFor: 'testing'!
canBeSpecialArgument
	"Can I be an argument of (e.g.) ifTrue:?"

	^false! !

!ParseNode methodsFor: 'testing'!
canCascade

	^false! !

!ParseNode methodsFor: 'testing'!
isArg

	^false! !

!ParseNode methodsFor: 'testing'!
isComplex
	"Used for pretty printing to determine whether to start a new line"

	^false! !

!ParseNode methodsFor: 'testing'!
isConstantNumber  "Overridden in LiteralNode"
	^false! !

!ParseNode methodsFor: 'testing' stamp: 'md 1/20/2006 16:22'!
isDoIt
	"polymorphic with RBNodes; called by debugger"

	^ false! !

!ParseNode methodsFor: 'testing' stamp: 'ls 1/29/2004 21:11'!
isJust: node
	^false! !

!ParseNode methodsFor: 'testing' stamp: 'di 4/5/2000 11:14'!
isLiteral

	^ false! !

!ParseNode methodsFor: 'testing' stamp: 'md 7/27/2006 19:14'!
isMessage
	^false! !

!ParseNode methodsFor: 'testing'!
isMessage: selSymbol receiver: rcvrPred arguments: argsPred
	"See comment in MessageNode."

	^false! !

!ParseNode methodsFor: 'testing'!
isReturnSelf

	^false! !

!ParseNode methodsFor: 'testing'!
isReturningIf

	^false! !

!ParseNode methodsFor: 'testing' stamp: 'tk 8/2/1999 18:39'!
isSelfPseudoVariable	
	"Overridden in VariableNode."
	^false! !

!ParseNode methodsFor: 'testing'!
isSpecialConstant
	^ false! !

!ParseNode methodsFor: 'testing' stamp: 'di 10/12/1999 15:28'!
isTemp
	^ false! !

!ParseNode methodsFor: 'testing'!
isUndefTemp
	^ false! !

!ParseNode methodsFor: 'testing'!
isUnusedTemp
	^ false! !

!ParseNode methodsFor: 'testing'!
isVariableReference

	^false! !

!ParseNode methodsFor: 'testing'!
nowHasDef  "Ignored in all but VariableNode"! !

!ParseNode methodsFor: 'testing'!
nowHasRef  "Ignored in all but VariableNode"! !

!ParseNode methodsFor: 'testing'!
toDoIncrement: ignored
	"Only meant for Messages or Assignments - else return nil"
	^ nil! !


!ParseNode methodsFor: '*eToys-tiles' stamp: 'ab 7/13/2004 13:47'!
addCommentToMorph: aMorph
	| row |
	(self comment isNil or: [self comment isEmpty]) ifTrue: [^ self].
	row _ aMorph addTextRow:
		(String streamContents: [:strm | self printCommentOn: strm indent: 1]).
	row firstSubmorph color: (SyntaxMorph translateColor: #comment).
	row parseNode: (self as: CommentNode).
! !

!ParseNode methodsFor: '*eToys-tiles' stamp: 'RAA 8/24/1999 12:24'!
asMorphicSyntaxIn: parent

	| morph |
	"Default for missing implementations"

	morph _ parent addColumn: #error on: self.
	morph addTextRow: self class printString.
	^morph
	

! !

!ParseNode methodsFor: '*eToys-tiles' stamp: 'RAA 8/24/1999 13:06'!
currentValueIn: aContext

	^nil! !

!ParseNode methodsFor: '*eToys-tiles' stamp: 'RAA 8/24/1999 18:18'!
explanation

	^self class printString! !


!ParseNode methodsFor: 'private' stamp: 'ls 1/29/2004 21:17'!
ifNilReceiver
	"assuming this object is the receiver of an ifNil:, what object is being asked about?"
	^self! !

!ParseNode methodsFor: 'private' stamp: 'sma 5/28/2000 10:47'!
nextWordFrom: aStream setCharacter: aBlock
	| outStream char |
	outStream _ WriteStream on: (String new: 16).
	[(aStream peekFor: Character space) 
		or: [aStream peekFor: Character tab]] whileTrue.
	[aStream atEnd
		or:
			[char _ aStream next.
			char = Character cr or: [char = Character space]]]
		whileFalse: [outStream nextPut: char].
	aBlock value: char.
	^ outStream contents! !

!ParseNode methodsFor: 'private' stamp: 'nk 7/11/2004 13:39'!
printSingleComment: aString on: aStream indent: indent 
	"Print the comment string, assuming it has been indented indent tabs.
	Break the string at word breaks, given the widths in the default
	font, at 450 points."

	| readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar |
	readStream _ ReadStream on: aString.
	font _ TextStyle default defaultFont.
	tabWidth _ TextConstants at: #DefaultTab.
	spaceWidth _ font widthOf: Character space.
	position _ indent * tabWidth.
	lineBreak _ 450.
	[readStream atEnd]
		whileFalse: 
			[word _ self nextWordFrom: readStream setCharacter: [:lc | lastChar _ lc].
			wordWidth _ word inject: 0 into: [:width :char | width + (font widthOf: char)].
			position _ position + wordWidth.
			position > lineBreak
				ifTrue: 
					[aStream skip: -1; crtab: indent.
					position _ indent * tabWidth + wordWidth + spaceWidth.
					lastChar = Character cr
						ifTrue: [[readStream peekFor: Character tab] whileTrue].
					word isEmpty ifFalse: [aStream nextPutAll: word; space]]
				ifFalse: 
					[aStream nextPutAll: word.
					readStream atEnd
						ifFalse: 
							[position _ position + spaceWidth.
							aStream space].
					lastChar = Character cr
						ifTrue: 
							[aStream skip: -1; crtab: indent.
							position _ indent * tabWidth.
							[readStream peekFor: Character tab] whileTrue]]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ParseNode class
	instanceVariableNames: ''!

!ParseNode class methodsFor: 'class initialization' stamp: 'ajh 8/12/2002 11:10'!
blockReturnCode

	^ EndRemote! !

!ParseNode class methodsFor: 'class initialization'!
initialize
	"ParseNode initialize. VariableNode initialize"
	LdInstType _ 1.
	LdTempType _ 2.
	LdLitType _ 3.
	LdLitIndType _ 4.
	SendType _ 5.
	CodeBases _ #(0 16 32 64 208 ).
	CodeLimits _ #(16 16 32 32 16 ).
	LdSelf _ 112.
	LdTrue _ 113.
	LdFalse _ 114.
	LdNil _ 115.
	LdMinus1 _ 116.
	LoadLong _ 128.
	Store _ 129.
	StorePop _ 130.
	ShortStoP _ 96.
	SendLong _ 131.
	DblExtDoAll _ 132.
	SendLong2 _ 134.
	LdSuper _ 133.
	Pop _ 135.
	Dup _ 136.
	LdThisContext _ 137.
	EndMethod _ 124.
	EndRemote _ 125.
	Jmp _ 144.
	Bfp _ 152.
	JmpLimit _ 8.
	JmpLong _ 164.  "code for jmp 0"
	BtpLong _ 168.
	SendPlus _ 176.
	Send _ 208.
	SendLimit _ 16! !

!ParseNode class methodsFor: 'class initialization' stamp: 'ajh 8/6/2002 12:04'!
popCode

	^ Pop! !
Object subclass: #ParseStack
	instanceVariableNames: 'position length'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Support'!
!ParseStack commentStamp: '<historical>' prior: 0!
I keep track of the current and high position of the stack that will be needed by code being compiled.!


!ParseStack methodsFor: 'accessing'!
pop: n

	(position _ position - n) < 0 
		ifTrue: [self error: 'Parse stack underflow']! !

!ParseStack methodsFor: 'accessing'!
push: n

	(position _ position + n) > length 
		ifTrue: [length _ position]! !

!ParseStack methodsFor: 'accessing'!
size

	^length! !


!ParseStack methodsFor: 'initialize-release'!
init

	length _ position _ 0! !


!ParseStack methodsFor: 'printing'!
printOn: aStream
	
	super printOn: aStream.
	aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length! !


!ParseStack methodsFor: 'results'!
position

	^position! !
Scanner subclass: #Parser
	instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Kernel'!
!Parser commentStamp: '<historical>' prior: 0!
I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead.!


!Parser methodsFor: 'error correction' stamp: 'rbb 2/18/2005 11:01'!
correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction
	"Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated.  abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector.  Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts."

	| alternatives aStream choice correctSelector userSelection lines firstLine |
	"If we can't ask the user, assume that the keyword will be defined later"
	self interactive ifFalse: [ ^ proposedKeyword asSymbol ].

	userSelection _ requestor selectionInterval.
	requestor selectFrom: spots first first to: spots last last.
	requestor select.
	alternatives _ Symbol possibleSelectorsFor: proposedKeyword.
	self flag: #toBeFixed.
	"alternatives addAll: (MultiSymbol possibleSelectorsFor: proposedKeyword)."

	aStream _ WriteStream on: (String new: 200).
	aStream nextPutAll: (proposedKeyword contractTo: 35); cr.
	firstLine _ 1.
 	alternatives do:
		[:sel | aStream nextPutAll: (sel contractTo: 35); nextPut: Character cr].
	aStream nextPutAll: 'cancel'.
	lines _ Array with: firstLine with: (alternatives size + firstLine).
	
	choice _ (UIManager default 
			chooseFrom: (aStream contents substrings)
			lines: lines
			title: 'Unknown selector, please\confirm, correct, or cancel' withCRs).

	(choice = 0) | (choice > (lines at: 2))
		ifTrue: [ ^ abortAction value ].

	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.

	choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ].
	correctSelector _ alternatives at: choice - 1.
	self substituteSelector: correctSelector keywords wordIntervals: spots.
	((proposedKeyword last ~= $:) and: [correctSelector last == $:]) ifTrue: [
		^ abortAction value].
	^ correctSelector.
! !

!Parser methodsFor: 'error correction' stamp: 'rbb 2/18/2005 09:01'!
correctVariable: proposedVariable interval: spot
	"Correct the proposedVariable to a known variable, or declare it as a new
	variable if such action is requested.  We support declaring lowercase
	variables as temps or inst-vars, and uppercase variables as Globals or 
	ClassVars, depending on whether the context is nil (class=UndefinedObject).
	Spot is the interval within the test stream of the variable.
	rr 3/4/2004 10:26 : adds the option to define a new class. "

	| tempIvar labels actions lines alternatives binding userSelection choice action |

	"Check if this is an i-var, that has been corrected already (ugly)"
	(encoder classEncoding allInstVarNames includes: proposedVariable) ifTrue: [
		^LiteralVariableNode new 
			name: proposedVariable index: (encoder classEncoding allInstVarNames indexOf: proposedVariable) - 1 type: 1;
			yourself ].

	"If we can't ask the user for correction, make it undeclared"
	self interactive 
		ifFalse: [ ^encoder undeclared: proposedVariable ].

	"First check to see if the requestor knows anything about the variable"
	tempIvar _ proposedVariable first canBeNonGlobalVarInitial.
	(tempIvar and: [ (binding _ requestor bindingOf: proposedVariable) notNil ])
		ifTrue: [ ^encoder global: binding name: proposedVariable ].
	userSelection _ requestor selectionInterval.
	requestor selectFrom: spot first to: spot last.
	requestor select.

	"Build the menu with alternatives"
	labels _ OrderedCollection new. actions _ OrderedCollection new. lines _ OrderedCollection new.
	alternatives _ encoder possibleVariablesFor: proposedVariable.
	tempIvar 
		ifTrue: [ 
			labels add: 'declare temp'. 
			actions add: [ self declareTempAndPaste: proposedVariable ].
			labels add: 'declare instance'.
			actions add: [ self declareInstVar: proposedVariable ] ]
		ifFalse: [ 
			labels add: 'define new class'.
			actions add: [self defineClass: proposedVariable].
			labels add: 'declare global'.
			actions add: [ self declareGlobal: proposedVariable ].
			encoder classEncoding == UndefinedObject ifFalse: [ 
				labels add: 'declare class variable'.
				actions add: [ self declareClassVar: proposedVariable ] ] ].
	lines add: labels size.
	alternatives do: [ :each | 
		labels add: each.
		actions add: [ 
			self substituteWord: each wordInterval: spot offset: 0.
			encoder encodeVariable: each ] fixTemps ].
	lines add: labels size.
	labels add: 'cancel'.

	"Display the pop-up menu"
	choice _ (UIManager default chooseFrom: labels asArray lines: lines asArray
		title:  'Unknown variable: ', proposedVariable, ' please correct, or cancel:').
	action _ actions at: choice ifAbsent: [ ^self fail ].

	"Execute the selected action"
	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.
	^action value! !

!Parser methodsFor: 'error correction'!
declareClassVar: name
	| sym class |
	sym _ name asSymbol.
	class _ encoder classEncoding.
	class _ class theNonMetaClass.		"not the metaclass"
	class addClassVarName: name.
	^ encoder global: (class classPool associationAt: sym)
			name: sym! !

!Parser methodsFor: 'error correction'!
declareGlobal: name
	| sym |
	sym _ name asSymbol.
	Smalltalk at: sym put: nil.
	^ encoder global: (Smalltalk associationAt: sym) name: sym! !

!Parser methodsFor: 'error correction' stamp: 'rr 3/6/2004 16:07'!
declareInstVar: name
	" rr 3/6/2004 16:06 : adds the line to correctly compute the index. uncommented the option in 
	the caller."
	| index |
	encoder classEncoding addInstVarName: name.
	index _ encoder classEncoding instVarNames indexOf: name.
	encoder classEncoding allSuperclassesDo: [:cls | index := index + cls instVarNames size].
	^LiteralVariableNode new
		name: name index: index - 1 type: 1;
		yourself
		! !

!Parser methodsFor: 'error correction' stamp: 'RAA 6/5/2001 11:57'!
declareTempAndPaste: name
	| insertion delta theTextString characterBeforeMark |

	theTextString _ requestor text string.
	characterBeforeMark _ theTextString at: tempsMark-1 ifAbsent: [$ ].
	(theTextString at: tempsMark) = $| ifTrue: [
  		"Paste it before the second vertical bar"
		insertion _ name, ' '.
		characterBeforeMark isSeparator ifFalse: [insertion _ ' ', insertion].
		delta _ 0.
	] ifFalse: [
		"No bars - insert some with CR, tab"
		insertion _ '| ' , name , ' |',String cr.
		delta _ 2.	"the bar and CR"
		characterBeforeMark = Character tab ifTrue: [
			insertion _ insertion , String tab.
			delta _ delta + 1.	"the tab"
		].
	].
	tempsMark _ tempsMark +
		(self substituteWord: insertion
			wordInterval: (tempsMark to: tempsMark-1)
			offset: 0) - delta.
	^ encoder bindAndJuggle: name! !

!Parser methodsFor: 'error correction' stamp: 'DF 4/28/2006 14:31'!
defineClass: className 
	"prompts the user to define a new class,  
	asks for it's category, and lets the users edit further  
	the definition"
	| sym cat def d2 |
	sym := className asSymbol.
	cat := UIManager default request: 'Enter class category : ' initialAnswer: self encoder classEncoding theNonMetaClass category.
	cat
		ifEmpty: [cat := 'Unknown'].
	def := 'Object subclass: #' , sym , '
		instanceVariableNames: '''' 
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''' , cat , ''''.
	d2 := UIManager default request: 'Edit class definition : ' initialAnswer: def.
	d2
		ifEmpty: [d2 := def].
	Compiler evaluate: d2.
	^ encoder
		global: (Smalltalk associationAt: sym)
		name: sym! !

!Parser methodsFor: 'error correction' stamp: 'rbb 2/18/2005 09:10'!
queryUndefined
	| varStart varName | 
	varName _ parseNode key.
	varStart _ self endOfLastToken + requestorOffset - varName size + 1.
	requestor selectFrom: varStart to: varStart + varName size - 1; select.
	((UIManager default 
		chooseFrom: #('yes' 'no') 
		title: ((varName , ' appears to be\undefined at this point.Proceed anyway?') 
				withCRs asText makeBoldFrom: 1 to: varName size))
		= 1) ifFalse: [^ self fail]! !

!Parser methodsFor: 'error correction' stamp: 'rbb 2/18/2005 09:08'!
removeUnusedTemps
	"Scan for unused temp names, and prompt the user about the prospect of removing each one found"

	| str end start madeChanges | 
	madeChanges _ false.
	str _ requestor text string.
	((tempsMark between: 1 and: str size)
		and: [(str at: tempsMark) = $|]) ifFalse: [^ self].
	encoder unusedTempNames do:
		[:temp |
		((UIManager default 
				chooseFrom: #('yes' 'no') 
				title: ((temp , ' appears to be\unused in this method.\OK to remove it?') 
						withCRs asText makeBoldFrom: 1 to: temp size)) = 1)
		ifTrue:
		[(encoder encodeVariable: temp) isUndefTemp
			ifTrue:
			[end _ tempsMark.
			["Beginning at right temp marker..."
			start _ end - temp size + 1.
			end < temp size or: [temp = (str copyFrom: start to: end)
					and: [(str at: start-1) isAlphaNumeric not & (str at: end+1) isAlphaNumeric not]]]
			whileFalse:
				["Search left for the unused temp"
				end _ requestor nextTokenFrom: end direction: -1].
			end < temp size ifFalse:
				[(str at: start-1) = $  ifTrue: [start _ start-1].
				requestor correctFrom: start to: end with: ''.
				str _ str copyReplaceFrom: start to: end with: ''. 
				madeChanges _ true.
				tempsMark _ tempsMark - (end-start+1)]]
			ifFalse:
			[self inform:
'You''ll first have to remove the
statement where it''s stored into']]].
	madeChanges ifTrue: [ParserRemovedUnusedTemps signal]! !

!Parser methodsFor: 'error correction'!
substituteSelector: selectorParts wordIntervals: spots
	"Substitute the correctSelector into the (presuamed interactive) receiver."
	| offset |
	offset _ 0.
	selectorParts with: spots do:
		[ :word :interval |
		offset _ self substituteWord: word wordInterval: interval offset: offset ]
! !

!Parser methodsFor: 'error correction'!
substituteWord: correctWord wordInterval: spot offset: o
	"Substitute the correctSelector into the (presuamed interactive) receiver."

	requestor correctFrom: (spot first + o)
					to: (spot last + o)
					with: correctWord.

	requestorOffset _ requestorOffset + correctWord size - spot size.
	^ o + correctWord size - spot size! !


!Parser methodsFor: 'error handling' stamp: 'hmm 7/18/2001 21:45'!
expected: aString 
	"Notify a problem at token 'here'."

	tokenType == #doIt ifTrue: [hereMark _ hereMark + 1].
	hereType == #doIt ifTrue: [hereMark _ hereMark + 1].
	^ self notify: aString , ' expected' at: hereMark + requestorOffset! !

!Parser methodsFor: 'error handling'!
fail

	| exitBlock |
	encoder == nil
		ifFalse: [encoder release. encoder _ nil]. "break cycle"
	exitBlock _ failBlock.
	failBlock _ nil.
	^exitBlock value! !

!Parser methodsFor: 'error handling' stamp: 'stephaneducassse 11/5/2005 16:39'!
interactive
	"this version of the method is necessary to load code from MC else the interactive mode is one. 
	This method is really bad since it links the compiler package with the Tools
	one. The solution would be to have a real SyntaxError exception belonging to the 
	compiler package and not a subclass of StringHolder - sd Nov 2005"
	"the code submitted by PlusTools is ideally the one that should be used
	interactive

	      ^requestor ~~ nil "
	
	^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not! !

!Parser methodsFor: 'error handling'!
notify: aString 
	"Notify problem at token before 'here'."

	^self notify: aString at: prevMark + requestorOffset! !

!Parser methodsFor: 'error handling' stamp: 'KLC 11/28/2005 18:01'!
notify: string at: location
	requestor isNil
		ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail  "failure setting up syntax error"].
				SyntaxErrorNotification
					inClass: encoder classEncoding
					category: encoder classEncoding category
					withCode: 
						(source contents
							copyReplaceFrom: location
							to: location - 1
							with: string , ' ->')
					doitFlag: doitFlag]
		ifFalse: [requestor
					notify: string , ' ->'
					at: location
					in: source].
	^self fail! !

!Parser methodsFor: 'error handling' stamp: 'di 2/9/1999 15:43'!
offEnd: aString 
	"Notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!"

	requestorOffset == nil
		ifTrue: [^ self notify: aString at: mark]
		ifFalse: [^ self notify: aString at: mark + requestorOffset]
! !


!Parser methodsFor: 'expression types'!
argumentName

	hereType == #word
		ifFalse: [^self expected: 'Argument name'].
	^self advance! !

!Parser methodsFor: 'expression types' stamp: 'hmm 7/16/2001 18:47'!
assignment: varNode
	" var '_' expression => AssignmentNode."
	| loc start |
	(loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0
		ifTrue: [^self notify: 'Cannot store into' at: loc].
	start _ self startOfNextToken.
	varNode nowHasDef.
	self advance.
	self expression ifFalse: [^self expected: 'Expression'].
	parseNode _ AssignmentNode new
				variable: varNode
				value: parseNode
				from: encoder
				sourceRange: (start to: self endOfLastToken).
	^true! !

!Parser methodsFor: 'expression types' stamp: 'hmm 7/17/2001 21:03'!
blockExpression
	"[ ({:var} |) (| {temps} |) (statements) ] => BlockNode."

	| variableNodes temporaryBlockVariables start |

	variableNodes _ OrderedCollection new.
	start _ prevMark + requestorOffset.
	"Gather parameters."
	[self match: #colon] whileTrue: [variableNodes addLast: (encoder autoBind: self argumentName)].
	(variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^self expected: 'Vertical bar'].

	temporaryBlockVariables _ self temporaryBlockVariables.
	self statements: variableNodes innerBlock: true.
	parseNode temporaries: temporaryBlockVariables.

	(self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket'].

	encoder noteSourceRange: (self endOfLastToken to: self endOfLastToken) forNode: parseNode.

	"The scope of the parameters and temporary block variables is no longer active."
	temporaryBlockVariables do: [:variable | variable scope: -1].
	variableNodes do: [:variable | variable scope: -1]! !

!Parser methodsFor: 'expression types' stamp: 'di 3/8/2000 09:36'!
braceExpression
	" { elements } => BraceNode."

	| elements locations loc more |
	elements _ OrderedCollection new.
	locations _ OrderedCollection new.
	self advance.
	more _ hereType ~~ #rightBrace.
	[more]
		whileTrue: 
			[loc _ hereMark + requestorOffset.
			self expression
				ifTrue: 
					[elements addLast: parseNode.
					locations addLast: loc]
				ifFalse:
					[^self expected: 'Variable or expression'].
			(self match: #period)
				ifTrue: [more _ hereType ~~ #rightBrace]
				ifFalse: [more _ false]].
	parseNode _ BraceNode new elements: elements sourceLocations: locations.
	(self match: #rightBrace)
		ifFalse: [^self expected: 'Period or right brace'].
	^true! !

!Parser methodsFor: 'expression types'!
cascade
	" {; message} => CascadeNode."

	| rcvr msgs |
	parseNode canCascade
		ifFalse: [^self expected: 'Cascading not'].
	rcvr _ parseNode cascadeReceiver.
	msgs _ OrderedCollection with: parseNode.
	[self match: #semicolon]
		whileTrue: 
			[parseNode _ rcvr.
			(self messagePart: 3 repeat: false)
				ifFalse: [^self expected: 'Cascade'].
			parseNode canCascade
				ifFalse: [^self expected: '<- No special messages'].
			parseNode cascadeReceiver.
			msgs addLast: parseNode].
	parseNode _ CascadeNode new receiver: rcvr messages: msgs! !

!Parser methodsFor: 'expression types' stamp: 'di 11/19/1999 07:43'!
expression

	(hereType == #word and: [tokenType == #leftArrow])
		ifTrue: [^ self assignment: self variable].
	hereType == #leftBrace
		ifTrue: [self braceExpression]
		ifFalse: [self primaryExpression ifFalse: [^ false]].
	(self messagePart: 3 repeat: true)
		ifTrue: [hereType == #semicolon ifTrue: [self cascade]].
	^ true! !

!Parser methodsFor: 'expression types' stamp: 'di 4/5/2000 08:27'!
keylessMessagePartTest: level repeat: repeat
! !

!Parser methodsFor: 'expression types' stamp: 'yo 8/30/2002 14:41'!
messagePart: level repeat: repeat

	| start receiver selector args precedence words keywordStart |
	[receiver _ parseNode.
	(hereType == #keyword and: [level >= 3])
		ifTrue: 
			[start _ self startOfNextToken.
			selector _ WriteStream on: (String new: 32).
			args _ OrderedCollection new.
			words _ OrderedCollection new.
			[hereType == #keyword]
				whileTrue: 
					[keywordStart _ self startOfNextToken + requestorOffset.
					selector nextPutAll: self advance.
					words addLast: (keywordStart to: self endOfLastToken + requestorOffset).
					self primaryExpression ifFalse: [^self expected: 'Argument'].
					self messagePart: 2 repeat: true.
					args addLast: parseNode].
			(Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym])
				ifFalse: [ selector _ self correctSelector: selector contents
										wordIntervals: words
										exprInterval: (start to: self endOfLastToken)
										ifAbort: [ ^ self fail ] ].
			precedence _ 3]
		ifFalse: [((hereType == #binary or: [hereType == #verticalBar])
				and: [level >= 2])
				ifTrue: 
					[start _ self startOfNextToken.
					selector _ self advance asOctetString asSymbol.
					self primaryExpression ifFalse: [^self expected: 'Argument'].
					self messagePart: 1 repeat: true.
					args _ Array with: parseNode.
					precedence _ 2]
				ifFalse: [hereType == #word
						ifTrue: 
							[start _ self startOfNextToken.
							selector _ self advance.
							args _ #().
							words _ OrderedCollection with: (start  + requestorOffset to: self endOfLastToken + requestorOffset).
							(Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym])
								ifFalse: [ selector _ self correctSelector: selector
													wordIntervals: words
													exprInterval: (start to: self endOfLastToken)
													ifAbort: [ ^ self fail ] ].
							precedence _ 1]
						ifFalse: [^args notNil]]].
	parseNode _ MessageNode new
				receiver: receiver
				selector: selector
				arguments: args
				precedence: precedence
				from: encoder
				sourceRange: (start to: self endOfLastToken).
	repeat]
		whileTrue: [].
	^true! !

!Parser methodsFor: 'expression types' stamp: 'lr 7/3/2006 14:37'!
method: doit context: ctxt encoder: encoderToUse
	" pattern [ | temporaries ] block => MethodNode."

	| sap blk prim temps messageComment methodNode |
	encoder _ encoderToUse.
	sap _ self pattern: doit inContext: ctxt.
	"sap={selector, arguments, precedence}"
	(sap at: 2) do: [:argNode | argNode isArg: true].
	doit ifFalse: [ self pragmaSequence ].
	temps _ self temporariesIn: (sap at: 1)..
	messageComment _ currentComment.
	currentComment _ nil.
	doit ifFalse: [ self pragmaSequence ].
	prim := self pragmaPrimitives.
	self statements: #() innerBlock: doit.
	blk _ parseNode.
	doit ifTrue: [blk returnLast]
		ifFalse: [blk returnSelfIfNoOther].
	hereType == #doIt ifFalse: [^self expected: 'Nothing more'].
	self interactive ifTrue: [self removeUnusedTemps].
	methodNode _ self newMethodNode comment: messageComment.
	^ methodNode
		selector: (sap at: 1)
		arguments: (sap at: 2)
		precedence: (sap at: 3)
		temporaries: temps
		block: blk
		encoder: encoder
		primitive: prim
		properties: properties! !

!Parser methodsFor: 'expression types' stamp: 'di 5/30/2000 21:59'!
newMethodNode

	^ MethodNode new! !

!Parser methodsFor: 'expression types' stamp: 'ar 1/2/2002 14:31'!
pattern: fromDoit inContext: ctxt 
	" unarySelector | binarySelector arg | keyword arg {keyword arg} =>  
	{selector, arguments, precedence}."
	| args selector |
	doitFlag _ fromDoit.
	fromDoit ifTrue:
			[ctxt == nil
				ifTrue: [^ {#DoIt. {}. 1}]
				ifFalse: [^ {#DoItIn:. {encoder encodeVariable: 'homeContext'}. 3}]].

	hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}].

	(hereType == #binary or: [hereType == #verticalBar])
		ifTrue: 
			[selector _ self advance asSymbol.
			args _ Array with: (encoder bindArg: self argumentName).
			^ {selector. args. 2}].

	hereType == #keyword
		ifTrue: 
			[selector _ WriteStream on: (String new: 32).
			args _ OrderedCollection new.
			[hereType == #keyword] whileTrue:[
				selector nextPutAll: self advance.
				args addLast: (encoder bindArg: self argumentName).
			].
			^ {selector contents asSymbol. args. 3}].

	^ self expected: 'Message pattern'! !

!Parser methodsFor: 'expression types'!
primaryExpression 
	hereType == #word 
		ifTrue: 
			[parseNode _ self variable.
			(parseNode isUndefTemp and: [self interactive])
				ifTrue: [self queryUndefined].
			parseNode nowHasRef.
			^ true].
	hereType == #leftBracket
		ifTrue: 
			[self advance.
			self blockExpression.
			^true].
	hereType == #leftBrace
		ifTrue: 
			[self braceExpression.
			^true].
	hereType == #leftParenthesis
		ifTrue: 
			[self advance.
			self expression ifFalse: [^self expected: 'expression'].
			(self match: #rightParenthesis)
				ifFalse: [^self expected: 'right parenthesis'].
			^true].
	(hereType == #string or: [hereType == #number or: [hereType == #literal]])
		ifTrue: 
			[parseNode _ encoder encodeLiteral: self advance.
			^true].
	(here == #- and: [tokenType == #number])
		ifTrue: 
			[self advance.
			parseNode _ encoder encodeLiteral: self advance negated.
			^true].
	^false! !

!Parser methodsFor: 'expression types' stamp: 'di 6/7/2000 08:45'!
statements: argNodes innerBlock: inner

	| stmts returns start more blockComment |
	stmts _ OrderedCollection new.
	"give initial comment to block, since others trail statements"
	blockComment _ currentComment.
	currentComment _ nil.
	returns _ false.
	more _ hereType ~~ #rightBracket.
	[more]
		whileTrue: 
		[start _ self startOfNextToken.
		(returns _ self matchReturn)
			ifTrue: 
				[self expression
					ifFalse: [^self expected: 'Expression to return'].
				self addComment.
				stmts addLast: (parseNode isReturningIf
					ifTrue: [parseNode]
					ifFalse: [ReturnNode new
							expr: parseNode
							encoder: encoder
							sourceRange: (start to: self endOfLastToken)])]
			ifFalse: 
				[self expression
					ifTrue: 
						[self addComment.
						stmts addLast: parseNode]
					ifFalse: 
						[self addComment.
						stmts size = 0
							ifTrue: 
								[stmts addLast: 
									(encoder encodeVariable:
										(inner ifTrue: ['nil'] ifFalse: ['self']))]]].
		returns 
			ifTrue: 
				[self match: #period.
				(hereType == #rightBracket or: [hereType == #doIt])
					ifFalse: [^self expected: 'End of block']].
		more _ returns not and: [self match: #period]].
	parseNode _ BlockNode new
				arguments: argNodes
				statements: stmts
				returns: returns
				from: encoder.
	parseNode comment: blockComment.
	^ true! !

!Parser methodsFor: 'expression types' stamp: 'ar 1/4/2002 00:23'!
temporaries
	" [ '|' (variable)* '|' ]"
	| vars theActualText |
	(self match: #verticalBar) ifFalse: 
		["no temps"
		doitFlag ifTrue: [self interactive
				ifFalse: [tempsMark _ 1]
				ifTrue: [tempsMark _ requestor selectionInterval first].
			^ #()].
		tempsMark _ (prevEnd ifNil: [0]) + 1.
		tempsMark _ hereMark	"formerly --> prevMark + prevToken".

		tempsMark > 0 ifTrue:
			[theActualText _ source contents.
			[tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]]
				whileTrue: [tempsMark _ tempsMark + 1]].
			^ #()].
	vars _ OrderedCollection new.
	[hereType == #word]
		whileTrue: [vars addLast: (encoder bindTemp: self advance)].
	(self match: #verticalBar) ifTrue: 
		[tempsMark _ prevMark.
		^ vars].
	^ self expected: 'Vertical bar'
! !

!Parser methodsFor: 'expression types' stamp: 'mir 1/17/2004 12:27'!
temporariesIn: methodSelector
	" [ '|' (variable)* '|' ]"
	| vars theActualText |
	(self match: #verticalBar) ifFalse: 
		["no temps"
		doitFlag ifTrue: [requestor
				ifNil: [tempsMark _ 1]
				ifNotNil: [tempsMark _ requestor selectionInterval first].
			^ #()].
		tempsMark _ (prevEnd ifNil: [0]) + 1.
		tempsMark _ hereMark	"formerly --> prevMark + prevToken".

		tempsMark > 0 ifTrue:
			[theActualText _ source contents.
			[tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]]
				whileTrue: [tempsMark _ tempsMark + 1]].
			^ #()].
	vars _ OrderedCollection new.
	[hereType == #word]
		whileTrue: [vars addLast: (encoder bindTemp: self advance in: methodSelector)].
	(self match: #verticalBar) ifTrue: 
		[tempsMark _ prevMark.
		^ vars].
	^ self expected: 'Vertical bar'! !

!Parser methodsFor: 'expression types' stamp: 'crl 2/26/1999 12:22'!
temporaryBlockVariables
	"Scan and answer temporary block variables."

	| variables |

	(self match: #verticalBar) ifFalse: [
		"There are't any temporary variables."
		^#()].

	variables _ OrderedCollection new.
	[hereType == #word] whileTrue: [variables addLast: (encoder bindBlockTemp: self advance)].
	(self match: #verticalBar) ifTrue: [^variables].
	^self expected: 'Vertical bar'! !

!Parser methodsFor: 'expression types' stamp: 'di 12/4/1999 21:04'!
variable

	| varName varStart varEnd |
	varStart _ self startOfNextToken + requestorOffset.
	varName _ self advance.
	varEnd _ self endOfLastToken + requestorOffset.
	^ encoder encodeVariable: varName
		sourceRange: (varStart to: varEnd)
		ifUnknown: [self correctVariable: varName interval: (varStart to: varEnd)]! !


!Parser methodsFor: 'pragmas' stamp: 'lr 2/6/2006 20:50'!
addPragma: aPragma
	self properties addPragma: aPragma.! !

!Parser methodsFor: 'pragmas' stamp: 'lr 2/6/2006 21:02'!
pragmaLiteral
	"Read a pragma literal."

	(hereType == #string or: [ hereType == #literal or: [ hereType == #number ] ])
		ifTrue: [ ^ self advance ].
	(here == $# and: [ tokenType == #word ])
		ifTrue: [ ^ self advance ].
	(here == #- and: [ tokenType == #number ])
		ifTrue: [ ^ (self advance; advance) negated ].
	(here = 'true' or: [ here = 'false' or: [ here = 'nil' or: [ Smalltalk hasClassNamed: here ] ] ])
		ifTrue: [ ^ Compiler evaluate: self advance ].
	^ self expected: 'Literal constant'.! !

!Parser methodsFor: 'pragmas' stamp: 'lr 2/6/2006 20:23'!
pragmaPrimitives
	| primitives |
	primitives := self properties pragmas select: [ :each | 
		#( primitive: primitive:module: ) 
			includes: each keyword ].
	primitives isEmpty 
		ifTrue: [ ^ 0 ].
	primitives size = 1 
		ifFalse: [ ^ self notify: 'Ambigous primitives' ].
	^ primitives first message sendTo: self.! !

!Parser methodsFor: 'pragmas' stamp: 'lr 2/6/2006 20:23'!
pragmaSequence
	"Parse a sequence of method pragmas."
	
	[ true ] whileTrue: [
		(self matchToken: #<)
			ifFalse: [ ^ self ].
		self pragmaStatement.
		(self matchToken: #>)
			ifFalse: [ ^ self expected: '>' ] ].! !

!Parser methodsFor: 'pragmas' stamp: 'lr 7/9/2006 19:37'!
pragmaStatement
	"Read a single pragma statement. Parse all generic pragmas in the form of: <key1: val1 key2: val2 ...> and remember them, including primitives."
	
	| arguments keyword |
	(hereType = #keyword or: [ hereType = #word ])
		ifFalse: [  ^ self expected: 'pragma declaration' ].

	" This is a ugly hack into the compiler of the FFI package. FFI should be changed to use propre pragmas that can be parsed with the code here. "
	(here = #apicall: or: [ here = #cdecl: ])
		ifTrue: [ ^ self externalFunctionDeclaration ].

	arguments := Array new.
	keyword := self advance.
	keyword last = $: ifTrue: [
		[ arguments := arguments copyWith: self pragmaLiteral.
		  hereType = #keyword ] whileTrue: [ keyword := keyword , self advance ] ].
	keyword numArgs ~= arguments size
		ifTrue: [ ^ self expected: 'pragma argument' ].
	self addPragma: (Pragma 
		keyword: keyword asSymbol 
		arguments: arguments).
	^ true! !

!Parser methodsFor: 'pragmas' stamp: 'lr 2/6/2006 20:39'!
properties
	^ properties ifNil: [ properties := MethodProperties new ].! !


!Parser methodsFor: 'primitives'!
allocateLiteral: lit
	encoder litIndex: lit! !

!Parser methodsFor: 'primitives' stamp: 'lr 2/6/2006 20:50'!
externalFunctionDeclaration
	"Parse the function declaration for a call to an external library."
	| descriptorClass callType retType externalName args argType module fn |
	descriptorClass _ Smalltalk at: #ExternalFunction ifAbsent:[nil].
	descriptorClass == nil ifTrue:[^false].
	callType _ descriptorClass callingConventionFor: here.
	callType == nil ifTrue:[^false].
	"Parse return type"
	self advance.
	retType _ self externalType: descriptorClass.
	retType == nil ifTrue:[^self expected:'return type'].
	"Parse function name or index"
	externalName _ here.
	(self match: #string) 
		ifTrue:[externalName _ externalName asSymbol]
		ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']].
	(self matchToken:'(' asSymbol) ifFalse:[^self expected:'argument list'].
	args _ WriteStream on: Array new.
	[here == ')' asSymbol] whileFalse:[
		argType _ self externalType: descriptorClass.
		argType == nil ifTrue:[^self expected:'argument'].
		argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType].
	].
	(self matchToken:')' asSymbol) ifFalse:[^self expected:')'].
	(self matchToken: 'module:') ifTrue:[
		module _ here.
		(self match: #string) ifFalse:[^self expected: 'String'].
		module _ module asSymbol].
	Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn|
		fn _ xfn name: externalName 
				module: module 
				callType: callType
				returnType: retType
				argumentTypes: args contents.
		self allocateLiteral: fn.
	].
	self addPragma: (Pragma keyword: #primitive: arguments: #(120)).
	^true! !

!Parser methodsFor: 'primitives' stamp: 'ar 12/2/1999 16:49'!
externalType: descriptorClass
	"Parse an return an external type"
	| xType |
	xType _ descriptorClass atomicTypeNamed: here.
	xType == nil ifTrue:["Look up from class scope"
		Symbol hasInterned: here ifTrue:[:sym|
			xType _ descriptorClass structTypeNamed: sym]].
	xType == nil ifTrue:[
		"Raise an error if user is there"
		self interactive ifTrue:[^nil].
		"otherwise go over it silently"
		xType _ descriptorClass forceTypeNamed: here].
	self advance.
	(self matchToken:#*)
		ifTrue:[^xType asPointerType]
		ifFalse:[^xType]! !

!Parser methodsFor: 'primitives' stamp: 'lr 2/6/2006 20:24'!
primitive: anIntegerOrString
	"Create indexed primitive."
		
	^ anIntegerOrString isInteger
		ifTrue: [ anIntegerOrString ]
		ifFalse: [ 
			anIntegerOrString isString
				ifTrue: [ self primitive: anIntegerOrString module: nil ]
				ifFalse: [ self expected: 'Indexed primitive' ] ].! !

!Parser methodsFor: 'primitives' stamp: 'lr 2/6/2006 20:24'!
primitive: aNameString module: aModuleStringOrNil
	"Create named primitive."
	
	(aNameString isString and: [ aModuleStringOrNil isNil or: [ aModuleStringOrNil isString ] ])
		ifFalse: [ ^ self expected: 'Named primitive' ].
	self allocateLiteral: (Array 
		with: (aModuleStringOrNil isNil 
			ifFalse: [ aModuleStringOrNil asSymbol ])
		with: aNameString asSymbol
		with: 0 with: 0).
	^ 117.! !


!Parser methodsFor: 'public access'!
encoder
	^ encoder! !

!Parser methodsFor: 'public access' stamp: 'ajh 1/22/2003 16:51'!
parse: sourceStreamOrString class: behavior

	^ self parse: sourceStreamOrString readStream class: behavior
		noPattern: false context: nil notifying: nil ifFail: [self parseError]! !

!Parser methodsFor: 'public access' stamp: 'stephaneducassse 11/5/2005 16:35'!
parse: sourceStream class: class category: aCategory noPattern: noPattern context: ctxt notifying: req ifFail: aBlock 
        "Answer a MethodNode for the argument, sourceStream, that is the root of 
        a parse tree. Parsing is done with respect to the argument, class, to find 
        instance, class, and pool variables; and with respect to the argument, 
        ctxt, to find temporary variables. Errors in parsing are reported to the 
        argument, req, if not nil; otherwise aBlock is evaluated. The argument 
        noPattern is a Boolean that is true if the the sourceStream does not 
        contain a method header (i.e., for DoIts)."

		category := aCategory.
        	^ self parse: sourceStream class: class  noPattern: noPattern context: ctxt notifying: req ifFail: aBlock 
! !

!Parser methodsFor: 'public access' stamp: 'stephaneducassse 11/5/2005 16:26'!
parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock 
        "Answer a MethodNode for the argument, sourceStream, that is the root of 
        a parse tree. Parsing is done with respect to the argument, class, to find 
        instance, class, and pool variables; and with respect to the argument, 
        ctxt, to find temporary variables. Errors in parsing are reported to the 
        argument, req, if not nil; otherwise aBlock is evaluated. The argument 
        noPattern is a Boolean that is true if the the sourceStream does not 
        contain a method header (i.e., for DoIts)."

         | methNode repeatNeeded myStream s p |
 
        myStream _ sourceStream.
        [repeatNeeded _ false.
	   p _ myStream position.
	   s _ myStream upToEnd.
	   myStream position: p.
        self init: myStream notifying: req failBlock: [^ aBlock value].
        doitFlag _ noPattern.
        failBlock_ aBlock.
        [methNode _ self method: noPattern context: ctxt
                                encoder: (Encoder new init: class context: ctxt notifying: self)] 
                on: ParserRemovedUnusedTemps 
                do: 
                        [ :ex | repeatNeeded _ (requestor isKindOf: TextMorphEditor) not.
                        myStream _ ReadStream on: requestor text string.
                        ex resume].
        repeatNeeded] whileTrue.
        encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow"
	   methNode sourceText: s.
        ^ methNode! !

!Parser methodsFor: 'public access' stamp: 'md 8/14/2005 17:53'!
parseArgsAndTemps: aString notifying: req 
        "Parse the argument, aString, notifying req if an error occurs. Otherwise, 
        answer a two-element Array containing Arrays of strings (the argument 
        names and temporary variable names)."

        aString == nil ifTrue: [^#()].
        doitFlag _ false.               "Don't really know if a doit or not!!"
        ^self initPattern: aString
                notifying: req
                return: [:pattern | (pattern at: 2) , (self temporariesIn: (pattern at: 1))]! !

!Parser methodsFor: 'public access'!
parseMethodComment: aString setPattern: aBlock
	"Answer the method comment for the argument, aString. Evaluate aBlock 
	with the message pattern in the form #(selector, arguments, precedence)."

	self
		initPattern: aString
		notifying: nil
		return: aBlock.
	currentComment==nil
		ifTrue:	[^OrderedCollection new]
		ifFalse:	[^currentComment]! !

!Parser methodsFor: 'public access'!
parseSelector: aString 
	"Answer the message selector for the argument, aString, which should 
	parse successfully up to the temporary declaration or the end of the 
	method header."

	^self
		initPattern: aString
		notifying: nil
		return: [:pattern | pattern at: 1]! !

!Parser methodsFor: 'public access' stamp: 'md 1/20/2006 16:31'!
parse: sourceStream class: class noPattern: noPattern notifying: req ifFail: aBlock

	^ self parse: sourceStream class: class noPattern: noPattern context: nil notifying: req ifFail: aBlock! !


!Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 20:12'!
advance
	| this |
	prevMark _ hereMark.
	prevEnd _ hereEnd.
	this _ here.
	here _ token.
	hereType _ tokenType.
	hereMark _ mark.
	hereEnd _ source position - (source atEnd ifTrue: [hereChar == 30 asCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]).
	self scanToken.
	"Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr."
	^this! !

!Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 19:23'!
endOfLastToken

	^ prevEnd ifNil: [mark]! !

!Parser methodsFor: 'scanning'!
match: type 
	"Answer with true if next tokens type matches."

	hereType == type
		ifTrue: 
			[self advance.
			^true].
	^false! !

!Parser methodsFor: 'scanning' stamp: 'di 6/7/2000 08:44'!
matchReturn

	^ self match: #upArrow! !

!Parser methodsFor: 'scanning'!
matchToken: thing 
	"Matches the token, not its type."

	here = thing ifTrue: [self advance. ^true].
	^false! !

!Parser methodsFor: 'scanning'!
startOfNextToken
	"Return starting position in source of next token."

	hereType == #doIt ifTrue: [^source position + 1].
	^hereMark! !


!Parser methodsFor: 'temps'!
bindArg: name

	^ self bindTemp: name! !

!Parser methodsFor: 'temps'!
bindTemp: name

	^name! !

!Parser methodsFor: 'temps' stamp: 'al 9/29/2005 16:40'!
bindTemp: name in: methodSelector

	^self bindTemp: name! !


!Parser methodsFor: 'private'!
addComment

	parseNode ~~ nil
		ifTrue: 
			[parseNode comment: currentComment.
			currentComment _ nil]! !

!Parser methodsFor: 'private'!
init: sourceStream notifying: req failBlock: aBlock

	requestor _ req.
	failBlock _ aBlock.
	super scan: sourceStream.
	prevMark _ hereMark _ mark.
	requestorOffset _ 0.
	self advance! !

!Parser methodsFor: 'private'!
initPattern: aString notifying: req return: aBlock

	| result |
	self
		init: (ReadStream on: aString asString)
		notifying: req
		failBlock: [^nil].
	encoder _ self.
	result _ aBlock value: (self pattern: false inContext: nil).
	encoder _ failBlock _ nil.  "break cycles"
	^result! !
Notification subclass: #ParserRemovedUnusedTemps
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Tests'!
PasteUpMorph subclass: #PartsBin
	instanceVariableNames: ''
	classVariableNames: 'Thumbnails'
	poolDictionaries: ''
	category: 'MorphicExtras-PartsBin'!

!PartsBin methodsFor: 'dropping/grabbing' stamp: 'sw 4/22/2005 21:55'!
morphToDropFrom: aMorph
	"Answer the morph to drop if the user attempts to drop aMorph"

	| aButton |
	((aMorph isKindOf: IconicButton) and: [aMorph actionSelector == #launchPartVia:label:])
		ifTrue: [^ aMorph].  
	"The above handles the unusual case of a button that's already set up in a manner suitable for living in PartsBin; the archetypal example is the attempt to reposition an object within a partsflap by dragging it via the black halo handle."

	aButton := IconicButton new.
	aButton color: self color;
		initializeToShow: aMorph withLabel: aMorph externalName andSend: #veryDeepCopy to: aMorph veryDeepCopy.
	^ aButton! !

!PartsBin methodsFor: 'dropping/grabbing' stamp: 'sw 6/13/2001 17:47'!
wantsDroppedMorph: aMorph event: evt
	"Answer whether the receiver would like to accept the given morph.  For a Parts bin, we accept just about anything except something that just originated from ourselves"

	(aMorph hasProperty: #beFullyVisibleAfterDrop) ifTrue:
		["Sign that this was launched from a parts bun, probably indeed this very parts bin"
		^ false].

	^ super wantsDroppedMorph: aMorph event: evt! !


!PartsBin methodsFor: 'initialization' stamp: 'nk 9/1/2004 17:28'!
listDirection: aListDirection quadList: quadList
	"Initialize the receiver to run horizontally or vertically, obtaining its elements from the list of tuples of the form:
		(<receiver> <selector> <label> <balloonHelp>)"

	| aButton aClass |
	self layoutPolicy: TableLayout new.
	self listDirection: aListDirection.
	self wrapCentering: #topLeft.
	self layoutInset: 2.
	self cellPositioning: #bottomCenter.

	aListDirection == #leftToRight
		ifTrue:
			[self vResizing: #rigid.
			self hResizing: #spaceFill.
			self wrapDirection: #topToBottom]
		ifFalse:
			[self hResizing: #rigid.
			self vResizing: #spaceFill.
			self wrapDirection: #leftToRight].
	quadList do:
		[:tuple |
			aClass _ Smalltalk at: tuple first.
			aButton _ IconicButton new initializeWithThumbnail: (self class thumbnailForQuad: tuple color: self color) withLabel: tuple third andColor: self color andSend: tuple second to: aClass.
			(tuple size > 3 and: [tuple fourth isEmptyOrNil not]) ifTrue:
				[aButton setBalloonText: tuple fourth].
 			self addMorphBack: aButton]! !

!PartsBin methodsFor: 'initialization' stamp: 'nk 9/1/2004 20:09'!
listDirection: aListDirection quadList: quadList buttonClass: buttonClass
	"Initialize the receiver to run horizontally or vertically, obtaining its elements from the list of tuples of the form:
		(<receiver> <selector> <label> <balloonHelp>)"

	| aButton aClass |
	self layoutPolicy: TableLayout new.
	self listDirection: aListDirection.
	self wrapCentering: #topLeft.
	self layoutInset: 2.
	self cellPositioning: #bottomCenter.

	aListDirection == #leftToRight
		ifTrue:
			[self vResizing: #rigid.
			self hResizing: #spaceFill.
			self wrapDirection: #topToBottom]
		ifFalse:
			[self hResizing: #rigid.
			self vResizing: #spaceFill.
			self wrapDirection: #leftToRight].
	quadList do:
		[:tuple |
			aClass _ Smalltalk at: tuple first.
			aButton _ buttonClass new initializeWithThumbnail: (self class thumbnailForQuad: tuple color: self color) withLabel: tuple third andColor: self color andSend: tuple second to: aClass.
			(tuple size > 3 and: [tuple fourth isEmptyOrNil not]) ifTrue:
				[aButton setBalloonText: tuple fourth].
 			self addMorphBack: aButton]! !


!PartsBin methodsFor: 'properties' stamp: 'dgd 8/30/2003 15:52'!
innocuousName
	"Answer a harmless name for an unnamed instance"

	^ 'parts bin' translated! !


!PartsBin methodsFor: 'event handling' stamp: 'dgd 9/27/2004 13:56'!
wantsEasySelection
	"Answer if the receiver want easy selection mode"
	^ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PartsBin class
	instanceVariableNames: ''!

!PartsBin class methodsFor: 'class initialization' stamp: 'sw 7/12/2001 19:07'!
initialize
	"Initialize the PartsBin class, by starting it out with an empty Thumbnails dictionary"

	Thumbnails _ Dictionary new
	"PartsBin initialize"! !

!PartsBin class methodsFor: 'class initialization' stamp: 'tak 8/3/2005 18:32'!
localeChanged
	self initialize! !


!PartsBin class methodsFor: 'instance creation' stamp: 'nk 8/31/2004 18:51'!
newPartsBinWithOrientation: aListDirection andColor: aColor from: quadList 
	"Answer a new PartBin object, to run horizontally or vertically,  
	obtaining its elements from the list of tuples of the form:  
	(<receiver> <selector> <label> <balloonHelp>)"
	^ (self new)
		color: aColor;
		listDirection: aListDirection quadList: (self translatedQuads: quadList).! !

!PartsBin class methodsFor: 'instance creation' stamp: 'dgd 8/26/2004 12:24'!
newPartsBinWithOrientation: aListDirection from: quadList 
	"Answer a new PartBin object, to run horizontally or vertically,  
	obtaining its elements from the list of tuples of the form:  
	(<receiver> <selector> <label> <balloonHelp>)"
	^ self new
		listDirection: aListDirection
		quadList: (self translatedQuads: quadList) ! !


!PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 8/12/2001 17:44'!
cacheAllThumbnails
	"In one monster operation, cache all the thumbnails of parts.  Intended to be called from do-its in update postscripts, for example, or manually."

	Cursor wait showWhile:
		[Morph withAllSubclasses do: [:aClass |
			(aClass class includesSelector: #descriptionForPartsBin) ifTrue:
				[self thumbnailForPartsDescription: aClass descriptionForPartsBin].
			(aClass class includesSelector: #supplementaryPartsDescriptions) ifTrue:
				[aClass supplementaryPartsDescriptions do:
					[:aDescription | self thumbnailForPartsDescription: aDescription]]]]

"Time millisecondsToRun: [PartsBin initialize. PartsBin cacheAllThumbnails]"
! !

!PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 7/12/2001 19:06'!
cacheThumbnail: aThumbnail forSymbol: aSymbol
	"Cache the thumbnail provided as the graphic representing a parts-bin denizen whose name is the given symbol"

	Thumbnails at: aSymbol put: aThumbnail! !

!PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 7/12/2001 18:56'!
clearThumbnailCache
	"Clear the cache of thumbnails:
		PartsBin clearThumbnailCache
"

	Thumbnails _ Dictionary new! !

!PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 7/12/2001 19:06'!
thumbnailForInstanceOf: aMorphClass
	"Answer a thumbnail for a stand-alone instance of the given class, creating it if necessary.  If it is created afresh, it will also be cached at this time"

	| aThumbnail |
	^ Thumbnails at: aMorphClass name ifAbsent:
		[aThumbnail _ Thumbnail new makeThumbnailFromForm: aMorphClass newStandAlone imageForm.
		self cacheThumbnail: aThumbnail forSymbol: aMorphClass name.
		^ aThumbnail]

"PartsBin initialize"! !

!PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 10/24/2001 15:29'!
thumbnailForPartsDescription: aPartsDescription
	"Answer a thumbnail for the given parts description creating it if necessary.  If it is created afresh, it will also be cached at this time"

	| aThumbnail aSymbol |
	aSymbol _ aPartsDescription formalName asSymbol.
	^ Thumbnails at: aSymbol ifAbsent:
		[aThumbnail _ Thumbnail new makeThumbnailFromForm: aPartsDescription sampleImageForm.
		self cacheThumbnail: aThumbnail forSymbol: aSymbol.
		^ aThumbnail]

"PartsBin initialize"! !

!PartsBin class methodsFor: 'thumbnail cache' stamp: 'nk 9/1/2004 17:38'!
thumbnailForQuad: aQuint
	"Answer a thumbnail for a morph obtaining as per the quintuplet provided, creating the thumbnail if necessary.  If it is created afresh, it will also be cached at this time"
	^self thumbnailForQuad: aQuint color: Color transparent.! !

!PartsBin class methodsFor: 'thumbnail cache' stamp: 'nk 9/1/2004 17:44'!
thumbnailForQuad: aQuint color: aColor
	"Answer a thumbnail for a morph obtaining as per the quintuplet provided, creating the thumbnail if necessary.  If it is created afresh, it will also be cached at this time"

	| aThumbnail aSymbol formToThumbnail labeledItem |
	aSymbol _ aQuint third.
	Thumbnails at: aSymbol ifPresent: [ :thumb | ^thumb ].
	formToThumbnail _ aQuint at: 5 ifAbsent: [].
	formToThumbnail ifNil: [
		labeledItem := (Smalltalk at: aQuint first) perform: aQuint second.
		formToThumbnail := labeledItem imageForm: 32 backgroundColor: aColor forRectangle: labeledItem fullBounds.
		formToThumbnail replaceColor: aColor withColor: Color transparent.
	].

	aThumbnail _ Thumbnail new makeThumbnailFromForm: formToThumbnail.
	self cacheThumbnail: aThumbnail forSymbol: aSymbol.
	^ aThumbnail

"PartsBin initialize"! !


!PartsBin class methodsFor: 'private' stamp: 'dgd 8/26/2004 12:23'!
translatedQuads: quads
	"private - convert the given quads to a translated one"
	
	| translatedQuads |

	translatedQuads := quads collect: [:each |
		| element |
		element := each copy. 
		element at: 3 put: each third translated.
		element at: 4 put: each fourth translated.
		element.
	].

	^ translatedQuads
! !
SystemWindow subclass: #PartsWindow
	instanceVariableNames: 'book prevButton nextButton menuButton openForEditing'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-PartsBin'!
!PartsWindow commentStamp: '<historical>' prior: 0!
Disused.  Instances may persist in users' images, so this obsolete code is kept around for the time being.  Supplanted by the ObjectsTool.!


!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:51'!
adjustBookControls
	| inner |
	prevButton ifNil: [^ self].
	prevButton align: prevButton topLeft with: (inner _ self innerBounds) topLeft + (32 @ -1).
	nextButton align: nextButton topRight with: inner topRight - (18 @ 1).
	menuButton align: menuButton topLeft with: inner topRight + (-42 @ 5).! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'RAA 12/26/2000 14:31'!
book: aBook

	book _ aBook.
	self addMorph: aBook frame: (0@0 extent: 1@1).
	book beSticky.
	self extent: aBook extent + (0@self labelHeight).
	nextButton target: aBook.
	prevButton target: aBook! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/30/1998 17:30'!
closeEditing
	openForEditing _ false.
	self color: Color white.
	book pages do:
		[:aPage | aPage setPartsBinStatusTo: true]! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 12/11/2000 07:33'!
invokePartsWindowMenu
	"Put up a menu offering parts-bin controls"

	| aMenu sel |
	aMenu _ MVCMenuMorph new.
	aMenu defaultTarget: aMenu.
	openForEditing
		ifTrue:
			[aMenu add: 'resume being a parts bin' selector: #selectMVCItem: argument:	#toggleStatus]
		ifFalse:
			[aMenu add: 'open for editing' selector: #selectMVCItem: argument:#toggleStatus].
	aMenu add: 'sort pages'	selector: #selectMVCItem: argument: #sortPages.
	aMenu add: 'save as Custom Parts Bin' selector: #selectMVCItem: argument: #saveAsCustomPartsBin.
	sel _ aMenu invokeAt: self primaryHand position in: self world.
	sel ifNotNil: [self perform: sel].
! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/30/1998 17:30'!
openEditing
	openForEditing _ true.
	self color: Color green.
	book pages do:
		[:aPage | aPage setPartsBinStatusTo: false]! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 8/12/2001 17:16'!
saveAsCustomPartsBin
	self inform: 'this feature is obsolete, as, indeed, is this entire tool'! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/30/1998 17:12'!
sortPages
	book sortPages! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 11/7/1998 21:56'!
toggleStatus
	openForEditing _ openForEditing not.
	openForEditing
		ifTrue:
			[self openEditing.
			menuButton state: #off.
			menuButton setBalloonText: 'resume being a parts bin']
		ifFalse:
			[self closeEditing.
			menuButton state: #on.
			menuButton setBalloonText: 'open for editing']! !


!PartsWindow methodsFor: 'geometry' stamp: 'sw 10/8/1998 13:44'!
extent: newExtent
	super extent: (newExtent max: 100 @ 50).
	self adjustBookControls! !


!PartsWindow methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color white! !

!PartsWindow methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:46'!
initialize
	"initialize the state of the receiver"
	| aFont aForm |
	super initialize.
	""
	
	openForEditing _ false.
	aFont _ Preferences standardButtonFont.
	self addMorph: (prevButton _ SimpleButtonMorph new borderWidth: 0;
					 label: '<' font: aFont;
					 color: Color transparent;
					 setBalloonText: 'previous page';
					 actionSelector: #previousPage;
					 target: self;
					 extent: 16 @ 16).
	self addMorph: (nextButton _ SimpleButtonMorph new borderWidth: 0;
					 label: '>' font: aFont;
					 color: Color transparent;
					 setBalloonText: 'next page';
					 actionSelector: #nextPage;
					 target: self;
					 extent: 16 @ 16).
	menuButton _ ThreePhaseButtonMorph new onImage: (aForm _ ScriptingSystem formAtKey: 'OfferToUnlock');
				
				offImage: (ScriptingSystem formAtKey: 'OfferToLock');
				
				pressedImage: (ScriptingSystem formAtKey: 'OfferToLock');
				 extent: aForm extent;
				 state: #on.
	menuButton target: self;
		 actionSelector: #toggleStatus;
		 actWhen: #buttonUp.
	menuButton setBalloonText: 'open for editing'.
	self addMorph: menuButton.
	" 
	self addMorph: (menuButton _ SimpleButtonMorph new  
	borderWidth: 0;  
	label: '·' font: aFont; color: Color transparent;  
	actWhen: #buttonDown;  
	actionSelector: #invokePartsWindowMenu; target: self; extent:  
	16@16)."
	self adjustBookControls! !


!PartsWindow methodsFor: 'label' stamp: 'sw 9/29/1999 07:39'!
setLabelWidgetAllowance
	^ labelWidgetAllowance _ 115! !


!PartsWindow methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:56'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'parts window controls...' translated action: #invokePartsWindowMenu
! !


!PartsWindow methodsFor: 'resize/collapse' stamp: 'sw 6/5/2001 00:19'!
wantsExpandBox
	"Answer whether I'd like an expand box"

	^ false! !
Object subclass: #Password
	instanceVariableNames: 'cache sequence'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!Password commentStamp: '<historical>' prior: 0!
"Hold a password.  There are three ways to get the password.

If there is no password (sequence == nil), ask the user for it.

If the use supplied one during this session, return that.  It is cleared at shutDown.

If sequence is a number, get the server passwords off the disk.  File 'sqk.info' must be in the same folder 'Squeak.sources' file.  Decode the file.  Return the password indexed by sequence."!


!Password methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'!
cache: anObject
	cache _ anObject! !

!Password methodsFor: 'accessing' stamp: 'rbb 3/1/2005 11:06'!
passwordFor: serverDir
	"Returned the password from one of many sources.  OK if send in a nil arg."

	| sp msg |
	cache ifNotNil: [^ cache].
	sequence ifNotNil: [
		(sp := self serverPasswords) ifNotNil: [
			sequence <= sp size ifTrue: [^ sp at: sequence]]].
	msg := serverDir isRemoteDirectory
		ifTrue: [serverDir moniker]
		ifFalse: ['this directory'].
	(serverDir user = 'anonymous') & (serverDir typeWithDefault == #ftp) ifTrue: [
			^ cache := UIManager default request: 'Please let this anonymous ftp\server know your email address.\This is the polite thing to do.' withCRs
			initialAnswer: 'yourName@company.com'].

	^ cache := UIManager default requestPassword: 'Password for ', serverDir user, ' at ', msg, ':'.
		"Diff between empty string and abort?"! !

!Password methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:01'!
sequence
	^sequence! !

!Password methodsFor: 'accessing' stamp: 'tk 1/5/98 21:14'!
sequence: anNumber
	sequence _ anNumber! !


!Password methodsFor: 'as yet unclassified' stamp: 'tk 1/5/98 21:08'!
decode: string
	"Xor with secret number -- just so file won't have raw password in it"
	| kk rand |
	rand _ Random new seed: 234237.
	kk _ (ByteArray new: string size) collect: [:bb | (rand next * 255) asInteger].
	1 to: kk size do: [:ii |
		kk at: ii put: ((kk at: ii) bitXor: (string at: ii) asciiValue)].
	^ kk asString! !

!Password methodsFor: 'as yet unclassified' stamp: 'tk 10/15/2002 14:39'!
serverPasswords
	"Get the server passwords off the disk and decode them. The file 'sqk.info' must be in some folder that Squeak thinks is special (vm folder, or default directory).  (Note: This code works even if you are running with no system sources file.)"

	| sfile |
	(sfile _ FileDirectory lookInUsualPlaces: 'sqk.info') ifNil: [^ nil].
		"If not there, Caller will ask user for password"
		"If you don't have this file, and you really do want to release an update, 
		 contact Ted Kaehler."
	^ (self decode: (sfile contentsOfEntireFile)) findTokens: String cr
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Password class
	instanceVariableNames: ''!

!Password class methodsFor: 'as yet unclassified' stamp: 'tk 6/24/1999 11:36'!
shutDown
	"Forget all cached passwords, so they won't stay in the image"

	self allSubInstancesDo: [:each | each cache: nil].! !
BorderedMorph subclass: #PasteUpMorph
	instanceVariableNames: 'presenter model cursor padding backgroundMorph turtleTrailsForm turtlePen lastTurtlePositions isPartsBin autoLineLayout indicateCursor resizeToFit wantsMouseOverHalos worldState griddingOn'
	classVariableNames: 'DisableDeferredUpdates MinCycleLapse StillAlive'
	poolDictionaries: ''
	category: 'Morphic-Worlds'!
!PasteUpMorph commentStamp: '<historical>' prior: 0!
A morph whose submorphs comprise a paste-up of rectangular subparts which "show through".  Anything called a 'Playfield' is a PasteUpMorph.

Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided.

A World, the entire Smalltalk screen, is a PasteUpMorph.  A World responds true to isWorld.  Morph subclasses that have specialized menus (BookMorph) build them in the message addBookMenuItemsTo:hand:.  A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu.

presenter	A Presenter in charge of stopButton stepButton and goButton, 
			mouseOverHalosEnabled soundsEnabled fenceEnabled coloredTilesEnabled.
model		<not used>
cursor		??
padding		??
backgroundMorph		A Form that covers the background.
turtleTrailsForm			Moving submorphs may leave trails on this form.
turtlePen				Draws the trails.
lastTurtlePositions		A Dictionary of (aPlayer -> aPoint) so turtle trails can be drawn 
						only once each step cycle.  The point is the start of the current stroke.
isPartsBin		If true, every object dragged out is copied.
autoLineLayout		??
indicateCursor		??
resizeToFit		??
wantsMouseOverHalos		If true, simply moving the cursor over a submorph brings up its halo.
worldState		If I am also a World, keeps the hands, damageRecorder, stepList etc.
griddingOn		If true, submorphs are on a grid

!


!PasteUpMorph methodsFor: 'accessing' stamp: 'ar 6/30/2001 13:21'!
assureFlapWidth: requestedWidth
	| tab |
	self width: requestedWidth.
	tab _ self flapTab ifNil:[^self].
	tab flapShowing ifTrue:[tab hideFlap; showFlap].! !

!PasteUpMorph methodsFor: 'accessing' stamp: 'tk 7/17/2001 16:07'!
flapTab
	| ww |
	self isFlap ifFalse:[^nil].
	ww _ self world ifNil: [World].
	^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]! !

!PasteUpMorph methodsFor: 'accessing' stamp: 'tak 3/15/2005 17:31'!
modalWindow: aMorph 
	(self valueOfProperty: #modalWindow)
		ifNotNilDo: [:morph | morph doCancel].
	self setProperty: #modalWindow toValue: aMorph.
	aMorph
		ifNotNil: [self
				when: #aboutToLeaveWorld
				send: #removeModalWindow
				to: self]! !

!PasteUpMorph methodsFor: 'accessing' stamp: 'sw 4/1/98 21:18'!
modelOrNil
	"Return the model object for this world, or nil if it doesn't have one."

	^ model
! !

!PasteUpMorph methodsFor: 'accessing' stamp: 'di 6/8/1999 14:06'!
presenter
	"Normally only the world will have a presenter, but the architecture supports individual localized presenters as well"

	^ presenter ifNil:
		[self isWorldMorph
			ifTrue: [presenter _ Presenter new associatedMorph: self]
			ifFalse: [super presenter]]! !

!PasteUpMorph methodsFor: 'accessing' stamp: 'tak 3/15/2005 17:31'!
removeModalWindow
	self modalWindow: nil! !

!PasteUpMorph methodsFor: 'accessing' stamp: 'ar 4/25/2001 17:15'!
useRoundedCorners
	"Somewhat special cased because we do have to fill Display for this"
	super useRoundedCorners.
	self == World ifTrue:[Display bits primFill: 0]. "done so that we *don't* get a flash"! !


!PasteUpMorph methodsFor: 'alarms-scheduler' stamp: 'ar 9/11/2000 16:40'!
addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime
	"Add a new alarm with the given set of parameters"
	worldState addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime.! !

!PasteUpMorph methodsFor: 'alarms-scheduler' stamp: 'ar 9/11/2000 16:39'!
removeAlarm: aSelector for: aTarget
	"Remove the alarm with the given selector"
	worldState removeAlarm: aSelector for: aTarget! !


!PasteUpMorph methodsFor: 'caching' stamp: 'tak 3/15/2005 17:33'!
releaseCachedState
	super releaseCachedState.
	self removeModalWindow.
	presenter ifNotNil:[presenter flushPlayerListCache].
	self isWorldMorph ifTrue:[self cleanseStepList].! !


!PasteUpMorph methodsFor: 'change reporting' stamp: 'ar 1/5/2002 17:06'!
invalidRect: damageRect from: aMorph
        "Clip damage reports to my bounds, since drawing is clipped to my bounds."

        self == self outermostWorldMorph 
                ifTrue: [worldState recordDamagedRect: (damageRect intersect: self bounds)]
                ifFalse: [super invalidRect: damageRect from: aMorph]
! !


!PasteUpMorph methodsFor: 'classification' stamp: 'sw 1/29/98 21:50'!
isPlayfieldLike
	^ true! !

!PasteUpMorph methodsFor: 'classification' stamp: 'di 7/27/1999 10:46'!
isWorldMorph

	^ worldState notNil! !


!PasteUpMorph methodsFor: 'copying' stamp: 'tk 7/30/2001 09:26'!
veryDeepCopyWith: deepCopier
	"See storeDataOn:"

	^ self isWorldMorph
		ifTrue: [self]	"never copy the World"
		ifFalse: [super veryDeepCopyWith: deepCopier]! !


!PasteUpMorph methodsFor: 'cursor' stamp: 'tak 11/7/2004 18:33'!
cursorWrapped: aNumber 
	"Set the cursor to the given number, modulo the number of items I
	contain. Fractional cursor values are allowed."
	| oldRect newRect offset |
	cursor = aNumber
		ifTrue: [^ self].
	self hasSubmorphs
		ifFalse: [cursor := 1.
			^ self].
	oldRect := self selectedRect.
	offset := (self asNumber: aNumber) - 1 \\ submorphs size.
	cursor := offset + 1.
	newRect := self selectedRect.
	self indicateCursor
		ifTrue: [self invalidRect: oldRect;
				 invalidRect: newRect]! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 9/8/2000 16:41'!
numberAtCursor
	"Answer the number represented by the object at my current cursor position"

	| chosenMorph |
	submorphs isEmpty ifTrue: [^ 0].
	chosenMorph _ submorphs at: ((cursor truncated max: 1) min: submorphs size).
	^ chosenMorph getNumericValue
! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 5/12/1998 10:55'!
rectifyCursor
	cursor _ ((cursor truncated max: 1) min: submorphs size)
! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'jdl 3/28/2003 08:17'!
selectedRect
	"Return a rectangle enclosing the morph at the current cursor. Note that the cursor may be a float and may be out of range, so pick the nearest morph. Assume there is at least one submorph."

	| p |
	p := cursor asInteger.
	p := p min: submorphs size.
	p := p max: 1.
	^(submorphs at: p) fullBounds expandBy: 2! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'bf 9/30/2002 23:37'!
valueAtCursor
	"Answer the submorph of mine indexed by the value of my 'cursor' slot"

	submorphs isEmpty ifTrue: [^ self presenter standardPlayer costume].
	^ (submorphs at: ((cursor truncated max: 1) min: submorphs size)) morphRepresented! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 5/12/1998 10:55'!
valueAtCursor: aMorph
	submorphs isEmpty ifTrue: [^ self].
	self rectifyCursor.
	self replaceSubmorph: self valueAtCursor by: aMorph! !


!PasteUpMorph methodsFor: 'display' stamp: 'ar 9/7/2002 15:24'!
gradientFillColor: aColor
	"For backwards compatibility with GradientFillMorph"

	self flag: #fixThis.
	self useGradientFill.
	self fillStyle colorRamp: {0.0 -> self fillStyle colorRamp first value. 1.0 -> aColor}.
	self changed! !

!PasteUpMorph methodsFor: 'display' stamp: 'ar 10/5/2000 18:52'!
setGradientColor: evt
	"For backwards compatibility with GradientFillMorph"

	self flag: #fixThis.
	self changeColorTarget: self selector: #gradientFillColor:
		originalColor: (self fillStyle isGradientFill
			ifTrue: [self fillStyle colorRamp last value]
			ifFalse: [color])
		hand: evt hand.! !


!PasteUpMorph methodsFor: 'drawing' stamp: 'nk 7/4/2003 16:07'!
drawOn: aCanvas 
	"Draw in order:
	- background color
	- grid, if any
	- background sketch, if any
	- Update and draw the turtleTrails form. See the comment in updateTrailsForm.
	- cursor box if any

	Later (in drawSubmorphsOn:) I will skip drawing the background sketch."

	"draw background fill"
	super drawOn: aCanvas.

	"draw grid"
	(self griddingOn and: [self gridVisible]) 
		ifTrue: 
			[aCanvas fillRectangle: self bounds
				fillStyle: (self 
						gridFormOrigin: self gridOrigin
						grid: self gridModulus
						background: nil
						line: Color lightGray)].

	"draw background sketch."
	backgroundMorph ifNotNil: [
		self clipSubmorphs ifTrue: [
			aCanvas clipBy: self clippingBounds
				during: [ :canvas | canvas fullDrawMorph: backgroundMorph ]]
			ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]].

	"draw turtle trails"
	self updateTrailsForm.
	turtleTrailsForm 
		ifNotNil: [aCanvas paintImage: turtleTrailsForm at: self position].

	"draw cursor"
	(submorphs notEmpty and: [self indicateCursor]) 
		ifTrue: 
			[aCanvas 
				frameRectangle: self selectedRect
				width: 2
				color: Color black]! !


!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 9/10/2004 13:45'!
acceptDroppingMorph: dropped event: evt
	"The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied"

	| mm tfm aMorph |
	aMorph _ self morphToDropFrom: dropped.
	self isWorldMorph
		ifTrue:["Add the given morph to this world and start stepping it if it wants to be."
				self addMorphFront: aMorph.
				(aMorph fullBounds intersects: self viewBox) ifFalse:
					[Beeper beep.  aMorph position: self bounds center]]
		ifFalse:[super acceptDroppingMorph: aMorph event: evt].

	aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]].
	aMorph allMorphsDo:  "Establish any penDown morphs in new world"
		[:m | m player ifNotNil:
			[m player getPenDown ifTrue:
				[((mm _ m player costume) notNil and: [(tfm _ mm owner transformFrom: self) notNil])
					ifTrue: [self noteNewLocation: (tfm localPointToGlobal: mm referencePosition)
									forPlayer: m player]]]].

	self isPartsBin
		ifTrue:
			[aMorph isPartsDonor: true.
			aMorph stopSteppingSelfAndSubmorphs.
			aMorph suspendEventHandler]
		ifFalse:
			[self world startSteppingSubmorphsOf: aMorph].

	self presenter morph: aMorph droppedIntoPasteUpMorph: self.

	self showingListView ifTrue:
		[self sortSubmorphsBy: (self valueOfProperty: #sortOrder).
		self currentWorld abandonAllHalos].

	self bringTopmostsToFront.
! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 6/18/1998 09:10'!
automaticPhraseExpansion
	^ self hasProperty: #automaticPhraseExpansion! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/4/2001 00:54'!
dropEnabled
	"Get this morph's ability to add and remove morphs via drag-n-drop."

	^ (self valueOfProperty: #dropEnabled) ~~ false
! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 9/1/2000 05:37'!
justDroppedInto: aMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph"

	super justDroppedInto: aMorph event: anEvent.
	self isPartsBin ifTrue: [self setPartsBinStatusTo: true]  "gets some things right about the subtle case of dropping a parts bin"
! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'gm 2/22/2003 13:08'!
morphToDropFrom: aMorph 
	"Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited.  Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service."

	| aNail representee handy posBlock tempPos |
	handy := self primaryHand.
	posBlock := 
			[:z | 
			tempPos := handy position 
						- ((handy targetOffset - aMorph formerPosition) 
								* (z extent / aMorph extent)) rounded.
			self pointFromWorld: tempPos].
	self alwaysShowThumbnail 
		ifTrue: 
			[aNail := aMorph 
						representativeNoTallerThan: self maxHeightToAvoidThumbnailing
						norWiderThan: self maximumThumbnailWidth
						thumbnailHeight: self heightForThumbnails.
			aNail == aMorph 
				ifFalse: 
					[aMorph formerPosition: aMorph position.
					aNail position: (posBlock value: aNail)].
			^aNail].
	((aMorph isKindOf: MorphThumbnail) 
		and: [(representee := aMorph morphRepresented) owner isNil]) 
			ifTrue: 
				[representee position: (posBlock value: representee).
				^representee].
	self showingListView 
		ifTrue: 
			[^aMorph 
				listViewLineForFieldList: (self valueOfProperty: #fieldListSelectors)].
	(aMorph hasProperty: #newPermanentScript) 
		ifTrue: [^aMorph asEmptyPermanentScriptor].
	((aMorph isKindOf: PhraseTileMorph) or: [aMorph isSyntaxMorph]) 
		ifFalse: [^aMorph].
	aMorph userScriptSelector isEmptyOrNil 
		ifTrue: 
			["non-user"

			self automaticPhraseExpansion ifFalse: [^aMorph]].
	^aMorph morphToDropInPasteUp: self! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 7/6/1999 13:26'!
originAtCenter
	^ self hasProperty: #originAtCenter! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 5/2/1998 11:31'!
positionNear: aPoint forExtent: anExtent adjustmentSuggestion: adjustmentPoint
	"Compute a plausible positioning for adding a subpart of size anExtent, somewhere near aPoint, using adjustmentPoint as the unit of adjustment"

	| adjustedPosition |
	adjustedPosition _ aPoint.
	[((self morphsAt: (adjustedPosition + (anExtent // 2))) size > 1) and:  "that 1 is self here"
		[bounds containsPoint: adjustedPosition]]
	whileTrue:
		[adjustedPosition _ adjustedPosition + adjustmentPoint].

	^ adjustedPosition! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:22'!
repelsMorph: aMorph event: ev
	(aMorph wantsToBeDroppedInto: self) ifFalse: [^ false].
	self dropEnabled ifFalse: [^ true].
	(self wantsDroppedMorph: aMorph event: ev) ifFalse: [^ true].
	^ super repelsMorph: aMorph event: ev "consults #repelling flag"! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:22'!
wantsDroppedMorph: aMorph event: evt
	self isWorldMorph ifTrue:[^true]. "always"
	self visible ifFalse: [^ false].  "will be a call to #hidden again very soon"
	self dropEnabled ifFalse: [^ false].
	^ true! !


!PasteUpMorph methodsFor: 'event handling' stamp: 'mir 1/10/2002 17:35'!
dropFiles: anEvent
	"Handle a number of dropped files from the OS.
	TODO:
		- use a more general mechanism for figuring out what to do with the file (perhaps even offering a choice from a menu)
		- remember the resource location or (when in browser) even the actual file handle
	"
	| numFiles stream handler |
	numFiles _ anEvent contents.
	1 to: numFiles do: [:i |
		stream _ FileStream requestDropStream: i.
		handler _ ExternalDropHandler lookupExternalDropHandler: stream.
		[handler ifNotNil: [handler handle: stream in: self dropEvent: anEvent]]
			ensure: [stream close]].! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 18:44'!
handlesKeyboard: evt
	^self isWorldMorph or:[evt keyCharacter == Character tab and:[self tabAmongFields]]! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/3/2000 22:46'!
handlesMouseDown: evt
	^true! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 4/4/2006 14:42'!
keyStroke: anEvent
	"A keystroke has been made.  Service event handlers and, if it's a keystroke presented to the world, dispatch it to #unfocusedKeystroke:"

	| selected |
	super keyStroke: anEvent.  "Give event handlers a chance"

	selected := self selectedObject.
	selected isNil
		ifFalse:[ selected moveOrResizeFromKeystroke: anEvent ].

	(anEvent keyCharacter == Character tab) ifTrue:
		[self tabAmongFields
			ifTrue:[^ self tabHitWithEvent: anEvent]].
	self isWorldMorph ifTrue:
		[self keystrokeInWorld: anEvent]! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 2/23/2001 16:44'!
morphToGrab: event
	"Return the morph to grab from a mouse down event. If none, return nil."
	self submorphsDo:[:m|
		((m rejectsEvent: event) not and:[m fullContainsPoint: event cursorPoint]) ifTrue:[^m].
	].
	^nil! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 9/27/2004 13:56'!
mouseDown: evt
	"Handle a mouse down event."
	| grabbedMorph handHadHalos |

	(Preferences generalizedYellowButtonMenu
			and: [evt yellowButtonPressed])
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed].

	grabbedMorph _ self morphToGrab: evt.
	grabbedMorph ifNotNil:[
		grabbedMorph isSticky ifTrue:[^self].
		self isPartsBin ifFalse:[^evt hand grabMorph: grabbedMorph].
		grabbedMorph _ grabbedMorph partRepresented duplicate.
		grabbedMorph restoreSuspendedEventHandler.
		(grabbedMorph fullBounds containsPoint: evt position) 
			ifFalse:[grabbedMorph position: evt position].
		"Note: grabbedMorph is ownerless after duplicate so use #grabMorph:from: instead"
		^ evt hand grabMorph: grabbedMorph from: self].

	(super handlesMouseDown: evt)
		ifTrue:[^super mouseDown: evt].

	handHadHalos _ evt hand halo notNil.

	evt hand removeHalo. "shake off halos"
	evt hand releaseKeyboardFocus. "shake of keyboard foci"

	self submorphs
		select:[:each | each hasProperty: #morphHierarchy]
		thenDo:[:each | each delete].

	Preferences noviceMode
		ifTrue:[
			self submorphs
				select:[:each | (each isKindOf: MenuMorph) and:[each stayUp not]]
				thenDo:[:each | each delete].
		].

	(evt shiftPressed not
			and:[ self isWorldMorph not ]
			and:[ self wantsEasySelection not ])
	ifTrue:[
		"explicitly ignore the event if we're not the world and we'll not select,
		so that we could be picked up if need be"
		evt wasHandled: false.
		^ self.
	].

	( evt shiftPressed or: [ self wantsEasySelection ] ) ifTrue:[
		"We'll select on drag, let's decide what to do on click"
		| clickSelector |

		clickSelector := nil.

		evt shiftPressed ifTrue:[
			clickSelector := #findWindow:.
		]
		ifFalse:[
			self isWorldMorph ifTrue:[
				clickSelector := handHadHalos
										ifTrue: [ #delayedInvokeWorldMenu: ]
										ifFalse: [ #invokeWorldMenu: ]
			]
		].

		evt hand 
				waitForClicksOrDrag: self 
				event: evt 
				selectors: { clickSelector. nil. nil. #dragThroughOnDesktop: }
				threshold: 5.
	]
	ifFalse:[
		"We wont select, just bring world menu if I'm the world"
		self isWorldMorph ifTrue:[
			handHadHalos
				ifTrue: [ self delayedInvokeWorldMenu: evt ]
				ifFalse: [ self invokeWorldMenu: evt ]
		]
	].
! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 00:04'!
mouseUp: evt
	self isWorldMorph ifTrue:[self removeAlarm: #invokeWorldMenu:].
	super mouseUp: evt.! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:29'!
wantsDropFiles: anEvent
	^self isWorldMorph! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 9/27/2004 13:55'!
wantsEasySelection
	"Answer if the receiver want easy selection mode"
	^ Preferences easySelection! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 17:07'!
wantsKeyboardFocusFor: aSubmorph
	aSubmorph inPartsBin ifTrue: [^ false].
	aSubmorph wouldAcceptKeyboardFocus ifTrue: [ ^ true].
	^ super wantsKeyboardFocusFor: aSubmorph! !


!PasteUpMorph methodsFor: 'events-processing' stamp: 'ar 4/5/2001 21:42'!
processEvent: anEvent using: defaultDispatcher
	"Reimplemented to install the receiver as the new ActiveWorld if it is one"
	| priorWorld result |
	self isWorldMorph ifFalse:[^super processEvent: anEvent using: defaultDispatcher].
	priorWorld _ ActiveWorld.
	ActiveWorld _ self.
	result _ super processEvent: anEvent using: defaultDispatcher.
	ActiveWorld _ priorWorld.
	^result! !


!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/15/1999 20:37'!
accommodateFlap: aFlapTab
	"Shift submorphs over, if appropriate"
	| offset |
	aFlapTab slidesOtherObjects ifTrue:
		[offset _ self offsetForAccommodating: aFlapTab referent extent onEdge: aFlapTab edgeToAdhereTo.
		self shiftSubmorphsBy: offset]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'dao 10/1/2004 12:56'!
addGlobalFlaps 
	"Must make global flaps adapt to world.  Do this even if not shown, so the old world will not be pointed at by the flaps."

	| use thisWorld |
	use _ Flaps sharedFlapsAllowed.
	Project current flapsSuppressed ifTrue: [use _ false].
	"Smalltalk isMorphic ifFalse: [use _ false]."
	thisWorld _ use 
		ifTrue: [self]
		ifFalse: [PasteUpMorph new initForProject:  "fake to be flap owner"
						WorldState new;
					bounds: (0@0 extent: 4000@4000);
					viewBox: (0@0 extent: 4000@4000)].
	
	Flaps globalFlapTabsIfAny do: [:aFlapTab |
		(Project current isFlapEnabled: aFlapTab) ifTrue:
			[(aFlapTab world == thisWorld) ifFalse:
				[thisWorld addMorphFront: aFlapTab.
				aFlapTab adaptToWorld: thisWorld].	"always do"
			use ifTrue:
				[aFlapTab spanWorld.
				aFlapTab adjustPositionAfterHidingFlap.
				aFlapTab flapShowing ifTrue: [aFlapTab showFlap]]]]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 6/17/1999 16:02'!
assureFlapTabsFitOnScreen
	self flapTabs do:
		[:m | m fitOnScreen]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'dgd 4/4/2006 13:58'!
bringTopmostsToFront
	submorphs
		select:[:m| m wantsToBeTopmost]
		thenDo:[:m| self addMorphInLayer: m].! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 7/28/1999 15:42'!
correspondingFlapTab
	"If there is a flap tab whose referent is me, return it, else return nil"
	self currentWorld flapTabs do:
		[:aTab | aTab referent == self ifTrue: [^ aTab]].
	^ nil! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 5/5/2001 00:27'!
deleteGlobalFlapArtifacts
	"Delete all flap-related detritus from the world"

	| localFlaps |
	localFlaps _ self localFlapTabs collect: [:m | m referent].
	self submorphs do:
		[:m | 
			((m isFlapTab) and: [m isGlobalFlap]) ifTrue: [m delete].
			m isFlap ifTrue:[(localFlaps includes: m) ifFalse: [m delete]]]

"ActiveWorld deleteGlobalFlapArtifacts"

! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 4/17/2001 11:23'!
enableGlobalFlaps 
	"Restore saved global flaps, or obtain brand-new system defaults if necessary"

	Flaps globalFlapTabs. 		 "If nil, creates new ones"
	self addGlobalFlaps 			 "put them on screen"! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'ar 9/28/2000 13:56'!
flapTabs
	^ self submorphs select:[:m| m isFlapTab]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 4/17/2001 11:22'!
localFlapTabs
	"Answer a list of local flap tabs in the current project"

	| globalList aList aFlapTab |
	globalList _ Flaps globalFlapTabsIfAny.
	aList _ OrderedCollection new.
	submorphs do:
		[:m | ((m isFlapTab) and: [(globalList includes: m) not])
			ifTrue:
				[aList add: m]
			ifFalse:
				[((m isFlap) and:
					[(aFlapTab _ m submorphs detect: [:n | n isFlapTab] ifNone: [nil]) notNil])
						ifTrue:
							[aList add: aFlapTab]]].
	^ aList! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/11/1999 10:53'!
offsetForAccommodating: anExtent onEdge: edgeSymbol
	"Answer a delta to be applied to my submorphs in order tfor anExtent to be slid inboard on the indicated edge"
	edgeSymbol == #left ifTrue: [^ anExtent x @ 0].
	edgeSymbol == #right ifTrue: [^ anExtent x negated @ 0].
	edgeSymbol == #top ifTrue: [^ 0 @ anExtent y].
	edgeSymbol == #bottom ifTrue: [^ 0 @ anExtent y negated].! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 6/25/1999 21:35'!
paintingFlapTab
	"If the receiver has a flap which has a paintbox, return it, else return nil"
	self flapTabs do:
		[:aTab | aTab referent submorphsDo:
			[:aMorph | (aMorph isKindOf: PaintBoxMorph) ifTrue: [^ aTab]]].
	^ nil! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'RAA 1/9/2001 06:59'!
releaseViewers
	"In preparation for saving, make the flapTabs release their viewers."

	self flapTabs do: [:ft | 
		(ft respondsTo: #hibernate) ifTrue: [ft hibernate]]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/15/1999 20:36'!
removeAccommodationForFlap: aFlapTab
	"Shift submorphs over, if appropriate"
	| offset |
	aFlapTab slidesOtherObjects ifTrue:
		[offset _ self offsetForAccommodating: aFlapTab referent extent onEdge: aFlapTab edgeToAdhereTo.
		self shiftSubmorphsBy: offset negated]! !


!PasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/20/2000 12:42'!
extent: aPoint

	super extent: aPoint.
	worldState ifNotNil: [
		worldState viewBox ifNotNil: [
			worldState canvas: nil.
			worldState viewBox: bounds
		].
	].! !

!PasteUpMorph methodsFor: 'geometry' stamp: 'di 8/28/2000 23:13'!
gridPoint: ungriddedPoint

	self griddingOn ifFalse: [^ ungriddedPoint].
	^ (ungriddedPoint - self position - self gridOrigin grid: self gridModulus)
					+ self position + self gridOrigin! !

!PasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/1/2000 10:28'!
position: aPoint
	"Prevent moving a world (e.g. via HandMorph>>specialGesture:)"

	"for now, let's allow it and see what happens"

	self isWorldMorph ifFalse: [^super position: aPoint].
	super position: aPoint.
	self viewBox ifNotNil: [self viewBox: (aPoint extent: self viewBox extent)].

! !


!PasteUpMorph methodsFor: 'geometry testing' stamp: 'RAA 6/2/2000 10:22'!
fullContainsPoint: pt
	"The world clips its children"

	worldState ifNil: [^super fullContainsPoint: pt].
	^bounds containsPoint: pt

! !


!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:15'!
griddingOn

	^ griddingOn ifNil: [false]! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:48'!
griddingOnOff

	griddingOn _ self griddingOn not.
	self changed! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'dgd 12/13/2003 19:30'!
griddingString
	"Answer a string to use in a menu offering the user the 
	opportunity to start or stop using gridding"
	^ (self griddingOn
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'use gridding' translated! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'!
gridModulus

	^ self gridSpec extent! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'!
gridModulus: newModulus

	self gridSpecPut: (self gridOrigin extent: newModulus).
	self changed! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'!
gridOrigin

	^ self gridSpec origin! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'!
gridOrigin: newOrigin

	^ self gridSpecPut: (newOrigin extent: self gridModulus)! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:26'!
gridSpec
	"Gridding rectangle provides origin and modulus"

	^ self valueOfProperty: #gridSpec ifAbsent: [0@0 extent: 8@8]! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'!
gridSpecPut: newSpec
	"Gridding rectangle provides origin and modulus"

	^ self setProperty: #gridSpec toValue: newSpec! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:11'!
gridVisible

	^ self hasProperty: #gridVisible! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'!
gridVisibleOnOff

	self setProperty: #gridVisible toValue: self gridVisible not.
	self changed! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'dgd 12/13/2003 19:30'!
gridVisibleString
	"Answer a string to be used in a menu offering the opportunity 
	to show or hide the grid"
	^ (self gridVisible
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'show grid when gridding' translated! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'kfr 9/4/2004 15:44'!
setGridSpec
	"Gridding rectangle provides origin and modulus"
	| response result |
	response _ FillInTheBlank
			request: 'New grid origin (usually 0@0):' translated
			initialAnswer: self gridOrigin printString.
	response isEmpty ifTrue: [^ self].
	result _ [Compiler evaluate: response] ifError: [^ self].
	(result isPoint and: [(result >= (0@0))])
		ifTrue: [self gridOrigin: result]
		ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )].

	response _ FillInTheBlank
			request: 'New grid spacing:' translated
			initialAnswer: self gridModulus printString.
	response isEmpty ifTrue: [^ self].
	result _ [Compiler evaluate: response] ifError: [^ self].
	(result isPoint and: [(result > (0@0)) ])
		ifTrue: [self gridModulus: result]
		ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )].

! !


!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'sw 1/10/2000 16:44'!
defersHaloOnClickTo: aSubMorph
	"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
	^ true
	! !

!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'di 9/26/2000 21:39'!
wantsDirectionHandles

	^ super wantsDirectionHandles and: [self isWorldMorph not]! !

!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'ar 10/11/2000 18:22'!
wantsHaloFor: aSubMorph
	"Answer whether the receiver wishes for a mouse-over halo to be produced for aSubMorph"

	^ wantsMouseOverHalos == true and:
		 [self visible and:
			[isPartsBin ~~ true and:
				[self dropEnabled and:
					[self isWorldMorph not or: [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]]

	"The odd logic at the end of the above says...

		*  If we're an interior playfield, then if we're set up for mouseover halos, show em.
		*  If we're a World that's set up for mouseover halos, only show 'em if the putative
				recipient is a SketchMorph.

	This (old) logic was put in to suit a particular need in early e-toy days and seems rather strange now!!"! !

!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'yo 2/17/2005 14:45'!
wantsHaloFromClick
	(owner isSystemWindow) ifTrue: [^ false].
	self paintBoxOrNil ifNotNil: [^ false].
	^ true.
! !


!PasteUpMorph methodsFor: 'initialization' stamp: 'mir 10/29/2003 13:05'!
becomeActiveDuring: aBlock
	"Make the receiver the ActiveWorld during the evaluation of aBlock.
	Note that this method does deliberately *not* use #ensure: to prevent
	re-installation of the world on project switches."
	| priorWorld priorHand priorEvent |
	priorWorld _ ActiveWorld.
	priorHand _ ActiveHand.
	priorEvent _ ActiveEvent.
	ActiveWorld _ self.
	ActiveHand _ self hands first. "default"
	ActiveEvent _ nil. "not in event cycle"
	[aBlock value]
		on: Error
		do: [:ex | 
			ActiveWorld _ priorWorld.
			ActiveEvent _ priorEvent.
			ActiveHand _ priorHand.
			ex pass]! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color
		r: 0.861
		g: 1.0
		b: 0.722! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.8
		g: 1.0
		b: 0.6! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:31'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	cursor _ 1.
	padding _ 3.
	self enableDragNDrop.
	self isWorldMorph
		ifTrue: [self setProperty: #automaticPhraseExpansion toValue: true].
	self clipSubmorphs: true! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:30'!
newResourceLoaded
	"Some resource has just been loaded. Notify all morphs in case somebody wants to update accordingly."
	self allMorphsDo:[:m| m resourceJustLoaded ].
	self fullRepaintNeeded.! !


!PasteUpMorph methodsFor: 'interaction loop' stamp: 'ls 5/6/2003 16:51'!
doOneCycleNow
	"see the comment in doOneCycleNowFor:"
	worldState doOneCycleNowFor: self.
! !


!PasteUpMorph methodsFor: 'layout' stamp: 'sw 3/24/1999 14:11'!
addCenteredAtBottom: aMorph offset: anOffset
	"Add aMorph beneath all other morphs currently in the receiver, centered horizontally, with the vertical offset from the bottom of the previous morph given by anOffset"
	| curBot |
	curBot _ 0.
	submorphs do: [:m | curBot _ curBot max: m bottom].
	self addMorphBack: aMorph.
	aMorph position: ((self center x - (aMorph width // 2)) @ (curBot + anOffset))! !

!PasteUpMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:47'!
convertAlignment
	self clipSubmorphs: true.
	(autoLineLayout == true) ifTrue:[
		self layoutPolicy: TableLayout new.
		self layoutInset: 8; cellInset: 4.
		self listDirection: #leftToRight; wrapDirection: #topToBottom.
		self minHeight: self height.
	] ifFalse:[
		self layoutPolicy: nil.
		self layoutInset: 0; cellInset: 0.
	].
	(resizeToFit == true) ifTrue:[
		self vResizing: #shrinkWrap.
	] ifFalse:[
		self vResizing: #rigid.
	].! !

!PasteUpMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 13:43'!
layoutChanged
	"The receiver's layout changed; inform above and below"
	super layoutChanged.
	(self valueOfProperty: #SqueakPage) ifNotNil: [
		self setProperty: #pageDirty toValue: true].
		"I am the morph of a SqueakPage, I have changed and 
		need to be written out again"
! !

!PasteUpMorph methodsFor: 'layout' stamp: 'sw 8/3/1998 13:43'!
laySubpartsOutInOneRow
	| aPosition |
	aPosition _ 0 @ padding.
	submorphs do:
	[:aMorph |
		aMorph position: (aPosition + (padding @ 0)).
		aPosition _ aMorph topRight]! !


!PasteUpMorph methodsFor: 'macpal' stamp: 'sw 6/4/2001 19:38'!
currentVocabulary
	"Answer the default Vocabulary object to be applied when scripting"

	| aSym aVocab |
	aSym _ self valueOfProperty: #currentVocabularySymbol.
	aSym ifNil:
		[aVocab _ self valueOfProperty: #currentVocabulary.
		aVocab ifNotNil:
			[aSym _ aVocab vocabularyName.
			self setProperty: #currentVocabularySymbol toValue: aSym.
			self removeProperty: #currentVocabulary]].
	^ aSym
		ifNotNil:
			[Vocabulary vocabularyNamed: aSym]
		ifNil:
			[Vocabulary fullVocabulary]! !


!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 4/3/2006 14:38'!
addCustomMenuItems: menu hand: aHandMorph 
	"Add morph-specific menu itemns to the menu for the hand"
	super addCustomMenuItems: menu hand: aHandMorph.

	menu addLine.
	Preferences noviceMode
		ifFalse: [
			self addStackMenuItems: menu hand: aHandMorph.
			self addPenMenuItems: menu hand: aHandMorph.
			self addPlayfieldMenuItems: menu hand: aHandMorph].

	self isWorldMorph
		ifTrue: [
			menu addLine.
			Preferences noviceMode
				ifFalse: [(owner isKindOf: BOBTransformationMorph)
						ifTrue: [self addScalingMenuItems: menu hand: aHandMorph]].
			menu addUpdating: #showWorldMainDockingBarString action: #toggleShowWorldMainDockingBar.

			Flaps sharedFlapsAllowed ifTrue: [
				menu
					addUpdating: #suppressFlapsString
					target: Project current
					action: #toggleFlapsSuppressed.
			].

			Project current showWorldMainDockingBar ifFalse:[
				menu addLine.
				TheWorldMainDockingBar instance fillMenuItemsBar: menu.
			].

			Preferences noviceMode ifFalse: [| twm |
				menu addLine.

				twm := TheWorldMenu new.
				twm world: self project: Project current hand: aHandMorph.

				menu add: 'old desktop menu... (W)' translated subMenu: twm buildWorldMenu.
			].
		].
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 01:14'!
addPenMenuItems: menu hand: aHandMorph
	"Add a pen-trails-within submenu to the given menu"

	menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 01:15'!
addPenTrailsMenuItemsTo: aMenu
	"Add items relating to pen trails to aMenu"

	| oldTarget |
	oldTarget _ aMenu defaultTarget.
	aMenu defaultTarget: self.
	aMenu add: 'clear pen trails' translated action: #clearTurtleTrails.
	aMenu addLine.
	aMenu add: 'all pens up' translated action: #liftAllPens.
	aMenu add: 'all pens down' translated action: #lowerAllPens.
	aMenu addLine.
	aMenu add: 'all pens show lines' translated action: #linesForAllPens.
	aMenu add: 'all pens show arrowheads' translated action: #arrowsForAllPens.
	aMenu add: 'all pens show arrows' translated action: #linesAndArrowsForAllPens.
	aMenu add: 'all pens show dots' translated action: #dotsForAllPens.
	aMenu defaultTarget: oldTarget! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 17:52'!
addPlayfieldMenuItems: menu hand: aHandMorph
	"Add playfield-related items to the menu"

	menu add: 'playfield options...' translated target: self action: #presentPlayfieldMenu.
	(self hasProperty: #donorTextMorph) ifTrue:
		[menu add: 'send contents back to donor' translated action: #sendTextContentsBackToDonor]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 8/30/2003 21:18'!
addScalingMenuItems: menu hand: aHandMorph

	| subMenu |

	(subMenu _ MenuMorph new)
		defaultTarget: self;
		add: 'show application view' translated action: #showApplicationView;
		add: 'show factory view' translated action: #showFactoryView;
		add: 'show whole world view' translated action: #showFullView;
		add: 'expand' translated action: #showExpandedView;
		add: 'reduce' translated action: #showReducedView;
		addLine;
		add: 'define application view' translated action: #defineApplicationView;
		add: 'define factory view' translated action: #defineFactoryView.
	menu
		add: 'world scale and clip...' translated
		subMenu: subMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 10/23/2000 14:41'!
addStackMenuItems: menu hand: aHandMorph
	"Add appropriate stack-related items to the given menu"

	self isStackBackground
		ifTrue:
			[menu add: 'card & stack...' target: self action: #presentCardAndStackMenu]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'nk 2/15/2004 08:19'!
addWorldHaloMenuItemsTo: aMenu hand: aHandMorph
	"Add standard halo items to the menu, given that the receiver is a World"

	| unlockables |
	self addFillStyleMenuItems: aMenu hand: aHandMorph.
	self addLayoutMenuItems: aMenu hand: aHandMorph.

	aMenu addLine.
	self addWorldToggleItemsToHaloMenu: aMenu.
	aMenu addLine.
	self addCopyItemsTo: aMenu.
	self addPlayerItemsTo: aMenu.
	self addExportMenuItems: aMenu hand: aHandMorph.
	self addStackItemsTo: aMenu.
	self addMiscExtrasTo: aMenu.

	Preferences noviceMode ifFalse:
		[self addDebuggingItemsTo: aMenu hand: aHandMorph].

	aMenu addLine.
	aMenu defaultTarget: self.

	aMenu addLine.

	unlockables _ self submorphs select:
		[:m | m isLocked].
	unlockables size == 1 ifTrue:
		[aMenu add: ('unlock "{1}"' translated format:{unlockables first externalName})action: #unlockContents].
	unlockables size > 1 ifTrue:
		[aMenu add: 'unlock all contents' translated action: #unlockContents.
		aMenu add: 'unlock...' translated action: #unlockOneSubpart].

	aMenu defaultTarget: aHandMorph.
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 4/20/2002 01:38'!
addWorldToggleItemsToHaloMenu: aMenu
	"Add toggle items for the world to the halo menu"

	#(
	(hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me')
	(roundedCornersString toggleCornerRounding 'whether the world should have rounded corners')) do:

		[:trip | aMenu addUpdating: trip first action: trip second.
			aMenu balloonTextForLastItem: trip third]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:59'!
autoExpansionString
	"Answer the string to be shown in a menu to represent the  
	auto-phrase-expansion status"
	^ ((self hasProperty: #automaticPhraseExpansion)
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'auto-phrase-expansion' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:54'!
autoLineLayoutString
	"Answer the string to be shown in a menu to represent the  
	auto-line-layout status"
	^ (self autoLineLayout
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'auto-line-layout' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:02'!
autoViewingString
	"Answer the string to be shown in a menu to represent the  
	automatic-viewing status"
	^ (self automaticViewing
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'automatic viewing' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:01'!
batchPenTrailsString
	"Answer the string to be shown in a menu to represent the 
	batch-pen-trails enabled status"
	^ (self batchPenTrails
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'batch pen trails' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 8/30/2003 20:42'!
buildDebugMenu: aHandMorph
	| aMenu |
	aMenu _ super buildDebugMenu: aHandMorph.
	aMenu add:  'abandon costume history' translated target: self action: #abandonCostumeHistory.
	^ aMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 7/9/2005 18:19'!
currentlyUsingVectorVocabulary
	"Answer whether this world is currently set up to use the vector vocabulary"

	^ (self valueOfProperty: #currentVocabularySymbol) == #Vector! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:31'!
defineApplicationView

	| r |
	r _ Rectangle fromUser.
	self 
		setProperty: #applicationViewBounds 
		toValue: ((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated ! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:29'!
defineFactoryView

	| r |
	r _ Rectangle fromUser.
	self 
		setProperty: #factoryViewBounds 
		toValue: ((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated ! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'ar 10/3/2000 17:02'!
deleteBalloonTarget: aMorph
	"Delete the balloon help targeting the given morph"
	self handsDo:[:h| h deleteBalloonTarget: aMorph].! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:01'!
fenceEnabledString
	"Answer the string to be shown in a menu to represent the  
	fence enabled status"
	^ (self fenceEnabled
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'fence enabled' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:56'!
indicateCursorString
	"Answer the string to be shown in a menu to represent the  
	whether-to-indicate-cursor status"
	^ (self indicateCursor
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'indicate cursor' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:58'!
isOpenForDragNDropString
	"Answer the string to be shown in a menu to represent the  
	open-to-drag-n-drop status"
	^ (self dragNDropEnabled
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'open to drag & drop' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:57'!
isPartsBinString
	"Answer the string to be shown in a menu to represent the 
	parts-bin status"
	^ (self isPartsBin
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'parts bin' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 7/10/2005 02:53'!
makeVectorUseConformToPreference
	"Make certain that the use of vectors in this project conforms to the current preference setting."

	| prefValue currentValue |
	prefValue _ Preferences useVectorVocabulary.
	currentValue _ self currentlyUsingVectorVocabulary.
	prefValue ~~ currentValue ifTrue:
		[currentValue
			ifTrue:
				[self abandonVocabularyPreference]
			ifFalse:
				[self installVectorVocabulary]]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:58'!
mouseOverHalosString
	"Answer the string to be shown in a menu to represent the  
	mouse-over-halos status"
	^ (self wantsMouseOverHalos
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'mouse-over halos' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:00'!
originAtCenterString
	"Answer the string to be shown in a menu to represent the 
	origin-at-center status"
	^ ((self hasProperty: #originAtCenter)
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'origin-at-center' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'tak 3/17/2005 18:27'!
playfieldOptionsMenu
	"Answer an auxiliary menu with options specific to playfields -- too many to be housed in the main menu"

	| aMenu isWorld |
	isWorld _ self isWorldMorph.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	aMenu add: 'save on file...' translated action: #saveOnFile.
	Preferences eToyFriendly ifFalse: [
		aMenu add: 'save as SqueakPage at url...' translated action: #saveOnURL.
		aMenu add: 'update all from resources' translated action: #updateAllFromResources].

	aMenu add: 'round up strays' translated action: #roundUpStrays.
	aMenu balloonTextForLastItem:  'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.' translated.
	aMenu add: 'show all players' translated action: #showAllPlayers.
	aMenu balloonTextForLastItem:  'Make visible the viewers for all players which have user-written scripts in this playfield.' translated.
	aMenu add: 'hide all players' translated action: #hideAllPlayers.
	aMenu balloonTextForLastItem:  'Make invisible the viewers for all players in this playfield. This will save space before you publish this project' translated.


	aMenu addLine.
	aMenu add: 'shuffle contents' translated action: #shuffleSubmorphs.
	aMenu balloonTextForLastItem: 'Rearranges my contents in random order' translated.
	self griddingOn
		ifTrue: [aMenu add: 'turn gridding off' translated action: #griddingOnOff.
				aMenu add: (self gridVisible ifTrue: ['hide'] ifFalse: ['show']) translated, ' grid' translated
						action: #gridVisibleOnOff.
				aMenu add: 'set grid spacing...' translated action: #setGridSpec]
		ifFalse: [aMenu add: 'turn gridding on' translated action: #griddingOnOff].
	aMenu addLine.

	#(	(autoLineLayoutString	toggleAutoLineLayout
			'whether submorphs should automatically be laid out in lines')
		(indicateCursorString	toggleIndicateCursor
			'whether the "current" submorph should be indicated with a dark black border')
		(isPartsBinString		toggleIsPartsBin
			'whether dragging an object from the interior should produce a COPY of the object')
		(isOpenForDragNDropString	toggleDragNDrop
			'whether objects can be dropped into and dragged out of me')
		(mouseOverHalosString	toggleMouseOverHalos
			'whether objects should put up halos when the mouse is over them')
		(autoExpansionString	toggleAutomaticPhraseExpansion
			'whether tile phrases, dropped on me, should automatically sprout Scriptors around them')
		(originAtCenterString	toggleOriginAtCenter
			'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield')
		(showThumbnailString	toggleAlwaysShowThumbnail
			'whether large objects should be represented by thumbnail miniatures of themselves')
		(fenceEnabledString	toggleFenceEnabled
			'whether moving objects should stop at the edge of their container')
		(batchPenTrailsString	toggleBatchPenTrails 
			'if true, detailed movement of pens between display updates is ignored.  Thus multiple line segments drawn within a script may not be seen individually.')

	) do:

			[:triplet |
				(isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail) includes: triplet second]) ifFalse:
					[aMenu addUpdating: triplet first action: triplet second.
					aMenu balloonTextForLastItem: triplet third translated]]. 

	aMenu addUpdating: #autoViewingString action: #toggleAutomaticViewing.
	aMenu balloonTextForLastItem:  'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.' translated.

	((isWorld not or: [self backgroundSketch notNil]) or: [presenter isNil])
		ifTrue:
			[aMenu addLine].

	isWorld ifFalse:
		[aMenu add: 'set thumbnail height...' translated action: #setThumbnailHeight.
		aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them' translated.
		aMenu add: 'behave like a Holder' translated action: #becomeLikeAHolder.
		aMenu balloonTextForLastItem: 'Set properties to make this object nicely set up to hold frames of a scripted animation.' translated].

	self backgroundSketch ifNotNil:
		[aMenu add: 'delete background painting' translated action: #deleteBackgroundPainting.
		aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.' translated].
	presenter ifNil:
		[aMenu add: 'make detachable' translated action: #makeDetachable.
		aMenu balloonTextForLastItem: 'Allow this area to be separately governed by its own controls.' translated].

	aMenu addLine.
	aMenu add: 'use standard texture' translated action: #setStandardTexture.
	aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.' translated.
	aMenu add: 'make graph paper...' translated action: #makeGraphPaper.
	aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.' translated.
	aMenu addTitle: 'playfield options...' translated.

	^ aMenu
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 10/26/2000 11:32'!
presentCardAndStackMenu
	"Put up a menu holding card/stack-related options."

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.		
	aMenu addStayUpItem.
	aMenu addTitle: 'card und stack'.
	aMenu add: 'add new card' action: #insertCard.
	aMenu add: 'delete this card' action: #deleteCard.
	aMenu add: 'go to next card' action: #goToNextCardInStack.
	aMenu add: 'go to previous card' action: #goToPreviousCardInStack.
	aMenu addLine.
	aMenu add: 'show foreground objects' action: #showForegroundObjects.
	aMenu add: 'show background objects' action: #showBackgroundObjects.
	aMenu add: 'show designations' action: #showDesignationsOfObjects.
	aMenu add: 'explain designations'  action: #explainDesignations.
	aMenu popUpInWorld: (self world ifNil: [self currentWorld])! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/12/2000 09:14'!
presentPlayfieldMenu

	self playfieldOptionsMenu popUpForHand: self activeHand in: self world! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:04'!
presentViewMenu
	"Answer an auxiliary menu with options specific to viewing playfields -- this is put up from the provisional 'view' halo handle, on pasteup morphs only."

	| aMenu isWorld |
	isWorld _ self isWorldMorph.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	self addViewingItemsTo: aMenu.

	#(	"(autoLineLayoutString	toggleAutoLineLayout
			'whether submorphs should automatically be laid out in lines')"
		(indicateCursorString	toggleIndicateCursor
			'whether the "current" submorph should be indicated with a dark black border')
		(resizeToFitString		toggleResizeToFit
			'whether I should automatically strive exactly to fit my contents')
		(behaveLikeAHolderString	toggleBehaveLikeAHolder
			'whether auto-line-layout, resize-to-fit, and indicate-cursor should be set to true; useful for animation control, etc.')
		(isPartsBinString		toggleIsPartsBin
			'whether dragging an object from the interior should produce a COPY of the object')
		(isOpenForDragNDropString	toggleDragNDrop
			'whether objects can be dropped into and dragged out of me')
		(mouseOverHalosString	toggleMouseOverHalos
			'whether objects should put up halos when the mouse is over them')
		(autoExpansionString	toggleAutomaticPhraseExpansion
			'whether tile phrases, dropped on me, should automatically sprout Scriptors around them')
		(originAtCenterString	toggleOriginAtCenter
			'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield')
		(showThumbnailString	toggleAlwaysShowThumbnail
			'whether large objects should be represented by thumbnail miniatures of themselves')
		(fenceEnabledString	toggleFenceEnabled
			'whether moving objects should stop at the edge of their container')
		(autoViewingString		toggleAutomaticViewing
			'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.')
		(griddingString			griddingOnOff
			'whether gridding should be used in my interior')
		(gridVisibleString		gridVisibleOnOff
			'whether the grid should be shown when gridding is on')


	) do:

			[:triplet |
				(isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail toggleAutomaticViewing ) includes: triplet second]) ifFalse:
					[aMenu addUpdating: triplet first action: triplet second.
					aMenu balloonTextForLastItem: triplet third translated]]. 

	aMenu addLine.
	aMenu add: 'round up strays' translated action: #roundUpStrays.
	aMenu balloonTextForLastItem:  'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.' translated.
	aMenu add: 'shuffle contents' translated action: #shuffleSubmorphs.
	aMenu balloonTextForLastItem: 'Rearranges my contents in random order' translated.
	aMenu add: 'set grid spacing...' translated action: #setGridSpec.
	aMenu balloonTextForLastItem: 'Set the spacing to be used when gridding is on' translated.

	isWorld ifFalse:
		[aMenu add: 'set thumbnail height...' translated action: #setThumbnailHeight.
		aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them' translated].

	self backgroundSketch ifNotNil:
		[aMenu add: 'delete background painting' translated action: #deleteBackgroundPainting.
		aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.' translated].
	aMenu addLine.
	self addPenTrailsMenuItemsTo: aMenu.
	aMenu addLine.
	aMenu add: 'use standard texture' translated action: #setStandardTexture.
	aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.' translated.
	aMenu add: 'make graph paper...' translated action: #makeGraphPaper.
	aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.' translated.
	aMenu addTitle: ('viewing options for "{1}"' translated format: {self externalName}).

	aMenu popUpForHand: self activeHand in: self world
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 01:17'!
putUpPenTrailsSubmenu
	"Put up the pen trails menu"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu title: 'pen trails' translated.
	aMenu addStayUpItem.
	self addPenTrailsMenuItemsTo: aMenu.
	aMenu popUpInWorld: ActiveWorld! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 4/23/2001 12:33'!
reformulateUpdatingMenus
	"Give any updating menu morphs in the receiver a fresh kiss of life"

	(self submorphs select: [:m | m isKindOf: UpdatingMenuMorph]) do:
		[:m | m updateMenu] 

	"NB: to do the perfect job here one might well want to extend across allMorphs here, but the expense upon project entry is seemingly too high a price to pay at this point"! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 2/18/2003 03:08'!
sendTextContentsBackToDonor
	"Send my string contents back to the Text Morph from whence I came"

	(self valueOfProperty: #donorTextMorph) ifNotNilDo:
		[:aDonor | aDonor setCharacters: self assuredPlayer getStringContents]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:33'!
showApplicationView

	self transformToShow: (self valueOfProperty: #applicationViewBounds ifAbsent: [bounds])
		! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:47'!
showExpandedView

	owner	"the transform"
		owner	"the green border"
			bounds: Display boundingBox! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:33'!
showFactoryView

	self transformToShow: (self valueOfProperty: #factoryViewBounds ifAbsent: [bounds])
		! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 7/13/2000 10:17'!
showFullView

	self transformToShow: bounds
		! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:46'!
showReducedView

	| r |
	r _ Display extent // 4 extent: Display extent // 2.
	owner	"the transform"
		owner	"the green border"
			bounds: r! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:00'!
showThumbnailString
	"Answer the string to be shown in a menu to represent the 
	show-thumbnails status"
	^ ((self hasProperty: #alwaysShowThumbnail)
		ifTrue: ['<on>']
		ifFalse: ['<off>']), 'show thumbnails' translated! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/20/2004 19:27'!
showWorldMainDockingBarString
	^ self project showWorldMainDockingBarString! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/20/2004 19:27'!
toggleShowWorldMainDockingBar
	self project toggleShowWorldMainDockingBar! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 19:10'!
transformToShow: aRectangle

	owner changeWorldBoundsToShow: aRectangle
! !


!PasteUpMorph methodsFor: 'misc' stamp: 'sw 9/9/1998 10:45'!
abandonCostumeHistory
	self allMorphsDo:
		[:m | m player ifNotNil: [m player forgetOtherCostumes]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/24/1998 19:46'!
allScriptEditors
	^ self allMorphs select:
		[:s | s isKindOf: ScriptEditorMorph]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/24/2000 13:51'!
allScriptors
	"Answer a list of all active scriptors running on behalf of the receiver.  This is a hook used in past demos and with a future life which however presently is vacuous"

	^ #()
"
	^ self allMorphs select: [:m | m isKindOf: Scriptor]"! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 7/6/1998 14:19'!
alwaysShowThumbnail
	^ self hasProperty: #alwaysShowThumbnail! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:44'!
cachedOrNewThumbnailFrom: newThumbnail
	"If I have a cached thumbnail, and it is of the desired extent, then ruturn it.
	Otherwise produce one in newThumbnail and return it (after caching).
	This code parallels what happens in page: to match resultant extent."
	| cachedThumbnail scale ext |
	scale _ newThumbnail height / self fullBounds height.
	ext _ (self fullBounds extent * scale) truncated.
	(cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil:
		[cachedThumbnail extent = ext ifTrue: [^ cachedThumbnail]].
	self setProperty: #cachedThumbnail toValue: (newThumbnail page: self).
	^ newThumbnail! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 7/6/1999 13:30'!
cartesianOrigin
	^ self originAtCenter
		ifFalse:
			[self bottomLeft]
		ifTrue:
			[self center]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 9/8/2000 18:52'!
closedViewerFlapTabs
	"Answer all the viewer flap tabs in receiver that are closed"

	^ self submorphs select:
		[:m | (m isKindOf: ViewerFlapTab) and: [m flapShowing not]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/8/1998 16:50'!
heightForThumbnails
	^ self valueOfProperty: #heightForThumbnails ifAbsent: [50]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/18/2001 18:36'!
hideFlapsOtherThan: aFlapTab ifClingingTo: anEdgeSymbol
	"Hide flaps on the given edge unless they are the given one"

	self flapTabs do:
		[:aTab | (aTab edgeToAdhereTo == anEdgeSymbol)
			ifTrue:
				[aTab  == aFlapTab
					ifFalse:
						[aTab hideFlap]]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'ar 2/12/2001 23:17'!
hideViewerFlaps
	self flapTabs do:[:aTab |
		(aTab isKindOf: ViewerFlapTab) ifTrue:[aTab hideFlap]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/25/1999 22:44'!
hideViewerFlapsOtherThanFor: aPlayer
	self flapTabs do:
		[:aTab | (aTab isKindOf: ViewerFlapTab)
			ifTrue:
				[aTab scriptedPlayer == aPlayer
					ifFalse:
						[aTab hideFlap]]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 2/15/1999 19:32'!
impartPrivatePresenter
	presenter ifNil:
		[presenter _ Presenter new associatedMorph: self.
		presenter standardPlayer]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'dgd 8/30/2003 15:52'!
innocuousName
	^ (self isFlap)
		ifTrue:
			['flap' translated]
		ifFalse:
			[super innocuousName]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/16/1999 11:09'!
makeDetachable
	presenter
		ifNil:
			[self impartPrivatePresenter.
			self borderWidth: 1;  borderColor: Color green darker]
		ifNotNil:
			[self inform: 'This view is ALREADY detachable']! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/8/1998 16:50'!
maxHeightToAvoidThumbnailing
	^ self valueOfProperty: #maxHeightToAvoidThumbnailing ifAbsent: [80]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/13/1998 10:06'!
maximumThumbnailWidth
	^ self valueOfProperty: #maximumThumbnailWidth ifAbsent: [200 min: (self width - 10)]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'yo 2/17/2005 16:58'!
mouseX
	"Answer the x-coordinate of the mouse, in my coordinate system"

	^ self isInWorld
		ifTrue:
			[((self pointFromWorld: self cursorPoint) x) - self cartesianOrigin x]
		ifFalse:
			[0]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'yo 2/17/2005 16:58'!
mouseY
	"Answer the y-coordinate of the mouse, in my coordinate system"

	^ self isInWorld
		ifTrue:
			[self cartesianOrigin y - ((self pointFromWorld: self cursorPoint) y)]
		ifFalse:
			[0]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 8/16/2000 17:42'!
nameForCopyIfAlreadyNamed: aMorph
	"Answer a name to set for a copy of aMorph if aMorph itself is named, else nil"

	| aName usedNames |
	^ (aName _ aMorph knownName) ifNotNil:
		[usedNames _ self allKnownNames.
		Utilities keyLike: aName satisfying: [:f | (usedNames includes: f) not]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 4/23/1998 18:50'!
padding: aNumber
	padding _ aNumber! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 5/1/2005 00:29'!
prepareToBeSaved
	"Prepare for export via the ReferenceStream mechanism"

	| exportDict soundKeyList players |
	super prepareToBeSaved.
	turtlePen _ nil.
	self isWorldMorph
		ifTrue:
			[self removeProperty: #scriptsToResume.
			soundKeyList _ Set new.
			(players _ self presenter allExtantPlayers)
				do: [:aPlayer | aPlayer slotInfo
						associationsDo: [:assoc | assoc value type == #Sound
								ifTrue: [soundKeyList
										add: (aPlayer instVarNamed: assoc key)]]].
			players
				do: [:p | p allScriptEditors
						do: [:e | (e allMorphs
								select: [:m | m isKindOf: SoundTile])
								do: [:aTile | soundKeyList add: aTile literal]]].
			(self allMorphs
				select: [:m | m isKindOf: SoundTile])
				do: [:aTile | soundKeyList add: aTile literal].
			soundKeyList removeAllFoundIn: SampledSound universalSoundKeys.
			soundKeyList
				removeAllSuchThat: [:aKey | (SampledSound soundLibrary includesKey: aKey) not].
			soundKeyList isEmpty
				ifFalse: [exportDict _ Dictionary new.
					soundKeyList
						do: [:aKey | exportDict
								add: (SampledSound soundLibrary associationAt: aKey)].
					self setProperty: #soundAdditions toValue: exportDict]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:45'!
smallThumbnailForPageSorter

	^ self cachedOrNewThumbnailFrom: BookPageThumbnailMorph new smaller! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 3/23/2000 12:52'!
startRunningAll
	"Start running all scripted morphs.  Triggered by user hitting GO button"

	self presenter flushPlayerListCache.  "Inefficient, but makes sure things come right whenever GO hit"
	self presenter allExtantPlayers do: [:aPlayer | aPlayer costume residesInPartsBin ifFalse: [aPlayer startRunning]].
	self allScriptors do:
		[:aScriptor | aScriptor startRunningIfPaused].

	self world updateStatusForAllScriptEditors! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/23/2000 19:03'!
stepAll
	"tick all the paused player scripts in the receiver"

	self presenter allExtantPlayers do:
		[:aPlayer | 
			aPlayer startRunning; step; stopRunning].

	self allScriptors do:
		[:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/24/2000 07:33'!
stopRunningAll
	"Reset all ticking scripts to be paused.  Triggered by user hitting STOP button"

	self presenter allExtantPlayers do:
		[:aPlayer |
		aPlayer stopRunning].
	self allScriptors do:
		[:aScript | aScript pauseIfTicking].

	self world updateStatusForAllScriptEditors! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:44'!
thumbnailForPageSorter

	^ self cachedOrNewThumbnailFrom: BookPageThumbnailMorph new! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/1/1999 16:04'!
unhideHiddenObjects
	self allMorphsDo:
		[:m | m show]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/24/1998 19:47'!
updateStatusForAllScriptEditors
	self allScriptEditors do: [:anEditor | anEditor updateStatus]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'ka 4/10/2005 00:43'!
viewerFlapTabFor: anObject
	"Open up a Viewer on aMorph in its own flap, creating it if necessary"

	| bottomMost aPlayer aFlapTab tempFlapTab |
	bottomMost _ self top.
	aPlayer _ anObject isMorph ifTrue: [anObject assuredPlayer] ifFalse: [anObject objectRepresented].
	self flapTabs do:
		[:aTab | ((aTab isKindOf: ViewerFlapTab) or: [aTab hasProperty: #paintingFlap])
			ifTrue:
				[bottomMost _ aTab bottom max: bottomMost.
				((aTab isKindOf: ViewerFlapTab) and: [aTab scriptedPlayer == aPlayer])
					ifTrue:
						[^ aTab]]].
	"Not found; make a new one"
	tempFlapTab _ Flaps newFlapTitled: anObject nameForViewer onEdge: #right inPasteUp: self.
	tempFlapTab arrangeToPopOutOnDragOver: false;
		arrangeToPopOutOnMouseOver: false. 
	"For some reason those event handlers were causing trouble, as reported by ar 11/22/2001, after di's flapsOnBottom update."
	aFlapTab _ tempFlapTab as: ViewerFlapTab.

	aFlapTab initializeFor: aPlayer topAt: bottomMost + 2.
	aFlapTab referent color: (Color green muchLighter alpha: 0.5).
	aFlapTab referent borderWidth: 0.
	aFlapTab referent setProperty: #automaticPhraseExpansion toValue: true.
	Preferences compactViewerFlaps 
		ifTrue:	[aFlapTab makeFlapCompact: true].
	self addMorphFront: aFlapTab.
	aFlapTab adaptToWorld: self.
	aFlapTab setProperty: #isEToysFlap toValue: true.
	^ aFlapTab! !


!PasteUpMorph methodsFor: 'model' stamp: 'dgd 2/22/2003 14:09'!
createCustomModel
	"Create a model object for this world if it does not yet have one. A model object is an initially empty subclass of MorphicModel. As the user names parts and adds behavior, instance variables and methods are added to this class."

	model isNil ifFalse: [^self].
	model := MorphicModel newSubclass new! !

!PasteUpMorph methodsFor: 'model' stamp: 'sw 4/1/98 21:18'!
model
	"Return the model object for this world. If the world has no model, then create one."

	self createCustomModel.
	^ model! !

!PasteUpMorph methodsFor: 'model' stamp: 'sw 4/1/98 21:17'!
setModel: aModelMorph
	"Set the model for this world. Methods for sensitized morphs will be compiled into the class for this model."

	model _ aModelMorph
! !


!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 14:19'!
addRemoteClient: aClient
	self addHand: aClient hand.
	worldState addRemoteCanvas: aClient canvas.
	aClient canvas fullDrawMorph: self.
	self changed.  "force a redraw"
! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'RAA 11/8/2000 15:04'!
convertRemoteClientToBuffered: aClient

	worldState removeRemoteCanvas: aClient canvas.
	aClient convertToBuffered.
	worldState addRemoteCanvas: aClient canvas.
	self changed.  "force a redraw"
! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 15:03'!
hasRemoteServer
	^self remoteServer notNil! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'wiz 1/9/2005 15:37'!
isSafeToServe
	"True if all conditions are met to share safely. 
	(attends to mantis bug #0000519).
	Right now we reject worlds with FlashMorphs for subMorphs."

	(self findA: FlashMorph) ifNil: [^true].
	self inform: 'Can not share world if Squeaklogo is present. Collapse logo and try again'.
	^false! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 14:44'!
releaseRemoteServer
	"My server has been transferred to some other world. Release pending references"
	^worldState releaseRemoteServer.! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 14:08'!
remoteServer
	^worldState remoteServer.! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'RAA 11/6/2000 17:24'!
remoteServer: aNebraskaServer

	| h |

	worldState remoteServer: aNebraskaServer.
	h _ self primaryHand.
	aNebraskaServer ifNil:[
		(h hasProperty: #representingTheServer) ifTrue: [
			h removeProperty: #representingTheServer.
			h userInitials: '' andPicture: nil.
		]
	] ifNotNil:[
		(h hasProperty: #representingTheServer) ifFalse: [
			h setProperty: #representingTheServer toValue: true.
			h userInitials: Utilities authorName andPicture: nil.
		]
	].! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 14:19'!
removeRemoteClient: aClient
	self removeHand: aClient hand.
	worldState removeRemoteCanvas: aClient canvas.
	self changed.  "force a redraw"
! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 15:19'!
transferRemoteServerFrom: aWorld
	"Transfer the remote server which was associated with aWorld (if any) to the receiver"
	| server |
	(aWorld notNil and:[aWorld isMorph and:[aWorld isWorldMorph]]) ifFalse:[^self].
	server _ aWorld remoteServer.
	server ifNotNil:[
		self remoteServer: server.
		server clients do:[:each| self addRemoteClient: each].
		self primaryHand
			userInitials: (aWorld primaryHand userInitials)
			andPicture: (aWorld primaryHand userPicture).
		aWorld primaryHand userInitials: '' andPicture: nil].
	aWorld releaseRemoteServer.! !


!PasteUpMorph methodsFor: 'name' stamp: 'sw 6/17/2004 01:46'!
unusedMorphNameLike: stem
	"Answer a suitable name for a morph in this world, based on the stem provided"

	| names |
	names _ self allKnownNames.
	^ Utilities keyLike: stem asString satisfying:
		[:aName | (names includes: aName) not]! !


!PasteUpMorph methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:48'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"transition from project to worldState (8/16/1999)"
	worldState ifNil: [varDict at: 'project' ifPresent: [ :x | worldState _ x]].

	"elimination of specific gradient stuff (5/6/2000)"
	varDict at: 'fillColor2' ifPresent: [ :color2 |
		(color isColor and: [color2 isColor and: [color ~= color2]]) ifTrue: [
			self useGradientFill.
			self fillStyle
				colorRamp: {0.0 -> color. 1.0 -> color2};
				radial: false;
				origin: self position;
				direction: ((varDict at: 'gradientDirection') == #vertical 
					ifTrue:[0@self height] 
					ifFalse:[self width@0]).
		]
	].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !

!PasteUpMorph methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 17:31'!
fixUponLoad: aProject seg: anImageSegment
	"We are in an old project that is being loaded from disk.
Fix up conventions that have changed."

	self isWorldMorph ifTrue: [
			(self valueOfProperty: #soundAdditions) ifNotNilDo:
				[:additions | SampledSound
assimilateSoundsFrom: additions]].

	^ super fixUponLoad: aProject seg: anImageSegment! !

!PasteUpMorph methodsFor: 'objects from disk' stamp: 'yo 7/2/2004 13:21'!
saveOnFile
	"Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| aFileName fileStream ok |

	self flag: #bob0302.
	self isWorldMorph ifTrue: [^self project saveAs].

	aFileName _ ('my {1}' translated format: {self class name}) asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name? (".project" will be added to end)' translated 
			initialAnswer: aFileName.
	aFileName isEmpty ifTrue: [^ Beeper beep].
	self allMorphsDo: [:m | m prepareToBeSaved].

	ok _ aFileName endsWith: '.project'.	"don't double them"
	ok _ ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName _ aFileName,'.project'].
	fileStream _ FileStream newFileNamed: aFileName asFileName.
	fileStream fileOutClass: nil andObject: self.	"Puts UniClass definitions out anyway"! !


!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 12:48'!
autoLineLayout
	| layout |
	layout _ self layoutPolicy ifNil:[^false].
	layout isTableLayout ifFalse:[^false].
	self listDirection == #leftToRight ifFalse:[^false].
	self wrapDirection == #topToBottom ifFalse:[^false].
	^true! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 15:07'!
autoLineLayout: aBoolean
	"Make the receiver be viewed with auto-line-layout, which means that its submorphs will be laid out left-to-right and then top-to-bottom in the manner of a word processor, or (if aBoolean is false,) cease applying auto-line-layout"

	aBoolean ifTrue:
		[self viewingNormally ifTrue: [self saveBoundsOfSubmorphs]].
	aBoolean ifTrue:[
		self layoutPolicy: TableLayout new.
		self layoutInset: 8; cellInset: 4.
		self listDirection: #leftToRight; wrapDirection: #topToBottom.
	] ifFalse:[
		self layoutPolicy: nil.
		self layoutInset: 0; cellInset: 0.
	].
! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 9/28/1998 13:15'!
automaticViewing: aBoolean
	self setProperty: #automaticViewing toValue: aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/25/2000 06:04'!
batchPenTrails
	"Answer whether pen trails should be batched in the receiver"

	^ self valueOfProperty: #batchPenTrails ifAbsent: [Preferences batchPenTrails]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/25/2000 06:05'!
batchPenTrails: aBoolean

	self setProperty: #batchPenTrails toValue: aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'dgd 9/6/2003 17:55'!
becomeLikeAHolder
	(self autoLineLayout
			and: [self indicateCursor])
		ifTrue: [^ self inform: 'This view is ALREADY
behaving like a holder, which
is to say, it is set to indicate the
cursor and to have auto-line-layout.' translated].
	self behaveLikeHolder! !

!PasteUpMorph methodsFor: 'options' stamp: 'dgd 12/13/2003 19:30'!
behaveLikeAHolderString
	"Answer a string to be displayed in a menu to characterize 
	whether the receiver is currently behaving like a holder"
	^ (self behavingLikeAHolder
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'behave like a holder' translated! !

!PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:40'!
behaveLikeHolder
 
	self vResizeToFit: true; autoLineLayout: true; indicateCursor: true! !

!PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:40'!
behaveLikeHolder: aBoolean
 	"Change the receiver's viewing properties such that they conform to what we commonly call a Holder, viz: resize-to-fit, do auto-line-layout, and indicate the 'cursor'"

	self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
	! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/17/2000 12:04'!
behavingLikeAHolder
	"Answer whether the receiver is currently behaving like a Holder"

	^ self resizeToFit and: [self indicateCursor and: [self autoLineLayout]]! !

!PasteUpMorph methodsFor: 'options' stamp: 'RAA 10/4/2000 08:24'!
fenceEnabled: aBoolean

	self setProperty: #fenceEnabled toValue: aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/1/98 16:58'!
indicateCursor
	^ indicateCursor == true! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/1/98 16:59'!
indicateCursor: aBoolean
	indicateCursor _ aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/23/1998 16:49'!
isPartsBin: aBoolean
	isPartsBin _ aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 2/5/2001 16:59'!
replaceTallSubmorphsByThumbnails
	"Any submorphs that seem to tall get replaced by thumbnails; their balloon text is copied over to the thumbnail"

	|  itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails existingHelp |
	heightForThumbnails _ self heightForThumbnails.
	maxHeightToAvoidThumbnailing _ self maxHeightToAvoidThumbnailing.
	maxWidthForThumbnails _ self maximumThumbnailWidth.
	self submorphs do:
		[:aMorph |
			itsThumbnail _ aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
			(aMorph == itsThumbnail)
				ifFalse:
					[existingHelp _ aMorph balloonText.
					self replaceSubmorph: aMorph by: itsThumbnail.
					existingHelp ifNotNil:
						[itsThumbnail setBalloonText: existingHelp]]]! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 12:49'!
resizeToFit
	^self vResizing == #shrinkWrap! !

!PasteUpMorph methodsFor: 'options' stamp: 'dgd 12/13/2003 19:30'!
resizeToFitString
	"Answer a string, to be used in a self-updating menu, to 
	represent whether the receiver is currently using resize-to-fit 
	or not"
	^ (self resizeToFit
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'resize to fit' translated! !

!PasteUpMorph methodsFor: 'options' stamp: 'panda 4/25/2000 15:42'!
setPartsBinStatusTo: aBoolean
	isPartsBin _ aBoolean.
	aBoolean ifFalse: [self enableDragNDrop].
		"but note that we no longer reset openToDragNDrop to false upon making it a parts bin again"
	isPartsBin
		ifTrue:
			[submorphs do:
				[:m | m isPartsDonor: true.
					m stopStepping.
					m suspendEventHandler]]
		ifFalse:
			[submorphs do:
				[:m | m isPartsDonor: false.
					m restoreSuspendedEventHandler].
			self world ifNotNil: [self world startSteppingSubmorphsOf: self]]! !

!PasteUpMorph methodsFor: 'options' stamp: 'dgd 9/6/2003 18:05'!
setThumbnailHeight
	|  reply |
	(self hasProperty: #alwaysShowThumbnail) ifFalse:
		[^ self inform: 'setting the thumbnail height is only
applicable when you are currently
showing thumbnails.' translated].
	reply _ FillInTheBlank
		request: 'New height for thumbnails? ' translated
		initialAnswer: self heightForThumbnails printString.
	reply isEmpty ifTrue: [^ self].
	reply _ reply asNumber.
	(reply > 0 and: [reply <= 150]) ifFalse:
		[^ self inform: 'Please be reasonable!!' translated].
	self setProperty: #heightForThumbnails toValue: reply.
	self updateSubmorphThumbnails! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 7/6/1998 16:26'!
toggleAlwaysShowThumbnail
	(self hasProperty: #alwaysShowThumbnail)
		ifTrue:
			[self removeProperty: #alwaysShowThumbnail]
		ifFalse:
			[self setProperty: #alwaysShowThumbnail toValue: true].
	self updateSubmorphThumbnails! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/8/2000 22:37'!
toggleAutoLineLayout
	"Toggle the auto-line-layout setting"

	self autoLineLayout: self autoLineLayout not.
	self autoLineLayout ifFalse: [self restoreBoundsOfSubmorphs].! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/18/1998 09:12'!
toggleAutomaticPhraseExpansion
	| expand |
	expand _ self hasProperty: #automaticPhraseExpansion.
	expand
		ifTrue:
			[self removeProperty: #automaticPhraseExpansion]
		ifFalse:
			[self setProperty: #automaticPhraseExpansion toValue: true]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/18/1998 09:13'!
toggleAutomaticViewing
	| current |
	current _ self automaticViewing.
	current
		ifTrue:
			[self removeProperty: #automaticViewing]
		ifFalse:
			[self setProperty: #automaticViewing toValue: true]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/25/2000 06:06'!
toggleBatchPenTrails
	
	self batchPenTrails: self batchPenTrails not! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/23/2000 19:04'!
toggleBehaveLikeAHolder
	"Toggle whether or not the receiver is currently behaving like a holder"

	self behaveLikeHolder: (self behavingLikeAHolder not)! !

!PasteUpMorph methodsFor: 'options' stamp: 'RAA 10/4/2000 08:26'!
toggleFenceEnabled
	
	self fenceEnabled: self fenceEnabled not! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/8/2000 22:37'!
toggleIndicateCursor
	indicateCursor _ self indicateCursor not.
	self changed.! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 9/30/1998 17:24'!
toggleIsPartsBin
	"Not entirely happy with the openToDragNDrop not being directly manipulable etc, but still living with it for now."
	self setPartsBinStatusTo: self isPartsBin not! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 1/27/2000 14:51'!
toggleMouseOverHalos
	wantsMouseOverHalos _ self wantsMouseOverHalos not! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 7/6/1999 13:36'!
toggleOriginAtCenter
	| hasIt |
	hasIt _ self hasProperty: #originAtCenter.
	hasIt
		ifTrue:
			[self removeProperty: #originAtCenter]
		ifFalse:
			[self setProperty: #originAtCenter toValue: true]! !

!PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:41'!
toggleResizeToFit
	"Toggle whether the receiver is set to resize-to-fit"

	self vResizeToFit: self resizeToFit not! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 11/13/1998 09:56'!
updateSubmorphThumbnails
	| thumbsUp itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails |
	thumbsUp _ self alwaysShowThumbnail.
	heightForThumbnails _ self heightForThumbnails.
	maxHeightToAvoidThumbnailing _ self maxHeightToAvoidThumbnailing.
	maxWidthForThumbnails _ self maximumThumbnailWidth.
	self submorphs do:
		[:aMorph | thumbsUp
			ifTrue:
				[itsThumbnail _ aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
				(aMorph == itsThumbnail)
					ifFalse:
						[self replaceSubmorph: aMorph by: itsThumbnail]]
			ifFalse:
				[(aMorph isKindOf: MorphThumbnail)
					ifTrue:
						[self replaceSubmorph: aMorph by: aMorph morphRepresented]]]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/5/1998 18:13'!
wantsMouseOverHalos
	^ wantsMouseOverHalos == true! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/5/1998 18:13'!
wantsMouseOverHalos: aBoolean
	wantsMouseOverHalos _ aBoolean! !


!PasteUpMorph methodsFor: 'painting' stamp: 'bf 10/2/2002 18:36'!
backgroundForm

	^ self backgroundSketch
		ifNil: [Form extent: self extent depth: Display depth]
		ifNotNil: [backgroundMorph form]! !

!PasteUpMorph methodsFor: 'painting' stamp: 'nk 1/6/2004 12:39'!
backgroundForm: aForm

	self backgroundSketch: (self drawingClass new
		center: self center;
		form: aForm)! !

!PasteUpMorph methodsFor: 'painting' stamp: 'bf 10/2/2002 17:07'!
backgroundSketch

	backgroundMorph ifNil: [^ nil].
	backgroundMorph owner == self ifFalse:
		[backgroundMorph _ nil].	"has been deleted"
	^ backgroundMorph! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 10/17/2000 11:56'!
backgroundSketch: aSketchMorphOrNil
	"Set the receiver's background graphic as indicated.  If nil is supplied, remove any existing background graphic.  In any case, delete any preexisting background graphic."

	backgroundMorph ifNotNil: [backgroundMorph delete].  "replacing old background"

	aSketchMorphOrNil ifNil: [backgroundMorph _ nil.  ^ self].

	backgroundMorph _ StickySketchMorph new form: aSketchMorphOrNil form.
	backgroundMorph position: aSketchMorphOrNil position.
	self addMorphBack: backgroundMorph.
	aSketchMorphOrNil delete.
	backgroundMorph lock.
	backgroundMorph setProperty: #shared toValue: true.
	^ backgroundMorph
! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 6/16/1999 11:16'!
deleteBackgroundPainting
	backgroundMorph
		ifNotNil:
			[backgroundMorph delete.
			backgroundMorph _ nil]
		ifNil:
			[self inform: 'There is presently no
background painting
to delete.']! !

!PasteUpMorph methodsFor: 'painting' stamp: 'nk 7/4/2003 15:59'!
drawSubmorphsOn: aCanvas 
	"Display submorphs back to front, but skip my background sketch."

	| drawBlock |
	submorphs isEmpty ifTrue: [^self].
	drawBlock := [:canvas | submorphs reverseDo: [:m | m ~~ backgroundMorph ifTrue: [ canvas fullDrawMorph: m ]]].
	self clipSubmorphs 
		ifTrue: [aCanvas clipBy: self clippingBounds during: drawBlock]
		ifFalse: [drawBlock value: aCanvas]! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 3/24/2001 23:58'!
makeNewDrawingWithin
	"Start a painting session in my interior which will result in a new SketchMorph being created as one of my submorphs"

	| evt |
	evt _ MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand.
	self makeNewDrawing: evt! !

!PasteUpMorph methodsFor: 'painting' stamp: 'ar 6/2/2001 16:55'!
paintBackground
	| pic rect |
	self world prepareToPaint.
	pic _ self backgroundSketch.
	pic ifNotNil: [pic editDrawingIn: self forBackground: true]		"need to resubmit it? (tck comment)"
		ifNil: [rect _ self bounds.
			pic _ self world drawingClass new form: 
				(Form extent: rect extent depth: Display depth).
			pic bounds: rect.
			"self world addMorphBack: pic.  done below"
			pic _ self backgroundSketch: pic.	"returns a different guy"
			pic ifNotNil: [pic editDrawingIn: self forBackground: true]]! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 9/22/1998 12:26'!
paintingBoundsAround: aPoint
	"Return a rectangle for painting centered on the given point. Both the argument point and the result rectangle are in world coordinates."

	| paintExtent maxPaintArea myBnds |
	paintExtent _ self reasonablePaintingExtent.
	maxPaintArea _ paintExtent x * paintExtent y.
	myBnds _ self boundsInWorld.
	(myBnds area <= maxPaintArea) ifTrue: [^ myBnds].
	^ (aPoint - (paintExtent // 2) extent: paintExtent) intersect: myBnds
! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 10/4/2004 05:06'!
prepareToPaint
	"We're about to start painting. Do a few preparations that make the system more responsive."

	^ self prepareToPaint: Preferences keepTickingWhilePainting not! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 5/1/2005 00:32'!
prepareToPaint: stopRunningScripts
	"We're about to start painting. Do a few preparations that make the system more responsive."

	self hideViewerFlaps. "make room"
	stopRunningScripts ifTrue:
		[self setProperty: #scriptsToResume toValue: self presenter allCurrentlyTickingScriptInstantiations.  "We'll restart these when painting is done"
		self stopRunningAll]. "stop scripts"
	self abandonAllHalos. "no more halos"! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 9/29/1998 07:35'!
reasonablePaintingExtent
	^ Preferences unlimitedPaintArea
		ifTrue:
			[3000 @ 3000]
		ifFalse:
			[Preferences defaultPaintingExtent]! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 5/1/2005 00:33'!
resumeScriptsPausedByPainting
	"If there were any scripts running when painting was initiated, resume them now"

	| aList |
	(aList _ self valueOfProperty: #scriptsToResume) isEmptyOrNil ifFalse:
		[aList do:
			[:aScriptInstantiation |
				aScriptInstantiation player costume isInWorld ifTrue:
					[aScriptInstantiation startRunningIfPaused]]].
	self removeProperty: #scriptsToResume! !


!PasteUpMorph methodsFor: 'parts bin' stamp: 'sw 8/2/2001 17:50'!
initializeToStandAlone
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	self initialize.
	self color: Color green muchLighter;  extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161).
	self extent: 300 @ 240.
	self beSticky! !

!PasteUpMorph methodsFor: 'parts bin' stamp: 'sw 4/13/1998 18:15'!
isPartsBin
	^ isPartsBin == true! !

!PasteUpMorph methodsFor: 'parts bin' stamp: 'di 6/8/1999 14:22'!
residesInPartsBin
	"Answer true if the receiver is, or has some ancestor owner who is, a parts bin"

	self isWorldMorph
		ifTrue: [^ self isPartsBin]
		ifFalse: [^ self isPartsBin or: [super residesInPartsBin]]! !


!PasteUpMorph methodsFor: 'pen' stamp: 'RAA 5/18/2001 10:47'!
addImageToPenTrailsFor: aMorph

	"The turtleTrailsForm is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared."
	| image |

	self createOrResizeTrailsForm.
	"origin _ self topLeft."
	image _ aMorph imageForm offset: 0@0.
	image
		displayOn: turtleTrailsForm 
		at: aMorph topLeft - self topLeft
		rule: Form paint.
	self invalidRect: (image boundingBox translateBy: aMorph topLeft).
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'tk 10/4/2001 18:03'!
arrowheadsOnAllPens

	submorphs do: [:m | m assuredPlayer setPenArrowheads: true]
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/16/2003 12:45'!
arrowsForAllPens
	"Set the trail style for all my objects to show arrowheads only"

	self trailStyleForAllPens: #arrowheads! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/1/98 16:38'!
clearTurtleTrails

	turtleTrailsForm _ nil.
	turtlePen _ nil.
	self changed.
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'nk 7/7/2003 11:17'!
createOrResizeTrailsForm
	"If necessary, create a new turtleTrailsForm or resize the existing one to fill my bounds.
	On return, turtleTrailsForm exists and is the correct size.
	Use the Display depth so that color comparisons (#color:sees: and #touchesColor:) will work right."

	| newForm |
	(turtleTrailsForm isNil or: [ turtleTrailsForm extent ~= self extent ]) ifTrue:
		["resize TrailsForm if my size has changed"
		newForm _ Form extent: self extent depth: Display depth.
		turtleTrailsForm ifNotNil: [
			newForm copy: self bounds from: turtleTrailsForm
					to: 0@0 rule: Form paint ].
		turtleTrailsForm _ newForm.
		turtlePen _ nil].

	"Recreate Pen for this form"
	turtlePen ifNil: [turtlePen _ Pen newOnForm: turtleTrailsForm].! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/10/2003 21:15'!
dotsForAllPens
	"Set the trail style for all my objects to show dots"

	self trailStyleForAllPens: #dots! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/17/2003 12:01'!
drawPenTrailFor: aMorph from: oldPoint to: targetPoint
	"Draw a pen trail for aMorph, using its pen state (the pen is assumed to be down)."
	"The turtleTrailsForm is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared."

	| origin mPenSize offset turtleTrailsDelta newPoint aPlayer trailStyle aRadius dotSize |
	turtleTrailsDelta _ self valueOfProperty: #turtleTrailsDelta ifAbsent:[0@0].
	newPoint _ targetPoint - turtleTrailsDelta.
	oldPoint = newPoint ifTrue: [^ self].
	self createOrResizeTrailsForm.
	origin _ self topLeft.
	mPenSize _ aMorph getPenSize.
	turtlePen color: aMorph getPenColor.
	turtlePen sourceForm width ~= mPenSize
		ifTrue: [turtlePen squareNib: mPenSize].
	offset _ (mPenSize // 2)@(mPenSize // 2).
	(#(lines arrows) includes: (trailStyle _ (aPlayer _ aMorph player) getTrailStyle))
		ifTrue:
			[turtlePen drawFrom: (oldPoint - origin - offset) asIntegerPoint
				to: (newPoint - origin - offset) asIntegerPoint].
	((#(arrowheads arrows) includes: trailStyle) and: [oldPoint ~= newPoint]) ifTrue:
		[turtlePen
			arrowHeadFrom: (oldPoint - origin - offset) 
			to: (newPoint - origin - offset)
			forPlayer: aPlayer].
	(#(dots) includes: trailStyle)
		ifTrue:
			[dotSize _ aPlayer getDotSize.
			turtlePen
				putDotOfDiameter: dotSize at: (oldPoint - origin).
			turtlePen
				putDotOfDiameter: dotSize at: (targetPoint - origin).
			aRadius _ (dotSize // 2) + 1.
			dotSize _ dotSize + 1.  "re round-off-derived gribblies"
			self invalidRect: ((oldPoint - origin - (aRadius @ aRadius)) extent: (dotSize @ dotSize)).
			self invalidRect: ((targetPoint - origin - (aRadius @ aRadius)) extent: (dotSize @ dotSize))]
		ifFalse:
			[self invalidRect: ((oldPoint rect: newPoint) expandBy: mPenSize)]! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:47'!
liftAllPens
	submorphs do: [:m | m assuredPlayer liftPen]! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/16/2003 12:27'!
linesAndArrowsForAllPens
	"Set the trail style for all my objects to show arrows"

	self trailStyleForAllPens: #arrows! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 3/11/2003 11:57'!
linesForAllPens
	"Set the trail style for all my objects to show lines only"

	self trailStyleForAllPens: #lines! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:47'!
lowerAllPens
	submorphs do: [:m | m assuredPlayer lowerPen]
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'tk 10/4/2001 18:03'!
noArrowheadsOnAllPens

	submorphs do: [:m | m assuredPlayer setPenArrowheads: false]
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'di 5/24/2000 15:13'!
noteNewLocation: location forPlayer: player
	"Note that a morph has just moved with its pen down, begining at startPoint.
	Only used in conjunction with Preferences batchPenTrails."

	lastTurtlePositions ifNil: [lastTurtlePositions _ IdentityDictionary new].
	lastTurtlePositions at: player put: location! !

!PasteUpMorph methodsFor: 'pen' stamp: 'di 5/24/2000 15:10'!
notePenDown: penDown forPlayer: player at: location
	"Note that a morph has just moved with its pen down, begining at startPoint.
	Only used in conjunction with Preferences batchPenTrails."

	| startLoc |
	lastTurtlePositions ifNil: [lastTurtlePositions _ IdentityDictionary new].
	penDown
		ifTrue: ["Putting the Pen down -- record current location"
				(lastTurtlePositions includesKey: player) ifFalse:
					[lastTurtlePositions at: player put: location]]
		ifFalse: ["Picking the Pen up -- draw to current location and remove"
				(startLoc _ lastTurtlePositions at: player ifAbsent: [nil]) ifNotNil:
					[self drawPenTrailFor: player costume
							from: startLoc to: location].
				lastTurtlePositions removeKey: player ifAbsent: []]! !

!PasteUpMorph methodsFor: 'pen' stamp: 'di 9/10/1998 16:17'!
trailMorph
	"Yes, you can draw trails on me."
	^ self! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 3/11/2003 11:40'!
trailStyleForAllPens: aTrailStyle
	"Ascribe the given trail style to all pens of objects within me"

	submorphs do: [:m | m assuredPlayer setTrailStyle: aTrailStyle]
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'dgd 2/22/2003 14:12'!
updateTrailsForm
	"Update the turtle-trails form using the current positions of all pens.
	Only used in conjunction with Preferences batchPenTrails."

	"Details: The positions of all morphs with their pens down are recorded each time the draw method is called. If the list from the previous display cycle isn't empty, then trails are drawn from the old to the new positions of those morphs on the turtle-trails form. The turtle-trails form is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared."

	| morph oldPoint newPoint removals player tfm |
	self flag: #bob.	"transformations WRONG here"
	(lastTurtlePositions isNil or: [lastTurtlePositions isEmpty]) 
		ifTrue: [^self].
	removals := OrderedCollection new.
	lastTurtlePositions associationsDo: 
			[:assoc | 
			player := assoc key.
			morph := player costume.
			(player getPenDown and: [morph trailMorph == self]) 
				ifTrue: 
					[oldPoint := assoc value.
					tfm := morph owner transformFrom: self.
					newPoint := tfm localPointToGlobal: morph referencePosition.
					newPoint = oldPoint 
						ifFalse: 
							[assoc value: newPoint.
							self 
								drawPenTrailFor: morph
								from: oldPoint
								to: newPoint]]
				ifFalse: [removals add: player]].
	removals do: [:key | lastTurtlePositions removeKey: key ifAbsent: []]! !


!PasteUpMorph methodsFor: 'printing' stamp: 'sw 10/18/2000 10:54'!
printOn: aStream
	"Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is"

	super printOn: aStream.
	self isWorldMorph ifTrue: [aStream nextPutAll: ' [world]']! !


!PasteUpMorph methodsFor: 'project' stamp: 'tk 9/3/1999 12:07'!
project
	"Find the project that owns me.  Not efficient to call this."

	^ Project ofWorld: self! !

!PasteUpMorph methodsFor: 'project' stamp: 'tk 3/27/2000 20:38'!
releaseSqueakPages
	| uu |
	"If this world has a book with SqueakPages, then clear the SqueakPageCache"

	submorphs do: [:sub | (sub isKindOf: BookMorph) ifTrue: [
		uu _ sub valueOfProperty: #url ifAbsent: [nil].
		uu ifNotNil: [(SqueakPageCache pageCache includesKey: uu) ifTrue: [
				SqueakPageCache initialize]]]].	"wipe the cache"! !

!PasteUpMorph methodsFor: 'project' stamp: 'gm 2/16/2003 20:35'!
storeProjectsAsSegments
	"Force my sub-projects out to disk"

	submorphs do: 
			[:sub | 
			(sub isSystemWindow) 
				ifTrue: [(sub model isKindOf: Project) ifTrue: [sub model storeSegment]]]	"OK if was already out"! !


!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'!
canvas

	^ worldState canvas! !

!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'!
firstHand

	^ worldState hands first! !

!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'!
hands

	^ worldState hands! !

!PasteUpMorph methodsFor: 'project state' stamp: 'nk 7/4/2003 16:47'!
handsDo: aBlock

	^ worldState ifNotNil: [ worldState handsDo: aBlock ]! !

!PasteUpMorph methodsFor: 'project state' stamp: 'nk 7/4/2003 16:46'!
handsReverseDo: aBlock

	^ worldState ifNotNil: [ worldState handsReverseDo: aBlock ]! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 10/9/1999 22:51'!
isStepping: aMorph
	^ worldState isStepping: aMorph! !

!PasteUpMorph methodsFor: 'project state' stamp: 'ar 10/22/2000 16:43'!
isStepping: aMorph selector: aSelector
	^ worldState isStepping: aMorph selector: aSelector! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 06:45'!
listOfSteppingMorphs
	^ worldState listOfSteppingMorphs

"self currentWorld listOfSteppingMorphs"! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:56'!
stepListSize
	^ worldState stepListSize

"Transcript cr; show: self currentWorld stepListSize printString, ' items on steplist as of ', Date dateAndTimeNow printString"! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:56'!
stepListSummary
	^ worldState stepListSummary

"Transcript cr show: self currentWorld stepListSummary"! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:59'!
steppingMorphsNotInWorld
	| all |
	all _ self allMorphs.
	^ self listOfSteppingMorphs select: [:m | (all includes: m) not]

	"self currentWorld steppingMorphsNotInWorld do: [:m | m delete]"! !

!PasteUpMorph methodsFor: 'project state' stamp: 'dgd 9/27/2004 11:45'!
viewBox
	"This tortured workaround arises from a situation encountered 
	in which a PasteUpMorph was directliy lodged as a submorph 
	of another PasteUpMorph of identical size, with the former 
	bearing flaps but the latter being the world"
	^ worldState
		ifNil: [super viewBox]
		ifNotNil: [worldState viewBox]! !

!PasteUpMorph methodsFor: 'project state' stamp: 'dgd 2/22/2003 14:12'!
viewBox: newViewBox 
	"I am now displayed within newViewBox; react."

	self isWorldMorph 
		ifTrue: 
			[(self viewBox isNil or: [self viewBox extent ~= newViewBox extent]) 
				ifTrue: [worldState canvas: nil].
			worldState viewBox: newViewBox].
	super position: newViewBox topLeft.
	fullBounds := bounds := newViewBox.

	"Paragraph problem workaround; clear selections to avoid screen
droppings."
	self flag: #arNote.	"Probably unnecessary"
	self isWorldMorph 
		ifTrue: 
			[worldState handsDo: [:hand | hand releaseKeyboardFocus].
			self fullRepaintNeeded]! !


!PasteUpMorph methodsFor: 'scripting' stamp: 'sw 7/22/2001 00:55'!
abandonOldReferenceScheme
	"Perform a one-time changeover"
	"ActiveWorld abandonOldReferenceScheme"

	Preferences setPreference: #capitalizedReferences toValue: true.
	(self presenter allExtantPlayers collect: [:aPlayer | aPlayer class]) asSet do:
			[:aPlayerClass |
				aPlayerClass isUniClass ifTrue:
					[aPlayerClass abandonOldReferenceScheme]]! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:12'!
adaptedToWorld: aWorld
	"If I refer to a world or a hand, return the corresponding items in the new world."
	self isWorldMorph ifTrue:[^aWorld].! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'tk 1/31/2001 15:58'!
allTileScriptingElements
	"Answer a list of all the morphs that pertain to tile-scripting.  A sledge-hammer"

	| all morphs |
	morphs _ IdentitySet new: 400.
	self allMorphsAndBookPagesInto: morphs.
	all _ morphs select: [:s | s isTileScriptingElement].
"	self closedViewerFlapTabs do:
		[:aTab | all addAll: aTab referent allTileScriptingElements].
"
	^ all asOrderedCollection! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'nk 8/29/2004 17:17'!
currentVocabularyFor: aScriptableObject 
	"Answer the Vocabulary object to be applied when scripting an object in the world."

	| vocabSymbol vocab aPointVocab |
	vocabSymbol := self valueOfProperty: #currentVocabularySymbol
				ifAbsent: [nil].
	vocabSymbol ifNil: 
			[vocab := self valueOfProperty: #currentVocabulary ifAbsent: [nil].
			vocab ifNotNil: 
					[vocabSymbol := vocab vocabularyName.
					self removeProperty: #currentVocabulary.
					self setProperty: #currentVocabularySymbol toValue: vocabSymbol]].
	vocabSymbol ifNotNil: [^Vocabulary vocabularyNamed: vocabSymbol]
		ifNil: 
			[(aScriptableObject isPlayerLike) ifTrue: [^Vocabulary eToyVocabulary].
			(aScriptableObject isNumber) 
				ifTrue: [^Vocabulary numberVocabulary].
			(aScriptableObject isKindOf: Time) 
				ifTrue: [^Vocabulary vocabularyForClass: Time].
			(aScriptableObject isString) 
				ifTrue: [^Vocabulary vocabularyForClass: String].
			(aScriptableObject isPoint) 
				ifTrue: 
					[(aPointVocab := Vocabulary vocabularyForClass: Point) 
						ifNotNil: [^aPointVocab]].
			(aScriptableObject isKindOf: Date) 
				ifTrue: [^Vocabulary vocabularyForClass: Date].
			"OrderedCollection and Holder??"
			^Vocabulary fullVocabulary]! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'sw 2/18/2003 02:56'!
elementCount
	"Answer how many objects are contained within me"

	^ submorphs size! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'sw 2/18/2003 01:46'!
getCharacters
	"obtain a string value from the receiver"

	^ String streamContents:
		[:aStream |
			submorphs do:
				[:m | aStream nextPutAll: m getCharacters]]! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'RAA 1/8/2001 15:17'!
hideAllPlayers

	| a |
	a _ OrderedCollection new.
	self allMorphsDo: [ :x | 
		(x isKindOf: ViewerFlapTab) ifTrue: [a add: x]
	].
	a do: [ :each | each delete].
! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'dgd 8/31/2003 19:39'!
modernizeBJProject
	"Prepare a kids' project from the BJ fork of September 2000 -- a once-off thing for converting such projects forward to a modern 3.1a image, in July 2001.  Except for the #enableOnlyGlobalFlapsWithIDs: call, this could conceivably be called upon reloading *any* project, just for safety."

	"ActiveWorld modernizeBJProject"

	ScriptEditorMorph allInstancesDo:
		[:m | m userScriptObject].
	Flaps enableOnlyGlobalFlapsWithIDs: {'Supplies' translated}.
	ActiveWorld abandonOldReferenceScheme.
	ActiveWorld relaunchAllViewers.! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'gm 2/22/2003 13:09'!
recreateScripts
	"self currentWorld recreateScripts."

	Preferences enable: #universalTiles.
	Preferences enable: #capitalizedReferences.
	"Rebuild viewers"
	self flapTabs do: 
			[:ff | 
			(ff isMemberOf: ViewerFlapTab) 
				ifTrue: 
					[ff referent 
						submorphsDo: [:m | (m isStandardViewer) ifTrue: [m recreateCategories]]]].
	"Rebuild scriptors"
	((self flapTabs collect: [:t | t referent]) copyWith: self) 
		do: [:w | w allScriptEditors do: [:scrEd | scrEd unhibernate]]! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'gm 2/22/2003 13:09'!
relaunchAllViewers
	"Relaunch all the viewers in the project"

	| aViewer |
	(self submorphs select: [:m | m isKindOf: ViewerFlapTab]) do: 
			[:aTab | 
			aViewer := aTab referent submorphs 
						detect: [:sm | sm isStandardViewer]
						ifNone: [nil].
			aViewer ifNotNil: [aViewer relaunchViewer]
			"ActiveWorld relaunchAllViewers"]! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'tk 6/14/1998 15:18'!
scriptorForTextualScript: aSelector ofPlayer: aPlayer
	| aScriptor |
	self world ifNil: [^ nil].
	aScriptor _ ScriptEditorMorph new setMorph: aPlayer costume scriptName: aSelector.
	aScriptor position: (self primaryHand position - (10 @ 10)).
	^ aScriptor! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'RAA 1/8/2001 15:24'!
showAllPlayers

	| a |
	a _ OrderedCollection new.
	self allMorphsDo: [ :x | 
		(x player notNil and: [x player hasUserDefinedScripts]) ifTrue: [a add: x]
	].
	a do: [ :each | each openViewerForArgument].
! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'sw 2/20/2003 13:06'!
tellAllContents: aMessageSelector
	"Send the given message selector to all the objects within the receiver"

	self submorphs do:
		[:m |
			m player ifNotNilDo:
				[:p | p performScriptIfCan: aMessageSelector]]! !


!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 11:10'!
cleanseStepList
	"Remove morphs from the step list that are not in this World.  Often were in a flap that has moved on to another world."

	worldState cleanseStepListForWorld: self! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 6/7/2000 10:12'!
runLocalStepMethods

	worldState runLocalStepMethodsIn: self
! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 10:27'!
runStepMethods

	worldState runStepMethodsIn: self
! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:39'!
startStepping: aMorph
	"Add the given morph to the step list. Do nothing if it is already being stepped."
	^self startStepping: aMorph at: Time millisecondClockValue selector: #stepAt: arguments: nil stepTime: nil! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:36'!
startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
	worldState startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 11:08'!
stopStepping: aMorph
	"Remove the given morph from the step list."

	worldState stopStepping: aMorph
! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:40'!
stopStepping: aMorph selector: aSelector
	"Remove the given morph from the step list."

	worldState stopStepping: aMorph selector: aSelector
! !


!PasteUpMorph methodsFor: 'stepping and presenter' stamp: 'RAA 8/14/2000 11:50'!
step

	(self isWorldMorph and: [owner notNil]) ifTrue: [
		^self runLocalStepMethods
	].
	super step! !


!PasteUpMorph methodsFor: 'structure' stamp: 'di 7/27/1999 10:46'!
activeHand

	^ worldState ifNotNil: [worldState activeHand] ifNil: [super activeHand]! !

!PasteUpMorph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:12'!
world
	worldState isNil ifTrue: [^super world].
	^self! !


!PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'RAA 5/24/2000 12:09'!
allMorphsDo: aBlock
	"Enumerate all morphs in the world, including those held in hands."

	super allMorphsDo: aBlock.
	self isWorldMorph
		ifTrue: [worldState handsReverseDo: [:h | h allMorphsDo: aBlock]].
! !

!PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'nk 7/4/2003 16:49'!
morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
	"Include hands if the receiver is the World"
	self handsDo:[:m|
		m == someMorph ifTrue:["Try getting out quickly"
			owner ifNil:[^self].
			^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock].
		"The hand only overlaps if it's not the hardware cursor"
		m needsToBeDrawn ifTrue:[
			(m fullBoundsInWorld intersects: aRectangle)
				ifTrue:[aBlock value: m]]].
	^super morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock! !


!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'di 7/15/1999 09:51'!
addAllMorphs: array

	super addAllMorphs: array.
	self isWorldMorph
		ifTrue: [array do: [:m | self startSteppingSubmorphsOf: m]].
! !

!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/16/2000 18:37'!
addMorphFront: aMorph

	^self addMorphInFrontOfLayer: aMorph
! !


!PasteUpMorph methodsFor: 'testing' stamp: 'wiz 2/25/2006 00:09'!
isEasySelecting
"This is to isolate easySelection predicate. 
Selectors in holders make no sense so we are limiting easy selection to the worldMorph.
It would also make sense in playfield so feel free to adjust this predicate.  Selection can always be forced by using the shift before mouse down."

^ self isWorldMorph and: [  Preferences easySelection ]! !

!PasteUpMorph methodsFor: 'testing' stamp: 'RAA 8/14/2000 11:50'!
stepTime

	(self isWorldMorph and: [owner notNil]) ifTrue: [
		^1
	].
	^super stepTime! !


!PasteUpMorph methodsFor: 'undo' stamp: 'RAA 9/21/2000 20:07'!
clearCommandHistory

	worldState ifNotNil: [worldState clearCommandHistory]! !

!PasteUpMorph methodsFor: 'undo' stamp: 'ar 8/31/2000 23:16'!
commandHistory
	"Return the command history for the receiver"
	^self isWorldMorph
		ifTrue:[worldState commandHistory]
		ifFalse:[super commandHistory]! !

!PasteUpMorph methodsFor: 'undo' stamp: 'sw 2/2/2006 02:30'!
onceAgainDismiss: aMorph
	"Occasioned by a redo of a dismiss-via-halo"

	aMorph dismissMorph.
	Preferences preserveTrash ifTrue: 
		[Preferences slideDismissalsToTrash
			ifTrue:[aMorph slideToTrash: nil]
			ifFalse:[TrashCanMorph moveToTrash: aMorph]]
! !

!PasteUpMorph methodsFor: 'undo' stamp: 'sw 2/2/2006 02:37'!
reintroduceIntoWorld: aMorph
	"The given morph is being raised from the dead.  Bring it back to life."

	(aMorph valueOfProperty: #lastPosition) ifNotNilDo:
		[:pos | aMorph position: pos].
	aMorph openInWorld; goHome

	! !


!PasteUpMorph methodsFor: 'update cycle' stamp: 'di 7/15/1999 09:51'!
startBackgroundProcess
	"Start a process to update this world in the background. Return the process created."

	| p |
	p _ [[true] whileTrue: [
		self doOneCycleInBackground.
		(Delay forMilliseconds: 20) wait]] newProcess.
	p resume.
	^ p
! !


!PasteUpMorph methodsFor: 'user interface' stamp: 'dgd 2/22/2003 14:11'!
modelWakeUp
	"I am the model of a SystemWindow, that has just been activated"

	| aWindow |
	owner isNil ifTrue: [^self].	"Not in Morphic world"
	(owner isKindOf: TransformMorph) ifTrue: [^self viewBox: self fullBounds].
	(aWindow := self containingWindow) ifNotNil: 
			[self viewBox = aWindow panelRect 
				ifFalse: [self viewBox: aWindow panelRect]]! !


!PasteUpMorph methodsFor: 'viewer' stamp: 'sw 1/25/2000 13:34'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ self isWorldMorph
		ifFalse:
			[super defaultNameStemForInstances]
		ifTrue:
			['world']! !


!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/9/2000 13:49'!
imposeListViewSortingBy: sortOrderSymbol retrieving: fieldListSelectors
	"Establish a list view of the receiver's contents, sorting the contents by the criterion represented by sortOrderSymbol, and displaying readouts as indicated by the list of field selectors."
	| rep |

	self setProperty: #sortOrder toValue: sortOrderSymbol.
	self setProperty: #fieldListSelectors toValue: fieldListSelectors.

	self showingListView ifFalse:
		[self autoLineLayout ifFalse: [self saveBoundsOfSubmorphs].
		self setProperty: #showingListView toValue: true.
		self layoutPolicy: TableLayout new.
		self layoutInset: 2; cellInset: 2.
		self listDirection: #topToBottom.
		self wrapDirection: #none].

	self submorphs "important that it be a copy" do:
		[:aMorph | 
			rep _ aMorph listViewLineForFieldList: fieldListSelectors.
			rep hResizing: #spaceFill.
			self replaceSubmorph: aMorph by: rep].

	self sortSubmorphsBy: (self valueOfProperty: #sortOrder).! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/5/2000 06:42'!
restoreBoundsOfSubmorphs
	"restores the saved xy-positions and extents"

	submorphs do:
		[:aSubmorph |
			aSubmorph valueOfProperty: #savedExtent ifPresentDo:
				[:anExtent | aSubmorph extent: anExtent].
			aSubmorph valueOfProperty: #savedPosition ifPresentDo:
				[:aPosition | aSubmorph position: aPosition]]! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/18/2000 10:59'!
saveBoundsOfSubmorphs
	"store the current xy-positions and extents of submorphs for future use"

	submorphs do:
		[:aSubmorph |
			aSubmorph setProperty: #savedExtent toValue: aSubmorph extent.
			aSubmorph setProperty: #savedPosition toValue: aSubmorph position]! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 7/20/2002 12:52'!
scriptSelectorToTriggerFor: aButtonMorph
	"Answer a new selector which will bear the code for aButtonMorph in the receiver"

	| buttonName selectorName |
	buttonName _ aButtonMorph externalName.
	selectorName _ self assuredPlayer acceptableScriptNameFrom: buttonName  forScriptCurrentlyNamed: nil.

	buttonName ~= selectorName ifTrue:
		[aButtonMorph setNameTo: selectorName].
	^ selectorName! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/23/2000 19:01'!
showingListView
	"Answer whether the receiver is currently showing a list view"

	^ self hasProperty: #showingListView
! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/12/2000 22:37'!
sortSubmorphsBy: sortOrderSymbol
	"Sort the receiver's submorphs by the criterion indicated in the provided symbol"
	self invalidRect: self fullBounds.
	submorphs _ submorphs sortBy:[:a :b | (a perform: sortOrderSymbol) <= (b perform: sortOrderSymbol)].
	self layoutChanged.! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/9/2000 13:50'!
viewByIcon
	"The receiver has been being viewed in some constrained layout view; now restore it to its normal x-y-layout view"

	|  oldSubs |
	self showingListView
		ifTrue:
			[oldSubs _ submorphs.
			self removeAllMorphs.
			self layoutPolicy: nil.
			oldSubs do:
				[:aSubmorph |
					self addMorphBack:  aSubmorph objectRepresented].
			self restoreBoundsOfSubmorphs.
			self removeProperty: #showingListView]
		ifFalse:
			[self autoLineLayout == true ifTrue: [self toggleAutoLineLayout]]! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/31/2000 09:29'!
viewByName
	"Make the receiver show its subparts as a vertical list of lines of information, sorted by object name"

	self imposeListViewSortingBy: #downshiftedNameOfObjectRepresented retrieving: #(nameOfObjectRepresented reportableSize  className oopString)! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/31/2000 07:08'!
viewBySize
	"Make the receiver show its subparts as a vertical list of lines of information, sorted by object size"

	self imposeListViewSortingBy: #reportableSize retrieving: #(externalName reportableSize className oopString)! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:50'!
viewingByIconString
	"Answer a string to show in a menu representing whether the 
	receiver is currently viewing its subparts by icon or not"
	^ ((self showingListView
			or: [self autoLineLayout == true])
		ifTrue: ['<no>']
		ifFalse: ['<yes>']), 'view by icon' translated! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:50'!
viewingByNameString
	"Answer a string to show in a menu representing whether the 
	receiver is currently viewing its subparts by name or not"
	^ ((self showingListView
			and: [(self
					valueOfProperty: #sortOrder
					ifAbsent: [])
					== #downshiftedNameOfObjectRepresented])
		ifTrue: ['<yes>']
		ifFalse: ['<no>']), 'view by name' translated! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:50'!
viewingBySizeString
	"Answer a string to show in a menu representing whether the 
	receiver is currently viewing its subparts by size or not"
	^ ((self showingListView
			and: [(self
					valueOfProperty: #sortOrder
					ifAbsent: [])
					== #reportableSize])
		ifTrue: ['<yes>']
		ifFalse: ['<no>']), 'view by size' translated! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:51'!
viewingNonOverlappingString
	"Answer a string to show in a menu representing whether the 
	receiver is currently viewing its subparts by 
	non-overlapping-icon (aka auto-line-layout)"
	^ ((self showingListView
			or: [self autoLineLayout ~~ true])
		ifTrue: ['<no>']
		ifFalse: ['<yes>']), 'view with line layout' translated! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/8/2000 18:13'!
viewingNormally
	"Answer whether the receiver is being viewed normally, viz not in list-view or auto-line-layout"

	^ (self showingListView or: [self autoLineLayout == true]) not
! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/8/2000 22:37'!
viewNonOverlapping
	"Make the receiver show its contents as full-size morphs laid out left-to-right and top-to-bottom to be non-overlapping."

	self viewingNormally ifTrue:
		[self saveBoundsOfSubmorphs].
	self showingListView ifTrue:
		[self viewByIcon.
		self removeProperty: #showingListView].
	self autoLineLayout: true.! !


!PasteUpMorph methodsFor: 'visual properties' stamp: 'bf 5/4/2000 15:27'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^ true! !


!PasteUpMorph methodsFor: 'WiW support' stamp: 'dgd 8/31/2004 16:25'!
addMorphInLayer: aMorph
	super addMorphInLayer: aMorph.
	aMorph wantsToBeTopmost ifFalse:[self bringTopmostsToFront].! !

!PasteUpMorph methodsFor: 'WiW support' stamp: 'RAA 10/3/2000 09:24'!
morphicLayerNumber

	self isFlap ifTrue:[^26]. 	"As navigators"
	^super morphicLayerNumber.! !

!PasteUpMorph methodsFor: 'WiW support' stamp: 'dao 10/1/2004 13:39'!
restartWorldCycleWithEvent: evt

	"RAA 27 Nov 99 - redispatch that click picked up from our inner world"
	evt ifNotNil: [
		self primaryHand handleEvent: (evt setHand: self primaryHand).
	].
	Project spawnNewProcessAndTerminateOld: true
! !

!PasteUpMorph methodsFor: 'WiW support' stamp: 'RAA 8/14/2000 12:10'!
shouldGetStepsFrom: aWorld

	(self isWorldMorph and: [owner notNil]) ifTrue: [
		^self outermostWorldMorph == aWorld
	].
	^super shouldGetStepsFrom: aWorld! !

!PasteUpMorph methodsFor: 'WiW support' stamp: 'RAA 11/14/1999 15:07'!
validateMouseEvent: evt

	! !


!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 8/12/2001 17:47'!
activateObjectsTool
	"Offer the user a parts bin of morphs -- if one already exists, bring it to the front and flash its border beckoningly; if none exists yet, create a new one and place it in the center of the screen"

	| anObjectTool |
	submorphs do:
		[:aMorph | (aMorph renderedMorph isKindOf: ObjectsTool)
			ifTrue:
				[aMorph comeToFront.
				aMorph flash.
				^ self]].
	"None found, so create one"

	anObjectTool _ ObjectsTool newStandAlone.
	self addMorphFront: anObjectTool.
	anObjectTool fullBounds.
	anObjectTool center: self center

	"ActiveWorld activateObjectsTool"! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 18:34'!
addUndoItemsTo: aWorldMenu
	"Add undo-related items to the given menu.  Will add zero, one or two items, depending on the settings of the #useUndo and #infiniteUndo preferences"

	Preferences useUndo ifFalse: [^ self].
	Preferences infiniteUndo
		ifFalse:
			[aWorldMenu addUpdating: #undoOrRedoMenuWording target: self commandHistory action: #undoOrRedoCommand]
		ifTrue:
			[aWorldMenu addUpdating: #undoMenuWording target: self commandHistory  action: #undoLastCommand.
			aWorldMenu addUpdating: #redoMenuWording target: self commandHistory action: #redoNextCommand.
			self flag: #deferred.  "The following feature to be unblocked in due course"
			"aWorldMenu add: 'undo to...' target: self commandHistory action: #undoTo"].
	aWorldMenu addLine! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 6/6/2004 13:16'!
attemptCleanup
	"Try to fix up some bad things that are known to occur in some etoy projects we've seen.  This is a bare beginning, but a useful place to tack on further cleanups, which then can be invoked whenever the attempt-cleanup item invoked from the debug menu"

	self attemptCleanupReporting: true

"
ActiveWorld attemptCleanup
"! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'yo 3/15/2005 13:36'!
attemptCleanupReporting: whetherToReport
	"Try to fix up some bad things that are known to occur in some etoy projects we've seen. If the whetherToReport parameter is true, an informer is presented after the cleanups"

	| fixes |
	fixes _ 0.
	ActiveWorld ifNotNil:
		[(ActiveWorld submorphs select:
			[:m | (m isKindOf: ScriptEditorMorph) and: [m submorphs isEmpty]]) do:
				[:m | m delete.  fixes _ fixes + 1]].

	TransformationMorph allSubInstancesDo:
		[:m | (m player notNil and: [m renderedMorph ~~ m])
			ifTrue:
				[m renderedMorph visible ifFalse:
					[m renderedMorph visible: true.  fixes _ fixes + 1]]].

	(Player class allSubInstances select: [:cl | cl isUniClass]) do:
		[:aUniclass |
			fixes _ fixes + aUniclass cleanseScripts].

	self presenter flushPlayerListCache; allExtantPlayers.
	whetherToReport ifTrue:
		[self inform: ('{1} [or more] repair(s) made' translated format: {fixes printString})]

"
ActiveWorld attemptCleanupReporting: true.
ActiveWorld attemptCleanupReporting: false.
"! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/30/2001 20:37'!
bringWindowsFullOnscreen
	"Make ever SystemWindow on the desktop be totally on-screen, whenever possible."
	
	(SystemWindow windowsIn: self satisfying: [:w | true]) do:
		[:aWindow | 
			aWindow right: (aWindow right min: bounds right).
			aWindow bottom: (aWindow bottom min: bounds bottom).
			aWindow left: (aWindow left max: bounds left).
			aWindow top: (aWindow top max: bounds top)]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 6/4/2004 15:00'!
browseAllScriptsTextually
	"Put up a browser showing all scripts in the project textually"

	self presenter browseAllScriptsTextually

"ActiveWorld browseAllScriptsTextually"! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 18:27'!
buildWorldMenu: evt
	^(TheWorldMenu new
		world: self
		project: (self project ifNil: [Project current])       "mvc??"
		hand: evt hand) buildWorldMenu.! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/21/2003 17:39'!
closeUnchangedWindows
	"Present a menu of window titles for all windows with changes,
	and activate the one that gets chosen."
	(SelectionMenu confirm:
'Do you really want to close all windows
except those with unaccepted edits?' translated)
		ifFalse: [^ self].

	(SystemWindow windowsIn: self satisfying: [:w | w model canDiscardEdits])
		do: [:w | w delete]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:27'!
collapseAll
	"Collapse all windows"
	(SystemWindow windowsIn: self satisfying: [:w | w isCollapsed not])
		reverseDo: [:w | w collapseOrExpand.  self displayWorld].
	self collapseNonWindows! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:27'!
collapseNonWindows
	self allNonFlapRelatedSubmorphs do:
		[:m | m collapse]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:52'!
commandKeySelectors
	"Answer my command-key table"

	| aDict |
	aDict _ self valueOfProperty: #commandKeySelectors ifAbsentPut: [self initializeDesktopCommandKeySelectors].
	^ aDict! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:03'!
connectRemoteUser
	
	^self
		connectRemoteUserWithName: nil 
		picture: nil 
		andIPAddress: nil
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'mir 11/14/2002 17:37'!
connectRemoteUserWithName: nameStringOrNil picture: aFormOrNil andIPAddress: aStringOrNil
	"Prompt for the initials to be used to identify the cursor of a remote user, then create a cursor for that user and wait for a connection."

	| initials addr h |
	initials _ nameStringOrNil.
	initials isEmptyOrNil ifTrue: [
		initials _ FillInTheBlank request: 'Enter initials for remote user''s cursor?'.
	].
	initials isEmpty ifTrue: [^ self].  "abort"
	addr _ 0.
	aStringOrNil isEmptyOrNil ifFalse: [
		addr _ NetNameResolver addressForName: aStringOrNil timeout: 30
	].
	addr = 0 ifTrue: [
		addr _ NetNameResolver promptUserForHostAddress.
	].
	addr = 0 ifTrue: [^ self].  "abort"

	RemoteHandMorph ensureNetworkConnected.
	h _ RemoteHandMorph new userInitials: initials andPicture: aFormOrNil.
	self addHand: h.
	h changed.
	h startListening.
	h startTransmittingEventsTo: addr.
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/11/2004 20:45'!
delayedInvokeWorldMenu: evt 
	self
		addAlarm: #invokeWorldMenu:
		with: evt
		after: 200! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/21/2003 17:40'!
deleteNonWindows
	(SelectionMenu confirm:
'Do you really want to discard all objects
that are not in windows?' translated)
		ifFalse: [^ self].

	self allNonFlapRelatedSubmorphs do:
		[:m | m delete]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:29'!
detachableScriptingSpace
	ScriptingSystem newScriptingSpace openInWorld: self! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:07'!
disconnectAllRemoteUsers
	"Disconnect all remote hands and stop transmitting events."
	self world handsDo: [:h |
		(h isKindOf: RemoteHandMorph) 
			ifTrue: [h withdrawFromWorld]].! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:09'!
disconnectRemoteUser
	"Prompt for the initials of the remote user, then remove the remote hand with those initials, breaking its connection."

	"select hand to remove"
	| initials handToRemove |
	initials _ FillInTheBlank request: 'Enter initials for remote user''s cursor?'.
	initials isEmpty ifTrue: [^ self].  "abort"
	handToRemove _ nil.
	self handsDo: [:h |
		h userInitials = initials ifTrue: [handToRemove _ h]].
	handToRemove ifNil: [^ self].  "no hand with those initials"
	handToRemove withdrawFromWorld.
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 12:19'!
dispatchCommandKeyInWorld: aChar event: evt
	"Dispatch the desktop command key if possible.  Answer whether handled"

	| aMessageSend |
	aMessageSend _ self commandKeySelectors at: aChar ifAbsent: [^ false].
	aMessageSend selector numArgs = 0
		ifTrue:
			[aMessageSend value]
		ifFalse:
			[aMessageSend valueWithArguments: (Array with: evt)].
	^ true
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 19:11'!
drawingClass

	^ SketchMorph! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:33'!
expandAll
	"Expand all windows"
	(SystemWindow windowsIn: self satisfying: [:w | w isCollapsed])
		reverseDo: [:w | w collapseOrExpand.  self displayWorld]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'nk 1/6/2004 12:38'!
extractScreenRegion: poly andPutSketchInHand: hand
	"The user has specified a polygonal area of the Display.
	Now capture the pixels from that region, and put in the hand as a Sketch."
	| screenForm outline topLeft innerForm exterior |
	outline _ poly shadowForm.
	topLeft _ outline offset.
	exterior _ (outline offset: 0@0) anyShapeFill reverse.
	screenForm _ Form fromDisplay: (topLeft extent: outline extent).
	screenForm eraseShape: exterior.
	innerForm _ screenForm trimBordersOfColor: Color transparent.
	innerForm isAllWhite ifFalse:
		[hand attachMorph: (self drawingClass withForm: innerForm)]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 13:47'!
findAChangeSorter: evt
	"Locate a change sorter, open it, and bring it to the front.  Create one if necessary"

	self findAWindowSatisfying:
		[:aWindow | (aWindow model isMemberOf: ChangeSorter) or:
				[aWindow model isKindOf: DualChangeSorter]] orMakeOneUsing: [DualChangeSorter new morphicWindow]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'md 2/24/2006 15:20'!
findAFileList: evt 
	"Locate a file list, open it, and bring it to the front.
	Create one if necessary, respecting the Preference."

	self
		findAWindowSatisfying: [:aWindow | aWindow model isKindOf: FileList]
		orMakeOneUsing: [FileList2 prototypicalToolWindow]
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 13:53'!
findAMessageNamesWindow: evt
	"Locate a MessageNames tool, open it, and bring it to the front.  Create one if necessary"

	self findAWindowSatisfying:
		[:aWindow | aWindow model isKindOf: MessageNames] orMakeOneUsing: [MessageNames new inMorphicWindowLabeled: 'Message Names']! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 16:19'!
findAPreferencesPanel: evt
	"Locate a Preferences Panel, open it, and bring it to the front.  Create one if necessary"

	| aPanel |
	self findAWindowSatisfying:
		[:aWindow | aWindow model isKindOf: PreferencesPanel] orMakeOneUsing:
			[aPanel _ Preferences preferencesControlPanel.
			"Note -- we don't really want the openInHand -- but owing to some annoying
			difficulty, if we don't, we get the wrong width.  Somebody please clean this up"
			^ aPanel openInHand]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/22/2002 08:54'!
findATranscript: evt
	"Locate a transcript, open it, and bring it to the front.  Create one if necessary"

	self findAWindowSatisfying:
		[:aWindow | aWindow model == Transcript] orMakeOneUsing: [Transcript openAsMorphLabel: 'Transcript']! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'gm 2/16/2003 20:35'!
findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock 
	"Locate a window satisfying a block, open it, and bring it to the front.  Create one if necessary, by using the makeBlock"

	| aWindow |
	submorphs do: 
			[:aMorph | 
			(((aWindow := aMorph renderedMorph) isSystemWindow) 
				and: [qualifyingBlock value: aWindow]) 
					ifTrue: 
						[aWindow isCollapsed ifTrue: [aWindow expand].
						aWindow activateAndForceLabelToShow.
						^self]].
	"None found, so create one"
	makeBlock value openInWorld! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 2/22/2003 14:10'!
findDirtyBrowsers: evt 
	"Present a menu of window titles for browsers with changes,
	and activate the one that gets chosen."

	| menu |
	menu := MenuMorph new.
	(SystemWindow windowsIn: self
		satisfying: [:w | (w model isKindOf: Browser) and: [w model canDiscardEdits not]]) 
			do: 
				[:w | 
				menu 
					add: w label
					target: w
					action: #activate].
	menu submorphs notEmpty ifTrue: [menu popUpEvent: evt in: self]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 2/22/2003 14:10'!
findDirtyWindows: evt 
	"Present a menu of window titles for all windows with changes,
	and activate the one that gets chosen."

	| menu |
	menu := MenuMorph new.
	(SystemWindow windowsIn: self
		satisfying: [:w | w model canDiscardEdits not]) do: 
				[:w | 
				menu 
					add: w label
					target: w
					action: #activate].
	menu submorphs notEmpty ifTrue: [menu popUpEvent: evt in: self]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sd 11/13/2003 21:25'!
findWindow: evt
	"Present a menu names of windows and naked morphs, and activate the one that gets chosen.  Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo."
	| menu expanded collapsed nakedMorphs |
	menu _ MenuMorph new.
	expanded _ SystemWindow windowsIn: self satisfying: [:w | w isCollapsed not].
	collapsed _ SystemWindow windowsIn: self satisfying: [:w | w isCollapsed].
	nakedMorphs _ self submorphsSatisfying:
		[:m | (m isSystemWindow not and: [(m isKindOf: StickySketchMorph) not]) and:
			[(m isFlapTab) not]].
	(expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty)) ifTrue: [^ Beeper beep].
	(expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do:
		[:w | menu add: w label target: w action: #activateAndForceLabelToShow.
			w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	(expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty)) ifFalse: [menu addLine].
	(collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: 
		[:w | menu add: w label target: w action: #collapseOrExpand.
		w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	nakedMorphs isEmpty ifFalse: [menu addLine].
	(nakedMorphs asSortedCollection: [:w1 :w2 | w1 nameForFindWindowFeature caseInsensitiveLessOrEqual: w2 nameForFindWindowFeature]) do:
		[:w | menu add: w nameForFindWindowFeature target: w action: #comeToFrontAndAddHalo].
	menu addTitle: 'find window' translated.
	
	menu popUpEvent: evt in: self.! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/28/2004 16:34'!
galleryOfPlayers
	"Put up a tool showing all the players in the project"
	
	(ActiveWorld findA: AllPlayersTool) ifNotNilDo: [:aTool | ^ aTool comeToFront].
	AllPlayersTool newStandAlone openInHand

"ActiveWorld galleryOfPlayers"! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 19:09'!
getWorldMenu: aSymbol
	^(TheWorldMenu new
		world: self
		project: (self project ifNil: [Project current])       "mvc??"
		hand: self primaryHand) perform: aSymbol! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 03:33'!
grabDrawingFromScreen: evt
	"Allow the user to specify a rectangular area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand."
	| m |
	m _ self drawingClass new form: Form fromUser.
	evt hand position: Sensor cursorPoint.  "update hand pos after Sensor loop in fromUser"
	evt hand attachMorph: m.! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'nk 1/6/2004 12:39'!
grabFloodFromScreen: evt
	"Allow the user to plant a flood seed on the Display, and create a new drawing morph from the resulting region. Attach the result to the hand."
	| screenForm exterior p1 box |
	Cursor crossHair showWhile: [p1 _ Sensor waitButton].
	box _ Display floodFill: Color transparent at: p1.
	exterior _ ((Display copy: box) makeBWForm: Color transparent) reverse.
	self world invalidRect: box; displayWorldSafely.
	(box area > (Display boundingBox area // 2))
		ifTrue: [^ PopUpMenu notify: 'Sorry, the region was too big'].
	(exterior deepCopy reverse anyShapeFill reverse)  "save interior bits"
		displayOn: exterior at: 0@0 rule: Form and.
	screenForm _ Form fromDisplay: box.
	screenForm eraseShape: exterior.
	screenForm isAllWhite ifFalse:
		[evt hand attachMorph: (self drawingClass withForm: screenForm)]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 02:58'!
grabLassoFromScreen: evt
	"Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand."

	self extractScreenRegion: (PolygonMorph fromHandFreehand: evt hand)
		andPutSketchInHand: evt hand
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 01:13'!
grabRubberBandFromScreen: evt
	"Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand."

	self extractScreenRegion: (PolygonMorph fromHand: evt hand)
		andPutSketchInHand: evt hand! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:52'!
initializeDesktopCommandKeySelectors
	"Provide the starting settings for desktop command key selectors.  Answer the dictionary."

	"ActiveWorld initializeDesktopCommandKeySelectors"
	| dict messageSend |
	dict _ IdentityDictionary new.
	self defaultDesktopCommandKeyTriplets do:
		[:trip |
			messageSend _ MessageSend receiver: trip second selector: trip third.
			dict at: trip first put: messageSend].
	self setProperty: #commandKeySelectors toValue: dict.
	^ dict

! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 4/30/2001 21:03'!
invokeWorldMenu: evt
	"Put up the world menu, triggered by the passed-in event.  But don't do it if the eToyFriendly preference is set to true."

	Preferences eToyFriendly ifFalse:
		[self putUpWorldMenu: evt]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 5/20/2003 15:04'!
keyboardNavigationHandler
	"Answer the receiver's existing keyboardNavigationHandler, or nil if none."

	| aHandler |
	aHandler _ self valueOfProperty: #keyboardNavigationHandler ifAbsent: [^ nil].
	(aHandler hasProperty: #moribund) ifTrue:  "got clobbered in another project"
		[self removeProperty: #keyboardNavigationHander.
		^ nil].
	^ aHandler! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/18/2003 23:10'!
keyboardNavigationHandler: aHandler
	"Set the receiver's keyboard navigation handler as indicated.  A nil argument means to remove the handler"

	aHandler
		ifNil:
			[self removeProperty: #keyboardNavigationHandler]
		ifNotNil:
			[self setProperty: #keyboardNavigationHandler toValue: aHandler]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'tak 1/26/2005 22:08'!
keystrokeInWorld: evt
	"A keystroke was hit when no keyboard focus was set, so it is sent here to the world instead."

	|  aChar isCmd ascii |
	aChar _ evt keyCharacter.
	(ascii _ aChar asciiValue) = 27 ifTrue: "escape key"
		[^ self putUpWorldMenuFromEscapeKey].
	(evt controlKeyPressed not
		and: [(#(1 4 8 28 29 30 31 32) includes: ascii)  "home, end, backspace, arrow keys, space"
			and: [self keyboardNavigationHandler notNil]])
				ifTrue: [self keyboardNavigationHandler navigateFromKeystroke: aChar].

	isCmd _ evt commandKeyPressed and: [Preferences cmdKeysInText].
	(evt commandKeyPressed and: [Preferences eToyFriendly])
			ifTrue:
				[(aChar == $W) ifTrue: [^ self putUpWorldMenu: evt]].
	(isCmd and: [Preferences honorDesktopCmdKeys]) ifTrue:
		[^ self dispatchCommandKeyInWorld: aChar event: evt].

	"It was unhandled. Remember the keystroke."
	self lastKeystroke: evt keyString.
	self triggerEvent: #keyStroke! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 2/8/2001 19:26'!
makeNewDrawing: evt
	^self makeNewDrawing: evt at: evt position! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 12/12/2001 11:36'!
makeNewDrawing: evt at: aPoint
	"make a new drawing, triggered by the given event, with the painting area centered around the given point"

	| w newSketch newPlayer sketchEditor aPaintBox aPalette tfx whereToPresent rect ownerBeforeHack aPaintTab aWorld |
	w _ self world.
	w assureNotPaintingElse: [^ self].
	rect _ self paintingBoundsAround: aPoint.
	aPalette _ self standardPalette.
	aPalette ifNotNil: [aPalette showNoPalette; layoutChanged].
	w prepareToPaint.

	newSketch _ self drawingClass new player: (newPlayer _ UnscriptedPlayer newUserInstance).
	newPlayer costume: newSketch.
	newSketch nominalForm: (Form extent: rect extent depth: w assuredCanvas depth).
	newSketch bounds: rect.
	sketchEditor _ SketchEditorMorph new.
	w addMorphFront: sketchEditor.
	sketchEditor initializeFor: newSketch inBounds: rect pasteUpMorph: self.
	sketchEditor
		afterNewPicDo: [:aForm :aRect |
			whereToPresent _ self presenter.
			newSketch form: aForm.
			tfx _ self transformFrom: w.
			newSketch position: (tfx globalPointToLocal: aRect origin).
			newSketch rotationStyle: sketchEditor rotationStyle.
			newSketch forwardDirection: sketchEditor forwardDirection.

			ownerBeforeHack _ newSketch owner.	"about to break the invariant!!!!"
			newSketch privateOwner: self. "temp for halo access"
			newPlayer setHeading: sketchEditor forwardDirection.
			(aPaintTab _ (aWorld _ self world) paintingFlapTab)
				ifNotNil:[aPaintTab hideFlap]
				ifNil:[(aPaintBox _ aWorld paintBox) ifNotNil:[aPaintBox delete]].

			"Includes  newSketch rotationDegrees: sketchEditor forwardDirection."
			newSketch privateOwner: ownerBeforeHack. "probably nil, but let's be certain"

			self addMorphFront: newPlayer costume.
			w startSteppingSubmorphsOf: newSketch.
			whereToPresent drawingJustCompleted: newSketch]
		 ifNoBits:[
			(aPaintTab _ (aWorld _ self world) paintingFlapTab)
				ifNotNil:[aPaintTab hideFlap]
				ifNil:[(aPaintBox _ aWorld paintBox) ifNotNil:[aPaintBox delete]].
			aPalette ifNotNil: [aPalette showNoPalette].]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:40'!
newDrawingFromMenu: evt
	self assureNotPaintingElse: [^ self].
	evt hand attachMorph: PaintInvokingMorph new markAsPartsDonor! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 14:01'!
openRecentSubmissionsBrowser: evt
	"Locate a recent-submissions browser, open it, and bring it to the front.  Create one if necessary.  Only works in morphic"

	self findAWindowSatisfying:
		[:aWindow | aWindow model isKindOf: RecentMessageSet] orMakeOneUsing: [Utilities recentSubmissionsWindow]
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 2/7/2001 20:10'!
openScrapsBook: evt
	"Open up the Scraps book in the center of the screen"

	evt hand world addMorphCentered: Utilities scrapsBook! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/12/2001 20:02'!
printScriptSummary
	"Put up a window with summaries of all scripts in the world"

	self presenter reportPlayersAndScripts

"self currentWorld printScriptSummary"! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 11:51'!
putUpNewMorphMenu
	"Put up the New Morph menu in the world"

	TheWorldMenu new adaptToWorld: self; newMorph! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/20/2004 20:17'!
putUpWorldMenuFromEscapeKey
	Preferences noviceMode
		ifFalse: [self putUpWorldMenu: ActiveEvent]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 8/31/2004 16:25'!
putUpWorldMenu: evt
	"Put up a menu in response to a click on the desktop, triggered by evt."

	| menu |
	self bringTopmostsToFront.
	evt isMouse ifTrue:
		[evt yellowButtonPressed
			ifTrue: [^ self yellowButtonClickOnDesktopWithEvent: evt].
		evt shiftPressed ifTrue:[^ self findWindow: evt]].
	"put up screen menu"
	menu _ self buildWorldMenu: evt.
	menu addTitle: Preferences desktopMenuTitle translated.
	menu popUpEvent: evt in: self.
	^ menu! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 5/3/2001 20:56'!
removeAllViewers
	"Delete all the viewers lined up along my right margin."

	(self submorphs select: [:m | m isKindOf: ViewerFlapTab]) do:
		[:m |
			m referent ifNotNil: [m referent delete].
			m delete.]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:40'!
reportLocalAddress
	"Report the local host address of this computer."

	| addrString m s |
	Socket initializeNetwork.
	addrString _ NetNameResolver localAddressString.
	m _ RectangleMorph new
		color: (Color r: 0.6 g: 0.8 b: 0.6);
		extent: 118@36;
		borderWidth: 1.
	s _ StringMorph contents: 'Local Host Address:'.
	s position: m position + (5@4).
	m addMorph: s.
	s _ StringMorph contents: addrString.
	s position: m position + (5@19).
	m addMorph: s.
	self primaryHand attachMorph: m.
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:56'!
respondToCommand: aCharacter bySending: aSelector to: aReceiver
	"Respond to the command-key use of the given character by sending the given selector to the given receiver.  If the selector is nil, retract any prior such setting"

	aSelector
		ifNil:
			[self commandKeySelectors removeKey: aCharacter]
		ifNotNil:
			[self commandKeySelectors at: aCharacter put: (MessageSend receiver: aReceiver selector: aSelector)]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/14/2001 03:04'!
showStatusOfAllScripts
	"Put up a window that shows, and allows you to change, the status of all scripts"

	self presenter toolToViewScriptInstantiations! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 11:58'!
toggleClassicNavigatorIfAppropriate
	"If appropriate, toggle the presence of classic navigator"

	Preferences classicNavigatorEnabled ifTrue: [^ Preferences togglePreference: #showProjectNavigator]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 12:25'!
undoOrRedoCommand
	"Undo or redo the last command recorded in the world"

	^ self commandHistory undoOrRedoCommand! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/19/2003 11:22'!
yellowButtonClickOnDesktopWithEvent: evt 
	"Put up either the personalized menu or the world menu when 
	the user clicks on the morphic desktop with the yellow button. 
	The preference 'personalizedWorldMenu' governs which one 
	is used"
	| aMenu |
	Preferences personalizedWorldMenu
		ifTrue: [aMenu := MenuMorph new defaultTarget: self.
			Preferences personalizeUserMenu: aMenu.
			aMenu addLine.
			aMenu
				add: 'personalize...' translated
				target: Preferences
				action: #letUserPersonalizeMenu]
		ifFalse: [aMenu := self buildWorldMenu: evt.
			aMenu addTitle: 'World' translated].
	aMenu popUpEvent: evt in: self! !


!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 19:25'!
abandonAllHalos
	self flag: #arNote. "Remove the method"
	^self deleteAllHalos! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 7/10/2005 03:55'!
abandonVocabularyPreference
	"Remove any memory of a preferred vocabulary in the project"

	| standardViewers aVocabulary |
	self removeProperty: #currentVocabularySymbol.

	standardViewers _ (self submorphsSatisfying: [:m | m isKindOf: ViewerFlapTab]) collect:
		[:m | m referent firstSubmorph].
	aVocabulary _ Vocabulary vocabularyNamed: #eToy.
	standardViewers do:
		[:m | ((m valueOfProperty: #currentVocabularySymbol ifAbsent: [nil]) == #Vector) ifTrue:
			[m switchToVocabulary: aVocabulary]]

"ActiveWorld abandonVocabularyPreference"! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 22:29'!
activeHand: aHandMorph
	"temporarily retained for old main event loops"

	worldState activeHand: aHandMorph.

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 10/26/2000 14:52'!
addHand: aHandMorph
	"Add the given hand to the list of hands for this world."

	aHandMorph owner ifNotNil:[aHandMorph owner removeHand: aHandMorph].
	worldState addHand: aHandMorph.
	aHandMorph privateOwner: self.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:09'!
addMorphsAndModel: aMorphOrList 
	"Dump in submorphs, model, and stepList from aMorphOrList.  Used to bring a world, paste-up, or other morph in from an object file."

	aMorphOrList isMorph 
		ifTrue: 
			[aMorphOrList isWorldMorph 
				ifFalse: 
					["one morph, put on hand"

					"aMorphOrList installModelIn: self.  	a chance to install model pointers"

					aMorphOrList privateOwner: nil.
					self firstHand attachMorph: aMorphOrList.
					self startSteppingSubmorphsOf: aMorphOrList]
				ifTrue: 
					[model isNil 
						ifTrue: [self setModel: aMorphOrList modelOrNil]
						ifFalse: 
							[aMorphOrList modelOrNil ifNotNil: 
									[aMorphOrList modelOrNil privateOwner: nil.
									self addMorph: aMorphOrList modelOrNil]].
					aMorphOrList privateSubmorphs reverseDo: 
							[:m | 
							m privateOwner: nil.
							self addMorph: m.
							m changed].
					(aMorphOrList instVarNamed: 'stepList') 
						do: [:entry | entry first startSteppingIn: self]]]
		ifFalse: 
			["list, add them all"

			aMorphOrList reverseDo: 
					[:m | 
					m privateOwner: nil.
					self addMorph: m.
					self startSteppingSubmorphsOf: m.	"It may not want this!!"
					m changed]]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
addMorph: aMorph centeredNear: aPoint
	"Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world."

	| trialRect delta |
	trialRect _ Rectangle center: aPoint extent: aMorph fullBounds extent.
	delta _ trialRect amountToTranslateWithin: bounds.
	aMorph position: trialRect origin + delta.
	self addMorph: aMorph.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 8/31/2004 16:23'!
allNonFlapRelatedSubmorphs
	"Answer all non-window submorphs that are not flap-related"

	^submorphs 
		select: [:m | (m isSystemWindow) not and: [m wantsToBeTopmost not]]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 10:45'!
assuredCanvas
	
	^worldState assuredCanvas! !

!PasteUpMorph methodsFor: 'world state' stamp: 'tak 3/15/2005 17:31'!
assureNotPaintingElse: aBlock
	"If painting is already underway in the receiver, put up an informer to that effect and evalute aBlock"
	self removeModalWindow.
	self sketchEditorOrNil ifNotNil:
		[self inform: 'Sorry, you can only paint
one object at a time' translated.
		Cursor normal show.
		^ aBlock value]
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 12/18/2000 01:16'!
assureNotPaintingEvent: evt
	"If painting is already underway
	in the receiver, put up an informer to that effect and evalute aBlock"
	| editor |
	(editor _ self sketchEditorOrNil) ifNotNil:[
		editor save: evt.
		Cursor normal show.
	].! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/19/2000 07:44'!
beWorldForProject: aProject

	self privateOwner: nil.
	worldState _ WorldState new.
	self addHand: HandMorph new.
	self setProperty: #automaticPhraseExpansion toValue: true.
	self setProperty: #optimumExtentFromAuthor toValue: Display extent.
	self startSteppingSubmorphsOf: self! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/17/2001 23:57'!
checkCurrentHandForObjectToPaste

	| response |
	self primaryHand pasteBuffer ifNil: [^self].
	response _ (PopUpMenu labels: 'Delete\Keep' withCRs)
		startUpWithCaption: 'Hand is holding a Morph in its paste buffer:\' withCRs,
			self primaryHand pasteBuffer printString.
	response = 1 ifTrue: [self primaryHand pasteBuffer: nil].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/17/2001 23:57'!
checkCurrentHandForObjectToPaste2

	self primaryHand pasteBuffer ifNil: [^self].
	self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs,
		self primaryHand pasteBuffer printString.

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'bf 1/5/2000 19:25'!
chooseClickTarget
	Cursor crossHair showWhile:
		[Sensor waitButton].
	Cursor down showWhile:
		[Sensor anyButtonPressed].
	^ (self morphsAt: Sensor cursorPoint) first! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
colorAt: aPoint belowMorph: aMorph
	"Return the color of the pixel immediately behind the given morph at the given point.
	NOTE: due to some bounds wobble in flexing, we take the middle of 3x3 rect."
	^ (self patchAt: (aPoint-1 extent: 3) without: aMorph andNothingAbove: true)
		colorAt: 1@1
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/15/2000 23:28'!
deEmphasizeViewMVC: asTwoTone
	self flag: #arNote. "Probably unnecessary"
	worldState handsDo:          "free dependents links if any"
		[:h | h releaseKeyboardFocus].
	worldState canvas: nil.		"free model's canvas to save space"
	self fullReleaseCachedState.
	asTwoTone ifTrue: [
		"draw deEmphasized as a two-tone (monochrome) form"
		self displayWorldAsTwoTone].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 9/9/2004 22:47'!
deleteAllHalos

	self haloMorphs
		do: [:each | (each target isKindOf: SelectionMorph)
				ifTrue: [each target delete]].
	self hands
		do: [:each | each removeHalo]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:43'!
displayWorld

	self outermostWorldMorph privateOuterDisplayWorld
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 13:20'!
displayWorldAsTwoTone
	"Display the world in living black-and-white. (This is typically done to save space.)"

	worldState displayWorldAsTwoTone: self submorphs: submorphs color: color
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:10'!
displayWorldNonIncrementally
	"Display the morph world non-incrementally. Used for testing."

	(worldState canvas isNil or: 
			[worldState canvas extent ~= self viewBox extent 
				or: [worldState canvas form depth ~= Display depth]]) 
		ifTrue: 
			["allocate a new offscreen canvas the size of the window"

			worldState 
				canvas: (Display defaultCanvasClass extent: self viewBox extent)].
	worldState canvas fillColor: color.
	submorphs reverseDo: [:m | worldState canvas fullDrawMorph: m].
	worldState handsReverseDo: [:h | worldState canvas fullDrawMorph: h].
	worldState canvas form displayOn: Display at: self viewBox origin.
	self fullRepaintNeeded.	"don't collect damage"
	Display forceDisplayUpdate! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 12:23'!
displayWorldSafely

	worldState displayWorldSafely: self.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ls 5/6/2003 16:51'!
doOneCycle
	"see the comment in doOneCycleFor:"

	worldState doOneCycleFor: self! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 10:14'!
doOneCycleInBackground
	
	worldState doOneCycleInBackground
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 11:59'!
doOneSubCycle
	"Like doOneCycle, but preserves activeHand."

	worldState doOneSubCycleFor: self! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 9/19/2000 22:17'!
dragThroughOnDesktop: evt
	"Draw out a selection rectangle"
	| selection |
	selection _ SelectionMorph newBounds: (evt cursorPoint extent: 8@8).
	self addMorph: selection.
	^ selection extendByHand: evt hand
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/11/2000 17:45'!
embeddedProjectDisplayMode

	"#naked - the embedded project/world is just a pasteup in the outer p/w
	#window - the embedded p/w is in a system window in the outer p/w
	#frame - the embedded p/w is in a green frame and clipped
	#scaled - the embedded p/w is in a green frame and scaled to fit"

	^#scaled
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 12/19/2000 19:23'!
endDrawing: evt
	"If painting is already underway
	in the receiver, finish and save it."
	| editor |
	(editor _ self sketchEditorOrNil) ifNotNil:[
		editor save: evt.
		Cursor normal show.
	].! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dao 10/1/2004 13:14'!
exit

	Project current exit
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 5/28/2000 12:10'!
flashRects: rectangleList color: aColor
	"For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work."
	"Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode."

	| blt screenRect |
	blt _ (BitBlt current toForm: Display)
		sourceForm: nil;
		sourceOrigin: 0@0;
		clipRect: self viewBox;
		combinationRule: Form reverse.
	rectangleList do: [:r |
		screenRect _ r translateBy: self viewBox origin.
		blt destRect: screenRect; copyBits.
		Display forceToScreen: screenRect; forceDisplayUpdate.
		(Delay forMilliseconds: 15) wait.
		blt destRect: screenRect; copyBits.
		Display forceToScreen: screenRect; forceDisplayUpdate].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:12'!
fullRepaintNeeded

	worldState doFullRepaint.
	SystemWindow windowsIn: self
		satisfying: [:w | w makeMeVisible. false].

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 11/27/1999 10:11'!
goBack

	Project returnToPreviousProject.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 18:00'!
haloMorphs
	^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/27/1999 10:46'!
handleFatalDrawingError: errMsg
	"Handle a fatal drawing error."
	Smalltalk isMorphic ifFalse:[^self error: errMsg]. "Can still handle it from MVC"
	Display deferUpdates: false. "Just in case"
	self primitiveError: errMsg.

	"Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 9/5/2004 16:19'!
initForProject: aWorldState

	worldState _ aWorldState.
	bounds _ Display boundingBox.
	self color: Preferences defaultWorldColor.
	self addHand: HandMorph new.
	self setProperty: #automaticPhraseExpansion toValue: true.
	self setProperty: #optimumExtentFromAuthor toValue: Display extent.
	self wantsMouseOverHalos: Preferences mouseOverHalos.
	self borderWidth: 0.
	model _ nil.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:10'!
install
	owner := nil.	"since we may have been inside another world previously"
	ActiveWorld := self.
	ActiveHand := self hands first.	"default"
	ActiveEvent := nil.
	submorphs do: [:ss | ss owner isNil ifTrue: [ss privateOwner: self]].
	"Transcript that was in outPointers and then got deleted."
	self viewBox: Display boundingBox.
	Sensor flushAllButDandDEvents.
	worldState handsDo: [:h | h initForEvents].
	self installFlaps.
	self borderWidth: 0.	"default"
	(Preferences showSecurityStatus 
		and: [SecurityManager default isInRestrictedMode]) 
			ifTrue: 
				[self
					borderWidth: 2;
					borderColor: Color red].
	self presenter allExtantPlayers do: [:player | player prepareToBeRunning].
	SystemWindow noteTopWindowIn: self.
	self displayWorldSafely! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:11'!
installAsActiveSubprojectIn: enclosingWorld at: newBounds titled: aString 
	| window howToOpen tm boundsForWorld |
	howToOpen := self embeddedProjectDisplayMode.
	"#scaled may be the only one that works at the moment"
	submorphs do: [:ss | ss owner isNil ifTrue: [ss privateOwner: self]].
	"Transcript that was in outPointers and then got deleted."
	boundsForWorld := howToOpen == #naked ifTrue: [newBounds] ifFalse: [bounds].
	worldState canvas: nil.
	worldState viewBox: boundsForWorld.
	self bounds: boundsForWorld.

	"self viewBox: Display boundingBox."
	"worldState handsDo: [:h | h initForEvents]."
	self installFlaps.

	"SystemWindow noteTopWindowIn: self."
	"self displayWorldSafely."
	howToOpen == #naked ifTrue: [enclosingWorld addMorphFront: self].
	howToOpen == #window 
		ifTrue: 
			[window := (NewWorldWindow labelled: aString) model: self.
			window addMorph: self frame: (0 @ 0 extent: 1.0 @ 1.0).
			window openInWorld: enclosingWorld].
	howToOpen == #frame 
		ifTrue: 
			[window := (AlignmentMorphBob1 new)
						minWidth: 100;
						minHeight: 100;
						borderWidth: 8;
						borderColor: Color green;
						bounds: newBounds.
			window addMorph: self.
			window openInWorld: enclosingWorld].
	howToOpen == #scaled 
		ifTrue: 
			[self position: 0 @ 0.
			window := (EmbeddedWorldBorderMorph new)
						minWidth: 100;
						minHeight: 100;
						borderWidth: 8;
						borderColor: Color green;
						bounds: newBounds.
			tm := BOBTransformationMorph new.
			window addMorph: tm.
			tm addMorph: self.
			window openInWorld: enclosingWorld.
			tm changeWorldBoundsToShow: bounds.
			self arrangeToStartSteppingIn: enclosingWorld
			"tm scale: (tm width / self width min: tm height / self height) asFloat."]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/11/2000 16:16'!
installAsActiveSubprojectIn: enclosingWorld titled: aString

	| opt newWidth |

	opt _ self optimumExtentFromAuthor.
	(opt x > (enclosingWorld width * 0.7) or: 
			[opt y > (enclosingWorld height * 0.7)]) ifTrue: [
		newWidth _ enclosingWorld width // 2.
		opt _ newWidth @ (opt y * newWidth / opt x) truncated
	].
	^self 
		installAsActiveSubprojectIn: enclosingWorld 
		at: (enclosingWorld topLeft + (enclosingWorld extent - opt // 2) extent: opt) 
		titled: aString
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 8/31/2004 16:25'!
installFlaps
	"Get flaps installed within the bounds of the receiver"

	Project current assureFlapIntegrity.
	self addGlobalFlaps.
	self localFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld].
	self assureFlapTabsFitOnScreen.
	self bringTopmostsToFront! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 7/9/2005 12:58'!
installVectorVocabulary
	"Install the experimental Vector vocabulary as the default for the current project"

	| standardViewers aVocabulary |
	self setProperty: #currentVocabularySymbol toValue: #Vector.
	standardViewers _ (self submorphsSatisfying: [:m | m isKindOf: ViewerFlapTab]) collect:
		[:m | m referent firstSubmorph].
	aVocabulary _ Vocabulary vocabularyNamed: #Vector.
	standardViewers do: [:m | m switchToVocabulary: aVocabulary]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 11/27/1999 10:20'!
jumpToProject

	Project jumpToProject.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'!
nextPage
	"backstop for smart next-page buttons that look up the containment hierarchy until they find somone who is willing to field this command.  If we get here, the 'next' button was not embedded in a book, so we can do nothing useful"

	Beeper beep! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
open
	"Open a view on this WorldMorph."

	MorphWorldView openOn: self.! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
openWithTitle: aString cautionOnClose: aBoolean
	"Open a view on this WorldMorph with the given title."

	MorphWorldView openOn: self label: aString cautionOnClose: aBoolean! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/11/2000 15:09'!
optimumExtentFromAuthor

	| opt |
	^self 
		valueOfProperty: #optimumExtentFromAuthor 
		ifAbsent: [
			opt _ bounds extent.
			self setProperty: #optimumExtentFromAuthor toValue: opt.
			^opt
		]

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
paintArea
	"What rectangle should the user be allowed to create a new painting in??  An area beside the paintBox.  Allow playArea to override with its own bounds!!  "

	| playfield paintBoxBounds |
	playfield _ self submorphNamed: 'playfield' ifNone: [nil].
	playfield ifNotNil: [^ playfield bounds].

	paintBoxBounds _ self paintBox bounds.
	self firstHand targetOffset x < paintBoxBounds center x
		ifTrue: [^ bounds topLeft corner: paintBoxBounds left@bounds bottom]   "paint on left side"
		ifFalse: [^ paintBoxBounds right@bounds top corner: bounds bottomRight].  "paint on right side"
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 19:01'!
paintAreaFor: aSketchMorph 
	"Answer the area to comprise the onion-skinned canvas for painting/repainting aSketchMorph"

	| itsOwner |
	((itsOwner := aSketchMorph owner) notNil and: [itsOwner isPlayfieldLike]) 
		ifTrue: [^itsOwner bounds].	"handles every plausible situation"
	^self paintArea! !

!PasteUpMorph methodsFor: 'world state' stamp: 'tk 8/21/2000 15:36'!
paintBox
	"Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph, or if it has been deleted from this world, create a new one."

	| newPaintBox refPoint aPalette |
	self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]].
	refPoint _ (aPalette _ self standardPalette)
		ifNotNil:
			[aPalette showNoPalette.
			aPalette topRight + (0 @ 12)]
		ifNil:
			[self topRight].
	newPaintBox _ PaintBoxMorph new.
	newPaintBox position: (refPoint - (newPaintBox width @ 0)). 
	self addMorph: newPaintBox.
	^ newPaintBox
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 12:01'!
paintBoxOrNil
	"Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph return nil"

	self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]].
	^ nil
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'nk 7/7/2003 11:15'!
patchAt: patchRect without: stopMorph andNothingAbove: stopThere
	"Return a complete rendering of this patch of the display screen
	without stopMorph, and possibly without anything above it."

	| c |
	c _ ColorPatchCanvas
		extent: patchRect extent
		depth: Display depth
		origin: patchRect topLeft negated
		clipRect: (0@0 extent: patchRect extent).
	c stopMorph: stopMorph.
	c doStop: stopThere.

	(self bounds containsRect: patchRect) ifFalse:
		["Need to fill area outside bounds with black."
		c form fillColor: Color black].
	(self bounds intersects: patchRect) ifFalse:
		["Nothing within bounds to show."
		^ c form].
	self fullDrawOn: c.
	stopThere ifFalse: [ self world handsReverseDo: [:h | h drawSubmorphsOn: c]].
	^c form
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 10:38'!
pauseEventRecorder
	"Suspend any event recorder, and return it if found"

	| er |
	worldState handsDo: [:h | (er _ h pauseEventRecorderIn: self) ifNotNil: [^ er]].
	^ nil! !

!PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'!
previousPage
	"backstop for smartprev-page buttons that look up the containment hierarchy until they find somone who is willing to field this command.  If we get here, the button was not embedded in a book, so we can do nothing useful"

	Beeper beep! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:43'!
privateOuterDisplayWorld

	worldState displayWorld: self submorphs: submorphs
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 10/5/2000 16:23'!
removeHand: aHandMorph
	"Remove the given hand from the list of hands for this world."

	(worldState hands includes: aHandMorph) ifFalse: [^self].
	aHandMorph dropMorphs.
	self invalidRect: aHandMorph fullBounds.
	worldState removeHand: aHandMorph.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 8/7/2000 12:09'!
repairEmbeddedWorlds

	| transform eWorld toDoList |

	toDoList _ OrderedCollection new.
	self allMorphsDo: [ :each |
		(each isKindOf: EmbeddedWorldBorderMorph) ifTrue: [
			transform _ each submorphs at: 1 ifAbsent: [nil].
			transform ifNotNil: [
				eWorld _ transform submorphs at: 1 ifAbsent: [nil].
				eWorld ifNotNil: [
					toDoList add: {transform. eWorld}.
				].
			].
			"Smalltalk at: #Q put: {self. each. transform. eWorld}."
		].
	].
	toDoList do: [ :each |
		each first addMorph: each second.
	].! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 2/7/2002 16:22'!
repositionFlapsAfterScreenSizeChange
	"Reposition flaps after screen size change"

	(Flaps globalFlapTabsIfAny, ActiveWorld localFlapTabs) do:
		[:aFlapTab |
			aFlapTab applyEdgeFractionWithin: self bounds].
	Flaps doAutomaticLayoutOfFlapsIfAppropriate! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/18/2001 00:35'!
restoreDisplay

	World restoreMorphicDisplay.	"I don't actually expect this to be called"! !

!PasteUpMorph methodsFor: 'world state' stamp: 'md 2/12/2006 20:08'!
restoreFlapsDisplay
	"Restore the display of flaps"

	(Flaps sharedFlapsAllowed and: [Project current flapsSuppressed not]) ifTrue:
		[Flaps globalFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld]].
	self localFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld].
	self assureFlapTabsFitOnScreen.
	self bringTopmostsToFront.! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 9/5/2004 19:46'!
restoreMainDockingBarDisplay
	"Restore the display of docking bars"
	self dockingBars
		do: [:each | each updateBounds]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 4/3/2006 14:36'!
restoreMorphicDisplay

	DisplayScreen startUp.

	ThumbnailMorph recursionReset.

	self
		extent: Display extent;
		viewBox: Display boundingBox;
		handsDo: [:h | h visible: true; showTemporaryCursor: nil];
		restoreFlapsDisplay;
		restoreMainDockingBarDisplay;
		fullRepaintNeeded.
		
	WorldState
		addDeferredUIMessage: [Cursor normal show].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
saveAsWorld
	| worldName s |
	worldName _ FillInTheBlank
		request: 'Please give this world a name'
		initialAnswer: 'test'.
	((self class class includesSelector: worldName asSymbol) and:
		[(PopUpMenu confirm: 'OK to overwrite ' , worldName , '?') not])
		ifTrue: [^ self].

	s _ WriteStream on: (String new: 1000).
	s	nextPutAll: worldName; cr; tab;
		nextPutAll: '"' , self class name , ' ' , worldName, ' open"'; cr; cr; tab;
		nextPutAll: '^ '.
	self printConstructorOn: s indent: 0.
	s cr.

	self class class
		compile: s contents
		classified: 'examples'
		notifying: nil.! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 13:09'!
sketchEditorOrNil
	"Return a SketchEditorMorph found in the world, if any, else nil"

	^ self findA: SketchEditorMorph
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 7/16/2000 00:36'!
sleep

	self flag: #bob.		"Alan wanted this"

	worldState canvas ifNil: [^ self  "already called (clean this up)"].
	Cursor normal show.	"restore the normal cursor"

">>>> Alan wanted this out
	(turtleTrailsForm ~~ nil and: [self confirm: 'May I clear the pen trails
in this worldState to save space?']) ifTrue: [self clearTurtleTrails].
<<<<<"

	worldState canvas: nil.		"free my canvas to save space"
	self fullReleaseCachedState.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:11'!
someHalo
	"Return some halo that's currently visible in the world"

	| m |
	^(m := self haloMorphs) notEmpty ifTrue: [m first] ifFalse: [nil]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
specialNameInModelFor: aMorph
	^ model ifNotNil: [model nameFor: aMorph] ifNil: [nil]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'!
standardPlayerHit

	self playSoundNamed: 'peaks'.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:12'!
standardSystemController
	^ScheduledControllers controllerSatisfying: 
			[:c | 
			c view subViews notEmpty and: [c view firstSubView model == self]]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/1/2000 19:01'!
startSteppingSubmorphsOf: aMorph

	"Ensure that all submorphs of the given morph that want to be stepped are added to the step list.   Typically used after adding a morph to the world."

	aMorph allMorphsDo: [:m |
		m wantsSteps ifTrue: [m arrangeToStartSteppingIn: m world].
	]

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
triggerClosingScripts
	"If the receiver has any scripts set to run on closing, run them now"
	| aPlayer |
	(aPlayer _ self player) ifNotNil:
		[aPlayer runAllClosingScripts]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
triggerOpeningScripts
	"If the receiver has any scripts set to run on opening, run them now"
	| aPlayer |
	(aPlayer _ self player) ifNotNil:
		[aPlayer runAllOpeningScripts]! !


!PasteUpMorph methodsFor: '*39Deprecated' stamp: 'dgd 8/31/2004 16:27'!
bringFlapTabsToFront
	self deprecated: 'Replaced by #bringTopmostsToFront'.
	(submorphs select:[:m| m wantsToBeTopmost]) do:[:m| self addMorphInLayer: m].! !




!PasteUpMorph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/26/2003 23:24'!
addUserCustomEventNamed: aSymbol help: helpString
	self userCustomEventsRegistry at: aSymbol put: helpString.
! !

!PasteUpMorph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/26/2003 23:26'!
removeUserCustomEventNamed: aSymbol
	^self userCustomEventsRegistry removeKey: aSymbol ifAbsent: [].! !

!PasteUpMorph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/26/2003 23:20'!
userCustomEventNames
	| reg |
	reg _ self valueOfProperty: #userCustomEventsRegistry ifAbsent: [ ^#() ].
	^reg keys asArray sort! !

!PasteUpMorph methodsFor: '*eToys-customevents-scripting' stamp: 'nk 9/26/2003 23:18'!
userCustomEventsRegistry
	^self valueOfProperty: #userCustomEventsRegistry ifAbsentPut: [ IdentityDictionary new ].! !



!PasteUpMorph methodsFor: '*eToys-e-toy support' stamp: 'nk 10/13/2004 11:26'!
lastKeystroke
	"Answer the last keystroke fielded by the receiver"

	^ self valueOfProperty: #lastKeystroke ifAbsent: ['']! !

!PasteUpMorph methodsFor: '*eToys-e-toy support' stamp: 'nk 10/13/2004 11:27'!
lastKeystroke: aString
	"Remember the last keystroke fielded by the receiver"

	^ self setProperty: #lastKeystroke toValue: aString! !







!PasteUpMorph methodsFor: '*eToys-world menu' stamp: 'nk 10/14/2004 07:07'!
makeAllScriptEditorsReferToMasters
	"Ensure that all script editors refer to the first (by alphabetical externalName) Player among the list of siblings"

	(self presenter allExtantPlayers groupBy: [ :p | p class ] having: [ :p | true ])
		do: [ :group | group first allScriptEditors ]! !



!PasteUpMorph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 8/21/2004 13:35'!
printVocabularySummary
	"Put up a window with summaries of all Morph vocabularies."

	
	(StringHolder new contents: EToyVocabulary vocabularySummary) 
	openLabel: 'EToy Vocabulary' 

	"self currentWorld printVocabularySummary"! !


!PasteUpMorph methodsFor: '*services-base' stamp: 'rr 3/14/2006 20:30'!
openWorldMenu
	| menu |
	menu := (TheWorldMenu new adaptToWorld: self) buildWorldMenu.
	menu addTitle: Preferences desktopMenuTitle translated.
	menu openInHand! !

!PasteUpMorph methodsFor: '*services-base' stamp: 'rr 3/10/2006 14:25'!
requestor
	"returns the focused window's requestor"
	^ Requestor default! !

!PasteUpMorph methodsFor: '*services-base' stamp: 'rr 3/10/2006 14:25'!
topRequestor
	"returns the focused window's requestor"
	^ SystemWindow topWindow requestor! !

!PasteUpMorph methodsFor: '*services-base' stamp: 'rr 3/14/2006 20:31'!
worldMenu
	| |
	^ TheWorldMenu new adaptToWorld: self! !


!PasteUpMorph methodsFor: '*Tools' stamp: 'dgd 4/4/2006 14:38'!
defaultDesktopCommandKeyTriplets
	"Answer a list of triplets of the form
		<key> <receiver> <selector>   [+ optional fourth element, a <description> for use in desktop-command-key-help]
that will provide the default desktop command key handlers.  If the selector takes an argument, that argument will be the command-key event"

	| noviceKeys expertKeys |

	noviceKeys := {
		{ $o.	ActiveWorld.						#activateObjectsTool.						'Activate the "Objects Tool"'}.
		{ $r.	ActiveWorld.						#restoreMorphicDisplay.					'Redraw the screen'}.		
		{ $z.	self.								#undoOrRedoCommand.					'Undo or redo the last undoable command'}.
		{ $F.	Project current.					#toggleFlapsSuppressed.					'Toggle the display of flaps'}.
		{ $N.	self.								#toggleClassicNavigatorIfAppropriate.	'Show/Hide the classic Navigator, if appropriate'}.
		{ $M.	self.								#toggleShowWorldMainDockingBar.		'Show/Hide the Main Docking Bar'}.
	}.

	Preferences noviceMode
			ifTrue:[^ noviceKeys].

	expertKeys := {
		{ $b.	SystemBrowser.					#defaultOpenBrowser.						'Open a new System Browser'}.
		{ $k.	StringHolder.					#open.										'Open a new, blank Workspace'}.
		{ $m.	self.								#putUpNewMorphMenu.					'Put up the "New Morph" menu'}.
		{ $t.	self.	 							#findATranscript:.							'Make a System Transcript visible'}.
		{ $w.	SystemWindow.					#closeTopWindow.							'Close the topmost window'}.

		{ $C.	self.								#findAChangeSorter:.						'Make a Change Sorter visible'}.

		{ $L.	self.								#findAFileList:.								'Make a File List visible'}.
		{ $P.	self.								#findAPreferencesPanel:.					'Activate the Preferences tool'}.
		{ $R.	self. 								#openRecentSubmissionsBrowser:.		'Make a Recent Submissions browser visible'}.

		{ $W.	self. 								#findAMessageNamesWindow:.			'Make a MessageNames tool visible'}.
		{ $Z.	ChangeList. 						#browseRecentLog.							'Browse recently-logged changes'}.

		{ $\.	SystemWindow. 					#sendTopWindowToBack.					'Send the top window to the back'}.
	}.

	^ noviceKeys, expertKeys
! !


!PasteUpMorph methodsFor: 'private' stamp: 'ar 3/14/2000 23:20'!
privateFullMoveBy: delta
	"Private. Overridden to prevent drawing turtle trails when a playfield is moved"
	self setProperty: #turtleTrailsDelta toValue: delta.
	super privateFullMoveBy: delta.
	self removeProperty: #turtleTrailsDelta.
! !

!PasteUpMorph methodsFor: 'private' stamp: 'RAA 6/1/2000 14:23'!
privateMoveBy: delta

	super privateMoveBy: delta.
	worldState ifNotNil: [
		worldState viewBox ifNotNil: [
			worldState viewBox: bounds
		].
	].! !

!PasteUpMorph methodsFor: 'private' stamp: 'nk 7/8/2003 09:18'!
privateRemoveMorph: aMorph
	backgroundMorph == aMorph ifTrue: [ backgroundMorph _ nil ].
	^super privateRemoveMorph: aMorph.
! !


!PasteUpMorph methodsFor: 'debug and other' stamp: 'sw 1/3/2001 06:42'!
addViewingItemsTo: aMenu
	"Add viewing-related items to the given menu.  If any are added, this method is also responsible for adding a line after them"

	#(	(viewingByIconString 			viewByIcon)
		(viewingByNameString 			viewByName)
		"(viewingBySizeString 			viewBySize)"
		(viewingNonOverlappingString 	viewNonOverlapping)) do:
			[:pair |  aMenu addUpdating: pair first target:  self action: pair second].
	aMenu addLine
! !


!PasteUpMorph methodsFor: 'e-toy support' stamp: 'sw 7/6/1999 08:39'!
automaticViewing
	^ self hasProperty: #automaticViewing! !

!PasteUpMorph methodsFor: 'e-toy support' stamp: 'di 7/27/1999 10:24'!
cursor 
	^ cursor
! !

!PasteUpMorph methodsFor: 'e-toy support' stamp: 'sw 9/7/2000 11:43'!
cursor: aNumber
	"for backward compatibility"

	self cursorWrapped: aNumber! !

!PasteUpMorph methodsFor: 'e-toy support' stamp: 'RAA 10/4/2000 08:24'!
fenceEnabled

	^ self valueOfProperty: #fenceEnabled ifAbsent: [Preferences fenceEnabled]! !

!PasteUpMorph methodsFor: 'e-toy support' stamp: 'sw 1/25/2000 13:07'!
isCandidateForAutomaticViewing
	"A viewer on a world is a dangerous thing to get casually!!"

	^ self isWorldMorph not! !

!PasteUpMorph methodsFor: 'e-toy support' stamp: 'nk 9/8/2003 17:17'!
referencePlayfield
	"Answer a pasteup morph to be used as the reference for cartesian coordinates.
	Do not get fooled by other morphs (like viewers) that happen to be named 'playfield'."

	^self isWorldMorph
		ifTrue: [ self submorphThat: [ :s | (s knownName = 'playfield') and: [ s isPlayfieldLike] ] ifNone: [self]]
		ifFalse: [ super referencePlayfield ]! !


!PasteUpMorph methodsFor: '*MorphicExtras-flaps' stamp: 'dgd 4/3/2006 14:41'!
deleteAllFlapArtifacts
	"self currentWorld deleteAllFlapArtifacts"

	self submorphs do:[:m | m wantsToBeTopmost ifTrue:[m delete]].! !


!PasteUpMorph methodsFor: 'thumbnail' stamp: 'dgd 9/22/2004 19:37'!
icon
	"Answer a form with an icon to represent the receiver"
	^ self isWorldMorph
		ifTrue: [MenuIcons homeIcon]
		ifFalse: [MenuIcons projectIcon]! !


!PasteUpMorph methodsFor: '*MorphicExtras-misc' stamp: 'dgd 4/3/2006 14:33'!
roundUpStrays
	self submorphs
		reject: [:each | each wantsToBeTopmost]
		thenDo: [:each | each goHome].
	super roundUpStrays! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PasteUpMorph class
	instanceVariableNames: ''!

!PasteUpMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:48'!
descriptionForPartsBin
	^ self partName:	'Playfield'
		categories:		#('Presentation')
		documentation:	'A place for assembling parts or for staging animations'! !


!PasteUpMorph class methodsFor: 'printing' stamp: 'sw 5/3/1998 14:25'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ 'playfield'! !


!PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'!
MinCycleLapse: milliseconds
	"set the minimum amount of time that may transpire between two calls to doOneCycle"
	MinCycleLapse _ milliseconds ifNotNil: [ milliseconds rounded ].! !

!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 5/25/2000 15:26'!
disableDeferredUpdates

	^DisableDeferredUpdates ifNil: [DisableDeferredUpdates _ false]
! !

!PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'!
disableDeferredUpdates: aBoolean
	"If the argument is true, disable deferred screen updating."
	"Details: When deferred updating is used, Morphic performs double-buffered screen updates by telling the VM to de-couple the Display from the hardware display buffer, drawing directly into the Display, and then forcing the changed regions of the Display to be copied to the screen. This saves both time (an extra BitBlt is avoided) and space (an extra display buffer is avoided). However, on platforms on which the Display points directly to the hardware screen buffer, deferred updating can't be used (you'd see ugly flashing as the layers of the drawing were assembled). In this case, the drawing is composited into an offscreen FormCanvas  and then copied to the hardware display buffer."

	DisableDeferredUpdates _ aBoolean.
! !

!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 5/25/2000 15:15'!
newWorldForProject: projectOrNil 
	"Return a new pasteUpMorph configured as a world (ie project notNil).
	projectOrNil is no longer used."

	^ self new initForProject: WorldState new! !

!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 5/26/2000 10:07'!
newWorldTesting

	| world ex |

	ex _ 500@500.
	world _ PasteUpMorph newWorldForProject: nil.
	world extent: ex; color: Color orange.
	world openInWorld.
	world viewBox: (0@0 extent: ex).
	BouncingAtomsMorph new openInWorld: world.

"-----

	| world window |
	world _ PasteUpMorph newWorldForProject: nil.
	world extent: 300@300; color: Color orange.
	world viewBox: (0@0 extent: 300@300).
	window _ (SystemWindow labelled: 'the new world') model: world.
	window color: Color orange.
	window addMorph: world frame: (0@0 extent: 1.0@1.0).
	window openInWorld.

---"
! !


!PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 8/3/2005 13:57'!
additionsToViewerCategoryPreferences
	"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."

	^ #(preferences (
			(slot useVectorVocabulary 'Whether to use the Vector vocabulary with etoy scripting in this project' Boolean readWrite Player getUseVectorVocabulary Player setUseVectorVocabulary:)
			(slot dropProducesWatcher 'Whether a drop of a value tile, such as "car''s x", on the desktop, should produce a watcher for that value' Boolean readWrite Player getDropProducesWatcher Player setDropProducesWatcher:)
			(slot allowEtoyUserCustomEvents 'Whether to allow "custom events" in etoys.' Boolean readWrite Player getAllowEtoyUserCustomEvents Player setAllowEtoyUserCustomEvents:)
			(slot batchPenTrails 'Whether pen trails should reflect small movements within the same tick or only should integrate all movement between ticks' Boolean readWrite Player getBatchPenTrails Player setBatchPenTrails:)
			"(slot eToyFriendly 'Whether various restrictions should apply in many parts of the system.  Intended to be set to true for younger users.' Boolean readWrite Player getEToyFriendly Player setEToyFriendly:)"
			(slot fenceEnabled 'Whether an object hitting the edge of the screen should be kept "fenced in", rather than being allowed to escape and disappear' Boolean readWrite Player getFenceEnabled Player setFenceEnabled:)
			(slot keepTickingWhilePainting 'Whether scripts should continue to run while you''re using the painting system' Boolean readWrite Player getKeepTickingWhilePainting Player setKeepTickingWhilePainting:)
			(slot oliveHandleForScriptedObjects 'Whether the default green halo handle (at the top right of the halo) should, for scripted objects, be the olive-green handle, signifying that use will result in a sibling instance. ' Boolean readWrite Player getOliveHandleForScriptedObjects  Player setOliveHandleForScriptedObjects: )
	))! !

!PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 3/4/1999 15:05'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	| proto |
	proto _ self new markAsPartsDonor.
	proto color: Color green muchLighter;  extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161).
	proto extent: 300 @ 240.
	proto beSticky.
	^ proto! !


!PasteUpMorph class methodsFor: 'system startup' stamp: 'rww 10/1/2001 01:17'!
shutDown
	
	World ifNotNil:[
		World triggerEvent: #aboutToLeaveWorld.
	].! !

!PasteUpMorph class methodsFor: 'system startup' stamp: 'rww 10/1/2001 01:17'!
startUp
	
	World ifNotNil:[
		World restoreMorphicDisplay.
		World triggerEvent: #aboutToEnterWorld.
	].! !


!PasteUpMorph class methodsFor: '*eToys-scripting' stamp: 'nk 10/13/2004 11:39'!
additionsToViewerCategoryInput
	"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."

	^ #(input (
			(slot lastKeystroke 'The last unhandled keystroke' String readWrite Player getLastKeystroke Player setLastKeystroke:)
	))! !


!PasteUpMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'nk 12/13/2004 18:22'!
initialize
	"Initialize the class"

	self registerInFlapsRegistry.	
	ScriptingSystem addCustomEventFor: self named: #keyStroke help: 'when a keystroke happens and nobody heard it' targetMorphClass: PasteUpMorph.! !

!PasteUpMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 10:10'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(PasteUpMorph			authoringPrototype		'Playfield'		'A place for assembling parts or for staging animations')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(PasteUpMorph			authoringPrototype		'Playfield'		'A place for assembling parts or for staging animations')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(PasteUpMorph			authoringPrototype		'Playfield'		'A place for assembling parts or for staging animations')
						forFlapNamed: 'Scripting']! !

!PasteUpMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:38'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!PasteUpMorph class methodsFor: '*MorphicExtras-parts bin' stamp: 'sw 8/2/2001 16:29'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'Holder'
		categoryList: #(Scripting)
		documentation: 'A place for storing alternative pictures in an animation, ec.'
		globalReceiverSymbol: #ScriptingSystem
		nativitySelector: #prototypicalHolder}! !


!PasteUpMorph class methodsFor: '*MorphicExtras-scripting' stamp: 'sw 10/3/2004 01:14'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ # (

(playfield (
(command initiatePainting 'Initiate painting of a new object in the standard playfield.')
(slot mouseX 'The x coordinate of the mouse pointer' Number readWrite Player getMouseX  unused unused)
(slot mouseY 'The y coordinate of the mouse pointer' Number readWrite Player getMouseY  unused unused)
(command roundUpStrays 'Bring all out-of-container subparts back into view.')
(slot graphic 'The graphic shown in the background of this object' Graphic readWrite Player getGraphic Player setGraphic:)
(command unhideHiddenObjects 'Unhide all hidden objects.')))

(scripting (
(command tellAllContents: 'Send a message to all the objects inside the playfield' ScriptName)))

(collections (
(slot cursor 'The index of the chosen element' Number readWrite Player getCursor Player setCursorWrapped:)
(slot count 'How many elements are within me' Number readOnly Player getCount unused unused)
(slot stringContents 'The characters of the objects inside me, laid end to end' String readOnly Player getStringContents unused unused)
(slot playerAtCursor 'the object currently at the cursor' Player readWrite Player getValueAtCursor  unused unused)
(slot firstElement  'The first object in my contents' Player  readWrite Player getFirstElement  Player  setFirstElement:)
(slot numberAtCursor 'the number at the cursor' Number readWrite Player getNumberAtCursor Player setNumberAtCursor: )
(slot graphicAtCursor 'the graphic worn by the object at the cursor' Graphic readOnly Player getGraphicAtCursor  unused unused)
(command tellAllContents: 'Send a message to all the objects inside the playfield' ScriptName)
(command removeAll 'Remove all elements from the playfield')
(command shuffleContents 'Shuffle the contents of the playfield')
(command append: 'Add the object to the end of my contents list.' Player)
(command prepend: 'Add the object at the beginning of my contents list.' Player)
(command includeAtCursor: 'Add the object to my contents at my current cursor position' Player)
(command include: 'Add the object to my contents' Player)
))

(#'stack navigation' (
(command goToNextCardInStack 'Go to the next card')
(command goToPreviousCardInStack  'Go to the previous card')
(command goToFirstCardInBackground 'Go to the first card of the current background')
(command goToFirstCardOfStack 'Go to the first card of the entire stack')
(command goToLastCardInBackground 'Go to the last card of the current background')
(command goToLastCardOfStack 'Go to the last card of the entire stack')
(command deleteCard 'Delete the current card')
(command insertCard 'Create a new card')))

"(viewing (
(slot viewingNormally 'whether contents are viewed normally' Boolean readWrite Player getViewingByIcon Player setViewingByIcon: )))"

(#'pen trails' (
(command liftAllPens 'Lift the pens on all the objects in my interior.')
(command lowerAllPens  'Lower the pens on all the objects in my interior.')
(command trailStyleForAllPens:  'Set the trail style for pens of all objects within' TrailStyle)
(command clearTurtleTrails 'Clear all the pen trails in the interior.'))))
! !
ClassTestCase subclass: #PasteUpMorphTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Worlds'!
!PasteUpMorphTest commentStamp: '<historical>' prior: 0!
I am a TestCase for PasteUpMorph.!


!PasteUpMorphTest methodsFor: 'tests' stamp: 'tak 11/7/2004 18:29'!
testCursorWrapped
	"self debug: #testCursorWrapped"
	| holder |
	holder := PasteUpMorph new.
	self assert: holder cursor = 1.
	holder cursorWrapped: 2.
	self assert: holder cursor = 1.
	holder addMorph: Morph new;
		 addMorph: Morph new;
		 addMorph: Morph new.
	holder cursorWrapped: 3.
	self assert: holder cursor = 3.
	holder cursorWrapped: 5.
	self assert: holder cursor = 2.
	holder cursorWrapped: 0.
	self assert: holder cursor = 3.
	holder cursorWrapped: -1.
	self assert: holder cursor = 2.! !

!PasteUpMorphTest methodsFor: 'tests' stamp: 'tak 11/7/2004 18:34'!
testCursorWrappedWithFraction
	"self debug: #testCursorWrappedWithFraction"
	| holder |
	holder := PasteUpMorph new.
	holder addMorph: Morph new;
		 addMorph: Morph new;
		 addMorph: Morph new.
	holder cursorWrapped: 3.5.
	self assert: holder cursor = 3.5.
	holder cursorWrapped: 5.5.
	self assert: holder cursor = 2.5.
	holder cursorWrapped: 0.5.
	self assert: holder cursor = 3.5.
	holder cursorWrapped: -0.5.
	self assert: holder cursor = 2.5.! !

!PasteUpMorphTest methodsFor: 'tests' stamp: 'mjr 3/6/2003 11:34'!
testGridToGradient
	"A trivial test for checking that you can change from a grid to a  
	gradient background. A recent [FIX] will make this pass."
	| pum |
	pum _ PasteUpMorph new.
	pum setStandardTexture.
	"The following should fail without the fix"
	self
		shouldnt: [pum gradientFillColor: Color red]
		raise: MessageNotUnderstood! !
DisplayObject subclass: #Path
	instanceVariableNames: 'form collectionOfPoints'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Path commentStamp: '<historical>' prior: 0!
I am the abstract superclass of the Graphic spatial primitives. I represent an ordered sequence of Points. Spatial primitives are used to generate "trajectories" such as lines and circles.!


!Path methodsFor: 'accessing'!
at: index 
	"Answer the point on the receiver's path at position index."

	^collectionOfPoints at: index! !

!Path methodsFor: 'accessing'!
at: index put: aPoint 
	"Store the argument, aPoint, as the point on the receiver's path at position
	index."

	^collectionOfPoints at: index put: aPoint! !

!Path methodsFor: 'accessing'!
first
	"Answer the first point on the receiver's path; included to correspond to 
	OrderedCollection protocol."

	^collectionOfPoints first! !

!Path methodsFor: 'accessing'!
firstPoint
	"Answer the first point on the receiver's path."

	^collectionOfPoints first! !

!Path methodsFor: 'accessing'!
firstPoint: aPoint 
	"Replace the first element of the receiver with the new value aPoint. 
	Answer the argument aPoint."

	collectionOfPoints at: 1 put: aPoint.
	^aPoint! !

!Path methodsFor: 'accessing'!
form
	"Answer the receiver's form, or, if form is nil, then answer a 1 x 1 black 
	form (a black dot)."

	| aForm |
	form == nil
		ifTrue: 
			[aForm _ Form extent: 1 @ 1.
			aForm fillBlack.
			^aForm]
		ifFalse: 
			[^form]! !

!Path methodsFor: 'accessing'!
form: aForm 
	"Make the argument, aForm, be the receiver's form."

	form _ aForm! !

!Path methodsFor: 'accessing'!
last
	"Answer the last point on the receiver's path; included to correspond to 
	OrderedCollection protocol."

	^collectionOfPoints last! !

!Path methodsFor: 'accessing'!
offset
	"There are basically two kinds of display objects in the system: those
	that, when asked to transform themselves, create a new object; and those
	that side effect themselves by maintaining a record of the transformation
	request (typically an offset). Path, like Rectangle and Point, is a display
	object of the first kind."

	self shouldNotImplement! !

!Path methodsFor: 'accessing'!
secondPoint
	"Answer the second element of the receiver."

	^collectionOfPoints at: 2! !

!Path methodsFor: 'accessing'!
secondPoint: aPoint 
	"Replace the second element of the receiver with the new value aPoint. 
	Answer the argument aPoint."

	collectionOfPoints at: 2 put: aPoint.
	^aPoint! !

!Path methodsFor: 'accessing'!
size
	"Answer the length of the receiver."

	^collectionOfPoints size! !

!Path methodsFor: 'accessing'!
thirdPoint
	"Answer the third element of the receiver."

	^collectionOfPoints at: 3! !

!Path methodsFor: 'accessing'!
thirdPoint: aPoint 
	"Replace the third element of the receiver with the new value aPoint. 
	Answer the argument aPoint."

	collectionOfPoints at: 3 put: aPoint.
	^aPoint! !


!Path methodsFor: 'adding'!
add: aPoint 
	"Include aPoint as one of the receiver's elements."

	collectionOfPoints add: aPoint! !


!Path methodsFor: 'display box access'!
computeBoundingBox 
	"Refer to the comment in DisplayObject|computeBoundingBox."

	| box |
	box _ Rectangle origin: (self at: 1) extent: 0 @ 0.
	collectionOfPoints do: 
		[:aPoint | box _ box merge: (Rectangle origin: aPoint extent: 0 @ 0)].
	^box! !


!Path methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Display this Path--offset by aPoint, clipped by clipRect and the form 
	associated with this Path will be displayedr according to one of the sixteen 
	functions of two logical variables (rule). Also the source form will be first 
	anded with aForm as a mask. Does not effect the state of the Path"

	collectionOfPoints do: 
		[:element | 
		self form
			displayOn: aDisplayMedium
			at: element + aDisplayPoint
			clippingBox: clipRectangle
			rule: ruleInteger
			fillColor: aForm]! !

!Path methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Displays this path, translated and scaled by aTransformation. Get the
	scaled and translated Path."

	| newPath transformedPath |
	transformedPath _ displayTransformation applyTo: self.
	newPath _ Path new.
	transformedPath do: [:point | newPath add: point].
	newPath form: self form.
	newPath
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm! !


!Path methodsFor: 'enumerating'!
collect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect the resulting values into a path that is like the receiver. Answer 
	the new path."

	| newCollection |
	newCollection _ collectionOfPoints collect: aBlock.
	newCollection form: self form.
	^newCollection! !

!Path methodsFor: 'enumerating'!
select: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect into a new path like the receiver only those elements for which 
	aBlock evaluates to true. Answer the new path."

	| newCollection |
	newCollection _ collectionOfPoints select: aBlock.
	newCollection form: self form.
	^newCollection! !


!Path methodsFor: 'removing' stamp: 'di 4/4/2000 12:33'!
removeAllSuchThat: aBlock 
	"Evaluate aBlock for each element of the receiver.
	Remove each element for which aBlock evaluates to true."

	collectionOfPoints removeAllSuchThat: aBlock.
! !


!Path methodsFor: 'testing'!
isEmpty

	^collectionOfPoints isEmpty! !


!Path methodsFor: 'transforming' stamp: 'jrm 9/1/1999 21:26'!
scaleBy: aPoint 
	"Answers a new Path scaled by aPoint. Does not affect the current data in 
	this Path."

	| newPath | 
	newPath _ self species new: self size. 
	newPath form: self form.
	collectionOfPoints do: [:element | newPath add: (element scaleBy: aPoint)].
	^newPath! !

!Path methodsFor: 'transforming' stamp: 'jrm 9/1/1999 21:28'!
translateBy: aPoint 
	"Answers a new Path whose elements are translated by aPoint. Does not
	affect the elements of this Path."

	| newPath |
	newPath _ self species new: self size.
	newPath form: self form.
	collectionOfPoints do: [:element | newPath add: (element translateBy: aPoint)].
	^newPath! !


!Path methodsFor: 'private'!
initializeCollectionOfPoints

	collectionOfPoints _ OrderedCollection new! !

!Path methodsFor: 'private'!
initializeCollectionOfPoints: anInteger

	collectionOfPoints _ OrderedCollection new: anInteger! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Path class
	instanceVariableNames: ''!

!Path class methodsFor: 'examples'!
example
	"Creates a Path from mousePoints and displays it several ways on the display screen. Messes up the display. For learning about class Path, just select the code below and execute it to create a path and see it redisplayed in another place on the screen. Each path displays using a different form. A path is indicated by pressing the red mouse button in a sequence; press any other mouse button to terminate. "

	| aPath aForm pl fl flag |
	aForm _ Form extent: 2 @ 40.		"creates a form one inch long"
	aForm fillBlack.							"turns it black"
	aPath _ Path new.
	aPath form: aForm.						"use the long black form for displaying"
	flag _ true.
	[flag]
		whileTrue: 
			[Sensor waitButton.
			Sensor redButtonPressed
				ifTrue: 
					[aPath add: Sensor waitButton.
					Sensor waitNoButton.
					aForm displayOn: Display at: aPath last]
				ifFalse: [flag _ false]].
	Display fillWhite.
	aPath displayOn: Display.			"the original path"
	pl _ aPath translateBy: 0 @ 100.
	fl _ Form extent: 40 @ 40.
	fl fillGray.
	pl form: fl.
	pl displayOn: Display.				"the translated path"
	Sensor waitNoButton

	"Path example"! !


!Path class methodsFor: 'instance creation'!
new

	^self basicNew initializeCollectionOfPoints! !

!Path class methodsFor: 'instance creation'!
new: anInteger

	^self basicNew initializeCollectionOfPoints: anInteger! !
BitBlt subclass: #Pen
	instanceVariableNames: 'location direction penDown'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Pen commentStamp: '<historical>' prior: 0!
My instances can scribble on the screen or some other Form, drawing and printing at any angle. Since I am a BitBlt, the drawing can be done with an arbitary source Form.
!


!Pen methodsFor: 'accessing'!
direction
	"Answer the receiver's current direction. 0 is towards the top of the
	screen."

	^direction! !

!Pen methodsFor: 'accessing'!
location
	"Answer where the receiver is currently located."

	^location! !


!Pen methodsFor: 'geometric designs' stamp: 'di 6/11/1998 22:01'!
dragon: n  "Display restoreAfter: [Display fillWhite. Pen new dragon: 10]."
	"Display restoreAfter: [Display fillWhite. 1 to: 4 do:
				[:i | Pen new color: i; turn: 90*i; dragon: 10]]"
	"Draw a dragon curve of order n in the center of the screen."
	n = 0
		ifTrue: [self go: 5]
		ifFalse: [n > 0
				ifTrue: [self dragon: n - 1; turn: 90; dragon: 1 - n]
				ifFalse: [self dragon: -1 - n; turn: -90; dragon: 1 + n]]
! !

!Pen methodsFor: 'geometric designs' stamp: 'di 6/14/1998 13:42'!
filberts: n side: s   "Display restoreAfter: [Pen new filberts: 4 side: 5]"
	"Two Hilbert curve fragments form a Hilbert tile. Draw four interlocking 
	tiles of order n and sides length s."
	| n2 |
	Display fillWhite.
	n2 _ 1 bitShift: n - 1.
	self up; go: 0 - n2 * s; down.
	1 to: 4 do: 
		[:i | 
		self fill: [:p |
				p hilbert: n side: s.
				p go: s.
				p hilbert: n side: s.
				p go: s.
				p up.
				p go: n2 - 1 * s.
				p turn: -90.
				p go: n2 * s.
				p turn: 180.
				p down]
			color: (Color perform: (#(yellow red green blue) at: i))]! !

!Pen methodsFor: 'geometric designs'!
hilbert: n side: s 
	"Draw an nth level Hilbert curve with side length s in the center of the 
	screen. Write directly into the display's bitmap only. A Hilbert curve is 
	a space-filling curve."

	| a m |
	n = 0 ifTrue: [^self turn: 180].
	n > 0
		ifTrue: 
			[a _ 90.
			m _ n - 1]
		ifFalse: 
			[a _ -90.
			m _ n + 1].
	self turn: a.
	self hilbert: 0 - m side: s.
	self turn: a; go: s.
	self hilbert: m side: s.
	self turn: 0 - a; go: s; turn: 0 - a.
	self hilbert: m side: s.
	self go: s; turn: a.
	self hilbert: 0 - m side: s.
	self turn: a
	" 
	(Pen new) hilbert: 3 side: 8. 
	(Pen new sourceForm: Cursor wait) combinationRule: Form under; 
	hilbert: 3 side: 25.
	"! !

!Pen methodsFor: 'geometric designs'!
hilberts: n   "Display restoreAfter: [Display fillWhite.  Pen new hilberts: 5]"
	"Draws n levels of nested Hilbert curves"
	| s |
	self up; turn: 90; go: 128; down.
	1 to: n do: 
		[:i | 
		s _ 256 bitShift: 0 - i.
		self defaultNib: n - i * 2 + 1.
		self color: i+1.
		self up; go: 0 - s / 2; turn: -90; go: s / 2; turn: 90; down.
		self hilbert: i side: s.
		self go: s.
		self hilbert: i side: s.
		self go: s]! !

!Pen methodsFor: 'geometric designs'!
mandala: npoints
	"Display restoreAfter: [Pen new mandala: 30]"
	"On a circle of diameter d, place npoints number of points. Draw all 	possible connecting lines between the circumferential points."
	| l points d |
	Display fillWhite.
	d _ Display height-50.
	l _ 3.14 * d / npoints.
	self home; up; turn: -90; go: d // 2; turn: 90; go: 0 - l / 2; down.
	points _ Array new: npoints.
	1 to: npoints do: 
		[:i | 
		points at: i put: location rounded.
		self go: l; turn: 360.0 / npoints].
	npoints // 2
		to: 1
		by: -1
		do: 
			[:i | 
			self color: i.
			1 to: npoints do: 
				[:j | 
				self place: (points at: j).
				self goto: (points at: j + i - 1 \\ npoints + 1)]]
! !

!Pen methodsFor: 'geometric designs' stamp: 'jm 5/6/1998 22:26'!
spiral: n angle: a 
	"Draw a double squiral (see Papert, MindStorms), where each design is made
	by moving the receiver a distance of n after turning the amount + or -a."

	1 to: n do: 
		[:i | 
		self color: i * 2.
		self go: i; turn: a]
"
	Display restoreAfter: [
		Display fillWhite. Pen new spiral: 200 angle: 89; home; spiral: 200 angle: -89].
"! !

!Pen methodsFor: 'geometric designs' stamp: 'jm 8/1/97 11:42'!
web   "Display restoreAfter: [Pen new web]"
	"Draw pretty web-like patterns from the mouse movement on the screen.
	Press the mouse button to draw, option-click to exit.
	By Dan Ingalls and Mark Lentczner. "
	| history newPoint ancientPoint lastPoint filter color |
	"self erase."
	color _ 1.
	[ true ] whileTrue:
		[ history _ OrderedCollection new.
		Sensor waitButton.
		Sensor yellowButtonPressed ifTrue: [^ self].
		filter _ lastPoint _ Sensor mousePoint.
		20 timesRepeat: [ history addLast: lastPoint ].
		self color: (color _ color + 1).
		[ Sensor redButtonPressed ] whileTrue: 
			[ newPoint _ Sensor mousePoint.
			(newPoint = lastPoint) ifFalse:
				[ ancientPoint _ history removeFirst.
				filter _ filter * 4 + newPoint // 5.
				self place: filter.
				self goto: ancientPoint.
				lastPoint _ newPoint.
				history addLast: filter ] ] ]! !


!Pen methodsFor: 'initialize-release' stamp: 'jm 4/28/1998 04:02'!
defaultNib: widthInteger 
	"Nib is the tip of a pen. This sets up the pen, with a nib of width widthInteger. You can also set the shape of the pen nib using:
		roundNib: widthInteger, or
		squareNib: widthInteger, or
		sourceForm: aForm"
"Example:
	| bic |
	bic _ Pen new sourceForm: Cursor normal.
	bic combinationRule: Form paint; turn: 90.
	10 timesRepeat: [bic down; go: 3; up; go: 10]."

	self color: Color black.
	self squareNib: widthInteger.
! !

!Pen methodsFor: 'initialize-release' stamp: 'jm 4/28/1998 04:03'!
roundNib: diameter
	"Makes this pen draw with a round dot of the given diameter."

	self sourceForm: (Form dotOfSize: diameter).
	combinationRule _ Form paint.
! !

!Pen methodsFor: 'initialize-release' stamp: 'jm 4/28/1998 04:03'!
squareNib: widthInteger 
	"Makes this pen draw with a square nib of the given width."

	self sourceForm: (Form extent: widthInteger @widthInteger) fillBlack.
	self combinationRule: Form over.  "a bit faster than paint mode"
! !


!Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 03:17'!
arrowHead
	"Put an arrowhead on the previous pen stroke"
	" | pen | pen _ Pen new. 20 timesRepeat: [pen turn: 360//20; go: 20; arrowHead]."

	penDown ifTrue:
		[self arrowHeadFrom: (direction degreeCos @ direction degreeSin) * -40 + location 
			to: location
			arrowSpec: (Preferences parameterAt: #arrowSpec ifAbsent: [5 @ 4])]! !

!Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 02:29'!
arrowHeadForArrowSpec: anArrowSpec
	"Put an arrowhead on the previous pen stroke"
"
	 | pen aPoint |
	aPoint _ Point fromUser.
	pen _ Pen new.
	20 timesRepeat: [pen turn: 360//20; go: 20; arrowHeadForArrowSpec: aPoint].
"


	penDown ifTrue:
		[self arrowHeadFrom: (direction degreeCos @ direction degreeSin) * -40 + location 
			to: location
			arrowSpec: anArrowSpec]! !

!Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 02:25'!
arrowHeadFrom: prevPt to: newPt arrowSpec: anArrowSpec
	"Put an arrowhead on the pen stroke from oldPt to newPt"

	| pm af myColor finalPt delta |
	myColor _ self color.
	delta _ newPt - prevPt.
	delta r <= 2 "pixels" ifTrue: [^ self].
	finalPt _ newPt + (Point r: sourceForm width degrees: delta degrees).	"in same direction"
	pm _ PolygonMorph vertices: (Array with: prevPt asIntegerPoint with: finalPt asIntegerPoint)  
		color: myColor  "not used"
		borderWidth: sourceForm width borderColor: myColor.
	pm makeOpen; makeForwardArrow.
	anArrowSpec ifNotNil: [pm arrowSpec: anArrowSpec].
	af _ pm arrowForms first.
	"render it onto the destForm"
	(FormCanvas on: destForm "Display") stencil: af at: af offset + (1@1)
		color: myColor! !

!Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 02:11'!
arrowHeadFrom: prevPt to: newPt forPlayer: aPlayer
	"Put an arrowhead on the pen stroke from oldPt to newPt"
	
	| aSpec |
	(aPlayer notNil and: [(aSpec _ aPlayer costume renderedMorph valueOfProperty: #arrowSpec) notNil]) 
		ifFalse:
			[aSpec _ Preferences parameterAt: #arrowSpec "may well be nil"].
	self arrowHeadFrom: prevPt to: newPt arrowSpec: aSpec! !

!Pen methodsFor: 'operations' stamp: 'jm 4/28/1998 03:40'!
color: aColorOrInteger
	"Set the pen to the given color or to a color chosen from a fixed set of colors."

	| count c |
	aColorOrInteger isInteger
		ifTrue: [
			destForm depth = 1 ifTrue: [^ self fillColor: Color black].
			count _ 19.  "number of colors in color wheel"
			c _ (Color red wheel: count) at: ((aColorOrInteger * 7) \\ count) + 1]
		ifFalse: [c _ aColorOrInteger].  "assume aColorOrInteger is a Color"
	self fillColor: c.
! !

!Pen methodsFor: 'operations'!
down
	"Set the state of the receiver's pen to down (drawing)."

	penDown _ true! !

!Pen methodsFor: 'operations' stamp: 'di 6/21/1998 09:37'!
fill: drawBlock color: color
	| region tileForm tilePen shape saveColor recorder |
	drawBlock value: (recorder _ self as: PenPointRecorder).
	region _ Rectangle encompassing: recorder points.
	tileForm _ Form extent: region extent+6.
	tilePen _ Pen newOnForm: tileForm.
	tilePen location: location-(region origin-3)
		direction: direction
		penDown: penDown.
	drawBlock value: tilePen.  "Draw the shape in B/W"
	saveColor _ halftoneForm.
	drawBlock value: self.
	halftoneForm _ saveColor.
	shape _ (tileForm findShapeAroundSeedBlock: [:f | f borderWidth: 1]) reverse.
	shape copy: shape boundingBox from: tileForm to: 0@0 rule: Form erase.
	destForm fillShape: shape fillColor: color at: region origin-3! !

!Pen methodsFor: 'operations'!
go: distance 
	"Move the pen in its current direction a number of bits equal to the 
	argument, distance. If the pen is down, a line will be drawn using the 
	receiver's form source as the shape of the drawing brush."

	self goto: (direction degreeCos @ direction degreeSin) * distance + location! !

!Pen methodsFor: 'operations' stamp: 'di 11/4/97 20:11'!
goto: aPoint 
	"Move the receiver to position aPoint. If the pen is down, a line will be 
	drawn from the current position to the new one using the receiver's 
	form source as the shape of the drawing brush. The receiver's set 
	direction does not change."
	| old |
	old _ location.
	location _ aPoint.
	penDown ifTrue: [self drawFrom: old rounded
								to: location rounded]

	"NOTE:  This should be changed so it does NOT draw the first point, so as
	not to overstrike at line junctions.  At the same time, place should draw
	a single dot if the pen is down, as should down (put-pen-down) if it
	was not down before."! !

!Pen methodsFor: 'operations'!
home
	"Place the receiver at the center of its frame."
	location _ destForm boundingBox center! !

!Pen methodsFor: 'operations'!
north
	"Set the receiver's direction to facing toward the top of the display screen."

	direction _ 270! !

!Pen methodsFor: 'operations'!
place: aPoint 
	"Set the receiver at position aPoint. No lines are drawn."

	location _ aPoint! !

!Pen methodsFor: 'operations' stamp: 'ar 5/28/2000 12:10'!
print: str withFont: font
	"Print the given string in the given font at the current heading"
	| lineStart form charStart rowStart scale wasDown bb pix |
	scale _ sourceForm width.
	wasDown _ penDown.
	lineStart _ location.
	str do:
		[:char |
		char = Character cr ifTrue:
			[self place: lineStart; up; turn: 90; go: font height*scale; turn: -90; down]
		ifFalse:
			[form _ font characterFormAt: char.
			charStart _ location.
wasDown ifTrue: [
			self up; turn: -90; go: font descent*scale; turn: 90; down.
			0 to: form height-1 do:
				[:y |
				rowStart _ location.
				bb _ BitBlt current bitPeekerFromForm: form.
				pix _ RunArray newFrom:
					((0 to: form width-1) collect: [:x | bb pixelAt: x@y]).
				pix runs with: pix values do:
					[:run :value |
					value = 0
						ifTrue: [self up; go: run*scale; down]
						ifFalse: [self go: run*scale]].
				self place: rowStart; up; turn: 90; go: scale; turn: -90; down].
].
			self place: charStart; up; go: form width*scale; down].
			].
	wasDown ifFalse: [self up]
"
Display restoreAfter:
[Pen new squareNib: 2; color: Color red; turn: 45;
	print: 'The owl and the pussycat went to sea
in a beautiful pea green boat.' withFont: TextStyle defaultFont]
"! !

!Pen methodsFor: 'operations' stamp: 'sw 4/10/2003 22:37'!
putDotOfDiameter: aDiameter at: aPoint
	"Put a dot of the given size at the given point, using my colot"

	(FormCanvas on: destForm) 
			fillOval: (Rectangle center: aPoint extent: (aDiameter @ aDiameter))
			color: self color! !

!Pen methodsFor: 'operations'!
turn: degrees 
	"Change the direction that the receiver faces by an amount equal to the 
	argument, degrees."

	direction _ direction + degrees! !

!Pen methodsFor: 'operations'!
up
	"Set the state of the receiver's pen to up (no drawing)."

	penDown _ false! !


!Pen methodsFor: 'private' stamp: 'di 6/11/1998 16:09'!
location: aPoint direction: aFloat penDown: aBoolean
	location _ aPoint.
	direction _ aFloat.
	penDown _ aBoolean! !

!Pen methodsFor: 'private'!
sourceForm: aForm
	(aForm depth = 1 and: [destForm depth > 1])
		ifTrue: ["Map 1-bit source to all ones for color mask"
				colorMap _ Bitmap with: 0 with: 16rFFFFFFFF]
		ifFalse: [colorMap _ nil].
	^ super sourceForm: aForm! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Pen class
	instanceVariableNames: ''!

!Pen class methodsFor: 'examples' stamp: 'jm 5/6/1998 22:28'!
example
	"Draw a spiral with a pen that is 2 pixels wide."
	"Display restoreAfter: [Pen example]"

	| bic |
	bic _ self new.
	bic defaultNib: 2.
	bic color: Color blue.
	bic combinationRule: Form over.
	1 to: 100 do: [:i | bic go: i*4. bic turn: 89].
! !


!Pen class methodsFor: 'instance creation'!
new
	^ self newOnForm: Display! !

!Pen class methodsFor: 'instance creation'!
newOnForm: aForm
	| pen |
	pen _ super new.
	pen setDestForm: aForm.
	pen sourceOrigin: 0@0.
	pen home.
	pen defaultNib: 1.
	pen north.
	pen down.
	^ pen! !


!Pen class methodsFor: 'tablet drawing examples' stamp: 'ar 5/14/2001 23:35'!
feltTip: width cellSize: cellSize
	"Warning: This example potentially uses a large amount of memory--it creates a Form with cellSize squared bits for every Display pixel."
	"In this example, all drawing is done into a large, monochrome Form and then scaled down onto the Display using smoothing. The larger the cell size, the more possible shades of gray can be generated, and the smoother the resulting line appears. A cell size of 8 yields 64 possible grays, while a cell size of 16 gives 256 levels, which is about the maximum number of grays that the human visual system can distinguish. The width parameter determines the maximum line thickness. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 
	"Pen feltTip: 2.7 cellSize: 8"

	| tabletScale bitForm pen warp p srcR dstR nibSize startP r |
	tabletScale _ self tabletScaleFactor.
	bitForm _ Form extent: Display extent * cellSize depth: 1.
	pen _ Pen newOnForm: bitForm.
	pen color: Color black.
	warp _ (WarpBlt current toForm: Display)
		sourceForm: bitForm;
		colorMap: (bitForm colormapIfNeededFor: Display);
		cellSize: cellSize;
		combinationRule: Form over.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			p _ (Sensor tabletPoint * cellSize * tabletScale) rounded.
			nibSize _ (Sensor tabletPressure * (cellSize * width)) rounded.
		     nibSize > 0
				ifTrue: [
					pen squareNib: nibSize.
					startP _ pen location.
					pen goto: p.
					r _ startP rect: pen location.
					dstR _ (r origin // cellSize) corner: ((r corner + nibSize + (cellSize - 1)) // cellSize).
					srcR _ (dstR origin * cellSize) corner: (dstR corner * cellSize).
					warp copyQuad: srcR innerCorners toRect: dstR]
				ifFalse: [
					pen place: p]]].
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:20'!
inkBrush
	"Similar to simplePressurePen, but this example uses the average of the recent pen pressure values. The effect is that of a Japanese ink brush that comes up gradually off the paper as the brush is lifted, causing end (and beginning) of each stroke to taper. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 
	"Pen inkBrush"

	| tabletScale historyMSecs pressureHistory pen now currentPressure sum averagePressure p |
	tabletScale _ self tabletScaleFactor.
	historyMSecs _ 120.
	pressureHistory _ OrderedCollection new.
	pen _ Pen newOnForm: Display.
	pen color: Color black.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			"compute the average pressure over last historyMSecs milliseconds"
			now _ Time millisecondClockValue.
			currentPressure _ (20.0 * Sensor tabletPressure) rounded.
			pressureHistory addLast: (Array with: now with: currentPressure).
			[pressureHistory size > 0 and:
			 [(pressureHistory first first + historyMSecs) < now]]
				whileTrue: [pressureHistory removeFirst].  "prune old entries"
			sum _ pressureHistory inject: 0 into: [:t :e | t + e last].
			averagePressure _ sum // pressureHistory size.

			p _ (Sensor tabletPoint * tabletScale) rounded.
		     averagePressure > 0
				ifTrue: [
					pen roundNib: averagePressure.
					pen goto: p]
				ifFalse: [
					pen place: p]]].
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:13'!
simplePressurePen
	"An example of using a pressure sensitive pen to control the thickness of the pen. This requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 
	"Pen simplePressurePen"

	| tabletScale pen pressure p |
	tabletScale _ self tabletScaleFactor.
	pen _ Pen newOnForm: Display.
	pen color: Color black.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			p _ (Sensor tabletPoint * tabletScale) rounded.
			pressure _ (15.0 * Sensor tabletPressure) rounded.
		     pressure > 0
				ifTrue: [
					pen roundNib: pressure.
					pen goto: p]
				ifFalse: [
					pen place: p]]].
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:12'!
tabletScaleFactor
	"Answer a Point that scales tablet coordinates to Display coordinates, where the full extent of the tablet maps to the extent of the entire Display."

	| tabletExtent |
	tabletExtent _ Sensor tabletExtent.
	^ (Display width asFloat / tabletExtent x) @ (Display height asFloat / tabletExtent y)
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/12/1999 12:51'!
testMouseTracking
	"A very simple example of drawing using the mouse. Compare the tracking speed of this example with that of testTabletTracking. Mouse down to draw a stroke, shift-mouse to exit." 
	"Pen testMouseTracking"

	| pen p |
	pen _ Pen newOnForm: Display.
	pen roundNib: 8.
	pen color: Color black.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			p _ Sensor cursorPoint.
		     Sensor anyButtonPressed
				ifTrue: [pen goto: p]
				ifFalse: [
					pen color: Color random.
					pen place: p]]].
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:21'!
testTabletTracking
	"A very simple example of drawing using the pen of a digitizing tablet such as a Wacom ArtZ tablet. This requires the optional tablet support primitives which may not be supported on all platforms. Compare the tracking speed of this example with that of testMouseTracking. On a Macintosh, the tablet primitives provide roughly 120 samples/second versus only 60 mouse samples/second, and the difference is noticable. Works best in full screen mode. Mouse down to draw a stroke, shift-mouse to exit." 
	"Pen testTabletTracking"

	| tabletScale pen p |
	tabletScale _ self tabletScaleFactor.
	pen _ Pen newOnForm: Display.
	pen roundNib: 8.
	pen color: Color black.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			p _ (Sensor tabletPoint * tabletScale) rounded.
		     Sensor tabletPressure > 0
				ifTrue: [pen goto: p]
				ifFalse: [
					pen color: Color random.
					pen place: p]]].
! !
Pen subclass: #PenPointRecorder
	instanceVariableNames: 'points'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!PenPointRecorder commentStamp: '<historical>' prior: 0!
This class is a special kind of Pen that instead of actually drawing lines records the destination points for those lines. These points can later be accessed through my accessing method #points.

This can be useful when determining the boundaries of a drawing session.

Example:

| pen |
pen _ PenPointRecorder new.
pen up; goto: 100@100; down; goto: 120@120.
Transcript cr;
	show: 'Bounding box for drawing: ';
	show: (Rectangle encompassing: pen points)

Implementation note: Shouldn't we override #drawFrom:to:withFirstPoint: instead, and what about #drawLoopX:Y:? Aren't we missing those calls?!


!PenPointRecorder methodsFor: 'accessing' stamp: 'di 6/21/1998 09:35'!
points
	^ points! !


!PenPointRecorder methodsFor: 'line drawing' stamp: 'md 11/14/2003 16:56'!
drawFrom: p1 to: p2
	"Overridden to skip drawing but track bounds of the region traversed."

	points ifNil: [points _ OrderedCollection with: p1].
	points addLast: p2! !
Object subclass: #Phoneme
	instanceVariableNames: 'name properties'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phonetics'!
!Phoneme commentStamp: '<historical>' prior: 0!
My instances are phonemes. See also PhonemeSet class.!


!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:33'!
example
	^ self at: #example ifAbsent: []! !

!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:34'!
example: aString
	self at: #example put: aString! !

!Phoneme methodsFor: 'accessing' stamp: 'len 4/9/98 23:13'!
name
	^ name! !

!Phoneme methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
name: aString
	name := aString! !

!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:35'!
stress
	"Answer the stress level of the receiver."
	^ self at: #stress ifAbsent: [0]! !

!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:38'!
stress: aNumber
	"Set the stress level of the receiver."
	self at: #stress put: aNumber! !


!Phoneme methodsFor: 'comparing' stamp: 'len 6/1/1999 02:13'!
= aPhoneme
	^ self species == aPhoneme species and: [self name = aPhoneme name]! !

!Phoneme methodsFor: 'comparing' stamp: 'len 5/29/1999 04:01'!
hash
	^ self name hash! !


!Phoneme methodsFor: 'copying' stamp: 'len 6/9/1999 02:10'!
copy
	^ super copy properties: properties copy! !


!Phoneme methodsFor: 'printing' stamp: 'len 8/17/1999 01:19'!
printOn: aStream
	name isNil ifTrue: [^ super printOn: aStream].
	aStream nextPutAll: name.
	self stress > 0 ifTrue: [aStream print: self stress]! !


!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:28'!
addProperty: anObject
	self at: anObject put: #nothing! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:26'!
at: anObject
	^ properties at: anObject! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:45'!
at: anObject ifAbsent: aBlock
	properties isNil ifFalse: [^ properties at: anObject ifAbsent: aBlock].
	^ aBlock value! !

!Phoneme methodsFor: 'properties' stamp: 'stephaneducasse 2/3/2006 22:22'!
at: anObject put: anotherObject
	properties isNil ifTrue: [properties := IdentityDictionary new].
	^ properties at: anObject put: anotherObject! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/10/1999 01:46'!
hasProperty: anObject
	^ properties notNil and: [properties includesKey: anObject]! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:30'!
properties
	^ properties! !

!Phoneme methodsFor: 'properties' stamp: 'stephaneducasse 2/3/2006 22:22'!
properties: anIdentityDictionary
	properties := anIdentityDictionary! !


!Phoneme methodsFor: 'testing' stamp: 'len 6/9/1999 01:27'!
hasFeature: aSymbol
	^ self hasProperty: aSymbol! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isAffricate
	"Answer true if the receiver is an affricate phoneme."
	^ self hasFeature: #affricate! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isBackVowel
	"Answer true if the receiver is a back vowel phoneme."
	^ self isVowel and: [self hasFeature: #back]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isConsonant
	"Answer true if the receiver is a consonant phoneme."
	^ self hasFeature: #consonant! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isContinuant
	"Answer true if the receiver is a continuant phoneme."
	^ self hasFeature: #continuant! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isDiphthong
	"Answer true if the receiver is a diphthong phoneme."
	^ self hasFeature: #diphthong! !

!Phoneme methodsFor: 'testing' stamp: 'len 8/10/1999 00:26'!
isFricative
	"Answer true if the receiver is a fricative phoneme."
	^ self hasFeature: #fricative! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isFrontVowel
	"Answer true if the receiver is a front vowel phoneme."
	^ self isVowel and: [self hasFeature: #front]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isGlide
	"Answer true if the receiver is a glide phoneme."
	^ self hasFeature: #glide! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isLiquid
	"Answer true if the receiver is a liquid phoneme."
	^ self hasFeature: #liquid! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isMidVowel
	"Answer true if the receiver is a mid vowel phoneme."
	^ self isVowel and: [self hasFeature: #mid]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isNasal
	"Answer true if the receiver is an nasal phoneme."
	^ self hasFeature: #nasal! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 01:29'!
isNonContinuant
	"Answer true if the receiver is a noncontinuant phoneme."
	^ self isContinuant not! !

!Phoneme methodsFor: 'testing' stamp: 'len 8/16/1999 01:39'!
isObstruent
	"Answer true if the receiver is an obstruent phoneme."
	^ self isStop or: [self isFricative or: [self isAffricate]]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isSemivowel
	"Answer true if the receiver is a semivowel phoneme."
	^ self hasFeature: #semivowel! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/8/1999 01:21'!
isSilence
	"Answer true if the receiver is the silence phoneme."
	^ self hasFeature: #silence! !

!Phoneme methodsFor: 'testing' stamp: 'len 8/16/1999 01:39'!
isSonorant
	"Answer true if the receiver is a sonorant phoneme."
	^ self isObstruent not! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isStop
	"Answer true if the receiver is a stop phoneme."
	^ self hasFeature: #stop! !

!Phoneme methodsFor: 'testing' stamp: 'len 8/16/1999 00:46'!
isSyllabic
	"Answer true if the receiver is a syllabic consonant (or a vowel)."
	^ self isVowel or: [self isDiphthong]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isUnvoiced
	"Answer true if the receiver is an uvoiced phoneme."
	^ self hasFeature: #unvoiced! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isVoiced
	"Answer true if the receiver is a voiced phoneme."
	^ self hasFeature: #voiced! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/21/1999 19:55'!
isVoicedConsonant
	"Answer true if the receiver is a voiced consonant."
	^ self isVoiced and: [self isConsonant]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isVowel
	"Answer true if the receiver is a vowel phoneme."
	^ self hasFeature: #vowel! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isWhisper
	"Answer true if the receiver is an whisper phoneme."
	^ self hasFeature: #whisper! !


!Phoneme methodsFor: 'transforming' stamp: 'len 6/9/1999 01:35'!
stressed: aNumber
	^ self copy stress: aNumber! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Phoneme class
	instanceVariableNames: ''!

!Phoneme class methodsFor: 'instance creation' stamp: 'len 5/30/1999 01:17'!
name: aString
	^ self new name: aString! !

!Phoneme class methodsFor: 'instance creation' stamp: 'len 5/29/1999 04:34'!
name: aString example: anotherString
	^ self new name: aString; example: anotherString! !

!Phoneme class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/3/2006 22:23'!
name: aString example: anotherString features: anArray
	| answer |
	answer := self new name: aString; example: anotherString.
	anArray do: [ :each | answer addProperty: each].
	^ answer! !
Object subclass: #PhonemeRecognizer
	instanceVariableNames: 'phonemeRecords silentPhoneme'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phoneme Recognizer'!
!PhonemeRecognizer commentStamp: 'dd 2/18/2005 17:43' prior: 0!
I am experimental phoneme recognizer. My approach to phoneme recognition is fairly crude, but the goal is not full speech recognition, but merely a close enough approximation to drive the mouth of an animated character from speech input.

The phoneme recognizer has a collection of phoneme examples that were recorded in advance. Each of these phomemes has a "features vector" that describes that phoneme. Currently, feature vectors are basically a simplified version of the frequency spectrum measuring the sound energy in about two dozen frequency bands up to around 4000 Hz. The exact parameters are described in the class initialization method of PhonemeRecord and can be tweaked.

To do phoneme recognition, a short window of sound is analyzed via FFT, and its feature vector is extracted. This feature vector is then compared to the feature vectors of all phonemes in the example set. The phoneme that matches most closely is considered the currently sounding phoneme. This phoneme matching approach is similar to some of the earliest speech recognition work. However, current speech recognition software is generally driven by features derived from a linear predictive or vocal tract model of speech, rather than the raw spectrum data.!


!PhonemeRecognizer methodsFor: 'accessing' stamp: 'dd 2/18/2005 15:31'!
phonemes
	"Answer all phonemes available in the phoneme set."
	^ phonemeRecords ! !

!PhonemeRecognizer methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
phonemes: newPhonemes
	"Replace the phoneme set with new phonemes."
	phonemeRecords := newPhonemes ! !

!PhonemeRecognizer methodsFor: 'accessing' stamp: 'dd 2/18/2005 15:36'!
silentPhoneme
	"Answer a silent phoneme."
	^ silentPhoneme! !


!PhonemeRecognizer methodsFor: 'analysis' stamp: 'stephaneducasse 2/3/2006 22:22'!
findMatchesFor: aSampledSound
	"Process a sampled sound and return a sequence of phoneme matches for that sound."

	| out fftSize samplesPerInterval startIndex buf p |

	out := OrderedCollection new: 1000.
	fftSize := PhonemeRecord fftSize.
	samplesPerInterval := aSampledSound samplingRate / 24.0.
	1 to: (aSampledSound samples size - fftSize) + 1 by: samplesPerInterval do: [:i |
		startIndex := i truncated.
		buf := aSampledSound samples copyFrom: startIndex to: startIndex + fftSize - 1.
		p :=	self findMatchFor: buf samplingRate: aSampledSound samplingRate.
		out addLast: p.
	].
	^ out asArray.! !

!PhonemeRecognizer methodsFor: 'analysis' stamp: 'stephaneducasse 2/3/2006 22:22'!
findMatchFor: aSoundBuffer samplingRate: samplingRate
	"Find the phoneme whose features most closesly match those of the given sound buffer."

	| unknown bestMatch bestDistance d |
	unknown := PhonemeRecord new
		samples: aSoundBuffer samplingRate: samplingRate.
	unknown peakLevel > 1500
		ifTrue: [
			unknown computeFeatures.
			bestMatch := silentPhoneme.
			bestDistance := SmallInteger maxVal.
			phonemeRecords do: [:p |
				d := p featureDistanceFrom: unknown features to: p features.
				d < bestDistance ifTrue: [
					bestMatch := p.
					bestDistance := d]]]
		ifFalse: [bestMatch := silentPhoneme].
	^ bestMatch! !


!PhonemeRecognizer methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	phonemeRecords := OrderedCollection new.
	silentPhoneme := PhonemeRecord new initialize name: '...'.
	! !
AlignmentMorph subclass: #PhonemeRecognizerMorph
	instanceVariableNames: 'recognizer soundInput statusLight levelMeter phonemeDisplay currentPhoneme'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phoneme Recognizer'!
!PhonemeRecognizerMorph commentStamp: 'dd 2/18/2005 17:45' prior: 0!
I provide a morph for controlling a phoneme recognizer.

The first step is to plan how many different mouth positions will be used by the animation, and which phonemes map to which mouth positions. Traditional animators might draw four mouth positions for vowels and four to six for consonants.

The person whose speech is to be recognized then records phoneme examples for the phonemes to be recognized. For animation, these phonems might consist of the vowel sounds "eh", "ee", "ah", "o", "u" and the consonants "n", "r", "s", "sh", "th", "z", "l", "r", "w", and "m". In some cases "f" and "v" might also be included. The consonants "b" and "p" are also significant in animation, since these sounds, like "m", bring the lips together. Unfortunately, "b" and "p" are tricky to recognize with the scheme used here because they are actually two things in quick succession: a momentary silence followed by the sound of the released breath. However, if the mouth position for silence is drawn with the mouth closed, then the animation of "b" and "p" will probably look okay.

Each phoneme example is recorded by clicking the "add" button and speaking the phoneme into the microphone. Leading and trailing silence is automatically removed. The user is prompted for the phoneme name and a mouth position index. The name is just a mnemonic for the user. The index can be used to select a costume from a holder during animation. It is handy to list and number the mouth positions before recording the phoneme example set.

A phoneme can be reviewed with the "play phoneme" menu command. If it contains noise, includes slides between several different sounds, or doesn't sound like a representative example of the phoneme, delete it and record it again. English contains a number of "diphthongs"--vowel sounds that are actually slides between two different vowel sounds, as in the words "boy" or "boat". It is best to record each component of a diphthong individually. You can also set the name and mouth position index for the "silence" phoneme, the phoneme that is reported whenever the input sound falls below a certain threshold. A graphical view of the features vector for a given phoneme can be generated by selecting "show phoneme features" from the menu. A phoneme set can be saved to a file and restored later.

Once you have recorded your phoneme examples, you can try them by clicking the "run" button and speaking into the microphone. You should see the phoneme display update to report the current match. The "match sound file" menu command can be used to analyze an entire AIFF or a WAV sound file at once. The resulting phoneme stream is currently reported by opening an inspector on the phoneme list. There is one phoneme in this list for each 1/24th of a second window of sound in the sound file.

To allow use of the phoneme recognizer in tile scripts, the "mouth position tile" menu command creates a tile that reports the current phonemes mouth position index. This can be used to set the cursor of a holder containing the set of mouth position drawings. A two-line tile script can thus drive the mouth of an animated character. On a reasonably fast machine, the current phoneme can be watched by a program and used to drive real-time mouth animation.!


!PhonemeRecognizerMorph methodsFor: 'accessing' stamp: 'jm 5/18/2000 18:28'!
currentPhonemeMouthPosition
	"Answer the mouth position index (a position integer) of the currently matching phoneme."

	^ currentPhoneme mouthPosition
! !

!PhonemeRecognizerMorph methodsFor: 'accessing' stamp: 'jm 5/18/2000 18:27'!
currentPhonemeName
	"Answer the name of the currently matching phoneme."

	^ currentPhoneme name
! !


!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
addPhoneme
	"Record and add a new phoneme example to my phoneme set. Prompt the user for its name and mouth position."

	| phoneme |
	self stopRecognizing.
	Utilities
		informUser: 'Press and hold the mouse button while speaking the phoneme.'
		during: [Sensor waitButton].
	soundInput isRecording ifTrue: [self stop].
	phoneme := PhonemeRecord new initialize.
	phoneme recordWithLevel: soundInput recordLevel.
	phoneme samples size < 10000 ifTrue: [
		^ self inform: 'Nothing recorded; check the record input source and adjust the level'].

	self promptForDetailsOfPhoneme: phoneme.
	recognizer phonemes add: phoneme.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
changePhonemeDetails
	"Change the name and mouth position index of a phoneme specified by the user."

	| phoneme |
	phoneme := self selectPhonemeFromMenu: 'Phoneme to rename'.
	phoneme ifNotNil: [self promptForDetailsOfPhoneme: phoneme].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
deletePhoneme
	"Delete a phoneme specified by the user."

	| phoneme |
	phoneme := self selectPhonemeFromMenu: 'Phoneme to delete'.
	phoneme ifNotNil: [
		recognizer phonemes remove: phoneme ifAbsent: [] ].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
invokeMenu
	"Invoke the settings menu."

	| aMenu |
	aMenu := CustomMenu new.
	aMenu title: 'Phoneme Recognizer'.
	aMenu addList:	#(
		('add phoneme'				addPhoneme)
		('play phoneme'				playPhoneme)
		('show phoneme features'	showPhonemeFeatures)
		('change phoneme name'	changePhonemeDetails)
		('set phoneme for silence'	setSilentPhoneme)
		('delete phoneme'			deletePhoneme)
		-
		('mouth position tile'		makeTile)
		('phoneme name tile'		makePhonemeNameTile)
		('match sound file'			matchSoundFile)
		-
		('save phonemes to file'		savePhonemes)
		('read phonemes from file'	readPhonemes)
		-
		('help'						presentHelp)).
	aMenu invokeOn: self defaultSelection: nil.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dd 2/18/2005 13:13'!
makePhonemeNameTile
	"Make a scripting tile to fetch the current phoneme's name."
	self makeTile: #getPhonemeName ofType: #String.! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dd 2/18/2005 13:04'!
makeTile
	"Make a scripting tile to fetch the current phoneme's mouth position."
	self makeTile: #getMouthPosition ofType: #Number.! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
matchSoundFile
	"Process an AIFF or WAV sound file and generate a sequence of phoneme matches for that file in the Transcript. When done, open an inspector on the resulting collection of phonemes."

	| fileName snd phonemes |
	fileName := Utilities
		chooseFileWithSuffixFromList: #('.aif' '.aiff' '.wav')
		withCaption: 'Sound file?'.
	fileName = #none ifTrue: [^ self inform: 'No sound files.'].

	('*aif*' match: fileName) ifTrue:
		[snd := SampledSound fromAIFFfileNamed: fileName].
	('*wav' match: fileName) ifTrue:
		[snd := SampledSound fromWaveFileNamed: fileName].

	phonemes := recognizer findMatchesFor: snd.
	phonemes collect: [ :p | Transcript show: p name. ].
	phonemes inspect.! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
playPhoneme
	"Play a phoneme specified by the user."

	| phoneme |
	
	phoneme := self selectPhonemeFromMenu: 'Phoneme to play'.
	phoneme ifNotNil: [
		"Stop recognizing otherwise I can't play the phoneme"
		self stopRecognizing.
		"Play the phoneme"
		phoneme play.
	].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
readPhonemes
	"Read a previously saved phoneme set from a file."

	| fname s newPhonemes |
	fname := Utilities chooseFileWithSuffixFromList: #('.pho' '.phonemes')
				withCaption: 'Phoneme file?'.
	fname isNil ifTrue: [^self].
	fname ifNil: [^self].
	s := FileStream readOnlyFileNamed: fname.
	newPhonemes := s fileInObjectAndCode.
	s close.
	recognizer phonemes: newPhonemes! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
savePhonemes
	"Save the current phoneme set in a file."

	| fname refStream |
	fname := FillInTheBlank request: 'Phoneme file name?'.
	fname isEmpty ifTrue: [^ self].
	((fname endsWith: '.pho') or: [fname endsWith: '.phonemes'])
		ifFalse: [fname := fname, '.phonemes'].
	refStream := SmartRefStream fileNamed: fname.
	refStream nextPut: recognizer phonemes.
	refStream close.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dd 2/18/2005 15:55'!
setSilentPhoneme
	"Prompt the user for the name and mouth position associated with silence."

	self promptForDetailsOfPhoneme: recognizer silentPhoneme.
	phonemeDisplay contents: recognizer silentPhoneme name.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
showPhonemeFeatures
	"Show a graph of the features array for the phoneme selected by the user."

	| phoneme m |
	phoneme := self selectPhonemeFromMenu: 'Show Features'.
	phoneme ifNotNil: [
		m := ImageMorph new image: phoneme featuresGraph.
		self world firstHand attachMorph: m].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/22/2000 17:37'!
startRecognizing
	"Start recognizing phonemes from the sound input."

	self stopRecognizing.
	soundInput bufferSize: (PhonemeRecord fftSize).
	soundInput startRecording.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'stephaneducasse 2/3/2006 22:22'!
stopRecognizing
	"Stop listening."

	soundInput stopRecording.
	currentPhoneme := recognizer silentPhoneme.
! !


!PhonemeRecognizerMorph methodsFor: 'e-toy support' stamp: 'jm 5/22/2000 17:32'!
getMouthPosition
	"Answer the mouth position index (a position integer) of the currently matching phoneme. Sent by tile scripts."

	^ currentPhoneme mouthPosition
! !

!PhonemeRecognizerMorph methodsFor: 'e-toy support' stamp: 'dd 2/18/2005 15:35'!
getPhonemeName
	"Answer the name (a string) of the currently matching phoneme. Used by script tile."
	^ currentPhoneme name! !


!PhonemeRecognizerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	"PhonemeRecognizerMorph new openInWorld."
	
	| r |
	super initialize.

	soundInput := SoundInputStream new samplingRate: 22050.
	recognizer := PhonemeRecognizer new.

	borderWidth := 2.
	self listDirection: #topToBottom.
	"Morph must be told how to resize before adding submorphs, not after."
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	self addTitle.
	self addButtonRows.
	self addLevelSlider.
	r := AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: self makeLevelMeter.
	self addMorphBack: r.
	self addPhonemeDisplay.! !

!PhonemeRecognizerMorph methodsFor: 'initialization' stamp: 'dd 2/18/2005 15:52'!
presentHelp
	self class organization classComment asString openInWorkspaceWithTitle: 'About Phoneme Recognizer'.! !


!PhonemeRecognizerMorph methodsFor: 'stepping and presenter' stamp: 'stephaneducasse 2/3/2006 22:22'!
step
	"Update the record light, level meter, and display."

	| w buf |
	"update the record light and level meter"
	soundInput isRecording
		ifTrue: [statusLight color: Color yellow]
		ifFalse: [statusLight color: Color gray].
	w := ((121 * soundInput meterLevel) // 100) max: 1.
	levelMeter width ~= w ifTrue: [levelMeter width: w].

	soundInput isRecording ifTrue: [
		[soundInput bufferCount > 0] whileTrue: [
			"skip to the most recent buffer"
			buf := soundInput nextBufferOrNil].
		buf ifNotNil: [
			currentPhoneme := recognizer findMatchFor: buf samplingRate: soundInput samplingRate.
			phonemeDisplay contents: currentPhoneme name]].

! !

!PhonemeRecognizerMorph methodsFor: 'stepping and presenter' stamp: 'jm 5/10/2000 16:04'!
stopStepping
	"Turn off recording."

	super stopStepping.
	soundInput stopRecording.
! !


!PhonemeRecognizerMorph methodsFor: 'testing' stamp: 'jm 5/23/2000 05:48'!
stepTime

	^ 30
! !


!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
addButtonRows
	"Create and add my button row."

	| r |
	r := AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: ((self buttonName: 'Menu' action: #invokeMenu)
		actWhen: #buttonDown).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Add' action: #addPhoneme).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Run' action: #startRecognizing).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' action: #stopRecognizing).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: self makeStatusLight.
	self addMorphBack: r.
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
addLevelSlider
	"Create and add a slider to set the sound input level. This level is used both when recognizing and adding phonemes."

	| levelSlider r |
	levelSlider := SimpleSliderMorph new
		color: color;
		extent: 100@2;
		target: soundInput;
		actionSelector: #recordLevel:;
		adjustToValue: soundInput recordLevel.
	r := AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '0 ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' 10').
	self addMorphBack: r.
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
addPhonemeDisplay
	"Add a display to show the currently matching phoneme."

	| font r |
	font := StrikeFont familyName: 'Helvetica' size: 36.
	phonemeDisplay := StringMorph contents: '...' font: font.
	r := AlignmentMorph newColumn
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #rigid;
		height: 20.
	r addMorphBack: phonemeDisplay.
	self addMorphBack: (Morph new extent: 5@8; color: Color transparent).  "spacer"
	self addMorphBack: r.
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
addTitle
	"Add a title."

	| font title r |
	font := StrikeFont familyName: Preferences standardEToysFont familyName size: 20.
	title := StringMorph contents: 'Phoneme Recognizer' font: font.
	r := AlignmentMorph newColumn
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #rigid;
		height: 20.
	r addMorphBack: title.
	self addMorphBack: r.
	self addMorphBack: (Morph new extent: 5@8; color: Color transparent).  "spacer"
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'jm 5/22/2000 17:48'!
buttonName: aString action: aSymbol
	"Create a button of the given name to send myself the given unary message."

	^ SimpleButtonMorph new
		target: self;
		label: aString;
		actionSelector: aSymbol
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
makeLevelMeter
	"Create a recording level meter."

	| outerBox |
	outerBox := RectangleMorph new extent: 125@14; color: Color lightGray.
	levelMeter := Morph new extent: 2@10; color: Color yellow.
	levelMeter position: outerBox topLeft + (2@2).
	outerBox addMorph: levelMeter.
	^ outerBox

! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
makeStatusLight
	"Create a status light to show when the recognizer is running."

	| s |
	statusLight := RectangleMorph new extent: 24@19.
	statusLight color: Color gray.
	s := StringMorph contents: 'On'.
	s position: statusLight center - (s extent // 2).
	statusLight addMorph: s.
	^ statusLight
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
makeTile: anOperator ofType: aType
	"Make a scripting tile to fetch an operator. Attach it to the hand, allowing the user to drop it directly into a tile script."

	| tile argTile |
	tile := PhraseTileMorph new setSlotRefOperator: anOperator type: aType.
	argTile := self tileToRefer.
	argTile bePossessive.
	tile firstSubmorph addMorph: argTile.
	tile enforceTileColorPolicy.
	ActiveHand attachMorph: tile
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
promptForDetailsOfPhoneme: phoneme
	"Prompt the user for the name and mouth position of the given phoneme."

	| response |
	response := FillInTheBlank
		request: 'Phoneme name?'
		initialAnswer: phoneme name.
	response ifNotNil: [phoneme name: response].

	response := FillInTheBlank
		request: 'Mouth Position Index?'
		initialAnswer: phoneme mouthPosition printString.
	response ifNotNil: [phoneme mouthPosition: response asNumber asInteger].

! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:22'!
selectPhonemeFromMenu: title
	"Answer the phone selected by the user from a menu of the current phoneme records. Answer nil if the user does not select any phoneme."

	| aMenu |
	recognizer phonemes isEmpty ifTrue: [self inform: 'The phoneme database is empty.'. ^ nil].
	aMenu := CustomMenu new title: title.
	recognizer phonemes do: [:phoneme |
		aMenu add: phoneme name action: phoneme].
	^ aMenu startUp
! !
ClassTestCase subclass: #PhonemeRecognizerTest
	instanceVariableNames: 'recognizer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phoneme Recognize-Test'!
!PhonemeRecognizerTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class PhonemeRecognizer.!


!PhonemeRecognizerTest methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/3/2006 22:22'!
setUp
	recognizer := PhonemeRecognizer new initialize.
	recognizer phonemes add: PhonemeRecordTest sampleOne; add: PhonemeRecordTest sampleTwo.! !


!PhonemeRecognizerTest methodsFor: 'testing' stamp: 'stephaneducasse 2/3/2006 22:22'!
testFindMatchFor
	| soundBuffer bestMatch |
	soundBuffer := SoundBuffer fromArray: (Array new: 512 withAll: 0).
	bestMatch := recognizer findMatchFor: soundBuffer samplingRate: 22050.
	"Because the sound buffer is empty, the recognizer should find nothing but an empty  phoneme record."
	self assert: bestMatch name = '...'.
	 ! !
Object subclass: #PhonemeRecord
	instanceVariableNames: 'name mouthPosition samples samplingRate features'
	classVariableNames: 'AverageFeatures CutoffFreq FFTSize FilterBandwidth HighFreqWeight'
	poolDictionaries: ''
	category: 'Speech-Phoneme Recognizer'!
!PhonemeRecord commentStamp: '<historical>' prior: 0!
I represent a single phoneme. I contain the phoneme's name and an integer that represents the mouth position associated with this phoneme. This integer can be used as an index to select the mouth shape for an animated character. I also contain a 'features vector' derived from an analysis of my sound; this 'features vector' is the basis of matching during phoneme recognition. I also retain the original sound from which the features were computed so that it can be re-analyzed to create a new feature vector when the analysis algorithm is changed.
!


!PhonemeRecord methodsFor: 'access' stamp: 'stephaneducasse 2/3/2006 22:22'!
features
	"Answer the features vector for this phoneme, an array of numbers used in the phoneme matching process. Compute the features if necessary."

	features ifNil: [
		AverageFeatures
			ifTrue: [features := self averageFeatures]
			ifFalse: [features := self featuresAtCenter]].
	^ features
! !

!PhonemeRecord methodsFor: 'access' stamp: 'stephaneducasse 2/3/2006 22:22'!
features: anObject

	features := anObject.
! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/19/2000 23:11'!
mouthPosition
	"Answer the mouth position associated with this phoneme, a positive integer that can be used to index into a collection of frames for an animation."

	^ mouthPosition! !

!PhonemeRecord methodsFor: 'access' stamp: 'stephaneducasse 2/3/2006 22:22'!
mouthPosition: anInteger

	mouthPosition := anInteger.
! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/17/2000 17:55'!
name
	"Answer the name the user gave this phoneme."

	^ name! !

!PhonemeRecord methodsFor: 'access' stamp: 'stephaneducasse 2/3/2006 22:22'!
name: anObject

	name := anObject.! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/17/2000 17:53'!
samples
	"Answer the SoundBuffer containing my sampled sound data."

	^ samples
! !

!PhonemeRecord methodsFor: 'access' stamp: 'stephaneducasse 2/3/2006 22:22'!
samples: aSoundBuffer samplingRate: aNumber
	"Set my samples and sampling rate, and clear my cached features vector."

	samples := aSoundBuffer.
	samplingRate := aNumber.
	self clearFeatures.
! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/17/2000 17:55'!
samplingRate
	"Answer the sampling rate used to record my samples."

	^ samplingRate
! !


!PhonemeRecord methodsFor: 'feature analysis' stamp: 'stephaneducasse 2/3/2006 22:22'!
averageFeatures
	"Compute the average features vector across my sound samples."

	| startI endI featureVectors |
	"skip the first and last bits"
	startI := (samplingRate // 5).
	endI := samples monoSampleCount - (samplingRate // 5).
	endI - startI < FFTSize ifTrue: [^ self extractFeaturesAt: endI].

	featureVectors := (startI to: endI by: FFTSize)
		collect: [:i | (self extractFeaturesAt: i)].
	^ self prunedAverageFeatures: featureVectors
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'stephaneducasse 2/3/2006 22:22'!
clearFeatures
	"Clear my features vector cache. This must be done when new sample data is recorded or when the analysis algorithm is changed."

	features := nil.
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/18/2000 22:21'!
computeFeatures
	"Compute and record a features vector take from the start of my samples. This method is typically used to analyze a single buffer during recognition."

	self features: (self extractFeaturesAt: 1).
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/21/2000 09:28'!
distanceToPhoneme: otherPhoneme
	"Answer the distance in feature space between this phoneme and the given phoneme."

	^ self featureDistanceFrom: self features to: otherPhoneme features
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'stephaneducasse 2/3/2006 22:22'!
extractFeaturesAt: startIndex
	"Extract a features vector from the given point in my samples."

	| spectrum cutoffIndex binSize s i avg unscaledFeatures total |
	spectrum := (FFT new: FFTSize)
		transformDataFrom: samples
		startingAt: (startIndex min: (samples monoSampleCount - FFTSize + 1)).

	cutoffIndex := ((CutoffFreq * spectrum size) / (samplingRate / 2)) rounded.
	binSize := ((FilterBandwidth * spectrum size) / (samplingRate / 2)) rounded.

	s := WriteStream on: (Array new: 50).
	i := 2. "skip first bin of FFT data, which just contains the D.C. component"
	[i < cutoffIndex] whileTrue: [
		avg := (spectrum copyFrom: i to: i + binSize - 1) sum / binSize.
		s nextPut: avg.
		i := i + binSize].

	"final entry of feature vector sums all energy above the cutoff frequency"
	s nextPut: HighFreqWeight *
		((spectrum copyFrom: i to: spectrum size) sum / (spectrum size + 1 - i)).

	unscaledFeatures := s contents.
	total := unscaledFeatures sum.
	^ unscaledFeatures collect: [:n | (1000.0 * n) // total].
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'stephaneducasse 2/3/2006 22:22'!
featureDistanceFrom: featuresVec1 to: featuresVec2
	"Answer the distance between the given two feature vectors. The lower this value, the closer the phonemes match."

	| sumOfSquares |
	sumOfSquares := 0.
	1 to: featuresVec1 size do: [:i |
		 sumOfSquares := sumOfSquares +
			((featuresVec1 at: i) - (featuresVec2 at: i)) squared].
	^ sumOfSquares sqrt
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/17/2000 19:54'!
featuresAtCenter
	"Answer the features vector computed from a single FFT window taken from the center of my samples."

	^ self extractFeaturesAt: (samples monoSampleCount // 2)
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'stephaneducasse 2/3/2006 22:22'!
peakLevel
	"Answer the absolute value of the peak sample value my buffer."

	| maxVal v |
	maxVal := 0.
	1 to: samples size do: [:i |
		v := samples at: i.
		v < 0 ifTrue: [v := 0 - v].
		v > maxVal ifTrue: [maxVal := v]].
	^ maxVal
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/21/2000 09:28'!
phonemeDistanceTo: otherPhoneme
	"Answer the distance in feature space between this phoneme and the given phoneme."

	^ self featureDistanceFrom: self features to: otherPhoneme features
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'stephaneducasse 2/3/2006 22:22'!
prunedAverageFeatures: featureVectors
	"Compute the average of the given collection of feature vectors, then discard the outliers and average the remainding feature vectors. The result is an average of the most typical feature vectors in the given collection."

	| centroid sum vectorsWithErrors filtered |
	"compute the average of all the feature vectors"
	centroid := (1 to: featureVectors first size) collect: [:i |
		sum := 0.
		1 to: featureVectors size do: [:j | sum := sum + ((featureVectors at: j) at: i)].
		(sum asFloat / featureVectors size) rounded].

	"sort vectors by their distance from the centroid"
	vectorsWithErrors := SortedCollection sortBlock: [:e1 :e2 | e1 last < e2 last].
	featureVectors do: [:v |
		vectorsWithErrors add: (Array with: v with: (self featureDistanceFrom: v to: centroid))].

	"reject outlying feature vectors"
	filtered := (1 to: (0.8 * vectorsWithErrors size) rounded)
		collect: [:i | (vectorsWithErrors at: i) first].

	"answer the average of the remaining feature vectors"
	^ (1 to: filtered first size) collect: [:i |
		sum := 0.
		1 to: filtered size do: [:j | sum := sum + ((filtered at: j) at: i)].
		(sum asFloat / filtered size) rounded].

! !


!PhonemeRecord methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize

	name := ''.
	mouthPosition := 1.
	samples := SoundBuffer new.
	samplingRate := 22050.
	features := nil.
! !


!PhonemeRecord methodsFor: 'other' stamp: 'stephaneducasse 2/3/2006 22:22'!
featuresGraph
	"Answer a Form containing a pictorial view of my features vector."

	| labelForm graphHeight barWidth bottom f min max scale x h |
	labelForm := name asParagraph asForm.
	graphHeight := 100.
	barWidth := 5.
	bottom := graphHeight + 2.  "2 pixel border"
	f := Form
		extent: (self features size * barWidth) @ (graphHeight + labelForm height + 5)
		depth: 16.
	f fillWhite: f boundingBox.
	f border: f boundingBox width: 2.

	min := 1.0e30.
	max := -1.0e30.
	features do: [:v |
		v < min ifTrue: [min := v].
		v > max ifTrue: [max := v]].
	scale := (graphHeight - 1) asFloat / (max - min).
	x := 2.
	self features do: [:v |
		h := (scale * (v - min)) asInteger.
		f fill: ((x@(bottom - h)) extent: barWidth@h) fillColor: (Color r: 0.581 g: 0.581 b: 0.0).
		x := x + barWidth].
	f fillBlack: ((0@bottom) extent: (f width@1)).
	labelForm displayOn: f
		at: ((f width - labelForm width) // 2)@bottom
		rule: Form paint.
	^ f
! !

!PhonemeRecord methodsFor: 'other' stamp: 'jm 5/17/2000 17:58'!
play
	"Playback my samples."

	(SampledSound samples: samples samplingRate: samplingRate) play.
! !

!PhonemeRecord methodsFor: 'other' stamp: 'stephaneducasse 2/3/2006 22:22'!
recordWithLevel: recordLevel
	"Initialize my sound samples by recording a snippet of sound while the mouse is held down. Trim off leading and trailing silence, and normalize the level of the recording."

	| recorder |
	"record the sound"
	recorder := SoundRecorder new
		samplingRate: samplingRate;
		recordLevel: recordLevel;
		clearRecordedSound.
	Utilities
		informUser: 'Recording a phoneme. Release the mouse button when done.'
		during: [
			recorder resumeRecording.
			Sensor waitNoButton.
			recorder stopRecording].
	Utilities
		informUser: 'Removing leading/trailing silence...'
		during: [
			samples := recorder condensedSamples.
			samples size > 0 ifTrue: [
				samples := self trimAndNormalize: samples]].

	self clearFeatures.
! !

!PhonemeRecord methodsFor: 'other' stamp: 'stephaneducasse 2/3/2006 22:22'!
trimAndNormalize: aSoundBuffer
	"Trim leading and trailing silence and normalize the sound level of the given samples."

	| lastSampleIndex maxLevel v threshold startI endI adjust count result |
	"skip the sound of the terminating mouse click..."
	lastSampleIndex := (aSoundBuffer monoSampleCount - (samplingRate // 10)) max: 1.

	"find maximum level"
	maxLevel := 0.

	1 to: lastSampleIndex do: [:i |
		v := aSoundBuffer at: i.
		v < 0 ifTrue: [v := 0 - v].
		v > maxLevel ifTrue: [maxLevel := v]].

	"find indices of start and end"
	threshold := (0.1 * maxLevel) asInteger.
	startI := 1.
	[(aSoundBuffer at: startI) < threshold]
		whileTrue: [startI := startI + 1].  "scan for starting point"
	endI := lastSampleIndex.
	[(aSoundBuffer at: endI) < threshold]
		whileTrue: [endI := endI - 1].  "scan for ending point"

	"extend range by a twentieth of a second on both ends"
	startI := (startI - (samplingRate // 20)) max: 1.
	endI := (endI + (samplingRate // 20)) min: aSoundBuffer monoSampleCount.

	adjust := (10000 * (30000 / maxLevel)) asInteger.  "fixed point constant for speed"
	count := (endI - startI) + 1.
	result := SoundBuffer newMonoSampleCount: (endI - startI) + 1.
	1 to: count do: [:i |
		v := (adjust * (aSoundBuffer at: (startI + i - 1))) // 10000.
		result at: i put: v].

	^ result
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhonemeRecord class
	instanceVariableNames: ''!

!PhonemeRecord class methodsFor: 'class initialization' stamp: 'jm 5/22/2000 17:36'!
fftSize
	"Answer the FFT size for frequency analysis. It must be a power of two."

	^ FFTSize
! !

!PhonemeRecord class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/3/2006 22:23'!
initialize
	"Initialize the parameter used to extract phoneme features. After changing these parameters, execute 'PhonemeRecord initialize'. The features vectors of any existing phoneme records will be cleared and recomputed as needed."
	"PhonemeRecord initialize"

	FFTSize := 512.			"size of FFT for analysis; this must be a power of two"
	CutoffFreq := 4000.		"boundary between fine and coarse ranges"
	FilterBandwidth := 160.	"bandwidth of each frequency band in the fine range"
	HighFreqWeight := 5.		"weighting of energy above the cutoff frequency"
	AverageFeatures := false.
		"If AverageFeatures is true, then average features over the phoneme recording. Otherwise, extract features from the center of the recording."

	"clear all cached feature vectors"
	PhonemeRecord allInstancesDo: [:p | p clearFeatures].
! !
ClassTestCase subclass: #PhonemeRecordTest
	instanceVariableNames: 'phoneme'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phoneme Recognize-Test'!

!PhonemeRecordTest methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/3/2006 22:22'!
setUp
	phoneme := PhonemeRecordTest sampleOne.! !


!PhonemeRecordTest methodsFor: 'testing' stamp: 'stephaneducasse 2/3/2006 22:22'!
testDistanceToPhoneme
	| p distance |
	p := PhonemeRecordTest sampleTwo.
	distance := phoneme distanceToPhoneme: p.
	self assert: distance > 0.
	distance := phoneme distanceToPhoneme: phoneme.
	self assert: distance = 0.! !

!PhonemeRecordTest methodsFor: 'testing' stamp: 'dd 2/18/2005 16:44'!
testFeatures
	self deny: phoneme features isEmptyOrNil.! !

!PhonemeRecordTest methodsFor: 'testing' stamp: 'stephaneducasse 2/3/2006 22:22'!
testMouthPosition
	| p |
	p := PhonemeRecordTest sampleOne.
	self assert: phoneme mouthPosition = p mouthPosition.
	phoneme mouthPosition: 3.
	self assert: phoneme mouthPosition = 3.! !

!PhonemeRecordTest methodsFor: 'testing' stamp: 'stephaneducasse 2/3/2006 22:22'!
testName
	| p |
	p := PhonemeRecordTest sampleOne.
	self assert: phoneme name = p name.
	phoneme name: 'p3'.
	self assert: phoneme name = 'p3'.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhonemeRecordTest class
	instanceVariableNames: ''!

!PhonemeRecordTest class methodsFor: 'as yet unclassified' stamp: 'dd 2/18/2005 17:27'!
sampleOne
	^ PhonemeRecord new name: 'a'; mouthPosition: 1; features: #(221 341 240 128 22 8 3 3 2 2 2 1 1 2 2 1 1 1 1 1 1 1 0 3).! !

!PhonemeRecordTest class methodsFor: 'as yet unclassified' stamp: 'dd 2/18/2005 17:27'!
sampleTwo
	^ PhonemeRecord new name: 'a'; mouthPosition: 2; features: #(632 232 28 11 6 15 5 7 3 2 3 4 5 3 3 1 2 2 2 4 5 2 2 7).! !
Object subclass: #PhonemeSet
	instanceVariableNames: 'name description phonemes specials'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phonetics'!
!PhonemeSet commentStamp: '<historical>' prior: 0!
My instances are phoneme sets, i.e. phonetic alphabets.
There are several "standard" phoneme sets used among phoneticians. We choosed ARPABET to be the default phoneme set in this system, but other examples are implemented, such as DARPA (radio), MRPA and SAMPA. As well, mappings from those phoneme sets to ARPABET are provided.!


!PhonemeSet methodsFor: 'accessing' stamp: 'len 5/31/1999 01:00'!
add: aPhoneme
	^ phonemes at: aPhoneme name put: aPhoneme! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 5/31/1999 03:45'!
at: aString
	^ phonemes at: aString! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 5/31/1999 03:45'!
at: aString ifAbsent: aBlock
	^ phonemes at: aString ifAbsent: aBlock! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/22/1998 00:53'!
description
	^ description! !

!PhonemeSet methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
description: aString
	description := aString! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/22/1998 00:53'!
name
	^ name! !

!PhonemeSet methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:22'!
name: aString
	name := aString! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/8/1999 00:55'!
names
	"Answer the names of all the phonemes."
	^ phonemes keys! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/5/1999 01:43'!
pause
	^ self silence! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 5/31/1999 01:00'!
phonemes
	^ phonemes values! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/5/1999 01:43'!
silence
	^ self specials at: #silence! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/2/1999 02:46'!
specials
	^ specials! !


!PhonemeSet methodsFor: 'copying' stamp: 'len 5/31/1999 01:35'!
copy
	^ self class new addAll: self phonemes; yourself! !


!PhonemeSet methodsFor: 'enumerating' stamp: 'len 8/22/1999 18:27'!
do: aBlock
	phonemes do: aBlock! !


!PhonemeSet methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:22'!
initialize
	phonemes := Dictionary new.
	specials := Dictionary new! !


!PhonemeSet methodsFor: 'printing' stamp: 'len 5/28/1999 02:55'!
printOn: aStream
	name isNil ifTrue: [^ super printOn: aStream].
	aStream nextPutAll: name, ' phoneme set'! !


!PhonemeSet methodsFor: 'transcribing' stamp: 'len 5/31/1999 03:26'!
transcriptionOf: aString
	^ (aString findTokens: '/ ')
		collect: [ :each |
			each last isDigit
				ifTrue: [(self at: (each copyFrom: 1 to: each size - 1))
							stressed: each last asString asNumber]
				ifFalse: [self at: each]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhonemeSet class
	instanceVariableNames: 'arpabet'!

!PhonemeSet class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/3/2006 22:23'!
initialize
	"
	PhonemeSet initialize
	"
	arpabet := self new name: 'ARPAbet'; description: 'This is the ARPAbet phonetic alphabet.'.
	#("Name"	"Example"	"Features"
		('iy'	'heed'		#(continuant vowel front))
		('ih'	'hid'		#(continuant vowel front))
		('ey'	'hayed'		#(continuant vowel front))
		('eh'	'head'		#(continuant vowel front))
		('ae'	'had'		#(continuant vowel front))
		('aa'	'hod'		#(continuant vowel back))
		('ao'	'hawed'		#(continuant vowel back))
		('ow'	'hoed'		#(continuant vowel back))
		('uh'	'hood'		#(continuant vowel back))
		('uw'	'who''d'		#(continuant vowel back))
		('er'	'heard'		#(continuant vowel mid))
		('ax'	'ago'		#(continuant vowel mid))
		('ah'	'mud'		#(continuant vowel mid))
		('ay'	'hide'		#(diphthong))
		('aw'	'how''d'		#(diphthong))
		('oy'	'boy'		#(diphthong))
		('ix'		'roses'		#())
		('p'		'pea'		#(consonant stop unvoiced))
		('b'		'bat'		#(consonant stop voiced))
		('t'		'tea'		#(consonant stop unvoiced))
		('d'		'deep'		#(consonant stop voiced))
		('k'		'kick'		#(consonant stop unvoiced))
		('g'		'go'			#(consonant stop voiced))
		('f'		'five'		#(continuant consonant fricative unvoiced))
		('v'		'vice'		#(continuant consonant fricative voiced))
		('th'	'thing'		#(continuant consonant fricative unvoiced))
		('dh'	'then'		#(continuant consonant fricative voiced))
		('s'		'so'			#(continuant consonant fricative unvoiced))
		('z'		'zebra'		#(continuant consonant fricative voiced))
		('sh'	'show'		#(continuant consonant fricative unvoiced))
		('zh'	'measure'	#(continuant consonant fricative voiced))
		('hh'	'help'		#(continuant consonant whisper))
		('m'		'mom'		#(continuant consonant nasal))
		('n'		'noon'		#(continuant consonant nasal))
		('ng'	'sing'		#(continuant consonant nasal))		"old name: nx"
		('l'		'love'		#(semivowel liquid))
		('el'		'cattle')
		('em'	'some')
		('en'	'son')
		('dx'	'batter')
		('q'		'[glottal stop]')
		('w'		'want'		#(continuant semivowel glide))
		('y'		'yard'		#(continuant semivowel glide))
		('r'		'race'		#(continuant semivowel liquid))
		('ch'	'church'	#(continuant consonant affricate))
		('jh'	'just'		#(continuant consonant affricate))
		('wh'	'when'		#(semivowel liquid))
	"not found in the original:"
		('sil'	'[silence]'	#(silence))
		('ll'		'')	"dark l"
		('ai'	''			#(vowel))	"what is this?"
		('ia'	''			#(vowel))
		('ea'	''			#(vowel))
		('ua'	''			#(vowel))
		('aor'	'')
		('rx'	''			#())
	) do: [ :each |
		arpabet add: (each size > 2
						ifTrue: [Phoneme name: each first example: each second features: each last]
						ifFalse: [Phoneme name: each first example: each last])].
	arpabet specials at: #silence put: (arpabet at: 'sil')! !


!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/10/1999 04:12'!
arpabet
	"Answer the ARPAbet phoneme set."
	^ arpabet! !

!PhonemeSet class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
arpabetToSampa
	"Answer a dictionary with ARPAbet phonemes
	as keys and SAMPA phoneme names as values."

	| answer |
	answer := Dictionary new.
	self sampaToArpabet associationsDo: [ :each | answer at: each value put: each key].
	^ answer! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/10/1999 04:12'!
darpa
	"Answer the DARPA phoneme set."
	^ self radio! !

!PhonemeSet class methodsFor: 'examples' stamp: 'md 7/15/2006 18:08'!
dectalkToArpabet
	"Answer a dictionary with DECTalk phoneme names
	as keys and ARPAbet phonemes as values."

	| answer |
	answer := Dictionary new.
	self arpabet do: [ :each | answer at: each name put: each].
	#(
		('nx'	'ng')
		('yx'	'jh')
		('lx'		'l')
		('rr'	'r')
		('u'		'uw')
		('hx'	'hh')
		('h'		'hh')
		('_'		'sil')) do: [ :each | answer at: each first put: (self arpabet at: each last)].
	^ answer! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 5/31/1999 00:25'!
default
	^ self arpabet! !

!PhonemeSet class methodsFor: 'examples' stamp: 'md 7/15/2006 18:08'!
mactalkToArpabet
	"Answer a dictionary with MacTalk phoneme names
	as keys and ARPAbet phonemes as values."

	| answer |
	answer := Dictionary new.
	#(	
		('IY'	'iy')
		('IH'	'ih')
		('EY'	'ey')
		('EH'	'eh')
		('AE'	'ae')
		('AA'	'aa')
		('AO'	'ao')
		('OW'	'ow')
		('UH'	'uh')
		('UW'	'uw')
"		(''	'er')"
		('AX'	'ax')
		('AH'	'ah')
		('AY'	'ay')
		('AW'	'aw')
		('OY'	'oy')
"		(''	'ix')"
		('p'		'p')
		('b'		'b')
		('t'		't')
		('d'		'd')
		('k'		'k')
		('g'		'g')
		('f'		'f')
		('v'		'v')
		('T'		'th')
		('D'		'dh')
		('s'		's')
		('z'		'z')
		('S'		'sh')
		('Z'		'zh')
		('h'		'hh')
		('m'		'm')
		('n'		'n')
		('N'		'ng')
		('l'		'l')
		('w'		'w')
		('y'		'y')
		('r'		'r')
		('C'		'ch')
		('J'		'jh')
		('UX'	'ax')
		('_'		'sil')
		('~'		'sil')) do: [ :each | answer at: each first put: (self arpabet at: each last)].
	^ answer! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/10/1999 04:11'!
mrpa
	"Answer the MRPA phoneme set."
	self notYetImplemented! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/21/1999 20:46'!
mrpaToArpabet
	"Answer a dictionary with MRPA phoneme names
	as keys and ARPAbet Phonemes as values."

	self notYetImplemented! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/8/1999 01:55'!
radio
	"Answer the radio phoneme set, named after the BU RADIO FM corpus."
	self notYetImplemented! !

!PhonemeSet class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
sampa
	"Answer the sampa phoneme set."
	| answer mapping |
	mapping := self sampaToArpabet.
	answer := self new.
	mapping keysDo: [ :each | answer add: ((self arpabet at: (mapping at: each)) copy name: each)].
	^ answer! !

!PhonemeSet class methodsFor: 'examples' stamp: 'md 7/15/2006 18:08'!
sampaToArpabet
	"Answer a dictionary with SAMPA phoneme names
	as keys and ARPAbet phonemes as values."

	| answer |
	answer := Dictionary new.
	#(	('p'		'p')
		('b'		'b')
		('t'		't')
		('d'		'd')
		('k'		'k')
		('m'		'm')
		('n'		'n')
		('l'		'l')
		('r'		'r')
		('f'		'f')
		('v'		'v')
		('s'		's')
		('z'		'z')
		('h'		'hh')
		('w'		'w')
		('g'		'g')
		('tS'		'ch')
		('dZ'	'jh')
		('N'		'ng')
		('T'		'th')
		('D'		'dh')
		('S'		'sh')
		('Z'		'zh')
		('j'		'y')
		('i:'		'iy')
		('i'		'iy')
		('A:'	'aa')
		('A'		'aa')
		('O:'	'ao')
		('O'		'ao')
		('u:'	'uw')
		('u'		'uw')
		('3:'		'er')
		('r='	'er')
		('I'		'ih')
		('e'		'eh')
		('E'		'eh')
		('{'		'ae')
		('V'		'ah')
		"	('Q'		'oh')"
		('U'		'uh')
		('@'		'ax')
		('eI'		'ey')
		('aI'	'ay')
		('OI'	'oy')
		('@U'	'ow')
		('aU'	'aw')
		('I@'	'ia')
		('e@'	'ea')
		('U@'	'ua')
		('AI'	'ay')
		('EI'		'ey')
		('4'		't')
		('_'		'sil')) do: [ :each | answer at: each first put: (self arpabet at: each last)].
	^ answer! !
VoiceEvent subclass: #PhoneticEvent
	instanceVariableNames: 'phoneme pitchPoints duration loudness'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!
!PhoneticEvent commentStamp: '<historical>' prior: 0!
My instances are events for a Voice.!


!PhoneticEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
averagePitch
	| sum previous |
	self pitchPoints size = 1 ifTrue: [^ self pitchPoints first y].
	sum := 0.0.
	self pitchPoints do: [ :each |
		previous isNil ifFalse: [sum := (each y + previous y) / 2.0 * (each x - previous x) + sum].
		previous := each].
	sum := previous y * (self duration - previous x) + sum.
	^ sum / self duration! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 23:18'!
duration
	"Answer the duration (in seconds) of the receiver."
	^ duration! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
duration: aNumber
	"Set the duration of the receiver (in seconds)."
	((pitchPoints isNil or: [duration isNil]) or: [duration = 0])
		ifFalse: [pitchPoints := pitchPoints collect: [ :each | each x / duration * aNumber @ each y]].
	duration := aNumber! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 5/28/1999 01:36'!
loudness
	^ loudness! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
loudness: aNumber
	loudness := aNumber! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 5/28/1999 01:36'!
phoneme
	^ phoneme! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
phoneme: aPhoneme
	phoneme := aPhoneme! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 9/27/1999 23:03'!
pitch: aNumber
	self pitchPoints: aNumber! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
pitchAt: time
	"Answer the pitch of the receiver at a given time. (Do linear interpolation.)"
	| xVal count x1 x2 y1 y2 |
	pitchPoints isNil ifTrue: [^ nil].
	xVal := pitchPoints first x.
	count := 1.
	[xVal < time]
		whileTrue: [count := count + 1.
					count > pitchPoints size ifTrue: [^ pitchPoints last y].
					xVal := (pitchPoints at: count) x].
	xVal = time ifTrue: [^ (pitchPoints at: count) y].
	count = 1 ifTrue: [^ pitchPoints first y].
	x1 := (pitchPoints at: count - 1) x.
	x2 := (pitchPoints at: count) x.
	y1 := (pitchPoints at: count - 1) y.
	y2 := (pitchPoints at: count) y.
	^ (time - x1) / (x2 - x1) * (y2 - y1) + y1! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
pitchAt: time put: aNumber
	"Set the pitch of the receiver at a given time."
	pitchPoints isNil ifTrue: [pitchPoints := Array with: time @ aNumber. ^ self].
	pitchPoints := pitchPoints copyWith: time @ aNumber! !


!PhoneticEvent methodsFor: 'accessing-private' stamp: 'len 9/27/1999 23:06'!
pitchPoints
	^ pitchPoints! !

!PhoneticEvent methodsFor: 'accessing-private' stamp: 'stephaneducasse 2/3/2006 22:23'!
pitchPoints: p
	pitchPoints := p isNumber
		ifTrue: [((0.0 to: duration by: 0.035) collect: [ :time | time @ p])]
		ifFalse: [p first isPoint ifTrue: [p] ifFalse: [(p collect: [ :each | each first @ each last])]]! !


!PhoneticEvent methodsFor: 'converting' stamp: 'stephaneducasse 2/3/2006 22:23'!
asPHOString
	| stream |
	stream := WriteStream on: String new.
	stream
		nextPutAll: (PhonemeSet arpabetToSampa at: self phoneme); space;
		print: (self duration * 1000) rounded.
	self pitchPoints do: [ :each | stream space; print: (each x * 1000) rounded; space; print: each y rounded].
	^ stream contents! !


!PhoneticEvent methodsFor: 'copying' stamp: 'len 9/27/1999 23:01'!
copy
	^ super copy pitchPoints: self pitchPoints copy! !


!PhoneticEvent methodsFor: 'playing' stamp: 'len 8/28/1999 03:54'!
playOn: aVoice at: time
	aVoice playPhoneticEvent: self at: time! !


!PhoneticEvent methodsFor: 'printing' stamp: 'stephaneducasse 2/3/2006 22:23'!
printOn: aStream
	| first |
	aStream nextPutAll: '#('; print: phoneme; space; print: loudness; space; print: duration.
	self pitchPoints isNil ifTrue: [aStream nextPut: $). ^ self].
	aStream nextPutAll: ' #('.
	first := true.
	self pitchPoints do: [ :each |
		first ifFalse: [aStream space].
		aStream print: each x; space; print: each y.
		first := false].
	aStream nextPutAll: '))'! !


!PhoneticEvent methodsFor: 'testing' stamp: 'len 9/27/1999 23:04'!
hasPitch
	"Answer true if there is a pitch contour specified for the receiver."
	^ pitchPoints notNil! !

!PhoneticEvent methodsFor: 'testing' stamp: 'len 8/29/1999 21:17'!
isPhonetic
	^ true! !


!PhoneticEvent methodsFor: 'transforming' stamp: 'stephaneducasse 2/3/2006 22:23'!
pitchApply: aBlock
	"Apply aBlock to the pitch points in the receiver."
	self hasPitch ifFalse: [^ self].
	pitchPoints := pitchPoints collect: aBlock! !

!PhoneticEvent methodsFor: 'transforming' stamp: 'stephaneducasse 2/3/2006 22:23'!
pitchBy: aNumber
	"Multiply the receiver's pitch contour by aNumber."
	self hasPitch ifFalse: [^ self].
	pitchPoints := pitchPoints collect: [ :each | each x @ (each y * aNumber)]! !

!PhoneticEvent methodsFor: 'transforming' stamp: 'len 6/5/1999 03:26'!
stretch: aNumber
	self duration: self duration * aNumber! !

!PhoneticEvent methodsFor: 'transforming' stamp: 'stephaneducasse 2/3/2006 22:23'!
transposeBy: aNumber
	"Add the given step to the receiver's pitch."
	pitchPoints := pitchPoints collect: [ :each | each x @ (each y + aNumber)]! !
Object subclass: #PhoneticRule
	instanceVariableNames: 'left text right phonemes'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phonetics'!
!PhoneticRule commentStamp: '<historical>' prior: 0!
My instances are letter-to-sound rules for perform automatic text-to-phonemes transcription. (See the PhoneticTranscriber class comment too.)

Rules are made up of four parts: (1) left context pattern, (2) the text to match, (3) the right context pattern, and (4) the phonemes to substitute for the matched text.

The transcription procedure begins separating each block of letters (apostrophes included) and adding a space on each side. For each unmatched letter in the word, look through the rules where the text to match starts with the letter in the word. If the text to match if found and the right and left contexts patterns also match, output the phonemes for that rule and skip to the next unmatched letter.

Context patterns special characters:
	#	One or more vowels
	:	Zero or more consonants
	^	One consonant
	.	One of B, D, V, G, J, L, M, N, R, W, or Z (voiced consonants)
	%	One of ER, E, ES, ED, ING, ELY (a suffix)	[ONLY FOR RIGHT CONTEXT]
	+	One of E, I or Y (a "front" vowel)
Furthermore, the space character means any separator (space, comma, colon, etc), and any other character means that character it self.

The english example is derived from: "Automatic Translation of English Text to Phonetics by Means of Letter-To-Sound Rules", NRL Report 7948, January 21st, 1976, Naval Research Laboratory, Washington, D.C. Published by the National Technical Information Service as document "AD/A021 929".
!


!PhoneticRule methodsFor: 'accessing' stamp: 'len 5/29/1999 03:59'!
left
	^ left! !

!PhoneticRule methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
left: aString
	left := aString! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 4/10/98 05:01'!
phonemes
	^ phonemes! !

!PhoneticRule methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
phonemes: aCollection
	phonemes := aCollection! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 5/29/1999 03:59'!
right
	^ right! !

!PhoneticRule methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
right: aString
	right := aString! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 4/10/98 05:00'!
text
	^ text! !

!PhoneticRule methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
text: aString
	text := aString! !


!PhoneticRule methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:08'!
= anObject

	self species == anObject species ifFalse: [^ false].
	^ anObject left = self left
		and: [anObject right = self right
			and: [anObject text = self text
				and: [anObject phonemes = self phonemes]]]! !

!PhoneticRule methodsFor: 'comparing' stamp: 'len 5/29/1999 03:58'!
hash
	^ self text hash! !

!PhoneticRule methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:09'!
species
	^PhoneticRule ! !


!PhoneticRule methodsFor: 'printing' stamp: 'len 5/31/1999 00:32'!
printOn: aStream
	aStream
		nextPut: $[; print: left; nextPut: $,; print: text; nextPut: $,; print: right; nextPut: $];
		nextPutAll: ' -> '.
	phonemes isEmpty ifTrue: [aStream nextPutAll: '{}'] ifFalse: [aStream nextPut: $/].
	phonemes do: [ :each | aStream nextPutAll: each name; nextPut: $/]! !


!PhoneticRule methodsFor: 'testing' stamp: 'len 6/8/1999 00:14'!
matches: aString at: anInteger
	^ (self textMatches: aString at: anInteger)
		and: [(self leftMatches: aString at: anInteger)
			and: [self rightMatches: aString at: anInteger]]! !


!PhoneticRule methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:23'!
leftMatches: aString at: anInteger
	| leftindex textindex pattern |
	left isEmpty ifTrue: [^ true].
	leftindex := left size.
	textindex := anInteger - 1.
	[leftindex >= 1 and: [textindex >= 1]] whileTrue: [
		pattern := left at: leftindex.
		"first check for simple text or apostrophe:"
		(pattern isAlphaNumeric or: [pattern = $'])
			ifTrue: [(aString at: textindex) asLowercase ~= pattern asLowercase
						ifTrue: [^ false].
					textindex := textindex - 1].
		"space:"
		pattern = Character space
			ifTrue: [((aString at: textindex) isSeparator
						or: ['.,;:' includes: (aString at: textindex)]) ifFalse: [^ false].
					textindex := textindex - 1].
		"one or more vowels:"
		pattern = $#
			ifTrue: [(aString at: textindex) isVowel ifFalse: [^ false].
					textindex := textindex - 1.
					[textindex >= 1 and: [(aString at: textindex) isVowel]]
						whileTrue: [textindex := textindex - 1]].
		"zero or more consonants:"
		pattern = $:
			ifTrue: [[textindex >= 1
						and: ['bcdfghjklmnpqrstvwxyz'
								includes: (aString at: textindex) asLowercase]]
							whileTrue: [textindex := textindex - 1]].
		"one consonant:"
		pattern = $^
			ifTrue: [('bcdfghjklmnpqrstvwxyz' includes: (aString at: textindex))
						ifFalse: [^ false].
					textindex := textindex - 1].
		"b, d, v, g, j, l, m, n, r, w, z (voiced consonants):"
		pattern = $.
			ifTrue: [('bdvgjlmnrwz' includes: (aString at: textindex) asLowercase)
						ifFalse: [^ false].
					textindex := textindex - 1].
		"e, i or y (front vowels)"
		pattern = $+
			ifTrue: [('eiy' includes: (aString at: textindex) asLowercase)
						ifFalse: [^ false].
					textindex := textindex - 1].
		leftindex := leftindex - 1].
	^ true! !

!PhoneticRule methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:23'!
rightMatches: aString at: anInteger
	| rightindex textindex pattern |
	right isEmpty ifTrue: [^ true].
	rightindex := 1.
	textindex := anInteger + text size.
	[rightindex <= right size and: [textindex <= aString size]] whileTrue: [
		pattern := right at: rightindex.
		"first check for simple text or apostrophe:"
		(pattern isAlphaNumeric or: [pattern = $'])
			ifTrue: [(aString at: textindex) asLowercase ~= pattern asLowercase
						ifTrue: [^ false].
					textindex := textindex + 1].
		"space:"
		pattern = Character space
			ifTrue: [((aString at: textindex) isSeparator
						or: ['.,;:' includes: (aString at: textindex)]) ifFalse: [^ false].
					textindex := textindex + 1].
		"one or more vowels:"
		pattern = $#
			ifTrue: [(aString at: textindex) isVowel ifFalse: [^ false].
					textindex := textindex + 1.
					[textindex <= aString size and: [(aString at: textindex) isVowel]]
						whileTrue: [textindex := textindex + 1]].
		"zero or more consonants:"
		pattern = $:
			ifTrue: [[textindex <= aString size
						and: ['bcdfghjklmnpqrstvwxyz'
								includes: (aString at: textindex) asLowercase]]
							whileTrue: [textindex := textindex + 1]].
		"one consonant:"
		pattern = $^
			ifTrue: [('bcdfghjklmnpqrstvwxyz' includes: (aString at: textindex))
						ifFalse: [^ false].
					textindex := textindex + 1].
		"b, d, v, g, j, l, m, n, r, w, z (voiced consonants):"
		pattern = $.
			ifTrue: [('bdvgjlmnrwz' includes: (aString at: textindex) asLowercase)
						ifFalse: [^ false].
					textindex := textindex + 1].
		"e, i or y (front vowels):"
		pattern = $+
			ifTrue: [('eiy' includes: (aString at: textindex) asLowercase)
						ifFalse: [^ false].
					textindex := textindex + 1].
		"er, e, es, ed, ing, ely (a suffix):"
		pattern = $%
			ifTrue: [(aString at: textindex) asLowercase = $e
						ifTrue: [textindex := textindex + 1.
								(textindex < aString size and: [(aString at: textindex) asLowercase = $l])
									ifTrue: [textindex := textindex + 1.
											(textindex < aString size and: [(aString at: textindex) asLowercase = $y])
												ifTrue: [textindex := textindex + 1]
												ifFalse: [textindex := textindex - 1]]
									ifFalse: [('rsd' includes: (aString at: textindex) asLowercase)
												ifTrue: [textindex := textindex + 1]]]
						ifFalse: [(textindex + 2 <= aString size
									and: [(aString at: textindex) asLowercase = $i
										and: [(aString at: textindex + 1) asLowercase = $n
											and: [(aString at: textindex + 2) asLowercase = $g]]])
									ifTrue: [textindex := textindex + 3]
									ifFalse: [^ false]]].
		rightindex := rightindex + 1].
	^ true! !

!PhoneticRule methodsFor: 'private' stamp: 'len 4/10/98 23:19'!
textMatches: aString at: anInteger
	text size > (aString size - anInteger + 1) ifTrue: [^ false].
	1 to: text size do: [ :each |
		(text at: each) asLowercase = (aString at: anInteger + each - 1) asLowercase ifFalse: [^ false]].
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhoneticRule class
	instanceVariableNames: ''!

!PhoneticRule class methodsFor: 'examples' stamp: 'stephaneducasse 2/3/2006 22:23'!
spanish
	"Answer the spanish phonetic rules."
	| phonemes |
	phonemes := PhonemeSet spanish.
	^ #(
		(''		'a'		''		'a')
		(''		'b'		''		'b')
		(''		'ch'		''		'ch')
		(''		'c'		'i'		'z')
		(''		'c'		'e'		'z')
		(''		'c'		''		'k')
		(''		'd'		''		'd')
		(''		'e'		''		'e')
		(''		'f'		''		'f')
		(''		'g'		'e'		'j')
		(''		'g'		'i'		'j')
		(''		'gu'		'e'		'g')
		(''		'gu'		'i'		'g')
		(''		'g'		''		'g')
		(''		'h'		''		'')
		(''		'i'		''		'i')
		(''		'j'		''		'j')
		(''		'k'		''		'k')
		(''		'll'		''		'y')
		(''		'l'		''		'l')
		(''		'm'		''		'm')
		(''		'n'		''		'n')
		(''		'o'		''		'o')
		(''		'p'		''		'p')
		(''		'qu'		''		'k')
		(''		'rr'		''		'rx')
		(' '		'r'		''		'rx')
		(''		'r'		''		'r')
		(''		's'		''		's')
		(''		't'		''		't')
		(''		'u'		''		'u')
		(''		'v'		''		'v')
		(''		'w'		''		'w')
		(''		'x'		''		'k/s')
		(''		'y'		' '		'i')
		(''		'y'		''		'y')
		(''		'z'		''		'z')
	) collect: [ :each | self fromArray: each phonemes: phonemes]! !


!PhoneticRule class methodsFor: 'examples-english' stamp: 'stephaneducasse 2/3/2006 22:23'!
english
	"Answer the english phonetic rules."
	| answer |
	answer := OrderedCollection new.
	#(englishPunctuationRules
		englishARules englishBRules englishCRules englishDRules englishERules
		englishFRules englishGRules englishHRules englishIRules englishJRules
		englishKRules englishLRules englishMRules englishNRules englishORules
		englishPRules englishQRules englishRRules englishSRules englishTRules
		englishURules englishVRules englishWRules englishXRules englishYRules
		englishZRules) do: [ :each | answer addAll: (self perform: each)].
	^ answer asArray! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/30/1999 23:54'!
englishARules
	^ #((''		'a'		' '		'ax')
		(' '		'are'	' '		'aa/r')
		(' '		'ar'		'o'		'ax/r')
		(''		'ar'		'#'		'eh/r')
		('^'		'as'		'#'		'ey/s')
		(''		'a'		'wa'	'ax')
		(''		'aw'	''		'ao')
		(' :'		'any'	''		'eh/n/iy')
		(''		'a'		'^+#'	'ey')
		('#:'	'ally'	''		'ax/l/iy')
		(' '		'al'		'#'		'ax/l')
		(''		'again'	''		'ax/g/eh/n')
		('#:'	'ag'		'e'		'ih/jh')
		(''		'a'		'^+:#'	'ae')
		(' :'		'a'		'^+ '	'ey')
		(' '		'arr'	''		'ax/r')
		(''		'arr'	''		'ae/r')
		(' :'		'ar'		' '		'aa/r')
		(''		'ar'		' '		'er')
		(''		'ar'		''		'aa/r')
		(''		'air'	''		'eh/r')
		(''		'ai'		''		'ey')
		(''		'ay'		''		'ey')
		(''		'au'		''		'ao')
		('#:'	'al'		' '		'ax/l')
		('#:'	'als'	' '		'ax/l/z')
		(''		'alk'	''		'ao/k')
		(''		'al'		'^'		'ao/l')
		(' :'		'able'	''		'ey/b/ax/l')
		(''		'able'	''		'ax/b/ax/l')
		(''		'ang'	'+'		'ey/n/jh')
		('^'		'a'		'^#'		'ey')
		(''		'a'		''		'ae')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/30/1999 23:58'!
englishBRules
	^ #((' '		'be'		'^#'		'b/ih')
		(''		'being'	''		'b/iy/ih/ng')
		(' '		'both'	''		'b/ow/th')
		(' '		'bus'	'#'		'b/ih/z')
		(''		'buil'	''		'b/ih/l')
		(''		'b'		''		'b')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/30/1999 23:59'!
englishCRules
	^ #((' '		'ch'		'^'		'k')
		('^e'	'ch'		''		'k')
		(''		'ch'		''		'ch')
		(' s'		'ci'		'#'		's/ay')
		(''		'ci'		'a'		'sh')
		(''		'ci'		'o'		'sh')
		(''		'ci'		'en'		'sh')
		(''		'c'		'+'		's')
		(''		'ck'		''		'k')
		(''		'com'	'%'		'k/ah/m')
		(''		'c'		''		'k')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 12/2/1999 02:41'!
englishDRules
	^ #(('#:'	'ded'	' '		'd/ih/d')
		('.e'		'd'		' '		'd')
		('#:^e'	'd'		' '		't')
		(' '		'de'		'^#'		'd/ih')
		(' '		'do'		' '		'd/uw')
		(' '		'does'	''		'd/ah/z')
		(' '		'doing'	''		'd/uw/ih/ng')
		(' '		'dow'	''		'd/aw')
		(''		'du'		'a'		'jh/uw')
		(''		'd'		''		'd')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 12/9/1999 02:27'!
englishERules
	^ #(('#:'	'e'		' '		'')
		(''':^'	'e'		' '		'')
		(' :'		'e'		' '		'iy')
		('#'		'ed'		' '		'd')
		('#:'	'e'		'd'		'')
		(''		'ev'		'er'		'eh/v')
		(''		'e'		'^%'		'iy')
		(''		'eri'	'#'		'iy/r/iy')
		(''		'eri'	''		'eh/r/ih')
		('#:'	'er'		'#'		'er')
		(''		'er'		'#'		'eh/r')
		(''		'er'		''		'er')
		(' '		'even'	''		'iy/v/eh/n')
		('#:'	'e'		'w'		'')
		('t'		'ew'	''		'uw')
		('s'		'ew'	''		'uw')
		('r'		'ew'	''		'uw')
		('d'		'ew'	''		'uw')
		('l'		'ew'	''		'uw')
		('z'		'ew'	''		'uw')
		('n'		'ew'	''		'uw')
		('j'		'ew'	''		'uw')
		('th'	'ew'	''		'uw')
		('ch'	'ew'	''		'uw')
		('sh'	'ew'	''		'uw')
		(''		'ew'	''		'y/uw')
		(''		'e'		'o'		'iy')
		('#:s'	'es'		' '		'ih/z')
		('#:c'	'es'		' '		'ih/z')
		('#:g'	'es'		' '		'ih/z')
		('#:z'	'es'		' '		'ih/z')
		('#:x'	'es'		' '		'ih/z')
		('#:j'	'es'		' '		'ih/z')
		('#:ch'	'es'		' '		'ih/z')
		('#:sh'	'es'		' '		'ih/z')
		('#:'	'e'		's'		'')
		('#:'	'ely'	' '		'l/iy')
		('#:'	'ement'	''		'm/eh/n/t')
		(''		'eful'	''		'f/uh/l')
		(''		'ee'		''		'iy')
		(''		'earn'	''		'er/n')
		(' '		'ear'	'^'		'er')
		(''		'ead'	''		'eh/d')
		('#:'	'ea'		' '		'iy/ax')
		(''		'ea'		'su'		'eh')
		(''		'ea'		''		'iy')
		(''		'eigh'	''		'ey')
		(''		'ei'		''		'iy')
		(' '		'eye'	''		'ay')
		(''		'ey'		''		'iy')
		(''		'eu'		''		'y/uw')
		(''		'e'		''		'eh')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:01'!
englishFRules
	^ #((''		'ful'	''		'f/uh/l')
		(''		'f'		''		'f')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:02'!
englishGRules
	^ #((''		'giv'	''		'g/iy/v')
		(' '		'g'		'i^'		'g')
		(''		'ge'		't'		'g/eh')
		('su'	'gges'	''		'g/jh/eh/s')
		(''		'gg'		''		'g')
		(' b#'	'g'		''		'g')
		(''		'g'		'+'		'jh')
		(''		'great'	''		'g/r/ey/t')
		('#'		'gh'		''		'')
		(''		'g'		''		'g')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 7/20/1999 00:42'!
englishHRules
	^ #((' '		'hav'	''		'hh/ae/v')
		(' '		'here'	''		'hh/iy/r')
		(' '		'hour'	''		'aw/er')
		(''		'how'	''		'hh/aw')
		(''		'h'		'#'		'hh')
		(''		'h'		''		'')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:03'!
englishIRules
	^ #((' '		'in'		''		'ih/n')
		(' '		'i'		' '		'ay')
		(''		'in'		'd'		'ay/n')
		(''		'ier'	''		'iy/er')
		('#:r'	'ied'	''		'iy/d')
		(''		'ied'	' '		'ay/d')
		(''		'ien'	''		'iy/eh/n')
		(''		'ie'		't'		'ay/eh')
		(' :'		'i'		'%'		'ay')
		(''		'i'		'%'		'iy')
		(''		'ie'		''		'iy')
		(''		'i'		'^+:#'	'ih')
		(''		'ir'		'#'		'ay/r')
		(''		'iz'		'%'		'ay/z')
		(''		'is'		'%'		'ay/z')
		(''		'i'		'd%'		'ay')
		('+^'	'i'		'^+'		'ih')
		(''		'i'		't%'		'ay')
		('#:^'	'i'		'^+'		'ih')
		(''		'i'		'^+'		'ay')
		(''		'ir'		''		'er')
		(''		'igh'	''		'ay')
		(''		'ild'		''		'ay/l/d')
		(''		'ign'	' '		'ay/n')
		(''		'ign'	'^'		'ay/n')
		(''		'ign'	'%'		'ay/n')
		(''		'ique'	''		'iy/k')
		(''		'i'		''		'ih')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:03'!
englishJRules
	^ #((''		'j'		''		'jh')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:04'!
englishKRules
	^ #((''		'k'		'n'		'')
		(''		'k'		''		'k')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:04'!
englishLRules
	^ #((''		'lo'		'c#'		'l/ow')
		('l'		'l'		''		'')
		('#:^'	'l'		'%'		'ax/l')
		(''		'lead'	''		'l/iy/d')
		(''		'l'		''		'l')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:04'!
englishMRules
	^ #((''		'mov'	''		'm/uw/v')
		(''		'm'		''		'm')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:05'!
englishNRules
	^ #(('e'		'ng'		'+'		'n/jh')
		(''		'ng'		'r'		'ng/g')
		(''		'ng'		'#'		'ng/g')
		(''		'ngl'	'%'		'ng/g/ax/l')
		(''		'ng'		''		'ng')
		(''		'nk'		''		'ng/k')
		(' '		'now'	' '		'n/aw')
		(''		'n'		''		'n')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:06'!
englishORules
	^ #((''		'of'		' '		'ax/v')
		(''		'orough'	''	'er/ow')
		('#:'	'or'		' '		'er')
		('#:'	'ors'	' '		'er/z')
		(''		'or'		''		'ao/r')
		(' '		'one'	''		'w/ah/n')
		(''		'ow'	''		'ow')
		(' '		'over'	''		'ow/v/er')
		(''		'ov'		''		'ah/v')
		(''		'o'		'^%'		'ow')
		(''		'o'		'^en'	'ow')
		(''		'o'		'^i#'	'ow')
		(''		'ol'		'd'		'ow/l')
		(''		'ought'	''		'ao/t')
		(''		'ough'	''		'ah/f')
		(' '		'ou'		''		'aw')
		('h'		'ou'		's#'		'aw')
		(''		'ous'	''		'ax/s')
		(''		'our'	''		'ao/r')
		(''		'ould'	''		'uh/d')
		('^'		'ou'		'^l'		'ah')
		(''		'oup'	''		'uw/p')
		(''		'ou'		''		'aw')
		(''		'oy'		''		'oy')
		(''		'oing'	''		'ow/ih/ng')
		(''		'oi'		''		'oy')
		(''		'oor'	''		'ao/r')
		(''		'ook'	''		'uh/k')
		(''		'ood'	''		'uh/d')
		(''		'oo'		''		'uw')
		(''		'o'		'e'		'ow')
		(''		'o'		' '		'ow')
		(''		'oa'		''		'ow')
		(' '		'only'	''		'ow/n/l/iy')
		(' '		'once'	''		'w/ah/n/s')
		(''		'on''t'	''		'ow/n/t')
		('c'		'o'		'n'		'aa')
		(''		'o'		'ng'		'ao')
		(' :^'	'o'		'n'		'ah')
		('i'		'on'		''		'ax/n')
		('#:'	'on'		' '		'ax/n')
		('#^'	'on'		''		'ax/n')
		(''		'o'		'st '		'ow')
		(''		'of'		'^'		'ao/f')
		(''		'other'	''		'ah/dh/er')
		(''		'oss'	' '		'ao/s')
		('#:^'	'om'	''		'ah/m')
		(''		'o'		''		'aa')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:06'!
englishPRules
	^ #((''		'ph'		''		'f')
		(''		'peop'	''		'p/iy/p')
		(''		'pow'	''		'p/aw')
		(''		'put'	' '		'p/uh/t')
		(''		'p'		''		'p')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:07'!
englishPunctuationRules
	^ #(('.'		'''s'		''		'z')
		('#:.e'	'''s'		''		'z')
		('#'		'''s'		''		'z')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:07'!
englishQRules
	^ #((''		'quar'	''		'k/w/ao/r')
		(''		'qu'		''		'k/w')
		(''		'q'		''		'k')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:07'!
englishRRules
	^ #((''		're'		'^#'		'r/iy')
		(''		'r'		''		'r')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:07'!
englishSRules
	^ #((''		'sh'		''		'sh')
		('#'		'sion'	''		'zh/ax/n')
		(''		'some'	''		's/ah/m')
		('#'		'sur'	'#'		'zh/er')
		(''		'sur'	'#'		'sh/er')
		('#'		'su'		'#'		'zh/uw')
		('#'		'ssu'	'#'		'sh/uw')
		('#'		'sed'	' '		'z/d')
		('#'		's'		'#'		'z')
		(''		'said'	''		's/eh/d')
		('^'		'sion'	''		'sh/ax/n')
		(''		's'		's'		'')
		('.'		's'		' '		'z')
		('#:.e'	's'		' '		'z')
		('#:^##'	's'		' '		'z')
		('#:^#'	's'		' '		's')
		('u'		's'		' '		's')
		(' :#'	's'		' '		'z')
		(' '		'sch'	''		's/k')
		(''		's'		'c+'		'')
		('#'		'sm'		''		'z/m')
		('#'		'sn'		''''		'z/ax/n')
		(''		's'		''		's')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:08'!
englishTRules
	^ #((' '		'the'	' '		'dh/ax')
		(''		'to'		' '		't/uw')
		(''		'that'	' '		'dh/ae/t')
		(' '		'this'	' '		'dh/ih/s')
		(' '		'they'	''		'dh/ey')
		(' '		'there'	''		'dh/eh/r')
		(''		'ther'	''		'dh/er')
		(''		'their'	''		'dh/eh/r')
		(' '		'than'	' '		'dh/ae/n')
		(' '		'them'	' '		'dh/eh/m')
		(''		'these'	' '		'dh/iy/z')
		(' '		'then'	''		'dh/eh/n')
		(''		'through'	''	'th/r/uw')
		(''		'those'	''		'dh/ow/z')
		(''		'though'	' '	'dh/ow')
		(' '		'thus'	''		'dh/ah/s')
		(''		'th'		''		'th')
		('#:'	'ted'	' '		't/ih/d')
		('s'		'ti'		'#n'	'ch')
		(''		'ti'		'o'		'sh')
		(''		'ti'		'a'		'sh')
		(''		'tien'	''		'sh/ax/n')
		(''		'tur'	'#'		'ch/er')
		(''		'tu'		'a'		'ch/uw')
		(''		'two'	''		't/uw')
		(''		't'		''		't')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:09'!
englishURules
	^ #((' '		'un'	'i'		'y/uw/n')
		(' '		'un'	''		'ah/n')
		(' '		'upon'	''		'ax/p/ao/n')
		('t'		'ur'		'#'		'uh/r')
		('s'		'ur'		'#'		'uh/r')
		('r'		'ur'		'#'		'uh/r')
		('d'		'ur'		'#'		'uh/r')
		('l'		'ur'		'#'		'uh/r')
		('z'		'ur'		'#'		'uh/r')
		('n'		'ur'		'#'		'uh/r')
		('j'		'ur'		'#'		'uh/r')
		('th'	'ur'		'#'		'uh/r')
		('ch'	'ur'		'#'		'uh/r')
		('sh'	'ur'		'#'		'uh/r')
		(''		'ur'		'#'		'y/uh/r')
		(''		'ur'		''		'er')
		(''		'u'		'^'		'ah')
		(''		'u'		'^^'		'ah')
		(''		'uy'	''		'ay')
		(' g'	'u'		'#'		'')
		('g'		'u'		'%'		'')
		('g'		'u'		'#'		'w')
		('#n'	'u'		''		'y/uw')
		('t'		'u'		''		'uw')
		('s'		'u'		''		'uw')
		('r'		'u'		''		'uw')
		('d'		'u'		''		'uw')
		('l'		'u'		''		'uw')
		('z'		'u'		''		'uw')
		('n'		'u'		''		'uw')
		('j'		'u'		''		'uw')
		('th'	'u'		''		'uw')
		('ch'	'u'		''		'uw')
		('sh'	'u'		''		'uw')
		(''		'u'		''		'y/uw')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:09'!
englishVRules
	^ #((''		'view'	''		'v/y/uw')
		(''		'v'		''		'v')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 7/20/1999 00:43'!
englishWRules
	^ #((' '		'were'	''		'w/er')
		(''		'wa'	's'		'w/aa')
		(''		'wa'	't'		'w/aa')
		(''		'where'	''		'wh/eh/r')
		(''		'what'	''		'wh/aa/t')
		(''		'whol'	''		'hh/ow/l')
		(''		'who'	''		'hh/uw')
		(''		'wh'	''		'wh')
		(''		'war'	''		'w/ao/r')
		(''		'wor'	'^'		'w/er')
		(''		'wr'	''		'r')
		(''		'w'		''		'w')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:10'!
englishXRules
	^ #((''		'x'		''		'k/s')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:10'!
englishYRules
	^ #((''		'young'	''		'y/ah/ng')
		(' '		'you'	''		'y/uw')
		(' '		'yes'	''		'y/eh/s')
		(' '		'y'		''		'y')
		('#:^'	'y'		' '		'iy')
		('#:^'	'y'		'i'		'iy')
		(' :'		'y'		''		'ay')
		(' :'		'y'		'#'		'ay')
		(' :'		'y'		'^+:#'	'ih')
		(' :'		'y'		'^#'		'ay')
		(''		'y'		''		'ih')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:10'!
englishZRules 
	^ #((''		'z'		''		'z')
	) collect: [ :each | self fromArray: each]! !


!PhoneticRule class methodsFor: 'instance creation' stamp: 'len 5/31/1999 00:16'!
fromArray: anArray
	^ self fromArray: anArray phonemes: PhonemeSet arpabet! !

!PhoneticRule class methodsFor: 'instance creation' stamp: 'len 5/31/1999 00:19'!
fromArray: anArray phonemes: aPhonemeSet
	^ self new
		left: (anArray at: 1);
		text: (anArray at: 2);
		right: (anArray at: 3);
		phonemes: (aPhonemeSet transcriptionOf: (anArray at: 4)) asArray! !
Object subclass: #PhoneticTranscriber
	instanceVariableNames: 'phonemes rules lexicon'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phonetics'!
!PhoneticTranscriber commentStamp: '<historical>' prior: 0!
My instances perform automatic words-to-phonemes transcription. (See the PhoneticRule class comment too.)

Each transcriber must have a collection of PhoneticRules, and optionally a lexicon. When a transcriber is asked for the transcription of a word, it searches for the word in the lexicon first, and if the word is not found then the rules are used.

Rules are made up of four parts: (1) left context pattern, (2) the text to match, (3) the right context pattern, and (4) the phonemes to substitute for the matched text.

The transcription procedure begins when a text is provided to a transcriber. For each unmatched letter in the word, look through the rules where the text to match starts with the letter in the word. If one matching rule is found, then the rule is applied, writing the corresponding phonemes in the output and moving forward to the next unmatched position. If no rule is found for a position in the text, then the unmatched position is logged. At the end of the transcription, the phonemes extracted are provided in a collection and so are the unmatched positions.
!


!PhoneticTranscriber methodsFor: 'accessing' stamp: 'len 11/29/1999 02:31'!
lexicon
	^ lexicon! !

!PhoneticTranscriber methodsFor: 'accessing' stamp: 'len 6/5/1999 01:56'!
phonemes
	^ phonemes! !

!PhoneticTranscriber methodsFor: 'accessing' stamp: 'len 6/5/1999 01:56'!
rules
	^ rules! !


!PhoneticTranscriber methodsFor: 'accessing-private' stamp: 'stephaneducasse 2/3/2006 22:23'!
lexicon: aDictionary
	lexicon := aDictionary! !

!PhoneticTranscriber methodsFor: 'accessing-private' stamp: 'stephaneducasse 2/3/2006 22:23'!
phonemes: aPhonemeSet
	phonemes := aPhonemeSet! !

!PhoneticTranscriber methodsFor: 'accessing-private' stamp: 'stephaneducasse 2/3/2006 22:23'!
rules: aCollection
	rules := aCollection! !


!PhoneticTranscriber methodsFor: 'computing' stamp: 'stephaneducasse 2/3/2006 22:23'!
transcriptionOf: aString
	"Answer the phonetic transcription of the word in aString."
	| rule string index transcription stressed |
	(transcription := self tryLexicon: aString) isNil ifFalse: [^ transcription].
	transcription := OrderedCollection new.
	string := ' ', aString,' '.
	index := 2.
	[index < string size] whileTrue: [
		rule := self rules
			detect: [ :one | one matches: string at: index]
			ifNone: [].
		rule isNil
			ifTrue: ["unmatched character" index := index+1]
			ifFalse: [index := index + rule text size.
					transcription addAll: rule phonemes]].
	stressed := false.
	^ transcription collect: [ :each |
		(stressed not and: [each isVowel or: [each isDiphthong]])
			ifTrue: [stressed := true. each stressed: 1] ifFalse: [each]]! !


!PhoneticTranscriber methodsFor: 'computing-private' stamp: 'stephaneducasse 2/3/2006 22:23'!
tryLexicon: aWord
	| string |
	self lexicon isNil ifTrue: [^ nil].
	string := self lexicon at: aWord asUppercase ifAbsent: [^ nil].
	^ self phonemes transcriptionOf: string asLowercase! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhoneticTranscriber class
	instanceVariableNames: ''!

!PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 4/13/98 16:21'!
default
	^ self english! !

!PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 12/14/1999 03:29'!
english
	"Answer an english phonetic transcriber."
	^ self new rules: PhoneticRule english; phonemes: PhonemeSet arpabet; lexicon: self englishLexicon! !

!PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 8/24/2001 13:48'!
englishLexicon
	^ Dictionary new
		add: 'HOW' -> 'HH AW1';
		add: 'YOU' -> 'Y UW1';
		add: 'ARE' -> 'AA1 R';
		add: 'DOING' -> 'D UW1 IH0 NG';
		add: 'THIS' -> 'DH IH1 S';
		add: 'IS' -> 'IH1 Z';
		add: 'MY' -> 'M AY1';
		add: 'HI' -> 'HH AY1';
		add: 'VOICE' -> 'V OY1 S';
		add: 'FAST' -> 'F AE1 S T';
		add: 'SLOW' -> 'S L OW1';
		add: 'I' -> 'AY1';
		add: 'AM' -> 'AE1 M';
		add: 'A' -> 'AH0';
		add: 'AN' ->  'AE1 N';
		add: 'LOW' -> 'L OW1';
		add: 'SPEAKER' -> 'S P IY1 K ER0';
		add: 'ANSWER' -> 'AE1 N S ER0';
		add: 'RECEIVER' -> 'R AH0 S IY1 V ER0';
		add: 'OBJECT' -> 'AA1 B JH EH0 K T';
		add: 'READ' -> 'R IY1 D';
		add: 'WRITE' -> 'R AY1 T';
		add: 'SQUEAK' -> 'S K W IY1 K';
		add: 'SMALLTALK' -> ' S M AO1 L T AO2 K';
		add: 'CLASS' -> 'K L AE1 S';
		add: 'WOMAN' -> 'W UH1 M AH0 N';
		add: 'BICYCLIC' ->  'B AY1 S IH0 K L IH0 K';
		add: 'LISTEN' -> 'L IH1 S AH0 N';
		add: 'ZERO' -> 'Z IY1 R OW';
		add: 'SEVEN' -> 'S EH1 V EH N';
		add: 'ELEVEN' -> 'EH1 L EH1 V EH N';
		add: 'SEVENTEEN' -> 'S EH1 V EH N T IY N';
		add: 'SEVENTY' -> 'S EH1 V EH N T IH';
		add: 'NINETEEN' -> 'N AH1 N T IY N';
		add: 'NINETY' -> 'N AH1 N T IH';
		yourself! !

!PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 12/14/1999 03:29'!
spanish
	"Answer a spanish phonetic transcriber."
	^ self new rules: PhoneticRule spanish; phonemes: PhonemeSet arpabet! !
Object subclass: #Phrase
	instanceVariableNames: 'string words accent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!
!Phrase commentStamp: '<historical>' prior: 0!
My instances are phrases. They can carry a phrase accent ('H-' or 'L-') and a boundary tone ('H%', 'L%', '%H').!


!Phrase methodsFor: 'accessing' stamp: 'len 12/12/1999 22:32'!
accent
	^ accent! !

!Phrase methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
accent: aString
	accent := aString! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/8/1999 17:48'!
accept: anObject
	anObject phrase: self! !

!Phrase methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
events
	| answer |
	answer := CompositeEvent new.
	self words do: [ :each | answer addAll: each events].
	^ answer! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/8/1999 18:51'!
lastSyllable
	^ self words last lastSyllable! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/12/1999 22:22'!
string
	^ string! !

!Phrase methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
string: aString
	string := aString! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/8/1999 17:47'!
words
	^ words! !

!Phrase methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
words: aCollection
	words := aCollection! !


!Phrase methodsFor: 'enumarating' stamp: 'len 12/13/1999 01:19'!
eventsDo: aBlock
	self words do: [ :word | word eventsDo: aBlock]! !

!Phrase methodsFor: 'enumarating' stamp: 'len 12/13/1999 02:37'!
syllablesDo: aBlock
	self words do: [ :each | each syllables do: aBlock]! !


!Phrase methodsFor: 'printing' stamp: 'len 12/8/1999 18:17'!
printOn: aStream
	self words do: [ :each | aStream print: each; space]! !
TileLikeMorph subclass: #PhraseTileMorph
	instanceVariableNames: 'resultType brightenedOnEnter userScriptSelector justGrabbedFromViewer vocabulary vocabularySymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!PhraseTileMorph commentStamp: '<historical>' prior: 0!
Phrase Tile World: A single smalltalk expression in tiles.  Like (car forwardBy: number), having 3 tiles.  

type = command
rcvrType = #actor


In the Old Single tile world:  Holder for a phrase of tiles as it came from the viewer and while it is being dragged by the hand.

 !


!PhraseTileMorph methodsFor: 'all' stamp: 'sw 12/13/2001 17:41'!
rowOfRightTypeFor: aLayoutMorph forActor: aPlayer
	"Answer a phrase of the right type for the putative container"

	| aTemporaryViewer aPhrase |
	aLayoutMorph demandsBoolean ifTrue:
		[self isBoolean ifTrue: [^ self].
		aTemporaryViewer _ CategoryViewer new invisiblySetPlayer: aPlayer.
		aPhrase _ aTemporaryViewer booleanPhraseFromPhrase: self.
		aPhrase justGrabbedFromViewer: false.
		^ aPhrase].
	^ self! !


!PhraseTileMorph methodsFor: 'code generation' stamp: 'sw 9/2/1999 15:33'!
codeString
	^ String streamContents: [:aStream | self storeCodeOn: aStream indent: 1]
! !

!PhraseTileMorph methodsFor: 'code generation' stamp: 'dgd 2/22/2003 19:08'!
storeCodeOn: aStream indent: tabCount 
	"Add in some smarts for division by zero."

	aStream nextPut: $(.
	submorphs first storeCodeOn: aStream indent: tabCount.
	aStream space.
	submorphs second storeCodeOn: aStream indent: tabCount.
	submorphs size > 2 
		ifTrue: 
			[(self catchDivideByZero: aStream indent: tabCount) 
				ifFalse: 
					[aStream space.
					(submorphs third) storeCodeOn: aStream indent: tabCount]].
	aStream nextPut: $)! !


!PhraseTileMorph methodsFor: 'customevents-scripting' stamp: 'nk 11/1/2004 11:14'!
setAsActionInButtonProperties: buttonProperties

	userScriptSelector ifNil: [
		buttonProperties
			target: self associatedPlayer;
			actionSelector: #evaluateUnloggedForSelf:;
			arguments: {self codeString}.
		^true
	].
	buttonProperties
		target: self objectViewed player;
		actionSelector: #triggerScript: ;
		arguments: {userScriptSelector}.
	^true

"==== or 

	buttonProperties
		target: (self morphToDropInPasteUp: nil);
		actionSelector: #tryMe;
		arguments: #().
	^true


	==="! !


!PhraseTileMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/9/2001 00:15'!
justDroppedInto: newOwner event: evt
	"Phrase tiles only auto-expand if they originate from viewers.  Any phrase tile, once dropped, loses its auto-phrase-expansion thing"

	justGrabbedFromViewer _ false.
	super justDroppedInto: newOwner event: evt! !


!PhraseTileMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 23:38'!
handlesMouseDown: evt
	^true! !


!PhraseTileMorph methodsFor: 'e-toy support' stamp: 'sw 7/28/1999 17:02'!
isCandidateForAutomaticViewing
	^ false! !


!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 8/28/2004 14:23'!
initialize
	"Initialize a nascent instance"

	super initialize.
	resultType _ #unknown.
	brightenedOnEnter _ false.
	self wrapCentering: #center; cellPositioning: #leftCenter.
	self hResizing: #shrinkWrap.
	borderWidth _ 0.
	self layoutInset: 0.
	self extent: 5@5.  "will grow to fit"
	self minCellSize: (0 @ (Preferences standardEToysFont height rounded + 10)).
	justGrabbedFromViewer _ true.  "All new PhraseTileMorphs that go through the initialize process (rather than being copied) are placed in viewers; the clones dragged out from them will thus have this set the right way; the drop code resets this to false"
! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 6/18/2004 16:01'!
setAngleToOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaAngleToTile new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 10/29/1998 16:01'!
setAssignmentRoot: opSymbol type: opType rcvrType: rcvrType argType: argType
	resultType _ opType.
	self color: (ScriptingSystem colorForType: opType).
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	self addMorphBack: ((AssignmentTileMorph new setRoot: opSymbol asString dataType: argType) typeColor: color).
	self addMorphBack: (TilePadMorph new setType: argType)
! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 8/12/2004 18:58'!
setAssignmentRoot: opSymbol type: opType rcvrType: rcvrType argType: argType vocabulary: aVocabulary
	"Add submorphs to make me constitute a setter of the given symbol"

	| anAssignmentTile |
	resultType _ opType.
	self color: (ScriptingSystem colorForType: opType).
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	anAssignmentTile _ AssignmentTileMorph new rawVocabulary: aVocabulary.
	self addMorphBack: (anAssignmentTile typeColor: color).
	anAssignmentTile setRoot: opSymbol asString dataType: argType.
	anAssignmentTile setAssignmentSuffix: #:.
	self addMorphBack: (TilePadMorph new setType: argType)! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 9/28/2004 18:24'!
setBounceOnColorOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaBounceOnColorTile new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 9/27/2004 14:58'!
setBounceOnOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaBounceOnTile new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 10/12/2004 22:43'!
setColorComponentRoot: opSymbol componentName: componentName type: opType rcvrType: rcvrType argType: argType vocabulary: aVocabulary
	"Add submorphs to make me constitute a setter of the given symbol"

	| anAssignmentTile |
	resultType _ opType.
	self color: (ScriptingSystem colorForType: opType).
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	anAssignmentTile _ KedamaSetColorComponentTile new rawVocabulary: aVocabulary.
	anAssignmentTile componentName: componentName.
	self addMorphBack: (anAssignmentTile typeColor: color).
	anAssignmentTile setRoot: opSymbol asString dataType: argType.
	self addMorphBack: (TilePadMorph new setType: argType)! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 6/18/2004 16:01'!
setDistanceToOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaDistanceToTile new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 1/30/2005 11:02'!
setGetColorComponentOperator: opSymbol componentName: componentName type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaGetColorComponentTile new adoptVocabulary: self currentVocabulary.
	aTileMorph componentName: componentName.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 6/18/2004 16:50'!
setGetPixelOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaGetPixelValueTile new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 2/5/1999 14:51'!
setOperator: opSymbol type: opType rcvrType: rcvrType
	self setOperator: opSymbol type: opType rcvrType: rcvrType argType: nil.
! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 9/26/2001 11:58'!
setOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ TileMorph new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 6/18/2004 16:02'!
setPixelValueRoot: opSymbol type: opType rcvrType: rcvrType argType: argType vocabulary: aVocabulary
	"Add submorphs to make me constitute a setter of the given symbol"

	| anAssignmentTile |
	resultType _ opType.
	self color: (ScriptingSystem colorForType: opType).
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	anAssignmentTile _ KedamaSetPixelValueTile new rawVocabulary: aVocabulary.
	self addMorphBack: (anAssignmentTile typeColor: color).
	anAssignmentTile setRoot: opSymbol asString dataType: argType.
	self addMorphBack: (TilePadMorph new setType: argType)! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:41'!
setSlotRefOperator: opSymbol type: opType
	"Set the given symbol as the receiver's slot-reference operator, adding tiles to the receiver appropriately"

	resultType _ opType.
	self color: (ScriptingSystem colorForType: opType).
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: #Player).
	self addMorphBack: ((TileMorph new setSlotRefOperator: opSymbol asString) typeColor: color)
! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 10/9/2004 15:38'!
setTurtleAtOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaTurtleAtTile new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 3/7/2005 08:39'!
setTurtleOfOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaTurtleOfTile new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'yo 6/18/2004 16:02'!
setUpHillOperator: opSymbol type: opType rcvrType: rcvrType argType: argType
	"Set the operator, type, receiver type, and argument type for the phrase"

	| aTileMorph |

	resultType _ opType.
	opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)].
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	aTileMorph _ KedamaUpHillTile new adoptVocabulary: self currentVocabulary.
	self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'gm 2/24/2003 18:06'!
vocabulary: aVocab 
	"Set the vocabulary"

	vocabularySymbol := (aVocab isKindOf: Symbol) 
				ifTrue: [aVocab]
				ifFalse: [aVocab vocabularyName]! !


!PhraseTileMorph methodsFor: 'macpal' stamp: 'sw 6/4/2001 19:35'!
currentVocabulary
	"Answer the current vocabulary"

	vocabulary "fix up old strutures"
		ifNotNil: 
			[vocabularySymbol _ vocabulary vocabularyName.
			vocabulary _ nil].

	^ vocabularySymbol
		ifNotNil:
			[Vocabulary vocabularyNamed: vocabularySymbol]
		ifNil:
			[super currentVocabulary]
! !


!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 8/11/1998 16:39'!
actualObject
	"Answer the player that's the object of my attention"

	^ self associatedPlayer! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'dgd 8/30/2003 21:56'!
addCustomMenuItems:  aMenu hand: aHand
	"Add additional items to the halo manu"

	super addCustomMenuItems: aMenu hand: aHand.
	aMenu add: 'Sprout a new scriptor around this phrase' translated target: self action: #sproutNewScriptor! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'tk 8/6/1999 13:59'!
associatedPlayer
	"Answer the player that's the object of my attention"

	| pp |
	pp _ self firstSubmorph.
	[pp isKindOf: PhraseTileMorph] whileTrue: [pp _ pp firstSubmorph].
	^ pp firstSubmorph actualObject! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/8/2000 16:42'!
bePossessive
	"No way for doubly possessive stuff to work at present, so we just catch and swallow this request here."

	self flag: #deferred! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 12/22/2004 01:34'!
dismissViaHalo
	"The user has clicked in the delete halo-handle.."

	| ed |
	ed _ self topEditor.
	super dismissViaHalo.
	ed ifNotNil: [ed scriptEdited]! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 3/7/2004 13:04'!
isPlayer: aPlayer ofReferencingTile: tile
	"Answer whether a given player is the object referred to by the given tile, or a sibling of that object."

	^ aPlayer class == self actualObject class! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/19/2001 15:06'!
justGrabbedFromViewer
	"Answer whether the receiver originated in a Viewer.  Only tiles that originated in a viewer will ever do that infernal sprouting of a new script around them.  The nil branch is only for backward compatibility."

	^ justGrabbedFromViewer ifNil: [justGrabbedFromViewer _ true]! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/19/2001 20:26'!
justGrabbedFromViewerOrNil
	"Answer the value of the receiver's justGrabbedFromViewer slot.  Needed only for conversion methods"

	^ justGrabbedFromViewer! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/19/2001 14:25'!
justGrabbedFromViewer: aBoolean
	"Set the receiver's justGrabbedFromViewer instance variable"

	justGrabbedFromViewer _ aBoolean! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'tk 8/16/2000 10:01'!
lastTile
	"The tile that might get an extension arrow"

	^ self lastSubmorph lastTile! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/1/2000 08:41'!
operatorTile
	"Answer the submorph which comprises the operator tile of the receiver.  Ouch!!"

	^ submorphs second! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/27/2001 17:28'!
resultType
	"Answer the result type of the receiver"

	^ resultType! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'tk 2/14/2001 14:07'!
sproutNewScriptor
	"The receiver, operating as a naked phrase tile, wishes to get iself placed in a nascent script"

	| newScriptor |

	self actualObject assureUniClass.
	newScriptor _ self actualObject newScriptorAround:
		((self ownerThatIsA: Viewer orA: ScriptEditorMorph)
			ifNotNil:
				[self veryDeepCopy]
			ifNil:
				[self]).
	self currentHand attachMorph: newScriptor! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'tk 2/15/2001 16:37'!
tileRows
	"Answer a list of tile rows -- in this case exactly one row -- representing the receiver.  The fullCopy is deeply problematical here in the presence of the formerOwner property, so it the latter is temporarily set aside"

	^ Array with: (Array with: self veryDeepCopy)! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'yo 4/4/2005 17:15'!
try
	"Evaluate the given phrase once"

	| aPlayer |
	(userScriptSelector notNil and: [userScriptSelector numArgs = 0])
		ifTrue:
			[aPlayer _ self objectViewed player.
			aPlayer triggerScript: userScriptSelector]
		ifFalse:
			[Compiler evaluate:
				self codeString
				for: self associatedPlayer
				logged: false]! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/29/98 01:49'!
userScriptSelector
	^ userScriptSelector! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/29/98 01:49'!
userScriptSelector: s
	userScriptSelector _ s! !


!PhraseTileMorph methodsFor: 'mouse' stamp: 'tak 3/15/2005 11:40'!
catchDivideByZero: aStream indent: tabCount 
	"See if I am have divide as my operator. If so, insert a test in the argument to divide."

	| exp |
	submorphs second type = #operator ifFalse: [^false].	"not me"
	exp _ submorphs second operatorOrExpression.
	(#(/ // \\) includes: exp) ifFalse: [^false].	"not me"
	aStream space.
	aStream nextPutAll: '(self beNotZero: '.
	(submorphs third) storeCodeOn: aStream indent: tabCount.
	aStream nextPut: $).
	^true! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'tak 4/6/2005 14:20'!
morphToDropInPasteUp: aPasteUp
	"Answer the morph to drop in aPasteUp, given that the receiver is the putative droppee"

	| actualObject itsSelector aScriptor pos aWatcher op |

	((actualObject _ self actualObject) isNil or: [actualObject costume isInWorld not]) ifTrue: [^ self].
	self isCommand ifFalse:  "Can't expand to a scriptor, but maybe launch a watcher..."
		[^ (Preferences dropProducesWatcher and: [(#(unknown command) includes: self resultType) not] and:
			[(op _ self operatorTile operatorOrExpression) notNil] and: [op numArgs = 0] and: [(Vocabulary gettersForbiddenFromWatchers includes: op) not])
			ifTrue:
				[aWatcher _ WatcherWrapper new fancyForPlayer: self associatedPlayer getter: op.
				aWatcher position: self position]
			ifFalse:
				[self]].

	self justGrabbedFromViewer ifFalse: [^ self].
	actualObject assureUniClass.
	itsSelector _ self userScriptSelector.
	pos _ self position.
	aScriptor _ itsSelector isEmptyOrNil
		ifFalse:
			[actualObject scriptEditorFor: itsSelector]
		ifTrue:
			["It's a system-defined selector; construct an anonymous scriptor around it"
			actualObject newScriptorAround: self].
	aScriptor ifNil:[^self].
	(self hasOwner: aScriptor) ifTrue:[
		aScriptor fullBounds. "force layout"
		aScriptor position: pos - self position.
	] ifFalse:[
		aScriptor position: self position.
	].
	^ aScriptor! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'sw 6/17/2003 16:03'!
mouseDown: evt 
	"Handle a mouse-down on the receiver"

	| ed guyToTake dup enclosingPhrase |
	self isPartsDonor ifTrue:
		[dup _ self duplicate.
		dup eventHandler: nil.   "Remove viewer-related evt mouseover feedback"
		evt hand attachMorph: dup.
		dup position: evt position.
		"So that the drag vs. click logic works"
		dup formerPosition: evt position.
		^ self].
	submorphs isEmpty
		ifTrue: [^ self].

	guyToTake _ self.
	[(enclosingPhrase _ guyToTake ownerThatIsA: PhraseTileMorph) notNil] whileTrue:
		[guyToTake _ enclosingPhrase].  "This logic always grabs the outermost phrase, for now anyway"
	
	"the below had comment: 'picking me out of another phrase'"
	"owner class == TilePadMorph
		ifTrue:
			[(ss _ submorphs first) class == TilePadMorph
				ifTrue: [ss _ ss submorphs first].
			guyToTake _  ss veryDeepCopy]."

	(ed _ self enclosingEditor) ifNil: [^ evt hand grabMorph: guyToTake].
	evt hand grabMorph: guyToTake.
	ed startStepping.
	ed mouseEnterDragging: evt.
	ed setProperty: #justPickedUpPhrase toValue: true.
! !


!PhraseTileMorph methodsFor: 'queries' stamp: 'sw 9/28/2001 07:46'!
isBoolean
	"Answer whether the receiver has a boolean type"

	^ self resultType = #Boolean! !

!PhraseTileMorph methodsFor: 'queries' stamp: 'nk 7/8/2000 13:35'!
isCommand
	"Answer whether the receiver is a true line of phrase-command. If not,  
	it is a fragment that will not be able to serve as a line of script on its  
	own"
	| rcvrTile pad |
	submorphs isEmpty
		ifTrue: [^ false].
	pad _ submorphs first.
	(pad isKindOf: TilePadMorph)
		ifTrue: [(submorphs second isKindOf: AssignmentTileMorph)
				ifTrue: [^ true].
			(((rcvrTile _ pad submorphs first) isKindOf: TileMorph)
					and: [rcvrTile isPossessive])
				ifTrue: [^ false]].
	^ true! !

!PhraseTileMorph methodsFor: 'queries' stamp: 'di 8/11/1998 13:15'!
isPossessive
	^ false! !


!PhraseTileMorph methodsFor: 'scripting' stamp: 'sw 4/22/1998 14:59'!
bringUpToDate
	"Nothing here to do in the current architecture"! !

!PhraseTileMorph methodsFor: 'scripting' stamp: 'sw 4/21/1998 21:35'!
isTileScriptingElement
	^ true! !


!PhraseTileMorph methodsFor: 'kedama' stamp: 'sw 10/24/2005 02:48'!
duplicate
	"Make and return a duplicate of the receiver."

	| newMorph |
	newMorph _ super duplicate.
	(self ownerThatIsA: Viewer) ifNotNilDo:
		[:aViewer | newMorph replacePlayerInReadoutWith: aViewer scriptedPlayer].

	^ newMorph! !

!PhraseTileMorph methodsFor: 'kedama' stamp: 'yo 4/6/2005 14:59'!
firstMorphBearingKedamaPlayer

	self allMorphsWithPlayersDo: [:e :p | (p isKindOf: KedamaExamplerPlayer) ifTrue: [^ e]].
	^ nil.
! !

!PhraseTileMorph methodsFor: 'kedama' stamp: 'yo 4/3/2005 17:36'!
morphsBearingPlayers

	| c |
	c _ OrderedCollection new.
	self allMorphsWithPlayersDo: [:e :p | c add: e].
	^ c asArray.
! !

!PhraseTileMorph methodsFor: 'kedama' stamp: 'yo 4/6/2005 14:59'!
replacePlayerInReadoutWith: aPlayer 

	| tile |
	tile _ self firstMorphBearingKedamaPlayer.
	tile ifNil: [^ self].
	(tile isMemberOf: TileMorph) ifFalse: [^ self].
	tile type = #objRef ifFalse: [^ self].
	tile referToSimilarObject: aPlayer.

	self allMorphsDo: [:e |
		((e isMemberOf: UpdatingStringMorph) or: [e isMemberOf: UpdatingRectangleMorph]) ifTrue: [
			e target isPlayerLike ifTrue: [
				e target: aPlayer
			].
		].
	].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhraseTileMorph class
	instanceVariableNames: ''!

!PhraseTileMorph class methodsFor: 'backward compatibility' stamp: 'sw 1/19/2001 22:25'!
markViewerOrigination
	"For bringing old content forward"

	| hadIt gotIt didntWantIt |
	hadIt _ 0.
	gotIt _ 0.
	didntWantIt _ 0.
	self allSubInstancesDo:
		[:m | (m ownerThatIsA: CategoryViewer)
			ifNil:
				[m justGrabbedFromViewer: false.
				didntWantIt _ didntWantIt + 1]
			ifNotNil:
				[(m justGrabbedFromViewerOrNil == true)
					ifTrue:
						[hadIt _ hadIt + 1]
					ifFalse:
						[m justGrabbedFromViewer: true.
						gotIt _ gotIt + 1]]].
	Transcript cr; show: 'updating phrase tiles -- already ok: '; show: hadIt; show: '  marked as in-viewer: '; show: gotIt; show: '  marked as not-in-viewer: '; show: didntWantIt.

	"PhraseTileMorph markViewerOrigination"! !


!PhraseTileMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'!
defaultNameStemForInstances
	^ 'PhraseTile'! !
AlignmentMorph subclass: #PhraseWrapperMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!PhraseWrapperMorph commentStamp: '<historical>' prior: 0!
An alignment morph designed for use in scripting Viewers; it wraps a set of phrases in a category viewer, and repels attempts to drop phrases upon it.!


!PhraseWrapperMorph methodsFor: 'dropping/grabbing' stamp: 'sw 6/1/2000 22:30'!
repelsMorph: aMorph event: ev
	^ (aMorph isKindOf: PhraseTileMorph) or:
		[aMorph hasProperty: #newPermanentScript]! !


!PhraseWrapperMorph methodsFor: 'parts bin' stamp: 'sw 8/12/97 14:16'!
isPartsBin
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhraseWrapperMorph class
	instanceVariableNames: ''!

!PhraseWrapperMorph class methodsFor: 'new-morph participation' stamp: 'sw 11/9/1998 16:16'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
RectangleMorph subclass: #PianoKeyboardMorph
	instanceVariableNames: 'whiteKeyColor blackKeyColor playingKeyColor nOctaves target noteOnSelector noteOffSelector soundPrototype soundPlaying'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!PianoKeyboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color veryLightGray! !

!PianoKeyboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:56'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	whiteKeyColor _ Color gray: 0.95.
	blackKeyColor _ Color black.
	playingKeyColor _ Color red.
	nOctaves _ 6.
	self buildKeyboard.
	soundPrototype _ FMSound brass1 duration: 9.9! !


!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:30'!
buildKeyboard
	| wtWid bkWid keyRect octavePt nWhite nBlack |
	self removeAllMorphs.
	wtWid _ 8. bkWid _ 5.
	self extent: 10@10.
	1 to: nOctaves+1 do:
		[:i | i <= nOctaves ifTrue: [nWhite _ 7.  nBlack _ 5]
						ifFalse: [nWhite _ 1.  nBlack _ 0 "High C"].
		octavePt _ self innerBounds topLeft + ((7*wtWid*(i-1)-1)@-1).
		1 to: nWhite do:
			[:j | keyRect _ octavePt + (j-1*wtWid@0) extent: (wtWid+1)@36.
			self addMorph: ((RectangleMorph newBounds: keyRect color: whiteKeyColor)
								borderWidth: 1;
				on: #mouseDown send: #mouseDownPitch:event:noteMorph: to: self
								withValue: i-1*12 + (#(1 3 5 6 8 10 12) at: j))].
		1 to: nBlack do:
			[:j | keyRect _ octavePt + ((#(6 15 29 38 47) at: j)@1) extent: bkWid@21.
			self addMorph: ((Morph newBounds: keyRect color: blackKeyColor)
				on: #mouseDown send: #mouseDownPitch:event:noteMorph: to: self
								withValue: i-1*12 + (#(2 4 7 9 11) at: j))]].
	self submorphsDo:
		[:m | m on: #mouseMove send: #mouseMovePitch:event:noteMorph: to: self;
				on: #mouseUp send: #mouseUpPitch:event:noteMorph: to: self;
				on: #mouseEnterDragging send: #mouseDownPitch:event:noteMorph: to: self;
				on: #mouseLeaveDragging send: #mouseUpPitch:event:noteMorph: to: self].
	self extent: (self fullBounds extent + borderWidth - 1)! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/18/2001 17:27'!
mouseDownEvent: arg1 noteMorph: arg2 pitch: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self mouseDownPitch: arg1 event: arg2 noteMorph: arg3! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:27'!
mouseDownPitch: midiKey event: event noteMorph: noteMorph
	| pitch |
	event hand hasSubmorphs ifTrue: [^ self  "no response if drag something over me"].
	event hand mouseFocus ifNil:
		["If dragged into me, then establish focus so I'll see moves"
		event hand newMouseFocus: noteMorph event: event].
	noteMorph color: playingKeyColor.
	pitch _ AbstractSound pitchForMIDIKey: midiKey + 23.
	soundPlaying ifNotNil: [soundPlaying stopGracefully].
	soundPlaying _ soundPrototype soundForPitch: pitch dur: 100.0 loudness: 0.3.
	SoundPlayer resumePlaying: soundPlaying quickStart: true.
! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/18/2001 17:27'!
mouseMoveEvent: arg1 noteMorph: arg2 pitch: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self mouseMovePitch: arg1 event: arg2 noteMorph: arg3! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:28'!
mouseMovePitch: pitch event: event noteMorph: noteMorph

	(noteMorph containsPoint: event cursorPoint) ifFalse:
		["If drag out of me, zap focus so other morphs can see drag in."
		event hand releaseMouseFocus: noteMorph]
! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/18/2001 17:28'!
mouseUpEvent: arg1 noteMorph: arg2 pitch: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self mouseUpPitch: arg1 event: arg2 noteMorph: arg3! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:29'!
mouseUpPitch: pitch event: event noteMorph: noteMorph

	noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12)
					ifTrue: [whiteKeyColor]
					ifFalse: [blackKeyColor]).
	soundPlaying ifNotNil: [soundPlaying stopGracefully].
! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'di 9/4/1998 12:57'!
soundPrototype: aSound
	soundPrototype _ aSound! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PianoKeyboardMorph class
	instanceVariableNames: ''!

!PianoKeyboardMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 14:52'!
descriptionForPartsBin
	^ self partName:	'PianoKeyboard'
		categories:		#('Multimedia')
		documentation:	'A piano keyboard'! !
Morph subclass: #PianoRollNoteMorph
	instanceVariableNames: 'trackIndex indexInTrack hitLoc editMode selected notePlaying'
	classVariableNames: 'SoundPlaying'
	poolDictionaries: ''
	category: 'Sound-Scores'!
!PianoRollNoteMorph commentStamp: '<historical>' prior: 0!
A PianoRollNoteMorph is drawn as a simple mroph, but it carries the necessary state to locate its source sound event via its owner (a PianorRollScoreMorph) and the score therein.  Simple editing of pitch and time placement is provided here.!


!PianoRollNoteMorph methodsFor: 'accessing' stamp: 'di 6/17/1999 11:17'!
indexInTrack

	^ indexInTrack! !

!PianoRollNoteMorph methodsFor: 'accessing' stamp: 'di 6/17/1999 11:16'!
trackIndex

	^ trackIndex! !


!PianoRollNoteMorph methodsFor: 'drawing' stamp: 'di 6/17/1999 10:56'!
drawOn: aCanvas

	selected
		ifTrue: [aCanvas frameAndFillRectangle: self fullBounds fillColor: color borderWidth: 1 borderColor: Color black]
		ifFalse: [aCanvas fillRectangle: self bounds color: color].
! !


!PianoRollNoteMorph methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:41'!
editPitch: evt

	| mk note |
	mk := owner midiKeyForY: evt cursorPoint y.
	note := (owner score tracks at: trackIndex) at: indexInTrack.
	note midiKey = mk ifTrue: [^ self].
	note midiKey: mk.
	self playSound: (self soundOfDuration: 999.0).
	self position: self position x @ ((owner yForMidiKey: mk) - 1)
! !

!PianoRollNoteMorph methodsFor: 'editing' stamp: 'di 6/17/1999 16:08'!
gridToNextQuarter

	owner score gridTrack: trackIndex toQuarter: 1 at: indexInTrack.
	owner rebuildFromScore! !

!PianoRollNoteMorph methodsFor: 'editing' stamp: 'di 6/17/1999 16:08'!
gridToPrevQuarter

	owner score gridTrack: trackIndex toQuarter: -1 at: indexInTrack.
	owner rebuildFromScore! !


!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/15/1999 14:55'!
handlesMouseDown: evt

	^ owner scorePlayer isPlaying not! !

!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'stephaneducasse 2/4/2006 20:41'!
mouseDown: evt

	hitLoc := evt cursorPoint.
	editMode := nil.
	owner submorphsDo:
		[:m | (m isKindOf: PianoRollNoteMorph) ifTrue: [m deselect]].
	selected := true.
	self changed.
	owner selection: (Array with: trackIndex with: indexInTrack with: indexInTrack).
	self playSound! !

!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 14:49'!
mouseMove: evt 
	| delta offsetEvt |
	editMode isNil 
		ifTrue: 
			["First movement determines edit mode"

			((delta := evt cursorPoint - hitLoc) dist: 0 @ 0) <= 2 
				ifTrue: [^self	"No significant movement yet."].
			delta x abs > delta y abs 
				ifTrue: 
					[delta x > 0 
						ifTrue: 
							["Horizontal drag"

							editMode := #selectNotes]
						ifFalse: 
							[self playSound: nil.
							offsetEvt := evt copy setCursorPoint: evt cursorPoint + (20 @ 0).
							self invokeNoteMenu: offsetEvt]]
				ifFalse: [editMode := #editPitch	"Vertical drag"]].
	editMode == #editPitch ifTrue: [self editPitch: evt].
	editMode == #selectNotes ifTrue: [self selectNotes: evt]! !

!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 08:29'!
mouseUp: evt

	self playSound: nil! !


!PianoRollNoteMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
trackIndex: ti indexInTrack: i

	trackIndex := ti.
	indexInTrack := i.
	selected := false! !


!PianoRollNoteMorph methodsFor: 'layout' stamp: 'di 6/17/1999 10:55'!
fullBounds

	selected
		ifTrue: [^ bounds expandBy: 1]
		ifFalse: [^ bounds]! !


!PianoRollNoteMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
invokeNoteMenu: evt
	"Invoke the note's edit menu."

	| menu |
	menu := MenuMorph new defaultTarget: self.
	menu addList:
		#(('grid to next quarter'		gridToNextQuarter)
		('grid to prev quarter'		gridToPrevQuarter)).

	menu popUpEvent: evt in: self world.
! !


!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/17/1999 11:48'!
noteInScore

	^ (owner score tracks at: trackIndex) at: indexInTrack
! !

!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
noteOfDuration: duration

	| note |
	note := self noteInScore.
	^ (owner scorePlayer instrumentForTrack: trackIndex)
			soundForMidiKey: note midiKey
			dur: duration
			loudness: (note velocity asFloat / 127.0)
! !

!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/19/1999 08:19'!
playSound
	"This STARTS a single long sound.  It must be stopped by playing another or nil."

	^ self playSound: (self soundOfDuration: 999.0)! !

!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
playSound: aSoundOrNil

	SoundPlaying ifNotNil: [SoundPlaying stopGracefully].
	SoundPlaying := aSoundOrNil.
	SoundPlaying ifNotNil: [SoundPlaying play].! !

!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
soundOfDuration: duration

	| sound |
	sound := MixedSound new.
	sound add: (self noteOfDuration: duration)
		pan: (owner scorePlayer panForTrack: trackIndex)
		volume: owner scorePlayer overallVolume *
				(owner scorePlayer volumeForTrack: trackIndex).
	^ sound reset
! !


!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:41'!
deselect

	selected ifFalse: [^ self].
	self changed.
	selected := false.
! !

!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:41'!
select

	selected ifTrue: [^ self].
	selected := true.
	self changed! !

!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'dgd 2/22/2003 14:50'!
selectFrom: selection 
	(trackIndex = selection first and: 
			[indexInTrack >= (selection second) and: [indexInTrack <= (selection third)]]) 
		ifTrue: [selected ifFalse: [self select]]
		ifFalse: [selected ifTrue: [self deselect]]! !

!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:41'!
selectNotes: evt

	| lastMorph oldEnd saveOwner |
	saveOwner := owner.
	(owner autoScrollForX: evt cursorPoint x) ifTrue:
		["If scroll talkes place I will be deleted and my x-pos will become invalid."
		owner := saveOwner.
		bounds := bounds withLeft: (owner xForTime: self noteInScore time)].
	oldEnd := owner selection last.
	(owner notesInRect: (evt cursorPoint x @ owner top corner: owner bottomRight))
		do: [:m | m trackIndex = trackIndex ifTrue: [m deselect]].
	self select.  lastMorph := self.
	(owner notesInRect: (self left @ owner top corner: evt cursorPoint x @ owner bottom))
		do: [:m | m trackIndex = trackIndex ifTrue: [m select.  lastMorph := m]].
	owner selection: (Array with: trackIndex with: indexInTrack with: lastMorph indexInTrack).
	lastMorph indexInTrack ~= oldEnd ifTrue:
		["Play last note as selection grows or shrinks"
		owner ifNotNil: [lastMorph playSound]]
! !

!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/20/1999 11:44'!
selected

	^ selected! !
RectangleMorph subclass: #PianoRollScoreMorph
	instanceVariableNames: 'scorePlayer score colorForTrack lowestNote leftEdgeTime timeScale indexInTrack lastUpdateTick lastMutedState cursor selection timeSignature beatsPerMeasure notePerBeat showMeasureLines showBeatLines soundsPlaying soundsPlayingMorph movieClipPlayer'
	classVariableNames: 'NotePasteBuffer'
	poolDictionaries: ''
	category: 'Sound-Scores'!
!PianoRollScoreMorph commentStamp: '<historical>' prior: 0!
A PianoRollScoreMorph displays a score such as a MIDIScore, and will scroll through it tracking the progress of a ScorePlayerMorph (from which it is usually spawned).

timeScale is in pixels per score tick.

Currently the ambient track (for synchronizing thumbnails, eg) is treated specially here and in the score.  This should be cleaned up by adding a trackType or something like it in the score.!


!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 16:25'!
beatsPerMeasure: n

	^ self timeSignature: n over: notePerBeat! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 10/19/2000 10:07'!
movieClipPlayer

	^ movieClipPlayer! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
movieClipPlayer: moviePlayer

	movieClipPlayer := moviePlayer
! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 16:25'!
notePerBeat: n

	^ self timeSignature: beatsPerMeasure over: n! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/15/1999 15:46'!
score

	^ score! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/15/1999 14:52'!
scorePlayer

	^ scorePlayer! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
selection
	"Returns an array of 3 elements:
		trackIndex
		indexInTrack of first note
		indexInTrack of last note"

	| trackIndex track |
	selection ifNil:  "If no selection, return last event of 1st non-muted track (or nil)"
		[trackIndex := (1 to: score tracks size)
			detect: [:i | (scorePlayer mutedForTrack: i) not] ifNone: [^ nil].
		track := score tracks at: trackIndex.
		^ Array with: trackIndex with: track size with: track size].
	(scorePlayer mutedForTrack: selection first)
		ifTrue: [selection := nil.  ^ self selection].
	^ selection! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
selection: anArray

	selection := anArray! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 10/19/2000 21:19'!
timeScale

	^ timeScale  "in pixels per tick"! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
timeSignature: num over: denom

	beatsPerMeasure := num.
	notePerBeat := denom.  "a number like 2, 4, 8"
	self changed! !


!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'stephaneducasse 2/4/2006 20:41'!
addNotes
	"Recompute the set of morphs that should be visible at the current scroll position."

	| visibleMorphs rightEdge topEdge trackColor i done n nLeft nTop nRight rightEdgeTime |
	visibleMorphs := OrderedCollection new: 500.
	rightEdge := self right - borderWidth.
	rightEdgeTime := self timeForX: rightEdge.
	topEdge := self top + borderWidth + 1.

	"Add ambient morphs first (they will be front-most)"
	score eventMorphsWithTimeDo:
		[:m :t | m addMorphsTo: visibleMorphs pianoRoll: self eventTime: t
					betweenTime: leftEdgeTime and: rightEdgeTime].

	"Then add note morphs"
	score tracks withIndexDo:
		[:track :trackIndex |
		trackColor := colorForTrack at: trackIndex.
		i := indexInTrack at: trackIndex.
		done := scorePlayer mutedForTrack: trackIndex.
		[done | (i > track size)] whileFalse: [
			n := track at: i.
			(n isNoteEvent and: [n midiKey >= lowestNote]) ifTrue: [
				n time > rightEdgeTime
					ifTrue: [done := true]
					ifFalse: [
						nLeft := self xForTime: n time.
						nTop := (self yForMidiKey: n midiKey) - 1.
						nTop > topEdge ifTrue: [
							nRight := nLeft + (n duration * timeScale) truncated - 1.
							visibleMorphs add:
								((PianoRollNoteMorph
									newBounds: (nLeft@nTop corner: nRight@(nTop + 3))
									color: trackColor)
									trackIndex: trackIndex indexInTrack: i)]]].
			i := i + 1].
			(selection notNil
				and: [trackIndex = selection first
				and: [i >= selection second and: [(indexInTrack at: trackIndex) <= selection third]]])
				ifTrue: [visibleMorphs do:
						[:vm | (vm isKindOf: PianoRollNoteMorph) ifTrue: [vm selectFrom: selection]]]].

	"Add the cursor morph in front of all notes; height and position are set later."
	cursor ifNil: [cursor := Morph newBounds: (self topLeft extent: 1@1) color: Color red].
	visibleMorphs addFirst: cursor.

	self changed.
	self removeAllMorphs.
	self addAllMorphs: visibleMorphs.
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'stephaneducasse 2/4/2006 20:41'!
drawMeasureLinesOn: aCanvas

	| ticksPerMeas x measureLineColor inner |
	showBeatLines ifNil: [showBeatLines := false].
	showMeasureLines ifNil: [showMeasureLines := true].
	notePerBeat ifNil: [self timeSignature: 4 over: 4].
	showBeatLines ifTrue:
		[measureLineColor := Color gray: 0.8.
		ticksPerMeas := score ticksPerQuarterNote.
		inner := self innerBounds.
		(leftEdgeTime + ticksPerMeas truncateTo: ticksPerMeas)
			to: ((self timeForX: self right - borderWidth) truncateTo: ticksPerMeas)
			by: ticksPerMeas
			do: [:tickTime | x := self xForTime: tickTime.
				aCanvas fillRectangle: (x @ inner top extent: 1 @ inner height)
					color: measureLineColor]].

	showMeasureLines ifTrue:
		[measureLineColor := Color gray: 0.7.
		ticksPerMeas := beatsPerMeasure*score ticksPerQuarterNote*4//notePerBeat.
		inner := self innerBounds.
		(leftEdgeTime + ticksPerMeas truncateTo: ticksPerMeas)
			to: ((self timeForX: self right - borderWidth) truncateTo: ticksPerMeas)
			by: ticksPerMeas
			do: [:tickTime | x := self xForTime: tickTime.
				aCanvas fillRectangle: (x @ inner top extent: 1 @ inner height)
						color: (tickTime = 0 ifTrue: [Color black] ifFalse: [measureLineColor])]].
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'jm 5/30/1999 17:56'!
drawOn: aCanvas

	super drawOn: aCanvas.
	self drawStaffOn: aCanvas.
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'stephaneducasse 2/4/2006 20:41'!
drawStaffOn: aCanvas

	| blackKeyColor l r topEdge y |
	self drawMeasureLinesOn: aCanvas.

	blackKeyColor := Color gray: 0.5.
	l := self left + borderWidth.
	r := self right - borderWidth.
	topEdge := self top + borderWidth + 3.
	lowestNote to: 127 do: [:k |
		y := self yForMidiKey: k.
		y <= topEdge ifTrue: [^ self].  "over the top!!"
		(self isBlackKey: k) ifTrue: [
			aCanvas
				fillRectangle: (l@y corner: r@(y + 1))
				color: blackKeyColor]].
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'stephaneducasse 2/4/2006 20:41'!
isBlackKey: midiKey
	"Answer true if the given MIDI key corresponds to a black key on the piano keyboard."

	| note |
	note := midiKey \\ 12.
	note = 1 ifTrue: [^ true].
	note = 3 ifTrue: [^ true].
	note = 6 ifTrue: [^ true].
	note = 8 ifTrue: [^ true].
	note = 10 ifTrue: [^ true].
	^ false
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'di 6/20/1999 12:23'!
rebuildFromScore
	"Rebuild my submorphs from the score. This method should be invoked after changing the time scale, the color or visibility of a track, the extent of this morph, etc."

	score ifNil: [^ self].
	self addNotes.
! !


!PianoRollScoreMorph methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:41'!
appendEvent: noteEvent fullDuration: fullDuration 

	| sel x |
	score appendEvent: noteEvent fullDuration: fullDuration at: (sel := self selection).
	noteEvent midiKey = -1 ifFalse:  "Unless it is a rest..."
		["Advance the selection to the note just entered"
		selection := Array with: sel first with: sel third + 1 with: sel third + 1].

	"This is all horribly inefficient..."
	scorePlayer updateDuration.
	(x := self xForTime: noteEvent endTime) > (self right - 30) ifTrue:
		[self autoScrollForX: x + (30 + self width // 4)].
	self updateLowestNote.
	self rebuildFromScore! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'!
copySelection
	selection isNil ifTrue: [^self].
	NotePasteBuffer := (score tracks at: selection first) 
				copyFrom: selection second
				to: selection third! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'!
cutSelection
	selection isNil ifTrue: [^self].
	self copySelection.
	self deleteSelection! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'!
deleteSelection
	| selMorphs priorEvent x |
	(selection isNil or: [selection second = 0]) ifTrue: [^self].
	score cutSelection: selection.
	selection second > 1 
		ifTrue: 
			[selection at: 2 put: selection second - 1.
			selection at: 3 put: selection second.
			priorEvent := (score tracks at: selection first) at: selection second.
			(x := self xForTime: priorEvent time) < (self left + 30) 
				ifTrue: [self autoScrollForX: x - ((30 + self width) // 4)]]
		ifFalse: [selection := nil].
	scorePlayer updateDuration.
	self rebuildFromScore.
	selMorphs := self 
				submorphsSatisfying: [:m | (m isKindOf: PianoRollNoteMorph) and: [m selected]].
	selMorphs isEmpty ifFalse: [(selMorphs last noteOfDuration: 0.3) play]! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'!
insertSelection
	self selection isNil ifTrue: [^self].
	score insertEvents: NotePasteBuffer at: self selection.
	scorePlayer updateDuration.
	self rebuildFromScore! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'!
insertTransposed
	| delta transposedNotes |
	(delta := (SelectionMenu 
				selections: ((12 to: -12 by: -1) collect: [:i | i printString])) 
					startUpWithCaption: 'offset...') ifNil: [^self].
	transposedNotes := NotePasteBuffer 
				collect: [:note | note copy midiKey: note midiKey + delta].
	selection isNil ifTrue: [^self].
	score insertEvents: transposedNotes at: self selection.
	scorePlayer updateDuration.
	self rebuildFromScore! !


!PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/17/1999 12:40'!
handlesMouseDown: evt

	^ true! !

!PianoRollScoreMorph methodsFor: 'event handling' stamp: 'stephaneducasse 2/4/2006 20:41'!
mouseDown: evt

	| noteMorphs chordRect sound |
	(self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 2@30)) isEmpty
		ifTrue: ["If not near a note, then put up score edit menu"
				^ self invokeScoreMenu: evt].

	"Clicked near (but not on) a note, so play all notes at the cursor time"
	noteMorphs := self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 0@self height).
	chordRect := (self innerBounds withLeft: evt cursorPoint x) withWidth: 1.
	soundsPlayingMorph := Morph newBounds: chordRect color: Color green.
	self addMorphBack: soundsPlayingMorph.
	
	soundsPlaying := IdentityDictionary new.
	noteMorphs do:
		[:m | sound := m soundOfDuration: 999.0.
		soundsPlaying at: m put: sound.
		SoundPlayer resumePlaying: sound quickStart: false].

! !

!PianoRollScoreMorph methodsFor: 'event handling' stamp: 'stephaneducasse 2/4/2006 20:41'!
mouseMove: evt

	| noteMorphs chordRect sound |
	soundsPlaying ifNil: [^ self].
	self autoScrollForX: evt cursorPoint x.

	"Play all notes at the cursor time"
	noteMorphs := self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 0@self height).
	chordRect := (self innerBounds withLeft: evt cursorPoint x) withWidth: 1.
	soundsPlayingMorph delete.
	soundsPlayingMorph := Morph newBounds: chordRect color: Color green.
	self addMorphBack: soundsPlayingMorph.
	
	noteMorphs do:
		[:m |  "Add any new sounds"
		(soundsPlaying includesKey: m)
			ifFalse: [sound := m soundOfDuration: 999.0.
					soundsPlaying at: m put: sound.
					SoundPlayer resumePlaying: sound quickStart: false]].
	soundsPlaying keys do:
		[:m |  "Remove any sounds no longer in selection."
		(noteMorphs includes: m)
			ifFalse: [(soundsPlaying at: m) stopGracefully.
					soundsPlaying removeKey: m]].

! !

!PianoRollScoreMorph methodsFor: 'event handling' stamp: 'stephaneducasse 2/4/2006 20:41'!
mouseUp: evt

	soundsPlayingMorph ifNotNil: [soundsPlayingMorph delete].
	soundsPlaying ifNotNil: [soundsPlaying do: [:s | s stopGracefully]].
	soundsPlayingMorph := soundsPlaying := nil
! !


!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'stephaneducasse 2/4/2006 20:41'!
contractTime

	timeScale := timeScale / 1.5.
	self rebuildFromScore.
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'stephaneducasse 2/4/2006 20:41'!
expandTime

	timeScale := timeScale * 1.5.
	self rebuildFromScore.
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 6/20/1999 15:25'!
extent: aPoint
	"Force rebuild when re-sized."

	super extent: aPoint. 
	score ifNotNil: [self updateLowestNote].
	self rebuildFromScore.
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 6/15/1999 14:48'!
midiKeyForY: y

	^ lowestNote - ((y - (bounds bottom - borderWidth - 4)) // 3)
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 10/12/2000 00:40'!
tickTimeAtCursor
	cursor ifNil: [^ 0].
	^ self timeForX: cursor left! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 8/3/1998 21:35'!
timeForX: aNumber

	^ ((aNumber - bounds left - borderWidth) asFloat / timeScale + leftEdgeTime) asInteger! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 8/3/1998 21:29'!
xForTime: aNumber

	^ ((aNumber - leftEdgeTime) asFloat * timeScale) asInteger + bounds left + borderWidth
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 7/10/1998 14:35'!
yForMidiKey: midiKey

	^ (bounds bottom - borderWidth - 4) - (3 * (midiKey - lowestNote))
! !


!PianoRollScoreMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!PianoRollScoreMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color white! !

!PianoRollScoreMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	self extent: 400 @ 300.
	showMeasureLines := true.
	showBeatLines := false.
	self timeSignature: 4 over: 4.
	self clipSubmorphs: true! !

!PianoRollScoreMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
on: aScorePlayer

	scorePlayer := aScorePlayer.
	score := aScorePlayer score.
	colorForTrack := Color wheel: score tracks size.
	leftEdgeTime := 0.
	timeScale := 0.1.
	indexInTrack := Array new: score tracks size withAll: 1.
	lastUpdateTick := -1.

	self updateLowestNote
! !

!PianoRollScoreMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateLowestNote
	"find the actual lowest note in the score"

	| n |
	lowestNote := 128 - (self innerBounds height // 3).
	score tracks do: [:track |
		1 to: track size do: [:i |
			n := track at: i.
			(n isNoteEvent and: [n midiKey < lowestNote])
				ifTrue: [lowestNote := n midiKey - 4]]].
! !


!PianoRollScoreMorph methodsFor: 'layout' stamp: 'RAA 12/11/2000 23:00'!
acceptDroppingMorph: aMorph event: evt
	"In addition to placing this morph in the pianoRoll, add a corresponding
	event to the score so that it will always appear when played, in addition
	to possibly triggering other actions"

	aMorph justDroppedIntoPianoRoll: self event: evt.
	super acceptDroppingMorph: aMorph event: evt.

! !

!PianoRollScoreMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
fullBounds
	"Overridden to clip submorph hit detection to my bounds."

	fullBounds ifNil: [fullBounds := bounds].
	^ bounds
! !

!PianoRollScoreMorph methodsFor: 'layout' stamp: 'jm 9/11/1998 09:20'!
layoutChanged
	"Override this to avoid propagating 'layoutChanged' when just adding/removing note objects."

	fullBounds = bounds ifTrue: [^ self].
	super layoutChanged.
! !


!PianoRollScoreMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:56'!
addCustomMenuItems: aMenu hand: aHandMorph

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu add: 'expand time' translated action: #expandTime.
	aMenu add: 'contract time' translated action: #contractTime.
	aMenu addLine.
	aMenu add: 'add movie clip player' translated action: #addMovieClipPlayer.
	(self valueOfProperty: #dragNDropEnabled) == true
		ifTrue: [aMenu add: 'close drag and drop' translated action: #disableDragNDrop]
		ifFalse: [aMenu add: 'open drag and drop' translated action: #enableDragNDrop].
! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 6/18/1999 15:55'!
addKeyboard

	(KeyboardMorphForInput new pianoRoll: self) openInWorld! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
beatLinesOnOff

	showBeatLines := showBeatLines not.
	self changed! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
invokeScoreMenu: evt
	"Invoke the score's edit menu."

	| menu subMenu |
	menu := MenuMorph new defaultTarget: self.
	menu addList:
		{{'cut' translated.		#cutSelection}.
		{'copy' translated.		#copySelection}.
		{'paste' translated.		#insertSelection}.
		{'paste...' translated.		#insertTransposed}}.
	menu addLine.
	menu addList:
		{{'legato' translated.		#selectionBeLegato}.
		{'staccato' translated.	#selectionBeStaccato}.
		{'normal' translated.		#selectionBeNormal}}.
	menu addLine.
	menu addList:
		{{'expand time' translated.		#expandTime}.
		{'contract time' translated.		#contractTime}}.
	menu addLine.
	subMenu := MenuMorph new defaultTarget: self.
		(2 to: 12) do: [:i | subMenu add: i printString selector: #beatsPerMeasure: argument: i].
		menu add: 'time   ' translated, beatsPerMeasure printString subMenu: subMenu.
	subMenu := MenuMorph new defaultTarget: self.
		#(2 4 8) do: [:i | subMenu add: i printString selector: #notePerBeat: argument: i].
		menu add: 'sig     ' translated, notePerBeat printString subMenu: subMenu.
	menu addLine.
	showMeasureLines
		ifTrue: [menu add: 'hide measure lines' translated action: #measureLinesOnOff]
		ifFalse: [menu add: 'show measure lines' translated action: #measureLinesOnOff].
	showBeatLines
		ifTrue: [menu add: 'hide beat lines' translated action: #beatLinesOnOff]
		ifFalse: [menu add: 'show beat lines' translated action: #beatLinesOnOff].

	menu addLine.
	menu add: 'add keyboard' translated action: #addKeyboard.

	menu popUpEvent: evt in: self world.
! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
measureLinesOnOff

	showMeasureLines := showMeasureLines not.
	self changed! !


!PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'stephaneducasse 2/4/2006 20:41'!
autoScrollForX: x
	"Scroll by the amount x lies outside of my innerBounds.  Return true if this happens."

	| d ticks |
	((d := x - self innerBounds right) > 0
		or: [(d := x - self innerBounds left) < 0])
		ifTrue: [ticks := (self timeForX: self bounds center x + d+1)
						min: score durationInTicks max: 0.
				self moveCursorToTime: ticks.
				scorePlayer ticksSinceStart: ticks.
				^ true].
	^ false
! !

!PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'stephaneducasse 2/4/2006 20:41'!
goToTime: scoreTime

	| track trackSize index newLeftEdgeTime |
	newLeftEdgeTime := scoreTime asInteger.
	newLeftEdgeTime < leftEdgeTime
		ifTrue: [indexInTrack := Array new: score tracks size+1 withAll: 1].
	leftEdgeTime := newLeftEdgeTime.
	1 to: score tracks size do: [:trackIndex |
		track := score tracks at: trackIndex.
		index := indexInTrack at: trackIndex.
		trackSize := track size.
		[(index < trackSize) and:
		 [(track at: index) endTime < leftEdgeTime]]
			whileTrue: [index := index + 1].
		indexInTrack at: trackIndex put: index].
	self addNotes.
! !

!PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'stephaneducasse 2/4/2006 20:41'!
moveCursorToTime: scoreTime

	| cursorOffset desiredCursorHeight |
	scorePlayer isPlaying
		ifTrue:
			[cursorOffset := ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger.
			(cursorOffset < 0
				or: [cursorOffset > (self width-20)])
				ifTrue:
				[self goToTime: scoreTime - (20/timeScale).
				cursorOffset := ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger]]
		ifFalse:
			[self goToTime: (scoreTime - (self width//2 / timeScale)
							max: (self width//10 / timeScale) negated).
			cursorOffset := ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger].

	cursor position: (self left + borderWidth + cursorOffset)@(self top + borderWidth).
	desiredCursorHeight := self height.
	cursor height ~= desiredCursorHeight ifTrue: [cursor extent: 1@desiredCursorHeight].
! !

!PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'di 6/17/1999 09:36'!
notesInRect: timeSlice

	^ self submorphsSatisfying:
		[:m | (timeSlice intersects: m bounds)
				and: [m isKindOf: PianoRollNoteMorph]]! !


!PianoRollScoreMorph methodsFor: 'stepping and presenter' stamp: 'stephaneducasse 2/4/2006 20:41'!
step

	| t |
	score ifNil: [^ self].

	lastMutedState ~= scorePlayer mutedState ifTrue: [
		self rebuildFromScore.
		lastMutedState := scorePlayer mutedState copy].

	t := scorePlayer ticksSinceStart.
	t = lastUpdateTick ifFalse: [
		self moveCursorToTime: t.
		lastUpdateTick := t].
! !


!PianoRollScoreMorph methodsFor: 'testing' stamp: 'jm 6/1/1998 09:07'!
stepTime

	^ 0
! !


!PianoRollScoreMorph methodsFor: '*movies-*movies' stamp: 'stephaneducasse 2/4/2006 20:48'!
addMovieClipPlayer

	movieClipPlayer := MoviePlayerMorph new.
	movieClipPlayer pianoRoll: self.  "back link"
	self activeHand attachMorph: movieClipPlayer! !


!PianoRollScoreMorph methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
removedMorph: aMorph
	| trackSize |
	trackSize := score ambientTrack size.
	score removeAmbientEventWithMorph: aMorph.
	trackSize = score ambientTrack size ifFalse:
		["Update duration if we removed an event"
		scorePlayer updateDuration].
	^super removedMorph: aMorph! !
Notification subclass: #PickAFileToWriteNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
ImageMorph subclass: #PinMorph
	instanceVariableNames: 'component pinForm pinSpec wires'
	classVariableNames: 'InputPinForm IoPinForm OutputPinForm'
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!PinMorph methodsFor: 'accessing' stamp: 'di 5/1/1998 15:51'!
pinSpec
	^ pinSpec! !


!PinMorph methodsFor: 'event handling' stamp: 'jm 5/29/1998 14:33'!
handlesMouseDown: evt

	^ (evt yellowButtonPressed | evt blueButtonPressed) not
! !

!PinMorph methodsFor: 'event handling' stamp: 'di 4/30/1998 22:34'!
mouseDown: event
	"Unshifted action is to move the pin (see mouseMove:)"
	event shiftPressed ifTrue: [self startWiring: event].
! !

!PinMorph methodsFor: 'event handling' stamp: 'di 4/30/1998 12:30'!
mouseMove: evt
	evt shiftPressed ifTrue: [^ self].
	self position: evt targetPoint.
	self updateImage! !


!PinMorph methodsFor: 'geometry' stamp: 'di 1/18/2000 12:31'!
placeFromSpec
	| side corners c1 c2 |
	side _ pinSpec pinLoc asInteger.  "1..4 ccw from left"
	corners _ owner bounds corners.
	c1 _ corners at: side.
	c2 _ corners atWrap: side+1.
	self position: (c1 + (c2 - c1 * pinSpec pinLoc fractionPart)).
	self updateImage.! !

!PinMorph methodsFor: 'geometry' stamp: 'aoy 2/15/2003 21:23'!
position: p 
	"Adhere to owner bounds, and apply gridding"

	| r side p1 corners c1 c2 sideIndex |
	r := owner bounds.
	side := r sideNearestTo: p.
	p1 := r pointNearestTo: p.	"a point on the border"
	p1 := (side = #top or: [side = #left]) 
		ifTrue: [r topLeft + (p1 - r topLeft grid: 4 @ 4)]
		ifFalse: [ r bottomRight + (p1 - r bottomRight grid: 4 @ 4)].

	"Update pin spec(5) = side index + fraction along side"
	corners := r corners.
	sideIndex := #(#left #bottom #right #top) indexOf: side.
	c1 := corners at: sideIndex.
	c2 := corners atWrap: sideIndex + 1.
	pinSpec pinLoc: sideIndex + ((p1 dist: c1) / (c2 dist: c1) min: 0.99999).

	"Set new position with appropriate offset."
	side = #top ifTrue: [super position: p1 - (0 @ 8)].
	side = #left ifTrue: [super position: p1 - (8 @ 0)].
	side = #bottom ifTrue: [super position: p1].
	side = #right ifTrue: [super position: p1].
	wires do: [:w | w pinMoved]! !

!PinMorph methodsFor: 'geometry' stamp: 'di 5/4/1998 09:10'!
updateImage
	"pinForm was made for right side.  Rotate/flip for other sides"

	bounds left < owner bounds left ifTrue:  "left side"
		[^ self image: (pinForm flipBy: #horizontal centerAt: 0@0)].
	bounds bottom > owner bounds bottom ifTrue:  "bottom"
		[^ self image: ((pinForm rotateBy: #left centerAt: 0@0)
								flipBy: #vertical centerAt: 0@0)].
	bounds right > owner bounds right ifTrue:  "right side"
		[^ self image: pinForm].
	bounds top < owner bounds top ifTrue:  "top"
		[^ self image: (pinForm rotateBy: #left centerAt: 0@0)].
self halt: 'uncaught pin geometry case'! !

!PinMorph methodsFor: 'geometry' stamp: 'di 4/30/1998 12:12'!
wiringEndPoint
	| side |
	side _ owner bounds sideNearestTo: bounds center.
	side = #left ifTrue: [^ self position + (0@4)].
	side = #bottom ifTrue: [^ self position + (4@7)].
	side = #right ifTrue: [^ self position + (7@4)].
	side = #top ifTrue: [^ self position + (4@0)]! !


!PinMorph methodsFor: 'initialization' stamp: 'di 5/4/1998 09:13'!
component: aComponent pinSpec: spec
	component _ aComponent.
	pinSpec _ spec.
	pinSpec isInput ifTrue: [pinForm _ InputPinForm].
	pinSpec isOutput ifTrue: [pinForm _ OutputPinForm].
	pinSpec isInputOutput ifTrue: [pinForm _ IoPinForm].
	self image: pinForm! !

!PinMorph methodsFor: 'initialization' stamp: 'di 5/4/1998 09:13'!
initialize
	super initialize.
	wires _ OrderedCollection new! !


!PinMorph methodsFor: 'submorphs-add/remove' stamp: 'di 5/2/1998 15:37'!
delete
	self unwire.
	^ super delete! !


!PinMorph methodsFor: 'variables' stamp: 'di 5/4/1998 00:11'!
addModelVariable
	| accessors |
	accessors _ component model addVariableNamed: component knownName , pinSpec pinName.
	pinSpec modelReadSelector: accessors first modelWriteSelector: accessors second.
	component initFromPinSpecs.
	self connectedPins do: [:connectee | connectee shareVariableOf: self]! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/1/1998 13:21'!
hasVariable
	^ pinSpec hasVariable! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/4/1998 00:01'!
mergeVariableWith: otherPin
	"Change all pins with otherPin's selectors to these selectors,
	and then remove the slot and accessors for the old selectors"
	self removeModelVariable.
	self connectedPins do:
		[:connectee | connectee shareVariableOf: otherPin].
	self shareVariableOf: otherPin! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/3/1998 23:58'!
removeModelVariable
	component model removeVariableNamed: pinSpec variableName.
	self removeVariableAccess! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/4/1998 00:18'!
removeVariableAccess
	pinSpec modelReadSelector: nil modelWriteSelector: nil.
	component initFromPinSpecs! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/2/1998 15:55'!
shareVariableOf: otherPin
	pinSpec modelReadSelector: otherPin pinSpec modelReadSelector
			modelWriteSelector: otherPin pinSpec modelWriteSelector.
	component initFromPinSpecs! !


!PinMorph methodsFor: 'wires' stamp: 'di 4/30/1998 13:25'!
addWire: aWireMorph
	wires add: aWireMorph! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/1/1998 22:25'!
canDockWith: otherPin
	"Later include data type compatibility and circularity as well"
	(pinSpec isInputOnly and: [otherPin pinSpec isInputOnly]) ifTrue: [^ false].
	(pinSpec isOutputOnly and: [otherPin pinSpec isOutputOnly]) ifTrue: [^ false].
	^ true! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/2/1998 17:23'!
connectedPins
	^ wires collect: [:w | w otherPinFrom: self]! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/2/1998 17:24'!
isIsolated
	^ wires isEmpty! !

!PinMorph methodsFor: 'wires' stamp: 'di 4/30/1998 13:25'!
removeWire: aWireMorph
	wires remove: aWireMorph! !

!PinMorph methodsFor: 'wires' stamp: 'dgd 2/22/2003 14:38'!
startWiring: event 
	"Start wiring from this pin"

	| origin handle candidates candidate wiringColor wire |
	origin := self wiringEndPoint.
	candidates := OrderedCollection new.
	"Later this could be much faster if we define pinMorphsDo:
		so that it doesn't go too deep and bypasses non-widgets."
	self pasteUpMorph allMorphsDo: 
			[:m | 
			((m isMemberOf: PinMorph) and: [m canDockWith: self]) 
				ifTrue: [candidates add: m]].
	handle := NewHandleMorph new 
				followHand: event hand
				forEachPointDo: 
					[:newPoint | 
					candidate := candidates detect: [:m | m containsPoint: newPoint]
								ifNone: [nil].
					wiringColor := candidate isNil ifTrue: [Color black] ifFalse: [Color red].
					handle
						removeAllMorphs;
						addMorph: (PolygonMorph 
									vertices: (Array with: origin with: newPoint)
									color: Color black
									borderWidth: 1
									borderColor: wiringColor)]
				lastPointDo: 
					[:lastPoint | 
					(self wireTo: candidate) 
						ifTrue: 
							[wire := (WireMorph 
										vertices: (Array with: origin with: lastPoint)
										color: Color black
										borderWidth: 1
										borderColor: Color black) fromPin: self toPin: candidate.
							self pasteUpMorph addMorph: wire.
							self addWire: wire.
							candidate addWire: wire]].
	event hand world addMorph: handle.
	handle startStepping! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/4/1998 00:15'!
unwire
	"Remove wires one by one.  Not fastest, but by far simplest"

	wires do: [:w | w delete].  "This is where all the work is done"! !

!PinMorph methodsFor: 'wires' stamp: 'dgd 2/22/2003 14:38'!
wireTo: otherPin 
	"Note must return true or false indicating success"

	(otherPin isNil or: [otherPin == self]) ifTrue: [^false].
	self hasVariable 
		ifTrue: 
			[otherPin hasVariable 
				ifTrue: [self mergeVariableWith: otherPin]
				ifFalse: [otherPin shareVariableOf: self]]
		ifFalse: 
			[otherPin hasVariable 
				ifTrue: [self shareVariableOf: otherPin]
				ifFalse: 
					[self addModelVariable.
					otherPin shareVariableOf: self]].
	component model changed: pinSpec modelReadSelector.
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PinMorph class
	instanceVariableNames: ''!

!PinMorph class methodsFor: 'class initialization' stamp: 'di 4/28/1998 10:58'!
initialize  "PinMorph initialize"
	OutputPinForm _ Form extent: 8@8 depth: 1 fromArray:
			#( 0 3221225472 4026531840 4227858432 4278190080 4227858432 4026531840 3221225472)
		offset: 0@0.

	IoPinForm _ Form extent: 8@8 depth: 1 fromArray:
			#( 0 402653184 1006632960 2113929216 4278190080 2113929216 1006632960 402653184)
		offset: 0@0.

	InputPinForm _ OutputPinForm flipBy: #horizontal centerAt: 0@0.
! !


!PinMorph class methodsFor: 'new-morph participation' stamp: 'di 5/3/1998 10:09'!
includeInNewMorphMenu
	^ false! !
Object subclass: #PinSpec
	instanceVariableNames: 'pinName direction localReadSelector localWriteSelector modelReadSelector modelWriteSelector defaultValue pinLoc'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:59'!
defaultValue
	^ defaultValue! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 16:38'!
isInput
	direction = #input ifTrue: [^ true].
	direction = #inputOutput ifTrue: [^ true].
	direction = #ioAsInput ifTrue: [^ true].
	^ false! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 22:25'!
isInputOnly
	direction = #input ifTrue: [^ true].
	direction = #ioAsInput ifTrue: [^ true].
	^ false! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 16:42'!
isInputOutput
	^ direction = #inputOutput! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 16:39'!
isOutput
	direction = #output ifTrue: [^ true].
	direction = #inputOutput ifTrue: [^ true].
	direction = #ioAsOutput ifTrue: [^ true].
	^ false! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 22:26'!
isOutputOnly
	direction = #output ifTrue: [^ true].
	direction = #ioAsOutput ifTrue: [^ true].
	^ false! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:58'!
localReadSelector
	^ localReadSelector! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:58'!
localWriteSelector
	^ localWriteSelector! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:59'!
modelReadSelector
	^ modelReadSelector! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 13:36'!
modelReadSelector: a modelWriteSelector: b
	modelReadSelector _ a.
	modelWriteSelector _ b! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:59'!
modelWriteSelector
	^ modelWriteSelector! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 10:00'!
pinLoc
	^ pinLoc! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 10:14'!
pinLoc: x
	pinLoc _ x! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 13:39'!
pinName
	^ pinName! !


!PinSpec methodsFor: 'initialization' stamp: 'di 5/1/1998 13:38'!
pinName: a direction: b localReadSelector: c localWriteSelector: d modelReadSelector: e modelWriteSelector: f defaultValue: g pinLoc: h
	pinName _ a.
	direction _ b.
	localReadSelector _ c.
	localWriteSelector _ d.
	modelReadSelector _ e.
	modelWriteSelector _ f.
	defaultValue _ g.
	pinLoc _ h! !


!PinSpec methodsFor: 'variables' stamp: 'dgd 2/22/2003 19:00'!
hasVariable
	^modelReadSelector notNil or: [modelWriteSelector notNil]! !

!PinSpec methodsFor: 'variables' stamp: 'di 5/2/1998 15:47'!
variableName
	^ modelReadSelector! !
AbstractScoreEvent subclass: #PitchBendEvent
	instanceVariableNames: 'bend channel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!

!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'!
bend

	^ bend
! !

!PitchBendEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
bend: midiPitchBend

	bend := midiPitchBend.
! !

!PitchBendEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
bend: midiPitchBend channel: midiChannel

	bend := midiPitchBend.
	channel := midiChannel.
! !

!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel

	^ channel
! !

!PitchBendEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
channel: midiChannel

	channel := midiChannel.
! !


!PitchBendEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:45'!
isPitchBend

	^ true
! !


!PitchBendEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'!
outputOnMidiPort: aMidiPort
	"Output this event to the given MIDI port."

	aMidiPort
		midiCmd: 16rE0
		channel: channel
		byte: (bend bitAnd: 16r7F)
		byte: (bend bitShift: -7).
! !


!PitchBendEvent methodsFor: 'printing' stamp: 'jm 9/10/1998 09:42'!
printOn: aStream

	aStream nextPut: $(.
	time printOn: aStream.
	aStream nextPutAll: ': bend '.
	bend printOn: aStream.
	aStream nextPut: $).
! !
Envelope subclass: #PitchEnvelope
	instanceVariableNames: 'centerPitch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 1/31/98 14:46'!
centerPitch

	^ centerPitch
! !

!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
centerPitch: aNumber

	centerPitch := aNumber.
! !

!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 07:30'!
updateSelector
	"Needed by the envelope editor."

	^ #pitch:
! !

!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateTargetAt: mSecs
	"Update the pitch for my target. Answer true if the value changed."
	"Details: Assume envelope range is 0.0..2.0, with 1 being the center pitch. Subtracting one yields the range -1.0..1.0. Raising two to this power yields pitches between half and double the center pitch; i.e. from an octave below to an octave about the center pitch."

	| newValue |
	newValue := self valueAtMSecs: mSecs.
	newValue ~= lastValue ifTrue: [
		target pitch: (2.0 raisedTo: newValue - (scale / 2.0)) * centerPitch.
		lastValue := newValue.
		^ true].

	^ false
! !
MorphicModel subclass: #PlayWithMe1
	instanceVariableNames: 'slider1 valuePrinter scrollBar1 listPane1 listPane2'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Models'!

!PlayWithMe1 methodsFor: 'input events'!
listPane1MenuButtonPressed: t1 
	self confirm: 'Do you like menu buttons?'! !

!PlayWithMe1 methodsFor: 'input events'!
listPane1NewSelection: t1 
	valuePrinter
		contents: (t1 = 0
				ifTrue: ['-']
				ifFalse: [(listPane1 instVarNamed: 'list')
						at: t1]).
	listPane1 selectionIndex: t1.
	listPane2 selectionIndex: t1! !

!PlayWithMe1 methodsFor: 'input events'!
listPane2MenuButtonPressed: t1 
	self confirm: 'Do you like menu buttons?'! !

!PlayWithMe1 methodsFor: 'input events'!
listPane2NewSelection: t1 
	valuePrinter
		contents: (t1 = 0
				ifTrue: ['-']
				ifFalse: [(listPane2 instVarNamed: 'list')
						at: t1]).
	listPane2 selectionIndex: t1.
	listPane1 selectionIndex: t1! !

!PlayWithMe1 methodsFor: 'input events'!
scrollBar1MenuButtonPressed: t1 
	self confirm: 'Do you like menu buttons?'! !

!PlayWithMe1 methodsFor: 'input events'!
scrollBar1Value: t1 
	valuePrinter contents: t1 printString.
	slider1 value: t1! !


!PlayWithMe1 methodsFor: 'public access'!
slider1Value: t1 
	valuePrinter contents: t1 printString.
	scrollBar1 value: t1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PlayWithMe1 class
	instanceVariableNames: ''!

!PlayWithMe1 class methodsFor: 'new-morph participation'!
includeInNewMorphMenu
	^ false! !
Model subclass: #Player
	instanceVariableNames: 'costume costumes'
	classVariableNames: 'BiggestSubclassNumber TimeOfError'
	poolDictionaries: 'References'
	category: 'EToys-Scripting'!
!Player commentStamp: '<historical>' prior: 0!
The fundamental user-scriptable entity.  Always represented by a user-specific subclass of Player; instance vars and methods relate to user-defined structures.

costume  is a Morph, the primary morph I am currently wearing for graphical display.

Scripts are defined in subclasses of Player.  These are UniClasses.

Messages in scripts are sent to Players.  A Player may delegate to its costume, or to an object the costume suggests.  Or, a Player may designate some other object to receive the script messages it does not understand. (see doesNotUnderstand:) !


!Player methodsFor: 'accessing' stamp: 'sw 8/17/1998 17:21'!
presenter
	"Convenience for calling from user scripts"
	^ self costume presenter! !

!Player methodsFor: 'accessing' stamp: 'yo 3/31/2005 15:00'!
readoutPlayer

	^ self.
! !


!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:07'!
deleteCard
	"Tell the receiver's stack to delete the current card"

	self costume stackDo: [:aStack | aStack deleteCard]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:56'!
firstPage
	self sendMessageToCostume: #firstPage! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/30/2000 07:12'!
getRoundedCorners
	"Anwer the rounded-corners attribute of my costume"

	^ costume renderedMorph cornerStyle == #rounded! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:12'!
goToCard: aCard
	"Install aCard as the new current card of the stack"

	self stackDo: [:aStack | aStack goToCard: aCard]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:19'!
goToFirstCardInBackground
	"Send the stack to the first card of the current background"

	costume stackDo: [:aStack | aStack goToFirstCardInBackground]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:19'!
goToFirstCardOfStack
	"Send the stack to the first card of the entire stack"

	costume stackDo: [:aStack | aStack goToFirstCardOfStack]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:17'!
goToLastCardInBackground
	"Send the stack to the final card of the current background"

	costume stackDo: [:aStack | aStack goToLastCardInBackground]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:20'!
goToLastCardOfStack
	"Send the stack to the last card of the entire stack"

	costume stackDo: [:aStack | aStack goToLastCardOfStack]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 14:54'!
goToNextCardInStack
	"Install the next card into the receiver's stack"

	self costume goToNextCardInStack! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:13'!
goToPreviousCardInStack
	"Install the previous card into the receiver's stack"

	self costume goToPreviousCardInStack! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:56'!
goto: aPlayer
	self sendMessageToCostume: #goto: with: aPlayer! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:14'!
insertCard
	"Insert a new card into the stack"

	self costume stackDo: [:aStack | aStack insertCard]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:56'!
lastPage
	self sendMessageToCostume: #lastPage! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:55'!
nextPage
	self sendMessageToCostume: #nextPage! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:55'!
previousPage
	self sendMessageToCostume: #previousPage! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/30/2000 08:34'!
setRoundedCorners: aBoolean
	"Set the rounded-corners attribute as indicated"

	costume renderedMorph cornerStyle: (aBoolean ifTrue: [#rounded] ifFalse: [#square])! !


!Player methodsFor: 'copying' stamp: 'tk 1/8/2001 10:38'!
copyUniClassWith: deepCopier
	"my class is a subclass of Player.  Return another class just like my class.  Share the costume list."
	| newCls |
	newCls _ self class officialClass 
		newUniqueClassInstVars: self class instanceVariablesString 
		classInstVars: self class class instanceVariablesString.
	newCls copyMethodDictionaryFrom: self class.
	newCls class copyMethodDictionaryFrom: self class class.
	newCls scripts: self class privateScripts.	"duplicate this in mapUniClasses"
	newCls slotInfo: (self class privateSlotInfo veryDeepCopyWith: deepCopier).
	newCls copyAddedStateFrom: self class.  "All class inst vars for inter Player refs"
	^ newCls
! !

!Player methodsFor: 'copying' stamp: 'sw 9/15/1998 13:12'!
initializeCostumesFrom: aPlayer
	"Used to copy costume info over from an UnscriptedPlayer to a Player UniClass"
	costume _ aPlayer costume.
	costumes _ aPlayer costumes! !

!Player methodsFor: 'copying' stamp: 'tk 9/4/2001 11:10'!
veryDeepFixupWith: deepCopier
	| old |
	"Any uniClass inst var may have been weakly copied.  If they were in the tree being copied, fix them up, otherwise point to the originals."

super veryDeepFixupWith: deepCopier.
Player instSize + 1 to: self class instSize do:
	[:ii | old _ self instVarAt: ii.
	self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])].
! !

!Player methodsFor: 'copying' stamp: 'tk 9/5/2001 09:43'!
veryDeepInner: deepCopier
	"Special code that handles user-added instance variables of a uniClass.
	Copy all of my instance variables.  Some need to be not copied at all, but shared.  This is special code for the dictionary.  See DeepCopier."
	| instVar weak subAss |

	super veryDeepInner: deepCopier.
	"my own instance variables are completely normal"
	costume _ costume veryDeepCopyWith: deepCopier.
	costumes _ costumes veryDeepCopyWith: deepCopier.

	Player instSize + 1 to: self class instSize do: [:index |
		instVar _ self instVarAt: index.
		weak _ instVar isMorph | instVar isPlayerLike. 
		(subAss _ deepCopier references associationAt: instVar ifAbsent: [nil])
				"use association, not value, so nil is an exceptional value"
			ifNil: [weak ifFalse: [
					self instVarAt: index put: (instVar veryDeepCopyWith: deepCopier)]]
			ifNotNil: [self instVarAt: index put: subAss value].
		].
!
]style[(25 205 10 659)f1b,f1,f1LDeepCopier Comment;,f1! !


!Player methodsFor: 'costume' stamp: 'sw 5/13/1998 14:07'!
availableCostumeNames
	"Answer a list of class names (minus trailing ...Morph) to be offered in the thumbnail 'new-Costume' menu in the Viewer"

 	^ #(Book BouncingAtoms Curve Ellipse  Flasher Image Joystick  PasteUp Polygon Rectangle Ruler Sketch Star String Text  )

"  ScrollBar  SimpleButton SimpleSlider SimpleSwitch  UserFrame  "! !

!Player methodsFor: 'costume' stamp: 'sw 4/5/1999 13:48'!
availableCostumesForArrows
	^ costumes ifNil: [Array new]! !

!Player methodsFor: 'costume' stamp: 'sw 9/30/2004 04:29'!
ceaseHavingAParameterFor: aSelector
	"Make the script represented by aSelector cease bearing a parameter"

	| newSel |
	self renameScript: aSelector newSelector: (newSel _ (aSelector copyWithout: $:) asSymbol).

	(self scriptEditorFor: newSel) assureParameterTilesValid; install! !

!Player methodsFor: 'costume' stamp: 'sw 7/18/2002 11:26'!
changeParameterTypeFor: aSelector
	"Change the parameter type for the given selector.  Not currently sent, since types are now set by direct manipulation in the Scriptor header.  If this were reinstated someday, there would probably be an issue about getting correct-looking Parameter tile(s) into the Scriptor header(s)"

	| current typeChoices typeChosen |
	current _ self typeforParameterFor: aSelector.
	typeChoices _ Vocabulary typeChoices.
	typeChosen _ (SelectionMenu selections: typeChoices lines: #()) startUpWithCaption: 
		('Choose the TYPE
for the parameter (currently ', current, ')').
	self setParameterFor: aSelector toType: typeChosen

! !

!Player methodsFor: 'costume' stamp: 'sw 2/27/2001 18:28'!
clearOwnersPenTrails
	"Clear the pen trails of the containing playfield"

	self costume referencePlayfield clearTurtleTrails! !

!Player methodsFor: 'costume' stamp: 'sw 3/4/2001 13:57'!
clearPenTrails
	"Allow old code invoking the short-lived deviant clearPenTrails command to continue to work when imported from a bj image into a mainstream image.  For backward compatibility only!!"

	self costume referencePlayfield clearTurtleTrails! !

!Player methodsFor: 'costume' stamp: 'sw 12/16/97 11:00'!
costume
	^ costume! !

!Player methodsFor: 'costume' stamp: 'sw 4/7/1999 21:20'!
costumeRespondingTo: aSelector
	"Answer a costume that responds to the given selector, or nil if none"
	| aMorph |
	((aMorph _ self costume renderedMorph) respondsTo: aSelector) ifTrue: [^ aMorph].
	costumes isEmptyOrNil ifFalse:
		[costumes do: [:aCostume | (aCostume respondsTo: aSelector) ifTrue: [^ aCostume]]].
	^ nil "usually an error will result"! !

!Player methodsFor: 'costume' stamp: 'nk 9/4/2004 17:05'!
costumesDo: aBlock 
	"Evaluate aBlock against every real (not flex) costume known to the receiver,
	starting with the current costume."

	costume ifNotNil: [ aBlock value: costume renderedMorph ].
	costumes
		ifNil: [^ self].
	costumes
		do: [:aCostume | aCostume ~~ costume
				ifTrue: [aBlock value: aCostume renderedMorph]]! !

!Player methodsFor: 'costume' stamp: 'mga 11/18/2003 11:23'!
flipHorizontal
	self costume flipHorizontal! !

!Player methodsFor: 'costume' stamp: 'mga 11/18/2003 11:23'!
flipVertical
	self costume flipVertical! !

!Player methodsFor: 'costume' stamp: 'sw 8/3/2000 10:16'!
forgetOtherCostumes
	self resetCostumeList.
	self updateAllViewers! !

!Player methodsFor: 'costume' stamp: 'sw 8/17/1998 15:39'!
getValueFromCostume: aSelector
	| aCostume |
	(aCostume _ self costumeRespondingTo: aSelector) ifNotNil:
		[^ aCostume perform: aSelector].
	^ nil! !

!Player methodsFor: 'costume' stamp: 'nk 9/4/2004 17:05'!
hasCostumeThatIsAWorld

	self costumesDo: [ :aCostume | (aCostume isWorldMorph) ifTrue: [^ true]].
	^ false! !

!Player methodsFor: 'costume' stamp: 'nk 9/4/2004 17:04'!
hasOnlySketchCostumes
	"Answer true if the only costumes assocaited with this Player are SketchMorph costumes"

	self costumesDo: [ :aCostume | aCostume isSketchMorph ifFalse: [^ false]].
	^ true! !

!Player methodsFor: 'costume' stamp: 'nk 6/12/2004 10:01'!
knownSketchCostumeWithSameFormAs: aSketchMorph 
	| itsForm |
	itsForm := aSketchMorph form.
	^ costumes
		ifNotNil: [costumes
				detect: [:c | c isSketchMorph
						and: [c form == itsForm]]
				ifNone: []]! !

!Player methodsFor: 'costume' stamp: 'sw 10/24/1998 21:48'!
newCostume

	| aMenu reply |
	aMenu _ SelectionMenu selections: self availableCostumeNames.
	(reply _ aMenu startUpWithCaption: 'choose a costume') ifNil: [^ self].
	self wearCostumeOfName: reply.
	self updateAllViewers! !

!Player methodsFor: 'costume' stamp: 'sw 8/20/1998 17:35'!
rawCostume: aMorph
	costume _ aMorph! !

!Player methodsFor: 'costume' stamp: 'nk 6/12/2004 10:01'!
recaptureUniqueCostumes
	"Recapture all unique sketch-like costumes. Debugging only."
	| unique |
	costumes ifNil:[^self].
	unique := PluggableSet new 
				equalBlock:[:s1 :s2| s1 form == s2 form];
				hashBlock:[:s| s form identityHash].
	unique addAll: (costumes select:[:c| c isSketchMorph]).
	unique := unique asIdentitySet.
	costumes := costumes select:[:c|
		(c isSketchMorph) not or:[unique includes: c]].
! !

!Player methodsFor: 'costume' stamp: 'nk 6/12/2004 10:02'!
rememberCostume: aCostume
	"Put aCostume in my remembered-costumes list, as the final element"
	| costumeToRemember existing |
	costumeToRemember _ aCostume renderedMorph.
		"Remember real morphs, not their transformations"
	costumes ifNil: [costumes _ OrderedCollection new].
	existing _ (costumeToRemember isSketchMorph)
		ifTrue:
			[self knownSketchCostumeWithSameFormAs: costumeToRemember]
		ifFalse:
			[costumes detect: [:c | c == costumeToRemember] ifNone: [nil]].
	costumes _ costumes copyWithout: existing.
	costumes addLast: costumeToRemember! !

!Player methodsFor: 'costume' stamp: 'mir 6/13/2001 15:28'!
renderedCostume: aMorph
	"Make aMorph be the receiver's rendered costume; if flexing is currently in effect, make the new morph be flexed correspondingly"
	self renderedCostume: aMorph remember: true! !

!Player methodsFor: 'costume' stamp: 'sw 12/12/2001 14:13'!
renderedCostume: aMorph remember: rememberCostume
	"Make aMorph be the receiver's rendered costume; if flexing is currently in effect, make the new morph be flexed correspondingly"

	| renderedMorph known anEventHandler w baseGraphic |
	renderedMorph _ costume renderedMorph.
	renderedMorph == aMorph ifTrue: [^ self].
	baseGraphic _ costume renderedMorph valueOfProperty: #baseGraphic.
	rememberCostume
		ifTrue: [self rememberCostume: renderedMorph].
	renderedMorph changed.
	w _ renderedMorph world.
	"Copy 'player state' (e.g., state which should be associated with the player but is stored in the morph itself these days) from the old rendered morph the new morph."
	aMorph rotationStyle: renderedMorph rotationStyle.
	aMorph forwardDirection: renderedMorph forwardDirection.
	"Note: referencePosition is *not* state but #moveTo: behavior"
	aMorph referencePosition: renderedMorph referencePosition.
	anEventHandler _ renderedMorph eventHandler.
	costume isFlexMorph
		ifTrue:
			[costume adjustAfter:
				[costume replaceSubmorph: renderedMorph by: aMorph]]
		ifFalse:
			[costume owner ifNotNil: [costume owner replaceSubmorph: costume by: aMorph].
			aMorph player: self.
			aMorph actorState: costume actorState.
			(known _ costume knownName) ifNotNil:
				[aMorph setNameTo: known].
			costume _ aMorph.
			w ifNotNil:
				[w stopStepping: renderedMorph.
				w startStepping: aMorph]].

	baseGraphic ifNotNil: [self setBaseGraphic: baseGraphic].
	aMorph eventHandler: anEventHandler.
	aMorph changed! !

!Player methodsFor: 'costume' stamp: 'sw 8/3/2000 10:16'!
resetCostumeList
	costumes _ nil! !

!Player methodsFor: 'costume' stamp: 'nk 6/12/2004 10:02'!
restoreBaseGraphic
	"Restore my base graphic"

	| cos |
	((cos _ self costume renderedMorph) isSketchMorph)
		ifTrue:
			[cos restoreBaseGraphic]! !

!Player methodsFor: 'costume' stamp: 'sw 10/26/1998 15:55'!
sendMessageToCostume: aSelector
	| aCostume |
	(aCostume _ self costumeRespondingTo: aSelector) ifNotNil:
		[^ aCostume perform: aSelector].
	^ nil! !

!Player methodsFor: 'costume' stamp: 'sw 10/26/1998 15:54'!
sendMessageToCostume: aSelector with: arg
	| aCostume |
	(aCostume _ self costumeRespondingTo: aSelector) ifNotNil:
		[^ aCostume perform: aSelector with: arg].
	^ nil! !

!Player methodsFor: 'costume' stamp: 'sw 8/17/1998 15:45'!
setCostumeSlot: setterSelector toValue: aValue
	| aCostume |
	(aCostume _ self costumeRespondingTo: setterSelector) ifNotNil:
		[aCostume perform: setterSelector with: aValue]! !

!Player methodsFor: 'costume' stamp: 'sw 7/22/2002 17:44'!
setParameterFor: aSelector toType: aTypeSymbol
	"Set the parameter type for the given selector"

	| aUniclassScript |
	aTypeSymbol isEmptyOrNil ifTrue: [^ self].
	(self typeforParameterFor: aSelector) = aTypeSymbol ifTrue: [^ self].
	aUniclassScript _ self class scripts at: aSelector.
	aUniclassScript argumentVariables first variableType: aTypeSymbol.
	aUniclassScript currentScriptEditorDo:
		[:aScriptEditor | aScriptEditor assureParameterTilesValid].
	self updateAllViewersAndForceToShow: #scripts
	

! !

!Player methodsFor: 'costume' stamp: 'RAA 5/18/2001 12:41'!
stamp

	"stamp an image of ourself onto the pen trails form"

	costume pasteUpMorph addImageToPenTrailsFor: costume topRendererOrSelf! !

!Player methodsFor: 'costume' stamp: 'RAA 5/18/2001 09:21'!
stampAndErase

	self stamp.
	self erase.! !

!Player methodsFor: 'costume' stamp: 'sw 9/30/2004 04:49'!
startHavingParameterFor: aSelector
	"Start having a parameter for the given selector.  After this change, the script name will change by the addition of a colon."

	| newSelector |
	self renameScript: aSelector newSelector: (newSelector _ (aSelector, ':') asSymbol).
	(self scriptEditorFor: newSelector) install! !

!Player methodsFor: 'costume' stamp: 'sw 3/11/2003 00:32'!
tearOffButtonToFireScriptForSelector: aSelector
	"Tear off a button to fire the script for the given selector"

	| aButton props |
	Preferences useButtonProprtiesToFire ifFalse:
		[aButton _ ScriptActivationButton new.
		aButton initializeForPlayer: self uniclassScript:  (self class scripts at: aSelector).
		^ aButton openInHand].

	(aButton _ RectangleMorph new) useRoundedCorners; color: Color yellow.
	props _ aButton ensuredButtonProperties.
	props
		target: self;
		actionSelector: #runScript:;
		arguments: {aSelector};
		delayBetweenFirings: 80;
		actWhen: #mouseUp;
		mouseDownHaloWidth: 8;
		wantsRolloverIndicator: true;
		mouseOverHaloWidth: 5;
		establishEtoyLabelWording.
	aButton width: aButton submorphs first width + 20; height: 20.
	self currentHand attachMorph: aButton.
! !

!Player methodsFor: 'costume' stamp: 'sw 7/5/2002 22:16'!
typeforParameterFor: aSelector
	"Answer the type of the parameter for the given selector"

	(self class scripts at: aSelector ifAbsent: [nil]) ifNotNilDo:
		[:aScript | ^ aScript argumentVariables first variableType].
	self error: 'No parameter type for ', aSelector.
	^ #Number! !

!Player methodsFor: 'costume' stamp: 'sw 12/3/1998 10:05'!
wearCostumeOfClass: aClass
	"Assume that the costume in the library has player = nil"
	| newCostume |
	(costume renderedMorph isKindOf: aClass) ifTrue: [^ self].
	costumes ifNotNil:
		[costumes do:
			[:aCostume | (aCostume class  == aClass)
				ifTrue:
					[^ self renderedCostume: aCostume]]].

	newCostume _ aClass new.
	self renderedCostume: newCostume! !

!Player methodsFor: 'costume' stamp: 'sw 2/20/98 00:32'!
wearCostumeOfName: aName
	| classToUse |
	classToUse _ Smalltalk at: (aName, 'Morph') asSymbol ifAbsent: 
		[Smalltalk at: aName asSymbol].
	self wearCostumeOfClass: classToUse! !

!Player methodsFor: 'costume' stamp: 'mir 6/13/2001 15:29'!
wearCostumeOf: anotherPlayer
	"Put on a costume similar to the one currently worn by anotherPlayer"

	self renderedCostume: (anotherPlayer costume renderedMorph asWearableCostumeOfExtent: self costume extent) remember: anotherPlayer costume shouldRememberCostumes! !


!Player methodsFor: 'customevents-costume' stamp: 'nk 9/24/2003 17:33'!
costume: aMorph
	"Make aMorph be the receiver's current costume"
	| itsBounds |
	costume == aMorph ifTrue: [^ self].
	costume ifNotNil:
		[self rememberCostume: costume renderedMorph.
		itsBounds _ costume bounds.
		(costume ownerThatIsA: HandMorph orA: PasteUpMorph) replaceSubmorph: costume topRendererOrSelf by: aMorph.
		aMorph position: itsBounds origin.
		aMorph actorState: costume actorStateOrNil.
		aMorph setNameTo: costume externalName].
	aMorph player: self.
	costume _ aMorph.
	aMorph arrangeToStartStepping! !


!Player methodsFor: 'customevents-custom events' stamp: 'nk 11/1/2004 11:26'!
getTriggeringObject
	"Answer the Player that is triggering the current script,
	or the default UnscriptedPlayer if none."

	| rcvr |
	rcvr := GetTriggeringObjectNotification signal.

	^rcvr ifNil: [ self costume presenter standardPlayer ]
		ifNotNil: [ rcvr isMorph
				ifTrue: [ rcvr assuredPlayer ]
				ifFalse: [ rcvr ]]! !

!Player methodsFor: 'customevents-custom events' stamp: 'nk 8/26/2003 10:50'!
triggerCustomEvent: aSymbol
	"Trigger whatever scripts may be connected to the custom event named aSymbol"

	self costume renderedMorph triggerCustomEvent: aSymbol! !

!Player methodsFor: 'customevents-custom events' stamp: 'nk 11/1/2004 10:48'!
triggerScript: aSymbol 
	"Perform the script of the given name,
	which is guaranteed to exist.
	However, it's possible that the script may still result in a DNU,
	which will be swallowed and reported to the Transcript."

	^ [[self perform: aSymbol]
		on: GetTriggeringObjectNotification do: [ :ex |
			ex isNested
				ifTrue: [ ex pass ]
				ifFalse: [ ex resume: self ]]]
		on: MessageNotUnderstood
		do: [:ex | 
			ScriptingSystem
				reportToUser: (String
						streamContents: [:s | s nextPutAll: self externalName;
								 nextPutAll: ': exception in script ';
								 print: aSymbol;
								 nextPutAll: ' : ';
								 print: ex]).
			ex return: self
			"ex pass"]! !


!Player methodsFor: 'customevents-misc' stamp: 'nk 9/24/2003 18:26'!
noteDeletionOf: aMorph fromWorld: aWorld
	"aMorph, while pointing to me as its costumee, has been deleted"
	"This may be too aggressive because deletion of a morph may not really mean deletion of its associated player -- in light of hoped-for multiple viewing"

	| viewers scriptors viewerFlaps |
	viewers _ OrderedCollection new.
	viewerFlaps _ OrderedCollection new.
	scriptors _ OrderedCollection new.
	aWorld allMorphs do:
		[:m | m isAViewer ifTrue: [viewers add: m].
			((m isKindOf: ViewerFlapTab) and: [m scriptedPlayer == self])
				ifTrue:
					[viewerFlaps add: m].
			((m isKindOf: ScriptEditorMorph) and: [m myMorph == aMorph])
				ifTrue: [scriptors add: m]].

	aMorph  removeAllEventTriggersFor: self.
	aWorld removeAllEventTriggersFor: self.
	viewers do: [:v |  v noteDeletionOf: aMorph].
	viewerFlaps do: [:v  | v dismissViaHalo].
	scriptors do: [:s | s privateDelete] ! !


!Player methodsFor: 'customevents-scripts-kernel' stamp: 'nk 9/25/2003 11:53'!
existingScriptInstantiationForSelector: scriptName
	"Answer the existing script instantiation for the given selector, or nil if none"

	scriptName ifNil: [^ nil].
	Symbol hasInterned: scriptName
		ifTrue: [ :sym |
			self costume actorStateOrNil ifNotNilDo: [ :actorState |
				^actorState instantiatedUserScriptsDictionary at: sym ifAbsent: [nil]]].
	^ nil! !

!Player methodsFor: 'customevents-scripts-kernel' stamp: 'nk 9/24/2003 17:36'!
instantiatedUserScriptsDo: aBlock
	"Evaluate aBlock on behalf of all the instantiated user scripts in the receiver"

	| aState aCostume |
	((aCostume _ self costume) notNil and: [(aState _ aCostume actorStateOrNil) notNil]) ifTrue:
		[aState instantiatedUserScriptsDictionary do: aBlock]! !

!Player methodsFor: 'customevents-scripts-kernel' stamp: 'nk 8/18/2004 17:40'!
pacifyScript: aSymbol
	"Make sure the script represented by the symbol doesn't do damage by lingering in related structures on the morph side"

	| aHandler aUserScript |
	aUserScript _ self class userScriptForPlayer: self selector: aSymbol.
	aUserScript ifNil: [self flag: #deferred.  ^ Beeper beep].  
	"Maddeningly, without this line here the thing IS nil and the debugger is in a bad state
	(the above note dates from 1/12/99 ?!!"

	self class allInstancesDo:
		[:aPlayer | | itsCostume |
		aPlayer actorState instantiatedUserScriptsDictionary removeKey: aSymbol ifAbsent: [].
		itsCostume _ aPlayer costume renderedMorph.
		(aHandler _ itsCostume eventHandler) ifNotNil:
			[aHandler forgetDispatchesTo: aSymbol].
		itsCostume removeEventTrigger: aSymbol ]! !


!Player methodsFor: 'error handling' stamp: 'tk 11/21/2000 16:17'!
doesNotUnderstand: aMessage 
	 | ours |
"See it the message is a special setter that has not been defined.  Define it and try again."

	ours _ false.
	(aMessage selector endsWith: 'IncreaseBy:') ifTrue: [ours _ true].
	(aMessage selector endsWith: 'DecreaseBy:') ifTrue: [ours _ true].
	(aMessage selector endsWith: 'MultiplyBy:') ifTrue: [ours _ true].
	ours ifFalse: [^ super doesNotUnderstand: aMessage].
	(self addSpecialSetter: aMessage selector) ifFalse: ["not our inst var"
		^ super doesNotUnderstand: aMessage].
	^ aMessage sentTo: self! !


!Player methodsFor: 'fileIn/Out' stamp: 'tk 8/6/1999 17:18'!
releaseCachedState
	"release all non-showing scriptors"

	self class userScriptsDo: [:userScript | userScript releaseCachedState].! !


!Player methodsFor: 'heading' stamp: 'jm 4/24/1998 22:30'!
headDown

	| radians |
	radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
	self setHeading:
		((radians cos @ radians sin abs) theta radiansToDegrees
			roundTo: 0.001) + 90.0.
! !

!Player methodsFor: 'heading' stamp: 'jm 4/24/1998 22:30'!
headLeft

	| radians |
	radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
	self setHeading:
		((radians cos abs negated @ radians sin) theta radiansToDegrees
			roundTo: 0.001) + 90.0.
! !

!Player methodsFor: 'heading' stamp: 'jm 4/24/1998 22:30'!
headRight

	| radians |
	radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
	self setHeading:
		((radians cos abs @ radians sin) theta radiansToDegrees
			roundTo: 0.001) + 90.0.
! !

!Player methodsFor: 'heading' stamp: 'jm 4/24/1998 22:30'!
headUp

	| radians |
	radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
	self setHeading:
		((radians cos @ radians sin abs negated) theta radiansToDegrees
			roundTo: 0.001) + 90.0.
! !


!Player methodsFor: 'macpal' stamp: 'sw 3/20/2001 13:28'!
isUniversalTiles
	"Return true if I (my world) uses universal tiles.  This message can be called in places where the current World is not known, such as when writing out a project.  For information about the writingUniversalTiles thing, contact Ted Kaehler."

	^ costume world
		ifNil:
			[ScriptEditorMorph writingUniversalTiles == true  "only valid during a project write"]
		ifNotNil:
			[Preferences universalTiles]! !

!Player methodsFor: 'macpal' stamp: 'sw 4/8/98 11:56'!
slotInfo
	^ self class slotInfo! !


!Player methodsFor: 'menus' stamp: 'ar 2/12/2001 18:50'!
step
	"obsolete"
	^self stepAt: Time millisecondClockValue.! !


!Player methodsFor: 'misc' stamp: 'sw 10/7/2004 17:20'!
actorState
	"Answer the receiver's actorState.  If the receiver has no costume, answer nil, else answer the costume's current actor state, creating it at this time if necessary."

	^ self costume ifNotNil: [costume actorState]
! !

!Player methodsFor: 'misc' stamp: 'nk 8/18/2004 16:43'!
adoptScriptsFrom
	"Let the user click on another object form which the receiver should obtain scripts and code"

	| aMorph |
	Sensor waitNoButton.
	aMorph _ ActiveWorld chooseClickTarget.
	aMorph ifNil: [^ Beeper beep].

	(((aMorph isSketchMorph) and: [aMorph player belongsToUniClass]) and: [self belongsToUniClass not])
		ifTrue:
			[costume acquirePlayerSimilarTo: aMorph player]
		ifFalse:
			[Beeper beep]! !

!Player methodsFor: 'misc' stamp: 'gm 2/22/2003 14:53'!
allOpenViewers
	"Answer a list of all the viewers open on the receiver.  Include viewers in closed flaps"

	| aWorld all |
	(aWorld := self costume world) ifNil: [^#()].
	all := aWorld allMorphs.
	aWorld closedViewerFlapTabs 
		do: [:aTab | all addAll: aTab referent allMorphs].
	^all 
		select: [:m | (m isStandardViewer) and: [m scriptedPlayer == self]]! !

!Player methodsFor: 'misc' stamp: 'gm 2/22/2003 14:54'!
allOpenViewersOnReceiverAndSiblings
	"Answer a list of all the viewers open on the receiver and any of its sibling instances.  Include viewers in closed flaps"

	| aWorld all |
	(aWorld := self costume world) ifNil: [^#()].
	all := aWorld allMorphs.
	aWorld closedViewerFlapTabs 
		do: [:aTab | all addAll: aTab referent allMorphs].
	^all select: 
			[:m | 
			(m isStandardViewer) and: [m scriptedPlayer class == self class]]! !

!Player methodsFor: 'misc' stamp: 'sw 7/4/2004 00:20'!
arrowDeltaFor: aGetSelector
	"Answer the arrowDelta to use in conjunction with a readout for aGetSelector, which will be of the form 'getXXX'"

	costume ifNotNil:
		[^ costume renderedMorph arrowDeltaFor: aGetSelector].
	^ 1
	
	"For the future, possibly:  If we want the SlotInformation for a user-defined slot to be able to specify a standard arrowDelta for that slot, we'd include something like the following... 
	| aSlotName slotInfo |
	aSlotName _ Utilities inherentSelectorForGetter: aGetSelector.
	(slotInfo _ self slotInfoAt: aSlotName ifAbsent: [nil]) ifNotNil:
		[^ slotInfo arrowDelta]."
! !

!Player methodsFor: 'misc' stamp: 'gk 2/23/2004 20:51'!
beep: soundName
	"Play given sound or at least beep."

	SoundService default playSoundNamedOrBeep: soundName
! !

!Player methodsFor: 'misc' stamp: 'sw 3/17/2005 00:47'!
beNotZero: aNumber
	"This is a runtime check if the arg to divide in a script is zero.  If it is, put up a warning message.  Return 0.001 instead of 0.  Note the time.  If fails again within 1 min., don't tell the user again."

	aNumber = 0 ifFalse: [^ aNumber].	"normal case"
	"We have a problem"
	TimeOfError 
		ifNil: [TimeOfError _ Time totalSeconds]
		ifNotNil: [(Time totalSeconds - TimeOfError) > 45 ifTrue: [
			TimeOfError _ Time totalSeconds.	"in case user interrupt and reenter"
			self inform: 
'Dividing by zero makes a number too
large for even a Sorcerer to handle.
Please change your script.' translated.
			TimeOfError _ Time totalSeconds]].
	^ 0.001! !

!Player methodsFor: 'misc' stamp: 'sw 7/28/2004 20:51'!
beRevealedInActiveWorld
	"Reveal my corresponding morph in the active world"

	self revealPlayerIn: ActiveWorld! !

!Player methodsFor: 'misc' stamp: 'sw 3/20/2001 12:21'!
browseEToyVocabulary
	"Open a protocol browser on the receiver, showing its etoy vocabulary"

	| littleMe | 
	littleMe _ self assureUniClass.

	(InstanceBrowser new useVocabulary: Vocabulary eToyVocabulary) openOnObject: littleMe  inWorld: ActiveWorld showingSelector: nil! !

!Player methodsFor: 'misc' stamp: 'sw 1/12/1999 16:00'!
browsePlayerClass
	Browser newOnClass: self class label: 'Compiled scripts for ', self externalName! !

!Player methodsFor: 'misc' stamp: 'sw 2/1/98 02:36'!
color
	^ self costume color! !

!Player methodsFor: 'misc' stamp: 'sw 12/13/2001 14:34'!
color: myColor sees: externalColor
	"Answer whether any pixel of one color on my costume is coincident with any pixel of a second color in its surround.  Returns false if the costume is not currently in the world"

	self costume isInWorld ifFalse: [^ false].
	^ self costume color: myColor sees: externalColor! !

!Player methodsFor: 'misc' stamp: 'sw 9/13/2002 17:52'!
decimalPlacesForGetter: aGetter
	"Answer the number of decimal places wanted when displaying the getter's value.  Answer nil if this object does not have a personal preference regarding this getter."

	^ costume decimalPlacesForGetter: aGetter! !

!Player methodsFor: 'misc' stamp: 'sw 7/4/2004 00:29'!
defaultFloatPrecisionFor: aGetSelector
	"Answer the float position to use in conjunction with a readout for aGetSelector, which will be of the form 'getXXX'"

	| aSlotName slotInfo |
	aSlotName _ Utilities inherentSelectorForGetter: aGetSelector.
	(slotInfo _ self slotInfoAt: aSlotName ifAbsent: [nil]) ifNotNil:
		[^ slotInfo floatPrecision].

	self costume ifNotNil:
		[^ self costume renderedMorph defaultFloatPrecisionFor: aGetSelector].
	^ 1! !

!Player methodsFor: 'misc' stamp: 'sw 11/28/2000 07:25'!
dummy
	"this space for rent"! !

!Player methodsFor: 'misc' stamp: 'sw 7/28/2004 20:52'!
entryForPlayersTool: aPlayersTool
	"Answer an entry for the receiver in the All Players tool"

	^ PlayerSurrogate newRow playerRepresented: self! !

!Player methodsFor: 'misc' stamp: 'sw 7/8/2004 01:29'!
erase
	"Dismiss the receiver from the screen.  It can subsequently be found in the trash if need be, provided the preserveTrash preference is set to true"

	self costume topRendererOrSelf dismissViaHalo! !

!Player methodsFor: 'misc' stamp: 'sw 2/1/1999 14:04'!
getIsOverColor: aColor
	^ self seesColor: aColor! !

!Player methodsFor: 'misc' stamp: 'sw 7/19/2004 16:41'!
grabPlayerInActiveWorld
	"Invoked from a Viewer: rip my morph out of its container, wherever that may be, and place it in the hand, being careful to set things up so that if the subsequent drop is rejected, the morph will end up in a visible location on the screen"

	self grabPlayerIn: ActiveWorld! !

!Player methodsFor: 'misc' stamp: 'ka 3/25/2004 05:25'!
grabPlayerIn: aWorld
	"Invoked from a Viewer: rip my morph out of its container, wherever that may be, and place it in the hand, being careful to set things up so that if the subsequent drop is rejected, the morph will end up in a visible location on the screen"

	| aMorph newPosition |
	self costume == aWorld ifTrue: [^ self].
	ActiveHand releaseMouseFocus.
	(aMorph _ self costume) visible: true.
	newPosition _ ActiveHand position - (aMorph extent // 2).
	aMorph isInWorld
		ifTrue:
			[aMorph goHome.
			aMorph formerPosition: aMorph positionInWorld]
		ifFalse:
			[aMorph formerPosition: aWorld center].
	aMorph formerOwner: ActiveWorld.
	aMorph position: newPosition.

	ActiveHand targetOffset: aMorph position - ActiveHand position.
	ActiveHand addMorphBack: aMorph.! !

!Player methodsFor: 'misc' stamp: 'sw 1/29/2001 21:57'!
grabScriptorForSelector: itsSelector in: aWorld
	"Grab the scriptor for the given selector and place it in the hand"

	aWorld currentHand attachMorph: (self scriptEditorFor: itsSelector) ! !

!Player methodsFor: 'misc' stamp: 'nk 6/12/2004 10:01'!
impartSketchScripts
	"Let the user designate another object to which my scripts and code should be imparted"

	| aMorph |
	Sensor waitNoButton.
	aMorph _ ActiveWorld chooseClickTarget.
	aMorph ifNil: [^ self].
	(aMorph renderedMorph isSketchMorph) ifTrue:
		[aMorph acquirePlayerSimilarTo: self]! !

!Player methodsFor: 'misc' stamp: 'sw 7/28/2001 01:03'!
indicateLocationOnScreen
	"Give momentary feedback on screen until mouse button is clicked"

	| bds |
	bds _ self costume boundsInWorld.
	5 timesRepeat:
		[Display reverse: bds.
		(Delay forMilliseconds: 80) wait.
		Display reverse: bds.
		(Delay forMilliseconds: 200) wait.].
	costume changed! !

!Player methodsFor: 'misc' stamp: 'sw 1/10/2005 00:08'!
makeBounceSound: soundName
	"Having bounced off an edge, produce the given sound"

	Preferences soundsEnabled
		ifTrue: [self costume playSoundNamed: soundName]! !

!Player methodsFor: 'misc' stamp: 'sw 9/13/2002 17:53'!
noteDecimalPlaces: aNumber forGetter: aGetter
	"Note the given preference of decimal places for the given getter"

	costume noteDecimalPlaces: aNumber forGetter: aGetter! !

!Player methodsFor: 'misc' stamp: 'sw 10/6/2004 11:17'!
offerAlternateViewerMenuFor: aViewer event: evt
	"Put up an alternate Viewer menu on behalf of the receiver."

	| aMenu aWorld  |
	aWorld _ aViewer world.
	aMenu _ MenuMorph new defaultTarget: self.
	costumes ifNotNil:
		[(costumes size > 1 or: [costumes size == 1 and: [costumes first ~~ costume renderedMorph]])
			ifTrue:
				[aMenu add: 'forget other costumes' translated target: self selector: #forgetOtherCostumes]].

	aMenu add: 'expunge empty scripts' translated target: self action: #expungeEmptyScripts.
	aMenu addLine.
	aMenu add: 'choose vocabulary...' translated target: aViewer action: #chooseVocabulary.
	aMenu balloonTextForLastItem: 'Choose a different vocabulary for this Viewer.' translated.
	aMenu add: 'choose limit class...' translated target: aViewer action: #chooseLimitClass.
	aMenu balloonTextForLastItem: 'Specify what the limitClass should be for this Viewer -- i.e., the most generic class whose methods and categories should be considered here.' translated.

	aMenu add: 'open standard lexicon' translated target: aViewer action: #openLexicon.
	aMenu balloonTextForLastItem: 'open a window that shows the code for this object in traditional programmer format' translated.

	aMenu add: 'open lexicon with search pane' translated target: aViewer action: #openSearchingProtocolBrowser.
	aMenu balloonTextForLastItem: 'open a lexicon that has a type-in pane for search (not recommended!!)' translated.


	aMenu addLine.
	aMenu add: 'inspect morph' translated target: costume selector: #inspect.
	aMenu add: 'inspect player' translated target: self selector: #inspect.
	self belongsToUniClass ifTrue:
		[aMenu add: 'browse class' translated target: self action: #browsePlayerClass.
		aMenu add: 'inspect class' translated target: self class action: #inspect].
	aMenu add: 'inspect this Viewer' translated target: aViewer selector: #inspect.
	aMenu add: 'inspect this Vocabulary' translated target: aViewer currentVocabulary selector: #inspect.

	aMenu addLine.
	aMenu add: 'relaunch this Viewer' translated target: aViewer action: #relaunchViewer.
	aMenu add: 'attempt repairs' translated target: ActiveWorld action: #attemptCleanup.
	aMenu add: 'view morph directly' translated target: aViewer action: #viewMorphDirectly.
	aMenu balloonTextForLastItem: 'opens a Viewer directly on the rendered morph.' translated.
	(costume renderedMorph isSketchMorph) ifTrue:
		[aMenu addLine.
		aMenu add: 'impart scripts to...' translated target: self action: #impartSketchScripts].

	aMenu popUpEvent: evt in: aWorld! !

!Player methodsFor: 'misc' stamp: 'dgd 4/4/2006 16:25'!
offerViewerMenuFor: aViewer event: evt
	"Put up the Viewer menu on behalf of the receiver.  If the shift key is held down, put up the alternate menu. The menu omits the 'add a new variable' item when in eToyFriendly mode, as per request from teachers using Squeakland in 2003 once the button for adding a new variable was added to the viewer"

	| aMenu aWorld  |
	(evt notNil and: [evt shiftPressed] and: [Preferences eToyFriendly not]) ifTrue:[
		^ self offerAlternateViewerMenuFor: aViewer event: evt
	].

	aWorld _ aViewer world.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu title: self externalName.
	aMenu addStayUpItem.
	self costume renderedMorph offerCostumeViewerMenu: aMenu.

	Preferences eToyFriendly ifFalse: "exclude this from squeakland-like UI "
		[aMenu add: 'add a new variable' translated target: self action: #addInstanceVariable.
		aMenu balloonTextForLastItem: 'Add a new variable to this object and all of its siblings.  You will be asked to supply a name for it.' translated].

	aMenu add: 'add a new script' translated target: aViewer action: #newPermanentScript.
	aMenu balloonTextForLastItem: 'Add a new script that will work for this object and all of its siblings' translated.
	aMenu addLine.
	self hasCostumeThatIsAWorld ifFalse:[
	
	aMenu add: 'grab me' translated target: self selector: #grabPlayerIn: argument: aWorld.
	
	aMenu balloonTextForLastItem: 'This will actually pick up the object this Viewer is looking at, and hand it to you.  Click the (left) button to drop it' translated.
	].

	aMenu add: 'reveal me' translated target: self selector: #revealPlayerIn: argument: aWorld.
	aMenu balloonTextForLastItem: 'If you have misplaced the object that this Viewer is looking at, use this item to (try to) make it visible' translated.

	aMenu addLine.
	aMenu add: 'tile representing me' translated action: #tearOffTileForSelf.
	aMenu add: 'add search pane' translated target: aViewer action: #addSearchPane.
	Preferences eToyFriendly ifFalse:[
	
	aMenu addLine.
	
	aMenu add: 'more...' translated target: self selector: #offerAlternateViewerMenuFor:event: argumentList: {aViewer. evt}.
	].

	aMenu popUpEvent: evt in: aWorld
! !

!Player methodsFor: 'misc' stamp: 'sw 3/7/2001 12:56'!
openSearchingVocabularyBrowser
	"Open a vocabulary browser on the receiver, showing its etoy vocabulary.  No senders; a disused but presumably still viable path, provisionally retained"

	(Lexicon new useVocabulary: Vocabulary fullVocabulary) openWithSearchPaneOn: self class inWorld: self currentWorld! !

!Player methodsFor: 'misc' stamp: 'sw 1/19/2001 17:44'!
openUnderlyingScriptorFor: aSelector
	"Open the underlying scriptor for the given selector"

	self grabScriptorForSelector: aSelector in: self currentWorld! !

!Player methodsFor: 'misc' stamp: 'sw 10/27/2000 06:38'!
ordinalNumber
	"Answer a number indicating the relative position of the receiver in its stack, if any, else 1"

	| aStack |
	^ (aStack _ self stack) ifNotNil: [aStack cardIndexOf: self] ifNil: [nil]! !

!Player methodsFor: 'misc' stamp: 'tak 1/21/2005 11:59'!
overlaps: aPlayer 
	"Answer whether my costume overlaps that of another player"

	| goalCostume intersection myShadow goalShadow bb myRect goalRect |
	aPlayer ifNil: [^false].
	goalCostume := aPlayer costume.
	costume world == goalCostume world ifFalse: [^false].

	"check if the 2 player costumes intersect"
	intersection := costume bounds intersect: goalCostume bounds.
	(intersection width = 0 or: [intersection height = 0]) 
		ifTrue: [^false]
		ifFalse: 
			["check if the overlapping region is non-transparent"

			"compute 1-bit, black and white versions (stencils) of the intersecting  
			part of each morph's costume"

			myRect := intersection translateBy: 0 @ 0 - costume topLeft.
			myShadow := (costume imageForm contentsOfArea: myRect) stencil.
			goalRect := intersection translateBy: 0 @ 0 - goalCostume topLeft.
			goalShadow := (goalCostume imageForm contentsOfArea: goalRect) stencil.

			"compute a pixel-by-pixel AND of the two stencils.  Result will be black 
			(pixel value = 1) where black parts of the stencils overlap"
			bb := BitBlt toForm: myShadow.
			bb 
				copyForm: goalShadow
				to: 0 @ 0
				rule: Form and.

			"return TRUE if resulting form contains any black pixels"
			^(bb destForm tallyPixelValues second) > 0]! !

!Player methodsFor: 'misc' stamp: 'sw 7/28/2001 01:05'!
revealPlayerIn: aWorld
	"Reveal the receiver if at all possible in the world; once it's visible, flash its image for a bit, and leave it with its halo showing"

	| aMorph |
	(aMorph _ self costume) isInWorld ifTrue:
		[aMorph goHome.
		self indicateLocationOnScreen.
		aMorph addHalo.
		^ self].

	"It's hidden somewhere; search for it"
	aWorld submorphs do:
		[:m | (m succeededInRevealing: self) ifTrue:  "will have obtained halo already"
			[aWorld doOneCycle.
			self indicateLocationOnScreen.
			^ self]].

	"The morph is truly unreachable in this world at present.  So extract it from hyperspace, and place it at center of screen, wearing a halo."
	aMorph isWorldMorph ifFalse:
		[aWorld addMorphFront: aMorph.
		aMorph position: aWorld bounds center.
		aMorph addHalo]
	
	! !

!Player methodsFor: 'misc' stamp: 'tak 1/18/2005 13:12'!
revealPlayerNamed: aSymbol in: aWorld 
	| getter |
	getter := Utilities getterSelectorFor: aSymbol.
	^ (self perform: getter)
		revealPlayerIn: aWorld! !

!Player methodsFor: 'misc' stamp: 'dgd 2/22/2003 13:45'!
revertToUnscriptedPlayerIfAppropriate
	| anInstance |
	(self class selectors notEmpty or: [self class instVarNames notEmpty]) 
		ifTrue: [^self].
	anInstance := UnscriptedPlayer new.
	anInstance initializeCostumesFrom: self.
	self become: anInstance! !

!Player methodsFor: 'misc' stamp: 'sw 1/1/1999 22:28'!
roundUpStrays
	self sendMessageToCostume: #roundUpStrays! !

!Player methodsFor: 'misc' stamp: 'sw 10/26/1998 15:45'!
seesColor: aColor
	costume isInWorld ifFalse: [^ false].
	^ costume touchesColor: aColor! !

!Player methodsFor: 'misc' stamp: 'sw 10/27/2000 06:37'!
stack
	"Answer the stack to which the receiver belongs.  This only searches via the costume's parent pointer, so there is no guarantee that the stack that is found actually contains the receiver in its card list"

	^ costume ifNotNil: [costume stack]! !

!Player methodsFor: 'misc' stamp: 'gm 2/22/2003 14:54'!
tearOffTileForSelf
	| tiles |
	self currentHand attachMorph: (tiles := self tileReferringToSelf).
	(tiles isSyntaxMorph) 
		ifTrue: 
			[Preferences tileTranslucentDrag 
				ifTrue: [tiles lookTranslucent]
				ifFalse: 
					[tiles align: tiles topLeft
						with: self currentHand position + tiles cursorBaseOffset]]! !

!Player methodsFor: 'misc' stamp: 'sw 11/6/2000 12:25'!
thumbnailMenuEvt: anEvent forMorph: aMorph
	"The mouse went down in the thumbnail of a Viewer for the receiver"

	^ self offerViewerMenuForEvt: anEvent morph: aMorph! !

!Player methodsFor: 'misc' stamp: 'yo 8/15/2005 18:08'!
tileReferringToSelf
	"answer a tile that refers to the receiver"

	| aTile  nn tile |
	Preferences universalTiles ifTrue:
		[nn _ self externalName. 	"name it, if necessary, and put in References"
		(References includesKey: nn asSymbol) ifFalse: [
			 References at: nn asSymbol put: self].
		tile _ SyntaxMorph new parseNode: 
			(VariableNode new name: nn key: nn code: nil).
		tile layoutInset: 1; addMorph: (tile addString: nn special: false).
		tile color: (SyntaxMorph translateColor: #variable).
		tile extent: tile firstSubmorph extent + (2@2).
		^ tile].

	aTile _ TileMorph new setToReferTo: self.
	aTile updateWordingToMatchVocabulary.
	^ aTile! !

!Player methodsFor: 'misc' stamp: 'sw 9/6/2002 13:11'!
touchesA: aPrototypicalPlayer
	"Answer whether the receiver overlaps any player who wears a Sketch costume and who is of the same class as the prototypicalPlayer and who is wearing the same bitmap, but who is *not that player itself*!!  This is an extreme case of a function highly customized (by Bob Arning) to suit a single, idiosycratic, and narrow demo need of Alan's.  Consult:
http://groups.yahoo.com/group/squeak/message/40560"

	| envelope trueNeighbor trueGoal trueSelf itsPlayer |
	aPrototypicalPlayer ifNil: [^ false].
	envelope _ costume owner ifNil: [^ false].
	trueSelf _ costume renderedMorph.
	trueGoal _ aPrototypicalPlayer costume renderedMorph.
	envelope submorphs do: [:each |
		trueNeighbor _ each renderedMorph.
		(trueNeighbor == trueGoal or: [trueNeighbor == trueSelf]) ifFalse:
			[(itsPlayer _ each player) ifNotNil:
				[(itsPlayer overlaps: self) ifTrue:
					[(trueGoal appearsToBeSameCostumeAs: trueNeighbor) ifTrue: [^ true]]]]].
	^ false
! !

!Player methodsFor: 'misc' stamp: 'sw 1/1/1999 22:27'!
unhideHiddenObjects
	self sendMessageToCostume: #unhideHiddenObjects! !

!Player methodsFor: 'misc' stamp: 'sw 11/14/2000 11:20'!
uninstallFrom: aPlayfield
	"The receiver is about to be supplanted by another instance which is about to be installed as the current 'card' in the playfield.  Exit gracefully"

	self runAllClosingScripts.
	self commitCardPlayerDataFrom: aPlayfield! !

!Player methodsFor: 'misc' stamp: 'dgd 9/1/2003 14:17'!
unusedScriptName
	"answer a name of the form 'scriptN', where N is one higher than the highest-numbered similarly-named script"

	| highestThus aPair |
	highestThus _ 0.
	self class tileScriptNames do:
		[:aName |
			aPair _ (aName copyWithout: $:) stemAndNumericSuffix.
			aPair first = 'script' translated ifTrue: [highestThus _ highestThus max: aPair last]].
	^ ('script' translated, (highestThus + 1) printString) asSymbol! !

!Player methodsFor: 'misc' stamp: 'sw 1/19/2001 15:35'!
updateAllViewers
	"The receiver's structure has changed, so viewers on it and its siblings need to be reconstituted."

	| aPresenter |
	(aPresenter _ self costume presenter) ifNil: [^ self].
	self allOpenViewersOnReceiverAndSiblings do:
		[:aViewer | aPresenter updateViewer: aViewer]! !

!Player methodsFor: 'misc' stamp: 'sw 1/19/2001 15:36'!
updateAllViewersAndForceToShow: aCategory
	"The receiver's structure has changed, so viewers on it and all its siblings need to be reconstituted."

	| aPresenter |
	(aPresenter _ self costume presenter) ifNil: [^ self].
	self allOpenViewersOnReceiverAndSiblings do:
		[:aViewer | aPresenter updateViewer: aViewer forceToShow: aCategory]! !

!Player methodsFor: 'misc' stamp: 'ccn 12/15/2000 19:03'!
viewerFlapTab
	"If a viewer in a flap exists for me, return it."

	(costume world ifNil: [self currentWorld])
		submorphsDo: [:mm |
			(mm isKindOf: ViewerFlapTab)
				ifTrue:
					[mm scriptedPlayer == self
						ifTrue: [^mm]]].
	^nil! !

!Player methodsFor: 'misc' stamp: 'sw 2/1/98 02:36'!
width
	^ self costume width! !


!Player methodsFor: 'name' stamp: 'sw 11/2/2000 22:00'!
tryToRenameTo: aName
	self costume topRendererOrSelf tryToRenameTo: aName! !


!Player methodsFor: 'objects from disk' stamp: 'tk 8/6/1999 17:14'!
storeDataOn: aDataStream
	"Discard all non-showing script editors"

	self releaseCachedState.
	super storeDataOn: aDataStream.
! !


!Player methodsFor: 'pen' stamp: 'nk 6/12/2004 10:00'!
addPlayerMenuItemsTo: aMenu hand: aHandMorph
	"Note that these items are primarily available in another way in an object's Viewer"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	self getPenDown
		ifTrue: [subMenu add: 'lift pen' action: #liftPen]
		ifFalse: [subMenu add: 'lower pen' action: #lowerPen].
	subMenu add: 'choose pen size...' action: #choosePenSize.
	subMenu add: 'choose pen color...' action: #choosePenColor:.
	aMenu add: 'pen...' subMenu: subMenu.

	(costume renderedMorph isSketchMorph) ifTrue:
		[self belongsToUniClass
			ifFalse: 
				[aMenu add: 'adopt scripts from...' target: self action: #adoptScriptsFrom]
			ifTrue:
				[aMenu add: 'impart scripts to...' target: self action: #impartSketchScripts]]! !

!Player methodsFor: 'pen' stamp: 'tk 10/4/2001 18:16'!
arrowheadsOnAllPens
	"Only for the Player of a World"

	self costume arrowheadsOnAllPens! !

!Player methodsFor: 'pen' stamp: 'ar 10/5/2000 18:53'!
choosePenColor: evt
	self costume changeColorTarget:  self costume  selector: #penColor: originalColor: self getPenColor hand: evt hand! !

!Player methodsFor: 'pen' stamp: 'sw 4/22/1998 13:25'!
choosePenSize
	^ self actorState choosePenSize! !

!Player methodsFor: 'pen' stamp: 'sw 10/4/2002 13:14'!
clearTurtleTrails
	"Clear all turtle trails within my costume, presumed to be a playfield"

	self costume renderedMorph clearTurtleTrails! !

!Player methodsFor: 'pen' stamp: 'sw 8/17/1998 17:12'!
colorUnder
	^ self costume colorUnder! !

!Player methodsFor: 'pen' stamp: 'sw 2/4/98 15:16'!
defaultPenColor
	^ Color blue! !

!Player methodsFor: 'pen' stamp: 'sw 2/4/98 15:03'!
defaultPenSize
	^ 1! !

!Player methodsFor: 'pen' stamp: 'sw 4/17/2003 12:26'!
getDotSize
	"Answer the receiver's dotSize"

	^ self costume renderedMorph valueOfProperty: #trailDotSize ifAbsentPut: [6]! !

!Player methodsFor: 'pen' stamp: 'tk 10/4/2001 16:47'!
getPenArrowheads
	"Answer a boolean indicating whether the receiver's pen will draw an arrowhead at the end of a stroke"
	^ self actorState getPenArrowheads! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 07:25'!
getPenColor
	"Answer the current pen color"

	^ self actorState getPenColor! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 07:26'!
getPenDown
	"Answer a boolean indicating whether the receiver's pen is currently down (true) or up (false)"
	^ self actorState getPenDown! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 07:26'!
getPenSize
	"Answer a number indicating the current pen size"

	^ self actorState getPenSize! !

!Player methodsFor: 'pen' stamp: 'sw 3/11/2003 11:28'!
getTrailStyle
	"Answer the receiver's trailStyle"

	^ self actorState trailStyle! !

!Player methodsFor: 'pen' stamp: 'sw 8/3/1998 16:10'!
liftAllPens
	self costume liftAllPens! !

!Player methodsFor: 'pen' stamp: 'sw 4/13/1998 22:38'!
liftPen
	self actorState liftPen! !

!Player methodsFor: 'pen' stamp: 'sw 8/3/1998 16:10'!
lowerAllPens
	self costume lowerAllPens! !

!Player methodsFor: 'pen' stamp: 'sw 4/13/1998 22:38'!
lowerPen
	self actorState lowerPen! !

!Player methodsFor: 'pen' stamp: 'tk 10/4/2001 18:14'!
noArrowheadsOnAllPens
	"Only for the Player of a Playfield"

	self costume noArrowheadsOnAllPens! !

!Player methodsFor: 'pen' stamp: 'sw 4/13/1998 22:38'!
penColor: aColor
	self actorState penColor: aColor! !

!Player methodsFor: 'pen' stamp: 'sw 4/17/2003 11:56'!
setDotSize: aNumber
	"Set the trail dot size as indicated, but confine matters to a reasonable range"

	self costume renderedMorph setProperty: #trailDotSize toValue: ((aNumber max: 1) min: 100)! !

!Player methodsFor: 'pen' stamp: 'tk 10/4/2001 16:48'!
setPenArrowheads: penDown
	"Set whether the pen will draw arrowheads on the ends of strokes"

	self actorState setPenArrowheads: penDown.
! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 09:03'!
setPenColor: aColor
	"Set the turtle pen color as indicated"

	self actorState setPenColor: aColor! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 09:03'!
setPenDown: penDown
	"Set the penDown state as indicated, to true or false"

	| morph trailMorph tfm |
	self actorState setPenDown: penDown.
	((morph _ self costume) notNil and: [(trailMorph _ morph trailMorph) notNil])
		ifTrue:
		[tfm _ morph owner transformFrom: trailMorph.
		trailMorph notePenDown: penDown forPlayer: self
					at: (tfm localPointToGlobal: morph referencePosition)]
! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 09:03'!
setPenSize: aSize
	"Set the pen size as indicated"

	self actorState setPenSize: aSize! !

!Player methodsFor: 'pen' stamp: 'sw 3/11/2003 11:23'!
setTrailStyle: aTrailStyle
	"Set the trail style"

	self actorState trailStyle: aTrailStyle
! !

!Player methodsFor: 'pen' stamp: 'sw 3/11/2003 11:22'!
trailStyleForAllPens: aTrailStyle
	"Only for the Player of a World"

	self costume renderedMorph trailStyleForAllPens: aTrailStyle! !


!Player methodsFor: 'playing commands' stamp: 'jm 9/28/2004 17:09'!
getCurrentFrameForm

	^ self sendMessageToCostume: #getCurrentFrameForm
! !

!Player methodsFor: 'playing commands' stamp: 'sw 10/13/2004 06:41'!
getFrameGraphic
	"Answer a form representing the receiver's costume's current graphic"

	^ self sendMessageToCostume: #getCurrentFrameForm
! !

!Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 22:03'!
getIsRunning
	^ self sendMessageToCostume: #getIsRunning! !

!Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 22:06'!
getRepeat
	^ self sendMessageToCostume: #getRepeat! !

!Player methodsFor: 'playing commands' stamp: 'sw 10/13/2004 06:38'!
getTotalFrames
	"Answer the receiver's costume's totalFrames.  Applies to MPEGMoviePlayerMorphs"

	^ self sendMessageToCostume: #totalFrames
! !

!Player methodsFor: 'playing commands' stamp: 'sw 10/13/2004 06:37'!
getTotalSeconds
	"Answer the total number of seconds in the receiver's costume, typically a movie"

	^ self sendMessageToCostume: #totalSeconds
! !

!Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 21:29'!
play
	self sendMessageToCostume: #play! !

!Player methodsFor: 'playing commands' stamp: 'jm 10/12/2004 11:17'!
playUntilPosition: aNumber

	 self sendMessageToCostume: #playUntilPosition: with: aNumber! !

!Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 21:32'!
rewind
	self sendMessageToCostume: #rewind! !

!Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 22:07'!
setRepeat: aBoolean 
	 self sendMessageToCostume: #setRepeat: with: aBoolean! !

!Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 21:31'!
stop
	self sendMessageToCostume: #stop! !

!Player methodsFor: 'playing commands' stamp: 'jm 9/28/2004 16:30'!
totalFrames

	^ self sendMessageToCostume: #totalFrames
! !

!Player methodsFor: 'playing commands' stamp: 'jm 9/28/2004 16:30'!
totalSeconds

	^ self sendMessageToCostume: #totalSeconds
! !


!Player methodsFor: 'printing' stamp: 'sw 8/17/1998 17:14'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: (' (', self asOop printString, ')').
	self costume ifNil: [aStream nextPutAll: ' (with nil costume)'.  ^ self].
	aStream nextPutAll: ' named ', self externalName! !

!Player methodsFor: 'printing' stamp: 'sw 1/6/1999 17:44'!
stringForReadout
	^ self externalName! !


!Player methodsFor: 'scripting' stamp: 'tk 8/13/2001 09:27'!
methodInterfacesForScriptsCategoryIn: aVocabulary
	"Answer a list of method interfaces for the category #scripts, as seen in a viewer or other tool.  The vocabulary argument is not presently used."

	| myScripts |
	myScripts _ self class scripts values collect: [:us |
		(us isKindOf: UserScript)
			ifTrue: [us as: MethodWithInterface]
			ifFalse: [us]].
	^ {self methodInterfaceForEmptyScript}, myScripts! !


!Player methodsFor: 'scripts-execution' stamp: 'sw 5/13/1998 13:10'!
assureEventHandlerRepresentsStatus
	self instantiatedUserScriptsDo:
			[:aScriptInst | aScriptInst assureEventHandlerRepresentsStatus]! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 6/13/2002 10:57'!
assureNoScriptOtherThan: aScriptInstantiation hasStatus: aStatus
	self instantiatedUserScriptsDo:
		[:aScriptInst | aScriptInst == aScriptInstantiation  ifFalse: [aScriptInst resetToNormalIfCurrently:  aStatus]]! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 2/6/2001 23:21'!
fireOnce
	"If the receiver has any script armed to be triggered on mouse down and/or mouse-up, run those scripts now -- first the mouseDown ones, then the mouseUp ones."

	self instantiatedUserScriptsDo:
		[:aScriptInst |
			aScriptInst status == #mouseDown ifTrue: [aScriptInst fireOnce]].
	self instantiatedUserScriptsDo:
		[:aScriptInst |
			aScriptInst status == #mouseUp ifTrue: [aScriptInst fireOnce]].
! !

!Player methodsFor: 'scripts-execution' stamp: 'ar 2/12/2001 18:57'!
prepareToBeRunning
	self instantiatedUserScriptsDo:
		[:aScriptInstantiation | aScriptInstantiation prepareToBeRunning].! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 7/3/1998 20:22'!
runAllClosingScripts
	"Run all the receiver's scripts marked as #closing.  Return a boolean indicating whether any such scripts were encountered and run"

	| any |
	any _ false.
	self instantiatedUserScriptsDo:
		[:aScriptInstantiation | aScriptInstantiation runIfClosing ifTrue: [any _ true]].
	^ any! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 7/3/1998 20:21'!
runAllOpeningScripts
	"Run all the receiver's scripts marked as #opening.  Return a boolean indicating whether any such scripts were encountered and run"

	| any |
	any _ false.
	self instantiatedUserScriptsDo:
		[:aScriptInstantiation | aScriptInstantiation runIfOpening ifTrue: [any _ true]].
	^ any! !

!Player methodsFor: 'scripts-execution' stamp: 'ar 2/12/2001 18:04'!
runAllTickingScripts: nowTick

	self instantiatedUserScriptsDo: [:aScriptInstantiation | aScriptInstantiation runIfTicking: nowTick]! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 12/1/1999 13:12'!
scriptingError: aMessage
	"An error arose, characterized by aMessage, when a script was being run.  For the moment, we report it to the transcript only"
	Transcript cr; show: 'Scripting error for ', self externalName, ': ', aMessage! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 8/21/1998 16:34'!
startRunning
	self costume arrangeToStartStepping.
	self instantiatedUserScriptsDo:
		[:aScript | aScript startRunningIfPaused]! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 8/21/1998 16:34'!
startRunningScripts
	self startRunning.
	self costume arrangeToStartStepping.  "emergency patch, if not going already"
	self costume presenter startRunningScripts! !

!Player methodsFor: 'scripts-execution' stamp: 'ar 2/12/2001 18:04'!
stepAt: nowTick
	self runAllTickingScripts: nowTick! !

!Player methodsFor: 'scripts-execution' stamp: 'jm 6/16/1999 14:37'!
stopProgramatically
	"stop running my ticking scripts -- called from running code"
	self instantiatedUserScriptsDo:
		[:aUserScript | aUserScript stopTicking].
	(costume renderedMorph isKindOf: SpeakerMorph)
		ifTrue: [costume renderedMorph stopSound].  "turn off buffered speaker sound"
! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 2/12/98 14:51'!
stopRunning
	self stopProgramatically! !


!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/4/2005 02:18'!
acceptableScriptNameFrom: originalString forScriptCurrentlyNamed: currentName
	"Produce an acceptable script name, derived from the current name, for the receiver.  This method will always return a valid script name that will be suitable for use in the given situation, though you might not like its beauty sometimes."

	| aString stemAndSuffix proscribed stem suffix withoutColon currentNumArgs withColon |
	withoutColon _ originalString copyWithoutAll: {$:. $ }.
	(currentName notNil and: [(currentName copyWithout: $:) = withoutColon])
		ifTrue:
			[^ currentName].  "viz. no change; otherwise, the #respondsTo: check gets in the way"

	currentNumArgs _ currentName ifNil: [0] ifNotNil: [currentName numArgs].
	aString _ withoutColon asIdentifier: false.  "get an identifier starting with a lowercase letter"
	stemAndSuffix _ aString stemAndNumericSuffix.
	proscribed _ #(self super thisContext costume costumes dependents #true #false size).

	stem _ stemAndSuffix first.
	suffix _ stemAndSuffix last.
	withoutColon _ aString asSymbol.
	withColon _ (withoutColon, ':') asSymbol.

	[(proscribed includes: withoutColon)
		or: [self respondsTo: withoutColon]
		or: [self respondsTo: withColon]
		or:	[Smalltalk includesKey: withoutColon]
		or: [Smalltalk includesKey: withColon]]
	whileTrue:
		[suffix _ suffix + 1.
		withoutColon _ (stem, suffix printString) asSymbol.
		withColon _ (withoutColon, ':') asSymbol].

	^ currentNumArgs = 0
		ifTrue:
			[withoutColon]
		ifFalse:
			[withColon]! !

!Player methodsFor: 'scripts-kernel' stamp: 'NS 1/28/2004 14:41'!
acceptScript: aScriptEditorMorph for: aSelector
	"Accept the tile code in the script editor as the code for the given selector.  This branch is only for the classic-tile system, 1997-2001"

	| aUniclassScript |
	self class compileSilently: aScriptEditorMorph methodString
		classified: 'scripts'.
	aUniclassScript _ self class assuredMethodInterfaceFor: aSelector asSymbol.
	aUniclassScript currentScriptEditor: aScriptEditorMorph! !

!Player methodsFor: 'scripts-kernel' stamp: 'yo 2/12/2005 19:53'!
addIdiosyncraticMenuItemsTo: aMenu forSlotSymol: slotSym
	"The menu provided has the receiver as its argument, and is used as the menu for the given slot-symbol in a line of a Viewer.  Add special-case items"

	(#(copy getNewClone newClone) includes: slotSym) ifTrue:
		[aMenu add: 'give me a copy now' translated action: #handTheUserACopy].

"	(slotSym == #dropShadow) ifTrue:
		[aMenu add: 'set shadow offset' translated action: #setShadowOffset].

	(slotSym == #useGradientFill) ifTrue:
		[aMenu add: 'set gradient origin...' translated action: #setGradientOffset.
		aMenu add: 'set gradient direction...' translated action: #setGradientDirection]."
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 4/9/98 21:56'!
allScriptEditors
	"Used presently only an one-shot efforts to update all tile scripts to new styles"

	^ self class tileScriptNames collect: [:n | self scriptEditorFor: n]! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:04'!
editDescriptionForSelector:  aSelector
	"Allow the user to edit the balloon-help description for the given selector"

	(self class userScriptForPlayer: self selector: aSelector) editDescription.
	self updateAllViewers! !

!Player methodsFor: 'scripts-kernel' stamp: 'ar 1/10/2001 12:10'!
emptyScript
	"The empty script"! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 9/8/2000 17:03'!
expungeEmptyScripts
	"Track down and destroy -- and destroy screen artifacts relating to -- all scripts belonging to the receiver that have no lines of code in them"

	| any |
	any _ false.
	self class namedTileScriptSelectors do:
		[:aSel |
			(self isEmptyTileScript: aSel)
				ifTrue:
					[any _ true.
					self removeScriptWithoutUpdatingViewers: aSel]].
	any ifTrue: [self updateAllViewersAndForceToShow: #scripts]
			
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 9/8/2000 17:04'!
expungeEmptyUnRenamedScripts
	"Track down and destroy -- and destroy screen artifacts relating to -- all scripts belonging to the receiver that have not been named and that have no lines of code in them"

	| any |
	any _ false.
	self class namedTileScriptSelectors do:
		[:aSel |
			(self isExpendableScript: aSel)
				ifTrue:
					[any _ true.
					self removeScriptWithoutUpdatingViewers: aSel]].
	any ifTrue:
		[self updateAllViewersAndForceToShow: #scripts]
			
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/21/98 23:32'!
hasScriptInvoking: scriptName ofPlayer: aPlayer
	"Answer whether the receiver bears any script that invokes a script of the given name for  the given player"
	self allScriptEditors do:
		[:anEditor | (anEditor hasScriptInvoking: scriptName ofPlayer: aPlayer) ifTrue: [^ true]].
	^ false! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/16/1999 16:27'!
hasScriptReferencing: slotName ofPlayer: aPlayer
	"Answer whether the receiver bears any script that references a slot of the given name for  the given player"
	self allScriptEditors do:
		[:anEditor | (anEditor hasScriptReferencing: slotName ofPlayer: aPlayer) ifTrue: [^ true]].
	^ false! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/20/2001 02:28'!
isEmptyTileScript: aScriptName
	"Answer whether the script of the given name is an empty classic tile script.  Presently disused -- formerly it was all too easy to propagate many empty tile scripts but this difficulty has receded considerably with recent changes, so this has no senders other than from an unusual menu item, and will perhaps die soon"

	| aUserScript |
	Preferences universalTiles ifTrue: [^ false].
	aUserScript _ self class userScriptForPlayer: self selector: aScriptName.
	^ (aUserScript instantiatedScriptEditorForPlayer: self) isEmpty
! !

!Player methodsFor: 'scripts-kernel' stamp: 'dgd 9/1/2003 14:17'!
isExpendableScript: aScriptName
	^ (self isEmptyTileScript: aScriptName) and:
		[aScriptName beginsWith: 'script' translated]
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:03'!
makeIsolatedCodePaneForSelector: aSelector
	"make an isolated code pane for the given selector"

	MethodHolder makeIsolatedCodePaneForClass: self class selector: aSelector
! !

!Player methodsFor: 'scripts-kernel' stamp: 'mir 7/12/2004 19:41'!
methodInterfaceForEmptyScript
	"Answer a MethodInterface representing Andreas's 'emptyScript' feature"

	| anInterface |
	anInterface _ MethodInterface new.
	anInterface receiverType: #Player.
	anInterface flagAttribute: #scripts.
	anInterface
		wording: (ScriptingSystem wordingForOperator: #emptyScript);
		helpMessage: 'an empty script; drop on desktop to get a new empty script for this object'.

	anInterface selector: #emptyScript type: nil setter: nil.
	^ anInterface! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 7/17/2002 16:41'!
newTextualScriptorFor: aSelector
	"Sprout a scriptor for aSelector, opening up in textual mode.  Rather special-purpose, consult my lone sender"

	| aMethodWithInterface aScriptEditor |
	(self class selectors includes: aSelector) ifTrue: [self error: 'selector already exists'].

	aMethodWithInterface _ self class permanentUserScriptFor: aSelector player: self.
	aScriptEditor _ aMethodWithInterface instantiatedScriptEditorForPlayer: self.
	aScriptEditor install.
	aScriptEditor showSourceInScriptor.
	aMethodWithInterface selector numArgs == 0 ifTrue:
		[self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aMethodWithInterface selector]].
		"The above assures the presence of a ScriptInstantiation for the new selector in all siblings"

	self updateAllViewersAndForceToShow: #scripts.
	^ aScriptEditor! !

!Player methodsFor: 'scripts-kernel' stamp: 'yo 1/2/2004 06:40'!
noteRenameOf: oldSlotName to: newSlotName inPlayer: aPlayer
	"Note that aPlayer has renamed a slot formerly known as oldSlotName to be newSlotName"

	self allScriptEditors do:
		[:anEditor | (anEditor showingMethodPane not and: [anEditor hasScriptReferencing: oldSlotName ofPlayer: aPlayer]) ifTrue: 
			[anEditor replaceReferencesToSlot: oldSlotName inPlayer: aPlayer with: newSlotName]]! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 8/17/1998 17:13'!
okayToDestroyScriptNamed: scriptName
	self costume world presenter allExtantPlayers do:
		[:aPlayer | (aPlayer hasScriptInvoking: scriptName ofPlayer: self)
			ifTrue:
				[^ false]].
	^ true! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 8/17/1998 17:21'!
okayToRemoveSlotNamed: aSlotName
	self costume world presenter allExtantPlayers do:
		[:aPlayer | (aPlayer hasScriptReferencing: aSlotName ofPlayer: self)
			ifTrue:
				[^ false]].
	^ true! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 7/16/1999 17:06'!
removeScriptWithoutUpdatingViewers: aSymbol
	self pacifyScript: aSymbol.
	self class removeScriptNamed: aSymbol.

	(self scriptorsForSelector: aSymbol inWorld: costume world) do:
		[:s | s privateDelete].
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 8/15/2000 11:57'!
removeScriptWithoutUpdatingViewers: aSymbol fromWorld: aWorld
	self pacifyScript: aSymbol.
	self class removeScriptNamed: aSymbol.

	(self scriptorsForSelector: aSymbol inWorld: aWorld) do:
		[:s | s privateDelete].
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:01'!
removeScriptWithSelector: aSelector
	"Remove the given script, and get the display right"

	self removeScript: aSelector fromWorld:  self currentWorld
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 9/8/2000 17:06'!
removeScript: aSymbol fromWorld: aWorld
	"Remove the given script, and get the display right in aWorld"

	self removeScriptWithoutUpdatingViewers: aSymbol fromWorld: aWorld.
	self updateAllViewersAndForceToShow: #scripts
! !

!Player methodsFor: 'scripts-kernel' stamp: 'yo 2/11/2005 15:37'!
renameScript: oldSelector 
	"The user has asked to rename the script formerly known by oldSelector; obtain a new selector from the user, check it out, and if all is well, ascribe the new name as appropriate"

	| reply newSelector aUserScript |
	self flag: #deferred.
	"Relax the restriction below, before too long"
	aUserScript := self class userScriptForPlayer: self selector: oldSelector.
	aUserScript okayToRename 
		ifFalse: 
			[self 
				inform: 'Sorry, we do not permit you to rename
classic-tiled scripts that are currently
textually coded.  Go back to tile scripts
and try again.  Humble apologies.' translated.
			^self].
	reply := FillInTheBlank request: 'Script Name' translated initialAnswer: oldSelector.
	reply isEmpty ifTrue: [^self].
	reply = oldSelector ifTrue: [^Beeper beep].
	newSelector := self acceptableScriptNameFrom: reply
				forScriptCurrentlyNamed: oldSelector.
	Preferences universalTiles 
		ifTrue: 
			["allow colons"

			(reply copyWithout: $:) = newSelector 
				ifTrue: [newSelector := reply asSymbol]
				ifFalse: [self inform: 'name will be modified']].
	self renameScript: oldSelector newSelector: newSelector! !

!Player methodsFor: 'scripts-kernel' stamp: 'yo 5/6/2005 09:49'!
renameScript: oldSelector newSelector: newSelector
	"Rename the given script to have the new selector"

	|  aUserScript anInstantiation aDict |
	oldSelector = newSelector ifTrue: [^ self].

	oldSelector numArgs == 0
		ifTrue:
			[self class allSubInstancesDo:
				[:aPlayer | | itsCostume |
					anInstantiation _ aPlayer scriptInstantiationForSelector: oldSelector.
					anInstantiation ifNotNil: [
						newSelector numArgs == 0
							ifTrue:
								[anInstantiation changeSelectorTo: newSelector].
						aDict _ aPlayer costume actorState instantiatedUserScriptsDictionary.
						itsCostume _ aPlayer costume renderedMorph.
						itsCostume renameScriptActionsFor: aPlayer from: oldSelector to: newSelector.
						self currentWorld renameScriptActionsFor: aPlayer from: oldSelector to: newSelector.
						aDict removeKey: oldSelector.

						newSelector numArgs  == 0 ifTrue:
							[aDict at: newSelector put: anInstantiation.
							anInstantiation assureEventHandlerRepresentsStatus]]]]
		ifFalse:
			[newSelector numArgs == 0 ifTrue:
				[self class allSubInstancesDo:
					[:aPlayer |
						anInstantiation _ aPlayer scriptInstantiationForSelector: newSelector.
						anInstantiation ifNotNil: [anInstantiation assureEventHandlerRepresentsStatus]]]].

	aUserScript _ self class userScriptForPlayer: self selector: oldSelector.

	aUserScript renameScript: newSelector fromPlayer: self.
		"updates all script editors, and inserts the new script in my scripts directory"

	self class removeScriptNamed: oldSelector.
	((self existingScriptInstantiationForSelector: newSelector) notNil and:
		[newSelector numArgs > 0]) ifTrue: [self error: 'ouch'].
		
	self updateAllViewersAndForceToShow: 'scripts'! !

!Player methodsFor: 'scripts-kernel' stamp: 'yo 7/27/2004 15:59'!
runScript: aSelector
	"Called from script-activation buttons.  Provides a safe way to run a script that may have changed its name"
	(self respondsTo: aSelector) ifTrue:
		[^ self triggerScript: aSelector].
	self inform: 
'Oops, object "', self externalName, '" no longer has
a script named "', aSelector, '".
It must have been deleted or renamed.'! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/17/2001 01:05'!
scriptEditorFor: aSelector
	"Answer the receiver's script editor for aSelector"

	| aScriptEditor |
	aScriptEditor _ (self class userScriptForPlayer: self selector: aSelector) instantiatedScriptEditorForPlayer: self.
	aScriptEditor updateToPlayer: self.
	aScriptEditor bringUpToDate.
	^ aScriptEditor! !

!Player methodsFor: 'scripts-kernel' stamp: 'yo 5/6/2005 09:47'!
scriptInstantiationForSelector: aSelector
	"Answer a script instantiation for the given selector, creating it at this time if necessary"

	|  entry scriptDict classEntry actorState |
	actorState _ self actorState.
	actorState ifNil: [^ nil].
	scriptDict _ actorState instantiatedUserScriptsDictionary.
	entry _ scriptDict at: aSelector ifAbsent: [nil].
	entry ifNil:
		[classEntry _ self class userScriptForPlayer: self selector: aSelector.
		entry _ ScriptInstantiation new player: self selector: aSelector status: classEntry defaultStatus.
		scriptDict at: aSelector put: entry].
	^ entry! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/19/2001 15:15'!
scriptorsForSelector: aSelector inWorld: aWorld
	"Answer, for the purpose of deletion, a list of all scriptor objects for the given selector that are associated with any member of the receiver's uniclass"

	| scriptors |
	aWorld ifNil: [^ OrderedCollection new].
	scriptors _ (aWorld allMorphs select:
		[:m | (((m isKindOf: ScriptEditorMorph) and: [m playerScripted class == self class]) and: [m scriptName == aSelector])] thenCollect: [:m | m topEditor]) asSet.
	^ scriptors asArray! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 8/3/2005 14:48'!
slotInfoButtonHitFor: aGetterSymbol inViewer: aViewer
	"The user made a gesture asking for slot menu for the given getter symbol in a viewer; put up the menu."

	| aMenu slotSym aType typeVocab interface selector |

	 (#(+ - * /) includes: aGetterSymbol)
		ifTrue:
			 [^ self inform: aGetterSymbol, ' is used for vector operations'].

	slotSym _ Utilities inherentSelectorForGetter: aGetterSymbol.
	aType _ self typeForSlotWithGetter: aGetterSymbol asSymbol.
	aMenu _ MenuMorph new defaultTarget: self.
	interface := aViewer currentVocabulary methodInterfaceAt: aGetterSymbol ifAbsent: [nil].
	selector := interface isNil
		ifTrue: [slotSym asString]
		ifFalse: [interface selector].
	aMenu addTitle: (selector, ' (', (aType asString translated), ')').

	aType = #Patch ifTrue: [
		aMenu add: 'grab morph' translated
			target: (self perform: aGetterSymbol)
			selector: #grabPatchMorph
			argument: #().
			aMenu addLine.
	].

	(typeVocab _ Vocabulary vocabularyForType: aType) addWatcherItemsToMenu: aMenu forGetter: aGetterSymbol.

	(self slotInfo includesKey: slotSym)
		ifTrue:
			[aMenu add: 'change value type' translated selector: #chooseSlotTypeFor: argument: aGetterSymbol.
			typeVocab addUserSlotItemsTo: aMenu slotSymbol: slotSym.
			aMenu add: ('remove "{1}"' translated format: {slotSym}) selector: #removeSlotNamed: argument: slotSym.
			aMenu add: ('rename "{1}"' translated format: {slotSym}) selector: #renameSlot: argument: slotSym.			aMenu addLine].

	typeVocab addExtraItemsToMenu: aMenu forSlotSymbol: slotSym.  "e.g. Player type adds hand-me-tiles"

	aMenu add: 'show categories....' translated target: aViewer selector: #showCategoriesFor: argument: aGetterSymbol.
	self addIdiosyncraticMenuItemsTo: aMenu forSlotSymol: slotSym.

	aMenu items isEmpty ifTrue:
		[aMenu add: 'ok' translated action: #yourself].

	aMenu popUpForHand: aViewer primaryHand in: aViewer world! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 11/5/1998 10:33'!
sourceCodeFor: sel
	^ self class sourceCodeAt: sel ifAbsent: 
		[Player sourceCodeAt: sel ifAbsent: ['this space for rent']]
	! !

!Player methodsFor: 'scripts-kernel' stamp: 'mir 7/12/2004 19:36'!
tilesToCall: aMethodInterface
	"Answer a phrase for the non-typed command represented by aMethodInterface."

	| resultType cmd argType argTile selfTile aPhrase balloonTextSelector aDocString universal |
	self class namedTileScriptSelectors.

	resultType _ aMethodInterface resultType.
	cmd _ aMethodInterface selector.
	(universal _ self isUniversalTiles)
		ifTrue:
			[aPhrase _ self universalTilesForInterface: aMethodInterface]
		ifFalse: [cmd numArgs == 0
			ifTrue:
				[aPhrase _ PhraseTileMorph new setOperator: cmd
					type: resultType
					rcvrType: #Player]
			ifFalse:
				["only one arg supported in classic tiles, so if this is fed
				with a selector with > 1 arg, results will be very strange"
				argType _ aMethodInterface typeForArgumentNumber: 1.
				aPhrase _ PhraseTileMorph new setOperator: cmd
					type: resultType
					rcvrType: #Player
					argType: argType.
				argTile _ ScriptingSystem tileForArgType: argType.
				argTile position: aPhrase lastSubmorph position.
				aPhrase lastSubmorph addMorph: argTile]].

	(self slotInfo includesKey: cmd)
		ifTrue: [balloonTextSelector _ #userSlot].

	(self belongsToUniClass and: [self class includesSelector: cmd])
		ifTrue:
			[aDocString _ (self class userScriptForPlayer: self selector: cmd) documentation.
			aDocString
				ifNotNil: [aPhrase submorphs second setBalloonText: aDocString]
				ifNil: [balloonTextSelector _ #userScript]].

	(universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]) balloonTextSelector: 
			(balloonTextSelector ifNil: [cmd]).
	universal ifFalse:
		[selfTile _ self tileToRefer.
		selfTile position: aPhrase firstSubmorph position.
		aPhrase firstSubmorph addMorph: selfTile.
		aPhrase makeAllTilesGreen.
		aPhrase justGrabbedFromViewer: false].
	^ aPhrase! !

!Player methodsFor: 'scripts-kernel' stamp: 'tk 9/29/2001 22:20'!
universalTilesForInterface: aMethodInterface
	"Return universal tiles for the given method interface.  Record who self is."

	| ms argTile itsSelector aType argList makeSelfGlobal phrase |
	itsSelector _ aMethodInterface selector.
	argList _ OrderedCollection new.
	aMethodInterface argumentVariables doWithIndex:
		[:anArgumentVariable :anIndex | 
			argTile _ ScriptingSystem tileForArgType: (aType _ aMethodInterface typeForArgumentNumber: anIndex).
			argList add: (aType == #Player 
				ifTrue: [argTile actualObject]
				ifFalse: [argTile literal]).	"default value for each type"].

	ms _ MessageSend receiver: self selector: itsSelector arguments: argList asArray.
	"For CardPlayers, use 'self'.  For others, name me, and use my global name."
	makeSelfGlobal _ self class officialClass ~~ CardPlayer.
	phrase _ ms asTilesIn: self class globalNames: makeSelfGlobal.
	makeSelfGlobal ifFalse: [phrase setProperty: #scriptedPlayer toValue: self].
	^ phrase
! !


!Player methodsFor: 'scripts-standard' stamp: 'ar 4/10/2005 18:50'!
append: aPlayer 
	"Add aPlayer to the list of objects logically 'within' me.  This is visually represented by its morph becoming my costume's last submorph.   Also allow text to be appended."

	| aCostume |
	(aPlayer isNil or: [aPlayer == self]) ifTrue: [^self].
	(aPlayer isText or: [aPlayer isString]) 
		ifTrue: 
			[self costume class == TextFieldMorph 
				ifTrue: [^self costume append: aPlayer]
				ifFalse: [^self]].
	(aCostume := self costume topRendererOrSelf) 
		addMorphNearBack: aPlayer costume.
	aPlayer costume goHome.	"assure it's in view"
	(aCostume isKindOf: PasteUpMorph) 
		ifTrue: [self setCursor: (aCostume submorphs indexOf: aPlayer costume)]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/4/2001 07:42'!
assignStatus: newStatus toAllFor: scriptName
	"Change the status of my script of the given name to be as specified in me and all of my siblings."

	| aWorld |
	(self existingScriptInstantiationForSelector: scriptName) ifNotNilDo:
		[:scriptInstantiation |
				scriptInstantiation status: newStatus.
				scriptInstantiation assignStatusToAllSiblings.
				^ (aWorld _ self costume world) ifNotNil:
					[aWorld updateStatusForAllScriptEditors]]! !

!Player methodsFor: 'scripts-standard' stamp: 'dgd 2/22/2003 13:42'!
bounce: soundName 
	"If the receiver's current bounds obtrude beyond the bounds of its container, then 'bounce' it back within the container, and make the indicated sound while doing so"

	| box bounced aCostume |
	(aCostume := self costume) ifNil: [^self].
	(aCostume owner isNil or: [aCostume owner isHandMorph]) ifTrue: [^self].
	box := aCostume owner bounds.
	bounced := false.
	aCostume left < box left 
		ifTrue: 
			[self headRight.
			bounced := true].
	aCostume right > box right 
		ifTrue: 
			[self headLeft.
			bounced := true].
	aCostume top < box top 
		ifTrue: 
			[self headDown.
			bounced := true].
	aCostume bottom > box bottom 
		ifTrue: 
			[self headUp.
			bounced := true].
	bounced ifTrue: [^self makeBounceSound: soundName]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/11/2001 20:47'!
changeScript: scriptName toStatus: statusSymbol
	"Change the script of the given name to have the given status, and get all relevant script-status controls updated"

	scriptName ifNil: [^ self].
	Symbol hasInterned: scriptName ifTrue:
		[:sym | self instantiatedUserScriptsDo:
			[:aScriptInstantiation | aScriptInstantiation selector == sym
				ifTrue:
					[aScriptInstantiation status: statusSymbol.
					aScriptInstantiation updateAllStatusMorphs]]]! !

!Player methodsFor: 'scripts-standard' stamp: 'jm 4/22/1999 15:52'!
clear

	self sendMessageToCostume: #clear.
! !

!Player methodsFor: 'scripts-standard' stamp: 'tk 1/14/2001 06:27'!
contents
	^ costume contents! !

!Player methodsFor: 'scripts-standard' stamp: 'tk 1/14/2001 06:27'!
contents: stuff
	^ costume contents: stuff! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/5/2001 11:25'!
doButtonAction
	"Do the button action of my costume"

	self costume renderedMorph doButtonAction! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:58'!
doMenuItem: menuString
	"Do the menu item whose wording is provided"

	self costume doMenuItem: menuString! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/2/2001 11:59'!
doScript: scriptNameString
	"On the next tick of the clock, run the given script once"

	Symbol hasInterned: scriptNameString ifTrue:
		[:sym | (self class includesSelector: sym) ifTrue:
			[costume addAlarm: #triggerScript: with: sym after: 1]]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/6/2001 21:13'!
fire
	"Do the button action of my costume"

	self costume renderedMorph fire! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:59'!
followPath
	"If there is a path defined for this object, follow it now"

	self costume followPath! !

!Player methodsFor: 'scripts-standard' stamp: 'mir 6/7/2002 17:08'!
forward: dist 
	"Move forward (viz. in the direction of my heading) by the given amount"

	| rho radians delta didStray p aCostume aPlayfield |
	(aCostume _ self costume) isInWorld ifFalse: [^ self].
	aCostume isWorldOrHandMorph ifTrue: [^ self].
	aCostume owner isHandMorph ifTrue: [^ self].

	rho _ (aCostume asNumber: dist) asFloat.
	radians _ (self getHeadingUnrounded asFloat - 90.0) degreesToRadians.
	delta _ (radians cos @ radians sin) * rho.

	(aPlayfield _ aCostume pasteUpMorph) fenceEnabled ifTrue:
		[(aPlayfield bounds containsRect: aCostume bounds) ifFalse:
			["If I stray out of the bounds of my playfield, pull me back, but
			 without changing my heading as bounce would. Do nothing if
			 bounce has already corrected the direction."
			didStray _ false.
			((aCostume left < aPlayfield left and: [delta x < 0]) or:
			 [aCostume right > aPlayfield right and: [delta x > 0]]) ifTrue:
				[delta _ delta x negated @ delta y.
				didStray _ true].
			((aCostume top < aPlayfield top and: [delta y < 0]) or:
			 [aCostume bottom > aPlayfield bottom and: [delta y > 0]]) ifTrue:
				[delta _ delta x @ delta y negated.
				didStray _ true].
			(didStray and: [Preferences fenceSoundEnabled]) ifTrue: [aCostume makeFenceSound]]].

	"use and record the fractional position"
	p _ aCostume referencePosition + delta.
	aCostume referencePosition: p! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 10/3/2004 01:45'!
getBackgroundColor
	"Answer the background color; the costume is presumed to be a TextMorph"

	^  self costume renderedMorph backgroundColor ifNil: [Color transparent]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/7/2000 12:52'!
getObtrudes
	"Answer whether the receiver's costume obtrudes beyond the bounds of its container"

	| aCostume |
	(aCostume _ self costume) ifNil: [^ false].
	^ aCostume obtrudesBeyondContainer
! !

!Player methodsFor: 'scripts-standard' stamp: 'yo 3/16/2005 15:43'!
goToRightOf: aPlayer 
	"Place the object so that it lies directly to the right of the given object"

	| hisCostume aCostume |
	(aPlayer isNil or: [aPlayer == self]) ifTrue: [^self].
	(hisCostume := aPlayer costume) isInWorld ifFalse: [^self].
	aCostume := self costume.
	aCostume isWorldMorph ifTrue: [^ self].
	aCostume owner == hisCostume owner 
		ifFalse: [hisCostume owner addMorphFront: aCostume].
	aCostume 
		position: hisCostume bounds rightCenter - (0 @ (aCostume height // 2))! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:57'!
hide
	"Make the object be hidden, as opposed to visible"

	self costume hide! !

!Player methodsFor: 'scripts-standard' stamp: 'ar 4/10/2005 18:50'!
includeAtCursor: aPlayer 
	"Add aPlayer to the list of objects logically 'within' me, at my current cursor position. ."

	| aCostume |
	(aPlayer isNil or: [aPlayer == self]) ifTrue: [^self].
	(aPlayer isText or: [aPlayer isString]) 
		ifTrue: 
			[^ self costume class == TextFieldMorph 
				ifTrue: [self costume append: aPlayer]
				ifFalse: [self]].
	aCostume := self costume topRendererOrSelf.
	aPlayer costume goHome.	"assure it's in view"
	(aCostume isKindOf: PasteUpMorph) 
		ifTrue:
			[aCostume addMorph: aPlayer costume asElementNumber: self getCursor.
			aCostume invalidRect: aCostume bounds]
		ifFalse:
			[aCostume addMorphBack: aPlayer.
			self setCursor: aCostume submorphs size]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/3/2002 23:09'!
include: anObject
	"Add the object to my content"

	^ self append: anObject! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 8/17/1998 17:18'!
initiatePainting
	(self costume isKindOf: PasteUpMorph) ifTrue:
		[self costume makeNewDrawingWithin]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/18/2003 02:57'!
insertCharacters: aString
	"Insert the given characters at my current cursor position"

	self costume renderedMorph insertCharacters: aString! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/18/2003 02:57'!
insertContentsOf: aPlayer
	"Insert the string contents of the given player at my given cursor position"

	self costume renderedMorph insertContentsOf: aPlayer! !

!Player methodsFor: 'scripts-standard' stamp: 'jm 4/22/1999 15:53'!
loadSineWave

	self sendMessageToCostume: #loadSineWave.
! !

!Player methodsFor: 'scripts-standard' stamp: 'gk 2/23/2004 20:51'!
loadSound: soundName

	| snd |
	snd _ SoundService default soundNamed: soundName.
	snd ifNotNil: [self sendMessageToCostume: #loadSound: with: snd].
! !

!Player methodsFor: 'scripts-standard' stamp: 'dgd 2/22/2003 13:43'!
makeNewDrawingIn: paintPlacePlayer 
	| paintPlace |
	((paintPlacePlayer isNil 
		or: [((paintPlace := paintPlacePlayer costume) isKindOf: PasteUpMorph) not]) 
			or: [paintPlace isInWorld not]) 
			ifTrue: 
				[^self 
					inform: 'Error: not a plausible
place in which to make
a new drawing'].
	paintPlace makeNewDrawingWithin! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/22/1999 11:50'!
menuItemAfter: menuString
	^ self costume menuItemAfter: menuString! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/22/1999 11:55'!
menuItemBefore: menuString
	^ self costume menuItemBefore: menuString! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 7/29/2005 17:32'!
moveToward: aPlayer
	"Move a standard amount in the direction of the given player.  If the object has an instance variable named 'speed', the speed of the motion will be governed by that value"

	| myPosition itsPosition |
	((aPlayer ~~ self) and: [(self overlaps: aPlayer) not]) ifTrue:
		[((myPosition _ self costume referencePosition) = (itsPosition _ aPlayer costume referencePosition))
			ifFalse:
				[self setHeading: (myPosition bearingToPoint: itsPosition).
				self forward: self getSpeed]]! !

!Player methodsFor: 'scripts-standard' stamp: 'tak 1/21/2005 12:08'!
overlapsAny: aPlayer 
	"Answer true if my costume overlaps that of aPlayer, or any of its  
	siblings (if aPlayer is a scripted player)  
	or if my costume overlaps any morphs of the same class (if aPlayer is  
	unscripted)."
	| possibleCostumes itsCostume itsCostumeClass myShadow |
	(self ~= aPlayer
			and: [self overlaps: aPlayer])
		ifTrue: [^ true].
	possibleCostumes := IdentitySet new.
	aPlayer belongsToUniClass
		ifTrue: [aPlayer class
				allSubInstancesDo: [:anInstance | (anInstance ~~ aPlayer
							and: [itsCostume := anInstance costume.
								(itsCostume bounds intersects: costume bounds)
									and: [itsCostume world == costume world]])
						ifTrue: [possibleCostumes add: itsCostume]]]
		ifFalse: [itsCostumeClass := aPlayer costume class.
			self costume world presenter allExtantPlayers
				do: [:ep | ep costume
						ifNotNilDo: [:ea | (ea class == itsCostumeClass
									and: [ea bounds intersects: costume bounds])
								ifTrue: [possibleCostumes add: ea]]]].
	possibleCostumes isEmpty
		ifTrue: [^ false].
	myShadow := costume shadowForm.
	^ possibleCostumes
		anySatisfy: [:m | m overlapsShadowForm: myShadow bounds: costume fullBounds]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/4/2001 07:23'!
pauseAll: scriptName
	"Change the status of my script of the given name to be #paused in me and all of my siblings."

	self assignStatus: #paused toAllFor: scriptName! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:57'!
pauseScript: scriptName
	"Change the status of my script of the given name to be #paused"

	self changeScript: scriptName toStatus: #paused! !

!Player methodsFor: 'scripts-standard' stamp: 'nk 8/21/2004 12:15'!
performScriptIfCan: scriptNameString 
	"If I understand the given script name, perform it now"
	^Symbol
		hasInterned: scriptNameString
		ifTrue: [:sym | (self class includesSelector: sym)
				ifTrue: [self triggerScript: sym]]! !

!Player methodsFor: 'scripts-standard' stamp: 'ar 4/10/2005 18:51'!
prepend: aPlayer 
	"Add aPlayer to the list of objects logically 'within' me.  This is visually represented by its morph becoming my costume's first submorph.   Also allow text to be prepended."

	| aCostume |
	(aPlayer isNil or: [aPlayer == self]) ifTrue: [^self].
	(aPlayer isText or: [aPlayer isString]) 
		ifTrue: 
			[^ self costume class == TextFieldMorph 
				ifTrue: [self costume prepend: aPlayer]
				ifFalse: [self]].
	(aCostume := self costume topRendererOrSelf) 
		addMorphFront: aPlayer costume.
	aPlayer costume goHome.	"assure it's in view"
	(aCostume isKindOf: PasteUpMorph) 
		ifTrue: [self setCursor: (aCostume submorphs indexOf: aPlayer costume)]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/8/2000 17:05'!
removeAll
	"Remove all the elements from my companion morph's collection.  This is destructive!!"

	costume ifNotNil: [costume removeAllMorphs]! !

!Player methodsFor: 'scripts-standard' stamp: 'jm 4/22/1999 15:52'!
reverse

	self sendMessageToCostume: #reverse.
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 10/3/2004 01:32'!
setBackgroundColor: aColor
	"Set the background color; the costume is presumed to be a text morph."

	self costume renderedMorph backgroundColor: aColor! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:56'!
show
	"Make the object be visible, as opposed to hidden"

	self costume show! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/8/2000 18:39'!
shuffleContents
	"Tell my costume to rearrange its submorphs randomly"

	costume shuffleSubmorphs! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/4/2001 06:59'!
startAll: scriptName
	"Change the status of my script of the given name to be #ticking in me and all of my siblings."

	self assignStatus: #ticking toAllFor: scriptName! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:56'!
startScript: scriptName
	"Change the status of my script of the given name to be #ticking"

	self changeScript: scriptName toStatus: #ticking! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/4/2001 07:24'!
stopAll: scriptName
	"Change the status of my script of the given name to be #normal in me and all of my siblings."

		self assignStatus: #normal toAllFor: scriptName! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:56'!
stopScript: scriptName
	"Change the status of my script of the given name to be #normal"

	self changeScript: scriptName toStatus: #normal! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/20/2003 13:14'!
tellAllContents: aMessageSelector
	"Send the given message selector to all the content players within the receiver's morph"

	costume renderedMorph tellAllContents: aMessageSelector! !

!Player methodsFor: 'scripts-standard' stamp: 'nk 8/21/2004 12:39'!
tellAllSiblings: aMessageSelector
	"Send the given message selector to all my sibling instances, but not to myself"

	Symbol hasInterned: aMessageSelector
		ifTrue: [ :sel |
	self belongsToUniClass
		ifTrue: [self class allSubInstancesDo:
				[:anInstance | anInstance ~~ self ifTrue: [ anInstance triggerScript: sel ]]]
		ifFalse:
			[(sel ~~ #emptyScript) ifTrue:
				[ScriptingSystem reportToUser: ('Cannot "tell" ', aMessageSelector, ' to ', self externalName) ]]]! !

!Player methodsFor: 'scripts-standard' stamp: 'nk 8/21/2004 12:42'!
tellSelfAndAllSiblings: aMessageSelector
	"Send the given message selector to all my sibling instances, including myself"

	Symbol hasInterned: aMessageSelector
		ifTrue: [ :sel |
	self belongsToUniClass
		ifTrue: [self class allSubInstancesDo:
				[:anInstance | anInstance triggerScript: sel ]]
		ifFalse:
			[(sel ~~ #emptyScript) ifTrue:
				[ScriptingSystem reportToUser: ('Cannot "tell" ', aMessageSelector, ' to ', self externalName) ]]]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 7/29/2005 17:25'!
turnToward: aPlayer
	"Turn to face the given player, unless our positions coincide."

	|  aCostume myPosition itsPosition |
	(aPlayer == nil or: [aPlayer == self]) ifTrue: [^ self].
	aCostume _ self costume.
	aCostume isWorldMorph ifTrue: [^ self].
	(self overlaps: aPlayer) ifFalse:
		[((myPosition _ aCostume referencePosition) = (itsPosition _ aPlayer costume referencePosition))
			ifFalse: "avoid division by zero ;-("
				[self setHeading: (myPosition bearingToPoint: itsPosition)]]
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 1/6/2001 06:24'!
turn: degrees
	"Rotate the heading of the object by the given number of degrees"

	degrees ifNil: [^ self].
	degrees = 0 ifTrue: [^ self].
	self setHeading: (self getHeading + degrees asFloat) \\ 360.0
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 11:02'!
wrap
	"If the object has gone outside the bounds of its container, zap it over to the opposite edge of the container, providing a 'wrapping' impression "

	self costume wrap! !


!Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:41'!
asPoint

	^ self getX @ self getY! !

!Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:46'!
decr: aPlayer
	"Treating Players like vectors, subtract aPlayer from me"

	self setX: self getX - aPlayer asPoint x.
	self setY: self getY - aPlayer asPoint y.! !

!Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:51'!
dividedBy: aNumber
	"Treating Players like vectors, divide myself by aNumber"

	self setX: self getX / aNumber asPoint x.
	self setY: self getY / aNumber asPoint y.
! !

!Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:49'!
incr: aPlayer
	"Treating Players like vectors, add aPlayer to me"

	self setX: self getX + aPlayer asPoint x.
	self setY: self getY + aPlayer asPoint y.
! !

!Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:51'!
multBy: aNumber
	"Treating Players like vectors, scale myself by aNumber"

	self setX: self getX * aNumber asPoint x.
	self setY: self getY * aNumber asPoint y.
! !

!Player methodsFor: 'scripts-vector' stamp: 'nk 9/25/2003 11:46'!
* aNumber
	"Treating Players like vectors, return a new Player that is myself scaled by the number"

	| new |
	new _ costume usableSiblingInstance player.
	new setX: self getX * aNumber asPoint x.
	new setY: self getY * aNumber asPoint y.
	^ new
! !

!Player methodsFor: 'scripts-vector' stamp: 'nk 9/25/2003 11:46'!
+ aPlayer
	"Treating Players like vectors, add aPlayer to me and return a new Player"

	| new |
	new _ costume usableSiblingInstance player.
	new setX: self getX + aPlayer asPoint x.
	new setY: self getY + aPlayer asPoint y.
	^ new! !

!Player methodsFor: 'scripts-vector' stamp: 'nk 9/25/2003 11:46'!
- aPlayer
	"Treating Players like vectors, subtract aPlayer from me and return a new Player"

	| new |
	new _ costume usableSiblingInstance player.
	new setX: self getX - aPlayer asPoint x.
	new setY: self getY - aPlayer asPoint y.
	^ new! !

!Player methodsFor: 'scripts-vector' stamp: 'nk 9/25/2003 11:45'!
/ aNumber
	"Treating Players like vectors, return a new Player that is myself divided by the number"

	| new |
	new _ costume usableSiblingInstance player.
	new setX: self getX / aNumber asPoint x.
	new setY: self getY / aNumber asPoint y.
	^ new
! !


!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/7/2002 13:18'!
bookEmbodied
	"Answer the book embodied by the receiver's costume; usually this is directly the receiver's costume, but in case it is not, we look up the owner chain for one.  This allows page-number messages to be sent to a *page* of the stack, as Alan is wont to do, and have them still find their way to the right place"

	| aMorph |
	^ ((aMorph _ self costume renderedMorph) isKindOf: BookMorph)
		ifTrue:
			[aMorph]
		ifFalse:
			[aMorph ownerThatIsA: BookMorph]! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 12/2/2000 14:48'!
cameraPoint

	^ self costume cameraPoint! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 12/2/2000 14:49'!
cameraPoint: pt

	self costume cameraPoint: pt
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 07:08'!
getActWhen
	"Answer the #actWhen status of my costume, which is expected to be a button with an #actWhen protocol"

	^ costume renderedMorph actWhen! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2000 06:11'!
getAllButFirstCharacter 
	"Answer a string consisting of all but the first character in its string"

	^ costume renderedMorph getAllButFirstCharacter! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:25'!
getAllowEtoyUserCustomEvents
	"Answer whether to use the vector vocabulary."

	^ Preferences allowEtoyUserCustomEvents! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/19/2005 01:47'!
getAlpha
	"Answer the alpha of the color of my costume."

	^ self getColor alpha! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/24/1998 23:15'!
getAmount
	^ self getValueFromCostume: #amount! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 15:40'!
getAngle
	^ self getValueFromCostume: #angle! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'!
getBaseGraphic
	"Answer a form representing the receiver's base graphic"

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isSketchMorph)
		ifTrue:
			[aMorph baseGraphic]
		ifFalse:
			[aMorph imageForm]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:26'!
getBatchPenTrails
	"Answer whether to batch pen trails."

	^ Preferences batchPenTrails! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/5/2004 22:47'!
getBorderColor
	"Answer the border color of my costume"

	^ costume renderedMorph borderStyle color ifNil: [costume renderedMorph borderStyle baseColor]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/26/2001 10:02'!
getBorderStyle
	"Answer the border style"

	^ costume renderedMorph borderStyle style! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/26/2001 11:33'!
getBorderWidth
	"Answer the border width of my costume"

	^ costume renderedMorph borderStyle width! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:06'!
getBottom
	"Answer the bottom coordinate, in the cartesian sense (decreases towards bottom of screen)"

	^ self costume cartesianBoundsTopLeft y - self costume height! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 1/15/2001 17:45'!
getBrightnessUnder
	^ self costume colorUnder brightness * 100! !

!Player methodsFor: 'slot getters/setters' stamp: 'mir 9/4/2005 16:45'!
getButton1
	^ self getValueFromCostume: #button1! !

!Player methodsFor: 'slot getters/setters' stamp: 'mir 9/4/2005 16:46'!
getButton2
	^ self getValueFromCostume: #button2! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 12/2/2000 15:58'!
getCameraPoint

	^ self costume cameraPoint! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/4/2002 19:31'!
getCardNumber
	"Answer the current card number"

	| aStack |
	^ (aStack _ self stackEmbodied) cardNumberOf: aStack currentCard! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:31'!
getCellInset
	"Getter for costume's cellInset"

	^ costume cellInset! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/17/2003 18:09'!
getCharacterAtCursor
	"Answer the value of the text cursor"

	| aLoc aTextMorph aString |
	aLoc _ (aTextMorph _ self costume renderedMorph) cursor.
	aString _ aTextMorph text string.
	^ (aString at: aLoc ifAbsent: ['·']) asString! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:26'!
getCharacters
	"Answer the characters in my costume, likely a TextMorph"

	^ costume renderedMorph getCharacters! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 10:22'!
getClipSubmorphs
	"Getter for costume's clipSubmorphs"

	^ costume renderedMorph clipSubmorphs! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:34'!
getColor
	"Answer the color of my costume.  If it uses a gradient fill, answer the first color."

	| aFillStyle aMorph |
	^ (aFillStyle _ (aMorph _ self costume renderedMorph) fillStyle) isGradientFill
		ifTrue:
			[aFillStyle colorRamp first value]
		ifFalse:
			[aMorph color]! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 4/5/2005 11:08'!
getColorOpaque

	^ self getColor.
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/15/2000 13:30'!
getColorUnder
	"Answer the color beneath the center of the costume"

	^ self costume colorUnder! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'!
getCostume
	"Answer a form representing the receiver's primary graphic.  An earlier wording, disused but may persist in preexisting scripts."

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isSketchMorph)
		ifTrue:
			[aMorph form]
		ifFalse:
			[aMorph imageForm]! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'!
getCostumeAtCursor
	"Answer the form representing the object at the current cursor.  An earlier wording, disused but may persist in preexisting scripts"

	| anObject aMorph |
	
	anObject _ self getValueFromCostume: #valueAtCursor.
	^ anObject == 0  "weird return from GraphMorph"
		ifTrue:
			[ScriptingSystem formAtKey: #Paint]
		ifFalse:
			[((aMorph _ anObject renderedMorph) isSketchMorph)
				ifTrue:
					[aMorph form]
				ifFalse:
					[anObject imageForm]]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/17/2003 11:46'!
getCount
	"Answer the number of elements"

	^ self costume renderedMorph elementCount! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/7/2000 09:25'!
getCursor
	"Obtain the cursor setting from the receiver's costume"

	^ costume renderedMorph cursor
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/7/2000 09:25'!
getCursorWrapped
	"maintained for backward compatibility only, for preexisting etoys"

	^ self getCursor
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/10/2000 13:50'!
getDescending
	^  self getValueFromCostume: #descending! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/17/2001 15:11'!
getDistance
	"Answer distance from the origin to the objet's position"

	^ (self getX @ self getY) r! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:29'!
getDragEnabled
	"Getter for costume's dragEnabled"

	^ costume dragEnabled! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:32'!
getDropEnabled
	"Getter for costume's dropEnabled"

	^ costume dropEnabled! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/10/2005 04:22'!
getDropProducesWatcher
	"Answer the value of the dropProducesWatcher preference."

	^ Preferences dropProducesWatcher! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/12/2005 14:43'!
getDropShadow
	"Getter for costume's hasDropShadow"

	^ costume renderedMorph hasDropShadow! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:27'!
getEToyFriendly
	"Answer the value of the eToyFriendly preference."

	^ Preferences eToyFriendly! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:28'!
getFenceEnabled
	"Answer the value of the fenceEnabled preference."

	^ Preferences fenceEnabled! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:26'!
getFirstCharacter
	"Answer a string consisting of the first character in my costume, likely itself a TextMorph"

	^ costume renderedMorph getFirstCharacter! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/22/2003 13:43'!
getFirstElement
	"Answer a player representing the receiver's costume's first submorph"

	| itsMorphs |
	^(itsMorphs := costume submorphs) notEmpty 
		ifFalse: [costume presenter standardPlayer]
		ifTrue: [itsMorphs first assuredPlayer]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 07:09'!
getGetListSelector
	"Answer the selector used by my costume (a list) to obtain a fresh copy of its list"

	^ self costume renderedMorph getListSelector! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'!
getGraphic
	"Answer a form representing the receiver's primary graphic"

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isSketchMorph)
		ifTrue:
			[aMorph form]
		ifFalse:
			[aMorph isPlayfieldLike
				ifTrue:
					[aMorph backgroundForm]
				ifFalse:
					[aMorph imageForm]]! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'!
getGraphicAtCursor
	"Answer the form representing the object at the current cursor"

	| anObject aMorph |
	
	anObject _ self getValueFromCostume: #valueAtCursor.
	^ anObject == 0  "weird return from GraphMorph"
		ifTrue:
			[ScriptingSystem formAtKey: #Paint]
		ifFalse:
			[((aMorph _ anObject renderedMorph) isSketchMorph)
				ifTrue:
					[aMorph form]
				ifFalse:
					[aMorph isPlayfieldLike
						ifTrue:
							[aMorph backgroundForm]
						ifFalse:
							[aMorph imageForm]]]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2002 12:03'!
getHeading
	"Answer the heading of the object, *formerly* ;-) always given as a whole number"

	^ self getHeadingUnrounded "rounded"! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/17/2002 10:50'!
getHeadingTheta
	"Answer the angle, in degrees, between the positive x-axis and the receiver's heading vector"

	| aHeading excess normalized |
	aHeading _ self getHeadingUnrounded.
	excess _ aHeading - (aHeading rounded).

	normalized _ (450 - aHeading) \\ 360.
	^ normalized + excess! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 9/22/2000 13:42'!
getHeadingUnrounded
	^ self costume heading asSmallAngleDegrees! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:08'!
getHeight
	"Answer the height of the object"

	^ self costume height! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/6/2001 19:38'!
getHolder
	"Answer the player belonging to my costume's container"

	^ costume topRendererOrSelf owner topRendererOrSelf assuredPlayer! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:29'!
getHResizing
	"Getter for costume's hResizing"

	^ costume hResizing! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/1/2000 10:35'!
getIndexInOwner
	"Answer my costume's index in its owner"

	^ costume getIndexInOwner! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:39'!
getIsLocked
	"Answer whether the receiver's costume is locked"

	^ costume isLocked! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 07:24'!
getIsUnderMouse
	"Answer true or false, depending on whether the object currently is or is not under the mouse"

	costume isInWorld ifFalse: [^ false].
	^ costume containsPoint: (costume pointFromWorld: costume primaryHand lastEvent cursorPoint)! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:29'!
getKeepTickingWhilePainting
	"Answer the value of the keepTickingWhilePainting preference."

	^ Preferences keepTickingWhilePainting! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/7/2000 17:36'!
getKnobColor
	^ self getValueFromCostume: #sliderColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 07:10'!
getLabel
	"Answer the label of my costume"

	^ self costume renderedMorph label! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/10/2004 12:15'!
getLastCharacter
	"Answer my costume's last character."

	^ costume renderedMorph getLastCharacter! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 10/13/2004 11:30'!
getLastKeystroke
	"Answer the last keystroke fielded"

	^ self getValueFromCostume: #lastKeystroke! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/21/1999 11:46'!
getLastValue

	^ self getValueFromCostume: #lastValue
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:29'!
getLayoutInset
	"Getter for costume's layoutInset"

	^ costume layoutInset! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:09'!
getLeft
	"answer the left coordinate"

	^ self costume cartesianBoundsTopLeft x! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 15:41'!
getLeftRight
	^ self getValueFromCostume: #leftRight! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 3/10/2004 12:15'!
getLength
	"Answer the length of the object"

	| aLength cost |
	((cost  _ self costume) isLineMorph) "annoying special case"
		ifTrue:
			[^ cost unrotatedLength].
	aLength _ cost renderedMorph height.  "facing upward when unrotated"
	cost isRenderer
		ifTrue:
			[aLength _ aLength * cost scaleFactor].
	^ aLength! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:31'!
getListCentering
	"Getter for costume's listCentering"

	^ costume listCentering! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:30'!
getListDirection
	"Getter for costume's listDirection"

	^ costume listDirection! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 1/15/2001 17:45'!
getLuminanceUnder
	^ self costume colorUnder luminance * 100! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/6/2000 17:11'!
getMaxVal
	^  self getValueFromCostume: #maxVal! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/6/2000 17:11'!
getMinVal
	^  self getValueFromCostume: #minVal! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 2/12/2005 20:18'!
getMouseX
	^ self costume renderedMorph mouseX! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 2/12/2005 20:26'!
getMouseY
	^ self costume renderedMorph mouseY.
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/3/98 23:36'!
getName
	^ self externalName! !

!Player methodsFor: 'slot getters/setters' stamp: 'tak 1/26/2005 14:58'!
getNewClone
	"Answer a new player of the same class as the receiver, with a costume much like mine"

	| clone |
	clone _  costume usableSiblingInstance.
	costume pasteUpMorph ifNotNilDo: [:parent | parent addMorph: clone].
	^ clone player
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/1/2000 10:36'!
getNumberAtCursor
	"Answer the number borne by the object at my costume's current cursor position"

	| renderedMorph aCostume |
	aCostume _ self costume.
	((renderedMorph _ aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor getNumericValue]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:39'!
getNumericValue
	"Answer the numeric value contained in my costume"

	^ costume renderedMorph getNumericValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:43'!
getOffsetX

	^ self costume offsetX! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:43'!
getOffsetY

	^ self costume offsetY! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 13:53'!
getOliveHandleForScriptedObjects

	"Answer the value of the oliveHandleForScriptedObjects preference."

	^ Preferences oliveHandleForScriptedObjects! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/7/2002 13:31'!
getPageNumber
	"Answer the current page number of my book"

	| aBook |
	^ (aBook _ self bookEmbodied) pageNumberOf: aBook currentPage! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2000 10:10'!
getPlayerAtCursor
	^ self getValueAtCursor! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/15/2004 21:11'!
getPosition
	"Answer the numeric value contained in my costume"
	^ costume renderedMorph getPosition! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 08:32'!
getRadialGradientFill
	"Geter for costume's useGradientFill"

	| aStyle |
	^ (aStyle _ costume renderedMorph fillStyle) isGradientFill and:
		[aStyle isRadialFill]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/15/2001 16:34'!
getResistsRemoval
	"Answer whether the receiver is marked to resist removal"

	^ costume resistsRemoval! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:09'!
getRight
	"Answer the coordinate of the right edge of the object"

	^ self costume cartesianBoundsTopLeft x + self costume width! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/14/2004 21:37'!
getRotationStyle
	"Answer the symbol representing the rotation style"

	^ (#(rotate #'do not rotate' #'flip left right' #'flip up down') at:
		(#(normal none leftRight upDown ) indexOf: costume renderedMorph rotationStyle))! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/22/1999 15:45'!
getSampleAtCursor
	"Note: Performance hacked to allow real-time sound. Assumes costume is a GraphMorph."

	^ costume renderedMorph interpolatedValueAtCursor
! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 1/15/2001 17:45'!
getSaturationUnder
	^ self costume colorUnder saturation * 100! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:35'!
getScale

	^ self costume scale! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/15/2002 02:37'!
getScaleFactor
	"Answer the scale factor of the object"

	^ self costume scaleFactor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:12'!
getSecondColor
	"Getter for costume's second color, if it's using gradient fill; sonst answers white."

	| aFillStyle |
	^ (aFillStyle _ costume renderedMorph fillStyle) isGradientFill
		ifTrue:
			[aFillStyle  colorRamp last value]
		ifFalse:
			[Color white]! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/14/2005 10:38'!
getShadowColor
	"Getter for costume's shadowColor"

	^ costume renderedMorph shadowColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/21/98 23:23'!
getSpeed
	"If user defines a speed slot, it will override this.  This provides a backstop value for use with moveToward:, etc"

	^ 5 ! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:30'!
getSticky
	"Getter for costume's isSticky"

	^ costume isSticky! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/18/2003 02:20'!
getStringContents
	"Answer the String contents"

	^ self costume renderedMorph getCharacters! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 3/8/2004 21:40'!
getSubtitlesFileName
	"Answer the subtitlesFileName in my costume"
	^ costume renderedMorph getSubtitlesFileName! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/17/2001 15:10'!
getTheta
	"Answer the angle between the positive x-axis and the line connecting the origin and the object's position"

	^ (self getX @ self getY) degrees! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:10'!
getTop
	"Answer the coordinate of the topmost point of the object, using cartesian sense"

	^ self costume cartesianBoundsTopLeft y! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/12/2000 11:51'!
getTruncate
	^  self getValueFromCostume: #truncate! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 15:42'!
getUpDown
	^ self getValueFromCostume: #upDown! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 08:33'!
getUseGradientFill
	"Geter for costume's useGradientFill"

	^ costume renderedMorph fillStyle isGradientFill! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/10/2005 03:36'!
getUseVectorVocabulary
	"Answer whether to use the vector vocabulary."

	^ Preferences useVectorVocabulary! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 15:43'!
getValueAtCursor
	| anObject |
	anObject _ self getValueFromCostume: #valueAtCursor.
	^ anObject == 0  "weird return from GraphMorph"
		ifTrue:
			[nil]
		ifFalse:
			[anObject assuredPlayer]! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 3/8/2004 18:26'!
getVideoFileName
	"Answer the videoFileName in my costume"
	^ costume renderedMorph getVideoFileName! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 07:12'!
getViewingByIcon
	"Answer whether my costume is currently viewing by icon"

	^ costume renderedMorph viewingNormally! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/15/2004 21:13'!
getVolume
	"Answer the numeric value contained in my costume"
	^ costume renderedMorph getVolume! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:29'!
getVResizing
	"Getter for costume's vResizing"

	^ costume vResizing! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 3/10/2004 12:15'!
getWidth
	"Answer the width of the object"

	| aWidth cost |
	((cost _ self costume) isLineMorph) "annoying special case"
		ifTrue:
			[^ cost unrotatedWidth].
	aWidth _ cost renderedMorph width.  "facing upward when unrotated"

	cost isRenderer
		ifTrue:
			[aWidth _ aWidth * cost scaleFactor].
	^ aWidth! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:27'!
getWrapDirection
	"Getter for costume's wrapDirection"

	^ costume wrapDirection! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 17:23'!
getX
		"emergency patch; unclear why not needed in getY; in any case, have
		 removed the getX/getY retrievals from the viewer in 2.0-final anyway"
	| aCostume |
	(aCostume _ self costume) isInWorld ifFalse: [^ 100].
	^ aCostume x! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 07:22'!
getY
	"Answer the y coordinate of the object, relative to its container"

	^ self costume y! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/8/2000 12:21'!
handTheUserACopy
	"Called from the user-interface: hand the user a copy"

	^ costume currentHand attachMorph: self getNewClone costume! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/25/2001 03:38'!
setActWhen: val
	"Tell the receiver's costume (hopefully a button!!) to set its actWhen parameter as indicated"

	costume renderedMorph actWhen: val! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:29'!
setAllButFirstCharacter: aString
	"Set my costume's all-but-first characters to be aString"

	costume renderedMorph setAllButFirstCharacter: aString! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:25'!
setAllowEtoyUserCustomEvents: aValue
	"Set the allowEtoyUserCustomEvents preferences"

	Preferences setPreference: #allowEtoyUserCustomEvents toValue: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/19/2005 01:49'!
setAlpha: alpha
	"Set the alpha of the color of my costume."

	| adjusted |
	adjusted _ (alpha max: 0.0) min: 1.0.
	^ self setColor: (self getColor alpha: adjusted)! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:02'!
setBaseGraphic: aGraphic
	"Set the base graphic"

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isSketchMorph)
		ifTrue:
			[aMorph baseGraphic: aGraphic]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:26'!
setBatchPenTrails: aValue
	"Set the batchPenTrails preference."

	Preferences setPreference: #batchPenTrails toValue: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 4/13/2004 18:55'!
setBorderColor: aColor 
	"Set the border color as requested"

	costume renderedMorph borderColor: aColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/26/2001 16:20'!
setBorderStyle: aSymbol
	"Set the border style of my costume"

	costume renderedMorph setBorderStyle: aSymbol! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 4/13/2004 18:55'!
setBorderWidth: aWidth 
	"Set the border width to the given number"
	costume renderedMorph borderWidth: aWidth! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:32'!
setBottom: w
	"Set the bottom coordinate (cartesian sense) of the object as requested"

	| topLeftNow cost |
	cost _ self costume.
	cost isWorldMorph ifTrue: [^ self].
	topLeftNow _ cost cartesianBoundsTopLeft.
	^ cost bottom: cost top + topLeftNow y - w
! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 12/2/2000 15:58'!
setCameraPoint: pt

	self costume cameraPoint: pt
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/4/2002 19:32'!
setCardNumber: aNumber
	"Go to the given card number"

	self stackEmbodied goToCardNumber: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:34'!
setCellInset: aValue
	"Setter for costume's cellInset"

	costume cellInset: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/17/2003 17:35'!
setCharacterAtCursor: aCharOrString
	"Insert the given character at my cursor position"

	| aLoc aTextMorph aString charToUse |
	aLoc _ (aTextMorph _ self costume renderedMorph) cursor.
	charToUse _ (aString _ aCharOrString asString) size > 0
		ifTrue:
			[aString first]
		ifFalse:
			['·'].
	aTextMorph paragraph replaceFrom: aLoc to: aLoc with: charToUse asString asText displaying: true.
	aTextMorph updateFromParagraph  ! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:28'!
setCharacters: amt
	"Set my costume's characters as indicated"

	costume renderedMorph setCharacters: amt! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 10:23'!
setClipSubmorphs: aBoolean
	"Setter for costume's clipSubmorphs"

	costume renderedMorph clipSubmorphs: aBoolean.
	costume renderedMorph changed! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 5/4/2001 06:06'!
setColorUnder: aValue
	"Provide a soft landing for old readouts that may try to send this"! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:27'!
setColor: aColor
	"Set the color of the graphic as requested"

	| aFillStyle aMorph |
	(aFillStyle _ (aMorph _ self costume renderedMorph) fillStyle) isGradientFill
		ifTrue:
			[aFillStyle firstColor: aColor forMorph: aMorph hand: nil]
		ifFalse:
			[aMorph color: aColor]! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:02'!
setCostume: aForm
	"Set the receiver's graphic as indicated.  An earlier wording, disused but may persist in preexisting scripts."

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isSketchMorph)
		ifTrue:
			[aMorph form: aForm]
		ifFalse:
			["what to do?"]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/7/2000 09:29'!
setCursorWrapped: aNumber
	"maintained for backward compatibility with existing etoys"

	^ self setCursor: aNumber
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/8/2000 11:16'!
setCursor: aNumber
	"Set my costume's cursor to the given number"

	costume renderedMorph cursorWrapped: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/10/2000 13:52'!
setDescending: aBoolean
	self setCostumeSlot: #descending: toValue: aBoolean! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:35'!
setDistance: aDistance
	"Set the object's distance from the origin to be as indicated, preserving its angle."

	| cost |
	cost _ self costume.
	cost isWorldMorph ifTrue: [^ self].
	cost cartesianXY: (Point r: aDistance degrees:  self getTheta)! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:32'!
setDragEnabled: aValue
	"Setter for costume's dragEnabled"

	costume dragEnabled: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:34'!
setDropEnabled: aValue
	"Setter for costume's dropEnabled"

	costume dropEnabled: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/10/2005 04:22'!
setDropProducesWatcher: aValue
	"Set the dropProducesWatcher preferences"

	Preferences setPreference: #dropProducesWatcher toValue: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/15/2005 18:23'!
setDropShadow: aValue
	"Setter for costume's dropShadow"

	| aMorph |
	(aMorph _ costume renderedMorph) hasDropShadow ~~ aValue ifTrue: [aMorph toggleDropShadow]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:27'!
setEToyFriendly: aValue
	"Set the eToyFriendly preference."

	Preferences setPreference: #eToyFriendly toValue: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:28'!
setFenceEnabled: aValue
	"Set the fenceEnabled preference."

	Preferences setPreference: #fenceEnabled toValue: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:29'!
setFirstCharacter: aChar
	"Set my costume's first character to the indicated one"

	costume renderedMorph setFirstCharacter: aChar! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/22/2003 13:45'!
setFirstElement: aPlayer 
	"Caution - this is a replacement operation!!  Replace the receiver's costume's first element with the morph represented by aPlayer"

	| aCostume |
	(aPlayer == self or: [(aCostume := self costume) submorphs isEmpty]) 
		ifTrue: [^self].
	costume replaceSubmorph: aCostume submorphs first by: aPlayer costume! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 11:18'!
setGetListSelector: sel
	"Set the receiver's get-list-selector as indicated."

	costume renderedMorph getListSelector: sel
	! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:02'!
setGraphic: aForm
	"Set the receiver's graphic as indicated"

	| aMorph |
	^ ((aMorph _ costume renderedMorph) isSketchMorph)
		ifTrue:
			[aMorph form: aForm]
		ifFalse:
			[aMorph isPlayfieldLike
				ifTrue: 
					[aMorph backgroundForm: aForm]
				ifFalse:
					["what to do?"]]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/17/2002 10:17'!
setHeadingTheta: anAngle
	"Set the heading theta"

	self setHeading: (450 - anAngle)! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:34'!
setHeading: newHeading
	"Set the heading as indicated"

	| aCostume |
	aCostume _ self costume.
	aCostume isWorldMorph ifTrue: [^ self].
	(newHeading closeTo: aCostume heading) ifTrue: [^ self].
	aCostume heading: newHeading.
	aCostume _ self costume. "in case we just got flexed for no apparent reason"
	(aCostume isFlexMorph and:[aCostume hasNoScaleOrRotation]) 
		ifTrue:	[aCostume removeFlexShell]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:12'!
setHeight: w
	"Set the height of the object as indicated"

	^ self costume height: w! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 09:55'!
setHResizing: aValue
	"Setter for costume's hResizing"

	costume hResizing: aValue asSymbol! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/8/2000 11:18'!
setIndexInOwner: amt
	"Move my costume to a different z-position within its container.  This is primarily in service of auto-line-layout views in which the z-ordering determines the left/right and top/bottom placement."

	costume setIndexInOwner: amt! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:40'!
setIsLocked: aBoolean
	"Set my costume's isLocked"

	costume lock: aBoolean! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 01:29'!
setKeepTickingWhilePainting: aValue
	"Set the keepTickingWhilePainting preferences"

	Preferences setPreference: #keepTickingWhilePainting toValue: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/7/2000 17:36'!
setKnobColor: aColor
	self setCostumeSlot: #sliderColor: toValue: aColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 08:33'!
setLabel: aLab
	"Set the receiver's costume's label as specified"

	costume renderedMorph label: aLab! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/10/2004 00:54'!
setLastCharacter: aChar
	"Set my costume's last character to the indicated value, usually a string of length one."

	costume renderedMorph setLastCharacter: aChar! !

!Player methodsFor: 'slot getters/setters' stamp: 'nk 10/13/2004 11:30'!
setLastKeystroke: aString
	"Set the last keystroke fielded"

	self setCostumeSlot: #lastKeystroke: toValue: aString! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/21/1999 11:46'!
setLastValue: aNumber

	self setCostumeSlot: #lastValue: toValue: aNumber.
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:34'!
setLayoutInset: aValue
	"Setter for costume's layoutInset"

	costume layoutInset: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:32'!
setLeft: w
	"Set the object's left coordinate as indicated"

	| topLeftNow cost |
	cost _ self costume.
	cost isWorldMorph ifTrue: [^ self].
	topLeftNow _ cost cartesianBoundsTopLeft.
	^ cost left: cost left - topLeftNow x + w
! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 10/23/2004 14:44'!
setLength: aLength
	"Set the length of the receiver."

	| cost lengthToUse |

	self hasCostumeThatIsAWorld ifTrue:[^ self].

	((cost _ self costume) isLineMorph)
		ifTrue:
			[^ cost unrotatedLength: aLength].
	lengthToUse _ cost isRenderer
		ifTrue:
			[aLength / cost scaleFactor]
		ifFalse:
			[aLength].
	cost renderedMorph height: lengthToUse! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:33'!
setListCentering: val
	"Setter for costume's listCentering"

	costume listCentering: val! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:33'!
setListDirection: aValue
	"Setter for costume's listDirection"

	costume listDirection: aValue asSymbol! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/6/2000 17:14'!
setMaxVal: aNumber
	self setCostumeSlot: #setMaxVal: toValue: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/6/2000 17:16'!
setMinVal: aNumber
	self setCostumeSlot: #setMinVal: toValue: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 17:13'!
setName: aName
	^ self costume renameTo: aName! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/1/2000 10:37'!
setNumberAtCursor: aNumber
	"Place the given number into the morph residing at my costume's current cursor position"

	| renderedMorph aCostume |
	aCostume _ self costume.
	((renderedMorph _ aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor setNumericValue: aNumber]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2000 06:12'!
setNumericValue: amt
	"Set the receiver's numeric value to the amount.  This is passed on to the costume"

	costume renderedMorph setNumericValue: amt! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:44'!
setOffsetX: aNumber

	^ self costume offsetX: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:56'!
setOffsetY: aNumber

	^ self costume offsetY: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/3/2005 13:54'!
setOliveHandleForScriptedObjects: aBoolean
	"Set the value of the oliveHandleForScriptedObjects preference."

	Preferences setPreference: #oliveHandleForScriptedObjects toValue: aBoolean! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/7/2002 13:34'!
setPageNumber: aNumber
	"Set the page number of my book as indicated."

	self bookEmbodied goToPage: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/15/2004 21:11'!
setPosition: amt 
	"Set the receiver's numeric value to the amount. This is passed 
	on to the costume"
	costume renderedMorph setPosition: amt! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 08:51'!
setRadialGradientFill: aBoolean
	"Setter for costume's radialGradientFill"

	| aStyle |
	(aStyle _ costume renderedMorph fillStyle) isGradientFill
		ifTrue:
			[aStyle isRadialFill ~~ aBoolean ifTrue:
				[aStyle radial: aBoolean.
				costume renderedMorph changed]]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/15/2001 16:34'!
setResistsRemoval: aBoolean
	"Set the resistsRemoval property"

	^ costume resistsRemoval: aBoolean! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:32'!
setRight: w
	"Set the right coordinate to the given value"

	| topLeftNow cost |
	cost _ self costume.
	cost isWorldMorph ifTrue: [^ self].
	topLeftNow _ cost cartesianBoundsTopLeft.
	^ cost right: cost left - topLeftNow x + w
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/14/2004 21:35'!
setRotationStyle: aStyleSymbol
	"Set the rotation style to the indicated symbol; the external symbols seen are different, as you'll observe..."

	costume renderedMorph rotationStyle: 
		(#(normal none leftRight upDown ) at:
		(#(rotate #'do not rotate' #'flip left right' #'flip up down') indexOf: aStyleSymbol))! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/22/1999 15:46'!
setSampleAtCursor: aNumber
	"Note: Performance hacked to allow real-time sound. Assumes costume is a GraphMorph."

	self setCostumeSlot: #valueAtCursor: toValue: aNumber.
! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:33'!
setScaleFactor: aNumber
	"Set the scale factor to be the given value"

	| cost |
	cost _ self costume.
	cost isWorldMorph ifTrue: [^ self].
	cost scaleFactor: ((aNumber asFloat max: 0.1) min: 10.0)! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:35'!
setScale: aNumber

	^ self costume scale: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/9/2001 23:55'!
setSecondColor: aColor
	"Setter for costume's second color, if it's using gradient fill; if not, does nothing"

	| aFillStyle aMorph |
	^ (aFillStyle _ (aMorph _ costume renderedMorph) fillStyle) isGradientFill
		ifTrue:
			[aFillStyle lastColor: aColor forMorph: aMorph hand: ActiveHand]! !

!Player methodsFor: 'slot getters/setters' stamp: 'tak 3/15/2005 11:17'!
setShadowColor: aValue
	"Setter for costume's shadowColor"

	costume  renderedMorph shadowColor: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:33'!
setSticky: val
	"Setter for costume's sticky"

	costume sticky: val! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 3/8/2004 21:40'!
setSubtitlesFileName: aString 
	"Set my costume's subtitlesFileName as indicated"
	costume renderedMorph setSubtitlesFileName: aString! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:35'!
setTheta: aTheta
	"Set the object's position such that its rho is unchanged but the angle between the positive x-axis and the vector connecting the origin and the object's position is as given."

	| cost |
	cost _ self costume.
	cost isWorldMorph ifTrue: [^ self].
	cost cartesianXY: (Point r: self getDistance degrees: aTheta)! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:32'!
setTop: w
	"Set the top coordinate as indicated, using cartesian sense"

	| topLeftNow cost |
	cost _ self costume.
	cost isWorldMorph ifTrue: [^ self].
	topLeftNow _ cost cartesianBoundsTopLeft.
	^ cost top: cost top + topLeftNow y - w! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/12/2000 11:52'!
setTruncate: aBoolean
	self setCostumeSlot: #truncate: toValue: aBoolean! !

!Player methodsFor: 'slot getters/setters' stamp: 'yo 3/14/2005 13:45'!
setUseGradientFill: aBoolean
	"Setter for costume's useGradientFill"

	costume renderedMorph fillStyle isGradientFill
		ifTrue:
			[aBoolean ifFalse: [costume renderedMorph useSolidFill]]
		ifFalse:
			[aBoolean ifTrue: [costume renderedMorph useGradientFill]]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 7/10/2005 03:41'!
setUseVectorVocabulary: aValue
	"Set the useVectorVocabulary preferences"

	Preferences setPreference: #useVectorVocabulary toValue: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 17:15'!
setValueAtCursor: aPlayer
	| renderedMorph aCostume |
	aCostume _ self costume.
	((renderedMorph _ aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor: aPlayer costume].

	(aCostume respondsTo: #valueAtCursor:) ifTrue: [aCostume valueAtCursor: aPlayer costume]! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 3/8/2004 18:24'!
setVideoFileName: aString 
	"Set my costume's videoFileName as indicated"
	costume renderedMorph setVideoFileName: aString! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 08:35'!
setViewingByIcon: aVal
	"Set the user's  costume's view-by-icon attribute as indictated"

	(aVal == false)
		ifTrue:
			["problematical - we always need *some* view"
			costume renderedMorph viewByName]
		ifFalse:
			[costume renderedMorph viewByIcon]! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/15/2004 21:15'!
setVolume: amt 
	"Set the receiver's numeric value to the amount. This is passed 
	on to the costume"
	costume renderedMorph setVolume: amt! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 09:55'!
setVResizing: aValue
	"Setter for costume's vResizing"

	costume vResizing: aValue asSymbol! !

!Player methodsFor: 'slot getters/setters' stamp: 'dgd 4/4/2006 16:32'!
setWidth: aWidth 
	"Set the width"
	
	| cost widthToUse |

	self hasCostumeThatIsAWorld
		ifTrue: [^ self].

	(cost := self costume) isLineMorph
		ifTrue: [^ cost unrotatedWidth: aWidth].

	widthToUse := cost isRenderer
				ifTrue: [aWidth / cost scaleFactor]
				ifFalse: [aWidth].

	cost renderedMorph width: widthToUse.
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:32'!
setWrapDirection: aValue
	"Setter for costume's wrapDirection"

	costume wrapDirection: aValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'di 9/12/2001 20:49'!
setX: val
	"Set the x coordinate as indicated"

	| aCostume |
	(aCostume _ self costume) isInWorld ifFalse: [^ self].
	aCostume isWorldOrHandMorph ifTrue: [^ self].
	aCostume owner isHandMorph ifTrue: [^ self].
	^ aCostume x: val! !

!Player methodsFor: 'slot getters/setters' stamp: 'di 9/12/2001 20:51'!
setY: val
	"Set the y coordinate as indicated"

	| aCostume |
	(aCostume _ self costume) isInWorld ifFalse: [^ self].
	aCostume isWorldOrHandMorph ifTrue: [^ self].
	aCostume owner isHandMorph ifTrue: [^ self].
	^ aCostume y: val! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/4/2002 19:31'!
stackEmbodied
	"Answer the stack embodied by the receiver's costume; usually this is directly the receiver's costume, but in case it is not, we look up the owner chain for one.  This allows card-number messages to be sent to a *page* of the stack, as Alan is wont to do, and have them still find their way to the right place"

	| aMorph |
	^ ((aMorph _ self costume renderedMorph) isKindOf: StackMorph)
		ifTrue:
			[aMorph]
		ifFalse:
			[aMorph ownerThatIsA: StackMorph]! !


!Player methodsFor: 'slots-assignment' stamp: 'sw 1/31/98 00:06'!
assignDecrGetter: getterSelector setter: setterSelector amt: aDecrement
	self perform: setterSelector with:
		((self perform: getterSelector) - aDecrement)! !

!Player methodsFor: 'slots-assignment' stamp: 'sw 1/31/98 00:07'!
assignGetter: getterSelector setter: setterSelector amt: amt
	self perform: setterSelector with: amt! !

!Player methodsFor: 'slots-assignment' stamp: 'sw 1/31/98 00:07'!
assignIncrGetter: getterSelector setter: setterSelector amt: anIncrement
	self perform: setterSelector with:
		((self perform: getterSelector) + anIncrement)! !

!Player methodsFor: 'slots-assignment' stamp: 'sw 1/31/98 00:06'!
assignMultGetter: getterSelector setter: setterSelector amt: aMultiplier
	self perform: setterSelector with:
		((self perform: getterSelector) * aMultiplier)! !


!Player methodsFor: 'slots-kernel' stamp: 'sw 12/6/2001 21:57'!
absorbBackgroundDataFrom: aLine forInstanceVariables: slotNames
	"Fill my background fields from the substrings in a tab-delimited line of data.  At the moment this only really cateres to string-valued items"

	slotNames doWithIndex:
		[:aSlotName :anIndex |
			aLine do:
				[:aValue |
					self instVarNamed: aSlotName put: aValue] toFieldNumber: anIndex]! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 3/3/2004 23:58'!
categories
	"Answer a list of categories appropriate to the the receiver and its costumes"

	| aList |
	(self hasCostumeThatIsAWorld)
		ifTrue:	[^ self categoriesForWorld].

	aList _ OrderedCollection new.
	self slotNames notEmpty ifTrue:
		[aList add: ScriptingSystem nameForInstanceVariablesCategory].
	aList addAll: costume categoriesForViewer.
	aList remove: ScriptingSystem nameForScriptsCategory ifAbsent: [].
	aList add: ScriptingSystem nameForScriptsCategory after: aList first.
	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 3/3/2004 00:00'!
categoriesForVocabulary: aVocabulary
	"Answer a list of categories appropriate to the receiver and its costumes, in the given Vocabulary"

	| aList |
	self hasCostumeThatIsAWorld
		ifTrue:
			[aList _ self categoriesForWorld]
		ifFalse:
			[aList _ OrderedCollection new.
			self slotNames ifNotEmpty:
				[aList add: ScriptingSystem nameForInstanceVariablesCategory].
			aList addAll: costume categoriesForViewer].
	aVocabulary addCustomCategoriesTo: aList.
	aList remove: ScriptingSystem nameForScriptsCategory ifAbsent: [].
	aList add: ScriptingSystem nameForScriptsCategory after: aList first.
	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'dgd 4/4/2006 16:21'!
categoriesForWorld
	"Answer the list of categories given that the receiver is the Player representing a World"

	| aList |
	aList _ #(#'color & border' #geometry #'pen trails' playfield collections #'stack navigation') asOrderedCollection.
	aList addFirst: ScriptingSystem nameForScriptsCategory.
	aList addFirst: ScriptingSystem nameForInstanceVariablesCategory.
	aList add: #input.
	Preferences eToyFriendly ifFalse:
		[aList add: #preferences].

	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'yo 8/1/2004 02:04'!
methodInterfacesForInstanceVariablesCategoryIn: aVocabulary
	"Return a collection of methodInterfaces for the instance-variables category.  The vocabulary parameter, at present anyway, is not used."

	| aList anInterface itsSlotName |
	aList _ OrderedCollection new.
	self slotInfo associationsDo:
		[:assoc |
			anInterface _ MethodInterface new.
			itsSlotName _ assoc key.
			anInterface
				wording: itsSlotName;
				helpMessage: 'a variable defined by this object' translated.

			anInterface selector: (Utilities getterSelectorFor: itsSlotName) type: assoc value type setter: (Utilities setterSelectorFor: itsSlotName).
			anInterface setToRefetch.
			aList add: anInterface].
	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 2/15/98 13:08'!
slotNames
	^ self class instVarNames  "Could also get it from the slotInfo dictionary"
			! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 8/3/2005 14:21'!
typeForSlotWithGetter: aGetter
	"Answer the data type for values of the instance variable of the given name"

	| getter inherentSelector |
	(#(color:sees: seesColor: touchesA: overlaps: overlapsAny:) includes: aGetter) ifTrue: [^ #Boolean].
	(#(+ * - /) includes: aGetter) ifTrue: [^ #Player].  "weird vector stuff"
  	"Annoying special cases"

	inherentSelector _ Utilities inherentSelectorForGetter: aGetter.
	(self slotInfo includesKey: inherentSelector) ifTrue: [^ (self slotInfoAt: inherentSelector) type].
	getter _ (aGetter beginsWith: 'get')
		ifTrue:
			[aGetter]
		ifFalse:
			[Utilities getterSelectorFor: aGetter].
	^ (Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aGetter]) resultType! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 5/29/2001 13:57'!
typeForSlot: aSlotName
	"Answer the data type for values of the instance variable of the given name"

	| getter |
	(self slotInfo includesKey: aSlotName) ifTrue: [^ (self slotInfoAt: aSlotName) type].
	getter _ (aSlotName beginsWith: 'get')
		ifTrue:
			[aSlotName]
		ifFalse:
			[Utilities getterSelectorFor: aSlotName].
	^ (self currentVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aSlotName]) resultType! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 5/24/2001 14:29'!
typeForSlot: aSlotName vocabulary: aVocabulary
	"Answer the data type for values of the instance variable of the given name.  Presently has no senders but retained for a while..."

	| getter inherentSelector |
	inherentSelector _ Utilities inherentSelectorForGetter: aSlotName.
	(self slotInfo includesKey: inherentSelector) ifTrue: [^ (self slotInfoAt: inherentSelector) type].
	getter _ (aSlotName beginsWith: 'get')
		ifTrue:
			[aSlotName]
		ifFalse:
			[Utilities getterSelectorFor: aSlotName].
	^ (aVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aSlotName]) resultType! !

!Player methodsFor: 'slots-kernel' stamp: 'dgd 4/4/2006 16:35'!
usableMethodInterfacesIn: methodInterfaceList
	"Filter the list given by methodInterfaceList, to remove items inappropriate to the receiver"

	self hasCostumeThatIsAWorld ifTrue:
		[^ methodInterfaceList select: [:anInterface |
			#(append: prepend: beep: clearTurtleTrails doScript: getColor "color" getCursor "cursor" deleteCard doMenuItem emptyScript firstPage goToFirstCardInBackground goToFirstCardOfStack goToLastCardInBackground goToLastCardOfStack goToNextCardInStack goToPreviousCardInStack initiatePainting insertCard  liftAllPens lowerAllPens trailStyleForAllPens: arrowheadsOnAllPens noArrowheadsOnAllPens getMouseX getMouseY "mouseX mouseY" pauseScript: reverse roundUpStrays shuffleContents startScript: stopScript: unhideHiddenObjects getValueAtCursor "valueAtCursor"
startAll: pauseAll: stopAll:  
viewAllMessengers clobberAllMessengers openAllScriptsTool handScriptControlButtons viewAllReferencedObjects jumpToProject: #getLength #getWidth )

includes: anInterface selector]].

	self hasAnyBorderedCostumes ifTrue: [^ methodInterfaceList].

	^ self hasOnlySketchCostumes
		ifTrue:
			[methodInterfaceList select: [:anInterface | (#(getColor getAlpha getSecondColor getBorderColor getBorderWidth getBorderStyle getRoundedCorners getUseGradientFill getRadialGradientFill ) includes: anInterface selector) not]]
		ifFalse:
			[methodInterfaceList select: [:anInterface | (#(getBorderColor getBorderWidth) includes: anInterface selector) not]]! !


!Player methodsFor: 'slots-user' stamp: 'yo 9/24/2004 09:09'!
addInstanceVariable
	"Offer the user the opportunity to add an instance variable, and if he goes through with it, actually add it."

	| itsName initialValue typeChosen usedNames initialAnswer setterSelector originalString |
	usedNames _ self class instVarNames.

	initialAnswer _ Utilities keyLike: ('var' translated, (usedNames size + 1) asString)  satisfying: [:aKey | (usedNames includes: aKey) not].

	originalString _ FillInTheBlank request: 'name for new variable: ' translated initialAnswer: initialAnswer.
	originalString isEmptyOrNil ifTrue: [^ self].
	itsName _ ScriptingSystem acceptableSlotNameFrom: originalString forSlotCurrentlyNamed: nil asSlotNameIn: self world: self costume world.

 	itsName size == 0 ifTrue: [^ self].	
	self assureUniClass.
	typeChosen _ self initialTypeForSlotNamed: itsName.
	self slotInfo at: itsName put: (SlotInformation new initialize type: typeChosen).
	initialValue _ self initialValueForSlotOfType: typeChosen.
	self addInstanceVarNamed: itsName withValue: initialValue.
	self compileInstVarAccessorsFor: itsName.
	setterSelector _ Utilities setterSelectorFor: itsName.
	((self class allSubInstances copyWithout: self) reject: [:e | e isSequentialStub]) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory! !

!Player methodsFor: 'slots-user' stamp: 'yo 6/5/2004 18:49'!
addInstanceVariable2Named: nameSymbol type: typeChosen value: aValue
	"Add an instance variable of the given name and type, and initialize it to have the given value"

	| initialValue setterSelector |
	self assureUniClass.
	self slotInfo at: nameSymbol put: (SlotInformation new initialize type: typeChosen).
	initialValue _ aValue.
	self addInstanceVarNamed: nameSymbol withValue: aValue.
	self class compileAccessorsFor: nameSymbol.
	setterSelector _ Utilities setterSelectorFor: nameSymbol.
	(self class allSubInstances copyWithout: self) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: #'instance variables'
! !

!Player methodsFor: 'slots-user' stamp: 'md 3/1/2006 09:15'!
addInstanceVariableNamed: nameSymbol type: typeChosen value: aValue
	"Add an instance variable of the given name and type, and initialize it to have the given value"

	| initialValue setterSelector |
	self assureUniClass.
	self slotInfo at: nameSymbol put: (SlotInformation new type: typeChosen).
	initialValue _ self initialValueForSlotOfType: typeChosen.
	self addInstanceVarNamed: nameSymbol withValue: aValue.
	self class compileAccessorsFor: nameSymbol.
	setterSelector _ Utilities setterSelectorFor: nameSymbol.
	(self class allSubInstances copyWithout: self) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory
! !

!Player methodsFor: 'slots-user' stamp: 'NS 1/28/2004 14:47'!
addSpecialSetter: selector
	| instVar code |
	"For the special setters, fooIncreaseBy:, fooDecreaseBy:, fooMultiplyBy:, add a method that does them."

 	self assureUniClass.
	instVar _ (selector allButLast: 11) asLowercase.  "all three are 11 long!!"
	(self respondsTo: ('set', instVar capitalized, ':') asSymbol) ifFalse: [^ false].
	code _ String streamContents: [:strm |
		strm nextPutAll: selector, ' amount'; crtab.
		strm nextPutAll: 'self set', instVar capitalized, ': (self get', instVar capitalized; space.
		(selector endsWith: 'IncreaseBy:') ifTrue: [strm nextPut: $+].
		(selector endsWith: 'DecreaseBy:') ifTrue: [strm nextPut: $-].
		(selector endsWith: 'MultiplyBy:') ifTrue: [strm nextPut: $*].
		strm nextPutAll: ' amount)'].

	self class compileSilently: code classified: 'access' notifying: nil.
	^ true
! !

!Player methodsFor: 'slots-user' stamp: 'sw 1/6/2005 01:32'!
allPossibleWatchersFromWorld
	"Answer a list of all UpdatingStringMorphs, PlayerReferenceReadouts, ThumbnailMorphs, and  UpdatingReferenceMorphs in the Active world and its hidden book pages, etc., which have me or any of my siblings as targets"

	| a |
	a _ IdentitySet new: 400.
	ActiveWorld allMorphsAndBookPagesInto: a.
	^ a select: [:e | e isEtoyReadout and: [e target class == self class]]! !

!Player methodsFor: 'slots-user' stamp: 'yo 9/20/2004 10:36'!
basicCompileInstVarAccessorsFor: varName
	self class compileInstVarAccessorsFor: varName! !

!Player methodsFor: 'slots-user' stamp: 'yo 9/20/2004 12:13'!
basicRemoveSlotNamed: aSlotName
	"The user has requested that an instance variable be removed..."

	| aSetter aGetter |
	(self okayToRemoveSlotNamed: aSlotName) ifFalse:
		[^ self inform: 'Sorry, ', aSlotName, ' is in
use in a script.'].

	aSetter _ Utilities setterSelectorFor: aSlotName.
	aGetter _ Utilities getterSelectorFor: aSlotName.
	((self systemNavigation allCallsOn: aSetter) size > 0 or: [(self systemNavigation allCallsOn: aGetter) size > 0]) ifTrue:
		[self inform: 
'Caution!!  There may be scripts belonging to
other objects that may rely on the presence of
this variable.  If there are, they may now be broken.
You may need to fix them up manually.'].

	self class removeInstVarName: aSlotName asString.

	self updateAllViewers! !

!Player methodsFor: 'slots-user' stamp: 'yo 9/24/2004 10:06'!
basicRenameSlot: oldSlotName newSlotName: newSlotName
	"Give an existing instance variable a new name"

	self class renameSilentlyInstVar: oldSlotName to: newSlotName.
	self renameSlotInWatchersOld: oldSlotName new: newSlotName.

	self updateAllViewers.

	self presenter allExtantPlayers do:
		[:aPlayer | (aPlayer hasScriptReferencing: oldSlotName ofPlayer: self)
			ifTrue:
				[aPlayer noteRenameOf: oldSlotName to: newSlotName inPlayer: self]].

	self presenter hasAnyTextuallyCodedScripts
		ifTrue:
			[self inform: 
'Caution!!  References in texutally coded scripts won''t be renamed.'].

	^ true! !

!Player methodsFor: 'slots-user' stamp: 'sw 3/24/2005 01:33'!
chooseSlotTypeFor: aGetter
	"Let the user designate a type for the slot associated with the given getter"

	| typeChoices typeChosen slotName |
	slotName _ Utilities inherentSelectorForGetter: aGetter.
	typeChoices _ Vocabulary typeChoices.
	typeChosen _ (SelectionMenu labelList: (typeChoices collect: [:t | t translated]) lines: #() selections: typeChoices) startUpWithCaption: 
		('Choose the TYPE
for ' translated, slotName, '
(currently ' translated, (self slotInfoAt: slotName) type translated, ')').
	typeChosen isEmptyOrNil ifTrue: [^ self].
	(self typeForSlot: slotName) capitalized = typeChosen ifTrue: [^ self].

	(self slotInfoAt: slotName) type: typeChosen.
	self class allInstancesDo:   "allSubInstancesDo:"
		[:anInst | anInst instVarNamed: slotName asString put: 
			(anInst valueOfType: typeChosen from: (anInst instVarNamed: slotName))].
	self updateAllViewers.	"does siblings too"
	self changeTypesInWatchersOf: slotName  "does siblings too"
! !

!Player methodsFor: 'slots-user' stamp: 'sw 4/5/1999 13:55'!
chooseUserSlot
	| names aMenu result |
	(names _ self slotNames) size == 1
		ifTrue: [^ names first].
	aMenu _ SelectionMenu selections: names.
	result _ aMenu startUpWithCaption: 'Please choose a variable'.
	result isEmptyOrNil ifTrue: [^ nil].
	^ result! !

!Player methodsFor: 'slots-user' stamp: 'sw 1/12/1999 16:00'!
compileInstVarAccessorsFor: varName
	self class compileInstVarAccessorsFor: varName! !

!Player methodsFor: 'slots-user' stamp: 'sw 7/18/2002 11:15'!
defaultValueOfType: aSymbol
	"Answer a default value for the given type -- invoked in compiled user scripts when a parameter tile of the wrong type is present"

	^ self initialValueForSlotOfType: aSymbol
	"Not really intended for that purpose but seemingly serves adequately"! !

!Player methodsFor: 'slots-user' stamp: 'yo 2/12/2005 18:58'!
fancyWatcherFor: aGetter
	"Anser a labeled readout for viewing a value textuallyi"

	| aWatcher aColor aLine itsName aSelector aLabel |
	aWatcher _ self unlabeledWatcherFor: aGetter.
	aColor _ Color r: 0.387 g: 0.581 b: 1.0.
	aLine _ WatcherWrapper newRow.
	aLine player: self variableName: (aSelector _ Utilities inherentSelectorForGetter: aGetter).
	itsName _ aWatcher externalName.
	aWatcher setNameTo: 'readout'.
	aLine addMorphFront: (self tileReferringToSelf
				borderWidth: 0; layoutInset: 4@0;
				typeColor: aColor; 
				color: aColor; bePossessive).
	aLabel _ StringMorph contents: aSelector translated, ' = ' font: ScriptingSystem fontForTiles.
	aLabel setProperty: #watcherLabel toValue: true.
	aLine addMorphBack: aLabel.
	aLine addMorphBack: aWatcher.
	aLine setNameTo: itsName.

	^ aLine! !

!Player methodsFor: 'slots-user' stamp: 'dgd 2/22/2003 13:43'!
hasUserDefinedScripts
	^self class scripts notEmpty! !

!Player methodsFor: 'slots-user' stamp: 'sw 9/25/2001 22:28'!
initialValueForSlotOfType: aType
	"Answer the default initial value to ascribe to a slot of the given type"

	^ (Vocabulary vocabularyForType: aType)
		initialValueForASlotFor: self! !

!Player methodsFor: 'slots-user' stamp: 'yo 2/12/2005 20:09'!
offerGetterTiles: slotName 
	"For a player-type slot, offer to build convenient compound tiles that otherwise would be hard to get"

	| typeChoices typeChosen thePlayerThereNow slotChoices slotChosen getterTiles aCategoryViewer playerGetter |
	typeChoices := Vocabulary typeChoices.
	typeChosen := (SelectionMenu labelList: (typeChoices collect: [:t | t translated]) lines: #() selections: typeChoices) 
				startUpWithCaption: ('Choose the TYPE
of data to get from
{1}''s {2}' translated format: {self externalName. slotName translated}).
	typeChosen isEmptyOrNil ifTrue: [^self].
	thePlayerThereNow := self perform: (Utilities getterSelectorFor: slotName).
	thePlayerThereNow 
		ifNil: [thePlayerThereNow := self presenter standardPlayer].
	slotChoices := thePlayerThereNow slotNamesOfType: typeChosen.
	slotChoices isEmpty 
		ifTrue: [^self inform: 'sorry -- no slots of that type' translated].
	slotChoices _ slotChoices asSortedArray.
	slotChosen := (SelectionMenu labelList: (slotChoices collect: [:t | t translated]) selections: slotChoices) 
				startUpWithCaption: ('Choose the datum
you want to extract from {1}''s {2}' translated format: {self externalName. slotName translated}).
	slotChosen isEmptyOrNil ifTrue: [^self].
	"Now we want to tear off tiles of the form
		holder's valueAtCursor's foo"
	getterTiles := nil.
	aCategoryViewer := CategoryViewer new initializeFor: thePlayerThereNow
				categoryChoice: 'basic'.
	getterTiles := aCategoryViewer 
				getterTilesFor: (Utilities getterSelectorFor: slotChosen)
				type: typeChosen.
	aCategoryViewer := CategoryViewer new initializeFor: self
				categoryChoice: 'basic'.
	playerGetter := aCategoryViewer 
				getterTilesFor: (Utilities getterSelectorFor: slotName)
				type: #Player.
	getterTiles submorphs first acceptDroppingMorph: playerGetter event: nil.	"the pad"	"simulate a drop"
	getterTiles makeAllTilesGreen.
	getterTiles justGrabbedFromViewer: false.
	(getterTiles firstSubmorph)
		changeTableLayout;
		hResizing: #shrinkWrap;
		vResizing: #spaceFill.
	ActiveHand attachMorph: getterTiles! !

!Player methodsFor: 'slots-user' stamp: 'yo 2/11/2005 15:44'!
removeSlotNamed: aSlotName
	"The user has requested that an instance variable be removed..."

	| aSetter aGetter |
	(self okayToRemoveSlotNamed: aSlotName) ifFalse:
		[^ self inform: ('Sorry, {1} is in
use in a script.' translated format: {aSlotName})].

	aSetter _ Utilities setterSelectorFor: aSlotName.
	aGetter _ Utilities getterSelectorFor: aSlotName.
	((self systemNavigation allCallsOn: aSetter) size > 0 or: [(self systemNavigation allCallsOn: aGetter) size > 0]) ifTrue:
		[self inform: 
'Caution!!  There may be scripts belonging to
other objects that may rely on the presence of
this variable.  If there are, they may now be broken.
You may need to fix them up manually.' translated].

	self class removeInstVarName: aSlotName asString.

	self updateAllViewers! !

!Player methodsFor: 'slots-user' stamp: 'yo 7/2/2004 19:36'!
renameSlot: oldSlotName 
	| reply newSlotName |
	reply := FillInTheBlank request: 'New name for "' translated , oldSlotName , '":'
				initialAnswer: oldSlotName.
	reply isEmpty ifTrue: [^self].
	newSlotName := ScriptingSystem 
				acceptableSlotNameFrom: reply
				forSlotCurrentlyNamed: oldSlotName
				asSlotNameIn: self
				world: self costume currentWorld.
	self renameSlot: oldSlotName newSlotName: newSlotName! !

!Player methodsFor: 'slots-user' stamp: 'sw 3/8/2004 22:14'!
renameSlot: oldSlotName newSlotName: newSlotName
	"Give an existing instance variable a new name"

	self class renameSilentlyInstVar: oldSlotName to: newSlotName.
	self renameSlotInWatchersOld: oldSlotName new: newSlotName.

	self updateAllViewers.

	self presenter allExtantPlayers do:
		[:aPlayer | (aPlayer hasScriptReferencing: oldSlotName ofPlayer: self)
			ifTrue:
				[aPlayer noteRenameOf: oldSlotName to: newSlotName inPlayer: self]].

	self presenter hasAnyTextuallyCodedScripts
		ifTrue:
			[self inform: 
'Caution!!  References in texutally coded scripts won''t be renamed.'].

	^ true! !

!Player methodsFor: 'slots-user' stamp: 'sw 7/4/2004 00:26'!
setFloatPrecisionFor: aReadout
	"If appropriate, set the floatPrecision for the given watcher readout (an UpdatingStringMorph), whose getter is assumed already to be established."
	
	| precision  |
	(precision _ self defaultFloatPrecisionFor: aReadout getSelector) ~= 1 ifTrue: [aReadout floatPrecision: precision]! !

!Player methodsFor: 'slots-user' stamp: 'yo 8/1/2004 19:46'!
setPrecisionFor: slotName 
	"Set the precision for the given slot name"

	| aList aMenu reply val aGetter places |
	aGetter := Utilities getterSelectorFor: slotName.
	places := Utilities 
				decimalPlacesForFloatPrecision: (self defaultFloatPrecisionFor: aGetter).
	aList := #('0' '1' '2' '3' '4' '5' '6').
	aMenu := SelectionMenu labels: aList
				selections: (aList collect: [:m | m asNumber]).
	reply := aMenu 
				startUpWithCaption: ('How many decimal places? (currently {1})' translated
						format: {places}).
	reply ifNotNil: 
			[(self slotInfo includesKey: slotName) 
				ifTrue: 
					["it's a user slot"

					(self slotInfoAt: slotName) 
						floatPrecision: (Utilities floatPrecisionForDecimalPlaces: reply).
					self class allInstancesDo: 
							[:anInst | 
							reply == 0 
								ifFalse: 
									[((val := anInst instVarNamed: slotName asString) isInteger) 
										ifTrue: [anInst instVarNamed: slotName asString put: val asFloat]].
							anInst updateAllViewers]]
				ifFalse: 
					["it's specifying a preference for precision on a system-defined numeric slot"

					self noteDecimalPlaces: reply forGetter: aGetter.
					self updateAllViewers]]! !

!Player methodsFor: 'slots-user' stamp: 'md 3/1/2006 09:16'!
slotInfoAt: slotName 
	| info |
	info := self slotInfo at: slotName ifAbsent: [nil].
	info ifNil: [self slotInfo at: slotName put: (info := SlotInformation new)].
	(info isSymbol) ifTrue: ["bkward compat"
			self slotInfo at: slotName put: (info := SlotInformation new type: info)].
	^info! !

!Player methodsFor: 'slots-user' stamp: 'sw 7/26/2001 12:01'!
slotInfoAt: slotName ifAbsent: aBlock
	"If the receiver has a slot of the given name, answer its slot info, else answer nil"

	| info |
	info _ self slotInfo at: slotName ifAbsent: [^ aBlock value].
	^ info! !

!Player methodsFor: 'slots-user' stamp: 'sw 5/16/2001 13:01'!
slotInfoForGetter: aGetter
	"Answer a SlotInformation object which describes an instance variable of mine retrieved via the given getter, or nil if none"

	^ self slotInfo at: (Utilities inherentSelectorForGetter: aGetter) ifAbsent: [nil]! !

!Player methodsFor: 'slots-user' stamp: 'sw 5/16/2001 18:29'!
slotNamesOfType: aType
	"Answer a list of potential slot names of the given type in the receiver"

	| fullList forViewer gettersToOffer |
	fullList _ (ScriptingSystem systemSlotNamesOfType: aType),
		(self class slotGettersOfType: aType).
	forViewer _ costume renderedMorph selectorsForViewer select:
		[:aSel | aSel beginsWith: 'get'].
	gettersToOffer _ fullList select: [:anItem | forViewer includes: anItem].
	^ gettersToOffer collect:
		[:aSel | Utilities inherentSelectorForGetter: aSel]! !

!Player methodsFor: 'slots-user' stamp: 'tak 4/6/2005 14:20'!
tearOffFancyWatcherFor: aGetter
	"Hand the user a labeled readout for viewing a numeric value"

	(WatcherWrapper new fancyForPlayer: self getter: aGetter) openInHand! !

!Player methodsFor: 'slots-user' stamp: 'tak 4/6/2005 11:40'!
tearOffUnlabeledWatcherFor: aGetter 
	"Hand the user anUnlabeled readout for viewing a numeric value"
	(WatcherWrapper new unlabeledForPlayer: self getter: aGetter) openInHand! !

!Player methodsFor: 'slots-user' stamp: 'sw 8/12/2004 02:27'!
tearOffWatcherFor: aSlotGetter
	"Tear off a simple textual watcher for the slot whose getter is provided"

	| aWatcher anInterface info isNumeric |

	info _ self slotInfoForGetter: aSlotGetter.
	info
		ifNotNil:
			[isNumeric _ info type == #Number]
		ifNil:
			[anInterface _ Vocabulary eToyVocabulary methodInterfaceAt: aSlotGetter ifAbsent: [nil].
			isNumeric _ anInterface notNil and: [anInterface resultType == #Number]].
	aWatcher _ UpdatingStringMorph new.
	
	aWatcher
		growable: true;
		getSelector: aSlotGetter;
		putSelector: (info notNil
			ifTrue:
				[ScriptingSystem setterSelectorForGetter: aSlotGetter]
			ifFalse:
				[anInterface companionSetterSelector]);
		setNameTo: (info notNil
			ifTrue:
				[Utilities inherentSelectorForGetter: aSlotGetter]
			ifFalse:
				[anInterface wording]);
 		target: self.
	isNumeric
		ifFalse:
			[aWatcher useStringFormat]
		ifTrue:
			[self setFloatPrecisionFor: aWatcher].
	aWatcher
		step;
		fitContents;
		openInHand! !

!Player methodsFor: 'slots-user' stamp: 'sw 1/5/2005 22:17'!
unlabeledWatcherFor: aGetter
	"Answer an unnlabeled readout for viewing a numeric-valued slot of mine"

	| aWatcher info anInterface watcherWording itsType vocab aSetter |
	info _ self slotInfoForGetter: aGetter.
	info ifNotNil:
			[itsType _ info type.
			watcherWording _ Utilities inherentSelectorForGetter: aGetter.
			aSetter _ Utilities setterSelectorFor: watcherWording]
		ifNil:
			[anInterface _Vocabulary eToyVocabulary methodInterfaceAt: aGetter ifAbsent: [nil].
			anInterface
				ifNotNil:
					[itsType _ anInterface resultType.
					aSetter _ anInterface companionSetterSelector]
				ifNil:
					[itsType _ #Unknown.
					aSetter _ nil].
			watcherWording _ anInterface ifNotNil: [anInterface wording] ifNil: ['*']].
	vocab _ Vocabulary vocabularyForType: itsType.
	aWatcher _ vocab updatingTileForTarget: self partName: watcherWording getter: aGetter setter: aSetter.

	aWatcher setNameTo: (self externalName, '''s ', watcherWording).
	aWatcher minHeight: (vocab wantsArrowsOnTiles ifTrue: [22] ifFalse: [14]).
	^ aWatcher! !

!Player methodsFor: 'slots-user' stamp: 'sw 7/4/1998 18:03'!
valueOfType: aType from: oldValue
	"The user has changed a slot's type to aType; convert its former value, oldValue, to something of the appropriate type.  For now, does not take oldValue into account"
	^ self initialValueForSlotOfType: aType! !


!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:11'!
getFogColor
	^self costume renderedMorph fogColor! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:22'!
getFogDensity
	^self costume renderedMorph fogDensity * 100! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'!
getFogRangeEnd
	^self costume renderedMorph fogRangeEnd * 100! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'!
getFogRangeStart
	^self costume renderedMorph fogRangeStart * 100! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:11'!
getFogType
	^self costume renderedMorph fogType! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:11'!
setFogColor: x
	self costume renderedMorph fogColor: x! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'!
setFogDensity: x
	self costume renderedMorph fogDensity: x * 0.01! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'!
setFogRangeEnd: x
	self costume renderedMorph fogRangeEnd: x * 0.01! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'!
setFogRangeStart: x
	self costume renderedMorph fogRangeStart: x * 0.01! !

!Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:12'!
setFogType: x
	self costume renderedMorph fogType: x! !


!Player methodsFor: 'testing' stamp: 'sw 9/27/2001 17:26'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	^ #Player! !

!Player methodsFor: 'testing' stamp: 'sw 9/15/1998 13:12'!
costumes
	^ costumes! !

!Player methodsFor: 'testing' stamp: 'sw 10/24/2000 07:28'!
knownName
	"Answer a name by which the receiver is known, or nil if none"

	^ costume knownName! !

!Player methodsFor: 'testing' stamp: 'sw 10/25/2000 23:16'!
nameForViewer
	"Answer the name to be used for the receiver in its Viewer"

	^ self getName! !

!Player methodsFor: 'testing' stamp: 'tk 7/28/2005 04:52'!
renameInternal: aName

	^ self costume topRendererOrSelf renameInternal: aName! !

!Player methodsFor: 'testing' stamp: 'tk 7/28/2005 04:55'!
renameTo: aName

	^ self costume topRendererOrSelf renameTo: aName! !

!Player methodsFor: 'testing' stamp: 'sw 10/19/1999 08:30'!
wantsSteps
	"UnscriptedPlayer, with no scripts, overrides to false"
	^ true! !


!Player methodsFor: 'translation' stamp: 'sw 7/25/2005 05:04'!
changeTypesInWatchersOf: slotName
	"The type of a variable has changed; adjust watchers to that fact."

	| aGetter newWatcher |
	aGetter _ Utilities getterSelectorFor: slotName.
	self allPossibleWatchersFromWorld do: [:aWatcher |
		(aWatcher getSelector = aGetter) ifTrue:
			[(aWatcher ownerThatIsA: WatcherWrapper) ifNotNilDo:
				[:aWrapper |
					newWatcher _ (aWrapper submorphs size = 1)
						ifTrue:
							[WatcherWrapper new unlabeledForPlayer: self getter: aGetter]
						ifFalse:
							[WatcherWrapper new fancyForPlayer: self getter: aGetter].
					newWatcher position: aWatcher position.
					aWrapper owner replaceSubmorph: aWrapper by: newWatcher]]]
! !

!Player methodsFor: 'translation' stamp: 'yo 1/18/2004 10:59'!
labelFromWatcher: w
	"Answer the morph holding the label of the given watcher"

	^ w owner owner submorphs third submorphs second! !

!Player methodsFor: 'translation' stamp: 'sw 1/6/2005 16:34'!
renameSlotInWatchersOld: oldName new: newName
	"A variable has been renamed; get all relevant extant watchers updated.  All this assumed to be happening in the ActiveWorld"

	| wasStepping oldGetter |
	oldGetter _ Utilities getterSelectorFor: oldName.
	self allPossibleWatchersFromWorld do: [:aWatcher |
		(aWatcher getSelector = oldGetter) ifTrue:
			[(wasStepping _ aWatcher isStepping) ifTrue: [aWatcher stopStepping].
			aWatcher getSelector: (Utilities getterSelectorFor: newName).
			aWatcher putSelector ifNotNil:
				[aWatcher putSelector: (Utilities setterSelectorFor: newName)].
			((aWatcher isKindOf: UpdatingStringMorph) and: [aWatcher hasStructureOfComplexWatcher]) ifTrue:  "Old style fancy watcher"
				[aWatcher owner owner traverseRowTranslateSlotOld: oldName to: newName.
				(aWatcher target labelFromWatcher: aWatcher) contents: newName, ' = '].
			(aWatcher ownerThatIsA: WatcherWrapper) ifNotNilDo:
				[:wrapper | wrapper player: self variableName: newName].
			wasStepping ifTrue: [aWatcher startStepping]]]! !


!Player methodsFor: 'user interface' stamp: 'tk 1/3/2001 09:37'!
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."
	^ self knownName ifNil: ['An unaffiliated Player'] ifNotNil: [self knownName]! !


!Player methodsFor: 'viewer' stamp: 'sw 9/15/1998 13:19'!
assureUniClass
	"If I am not currently a member of a UniClass, become one now"! !

!Player methodsFor: 'viewer' stamp: 'sw 1/12/1999 16:00'!
belongsToUniClass
	"UnscriptedPlayer reimplements to false"
	^ true! !

!Player methodsFor: 'viewer' stamp: 'sw 5/22/2001 14:56'!
elementTypeFor: aStringOrSymbol vocabulary: aVocabulary
	"Answer whether aStringOrSymbol is best characterized as a #systemSlot, #systemScript, #userSlot, or #userScript.  This is ancient and odious but too tedious to rip out at this point."

	| aSymbol anInterface aSlotName |
	aSymbol _ aStringOrSymbol asSymbol.
	aSlotName _ Utilities inherentSelectorForGetter: aSymbol.
	(self slotInfo includesKey: aSlotName) ifTrue: [^ #userSlot].
	(self class isUniClass and: [self class scripts includesKey: aSymbol]) ifTrue: [^ #userScript].
	
	anInterface _ aVocabulary methodInterfaceAt: aSymbol ifAbsent: [nil].
	^ anInterface
		ifNotNil:
			[(anInterface resultType == #unknown)
				ifTrue:
					[#systemScript]
				ifFalse:
					[#systemSlot]]
		ifNil:
			[#systemScript]! !

!Player methodsFor: 'viewer' stamp: 'sw 1/28/2001 20:17'!
externalName
	"Answer an external name for the receiver.  If it has none, supply a backstop name"

	| aCostume |
	^ (aCostume _ self costume) ifNotNil: [aCostume externalName] ifNil: ['an orphaned Player']! !

!Player methodsFor: 'viewer' stamp: 'sw 5/2/2001 23:46'!
graphicForViewerTab
	"Answer the graphic to show in the tab of a Viewer looking at me"

	^ self costume renderedMorph! !

!Player methodsFor: 'viewer' stamp: 'dgd 2/22/2003 13:43'!
hasUserDefinedSlots
	^self class slotInfo notEmpty! !

!Player methodsFor: 'viewer' stamp: 'yo 2/11/2005 15:48'!
infoFor: anElement inViewer: aViewer 
	"The user made a gesture asking for info/menu relating"

	| aMenu elementType aSelector |
	elementType := self elementTypeFor: anElement
				vocabulary: aViewer currentVocabulary.
	elementType = #systemSlot | (elementType == #userSlot) 
		ifTrue: [^self slotInfoButtonHitFor: anElement inViewer: aViewer].
	aMenu := MenuMorph new defaultTarget: self.
	aMenu defaultTarget: self.
	aSelector := anElement asSymbol.
	elementType == #userScript 
		ifTrue: 
			[aMenu 
				add: 'destroy "' translated , anElement , '"'
				selector: #removeScriptWithSelector:
				argument: aSelector.
			aMenu 
				add: 'rename  "' translated, anElement , '"'
				selector: #renameScript:
				argument: aSelector.
			aMenu 
				add: 'textual scripting pane' translated
				selector: #makeIsolatedCodePaneForSelector:
				argument: aSelector.
			aSelector numArgs > 0 
				ifTrue: 
					[aMenu 
						add: 'remove parameter' translated
						selector: #ceaseHavingAParameterFor:
						argument: aSelector]
				ifFalse: 
					[aMenu 
						add: 'add parameter' translated
						selector: #startHavingParameterFor:
						argument: aSelector.
					aMenu 
						add: 'button to fire this script' translated
						selector: #tearOffButtonToFireScriptForSelector:
						argument: aSelector].
			aMenu 
				add: 'edit balloon help' translated
				selector: #editDescriptionForSelector:
				argument: aSelector].
	aMenu 
		add: 'show categories....' translated
		target: aViewer
		selector: #showCategoriesFor:
		argument: aSelector.
	aMenu items isEmpty 
		ifTrue: 
			["Never 0 at the moment because of show categories addition"

			aMenu add: 'ok' translated action: nil].
	aMenu addTitle: anElement asString , ' (' , elementType translated , ')'.
	aMenu popUpInWorld: aViewer world! !

!Player methodsFor: 'viewer' stamp: 'sw 9/27/2001 17:41'!
initialTypeForSlotNamed: aName
	"Answer the initial type to be ascribed to the given instance variable"

	^ #Number! !

!Player methodsFor: 'viewer' stamp: 'ar 5/26/2001 16:14'!
isPlayerLike
	"Return true if the receiver is a player-like object"
	^true! !

!Player methodsFor: 'viewer' stamp: 'tk 8/3/2001 11:08'!
newScriptorAround: aPhrase
	"Sprout a scriptor around aPhrase, thus making a new script.  aPhrase may either be a PhraseTileMorph (classic tiles 1997-2001) or a SyntaxMorph (2001 onward)"

	| aScriptEditor aUniclassScript tw blk |
	aUniclassScript _ self class permanentUserScriptFor: self unusedScriptName player: self.
	aScriptEditor _ aUniclassScript instantiatedScriptEditorForPlayer: self.

	Preferences universalTiles ifTrue: [
		aScriptEditor install.
		"aScriptEditor hResizing: #shrinkWrap;
			vResizing: #shrinkWrap;
			cellPositioning: #topLeft;
			setProperty: #autoFitContents toValue: true."
		aScriptEditor insertUniversalTiles.  "Gets an empty SyntaxMorph for a MethodNode"
		tw _ aScriptEditor findA: TwoWayScrollPane.
		aPhrase ifNotNil:
			[blk _ (tw scroller findA: SyntaxMorph "MethodNode") findA: BlockNode.
			blk addMorphFront: aPhrase.
			aPhrase accept.
		].
		SyntaxMorph setSize: nil andMakeResizable: aScriptEditor.
	] ifFalse: [
		aPhrase 
				ifNotNil: [aScriptEditor phrase: aPhrase]	"does an install"
				ifNil: [aScriptEditor install]
	].
	self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aUniclassScript selector].
		"The above assures the presence of a ScriptInstantiation for the new selector in all siblings"
	self updateAllViewersAndForceToShow: #scripts.
	^ aScriptEditor! !

!Player methodsFor: 'viewer' stamp: 'sw 5/4/2001 05:19'!
tileToRefer
	"Answer a reference tile that comprises an alias to me.  Forgive this temporary and seemingly gratuituous revectoring as worlds collide"

	^ self tileReferringToSelf! !

!Player methodsFor: 'viewer' stamp: 'sw 10/30/2000 17:13'!
uniqueNameForReference
	"Answer a unique name for referring to the receiver"

	| itsReferent |
	self flag: #deferred.  "The once-and-maybe-future ObjectRepresentativeMorph scheme is for the moment disenfranchised"

	"(costume isKindOf: ObjectRepresentativeMorph) ifTrue:
		[((itsReferent _ costume objectRepresented) isKindOf: Class)
			ifTrue:
				[^ itsReferent name].
		itsReferent == Smalltalk ifTrue: [^ #Smalltalk].
		itsReferent == ScriptingSystem ifTrue: [^ #ScriptingSystem]]."

	^  super uniqueNameForReference

! !


!Player methodsFor: '*flexibleVocabularies-flexibleVocabularies-costume' stamp: 'nk 9/4/2004 11:48'!
hasAnyBorderedCostumes
	"Answer true if any costumes of the receiver are BorderedMorph descendents"

	self costumesDo:
		[:cost | (cost understandsBorderVocabulary) ifTrue: [^ true]].
	^ false! !


!Player methodsFor: '*sound' stamp: 'jm 4/22/1999 15:46'!
getConePosition
	"Note: Performance hacked to allow real-time sound. Assumes costume is a SpeakerMorph."

	^ costume renderedMorph conePosition
! !

!Player methodsFor: '*sound' stamp: 'jm 4/22/1999 15:46'!
setConePosition: aNumber
	"Note: Performance hacked to allow real-time sound. Assumes costume is a SpeakerMorph."

	costume renderedMorph conePosition: aNumber.
! !


!Player methodsFor: 'slot-kedama' stamp: 'yo 2/2/2005 17:47'!
addPatchVarNamed: nameSymbol

	| f |
	f _ KedamaPatchMorph newExtent: self costume dimensions.
	f assuredPlayer assureUniClass.
	f setNameTo: (ActiveWorld unusedMorphNameLike: f innocuousName).
	self addInstanceVariable2Named: nameSymbol type: #Patch value: f player.
	^ f.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/9/2004 15:14'!
addToPatchDisplayList: aPlayer

	costume renderedMorph addToPatchDisplayList: aPlayer costume renderedMorph.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/9/2004 15:28'!
addToTurtleDisplayList: aPlayer

	costume renderedMorph addToTurtleDisplayList: aPlayer "costume renderedMorph".
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/13/2004 00:57'!
blueComponentFrom: another

	costume renderedMorph blueComponentFrom: another costume renderedMorph.

! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/13/2004 00:18'!
blueComponentInto: another

	costume renderedMorph blueComponentInto: another costume renderedMorph.

! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/28/2004 18:39'!
bounceOnColor: aPlayer

	^ false.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/27/2004 11:43'!
bounceOn: aPlayer

	^ false.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/28/2004 18:25'!
bounceOn: aPlayer color: c

	^ false.
! !

!Player methodsFor: 'slot-kedama' stamp: 'KR 4/14/2006 15:40'!
createSlotForPatch: aPatchMorph
	"anEmbeddedMorph has just been added to my costume because of explicit user action.  
	Create an instance variable and accessors for it as a Player-valued slot."
	| itsName openViewers |
	self costume isInWorld ifFalse: [ ^self ].

	itsName _ aPatchMorph externalName asSymbol.

	self slotInfo
		at: itsName
		put: (SlotInformation new initialize type: #Patch).
	self addInstanceVarNamed: itsName withValue: (aPatchMorph assuredPlayer).
	self class compileAccessorsFor: itsName.
	openViewers := self allOpenViewersOnReceiverAndSiblings.
	openViewers isEmpty
		ifTrue: [^ self]
		ifFalse: [| aPresenter | 
			(aPresenter := self costume presenter)
				ifNil: [^ self].
			openViewers
				do: [:aViewer | aPresenter updateViewer: aViewer forceToShow: ScriptingSystem nameForInstanceVariablesCategory]]
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/3/2004 23:28'!
decayPatchVariable

	self costume renderedMorph evaporate.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/16/2004 18:50'!
defaultPatchPlayer

	^ costume renderedMorph kedamaWorld player getPatch.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/3/2004 00:29'!
die
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/3/2004 23:28'!
diffusePatchVariable
	"Diffuse the patch variable of the given name."

	self costume renderedMorph diffuse.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/14/2004 15:56'!
doCommand: aBlock

	^ aBlock value: self.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 09:59'!
getAngleTo: aPlayer

	^ 0.0.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/12/2004 22:55'!
getBlueComponentIn: aPatch! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 16:34'!
getBottomEdgeMode

	^ self getValueFromCostume: #bottomEdgeMode.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 5/30/2004 17:09'!
getDiffusionRate

	^ self getValueFromCostume: #diffusionRate.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/15/2004 05:13'!
getDisplayScaleMax

	^ self getValueFromCostume: #displayMax.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/4/2004 17:44'!
getDisplayShiftAmount

	^ self getValueFromCostume: #displayShiftAmount.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 3/7/2005 12:00'!
getDisplayType

	^ self getValueFromCostume: #displayType.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/14/2004 15:53'!
getDistanceTo: aPlayer

	^ 0.0.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 5/30/2004 17:23'!
getEvaporationRate

	^ self getValueFromCostume: #evaporationRate.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/12/2004 22:55'!
getGreenComponentIn: aPatch! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/14/2004 15:46'!
getGrouped

	^ self getValueFromCostume: #isGroup.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 16:33'!
getLeftEdgeMode

	^ self getValueFromCostume: #leftEdgeMode.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/5/2004 16:41'!
getPatchesList

	^ self getValueFromCostume: #patchesToDisplayAsString.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 19:46'!
getPatchName

	^ (self perform: #getPatch) externalName.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/19/2004 00:05'!
getPatchValueIn: aPatch

	^ 0.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/11/2004 01:16'!
getPixelsPerPatch

	^ self getValueFromCostume: #pixelsPerPatch.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/12/2004 22:55'!
getRedComponentIn: aPatch! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/2/2004 23:17'!
getReplicated
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 16:32'!
getRightEdgeMode

	^ self getValueFromCostume: #rightEdgeMode.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 5/30/2004 17:07'!
getSniffRange

	^ self getValueFromCostume: #sniffRange.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 16:33'!
getTopEdgeMode

	^ self getValueFromCostume: #topEdgeMode.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/2/2004 16:36'!
getTurtleCount

	^ self getValueFromCostume: #turtleCount.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/9/2004 15:21'!
getTurtlesList

	^ self getValueFromCostume: #turtlesToDisplayAsString.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 3/7/2005 07:32'!
getTurtleVisible

	^ self costume visible.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/7/2004 18:04'!
getUphillIn: aPatch

	^ self costume heading.

! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/15/2004 05:15'!
getUseLogDisplay

	^ self getValueFromCostume: #useLogDisplay.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/5/2004 19:03'!
grabPatchMorph

	World primaryHand attachMorph: costume renderedMorph.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/13/2004 00:57'!
greenComponentFrom: another

	costume renderedMorph greenComponentFrom: another costume renderedMorph.

! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/13/2004 00:18'!
greenComponentInto: another

	costume renderedMorph greenComponentInto: another costume renderedMorph.

! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/14/2004 15:44'!
isGroup: aBoolean

	self setCostumeSlot: #isGroup: toValue: aBoolean.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/14/2004 17:18'!
isPrototypeTurtlePlayer

	^ false.
"
	costume ifNil: [^ false].
	^ costume renderedMorph isMemberOf: KedamaTurtleMorph
"! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/24/2004 06:08'!
isSequentialStub

	^ false.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/13/2005 22:03'!
newPatch

	| f |
	f _ KedamaPatchMorph newExtent: self costume renderedMorph dimensions.
	f assuredPlayer assureUniClass.
	f setNameTo: (ActiveWorld unusedMorphNameLike: f innocuousName).
	self createSlotForPatch: f.
	self addToPatchDisplayList: f assuredPlayer.
	self costume world primaryHand attachMorph: f.
	^ f.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 8/18/2005 15:33'!
newTurtle

	| m |
	m _ KedamaTurtleMorph new openInWorld.
	self costume hasNoTurtleBreed ifTrue: [m color: Color red].
	self useTurtle: m player.
	m setNameTo: (ActiveWorld unusedMorphNameLike: m innocuousName).
	self costume world primaryHand attachMorph: m.
	^ m.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 8/10/2004 12:37'!
newTurtleSilently

	| m |
	m _ KedamaTurtleMorph new openInWorld.
	self useTurtle: m player.
	m turtleCount: 0.
	m setNameTo: (ActiveWorld unusedMorphNameLike: m innocuousName).
	^ m.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/13/2004 00:57'!
redComponentFrom: another

	costume renderedMorph redComponentFrom: another costume renderedMorph.

! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/13/2004 00:18'!
redComponentInto: another

	costume renderedMorph redComponentInto: another costume renderedMorph.

! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/9/2004 15:16'!
removeAllFromPatchDisplayList

	costume renderedMorph removeAllFromPatchDisplayList.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/9/2004 15:19'!
removeAllFromTurtleDisplayList

	costume renderedMorph removeAllFromTurtleDisplayList.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/12/2004 22:55'!
setBlueComponentIn: aPatch to: value
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 16:35'!
setBottomEdgeMode: aSymbol

	self setCostumeSlot: #bottomEdgeMode: toValue: aSymbol.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 5/30/2004 17:09'!
setDiffusionRate: aNumber

	^ self setCostumeSlot: #diffusionRate: toValue: aNumber.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/15/2004 05:11'!
setDisplayScaleMax: aNumber

	self setCostumeSlot: #displayMax: toValue: aNumber.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/4/2004 17:44'!
setDisplayShiftAmount: aNumber

	self setCostumeSlot: #displayShiftAmount: toValue: aNumber.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 3/7/2005 12:04'!
setDisplayType: aSymbol

	^ self setCostumeSlot: #displayType: toValue: aSymbol.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 5/30/2004 17:23'!
setEvaporationRate: aNumber

	self setCostumeSlot: #evaporationRate: toValue: aNumber.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/12/2004 22:55'!
setGreenComponentIn: aPatch to: value
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/14/2004 15:45'!
setGrouped: aBoolean

	self setCostumeSlot: #isGroup: toValue: aBoolean.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 16:35'!
setLeftEdgeMode: aSymbol

	self setCostumeSlot: #leftEdgeMode: toValue: aSymbol.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/7/2004 18:37'!
setPatchValueIn: aPatch to: value
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/11/2004 01:17'!
setPixelsPerPatch: aNumber

	^ self setCostumeSlot: #pixelsPerPatch: toValue: aNumber.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 10/12/2004 22:54'!
setRedComponentIn: aPatch to: value
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 16:35'!
setRightEdgeMode: aSymbol

	self setCostumeSlot: #rightEdgeMode: toValue: aSymbol.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 5/30/2004 16:57'!
setSniffRange: aNumber

	self setCostumeSlot: #sniffRange: toValue: aNumber.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/17/2004 16:35'!
setTopEdgeMode: aSymbol

	self setCostumeSlot: #topEdgeMode: toValue: aSymbol.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/4/2004 01:19'!
setTurtleCount: aNumber

	self setCostumeSlot: #turtleCount: toValue: aNumber.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 3/7/2005 07:34'!
setTurtleVisible: aBoolean
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 6/15/2004 05:15'!
setUseLogDisplay: aBoolean

	^ self setCostumeSlot: #useLogDisplay: toValue: aBoolean.
! !

!Player methodsFor: 'slot-kedama' stamp: 'yo 9/16/2004 18:50'!
useTurtle: aPlayer

	aPlayer costume renderedMorph kedamaWorld: costume renderedMorph.
	aPlayer costume renderedMorph install.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Player class
	instanceVariableNames: 'scripts slotInfo'!

!Player class methodsFor: 'housekeeping' stamp: 'ls 10/10/1999 13:42'!
abandonUnnecessaryUniclasses
	"Player abandonUnnecessaryUniclasses"
	| oldCount oldFree newFree newCount report |
	oldCount _ self subclasses size - 1.
	oldFree _ Smalltalk garbageCollect.
	self allSubInstances do:
		[:aPlayer | aPlayer revertToUnscriptedPlayerIfAppropriate.  
		"encourage last one to get garbage-collected"
		aPlayer _ nil ].

	ScriptingSystem spaceReclaimed.
	newFree _ Smalltalk garbageCollect.
	newCount _ self subclasses size - 1.
	report _ 'Before: ', oldCount printString, ' uniclasses, ', oldFree
printString, ' bytes free
After:  ', newCount printString, ' uniclasses, ', newFree printString, '
bytes free'.
	Transcript cr; show: 'abandonUnnecessaryUniclasses:'; cr; show: report.
	^ report
	! !

!Player class methodsFor: 'housekeeping' stamp: 'sw 12/15/2004 20:43'!
cleanseScripts
	"Fix up various known structure errors in the uniclass relating to the scripts dctionary.  Answer the number of fixes made."

	| errs ed |
	scripts ifNil: [scripts _ IdentityDictionary new].
	errs _ 0.
	(scripts includesKey: nil) ifTrue: [errs _ errs + 1.  scripts removeKey: nil].
	scripts keysAndValuesDo: 
		[:sel :uniclassScript |
			uniclassScript
				ifNil:
					[errs _ errs + 1.
					Transcript cr; show: ' fix type 1, nil scripts key'.
					scripts removeKey: sel]
				ifNotNil:
					[(ed _ uniclassScript currentScriptEditor)
						ifNil:
							[errs _ errs + 1.
							Transcript cr; show: ' fix type 2, sel = ', sel.
							self someInstance removeScriptWithSelector: uniclassScript selector.]
						ifNotNil:
							[uniclassScript playerClassPerSe
								ifNil:
									[errs _ errs + 1.
									Transcript cr; show: ' fix type 3, sel = ', sel.
									uniclassScript playerClass: self selector:  sel]
								ifNotNil:
									[(ed scriptName ~= uniclassScript selector) ifTrue:
										[errs _ errs + 1.
										ed restoreScriptName: sel.
										Transcript cr; show: ' fix type 4, sel = ', sel.]]]]].
	^ errs! !

!Player class methodsFor: 'housekeeping' stamp: 'sw 4/10/2001 20:03'!
cleanseScriptsOfNilKeys
	"If, owing to an earlier bug, the receiver's scripts dictionary has a nil key, remove that offender before he causes more trouble"

	scripts ifNotNil:
		[scripts removeKey: nil ifAbsent: []]! !

!Player class methodsFor: 'housekeeping' stamp: 'sw 5/19/2000 16:26'!
cleanseSlotInfo
	| newInfo |
	slotInfo ifNotNil:
		[newInfo _ IdentityDictionary new.
		slotInfo associationsDo:
			[:assoc | newInfo at: assoc key asSymbol put: assoc value].
		slotInfo _ newInfo]
! !

!Player class methodsFor: 'housekeeping' stamp: 'ar 4/25/2005 13:36'!
freeUnreferencedSubclasses
	"Player classes may hold in their class instance variables references
to instances of themselves that are housekeepingwise unreachable. This
method allows such loops to be garbage collected. This is done in three
steps:
	1. Remove user-created subclasses from the 'subclasses' set and from
Smalltalk. Only remove classes whose name begins with 'Player' and which
have no references.
	2. Do a full garbage collection.
	3. Enumerate all Metaclasses and find those whose soleInstance's
superclass is this class. Reset the subclasses set to this set of
classes, and add back to Smalltalk."
	"Player freeUnreferencedSubclasses"

	| oldFree candidatesForRemoval class |
	oldFree _ Smalltalk garbageCollect.
	candidatesForRemoval _ self subclasses asOrderedCollection select:
		[:aClass | (aClass name beginsWith: 'Player') and: [aClass name
endsWithDigit]].

	"Break all system links and then perform garbage collection."
	candidatesForRemoval do:
		[:c | self removeSubclass: c.  "Break downward subclass pointers."
		Smalltalk removeKey: c name ifAbsent: [].  "Break binding of global
name"].
	candidatesForRemoval _ nil.
	Smalltalk garbageCollect.  "Now this should reclaim all unused
subclasses"

	"Now reconstruct system links to subclasses with valid references."
	"First restore any global references via associations"
	(Association allSubInstances select:
			[:assn | (assn key isSymbol)
					and: [(assn key beginsWith: 'Player')
					and: [assn key endsWithDigit]]])
		do: [:assn | class _ assn value.
			(class isKindOf: self class) ifTrue:
				[self addSubclass: class.
				Smalltalk add: assn]].
	"Then restore any further direct references, creating new
associations."
	(Metaclass allInstances select:
			[:m | (m soleInstance name beginsWith: 'Player')
					and: [m soleInstance name endsWithDigit]])
		do: [:m | class _ m soleInstance.
			((class isKindOf: self class) and: [(Smalltalk includesKey: class
name) not]) ifTrue:
				[self addSubclass: class.
				Smalltalk at: class name put: class]].
	SystemOrganization removeMissingClasses.
	^ Smalltalk garbageCollect - oldFree
! !

!Player class methodsFor: 'housekeeping' stamp: 'sw 12/18/2000 15:45'!
isUniClass
	"UnscriptedPlayer reimplements to false"

	^ self ~~ Player! !

!Player class methodsFor: 'housekeeping' stamp: 'tk 8/12/1999 15:45'!
playersWithUnnecessarySubclasses
	"Return a list of all players whose scripts dictionaries contain entries with nil selectors"
	"Player playersWithUnnecessarySubclasses size"
	^ self class allSubInstances select:
		[:p | p class isSystemDefined not and: [p scripts size == 0 and: [p instVarNames size == 0]]] ! !

!Player class methodsFor: 'housekeeping' stamp: 'yo 6/3/2004 13:36'!
removeUninstantiatedSubclassesSilently
	"Remove the classes of any subclasses that have neither instances nor subclasses.  Answer the number of bytes reclaimed"
	"Player removeUninstantiatedSubclassesSilently"

	| candidatesForRemoval  oldFree |

	oldFree _ Smalltalk garbageCollect.
	candidatesForRemoval _ OrderedCollection new.
	self allSubclassesWithLevelDo: [:e :l | candidatesForRemoval add: e] startingLevel: 2.
	candidatesForRemoval _ candidatesForRemoval reverse.
	candidatesForRemoval _
		candidatesForRemoval select: [:c |
			(c instanceCount = 0) and: [c subclasses size = 0]].
	candidatesForRemoval _ candidatesForRemoval select:
		[:aClass | aClass isSystemDefined not].
	candidatesForRemoval do: [:c | c removeFromSystemUnlogged].
	^ Smalltalk garbageCollect - oldFree! !


!Player class methodsFor: 'namespace' stamp: 'NS 1/28/2004 14:41'!
compileReferenceAccessorFor: varName
	"Compile reference accessors for the given variable.  If the #capitalizedReferences preference is true, then nothing is done here"

	Preferences capitalizedReferences ifTrue: [^ self].

	self class compileSilently: ((self referenceAccessorSelectorFor: varName), '
	^ ', varName)
		classified: 'reference'! !

!Player class methodsFor: 'namespace' stamp: 'sw 4/27/1998 23:42'!
makeReferenceFor: anObject

	| stem otherNames i partName |
	stem _ anObject class name.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString, stem allButFirst.
	otherNames _ self class allInstVarNames.
	i _ 1.
	[otherNames includes: (partName _ stem, i printString)]
		whileTrue: [i _ i + 1].
	self class addInstVarName: partName.
	self instVarAt: self class instSize put: anObject.  "assumes added as last field"

	self compileReferenceAccessorFor: partName.
	^ self referenceAccessorSelectorFor: partName! !

!Player class methodsFor: 'namespace' stamp: 'sw 4/27/1998 23:38'!
referenceAccessorSelectorFor: varName
	^ 'ref', (varName asString capitalized)! !

!Player class methodsFor: 'namespace' stamp: 'sw 4/28/1998 00:03'!
referenceSelectorFor: anObject
	self class instVarNames do:  "Just those added in the unique subclass"
		[:aName | (self instVarNamed: aName) == anObject
			ifTrue:
				[^ self referenceAccessorSelectorFor: aName]].
	^ self makeReferenceFor: anObject! !


!Player class methodsFor: 'other' stamp: 'sw 7/27/2001 13:45'!
abandonOldReferenceScheme
	"Abandon the old reference scheme"

	"(ActiveWorld presenter allExtantPlayers collect:
		[:aPlayer | aPlayer class]) asSet do:
			[:aPlayerClass | aPlayerClass abandonOldReferenceScheme]"

	self isUniClass ifTrue:
		[self userScriptsDo:
			[:aScript | aScript recompileScriptFromTilesUnlessTextuallyCoded].
		self class selectors do:
			[:sel | self class removeSelector: sel].
		self class instVarNames do:
			[:aName | self class removeInstVarName: aName].
		self organization removeEmptyCategories.
		self class organization removeEmptyCategories]! !

!Player class methodsFor: 'other' stamp: 'tk 6/26/1998 18:21'!
chooseUniqueClassName
	| ii className |
	ii _ BiggestSubclassNumber ifNil: [1] ifNotNil: [BiggestSubclassNumber+1].
	[className _ (self name , ii printString) asSymbol.
	 Smalltalk includesKey: className]
		whileTrue: [ii _ ii + 1].
	BiggestSubclassNumber _ ii.
	^ className	

! !

!Player class methodsFor: 'other' stamp: 'yo 6/2/2004 23:34'!
chooseUniqueTurtleClassName
	| ii className |
	className _ self name.
	[className last isDigit] whileTrue: [className _ className copyFrom: 1 to: className size - 1].

	ii _ BiggestSubclassNumber ifNil: [1] ifNotNil: [BiggestSubclassNumber+1].
	[className _ (className , ii printString) asSymbol.
	 Smalltalk includesKey: className]
		whileTrue: [ii _ ii + 1].
	BiggestSubclassNumber _ ii.
	^ className	

! !

!Player class methodsFor: 'other' stamp: 'sw 8/17/1998 07:33'!
isSystemDefined
	^ name endsWithDigit not! !

!Player class methodsFor: 'other' stamp: 'sw 1/6/2001 06:27'!
nameForViewer
	"Answer the name by which the receiver is to be referred in a viewer"

	^ self isUniClass
		ifTrue:
			[self someInstance getName]
		ifFalse:
			[super nameForViewer]! !

!Player class methodsFor: 'other' stamp: 'tk 3/15/98 20:23'!
officialClass
	"We want to make a new instance of the receiver, which is a subclass of Player.  Answer who to make a new subclass of.  Also used to tell if a given class is a UniClass, existing only for its single instance."
	^ Player! !

!Player class methodsFor: 'other' stamp: 'sw 6/4/2004 13:56'!
typicalInstanceName
	"For the purpose of documentation, answer the name of a named instance of the receiver, if possible, else answer the class name"

	| known |
	known _ (self allInstances collect: [:i | i knownName]) detect: [:n | n isEmptyOrNil not] ifNone: [nil].
	^ known ifNil: [self name]! !

!Player class methodsFor: 'other' stamp: 'tk 9/28/2001 11:43'!
wantsChangeSetLogging
	"Log changes for Player itself, but not for automatically-created subclasses like Player1, Player2, but *do* log it for uniclasses that have been manually renamed."

	^ (self == Player or:
		[(self name beginsWith: 'Player') not]) or:
			[Preferences universalTiles]! !

!Player class methodsFor: 'other' stamp: 'sw 7/31/2000 12:57'!
wantsRecompilationProgressReported
	"Report progress for Player itself, but not for automatically-created subclasses like Player1, Player2"

	^ self == Player or:
		[(self class name beginsWith: 'Player') not]! !


!Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 03:44'!
assuredMethodInterfaceFor: aSelector
	"Answer the method interface object for aSelector, creating it if it does not already exist."

	| selSym  aMethodInterface |
	selSym _ aSelector asSymbol.
	aMethodInterface _ self scripts at: selSym ifAbsent: 
		[scripts at: selSym put: (self nascentUserScriptInstance playerClass: self selector: selSym)].
	
	^ aMethodInterface! !

!Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 02:50'!
atSelector: aSelector putScript: aMethodWithInterface
	"Place the given method interface in my directory of scripts, at the given selector"

	self scripts at: aSelector asSymbol put: aMethodWithInterface! !

!Player class methodsFor: 'scripts' stamp: 'sw 10/17/2001 09:08'!
bringScriptsUpToDate
	"Bring all the receiver's scripts up to date, after, for example, a name change"

	self scripts do:
		[:aUniclassScript |
			aUniclassScript bringUpToDate]! !

!Player class methodsFor: 'scripts' stamp: 'sw 4/9/98 21:55'!
jettisonScripts
	scripts _ IdentityDictionary new! !

!Player class methodsFor: 'scripts' stamp: 'sw 1/25/2001 16:24'!
namedTileScriptSelectors
	"Answer a list of all the selectors of named tile scripts"

	scripts ifNil: [^ OrderedCollection new].
	^ scripts select: [:aScript | aScript selector ~~ nil] 
		thenCollect: [:aScript | aScript selector]! !

!Player class methodsFor: 'scripts' stamp: 'sw 12/19/2003 23:28'!
namedUnaryTileScriptSelectors
	"Answer a list of all the selectors of named unary tile scripts"

	| sel |
	scripts ifNil: [^ OrderedCollection new].
	^ scripts select: [:aScript | ((sel _ aScript selector) ~~ nil) and: [sel numArgs == 0]] 
		thenCollect: [:aScript | aScript selector]! !

!Player class methodsFor: 'scripts' stamp: 'sw 2/18/2001 18:42'!
nascentUserScriptInstance
	"Answer a new script object of the appropriate class"

	| classToUse |
	classToUse _ Preferences universalTiles
		ifTrue:	[MethodWithInterface]
		ifFalse:	[UniclassScript].
	^ classToUse new! !

!Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 00:59'!
permanentUserScriptFor: aSelector player: aPlayer
	"Create and answer a suitable script  object for the given player (who will be an instance of the receiver) and selector.  Save that script-interface object in my (i.e. the class's) directory of scripts"

	|  entry |
	scripts ifNil: [scripts _ IdentityDictionary new].
	entry _ self nascentUserScriptInstance playerClass: aPlayer class selector: aSelector.
	scripts at: aSelector put: entry.
	^ entry! !

!Player class methodsFor: 'scripts' stamp: 'tk 8/31/1998 15:42'!
privateScripts
	"for copying"
	^ scripts! !

!Player class methodsFor: 'scripts' stamp: 'NS 1/30/2004 13:11'!
removeScriptNamed: aScriptName
	aScriptName ifNotNil:
		[scripts removeKey: aScriptName.
		self removeSelectorSilently: aScriptName]! !

!Player class methodsFor: 'scripts' stamp: 'sw 4/20/2001 20:11'!
scripts
	"Answer the receiver's scripts -- an IdentityDictionary"

	scripts
		ifNil:
			[scripts _ IdentityDictionary new]
		ifNotNil:
			[self cleanseScriptsOfNilKeys].
	^ scripts! !

!Player class methodsFor: 'scripts' stamp: 'tk 8/31/1998 15:41'!
scripts: aDict
	"for copying"
	scripts _ aDict! !

!Player class methodsFor: 'scripts' stamp: 'tk 1/22/2001 14:54'!
tilesFrom: aString
	| code tree syn block phrase |
	"Construct SyntaxMorph tiles for the String."

	"This is really cheating!!  Make a true parse tree later. -tk"
	code _ String streamContents: [:strm | 
		strm nextPutAll: 'doIt'; cr; tab.
		strm nextPutAll: aString].
	"decompile to tiles"
	tree _ Compiler new 
		parse: code 
		in: self
		notifying: nil.
	syn _ tree asMorphicSyntaxUsing: SyntaxMorph.
	block _ syn submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == BlockNode] ifFalse: [false]].
	phrase _ block submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == MessageNode] ifFalse: [false]].
	^ phrase

! !

!Player class methodsFor: 'scripts' stamp: 'sw 3/28/2001 16:18'!
userScriptForPlayer: aPlayer selector: aSelector
	"Answer the user script for the player (one copy for all instances of the uniclass) and selector"

	|  newEntry existingEntry |
	scripts ifNil: [scripts _ IdentityDictionary new].
	existingEntry _ scripts at: aSelector ifAbsent: [nil].

	"Sorry for all the distasteful isKindOf: and isMemberOf: stuff here, folks; it arises out of concern for preexisting content saved on disk from earlier stages of this architecture.  Someday much of it could be cut loose"
	Preferences universalTiles
		ifTrue:
			[(existingEntry isMemberOf: MethodWithInterface) ifTrue: [^ existingEntry].
			newEntry _ (existingEntry isKindOf: UniclassScript)
				ifTrue:
					[existingEntry as: MethodWithInterface] "let go of extra stuff if it was UniclassScript"
				ifFalse:
					[MethodWithInterface new playerClass: aPlayer class selector: aSelector].
			scripts at: aSelector put: newEntry.
			^ newEntry]
		ifFalse:
			[(existingEntry isKindOf: UniclassScript)
				ifTrue:
					[^ existingEntry]
				ifFalse:
					[newEntry _ UniclassScript new playerClass: self selector: aSelector.
					scripts at: aSelector put: newEntry.
					existingEntry ifNotNil: "means it is a grandfathered UserScript that needs conversion"
						[newEntry convertFromUserScript: existingEntry].
					^ newEntry]]! !

!Player class methodsFor: 'scripts' stamp: 'sw 4/14/1998 01:16'!
userScriptsDo: aBlock
	self scripts do:
		[:aUserScript | aBlock value: aUserScript]! !


!Player class methodsFor: 'slots' stamp: 'sw 12/18/1998 21:08'!
compileAccessorsFor: varName
	^ self compileInstVarAccessorsFor: varName! !

!Player class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41'!
compileInstVarAccessorsFor: varName
	"Compile getters and setteres for the given instance variable name"

	| nameString |
	nameString _ varName asString capitalized.
	self compileSilently: ('get', nameString, '
	^ ', varName)
		classified: 'access'.
	self compileSilently: ('set', nameString, ': val
	', varName, ' _ val')
		classified: 'access'! !

!Player class methodsFor: 'slots' stamp: 'tk 8/31/1998 15:45'!
privateSlotInfo
	"for copying"
	^ slotInfo! !

!Player class methodsFor: 'slots' stamp: 'sw 12/17/1998 20:30'!
removeAccessorsFor: varName
	^ self removeInstVarAccessorsFor: varName! !

!Player class methodsFor: 'slots' stamp: 'sw 12/17/1998 20:31'!
removeInstVarAccessorsFor: varName
	| nameString |

	nameString _ varName asString capitalized.
	self removeSelector: ('get', nameString) asSymbol.
	self removeSelector: ('set', nameString, ':') asSymbol! !

!Player class methodsFor: 'slots' stamp: 'di 1/19/2000 17:18'!
removeInstVarName: aName
	self removeInstVarAccessorsFor: aName.
	super removeInstVarName: aName.
	self slotInfo removeKey: aName asSymbol ifAbsent: []! !

!Player class methodsFor: 'slots' stamp: 'sw 5/19/2000 16:37'!
renameSilentlyInstVar: oldName to: newName
	(instanceVariables includes: oldName asString) ifFalse:
		[self error: oldName , ' is not defined in ', self name].
	self removeAccessorsFor: oldName.

	super renameSilentlyInstVar: oldName to: newName.
	self compileAccessorsFor: newName.
	slotInfo at: newName asSymbol put: (slotInfo at: oldName).
	slotInfo removeKey: oldName! !

!Player class methodsFor: 'slots' stamp: 'sw 5/25/2001 10:26'!
slotGettersOfType: aType
	"Answer a list of gettter selectors for slots of mine of the given type"

	| aList |
	aList _ OrderedCollection new.
	self slotInfo associationsDo:
		[:assoc |
			(assoc value type = aType) ifTrue:
				[aList add: (Utilities getterSelectorFor: assoc key)]].
	^ aList! !

!Player class methodsFor: 'slots' stamp: 'sw 4/8/98 11:58'!
slotInfo
	slotInfo ifNil: [slotInfo _ IdentityDictionary new].
	^ slotInfo! !

!Player class methodsFor: 'slots' stamp: 'tk 8/31/1998 15:44'!
slotInfo: aDict
	"for copying"
	slotInfo _ aDict! !


!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 6/4/2004 13:59'!
addDocumentationForScriptsTo: aStream
	"Add documentation for every script in the receiver to the stream"

	self scripts do:
		[:aScript |
			aScript selector ifNotNil:
				[aStream cr; cr.
				aStream nextPutAll: self typicalInstanceName, '.'.
				self printMethodChunk: aScript selector withPreamble: false on: aStream moveSource: false toFile: nil.
				aStream position: (aStream position - 2)]].
	self scripts size == 0 ifTrue:
		[aStream cr; tab; nextPutAll: 'has no scripts']! !

!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 6/4/2004 15:04'!
addMethodReferencesTo: aCollection
	"For each extant script in the receiver, add a MethodReference object"

	| sel |
	self scripts do:
		[:aScript |
			(sel _ aScript selector) ifNotNil:
				[aCollection add: (MethodReference new setStandardClass: self methodSymbol: sel)]]! !

!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 10/30/2000 07:04'!
baseUniclass
	"Answer the uniclass that new instances should be instances of; this protocol allows for individual cards of a background to have their own class"

	| curr |
	curr _ self.
	[curr theNonMetaClass superclass name endsWithDigit]
		whileTrue:
			[curr _ curr superclass].
	^ curr

"CardPlayer100 baseUniclass 
CardPlayer100X baseUniclass
"! !

!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 5/6/1998 12:16'!
initialInstance
	self == Player ifTrue: [self error: 'must not instantiate naked Player'].
	^ super initialInstance! !

!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 8/2/1998 22:52'!
tileScriptNames
	scripts ifNil: [^ OrderedCollection new].
	"The following is an emergency workaround for damaged script dictionaries occurring in Alan's demo image 8/2/98; no selector should be nil but somehow some is, so here we filter such damaging things out"
	^ scripts collect: [:aScript | aScript selector] thenSelect: [:n | n ~~ nil]! !


!Player class methodsFor: 'turtles' stamp: 'yo 9/17/2004 08:06'!
createSequencialStubSubclass

	| instVarString classInstVarString aName aClass |
	instVarString _ KedamaSequenceExecutionStub instVarNames.
	classInstVarString _ ''.
	aName _ self chooseUniqueTurtleClassName.
	aClass _ self subclass: aName instanceVariableNames: instVarString 
		classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses.
	classInstVarString size > 0 ifTrue:
		[aClass class instanceVariableNames: classInstVarString].
	aClass copyAllCategoriesUnobtrusivelyFrom: KedamaSequenceExecutionStub.
	^ aClass
! !

!Player class methodsFor: 'turtles' stamp: 'yo 9/14/2004 21:36'!
createTurtleSubclass

	| instVarString classInstVarString aName aClass |
	instVarString _ KedamaTurtleVectorPlayer instVarNames.
	classInstVarString _ ''.
	aName _ self chooseUniqueTurtleClassName.
	aClass _ self subclass: aName instanceVariableNames: instVarString 
		classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses.
	classInstVarString size > 0 ifTrue:
		[aClass class instanceVariableNames: classInstVarString].
	aClass copyAllCategoriesUnobtrusivelyFrom: KedamaTurtleVectorPlayer.
	^ aClass
! !
ThumbnailMorph subclass: #PlayerReferenceReadout
	instanceVariableNames: 'putSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Support'!
!PlayerReferenceReadout commentStamp: '<historical>' prior: 0!
A thumbnail that serves as the value readout for a player-valued slot in a Viewer.  Clicking on it allows the user to select a new object for the slot to point to. !


!PlayerReferenceReadout methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:24'!
isEtoyReadout
	"Answer whether the receiver can serve as an etoy readout"

	^ true! !

!PlayerReferenceReadout methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:38'!
target
	"Answer the object on which I act"

	^ objectToView! !


!PlayerReferenceReadout methodsFor: 'event handling' stamp: 'sw 4/26/1998 02:02'!
handlesMouseDown: evt
	"Allow the user to respecify this by direct clicking"
	^ true! !

!PlayerReferenceReadout methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:58'!
mouseDown: evt 
	"Allow the user to respecify this by direct clicking"

	| aMorph |
	(putSelector == #unused or: [putSelector isNil]) ifTrue: [^self].
	Sensor waitNoButton.
	aMorph := self world chooseClickTarget.
	aMorph ifNil: [^self].
	objectToView perform: putSelector with: aMorph assuredPlayer.
	self changed! !


!PlayerReferenceReadout methodsFor: 'initialization' stamp: 'sw 4/26/1998 02:07'!
objectToView: objectOrNil viewSelector: aSelector putSelector: aPutSelector
	self objectToView: objectOrNil viewSelector: aSelector.
	putSelector _ aPutSelector! !

!PlayerReferenceReadout methodsFor: 'initialization' stamp: 'sw 1/6/2005 17:12'!
putSelector
	"Answer the putSelector"

	^ putSelector! !

!PlayerReferenceReadout methodsFor: 'initialization' stamp: 'sw 1/6/2005 17:13'!
putSelector: aSel
	"Reset the putSelector"

	self objectToView: objectToView viewSelector: viewSelector putSelector: aSel! !
AlignmentMorph subclass: #PlayerSurrogate
	instanceVariableNames: 'playerRepresented'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!PlayerSurrogate commentStamp: '<historical>' prior: 0!
An morph representing an E-Toy "Player" in an AllPlayersTool.!


!PlayerSurrogate methodsFor: 'accessing' stamp: 'sw 7/19/2004 12:48'!
playerRepresented
	"Answer the value of playerRepresented"

	^ playerRepresented! !

!PlayerSurrogate methodsFor: 'accessing' stamp: 'sw 7/28/2004 21:16'!
playerRepresented: anObject
	"Set the value of playerRepresented"

	playerRepresented _ anObject.
	self rebuildRow.
	self setNameTo: anObject costume topRendererOrSelf externalName! !

!PlayerSurrogate methodsFor: 'accessing' stamp: 'sw 7/28/2004 22:19'!
rebuildRow
	"Rebuild the row"

	| aThumbnail aTileButton aViewerButton |
	self removeAllMorphs.
	self layoutInset: 2; cellInset: 3.
	self beTransparent.
	aThumbnail _ ThumbnailForAllPlayersTool new objectToView: playerRepresented viewSelector: #graphicForViewerTab.
	aThumbnail setBalloonText: 'Click here to reveal this object' translated.
	self addMorphBack: aThumbnail.
	aThumbnail on: #mouseUp send: #beRevealedInActiveWorld to: playerRepresented.
	
	"aMenuButton _ IconicButton new labelGraphic: Cursor menu.
	aMenuButton target: self;
		actionSelector: #playerButtonHit;

		color: Color transparent;
		borderWidth: 0;
		shedSelvedge;
		actWhen: #buttonDown.
	aMenuButton setBalloonText: 'Press here to get a menu'.
	self addMorphBack: aMenuButton."
	aViewerButton _ IconicButton new labelGraphic: (ScriptingSystem formAtKey: #Viewer).
	aViewerButton color: Color transparent; 
			actWhen: #buttonUp;
			actionSelector: #beViewed; target: playerRepresented;
			setBalloonText: 'click here to obtain this object''s Viewer' translated;
			color: Color transparent;
			borderWidth: 0;
			shedSelvedge.

	self addMorphBack: aViewerButton.

	aTileButton _ IconicButton  new borderWidth: 0.
	aTileButton labelGraphic: (TileMorph new setToReferTo: playerRepresented) imageForm.
	aTileButton color: Color transparent; 
			actWhen: #buttonDown;
			actionSelector: #tearOffTileForSelf; target: playerRepresented;
			setBalloonText: 'click here to obtain a tile that refers to this player.' translated.
	self addMorphBack: aTileButton.

"	aNameMorph _ UpdatingStringMorph new
		useStringFormat;
		target:  playerRepresented;
		getSelector: #nameForViewer;
		setNameTo: 'name';
		font: ScriptingSystem fontForNameEditingInScriptor.
	aNameMorph putSelector: #setName:.
		aNameMorph setProperty: #okToTextEdit toValue: true.
	aNameMorph step.
	self addMorphBack: aNameMorph.
	aNameMorph setBalloonText: 'Click here to edit the player''s name.'.	"

	! !


!PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 21:18'!
addCustomMenuItems: aMenu hand:  aHand
	"Add cu stom items to the menu"

	aMenu addList: #(
		('grab this object'	grabThisObject	'wherever it may be rip this object out of its container and hand it to me.')
		('reveal this object'	revealThisObject		'make this object visible and put up its halo')
		('hand me a tile'	handMeATile	'hand me a tile for this object')
		('open viewer'		viewerForThisObject	'open this object''s Viewer'))! !

!PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 20:54'!
grabThisObject
	"Hand the user the object represented by the receiver.  Invoked from menu, formerly at least."

	playerRepresented grabPlayerInActiveWorld! !

!PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 20:52'!
handMeATile
	"Hand the user a tile representing the player for which the receiver is a surrogate"

	playerRepresented tearOffTileForSelf! !

!PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 18:05'!
revealThisObject
	"Reveal the object I represent"

	playerRepresented revealPlayerIn: ActiveWorld! !

!PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 20:53'!
viewerForThisObject
	"Open a viewer for the object represented by the receiver"

	playerRepresented beViewed! !


!PlayerSurrogate methodsFor: 'updating' stamp: 'sw 7/28/2004 20:55'!
bringUpToDate
	"To react to changes  in the corrreponding player, rebuild the display with fresh information from its surrogate"

	self rebuildRow! !

!PlayerSurrogate methodsFor: 'updating' stamp: 'sw 7/28/2004 20:54'!
isTileScriptingElement
	"Answer (for the purpose of updating) whether the receiver is a tile-scripting element"

	^ true! !
DataType subclass: #PlayerType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Protocols-Type Vocabularies'!

!PlayerType methodsFor: 'color' stamp: 'sw 9/27/2001 17:21'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(1.0  0 0.065)! !


!PlayerType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:29'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ aPlayer costume presenter standardPlayer! !


!PlayerType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:24'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	self vocabularyName: #Player! !


!PlayerType methodsFor: 'tiles' stamp: 'tak 1/18/2005 13:13'!
addExtraItemsToMenu: aMenu forSlotSymbol: slotSym
	"If the receiver has extra menu items to add to the slot menu, here is its chance to do it"

	aMenu add: 'tiles to get...' translated selector: #offerGetterTiles: argument: slotSym.
	aMenu add:  'reveal me' translated target: aMenu defaultTarget selector: #revealPlayerNamed:in: argumentList: { slotSym. ActiveWorld}.! !

!PlayerType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ ActiveWorld presenter standardPlayer tileToRefer! !

!PlayerType methodsFor: 'tiles' stamp: 'sw 9/25/2001 21:04'!
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter
	"Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter"

	^ PlayerReferenceReadout new objectToView: aTarget viewSelector: getter putSelector: setter! !

!PlayerType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:33'!
wantsArrowsOnTiles
	"Answer whether this data type wants up/down arrows on tiles representing its values"

	^ false! !
AbstractSound subclass: #PluckedSound
	instanceVariableNames: 'initialCount count ring scaledIndex scaledIndexIncr scaledIndexLimit'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!PluckedSound commentStamp: '<historical>' prior: 0!
The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string. Fractional indexing is used to allow precise tuning; without this, the pitch would be rounded to the pitch corresponding to the nearest buffer size.
!


!PluckedSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:07'!
duration
	"Answer the duration of this sound in seconds."

	^ initialCount asFloat / self samplingRate
! !

!PluckedSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration: seconds

	super duration: seconds.
	count := initialCount := (seconds * self samplingRate) rounded.
! !


!PluckedSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:13'!
copy

	^ super copy copyRing
! !

!PluckedSound methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:41'!
copyRing
	"Private!! Support for copying"

	ring := ring copy.
! !


!PluckedSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setPitch: pitchNameOrNumber dur: d loudness: vol

	| p sz |
	super setPitch: pitchNameOrNumber dur: d loudness: vol.
	p := self nameOrNumberToPitch: pitchNameOrNumber.
	initialCount := (d * self samplingRate asFloat) asInteger.
	ring := SoundBuffer newMonoSampleCount:
		(((2.0 * self samplingRate) / p) asInteger max: 2).
	sz := ring monoSampleCount.
	scaledIndexLimit := (sz + 1) * ScaleFactor.
	scaledIndexIncr := (p * sz * ScaleFactor) // (2.0 * self samplingRate).
	self reset.
! !


!PluckedSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string."
	"(PluckedSound pitch: 220.0 dur: 6.0 loudness: 0.8) play"

	| lastIndex scaledThisIndex scaledNextIndex average sample i s |
	<primitive:'primitiveMixPluckedSound' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #ring declareC: 'short int *ring'.

	lastIndex := (startIndex + n) - 1.
	scaledThisIndex := scaledNextIndex := scaledIndex.
	startIndex to: lastIndex do: [:sliceIndex |
		scaledNextIndex := scaledThisIndex + scaledIndexIncr.
		scaledNextIndex >= scaledIndexLimit
			ifTrue: [scaledNextIndex := ScaleFactor + (scaledNextIndex - scaledIndexLimit)].
		average :=
			((ring at: scaledThisIndex // ScaleFactor) +
			 (ring at: scaledNextIndex // ScaleFactor)) // 2.
		ring at: scaledThisIndex // ScaleFactor put: average.
		sample := (average * scaledVol) // ScaleFactor.  "scale by volume"
		scaledThisIndex := scaledNextIndex.

		leftVol > 0 ifTrue: [
			i := (2 * sliceIndex) - 1.
			s := (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor).
			s >  32767 ifTrue: [s :=  32767].  "clipping!!"
			s < -32767 ifTrue: [s := -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
		rightVol > 0 ifTrue: [
			i := 2 * sliceIndex.
			s := (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
			s >  32767 ifTrue: [s :=  32767].  "clipping!!"
			s < -32767 ifTrue: [s := -32767].  "clipping!!"
			aSoundBuffer at: i put: s].

		scaledVolIncr ~= 0 ifTrue: [
			scaledVol := scaledVol + scaledVolIncr.
			((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
			 [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
				ifTrue: [  "reached the limit; stop incrementing"
					scaledVol := scaledVolLimit.
					scaledVolIncr := 0]]].

	scaledIndex := scaledNextIndex.
	count := count - n.
! !

!PluckedSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset
	"Fill the ring with random noise."

	| seed n |
	super reset.
	seed := 17.
	n := ring monoSampleCount.
	1 to: n do: [:i |
		seed := ((seed * 1309) + 13849) bitAnd: 65535.
		ring at: i put: seed - 32768].
	count := initialCount.
	scaledIndex := ScaleFactor.
! !

!PluckedSound methodsFor: 'sound generation' stamp: 'jm 11/26/97 10:51'!
samplesRemaining

	^ count
! !

!PluckedSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds."

	count := (mSecs * self samplingRate) // 1000.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluckedSound class
	instanceVariableNames: ''!

!PluckedSound class methodsFor: 'instruments' stamp: 'stephaneducasse 2/4/2006 20:41'!
default
	"PluckedSound default play"
	"(AbstractSound majorScaleOn: PluckedSound default) play"

	| snd p env |
	snd := PluckedSound new.
	p := OrderedCollection new.
	p add: 0@1.0; add: 10@1.0; add: 20@0.0.
	env := VolumeEnvelope points: p loopStart: 2 loopEnd: 2.
	env target: snd; scale: 0.3.
	^ snd
		addEnvelope: env;
		setPitch: 220 dur: 3.0 loudness: 0.3
! !
PluggableButtonSpec subclass: #PluggableActionButtonSpec
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableActionButtonSpec commentStamp: 'ar 2/12/2005 23:12' prior: 0!
PluggableActionButtonSpec is intentded as a HINT for the builder that this widget will be used as push (action) button. Unless explicitly supported it will be automatically substituted by PluggableButton.!


!PluggableActionButtonSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableActionButton: self! !
Controller subclass: #PluggableButtonController
	instanceVariableNames: 'selector arguments shownAsComplemented'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableButtonController commentStamp: '<historical>' prior: 0!
The controller for Buttons.  Not meant to be used with buttons that have mouseOver feeback when the button is not pressed.  Use mouseEnter/mouseLeave for that. !


!PluggableButtonController methodsFor: 'basic control sequence' stamp: 'acg 3/13/2000 08:49'!
controlInitialize 
	"Provide feedback indicating that button has been entered with the mouse down. If triggerOnMouseDown is true, then do the button action on mouse down--and don't bother with the feedback since the action happens immediately."

	sensor anyButtonPressed ifFalse: [^ self].
	view triggerOnMouseDown
		ifTrue: [sensor yellowButtonPressed 
			ifTrue: [self yellowButtonActivity]
			ifFalse: [view performAction]]
		ifFalse: [view toggleMouseOverFeedback.
				 shownAsComplemented _ true]! !

!PluggableButtonController methodsFor: 'basic control sequence' stamp: 'acg 3/13/2000 08:44'!
controlTerminate 
	"Reverse the feedback displayed by controlInitialize, if any. Perform the button action if necessary."

	view ifNotNil:
		[view triggerOnMouseDown
			ifFalse:
				[shownAsComplemented ifTrue: [view toggleMouseOverFeedback].
				self viewHasCursor ifTrue: [view performAction]]]! !


!PluggableButtonController methodsFor: 'button activity' stamp: 'di 9/7/1999 08:44'!
yellowButtonActivity
	"Invoke the model's menu.  This is option-click, NOT the normal button press."
	| menu |
	menu _ view getMenu: false.
	menu == nil
		ifTrue: [sensor waitNoButton]
		ifFalse: [self terminateAndInitializeAround: [menu invokeOn: model]].
! !


!PluggableButtonController methodsFor: 'control defaults' stamp: 'sma 5/28/2000 16:29'!
controlActivity 

	shownAsComplemented ifNil: [^ self].
	shownAsComplemented = self viewHasCursor
		ifFalse:
			[view ifNotNil: [view toggleMouseOverFeedback]. 
			shownAsComplemented _ shownAsComplemented not]! !

!PluggableButtonController methodsFor: 'control defaults' stamp: 'acg 3/13/2000 08:26'!
isControlActive 

	^ sensor anyButtonPressed! !

!PluggableButtonController methodsFor: 'control defaults' stamp: 'tk 4/29/1998 10:47'!
isControlWanted

	"sensor flushKeyboard."
	self viewHasCursor & sensor anyButtonPressed ifFalse: [^ false].
	view askBeforeChanging
		ifTrue: [^ model okToChange]  "ask before changing"
		ifFalse: [^ true].
! !
AlignmentMorph subclass: #PluggableButtonMorph
	instanceVariableNames: 'model label getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown offColor onColor feedbackColor showSelectionFeedback allButtons arguments argumentsProvider argumentsSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!
!PluggableButtonMorph commentStamp: '<historical>' prior: 0!
A PluggableButtonMorph is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are:

		getStateSelector		fetch a boolean value from the model
		actionSelector		invoke this button's action on the model
		getLabelSelector		fetch this button's lable from the model
		getMenuSelector		fetch a pop-up menu for this button from the model

Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false.

The model informs its view(s) of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector.

If the actionSelector takes one or more arguments, then the following are relevant:
		arguments			A list of arguments to provide when the actionSelector is called.
		argumentsProvider	The object that is sent the argumentSelector to obtain arguments, if dynamic
		argumentsSelector	The message sent to the argumentProvider to obtain the arguments.

Options:
	askBeforeChanging		have model ask user before allowing a change that could lose edits
	triggerOnMouseDown	do this button's action on mouse down (vs. up) transition
	shortcutCharacter		a place to record an optional shortcut key
!


!PluggableButtonMorph methodsFor: 'accessing'!
action: aSymbol 
	"Set actionSelector to be the action defined by aSymbol."

	actionSelector _ aSymbol.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 12/28/2000 16:17'!
actionSelector
	"Answer the receiver's actionSelector"

	^ actionSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 18:53'!
askBeforeChanging

	^ askBeforeChanging
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/7/98 19:17'!
askBeforeChanging: aBoolean
	"If this preference is turned on, then give the model an opportunity to ask the user before accepting a change that might cause unaccepted edits to be lost."

	askBeforeChanging _ aBoolean.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 17:47'!
feedbackColor: aColor
	"Set the color of this button's selection feedback border."

	feedbackColor _ aColor.
	self changed.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:38'!
label
	"Answer the DisplayObject used as this button's label."

	^ label
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'ar 11/9/2000 21:21'!
label: aStringOrTextOrMorph
	"Label this button with the given string or morph."

	| r |
	self removeAllMorphs.
	"nest label in a row for centering"
	r _ AlignmentMorph newRow
		borderWidth: 0;
		layoutInset: 0;
		color: Color transparent;
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		wrapCentering: #center; cellPositioning: #leftCenter.
	aStringOrTextOrMorph isMorph
		ifTrue: [
			label _ aStringOrTextOrMorph.
			r addMorph: aStringOrTextOrMorph]
		ifFalse: [
			label _ aStringOrTextOrMorph asString.
			r addMorph: (StringMorph contents: label)].
	self addMorph: r.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 7/30/2001 15:55'!
label: aStringOrTextOrMorph font: aFont
	"Label this button with the given string or morph."

	| r |
	self removeAllMorphs.
	"nest label in a row for centering"
	r _ AlignmentMorph newRow
		borderWidth: 0;
		layoutInset: 0;
		color: Color transparent;
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		wrapCentering: #center; cellPositioning: #leftCenter.
	aStringOrTextOrMorph isMorph
		ifTrue: [
			label _ aStringOrTextOrMorph.
			r addMorph: aStringOrTextOrMorph]
		ifFalse: [
			label _ aStringOrTextOrMorph asString.
			r addMorph: (StringMorph contents: label font: aFont)].
	self addMorph: r.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 16:52'!
model: anObject
	"Set my model and make me me a dependent of the given object."

	model ifNotNil: [model removeDependent: self].
	anObject ifNotNil: [anObject addDependent: self].
	model _ anObject.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 10/25/1999 14:36'!
offColor
	^ offColor
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 12/28/2000 16:19'!
offColor: colorWhenOff
	"Set the fill colors to be used when this button is off."

	self onColor: onColor offColor: colorWhenOff
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 16:29'!
onColor: colorWhenOn offColor: colorWhenOff
	"Set the fill colors to be used when this button is on/off."

	onColor _ colorWhenOn.
	offColor _ colorWhenOff.
	self update: nil.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 2/17/2002 05:29'!
performAction
	"Inform the model that this button has been pressed. Sent by the controller when this button is pressed. If the button's actionSelector takes any arguments, they are obtained dynamically by sending the argumentSelector to the argumentsProvider"

	askBeforeChanging ifTrue: [model okToChange ifFalse: [^ self]].
	actionSelector ifNotNil:
		[actionSelector numArgs == 0
			ifTrue:
				[model perform: actionSelector]
			ifFalse:
				[argumentsProvider ifNotNil:
					[arguments _ argumentsProvider perform: argumentsSelector].
					model perform: actionSelector withArguments: arguments]]! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'!
shortcutCharacter
	"Return the Character to be used as a shortcut to turn on this switch, or nil if this switch doesn't have a keyboard shortcut."

	^ shortcutCharacter
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'!
shortcutCharacter: aCharacter 
	"Set the character to be used as a keyboard shortcut for turning on this switch."

	shortcutCharacter _ aCharacter.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 19:26'!
triggerOnMouseDown

	^ triggerOnMouseDown
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/7/98 19:16'!
triggerOnMouseDown: aBoolean
	"If this preference is turned on, then trigger my action immediately when the mouse goes down."

	triggerOnMouseDown _ aBoolean.
! !


!PluggableButtonMorph methodsFor: 'arguments' stamp: 'sw 2/17/2002 01:03'!
arguments: args
	"If the receiver takes argument(s) that are static, they can be filled by calling this.  If its argument(s) are to be dynamically determined, then use an argumentProvider and argumentSelector instead"

	arguments _ args! !

!PluggableButtonMorph methodsFor: 'arguments' stamp: 'sw 2/17/2002 05:29'!
argumentsProvider: anObject argumentsSelector: aSelector
	"Set the argument provider and selector"

	argumentsProvider _ anObject.
	argumentsSelector _ aSelector! !


!PluggableButtonMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 16:53'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
model _ deepCopier references at: model ifAbsent: [model].
! !

!PluggableButtonMorph methodsFor: 'copying' stamp: 'sw 2/17/2002 05:29'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"model _ model.		Weakly copied"
label _ label veryDeepCopyWith: deepCopier.
"getStateSelector _ getStateSelector.		a Symbol"
"actionSelector _ actionSelector.		a Symbol"
"getLabelSelector _ getLabelSelector.		a Symbol"
"getMenuSelector _ getMenuSelector.		a Symbol"
shortcutCharacter _ shortcutCharacter veryDeepCopyWith: deepCopier.
askBeforeChanging _ askBeforeChanging veryDeepCopyWith: deepCopier.
triggerOnMouseDown _ triggerOnMouseDown veryDeepCopyWith: deepCopier.
offColor _ offColor veryDeepCopyWith: deepCopier.
onColor _ onColor veryDeepCopyWith: deepCopier.
feedbackColor _ feedbackColor veryDeepCopyWith: deepCopier.
showSelectionFeedback _ showSelectionFeedback veryDeepCopyWith: deepCopier.
allButtons _ nil.		"a cache"
arguments _ arguments veryDeepCopyWith: deepCopier.
argumentsProvider _ argumentsProvider veryDeepCopyWith: deepCopier.
argumentsSelector _ argumentsSelector.  " a Symbol" ! !


!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jm 5/4/1998 17:46'!
drawOn: aCanvas 

	super drawOn: aCanvas.
	showSelectionFeedback ifTrue: [
		aCanvas frameRectangle: self innerBounds width: 2 color: feedbackColor].
! !


!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 16:57'!
handlesMouseDown: evt

	^ true
! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jrp 7/3/2005 18:13'!
handlesMouseOverDragging: evt

	^ true! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jrp 7/2/2005 10:44'!
handlesMouseOver: evt

	^ true! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/20/1998 11:49'!
mouseDown: evt
	"Details: If this button is triggered on mouse down or the event is the menu gesture, handle it immediately. Otherwise, make a list of buttons (including the receiver) for mouseMove feedback. This allows a simple radio-button effect among the button submorphs of a given morph."

	allButtons _ nil.
	evt yellowButtonPressed ifTrue: [^ self invokeMenu: evt].
	triggerOnMouseDown
		ifTrue: [self performAction]
		ifFalse: [
			allButtons _ owner submorphs select: [:m | m class = self class].
			self updateFeedbackForEvt: evt].
! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jrp 7/2/2005 10:59'!
mouseEnter: evt

	"0.09375 is exact in floating point so no cumulative rounding error will occur"
	self color: (self color adjustBrightness: -0.09375)! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jrp 7/3/2005 18:13'!
mouseLeaveDragging: evt

	self mouseLeave: evt! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jrp 7/2/2005 16:21'!
mouseLeave: evt

	"0.09375 is exact in floating point so no cumulative rounding error will occur"
	self color: (self color adjustBrightness: 0.09375).
	self update: nil! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 17:30'!
mouseMove: evt

	allButtons ifNil: [^ self].
	allButtons do: [:m | m updateFeedbackForEvt: evt].
! !

!PluggableButtonMorph methodsFor: 'event handling' stamp: 'ar 8/16/2001 11:24'!
mouseUp: evt

	showSelectionFeedback _ false.
	borderColor isColor ifFalse:[borderColor _ #raised].
	allButtons ifNil: [^ self].
	allButtons do: [:m |
		(m containsPoint: evt cursorPoint) ifTrue: [m performAction]].
	allButtons _ nil.
	self changed.
! !


!PluggableButtonMorph methodsFor: 'events' stamp: 'ar 8/16/2001 11:24'!
updateFeedbackForEvt: evt

	| newState |
	newState _ self containsPoint: evt cursorPoint.
	newState = showSelectionFeedback ifFalse: [
		borderColor isColor
			ifTrue:[showSelectionFeedback _ newState]
			ifFalse:[borderColor _ newState ifTrue:[#inset] ifFalse:[#raised]].
		self changed].
! !


!PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGreen! !


!PluggableButtonMorph methodsFor: 'initialize-release' stamp: 'jrp 7/28/2005 22:42'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap.
	"<--so naked buttons work right"
	self vResizing: #shrinkWrap.
	self wrapCentering: #center;
		 cellPositioning: #topCenter.
	self borderStyle: BorderStyle thinGray.
	model _ nil.
	label _ nil.
	getStateSelector _ nil.
	actionSelector _ nil.
	getLabelSelector _ nil.
	getMenuSelector _ nil.
	shortcutCharacter _ nil.
	askBeforeChanging _ false.
	triggerOnMouseDown _ false.
	onColor _ self color darker.
	offColor _ self color.
	feedbackColor _ Color red.
	showSelectionFeedback _ false.
	allButtons _ nil.
	argumentsProvider _ nil.
	argumentsSelector _ nil.
	self extent: 20 @ 15! !

!PluggableButtonMorph methodsFor: 'initialize-release' stamp: 'gk 9/22/2003 09:10'!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	self model: anObject.
	getStateSelector _ getStateSel.
	actionSelector _ actionSel.
	getLabelSelector _ labelSel.
	getMenuSelector _ menuSel.
	self update: labelSel.
! !


!PluggableButtonMorph methodsFor: 'updating' stamp: 'jm 5/4/1998 17:53'!
update: aParameter 

	getLabelSelector ifNotNil: [
		aParameter == getLabelSelector ifTrue: [
			self label: (model perform: getLabelSelector)]].
	self getModelState
		ifTrue: [self color: onColor]
		ifFalse: [self color: offColor].
! !


!PluggableButtonMorph methodsFor: '*omnibrowser' stamp: 'cwp 2/24/2004 19:07'!
isOn
	^ self color = onColor! !


!PluggableButtonMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:40'!
getMenu: shiftPressed 
	"Answer the menu for this button, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| menu |
	getMenuSelector isNil ifTrue: [^nil].
	menu := MenuMorph new defaultTarget: model.
	getMenuSelector numArgs = 1 
		ifTrue: [^model perform: getMenuSelector with: menu].
	getMenuSelector numArgs = 2 
		ifTrue: 
			[^model 
				perform: getMenuSelector
				with: menu
				with: shiftPressed].
	^self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!PluggableButtonMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:41'!
getModelState
	"Answer the result of sending the receiver's model the getStateSelector message."

	^ getStateSelector isNil 
		ifTrue: [false]
		ifFalse: [model perform: getStateSelector]! !

!PluggableButtonMorph methodsFor: 'private' stamp: 'RAA 6/12/2000 09:04'!
invokeMenu: evt
	"Invoke my menu in response to the given event."
	| menu |
	menu _ self getMenu: evt shiftPressed.
	menu ifNotNil: [menu popUpEvent: evt in: self world]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableButtonMorph class
	instanceVariableNames: ''!

!PluggableButtonMorph class methodsFor: 'example' stamp: 'RAA 1/17/2001 14:32'!
example
	"PluggableButtonMorph example openInWorld"

	| s1 s2 s3 b1 b2 b3 row |
	s1 _ Switch new.
	s2 _ Switch new turnOn.
	s3 _ Switch new.
	s2 onAction: [s3 turnOff].
	s3 onAction: [s2 turnOff].
	b1 _ (PluggableButtonMorph on: s1 getState: #isOn action: #switch) label: 'S1'.
	b2 _ (PluggableButtonMorph on: s2 getState: #isOn action: #turnOn) label: 'S2'.
	b3 _ (PluggableButtonMorph on: s3 getState: #isOn action: #turnOn) label: 'S3'.
	b1
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	b2
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	b3
		hResizing: #spaceFill;
		vResizing: #spaceFill.

	row _ AlignmentMorph newRow
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		addAllMorphs: (Array with: b1 with: b2 with: b3);
		extent: 120@35.
	^ row
! !


!PluggableButtonMorph class methodsFor: 'instance creation'!
on: anObject

	^ self on: anObject getState: #isOn action: #switch
! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:28'!
on: anObject getState: getStateSel action: actionSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: nil
		menu: nil
! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:28'!
on: anObject getState: getStateSel action: actionSel label: labelSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		menu: nil
! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:29'!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		menu: menuSel
! !
PluggableButtonMorph subclass: #PluggableButtonMorphPlus
	instanceVariableNames: 'enabled action getColorSelector getEnabledSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!PluggableButtonMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0!
An extended version of PluggableButtonMorph supporting enablement, color and block/message actions.!


!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 20:53'!
action
	^action! !

!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 20:55'!
action: anAction	
	action := nil.
	anAction isSymbol ifTrue:[^super action: anAction].
	action := anAction.! !

!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:52'!
enabled
	^enabled! !

!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'bf 5/27/2005 19:42'!
enabled: aBool
	enabled := aBool.
	enabled 
		ifFalse:[self color: Color gray]
		ifTrue:[self getModelState
			ifTrue: [self color: onColor]
			ifFalse: [self color: offColor]]! !

!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:36'!
getColorSelector
	^getColorSelector! !

!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:36'!
getColorSelector: aSymbol
	getColorSelector := aSymbol.
	self update: getColorSelector.! !

!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:51'!
getEnabledSelector
	^getEnabledSelector! !

!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 6/21/2005 11:01'!
getEnabledSelector: aSymbol
	getEnabledSelector := aSymbol.
	self update: aSymbol.! !

!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:35'!
onColor: colorWhenOn offColor: colorWhenOff
	"Set the fill colors to be used when this button is on/off."

	onColor := colorWhenOn.
	offColor := colorWhenOff.
	self update: getStateSelector.! !


!PluggableButtonMorphPlus methodsFor: 'action' stamp: 'ar 2/11/2005 19:52'!
mouseDown: evt
	enabled ifFalse:[^self].
	^super mouseDown: evt! !

!PluggableButtonMorphPlus methodsFor: 'action' stamp: 'ar 2/11/2005 19:52'!
mouseMove: evt
	enabled ifFalse:[^self].
	^super mouseMove: evt! !

!PluggableButtonMorphPlus methodsFor: 'action' stamp: 'ar 2/11/2005 19:53'!
mouseUp: evt
	enabled ifFalse:[^self].
	^super mouseUp: evt! !

!PluggableButtonMorphPlus methodsFor: 'action' stamp: 'ar 2/11/2005 20:54'!
performAction
	enabled ifFalse:[^self].
	action ifNotNil:[^action value].
	^super performAction! !


!PluggableButtonMorphPlus methodsFor: 'initialize-release' stamp: 'ar 2/12/2005 14:23'!
beActionButton
	"Make me like an action button"
	self borderWidth: 2.
	self borderColor: #raised.
	self onColor: Color transparent offColor: Color transparent.
	self cornerStyle: #rounded.! !

!PluggableButtonMorphPlus methodsFor: 'initialize-release' stamp: 'ar 2/11/2005 21:56'!
initialize
	super initialize.
	enabled := true.
	self color: Color transparent.! !


!PluggableButtonMorphPlus methodsFor: 'updating' stamp: 'ar 2/11/2005 21:39'!
update: what
	what ifNil:[^self].
	what == getLabelSelector ifTrue: [
		self label: (model perform: getLabelSelector)].
	what == getColorSelector ifTrue: [
		color := (model perform: getColorSelector).
		self onColor: color offColor: color.
		self changed.
	].
	what == getStateSelector ifTrue:[
		self getModelState
			ifTrue: [self color: onColor]
			ifFalse: [self color: offColor].
	].
	what == getEnabledSelector ifTrue:[^self enabled: (model perform: getEnabledSelector)].! !
PluggableWidgetSpec subclass: #PluggableButtonSpec
	instanceVariableNames: 'action label state enabled color help'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableButtonSpec commentStamp: 'ar 2/11/2005 21:57' prior: 0!
A button, both for firing as well as used in radio-button style (e.g., carrying a selection).

Instance variables:
	action	<Symbol>	The action to perform when the button is fired.
	label	<Symbol|String>	The selector for retrieving the button's label or label directly.
	state	<Symbol>	The selector for retrieving the button's selection state.
	enabled	<Symbo>		The selector for retrieving the button's enabled state.
	color	<Symbo>		The selector for retrieving the button color.
	help	<String>		The balloon help for the button.!


!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:20'!
action
	"Answer the action to be performed by the receiver"
	^action! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:20'!
action: aSymbol
	"Indicate the action to be performed by the receiver"
	action := aSymbol! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:50'!
color
	"Answer the selector for retrieving the button's color"
	^color! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:50'!
color: aSymbol
	"Indicate the selector for retrieving the button's color"
	color := aSymbol! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 6/21/2005 10:41'!
enabled
	"Answer the selector for retrieving the button's enablement"
	^enabled ifNil:[true]! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 14:39'!
enabled: aSymbol
	"Indicate the selector for retrieving the button's enablement"
	enabled := aSymbol! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 21:14'!
help
	"Answer the help text for this button"
	^help! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 21:14'!
help: aString
	"Indicate the help text for this button"
	help := aString.! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:18'!
label
	"Answer the label (or the selector for retrieving the label)"
	^label! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:44'!
label: aSymbol
	"Indicate the selector for retrieving the label"
	label := aSymbol.! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:19'!
state
	"Answer the selector for retrieving the button's state"
	^state! !

!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:44'!
state: aSymbol
	"Indicate the selector for retrieving the button's state"
	state := aSymbol.! !


!PluggableButtonSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableButton: self! !
View subclass: #PluggableButtonView
	instanceVariableNames: 'label getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown complemented argumentsProvider argumentsSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableButtonView commentStamp: '<historical>' prior: 0!
A PluggableButtonView is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are:

		getStateSelector		fetch a boolean value from the model
		actionSelector		invoke this button's action on the model

Either of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false.

The model informs a pluggable view of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector.

Options:
	askBeforeChanging		have model ask user before allowing change that could lose edits
	triggerOnMouseDown	do button action on mouse down (vs. up) transition
	shortcutCharacter		a place to record an optional shortcut key

!


!PluggableButtonView methodsFor: 'accessing' stamp: 'jrm 6/1/1998 21:53'!
action: aSymbol 
	"Set actionSelector to be the action defined by aSymbol."

	actionSelector _ aSymbol
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 18:53'!
askBeforeChanging

	^ askBeforeChanging
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/7/98 19:17'!
askBeforeChanging: aBoolean
	"If this preference is turned on, then give the model an opportunity to ask the user before accepting a change that might cause unaccepted edits to be lost."

	askBeforeChanging _ aBoolean.
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 17:38'!
label
	"Answer the DisplayObject used as this button's label."

	^ label
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'nk 4/17/2004 19:49'!
label: aStringOrDisplayObject 
	"Label this button with the given String or DisplayObject."

	((aStringOrDisplayObject isKindOf: Paragraph)
	or: [aStringOrDisplayObject isForm])
		ifTrue: [label _ aStringOrDisplayObject]
		ifFalse: [label _ aStringOrDisplayObject asParagraph].
	self centerLabel.
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'!
shortcutCharacter
	"Return the Character to be used as a shortcut to turn on this switch, or nil if this switch doesn't have a keyboard shortcut."

	^ shortcutCharacter
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'!
shortcutCharacter: aCharacter 
	"Set the character to be used as a keyboard shortcut for turning on this switch."

	shortcutCharacter _ aCharacter.
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 19:26'!
triggerOnMouseDown

	^ triggerOnMouseDown
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/7/98 19:16'!
triggerOnMouseDown: aBoolean
	"If this preference is turned on, then trigger my action immediately when the mouse goes down."

	triggerOnMouseDown _ aBoolean.
! !


!PluggableButtonView methodsFor: 'controller access' stamp: 'jm 4/2/98 17:39'!
defaultControllerClass 

	^ PluggableButtonController
! !


!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/2/98 18:49'!
deEmphasizeView 

	self getModelState ifTrue: [self displayNormal].
! !

!PluggableButtonView methodsFor: 'displaying'!
display
	"Sets the PluggableButtonView mode to 'normal', displays the border, displays the inside and, if its model is 'on', complements the inside."

	self displayBorder.
	self displayView.
! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/4/98 20:49'!
displayComplemented
	"Complement the receiver if it isn't already."

	complemented ifFalse: [
		complemented _ true.
		Display reverse: self insetDisplayBox].
! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/2/98 18:43'!
displayNormal
	"Complement the receiver if its mode is 'complemented'."

	complemented ifTrue: [
		complemented _ false.
		Display reverse: self insetDisplayBox].
! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'acg 2/23/2000 00:18'!
displayView

	"Displays this switch and its label, if any."

	self clearInside.
	label ifNotNil: [
		(label isKindOf: Paragraph) ifTrue: [
			label foregroundColor: self foregroundColor
				 backgroundColor: self backgroundColor].
		label displayOn: Display
				at: label boundingBox topLeft
				clippingBox: self insetDisplayBox].
	complemented _ false.! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/4/98 20:41'!
emphasizeView 

	self getModelState ifTrue: [self displayComplemented].
! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/5/98 12:54'!
toggleMouseOverFeedback
	"Complement the label (or a portion of the displayBox if no label is defined) to show that the mouse is over this button. This feedback can be removed by a second call to this method."

	Display reverse: self insetDisplayBox fillColor: Color gray.
	Display reverse: (self insetDisplayBox insetBy: 2) fillColor: Color gray.
! !


!PluggableButtonView methodsFor: 'initialize-release' stamp: 'jm 5/2/1998 15:20'!
initialize

 	super initialize.
	label _ nil.
	getStateSelector _ nil.
	actionSelector _ nil.
	getLabelSelector _ nil.
	getMenuSelector _ nil.
	shortcutCharacter _ nil.
	askBeforeChanging _ false.
	triggerOnMouseDown _ false.
	complemented _ false.
! !

!PluggableButtonView methodsFor: 'initialize-release' stamp: 'sw 2/17/2002 05:32'!
on: anObject getState: getStateSel action: actionSel getArguments: getArgumentsSel from: argsProvidor label: labelSel menu: menuSel

	self initialize.
	self model: anObject.
	getStateSelector _ getStateSel.
	actionSelector _ actionSel.
	argumentsSelector _ getArgumentsSel.
	argumentsProvider _ argsProvidor.
	getLabelSelector _ labelSel.
	getMenuSelector _ menuSel! !

!PluggableButtonView methodsFor: 'initialize-release' stamp: 'tk 4/29/1998 11:18'!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	self initialize.
	self model: anObject.
	getStateSelector _ getStateSel.
	actionSelector _ actionSel.
	getLabelSelector _ labelSel.
	getMenuSelector _ menuSel.! !


!PluggableButtonView methodsFor: 'other' stamp: 'jm 4/7/98 19:12'!
defaultWindow
	"Return a rectangle large enough to contain this button's label. If this button is label-less, just return the standard View default window."

	label == nil
		ifTrue: [^ super defaultWindow]
		ifFalse: [^ label boundingBox expandBy: 6].
! !

!PluggableButtonView methodsFor: 'other' stamp: 'sw 2/17/2002 05:32'!
performAction
	"Inform the model that this button has been pressed. Sent by the controller when this button is pressed."

	argumentsSelector
		ifNil:
			[actionSelector ifNotNil:
				[model perform: actionSelector]]
		ifNotNil:
			[model perform: actionSelector
				withArguments:
					(Array with: (argumentsProvider perform: argumentsSelector))]! !

!PluggableButtonView methodsFor: 'other' stamp: 'tk 4/27/1998 21:23'!
update: aParameter 

	aParameter == getLabelSelector ifTrue: [
		getLabelSelector ifNotNil: [
			self label: (model perform: getLabelSelector).
			self displayView]].
	self getModelState 
		ifTrue: [self displayComplemented]
		ifFalse: [self displayNormal].
! !

!PluggableButtonView methodsFor: 'other' stamp: 'jm 4/7/98 19:12'!
window: aWindow
	"Center my label when my window changes."

	super window: aWindow.
	self centerLabel.
! !


!PluggableButtonView methodsFor: 'private' stamp: 'nk 4/17/2004 19:49'!
centerAlignLabelWith: aPoint
	"Align the center of the label with aPoint."

	| alignPt |
	alignPt _ label boundingBox center.
	(label isKindOf: Paragraph) ifTrue: 
		[alignPt _ alignPt + (0@(label textStyle leading))]. 
	(label isForm)
	  ifTrue: [label offset: 0 @ 0].
	label align: alignPt with: aPoint
! !

!PluggableButtonView methodsFor: 'private' stamp: 'acg 2/23/2000 00:10'!
centerLabel
	"If there is a label, align its center with the center of the insetDisplayBox"

	label ifNotNil: 
		[self centerAlignLabelWith: self insetDisplayBox center].
! !

!PluggableButtonView methodsFor: 'private' stamp: 'di 6/26/1998 11:04'!
getMenu: shiftKeyDown
	"Answer the menu for this view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| menu |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ CustomMenu new.
	getMenuSelector numArgs = 1
		ifTrue: [^ model perform: getMenuSelector with: menu].
	getMenuSelector numArgs = 2
		ifTrue: [^ model perform: getMenuSelector with: menu with: shiftKeyDown].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'
! !

!PluggableButtonView methodsFor: 'private' stamp: 'jm 4/4/98 20:50'!
getModelState
	"Answer the result of sending the receiver's model the getStateSelector message."

	getStateSelector == nil
		ifTrue: [^ false]
		ifFalse: [^ model perform: getStateSelector].
! !

!PluggableButtonView methodsFor: 'private' stamp: 'acg 2/23/2000 00:09'!
insetDisplayBox
	"Answer the receiver's inset display box. The inset display box is the 
	intersection of the receiver's window, tranformed to display coordinates, 
	and the inset display box of the superView, inset by the border width. 
	The inset display box represents the region of the display screen in 
	which the inside of the receiver (all except the border) is displayed. If 
	the receiver is totally clipped by the display screen and its superView, 
	the resulting Rectangle will be invalid."

	insetDisplayBox ifNil: 
		[insetDisplayBox _ self computeInsetDisplayBox.
		 self centerLabel].
	^insetDisplayBox! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableButtonView class
	instanceVariableNames: ''!

!PluggableButtonView class methodsFor: 'example' stamp: 'jm 4/7/98 19:55'!
example
	"PluggableButtonView example"

	| s1 s2 s3 b1 b2 b3 topView |
	s1 _ Switch new.
	s2 _ Switch new turnOn.
	s3 _ Switch new.
	s2 onAction: [s3 turnOff].
	s3 onAction: [s2 turnOff].
	b1 _ (PluggableButtonView on: s1 getState: #isOn action: #switch) label: 'S1'.
	b2 _ (PluggableButtonView on: s2 getState: #isOn action: #turnOn) label: 'S2'.
	b3 _ (PluggableButtonView on: s3 getState: #isOn action: #turnOn) label: 'S3'.
	b1 borderWidth: 1.
	b2 borderWidth: 1.
	b3 borderWidth: 1.
	topView _ StandardSystemView new
		label: 'Switch Test';
		addSubView: b1;
		addSubView: b2 toRightOf: b1;
		addSubView: b3 toRightOf: b2.
	topView controller open.
! !


!PluggableButtonView class methodsFor: 'instance creation' stamp: 'jm 8/14/1998 16:19'!
on: anObject

	^ self on: anObject getState: #isOn action: #switch
! !

!PluggableButtonView class methodsFor: 'instance creation' stamp: 'tk 4/29/1998 11:19'!
on: anObject getState: getStateSel action: actionSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: nil
		menu: nil! !

!PluggableButtonView class methodsFor: 'instance creation' stamp: 'sumim 2/15/2002 17:18'!
on: anObject getState: getStateSel action: actionSel getArguments: getArgumentsSel from: argsProvidor

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		getArguments: getArgumentsSel
		from: argsProvidor
		label: nil
		menu: nil! !

!PluggableButtonView class methodsFor: 'instance creation' stamp: 'tk 4/29/1998 11:19'!
on: anObject getState: getStateSel action: actionSel label: labelSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		menu: nil! !

!PluggableButtonView class methodsFor: 'instance creation' stamp: 'tk 4/29/1998 11:18'!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		menu: menuSel! !
Canvas subclass: #PluggableCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!PluggableCanvas commentStamp: '<historical>' prior: 0!
An abstract canvas which modifies the behavior of an underlying canvas in some way.  Subclasses should implement apply:, which takes a one argument block and an actual canvas to draw on.  See apply: for the specific definition.!


!PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:02'!
clipRect
	| innerClipRect |
	self apply: [ :c |
		innerClipRect := c clipRect ].
	^innerClipRect! !

!PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/26/2000 13:57'!
contentsOfArea: aRectangle into: aForm
	self apply: [ :c |
		c contentsOfArea: aRectangle into: aForm ].
	^aForm! !

!PluggableCanvas methodsFor: 'accessing' stamp: 'RAA 8/13/2000 18:56'!
extent

	self apply: [ :c | ^c extent ].
! !

!PluggableCanvas methodsFor: 'accessing' stamp: 'RAA 8/13/2000 18:57'!
origin

	self apply: [ :c | ^c origin ].
! !

!PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:14'!
shadowColor: color
	self apply: [ :c |
		c shadowColor: color ]! !


!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 11/6/2000 16:33'!
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc

	self apply: [ :c | 
		c balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/28/2000 06:52'!
balloonFillRectangle: aRectangle fillStyle: aFillStyle

	self apply: [ :c | c balloonFillRectangle: aRectangle fillStyle: aFillStyle ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 8/25/2000 13:34'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self apply: [ :c | c infiniteFillRectangle: aRectangle fillStyle: aFillStyle ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/25/2000 15:53'!
showAt: pt invalidRects: updateRects
	self apply: [ :c |
		c showAt: pt invalidRects: updateRects ]! !


!PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:31'!
line: pt1 to: pt2 brushForm: brush
	self apply: [ :c |
		c line: pt1 to: pt2 brushForm: brush ]! !

!PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:31'!
line: pt1 to: pt2 width: w color: c
	self apply: [ :clippedCanvas |
		clippedCanvas line: pt1 to: pt2 width: w color: c ]! !

!PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:33'!
paragraph: paragraph bounds: bounds color: color
	self apply: [ :c |
		c paragraph: paragraph bounds: bounds color: color ]! !

!PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:34'!
render: anObject
	self apply: [ :c |
		c render: anObject ]! !


!PluggableCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:46'!
roundCornersOf: aMorph in: bounds during: aBlock
	aMorph wantsRoundedCorners ifFalse:[^aBlock value].
	(self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds))
		ifTrue: ["Don't bother with corner logic if the region is inside them"
				^ aBlock value].
	CornerRounder roundCornersOf: aMorph on: self in: bounds
		displayBlock: aBlock
		borderWidth: aMorph borderWidthForRounding
		corners: aMorph roundedCorners! !


!PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:32'!
paintImage: aForm at: aPoint
	self apply: [ :c |
		c paintImage: aForm at: aPoint ]! !

!PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:32'!
paintImage: aForm at: aPoint sourceRect: sourceRect
	self apply: [ :c |
		c paintImage: aForm at: aPoint sourceRect: sourceRect ]! !

!PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:35'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	self apply: [ :c |
		c stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]! !


!PluggableCanvas methodsFor: 'drawing-ovals' stamp: 'ls 3/20/2000 20:03'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	self apply: [ :clippedCanvas |
		clippedCanvas fillOval: r color: c borderWidth: borderWidth borderColor: borderColor ]! !

!PluggableCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 16:32'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval."
	self shadowColor ifNotNil:
		[^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
	(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
		self flag: #fixThis.
		^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc].
	(aFillStyle isSolidFill) ifTrue:[
		^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
	"Use a BalloonCanvas instead"
	self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! !


!PluggableCanvas methodsFor: 'drawing-polygons' stamp: 'ls 3/20/2000 20:01'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	self apply: [ :c |
		c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]! !


!PluggableCanvas methodsFor: 'drawing-rectangles' stamp: 'RAA 8/25/2000 14:40'!
fillRectangle: aRectangle fillStyle: aFillStyle

	| pattern |

	self shadowColor ifNotNil: [^self fillRectangle: aRectangle color: self shadowColor].

	(aFillStyle isKindOf: InfiniteForm) ifTrue: [
		^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	].

	aFillStyle isSolidFill ifTrue:[ ^self fillRectangle: aRectangle color: aFillStyle asColor].

	"We have a very special case for filling with infinite forms"
	(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
		pattern _ aFillStyle form.
		(aFillStyle direction = (pattern width @ 0) 
			and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
				"Can use an InfiniteForm"
				^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
	].
	"Use a BalloonCanvas instead"
	self balloonFillRectangle: aRectangle fillStyle: aFillStyle.
! !

!PluggableCanvas methodsFor: 'drawing-rectangles' stamp: 'ls 3/20/2000 20:04'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	self apply: [ :c |
		c frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor ]! !


!PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 19:59'!
clipBy: newClipRect during: aBlock
	self apply: [ :c |
		c clipBy: newClipRect during: aBlock ]! !

!PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 20:35'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	self apply: [ :clippedCanvas |
		clippedCanvas transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize ]! !

!PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 20:37'!
translateBy: delta during: aBlock
	self apply: [ :clippedCanvas |
		 clippedCanvas translateBy: delta during: aBlock ]! !


!PluggableCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	self apply: [ :clippedCanvas |
		clippedCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! !


!PluggableCanvas methodsFor: 'initialization' stamp: 'ls 3/20/2000 21:16'!
flush
	self apply: [ :c |
		c flush ]! !


!PluggableCanvas methodsFor: 'other' stamp: 'ls 3/20/2000 21:16'!
flushDisplay
	self apply: [ :c |
		c flushDisplay ]! !

!PluggableCanvas methodsFor: 'other' stamp: 'RAA 7/20/2000 16:49'!
forceToScreen: rect

	self apply: [ :c |
		c forceToScreen: rect ]! !

!PluggableCanvas methodsFor: 'other' stamp: 'ls 3/20/2000 20:37'!
translateBy: aPoint clippingTo: aRect during: aBlock
	self apply: [ :clippedCanvas |
		clippedCanvas translateBy: aPoint clippingTo: aRect during: aBlock ]! !


!PluggableCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:46'!
apply: aBlock
	"evaluate aBlock with a canvas to do a drawing command on.  See implementors for examples"! !

!PluggableCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:30'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	self apply:  [ :c |
		c image: aForm at: aPoint sourceRect: sourceRect rule: rule ]! !
PluggableButtonSpec subclass: #PluggableCheckBoxSpec
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableCheckBoxSpec commentStamp: 'ar 2/12/2005 23:13' prior: 0!
PluggableCheckBox is intended as a HINT for the builder that this widget will be used as check box. Unless explicitly supported it will be automatically substituted by PluggableButton.!


!PluggableCheckBoxSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableCheckBox: self! !
PluggableWidgetSpec subclass: #PluggableCompositeSpec
	instanceVariableNames: 'children layout'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableCompositeSpec commentStamp: 'ar 2/11/2005 21:58' prior: 0!
A composite user interface element.

Instance variables:
	children	<Symbol|Collection>	Symbol to retrieve children or children directly
	layout	<Symbol> The layout for this composite.
!


!PluggableCompositeSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:19'!
children
	"Answer the selector to retrieve this panel's children"
	^children! !

!PluggableCompositeSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:19'!
children: aSymbol
	"Indicate the selector to retrieve this panel's children"
	children := aSymbol! !

!PluggableCompositeSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:33'!
layout
	"Answer the symbol indicating the layout of the composite:
		#proportional (default): Use frames as appropriate.
		#horizontal: Arrange the elements horizontally
		#vertical: Arrange the elements vertically.
	"
	^layout ifNil:[#proportional]! !

!PluggableCompositeSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:17'!
layout: aSymbol
	"Answer the symbol indicating the layout of the composite:
		#proportional (default): Use frames as appropriate.
		#horizontal: Arrange the elements horizontally
		#vertical: Arrange the elements vertically.
	"
	layout := aSymbol! !
Dictionary subclass: #PluggableDictionary
	instanceVariableNames: 'hashBlock equalBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!PluggableDictionary commentStamp: '<historical>' prior: 0!
Class PluggableDictionary allows the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the dictionary. See the class comment of PluggableSet for an example.

Instance variables:
	hashBlock	<BlockContext>	A one argument block used for hashing the elements.
	equalBlock	<BlockContext>	A two argument block used for comparing the elements.
!


!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'!
equalBlock
	"Return the block used for comparing the elements in the receiver."
	^equalBlock! !

!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'!
equalBlock: aBlock
	"Set a new equality block. The block must accept two arguments and return true if the argumets are considered to be equal, false otherwise"
	equalBlock _ aBlock.! !

!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'!
hashBlock
	"Return the block used for hashing the elements in the receiver."
	^hashBlock! !

!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'!
hashBlock: aBlock
	"Set a new hash block. The block must accept one argument and must return the hash value of the given argument."
	hashBlock _ aBlock.! !

!PluggableDictionary methodsFor: 'accessing' stamp: 'dvf 6/10/2000
19:34'!
keys
	"Answer a Set containing the receiver's keys."
	| aSet |
	aSet _ PluggableSet new: self size.
	self equalBlock ifNotNil: [aSet equalBlock: self equalBlock fixTemps].
	self hashBlock ifNotNil: [aSet hashBlock: self hashBlock fixTemps].
	self keysDo: [:key | aSet add: key].
	^ aSet! !


!PluggableDictionary methodsFor: 'copying' stamp: 'ar 11/12/1998 18:48'!
copy
	^super copy postCopyBlocks! !

!PluggableDictionary methodsFor: 'copying' stamp: 'dvf 6/10/2000 19:35'!
postCopyBlocks
	hashBlock _ hashBlock copy.
	equalBlock _ equalBlock copy.
	"Fix temps in case we're referring to outside stuff"
	hashBlock ifNotNil: [hashBlock fixTemps].
	equalBlock ifNotNil: [equalBlock fixTemps]! !


!PluggableDictionary methodsFor: 'private' stamp: 'dvf 6/11/2000 01:33'!
scanFor: anObject 
	"Scan the key array for the first slot containing either a nil
(indicating 
	  an empty slot) or an element that matches anObject. Answer the index 
	  
	of that slot or zero if no slot is found. This  method will be
overridden   
	in various subclasses that have different interpretations for matching 
 
	elements."
	| element start finish |
	start _ (hashBlock ifNil: [anObject hash]
				ifNotNil: [hashBlock value: anObject])
				\\ array size + 1.
	finish _ array size.
	"Search from (hash mod size) to the end."
	start to: finish do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element key = anObject]
				ifNotNil: [equalBlock value: element key value: anObject]])
			ifTrue: [^ index]].
	"Search from 1 to where we started."
	1 to: start - 1 do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element key = anObject]
				ifNotNil: [equalBlock value: element key value: anObject]])
			ifTrue: [^ index]].
	^ 0"No match AND no empty slot"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableDictionary class
	instanceVariableNames: ''!

!PluggableDictionary class methodsFor: 'as yet unclassified' stamp: 'dvf
6/10/2000 18:13'!
integerDictionary
	^ self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! !
FileList subclass: #PluggableFileList
	instanceVariableNames: 'accepted fileFilterBlock canAcceptBlock validateBlock newFiles prompt resultBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-FileList'!
!PluggableFileList commentStamp: '<historical>' prior: 0!
I am a model for a modal dialog akin to "Standard File Services" on various modern GUI operating systems.  My protocol includes some methods to maintain upward compatibility with StandardFileMenu, which I hope to replace.

Sample doIts:

	"StandardFileDialog getFolder"-- ask user to select folder, answer corresponding FileDirectory
	"StandardFileDialog getFile"	-- ask user to select file, answer corresponding FileStream
	"StandardFileDialog putFile"	-- ask user to create new file, answer FileStream

  In addition to the instance variables inhereted from FileList, of which I am a subclass, I am pluggable via the following instance variables:

prompt			<String>
	Display a prompt between the buttons.

resultBlock		<BlockContext>
	Passed a file directory and a file name, answer the result to be answered by the dialog.	

canAcceptBlock	<BlockContext>	
	Answer whether the accept button should be "active"

fileFilterBlock	<BlockContext>	
	Passed a file directory entry, answer whether the entry should be added to the list.  The list can be further filtered (but not expanded) by the user through the pattern.

validateBlock	<BlockContent>
	Passed a file directory entry, a file name and a collection of newly created files, answer whether the dialog selection is valid.  validateBlock is checked after the user has pressed accept, for example to ask if the user really meant to delete a file.

newFiles		<OrderedCollection>

	newFiles is an OrderedCollection of fileNames of files added by the user to the current directory since the user last entered same!


!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/9/2000 01:05'!
leftButtonPressed

	accepted _ false.
	self changed: #close.
! !

!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/14/2000 22:40'!
leftButtonState

	^true! !

!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/9/2000 00:38'!
result

	accepted ifFalse: [^nil].
	^resultBlock value: directory value: fileName! !

!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/10/2000 07:58'!
rightButtonPressed

	(canAcceptBlock value: directory value: fileName) ifFalse: [^nil].
	(validateBlock value: directory value: fileName value: newFiles) ifFalse: [^nil].
	accepted _ true.
	self changed: #close! !

!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/14/2000 22:43'!
rightButtonState

	^self canAccept! !


!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/13/2000 15:33'!
beAccepted

	^accepted _ true! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 09:10'!
canAccept

	^canAcceptBlock value: directory value: fileName! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:52'!
canAcceptBlock: aBlock

	^canAcceptBlock _ aBlock! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 07:33'!
fileFilterBlock: aBlock

	^fileFilterBlock _ aBlock! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/18/2000 21:21'!
fileListIndex

	self changed: #fileString.
	^super fileListIndex! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/18/2000 21:21'!
fileVolumeIndex

	self changed: #fileString.
	^super fileVolumeIndex! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:28'!
prompt: aString

	 prompt _ aString! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:31'!
resultBlock: aBlock

	^resultBlock _ aBlock! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/13/2000 15:28'!
validate

	^validateBlock value: directory value: fileName value: newFiles! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/10/2000 08:02'!
validateBlock: aBlock

	^validateBlock _ aBlock! !


!PluggableFileList methodsFor: 'file list menu' stamp: 'rbb 3/1/2005 11:07'!
addNew: aString byEvaluating: aBlock
	"A parameterization of earlier versions of #addNewDirectory and
	#addNewFile.  Fixes the bug in each that pushing the cancel button
	in the FillInTheBlank dialog gave a walkback."

	| response newName index ending |
	self okToChange ifFalse: [^ self].
	(response := UIManager default request: 'New ',aString,' Name?'
 					initialAnswer: aString,'Name')
		isEmpty ifTrue: [^ self].
	newName := response asFileName.
	Cursor wait showWhile: [
		aBlock value: newName].
	self updateFileList.
	index := list indexOf: newName.
	index = 0 ifTrue: [ending := ') ',newName.
		index := list findFirst: [:line | line endsWith: ending]].
	self fileListIndex: index.
	newFiles add: newName
! !

!PluggableFileList methodsFor: 'file list menu' stamp: 'asm 8/25/2003 18:37'!
fileSelectedMenu: aMenu
	| firstItems secondItems thirdItems n1 n2 n3 services |
	firstItems _ self itemsForFile: self fullName asLowercase.
	secondItems _ self itemsForAnyFile.
	thirdItems _ self itemsForNoFile.
	n1 _ firstItems size.
	n2 _ n1 + secondItems size.
	n3 _ n2 + thirdItems size.
	services _ firstItems, secondItems, thirdItems, 
			(OrderedCollection with: (SimpleServiceEntry provider: self label: 'more...' selector: #offerAllFileOptions)).
	^ aMenu 
		addServices2: services 
		for: self
		extraLines: (Array with: n1 with: n2 with: n3)
! !

!PluggableFileList methodsFor: 'file list menu' stamp: 'sma 11/11/2000 18:14'!
listForPattern: pat
	"Make the list be those file names which match the pattern."
	| entries sizePad newList allFiles |
	entries _ directory entries select: fileFilterBlock.
	sizePad _ (entries inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
					asStringWithCommas size - 1.

	newList _ (SortedCollection new: 30) sortBlock: self sortBlock.

	allFiles _ pat = '*'.
	entries do:
		[:entry | "<dirflag><name><creationTime><modificationTime><fileSize>"
		(allFiles or: [entry isDirectory or: [pat match: entry first]]) ifTrue:
			[newList add: entry]].

	newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].

	volList size = 1 ifTrue:
		["Include known servers along with other desktop volumes" 
		^ newList asArray ,
		(ServerDirectory serverNames collect: [:n | '^' , n , self folderString])].
	newFiles _ OrderedCollection new.
	^ newList asArray.! !


!PluggableFileList methodsFor: 'file string' stamp: 'acg 2/18/2000 21:23'!
fileString

	fileName ifNil: [^directory pathName].
	^directory fullNameFor: fileName! !

!PluggableFileList methodsFor: 'file string' stamp: 'acg 2/19/2000 01:02'!
fileString: aString

	"| textName index ending |
	textName _ aString asString.
	(FileDirectory default fileExists: textName) ifTrue:
		[self directory: (FileDirectory forFileName: textName).
		 index _ list indexOf: (FileDirectory localNameFor: textName).
		 index = 0 ifTrue: 
			[ending _ ') ', (FileDirectory localNameFor: textName).
		  	 index _ list findFirst: [:line | line endsWith: ending]].
		 self fileListIndex: index].
	(FileDirectory default directoryExists: textName) ifTrue:
		[self directory: (FileDirectory on: textName)]."
	self changed: #fileString.
	self changed: #contents.
	^true! !


!PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/12/2000 21:44'!
defaultBackgroundColor

	^Color lightYellow! !

!PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/12/2000 14:52'!
initialize

	prompt _ 'Select File'.
	directory _ FileDirectory default.
	newFiles _ OrderedCollection new.
	fileFilterBlock _ PluggableFileList allFilesAndFoldersFileFilter.
	canAcceptBlock _ PluggableFileList fileNameSelectedAcceptBlock.
	resultBlock _ PluggableFileList pathNameResultBlock.
	validateBlock _ PluggableFileList checkExistingFileValidateBlock.
! !

!PluggableFileList methodsFor: 'initialize-release' stamp: 'BG 8/27/2003 19:03'!
open
Smalltalk isMorphic 
	ifTrue:[^self openAsMorphLabel: prompt inWorld: self currentWorld]
	ifFalse: [^self openLabel: directory pathName]! !

!PluggableFileList methodsFor: 'initialize-release' stamp: 'BG 8/27/2003 22:58'!
openAsMorphLabel: aString inWorld: aWorld
	"Open a view of an instance of me."
	"PluggableFileList new openAsMorphLabel: 'foo' inWorld: World"
	| windowMorph volListMorph templateMorph fileListMorph leftButtonMorph middleButtonMorph rightButtonMorph |
	
	self directory: directory.
	windowMorph _ (SystemWindow labelled: aString) model: self.

	volListMorph _ PluggableListMorph on: self
		list: #volumeList
		selected: #volumeListIndex
		changeSelected: #volumeListIndex:
		menu: #volumeMenu:.
	volListMorph autoDeselect: false.
	windowMorph addMorph: volListMorph frame: (0@0 corner: 0.4@0.5625).

	templateMorph _ PluggableTextMorph on: self
		text: #pattern
		accept: #pattern:.
	templateMorph askBeforeDiscardingEdits: false.
	windowMorph addMorph: templateMorph frame: (0@0.5625 corner: 0.4@0.75).

	fileListMorph _ PluggableListMorph on: self
		list: #fileList
		selected: #fileListIndex
		changeSelected: #fileListIndex:
		menu: #fileListMenu:.

	windowMorph addMorph: fileListMorph frame: (0.4@0 corner: 1.0@0.75).

	leftButtonMorph _ PluggableButtonMorph 
		on: self
		getState: #leftButtonState
		action: #leftButtonPressed.
	leftButtonMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'Cancel';
		onColor: Color red offColor: Color red;
		feedbackColor: Color orange;
		borderWidth: 3.

	middleButtonMorph _ PluggableButtonMorph
		on: self
		getState: nil
		action: nil.
	middleButtonMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: prompt;
		onColor: Color lightYellow offColor: Color lightYellow;
		feedbackColor: Color lightYellow;
		borderWidth: 1.

	rightButtonMorph _ PluggableButtonMorph
		on: self
		getState: #rightButtonState
		action: #rightButtonPressed.
	rightButtonMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'Accept';
		onColor: Color green offColor: Color lightYellow;
		feedbackColor: Color black;
		borderWidth: (self canAccept ifTrue: [3] ifFalse: [1]).
	"self canAccept ifFalse: [rightButtonMorph controller: NoController new]."

	windowMorph
		addMorph: leftButtonMorph frame: (0@0.75 corner: 0.25@1.0);
		addMorph: middleButtonMorph frame: (0.25@0.75 corner: 0.75@1.0);
		addMorph: rightButtonMorph frame: (0.75@0.75 corner: 1.0@1.0).

	self changed: #getSelectionSel.

    windowMorph openInWorld: aWorld.
    [windowMorph model notNil]
       whileTrue: [aWorld doOneCycle].
    ^self result
! !

!PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/19/2000 01:10'!
openLabel: aString
	"Open a view of an instance of me."
	"StandardFileDialog new open"
	| topView volListView templateView fileListView fileStringView leftButtonView middleButtonView rightButtonView |
	
	self directory: directory.
	topView _ (PluggableFileListView new)
		model: self.

	volListView _ PluggableListView on: self
		list: #volumeList
		selected: #volumeListIndex
		changeSelected: #volumeListIndex:
		menu: #volumeMenu:.
	volListView autoDeselect: false.
	volListView window: (0@0 extent: 80@45).
	topView addSubView: volListView.

	templateView _ PluggableTextView on: self
		text: #pattern
		accept: #pattern:.
	templateView askBeforeDiscardingEdits: false.
	templateView window: (0@0 extent: 80@15).
	topView addSubView: templateView below: volListView.

	fileListView _ PluggableListView on: self
		list: #fileList
		selected: #fileListIndex
		changeSelected: #fileListIndex:
		menu: #fileListMenu:.
	fileListView window: (0@0 extent: 120@60).

	topView addSubView: fileListView toRightOf: volListView.

	fileListView controller terminateDuringSelect: true.  "Pane to left may change under scrollbar"

	"fileStringView _ PluggableTextView on: self
		text: #fileString
		accept: #fileString:.
	fileStringView askBeforeDiscardingEdits: false.
	fileStringView window: (0@0 extent: 200@15).
	topView addSubView: fileStringView below: templateView."
	fileStringView _ templateView.


	leftButtonView _ PluggableButtonView 
		on: self
		getState: nil
		action: #leftButtonPressed.
	leftButtonView
		label: 'Cancel';
		backgroundColor: Color red;
		borderWidth: 3;
		window: (0@0 extent: 50@15).

	middleButtonView _ PluggableButtonView
		on: self
		getState: nil
		action: nil.
	middleButtonView
		label: prompt;
		window: (0@0 extent: 100@15);
		borderWidth: 1;
		controller: NoController new.

	rightButtonView _ PluggableButtonView
		on: self
		getState: nil
		action: #rightButtonPressed.
	rightButtonView
		label: 'Accept';
		backgroundColor: (self canAccept ifTrue: [Color green] ifFalse: [Color lightYellow]);
		borderWidth: (self canAccept ifTrue: [3] ifFalse: [1]);
		window: (0@0 extent: 50@15).
	self canAccept ifFalse: [rightButtonView controller: NoController new].

	topView acceptButtonView: rightButtonView.

	topView
		addSubView: leftButtonView below: fileStringView;
		addSubView: middleButtonView toRightOf: leftButtonView;
		addSubView: rightButtonView toRightOf: middleButtonView.

	self changed: #getSelectionSel.
	topView doModalDialog.
	
	^self result
! !


!PluggableFileList methodsFor: 'StandardFileMenu' stamp: 'ar 3/18/2001 00:55'!
startUpWithCaption: captionOrNil
	"Display the menu, slightly offset from the cursor,
	so that a slight tweak is required to confirm any action."
	^ self startUpWithCaption: captionOrNil at: (ActiveHand ifNil:[Sensor cursorPoint]).! !

!PluggableFileList methodsFor: 'StandardFileMenu' stamp: 'acg 2/12/2000 15:35'!
startUpWithCaption: aString at: location

	self prompt: aString.
	^self open! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableFileList class
	instanceVariableNames: ''!

!PluggableFileList class methodsFor: 'canAcceptBlocks' stamp: 'acg 2/10/2000 08:18'!
alwaysAcceptBlock

	^[:theDirectory :theFileName | true]! !

!PluggableFileList class methodsFor: 'canAcceptBlocks' stamp: 'acg 2/10/2000 08:10'!
fileNameSelectedAcceptBlock

	^[:theDirectory :theFileName | theFileName isNil not]! !


!PluggableFileList class methodsFor: 'fileFilterBlocks' stamp: 'acg 2/10/2000 08:16'!
allFilesAndFoldersFileFilter

	^[:each | true]! !

!PluggableFileList class methodsFor: 'fileFilterBlocks' stamp: 'acg 2/10/2000 08:17'!
allFoldersFileFilter

	^[:each | each isDirectory]! !


!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'!
getFilePathNameDialog

	^(self new)
		validateBlock: PluggableFileList alwaysValidateBlock;
		yourself! !

!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'!
getFilePathNameDialogWithExistenceCheck

	^(self new)
		prompt: 'Select New File:';
		validateBlock: PluggableFileList checkExistingFileValidateBlock;
		yourself! !

!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'!
getFolderDialog

	^(self new)
		prompt: 'Select a Folder';
		fileFilterBlock: PluggableFileList allFoldersFileFilter;
		canAcceptBlock: PluggableFileList alwaysAcceptBlock;
		resultBlock: PluggableFileList directoryResultBlock;
		validateBlock: PluggableFileList alwaysValidateBlock;
		yourself! !

!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/9/2000 00:34'!
open

	^self new open! !


!PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:19'!
directoryResultBlock

	^[:theDirectory :theFileName | theDirectory]! !

!PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:07'!
fileNameResultBlock

	^[:theDirectory :theFileName | theFileName]! !

!PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:07'!
pathNameResultBlock

	^[:theDirectory :theFileName | 
		theFileName 
			ifNil: [theDirectory pathName]
			ifNotNil: [theDirectory fullNameFor: theFileName]].
! !

!PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/12/2000 15:08'!
sfmResultBlock

	^[:theDirectory :theFileName | 
		StandardFileMenuResult directory: theDirectory name: theFileName]! !


!PluggableFileList class methodsFor: 'StandardFileMenu' stamp: 'BG 12/13/2002 15:31'!
newFileMenu: aDirectory

	"For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult"
	^(self getFilePathNameDialogWithExistenceCheck)
		resultBlock: self sfmResultBlock;
		directory: aDirectory;
		yourself! !

!PluggableFileList class methodsFor: 'StandardFileMenu' stamp: 'BG 12/13/2002 15:32'!
oldFileMenu: aDirectory

	"For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult"
	^(self getFilePathNameDialog)
		resultBlock: self sfmResultBlock;
		directory: aDirectory;
		yourself! !


!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:24'!
getFile

	| result |
	result _ self getFilePathName.
	^result ifNotNil: [FileStream oldFileNamed: result]! !

!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:31'!
getFilePathName

	^self getFilePathNameDialog open! !

!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:29'!
getFilePathNameWithExistenceCheck

	^self getFilePathNameDialogWithExistenceCheck open! !

!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/9/2000 01:16'!
getFolder

	^self getFolderDialog open! !

!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:29'!
putFile

	| result |
	result _ self getFilePathNameWithExistenceCheck.
	^result ifNotNil: 
		[FileDirectory deleteFilePath: result.
		 FileStream newFileNamed: result]! !


!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/10/2000 08:27'!
alwaysValidateBlock

	^[:theDirectory :theFileName :theNewFiles | true].! !

!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/12/2000 14:52'!
checkExistingFileValidateBlock

	^[:theDirectory :theFileName :theNewFiles | 
		(theNewFiles includes: theFileName) or:
			[(PluggableFileList okToOverwrite: theFileName)]].! !

!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/12/2000 14:52'!
existingFileValidateBlock

	^[:theDirectory :theFileName :theNewFiles | 
		(theNewFiles includes: theFileName) or:
			[(PluggableFileList okToOverwrite: theFileName)]].! !

!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'rbb 2/18/2005 11:35'!
okToOpen: aFileNameString without: aSuffixString

	"Answer whether user confirms that it is ok to overwrite the file named in aString"
	^ 1 = (UIManager default 
				chooseFrom: #('overwrite that file' 'select another file')
				title:  aFileNameString, ' already exists.').
! !

!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'rbb 2/18/2005 11:36'!
okToOverwrite: aString

	"Answer whether user confirms that it is ok to overwrite the file named in aString"
	^ 1 = (UIManager default chooseFrom: #('overwrite that file' 'select another file')
			title:  aString, ' already exists.')
! !
ModalSystemWindowView subclass: #PluggableFileListView
	instanceVariableNames: 'acceptButtonView'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-FileList'!
!PluggableFileListView commentStamp: '<historical>' prior: 0!
I provide aview for PluggableFileList!


!PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 08:57'!
acceptButtonView: aView

	^acceptButtonView _ aView! !

!PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/18/2000 20:52'!
label: aString

	super label: aString.
	self noLabel! !

!PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 08:55'!
update: aSymbol
	(aSymbol = #volumeListIndex or: [aSymbol = #fileListIndex])
		ifTrue: [self updateAcceptButton].
	^super update: aSymbol! !

!PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 09:40'!
updateAcceptButton

	self model canAccept
		ifTrue:
			[acceptButtonView
				backgroundColor: Color green;
				borderWidth: 3;
				controller: acceptButtonView defaultController]
		ifFalse:
			[acceptButtonView
				backgroundColor: Color lightYellow;
				borderWidth: 1;
				controller: NoController new].
	acceptButtonView display.! !
PluggableTextSpec subclass: #PluggableInputFieldSpec
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableInputFieldSpec commentStamp: 'ar 2/12/2005 23:13' prior: 0!
PluggableInputField is intended as a HINT for the builder that this widget will be used as a single line input field. Unless explicitly supported it will be automatically substituted by PluggableText.!


!PluggableInputFieldSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableInputField: self! !
ListController subclass: #PluggableListController
	instanceVariableNames: 'terminateDuringSelect'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableListController methodsFor: 'control defaults' stamp: 'tk 4/1/98 09:40'!
redButtonActivity
	model okToChange   "Don't change selection if model refuses to unlock"
		ifTrue: [^ super redButtonActivity]! !


!PluggableListController methodsFor: 'initialization' stamp: 'di 5/25/1998 10:15'!
initialize
	super initialize.
	self terminateDuringSelect: false! !


!PluggableListController methodsFor: 'private' stamp: 'di 5/25/1998 10:20'!
changeModelSelection: anInteger
	"Let the view handle this."

	terminateDuringSelect ifTrue: [self controlTerminate].
	view changeModelSelection: anInteger.
	terminateDuringSelect ifTrue: [self controlInitialize].! !

!PluggableListController methodsFor: 'private' stamp: 'sma 3/11/2000 15:38'!
processKeyboard
	sensor keyboardPressed
		ifTrue: [view handleKeystroke: sensor keyboard]
		ifFalse: [super processKeyboard]! !

!PluggableListController methodsFor: 'private' stamp: 'di 5/25/1998 10:14'!
terminateDuringSelect: trueOrFalse
	terminateDuringSelect _ trueOrFalse! !
PluggableListController subclass: #PluggableListControllerOfMany
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableListControllerOfMany methodsFor: 'control defaults' stamp: 'tpr 10/4/2001 22:19'!
redButtonActivity
	| selection firstHit turningOn lastSelection pt scrollFlag |
	model okToChange ifFalse: [^ self].
		"Don't change selection if model refuses to unlock"
	firstHit _ true.
	scrollFlag _ false.
	lastSelection _ 0.
	[sensor redButtonPressed] whileTrue: 
		[selection _ view findSelection: (pt _ sensor cursorPoint).
		selection == nil ifTrue:  "Maybe out of box - check for auto-scroll"
			[pt y < view insetDisplayBox top ifTrue:
				[self scrollView: view list lineGrid.
				scrollFlag _ true.
				selection _ view firstShown].
			pt y > view insetDisplayBox bottom ifTrue:
				[self scrollView: view list lineGrid negated.
				scrollFlag _ true.
				selection _ view lastShown]].
		(selection == nil or: [selection = lastSelection]) ifFalse: 
			[firstHit ifTrue:
				[firstHit _ false.
				turningOn _ (view listSelectionAt: selection) not].
			view selection: selection.
			(view listSelectionAt: selection) == turningOn ifFalse:
				[view displaySelectionBox.
				view listSelectionAt: selection put: turningOn].
			lastSelection _ selection]].
	selection notNil ifTrue:
		["Normal protocol delivers change, so unchange first (ugh)"
		view listSelectionAt: selection put: (view listSelectionAt: selection) not.
		self changeModelSelection: selection].
	scrollFlag ifTrue: [self moveMarker]! !


!PluggableListControllerOfMany methodsFor: 'scrolling' stamp: 'tk 4/8/98 11:09'!
scrollView: anInteger 
	"Need to minimize the selections which get recomputed"
	| oldLimit |
	oldLimit _ anInteger > 0
		ifTrue: [view firstShown]
		ifFalse: [view lastShown].
	(view scrollBy: anInteger)
		ifTrue: [anInteger > 0  "Highlight selections brought into view"
					ifTrue: [view highlightFrom: view firstShown
								to: (oldLimit-1 min: view lastShown)]
					ifFalse: [view highlightFrom: (oldLimit+1 max: view firstShown)
								to: view lastShown].
				^ true]
		ifFalse: [^ false]! !
ListItemWrapper subclass: #PluggableListItemWrapper
	instanceVariableNames: 'string getContentsSelector getStringSelector hasContentsSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!
!PluggableListItemWrapper commentStamp: 'ar 10/14/2003 23:51' prior: 0!
luggableListItemWrapper makes it more easy for clients to use hierarchical lists. Rather than having to write a subclass of ListItemWrapper, a PluggableListItemWrapper can be used to provide the appropriate information straight from the model:
	string - an explicit string representation (contrary to the 'item' which contains any kind of object)
	getStringSelector - a message invoked to retrieve the sting representation of its item dynamically from its model (when a constant representation is undesirable)
	hasContentsSelector - a message invoked in the model to answer whether the item has any children or not.
	getContentsSelector - a message invoked in the model to retrieve the contents for its item.

All callback selectors can have zero, one or two arguments with the item and the wrapper as first and second argument.!


!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'!
asString
	string ifNotNil:[^string].
	getStringSelector ifNil:[^super asString].
	^self sendToModel: getStringSelector
! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:48'!
contents
	getContentsSelector ifNil:[^#()].
	^self sendToModel: getContentsSelector.! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'!
getContentsSelector
	^getContentsSelector! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:50'!
getContentsSelector: aSymbol
	self validateSelector: aSymbol.
	getContentsSelector := aSymbol.! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:48'!
getStringSelector
	^getStringSelector! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'!
getStringSelector: aSymbol
	self validateSelector: aSymbol.
	getStringSelector := aSymbol.! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:53'!
hasContents
	hasContentsSelector ifNil:[^super hasContents].
	^self sendToModel: hasContentsSelector
! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'!
hasContentsSelector
	^hasContentsSelector! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'!
hasContentsSelector: aSymbol
	self validateSelector: aSymbol.
	hasContentsSelector := aSymbol.! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:49'!
item
	^item! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:49'!
item: newItem
	item := newItem! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'!
string
	^string! !

!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'!
string: aString
	string := aString! !


!PluggableListItemWrapper methodsFor: 'printing' stamp: 'ar 10/11/2003 23:21'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(; nextPutAll: self asString; nextPut:$).! !


!PluggableListItemWrapper methodsFor: 'private' stamp: 'ar 10/11/2003 21:47'!
sendToModel: aSelector
	aSelector numArgs = 0 
		ifTrue:[^model perform: aSelector].
	aSelector numArgs = 1 
		ifTrue:[^model perform: aSelector with: item].
	aSelector numArgs = 2 
		ifTrue:[^model perform: aSelector with: item with: self].! !

!PluggableListItemWrapper methodsFor: 'private' stamp: 'ar 10/11/2003 21:50'!
validateSelector: aSymbol
	(aSymbol numArgs between: 0 and: 2) ifFalse:[^self error: 'Invalid pluggable selector'].! !
ScrollPane subclass: #PluggableListMorph
	instanceVariableNames: 'list getListSelector getListSizeSelector getListElementSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes lastClickTime doubleClickSelector handlesBasicKeys potentialDropRow listMorph hScrollRangeCache'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!
!PluggableListMorph commentStamp: '<historical>' prior: 0!
...

When a PluggableListMorph is in focus, type in a letter (or several
letters quickly) to go to the next item that begins with that letter.
Special keys (up, down, home, etc.) are also supported.!


!PluggableListMorph methodsFor: 'accessing' stamp: 'ar 1/31/2001 19:21'!
highlightSelector
	^self valueOfProperty: #highlightSelector! !

!PluggableListMorph methodsFor: 'accessing' stamp: 'ls 5/15/2001 22:31'!
highlightSelector: aSelector
	self setProperty: #highlightSelector toValue: aSelector.
	self updateList! !

!PluggableListMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 15:32'!
itemFromPoint: aPoint
	"Return the list element (morph) at the given point or nil if outside"
	| ptY |
	scroller hasSubmorphs ifFalse:[^nil].
	(scroller fullBounds containsPoint: aPoint) ifFalse:[^nil].
	ptY _ (scroller firstSubmorph point: aPoint from: self) y.
	"note: following assumes that submorphs are vertical, non-overlapping, and ordered"
	scroller firstSubmorph top > ptY ifTrue:[^nil].
	scroller lastSubmorph bottom < ptY ifTrue:[^nil].
	"now use binary search"
	^scroller 
		findSubmorphBinary:[:item|
			(item top <= ptY and:[item bottom >= ptY])
				ifTrue:[0] "found"
				ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]! !

!PluggableListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 20:31'!
rowAtLocation: aPoint
	"Return the row at the given point or 0 if outside"
	| pointInListMorphCoords |
	pointInListMorphCoords := (self scroller transformFrom: self) transform: aPoint.
	^self listMorph rowAtLocation: pointInListMorphCoords.! !


!PluggableListMorph methodsFor: 'as yet unclassified' stamp: 'ls 2/5/2004 18:01'!
listMorph
	listMorph ifNil: [
		"crate this lazily, in case the morph is legacy"
		listMorph := self listMorphClass new.
		listMorph listSource: self.
		listMorph width: self scroller width.
		listMorph color: self textColor ].

	listMorph owner ~~ self scroller ifTrue: [
		"list morph needs to be installed.  Again, it's done this way to accomodate legacy PluggableListMorphs"
		self scroller removeAllMorphs.
		self scroller addMorph: listMorph ].

	^listMorph! !

!PluggableListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/17/2001 09:04'!
listMorphClass
	^LazyListMorph! !


!PluggableListMorph methodsFor: 'debug and other' stamp: 'di 5/6/1998 21:19'!
installModelIn: aWorld
	"No special inits for new components"
	^ self! !

!PluggableListMorph methodsFor: 'debug and other' stamp: 'bf 2/17/2006 17:25'!
userString
	^list! !


!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:56'!
acceptDroppingMorph: aMorph event: evt 
	"This message is sent when a morph is dropped onto a morph that has     
	agreed to accept the dropped morph by responding 'true' to the     
	wantsDroppedMorph:Event: message. The default implementation just     
	adds the given morph to the receiver."
	"Here we let the model do its work."

	self model
		acceptDroppingMorph: aMorph
		event: evt
		inMorph: self.
	self resetPotentialDropRow.
	evt hand releaseMouseFocus: self.
	Cursor normal show.
! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:01'!
potentialDropItem
	"return the item that the most recent drop hovered over, or nil if there is no potential drop target"
	self potentialDropRow = 0 ifTrue: [ ^self ].
	^self getListItem: self potentialDropRow! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:10'!
potentialDropRow
	"return the row of the item that the most recent drop hovered over, or 0 if there is no potential drop target"
	^potentialDropRow ifNil: [ 0 ].
! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:01'!
resetPotentialDropRow
	potentialDropRow ifNotNil: [
	potentialDropRow ~= 0 ifTrue: [
		potentialDropRow _ 0.
		self changed. ] ]! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 07:09'!
startDrag: evt 
	| ddm draggedItem draggedItemMorph passenger |
	evt hand hasSubmorphs
		ifTrue: [^ self].
	[(self dragEnabled
			and: [model okToChange])
		ifFalse: [^ self].
	(draggedItem := self selection)
		ifNil: [^ self].
	draggedItemMorph := StringMorph contents: draggedItem asStringOrText.
	passenger := self model dragPassengerFor: draggedItemMorph inMorph: self.
	passenger
		ifNil: [^ self].
	ddm := TransferMorph withPassenger: passenger from: self.
	ddm
		dragTransferType: (self model dragTransferTypeForMorph: self).
	Preferences dragNDropWithAnimation
		ifTrue: [self model dragAnimationFor: draggedItemMorph transferMorph: ddm].
	evt hand grabMorph: ddm]
		ensure: [Cursor normal show.
			evt hand releaseMouseFocus: self]! !


!PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53'!
highlightSelection! !

!PluggableListMorph methodsFor: 'drawing' stamp: 'sbw 12/1/2000 12:12'!
superDrawOn: aCanvas 
	super drawOn: aCanvas.
! !

!PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53'!
unhighlightSelection
! !


!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:26'!
wantsDroppedMorph: aMorph event: anEvent 
	^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! !


!PluggableListMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 22:57'!
handlesKeyboard: evt
	^true! !

!PluggableListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 16:05'!
handlesMouseOverDragging: evt
	^self dropEnabled! !

!PluggableListMorph methodsFor: 'event handling' stamp: 'ar 9/14/2000 19:16'!
keyStroke: event 
	"Process keys 
	specialKeys are things like up, down, etc. ALWAYS HANDLED 
	modifierKeys are regular characters either 1) accompanied with ctrl, 
	cmd or 2) any character if the list doesn't want to handle basic 
	keys (handlesBasicKeys returns false) 
	basicKeys are any characters"
	| aChar aSpecialKey |
	(self scrollByKeyboard: event) ifTrue: [^self].
	aChar _ event keyCharacter.
	aSpecialKey _ aChar asciiValue.
	aSpecialKey < 32 ifTrue: [^ self specialKeyPressed: aSpecialKey].
	(event anyModifierKeyPressed or: [self handlesBasicKeys not])
		ifTrue: [^ self modifierKeyPressed: aChar].
	^ self basicKeyPressed: aChar! !

!PluggableListMorph methodsFor: 'event handling' stamp: 'nk 8/6/2003 11:38'!
keyboardFocusChange: aBoolean
	"The message is sent to a morph when its keyboard focus changes.
	The given argument indicates that the receiver is gaining (versus losing) the keyboard focus.
	In this case, all we need to do is to redraw border feedback"

	(self innerBounds areasOutside: (self innerBounds insetBy: 1))
		do: [ :rect | self invalidRect: rect ]! !

!PluggableListMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:04'!
mouseEnter: event
	super mouseEnter: event.
	self flag: #arNote. "remove this - keyboard input automatically goes right"
	event hand newKeyboardFocus: self. ! !


!PluggableListMorph methodsFor: 'events' stamp: 'ls 5/16/2001 22:28'!
doubleClick: event
	| index |
	doubleClickSelector isNil ifTrue: [^super doubleClick: event].
	index _ self rowAtLocation: event position.
	index = 0 ifTrue: [^super doubleClick: event].
	"selectedMorph ifNil: [self setSelectedMorph: aMorph]."
	^ self model perform: doubleClickSelector! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:08'!
handleBasicKeys: aBoolean
	"set whether the list morph should handle basic keys like arrow keys, or whether everything should be passed to the model"
	handlesBasicKeys _ aBoolean! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:09'!
handlesBasicKeys
	" if ya don't want the list to automatically handle non-modifier key 
	(excluding shift key) input, return false"
	^ handlesBasicKeys ifNil: [ true ]! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:28'!
mouseDown: evt
	| selectors row |
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
	row _ self rowAtLocation: evt position.
	row = 0  ifTrue: [^super mouseDown: evt].
	"self dragEnabled ifTrue: [aMorph highlightForMouseDown]."
	selectors _ Array 
		with: #click:
		with: (doubleClickSelector ifNotNil:[#doubleClick:])
		with: nil
		with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]).
	evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: 10 "pixels".! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:58'!
mouseEnterDragging: evt

	(evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d"
		^super mouseEnterDragging: evt].

	(self wantsDroppedMorph: evt hand firstSubmorph event: evt )
		ifTrue:[
			potentialDropRow _ self rowAtLocation: evt position.
			evt hand newMouseFocus: self.
			self changed.
			"above is ugly but necessary for now"
		].
! !

!PluggableListMorph methodsFor: 'events' stamp: 'nk 8/6/2003 11:25'!
mouseLeave: event
	"The mouse has left the area of the receiver"

	super mouseLeave: event.
	event hand releaseKeyboardFocus: self! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:56'!
mouseLeaveDragging: anEvent
	(self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d"
		^ super mouseLeaveDragging: anEvent].
	self resetPotentialDropRow.
	anEvent hand releaseMouseFocus: self.
	"above is ugly but necessary for now"
! !

!PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:55'!
mouseMove: evt

	(self dropEnabled and:[evt hand hasSubmorphs]) 
		ifFalse:[^super mouseMove: evt].
	potentialDropRow ifNotNil:[
		potentialDropRow = (self rowAtLocation: evt position)
			ifTrue:[^self].
	].
	self mouseLeaveDragging: evt.
	(self containsPoint: evt position) 
		ifTrue:[self mouseEnterDragging: evt].! !

!PluggableListMorph methodsFor: 'events' stamp: 'wiz 7/3/2005 21:09'!
mouseUp: event 
	"The mouse came up within the list; take appropriate action"
	| row |
	row := self rowAtLocation: event position.
	"aMorph ifNotNil: [aMorph highlightForMouseDown: false]."
	model okToChange
		ifFalse: [^ self].
	"No change if model is locked"
	row == self selectionIndex
		ifTrue: [(autoDeselect ifNil: [true]) ifTrue:[row == 0 ifFalse: [self changeModelSelection: 0] ]]
		ifFalse: [self changeModelSelection: row].
	Cursor normal show! !


!PluggableListMorph methodsFor: 'events-processing' stamp: 'ar 3/17/2001 16:16'!
handleMouseMove: anEvent
	"Reimplemented because we really want #mouseMove when a morph is dragged around"
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
	anEvent wasHandled: true.
	self mouseMove: anEvent.
	(self handlesMouseStillDown: anEvent) ifTrue:[
		"Step at the new location"
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].
! !


!PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 15:33'!
extent: newExtent
	super extent: newExtent.
	
	"Change listMorph's bounds to the new width. It is either the size
	of the widest list item, or the size of self, whatever is bigger"
	self listMorph width: ((self width max: listMorph hUnadjustedScrollRange) + 20). 
! !

!PluggableListMorph methodsFor: 'geometry' stamp: 'ls 5/17/2001 21:01'!
scrollDeltaHeight
	"Return the increment in pixels which this pane should be scrolled."
	^ self font height! !

!PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 17:31'!
scrollDeltaWidth
"A guess -- assume that the width of a char is approx 1/2 the height of the font"
	^ self scrollDeltaHeight // 2

! !


!PluggableListMorph methodsFor: 'initialization' stamp: 'di 4/10/98 16:20'!
autoDeselect: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	autoDeselect _ trueOrFalse.! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/12/2000 16:22'!
doubleClickSelector: aSymbol
	doubleClickSelector _ aSymbol! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'!
font

	^ self listMorph font
! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'!
font: aFontOrNil
	self listMorph font: aFontOrNil.
! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:15'!
getListElementSelector: aSymbol
	"specify a selector that can be used to obtain a single element in the underlying list"
	getListElementSelector := aSymbol.
	list := nil.  "this cache will not be updated if getListElementSelector has been specified, so go ahead and remove it"! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/9/2002 01:03'!
getListSelector: sel
	"Set the receiver's getListSelector as indicated, and trigger a recomputation of the list"

	getListSelector _ sel.
	self changed.
	self updateList.! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/22/2001 18:21'!
getListSizeSelector: aSymbol
	"specify a selector that can be used to specify the list's size"
	getListSizeSelector := aSymbol! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'di 10/11/1999 08:45'!
initForKeystrokes
	lastKeystrokeTime _ 0.
	lastKeystrokes _ ''! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/18/2001 13:08'!
keystrokeActionSelector: keyActionSel
	"Set the keystroke action selector as specified"

	keystrokeActionSelector _ keyActionSel! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/5/2004 16:29'!
list: listOfStrings  
	"lex doesn't think this is used any longer, but is not yet brave enough to remove it.  It should be removed eventually"
	
	
	"Set the receiver's list as specified"

	| morphList h loc index converter item aSelector textColor font |
	scroller removeAllMorphs.
	list _ listOfStrings ifNil: [Array new].
	list isEmpty ifTrue: [self setScrollDeltas.  ^ self selectedMorph: nil].
	"NOTE: we will want a quick StringMorph init message, possibly even
		combined with event install and positioning"
	font ifNil: [font _ Preferences standardListFont].
	converter _ self valueOfProperty: #itemConversionMethod.
	converter ifNil: [converter _ #asStringOrText].
	textColor _ self valueOfProperty: #textColor.
	morphList _ list collect: [:each | | stringMorph |
		item _ each.
		item _ item perform: converter.
		stringMorph _ item isText
			ifTrue: [StringMorph contents: item font: font emphasis: (item emphasisAt: 1)]
			ifFalse: [StringMorph contents: item font: font].
		textColor ifNotNil: [ stringMorph color: textColor ].
		stringMorph
	].
	
	(aSelector _ self valueOfProperty: #balloonTextSelectorForSubMorphs)
		ifNotNil:
			[morphList do: [:m | m balloonTextSelector: aSelector]].

	self highlightSelector ifNotNil:
		[model perform: self highlightSelector with: list with: morphList].

	"Lay items out vertically and install them in the scroller"
	h _ morphList first height "self listItemHeight".
	loc _ 0@0.
	morphList do: [:m | m bounds: (loc extent: 9999@h).  loc _ loc + (0@h)].
	scroller addAllMorphs: morphList.

	index _ self getCurrentSelectionIndex.
	self selectedMorph: ((index = 0 or: [index > morphList size]) ifTrue: [nil] ifFalse: [morphList at: index]).
	self setScrollDeltas.
	scrollBar setValue: 0.0! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'di 5/22/1998 00:32'!
listItemHeight
	"This should be cleaned up.  The list should get spaced by this parameter."
	^ 12! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:31'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 
	self model: anObject.
	getListSelector _ getListSel.
	getIndexSelector _ getSelectionSel.
	setIndexSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	self updateList.
	self selectionIndex: self getCurrentSelectionIndex.
	self initForKeystrokes! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:41'!
textColor
	"Answer my default text color."
	^self valueOfProperty: #textColor ifAbsent: [ Color black ]
! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/5/2004 18:02'!
textColor: aColor
	"Set my default text color."
	self setProperty: #textColor toValue: aColor.
	self listMorph color: aColor.! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:40'!
textHighlightColor
	"Answer my default text highlight color."
	^self valueOfProperty: #textHighlightColor ifAbsent: [ Color red ].
! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:37'!
textHighlightColor: aColor
	"Set my default text highlight color."
	self setProperty: #textHighlightColor toValue: aColor.
! !


!PluggableListMorph methodsFor: 'menu' stamp: 'tk 12/10/2001 20:33'!
getMenu: shiftKeyState
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| aMenu |
	aMenu _ super getMenu: shiftKeyState.
	aMenu ifNotNil: [aMenu commandKeyHandler: self].
	^ aMenu! !


!PluggableListMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:56'!
addCustomMenuItems:  aMenu hand: aHandMorph
	"Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo."

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu addLine.
	aMenu add: 'list font...' translated target: self action: #setListFont.
	aMenu add: 'copy list to clipboard' translated target: self action: #copyListToClipboard.
	aMenu add: 'copy selection to clipboard' translated target: self action: #copySelectionToClipboard! !

!PluggableListMorph methodsFor: 'menus' stamp: 'dao 6/6/2006 15:58'!
copyListToClipboard
	"Copy my items to the clipboard as a multi-line string"

	| stream |
	stream _ WriteStream on: (String new: self getList size * 40).
	list do: [:ea | stream nextPutAll: ea asString] separatedBy: [stream nextPut: Character cr].
	Clipboard clipboardText: stream contents! !

!PluggableListMorph methodsFor: 'menus' stamp: 'sw 3/31/2002 02:38'!
copySelectionToClipboard
	"Copy my selected item to the clipboard as a string"

	self selection
		ifNotNil:
			[Clipboard clipboardText: self selection asString]
		ifNil:
			[self flash]! !

!PluggableListMorph methodsFor: 'menus' stamp: 'nk 9/1/2004 10:48'!
setListFont
	"set the font for the list"

	Preferences chooseFontWithPrompt: 'Choose the font for this list' translated andSendTo: self withSelector: #font: highlight: self listMorph font! !


!PluggableListMorph methodsFor: 'model access' stamp: 'ls 6/23/2001 00:45'!
basicKeyPressed: aChar 
	| oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText |
	nextSelection _ oldSelection _ self getCurrentSelectionIndex.
	max _ self maximumSelection.
	milliSeconds _ Time millisecondClockValue.
	milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting"
		lastKeystrokes _ ''].
	lastKeystrokes _ lastKeystrokes , aChar asLowercase asString.
	lastKeystrokeTime _ milliSeconds.
	nextSelectionList _ OrderedCollection newFrom: (self getList copyFrom: oldSelection + 1 to: max).
	nextSelectionList addAll: (self getList copyFrom: 1 to: oldSelection).
	"Get rid of blanks and style used in some lists"
	nextSelectionText _ nextSelectionList detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes]
				ifNone: [^ self flash"match not found"].
	model okToChange ifFalse: [^ self].
	nextSelection _ self getList findFirst: [:a | a == nextSelectionText].
	"No change if model is locked"
	oldSelection == nextSelection ifTrue: [^ self flash].
	^ self changeModelSelection: nextSelection! !

!PluggableListMorph methodsFor: 'model access' stamp: 'di 5/6/1998 21:18'!
changeModelSelection: anInteger
	"Change the model's selected item index to be anInteger."

	setIndexSelector ifNotNil:
		[model perform: setIndexSelector with: anInteger].! !

!PluggableListMorph methodsFor: 'model access' stamp: 'sw 12/4/2001 20:51'!
commandKeyTypedIntoMenu: evt
	"The user typed a command-key into a menu which has me as its command-key handler"

	^ self modifierKeyPressed: evt keyCharacter! !

!PluggableListMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:05'!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	getIndexSelector isNil ifTrue: [^0].
	^model perform: getIndexSelector! !

!PluggableListMorph methodsFor: 'model access' stamp: 'ls 8/19/2001 14:16'!
getList
	"Answer the list to be displayed.  Caches the returned list in the 'list' ivar"
	getListSelector == nil ifTrue: [^ #()].
	list _ model perform: getListSelector.
	list == nil ifTrue: [^ #()].
	list _ list collect: [ :item | item asStringOrText ].
	^ list! !

!PluggableListMorph methodsFor: 'model access' stamp: 'ls 7/1/2001 10:39'!
getListItem: index
	"get the index-th item in the displayed list"
	getListElementSelector ifNotNil: [ ^(model perform: getListElementSelector with: index) asStringOrText ].
	list ifNotNil: [ ^list at: index ].
	^self getList at: index! !

!PluggableListMorph methodsFor: 'model access' stamp: 'ls 5/17/2001 22:04'!
getListSize
	"return the current number of items in the displayed list"
	getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ].
	^self getList size! !

!PluggableListMorph methodsFor: 'model access' stamp: 'ls 6/10/2001 12:26'!
itemSelectedAmongMultiple: index
	"return whether the index-th row is selected.  Always false in PluggableListMorph, but sometimes true in PluggableListMorphOfMany"
	^false! !

!PluggableListMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:05'!
modifierKeyPressed: aChar 
	| args |
	keystrokeActionSelector isNil ifTrue: [^nil].
	args := keystrokeActionSelector numArgs.
	args = 1 ifTrue: [^model perform: keystrokeActionSelector with: aChar].
	args = 2 
		ifTrue: 
			[^model 
				perform: keystrokeActionSelector
				with: aChar
				with: self].
	^self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol'! !

!PluggableListMorph methodsFor: 'model access' stamp: 'sw 12/9/2001 18:54'!
specialKeyPressed: asciiValue
	"A special key with the given ascii-value was pressed; dispatch it"

	| oldSelection nextSelection max howManyItemsShowing |
	asciiValue = 27 ifTrue: 
		[" escape key"
		^ ActiveEvent shiftPressed
			ifTrue:
				[ActiveWorld putUpWorldMenuFromEscapeKey]
			ifFalse:
				[self yellowButtonActivity: false]].

	max _ self maximumSelection.
	max > 0 ifFalse: [^ self].
	nextSelection _ oldSelection _ self getCurrentSelectionIndex.
	asciiValue = 31 ifTrue: 
		[" down arrow"
		nextSelection _ oldSelection + 1.
		nextSelection > max ifTrue: [nextSelection _ 1]].
	asciiValue = 30 ifTrue: 
		[" up arrow"
		nextSelection _ oldSelection - 1.
		nextSelection < 1 ifTrue: [nextSelection _ max]].
	asciiValue = 1 ifTrue:
		[" home"
		nextSelection _ 1].
	asciiValue = 4 ifTrue:
		[" end"
		nextSelection _ max].
	howManyItemsShowing _ self numSelectionsInView.
	asciiValue = 11 ifTrue:
		[" page up"
		nextSelection _ 1 max: oldSelection - howManyItemsShowing].
	asciiValue = 12 ifTrue:
		[" page down"
		nextSelection _ oldSelection + howManyItemsShowing min: max].
	model okToChange ifFalse: [^ self].
	"No change if model is locked"
	oldSelection = nextSelection ifTrue: [^ self flash].
	^ self changeModelSelection: nextSelection! !


!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'!
doubleClick: event onItem: aMorph
	self removeObsoleteEventHandlers.! !

!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'!
mouseDown: event onItem: aMorph
	self removeObsoleteEventHandlers.! !

!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'!
mouseEnterDragging: anEvent onItem: aMorph 
	self removeObsoleteEventHandlers.! !

!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'!
mouseLeaveDragging: anEvent onItem: aMorph 
	self removeObsoleteEventHandlers.! !

!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'!
mouseUp: event onItem: aMorph 
	self removeObsoleteEventHandlers.! !

!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'!
removeObsoleteEventHandlers
	scroller submorphs do:[:m|
		m eventHandler: nil; highlightForMouseDown: false; resetExtension].! !

!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'!
startDrag: evt onItem: itemMorph 
	self removeObsoleteEventHandlers.! !


!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'!
deriveHScrollRange

	|  unadjustedRange totalRange |
	(list isNil or: [list isEmpty]) 
		ifTrue:[hScrollRangeCache _ Array with: 0 with: 0 with: 0 with: 0 with: 0 ]
		ifFalse:[ 
			unadjustedRange _ self listMorph hUnadjustedScrollRange.
			totalRange _ unadjustedRange + self hExtraScrollRange + self hMargin.
			hScrollRangeCache _ Array 
										with: totalRange 
										with: unadjustedRange 
										with: list size 
										with: list first 
										with: list last .
		].
! !

!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'!
hTotalScrollRange
	"Return the entire scrolling range."

	 self resetHScrollRangeIfNecessary.

	^hScrollRangeCache first
! !

!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'!
hUnadjustedScrollRange
	"Return the entire scrolling range."

	 self resetHScrollRangeIfNecessary.

	^hScrollRangeCache second
! !

!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'!
resetHScrollRange

	hScrollRangeCache _ nil.
	self deriveHScrollRange.
! !

!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'!
resetHScrollRangeIfNecessary

	hScrollRangeCache ifNil: [ ^self deriveHScrollRange ].

	(list isNil or: [list isEmpty]) 
		ifTrue:[^hScrollRangeCache _ Array with: 0 with: 0 with: 0 with: 0 with: 0].

"Make a guess as to whether the scroll ranges need updating based on whether the size, first item, or last item of the list has changed"
	(
		(hScrollRangeCache third == list size) and: [
		(hScrollRangeCache fourth == list first) and: [
		(hScrollRangeCache fifth == list last)
	]])
		ifFalse:[self deriveHScrollRange].

! !

!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'!
resizeScrollBars


	(self extent = self defaultExtent)
		ifTrue:[
			WorldState addDeferredUIMessage: 
				[ self  vResizeScrollBar; resizeScroller; hResizeScrollBar]
		]
		ifFalse:[self vResizeScrollBar; hResizeScrollBar].

	
! !


!PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 12/24/2002 18:31'!
hExtraScrollRange
	"Return the amount of extra blank space to include to the right of the scroll content."
	^5 
! !

!PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 12/26/2002 13:36'!
vUnadjustedScrollRange
	"Return the height extent of the receiver's submorphs."
	(scroller submorphs size > 0) ifFalse:[ ^0 ].
	^(scroller submorphs last fullBounds bottom)
! !


!PluggableListMorph methodsFor: 'selection' stamp: 'di 6/21/1998 22:19'!
getListSelector
	^ getListSelector! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 5/17/2001 23:06'!
maximumSelection
	^ self getListSize! !

!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'!
minimumSelection
	^ 1! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/16/2001 14:15'!
scrollSelectionIntoView
	"make sure that the current selection is visible"
	| row |
	row := self getCurrentSelectionIndex.
	row = 0 ifTrue: [ ^ self ].
	self scrollToShow: (self listMorph drawBoundsForRow: row)! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:20'!
selectedMorph
	"this doesn't work with the LargeLists patch!!  Use #selectionIndex and #selection instead."
	^self scroller submorphs at: self selectionIndex! !

!PluggableListMorph methodsFor: 'selection' stamp: 'nk 7/30/2004 17:53'!
selectedMorph: aMorph 
	"this shouldn't be used any longer"

	"self isThisEverCalled ."

	Beeper  beep.
	true ifTrue: [^self]! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:29'!
selection 
	self selectionIndex = 0 ifTrue: [ ^nil ].
	list ifNotNil: [ ^list at: self selectionIndex ].
	^ self getListItem: self selectionIndex! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:49'!
selection: item
	"Called from outside to request setting a new selection."

	self selectionIndex: (self getList indexOf: item)! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:49'!
selectionIndex
	"return the index we have currently selected, or 0 if none"
	^self listMorph selectedRow ifNil: [ 0 ]! !

!PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:50'!
selectionIndex: index
	"Called internally to select the index-th item."
	| row |
	self unhighlightSelection.
	row := index ifNil: [ 0 ].
	row := row min: self getListSize.  "make sure we don't select past the end"
	self listMorph selectedRow: row.
	self highlightSelection.
	self scrollSelectionIntoView.! !

!PluggableListMorph methodsFor: 'selection' stamp: 'sw 10/30/2000 11:16'!
setGetListSelector: sel
	"Set the the receiver's getListSelector as indicated.  For access via scripting"

	getListSelector _ sel! !

!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/6/1998 21:20'!
setSelectedMorph: aMorph
	self changeModelSelection: (scroller submorphs indexOf: aMorph)! !


!PluggableListMorph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 13:57'!
allSubmorphNamesDo: nameBlock
	"Assume list morphs do not have named parts -- saves MUCH time"

	^ self! !


!PluggableListMorph methodsFor: 'updating' stamp: 'ls 5/15/2001 22:31'!
update: aSymbol 
	"Refer to the comment in View|update:."

	aSymbol == getListSelector ifTrue: 
		[self updateList.
		^ self].
	aSymbol == getIndexSelector ifTrue:
		[self selectionIndex: self getCurrentSelectionIndex.
		^ self].
! !

!PluggableListMorph methodsFor: 'updating' stamp: 'ls 6/22/2001 23:56'!
updateList
	| index |
	"the list has changed -- update from the model"
	self listMorph listChanged.
	self setScrollDeltas.
	scrollBar setValue: 0.0.
	index _ self getCurrentSelectionIndex.
	self resetPotentialDropRow.
	self selectionIndex: index.
! !

!PluggableListMorph methodsFor: 'updating' stamp: 'ls 8/19/2001 14:36'!
verifyContents
	"Verify the contents of the receiver, reconstituting if necessary.  Called whenever window is reactivated, to react to possible structural changes.  Also called periodically in morphic if the smartUpdating preference is true"
	| newList existingSelection anIndex oldList |
	oldList _ list ifNil: [ #() ].
	newList _ self getList.
	((oldList == newList) "fastest" or: [oldList = newList]) ifTrue: [^ self].
	self flash.  "list has changed beneath us; give the user a little visual feedback that the contents of the pane are being updated."
	existingSelection _ self selectionIndex > 0 ifTrue: [ oldList at: self selectionIndex ] ifFalse: [ nil ].
	self updateList.
	(existingSelection notNil and: [(anIndex _ list indexOf: existingSelection asStringOrText ifAbsent: [nil]) notNil])
		ifTrue:
			[model noteSelectionIndex: anIndex for: getListSelector.
			self selectionIndex: anIndex]
		ifFalse:
			[self changeModelSelection: 0]! !


!PluggableListMorph methodsFor: '*omnibrowser' stamp: 'cwp 3/14/2004 13:09'!
getListDelicately
	| lazy |
	lazy _ self listMorph.
	^ (1 to: lazy getListSize) collect: [:i | lazy item: i].
	! !

!PluggableListMorph methodsFor: '*omnibrowser' stamp: 'cwp 3/14/2004 13:47'!
getListObtrusively
	| lazy |
	lazy _ self listMorph.
	^ (1 to: lazy getListSize) collect: [:i | lazy getListItem: i].
	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableListMorph class
	instanceVariableNames: ''!

!PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: nil
		keystroke: #arrowKey:from:		"default"! !

!PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: #arrowKey:from:		"default"
! !

!PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel
! !
PluggableListMorph subclass: #PluggableListMorphByItem
	instanceVariableNames: 'itemList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!

!PluggableListMorphByItem methodsFor: 'as yet unclassified' stamp: 'ls 8/19/2001 15:57'!
getList
	"cache the raw items in itemList"
	itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ].
	^super getList! !


!PluggableListMorphByItem methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:52'!
list: arrayOfStrings
	"Set the receivers items to be the given list of strings."
	"Note: the instance variable 'items' holds the original list.
	 The instance variable 'list' is a paragraph constructed from
	 this list."
"NOTE: this is no longer true; list is a real list, and itemList is no longer used.  And this method shouldn't be called, incidentally."
self isThisEverCalled .
	itemList _ arrayOfStrings.
	^ super list: arrayOfStrings! !


!PluggableListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 15:58'!
changeModelSelection: anInteger
	"Change the model's selected item to be the one at the given index."

	| item |
	setIndexSelector ifNotNil: [
		item _ (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]).
		model perform: setIndexSelector with: item].
	self update: getIndexSelector.
! !

!PluggableListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 14:51'!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getIndexSelector == nil ifTrue: [^ 0].
	item _ model perform: getIndexSelector.
	^ list findFirst: [ :x | x = item]
! !
PluggableListMorphPlus subclass: #PluggableListMorphByItemPlus
	instanceVariableNames: 'itemList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!PluggableListMorphByItemPlus commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!PluggableListMorphByItemPlus methodsFor: 'as yet unclassified' stamp: 'ar 7/15/2005 11:23'!
getList
	"cache the raw items in itemList"
	itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ].
	^super getList! !


!PluggableListMorphByItemPlus methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:35'!
list: arrayOfStrings
	"Set the receivers items to be the given list of strings."
	"Note: the instance variable 'items' holds the original list.
	 The instance variable 'list' is a paragraph constructed from
	 this list."
"NOTE: this is no longer true; list is a real list, and itemList is no longer used.  And this method shouldn't be called, incidentally."
self isThisEverCalled .
	itemList := arrayOfStrings.
	^ super list: arrayOfStrings! !


!PluggableListMorphByItemPlus methodsFor: 'model access' stamp: 'stephaneducasse 2/3/2006 22:35'!
changeModelSelection: anInteger
	"Change the model's selected item to be the one at the given index."

	| item |
	setIndexSelector ifNotNil: [
		item := (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]).
		model perform: setIndexSelector with: item].
	self update: getIndexSelector.
! !

!PluggableListMorphByItemPlus methodsFor: 'model access' stamp: 'stephaneducasse 2/3/2006 22:35'!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getIndexSelector == nil ifTrue: [^ 0].
	item := model perform: getIndexSelector.
	^ list findFirst: [ :x | x = item]
! !
PluggableListMorph subclass: #PluggableListMorphOfMany
	instanceVariableNames: 'dragOnOrOff getSelectionListSelector setSelectionListSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!
!PluggableListMorphOfMany commentStamp: 'hpt 4/5/2004 11:21' prior: 0!
A variant of its superclass that allows multiple items to be selected simultaneously.  There is still a distinguished element which is selected, but each other element in the list may be flagged on or off.
!


!PluggableListMorphOfMany methodsFor: 'drawing' stamp: 'tpr 10/4/2001 21:26'!
listSelectionAt: index
	getSelectionListSelector ifNil:[^false].
	^model perform: getSelectionListSelector with: index! !

!PluggableListMorphOfMany methodsFor: 'drawing' stamp: 'tpr 10/4/2001 21:27'!
listSelectionAt: index put: value
	setSelectionListSelector ifNil:[^false].
	^model perform: setSelectionListSelector with: index with: value! !


!PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'ls 7/15/2002 11:16'!
mouseDown: event
	| oldIndex oldVal row |
	event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
	row := self rowAtLocation: event position.

	row = 0 ifTrue: [^super mouseDown: event].

	model okToChange ifFalse: [^ self].  "No change if model is locked"

	"Set meaning for subsequent dragging of selection"
	dragOnOrOff _ (self listSelectionAt: row) not.
	oldIndex _ self getCurrentSelectionIndex.
	oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex].

	"Set or clear new primary selection (listIndex)"
	dragOnOrOff
		ifTrue: [self changeModelSelection: row]
		ifFalse: [self changeModelSelection: 0].

	"Need to restore the old one, due to how model works, and set new one."
	oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal].
	self listSelectionAt: row put: dragOnOrOff.
	"event hand releaseMouseFocus: aMorph."
	"aMorph changed"! !

!PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'nk 10/14/2003 22:19'!
mouseMove: event 
	"The mouse has moved, as characterized by the event provided.  Adjust the scrollbar, and alter the selection as appropriate"

	| oldIndex oldVal row |
	event position y < self top 
		ifTrue: 
			[scrollBar scrollUp: 1.
			row := self rowAtLocation: scroller topLeft + (1 @ 1)]
		ifFalse: 
			[row := event position y > self bottom 
				ifTrue: 
					[scrollBar scrollDown: 1.
					self rowAtLocation: scroller bottomLeft + (1 @ -1)]
				ifFalse: [ self rowAtLocation: event position]].
	row = 0 ifTrue: [^super mouseDown: event].

	model okToChange ifFalse: [^self].	"No change if model is locked"

	dragOnOrOff ifNil: 
			["Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item"
			dragOnOrOff := (self listSelectionAt: row) not].

	"Set meaning for subsequent dragging of selection"
	oldIndex := self getCurrentSelectionIndex.
	oldIndex ~= 0 ifTrue: [oldVal := self listSelectionAt: oldIndex].

	"Set or clear new primary selection (listIndex)"
	dragOnOrOff 
		ifTrue: [self changeModelSelection: row]
		ifFalse: [self changeModelSelection: 0].

	"Need to restore the old one, due to how model works, and set new one."
	oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal].
	self listSelectionAt: row put: dragOnOrOff.
	row changed! !

!PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'ar 3/17/2001 16:23'!
mouseUp: event

	dragOnOrOff _ nil.  "So improperly started drags will have not effect"! !


!PluggableListMorphOfMany methodsFor: 'initialization' stamp: 'ar 3/17/2001 17:07'!
list: listOfStrings
	scroller removeAllMorphs.
	list _ listOfStrings ifNil: [Array new].
	list isEmpty ifTrue: [^ self selectedMorph: nil].
	super list: listOfStrings.

	"At this point first morph is sensitized, and all morphs share same handler."
	scroller firstSubmorph on: #mouseEnterDragging
						send: #mouseEnterDragging:onItem:
						to: self.
	scroller firstSubmorph on: #mouseUp
						send: #mouseUp:onItem:
						to: self.
	"This should add this behavior to the shared event handler thus affecting all items"! !

!PluggableListMorphOfMany methodsFor: 'initialization' stamp: 'tpr 10/4/2001 21:24'!
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel
	"setup a whole load of pluggability options"
	getSelectionListSelector _ getListSel.
	setSelectionListSelector _ setListSel.
	super on: anObject list: listSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
! !


!PluggableListMorphOfMany methodsFor: 'model access' stamp: 'hpt 4/5/2004 11:00'!
itemSelectedAmongMultiple: index
	^self listSelectionAt: index! !


!PluggableListMorphOfMany methodsFor: 'updating' stamp: 'di 11/10/1998 14:44'!
update: aSymbol 
	aSymbol == #allSelections ifTrue:
		[self selectionIndex: self getCurrentSelectionIndex.
		^ self changed].
	^ super update: aSymbol! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableListMorphOfMany class
	instanceVariableNames: ''!

!PluggableListMorphOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/4/2001 21:54'!
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel
	^ self new
		on: anObject
		list: listSel
		primarySelection: getSelectionSel
		changePrimarySelection: setSelectionSel
		listSelection: getListSel
		changeListSelection: setListSel
		menu: getMenuSel
		keystroke: #arrowKey:from:		"default"! !

!PluggableListMorphOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/4/2001 21:52'!
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel 
	^ self new
		on: anObject
		list: listSel
		primarySelection: getSelectionSel
		changePrimarySelection: setSelectionSel
		listSelection: getListSel
		changeListSelection: setListSel
		menu: getMenuSel
		keystroke: keyActionSel! !
PluggableListMorph subclass: #PluggableListMorphPlus
	instanceVariableNames: 'dragItemSelector dropItemSelector wantsDropSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!PluggableListMorphPlus commentStamp: 'ar 7/15/2005 11:10' prior: 0!
Extensions for PluggableListMorph needed by ToolBuilder!


!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:24'!
dragItemSelector
	^dragItemSelector! !

!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:26'!
dragItemSelector: aSymbol
	dragItemSelector := aSymbol.
	aSymbol ifNotNil:[self dragEnabled: true].! !

!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:25'!
dropItemSelector
	^dropItemSelector! !

!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:25'!
dropItemSelector: aSymbol
	dropItemSelector := aSymbol.
	aSymbol ifNotNil:[self dropEnabled: true].! !

!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 12:07'!
wantsDropSelector
	^wantsDropSelector! !

!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 12:07'!
wantsDropSelector: aSymbol
	wantsDropSelector := aSymbol! !


!PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'ar 7/15/2005 11:28'!
acceptDroppingMorph: aMorph event: evt
	| item |
	dropItemSelector ifNil:[^self].
	item := aMorph passenger.
	model perform: dropItemSelector with: item with: potentialDropRow.
	self resetPotentialDropRow.
	evt hand releaseMouseFocus: self.
	Cursor normal show.
! !

!PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'ar 7/15/2005 11:44'!
startDrag: evt 
	| ddm draggedItem dragIndex |
	dragItemSelector ifNil:[^self].
	evt hand hasSubmorphs ifTrue: [^ self].
	[(self dragEnabled and: [model okToChange]) ifFalse: [^ self].
	dragIndex := self rowAtLocation: evt position.
	dragIndex = 0 ifTrue:[^self].
	draggedItem := model perform: dragItemSelector with: dragIndex.
	draggedItem ifNil:[^self].
	ddm := TransferMorph withPassenger: draggedItem from: self.
	ddm dragTransferType: #dragTransferPlus.
	evt hand grabMorph: ddm]
		ensure: [Cursor normal show.
			evt hand releaseMouseFocus: self]! !

!PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'ar 7/15/2005 12:08'!
wantsDroppedMorph: aMorph event: anEvent
	aMorph dragTransferType == #dragTransferPlus ifFalse:[^false].
	dropItemSelector ifNil:[^false].
	wantsDropSelector ifNil:[^true].
	^(model perform: wantsDropSelector with: aMorph passenger) == true! !
PluggableWidgetSpec subclass: #PluggableListSpec
	instanceVariableNames: 'list getIndex setIndex getSelected setSelected menu keyPress autoDeselect dragItem dropItem dropAccept'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableListSpec commentStamp: 'ar 7/15/2005 11:54' prior: 0!
A single selection list element.

Instance variables:
	list		<Symbol>	The selector to retrieve the list elements.
	getIndex	<Symbol>	The selector to retrieve the list selection index.
	setIndex	<Symbol>	The selector to set the list selection index.
	getSelected	<Symbol>	The selector to retrieve the list selection.
	setSelected	<Symbol>	The selector to set the list selection.
	menu	<Symbol>	The selector to offer (to retrieve?) the context menu.
	keyPress <Symbol>	The selector to invoke for handling keyboard shortcuts.
	autoDeselect	<Boolean>	Whether the list should allow automatic deselection or not.
	dragItem	<Symbol>	Selector to initiate a drag action on an item
	dropItem	<Symbol>	Selector to initiate a drop action of an item
	dropAccept	<Symbol>	Selector to determine whether a drop would be accepted!


!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 16:42'!
autoDeselect
	"Answer whether this tree can be automatically deselected"
	^autoDeselect ifNil:[true]! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 16:41'!
autoDeselect: aBool
	"Indicate whether this tree can be automatically deselected"
	autoDeselect := aBool! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:07'!
dragItem
	"Answer the selector for dragging an item"
	^dragItem! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:07'!
dragItem: aSymbol
	"Set the selector for dragging an item"
	dragItem := aSymbol! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:54'!
dropAccept
	"Answer the selector to determine whether a drop would be accepted"
	^dropAccept! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:55'!
dropAccept: aSymbol
	"Answer the selector to determine whether a drop would be accepted"
	dropAccept := aSymbol.! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:07'!
dropItem
	"Answer the selector for dropping an item"
	^dropItem! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:07'!
dropItem: aSymbol
	"Set the selector for dropping an item"
	dropItem := aSymbol! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:21'!
getIndex
	"Answer the selector for retrieving the list's selection index"
	^getIndex! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:21'!
getIndex: aSymbol
	"Indicate the selector for retrieving the list's selection index"
	getIndex := aSymbol! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 22:33'!
getSelected
	"Answer the selector for retrieving the list selection"
	^getSelected! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 22:33'!
getSelected: aSymbol
	"Indicate the selector for retrieving the list selection"
	getSelected := aSymbol! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:23'!
keyPress
	"Answer the selector for invoking the list's keyPress handler"
	^keyPress! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:23'!
keyPress: aSymbol
	"Indicate the selector for invoking the list's keyPress handler"
	keyPress := aSymbol! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:20'!
list
	"Answer the selector for retrieving the list contents"
	^list! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:24'!
list: aSymbol
	"Indicate the selector for retrieving the list contents"
	list := aSymbol.! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:22'!
menu
	"Answer the selector for retrieving the list's menu"
	^menu! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:22'!
menu: aSymbol
	"Indicate the selector for retrieving the list's menu"
	menu := aSymbol! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:21'!
setIndex
	"Answer the selector for setting the list's selection index"
	^setIndex! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:21'!
setIndex: aSymbol
	"Answer the selector for setting the list's selection index"
	setIndex := aSymbol! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 22:34'!
setSelected
	"Answer the selector for setting the list selection"
	^setSelected! !

!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 22:33'!
setSelected: aSymbol
	"Indicate the selector for setting the list selection"
	setSelected := aSymbol! !


!PluggableListSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableList: self! !
ListView subclass: #PluggableListView
	instanceVariableNames: 'getListSelector getSelectionSelector setSelectionSelector getMenuSelector getMenuTitleSelector keystrokeActionSelector autoDeselect items'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableListView commentStamp: '<historical>' prior: 0!
A pluggable list view gets its content from the model. This allows the same kind of view to be used in different situations, thus avoiding a proliferation of gratuitous view and controller classes. Selector usage is:

		getListSel		fetch the list of items (strings) to be displayed
		getSelectionSel	get the currently selected item
		setSelectionSel	set the currently selected item (takes an argument)
		getMenuSel		get the pane-specific, 'yellow-button' menu
		keyActionSel	process a keystroke typed in this pane (takes an argument)

	Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. However, if getListSel is nil, the default behavior just provides an empty list, which makes for a rather dull list view!!

	The model informs a pluggable view of changes by sending #changed: to itself with getListSel or getSelectionSel as a parameter. The view informs the model of selection changes by sending setSelectionSel to it with the newly selected item as a parameter, and invokes menu and keyboard actions on the model via getMenuSel and keyActionSel.

	Pluggability allows a single model object to have pluggable list views on multiple aspects of itself. For example, an object representing one personal music library might be organized as a three-level hierarchy: the types of music, the titles within a given type, and the songs on a given title. Pluggability allows one to easily build a multipane browser for this object with separate list views for the music type, title, and song.

	AutoDeselect is a feature, normally set to true, that will tell the model that there is no selection if you click on an item that is currently selected.  If autoDeselect is false, then the model will simply be told to select the same item again.!


!PluggableListView methodsFor: 'controller access' stamp: 'jm 3/11/98 17:17'!
defaultControllerClass 

	^ PluggableListController
! !


!PluggableListView methodsFor: 'initialization' stamp: 'di 4/10/98 09:56'!
autoDeselect: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	autoDeselect _ trueOrFalse.! !

!PluggableListView methodsFor: 'initialization' stamp: 'jm 9/20/1998 19:48'!
font: aFontOrNil

	super font: aFontOrNil.
	self list: self getList.  "update display"
! !

!PluggableListView methodsFor: 'initialization' stamp: 'di 6/20/2001 09:58'!
list: arrayOfStrings
	"Set the receivers items to be the given list of strings
	The instance variable 'items' holds the original list. The instance variable 'list' is a paragraph constructed from this list."

	((items == arrayOfStrings) "fastest" or: [items = arrayOfStrings]) ifTrue: [^ self].
	items _ arrayOfStrings.
	isEmpty _ arrayOfStrings isEmpty.

	"add top and bottom delimiters"
	list _ ListParagraph
		withArray:
			(Array streamContents: [:s |
				s nextPut: topDelimiter.
				arrayOfStrings do:
					[:item | item == nil ifFalse:
						[(item isMemberOf: MethodReference)  "A very specific fix for MVC"
							ifTrue: [s nextPut: item asStringOrText]
							ifFalse: [s nextPut: item]]].
				s nextPut: bottomDelimiter])
		 style: self assuredTextStyle.

	selection _ self getCurrentSelectionIndex.
	self positionList.! !

!PluggableListView methodsFor: 'initialization' stamp: 'tk 4/12/1998 08:25'!
menu: getMenuSel

	getMenuSelector _ getMenuSel! !

!PluggableListView methodsFor: 'initialization' stamp: 'sw 8/18/1998 12:04'!
menuTitleSelector: getMenuTitleSel
	getMenuTitleSelector _ getMenuTitleSel! !

!PluggableListView methodsFor: 'initialization' stamp: 'di 4/10/98 09:55'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel

	self model: anObject.
	getListSelector _ getListSel.
	getSelectionSelector _ getSelectionSel.
	setSelectionSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	self list: self getList.! !


!PluggableListView methodsFor: 'model access' stamp: 'di 5/6/1998 20:52'!
changeModelSelection: anInteger
	"Change the model's selected item index to be anInteger."
	| newIndex |
	newIndex _ anInteger.
	(autoDeselect == nil or: [autoDeselect]) ifTrue:
		[getSelectionSelector ifNotNil:
			[(model perform: getSelectionSelector) = anInteger ifTrue:
				["Click on existing selection deselects"
				newIndex _ 0]]].

	setSelectionSelector ifNotNil:
		[model perform: setSelectionSelector with: newIndex].! !

!PluggableListView methodsFor: 'model access' stamp: 'di 5/6/1998 20:52'!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	getSelectionSelector == nil ifTrue: [^ 0].
	^ model perform: getSelectionSelector! !

!PluggableListView methodsFor: 'model access'!
getList 
	"Answer the list to be displayed."

	| lst |
	getListSelector == nil ifTrue: [^ #()].
	lst _ model perform: getListSelector.
	lst == nil ifTrue: [^ #()].
	^ lst! !

!PluggableListView methodsFor: 'model access' stamp: 'tk 4/2/98 13:36'!
getListSelector
	^ getListSelector! !

!PluggableListView methodsFor: 'model access' stamp: 'sw 8/18/1998 12:07'!
getMenu: shiftKeyDown
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."
	| menu aMenu |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ CustomMenu new.
	getMenuSelector numArgs = 1
		ifTrue:
			[aMenu _ model perform: getMenuSelector with: menu.
			getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)].
			^ aMenu].
	getMenuSelector numArgs = 2
		ifTrue: [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyDown.
				getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)].
				^ aMenu].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!PluggableListView methodsFor: 'model access' stamp: 'nk 6/29/2004 14:45'!
handleKeystroke: aChar
	"Answer the menu for this list view."

	| args aSpecialKey |

	aSpecialKey _ aChar asciiValue.
	aSpecialKey < 32 ifTrue: [ self specialKeyPressed: aSpecialKey. ^nil ].
	keystrokeActionSelector ifNil: [^ nil].

	controller controlTerminate.
	(args _ keystrokeActionSelector numArgs) = 1
		ifTrue: [model perform: keystrokeActionSelector with: aChar.
				^ controller controlInitialize].
	args = 2
		ifTrue: [model perform: keystrokeActionSelector with: aChar with: self.
				^ controller controlInitialize].
	^ self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! !

!PluggableListView methodsFor: 'model access' stamp: 'sw 10/9/1998 08:24'!
setSelectionSelectorIs: aSelector
	^ aSelector == setSelectionSelector! !

!PluggableListView methodsFor: 'model access' stamp: 'nk 6/29/2004 14:42'!
specialKeyPressed: keyEvent
	"Process the up and down arrows in a list pane."
     | oldSelection nextSelection max min howMany |

	(#(1 4 11 12 30 31) includes: keyEvent) ifFalse: [ ^ false ].

     oldSelection := self getCurrentSelectionIndex.
     nextSelection := oldSelection.
     max := self maximumSelection.
     min := self minimumSelection.
     howMany := self numSelectionsInView.	"get this exactly??"

     keyEvent == 31 ifTrue:
		["down-arrow; move down one, wrapping to top if needed"
		nextSelection := oldSelection + 1.
		nextSelection > max ifTrue: [nextSelection _ 1]].

     keyEvent == 30 ifTrue:
		["up arrow; move up one, wrapping to bottom if needed"
		nextSelection := oldSelection - 1.
		nextSelection < 1 ifTrue: [nextSelection _ max]].

     keyEvent == 1  ifTrue: [nextSelection := 1].  "home"
     keyEvent == 4  ifTrue: [nextSelection := max].   "end"
     keyEvent == 11 ifTrue: [nextSelection := min max: (oldSelection - howMany)].  "page up"
     keyEvent == 12  ifTrue: [nextSelection := (oldSelection + howMany) min: max].  "page down"
     nextSelection = oldSelection  ifFalse:
		[model okToChange
			ifTrue:
				[self changeModelSelection: nextSelection.
				"self controller moveMarker"]].
	
	^true
			! !


!PluggableListView methodsFor: 'updating' stamp: 'di 5/25/1998 10:24'!
update: aSymbol 
	"Refer to the comment in View|update:."
	aSymbol == getListSelector ifTrue:
		[self list: self getList.
		self displayView.
		self displaySelectionBox.
		^self].
	aSymbol == getSelectionSelector ifTrue:
		[^ self moveSelectionBox: self getCurrentSelectionIndex].
! !

!PluggableListView methodsFor: 'updating' stamp: 'BG 1/22/2004 13:15'!
verifyContents
	| newItems existingSelection anIndex |
	"Called on window reactivation to react to possible structural changes.  Update contents if necessary."

	newItems _ self getList.
	((items == newItems) "fastest" or: [items = newItems]) ifTrue: [^ self].
	self flash.  "list has changed beneath us; could get annoying, but hell"
	existingSelection _ list stringAtLineNumber: (selection + (topDelimiter ifNil: [0] ifNotNil: [1])).  "account for cursed ------ row"
	self list: newItems.

	(newItems size > 0 and: [newItems first isKindOf: Symbol]) ifTrue:
		[existingSelection _ existingSelection asSymbol].
	(anIndex _ newItems indexOf: existingSelection ifAbsent: [nil])
		ifNotNil:
			[model noteSelectionIndex: anIndex for: getListSelector.]
		ifNil:
			[self changeModelSelection: 0].
	selection := 0. " to display the list without selection "
	self displayView.
	self update: getSelectionSelector.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableListView class
	instanceVariableNames: ''!

!PluggableListView class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:34'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: nil
		keystroke: #arrowKey:from:		"default"
! !

!PluggableListView class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:34'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: #arrowKey:from:		"default"

! !

!PluggableListView class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel
! !
PluggableListView subclass: #PluggableListViewByItem
	instanceVariableNames: 'itemList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableListViewByItem methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 16:28'!
changeModelSelection: anInteger
	"Change the model's selected item to be the one at the given index."
	| item |
	setSelectionSelector ifNotNil: [
		item _ (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]).
		model perform: setSelectionSelector with: item].
! !

!PluggableListViewByItem methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 16:27'!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getSelectionSelector == nil ifTrue: [^ 0].
	item _ model perform: getSelectionSelector.
	^ itemList findFirst: [ :x | x = item]
! !

!PluggableListViewByItem methodsFor: 'as yet unclassified' stamp: 'sw 12/9/1999 18:07'!
list: arrayOfStrings
	"Set the receivers items to be the given list of strings."
	"Note: the instance variable 'items' holds the original list.
	 The instance variable 'list' is a paragraph constructed from
	 this list."

	itemList _ arrayOfStrings.
	isEmpty _ arrayOfStrings isEmpty.

	"add top and bottom delimiters"
	list _ ListParagraph
		withArray:
			(Array streamContents: [:s |
				s nextPut: topDelimiter.
				arrayOfStrings do: [:item | item == nil ifFalse: [s nextPut: item]].
				s nextPut: bottomDelimiter])
		 style: self assuredTextStyle.

	selection _ self getCurrentSelectionIndex.
	self positionList.! !
PluggableListView subclass: #PluggableListViewOfMany
	instanceVariableNames: 'getSelectionListSelector setSelectionListSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableListViewOfMany methodsFor: 'controller access' stamp: 'di 5/17/1998 22:48'!
defaultControllerClass 

	^ PluggableListControllerOfMany
! !


!PluggableListViewOfMany methodsFor: 'displaying' stamp: 'tpr 10/4/2001 21:34'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."
	selection _ 0.
	1 to: self maximumSelection do:
		[:i | selection _ i.
		(self listSelectionAt: i) ifTrue: [self deEmphasizeSelectionBox]].
	selection _ 0! !

!PluggableListViewOfMany methodsFor: 'displaying' stamp: 'tpr 10/4/2001 21:34'!
highlightFrom: start to: stop
	(start == nil or: [stop == nil]) ifTrue: [^ self displayView].
	start to: stop do:
		[:i | selection _ i.
		(self listSelectionAt: selection) ifTrue: [self displaySelectionBox]].
	selection _ 0! !

!PluggableListViewOfMany methodsFor: 'displaying' stamp: 'tk 4/6/98 20:42'!
scrollBy: anInteger
	"This is a possible way to intercept what ListOfManyController did to get multiple selections to show.  Feel to replace this."

	| ans |
	ans _ super scrollBy: anInteger.
"	self displaySelectionBox."
	^ ans! !


!PluggableListViewOfMany methodsFor: 'initialization' stamp: 'tpr 10/8/2001 20:53'!
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel
	"setup a whole load of pluggability options"
	getSelectionListSelector _ getListSel.
	setSelectionListSelector _ setListSel.
	super on: anObject list: listSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
! !


!PluggableListViewOfMany methodsFor: 'selecting' stamp: 'tpr 10/4/2001 22:17'!
listSelectionAt: index
	getSelectionListSelector ifNil:[^false].
	^model perform: getSelectionListSelector with: index! !

!PluggableListViewOfMany methodsFor: 'selecting' stamp: 'tpr 10/4/2001 22:17'!
listSelectionAt: index put: value
	setSelectionListSelector ifNil:[^false].
	^model perform: setSelectionListSelector with: index with: value! !

!PluggableListViewOfMany methodsFor: 'selecting' stamp: 'tk 4/6/98 15:43'!
moveSelectionBox: anInteger 
	"Presumably the selection has changed to be anInteger. Deselect the 
	previous selection and display the new one, highlighted."
	selection ~= anInteger
		ifTrue: 
			[selection _ anInteger.
			self displaySelectionBox]! !

!PluggableListViewOfMany methodsFor: 'selecting' stamp: 'tk 4/6/98 15:43'!
selection
	"Have to override normal controller smarts about deselection"
	^ 0! !


!PluggableListViewOfMany methodsFor: 'updating' stamp: 'tk 4/8/98 13:12'!
update: aSymbol 
	aSymbol == getListSelector
		ifTrue: [self list: self getList.
			^ self displayView; emphasizeView].
	aSymbol == getSelectionSelector
		ifTrue: [^ self displayView; emphasizeView].
	aSymbol == #allSelections
		ifTrue: [^ self displayView; emphasizeView].
	^ super update: aSymbol! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableListViewOfMany class
	instanceVariableNames: ''!

!PluggableListViewOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/8/2001 20:53'!
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel
	^ self new
		on: anObject
		list: listSel
		primarySelection: getSelectionSel
		changePrimarySelection: setSelectionSel
		listSelection: getListSel
		changeListSelection: setListSel
		menu: getMenuSel
		keystroke: #arrowKey:from:		"default"! !

!PluggableListViewOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/8/2001 20:52'!
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel 
	^ self new
		on: anObject
		list: listSel
		primarySelection: getSelectionSel
		changePrimarySelection: setSelectionSel
		listSelection: getListSel
		changeListSelection: setListSel
		menu: getMenuSel
		keystroke: keyActionSel! !
ToolBuilderSpec subclass: #PluggableMenuItemSpec
	instanceVariableNames: 'label action checked enabled separator subMenu help'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:23'!
action
	"Answer the action associated with the receiver"
	^action! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:23'!
action: aMessageSend
	"Answer the action associated with the receiver"
	action := aMessageSend! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:28'!
checked
	"Answer whether the receiver is checked"
	^checked ifNil:[false]! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'!
checked: aBool
	"Indicate whether the receiver is checked"
	checked := aBool.! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:28'!
enabled
	"Answer whether the receiver is enabled"
	^enabled ifNil:[true]! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'!
enabled: aBool
	"Indicate whether the receiver is enabled"
	enabled := aBool! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:24'!
help
	"Answer the help text associated with the receiver"
	^help! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:24'!
help: aString
	"Answer the help text associated with the receiver"
	help := aString.! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:20'!
label
	"Answer the receiver's label"
	^label! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'!
label: aString
	"Set the receiver's label"
	label := aString! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:28'!
separator
	"Answer whether the receiver should be followed by a separator"
	^separator ifNil:[false]! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'!
separator: aBool
	"Indicate whether the receiver should be followed by a separator"
	separator := aBool.! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'!
subMenu
	"Answer the receiver's subMenu"
	^subMenu! !

!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'!
subMenu: aMenuSpec
	"Answer the receiver's subMenu"
	subMenu := aMenuSpec! !


!PluggableMenuItemSpec methodsFor: 'building' stamp: 'ar 2/28/2006 17:23'!
buildWith: builder
	^ builder buildPluggableMenuItem: self! !
ToolBuilderSpec subclass: #PluggableMenuSpec
	instanceVariableNames: 'label model items'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!

!PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:27'!
items
	^ items ifNil: [items := OrderedCollection new]! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:12'!
label
	^label! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:12'!
label: aString
	label := aString.! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: 'cwp 6/8/2005 23:36'!
model
	^ model! !

!PluggableMenuSpec methodsFor: 'accessing' stamp: 'cwp 6/8/2005 23:36'!
model: anObject 
	model := anObject! !


!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:26'!
add: aString action: aMessageSend
	| item |
	item := self addMenuItem.
	item label: aString.
	item action: aMessageSend.
	^item! !

!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:25'!
add: aString target: anObject selector: aSelector argumentList: anArray
	^self add: aString action: (MessageSend 
				receiver: anObject 
				selector: aSelector
				arguments: anArray).! !

!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:27'!
addMenuItem
	| item |
	item := self newMenuItem.
	self items add: item.
	^item! !

!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:25'!
addSeparator
	self items isEmpty ifTrue:[^nil].
	self items last separator: true.! !

!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 6/21/2005 10:45'!
buildWith: builder
	^ builder buildPluggableMenu: self! !

!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:27'!
newMenuItem
	^PluggableMenuItemSpec new! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableMenuSpec class
	instanceVariableNames: ''!

!PluggableMenuSpec class methodsFor: 'as yet unclassified' stamp: 'cwp 6/9/2005 00:22'!
withModel: aModel
	^ self new model: aModel! !
PluggableListMorph subclass: #PluggableMessageCategoryListMorph
	instanceVariableNames: 'getRawListSelector priorRawList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!
!PluggableMessageCategoryListMorph commentStamp: '<historical>' prior: 0!
A variant of PluggableListMorph designed specially for efficient handling of the --all-- feature in message-list panes.  In order to be able *quickly* to check whether there has been an external change to the list, we cache the raw list for identity comparison (the actual list is a combination of the --all-- element and the the actual list).!


!PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'md 10/20/2004 15:32'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel
	self model: anObject.
	getListSelector _ getListSel.
	getIndexSelector _ getSelectionSel.
	setIndexSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	getRawListSelector _ getRawSel.
	self updateList.
	self selectionIndex: self getCurrentSelectionIndex.
	self initForKeystrokes! !


!PluggableMessageCategoryListMorph methodsFor: 'model access' stamp: 'ls 8/19/2001 15:35'!
getList
	"Differs from the generic in that here we obtain and cache the raw list, then cons it together with the special '-- all --' item to produce the list to be used in the browser.  This special handling is done in order to avoid excessive and unnecessary reformulation of the list in the step method"

	getRawListSelector == nil ifTrue: ["should not happen!!" priorRawList _ nil.  ^ #()].
	model classListIndex = 0 ifTrue: [^ priorRawList _ list _ Array new].
	priorRawList _ model perform: getRawListSelector.
	list := (Array with: ClassOrganizer allCategory), priorRawList.
	^list! !


!PluggableMessageCategoryListMorph methodsFor: 'updating' stamp: 'ls 8/19/2001 14:26'!
verifyContents
	
	| newList existingSelection anIndex newRawList |
	(model editSelection == #editComment) ifTrue: [^ self].
	model classListIndex = 0 ifTrue: [^ self].
	newRawList _ model perform: getRawListSelector.
	newRawList == priorRawList ifTrue: [^ self].  "The usual case; very fast"
	priorRawList _ newRawList.
	newList _ (Array with: ClassOrganizer allCategory), priorRawList.
	list = newList ifTrue: [^ self].
	self flash.  "could get annoying, but hell"
	existingSelection _ self selection.
	self updateList.
	(anIndex _ newList indexOf: existingSelection ifAbsent: [nil])
		ifNotNil:
			[model noteSelectionIndex: anIndex for: getListSelector.
			self selectionIndex: anIndex]
		ifNil:
			[self changeModelSelection: 0]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableMessageCategoryListMorph class
	instanceVariableNames: ''!

!PluggableMessageCategoryListMorph class methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 16:59'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel
	^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel! !
PluggableListMorph subclass: #PluggableMultiColumnListMorph
	instanceVariableNames: 'lists'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!
!PluggableMultiColumnListMorph commentStamp: '<historical>' prior: 0!
This morph can be used to show a list having multiple columns,  The columns are self width sized to make the largest entry in each list fit.  In some cases the pane may then be too narrow.

Use it like a regular PluggableListMorph except pass in an array of lists instead of a single list.

There are base assumptions made here that each list in the array of lists is the same size.

Also, the highlight color for the selection is easy to modify in the #highlightSelection method.  I used blue
when testing just to see it work.!


!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/18/2001 10:32'!
getListRow: row
	"return the strings that should appear in the requested row"
	getListElementSelector ifNotNil: [ ^model perform: getListElementSelector with: row ].
	^self getList collect: [ :l | l at: row ]! !

!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 23:03'!
getListSize
	| l |
	getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ].

	l := self getList.
	l isEmpty ifTrue: [ ^ 0 ].
	^l first size! !

!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'nk 4/5/2001 23:18'!
itemFromPoint: aPoint
	"Return the list element (morph) at the given point or nil if outside"
	| ptY |
	scroller hasSubmorphs ifFalse:[^nil].
	(scroller fullBounds containsPoint: aPoint) ifFalse:[^nil].
	ptY _ (scroller firstSubmorph point: aPoint from: self) y.
	"note: following assumes that submorphs are vertical, non-overlapping, and ordered"
	scroller firstSubmorph top > ptY ifTrue:[^nil].
	scroller lastSubmorph bottom < ptY ifTrue:[^nil].
	"now use binary search"
	^scroller submorphThat: [ :item | item top <= ptY and:[item bottom >= ptY] ] ifNone: [].
! !

!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 20:01'!
listMorphClass
	^MulticolumnLazyListMorph! !


!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:37'!
calculateColumnOffsetsFrom: maxWidths
	| offsets previous current |
	offsets _ Array new: maxWidths size.
	1
		to: offsets size
		do: [:indx | offsets at: indx put: (maxWidths at: indx)
					+ 10].
	2
		to: offsets size
		do: [:indx | 
			previous _ offsets at: indx - 1.
			current _ offsets at: indx.
			current _ previous + current.
			offsets at: indx put: current].
	^offsets
! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:36'!
calculateColumnWidthsFrom: arrayOfMorphs 
	| maxWidths |
	maxWidths _ Array new: arrayOfMorphs size - 1.
	1
		to: maxWidths size
		do: [:idx | maxWidths at: idx put: 0].
	1
		to: maxWidths size
		do: [:idx | (arrayOfMorphs at: idx)
				do: [:mitem | mitem width
							> (maxWidths at: idx)
						ifTrue: [maxWidths at: idx put: mitem width]]].
	^maxWidths! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:22'!
createMorphicListsFrom: arrayOfLists 
	| array |

	array _ Array new: arrayOfLists size.
	1 to: arrayOfLists size do: [:arrayIndex |
		array at: arrayIndex put: (
			(arrayOfLists at: arrayIndex) collect: [:item | item isText
						ifTrue: [StringMorph
								contents: item
								font: self font
								emphasis: (item emphasisAt: 1)]
						ifFalse: [StringMorph contents: item font: self font]])
		].
	^array! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:38'!
layoutMorphicLists: arrayOfMorphs 
	| maxWidths offsets locs h |
	maxWidths _ self calculateColumnWidthsFrom: arrayOfMorphs.
	offsets _ self calculateColumnOffsetsFrom: maxWidths.
	locs _ Array new: arrayOfMorphs size.
	locs at: 1 put: 0 @ 0.
	2
		to: locs size
		do: [:indx | locs at: indx put: (offsets at: indx - 1)
					@ 0].
	h _ arrayOfMorphs first first height.
	1
		to: arrayOfMorphs size
		do: [:indx | (arrayOfMorphs at: indx)
				do: [:morphItem | 
					morphItem
						bounds: ((locs at: indx)
								extent: 9999 @ h).
					locs at: indx put: (locs at: indx)
							+ (0 @ h)]]! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'ls 5/17/2001 21:16'!
list: arrayOfLists 
	| listOfStrings |
	lists _ arrayOfLists.
	scroller removeAllMorphs.
	listOfStrings _ arrayOfLists == nil
				ifTrue: [Array new]
				ifFalse: [
					arrayOfLists isEmpty ifFalse: [
					arrayOfLists at: 1]].
	list _ listOfStrings
				ifNil: [Array new].
	self listMorph listChanged..

	self setScrollDeltas.
	scrollBar setValue: 0.0! !


!PluggableMultiColumnListMorph methodsFor: 'model access' stamp: 'ls 11/14/2002 13:13'!
basicKeyPressed: aChar
	"net supported for multi-column lists; which column should be used?!!  The issue is that the base class implementation uses getList expecting a single collectino to come back instead of several of them"
	^self! !

!PluggableMultiColumnListMorph methodsFor: 'model access' stamp: 'ls 7/12/2001 23:24'!
getList
	"fetch and answer the lists to be displayed"
	getListSelector == nil ifTrue: [^ #()].
	list _ model perform: getListSelector.
	list == nil ifTrue: [^ #()].
	list _ list collect: [ :column | column collect: [ :item | item asStringOrText ] ].
	^ list! !


!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'ls 5/16/2001 22:24'!
highlightSelection
^self! !

!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'ls 5/16/2001 22:23'!
unhighlightSelection
^self! !
PluggableMultiColumnListMorph subclass: #PluggableMultiColumnListMorphByItem
	instanceVariableNames: 'itemList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!

!PluggableMultiColumnListMorphByItem methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:55'!
list: arrayOfStrings 
	"Set the receivers items to be the given list of strings."
	"Note: the instance variable 'items' holds the original list.  
	The instance variable 'list' is a paragraph constructed from  
	this list."
"NO LONGER TRUE.  list is a real list, and listItems is obsolete."
self isThisEverCalled .
	itemList _ arrayOfStrings first.
	^ super list: arrayOfStrings! !


!PluggableMultiColumnListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 14:57'!
changeModelSelection: anInteger 
	"Change the model's selected item to be the one at the given index."
	| item |
	setIndexSelector
		ifNotNil: [item _ anInteger = 0
						ifFalse: [list first at: anInteger].
			model perform: setIndexSelector with: item].
	self update: getIndexSelector! !

!PluggableMultiColumnListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 15:11'!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getIndexSelector == nil
		ifTrue: [^ 0].
	item _ model perform: getIndexSelector.

	^ list first
		findFirst: [:x | x  = item]! !
PluggableListSpec subclass: #PluggableMultiSelectionListSpec
	instanceVariableNames: 'getSelectionList setSelectionList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableMultiSelectionListSpec commentStamp: 'ar 2/12/2005 13:31' prior: 0!
PluggableMultiSelectionListSpec specifies a list with multiple selection behavior.

Instance variables:
	getSelectionList	<Symbol>	The message to retrieve the multiple selections.
	setSelectionList	<Symbol>	The message to indicate multiple selections.!


!PluggableMultiSelectionListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 13:32'!
getSelectionList
	"Answer the message to retrieve the multiple selections"
	^getSelectionList! !

!PluggableMultiSelectionListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 13:32'!
getSelectionList: aSymbol
	"Indicate the message to retrieve the multiple selections"
	getSelectionList := aSymbol! !

!PluggableMultiSelectionListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 13:32'!
setSelectionList
	"Answer the message to indicate multiple selections"
	^setSelectionList! !

!PluggableMultiSelectionListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 13:32'!
setSelectionList: aSymbol
	"Indicate the message to indicate multiple selections"
	setSelectionList := aSymbol! !


!PluggableMultiSelectionListSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableMultiSelectionList: self! !
AlignmentMorph subclass: #PluggablePanelMorph
	instanceVariableNames: 'model getChildrenSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!PluggablePanelMorph commentStamp: 'ar 2/11/2005 20:13' prior: 0!
A pluggable panel morph which deals with changing children.!


!PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:47'!
getChildrenSelector
	^getChildrenSelector! !

!PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:47'!
getChildrenSelector: aSymbol
	getChildrenSelector := aSymbol.! !

!PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:48'!
model
	^model! !

!PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:48'!
model: aModel
	model ifNotNil:[model removeDependent: self].
	model := aModel.
	model ifNotNil:[model addDependent: self].! !


!PluggablePanelMorph methodsFor: 'update' stamp: 'ar 2/11/2005 20:01'!
update: what
	what == nil ifTrue:[^self].
	what == getChildrenSelector ifTrue:[
		self removeAllMorphs.
		self addAllMorphs: (model perform: getChildrenSelector).
		self submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill].
	].! !
PluggableCompositeSpec subclass: #PluggablePanelSpec
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggablePanelSpec commentStamp: 'ar 2/11/2005 15:01' prior: 0!
A panel with a (possibly changing) set of child elements. Expects to see change/update notifications when the childrens change.!


!PluggablePanelSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggablePanel: self.! !
PluggableButtonSpec subclass: #PluggableRadioButtonSpec
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableRadioButtonSpec commentStamp: 'ar 2/12/2005 23:14' prior: 0!
PluggableRadioButton is intended as a HINT for the builder that this widget will be used as radio button. Unless explicitly supported it will be automatically substituted by PluggableButton.!


!PluggableRadioButtonSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableRadioButton: self! !
Set subclass: #PluggableSet
	instanceVariableNames: 'hashBlock equalBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!PluggableSet commentStamp: '<historical>' prior: 0!
PluggableSets allow the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the set which in turn can heavily improve the performance of sets and dictionaries.

Instance variables:
	hashBlock	<BlockContext>	A one argument block used for hashing the elements.
	equalBlock	<BlockContext>	A two argument block used for comparing the elements.

Example: Adding 1000 integer points in the range (0@0) to: (100@100) to a set.

	| rnd set max pt |
	set _ Set new: 1000.
	rnd _ Random new.
	max _ 100.
	Time millisecondsToRun:[
		1 to: 1000 do:[:i|
			pt _ (rnd next * max) truncated @ (rnd next * max) truncated.
			set add: pt.
		].
	].

The above is way slow since the default hashing function of points leads to an awful lot of collisions in the set. And now the same, with a somewhat different hash function:

	| rnd set max pt |
	set _ PluggableSet new: 1000.
	set hashBlock:[:item| (item x bitShift: 16) + item y].
	rnd _ Random new.
	max _ 100.
	Time millisecondsToRun:[
		1 to: 1000 do:[:i|
			pt _ (rnd next * max) truncated @ (rnd next * max) truncated.
			set add: pt.
		].
	].
!


!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'!
equalBlock
	"Return the block used for comparing the elements in the receiver."
	^equalBlock! !

!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'!
equalBlock: aBlock
	"Set a new equality block. The block must accept two arguments and return true if the argumets are considered equal, false otherwise"
	equalBlock _ aBlock.! !

!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'!
hashBlock
	"Return the block used for hashing the elements in the receiver."
	^hashBlock! !

!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 19:02'!
hashBlock: aBlock
	"Set a new hash block. The block must accept one argument and return the hash value of the given argument."
	hashBlock _ aBlock.! !


!PluggableSet methodsFor: 'copying' stamp: 'ar 11/12/1998 18:47'!
copy
	^super copy postCopyBlocks! !

!PluggableSet methodsFor: 'copying' stamp: 'dvf 6/10/2000 19:34'!
postCopyBlocks
	hashBlock _ hashBlock copy.
	equalBlock _ equalBlock copy.
	"Fix temps in case we're referring to outside stuff"
	hashBlock ifNotNil: [hashBlock fixTemps].
	equalBlock ifNotNil: [equalBlock fixTemps]! !


!PluggableSet methodsFor: 'private' stamp: 'dvf 6/11/2000 00:54'!
scanFor: anObject 
	"Scan the key array for the first slot containing either a nil
(indicating 
	  an empty slot) or an element that matches anObject. Answer the index 
	  
	of that slot or zero if no slot is found. This  method will be
overridden   
	in various subclasses that have different interpretations for matching 
 
	elements."
	| element start finish |
	start _ (hashBlock ifNil: [anObject hash]
				ifNotNil: [hashBlock value: anObject])
				\\ array size + 1.
	finish _ array size.
	"Search from (hash mod size) to the end."
	start to: finish do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element = anObject]
				ifNotNil: [equalBlock value: element value: anObject]])
			ifTrue: [^ index]].
	"Search from 1 to where we started."
	1 to: start - 1 do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element = anObject]
				ifNotNil: [equalBlock value: element value: anObject]])
			ifTrue: [^ index]].
	^ 0"No match AND no empty slot"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableSet class
	instanceVariableNames: ''!

!PluggableSet class methodsFor: 'as yet unclassified' stamp: 'dvf
6/10/2000 18:13'!
integerSet
	^self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! !
SystemWindow subclass: #PluggableSystemWindow
	instanceVariableNames: 'getLabelSelector getChildrenSelector children closeWindowSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!PluggableSystemWindow commentStamp: 'ar 2/11/2005 20:14' prior: 0!
A pluggable system window. Fixes the issues with label retrieval and adds support for changing children.!


!PluggableSystemWindow methodsFor: 'accessing' stamp: 'md 8/31/2005 07:59'!
addPaneMorph: aMorph
	self addMorph: aMorph fullFrame: aMorph layoutFrame! !

!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:05'!
closeWindowSelector
	^closeWindowSelector! !

!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:05'!
closeWindowSelector: aSymbol
	closeWindowSelector := aSymbol! !

!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'!
getChildrenSelector
	^getChildrenSelector! !

!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'!
getChildrenSelector: aSymbol
	getChildrenSelector := aSymbol! !

!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'!
getLabelSelector
	^getLabelSelector! !

!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:53'!
getLabelSelector: aSymbol
	getLabelSelector := aSymbol.
	self update: aSymbol.! !

!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:52'!
label
	^label contents! !

!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:51'!
label: aString
	self setLabel: aString.! !


!PluggableSystemWindow methodsFor: 'updating' stamp: 'ar 2/11/2005 20:15'!
update: what
	what ifNil:[^self].
	what == getLabelSelector ifTrue:[self setLabel: (model perform: getLabelSelector)].
	what == getChildrenSelector ifTrue:[
		children ifNil:[children := #()].
		self removeAllMorphsIn: children.
		children := model perform: getChildrenSelector.
		self addAllMorphs: children.
		children do:[:m| m hResizing: #spaceFill; vResizing: #spaceFill].
	].
	^super update: what! !


!PluggableSystemWindow methodsFor: 'initialization' stamp: 'ar 9/17/2005 21:08'!
delete
	closeWindowSelector ifNotNil:[model perform: closeWindowSelector].
	super delete.
! !
Morph subclass: #PluggableTabBarMorph
	instanceVariableNames: 'target tabs activeTab'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!
!PluggableTabBarMorph commentStamp: 'KLC 9/17/2004 11:26' prior: 0!
This morph manages a set of PluggableTabButtonMorphs.  Each tab should be added in the left to right order that they should be displayed.  Each tab will be evenly sized to fit the available space.  This morph intercepts mouse clicks, figures out which tab was clicked, pops up the new tab as the active tab and triggers the registered event.  See PluggableTabButtonMorph for information on what a tab can consist of.

Example:

(PluggableTabBarMorph on: nil)
	addTab: (Text fromString: 'Test') withAction: [Transcript show: 'Test'; cr];
	addTab: (Text fromString: 'Another') withAction: [Transcript show: 'Another'; cr];
	width: 200;
	openInHand
!


!PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/24/2004 15:26'!
addTab: aStringOrTextOrMorph withAction: aSymbolOrBlock
	"Add a new tab.  The tab will be added onto the end of the list and displayed on the far right of previously added tabs.  The first argument can be a simple String, a Text, or any Morph.  The second argument is the action to be performed when the tab is selected. It can either be a symbol for a unary method on the target object or a block.  Each tab is stored as an Association with the created tab as the key and the selector as the value."
	| tabMorph |
	tabMorph _ PluggableTabButtonMorph on: nil label: [ aStringOrTextOrMorph].
	tabMorph color: self color.
	self addMorphBack: tabMorph.
	self tabs ifEmpty: [ self activeTab: tabMorph ].
	self tabs add: (Association key: tabMorph value: aSymbolOrBlock).
	self layoutChanged.
	self changed.! !

!PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 17:36'!
color: aFillStyle
	color _ aFillStyle.
	self tabs do: [ :anAssociation |
		anAssociation key color: aFillStyle ]
! !

!PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 10:37'!
target: anObject
	target _ anObject! !


!PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/2/2004 16:22'!
handlesMouseDown: anEvent
	^ true! !

!PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/2/2004 17:49'!
layoutChanged
	"Fix up our tabs bounds"
	| tabsCount |
	super layoutChanged.
	tabsCount _ self tabs size.
	tabsCount isZero ifFalse: [ | tabInnerExtent count |
		tabInnerExtent _ ((self width -
				((self tabs first key outerGap + self tabs last key outerGap) // 2)
					- tabsCount)
			 		// tabsCount)
			@ (self height).
		count _ 1.
		self tabs do: [ :anAssociation | | tab |
			tab _ anAssociation key.
			tab innerExtent: tabInnerExtent.
			count = 1
				ifTrue: [tab position: self position]
				ifFalse: [
					tab position:
						(self position translateBy:
							((tabInnerExtent x + 1) * (count - 1))@0)].
			count _ count + 1  ]	].
	self changed.! !

!PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/24/2004 15:14'!
mouseDown: anEvent
	| xPosition newTab |
	xPosition _ anEvent cursorPoint x.
	newTab _
		((self tabs detect: [ :anAssociation | | tabBounds |
				tabBounds _ anAssociation key bounds.
				(tabBounds left <= xPosition) and: [ tabBounds right >= xPosition]]
			ifNone: [nil])
		key).
	newTab ifNil: [^ self].
	newTab = activeTab ifFalse: [ self activeTab: newTab ]
! !

!PluggableTabBarMorph methodsFor: 'actions' stamp: 'tlk 7/17/2004 14:35'!
performActiveTabAction
	"Look up the Symbol or Block associated with the currently active tab, and perform it."
	
	| tabActionAssoc aSymbolOrBlock |
	
	tabActionAssoc _ self tabs detect: [ :assoc | assoc key = self activeTab.] ifNone: [ Association new ].
	aSymbolOrBlock _ tabActionAssoc value.
	aSymbolOrBlock ifNil: [ ^ false ].
	^ aSymbolOrBlock isSymbol
		ifTrue: [ self target perform: aSymbolOrBlock ]
		ifFalse: [ aSymbolOrBlock value ].
	! !


!PluggableTabBarMorph methodsFor: 'drawing' stamp: 'KLC 2/24/2004 15:10'!
drawOn: aCanvas
	self tabs size > 0 ifFalse: [^ self ].
	self tabs do: [ :anAssociation | | tab |
		tab _ anAssociation key.
		tab drawOn: aCanvas]! !


!PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 14:17'!
activeTab
	activeTab ifNil: [
		self tabs size > 0 ifTrue: [
			activeTab _ self tabs first key.
			activeTab active: true]].
	^ activeTab ! !

!PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/24/2004 15:27'!
activeTab: aTabMorph
	self activeTab ifNotNil: [self activeTab toggle].
	activeTab _ aTabMorph.
	self activeTab toggle.
	aTabMorph delete.
	self addMorphFront: aTabMorph.
	self performActiveTabAction.
	self changed.
! !

!PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 13:25'!
tabs
	tabs ifNil: [ tabs _ OrderedCollection new ].
	^ tabs! !

!PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 10:37'!
target
	^ target! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTabBarMorph class
	instanceVariableNames: ''!

!PluggableTabBarMorph class methodsFor: 'instance creation' stamp: 'KLC 2/2/2004 10:38'!
on: anObject
	^ super new target: anObject! !
Morph subclass: #PluggableTabButtonMorph
	instanceVariableNames: 'active model textSelector arcLengths subMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!
!PluggableTabButtonMorph commentStamp: 'KLC 9/17/2004 11:27' prior: 0!
This is a specialized pluggable button morph that is meant to represent a tab in a set of tabs arranged horizontally.  Each tab will overlap slightly when drawn.  All but one tab will be drawn in left to right order in the specified color, but lighter.  The active tab will be drawn last in the full color and slightly taller to indicate that it is selected.  Clicking the active tab has no effect but clicking any other tab will change the active tab to the clicked tab.

This morph does not itself accept any events.  The parent tab set will grab the mouse clicks and handle notifying the appropriate tabs that they have been activated or deactivated.

There is a single selector which provides the text for the button label and affects the width of the tab.  When the width changes the tab will inform its parent that it has changed and that the layout needs to be updated.  The model for the text selector of course should be the client for the tab set.

The button label can be a String, Text, or Morph.  Texts work better than plain Strings.!


!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:25'!
active
	active ifNil: [ active _ false ].
	^ active! !

!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:26'!
active: aBoolean
	active _ aBoolean.
	self changed.! !

!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 14:05'!
innerExtent: aPoint
	"Set the extent based on the primary visible part of the tab.  In other words add twice the cornerRadius to this extent"
	self extent: (aPoint x + (self cornerRadius * 2)) @ (aPoint y)! !

!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'!
model
	^ model
! !

!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'!
model: anObject
	model _ anObject! !

!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 14:07'!
outerGap
	"The horizontal distance of the outer left and right edges of the tab excluding the inner visible part"
	^ self cornerRadius * 2! !

!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'!
textSelector
	^ textSelector
! !

!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'!
textSelector: aSymbol
	textSelector _ aSymbol! !


!PluggableTabButtonMorph methodsFor: 'actions' stamp: 'KLC 1/23/2004 15:38'!
toggle
	self active: self active not! !


!PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 1/23/2004 15:49'!
drawOn: aCanvas
	self drawTabOn: aCanvas.
	self drawSubMorphOn: aCanvas! !

!PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 9/17/2004 11:24'!
drawSubMorphOn: aCanvas
	| morphBounds |
	morphBounds _ self bounds insetBy: (self cornerRadius + 3) @ (self topInactiveGap // 2 + 2).
	morphBounds _ morphBounds translateBy: 0@(self topInactiveGap // 2 + 1).
	self active ifTrue: [
		morphBounds _ morphBounds translateBy: 0@((self topInactiveGap // 2 + 1) negated)].
	self subMorph bounds height < (morphBounds height)
		ifTrue: [
			morphBounds _ morphBounds
				insetBy: 0@((morphBounds height - self subMorph bounds height) // 2)].
	self subMorph bounds width < (morphBounds width)
		ifTrue: [
			morphBounds _ morphBounds
				insetBy: ((morphBounds width - self subMorph bounds width) // 2)@0].

	self subMorph bounds: morphBounds.			
	aCanvas drawMorph: self subMorph! !

!PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 2/2/2004 15:07'!
drawTabOn: aCanvas
	| top myColor cornerRadius myArcLengths myBounds |
	cornerRadius _ self cornerRadius.
	myBounds _ self bounds.
	self active
		ifTrue: [ top _ myBounds top.
			myColor _ self color ]
		ifFalse: [ top _ myBounds top + self topInactiveGap.
			myColor _ self color whiter whiter ].
	aCanvas fillRectangle:
		((myBounds left + cornerRadius)
				@ (top + cornerRadius)
			corner: (myBounds right - cornerRadius)
						@ self bottom)
		color: myColor.
	aCanvas fillRectangle:
		((myBounds left + (cornerRadius * 2)) @ top
			corner: (myBounds right - (cornerRadius * 2))
				@ (top + cornerRadius))
		color: myColor.
	aCanvas fillOval:
		((myBounds left + self cornerRadius) @ top
			corner: (myBounds left + (self cornerRadius * 3))
				@ (top + (self cornerRadius * 2)))
		color: myColor.
	aCanvas fillOval:
		((myBounds right - (self cornerRadius * 3)) @ top
			corner: (myBounds right - self cornerRadius)
				@ (top + (self cornerRadius * 2)))
		color: myColor.

	myArcLengths _ self arcLengths.
	1 to: myArcLengths size do: [ :i | | length |
		length _ myArcLengths at: i.
		aCanvas line: (myBounds left + cornerRadius - i) @ (myBounds bottom - 1 )
			to: (myBounds left + cornerRadius - i) @ (myBounds bottom - length - 1)
			color: myColor.
		aCanvas line: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - 1)
			to: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - length - 1)
			color: myColor]
	
! !


!PluggableTabButtonMorph methodsFor: 'initialization' stamp: 'KLC 1/22/2004 16:45'!
initialize
	^ super initialize
! !


!PluggableTabButtonMorph methodsFor: 'precalculations' stamp: 'KLC 1/23/2004 14:46'!
calculateArcLengths
	| array radius |
	radius _ self cornerRadius.
	array _ Array new: radius.
	
	1 to: radius do: [ :i | | x |
		x _ i - 0.5.
		array at: i
		 	put: (radius - ((2 * x * radius) - (x * x)) sqrt) asInteger].
		
	self arcLengths: array! !


!PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 2/2/2004 10:15'!
step
	self subMorph step.
	self changed.
! !

!PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'!
stepTime
	^ self subMorph stepTime
! !

!PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'!
wantsSteps
	^ self subMorph wantsSteps! !


!PluggableTabButtonMorph methodsFor: 'updating' stamp: 'KLC 1/23/2004 17:02'!
update: aSelector
	self textSelector ifNotNil: [
		aSelector = self textSelector
			ifTrue: [ | morph |
				(aSelector isSymbol and: [model notNil])
					ifTrue: [
						morph _
							(self model perform: aSelector) asMorph]
					ifFalse: [ morph _ aSelector value asMorph].
				self subMorph: morph]].
	self changed! !


!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:36'!
arcLengths
	arcLengths ifNil: [ self calculateArcLengths ].
	^ arcLengths! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:37'!
arcLengths: anArrayOfIntegers
	arcLengths _ anArrayOfIntegers
! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'!
cornerRadius
	^ 5
! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'!
subMorph
	subMorph ifNil: [ self update: self textSelector ].
	^ subMorph! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'!
subMorph: aMorph
	subMorph _ aMorph
! !

!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'!
topInactiveGap
	^ 5! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTabButtonMorph class
	instanceVariableNames: ''!

!PluggableTabButtonMorph class methodsFor: 'instance creation' stamp: 'KLC 1/22/2004 14:46'!
on: anObject label: getTextSelector
	| instance |
	instance _ super new.
	instance model: anObject.
	instance textSelector: getTextSelector.
	^ instance ! !
Object subclass: #PluggableTest
	instanceVariableNames: 'musicTypeList musicTypeIndex artistList artistIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableTest commentStamp: '<historical>' prior: 0!
This class demonstrates how to use PluggableListViews.
!


!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:20'!
artist

	^ artistIndex
! !

!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:20'!
artist: anInteger

	artistIndex _ anInteger.
	self changed: #artist.
! !

!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:14'!
artistKeystroke: aCharacter

	self artistList doWithIndex: [:artist :i |
		(artist first asLowercase = aCharacter asLowercase) ifTrue: [
			self artist: i]].
! !

!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:21'!
artistList

	((musicTypeIndex ~= nil) and:
	 [musicTypeIndex between: 1 and: artistList size])
		ifTrue: [^ artistList at: musicTypeIndex]
		ifFalse: [^ #()].
! !

!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:20'!
artistName
	"Answer the name of the currently selected artist, or nil if no artist is selected."

	| artistsForCurrentType |
	artistsForCurrentType _ self artistList.
	(artistIndex between: 1 and: artistsForCurrentType size)
		ifTrue: [^ artistsForCurrentType at: artistIndex]
		ifFalse: [^ nil].
! !


!PluggableTest methodsFor: 'initialization' stamp: 'jm 5/3/1998 16:20'!
initialize

	musicTypeList _ #('reggae' 'classical' 'early').
	artistList _ #(
		('alpha blondy' 'black uhuru' 'bob marley' 'burning spear')
		('bach' 'beethoven' 'josquin' 'morley' 'mozart' 'telemann')
		('josquin' 'morley' 'telemann')).
	musicTypeIndex _ 0.
	artistIndex _ 0.
! !


!PluggableTest methodsFor: 'menu commands' stamp: 'jm 5/3/1998 16:00'!
earlyCmd

	self musicType: (musicTypeList indexOf: 'early').
! !

!PluggableTest methodsFor: 'menu commands'!
flashCmd

	Display reverse; reverse.! !

!PluggableTest methodsFor: 'menu commands'!
grungeCmd

	SelectionMenu confirm:
		'You mean, like those strange bands from Seattle?'! !

!PluggableTest methodsFor: 'menu commands' stamp: 'sw 8/18/1998 12:29'!
perform: sel orSendTo: otherObject
	(self respondsTo: sel) ifTrue: [self perform: sel] ifFalse: [otherObject perform: sel]! !

!PluggableTest methodsFor: 'menu commands' stamp: 'jm 5/3/1998 15:59'!
reggaeCmd

	self musicType: (musicTypeList indexOf: 'reggae').
! !


!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:21'!
musicType

	^ musicTypeIndex
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:21'!
musicType: anInteger

	| oldArtist |
	oldArtist _ self artistName.
	musicTypeIndex _ anInteger.  "this changes artists list"
	artistIndex _ self artistList indexOf: oldArtist.
	self changed: #musicType.
	self changed: #artistList.
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/2/1998 15:18'!
musicTypeKeystroke: aCharacter

	musicTypeList doWithIndex: [:type :i |
		(type first asLowercase = aCharacter asLowercase)
			ifTrue: [self musicType: i]].
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:11'!
musicTypeList

	^ musicTypeList
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'sw 8/18/1998 12:31'!
musicTypeListTitle
	^ 'Choose a command'! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:00'!
musicTypeMenu: aMenu

	^ aMenu addList: #(
		(reggae reggaeCmd)
		(early earlyCmd)
		(grunge grungeCmd)
		-
		(flash flashCmd))
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:21'!
musicTypeName
	"Answer the name of the currently selected music type, or nil if no music type is selected."

	(musicTypeIndex between: 1 and: musicTypeList size)
		ifTrue: [^ musicTypeList at: musicTypeIndex]
		ifFalse: [^ nil].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTest class
	instanceVariableNames: ''!

!PluggableTest class methodsFor: 'example' stamp: 'nk 7/30/2004 21:50'!
open
	"PluggableTest open"

	| model listView1 topView listView2 |
	model := self new.
	listView1 := PluggableListView 
				on: model
				list: #musicTypeList
				selected: #musicType
				changeSelected: #musicType:
				menu: #musicTypeMenu:
				keystroke: #musicTypeKeystroke:.
	listView1 menuTitleSelector: #musicTypeListTitle.
	listView2 := PluggableListView 
				on: model
				list: #artistList
				selected: #artist
				changeSelected: #artist:
				menu: nil
				keystroke: #artistKeystroke:.
	topView := (StandardSystemView new)
				label: 'Pluggable Test';
				minimumSize: 300 @ 200;
				borderWidth: 1;
				addSubView: listView1;
				addSubView: listView2 toRightOf: listView1.
	topView borderWidth: 1.
	topView controller open! !
TextAction subclass: #PluggableTextAttribute
	instanceVariableNames: 'evalBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!PluggableTextAttribute commentStamp: '<historical>' prior: 0!
An attribute which evaluates an arbitrary block when it is selected.!


!PluggableTextAttribute methodsFor: 'clicking' stamp: 'ls 6/21/2001 18:13'!
actOnClickFor: anObject
	evalBlock ifNil: [ ^self ].
	evalBlock numArgs = 0 ifTrue: [ evalBlock value.  ^true ].
	evalBlock numArgs = 1 ifTrue: [ evalBlock value: anObject.  ^true ].
	self error: 'evalBlock should have 0 or 1 arguments'! !


!PluggableTextAttribute methodsFor: 'initialization' stamp: 'ls 6/21/2001 18:06'!
evalBlock: aBlock
	evalBlock := aBlock! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTextAttribute class
	instanceVariableNames: ''!

!PluggableTextAttribute class methodsFor: 'instance creation' stamp: 'ls 6/21/2001 18:09'!
evalBlock: aBlock
	^super new evalBlock: aBlock! !
StringHolderController subclass: #PluggableTextController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableTextController methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:37'!
selectForTopFrom: start to: stop
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	self selectFrom: start to: stop scroll: #selectAndScrollToTop! !

!PluggableTextController methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:37'!
selectFrom: start to: stop
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	self selectFrom: start to: stop scroll: #selectAndScroll! !

!PluggableTextController methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:35'!
selectFrom: start to: stop scroll: scrollCommand
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	(start = self startIndex and: [stop + 1 = self stopIndex]) ifFalse:
		[view superView ifNotNil: [self deselect].
		self selectInvisiblyFrom: start to: stop].
	view superView ifNotNil: [self perform: scrollCommand]! !


!PluggableTextController methodsFor: 'as yet unclassified' stamp: 'dgd 9/21/2003 17:47'!
accept 
	view hasUnacceptedEdits ifFalse: [^ view flash].
	view hasEditingConflicts ifTrue:
		[(self confirm: 
'Caution!! This method may have been
changed elsewhere since you started
editing it here.  Accept anyway?' translated) ifFalse: [^ self flash]].

	(view setText: paragraph text from: self) ifTrue:
		[initialText _ paragraph text copy.
		view ifNotNil: [view hasUnacceptedEdits: false]]    .
! !

!PluggableTextController methodsFor: 'as yet unclassified' stamp: 'tk 3/31/98 20:49'!
userHasEdited
	"Note that the user has edited my text."

	view hasUnacceptedEdits: true! !

!PluggableTextController methodsFor: 'as yet unclassified' stamp: 'tk 3/31/98 20:49'!
userHasNotEdited
	"Note that my text is free of user edits."

	view hasUnacceptedEdits: false! !


!PluggableTextController methodsFor: 'transcript' stamp: 'di 6/3/1998 20:46'!
appendEntry
	"Append the text in the model's writeStream to the editable text. "
	self deselect.
	paragraph text size > model characterLimit ifTrue:
		["Knock off first half of text"
		self selectInvisiblyFrom: 1 to: paragraph text size // 2.
		self replaceSelectionWith: Text new].
	self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size.
	self replaceSelectionWith: model contents asText.
	self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size! !

!PluggableTextController methodsFor: 'transcript' stamp: 'sma 3/15/2000 21:39'!
bsText
	self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! !

!PluggableTextController methodsFor: 'transcript' stamp: 'di 5/13/1998 14:16'!
changeText: aText
	"The paragraph to be edited is changed to aText."
	paragraph text: aText.
	self resetState.
	self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size.
	self selectAndScroll.
	self deselect! !

!PluggableTextController methodsFor: 'transcript' stamp: 'di 6/3/1998 20:42'!
doOccluded: actionBlock
	| paneRect rectSet bottomStrip |
	paneRect _ paragraph clippingRectangle.
	paragraph withClippingRectangle: (paneRect withHeight: 0)
		do: [actionBlock value.
			self scrollIn: paneRect].
	view topView isCollapsed ifTrue: [^ self].
	rectSet _ self visibleAreas.
	bottomStrip _ paneRect withTop: paragraph compositionRectangle bottom + 1.
	rectSet do:
		[:rect |
		(bottomStrip intersects: rect) ifTrue:
			["The subsequent displayOn should clear this strip but it doesnt"
			Display fill: (bottomStrip intersect: rect)
					fillColor: paragraph backgroundColor].
		paragraph withClippingRectangle: rect
				do: [paragraph displayOn: Display]]! !

!PluggableTextController methodsFor: 'transcript' stamp: 'th 9/20/2002 11:26'!
scrollIn: scrollRect
	"Altered from selectAndScroll so can use with null clipRect"
	"Scroll until the selection is in the view and then highlight it."
	| deltaY |
	deltaY _ self stopBlock top - scrollRect top.
	deltaY >= 0 
		ifTrue: [deltaY _ self stopBlock bottom - scrollRect bottom max: 0].
						"check if stopIndex below bottom of scrollRect"
	deltaY ~= 0 
		ifTrue: [self scrollBy: (deltaY abs + paragraph lineGrid - 1) * deltaY sign]! !

!PluggableTextController methodsFor: 'transcript' stamp: 'di 5/7/1998 22:23'!
visibleAreas
	"Transcript dependents last controller visibleAreas"
	| visibleAreas rect remnants myTopController |
	myTopController _ self view topView controller.
	visibleAreas _ Array with: view insetDisplayBox.
	myTopController view uncacheBits.
	ScheduledControllers scheduledWindowControllers do:
		[:c | c == myTopController ifTrue: [^ visibleAreas].
		rect _ c view windowBox.
		remnants _ OrderedCollection new.
		visibleAreas do: [:a | remnants addAll: (a areasOutside: rect)].
		visibleAreas _ remnants].
	^ visibleAreas! !
ScrollPane subclass: #PluggableTextMorph
	instanceVariableNames: 'textMorph getTextSelector setTextSelector getSelectionSelector hasUnacceptedEdits askBeforeDiscardingEdits selectionInterval hasEditingConflicts'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!

!PluggableTextMorph methodsFor: 'accessing' stamp: 'sr 4/25/2000 07:21'!
getTextSelector
	^getTextSelector! !


!PluggableTextMorph methodsFor: 'debug and other' stamp: 'di 5/3/1998 12:45'!
installModelIn: aWorld
	"No special inits for new components"
	^ self! !


!PluggableTextMorph methodsFor: 'dependents access' stamp: 'di 4/20/1998 18:52'!
canDiscardEdits
	"Return true if this view either has no text changes or does not care."

	^ (hasUnacceptedEdits & askBeforeDiscardingEdits) not
! !

!PluggableTextMorph methodsFor: 'dependents access' stamp: 'di 4/20/1998 18:56'!
hasUnacceptedEdits
	"Return true if this view has unaccepted edits."

	^ hasUnacceptedEdits! !


!PluggableTextMorph methodsFor: 'drawing' stamp: 'sw 5/22/2001 16:43'!
drawOn: aCanvas 
	"Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame"

	super drawOn: aCanvas. 
	self wantsFrameAdornments ifTrue:
		[(model notNil and: [model refusesToAcceptCode])
			ifTrue:  "Put up feedback showing that code cannot be submitted in this state"
				[aCanvas frameRectangle: self innerBounds width: 2 color: Color tan]
			ifFalse:
				[self hasEditingConflicts
					ifTrue:
						[aCanvas frameRectangle: self innerBounds width: 3 color: Color red] 
					ifFalse:
						[self hasUnacceptedEdits
							ifTrue:
								[model wantsDiffFeedback
									ifTrue:
										[aCanvas frameRectangle: self innerBounds width: 3 color: Color green]
									ifFalse:
										[aCanvas frameRectangle: self innerBounds width: 1 color: Color red]]
							ifFalse:
								[model wantsDiffFeedback
									ifTrue:
										[aCanvas frameRectangle: self innerBounds width: 1 color: Color green]]]]]! !

!PluggableTextMorph methodsFor: 'drawing' stamp: 'dgd 10/1/2004 12:32'!
wantsFrameAdornments
	"Answer whether the receiver wishes to have red borders, etc.,  
	used to show editing state"
	"A 'long-term temporary workaround': a nonmodular,  
	unsavory, but expedient way to get the desired effect, sorry.  
	Clean up someday."
	^ self
		valueOfProperty: #wantsFrameAdornments
		ifAbsent: [(#(#annotation #searchString #infoViewContents ) includes: getTextSelector) not]! !

!PluggableTextMorph methodsFor: 'drawing' stamp: 'dgd 10/1/2004 12:32'!
wantsFrameAdornments: aBoolean 
	self setProperty: #wantsFrameAdornments toValue: aBoolean! !


!PluggableTextMorph methodsFor: 'dropping/grabbing' stamp: 'jcg 7/7/2000 11:13'!
wantsDroppedMorph: aMorph event: anEvent 
	^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! !


!PluggableTextMorph methodsFor: 'editor access' stamp: 'di 11/2/1998 15:57'!
handleEdit: editBlock
	| result |
	textMorph editor selectFrom: selectionInterval first to: selectionInterval last;
						model: model.  "For, eg, evaluateSelection"
	textMorph handleEdit: [result _ editBlock value].   "Update selection after edit"
	self scrollSelectionIntoView.
	^ result! !

!PluggableTextMorph methodsFor: 'editor access' stamp: 'di 5/22/1998 12:35'!
scrollSelectionIntoView
	"Scroll my text into view if necessary and return true, else return false"
	^ self scrollSelectionIntoView: nil! !

!PluggableTextMorph methodsFor: 'editor access' stamp: 'kfr 11/14/2004 13:20'!
scrollSelectionIntoView: event 
	"Scroll my text into view if necessary and return true, else return false"
	| selRects delta selRect rectToTest transform cpHere |
	selectionInterval _ textMorph editor selectionInterval.
	selRects _ textMorph paragraph selectionRects.
	selRects isEmpty ifTrue: [^ false].
	rectToTest _ selRects first merge: selRects last.
	transform _ scroller transformFrom: self.
	(event notNil and: [event anyButtonPressed]) ifTrue:  "Check for autoscroll"
		[cpHere _ transform localPointToGlobal: event cursorPoint.
		cpHere y <= self top
			ifTrue: [rectToTest _ selRects first topLeft extent: 2@2]
			ifFalse: [cpHere y >= self bottom
					ifTrue: [rectToTest _ selRects last bottomRight extent: 2@2]
					ifFalse: [^ false]]].
	selRect _ transform localBoundsToGlobal: rectToTest.
	selRect height > bounds height
		ifTrue: [^ false].  "Would not fit, even if we tried to scroll"
	(delta _ selRect amountToTranslateWithin: self innerBounds) y ~= 0 ifTrue:
		["Scroll end of selection into view if necessary"
		self scrollBy: 0@delta y.
		^ true].
	^ false! !

!PluggableTextMorph methodsFor: 'editor access' stamp: 'sw 7/24/2001 02:21'!
selectAll
	"Tell my textMorph's editor to select all"

	textMorph editor selectAll! !

!PluggableTextMorph methodsFor: 'editor access' stamp: 'sw 7/24/2001 02:24'!
setTextMorphToSelectAllOnMouseEnter
	"Tell my textMorph's editor to select all when the mouse enters"

	textMorph on: #mouseEnter send: #selectAll to: textMorph! !


!PluggableTextMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:21'!
handlesKeyboard: evt
	^true! !

!PluggableTextMorph methodsFor: 'event handling' stamp: 'sw 12/12/2000 14:42'!
keyStroke: evt
	"A keystroke was hit while the receiver had keyboard focus.  Pass the keywtroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler"

	textMorph keyStroke: evt.
	self eventHandler ifNotNil:
		[self eventHandler keyStroke: evt fromMorph: self].
! !

!PluggableTextMorph methodsFor: 'event handling' stamp: 'di 11/22/2001 09:52'!
mouseEnter: event
	super mouseEnter: event.
	selectionInterval ifNotNil:
		[textMorph editor selectInterval: selectionInterval; setEmphasisHere].
	textMorph selectionChanged.
	event hand newKeyboardFocus: textMorph! !

!PluggableTextMorph methodsFor: 'event handling' stamp: 'sw 12/4/2001 12:42'!
mouseLeave: event
	"The mouse has left the area of the receiver"

	textMorph ifNotNil: [selectionInterval _ textMorph editor selectionInterval].
	super mouseLeave: event.
	Preferences mouseOverForKeyboardFocus ifTrue:
		[event hand releaseKeyboardFocus: textMorph]! !

!PluggableTextMorph methodsFor: 'event handling' stamp: 'dvf 7/28/2003 14:50'!
onKeyStrokeSend: sel to: recipient
	textMorph on: #keyStroke send: sel to: recipient.! !


!PluggableTextMorph methodsFor: 'geometry' stamp: 'nk 7/11/2004 19:08'!
extent: newExtent

	bounds extent = newExtent ifTrue: [^ self].
	super extent: (newExtent max: 36@16).
	textMorph ifNotNil:
		[textMorph extent: (self innerBounds width-6)@self height].
	self setScrollDeltas
! !

!PluggableTextMorph methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:15'!
extraScrollRange
	^ self height // 4! !

!PluggableTextMorph methodsFor: 'geometry' stamp: 'kfr 6/8/2000 22:38'!
resetExtent
	"Reset the extent while maintaining the current selection.  Needed when resizing while the editor is active (when inside the pane)."
	| tempSelection |
	textMorph notNil ifTrue:
		["the current selection gets munged by resetting the extent, so store it"
		tempSelection _ self selectionInterval.
		
		"don't reset it if it's not active"
		tempSelection = (Interval from: 1 to: 0) 
						ifTrue: [retractableScrollBar
							ifTrue:[ ^ self]].
		self extent: self extent.
		self setSelection: tempSelection]! !

!PluggableTextMorph methodsFor: 'geometry' stamp: 'dew 2/19/1999 17:08'!
scrollDeltaHeight
	"Return the increment in pixels which this pane should be scrolled."
	^ scroller firstSubmorph defaultLineHeight
! !


!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 9/11/1998 15:46'!
acceptOnCR: trueOrFalse
	textMorph acceptOnCR: trueOrFalse! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 5/4/1998 15:55'!
editString: aString 
	"Jam some text in.  This is treated as clean text by default."

	self setText: aString asText! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'bolot 11/2/1999 03:18'!
font: aFont
	textMorph beAllFont: aFont! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:19'!
initialize
	"initialize the state of the receiver"
	super initialize.
	hasUnacceptedEdits _ false.
	hasEditingConflicts _ false.
	askBeforeDiscardingEdits _ true.
! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 4/9/98 16:25'!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	self model: anObject.
	getTextSelector _ getTextSel.
	setTextSelector _ setTextSel.
	getSelectionSelector _ getSelectionSel.
	getMenuSelector _ getMenuSel.
	self borderWidth: 1.
	self setText: self getText.
	self setSelection: self getSelection.! !


!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 6/22/1998 15:15'!
correctFrom: start to: stop with: aString
	^ self handleEdit: [textMorph editor correctFrom: start to: stop with: aString]! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'jcg 11/5/2000 22:25'!
correctSelectionWithString: aString
	| result newPosition |

	"I can't tell if this is a hack or if it's the right thing to do."
	self setSelection: selectionInterval. 

	result _ self correctFrom: selectionInterval first to: selectionInterval last with: aString.
	newPosition _ selectionInterval first + aString size.
	self setSelection: (newPosition to: newPosition - 1).
	^ result! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:16'!
deselect
	^ textMorph editor deselect! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:26'!
nextTokenFrom: start direction: dir
	^ textMorph editor nextTokenFrom: start direction: dir! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/20/1998 08:32'!
notify: aString at: anInteger in: aStream
	^ textMorph editor notify: aString at: anInteger in: aStream! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:59'!
select
	^ textMorph editor select! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:58'!
selectFrom: start to: stop
	^ textMorph editor selectFrom: start to: stop! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:18'!
selectInvisiblyFrom: start to: stop
	^ textMorph editor selectInvisiblyFrom: start to: stop! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:56'!
selectionInterval
	^ textMorph editor selectionInterval! !


!PluggableTextMorph methodsFor: 'layout' stamp: 'jcg 7/7/2000 11:08'!
acceptDroppingMorph: aMorph event: evt 
	"This message is sent when a morph is dropped onto a morph that has     
	agreed to accept the dropped morph by responding 'true' to the     
	wantsDroppedMorph:Event: message. The default implementation just     
	adds the given morph to the receiver."
	"Here we let the model do its work."

	self model
		acceptDroppingMorph: aMorph
		event: evt
		inMorph: self.

! !


!PluggableTextMorph methodsFor: 'menu commands' stamp: 'ar 9/27/2005 20:54'!
accept 
	"Inform the model of text to be accepted, and return true if OK."

	| ok saveSelection saveScrollerOffset |
"sps 8/13/2001 22:41: save selection and scroll info"
	saveSelection := self selectionInterval copy.
	saveScrollerOffset := scroller offset copy.

	(self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not])
		ifTrue: [^ self flash].

	self hasEditingConflicts ifTrue:
		[(self confirm: 
'Caution!! This method may have been
changed elsewhere since you started
editing it here.  Accept anyway?' translated) ifFalse: [^ self flash]].
	ok := self acceptTextInModel.
	ok==true ifTrue:
		[self setText: self getText.
		self hasUnacceptedEdits: false.
		(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo:
			[:aPane | model changed: #annotation]].

	"sps 8/13/2001 22:41: restore selection and scroll info"
	["During the step for the browser, updateCodePaneIfNeeded is called, and 
		invariably resets the contents of the codeholding PluggableTextMorph
		at that time, resetting the cursor position and scroller in the process.
		The following line forces that update without waiting for the step, 		then restores the cursor and scrollbar"

	ok ifTrue: "(don't bother if there was an error during compile)"
		[(model respondsTo: #updateCodePaneIfNeeded) 
			ifTrue: [model updateCodePaneIfNeeded].
		WorldState addDeferredUIMessage:
			[self currentHand newKeyboardFocus: textMorph.
			scroller offset: saveScrollerOffset.
			self setScrollDeltas.
			self selectFrom: saveSelection first to: saveSelection last]]]

			on: Error do: []
! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tween 8/29/2004 20:25'!
acceptTextInModel
	"Inform the model that the receiver's textMorph's text should be accepted.
	Answer true if the model accepted ok, false otherwise"
	| textToAccept |

	textToAccept := textMorph asText.
	^setTextSelector isNil or:
		[setTextSelector numArgs = 2
			ifTrue: [model perform: setTextSelector with: textToAccept with: self]
			ifFalse: [model perform: setTextSelector with: textToAccept]]
! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'!
again
	self handleEdit: [textMorph editor again]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 4/24/2001 12:24'!
browseChangeSetsWithSelector
	"Help the user track down which change sets mention a particular selector"

	self handleEdit: [textMorph editor browseChangeSetsWithSelector]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:04'!
browseIt
	self handleEdit: [textMorph editor browseIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'md 12/12/2003 16:21'!
cancel
	self setText: self getText.
	self setSelection: self getSelection.
	getTextSelector == #annotation ifFalse:
		[(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo:
			[:aPane | model changed: #annotation]]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'!
changeStyle
	self handleEdit: [textMorph editor changeStyle]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 9/27/1999 11:57'!
chooseAlignment
	self handleEdit: [textMorph editor changeAlignment]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 5/1/2001 21:37'!
classCommentsContainingIt
	self handleEdit: [textMorph editor classCommentsContainingIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 7/31/2002 01:48'!
classNamesContainingIt
	self handleEdit: [textMorph editor classNamesContainingIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:04'!
copySelection
	self handleEdit: [textMorph editor copySelection]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'!
cut
	self handleEdit: [textMorph editor cut]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'vb 7/29/2001 12:45'!
debugIt
	self handleEdit: [textMorph editor debugIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 22:04'!
doIt
	self handleEdit: [textMorph editor evaluateSelection]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'!
explain
	self handleEdit: [textMorph editor explain]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'rhi 12/6/2001 11:06'!
exploreIt

	| result |
	self handleEdit: [
		result _ textMorph editor evaluateSelection.
		((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [self flash]
			ifFalse: [result explore]].! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:02'!
fileItIn
	self handleEdit: [textMorph editor fileItIn]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:42'!
find
	self handleEdit: [textMorph editor find]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:42'!
findAgain
	self handleEdit: [textMorph editor findAgain]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:02'!
implementorsOfIt
	self handleEdit: [textMorph editor implementorsOfIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 22:07'!
inspectIt
	| result |
	self handleEdit:
		[result _ textMorph editor evaluateSelection.
		((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [self flash]
			ifFalse: [result inspect]]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'!
methodNamesContainingIt
	self handleEdit: [textMorph editor methodNamesContainingIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'!
methodSourceContainingIt
	self handleEdit: [textMorph editor methodSourceContainingIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'!
methodStringsContainingit
	self handleEdit: [textMorph editor methodStringsContainingit]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'ar 12/17/2001 13:00'!
offerFontMenu
	self handleEdit: [textMorph editor changeTextFont]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:44'!
paste
	self handleEdit: [textMorph editor paste]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'ar 1/15/2001 18:36'!
pasteRecent
	"Paste an item chosen from RecentClippings."

	| clipping |
	(clipping _ Clipboard chooseRecentClipping) ifNil: [^ self].
	Clipboard clipboardText: clipping.
	^ self handleEdit: [textMorph editor paste]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:44'!
presentSpecialMenu
	self handleEdit: [textMorph editor presentSpecialMenu]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 11/7/1999 00:01'!
prettyPrint
	self handleEdit: [textMorph editor prettyPrint]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 11/7/1999 00:01'!
prettyPrintWithColor
	self handleEdit: [textMorph editor prettyPrintWithColor]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dew 3/7/2000 21:10'!
printerSetup
	self handleEdit: [textMorph editor printerSetup]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:07'!
printIt
	| result oldEditor |

	textMorph editor selectFrom: selectionInterval first to: selectionInterval last;
						model: model.  "For, eg, evaluateSelection"
	textMorph handleEdit: [result _ (oldEditor _ textMorph editor) evaluateSelection].
	((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [^self flash].
	selectionInterval _ oldEditor selectionInterval.
	textMorph installEditorToReplace: oldEditor.
	textMorph handleEdit: [oldEditor afterSelectionInsertAndSelect: result printString].
	selectionInterval _ oldEditor selectionInterval.
	
	textMorph editor selectFrom: selectionInterval first to: selectionInterval last.
	self scrollSelectionIntoView.

! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 15:59'!
referencesToIt
	self handleEdit: [textMorph editor referencesToIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dew 3/7/2000 21:15'!
saveContentsInFile
	self handleEdit: [textMorph editor saveContentsInFile]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 1/22/2001 14:59'!
selectionAsTiles
	self handleEdit: [textMorph editor selectionAsTiles]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dew 3/7/2000 20:09'!
sendContentsToPrinter
	self handleEdit: [textMorph editor sendContentsToPrinter]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 15:31'!
sendersOfIt
	self handleEdit: [textMorph editor sendersOfIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:09'!
setSearchString
	self handleEdit: [textMorph editor setSearchString]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/20/1998 23:11'!
spawn
	self handleEdit: [textMorph editor spawn].
	self cancel! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'ab 3/23/2005 16:50'!
tallyIt
	self handleEdit: [textMorph editor tallyIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 10/30/2000 11:16'!
tileForIt
	"Return a tile referring to the object resulting form evaluating my current selection.  Not currently threaded in, but useful in earlier demos and possibly still of value."

	| result |
	self handleEdit:
		[result _ textMorph editor evaluateSelection.
		((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [self flash]
			ifFalse: [self currentHand attachMorph: result tileToRefer]]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'md 12/12/2003 16:21'!
toggleAnnotationPaneSize

	| handle origin aHand siblings newHeight lf prevBottom m ht |

	self flag: #bob.		"CRUDE HACK to enable changing the size of the annotations pane"

	owner ifNil: [^self].
	siblings _ owner submorphs.
	siblings size > 3 ifTrue: [^self].
	siblings size < 2 ifTrue: [^self].

	aHand _ self primaryHand.
	origin _ aHand position.
	handle _ HandleMorph new
		forEachPointDo: [:newPoint |
			handle removeAllMorphs.
			newHeight _ (newPoint - origin) y asInteger min: owner height - 50 max: 16.
			lf _ siblings last layoutFrame.
			lf bottomOffset: newHeight.
			prevBottom _ newHeight.
			siblings size - 1 to: 1 by: -1 do: [ :index |
				m _ siblings at: index.
				lf _ m layoutFrame.
				ht _ lf bottomOffset - lf topOffset.
				lf topOffset: prevBottom.
				lf bottomOffset = 0 ifFalse: [
					lf bottomOffset: (prevBottom + ht).
				].
				prevBottom _ prevBottom + ht.
			].
			owner layoutChanged.

		]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo ifNotNilDo: [:halo | halo addHandles].
		].
	aHand attachMorph: handle.
	handle setProperty: #helpAtCenter toValue: true.
	handle showBalloon:
'Move cursor farther from
this point to increase pane.
Click when done.' hand: aHand.
	handle startStepping

! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:13'!
undo
	self handleEdit: [textMorph editor undo]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dgd 10/1/2004 13:27'!
yellowButtonActivity
	"Called when the shifted-menu's 'more' item is chosen"
	self yellowButtonActivity: false! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dgd 10/1/2004 13:32'!
yellowButtonActivity: shiftKeyState 
	"Called when the shifted-menu's 'more' item is chosen"
	| menu |
	(menu := self getMenu: shiftKeyState)
		ifNotNil: [""
			menu setInvokingView: self.
			menu invokeModal]! !


!PluggableTextMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:02'!
getSelection
	"Answer the model's selection interval."

	getSelectionSelector isNil ifTrue: [^1 to: 0].	"null selection"
	^model perform: getSelectionSelector! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:02'!
getText
	"Retrieve the current model text"

	| newText |
	getTextSelector isNil ifTrue: [^Text new].
	newText := model perform: getTextSelector.
	newText ifNil: [^Text new].
	^newText shallowCopy! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'di 6/22/1998 01:32'!
selectionInterval: sel
	selectionInterval _ sel! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'wod 5/26/1998 17:03'!
setSelection: sel
	selectionInterval _ sel.
	textMorph editor selectFrom: sel first to: sel last.
	self scrollSelectionIntoView ifFalse: [scroller changed].! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'sw 2/6/2001 01:24'!
setTextColor: aColor
	"Set the color of my text to the given color"

	textMorph color: aColor! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'tween 8/29/2004 20:43'!
setText: aText
	scrollBar setValue: 0.0.
	textMorph
		ifNil: [textMorph _ self textMorphClass new
						contents: aText wrappedTo: self innerBounds width-6.
				textMorph setEditView: self.
				scroller addMorph: textMorph]
		ifNotNil: [textMorph newContents: aText].
	self hasUnacceptedEdits: false.
	self setScrollDeltas.! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'di 4/20/1998 07:59'!
text
	^ textMorph contents! !


!PluggableTextMorph methodsFor: 'scroll bar events' stamp: 'rr 3/10/2004 09:30'!
scrollBarMenuButtonPressed: event
	"The menu button in the scrollbar was pressed; put up the menu"

	| menu |
	(menu _ self getMenu: event shiftPressed) ifNotNil:
		["Set up to use perform:orSendTo: for model/view dispatch"
		menu setInvokingView: self.
		menu invokeModal]! !


!PluggableTextMorph methodsFor: 'scrolling' stamp: 'sps 3/9/2004 15:55'!
hUnadjustedScrollRange
"Return the width of the widest item in the list"

	textMorph ifNil: [ ^0 ].
	textMorph isWrapped ifTrue:[ ^0 ].

	^super hUnadjustedScrollRange
! !


!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/13/1998 14:29'!
appendEntry
	"Append the text in the model's writeStream to the editable text. "
	textMorph asText size > model characterLimit ifTrue:
		["Knock off first half of text"
		self selectInvisiblyFrom: 1 to: textMorph asText size // 2.
		self replaceSelectionWith: Text new].
	self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size.
	self replaceSelectionWith: model contents asText.
	self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size! !

!PluggableTextMorph methodsFor: 'transcript' stamp: 'sma 3/15/2000 21:40'!
bsText
	self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! !

!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/8/1998 21:22'!
changeText: aText
	"The paragraph to be edited is changed to aText."
	self setText: aText! !

!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/9/1998 21:40'!
replaceSelectionWith: aText
	^ textMorph editor replaceSelectionWith: aText! !


!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'di 4/20/1998 18:53'!
askBeforeDiscardingEdits: aBoolean
	"Set the flag that determines whether the user should be asked before discarding unaccepted edits."

	askBeforeDiscardingEdits _ aBoolean! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 22:55'!
hasEditingConflicts
	"Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited"

	^ hasEditingConflicts == true! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 22:55'!
hasEditingConflicts: aBoolean

	hasEditingConflicts _ aBoolean! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 23:06'!
hasUnacceptedEdits: aBoolean
	"Set the hasUnacceptedEdits flag to the given value. "
	aBoolean == hasUnacceptedEdits ifFalse:
		[hasUnacceptedEdits _ aBoolean.
		self changed].
	aBoolean ifFalse: [hasEditingConflicts _ false]! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'dgd 9/21/2003 17:40'!
promptForCancel
	"Ask if it is OK to cancel changes to text"
	(self confirm:
'Changes have not been saved.
Is it OK to cancel those changes?' translated)
		ifTrue: [model clearUserEditFlag].
! !


!PluggableTextMorph methodsFor: 'updating' stamp: 'dgd 2/22/2003 18:58'!
update: aSymbol 
	aSymbol ifNil: [^self].
	aSymbol == #flash ifTrue: [^self flash].
	aSymbol == getTextSelector 
		ifTrue: 
			[self setText: self getText.
			^self setSelection: self getSelection].
	aSymbol == getSelectionSelector 
		ifTrue: [^self setSelection: self getSelection].
	(aSymbol == #autoSelect and: [getSelectionSelector notNil]) 
		ifTrue: 
			[self handleEdit: 
					[ParagraphEditor abandonChangeText.	"no replacement!!"
					(textMorph editor)
						setSearch: model autoSelectString;
						againOrSame: true]].
	aSymbol == #clearUserEdits ifTrue: [^self hasUnacceptedEdits: false].
	aSymbol == #wantToChange 
		ifTrue: 
			[self canDiscardEdits ifFalse: [^self promptForCancel].
			^self].
	aSymbol == #appendEntry 
		ifTrue: 
			[self handleEdit: [self appendEntry].
			^self refreshWorld].
	aSymbol == #clearText 
		ifTrue: 
			[self handleEdit: [self changeText: Text new].
			^self refreshWorld].
	aSymbol == #bs 
		ifTrue: 
			[self handleEdit: [self bsText].
			^self refreshWorld].
	aSymbol == #codeChangedElsewhere 
		ifTrue: 
			[self hasEditingConflicts: true.
			^self changed]! !


!PluggableTextMorph methodsFor: '*eToys-model access' stamp: 'RAA 11/5/2000 14:10'!
eToyGetMainFont

	^ textMorph textStyle! !


!PluggableTextMorph methodsFor: '*eToys-transcript' stamp: 'RAA 5/1/2002 18:17'!
appendTextEtoy: moreText
	"Append the text in the model's writeStream to the editable text. "

	self handleEdit: [
		self 
			selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size;
			replaceSelectionWith: moreText;
			selectFrom: textMorph asText size + 1 to: textMorph asText size;
			hasUnacceptedEdits: false;
			scrollSelectionIntoView;
			changed
	]! !


!PluggableTextMorph methodsFor: '*services-base' stamp: 'rr 3/21/2004 12:29'!
textMorph
	^ textMorph! !


!PluggableTextMorph methodsFor: 'private' stamp: 'tween 8/29/2004 20:42'!
textMorphClass
	"Answer the class used to create the receiver's textMorph"
	
	^TextMorphForEditView! !


!PluggableTextMorph methodsFor: 'html' stamp: 'dgd 9/2/2005 12:41'!
copyHtml
	"put the html representation of the receiver's text into the clipboard"
	Clipboard clipboardText: self text printHtmlString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTextMorph class
	instanceVariableNames: ''!

!PluggableTextMorph class methodsFor: 'as yet unclassified' stamp: 'di 4/7/98 16:03'!
on: anObject text: getTextSel accept: setTextSel

	^ self on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: nil
		menu: nil! !

!PluggableTextMorph class methodsFor: 'as yet unclassified' stamp: 'di 4/7/98 16:03'!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	^ self new on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: getSelectionSel
		menu: getMenuSel! !
PluggableTextMorph subclass: #PluggableTextMorphPlus
	instanceVariableNames: 'getColorSelector acceptAction'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!PluggableTextMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0!
A pluggable text morph with support for color.!


!PluggableTextMorphPlus methodsFor: 'accessing' stamp: 'ar 7/16/2005 19:01'!
acceptAction
	^acceptAction! !

!PluggableTextMorphPlus methodsFor: 'accessing' stamp: 'ar 7/16/2005 19:01'!
acceptAction: anAction
	acceptAction := anAction! !

!PluggableTextMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:21'!
getColorSelector
	^getColorSelector! !

!PluggableTextMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:21'!
getColorSelector: aSymbol
	getColorSelector := aSymbol.
	self update: getColorSelector.! !


!PluggableTextMorphPlus methodsFor: 'updating' stamp: 'ar 7/16/2005 19:02'!
accept
	super accept.
	acceptAction ifNotNil:[acceptAction value: textMorph asText].! !

!PluggableTextMorphPlus methodsFor: 'updating' stamp: 'ar 2/11/2005 21:22'!
update: what
	what ifNil:[^self].
	what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)].
	^super update: what! !
PluggableTextMorph subclass: #PluggableTextMorphWithModel
	instanceVariableNames: 'myContents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!

!PluggableTextMorphWithModel methodsFor: 'contents' stamp: 'mjg 12/3/1999 11:57'!
getMyText
	^myContents! !

!PluggableTextMorphWithModel methodsFor: 'contents' stamp: 'sw 10/26/2000 14:37'!
newTextContents: stringOrText
	"Accept new text contents."

	| newText aStack setter myText |
	"Just underway; trying to make this work like TextMorph does, but not quite there yet."

	newText _ stringOrText asText.
	(myText _ textMorph text) = newText ifTrue: [^ self].  "No substantive change"

	(self holdsSeparateDataForEachInstance and: [(aStack _ self stack) notNil])
		ifTrue:
			[setter _ self valueOfProperty: #setterSelector.
			setter ifNotNil:
				[(self valueOfProperty: #cardInstance) perform: setter with: newText]].

	self world ifNotNil:
		[self world startSteppingSubmorphsOf: self ].
! !

!PluggableTextMorphWithModel methodsFor: 'contents' stamp: 'mjg 12/3/1999 11:59'!
setMyText: someText
	myContents _ someText.
	^true.! !


!PluggableTextMorphWithModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:25'!
initialize
	"initialize the state of the receiver"
	super initialize.
	self
		on: self
		text: #getMyText
		accept: #setMyText:
		readSelection: nil
		menu: nil! !


!PluggableTextMorphWithModel methodsFor: 'submorphs-add/remove' stamp: 'sw 10/26/2000 14:39'!
delete
	"Delete the receiver.  Since I have myself as a dependent, I need to remove it. which is odd in itself.  Also, the release of dependents will seemingly not be done if the *container* of the receiver is deleted rather than the receiver itself, a further problem"

	self removeDependent: self.
	super delete! !


!PluggableTextMorphWithModel methodsFor: '*eToys-card in a stack' stamp: 'sw 10/24/2000 14:52'!
couldHoldSeparateDataForEachInstance
	"Answer whethre the receiver is structurally capable of holding uniqe data for each ard instance"

	^ true! !


!PluggableTextMorphWithModel methodsFor: '*eToys-player' stamp: 'sw 10/30/2000 11:14'!
currentDataValue
	"Answer the current data value of the receiver"

	^ myContents! !

!PluggableTextMorphWithModel methodsFor: '*eToys-player' stamp: 'sw 10/25/2000 07:00'!
variableDocks
	"Answer a list of VariableDocks that will handle the interface between me and instance data stored on my behalf on a card"

	^ Array with: (VariableDock new variableName: self defaultVariableName type: #text definingMorph: self morphGetSelector: #getMyText morphPutSelector: #setMyText:)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTextMorphWithModel class
	instanceVariableNames: ''!

!PluggableTextMorphWithModel class methodsFor: 'scripting' stamp: 'sw 10/30/2000 11:14'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin"

	| proto |
	proto _ super authoringPrototype.
	proto color: (Color r: 0.972 g: 0.972 b: 0.662).
	^ proto! !
PluggableWidgetSpec subclass: #PluggableTextSpec
	instanceVariableNames: 'getText setText selection menu color'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableTextSpec commentStamp: 'ar 2/11/2005 21:58' prior: 0!
A text editor.

Instance variables:
	getText	<Symbol>	The selector to retrieve the text.
	setText	<Symbol>	The selector to set the text.
	selection <Symbol>	The selector to retrieve the text selection.
	menu	<Symbol>	The selector to offer (to retrieve?) the context menu.
	color	 <Symbol>	The selector to retrieve the background color.

!


!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:51'!
color
	"Answer the selector for retrieving the background color"
	^color! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:51'!
color: aSymbol
	"Indicate the selector for retrieving the background color"
	color := aSymbol.! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:23'!
getText
	"Answer the selector for retrieving the text"
	^getText! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:23'!
getText: aSymbol
	"Answer the selector for retrieving the text"
	getText := aSymbol! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:25'!
menu
	"Answer the selector for retrieving the text's menu"
	^menu! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:26'!
menu: aSymbol
	"Indicate the selector for retrieving the text's menu"
	menu := aSymbol! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:25'!
selection
	"Answer the selector for retrieving the text selection"
	^selection! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:25'!
selection: aSymbol
	"Indicate the selector for retrieving the text selection"
	selection := aSymbol! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:24'!
setText
	"Answer the selector for setting the text"
	^setText! !

!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:24'!
setText: aSymbol
	"Answer the selector for setting the text"
	setText := aSymbol! !


!PluggableTextSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableText: self! !
StringHolderView subclass: #PluggableTextView
	instanceVariableNames: 'getTextSelector setTextSelector getSelectionSelector getMenuSelector hasEditingConflicts'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableTextView commentStamp: '<historical>' prior: 0!
A PluggableTextView gets its content from the model. This allows the same kind of view to be used in different situations, thus avoiding a proliferation of gratuitous view and controller classes. See the class comment for PluggableListView.

Selectors are:

		getTextSel		fetch the original text from the model
		setTextSel		submit new text to the model when user "accepts"
		getSelectionSel	get the current text selection range
		getMenuSel		get the pane-specific, 'yellow-button' menu

	Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if setTextSel is nil then this view is consider read-only.

	The model informs a pluggable view of changes by sending #changed: to itself with getTextSel as a parameter. The view informs the model of selection changes by sending setTextSel to it with the newly selected item as a parameter, and invokes menu actions on the model via getMenuSel.
!


!PluggableTextView methodsFor: 'controller access' stamp: 'BG 11/26/2003 16:06'!
selectionInterval

  ^self controller selectionInterval! !


!PluggableTextView methodsFor: 'initialization' stamp: 'jm 3/29/98 07:24'!
defaultControllerClass 

	^ PluggableTextController
! !

!PluggableTextView methodsFor: 'initialization' stamp: 'sw 10/29/1999 21:02'!
initialize 
	super initialize.
	hasEditingConflicts _ false! !

!PluggableTextView methodsFor: 'initialization' stamp: 'tk 4/6/98 10:51'!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	self model: anObject.
	getTextSelector _ getTextSel.
	setTextSelector _ setTextSel.
	getSelectionSelector _ getSelectionSel.
	getMenuSelector _ getMenuSel.
	self borderWidth: 1.
	self editString: self getText.
	self setSelection: self getSelection.

! !

!PluggableTextView methodsFor: 'initialization' stamp: 'jm 3/29/98 07:25'!
setSelection: sel

	controller selectFrom: sel first to: sel last.
! !


!PluggableTextView methodsFor: 'model access' stamp: 'di 6/26/1998 11:06'!
getMenu: shiftKeyDown
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| menu |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ CustomMenu new.
	getMenuSelector numArgs = 1
		ifTrue: [^ model perform: getMenuSelector with: menu].
	getMenuSelector numArgs = 2
		ifTrue: [^ model perform: getMenuSelector with: menu with: shiftKeyDown].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!PluggableTextView methodsFor: 'model access' stamp: 'sw 1/16/1999 14:31'!
getSelection
	"Answer the model's selection interval."

	getSelectionSelector == nil ifTrue: [^ 1 to: 0].  "null selection"
	^ getSelectionSelector ifNotNil: [model perform: getSelectionSelector]
! !

!PluggableTextView methodsFor: 'model access' stamp: 'tk 4/1/98 08:32'!
getText 
	"Answer the list to be displayed."
	| txt |
	getTextSelector == nil ifTrue: [^ Text new].
	txt _ model perform: getTextSelector.
	txt == nil ifTrue: [^ Text new].
	self hasUnacceptedEdits: false.	"clean now"
	^ txt! !

!PluggableTextView methodsFor: 'model access' stamp: 'tk 3/31/98 15:58'!
getTextSelector
	"This is sent to the model to find out what text to display"

	^ getTextSelector! !

!PluggableTextView methodsFor: 'model access' stamp: 'jm 5/3/1998 19:29'!
isReadOnlyView

	^ setTextSelector == nil
! !

!PluggableTextView methodsFor: 'model access' stamp: 'jm
 8/20/1998 11:55'!
model: aLockedModel 
	"Refer to the comment in View|model:."
 
	self model: aLockedModel controller: controller.
	self editString: self getText.
! !

!PluggableTextView methodsFor: 'model access' stamp: 'di 3/10/98 13:51'!
setText: textToAccept from: ctlr
	"Inform the model of text to be accepted, and return true if OK.
	Any errors should be reported to the controller, ctlr."
	setTextSelector == nil ifTrue: [^ true].
	setTextSelector numArgs = 2
		ifTrue: [^ model perform: setTextSelector with: textToAccept with: ctlr]
		ifFalse: [^ model perform: setTextSelector with: textToAccept]! !

!PluggableTextView methodsFor: 'model access' stamp: 'di 4/27/1998 12:46'!
updateDisplayContents

	self editString: self getText.
	self displayView.
	self setSelection: self getSelection.
! !


!PluggableTextView methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:48'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	hasEditingConflicts ifNil: [hasEditingConflicts _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:03'!
hasEditingConflicts
	"Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited"

	^ hasEditingConflicts == true! !

!PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:04'!
hasEditingConflicts: aBoolean
	hasEditingConflicts _ aBoolean! !

!PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:04'!
hasUnacceptedEdits: aBoolean
	super hasUnacceptedEdits: aBoolean.
	aBoolean ifFalse: [hasEditingConflicts _ false]! !

!PluggableTextView methodsFor: 'updating' stamp: 'tk 5/23/2001 12:26'!
update: aSymbol
	"Refer to the comment in View|update:. Do nothing if the given symbol does not match any action. "

	aSymbol == #wantToChange ifTrue:
			[self canDiscardEdits ifFalse: [self promptForCancel].  ^ self].
	aSymbol == #flash ifTrue: [^ controller flash].
	aSymbol == getTextSelector ifTrue: [^ self updateDisplayContents].
	aSymbol == getSelectionSelector ifTrue: [^ self setSelection: self getSelection].
	aSymbol == #clearUserEdits ifTrue: [^ self hasUnacceptedEdits: false].
	(aSymbol == #autoSelect and: [getSelectionSelector ~~ nil]) ifTrue:
			[ParagraphEditor abandonChangeText.	"no replacement!!"
			^ controller setSearch: model autoSelectString;
					againOrSame: true].
	aSymbol == #appendEntry ifTrue:
			[^ controller doOccluded: [controller appendEntry]].
	aSymbol == #clearText ifTrue:
			[^ controller doOccluded:
				[controller changeText: Text new]].
	aSymbol == #bs ifTrue:
			[^ controller doOccluded:
				[controller bsText]].
	aSymbol == #codeChangedElsewhere ifTrue:
			[^ self hasEditingConflicts: true]

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTextView class
	instanceVariableNames: ''!

!PluggableTextView class methodsFor: 'instance creation' stamp: 'jm 3/29/98 07:24'!
on: anObject text: getTextSel accept: setTextSel

	^ self on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: nil
		menu: nil
! !

!PluggableTextView class methodsFor: 'instance creation' stamp: 'jm 3/29/98 07:24'!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	^ self new on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: getSelectionSel
		menu: getMenuSel
! !
TwoWayScrollPane subclass: #PluggableTileScriptorMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Tile Scriptors'!

!PluggableTileScriptorMorph methodsFor: 'as yet unclassified' stamp: 'tk 9/23/2001 02:27'!
syntaxMorph
	"Return the SyntaxMorph(MethodNode) that is inside me."

	| tm |
	^ (tm _ self findA: TransformMorph) ifNotNil: [tm findA: SyntaxMorph]! !


!PluggableTileScriptorMorph methodsFor: 'event handling' stamp: 'tk 9/23/2001 02:28'!
keyStroke: evt
	"A keystroke was hit while the receiver had keyboard focus.  Pass the keystroke on to my syntaxMorph, and also, if I have an event handler, pass it on to that handler"


	| sm |
	(sm _ self syntaxMorph) ifNotNil: [sm keyStroke: evt].
	super keyStroke: evt! !


!PluggableTileScriptorMorph methodsFor: 'updating' stamp: 'tk 9/14/2001 18:16'!
update: aSymbol
	"Update the receiver in the manner suggested by aSymbol"

	aSymbol == #flash ifTrue: [^ self flash].
	(aSymbol == #contents or: [aSymbol == #tiles])
		ifTrue: [^ self containingWindow model installTilesForSelection]! !
ListItemWrapper subclass: #PluggableTreeItemNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0!
Tree item for PluggableTreeMorph.!


!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'!
acceptDroppingObject: anotherItem
	^model dropNode: anotherItem on: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'!
asString
	^model printNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'!
balloonText
	^model balloonTextForNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:02'!
canBeDragged
	^model isDraggableNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:03'!
contents
	^model contentsOfNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'!
hasContents
	^model hasNodeContents: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:04'!
icon
	^model iconOfNode: self! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 01:00'!
item
	^item! !

!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'!
wantsDroppedObject: anotherItem
	^model wantsDroppedNode: anotherItem on: self! !
SimpleHierarchicalListMorph subclass: #PluggableTreeMorph
	instanceVariableNames: 'roots selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedSelector getHelpSelector dropItemSelector wantsDropSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Morphic'!
!PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 0!
A pluggable tree morph.!


!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'!
dropItemSelector
	^dropItemSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'!
dropItemSelector: aSymbol
	dropItemSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'!
getChildrenSelector
	^getChildrenSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'!
getChildrenSelector: aSymbol
	getChildrenSelector := aSymbol.! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'!
getHelpSelector
	^getHelpSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'!
getHelpSelector: aSymbol
	getHelpSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'!
getIconSelector
	^getIconSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'!
getIconSelector: aSymbol
	getIconSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'!
getLabelSelector
	^getLabelSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'!
getLabelSelector: aSymbol
	getLabelSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:57'!
getMenuSelector
	^getMenuSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:57'!
getMenuSelector: aSymbol
	getMenuSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'!
getRootsSelector
	^getRootsSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'!
getRootsSelector: aSelector
	getRootsSelector := aSelector.
	self update: getRootsSelector.! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:33'!
getSelectedPathSelector
	^getSelectedPathSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:33'!
getSelectedPathSelector: aSymbol
	getSelectedPathSelector := aSymbol.! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'!
hasChildrenSelector
	^hasChildrenSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'!
hasChildrenSelector: aSymbol
	hasChildrenSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:58'!
keystrokeActionSelector
	^keystrokeActionSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:58'!
keystrokeActionSelector: aSymbol
	keystrokeActionSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:22'!
roots
	^roots! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 01:11'!
roots: anArray
	roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self].
	self list: roots.! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'!
setSelectedSelector
	^setSelectedSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'!
setSelectedSelector: aSymbol
	setSelectedSelector := aSymbol! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'!
wantsDropSelector
	^wantsDropSelector! !

!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:27'!
wantsDropSelector: aSymbol
	wantsDropSelector := aSymbol! !


!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:19'!
balloonTextForNode: node
	getHelpSelector ifNil:[^nil].
	^model perform: getHelpSelector with: node item! !

!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 01:13'!
contentsOfNode: node
	| children |
	getChildrenSelector ifNil:[^#()].
	children := model perform: getChildrenSelector with: node item.
	^children collect:[:item| PluggableTreeItemNode with: item model: self]! !

!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'!
dropNode: srcNode on: dstNode
	dropItemSelector ifNil:[^nil].
	model perform: dropItemSelector with: srcNode item with: dstNode item! !

!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:11'!
hasNodeContents: node
	hasChildrenSelector ifNil:[^node contents isEmpty not].
	^model perform: hasChildrenSelector with: node item! !

!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'!
iconOfNode: node
	getIconSelector ifNil:[^nil].
	^model perform: getIconSelector with: node item! !

!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:02'!
isDraggableNode: node
	^true! !

!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'!
printNode: node
	getLabelSelector ifNil:[^node item printString].
	^model perform: getLabelSelector with: node item! !

!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 7/15/2005 12:11'!
wantsDroppedNode: srcNode on: dstNode
	dropItemSelector ifNil:[^false].
	wantsDropSelector ifNil:[^true].
	^(model perform: wantsDropSelector with: srcNode with: dstNode) == true! !


!PluggableTreeMorph methodsFor: 'selection' stamp: 'ar 2/12/2005 01:20'!
setSelectedMorph: aMorph
	selectedWrapper := aMorph complexContents.
	self selection: selectedWrapper.
	setSelectedSelector ifNotNil:[
		model 
			perform: setSelectedSelector 
			with: (selectedWrapper ifNotNil:[selectedWrapper item]).
	].! !


!PluggableTreeMorph methodsFor: 'updating' stamp: 'ar 2/12/2005 17:29'!
selectPath: path in: listItem
	path isEmpty ifTrue: [^self setSelectedMorph: nil].
	listItem withSiblingsDo: [:each | 
		(each complexContents item = path first) ifTrue: [
			each isExpanded ifFalse: [
				each toggleExpandedState.
				self adjustSubmorphPositions.
			].
			each changed.
			path size = 1 ifTrue: [
				^self setSelectedMorph: each
			].
			each firstChild ifNil: [^self setSelectedMorph: nil].
			^self selectPath: path allButFirst in: each firstChild
		].
	].
	^self setSelectedMorph: nil

! !

!PluggableTreeMorph methodsFor: 'updating' stamp: 'ar 2/12/2005 19:11'!
update: what
	what ifNil:[^self].
	what == getRootsSelector ifTrue:[
		self roots: (model perform: getRootsSelector)
	].
	what == getSelectedPathSelector ifTrue:[
		^self selectPath: (model perform: getSelectedPathSelector)
			in: (scroller submorphs at: 1 ifAbsent: [^self]) 
	].
	^super update: what! !
PluggableWidgetSpec subclass: #PluggableTreeSpec
	instanceVariableNames: 'roots getSelectedPath setSelected getChildren hasChildren label icon help menu keyPress wantsDrop dropItem dropAccept autoDeselect'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableTreeSpec commentStamp: 'ar 2/12/2005 16:40' prior: 0!
A pluggable tree widget. PluggableTrees are slightly different from lists in such that they ALWAYS store the actual objects and use the label selector to query for the label of the item. PluggableTrees also behave somewhat differently in such that they do not have a "getSelected" message but only a getSelectedPath message. The difference is that getSelectedPath is used to indicate by the model that the tree should select the appropriate path. This allows disambiguation of items. Because of this, implementations of PluggableTrees must always set their internal selection directly, e.g., rather than sending the model a setSelected message and wait for an update of the #getSelected the implementation must set the selection before sending the #setSelected message. If a client doesn't want this, it can always just signal a change of getSelectedPath to revert to whatever is needed.

Instance variables:
	roots 	<Symbol>	The message to retrieve the roots of the tree.
	getSelectedPath	<Symbol> The message to retrieve the selected path in the tree.
	setSelected	<Symbol>	The message to set the selected item in the tree.
	getChildren	<Symbol>	The message to retrieve the children of an item
	hasChildren	<Symbol>	The message to query for children of an item
	label 	<Symbol>	The message to query for the label of an item.
	icon 	<Symbol>	The message to query for the icon of an item.
	help 	<Symbol>	The message to query for the help of an item.
	menu	<Symbol>	The message to query for the tree's menu
	keyPress	<Symbol>	The message to process a keystroke.
	wantsDrop	<Symbol>	The message to query whether a drop might be accepted.
	dropItem	<Symbol>	The message to drop an item.
	autoDeselect	<Boolean>	Whether the tree should allow automatic deselection or not.!


!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 17:38'!
autoDeselect
	"Answer whether this tree can be automatically deselected"
	^autoDeselect ifNil:[true]! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 16:41'!
autoDeselect: aBool
	"Indicate whether this tree can be automatically deselected"
	autoDeselect := aBool! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 12:09'!
dropAccept
	"Answer the selector for querying the receiver about accepting drops"
	^dropAccept! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 12:09'!
dropAccept: aSymbol
	"Set the selector for querying the receiver about accepting drops"
	dropAccept := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:35'!
dropItem
	"Answer the selector for invoking the tree's dragDrop handler"
	^dropItem! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:35'!
dropItem: aSymbol
	"Indicate the selector for invoking the tree's dragDrop handler"
	dropItem := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:31'!
getChildren
	"Answer the message to get the children of this tree"
	^getChildren! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:31'!
getChildren: aSymbol
	"Indicate the message to retrieve the children of this tree"
	getChildren := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:28'!
getSelectedPath
	"Answer the message to retrieve the selection of this tree"
	^getSelectedPath! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:28'!
getSelectedPath: aSymbol
	"Indicate the message to retrieve the selection of this tree"
	getSelectedPath := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:31'!
hasChildren
	"Answer the message to get the existence of children in this tree"
	^hasChildren! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:31'!
hasChildren: aSymbol
	"Indicate the message to retrieve the existence children in this tree"
	hasChildren := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:33'!
help
	"Answer the message to get the help texts of this tree"
	^help! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:33'!
help: aSymbol
	"Indicate the message to retrieve the help texts of this tree"
	help := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:32'!
icon
	"Answer the message to get the icons of this tree"
	^icon! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:32'!
icon: aSymbol
	"Indicate the message to retrieve the icon of this tree"
	icon := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:34'!
keyPress
	"Answer the selector for invoking the tree's keyPress handler"
	^keyPress! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:34'!
keyPress: aSymbol
	"Indicate the selector for invoking the tree's keyPress handler"
	keyPress := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:32'!
label
	"Answer the message to get the labels of this tree"
	^label! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:32'!
label: aSymbol
	"Indicate the message to retrieve the labels of this tree"
	label := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:33'!
menu
	"Answer the message to get the menus of this tree"
	^menu! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:33'!
menu: aSymbol
	"Indicate the message to retrieve the menus of this tree"
	menu := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:29'!
roots
	"Answer the message to retrieve the roots of this tree"
	^roots! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:30'!
roots: aSymbol
	"Indicate the message to retrieve the roots of this tree"
	roots := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:30'!
setSelected
	"Answer the message to set the selection of this tree"
	^setSelected! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:30'!
setSelected: aSymbol
	"Indicate the message to set the selection of this tree"
	setSelected := aSymbol! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:35'!
wantsDrop
	"Answer the selector for invoking the tree's wantsDrop handler"
	^wantsDrop! !

!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:35'!
wantsDrop: aSymbol
	"Indicate the selector for invoking the tree's wantsDrop handler"
	wantsDrop := aSymbol! !


!PluggableTreeSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableTree: self! !
ToolBuilderSpec subclass: #PluggableWidgetSpec
	instanceVariableNames: 'model frame'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableWidgetSpec commentStamp: 'ar 2/9/2005 18:40' prior: 0!
The abstract superclass for all widgets.

Instance variables:
	model	<Object>	The object the various requests should be directed to.
	frame	<Rectangle> The associated layout frame for this object (if any).
!


!PluggableWidgetSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:26'!
frame
	"Answer the receiver's layout frame"
	^frame! !

!PluggableWidgetSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:27'!
frame: aRectangle
	"Indicate the receiver's layout frame"
	frame := aRectangle! !

!PluggableWidgetSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:28'!
model
	"Answer the model for which this widget should be built"
	^model! !

!PluggableWidgetSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:28'!
model: aModel
	"Indicate the model for which this widget should be built"
	model := aModel.! !
PluggableCompositeSpec subclass: #PluggableWindowSpec
	instanceVariableNames: 'label extent closeAction'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!PluggableWindowSpec commentStamp: '<historical>' prior: 0!
A common window. Expects to see change/update notifications when the label should change.

Instance variables:
	label	<String|Symbol> The selector under which to retrieve the label or the label directly
	extent	<Point>	The (initial) extent of the window.
	closeAction		<Symbol>	The action to perform when the window is closed.!


!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:00'!
closeAction
	"Answer the receiver's closeAction"
	^closeAction! !

!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:00'!
closeAction: aSymbol
	"Answer the receiver's closeAction"
	closeAction := aSymbol.! !

!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:30'!
extent
	"Answer the window's (initial) extent"
	^extent! !

!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:30'!
extent: aPoint
	"Indicate the window's (initial) extent"
	extent := aPoint! !

!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:29'!
label
	"Answer the selector for retrieving the window's label"
	^label! !

!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:30'!
label: aString
	"Indicate the selector for retrieving the window's label"
	label := aString! !


!PluggableWindowSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'!
buildWith: builder
	^builder buildPluggableWindow: self.! !
HTTPDownloadRequest subclass: #PluginHTTPDownloadRequest
	instanceVariableNames: 'fileStream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Download'!
!PluginHTTPDownloadRequest commentStamp: '<historical>' prior: 0!
HTTPBrowserRequest attempts to fetch the contents through a Webbrowser. This works transparently if Squeak is not running in the browser.!


!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'nk 8/30/2004 07:58'!
contentStream
	semaphore wait.
	fileStream
		ifNotNil: [^ fileStream].
	^ content
		ifNotNil: [content isString
				ifTrue: [self error: 'Error loading ' , self url printString]
				ifFalse: [content contentStream]]! !

!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:21'!
contents
	| |
	semaphore wait.
	(content isNil and:[fileStream notNil]) ifTrue:[
"		pos _ fileStream position."
		fileStream position: 0.
		content _ MIMEDocument content: fileStream upToEnd.
		fileStream close.
	].
	^content! !

!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 12/21/1999 16:36'!
maxAttempts
	"Return the number of attempts to retry before giving up"
	^3! !

!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:21'!
signalAbort
	fileStream ifNotNil: [
		fileStream close].
	fileStream _ nil.
	super signalAbort.! !

!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 1/11/2000 11:36'!
startRetrieval
	| attempts |
	attempts _ self maxAttempts.
	"Note: Only the first request may fail due to not running in a browser"
	url first = $/
		ifTrue: [url _ url copyFrom: 2 to: url size].
	fileStream _ FileStream requestURLStream: url ifError:[^super startRetrieval].
	[fileStream == nil] whileTrue:[
		attempts _ attempts - 1.
		attempts = 0 ifTrue:[^self content:'Error downloading file'].
		fileStream _ FileStream requestURLStream: url].
	semaphore signal.! !
Object subclass: #Point
	instanceVariableNames: 'x y'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Point commentStamp: '<historical>' prior: 0!
I represent an x-y pair of numbers usually designating a location on the screen.!


!Point methodsFor: 'accessing'!
x
	"Answer the x coordinate."

	^x! !

!Point methodsFor: 'accessing'!
y
	"Answer the y coordinate."

	^y! !


!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'!
* arg 
	"Answer a Point that is the product of the receiver and arg."

	arg isPoint ifTrue: [^ (x * arg x) @ (y * arg y)].
	^ arg adaptToPoint: self andSend: #*! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'!
+ arg 
	"Answer a Point that is the sum of the receiver and arg."

	arg isPoint ifTrue: [^ (x + arg x) @ (y + arg y)].
	^ arg adaptToPoint: self andSend: #+! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'!
- arg 
	"Answer a Point that is the difference of the receiver and arg."

	arg isPoint ifTrue: [^ (x - arg x) @ (y - arg y)].
	^ arg adaptToPoint: self andSend: #-! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'!
/ arg 
	"Answer a Point that is the quotient of the receiver and arg."

	arg isPoint ifTrue: [^ (x / arg x) @ (y / arg y)].
	^ arg adaptToPoint: self andSend: #/! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'!
// arg 
	"Answer a Point that is the quotient of the receiver and arg."

	arg isPoint ifTrue: [^ (x // arg x) @ (y // arg y)].
	^ arg adaptToPoint: self andSend: #//! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'!
\\ arg 
	"Answer a Point that is the mod of the receiver and arg."

	arg isPoint ifTrue: [^ (x \\ arg x) @ (y \\ arg y)].
	^ arg adaptToPoint: self andSend: #\\! !

!Point methodsFor: 'arithmetic'!
abs
	"Answer a Point whose x and y are the absolute values of the receiver's x 
	and y."

	^ x abs @ y abs! !

!Point methodsFor: 'arithmetic' stamp: 'TRee 6/3/2004 11:09'!
reciprocal
    " Answer a Point with coordinates that are the reciprocals of mine. "
    " Method was missing from release. "
    " 20040301 20:50:35 TRee(Squeak3.6-5429-tree07.38) "

    ^ x reciprocal @ y reciprocal.
! !


!Point methodsFor: 'comparing'!
< aPoint 
	"Answer whether the receiver is above and to the left of aPoint."

	^x < aPoint x and: [y < aPoint y]! !

!Point methodsFor: 'comparing'!
<= aPoint 
	"Answer whether the receiver is neither below nor to the right of aPoint."

	^x <= aPoint x and: [y <= aPoint y]! !

!Point methodsFor: 'comparing'!
= aPoint

	self species = aPoint species
		ifTrue: [^x = aPoint 
	"Refer to the comment in Object|=." x and: [y = aPoint y]]
		ifFalse: [^false]! !

!Point methodsFor: 'comparing'!
> aPoint 
	"Answer whether the receiver is below and to the right of aPoint."

	^x > aPoint x and: [y > aPoint y]! !

!Point methodsFor: 'comparing'!
>= aPoint 
	"Answer whether the receiver is neither above nor to the left of aPoint."

	^x >= aPoint x and: [y >= aPoint y]! !

!Point methodsFor: 'comparing' stamp: 'SqR 11/3/2000 17:08'!
hash
	"Hash is reimplemented because = is implemented."

	^(x hash hashMultiply + y hash) hashMultiply! !

!Point methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !

!Point methodsFor: 'comparing'!
max: aPoint 
	"Answer the lower right corner of the rectangle uniquely defined by the 
	receiver and the argument, aPoint."

	^ (x max: aPoint x) @ (y max: aPoint y)! !

!Point methodsFor: 'comparing'!
min: aPoint 
	"Answer the upper left corner of the rectangle uniquely defined by the 
	receiver and the argument, aPoint."

	^ (x min: aPoint x) @ (y min: aPoint y)! !

!Point methodsFor: 'comparing'!
min: aMin max: aMax 

	^ (self min: aMin) max: aMax! !


!Point methodsFor: 'converting' stamp: 'di 11/6/1998 13:45'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with a Collection, return a Collection of
	the results of each element combined with me in that expression."

	^ rcvr collect: [:element | element perform: selector with: self]! !

!Point methodsFor: 'converting' stamp: 'di 11/9/1998 12:44'!
adaptToNumber: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a Point."
	^ rcvr@rcvr perform: selector with: self! !

!Point methodsFor: 'converting' stamp: 'di 11/6/1998 13:47'!
adaptToString: rcvr andSend: selector
	"If I am involved in arithmetic with a String, convert it to a Number."
	^ rcvr asNumber perform: selector with: self! !

!Point methodsFor: 'converting'!
asFloatPoint
	^ x asFloat @ y asFloat! !

!Point methodsFor: 'converting'!
asIntegerPoint
	^ x asInteger @ y asInteger! !

!Point methodsFor: 'converting' stamp: 'wiz 11/25/2004 12:48'!
asNonFractionalPoint
(x isFraction or: [y isFraction])
	ifTrue:[^ x asFloat @ y asFloat]! !

!Point methodsFor: 'converting'!
asPoint
	"Answer the receiver itself."

	^self! !

!Point methodsFor: 'converting'!
corner: aPoint 
	"Answer a Rectangle whose origin is the receiver and whose corner is 
	aPoint. This is one of the infix ways of expressing the creation of a 
	rectangle."

	^Rectangle origin: self corner: aPoint! !

!Point methodsFor: 'converting'!
extent: aPoint 
	"Answer a Rectangle whose origin is the receiver and whose extent is 
	aPoint. This is one of the infix ways of expressing the creation of a 
	rectangle."

	^Rectangle origin: self extent: aPoint! !

!Point methodsFor: 'converting' stamp: 'di 11/6/1998 07:45'!
isPoint
	^ true! !

!Point methodsFor: 'converting' stamp: 'di 12/3/97 19:00'!
rect: aPoint 
	"Answer a Rectangle that encompasses the receiver and aPoint.
	This is the most general infix way to create a rectangle."

	^ Rectangle 
		origin: (self min: aPoint)
		corner: (self max: aPoint)! !


!Point methodsFor: 'copying'!
deepCopy
	"Implemented here for better performance."

	^x deepCopy @ y deepCopy! !

!Point methodsFor: 'copying' stamp: 'tk 8/19/1998 16:05'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."! !


!Point methodsFor: 'geometry' stamp: 'laza 1/24/2000 03:44'!
isInsideCircle: a with: b with: c 
	"Returns TRUE if self is inside the circle defined by the     
	points a, b, c. See Guibas and Stolfi (1985) p.107"
	^ (a dotProduct: a)
		* (b triangleArea: c with: self) - ((b dotProduct: b)
			* (a triangleArea: c with: self)) + ((c dotProduct: c)
			* (a triangleArea: b with: self)) - ((self dotProduct: self)
			* (a triangleArea: b with: c)) > 0.0! !

!Point methodsFor: 'geometry' stamp: 'laza 1/6/2000 10:30'!
sideOf: otherPoint 
	"Returns #left, #right or #center if the otherPoint lies to the left, right 
	or on the line given by the vector from 0@0 to self"
	| side |
	side _ (self crossProduct: otherPoint) sign.
	^ {#right. #center. #left} at: side + 2
! !

!Point methodsFor: 'geometry' stamp: 'ar 4/6/2000 18:37'!
to: end1 intersects: start2 to: end2 
	"Returns true if the linesegment from start1 (=self) to end1 intersects      
	    with the segment from start2 to end2, otherwise false."
	| start1 sideStart sideEnd |
	start1 _ self.
	(((start1 = start2 or: [end1 = end2])
		or: [start1 = end2])
		or: [start2 = end1])
		ifTrue: [^ true].
	sideStart _ start1 to: end1 sideOf: start2.
	sideEnd _ start1 to: end1 sideOf: end2.
	sideStart = sideEnd ifTrue: [^ false].
	sideStart _ start2 to: end2 sideOf: start1.
	sideEnd _ start2 to: end2 sideOf: end1.
	sideStart = sideEnd ifTrue: [^ false].
	^ true! !

!Point methodsFor: 'geometry' stamp: 'laza 1/5/2000 11:50'!
to: end sideOf: otherPoint 
	"Returns #left, #right, #center if the otherPoint lies to the left, right or on the line given by the vector from self to end"
	^ end - self sideOf: otherPoint - self! !

!Point methodsFor: 'geometry' stamp: 'laza 1/17/2000 15:47'!
triangleArea: b with: c
	"Returns twice the area of the oriented triangle (a, b, c), i.e., the   
	area is positive if the triangle is oriented counterclockwise"
	^ b x - self x * (c y - self y) - (b y - self y * (c x - self x))! !


!Point methodsFor: 'interpolating' stamp: 'jsp 3/22/1999 16:31'!
interpolateTo: end at: amountDone
	"Interpolate between the instance and end after the specified amount has been done (0 - 1)."

	^ self + ((end - self) * amountDone).! !


!Point methodsFor: 'point functions' stamp: 'FBS 1/5/2004 13:08'!
bearingToPoint: anotherPoint
    "Return the bearing, in degrees, from the receiver to anotherPoint.
     Adapted from Playground, where the ultimate provenance of the algorithm was a wild earlier method of Jay Fenton's which I never checked carefully, but the thing has always seemed to work"

    | deltaX deltaY  |
    deltaX := anotherPoint x -  x.
    deltaY := anotherPoint y - y.

    deltaX abs < 0.001
        ifTrue:
            [^ deltaY > 0 ifTrue: [180] ifFalse: [0]].

    ^ ((deltaX >= 0 ifTrue: [90] ifFalse: [270])
            - ((deltaY / deltaX) arcTan negated radiansToDegrees)) rounded
! !

!Point methodsFor: 'point functions' stamp: 'ar 10/30/1998 03:05'!
crossProduct: aPoint 
	"Answer a number that is the cross product of the receiver and the 
	argument, aPoint."

	^ (x * aPoint y) - (y * aPoint x)! !

!Point methodsFor: 'point functions' stamp: 'spfa 11/6/2004 16:01'!
dist: aPoint 
	"Answer the distance between aPoint and the receiver."

	| dx dy |

	dx _ aPoint x - x.
	dy _ aPoint y - y.

	^ ((dx * dx) + (dy * dy)) sqrt! !

!Point methodsFor: 'point functions' stamp: 'di 9/11/1998 16:22'!
dotProduct: aPoint 
	"Answer a number that is the dot product of the receiver and the 
	argument, aPoint. That is, the two points are multipled and the 
	coordinates of the result summed."

	^ (x * aPoint x) + (y * aPoint y)! !

!Point methodsFor: 'point functions'!
eightNeighbors
	^ (Array with: self + (1@0)
		with: self + (1@1)
		with: self + (0@1)
		with: self + (-1@1)) ,
	(Array with: self + (-1@0)
		with: self + (-1@-1)
		with: self + (0@-1)
		with: self + (1@-1))
! !

!Point methodsFor: 'point functions' stamp: 'di 6/11/97 16:08'!
flipBy: direction centerAt: c
	"Answer a Point which is flipped according to the direction about the point c.
	Direction must be #vertical or #horizontal."
	direction == #vertical ifTrue: [^ x @ (c y * 2 - y)].
	direction == #horizontal ifTrue: [^ (c x * 2 - x) @ y].
	self error: 'unrecognizable direction'! !

!Point methodsFor: 'point functions'!
fourNeighbors
	^ Array with: self + (1@0)
		with: self + (0@1)
		with: self + (-1@0)
		with: self + (0@-1)
! !

!Point methodsFor: 'point functions'!
grid: aPoint 
	"Answer a Point to the nearest rounded grid modules specified by aPoint."

	| newX newY |
	newX _ x + (aPoint x // 2) truncateTo: aPoint x.
	newY _ y + (aPoint y // 2) truncateTo: aPoint y.
	^newX @ newY! !

!Point methodsFor: 'point functions' stamp: 'ar 5/22/2001 23:46'!
insideTriangle: p1 with: p2 with: p3
	"Return true if the receiver is within the triangle defined by the three coordinates.
	Note: This method computes the barycentric coordinates for the receiver and tests those coordinates."
	| p0 b0 b1 b2 b3 |
	p0 _ self.
	b0 _ ((p2 x - p1 x) * (p3 y - p1 y)) - ((p3 x - p1 x) * (p2 y - p1 y)).
	b0 isZero ifTrue:[^false]. "degenerate"
	b0 _ 1.0 / b0.
	b1 _ (((p2 x - p0 x) * (p3 y - p0 y)) - ((p3 x - p0 x) * (p2 y - p0 y))) * b0.
	b2 _ (((p3 x - p0 x) * (p1 y - p0 y)) - ((p1 x - p0 x) * (p3 y - p0 y))) * b0.
	b3 _ (((p1 x - p0 x) * (p2 y - p0 y)) - ((p2 x - p0 x) * (p1 y - p0 y))) * b0.
	b1 < 0.0 ifTrue:[^false].
	b2 < 0.0 ifTrue:[^false].
	b3 < 0.0 ifTrue:[^false].
	^true

! !

!Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:37'!
nearestPointAlongLineFrom: p1 to: p2
	"Note this will give points beyond the endpoints.
	Streamlined by Gerardo Richarte 11/3/97"
	| x21 y21 t x1 y1 |
	p1 x = p2 x ifTrue: [^ p1 x @ y].
	p1 y = p2 y ifTrue: [^ x @ p1 y].
	x1 _ p1 x asFloat.
	y1 _ p1 y asFloat.
	x21 _ p2 x asFloat - x1.
	y21 _ p2 y asFloat - y1.
	t _ ((y asFloat - y1 / x21) + (x asFloat - x1 / y21))
			/ ((x21 / y21) + (y21 / x21)).
	^ (x1 + (t * x21)) @ (y1 + (t * y21))
"
	| old new |
	Pen new place: 200@100; goto: (old _ 500@300).
	Display reverse: (old extent: 10@10).
	[Sensor anyButtonPressed] whileFalse:
		[(new _ (Sensor cursorPoint nearestPointAlongLineFrom: 200@100 to: 500@300) )
			= old ifFalse:
				[Display reverse: (old extent: 10@10).
				Display reverse: ((old _ new) extent: 10@10)]]
"
! !

!Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:40'!
nearestPointOnLineFrom: p1 to: p2
	"This will not give points beyond the endpoints"
	^ (self nearestPointAlongLineFrom: p1 to: p2)
		adhereTo: (p1 rect: p2)! !

!Point methodsFor: 'point functions'!
normal
	"Answer a Point representing the unit vector rotated 90 deg clockwise."

	| n |
	n _ y negated @ x.
	^n / (n x * n x + (n y * n y)) sqrt! !

!Point methodsFor: 'point functions' stamp: 'ar 8/26/2001 22:15'!
normalized
	"Optimized for speed -- ar 8/26/2001"
	| r |
	r _ ((x*x) + (y * y)) sqrt.
	^(x / r) @ (y / r)! !

!Point methodsFor: 'point functions' stamp: 'laza 12/13/1999 11:43'!
octantOf: otherPoint 
	"Return 1..8 indicating relative direction to otherPoint.  
	1=ESE, 2=SSE, ... etc. clockwise to 8=ENE"
	"[Sensor anyButtonPressed] whileFalse: [(Display boundingBox center 
	octantOf: Sensor cursorPoint) printString displayAt: 0@0]"
	| quad moreHoriz |
	(x = otherPoint x and: [y > otherPoint y])
		ifTrue: [^ 6].
	"special case"
	(y = otherPoint y and: [x < otherPoint x])
		ifTrue: [^ 8].
	quad _ self quadrantOf: otherPoint.
	moreHoriz _ (x - otherPoint x) abs >= (y - otherPoint y) abs.
	(quad even eqv: moreHoriz)
		ifTrue: [^ quad * 2]
		ifFalse: [^ quad * 2 - 1]! !

!Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:12'!
onLineFrom: p1 to: p2
	^ self onLineFrom: p1 to: p2 within: 2! !

!Point methodsFor: 'point functions' stamp: 'jm 2/24/98 08:34'!
onLineFrom: p1 to: p2 within: epsilon
	"Answer true if the receiver lies on the given line segment between p1 and p2 within a small epsilon."

	"is this point within the box spanning p1 and p2 expanded by epsilon? (optimized)"
	p1 x < p2 x
		ifTrue: [
			((x < (p1 x - epsilon)) or: [x > (p2 x + epsilon)]) ifTrue: [^ false]]
		ifFalse: [
			((x < (p2 x - epsilon)) or: [x > (p1 x + epsilon)]) ifTrue: [^ false]].
	p1 y < p2 y
		ifTrue: [
			((y < (p1 y - epsilon)) or: [y > (p2 y + epsilon)]) ifTrue: [^ false]]
		ifFalse: [
			((y < (p2 y - epsilon)) or: [y > (p1 y + epsilon)]) ifTrue: [^ false]].

	"it's in the box; is it on the line?"
	^ (self dist: (self nearestPointAlongLineFrom: p1 to: p2)) <= epsilon! !

!Point methodsFor: 'point functions' stamp: '6/9/97 14:51 di'!
quadrantOf: otherPoint
	"Return 1..4 indicating relative direction to otherPoint.
	1 is downRight, 2=downLeft, 3=upLeft, 4=upRight"
	^ x <= otherPoint x
		ifTrue: [y < otherPoint y ifTrue: [1] ifFalse: [4]]
		ifFalse: [y <= otherPoint y ifTrue: [2] ifFalse: [3]]
"
[Sensor anyButtonPressed] whileFalse:
	[(Display boundingBox center quadrantOf: Sensor cursorPoint) printString displayAt: 0@0]
"! !

!Point methodsFor: 'point functions' stamp: 'di 6/11/97 15:12'!
rotateBy: direction centerAt: c
	"Answer a Point which is rotated according to direction, about the point c.
	Direction must be one of #right (CW), #left (CCW) or #pi (180 degrees)."
	| offset |
	offset _ self - c.
	direction == #right ifTrue: [^ (offset y negated @ offset x) + c].
	direction == #left ifTrue: [^ (offset y @ offset x negated) + c].
	direction == #pi ifTrue: [^ c - offset].
	self error: 'unrecognizable direction'! !

!Point methodsFor: 'point functions' stamp: 'ar 4/18/1999 05:17'!
sortsBefore: otherPoint
	"Return true if the receiver sorts before the other point"
	^y = otherPoint y
		ifTrue:[x <= otherPoint x]
		ifFalse:[y <= otherPoint y]! !

!Point methodsFor: 'point functions' stamp: 'ar 5/23/2001 21:29'!
squaredDistanceTo: aPoint
	"Answer the distance between aPoint and the receiver."
	| delta |
	delta _ aPoint - self.
	^delta dotProduct: delta! !

!Point methodsFor: 'point functions' stamp: 'ar 11/12/1998 01:44'!
transposed
	^y@x! !


!Point methodsFor: 'polar coordinates' stamp: 'di 6/12/97 12:18'!
degrees
	"Answer the angle the receiver makes with origin in degrees. right is 0; down is 90."
	| tan theta |
	x = 0
		ifTrue: [y >= 0
				ifTrue: [^ 90.0]
				ifFalse: [^ 270.0]]
		ifFalse: 
			[tan _ y asFloat / x asFloat.
			theta _ tan arcTan.
			x >= 0
				ifTrue: [y >= 0
						ifTrue: [^ theta radiansToDegrees]
						ifFalse: [^ 360.0 + theta radiansToDegrees]]
				ifFalse: [^ 180.0 + theta radiansToDegrees]]! !

!Point methodsFor: 'polar coordinates'!
r
	"Answer the receiver's radius in polar coordinate system."

	^(self dotProduct: self) sqrt! !

!Point methodsFor: 'polar coordinates' stamp: 'hk 11/10/2005 10:07'!
theta
	"Answer the angle the receiver makes with origin in radians. right is 0; 
	down is 90. 
	Corrected the constants from single precision to 64 Bit precision 
	and changed the sends in case of overflow to constants HK 2005-07-23"

	| tan theta |
	x = 0
		ifTrue: [y >= 0
				ifTrue: [^ 1.570796326794897 "90.0 degreesToRadians"]
				ifFalse: [^ 4.71238898038469 "270.0 degreesToRadians"]]
		ifFalse: 
			[tan := y asFloat / x asFloat.
			theta := tan arcTan.
			x >= 0
				ifTrue: [y >= 0
						ifTrue: [^theta]
						ifFalse: [^"360.0 degreesToRadians" 6.283185307179586 + theta]]
				ifFalse: [^"180.0 degreesToRadians" 3.141592653589793 + theta]]! !


!Point methodsFor: 'printing' stamp: 'sw 9/27/2001 17:26'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	^ #Point! !

!Point methodsFor: 'printing'!
printOn: aStream 
	"The receiver prints on aStream in terms of infix notation."

	x printOn: aStream.
	aStream nextPut: $@.
	y printOn: aStream! !

!Point methodsFor: 'printing' stamp: 'ar 7/8/2006 19:15'!
storeOn: aStream 
	"x@y printed form is good for storing too"
	aStream nextPut: $(.
	self printOn: aStream.
	aStream nextPut: $).
! !


!Point methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:48'!
isSelfEvaluating
	^ self class == Point! !


!Point methodsFor: 'testing' stamp: 'ar 10/29/2000 19:02'!
isZero
	^x isZero and:[y isZero]! !


!Point methodsFor: 'transforming' stamp: 'di 4/30/1998 11:16'!
adhereTo: aRectangle
	"If the receiver lies outside aRectangle, return the nearest point on the boundary of the rectangle, otherwise return self."

	(aRectangle containsPoint: self) ifTrue: [^ self].
	^ ((x max: aRectangle left) min: aRectangle right)
		@ ((y max: aRectangle top) min: aRectangle bottom)! !

!Point methodsFor: 'transforming' stamp: 'ar 8/26/2001 22:14'!
negated
	"Answer a point whose x and y coordinates are the negatives of those of the receiver.  6/6/96 sw"
	"Optimized for speed -- ar 8/26/2001"
	^ (0 - x) @ (0 - y)! !

!Point methodsFor: 'transforming'!
rotateBy: angle about: center
	"Even though Point.theta is measured CW, this rotates with the more conventional CCW interpretateion of angle."

	| p r theta |
	p _ self - center.
	r _ p r.
	theta _ angle asFloat - p theta.
	^ (center x asFloat + (r * theta cos)) @
	  (center y asFloat - (r * theta sin))! !

!Point methodsFor: 'transforming'!
scaleBy: factor 
	"Answer a Point scaled by factor (an instance of Point)."

	^(factor x * x) @ (factor y * y)! !

!Point methodsFor: 'transforming' stamp: 'di 12/4/97 14:34'!
scaleFrom: rect1 to: rect2
	"Produce a point stretched according to the stretch from rect1 to rect2"
	^ rect2 topLeft + (((x-rect1 left) * rect2 width // rect1 width)
					@ ((y-rect1 top) * rect2 height // rect1 height))! !

!Point methodsFor: 'transforming'!
translateBy: delta 
	"Answer a Point translated by delta (an instance of Point)."

	^(delta x + x) @ (delta y + y)! !


!Point methodsFor: 'truncation and round off' stamp: 'jm 6/3/1998 12:21'!
rounded
	"Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral."

	(x isInteger and: [y isInteger]) ifTrue: [^ self].
	^ x rounded @ y rounded
! !

!Point methodsFor: 'truncation and round off' stamp: 'nice 2/5/2006 16:35'!
roundTo: grid
	"Answer a Point that is the receiver's x and y rounded to grid x and 
	grid y."
	
	| gridPoint |
	gridPoint := grid asPoint.
	^(x roundTo: gridPoint x) @ (y roundTo: gridPoint y)! !

!Point methodsFor: 'truncation and round off'!
truncateTo: grid
	"Answer a Point that is the receiver's x and y truncated to grid x and 
	grid y."
	| gridPoint |
	gridPoint _ grid asPoint.
	^(x truncateTo: gridPoint x) @ (y truncateTo: gridPoint y)! !

!Point methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'!
truncated
	"Answer a Point whose x and y coordinates are integers. Answer the receiver if its coordinates are already integral."

	(x isInteger and: [y isInteger]) ifTrue: [^ self].
	^ x truncated @ y truncated
! !


!Point methodsFor: '*MorphicExtras-*morphic-Postscript Canvases'!
encodePostscriptOn:aStream 
	aStream writePoint:self.! !


!Point methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'RAA 7/31/2000 17:27'!
encodeForRemoteCanvas

	| encoded |

	CanvasEncoder at: 3 count:  1.
	encoded := String new: 8.
	encoded putInteger32: x asInteger at: 1.
	encoded putInteger32: y asInteger at: 5.
	^encoded! !


!Point methodsFor: 'private' stamp: 'ar 4/4/1999 00:40'!
bitShiftPoint: bits
	x _ x bitShift: bits.
	y _ y bitShift: bits.! !

!Point methodsFor: 'private' stamp: 'tk 10/4/2001 16:16'!
setR: rho degrees: degrees 

	| radians |
	radians _ degrees asFloat degreesToRadians.
	x _ rho asFloat * radians cos.
	y _ rho asFloat * radians sin.! !

!Point methodsFor: 'private' stamp: 'sw 3/21/2000 13:24'!
setX: xValue setY: yValue

	x _ xValue.
	y _ yValue! !


!Point methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'nice 2/5/2006 16:43'!
ceiling
	"Answer a Point that is the receiver's x and y ceiling. Answer the receiver if its coordinates are already integral."

	(x isInteger and: [y isInteger]) ifTrue: [^ self].
	^ x ceiling @ y ceiling
! !

!Point methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'nice 2/5/2006 16:43'!
floor
	"Answer a Point that is the receiver's x and y floor. Answer the receiver if its coordinates are already integral."

	(x isInteger and: [y isInteger]) ifTrue: [^ self].
	^ x floor @ y floor
! !

!Point methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'wiz 1/11/2006 18:32'!
isIntegerPoint
^ x isInteger and: [ y isInteger ] ! !

!Point methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'nice 2/5/2006 16:42'!
roundDownTo: grid
	"Answer a Point that is the receiver's x and y rounded to grid x and 
	grid y by lower value (toward negative infinity)."
	
	| gridPoint |
	gridPoint := grid asPoint.
	^(x roundDownTo: gridPoint x) @ (y roundDownTo: gridPoint y)! !

!Point methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'nice 2/5/2006 16:41'!
roundUpTo: grid
	"Answer a Point that is the receiver's x and y rounded to grid x and 
	grid y by upper value (toward infinity)."
	
	| gridPoint |
	gridPoint := grid asPoint.
	^(x roundUpTo: gridPoint x) @ (y roundUpTo: gridPoint y)! !


!Point methodsFor: '*Morphic-extent functions' stamp: 'wiz 8/9/2005 02:44'!
guarded
"Return a positive nonzero extent."
self max: 1@1 .! !

!Point methodsFor: '*Morphic-extent functions' stamp: 'wiz 9/14/2005 22:41'!
scaleTo: anExtent
"Return a Point scalefactor for shrinking a thumbnail of the receiver's extent to fit within anExtent"
" self and anExtent are expected to have positive nonZero x and y. "
|  factor  sX sY | 
factor :=  3.0  reciprocal . "EccentricityThreshhold reciprical"
sX := anExtent x / self  x asFloat  .
sY :=  anExtent y / self  y asFloat  .
sX = sY ifTrue: [ ^ sX @ sY ] . "Same aspect ratio"
^ sX < sY ifTrue: [   sX @ (sX max: sY * factor) ] 
	ifFalse: [  (sY max: sX * factor ) @ sY  ] ! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Point class
	instanceVariableNames: ''!

!Point class methodsFor: 'instance creation' stamp: 'sw 9/20/97 15:34'!
fromUser
	Sensor waitNoButton.
	Cursor crossHair show.
	Sensor waitButton.
	Cursor normal show.
	^ Sensor cursorPoint

"Point fromUser"! !

!Point class methodsFor: 'instance creation' stamp: 'wiz 5/4/2006 00:04'!
fromUserWithCursor: aCursor
	Sensor waitNoButton.
	aCursor showWhile:[Sensor waitButton].
	^ Sensor cursorPoint

"Point fromUserWithCursor: Cursor target"! !

!Point class methodsFor: 'instance creation' stamp: 'md 12/2/2004 23:44'!
r: rho degrees: degrees
	"Answer an instance of me with polar coordinates rho and theta."

	^self basicNew setR: rho degrees: degrees! !

!Point class methodsFor: 'instance creation' stamp: 'md 12/2/2004 23:44'!
x: xInteger y: yInteger 
	"Answer an instance of me with coordinates xInteger and yInteger."

	^self basicNew setX: xInteger setY: yInteger! !
IntegerArray variableWordSubclass: #PointArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Collections'!
!PointArray commentStamp: '<historical>' prior: 0!
This class stores 32bit Integer points in place. It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.!


!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'!
at: index
	"Return the element (e.g., point) at the given index"
	^(super at: index * 2 - 1) @ (super at: index * 2)! !

!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'!
at: index put: aPoint
	"Store the argument aPoint at the given index"
	super at: index * 2 - 1 put: aPoint x asInteger.
	super at: index * 2 put: aPoint y asInteger.
	^aPoint! !

!PointArray methodsFor: 'accessing' stamp: 'ar 11/10/1998 19:41'!
bounds
	| min max |
	min := max := self at: 1.
	self do:[:pt|
		min := min min: pt.
		max := max max: pt].
	^min corner: max
		! !

!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0@0! !

!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'!
size
	"Return the number of elements in the receiver"
	^super size // 2! !


!PointArray methodsFor: 'converting' stamp: 'NS 5/30/2001 20:54'!
asPointArray
	^ self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PointArray class
	instanceVariableNames: ''!

!PointArray class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 00:04'!
new: n
	^super new: n*2! !
ClassTestCase subclass: #PointTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'GraphicsTests-Primitives'!
!PointTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Point. 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!


!PointTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 10:16'!
testBearingToPoint

	self assert: (0@0 bearingToPoint: 0@0) = 0.
	self assert: (0@0 bearingToPoint: 0@-1) = 0.
	self assert: (0@0 bearingToPoint: 1@0) = 90.
	self assert: (0@0 bearingToPoint: 0@1) = 180.
	self assert: (0@0 bearingToPoint: -1@0) = 270.
	self assert: (0@0 bearingToPoint: 1@1) = 135.
	self assert: (0@0 bearingToPoint: 0.01@0) = 90.
	self assert: (0@0 bearingToPoint: -2@-3) = 326.
	self assert: (0@0 bearingToPoint: -0@0) = 0.
	
	self assert: (-2@-3 bearingToPoint: 0@0) = 146.! !

!PointTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 10:16'!
testIsZero

	self assert: (0@0) isZero.	
	self deny:  (0@1) isZero.
	self deny:  (1@0) isZero.
	self deny:  (1@1) isZero.! !


!PointTest methodsFor: 'testing - testing' stamp: 'hk 11/10/2005 10:09'!
testTheta
      | result dir tan x y |
	self assert: ((0@1) theta - 90.0 degreesToRadians) abs < 1e-15.
	self assert: ((0@-1) theta - 270.0 degreesToRadians) abs < 1e-15.
	" See code of old and new theta"
	x := 1.0 . y := -1.0.
	tan := y  / x .
	dir := tan arcTan.
      result :=  360.0 degreesToRadians + dir.
      self assert: ((x@y) theta - result) abs < 1e-15.
	x := -1.0. "Don't reuse old results whenyou want numeric precision!!"
	tan := y  / x .
	dir := tan arcTan.
      result :=  180.0 degreesToRadians + dir.
      self assert: ((x@y) theta - result) abs < 1e-15.

	! !
ObjectExplorer subclass: #PointerExplorer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!PointerExplorer commentStamp: 'avi 8/21/2004 20:01' prior: 0!
A variant on the ObjectExlorer that works "backwards": like the ObjectExplorer, it shows a tree of objects, but expanding a node won't show the objects which that node references, but rather the objects that reference that node.  Its main use is to track down memory leaks: if you want to know why a particular object is still alive, open a PointerExplorer on it and drill down until you find the root object that's referencing it.  For example, find all the references to the symbol #zot with:

PointerExplorer new openExplorerFor: #zot

For the "name" of the object, the PointerExplorer shows each object's identityHash, to allow the user to identify when two similar objects are identical and notice cycles.!


!PointerExplorer methodsFor: 'accessing' stamp: 'ab 8/22/2003 18:51'!
getList
	^Array with: (PointerExplorerWrapper with: rootObject name: rootObject identityHash asString model: self)
! !
ObjectExplorerWrapper subclass: #PointerExplorerWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!PointerExplorerWrapper commentStamp: 'avi 8/21/2004 19:58' prior: 0!
A subclass of ObjectExplorerWrapper for use with PointerExplorer.  #contents is overridden to work backwards: it returns wrappers for the objects pointing to item rather than for the objects that item points to.!


!PointerExplorerWrapper methodsFor: 'accessing' stamp: 'ar 9/27/2005 18:03'!
contents
	| objects |
	objects := Utilities pointersTo: item except: (Array with: self with: model).	
	^(objects reject: [:ea | ea class = self class])
		collect: [:ea| self class with: ea name: ea identityHash asString model: item]! !


!PointerExplorerWrapper methodsFor: 'testing' stamp: 'ab 8/22/2003 18:39'!
hasContents
	^true! !
Model subclass: #PointerFinder
	instanceVariableNames: 'goal parents toDo toDoNext hasGemStone pointerList objectList parentsSize todoSize depth pointerListIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!PointerFinder commentStamp: '<historical>' prior: 0!
I can search for reasons why a certain object isn't garbage collected.  I'm a quick port of a VisualWorks program written by Hans-Martin Mosner.  Call me as shown below.  I'll search for a path from a global variable to the given object, presenting it in a small morphic UI.

Examples:
	PointerFinder on: self currentHand
	PointerFinder on: StandardSystemView someInstance

Now, let's see why this image contains more HandMorphs as expected...

HandMorph allInstancesDo: [:e | PointerFinder on: e]!


!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:38'!
buildList
	| list obj parent object key |
	list := OrderedCollection new.
	obj := goal.
	
	[list addFirst: obj.
	obj := parents at: obj ifAbsent: [].
	obj == nil] whileFalse.
	list removeFirst.
	parent := Smalltalk.
	objectList := OrderedCollection new.
	pointerList := OrderedCollection new.
	[list isEmpty]
		whileFalse: 
			[object := list removeFirst.
			key := nil.
			(parent isKindOf: Dictionary)
				ifTrue: [list size >= 2
						ifTrue: 
							[key := parent keyAtValue: list second ifAbsent: [].
							key == nil
								ifFalse: 
									[object := list removeFirst; removeFirst.
									pointerList add: key printString , ' -> ' , object class name]]].
			key == nil
				ifTrue: 
					[parent class == object ifTrue: [key := 'CLASS'].
					key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i)
									== object ifTrue: [key := parent class allInstVarNames at: i]]]].
					key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i)
									== object ifTrue: [key := i printString]]]].
					key == nil ifTrue: [(parent isMorph and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']].
					key == nil ifTrue: [(parent isCompiledMethod and: [object isVariableBinding]) ifTrue: [key := 'literals?']].
					key == nil ifTrue: [key := '???'].
					pointerList add: key , ': ' , object class name].
			objectList add: object.
			parent := object]! !

!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:29'!
follow: anObject from: parentObject
	anObject == goal
		ifTrue: 
			[parents at: anObject put: parentObject.
			^ true].
	anObject isLiteral ifTrue: [^ false].
	"Remove this after switching to new CompiledMethod format --bf 2/12/2006"
	(anObject class isPointers or: [anObject isCompiledMethod]) ifFalse: [^ false].
	anObject class isWeak ifTrue: [^ false].
	(parents includesKey: anObject)
		ifTrue: [^ false].
	parents at: anObject put: parentObject.
	toDoNext add: anObject.
	^ false! !

!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:33'!
followObject: anObject
	(self follow: anObject class from: anObject)
		ifTrue: [^ true].
	"Remove this after switching to new CompiledMethod format --bf 2/12/2006"
	anObject isCompiledMethod ifTrue: [
		1 to: anObject numLiterals do:
			[:i |
			(self follow: (anObject literalAt: i) from: anObject)
				ifTrue: [^ true]].
		^false].
	1 to: anObject class instSize do:
		[:i |
		(self follow: (anObject instVarAt: i) from: anObject)
			ifTrue: [^ true]].
	1 to: anObject basicSize do:
		[:i |
		(self follow: (anObject basicAt: i) from: anObject)
			ifTrue: [^ true]].
	^ false! !

!PointerFinder methodsFor: 'application' stamp: 'sd 11/20/2005 21:27'!
goal: anObject
	goal := anObject! !

!PointerFinder methodsFor: 'application' stamp: 'sd 11/20/2005 21:27'!
initialize
	parents := IdentityDictionary new: 20000.
	parents at: Smalltalk put: nil.
	parents at: Processor put: nil.
	parents at: self put: nil.

	toDo := OrderedCollection new: 5000.
	toDo add: Smalltalk.
	toDoNext := OrderedCollection new: 5000! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/7/2000 00:19'!
isLiteral
	"Horrible hack to omit other Pointer Finders from scanning."

	^ true! !

!PointerFinder methodsFor: 'application' stamp: 'sd 11/20/2005 21:27'!
search
	Smalltalk garbageCollect.

	self initialize.
	
	Cursor wait showWhile: [
		[[toDo isEmpty or: [self followObject: toDo removeFirst]] whileFalse.
		toDo isEmpty and: [toDoNext isEmpty not]]
			whileTrue: 
				[toDo := toDoNext.
				toDoNext := OrderedCollection new: 5000]].

	self buildList! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 19:10'!
update
	('done: ' , parents size asString , ' todo: ' , toDo size asString , '   ') displayAt: 0@0! !


!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:23'!
arrowKey: key from: aController
	key = $i ifTrue: [^ self inspectObject].
	^ super arrowKey: key from: aController! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:48'!
initialExtent
	^ 300 @ 300! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'nb 6/17/2003 12:25'!
inspectObject
	pointerListIndex = 0 ifTrue: [^ Beeper beep].
	(objectList at: pointerListIndex) inspect! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:09'!
menu: aMenu shifted: shifted
	^ MenuMorph new
		defaultTarget: self;
		add: 'Inspect (i)' action: #inspectObject;
		balloonTextForLastItem: 'Live long and prosper!!';
		addLine;
		add: 'Search again' action: #searchAgain;
		balloonTextForLastItem: 'Search again\for the same object' withCRs;
		yourself! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'wiz 2/25/2006 20:18'!
open
	| window list |
	window := (SystemWindow labelled: 'Pointer Finder')
		model: self.
	list := PluggableListMorph new
		doubleClickSelector: #inspectObject;

		on: self
		list: #pointerList
		selected: #pointerListIndex
		changeSelected: #pointerListIndex:
		menu: #menu:shifted:
		keystroke: #arrowKey:from:.
		"For doubleClick to work best disable autoDeselect"
		list autoDeselect: false.
	window addMorph: list frame: (0@0 extent: 1@1).
	list color: Color lightMagenta.
	window openInWorld! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:15'!
perform: selector orSendTo: otherTarget
	selector == #inspectObject ifTrue: [^ self inspectObject].
	selector == #searchAgain ifTrue: [^ self searchAgain].
	^ super perform: selector orSendTo: otherTarget! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:49'!
pointerList
	^ pointerList asArray! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:27'!
pointerListIndex
	^ pointerListIndex ifNil: [0]! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sd 11/20/2005 21:27'!
pointerListIndex: anInteger
	pointerListIndex := anInteger.
	self changed: #pointerListIndex! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:16'!
searchAgain
	self pointerListIndex: 0.
	self search.
	self changed: #pointerList! !


!PointerFinder methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:48'!
isSelfEvaluating
	^ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PointerFinder class
	instanceVariableNames: ''!

!PointerFinder class methodsFor: 'instance creation' stamp: 'sma 6/6/2000 23:52'!
on: anObject
	^ self new goal: anObject; search; open! !


!PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:49'!
pointersTo: anObject
	"Find all occurrences in the system of pointers to the argument anObject."
	"(PointerFinder pointersTo: Browser) inspect."

	^ self pointersTo: anObject except: #()
! !

!PointerFinder class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'!
pointersTo: anObject except: objectsToExclude
	"Find all occurrences in the system of pointers to the argument anObject. 
	Remove objects in the exclusion list from the results."
	
	| results anObj |
	Smalltalk garbageCollect.
	"big collection shouldn't grow, so it's contents array is always the same"
	results := OrderedCollection new: 1000.

	"allObjectsDo: is expanded inline to keep spurious
	 method and block contexts out of the results"
	anObj := self someObject.
	[0 == anObj] whileFalse: [
		anObj isInMemory ifTrue: [
			(anObj pointsTo: anObject) ifTrue: [
				"exclude the results collector and contexts in call chain"
				((anObj ~~ results collector) and:
				 [(anObj ~~ objectsToExclude) and:
				 [(anObj ~~ thisContext) and:
				 [(anObj ~~ thisContext sender) and:
				 [anObj ~~ thisContext sender sender]]]])
					 ifTrue: [ results add: anObj ].
			]].
		anObj := anObj nextObject.
	].
	objectsToExclude do: [ :obj | results removeAllSuchThat: [ :el | el == obj]].

	^ results asArray
! !

!PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:48'!
pointersToItem: index of: anArray
	"Find all occurrences in the system of pointers to the given element of the given array. 
	This is useful for tracing up a pointer chain from an inspector on the results of a previous 	call of pointersTo:. To find out who points to the second element of the results, one would 	evaluate:

		PointerFinder pointersToItem: 2 of: self

	in the inspector."

	^ self pointersTo: (anArray at: index) except: (Array with: anArray)! !
BorderedMorph subclass: #PolygonMorph
	instanceVariableNames: 'vertices closed filledForm arrows arrowForms smoothCurve curveState borderDashSpec handles borderForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!PolygonMorph commentStamp: 'md 2/24/2006 20:34' prior: 0!
This class implements a morph which can behave as four different objects depending on the the following two facts:
- is it OPEN or CLOSED?
- is it SEGMENTED or SMOOTHED.

1. The OPEN and SEGMENTED variant looks like polyline.

2. The OPEN and SMOOTHED variant looks like spline (kind of curve)

3. The CLOSED and SEGMENTED variant looks like polygon. This is actually what you get when you do
	PolygonMorph new openInWorld
You get a triangle. See below how to manipulate these objects...

4. The CLOSED and SMOOTHED variant looks like blob (???)

Prototypes of this morph can also be found in "Object Catalog". Several (different variants) of this object are among "Basic" morphs.

Explore the assiciated morph-menu. It enables you
- to toggle showing of "handles". They make it possible to
	- reposition already existing vertices (by moving yellow handles)
	- create new vertices (by moving green handles)
	- delete already existing vertices (by dragging and dropping one yellow handle closely
	  nearby the adjacent yellow handle
  Handles can be made visible/hidden by shift+leftclicking the morph. This way it is possible
  to quickly show handles, adjust vertices and then again hide handles.
- making closed polygon open, i.e. converting it to a curve (and vice versa)
- toggle smoothed/segmented line/outline
- set up custom dashing (for line, curves or borders of closed polygons
- set up custom arrow-heads (for lines resp. curves)

------------------------------------------------------------------------------------------
Implementation notes:

This class combines the old Polygon and Curve classes.

The 1-bit fillForm to make display and containment tests reasonably fast.  However, this functionality is in the process of being supplanted by balloon capabilities, which should eventually provide anti-aliasing as well.

wiz 7/18/2004 21:26
s have made some changes to this class to

1) correct some bugs associated with one vertex polygons.

2) prepare for some enhancements with new curves.

3) add shaping items to menu.!


!PolygonMorph methodsFor: 'access' stamp: 'aoy 2/15/2003 20:51'!
borderColor: aColor 

	super borderColor: aColor.
	(borderColor isColor and: [borderColor isTranslucentColor]) 
		== (aColor isColor and: [aColor isTranslucentColor]) 
			ifFalse: 
				["Need to recompute fillForm and borderForm
					if translucency of border changes."

				self releaseCachedState]! !

!PolygonMorph methodsFor: 'access' stamp: 'sw 8/25/2000 22:37'!
isClosed
	^ closed! !

!PolygonMorph methodsFor: 'access' stamp: 'di 9/7/2000 16:18'!
isCurve
	^ smoothCurve! !

!PolygonMorph methodsFor: 'access' stamp: 'jm 11/19/97 18:55'!
isOpen
	^ closed not! !

!PolygonMorph methodsFor: 'access' stamp: 'sw 8/23/2000 16:16'!
makeOpenOrClosed
	"toggle the open/closed status of the receiver"
	closed ifTrue: [self makeOpen] ifFalse: [self makeClosed]! !

!PolygonMorph methodsFor: 'access' stamp: 'wiz 6/24/2004 22:50'!
midVertices
	"Return and array of midpoints for this line or closed curve"
	| midPts nextVertIx tweens |
	vertices size < 2
		ifTrue: [^ vertices].
	midPts := OrderedCollection new.
	nextVertIx := 2.
	tweens := OrderedCollection new.
	tweens add: vertices first asIntegerPoint.
	"guarantee at least two points."
	self
		lineSegmentsDo: [:p1 :p2 | 
			tweens addLast: p2 asIntegerPoint.
			p2
					= (vertices atWrap: nextVertIx)
				ifTrue: ["Found endPoint."
					midPts addLast: (tweens atWrap: tweens size + 1 // 2)
							+ (tweens at: tweens size // 2 + 1) // 2.
					"wiz 6/19/2004 20:11 adjusted to handle  
					one segment properly"
					tweens := OrderedCollection new.
					tweens add: p2 asIntegerPoint.
					"guarantee at least two points."
					nextVertIx := nextVertIx + 1]].
	^ midPts asArray! !

!PolygonMorph methodsFor: 'access' stamp: 'dgd 12/11/2003 13:14'!
openOrClosePhrase
	| curveName |
	curveName := (self isCurve
				ifTrue: ['curve']
				ifFalse: ['polygon']) translated.
	^ closed
		ifTrue: ['make open {1}' translated format: {curveName}]
		ifFalse: ['make closed {1}' translated format: {curveName}]! !

!PolygonMorph methodsFor: 'access' stamp: 'wiz 6/6/2004 21:56'!
smoothOrSegmentedPhrase
				| lineName |
	lineName := (closed
						ifTrue: ['outline']
						ifFalse: ['line']) translated.

			^ self isCurve
				ifTrue: ['make segmented {1}' translated format: {lineName}]
				ifFalse: ['make smooth {1}' translated format: {lineName}].! !

!PolygonMorph methodsFor: 'access' stamp: 'sw 9/14/97 18:22'!
vertices
	^ vertices! !


!PolygonMorph methodsFor: 'accessing' stamp: 'nk 9/4/2004 17:23'!
borderWidth: anInteger

	borderColor ifNil: [borderColor _ Color black].
	borderWidth _ anInteger max: 0.
	self computeBounds! !

!PolygonMorph methodsFor: 'accessing' stamp: 'sw 11/24/1999 14:57'!
couldHaveRoundedCorners
	^ false! !


!PolygonMorph methodsFor: 'caching' stamp: 'di 11/13/97 15:16'!
loadCachedState
	"Prepare for fast response -- next page of a book?"
	self filledForm.
	self arrowForms! !

!PolygonMorph methodsFor: 'caching' stamp: 'di 9/4/2000 13:36'!
releaseCachedState
	super releaseCachedState.
	filledForm _ nil.
	arrowForms _ nil.
	borderForm _ nil.
	curveState _ nil.
	(self hasProperty: #flex) ifTrue:
		[self removeProperty: #unflexedVertices;
			removeProperty: #flex].
! !


!PolygonMorph methodsFor: 'dashes' stamp: 'dgd 2/22/2003 18:55'!
borderDashOffset
	borderDashSpec size < 4 ifTrue: [^0.0].
	^(borderDashSpec fourth) asFloat! !

!PolygonMorph methodsFor: 'dashes' stamp: 'nk 2/27/2001 12:11'!
dashedBorder
	^borderDashSpec
	"A dash spec is a 3- or 5-element array with
		{ length of normal border color.
		length of alternate border color.
		alternate border color.
		starting offset.
		amount to add to offset at each step }
	Starting offset is usually = 0, but changing it moves the dashes along the curve."
! !

!PolygonMorph methodsFor: 'dashes' stamp: 'di 9/9/2000 09:20'!
dashedBorder: dashSpec
	"A dash spec is a 3- or 5-element array with
		{ length of normal border color.
		length of alternate border color.
		alternate border color.
		starting offset.
		amount to add to offset at each step }
	Starting offset is usually = 0, but changing it moves the dashes along the curve."

	borderDashSpec _ dashSpec.
	self changed! !

!PolygonMorph methodsFor: 'dashes' stamp: 'nk 4/5/2001 16:02'!
removeVertex: aVert
	"Make sure that I am not left with less than two vertices"
	| newVertices |
	vertices size < 2 ifTrue: [ ^self ].
	newVertices _ vertices copyWithout: aVert.
	newVertices size caseOf: {
		[1] -> [ newVertices _ { newVertices first . newVertices first } ].
		[0] -> [ newVertices _ { aVert . aVert } ]
	} otherwise: [].
	self setVertices: newVertices 
! !

!PolygonMorph methodsFor: 'dashes' stamp: 'nk 2/25/2001 17:05'!
vertexAt: n
	^vertices at: (n min: vertices size).! !


!PolygonMorph methodsFor: 'debug and other' stamp: 'di 9/26/97 10:33'!
installModelIn: aWorld
	aWorld isWorldMorph ifTrue: [self addHandles]! !

!PolygonMorph methodsFor: 'debug and other' stamp: 'wiz 5/1/2004 00:21'!
rotateTestFlip: aBool 
	"Return one copy of me for each vertex using each vertex as  
	the  
	starting point.  
	Vary to border color to destinguish the copies.  
	This tests closed curves for their consistency.  
	The flip boolean tests the reversed rotations."
	| len colors verts flip |
	verts := self vertices.
	flip := aBool == true
				ifTrue: [1]
				ifFalse: [0].
	len := verts size.
	colors := Color wheel: len*2 .
	(1 to: len)
		do: [:i | | j | (self copy
				borderColor: (colors at: (j:=i * 2 - flip));
				 yourself)
				setVertices: (verts flipRotated: j);
				 openInWorld]! !


!PolygonMorph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:36'!
areasRemainingToFill: aRectangle
	"Could be improved by quick check of inner rectangle"

	^ Array with: aRectangle! !

!PolygonMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 18:56'!
drawArrowOn: aCanvas at: endPoint from: priorPoint 
	"Draw a triangle oriented along the line from priorPoint to  
	endPoint. Answer the wingBase."

	| pts spec wingBase |
	pts := self arrowBoundsAt: endPoint from: priorPoint.
	wingBase := pts size = 4 
				ifTrue: [pts third]
				ifFalse: [(pts copyFrom: 2 to: 3) average].
	spec := self valueOfProperty: #arrowSpec ifAbsent: [5 @ 4].
	spec x sign = spec y sign 
		ifTrue: [aCanvas drawPolygon: pts fillStyle: borderColor]
		ifFalse: 
			[aCanvas 
				drawPolygon: pts
				fillStyle: Color transparent
				borderWidth: (borderWidth + 1) // 2
				borderColor: borderColor].
	^wingBase! !

!PolygonMorph methodsFor: 'drawing' stamp: 'wiz 2/23/2006 19:19'!
drawArrowsOn: aCanvas 
	"Answer (possibly modified) endpoints for border drawing"
	"ArrowForms are computed only upon demand"
	| array |

	self hasArrows
		ifFalse: [^ #() ].
	"Nothing to do"

	array _ Array with: vertices first with: vertices last.

	"Prevent crashes for #raised or #inset borders"
	borderColor isColor
		ifFalse: [ ^array ].

	(arrows == #forward or: [arrows == #both])
		ifTrue: [ array at: 2 put: (self
				drawArrowOn: aCanvas
				at: vertices last
				from: self nextToLastPoint) ].

	(arrows == #back or: [arrows == #both])
		ifTrue: [ array at: 1 put: (self
				drawArrowOn: aCanvas
				at: vertices first
				from: self nextToFirstPoint) ].

	^array! !

!PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'!
drawBorderOn: aCanvas 
	self
		drawClippedBorderOn: aCanvas
		usingEnds: (Array with: vertices first with: vertices last)! !

!PolygonMorph methodsFor: 'drawing' stamp: 'wiz 6/22/2004 15:56'!
drawBorderOn: aCanvas usingEnds: anArray 
	"Display my border on the canvas."
	"NOTE: Much of this code is also copied in  
	drawDashedBorderOn:  
	(should be factored)"
	| bigClipRect p1i p2i style |
	borderDashSpec
		ifNotNil: [^ self drawDashedBorderOn: aCanvas usingEnds: anArray].
	style := self borderStyle.
	bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2.
	self
		lineSegmentsDo: [:p1 :p2 | 
			p1i := p1 asIntegerPoint.
			p2i := p2 asIntegerPoint.
			self hasArrows
				ifTrue: ["Shorten line ends so as not to interfere with tip  
					of arrow."
					((arrows == #back
								or: [arrows == #both])
							and: [p1 = vertices first])
						ifTrue: [p1i := anArray first asIntegerPoint].
					((arrows == #forward
								or: [arrows == #both])
							and: [p2 = vertices last])
						ifTrue: [p2i := anArray last asIntegerPoint]].
			(closed
					or: ["bigClipRect intersects: (p1i rect: p2i)  
						optimized:"
						((p1i min: p2i)
							max: bigClipRect origin)
							<= ((p1i max: p2i)
									min: bigClipRect corner)])
				ifTrue: [style
						drawLineFrom: p1i
						to: p2i
						on: aCanvas]]! !

!PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'!
drawClippedBorderOn: aCanvas usingEnds: anArray 
	aCanvas clipBy: self bounds during:[:cc| self drawBorderOn: cc usingEnds: anArray].! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:23'!
drawDashedBorderOn: aCanvas 
	self
		drawDashedBorderOn: aCanvas
		usingEnds: (Array with: vertices first with: vertices last)! !

!PolygonMorph methodsFor: 'drawing' stamp: 'wiz 6/22/2004 15:56'!
drawDashedBorderOn: aCanvas usingEnds: anArray 
	"Display my border on the canvas. NOTE: mostly copied from  
	drawBorderOn:"
	| lineColor bevel topLeftColor bottomRightColor bigClipRect p1i p2i segmentOffset |
	(borderColor isNil
			or: [borderColor isColor
					and: [borderColor isTransparent]])
		ifTrue: [^ self].
	lineColor := borderColor.
	bevel := false.
	"Border colors for bevelled effects depend on CW ordering of  
	vertices"
	borderColor == #raised
		ifTrue: [topLeftColor := color lighter.
			bottomRightColor := color darker.
			bevel := true].
	borderColor == #inset
		ifTrue: [topLeftColor := owner colorForInsets darker.
			bottomRightColor := owner colorForInsets lighter.
			bevel := true].
	bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2.
	segmentOffset := self borderDashOffset.
	self
		lineSegmentsDo: [:p1 :p2 | 
			p1i := p1 asIntegerPoint.
			p2i := p2 asIntegerPoint.
			self hasArrows
				ifTrue: ["Shorten line ends so as not to interfere with tip  
					of arrow."
					((arrows == #back
								or: [arrows == #both])
							and: [p1 = vertices first])
						ifTrue: [p1i := anArray first asIntegerPoint].
					((arrows == #forward
								or: [arrows == #both])
							and: [p2 = vertices last])
						ifTrue: [p2i := anArray last asIntegerPoint]].
			(closed
					or: ["bigClipRect intersects: (p1i rect: p2i)  
						optimized:"
						((p1i min: p2i)
							max: bigClipRect origin)
							<= ((p1i max: p2i)
									min: bigClipRect corner)])
				ifTrue: [bevel
						ifTrue: [lineColor := (p1i quadrantOf: p2i)
											> 2
										ifTrue: [topLeftColor]
										ifFalse: [bottomRightColor]].
					segmentOffset := aCanvas
								line: p1i
								to: p2i
								width: borderWidth
								color: lineColor
								dashLength: borderDashSpec first
								secondColor: borderDashSpec third
								secondDashLength: borderDashSpec second
								startingOffset: segmentOffset]]! !

!PolygonMorph methodsFor: 'drawing'!
drawOnFormCanvas: aCanvas 
	"Display the receiver, a spline curve, approximated by straight line segments."

	| |
	vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point'].
	closed & color isTransparent not
		ifTrue: [aCanvas stencil: self filledForm at: bounds topLeft - 1 color: color].
	(borderColor isColor and: [borderColor isTranslucentColor])
		ifTrue: [aCanvas stencil: self borderForm at: bounds topLeft
						color: borderColor]
		ifFalse: [self drawBorderOn: aCanvas].
	self arrowForms do:
		[:f | aCanvas stencil: f at: f offset
			color: (borderColor isColor ifTrue: [borderColor] ifFalse: [color])]! !

!PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'!
drawOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight 
	line segments."
	| array |
	vertices size < 1
		ifTrue: [self error: 'a polygon must have at least one point'].
	closed ifTrue:
		[aCanvas drawPolygon: self getVertices fillStyle: self fillStyle.
		aCanvas isShadowDrawing ifTrue: [^ self]].
	array _ self drawArrowsOn: aCanvas.
	self drawClippedBorderOn: aCanvas usingEnds: array.
! !


!PolygonMorph methodsFor: 'dropping/grabbing' stamp: 'di 9/8/2000 09:56'!
justDroppedInto: newOwner event: evt

	| delta |
	(newOwner isKindOf: PasteUpMorph) ifTrue:
		["Compensate for border width so that gridded drop
			is consistent with gridded drag of handles."
		delta _ borderWidth+1//2.
		self position: (newOwner gridPoint: self position + delta) - delta].
	^ super justDroppedInto: newOwner event: evt! !


!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 19:02'!
addHandles
	"Put moving handles at the vertices. Put adding handles at
	edge midpoints.
	Moving over adjacent vertex and dropping will delete a
	vertex. "
	| handle newVert tri |
	self removeHandles.
	handles := OrderedCollection new.
	tri := Array
				with: 0 @ -4
				with: 4 @ 3
				with: -3 @ 3.
	vertices
		withIndexDo: [:vertPt :vertIndex | 
			handle := EllipseMorph
						newBounds: (Rectangle center: vertPt extent: 8 @ 8)
						color: (self handleColorAt: vertIndex) .
			handle
				on: #mouseMove
				send: #dragVertex:event:fromHandle:
				to: self
				withValue: vertIndex.
			handle
				on: #mouseUp
				send: #dropVertex:event:fromHandle:
				to: self
				withValue: vertIndex.
				handle
				on: #click
				send: #clickVertex:event:fromHandle:
				to: self
				withValue: vertIndex.
			self addMorph: handle.
			handles addLast: handle.
			(closed
					or: [1 = vertices size
						"Give a small polygon a chance to grow. 
						-wiz"]
					or: [vertIndex < vertices size])
				ifTrue: [newVert := PolygonMorph
								vertices: (tri
										collect: [:p | p + (vertPt
													+ (vertices atWrap: vertIndex + 1) // 2)])
								color: Color green
								borderWidth: 1
								borderColor: Color black.
					newVert
						on: #mouseDown
						send: #newVertex:event:fromHandle:
						to: self
						withValue: vertIndex.
					self addMorph: newVert.
					handles addLast: newVert]].
	self isCurvy
		ifTrue: [self updateHandles; layoutChanged].
	self changed! !

!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/7/2006 23:35'!
clickVertex: ix event: evt fromHandle: handle
	"Backstop for MixedCurveMorph"! !

!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:20'!
deleteVertexAt: anIndex
	"This acts as a backstop for MixedCurveMorph."
			self
				setVertices: (vertices
						copyReplaceFrom: anIndex
						to: anIndex
						with: Array new).
						! !

!PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:30'!
dragVertex: ix event: evt fromHandle: handle
	| p |
	p _ self isCurve
		ifTrue: [evt cursorPoint]
		ifFalse: [self griddedPoint: evt cursorPoint].
	handle position: p - (handle extent//2).
	self verticesAt: ix put: p.
! !

!PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'!
dragVertex: arg1 fromHandle: arg2 vertIndex: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self dragVertex: arg1 event: arg2 fromHandle: arg3! !

!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:35'!
dropVertex: ix event: evt fromHandle: handle
	"Leave vertex in new position. If dropped ontop another vertex delete this one.
	Check for too few vertices before deleting. The alternative 
				is not pretty -wiz"
	| p |
	p := vertices at: ix.
	(vertices size >= 2
			and: ["check for too few vertices before deleting. The alternative 
				is not pretty -wiz"
				((vertices atWrap: ix - 1)
						dist: p)
						< 3
					or: [((vertices atWrap: ix + 1)
							dist: p)
							< 3]])
		ifTrue: ["Drag a vertex onto its neighbor means delete"
				self deleteVertexAt: ix .].
	evt shiftPressed
		ifTrue: [self removeHandles]
		ifFalse: [self addHandles
			"remove then add to recreate"]! !

!PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'!
dropVertex: arg1 fromHandle: arg2 vertIndex: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self dropVertex: arg1 event: arg2 fromHandle: arg3! !

!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:37'!
handleColorAt: vertIndex
      "This is a backstop for MixedCurveMorph"

^ Color yellow
! !

!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:19'!
insertVertexAt: anIndex put: aValue
	"This serves as a hook and a backstop for MixedCurveMorph."
	self setVertices: (vertices copyReplaceFrom: anIndex + 1 to: anIndex 
									with: (Array with: aValue)).! !

!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:25'!
newVertex: ix event: evt fromHandle: handle
	"Insert a new vertex and fix everything up!! Install the drag-handle of the new vertex as recipient of further mouse events."

	| pt |
	"(self hasProperty: #noNewVertices) ifFalse:
		[pt _ evt cursorPoint.
		self setVertices: (vertices copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)).
		evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)]"
	"modified to remove now vestigial test. see PolygonMorph class>>arrowprototype"
	pt _ evt cursorPoint.
	self  insertVertexAt: ix put:  pt .
	evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)! !

!PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'!
newVertex: arg1 fromHandle: arg2 afterVert: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self newVertex: arg1 event: arg2 fromHandle: arg3! !

!PolygonMorph methodsFor: 'editing' stamp: 'wiz 6/24/2004 23:03'!
updateHandles
	| newVert oldVert |
	self isCurvy
		ifTrue: [handles first center: vertices first.
			handles last center: vertices last.
			self midVertices
				withIndexDo: [:midPt :vertIndex | (closed
							or: [vertIndex < vertices size])
						ifTrue: [newVert := handles atWrap: vertIndex * 2.
							newVert position: midPt - (newVert extent // 2)]]]
		ifFalse: [vertices
				withIndexDo: [:vertPt :vertIndex | 
					oldVert := handles at: vertIndex * 2 - 1.
					oldVert position: vertPt - (oldVert extent // 2).
					(closed
							or: [vertIndex < vertices size])
						ifTrue: [newVert := handles at: vertIndex * 2.
							newVert position: vertPt
									+ (vertices atWrap: vertIndex + 1) - newVert extent // 2 + (1 @ -1)]]]! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 9/8/2000 10:39'!
verticesAt: ix put: newPoint
	vertices at: ix put: newPoint.
	self computeBounds! !


!PolygonMorph methodsFor: 'event handling' stamp: 'di 8/20/2000 14:29'!
handlesMouseDown: evt

	^ (super handlesMouseDown: evt) or: [evt shiftPressed]! !

!PolygonMorph methodsFor: 'event handling' stamp: 'nk 8/8/2001 12:13'!
mouseDown: evt

	^ evt shiftPressed
		ifTrue: [((owner isKindOf: PolygonMorph) and: [owner includesHandle: self])
					ifTrue: ["Prevent insertion handles from getting edited"
							^ super mouseDown: evt].
				self toggleHandles.
				handles ifNil: [^ self].
				vertices withIndexDo:  "Check for click-to-drag at handle site"
					[:vertPt :vertIndex |
					((handles at: vertIndex*2-1 ifAbsent: [ ^self ]) containsPoint: evt cursorPoint) ifTrue:
						["If clicked near a vertex, jump into drag-vertex action"
						evt hand newMouseFocus: (handles at: vertIndex*2-1)]]]
		ifFalse: [super mouseDown: evt]! !


!PolygonMorph methodsFor: 'geometry' stamp: 'nk 2/15/2001 09:09'!
arrowsContainPoint: aPoint
	"Answer an Array of two Booleans that indicate whether the given point is inside either arrow"

	| retval f |

	retval _ { false . false }.
	(super containsPoint: aPoint) ifFalse: [^ retval ].
	(closed or: [arrows == #none or: [vertices size < 2]]) ifTrue: [^ retval].

	(arrows == #forward or: [arrows == #both]) ifTrue: [	"arrowForms first has end form"
		f _ self arrowForms first.
		retval at: 2 put: ((f pixelValueAt: aPoint - f offset) > 0)
	].
	(arrows == #back or: [arrows == #both]) ifTrue: [ "arrowForms last has start form"
		f _ self arrowForms last.
		retval at: 1 put: ((f pixelValueAt: aPoint - f offset) > 0)
	].
	^retval.! !

!PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 14:14'!
closestPointTo: aPoint 
	| curvePoint closestPoint dist minDist |
	closestPoint := minDist := nil.
	self lineSegmentsDo: 
			[:p1 :p2 | 
			curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2.
			dist := curvePoint dist: aPoint.
			(closestPoint isNil or: [dist < minDist]) 
				ifTrue: 
					[closestPoint := curvePoint.
					minDist := dist]].
	^closestPoint! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 3/11/2001 19:08'!
closestSegmentTo: aPoint
	"Answer the starting index of my (big) segment nearest to aPoint"
	| curvePoint closestPoint dist minDist vertexIndex closestVertexIndex |
	vertexIndex _ 0.
	closestVertexIndex _ 0.
	closestPoint _ minDist _ nil.
	self lineSegmentsDo:
		[:p1 :p2 | 
		(p1 = (self vertices at: vertexIndex + 1))
			ifTrue: [ vertexIndex _ vertexIndex + 1 ].
		curvePoint _ aPoint nearestPointOnLineFrom: p1 to: p2.
		dist _ curvePoint dist: aPoint.
		(closestPoint == nil or: [dist < minDist])
			ifTrue: [closestPoint _ curvePoint.
					minDist _ dist.
					closestVertexIndex _ vertexIndex. ]].
	^ closestVertexIndex! !

!PolygonMorph methodsFor: 'geometry' stamp: 'di 9/24/2000 08:44'!
extent: newExtent 
	"Not really advisable, but we can preserve most of the geometry if we don't
	shrink things too small."
	| safeExtent center |
	center _ self referencePosition.
	safeExtent _ newExtent max: 20@20.
	self setVertices: (vertices collect:
		[:p | p - center * (safeExtent asFloatPoint / (bounds extent max: 1@1)) + center])! !

!PolygonMorph methodsFor: 'geometry' stamp: 'edc 3/20/2002 14:24'!
flipHAroundX: centerX
	"Flip me horizontally around the center.  If centerX is nil, compute my center of gravity."

	| cent |
	cent _ centerX 
		ifNil: [bounds center x
			"cent _ 0.
			vertices do: [:each | cent _ cent + each x].
			cent asFloat / vertices size"]		"average is the center"
		ifNotNil: [centerX].
	self setVertices: (vertices collect: [:vv |
			((vv x - cent) * -1 + cent) @ vv y]) reversed.! !

!PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!
flipVAroundY: centerY
	"Flip me vertically around the center.  If centerY is nil, compute my center of gravity."

	| cent |
	cent _ centerY 
		ifNil: [bounds center y
			"cent _ 0.
			vertices do: [:each | cent _ cent + each y].
			cent asFloat / vertices size"]		"average is the center"
		ifNotNil: [centerY].
	self setVertices: (vertices collect: [:vv |
			vv x @ ((vv y - cent) * -1 + cent)]) reversed.! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 3/30/2002 12:29'!
intersectionsWith: aRectangle
	"Answer a Set of points where the given Rectangle intersects with me.
	Ignores arrowForms."

	| retval |
	retval _ IdentitySet new: 4.
	(self bounds intersects: aRectangle) ifFalse: [^ retval].

	self lineSegmentsDo: [ :lp1 :lp2 | | polySeg |
		polySeg _ LineSegment from: lp1 to: lp2.
		aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int |
			rectSeg _ LineSegment from: rp1 to: rp2.
			int _ polySeg intersectionWith: rectSeg.
			int ifNotNil: [ retval add: int ].
		].
	].

	^retval
! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 2/15/2001 15:45'!
intersectionWithLineSegmentFromCenterTo: aPoint 
	^self closestPointTo: aPoint! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 4/27/2003 16:15'!
intersects: aRectangle 
	"Answer whether any of my segments intersects aRectangle, which is in World coordinates."
	| rect |
	(super intersects: aRectangle) ifFalse: [ ^false ].
	rect _ self bounds: aRectangle in: self world.
	self
		lineSegmentsDo: [:p1 :p2 | (rect intersectsLineFrom: p1 to: p2)
				ifTrue: [^ true]].
	^ false! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:38'!
isBordered
	^false! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:06'!
lineBorderColor
	^self borderColor! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:06'!
lineBorderColor: aColor
	self borderColor: aColor! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:07'!
lineBorderWidth

	^self borderWidth! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:46'!
lineBorderWidth: anInteger

	self borderWidth: anInteger! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:48'!
lineColor
	^self borderColor! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:48'!
lineColor: aColor
	self borderColor: aColor! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:47'!
lineWidth

	^self borderWidth! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:48'!
lineWidth: anInteger

	self borderWidth: (anInteger rounded max: 1)! !

!PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 18:57'!
mergeDropThird: mv in: hv from: shared 
	"We are merging two polygons.  In this case, they have at least three identical shared vertices.  Make sure they are sequential in each, and drop the middle one from vertex lists mv, hv, and shared.  First vertices on lists are identical already."

	"know (mv first = hv first)"

	| mdrop vv |
	(shared includes: (mv at: mv size - 2)) 
		ifTrue: [(shared includes: mv last) ifTrue: [mdrop := mv last]]
		ifFalse: 
			[(shared includes: mv last) 
				ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv first]]].
	(shared includes: (mv third)) 
		ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv second]].
	mdrop ifNil: [^nil].
	mv remove: mdrop.
	hv remove: mdrop.
	shared remove: mdrop.
	[shared includes: mv first] whileFalse: 
			["rotate them"

			vv := mv removeFirst.
			mv addLast: vv].
	[mv first = hv first] whileFalse: 
			["rotate him until same shared vertex is first"

			vv := hv removeFirst.
			hv addLast: vv]! !

!PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 18:56'!
merge: aPolygon 
	"Expand myself to enclose the other polygon.  (Later merge overlapping or disjoint in a smart way.)  For now, the two polygons must share at least two vertices.  Shared vertices must come one after the other in each polygon.  Polygons must not overlap."

	| shared mv vv hv xx |
	shared := vertices select: [:mine | aPolygon vertices includes: mine].
	shared size < 2 ifTrue: [^nil].	"not sharing a segment"
	mv := vertices asOrderedCollection.
	[shared includes: mv first] whileFalse: 
			["rotate them"

			vv := mv removeFirst.
			mv addLast: vv].
	hv := aPolygon vertices asOrderedCollection.
	[mv first = hv first] whileFalse: 
			["rotate him until same shared vertex is first"

			vv := hv removeFirst.
			hv addLast: vv].
	[shared size > 2] whileTrue: 
			[shared := shared asOrderedCollection.
			(self 
				mergeDropThird: mv
				in: hv
				from: shared) ifNil: [^nil]].
	"works by side effect on the lists"
	(mv second) = hv last 
		ifTrue: 
			[mv
				removeFirst;
				removeFirst.
			^self setVertices: (hv , mv) asArray].
	(hv second) = mv last 
		ifTrue: 
			[hv
				removeFirst;
				removeFirst.
			^self setVertices: (mv , hv) asArray].
	(mv second) = (hv second) 
		ifTrue: 
			[hv removeFirst.
			mv remove: (mv second).
			xx := mv removeFirst.
			^self setVertices: (hv , (Array with: xx) , mv reversed) asArray].
	mv last = hv last 
		ifTrue: 
			[mv removeLast.
			hv removeFirst.
			^self setVertices: (mv , hv reversed) asArray].
	^nil! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 4/27/2003 15:39'!
nextDuplicateVertexIndex
	vertices
		doWithIndex: [:vert :index | ((index between: 2 and: vertices size - 1)
					and: [| epsilon v1 v2 | 
						v1 _ vertices at: index - 1.
						v2 _ vertices at: index + 1.
						epsilon _ ((v1 x - v2 x) abs max: (v1 y - v2 y) abs)
									// 32 max: 1.
						vert
							onLineFrom: v1
							to: v2
							within: epsilon])
				ifTrue: [^ index]].
	^ 0! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 4/18/2002 16:58'!
reduceVertices
	"Reduces the vertices size, when 3 vertices are on the same line with a 
	little epsilon. Based on code by Steffen Mueller"
	| dup |
	[ (dup _ self nextDuplicateVertexIndex) > 0 ] whileTrue: [
		self setVertices: (vertices copyWithoutIndex: dup)
	].
	^vertices size.! !

!PolygonMorph methodsFor: 'geometry' stamp: 'nk 3/6/2001 16:36'!
straighten
	self setVertices: { vertices first . vertices last }! !

!PolygonMorph methodsFor: 'geometry' stamp: 'ar 10/6/2000 15:40'!
transformedBy: aTransform
	self setVertices: (self vertices collect:[:v| aTransform localPointToGlobal: v])! !


!PolygonMorph methodsFor: 'geometry eToy' stamp: 'di 9/24/2000 08:38'!
referencePosition 
	"Return the current reference position of the receiver"
	^ self valueOfProperty: #referencePosition ifAbsent: [super referencePosition]
! !

!PolygonMorph methodsFor: 'geometry eToy' stamp: 'di 9/24/2000 09:21'!
rotationCenter
	"Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	| refPos |
	refPos _ self valueOfProperty: #referencePosition
		ifAbsent: [^ 0.5@0.5].
	^ (refPos - self bounds origin) / self bounds extent asFloatPoint! !

!PolygonMorph methodsFor: 'geometry eToy' stamp: 'di 9/24/2000 09:31'!
rotationCenter: aPointOrNil
	"Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	| box |
	aPointOrNil isNil
		ifTrue: [self removeProperty: #referencePosition]
		ifFalse: [box _ self bounds.
				self setProperty: #referencePosition
					toValue: box origin + (aPointOrNil * box extent)]
! !


!PolygonMorph methodsFor: 'geometry testing' stamp: 'di 8/20/2000 14:33'!
containsPoint: aPoint
	(super containsPoint: aPoint) ifFalse: [^ false].

	closed & color isTransparent not ifTrue:
		[^ (self filledForm pixelValueAt: aPoint - bounds topLeft + 1) > 0].

	self lineSegmentsDo:
		[:p1 :p2 |
		(aPoint onLineFrom: p1 to: p2 within: (3 max: borderWidth+1//2) asFloat)
				ifTrue: [^ true]].

	self arrowForms do:
		[:f | (f pixelValueAt: aPoint - f offset) > 0 ifTrue: [^ true]].

	^ false! !


!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 09:42'!
rotationDegrees: degrees 
	| flex center |
	(center _ self valueOfProperty: #referencePosition) ifNil:
		[self setProperty: #referencePosition toValue: (center _ self bounds center)].
	flex _ (MorphicTransform offset: center negated)
			withAngle: (degrees - self forwardDirection) degreesToRadians.
	self setVertices: (vertices collect: [:v | (flex transform: v) - flex offset]).
	self forwardDirection: degrees.

! !


!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:44'!
beSmoothCurve

	smoothCurve == true ifFalse:
		[smoothCurve _ true.
		self computeBounds]! !

!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:45'!
beStraightSegments

	smoothCurve == false ifFalse:
		[smoothCurve _ false.
		self computeBounds]! !

!PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color
		r: 0.0
		g: 0.419
		b: 0.935! !

!PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color orange! !

!PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:10'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	vertices _ Array
				with: 5 @ 0
				with: 20 @ 10
				with: 0 @ 20.
	closed _ true.
	smoothCurve _ false.
	arrows _ #none.
	self computeBounds! !

!PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:09'!
vertices: verts color: aColor borderWidth: borderWidthInteger borderColor: anotherColor 
	super initialize.
""
	vertices _ verts.
	color _ aColor.
	borderWidth _ borderWidthInteger.
	borderColor _ anotherColor.
	closed _ vertices size > 2.
	arrows _ #none.
	self computeBounds! !


!PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 14:42'!
addCustomMenuItems: aMenu hand: aHandMorph 
	| |
	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu
		addUpdating: #handlesShowingPhrase
		target: self
		action: #showOrHideHandles.
	vertices size > 2
		ifTrue: [ self addPolyLIneCurveMenuItems: aMenu hand: aHandMorph ].
	aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
	"aMenu add: 'use debug border' translated action: #showSegmentsBorderStyle."
	self isOpen
		ifTrue: [self addPolyArrowMenuItems: aMenu hand: aHandMorph]
			ifFalse: [self addPolyShapingMenuItems: aMenu hand: aHandMorph]! !

!PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 13:53'!
addPolyArrowMenuItems: aMenu hand: aHandMorph 
aMenu addLine.
			aMenu
				addWithLabel: '---'
				enablement: [self isOpen
						and: [arrows ~~ #none]]
				action: #makeNoArrows.
			aMenu
				addWithLabel: '-->'
				enablement: [self isOpen
						and: [arrows ~~ #forward]]
				action: #makeForwardArrow.
			aMenu
				addWithLabel: '<--'
				enablement: [self isOpen
						and: [arrows ~~ #back]]
				action: #makeBackArrow.
			aMenu
				addWithLabel: '<->'
				enablement: [self isOpen
						and: [arrows ~~ #both]]
				action: #makeBothArrows.
			aMenu add: 'customize arrows' translated action: #customizeArrows:.
			(self hasProperty: #arrowSpec)
				ifTrue: [aMenu add: 'standard arrows' translated action: #standardArrows]! !

!PolygonMorph methodsFor: 'menu' stamp: 'wiz 4/1/2006 19:05'!
addPolyLIneCurveMenuItems: aMenu hand: aHandMorph 

	aMenu addLine;
				addUpdating: #openOrClosePhrase
				target: self
				action: #makeOpenOrClosed.
			
			aMenu
				addUpdating: #smoothOrSegmentedPhrase
				target: self
				action: #toggleSmoothing.! !

!PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 13:50'!
addPolyShapingMenuItems: aMenu hand: aHandMorph 
	aMenu addLine.
			aMenu
				addWithLabel: 'make inscribed diamondOval'
				enablement: [self isClosed ]
				action: #diamondOval.
			aMenu
				addWithLabel: 'make enclosing rectangleOval'
				enablement: [self isClosed ]
					action: #rectOval.
					! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 19:23'!
arrowLength: aLength
	"Assumes that I have exactly two vertices"

	| theta horizontalOffset verticalOffset newTip delta |
	delta _ vertices second - vertices first.
	theta _ delta theta.
	horizontalOffset _ aLength * (theta cos).
	verticalOffset _ aLength * (theta sin).
	newTip _ vertices first + (horizontalOffset @ verticalOffset).
	self verticesAt: 2 put: newTip! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 09:09'!
arrowSpec: specPt
	"Specify a custom arrow for this line.
	specPt x abs gives the length of the arrow (point to base) in terms of borderWidth.
	If specPt x is negative, then the base of the arrow will be concave.
	specPt y abs gives the width of the arrow.
	The standard arrow is equivalent to arrowSpec: 5@4.
	See arrowBoundsAt:From: for details."

	self setProperty: #arrowSpec toValue: specPt.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'nk 2/26/2001 20:11'!
arrows
	^arrows! !

!PolygonMorph methodsFor: 'menu' stamp: 'md 12/12/2003 16:22'!
customizeArrows: evt
	| handle origin aHand |
	aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin _ aHand position.
	handle _ HandleMorph new
		forEachPointDo:
			[:newPoint | handle removeAllMorphs.
			handle addMorph:
				(LineMorph from: origin to: newPoint color: Color black width: 1).
			self arrowSpec: (newPoint - origin) / 5.0]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo ifNotNilDo: [:halo | halo addHandles].].
	aHand attachMorph: handle.
	handle setProperty: #helpAtCenter toValue: true.
	handle showBalloon:
'Move cursor left and right
to change arrow length and style.
Move it up and down to change width.
Click when done.' hand: evt hand.
	handle startStepping! !

!PolygonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:57'!
handlesShowingPhrase
	^ (self showingHandles
		ifTrue: ['hide handles']
		ifFalse: ['show handles']) translated! !

!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'!
makeBackArrow
	arrows _ #back.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'!
makeBothArrows
	arrows _ #both.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'!
makeClosed
	closed _ true.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'!
makeForwardArrow
	arrows _ #forward.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'!
makeNoArrows
	arrows _ #none.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'!
makeOpen
	closed _ false.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 13:10'!
quickFill: ignored! !

!PolygonMorph methodsFor: 'menu' stamp: 'tk 9/2/97 16:04'!
removeHandles
	"tk 9/2/97 allow it to be called twice (when nil already)"

	handles ifNotNil: [
		handles do: [:h | h delete].
		handles _ nil].! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 9/24/2000 09:25'!
setRotationCenterFrom: aPoint
	"Polygons store their referencePosition."
	self setProperty: #referencePosition toValue: aPoint! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:17'!
showingHandles
	^ handles notNil! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:16'!
showOrHideHandles
	self showingHandles
		ifTrue:	[self removeHandles]
		ifFalse:	[self addHandles]! !

!PolygonMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 12:54'!
specifyDashedLine

	| executableSpec newSpec |
	executableSpec _ FillInTheBlank
		request:
'Enter a dash specification as
{ major dash length. minor dash length. minor dash color }
The major dash will have the normal border color.
A blank response will remove the dash specification.
[Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3}
where the 4th ityem is zero, and the 5th is the number of pixels
by which the dashes will move in each step of animation]' translated
		initialAnswer: '{ 10. 5. Color red }'.
	executableSpec isEmpty ifTrue:
		[^ self stopStepping; dashedBorder: nil].
	newSpec _ [Compiler evaluate: executableSpec] ifError:
		[^ self stopStepping; dashedBorder: nil].
	newSpec first isNumber & newSpec second isNumber & newSpec third isColor ifFalse:
		[^ self stopStepping; dashedBorder: nil].
	newSpec size = 3 ifTrue:
		[^ self stopStepping; dashedBorder: newSpec].
	(newSpec size = 5 and: [newSpec fourth isNumber & newSpec fifth isNumber]) ifTrue:
		[^ self dashedBorder: newSpec; startStepping].
! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 07:12'!
standardArrows

	self removeProperty: #arrowSpec.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:31'!
toggleHandles

	handles ifNil: [self addHandles] ifNotNil: [self removeHandles].

! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 15:43'!
toggleSmoothing

	smoothCurve _ smoothCurve not.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:06'!
unrotatedLength
	"If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is"

	vertices size == 2 ifTrue:
		[^ (vertices second - vertices first) r].

	^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:54'!
unrotatedLength: aLength
	"If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is"

	vertices size == 2 ifTrue: [^ self arrowLength: aLength].

	self setVertices: ((((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height: aLength) rotationDegrees: 0) vertices! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:17'!
unrotatedWidth
	"If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is"
	
	vertices size == 2 ifTrue: [^ self borderWidth].
	^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) width! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:18'!
unrotatedWidth: aWidth
	"If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is"

	self borderWidth: aWidth! !


!PolygonMorph methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:48'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	smoothCurve ifNil: [smoothCurve _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!PolygonMorph methodsFor: 'rotate scale and flex' stamp: 'di 11/28/2001 18:23'!
addFlexShellIfNecessary
	"When scaling or rotating from a halo, I can do this without a flex shell"

	^ self
! !

!PolygonMorph methodsFor: 'rotate scale and flex' stamp: 'di 9/24/2000 08:42'!
rotationDegrees

	^ self forwardDirection! !


!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 1/7/2005 19:53'!
coefficients
	"Compute an array for the coefficients."
	| verts vertXs vertYs slopeXs slopeYs coefficients |
	curveState
		ifNotNil: [^ curveState at: 1].
	verts := self vertices.
	verts size < 1
		ifTrue: [^ self].
	"Less than three points handled as segments by our 
	lineSegmentsDo:"
	(self isCurvier)
		ifFalse: [closed
				ifTrue: [verts := verts , verts first asOrderedCollection]].
	coefficients := {vertXs := verts
						collect: [:p | p x asFloat]. slopeXs := self slopes: vertXs. vertXs changeInSlopes: slopeXs. vertXs changeOfChangesInSlopes: slopeXs. vertYs := verts
						collect: [:p | p y asFloat]. slopeYs := self slopes: vertYs. vertYs changeInSlopes: slopeYs. vertYs changeOfChangesInSlopes: slopeYs. Array new: verts size withAll: 12}.
	coefficients
		at: 9
		put: ((1 to: verts size)
				collect: [:i | (coefficients cubicPointPolynomialAt: i) bestSegments]).
	(self isCurvier)
		ifFalse: [closed
				ifTrue: [coefficients := coefficients
								collect: [:each | each allButLast]]].
	curveState := {coefficients. nil. nil}.
	self computeNextToEndPoints.
	^ coefficients! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:15'!
computeNextToEndPoints
	| pointAfterFirst pointBeforeLast |
	pointAfterFirst := nil.
	self lineSegmentsDo: 
			[:p1 :p2 | 
			pointAfterFirst isNil ifTrue: [pointAfterFirst := p2 asIntegerPoint].
			pointBeforeLast := p1 asIntegerPoint].
	curveState at: 2 put: pointAfterFirst.
	curveState at: 3 put: pointBeforeLast! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:16'!
derivs: a first: point1 second: point2 third: point3 
	"Compute the first, second and third derivitives (in coeffs) from
	the Points in this Path (coeffs at: 1 and coeffs at: 5)."

	| len v anArray |
	len := a size.
	len < 2 ifTrue: [^self].
	len > 2 
		ifTrue: 
			[v := Array new: len.
			v at: 1 put: 4.0.
			anArray := Array new: len.
			anArray at: 1 put: 6.0 * (a first - (a second * 2.0) + (a third)).
			2 to: len - 2
				do: 
					[:i | 
					v at: i put: 4.0 - (1.0 / (v at: i - 1)).
					anArray at: i
						put: 6.0 * ((a at: i) - ((a at: i + 1) * 2.0) + (a at: i + 2)) 
								- ((anArray at: i - 1) / (v at: i - 1))].
			point2 at: len - 1 put: (anArray at: len - 2) / (v at: len - 2).
			len - 2 to: 2
				by: 0 - 1
				do: 
					[:i | 
					point2 at: i
						put: ((anArray at: i - 1) - (point2 at: i + 1)) / (v at: i - 1)]].
	point2 at: 1 put: (point2 at: len put: 0.0).
	1 to: len - 1
		do: 
			[:i | 
			point1 at: i
				put: (a at: i + 1) - (a at: i) 
						- (((point2 at: i) * 2.0 + (point2 at: i + 1)) / 6.0).
			point3 at: i put: (point2 at: i + 1) - (point2 at: i)]! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 1/8/2005 19:24'!
lineSegmentsDo: endPointsBlock 
	"Emit a sequence of segment endpoints into endPointsBlock."
	"Unlike the method this one replaces we expect the curve 
	coefficents not the dirivatives"
	"Also unlike the replaced method the smooth closed curve
	does 
	not need an extra vertex. 
	We take care of the extra endpoint here. Just like for 
	segmented curves."
	| n t x y x1 x2 x3 y1 y2 y3 beginPoint endPoint cs |
	vertices size < 1
		ifTrue: [^ self].
	"test too few vertices first"
	self isCurvy
		ifFalse: [beginPoint := nil.
			"smoothCurve 
			ifTrue: [cs := self coefficients]."
			"some things still depend on smoothCurves having 
			curveState"
			vertices
				do: [:vert | 
					beginPoint
						ifNotNil: [endPointsBlock value: beginPoint value: vert].
					beginPoint := vert].
			(closed
					or: [vertices size = 1])
				ifTrue: [endPointsBlock value: beginPoint value: vertices first].
			^ self].
	"For curves we include all the interpolated sub segments."
	"self assert: [(vertices size > 2 )].	"
	cs := self coefficients.
	beginPoint := (x := cs first first) @ (y := cs fifth first).
	(closed
		ifTrue: [1 to: cs first size]
		ifFalse: [1 to: cs first size - 1])
		do: [:i | 
			"taylor series coefficients"
			x1 := cs second at: i.
			y1 := cs sixth at: i.
			x2 := cs third at: i.
			y2 := cs seventh at: i.
			x3 := cs fourth at: i.
			y3 := cs eighth at: i.
			n := cs ninth at: i.
			"guess n 
			n := 5 max: (x2 abs + y2 abs * 2.0 + (cs third atWrap:
			i 
			+ 1) abs + (cs seventh atWrap: i + 1) abs / 100.0) 
			rounded."
			1
				to: n - 1
				do: [:j | 
					t := j asFloat / n asFloat.
					endPoint := x3 * t + x2 * t + x1 * t + x @ (y3 * t + y2 * t + y1 * t + y).
					endPointsBlock value: beginPoint value: endPoint.
					beginPoint := endPoint].
			endPoint := (x := cs first atWrap: i + 1) @ (y := cs fifth atWrap: i + 1).
			endPointsBlock value: beginPoint value: endPoint.
			beginPoint := endPoint]! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 11/16/2004 19:54'!
nextToFirstPoint
	"For arrow direction"
	self isCurvy
		ifTrue: [curveState
				ifNil: [self coefficients].
			^ curveState second]
		ifFalse: [^ vertices second]! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 11/16/2004 19:51'!
nextToLastPoint
	"For arrow direction"
	self isCurvy
		ifTrue: [curveState
				ifNil: [self coefficients].
			^ curveState third]
		ifFalse: [^ vertices at: vertices size - 1]! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 1/7/2005 19:53'!
slopes: knots 
	"Choose slopes according to state of polygon and preferences"
	self isCurvy
		ifFalse: [^ knots segmentedSlopes].
	^ (closed
			and: [self isCurvier])
		ifTrue: [knots closedCubicSlopes]
		ifFalse: [knots naturalCubicSlopes]! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'nk 4/23/2002 15:48'!
straightLineSegmentsDo: endPointsBlock
	"Emit a sequence of segment endpoints into endPointsBlock.
	Work the same way regardless of whether I'm curved."
	| beginPoint |
	beginPoint _ nil.
		vertices do:
			[:vert | beginPoint ifNotNil:
				[endPointsBlock value: beginPoint
								value: vert].
			beginPoint _ vert].
		(closed or: [vertices size = 1])
			ifTrue: [endPointsBlock value: beginPoint
									value: vertices first].! !


!PolygonMorph methodsFor: 'stepping and presenter' stamp: 'dgd 2/22/2003 18:58'!
step
	borderDashSpec ifNil: [^super step].
	borderDashSpec size < 5 ifTrue: [^super step].

	"Only for dashed lines with creep"
	borderDashSpec at: 4 put: (borderDashSpec fourth) + borderDashSpec fifth.
	self changed.
	^super step! !


!PolygonMorph methodsFor: 'testing' stamp: 'wiz 7/18/2004 23:00'!
hasArrows
	"Are all the conditions meet for having arrows?"
	^ (closed
		or: [arrows == #none
				or: [vertices size < 2]]) not! !

!PolygonMorph methodsFor: 'testing' stamp: 'wiz 1/7/2005 19:59'!
isCurvier
	"Test used by smoothing routines.  If true use true closed curve splines for closed curves. If not mimic old stodgy curveMorph curves with one sharp bend.. Override this routine in classes where backward compatability is still needed."
	^ (Preferences valueOfFlag: #Curvier)! !

!PolygonMorph methodsFor: 'testing' stamp: 'wiz 5/2/2004 22:03'!
isCurvy
	"Test for significant curves.  
	Small smoothcurves in practice are straight."
	^ smoothCurve
		and: [vertices size > 2]! !

!PolygonMorph methodsFor: 'testing' stamp: 'nk 10/13/2003 18:36'!
isLineMorph
	^closed not! !

!PolygonMorph methodsFor: 'testing' stamp: 'di 9/9/2000 09:24'!
stepTime

	^ 100! !

!PolygonMorph methodsFor: 'testing' stamp: 'dgd 2/22/2003 18:58'!
wantsSteps
	super wantsSteps ifTrue: [^true].

	"For crawling ants effect of dashed line."
	borderDashSpec ifNil: [^false].
	^borderDashSpec size = 5 and: [(borderDashSpec fifth) > 0]! !


!PolygonMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:18'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^true! !

!PolygonMorph methodsFor: 'visual properties' stamp: 'di 9/19/2000 22:00'!
fillStyle

	self isOpen
		ifTrue: [^ self borderColor  "easy access to line color from halo"]
		ifFalse: [^ super fillStyle]! !

!PolygonMorph methodsFor: 'visual properties' stamp: 'wiz 1/7/2005 20:39'!
fillStyle: newColor

	self isOpen
		ifTrue: [^ self borderColor: newColor asColor "easy access to line color from halo"]
		ifFalse: [^ super fillStyle: newColor]! !


!PolygonMorph methodsFor: '*eToys-geometry eToy' stamp: 'di 9/24/2000 09:36'!
heading: newHeading
	"Set the receiver's heading (in eToy terms).
	Note that polygons never use flex shells."
	self rotationDegrees: newHeading.! !


!PolygonMorph methodsFor: '*MorphicExtras-geometry eToy' stamp: 'nk 9/4/2004 11:57'!
scale: scaleFactor 
	| flex center ratio |
	ratio := self scaleFactor / scaleFactor.
	self borderWidth: ((self borderWidth / ratio) rounded max: 0).
	center := self referencePosition.
	flex := (MorphicTransform offset: center negated)
				withScale: ratio.
	self
		setVertices: (vertices
				collect: [:v | (flex transform: v)
						- flex offset]).
	super scale: scaleFactor.! !


!PolygonMorph methodsFor: '*MorphicExtras-*morphic-Postscript Canvases' stamp: 'ar 11/26/2001 23:15'!
drawPostscriptOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight 
	line segments."
	| array |
	vertices size < 1
		ifTrue: [self error: 'a polygon must have at least one point'].
	array _ self drawArrowsOn: aCanvas.
	closed
		ifTrue: [aCanvas
				drawPolygon: self getVertices
				color: self color
				borderWidth: self borderWidth
				borderColor: self borderColor]
		ifFalse: [self drawClippedBorderOn: aCanvas usingEnds: array].
! !


!PolygonMorph methodsFor: 'private' stamp: 'di 10/3/2000 09:02'!
arrowBoundsAt: endPoint from: priorPoint 
	"Answer a triangle oriented along the line from priorPoint to endPoint."
	| d v angle wingBase arrowSpec length width |
	v _ endPoint - priorPoint.
	angle _ v degrees.
	d _ borderWidth max: 1.
	arrowSpec _ self valueOfProperty: #arrowSpec ifAbsent: [5@4].
	length _ arrowSpec x abs.  width _ arrowSpec y abs.
	wingBase _ endPoint + (Point r: d * length degrees: angle + 180.0).
	arrowSpec x >= 0
		ifTrue: [^ {	endPoint.
					wingBase + (Point r: d * width degrees: angle + 125.0).
					wingBase + (Point r: d * width degrees: angle - 125.0) }]
		ifFalse: ["Negative length means concave base."
				^ {	endPoint.
					wingBase + (Point r: d * width degrees: angle + 125.0).
					wingBase.
					wingBase + (Point r: d * width degrees: angle - 125.0) }]! !

!PolygonMorph methodsFor: 'private' stamp: 'wiz 6/22/2004 15:54'!
arrowForms
	"ArrowForms are computed only upon demand"
	arrowForms
		ifNotNil: [^ arrowForms].
	arrowForms := Array new.
	self hasArrows
		ifFalse: [^ arrowForms].
	(arrows == #forward
			or: [arrows == #both])
		ifTrue: [arrowForms := arrowForms
						copyWith: (self computeArrowFormAt: vertices last from: self nextToLastPoint)].
	(arrows == #back
			or: [arrows == #both])
		ifTrue: [arrowForms := arrowForms
						copyWith: (self computeArrowFormAt: vertices first from: self nextToFirstPoint)].
	^ arrowForms! !

!PolygonMorph methodsFor: 'private' stamp: 'ar 5/25/2000 18:04'!
borderForm
	"A form must be created for drawing the border whenever the borderColor is translucent."

	| borderCanvas |
	borderForm ifNotNil: [^ borderForm].
	borderCanvas _ (Display defaultCanvasClass extent: bounds extent depth: 1)
		shadowColor: Color black.
	borderCanvas translateBy: bounds topLeft negated
		during:[:tempCanvas| self drawBorderOn: tempCanvas].
	borderForm _ borderCanvas form.
	self arrowForms do:
		[:f |  "Eliminate overlap between line and arrowheads if transparent."
		borderForm copy: f boundingBox from: f to: f offset - self position rule: Form erase].
	^ borderForm! !

!PolygonMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:56'!
computeArrowFormAt: endPoint from: priorPoint 
	"Compute a triangle oriented along the line from priorPoint to  
	endPoint. Then draw those lines in a form and return that  
	form, with appropriate offset"

	| p1 pts box arrowForm bb origin |
	pts := self arrowBoundsAt: endPoint from: priorPoint.
	box := ((pts first rect: pts last) encompass: (pts second)) expandBy: 1.
	arrowForm := Form extent: box extent asIntegerPoint.
	bb := (BitBlt current toForm: arrowForm)
				sourceForm: nil;
				fillColor: Color black;
				combinationRule: Form over;
				width: 1;
				height: 1.
	origin := box topLeft.
	p1 := pts last - origin.
	pts do: 
			[:p | 
			bb drawFrom: p1 to: p - origin.
			p1 := p - origin].
	arrowForm convexShapeFill: Color black.
	^arrowForm offset: box topLeft! !

!PolygonMorph methodsFor: 'private' stamp: 'wiz 2/12/2006 00:04'!
computeBounds
	| oldBounds delta excludeHandles |
	vertices ifNil: [^ self].

	self changed.
	oldBounds _ bounds.
	self releaseCachedState.
	bounds _ self curveBounds expanded.
	self arrowForms do:
		[:f | bounds _ bounds merge: (f offset extent: f extent)].
	handles ifNotNil: [self updateHandles].

	"since we are directly updating bounds, see if any ordinary submorphs exist and move them accordingly"
	(oldBounds notNil and: [(delta _ bounds origin - oldBounds origin) ~= (0@0)]) ifTrue: [
		excludeHandles _ IdentitySet new.
		handles ifNotNil: [excludeHandles addAll: handles].
		self submorphsDo: [ :each |
			(excludeHandles includes: each) ifFalse: [
				each position: each position + delta
			].
		].
	].
	self layoutChanged.
	self changed.
! !

!PolygonMorph methodsFor: 'private' stamp: 'wiz 2/12/2006 02:58'!
curveBounds
	"Compute the bounds from actual curve traversal, with 
	leeway for borderWidth. 
	Also note the next-to-first and next-to-last points for arrow 
	directions."
	"wiz - to avoid roundoff errors we return unrounded curvebounds."
	"we expect our receiver to take responsibility for approriate rounding adjustment."
	"hint: this is most likely 'self curveBounds expanded' "
	| pointAfterFirst pointBeforeLast  oX oY cX cY |
	self isCurvy
		ifFalse: [^ (Rectangle encompassing: vertices)
				expandBy: borderWidth * 0.5 ].
	curveState := nil.
	"Force recomputation"
	"curveBounds := vertices first corner: vertices last."
	pointAfterFirst := nil.
	self
		lineSegmentsDo: [:p1 :p2 | 
			pointAfterFirst isNil
				ifTrue: [pointAfterFirst := p2 floor .
					oX := cX := p1 x.
					oY := cY := p1 y. ].
			"curveBounds := curveBounds encompass: p2 ."
			oX:= oX min: p2 x.
			cX := cX max: p2 x.
			oY := oY min: p2 y.
			cY := cY max: p2 y.
			pointBeforeLast := p1 floor ].
	curveState at: 2 put: pointAfterFirst.
	curveState at: 3 put: pointBeforeLast.
	^ ( oX @ oY corner: cX @ cY )  expandBy: borderWidth * 0.5 ! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/7/2000 13:30'!
filledForm
	"Note: The filled form is actually 2 pixels bigger than bounds, and the point corresponding to this morphs' position is at 1@1 in the form.  This is due to the details of the fillig routines, at least one of which requires an extra 1-pixel margin around the outside.  Computation of the filled form is done only on demand."
	| bb origin |
	closed ifFalse: [^ filledForm _ nil].
	filledForm ifNotNil: [^ filledForm].
	filledForm _ Form extent: bounds extent+2.

	"Draw the border..."
	bb _ (BitBlt current toForm: filledForm) sourceForm: nil; fillColor: Color black;
			combinationRule: Form over; width: 1; height: 1.
	origin _ bounds topLeft asIntegerPoint-1.
	self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 asIntegerPoint-origin
										to: p2 asIntegerPoint-origin].

	"Fill it in..."
	filledForm convexShapeFill: Color black.

	(borderColor isColor and: [borderColor isTranslucentColor]) ifTrue:
		["If border is stored as a form, then erase any overlap now."
		filledForm copy: self borderForm boundingBox from: self borderForm
			to: 1@1 rule: Form erase].

	^ filledForm! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/7/2000 16:17'!
getVertices

	smoothCurve ifFalse: [^ vertices].

	"For curves, enumerate the full set of interpolated points"
	^ Array streamContents:
		[:s | self lineSegmentsDo: [:pt1 :pt2 | s nextPut: pt1]]! !

!PolygonMorph methodsFor: 'private' stamp: 'di 8/31/2000 13:46'!
includesHandle: aMorph

	handles ifNil: [^ false].
	^ handles includes: aMorph! !

!PolygonMorph methodsFor: 'private' stamp: 'di 11/21/97 21:29'!
lineSegments
	| lineSegments |
	lineSegments _ OrderedCollection new.
	self lineSegmentsDo: [:p1 :p2 | lineSegments addLast: (Array with: p1 with: p2)].
	^ lineSegments! !

!PolygonMorph methodsFor: 'private' stamp: 'md 12/12/2003 16:22'!
privateMoveBy: delta
	super privateMoveBy: delta.
	vertices _ vertices collect: [:p | p + delta].
	self arrowForms do: [:f | f offset: f offset + delta].
	curveState _ nil.  "Force recomputation"
	(self valueOfProperty: #referencePosition) ifNotNilDo:
		[:oldPos | self setProperty: #referencePosition toValue: oldPos + delta]! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/8/2000 10:36'!
setVertices: newVertices
	vertices _ newVertices.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'private' stamp: 'nk 3/27/2001 21:23'!
transformVerticesFrom: oldOwner to: newOwner
	| oldTransform newTransform world newVertices |
	world _ self world.
	oldTransform _ oldOwner
		ifNil: [ IdentityTransform new ]
		ifNotNil: [ oldOwner transformFrom: world ].
	newTransform _ newOwner
		ifNil: [ IdentityTransform new ]
		ifNotNil: [ newOwner transformFrom: world ].
	newVertices _ vertices collect: [ :ea | newTransform globalPointToLocal:
		(oldTransform localPointToGlobal: ea) ].
	self setVertices: newVertices.
! !


!PolygonMorph methodsFor: 'shaping' stamp: 'wiz 1/8/2005 19:27'!
diamondOval
	"Set my vertices to an array of edge midpoint vertices. 
	Order of vertices is in the tradion of warpblt quads."
	| b r |
	b := self bounds.
	r := {b leftCenter. b bottomCenter. b rightCenter. b topCenter}.
	self setVertices: r! !

!PolygonMorph methodsFor: 'shaping' stamp: 'wiz 1/8/2005 19:20'!
rectOval
	"Set my vertices to an array of corner vertices.
	Order of vertices is in the tradion of warpblt quads."

	self setVertices: self bounds corners.! !


!PolygonMorph methodsFor: 'attachments' stamp: 'nk 8/14/2004 13:58'!
boundsSignatureHash
	^(vertices - (self positionInWorld))  hash
! !

!PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:21'!
defaultAttachmentPointSpecs
	^{ 
		{ #firstVertex } .
		{ #midpoint  } .
		{ #lastVertex }
	}! !

!PolygonMorph methodsFor: 'attachments' stamp: 'nk 4/18/2001 11:43'!
endShapeColor: aColor
	self borderColor: aColor.
	self isClosed ifTrue: [ self color: aColor ].! !

!PolygonMorph methodsFor: 'attachments' stamp: 'nk 5/31/2003 10:56'!
endShapeWidth: aWidth
	| originalWidth originalVertices transform |
	originalWidth _ self valueOfProperty: #originalWidth ifAbsentPut: [ self borderWidth isZero ifFalse: [ self borderWidth ] ifTrue: [ 2 ] ].
	self borderWidth: aWidth.
	originalVertices _ self valueOfProperty: #originalVertices ifAbsentPut: [
		self vertices collect: [ :ea | (ea - (self referencePosition)) rotateBy: self heading degreesToRadians about: 0@0 ]
	].
	transform _ MorphicTransform offset: 0@0 angle: self heading degreesToRadians scale: originalWidth / aWidth.
	self setVertices: (originalVertices collect: [ :ea |
		((transform transform: ea) + self referencePosition) asIntegerPoint
	]).
	self computeBounds.! !

!PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:19'!
firstVertex
	^vertices first! !

!PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:19'!
lastVertex
	^vertices last! !

!PolygonMorph methodsFor: 'attachments' stamp: 'nk 7/3/2003 14:43'!
midpoint
	"Answer the midpoint along my segments"
	| middle |
	middle _ 0.
	self lineSegmentsDo: [ :a :b | middle _ middle + (a dist: b) ].
	middle < 2 ifTrue: [ ^ self center ].
	middle _ middle / 2.
	self lineSegmentsDo: [ :a :b | | dist |
		dist _ (a dist: b).
		middle < dist
			ifTrue: [ ^(a + ((b - a) * (middle / dist))) asIntegerPoint ].
		middle _ middle - dist.
	].
	self error: 'can''t happen'! !

!PolygonMorph methodsFor: 'attachments' stamp: 'nk 4/23/2002 15:49'!
nudgeForLabel: aRectangle
	"Try to move the label off me. Prefer labels on the top and right."

	| i flags nudge |
	(self bounds intersects: aRectangle) ifFalse: [^ 0@0 ].
	flags _ 0.
	nudge _ 0@0.
	i _ 1.
	aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int |
		rectSeg _ LineSegment from: rp1 to: rp2.
		self straightLineSegmentsDo: [ :lp1 :lp2 | | polySeg  |
			polySeg _ LineSegment from: lp1 to: lp2.
			int _ polySeg intersectionWith: rectSeg.
			int ifNotNil: [ flags _ flags bitOr: i ].
		].
		i _ i * 2.
	].
	"Now flags has bitflags for which sides"
	nudge _ flags caseOf: {
"no intersection"
		[ 0 ] -> [ 0@0 ].
"2 adjacent sides only" 
		[ 9 ] -> [ 1@1 ].
		[ 3 ] -> [ -1@1 ].
		[ 12 ] -> [ 1@-1 ].
		[ 6 ] -> [ -1@-1 ].
"2 opposite sides only" 
		[ 10 ] -> [ 0@-1 ].
		[ 5 ] -> [ 1@0 ].
"only 1 side" 
		[ 8 ] -> [ -1@0 ].
		[ 1 ] -> [ 0@-1 ].
		[ 2 ] -> [ 1@0 ].
		[ 4 ] -> [ 0@1 ].
"3 sides" 
		[ 11 ] -> [ 0@1 ].
		[ 13 ] -> [ 1@0 ].
		[ 14 ] -> [ 0@-1 ].
		[ 7 ] -> [ -1@0 ].
 "all sides" 
		[ 15 ] -> [ 1@-1 "move up and to the right" ].
	}.
	^nudge! !

!PolygonMorph methodsFor: 'attachments' stamp: 'nk 7/3/2003 14:42'!
totalLength
	"Answer the full length of my segments. Can take a long time if I'm curved."
	| length |
	length _ 0.
	self lineSegmentsDo: [ :a :b | length _ length + (a dist: b) ].
	^length.! !


!PolygonMorph methodsFor: 'rounding' stamp: 'ka 12/4/2005 00:56'!
cornerStyle: aSymbol 
	"Set the receiver's corner style.  But, in this case, do *not*"

	self removeProperty: #cornerStyle.
	self changed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PolygonMorph class
	instanceVariableNames: ''!

!PolygonMorph class methodsFor: 'instance creation' stamp: 'wiz 7/13/2005 00:43'!
arrowPrototype
	"Answer an instance of the receiver that will serve as a prototypical arrow"

	| aa |
	aa _ self new. 
	aa vertices: (Array with: 0@0 with: 40@40) 
		color: Color black 
		borderWidth: 2 
		borderColor: Color black.
	"aa setProperty: #noNewVertices toValue: true."
	"Revert to expected behavior. Remove vestigial code."
	aa makeForwardArrow.		"is already open"
	aa computeBounds.
	^ aa! !

!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 10/18/2001 03:56'!
fromHand: hand
	"Let the user draw a polygon, clicking at each vertex, and ending
		by clicking within 5 of the first point..."
	| p1 poly oldVerts pN opposite |
	Cursor crossHair showWhile:
		[[Sensor anyButtonPressed] whileFalse:
			[self currentWorld displayWorldSafely; runStepMethods].
		p1 _ Sensor cursorPoint].
	opposite _ (Display colorAt: p1) negated.
	opposite = Color transparent ifTrue: [opposite _ Color red].
	(poly _ LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld.
	oldVerts _ {p1}.
	self currentWorld displayWorldSafely; runStepMethods.
	[true] whileTrue:
		[[Sensor anyButtonPressed] whileTrue:
			[pN _ Sensor cursorPoint.
			poly setVertices: (oldVerts copyWith: pN).
			self currentWorld displayWorldSafely; runStepMethods].
		(oldVerts size > 1 and: [(pN dist: p1) < 5]) ifTrue:
			[hand position: Sensor cursorPoint.  "Done -- update hand pos"
			^ (poly setVertices: (poly vertices copyWith: p1)) delete].
		oldVerts _ poly vertices.
		[Sensor anyButtonPressed] whileFalse:
			[pN _ Sensor cursorPoint.
			poly setVertices: (oldVerts copyWith: pN).
			self currentWorld displayWorldSafely; runStepMethods]].
! !

!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 10/18/2001 04:42'!
fromHandFreehand: hand
	"Let the user draw a polygon, holding the mouse down, and ending
		by clicking within 5 of the first point..."
	| p1 poly pN opposite |
	Cursor crossHair showWhile:
		[[Sensor anyButtonPressed] whileFalse:
			[self currentWorld displayWorldSafely; runStepMethods].
		p1 _ Sensor cursorPoint].
	opposite _ (Display colorAt: p1) negated.
	opposite = Color transparent ifTrue: [opposite _ Color red].
	(poly _ LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld.
	self currentWorld displayWorldSafely; runStepMethods.
	[Sensor anyButtonPressed] whileTrue:
			[pN _ Sensor cursorPoint.
			(pN dist: poly vertices last) > 3 ifTrue:
				[poly setVertices: (poly vertices copyWith: pN).
				self currentWorld displayWorldSafely; runStepMethods]].
	hand position: Sensor cursorPoint.  "Done -- update hand pos"
	^ (poly setVertices: (poly vertices copyWith: p1)) delete! !

!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 9/9/2000 11:41'!
shapeFromPen: penBlock color: c borderWidth: bw borderColor: bc
	"World addMorph: (PolygonMorph
		shapeFromPen: [:p | p hilbert: 4 side: 5. p go: 5.
						p hilbert: 4 side: 5. p go: 5]
		color: Color red borderWidth: 1 borderColor: Color black)"

	| pen |
	penBlock value: (pen _ PenPointRecorder new).
	^ (self vertices: pen points asArray color: c borderWidth: bw borderColor: bc)
		quickFill: false! !

!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 9/7/2000 17:05'!
vertices: verts color: c borderWidth: bw borderColor: bc
	^ self basicNew beStraightSegments vertices: verts color: c borderWidth: bw borderColor: bc! !


!PolygonMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:12'!
descriptionForPartsBin
	^ self partName:	'Polygon'
		categories:		#('Graphics' 'Basic')
		documentation:	'A series of connected line segments, which may be a closed solid, or a zig-zag line.  Shift-click to get handles and move the points.'! !


!PolygonMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 10:03'!
initialize

	self registerInFlapsRegistry.	! !

!PolygonMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 10:10'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(PolygonMorph	authoringPrototype		'Polygon'	'A straight-sided figure with any number of sides')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(PolygonMorph	authoringPrototype		'Polygon'	'A straight-sided figure with any number of sides')
						forFlapNamed: 'Supplies'.]! !

!PolygonMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:38'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!PolygonMorph class methodsFor: '*MorphicExtras-instance creation' stamp: 'nk 8/23/2004 18:12'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'Arrow'
		categoryList: #('Basic' 'Graphics')
		documentation: 'A line with an arrowhead.  Shift-click to get handles and move the ends.'
		globalReceiverSymbol: #PolygonMorph
		nativitySelector: #arrowPrototype}
! !
StringMorph subclass: #PopUpChoiceMorph
	instanceVariableNames: 'target actionSelector arguments getItemsSelector getItemsArgs choiceSelector choiceArgs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
actionSelector

	^ actionSelector
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
arguments

	^ arguments
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:33'!
getItemsArgs

	^ getItemsArgs
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:33'!
getItemsArgs: aCollection

	getItemsArgs _ aCollection asArray copy.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:32'!
getItemsSelector

	^ getItemsSelector
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:32'!
getItemsSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ getItemsSelector _ nil].

	getItemsSelector _ aSymbolOrString asSymbol.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
target

	^ target
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
target: anObject

	target _ anObject
! !


!PopUpChoiceMorph methodsFor: 'copying' stamp: 'di 3/24/1999 09:57'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
getItemsArgs _ getItemsArgs collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
choiceArgs ifNotNil: [choiceArgs _ choiceArgs collect: [:each |
	deepCopier references at: each ifAbsent: [each]]].! !

!PopUpChoiceMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:43'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		a Symbol"
"arguments _ arguments.		All weakly copied"
"getItemsSelector _ getItemsSelector.		a Symbol"
"getItemsArgs _ getItemsArgs.		All weakly copied"
"choiceSelector _ choiceSelector.		a Symbol"
choiceArgs _ choiceArgs.		"All weakly copied"
     ! !


!PopUpChoiceMorph methodsFor: 'event handling' stamp: 'jm 2/2/98 00:20'!
handlesMouseDown: evt

	^ true
! !

!PopUpChoiceMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:50'!
mouseDown: evt 
	| items menu selectedItem |
	(target isNil or: [getItemsSelector isNil]) ifTrue: [^self].
	items := target perform: getItemsSelector withArguments: getItemsArgs.
	menu := CustomMenu new.
	items do: [:item | menu add: item action: item].
	selectedItem := menu startUp.
	selectedItem ifNil: [^self].
	self contentsClipped: selectedItem.	"Client can override this if necess"
	actionSelector ifNotNil: 
			[target perform: actionSelector
				withArguments: (arguments copyWith: selectedItem)]! !


!PopUpChoiceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:44'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self contents: 'PopUpChoice of Colors'.
	target _ Color.
	actionSelector _ nil.
	arguments _ EmptyArray.
	getItemsSelector _ #colorNames.
	getItemsArgs _ EmptyArray! !
Object subclass: #PopUpMenu
	instanceVariableNames: 'labelString font lineArray frame form marker selection'
	classVariableNames: 'CacheMenuForms MenuStyle'
	poolDictionaries: ''
	category: 'ST80-Menus'!
!PopUpMenu commentStamp: '<historical>' prior: 0!
I represent a list of items. My instances are presented on the display screen in a rectangular area. The user points to an item, pressing a mouse button; the item is highlighted. When the button is released, the highlighted item indicates the selection.!


!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:44'!
center
	"Answer the point at the center of the receiver's rectangular area."

	^ frame center! !

!PopUpMenu methodsFor: 'accessing' stamp: 'di 4/20/1999 14:33'!
frameHeight
	"Designed to avoid the entire frame computation (includes MVC form),
	since the menu may well end up being displayed in Morphic anyway."
	| nItems |
	frame ifNotNil: [^ frame height].
	nItems _ 1 + (labelString occurrencesOf: Character cr).
	^ (nItems * MenuStyle lineGrid) + 4 "border width"! !

!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 14:55'!
labelString
	^ labelString! !

!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 14:55'!
lineArray
	^ lineArray! !

!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 12:32'!
nItems
	^ (labelString occurrencesOf: Character cr) + 1! !

!PopUpMenu methodsFor: 'accessing' stamp: 'sw 3/12/2002 21:37'!
startUpLeftFlush
	"Build and invoke this menu with no initial selection.  By Jerry Archibald, 4/01.
	If in MVC, align menus items with the left margin.
	Answer the selection associated with the menu item chosen by the user or nil if none is chosen.  
	The mechanism for getting left-flush appearance in mvc leaves a tiny possibility for misadventure: if the user, in mvc, puts up the jump-to-project menu, then hits cmd period while it is up, then puts up a second jump-to-project menu before dismissing or proceeding through the debugger, it's possible for mvc popup-menus thereafter to appear left-aligned rather than centered; this very unlikely condition can be cleared by evaluating 'PopUpMenu alignment: 2'"

	| saveAlignment result |
	Smalltalk isMorphic ifFalse:
		[saveAlignment _ PopUpMenu alignment.
		PopUpMenu leftFlush].
	[result _ self startUp] ensure:
		[Smalltalk isMorphic ifFalse:
			[PopUpMenu alignment: saveAlignment]].
	^ result! !


!PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 6/1/2000 13:04'!
controlActivity
	"Do whatever a menu must do - now with keyboard support."

	| didNotMove downPos |
	didNotMove _ true.
	Sensor anyButtonPressed
		ifFalse:
			[didNotMove _ false.
			Sensor waitButtonOrKeyboard]. 
	
	Sensor keyboardPressed ifFalse: [self manageMarker].
	(didNotMove and: [selection = 0])
		ifTrue:
			[downPos _ Sensor cursorPoint.
			[didNotMove and: [Sensor anyButtonPressed]]
				whileTrue:
					[(downPos dist: Sensor cursorPoint) < 2 ifFalse: [didNotMove _ false]].
			didNotMove ifTrue: [Sensor waitButtonOrKeyboard]].

	[Sensor keyboardPressed] whileTrue:
		[self readKeyboard ifTrue: [^ self].
		Sensor waitButtonOrKeyboard].

	[Sensor anyButtonPressed] whileTrue: [self manageMarker]! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 6/1/2000 10:55'!
readKeyboard
	"Keyboard support for menus. ESC will abort the menu, Space or CR
	will select an item. Cursor up and cursor down will change the
	selection. Any other key will either select an item whose label starts
	with that character or select the next matching label.
	Answer true if the menu should be closed and false otherwise."

	| ch labels occurences |
	ch _ Sensor keyboard asciiValue.
	(ch = 13 or: [ch = 32]) ifTrue: [^ true].
	ch = 27 ifTrue: [self setSelection: 0. ^ true].
	ch = 30
		ifTrue:
			[self setSelection: (selection <= 1
				ifTrue: [self nItems]
				ifFalse: [selection - 1])].
	ch = 31 ifTrue: [self setSelection: selection \\ self nItems + 1].
	ch _ ch asCharacter asLowercase.
	labels _ labelString findTokens: Character cr asString.
	occurences _ 0.
	1 + selection to: selection + labels size do:
		[:index |
		| i | i _ index - 1 \\ labels size + 1.
		(labels at: i) withBlanksTrimmed first asLowercase = ch
			ifTrue: [(occurences _ occurences + 1) = 1 ifTrue: [self setSelection: i]]].
	^ occurences = 1! !

!PopUpMenu methodsFor: 'basic control sequence'!
startUp
	"Display and make a selection from the receiver as long as the button 
	is pressed. Answer the current selection."
	
	^ self startUpWithCaption: nil! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 3/18/2001 00:55'!
startUpCenteredWithCaption: captionOrNil
	"Differs from startUpWithCaption: by appearing with cursor in the menu,
	and thus ready to act on mouseUp, without requiring user tweak to confirm"
	^ self startUpWithCaption: captionOrNil at: (ActiveHand ifNil:[Sensor]) cursorPoint - (20@0)! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'yo 3/15/2005 12:55'!
startUpSegmented: segmentHeight withCaption: captionOrNil at: location
	"This menu is too big to fit comfortably on the screen.
	Break it up into smaller chunks, and manage the relative indices.
	Inspired by a special-case solution by Reinier van Loon."
"
(PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1])
		lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'.
"
	| nLines nLinesPer allLabels from to subset subLines index |
	frame ifNil: [self computeForm].
	allLabels := labelString findTokens: Character cr asString.
	nLines _ allLabels size.
	lineArray ifNil: [lineArray _ Array new].
	nLinesPer _ segmentHeight // marker height - 3.
	from := 1.
	[ true ] whileTrue:
		[to := (from + nLinesPer) min: nLines.
		subset := allLabels copyFrom: from to: to.
		subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated])
			before: subset first.
		subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1].
		subLines _ (Array with: 1) , subLines.
		index := (PopUpMenu labels: subset asStringWithCr lines: subLines)
					startUpWithCaption: captionOrNil at: location.
		index = 1
			ifTrue: [from := to + 1.
					from > nLines ifTrue: [ from := 1 ]]
			ifFalse: [index = 0 ifTrue: [^ 0].
					^ from + index - 2]]! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'yo 3/15/2005 12:55'!
startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean
	"This menu is too big to fit comfortably on the screen.
	Break it up into smaller chunks, and manage the relative indices.
	Inspired by a special-case solution by Reinier van Loon.  The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)"

"
(PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1])
		lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'.
"
	| nLines nLinesPer allLabels from to subset subLines index |
	frame ifNil: [self computeForm].
	allLabels := labelString findTokens: Character cr asString.
	nLines _ allLabels size.
	lineArray ifNil: [lineArray _ Array new].
	nLinesPer _ segmentHeight // marker height - 3.
	from := 1.
	[ true ] whileTrue:
		[to := (from + nLinesPer) min: nLines.
		subset := allLabels copyFrom: from to: to.
		subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated])
			before: subset first.
		subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1].
		subLines _ (Array with: 1) , subLines.
		index := (PopUpMenu labels: subset asStringWithCr lines: subLines)
					startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean.
		index = 1
			ifTrue: [from := to + 1.
					from > nLines ifTrue: [ from := 1 ]]
			ifFalse: [index = 0 ifTrue: [^ 0].
					^ from + index - 2]]! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 3/18/2001 00:55'!
startUpWithCaption: captionOrNil
	"Display the menu, slightly offset from the cursor,
	so that a slight tweak is required to confirm any action."
	^ self startUpWithCaption: captionOrNil at: (ActiveHand ifNil:[Sensor]) cursorPoint! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 12/27/2001 22:47'!
startUpWithCaption: captionOrNil at: location
	"Display the menu, with caption if supplied. Wait for the mouse button to go down,
	then track the selection as long as the button is pressed. When the button is released, 
	answer the index of the current selection, or zero if the mouse is not released over 
	any menu item. Location specifies the desired topLeft of the menu body rectangle."

		^ self startUpWithCaption: captionOrNil at: location allowKeyboard: Preferences menuKeyboardControl! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'dgd 4/4/2006 14:47'!
startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean
	"Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released,
	Answer the index of the current selection, or zero if the mouse is not released over  any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard."

	^ self
			startUpWithCaption: captionOrNil
			icon: nil
			at: location
			allowKeyboard: aBoolean! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'dgd 10/12/2004 13:43'!
startUpWithCaption: captionOrNil icon: aForm
	"Display the menu, slightly offset from the cursor,
	so that a slight tweak is required to confirm any action."
	^ self
			startUpWithCaption: captionOrNil
			icon: aForm
			at: (ActiveHand ifNil:[Sensor]) cursorPoint
! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'dgd 10/12/2004 13:44'!
startUpWithCaption: captionOrNil icon: aForm at: location
	"Display the menu, with caption if supplied. Wait for the mouse button to go down,
	then track the selection as long as the button is pressed. When the button is released, 
	answer the index of the current selection, or zero if the mouse is not released over 
	any menu item. Location specifies the desired topLeft of the menu body rectangle."

	^ self
			startUpWithCaption: captionOrNil
			icon: aForm
			at: location
			allowKeyboard: Preferences menuKeyboardControl
! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'tlk 5/2/2006 22:22'!
startUpWithCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean
	"Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released,
	Answer the index of the current selection, or zero if the mouse is not released over  any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard."

	| maxHeight |
	(ProvideAnswerNotification signal: captionOrNil) ifNotNilDo:
		[:answer | ^ selection _ answer ifTrue: [1] ifFalse: [2]].
		 
	maxHeight _ Display height*3//4.
	self frameHeight > maxHeight ifTrue:
		[^ self
			startUpSegmented: maxHeight
			withCaption: captionOrNil
			at: location
			allowKeyboard: aBoolean].

	Smalltalk isMorphic
		ifTrue:[
			selection _ Cursor normal showWhile:
				[| menuMorph | 
				menuMorph := MVCMenuMorph from: self title: nil.
				(captionOrNil notNil or:[aForm notNil])
					ifTrue:[menuMorph addTitle: captionOrNil icon: aForm].
				MenuIcons decorateMenu: menuMorph.
				menuMorph
					invokeAt: location 
					in: ActiveWorld
					allowKeyboard: aBoolean].
			^ selection].

	frame ifNil: [self computeForm].
	Cursor normal showWhile:
		[self
			displayAt: location
			withCaption: captionOrNil
			during: [self controlActivity]].
	^ selection! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'sw 12/17/2001 17:01'!
startUpWithoutKeyboard
	"Display and make a selection from the receiver as long as the button  is pressed. Answer the current selection.  Do not allow keyboard input into the menu"
	
	^ self startUpWithCaption: nil at: ((ActiveHand ifNil:[Sensor]) cursorPoint) allowKeyboard: false! !


!PopUpMenu methodsFor: 'displaying' stamp: 'sw 12/10/1999 09:55'!
displayAt: aPoint withCaption: captionOrNil during: aBlock
	"Display the receiver just to the right of aPoint while aBlock is evaluated.  If the receiver is forced off screen, display it just to the right."
	| delta savedArea captionForm captionSave outerFrame captionText tFrame frameSaveLoc captionBox |
	marker ifNil: [self computeForm].
	frame _ frame align: marker leftCenter with: aPoint + (2@0).
	outerFrame _ frame.
	captionOrNil notNil ifTrue:
		[captionText _ (DisplayText
				text: captionOrNil asText
				textStyle: MenuStyle copy centered)
					foregroundColor: Color black
					backgroundColor: Color white.
		tFrame _ captionText boundingBox insetBy: -2.
		outerFrame _ frame merge: (tFrame align: tFrame bottomCenter
					with: frame topCenter + (0@2))].
	delta _ outerFrame amountToTranslateWithin: Display boundingBox.
	frame right > Display boundingBox right
		ifTrue: [delta _ 0 - frame width @ delta y].
	frame _ frame translateBy: delta.
	captionOrNil notNil ifTrue:
		[captionForm _ captionText form.
		captionBox _ captionForm boundingBox expandBy: 4.
		captionBox _ captionBox align: captionBox bottomCenter
								with: frame topCenter + (0@2).
		captionSave _ Form fromDisplay: captionBox.
		Display border: captionBox width: 4 fillColor: Color white.
		Display border: captionBox width: 2 fillColor: Color black.
		captionForm displayAt: captionBox topLeft + 4].
	marker _ marker align: marker leftCenter with: aPoint + delta +  (2@0).
	savedArea _ Form fromDisplay: frame.
	self menuForm displayOn: Display at: (frameSaveLoc _ frame topLeft).
	selection ~= 0 ifTrue: [Display reverse: marker].
	Cursor normal showWhile: [aBlock value].
	savedArea displayOn: Display at: frameSaveLoc.
	captionOrNil notNil ifTrue:
		[captionSave displayOn: Display at: captionBox topLeft]! !


!PopUpMenu methodsFor: 'marker adjustment' stamp: 'di 4/13/1999 17:42'!
manageMarker
	"If the cursor is inside the receiver's frame, then highlight the marked 
	item. Otherwise no item is to be marked."
	| pt |
	"Don't let pt get far from display box, so scrolling will go all the way"
	pt _ Sensor cursorPoint adhereTo: (Display boundingBox expandBy: 1).
	(frame inside containsPoint: pt)
		ifTrue: ["Need to cache the form for reasonable scrolling performance"
				((Display boundingBox insetBy: 0@3) containsPoint: pt)
					ifFalse: [pt _ pt - (self scrollIntoView: pt)].
				self markerOn: pt]
		ifFalse: [self markerOff]! !

!PopUpMenu methodsFor: 'marker adjustment' stamp: 'sma 5/28/2000 15:27'!
markerOff
	"No item is selected. Reverse the highlight if any item has been marked 
	as selected."

	self setSelection: 0! !

!PopUpMenu methodsFor: 'marker adjustment' stamp: 'sma 6/1/2000 13:01'!
markerOn: aPoint 
	"The item whose bounding area contains aPoint should be marked as 
	selected. Highlight its area and set the selection to its index."

	selection = 0 | (marker containsPoint: aPoint) not 
		ifTrue: [selection = 0 & (marker containsPoint: aPoint)
					ifTrue: [Display reverse: marker]
					ifFalse: 
						[selection > 0 ifTrue: [Display reverse: marker].
						marker _ 
							marker 
								align: marker topLeft 
								with: marker left @ (self markerTop: aPoint).
						Display reverse: marker]].
	selection _ marker top - frame top // marker height + 1! !

!PopUpMenu methodsFor: 'marker adjustment'!
markerTop: aPoint 
	"Answer aPoint, gridded to lines in the receiver."

	^(aPoint y - frame inside top truncateTo: font height) + frame inside top! !

!PopUpMenu methodsFor: 'marker adjustment' stamp: 'di 3/9/98 19:46'!
scrollIntoView: cursorLoc
	| dy |
	dy _ 0.
	cursorLoc y < 2 ifTrue: [dy _ font height].
	cursorLoc y > (Display height-3) ifTrue: [dy _ font height negated].
	dy = 0 ifTrue: [^ 0@0].
	self markerOff.
	frame _ frame translateBy: 0@dy.
	marker _ marker translateBy: 0@dy.
	self menuForm displayOn: Display at: frame topLeft.
	^ 0@dy! !


!PopUpMenu methodsFor: 'selecting' stamp: 'sma 5/28/2000 12:27'!
selection
	"Answer the current selection."

	^ selection! !

!PopUpMenu methodsFor: 'selecting' stamp: 'sma 6/1/2000 11:01'!
setSelection: index
	| newSelection |
	selection = index ifTrue: [^ self].
	newSelection _ (0 max: index) min: frame height // marker height.
	selection > 0 ifTrue: [Display reverse: marker].
	marker _ marker translateBy: 0 @ (newSelection - selection * marker height).
	selection _ newSelection.
	selection > 0 ifTrue: [Display reverse: marker]! !


!PopUpMenu methodsFor: 'private' stamp: 'BG 8/6/2003 12:34'!
computeForm
	"Compute and answer a Form to be displayed for this menu."

	| borderInset paraForm menuForm inside |
	borderInset _ 4@4.
	paraForm _ (DisplayText text: labelString asText textStyle: MenuStyle) form.
	menuForm _ Form extent: paraForm extent + (borderInset * 2) depth: paraForm depth.
      menuForm fill: (0 @ 0 extent: menuForm  extent)
                        rule: Form over
                        fillColor: Color white.
	menuForm borderWidth: 2.
	paraForm displayOn: menuForm at: borderInset.
	lineArray == nil ifFalse:
		[lineArray do:
			[ :line |
			menuForm fillBlack: (4 @ ((line * font height) + borderInset y)
				extent: (menuForm width - 8 @ 1))]].

	frame _ Quadrangle new.
	frame region: menuForm boundingBox.
	frame borderWidth: 4.
	inside _ frame inside.
	marker _ inside topLeft extent: (inside width @ MenuStyle lineGrid).
	selection _ 1.

	^ form _ menuForm
! !

!PopUpMenu methodsFor: 'private'!
computeLabelParagraph
	"Answer a Paragraph containing this menu's labels, one per line and centered."

	^ Paragraph withText: labelString asText style: MenuStyle! !

!PopUpMenu methodsFor: 'private' stamp: 'di 4/13/1999 16:21'!
labels: aString font: aFont lines: anArray

	labelString _ aString.
	font _ aFont.
	lineArray _ anArray.
! !

!PopUpMenu methodsFor: 'private' stamp: 'di 4/13/1999 17:51'!
menuForm
	"Answer a Form to be displayed for this menu."

	form == nil ifTrue: [self computeForm].
	^ form! !

!PopUpMenu methodsFor: 'private' stamp: 'sma 2/5/2000 11:56'!
rescan
	"Cause my form to be recomputed after a font change."

	labelString == nil ifTrue: [labelString _ 'NoText!!'].
	self labels: labelString font: (MenuStyle fontAt: 1) lines: lineArray.
	frame _ marker _ form _ nil.

	"PopUpMenu allSubInstancesDo: [:m | m rescan]"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PopUpMenu class
	instanceVariableNames: ''!

!PopUpMenu class methodsFor: 'class initialization' stamp: 'jla 4/2/2001 20:41'!
alignment

	^ MenuStyle alignment! !

!PopUpMenu class methodsFor: 'class initialization' stamp: 'jla 4/2/2001 20:46'!
alignment: anAlignment

	^ MenuStyle alignment: anAlignment! !

!PopUpMenu class methodsFor: 'class initialization' stamp: 'sw 12/6/1999 13:08'!
initialize  "PopUpMenu initialize"
	(MenuStyle _ TextStyle default copy)
		gridForFont: TextStyle default defaultFontIndex withLead: 0;
		centered.
	PopUpMenu allSubInstancesDo: [:m | m rescan]! !

!PopUpMenu class methodsFor: 'class initialization' stamp: 'jla 4/2/2001 20:56'!
leftFlush

	MenuStyle leftFlush! !

!PopUpMenu class methodsFor: 'class initialization' stamp: 'nk 9/1/2004 10:27'!
setMenuFontTo: aFont
	"Set the menu font as indicated"

	MenuStyle _ TextStyle fontArray: { aFont }.
	MenuStyle 
		gridForFont: 1 withLead: 0;
		centered.
	self allSubInstancesDo: [:m | m rescan]! !


!PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 9/5/2003 18:24'!
confirm: queryString
	"Put up a yes/no menu with caption queryString. Answer true if the 
	response is yes, false if no. This is a modal question--the user must 
	respond yes or no."

	"PopUpMenu confirm: 'Are you hungry?'"

	^ self confirm: queryString trueChoice: 'Yes' translated falseChoice: 'No' translated! !

!PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 10/12/2004 13:49'!
confirm: queryString orCancel: cancelBlock 
	"Put up a yes/no/cancel menu with caption aString. Answer 
	true if  
	the response is yes, false if no. If cancel is chosen, evaluate  
	cancelBlock. This is a modal question--the user must respond 
	yes or no."
	"PopUpMenu confirm: 'Reboot universe' orCancel: 
	[^'Nevermind'] "
	| menu choice |
	menu := PopUpMenu labelArray: {'Yes' translated. 'No' translated. 'Cancel' translated}.
	choice := menu startUpWithCaption: queryString icon: MenuIcons confirmIcon.
	choice = 1
		ifTrue: [^ true].
	choice = 2
		ifTrue: [^ false].
	^ cancelBlock value! !

!PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 10/12/2004 13:49'!
confirm: queryString trueChoice: trueChoice falseChoice: falseChoice 
	"Put up a yes/no menu with caption queryString. The actual 
	wording  
	for the two choices will be as provided in the trueChoice and  
	falseChoice parameters. Answer true if the response is the 
	true-choice,  
	false if it's the false-choice. 
	This is a modal question -- the user must respond one way or 
	the other."
	"PopUpMenu  
	confirm: 'Are you hungry?' 
	trueChoice: 'yes, I''m famished' 
	falseChoice: 'no, I just ate'"
	| menu choice |
	menu := PopUpMenu labelArray: {trueChoice. falseChoice}.
	[(choice := menu startUpWithCaption: queryString icon: MenuIcons confirmIcon) isNil] whileTrue.
	^ choice = 1! !

!PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 10/12/2004 13:42'!
inform: aString
	"PopUpMenu inform: 'I like Squeak'"

	(PopUpMenu labels: ' OK ' translated)
		startUpWithCaption: aString
		icon: MenuIcons confirmIcon
! !

!PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 5/28/2000 15:57'!
notify: message
	"Deprecated. Use #inform: instead."

	self inform: message! !


!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:44'!
labelArray: labelArray
	"Answer an instance of me whose items are in labelArray."

	^ self labelArray: labelArray lines: nil! !

!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:43'!
labelArray: labelArray lines: lineArray
	"Answer an instance of me whose items are in labelArray, with lines 
	drawn after each item indexed by anArray. 2/1/96 sw"

	labelArray isEmpty ifTrue: [self error: 'Menu must not be zero size'].
	^ self
		labels: (String streamContents: 
			[:stream |
			labelArray do: [:each | stream nextPutAll: each; cr].
			stream skip: -1 "remove last CR"])
		lines: lineArray

"Example:
	(PopUpMenu labelArray: #('frog' 'and' 'toad') lines: #()) startUp"! !

!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:36'!
labels: aString
	"Answer an instance of me whose items are in aString."

	^ self labels: aString lines: nil! !

!PopUpMenu class methodsFor: 'instance creation' stamp: 'sw 12/6/1999 17:55'!
labels: aString lines: anArray
	"Answer an instance of me whose items are in aString, with lines drawn 
	after each item indexed by anArray."

	^ self new
		labels: aString
		font: MenuStyle defaultFont
		lines: anArray! !

!PopUpMenu class methodsFor: 'instance creation' stamp: 'nk 8/30/2004 07:59'!
withCaption: cap chooseFrom: labels 
	"Simply put up a menu. Get the args in the right order with the caption 
	first. labels may be either an array of items or a string with CRs in it. 
	May use backslashes for returns."

	^ (labels isString
		ifTrue: [self labels: labels withCRs lines: nil]
		ifFalse: [self labelArray: labels lines: nil])
		startUpWithCaption: cap withCRs! !
Stream subclass: #PositionableStream
	instanceVariableNames: 'collection position readLimit'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!PositionableStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects (a collection) that are externally named by indices so that the point of access can be repositioned. I am abstract in that I do not implement the messages next and nextPut: which are inherited from my superclass Stream.!


!PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:03'!
back
	"Go back one element and return it.  Use indirect messages in case I am a StandardFileStream"

	self position = 0 ifTrue: [self errorCantGoBack].
	self position = 1 ifTrue: [self position: 0.  ^ nil].
	self skip: -2.
	^ self next
! !

!PositionableStream methodsFor: 'accessing'!
contents
	"Answer with a copy of my collection from 1 to readLimit."

	^collection copyFrom: 1 to: readLimit! !

!PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'!
contentsOfEntireFile
	"For non-file streams"
	^ self contents! !

!PositionableStream methodsFor: 'accessing' stamp: 'tk 9/23/2001 01:14'!
last
	"Return the final element in the receiver"

	^ collection at: position! !

!PositionableStream methodsFor: 'accessing' stamp: 'tk 3/27/98 08:44'!
nextDelimited: terminator
	"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character.  For example: 'this '' was a quote'. Start postioned before the initial terminator."

	| out ch |
	out _ WriteStream on: (String new: 1000).
	self atEnd ifTrue: [^ ''].
	self next == terminator ifFalse: [self skip: -1].	"absorb initial terminator"
	[(ch _ self next) == nil] whileFalse: [
		(ch == terminator) ifTrue: [
			self peek == terminator ifTrue: [
				self next.  "skip doubled terminator"
			] ifFalse: [
				^ out contents  "terminator is not doubled; we're done!!"
			].
		].
		out nextPut: ch.
	].
	^ out contents! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:53'!
nextInto: aCollection
	"Read the next elements of the receiver into aCollection.
	Return aCollection or a partial copy if less than aCollection
	size elements have been read."
	^self next: aCollection size into: aCollection startingAt: 1.! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:59'!
nextInto: aCollection startingAt: startIndex
	"Read the next elements of the receiver into aCollection.
	Return aCollection or a partial copy if less than aCollection
	size elements have been read."
	^self next: (aCollection size - startIndex+1) into: aCollection startingAt: startIndex.! !

!PositionableStream methodsFor: 'accessing' stamp: 'bf 11/24/1998 13:35'!
nextLine
	"Answer next line (may be empty), or nil if at end"

	self atEnd ifTrue: [^nil].
	^self upTo: Character cr! !

!PositionableStream methodsFor: 'accessing' stamp: 'nk 3/18/2004 08:52'!
nextWordsInto: aBitmap 
	"Fill the word based buffer from my collection. 
	Stored on stream as Big Endian. Optimized for speed. 
	Read in BigEndian, then restoreEndianness."
	| blt pos source byteSize |
	collection class isBytes
		ifFalse: [^ self next: aBitmap size into: aBitmap startingAt: 1].

	byteSize := aBitmap byteSize.
	"is the test on collection basicSize \\ 4 necessary?"
	((self position bitAnd: 3) = 0 and: [ (collection basicSize bitAnd: 3) = 0])
		ifTrue: [source := collection.
			pos := self position.
			self skip: byteSize]
		ifFalse: ["forced to copy it into a buffer"
			source := self next: byteSize.
			pos := 0].

	"Now use BitBlt to copy the bytes to the bitmap."
	blt := (BitBlt current
				toForm: (Form new hackBits: aBitmap))
				sourceForm: (Form new hackBits: source).
	blt combinationRule: Form over. "store"
	blt sourceX: 0;
		 sourceY: pos // 4;
		 height: byteSize // 4;
		 width: 4.
	blt destX: 0;
		 destY: 0.
	blt copyBits.

	"And do whatever the bitmap needs to do to convert from big-endian order."
	aBitmap restoreEndianness.

	^ aBitmap 	"May be WordArray, ColorArray, etc"
! !

!PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'!
next: anInteger 
	"Answer the next anInteger elements of my collection. Must override 
	because default uses self contents species, which might involve a large 
	collection."

	| newArray |
	newArray _ collection species new: anInteger.
	1 to: anInteger do: [:index | newArray at: index put: self next].
	^newArray! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:58'!
next: n into: aCollection
	"Read n objects into the given collection.
	Return aCollection or a partial copy if less than
	n elements have been read."
	^self next: n into: aCollection startingAt: 1! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:54'!
next: n into: aCollection startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than
	n elements have been read."
	| obj |
	0 to: n-1 do:[:i|
		(obj _ self next) == nil ifTrue:[^aCollection copyFrom: 1 to: startIndex+i-1].
		aCollection at: startIndex+i put: obj].
	^aCollection! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 1/2/2000 15:32'!
next: anInteger putAll: aCollection
	"Store the next anInteger elements from the given collection."
	^self next: anInteger putAll: aCollection startingAt: 1! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 8/12/2003 16:56'!
next: anInteger putAll: aCollection startingAt: startIndex
	"Store the next anInteger elements from the given collection."
	(startIndex = 1 and:[anInteger = aCollection size])
		ifTrue:[^self nextPutAll: aCollection].
	^self nextPutAll: (aCollection copyFrom: startIndex to: startIndex+anInteger-1)! !

!PositionableStream methodsFor: 'accessing'!
originalContents
	"Answer the receiver's actual contents collection, NOT a copy.  1/29/96 sw"

	^ collection! !

!PositionableStream methodsFor: 'accessing'!
peek
	"Answer what would be returned if the message next were sent to the 
	receiver. If the receiver is at the end, answer nil."

	| nextObject |
	self atEnd ifTrue: [^nil].
	nextObject _ self next.
	position _ position - 1.
	^nextObject! !

!PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:02'!
peekBack
	"Return the element at the previous position, without changing position.  Use indirect messages in case self is a StandardFileStream."

	| element |
	element _ self back.
	self skip: 1.
	^ element! !

!PositionableStream methodsFor: 'accessing'!
peekFor: anObject 
	"Answer false and do not move over the next element if it is not equal to 
	the argument, anObject, or if the receiver is at the end. Answer true 
	and increment the position for accessing elements, if the next element is 
	equal to anObject."

	| nextObject |
	self atEnd ifTrue: [^false].
	nextObject _ self next.
	"peek for matching element"
	anObject = nextObject ifTrue: [^true].
	"gobble it if found"
	position _ position - 1.
	^false! !

!PositionableStream methodsFor: 'accessing' stamp: 'tk 7/18/1999 17:10'!
upToAll: aCollection
	"Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aCollection. If aCollection is not in the stream, answer the entire rest of the stream."

	| startPos endMatch result |
	startPos _ self position.
	(self match: aCollection) 
		ifTrue: [endMatch _ self position.
			self position: startPos.
			result _ self next: endMatch - startPos - aCollection size.
			self position: endMatch.
			^ result]
		ifFalse: [self position: startPos.
			^ self upToEnd]! !

!PositionableStream methodsFor: 'accessing' stamp: 'BG 2/19/2004 14:06'!
upToEnd
	"Answer a subcollection from the current access position through the last element of the receiver."

	| newStream |
	newStream _ WriteStream on: (collection species new: 100).
	[self atEnd] whileFalse: [ newStream nextPut: self next ].
	^ newStream contents! !

!PositionableStream methodsFor: 'accessing'!
upTo: anObject 
	"Answer a subcollection from the current access position to the 
	occurrence (if any, but not inclusive) of anObject in the receiver. If 
	anObject is not in the collection, answer the entire rest of the receiver."
	| newStream element |
	newStream _ WriteStream on: (collection species new: 100).
	[self atEnd or: [(element _ self next) = anObject]]
		whileFalse: [newStream nextPut: element].
	^newStream contents! !


!PositionableStream methodsFor: 'converting' stamp: 'tk 2/7/2000 11:08'!
asBinaryOrTextStream
	"Convert to a stream that can switch between bytes and characters"

	^ (RWBinaryOrTextStream with: self contentsOfEntireFile) reset! !

!PositionableStream methodsFor: 'converting' stamp: 'ar 1/2/2000 15:32'!
asZLibReadStream
	^ZLibReadStream on: collection from: position+1 to: readLimit! !


!PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:09'!
boolean
	"Answer the next boolean value from this (binary) stream."

	^ self next ~= 0
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:11'!
boolean: aBoolean
	"Store the given boolean value on this (binary) stream."

	self nextPut: (aBoolean ifTrue: [1] ifFalse: [0]).
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:43'!
int16
	"Answer the next signed, 16-bit integer from this (binary) stream."

	| n |
	n _ self next.
	n _ (n bitShift: 8) + (self next).
	n >= 16r8000 ifTrue: [n _ n - 16r10000].
	^ n
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:44'!
int16: anInteger
	"Store the given signed, 16-bit integer on this (binary) stream."

	| n |
	(anInteger < -16r8000) | (anInteger >= 16r8000)
		ifTrue: [self error: 'outside 16-bit integer range'].

	anInteger < 0
		ifTrue: [n _ 16r10000 + anInteger]
		ifFalse: [n _ anInteger].
	self nextPut: (n digitAt: 2).
	self nextPut: (n digitAt: 1).
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 15:15'!
int32
	"Answer the next signed, 32-bit integer from this (binary) stream."
	"Details: As a fast check for negative number, check the high bit of the first digit"

	| n firstDigit |
	n _ firstDigit _ self next.
	n _ (n bitShift: 8) + self next.
	n _ (n bitShift: 8) + self next.
	n _ (n bitShift: 8) + self next.
	firstDigit >= 128 ifTrue: [n _ -16r100000000 + n].  "decode negative 32-bit integer"
	^ n
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:46'!
int32: anInteger
	"Store the given signed, 32-bit integer on this (binary) stream."

	| n |
	(anInteger < -16r80000000) | (anInteger >= 16r80000000)
		ifTrue: [self error: 'outside 32-bit integer range'].

	anInteger < 0
		ifTrue: [n _ 16r100000000 + anInteger]
		ifFalse: [n _ anInteger].
	self nextPut: (n digitAt: 4).
	self nextPut: (n digitAt: 3).
	self nextPut: (n digitAt: 2).
	self nextPut: (n digitAt: 1).
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 07:35'!
string
	"Answer the next string from this (binary) stream."

	| size |
	size _ self uint16.
	^ (self next: size) asString
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 12:09'!
string: aString
	"Store the given string on this (binary) stream. The string must contain 65535 or fewer characters."

	aString size > 16rFFFF ifTrue: [self error: 'string too long for this format'].
	self uint16: aString size.
	self nextPutAll: aString asByteArray.
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'!
uint16
	"Answer the next unsigned, 16-bit integer from this (binary) stream."

	| n |
	n _ self next.
	n _ (n bitShift: 8) + (self next).
	^ n
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'!
uint16: anInteger
	"Store the given unsigned, 16-bit integer on this (binary) stream."

	(anInteger < 0) | (anInteger >= 16r10000)
		ifTrue: [self error: 'outside unsigned 16-bit integer range'].

	self nextPut: (anInteger digitAt: 2).
	self nextPut: (anInteger digitAt: 1).
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'!
uint24
	"Answer the next unsigned, 24-bit integer from this (binary) stream."

	| n |
	n _ self next.
	n _ (n bitShift: 8) + self next.
	n _ (n bitShift: 8) + self next.
	^ n
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'!
uint24: anInteger
	"Store the given unsigned, 24-bit integer on this (binary) stream."

	(anInteger < 0) | (anInteger >= 16r1000000)
		ifTrue: [self error: 'outside unsigned 24-bit integer range'].

	self nextPut: (anInteger digitAt: 3).
	self nextPut: (anInteger digitAt: 2).
	self nextPut: (anInteger digitAt: 1).
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'!
uint32
	"Answer the next unsigned, 32-bit integer from this (binary) stream."

	| n |
	n _ self next.
	n _ (n bitShift: 8) + self next.
	n _ (n bitShift: 8) + self next.
	n _ (n bitShift: 8) + self next.
	^ n
! !

!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:52'!
uint32: anInteger
	"Store the given unsigned, 32-bit integer on this (binary) stream."

	(anInteger < 0) | (anInteger >= 16r100000000)
		ifTrue: [self error: 'outside unsigned 32-bit integer range'].

	self nextPut: (anInteger digitAt: 4).
	self nextPut: (anInteger digitAt: 3).
	self nextPut: (anInteger digitAt: 2).
	self nextPut: (anInteger digitAt: 1).
! !


!PositionableStream methodsFor: 'fileIn/Out' stamp: 'ajh 1/18/2002 01:02'!
backChunk
	"Answer the contents of the receiver back to the previous terminator character.  Doubled terminators indicate an embedded terminator character."
	| terminator out ch |
	terminator _ $!!.
	out _ WriteStream on: (String new: 1000).
	[(ch _ self back) == nil] whileFalse: [
		(ch == terminator) ifTrue: [
			self peekBack == terminator ifTrue: [
				self back.  "skip doubled terminator"
			] ifFalse: [
				^ out contents reversed  "we're done!!"
			].
		].
		out nextPut: ch.
	].
	^ out contents reversed! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'yo 8/7/2003 13:04'!
basicNextChunk
	"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character."
	| terminator out ch |
	terminator _ $!!.
	out _ WriteStream on: (String new: 1000).
	self skipSeparators.
	[(ch _ self next) == nil] whileFalse: [
		(ch == terminator) ifTrue: [
			self peek == terminator ifTrue: [
				self next.  "skip doubled terminator"
			] ifFalse: [
				^ out contents  "terminator is not doubled; we're done!!"
			].
		].
		out nextPut: ch.
	].
	^ out contents! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:40'!
checkForPreamble: chunk
	((chunk beginsWith: '"Change Set:') and: [ChangeSet current preambleString == nil])
		ifTrue: [ChangeSet current preambleString: chunk].
	((chunk beginsWith: '"Postscript:') and: [ChangeSet current postscriptString == nil])
		ifTrue: [ChangeSet current postscriptString: chunk].
							
! !

!PositionableStream methodsFor: 'fileIn/Out'!
command: aString
	"Overridden by HtmlFileStream to append commands directly without translation.  4/5/96 tk"
	"We ignore any HTML commands.  Do nothing"! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 2/3/98 14:44'!
copyMethodChunkFrom: aStream
	"Copy the next chunk from aStream (must be different from the receiver)."
	| chunk |
	chunk _ aStream nextChunkText.
	chunk runs values size = 1 "Optimize for unembellished text"
		ifTrue: [self nextChunkPut: chunk asString]
		ifFalse: [self nextChunkPutWithStyle: chunk]! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'yo 10/15/2003 19:02'!
copyMethodChunkFrom: aStream at: pos
	"Copy the next chunk from aStream (must be different from the receiver)."
	| chunk |
	aStream position: pos.
	chunk _ aStream nextChunkText.
	chunk runs values size = 1 "Optimize for unembellished text"
		ifTrue: [self nextChunkPut: chunk asString]
		ifFalse: [self nextChunkPutWithStyle: chunk]! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'ar 4/11/2006 14:29'!
copyPreamble: preamble from: aStream at: pos
	"Look for a changeStamp for this method by peeking backward.
	Write a method preamble, with that stamp if found."
	| terminator last50 stamp i |
	terminator := $!!.

	"Look back to find stamp in old preamble, such as...
	Polygon methodsFor: 'private' stamp: 'di 6/25/97 21:42' prior: 34957598!! "
	aStream position: pos.
		aStream backChunk.				"to beginning of method"
		last50 := aStream backChunk.	"to get preamble"
	aStream position: pos.

	stamp := String new.
	(i := last50 findLastOccuranceOfString: 'stamp:' startingAt: 1) > 0 ifTrue:
		[stamp := (last50 copyFrom: i+8 to: last50 size) copyUpTo: $'].

	"Write the new preamble, with old stamp if any."
	self cr; nextPut: terminator.
	self nextChunkPut: (String streamContents:
		[:strm |
		strm nextPutAll: preamble.
		stamp size > 0 ifTrue:
			[strm nextPutAll: ' stamp: '; print: stamp]]).
	self cr! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'ar 4/12/2005 17:34'!
decodeString: string andRuns: runsRaw

	| strm runLength runValues newString index |
	strm _ ReadStream on: runsRaw from: 1 to: runsRaw size.
	(strm peekFor: $( ) ifFalse: [^ nil].
	runLength _ OrderedCollection new.
	[strm skipSeparators.
	 strm peekFor: $)] whileFalse: 
		[runLength add: (Number readFrom: strm)].

	runValues _ OrderedCollection new.
	[strm atEnd not] whileTrue: 
		[runValues add: (Number readFrom: strm).
		strm next.].

	newString _ WideString new: string size.
	index _ 1.
	runLength with: runValues do: [:length :leadingChar |
		index to: index + length - 1 do: [:pos |
			newString at: pos put: (Character leadingChar: leadingChar code: (string at: pos) charCode).
		].
		index _ index + length.
	].

	^ newString.
! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'tk 12/13/97 13:36'!
decodeStyle: runsObjData version: styleVersion
	"Decode the runs array from the ReferenceStream it is stored in."
	"Verify that the class mentioned have the same inst vars as we have now"

	| structureInfo |
	styleVersion = RemoteString currentTextAttVersion ifTrue: [
		"Matches our classes, no need for checking"
		^ (ReferenceStream on: runsObjData) next].
	structureInfo _ RemoteString structureAt: styleVersion.	"or nil"
		"See SmartRefStream instVarInfo: for dfn"
	^ SmartRefStream read: runsObjData withClasses: structureInfo! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'mir 7/26/2000 13:28'!
fileIn
	"This is special for reading expressions from text that has been formatted 
	with exclamation delimitors. The expressions are read and passed to the 
	Compiler. Answer the result of compilation."

	^ self fileInAnnouncing: 'Reading ' , self name! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'NS 1/28/2004 11:22'!
fileInAnnouncing: announcement 
	"This is special for reading expressions from text that has been formatted 
	with exclamation delimitors. The expressions are read and passed to the 
	Compiler. Answer the result of compilation.  Put up a progress report with
     the given announcement as the title."

	| val chunk |
	announcement 
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: self size
		during: 
			[:bar | 
			[self atEnd] whileFalse: 
					[bar value: self position.
					self skipSeparators.
					
					[val := (self peekFor: $!!) 
								ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self]
								ifFalse: 
									[chunk := self nextChunk.
									self checkForPreamble: chunk.
									Compiler evaluate: chunk logged: true]] 
							on: InMidstOfFileinNotification
							do: [:ex | ex resume: true].
					self skipStyleChunk].
			self close].
	"Note:  The main purpose of this banner is to flush the changes file."
	SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'.
	self flag: #ThisMethodShouldNotBeThere.	"sd"
	Smalltalk forgetDoIts.
	^val! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'NS 1/28/2004 11:21'!
fileInFor: client announcing: announcement
	"This is special for reading expressions from text that has been formatted 
	with exclamation delimitors. The expressions are read and passed to the 
	Compiler. Answer the result of compilation.  Put up a progress report with
     the given announcement as the title.
	Does NOT handle preambles or postscripts specially."
	| val chunk |
	announcement displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
		[:bar |
		[self atEnd]
			whileFalse: 
				[bar value: self position.
				self skipSeparators.
				[ val _ (self peekFor: $!!) ifTrue: [
						(Compiler evaluate: self nextChunk for: client logged: false) scanFrom: self
					] ifFalse: [
						chunk _ self nextChunk.
						self checkForPreamble: chunk.
						Compiler evaluate: chunk for: client logged: true ].
				] on: InMidstOfFileinNotification
				  do: [ :ex | ex resume: true].
				self atEnd ifFalse: [ self skipStyleChunk ]].
		self close].
	"Note:  The main purpose of this banner is to flush the changes file."
	SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'.
	Smalltalk forgetDoIts.
	^ val! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'nk 7/30/2004 17:54'!
fileInSilentlyAnnouncing: announcement 
	"This is special for reading expressions from text that has been formatted 
	with exclamation delimitors. The expressions are read and passed to the 
	Compiler. Answer the result of compilation.  Put up a progress report with
     the given announcement as the title."

	| val chunk |
	[self atEnd] whileFalse: 
			[self skipSeparators.
			
			[val := (self peekFor: $!!) 
						ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self]
						ifFalse: 
							[chunk := self nextChunk.
							self checkForPreamble: chunk.
							Compiler evaluate: chunk logged: true]] 
					on: InMidstOfFileinNotification
					do: [:ex | ex resume: true].
			self skipStyleChunk].
	self close.
	"Note:  The main purpose of this banner is to flush the changes file."
	SmalltalkImage current  logChange: '----End fileIn of ' , self name , '----'.
	self flag: #ThisMethodShouldNotBeThere.	"sd"
	SystemNavigation new allBehaviorsDo: 
			[:cl | 
			cl
				removeSelectorSimply: #DoIt;
				removeSelectorSimply: #DoItIn:].
	^val! !

!PositionableStream methodsFor: 'fileIn/Out'!
header
	"If the stream requires a standard header, override this message.  See HtmlFileStream"! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'yo 8/13/2003 11:59'!
nextChunk
	"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character."
	| terminator out ch |
	terminator _ $!!.
	out _ WriteStream on: (String new: 1000).
	self skipSeparators.
	[(ch _ self next) == nil] whileFalse: [
		(ch == terminator) ifTrue: [
			self peek == terminator ifTrue: [
				self next.  "skip doubled terminator"
			] ifFalse: [
				^ self parseLangTagFor: out contents  "terminator is not doubled; we're done!!"
			].
		].
		out nextPut: ch.
	].
	^ self parseLangTagFor: out contents.
! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'sumim 11/20/2003 18:13'!
nextChunkText
	"Deliver the next chunk as a Text.  Decode the following ]style[ chunk if present.  Position at start of next real chunk."
	| string runsRaw strm runs peek pos |
	"Read the plain text"
	string _ self nextChunk.
	
	"Test for ]style[ tag"
	pos _ self position.
	peek _ self skipSeparatorsAndPeekNext.
	peek = $] ifFalse: [self position: pos. ^ string asText].  "no tag"
	(self upTo: $[) = ']style' ifFalse: [self position: pos. ^ string asText].  "different tag"

	"Read and decode the style chunk"
	runsRaw _ self basicNextChunk.	"style encoding"
	strm _ ReadStream on: runsRaw from: 1 to: runsRaw size.
	runs _ RunArray scanFrom: strm.

	^ Text basicNew setString: string setRunsChecking: runs.
! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'sumim 11/20/2003 18:11'!
parseLangTagFor: aString

	| string peek runsRaw pos |
	string _ aString.
	"Test for ]lang[ tag"
	pos _ self position.
	peek _ self skipSeparatorsAndPeekNext.
	peek = $] ifFalse: [self position: pos. ^ string].  "no tag"
	(self upTo: $[) = ']lang' ifTrue: [
		runsRaw _ self basicNextChunk.
		string _ self decodeString: aString andRuns: runsRaw
	] ifFalse: [
		self position: pos
	].
	^ string.
! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 6/13/97 12:00'!
skipSeparators
	[self atEnd]
		whileFalse:
		[self next isSeparator ifFalse: [^ self position: self position-1]]! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 1/13/98 16:08'!
skipSeparatorsAndPeekNext
	"A special function to make nextChunk fast"
	| peek |
	[self atEnd]
		whileFalse:
		[(peek _ self next) isSeparator
			ifFalse: [self position: self position-1. ^ peek]]! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'tk 12/29/97 12:37'!
skipStyleChunk
	"Get to the start of the next chunk that is not a style for the previous chunk"

	| pos |
	pos _ self position.
	self skipSeparators.
	self peek == $] 
		ifTrue: [(self upTo: $[) = ']text' 	"old -- no longer needed"
				"now positioned past the open bracket"
			ifFalse: [self nextChunk]]	"absorb ]style[ and its whole chunk"
				
		ifFalse: [self position: pos]	"leave untouched"
! !

!PositionableStream methodsFor: 'fileIn/Out'!
trailer
	"If the stream requires a standard trailer, override this message.  See HtmlFileStream"! !

!PositionableStream methodsFor: 'fileIn/Out'!
unCommand
	"If this read stream is at a <, then skip up to just after the next >.  For removing html commands."
	| char |
	[self peek = $<] whileTrue: ["begin a block"
		[self atEnd == false and: [self next ~= $>]] whileTrue.
		"absorb characters"
		].
 ! !

!PositionableStream methodsFor: 'fileIn/Out'!
verbatim: aString
	"Do not attempt to translate the characters.  Use to override nextPutAll:"
	^ self nextPutAll: aString! !


!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextInt32
	"Read a 32-bit signed integer from the next 4 bytes"
	| s |
	s _ 0.
	1 to: 4 do: [:i | s _ (s bitShift: 8) + self next].
	(s bitAnd: 16r80000000) = 0
		ifTrue: [^ s]
		ifFalse: [^ -1 - s bitInvert32]! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextInt32Put: int32
	"Write a signed integer to the next 4 bytes"
	| pos |
	pos _ int32 < 0
		ifTrue: [(0-int32) bitInvert32 + 1]
		ifFalse: [int32].
	1 to: 4 do: [:i | self nextPut: (pos digitAt: 5-i)].
	^ int32! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'jm 4/9/98 21:36'!
nextLittleEndianNumber: n 
	"Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant."

	| bytes s |
	bytes _ self next: n.
	s _ 0.
	n to: 1 by: -1 do: [:i | s _ (s bitShift: 8) bitOr: (bytes at: i)].
	^ s
! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'di 12/6/1999 10:13'!
nextLittleEndianNumber: n put: value
	"Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant."
	| bytes |
	bytes _ ByteArray new: n.
	1 to: n do: [: i | bytes at: i put: (value digitAt: i)].
	self nextPutAll: bytes! !

!PositionableStream methodsFor: 'nonhomogeneous accessing'!
nextNumber: n 
	"Answer the next n bytes as a positive Integer or LargePositiveInteger."
	| s |
	s _ 0.
	1 to: n do: 
		[:i | s _ (s bitShift: 8) bitOr: self next asInteger].
	^ s normalize! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextNumber: n put: v 
	"Append to the receiver the argument, v, which is a positive 
	SmallInteger or a LargePositiveInteger, as the next n bytes.
	Possibly pad with leading zeros."

	1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)].
	^ v
! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 3/1/2005 06:03'!
nextString
	"Read a string from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first four bytes encode the length.  I expect to be in ascii mode when called (caller puts back to binary)."

	| length aByteArray |

	"read the length in binary mode"
	self binary.
	length _ self next.		"first byte."
	length >= 192 ifTrue: [length _ length - 192.
		1 to: 3 do: [:ii | length _ length * 256 + self next]].
	aByteArray _ ByteArray new: length.

	self nextInto: aByteArray.
	^aByteArray asString.
! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'tk 6/8/1998 21:01'!
nextStringOld
	"Read a string from the receiver. The first byte is the length of the 
	string, unless it is greater than 192, in which case the first *two* bytes 
	encode the length.  Max size 16K. "

	| aString length |
	length _ self next.		"first byte."
	length >= 192 ifTrue: [length _ (length - 192) * 256 + self next].
	aString _ String new: length.
	1 to: length do: [:ii | aString at: ii put: self next asCharacter].
	^aString! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 4/16/2001 17:56'!
nextStringPut: s 
	"Append the string, s, to the receiver.  Only used by DataStream.  Max size of 64*256*256*256."

	| length |
	(length _ s size) < 192
		ifTrue: [self nextPut: length]
		ifFalse: 
			[self nextPut: (length digitAt: 4)+192.
			self nextPut: (length digitAt: 3).
			self nextPut: (length digitAt: 2).
			self nextPut: (length digitAt: 1)].
	self nextPutAll: s asByteArray.
	^s! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextWord
	"Answer the next two bytes from the receiver as an Integer."

	| high low |
	high _ self next.
		high==nil ifTrue: [^false].
	low _ self next.
		low==nil ifTrue: [^false].
	^(high asInteger bitShift: 8) + low asInteger! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextWordPut: aWord 
	"Append to the receiver an Integer as the next two bytes."

	self nextPut: ((aWord bitShift: -8) bitAnd: 255).
	self nextPut: (aWord bitAnd: 255).
	^aWord! !


!PositionableStream methodsFor: 'positioning' stamp: 'tk 3/22/2002 19:33'!
backUpTo: subCollection
	"Back up the position to he subCollection.  Position must be somewhere within the stream initially.  Leave it just after it.  Return true if succeeded.  No wildcards, and case does matter."
"Example:
	| strm | strm _ ReadStream on: 'zabc abdc'.
	strm setToEnd; backUpTo: 'abc'; position 
"

	| pattern startMatch |
	pattern _ ReadStream on: subCollection reversed.
	startMatch _ nil.
	[pattern atEnd] whileFalse: 
		[self position = 0 ifTrue: [^ false].
		self skip: -1.
		(self next) = (pattern next) 
			ifTrue: [pattern position = 1 ifTrue: [startMatch _ self position]]
			ifFalse: [pattern position: 0.
					startMatch ifNotNil: [
						self position: startMatch-1.
						startMatch _ nil]].
		self skip: -1].
	self position: startMatch.
	^ true

! !

!PositionableStream methodsFor: 'positioning' stamp: 'hmm 10/22/1999 21:18'!
match: subCollection
	"Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found.  No wildcards, and case does matter."

	| pattern startMatch |
	pattern _ ReadStream on: subCollection.
	startMatch _ nil.
	[pattern atEnd] whileFalse: 
		[self atEnd ifTrue: [^ false].
		(self next) = (pattern next) 
			ifTrue: [pattern position = 1 ifTrue: [startMatch _ self position]]
			ifFalse: [pattern position: 0.
					startMatch ifNotNil: [
						self position: startMatch.
						startMatch _ nil]]].
	^ true

! !

!PositionableStream methodsFor: 'positioning' stamp: 'di 5/25/1998 15:16'!
padToNextLongPut: char 
	"Make position be on long word boundary, writing the padding 
	character, char, if necessary."
	[self position \\ 4 = 0]
		whileFalse: [self nextPut: char]! !

!PositionableStream methodsFor: 'positioning' stamp: 'di 2/15/98 14:41'!
padTo: nBytes put: aCharacter 
	"Pad using the argument, aCharacter, to the next boundary of nBytes characters."
	| rem |
	rem _ nBytes - (self position \\ nBytes).
	rem = nBytes ifTrue: [^ 0].
	self next: rem put: aCharacter.! !

!PositionableStream methodsFor: 'positioning'!
position
	"Answer the current position of accessing the sequence of objects."

	^position! !

!PositionableStream methodsFor: 'positioning' stamp: 'mir 6/29/2004 17:35'!
positionOfSubCollection: subCollection
	"Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position.
	If no such match is found, answer 0."

	^self positionOfSubCollection: subCollection ifAbsent: [0]! !

!PositionableStream methodsFor: 'positioning' stamp: 'mir 7/5/2005 08:32'!
positionOfSubCollection: subCollection ifAbsent: exceptionBlock
	"Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position.
	If no such match is found, answer the result of evaluating argument, exceptionBlock."

	| pattern startPosition currentPosition |
	pattern _ ReadStream on: subCollection.
	startPosition := self position.
	[pattern atEnd] whileFalse: 
		[self atEnd ifTrue: [^exceptionBlock value].
		self next = pattern next
			ifFalse: [
				self position: self position-pattern position+1.
				pattern reset]].
	currentPosition := self position.
	self position: startPosition.
	^pattern atEnd
		ifTrue: [currentPosition + 1 - subCollection size]
		ifFalse: [exceptionBlock value]! !

!PositionableStream methodsFor: 'positioning'!
position: anInteger 
	"Set the current position for accessing the objects to be anInteger, as long 
	as anInteger is within the bounds of the receiver's contents. If it is not, 
	create an error notification."

	anInteger >= 0 & (anInteger <= readLimit)
		ifTrue: [position _ anInteger]
		ifFalse: [self positionError]! !

!PositionableStream methodsFor: 'positioning' stamp: 'mir 5/14/2003 18:45'!
pushBack: aString
	"Compatibility with SocketStreams"
	self skip: aString size negated! !

!PositionableStream methodsFor: 'positioning'!
reset
	"Set the receiver's position to the beginning of the sequence of objects."

	position _ 0! !

!PositionableStream methodsFor: 'positioning' stamp: 'sw 3/10/98 13:55'!
resetContents
	"Set the position and limits to 0."

	position _ 0.
	readLimit _ 0! !

!PositionableStream methodsFor: 'positioning'!
setToEnd
	"Set the position of the receiver to the end of the sequence of objects."

	position _ readLimit! !

!PositionableStream methodsFor: 'positioning'!
skipTo: anObject 
	"Set the access position of the receiver to be past the next occurrence of 
	anObject. Answer whether anObject is found."

	[self atEnd]
		whileFalse: [self next = anObject ifTrue: [^true]].
	^false! !

!PositionableStream methodsFor: 'positioning'!
skip: anInteger 
	"Set the receiver's position to be the current position+anInteger. A 
	subclass might choose to be more helpful and select the minimum of the 
	receiver's size and position+anInteger, or the maximum of 1 and 
	position+anInteger for the repositioning."

	self position: position + anInteger! !

!PositionableStream methodsFor: 'positioning' stamp: 'tak 8/5/2005 10:34'!
untilEndWithFork: aBlock displayingProgress: aString 
	| sem done result |
	sem := Semaphore new.
	done := false.
	[[result := aBlock value]
		ensure: [done := true.
			sem signal]] fork.
	self
		untilEnd: [done
				ifTrue: [^ result].
			(Delay forSeconds: 0.2) wait]
		displayingProgress: aString.
	sem wait.
	^ result! !


!PositionableStream methodsFor: 'testing'!
atEnd
	"Primitive. Answer whether the receiver can access any more objects.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 67>
	^position >= readLimit! !

!PositionableStream methodsFor: 'testing' stamp: 'ar 1/2/2000 17:24'!
isBinary
	"Return true if the receiver is a binary byte stream"
	^collection class == ByteArray! !

!PositionableStream methodsFor: 'testing'!
isEmpty
	"Answer whether the receiver's contents has no elements."

	^position = 0! !


!PositionableStream methodsFor: '*packageinfo-base' stamp: 'nk 6/17/2003 07:45'!
untilEnd: aBlock displayingProgress: aString
	aString
		displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
			[:bar |
			[self atEnd] whileFalse:
				[bar value: self position.
				aBlock value]].! !


!PositionableStream methodsFor: 'private'!
on: aCollection

	collection _ aCollection.
	readLimit _ aCollection size.
	position _ 0.
	self reset! !

!PositionableStream methodsFor: 'private'!
positionError
	"Since I am not necessarily writable, it is up to my subclasses to override 
	position: if expanding the collection is preferrable to giving this error."

	self error: 'Attempt to set the position of a PositionableStream out of bounds'! !

!PositionableStream methodsFor: 'private'!
setFrom: newStart to: newStop

	position _ newStart - 1.
	readLimit _ newStop! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PositionableStream class
	instanceVariableNames: ''!

!PositionableStream class methodsFor: 'instance creation'!
on: aCollection 
	"Answer an instance of me, streaming over the elements of aCollection."

	^self basicNew on: aCollection! !

!PositionableStream class methodsFor: 'instance creation'!
on: aCollection from: firstIndex to: lastIndex 
	"Answer an instance of me, streaming over the elements of aCollection 
	starting with the element at firstIndex and ending with the one at 
	lastIndex."

	^self basicNew on: (aCollection copyFrom: firstIndex to: lastIndex)! !
Canvas subclass: #PostscriptCanvas
	instanceVariableNames: 'origin clipRect currentColor shadowColor currentFont morphLevel gstateStack fontMap usedFonts psBounds topLevelMorph initialScale savedMorphExtent currentTransformation printSpecs pages'
	classVariableNames: 'FontMap'
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Canvases'!
!PostscriptCanvas commentStamp: '<historical>' prior: 0!
I am a canvas that converts Morphic drawing messages into Postscript.  The canvas itself does not actually generate the Postscript code, but rather sends messages corresponding 1:1 to the Postscript imaging model to its target (default: PostscriptEncoder), which has the job of generating actual drawing commands.

PostscriptCharacterScanner and PostscriptDummyWarp are helper classes that simulate effects currently implemented via BitBlt-specific mechanisms during Postscript generation.  They should be going away as Morphic becomes fully device independent.

!


!PostscriptCanvas methodsFor: 'accessing' stamp: 'mpw 8/3/1930 07:36'!
clipRect
	^clipRect.
! !

!PostscriptCanvas methodsFor: 'accessing' stamp: 'mpw 8/6/2000 13:36'!
contentsOfArea: aRectangle into: aForm
	"not supported for PS canvas"
! !

!PostscriptCanvas methodsFor: 'accessing' stamp: 'nk 4/1/2004 19:08'!
isShadowDrawing
	^shadowColor notNil! !

!PostscriptCanvas methodsFor: 'accessing' stamp: 'mpw 8/3/1930 07:35'!
origin
	^origin.
! !

!PostscriptCanvas methodsFor: 'accessing' stamp: 'nk 4/1/2004 19:06'!
shadowColor
	^shadowColor! !

!PostscriptCanvas methodsFor: 'accessing' stamp: 'nk 4/1/2004 19:02'!
shadowColor: aColor
	shadowColor _ aColor.! !


!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'mpw 9/13/1999 20:57'!
aaLevel:newLevel
	"ignore "! !

!PostscriptCanvas methodsFor: 'balloon compatibility'!
asBalloonCanvas
     ^self.! !

!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 12/28/2003 17:42'!
deferred: ignored! !

!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 4/1/2004 20:34'!
drawGeneralBezierShape: shapeArray color: color borderWidth: borderWidth borderColor: borderColor 
	"shapeArray is an array of: 
	arrays of points, each of which must have 
	a multiple of 3 points in it. 
	This method tries to sort the provided triplets so that curves that 
	start and end at the same point are together."
	| where triplets groups g2 fillC |
	fillC := self shadowColor
				ifNil: [color].
	shapeArray isEmpty
		ifTrue: [^ self].
	where := nil.
	groups := OrderedCollection new.
	triplets := OrderedCollection new.
	shapeArray
		do: [:arr | arr
				groupsOf: 3
				atATimeDo: [:bez | 
					| rounded | 
					rounded := bez roundTo: 0.001.
					(where isNil
							or: [where = rounded first])
						ifFalse: [groups addLast: triplets.
							triplets := OrderedCollection new].
					triplets addLast: rounded.
					where := rounded last]].
	groups addLast: triplets.
	triplets := OrderedCollection new.
	"now try to merge stray groups"
	groups copy
		do: [:g1 | g1 first first = g1 last last
				ifFalse: ["not closed"
					g2 := groups
								detect: [:g | g ~~ g1
										and: [g1 last last = g first first]]
								ifNone: [].
					g2
						ifNotNil: [groups remove: g2.
							groups add: g2 after: g1]]].
	groups
		do: [:g | triplets addAll: g].
	where := nil.
	self
		definePathProcIn: [ :cvs |
			triplets do: [:shape | 
					where ~= shape first
						ifTrue: [where
								ifNotNil: [cvs closepath].
							cvs moveto: shape first].
					where := cvs outlineQuadraticBezierShape: shape]]
		during: [ :cvs |
			cvs clip.
			cvs setLinewidth: borderWidth "*2";
				 fill: fillC andStroke: borderColor]! !

!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 4/1/2004 19:14'!
drawOval: r color: c borderWidth: borderWidth borderColor: borderColor
	| fillC |
	fillC _ self shadowColor ifNil:[c].
	^ self fillOval: r color: fillC borderWidth: borderWidth borderColor: borderColor
	

		
! !

!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 4/1/2004 19:16'!
drawRectangle: r color: color borderWidth: borderWidth borderColor: borderColor

	| fillC |
	fillC := self shadowColor
				ifNil: [color].
	^ self
		frameAndFillRectangle: r
		fillColor: fillC
		borderWidth: borderWidth
		borderColor: borderColor! !

!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'RAA 9/20/2000 16:16'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self flag: #bob.		"need to fix this"

	"^aFillStyle 
		displayOnPort: (port clippedBy: aRectangle) 
		at: aRectangle origin - origin"
! !

!PostscriptCanvas methodsFor: 'balloon compatibility'!
setOrigin: aPoint clipRect: aRectangle
	self comment:'new origin: ' with:aPoint.
	target rectclip:aRectangle.
	self translate:aPoint - origin.

"	self grestore; gsave.

	self write:aRectangle.
	target print:' textclip'; cr.
	target print:'% new offset '.
	target write:aPoint.
	target cr.
"	super setOrigin: aPoint clipRect: aRectangle.
! !

!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'mpw 8/4/1930 12:13'!
transformBy:aMatrix
	("aMatrix isPureTranslation" false) ifTrue:[
		target translate:aMatrix offset negated.
	] ifFalse:[
		target  concat:aMatrix.
	].
	^self.
! !

!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'mpw 9/13/1999 21:05'!
transformBy:aTransform during:aBlock
	^self transformBy:aTransform clippingTo: nil during:aBlock! !

!PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'mpw 8/4/1930 20:11'!
warpFrom: sourceQuad toRect: innerRect
	"^PostscriptDummyWarp canvas:self."! !


!PostscriptCanvas methodsFor: 'drawing'!
fillColor:aColor
	self rect:clipRect; fill:aColor.
! !

!PostscriptCanvas methodsFor: 'drawing'!
line: pt1 to: pt2 brushForm: brush 
	" to do: set brushform "
	self moveto:pt1; lineto:pt2; stroke:currentColor.
 
! !

!PostscriptCanvas methodsFor: 'drawing'!
line: pt1 to: pt2 width: w color: c 
	self setLinewidth:w; moveto:pt1; lineto:pt2; stroke:c. 	
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'di 8/13/2000 12:27'!
paragraph: para bounds: bounds color: c 
	| displayablePara |
	self comment:'paragraph with bounds: ' with:bounds.
	displayablePara _ para asParagraphForPostscript.
	self preserveStateDuring:
		[:inner |
		displayablePara displayOn: inner
			using: (PostscriptCharacterScanner
					scannerWithCanvas: self paragraph: displayablePara bounds: bounds)
			at: bounds topLeft]
! !


!PostscriptCanvas methodsFor: 'drawing-general' stamp: 'mpw 8/10/1930 05:23'!
draw: anObject
	^anObject drawPostscriptOn: self! !

!PostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:47'!
fullDraw: aMorph 
	self comment: 'start morph: ' with: aMorph.
	self comment: 'level: ' with: morphLevel.
	self comment: 'bounds: ' with: aMorph bounds.
	self comment: 'corner: ' with: aMorph bounds corner.
	morphLevel := morphLevel + 1.
	self setupGStateForMorph: aMorph.
	aMorph fullDrawPostscriptOn: self.
	self endGStateForMorph: aMorph.
	morphLevel := morphLevel - 1.
	self comment: 'end morph: ' with: aMorph.
	self comment: 'level: ' with: morphLevel.
! !

!PostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:00'!
fullDrawBookMorph:aBookMorph
	^aBookMorph fullDrawOn:self.
! !


!PostscriptCanvas methodsFor: 'drawing-images'!
stencil: stencilForm at: aPoint color: aColor
	target comment:' imagemask'.
! !


!PostscriptCanvas methodsFor: 'drawing-ovals' stamp: 'di 8/12/2000 19:45'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor 
	self preserveStateDuring:
		[:inner |
		inner oval: r;
		setLinewidth: borderWidth;
		fill: c andStroke: borderColor].

	

		
! !


!PostscriptCanvas methodsFor: 'drawing-polygons' stamp: 'nk 4/1/2004 19:15'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc 
	| fillC |
	fillC _ self shadowColor ifNil:[aColor].
	self
		preserveStateDuring: [:pc | pc
			 outlinePolygon: vertices;
				 setLinewidth: bw;
				
				fill: fillC
				andStroke: ((bc isKindOf: Symbol)
						ifTrue: [Color gray]
						ifFalse: [bc])]! !


!PostscriptCanvas methodsFor: 'drawing-rectangles'!
fillRectangle: r color: c
	self rect:r; fill:c.! !

!PostscriptCanvas methodsFor: 'drawing-rectangles' stamp: 'RAA 2/2/2001 09:54'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle."
	| pattern |

	(aFillStyle isKindOf: InfiniteForm) ifTrue: [
		^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	].

	aFillStyle isSolidFill ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor].

	"We have a very special case for filling with infinite forms"
	(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
		pattern _ aFillStyle form.
		(aFillStyle direction = (pattern width @ 0) 
			and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
				"Can use an InfiniteForm"
				^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
	].

	"Use a BalloonCanvas instead PROBABLY won't work here"
	"self balloonFillRectangle: aRectangle fillStyle: aFillStyle."

	^self fillRectangle: aRectangle color: aFillStyle asColor! !

!PostscriptCanvas methodsFor: 'drawing-rectangles' stamp: 'nk 12/29/2003 20:10'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor 
	"since postscript strokes on the line and squeak strokes inside, we need 
	to adjust inwards"
	self
		preserveStateDuring: [:pc | pc
				
				rect: (r insetBy: borderWidth / 2);
				 setLinewidth: borderWidth;
				 fill: fillColor andStroke: borderColor]! !

!PostscriptCanvas methodsFor: 'drawing-rectangles' stamp: 'nk 12/29/2003 16:27'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor 
	self
		preserveStateDuring: [:pc | 
			target newpath.
			pc setLinewidth: 0.
			pc outlinePolygon: {r origin. r topRight. r topRight + (borderWidth negated @ borderWidth). r origin + (borderWidth @ borderWidth). r bottomLeft + (borderWidth @ borderWidth negated). r bottomLeft. r origin};
				 fill: topLeftColor andStroke: topLeftColor.
			target newpath.
			pc outlinePolygon: {r topRight. r bottomRight. r bottomLeft. r bottomLeft + (borderWidth @ borderWidth negated). r bottomRight - (borderWidth @ borderWidth). r topRight + (borderWidth negated @ borderWidth). r topRight};
				 fill: bottomRightColor andStroke: bottomRightColor]! !

!PostscriptCanvas methodsFor: 'drawing-rectangles'!
frameRectangle: r width: w color: c 
	self rect:r; stroke:c.

! !


!PostscriptCanvas methodsFor: 'drawing-support' stamp: 'mpw 6/22/1930 22:37'!
clipBy: aRectangle during: aBlock
	^self translateBy: 0@0 clippingTo: aRectangle during: aBlock.
! !

!PostscriptCanvas methodsFor: 'drawing-support' stamp: 'nk 4/1/2004 20:46'!
definePathProcIn: pathBlock during: duringBlock 
	"Bracket the output of pathBlock (which is passed the receiver) in 
	gsave 
		newpath 
			<pathBlock> 
		closepath 
		<duringBlock> 
	grestore 
	"
	| retval |
	self
		preserveStateDuring: [:tgt | 
			self comment: 'begin pathProc path block'.
			target newpath.
			pathBlock value: tgt.
			target closepath.
			self comment: 'begin pathProc during block'.
			retval := duringBlock value: tgt.
			self comment: 'end pathProc'].
	^ retval! !

!PostscriptCanvas methodsFor: 'drawing-support' stamp: 'nk 4/1/2004 19:52'!
preserveStateDuring: aBlock
	| retval saveClip saveTransform |
	target preserveStateDuring: [ :innerTarget |
		saveClip _ clipRect.
		saveTransform _ currentTransformation.
		gstateStack addLast: currentFont.
		gstateStack addLast: currentColor.
		gstateStack addLast: shadowColor.
		retval _ aBlock value: self.
		shadowColor _ gstateStack removeLast.
		currentColor _ gstateStack removeLast.
		currentFont _ gstateStack removeLast.
		clipRect _ saveClip.
		currentTransformation _ saveTransform.
	].
	^ retval
! !

!PostscriptCanvas methodsFor: 'drawing-support' stamp: 'nk 4/1/2004 19:48'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize 
	| retval oldShadow |
	oldShadow := shadowColor.
	self comment: 'drawing clipped ' with: aClipRect.
	self comment: 'drawing transformed ' with: aDisplayTransform.
	self
		preserveStateDuring: [:inner | 
			currentTransformation
				ifNil: [currentTransformation := aDisplayTransform]
				ifNotNil: [currentTransformation := currentTransformation composedWithLocal: aDisplayTransform].
			aClipRect
				ifNotNil: [clipRect := aDisplayTransform
								globalBoundsToLocal: (clipRect intersect: aClipRect).
					inner rect: aClipRect;
						 clip].
			inner transformBy: aDisplayTransform.
			retval := aBlock value: inner].
	self comment: 'end of drawing clipped ' with: aClipRect.
	shadowColor := oldShadow.
	^ retval! !

!PostscriptCanvas methodsFor: 'drawing-support' stamp: 'nk 4/1/2004 19:41'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."

	| result oldShadow |
	oldShadow := shadowColor.
	self translate: delta.
	result _ aBlock value: self.
	self translate: delta negated.
	shadowColor := oldShadow.
	^ result
! !


!PostscriptCanvas methodsFor: 'drawing-text' stamp: 'nk 4/1/2004 19:28'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c 
	| fillC oldC |
	fillC := self shadowColor
		ifNil: [c].
	self setFont: (fontOrNil
				ifNil: [self defaultFont]).
	self comment: ' text color: ' , c printString.
	oldC := currentColor.
	self setColor: fillC.
	self comment: ' boundsrect origin ' , boundsRect origin printString.
	self comment: '  origin ' , origin printString.
	self moveto: boundsRect origin.
	target print: ' (';
		 print: (s asString copyFrom: firstIndex to: lastIndex) asPostscript;
		 print: ') show';
		 cr.
	self setColor: oldC.! !

!PostscriptCanvas methodsFor: 'drawing-text' stamp: 'nk 12/30/2003 17:50'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c background: b
	target preserveStateDuring: [ :t | self fillRectangle: boundsRect color: b ].
	self drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c ! !


!PostscriptCanvas methodsFor: 'initialization' stamp: 'nk 4/1/2004 19:09'!
reset
	super reset.
	origin := 0 @ 0.				"origin of the top-left corner of this canvas"
	clipRect := 0 @ 0 corner: 10000 @ 10000.		"default clipping rectangle"
	currentTransformation := nil.
	morphLevel := 0.
	pages := 0.
	gstateStack := OrderedCollection new.
	usedFonts := Dictionary new.
	initialScale := 1.0.
	shadowColor := nil.
	currentColor := nil! !


!PostscriptCanvas methodsFor: 'morph drawing' stamp: 'mir 4/13/2005 17:09'!
writeTrailer: somePages 
	target
		print: '%%Trailer';
		cr.
	usedFonts isEmpty 
		ifFalse: 
			[target print: '%%DocumentFonts:'.
			usedFonts values asSet do: 
					[:f | 
					target
						space;
						print: f].
			target cr].
	target print:'%%Pages: '; write: somePages; cr.
	target
		print: '%%EOF';
		cr! !


!PostscriptCanvas methodsFor: 'other' stamp: 'mpw 8/4/1930 12:07'!
translateBy: delta clippingTo: aRect during: aBlock
	self comment:'translateBy: ' with:delta.
	^self transformBy:(MatrixTransform2x3 withOffset:delta) clippingTo:aRect during:aBlock.

! !


!PostscriptCanvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:08'!
canBlendAlpha
	^false! !

!PostscriptCanvas methodsFor: 'testing' stamp: 'di 8/12/2000 15:04'!
doesRoundedCorners 

	^ false! !

!PostscriptCanvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:09'!
isPostscriptCanvas
	^true! !


!PostscriptCanvas methodsFor: 'private' stamp: 'mpw 8/7/2000 09:09'!
bounds:newBounds
	psBounds _ newBounds.
! !

!PostscriptCanvas methodsFor: 'private'!
clip	
	^target clip.
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'mpw 8/3/1930 08:39'!
closepath
	^target closepath.


              ! !

!PostscriptCanvas methodsFor: 'private'!
comment:aString
	target comment:aString.
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 12/29/2003 09:51'!
comment: aString with: anObject 
	target comment:aString with:anObject.
	! !

!PostscriptCanvas methodsFor: 'private' stamp: 'sw 12/6/1999 13:10'!
defaultFont
	^ TextStyle defaultFont! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 15:34'!
defineFont: aFont

	| psNameFor alreadyRemapped |

	(usedFonts includesKey: aFont) ifFalse:[
		psNameFor _ self postscriptFontNameForFont: aFont.
		alreadyRemapped _ usedFonts includes: psNameFor.
		usedFonts at: aFont put: psNameFor.
		" here: define as Type-3 unless we think its available "
		" or, just remap"

		" I had some problems if same font remapped twice"
		alreadyRemapped ifFalse: [target remapFontForSqueak: psNameFor].
	].! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 4/1/2004 20:36'!
drawGradient: fillColor 
	self comment: 'not-solid fill ' with: fillColor.
	self comment: ' origin ' with: fillColor origin.
	self comment: ' direction ' with: fillColor direction.
	self fill: fillColor asColor! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:54'!
drawPage:aMorph
	self fullDrawMorph:aMorph.
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:18'!
drawPages:collectionOfPages
	collectionOfPages do:[ :page |
		pages _ pages + 1.
		target print:'%%Page: '; write:pages; space; write:pages; cr.
		self drawPage:page.
	].
	morphLevel = 0 ifTrue: [ self writeTrailer: pages ].! !

!PostscriptCanvas methodsFor: 'private' stamp: 'di 8/12/2000 09:42'!
drawPostscriptContext: subCanvas
	| contents |
	(contents _ subCanvas contents) ifNil: [^ self].
	^ target comment: ' sub-canvas start';
		preserveStateDuring: [:inner | inner print: contents];
		comment: ' sub-canvas stop'.	

! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:53'!
endGStateForMorph: aMorph 

	morphLevel == 1
		ifTrue: [ target showpage; print: 'grestore'; cr ]! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 12/28/2003 21:08'!
fill: fillColor
	fillColor isSolidFill
		ifTrue: [self paint: fillColor asColor operation: #eofill]
		ifFalse: [self preserveStateDuring: [:inner | inner clip; drawGradient: fillColor]]! !

!PostscriptCanvas methodsFor: 'private' stamp: 'di 8/12/2000 09:44'!
fill: fillColor andStroke: strokeColor
	self preserveStateDuring: [:inner | inner fill: fillColor];
		stroke: strokeColor.
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'di 8/12/2000 10:06'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule 
	self preserveStateDuring:
		[:inner | inner translate: aPoint + self origin.
		target write: aForm]
! !

!PostscriptCanvas methodsFor: 'private'!
lineto:aPoint
	^target lineto:aPoint.


              ! !

!PostscriptCanvas methodsFor: 'private'!
moveto:aPoint
	^target moveto:aPoint.


              ! !

!PostscriptCanvas methodsFor: 'private' stamp: 'dgd 2/21/2003 23:06'!
outlinePolygon: vertices 
	target moveto: (vertices first).
	2 to: vertices size do: [:i | target lineto: (vertices at: i)].
	target closepath! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 22:29'!
outlineQuadraticBezierShape: vertices 
	| where |
	3
		to: vertices size
		by: 3
		do: [:i | 
			| v1 v2 v3 | 
			v1 := (vertices at: i - 2) roundTo: 0.001.
			v2 := (vertices at: i - 1) roundTo: 0.001.
			v3 := (vertices at: i) roundTo: 0.001.
			(v1 = v2
					or: [v2 = v3])
				ifTrue: [target lineto: v3]
				ifFalse: [target
						curvetoQuadratic: v3
						from: v1
						via: v2].
			where := v3].
	^where! !

!PostscriptCanvas methodsFor: 'private'!
oval:aPoint
	^target oval:aPoint.! !

!PostscriptCanvas methodsFor: 'private'!
paint:color operation:operation
	self setColor:color.
	currentColor isTransparent ifFalse:[target perform:operation] ifTrue:[target newpath].

              ! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 22:18'!
postscriptFontNameForFont: font

	^(self class postscriptFontInfoForFont: font) first
! !

!PostscriptCanvas methodsFor: 'private'!
printContentsOn: aStream 
	^ aStream nextPutAll: target contents! !

!PostscriptCanvas methodsFor: 'private'!
psSize
	^ target size! !

!PostscriptCanvas methodsFor: 'private'!
rect:aRect
	^target rect:aRect.
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'di 9/22/1999 08:16'!
resetContentRotated: rotateFlag
	target _ self class defaultTarget.
	self writeHeaderRotated: rotateFlag.
     ^self.! !

!PostscriptCanvas methodsFor: 'private'!
setColor: color 
     currentColor ~= color ifTrue:[
          target write:color asColor.
		currentColor _ color.
	].
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 3/25/2004 15:36'!
setFont:aFont

	| fInfo |

	aFont = currentFont ifTrue: [^self].
	currentFont _ aFont.
	self defineFont: aFont.
	fInfo _ self class postscriptFontInfoForFont: aFont.

	target 
		selectflippedfont: fInfo first
		size: (aFont pixelSize * fInfo second)
		ascent: aFont ascent.
! !

!PostscriptCanvas methodsFor: 'private'!
setLinewidth: width 
	target setLinewidth: width.
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:42'!
setupGStateForMorph: aMorph 

	morphLevel == 1
		ifTrue: [self writePageSetupFor: aMorph]! !

!PostscriptCanvas methodsFor: 'private' stamp: 'gm 2/24/2003 18:07'!
stroke: strokeColor 
	strokeColor ifNil: [^self].
	(strokeColor isKindOf: Symbol) 
		ifTrue: [^self paint: Color gray operation: #stroke	"punt"].
	strokeColor isSolidFill 
		ifTrue: [^self paint: strokeColor asColor operation: #stroke].
	self preserveStateDuring: 
			[:inner | 
			inner
				strokepath;
				fill: strokeColor]! !

!PostscriptCanvas methodsFor: 'private'!
strokepath
	^target strokepath.


              ! !

!PostscriptCanvas methodsFor: 'private' stamp: 'RAA 10/2/2000 20:20'!
text: s at:point font: fontOrNil color: c justified:justify parwidth:parwidth

	self flag: #bob.		"deprecated in favor of #textStyled......."







	self setFont:(fontOrNil ifNil:[self defaultFont]).
	self comment:' text color: ',c printString.
	self setColor:c.
	self comment:'  origin ',  origin printString.
     self moveto: point.
	target print:' (';
     	 print:s asPostscript; print:') '.
		justify ifTrue:[
			target write:parwidth; print:' jshow'; cr.
		] ifFalse:[
			target print:'show'.
		].
		target cr.
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 4/1/2004 19:28'!
text: s at: point font: fontOrNil color: c spacePad: pad 
	| fillC oldC |
	fillC := self shadowColor
				ifNil: [c].
	self
		setFont: (fontOrNil
				ifNil: [self defaultFont]).
	self comment: ' text color: ' , c printString.
	oldC := currentColor.
	self setColor: fillC.
	self comment: '  origin ' , origin printString.
	self moveto: point.
	target write: pad;
		 print: ' 0 32 (';
		 print: s asPostscript;
		 print: ') widthshow';
		 cr.
	self setColor: oldC.! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 4/1/2004 19:27'!
textStyled: s at: ignored0 font: ignored1 color: c justified: justify parwidth: parwidth 
	| fillC oldC |
	fillC := c.
	self shadowColor
		ifNotNilDo: [:sc | 
			self comment: ' shadow color: ' , sc printString.
			fillC := sc].
	self comment: ' text color: ' , c printString.
	oldC := currentColor.
	self setColor: fillC.
	self comment: '  origin ' , origin printString.
	"self moveto: point."
	"now done by sender"
	target print: ' (';
		 print: s asPostscript;
		 print: ') '.
	justify
		ifTrue: [target write: parwidth;
				 print: ' jshow';
				 cr]
		ifFalse: [target print: 'show'].
	target cr.
	self setColor: oldC.! !

!PostscriptCanvas methodsFor: 'private' stamp: 'mpw 9/14/1999 06:58'!
topLevelMorph
	^topLevelMorph
! !

!PostscriptCanvas methodsFor: 'private' stamp: 'mpw 9/14/1999 06:58'!
topLevelMorph:newMorph
	topLevelMorph _ newMorph.
! !

!PostscriptCanvas methodsFor: 'private'!
translate:aPoint
	^target translate:aPoint.


              ! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 20:24'!
writeGlobalSetup: rotateFlag 
	target print: '%%EndProlog';
		 cr.
	target print: '%%BeginSetup';
		 cr.
	target print: '% initialScale: ';
		 write: initialScale;
		 cr.
	target print: '% pageBBox: '; write: self pageBBox; cr.
	
	target print: '% pageOffset';
		 cr.
	target translate: self pageOffset.
	rotateFlag
		ifTrue: ["no translate needed for 0,0 = upper LH corner of page"
			target print: '90 rotate';
				 cr;
				 print: '0 0 translate';
				 cr]
		ifFalse: [target write: 0 @ topLevelMorph height * initialScale;
				 print: ' translate';
				 cr].
	target print: '% flip';
		 cr.
	target scale: initialScale @ initialScale negated;
		 print: ' [ {true setstrokeadjust} stopped ] pop';
		 cr.
	target print: '%%EndSetup';
		 cr! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 17:50'!
writeHeaderRotated: rotateFlag 
	self writePSIdentifierRotated: rotateFlag.
	self writeProcset.
	self writeGlobalSetup: rotateFlag.! !

!PostscriptCanvas methodsFor: 'private' stamp: 'di 9/22/1999 08:24'!
writePSIdentifierRotated: rotateFlag
	"NB: rotation not yet supported"

	target print:'%!!'; cr.! !

!PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:37'!
writePageSetupFor: aMorph 

	target print: '%%BeginPageSetup'; cr.
	target print: 'gsave'; cr.
	target translate: aMorph bounds origin negated.
	target print: '%%EndPageSetup';
		 cr! !

!PostscriptCanvas methodsFor: 'private' stamp: 'mpw 11/15/1999 08:57'!
writeProcset
	target print:'

%%BeginProcset: Squeak-Level2-Emulation
/level1 /languagelevel where { 
	pop  languagelevel 2 lt
} {true } ifelse def
level1
{
	/rectclip {
		4 2 roll moveto
		1 index 0 rlineto
		 0 exch rlineto
		neg 0 rlineto closepath
		clip newpath
	} bind def
	/setcolorspace { pop } bind def
	/makeDict {
		counttomark 2 idiv dup dict begin
		{  def } repeat
		currentdict end exch pop
	} bind def
	/defaultDict [ /MultipleDataSources  false makeDict def
	/image {
		dup type /dicttype eq {
			defaultDict begin
			begin
				Width
				Height
				BitsPerComponent
				ImageMatrix 
				/DataSource load MultipleDataSources { aload pop } if				MultipleDataSources
				Decode length 2 idiv
			end
			end
		} if
		colorimage 
		currentfile ( ) readstring pop pop
	} bind def

	/_imagemask /imagemask load def
	/imagemask {
		dup type /dicttype eq {
			begin
				Width
				Height
				Decode 0 get 1 eq
				ImageMatrix
				/DataSource load
			end
		} if
		_imagemask 
		currentfile ( ) readstring pop pop
	} bind def
	/transparentimage {
		pop image
	} bind def

} {
	/makeDict { >> } bind def
	/transparentimage {
	  gsave
	  32 dict begin
	  /tinteger exch def
	  /transparent 1 string def
	  transparent 0 tinteger put
	  /olddict exch def
	  olddict /DataSource get dup type /filetype ne {
	    olddict /DataSource 3 -1 roll 0 () /SubFileDecode filter put
	  } {
	    pop
	  } ifelse
	  /newdict olddict maxlength dict def
	  olddict newdict copy pop
	  /w newdict /Width get def
	  /str w string def
	  /substrlen 2 w log 2 log div floor exp cvi def
	  /substrs [
	  {
	     substrlen string
	     0 1 substrlen 1 sub {
	       1 index exch tinteger put
	     } for
	     /substrlen substrlen 2 idiv def
	     substrlen 0 eq {exit} if
	  } loop
	  ] def
	  /h newdict /Height get def
	  1 w div 1 h div matrix scale
	  olddict /ImageMatrix get exch matrix concatmatrix
	  matrix invertmatrix concat
	  newdict /Height 1 put
	  newdict /DataSource str put
	  /mat [w 0 0 h 0 0] def
	  newdict /ImageMatrix mat put
	  0 1 h 1 sub {
	    mat 5 3 -1 roll neg put
	    olddict /DataSource get str readstring pop pop
	    /tail str def
	    /x 0 def
	    {
	      tail transparent search dup /done exch not def
	      {exch pop exch pop} if
	      /w1 1 index length def
	      w1 0 ne {
	        newdict /DataSource 3 -1 roll put
	        newdict /Width w1 put
	        mat 4 x neg put
	        /x x w1 add def
	        newdict image
	        /tail tail w1 tail length w1 sub getinterval def
	      } if
	      done {exit} if
	      tail substrs {
	        anchorsearch {pop} if
	      } forall
	      /tail exch def
	      tail length 0 eq {exit} if
	      /x w tail length sub def
	    } loop
	  } for
	  end
	  grestore
	} bind def
} ifelse

%%EndProcset
%%BeginProcset: Squeak-Printing
/_showpageSqueak /showpage load def
/showpage { gsave _showpageSqueak grestore } bind def
/countspaces {
	[ exch { dup 32 ne { pop } if  } forall ] length 
} bind def
/jshow { 
	10 dict begin
	/width exch def
	/str exch def
	str length 0 gt {
		str dup length 1 sub get 32 eq { /str str dup length 1 sub 0 exch getinterval def } if
		/strw str stringwidth pop def
		/diffwidth width strw sub def
		/numspaces str countspaces def
		numspaces 0 eq { /numspaces 1 def } if
		/adjspace width strw sub numspaces div def
		/adjchar 0 def
		diffwidth 0 lt {
			/adjspace adjspace 0.2 mul def
			/adjchar diffwidth str length div 0.8 mul def
		} if
		adjspace 0 32 adjchar 0 str awidthshow

	} if
	end
} bind def

/copydict {
	dup length dict begin 
		 { 1 index /FID eq 2 index /UniqueID eq and {pop pop} {  def  } ifelse } forall
	currentdict end
} bind def
/getSymbolcharproc {
	1 dict begin 
		/charstring exch def 
	 [ 550 0 0 0 650 600 /setcachedevice cvx 50 100 /translate cvx  /pop cvx 
		1 dict begin /setbbox { pop pop pop } bind def currentdict end /begin cvx   

		gsave  /Symbol 600 selectfont 0 0 moveto charstring false charpath false upath grestore

	 /exec cvx /fill cvx /end cvx ] cvx bind 
	end
} bind def
/adjustFontForSqueak		% converts _ to left-arrow, ^to upArrow and tab -> 4 spaces
{ 
	gsave dup 1000 selectfont
	dup dup findfont copydict
	begin
	CharStrings 
	/CharStrings exch copydict
	dup /leftarrow (\254) getSymbolcharproc  put
	dup /uparrow (\255) getSymbolcharproc  put
	dup /tab [ /pop cvx ( ) stringwidth pop 6 mul 0 0 0 0 0  /setcachedevice cvx ] cvx bind  put
	def
	/Encoding Encoding dup length array copy 
	dup 94 /uparrow put
	dup 95 /leftarrow put
	dup 9 /tab put
	def
	currentdict end definefont pop pop
	grestore
} bind def

%%EndProcset
'.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptCanvas class
	instanceVariableNames: ''!

!PostscriptCanvas class methodsFor: 'configuring' stamp: 'mpw 9/18/1999 11:04'!
baseOffset
	^0@0.
! !

!PostscriptCanvas class methodsFor: 'configuring' stamp: 'RAA 2/1/2001 15:50'!
defaultCanvasType

	^Preferences postscriptStoredAsEPS ifTrue: [EPSCanvas] ifFalse: [DSCPostscriptCanvas]! !

!PostscriptCanvas class methodsFor: 'configuring' stamp: 'nk 12/29/2003 13:19'!
defaultExtension
	^ '.ps'! !

!PostscriptCanvas class methodsFor: 'configuring'!
defaultTarget
	^PostscriptEncoder stream.
! !

!PostscriptCanvas class methodsFor: 'configuring'!
filterSelector
	^#fullDrawPostscriptOn:.
! !


!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 22:32'!
convertFontName: aName
	"Break apart aName on case boundaries, inserting hyphens as needed."
	| lastCase |
	lastCase _ aName first isUppercase.
	^ String streamContents: [ :s |
		aName do: [ :c | | thisCase |
			thisCase _ c isUppercase.
			(thisCase and: [ lastCase not ]) ifTrue: [ s nextPut: $- ].
			lastCase _ thisCase.
			s nextPut: c ]]! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 22:20'!
fontMap
	"Answer the font mapping dictionary. Made into a class var so that it can be edited."
	^FontMap ifNil: [ self initializeFontMap. FontMap ].! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 3/25/2004 16:06'!
fontSampler
	"Produces a Postscript .eps file on disk, returns a Morph."
	"PostscriptCanvas fontSampler"
	"PostscriptCanvas fontSampler openInWorld"
	| morph file |
	morph _ Morph new
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		wrapDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		color: Color white.
	TextStyle actualTextStyles keysAndValuesDo: [ :styleName :style |
		{ style fontArray first. style fontArray last } do: [ :baseFont | | info |
			0 to: 2 do: [ :i | | font string string2 textMorph row |
				font _ baseFont emphasized: i.
				(i isZero or: [ font ~~ baseFont ]) ifTrue: [
					string _ font fontNameWithPointSize.
					row _ Morph new
						layoutPolicy: TableLayout new;
						listDirection: #topToBottom;
						hResizing: #shrinkWrap;
						vResizing: #shrinkWrap;
						cellSpacing: 20@0;
						color: Color white.
		
					textMorph _ TextMorph new hResizing: #spaceFill; backgroundColor: Color white; beAllFont: font; contentsAsIs: string.
					row addMorphBack: (textMorph imageForm asMorph).

					info _ self postscriptFontInfoForFont: font.
					string2 _ String streamContents: [ :stream |
						stream nextPutAll: info first; space; print: (font pixelSize * info second) rounded.
					].
					textMorph _ TextMorph new hResizing: #spaceFill; backgroundColor: Color white; beAllFont: font; contentsAsIs: string2.
					row addMorphBack: textMorph.
					
					morph addMorphBack: row.
				]
			]
		]
	].
	morph bounds: World bounds.
	morph layoutChanged; fullBounds.
	file _ (FileDirectory default newFileNamed: 'PSFontSampler.eps').
	Cursor wait showWhile: [ 
		file nextPutAll: (EPSCanvas morphAsPostscript: morph) ].
	^morph! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'!
fontsForAccuAt

	| d |

	"Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16"
	d _ Dictionary new.
	d
		at: 0 put: #('Helvetica-Bold' 1.0);
		at: 1 put: #('Helvetica-Bold' 1.0);
		at: 2 put: #('Helvetica-BoldOblique' 1.0);
		at: 3 put: #('Helvetica-BoldOblique' 1.0).
	^d! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'!
fontsForComicBold

	| d |

	"Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16"
	d _ Dictionary new.
	d
		at: 0 put: #('Helvetica-Narrow-Bold' 0.9);
		at: 1 put: #('Helvetica-Narrow-Bold' 0.9);
		at: 2 put: #('Helvetica-Narrow-BoldOblique' 0.9);
		at: 3 put: #('Helvetica-Narrow-BoldOblique' 0.9).
	^d! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'!
fontsForComicPlain

	| d |

	"Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16"

"how do we do underlined??"

	d _ Dictionary new.
	d
		at: 0 put: #('Helvetica-Narrow' 0.9);
		at: 1 put: #('Helvetica-Narrow-Bold' 0.9);
		at: 2 put: #('Helvetica-Narrow-Oblique' 0.9);
		at: 3 put: #('Helvetica-Narrow-BoldOblique' 0.9).
	^d
! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'!
fontsForHelvetica

	| d |

	"Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16"
	d _ Dictionary new.
	d
		at: 0 put: #('Helvetica' 1.0);
		at: 1 put: #('Helvetica-Bold' 1.0);
		at: 2 put: #('Helvetica-Oblique' 1.0);
		at: 3 put: #('Helvetica-BoldOblique' 1.0);
		at: 8 put: #('Helvetica-Narrow' 1.0);
		at: 9 put: #('Helvetica-Narrow-Bold' 1.0);
		at: 10 put: #('Helvetica-Narrow-Oblique' 1.0);
		at: 11 put: #('Helvetica-Narrow-BoldOblique' 1.0).
	^d! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'!
fontsForNewYork

	| d |

	"Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16"
	d _ Dictionary new.
	d
		at: 0 put: #('Times-Roman' 1.0);
		at: 1 put: #('Times-Bold' 1.0);
		at: 2 put: #('Times-Italic' 1.0);
		at: 3 put: #('Times-BoldItalic' 1.0);
		at: 8 put: #('Helvetica-Narrow' 1.0);
		at: 9 put: #('Helvetica-Narrow-Bold' 1.0);
		at: 10 put: #('Helvetica-Narrow-Oblique' 1.0);
		at: 11 put: #('Helvetica-Narrow-BoldOblique' 1.0).
	^d! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'!
fontsForPalatino

	| d |

	"Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16"
	d _ Dictionary new.
	d
		at: 0 put: #('Palatino-Roman' 1.0);
		at: 1 put: #('Palatino-Bold' 1.0);
		at: 2 put: #('Palatino-Italic' 1.0);
		at: 3 put: #('Palatino-BoldItalic' 1.0).
	^d
! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 23:05'!
initializeFontMap
	"Initialize the dictionary mapping font names to substitutions for Postscript code generation."
	"PostscriptCanvas initializeFontMap"
	| f |
	FontMap := Dictionary new.
	FontMap
		at: 'NewYork' put: (f _ self fontsForNewYork);
		at: 'Accuny' put: f;

		at: 'Helvetica' put: (f _ self fontsForHelvetica);
		at: 'Accujen' put: f;
				
		at: 'Palatino' put: self fontsForPalatino;
		
		at: 'ComicBold' put: (f _ self fontsForComicBold);
		at: 'Accuat' put: self fontsForAccuAt;
		
		at: 'ComicPlain' put: self fontsForComicPlain! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 3/25/2004 20:13'!
postscriptFontInfoForFont: font

	| fontName decoded desired mask decodedName keys match |

	fontName _ font textStyleName asString.
	decoded _ TextStyle decodeStyleName: fontName.
	decodedName _ decoded second.
	keys _ self fontMap keys asArray sort: [ :a :b | a size > b size ].

	match _ keys select: [ :k | decoded first = k or: [ fontName = k ] ].
	match do: [ :key | | subD |
		subD := self fontMap at: key.
		desired _ font emphasis.
		mask _ 31.
		[
			desired _ desired bitAnd: mask.
			subD at: desired ifPresent: [ :answer | ^answer].
			mask _ mask bitShift: -1.
			desired > 0
		] whileTrue.
	].

	"No explicit lookup found; try to convert the style name into the canonical Postscript name.
	This name will probably still be wrong."

	fontName _ String streamContents: [ :s |
		s nextPutAll: decodedName.
		decoded third do: [ :nm | s nextPut: $-; nextPutAll: nm ].

		(font emphasis == 0 and: [ (decoded last includes: 0) not ])
			ifTrue: [ s nextPutAll:  '-Regular' ].

		(font emphasis == 1 and: [ (decoded first anyMask: 1) not ])
			ifTrue: [ s nextPutAll:  '-Bold' ].

		(font emphasis == 2 and: [ (decoded first anyMask: 2) not ])
			ifTrue: [ s nextPutAll:  '-Italic' ].

		(font emphasis == 3 and: [ (decoded first anyMask: 3) not ])
			ifTrue: [ s nextPutAll:  '-BoldItalic' ].
	].

	^ {fontName. 1.0}
! !

!PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 3/25/2004 15:55'!
postscriptFontMappingSummary
	"
	Transcript nextPutAll: 
	PostscriptCanvas postscriptFontMappingSummary
	; endEntry
	"
	| stream |
	stream _ WriteStream on: (String new: 1000).
	TextStyle actualTextStyles keysAndValuesDo: [ :styleName :style |
		stream nextPutAll: styleName; cr.
		style fontArray do: [ :baseFont | | info |
			0 to: 3 do: [ :i | | font |
				font _ baseFont emphasized: i.
				font emphasis = i ifTrue: [
					stream tab; nextPutAll: font fontNameWithPointSize; tab.
					info _ self postscriptFontInfoForFont: font.
					stream nextPutAll: info first; space; print: (font pixelSize * info second) rounded.
					stream cr.
				]
			]
		]
	].
	^stream contents! !


!PostscriptCanvas class methodsFor: 'testing' stamp: 'mpw 9/18/1999 11:02'!
morphAsPostscript:aMorph
	^self morphAsPostscript:aMorph rotated:false offsetBy:self baseOffset.
! !

!PostscriptCanvas class methodsFor: 'testing' stamp: 'di 9/22/1999 09:31'!
morphAsPostscript: aMorph rotated: rotateFlag

	^ self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: self baseOffset.
! !

!PostscriptCanvas class methodsFor: 'testing' stamp: 'nk 1/1/2004 20:21'!
morphAsPostscript:aMorph rotated:rotateFlag offsetBy:offset
 | psCanvas |
  psCanvas _ self new.
  psCanvas reset.
  psCanvas bounds: (0@0 extent: (aMorph bounds extent + (2 * offset))).
  psCanvas topLevelMorph:aMorph.
  psCanvas resetContentRotated: rotateFlag.
  psCanvas fullDrawMorph: aMorph .
  ^psCanvas contents.
! !
Object subclass: #PostscriptCharacterScanner
	instanceVariableNames: 'canvas paragraph bounds curPos font foregroundColor emphasis'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Canvases'!
!PostscriptCharacterScanner commentStamp: '<historical>' prior: 0!
I am a simple character scanner that forwards text-drawing commands to my canvas.  Despite the name, it should also work with other Canvases that actually implement the text-drawing commands (which the basic FormCanvas does not).

Style text support currently includes color, centering, fonts and emphasis.  Not yet supported are embedded objects, full justification and probably some others as well.

Tabs aren't supported properly, but rather hacked in the Postscript Header provided by PostscriptCanvas to be equivalent to 4 space.

mpw.
!


!PostscriptCharacterScanner methodsFor: 'accessing'!
bounds:newBounds
    bounds_newBounds.
    curPos_newBounds origin.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
canvas
	^canvas.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
canvas:newCanvas
    canvas_newCanvas.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing' stamp: 'sw 12/6/1999 13:10'!
defaultFont
	^ TextStyle defaultFont! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
font
	^ font ifNil:[self defaultFont].! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
paragraph
	^paragraph.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
paragraph:newPara
    paragraph_newPara.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing' stamp: 'mpw 8/4/1930 09:09'!
setDestForm:destForm
	"dummy"
! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
textStyle
	^paragraph textStyle.
! !


!PostscriptCharacterScanner methodsFor: 'displaying' stamp: 'RAA 10/2/2000 21:00'!
displayLine: line offset: baseOffset leftInRun: leftInRun
	| drawFont offset aText string s doJustified |

	self setTextStylesForOffset: ((line first) + 1).	" sets up various instance vars from text styles "
	drawFont _ self font.
	offset _ baseOffset.
	offset _ offset + (line left @ (line top + line baseline - drawFont ascent )). 
	offset _ offset + ((self textStyle alignment caseOf:{
		[2] -> [ line paddingWidth /2 ].
		[1] -> [ line paddingWidth ] } otherwise:[0]) @ 0).

	canvas moveto: offset.

	aText _ paragraph text copyFrom: line first to: line last.
	doJustified _ (paragraph textStyle alignment = 3)
						and: [ (paragraph text at:line last) ~= Character cr
						and: [aText runs runs size = 1]].
	string _ aText string.
	aText runs withStartStopAndValueDo: [:start :stop :attributes |
		self setTextStylesForOffset: (start + line first - 1).	" sets up inst vars from text styles "
		s _ string copyFrom: start to: stop.
		drawFont _ self font.
		canvas setFont: drawFont.
		canvas 
			textStyled: s
			at: offset 		"<--now ignored"
			font: drawFont 		"<--now ignored"
			color: foregroundColor
			justified: doJustified		"<-can't do this now for multi-styles" 
			parwidth: line right - line left.
	].
! !


!PostscriptCharacterScanner methodsFor: 'textstyle support' stamp: 'RAA 5/8/2001 10:01'!
addEmphasis: emphasisCode

	emphasis _ emphasis bitOr: emphasisCode.! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
addKern: kern
	" canvas comment:'kern now: ',kern printString. "
! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
indentationLevel: amount
	" canvas comment:'indentation level ',amount printString. "
! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
placeEmbeddedObject: anchoredMorph
! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
setActualFont: newFont
	font _ newFont.! !

!PostscriptCharacterScanner methodsFor: 'textstyle support' stamp: 'nk 6/10/2004 13:32'!
setAlignment: alignment
	self paragraph textStyle alignment: alignment.! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
setFont: fontNumber
	self setActualFont:(self textStyle fontAt:fontNumber).
! !

!PostscriptCharacterScanner methodsFor: 'textstyle support' stamp: 'sw 12/7/1999 12:28'!
setTextStylesForOffset:offset
	" default text style "
	font _ self textStyle defaultFont.
	emphasis _ 0.
	foregroundColor _ Color black.

	" set text styles defined at this point, these methods will set instance vars of myself "
	(paragraph text attributesAt: offset forStyle: paragraph textStyle) do: 
		[:att | att emphasizeScanner: self].

	" post-processing of 'emphasis' "
	self setActualFont: (font emphasized: emphasis)! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
textColor: aColor
	foregroundColor _ aColor.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptCharacterScanner class
	instanceVariableNames: ''!

!PostscriptCharacterScanner class methodsFor: 'as yet unclassified'!
scannerWithCanvas:aCanvas paragraph:aParagraph bounds:newBounds
    ^self new canvas:aCanvas; paragraph:aParagraph; bounds:newBounds.
 ! !
Object subclass: #PostscriptDummyWarp
	instanceVariableNames: 'canvas subCanvas transform'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Canvases'!
!PostscriptDummyWarp commentStamp: '<historical>' prior: 0!
I simulate the effects of having a WarpBlit done in Postscript, by simply adjusting the coordinate system.
!


!PostscriptDummyWarp methodsFor: 'dummy'!
canvas
	^canvas
! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:19'!
canvas:newCanvas
	canvas _ newCanvas.
! !

!PostscriptDummyWarp methodsFor: 'dummy'!
cellSize:newCellSize
	^self.! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:09'!
colorMap:aMap
! !

!PostscriptDummyWarp methodsFor: 'dummy'!
combinationRule:newRule
	^self.! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:12'!
drawPostscriptContext:aCanvas
	canvas drawPostscriptContext:aCanvas.


! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'di 8/12/2000 10:01'!
preserveStateDuring: aBlock

	^ canvas preserveStateDuring:
		"Note block arg must be self so various things get overridden properly"
		[:inner | aBlock value: self]

! !

!PostscriptDummyWarp methodsFor: 'dummy'!
sourceForm:newForm
	^self.! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:10'!
sourceQuad:aQuad destRect:aRect
! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/10/1930 21:02'!
subCanvas:patchRect
	subCanvas ifNil:
		[ subCanvas _ PostscriptCanvas new reset setOrigin:patchRect topLeft clipRect:(-10000@-10000 extent:20000@20000)].
	^subCanvas.

! !

!PostscriptDummyWarp methodsFor: 'dummy'!
transform
	^transform.
! !

!PostscriptDummyWarp methodsFor: 'dummy'!
transform:newTransform
	transform _ newTransform.
	^self.
! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:11'!
transformBy:aTransform
	canvas transformBy:aTransform.


! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'di 8/12/2000 10:13'!
warpBits
	canvas preserveStateDuring:
		[:inner | 
		transform ifNotNil: [inner transformBy: transform].
		inner drawPostscriptContext:subCanvas].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptDummyWarp class
	instanceVariableNames: ''!

!PostscriptDummyWarp class methodsFor: 'as yet unclassified' stamp: 'mpw 8/4/1930 09:18'!
canvas:aCanvas
	^self new canvas:aCanvas.! !
PrintableEncoder subclass: #PostscriptEncoder
	instanceVariableNames: ''
	classVariableNames: 'MacToPSCharacterMappings'
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Canvases'!
!PostscriptEncoder commentStamp: '<historical>' prior: 0!
I translate the message protocol generated by PostscriptCanvas that represents the Postscript imaging model into an actual stream of ASCII-encoded Postscript Level 2.

Alternative implementations might provide binary representations, Level I or Level III or even PDF.


!


!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 4/1/2004 20:16'!
clip
	self print: 'clip'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
closepath
	self print:'closepath'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
comment:aString
	self print:'%'; print:aString; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
comment:aString with:anObject
	self print:'%'; print:aString; print:' '; write:anObject; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
concat:aMatrix
	self write:aMatrix asMatrixTransform2x3; print:' concat'; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'mpw 9/12/1999 22:11'!
curvetoQuadratic:targetPoint from:sourcePoint via:offPoint
	self write:(sourcePoint + offPoint) / 2; print:' ';
		 write:(offPoint + targetPoint) / 2; print:' ';
		 write:targetPoint;
		 print:' curveto'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/28/2003 21:09'!
eofill
	self print: 'eofill'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
fill
	self print:'fill'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
lineto:aPoint
	self write:aPoint; print:' lineto'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
moveto:aPoint
	self write:aPoint; print:' moveto'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 4/1/2004 20:16'!
newpath
	self print: 'newpath'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'di 8/12/2000 19:45'!
oval: aPoint
	self print: 'matrix currentmatrix'; cr;
		write: (aPoint extent // 2); space;
		write: aPoint topLeft;
		print: ' newpath translate scale 1 1 1 0 360 arc setmatrix'; cr
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/29/2003 15:56'!
preserveStateDuring: aBlock 
	"Note that this method supplies self, an encoder, to the block"
	| retval |
	self print: 'gsave';
		 cr.
	retval := aBlock value: self.
	self print: 'grestore';
		 cr.
	^ retval! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/30/2003 17:24'!
rect: aRect

	self newpath.
	self
		moveto:aRect topLeft;
		lineto:aRect topRight x @ aRect topRight y;
		lineto:aRect bottomRight x @ aRect bottomRight y;
		lineto:aRect bottomLeft x @ aRect bottomLeft y;
		closepath.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
rectclip:aRect
	self write:aRect; print:' rectclip'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
rectfill:aRect
	self write:aRect; print:' rectfill'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
remapFontForSqueak:aFontName
	self print:'/'; print:aFontName; print:' adjustFontForSqueak'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
safeGrestore
	self print:'{ grestore } stopped pop'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
scale:aPoint
	self write:aPoint; print:' scale'; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
selectflippedfont:fontname size:size
	self selectflippedfont:fontname size:size ascent:size.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
selectflippedfont:fontname size:size ascent:ascent
	self print:'/'; print:fontname; space; 
		print:'[ '; write:size; print:' 0 0 ';write:size negated; print:' 0 '; write:ascent; print:'] selectfont'; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
selectfont:fontname size:size
	self print:'/'; print:fontname; space; write:size; print:' selectfont'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
setLinewidth:width
	self write:width; print:' setlinewidth';cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
setrgbcolor:aColor
	self write:aColor red; space;
		 write:aColor green; space;
		write:aColor blue; 
		print:' setrgbcolor'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'mpw 8/10/1930 21:34'!
showpage
	self print:'showpage'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
stroke
	self print:'stroke'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'mpw 8/10/1930 21:34'!
strokepath
	self print:'strokepath'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
translate:aPoint
	self write:aPoint; print:' translate'; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
writeMatrix:m
	self print:'[';
		write:m a11; print:' ';
		write:m a21; print:' ';
		write:m a12; print:' ';
		write:m a22; print:' ';
		write:m a13; print:' ';
		write:m a23; print:'] '.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
writePoint:aPoint
	self write:aPoint x; space; write:aPoint y.
! !


!PostscriptEncoder methodsFor: 'writing' stamp: 'mpw 11/12/1999 00:46'!
writeNumber:aNumber
	super writeNumber:(aNumber isInteger ifTrue:[aNumber] ifFalse:[aNumber roundTo:0.001]).
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptEncoder class
	instanceVariableNames: ''!

!PostscriptEncoder class methodsFor: 'configuring' stamp: 'RAA 9/19/2000 23:07'!
clearCharacterMappings

	MacToPSCharacterMappings _ nil.! !

!PostscriptEncoder class methodsFor: 'configuring'!
filterSelector
	^#encodePostscriptOn:.! !

!PostscriptEncoder class methodsFor: 'configuring' stamp: 'RAA 9/19/2000 23:06'!
macToPSCharacterChart
	"mac char code, PS char code"
	^#(
		(128 999)  "Ä"
		(129 999)  "Å"
		(130 999)  "Ç"
		(131 999)  "É"
		(132 999)  "Ñ"
		(133 999)  "Ö"
		(134 999)  "Ü"
		(135 999)  "á"
		(136 999)  "à"
		(137 999)  "â"
		(138 999)  "ä"
		(139 999)  "ã"
		(140 999)  "å"
		(141 999)  "ç"
		(142 999)  "é"
		(143 999)  "è"
		(144 999)  "ê"
		(145 999)  "ë"
		(146 999)  "í"
		(147 999)  "ì"
		(148 999)  "î"
		(149 999)  "ï"
		(150 999)  "ñ"
		(151 999)  "ó"
		(152 999)  "ò"
		(153 999)  "ô"
		(154 999)  "ö"
		(155 999)  "õ"
		(156 999)  "ú"
		(157 999)  "ù"
		(158 999)  "û"
		(159 999)  "ü"
		(160 999)  "†"
		(161 202)  "°"
		(162 162)  "¢"
		(163 163)  "£"
		(164 167)  "§"
		(165 183)  "·"
		(166 182)  "¶"
		(167 251)  "ß"
		(168 999)  "®"
		(169 999)  "©"
		(170 999)  "™"
		(171 999)  "´"
		(172 999)  "¨"
		(173 999)  "€"
		(174 225)  "Æ"
		(175 999)  "Ø"
		(176 999)  ""
		(177 999)  "±"
		(178 999)  "Š"
		(179 999)  ""
		(180 165)  "¥"
		(181 999)  "µ"
		(182 999)  "Ž"
		(183 999)  ""
		(184 999)  ""
		(185 999)  "š"
		(186 999)  ""
		(187 227)  "ª"
		(188 235)  "º"
		(189 999)  "ž"
		(190 241)  "æ"
		(191 999)  "ø"
		(192 191)  "¿"
		(193 166)  "¡"
		(194 999)  "¬"
		(195 999)  "¦"
		(196 999)  "ƒ"
		(197 999)  "­"
		(198 999)  "²"
		(199 171)  "«"
		(200 187)  "»"
		(201 188)  "…"
		(202 999)  " "
		(203 999)  "À"
		(204 999)  "Ã"
		(205 999)  "Õ"
		(206 234)  "Œ"
		(207 250)  "œ"
		(208 999)  "–"
		(209 999)  "—"
		(210 999)  "“"
		(211 999)  "”"
		(212 999)  "‘"
		(213 999)  "’"
		(214 999)  "÷"
		(215 999)  "³"
		(216 999)  "ÿ"
		(217 999)  "Ÿ"
		(218 999)  "¹"
		(219 999)  "¤"
		(220 999)  "‹"
		(221 999)  "›"
		(222 999)  "¼"
		(223 999)  "½"
		(224 999)  "‡"
		(225 999)  "·"
		(226 999)  "‚"
		(227 999)  "„"
		(228 999)  "‰"
		(229 999)  "Â"
		(230 999)  "Ê"
		(231 999)  "Á"
		(232 999)  "Ë"
		(233 999)  "È"
		(234 999)  "Í"
		(235 999)  "Î"
		(236 999)  "Ï"
		(237 999)  "Ì"
		(238 999)  "Ó"
		(239 999)  "Ô"
		(240 999)  "¾"
		(241 999)  "Ò"
		(242 999)  "Ú"
		(243 999)  "Û"
		(244 999)  "Ù"
		(245 999)  "Ð"
		(246 999)  "ˆ"
		(247 999)  "˜"
		(248 999)  "¯"
		(249 999)  "×"
		(250 999)  "Ý"
		(251 999)  "Þ"
		(252 999)  "¸"
		(253 999)  "ð"
		(254 999)  "ý"
		(255 999)  "þ"
	)! !

!PostscriptEncoder class methodsFor: 'configuring' stamp: 'RAA 9/19/2000 18:05'!
mapMacStringToPS: aString

	| copy val newVal |
	MacToPSCharacterMappings ifNil: [
		MacToPSCharacterMappings _ Array new: 256.
		self macToPSCharacterChart do: [ :pair |
			pair second = 999 ifFalse: [MacToPSCharacterMappings at: pair first put: pair second]
		].
	].
	copy _ aString copy.
	copy withIndexDo: [ :ch :index |
		(val _ ch asciiValue) > 127 ifTrue: [
			(newVal _ MacToPSCharacterMappings at: val) ifNotNil: [
				copy at: index put: newVal asCharacter
			].
		].
	].
	^copy! !
PostscriptEncoder subclass: #PostscriptEncoderToDisk
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Canvases'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptEncoderToDisk class
	instanceVariableNames: ''!

!PostscriptEncoderToDisk class methodsFor: 'creation' stamp: 'RAA 10/12/2000 09:32'!
stream

	^self new initWithTarget: PickAFileToWriteNotification signal
! !
Object subclass: #PowerManagement
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!PowerManagement commentStamp: '<historical>' prior: 0!
This class is used to restore the VM's view of the power manage option. On the macintosh in a 3.x VM  you can  turn the power manager on or off. This may make your iBook run faster, and will prevents your macintosh from sleeping. This does consume more power so your battery life will be degraded. 

Usually you can turn processor cycling off in the control panel, but this class ensures it's off if you set the preference to turn power management off!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PowerManagement class
	instanceVariableNames: ''!

!PowerManagement class methodsFor: 'class initialization' stamp: 'JMM 2/2/2001 13:09'!
initialize
	"PowerManagement initialize"

	Smalltalk addToStartUpList: self! !


!PowerManagement class methodsFor: 'computing' stamp: 'md 10/26/2003 13:07'!
itsyVoltage
	"On the Itsy, answer the approximate Vcc voltage. The Itsy will shut 
	itself down when this value reaches 2.0 volts. This method allows one to 
	build a readout of the current battery condition."
	| n |
	n _ SmalltalkImage current getSystemAttribute: 1200.
	n
		ifNil: [^ 'no voltage attribute'].
	^ (n asNumber / 150.0 roundTo: 0.01) asString , ' volts'! !


!PowerManagement class methodsFor: 'power management' stamp: 'sd 4/29/2003 21:55'!
disablePowerManager
	self disablePowerManager: 1! !

!PowerManagement class methodsFor: 'power management' stamp: 'sd 4/29/2003 21:56'!
disablePowerManager: aInteger 
	"Disable/Enable the architectures power manager by passing in nonzero 
	or zero"
	<primitive: 'primitiveDisablePowerManager'> "primitiveExternalCall" 
	^ self! !

!PowerManagement class methodsFor: 'power management' stamp: 'sd 4/29/2003 21:57'!
enablePowerManager
	self disablePowerManager: 0! !


!PowerManagement class methodsFor: 'startup logic' stamp: 'JMM 2/2/2001 13:10'!
deinstall
	"PowerManagement deinstall"

	Smalltalk removeFromStartUpList: self.
! !

!PowerManagement class methodsFor: 'startup logic' stamp: 'sd 4/29/2003 22:05'!
startUp
	[Preferences turnOffPowerManager
		ifTrue: [self disablePowerManager]]
		ifError: []! !
Object subclass: #Pragma
	instanceVariableNames: 'method keyword arguments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!Pragma commentStamp: '<historical>' prior: 0!
I represent a pragma instance found in a compiled method. I can provide information about the defining class, method, its selector, as well as the information about the pragma keyword and its arguments. See the two 'accessing' protocols for details. 'accessing-method' provides information about the method the pragma is found in, while 'accessing-pragma' is about the pragma itself.

Instances are retreived using one of the pragma search methods of the 'finding' protocol on the class side.!


!Pragma methodsFor: 'accessing-method' stamp: 'lr 1/20/2006 02:04'!
method
	"Answer the compiled-method containing the pragma."
	
	^ method! !

!Pragma methodsFor: 'accessing-method' stamp: 'lr 1/20/2006 02:08'!
methodClass
	"Answer the class of the method containing the pragma."
	
	^ method methodClass! !

!Pragma methodsFor: 'accessing-method' stamp: 'md 2/16/2006 14:01'!
selector
	"Answer the selector of the method containing the pragma."
	
	^ method selector.! !


!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/20/2006 02:10'!
argumentAt: anInteger
	"Answer one of the arguments of the pragma."
	
	^ self arguments at: anInteger.! !

!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:54'!
arguments
	"Answer the arguments of the recieving pragma. For a pragma defined as <key1: val1 key2: val2> this will answer #(val1 val2)."
	
	^ arguments! !

!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:53'!
keyword
	"Answer the keyword of the recieving pragma. For a pragma defined as <key1: val1 key2: val2> this will answer #key1:key2."
	
	^ keyword! !

!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:55'!
message
	"Answer the message of the recieving pragma."
	
	^ Message selector: self keyword arguments: self arguments. ! !

!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/20/2006 02:10'!
numArgs
	"Answer the number of arguments in the pragma."

	^ self arguments size.! !


!Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'!
setArguments: anArray
	arguments := anArray! !

!Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'!
setKeyword: aSymbol
	keyword := aSymbol! !

!Pragma methodsFor: 'initialization' stamp: 'lr 1/19/2006 23:39'!
setMethod: aCompiledMethod
	method := aCompiledMethod! !


!Pragma methodsFor: 'printing' stamp: 'lr 2/6/2006 19:56'!
printOn: aStream
	aStream nextPut: $<.
	self keyword precedence = 1
		ifTrue: [ aStream nextPutAll: self keyword ]
		ifFalse: [
			self keyword keywords with: self arguments do: [ :key :arg |
				aStream nextPutAll: key; space; print: arg; space ].
			aStream skip: -1 ].
	aStream nextPut: $>.! !


!Pragma methodsFor: 'testing' stamp: 'lr 2/6/2006 22:17'!
hasLiteralSuchThat: aBlock
	^ (aBlock value: self keyword)
		or: [ self arguments hasLiteralSuchThat: aBlock ].! !

!Pragma methodsFor: 'testing' stamp: 'lr 2/6/2006 22:16'!
hasLiteral: aLiteral
	^ self keyword == aLiteral 
		or: [ self arguments hasLiteral: aLiteral ].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Pragma class
	instanceVariableNames: ''!

!Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 08:54'!
allNamed: aSymbol from: aSubClass to: aSuperClass
	"Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol."
	
	^ Array streamContents: [ :stream |
		aSubClass withAllSuperclassesDo: [ :class |
			self withPragmasIn: class do:  [ :pragma |
				pragma keyword = aSymbol
					ifTrue: [ stream nextPut: pragma ] ].
			aSuperClass = class
				ifTrue: [ ^ stream contents ] ] ].! !

!Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 18:16'!
allNamed: aSymbol from: aSubClass to: aSuperClass sortedByArgument: anInteger
	"Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to argument anInteger."

	^ self allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! !

!Pragma class methodsFor: 'finding' stamp: 'lr 1/19/2006 20:12'!
allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: aSortBlock
	"Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to aSortBlock."
	
	^ (self allNamed: aSymbol from: aSubClass to: aSuperClass) sort: aSortBlock.! !

!Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 08:55'!
allNamed: aSymbol in: aClass
	"Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol."
	
	^ Array streamContents: [ :stream |
		self withPragmasIn: aClass do: [ :pragma |
			pragma keyword = aSymbol
				ifTrue: [ stream nextPut: pragma ] ] ].! !

!Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 18:16'!
allNamed: aSymbol in: aClass sortedByArgument: anInteger
	"Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to argument anInteger."

	^ self allNamed: aSymbol in: aClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! !

!Pragma class methodsFor: 'finding' stamp: 'lr 1/19/2006 20:06'!
allNamed: aSymbol in: aClass sortedUsing: aSortBlock
	"Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to aSortBlock."
	
	^ (self allNamed: aSymbol in: aClass) sort: aSortBlock.! !


!Pragma class methodsFor: 'private' stamp: 'lr 1/20/2006 00:34'!
keyword: aSymbol arguments: anArray
	^ self new
		setKeyword: aSymbol;
		setArguments: anArray;
		yourself.! !

!Pragma class methodsFor: 'private' stamp: 'lr 1/20/2006 08:50'!
withPragmasIn: aClass do: aBlock
	aClass selectorsAndMethodsDo: [ :selector :method | method pragmas do: aBlock ].! !
SystemWindow subclass: #PreDebugWindow
	instanceVariableNames: 'proceedButton debugButton'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:37'!
adjustBookControls
	| inner |
	proceedButton ifNil: [^ self].
	proceedButton align: proceedButton topLeft with: (inner _ self innerBounds) topLeft + (35@-4).
	debugButton align: debugButton topRight with: inner topRight - (16@4).! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'nk 2/12/2003 23:00'!
createMethod
	model createMethod! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'!
debug
	model debug! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'!
proceed
	model proceed! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'yo 3/15/2005 13:07'!
setBalloonTextForCloseBox
	closeBox ifNotNil:
		[closeBox setBalloonText: 'abandon this execution by closing this window' translated].
! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'mir 11/10/2003 15:15'!
storeLog
	model storeLog! !


!PreDebugWindow methodsFor: 'geometry' stamp: 'sw 11/4/1998 09:50'!
extent: newExtent
	super extent: (newExtent max: 100 @ 50).
	self adjustBookControls! !


!PreDebugWindow methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:39'!
initialize
	| aFont proceedLabel debugLabel aWidth |
	super initialize.
	true 
		ifFalse: 
			["Preferences optionalMorphicButtons"

			(aWidth := self widthOfFullLabelText) > 280 ifTrue: [^self].	"No proceed/debug buttons if title too long"
			debugLabel := aWidth > 210 
				ifTrue: 
					["Abbreviated buttons if title pretty long"

					proceedLabel := 'p'.
					'd']
				ifFalse: 
					["Full buttons if title short enough"

					proceedLabel := 'proceed'.
					'debug'].
			aFont := Preferences standardButtonFont.
			self addMorph: (proceedButton := (SimpleButtonMorph new)
								borderWidth: 0;
								label: proceedLabel font: aFont;
								color: Color transparent;
								actionSelector: #proceed;
								target: self).
			proceedButton setBalloonText: 'continue execution'.
			self addMorph: (debugButton := (SimpleButtonMorph new)
								borderWidth: 0;
								label: debugLabel font: aFont;
								color: Color transparent;
								actionSelector: #debug;
								target: self).
			debugButton setBalloonText: 'bring up a debugger'.
			proceedButton submorphs first color: Color blue.
			debugButton submorphs first color: Color red].
	self adjustBookControls! !


!PreDebugWindow methodsFor: 'label' stamp: 'tk 1/3/2000 12:54'!
setLabelWidgetAllowance
	^ labelWidgetAllowance _ (Smalltalk isMorphic | Preferences optionalButtons)
		ifTrue:
			[super setLabelWidgetAllowance]
		ifFalse:
			[180]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PreDebugWindow class
	instanceVariableNames: ''!

!PreDebugWindow class methodsFor: 'new-morph participation' stamp: 'sw 11/4/1998 09:20'!
includeInNewMorphMenu
	^ false! !
Object subclass: #Preference
	instanceVariableNames: 'name value defaultValue helpString localToProject categoryList changeInformee changeSelector viewRegistry'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!Preference commentStamp: '<historical>' prior: 0!
Represents a true/false flag that is under user control and which can be interrogated by a call to Preferences
	viewRegistry		the registry of the classes responsible for building my view
	name 				a symbol, the formal name of the preference.
	value				a boolean, the current value
	defaultValue		the default value of the preference
	helpString 			string or text, constituting the help message
	localToProject		boolean, whether each project holds its own version
	categoryList			list of categories under which to offer this
	changeInformee 	whom, if anyone, to inform if the value changes:
	changeSelector 		what selector to send to the changeInformee when the value changes!


!Preference methodsFor: 'change notification' stamp: 'sw 4/12/2001 01:39'!
changeInformee: informee changeSelector: aSelector
	"Set the changeInformee and changeSelector as specified"

	changeInformee _ informee.
	changeSelector _ aSelector! !

!Preference methodsFor: 'change notification' stamp: 'sw 4/12/2001 00:03'!
notifyInformeeOfChange
	"If there is a changeInformee, notify her that I have changed value"

	changeInformee ifNotNil: [changeInformee perform: changeSelector]! !


!Preference methodsFor: 'debugging' stamp: 'sw 4/13/2001 00:05'!
printOn: aStream
	"Print a string decribing the receiver to the given stream"

	super printOn: aStream.
	aStream nextPutAll: name storeString, ' ', value storeString! !


!Preference methodsFor: 'initialization' stamp: 'sw 4/29/2001 23:51'!
categoryList: aList
	"Set the receiver's categoryList"

	categoryList _ aList! !

!Preference methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:59'!
name: aName defaultValue: aValue helpString: aString localToProject: projectBoolean categoryList: aList changeInformee: informee changeSelector:  aChangeSelector viewRegistry: aViewRegistry
	"Initialize the preference from the given values.  There is an extra tolerence here for the symbols #true, #false, and #nil, which are interpreted, when appropriate, as meaning true, false, and nil"

	name := aName asSymbol.
	defaultValue := aValue.
	aValue = #true ifTrue: [defaultValue := true].
	aValue = #false ifTrue: [defaultValue := false].
	value := defaultValue.
	helpString := aString.
	localToProject := projectBoolean == true or: [projectBoolean = #true].
	viewRegistry := aViewRegistry.
	categoryList := (aList ifNil: [OrderedCollection with: #unclassified]) collect:
		[:elem | elem asSymbol].

	changeInformee := (informee == nil or: [informee == #nil])
						ifTrue: [nil]
						ifFalse:	[(informee isKindOf: Symbol)
							ifTrue:
								[Smalltalk at: informee]
							ifFalse:
								[informee]].
	changeSelector  := aChangeSelector! !


!Preference methodsFor: 'local to project' stamp: 'sw 4/10/2001 12:37'!
isProjectLocalString
	"Answer a string representing whether sym is a project-local preference or not"

	| aStr |
	aStr _  'each project has its own setting'.
	^ localToProject
		ifTrue:
			['<yes>', aStr]
		ifFalse:
			['<no>', aStr]! !

!Preference methodsFor: 'local to project' stamp: 'sw 4/10/2001 01:14'!
localToProject
	"Answer whether this preference is project-local"

	^ localToProject! !

!Preference methodsFor: 'local to project' stamp: 'sw 4/10/2001 11:58'!
toggleProjectLocalness
	"Toggle whether the preference should be held project-by-project or globally"

	localToProject _ localToProject not.
	PreferencesPanel allInstancesDo:
		[:aPanel | aPanel adjustProjectLocalEmphasisFor: name].
! !


!Preference methodsFor: 'menu' stamp: 'sw 4/12/2001 23:42'!
categoryList
	"Answer the categoryList"

	^ categoryList! !

!Preference methodsFor: 'menu' stamp: 'sw 4/13/2001 00:01'!
copyName
	"Copy the name of the given preference to the clipboard"

	Clipboard clipboardText: name asString asText! !

!Preference methodsFor: 'menu' stamp: 'sw 4/13/2001 00:04'!
helpString
	"Answer the help string provided for the receiver"

	^ helpString ifNil: ['no help available']! !

!Preference methodsFor: 'menu' stamp: 'sw 4/10/2001 15:02'!
name
	"Answer this preference's name"

	^ name! !


!Preference methodsFor: 'testing' stamp: 'ar 9/27/2005 21:50'!
isObsolete
	^(changeInformee class isObsolete or:[changeInformee isBehavior and:[changeInformee isObsolete]])! !


!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:58'!
representativeButtonWithColor: aColor inPanel: aPanel
	| view |
	view _ self viewForPanel: aPanel.
	^view ifNotNil: [view representativeButtonWithColor: aColor inPanel: aPanel]! !

!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:42'!
viewClassForPanel: aPreferencePanel
	^self viewRegistry viewClassFor: aPreferencePanel! !

!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:58'!
viewForPanel: aPreferencePanel
	| viewClass |
	viewClass _ self viewClassForPanel: aPreferencePanel.
	^viewClass ifNotNil: [viewClass preference: self]! !

!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:40'!
viewRegistry
	^viewRegistry! !

!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:40'!
viewRegistry: aRegistry
	viewRegistry _ aRegistry! !


!Preference methodsFor: 'value' stamp: 'sw 4/10/2001 15:01'!
defaultValue
	"Answer this preference's defaultValue"

	^ defaultValue! !

!Preference methodsFor: 'value' stamp: 'sw 4/18/2002 12:15'!
defaultValue: aValue
	"Set the receiver's defaultValue"

	defaultValue _ aValue.! !

!Preference methodsFor: 'value' stamp: 'sw 4/10/2001 15:35'!
preferenceValue
	"Answer the current value of the preference"

	^ value! !

!Preference methodsFor: 'value' stamp: 'sw 4/12/2001 23:28'!
preferenceValue: aValue
	"set the value as indicated, and invoke the change selector if appropriate"

	| oldValue |
	oldValue _ value.
	value _ aValue.
	oldValue ~~ value ifTrue:
		[self notifyInformeeOfChange]! !

!Preference methodsFor: 'value' stamp: 'sw 4/12/2001 23:28'!
rawValue: aValue
	"set the value as indicated, with no side effects"

	value _ aValue! !

!Preference methodsFor: 'value' stamp: 'sw 4/12/2001 00:04'!
restoreDefaultValue
	"restore the default value to the preference"

	value _ defaultValue! !

!Preference methodsFor: 'value' stamp: 'hpt 9/26/2004 16:51'!
togglePreferenceValue
	"Toggle whether the value of the preference. Self must be a boolean preference."
	value := value not.
	self notifyInformeeOfChange! !
Model subclass: #PreferenceBrowser
	instanceVariableNames: 'selectedCategoryIndex selectedPreference searchPattern searchResults lastExecutedSearch preferences title'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 17:59'!
allCategorySelected
	^self selectedCategory = self allCategoryLabel! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:05'!
allPreferences
	^ preferences allPreferenceObjects  asSortedCollection:
			[:pref1 :pref2 | 
			pref1 viewRegistry viewOrder  <pref2 viewRegistry viewOrder  or:
					[pref1 viewRegistry viewOrder  =pref2 viewRegistry viewOrder 
						 &(pref1 name  <pref2 name)]]! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:05'!
categoryList
	^OrderedCollection new
		add:  self allCategoryLabel;
		addAll: preferences categoryNames asSortedCollection;
		add: self searchResultsCategoryLabel;
		yourself.
	
	! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 8/27/2005 23:35'!
lastExecutedSearch
	^lastExecutedSearch! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'!
lastExecutedSearch: aTextOrString
	^lastExecutedSearch:= aTextOrString! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 18:01'!
nonSpecialCategorySelected
	^self allCategorySelected not & self searchResultsCategorySelected not! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'rr 10/11/2005 17:14'!
preferences
	^ preferences! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:05'!
preferencesInCategory: aCategory
	^(preferences preferenceObjectsInCategory: aCategory)! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 7/8/2006 17:50'!
searchFieldLegend
	^''.! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 8/27/2005 23:39'!
searchPattern
	^searchPattern ifNil: [searchPattern := self searchFieldLegend]! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'!
searchPattern: aStringOrText
	aStringOrText 
		ifEmpty: [searchPattern := self searchFieldLegend]
		ifNotEmpty: [searchPattern := aStringOrText asString].
	self changed: #searchPattern.
	^true! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'!
searchResults
	^searchResults ifNil: [searchResults := #()]! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 18:01'!
searchResultsCategorySelected
	^self selectedCategory = self searchResultsCategoryLabel! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/19/2004 00:01'!
selectedCategory
	^self categoryList at: selectedCategoryIndex ifAbsent: []! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 20:49'!
selectedCategoryIndex
	^selectedCategoryIndex ifNil: [selectedCategoryIndex := 0].! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 23:45'!
selectedCategoryIndex: anIndex
	anIndex = 0
		ifTrue: [^self].
	self selectedPreference: nil.
	selectedCategoryIndex := anIndex.
	self changed: #selectedCategoryIndex.! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/19/2004 03:27'!
selectedCategoryPreferences
	self allCategorySelected
		ifTrue: [^self allPreferences].
	self searchResultsCategorySelected 
		ifTrue: [^self searchResults].
	^self preferencesInCategory: self selectedCategory.
	! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/25/2004 17:09'!
selectedCategory: aCategorySymbol
	self selectedCategoryIndex: (self categoryList indexOf: aCategorySymbol ifAbsent: [0]).! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 20:53'!
selectedPreference
	^selectedPreference! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 12/8/2004 15:22'!
selectedPreferenceHelpText
	self selectedPreference
		ifNil: [^''].
	^self selectedPreference helpString withBlanksTrimmed.! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 21:17'!
selectedPreferenceIndex
	^self selectedCategoryPreferences indexOf: self selectedPreference ifAbsent: [0]! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 23:41'!
selectedPreferenceIndex: anIndex
	anIndex = 0
		ifTrue: [^self].
	self selectedPreference: (self selectedCategoryPreferences at: anIndex).! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/19/2004 00:39'!
selectedPreference: aPreference
	selectedPreference := aPreference.
	self changed: #selectedPreference.
	self changed: #selectedPreferenceIndex.
	self changed: #selectedPreferenceHelpText.! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'!
selectFirstPreferenceOrNil
	| prefs |
	self selectedCategory
		ifNil: [^self selectedPreference: nil].
	prefs := self preferencesInCategory: self selectedCategory.
	prefs isEmpty
		ifTrue: [^self selectedPreference: nil].
	self selectedPreference: prefs first.! !

!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/19/2004 03:23'!
selectSearchResultsCategory
	self selectedCategoryIndex: (self categoryList indexOf: self searchResultsCategoryLabel)! !


!PreferenceBrowser methodsFor: 'buttons callbacks' stamp: 'hpt 9/19/2004 03:21'!
searchSelected
	self searchPreferencesFor: self searchPattern.! !


!PreferenceBrowser methodsFor: 'find' stamp: 'rr 10/1/2005 15:05'!
findCategoryFromPreference: prefSymbol
	"Find all categories in which the preference occurs"

	| aMenu| 
	aMenu := MenuMorph new defaultTarget: self.
	(preferences categoriesContainingPreference: prefSymbol) do:
		[:aCategory | aMenu add: aCategory target: self selector: #selectedCategory: argument: aCategory].
	aMenu popUpInWorld! !


!PreferenceBrowser methodsFor: 'initialize-release' stamp: 'rr 10/1/2005 15:25'!
initialize
	preferences := Preferences.
	title := 'Preference Browser'.! !


!PreferenceBrowser methodsFor: 'preferences search' stamp: 'hpt 9/19/2004 12:01'!
defaultSelected
	Preferences chooseInitialSettings! !

!PreferenceBrowser methodsFor: 'preferences search' stamp: 'hpt 8/27/2005 13:18'!
helpSelected 
	"Open up a workspace with explanatory info in it about the Preference Browser"
	Workspace new
		contents: self helpText;
		openLabel: self windowTitle.! !

!PreferenceBrowser methodsFor: 'preferences search' stamp: 'hpt 8/27/2005 13:42'!
helpText
	^(String streamContents: [:str |
		str nextPutAll:
'Many aspects of the system are goberned by the settings of various ''Preferences''.

Click on any of the categories shown at the left list to see all the preferences in that category. Or type into the search box at the bottom of the window, then hit Search, and all Preferences matching whatever you typed in will appear in the ''search results'' category. A preference is considered to match your search if either its name matches the text *or* if anything in the preference''s help text does.

To find out more about any particular Preference just select it and its help text will appear.

Some preferences can be ''local'' instead of global. When a preference is set as global its value will apply to whatever project you are in. A local preference will only be valid in the project that you set it in.

The ''Save'' button allow you to quickly save your current settings so it can later be restored with the ''Load'' button.

To carry your settings to another Squeak you might want to use the ''Save to disk'' and ''Load from disk'' buttons. The save to disk option will store all your settings in a ''my.prefs'' file in your Squeak''s current directory.

Lastly, you can use the "theme..." button to set multiple preferences all at once; click on the "theme..." button and try the themes already provided with your Squeak image.']) translated! !

!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:05'!
loadFromDiskSelected 
	preferences restorePreferencesFromDisk! !

!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:05'!
loadSelected
	preferences restorePersonalPreferences ! !

!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:05'!
saveSelected
	preferences savePersonalPreferences ! !

!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:05'!
saveToDiskSelected 
	preferences storePreferencesToDisk! !

!PreferenceBrowser methodsFor: 'preferences search' stamp: 'hpt 8/27/2005 23:36'!
searchPreferencesFor: pattern
	| result |
	result := pattern asString asLowercase withBlanksTrimmed.
	result ifEmpty: [^self].
	searchResults := self allPreferences select: [:aPreference |
		(aPreference name includesSubstring: result caseSensitive: false) or:
				[aPreference helpString includesSubstring: result caseSensitive: false]].		
	self selectSearchResultsCategory.
	self lastExecutedSearch: pattern.
! !

!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:06'!
themeSelected 
	preferences offerThemesMenu! !


!PreferenceBrowser methodsFor: 'stepping' stamp: 'hpt 8/27/2005 23:35'!
stepAt: millisecondClockValue in: aWindow
	super stepAt: millisecondClockValue in: aWindow.
	self searchPattern ~= self lastExecutedSearch
		ifTrue: [self searchPreferencesFor: self searchPattern].! !

!PreferenceBrowser methodsFor: 'stepping' stamp: 'hpt 8/27/2005 23:41'!
wantsStepsIn: aWindow
	^true.! !


!PreferenceBrowser methodsFor: 'user interface' stamp: 'hpt 9/19/2004 02:30'!
allCategoryLabel
	^'-- all --' translated! !

!PreferenceBrowser methodsFor: 'user interface' stamp: 'md 2/28/2006 17:28'!
initialExtent
	^ 520@440! !

!PreferenceBrowser methodsFor: 'user interface' stamp: 'hpt 9/19/2004 02:30'!
searchResultsCategoryLabel
	^'-- search results --' translated! !

!PreferenceBrowser methodsFor: 'user interface' stamp: 'rr 1/8/2006 12:35'!
windowTitle
	^ title translated! !


!PreferenceBrowser methodsFor: '*services-base' stamp: 'rr 10/1/2005 15:25'!
initializeForServices
	preferences := ServicePreferences.
	title := 'Services Browser'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PreferenceBrowser class
	instanceVariableNames: ''!

!PreferenceBrowser class methodsFor: 'class initialization' stamp: 'hpt 9/19/2004 12:45'!
initialize
	self
		registerWindowColor;
		registerInOpenMenu;
		registerInFlaps! !

!PreferenceBrowser class methodsFor: 'class initialization' stamp: 'hpt 9/19/2004 12:48'!
registerInFlaps
	Flaps 
		registerQuad: 
			{ #PreferenceBrowser. 
			#prototypicalToolWindow.
			'Preference Browser' translated.
			'A tool for expressing personal preferences for numerous options' translated }
	 	forFlapNamed: 'Tools' translated.
	Flaps replaceToolsFlap! !

!PreferenceBrowser class methodsFor: 'class initialization' stamp: 'hpt 9/19/2004 12:40'!
registerInOpenMenu
	(TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [
		TheWorldMenu unregisterOpenCommand: 'Preference Browser'.
		TheWorldMenu registerOpenCommand: {'Preference Browser'. {self. #open}}].
		! !

!PreferenceBrowser class methodsFor: 'class initialization' stamp: 'hpt 9/19/2004 12:39'!
registerWindowColor
	(Preferences windowColorFor: self name) = Color white
		ifTrue: [ Preferences setWindowColorFor: self name to: (Color colorFrom: self windowColorSpecification brightColor) ].! !

!PreferenceBrowser class methodsFor: 'class initialization' stamp: 'hpt 9/19/2004 12:45'!
unload
	self 
		unregisterFromOpenMenu;
		unregisterFromFlaps.! !

!PreferenceBrowser class methodsFor: 'class initialization' stamp: 'hpt 9/19/2004 12:47'!
unregisterFromFlaps
	Flaps 
		unregisterQuadsWithReceiver: self;
		replaceToolsFlap! !

!PreferenceBrowser class methodsFor: 'class initialization' stamp: 'hpt 9/19/2004 12:44'!
unregisterFromOpenMenu
	 (TheWorldMenu respondsTo: #registerOpenCommand:)
		ifTrue: [TheWorldMenu unregisterOpenCommand: 'Preference Browser'].
! !


!PreferenceBrowser class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:39'!
open
	| browser |
	browser := self new.
	(PreferenceBrowserMorph withModel: browser)
		openInWorld.
	^browser.	! !

!PreferenceBrowser class methodsFor: 'instance creation' stamp: 'hpt 9/19/2004 12:51'!
prototypicalToolWindow
	| window |
	window := PreferenceBrowserMorph withModel: self new.
	window applyModelExtent.
	^window! !


!PreferenceBrowser class methodsFor: 'window color' stamp: 'hpt 9/18/2004 15:46'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Preference Browser' brightColor: #(0.645 1.0 1.0)	pastelColor: #(0.886 1.0 1.0) helpMessage: 'A tool for expressing personal preferences for numerous options.'! !


!PreferenceBrowser class methodsFor: '*services-base' stamp: 'rr 7/10/2006 15:27'!
openForServices
	"PreferenceBrowser openForServices"
	| browser |
	browser _ self new.
	browser initializeForServices.
	(ServiceBrowserMorph withModel: browser)
		openInWorld.
	^browser.	! !
SystemWindow subclass: #PreferenceBrowserMorph
	instanceVariableNames: 'mainPanel defaultButton saveButton loadButton saveToDiskButton loadFromDiskButton themeButton helpButton preferenceList lastKeystrokeTime lastKeystrokes highlightedPreferenceButton'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PreferenceBrowser'!

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:12'!
basicKeyPressed: anEvent
	| aChar oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionPref |
	aChar := anEvent keyCharacter.
	nextSelection := oldSelection := self selectedPreferenceIndex.
	max := self selectedCategoryPreferences size.
	milliSeconds := Time millisecondClockValue.
	milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting"
		lastKeystrokes := ''].
	lastKeystrokes := lastKeystrokes , aChar asLowercase asString.
	lastKeystrokeTime := milliSeconds.
	nextSelectionList := OrderedCollection newFrom: (self selectedCategoryPreferences copyFrom: oldSelection + 1 to: max).
	nextSelectionList addAll: (self selectedCategoryPreferences copyFrom: 1 to: oldSelection).
	"Get rid of blanks and style used in some lists"
	nextSelectionPref := nextSelectionList detect: [:a | a name withBlanksTrimmed asLowercase beginsWith: lastKeystrokes]
				ifNone: [^ self preferenceList flash"match not found"].
	nextSelection := self selectedCategoryPreferences findFirst: [:a | a  = nextSelectionPref].
	"No change if model is locked"
	oldSelection == nextSelection ifTrue: [^ self preferenceList flash].
	^ self selectedPreferenceIndex: nextSelection! !

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:16'!
downKeyPressed: anEvent
	self selectedPreferenceIndex:
		(self selectedPreferenceIndex + 1 
				min: self selectedCategoryPreferences size)! !

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:17'!
endKeyPressed: anEvent
	self selectedPreferenceIndex: self selectedCategoryPreferences size.
! !

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:16'!
homeKeyPressed: anEvent
	self selectedPreferenceIndex: 1.
! !

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:19'!
keyPressed: anEvent
	self selectedCategory 
		ifNil: [^self].
	anEvent keyValue = 30
		ifTrue: [^self upKeyPressed: anEvent].
	anEvent keyValue = 31
		ifTrue: [^self downKeyPressed: anEvent].
	anEvent keyValue = 1 
		ifTrue: [^self homeKeyPressed: anEvent].
	anEvent keyValue = 4
		ifTrue: [^self endKeyPressed: anEvent].
	anEvent keyValue = 11
		ifTrue: [^self pageUpKeyPressed: anEvent].
	anEvent keyValue = 12
		ifTrue: [^self pageDownKeyPressed: anEvent].
	self basicKeyPressed: anEvent.! !

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/26/2004 23:01'!
mouseDownOn: aPreferenceView event: anEvent
	anEvent hand newKeyboardFocus: self preferenceList scroller.
	anEvent yellowButtonPressed
		ifTrue: [aPreferenceView offerPreferenceNameMenu: self model]! !

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:24'!
pageDownKeyPressed: anEvent
	self selectedPreferenceIndex: (self selectedPreferenceIndex + self preferencesShowing size min: self selectedCategoryPreferences size).
! !

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:30'!
pageUpKeyPressed: anEvent
	self selectedPreferenceIndex: (self selectedPreferenceIndex - self preferencesShowing size max: 1).
! !

!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:16'!
upKeyPressed: anEvent
	self selectedPreferenceIndex: 
			(self selectedPreferenceIndex - 1 max: 1).
! !


!PreferenceBrowserMorph methodsFor: 'geometry' stamp: 'hpt 9/18/2004 21:05'!
extent: aPoint
	super extent: aPoint.
	self fullBounds.
	self adjustPreferenceListItemsWidth.! !


!PreferenceBrowserMorph methodsFor: 'initialization' stamp: 'hpt 9/19/2004 02:52'!
initializeWithModel: aPreferenceBrowser
	lastKeystrokeTime := 0.
	lastKeystrokes := ''.
	self 
		model: aPreferenceBrowser;
		clipSubmorphs: true;
		setLabel: self model windowTitle;
		name: 'PreferenceBrowser';
		addMorph: self rootPanel fullFrame: self rootPanelLayoutFrame;
		addMorph: self newButtonRow fullFrame: self buttonRowLayoutFrame.! !


!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'!
selectedCategory
	^self model selectedCategory! !

!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'!
selectedCategoryIndex
	^self model selectedCategoryIndex! !

!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'!
selectedCategoryIndex: anIndex
	^self model selectedCategoryIndex: anIndex! !

!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'!
selectedCategoryPreferences
	^self model selectedCategoryPreferences! !

!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'!
selectedPreference
	^self model selectedPreference! !

!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:10'!
selectedPreferenceIndex
	^self model selectedPreferenceIndex! !

!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:10'!
selectedPreferenceIndex: anIndex
	^self model selectedPreferenceIndex: anIndex! !

!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:06'!
selectedPreference: aPreference
	^self model selectedPreference: aPreference! !


!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 8/27/2005 23:58'!
basicButton
	| button |
	button := SimpleButtonMorph new.
	button
		borderWidth: 2;
		borderColor: #raised;
		on: #mouseEnter send: #value to: [button borderColor: self paneColor];
		on: #mouseLeave send: #value to: [button borderColor: #raised];
		vResizing: #spaceFill;
		useRoundedCorners;
		clipSubmorphs: true;
		color: self paneColor muchLighter;
		target: self model.
	^button! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 8/28/2005 00:04'!
buttonRowLayoutFrame 
	^LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (TextStyle defaultFont height * 2.5))! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:55'!
defaultButton
	^defaultButton ifNil: 
		[defaultButton := self basicButton 
						label: 'default' translated; 
						actionSelector: #defaultSelected;						
						setBalloonText: 
							'Click here to reset all the preferences to their standard ',
							'default values.' translated]! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'!
helpButton
	^helpButton ifNil: 
		[helpButton := self basicButton 
						label: 'help' translated; 
						setBalloonText: 
							'Click here to get some hints on use of this Preferences ',
							'Panel' translated;
						actionSelector: #helpSelected]! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'!
loadButton
	^loadButton ifNil: 
		[loadButton := self basicButton 
						label: 'load' translated; 
						actionSelector: #loadSelected;						
						setBalloonText: 
							'Click here to reset all the preferences to their values ',
							'in your Personal Preferences.' translated]! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'!
loadFromDiskButton
	^loadFromDiskButton ifNil: 
		[loadFromDiskButton := self basicButton 
						label: 'load from disk' translated; 
						actionSelector: #loadFromDiskSelected;						
						setBalloonText: 
							'Click here to load all the preferences from ',
							'their saved values on disk.' translated]! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 8/27/2005 23:59'!
newButtonRow
	^BorderedMorph new
		color: Color transparent;
		cellInset: 2;
		layoutInset: 2;
		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
		listCentering: #topLeft;
		cellPositioning: #topLeft;
		on: #mouseEnter send: #paneTransition: to: self;
		on: #mouseLeave send: #paneTransition: to: self;
		addMorphBack: self defaultButton;
		addMorphBack: self newSeparator;
		addMorphBack: self saveButton;
		addMorphBack: self loadButton;
		addMorphBack: self newSeparator;
		addMorphBack: self saveToDiskButton;
		addMorphBack: self loadFromDiskButton;
		addMorphBack: self newSeparator;
		addMorphBack: self themeButton;
		addMorphBack: self newTransparentFiller;
		addMorphBack: self helpButton;
		yourself.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:51'!
newSeparator
	^BorderedMorph new
		borderWidth: 2;
		borderColor: Color transparent;
		color: self paneColor;
		hResizing: #rigid;
		width: 5;
		vResizing: #spaceFill;
		yourself! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:49'!
newTransparentFiller
	^Morph new
		color: Color transparent;
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		yourself.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'!
saveButton
	^saveButton ifNil: 
		[saveButton := self basicButton 
						label: 'save' translated; 
						actionSelector: #saveSelected;						
						setBalloonText: 
							'Click here to save the current constellation of Preferences ',
							'settings as your personal defaults; you can get them all ',
							'reinstalled with a single gesture by clicking the "Restore ',
							'my Personal Preferences".' translated]! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'!
saveToDiskButton
	^saveToDiskButton ifNil: 
		[saveToDiskButton := self basicButton 
						label: 'save to disk' translated; 
						actionSelector: #saveToDiskSelected;						
						setBalloonText: 
							'Click here to save the current constellation of Preferences ',
							'settings to a file; you can get them all reinstalled with a ', 
							'single gesture by clicking "Restore Settings From Disk".'
								 translated]! !

!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'!
themeButton
	^themeButton ifNil: 
		[themeButton := self basicButton 
						label: 'theme...' translated; 
						actionSelector: #themeSelected;
						setBalloonText: 
							'Numerous "Preferences" govern many things about the ',
							'way Squeak looks and behaves.  Set individual preferences ',
							'using a "Preferences" panel.  Set an entire "theme" of many ',
							'Preferences all at the same time by pressing this "change ',
							'theme" button and choosing a theme to install.  Look in ',
							'category "themes" in Preferences class to see what each ', 
							'theme does; add your own methods to the "themes" ',
							'category and they will show up in the list of theme ',
							'choices.' translated].! !


!PreferenceBrowserMorph methodsFor: 'submorphs - category list' stamp: 'hpt 9/18/2004 16:07'!
newCategoryList 
	^(PluggableListMorph
		on: self model
		list: #categoryList
		selected: #selectedCategoryIndex
		changeSelected: #selectedCategoryIndex:)
			color: Color white;
			borderInset;
			vResizing: #spaceFill;
			hResizing: #rigid;
			width: 150;
			yourself.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - category list' stamp: 'hpt 8/27/2005 23:44'!
newCategoryListPanel
	^Morph new
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		color: Color transparent;
		layoutPolicy: TableLayout new;
		cellInset: 3;
		listCentering: #topLeft;
		listDirection: #topToBottom;
		cellPositioning: #topLeft;
		clipSubmorphs: true;
		addMorphBack: self newCategoryListPanelLabel;
		addMorphBack: self newCategoryList! !

!PreferenceBrowserMorph methodsFor: 'submorphs - category list' stamp: 'hpt 9/19/2004 02:29'!
newCategoryListPanelLabel 
	^StringMorph contents: 'Categories' translated.! !


!PreferenceBrowserMorph methodsFor: 'submorphs - main panel' stamp: 'hpt 9/19/2004 03:01'!
mainPanel
	^mainPanel ifNil: 
		[mainPanel := Morph new
			color: Color transparent;
			hResizing: #spaceFill;
			vResizing: #spaceFill;
			cellInset: 5;
			layoutPolicy: TableLayout new;
			listCentering: #topLeft;
			listDirection: #leftToRight;
			cellPositioning: #topLeft;
			clipSubmorphs: true;
			on: #mouseEnter send: #paneTransition: to: self;
			addMorphBack: self newCategoryListPanel;
			addMorphBack: self newPreferenceListPanel;
			yourself].! !


!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 12/8/2004 17:20'!
newPreferenceButtonFor: aPreference 
	| button |
	button := PBPreferenceButtonMorph preference: aPreference model: self model.
	button 
		on: #mouseDown
		send: #value:
		to: 
			[:anEvent | 
			self
				selectedPreference: aPreference;
				mouseDownOn: button preferenceView event: anEvent].
	^button! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 12/8/2004 17:20'!
newPreferenceListInnerPanel
	| panel maxWidth totalHeight |
	panel := (Morph new)
				color: Color transparent;
				layoutPolicy: TableLayout new;
				listDirection: #topToBottom;
				cellPositioning: #topLeft;
				yourself.
	self selectedCategoryPreferences 
		do: [:aPref | panel addMorphBack: (self newPreferenceButtonFor: aPref)].
	panel submorphs size = 0 ifTrue: [^panel].
	maxWidth := (panel submorphs detectMax: [:m | m width]) width.
	panel width: maxWidth.
	totalHeight := (panel submorphs collect: [:ea | ea height]) inject: 0
				into: [:h :tot | h + tot].
	panel height: totalHeight.
	panel fullBounds.
	^panel! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 8/27/2005 23:44'!
newPreferenceListPanel
	| panel |
	panel := Morph new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		color: Color transparent;
		layoutPolicy: TableLayout new;
		cellInset: 3;
		listCentering: #topLeft;
		listDirection: #topToBottom;
		cellPositioning: #topLeft;
		clipSubmorphs: true;
		addMorphBack: self newPreferenceListPanelLabel;
		addMorphBack: self preferenceList.
	^panel.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 9/19/2004 02:29'!
newPreferenceListPanelLabel 
	^StringMorph contents: 'Preferences' translated.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 9/25/2004 17:49'!
preferenceList 
	^preferenceList ifNil:
		[preferenceList := ScrollPane new
			color: Color white;
			borderInset;
			vResizing: #spaceFill;
			hResizing: #spaceFill.
		preferenceList scroller
			on: #mouseEnter send: #value: 
				to: [:event | event hand newKeyboardFocus: preferenceList scroller];
			on: #keyStroke send: #keyPressed: to: self.
		preferenceList.]! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 9/18/2004 21:19'!
preferenceListInnerPanel
	^self preferenceList scroller submorphs first! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 9/19/2004 00:29'!
preferencesShowing
	| prefs |
	prefs := self preferenceListInnerPanel submorphs
					copyFrom: (self selectedPreferenceIndex max: 1)
					to: self selectedCategoryPreferences size.
	^prefs reject: [:ea | (ea top - prefs first top) > self preferenceList scroller height].! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 12/8/2004 15:50'!
selectedPreferenceButton
	^(self preferenceListInnerPanel submorphs at: self selectedPreferenceIndex)! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 12/8/2004 15:54'!
turnOffSelectedPreference
	highlightedPreferenceButton 
		ifNil: [^self].
	highlightedPreferenceButton highlightOff.
	highlightedPreferenceButton := nil.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 8/28/2005 00:25'!
turnOnSelectedPreference
	highlightedPreferenceButton 
		ifNotNilDo: [:m | m highlightOff].
	highlightedPreferenceButton := self selectedPreferenceButton
		highlightOn;
		yourself.
	self preferenceList scrollToShow: highlightedPreferenceButton bounds.! !


!PreferenceBrowserMorph methodsFor: 'submorphs - root panel' stamp: 'hpt 8/27/2005 23:06'!
rootPanel
	^BorderedMorph new
		color: Color transparent;
		layoutInset: 10;
		cellInset: 10;
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		listCentering: #topLeft;
		cellPositioning: #topLeft;
		addMorphBack: self newSearchPanel;
		addMorphBack: self mainPanel;
		yourself.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - root panel' stamp: 'stephaneducasse 2/4/2006 20:39'!
rootPanelLayoutFrame 
	| frame |
	frame := self buttonRowLayoutFrame.
	^LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@(frame bottomOffset) corner: 0@0)! !


!PreferenceBrowserMorph methodsFor: 'submorphs - search panel' stamp: 'hpt 9/19/2004 02:55'!
newSearchButton
	^self basicButton
			label: 'search' translated; 
			actionSelector: #searchSelected;
			setBalloonText: 
				'Type what you want to search for here, then hit ',
				'the "Search" button, or else hit RETURN or ENTER' translated.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - search panel' stamp: 'hpt 8/27/2005 23:44'!
newSearchPanel
	| bottom |
	bottom := Morph new
		color: Color transparent;
		cellInset: 5;
		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
		listCentering: #topLeft;
		cellPositioning: #topLeft;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		addMorphBack: self newSearchTextField
		yourself.
	^Morph new
		color: Color transparent;
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		listCentering: #topLeft;
		cellPositioning: #topLeft;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		cellInset: 3;
		addMorphBack: (StringMorph contents: 'Search preferences for: ');
		addMorphBack: bottom;
		yourself.! !

!PreferenceBrowserMorph methodsFor: 'submorphs - search panel' stamp: 'hpt 7/8/2006 17:39'!
newSearchTextField
	| ptm |
	ptm := PluggableTextMorph
		on: self model
		text: #searchPattern
		accept: #searchPattern:.
	ptm
		hideVScrollBarIndefinitely: true;
		borderInset;
		color: Color white;
		vResizing: #rigid;
		hResizing: #spaceFill;
		height: TextStyle defaultFont height * 2;
		acceptOnCR: true;
		onKeyStrokeSend: #value to: [ptm hasUnacceptedEdits ifTrue: [ptm accept]].
	^ptm.! !


!PreferenceBrowserMorph methodsFor: 'updating' stamp: 'hpt 9/20/2004 23:31'!
adjustPreferenceListItemsWidth
	| panel |
	self preferenceList scroller submorphs 
		ifEmpty: [^self].
	panel := self preferenceListInnerPanel. 
	panel width: self preferenceList width - (self preferenceList scrollBarThickness*2).
	panel submorphsDo: [:ea | ea hResizing: #rigid; width: panel width].
	self preferenceList setScrollDeltas.! !

!PreferenceBrowserMorph methodsFor: 'updating' stamp: 'hpt 12/8/2004 19:10'!
updateSelectedCategoryPreferences
	Cursor wait showWhile: 
		[self preferenceList 
				hScrollBarValue: 0;
				vScrollBarValue: 0.
		self preferenceList scroller removeAllMorphs.
		self preferenceList scroller addMorphBack: self newPreferenceListInnerPanel.
		self adjustPreferenceListItemsWidth]! !

!PreferenceBrowserMorph methodsFor: 'updating' stamp: 'hpt 9/19/2004 00:08'!
updateSelectedPreference
	| index |
	self selectedCategory ifNotNil: [self turnOffSelectedPreference].
	index := self selectedPreferenceIndex.
	index = 0
		ifTrue: [^self].
	self turnOnSelectedPreference.! !

!PreferenceBrowserMorph methodsFor: 'updating' stamp: 'hpt 9/18/2004 21:16'!
update: aSymbol
	super update: aSymbol.
	aSymbol == #selectedPreference
		ifTrue: [self updateSelectedPreference].
	aSymbol == #selectedCategoryIndex
		ifTrue: [self updateSelectedCategoryPreferences].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PreferenceBrowserMorph class
	instanceVariableNames: ''!

!PreferenceBrowserMorph class methodsFor: 'instance creation' stamp: 'hpt 9/18/2004 15:31'!
withModel: aPreferenceBrowser
	^self new initializeWithModel: aPreferenceBrowser;
		yourself.! !


!PreferenceBrowserMorph class methodsFor: '*services-base' stamp: 'rr 12/30/2005 18:43'!
updateBrowsers

	(self allInstances select: [:e | e visible]) 
		do: [:each | 
			(each  findDeepSubmorphThat:[:m | m  isKindOf:PluggableListMorph]
				ifAbsent:[^ self]) verifyContents].! !
Object subclass: #PreferenceView
	instanceVariableNames: 'preference'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!PreferenceView commentStamp: '<historical>' prior: 0!
My subclasses instances are responsible for building the visual representation of each kind of preference.!


!PreferenceView methodsFor: 'accessing' stamp: 'hpt 9/24/2004 22:25'!
preference
	^preference! !


!PreferenceView methodsFor: 'initialization' stamp: 'hpt 9/24/2004 22:25'!
initializeWithPreference: aPreference
	preference := aPreference! !


!PreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 22:56'!
representativeButtonWithColor: aColor inPanel: aPreferencesPanel
	self subclassResponsibility ! !

!PreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:14'!
tearOffButton
	"Hand the user a button the can control this"

	| aButton |
	aButton := self representativeButtonWithColor: self preference defaultBackgroundColor inPanel: nil.
	aButton borderWidth: 1; borderColor:  Color black; useRoundedCorners.
	aButton openInHand! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PreferenceView class
	instanceVariableNames: 'registeredClasses'!

!PreferenceView class methodsFor: 'instance creation' stamp: 'hpt 9/24/2004 22:25'!
preference: aPreference
	^self new
		initializeWithPreference: aPreference;
		yourself! !


!PreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:09'!
handlesPanel: aPreferencePanel
	self subclassResponsibility ! !
Object subclass: #PreferenceViewRegistry
	instanceVariableNames: 'registeredClasses viewOrder'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!PreferenceViewRegistry commentStamp: '<historical>' prior: 0!
PreferenceViewRegistry is much like the AppRegistry classes.  Its purpose is to allow PreferenceBrowser implementers to register its own views for each kind of preference.!


!PreferenceViewRegistry methodsFor: 'initialize-release' stamp: 'hpt 9/26/2004 16:22'!
initialize
	viewOrder _ 1.! !


!PreferenceViewRegistry methodsFor: 'view order' stamp: 'hpt 9/26/2004 16:22'!
viewOrder
	"answer the order in which the registered views should appear relative to the other views"
	^viewOrder! !

!PreferenceViewRegistry methodsFor: 'view order' stamp: 'hpt 9/26/2004 16:22'!
viewOrder: aNumber
	viewOrder _ aNumber! !


!PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'!
register: aProviderClass
	(self registeredClasses includes: aProviderClass) 
		ifFalse: [self registeredClasses add: aProviderClass].! !

!PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'!
registeredClasses
	^registeredClasses ifNil: [registeredClasses := OrderedCollection new]! !

!PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'!
unregister: aProviderClass
	self registeredClasses remove: aProviderClass ifAbsent: []! !

!PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'!
viewClassFor: aPreferencePanel
	^self registeredClasses 
		detect: [:aViewClass| aViewClass handlesPanel: aPreferencePanel]
		ifNone: [].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PreferenceViewRegistry class
	instanceVariableNames: 'registries'!

!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'!
ofBooleanPreferences
	^(self registryOf: #booleanPreferences)
		viewOrder: 1; 
		yourself.! !

!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:24'!
ofColorPreferences
	^(self registryOf: #colorPreferences)
		viewOrder: 5;
		yourself.! !

!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:24'!
ofFontPreferences
	^(self registryOf: #fontPreferences)
		viewOrder: 4;
		yourself.! !

!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'!
ofHaloThemePreferences
	^(self registryOf: #haloThemePreferences)
		viewOrder: 2;
		yourself.! !

!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 12/9/2004 22:16'!
ofNumericPreferences
	^(self registryOf: #numericPreferences)
		viewOrder: 3;
		yourself.! !

!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'!
ofTextPreferences
	^(self registryOf: #textPreferences)
		viewOrder: 3;
		yourself.! !

!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 15:28'!
registries
	^registries ifNil: [registries _ Dictionary new]! !

!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 15:33'!
registryOf: aSymbol
	^self registries at: aSymbol ifAbsentPut: [self new]! !
Object subclass: #Preferences
	instanceVariableNames: ''
	classVariableNames: 'DesktopColor DictionaryOfPreferences Parameters'
	poolDictionaries: ''
	category: 'System-Support'!
!Preferences commentStamp: '<historical>' prior: 0!
A general mechanism to store preference choices.  The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always returned as false.  

	To open the control panel:		Preferences openFactoredPanel
	To read how to use the panel (and how to make a preference be per-project):
		 Preferences giveHelpWithPreferences

All messages are on the class side.

To query a a preference:
	Preferences logDebuggerStackToFile
or some people prefer the more verbose
	Preferences valueOfFlag: #logDebuggerStackToFile

You can make up a new preference any time.  Do not define a new message in Preferences class. Accessor methods are compiled automatically when you add a preference as illustrated below:

To add a preference (e.g. in the Postscript of a fileout):
	Preferences addPreference: #samplePreference categories: #(general browsing)
		default: true balloonHelp: 'This is an example of a preference added by a do-it'
		projectLocal: false changeInformee: nil changeSelector: nil.

To change a preference programatically:
	Preferences disable: #logDebuggerStackToFile.
Or to turn it on,
	Preferences enable: #logDebuggerStackToFile.
!
]style[(220 29 81 35 812)f1,f1dPreferences openFactoredPanel;;,f1,f1dPreferences giveHelpWithPreferences;;,f1!


!Preferences methodsFor: 'look in class' stamp: 'di 12/4/1999 15:11'!
seeClassSide
	"All the code for Preferences is on the class side"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Preferences class
	instanceVariableNames: ''!

!Preferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:14'!
dictionaryOfPreferences
	^DictionaryOfPreferences! !

!Preferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:14'!
dictionaryOfPreferences: anObject
	DictionaryOfPreferences := anObject! !


!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:00'!
addBooleanPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addPreference: prefSymbol  categories: categoryList  default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/5/2004 13:28'!
addBooleanPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol  changeSelector: aChangeSelector
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean"

	self addPreference: prefSymbol  categories: categoryList default:  aValue balloonHelp: helpString  projectLocal: localBoolean  changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:01'!
addBooleanPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addPreference: prefSymbol  categories: {categorySymbol} default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'!
addColorPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addPreference: prefSymbol  categories: categoryList  default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofColorPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'!
addColorPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addPreference: prefSymbol  categories: {categorySymbol} default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofColorPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'!
addFontPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addPreference: prefSymbol  categories: categoryList  default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofFontPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'!
addFontPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addPreference: prefSymbol  categories: {categorySymbol} default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofFontPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/9/2004 22:15'!
addNumericPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. "

	self addPreference: prefSymbol  categories: categoryList  default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofNumericPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/9/2004 22:15'!
addNumericPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system."

	self addPreference: prefSymbol  categories: {categorySymbol} default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofNumericPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:05'!
addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"
	self addBooleanPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString.! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/5/2004 13:29'!
addPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol  changeSelector: aChangeSelector
	"Add an item representing the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addBooleanPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol  changeSelector: aChangeSelector
! !

!Preferences class methodsFor: 'add preferences' stamp: 'rr 10/1/2005 15:14'!
addPreference: aName categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: aViewRegistry 
	"Add or replace a preference as indicated.  Reuses the preexisting Preference object for this symbol, if there is one, so that UI artifacts that interact with it will remain valid."

	| aPreference aPrefSymbol |
	aPrefSymbol _ aName asSymbol.
	aPreference _ self dictionaryOfPreferences  at:aPrefSymbol
				 ifAbsent:[Preference new].
	aPreference 
		 name:aPrefSymbol
		 defaultValue:aValue
		 helpString:helpString
		 localToProject:localBoolean
		 categoryList:categoryList
		 changeInformee:informeeSymbol
		 changeSelector:aChangeSelector
		 viewRegistry:aViewRegistry.
	self dictionaryOfPreferences  at:aPrefSymbol  put:aPreference.
	self  compileAccessMethodForPreference:aPreference! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:05'!
addPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 
	"Add the given preference, putting it in the given category, with the given default value, and with the given balloon help. It assumes boolean preference for backward compatibility"

	self addBooleanPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString.! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'!
addTextPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addPreference: prefSymbol  categories: categoryList  default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofTextPreferences ! !

!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'!
addTextPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 
	"Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility"

	self addPreference: prefSymbol  categories: {categorySymbol} default:  defaultValue balloonHelp: helpString  projectLocal: false  changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofTextPreferences ! !


!Preferences class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:18'!
initialize

	self registerInFlapsRegistry.	! !

!Preferences class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:20'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(Preferences	preferencesControlPanel	'Preferences'	'Allows you to control numerous options')
						forFlapNamed: 'Tools'.
						cl registerQuad: #(Preferences			annotationEditingWindow	'Annotations'		'Allows you to specify the annotations to be shown in the annotation panes of browsers, etc.')
						forFlapNamed: 'Tools'.]! !

!Preferences class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:38'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 4/10/2001 14:29'!
categoriesContainingPreference: prefSymbol
	"Return a list of all categories in which the preference occurs"

	^ (self preferenceAt: prefSymbol ifAbsent: [^ #(unclassified)]) categoryList! !


!Preferences class methodsFor: 'fonts' stamp: 'sw 7/25/2004 20:03'!
attemptToRestoreClassicFonts
	"If certain fonts formerly used in early versions of Squeak happen to be present in the image, restore them to their corresponding roles.  Not called by any other method -- intended to be invoked via do-it, possibly in a postscript"
	"Preferences attemptToRestoreClassicFonts"

	| aTextStyle |
	#(	(setButtonFontTo:		NewYork		12)
		(setCodeFontTo:			NewYork		12)
		(setFlapsFontTo:			ComicBold		16)
		(setEToysFontTo:			ComicBold		16)
		(setListFontTo:			NewYork		12)
		(setMenuFontTo:			NewYork		12)
		(setWindowTitleFontTo:	NewYork		15)
		(setSystemFontTo:		NewYork		12)) do:
			[:triplet |
				(aTextStyle _ TextStyle named: triplet second) ifNotNil:
					[self perform: triplet first with: (aTextStyle fontOfSize: triplet third).
					Transcript cr; show: triplet second, ' installed as ', (triplet first copyFrom: 4 to: triplet first size - 3)]]! !

!Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:20'!
chooseBalloonHelpFont

	BalloonMorph chooseBalloonFont! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:48'!
chooseCodeFont
	"Not currently sent, but once protocols are sorted out so that we can disriminate on whether a text object being launched is for code or not, will be reincorporated"

	self chooseFontWithPrompt: 'Choose the font to be used for displaying code' translated andSendTo: self withSelector: #setCodeFontTo: highlight: self standardCodeFont.! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:48'!
chooseEToysFont
	"present a menu with the possible fonts for the eToys"
	self
		chooseFontWithPrompt: 'Choose the eToys font' translated
		andSendTo: self
		withSelector: #setEToysFontTo:
		highlight: self standardEToysFont! !

!Preferences class methodsFor: 'fonts' stamp: 'dgd 11/3/2004 21:00'!
chooseEToysTitleFont
	"present a menu with the possible fonts for the eToys"
	self
		chooseFontWithPrompt: 'Choose the eToys title font' translated
		andSendTo: self
		withSelector: #setEToysTitleFontTo:
		highlight: self standardEToysTitleFont! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:48'!
chooseFlapsFont
	self chooseFontWithPrompt: 'Choose a flaps font' translated andSendTo: self withSelector: #setFlapsFontTo: highlight: self standardFlapFont! !

!Preferences class methodsFor: 'fonts' stamp: 'laza 3/25/2004 23:11'!
chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector
	self chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: nil
! !

!Preferences class methodsFor: 'fonts' stamp: 'laza 3/25/2004 23:11'!
chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: currentFont
	Smalltalk isMorphic
		ifFalse:
			[TextStyle mvcPromptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector]
		ifTrue:
			[TextStyle promptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: currentFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'dgd 8/25/2004 17:14'!
chooseHaloLabelFont
	"present a menu with the possible fonts for label in halo"
	self
		chooseFontWithPrompt: 'halo label font'
		andSendTo: self
		withSelector: #setHaloLabelFontTo:
		highlight: self standardHaloLabelFont! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:48'!
chooseListFont
	self chooseFontWithPrompt: 'Choose the standard list font' translated andSendTo: self withSelector: #setListFontTo: highlight: self standardListFont! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:49'!
chooseMenuFont
	self chooseFontWithPrompt: 'Choose the standard menu font' translated andSendTo: self withSelector: #setMenuFontTo: highlight: self standardMenuFont! !

!Preferences class methodsFor: 'fonts' stamp: 'edc 3/3/2005 08:37'!
chooseStandardButtonFont
	self chooseFontWithPrompt: 'Choose the button font' translated andSendTo: self withSelector: #setButtonFontTo: highlight: self standardButtonFont

! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:49'!
chooseSystemFont
	self chooseFontWithPrompt: 'Choose the default text font' translated andSendTo: self withSelector: #setSystemFontTo: highlight: (TextConstants at: #DefaultTextStyle) defaultFont! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:49'!
chooseWindowTitleFont
	self chooseFontWithPrompt: 'Choose the window title font' translated andSendTo: self withSelector: #setWindowTitleFontTo: highlight: self windowTitleFont! !

!Preferences class methodsFor: 'fonts' stamp: 'dgd 4/3/2006 14:23'!
fontConfigurationMenu
	| aMenu |
	aMenu := MenuMorph new defaultTarget: Preferences.
	aMenu addTitle: 'Standard System Fonts' translated.
	
	aMenu addStayUpIcons.
	
	aMenu add: 'default text font...' translated action: #chooseSystemFont.
	aMenu balloonTextForLastItem: 'Choose the default font to be used for code and  in workspaces, transcripts, etc.' translated.
	aMenu lastItem font: Preferences standardDefaultTextFont.
	
	aMenu add: 'list font...' translated action: #chooseListFont.
	aMenu lastItem font: Preferences standardListFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in list panes' translated.
	
	aMenu add: 'flaps font...' translated action: #chooseFlapsFont.
	aMenu lastItem font: Preferences standardFlapFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used on textual flap tabs' translated.

	aMenu add: 'eToys font...' translated action: #chooseEToysFont.
	aMenu lastItem font: Preferences standardEToysFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used on eToys environment' translated.

	aMenu add: 'eToys title font...' translated action: #chooseEToysTitleFont.
	aMenu lastItem font: Preferences standardEToysTitleFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in titles on eToys environment' translated.

	aMenu add: 'halo label font...' translated action: #chooseHaloLabelFont.
	aMenu lastItem font: Preferences standardHaloLabelFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used on labels ih halo' translated.

	aMenu add: 'menu font...' translated action: #chooseMenuFont.
	aMenu lastItem font: Preferences standardMenuFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in menus' translated.
	
	aMenu add: 'window-title font...' translated action: #chooseWindowTitleFont.
	aMenu lastItem font: Preferences windowTitleFont emphasis: 1.
	aMenu balloonTextForLastItem: 'Choose the font to be used in window titles.' translated.

	aMenu add: 'balloon-help font...' translated action: #chooseBalloonHelpFont.
	aMenu lastItem font: Preferences standardBalloonHelpFont.
	aMenu balloonTextForLastItem: 'choose the font to be used when presenting balloon help.' translated.
	
	aMenu add: 'code font...' translated action: #chooseCodeFont. 
	aMenu lastItem font: Preferences standardCodeFont. 
	aMenu balloonTextForLastItem: 'Choose the font to be used in code panes.' translated.

	aMenu add: 'button font...' translated action: #chooseStandardButtonFont.
	aMenu lastItem font: Preferences standardButtonFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in buttons.' translated.

	aMenu addLine.
	aMenu add: 'demo mode' translated action: #setDemoFonts.
	aMenu balloonTextForLastItem: 'Set Fonts usable for giving a presentation' translated.

	aMenu addLine.
	aMenu add: 'restore default font choices' translated action: #restoreDefaultFonts.
	aMenu balloonTextForLastItem: 'Use the standard system font defaults' translated.
	
	aMenu add: 'print default font choices' translated action: #printStandardSystemFonts.
	aMenu balloonTextForLastItem: 'Print the standard system font defaults to the Transcript' translated.

	^ aMenu! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 11:37'!
printStandardSystemFonts
	"self printStandardSystemFonts"

	| string |
	string := String streamContents: [ :s |

	#(standardDefaultTextFont standardListFont standardFlapFont 
	standardEToysFont standardMenuFont windowTitleFont 
	standardBalloonHelpFont standardCodeFont standardButtonFont) do: [:selector |
		| font |
		font _ Preferences perform: selector.
		s
			nextPutAll: selector; space;
			nextPutAll: font familyName; space;
			nextPutAll: (AbstractFont emphasisStringFor: font emphasis);
			nextPutAll: ' points: ';
			print: font pointSize;
			nextPutAll: ' height: ';
			print: font height;
			cr
		]].

	(StringHolder new)
		contents: string;
		openLabel: 'Current system font settings' translated.
! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 7/18/2004 15:34'!
refreshFontSettings
	"Try to update all the current font settings to make things consistent."

	self setFlapsFontTo: (self standardFlapFont);
		setEToysFontTo: (self standardEToysFont);
		setWindowTitleFontTo: (self windowTitleFont);
		setListFontTo: (self standardListFont);
		setMenuFontTo: (self standardMenuFont);
		setSystemFontTo: (TextStyle defaultFont);
		setCodeFontTo: (self standardCodeFont);
		setBalloonHelpFontTo: (BalloonMorph balloonFont).

	SystemWindow allSubInstancesDo: [ :s | | rawLabel |
		rawLabel := s getRawLabel.
		rawLabel owner vResizing: #spaceFill.
		rawLabel font: rawLabel font.
		s setLabel: s label.
		s replaceBoxes ].! !

!Preferences class methodsFor: 'fonts' stamp: 'yo 1/12/2005 22:43'!
restoreDefaultFonts
	"Since this is called from menus, we can take the opportunity to prompt for missing font styles."
	"
	Preferences restoreDefaultFonts
	"

	self setDefaultFonts: #(
		(setSystemFontTo:		Accuny				10)
		(setListFontTo:			Accuny				10)
		(setFlapsFontTo:			Accushi				12)
		(setEToysFontTo:			BitstreamVeraSansBold	9)
		(setPaintBoxButtonFontTo:			BitstreamVeraSansBold	9)
		(setMenuFontTo:			Accuny				10)
		(setWindowTitleFontTo:	BitstreamVeraSansBold	12)
		(setBalloonHelpFontTo:	Accujen				9)
		(setCodeFontTo:			Accuny				10)
		(setButtonFontTo:		BitstreamVeraSansMono				9)
	)
! !

!Preferences class methodsFor: 'fonts' stamp: 'yo 7/28/2004 21:25'!
restoreDefaultFontsForJapanese
	"Preferences restoreDefaultFontsForJapanese"
	#(	"(setButtonFontTo:		ComicBold		15)"
		"(setTextButtonFontTo:		NewYork		12)"
		"(setCodeFontTo:			NewYork		12)"  "Later"
		(setFlapsFontTo:			NewYork		15)
		(setListFontTo:			NewYork		12)
		(setMenuFontTo:			NewYork		12)
		(setWindowTitleFontTo:	NewYork		15)
		(setSystemFontTo:		NewYork		12)) do:
			[:triplet |
				self perform: triplet first with: (StrikeFontSet familyName: triplet second size: triplet third)].

	self setButtonFontTo: (StrikeFont familyName: #ComicBold size: 16).

	Smalltalk at: #BalloonMorph ifPresent:
		[:thatClass | thatClass setBalloonFontTo: (StrikeFontSet familyName: #NewYork size: 12)].

	"Note:  The standardCodeFont is not currently used -- the default font is instead; later hopefully we can split the code font out as  a separate choice, but only after we're able to have the protocols reorganized such that we can know whether it's code or not when we launch the text object.

	Note:  The standard button font is reset by this code but is not otherwise settable by a public UI (too many things can go afoul) "! !

!Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:46'!
setBalloonHelpFontTo: aFont

	Smalltalk at: #BalloonMorph ifPresent:
		[:thatClass | thatClass setBalloonFontTo: aFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 22:06'!
setButtonFontTo: aFont
	Parameters at: #standardButtonFont put: aFont! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 7/25/2004 17:26'!
setCodeFontTo: aFont
	"Establish the code font."

	Parameters at: #standardCodeFont put: aFont! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:19'!
setDefaultFonts: defaultFontsSpec
	"Since this is called from menus, we can take the opportunity to prompt for missing font styles."

	| fontNames map emphases |
	fontNames _ defaultFontsSpec collect: [:array | array second].
	map _ IdentityDictionary new.
	emphases _ IdentityDictionary new.
	fontNames do: [:originalName | | decoded style response |
		decoded := TextStyle decodeStyleName: originalName.
		style _ map at: originalName put: (TextStyle named: decoded second).
		emphases at: originalName put: decoded first.
		style ifNil: [
			response _ TextStyle modalStyleSelectorWithTitle: 'Choose replacement for text style ', originalName.
			map at: originalName put: (response ifNil: [TextStyle default])]].

	defaultFontsSpec do: [:triplet | self
		perform: triplet first
		with: (((map at: triplet second) fontOfPointSize: triplet third) emphasis: (emphases at: triplet second))]! !

!Preferences class methodsFor: 'fonts' stamp: 'md 3/7/2006 10:27'!
setDemoFonts
	"Preferences setDemoFonts"

	self setDefaultFonts: #(
		(setSystemFontTo:			BitstreamVeraSans			 		12)
		(setListFontTo:				BitstreamVeraSans					14)
		(setFlapsFontTo:				Accushi								12)
		(setEToysFontTo:				BitstreamVeraSansBold				9)
		(setPaintBoxButtonFontTo:	BitstreamVeraSansBold				9)
		(setMenuFontTo:				BitstreamVeraSans					14)
		(setWindowTitleFontTo:		BitstreamVeraSansBold				12)
		(setBalloonHelpFontTo:		Accujen								18)
		(setCodeFontTo:				BitstreamVeraSans					18)
		(setButtonFontTo:			BitstreamVeraSansMono				14)
	)
! !

!Preferences class methodsFor: 'fonts' stamp: 'dgd 7/12/2003 11:52'!
setEToysFontTo: aFont 
	"change the font used in eToys environment"
	Parameters at: #eToysFont put: aFont! !

!Preferences class methodsFor: 'fonts' stamp: 'dgd 11/3/2004 15:03'!
setEToysTitleFontTo: aFont 
	"change the font used in eToys environment"
	Parameters at: #eToysTitleFont put: aFont! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 18:15'!
setFlapsFontTo: aFont

	Parameters at: #standardFlapFont put: aFont.
	FlapTab allSubInstancesDo:
		[:aFlapTab | aFlapTab reformatTextualTab]! !

!Preferences class methodsFor: 'fonts' stamp: 'mir 8/24/2004 12:34'!
setHaloLabelFontTo: aFont 
	"change the font used in eToys environment"
	Parameters at: #haloLabelFont put: aFont! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 4/17/2001 11:34'!
setListFontTo: aFont
	"Set the list font as indicated"

	Parameters at: #standardListFont put: aFont.
	ListParagraph initialize.
	Flaps replaceToolsFlap! !

!Preferences class methodsFor: 'fonts' stamp: 'dgd 4/3/2006 14:21'!
setMenuFontTo: aFont
	"rbb 2/18/2005 12:54 - How should this be changed to work
	with the UIManager, if at all?"
	Parameters at: #standardMenuFont put: aFont.
	PopUpMenu setMenuFontTo: aFont.
	TheWorldMainDockingBar updateInstances.! !

!Preferences class methodsFor: 'fonts' stamp: 'yo 1/12/2005 22:43'!
setPaintBoxButtonFontTo: aFont 
	"change the font used in the buttons in PaintBox."
	Parameters at: #paintBoxButtonFont put: aFont! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 4/17/2001 11:34'!
setSystemFontTo: aFont
	"Establish the default text font and style"

	| aStyle newDefaultStyle |
	aFont ifNil: [^ self].
	aStyle _ aFont textStyle ifNil: [^ self].
	newDefaultStyle _ aStyle copy.
	newDefaultStyle defaultFontIndex: (aStyle fontIndexOf: aFont).
	TextConstants at: #DefaultTextStyle put: newDefaultStyle.
	Flaps replaceToolsFlap.
	ScriptingSystem resetStandardPartsBin! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 4/17/2001 13:28'!
setWindowTitleFontTo: aFont
	"Set the window-title font to be as indicated"

	Parameters at: #windowTitleFont put: aFont.
	StandardSystemView setLabelStyle.
	Flaps replaceToolsFlap! !

!Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:19'!
standardBalloonHelpFont
	^BalloonMorph balloonFont! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:13'!
standardButtonFont
	"Answer an attractive font to use for buttons"
	"Answer the font to be used for textual flap tab labels"
	^ Parameters at: #standardButtonFont ifAbsent:
		[Parameters at: #standardButtonFont put: (StrikeFont familyName: #ComicBold size: 16)]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:58'!
standardCodeFont
	"Answer the font to be used in code"

	 ^ Parameters at: #standardCodeFont ifAbsent:
		[Parameters at: #standardCodeFont put: TextStyle defaultFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:24'!
standardDefaultTextFont
	^TextStyle defaultFont! !

!Preferences class methodsFor: 'fonts' stamp: 'nk 7/12/2003 08:50'!
standardEToysFont
	"Answer the font to be used in the eToys environment"
	^ Parameters
		at: #eToysFont
		ifAbsent: [Parameters at: #eToysFont put: self standardButtonFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'dgd 11/3/2004 15:02'!
standardEToysTitleFont
	"Answer the font to be used in the eToys environment"
	^ Parameters
		at: #eToysTitleFont
		ifAbsent: [Parameters at: #eToysTitleFont put: self standardEToysFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:13'!
standardFlapFont
	"Answer the font to be used for textual flap tab labels"
	^ Parameters at: #standardFlapFont ifAbsent:
		[Parameters at: #standardFlapFont put: self standardButtonFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'mir 8/24/2004 12:34'!
standardHaloLabelFont
	"Answer the font to be used in the eToys environment"
	^ Parameters
		at: #haloLabelFont
		ifAbsent: [Parameters at: #haloLabelFont put: TextStyle defaultFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:09'!
standardListFont
	"Answer the font to be used in lists"

	 ^ Parameters at: #standardListFont ifAbsent:
		[Parameters at: #standardListFont put: TextStyle defaultFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:58'!
standardMenuFont
	"Answer the font to be used in menus"

	 ^ Parameters at: #standardMenuFont ifAbsent:
		[Parameters at: #standardMenuFont put: TextStyle defaultFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'yo 1/12/2005 22:40'!
standardPaintBoxButtonFont
	"Answer the font to be used in the eToys environment"
	^ Parameters
		at: #paintBoxButtonFont
		ifAbsent: [Parameters at: #paintBoxButtonFont put: self standardButtonFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:10'!
windowTitleFont
	"Answer the standard font to use for window titles"
	^  Parameters at: #windowTitleFont ifAbsent:
		[Parameters at: #windowTitleFont put: (StrikeFont familyName: #NewYork size: 15)]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 22:18'!
windowTitleStyle
	"Answer the standard style to use for window titles"
	^  self windowTitleFont textStyle! !


!Preferences class methodsFor: 'get/set' stamp: 'dgd 8/31/2003 18:07'!
automaticFlapLayoutString
	"Answer a string for the automaticFlapLayout menu item"
	^ (self automaticFlapLayout
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'automatic flap layout' translated! !

!Preferences class methodsFor: 'get/set' stamp: 'sw 1/19/2000 13:51'!
disableGently: preferenceNameSymbol
	"Unlike #disable:, this on does not reset the CategoryInfo cache"
	self setPreference: preferenceNameSymbol toValue: false! !

!Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'!
disable: aSymbol
	"Shorthand access to enabling a preference of the given name.  If there is none in the image, conjure one up"

	| aPreference |
	aPreference _ self preferenceAt: aSymbol ifAbsent:
		[self addPreference: aSymbol category: 'unclassified' default: false balloonHelp: 'this preference was added idiosyncratically and has no help message.'.
		self preferenceAt: aSymbol].
	aPreference preferenceValue: false! !

!Preferences class methodsFor: 'get/set' stamp: 'sw 11/11/1998 11:40'!
doesNotUnderstand: aMessage
	"Look up the message selector as a flag."
	aMessage arguments size > 0 ifTrue: [^ super doesNotUnderstand: aMessage].
	^ self valueOfFlag: aMessage selector
! !

!Preferences class methodsFor: 'get/set' stamp: 'sw 1/19/2000 13:53'!
enableGently: preferenceNameSymbol
	"Unlike #enable:, this one does not reset the CategoryInfo cache"
	self setPreference: preferenceNameSymbol toValue: true! !

!Preferences class methodsFor: 'get/set' stamp: 'sw 8/12/2000 01:26'!
enableOrDisable: preferenceNameSymbol asPer: aBoolean
	"either enable or disable the given Preference, depending on the value of aBoolean"

	aBoolean ifTrue: [self enable: preferenceNameSymbol] ifFalse: [self disable: preferenceNameSymbol]! !

!Preferences class methodsFor: 'get/set' stamp: 'sw 7/13/2001 21:34'!
enableProjectNavigator
	"Answer whether the project-navigator menu item should be enabled"

	^ true! !

!Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'!
enable: aSymbol
	"Shorthand access to enabling a preference of the given name.  If there is none in the image, conjure one up"

	| aPreference |
	aPreference _ self preferenceAt: aSymbol ifAbsent:
		[self addPreference: aSymbol category: 'unclassified' default: true balloonHelp: 'this preference was added idiosyncratically and has no help message.'.
		self preferenceAt: aSymbol].
	aPreference preferenceValue: true! !

!Preferences class methodsFor: 'get/set' stamp: 'dgd 8/31/2003 18:03'!
navigatorShowingString
	"Answer a string for the show-project-navigator menu item"
	^ (self showProjectNavigator
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'show navigator (N)' translated! !

!Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'!
setPreference: prefSymbol toValue: aBoolean
	"Set the given preference to the given value, and answer that value"

	^ (self preferenceAt: prefSymbol ifAbsent: [^ aBoolean]) preferenceValue: aBoolean! !

!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:50'!
togglePreference: prefSymbol
	"Toggle the given preference. prefSymbol must be of a boolean preference"
	(self preferenceAt: prefSymbol ifAbsent: [self error: 'unknown preference: ', prefSymbol]) togglePreferenceValue! !

!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'!
valueOfFlag: aFlagName
	"Utility method for all the preferences that are boolean, and for backward compatibility"
	^self valueOfPreference: aFlagName ifAbsent: [false].! !

!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:48'!
valueOfFlag: aFlagName ifAbsent: booleanValuedBlock
	"the same as in #valueOfFlag:"
	^self valueOfPreference: aFlagName ifAbsent: booleanValuedBlock.! !

!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'!
valueOfPreference: aPreferenceSymbol
	"Answer the value of the given preference"
	^self valueOfPreference: aPreferenceSymbol ifAbsent: []! !

!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'!
valueOfPreference: aPreferenceSymbol ifAbsent: booleanValuedBlock
	"Answer the value of the given preference"
	^ (self preferenceAt: aPreferenceSymbol ifAbsent: [^ booleanValuedBlock value]) preferenceValue! !


!Preferences class methodsFor: 'halos' stamp: 'sw 12/30/2004 01:42'!
classicHaloSpecs
	"Non-iconic halos with traditional placements"

	"Preferences installClassicHaloSpecs"
	"Preferences resetHaloSpecifications"  "  <-  will result in the standard default halos being reinstalled"
	"NB: listed below in clockwise order"

		^ #(
	"  	selector				horiz		vert			color info						icon key
		---------				------		-----------		-------------------------------		---------------"
	(addMenuHandle:		left			top				(red)							none)
	(addDismissHandle:		leftCenter	top				(red		muchLighter)			'Halo-Dismiss')
	(addGrabHandle:			center		top				(black)							none)
	(addDragHandle:			rightCenter	top				(brown)							none)
	(addDupHandle:			right		top				(green)							none)	
	(addMakeSiblingHandle:		right		top				(green muchDarker)				'Halo-Dup')	
	(addDebugHandle:		right		topCenter		(blue	veryMuchLighter)		none)
	(addPoohHandle:			right		center			(white)							none)
	(addPaintBgdHandle:		right		center			(lightGray)						none)
	(addRepaintHandle:		right		center			(lightGray)						none)
	(addGrowHandle:		right		bottom			(yellow)						none)
	(addScaleHandle:		right		bottom			(lightOrange)					none)
	(addFontEmphHandle:	rightCenter	bottom			(lightBrown darker)				none)
	(addFontStyleHandle:		center		bottom			(lightRed)						none)
	(addFontSizeHandle:		leftCenter	bottom			(lightGreen)						none)

	(addRecolorHandle:		right		bottomCenter	(magenta darker)				none)

	(addRotateHandle:		left			bottom			(blue)							none))

! !

!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'!
classicHalosInForce
	^ (self preferenceAt: #haloTheme) preferenceValue == #classicHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'laza 3/24/2000 16:05'!
customHaloSpecs
	"Intended for you to modify to suit your personal preference.  What is implemented in the default here is just a skeleton; in comment at the bottom of this method are some useful lines you may wish to paste in to the main body here, possibly modifying positions, colors, etc..
	Note that in this example, we include:
			Dismiss handle, at top-left
			Menu handle, at top-right
			Resize handle, at bottom-right
			Rotate handle, at bottom-left
			Drag handle, at top-center
			Recolor handle, at left-center.  (this one is NOT part of the standard formulary --
											it is included here to illustrate how to
 											add non-standard halos)
			Note that the optional handles for specialized morphs, such as Sketch, Text, PasteUp, are also included"

	^ #(
	(addDismissHandle:		left			top				(red		muchLighter)			'Halo-Dismiss')
	(addMenuHandle:		right		top				(red)							'Halo-Menu')
	(addDragHandle:			center	top					(brown)							'Halo-Drag')
	(addGrowHandle:		right		bottom			(yellow)						'Halo-Scale')
	(addScaleHandle:		right		bottom			(lightOrange)					'Halo-Scale')

	(addRecolorHandle:		left			center			(green muchLighter lighter)		'Halo-Recolor')

	(addPaintBgdHandle:		right		center			(lightGray)						'Halo-Paint')
	(addRepaintHandle:		right		center			(lightGray)						'Halo-Paint')
	(addFontSizeHandle:		leftCenter	bottom			(lightGreen)						'Halo-FontSize')
	(addFontStyleHandle:		center		bottom			(lightRed)						'Halo-FontStyle')
	(addFontEmphHandle:	rightCenter	bottom			(lightBrown darker)				'Halo-FontEmph')
	(addRotateHandle:		left			bottom			(blue)							'Halo-Rot')

	(addDebugHandle:		right		topCenter		(blue	veryMuchLighter)		'Halo-Debug')
	(addPoohHandle:			right		center			(white)							'Halo-Pooh')


			)

	"  Other useful handles...

  		selector				horiz		vert			color info						icon key
		---------				------		-----------		-------------------------------		---------------

	(addTileHandle:			left			bottomCenter	(lightBrown)					'Halo-Tile')
	(addViewHandle:			left			center			(cyan)							'Halo-View')
	(addGrabHandle:			center		top				(black)							'Halo-Grab')
	(addDragHandle:			rightCenter	top				(brown)							'Halo-Drag')
	(addDupHandle:			right		top				(green)							'Halo-Dup')	
	(addHelpHandle:			center		bottom			(lightBlue)						'Halo-Help')
	(addFewerHandlesHandle:	left		topCenter		(paleBuff)						'Halo-FewerHandles')
	(addPaintBgdHandle:		right		center			(lightGray)						'Halo-Paint')
	(addRepaintHandle:		right		center			(lightGray)						'Halo-Paint')
	"
! !

!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'!
customHalosInForce
	^ (self preferenceAt: #haloTheme) preferenceValue == #customHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'ar 9/27/2005 20:32'!
editCustomHalos

	ToolSet browse: Preferences class
		selector: #customHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'sw 10/30/2000 13:32'!
haloSpecifications
	"Answer a list of HaloSpecs that describe which halos are to be used, what they should look like, and where they should be situated"

	^ Parameters at: #HaloSpecs ifAbsent:
			[self installHaloTheme: #iconicHaloSpecifications.
			^ Parameters at: #HaloSpecs]

	"Preferences haloSpecifications"
	"Preferences resetHaloSpecifications"
! !

!Preferences class methodsFor: 'halos' stamp: 'dgd 10/21/2004 12:17'!
haloSpecificationsForWorld
	| desired |
	"Answer a list of HaloSpecs that describe which halos are to be used on a world halo, what they should look like, and where they should be situated"
	"Preferences resetHaloSpecifications"

	desired _ #(addDebugHandle: addMenuHandle: addTileHandle: addViewHandle: addHelpHandle: addScriptHandle: addPaintBgdHandle: addRecolorHandle:).
	^ self haloSpecifications select:
		[:spec | desired includes: spec addHandleSelector]! !

!Preferences class methodsFor: 'halos'!
haloTheme
	^ self
		valueOfFlag: #haloTheme
		ifAbsent: [#iconicHaloSpecifications]! !

!Preferences class methodsFor: 'halos' stamp: 'sw 12/29/2004 22:16'!
iconicHaloSpecifications
	"Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme"

	"Preferences resetHaloSpecifications"

	^ #(
	"  	selector				horiz		vert			color info						icon key
		---------				------		-----------		-------------------------------		---------------"
	(addCollapseHandle:		left			topCenter		(tan)							'Halo-Collapse')
	(addPoohHandle:			right		center			(white)							'Halo-Pooh')
	(addDebugHandle:		right		topCenter		(blue	veryMuchLighter)		'Halo-Debug')
	(addDismissHandle:		left			top				(red		muchLighter)			'Halo-Dismiss')
	(addRotateHandle:		left			bottom			(blue)							'Halo-Rot')
	(addMenuHandle:		leftCenter	top				(red)							'Halo-Menu')
	(addTileHandle:			left			bottomCenter	(lightBrown)					'Halo-Tile')
	(addViewHandle:			left			center			(cyan)							'Halo-View')
	(addGrabHandle:			center		top				(black)							'Halo-Grab')
	(addDragHandle:			rightCenter	top				(brown)							'Halo-Drag')
	(addDupHandle:			right		top				(green)							'Halo-Dup')	
	(addMakeSiblingHandle:	right		top				(green muchDarker)				'Halo-Dup')	
	(addHelpHandle:			center		bottom			(lightBlue)						'Halo-Help')
	(addGrowHandle:		right		bottom			(yellow)						'Halo-Scale')
	(addScaleHandle:		right		bottom			(lightOrange)					'Halo-Scale')
	(addScriptHandle:		rightCenter	bottom			(green muchLighter)			'Halo-Script')
	(addPaintBgdHandle:		right		center			(lightGray)						'Halo-Paint')
	(addViewingHandle:		leftCenter	bottom			(lightGreen lighter)				'Halo-View')
	(addRepaintHandle:		right		center			(lightGray)						'Halo-Paint')
	(addFontSizeHandle:		leftCenter	bottom			(lightGreen)						'Halo-FontSize')
	(addFontStyleHandle:		center		bottom			(lightRed)						'Halo-FontStyle')
	(addFontEmphHandle:	rightCenter	bottom			(lightBrown darker)				'Halo-FontEmph')
	(addRecolorHandle:		right		bottomCenter	(magenta darker)				'Halo-Recolor')
	(addChooseGraphicHandle:	right	bottomCenter	(green muchLighter)			'Halo-ChooseGraphic')
		) ! !

!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'!
iconicHalosInForce
	^ (self preferenceAt: #haloTheme) preferenceValue == #iconicHaloSpecifications! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:35'!
installClassicHaloSpecs
	"Install an alternative set of halos,  rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.."
	"Preferences installClassicHaloSpecs"
	"Preferences resetHaloSpecifications"  "  <-  will result in the standard default halos being reinstalled"
	self installHaloTheme: #classicHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'!
installCustomHaloSpecs
	"Install an alternative set of halos, as customized by the user"
	"Preferences installCustomHaloSpecs"
	self installHaloTheme: #customHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 16:45'!
installHaloSpecsFromArray: anArray

	| aColor |
	^ Parameters at: #HaloSpecs put: 
		(anArray collect:
			[:quin |
				aColor _ Color.
				quin fourth do: [:sel | aColor _ aColor perform: sel].
				HaloSpec new 
					horizontalPlacement: quin second
					verticalPlacement: quin third 
					color: aColor
					iconSymbol: quin fifth
					addHandleSelector: quin first])! !

!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:35'!
installHaloTheme: themeSymbol
	self installHaloSpecsFromArray: (self perform: themeSymbol).
	(self preferenceAt: #haloTheme) preferenceValue: themeSymbol.
	! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'!
installIconicHaloSpecs
	"Install an alternative set of halos,  rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.."
	"Preferences installIconicHaloSpecs"
	self installHaloTheme: #iconicHaloSpecifications! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'!
installSimpleHaloSpecs
	"Preferences installSimpleHaloSpecs"
	self installHaloTheme: #simpleFullHaloSpecifications! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/25/2000 20:10'!
resetHaloSpecifications
	"Preferences resetHaloSpecifications"

	^ Parameters removeKey: #HaloSpecs ifAbsent: []! !

!Preferences class methodsFor: 'halos' stamp: 'sw 11/6/2000 10:02'!
showChooseGraphicHaloHandle
	"Hard-coded; reimplement to change behavior.  If this preference is set to true, then a choose-graphic halo handle may appear on the halo of SketchMorphs"

	^ false! !

!Preferences class methodsFor: 'halos' stamp: 'sw 7/28/2004 16:26'!
simpleFullHaloSpecifications
	"This method gives the specs for the 'full' handles variant when simple halos are in effect"

	"Preferences resetHaloSpecifications"

	^ #(
	"  	selector				horiz		vert			color info						icon key
		---------				------		-----------		-------------------------------		---------------"
	(addDebugHandle:		right		topCenter		(blue	veryMuchLighter)		'Halo-Debug')
	(addPoohHandle:			right		center			(white)							'Halo-Pooh')
	(addDismissHandle:		left			top				(red		muchLighter)			'Halo-Dismiss')
	(addRotateHandle:		left			bottom			(blue)							'Halo-Rot')
	(addMenuHandle:		leftCenter	top				(red)							'Halo-Menu')
	(addTileHandle:			left			bottomCenter	(lightBrown)					'Halo-Tile')
	(addViewHandle:			left			center			(cyan)							'Halo-View')
	(addGrabHandle:			center		top				(black)							'Halo-Grab')
	(addDragHandle:			rightCenter	top				(brown)							'Halo-Drag')
	(addDupHandle:			right		top				(green)							'Halo-Dup')	
	(addMakeSiblingHandle:	right		top				(green muchDarker)				'Halo-Dup')	
	(addHelpHandle:			center		bottom			(lightBlue)						'Halo-Help')
	(addGrowHandle:		right		bottom			(yellow)						'Halo-Scale')
	(addScaleHandle:		right		bottom			(lightOrange)					'Halo-Scale')
	(addFewerHandlesHandle:	left		topCenter		(paleBuff)						'Halo-FewerHandles')
	(addScriptHandle:		right		bottomCenter	(green muchLighter)			'Halo-Script')
	(addPaintBgdHandle:		right		center			(lightGray)						'Halo-Paint')
	(addRepaintHandle:		right		center			(lightGray)						'Halo-Paint')
	(addFontSizeHandle:		leftCenter	bottom			(lightGreen)						'Halo-FontSize')
	(addFontStyleHandle:		center		bottom			(lightRed)						'Halo-FontStyle')
	(addFontEmphHandle:	rightCenter	bottom			(lightBrown darker)		  'Halo-FontEmph')
	(addRecolorHandle:		right		bottomCenter	(magenta darker)				'Halo-Recolor')

		) ! !

!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'!
simpleHalosInForce
	^ (self preferenceAt: #haloTheme) preferenceValue == #simpleFullHaloSpecifications! !


!Preferences class methodsFor: 'hard-coded prefs' stamp: 'ar 9/28/2005 15:04'!
browseToolClass
	"This method is used for returning the appropiate class for the #browserShowsPackagePane preference. Now that preference modifies the registry so here we query directly to the registry"
	^ SystemBrowser default.! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'programmatic 7/15/1999 09:55'!
cmdKeysInText
	"compiled programatically -- return hard-coded preference value"
	^ true! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 12/1/1999 13:04'!
debugMenuItemsInvokableFromScripts
	"If true, then items occurring in an object's debug menu will be included in the alternatives offered as arguments to a doMenuItem: tile in the scripting system"
	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 9/6/2000 05:26'!
desktopMenuTitle
	"Answer the title to be used for the 'meta menu'.  For now, you can hard-code this, later someone should make this be a parameter the user can easily change.  sw 9/6/2000"

	^ 'World'    "This is what it has always been"

	"^ 'Desktop'
	^ 'Squeak'
	^ 'Mike''s Control Panel'"! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/11/2002 02:18'!
messengersInViewers
	"A coming technology..."

	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/18/2000 13:26'!
metaMenuDisabled
	"If true, then click/cmd-click on the desktop will not bring up the World menu.  Can be changed manually right here, and can be programattically changed via a call of the following form:

	Preferences compileHardCodedPref: #metaMenuDisabled enable: true"

	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/29/2000 15:01'!
preserveCommandExcursions
	"An architecture is in place for storing command excursions to which access is otherwise cut off by having taken a variant branch, but it is not accessible unless you hand-code this preference to true -- which I suggest you do only with fingers crossed."

	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 11/15/2001 08:37'!
suppressWindowTitlesInInstanceBrowsers
	"Hard-coded for the moment: answer whether instance browsers should suppresss their window titles"

	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 2/16/1999 11:24'!
useCategoryListsInViewers
	"Temporarily hard-coded pending viewer work underway"
	^ false! !


!Preferences class methodsFor: 'initialization' stamp: 'sw 4/10/2001 15:28'!
chooseInitialSettings
	"Restore the default choices for all of the standard Preferences."

	self allPreferenceObjects do:
		[:aPreference |
			aPreference restoreDefaultValue].
	Project current installProjectPreferences! !

!Preferences class methodsFor: 'initialization' stamp: 'NS 1/28/2004 14:43'!
compileAccessMethodForPreference: aPreference
	"Compile an accessor method for the given preference"

	self class compileSilently: (aPreference name, '
	^ self valueOfFlag: #', aPreference name, ' ifAbsent: [', aPreference defaultValue storeString, ']') classified: 'standard queries'! !

!Preferences class methodsFor: 'initialization' stamp: 'rr 10/1/2005 15:14'!
initializeDictionaryOfPreferences
	"Initialize the DictionaryOfPreferences to be an empty IdentityDictionary"

	"Preferences initializeDictionaryOfPreferences"

	self  dictionaryOfPreferences:IdentityDictionary new! !

!Preferences class methodsFor: 'initialization' stamp: 'tak 8/3/2005 21:17'!
localeChanged
	LocaleID current isoLanguage = 'ja'
		ifTrue: [Preferences enable: #useFormsInPaintBox]
		ifFalse: [Preferences disable: #useFormsInPaintBox]! !

!Preferences class methodsFor: 'initialization' stamp: 'ar 9/27/2005 21:49'!
removeObsolete
	"Remove obsolete preferences"
	Preference allInstancesDo:[:pref|
		pref isObsolete ifTrue:[self removePreference: pref].
	].! !

!Preferences class methodsFor: 'initialization' stamp: 'rr 10/1/2005 15:14'!
removePreference: aSymbol 
	"Remove all memory of the given preference symbol in my various structures."

	| pref |
	pref _ self  preferenceAt:aSymbol  ifAbsent:[^ self].
	pref localToProject 
		 ifTrue:
			[Project  allInstancesDo:
					[:proj | 
					proj projectPreferenceFlagDictionary  ifNotNil:
							[proj projectPreferenceFlagDictionary  removeKey:aSymbol  ifAbsent:[]]]].
	self dictionaryOfPreferences  removeKey:aSymbol  ifAbsent:[].
	self class  removeSelector:aSymbol

	"Preferences removePreference: #tileToggleInBrowsers"! !

!Preferences class methodsFor: 'initialization' stamp: 'sw 4/21/2002 05:13'!
setPreferencesFrom: listOfPairs
	"Given a list of <preferenceName, value> pairs, set preference values.  This method is tolerent of the value being supplied either a Boolean or else one of the symbols #true and #false.  Also, a new-value of #noOpinion will result in that 'preference's value not being changed."

	listOfPairs do:
		[:aPair |
			(aPair second == #noOpinion) ifFalse:
				[Preferences setPreference: aPair first toValue: ((aPair second == #true) or: [aPair second == true])]]

"
Preferences setPreferencesFrom: #(( mouseOverForKeyboardFocus false))
Preferences setPreferencesFrom: {{  #mouseOverForKeyboardFocus. true}}
"! !


!Preferences class methodsFor: 'menu parameters' stamp: 'dgd 9/5/2004 16:17'!
defaultWorldColor
	^ Parameters
		at: #defaultWorldColor
		ifAbsent: [ Color r: 0.937 g: 0.937 b: 0.937 ].
! !

!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:16'!
menuBorderColor
	Display depth <= 2 ifTrue: [^ Color black].
	^ Parameters at: #menuBorderColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:16'!
menuBorderWidth
	^ Parameters at: #menuBorderWidth! !

!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:17'!
menuColor
	Display depth <= 2 ifTrue: [^ Color white].
	^ Parameters at: #menuColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'dgd 3/23/2003 11:06'!
menuLineColor
	^ Parameters
		at: #menuLineColor
		ifAbsentPut: [Preferences menuBorderColor lighter]! !

!Preferences class methodsFor: 'menu parameters' stamp: 'dgd 8/30/2004 20:59'!
menuSelectionColor
	^ Parameters
		at: #menuSelectionColor
		ifAbsent: [nil]! !

!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:19'!
menuTitleBorderColor
	Display depth <= 2 ifTrue: [^ Color black].
	^ Parameters at: #menuTitleBorderColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:16'!
menuTitleBorderWidth
	^ Parameters at: #menuTitleBorderWidth! !

!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:18'!
menuTitleColor
	Display depth = 1 ifTrue: [^ Color white].
	Display depth = 2 ifTrue: [^ Color gray].
	^ Parameters at: #menuTitleColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'dgd 3/23/2003 11:11'!
restoreDefaultMenuParameters
	"Restore the four color choices of the original implementors of  
	MorphicMenus"
	" 
	Preferences restoreDefaultMenuParameters
	"
	Parameters
		at: #menuColor
		put: (Color
				r: 0.97
				g: 0.97
				b: 0.97).
	Parameters
		at: #menuBorderColor
		put: (Color
				r: 0.167
				g: 0.167
				b: 1.0).
	Parameters at: #menuBorderWidth put: 2.
	Parameters at: #menuTitleColor put: (Color
			r: 0.4
			g: 0.8
			b: 0.9) twiceDarker.
	Parameters
		at: #menuTitleBorderColor
		put: (Color
				r: 0.333
				g: 0.667
				b: 0.751).
	Parameters at: #menuTitleBorderWidth put: 1.
	Parameters
		at: #menuLineColor
		put: (Preferences menuBorderColor lighter)! !


!Preferences class methodsFor: 'misc' stamp: 'sw 10/6/1999 15:20'!
addModelItemsToWindowMenu: aMenu
	aMenu addLine.
	aMenu add: 'restore default preference settings' target: self action: #chooseInitialSettings.
	aMenu add: 'restore default text highlighting' target: self action: #initializeTextHighlightingParameters! !

!Preferences class methodsFor: 'misc' stamp: 'dgd 9/7/2004 18:35'!
balloonHelpDelayTime
	"Answer the number of milliseconds before a balloon help 
	should be put up on morphs."
	^ Parameters
		at: #balloonHelpDelayTime
		ifAbsent: [800]! !

!Preferences class methodsFor: 'misc' stamp: 'ar 9/27/2005 21:07'!
browseThemes
	"Open up a message-category browser on the theme-defining methods"

	| aBrowser |
	aBrowser := Browser new setClass: Preferences class selector: #outOfTheBox.
	aBrowser messageCategoryListIndex: ((Preferences class organization categories indexOf: 'themes' ifAbsent: [^ self inform: 'no themes found']) + 1).
	Browser openBrowserView: (aBrowser openMessageCatEditString: nil)
		label: 'Preference themes'

	"Preferences browseThemes"! !

!Preferences class methodsFor: 'misc' stamp: 'md 3/3/2006 10:23'!
defaultValueTableForCurrentRelease
	"Answer a table defining default values for all the preferences in the release.  Returns a list of (pref-symbol, boolean-symbol) pairs"

	^  #(
		(abbreviatedBrowserButtons false)
		(alternativeBrowseIt false)
		(annotationPanes false)
		(areaFillsAreTolerant false)
		(areaFillsAreVeryTolerant false)
		(automaticFlapLayout true)
		(automaticKeyGeneration false)
		(automaticPlatformSettings true)
		(automaticViewerPlacement true)
		(balloonHelpEnabled true)
		(balloonHelpInMessageLists false)
		(batchPenTrails false)
		(browseWithDragNDrop false)
		(browseWithPrettyPrint false)
		(browserShowsPackagePane false)
		(canRecordWhilePlaying false)
		(capitalizedReferences true)
		(caseSensitiveFinds false)
		(cautionBeforeClosing false)
		(changeSetVersionNumbers true)
		(checkForSlips true)
		(checkForUnsavedProjects true)
		(classicNavigatorEnabled false)
		(clickOnLabelToEdit false)
		(cmdDotEnabled true)
		(collapseWindowsInPlace false)
		(colorWhenPrettyPrinting false)
		(compactViewerFlaps false)
		(compressFlashImages false)
		(confirmFirstUseOfStyle true)
		(conversionMethodsAtFileOut false)
		(cpuWatcherEnabled false)
		(debugHaloHandle true)
		(debugPrintSpaceLog false)
		(debugShowDamage false)
		(decorateBrowserButtons true)
		(diffsInChangeList true)
		(diffsWithPrettyPrint false)
		(dismissAllOnOptionClose false)
		(dragNDropWithAnimation false)
		(eToyFriendly false)
		(eToyLoginEnabled false)
		(enableLocalSave true)
		(extractFlashInHighQuality true)
		(extractFlashInHighestQuality false)
		(fastDragWindowForMorphic true)
		(fenceEnabled true)
		(fullScreenLeavesDeskMargins true)
		(haloTransitions false)
		(hiddenScrollBars false)
		(higherPerformance false)
		(honorDesktopCmdKeys true)
		(ignoreStyleIfOnlyBold true)
		(includeSoundControlInNavigator false)
		(infiniteUndo false)
		(logDebuggerStackToFile true)
		(magicHalos false)
		(menuButtonInToolPane false)
		(menuColorFromWorld false)
		(menuKeyboardControl false)  
		(modalColorPickers true)
		(mouseOverForKeyboardFocus false)
		(mouseOverHalos false)
		(mvcProjectsAllowed true)
		(navigatorOnLeftEdge true)
		(noviceMode false)
		(okToReinitializeFlaps true)
		(optionalButtons true)
		(passwordsOnPublish false)
		(personalizedWorldMenu true)
		(postscriptStoredAsEPS false)
		(preserveTrash true)
		(projectViewsInWindows true)
		(projectZoom true)
		(projectsSentToDisk false)
		(promptForUpdateServer true)
		(propertySheetFromHalo false)
		(readDocumentAtStartup true)
		(restartAlsoProceeds false)
		(reverseWindowStagger true)
		(roundedMenuCorners true)
		(roundedWindowCorners true)
		(scrollBarsNarrow false)
		(scrollBarsOnRight true)
		(scrollBarsWithoutMenuButton false)
		(securityChecksEnabled false)
		(selectiveHalos false)
		(showBoundsInHalo false)
		(showDirectionForSketches false)
		(showDirectionHandles false)
		(showFlapsWhenPublishing false)
		(showProjectNavigator false)
		(showSecurityStatus true)
		(showSharedFlaps true)
		(signProjectFiles true)
		(simpleMenus false)
		(slideDismissalsToTrash true)
		(smartUpdating true)
		(soundQuickStart false)
		(soundStopWhenDone false)
		(soundsEnabled true)
		(startInUntrustedDirectory false)
		(systemWindowEmbedOK false)
		(thoroughSenders true)
		(tileTranslucentDrag true)
		(timeStampsInMenuTitles true)
		(turnOffPowerManager false)
		(twentyFourHourFileStamps true)
		(typeCheckingInTileScripting true)
		(uniTilesClassic true)
		(uniqueNamesInHalos false)
		(universalTiles false)
		(unlimitedPaintArea false)
		(updateSavesFile false)
		(useButtonProprtiesToFire false)
		(useUndo true)
		(viewersInFlaps true)
		(warnAboutInsecureContent true)
		(warnIfNoChangesFile true)
		(warnIfNoSourcesFile true))


"
Preferences defaultValueTableForCurrentRelease do:
	[:pair | (Preferences preferenceAt: pair first ifAbsent: [nil]) ifNotNilDo:
			[:pref | pref defaultValue: (pair last == true)]].
Preferences chooseInitialSettings.
"! !

!Preferences class methodsFor: 'misc' stamp: 'ar 9/27/2005 20:46'!
giveHelpWithPreferences
	"Open up a workspace with explanatory info in it about Preferences"

	| aString aHelpString |
	aString := String streamContents: [:aStream | 
		aStream nextPutAll:

'Many aspects of the system are governed by the settings of various "Preferences".  

Click on any of brown tabs at the top of the panel to see all the preferences in that category.  
Or type in to the box above the Search button, then hit Search, and all Preferences matching whatever you typed in will appear in the "search results" category.  A preference is considered to match your search if either its name matches the characters *or* if anything in the balloon help provided for the preferences matches the search text.

To find out more about any particular Preference, hold the mouse over it for a moment and balloon help will appear.  Also, a complete list of all the Preferences, with documentation for each, is included below.

Preferences whose names are in shown in bold in the Preferences Panel are designated as being allowed to vary from project to project; those whose name are not in bold are "global", which is to say, they apply equally whatever project you are in.

Click on the name of any preference to get a menu which allows you to *change* whether the preference should vary from project to project or should be global, and also allows you to browse all the senders of the preference, and to discover all the categories under which the preference has been classified, and to be handed a button that you can drop wherever you please that will control the preference.

If you like all your current Preferences settings, you may wish to hit the "Save Current Settings as my Personal Preferences" button.  Once you have done that, you can at any point in the future hit "Restore my Personal Preferences" and all your saved settings will get restored immediately.

Also, you can use "themes" to set multiple preferences all at once; click on the "change theme..." button in the Squeak flap or in the Preferences panel, or seek out the themes item in the Appearance menu.' translated.

	aStream cr; cr; nextPutAll: '-----------------------------------------------------------------';
		cr; cr; nextPutAll:  'Alphabetical listing of all Preferences' translated; cr; cr.
   (Preferences allPreferenceObjects asSortedCollection: [:a :b | a name < b name]) do:
	[:pref |
		aStream nextPutAll: pref name; cr.
		aHelpString := pref helpString translated.
		(aHelpString beginsWith: pref name) ifTrue:
			[aHelpString := aHelpString copyFrom: (pref name size + 3) to: aHelpString size].
		aHelpString := (aHelpString copyReplaceAll: String cr with: ' ')  copyWithout: Character tab.
		aStream nextPutAll: aHelpString capitalized.
		(aHelpString last == $.) ifFalse: [aStream nextPut: $.].
        aStream cr; cr]].

	UIManager default edit: aString label: 'About Preferences' translated

"Preferences giveHelpWithPreferences"! !

!Preferences class methodsFor: 'misc' stamp: 'yo 7/2/2004 19:44'!
installTheme: aSymbol
	"Install the theme represented by aSymbol.  The code that makes the theme-specific changes is lodged in a method of the same name as aSymbol, which must reside in category #themes in Preferences class"

	self perform: aSymbol.
	self inform: ('Theme {1} is now installed.
Many of the changes will only be
noticeable in new windows that you
create from now on.' translated format: {aSymbol translated}).! !

!Preferences class methodsFor: 'misc' stamp: 'dgd 9/21/2003 13:51'!
menuColorString
	^ ((self valueOfFlag: #menuColorFromWorld)
		ifTrue: ['stop menu-color-from-world']
		ifFalse: ['start menu-color-from-world']) translated! !

!Preferences class methodsFor: 'misc' stamp: 'em 3/24/2005 14:11'!
offerThemesMenu
	"Put up a menu offering the user a choice of themes.  Each theme is represented by a method in category #themes in Preferences class.  The comment at the front of each method is used as the balloon help for the theme"

	"Preferences offerThemesMenu"
	| selectors aMenu |
	selectors _ self class allMethodsInCategory: #themes.
	selectors _ selectors select: [:sel | sel numArgs = 0].
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Choose a theme to install' translated.
	selectors do:
		[:sel |
			aMenu add: sel target: self selector: #installTheme: argument: sel.
			aMenu balloonTextForLastItem: (self class firstCommentAt: sel)].
	aMenu addLine.
	aMenu add: 'browse themes' translated target: self action: #browseThemes.
	aMenu balloonTextForLastItem: 'Puts up a tool that will allow you to view and edit the code underlying all of the available themes' translated.
	aMenu popUpInWorld.
	"(Workspace new contents: 'here is an example of a new window with your new theme installed' translated) openLabel: 'Testing one two three'"! !

!Preferences class methodsFor: 'misc' stamp: 'sw 4/24/2001 12:02'!
okayToChangeProjectLocalnessOf: prefSymbol
	"Answer whether it would be okay to allow the user to switch the setting of whether or not the preference symbol is local to a project.  Formerly useful and perhaps again will be, though to be sure this is a non-modular design."

	^ (#() includes: prefSymbol) not! !

!Preferences class methodsFor: 'misc' stamp: 'yo 2/10/2005 16:15'!
roundedCornersString
	^ (((self valueOfFlag: #roundedWindowCorners)
		ifTrue: ['stop']
		ifFalse: ['start']) , ' rounding window corners') translated! !

!Preferences class methodsFor: 'misc' stamp: 'sw 3/2/2004 22:11'!
setArrowheads
	"Let the user edit the size of arrowheads"

	| aParameter result  |
	aParameter _ self parameterAt: #arrowSpec ifAbsent: [5 @ 4].
	result _ Morph obtainArrowheadFor: 'Default size of arrowheads on pen trails ' translated defaultValue: aParameter asString.
	result ifNotNil:
			[self setParameter: #arrowSpec to: result]
		ifNil:
			[Beeper beep]! !

!Preferences class methodsFor: 'misc' stamp: 'sw 1/4/2001 06:56'!
setFlag: prefSymbol toValue: aBoolean during: aBlock
	"Set the flag to the given value for the duration of aBlock"

	| existing |
	existing _ self valueOfFlag: prefSymbol.
	existing == aBoolean ifFalse: [self setPreference: prefSymbol toValue: aBoolean].
	aBlock value.
	existing == aBoolean ifFalse: [self setPreference: prefSymbol toValue: existing]! !

!Preferences class methodsFor: 'misc' stamp: 'dgd 10/17/2003 12:14'!
soundEnablingString
	^ self soundsEnabled
		ifFalse:
			['turn sound on' translated]
		ifTrue:
			['turn sound off' translated]! !

!Preferences class methodsFor: 'misc' stamp: 'dgd 9/21/2003 13:46'!
staggerPolicyString
	"Answer the string to be shown in a menu to represent the 
	stagger-policy status"
	^ ((self valueOfFlag: #reverseWindowStagger)
		ifTrue: ['<yes>']
		ifFalse: ['<no>']), 'stagger windows' translated! !

!Preferences class methodsFor: 'misc' stamp: 'dgd 9/1/2003 11:43'!
themeChoiceButtonOfColor: aColor font: aFont
	"Answer a button inviting the user to choose a theme"

	| aButton |
	aButton _ SimpleButtonMorph new target: self; actionSelector: #offerThemesMenu.
	aButton label: 'change theme...' translated font: aFont.
	aButton color: aColor.
	aButton setBalloonText: 'Numerous "Preferences" govern many things about the way Squeak looks and behaves.  Set individual preferences using a "Preferences" panel.  Set an entire "theme" of many Preferences all at the same time by pressing this "change theme" button and choosing a theme to install.  Look in category "themes" in Preferences class to see what each theme does; add your own methods to the "themes" category and they will show up in the list of theme choices.' translated.
	^ aButton! !

!Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:51'!
toggleMenuColorPolicy
	self togglePreference: #menuColorFromWorld! !

!Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:52'!
toggleRoundedCorners
	self togglePreference: #roundedWindowCorners! !

!Preferences class methodsFor: 'misc' stamp: 'ssa 2/9/2000 11:01'!
toggleSoundEnabling
     self togglePreference: #soundsEnabled! !

!Preferences class methodsFor: 'misc' stamp: 'sw 6/11/1999 20:49'!
toggleWindowPolicy
	self togglePreference: #reverseWindowStagger! !

!Preferences class methodsFor: 'misc' stamp: 'sw 8/29/2000 16:12'!
wantsChangeSetLogging
	"Answer whether method changes in the receiver should be logged to current change set.  This circumlocution avoids such logging for programmatically-compiled methods in Preferences, removing an annoyance"

	^ Utilities authorInitialsPerSe  ~= 'programmatic'! !


!Preferences class methodsFor: 'paintbox' stamp: 'yo 1/13/2005 11:05'!
useFormsInPaintBox: aBoolean

	self setPreference: #useFormsInPaintBox toValue: aBoolean
! !


!Preferences class methodsFor: 'parameters' stamp: 'sw 2/24/1999 12:26'!
acceptAnnotationsFrom: aSystemWindow
	"This intricate extraction is based on the precise structure of the annotation-request window.  Kindly avert your eyes."
	| aList |
	aList _ aSystemWindow paneMorphs first firstSubmorph submorphs collect:
		[:m |  m contents asSymbol].
	self defaultAnnotationRequests: aList
	! !

!Preferences class methodsFor: 'parameters' stamp: 'wiz 2/14/2006 02:21'!
annotationEditingWindow
	"Answer a window affording editing of annotations"
	| aPanel ins outs current aMorph aWindow aButton info pair standardHeight standardWidth |
	standardHeight := 180.
	standardWidth := (2 sqrt reciprocal * standardHeight) rounded.
	Smalltalk isMorphic
		ifFalse: [self error: 'annotations can be edited only in morphic'].
	aPanel := AlignmentMorph newRow extent: 2 * standardWidth @ standardHeight.
	ins := AlignmentMorph newColumn extent: standardWidth @ standardHeight.
	ins color: Color green muchLighter.
	ins enableDrop: true;
		 beSticky.
	outs := AlignmentMorph newColumn extent: standardWidth @ standardHeight.
	outs color: Color red muchLighter.
	outs enableDrop: true;
		 beSticky.
	aPanel addMorph: outs;
		 addMorphFront: ins.
	outs position: ins position + (standardWidth @ 0).
	current := self defaultAnnotationRequests.
	info := self annotationInfo.
	current
		do: [:sym | 
			pair := info
						detect: [:aPair | aPair first == sym].
			aMorph := StringMorph new contents: pair first.
			aMorph setBalloonText: pair last.
			aMorph enableDrag: true.
			aMorph
				on: #startDrag
				send: #startDrag:with:
				to: aMorph.
			ins addMorphBack: aMorph].
	info
		do: [:aPair | (current includes: aPair first)
				ifFalse: [aMorph := StringMorph new contents: aPair first.
					aMorph setBalloonText: aPair last.
					aMorph enableDrag: true.
					aMorph
						on: #startDrag
						send: #startDrag:with:
						to: aMorph.
					outs addMorph: aMorph]].
	aPanel layoutChanged.
	aWindow := SystemWindowWithButton new setLabel: 'Annotations'.
	aButton := SimpleButtonMorph new target: Preferences;
				 actionSelector: #acceptAnnotationsFrom:;
				
				arguments: (Array with: aWindow);
				 label: 'apply';
				 borderWidth: 0;
				 borderColor: Color transparent;
				 color: Color transparent.
	aButton submorphs first color: Color blue.
	aButton setBalloonText: 'After moving all the annotations you want to the left (green) side, and all the ones you do NOT want to the right (pink) side, hit this "apply" button to have your choices take effect.'.
	aWindow buttonInTitle: aButton;
		 adjustExtraButton.
	^ aPanel wrappedInWindow: aWindow"Preferences annotationEditingWindow openInHand"! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 7/12/2001 18:18'!
annotationInfo 
	"Answer a list of pairs characterizing all the available kinds of annotations; in each pair, the first element is a symbol representing the info type, and the second element is a string providing the corresponding balloon help"

	^ #(

		(timeStamp			'The time stamp of the last submission of the method.')
		(firstComment		'The first comment in the method, if any.')
		(masterComment		'The comment at the beginning of the supermost implementor of the method if any.')
		(documentation		'Comment at beginning of the method or, if it has none, comment at the beginning of a superclass''s implementation of the method')
		(messageCategory	'Which method category the method lies in')
		(sendersCount		'A report of how many senders there of the message.')
		(implementorsCount	'A report of how many implementors there are of the message.')
		(recentChangeSet	'The most recent change set bearing the method.')
		(allChangeSets		'A list of all change sets bearing the method.')
		(priorVersionsCount	'A report of how many previous versions there are of the method' )
		(priorTimeStamp		'The time stamp of the penultimate submission of the method, if any'))! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/15/1999 19:44'!
borderColorWhenRunning
	^ Color green! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/17/1999 00:40'!
defaultAnnotationRequests
	^ Parameters at: #MethodAnnotations ifAbsent:
		[self setDefaultAnnotationInfo]
	"Preferences annotationInfo"! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/8/1999 10:14'!
defaultAnnotationRequests: newList
	^ Parameters at: #MethodAnnotations put: newList! !

!Preferences class methodsFor: 'parameters' stamp: 'sma 6/1/2000 12:08'!
defaultAuthorName
	"Answer the author name to be planted, by default, in a changeset-preamble template.  You can hard-code this to hold your name, thus saving you time when writing the preambles of subsequent changesets"

	^ Utilities authorName! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/1/2000 14:05'!
defaultPaintingExtent
	"Answer the preferred size for the onion-skin paint area when launching a new painting within a paste-up morph.  Feel free to change the parameters to suit your configuration."

	^ 800 @ 600! !

!Preferences class methodsFor: 'parameters' stamp: 'jhm 10/15/97 17:31'!
desktopColor
	"Answer the desktop color. Initialize it if necessary."
	
	DesktopColor == nil ifTrue: [DesktopColor _ Color gray].
	^ DesktopColor
! !

!Preferences class methodsFor: 'parameters' stamp: 'jhm 10/15/97 17:31'!
desktopColor: aColor
	"Record a new desktop color preference."

	DesktopColor _ aColor.
! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 6/13/2001 19:40'!
editAnnotations
	"Put up a window that allows the user to edit annotation specifications"

	| aWindow |
	self currentWorld addMorphCentered: (aWindow _ self annotationEditingWindow).
	aWindow activateAndForceLabelToShow

	"Preferences editAnnotations"

! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 5/16/2003 00:27'!
expungeParameter: aKey
	"If Parameters holds an entry under the given key, remove the entry.  No senders in the current system, but called from the postscript of the change-set that defines it, and potentially useful otherwise."

	Parameters removeKey: aKey ifAbsent: []! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 9/7/1999 12:45'!
initializeParameters
	"Preferences initializeParameters"
	Parameters _ IdentityDictionary new.
	self restoreDefaultMenuParameters.
	Parameters at: #maxBalloonHelpLineLength put: 28.
	self initializeTextHighlightingParameters! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 1/24/2001 21:44'!
inspectParameters
	"Open up an inspector on the Parameters of Preferences.  This is crude!!"

	Parameters inspectWithLabel: 'Parameters'! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 11/5/1998 16:49'!
maxBalloonHelpLineLength
	^ Parameters at: #maxBalloonHelpLineLength! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 1/27/2000 23:02'!
parameterAt: aKey
	^ Parameters at: aKey ifAbsent: [nil]! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 9/28/2001 08:52'!
parameterAt: aKey default: defaultValueBlock
	"Deprecated interface; no surviving senders in the released image, but clients probably still use"

	^ self parameterAt: aKey ifAbsentPut: defaultValueBlock! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 9/28/2001 08:40'!
parameterAt: aKey ifAbsentPut: defaultValueBlock
	"Return the Parameter setting at the given key.  If there is no entry for this key in the Parameters dictionary, create one with the value of defaultValueBlock as its value"

	^ Parameters at: aKey ifAbsentPut: defaultValueBlock! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/7/2001 14:37'!
parameterAt: aKey ifAbsent: aBlock
	"Answer the parameter saved at the given key; if there is no such key in the Parameters dictionary, evaluate aBlock"

	^ Parameters at: aKey ifAbsent: [aBlock value]! !

!Preferences class methodsFor: 'parameters'!
scrollBarColor
	"Answer the preferred color for scroll bar elevators."

	^ Color gray! !

!Preferences class methodsFor: 'parameters'!
scrollBarWidth
	"Answer the preferred width for scroll bars."

	^ 8! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/17/1999 00:41'!
setDefaultAnnotationInfo
	"Preferences setDefaultAnnotationInfo"
	^ Parameters at: #MethodAnnotations put: #(timeStamp messageCategory implementorsCount allChangeSets)! !

!Preferences class methodsFor: 'parameters' stamp: 'stp 01/13/2000 13:29'!
setParameter: paramName to: paramValue
	"Set the given field in the parameters dictionary."

	Parameters at: paramName put: paramValue! !


!Preferences class methodsFor: 'personalization' stamp: 'NS 1/28/2004 14:43'!
compileHardCodedPref: prefName enable: aBoolean
	"Compile a method that returns a simple true or false (depending on the value of aBoolean) when Preferences is sent prefName as a message"

	self class compileSilently: (prefName asString, '
	"compiled programatically -- return hard-coded preference value"
	^ ', aBoolean storeString) classified: 'hard-coded prefs'.
	
"Preferences compileHardCodedPref: #testing enable: false"! !

!Preferences class methodsFor: 'personalization' stamp: 'nk 7/30/2004 21:45'!
disableProgrammerFacilities
	"Warning: do not call this lightly!!  It disables all access to menus, debuggers, halos.  There is no guaranteed return from this, which is to say, you cannot necessarily reenable these things once they are disabled -- you can only use whatever the UI of the current project affords, and you cannot even snapshot -- you can only quit. 

     You can completely reverse the work of this method by calling the dual Preferences method enableProgrammerFacilities, provided you have left yourself leeway to bring about a call to that method.

	To set up a system that will come up in such a state, you have to request the snapshot in the same breath as you disable the programmer facilities.  To do this, put the following line into the 'do' menu and then evaluate it from that 'do' menu:

         Preferences disableProgrammerFacilities.

You will be prompted for a new image name under which to save the resulting image."

	Beeper beep.
	(self 
		confirm: 'CAUTION!!!!
This is a drastic step!!
Do you really want to do this?') 
			ifFalse: 
				[Beeper beep.
				^self inform: 'whew!!'].
	self disable: #cmdDotEnabled.	"No user-interrupt-into-debugger"
	self compileHardCodedPref: #cmdGesturesEnabled enable: false.	"No halos, etc."
	self compileHardCodedPref: #cmdKeysInText enable: false.	"No user commands invokable via cmd-key combos in text editor"
	self enable: #noviceMode.	"No control-menu"
	self disable: #warnIfNoSourcesFile.
	self disable: #warnIfNoChangesFile.
	SmalltalkImage current saveAs! !

!Preferences class methodsFor: 'personalization' stamp: 'sw 6/29/1999 13:55'!
enableProgrammerFacilities
	"Meant as a one-touch recovery from a #disableProgrammerFacilities call."
	"Preferences enableProgrammerFacilities"

	self enable: #cmdDotEnabled.
	self compileHardCodedPref: #cmdGesturesEnabled enable: true. 
	self compileHardCodedPref: #cmdKeysInText enable: true.
	self disable: #noviceMode.
	self enable: #warnIfNoSourcesFile.
	self enable: #warnIfNoChangesFile.! !

!Preferences class methodsFor: 'personalization' stamp: 'ar 9/27/2005 20:32'!
letUserPersonalizeMenu
	"Invoked from menu, opens up a single-msg browser on the message that user is invited to customize for rapid morphic access via option-click on morphic desktop"

	ToolSet browse: Preferences class 
		selector: #personalizeUserMenu:! !

!Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 11:40'!
loadPreferencesFrom: aFileName
	| stream params dict desktopColor |
	stream _ ReferenceStream fileNamed: aFileName.
	params _ stream next.
	self assert: (params isKindOf: IdentityDictionary).
	params removeKey: #PersonalDictionaryOfPreferences.
	dict _ stream next.
	self assert: (dict isKindOf: IdentityDictionary).
	desktopColor _ stream next.
	stream close.
	dict keysAndValuesDo:
		[:key :value | (self preferenceAt: key ifAbsent: [nil]) ifNotNilDo:
			[:pref | pref preferenceValue: value preferenceValue]].

	params keysAndValuesDo: [ :key :value | self setParameter: key to: value ].

	Smalltalk isMorphic
		ifTrue: [ World fillStyle: desktopColor ]
		ifFalse: [ self desktopColor: desktopColor. ScheduledControllers updateGray ].
! !

!Preferences class methodsFor: 'personalization' stamp: 'wiz 2/20/2006 20:33'!
personalizeUserMenu: aMenu
	"The user has clicked on the morphic desktop with the yellow mouse button (option+click on the Mac); a menu is being constructed to present to the user in response; its default target is the current world.  In this method, you are invited to add items to the menu as per personal preferences.
	The default implementation, for illustrative purposes, sets the menu title to 'personal', and adds items for go-to-previous-project, show/hide flaps, and load code updates"
	
	aMenu addTitle: 'personal' translated.  "Remove or modify this as per personal choice"

	aMenu addStayUpItem.
	aMenu add: 'previous project' translated action: #goBack.
	aMenu add: 'load latest code updates' translated target: Utilities action: #updateFromServer.
	aMenu add: 'about this system...' translated target: SmalltalkImage current action: #aboutThisSystem.
	
	aMenu addLine.
				
	aMenu addUpdating: #suppressFlapsString target: Project current action: #toggleFlapsSuppressed.
	aMenu balloonTextForLastItem: 'Whether prevailing flaps should be shown in the project right now or not.' translated! !

!Preferences class methodsFor: 'personalization' stamp: 'sw 4/18/2002 18:02'!
restorePersonalPreferences
	"Restore all the user's saved personal preference settings"

	| savedPrefs |
	savedPrefs _ self parameterAt: #PersonalDictionaryOfPreferences ifAbsent: [^ self inform: 'There are no personal preferences saved in this image yet'].

	savedPrefs associationsDo:
		[:assoc | (self preferenceAt: assoc key ifAbsent: [nil]) ifNotNilDo:
			[:pref | pref preferenceValue: assoc value preferenceValue]]! !

!Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 12:07'!
restorePreferencesFromDisk
	(FileDirectory default fileExists: 'my.prefs')
		ifTrue: [ Cursor wait showWhile: [
			[ self loadPreferencesFrom: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error restoring the preferences' ]
		] ]
		ifFalse: [ self inform: 'you haven''t saved your preferences yet!!' ].
	! !

!Preferences class methodsFor: 'personalization' stamp: 'rr 10/1/2005 15:14'!
savePersonalPreferences
	"Save the current list of Preference settings as the user's personal choices"

	self  setParameter:#PersonalDictionaryOfPreferences
		 to:self dictionaryOfPreferences deepCopy! !

!Preferences class methodsFor: 'personalization' stamp: 'rr 10/1/2005 15:14'!
storePreferencesIn: aFileName 
	| stream |
	#(#Prevailing #PersonalPreferences )  do:[:ea | Parameters  removeKey:ea  ifAbsent:[]].
	stream _ ReferenceStream  fileNamed:aFileName.
	stream  nextPut:Parameters.
	stream  nextPut:self dictionaryOfPreferences.
	Smalltalk isMorphic 
		 ifTrue:[stream  nextPut:World fillStyle]
		 ifFalse:[stream  nextPut:DesktopColor].
	stream close! !

!Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 12:08'!
storePreferencesToDisk
	Cursor wait showWhile: [
		[ self storePreferencesIn: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error storing your preferences to disk' ]]! !


!Preferences class methodsFor: 'preferences panel' stamp: 'rr 10/1/2005 15:14'!
categoryNames
	| aSet |
	aSet _ Set new.
	self dictionaryOfPreferences  do:
			[:aPreference | 
			aSet  addAll:(aPreference categoryList 
						 collect:[:aCategory | aCategory asSymbol])].
	^ aSet! !

!Preferences class methodsFor: 'preferences panel' stamp: 'md 2/24/2006 21:26'!
initialExtent
	^ Smalltalk isMorphic ifFalse: [219 @ 309] ifTrue: [232 @ 309]! !

!Preferences class methodsFor: 'preferences panel' stamp: 'md 2/24/2006 15:55'!
initializePreferencePanel: aPanel in: aPasteUpMorph
	"Initialize the given Preferences panel. in the given pasteup, which is the top-level panel installed in the container window.  Also used to reset it after some change requires reformulation"

	| tabbedPalette controlPage aColor aFont maxEntriesPerCategory tabsMorph anExtent  prefObjects cc |
	aPasteUpMorph removeAllMorphs.

	aFont := StrikeFont familyName: 'NewYork' size: 19.

	aColor := aPanel defaultBackgroundColor.
	tabbedPalette := TabbedPalette newSticky.
	tabbedPalette dropEnabled: false.
	(tabsMorph := tabbedPalette tabsMorph) color: aColor darker;
		 highlightColor: Color red regularColor: Color brown darker darker.
	tabbedPalette on: #mouseDown send: #yourself to: #().
	maxEntriesPerCategory := 0.
	self listOfCategories do: 
		[:aCat | 
			controlPage := AlignmentMorph newColumn beSticky color: aColor.
			controlPage on: #mouseDown send: #yourself to: #().
			controlPage dropEnabled: false.
			cc := Color transparent.
			controlPage color: cc.
			controlPage borderColor: aColor;
				 layoutInset: 4.
			(prefObjects := self preferenceObjectsInCategory: aCat) do:
				[:aPreference | | button |
					button _ aPreference representativeButtonWithColor: cc inPanel: aPanel.
					button ifNotNil: [controlPage addMorphBack: button]].
			controlPage setNameTo: aCat asString.
			aCat = #?
				ifTrue:	[aPanel addHelpItemsTo: controlPage].
			tabbedPalette addTabFor: controlPage font: aFont.
			aCat = 'search results' ifTrue:
				[(tabbedPalette tabNamed: aCat) setBalloonText:
					'Use the ? category to find preferences by keyword; the results of your search will show up here'].
		maxEntriesPerCategory := maxEntriesPerCategory max: prefObjects size].
	tabbedPalette selectTabNamed: '?'.
	tabsMorph rowsNoWiderThan: aPasteUpMorph width.
	aPasteUpMorph on: #mouseDown send: #yourself to: #().
	anExtent := aPasteUpMorph width @ (490 max: (25 + tabsMorph height + (20 * maxEntriesPerCategory))).
	aPasteUpMorph extent: anExtent.
	aPasteUpMorph color: aColor.
	aPasteUpMorph 	 addMorphBack: tabbedPalette.! !

!Preferences class methodsFor: 'preferences panel' stamp: 'rr 10/1/2005 15:14'!
inspectPreferences
	"Open a window on the current preferences dictionary, allowing the user to inspect and change the current preference settings.  This is fallen back upon if Morphic is not present"

	"Preferences inspectPreferences"

	self dictionaryOfPreferences  inspectWithLabel:'Preferences'! !

!Preferences class methodsFor: 'preferences panel' stamp: 'hpt 9/25/2004 11:49'!
listOfCategories
	"Answer a list of category names for the preferences panel"
	^ {#?}, self categoryNames asSortedArray, {#'search results'}

	"Preferences listOfCategories"
! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 2/7/2001 15:02'!
openFactoredPanel
	"Open up a tabbed Preferences panel.  In mvc, a new one is launched on each request; in Morphic, any existing one is opened, and a new one launched only if no existing one can be found."

	Smalltalk isMorphic
		ifTrue:  "reuse an existing one if one is found, else create a fresh one"
			[self currentWorld findAPreferencesPanel: nil] 

		ifFalse:  "in mvc, always opens a new one for now"
			[self openNewPreferencesPanel]

"Preferences openFactoredPanel"
! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 2/18/2001 01:45'!
openFactoredPanelWithWidth: aWidth 
	"Open up a preferences panel of the given width"

	"Preferences openFactoredPanelWithWidth: 325"
	| window playfield aPanel |

	aPanel _ PreferencesPanel new.
	playfield _ PasteUpMorph new width: aWidth.
	playfield dropEnabled: false.
	self initializePreferencePanel: aPanel in: playfield.
	self couldOpenInMorphic
		ifTrue: [window _ (SystemWindow labelled: 'Preferences')
						model: aPanel.
			window on: #keyStroke send: #keyStroke: to: aPanel.
			window
				bounds: (100 @ 100 - (0 @ window labelHeight + window borderWidth) extent: playfield extent + (2 * window borderWidth)).
			window
				addMorph: playfield
				frame: (0 @ 0 extent: 1 @ 1).
			window updatePaneColors.
			window setProperty: #minimumExtent toValue: playfield extent + (12@15).
			self currentWorld addMorphFront: window.
			window center: self currentWorld center.
			window activateAndForceLabelToShow]
		ifFalse:
			[(window _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: playfield.
			MorphWorldView
				openOn: window
				label: 'Preferences'
				extent: playfield extent]! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 8/19/2001 08:19'!
openNewPreferencesPanel
	"Create and open a new Preferences Panel"

	self openFactoredPanelWithWidth: 370

"Preferences openNewPreferencesPanel"! !

!Preferences class methodsFor: 'preferences panel' stamp: 'nb 6/17/2003 12:25'!
openPreferencesControlPanel
	"Open a preferences panel"

	"Preferences openPreferencesControlPanel"
	Smalltalk verifyMorphicAvailability ifFalse: [^ Beeper beep].
	^ self openFactoredPanel! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 10/5/1998 13:10'!
openPreferencesInspector
	"Open a window on the current set of preferences choices, allowing the user to view and change their settings"
	
	Smalltalk hasMorphic
		ifFalse:	[self inspectPreferences]
		ifTrue:	[self openPreferencesControlPanel]! !

!Preferences class methodsFor: 'preferences panel' stamp: 'rr 10/1/2005 15:14'!
preferenceObjectsInCategory: aCategorySymbol 
	"Answer a list of Preference objects that reside in the given category, in alphabetical order"

	^ (self dictionaryOfPreferences 
		 select:[:aPreference | aPreference categoryList  includes:aCategorySymbol]) 
			 asSortedCollection:
				[:pref1 :pref2 | 
				pref1 viewRegistry viewOrder  <pref2 viewRegistry viewOrder  or:
						[pref1 viewRegistry viewOrder  =pref2 viewRegistry viewOrder 
							 &(pref1 name  <pref2 name)]]! !

!Preferences class methodsFor: 'preferences panel' stamp: 'jrp 7/9/2005 18:51'!
preferencesControlPanel
	"Answer a Preferences control panel window"

	"Preferences preferencesControlPanel openInHand"
	| window playfield aPanel |

	aPanel _ PreferencesPanel new.
	playfield _ PasteUpMorph new width: 385.
	playfield dropEnabled: false.
	window _ (SystemWindow labelled: 'Preferences') model: aPanel.
	self initializePreferencePanel: aPanel in: playfield.
	window on: #keyStroke send: #keyStroke: to: aPanel.
	window bounds: (100 @ 100 - (0 @ window labelHeight + window borderWidth) extent: playfield extent + (2 * window borderWidth)).
	window addMorph: playfield frame: (0 @ 0 extent: 1 @ 1).
	window updatePaneColors.
	window setProperty: #minimumExtent toValue: playfield extent + (12@15).
	^ window! !


!Preferences class methodsFor: 'preference-object access' stamp: 'rr 10/1/2005 15:14'!
allPreferenceObjects
	"Answer a list of all the Preference objects registered in the system"

	^ self dictionaryOfPreferences values! !

!Preferences class methodsFor: 'preference-object access' stamp: 'rr 10/1/2005 15:14'!
preferenceAt: aSymbol 
	"Answer the Preference object at the given symbol, or nil if not there"

	^ self dictionaryOfPreferences  at:aSymbol  ifAbsent:[nil]! !

!Preferences class methodsFor: 'preference-object access' stamp: 'rr 10/1/2005 15:14'!
preferenceAt: aSymbol ifAbsent: aBlock 
	"Answer the Preference object at the given symbol, or the value of aBlock if not present"

	^ self dictionaryOfPreferences  at:aSymbol  ifAbsent:[aBlock value]! !


!Preferences class methodsFor: 'reacting to change' stamp: 'sw 6/12/2001 20:17'!
annotationPanesChanged
	"The setting of the annotationPanes preference changed; react.  Formerly, we replaced prototypes in flaps but this is no longer necessary"! !

!Preferences class methodsFor: 'reacting to change' stamp: 'em 3/24/2005 15:34'!
classicTilesSettingToggled
	"The current value of the largeTiles flag has changed; now react"

	Smalltalk isMorphic ifTrue:
		[Preferences universalTiles
			ifFalse:
				[self inform: 
'note that this will only have a noticeable
effect if the universalTiles preference is
set to true, which it currently is not' translated]
			ifTrue:
				[World recreateScripts]]! !

!Preferences class methodsFor: 'reacting to change' stamp: 'dgd 7/28/2005 12:36'!
displaySizeChanged
	self flag: #todo.
	"only change font on small-land image"
	self smallLandFonts.
	self bigDisplay
		ifTrue: [self disable: #scrollBarsNarrow]
		ifFalse: [self enable: #scrollBarsNarrow].
self tinyDisplay ifTrue:[self disable: #biggerHandles] ifFalse:[self enable: #biggerHandles]! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:31'!
eToyFriendlyChanged
	"The eToyFriendly preference changed; React"
	
	ScriptingSystem customizeForEToyUsers: Preferences eToyFriendly! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:32'!
infiniteUndoChanged
	"The infiniteUndo preference changed; react"
	
	self infiniteUndo ifFalse:
		[CommandHistory resetAllHistory]! !

!Preferences class methodsFor: 'reacting to change' stamp: 'em 3/24/2005 15:34'!
largeTilesSettingToggled
	"The current value of the largeTiles flag has changed; now react"

	Smalltalk isMorphic ifTrue:
		[Preferences universalTiles
			ifFalse:
				[self inform: 
'note that this will only have a noticeable
effect if the universalTiles preference is
set to true, which it currently is not' translated]
			ifTrue:
				[World recreateScripts]]! !

!Preferences class methodsFor: 'reacting to change' stamp: 'mir 9/12/2001 15:15'!
mouseOverHalosChanged
	World wantsMouseOverHalos: self mouseOverHalos! !

!Preferences class methodsFor: 'reacting to change' stamp: 'dgd 9/30/2004 20:12'!
noviceModeSettingChanged
	"The current value of the noviceMode flag has changed;  
	now react"
	TheWorldMainDockingBar updateInstances.
	PasteUpMorph allSubInstances
		select: [:each | each isWorldMorph]
		thenDo: [:each | each initializeDesktopCommandKeySelectors].
	ParagraphEditor initialize.! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 6/12/2001 20:18'!
optionalButtonsChanged
	"The setting of the optionalButtons preference changed; react.  Formerly, we replaced prototypes in flaps but this is no longer necessary"
! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:11'!
roundedWindowCornersChanged
	"The user changed the value of the roundedWindowCorners preference.  React"

	ActiveWorld fullRepaintNeeded! !

!Preferences class methodsFor: 'reacting to change' stamp: 'dgd 9/20/2004 19:50'!
setNotificationParametersForStandardPreferences
	"Set up the notification parameters for the standard preferences that require need them.  When adding new Preferences that require use of the notification mechanism, users declare the notifcation info as part of the call that adds the preference, or afterwards -- the two relevant methods for doing that are:
 	Preferences.addPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector:   and
	Preference changeInformee:changeSelector:"

		"Preferences setNotificationParametersForStandardPreferences"

	| aPreference |
	#(	
		(annotationPanes		annotationPanesChanged)
		(eToyFriendly			eToyFriendlyChanged)
		(infiniteUndo			infiniteUndoChanged)
		(uniTilesClassic			classicTilesSettingToggled)
		(optionalButtons			optionalButtonsChanged)
		(roundedWindowCorners	roundedWindowCornersChanged)
		(showProjectNavigator	showProjectNavigatorChanged)
		(smartUpdating			smartUpdatingChanged)
		(universalTiles			universalTilesSettingToggled)
		(showSharedFlaps		sharedFlapsSettingChanged)
		(noviceMode		noviceModeSettingChanged)
	)  do:

			[:pair |
				aPreference _ self preferenceAt: pair first.
				aPreference changeInformee: self changeSelector: pair second]! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/30/2001 20:39'!
sharedFlapsSettingChanged
	"The current value of the showSharedFlaps flag has changed; now react"

	self showSharedFlaps  "viz. the new setting"
		ifFalse:		
			[Flaps globalFlapTabsIfAny do:
				[:aFlapTab | Flaps removeFlapTab: aFlapTab keepInList: true]]

		ifTrue:
			[Smalltalk isMorphic ifTrue:
				[self currentWorld addGlobalFlaps]]! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:33'!
showProjectNavigatorChanged
	"The showProjectNavigatorChanged preference changed; react"
	
	Project current assureNavigatorPresenceMatchesPreference! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:30'!
smartUpdatingChanged
	"The smartUpdating preference changed. React"

	SystemWindow allSubInstancesDo:
		[:aWindow | aWindow amendSteppingStatus]

	"NOTE: This makes this preference always behave like a global preference, which is problematical"! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/13/2001 11:22'!
universalTilesSettingToggled
	"The current value of the universalTiles flag has changed; now react"

	(self preferenceAt: #universalTiles ifAbsent: [^ self]) localToProject ifFalse:
			[^ self inform: 
'This is troubling -- you may regret having done that, because
the change will apply to *all projects*, including pre-existing ones.  Unfortunately this check is done after the damage is done, so you
may be hosed.  Fortunately, however, you can simply reverse your choice right now and perhaps no deep damage will have been done.'].

	self universalTiles  "User just switched project to classic tiles"
		ifFalse:
			[self inform: 
'CAUTION -- if you had any scripted objects in
this project that already used universal tiles, 
there is no reasonable way to go back to classic
tiles.  Recommended course of action in that case:
just toggle this preference right back to true.']
		ifTrue:
			[Preferences capitalizedReferences ifFalse:
				[Preferences enable: #capitalizedReferences.
				self inform: 
'Note that the "capitalizedReferences" flag
has now been automatically set to true for
you, since this is required for the use of
universal tiles.'].
			World isMorph ifTrue:
				[World recreateScripts]]! !

!Preferences class methodsFor: 'reacting to change' stamp: 'sw 7/10/2005 03:06'!
vectorVocabularySettingChanged
	"The current value of the useVectorVocabulary flag has changed; now react.  No senders, but invoked by the Preference object associated with the #useVectorVocabulary preference."

	Smalltalk isMorphic ifTrue:
		[ActiveWorld makeVectorUseConformToPreference]! !


!Preferences class methodsFor: 'scrollbar parameters' stamp: 'dgd 3/25/2003 19:58'!
fontFactor
	"answer the convertion factor for resizing element based on font  
	size"
	| factor |
	factor := TextStyle defaultFont height / 12.0.
	^ factor > 1.0
		ifTrue: [1 + (factor - 1.0 * 0.5)]
		ifFalse: [factor]! !


!Preferences class methodsFor: 'standard queries'!
abbreviatedBrowserButtons
	^ self
		valueOfFlag: #abbreviatedBrowserButtons
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
alphabeticalProjectMenu
	^ self
		valueOfFlag: #alphabeticalProjectMenu
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
alternateHandlesLook
	^ self
		valueOfFlag: #alternateHandlesLook
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
alternativeBrowseIt
	^ self
		valueOfFlag: #alternativeBrowseIt
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
alternativeButtonsInScrollBars
	^ self
		valueOfFlag: #alternativeButtonsInScrollBars
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries' stamp: 'dgd 3/21/2003 19:23'!
alternativeWindowBoxesLook
	^ self
		valueOfFlag: #alternativeWindowBoxesLook
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
alwaysHideHScrollbar
	^ self
		valueOfFlag: #alwaysHideHScrollbar
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
alwaysShowConnectionVocabulary
	^ self
		valueOfFlag: #alwaysShowConnectionVocabulary
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
alwaysShowHScrollbar
	^ self
		valueOfFlag: #alwaysShowHScrollbar
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
alwaysShowVScrollbar
	^ self
		valueOfFlag: #alwaysShowVScrollbar
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
annotationPanes
	^ self
		valueOfFlag: #annotationPanes
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
areaFillsAreTolerant
	^ self
		valueOfFlag: #areaFillsAreTolerant
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
areaFillsAreVeryTolerant
	^ self
		valueOfFlag: #areaFillsAreVeryTolerant
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
autoIndent
	^ self
		valueOfFlag: #autoIndent
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
automaticFlapLayout
	^ self
		valueOfFlag: #automaticFlapLayout
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
automaticKeyGeneration
	^ self
		valueOfFlag: #automaticKeyGeneration
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
automaticPlatformSettings
	^ self
		valueOfFlag: #automaticPlatformSettings
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
automaticViewerPlacement
	^ self
		valueOfFlag: #automaticViewerPlacement
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
balloonHelpEnabled
	^ self
		valueOfFlag: #balloonHelpEnabled
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
balloonHelpInMessageLists
	^ self
		valueOfFlag: #balloonHelpInMessageLists
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
batchPenTrails
	^ self
		valueOfFlag: #batchPenTrails
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
bigDisplay
	^ self
		valueOfFlag: #bigDisplay
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
biggerHandles
	^ self
		valueOfFlag: #biggerHandles
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
browserShowsPackagePane
	^ self
		valueOfFlag: #browserShowsPackagePane
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
browserWindowColor
	^ self
		valueOfFlag: #browserWindowColor
		ifAbsent: [Color
				r: 0.8
				g: 1.0
				b: 0.6]! !

!Preferences class methodsFor: 'standard queries'!
browseWithDragNDrop
	^ self
		valueOfFlag: #browseWithDragNDrop
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
browseWithPrettyPrint
	^ self
		valueOfFlag: #browseWithPrettyPrint
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
Curvier
	^ self
		valueOfFlag: #Curvier
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
canRecordWhilePlaying
	^ self
		valueOfFlag: #canRecordWhilePlaying
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
capitalizedReferences
	^ self
		valueOfFlag: #capitalizedReferences
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
caseSensitiveFinds
	^ self
		valueOfFlag: #caseSensitiveFinds
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
cautionBeforeClosing
	^ self
		valueOfFlag: #cautionBeforeClosing
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
changeListWindowColor
	^ self
		valueOfFlag: #changeListWindowColor
		ifAbsent: [Color
				r: 0.8
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
changeSetVersionNumbers
	^ self
		valueOfFlag: #changeSetVersionNumbers
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
changeSorterWindowColor
	^ self
		valueOfFlag: #changeSorterWindowColor
		ifAbsent: [Color
				r: 0.8
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
checkForSlips
	^ self
		valueOfFlag: #checkForSlips
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
checkForUnsavedProjects
	^ self
		valueOfFlag: #checkForUnsavedProjects
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
classCommentVersionsBrowserWindowColor
	^ self
		valueOfFlag: #classCommentVersionsBrowserWindowColor
		ifAbsent: [Color
				r: 0.769
				g: 0.653
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
classicNavigatorEnabled
	^ self
		valueOfFlag: #classicNavigatorEnabled
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
clickOnLabelToEdit
	^ self
		valueOfFlag: #clickOnLabelToEdit
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
cmdDotEnabled
	^ self
		valueOfFlag: #cmdDotEnabled
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries' stamp: 'programmatic 7/15/1999 09:55'!
cmdGesturesEnabled
	"compiled programatically -- return hard-coded preference value"
	^ true! !

!Preferences class methodsFor: 'standard queries'!
collapseWindowsInPlace
	^ self
		valueOfFlag: #collapseWindowsInPlace
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
colorWhenPrettyPrinting
	^ self
		valueOfFlag: #colorWhenPrettyPrinting
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
compactViewerFlaps
	^ self
		valueOfFlag: #compactViewerFlaps
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
compressFlashImages
	^ self
		valueOfFlag: #compressFlashImages
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
confirmFirstUseOfStyle
	^ self
		valueOfFlag: #confirmFirstUseOfStyle
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
conversionMethodsAtFileOut
	^ self
		valueOfFlag: #conversionMethodsAtFileOut
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
cpuWatcherEnabled
	^ self
		valueOfFlag: #cpuWatcherEnabled
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
debuggerWindowColor
	^ self
		valueOfFlag: #debuggerWindowColor
		ifAbsent: [Color
				r: 1.0
				g: 0.8
				b: 0.8]! !

!Preferences class methodsFor: 'standard queries'!
debugHaloHandle
	^ self
		valueOfFlag: #debugHaloHandle
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries' stamp: 'mir 3/5/2004 19:22'!
debugLogTimestamp
	^ self
		valueOfFlag: #debugLogTimestamp
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
debugPrintSpaceLog
	^ self
		valueOfFlag: #debugPrintSpaceLog
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
debugShowDamage
	^ self
		valueOfFlag: #debugShowDamage
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
decorateBrowserButtons
	^ self
		valueOfFlag: #decorateBrowserButtons
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
defaultFileOutFormatMacRoman
	^ self
		valueOfFlag: #defaultFileOutFormatMacRoman
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
defaultWindowColor
	^ self
		valueOfFlag: #defaultWindowColor
		ifAbsent: [Color
				r: 1.0
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
diffsInChangeList
	^ self
		valueOfFlag: #diffsInChangeList
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
diffsWithPrettyPrint
	^ self
		valueOfFlag: #diffsWithPrettyPrint
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
dismissAllOnOptionClose
	^ self
		valueOfFlag: #dismissAllOnOptionClose
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
dragNDropWithAnimation
	^ self
		valueOfFlag: #dragNDropWithAnimation
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
dropProducesWatcher
	^ self
		valueOfFlag: #dropProducesWatcher
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
dualChangeSorterWindowColor
	^ self
		valueOfFlag: #dualChangeSorterWindowColor
		ifAbsent: [Color
				r: 0.8
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
duplicateAllControlAndAltKeys
	^ self
		valueOfFlag: #duplicateAllControlAndAltKeys
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
duplicateControlAndAltKeys
	^ self
		valueOfFlag: #duplicateControlAndAltKeys
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
easySelection
	^ self
		valueOfFlag: #easySelection
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
enableLocalSave
	^ self
		valueOfFlag: #enableLocalSave
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
eToyFriendly
	^ self
		valueOfFlag: #eToyFriendly
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
eToyLoginEnabled
	^ self
		valueOfFlag: #eToyLoginEnabled
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
expandedPublishing
	^ self
		valueOfFlag: #expandedPublishing
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
extractFlashInHighestQuality
	^ self
		valueOfFlag: #extractFlashInHighestQuality
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
extractFlashInHighQuality
	^ self
		valueOfFlag: #extractFlashInHighQuality
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
extraDebuggerButtons
	^ self
		valueOfFlag: #extraDebuggerButtons
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
fastDragWindowForMorphic
	^ self
		valueOfFlag: #fastDragWindowForMorphic
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
fenceEnabled
	^ self
		valueOfFlag: #fenceEnabled
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
fenceSoundEnabled
	^ self
		valueOfFlag: #fenceSoundEnabled
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries' stamp: 'mir 6/7/2002 17:10'!
fenceSoundEnabled: aBoolean
	self setPreference: #fenceSoundEnabled toValue: aBoolean! !

!Preferences class methodsFor: 'standard queries'!
fileContentsBrowserWindowColor
	^ self
		valueOfFlag: #fileContentsBrowserWindowColor
		ifAbsent: [Color
				r: 0.8
				g: 0.8
				b: 0.5]! !

!Preferences class methodsFor: 'standard queries'!
fileListWindowColor
	^ self
		valueOfFlag: #fileListWindowColor
		ifAbsent: [Color
				r: 1.0
				g: 0.8
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
fullScreenLeavesDeskMargins
	^ self
		valueOfFlag: #fullScreenLeavesDeskMargins
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
generalizedYellowButtonMenu
	^ self
		valueOfFlag: #generalizedYellowButtonMenu
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
gradientMenu
	^ self
		valueOfFlag: #gradientMenu
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
gradientScrollBars
	^ self
		valueOfFlag: #gradientScrollBars
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
haloEnclosesFullBounds
	^ self
		valueOfFlag: #haloEnclosesFullBounds
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
haloTransitions
	^ self
		valueOfFlag: #haloTransitions
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
higherPerformance
	^ self
		valueOfFlag: #higherPerformance
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
honorDesktopCmdKeys
	^ self
		valueOfFlag: #honorDesktopCmdKeys
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
httpProxyPort
	^ self
		valueOfFlag: #httpProxyPort
		ifAbsent: [80]! !

!Preferences class methodsFor: 'standard queries'!
httpProxyServer
	^ self
		valueOfFlag: #httpProxyServer
		ifAbsent: ['']! !

!Preferences class methodsFor: 'standard queries'!
ignoreStyleIfOnlyBold
	^ self
		valueOfFlag: #ignoreStyleIfOnlyBold
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
includeSoundControlInNavigator
	^ self
		valueOfFlag: #includeSoundControlInNavigator
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
infiniteUndo
	^ self
		valueOfFlag: #infiniteUndo
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
inlineServicesInMenu
	^ self
		valueOfFlag: #inlineServicesInMenu
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
instanceBrowserWindowColor
	^ self
		valueOfFlag: #instanceBrowserWindowColor
		ifAbsent: [Color
				r: 0.806
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
keepTickingWhilePainting
	^ self
		valueOfFlag: #keepTickingWhilePainting
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
lexiconWindowColor
	^ self
		valueOfFlag: #lexiconWindowColor
		ifAbsent: [Color
				r: 0.878
				g: 1.0
				b: 0.878]! !

!Preferences class methodsFor: 'standard queries'!
logDebuggerStackToFile
	^ self
		valueOfFlag: #logDebuggerStackToFile
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
magicHalos
	^ self
		valueOfFlag: #magicHalos
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
maintainHalos
	^ self
		valueOfFlag: #maintainHalos
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
menuAppearance3d
	^ self
		valueOfFlag: #menuAppearance3d
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
menuButtonInToolPane
	^ self
		valueOfFlag: #menuButtonInToolPane
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
menuColorFromWorld
	^ self
		valueOfFlag: #menuColorFromWorld
		ifAbsent: [true
			"success"]! !

!Preferences class methodsFor: 'standard queries'!
menuKeyboardControl
	^ self
		valueOfFlag: #menuKeyboardControl
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
menuWithIcons
	^ self
		valueOfFlag: #menuWithIcons
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
messageListWindowColor
	^ self
		valueOfFlag: #messageListWindowColor
		ifAbsent: [Color
				r: 0.8
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
messageNamesWindowColor
	^ self
		valueOfFlag: #messageNamesWindowColor
		ifAbsent: [Color
				r: 0.645
				g: 1.0
				b: 0.452]! !

!Preferences class methodsFor: 'standard queries'!
methodFinderWindowColor
	^ self
		valueOfFlag: #methodFinderWindowColor
		ifAbsent: [Color
				r: 0.4
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
modalColorPickers
	^ self
		valueOfFlag: #modalColorPickers
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
mouseOverForKeyboardFocus
	^ self
		valueOfFlag: #mouseOverForKeyboardFocus
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
mouseOverHalos
	^ self
		valueOfFlag: #mouseOverHalos
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
multipleTextUndo
	^ self
		valueOfFlag: #multipleTextUndo
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
mvcProjectsAllowed
	^ self
		valueOfFlag: #mvcProjectsAllowed
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
navigatorOnLeftEdge
	^ self
		valueOfFlag: #navigatorOnLeftEdge
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
noviceMode
	^ self
		valueOfFlag: #noviceMode
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
okToReinitializeFlaps
	^ self
		valueOfFlag: #okToReinitializeFlaps
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
oliveHandleForScriptedObjects
	^ self
		valueOfFlag: #oliveHandleForScriptedObjects
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
optionalButtons
	^ self
		valueOfFlag: #optionalButtons
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
packageBrowserWindowColor
	^ self
		valueOfFlag: #packageBrowserWindowColor
		ifAbsent: [Color
				r: 1.0
				g: 1.0
				b: 0.6]! !

!Preferences class methodsFor: 'standard queries'!
passwordsOnPublish
	^ self
		valueOfFlag: #passwordsOnPublish
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
personalizedWorldMenu
	^ self
		valueOfFlag: #personalizedWorldMenu
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
postscriptStoredAsEPS
	^ self
		valueOfFlag: #postscriptStoredAsEPS
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
preferenceBrowserWindowColor
	^ self
		valueOfFlag: #preferenceBrowserWindowColor
		ifAbsent: [Color
				r: 0.645
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
preferencesPanelWindowColor
	^ self
		valueOfFlag: #preferencesPanelWindowColor
		ifAbsent: [Color
				r: 0.645
				g: 1.0
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
preserveTrash
	^ self
		valueOfFlag: #preserveTrash
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
projectsSentToDisk
	^ self
		valueOfFlag: #projectsSentToDisk
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
projectViewsInWindows
	^ self
		valueOfFlag: #projectViewsInWindows
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
projectZoom
	^ self
		valueOfFlag: #projectZoom
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
promptForUpdateServer
	^ self
		valueOfFlag: #promptForUpdateServer
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
propertySheetFromHalo
	^ self
		valueOfFlag: #propertySheetFromHalo
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
purgeUndoOnQuit
	^ self
		valueOfFlag: #purgeUndoOnQuit
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
readDocumentAtStartup
	^ self
		valueOfFlag: #readDocumentAtStartup
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
readOnlyMode
	^ self
		valueOfFlag: #readOnlyMode
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
restartAlsoProceeds
	^ self
		valueOfFlag: #restartAlsoProceeds
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
reverseWindowStagger
	^ self
		valueOfFlag: #reverseWindowStagger
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
roundedMenuCorners
	^ self
		valueOfFlag: #roundedMenuCorners
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
roundedWindowCorners
	^ self
		valueOfFlag: #roundedWindowCorners
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
scrollBarsNarrow
	^ self
		valueOfFlag: #scrollBarsNarrow
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
scrollBarsOnRight
	^ self
		valueOfFlag: #scrollBarsOnRight
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
scrollBarsWithoutMenuButton
	^ self
		valueOfFlag: #scrollBarsWithoutMenuButton
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
securityChecksEnabled
	^ self
		valueOfFlag: #securityChecksEnabled
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
selectiveHalos
	^ self
		valueOfFlag: #selectiveHalos
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
showAdvancedNavigatorButtons
	^ self
		valueOfFlag: #showAdvancedNavigatorButtons
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
showBoundsInHalo
	^ self
		valueOfFlag: #showBoundsInHalo
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
showDeprecationWarnings
	^ self
		valueOfFlag: #showDeprecationWarnings
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
showDirectionForSketches
	^ self
		valueOfFlag: #showDirectionForSketches
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
showDirectionHandles
	^ self
		valueOfFlag: #showDirectionHandles
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
showFlapsWhenPublishing
	^ self
		valueOfFlag: #showFlapsWhenPublishing
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
showProjectNavigator
	^ self
		valueOfFlag: #showProjectNavigator
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
showSecurityStatus
	^ self
		valueOfFlag: #showSecurityStatus
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
showSharedFlaps
	^ self
		valueOfFlag: #showSharedFlaps
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
showSplitterHandles
	^ self
		valueOfFlag: #showSplitterHandles
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
showWorldMainDockingBar
	^ self
		valueOfFlag: #showWorldMainDockingBar
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
signProjectFiles
	^ self
		valueOfFlag: #signProjectFiles
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
simpleMenus
	^ self
		valueOfFlag: #simpleMenus
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
slideDismissalsToTrash
	^ self
		valueOfFlag: #slideDismissalsToTrash
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
smartUpdating
	^ self
		valueOfFlag: #smartUpdating
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
soundQuickStart
	^ self
		valueOfFlag: #soundQuickStart
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
soundStopWhenDone
	^ self
		valueOfFlag: #soundStopWhenDone
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
soundsEnabled
	^ self
		valueOfFlag: #soundsEnabled
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries' stamp: 'mir 11/10/2003 14:28'!
standaloneSecurityChecksEnabled
	^ self
		valueOfFlag: #standaloneSecurityChecksEnabled
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
startInUntrustedDirectory
	^ self
		valueOfFlag: #startInUntrustedDirectory
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
swapControlAndAltKeys
	^ self
		valueOfFlag: #swapControlAndAltKeys
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
swapMouseButtons
	^ self
		valueOfFlag: #swapMouseButtons
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
systemWindowEmbedOK
	^ self
		valueOfFlag: #systemWindowEmbedOK
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
tabAmongFields
	^ self
		valueOfFlag: #tabAmongFields
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
testRunnerWindowColor
	^ self
		valueOfFlag: #testRunnerWindowColor
		ifAbsent: [Color
				r: 0.65
				g: 0.753
				b: 0.976]! !

!Preferences class methodsFor: 'standard queries'!
thoroughSenders
	^ self
		valueOfFlag: #thoroughSenders
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
tileTranslucentDrag
	^ self
		valueOfFlag: #tileTranslucentDrag
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
timeStampsInMenuTitles
	^ self
		valueOfFlag: #timeStampsInMenuTitles
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
tinyDisplay
	^ self
		valueOfFlag: #tinyDisplay
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
transcriptWindowColor
	^ self
		valueOfFlag: #transcriptWindowColor
		ifAbsent: [Color
				r: 1.0
				g: 0.8
				b: 0.4]! !

!Preferences class methodsFor: 'standard queries'!
turnOffPowerManager
	^ self
		valueOfFlag: #turnOffPowerManager
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
twentyFourHourFileStamps
	^ self
		valueOfFlag: #twentyFourHourFileStamps
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
typeCheckingInTileScripting
	^ self
		valueOfFlag: #typeCheckingInTileScripting
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
uniqueNamesInHalos
	^ self
		valueOfFlag: #uniqueNamesInHalos
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
uniTilesClassic
	^ self
		valueOfFlag: #uniTilesClassic
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
universalTiles
	^ self
		valueOfFlag: #universalTiles
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
unlimitedPaintArea
	^ self
		valueOfFlag: #unlimitedPaintArea
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
updateFromServerAtStartup
	^ self
		valueOfFlag: #updateFromServerAtStartup
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
updateSavesFile
	^ self
		valueOfFlag: #updateSavesFile
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
upgradeIsMerge
	^ self
		valueOfFlag: #upgradeIsMerge
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
useButtonProprtiesToFire
	^ self
		valueOfFlag: #useButtonProprtiesToFire
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
useFormsInPaintBox
	^ self
		valueOfFlag: #useFormsInPaintBox
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
useLocale
	^ self
		valueOfFlag: #useLocale
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
useOnlyServicesInMenu
	^ self
		valueOfFlag: #useOnlyServicesInMenu
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
useServicesInBrowserButtonBar
	^ self
		valueOfFlag: #useServicesInBrowserButtonBar
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
useSmartLabels
	^ self
		valueOfFlag: #useSmartLabels
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
useUndo
	^ self
		valueOfFlag: #useUndo
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
useVectorVocabulary
	^ self
		valueOfFlag: #useVectorVocabulary
		ifAbsent: [false]! !

!Preferences class methodsFor: 'standard queries'!
versionsBrowserWindowColor
	^ self
		valueOfFlag: #versionsBrowserWindowColor
		ifAbsent: [Color
				r: 0.869
				g: 0.753
				b: 1.0]! !

!Preferences class methodsFor: 'standard queries'!
viewersInFlaps
	^ self
		valueOfFlag: #viewersInFlaps
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
visualExplorer
	^ self
		valueOfFlag: #visualExplorer
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
warnAboutInsecureContent
	^ self
		valueOfFlag: #warnAboutInsecureContent
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
warnIfNoChangesFile
	^ self
		valueOfFlag: #warnIfNoChangesFile
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
warnIfNoSourcesFile
	^ self
		valueOfFlag: #warnIfNoSourcesFile
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
wordStyleCursorMovement
	^ self
		valueOfFlag: #wordStyleCursorMovement
		ifAbsent: [true]! !

!Preferences class methodsFor: 'standard queries'!
workspaceWindowColor
	^ self
		valueOfFlag: #workspaceWindowColor
		ifAbsent: [Color
				r: 1.0
				g: 1.0
				b: 0.8]! !


!Preferences class methodsFor: 'text highlighting' stamp: 'lr 7/12/2006 09:25'!
caretWidth
	^ Parameters at: #caretWidth! !

!Preferences class methodsFor: 'text highlighting' stamp: 'lr 7/12/2006 09:25'!
caretWidth: anInteger
	^ Parameters at: #caretWidth put: anInteger! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/6/2000 18:45'!
chooseInsertionPointColor
	"Let the user indicate what color he wishes to have used for insertion points in text"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self currentHand;
		target: self;
		selector: #insertionPointColor:;
		originalColor: self insertionPointColor;
		putUpFor: self currentHand near: self currentHand cursorBounds! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 12/7/2001 00:44'!
chooseKeyboardFocusColor
	"Let the user indicate what color he wishes to have used for keyboard-focus feedback"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self currentHand;
		target: self;
		selector: #keyboardFocusColor:;
		originalColor: self keyboardFocusColor;
		putUpFor: self currentHand near: self currentHand cursorBounds! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/6/2000 18:45'!
chooseTextHighlightColor
	"Let the user choose the text-highlight color"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self currentHand;
		target: self;
		selector: #textHighlightColor:;
		originalColor: self textHighlightColor;
		putUpFor: self currentHand near: self currentHand cursorBounds! !

!Preferences class methodsFor: 'text highlighting' stamp: 'lr 7/12/2006 09:42'!
initializeTextHighlightingParameters
	"Preferences initializeTextHighlightingParameters"

	self
		caretWidth: 2;
		insertionPointColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.8);
		textHighlightColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.2)! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:53'!
insertionPointColor
	^ Parameters at: #insertionPointColor! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:54'!
insertionPointColor: aColor
	Parameters at: #insertionPointColor put: aColor! !

!Preferences class methodsFor: 'text highlighting' stamp: 'dew 1/8/2002 01:07'!
keyboardFocusColor
	"Answer the keyboard focus color, initializing it if necessary"

	^ Parameters at: #keyboardFocusColor ifAbsentPut: [Color lightGray]

"
Parameters removeKey: #keyboardFocusColor.
Preferences keyboardFocusColor
"! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 12/7/2001 00:44'!
keyboardFocusColor: aColor
	"Set the keyboard focus color"

	Parameters at: #keyboardFocusColor put: aColor! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:53'!
textHighlightColor
	^ Parameters at: #textHighlightColor! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:54'!
textHighlightColor: aColor
	Parameters at: #textHighlightColor put: aColor! !


!Preferences class methodsFor: 'themes' stamp: 'sw 4/21/2002 07:37'!
outOfTheBox
	"The default out-of-the-box preference settings for Squeak 3.2.  The 'alternative' window-look and scrollbar-look are used.  Button panes are used but not annotation panes.  Scrollbars are on the right and do not flop out."

	self setPreferencesFrom: self defaultValueTableForCurrentRelease! !

!Preferences class methodsFor: 'themes' stamp: 'sw 5/2/2002 10:45'!
personal
	"Settings saved (by sometime earlier having hit the 'Save Current Settings as my Personal Preferences' in a Preferences panel) as my personal preferences"

	self restorePersonalPreferences! !

!Preferences class methodsFor: 'themes' stamp: 'dgd 3/12/2006 12:52'!
smallLand
	"Small-Land theme. It install the complete Small-Land theme  
	(Preferences, Fonts, Colors, etc)"
	" 
	Preferences smallLand.  
	"
	self smallLandPreferences.
	self smallLandFonts.
	SmallLandColorTheme current apply! !


!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/6/2004 22:49'!
checkForWindowColors
	(self allPreferenceObjects noneSatisfy:  [:aPref | aPref name endsWith: 'WindowColor'])
		ifTrue: [self installBrightWindowColors].! !

!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 19:34'!
darkenStandardWindowPreferences
	"Make all window-color preferences one shade darker"

	(self allPreferenceObjects 
		select: [:aPref | (aPref name endsWith: 'WindowColor')
								and: [aPref preferenceValue isColor]])
		do: [:aPref | aPref preferenceValue: aPref preferenceValue darker].

"Preferences darkenStandardWindowPreferences"
! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 13:56'!
installBrightWindowColors
	"Install the factory-provided default window colors for all tools"

	"Preferences installBrightWindowColors"

	self installWindowColorsVia: [:aSpec | aSpec brightColor]! !

!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 23:17'!
installMissingWindowColors
	"Install the factory-provided bright window colors  -- a one-time bootstrap"
	"Preferences installMissingWindowColors"
	| color |
	self windowColorTable do:
		[:aColorSpec |
			color := (Color colorFrom: aColorSpec brightColor).
			self setWindowColorFor: aColorSpec classSymbol to: color]! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 13:55'!
installPastelWindowColors
	"Install the factory-provided default pastel window colors for all tools"

	"Preferences installBrightWindowColors"
	self installWindowColorsVia: [:aSpec | aSpec pastelColor]! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 12:55'!
installUniformWindowColors
	"Install the factory-provided uniform window colors for all tools"

	"Preferences installUniformWindowColors"
	self installWindowColorsVia: [:aQuad | #white]! !

!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 20:10'!
installWindowColorsVia: colorSpecBlock
	"Install windows colors using colorSpecBlock to deliver the color source for each element; the block is handed a WindowColorSpec object"
	"Preferences installBrightWindowColors"
	| color |
	self windowColorTable do:
		[:aColorSpec |
			color := (Color colorFrom: (colorSpecBlock value: aColorSpec)).
			self setWindowColorFor: aColorSpec classSymbol to: color]
! !

!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 19:35'!
lightenStandardWindowPreferences
	"Make all window-color preferences one shade darker"

		(self allPreferenceObjects 
		select: [:aPref | (aPref name endsWith: 'WindowColor')
								and: [aPref preferenceValue isColor]])
		do: [:aPref | aPref preferenceValue: aPref preferenceValue lighter].

"Preferences lightenStandardWindowPreferences"
! !

!Preferences class methodsFor: 'window colors' stamp: 'hpt 10/9/2005 23:23'!
setWindowColorFor: modelSymbol to: incomingColor
	| aColor aPrefSymbol aColorSpec |
	aColorSpec _ WindowColorRegistry registeredWindowColorSpecFor: modelSymbol.
	aColorSpec ifNil: [^self].
	aColor := incomingColor asNontranslucentColor.
	(aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) 
		ifTrue: [^ self].	
	aPrefSymbol _ self windowColorPreferenceForClassNamed: aColorSpec classSymbol.
	self 
		addPreference: aPrefSymbol  
		categories:  { #'window colors' }
		default:  aColor 
		balloonHelp: aColorSpec helpMessage translated
		projectLocal: false
		changeInformee: nil
		changeSelector: nil
		viewRegistry: (PreferenceViewRegistry registryOf: #windowColorPreferences)! !

!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 23:28'!
windowColorFor: aModelClassName
	| classToCheck prefSymbol |
	self checkForWindowColors.
	classToCheck := Smalltalk at: aModelClassName.
	prefSymbol := self windowColorPreferenceForClassNamed: classToCheck name.
	[(classToCheck ~~ Object) and: [(self preferenceAt: prefSymbol) isNil]]
		whileTrue: 
				[classToCheck := classToCheck superclass.
				prefSymbol := self windowColorPreferenceForClassNamed: classToCheck name].
	^self valueOfPreference: prefSymbol ifAbsent: [Color white].! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 4/21/2002 02:55'!
windowColorHelp
	"Provide help for the window-color panel"

	| helpString |
	helpString _ 
'The "Window Colors" panel lets you select colors for many kinds of standard Squeak windows.

You can change your color preference for any particular tool by clicking on the color swatch and then selecting the desired color from the resulting color-picker.

The three buttons entitled "Bright", "Pastel", and "White" let you revert to any of three different standard color schemes.  

The choices you make in the Window Colors panel only affect the colors of new windows that you open.

You can make other tools have their colors governed by this panel by simply implementing #windowColorSpecification on the class side of the model -- consult implementors of that method to see examples of how to do this.'.

	 (StringHolder new contents: helpString)
		openLabel: 'About Window Colors'

	"Preferences windowColorHelp"! !

!Preferences class methodsFor: 'window colors' stamp: 'hpt 10/9/2005 23:28'!
windowColorPreferenceForClassNamed: aClassName
	| aColorSpec wording |
	aColorSpec _ WindowColorRegistry registeredWindowColorSpecFor: aClassName.
	wording := aColorSpec ifNil: [aClassName] ifNotNil: [aColorSpec wording].
	^(wording, 'WindowColor') asLegalSelector asSymbol.! !

!Preferences class methodsFor: 'window colors' stamp: 'hpt 10/9/2005 23:17'!
windowColorTable
	"Answer a list of WindowColorSpec objects, one for each tool to be represented in the window-color panel"
	^ (WindowColorRegistry registeredWindowColorSpecs
		asSortedCollection: 
			[:specOne :specTwo | specOne wording < specTwo wording]) asArray.

"Preferences windowColorTable"! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 14:15'!
windowSpecificationPanel
	"Put up a panel for specifying window colors"

	"Preferences windowSpecificationPanel"
	| aPanel buttonRow aButton aRow aSwatch aColor aWindow aMiniWorld aStringMorph |
	aPanel _ AlignmentMorph newColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap;
		layoutInset: 0.

	aPanel addMorph: (buttonRow _ AlignmentMorph newRow color: (aColor _ Color tan lighter)).
	
	buttonRow addTransparentSpacerOfSize: 2@0.
	buttonRow addMorphBack: (SimpleButtonMorph new label: '?'; target: self; actionSelector: #windowColorHelp; setBalloonText: 'Click for an explanation of this panel'; color: Color veryVeryLightGray; yourself).
	buttonRow addTransparentSpacerOfSize: 8@0.
	#(	('Bright' 	installBrightWindowColors	yellow
					'Use standard bright colors for all windows.')
		('Pastel'		installPastelWindowColors	paleMagenta
					'Use standard pastel colors for all windows.')
		('White'	installUniformWindowColors		white
					'Use white backgrounds for all standard windows.')) do:

		[:quad |
			aButton _ (SimpleButtonMorph new target: self)
				label: quad first;
				actionSelector: quad second;
				color: (Color colorFrom: quad third);
				setBalloonText: quad fourth;
				yourself.
			buttonRow addMorphBack: aButton.
			buttonRow addTransparentSpacerOfSize: 10@0].

	self windowColorTable do:
		[:colorSpec | 
			aRow _ AlignmentMorph newRow color: aColor.
			aSwatch _ ColorSwatch new
				target: self;
				getSelector: #windowColorFor:;
				putSelector: #setWindowColorFor:to:;
				argument: colorSpec classSymbol;
				extent: (40 @ 20);
				setBalloonText: 'Click here to change the standard color to be used for ', colorSpec wording, ' windows.';
				yourself.
			aRow addMorphFront: aSwatch.
			aRow addTransparentSpacerOfSize: (12 @ 1).
			aRow addMorphBack: (aStringMorph _ StringMorph contents: colorSpec wording font: TextStyle defaultFont).
			aStringMorph setBalloonText: colorSpec helpMessage.
			aPanel addMorphBack: aRow].

	 Smalltalk isMorphic
                ifTrue:
                        [aWindow _ aPanel wrappedInWindowWithTitle: 'Window Colors'.
					" don't allow the window to be picked up by clicking inside "
					aPanel on: #mouseDown send: #yourself to: aPanel.
					self currentWorld addMorphCentered: aWindow.
					aWindow activateAndForceLabelToShow ]
                ifFalse:
                        [(aMiniWorld _ MVCWiWPasteUpMorph newWorldForProject: nil)
						addMorph: aPanel.
                           aMiniWorld startSteppingSubmorphsOf: aPanel.
                        MorphWorldView openOn: aMiniWorld
                                label: 'Window Colors'
                                extent: aMiniWorld fullBounds extent]! !


!Preferences class methodsFor: '*eToys-customevents-preferences' stamp: 'sw 6/16/2005 01:38'!
allowEtoyUserCustomEvents
	^ self
		valueOfFlag: #allowEtoyUserCustomEvents
		ifAbsent: [false]! !



!Preferences class methodsFor: 'themes - small-land' stamp: 'dgd 11/3/2004 15:06'!
smallLandBigFonts
	"private - change the fonts to small-land's choices"

	"
	Preferences smallLandBigFonts.
	"

	#(
		(setButtonFontTo:			#BitstreamVeraSansMono	15)

		(setListFontTo:				#BitstreamVeraSans		15)
		(setMenuFontTo:			#BitstreamVeraSans		15)
		(setSystemFontTo:			#BitstreamVeraSans		15)

		(setWindowTitleFontTo:	#BitstreamVeraSans		15)

		(setCodeFontTo:				#BitstreamVeraSerif		15)

		(setFlapsFontTo:				#KomikaText					24)
		(setEToysFontTo:			#KomikaText					24)
		(setHaloLabelFontTo:		#KomikaText					24)
		(setEToysTitleFontTo:		#KomikaText					36)
 	)
		do: [:triplet |
			Preferences
				perform: triplet first
				with: (StrikeFont familyName: triplet second pointSize: triplet third)
		].

	BalloonMorph setBalloonFontTo: (StrikeFont familyName: #BitstreamVeraSans pointSize: 15).
! !

!Preferences class methodsFor: 'themes - small-land' stamp: 'dgd 7/28/2005 11:11'!
smallLandFonts
	"private - change the fonts to small-land's  
	choices"
	" 
	Preferences smallLandFonts.  
	"
	Preferences bigDisplay
		ifTrue: [^ self smallLandBigFonts].
	Preferences tinyDisplay
		ifTrue: [^ self smallLandTinyFonts].
	self smallLandSmallFonts! !

!Preferences class methodsFor: 'themes - small-land' stamp: 'dgd 4/13/2005 09:42'!
smallLandPreferences
	"Private - change the preferences according to small-land taste"

	self setPreferencesFrom: #(
		(haloEnclosesFullBounds true)
		(showBoundsInHalo       true)
		(cmdGesturesEnabled	false)
		(easySelection			true)
		(abbreviatedBrowserButtons       true)
		(alternativeBrowseIt             true)
		(alwaysShowVScrollbar            false)
		(annotationPanes                 true)
		(balloonHelpInMessageLists       true)
		(browseWithDragNDrop             true)
		(browseWithPrettyPrint           true)
		(classicNewMorphMenu             true)
		(collapseWindowsInPlace          true)
		(colorWhenPrettyPrinting         true)
		(diffsWithPrettyPrint            true)
		(dragNDropWithAnimation          true)
		(duplicateControlAndAltKeys      true)
		(eToyFriendly                    true)
		(extraDebuggerButtons            true)
		(extractFlashInHighestQuality    true)
		(fastDragWindowForMorphic        false)
		(includeSoundControlInNavigator  true)
		(menuKeyboardControl             true)
		(menuAppearance3d			false)
		(gradientMenu					false)
		(mouseOverForKeyboardFocus       true)
		(optionalButtons                 true)
		(preserveTrash                   true)
		(projectViewsInWindows           true)
		(propertySheetFromHalo           true)
		(scrollBarsNarrow                true)
		(scrollBarsOnRight               true)
		(selectiveHalos                  true)
		(showDirectionForSketches        true)
		(showDirectionHandles            true)
		(slideDismissalsToTrash          true)
		(translationWithBabel            true)
		(unlimitedPaintArea              true)
		(unlimitedPaintArea              true)

		(menuColorFromWorld false)
		(noviceMode true)
		(uniqueNamesInHalos true)
		(infiniteUndo true)
		(useUndo true)
		(soundStopWhenDone true)
	).

	self setParameter: #balloonHelpDelayTime to: 100.
! !

!Preferences class methodsFor: 'themes - small-land' stamp: 'dgd 11/3/2004 15:04'!
smallLandSmallFonts
	"private - change the fonts to small-land's choices"

	"
	Preferences smallLandFonts.
	"

	#(
		(setButtonFontTo:			#BitstreamVeraSansMono	12)

		(setListFontTo:				#BitstreamVeraSans		12)
		(setMenuFontTo:			#BitstreamVeraSans		12)
		(setSystemFontTo:			#BitstreamVeraSans		12)

		(setWindowTitleFontTo:	#BitstreamVeraSans		15)

		(setCodeFontTo:				#BitstreamVeraSerif		12)

		(setFlapsFontTo:				#KomikaText					15)
		(setEToysFontTo:			#KomikaText					15)
		(setHaloLabelFontTo:		#KomikaText					15)
		(setEToysTitleFontTo:		#KomikaText					24)
 	)
		do: [:triplet |
			Preferences
				perform: triplet first
				with: (StrikeFont familyName: triplet second pointSize: triplet third)
		].

	BalloonMorph setBalloonFontTo: (StrikeFont familyName: #BitstreamVeraSans pointSize: 12).
! !

!Preferences class methodsFor: 'themes - small-land' stamp: 'dgd 7/28/2005 12:35'!
smallLandTinyFonts
	"private - change the fonts to small-land's choices"

	"
	Preferences smallLandTinyFonts.
	"

	#(
		(setButtonFontTo:			#AccujenMono	9)

		(setListFontTo:				#Accujen		9)
		(setMenuFontTo:			#Accujen		9)
		(setSystemFontTo:			#Accujen		9)

		(setWindowTitleFontTo:	#Accujen		10)

		(setCodeFontTo:				#Accuny		9)

		(setFlapsFontTo:				#Atlanta		11)
		(setEToysFontTo:			#Atlanta		11)
		(setHaloLabelFontTo:		#Atlanta		11)
		(setEToysTitleFontTo:		#Atlanta		11)
 	)
		do: [:triplet |
			Preferences
				perform: triplet first
				with: (StrikeFont familyName: triplet second pointSize: triplet third)
		].

	BalloonMorph setBalloonFontTo: (StrikeFont familyName: #Accujen pointSize: 9).
! !
Model subclass: #PreferencesPanel
	instanceVariableNames: 'searchString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Palettes'!
!PreferencesPanel commentStamp: '<historical>' prior: 0!
I represent the model of a Preferences window.!


!PreferencesPanel methodsFor: 'category switch' stamp: 'sw 2/18/2001 04:02'!
switchToCategoryNamed: aName event: anEvent
	"Switch the panel so that it looks at the category of the given name"

	| aPalette |
	aPalette _ self containingWindow findDeeplyA: TabbedPalette.
	aPalette ifNil: [^ self].
	aPalette selectTabNamed: aName! !


!PreferencesPanel methodsFor: 'find' stamp: 'nk 4/28/2004 10:18'!
addHelpItemsTo: panelPage
	"Add the items appropriate the the ? page of the receiver"

	| aButton aTextMorph aMorph firstTextMorph |
	panelPage hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	firstTextMorph _  TextMorph new contents: 'Search Preferences for:'.
	firstTextMorph beAllFont: ((TextStyle default fontOfSize: 13) emphasized: 1).
	panelPage addMorphBack: firstTextMorph lock.
	panelPage addTransparentSpacerOfSize: 0@10.

	aMorph _ RectangleMorph new clipSubmorphs: true; beTransparent; borderWidth: 2; borderColor: Color black; extent: 250 @ 36.
	aMorph vResizing: #rigid; hResizing: #rigid.
	aTextMorph _  PluggableTextMorph new
				on: self
				text: #searchString
				accept: #setSearchStringTo:
				readSelection: nil
				menu: nil.
"	aTextMorph hResizing: #rigid."
	aTextMorph borderWidth: 0.
	aTextMorph font: ((TextStyle default fontOfSize: 21) emphasized: 1); setTextColor: Color red.
	aMorph addMorphBack: aTextMorph.
	aTextMorph acceptOnCR: true.
	aTextMorph position: (aTextMorph position + (6@5)).
	aMorph clipLayoutCells: true.
	aTextMorph extent: 240 @ 25.
	panelPage addMorphBack: aMorph.
	aTextMorph setBalloonText: 'Type what you want to search for here, then hit the "Search" button, or else hit RETURN or ENTER'.
	aTextMorph setTextMorphToSelectAllOnMouseEnter.
	aTextMorph hideScrollBarsIndefinitely.
	panelPage addTransparentSpacerOfSize: 0@10.

	aButton _ SimpleButtonMorph new target: self; color: Color transparent; actionSelector: #initiateSearch:; arguments: {aTextMorph}; label: 'Search'.
	panelPage addMorphBack: aButton.
	aButton setBalloonText: 'Type what you want to search for in the box above, then click here (or hit RETURN or ENTER) to start the search; results will appear in the "search results" category.'.

	panelPage addTransparentSpacerOfSize: 0@30.
	panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Restore all Default Preference Settings'; target: Preferences; actionSelector: #chooseInitialSettings; setBalloonText: 'Click here to reset all the preferences to their standard default values.'; yourself).

	panelPage addTransparentSpacerOfSize: 0@14.
	panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 
'Save Current Settings as my Personal Preferences'; 
		target: Preferences; actionSelector: #savePersonalPreferences; setBalloonText: 'Click here to save the current constellation of Preferences settings as your personal defaults; you can get them all reinstalled with a single gesture by clicking the "Restore my Personal Preferences".'; yourself).

	panelPage addTransparentSpacerOfSize: 0@14.
	panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Restore my Personal Preferences'; target: Preferences; actionSelector: #restorePersonalPreferences; setBalloonText: 'Click here to reset all the preferences to their values in your Personal Preferences.'; yourself).

	panelPage addTransparentSpacerOfSize: 0@30.
	panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 
'Save Current Settings to Disk'; 
		target: Preferences; actionSelector: #storePreferencesToDisk; setBalloonText: 'Click here to save the current constellation of Preferences settings to a file; you can get them all reinstalled with a single gesture by clicking "Restore Settings From Disk".'; yourself).

	panelPage addTransparentSpacerOfSize: 0@14.
	panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Restore Settings from Disk'; target: Preferences; actionSelector: #restorePreferencesFromDisk; setBalloonText: 'Click here to load all the preferences from their saved values on disk.'; yourself).

	panelPage addTransparentSpacerOfSize: 0@30.

	panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Inspect Parameters'; target: Preferences; actionSelector: #inspectParameters; setBalloonText: 'Click here to view all the values stored in the system Parameters dictionary'; yourself).

	panelPage addTransparentSpacerOfSize: 0@10.
	panelPage addMorphBack: (Preferences themeChoiceButtonOfColor: Color transparent font: TextStyle defaultFont).
	panelPage addTransparentSpacerOfSize: 0@10.
	panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Help!!'; target: Preferences; actionSelector: #giveHelpWithPreferences; setBalloonText: 'Click here to get some hints on use of this Preferences Panel'; yourself).
	panelPage wrapCentering: #center.
! !

!PreferencesPanel methodsFor: 'find' stamp: 'sw 8/6/2001 12:09'!
containingWindow
	"Answer the window in which the receiver is seen"

	^ super containingWindow ifNil:
		[Smalltalk isMorphic ifFalse: [self currentWorld]]! !

!PreferencesPanel methodsFor: 'find' stamp: 'sw 2/18/2001 04:03'!
findCategoryFromPreference: prefSymbol
	"Find all categories in which the preference occurs"

	| aMenu| 
	aMenu _ MenuMorph new defaultTarget: self.
	(Preferences categoriesContainingPreference: prefSymbol) do:
		[:aCategory | aMenu add: aCategory target: self selector: #switchToCategoryNamed:event: argumentList: {aCategory. MorphicEvent new}].
	aMenu popUpInWorld! !

!PreferencesPanel methodsFor: 'find' stamp: 'sw 2/6/2001 02:01'!
findPreferencesMatchingSearchString
	"find all preferences matching incomingTextOrString"

	self findPreferencesMatching: self searchString! !

!PreferencesPanel methodsFor: 'find' stamp: 'rbb 3/1/2005 11:07'!
findPreference: evt
	"Allow the user to submit a selector fragment; search for that among preference names; put up a list of qualifying preferences; if the user selects one of those, redirect the preferences panel to reveal the chosen preference"

	self findPreferencesMatching: (UIManager default request: 'Search for preferences containing:' initialAnswer: 'color')! !

!PreferencesPanel methodsFor: 'find' stamp: 'sw 7/27/2001 16:39'!
initiateSearch: morphHoldingSearchString
	"Carry out the action of the Search button in the Preferences panel"

	searchString _ morphHoldingSearchString text.
	self setSearchStringTo: self searchString.
	
	self findPreferencesMatchingSearchString! !

!PreferencesPanel methodsFor: 'find' stamp: 'sw 2/6/2001 02:06'!
keyStroke: anEvent
	"Handle a keystroke event in the panel; we map f (for find) into a switch to the ? category"

	(anEvent keyCharacter == $f) ifTrue:
		[^ self switchToCategoryNamed: #? event: nil]! !

!PreferencesPanel methodsFor: 'find' stamp: 'sw 7/27/2001 23:11'!
searchString
	"Answer the current searchString, initializing it if need be"

	 | win aMorph |
searchString isEmptyOrNil ifTrue: 
		[searchString _ 'Type here, hit Search'.
		(win _ self containingWindow) ifNotNil:
			[aMorph _ win findDeepSubmorphThat:
					[:m | m isKindOf: PluggableTextMorph]
				ifAbsent: [^ searchString].
			aMorph setText: searchString.
			aMorph setTextMorphToSelectAllOnMouseEnter.
			aMorph selectAll]].
	^ searchString! !

!PreferencesPanel methodsFor: 'find' stamp: 'sw 2/6/2001 01:45'!
setSearchStringTo: aText
	"The user submitted aText as the search string; now search for it"

	searchString _ aText asString.
	self findPreferencesMatching: searchString.
	^ true! !


!PreferencesPanel methodsFor: 'initialization' stamp: 'sw 2/6/2001 02:13'!
addModelItemsToWindowMenu: aMenu
	"aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic SystemWindow.  Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself."

	true ifTrue: [^ self].  

	"The below are provisionally disenfranchised, because their function is now directly available in the ? category"
	aMenu addLine.
	aMenu add: 'find preference... (f)' target: self action: #findPreference:.
	aMenu add: 'inspect parameters' target: Preferences action: #inspectParameters! !

!PreferencesPanel methodsFor: 'initialization' stamp: 'FBS 2/24/2004 14:26'!
adjustProjectLocalEmphasisFor: aSymbol
	"Somewhere, the preference represented by aSymbol got changed from being one that is truly global to one that varies by project, or vice-versa.  Get my panel right -- this involves changing the emphasis on the item"

	| aWindow toFixUp allMorphs emphasis |
	(aWindow _ self containingWindow) ifNil: [^ self].
	emphasis _ (Preferences preferenceAt: aSymbol ifAbsent: [^ self]) localToProject
		ifTrue:	[TextEmphasis bold emphasisCode "bold for local-to-project"]
		ifFalse:	[TextEmphasis normal emphasisCode "normal for global"].
	allMorphs _ IdentitySet new.
	aWindow allMorphsAndBookPagesInto: allMorphs.
	toFixUp _ allMorphs select:
		[:m | (m isKindOf: StringMorph) and: [m contents = aSymbol]].
	toFixUp do:
		[:aStringMorph | aStringMorph emphasis: emphasis]

	! !

!PreferencesPanel methodsFor: 'initialization' stamp: 'md 2/24/2006 16:04'!
findPreferencesMatching: incomingTextOrString
	"find all preferences matching incomingTextOrString"

	| result aList aPalette controlPage  |
	result := incomingTextOrString asString asLowercase.
	result := result asLowercase withBlanksTrimmed.
	result isEmptyOrNil ifTrue: [^ self].

	aList := Preferences allPreferenceObjects select:
		[:aPreference | 
			(aPreference name includesSubstring: result caseSensitive: false) or:
				[aPreference helpString includesSubstring: result caseSensitive: false]].
	aPalette := (self containingWindow ifNil: [^ self]) findDeeplyA: TabbedPalette.
	aPalette ifNil: [^ self].
	aPalette selectTabNamed:  'search results'.
	aPalette currentPage ifNil: [^ self].  "bkwd compat"
	controlPage := aPalette currentPage.
	controlPage removeAllMorphs.
	controlPage addMorph: (StringMorph contents: ('Preferences matching "', self searchString, '"') font: Preferences standardButtonFont).
	controlPage color: Color transparent.
	aList := aList asSortedCollection:
		[:a :b | a name < b name].
	aList do:
		[:aPreference | | button |
			button _ aPreference representativeButtonWithColor:  Color transparent inPanel: self.
			button ifNotNil: [controlPage addMorphBack: button]].
	aPalette world startSteppingSubmorphsOf: aPalette! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PreferencesPanel class
	instanceVariableNames: ''!

!PreferencesPanel class methodsFor: 'cleanup' stamp: 'gm 2/22/2003 18:58'!
deleteAllPreferencesPanels
	"Called manually to clobber all existing preferences panels"
	"PreferencesPanel deleteAllPreferencesPanels"

	| aWindow |
	self allInstancesDo:
		[:aPanel |
			(aWindow _ aPanel containingWindow) isMorph
				ifTrue:
					[aWindow delete]].
	self killExistingMVCViews.
	UpdatingThreePhaseButtonMorph allInstancesDo: "clobber old stand-alone prefs buttons"
		[:m | (m actionSelector == #togglePreference:) ifTrue:
			[(m owner isAlignmentMorph) ifTrue:
				[m owner delete]]]! !

!PreferencesPanel class methodsFor: 'cleanup' stamp: 'RAA 4/14/2001 11:04'!
isAPreferenceViewToKill: aSystemView
	"Answer whether the given StandardSystemView is one affiliated with a PreferencesPanel"

	| m target subView |
	aSystemView subViews size = 1 ifFalse: [^ false].
	subView _ aSystemView subViews first.
	(subView isKindOf: MorphWorldView) ifFalse: [^ false].
	((m _ subView model) isKindOf: MVCWiWPasteUpMorph) ifFalse: [^ false].
	m submorphs size = 1 ifFalse: [^ false].
	m firstSubmorph submorphs size = 1 ifFalse: [^ false].
	target _ m firstSubmorph firstSubmorph. 
	(target isKindOf: TabbedPalette) ifFalse: [^ false].
	^ #(browsing debug fileout general halos) allSatisfy: [:s |
		(target tabNamed: s) notNil]! !

!PreferencesPanel class methodsFor: 'cleanup' stamp: 'RAA 4/14/2001 11:03'!
killExistingMVCViews
	"Kill all existing preferences views in mvc"
"
PreferencesPanel killExistingMVCViews
"
	| byebye |

	ControlManager allInstances do: [ :cm |
		byebye _ cm controllersSatisfying: [ :eachC |
			self isAPreferenceViewToKill: eachC view].
		byebye do: [ :each | 
			each status: #closed.
			each view release.
			cm unschedule: each]]! !


!PreferencesPanel class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:41'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Preferences Panel' brightColor: #(0.645 1.0 1.0)	pastelColor: #(0.886 1.0 1.0) helpMessage: 'A tool for expressing personal preferences for numerous options.'! !
Object subclass: #Presenter
	instanceVariableNames: 'associatedMorph standardPlayer standardPlayfield standardPalette playerList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!Presenter commentStamp: '<historical>' prior: 0!
Optionally associated with a PasteUpMorph, provides a local scope for the running of scripts.

Once more valuable, may be again, but at present occupies primarily a historical niche.

Maintains a playerList cache.

Holds, optionally three 'standard items' -- standardPlayer standardPlayfield standardPalette -- originally providing idiomatic support of ongoing squeak-team internal work, but now extended to more general applicability.

   !


!Presenter methodsFor: 'access' stamp: 'sw 4/17/1998 20:07'!
associatedMorph
	^ associatedMorph! !

!Presenter methodsFor: 'access' stamp: 'sw 4/17/1998 20:07'!
associatedMorph: aMorph
	associatedMorph _ aMorph! !

!Presenter methodsFor: 'access' stamp: 'sw 4/22/1998 20:05'!
world
	^ associatedMorph world! !


!Presenter methodsFor: 'button creation' stamp: 'sw 3/7/1999 00:52'!
addTrashCan
	| aPosition aCan |
	(aCan _ associatedMorph findA: TrashCanMorph) ifNotNil: [^ aCan].
	aCan _ TrashCanMorph newSticky.
	aPosition _ associatedMorph positionNear: (associatedMorph bottomRight - aCan extent) forExtent: aCan extent adjustmentSuggestion:  (-10 @ 0).
	aCan position: aPosition.
	associatedMorph addMorph: aCan.
	aCan startStepping.
	aCan setToAdhereToEdge: #bottomRight.
	^ aCan
! !


!Presenter methodsFor: 'intialize' stamp: 'sw 12/13/2004 16:58'!
allExtantPlayers
	"The initial intent here was to produce a list of Player objects associated with any Morph in the tree beneath the receiver's associatedMorph.  whether it is the submorph tree or perhaps off on unseen bookPages.  We have for the moment moved away from that initial intent, and in the current version we only deliver up players associated with the submorph tree only.  <-- this note dates from 4/21/99

Call #flushPlayerListCache; to force recomputation."

	| fullList objectsReferredToByTiles |
	playerList ifNotNil:
		[^ playerList].

	fullList _ associatedMorph allMorphs select: 
		[:m | m player ~~ nil] thenCollect: [:m | m player].
	fullList copy do:
		[:aPlayer |
			aPlayer class scripts do:
				[:aScript |  aScript isTextuallyCoded ifFalse:
					[aScript currentScriptEditor ifNotNilDo: [:ed |
						objectsReferredToByTiles _ ed allMorphs
							select:
								[:aMorph | (aMorph isKindOf: TileMorph) and: [aMorph type == #objRef]]
							thenCollect:
								[:aMorph | aMorph actualObject].
						fullList addAll: objectsReferredToByTiles]]]].

	^ playerList _ (fullList asSet asSortedCollection:
			[:a :b | a externalName < b externalName]) asArray! !


!Presenter methodsFor: 'misc' stamp: 'dgd 2/22/2003 19:08'!
currentlyViewing: aPlayer 
	"Only detects viewers in tabs"

	aPlayer ifNil: [^false].
	^aPlayer viewerFlapTab notNil! !

!Presenter methodsFor: 'misc' stamp: 'sw 8/28/2002 23:07'!
drawingJustCompleted: aSketchMorph
	"The user just finished drawing.  Now maybe put up a viewer"

	| aWorld |
	self flushPlayerListCache.  "Because a new drawing already created one, thus obviating #assuredPlayer kicking in with its invalidation"

	aWorld _ associatedMorph world.
	(aWorld hasProperty: #automaticFlapViewing)
		ifTrue:
			[^ aWorld presenter viewMorph: aSketchMorph].

	(aSketchMorph pasteUpMorph hasProperty: #automaticViewing)
		ifTrue:
			[self viewMorph: aSketchMorph]! !

!Presenter methodsFor: 'misc' stamp: 'sw 6/30/1999 20:31'!
morph: aMorph droppedIntoPasteUpMorph: aPasteUpMorph
	aPasteUpMorph automaticViewing ifTrue:
		[aMorph isCandidateForAutomaticViewing ifTrue:
			[self viewMorph: aMorph]]! !

!Presenter methodsFor: 'misc' stamp: 'sw 6/17/1998 10:16'!
standardPlayfield: aPlayfield
	standardPlayfield _ aPlayfield! !

!Presenter methodsFor: 'misc' stamp: 'sw 4/23/1998 18:47'!
tempCommand
	Transcript cr; show: '#tempCommand invoked for Presenter'! !


!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 4/21/1998 22:57'!
ownStandardPalette
	^ standardPalette! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 6/16/1998 16:17'!
standardPalette: aPalette
	standardPalette _ aPalette! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 2/12/2001 22:02'!
systemQueryPhraseWithActionString: anActionString labelled: aLabel
	"Answer a SystemQueryPhrase with the given action string and label"

	| aTile aPhrase |
	
	aPhrase _ SystemQueryPhrase new.
	aTile _ BooleanTile new.
	aTile setExpression: anActionString label: aLabel.
	aPhrase addMorph: aTile.
	aPhrase enforceTileColorPolicy.
	^ aPhrase! !


!Presenter methodsFor: 'playerList' stamp: 'sw 5/1/2005 00:22'!
allCurrentlyTickingScriptInstantiations
	"Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."

	^ Array streamContents:
		[:aStream | 
			self allExtantPlayers do:
				[:aPlayer | aPlayer instantiatedUserScriptsDo:
					[:aScriptInstantiation |
						aScriptInstantiation status == #ticking ifTrue:
							[aStream nextPut: aScriptInstantiation]]]]! !

!Presenter methodsFor: 'playerList' stamp: 'yo 7/2/2004 19:45'!
allKnownScriptSelectors
	"Answer a list of all the selectors implemented by any user-scripted objected within the scope of the receiver"

	| aSet allUniclasses |
	aSet _ Set with: ('script' translated , '1') asSymbol.
	allUniclasses _ (self presenter allPlayersWithUniclasses collect:
		[:aPlayer | aPlayer class]) asSet.
	allUniclasses do:
		[:aUniclass | aSet addAll: aUniclass namedTileScriptSelectors].
	^ aSet asSortedArray

"ActiveWorld presenter allKnownScriptSelectors"
! !

!Presenter methodsFor: 'playerList' stamp: 'sw 12/19/2003 23:39'!
allKnownUnaryScriptSelectors
	"Answer a list of all the unary selectors implemented by any user-scripted objected within the scope of the receiver; include #emptyScript as a bail-out"

	| aSet allUniclasses |
	aSet _ Set with: #emptyScript.
	allUniclasses _ (self allPlayersWithUniclasses collect:
		[:aPlayer | aPlayer class]) asSet.
	allUniclasses do:
		[:aUniclass | aSet addAll: aUniclass namedUnaryTileScriptSelectors].
	^ aSet asSortedArray

"ActiveWorld presenter allKnownUnaryScriptSelectors"
! !

!Presenter methodsFor: 'playerList' stamp: 'sw 1/12/2001 16:58'!
allPlayersWithUniclasses
	"Answer a list of all players known to the receiver that have uniclasses"

	^ self allExtantPlayers select: [:p | p belongsToUniClass]! !

!Presenter methodsFor: 'playerList' stamp: 'sw 8/2/2004 17:24'!
browseAllScriptsTextually
	"Open a method-list browser on all the scripts in the project"

	| aList aMethodList |
	(aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players'].
	aMethodList _ OrderedCollection new.
	aList do:
		[:aPair | aPair first addMethodReferencesTo: aMethodList].
	aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!'].
	
	SystemNavigation new 
		browseMessageList: aMethodList 
		name: 'All scripts in this project' 
		autoSelect: nil

"
ActiveWorld presenter browseAllScriptsTextually
"! !

!Presenter methodsFor: 'playerList' stamp: 'sw 6/29/1998 17:17'!
flushPlayerListCache
	playerList _ nil! !

!Presenter methodsFor: 'playerList' stamp: 'sw 3/8/2004 22:09'!
hasAnyTextuallyCodedScripts
	"Answer whether any uniclasses in the receiver have any textually coded scripts"

	self uniclassesAndCounts do:
		[:classAndCount | 
			classAndCount first scripts do:
				[:aScript | aScript isTextuallyCoded ifTrue: [^ true]]].
	^ false

"
ActiveWorld presenter hasAnyTextuallyCodedScripts
"! !

!Presenter methodsFor: 'playerList' stamp: 'sw 11/14/2001 00:31'!
reinvigorateAllScriptsTool: anAllScriptsTool 
	"Rebuild the contents of an All Scripts tool"

	| showingOnlyActiveScripts candidateList firstTwo oldList allExtantPlayers newList morphList |
	showingOnlyActiveScripts _ anAllScriptsTool showingOnlyActiveScripts.
	self flushPlayerListCache.
	"needed? Probably to pick up on programmatical script-status control only"

	firstTwo _ {anAllScriptsTool submorphs first.  anAllScriptsTool submorphs second}.
	oldList _ (anAllScriptsTool submorphs copyFrom: 3 to: anAllScriptsTool submorphs size) collect:
		[:aRow |
			(aRow findA: UpdatingSimpleButtonMorph) target].

	allExtantPlayers _ self allExtantPlayers.
	anAllScriptsTool showingAllInstances "take all instances of all classes"
		ifTrue:
			[candidateList _ allExtantPlayers]  

		ifFalse:  "include only one exemplar per uniclass.  Try to get one that has some qualifying scripts"
			[candidateList _ Set new.
			allExtantPlayers do:
				[:aPlayer |
					(candidateList detect: [:plyr | plyr isMemberOf:  aPlayer class] ifNone: [nil]) ifNil:
						[aPlayer instantiatedUserScriptsDo: [:aScriptInstantiation |
							(showingOnlyActiveScripts not or: [aScriptInstantiation pausedOrTicking]) 								ifTrue:
									[candidateList add: aPlayer]]]]].
	newList _ OrderedCollection new.
	candidateList do:
		[:aPlayer | aPlayer instantiatedUserScriptsDo:
			[:aScriptInstantiation |
				(showingOnlyActiveScripts not or: [aScriptInstantiation pausedOrTicking]) ifTrue:
					[newList add: aScriptInstantiation]]].

	oldList asSet = newList asSet
		ifFalse:
			[anAllScriptsTool removeAllMorphs; addAllMorphs: firstTwo.
			morphList _ newList collect:
				[:aScriptInstantiation |  aScriptInstantiation statusControlRowIn: anAllScriptsTool].
			anAllScriptsTool addAllMorphs: morphList.
			newList do:
				[:aScriptInstantiation | aScriptInstantiation updateAllStatusMorphs]]! !

!Presenter methodsFor: 'playerList' stamp: 'sw 7/28/2004 21:00'!
reinvigoratePlayersTool: aPlayersTool 
	"Rebuild the contents of the Players tool"

	| firstTwo oldList newList rowsForPlayers |
	firstTwo _ {aPlayersTool submorphs first.  aPlayersTool submorphs second}.
	oldList _ (aPlayersTool submorphs copyFrom: 3 to: aPlayersTool submorphs size) collect:
		[:aRow |
			aRow playerRepresented].
	self flushPlayerListCache.
	newList _ self allExtantPlayers.
	oldList asSet = newList asSet
		ifFalse:
			[aPlayersTool removeAllMorphs; addAllMorphs: firstTwo.
			rowsForPlayers _ newList collect:
				[:aPlayer |  aPlayer entryForPlayersTool: aPlayersTool].
			aPlayersTool addAllMorphs: rowsForPlayers ]! !

!Presenter methodsFor: 'playerList' stamp: 'yo 2/10/2005 17:07'!
reportPlayersAndScripts
	"Open a window which contains a report on players and their scripts"

	| aList aString |
	(aList _ self uniclassesAndCounts) ifEmpty:  [^ self inform: 'there are no scripted players' translated].
	aString _ String streamContents:
		[:aStream |
			aList do:
				[:aPair |
					aStream nextPutAll: aPair first name, ' -- ', aPair second printString.
					aStream nextPutAll: ' ', (aPair second > 1 ifTrue: ['instances'] ifFalse: ['instance']) translated, ', '.
					aStream nextPutAll: 'named' translated.
					aPair first allInstancesDo: [:inst | aStream space; nextPutAll: inst externalName].
					aStream cr].
			aStream cr.
			aList do:
				[:aPair |
					aStream cr.
					aStream nextPutAll: 
'--------------------------------------------------------------------------------------------'.
					aStream cr; nextPutAll: aPair first typicalInstanceName.
					aStream nextPutAll: '''s' translated.
					aStream nextPutAll: ' scripts:' translated.
					aPair first addDocumentationForScriptsTo: aStream]].

	(StringHolder new contents: aString)
		openLabel: 'All scripts in this project' translated

"self currentWorld presenter reportPlayersAndScripts"! !

!Presenter methodsFor: 'playerList' stamp: 'sw 1/30/2001 23:07'!
toolToViewScriptInstantiations
	"Open a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the world"

	AllScriptsTool launchAllScriptsToolFor: self

	"self currentWorld presenter toolToViewScriptInstantiations"! !

!Presenter methodsFor: 'playerList' stamp: 'sw 1/12/2001 18:10'!
uniclassesAndCounts
	"Answer a list of all players known to the receiver that have uniclasses"

	^ (self allPlayersWithUniclasses collect: [:aPlayer | aPlayer class]) asSet asArray collect:
		[:aClass | Array
			with:	aClass
			with:	aClass instanceCount]


	"self currentWorld presenter uniclassesAndCounts"! !


!Presenter methodsFor: 'printing' stamp: 'sw 3/3/1999 01:15'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' (', self asOop printString, ')'! !


!Presenter methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:14'!
adaptedToWorld: aWorld
	"If I refer to a world or a hand, return the corresponding items in the new world."
	^aWorld presenter! !


!Presenter methodsFor: 'standardPlayer etc' stamp: 'tk 7/28/2005 04:54'!
createStandardPlayer
	| aMorph |

	aMorph _ ImageMorph new image: (ScriptingSystem formAtKey: 'standardPlayer').
	associatedMorph addMorphFront: aMorph.
	(standardPlayer _ aMorph assuredPlayer) renameTo: 'dot' translated.
	aMorph setBalloonText: '...'.
	self positionStandardPlayer.
	^ standardPlayer! !

!Presenter methodsFor: 'standardPlayer etc' stamp: 'sw 1/20/2004 20:08'!
positionStandardPlayer
	"Put the standard player slightly off-screen"

	standardPlayer ifNotNil:
		[standardPlayer costume position: (associatedMorph topLeft - (13@0))]! !

!Presenter methodsFor: 'standardPlayer etc' stamp: 'sw 6/17/1998 16:05'!
standardPlayer
	standardPlayer ifNil:
		[self createStandardPlayer].
	standardPlayer costume isInWorld ifFalse: [associatedMorph addMorphNearBack: standardPlayer costume].
	^ standardPlayer! !


!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:17'!
allGoButtons
	"Answer a list of all script-controlling Go buttons within my scope"

	^ associatedMorph allMorphs select:
		[:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and:
			[aMorph actionSelector == #goUp:with:]]

	"ActiveWorld presenter allGoButtons"! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:19'!
allStepButtons
	"Answer a list of all the script-controlling Step buttons within my scope"

	^ associatedMorph allMorphs select:
		[:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and:
			[aMorph actionSelector == #stepStillDown:with:]]

	"ActiveWorld presenter allStepButtons"! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:18'!
allStopButtons
	"Answer a list of all script-controlling Stop buttons within my scope"

	^ associatedMorph allMorphs select:
		[:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and:
			[aMorph actionSelector == #stopUp:with:]]

	"ActiveWorld presenter allStopButtons"! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:08'!
goButtonState: newState
	"Get all go buttons in my scope to show the correct state"

	self allGoButtons do:
		[:aButton | aButton state: newState]! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 10/30/1998 15:36'!
goUp: evt with: aMorph
	self startRunningScripts! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:43'!
startRunningScripts
	"Start running scripts; get stop-step-go buttons to show the right thing"

	self stopButtonState: #off.
	self stepButtonState: #off.
	self goButtonState: #on.
	associatedMorph startRunningAll.

	"associatedMorph borderColor: Preferences borderColorWhenRunning."

	ThumbnailMorph recursionReset.  "needs to be done once in a while (<- tk note from 1997)"! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:43'!
startRunningScriptsFrom: ignored
	"Start running all scripts.  Get all script-control buttons to show the right thing."

	self startRunningScripts! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:10'!
stepButtonState: newState
	"Get all step buttons in my scope to show the correct state"

	self allStepButtons do:
		[:aButton | aButton state: newState]! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 5/6/1998 10:20'!
stepDown: evt with: aMorph
	self stopRunningScripts! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:06'!
stepStillDown: dummy with: theButton
	"The step button is still down; get temporary button feedback right and step all and then get all button feedback right again"

	self stepButtonState: #pressed.
	self stopButtonState: #off.
	associatedMorph stepAll.
	associatedMorph world displayWorld.
	self stepButtonState: #off.
	self stopButtonState: #on
! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:06'!
stepUp: evt with: aMorph
	"The step button came up; get things right"

	self stepButtonState: #off! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:08'!
stopButtonState: newState
	"Get all stop buttons in my scope to show the correct state"

	self allStopButtons do:
		[:aButton | aButton state: newState]! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:42'!
stopRunningScripts
	"Put all ticking scripts within my scope into paused mode.  Get any scripting-control buttons to show the correct state"

	self stopButtonState: #on.
	self stepButtonState: #off.
	self goButtonState: #off.
	associatedMorph stopRunningAll.

	"associatedMorph borderColor: Preferences borderColorWhenStopped"! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:42'!
stopRunningScriptsFrom: ignored
	"Stop running scripts; get all script-control buttons to reflect this"

	self stopRunningScripts! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 6/29/1998 17:23'!
stopUp: dummy with: theButton
	self flushPlayerListCache.  "catch guys not in cache but who're running"
	self stopRunningScripts! !


!Presenter methodsFor: 'tile support' stamp: 'dgd 2/22/2003 19:08'!
booleanTiles
	"Answer some boolean-valued tiles.  This dates back to very early etoy work in 1997, and presently has no sent senders"

	| list rcvr op arg |
	list := #(#(0 #< 1) #(0 #<= 1) #(0 #= 1) #(0 #~= 1) #(0 #> 1) #(0 #>= 1)).
	list := list asOrderedCollection collect: 
					[:entry | 
					rcvr := entry first.
					op := (entry second) asSymbol.
					arg := entry last.
					self 
						phraseForReceiver: rcvr
						op: op
						arg: arg
						resultType: #Boolean].
	list add: (self 
				phraseForReceiver: Color red
				op: #=
				arg: Color red
				resultType: #Boolean).
	^list	"copyWith: CompoundTileMorph new"! !

!Presenter methodsFor: 'tile support' stamp: 'gm 2/22/2003 14:53'!
constantTile: anObject 
	"Answer a constant tile that represents the object"

	(anObject isColor) 
		ifTrue: 
			[^ColorTileMorph new typeColor: (ScriptingSystem colorForType: #Color)].
	^anObject newTileMorphRepresentative 
		typeColor: (ScriptingSystem colorForType: (self typeForConstant: anObject))! !

!Presenter methodsFor: 'tile support' stamp: 'dgd 2/21/2003 22:35'!
phraseForReceiver: rcvr op: op arg: arg resultType: resultType 
	"Answer a PhraseTileMorph affiliated with the given receiver, initialized to hold the given operator, argument, and result type"

	| m argTile rcvrTile |
	arg isNil 
		ifTrue: 
			[m := PhraseTileMorph new 
						setOperator: op
						type: resultType
						rcvrType: (self typeForConstant: rcvr)]
		ifFalse: 
			[m := PhraseTileMorph new 
						setOperator: op
						type: resultType
						rcvrType: (self typeForConstant: rcvr)
						argType: (self typeForConstant: arg).
			argTile := self constantTile: arg.
			argTile position: m lastSubmorph position.
			m lastSubmorph addMorph: argTile].
	rcvrTile := self constantTile: rcvr.
	"	TilePadMorph makeReceiverColorOfResultType ifTrue: [rcvrTile color: m color]."
	rcvrTile position: m firstSubmorph position.
	m firstSubmorph addMorph: rcvrTile.
	m vResizing: #shrinkWrap.
	^m! !

!Presenter methodsFor: 'tile support' stamp: 'sw 4/25/1998 13:28'!
typeForConstant: anObject
	^ anObject basicType! !

!Presenter methodsFor: 'tile support' stamp: 'sw 9/27/2001 17:43'!
valueTiles
	"Answer some constant-valued tiles.  This dates back to very early etoy work in 1997, and presently has no senders"

	| tiles |
	tiles _ OrderedCollection new.
	tiles add: (5 newTileMorphRepresentative typeColor: (ScriptingSystem colorForType: #Number)).
	tiles add: (ColorTileMorph new typeColor: (ScriptingSystem colorForType: #Color)).
	tiles add: (TileMorph new typeColor: (ScriptingSystem colorForType: #Number);
			setExpression: '(180 atRandom)'
			label: 'random').
	tiles add: RandomNumberTile new.
	^ tiles! !


!Presenter methodsFor: 'viewer' stamp: 'sw 2/19/2001 15:41'!
cacheSpecs: aMorph
	"For SyntaxMorph's type checking, cache the list of all viewer command specifications."

	aMorph world ifNil: [^ true].
	Preferences universalTiles ifFalse: [^ true].
	Preferences eToyFriendly ifFalse: [^ true].	"not checking"
	(Project current projectParameterAt: #fullCheck ifAbsent: [false]) 
		ifFalse: [^ true].	"not checking"

	SyntaxMorph initialize.! !

!Presenter methodsFor: 'viewer' stamp: 'sw 1/17/1999 21:51'!
nascentPartsViewer
	^ StandardViewer new! !

!Presenter methodsFor: 'viewer' stamp: 'yo 3/30/2005 11:21'!
nascentPartsViewerFor: aViewee
	"Create a new, naked Viewer object for viewing aViewee.  Give it a vocabulary if either the viewee insists on one or if the project insists on one."

	| aViewer aVocab |
	(aViewee isKindOf: KedamaExamplerPlayer) ifTrue: [^ KedamaStandardViewer new].
	aViewer _ StandardViewer new.
	(aVocab _ aViewee vocabularyDemanded)
		ifNotNil:
			[aViewer useVocabulary: aVocab]
		ifNil:
			[(aVocab _ associatedMorph currentVocabularyFor: aViewee) ifNotNil:
				[aViewer useVocabulary: aVocab]].
	
	"If the viewee does not *demand* a special kind of Viewer, and if the project has not specified a preferred vocabulary, then the system defaults will kick in later"
	^ aViewer! !

!Presenter methodsFor: 'viewer' stamp: 'sw 12/28/1998 22:34'!
updateViewer: aViewer
	self updateViewer: aViewer forceToShow: nil! !

!Presenter methodsFor: 'viewer' stamp: 'yo 4/4/2005 18:22'!
updateViewer: aViewer forceToShow: aCategorySymbol
	"Update the given viewer to make sure it is in step with various possible changes in the outside world, and when reshowing it be sure it shows the given category"

	| aPlayer aPosition newViewer oldOwner wasSticky barHeight itsVocabulary aCategory categoryInfo restrictedIndex |
	aCategory _ aCategorySymbol ifNotNil: [aViewer currentVocabulary translatedWordingFor: aCategorySymbol].
	categoryInfo _ aViewer categoryMorphs  asOrderedCollection collect:
		[:aMorph | aMorph categoryRestorationInfo].

	itsVocabulary _ aViewer currentVocabulary.
	aCategory ifNotNil: [(categoryInfo includes: aCategorySymbol) ifFalse: [categoryInfo addFirst: aCategorySymbol]].
	aPlayer _ aViewer scriptedPlayer.
	aPosition _ aViewer position.
	wasSticky _ aViewer isSticky.
	newViewer _ aViewer species new visible: false.
	(aViewer isMemberOf: KedamaStandardViewer)
		ifTrue: [restrictedIndex _ aViewer restrictedIndex].
	barHeight _ aViewer submorphs first listDirection == #topToBottom
		ifTrue:
			[aViewer submorphs first submorphs first height]
		ifFalse:
			[0].
	Preferences viewersInFlaps ifTrue:
		[newViewer setProperty: #noInteriorThumbnail toValue: true].

	newViewer rawVocabulary: itsVocabulary.
	newViewer limitClass: aViewer limitClass.
	newViewer initializeFor: aPlayer barHeight: barHeight includeDismissButton: aViewer hasDismissButton showCategories: categoryInfo.
	(newViewer isMemberOf: KedamaStandardViewer)
		ifTrue: [
			newViewer providePossibleRestrictedView: 0.
			newViewer providePossibleRestrictedView: restrictedIndex].
	wasSticky ifTrue: [newViewer beSticky].
	oldOwner _ aViewer owner.
	oldOwner ifNotNil:
		[oldOwner replaceSubmorph: aViewer by: newViewer].
	
	"It has happened that old readouts are still on steplist.  We may see again!!"

	newViewer position: aPosition.
	newViewer enforceTileColorPolicy.
	newViewer visible: true.
	newViewer world ifNotNilDo: [:aWorld | aWorld startSteppingSubmorphsOf: newViewer].
	newViewer layoutChanged! !

!Presenter methodsFor: 'viewer' stamp: 'nk 9/21/2003 12:53'!
viewMorph: aMorph 
	| aPlayer openViewers aViewer aPalette aRect aPoint nominalHeight aFlapTab topItem flapLoc |
	Sensor leftShiftDown 
		ifFalse: 
			[((aPalette := aMorph standardPalette) notNil and: [aPalette isInWorld]) 
				ifTrue: [^aPalette viewMorph: aMorph]].
	aPlayer := (topItem := aMorph topRendererOrSelf) assuredPlayer.
	openViewers _ aPlayer allOpenViewers.
	aViewer := openViewers isEmpty ifFalse: [ openViewers first ] ifTrue: [ self nascentPartsViewer ].
	self cacheSpecs: topItem.	"redo the spec cache once in a while"

	"19 sept 2000 - allow flaps in any paste up"
	flapLoc := associatedMorph.	"world"
	Preferences viewersInFlaps  ifTrue:  [
		aViewer owner ifNotNilDo: [ :f | ^f flapTab showFlap; yourself ].
		aViewer setProperty: #noInteriorThumbnail toValue: true.
			aViewer initializeFor: aPlayer barHeight: 0.
			aViewer enforceTileColorPolicy.
			aViewer fullBounds.	"force layout"
			"associatedMorph addMorph: aViewer."	"why???"
			flapLoc hideViewerFlapsOtherThanFor: aPlayer.
			aFlapTab := flapLoc viewerFlapTabFor: topItem.
			aFlapTab referent submorphs 
				do: [:m | (m isKindOf: Viewer) ifTrue: [m delete]].
			aViewer visible: true.
			aFlapTab applyThickness: aViewer width + 25.
			aFlapTab spanWorld.
			aFlapTab showFlap.
			aViewer position: aFlapTab referent position.
			aFlapTab referent addMorph: aViewer beSticky.	"moved"
			flapLoc startSteppingSubmorphsOf: aFlapTab.
			flapLoc startSteppingSubmorphsOf: aViewer.
			^aFlapTab].
	aViewer initializeFor: aPlayer barHeight: 6.
	aViewer enforceTileColorPolicy.
	aViewer fullBounds.	"force layout"
	Preferences automaticViewerPlacement 
		ifTrue: 
			[aPoint := aMorph bounds right 
						@ (aMorph center y - ((nominalHeight := aViewer initialHeightToAllow) // 2)).
			aRect := (aPoint extent: aViewer width @ nominalHeight) 
						translatedToBeWithin: flapLoc bounds.
			aViewer position: aRect topLeft.
			aViewer visible: true.
			associatedMorph addMorph: aViewer.
			flapLoc startSteppingSubmorphsOf: aViewer.
			"it's already in the world, somewhat coincidentally"
			^aViewer].
	aMorph primaryHand attachMorph: (aViewer visible: true).
	^aViewer! !

!Presenter methodsFor: 'viewer' stamp: 'sw 6/20/2001 13:12'!
viewObjectDirectly: anObject
	"Open up and return a viewer on the given object"

	|  aViewer aRect aPoint nominalHeight aFlapTab flapLoc |

	associatedMorph addMorph: (aViewer _ self nascentPartsViewerFor: anObject).
	flapLoc _ associatedMorph "world".
	Preferences viewersInFlaps ifTrue:
		[aViewer setProperty: #noInteriorThumbnail toValue: true.
		aViewer initializeFor: anObject barHeight: 0.
		aViewer enforceTileColorPolicy.
		flapLoc hideViewerFlapsOtherThanFor: anObject.
		aFlapTab _ flapLoc viewerFlapTabFor: anObject.
		aFlapTab referent submorphs do: 
			[:m | (m isKindOf: Viewer) ifTrue: [m delete]].
		aFlapTab referent addMorph: aViewer beSticky.
		aViewer visible: true.
		aFlapTab applyThickness: aViewer width + 25.
		aFlapTab spanWorld.
		aFlapTab showFlap. 
		aViewer position: aFlapTab referent position.
		flapLoc startSteppingSubmorphsOf: aFlapTab.
		flapLoc startSteppingSubmorphsOf: aViewer.
		^ aFlapTab].
	
	"Caution: the branch below is historical and has not been used for a long time, though if you set the #viewersInFlaps preference to false you'd hit it.  Not at all recently maintained."
	aViewer initializeFor: anObject barHeight: 6.
	aViewer enforceTileColorPolicy.
	Preferences automaticViewerPlacement ifTrue:
		[aPoint _ anObject bounds right @ 
			(anObject center y - ((nominalHeight _ aViewer initialHeightToAllow) // 2)).
		aRect _ (aPoint extent: (aViewer width @ nominalHeight)) translatedToBeWithin: flapLoc bounds.
		aViewer position: aRect topLeft.
		aViewer visible: true.
		flapLoc startSteppingSubmorphsOf: aViewer.
		"it's already in the world, somewhat coincidentally"
		^ aViewer].
	anObject primaryHand attachMorph: (aViewer visible: true).
	^aViewer! !

!Presenter methodsFor: 'viewer' stamp: 'sw 6/20/2001 12:37'!
viewObject: anObject
	"Open up and return a viewer on the given object.  If the object is a Morph, open a viewer on its associated Player"

	anObject isMorph
		ifTrue:
			[self viewMorph: anObject]  "historic morph/player implementation"
		ifFalse:
			[self viewObjectDirectly: anObject]! !
TextDiffBuilder subclass: #PrettyTextDiffBuilder
	instanceVariableNames: 'sourceClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FilePackage'!

!PrettyTextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:16'!
sourceClass: aClass
	sourceClass _ aClass.! !

!PrettyTextDiffBuilder methodsFor: 'initialize' stamp: 'nk 2/25/2005 09:52'!
split: aString 
	| formatted trimmed |
	trimmed := aString asString withBlanksTrimmed.
	trimmed isEmpty ifTrue: [ ^super split: '' ].
	formatted := [ sourceClass prettyPrinterClass
				format: trimmed
				in: sourceClass
				notifying: nil
				decorated: false ] on: Error do: [ :ex | trimmed ].
	^ super split: formatted! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrettyTextDiffBuilder class
	instanceVariableNames: ''!

!PrettyTextDiffBuilder class methodsFor: 'instance creation' stamp: 'nk 10/29/2000 12:35'!
from: srcString to: dstString inClass: srcClass 
	^ (self new sourceClass: srcClass) from: srcString to: dstString
		!
]style[(6 9 5 9 10 8 6 4 18 8 8 9 5 9 3)f1b,f1cblack;b,f1b,f1cblack;b,f1b,f1cblack;b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1! !
Object subclass: #PrimCallControllerAbstract
	instanceVariableNames: 'treatedMethods logStream changeStatusOfFailedCallsFlag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-PrimCallController'!
!PrimCallControllerAbstract commentStamp: 'sr 6/16/2004 09:42' prior: 0!
A PrimCallController (PCC) serves for switching external prim calls (primitiveExternalCall) on and off: this is an abstract class, instantiate one of the subclasses PCCByLiterals and PCCByCompilation.

External prim calls are used to access internal and external modules (plugins) as shown by
	SmalltalkImage current listLoadedModules.
	SmalltalkImage current listBuiltinModules.
Note: not loaded external modules (since they have not been called so far) are not shown by these methods.

Highlight: dis/en-abling prims by a PCC works for both internal and external modules!!


To help you choosing the right subclass, some properties are listed in the following table:

Functionality/Property							|	PCCByLiterals	PCCByCompilation
------------------------------------------------------------------------------------------------------
testing plugins									|		suited			not suited
permanent disabling of external prim calls		|		no				yes
------------------------------------------------------------------------------------------------------
method changes visible in changeset				|		no				yes
enabling survives snapshot/compilation			|		yes				yes
disabling survives snapshot/compilation			|		no				yes
speed disabling									|		fast				medium
speed enabling									|		fast				slow
CompiledMethod pointer valid after en/dis-abling	|		yes				no
									
Important: Be careful with mixing the use of different PCCs!! PCCByLiterals does not see prims disabled by PCCByCompilation and vice versa. For playing around you should start with PCCByLiterals; use PCCByCompilation only, if you know what you are doing!!

In protocols 'ui controlling', 'ui logging' and 'ui querying' (please look into this class) are the most important user interface methods. Thereafter the methods in 'ui testing' could be of interest.


Useful expressions:

Controlling:
	"Factorial example"
	| pcc tDisabled tEnabled tEnabled2 |
	pcc _ PCCByLiterals new logStream: Transcript. "logStream set here for more info"
	pcc disableCallsIntoModule: 'LargeIntegers'.
	tDisabled _ [1000 factorial] timeToRun.
	pcc enableDisabled.
	tEnabled _ [1000 factorial] timeToRun.
	tEnabled2 _ [1000 factorial] timeToRun.
	{tDisabled. tEnabled. tEnabled2}
Note: You shouldn't switch off module 'LargeIntegers' for a longer time, since this slows down your system.

Querying:
	PCCByLiterals new methodsWithCall.								"all calls"
	PCCByLiterals new methodsWithCall: 'prim1'.						"call in all modules or without module"
	PCCByLiterals new methodsWithCallIntoModule: nil.				"all calls without module"
	PCCByLiterals new methodsWithCallIntoModule: 'LargeIntegers'.	"all calls into module 'LargeIntegers'"
	PCCByLiterals new
		methodsWithCallIntoModule: 'LargeIntegers'
		forClass: Integer.							"all calls into module 'LargeIntegers' in class Integer"
	PCCByLiterals new
		methodsWithCallIntoModule: 'LargeIntegers'
		forClasses: Integer withAllSubclasses.		"all calls into module 'LargeIntegers' in class Integer withAllSubclasses"

	| pcc | (pcc _ PCCByLiterals new) methodsWithCall
			collect: [:mRef | {mRef. pcc extractCallModuleNames: mRef}].


Structure:
 treatedMethods				Dictionary of MethodReferences->#disabled/#enabled
								-- contains changed methods and how they are changed last
 logStream					WriteStream -- shows info about changed methods ifNotNil
 changeStatusOfFailedCalls	Boolean -- if status of failed calls should be changed, default is false!
]style[(165 13 5 16 339 26 792 10 84 8 120 31 82 4 118 19 17 18 2 452 29 37 18 15 56 1 18 26 35 2 18 26 79 26 122 26 170 79 1 320)f2FAccuny#12,f2LPCCByLiterals Comment;,f2FAccuny#12,f2LPCCByCompilation Comment;,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#15,f2FAccuny#12,f2,f2u,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2!


!PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/11/2004 04:52'!
changeStatusOfFailedCallsFlag
	^changeStatusOfFailedCallsFlag! !

!PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/11/2004 04:12'!
logStream
	^logStream! !

!PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/2/2004 05:27'!
treatedMethods
	^treatedMethods! !


!PrimCallControllerAbstract methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/3/2006 22:39'!
initialize
	treatedMethods := Dictionary new.
"	logStream := Transcript."
	changeStatusOfFailedCallsFlag := false! !


!PrimCallControllerAbstract methodsFor: 'logging' stamp: 'sr 6/11/2004 05:12'!
log: aString 
	self logStream
		ifNotNil: [self logStream cr; show: '[' , self className , '] ' , aString]! !


!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:39'!
changeStatusOfFailedCalls
	"En/dis-able not only dis/en-abled calls, but also failed ones. Using this 
	feature can hide serious problems."
	changeStatusOfFailedCallsFlag := true! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:15'!
disableCallIn: aMethodRef 
	"Disables enabled external prim call."
	(self existsEnabledCallIn: aMethodRef)
		ifFalse: [self changeStatusOfFailedCallsFlag
				ifTrue: [(self existsFailedCallIn: aMethodRef)
						ifFalse: [^ self error: 'no enabled or failed prim call found']]
				ifFalse: [^ self error: 'no enabled prim call found']].
	self privateDisableCallIn: aMethodRef.
	self treatedMethods at: aMethodRef put: #disabled.
	self logStream
		ifNotNil: [self log: 'Call ' , (self extractCallModuleNames: aMethodRef) printString , ' in ' , aMethodRef actualClass name , '>>' , aMethodRef methodSymbol , ' disabled.']! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:30'!
disableCallInCompiledMethod: aCompiledMethod 
	"Disables external prim call."
	self changeCallCompiledMethod: aCompiledMethod enable: false! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'!
disableCallInMethod: selector class: classOrSymbol 
	"Disables external prim call."
	self
		changeCallMethod: selector
		class: classOrSymbol
		enable: false! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:35'!
disableCallsIntoModule: aModule 
	"Disables enabled external prim calls in aModule."
	| methods |
	methods := self methodsWithEnabledCallIntoModule: aModule.
	self changeStatusOfFailedCallsFlag
		ifTrue: [methods
				addAll: (self methodsWithFailedCallIntoModule: aModule)].
	methods isEmpty
		ifTrue: [^ self error: 'no enabled '
					, (self changeStatusOfFailedCallsFlag	ifTrue: ['or failed ']	ifFalse: [''])
					, 'prim calls for module ' , aModule , ' found'].
	methods
		do: [:mRef | self disableCallIn: mRef]! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 02:01'!
disableCallsIntoModule: aModule forClasses: classes 
	"Disables enabled external prim calls in aModule for classes."
	| methods |
	methods := self methodsWithEnabledCallIntoModule: aModule forClasses: classes.
	self changeStatusOfFailedCallsFlag
		ifTrue: [methods
				addAll: (self methodsWithFailedCallIntoModule: aModule forClasses: classes)].
	methods isEmpty
		ifTrue: [^ self error: 'no enabled '
					, (self changeStatusOfFailedCallsFlag	ifTrue: ['or failed ']	ifFalse: [''])
					, 'prim calls for module ' , aModule , ' in given classes found'].
	methods
		do: [:mRef | self disableCallIn: mRef]! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:44'!
disableEnabled
	"Disables these external prim calls, which are formerly enabled by self."
	self treatedMethods
		keysAndValuesDo: [:mRef :status | status == #enabled
				ifTrue: [self disableCallIn: mRef]]! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/14/2004 02:05'!
enableCallIn: aMethodRef 
	"Enables disabled external prim call."
	(self existsDisabledCallIn: aMethodRef)
		ifTrue: [self privateEnableCallIn: aMethodRef]
		ifFalse: [self changeStatusOfFailedCallsFlag
				ifTrue: [(self existsFailedCallIn: aMethodRef)
						ifTrue: [self privateEnableViaLiteralIn: aMethodRef]
						ifFalse: [^ self error: 'no disabled or failed prim call found']]
				ifFalse: [^ self error: 'no disabled prim call found']].
	self treatedMethods at: aMethodRef put: #enabled.
	self logStream
		ifNotNil: [self log: 'Call ' , (self extractCallModuleNames: aMethodRef) printString , ' in ' , aMethodRef actualClass name , '>>' , aMethodRef methodSymbol , ' enabled.']! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'!
enableCallInCompiledMethod: aCompiledMethod 
	"Enables disabled external prim call."
	self changeCallCompiledMethod: aCompiledMethod enable: true! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'!
enableCallInMethod: selector class: classOrSymbol 
	"Enables disabled external prim call."
	self
		changeCallMethod: selector
		class: classOrSymbol
		enable: true! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:36'!
enableCallsIntoModule: aModule 
	"Enables disabled external prim calls in aModule."
	| methods |
	methods := self methodsWithDisabledCallIntoModule: aModule.
	self changeStatusOfFailedCallsFlag
		ifTrue: [methods
				addAll: (self methodsWithFailedCallIntoModule: aModule)].
	methods isEmpty
		ifTrue: [^ self error: 'no disabled '
					, (self changeStatusOfFailedCallsFlag	ifTrue: ['or failed ']	ifFalse: [''])
					, 'prim calls for module ' , aModule , ' found'].
	methods
		do: [:mRef | self enableCallIn: mRef]! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 02:01'!
enableCallsIntoModule: aModule forClasses: classes 
	"Enables disabled external prim calls in aModule for classes."
	| methods |
	methods := self methodsWithDisabledCallIntoModule: aModule forClasses: classes.
	self changeStatusOfFailedCallsFlag
		ifTrue: [methods
				addAll: (self methodsWithFailedCallIntoModule: aModule forClasses: classes)].
	methods isEmpty
		ifTrue: [^ self error: 'no disabled '
					, (self changeStatusOfFailedCallsFlag	ifTrue: ['or failed ']	ifFalse: [''])
					, 'prim calls for module ' , aModule , ' in given classes found'].
	methods
		do: [:mRef | self enableCallIn: mRef]! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:42'!
enableDisabled
	"Enables these external prim calls, which are formerly disabled by self."
	self treatedMethods
		keysAndValuesDo: [:mRef :status | status == #disabled
				ifTrue: [self enableCallIn: mRef]]! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:41'!
preserveStatusOfFailedCalls
	"Do not en/dis-able failed calls (default)."
	changeStatusOfFailedCallsFlag := false! !

!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:45'!
switchStored
	"Disables enabled and enables disabled (see corresponding method 
	comments). "
	self treatedMethods
		keysAndValuesDo: [:mRef :status | status == #enabled
				ifTrue: [self disableCallIn: mRef]
				ifFalse: [self enableCallIn: mRef]]! !


!PrimCallControllerAbstract methodsFor: 'ui logging' stamp: 'sr 6/11/2004 04:17'!
logStream: aStreamOrNil 
	"If aStreamOrNil is notNil, there will be shown dis/en-abling prim call 
	info; nil means no logging."
	logStream := aStreamOrNil! !


!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/10/2004 21:15'!
extractCallModuleNames: aMethodRef
	"Returns prim call and module name as call->module Association."
	self subclassResponsibility! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:27'!
methodsWithCall
	"Returns all methods containing external prim calls."
	self subclassResponsibility! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:15'!
methodsWithCall: primName
	^ self methodsWithCall: primName enabled: nil! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:12'!
methodsWithCall: primName intoModule: moduleNameOrNil
	^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: nil! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:20'!
methodsWithCallIntoModule: moduleNameOrNil
	^ self methodsWithCallIntoModule: moduleNameOrNil enabled: nil! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:30'!
methodsWithCallIntoModule: moduleNameOrNil forClass: class 
	^ self methodsWithCallIntoModule: moduleNameOrNil forClasses: {class}! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:30'!
methodsWithCallIntoModule: moduleNameOrNil forClasses: classes 
	^ self
		methodsWithCallIntoModule: moduleNameOrNil
		forClasses: classes
		enabled: nil! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:36'!
methodsWithCompiledCall
	"Returns all methods containing compiled in external prim calls.  
	If the by compilation subclass has disabled some, this method does *not*  
	return all methods containing prim calls (use >>methodsWithCall in this 
	case). "
	^ (SystemNavigation new
		allMethodsSelect: [:method | method primitive = 117])
		reject: [:method | method actualClass == ProtoObject]! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:28'!
methodsWithDisabledCall
	"Returns all methods containing disabled external prim calls."
	self subclassResponsibility! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:24'!
methodsWithDisabledCall: primName
	^ self methodsWithCall: primName enabled: false! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:25'!
methodsWithDisabledCall: primName intoModule: moduleNameOrNil
	^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: false! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:25'!
methodsWithDisabledCallIntoModule: moduleNameOrNil
	^ self methodsWithCallIntoModule: moduleNameOrNil enabled: false! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:24'!
methodsWithDisabledCallIntoModule: moduleNameOrNil forClass: class 
	^ self methodsWithDisabledCallIntoModule: moduleNameOrNil forClasses: {class}! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:20'!
methodsWithDisabledCallIntoModule: moduleNameOrNil forClasses: classes 
	^ self
		methodsWithCallIntoModule: moduleNameOrNil
		forClasses: classes
		enabled: false! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:28'!
methodsWithEnabledCall
	"Returns all methods containing enabled external prim calls."
	^ self methodsWithCompiledCall
		select: [:mRef | (mRef compiledMethod literals first at: 4)
				>= 0]! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:15'!
methodsWithEnabledCall: primName
	^ self methodsWithCall: primName enabled: true! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:16'!
methodsWithEnabledCall: primName intoModule: moduleNameOrNil
	^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: true! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:11'!
methodsWithEnabledCallIntoModule: moduleNameOrNil
	^ self methodsWithCallIntoModule: moduleNameOrNil enabled: true! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 05:46'!
methodsWithEnabledCallIntoModule: moduleNameOrNil forClass: class 
	^ self methodsWithEnabledCallIntoModule: moduleNameOrNil forClasses: {class}! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:07'!
methodsWithEnabledCallIntoModule: moduleNameOrNil forClasses: classes 
	^ self
		methodsWithCallIntoModule: moduleNameOrNil
		forClasses: classes
		enabled: true! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 20:47'!
methodsWithFailedCall
	"Returns all methods containing failed external prim calls."
	^ self methodsWithCompiledCall select: self blockSelectFailedCall! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 01:40'!
methodsWithFailedCallForClass: class 
	^ class selectors
		collect: [:sel | MethodReference new setStandardClass: class methodSymbol: sel]
		thenSelect: [:mRef | self existsFailedCallIn: mRef]! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 01:44'!
methodsWithFailedCallForClasses: classes
	| result |
	result := OrderedCollection new.
	classes
		do: [:class | result
				addAll: (self methodsWithFailedCallForClass: class)].
	^ result! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 19:58'!
methodsWithFailedCallIntoModule: moduleNameOrNil 
	^ self methodsWithFailedCall
		select: (self blockSelectModuleName: moduleNameOrNil)! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:19'!
methodsWithFailedCallIntoModule: moduleNameOrNil forClass: class 
	^ self methodsWithFailedCallIntoModule: moduleNameOrNil forClasses: {class}! !

!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 19:58'!
methodsWithFailedCallIntoModule: moduleNameOrNil forClasses: classes
	^ (self methodsWithFailedCallForClasses: classes)
		select: (self blockSelectModuleName: moduleNameOrNil)! !


!PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:31'!
existsCallIn: aMethodRef

	self subclassResponsibility! !

!PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/9/2004 02:12'!
existsDisabledCallIn: aMethodRef 
	self subclassResponsibility! !

!PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/11/2004 06:34'!
existsEnabledCallIn: aMethodRef 
	^ (self existsCompiledCallIn: aMethodRef)
		and: [(aMethodRef compiledMethod literals first at: 4)
				>= 0]! !

!PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/15/2004 20:46'!
existsFailedCallIn: aMethodRef 
	^ (self existsCompiledCallIn: aMethodRef)
		and: [self blockSelectFailedCall value: aMethodRef]! !


!PrimCallControllerAbstract methodsFor: 'private' stamp: 'sr 6/10/2004 21:32'!
extractCallModuleNamesFromLiterals: aMethodRef 
	| firstLiteral |
	firstLiteral := aMethodRef compiledMethod literals first.
	^ (firstLiteral at: 2)
		-> (firstLiteral at: 1)! !


!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:49'!
blockSelectCallName: callName

	^ [:mRef | (self extractCallModuleNames: mRef) key = callName]! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 20:45'!
blockSelectFailedCall
	"Precondition: mRef references compiledCall."
	^ [:mRef | (mRef compiledMethod literals first at: 4)
		= -1]! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:50'!
blockSelectModuleName: moduleNameOrNil

	^ [:mRef | (self extractCallModuleNames: mRef) value = moduleNameOrNil]! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'md 2/16/2006 14:02'!
changeCallCompiledMethod: aCompiledMethod enable: enableFlag 
	"Enables disabled or disables enabled external prim call by recompiling 
	method with prim call taken from comment."
	|  methodRef |
	methodRef := aCompiledMethod methodReference.
	enableFlag
		ifTrue: [self enableCallIn: methodRef]
		ifFalse: [self disableCallIn: methodRef]! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 17:31'!
changeCallMethod: selector class: classOrSymbol enable: enableFlag 
	"Enables disabled or disables enabled external prim call by recompiling  
	method with prim call taken from comment."
	| methodRef |
	methodRef := MethodReference new
				setStandardClass: (classOrSymbol isSymbol
						ifTrue: [Smalltalk at: classOrSymbol]
						ifFalse: [classOrSymbol])
				methodSymbol: selector.
	enableFlag
		ifTrue: [self enableCallIn: methodRef]
		ifFalse: [self disableCallIn: methodRef]! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/11/2004 06:31'!
existsCompiledCallIn: aMethodRef 
	"This just means that there is a compiled in external prim call: from the 
	by compiler subclass point of view disabled prim calls not visible by 
	this method are also prim calls."
	^ aMethodRef compiledMethod primitive = 117! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:59'!
methodsWithCall: callName enabled: enabledFlag 
	^ (self methodsWithCallEnabled: enabledFlag)
		select: (self blockSelectCallName: callName)! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 20:24'!
methodsWithCall: callName intoModule: moduleNameOrNil enabled: enabledFlag 
	^ ((self methodsWithCallEnabled: enabledFlag)
		select: (self blockSelectCallName: callName))
		select: (self blockSelectModuleName: moduleNameOrNil)! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 19:17'!
methodsWithCallEnabled: enabledFlag 
	^ enabledFlag
		ifNil: [self methodsWithCall]
		ifNotNil: [enabledFlag
				ifTrue: [self methodsWithEnabledCall]
				ifFalse: [self methodsWithDisabledCall]]! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 19:19'!
methodsWithCallForClass: class enabled: enabledFlag 
	^ class selectors
		collect: [:sel | MethodReference new setStandardClass: class methodSymbol: sel]
		thenSelect: (enabledFlag
				ifNil: [[:mRef | self existsCallIn: mRef]]
				ifNotNil: [enabledFlag
						ifTrue: [[:mRef | self existsEnabledCallIn: mRef]]
						ifFalse: [[:mRef | self existsDisabledCallIn: mRef]]])! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/13/2004 20:00'!
methodsWithCallForClasses: classes enabled: enabledFlag 
	| result |
	result := OrderedCollection new.
	classes
		do: [:class | result
				addAll: (self methodsWithCallForClass: class enabled: enabledFlag)].
	^ result! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:55'!
methodsWithCallIntoModule: moduleNameOrNil enabled: enabledFlag 
	^ (self methodsWithCallEnabled: enabledFlag)
		select: (self blockSelectModuleName: moduleNameOrNil)! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:57'!
methodsWithCallIntoModule: moduleNameOrNil forClasses: classes enabled: enabledFlag 
	^ (self methodsWithCallForClasses: classes enabled: enabledFlag)
		select: (self blockSelectModuleName: moduleNameOrNil)! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:34'!
privateDisableCallIn: aMethodRefWithExternalCall
	"Disables enabled or failed external prim call."
	self subclassResponsibility! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:33'!
privateEnableCallIn: aMethodRefWithExternalCall
	"Enables disabled external prim call."
	self subclassResponsibility! !

!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:09'!
privateEnableViaLiteralIn: aMethodRef 
	"Enables external prim call by filling function ref literal with zero for 
	'non called'."
	aMethodRef compiledMethod literals first at: 4 put: 0.
	Object flushCache! !
ClassTestCase subclass: #PrimCallControllerAbstractTest
	instanceVariableNames: 'pcc doNotMakeSlowTestsFlag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-PrimCallController'!
!PrimCallControllerAbstractTest commentStamp: 'sr 6/15/2004 19:20' prior: 0!
PrimCallController tests.

Tests are here, but this class isAbstract and won't be tested.
Tests are done in the subclasses, which inherit the tests here.

If you want to perform some more very slow tests, change doNotMakeSlowTestsFlag in >>setUp.!


!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:46'!
compiledMethodsToExampleModule
	^ self methodSelectorsToExampleModule
		collect: [:sel | self class >> sel]! !

!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:11'!
failedCallRef
	^ MethodReference new setStandardClass: self class methodSymbol: self failedCallSelector! !

!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:46'!
methodRefsToExampleModule
	^ self methodSelectorsToExampleModule
		collect: [:sym | MethodReference new setStandardClass: self class methodSymbol: sym]! !

!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 13:58'!
noExternalCallRef
	^ MethodReference new setStandardClass: self class methodSymbol: self noExternalCallSelector! !

!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'!
numOfCallsExampleModule
	^ self methodSelectorsToExampleModule size! !

!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:34'!
singularCallRef
	^ MethodReference new setStandardClass: self class methodSymbol: self singularCallSelector! !

!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:49'!
wrongCallRef
	^ MethodReference new setStandardClass: self class methodSymbol: #nonExistingCall! !

!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:49'!
wrongClassRef
	^ MethodReference new setStandardClass: Integer methodSymbol: self methodSelectorsToExampleModule first! !


!PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/14/2004 22:56'!
avoidSlowTest

	^ doNotMakeSlowTestsFlag and: [pcc class = PCCByCompilation]! !

!PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/7/2004 08:56'!
disabledCallRefs
	^ self disabledCallSelectors
		collect: [:sel | MethodReference new setStandardClass: self class methodSymbol: sel]! !

!PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/7/2004 08:57'!
enabledCallRefs
	^ self enabledCallSelectors
		collect: [:sel | MethodReference new setStandardClass: self class methodSymbol: sel]! !


!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 04:37'!
setUp
	super setUp.
	pcc := self classToBeTested new.
	"set failed call"
	(self class >> self failedCallSelector) literals first at: 4 put: -1.
	"set it to false for some very slow tests..."
	doNotMakeSlowTestsFlag := true! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:54'!
testChangeFailedCallFailing
	pcc preserveStatusOfFailedCalls.
	self
		should: [pcc enableCallIn: self failedCallRef]
		raise: TestResult error.
	self
		should: [pcc disableCallIn: self failedCallRef]
		raise: TestResult error! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:41'!
testChangeFailedCallSucceedingDisable
	pcc changeStatusOfFailedCalls.
	pcc disableCallIn: self failedCallRef.
	self
		assert: (pcc existsDisabledCallIn: self failedCallRef).
	"necessary for PCCByCompilation (to make it visible for initialization again)"
	pcc enableCallIn: self failedCallRef! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:34'!
testChangeFailedCallSucceedingEnable
	pcc changeStatusOfFailedCalls.
	pcc enableCallIn: self failedCallRef.
	self
		assert: (pcc existsEnabledCallIn: self failedCallRef)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:43'!
testDisableCallsIntoModule
	"wrong module"
	self
		should: [pcc disableCallsIntoModule: 'totallyRandom4711']
		raise: TestResult error.
	"precondition: all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"disabling"
	pcc disableCallsIntoModule: self exampleModuleName.
	"now all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	"not enabled!!"
	self
		should: [pcc disableCallsIntoModule: self exampleModuleName]
		raise: TestResult error.
	"enabling"
	self methodRefsToExampleModule
		do: [:ref | pcc enableCallIn: ref].
	"all enabled now"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not enabled!!"
	self
		should: [pcc disableCallsIntoModule: self failModuleName]
		raise: TestResult error.
	pcc changeStatusOfFailedCalls.
	pcc disableCallsIntoModule: self failModuleName.
	self assert: (pcc existsDisabledCallIn: self failedCallRef).
	"postcondition"
	pcc enableCallIn: self failedCallRef
! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:24'!
testDisableCallsIntoModuleForClasses
	"wrong module"
	self
		should: [pcc disableCallsIntoModule: 'totallyRandom4711' forClasses: {self class}]
		raise: TestResult error.
	"precondition: all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"disabling"
	pcc disableCallsIntoModule: self exampleModuleName forClasses: {self class}.
	"now all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	"not enabled!!"
	self
		should: [pcc disableCallsIntoModule: self exampleModuleName forClasses: {self class}]
		raise: TestResult error.
	"enabling"
	self methodRefsToExampleModule
		do: [:ref | pcc enableCallIn: ref].
	"all enabled now"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not enabled!!"
	self
		should: [pcc disableCallsIntoModule: self failModuleName forClasses: {self class}]
		raise: TestResult error.
	pcc changeStatusOfFailedCalls.
	pcc disableCallsIntoModule: self failModuleName forClasses: {self class}.
	self assert: (pcc existsDisabledCallIn: self failedCallRef).
	"postcondition"
	pcc enableCallIn: self failedCallRef
! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:43'!
testEnableCallsIntoModule
	self avoidSlowTest
		ifTrue: [^ self].
	"wrong module"
	self
		should: [pcc enableCallsIntoModule: 'totallyRandom4711']
		raise: TestResult error.
	"precondition: all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not disabled!!"
	self
		should: [pcc enableCallsIntoModule: self exampleModuleName]
		raise: TestResult error.
	"disabling"
	self methodRefsToExampleModule
		do: [:ref | pcc disableCallIn: ref].
	"now all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	"enabling"
	"now this should work"
	pcc enableCallsIntoModule: self exampleModuleName.
	"all enabled now"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not disabled!!"
	self
		should: [pcc enableCallsIntoModule: self failModuleName]
		raise: TestResult error.
	pcc changeStatusOfFailedCalls.
	pcc enableCallsIntoModule: self failModuleName.
	self assert: (pcc existsEnabledCallIn: self failedCallRef)
! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:43'!
testEnableCallsIntoModuleForClasses
	"wrong module"
	self
		should: [pcc enableCallsIntoModule: 'totallyRandom4711' forClasses: {self class}]
		raise: TestResult error.
	"precondition: all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not disabled!!"
	self
		should: [pcc enableCallsIntoModule: self exampleModuleName forClasses: {self class}]
		raise: TestResult error.
	"disabling"
	self methodRefsToExampleModule
		do: [:ref | pcc disableCallIn: ref].
	"now all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	"enabling"
	"now this should work"
	pcc enableCallsIntoModule: self exampleModuleName forClasses: {self class}.
	"all enabled now"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not disabled!!"
	self
		should: [pcc enableCallsIntoModule: self failModuleName forClasses: {self class}]
		raise: TestResult error.
	pcc changeStatusOfFailedCalls.
	pcc enableCallsIntoModule: self failModuleName forClasses: {self class}.
	self assert: (pcc existsEnabledCallIn: self failedCallRef)
! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:45'!
testEnableDisableCallIn
	| refs |
	refs := self methodRefsToExampleModule.
	"wrong call"
	self
		should: [pcc disableCallIn: self wrongCallRef]
		raise: TestResult error.
	"wrong class"
	self
		should: [pcc disableCallIn: self wrongClassRef]
		raise: TestResult error.
	"wrong call"
	self
		should: [pcc enableCallIn: self wrongCallRef]
		raise: TestResult error.
	"wrong class"
	self
		should: [pcc enableCallIn: self wrongClassRef]
		raise: TestResult error.
	"no external call"
	self
		should: [pcc enableCallIn: self noExternalCallRef]
		raise: TestResult error.
	"precondition: all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not disabled!!"
	self
		should: [refs
				do: [:ref1 | pcc enableCallIn: ref1]]
		raise: TestResult error.
	"disabling"
	refs
		do: [:ref2 | pcc disableCallIn: ref2].
	"now all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	"not enabled!!"
	self
		should: [refs
				do: [:ref3 | pcc disableCallIn: ref3]]
		raise: TestResult error.
	"enabling"
	"now this should work"
	refs
		do: [:ref4 | pcc enableCallIn: ref4].
	"all enabled now"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"try caches"
	pcc disableEnabled.
	"all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	pcc enableDisabled.
	"all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:07'!
testEnableDisableCallInCompiledMethod
	"Note: >>compiledMethodsToExampleModule has to be called frequently,  
	since the CMs are changing with a successful compile!!"
	"precondition: all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not disabled!!"
	self
		should: [self compiledMethodsToExampleModule
				do: [:cm1 | pcc enableCallInCompiledMethod: cm1]]
		raise: TestResult error.
	"disabling"
	self compiledMethodsToExampleModule
		do: [:cm2 | pcc disableCallInCompiledMethod: cm2].
	"now all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	"not enabled!!"
	self
		should: [self compiledMethodsToExampleModule
				do: [:cm3 | pcc disableCallInCompiledMethod: cm3]]
		raise: TestResult error.
	"enabling"
	"now this should work"
	self compiledMethodsToExampleModule
		do: [:cm4 | pcc enableCallInCompiledMethod: cm4].
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"try caches"
	pcc disableEnabled.
	"all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	pcc enableDisabled.
	"all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:57'!
testEnableDisableCallInMethodClass
	| sels |
	sels := self methodSelectorsToExampleModule.
	"wrong call"
	self
		should: [pcc disableCallInMethod: #nonExistingCall class: self class]
		raise: TestResult error.
	"wrong class"
	self
		should: [pcc disableCallInMethod: sels first class: Integer]
		raise: TestResult error.
	"wrong call"
	self
		should: [pcc enableCallInMethod: #nonExistingCall class: self class]
		raise: TestResult error.
	"wrong class"
	self
		should: [pcc enableCallInMethod: sels first class: Integer]
		raise: TestResult error.
	self
		should: [pcc enableCallInMethod: self noExternalCallSelector class: self class]
		raise: TestResult error.
	"precondition: all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"not disabled!!"
	self
		should: [sels
				do: [:sel1 | pcc enableCallInMethod: sel1 class: self class]]
		raise: TestResult error.
	"disabling"
	sels
		do: [:sel2 | pcc disableCallInMethod: sel2 class: self class].
	"now all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	"not enabled!!"
	self
		should: [sels
				do: [:sel3 | pcc disableCallInMethod: sel3 class: self class]]
		raise: TestResult error.
	"enabling"
	"now this should work"
	sels
		do: [:sel4 | pcc enableCallInMethod: sel4 class: self class].
	"all enabled now"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	"try caches"
	pcc disableEnabled.
	"all disabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	pcc enableDisabled.
	"all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:46'!
testExistsCallIn
	self
		deny: (pcc existsCallIn: self noExternalCallRef).
	self enabledCallRefs , self disabledCallRefs , {self failedCallRef}
		do: [:callRef | self
				assert: (pcc existsCallIn: callRef)]! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:47'!
testExistsDisabledCallIn
	self
		deny: (pcc existsDisabledCallIn: self noExternalCallRef).
	self
		deny: (pcc existsDisabledCallIn: self failedCallRef).
	self enabledCallRefs
		do: [:callRef | self
				deny: (pcc existsDisabledCallIn: callRef)].
	self disabledCallRefs
		do: [:disabledRef | self
				assert: (pcc existsDisabledCallIn: disabledRef)]! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:48'!
testExistsEnabledCallIn
	self
		deny: (pcc existsEnabledCallIn: self noExternalCallRef).
	self
		deny: (pcc existsEnabledCallIn: self failedCallRef).
	self enabledCallRefs
		do: [:callRef | self
				assert: (pcc existsEnabledCallIn: callRef)].
	self disabledCallRefs
		do: [:disabledRef | self
				deny: (pcc existsEnabledCallIn: disabledRef)]! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:49'!
testExistsFailedCallIn
	self
		deny: (pcc existsFailedCallIn: self noExternalCallRef).
	self enabledCallRefs , self disabledCallRefs
		do: [:callRef | self
				deny: (pcc existsFailedCallIn: callRef)].
	self
		assert: (pcc existsFailedCallIn: self failedCallRef)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:25'!
testMethodsWithCallAndMethodsWithDisabledCall
	| methodRefs disabledMethodRefs enabledMethodRefs failedMethodRefs |
	self avoidSlowTest
		ifTrue: [^ self].
	disabledMethodRefs := pcc methodsWithDisabledCall.
	self assert: disabledMethodRefs size > 0.
	enabledMethodRefs := pcc methodsWithEnabledCall.
	self assert: enabledMethodRefs size > 0.
	failedMethodRefs := pcc methodsWithFailedCall.
	self assert: failedMethodRefs size > 0.
	methodRefs := pcc methodsWithCall.
	self assert: methodRefs size = (disabledMethodRefs size + enabledMethodRefs size + failedMethodRefs size)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:54'!
testMethodsWithCallIntoModule
	| methodRefs |
	self avoidSlowTest ifTrue: [^ self].
	"precondition: all enabled"
	pcc disableCallIn: self methodRefsToExampleModule first.
	methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName.
	self assert: methodRefs size = self numOfCallsExampleModule.
	"postcondition"
	pcc enableCallIn: self methodRefsToExampleModule first! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:32'!
testMethodsWithCallIntoModuleForClass
	"precondition: all enabled"
	| methodRefs |
	pcc disableCallIn: self methodRefsToExampleModule first.
	methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName forClass: self class.
	self assert: methodRefs size = self numOfCallsExampleModule.
	"postcondition"
	pcc enableCallIn: self methodRefsToExampleModule first.
	methodRefs := pcc methodsWithCallIntoModule: nil forClass: self class.
	self
		assert: (methodRefs size = 2
				and: [| methodCoreStrings | 
					methodCoreStrings := methodRefs
								collect: [:mRef | mRef methodSymbol allButFirst asString].
					(methodCoreStrings includes: 'ExternalCallWithoutModule')
						and: [methodCoreStrings includes: 'DisabledExternalCallWithoutModule']])! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:31'!
testMethodsWithCallIntoModuleForClasses
	"precondition: all enabled"
	| methodRefs |
	pcc disableCallIn: self methodRefsToExampleModule first.
	methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName forClasses: {self class}.
	self assert: methodRefs size = self numOfCallsExampleModule.
	"postcondition"
	pcc enableCallIn: self methodRefsToExampleModule first.
	methodRefs := pcc methodsWithCallIntoModule: nil forClasses: {self class}.
	self
		assert: (methodRefs size = 2
				and: [| methodCoreStrings | 
					methodCoreStrings := methodRefs
								collect: [:mRef | mRef methodSymbol allButFirst asString].
					(methodCoreStrings includes: 'ExternalCallWithoutModule')
						and: [methodCoreStrings includes: 'DisabledExternalCallWithoutModule']])! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:36'!
testMethodsWithCallX
	| methodRefs |
	self avoidSlowTest
		ifTrue: [^ self].
	methodRefs := pcc methodsWithCall: self singularCallName.
	self assert: methodRefs size = 1! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:34'!
testMethodsWithCallXIntoModule
	| methodRefs |
	self avoidSlowTest
		ifTrue: [^ self].
	methodRefs := pcc methodsWithCall: self singularCallName intoModule: self moduleNameWithSingularCallName.
	self assert: methodRefs size = 1.
	methodRefs := pcc methodsWithCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName.
	self assert: methodRefs isEmpty! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:04'!
testMethodsWithDisabledCallIntoModule
	| methodRefs |
	self avoidSlowTest ifTrue: [^ self].
	"precondition: all enabled"
	pcc disableCallIn: self methodRefsToExampleModule first.
	methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName.
	self assert: methodRefs size = 1.
	"postcondition"
	pcc enableCallIn: self methodRefsToExampleModule first! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:37'!
testMethodsWithDisabledCallIntoModuleForClass
	"precondition: all enabled"
	| methodRefs |
	self methodRefsToExampleModule
		do: [:ref | pcc disableCallIn: ref].
	methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName forClass: self class.
	self assert: methodRefs size = self numOfCallsExampleModule.
	"postcondition"
	self methodRefsToExampleModule
		do: [:ref | pcc enableCallIn: ref].
	methodRefs := pcc methodsWithDisabledCallIntoModule: nil forClass: self class.
	self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'DisabledExternalCallWithoutModule')! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'!
testMethodsWithDisabledCallIntoModuleForClasses
	"precondition: all enabled"
	| methodRefs |
	self methodRefsToExampleModule
		do: [:ref | pcc disableCallIn: ref].
	methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName forClasses: {self class}.
	self assert: methodRefs size = self numOfCallsExampleModule.
	"postcondition"
	self methodRefsToExampleModule
		do: [:ref | pcc enableCallIn: ref].
	methodRefs := pcc methodsWithDisabledCallIntoModule: nil forClasses: {self class}.
	self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'DisabledExternalCallWithoutModule')! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:38'!
testMethodsWithDisabledCallX
	| methodRefs |
	self avoidSlowTest
		ifTrue: [^ self].
	"precondition: all enabled"
	pcc disableCallIn: self singularCallRef.
	methodRefs := pcc methodsWithDisabledCall: self singularCallName.
	self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self singularCallName).
	"postcondition"
	pcc enableCallIn: self singularCallRef! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:42'!
testMethodsWithDisabledCallXIntoModule
	"precondition: all enabled"
	| methodRefs |
	self avoidSlowTest
		ifTrue: [^ self].
	"precondition: all enabled"
	pcc disableCallIn: self singularCallRef.
	methodRefs := pcc methodsWithDisabledCall: self singularCallName intoModule: self moduleNameWithSingularCallName.
	self assert: methodRefs size = 1.
	methodRefs := pcc methodsWithDisabledCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName.
	self assert: methodRefs isEmpty.
	"postcondition"
	pcc enableCallIn: self singularCallRef! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:13'!
testMethodsWithEnabledCall
	| methodRefs |
	methodRefs := pcc methodsWithEnabledCall.
	self assert: methodRefs size > 0! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:17'!
testMethodsWithEnabledCallIntoModule
	| methodRefs |
	methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName.
	self assert: methodRefs size = self numOfCallsExampleModule! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:43'!
testMethodsWithEnabledCallIntoModuleForClass
	"precondition: all enabled"
	| methodRefs |
	methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class.
	self assert: methodRefs size = self numOfCallsExampleModule.
	methodRefs := pcc methodsWithEnabledCallIntoModule: nil forClass: self class.
	self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'ExternalCallWithoutModule')! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:12'!
testMethodsWithEnabledCallIntoModuleForClasses
	"precondition: all enabled"
	| methodRefs |
	methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClasses: {self class}.
	self assert: methodRefs size = self numOfCallsExampleModule.
	methodRefs := pcc methodsWithEnabledCallIntoModule: nil forClasses: {self class}.
	self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'ExternalCallWithoutModule')! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:16'!
testMethodsWithEnabledCallX
	| methodRefs |
	methodRefs := pcc methodsWithEnabledCall: self singularCallName.
	self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self singularCallName)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:17'!
testMethodsWithEnabledCallXIntoModule
	"precondition: all enabled"
	| methodRefs |
	methodRefs := pcc methodsWithEnabledCall: self singularCallName intoModule: self moduleNameWithSingularCallName.
	self assert: methodRefs size = 1.
	methodRefs := pcc methodsWithEnabledCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName.
	self assert: methodRefs isEmpty! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:07'!
testMethodsWithFailedCall
	| methodRefs |
	methodRefs := pcc methodsWithFailedCall.
	self assert: methodRefs size >= 1 & ((methodRefs
				select: [:mRef | mRef methodSymbol = self failedCallSelector]) size = 1)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:11'!
testMethodsWithFailedCallForClass
	| methodRefs |
	methodRefs := pcc methodsWithFailedCallForClass: self class.
	self assert: methodRefs size = 1 & (methodRefs asArray first methodSymbol = self failedCallSelector)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:54'!
testMethodsWithFailedCallIntoModule
	| methodRefs |
	methodRefs := pcc methodsWithFailedCallIntoModule: self failModuleName.
	self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self failedCallSelector)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:13'!
testMethodsWithFailedCallIntoModuleForClass
	| methodRefs |
	methodRefs := pcc methodsWithFailedCallIntoModule: self failModuleName forClass: self class.
	self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self failedCallSelector)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:58'!
testSwitchPrimCallOffOn
	| res |
	pcc disableCallInMethod: self realExternalCallOrPrimitiveFailedSelector class: self class.
	self
		should: [self perform: self realExternalCallOrPrimitiveFailedSelector]
		raise: TestResult error.
	pcc enableCallInMethod: self realExternalCallOrPrimitiveFailedSelector class: self class.
	self
		shouldnt: [res := self perform: self realExternalCallOrPrimitiveFailedSelector]
		raise: TestResult error.
	self assert: res isString! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'!
testSwitchStored
	| refs |
	"all enabled, precondition"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	refs := self methodRefsToExampleModule.
	"fill cache"
	refs
		do: [:ref | pcc disableCallIn: ref].
	"enable one"
	pcc enableCallIn: refs first.
	self
		assert: (pcc existsEnabledCallIn: refs first).
	self
		assert: (pcc existsDisabledCallIn: refs second).
	"switching"
	pcc switchStored.
	"now the checks go vice versa"
	self
		assert: (pcc existsDisabledCallIn: refs first).
	self
		assert: (pcc existsEnabledCallIn: refs second).
	pcc enableCallIn: refs first.
	self
		assert: (pcc existsEnabledCallIn: refs first)! !

!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'!
testTryCaches
	| refs |
	"all enabled, precondition"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	refs := self methodRefsToExampleModule.
	"fill cache"
	refs
		do: [:ref | pcc disableCallIn: ref].
	"try caches"
	pcc enableDisabled.
	"all enabled"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
	pcc disableEnabled.
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
	pcc enableDisabled.
	"all enabled, postcondition"
	self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrimCallControllerAbstractTest class
	instanceVariableNames: ''!

!PrimCallControllerAbstractTest class methodsFor: 'Testing' stamp: 'sr 6/7/2004 11:59'!
isAbstract
	^ true! !
Object subclass: #PrimitiveNode
	instanceVariableNames: 'primitiveNum spec'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!PrimitiveNode commentStamp: 'ajh 3/24/2003 21:35' prior: 0!
I represent a primitive.  I am more than just a number if I am a named primitive.

Structure:

 num	<Integer>	Primitive number.
 spec	<Object>		Stored in first literal when num is 117 or 120.
!


!PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:37'!
num

	^ primitiveNum! !

!PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:23'!
num: n

	primitiveNum _ n! !

!PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 3/12/2003 12:26'!
printOn: aStream

	aStream nextPutAll: 'primitive '; print: primitiveNum! !

!PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 3/19/2003 22:06'!
printPrimitiveOn: aStream 
	"Print the primitive on aStream"

	| primIndex primDecl |
	primIndex _ primitiveNum.
	primIndex = 0 ifTrue: [^ self].
	primIndex = 120 ifTrue: [
		"External call spec"
		^ aStream print: spec].
	aStream nextPutAll: '<primitive: '.
	primIndex = 117 ifTrue: [
		primDecl _ spec.
		aStream nextPut: $';
			nextPutAll: (primDecl at: 2);
			nextPut: $'.
		(primDecl at: 1) ifNotNil: [
			aStream nextPutAll: ' module: ';
				nextPut: $';
				nextPutAll: (primDecl at: 1);
				nextPut: $'].
	] ifFalse: [aStream print: primIndex].
	aStream nextPut: $>.
	(primIndex ~= 117 and: [primIndex ~= 120]) ifTrue: [
		Smalltalk at: #Interpreter ifPresent: [:cls |
			aStream nextPutAll: ' "', 
				((cls classPool at: #PrimitiveTable) at: primIndex + 1) , '" '
		].
	].
! !

!PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 3/19/2003 22:02'!
sourceText

	^ String streamContents: [:stream |
		self printPrimitiveOn: stream]! !

!PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:37'!
spec

	^ spec! !

!PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:30'!
spec: literal

	spec _ literal! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrimitiveNode class
	instanceVariableNames: ''!

!PrimitiveNode class methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:47'!
null

	^ self new num: 0! !
TextComponent subclass: #PrintComponent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!PrintComponent methodsFor: 'components' stamp: 'di 5/1/1998 13:39'!
initPinSpecs 
	pinSpecs _ Array
		with: (PinSpec new pinName: 'value' direction: #inputOutput
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: getTextSelector modelWriteSelector: setTextSelector
				defaultValue: nil pinLoc: 1.5)! !


!PrintComponent methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 23:04'!
accept
	"Inform the model of text to be accepted, and return true if OK."

	| textToAccept |
	self canDiscardEdits ifTrue: [^self flash].
	setTextSelector isNil ifTrue: [^self].
	textToAccept := textMorph asText.
	model perform: setTextSelector
		with: (Compiler evaluate: textToAccept logged: false).
	self setText: textToAccept.
	self hasUnacceptedEdits: false! !


!PrintComponent methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:04'!
getText
	"Retrieve the current model text"

	getTextSelector isNil ifTrue: [^Text new].
	^(model perform: getTextSelector) printString asText! !
PrintableEncoder subclass: #PrintEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Filters'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrintEncoder class
	instanceVariableNames: ''!

!PrintEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 01:50'!
filterSelector
	^#printOnStream:! !
Object subclass: #PrintSpecifications
	instanceVariableNames: 'landscapeFlag drawAsBitmapFlag scaleToFitPage'
	classVariableNames: 'DefaultSpecs'
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:06'!
drawAsBitmapFlag

	^drawAsBitmapFlag ifNil: [false]! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:07'!
drawAsBitmapFlag: aBoolean

	drawAsBitmapFlag _ aBoolean! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:35'!
initialize

	landscapeFlag _ false.
	scaleToFitPage _ false.
	drawAsBitmapFlag _ false.
! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:06'!
landscapeFlag

	^landscapeFlag ifNil: [false]! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:24'!
landscapeFlag: aBoolean

	landscapeFlag _ aBoolean! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:35'!
scaleToFitPage

	^scaleToFitPage ifNil: [false]! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:35'!
scaleToFitPage: aBoolean

	scaleToFitPage _ aBoolean! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrintSpecifications class
	instanceVariableNames: ''!

!PrintSpecifications class methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:29'!
defaultSpecs

	DefaultSpecs ifNil: [DefaultSpecs _ self new].
	^DefaultSpecs copy! !

!PrintSpecifications class methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:29'!
defaultSpecs: aPrintSpecification

	DefaultSpecs _ aPrintSpecification! !
ByteEncoder subclass: #PrintableEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Filters'!

!PrintableEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 22:50'!
writeNumber:aNumber base:aBase
	aBase ~= self numberDefaultBase ifTrue:[ self write:aBase; print:'r'].
	^super writeNumber:aNumber base:aBase.
! !
Link subclass: #Process
	instanceVariableNames: 'suspendedContext priority myList errorHandler name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!Process commentStamp: '<historical>' prior: 0!
I represent an independent path of control in the system. This path of control may be stopped (by sending the message suspend) in such a way that it can later be restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced partly using the value of priority.

(If anyone ever makes a subclass of Process, be sure to use allSubInstances in anyProcessesAbove:.)!


!Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 14:53'!
calleeOf: aContext
	"Return the context whose sender is aContext.  Return nil if aContext is on top.  Raise error if aContext is not in process chain."

	suspendedContext == aContext ifTrue: [^ nil].
	^ (suspendedContext findContextSuchThat: [:c | c sender == aContext])
		ifNil: [self error: 'aContext not in process chain']! !

!Process methodsFor: 'accessing' stamp: 'ajh 1/27/2003 18:39'!
copyStack

	^ self copy install: suspendedContext copyStack! !

!Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 19:44'!
isActiveProcess

	^ self == Processor activeProcess! !

!Process methodsFor: 'accessing' stamp: 'nk 10/28/2000 19:55'!
isSuspended
	^myList isNil! !

!Process methodsFor: 'accessing' stamp: 'ajh 3/4/2004 22:18'!
isTerminated

	self isActiveProcess ifTrue: [^ false].
	^ suspendedContext isNil or: [
		suspendedContext == suspendedContext bottomContext and: [
			suspendedContext pc > suspendedContext startpc]]! !

!Process methodsFor: 'accessing' stamp: 'svp 12/5/2002 14:42'!
name

	^name ifNil: [ self hash asString forceTo: 5 paddingStartWith: $ ]! !

!Process methodsFor: 'accessing' stamp: 'svp 12/5/2002 14:42'!
name: aString

	name _ aString! !

!Process methodsFor: 'accessing'!
offList
	"Inform the receiver that it has been taken off a list that it was 
	suspended on. This is to break a backpointer."

	myList _ nil! !

!Process methodsFor: 'accessing'!
priority
	"Answer the priority of the receiver."

	^priority! !

!Process methodsFor: 'accessing' stamp: 'ar 7/8/2001 17:04'!
priority: anInteger 
	"Set the receiver's priority to anInteger."
	(anInteger >= Processor lowestPriority and:[anInteger <= Processor highestPriority])
		ifTrue: [priority _ anInteger]
		ifFalse: [self error: 'Invalid priority: ', anInteger printString]! !

!Process methodsFor: 'accessing'!
suspendedContext
	"Answer the context the receiver has suspended."

	^suspendedContext! !

!Process methodsFor: 'accessing'!
suspendingList
	"Answer the list on which the receiver has been suspended."

	^myList! !


!Process methodsFor: 'changing process state' stamp: 'tpr 2/14/2001 10:00'!
primitiveResume
	"Primitive. Allow the process that the receiver represents to continue. Put 
	the receiver in line to become the activeProcess. Fail if the receiver is 
	already waiting in a queue (in a Semaphore or ProcessScheduler). 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 87>
	self primitiveFailed! !

!Process methodsFor: 'changing process state' stamp: 'ajh 7/20/2003 22:51'!
primitiveSuspend
	"Primitive. Stop the process that self represents in such a way 
	that it can be restarted at a later time (by sending #resume).
	ASSUMES self is the active process.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 88>
	self primitiveFailed! !

!Process methodsFor: 'changing process state' stamp: 'tpr 2/14/2001 10:03'!
resume
	"Allow the process that the receiver represents to continue. Put  
	the receiver in line to become the activeProcess. Check for a nil 
	suspendedContext, which indicates a previously terminated Process that 
	would cause a vm crash if the resume attempt were permitted"

	suspendedContext ifNil: [^ self primitiveFailed].
	^ self primitiveResume! !

!Process methodsFor: 'changing process state' stamp: 'ajh 1/23/2003 23:02'!
run
	"Suspend current process and execute self instead"

	| proc |
	proc _ Processor activeProcess.
	[	proc suspend.
		self resume.
	] forkAt: Processor highestPriority! !

!Process methodsFor: 'changing process state' stamp: 'ajh 7/20/2003 22:47'!
suspend
	"Stop the process that the receiver represents in such a way 
	that it can be restarted at a later time (by sending the receiver the 
	message resume). If the receiver represents the activeProcess, suspend it. 
	Otherwise remove the receiver from the list of waiting processes."

	self isActiveProcess ifTrue: [
		myList _ nil.
		self primitiveSuspend.
	] ifFalse: [
		myList ifNotNil: [
			myList remove: self ifAbsent: [].
			myList _ nil].
	]
! !

!Process methodsFor: 'changing process state' stamp: 'nk 6/21/2004 14:07'!
terminate 
	"Stop the process that the receiver represents forever.  Unwind to execute pending ensure:/ifCurtailed: blocks before terminating."

	| ctxt unwindBlock |
	self isActiveProcess ifTrue: [
		ctxt _ thisContext.
		[	ctxt _ ctxt findNextUnwindContextUpTo: nil.
			ctxt isNil
		] whileFalse: [
			unwindBlock _ ctxt tempAt: 1.
			unwindBlock ifNotNil: [
				ctxt tempAt: 1 put: nil.
				thisContext terminateTo: ctxt.
				unwindBlock value].
		].
		thisContext terminateTo: nil.
		myList _ nil.
		self primitiveSuspend.
	] ifFalse: [
		myList ifNotNil: [
			myList remove: self ifAbsent: [].
			myList _ nil].
		suspendedContext ifNotNil: [
			ctxt _ self popTo: suspendedContext bottomContext.
			ctxt == suspendedContext bottomContext ifFalse: [
				self debug: ctxt title: 'Unwind error during termination']].
	].
! !


!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 16:14'!
activateReturn: aContext value: value
	"Activate 'aContext return: value', so execution will return to aContext's sender"

	^ suspendedContext _ suspendedContext activateReturn: aContext value: value! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:13'!
complete: aContext 
	"Run self until aContext is popped or an unhandled error is raised.  Return self's new top context, unless an unhandled error was raised then return the signaler context (rather than open a debugger)."
	
	| ctxt pair error |
	ctxt _ suspendedContext.
	suspendedContext _ nil.  "disable this process while running its stack in active process below"
	pair _ ctxt runUntilErrorOrReturnFrom: aContext.
	suspendedContext _ pair first.
	error _ pair second.
	error ifNotNil: [^ error signalerContext].
	^ suspendedContext! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:16'!
completeStep: aContext 
	"Resume self until aContext is on top, or if already on top, complete next step"

	| callee |
	self suspendedContext == aContext ifFalse: [
		^ self complete: (self calleeOf: aContext)].
	callee _ self step.
	callee == aContext ifTrue: [^ callee].
	aContext isDead ifTrue: [^ self suspendedContext].  "returned"
	^ self complete: callee  "finish send"! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 21:43'!
completeTo: aContext 
	"Resume self until aContext is on top"

	self suspendedContext == aContext ifTrue: [^ aContext].
	^ self complete: (self calleeOf: aContext)! !

!Process methodsFor: 'changing suspended state'!
install: aContext 
	"Replace the suspendedContext with aContext."

	self == Processor activeProcess
		ifTrue: [^self error: 'The active process cannot install contexts'].
	suspendedContext _ aContext! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'!
popTo: aContext 
	"Pop self down to aContext by remote returning from aContext's callee.  Unwind blocks will be executed on the way.
	This is done by pushing a new context on top which executes 'aContext callee return' then resuming self until aContext is reached.  This way any errors raised in an unwind block will get handled by senders in self and not by senders in the activeProcess.
	If an unwind block raises an error that is not handled then the popping stops at the error and the signalling context is returned, othewise aContext is returned."

	| callee |
	self == Processor activeProcess
		ifTrue: [^ self error: 'The active process cannot pop contexts'].
	callee _ (self calleeOf: aContext) ifNil: [^ aContext].  "aContext is on top"
	^ self return: callee value: callee receiver! !

!Process methodsFor: 'changing suspended state' stamp: 'gk 12/18/2003 13:09'!
popTo: aContext value: aValue
	"Replace the suspendedContext with aContext, releasing all contexts 
	between the currently suspendedContext and it."

	| callee |
	self == Processor activeProcess
		ifTrue: [^ self error: 'The active process cannot pop contexts'].
	callee _ (self calleeOf: aContext) ifNil: [^ self].  "aContext is on top"
	self return: callee value: aValue! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 20:40'!
restartTop
	"Rollback top context and replace with new method.  Assumes self is suspended"

	suspendedContext privRefresh! !

!Process methodsFor: 'changing suspended state' stamp: 'nk 7/10/2004 11:16'!
restartTopWith: method
	"Rollback top context and replace with new method.  Assumes self is suspended"

	method isQuick 
		ifTrue: [ self popTo: suspendedContext sender ]
		ifFalse: [ suspendedContext privRefreshWith: method ].
! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'!
return: aContext value: value
	"Pop thread down to aContext's sender.  Execute any unwind blocks on the way.  See #popTo: comment and #runUntilErrorOrReturnFrom: for more details."

	suspendedContext == aContext ifTrue: [
		^ suspendedContext _ aContext return: value from: aContext].
	self activateReturn: aContext value: value.
	^ self complete: aContext.
! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'!
step

	^ suspendedContext _ suspendedContext step! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/31/2003 14:45'!
step: aContext 
	"Resume self until aContext is on top, or if already on top, do next step"

	^ self suspendedContext == aContext
		ifTrue: [self step]
		ifFalse: [self complete: (self calleeOf: aContext)]! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 22:06'!
stepToCallee
	"Step until top context changes"

	| ctxt |
	ctxt _ suspendedContext.
	[ctxt == suspendedContext] whileTrue: [
		suspendedContext _ suspendedContext step].
	^ suspendedContext! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 7/18/2003 22:13'!
stepToHome: aContext 
	"Resume self until the home of top context is aContext.  Top context may be a block context."

	| home ctxt |
	home _ aContext home.
	[	ctxt _ self step.
		home == ctxt home.
	] whileFalse: [
		home isDead ifTrue: [^ self suspendedContext].
	].
	^ self suspendedContext! !

!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'!
stepToSendOrReturn

	^ suspendedContext _ suspendedContext stepToSendOrReturn! !


!Process methodsFor: 'debugging' stamp: 'nk 10/29/2000 13:43'!
debug
	self debugWithTitle: 'Debug'.! !

!Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:54'!
debug: context title: title
	"Open debugger on self with context shown on top"

	self debug: context title: title full: false.
! !

!Process methodsFor: 'debugging' stamp: 'ar 9/27/2005 20:32'!
debug: context title: title full: bool
	"Open debugger on self with context shown on top"

	| topCtxt |
	topCtxt _ self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext].
	(topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process'].
	ToolSet debug: self context: context label: title contents: nil fullView: bool.
! !

!Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:55'!
debugWithTitle: title
	"Open debugger on self"

	| context |
	context _ self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext].
	self debug: context title: title full: true.
! !


!Process methodsFor: 'error handling'!
errorHandler
    ^ errorHandler! !

!Process methodsFor: 'error handling'!
errorHandler: aBlock
    errorHandler _ aBlock! !


!Process methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:46'!
objectForDataStream: refStrm
	"I am not allowed to be written on an object file."

	refStrm replace: self with: nil.
	^ nil! !


!Process methodsFor: 'printing' stamp: 'nk 10/28/2000 07:33'!
browserPrintString
	^self browserPrintStringWith: suspendedContext! !

!Process methodsFor: 'printing' stamp: 'svp 12/5/2002 14:45'!
browserPrintStringWith: anObject 
	| stream |
	stream _ WriteStream
				on: (String new: 100).
	stream nextPut: $(.
	priority printOn: stream.
	self isSuspended
		ifTrue: [stream nextPut: $s].
	stream nextPutAll: ') '.
	stream nextPutAll: self name.
	stream nextPut: $:.
	stream space.
	stream nextPutAll: anObject asString.
	^ stream contents! !

!Process methodsFor: 'printing' stamp: 'ajh 10/2/2001 14:36'!
longPrintOn: stream

	| ctxt |
	super printOn: stream.
	stream cr.
	ctxt _ self suspendedContext.
	[ctxt == nil] whileFalse: [
		stream space.
		ctxt printOn: stream.
		stream cr.
		ctxt _ ctxt sender.
	].
! !

!Process methodsFor: 'printing'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' in '.
	suspendedContext printOn: aStream! !


!Process methodsFor: 'signaling' stamp: 'svp 9/19/2003 18:41'!
pvtSignal: anException list: aList
	"Private. This method is used to signal an exception from another
	process...the receiver must be the active process.  If the receiver 
	was previously waiting on a Semaphore, then return the process
	to the waiting state after signaling the exception and if the Semaphore
	has not been signaled in the interim"

	"Since this method is not called in a normal way, we need to take care
	that it doesn't directly return to the caller (because I believe that could
	have the potential to push an unwanted object on the caller's stack)."

	| blocker |
	self isActiveProcess ifFalse: [^self].
	anException signal.
	blocker := Semaphore new.
	[self suspend.
	suspendedContext := suspendedContext swapSender: nil.
	aList class == Semaphore 
		ifTrue:
			[aList isSignaled
				ifTrue: 
					[aList wait.  "Consume the signal that would have restarted the receiver"
					self resume]
				ifFalse:
					["Add us back to the Semaphore's list (and remain blocked)"
					myList := aList.
					aList add: self]]
		ifFalse: [self resume]] fork.
	blocker wait.


! !

!Process methodsFor: 'signaling' stamp: 'ar 2/23/2005 11:48'!
signalException: anException
	"Signal an exception in the receiver process...if the receiver is currently
	suspended, the exception will get signaled when the receiver is resumed.  If 
	the receiver is blocked on a Semaphore, it will be immediately re-awakened
	and the exception will be signaled; if the exception is resumed, then the receiver
	will return to a blocked state unless the blocking Semaphore has excess signals"

	"If we are the active process, go ahead and signal the exception"
	self isActiveProcess ifTrue: [^anException signal].

	"Add a new method context to the stack that will signal the exception"
	suspendedContext := MethodContext
		sender: suspendedContext
		receiver: self
		method: (self class methodDict at: #pvtSignal:list:)
		arguments: (Array with: anException with: myList).

	"If we are on a list to run, then suspend and restart the receiver 
	(this lets the receiver run if it is currently blocked on a semaphore).  If
	we are not on a list to be run (i.e. this process is suspended), then when the
	process is resumed, it will signal the exception"

	myList ifNotNil: [self suspend; resume].! !


!Process methodsFor: 'private'!
suspendedContext: aContext

	suspendedContext _ aContext! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Process class
	instanceVariableNames: ''!

!Process class methodsFor: 'instance creation'!
forContext: aContext priority: anInteger 
	"Answer an instance of me that has suspended aContext at priority 
	anInteger."

	| newProcess |
	newProcess _ self new.
	newProcess suspendedContext: aContext.
	newProcess priority: anInteger.
	^newProcess! !
Model subclass: #ProcessBrowser
	instanceVariableNames: 'selectedProcess selectedContext methodText processList processListIndex stackList stackListIndex sourceMap selectedClass selectedSelector searchString autoUpdateProcess deferredMessageRecipient lastUpdate startedCPUWatcher'
	classVariableNames: 'Browsers SuspendedProcesses WellKnownProcesses'
	poolDictionaries: ''
	category: 'Tools-Process Browser'!
!ProcessBrowser commentStamp: '<historical>' prior: 0!
Change Set:		ProcessBrowser
Date:			14 March 2000
Author:			Ned Konz

email: ned@bike-nomad.com

This is distributed under the Squeak License.

Added 14 March:
	CPUWatcher integration
	automatically start and stop CPUWatcher
	added CPUWatcher to process list menu

Added 29 October:
	MVC version
	2.8, 2.7 compatibility
	rearranged menus
	added pointer inspection and chasing
	added suspend/resume
	recognized more well-known processes
	misc. bug fixes

Added 26 October: highlight pc in source code
Added 27 October: added 'signal semaphore'
added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu
added 'find context', 'next context' to process list menu
added 'change priority' and 'debug' choices to process list menu

27 October mods by Bob Arning:

alters process display in Ned's ProcessBrowser to 
- show process priority
- drop 'a Process in' that appears on each line
- show in priority order
- prettier names for known processes
- fix to Utilities to forget update downloading process when it ends (1 less dead
process)
- correct stack dump for the active process
!


!ProcessBrowser methodsFor: 'accessing'!
processList
	^ processList! !

!ProcessBrowser methodsFor: 'accessing'!
processListIndex
	^ processListIndex! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
processListIndex: index 
	processListIndex := index.
	selectedProcess := processList
				at: index
				ifAbsent: [].
	self updateStackList.
	self changed: #processListIndex.! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'md 2/17/2006 09:32'!
selectedClass
	"Answer the class in which the currently selected context's method was  
	found."
	^ selectedClass
		ifNil: [selectedClass := selectedContext receiver
				ifNil: [selectedSelector := selectedContext method selector.
					   selectedContext method methodClass]
				ifNotNil: [selectedContext methodClass]]! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
selectedMethod
	^ methodText ifNil: [methodText := selectedContext
						ifNil: ['']
						ifNotNil: [| pcRange | 
							methodText := [ selectedContext sourceCode ]
								ifError: [ :err :rcvr | 'error getting method text' ].
							pcRange := self pcRange.
							methodText asText
								addAttribute: TextColor red
								from: pcRange first
								to: pcRange last;
								
								addAttribute: TextEmphasis bold
								from: pcRange first
								to: pcRange last]]! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'md 2/17/2006 12:07'!
selectedSelector
	"Answer the class in which the currently selected context's method was  
	found."
	^ selectedSelector
		ifNil: [selectedSelector := selectedContext receiver
				ifNil: [selectedClass := selectedContext method methodClass
					   selectedContext method selector]
				ifNotNil: [selectedContext selector]]! !

!ProcessBrowser methodsFor: 'accessing'!
stackList
	^ stackList! !

!ProcessBrowser methodsFor: 'accessing'!
stackListIndex
	^ stackListIndex! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
stackListIndex: index 
	stackListIndex := index.
	selectedContext := nil.
	(stackList notNil
			and: [index > 0])
		ifTrue: [selectedContext := stackList
						at: index
						ifAbsent: []].
	sourceMap := nil.
	selectedClass := nil.
	selectedSelector := nil.
	methodText := nil.
	self changed: #stackListIndex.
	self changed: #selectedMethod! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'nk 10/28/2000 08:36'!
text
	^methodText! !


!ProcessBrowser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
initialize
	methodText := ''.
	stackListIndex := 0.
	searchString := ''.
	lastUpdate := 0.
	startedCPUWatcher := Preferences cpuWatcherEnabled and: [ self startCPUWatcher ].
	self updateProcessList; processListIndex: 1! !

!ProcessBrowser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
startCPUWatcher
	"Answers whether I started the CPUWatcher"

	| pw |
	pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ].
	pw ifNotNil: [
		pw isMonitoring ifFalse: [
			pw startMonitoringPeriod: 5 rate: 100 threshold: 0.85.
			self setUpdateCallbackAfter: 7.
			^true
		]
	].
	^false
! !

!ProcessBrowser methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
stopCPUWatcher
	| pw |
	pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ].
	pw ifNotNil: [
		pw stopMonitoring.
		self updateProcessList.
		startedCPUWatcher := false.	"so a manual restart won't be killed later"
	]
! !

!ProcessBrowser methodsFor: 'initialize-release' stamp: 'nk 3/14/2001 08:03'!
windowIsClosing
	startedCPUWatcher ifTrue: [ CPUWatcher stopMonitoring ]! !


!ProcessBrowser methodsFor: 'message handling' stamp: 'nk 10/28/2000 20:53'!
perform: selector orSendTo: otherTarget 
	"Selector was just chosen from a menu by a user. If can respond, then  
	perform it on myself. If not, send it to otherTarget, presumably the  
	editPane from which the menu was invoked."
	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ super perform: selector orSendTo: otherTarget]! !


!ProcessBrowser methodsFor: 'process actions' stamp: 'rbb 3/1/2005 11:07'!
changePriority
	| str newPriority nameAndRules |
	nameAndRules := self nameAndRulesForSelectedProcess.
	nameAndRules third
		ifFalse: [self inform: 'Nope, won''t change priority of ' , nameAndRules first.
			^ self].
	str := UIManager default 
				request: 'New priority' 
		  initialAnswer: selectedProcess priority asString.
	newPriority := str asNumber asInteger.
	newPriority
		ifNil: [^ self].
	(newPriority < 1
			or: [newPriority > Processor highestPriority])
		ifTrue: [self inform: 'Bad priority'.
			^ self].
	self class setProcess: selectedProcess toPriority: newPriority.
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'!
chasePointers
	| saved |
	selectedProcess
		ifNil: [^ self].
	saved := selectedProcess.
	[selectedProcess := nil.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [PointerFinder on: saved]
		ifFalse: [self inspectPointers]]
		ensure: [selectedProcess := saved]! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'!
debugProcess
	| nameAndRules |
	nameAndRules := self nameAndRulesForSelectedProcess.
	nameAndRules third
		ifFalse: [self inform: 'Nope, won''t debug ' , nameAndRules first.
			^ self].
	self class debugProcess: selectedProcess.! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 2/22/2005 15:26'!
inspectPointers
	| tc pointers |
	selectedProcess ifNil: [^self].
	tc := thisContext.
	pointers := PointerFinder pointersTo: selectedProcess
				except: { 
						self processList.
						tc.
						self}.
	pointers isEmpty ifTrue: [^self].
	OrderedCollectionInspector 
		openOn: pointers
		withEvalPane: false
		withLabel: 'Objects pointing to ' , selectedProcess browserPrintString! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:35'!
nameAndRulesFor: aProcess 
	"Answer a nickname and two flags: allow-stop, and allow-debug"
	aProcess == autoUpdateProcess ifTrue: [ ^{'my auto-update process'. true. true} ].
	^self class nameAndRulesFor: aProcess 
! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/28/2000 20:31'!
nameAndRulesForSelectedProcess
	"Answer a nickname and two flags: allow-stop, and allow-debug"
	^self nameAndRulesFor: selectedProcess! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:23'!
resumeProcess
	selectedProcess
		ifNil: [^ self].
	self class resumeProcess: selectedProcess.
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 09:58'!
signalSemaphore
	(selectedProcess suspendingList isKindOf: Semaphore)
		ifFalse: [^ self].
	[selectedProcess suspendingList signal] fork.
	(Delay forMilliseconds: 300) wait.
	"Hate to make the UI wait, but it's convenient..."
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'!
suspendProcess
	| nameAndRules |
	selectedProcess isSuspended
		ifTrue: [^ self].
	nameAndRules := self nameAndRulesForSelectedProcess.
	nameAndRules second
		ifFalse: [self inform: 'Nope, won''t suspend ' , nameAndRules first.
			^ self].
	self class suspendProcess: selectedProcess.
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'!
terminateProcess
	| nameAndRules |
	nameAndRules := self nameAndRulesForSelectedProcess.
	nameAndRules second
		ifFalse: [self inform: 'Nope, won''t kill ' , nameAndRules first.
			^ self].
	self class terminateProcess: selectedProcess.	
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 08:56'!
wasProcessSuspendedByProcessBrowser: aProcess
	^self class suspendedProcesses includesKey: aProcess! !


!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/27/2000 09:24'!
exploreProcess
	selectedProcess explore! !

!ProcessBrowser methodsFor: 'process list' stamp: 'rbb 3/1/2005 11:08'!
findContext
	| initialProcessIndex initialStackIndex found |
	initialProcessIndex := self processListIndex.
	initialStackIndex := self stackListIndex.
	searchString := UIManager default 
			request: 'Enter a string to search for in the process stack lists'
	  initialAnswer: searchString.
	searchString isEmpty
		ifTrue: [^ false].
	self processListIndex: 1.
	self stackListIndex: 1.
	found := self nextContext.
	found
		ifFalse: [self processListIndex: initialProcessIndex.
			self stackListIndex: initialStackIndex].
	^ found! !

!ProcessBrowser methodsFor: 'process list'!
inspectProcess
	selectedProcess inspect! !

!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'!
nextContext
	| initialProcessIndex initialStackIndex found |
	searchString isEmpty ifTrue: [ ^false ].
	initialProcessIndex := self processListIndex.
	initialStackIndex := self stackListIndex.
	found := false.
	initialProcessIndex
		to: self processList size
		do: [:pi | found
				ifFalse: [self processListIndex: pi.
					self stackNameList
						withIndexDo: [:name :si | (found not
									and: [pi ~= initialProcessIndex
											or: [si > initialStackIndex]])
								ifTrue: [(name includesSubString: searchString)
										ifTrue: [self stackListIndex: si.
											found := true]]]]].
	found
		ifFalse: [self processListIndex: initialProcessIndex.
			self stackListIndex: initialStackIndex].
	^ found! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/28/2000 08:19'!
notify: errorString at: location in: aStream 
	"A syntax error happened when I was trying to highlight my pc. 
	Raise a signal so that it can be ignored."
	Warning signal: 'syntax error'!
]style[(8 11 5 8 5 7 3 107 2 7 23)f1b,f1cblack;b,f1b,f1cblack;b,f1b,f1cblack;b,f1,f1c142040000,f1,f1cblack;,f1! !

!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'!
prettyNameForProcess: aProcess 
	| nameAndRules |
	aProcess ifNil: [ ^'<nil>' ].
	nameAndRules := self nameAndRulesFor: aProcess.
	^ aProcess browserPrintStringWith: nameAndRules first! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/29/2000 10:20'!
processListKey: aKey from: aView 
	^ aKey caseOf: {
		[$i] -> [self inspectProcess].
		[$I] -> [self exploreProcess].
		[$c] -> [self chasePointers].
		[$P] -> [self inspectPointers].
		[$t] -> [self terminateProcess].
		[$r] -> [self resumeProcess].
		[$s] -> [self suspendProcess].
		[$d] -> [self debugProcess].
		[$p] -> [self changePriority].
		[$m] -> [self messageTally].
		[$f] -> [self findContext].
		[$g] -> [self nextContext].
		[$a] -> [self toggleAutoUpdate].
		[$u] -> [self updateProcessList].
		[$S] -> [self signalSemaphore].
		[$k] -> [self moreStack]}
		 otherwise: [self arrowKey: aKey from: aView]! !

!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'!
processListMenu: menu 
	| pw |

	selectedProcess
		ifNotNil: [| nameAndRules | 
			nameAndRules := self nameAndRulesForSelectedProcess.
			menu addList: {{'inspect (i)'. #inspectProcess}. {'explore (I)'. #exploreProcess}. {'inspect Pointers (P)'. #inspectPointers}}.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [ menu add: 'chase pointers (c)' action: #chasePointers.  ].
			nameAndRules second
				ifTrue: [menu add: 'terminate (t)' action: #terminateProcess.
					selectedProcess isSuspended
						ifTrue: [menu add: 'resume (r)' action: #resumeProcess]
						ifFalse: [menu add: 'suspend (s)' action: #suspendProcess]].
			nameAndRules third
				ifTrue: [menu addList: {{'change priority (p)'. #changePriority}. {'debug (d)'. #debugProcess}}].
			menu addList: {{'profile messages (m)'. #messageTally}}.
			(selectedProcess suspendingList isKindOf: Semaphore)
				ifTrue: [menu add: 'signal Semaphore (S)' action: #signalSemaphore].
			menu add: 'full stack (k)' action: #moreStack.
			menu addLine].

	menu addList: {{'find context... (f)'. #findContext}. {'find again (g)'. #nextContext}}.
	menu addLine.

	menu
		add: (self isAutoUpdating
				ifTrue: ['turn off auto-update (a)']
				ifFalse: ['turn on auto-update (a)'])
		action: #toggleAutoUpdate.
	menu add: 'update list (u)' action: #updateProcessList.

	pw := Smalltalk at: #CPUWatcher ifAbsent: [].
	pw ifNotNil: [
		menu addLine.
		pw isMonitoring
				ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher ]
				ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher  ]
	].

	^ menu! !

!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'!
processNameList
	"since processList is a WeakArray, we have to strengthen the result"
	| pw tally |
	pw := Smalltalk at: #CPUWatcher ifAbsent: [ ].
	tally := pw ifNotNil: [ pw current ifNotNil: [ pw current tally ] ].
	^ (processList asOrderedCollection
		copyWithout: nil)
		collect: [:each | | percent |
			percent := tally
				ifNotNil: [ ((((tally occurrencesOf: each) * 100.0 / tally size) roundTo: 1)
						asString padded: #left to: 2 with: $ ), '% '  ]
				ifNil: [ '' ].
			percent, (self prettyNameForProcess: each)
		] ! !

!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'!
updateProcessList
	| oldSelectedProcess newIndex now |
	now := Time millisecondClockValue.
	now - lastUpdate < 500
		ifTrue: [^ self].
	"Don't update too fast"
	lastUpdate := now.
	oldSelectedProcess := selectedProcess.
	processList := selectedProcess := selectedSelector := nil.
	Smalltalk garbageCollectMost.
	"lose defunct processes"

	processList := Process allSubInstances
				reject: [:each | each isTerminated].
	processList := processList
				sortBy: [:a :b | a priority >= b priority].
	processList := WeakArray withAll: processList.
	newIndex := processList
				indexOf: oldSelectedProcess
				ifAbsent: [0].
	self changed: #processNameList.
	self processListIndex: newIndex! !


!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:49'!
browseContext
	selectedContext
		ifNil: [^ self].
	Browser newOnClass: self selectedClass selector: self selectedSelector!
]style[(13 30 4 4 7 42 4 17)f1b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'!
changeStackListTo: aCollection 

        stackList := aCollection.
        self changed: #stackNameList.
        self stackListIndex: 0! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:28'!
exploreContext
	selectedContext explore! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'!
exploreReceiver
	selectedContext ifNotNil: [ selectedContext receiver explore ]! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:23'!
inspectContext
	selectedContext inspect! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'!
inspectReceiver
	selectedContext
		ifNotNil: [selectedContext receiver inspect]! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'rbb 3/1/2005 11:08'!
messageTally
	| secString secs |
	secString := UIManager default request: 'Profile for how many seconds?' initialAnswer: '4'.
	secs := secString asNumber asInteger.
	(secs isNil
			or: [secs isZero])
		ifTrue: [^ self].
	[ TimeProfileBrowser spyOnProcess: selectedProcess forMilliseconds: secs * 1000 ] forkAt: selectedProcess priority + 1.! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 12:13'!
moreStack
	self updateStackList: 2000! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'md 2/16/2006 15:50'!
pcRange
	"Answer the indices in the source code for the method corresponding to  
	the selected context's program counter value."
	| i methodNode pc end |
	methodText isEmptyOrNil
		ifTrue: [^ 1 to: 0].
	sourceMap == nil
		ifTrue: [self selectedClass == nil
				ifTrue: [^ 1 to: 0].
			[[methodNode := self selectedClass compilerClass new
						parse: methodText
						in: self selectedClass
						notifying: self ]
				on: Warning
				do: [:ex | 
					methodText := ('(syntax error) ' , ex description , String cr , methodText) asText.
					ex return]]
				on: Error
				do: [:ex | 
					methodText := ('(parse error) ' , ex description , String cr , methodText) asText.
					ex return].
			methodNode
				ifNil: [sourceMap := nil.
					^ 1 to: 0].
			sourceMap := methodNode sourceMap].
	(sourceMap size = 0 or: [ selectedContext isDead ])
		ifTrue: [^ 1 to: 0].
	
	Smalltalk at: #RBProgramNode ifPresent:[:nodeClass|	
	 (methodNode isKindOf: #nodeClass) ifTrue: [
		pc _ stackListIndex = 1
			ifTrue: [selectedContext pc]
			ifFalse: [selectedContext previousPc].
		i _ sourceMap findLast: [:pcRange | pcRange key <= pc].
		i = 0 ifTrue:[^ 1 to: 0].
		^ (sourceMap at: i) value
	]].	
		
		
	pc := selectedContext pc.
	pc := pc - 2.
	i := sourceMap
				indexForInserting: (Association key: pc value: nil).
	i < 1
		ifTrue: [^ 1 to: 0].
	i > sourceMap size
		ifTrue: [end := sourceMap
						inject: 0
						into: [:prev :this | prev max: this value last].
			^ end + 1 to: end].
	^ (sourceMap at: i) value! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'!
stackListMenu: aMenu 
	| menu |
	selectedContext
		ifNil: [^ aMenu].
	menu := aMenu
				labels: 'inspect context (c)
explore context (C)
inspect receiver (i)
explore receiver (I)
browse (b)'
				lines: #(2 4 )
				selections: #(#inspectContext #exploreContext #inspectReceiver #exploreReceiver #browseContext ).
	^ menu! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:18'!
stackNameList
	^ stackList
		ifNil: [#()]
		ifNotNil: [stackList
				collect: [:each | each asString]]! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:24'!
updateStackList
	self updateStackList: 20! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'!
updateStackList: depth 
	| suspendedContext oldHighlight |
	selectedProcess
		ifNil: [^ self changeStackListTo: nil].
	(stackList notNil and: [ stackListIndex > 0 ])
		ifTrue: [oldHighlight := stackList at: stackListIndex].
	selectedProcess == Processor activeProcess
		ifTrue: [self
				changeStackListTo: (thisContext stackOfSize: depth)]
		ifFalse: [suspendedContext := selectedProcess suspendedContext.
			suspendedContext
				ifNil: [self changeStackListTo: nil]
				ifNotNil: [self
						changeStackListTo: (suspendedContext stackOfSize: depth)]].
	self
		stackListIndex: (stackList
				ifNil: [0]
				ifNotNil: [stackList indexOf: oldHighlight])! !


!ProcessBrowser methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 20:38'!
buildWith: builder
	"Create a pluggable version of me, answer a window"
	| windowSpec listSpec textSpec |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'Process Browser'.
	windowSpec children: OrderedCollection new.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #processNameList; 
		getIndex: #processListIndex; 
		setIndex: #processListIndex:; 
		menu: #processListMenu:; 
		keyPress: #processListKey:from:;
		frame: (0 @ 0 extent: 0.5 @ 0.5).
	windowSpec children add: listSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #stackNameList; 
		getIndex: #stackListIndex; 
		setIndex: #stackListIndex:; 
		menu: #stackListMenu:; 
		keyPress: #stackListKey:from:;
		frame: (0.5 @ 0.0 extent: 0.5 @ 0.5).
	windowSpec children add: listSpec.

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		getText: #selectedMethod; 
		setText: nil; 
		selection: nil; 
		menu: nil;
		frame: (0 @ 0.5 corner: 1 @ 1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !


!ProcessBrowser methodsFor: 'updating' stamp: 'nk 10/28/2000 21:48'!
isAutoUpdating
	^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended  not ]! !

!ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:20'!
isAutoUpdatingPaused
	^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended ]! !

!ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:20'!
pauseAutoUpdate
	self isAutoUpdating
		ifTrue: [ autoUpdateProcess suspend ].
	self updateProcessList! !

!ProcessBrowser methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'!
setUpdateCallbackAfter: seconds

		deferredMessageRecipient ifNotNil: [ | d |
			d := Delay forSeconds: seconds.
			[  d wait.
				d := nil.
				deferredMessageRecipient addDeferredUIMessage: [self updateProcessList]
			] fork
		]! !

!ProcessBrowser methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'!
startAutoUpdate
	self isAutoUpdatingPaused ifTrue: [ ^autoUpdateProcess resume ].
	self isAutoUpdating
		ifFalse: [| delay | 
			delay := Delay forSeconds: 2.
			autoUpdateProcess := [[self hasView]
						whileTrue: [delay wait.
							deferredMessageRecipient ifNotNil: [
								deferredMessageRecipient addDeferredUIMessage: [self updateProcessList]]
							ifNil: [ self updateProcessList ]].
					autoUpdateProcess := nil] fork].
	self updateProcessList! !

!ProcessBrowser methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'!
stopAutoUpdate
	autoUpdateProcess ifNotNil: [
		autoUpdateProcess terminate.
		autoUpdateProcess := nil].
	self updateProcessList! !

!ProcessBrowser methodsFor: 'updating' stamp: 'nk 10/28/2000 21:50'!
toggleAutoUpdate
	self isAutoUpdating
		ifTrue: [ self stopAutoUpdate ]
		ifFalse: [ self startAutoUpdate ].
! !


!ProcessBrowser methodsFor: 'views' stamp: 'sd 11/20/2005 21:27'!
asPrototypeInWindow
	"Create a pluggable version of me, answer a window"

	| window aTextMorph |
	window := (SystemWindow labelled: 'later') model: self.
	window
		addMorph: ((PluggableListMorph
				on: self
				list: #processNameList
				selected: #processListIndex
				changeSelected: #processListIndex:
				menu: #processListMenu:
				keystroke: #processListKey:from:)
				enableDragNDrop: false)
		frame: (0 @ 0 extent: 0.5 @ 0.5).
	window
		addMorph: ((PluggableListMorph
				on: self
				list: #stackNameList
				selected: #stackListIndex
				changeSelected: #stackListIndex:
				menu: #stackListMenu:
				keystroke: #stackListKey:from:)
				enableDragNDrop: false)
		frame: (0.5 @ 0.0 extent: 0.5 @ 0.5).
	aTextMorph := PluggableTextMorph
				on: self
				text: #selectedMethod
				accept: nil
				readSelection: nil
				menu: nil.
	window
		addMorph: aTextMorph
		frame: (0 @ 0.5 corner: 1 @ 1).
	window setLabel: 'Process Browser'.
	^ window! !

!ProcessBrowser methodsFor: 'views' stamp: 'nk 10/28/2000 11:44'!
hasView
	^self dependents isEmptyOrNil not! !

!ProcessBrowser methodsFor: 'views' stamp: 'sd 11/20/2005 21:27'!
openAsMVC
	"Create a pluggable version of me, answer a window"
	| window processListView stackListView methodTextView |
	window := StandardSystemView new model: self controller: (deferredMessageRecipient := DeferredActionStandardSystemController new).
	window borderWidth: 1.
	processListView := PluggableListView
				on: self
				list: #processNameList
				selected: #processListIndex
				changeSelected: #processListIndex:
				menu: #processListMenu:
				keystroke: #processListKey:from:.
	processListView
		window: (0 @ 0 extent: 300 @ 200).
	window addSubView: processListView.
	stackListView := PluggableListView
				on: self
				list: #stackNameList
				selected: #stackListIndex
				changeSelected: #stackListIndex:
				menu: #stackListMenu:
				keystroke: #stackListKey:from:.
	stackListView
		window: (300 @ 0 extent: 300 @ 200).
	window addSubView: stackListView toRightOf: processListView.
	methodTextView := PluggableTextView
				on: self
				text: #selectedMethod
				accept: nil
				readSelection: nil
				menu: nil.
	methodTextView askBeforeDiscardingEdits: false.
	methodTextView
		window: (0 @ 200 corner: 600 @ 400).
	window addSubView: methodTextView below: processListView.
	window setUpdatablePanesFrom: #(#processNameList #stackNameList ).
	window label: 'Process Browser'.
	window minimumSize: 300 @ 200.
	window subViews
		do: [:each | each controller].
	window controller open.
	startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ].
	^ window! !

!ProcessBrowser methodsFor: 'views' stamp: 'sd 11/20/2005 21:27'!
openAsMorph
	"Create a pluggable version of me, answer a window"
	| window aTextMorph |
	window := (SystemWindow labelled: 'later')
				model: self.

	deferredMessageRecipient := WorldState.
	window
		addMorph: ((PluggableListMorph
				on: self
				list: #processNameList
				selected: #processListIndex
				changeSelected: #processListIndex:
				menu: #processListMenu:
				keystroke: #processListKey:from:)
				enableDragNDrop: false)
		frame: (0 @ 0 extent: 0.5 @ 0.5).
	window
		addMorph: ((PluggableListMorph
				on: self
				list: #stackNameList
				selected: #stackListIndex
				changeSelected: #stackListIndex:
				menu: #stackListMenu:
				keystroke: #stackListKey:from:)
				enableDragNDrop: false)
		frame: (0.5 @ 0.0 extent: 0.5 @ 0.5).
	aTextMorph := PluggableTextMorph
				on: self
				text: #selectedMethod
				accept: nil
				readSelection: nil
				menu: nil.
	aTextMorph askBeforeDiscardingEdits: false.
	window
		addMorph: aTextMorph
		frame: (0 @ 0.5 corner: 1 @ 1).
	window setUpdatablePanesFrom: #(#processNameList #stackNameList ).
	(window setLabel: 'Process Browser') openInWorld.
	startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ].
	^ window! !

!ProcessBrowser methodsFor: 'views' stamp: 'nk 10/28/2000 16:53'!
stackListKey: aKey from: aView 
	^ aKey caseOf: {
		[$c] -> [self inspectContext].
		[$C] -> [self exploreContext].
		[$i] -> [self inspectReceiver].
		[$I] -> [self exploreReceiver].
		[$b] -> [self browseContext]}
		 otherwise: [self arrowKey: aKey from: aView]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProcessBrowser class
	instanceVariableNames: ''!

!ProcessBrowser class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:32'!
shutDown
	Browsers do: [ :ea | ea isAutoUpdating ifTrue: [ ea pauseAutoUpdate ]]! !

!ProcessBrowser class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:32'!
startUp
	Browsers do: [ :ea | ea isAutoUpdatingPaused ifTrue: [ ea startAutoUpdate ]]! !


!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'sd 11/20/2005 21:28'!
dumpTallyOnTranscript: tally
	"tally is from ProcessorScheduler>>tallyCPUUsageFor:
	Dumps lines with percentage of time, hash of process, and a friendly name"

	tally sortedCounts do: [ :assoc | | procName |
		procName := (self nameAndRulesFor: assoc value) first.
		Transcript print: (((assoc key / tally size) * 100.0) roundTo: 1);
			nextPutAll: '%   ';
			print: assoc value identityHash; space;
			nextPutAll: procName;
			cr.
	].
	Transcript flush.! !

!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'nk 3/8/2001 12:49'!
tallyCPUUsageFor: seconds
	"Compute CPU usage using a 10-msec sample for the given number of seconds,
	then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile"
	"ProcessBrowser tallyCPUUsageFor: 10"
	^self tallyCPUUsageFor: seconds every: 10! !

!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'sd 11/20/2005 21:28'!
tallyCPUUsageFor: seconds every: msec
	"Compute CPU usage using a msec millisecond sample for the given number of seconds,
	then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile"
	"ProcessBrowser tallyCPUUsageFor: 10 every: 100"

	| promise |
	promise := Processor tallyCPUUsageFor: seconds every: msec.

	[ | tally |
		tally := promise value.
		Smalltalk isMorphic
			ifTrue: [ WorldState addDeferredUIMessage: [ self dumpTallyOnTranscript: tally ] ]
			ifFalse: [ [ Transcript open ] forkAt: Processor userSchedulingPriority.
					[ (Delay forSeconds: 1) wait.
					self dumpTallyOnTranscript: tally ] forkAt: Processor userSchedulingPriority.]
	] fork.! !


!ProcessBrowser class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
initialize
	"ProcessBrowser initialize"
	Browsers ifNil: [ Browsers := WeakSet new ].
	SuspendedProcesses ifNil: [ SuspendedProcesses := IdentityDictionary new ].
	Smalltalk addToStartUpList: self.
	Smalltalk addToShutDownList: self.
	self registerInFlapsRegistry.
	self registerWellKnownProcesses! !

!ProcessBrowser class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:22'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | 	cl registerQuad: #(ProcessBrowser			prototypicalToolWindow		'Processes'			'A Process Browser shows you all the running processes')
						forFlapNamed: 'Tools'.]! !

!ProcessBrowser class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
registerWellKnownProcesses
	"Associate each well-known process with a nickname and two flags: allow-stop, and allow-debug.
	Additional processes may be added to this list as required"

	WellKnownProcesses := OrderedCollection new.
	self registerWellKnownProcess: []
		label: 'no process'
		allowStop: false
		allowDebug: false.
	self registerWellKnownProcess: [Smalltalk lowSpaceWatcherProcess]
		label: 'the low space watcher'
		allowStop: false
		allowDebug: false.
	self registerWellKnownProcess: [WeakArray runningFinalizationProcess]
		label: 'the WeakArray finalization process'
		allowStop: false
		allowDebug: false.
	self registerWellKnownProcess: [Processor activeProcess]
		label: 'the UI process'
		allowStop: false
		allowDebug: true.
	self registerWellKnownProcess: [Processor backgroundProcess]
		label: 'the idle process'
		allowStop: false
		allowDebug: false.
	self registerWellKnownProcess: [Sensor interruptWatcherProcess]
		label: 'the user interrupt watcher'
		allowStop: false
		allowDebug: false.
	self registerWellKnownProcess: [Sensor eventTicklerProcess]
		label: 'the event tickler'
		allowStop: false
		allowDebug: false.
	self registerWellKnownProcess: [Project uiProcess]
		label: 'the inactive Morphic UI process'
		allowStop: false
		allowDebug: false.
	self registerWellKnownProcess:
			[Smalltalk at: #SoundPlayer ifPresent: [:sp | sp playerProcess]]
		label: 'the Sound Player'
		allowStop: false
		allowDebug: false.
	self registerWellKnownProcess:
			[ScheduledControllers ifNotNil: [ScheduledControllers activeControllerProcess]]
		label: 'the inactive MVC controller process'
		allowStop: false
		allowDebug: true.
	self registerWellKnownProcess:
			[Smalltalk at: #CPUWatcher ifPresent: [:cw | cw currentWatcherProcess]]
		label: 'the CPUWatcher'
		allowStop: false
		allowDebug: false
! !

!ProcessBrowser class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:39'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!ProcessBrowser class methodsFor: 'instance creation' stamp: 'nk 3/14/2001 07:53'!
open
	"ProcessBrowser open"
	"Create and schedule a ProcessBrowser."
	Smalltalk garbageCollect.
	^ Smalltalk isMorphic
		ifTrue: [ self new openAsMorph ]
		ifFalse: [ self new openAsMVC ]! !

!ProcessBrowser class methodsFor: 'instance creation' stamp: 'sw 6/13/2001 01:04'!
prototypicalToolWindow
	"Answer a window representing a prototypical instance of the receiver"

	^ self new asPrototypeInWindow! !


!ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 17:09'!
debugProcess: aProcess
	self resumeProcess: aProcess.
	aProcess debugWithTitle: 'Interrupted from the Process Browser'.
! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 20:11'!
isUIProcess: aProcess
	^aProcess == (Smalltalk isMorphic
		ifTrue: [ Project uiProcess ]
		ifFalse: [ ScheduledControllers activeControllerProcess ])! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'dtl 2/5/2005 01:21'!
nameAndRulesFor: aProcess 
	"Answer a nickname and two flags: allow-stop, and allow-debug"
	^ [aProcess caseOf: WellKnownProcesses
		 otherwise: 
			[(aProcess priority = Processor timingPriority
					and: [aProcess suspendedContext receiver == Delay])
				ifTrue: [{'the timer interrupt watcher'. false. false}]
				ifFalse: [{aProcess suspendedContext asString. true. true}]]]
		ifError: [:err :rcvr | {aProcess suspendedContext asString. true. true}]! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'dtl 2/5/2005 09:07'!
registerWellKnownProcess: aBlockForProcess label: nickname allowStop: allowStop allowDebug: allowDebug
	"Add an entry to the registry of well known processes. aBlockForProcess
	evaluates to a known process to be identified by nickname, and allowStop
	and allowDebug are flags controlling allowable actions for this process
	in the browser."

	WellKnownProcesses add: aBlockForProcess->[{nickname . allowStop . allowDebug}]! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'!
resumeProcess: aProcess
	| priority |
	priority := self suspendedProcesses
				removeKey: aProcess
				ifAbsent: [aProcess priority].
	aProcess priority: priority.
	aProcess suspendedContext ifNotNil: [ aProcess resume ]
! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'!
setProcess: aProcess toPriority: priority
	| oldPriority |
	oldPriority := self suspendedProcesses at: aProcess ifAbsent: [ ].
	oldPriority ifNotNil: [ self suspendedProcesses at: aProcess put: priority ].
	aProcess priority: priority.
	^oldPriority! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'!
suspendProcess: aProcess
	| priority |
	priority := aProcess priority.
	self suspendedProcesses at: aProcess put: priority.
	"Need to take the priority down below the caller's
	so that it can keep control after signaling the Semaphore"
	(aProcess suspendingList isKindOf: Semaphore)
		ifTrue: [aProcess priority: Processor lowestPriority.
			aProcess suspendingList signal].
	[aProcess suspend]
		on: Error
		do: [:ex | self suspendedProcesses removeKey: aProcess].
	aProcess priority: priority.
! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'!
suspendedProcesses
	"Answer a collection of processes that my instances have suspended.  
	This is so that they don't get garbage collected."
	^ SuspendedProcesses
		ifNil: [SuspendedProcesses := IdentityDictionary new]! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:25'!
terminateProcess: aProcess
	aProcess ifNotNil: [
		self suspendedProcesses
			removeKey: aProcess
			ifAbsent: [].
		aProcess terminate
	].
! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'!
unregisterWellKnownProcess: aProcess
	"Remove the first registry entry that matches aProcess. Use
	with caution if more than one registry entry may match aProcess."

	"self unregisterWellKnownProcess: Smalltalk lowSpaceWatcherProcess"

	| entry |
	entry := WellKnownProcesses
		detect: [:e | e key value == aProcess]
		ifNone: [^ self].
	WellKnownProcesses remove: entry! !

!ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:26'!
wasProcessSuspendedByProcessBrowser: aProcess
	^self suspendedProcesses includesKey: aProcess! !
TestCase subclass: #ProcessTerminateBug
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Tests'!

!ProcessTerminateBug methodsFor: 'tests' stamp: 'm 7/28/2003 19:10'!
testSchedulerTermination
   | process sema gotHere sema2 |
   gotHere := false.
   sema := Semaphore new.
   sema2 := Semaphore new.
   process := [
       sema signal.
       sema2 wait.
       "will be suspended here"
       gotHere := true. "e.g., we must *never* get here"
   ] forkAt: Processor activeProcess priority.
   sema wait. "until process gets scheduled"
   process terminate.
   sema2 signal.
   Processor yield. "will give process a chance to continue and
horribly screw up"
   self assert: gotHere not.
! !

!ProcessTerminateBug methodsFor: 'tests' stamp: 'ar 7/27/2003 19:44'!
testUnwindFromActiveProcess
	| sema process |
	sema := Semaphore forMutualExclusion.
	self assert:(sema isSignaled).
	process := [
		sema critical:[
			self deny: sema isSignaled.
			Processor activeProcess terminate.
		]
	] forkAt: Processor userInterruptPriority.
	self assert: sema isSignaled.! !

!ProcessTerminateBug methodsFor: 'tests' stamp: 'ar 7/27/2003 19:49'!
testUnwindFromForeignProcess
	| sema process |
	sema := Semaphore forMutualExclusion.
	self assert: sema isSignaled.
	process := [
		sema critical:[
			self deny: sema isSignaled.
			sema wait. "deadlock"
		]
	] forkAt: Processor userInterruptPriority.
	self deny: sema isSignaled.
	"This is for illustration only - the BlockCannotReturn cannot 
	be handled here (it's truncated already)"
	self shouldnt: [process terminate] raise: BlockCannotReturn.
	self assert: sema isSignaled.
	! !
Object subclass: #ProcessorScheduler
	instanceVariableNames: 'quiescentProcessLists activeProcess'
	classVariableNames: 'BackgroundProcess HighIOPriority LowIOPriority SystemBackgroundPriority SystemRockBottomPriority TimingPriority UserBackgroundPriority UserInterruptPriority UserSchedulingPriority'
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!ProcessorScheduler commentStamp: '<historical>' prior: 0!
My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service.!


!ProcessorScheduler methodsFor: 'accessing'!
activePriority
	"Answer the priority level of the currently running Process."

	^activeProcess priority! !

!ProcessorScheduler methodsFor: 'accessing'!
activeProcess
	"Answer the currently running Process."

	^activeProcess! !

!ProcessorScheduler methodsFor: 'accessing' stamp: 'nk 10/27/2000 16:27'!
backgroundProcess
	"Answer the background process"
	^ BackgroundProcess! !

!ProcessorScheduler methodsFor: 'accessing'!
highestPriority
	"Answer the number of priority levels currently available for use."

	^quiescentProcessLists size! !

!ProcessorScheduler methodsFor: 'accessing'!
highestPriority: newHighestPriority
	"Change the number of priority levels currently available for use."

	| continue newProcessLists |
	(quiescentProcessLists size > newHighestPriority
		and: [self anyProcessesAbove: newHighestPriority])
			ifTrue: [self error: 'There are processes with priority higher than '
													,newHighestPriority printString].
	newProcessLists _ Array new: newHighestPriority.
	1 to: ((quiescentProcessLists size) min: (newProcessLists size)) do: 
		[:priority | newProcessLists at: priority put: (quiescentProcessLists at: priority)].
	quiescentProcessLists size to: newProcessLists size do: 
		[:priority | newProcessLists at: priority put: LinkedList new].
	quiescentProcessLists _ newProcessLists! !

!ProcessorScheduler methodsFor: 'accessing' stamp: 'ar 8/22/2001 17:33'!
preemptedProcess
	"Return the process that the currently active process just preempted."
	| list |
	activeProcess priority to: 1 by: -1 do:[:priority|
		list _ quiescentProcessLists at: priority.
		list isEmpty ifFalse:[^list last].
	].
	^nil

	"Processor preemptedProcess"! !

!ProcessorScheduler methodsFor: 'accessing' stamp: 'ar 7/8/2001 16:21'!
waitingProcessesAt: aPriority
	"Return the list of processes at the given priority level."
	^quiescentProcessLists at: aPriority! !


!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/8/2001 12:56'!
nextReadyProcess
	quiescentProcessLists reverseDo: [ :list |
		list isEmpty ifFalse: [ | proc |
			proc _ list first.
			proc suspendedContext ifNotNil: [ ^proc ]]].
	^nil! !

!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/8/2001 12:48'!
tallyCPUUsageFor: seconds
	"Start a high-priority process that will tally the next ready process for the given
	number of seconds. Answer a Block that will return the tally (a Bag) after the task
	is complete" 
	^self tallyCPUUsageFor: seconds every: 10
! !

!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/17/2001 10:06'!
tallyCPUUsageFor: seconds every: msec
	"Start a high-priority process that will tally the next ready process for the given
	number of seconds. Answer a Block that will return the tally (a Bag) after the task
	is complete" 
	| tally sem delay endDelay |
	tally _ IdentityBag new: 200.
	delay _ Delay forMilliseconds: msec truncated.
	endDelay _ Delay forSeconds: seconds.
	endDelay schedule.
	sem _ Semaphore new.
	[
		[ endDelay isExpired ] whileFalse: [
			delay wait.
			tally add: Processor nextReadyProcess
		].
		sem signal.
	] forkAt: self highestPriority.

	^[ sem wait. tally ]! !


!ProcessorScheduler methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:46'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	dp _ DiskProxy global: #Processor selector: #yourself args: #().
	refStrm replace: self with: dp.
	^ dp
! !


!ProcessorScheduler methodsFor: 'priority names'!
highIOPriority
	"Answer the priority at which the most time critical input/output 
	processes should run. An example is the process handling input from a 
	network."

	^HighIOPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
lowIOPriority
	"Answer the priority at which most input/output processes should run. 
	Examples are the process handling input from the user (keyboard, 
	pointing device, etc.) and the process distributing input from a network."

	^LowIOPriority! !

!ProcessorScheduler methodsFor: 'priority names' stamp: 'ar 7/8/2001 17:02'!
lowestPriority
	"Return the lowest priority that is allowed with the scheduler"
	^SystemRockBottomPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
systemBackgroundPriority
	"Answer the priority at which system background processes should run. 
	Examples are an incremental garbage collector or status checker."

	^SystemBackgroundPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
timingPriority
	"Answer the priority at which the system processes keeping track of real 
	time should run."

	^TimingPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
userBackgroundPriority
	"Answer the priority at which user background processes should run."

	^UserBackgroundPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
userInterruptPriority
	"Answer the priority at which user processes desiring immediate service 
	should run. Processes run at this level will preempt the window 
	scheduler and should, therefore, not consume the processor forever."

	^UserInterruptPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
userSchedulingPriority
	"Answer the priority at which the window scheduler should run."

	^UserSchedulingPriority! !


!ProcessorScheduler methodsFor: 'process state change'!
suspendFirstAt: aPriority 
	"Suspend the first Process that is waiting to run with priority aPriority."

	^self suspendFirstAt: aPriority
		  ifNone: [self error: 'No Process to suspend']! !

!ProcessorScheduler methodsFor: 'process state change'!
suspendFirstAt: aPriority ifNone: noneBlock 
	"Suspend the first Process that is waiting to run with priority aPriority. If 
	no Process is waiting, evaluate the argument, noneBlock."

	| aList |
	aList _ quiescentProcessLists at: aPriority.
	aList isEmpty
		ifTrue: [^noneBlock value]
		ifFalse: [^aList first suspend]! !

!ProcessorScheduler methodsFor: 'process state change'!
terminateActive
	"Terminate the process that is currently running."

	activeProcess terminate! !

!ProcessorScheduler methodsFor: 'process state change' stamp: 'tpr 4/28/2004 17:53'!
yield
	"Give other Processes at the current priority a chance to run."

	| semaphore |

	<primitive: 167>
	semaphore _ Semaphore new.
	[semaphore signal] fork.
	semaphore wait! !


!ProcessorScheduler methodsFor: 'removing'!
remove: aProcess ifAbsent: aBlock 
	"Remove aProcess from the list on which it is waiting for the processor 
	and answer aProcess. If it is not waiting, evaluate aBlock."

	(quiescentProcessLists at: aProcess priority)
		remove: aProcess ifAbsent: aBlock.
	^aProcess! !


!ProcessorScheduler methodsFor: 'private' stamp: 'tk 6/24/1999 11:27'!
anyProcessesAbove: highestPriority 
	"Do any instances of Process exist with higher priorities?"

	^(Process allInstances "allSubInstances" select: [:aProcess | 
		aProcess priority > highestPriority]) isEmpty
		"If anyone ever makes a subclass of Process, be sure to use allSubInstances."! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProcessorScheduler class
	instanceVariableNames: ''!

!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:44'!
idleProcess
	"A default background process which is invisible."

	[true] whileTrue:
		[self relinquishProcessorForMicroseconds: 1000]! !

!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/3/97 11:17'!
relinquishProcessorForMicroseconds: anInteger
	"Platform specific. This primitive is used to return processor cycles to the host operating system when Squeak's idle process is running (i.e., when no other Squeak process is runnable). On some platforms, this primitive causes the entire Squeak application to sleep for approximately the given number of microseconds. No Squeak process can run while the Squeak application is sleeping, even if some external event makes it runnable. On the Macintosh, this primitive simply calls GetNextEvent() to give other applications a chance to run. On platforms without a host operating system, it does nothing. This primitive should not be used to add pauses to a Squeak process; use a Delay instead."

	<primitive: 230>
	"don't fail if primitive is not implemented, just do nothing"
! !

!ProcessorScheduler class methodsFor: 'background process' stamp: 'di 2/4/1999 08:45'!
startUp
	"Install a background process of the lowest possible priority that is always runnable."
	"Details: The virtual machine requires that there is aways some runnable process that can be scheduled; this background process ensures that this is the case."

	Smalltalk installLowSpaceWatcher.
	BackgroundProcess == nil ifFalse: [BackgroundProcess terminate].
	BackgroundProcess _ [self idleProcess] newProcess.
	BackgroundProcess priority: SystemRockBottomPriority.
	BackgroundProcess resume.
! !

!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:32'!
sweepHandIdleProcess
	"A default background process which shows a sweeping circle of XOR-ed bits on the screen."

	| sweepHand |
	sweepHand _ Pen new.
	sweepHand defaultNib: 2.
	sweepHand combinationRule: 6.
	[true] whileTrue: [
		2 timesRepeat: [
			sweepHand north.
			36 timesRepeat: [
				sweepHand place: Display boundingBox topRight + (-25@25).
				sweepHand go: 20.
				sweepHand turn: 10]].
		self relinquishProcessorForMicroseconds: 10000].
! !


!ProcessorScheduler class methodsFor: 'class initialization' stamp: 'ar 7/8/2001 16:39'!
initialize
     
	SystemRockBottomPriority _ 10.
	SystemBackgroundPriority _ 20.
	UserBackgroundPriority _ 30.
	UserSchedulingPriority _ 40.
	UserInterruptPriority _ 50.
	LowIOPriority _ 60.
	HighIOPriority _ 70.
	TimingPriority _ 80.

	"ProcessorScheduler initialize."! !


!ProcessorScheduler class methodsFor: 'instance creation'!
new
	"New instances of ProcessorScheduler should not be created."

	self error:
'New ProcessSchedulers should not be created since
the integrity of the system depends on a unique scheduler'! !
AbstractScoreEvent subclass: #ProgramChangeEvent
	instanceVariableNames: 'program channel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel

	^ channel
! !

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
channel: midiChannel

	channel := midiChannel.
! !

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'!
program

	^ program
! !

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
program: midiProgramChange

	program := midiProgramChange.
! !

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
program: midiProgramChange channel: midiChannel

	program := midiProgramChange.
	channel := midiChannel.
! !


!ProgramChangeEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:46'!
isProgramChange

	^ true
! !


!ProgramChangeEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'!
outputOnMidiPort: aMidiPort
	"Output this event to the given MIDI port."

	aMidiPort
		midiCmd: 16rC0
		channel: channel
		byte: program.
! !


!ProgramChangeEvent methodsFor: 'printing' stamp: 'jm 9/10/1998 08:28'!
printOn: aStream

	aStream nextPut: $(.
	time printOn: aStream.
	aStream nextPutAll: ': prog '.
	program printOn: aStream.
	aStream nextPut: $).
! !
BorderedMorph subclass: #ProgressBarMorph
	instanceVariableNames: 'value progressColor lastValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!ProgressBarMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:14'!
progressColor
	^progressColor! !

!ProgressBarMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 18:52'!
progressColor: aColor
	progressColor = aColor
		ifFalse:
			[progressColor _ aColor.
			self changed]! !

!ProgressBarMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:09'!
value
	^value! !

!ProgressBarMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 18:53'!
value: aModel
	value ifNotNil: [value removeDependent: self].
	value _ aModel.
	value ifNotNil: [value addDependent: self]! !


!ProgressBarMorph methodsFor: 'drawing' stamp: 'sma 3/3/2000 18:54'!
drawOn: aCanvas
	| width inner |
	super drawOn: aCanvas.
	inner _ self innerBounds.
	width _ (inner width * lastValue) truncated min: inner width.
	aCanvas fillRectangle: (inner origin extent: width @ inner height) color: progressColor.! !


!ProgressBarMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 18:55'!
initialize
	super initialize.
	progressColor _ Color green.
	self value: (ValueHolder new contents: 0.0).
	lastValue _ 0.0! !


!ProgressBarMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:43'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addList: {
		{'progress color...' translated. #changeProgressColor:}.
		{'progress value...' translated. #changeProgressValue:}.
		}! !

!ProgressBarMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:51'!
changeProgressColor: evt
	| aHand |
	aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand].
	self changeColorTarget: self selector: #progressColor: originalColor: self progressColor hand: aHand.! !

!ProgressBarMorph methodsFor: 'menu' stamp: 'sma 3/3/2000 19:27'!
changeProgressValue: evt
	| answer |
	answer _ FillInTheBlank
		request: 'Enter new value (0 - 1.0)'
		initialAnswer: self value contents asString.
	answer isEmptyOrNil ifTrue: [^ self].
	self value contents: answer asNumber! !


!ProgressBarMorph methodsFor: 'updating' stamp: 'sma 3/3/2000 18:51'!
update: aSymbol 
	aSymbol == #contents
		ifTrue: 
			[lastValue _ value contents.
			self changed]! !
Exception subclass: #ProgressInitiationException
	instanceVariableNames: 'workBlock maxVal minVal aPoint progressTitle'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!ProgressInitiationException commentStamp: '<historical>' prior: 0!
I provide a way to alter the behavior of the old-style progress notifier in String. See examples in:

ProgressInitiationException testWithout.
ProgressInitiationException testWith.
!


!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'md 2/22/2006 21:26'!
defaultAction
	Smalltalk isMorphic
		ifTrue: [self defaultMorphicAction]
		ifFalse: [self defaultMVCAction].
! !

!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'laza 4/1/2004 12:47'!
defaultMVCAction

	| delta savedArea captionText textFrame barFrame outerFrame result range lastW w |
	barFrame _ aPoint - (75@10) corner: aPoint + (75@10).
	captionText _ DisplayText text: progressTitle asText allBold.
	captionText
		foregroundColor: Color black
		backgroundColor: Color white.
	textFrame _ captionText boundingBox insetBy: -4.
	textFrame _ textFrame align: textFrame bottomCenter
					with: barFrame topCenter + (0@2).
	outerFrame _ barFrame merge: textFrame.
	delta _ outerFrame amountToTranslateWithin: Display boundingBox.
	barFrame _ barFrame translateBy: delta.
	textFrame _ textFrame translateBy: delta.
	outerFrame _ outerFrame translateBy: delta.
	savedArea _ Form fromDisplay: outerFrame.
	Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2).
	Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2).
	captionText displayOn: Display at: textFrame topLeft + (4@4).
	range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal].  "Avoid div by 0"
	lastW _ 0.
	[result _ workBlock value:  "Supply the bar-update block for evaluation in the work block"
		[:barVal |
		w _ ((barFrame width-4) asFloat * ((barVal-minVal) asFloat / range min: 1.0)) asInteger.
		w ~= lastW ifTrue: [
			Display fillGray: (barFrame topLeft + (2@2) extent: w@16).
			lastW _ w]]]
		ensure: [savedArea displayOn: Display at: outerFrame topLeft].
	self resume: result! !

!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'laza 4/9/2004 10:52'!
defaultMorphicAction
	| result progress |
	progress _ SystemProgressMorph label: progressTitle min: minVal max: maxVal.
	[result _ workBlock value: progress] ensure: [SystemProgressMorph close: progress].
	self resume: result! !

!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 5/15/2000 11:43'!
display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock

	progressTitle _ argString.
	aPoint _ argPoint.
	minVal _ argMinVal.
	maxVal _ argMaxVal.
	workBlock _ argWorkBlock.
	^self signal! !

!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 5/15/2000 12:39'!
isResumable
	
	^true! !

!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 5/15/2000 12:40'!
sendNotificationsTo: aNewBlock

	self resume: (
		workBlock value: [ :barVal |
			aNewBlock value: minVal value: maxVal value: barVal
		]
	)
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProgressInitiationException class
	instanceVariableNames: ''!

!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 15:46'!
testInnermost

	"test the progress code WITHOUT special handling"

	^'Now here''s some Real Progress'
		displayProgressAt: Sensor cursorPoint
		from: 0 
		to: 10
		during: [ :bar |
			1 to: 10 do: [ :x | 
				bar value: x. (Delay forMilliseconds: 500) wait.
				x = 5 ifTrue: [1/0].	"just to make life interesting"
			].
			'done'
		].

! !

!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 12:42'!
testWith

	"test progress code WITH special handling of progress notifications"

	^[ self testWithAdditionalInfo ] 
		on: ProgressInitiationException
		do: [ :ex | 
			ex sendNotificationsTo: [ :min :max :curr |
				Transcript show: min printString,'  ',max printString,'  ',curr printString; cr
			].
		].
! !

!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 12:04'!
testWithAdditionalInfo

	^{'starting'. self testWithout. 'really!!'}! !

!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 15:45'!
testWithout

	"test the progress code WITHOUT special handling"

	^[self testInnermost]
		on: ZeroDivide
		do: [ :ex | ex resume]

! !


!ProgressInitiationException class methodsFor: 'signalling' stamp: 'ajh 1/22/2003 23:51'!
display: aString at: aPoint from: minVal to: maxVal during: workBlock

	^ self new
		display: aString at: aPoint from: minVal to: maxVal during: workBlock! !
RectangleMorph subclass: #ProgressMorph
	instanceVariableNames: 'labelMorph subLabelMorph progress'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!ProgressMorph methodsFor: 'accessing' stamp: 'mir 2/14/2000 17:55'!
done
	^self progress value contents! !

!ProgressMorph methodsFor: 'accessing'!
done: amountDone
	self progress value contents: ((amountDone min: 1.0) max: 0.0).
	self currentWorld displayWorld! !

!ProgressMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 19:05'!
incrDone: incrDone
	self done: self done + incrDone! !

!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:28'!
label
	^self labelMorph contents! !

!ProgressMorph methodsFor: 'accessing'!
label: aString
	self labelMorph contents: aString.
	self currentWorld displayWorld! !

!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:25'!
progress
	^progress ifNil: [self initProgressMorph]! !

!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:27'!
subLabel
	^self subLabelMorph contents! !

!ProgressMorph methodsFor: 'accessing'!
subLabel: aString
	self subLabelMorph contents: aString.
	self currentWorld displayWorld! !


!ProgressMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 19:13'!
initLabelMorph
	^ labelMorph _ StringMorph contents: '' font: (self fontOfPointSize: 14)! !

!ProgressMorph methodsFor: 'initialization' stamp: 'dvf 9/17/2003 05:14'!
initProgressMorph
	progress := ProgressBarMorph new.
	progress borderWidth: 1.
	progress color: Color white.
	progress progressColor: Color gray.
	progress extent: 200 @ 15.
! !

!ProgressMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 19:13'!
initSubLabelMorph
	^ subLabelMorph _ StringMorph contents: '' font: (self fontOfPointSize: 12)! !

!ProgressMorph methodsFor: 'initialization' stamp: 'mir 1/19/2000 13:28'!
initialize
	super initialize.
	self setupMorphs! !

!ProgressMorph methodsFor: 'initialization' stamp: 'nk 4/21/2002 20:06'!
setupMorphs
	|  |
	self initProgressMorph.
	self	
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		cellPositioning: #topCenter;
		listCentering: #center;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		color: Color transparent.

	self addMorphBack: self labelMorph.
	self addMorphBack: self subLabelMorph.
	self addMorphBack: self progress.

	self borderWidth: 2.
	self borderColor: Color black.

	self color: Color veryLightGray.
	self align: self fullBounds center with: Display boundingBox center
! !


!ProgressMorph methodsFor: 'private' stamp: 'nk 7/12/2003 08:59'!
fontOfPointSize: size
	^ (TextConstants at: Preferences standardEToysFont familyName ifAbsent: [TextStyle default]) fontOfPointSize: size! !

!ProgressMorph methodsFor: 'private' stamp: 'mir 1/19/2000 13:25'!
labelMorph
	^labelMorph ifNil: [self initLabelMorph]! !

!ProgressMorph methodsFor: 'private' stamp: 'mir 1/19/2000 13:25'!
subLabelMorph
	^subLabelMorph ifNil: [self initSubLabelMorph]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProgressMorph class
	instanceVariableNames: ''!

!ProgressMorph class methodsFor: 'example' stamp: 'sma 3/3/2000 19:07'!
example
	"ProgressMorph example"

	| progress |
	progress _ ProgressMorph label: 'Test progress'.
	progress subLabel: 'this is the subheading'.
	progress openInWorld.
	[10 timesRepeat:
		[(Delay forMilliseconds: 200) wait.
		progress incrDone: 0.1].
	progress delete] fork! !


!ProgressMorph class methodsFor: 'instance creation' stamp: 'mir 1/19/2000 13:07'!
label: aString
	^self new label: aString! !
Notification subclass: #ProgressNotification
	instanceVariableNames: 'amount done extra'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!ProgressNotification commentStamp: '<historical>' prior: 0!
Used to signal progress without requiring a specific receiver to notify. Caller/callee convention could be to simply count the number of signals caught or to pass more substantive information with #signal:.!


!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'!
amount
	^amount! !

!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'!
amount: aNumber
	amount _ aNumber! !

!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'!
done
	^done! !

!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'!
done: aNumber
	done _ aNumber! !

!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'!
extraParam
	^extra! !

!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'!
extraParam: anObject
	extra _ anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProgressNotification class
	instanceVariableNames: ''!

!ProgressNotification class methodsFor: 'exceptionInstantiator' stamp: 'ajh 1/22/2003 23:51'!
signal: signalerText extra: extraParam
	"TFEI - Signal the occurrence of an exceptional condition with a specified textual description."

	| ex |
	ex := self new.
	ex extraParam: extraParam.
	^ex signal: signalerText! !
Notification subclass: #ProgressTargetRequestNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!ProgressTargetRequestNotification commentStamp: '<historical>' prior: 0!
I am used to allow the ComplexProgressIndicator one last chance at finding an appropriate place to display. If I am unhandled, then the cursor location and a default rectangle are used.!


!ProgressTargetRequestNotification methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 12:25'!
defaultAction

	self resume: nil! !
Model subclass: #Project
	instanceVariableNames: 'world changeSet transcript parentProject previousProject displayDepth viewSize thumbnail nextProject guards projectParameters isolatedHead inForce version urlList environment lastDirectory lastSavedAtSeconds projectPreferenceFlagDictionary resourceManager'
	classVariableNames: 'AllProjects CurrentProject GoalFreePercent GoalNotMoreThan UIProcess'
	poolDictionaries: ''
	category: 'System-Support'!
!Project commentStamp: 'tk 12/2/2004 12:38' prior: 0!
A Project stores the state of a complete Squeak desktop, including
the windows, and the currently active changeSet.  A project knows who
its parent project is.  When you change projects, whether by entering
or exiting, the screen state of the project being exited is saved in
that project.

A project is retained by its view in the parent world.  It is
effectively named by the name of its changeSet, which can be changed
either by renaming in a changeSorter, or by editing the label of its
view from the parent project.

As the site of major context switch, Projects are the locus of
swapping between the old MVC and the new Morphic worlds.  The
distinction is based on whether the variable 'world' contains a
WorldMorph or a ControlManager.

Saving and Loading
Projects may be stored on the disk in external format.  (Project
named: 'xxx') exportSegment, or choose 'store project on file...'.
Projects may be loaded from a server and stored back.  Storing on a
server never overwrites;  it always makes a new version.  A project
remembers the url of where it lives in urlList.  The list is length
one, for now.  The url may point to a local disk instead of a server.
All projects that the user looks at, are cached in the Squeaklet
folder.  Sorted by server.  The cache holds the most recent version
only.

When a project is loaded into Squeak, its objects are converted to
the current version.  There are three levels of conversion.  First,
each object is converted from raw bits to an object in its old
format.  Then it is sent some or all of these messages:
	comeFullyUpOnReload: smartRefStream  		Used to
re-discover an object that already exists in this image, such as a
resource, global variable, Character, or Symbol.  (sent to objects in
outPointers)
	convertToCurrentVersion: varDict refStream: smartRefStrm
		fill in fields that have been added to a class since
the object was stored.  Used to set the extra inst var to a default
value.  Or, return a new object of a different class.  (sent to
objects that changed instance variables)
	fixUponLoad: aProject refStream: smartRefStrm
	change the object due to conventions that have changed on the
project level.  (sent to all objects in the incoming project)

Here is the calling sequence for storing out a Project:
Project saveAs
Project storeOnServer
Project storeOnServerWithProgressInfo
Project storeOnServerInnards
Project exportSegmentFileName:directory:
Project exportSegmentWithChangeSet:fileName:directory:
ImageSegment writeForExportWithSources:inDirectory:changeSet:
---------
Isolation (not used any more)
When you accept a method, the entire system feels the change, except
projects that are "isolated".  In an isolated project, all new global
variables (including new classes) arestored in the project-local
environment, and all changes to preexisting classes are revoked when
you leave the project.  When you enter another project, that
project's changes are invoked.  Invocation and revocation are handled
efficiently by swapping pointers.  To make a project be isolated,
choose 'isolate changes of this project' from the 'changes...'
section of the screen menu.  You can use an isolated project for
making dangerous change to a system, and you can get out if it
crashes.  A foreign application can have the separate environment it
wants.  Also, you can freeze part of the system for a demo that you
don't want to disturb.  An isolated project shares methods with all
subprojects inside it, unless they are isolated themselves.   Each
isolated project is the head of a tree of projects with which it
shares all methods.

You may 'assert' all changes ever made in the current project to take
effect above this project.  This amounts to exporting all the globals
in the current environment, and zapping the revocation lists to that
the current state of the world will remain in force upon exit from
this project.

[Later: A project may be 'frozen'.  Asserts do not apply to it after
that.  (Great for demos.)  You should be informed when an assert was
blocked in a frozen project.]

Class definitions are layered by the isolation mechanism.  You are
only allowed to change the shape of a class in projects that lie
within its isolation scope.  All versions of the methods are
recompiled, in all projects.  If you remove an inst var that is in
use in an isolated project, it will become an Undeclared global.  It
is best not to remove an inst var when it is being used in another
isolated project. [If we recompile them all, why can't we diagnose
the problem before allowing the change??]

Senders and Implementors do not see versions of a method in isolated
projects.  [again, we might want to make this possible at a cost].
When you ask for versions of a method, you will not get the history
in other isolated projects.

Moving methods and classes between changeSets, and merging changeSets
has no effect on which methods are in force.  But, when you look at a
changeSet from a different isolated project, the methods will contain
code that is not in force.  A changeSet is just a list of method
names, and does not keep separate copies of any code.

When finer grained assertion is needed, use the method (aProject
assertClass: aClass from: thisProject warn: warnConflicts).

How isolated changes work: The first time a class changes, store its
MethodDictionary object.  Keep parallel arrays of associations to
Classes and MethodDictionaries.  Traverse these and install them when
you enter an "ioslated project".  When you leave, store this
project's own MethodDictionaries there.
	To do an assert, we must discover which methods changed here,
and which changed only in the project we are asserting into.  There
is one copy of the 'virgin' method dictionaries in the system.  It is
always being temporarily stored by the currently inForce isolated
project.

isolatedHead - true for the top project, and for each isolated
project.  false or nil for any subproject that shares all methods
with its parent project.

inForce -  true if my methods are installed now.  false if I am
dormant. [is this equivalent to self == Project Current?]

classArray - list of associations to classes

methodDictArray - the method dictionaries of those classes before we
started changing methods.  They hang onto the original
compiledMethods.  (If this project is dormant, it contains the method
dictionaries of those classes as they will be here, in this project).

orgArray - the class organizations of the classes in classArray.

UsingIsolation (class variable) - No longer used.

When you want to save a project in export format from within that
very project, it gets tricky.  We set two flags in parentProject,
exit to it, and let parentProject write the project.
ProjectViewMorph in parentProject checks in its step method, does the
store, clears the flags, and reenters the subProject.

!


!Project methodsFor: 'accessing' stamp: 'ar 4/19/1999 04:26'!
addGuard: anObject
	"Add the given object to the list of objects receiving #okayToEnterProject on Project entry"
	guards ifNil:[guards _ WeakArray with: anObject]
			ifNotNil:[guards _ guards copyWith: anObject].! !

!Project methodsFor: 'accessing' stamp: 'sw 9/7/2000 06:56'!
addSubProjectNamesTo: aStream indentation: anIndentation
	"Add the names of the receiver and all its subprojects, and all *their* subprojects recursively, to aStream, indenting by the specified number of tab stops "

	self isTopProject ifFalse:  "circumvent an annoying cr at the top "
		[aStream cr].  
	aStream tab: anIndentation; nextPutAll: self name.
	self subProjects do:
		[:p |
			p addSubProjectNamesTo: aStream indentation: anIndentation + 1]! !

!Project methodsFor: 'accessing' stamp: 'tk 4/5/2000 16:29'!
changeSet
	^ changeSet! !

!Project methodsFor: 'accessing' stamp: 'jla 5/28/2001 21:50'!
children
	"Answer a list of all the subprojects of the receiver"
	
	| children |
	children _ OrderedCollection new.
	Project allProjects do: [ :p | 
		(self == p parent and: [self ~~ p]) ifTrue:
			[ children add: p ]].
	^ children

"
Project topProject children
"! !

!Project methodsFor: 'accessing' stamp: 'sw 10/27/2000 05:55'!
currentStack: aStack
	"Set the current stack as indicated; if the parameter supplied is nil, delete any prior memory of the CurrentStack"

	aStack
		ifNil:
			[self removeParameter: #CurrentStack]
		ifNotNil:
			[self projectParameterAt: #CurrentStack put: aStack]! !

!Project methodsFor: 'accessing'!
displayDepth: newDepth
	displayDepth _ newDepth! !

!Project methodsFor: 'accessing' stamp: 'nk 8/30/2004 08:00'!
findProjectView: projectDescription
	| pName dpName proj |
	"In this world, find the morph that holds onto the project described by projectDescription.  projectDescription can be a project, or the name of a project.  The project may be represented by a DiskProxy.  The holder morph may be at any depth in the world.
	Need to fix this if Projects have subclasses, or if a class other than ProjectViewMorph can officially hold onto a project.  (Buttons, links, etc)
	If parent is an MVC world, return the ProjectController."

	self flag: #bob.		"read the comment"


	pName _ (projectDescription isString) 
		ifTrue: [projectDescription]
		ifFalse: [projectDescription name].
	self isMorphic 
		ifTrue: [world allMorphsDo: [:pvm |
				pvm class == ProjectViewMorph ifTrue: [
					(pvm project class == Project and: 
						[pvm project name = pName]) ifTrue: [^ pvm].

					pvm project class == DiskProxy ifTrue: [ 
						dpName _ pvm project constructorArgs first.
						dpName _ (dpName findTokens: '/') last.
						dpName _ (Project parseProjectFileName: dpName unescapePercents) first.
						dpName = pName ifTrue: [^ pvm]]]]]
		ifFalse: [world scheduledControllers do: [:cont |
				(cont isKindOf: ProjectController) ifTrue: [
					((proj _ cont model) class == Project and: 
						[proj name = pName]) ifTrue: [^ cont view].

					proj class == DiskProxy ifTrue: [ 
						dpName _ proj constructorArgs first.
						dpName _ (dpName findTokens: '/') last.
						dpName _ (Project parseProjectFileName: dpName unescapePercents) first.
						dpName = pName ifTrue: [^ cont view]]]]
			].
	^ nil! !

!Project methodsFor: 'accessing' stamp: 'mir 6/22/2001 20:06'!
forgetExistingURL
	self resourceManager makeAllProjectResourcesLocalTo: self resourceUrl.
	urlList _ nil! !

!Project methodsFor: 'accessing' stamp: 'RAA 6/3/2000 10:23'!
isCurrentProject

	^self == CurrentProject! !

!Project methodsFor: 'accessing' stamp: 'tk 9/22/1999 18:32'!
isMorphic
	"Complexity is because #isMVC is lazily installed"
	^ world isInMemory 
		ifTrue: [world isMorph]
		ifFalse: [(self projectParameters at: #isMVC ifAbsent: [false]) not]! !

!Project methodsFor: 'accessing' stamp: 'di 3/29/2000 15:37'!
isTopProject
	"Return true only if this is the top project (its own parent).
	Also include the test here for malformed project hierarchy."

	parentProject == self ifTrue: [^ true].
	parentProject == nil ifTrue: [self error: 'No project should have a nil parent'].
	^ false! !

!Project methodsFor: 'accessing' stamp: 'tk 6/26/1998 22:17'!
labelString
	^ changeSet name! !

!Project methodsFor: 'accessing' stamp: 'mir 6/7/2001 16:18'!
lastDirectory: aDirectoryOrNil
	lastDirectory _ aDirectoryOrNil! !

!Project methodsFor: 'accessing' stamp: 'RAA 9/28/2000 18:33'!
lastSavedAtSeconds

	^lastSavedAtSeconds! !

!Project methodsFor: 'accessing' stamp: 'di 7/19/1999 15:06'!
name
	changeSet == nil ifTrue: [^ 'no name'].
	^ changeSet name! !

!Project methodsFor: 'accessing' stamp: 'jla 5/28/2001 20:01'!
nameAdjustedForDepth
	"Answer the name of the project, prepended with spaces reflecting the receiver's depth from the top project"
	"	Project current nameAdjustedForDepth	"

	| stream |
	stream _ WriteStream on: String new.
	self depth timesRepeat: 
	  [2 timesRepeat: [stream nextPut: $ ]].
	stream nextPutAll: self name.
	^ stream contents! !

!Project methodsFor: 'accessing' stamp: 'sw 2/15/1999 12:12'!
nextProject
	^ nextProject
! !

!Project methodsFor: 'accessing' stamp: 'di 3/6/98 10:22'!
parent
	^ parentProject! !

!Project methodsFor: 'accessing' stamp: 'jm 5/20/1998 23:31'!
previousProject
	^ previousProject
! !

!Project methodsFor: 'accessing'!
projectChangeSet
	^ changeSet! !

!Project methodsFor: 'accessing'!
renameTo: newName
	| oldBase |
	newName = self name
		ifFalse: [
			oldBase _ self resourceDirectoryName.
			version _ nil.
			self resourceManager adjustToRename: self resourceDirectoryName from: oldBase.
			self changeSet name: newName.
			].! !

!Project methodsFor: 'accessing' stamp: 'di 4/14/1999 13:59'!
setParent: newParent

	parentProject _ newParent.
	nextProject _ previousProject _ nil.! !

!Project methodsFor: 'accessing' stamp: 'RAA 5/10/2001 14:57'!
setThumbnail: aForm

	self flag: #bob.		"no longer used??"
	thumbnail _ aForm! !

!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:06'!
setViewSize: aPoint
	viewSize _ aPoint! !

!Project methodsFor: 'accessing' stamp: 'mir 6/26/2001 17:09'!
storeNewPrimaryURL: aURLString
	| oldResourceUrl |
	oldResourceUrl _ self resourceUrl.
	urlList isEmptyOrNil ifTrue: [urlList _ Array new: 1].
	urlList at: 1 put: aURLString.
	self lastDirectory: nil.
	self resourceManager adjustToNewServer: self resourceUrl from: oldResourceUrl
! !

!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:07'!
thumbnail
	^ thumbnail! !

!Project methodsFor: 'accessing' stamp: 'tk 4/5/2000 13:57'!
urlList
	^ urlList! !

!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:06'!
viewSize
	^ viewSize! !

!Project methodsFor: 'accessing' stamp: 'jla 5/28/2001 21:51'!
withChildrenDo: aBlock
	"Evaluate the block first with the receiver as argument, then, recursively and depth first, with each of the receiver's children as argument"
	
	aBlock value: self.
	self children do: [:p | 
		p withChildrenDo:
			[:c | aBlock value: c]]! !

!Project methodsFor: 'accessing'!
world
	^ world! !


!Project methodsFor: 'active process' stamp: 'dgd 4/4/2006 16:41'!
depth
	"Return the depth of this project from the top.
	 topProject = 0, next = 1, etc."
	"Project current depth."

	| depth topProject project |
	depth := 0.
	topProject := Project topProject.
	project := self.
	
	[project ~= topProject and:[project notNil]]
		whileTrue:
			[project := project parent.
			depth := depth + 1].
	^ depth! !


!Project methodsFor: 'displaying' stamp: 'RAA 10/6/2000 15:57'!
createViewIfAppropriate

	ProjectViewOpenNotification signal ifTrue: [
		Preferences projectViewsInWindows ifTrue: [
			(ProjectViewMorph newProjectViewInAWindowFor: self) openInWorld
		] ifFalse: [
			(ProjectViewMorph on: self) openInWorld		"but where??"
		].
	].
! !

!Project methodsFor: 'displaying' stamp: 'ar 5/28/2000 19:43'!
displayZoom: entering
	"Show the project transition when entering a new project"
	| newDisplay vanishingPoint |
	"Play the flash transition if any."
	self projectParameters at: #flashTransition ifPresent:[:dict|
		dict at: CurrentProject ifPresent:[:player| ^player playProjectTransitionFrom: CurrentProject to: self entering: entering]].
	"Show animated zoom to new display"
	newDisplay _ self imageForm.
	entering
		ifTrue: [vanishingPoint _ Sensor cursorPoint]
		ifFalse: [vanishingPoint _ self viewLocFor: CurrentProject].
	Display zoomIn: entering orOutTo: newDisplay at: 0@0
			vanishingPoint: vanishingPoint.! !

!Project methodsFor: 'displaying' stamp: 'ar 6/2/1999 01:58'!
imageForm
	^self imageFormOfSize: Display extent
		depth: (displayDepth ifNil:[Display depth])! !

!Project methodsFor: 'displaying' stamp: 'ar 9/1/2000 14:24'!
imageFormOfSize: extentPoint depth: d
	| newDisplay |
	newDisplay _ DisplayScreen extent: extentPoint depth: d.
	Display replacedBy: newDisplay do:[
		world isMorph 
			ifTrue:[Display getCanvas fullDrawMorph: world] "Morphic"
			ifFalse:[world restore]. "MVC"
	].
	^newDisplay! !

!Project methodsFor: 'displaying' stamp: 'sw 1/12/2000 18:44'!
showZoom
	"Decide if user wants a zoom transition, and if there is enough memory to do it."

	^ Preferences projectZoom and:
		"Only show zoom if there is room for both displays plus a megabyte"
		[Smalltalk garbageCollectMost > 
						(Display boundingBox area*displayDepth //8+1000000)]! !


!Project methodsFor: 'file in/out' stamp: 'RAA 5/10/2001 12:21'!
armsLengthCommand: aCommand withDescription: aString
	| pvm tempProject foolingForm tempCanvas bbox crossHatchColor stride |
	"Set things up so that this aCommand is sent to self as a message
after jumping to the parentProject.  For things that can't be executed
while in this project, such as saveAs, loadFromServer, storeOnServer.  See
ProjectViewMorph step."

	self isMorphic ifTrue: [
		world borderWidth: 0.	"get rid of the silly default border"
		tempProject _ Project newMorphic.
		foolingForm _ world imageForm.		"make them think they never left"
		tempCanvas _ foolingForm getCanvas.
		bbox _ foolingForm boundingBox.
		crossHatchColor _ Color yellow alpha: 0.3.
		stride _ 20.
		10 to: bbox width by: stride do: [ :x |
			tempCanvas fillRectangle: (x@0 extent: 1@bbox height) fillStyle: crossHatchColor.
		].
		10 to: bbox height by: stride do: [ :y |
			tempCanvas fillRectangle: (0@y extent: bbox width@1) fillStyle: crossHatchColor.
		].

		tempProject world color: (InfiniteForm with: foolingForm).
		tempProject projectParameters 
			at: #armsLengthCmd 
			put: (
				DoCommandOnceMorph new
					addText: aString;
					actionBlock: [
						self doArmsLengthCommand: aCommand.
					] fixTemps
			).
		tempProject projectParameters 
			at: #deleteWhenEnteringNewProject 
			put: true.
		tempProject enter.
	] ifFalse: [
		parentProject ifNil: [^ self inform: 'The top project can''t do that'].
		pvm _ parentProject findProjectView: self.
		pvm armsLengthCommand: {self. aCommand}.
		self exit.
	].
! !

!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:25'!
assureIntegerVersion
	"For converting the project versions"
	self currentVersionNumber. "Does it for us"! !

!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:06'!
bumpVersion: versionNumber
	"Make a new version after the previous version number"
	versionNumber ifNil:[^0].
	^versionNumber + 1! !

!Project methodsFor: 'file in/out' stamp: 'ar 5/30/2001 23:34'!
compressFilesIn: tempDir to: localName in: localDirectory resources: collector
	"Compress all the files in tempDir making up a zip file in localDirectory named localName"
	| archive entry urlMap archiveName |
	urlMap _ Dictionary new.
	collector locatorsDo:[:loc|
		"map local file names to urls"
		urlMap at: (tempDir localNameFor: loc localFileName) put: loc urlString.
		ResourceManager cacheResource: loc urlString inArchive: localName].
	archive _ ZipArchive new.
	tempDir fileNames do:[:fn|
		archiveName _ urlMap at: fn ifAbsent:[fn].
		entry _ archive addFile: (tempDir fullNameFor: fn) as: archiveName.
		entry desiredCompressionMethod: ZipArchive compressionStored.
	].
	archive writeToFileNamed: (localDirectory fullNameFor: localName).
	archive close.
	tempDir fileNames do:[:fn|
		tempDir deleteFileNamed: fn ifAbsent:[]].
	localDirectory deleteDirectory: tempDir localName.! !

!Project methodsFor: 'file in/out' stamp: 'RAA 6/3/2000 10:25'!
couldBeSwappedOut

	self flag: #bob.		"need a better test in multi-project world"
	^self isCurrentProject not! !

!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:25'!
currentVersionNumber

	version ifNil: [^0].
	version isInteger ifTrue:[^version].
	version _ Base64MimeConverter decodeInteger: version unescapePercents.
	^version! !

!Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:57'!
decideAboutCreatingBlank: otherProjectName

	| resp |

	"20 Oct - just do it"
	true "version isNil" ifFalse: [	"if saved, then maybe don't create"
		resp _ (UIManager default chooseFrom: #('Yes, make it up' 'No, skip it') 
			title: ('I cannot locate the project\',
				otherProjectName,
				'\Would you like me to create a new project\with that name?'
			) withCRs).
		resp = 1 ifFalse: [^ nil]
	].
	^Project openBlankProjectNamed: otherProjectName! !

!Project methodsFor: 'file in/out' stamp: 'tak 6/12/2005 14:56'!
doArmsLengthCommand: aCommand

	"We are no longer the active project, so do it"

	[self perform: aCommand]
		ensure: [self enter: #specialReturn.	"re-enter me and forget the temp project"]

! !

!Project methodsFor: 'file in/out' stamp: 'mir 6/25/2001 10:50'!
downloadUrl
	"^(self primaryServerIfNil: [^'']) downloadUrl"
	^lastDirectory
		ifNil: [(self primaryServerIfNil: [^'']) downloadUrl]
		ifNotNil: [lastDirectory downloadUrl]! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/26/2000 14:12'!
ensureChangeSetNameUnique

	| myName |

	myName _ self name.
	Project allProjects do: [:pp | 
		pp == self ifFalse: [
			(pp name = myName and: [pp projectChangeSet ~~ changeSet]) ifTrue: [
				(pp parameterAt: #loadingNewerVersion ifAbsent: [false]) ifTrue: [
					pp projectParameters at: #loadingNewerVersion put: false.
				] ifFalse: [
					changeSet ifNil: [^ changeSet _ ChangeSet new].
					^changeSet name: (ChangeSet uniqueNameLike: myName)
				].
			]
		]
	]
! !

!Project methodsFor: 'file in/out' stamp: 'dgd 9/21/2003 17:41'!
exportSegmentFileName: aFileName directory: aDirectory

	| exportChangeSet |

	"An experimental version to fileout a changeSet first so that a project can contain its own classes"

	"Store my project out on the disk as an *exported* ImageSegment.  Put all outPointers in a form that can be resolved in the target image.  Name it <project name>.extSeg.
	Player classes are included automatically."

	exportChangeSet _ nil.
	(changeSet notNil and: [changeSet isEmpty not]) ifTrue: [
		(self confirm: 
'Would you like to include all the changes in the change set
as part of this publishing operation?' translated) ifTrue: [
			exportChangeSet _ changeSet
		].
	].
	^ self 
		exportSegmentWithChangeSet: exportChangeSet
		fileName: aFileName 
		directory: aDirectory
! !

!Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:58'!
exportSegmentWithCatagories: catList classes: classList fileName: aFileName directory: aDirectory
	"Store my project out on the disk as an *exported* ImageSegment.  All outPointers will be in a form that can be resolved in the target image.  Name it <project name>.extSeg.  What do we do about subProjects, especially if they are out as local image segments?  Force them to come in?
	Player classes are included automatically."

	| is str ans revertSeg roots holder |
self halt.  "unused"
	"world == World ifTrue: [^ false]."
		"self inform: 'Can''t send the current world out'."
	world isMorph ifFalse: [
		self projectParameters at: #isMVC put: true.
		^ false].	"Only Morphic projects for now"
	world ifNil: [^ false].  world presenter ifNil: [^ false].

	Utilities emptyScrapsBook.
	world currentHand pasteBuffer: nil.	  "don't write the paste buffer."
	world currentHand mouseOverHandler initialize.	  "forget about any references here"
		"Display checkCurrentHandForObjectToPaste."
	Command initialize.
	world clearCommandHistory.
	world fullReleaseCachedState; releaseViewers. 
	world cleanseStepList.
	world localFlapTabs size = world flapTabs size ifFalse: [
		self error: 'Still holding onto Global flaps'].
	world releaseSqueakPages.
	ScriptEditorMorph writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false]).
	holder _ Project allProjects.	"force them in to outPointers, where DiskProxys are made"

	"Just export me, not my previous version"
	revertSeg _ self projectParameters at: #revertToMe ifAbsent: [nil].
	self projectParameters removeKey: #revertToMe ifAbsent: [].

	roots _ OrderedCollection new.
	roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail.
	roots add: world activeHand; addAll: classList; addAll: (classList collect: [:cls | cls class]).

	roots _ roots reject: [ :x | x isNil].	"early saves may not have active hand or thumbnail"

	catList do: [:sysCat | 
		(SystemOrganization listAtCategoryNamed: sysCat asSymbol) do: [:symb |
			roots add: (Smalltalk at: symb); add: (Smalltalk at: symb) class]].

	is _ ImageSegment new copySmartRootsExport: roots asArray.
		"old way was (is _ ImageSegment new copyFromRootsForExport: roots asArray)"

	is state = #tooBig ifTrue: [^ false].

	str _ ''.
	"considered legal to save a project that has never been entered"
	(is outPointers includes: world) ifTrue: [
		str _ str, '\Project''s own world is not in the segment.' withCRs].
	str isEmpty ifFalse: [
		ans _ (UIManager default
				 chooseFrom: #('Do not write file' 'Write file anyway' 'Debug')
				 title: str).
		ans = 1 ifTrue: [
			revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
			^ false].
		ans = 3 ifTrue: [self halt: 'Segment not written']].

	is writeForExportWithSources: aFileName inDirectory: aDirectory.
	revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
	holder.
	world flapTabs do: [:ft | 
			(ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
	is arrayOfRoots do: [:obj |
		obj class == ScriptEditorMorph ifTrue: [obj unhibernate]].
	^ true
! !

!Project methodsFor: 'file in/out' stamp: 'yo 11/29/2005 20:13'!
exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName
directory: aDirectory
	"Store my project out on the disk as an *exported*
ImageSegment.  All outPointers will be in a form that can be resolved
in the target image.  Name it <project name>.extSeg.  Whatdo we do
about subProjects, especially if they are out as local image
segments?  Force them to come in?
	Player classes are included automatically."

	| is str ans revertSeg roots holder collector fd mgr stacks |

	"Files out a changeSet first, so that a project can contain
its own classes"
world isMorph ifFalse: [
	self projectParameters at: #isMVC put: true.
	^ false].	"Only Morphic projects for now"
world ifNil: [^ false].  world presenter ifNil: [^ false].

Utilities emptyScrapsBook.
world currentHand pasteBuffer: nil.	  "don't write the paste buffer."
world currentHand mouseOverHandler initialize.	  "forget about any
references here"
	"Display checkCurrentHandForObjectToPaste."
Command initialize.
world clearCommandHistory.
world fullReleaseCachedState; releaseViewers.
world cleanseStepList.
world localFlapTabs size = world flapTabs size ifFalse: [
	self error: 'Still holding onto Global flaps'].
world releaseSqueakPages.
ScriptEditorMorph writingUniversalTiles: (self projectParameterAt:
#universalTiles ifAbsent: [false]).
holder _ Project allProjects.	"force them in to outPointers, where
DiskProxys are made"

"Just export me, not my previous version"
revertSeg _ self projectParameters at: #revertToMe ifAbsent: [nil].
self projectParameters removeKey: #revertToMe ifAbsent: [].

roots _ OrderedCollection new.
roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail.
roots add: world activeHand.

	"; addAll: classList; addAll: (classList collect: [:cls | cls class])"

roots _ roots reject: [ :x | x isNil].	"early saves may not have
active hand or thumbnail"

	fd _ aDirectory directoryNamed: self resourceDirectoryName.
	fd assureExistence.
	"Clean up resource references before writing out"
	mgr _ self resourceManager.
	self resourceManager: nil.
	ResourceCollector current: ResourceCollector new.
	ResourceCollector current localDirectory: fd.
	ResourceCollector current baseUrl: self resourceUrl.
	ResourceCollector current initializeFrom: mgr.
	ProgressNotification signal: '2:findingResources' extra:
'(collecting resources...)' translated.
	"Must activate old world because this is run at #armsLength.
	Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent
	will not be captured correctly if referenced from blocks or user code."
	world becomeActiveDuring:[
		is _ ImageSegment new copySmartRootsExport: roots asArray.
		"old way was (is _ ImageSegment new
copyFromRootsForExport: roots asArray)"
	].
	self resourceManager: mgr.
	collector _ ResourceCollector current.
	ResourceCollector current: nil.
	ProgressNotification signal: '2:foundResources' extra: ''.
	is state = #tooBig ifTrue: [
		collector replaceAll.
		^ false].

str _ ''.
"considered legal to save a project that has never been entered"
(is outPointers includes: world) ifTrue: [
	str _ str, '\Project''s own world is not in the segment.' translated withCRs].
str isEmpty ifFalse: [
	ans _ (PopUpMenu labels: 'Do not write file
Write file anyway
Debug' translated) startUpWithCaption: str.
	ans = 1 ifTrue: [
		revertSeg ifNotNil: [projectParameters at:
#revertToMe put: revertSeg].
		collector replaceAll.
		^ false].
	ans = 3 ifTrue: [
		collector replaceAll.
		self halt: 'Segment not written' translated]].
	stacks _ is findStacks.

	is
		writeForExportWithSources: aFileName
		inDirectory: fd
		changeSet: aChangeSetOrNil.
	SecurityManager default signFile: aFileName directory: fd.
	"Compress all files and update check sums"
	collector forgetObsolete.
	self storeResourceList: collector in: fd.
	self storeHtmlPageIn: fd.
	self storeManifestFileIn: fd.
	self writeStackText: stacks in: fd registerIn: collector.
	"local proj.005.myStack.t"
	self compressFilesIn: fd to: aFileName in: aDirectory
resources: collector.
			"also deletes the resource directory"
	"Now update everything that we know about"
	mgr updateResourcesFrom: collector.

revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
holder.

collector replaceAll.

world flapTabs do: [:ft |
		(ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
is arrayOfRoots do: [:obj |
	obj class == ScriptEditorMorph ifTrue: [obj unhibernate]].
^ true
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 7/15/2000 19:23'!
findAFolderToLoadProjectFrom

	self couldOpenInMorphic ifTrue: [
		^FileList2 modalFolderSelectorForProjectLoad
	] ifFalse: [
		^PluggableFileList getFolderDialog openLabel: 'Select a folder on a server:'
	]! !

!Project methodsFor: 'file in/out' stamp: 'RAA 6/30/2000 11:14'!
findAFolderToStoreProjectIn

	"Alan wants something prettier with a default"

	self couldOpenInMorphic ifTrue: [
		^FileList2 modalFolderSelectorForProject: self
	] ifFalse: [
		^PluggableFileList getFolderDialog openLabel: 'Select a folder on a server:'
	]! !

!Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:41'!
fromMyServerLoad: otherProjectName
	| pair pr dirToUse |
	"If a newer version of me is on the server, load it."

	(pr _ Project named: otherProjectName) ifNotNil: ["it appeared"
		^ pr enter
	].
	dirToUse _ self primaryServerIfNil: [
		lastDirectory ifNil: [
			self inform: 'Current project does not know a server either.'.
			^nil].
		lastDirectory].

	pair _ self class mostRecent: otherProjectName onServer: dirToUse.
	pair first ifNil: [^self decideAboutCreatingBlank: otherProjectName].	"nothing to load"
	^ProjectLoading
		installRemoteNamed: pair first
		from: dirToUse
		named: otherProjectName
		in: self

! !

!Project methodsFor: 'file in/out' stamp: 'RAA 9/21/2000 15:30'!
hasBadNameForStoring

	^Project isBadNameForStoring: self name
! !

!Project methodsFor: 'file in/out' stamp: 'yo 12/14/2004 18:54'!
htmlPagePrototype
	"Return the HTML page prototype"
^'<html>
<head>
<title>Squeak Project</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
</head>

<body bgcolor="#FFFFFF">
<EMBED 
	type="application/x-squeak-source"
	ALIGN="CENTER"
	WIDTH="$$WIDTH$$"
	HEIGHT="$$HEIGHT$$"
	src="$$PROJECT$$"
	pluginspage="http://www.squeakland.org/plugin/detect/detectinstaller.html">

</EMBED>

</body>
</html>
'! !

!Project methodsFor: 'file in/out' stamp: 'RAA 5/17/2000 18:52'!
loadFromServer
	
	^self loadFromServer: false! !

!Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:51'!
loadFromServer: newerAutomatically
	"If a newer version of me is on the server, load it."
	| pair resp server |
	self assureIntegerVersion.

	self isCurrentProject ifTrue: ["exit, then do the command"
		^ self armsLengthCommand: #loadFromServer withDescription: 'Loading' translated
	].
	server _ self tryToFindAServerWithMe ifNil: [^ nil].
	pair _ self class mostRecent: self name onServer: server.
	pair first ifNil: [^ self inform: ('can''t find file on server for {1}' translated format: {self name})].
	self currentVersionNumber > pair second ifTrue: [
		^ self inform: ('That server has an older version of the project.' translated)].
	version = (Project parseProjectFileName: pair first) second ifTrue: [
		resp _ (UIManager default chooseFrom: 
				(Array with: 'Reload anyway' translated 
						with: 'Cancel' translated withCRs) 
				title:  'The only changes are the ones you made here.' translated).
		resp ~= 1 ifTrue: [^ nil]
	] ifFalse: [
		newerAutomatically ifFalse: [
			resp _ (UIManager default 
						chooseFrom: #('Load it' 'Cancel') 
						title:  'A newer version exists on the server.').
			resp ~= 1 ifTrue: [^ nil]
		].
	].

	"let's avoid renaming the loaded change set since it will be replacing ours"
	self projectParameters at: #loadingNewerVersion put: true.

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project loading';
		withProgressDo: [
			ProjectLoading
				installRemoteNamed: pair first
				from: server
				named: self name
				in: parentProject
		]
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/26/2000 16:58'!
objectForDataStream: refStrm
	| uu dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	"Use a copy with no parent, previous or next to reduce extra stuff copied"
	refStrm project == self ifTrue: [^ self copy setParent: nil].

	dp _ (uu _ self url) size > 0 ifTrue: [
		DiskProxy global: #Project selector: #namedUrl: args: {uu}.
	] ifFalse: [
		DiskProxy global: #Project selector: #named: args: {self name}
	].
	refStrm replace: self with: dp.
	^ dp
! !

!Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:39'!
primaryServer
	"Return my primary server, that is the one I was downloaded from or are about to be stored on."
	^self primaryServerIfNil: [nil]! !

!Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:39'!
primaryServerIfNil: aBlock
	"Return my primary server, that is the one I was downloaded from or are about to be stored on. If none is set execute the exception block"
	| serverList | 
	serverList _ self serverList.
	^serverList isEmptyOrNil
		ifTrue: [aBlock value]
		ifFalse: [serverList first]! !

!Project methodsFor: 'file in/out' stamp: 'ar 2/27/2001 13:44'!
projectExtension
	^self class projectExtension! !

!Project methodsFor: 'file in/out' stamp: 'tk 7/28/2005 04:58'!
restoreReferences
	| key newKey extName |
	"I just came in from an exported segment.  Take all my players that were in References, and reinstall them."

	"*** Note that (world valueOfProperty: #References) is temporary during loading and is not the same as the global References dictionary (in Smalltalk)."
	(world valueOfProperty: #References ifAbsent: [#()]) do: [:assoc | "just came in"
		key _ assoc key.
		(References includesKey: key) 
			ifTrue: ["must rename" 
				extName _ assoc value externalName.	"what user sees"
				(References at: key) == assoc value ifTrue: [
					self error: 'why is this object already present?'].
				newKey _ assoc value uniqueNameForReference.
				References removeKey: newKey.
				assoc key: newKey.
				References add: assoc.	"use the known association"

				Preferences universalTiles
					ifTrue: [assoc value renameTo: newKey] 	"change names in scripts"
					ifFalse: [(assoc value renameInternal: extName)	"keep externalName the same"
								ifNil: [assoc value renameTo: newKey]].
									"rename Project itself.  Ignore others"
				]
			ifFalse: [References add: assoc]].
	world removeProperty: #References.! !

!Project methodsFor: 'file in/out' stamp: 'tk 10/26/1999 14:23'!
revert
	| |
	"Exit this project and do not save it.  Warn user unless in dangerous projectRevertNoAsk mode.  Exit to the parent project.  Do a revert on a clone of the segment, to allow later reverts."

	projectParameters ifNil: [^ self inform: 'nothing to revert to'].
	parentProject enter: false revert: true saveForRevert: false.
	"does not return!!"
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/13/2000 18:03'!
saveAs
	"Forget where stored before, and store.  Will ask user where."

	self forgetExistingURL.
	self storeOnServer.! !

!Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 19:50'!
saveForRevert
	"Exit to the parent project.  Do a GC.  Save the project in a segment.  Record the ImageSegment object as the revertToMe in Project parameters"

	self isTopProject ifTrue: [^ self inform: 'Can''t exit the top project' translated].
	parentProject enter: false revert: false saveForRevert: true.
	"does not return!!"

! !

!Project methodsFor: 'file in/out' stamp: 'mir 8/10/2001 17:49'!
serverList
	| servers server |
	"Take my list of server URLs and return a list of ServerDirectories to write on."

	urlList isEmptyOrNil ifTrue: [^ nil].
	servers _ OrderedCollection new.
	urlList do: [:url |
		server _ ServerDirectory serverForURL: url.
		server ifNotNil: [servers add: server].
		server _ ServerDirectory serverForURL: url asUrl downloadUrl.
		server ifNotNil: [servers add: server]].
	^servers isEmpty
		ifTrue: [nil]
		ifFalse: [servers]! !

!Project methodsFor: 'file in/out' stamp: 'RAA 2/19/2001 07:37'!
squeakletDirectory

	^self class squeakletDirectory! !

!Project methodsFor: 'file in/out' stamp: 'yo 12/14/2004 18:18'!
storeAttributeKey: key value: value on: aStream

	(key includes: $:) ifTrue: [self error: 'key should not contain :'].
	aStream nextPutAll: key.
	aStream nextPutAll: ': '.
	aStream nextPutAll: value.
	aStream cr.
! !

!Project methodsFor: 'file in/out' stamp: 'KR 12/16/2005 11:07'!
storeAttributesOn: aStream

	| details |
	self storeAttributeKey: 'Squeak-Version' value: SystemVersion current version on: aStream.
	self storeAttributeKey: 'Squeak-LatestUpdate' value: SystemVersion current highestUpdate printString on: aStream.
	self storeAttributeKey: 'File-Name-Encoding' value: LanguageEnvironment defaultFileNameConverter class encodingNames first on: aStream.

	details _ self world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new].
	details associationsDo: [:assoc |
		self storeAttributeKey: assoc key asString value: assoc value asString on: aStream.].
! !

!Project methodsFor: 'file in/out' stamp: 'tk 8/21/1999 07:31'!
storeDataOn: aDataStream
	"Write me out.  All references to other projects are weak references.  They only go out if they are written for another reason."
	| cntInstVars cntIndexedVars localInstVars offset |

	cntInstVars _ self class instSize.
	cntIndexedVars _ self basicSize.
	localInstVars _ Project instVarNames.
	offset _ Project superclass instSize.
	aDataStream
		beginInstance: self class
		size: cntInstVars + cntIndexedVars.
	1 to: cntInstVars do:
		[:ii | 
		(ii between: offset+1 and: offset + localInstVars size) 
			ifTrue: [(#('parentProject' 'previousProject' 'nextProject') includes: 
				(localInstVars at: ii-offset)) 
					ifTrue: [aDataStream nextPutWeak: (self instVarAt: ii)]
								"owner only written if in our tree"
					ifFalse: [aDataStream nextPut: (self instVarAt: ii)]]
			ifFalse: [aDataStream nextPut: (self instVarAt: ii)]].

	1 to: cntIndexedVars do:
		[:i | aDataStream nextPut: (self basicAt: i)]! !

!Project methodsFor: 'file in/out' stamp: 'yo 12/14/2004 19:01'!
storeHtmlPageIn: aFileDirectory
	"Prepare the HTML wrapper for the current project"
	| file page |
	file _ aFileDirectory forceNewFileNamed: (self name, FileDirectory dot,'html').
	file ifNil: [^self].
	file converter: UTF8TextConverter new.
	page _ self htmlPagePrototype.
	page _ page copyReplaceAll: '$$PROJECT$$' with: self versionedFileName.
	page _ page copyReplaceAll: '$$WIDTH$$' with: world bounds width printString.
	page _ page copyReplaceAll: '$$HEIGHT$$' with: world bounds height printString.
	page _ page copyReplaceAll: String cr with: String lf. "not sure if necessary..."
	file nextPutAll: page.
	file close.! !

!Project methodsFor: 'file in/out' stamp: 'KR 12/16/2005 10:07'!
storeManifestFileIn: aFileDirectory

	| file |
	file _ aFileDirectory forceNewFileNamed: (self name, FileDirectory dot,'manifest').
	file ifNil: [^ self].
	file converter: UTF8TextConverter new.
	self storeAttributesOn: file.
	file close.
! !

!Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 17:45'!
storeOnServer

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	world setProperty: #optimumExtentFromAuthor toValue: world extent.
	self validateProjectNameIfOK: [
		self isCurrentProject ifTrue: ["exit, then do the command"
			^ self 
				armsLengthCommand: #storeOnServerAssumingNameValid
				withDescription: 'Publishing' translated
		].
		self storeOnServerWithProgressInfo.
	].! !

!Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 17:45'!
storeOnServerAssumingNameValid

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	world setProperty: #optimumExtentFromAuthor toValue: world extent.
	self isCurrentProject ifTrue: ["exit, then do the command"
		^ self 
			armsLengthCommand: #storeOnServerAssumingNameValid
			withDescription: 'Publishing' translated
	].
	self storeOnServerWithProgressInfo.
! !

!Project methodsFor: 'file in/out' stamp: 'rbb 3/1/2005 11:08'!
storeOnServerInnards
	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	| resp newName primaryServerDirectory serverVersionPair localDirectory localVersionPair myVersionNumber warning maxNumber suppliedPassword oldResourceUrl |
	self assureIntegerVersion.

	"Find out what version"
	primaryServerDirectory := self primaryServerIfNil: [
		(primaryServerDirectory := self findAFolderToStoreProjectIn) ifNil: [^self].
		oldResourceUrl := self resourceUrl.
		primaryServerDirectory == #localOnly ifTrue: [
			self storeNewPrimaryURL: FileDirectory default url.
			nil
		] ifFalse: [
			self storeNewPrimaryURL: primaryServerDirectory downloadUrl.
			primaryServerDirectory
		].
	].

	localDirectory := self squeakletDirectory.
	serverVersionPair := self class mostRecent: self name onServer: primaryServerDirectory.
	localVersionPair := self class mostRecent: self name onServer: localDirectory.
	maxNumber := myVersionNumber := self currentVersionNumber.

	ProgressNotification signal: '2:versionsDetected'.

	warning := ''.
	myVersionNumber < serverVersionPair second ifTrue: [
		warning := warning,'\There are newer version(s) on the server' translated.
		maxNumber := maxNumber max: serverVersionPair second.
	].
	myVersionNumber < localVersionPair second ifTrue: [
		warning := warning,'\There are newer version(s) in the local directory' translated.
		maxNumber := maxNumber max: localVersionPair second.
	].
	"8 Nov 2000 - only check on the first attempt to publish"
	myVersionNumber = 0 ifTrue: [
		warning isEmpty ifFalse: [
			myVersionNumber = 0 ifTrue: [
				warning := warning,'\THIS PROJECT HAS NEVER BEEN SAVED' translated.
			].
			warning := 'WARNING' translated, '\Project: ' translated, self name,warning.
			resp := (UIManager default 
					chooseFrom: (Array with: 'Store anyway' translated 
										with: 'Cancel' translated)
  					title: (warning, '\Please cancel, rename this project, and see what is there.' translated) withCRs).
				resp ~= 1 ifTrue: [^ nil]
		].
	].
	version := self bumpVersion: maxNumber.

	oldResourceUrl
		ifNotNil: [self resourceManager adjustToNewServer: self resourceUrl from: oldResourceUrl].

	"write locally - now zipped automatically"
	newName := self versionedFileName.
	lastSavedAtSeconds := Time totalSeconds.
	self exportSegmentFileName: newName directory: localDirectory.
	(localDirectory readOnlyFileNamed: newName) setFileTypeToObject; close.

	ProgressNotification signal: '4:localSaveComplete'.	"3 is deep in export logic"

	primaryServerDirectory ifNotNil: [
		suppliedPassword := ''.
		Preferences passwordsOnPublish ifTrue: [
			suppliedPassword := UIManager default requestPassword: 'Project password' translated
		].
		[
		primaryServerDirectory
			writeProject: self
			inFileNamed: newName asFileName
			fromDirectory: localDirectory.
		] on: ProjectPasswordNotification do: [ :ex |
			ex resume: (suppliedPassword ifNil: [''])
		].
	].
	ProgressNotification signal: '9999 save complete'.

	"Later, store with same name on secondary servers.  Still can be race conditions.  All machines will go through the server list in the same order."
	"2 to: servers size do: [:aServer | aServer putFile: local named: newName]."
! !

!Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 17:45'!
storeOnServerShowProgressOn: aMorphOrNil forgetURL: forget

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	world setProperty: #optimumExtentFromAuthor toValue: world extent.
	self validateProjectNameIfOK: [
		self isCurrentProject ifTrue: ["exit, then do the command"
			forget
				ifTrue: [self forgetExistingURL]
				ifFalse: [urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList copy]].
			^self
				armsLengthCommand: #storeOnServerAssumingNameValid
				withDescription: 'Publishing' translated
		].
		self storeOnServerWithProgressInfoOn: aMorphOrNil.
	] fixTemps.
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 5/23/2000 12:56'!
storeOnServerWithProgressInfo

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project storing';
		withProgressDo: [self storeOnServerInnards]
	! !

!Project methodsFor: 'file in/out' stamp: 'RAA 6/30/2000 14:10'!
storeOnServerWithProgressInfoOn: aMorphOrNil

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	ComplexProgressIndicator new 
		targetMorph: aMorphOrNil;
		historyCategory: 'project storing';
		withProgressDo: [self storeOnServerInnards]
	! !

!Project methodsFor: 'file in/out' stamp: 'ar 3/17/2001 23:57'!
storeSegment
	"Store my project out on the disk as an ImageSegment.  Keep the outPointers in memory.  Name it <project name>.seg.  *** Caller must be holding (Project alInstances) to keep subprojects from going out. ***"

| is sizeHint |
(World == world) ifTrue: [^ false]. 
	"self inform: 'Can''t send the current world out'."
world isInMemory ifFalse: [^ false].  "already done"
world isMorph ifFalse: [
	self projectParameters at: #isMVC put: true.
	^ false].	"Only Morphic projects for now"
world ifNil: [^ false].  world presenter ifNil: [^ false].

Utilities emptyScrapsBook.
World checkCurrentHandForObjectToPaste.
world releaseSqueakPages.
sizeHint _ self projectParameters at: #segmentSize ifAbsent: [0].

is _ ImageSegment new copyFromRootsLocalFileFor: 
			(Array with: world presenter with: world)	"world, and all Players"
		 sizeHint: sizeHint.

is state = #tooBig ifTrue: [^ false].
is segment size < 2000 ifTrue: ["debugging" 
	Transcript show: self name, ' only ', is segment size printString, 
		'bytes in Segment.'; cr].
self projectParameters at: #segmentSize put: is segment size.
is extract; writeToFile: self name.
^ true
! !

!Project methodsFor: 'file in/out' stamp: 'md 10/22/2003 16:27'!
storeSegmentNoFile
	"For testing.  Make an ImageSegment.  Keep the outPointers in memory.  Also useful if you want to enumerate the objects in the segment afterwards (allObjectsDo:)"

| is str |
(World == world) ifTrue: [^ self].		" inform: 'Can''t send the current world out'."
world isInMemory ifFalse: [^ self].  "already done"
world isMorph ifFalse: [
	self projectParameters at: #isMVC put: true.
	^ self].	"Only Morphic projects for now"
world ifNil: [^ self].  world presenter ifNil: [^ self].

"Do this on project enter"
World flapTabs do: [:ft | ft referent adaptToWorld: World].
	"Hack to keep the Menu flap from pointing at my project"
"Preferences setPreference: #useGlobalFlaps toValue: false."
"Utilities globalFlapTabsIfAny do:
	[:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: false].
Utilities clobberFlapTabList.	"
"project world deleteAllFlapArtifacts."
"self currentWorld deleteAllFlapArtifacts.	"
Utilities emptyScrapsBook.
World checkCurrentHandForObjectToPaste2.

is _ ImageSegment new copyFromRootsLocalFileFor: 
		(Array with: world presenter with: world)	"world, and all Players"
	sizeHint: 0.

is segment size < 800 ifTrue: ["debugging" 
	Transcript show: self name, ' did not get enough objects'; cr.  ^ Beeper beep].
false ifTrue: [
	str _ String streamContents: [:strm |
		strm nextPutAll: 'Only a tiny part of the project got into the segment'.
		strm nextPutAll: '\These are pointed to from the outside:' withCRs.
		is outPointers do: [:out |
			(out class == Presenter) | (out class == ScriptEditorMorph) ifTrue: [
				strm cr. out printOn: strm.
				self systemNavigation
					browseAllObjectReferencesTo: out
					except: (Array with: is outPointers)
					ifNone: [:obj | ]].
			(is arrayOfRoots includes: out class) ifTrue: [strm cr. out printOn: strm.
				self systemNavigation
					browseAllObjectReferencesTo: out
					except: (Array with: is outPointers)
					ifNone: [:obj | ]]]].
	self inform: str.
	^ is inspect].

is extract.
"is instVarAt: 2 put: is segment clone."		"different memory"
! !

!Project methodsFor: 'file in/out' stamp: 'nk 7/30/2004 17:52'!
storeSomeSegment
	"Try all projects to see if any is ready to go out.  Send at most three of them.
	Previous one has to wait for a garbage collection before it can go out."

	| cnt pList start proj gain |
	cnt := 0.
	gain := 0.
	pList := Project allProjects.
	start := pList size atRandom.	"start in a random place"
	start to: pList size + start
		do: 
			[:ii | 
			proj := pList atWrap: ii.
			proj storeSegment 
				ifTrue: 
					["Yes, did send its morphs to the disk"

					gain := gain + (proj projectParameters at: #segmentSize ifAbsent: [0]).	"a guess"
					Beeper beep.
					(cnt := cnt + 1) >= 2 ifTrue: [^gain]]].
	Beeper  beep.
	^gain! !

!Project methodsFor: 'file in/out' stamp: 'md 10/22/2003 17:54'!
storeToMakeRoom
	"Write out enough projects to fulfill the space goals.
	Include the size of the project about to come in."

	| params memoryEnd goalFree cnt gain proj skip tried |
	GoalFreePercent ifNil: [GoalFreePercent _ 33].
	GoalNotMoreThan ifNil: [GoalNotMoreThan _ 20000000].
	params _ SmalltalkImage current  getVMParameters.
	memoryEnd	_ params at: 3.
"	youngSpaceEnd	_ params at: 2.
	free _ memoryEnd - youngSpaceEnd.
"
	goalFree _ GoalFreePercent asFloat / 100.0 * memoryEnd.
	goalFree _ goalFree min: GoalNotMoreThan.
	world isInMemory ifFalse: ["enough room to bring it in"
		goalFree _ goalFree + (self projectParameters at: #segmentSize ifAbsent: [0])].
	cnt _ 30.
	gain _ Smalltalk garbageCollectMost.
	"skip a random number of projects that are in memory"
	proj _ self.  skip _ 6 atRandom.
	[proj _ proj nextInstance ifNil: [Project someInstance].
		proj world isInMemory ifTrue: [skip _ skip - 1].
		skip > 0] whileTrue.
	cnt _ 0.  tried _ 0.

	[gain > goalFree] whileFalse: [
		proj _ proj nextInstance ifNil: [Project someInstance].
		proj storeSegment ifTrue: ["Yes, did send its morphs to the disk"
			gain _ gain + (proj projectParameters at: #segmentSize 
						ifAbsent: [20000]).	"a guess"
			Beeper beep.
			(cnt _ cnt + 1) > 5 ifTrue: [^ self]].	"put out 5 at most"
		(tried _ tried + 1) > 23 ifTrue: [^ self]].	"don't get stuck in a loop"! !

!Project methodsFor: 'file in/out' stamp: 'rbb 2/16/2005 17:15'!
tryToFindAServerWithMe

	| resp primaryServerDirectory |

	urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList copy].
	[self primaryServer isNil] whileTrue: [
		resp _ (UIManager default 
					chooseFrom: #('Try to find a server' 'Cancel')
					title: 'This project thinks it has never been on a server').
		resp ~= 1 ifTrue: [^ nil].
		(primaryServerDirectory _ self findAFolderToLoadProjectFrom) ifNil: [^nil].
		self storeNewPrimaryURL: primaryServerDirectory downloadUrl.
	].
	^self primaryServer
! !

!Project methodsFor: 'file in/out' stamp: 'mir 6/25/2001 10:55'!
url
	| firstURL |
	"compose my url on the server"

	urlList isEmptyOrNil ifTrue: [^''].
	firstURL _ urlList first.
	firstURL isEmpty
		ifFalse: [
			firstURL last == $/
				ifFalse: [firstURL _ firstURL, '/']].
	^ firstURL, self versionedFileName
! !

!Project methodsFor: 'file in/out' stamp: 'mir 8/8/2001 17:58'!
urlForLoading
	"compose a url that will load me in someone's browser"
	| myServer serverList myUrl downloadUrl |
	serverList _ self serverList.
	serverList isEmptyOrNil
		ifTrue: [
			urlList isEmptyOrNil ifTrue: [^nil].
			downloadUrl _ urlList first asUrl downloadUrl]
		ifFalse: [
			myServer _ serverList first.
			myUrl _ myServer altUrl.
			myUrl last == $/
				ifFalse: [myUrl _ myUrl , '/'].
			downloadUrl _ myUrl].
	^downloadUrl , (self name, FileDirectory dot,'html') encodeForHTTP
! !

!Project methodsFor: 'file in/out' stamp: 'mir 6/21/2001 15:45'!
versionForFileName
	"Project current versionForFileName"
	^self class versionForFileName: self currentVersionNumber! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/15/2000 19:10'!
versionFrom: aServerFile
	"Store the version of the file I actually came from.  My stored version was recorded before I knew the latest version number on the server!!"
	| theName serverUrl |

	self flag: #bob.		"this may become unnecessary once we get the version before writing"
	self flag: #bob.		"need to recognize swiki servers"

	serverUrl _ aServerFile directoryUrl.
	theName _ aServerFile localName.
	version _ (Project parseProjectFileName: theName) second.
	(serverUrl beginsWith: 'ftp:') ifTrue: ["update our server location"
		self storeNewPrimaryURL: serverUrl
	].
! !

!Project methodsFor: 'file in/out' stamp: 'mir 6/21/2001 15:43'!
versionedFileName
	"Project current versionedFileName"
	^String streamContents:[:s|
		s nextPutAll: self name.
		s nextPutAll: FileDirectory dot.
		s nextPutAll: self versionForFileName.
		s nextPutAll: FileDirectory dot.
		s nextPutAll: self projectExtension.
	]
! !

!Project methodsFor: 'file in/out' stamp: 'tak 6/24/2005 11:30'!
writeFileNamed: localFileName fromDirectory: localDirectory toServer: primaryServerDirectory

	| local resp gifFileName f |

	local _ localDirectory oldFileNamed: localFileName.
	resp _ primaryServerDirectory upLoadProject: local named: localFileName resourceUrl: self resourceUrl retry: false.
	local close.
	resp == true ifFalse: [
		"abandon resources that would've been stored with the project"
		self resourceManager abandonResourcesThat:
			[:loc| loc urlString beginsWith: self resourceUrl].
		self error: 'the primary server of this project seems to be down (',
							resp printString,')'. 
		^ self
	].

	gifFileName _ self name,'.gif'.
	localDirectory deleteFileNamed: gifFileName ifAbsent: [].
	local _ localDirectory fileNamed: gifFileName.
	thumbnail ifNil: [
		(thumbnail _ Form extent: 100@80) fillColor: Color orange
	] ifNotNil: [
		thumbnail unhibernate.
	].
	f _ thumbnail colorReduced.  "minimize depth"
	f depth > 8 ifTrue: [
		f _ thumbnail asFormOfDepth: 8
	].
	GIFReadWriter putForm: f onStream: local.
	local close.

	[local _ StandardFileStream readOnlyFileNamed: (localDirectory fullNameFor: gifFileName).
	(primaryServerDirectory isKindOf: FileDirectory)
		ifTrue: [primaryServerDirectory deleteFileNamed: gifFileName ifAbsent: []].
	resp _ primaryServerDirectory putFile: local named: gifFileName retry: false.
	] on: Error do: [:ex |].
	local close.

	primaryServerDirectory updateProjectInfoFor: self.
	primaryServerDirectory sleep.	"if ftp, close the connection"
! !

!Project methodsFor: 'file in/out' stamp: 'tk 6/28/2001 16:16'!
writeStackText: stacks in: resourceDirectory registerIn: aCollector
	"The user's text is very valuable.  Write an extra file with just the text.  It can be read in case the Project can't be opened." 
	"Find allText for each stack, storeOn a local file in the resources folder, with a name like myProj.005.myStack.t.  Make the names be unique."

	"get project name and version"
	| localName sn trial char ind fs resourceURL textLoc |
	resourceURL _ self resourceUrl.
	stacks do: [:stackObj |	"Construct a good file name"
		localName _ self versionedFileName allButLast: 2.	"projectName.005."
		stacks size = 1 ifFalse: ["must distinguish between stacks in the project"
			(sn _ stackObj knownName) ifNil: [
				sn _ stackObj hash printString].	"easy name, or use hash"
			localName _ localName , sn, FileDirectory dot]. 	"projectName.005.myStack."
		localName _ localName , 't'.
		"See if in use because truncates same as another, fix last char, try again"
		[trial _ resourceDirectory checkName: localName fixErrors: true.
		 trial endsWith: '.t'] whileFalse: [
				localName _ (localName allButLast: 3) , FileDirectory dot, 't'].
		[resourceDirectory fileExists: trial] whileTrue: [
			char _ trial at: (ind _ trial size - 3).
			trial at: ind put: (char asciiValue + 1) asCharacter].	"twiddle it a little"
		
		"write allText in file"
		fs _ resourceDirectory newFileNamed: trial.
		fs timeStamp; cr; nextPutAll: '''This is the text for a stack in this project.  Use only in an emergency, if the project file is ever unreadable.''.'; cr; cr.
		stackObj getAllText storeOn: fs.    fs close.
		textLoc _ (ResourceLocator new) localFileName: trial; 
			urlString: resourceURL, '/', trial.
		aCollector locatorMap at: trial "any distinct object" put: textLoc.
		].! !


!Project methodsFor: 'flaps support' stamp: 'dgd 8/31/2003 19:42'!
assureFlapIntegrity
	"Make certain that the items on the disabled-global-flap list are actually global flaps, and if not, get rid of them.  Also, old (and damaging) parameters that held references to actual disabled flaps are cleansed"

	| disabledFlapIDs currentGlobalIDs oldList |
	Smalltalk isMorphic ifTrue:
		[disabledFlapIDs _ self parameterAt: #disabledGlobalFlapIDs ifAbsent: [Set new].
		currentGlobalIDs _ Flaps globalFlapTabsIfAny collect: [:f | f flapID].
		oldList _ Project current projectParameterAt: #disabledGlobalFlaps ifAbsent: [nil].
		oldList ifNotNil:
			[disabledFlapIDs _ oldList collect: [:aFlap | aFlap flapID].
			disabledFlapIDs addAll: {'Scripting' translated. 'Stack Tools' translated. 'Painting' translated}].
		disabledFlapIDs _ disabledFlapIDs select: [:anID | currentGlobalIDs includes: anID].
		self projectParameterAt: #disabledGlobalFlapIDs put: disabledFlapIDs asSet.
		self assureNavigatorPresenceMatchesPreference].

	projectParameters ifNotNil:
		[projectParameters removeKey: #disabledGlobalFlaps ifAbsent: []]! !

!Project methodsFor: 'flaps support' stamp: 'sw 5/7/2001 12:48'!
cleanseDisabledGlobalFlapIDsList
	"Make certain that the items on the disabled-global-flap list are actually global flaps, and if not, get rid of them"

	| disabledFlapIDs currentGlobalIDs oldList |
	Smalltalk isMorphic ifTrue:
		[disabledFlapIDs _ self parameterAt: #disabledGlobalFlapIDs ifAbsent: [Set new].
		currentGlobalIDs _ Flaps globalFlapTabsIfAny collect: [:f | f flapID].
		oldList _ Project current projectParameterAt: #disabledGlobalFlaps ifAbsent: [nil].
		oldList ifNotNil:
			[disabledFlapIDs _ oldList select: [:aFlap | aFlap flapID]].
		disabledFlapIDs _ disabledFlapIDs select: [:anID | currentGlobalIDs includes: anID].
		self projectParameterAt: #disabledGlobalFlapIDs put: disabledFlapIDs].

	projectParameters ifNotNil:
		[projectParameters removeKey: #disabledGlobalFlaps ifAbsent: []].
! !

!Project methodsFor: 'flaps support' stamp: 'sw 4/29/2001 23:45'!
enableDisableGlobalFlap: aFlapTab
	"For the benefit of pre-existing which-global-flap buttons from a design now left behind."

	self flag: #toRemove.
	^ self inform: 
'Sorry, this is an obsolete menu; please
dismiss it and get a fresh menu.  Thanks.'.! !

!Project methodsFor: 'flaps support' stamp: 'sw 4/24/2001 11:03'!
flapsSuppressed
	"Answer whether flaps are suppressed in this project"

	^ self showSharedFlaps not! !

!Project methodsFor: 'flaps support' stamp: 'di 11/18/2001 14:34'!
flapsSuppressed: aBoolean
	"Make the setting of the flag that governs whether global flaps are suppressed in the project be as indicated and add or remove the actual flaps"

	self projectPreferenceFlagDictionary at: #showSharedFlaps put: aBoolean not.
	self == Project current  "Typical case"
		ifTrue:
			[Preferences setPreference: #showSharedFlaps toValue: aBoolean not]
		ifFalse:   "Anomalous case where this project is not the current one."
			[aBoolean
				ifTrue:		
					[Flaps globalFlapTabsIfAny do:
						[:aFlapTab | Flaps removeFlapTab: aFlapTab keepInList: true]]

				ifFalse:
					[Smalltalk isMorphic  ifTrue:
						[self currentWorld addGlobalFlaps]]].
	Project current assureNavigatorPresenceMatchesPreference! !

!Project methodsFor: 'flaps support' stamp: 'sw 11/6/2000 11:20'!
globalFlapEnabledString: aFlapTab
	"Answer the string to be shown in a menu to represent the status of the givne flap regarding whether it it should be shown in this project."

	^ (self isFlapEnabled: aFlapTab)
		ifTrue:
			['<on>', aFlapTab wording]
		ifFalse:
			['<off>', aFlapTab wording]! !

!Project methodsFor: 'flaps support' stamp: 'sw 4/30/2001 20:42'!
globalFlapWithIDEnabledString: aFlapID
	"Answer the string to be shown in a menu to represent the status of the given flap regarding whether it it should be shown in this project."

	| aFlapTab |
	aFlapTab _ Flaps globalFlapTabWithID: aFlapID.
	^ (self isFlapEnabled: aFlapTab)
		ifTrue:
			['<on>', aFlapTab wording]
		ifFalse:
			['<off>', aFlapTab wording]! !

!Project methodsFor: 'flaps support' stamp: 'sw 5/5/2001 00:37'!
isFlapEnabled:  aFlapTab
	"Answer whether the given flap tab is enabled in this project"

	^ self isFlapIDEnabled: aFlapTab flapID! !

!Project methodsFor: 'flaps support' stamp: 'sw 4/17/2001 12:49'!
isFlapIDEnabled:  aFlapID
	"Answer whether a flap of the given ID is enabled in this project"

	| disabledFlapIDs  |
	disabledFlapIDs _ self parameterAt: #disabledGlobalFlapIDs ifAbsent: [^ true].
	^ (disabledFlapIDs includes: aFlapID) not! !

!Project methodsFor: 'flaps support' stamp: 'sw 4/24/2001 11:02'!
showSharedFlaps
	"Answer whether shared flaps are shown or suppressed in this project"

	| result |
	result _ Preferences showSharedFlaps.
	^ self == Project current
		ifTrue:
			[result]
		ifFalse:
			[self projectPreferenceAt: #showSharedFlaps ifAbsent: [result]]! !

!Project methodsFor: 'flaps support' stamp: 'stephaneducasse 11/5/2005 20:57'!
suppressFlapsString
	^ (self flapsSuppressed
		ifTrue: ['<no>']
		ifFalse: ['<yes>']), 'show shared tabs (F)' translated! !

!Project methodsFor: 'flaps support' stamp: 'stephaneducasse 11/5/2005 20:58'!
toggleFlapsSuppressed
	"Project toggleFlapsSuppressed"

	^self flapsSuppressed: self flapsSuppressed not.! !


!Project methodsFor: 'initialization' stamp: 'dgd 9/5/2004 16:27'!
backgroundColorForMorphicProject
	^ Preferences defaultWorldColor! !

!Project methodsFor: 'initialization' stamp: 'sw 11/5/1998 21:28'!
backgroundColorForMvcProject
	^ Color r: 1.0 g: 1.0 b: 0.065! !

!Project methodsFor: 'initialization' stamp: 'tk 9/22/1999 18:35'!
defaultBackgroundColor
	^ self isMorphic
		ifTrue: [self backgroundColorForMorphicProject]
		ifFalse: [self backgroundColorForMvcProject]! !

!Project methodsFor: 'initialization' stamp: 'sw 7/9/2005 15:04'!
initMorphic
	"Written so that Morphic can still be removed.  Note that #initialize is never actually called for a morphic project -- see the senders of this method."

	Smalltalk verifyMorphicAvailability ifFalse: [^ nil].
	changeSet := ChangeSet new.
	transcript := TranscriptStream new.
	displayDepth := Display depth.
	parentProject := CurrentProject.
	isolatedHead := false.
	world := PasteUpMorph newWorldForProject: self.
	Locale switchToID: CurrentProject localeID.
	self initializeProjectPreferences. "Do this *after* a world is installed so that the project will be recognized as a morphic one."
	Preferences useVectorVocabulary ifTrue: [world installVectorVocabulary]! !

!Project methodsFor: 'initialization'!
initialExtent
	^ (Display extent // 6) + (0@17)! !

!Project methodsFor: 'initialization' stamp: 'di 4/14/1999 13:55'!
initialProject
	self saveState.
	parentProject _ self.
	previousProject _ nextProject _ nil! !

!Project methodsFor: 'initialization' stamp: 'di 4/6/2001 10:30'!
initialize
	"Initialize the project, seting the CurrentProject as my parentProject and initializing my project preferences from those of the CurrentProject"

	changeSet _ ChangeSet new.
	transcript _ TranscriptStream new.
	displayDepth _ Display depth.
	parentProject _ CurrentProject.
	isolatedHead _ false.
	self initializeProjectPreferences
! !

!Project methodsFor: 'initialization' stamp: 'ar 5/16/2001 17:08'!
installNewDisplay: extent depth: depth
	"When entering a new project, install a new Display if necessary."
	^Display setExtent: extent depth: depth! !

!Project methodsFor: 'initialization' stamp: 'di 7/19/1999 15:00'!
installPasteUpAsWorld: pasteUpMorph
	"(ProjectViewMorph newMorphicProjectOn: aPasteUpMorph) openInWorld."

	world _ pasteUpMorph beWorldForProject: self! !

!Project methodsFor: 'initialization' stamp: 'RAA 6/21/2000 22:59'!
setChangeSet: aChangeSet

	isolatedHead == true ifTrue: [^ self].  "ChangeSet of an isolated project cannot be changed"
	changeSet _ aChangeSet
! !

!Project methodsFor: 'initialization' stamp: 'di 3/29/2000 14:16'!
setProjectHolder: aProject

	self initialize.
	world _ ControlManager new.
! !

!Project methodsFor: 'initialization' stamp: 'RAA 10/13/2000 18:21'!
setServer
	"Mark me as a new project.  See if a server is known, remember it."

	self projectParameters at: #exportState put: #nacent.
	urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList].! !

!Project methodsFor: 'initialization' stamp: 'di 6/10/1998 13:54'!
windowActiveOnFirstClick

	^ true! !

!Project methodsFor: 'initialization' stamp: 'KLC 12/19/2005 14:32'!
windowReqNewLabel: newLabel
	newLabel isEmpty ifTrue: [^ false].
	newLabel = changeSet name ifTrue: [^ true].
	(ChangeSet named: newLabel) == nil
		ifFalse: [self inform: 'Sorry that name is already used'.
				^ false].
	changeSet name: newLabel.
	^ true! !


!Project methodsFor: 'isolation layers' stamp: 'md 2/24/2006 15:41'!
beIsolated
	"Establish an isolation layer at this project.
	This requires clearing the current changeSet or installing a new one."

	isolatedHead ifTrue: [^ self error: 'Already isolated'].
	self isCurrentProject ifFalse:
		[^ self inform: 'Must be in this project to isolate it'.].
	changeSet isEmpty ifFalse: [changeSet := ChangeSet newChangeSet].
	changeSet beIsolationSetFor: self.
	isolatedHead := true.
	inForce := true.! !

!Project methodsFor: 'isolation layers' stamp: 'di 4/1/2000 09:22'!
compileAll: newClass from: oldClass
	"Make sure that shadowed methods in isolation layers get recompiled.
	Traversal is done elsewhere.  This simply handles the current project."

	isolatedHead == true ifFalse: [^ self].   "only isolated projects need to act on this."
	
	changeSet compileAll: newClass from: oldClass! !

!Project methodsFor: 'isolation layers' stamp: 'RAA 9/27/2000 18:53'!
compileAllIsolated: newClass from: oldClass
	"Whenever a recompile is needed in a class, look in other isolated projects for saved methods and recompile them also.
	At the time this method is called, the recompilation has already been done for the project now in force."

	Project allProjects do: [:proj | proj compileAll: newClass from: oldClass].

! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 16:04'!
invoke
	"Install all methods changed here into method dictionaries.
	Make my versions be the ones that will be called."

	isolatedHead ifFalse: [^ self error: 'This isnt an isolation layer.'].
	inForce ifTrue: [^ self error: 'This layer is already in force.'].
	changeSet invoke.	
	inForce _ true.! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 15:49'!
invokeFrom: otherProject
	"Revoke the changes in force for this project, and then invoke those in force for otherProject.  This method shortens the process to the shortest path up then down through the isolation layers."

	| pathUp pathDown |
	pathUp _ otherProject layersToTop.  "Full paths to top"
	pathDown _ self layersToTop.

	"Shorten paths to nearest common ancestor"
	[pathUp isEmpty not
		and: [pathDown isEmpty not
		and: [pathUp last == pathDown last]]]
		whileTrue: [pathUp removeLast.  pathDown removeLast].

	"Now revoke changes up from otherProject and invoke down to self."
	pathUp do: [:p | p revoke].
	pathDown reverseDo: [:p | p invoke].
! !

!Project methodsFor: 'isolation layers' stamp: 'RAA 6/21/2000 23:01'!
isIsolated

	^ isolatedHead ifNil: [isolatedHead _ false]! !

!Project methodsFor: 'isolation layers' stamp: 'di 4/4/2000 21:10'!
isolationHead
	"Go up the parent chain and find the nearest isolated project."

	isolatedHead == true ifTrue: [^ self].
	self isTopProject ifTrue: [^ nil].
	^ parentProject isolationHead! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 17:00'!
isolationSet

	"Return the changeSet for this isolation layer or nil"
	isolatedHead == true ifTrue: [^ changeSet].
	self isTopProject ifTrue: [^ nil].  "At the top, but not isolated"
	^ parentProject isolationSet

! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 15:40'!
layersToTop
	"Return an OrderedCollection of all the projects that are isolation layers from this one up to the top of the project hierarchy, inclusive."

	| layers |
	self isTopProject
		ifTrue: [layers _ OrderedCollection new]
		ifFalse: [layers _ parentProject layersToTop].
	isolatedHead ifTrue: [layers addFirst: self].
	^ layers
! !

!Project methodsFor: 'isolation layers' stamp: 'di 4/14/2000 09:01'!
propagateChanges
	"Assert these changes in the next higher isolation layer of the system."

	isolatedHead ifFalse: [self error: 'You can only assert changes from isolated projects'].
	self halt: 'Not Yet Implemented'.

"This will be done by installing a new changeSet for this project (initted for isolation).  With the old changeSet no longer in place, no revert will happen when we leave, and those changes will have effectively propagated up a level.  NOTE: for this to work in general, the changes here must be assimilated into the isolationSet for the next layer."! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 16:06'!
revoke
	"Take back all methods changed here.
	Install the original method dictionaries and organizations.
	The orignal method versions will now be the ones used."

	isolatedHead ifFalse: [^ self error: 'This isnt an isolation layer.'].
	inForce ifFalse: [^ self error: 'This layer should have been in force.'].
	changeSet revoke.	
	inForce _ false.
! !


!Project methodsFor: 'language' stamp: 'dgd 4/4/2006 16:38'!
chooseNaturalLanguage
	"Put up a menu allowing the user to choose the natural language for the project"

	| aMenu availableLanguages |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'choose language' translated.
	aMenu lastItem setBalloonText: 'This controls the human language in which tiles should be viewed.  It is potentially extensible to be a true localization mechanism, but initially it only works in the classic tile scripting system.  Each project has its own private language choice' translated.
	Preferences noviceMode
		ifFalse:[aMenu addStayUpItem].

	availableLanguages := NaturalLanguageTranslator availableLanguageLocaleIDs
										asSortedCollection:[:x :y | x displayName < y displayName].

	availableLanguages do:
		[:localeID |
			aMenu addUpdating: #stringForLanguageNameIs: target: Locale selector:  #switchAndInstallFontToID: argumentList: {localeID}].
	aMenu popUpInWorld

"Project current chooseNaturalLanguage"! !

!Project methodsFor: 'language' stamp: 'tak 8/4/2005 16:30'!
localeChanged
	"Set the project's natural language as indicated"
	self projectParameterAt: #localeID put: LocaleID current.
	self updateLocaleDependents! !

!Project methodsFor: 'language' stamp: 'mir 9/1/2005 00:37'!
localeID
	"Answer the natural language for the project"

	| prev |
	^ self projectParameterAt: #localeID
		ifAbsentPut: [
			(prev _ self previousProject)
				ifNotNil: [prev projectParameterAt: #localeID ifAbsent: [LocaleID current]]
				ifNil: [LocaleID current]]! !

!Project methodsFor: 'language' stamp: 'dgd 10/7/2004 20:51'!
naturalLanguage
	"Answer the natural language for the project"
	^ self localeID displayName! !

!Project methodsFor: 'language' stamp: 'nk 9/3/2004 13:00'!
setFlaps

	| flapTabs flapIDs sharedFlapTabs navigationMorph |
	flapTabs _ ActiveWorld flapTabs.
	flapIDs _ flapTabs collect: [:tab | tab knownName].
	flapTabs
		do: [:tab | (tab isMemberOf: ViewerFlapTab)
				ifFalse: [tab isGlobalFlap
						ifTrue: [Flaps removeFlapTab: tab keepInList: false.
							tab currentWorld reformulateUpdatingMenus]
						ifFalse: [| referent | 
							referent _ tab referent.
							referent isInWorld
								ifTrue: [referent delete].
							tab delete]]].
	sharedFlapTabs _ Flaps classPool at: #SharedFlapTabs.
	flapIDs
		do: [:id | 
			id = 'Navigator' translated
				ifTrue: [sharedFlapTabs add: Flaps newNavigatorFlap].
			id = 'Widgets' translated
				ifTrue: [sharedFlapTabs add: Flaps newWidgetsFlap].
			id = 'Tools' translated
				ifTrue: [sharedFlapTabs add: Flaps newToolsFlap].
			id = 'Squeak' translated
				ifTrue: [sharedFlapTabs add: Flaps newSqueakFlap].
			id = 'Supplies' translated
				ifTrue: [sharedFlapTabs add: Flaps newSuppliesFlap].
			id = 'Stack Tools' translated
				ifTrue: [sharedFlapTabs add: Flaps newStackToolsFlap].
			id = 'Painting' translated
				ifTrue: [sharedFlapTabs add: Flaps newPaintingFlap].
			id = 'Objects' translated
				ifTrue: [sharedFlapTabs add: Flaps newObjectsFlap ]].
	2 timesRepeat: [flapIDs do: [:id | Flaps enableDisableGlobalFlapWithID: id]].
	ActiveWorld flapTabs
		do: [:flapTab | flapTab isCurrentlyTextual
				ifTrue: [flapTab changeTabText: flapTab knownName]].
	Flaps positionNavigatorAndOtherFlapsAccordingToPreference.
	navigationMorph _ World findDeeplyA: ProjectNavigationMorph preferredNavigator.
	navigationMorph isNil
		ifTrue: [^ self].
	navigationMorph allMorphs
		do: [:morph | morph class == SimpleButtonDelayedMenuMorph
				ifTrue: [(morph findA: ImageMorph) isNil
						ifTrue: [| label | 
							label _ morph label.
							label isNil
								ifFalse: [| name | 
									name _ morph knownName.
									name isNil
										ifTrue: [morph name: label.
											name _ label].
									morph label: name translated]]]]! !

!Project methodsFor: 'language' stamp: 'yo 8/11/2003 16:46'!
setPaletteFor: aLanguageSymbol 
	| prototype formKey form |
	prototype _ PaintBoxMorph prototype.
	formKey _ ('offPalette' , aLanguageSymbol) asSymbol.
	form _ Imports default imports
				at: formKey
				ifAbsent: [Imports default imports
						at: #offPaletteEnglish
						ifAbsent: []].
	form isNil ifFalse: [prototype loadOffForm: form].
	formKey _ ('pressedPalette' , aLanguageSymbol) asSymbol.
	form _ Imports default imports
				at: formKey
				ifAbsent: [Imports default imports
						at: #pressedPaletteEnglish
						ifAbsent: []].
	form isNil ifFalse: [prototype loadPressedForm: form].
! !

!Project methodsFor: 'language' stamp: 'KR 4/28/2006 11:33'!
updateLocaleDependents
	"Set the project's natural language as indicated"

	ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
			viewerOrScriptor localeChanged].

	Flaps disableGlobalFlaps: false.
	Preferences eToyFriendly
		ifTrue: [
			Flaps addAndEnableEToyFlaps.
			ActiveWorld addGlobalFlaps]
		ifFalse: [Flaps enableGlobalFlaps].

	(Project current isFlapIDEnabled: 'Navigator' translated)
		ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].

	Utilities emptyScrapsBook.
	MenuIcons initializeTranslations.

	LanguageEnvironment localeChanged.

	"self setFlaps.
	self setPaletteFor: aLanguageSymbol."
! !


!Project methodsFor: 'menu messages' stamp: 'sw 11/22/2001 08:40'!
assureNavigatorPresenceMatchesPreference
	"Make sure that the current project conforms to the presence/absence of the navigator"

	| navigator navType wantIt |
	Smalltalk isMorphic ifFalse: [^ self].
	wantIt _  Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator].
	navType _ ProjectNavigationMorph preferredNavigator.
	navigator _ world findA: navType.
	wantIt
		ifFalse:
			[navigator ifNotNil: [navigator delete]]
		ifTrue:
			[navigator isNil ifTrue: 
				[(navigator _ navType new)
					bottomLeft: world bottomLeft;
					openInWorld: world]]! !

!Project methodsFor: 'menu messages' stamp: 'yo 3/1/2005 12:05'!
displayFontProgress
	"Display progress for fonts"
	| done b pp |
	done := false.
	b := ScriptableButton new.
	b color: Color yellow.
	b borderWidth: 1; borderColor: Color black.
	pp := [	| dots str idx |
		dots := #(' - ' ' \ ' ' | ' ' / '). idx := 0.
		[done] whileFalse:[
			str := '$	Fixing fonts	$	' translated.
			str := str copyReplaceTokens: '$' with: (dots atWrap: (idx := idx + 1)) asString.
			b label: str font: (TextStyle defaultFont emphasized: 1).
			b extent: 200@50.
			b center: Display center.
			b fullDrawOn: Display getCanvas.
			(Delay forMilliseconds: 250) wait.
		].
	] forkAt: Processor userInterruptPriority.
	^[done := true]! !

!Project methodsFor: 'menu messages' stamp: 'RAA 5/16/2001 17:50'!
doWeWantToRename

	| want |

	self hasBadNameForStoring ifTrue: [^true].
	(self name beginsWith: 'Unnamed') ifTrue: [^true].
	want _ world valueOfProperty: #SuperSwikiRename ifAbsent: [false].
	world removeProperty: #SuperSwikiRename.
	^want

! !

!Project methodsFor: 'menu messages' stamp: 'tk 10/26/1999 14:25'!
enter
	"Enter the new project"
	self enter: (CurrentProject parent == self) revert: false saveForRevert: false.! !

!Project methodsFor: 'menu messages' stamp: 'RAA 6/11/2000 15:04'!
enterAsActiveSubprojectWithin: enclosingWorld

	"Install my ChangeSet, Transcript, and scheduled views as current globals. 

	If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case.
	If saveForRevert is true, save the ImageSegment of the project being left.
	If revertFlag is true, make stubs for the world of the project being left.
	If revertWithoutAsking is true in the project being left, then always revert."

	"Experimental mods for initial multi-project work:
		1. assume in morphic (this eliminated need for <showZoom>)
		2. assume <saveForRevert> is false (usual case) - removed <old>
		3. assume <revertFlag> is false
		4. assume <revertWithoutAsking> is false - <forceRevert> now auto false <seg> n.u.
		5. no zooming
		6. assume <projectsSentToDisk> false - could be dangerous here
		7. assume no isolation problems (isolationHead ==)
		8. no closing scripts
	"

	self isCurrentProject ifTrue: [^ self].

	guards ifNotNil: [
		guards _ guards reject: [:obj | obj isNil].
		guards do: [:obj | obj okayToEnterProject ifFalse: [^ self]]
	].

		"CurrentProject makeThumbnail."
		"--> Display bestGuessOfCurrentWorld triggerClosingScripts."
	CurrentProject displayDepth: Display depth.

	displayDepth == nil ifTrue: [displayDepth _ Display depth].
		"Display newDepthNoRestore: displayDepth."

		"(world hasProperty: #letTheMusicPlay)
			ifTrue: [world removeProperty: #letTheMusicPlay]
			ifFalse: [Smalltalk at: #ScorePlayer ifPresent: [:playerClass | 
						playerClass allSubInstancesDo: [:player | player pause]]]."

		"returningFlag
			ifTrue: [nextProject _ CurrentProject]
			ifFalse: [previousProject _ CurrentProject]."

		"CurrentProject saveState."
		"CurrentProject _ self."
		"Smalltalk newChanges: changeSet."
		"TranscriptStream newTranscript: transcript."
		"Sensor flushKeyboard."
		"recorderOrNil _ Display pauseMorphicEventRecorder."

		"Display changeMorphicWorldTo: world."  "Signifies Morphic"
	world 
		installAsActiveSubprojectIn: enclosingWorld 
		titled: self name.

		"recorderOrNil ifNotNil: [recorderOrNil resumeIn: world]."
	world triggerOpeningScripts.
	self removeParameter: #exportState.
		"self spawnNewProcessAndTerminateOld: true"! !

!Project methodsFor: 'menu messages' stamp: 'sw 11/10/1999 10:29'!
enter: returningFlag	
	self enter: returningFlag revert: false saveForRevert: false! !

!Project methodsFor: 'menu messages' stamp: 'yo 2/17/2005 15:07'!
enter: returningFlag revert: revertFlag saveForRevert: saveForRevert
	"Install my ChangeSet, Transcript, and scheduled views as current globals. If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case.
	If saveForRevert is true, save the ImageSegment of the project being left.
	If revertFlag is true, make stubs for the world of the project being left.
	If revertWithoutAsking is true in the project being left, then always revert."

	| showZoom recorderOrNil old forceRevert response seg newProcess |

	(world isKindOf: StringMorph) ifTrue: [
		self inform: 'This project is not all here. I will try to load a complete version.' translated.
		^self loadFromServer: true	"try to get a fresh copy"
	].
	self isCurrentProject ifTrue: [^ self].
	"Check the guards"
	guards ifNotNil:
		[guards _ guards reject: [:obj | obj isNil].
		guards do: [:obj | obj okayToEnterProject ifFalse: [^ self]]].
	CurrentProject world triggerEvent: #aboutToLeaveWorld.
	forceRevert _ false.
	CurrentProject rawParameters 
		ifNil: [revertFlag ifTrue: [^ self inform: 'nothing to revert to' translated]]
		ifNotNil: [saveForRevert ifFalse: [
				forceRevert _ CurrentProject projectParameters 
								at: #revertWithoutAsking ifAbsent: [false]]].
	forceRevert not & revertFlag ifTrue: [
		response _ SelectionMenu confirm: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' translated withCRs
			trueChoice: 'Revert to saved version' translated
			falseChoice: 'Cancel' translated.
		response ifFalse: [^ self]].

	revertFlag | forceRevert 
		ifTrue: [seg _ CurrentProject projectParameters at: #revertToMe ifAbsent: [
					^ self inform: 'nothing to revert to' translated]]
		ifFalse: [
			CurrentProject finalExitActions.
			CurrentProject makeThumbnail.
			returningFlag == #specialReturn
				ifTrue:
					[ProjectHistory forget: CurrentProject.		"this guy is irrelevant"
					Project forget: CurrentProject]
				ifFalse:
					[ProjectHistory remember: CurrentProject]].

	(revertFlag | saveForRevert | forceRevert) ifFalse:
		[(Preferences valueOfFlag: #projectsSentToDisk) ifTrue:
			[self storeToMakeRoom]].

	CurrentProject abortResourceLoading.
	Smalltalk isMorphic ifTrue: [CurrentProject world triggerClosingScripts].

	CurrentProject saveProjectPreferences.

	"Update the display depth and make a thumbnail of the current project"
	CurrentProject displayDepth: Display depth.
	old _ CurrentProject.		"for later"

	"Show the project transition.
	Note: The project zoom is run in the context of the old project,
		so that eventual errors can be handled accordingly"
	displayDepth == nil ifTrue: [displayDepth _ Display depth].
	self installNewDisplay: Display extent depth: displayDepth.
	(showZoom _ self showZoom) ifTrue: [
		self displayZoom: CurrentProject parent ~~ self].

	(world isMorph and: [world hasProperty: #letTheMusicPlay])
		ifTrue: [world removeProperty: #letTheMusicPlay]
		ifFalse: [Smalltalk at: #ScorePlayer ifPresentAndInMemory:
					[:playerClass | playerClass allSubInstancesDo:
						[:player | player pause]]].

	returningFlag == #specialReturn ifTrue: [
		old removeChangeSetIfPossible.	"keep this stuff from accumulating"
		nextProject _ nil
	] ifFalse: [
		returningFlag
			ifTrue: [nextProject _ CurrentProject]
			ifFalse: [previousProject _ CurrentProject].
	].

	CurrentProject saveState.
	CurrentProject isolationHead == self isolationHead ifFalse:
		[self invokeFrom: CurrentProject].
	CurrentProject _ self.
	self installProjectPreferences.
	ChangeSet  newChanges: changeSet.
	TranscriptStream newTranscript: transcript.
	Sensor flushKeyboard.
	Smalltalk isMorphic ifTrue: [recorderOrNil _ World pauseEventRecorder].

	ProjectHistory remember: CurrentProject.

	world isMorph
		ifTrue:
			[World _ world.  "Signifies Morphic"
			world install.
			world transferRemoteServerFrom: old world.
			"(revertFlag | saveForRevert | forceRevert) ifFalse: [
				(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
					self storeSomeSegment]]."
			recorderOrNil ifNotNil: [recorderOrNil resumeIn: world].
			world triggerOpeningScripts]
		ifFalse:
			[World _ nil.  "Signifies MVC"
			Smalltalk at: #ScheduledControllers put: world].

	saveForRevert ifTrue: [
		Smalltalk garbageCollect.	"let go of pointers"
		old storeSegment.
		"result _" old world isInMemory 
			ifTrue: ['Can''t seem to write the project.']
			ifFalse: [old projectParameters at: #revertToMe put: 
					old world xxxSegment clone].
				'Project written.'].
			"original is for coming back in and continuing."

	revertFlag | forceRevert ifTrue: [
		seg clone revert].	"non-cloned one is for reverting again later"
	self removeParameter: #exportState.

	"Complete the enter: by launching a new process"
	world isMorph ifTrue: [
		self finalEnterActions.
		world repairEmbeddedWorlds.
		world triggerEvent: #aboutToEnterWorld.
		Project spawnNewProcessAndTerminateOld: true
	] ifFalse: [
		SystemWindow clearTopWindow.	"break external ref to this project"
		newProcess _ [	
			ScheduledControllers resetActiveController.	"in case of walkback in #restore"
			showZoom ifFalse: [ScheduledControllers restore].
			ScheduledControllers searchForActiveController
		] fixTemps newProcess priority: Processor userSchedulingPriority.
		newProcess resume.		"lose the current process and its referenced morphs"
		Processor terminateActive.
	]! !

!Project methodsFor: 'menu messages' stamp: 'sd 5/23/2003 15:16'!
enterForEmergencyRecovery
	"This version of enter invokes an absolute minimum of mechanism.
	An unrecoverable error has been detected in an isolated project.
	It is assumed that the old changeSet has already been revoked.
	No new process gets spawned here.  This will happen in the debugger."

	self isCurrentProject ifTrue: [^ self].
	CurrentProject saveState.
	CurrentProject _ self.
	Display newDepthNoRestore: displayDepth.
	ChangeSet  newChanges: changeSet.
	TranscriptStream newTranscript: transcript.
	World pauseEventRecorder.

	world isMorph
		ifTrue:
			["Entering a Morphic project"
			World _ world.
			world install.
			world triggerOpeningScripts]
		ifFalse:
			["Entering an MVC project"
			World _ nil.
			Smalltalk at: #ScheduledControllers put: world.
			ScheduledControllers restore].
	UIProcess _ Processor activeProcess.
! !

!Project methodsFor: 'menu messages' stamp: 'yo 7/2/2004 19:46'!
exit
	"Leave the current project and return to the project in which this one was created."

	self isTopProject ifTrue: [^ self inform: 'Can''t exit the top project' translated].
	parentProject enter: false revert: false saveForRevert: false.
! !

!Project methodsFor: 'menu messages'!
fileOut
	changeSet fileOut! !

!Project methodsFor: 'menu messages' stamp: 'dgd 4/4/2006 16:40'!
finalEnterActions
	"Perform the final actions necessary as the receiver project is entered"

	| navigator armsLengthCmd navType thingsToUnhibernate fixBlock |

	self projectParameters 
		at: #projectsToBeDeleted 
		ifPresent: [ :projectsToBeDeleted |
			self removeParameter: #projectsToBeDeleted.
			projectsToBeDeleted do: [ :each | 
				Project deletingProject: each.
				each removeChangeSetIfPossible]].

	Locale switchAndInstallFontToID: self localeID.

	thingsToUnhibernate _ world valueOfProperty: #thingsToUnhibernate ifAbsent: [#()].
	(thingsToUnhibernate anySatisfy:[:each| 
		each isMorph and:[each hasProperty: #needsLayoutFixed]]) 
			ifTrue:[fixBlock := self displayFontProgress].
	thingsToUnhibernate do: [:each | each unhibernate].
	world removeProperty: #thingsToUnhibernate.

	fixBlock ifNotNil:[
		fixBlock value.
		world fullRepaintNeeded.
	].

	navType _ ProjectNavigationMorph preferredNavigator.
	armsLengthCmd _ self parameterAt: #armsLengthCmd ifAbsent: [nil].
	navigator _ world findA: navType.
	(Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator and: [navigator isNil]]) ifTrue:
		[(navigator _ navType new)
			bottomLeft: world bottomLeft;
			openInWorld: world].
	navigator notNil & armsLengthCmd notNil ifTrue:
		[navigator color: Color lightBlue].
	armsLengthCmd notNil ifTrue:
		[Preferences showFlapsWhenPublishing
			ifFalse:
				[self flapsSuppressed: true.
				navigator ifNotNil:	[navigator visible: false]].
		armsLengthCmd openInWorld: world].
	Smalltalk isMorphic ifTrue:
		[world reformulateUpdatingMenus.
		world presenter positionStandardPlayer.
		self assureMainDockingBarPresenceMatchesPreference].

	WorldState addDeferredUIMessage: [self startResourceLoading].! !

!Project methodsFor: 'menu messages' stamp: 'RAA 2/6/2001 14:21'!
finalExitActions

	| navigator |

	world isMorph ifTrue: [
		navigator _ world findA: ProjectNavigationMorph.
		navigator ifNotNil: [navigator retractIfAppropriate].
	].
! !

!Project methodsFor: 'menu messages' stamp: 'sw 4/19/2001 12:58'!
installProjectPreferences
	"Install the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary"

	| localValue |
	Preferences allPreferenceObjects do:
		[:aPreference | 
			aPreference localToProject ifTrue:
				[localValue _ self projectPreferenceFlagDictionary at: aPreference name ifAbsent: [nil].
				localValue ifNotNil:
					[aPreference rawValue: localValue]]]! !

!Project methodsFor: 'menu messages' stamp: 'RAA 5/10/2001 16:59'!
makeThumbnail
	"Make a thumbnail image of this project from the Display."

	world isMorph ifTrue: [world displayWorldSafely]. "clean pending damage"
	viewSize ifNil: [viewSize _ Display extent // 8].
	thumbnail _ Form extent: viewSize depth: Display depth.
	(WarpBlt current toForm: thumbnail)
			sourceForm: Display;
			cellSize: 2;  "installs a colormap"
			combinationRule: Form over;
			copyQuad: (Display boundingBox) innerCorners
			toRect: (0@0 extent: viewSize).
	InternalThreadNavigationMorph cacheThumbnailFor: self.
	^thumbnail
! !

!Project methodsFor: 'menu messages' stamp: 'dgd 8/31/2003 19:37'!
navigatorFlapVisible
	"Answer whether a Navigator flap is visible"

	^ (Flaps sharedFlapsAllowed and: 
		[self flapsSuppressed not]) and:
			[self isFlapIDEnabled: 'Navigator' translated]! !

!Project methodsFor: 'menu messages' stamp: 'sw 4/12/2001 22:29'!
saveProjectPreferences
	"Preserve the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary"

	Preferences allPreferenceObjects do:
		[:aPreference | 
			aPreference localToProject ifTrue:
				[projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]! !

!Project methodsFor: 'menu messages' stamp: 'sd 5/23/2003 14:40'!
saveState
	"Save the current state in me prior to leaving this project"

	changeSet _ ChangeSet current.
	thumbnail ifNotNil: [thumbnail hibernate].
	Smalltalk isMorphic
		ifTrue:
			[world _ World.
			world sleep.
			ActiveWorld _ ActiveHand _ ActiveEvent _ nil]
		ifFalse:
			[world _ ScheduledControllers.
			ScheduledControllers unCacheWindows].
	Sensor flushAllButDandDEvents. "Will be reinstalled by World>>install"
	transcript _ Transcript.
! !

!Project methodsFor: 'menu messages' stamp: 'RAA 5/16/2001 18:00'!
validateProjectNameIfOK: aBlock

	| details |

	details _ world valueOfProperty: #ProjectDetails.
	details ifNotNil: ["ensure project info matches real project name"
		details at: 'projectname' put: self name.
	].
	self doWeWantToRename ifFalse: [^aBlock value].
	EToyProjectDetailsMorph
		getFullInfoFor: self 
		ifValid: [
			World displayWorldSafely.
			aBlock value.
		] fixTemps
		expandedFormat: false
! !

!Project methodsFor: 'menu messages' stamp: 'gm 2/16/2003 20:37'!
viewLocFor: exitedProject 
	"Look for a view of the exitedProject, and return its center"

	| ctlr |
	world isMorph 
		ifTrue: 
			[world submorphsDo: 
					[:v | 
					((v isSystemWindow) and: [v model == exitedProject]) 
						ifTrue: [^v center]]]
		ifFalse: 
			[ctlr := world controllerWhoseModelSatisfies: [:p | p == exitedProject].
			ctlr ifNotNil: [^ctlr view windowBox center]].
	^Sensor cursorPoint	"default result"! !


!Project methodsFor: 'OBSOLETE' stamp: 'RAA 6/3/2000 19:01'!
obsolete

	self flag: #obsolete.
	"instance variable 
		exitFlag is no longer used
		activeProcess is on the way out
	"! !


!Project methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:49'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	isolatedHead ifNil: [isolatedHead _ false].
	inForce ifNil: [inForce _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!Project methodsFor: 'printing' stamp: 'jm 5/21/1998 07:40'!
printOn: aStream

	aStream nextPutAll: 'a Project(', self name, ')'.
! !


!Project methodsFor: 'project parameters' stamp: 'sw 10/27/2000 06:46'!
currentStack
	"Answer the current stack of the current project.  Called basically as a bail-out when we can't find the stack in the owner chain of a morph, probably because it is on a background that is not currently installed.  This method will always return a stack that is in the world, or nil if no stack is found in the world.  Of course it would be nice to have multiple stacks concurrently open in the same world, but at the moment that is problematical."

	| aStack curStack |

	curStack _ self projectParameterAt: #CurrentStack.
	curStack ifNotNil: [curStack isInWorld ifTrue: [^ curStack]].

	(aStack _ world findA: StackMorph) ifNotNil:
		[self currentStack: aStack].
	^ aStack! !

!Project methodsFor: 'project parameters' stamp: 'sw 4/24/2001 11:58'!
initializeProjectParameters
	"Initialize the project parameters."

	projectParameters _ IdentityDictionary new.
	^ projectParameters! !

!Project methodsFor: 'project parameters' stamp: 'di 11/16/2001 21:08'!
initializeProjectPreferences
	"Initialize the project's preferences from currently-prevailing preferences that are currently being held in projects in this system"
	
	projectPreferenceFlagDictionary _ Project current projectPreferenceFlagDictionary deepCopy.    "Project overrides in the new project start out being the same set of overrides in the calling project"

	Preferences allPreferenceObjects do:  "in case we missed some"
		[:aPreference |
			aPreference localToProject ifTrue:
				[(projectPreferenceFlagDictionary includesKey: aPreference name) ifFalse:
			[projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]].

	self isMorphic ifFalse: [self flapsSuppressed: true].
	(Project current projectParameterAt: #disabledGlobalFlapIDs  ifAbsent: [nil]) ifNotNilDo:
		[:idList | self projectParameterAt: #disabledGlobalFlapIDs put: idList copy]
! !

!Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:35'!
noteThatParameter: prefSymbol justChangedTo: aBoolean
	"Provides a hook so that a user's toggling of a project parameter might precipitate some immediate action"

! !

!Project methodsFor: 'project parameters' stamp: 'ar 5/25/2000 23:23'!
parameterAt: aSymbol
	^self parameterAt: aSymbol ifAbsent:[nil]! !

!Project methodsFor: 'project parameters' stamp: 'ar 5/25/2000 23:23'!
parameterAt: aSymbol ifAbsent: aBlock
	projectParameters ifNil:[^aBlock value].
	^projectParameters at: aSymbol ifAbsent: aBlock! !

!Project methodsFor: 'project parameters' stamp: 'sw 10/30/2000 11:14'!
projectParameterAt: aSymbol
	"Answer the project parameter stored at the given symbol, or nil if none"

	^ self projectParameters at: aSymbol ifAbsent: [nil]! !

!Project methodsFor: 'project parameters' stamp: 'sw 2/15/2001 14:32'!
projectParameterAt: aSymbol ifAbsent: aBlock
	"Answer the project parameter stored at the given symbol, or the result of evaluating the block"

	^ self projectParameters at: aSymbol ifAbsent: [aBlock value]! !

!Project methodsFor: 'project parameters' stamp: 'sw 9/28/2001 08:49'!
projectParameterAt: aKey ifAbsentPut: defaultValueBlock
	"Return the project parameter setting at the given key.  If there is no entry for this key in the Parameters dictionary, create one with the value of defaultValueBlock as its value"

	^ self projectParameters at: aKey ifAbsentPut: defaultValueBlock! !

!Project methodsFor: 'project parameters' stamp: 'sw 2/17/2001 21:36'!
projectParameterAt: aSymbol put: aValue
	"Set the given project parameter to the given value"

	self projectParameters at: aSymbol put: aValue.
	self noteThatParameter: aSymbol justChangedTo: aValue.
	^ aValue! !

!Project methodsFor: 'project parameters' stamp: 'sw 4/22/1999 15:14'!
projectParameters
	^ projectParameters ifNil: [self initializeProjectParameters]! !

!Project methodsFor: 'project parameters' stamp: 'sw 4/12/2001 23:36'!
projectPreferenceAt: aSymbol
	"Answer the project preference stored at the given symbol.  If there is none in the local preference dictionary, it must be because it was only latterly declared to be a project-local preference, so obtain its initial value instead from the last-known global or default setting"

	| aValue |
	^ self projectPreferenceAt: aSymbol ifAbsent: 
		[aValue _ Preferences valueOfFlag: aSymbol.
		self projectPreferenceFlagDictionary at: aSymbol put: aValue.
		^ aValue]! !

!Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:25'!
projectPreferenceAt: aSymbol ifAbsent: aBlock
	"Answer the project preference stored at the given symbol, or the result of evaluating the block"

	^ self projectPreferenceFlagDictionary at: aSymbol ifAbsent: [aBlock value]! !

!Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:23'!
projectPreferenceFlagDictionary
	"Answer the dictionary that holds the project preferences, creating it if necessary"

	^ projectPreferenceFlagDictionary ifNil: [projectPreferenceFlagDictionary _ IdentityDictionary new]! !

!Project methodsFor: 'project parameters' stamp: 'tk 10/26/1999 13:55'!
rawParameters
	^ projectParameters! !

!Project methodsFor: 'project parameters' stamp: 'ar 6/2/1999 05:29'!
removeParameter: aKey
	projectParameters ifNil:[^self].
	projectParameters removeKey: aKey ifAbsent:[].! !


!Project methodsFor: 'release' stamp: 'di 9/28/1999 23:46'!
addDependent: aMorph

	"Projects do not keep track of their dependents, lest they point into other projects and thus foul up the tree structure for image segmentation."

	^ self  "Ignore this request"! !

!Project methodsFor: 'release' stamp: 'sw 7/6/1998 11:16'!
canDiscardEdits
	"Don't regard a window of mine as one to be discarded as part of a 'closeUnchangedWindows' sweep"

	^ false! !

!Project methodsFor: 'release' stamp: 'RAA 5/10/2001 12:58'!
deletingProject: aProject
	"Clear my previousProject link if it points at the given Project, which is being deleted."

	self flag: #bob.		"zapping projects"

	parentProject == aProject ifTrue: [
		parentProject _ parentProject parent
	].
	previousProject == aProject
		ifTrue: [previousProject _ nil].
	nextProject == aProject
		ifTrue:	[nextProject _ nil]
! !

!Project methodsFor: 'release' stamp: 'dgd 9/21/2003 17:49'!
okToChange
	"Answer whether the window in which the project is housed can be dismissed -- which is destructive. We never clobber a project without confirmation"

	| ok is list |
	self subProjects size  >0 ifTrue:
		[self inform: 
('The project {1}
contains sub-projects.  You must remove these
explicitly before removing their parent.' translated format:{self name}).
		^ false].
	ok _ world isMorph not and: [world scheduledControllers size <= 1].
	ok ifFalse: [self isMorphic ifTrue:
		[self parent == CurrentProject 
			ifFalse: [^ true]]].  "view from elsewhere.  just delete it."
	ok _ (self confirm:
('Really delete the project
{1}
and all its windows?' translated format:{self name})).
		
	ok ifFalse: [^ false].

	world isMorph ifTrue:
		[Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass |
			world submorphs do:   "special release for wonderlands"
						[:m | (m isKindOf: aClass)
								and: [m getWonderland release]]].
			"Remove Player classes and metaclasses owned by project"
			is _ ImageSegment new arrayOfRoots: (Array with: self).
			(list _ is rootsIncludingPlayers) ifNotNil:
				[list do: [:playerCls | 
					(playerCls respondsTo: #isMeta) ifTrue:
						[playerCls isMeta ifFalse:
							[playerCls removeFromSystemUnlogged]]]]].

	self removeChangeSetIfPossible.
	"do this last since it will render project inaccessible to #allProjects and their ilk"
	ProjectHistory forget: self.
	Project deletingProject: self.
	^ true
! !

!Project methodsFor: 'release' stamp: 'RAA 6/7/2000 09:24'!
release

	self flag: #bob.	"this can be trouble if Projects are reused before garbage collection"
	world == nil ifFalse:
		[world release.
		world _ nil].
	^ super release! !

!Project methodsFor: 'release' stamp: 'ar 9/27/2005 20:09'!
removeChangeSetIfPossible

	| itsName |

	changeSet ifNil: [^self].
	changeSet isEmpty ifFalse: [^self].
	(changeSet projectsBelongedTo copyWithout: self) isEmpty ifFalse: [^self].
	itsName := changeSet name.
	ChangeSet removeChangeSet: changeSet.
	"Transcript cr; show: 'project change set ', itsName, ' deleted.'"
! !

!Project methodsFor: 'release' stamp: 'gm 2/16/2003 20:37'!
subProjects
	"Answer a list of all the subprojects  of the receiver.  This is nastily idiosyncratic."

	^self isMorphic 
		ifTrue: 
			[world submorphs 
				select: [:m | (m isSystemWindow) and: [m model isKindOf: Project]]
				thenCollect: [:m | m model]]
		ifFalse: 
			[(world controllersSatisfying: [:m | m model isKindOf: Project]) 
				collect: [:c | c model]]! !


!Project methodsFor: 'resources' stamp: 'ar 3/2/2001 17:25'!
abortResourceLoading
	"Abort loading resources"
	resourceManager ifNil:[^self].
	resourceManager stopDownload.! !

!Project methodsFor: 'resources' stamp: 'mir 6/21/2001 15:43'!
resourceDirectoryName
	"Project current resourceDirectoryName"
	^String streamContents:[:s|
		s nextPutAll: self name.
		s nextPutAll: FileDirectory dot.
		s nextPutAll: self versionForFileName.
	]
! !

!Project methodsFor: 'resources' stamp: 'ar 2/27/2001 17:02'!
resourceManager
	^resourceManager ifNil:[resourceManager _ ResourceManager new]! !

!Project methodsFor: 'resources' stamp: 'ar 2/27/2001 15:49'!
resourceManager: aResourceManager
	resourceManager _ aResourceManager! !

!Project methodsFor: 'resources' stamp: 'mir 6/26/2001 17:34'!
resourceUrl
	"compose my base url for resources on the server"
	| firstURL | 
"
	primaryServer _ self primaryServerIfNil: [^''].
	firstURL _ primaryServer altUrl ifNil: [primaryServer url]."
	firstURL _ self downloadUrl.
	firstURL isEmpty
		ifFalse: [firstURL last == $/ ifFalse: [firstURL _ firstURL, '/']].
	^ firstURL, self resourceDirectoryName , '/'
! !

!Project methodsFor: 'resources' stamp: 'mir 6/18/2001 16:19'!
startResourceLoading
	"Abort loading resources"
	resourceManager ifNil:[^self].
	resourceManager adjustToDownloadUrl: self resourceUrl.
	resourceManager startDownload! !

!Project methodsFor: 'resources' stamp: 'ar 3/2/2001 15:16'!
storeResourceList: collector in: fd
	"Store a list of all used resources in the given directory. Used for maintenance."
	| file rcName |
	rcName _ self resourceDirectoryName,'.rc'.
	file _ fd forceNewFileNamed: rcName.
	collector locatorsDo:[:loc| file nextPutAll: loc urlString; cr].
	file close.
	file _ fd readOnlyFileNamed: rcName.
	file compressFile.
	fd deleteFileNamed: rcName ifAbsent:[].! !


!Project methodsFor: 'SuperSwiki' stamp: 'RAA 7/13/2000 11:11'!
tellAFriend

	self tellAFriend: nil
! !

!Project methodsFor: 'SuperSwiki' stamp: 'yo 2/12/2005 19:25'!
tellAFriend: emailAddressOrNil
	| urlForLoading |
"
Project current tellAFriend
"

	(urlForLoading _ self urlForLoading) ifNil: [
		urlForLoading _ self url		"fallback for dtp servers"
	].
	urlForLoading isEmptyOrNil ifTrue: [
		^self inform: 'Since this project has not been saved yet,
I cannot tell someone where it is.' translated
	].
	HTTPClient tellAFriend: emailAddressOrNil url: urlForLoading name: self name! !




!Project methodsFor: '*sound' stamp: 'sma 6/16/2000 23:43'!
beep
	(PluckedSound pitch: 261.625*4 dur: 1 loudness: 0.1) play! !


!Project methodsFor: 'docking bars support' stamp: 'dgd 9/20/2004 16:29'!
assureMainDockingBarPresenceMatchesPreference
	"Syncronize the state of the receiver's dockings with the  
	preference"
	(self showWorldMainDockingBar)
		ifTrue: [self createOrUpdateMainDockingBar]
		ifFalse: [self removeMainDockingBar]! !

!Project methodsFor: 'docking bars support' stamp: 'dgd 9/6/2004 18:47'!
createOrUpdateMainDockingBar
	"Private - create a new main docking bar or update the current one"
	| w mainDockingBars |
	w := self world.
	mainDockingBars := w mainDockingBars.
	mainDockingBars isEmpty
		ifTrue: ["no docking bar, just create a new one"
			TheWorldMainDockingBar instance createDockingBar openInWorld: w.
			^ self].
	""
	"update if nedeed"
	mainDockingBars
		do: [:each | TheWorldMainDockingBar instance updateIfNeeded: each]! !

!Project methodsFor: 'docking bars support' stamp: 'dgd 9/6/2004 18:46'!
removeMainDockingBar
	"Remove the receiver's main docking bars"
	self world mainDockingBars
		do: [:each | each delete]! !

!Project methodsFor: 'docking bars support' stamp: 'dgd 9/20/2004 16:30'!
showWorldMainDockingBar

	^ self projectPreferenceFlagDictionary
		at: #showWorldMainDockingBar
		ifAbsent: [Preferences showWorldMainDockingBar]! !

!Project methodsFor: 'docking bars support' stamp: 'dgd 9/20/2004 19:28'!
showWorldMainDockingBarString
	^ (self showWorldMainDockingBar
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'show main docking bar (M)' translated! !

!Project methodsFor: 'docking bars support' stamp: 'dgd 9/6/2004 18:47'!
showWorldMainDockingBar: aBoolean 
	"Change ther receiver to show the main docking bar"
	self projectPreferenceFlagDictionary at: #showWorldMainDockingBar put: aBoolean.
	""
	self == Project current
		ifTrue: [""
			aBoolean == Preferences showWorldMainDockingBar
				ifFalse: [Preferences setPreference: #showWorldMainDockingBar toValue: aBoolean]].
	""
	self assureMainDockingBarPresenceMatchesPreference! !

!Project methodsFor: 'docking bars support' stamp: 'dgd 9/20/2004 16:31'!
toggleShowWorldMainDockingBar
	self showWorldMainDockingBar: self showWorldMainDockingBar not! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Project class
	instanceVariableNames: ''!

!Project class methodsFor: 'class initialization' stamp: 'RAA 6/3/2000 18:50'!
initialize
	"This is the Top Project."   

	CurrentProject ifNil:
		[CurrentProject _ super new initialProject.
		Project spawnNewProcessAndTerminateOld: true].

	"Project initialize"! !

!Project class methodsFor: 'class initialization' stamp: 'tak 8/3/2005 18:35'!
localeChanged
	self current localeChanged! !

!Project class methodsFor: 'class initialization' stamp: 'RAA 12/17/2000 12:37'!
rebuildAllProjects
	"Project rebuildAllProjects"

	AllProjects _ nil.
	self allProjects.! !


!Project class methodsFor: 'constants'!
current
	"Answer the project that is currently being used."

	^CurrentProject! !


!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:07'!
new

	| new |

	new _ super new.
	new setProjectHolder: CurrentProject.
	self addingProject: new.
	^new! !

!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:07'!
newMorphic
	| new |
	"ProjectView open: Project newMorphic"

	new _ self basicNew.
	self addingProject: new.
	new initMorphic.
	^new! !

!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:08'!
newMorphicOn: aPasteUpOrNil

	| newProject |

	newProject _ self basicNew initMorphic.
	self addingProject: newProject.
	aPasteUpOrNil ifNotNil: [newProject installPasteUpAsWorld: aPasteUpOrNil].
	newProject createViewIfAppropriate.
	^newProject
! !

!Project class methodsFor: 'instance creation' stamp: 'RAA 9/27/2000 13:41'!
uiProcess

	^ UIProcess! !


!Project class methodsFor: 'squeaklet on server' stamp: 'nb 6/17/2003 12:25'!
enterIfThereOrFind: aProjectName

	| newProject |
	newProject _ Project named: aProjectName.
	newProject ifNotNil: [^newProject enter].

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project loading';
		withProgressDo: [
			[
				newProject _ CurrentProject fromMyServerLoad: aProjectName
			] 
				on: ProjectViewOpenNotification
				do: [ :ex | ex resume: false]		
					"we probably don't want a project view morph in this case"
		].

	newProject ifNotNil: [^newProject enter].
	Beeper beep.! !

!Project class methodsFor: 'squeaklet on server' stamp: 'gk 10/21/2005 11:01'!
fromUrl: urlString
	"Load the project, and make a thumbnail to it in the current project.  Replace the old one if necessary.
To test it, make sure you don't have AAEmptyTest.001.pr in your Squeaklets directory. Then do:
Project fromUrl: 'http://209.143.91.36/super/SuperSwikiProj/AAEmptyTest.001.pr'.
The project should open and you should enter it. Return to the previous project and delete the project. Then do:
Project fromUrl: 'AAEmptyTest.001.pr'.
The project should open again - this time faster - and you should enter it. 
"
	| absoluteUrl projectFilename projName proj serverDir pair |
	Project canWeLoadAProjectNow ifFalse: [^ self].
	absoluteUrl := Url absoluteFromFileNameOrUrlString: urlString.
	projectFilename _ absoluteUrl fileName.
	projName _ (Project parseProjectFileName: projectFilename unescapePercents) first.
	(proj _ Project named: projName) ifNotNil: [
		"it appeared"
		^ProjectEntryNotification signal: proj].

	serverDir _ ServerDirectory serverForURL: absoluteUrl directoryUrl asString.
	serverDir ifNotNil: [
		pair _ self mostRecent: projectFilename onServer: serverDir.
		"Pair first is name exactly as it is on the server"
		pair first ifNil: [^self openBlankProjectNamed: projName].
		projectFilename _ pair first].

	ProjectLoading
		installRemoteNamed: projectFilename
		from: absoluteUrl asString unescapePercents
		named: projName
		in: CurrentProject! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 1/28/2001 08:39'!
isBadNameForStoring: aString

	| badChars |

	"will the name of this project cause problems when stored on an arbitrary file system?"
	badChars _ #( $: $< $> $| $/ $\ $? $* $" $.) asSet.
	^aString size > 24 or: [
		aString anySatisfy: [ :each | 
			each asciiValue < 32 or: [badChars includes: each]
		]
	]
! !

!Project class methodsFor: 'squeaklet on server' stamp: 'mir 8/8/2001 17:57'!
loaderUrl
	"Return a url that will allow to launch a project in a browser by composing a url like
	<loaderURL>?<projectURL>"

	^AbstractLauncher extractParameters at: 'LOADER_URL' ifAbsent: [nil].! !

!Project class methodsFor: 'squeaklet on server' stamp: 'ar 4/10/2005 18:51'!
mostRecent: projName onServer: aServerDirectory
	| stem list max goodName triple num stem1 stem2 rawList nothingFound unEscName |
	"Find the exact fileName of the most recent version of project with the stem name of projName.  Names are of the form 'projName|mm.pr' where mm is a mime-encoded integer version number.
	File names may or may not be HTTP escaped, %20 on the server."

	self flag: #bob.		"do we want to handle unversioned projects as well?"

	nothingFound _ {nil. -1}.
	aServerDirectory ifNil: [^nothingFound].
	"23 sept 2000 - some old projects have periods in name so be more careful"
	unEscName _ projName unescapePercents.
	triple _ Project parseProjectFileName: unEscName.
	stem _ triple first.
	rawList _ aServerDirectory fileNames.

	rawList isString ifTrue: [self inform: 'server is unavailable'. ^nothingFound].
	list _ rawList collect: [:nnn | nnn unescapePercents].
	max _ -1.  goodName _ nil.
	list withIndexDo: [:aName :ind |
		(aName beginsWith: stem) ifTrue: [
			num _ (Project parseProjectFileName: aName) second.
			num > max ifTrue: [max _ num.  goodName _ (rawList at: ind)]]].

	max = -1 ifFalse: [^ Array with: goodName with: max].

	"try with underbar for spaces on server"
	(stem includes: $ ) ifTrue: [
		stem1 _ stem copyReplaceAll: ' ' with: '_'.
		list withIndexDo: [:aName :ind |
			(aName beginsWith: stem1) ifTrue: [
				num _ (Project parseProjectFileName: aName) second.
				num > max ifTrue: [max _ num.  goodName _ (rawList at: ind)]]]].
	max = -1 ifFalse: [^ Array with: goodName with: max].
	
	"try without the marker | "
	stem1 _ stem allButLast, '.pr'.
	stem2 _ stem1 copyReplaceAll: ' ' with: '_'.	"and with spaces replaced"
	list withIndexDo: [:aName :ind |
		(aName beginsWith: stem1) | (aName beginsWith: stem2) ifTrue: [
			(triple _ aName findTokens: '.') size >= 2 ifTrue: [
				max _ 0.  goodName _ (rawList at: ind)]]].	"no other versions"
	max = -1 ifFalse: [^ Array with: goodName with: max].

	^nothingFound		"no matches"
! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 9/27/2000 14:11'!
namedUrl: urlString
	| projName |
	"Return project if in, else nil"

	"Ted's fix for unreachable projects"

	projName _ (urlString findTokens: '/') last.
	projName _ (Project parseProjectFileName: projName unescapePercents) first.
	^ Project named: projName
! !

!Project class methodsFor: 'squeaklet on server' stamp: 'dao 10/1/2004 13:25'!
openBlankProjectNamed: projName

	| proj projViewer |

	proj _ Project newMorphicOn: nil.
	proj changeSet name: projName.
	proj world addMorph: (
		TextMorph new 
			beAllFont: ((TextStyle default fontOfSize: 26) emphasized: 1);
			color: Color red;
			contents: 'Welcome to a new project - ',projName
	).
	proj setParent: self current.
	projViewer _ (CurrentProject findProjectView: projName) ifNil: [^proj].
	(projViewer owner isSystemWindow) ifTrue: [
			projViewer owner model: proj].
	^ projViewer project: proj! !

!Project class methodsFor: 'squeaklet on server' stamp: 'ar 10/11/2000 15:42'!
parseProjectFileName: aString
	"It was formerly possible to have periods in projct names and this messed up some parsing methods. Try to handle that more gracefully and allow for a change in scheme at a later time.
	ar 10/11/2000: Switch to a different version encoding scheme. The new scheme is
		baseName.NNN.ext
	where NNN is at least three digits wide and encodes the version in a human readable form.
	Examples:
		Project parseProjectFileName: 'My Project.007.pr'.
		Project parseProjectFileName: 'My.First.Project.042.prj'.
		Project parseProjectFileName: 'My Project.123456.p r o j e c t'.
	The 'dot' is determined on FileDirectory>>dot to compensate for platforms wishing to use something different from a period. Also allows parsing the former encoding of file using Base64 encoded versions of the form
	Project parseProjectFileName: 'aa.bb.cc|AQ.ss'
	"
	| suffix baseName version versionAndSuffix index tokens |
	"answer an array with: 
		1 = basic project name
		2 = version string
		3 = suffix (pr)"

	"First check for the old style versions"
	index _ aString findLast:[:ch| ch = $|].
	index = 0 ifFalse:["Old style version"
		baseName _ aString copyFrom: 1 to: index-1.
		versionAndSuffix _ aString copyFrom: index+1 to: aString size.
		(versionAndSuffix occurrencesOf: $.) = 0 ifTrue: [^ #('no suffix')].
		version _ versionAndSuffix copyUpTo: $..
		suffix _ versionAndSuffix copyFrom: version size+1 to: versionAndSuffix size.
		"Decode Base64 encoded version"
		version isEmpty
			ifTrue:[version _ 0]
			ifFalse:[version _ Base64MimeConverter decodeInteger: version unescapePercents].
		^{baseName. version. suffix}].
	"New style versions"
	tokens _ aString findTokens: FileDirectory dot.
	tokens size < 2 "Not even a single dot"
		ifTrue:[^{aString. 0. ''}].
	tokens size < 3 ifTrue:["Only one dot"
		self flag: #arNote. "We could allow project file names of the form 'project.001' (e.g., no project extension) or '.001.pr' (without a base name) but I don't think its a good idea."
		^{tokens first. 0. tokens last}].
	suffix _ tokens last.
	version _ tokens at: tokens size - 1.
	(version anySatisfy:[:ch| ch isDigit not]) ifTrue:[
		"Non-digit version??? I don't think so..."
		baseName _ aString copyFrom: 1 to: aString size - suffix size - 1.
		^{baseName. 0. suffix}].
	baseName _ aString copyFrom: 1 to: aString size - suffix size - version size - 2.
	version _ version asInteger.
	^{baseName. version. suffix}! !

!Project class methodsFor: 'squeaklet on server' stamp: 'ar 2/27/2001 13:43'!
projectExtension
	^'pr'! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 10/17/2000 19:11'!
serverDirectoryFromURL: aURLString

	| dir |
	self flag: #bob.		"need to include swikis in this - hacked for now"

	(aURLString findString: '/SuperSwikiProj/') > 0 ifTrue: [
		dir _ SuperSwikiServer new fullPath: (aURLString copyUpToLast: $/).
		^dir
	].

	^ServerDirectory new fullPath: aURLString! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 10/17/2000 19:11'!
serverFileFromURL: aURLString

	| dir |
	self flag: #bob.		"need to include swikis in this - hacked for now"

	(aURLString findString: '/SuperSwikiProj/') > 0 ifTrue: [
		dir _ SuperSwikiServer new fullPath: (aURLString copyUpToLast: $/).
		^dir readOnlyFileNamed: (aURLString findTokens: '/') last
	].
	^ServerFile new fullPath: aURLString! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 8/8/2000 10:42'!
spawnNewProcessIfThisIsUI: suspendedProcess

	self uiProcess == suspendedProcess ifTrue: [
		self spawnNewProcess.
		^true
	].
	^false		"no new process was created"
! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 2/19/2001 07:37'!
squeakletDirectory

	| squeakletDirectoryName |
	squeakletDirectoryName _ 'Squeaklets'.
	(FileDirectory default directoryExists: squeakletDirectoryName) ifFalse: [
		FileDirectory default createDirectory: squeakletDirectoryName
	].
	^FileDirectory default directoryNamed: squeakletDirectoryName! !

!Project class methodsFor: 'squeaklet on server' stamp: 'ar 4/10/2005 18:51'!
sweep: aServerDirectory
	| repository list parts ind entry projectName versions |
	"On the server, move all but the three most recent versions of each Squeaklet to a folder called 'older'"
	"Project sweep: ((ServerDirectory serverNamed: 'DaniOnJumbo') clone 
				directory: '/vol0/people/dani/Squeaklets/2.7')"

	"Ensure the 'older' directory"
	(aServerDirectory includesKey: 'older') 
		ifFalse: [aServerDirectory createDirectory: 'older'].
	repository _ aServerDirectory clone directory: aServerDirectory directory, '/older'.

	"Collect each name, and decide on versions"
	list _ aServerDirectory fileNames.
	list isString ifTrue: [^ self inform: 'server is unavailable'].
	list _ list asSortedCollection asOrderedCollection.
	parts _ list collect: [:en | Project parseProjectFileName: en].
	parts _ parts select: [:en | en third = 'pr'].
	ind _ 1.
	[entry _ list at: ind.
		projectName _ entry first asLowercase.
		versions _ OrderedCollection new.  versions add: entry.
		[(ind _ ind + 1) > list size 
			ifFalse: [(parts at: ind) first asLowercase = projectName 
				ifTrue: [versions add: (parts at: ind).  true]
				ifFalse: [false]]
			ifTrue: [false]] whileTrue.
		aServerDirectory moveYoungest: 3 in: versions to: repository.
		ind > list size] whileFalse.
! !


!Project class methodsFor: 'utilities' stamp: 'di 6/13/1998 11:29'!
addItem: item toMenu: menu selection: action
	(menu isKindOf: MenuMorph)
		ifTrue: [menu add: item selector: #jumpToSelection: argument: action]
		ifFalse: [menu add: item action: action]! !

!Project class methodsFor: 'utilities' stamp: 'dgd 7/28/2005 13:07'!
addItem: item toMenu: menu selection: action project: aProject 
	| color |
	color := aProject isMorphic
				ifTrue: [aProject world isInMemory
						ifTrue: [Color black]
						ifFalse: [Color brown]]
				ifFalse: [aProject world isInMemory
						ifTrue: [Color veryVeryDarkGray]
						ifFalse: [Color blue]].
	(menu isKindOf: MenuMorph)
		ifTrue: [| thumbnail | 
			menu
				add: item
				selector: #jumpToSelection:
				argument: action.
			menu lastItem color: color.
			thumbnail := aProject thumbnail.
			thumbnail isNil
				ifFalse: [menu lastItem
						icon: (thumbnail scaledIntoFormOfSize: (Preferences tinyDisplay ifTrue: [16] ifFalse: [28]))]]
		ifFalse: [menu add: item action: action]! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/16/2000 12:04'!
addingProject: newProject

	(self allProjects includes: newProject) ifTrue: [^self].
	AllProjects _ self allProjects copyWith: newProject.! !

!Project class methodsFor: 'utilities' stamp: 'tk 10/26/1999 14:25'!
advanceToNextProject
	| nextProj |
	(nextProj _ CurrentProject nextProject) ifNotNil:
		 [nextProj enter: true revert: false saveForRevert: false]
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/14/2000 19:14'!
allMorphicProjects

	^ self allProjects select: [:p | p world isMorph]! !

!Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:30'!
allNames
	^ (self allProjects collect: [:p | p name]) asSortedCollection: [:n1 :n2 | n1 asLowercase < n2 asLowercase]! !

!Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:30'!
allNamesAndProjects
	^ (self allProjects asSortedCollection: [:p1 :p2 | p1 name asLowercase < p2 name asLowercase]) collect:
		[:aProject | Array with: aProject name with: aProject]! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/13/2000 17:14'!
allProjects

	^AllProjects ifNil: [
		Smalltalk garbageCollect.
		AllProjects _ self allSubInstances select: [:p | p name notNil].
	].! !

!Project class methodsFor: 'utilities' stamp: 'jla 5/28/2001 21:48'!
allProjectsOrdered
	"Answer a list of all projects in hierarchical order, depth first"
	
	| allProjects  |
	allProjects _ OrderedCollection new.
	Project topProject withChildrenDo:
		[:p | allProjects add: p].
	^ allProjects

"
Project allProjectsOrdered
"! !

!Project class methodsFor: 'utilities' stamp: 'dgd 11/6/2004 20:49'!
buildJumpToMenu: menu
	"Make the supplied menu offer a list of potential projects, consisting of:
		*	The previous-project chain
		*	The next project, if any
		*	The parent project, if any
		*	All projects, alphabetically or hierarchically"

	| prev listed i next  toAdd |
	listed _ OrderedCollection with: CurrentProject.
	i _ 0.

	"The previous Project chain"
	prev _ CurrentProject previousProject.
	[(prev ~~ nil and: [(listed includes: prev) not])] whileTrue:
	  [i _ i + 1.
		listed add: prev.
		self 	addItem: prev name , ' (', ('back {1}' translated format:{i}  ), ')'
				toMenu: menu 
				selection: ('%back' , i printString) 
				project: prev.
		prev _ prev previousProject].
	i > 0 ifTrue: [menu addLine].


	"Then the next Project"
	(((next _ CurrentProject nextProject) ~~ nil) and: [(listed includes: next) not]) ifTrue:
		[self	addItem: (next name, ' (', ('forward {1}' translated format:{1}), ')') 
				toMenu: menu 
				selection: next name 
				project: next]. 
	next ~~ nil ifTrue: [menu addLine].

	"Then the parent"
	CurrentProject isTopProject ifFalse: 
		[self	addItem: CurrentProject parent name , ' (', 'parent' translated, ')' 
				toMenu: menu 
				selection: #parent 
				project: CurrentProject parent.
		  menu addLine].

	"Finally all the projects, in hierarchical or alphabetical order:"
	(Preferences alphabeticalProjectMenu
			ifTrue:
				[Project allNamesAndProjects]
			ifFalse:
				[Project hierarchyOfNamesAndProjects]) do:

		[:aPair | 
			toAdd _ aPair last isCurrentProject
				ifTrue:
				  [aPair first, ' (', 'current' translated, ')']
				ifFalse:
				  [aPair first].
			self	addItem: toAdd 
				toMenu: menu 
				selection: aPair first 
				project: aPair last].
	^ menu! !

!Project class methodsFor: 'utilities' stamp: 'RAA 7/25/2000 10:02'!
canWeLoadAProjectNow

	Smalltalk verifyMorphicAvailability ifFalse: [^ false].

	"starting to see about eliminating the below"
	"Smalltalk isMorphic ifFalse: [
		self inform: 'Later, allow jumping from MVC to Morphic Projects.'.
		^false
	]."

	^true
! !

!Project class methodsFor: 'utilities' stamp: 'sw 9/12/2001 23:05'!
chooseNaturalLanguage
	"Have the current project choose a new natural language"

	self current chooseNaturalLanguage! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/13/2000 17:26'!
deletingProject: outgoingProject

	ImageSegment allSubInstancesDo: [:seg |
		seg ifOutPointer: outgoingProject thenAllObjectsDo: [:obj |
			(obj isKindOf: ProjectViewMorph) ifTrue: [
				obj deletingProject: outgoingProject.  obj abandon].
			obj class == Project ifTrue: [obj deletingProject: outgoingProject]]].
	Project allProjects do: [:p | p deletingProject: outgoingProject].	"ones that are in"
	ProjectViewMorph allSubInstancesDo: [:p | 
		p deletingProject: outgoingProject.
		p project == outgoingProject ifTrue: [p abandon]].

	AllProjects _ self allProjects copyWithout: outgoingProject.! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 09:52'!
enter: aString
	"Enter the project with the given name"
	^ ((self named: aString) ifNil: [^ CurrentProject]) enter! !

!Project class methodsFor: 'utilities' stamp: 'RAA 12/26/2000 12:42'!
forget: aProject

	AllProjects _ self allProjects reject: [ :x | x == aProject].
! !

!Project class methodsFor: 'utilities' stamp: 'dgd 11/5/2004 15:03'!
hierarchyOfNamesAndProjects
	"Answer a list of all project names, with each entry preceded  
	by white space commensurate with its depth beneath the top  
	project"
	^ self allProjectsOrdered
		select: [:project | (#('<no name -- garbage?>' 'Building with Squeak' 'Fun With Music' ) includes: project name) not]
		thenCollect: [:project | Array with: project nameAdjustedForDepth with: project]! !

!Project class methodsFor: 'utilities' stamp: 'dtl 4/3/2005 14:02'!
interruptName: labelString
	"Create a Notifier on the active scheduling process with the given label."

	^ self interruptName: labelString preemptedProcess: nil
! !

!Project class methodsFor: 'utilities' stamp: 'dtl 4/3/2005 16:27'!
interruptName: labelString preemptedProcess: theInterruptedProcess
	"Create a Notifier on the active scheduling process with the given label."
	| preemptedProcess projectProcess suspendingList |
	Smalltalk isMorphic ifFalse:
		[^ ScheduledControllers interruptName: labelString].
	ActiveHand ifNotNil:[ActiveHand interrupted].
	ActiveWorld _ World. "reinstall active globals"
	ActiveHand _ World primaryHand.
	ActiveHand interrupted. "make sure this one's interrupted too"
	ActiveEvent _ nil.

	projectProcess _ self uiProcess.	"we still need the accessor for a while"
	preemptedProcess _ theInterruptedProcess ifNil: [Processor preemptedProcess].
	"Only debug preempted process if its priority is >= projectProcess' priority"
	preemptedProcess priority < projectProcess priority ifTrue:[
		(suspendingList _ projectProcess suspendingList) == nil
			ifTrue: [projectProcess == Processor activeProcess
						ifTrue: [projectProcess suspend]]
			ifFalse: [suspendingList remove: projectProcess ifAbsent: [].
					projectProcess offList].
		preemptedProcess _ projectProcess.
	] ifFalse:[
		preemptedProcess suspend offList.
	].
	Debugger openInterrupt: labelString onProcess: preemptedProcess
! !

!Project class methodsFor: 'utilities' stamp: 'dgd 11/6/2004 21:29'!
jumpToProject
	"Project jumpToProject"
	"Present a list of potential projects and enter the one selected."
	| menu |
menu_MenuMorph new.
menu defaultTarget: self.
	menu := self buildJumpToMenu: menu.
	menu popUpInWorld! !

!Project class methodsFor: 'utilities' stamp: 'jla 4/2/2001 15:57'!
jumpToSelection: selection
	"Enter the project corresponding to this menu selection."
	
	"Project jumpToProject"
	| nBack prev pr |
	selection ifNil: [^ self].
	(selection beginsWith: '%back') ifTrue:
		[nBack _ (selection copyFrom: 6 to: selection size) asNumber.
		prev _ CurrentProject previousProject.
		1 to: nBack-1 do:
			[:i | prev ifNotNil: [prev _ prev previousProject]].
		prev ifNotNil: [prev enter: true revert: false saveForRevert: false]].
	selection = #parent ifTrue:
		[CurrentProject parent enter: false revert: false saveForRevert: false.
		^ self].
	(pr _ Project namedWithDepth: selection) ifNil: [^ self].
	pr enter: false revert: false saveForRevert: false! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 19:00'!
maybeForkInterrupt

	Preferences cmdDotEnabled ifFalse: [^self].
	Smalltalk isMorphic
		ifTrue: [[self interruptName: 'User Interrupt'] fork]
		ifFalse: [[ScheduledControllers interruptName: 'User Interrupt'] fork]! !

!Project class methodsFor: 'utilities' stamp: 'tk 3/10/2000 21:10'!
named: projName
	"Answer the project with the given name, or nil if there is no project of that given name."
	"(Project named: 'New Changes') enter"

	^ self allProjects
		detect: [:proj | proj name = projName]
		ifNone: [nil]
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/11/2000 23:05'!
named: projName in: aListOfProjects
	"Answer the project with the given name, or nil if there is no project of that given name."
	"Use given collection for speed until we get faster #allProjects"

	^ aListOfProjects
		detect: [:proj | proj name = projName]
		ifNone: [nil]
! !

!Project class methodsFor: 'utilities' stamp: 'jla 4/2/2001 15:57'!
namedWithDepth: projName
	"Answer the project with the given name, or nil if there is no project of that given name."
	"(Project named: 'New Changes') enter"

	^ self allProjects
		detect: [:proj | 
			  proj name = projName or:
				[proj nameAdjustedForDepth = projName]]
		ifNone: [nil]! !

!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 19:00'!
ofWorld: aPasteUpMorph
	"Find the project of a world."

	"Usually it is the current project"
	CurrentProject world == aPasteUpMorph ifTrue: [^ CurrentProject].

	"Inefficient enumeration if it is not..."
	^ self allProjects detect: [:pr |
		pr world isInMemory 
			ifTrue: [pr world == aPasteUpMorph]
			ifFalse: [false]]
		ifNone: [nil]! !

!Project class methodsFor: 'utilities' stamp: 'sbw 4/13/2003 12:53'!
projectHierarchy
	"Answer a string representing all the projects in the system in  
	hierarchical order."
	"Project projectHierarchy"
	^ String
		streamContents: [:aStream | self hierarchyOfNamesAndProjects
				do: [:aPair | aStream nextPutAll: aPair first;
						 cr]]! !

!Project class methodsFor: 'utilities' stamp: 'mir 11/26/2004 16:15'!
removeAll: projects
	"Project removeAll: (Project allSubInstances copyWithout: Project current)"

	AllProjects _ nil.
	Smalltalk garbageCollect.

	ProjectHistory currentHistory initialize.
	projects do: [:project |
		Project deletingProject: project.
		StandardScriptingSystem removePlayersIn: project].

	Smalltalk garbageCollect.
	Smalltalk garbageCollect.
! !

!Project class methodsFor: 'utilities' stamp: 'mir 11/26/2004 15:22'!
removeAllButCurrent
	"Project removeAllButCurrent"

	AllProjects _ nil.
	Smalltalk garbageCollect.

	self removeAll: (Project allSubInstances copyWithout: Project current).

	AllProjects _ nil.
	Smalltalk garbageCollect.

	Smalltalk garbageCollect.
	Project rebuildAllProjects.
	^AllProjects! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:28'!
resumeProcess: aProcess
	"Adopt aProcess as the project process -- probably because of proceeding from a debugger"

	UIProcess _ aProcess.
	UIProcess resume! !

!Project class methodsFor: 'utilities' stamp: 'tk 10/26/1999 14:25'!
returnToPreviousProject
	"Return to the project from which this project was entered. Do nothing if the current project has no link to its previous project."

	| prevProj |
	prevProj _ CurrentProject previousProject.
	prevProj ifNotNil: [prevProj enter: true revert: false saveForRevert: false].
! !

!Project class methodsFor: 'utilities' stamp: 'sw 9/7/2000 06:50'!
showProjectHierarchyInWindow
	"Open a window that displays the project hierarchy"

	| hierarchyString numberOfProjects |
	hierarchyString _ self projectHierarchy.
	numberOfProjects _ hierarchyString lineCount.
	((StringHolder new contents: hierarchyString)
		embeddedInMorphicWindowLabeled: 'Projects (', numberOfProjects printString, ') ', Date today printString, ' ', Time now printString)
			setWindowColor:  (Color r: 1.0 g: 0.829 b: 0.909);
			openInWorld: self currentWorld extent: (300 @ (((numberOfProjects * (TextStyle  defaultFont lineGrid + 4) min: (self currentWorld height - 50)))))

"Project showProjectHierarchyInWindow"
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:49'!
spawnNewProcess

	UIProcess _ [
		[World doOneCycle.  Processor yield.  false] whileFalse: [].
	] newProcess priority: Processor userSchedulingPriority.
	UIProcess resume! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:49'!
spawnNewProcessAndTerminateOld: terminate

	self spawnNewProcess.
	terminate
		ifTrue: [Processor terminateActive]
		ifFalse: [Processor activeProcess suspend]! !

!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 18:52'!
storeAllInSegments
	"Write out all Projects in this Image.
	Project storeAllInSegments.		"

	| all ff ll |
all _ Project allProjects.
Transcript show: 'Initial Space Left: ', (ff _ Smalltalk garbageCollect) printString; cr.
all do: [:proj |
	Transcript show: proj name; cr.
	proj storeSegment  "storeSegmentNoFile"].
Transcript show: 'After writing all: ', (ll _ Smalltalk garbageCollect) printString; cr.
Transcript show: 'Space gained: ', (ll - ff) printString; cr.
"some will come back in"! !

!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 19:00'!
topProject
	"Answer the top project.  There is only one"

	^ self allProjects detect: [:p | p isTopProject]! !

!Project class methodsFor: 'utilities' stamp: 'mir 6/21/2001 15:44'!
versionForFileName: version
	"Project versionForFileName: 7"
	| v |
	^String streamContents:[:s|
		v _ version printString.
		v size < 3 ifTrue:[v _ '0', v].
		v size < 3 ifTrue:[v _ '0', v].
		s nextPutAll: v.
	]
! !
StandardSystemController subclass: #ProjectController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!

!ProjectController methodsFor: 'control activity' stamp: 'rbb 2/16/2005 16:24'!
redButtonActivity
	| index |
	view isCollapsed ifTrue: [^ super redButtonActivity].
	(view insetDisplayBox containsPoint: Sensor cursorPoint)
		ifFalse: [^ super redButtonActivity].
	index _ (UIManager default chooseFrom: #('enter' 'jump to project...') lines: #()).
	index = 0 ifTrue: [^ self].

	"save size on enter for thumbnail on exit"
	model setViewSize: view insetDisplayBox extent.
	index = 1 ifTrue: [^ model enter: false revert: false saveForRevert: false].
	index = 2 ifTrue: [Project jumpToProject. ^ self].
! !
Notification subclass: #ProjectEntryNotification
	instanceVariableNames: 'projectToEnter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!ProjectEntryNotification commentStamp: '<historical>' prior: 0!
I provide a way to override the style of Project entry (which is buried deep in several different methods). My default is a normal full-screen enter.!


!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 18:55'!
defaultAction

	self resume: projectToEnter enter! !

!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 19:02'!
projectToEnter

	^projectToEnter! !

!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 18:53'!
projectToEnter: aProject

	projectToEnter _ aProject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectEntryNotification class
	instanceVariableNames: ''!

!ProjectEntryNotification class methodsFor: 'as yet unclassified' stamp: 'ajh 1/22/2003 23:52'!
signal: aProject

	| ex |
	ex := self new.
	ex projectToEnter: aProject.
	^ex signal: 'Entering ',aProject printString! !
Model subclass: #ProjectHistory
	instanceVariableNames: 'mostRecent'
	classVariableNames: 'ChangeCounter CurrentHistory'
	poolDictionaries: ''
	category: 'System-Support'!

!ProjectHistory methodsFor: 'accessing' stamp: 'RAA 9/27/2000 20:29'!
mostRecentCopy

	self cleanUp.
	^mostRecent copy! !

!ProjectHistory methodsFor: 'accessing' stamp: 'RAA 11/10/2000 10:11'!
mostRecentNames

	self cleanUp.
	^mostRecent collect: [ :each |
		each first
	].
! !

!ProjectHistory methodsFor: 'accessing' stamp: 'rbb 3/1/2005 11:10'!
mostRecentThread

	| projectNames threadName |
	self cleanUp.
	projectNames := (mostRecent collect: [ :each | {each first} ]) reversed.

	threadName := UIManager default 
		request: 'Please name this thread.' 
		initialAnswer: 'Recent projects @ ',Time now printString.
	threadName isEmptyOrNil ifTrue: [^nil].
	"rbb 3/1/2005 - Should be refactored to eliminate Morphic dependency"
	InternalThreadNavigationMorph know: projectNames as: threadName.
	^threadName
! !


!ProjectHistory methodsFor: 'initialize-release' stamp: 'RAA 7/10/2000 15:27'!
initialize

	mostRecent _ OrderedCollection new.
! !


!ProjectHistory methodsFor: 'project lifetime' stamp: 'RAA 9/27/2000 20:49'!
cleanUp

	| proj |

	mostRecent _ mostRecent reject: [ :each |
		proj _ each fourth first.
		proj isNil or: [proj world isNil]
	].
	self changed.
! !

!ProjectHistory methodsFor: 'project lifetime' stamp: 'RAA 9/27/2000 20:27'!
forget: aProject

	| newTuple |
	newTuple _ {
		aProject name.
		aProject thumbnail.
		aProject url.
		WeakArray with: aProject.
	}.
	mostRecent _ mostRecent reject: [ :each |
		each fourth first == aProject or: [
			each fourth first isNil & (each first = newTuple first)
		].
	].
	self changed.
	^newTuple! !

!ProjectHistory methodsFor: 'project lifetime' stamp: 'RAA 7/12/2000 10:17'!
remember: aProject

	| newTuple |

	newTuple _ self forget: aProject.
	mostRecent addFirst: newTuple.
	mostRecent size > 10 ifTrue: [mostRecent _ mostRecent copyFrom: 1 to: 10].
	self changed! !


!ProjectHistory methodsFor: 'updating' stamp: 'RAA 7/10/2000 15:57'!
changed

	ChangeCounter _ (ChangeCounter ifNil: [0]) + 1.
	super changed.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectHistory class
	instanceVariableNames: ''!

!ProjectHistory class methodsFor: 'accessing' stamp: 'RAA 7/10/2000 15:56'!
changeCounter

	^ChangeCounter ifNil: [ChangeCounter _ 0].! !

!ProjectHistory class methodsFor: 'accessing' stamp: 'nk 7/30/2004 21:51'!
currentHistory
	^CurrentHistory ifNil: [CurrentHistory := self new]! !


!ProjectHistory class methodsFor: 'project lifetime' stamp: 'RAA 7/12/2000 10:16'!
forget: aProject

	self currentHistory forget: aProject
! !

!ProjectHistory class methodsFor: 'project lifetime' stamp: 'RAA 7/10/2000 15:31'!
remember: aProject

	self currentHistory remember: aProject
! !
AbstractLauncher subclass: #ProjectLauncher
	instanceVariableNames: 'showSplash splashURL whichFlaps eToyAuthentificationServer'
	classVariableNames: 'SplashMorph'
	poolDictionaries: ''
	category: 'System-Download'!

!ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/23/2001 22:04'!
cancelLogin
	"This is fine - we just proceed here. Later we may do something utterly different ;-)"
	^self proceedWithLogin! !

!ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 9/5/2001 16:32'!
doEtoyLogin
	"Pop up the eToy login if we have a server that provides us with a known user list"

	"Find us a server who could do eToy authentification for us"
	eToyAuthentificationServer _ 
		(ServerDirectory localProjectDirectories, ServerDirectory servers values)
			detect:[:any| any hasEToyUserList]
			ifNone:[nil].
	eToyAuthentificationServer "no server provides user information"
		ifNil:[^self startUpAfterLogin].
	self prepareForLogin.
	EtoyLoginMorph 
		loginAndDo:[:userName| self loginAs: userName]
		ifCanceled:[self cancelLogin].! !

!ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 9/5/2001 16:05'!
loginAs: userName
	"Assuming that we have a valid user url; read its contents and see if the user is really there."
	| actualName userList |
	eToyAuthentificationServer ifNil:[
		self proceedWithLogin.
		^true].
	userList _ eToyAuthentificationServer eToyUserList.
	userList ifNil:[
		self inform:
'Sorry, I cannot find the user list.
(this may be due to a network problem)
Please hit Cancel if you wish to use Squeak.'.
		^false].
	"case insensitive search"
	actualName  _ userList detect:[:any| any sameAs: userName] ifNone:[nil].
	actualName isNil ifTrue:[
		self inform: 'Unknown user: ',userName.
		^false].
	Utilities authorName: actualName.
	eToyAuthentificationServer eToyUserName: actualName.
	self proceedWithLogin.
	^true! !

!ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/23/2001 22:06'!
prepareForLogin
	"Prepare for login - e.g., hide everything so only the login morph is visible."
	World submorphsDo:[:m| 
		m isLocked ifFalse:[m hide]]. "hide all those guys"
	World displayWorldSafely.
! !

!ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/24/2001 15:17'!
proceedWithLogin
	eToyAuthentificationServer _ nil.
	World submorphsDo:[:m| m show].
	WorldState addDeferredUIMessage: [self startUpAfterLogin].! !


!ProjectLauncher methodsFor: 'initialization' stamp: 'mir 8/24/2001 20:25'!
initialize
	super initialize.
	showSplash _ true.
	HTTPClient isRunningInBrowser
		ifTrue: [whichFlaps _ 'etoy']! !

!ProjectLauncher methodsFor: 'initialization' stamp: 'mir 8/24/2001 15:51'!
setupFlaps
	"Only called when the image has been launched in a browser.  If I am requested to show etoy flaps, then remove any pre-existing shared flaps and put up the supplies flap only.  if I am requested to show all flaps, then if flaps already exist, use them as is, else set up to show the default set of standard flaps."

	((whichFlaps = 'etoy')
		or: [Preferences eToyFriendly])
		ifTrue:
			[Flaps addAndEnableEToyFlaps].
	whichFlaps = 'all'
		ifTrue: [Flaps sharedFlapsAllowed
				ifFalse: [Flaps enableGlobalFlaps]]! !

!ProjectLauncher methodsFor: 'initialization' stamp: 'mir 8/23/2002 14:52'!
setupFromParameters
	(self includesParameter: 'showSplash')
		ifTrue: [showSplash _ (self parameterAt: 'showSplash') asUppercase = 'TRUE'].
	(self includesParameter: 'flaps')
		ifTrue: [whichFlaps _ (self parameterAt: 'flaps')].
! !


!ProjectLauncher methodsFor: 'running' stamp: 'mir 4/3/2001 15:15'!
hideSplashMorph
	SplashMorph ifNil:[^self].
	self showSplash
		ifFalse: [^self].
	SplashMorph delete.
	World submorphs do:[:m| m visible: true]. "show all"
! !

!ProjectLauncher methodsFor: 'running' stamp: 'ar 3/16/2001 12:42'!
installProjectFrom: loader
	self showSplashMorph.
	[[[
		loader installProject
	] on: ProjectViewOpenNotification
	  do:[:ex| ex resume: false] "no project view in plugin launcher"
	] on: ProgressInitiationException "no 'reading aStream' nonsense"
	  do:[:ex| ex sendNotificationsTo: [ :min :max :curr |]]
	] on: ProjectEntryNotification "hide splash morph when entering project"
       do:[:ex| self hideSplashMorph. ex pass].! !

!ProjectLauncher methodsFor: 'running' stamp: 'mir 4/3/2001 15:15'!
showSplashMorph
	SplashMorph ifNil:[^self].
	self showSplash
		ifFalse: [^self].
	World submorphs do:[:m| m visible: false]. "hide all"
	World addMorphCentered: SplashMorph.
	World displayWorldSafely.! !

!ProjectLauncher methodsFor: 'running' stamp: 'fc 3/12/2004 15:28'!
startUp
	World ifNotNil: [World install].
	Utilities authorName: ''.
	Preferences eToyLoginEnabled
		ifFalse:[^self startUpAfterLogin].
	self doEtoyLogin.! !

!ProjectLauncher methodsFor: 'running' stamp: 'KR 8/30/2005 17:41'!
startUpAfterLogin
	| scriptName loader isUrl |
	self setupFlaps.
	Preferences readDocumentAtStartup ifTrue: [
		HTTPClient isRunningInBrowser ifTrue:[
			self setupFromParameters.
			scriptName _ self parameterAt: 'src'.
			CodeLoader defaultBaseURL: (self parameterAt: 'Base').
		] ifFalse:[
			scriptName _ (SmalltalkImage current getSystemAttribute: 2) ifNil:[''].
			scriptName _ scriptName convertFromSystemString.
			scriptName isEmpty ifFalse:[
				"figure out if script name is a URL by itself"
				isUrl _ (scriptName asLowercase beginsWith:'http://') or:[
						(scriptName asLowercase beginsWith:'file://') or:[
						(scriptName asLowercase beginsWith:'ftp://')]].
				isUrl ifFalse:[scriptName _ 'file:',scriptName]].
		]. ]
	ifFalse: [ scriptName := '' ].

	scriptName isEmptyOrNil
		ifTrue:[^Preferences eToyFriendly ifTrue: [self currentWorld addGlobalFlaps]].
	loader _ CodeLoader new.
	loader loadSourceFiles: (Array with: scriptName).
	(scriptName asLowercase endsWith: '.pr') 
		ifTrue:[self installProjectFrom: loader]
		ifFalse:[loader installSourceFiles].
! !


!ProjectLauncher methodsFor: 'private' stamp: 'mir 4/3/2001 15:15'!
showSplash
	^showSplash! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectLauncher class
	instanceVariableNames: ''!

!ProjectLauncher class methodsFor: 'accessing' stamp: 'ar 3/15/2001 23:32'!
splashMorph
	^SplashMorph! !

!ProjectLauncher class methodsFor: 'accessing' stamp: 'ar 3/15/2001 23:33'!
splashMorph: aMorph
	SplashMorph _ aMorph.! !
Object subclass: #ProjectLoading
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectLoading class
	instanceVariableNames: ''!

!ProjectLoading class methodsFor: 'accessing' stamp: 'ar 2/27/2001 14:33'!
projectStreamFromArchive: archive
	| ext prFiles entry unzipped |
	ext _ FileDirectory dot, Project projectExtension.
	prFiles _ archive members select:[:any| any fileName endsWith: ext].
	prFiles isEmpty ifTrue:[^''].
	entry _ prFiles first.
	unzipped _ RWBinaryOrTextStream on: (ByteArray new: entry uncompressedSize).
	entry extractTo: unzipped.
	^unzipped reset! !

!ProjectLoading class methodsFor: 'accessing' stamp: 'RAA 2/20/2001 20:26'!
thumbnailFromUrl: urlString

	| fileName fileAndDir |

	"Load the project, and make a thumbnail to it in the current project.
ProjectLoading thumbnailFromUrl: 'http://www.squeak.org/Squeak2.0/2.7segments/SqueakEasy.extSeg'.
"

	Project canWeLoadAProjectNow ifFalse: [^ self].
	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project loading';
		withProgressDo: [
			ProgressNotification signal: '1:foundMostRecent'.
			fileName _ (urlString findTokens: '/') last.
			fileAndDir _ self bestAccessToFileName: fileName andDirectory: urlString.
			self
				openName: fileName 
				stream: fileAndDir first 
				fromDirectory: fileAndDir second
				withProjectView: nil.
		]

! !


!ProjectLoading class methodsFor: 'loading' stamp: 'RAA 2/20/2001 20:25'!
installRemoteNamed: remoteFileName from: aServer named: otherProjectName in: currentProject

	| fileAndDir |

	"Find the current ProjectViewMorph, fetch the project, install in ProjectViewMorph without changing size, and jump into new project."

	ProgressNotification signal: '1:foundMostRecent'.
	fileAndDir _ self bestAccessToFileName: remoteFileName andDirectory: aServer.
	^self 
		openName: remoteFileName 
		stream: fileAndDir first 
		fromDirectory: fileAndDir second
		withProjectView: (currentProject findProjectView: otherProjectName).
! !

!ProjectLoading class methodsFor: 'loading' stamp: 'RAA 2/20/2001 20:25'!
openFromDirectory: aDirectory andFileName: aFileName

	| fileAndDir |

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project loading';
		withProgressDo: [
			ProgressNotification signal: '1:foundMostRecent'.
			fileAndDir _ self bestAccessToFileName: aFileName andDirectory: aDirectory.
			self 
				openName: aFileName 
				stream: fileAndDir first 
				fromDirectory: fileAndDir second
				withProjectView: nil.
		]! !

!ProjectLoading class methodsFor: 'loading' stamp: 'RAA 2/19/2001 08:22'!
openFromFile: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView


	self error: 'use #openFromFile:fromDirectory:withProjectView:'
! !

!ProjectLoading class methodsFor: 'loading' stamp: 'CdG 10/17/2005 22:48'!
openName: aFileName stream: preStream fromDirectory: aDirectoryOrNil
withProjectView: existingView
	"Reconstitute a Morph from the selected file, presumed to be
represent a Morph saved via the SmartRefStream mechanism, and open it
in an appropriate Morphic world."

   	| morphOrList proj trusted localDir projStream archive mgr
projectsToBeDeleted baseChangeSet enterRestricted substituteFont
numberOfFontSubstitutes exceptions |
	(preStream isNil or: [preStream size = 0]) ifTrue: [
		ProgressNotification  signal: '9999 about to enter
project'.		"the hard part is over"
		^self inform:
'It looks like a problem occurred while
getting this project. It may be temporary,
so you may want to try again,' translated
	].
	ProgressNotification signal: '2:fileSizeDetermined
',preStream size printString.
	preStream isZipArchive
		ifTrue:[	archive := ZipArchive new readFrom: preStream.
				projStream := self
projectStreamFromArchive: archive]
		ifFalse:[projStream := preStream].
	trusted := SecurityManager default positionToSecureContentsOf:
projStream.
	trusted ifFalse:
		[enterRestricted := (preStream isTypeHTTP or:
[aFileName isNil])
			ifTrue: [Preferences securityChecksEnabled]
			ifFalse: [Preferences standaloneSecurityChecksEnabled].
		enterRestricted
			ifTrue: [SecurityManager default enterRestrictedMode
				ifFalse:
					[preStream close.
					^ self]]].

	localDir := Project squeakletDirectory.
	aFileName ifNotNil: [
		(aDirectoryOrNil isNil or: [aDirectoryOrNil pathName
~= localDir pathName]) ifTrue: [
			localDir deleteFileNamed: aFileName.
			(localDir fileNamed: aFileName) binary
				nextPutAll: preStream contents;
				close.
		].
	].
	morphOrList := projStream asUnZippedStream.
	preStream sleep.		"if ftp, let the connection close"
	ProgressNotification  signal: '3:unzipped'.
	ResourceCollector current: ResourceCollector new.
	baseChangeSet := ChangeSet current.
	self useTempChangeSet.		"named zzTemp"
	"The actual reading happens here"
	substituteFont := Preferences standardEToysFont copy.
	numberOfFontSubstitutes := 0.
	exceptions := Set new.
	[[morphOrList := morphOrList fileInObjectAndCodeForProject]
		on: FontSubstitutionDuringLoading do: [ :ex |
				exceptions add: ex.
				numberOfFontSubstitutes :=
numberOfFontSubstitutes + 1.
				ex resume: substituteFont ]]
			ensure: [ ChangeSet  newChanges: baseChangeSet].
	mgr := ResourceManager new initializeFrom: ResourceCollector current.
	mgr fixJISX0208Resource.
	mgr registerUnloadedResources.
	archive ifNotNil:[mgr preLoadFromArchive: archive cacheName:
aFileName].
	(preStream respondsTo: #close) ifTrue:[preStream close].
	ResourceCollector current: nil.
	ProgressNotification  signal: '4:filedIn'.
	ProgressNotification  signal: '9999 about to enter project'.
		"the hard part is over"
	(morphOrList isKindOf: ImageSegment) ifTrue: [
		proj := morphOrList arrayOfRoots
			detect: [:mm | mm isKindOf: Project]
			ifNone: [^self inform: 'No project found in
this file'].
		proj projectParameters at: #substitutedFont put: (
			numberOfFontSubstitutes > 0
				ifTrue: [substituteFont]
				ifFalse: [#none]).
		proj projectParameters at: #MultiSymbolInWrongPlace put: false.
			"Yoshiki did not put MultiSymbols into
outPointers in older images!!"
		morphOrList arrayOfRoots do: [:obj |
			obj fixUponLoad: proj seg: morphOrList "imageSegment"].
		(proj projectParameters at: #MultiSymbolInWrongPlace) ifTrue: [
			morphOrList arrayOfRoots do: [:obj | (obj
isKindOf: Set) ifTrue: [obj rehash]]].

		proj resourceManager: mgr.
		"proj versionFrom: preStream."
		proj lastDirectory: aDirectoryOrNil.
		proj setParent: Project current.
		projectsToBeDeleted := OrderedCollection new.
		existingView ifNil: [
			Smalltalk isMorphic ifTrue: [
				proj createViewIfAppropriate.
			] ifFalse: [
				ChangeSet allChangeSets add: proj changeSet.
				ProjectView openAndEnter: proj.
				"Note: in MVC we get no further than the above"
			].
		] ifNotNil: [
			(existingView project isKindOf: DiskProxy) ifFalse: [
				existingView project changeSet name: 
ChangeSet defaultName.
				projectsToBeDeleted add: existingView project.
			].
			(existingView owner isSystemWindow) ifTrue: [
				existingView owner model: proj
			].
			existingView project: proj.
		].
		ChangeSet allChangeSets add: proj changeSet.
		Project current projectParameters
			at: #deleteWhenEnteringNewProject
			ifPresent: [ :ignored |
				projectsToBeDeleted add: Project current.
				Project current removeParameter:
#deleteWhenEnteringNewProject.
			].
		projectsToBeDeleted isEmpty ifFalse: [
			proj projectParameters
				at: #projectsToBeDeleted
				put: projectsToBeDeleted.
		].
		^ ProjectEntryNotification signal: proj
	].

	(morphOrList isKindOf: SqueakPage) ifTrue: [
		morphOrList := morphOrList contentsMorph
	].
	(morphOrList isKindOf: PasteUpMorph) ifFalse:
		[^ self inform: 'This is not a PasteUpMorph or
exported Project.' translated].
	(Project newMorphicOn: morphOrList) enter
! !


!ProjectLoading class methodsFor: 'utilities' stamp: 'gk 10/21/2005 11:18'!
bestAccessToFileName: aFileName andDirectory: aDirectoryOrUrlString
	"Answer an array with a stream and a directory. The directory can be nil."
	
	| dir url |
	dir _ Project squeakletDirectory.
	(dir fileExists: aFileName) ifTrue: [
		^{dir readOnlyFileNamed: aFileName. dir}].

	aDirectoryOrUrlString isString ifFalse: [
		^{aDirectoryOrUrlString readOnlyFileNamed: aFileName. aDirectoryOrUrlString}].

	url _ Url absoluteFromFileNameOrUrlString: aDirectoryOrUrlString.

	(url scheme = 'file') ifTrue: [
		dir := FileDirectory on: url pathForDirectory.
		^{dir readOnlyFileNamed: aFileName. dir}].

	(url path anySatisfy: [:each | each = 'SuperSwikiProj']) ifTrue: [
		dir _ SuperSwikiServer new fullPath: url directoryUrl asString.
		^{dir readOnlyFileNamed: url fileName. nil}].

	^{ServerFile new fullPath: aDirectoryOrUrlString. nil}! !

!ProjectLoading class methodsFor: 'utilities' stamp: 'ar 9/27/2005 20:10'!
useTempChangeSet
	"While reading the project in, use the temporary change set zzTemp"

	| zz |
	zz := ChangeSet named: 'zzTemp'.
	zz ifNil: [zz := ChangeSet basicNewChangeSet: 'zzTemp'].
	ChangeSet  newChanges: zz.! !
AlignmentMorphBob1 subclass: #ProjectNavigationMorph
	instanceVariableNames: 'mouseInside soundSlider'
	classVariableNames: 'LastManualPlacement'
	poolDictionaries: ''
	category: 'MorphicExtras-Navigators'!

!ProjectNavigationMorph methodsFor: 'accessing' stamp: 'RAA 7/5/2000 16:24'!
color: newColor

	| buttonColor |

	super color: newColor.
	buttonColor _ color darker.
	self submorphsDo: [:m | m submorphsDo: [:n | n color: buttonColor]]! !


!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:19'!
addButtons

	self orientedVertically ifTrue: [
		self addAColumn: (
			self makeTheButtons collect: [ :x | self inAColumn: {x}]
		)
	] ifFalse: [
		self addARow: (
			self makeTheButtons collect: [ :x | self inAColumn: {x}]
		)
	].
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/27/2000 17:54'!
amountToShowWhenSmall

	^7	"if no part of the buttons is visible, we chew up fewer cycles"! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'dao 10/1/2004 12:57'!
checkForRebuild
	| lastScreenMode flapsSuppressed |

	lastScreenMode _ ScreenController lastScreenModeSelected ifNil: [false].
	flapsSuppressed _ Project current flapsSuppressed.
	((self valueOfProperty: #currentNavigatorVersion) = self currentNavigatorVersion
			and: [lastScreenMode = self inFullScreenMode
			and: [flapsSuppressed = self inFlapsSuppressedMode
			and: [(self valueOfProperty: #includeSoundControlInNavigator) = 
						Preferences includeSoundControlInNavigator]]]) ifFalse: [
		self 
			setProperty: #includeSoundControlInNavigator 
			toValue: Preferences includeSoundControlInNavigator.
		self setProperty: #flapsSuppressedMode toValue: flapsSuppressed.
		self setProperty: #showingFullScreenMode toValue: lastScreenMode.
		self setProperty: #currentNavigatorVersion toValue: self currentNavigatorVersion.
		self removeAllMorphs.
		self addButtons.
	].
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/26/2000 18:51'!
colorForButtons

	^color darker! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'sw 1/31/2006 03:09'!
currentNavigatorVersion
	"Answer the current navigator version."

	^ 31		"since these guys get saved, we fix them up if they are older versions"! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/26/2000 18:52'!
fontForButtons

	^TextStyle defaultFont! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 08:26'!
inFlapsSuppressedMode

	^(self valueOfProperty: #flapsSuppressedMode) == true! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 00:03'!
inFullScreenMode

	^(self valueOfProperty: #showingFullScreenMode) == true! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'yo 7/2/2004 20:01'!
makeButton: aString balloonText: anotherString for: aSymbol

	self flag: #yo.
	"In principle, this method shouldn't call #translated."

	^ SimpleButtonDelayedMenuMorph new target: self;
		 borderColor: #raised;
		 color: self colorForButtons;
		 label: aString translated font: self fontForButtons;
		 setBalloonText: anotherString translated;
		 actionSelector: aSymbol! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'sw 1/31/2006 02:32'!
makeUpdatingButtonWithBalloonText: balloonString actionSelector: actionSymbol wordingSelector: wordingSymbol
	"Answer a button  whose target is the receiver (i.e. a ProjectNavigationMorph), who gets its wording by sending the wordingSelector to me.  The given string"

	| aButton |
	aButton _ UpdatingSimpleButtonMorph new.
	aButton
		target: self;
		borderColor: #raised;
		color: self colorForButtons;
		label: '-' font: self fontForButtons;
		setBalloonText: balloonString translated;
		actionSelector: actionSymbol;
		wordingSelector: wordingSymbol.
	aButton step.
	^ aButton
	
	! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/30/2003 21:59'!
orientationString
	^ (self orientedVertically
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'vertical orientation' translated! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:18'!
orientedVertically

	^self valueOfProperty: #orientedVertically ifAbsent: [false]
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:26'!
positionVertically

	| wb stickToTop |

	owner == self world ifFalse: [^self].
	wb _ self worldBounds.
	stickToTop _ self valueOfProperty: #stickToTop.
	stickToTop ifNil: [
		stickToTop _ (self top - wb top) abs < (self bottom - wb bottom) abs.
		self setProperty: #stickToTop toValue: stickToTop.
	].
	mouseInside == true ifTrue: [
		stickToTop ifTrue: [
			self top: wb top
		] ifFalse: [
			self bottom: wb bottom
		].
	] ifFalse: [
		stickToTop ifTrue: [
			self bottom: wb top + self amountToShowWhenSmall
		] ifFalse: [
			self top: wb bottom - self amountToShowWhenSmall
		].
	].

! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/6/2001 14:16'!
retractIfAppropriate

	mouseInside _ false.
	self positionVertically.
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/17/2001 12:44'!
showMenuFor: aSymbol event: evt

	(aSymbol == #publishProject or: [aSymbol == #publishProjectSimple]) ifTrue: [
		self doPublishButtonMenuEvent: evt.
		^true		"we did show the menu"
	].
	(aSymbol == #findAProject or: [aSymbol == #findAProjectSimple]) ifTrue: [
		self doFindButtonMenuEvent: evt.
		^true		"we did show the menu"
	].
	^false
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:18'!
toggleOrientation

	self setProperty: #orientedVertically toValue: self orientedVertically not.
	self setProperty: #currentNavigatorVersion toValue: self currentNavigatorVersion - 1.

! !


!ProjectNavigationMorph methodsFor: 'buttons' stamp: 'tak 3/15/2005 01:22'!
makeTheAdvancedButtons

	^{
		self buttonNewProject.
		self buttonShare.
		self buttonPrev.
		self buttonNext.
		self buttonPublish.
		self buttonNewer.
		self buttonTell.
		self buttonFind.
		self buttonFullScreen.
		"self buttonFlaps."
		self buttonPaint.
	},
	(
		Preferences includeSoundControlInNavigator ifTrue: [{self buttonSound}] ifFalse: [#()]
	),
	{
		self buttonLanguage.
		self buttonUndo.
		self buttonQuit.
	}
! !

!ProjectNavigationMorph methodsFor: 'buttons' stamp: 'tak 3/15/2005 01:40'!
makeTheButtons
	^ Preferences showAdvancedNavigatorButtons
		ifTrue: [self makeTheAdvancedButtons]
		ifFalse: [self makeTheSimpleButtons]! !

!ProjectNavigationMorph methodsFor: 'buttons' stamp: 'ar 7/28/2005 10:51'!
makeTheSimpleButtons

	^{
		self buttonNewProject.

		self buttonPrev.
		self buttonNext.
		self buttonPublish.
		self buttonFind.
		self buttonFullScreen.

		self buttonPaint.
	},
	(
		Preferences includeSoundControlInNavigator ifTrue: [{self buttonSound}] ifFalse: [#()]
	),
	{
		self buttonLanguage.
		self buttonUndo.
		self buttonQuit.
	}
! !


!ProjectNavigationMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 1/9/2001 07:47'!
justDroppedInto: aMorph event: anEvent

	self setProperty: #stickToTop toValue: nil.
	self positionVertically.
	LastManualPlacement _ {self position. self valueOfProperty: #stickToTop}.
	super justDroppedInto: aMorph event: anEvent.
	self step! !


!ProjectNavigationMorph methodsFor: 'event handling' stamp: 'RAA 6/29/2000 11:11'!
handlesMouseOver: evt

	^true! !

!ProjectNavigationMorph methodsFor: 'event handling' stamp: 'RAA 6/30/2000 13:57'!
mouseEnter: evt

	(self worldBounds containsPoint: evt cursorPoint) ifFalse: [^self].
	mouseInside _ true.
	self positionVertically.
	! !

!ProjectNavigationMorph methodsFor: 'event handling' stamp: 'RAA 9/1/2000 07:51'!
mouseLeave: evt

	self world ifNil: [^self].		"can happen after delete from control menu"
	(self worldBounds containsPoint: evt cursorPoint) ifFalse: [^self].
	mouseInside _ false.
	self positionVertically.
! !


!ProjectNavigationMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color orange! !

!ProjectNavigationMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:30'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self layoutInset: 6;
	  hResizing: #shrinkWrap;
	  vResizing: #shrinkWrap;
	  useRoundedCorners.
	mouseInside _ false.
	self addButtons! !

!ProjectNavigationMorph methodsFor: 'initialization' stamp: 'RAA 9/15/2000 21:43'!
openInWorld: aWorld

	LastManualPlacement ifNotNil: [
		self position: LastManualPlacement first.
		self setProperty: #stickToTop toValue: LastManualPlacement second.
	].
	super openInWorld: aWorld.! !


!ProjectNavigationMorph methodsFor: 'menus' stamp: 'RAA 1/9/2001 08:15'!
addCustomMenuItems: aMenu hand: aHandMorph

	"Add further items to the menu as appropriate"

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu 
		addUpdating: #orientationString 
		action: #toggleOrientation.
! !


!ProjectNavigationMorph methodsFor: 'stepping and presenter' stamp: 'RAA 8/23/2001 18:11'!
step
	| wb |

	owner ifNil: [^ self].
	(self ownerThatIsA: HandMorph) ifNotNil: [^self].
	self checkForRebuild.
	owner == self world ifTrue: [
		owner addMorphInLayer: self.
		wb _ self worldBounds.
		self left < wb left ifTrue: [self left: wb left].
		self right > wb right ifTrue: [self right: wb right].
		self positionVertically.
	].! !

!ProjectNavigationMorph methodsFor: 'stepping and presenter' stamp: 'sw 1/31/2006 04:06'!
undoButtonWording
	"Answer the wording for the Undo button."

	| wdng |
	wdng _ ActiveWorld commandHistory undoOrRedoMenuWording.
	(wdng endsWith: ' (z)') ifTrue:
		[wdng _ wdng copyFrom: 1to: wdng size - 4].
	^ wdng! !


!ProjectNavigationMorph methodsFor: 'testing' stamp: 'RAA 5/18/2000 11:43'!
stepTime

	^1000! !

!ProjectNavigationMorph methodsFor: 'testing' stamp: 'RAA 5/18/2000 11:43'!
wantsSteps

	^true! !


!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'mir 1/2/2004 13:54'!
chooseLanguage

	Project current chooseNaturalLanguage! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'dgd 8/27/2004 18:35'!
doFindButtonMenuEvent: evt

	| menu selection |

	menu _ CustomMenu new.
	menu 
		add: 'find a project' translated action: [self findAProjectSimple];
		add: 'find a project (more places)' translated action: [self findAProject];
		add: 'find any file' translated action: [self findAnything];
		add: 'search the SuperSwiki' translated action: [self findSomethingOnSuperSwiki].

	selection _ menu build startUpCenteredWithCaption: 'Find options' translated.
	selection ifNil: [^self].
	selection value.

! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'yo 2/17/2005 15:40'!
doNewPainting
	
	| w f |

	w _ self world.
	w assureNotPaintingElse: [^ self].
	(f _ self owner flapTab) ifNotNil: [f hideFlap].
	w makeNewDrawing: (self primaryHand lastEvent copy setPosition: w center)
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'yo 2/10/2005 15:42'!
doPublishButtonMenuEvent: evt

	| menu selection |

	menu _ CustomMenu new.
	menu 
		add: 'Publish' translated action: [self publishProject];
		add: 'Publish As...' translated action: [self publishProjectAs];
		add: 'Publish to Different Server' translated action: [self publishDifferent];
		add: 'edit project info' translated action: [self editProjectInfo].
	selection _ menu build startUpCenteredWithCaption: 'Publish options' translated.
	selection ifNil: [^self].
	selection value.

! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 12/24/2000 09:33'!
editProjectInfo

	EToyProjectDetailsMorph 
		getFullInfoFor: (self world ifNil: [^self]) project
		ifValid: []
		expandedFormat: true
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 2/17/2001 12:27'!
findAProject

	FileList2 
		morphicViewProjectLoader2InWorld: self world 
		reallyLoad: true
		dirFilterType: #initialDirectoryList! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 2/17/2001 12:27'!
findAProjectSimple

	FileList2 
		morphicViewProjectLoader2InWorld: self world 
		reallyLoad: true
		dirFilterType: #limitedSuperSwikiDirectoryList! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 7/24/2000 19:32'!
findAnything

	FileList2 morphicViewGeneralLoaderInWorld: self world! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 8/30/2000 15:32'!
fullScreenOff

	self setProperty: #showingFullScreenMode toValue: false.
	ScreenController new fullScreenOff.
	self removeProperty: #currentNavigatorVersion.
	mouseInside _ false.
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 8/30/2000 15:32'!
fullScreenOn

	self setProperty: #showingFullScreenMode toValue: true.
	ScreenController new fullScreenOn.
	self removeProperty: #currentNavigatorVersion.
	mouseInside _ false.
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'nb 6/17/2003 12:25'!
getNewerVersionIfAvailable

	(self world ifNil: [^Beeper beep]) project loadFromServer: true.

! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 9/19/2000 14:12'!
gotoAnother

	EToyProjectHistoryMorph new openInWorld! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 10/6/2000 13:55'!
newProject

	Project newMorphicOn: nil
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'nb 6/17/2003 12:25'!
nextProject

	Project advanceToNextProject.
	Beeper beep.! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'dao 10/1/2004 13:14'!
previousProject

	Project returnToPreviousProject.
	Project current exit.	"go to parent if no previous"
	Beeper beep.! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 5/16/2001 17:44'!
publishDifferent

	self 
		publishStyle: #initialDirectoryList 
		forgetURL: true
		withRename: false
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'yo 2/17/2005 14:55'!
publishProject

	self world paintBoxOrNil ifNotNil: [
		(self confirm: 'You seem to be painting a sketch.
Do you continue and publish the project with the paint tool?' translated) ifFalse: [^ self].
	].
	self 
		publishStyle: #limitedSuperSwikiPublishDirectoryList 
		forgetURL: false
		withRename: false! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'mir 6/25/2001 16:53'!
publishProjectAs

	self 
		publishStyle: #limitedSuperSwikiPublishDirectoryList 
		forgetURL: false
		withRename: true! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'mir 11/15/2004 10:25'!
publishStyle: aSymbol forgetURL: aBoolean withRename: renameBoolean

	| w saveOwner primaryServer rename |

	w _ self world ifNil: [^Beeper beep].
	w setProperty: #SuperSwikiPublishOptions toValue: aSymbol.

	primaryServer _ w project primaryServerIfNil: [nil].
	rename _ ((primaryServer notNil
		and: [primaryServer acceptsUploads]) not)
		or: [renameBoolean].
	w setProperty: #SuperSwikiRename toValue: rename.

	saveOwner _ owner.
	self delete.
	[w project 
		storeOnServerShowProgressOn: self 
		forgetURL: aBoolean | rename]
		ensure: [saveOwner addMorphFront: self]! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'sw 3/3/2004 14:19'!
quitSqueak
	"Obtain a confirmation from the user, and if the answer is true, quite Squeak summarily"

	(self confirm: 'Are you sure you want to Quit Squeak?' translated) ifFalse: [^ self].
	
	SmalltalkImage current snapshot: false andQuit: true
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 6/3/2000 10:54'!
tellAFriend

	self world project tellAFriend! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'dao 10/1/2004 13:45'!
toggleFlapsSuppressed

	Project current toggleFlapsSuppressed! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 2/19/2001 09:52'!
undoLastCommand
	
	self world commandHistory undoLastCommand! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'sw 1/31/2006 03:55'!
undoOrRedoLastCommand
	"Undo or redo the last command, as approrpiate."

	ActiveWorld commandHistory undoOrRedoCommand! !


!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'yo 2/10/2005 15:37'!
buttonFind
	"Answer a button for finding/loading projects"

	^ self makeButton: 'FIND' balloonText: 'Click here to find a project.  Hold down this button to reveal additional options.' translated for: #findAProjectSimple
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:42'!
buttonFlaps

	^self inFlapsSuppressedMode ifTrue: [
		self makeButton: 'Show tabs' balloonText: 'Show tabs' for: #toggleFlapsSuppressed
	] ifFalse: [
		self makeButton: 'Hide tabs' balloonText: 'Hide tabs' for: #toggleFlapsSuppressed
	].

! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:41'!
buttonFullScreen

	^self inFullScreenMode ifTrue: [
		self makeButton: 'Browser Reentry' balloonText: 'Re-enter the browser' for: #fullScreenOff
	] ifFalse: [
		self makeButton: 'Escape Browser' balloonText: 'Use the full screen' for: #fullScreenOn
	]

! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:53'!
buttonGoTo

	^self makeButton: 'GO TO' balloonText: 'Go to another project' for: #gotoAnother
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'dgd 4/3/2006 13:12'!
buttonLanguage
	"Answer a button for finding/loading projects"
	^ SimpleButtonDelayedMenuMorph new target: self;
		 borderColor: #raised;
		 color: self colorForButtons;
		 label: Project current naturalLanguage font: self fontForButtons;
		 setBalloonText: 'Click here to choose your language.' translated;
		 actionSelector: #chooseLanguage! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 7/16/2001 14:06'!
buttonNewProject

	^self makeButton: 'NEW' balloonText: 'Start a new project' for: #newProject
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:37'!
buttonNewer

	^self makeButton: 'Newer?' balloonText: 'Is there a newer version of this project ?' for: #getNewerVersionIfAvailable! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 14:04'!
buttonNext

	^self makeButton: 'NEXT >' balloonText: 'Next project' for: #nextProject! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 11/8/2000 09:53'!
buttonPaint

	| pb oldArgs brush myButton m |

	myButton _ self makeButton: '' balloonText: 'Make a painting' for: #doNewPainting.
	pb _ PaintBoxMorph new submorphNamed: #paint:.
	pb ifNil: [
		(brush _ Form extent: 16@16 depth: 16) fillColor: Color red
	] ifNotNil: [
		oldArgs _ pb arguments.
		brush _ oldArgs third.
		brush _ brush copy: (2@0 extent: 42@38).
		brush _ brush scaledToSize: brush extent // 2.
	].
	myButton addMorph: (m _ brush asMorph lock).
	myButton extent: m extent + (myButton borderWidth + 6).
	m position: myButton center - (m extent // 2).

	^myButton

"brush _ (ScriptingSystem formAtKey: 'Painting')."

! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 14:04'!
buttonPrev

	^self makeButton: '< PREV' balloonText: 'Previous project' for: #previousProject! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'yo 2/10/2005 15:42'!
buttonPublish
	"Answer a button for publishing the project"

	^ self makeButton: 'PUBLISH IT!!' translated balloonText: 'Click here to save a project.  Hold down this button to reveal additional publishing options' translated for: #publishProject! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 14:03'!
buttonQuit

	^self makeButton: 'QUIT' balloonText: 'Quit Squeak altogether' for: #quitSqueak
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:38'!
buttonTell

	^self makeButton: 'Tell!!' balloonText: 'Tell a friend about this project' for: #tellAFriend
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'sw 1/31/2006 03:54'!
buttonUndo
	"Build and return a fresh Undo button for me."

	^ self makeUpdatingButtonWithBalloonText:  'Undo or redo the last undoable action' actionSelector: #undoOrRedoLastCommand wordingSelector: #undoButtonWording

! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'dgd 8/27/2004 18:43'!
findSomethingOnSuperSwiki

	| projectServers server index |
	projectServers := ServerDirectory projectServers.
	projectServers isEmpty
		ifTrue: [^self].
	projectServers size = 1
		ifTrue: [server := projectServers first]
		ifFalse: [index := (PopUpMenu labelArray: (projectServers collect: [:each | (ServerDirectory nameForServer: each) translatedIfCorresponds]) lines: #()) 
				startUpWithCaption: 'Choose a super swiki:' translated.
			index > 0
				ifTrue: [server := projectServers at: index]
				ifFalse: [^self]].
	EToyProjectQueryMorph onServer: server! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'bf 10/8/2004 12:47'!
languageIcon
	^ (ColorForm
	extent: 19@18
	depth: 4
	fromArray: #( 4294967295 4294967295 4293918720 4294967206 2183331839 4293918720 4294946286 3972145919 4293918720 4294631150 3430031919 4293918720 4289588973 3396477476 4293918720 4292799965 3399692836 4293918720 4208913868 724784466 804257792 4141735107 858993445 804257792 4140616899 1127429205 804257792 4174171340 3006481493 804257792 4174171340 3274982741 804257792 4170435788 3409204562 804257792 4280497100 1429493074 4293918720 4280431429 1429558562 4293918720 4294059093 1431654959 4293918720 4294919237 1431446271 4293918720 4294967074 572719103 4293918720 4294967295 4294967295 4293918720)
	offset: 0@0)
	colorsFromArray: #(#(0.0 0.0 0.0) #(1.0 1.0 1.0) #(0.376 0.376 0.784) #(0.357 0.357 0.733) #(0.231 0.231 0.474) #(0.494 0.494 0.964) #(0.498 0.498 0.933) #(0.376 0.376 0.706) #(0.419 0.419 0.78) #(0.415 0.415 0.776) #(0.595 0.595 0.972) #(0.638 0.638 0.968) #(0.654 0.654 0.96) #(0.686 0.686 0.96) #(0.71 0.71 0.964) #( )  )! !


!ProjectNavigationMorph methodsFor: 'WiW support' stamp: 'RAA 10/3/2000 09:24'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^mouseInside == true ifTrue: [26] ifFalse: [25]

		"Navigators are behind menus and balloons, but in front of most other stuff"! !


!ProjectNavigationMorph methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'RAA 9/19/2000 13:43'!
buttonShare

	^self makeButton: 'Share' 
		balloonText: 'Share this project so that others can explore it with you.' 
		for: #shareThisWorld
! !

!ProjectNavigationMorph methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'RAA 8/4/2000 15:24'!
shareThisWorld

	NebraskaServerMorph serveWorld: self world! !


!ProjectNavigationMorph methodsFor: '*sound' stamp: 'stephaneducasse 2/4/2006 20:40'!
buttonSound

	| myButton m |

	myButton := RectangleMorph new 
		borderWidth: 1;
		cornerStyle: #rounded;
		borderColor: #raised;
		color: self colorForButtons;
		setBalloonText: 'Change sound volume' translated;
		on: #mouseDown send: #soundDownEvt:morph: to: self;
		on: #mouseStillDown send: #soundStillDownEvt:morph: to: self;
		on: #mouseUp send: #soundUpEvt:morph: to: self;
		yourself.

	myButton addMorph: (m := self speakerIcon lock).
	myButton extent: m extent + (myButton borderWidth + 6).
	m position: myButton center - (m extent // 2).
	^myButton
! !

!ProjectNavigationMorph methodsFor: '*sound' stamp: 'ar 8/23/2001 23:52'!
getSoundVolume

	^SoundPlayer soundVolume average! !

!ProjectNavigationMorph methodsFor: '*sound' stamp: 'ar 8/23/2001 23:49'!
setSoundVolume: x

	SoundPlayer setVolumeLeft: x volumeRight: x.
! !

!ProjectNavigationMorph methodsFor: '*sound' stamp: 'stephaneducasse 2/4/2006 20:40'!
soundDownEvt: a morph: b

	soundSlider ifNotNil: [soundSlider delete].
	(soundSlider := RectangleMorph new)
		setProperty: #morphicLayerNumber toValue: 1;
		extent: b width @ (b width * 3);
		color: self colorForButtons;
		borderColor: #raised;
		bottomLeft: b boundsInWorld origin.
	soundSlider addMorph: (
		RectangleMorph new
			color: self colorForButtons;
			borderColor: #raised;
			extent: b width @ 8;
			center: soundSlider center x @ 
				(soundSlider bottom - (soundSlider height * self getSoundVolume) asInteger)
	).
	soundSlider openInWorld.! !

!ProjectNavigationMorph methodsFor: '*sound' stamp: 'stephaneducasse 2/4/2006 20:40'!
soundStillDownEvt: evt morph: b

	| y pct |

	soundSlider ifNil: [^self].
	y := evt hand position y.
	(y between: soundSlider top and: soundSlider bottom) ifTrue: [
		pct := (soundSlider bottom - y) asFloat / soundSlider height.
		self setSoundVolume: pct.
		soundSlider firstSubmorph top: y - 5.
	]. 
! !

!ProjectNavigationMorph methodsFor: '*sound' stamp: 'stephaneducasse 2/4/2006 20:40'!
soundUpEvt: a morph: b

	soundSlider ifNotNil: [soundSlider delete].
	soundSlider := nil.
	Beeper beep ! !

!ProjectNavigationMorph methodsFor: '*sound' stamp: 'RAA 8/23/2001 17:05'!
speakerIcon


	^ImageMorph new
			image: (
(Form
	extent: 19@18
	depth: 8
	fromArray: #( 0 0 1493172224 0 0 0 0 1493172224 0 0 0 138 1493172224 0 0 0 35509 2315255808 0 0 0 9090522 2315255808 0 0 0 2327173887 2315255819 0 0 138 3051028442 2315255819 0 0 1505080590 4294957786 2315255808 184549376 0 3053453311 4292532917 1493172224 184549376 0 1505080714 3048584629 1493172224 184549376 0 9079434 3048584629 1493172224 184549376 0 138 2327164341 1493172235 0 0 0 2324346293 1493172235 0 0 0 9079477 1493172224 0 0 0 35466 1493172224 0 0 0 138 0 0 0 0 0 0 0 0 0 0 0 0 0)
	offset: 0@0)
			);
			setBalloonText: 'Quiet';
			on: #mouseUp send: #yourself to: 1
	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectNavigationMorph class
	instanceVariableNames: ''!

!ProjectNavigationMorph class methodsFor: 'as yet unclassified' stamp: 'mir 8/22/2001 18:09'!
preferredNavigator

	"Preferences eToyFriendly ifTrue: [^KidNavigationMorph]."
	^ProjectNavigationMorph! !
Notification subclass: #ProjectPasswordNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!ProjectPasswordNotification methodsFor: 'as yet unclassified' stamp: 'RAA 4/23/2001 16:47'!
defaultAction

	self resume: ''! !
BookPageSorterMorph subclass: #ProjectSorterMorph
	instanceVariableNames: 'sizeOfEachMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Navigators'!

!ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 19:44'!
addControls
	| b r partsBinButton newButton |

	newButton _ ImageMorph new image: (World project makeThumbnail scaledToSize: 24@18).
	newButton on: #mouseDown send: #insertNewProject: to: self.
	newButton setBalloonText: 'Make a new Project' translated.
	(partsBinButton _ UpdatingThreePhaseButtonMorph checkBox)
		target: self;
		actionSelector: #togglePartsBinStatus;
		arguments: #();
		getSelector: #getPartsBinStatus.
	(r _ AlignmentMorph newRow)
		color: Color transparent;
		borderWidth: 0;
		layoutInset: 0;
		wrapCentering: #center;
		cellPositioning: #topCenter;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		extent: 5@5.
	b _ SimpleButtonMorph new target: self; color: self defaultColor darker;
			borderColor: Color black.
	r addMorphBack: (self wrapperFor: (b label: 'Okay' translated;	actionSelector: #acceptSort)).
	b _ SimpleButtonMorph new target: self; color: self defaultColor darker;
			borderColor: Color black.
	r addMorphBack: (self wrapperFor: (b label: 'Cancel' translated;	actionSelector: #delete));
		addMorphBack: (self wrapperFor: (newButton));
		addTransparentSpacerOfSize: 8 @ 0;
		addMorphBack: (self wrapperFor: partsBinButton);
		addMorphBack: (self wrapperFor: (StringMorph contents: 'Parts bin' translated) lock).

	self addMorphFront: r.
! !

!ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/24/2001 22:19'!
clickFromSorterEvent: evt morph: aMorph

	| where what |
	(aMorph bounds containsPoint: evt cursorPoint) ifFalse: [^self].
	evt isMouseUp ifFalse: [
		evt shiftPressed ifFalse: [^evt hand grabMorph: aMorph].
		^self
	].

	evt shiftPressed ifTrue: [
		where _ aMorph owner submorphs indexOf: aMorph ifAbsent: [nil].
		what _ book threadName.
		WorldState addDeferredUIMessage: [
			InternalThreadNavigationMorph openThreadNamed: what atIndex: where
		] fixTemps.
		(Project named: (aMorph valueOfProperty: #nameOfThisProject)) enter.
	].
! !

!ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/4/2001 15:55'!
insertNewProject: evt

	| newProj |

	[newProj _ Project newMorphicOn: nil.]
		on: ProjectViewOpenNotification
		do: [ :ex | ex resume: false].	

	EToyProjectDetailsMorph 
		getFullInfoFor: newProj
		ifValid: [
			evt hand attachMorph: (self sorterMorphForProjectNamed: newProj name)
		]
		expandedFormat: false.


! !

!ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/4/2001 15:40'!
morphsForMyContentsFrom: listOfPages sizedTo: sz

	| morphsForPageSorter |

	'Assembling thumbnail images...'
		displayProgressAt: self cursorPoint
		from: 0 to: listOfPages size
		during: [:bar |
			morphsForPageSorter _ listOfPages withIndexCollect: [ :each :index | 
				bar value: index.
				self sorterMorphForProjectNamed: each first
			].
		].
	^morphsForPageSorter
! !

!ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 17:09'!
navigator: aThreadNavigator listOfPages: listOfPages

	| morphsForPageSorter pixelsAvailable pixelsNeeded scale |

	"a bit of fudging to try to outguess the layout mechanism and get best possible scale"
	pixelsAvailable _ Display extent - 130.
	pixelsAvailable _ pixelsAvailable x * pixelsAvailable y.
	pixelsNeeded _ 100@75.
	pixelsNeeded _ pixelsNeeded x * pixelsNeeded y  * listOfPages size.
	scale _ (pixelsAvailable / pixelsNeeded min: 1) sqrt.
	sizeOfEachMorph _ (100@75 * scale) rounded.

	morphsForPageSorter _ self morphsForMyContentsFrom: listOfPages sizedTo: sizeOfEachMorph.
	morphsForPageSorter _ morphsForPageSorter reject: [ :each | each isNil].
	self changeExtent: Display extent.

	self
		book: aThreadNavigator 
		morphsToSort: morphsForPageSorter.
	pageHolder 
		cursor: aThreadNavigator currentIndex;
		fullBounds;
		hResizing: #rigid.

! !

!ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/10/2001 17:07'!
sorterMorphForProjectNamed: projName

	| pvm proj |

	(proj _ Project named: projName) ifNil: [^nil].
	pvm _ (InternalThreadNavigationMorph getThumbnailFor: proj) asMorph.
	pvm setProperty: #nameOfThisProject toValue: projName.
	pvm setBalloonText: projName.
	pvm on: #mouseDown send: #clickFromSorterEvent:morph: to: self.
	pvm on: #mouseUp send: #clickFromSorterEvent:morph: to: self.
	^pvm

! !


!ProjectSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:54'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 0 ! !

!ProjectSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.365
		g: 0.634
		b: 0.729! !

!ProjectSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:54'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self useRoundedCorners.
	pageHolder useRoundedCorners; borderWidth: 0;
		color: (self
				gridFormOrigin: 0 @ 0
				grid: 16 @ 16
				background: Color white
				line: Color blue muchLighter)! !
ServerDirectory subclass: #ProjectSwikiServer
	instanceVariableNames: 'acceptsUploads'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RemoteDirectory'!

!ProjectSwikiServer methodsFor: 'accessing' stamp: 'mir 6/25/2001 12:40'!
acceptsUploads: aBoolean
	acceptsUploads _ aBoolean! !


!ProjectSwikiServer methodsFor: 'initialize' stamp: 'mir 4/20/2001 18:43'!
wakeUp! !


!ProjectSwikiServer methodsFor: 'testing' stamp: 'mir 6/25/2001 12:40'!
acceptsUploads
	^acceptsUploads == true! !

!ProjectSwikiServer methodsFor: 'testing' stamp: 'mir 4/16/2001 17:42'!
isProjectSwiki
	^true! !
StandardSystemView subclass: #ProjectView
	instanceVariableNames: ''
	classVariableNames: 'ArmsLengthCmd'
	poolDictionaries: ''
	category: 'ST80-Support'!

!ProjectView methodsFor: 'displaying' stamp: 'tk 4/19/2000 17:15'!
armsLengthCommand: aCommand
	"Set up a save to be done after the subproject exits to here.  displayOn: checks it."

	ArmsLengthCmd _ aCommand.! !

!ProjectView methodsFor: 'displaying'!
cacheBitsAsTwoTone
	^ false! !

!ProjectView methodsFor: 'displaying' stamp: 'tk 6/21/2000 16:22'!
displayDeEmphasized
	| cmd |
	"Display this view with emphasis off.  Check for a command that
could not be executed in my subproject.  Once it is done, remove the
trigger."

	super displayDeEmphasized.
	ArmsLengthCmd ifNil: [^ self].
	ArmsLengthCmd first == model ifFalse: [^ self].	"not ours"
	cmd _ ArmsLengthCmd second.
	ArmsLengthCmd _ nil.
	model "project" perform: cmd.
	model "project" enter.
! !

!ProjectView methodsFor: 'displaying' stamp: 'sw 1/11/2000 15:32'!
displayView
	super displayView.
	self label = model name
		ifFalse: [self setLabelTo: model name].
	self isCollapsed ifTrue: [^ self].
	model thumbnail ifNil: [^ self].
	self insetDisplayBox extent = model thumbnail extent
		ifTrue: [model thumbnail displayAt: self insetDisplayBox topLeft]
		ifFalse: [(model thumbnail
					magnify: model thumbnail boundingBox
					by: self insetDisplayBox extent asFloatPoint / model thumbnail extent) 				displayAt: self insetDisplayBox topLeft]
! !

!ProjectView methodsFor: 'displaying' stamp: 'sw 9/14/1998 13:01'!
release
	super release.
	Smalltalk garbageCollect! !


!ProjectView methodsFor: 'initialization'!
defaultControllerClass
	^ ProjectController! !

!ProjectView methodsFor: 'initialization' stamp: 'ar 9/27/2005 20:10'!
maybeRelabel: newLabel
	"If the change set name given by newLabel is already in use, do nothing; else relabel the view"

	(newLabel isEmpty or: [newLabel = self label])
		ifTrue: [^ self].
	(ChangeSet named: newLabel) == nil
		ifFalse: [^ self].
	self relabel: newLabel! !

!ProjectView methodsFor: 'initialization' stamp: 'ar 9/27/2005 20:10'!
relabel: newLabel
	(newLabel isEmpty or: [newLabel = self label])
		ifTrue: [^ self].
	(ChangeSet named: newLabel) == nil
		ifFalse: [self inform: 'Sorry that name is already used'.
				^ self].
	model projectChangeSet name: newLabel.
	super relabel: newLabel! !

!ProjectView methodsFor: 'initialization' stamp: 'sw 1/11/2000 15:30'!
uncacheBits
	super uncacheBits.
	self label ~=  model name ifTrue: [self setLabelTo: model name]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectView class
	instanceVariableNames: ''!

!ProjectView class methodsFor: 'as yet unclassified'!
open: aProject 
	"Answer an instance of me for the argument, aProject. It is created on the
	display screen."
	| topView |
	topView _ self new model: aProject.
	topView minimumSize: 50 @ 30.
	topView borderWidth: 2.
	topView controller open! !

!ProjectView class methodsFor: 'as yet unclassified' stamp: 'RAA 7/25/2000 10:35'!
openAndEnter: aProject 
	"Answer an instance of me for the argument, aProject. It is created on 
	the display screen."
	| topView |
	topView _ self new model: aProject.
	topView minimumSize: 50 @ 30.
	topView borderWidth: 2.
	topView window: (RealEstateAgent initialFrameFor: topView world: nil).
	ScheduledControllers schedulePassive: topView controller.
	aProject
		enter: false
		revert: false
		saveForRevert: false! !
ImageMorph subclass: #ProjectViewMorph
	instanceVariableNames: 'project lastProjectThumbnail'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ProjectViewMorph commentStamp: '<historical>' prior: 0!
I am a Morphic view of a project. I display a scaled version of the project's thumbnail, which itself is a scaled-down snapshot of the screen taken when the project was last exited. When I am displayed, I check to see if the project thumbnail has changed and, if so, I update my own view of that thumbnail.
!


!ProjectViewMorph methodsFor: 'accessing' stamp: 'RAA 2/12/2001 14:47'!
borderWidthForRounding

	^1! !

!ProjectViewMorph methodsFor: 'accessing' stamp: 'tk 8/30/1999 11:48'!
project
	^project! !

!ProjectViewMorph methodsFor: 'accessing' stamp: 'di 6/6/2001 21:34'!
thumbnail
	^ project ifNotNil: [project thumbnail]! !


!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 09:56'!
addProjectNameMorph

	| m |

	self removeAllMorphs.
	m _ UpdatingStringMorph contents: self safeProjectName font: self fontForName.
	m target: self; getSelector: #safeProjectName; putSelector: #safeProjectName:.
	m useStringFormat; fitContents.
	self addMorphBack: m.
	self updateNamePosition.
	^m

! !

!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 10:12'!
addProjectNameMorphFiller

	| m |

	self removeAllMorphs.
	m _ AlignmentMorph newRow color: Color transparent.
	self addMorphBack: m.
	m
		on: #mouseDown send: #editTheName: to: self;
		on: #mouseUp send: #yourself to: self.
	self updateNamePosition.

! !

!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 10:41'!
editTheName: evt

	self isTheRealProjectPresent ifFalse: [
		^self inform: 'The project is not present and may not be renamed now'
	].
	self addProjectNameMorph launchMiniEditor: evt.! !

!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'nk 6/9/2004 09:56'!
expungeProject
	(self confirm: ('Do you really want to delete {1}
and all its content?' translated format: {project name}))
		ifFalse: [^ self].
	owner isSystemWindow
		ifTrue: [owner model: nil;
				 delete].
	ProjectHistory forget: project.
	Project deletingProject: project! !


!ProjectViewMorph methodsFor: 'caching' stamp: 'RAA 10/27/2000 10:55'!
releaseCachedState

	"see if we can reduce size of published file, but there may be problems"
	super releaseCachedState.
	lastProjectThumbnail _ image.
! !


!ProjectViewMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 08:56'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
project _ deepCopier references at: project ifAbsent: [project].
lastProjectThumbnail _ deepCopier references at: lastProjectThumbnail 
				ifAbsent: [lastProjectThumbnail].
! !

!ProjectViewMorph methodsFor: 'copying' stamp: 'fc 12/23/2004 16:24'!
veryDeepInner: deepCopier 
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	project := project.	"Weakly copied"
	lastProjectThumbnail := lastProjectThumbnail veryDeepCopyWith: deepCopier.
! !


!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 8/30/2000 19:10'!
colorAroundName

	^Color gray: 0.8! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/1/2000 22:49'!
drawOn: aCanvas

	| font projectName nameForm rectForName |

	self ensureImageReady.
	super drawOn: aCanvas.
	self isEditingName ifTrue: [^self].

	font _ self fontForName.
	projectName _ self safeProjectName.
	nameForm _ (StringMorph contents: projectName font: font) imageForm.
	nameForm _ nameForm scaledToSize: (self extent - (4@2) min: nameForm extent).
	rectForName _ self bottomLeft + 
			(self width - nameForm width // 2 @ (nameForm height + 2) negated)
				extent: nameForm extent.
	rectForName topLeft eightNeighbors do: [ :pt |
		aCanvas
			stencil: nameForm 
			at: pt
			color: self colorAroundName.
	].
	aCanvas
		stencil: nameForm 
		at: rectForName topLeft 
		color: Color black.


	
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'raa 2/8/2001 10:40'!
ensureImageReady

	self isTheRealProjectPresent ifFalse: [^self].
	project thumbnail ifNil: [
		image fill: image boundingBox rule: Form over 
			fillColor: project defaultBackgroundColor.
		^self
	].
	project thumbnail ~~ lastProjectThumbnail ifTrue: ["scale thumbnail to fit my bounds"
		lastProjectThumbnail _ project thumbnail.
		self updateImageFrom: lastProjectThumbnail.
		project thumbnail ifNotNil: [project thumbnail hibernate].
		image borderWidth: 1
	].


! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 8/30/2000 19:11'!
fontForName

	| pickem |
	pickem _ 3.

	pickem = 1 ifTrue: [
		^(((TextStyle named: #Helvetica) ifNil: [TextStyle default]) fontOfSize: 13) emphasized: 1.
	].
	pickem = 2 ifTrue: [
		^(((TextStyle named: #Palatino) ifNil: [TextStyle default]) fontOfSize: 12) emphasized: 1.
	].
	^((TextStyle default) fontAt: 1) emphasized: 1
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/1/2000 22:45'!
isEditingName

	| nameMorph |
	nameMorph _ self findA: UpdatingStringMorph.
	nameMorph ifNil: [^false].

	^nameMorph hasFocus
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:38'!
isTheRealProjectPresent

	project ifNil: [^ false].
	project isInMemory ifFalse: [^ false].
	project class == DiskProxy ifTrue: [^ false].
	^true
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'gm 2/22/2003 13:14'!
safeProjectName
	| projectName args |
	projectName := self valueOfProperty: #SafeProjectName ifAbsent: ['???'].
	self isTheRealProjectPresent 
		ifFalse: 
			[project class == DiskProxy 
				ifTrue: 
					[args := project constructorArgs.
					((args isKindOf: Array) 
						and: [args size = 1 and: [args first isString]]) 
							ifTrue: [^args first]]
				ifFalse: [^projectName]].
	self setProperty: #SafeProjectName toValue: project name.
	^project name! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'gm 2/16/2003 20:34'!
safeProjectName: aString 
	self addProjectNameMorphFiller.
	self isTheRealProjectPresent ifFalse: [^self].
	project renameTo: aString.
	self setProperty: #SafeProjectName toValue: project name.
	self updateNamePosition.
	(owner isSystemWindow) ifTrue: [owner setLabel: aString]! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 1/26/2001 09:14'!
showBorderAs: aColor

	"image border: image boundingBox width: 1 fillColor: aColor.
	currentBorderColor _ aColor.
	self changed"
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 10/27/2000 10:50'!
updateImageFrom: sourceForm

	(WarpBlt current toForm: image)
		sourceForm: sourceForm;
		cellSize: 2;  "installs a colormap"
		combinationRule: Form over;
		copyQuad: (sourceForm boundingBox) innerCorners
		toRect: image boundingBox.
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:11'!
updateNamePosition

	| nameMorph shadowMorph nameFillerMorph |

	(nameMorph _ self findA: UpdatingStringMorph) ifNotNil: [
		nameMorph position:
			(self left + (self width - nameMorph width // 2)) @
			(self bottom - nameMorph height - 2).
	].
	(nameFillerMorph _ self findA: AlignmentMorph) ifNotNil: [
		nameFillerMorph
			position: self bottomLeft - (0@20);
			extent: self width@20.
	].
	(shadowMorph _ self findA: ImageMorph) ifNotNil: [
		shadowMorph delete	"no longer used"
	].

! !


!ProjectViewMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 11/2/2000 10:40'!
wantsDroppedMorph: aMorph event: evt

	self isTheRealProjectPresent ifFalse: [^false].
	project isMorphic ifFalse: [^false].
	project world viewBox ifNil: [^false].		"uninitialized"
	^true! !


!ProjectViewMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 22:13'!
handlesMouseDown: evt

	^ true
! !

!ProjectViewMorph methodsFor: 'event handling' stamp: 'sw 9/22/1999 11:41'!
handlesMouseOver: evt
	^ true! !

!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 1/26/2001 09:03'!
handlesMouseOverDragging: evt

	^ true! !

!ProjectViewMorph methodsFor: 'event handling' stamp: 'fc 12/23/2004 19:38'!
mouseDown: evt

	evt yellowButtonPressed ifTrue:
		[self showMenuForProjectView].
	evt hand newMouseFocus: self.
	self removeProperty: #wasOpenedAsSubproject.
	self showMouseState: 2.! !

!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 7/16/2000 14:14'!
mouseEnter: evt

	self showMouseState: 1! !

!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 7/16/2000 14:13'!
mouseLeave: evt

	self showMouseState: 3.
! !

!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 1/26/2001 09:03'!
mouseLeaveDragging: evt

	self mouseLeave: evt

! !

!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 7/16/2000 14:13'!
mouseUp: evt

	((self containsPoint: evt cursorPoint) and: 
				[(self hasProperty: #wasOpenedAsSubproject) not]) ifTrue:
		[^ self enter].
	self showMouseState: 3.
! !

!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 10/20/2000 10:12'!
wantsKeyboardFocusFor: aSubmorph

	^true! !


!ProjectViewMorph methodsFor: 'events' stamp: 'dgd 8/31/2003 18:40'!
balloonText
	^ 'Click here to enter the
project named
"{1}"' translated format: {project name}! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 5/17/2000 11:39'!
checkForNewerVersionAndLoad

	self withProgressDo: [
		project loadFromServer
	] 

! !

!ProjectViewMorph methodsFor: 'events' stamp: 'sumim 11/21/2003 13:43'!
deletingProject: aProject
	"My project is being deleted.  Delete me as well."

	self flag: #bob.		"zapping projects"


	project == aProject ifTrue: [
		self owner isSystemWindow ifTrue: [self owner model: nil; delete].
		self delete].! !

!ProjectViewMorph methodsFor: 'events' stamp: 'sw 3/17/2005 23:59'!
doButtonAction
	"My inherent button action consists of entering the project I represent"

	self enter! !

!ProjectViewMorph methodsFor: 'events' stamp: 'md 10/22/2003 15:51'!
enter
	"Enter my project."

	self world == self outermostWorldMorph ifFalse: [^Beeper beep].	"can't do this at the moment"
	project class == DiskProxy 
		ifFalse: 
			[(project world notNil and: 
					[project world isMorph 
						and: [project world hasOwner: self outermostWorldMorph]]) 
				ifTrue: [^Beeper beep	"project is open in a window already"]].
	project class == DiskProxy 
		ifTrue: 
			["When target is not in yet"

			self enterWhenNotPresent.	"will bring it in"
			project class == DiskProxy ifTrue: [^self inform: 'Project not found']].
	(owner isSystemWindow) ifTrue: [project setViewSize: self extent].
	self showMouseState: 3.
	project 
		enter: false
		revert: false
		saveForRevert: false! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 5/17/2000 11:38'!
enterWhenNotPresent

	self withProgressDo: [
		project enter: false revert: false saveForRevert: false.	"will bring it in"
	] 

! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 7/12/2000 07:44'!
lastProjectThumbnail: aForm
	
	lastProjectThumbnail _ aForm! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 11/2/2000 10:06'!
on: aProject

	project _ aProject.
	self addProjectNameMorphFiller.
	lastProjectThumbnail _ nil.
	project thumbnail
		ifNil: [self extent: 100@80]		"more like screen dimensions?"
		ifNotNil: [self extent: project thumbnail extent].
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 11/2/2000 10:06'!
project: aProject

	project _ aProject.
	self addProjectNameMorphFiller.! !

!ProjectViewMorph methodsFor: 'events' stamp: 'raa 11/2/2000 10:29'!
seeIfNameChanged

	| nameBefore nameNow |

	nameBefore _ self valueOfProperty: #SafeProjectName ifAbsent: ['???'].
	nameNow _ self safeProjectName.
	(submorphs notEmpty and: [nameBefore = nameNow]) ifTrue: [^self].
	self addProjectNameMorphFiller.
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'yo 8/1/2005 21:00'!
showMenuForProjectView
	| menu selection |
	(menu _ CustomMenu new)
		add: 'enter this project' translated
		action: [^ self enter];
		
		add: 'ENTER ACTIVE' translated
		action: [self setProperty: #wasOpenedAsSubproject toValue: true.
			^ self enterAsActiveSubproject];
		
		add: 'PUBLISH (also saves a local copy)' translated
		action: [^ project storeOnServerShowProgressOn: self forgetURL: false];
		
		add: 'PUBLISH to a different server' translated
		action: [project forgetExistingURL.
			^ project storeOnServerShowProgressOn: self forgetURL: true];
		
		add: 'see if server version is more recent' translated
		action: [^ self checkForNewerVersionAndLoad];

		addLine;
		add: 'expunge this project' translated
		action: [^ self expungeProject].

	selection _ menu build startUpCenteredWithCaption: 
('Project Named \"{1}"' translated withCRs format: {project name}).

	selection
		ifNil: [^ self].
	selection value! !

!ProjectViewMorph methodsFor: 'events' stamp: 'kfr 10/9/2004 10:36'!
showMouseState: anInteger 
	| aMorph |
	(owner isSystemWindow)
		ifTrue: [aMorph := owner]
		ifFalse: [aMorph := self].
	anInteger = 1
		ifTrue: ["enter"
			aMorph
				addMouseActionIndicatorsWidth: 10
				color: (Color blue alpha: 0.3)].
	anInteger = 2
		ifTrue: ["down"
			aMorph
				addMouseActionIndicatorsWidth: 15
				color: (Color blue alpha: 0.7)].
	anInteger = 3
		ifTrue: ["leave"
			aMorph deleteAnyMouseActionIndicators]! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 5/23/2000 10:08'!
withProgressDo: aBlock

	ComplexProgressIndicator new 
		targetMorph: self;
		historyCategory: 'project loading';
		withProgressDo: aBlock
! !


!ProjectViewMorph methodsFor: 'fileIn/out' stamp: 'tk 9/8/1999 17:51'!
storeSegment
	"Store my project out on the disk as an ImageSegment.  Keep the outPointers in memory.  Name it <project name>.seg"

	project storeSegment
! !


!ProjectViewMorph methodsFor: 'geometry' stamp: 'RAA 10/27/2000 11:08'!
extent: aPoint
	"Set my image form to the given extent."

	| newExtent scaleP scale |

	((bounds extent = aPoint) and: [image depth = Display depth]) ifFalse: [
		lastProjectThumbnail ifNil: [ lastProjectThumbnail _ image ].
		scaleP _ aPoint / lastProjectThumbnail extent.
		scale _ scaleP "scaleP x asFloat max: scaleP y asFloat".
		newExtent _ (lastProjectThumbnail extent * scale) rounded.
		self image: (Form extent: newExtent depth: Display depth).
		self updateImageFrom: lastProjectThumbnail.
	].
	self updateNamePosition.! !


!ProjectViewMorph methodsFor: 'initialization' stamp: 'yo 8/1/2005 22:28'!
dismissViaHalo
	| choice |
	project ifNil:[^self delete]. "no current project"
	choice := (PopUpMenu labelArray:{
		'yes - delete the window and the project' translated.
		'no - delete the window only' translated
	}) startUpWithCaption: ('Do you really want to delete {1}
and all its content?' translated format: {project name printString}).
	choice = 1 ifTrue:[^self expungeProject].
	choice = 2 ifTrue:[^self delete].! !

!ProjectViewMorph methodsFor: 'initialization' stamp: 'RAA 1/26/2001 09:14'!
initialize
	super initialize.
	"currentBorderColor _ Color gray."
	self addProjectNameMorphFiller.! !


!ProjectViewMorph methodsFor: 'layout' stamp: 'RAA 11/2/2000 10:39'!
acceptDroppingMorph: morphToDrop event: evt

	| myCopy smallR |

	(self isTheRealProjectPresent) ifFalse: [
		^morphToDrop rejectDropMorphEvent: evt.		"can't handle it right now"
	].
	(morphToDrop isKindOf: NewHandleMorph) ifTrue: [	"don't send these"
		^morphToDrop rejectDropMorphEvent: evt.
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we will send a copy"
	myCopy _ morphToDrop veryDeepCopy.	"gradient fills require doing this second"
	smallR _ (morphToDrop bounds scaleBy: image height / Display height) rounded.
	smallR _ smallR squishedWithin: image boundingBox.
	image getCanvas
		paintImage: (morphToDrop imageForm scaledToSize: smallR extent)
		at: smallR topLeft.
	myCopy openInWorld: project world

! !


!ProjectViewMorph methodsFor: 'objects from disk' stamp: 'RAA 10/27/2000 11:08'!
objectForDataStream: refStrm
	
	| copy |

	1 = 1 ifTrue: [^self].		"this didn't really work"

	copy _ self copy lastProjectThumbnail: nil.
	"refStrm replace: self with: copy."
	^copy
! !


!ProjectViewMorph methodsFor: 'rounding' stamp: 'gm 2/16/2003 20:34'!
wantsRoundedCorners
	^Preferences roundedWindowCorners 
		and: [(owner isSystemWindow) not]! !


!ProjectViewMorph methodsFor: 'stepping and presenter' stamp: 'raa 11/2/2000 10:20'!
step
	| cmd |
	"Check for a command that could not be executed in my subproject.  Once it is done, remove the trigger.  If this is too slow, make armsLengthCmd an inst var."

	self seeIfNameChanged.
	cmd _ self valueOfProperty: #armsLengthCmd.
	cmd ifNil: [^ super step].
	self removeProperty: #armsLengthCmd.
	project perform: cmd.
	project enter.! !


!ProjectViewMorph methodsFor: 'submorphs-add/remove' stamp: 'tk 12/9/1999 08:03'!
abandon
	"Home ViewMorph of project is going away."

	project _ nil.
	super abandon.

! !


!ProjectViewMorph methodsFor: 'testing' stamp: 'raa 11/2/2000 10:21'!
stepTime

	^1000! !


!ProjectViewMorph methodsFor: '*eToys-user interface' stamp: 'RAA 7/10/2000 23:30'!
eToyStreamedRepresentationNotifying: aWidget

	| safeVariant outData |

	self flag: #bob.		"probably irrelevant"
	safeVariant _ self copy.
	[ outData _ SmartRefStream streamedRepresentationOf: safeVariant ] 
		on: ProgressInitiationException
		do: [ :ex | 
			ex sendNotificationsTo: [ :min :max :curr |
				aWidget ifNotNil: [aWidget flashIndicator: #working].
			].
		].
	^outData
! !


!ProjectViewMorph methodsFor: '*MorphicExtras-event handling' stamp: 'ar 10/25/2000 17:37'!
handlesMouseStillDown: evt
	^true! !

!ProjectViewMorph methodsFor: '*MorphicExtras-event handling' stamp: 'fc 12/23/2004 16:24'!
mouseStillDown: evt

	(self containsPoint: evt cursorPoint) ifFalse: [
		self showMouseState: 3.
		^self
	].
	self showMouseState: 2.
	
	
					! !


!ProjectViewMorph methodsFor: '*MorphicExtras-events' stamp: 'fc 12/23/2004 19:33'!
enterAsActiveSubproject
	"Enter my project."

	self setProperty: #wasOpenedAsSubproject toValue: true.
	project class == DiskProxy 
		ifTrue: 
			["When target is not in yet"

			[self enterWhenNotPresent	"will bring it in"] on: ProjectEntryNotification
				do: [:ex | ^ex projectToEnter enterAsActiveSubprojectWithin: self world].
			project class == DiskProxy ifTrue: [self error: 'Could not find view']].
	(owner isSystemWindow) ifTrue: [project setViewSize: self extent].
	self showMouseState: 3.
	project enterAsActiveSubprojectWithin: self world! !


!ProjectViewMorph methodsFor: '*MorphicExtras-*morphic-Postscript Canvases' stamp: 'RAA 4/19/2001 11:25'!
fullDrawPostscriptOn: aCanvas

	| f |
	"handle the fact that we have the squished text within"

	f _ self imageForm.
	f offset: 0@0.
	aCanvas paintImage: f at: bounds origin.
! !


!ProjectViewMorph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/12/2000 10:08'!
triggerActionFromPianoRoll

	WorldState addDeferredUIMessage: [
		project world setProperty: #letTheMusicPlay toValue: true.
		self enter.
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectViewMorph class
	instanceVariableNames: ''!

!ProjectViewMorph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 16:54'!
initialize

	FileList registerFileReader: self! !


!ProjectViewMorph class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:55'!
fileReaderServicesForFile: fullName suffix: suffix

	^({ 'extseg'. 'project'. 'pr'. 'morph'. 'morphs'. 'sp'. '*' } includes: suffix)
		ifTrue: [ self services]
		ifFalse: [#()]! !

!ProjectViewMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:01'!
services

	^ Array with: self serviceOpenProjectFromFile

	! !


!ProjectViewMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'!
unload

	FileList unregisterFileReader: self ! !


!ProjectViewMorph class methodsFor: 'instance creation' stamp: 'jm 5/14/1998 16:19'!
on: aProject

	^ self new on: aProject
! !


!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'sw 4/24/2001 12:00'!
newMVCProject
	"Create an instance of me on a new MVC project (in a SystemWindow)."

	| proj window |
	proj _ Project new.
	window _ (SystemWindow labelled: proj name) model: proj.
	window
		addMorph: (self on: proj)
		frame: (0@0 corner: 1.0@1.0).
	^ window
! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 10/6/2000 15:46'!
newMorphicProject
	"Return an instance of me on a new Morphic project (in a SystemWindow)."

	self flag: #bob.		"No senders???"
	self halt.

	"^self newMorphicProjectOn: nil"! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 10/6/2000 15:45'!
newMorphicProjectOn: aPasteUpOrNil
	"Return an instance of me on a new Morphic project (in a SystemWindow)."

	self flag: #bob.		"No senders???"
	self halt.

	"^self newProjectViewInAWindowFor: (Project newMorphicOn: aPasteUpOrNil)"
! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'ar 8/31/2004 20:53'!
newProjectViewInAWindowFor: aProject
	"Return an instance of me on a new Morphic project (in a SystemWindow)."

	| window proj |
	proj := self on: aProject.
	window _ (SystemWindow labelled: aProject name) model: aProject.
	window
		addMorph: proj
		frame: (0@0 corner: 1.0@1.0).
	proj borderWidth: 0.
	^ window
! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/2/2002 08:11'!
openFromDirectory: aDirectory andFileName: aFileName
	
	Project canWeLoadAProjectNow ifFalse: [^ self].
	^ProjectLoading openFromDirectory: aDirectory andFileName: aFileName! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/2/2002 08:30'!
openFromDirectoryAndFileName: anArray
	
	Project canWeLoadAProjectNow ifFalse: [^ self].
	^ProjectLoading 
		openFromDirectory: anArray first 
		andFileName: anArray second! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/22/2002 06:19'!
openFromFile: fileName
	
	self flag: #bob.		"better not to use this one. nil directories are not nice.
						see #openFromDirectoryAndFileName: or 
						#openFromDirectory:andFileName: instead"

	self halt.

	Project canWeLoadAProjectNow ifFalse: [^ self].
	^ProjectLoading openFromDirectory: nil andFileName: fileName! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/22/2002 06:19'!
openFromFileList: fullName
	
	self flag: #bob.		"not sent??"

	self halt.

	^self openFromFile:  fullName! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/22/2002 06:12'!
serviceOpenProjectFromFile
	"Answer a service for opening a .pr project file"

	^ (SimpleServiceEntry 
		provider: self 
		label: 'load as project'
		selector: #openFromDirectoryAndFileName:
		description: 'open project from file'
		buttonLabel: 'load'
	)
		argumentGetter: [ :fileList | fileList dirAndFileName]! !


!ProjectViewMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'!
defaultNameStemForInstances
	^ 'ProjectView'! !
Notification subclass: #ProjectViewOpenNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!ProjectViewOpenNotification commentStamp: '<historical>' prior: 0!
ProjectViewOpenNotification is signalled to determine if a ProjectViewMorph is needed for a newly created project. The default answer is yes.!


!ProjectViewOpenNotification methodsFor: 'as yet unclassified' stamp: 'RAA 7/4/2000 16:24'!
defaultAction

	self resume: true! !
PrintableEncoder subclass: #PropertyListEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Filters'!

!PropertyListEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:22'!
writeArrayedCollection:aCollection
	self print:'/* '; print:aCollection class name; print:'*/'; cr.
	self print:'( '; writeCollectionContents:aCollection separator:','; print:')'.! !

!PropertyListEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:32'!
writeDictionary:aCollection
	self print:'{ '; writeDictionaryContents:aCollection separator:'; '; print:'}'.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PropertyListEncoder class
	instanceVariableNames: ''!

!PropertyListEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:22'!
filterSelector
	^#propertyListOn:.
! !
LayoutPolicy subclass: #ProportionalLayout
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!ProportionalLayout commentStamp: '<historical>' prior: 0!
I represent a layout that places all children of some morph in their given LayoutFrame.!


!ProportionalLayout methodsFor: 'layout' stamp: 'ar 10/29/2000 01:24'!
layout: aMorph in: newBounds
	"Compute the layout for the given morph based on the new bounds"
	aMorph submorphsDo:[:m| m layoutProportionallyIn: newBounds].! !

!ProportionalLayout methodsFor: 'layout' stamp: 'ar 2/5/2002 20:05'!
minExtentOf: aMorph in: newBounds
	"Return the minimal size aMorph's children would require given the new bounds"
	| min extent frame |
	min _ 0@0.
	aMorph submorphsDo:[:m|
		"Map the minimal size of the child through the layout frame.
		Note: This is done here and not in the child because its specific
		for proportional layouts. Perhaps we'll generalize this for table
		layouts but I'm not sure how and when."
		extent _ m minExtent.
		frame _ m layoutFrame.
		frame ifNotNil:[extent _ frame minExtentFrom: extent].
		min _ min max: extent].
	^min! !


!ProportionalLayout methodsFor: 'testing' stamp: 'ar 10/29/2000 01:29'!
isProportionalLayout
	^true! !
AbstractResizerMorph subclass: #ProportionalSplitterMorph
	instanceVariableNames: 'leftOrTop rightOrBottom splitsTopAndBottom oldColor traceMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ProportionalSplitterMorph commentStamp: 'jmv 1/29/2006 17:16' prior: 0!
I am the morph the user grabs to adjust pane splitters.!


!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:57'!
addLeftOrTop: aMorph

	leftOrTop add: aMorph! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:55'!
addRightOrBottom: aMorph

	rightOrBottom add: aMorph.
	
	! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:39'!
beSplitsTopAndBottom

	splitsTopAndBottom _ true.
	! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:16'!
bottomBoundary

	^ (self splitterBelow ifNil: [self containingWindow panelRect bottom] ifNotNil: [self splitterBelow top]) - 75! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 8/6/2005 23:59'!
drawOn: aCanvas 
	| dotBounds size alphaCanvas dotSize |
	super drawOn: aCanvas.
	self class showSplitterHandles ifTrue: [
	size _ self splitsTopAndBottom
				ifTrue: [self handleSize transposed]
				ifFalse: [self handleSize].
	dotSize _ self splitsTopAndBottom
				ifTrue: [6 @ self class splitterWidth]
				ifFalse: [self class splitterWidth @ 6].
	alphaCanvas _ aCanvas asAlphaBlendingCanvas: 0.7.
	dotBounds _ Rectangle center: self bounds center extent: size.
	alphaCanvas fillRectangle: dotBounds color: self handleColor.
	dotBounds _ Rectangle center: self bounds center extent: dotSize.
	alphaCanvas fillRectangle: dotBounds color: self dotColor]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'apl 7/8/2005 13:38'!
getOldColor
	^ oldColor ifNil: [Color transparent]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/4/2005 10:50'!
handleRect

	^ Rectangle
		center: self bounds center 
		extent: (self splitsTopAndBottom
			ifTrue: [self handleSize transposed] 
			ifFalse: [self handleSize])! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 8/6/2005 23:59'!
handleSize

	^ self class splitterWidth @ 30! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:46'!
initialize

	super initialize.
	
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	splitsTopAndBottom _ false.
	
	leftOrTop _ OrderedCollection new.
	rightOrBottom _ OrderedCollection new! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/9/2005 17:44'!
isCursorOverHandle
	^ self class showSplitterHandles not or: [self handleRect containsPoint: ActiveHand cursorPoint]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:09'!
leftBoundary

	^ (self splitterLeft ifNil: [self containingWindow panelRect left] ifNotNil: [self splitterLeft right]) + 50! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/9/2005 17:44'!
mouseDown: anEvent 
	(self class showSplitterHandles not
			and: [self bounds containsPoint: anEvent cursorPoint])
		ifTrue: [oldColor _ self color.
			self color: Color black].
	^ super mouseDown: anEvent ! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:11'!
mouseMove: anEvent 
	anEvent hand temporaryCursor
		ifNil: [^ self].
	self class fastSplitterResize
		ifFalse:  [self updateFromEvent: anEvent]
		ifTrue: [traceMorph
				ifNil: [traceMorph _ Morph newBounds: self bounds.
					traceMorph borderColor: Color lightGray.
					traceMorph borderWidth: 1.
					self owner addMorph: traceMorph].
			splitsTopAndBottom
				ifTrue: [traceMorph position: traceMorph position x @ (self normalizedY: anEvent cursorPoint y)]
				ifFalse: [traceMorph position: (self normalizedX: anEvent cursorPoint x) @ traceMorph position y]]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/8/2005 21:42'!
mouseUp: anEvent 
	(self bounds containsPoint: anEvent cursorPoint)
		ifFalse: [anEvent hand showTemporaryCursor: nil].
	self class fastSplitterResize
		ifTrue: [self updateFromEvent: anEvent].
	traceMorph ifNotNil: [traceMorph delete. traceMorph _ nil].
	self color: self getOldColor! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 22:45'!
normalizedX: x

	^ (x max: self leftBoundary) min: self rightBoundary! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:12'!
normalizedY: y

	^ (y max: self topBoundary) min: self bottomBoundary! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:39'!
resizeCursor

	^ Cursor resizeForEdge: (splitsTopAndBottom
		ifTrue: [#top]
		ifFalse: [#left])
		! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:09'!
rightBoundary

	^ (self splitterRight ifNil: [self containingWindow panelRect right] ifNotNil: [self splitterRight left]) - 50! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 20:20'!
siblingSplitters

	^ self owner submorphsSatisfying: [:each | (each isKindOf: self class) and: [self splitsTopAndBottom = each splitsTopAndBottom] and: [each ~= self]]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 17:25'!
splitsTopAndBottom

	^ splitsTopAndBottom! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:01'!
splitterAbove

	| splitters |
	splitters _ ((self siblingSplitters select: [:each | each y > self y]) asSortedCollection: [:a :b | a y < b y]).
	
	^ splitters ifEmpty: nil ifNotEmpty: [splitters first]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:01'!
splitterBelow

	| splitters |
	splitters _ ((self siblingSplitters select: [:each | each y < self y]) asSortedCollection: [:a :b | a y > b y]).
	
	^ splitters ifEmpty: nil ifNotEmpty: [splitters first]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:03'!
splitterLeft

	| splitters |
	splitters _ ((self siblingSplitters select: [:each | each x < self x]) asSortedCollection: [:a :b | a x > b x]).
	
	^ splitters ifEmpty: nil ifNotEmpty: [splitters first]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:03'!
splitterRight

	| splitters |
	splitters _ ((self siblingSplitters select: [:each | each x > self x]) asSortedCollection: [:a :b | a x < b x]).
	
	^ splitters ifEmpty: nil ifNotEmpty: [splitters first]! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:16'!
topBoundary

	^ (self splitterAbove ifNil: [self containingWindow panelRect top] ifNotNil: [self splitterAbove bottom]) + 75! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:19'!
updateFromEvent: anEvent 
	| delta firstRight firstBottom secondLeft secondTop selfTop selfBottom selfLeft selfRight |
	delta _ splitsTopAndBottom
				ifTrue: [0 @ ((self normalizedY: anEvent cursorPoint y) - lastMouse y)]
				ifFalse: [(self normalizedX: anEvent cursorPoint x) - lastMouse x @ 0].
				
	splitsTopAndBottom
		ifTrue: [lastMouse _ lastMouse x @ (self normalizedY: anEvent cursorPoint y)]
		ifFalse: [lastMouse _ (self normalizedX: anEvent cursorPoint x) @ lastMouse y].

	leftOrTop
				do: [:each | 
					firstRight _ each layoutFrame rightOffset
								ifNil: [0].
					firstBottom _ each layoutFrame bottomOffset
								ifNil: [0].
					each layoutFrame rightOffset: firstRight + delta x.
					each layoutFrame bottomOffset: firstBottom + delta y].
			rightOrBottom
				do: [:each | 
					secondLeft _ each layoutFrame leftOffset
								ifNil: [0].
					secondTop _ each layoutFrame topOffset
								ifNil: [0].
					each layoutFrame leftOffset: secondLeft + delta x.
					each layoutFrame topOffset: secondTop + delta y].
	selfTop _ self layoutFrame topOffset
				ifNil: [0].
	selfBottom _ self layoutFrame bottomOffset
				ifNil: [0].
	selfLeft _ self layoutFrame leftOffset
				ifNil: [0].
	selfRight _ self layoutFrame rightOffset
				ifNil: [0].
	self layoutFrame topOffset: selfTop + delta y.
	self layoutFrame bottomOffset: selfBottom + delta y.
	self layoutFrame leftOffset: selfLeft + delta x.
	self layoutFrame rightOffset: selfRight + delta x.
	self owner layoutChanged! !

!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:39'!
wantsEveryMouseMove

	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProportionalSplitterMorph class
	instanceVariableNames: ''!

!ProportionalSplitterMorph class methodsFor: 'as yet unclassified' stamp: 'jrp 8/6/2005 23:59'!
splitterWidth

	^ 4! !


!ProportionalSplitterMorph class methodsFor: 'preferences' stamp: 'md 2/24/2006 22:47'!
fastSplitterResize
	
	^ Preferences fastDragWindowForMorphic.! !

!ProportionalSplitterMorph class methodsFor: 'preferences' stamp: 'jrp 7/9/2005 17:43'!
showSplitterHandles

	^ Preferences valueOfPreference: #showSplitterHandles ifAbsent: [true]! !
ProtoObject subclass: #ProtoObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'.
ProtoObject superclass: nil!
!ProtoObject commentStamp: '<historical>' prior: 0!
ProtoObject establishes minimal behavior required of any object in Squeak, even objects that should balk at normal object behavior. Generally these are proxy objects designed to read themselves in from the disk, or to perform some wrapper behavior, before responding to a message. Current examples are ObjectOut and ImageSegmentRootStub, and one could argue that ObjectTracer should also inherit from this class.

ProtoObject has no instance variables, nor should any be added.!


!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'!
tryNamedPrimitive
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'!
tryNamedPrimitive: arg1
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'!
tryNamedPrimitive: arg1 with: arg2
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'!
tryNamedPrimitive: arg1 with: arg2 with: arg3
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'!
tryPrimitive: primIndex withArgs: argumentArray
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."

	<primitive: 118>
	^ ContextPart primitiveFailToken! !


!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'!
privGetInstVar: index
	"The compiler generates this message when accessing to instance variables of objects other than the receiver.  Do not override or change this unless you also modify the compiler and recompile everything"

	<primitive: 73>
	^ self basicAt: index - self class instSize! !

!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'!
privRemoteReturnTo: contextTag
	"Generated from compiler to return to the home of a block.  self is the value return and contextTag is the tag of the home context.  Do not override or change this unless you also modify the compiler and recompile everything"

	contextTag return: self! !

!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'!
privSetInHolder: valueHolder
	"The compiler generates this message to place values in global variables.  Do not override or change this unless you also modify the compiler and recompile everything"

	valueHolder value: self.
	^ self! !

!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'!
privSetInstVar: index put: value 

	<primitive: 74>
	^ self basicAt: index - self class instSize put: value! !

!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'!
privStoreIn: object instVar: index
	"The compiler generates this message when assigning to instance variables of objects that have been captured by a block closure.  Do not override or change this unless you also modify the compiler and recompile everything"

	object privSetInstVar: index put: self! !


!ProtoObject methodsFor: 'comparing' stamp: 'md 11/24/1999 19:27'!
== anObject 
	"Primitive. Answer whether the receiver and the argument are the same 
	object (have the same object pointer). Do not redefine the message == in 
	any other class!! Essential. No Lookup. Do not override in any subclass. 
	See Object documentation whatIsAPrimitive."

	<primitive: 110>
	self primitiveFailed! !

!ProtoObject methodsFor: 'comparing' stamp: 'md 11/24/1999 19:27'!
identityHash
	"Answer a SmallInteger whose value is related to the receiver's identity.
	This method must not be overridden, except by SmallInteger.
	Primitive. Fails if the receiver is a SmallInteger. Essential.
	See Object documentation whatIsAPrimitive.

	Do not override."

	<primitive: 75>
	self primitiveFailed! !

!ProtoObject methodsFor: 'comparing' stamp: 'md 11/24/1999 19:27'!
~~ anObject
	"Answer whether the receiver and the argument are not the same object 
	(do not have the same object pointer)."

	self == anObject
		ifTrue: [^ false]
		ifFalse: [^ true]! !


!ProtoObject methodsFor: 'debugging' stamp: 'sw 10/26/2000 14:29'!
doOnlyOnce: aBlock
	"If the 'one-shot' mechanism is armed, evaluate aBlock once and disarm the one-shot mechanism.  To rearm the mechanism, evaluate  'self rearmOneShot' manually."

	(Smalltalk at: #OneShotArmed ifAbsent: [true])
		ifTrue:
			[Smalltalk at: #OneShotArmed put: false.
			aBlock value]! !

!ProtoObject methodsFor: 'debugging' stamp: 'sw 4/28/2000 14:41'!
flag: aSymbol
	"Send this message, with a relevant symbol as argument, to flag a message for subsequent retrieval.  For example, you might put the following line in a number of messages:
	self flag: #returnHereUrgently
	Then, to retrieve all such messages, browse all senders of #returnHereUrgently."! !

!ProtoObject methodsFor: 'debugging' stamp: 'sw 10/26/2000 14:27'!
rearmOneShot
	"Call this manually to arm the one-shot mechanism; use the mechanism in code by calling
		self doOnlyOnce: <a block>"

	Smalltalk at: #OneShotArmed put: true

	"self rearmOneShot"
! !


!ProtoObject methodsFor: 'initialize-release' stamp: 'md 11/18/2003 10:33'!
initialize
	"Subclasses should redefine this method to perform initializations on instance creation"! !


!ProtoObject methodsFor: 'objects from disk' stamp: 'md 11/24/1999 20:03'!
rehash
	"Do nothing.  Here so sending this to a Set does not have to do a time consuming respondsTo:"! !


!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:30'!
become: otherObject 
	"Primitive. Swap the object pointers of the receiver and the argument.
	All variables in the entire system that used to point to the 
	receiver now point to the argument, and vice-versa.
	Fails if either object is a SmallInteger"

	(Array with: self)
		elementsExchangeIdentityWith:
			(Array with: otherObject)! !

!ProtoObject methodsFor: 'system primitives' stamp: 'ajh 1/13/2002 17:02'!
cannotInterpret: aMessage 
	 "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector.  Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose."

"If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent."

	(self class lookupSelector: aMessage selector) == nil ifFalse:
		["Simulated lookup succeeded -- resend the message."
		^ aMessage sentTo: self].

	"Could not recover by simulated lookup -- it's an error"
	Error signal: 'MethodDictionary fault'.

	"Try again in case an error handler fixed things"
	^ aMessage sentTo: self! !

!ProtoObject methodsFor: 'system primitives' stamp: 'ajh 10/9/2001 17:20'!
doesNotUnderstand: aMessage

	^ MessageNotUnderstood new 
		message: aMessage;
		receiver: self;
		signal! !

!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:58'!
nextInstance
	"Primitive. Answer the next instance after the receiver in the 
	enumeration of all instances of this class. Fails if all instances have been 
	enumerated. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 78>
	^nil! !

!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:58'!
nextObject
	"Primitive. Answer the next object after the receiver in the 
	enumeration of all objects. Return 0 when all objects have been 
	enumerated."

	<primitive: 139>
	self primitiveFailed.! !


!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:23'!
ifNil: nilBlock
	"Return self, or evaluate the block if I'm == nil (q.v.)"

	^ self! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:25'!
ifNil: nilBlock ifNotNil: ifNotNilBlock
	"Evaluate the block, unless I'm == nil (q.v.)"

	^ ifNotNilBlock value! !

!ProtoObject methodsFor: 'testing' stamp: 'md 1/20/2006 16:19'!
ifNotNil: ifNotNilBlock
	"Evaluate the block, unless I'm == nil (q.v.)"

	^ ifNotNilBlock valueWithPossibleArgs: {self}! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:25'!
ifNotNil: ifNotNilBlock ifNil: nilBlock 
	"If I got here, I am not nil, so evaluate the block ifNotNilBlock"

	^ ifNotNilBlock value! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:57'!
isInMemory
	"All normal objects are."
	^ true! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:26'!
isNil
	"Coerces nil to true and everything else to false."

	^false! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:58'!
pointsTo: anObject
	"This method returns true if self contains a pointer to anObject,
		and returns false otherwise"
	<primitive: 132>
	1 to: self class instSize do:
		[:i | (self instVarAt: i) == anObject ifTrue: [^ true]].
	1 to: self basicSize do:
		[:i | (self basicAt: i) == anObject ifTrue: [^ true]].
	^ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProtoObject class
	instanceVariableNames: ''!

!ProtoObject class methodsFor: 'as yet unclassified' stamp: 'sw 5/5/2000 09:31'!
initializedInstance
	^ nil! !
ClassTestCase subclass: #ProtoObjectTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Objects'!
!ProtoObjectTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class ProtoObject. 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!


!ProtoObjectTest methodsFor: 'testing - testing' stamp: 'sd 6/5/2005 09:05'!
testFlag
	
	self shouldnt: [ProtoObject new flag: #hallo] raise: Error.! !

!ProtoObjectTest methodsFor: 'testing - testing' stamp: 'sd 6/5/2005 09:05'!
testIsNil

	self assert: (ProtoObject new isNil = false).! !
MessageSet subclass: #ProtocolBrowser
	instanceVariableNames: 'selectedClass selectedSelector'
	classVariableNames: 'TextMenu'
	poolDictionaries: ''
	category: 'Tools-Browser'!
!ProtocolBrowser commentStamp: '<historical>' prior: 0!
An instance of ProtocolBrowser shows the methods a class understands--inherited or implemented at this level--as a "flattened" list.!


!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:33'!
getList
	"Answer the receiver's message list."
	^ messageList! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'sw 1/28/2001 21:01'!
growable
	"Answer whether the receiver is subject to manual additions and deletions"

	^ false! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:33'!
list
	"Answer the receiver's message list."
	^ messageList! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!
selector
	"Answer the receiver's selected selector."
	^ selectedSelector! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!
selector: aString
	"Set the currently selected message selector to be aString."
	selectedSelector := aString.
	self changed: #selector! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!
setSelector: aString
	"Set the currently selected message selector to be aString."
	selectedSelector := aString! !


!ProtocolBrowser methodsFor: 'class list' stamp: 'nk 4/10/2001 08:16'!
selectedClassOrMetaClass
	^selectedClass! !


!ProtocolBrowser methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
initListFrom: selectorCollection highlighting: aClass 
	"Make up the messageList with items from aClass in boldface."
	| defClass item |

	messageList := OrderedCollection new.
	selectorCollection do: [ :selector |  
		defClass := aClass whichClassIncludesSelector: selector.
		item := selector, '     (' , defClass name , ')'.
		defClass == aClass ifTrue: [item := item asText allBold].
		messageList add: (
			MethodReference new
				setClass: defClass 
				methodSymbol: selector 
				stringVersion: item
		)
	].
	selectedClass := aClass.! !

!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:26'!
on: aClass 
	"Initialize with the entire protocol for the class, aClass."
	self initListFrom: aClass allSelectors asSortedCollection
		highlighting: aClass! !

!ProtocolBrowser methodsFor: 'private' stamp: 'di 11/26/1999 19:39'!
onSubProtocolOf: aClass 
	"Initialize with the entire protocol for the class, aClass,
		but excluding those inherited from Object."
	| selectors |
	selectors := Set new.
	aClass withAllSuperclasses do:
		[:each | (each == Object or: [each == ProtoObject]) 
			ifFalse: [selectors addAll: each selectors]].
	self initListFrom: selectors asSortedCollection
		highlighting: aClass! !

!ProtocolBrowser methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
setClassAndSelectorIn: csBlock
	"Decode strings of the form    <selectorName> (<className> [class])"

	| i classAndSelString selString sel |

	sel := self selection ifNil: [^ csBlock value: nil value: nil].
	(sel isKindOf: MethodReference) ifTrue: [
		sel setClassAndSelectorIn: csBlock
	] ifFalse: [
		selString := sel asString.
		i := selString indexOf: $(.
		"Rearrange to  <className> [class] <selectorName> , and use MessageSet"
		classAndSelString := (selString copyFrom: i + 1 to: selString size - 1) , ' ' ,
							(selString copyFrom: 1 to: i - 1) withoutTrailingBlanks.
		MessageSet parse: classAndSelString toClassAndSelector: csBlock.
	].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProtocolBrowser class
	instanceVariableNames: ''!

!ProtocolBrowser class methodsFor: 'instance creation' stamp: 'di 7/13/97 15:15'!
openFullProtocolForClass: aClass 
	"Create and schedule a browser for the entire protocol of the class."
	"ProtocolBrowser openFullProtocolForClass: ProtocolBrowser."
	| aPBrowser label |
	aPBrowser := ProtocolBrowser new on: aClass.
	label := 'Entire protocol of: ', aClass name.
	self open: aPBrowser name: label! !

!ProtocolBrowser class methodsFor: 'instance creation' stamp: 'di 7/13/97 15:15'!
openSubProtocolForClass: aClass 
	"Create and schedule a browser for the entire protocol of the class."
	"ProtocolBrowser openSubProtocolForClass: ProtocolBrowser."
	| aPBrowser label |
	aPBrowser := ProtocolBrowser new onSubProtocolOf: aClass.
	label := 'Sub-protocol of: ', aClass name.
	self open: aPBrowser name: label! !
Object subclass: #ProtocolClient
	instanceVariableNames: 'stream connectInfo lastResponse pendingResponses progressObservers'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!ProtocolClient commentStamp: 'gk 12/13/2005 00:34' prior: 0!
ProtocolClient is the abstract super class for a variety of network protocol clients.
It uses a stream rather than the direct network access so it could also work for streams on serial connections etc.

Structure:
	stream				stream representing the connection to and from the server
	connectInfo			information required for opening a connection
	lastResponse			remembers the last response from the server.
	progressObservers 	any object understanding #show: can be registered as a progress observer (login, transfer, etc)!


!ProtocolClient methodsFor: 'accessing' stamp: 'mir 3/7/2002 14:55'!
logProgressToTranscript
	self progressObservers add: Transcript! !

!ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'!
messageText
	^super messageText
		ifNil: [self response]! !

!ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'!
response
	^self protocolInstance lastResponse! !

!ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'!
stream
	^stream! !

!ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'!
stream: aStream
	stream _ aStream! !


!ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:10'!
close
	self stream
		ifNotNil: [
			self stream close.
			stream _ nil]! !

!ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:11'!
reopen
	self ensureConnection! !


!ProtocolClient methodsFor: 'testing' stamp: 'mir 3/7/2002 14:33'!
isConnected
	^stream notNil
		and: [stream isConnected]! !


!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'!
connectionInfo
	connectInfo ifNil: [connectInfo _ Dictionary new].
	^connectInfo! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:34'!
defaultPortNumber
	^self class defaultPortNumber! !

!ProtocolClient methodsFor: 'private' stamp: 'md 8/14/2005 18:27'!
ensureConnection
	self isConnected
		ifTrue: [^self].
	self stream
		ifNotNil: [self stream close].

	self stream: (SocketStream openConnectionToHost: self host port: self port).
	self checkResponse.
	self login! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'!
host
	^self connectionInfo at: #host! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'!
host: hostId
	^self connectionInfo at: #host put: hostId! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'!
lastResponse
	^lastResponse! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'!
lastResponse: aString
	lastResponse _ aString.
! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:07'!
logFlag
	^self class logFlag! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 5/12/2003 18:10'!
logProgress: aString
	self progressObservers do: [:each | each show: aString].
! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:40'!
openOnHost: hostIP port: portNumber
	self host: hostIP.
	self port: portNumber.
	self ensureConnection! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'!
password
	^self connectionInfo at: #password! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'!
password: aString
	^self connectionInfo at: #password put: aString! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'!
pendingResponses
	pendingResponses ifNil: [pendingResponses := OrderedCollection new].
	^pendingResponses! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:55'!
popResponse
	| pendingResponse |
	pendingResponse := self pendingResponses removeFirst.
	pendingResponses isEmpty
		ifTrue: [pendingResponses := nil].
	^pendingResponse! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:57'!
port
	^self connectionInfo at: #port! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:38'!
port: aPortNumber
	^self connectionInfo at: #port put: aPortNumber! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 14:54'!
progressObservers
	progressObservers ifNil: [progressObservers _ OrderedCollection new].
	^progressObservers! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'!
pushResponse: aResponse
	self pendingResponses add: aResponse! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'!
resetConnectionInfo
	connectInfo _ nil! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 11/11/2002 16:19'!
user
	^self connectionInfo at: #user ifAbsent: [nil]! !

!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:39'!
user: aString
	^self connectionInfo at: #user put: aString! !


!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:52'!
checkForPendingError
	"If data is waiting, check it to catch any error reports.
	In case the response is not an error, push it back."

	self stream isDataAvailable
		ifFalse: [^self].
	self fetchNextResponse.
	self
		checkResponse: self lastResponse
		onError: [:response | (TelnetProtocolError protocolInstance: self) signal]
		onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal].
	"if we get here, it wasn't an error"
	self pushResponse: self lastResponse! !

!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 5/9/2003 18:47'!
checkResponse
	"Get the response from the server and check for errors."

	self
		checkResponseOnError: [:response | (TelnetProtocolError protocolInstance: self) signal]
		onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal].
! !

!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:51'!
checkResponse: aResponse onError: errorBlock onWarning: warningBlock
	"Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes."

	self responseIsError
		ifTrue: [errorBlock value: aResponse].
	self responseIsWarning
		ifTrue: [warningBlock value: aResponse].
! !

!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:54'!
checkResponseOnError: errorBlock onWarning: warningBlock
	"Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes."

	self fetchPendingResponse.
	self checkResponse: self lastResponse onError: errorBlock onWarning: warningBlock! !

!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/7/2002 13:16'!
fetchNextResponse
	self lastResponse: self stream nextLine! !

!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:50'!
fetchPendingResponse
	^pendingResponses
		ifNil: [self fetchNextResponse; lastResponse]
		ifNotNil: [self popResponse]! !

!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 5/12/2003 18:10'!
sendCommand: aString
	self stream sendCommand: aString.
! !

!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/5/2002 14:31'!
sendStreamContents: aStream
	self stream sendStreamContents: aStream! !


!ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'!
responseIsError
	self subclassResponsibility! !

!ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'!
responseIsWarning
	self subclassResponsibility! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProtocolClient class
	instanceVariableNames: ''!

!ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 16:00'!
defaultPortNumber
	self subclassResponsibility! !

!ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:07'!
logFlag
	self subclassResponsibility! !


!ProtocolClient class methodsFor: 'instance creation' stamp: 'mir 2/25/2002 15:59'!
openOnHost: hostIP port: portNumber
	^self new openOnHost: hostIP port: portNumber! !

!ProtocolClient class methodsFor: 'instance creation' stamp: 'gk 3/2/2004 11:10'!
openOnHostNamed: hostName
	"If the hostname uses the colon syntax to express a certain portnumber
	we use that instead of the default port number."

	| i |
	i _ hostName indexOf: $:.
	i = 0 ifTrue: [
			^self openOnHostNamed: hostName port: self defaultPortNumber]
		ifFalse: [
			| s p | 
			s _ hostName truncateTo: i - 1.
			p _ (hostName copyFrom: i + 1 to: hostName size) asInteger.
			^self openOnHostNamed: s port: p]
	! !

!ProtocolClient class methodsFor: 'instance creation' stamp: 'mir 2/25/2002 15:58'!
openOnHostNamed: hostName port: portNumber
	| serverIP |
	serverIP _ NetNameResolver addressForName: hostName timeout: 20.
	^self openOnHost: serverIP port: portNumber
! !


!ProtocolClient class methodsFor: 'retrieval' stamp: 'mir 3/5/2002 16:21'!
retrieveMIMEDocument: aURI
	self subclassResponsibility! !
Error subclass: #ProtocolClientError
	instanceVariableNames: 'protocolInstance'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!ProtocolClientError commentStamp: 'mir 5/12/2003 18:05' prior: 0!
Abstract super class for protocol clients

	protocolInstance		reference to the protocol client throughing the exception. Exception handlers can access the client in order close, respond or whatever may be appropriate
!


!ProtocolClientError methodsFor: 'accessing' stamp: 'mir 5/16/2003 11:17'!
messageText
	^super messageText
		ifNil: [self response]! !

!ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'!
protocolInstance
	^protocolInstance! !

!ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'!
protocolInstance: aProtocolInstance
	protocolInstance _ aProtocolInstance! !

!ProtocolClientError methodsFor: 'accessing' stamp: 'mir 5/16/2003 11:18'!
response
	^self protocolInstance lastResponse! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProtocolClientError class
	instanceVariableNames: ''!

!ProtocolClientError class methodsFor: 'instance creation' stamp: 'mir 10/30/2000 16:15'!
protocolInstance: aProtocolInstance
	^self new protocolInstance: aProtocolInstance! !
Object subclass: #PrototypeTester
	instanceVariableNames: 'prototype'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!PrototypeTester commentStamp: 'mjr 8/20/2003 13:09' prior: 0!
I am a simple holder of a prototype object and hand out copies when requested.!


!PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'!
prototype
	"Get a prototype"
	^ prototype copy ! !

!PrototypeTester methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/3/2006 22:39'!
prototype: aPrototype 
	"Set my prototype"
	prototype := aPrototype copy ! !

!PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:57'!
result
	"Perform the test the default number of times"
	^ self resultFor: self class defaultRuns ! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrototypeTester class
	instanceVariableNames: ''!

!PrototypeTester class methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 13:08'!
defaultRuns
"the default number of times to test"
	^ 50! !

!PrototypeTester class methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 13:08'!
with: aPrototype
	^self new prototype:aPrototype! !
Notification subclass: #ProvideAnswerNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
CodeModelExtension subclass: #ProvidedSelectors
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Requires'!

!ProvidedSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/5/2005 14:20'!
isSelector: selector providedIn: aClass
	^(self haveInterestsIn: aClass) 
		ifFalse: [aClass classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false]]
		ifTrue: [(self for: aClass) includes: selector]
		! !

!ProvidedSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 20:56'!
newCacheFor: aClass 

	| cache |
	aClass ifNil: [^IdentitySet new].
	cache := self for: aClass superclass copy.
	aClass selectorsAndMethodsDo: [:s :m | 
		m isProvided 
			ifTrue: [cache add: s]
			ifFalse: [cache remove: s ifAbsent: []]].
	^cache! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProvidedSelectors class
	instanceVariableNames: ''!
Object subclass: #PseudoClass
	instanceVariableNames: 'name definition organization source metaClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FilePackage'!
!PseudoClass commentStamp: '<historical>' prior: 0!
I provide an inert model of a Class, used by FileContentsBrowser to manipulate filedout code. Instead of a method dictionary or selectors onto CompiledMethods, I have a dictionary ("source") of selectors onto ChangeRecords, which were, in the case of FileContentsBrowser, parsed from a source or change set file.!


!PseudoClass methodsFor: 'accessing' stamp: 'nk 4/29/2004 06:59'!
allCallsOn
	^ (self realClass ifNil: [ ^#() ]) allCallsOn! !

!PseudoClass methodsFor: 'accessing' stamp: 'sma 6/16/1999 22:59'!
allInstVarNames
	^#()! !

!PseudoClass methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:32'!
allSuperclasses
	^ (self realClass ifNil: [ ^#() ]) allSuperclasses! !

!PseudoClass methodsFor: 'accessing' stamp: 'sma 4/28/2000 17:24'!
compilerClass
	^ (Smalltalk at: name ifAbsent: [^ Compiler]) compilerClass! !

!PseudoClass methodsFor: 'accessing'!
fullName
	^self name! !

!PseudoClass methodsFor: 'accessing' stamp: 'nk 3/9/2004 10:24'!
instVarNames
	^ #()! !

!PseudoClass methodsFor: 'accessing'!
name
	^name! !

!PseudoClass methodsFor: 'accessing'!
name: anObject
	name _ anObject! !

!PseudoClass methodsFor: 'accessing' stamp: 'NS 4/6/2004 15:46'!
organization
	organization ifNil: [organization _ PseudoClassOrganizer defaultList: SortedCollection new].

	"Making sure that subject is set correctly. It should not be necessary."
	organization setSubject: self.
	^ organization! !

!PseudoClass methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:00'!
prettyPrinterClass
	^self class prettyPrinterClass! !

!PseudoClass methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:32'!
realClass
	^Smalltalk at: self name asSymbol ifAbsent: []! !

!PseudoClass methodsFor: 'accessing' stamp: 'sd 6/27/2003 22:56'!
theMetaClass
	^ self metaclass! !

!PseudoClass methodsFor: 'accessing' stamp: 'wod 5/19/1998 17:42'!
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^self! !


!PseudoClass methodsFor: 'categories'!
removeCategory: selector
	(self organization listAtCategoryNamed: selector) do:[:sel|
		self organization removeElement: sel.
		self sourceCode removeKey: sel.
	].
	self organization removeCategory: selector.! !

!PseudoClass methodsFor: 'categories'!
removedCategoryName
	^'*** removed methods ***' asSymbol! !

!PseudoClass methodsFor: 'categories'!
whichCategoryIncludesSelector: aSelector 
	"Answer the category of the argument, aSelector, in the organization of 
	the receiver, or answer nil if the receiver does not inlcude this selector."

	^ self organization categoryOfElement: aSelector! !


!PseudoClass methodsFor: 'class'!
classComment: aChangeRecord
	self organization classComment: aChangeRecord! !

!PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'!
classPool 
	self exists ifFalse: [^ nil].
	^ self realClass classPool! !

!PseudoClass methodsFor: 'class' stamp: 'BJP 4/23/2001 13:50'!
comment
	| rStr |
	rStr := self organization commentRemoteStr.
	^rStr isNil
		ifTrue:[self name,' has not been commented in this file']
		ifFalse:[rStr string]! !

!PseudoClass methodsFor: 'class'!
comment: aString
	self commentString: aString.! !

!PseudoClass methodsFor: 'class' stamp: 'ar 2/5/2004 15:18'!
commentString
	^self comment asString! !

!PseudoClass methodsFor: 'class'!
commentString: aString
	self classComment: aString asText. "Just wrap it"! !

!PseudoClass methodsFor: 'class' stamp: 'LC 10/8/2001 04:46'!
definition
	| link linkText defText |
	^definition ifNil:
		[defText _ Text fromString: 'There is no class definition for '.
		link _ TextLink new.
		linkText _ link analyze: self name with: 'Definition'.
		linkText _ Text string: (linkText ifNil: ['']) attribute: link.
		defText append: linkText; append: ' in this file'].! !

!PseudoClass methodsFor: 'class'!
definition: aString
	definition := aString! !

!PseudoClass methodsFor: 'class'!
metaClass
	^metaClass ifNil:[metaClass := PseudoMetaclass new name: (self name)].! !

!PseudoClass methodsFor: 'class' stamp: 'nk 2/18/2004 18:30'!
renameTo: aString

	self hasDefinition ifTrue:[
		self isMeta ifTrue:[
			self definition: (self definition
				copyReplaceAll: name,' class'
				with: aString, ' class').
		] ifFalse:[
			self definition: (self definition 
					copyReplaceAll:'ubclass: #',name
					with:'ubclass: #', aString)]].
	name := aString.
	metaClass ifNotNil:[metaClass renameTo: aString].! !

!PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'!
sharedPools 
	self exists ifFalse: [^ nil].
	^ self realClass sharedPools! !


!PseudoClass methodsFor: 'errors'!
classNotDefined
	^self inform: self name,' is not defined in the system.
You have to define this class first.'.! !


!PseudoClass methodsFor: 'fileIn/fileOut'!
fileIn
	"FileIn the receiver"
	self hasDefinition ifTrue:[self fileInDefinition].
	self fileInMethods: self selectors.
	metaClass ifNotNil:[metaClass fileIn].
	self needsInitialize ifTrue:[
		self evaluate: self name,' initialize'.
	].! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInCategory: aCategory
	^self fileInMethods: (self organization listAtCategoryNamed: aCategory)! !

!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'ar 7/16/2005 14:06'!
fileInDefinition
	self hasDefinition ifFalse:[^self].
	(self makeSureSuperClassExists: (definition copyUpTo: Character space)) ifFalse:[^self].
	self hasDefinition ifTrue:[
		Transcript cr; show:'Defining ', self name.
		self evaluate: self definition].
	self exists ifFalse:[^self].
	self hasComment ifTrue:[self realClass classComment: self comment].! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInMethod: selector
	^self fileInMethods: (Array with: selector)! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInMethods
	^self fileInMethods: self selectors! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInMethods: aCollection
	"FileIn all methods with selectors taken from aCollection"
	| theClass cat |
	self exists ifFalse:[^self classNotDefined].
	theClass := self realClass.
	aCollection do:[:sel|
		cat := self organization categoryOfElement: sel.
		cat = self removedCategoryName ifFalse:[
			theClass 
				compile: (self sourceCodeAt: sel) 
				classified: cat
				withStamp: (self stampAt: sel)
				notifying: nil.
		].
	].! !

!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'yo 7/5/2004 20:21'!
fileOut
	| internalStream |
	internalStream _ WriteStream on: (String new: 1000).
	self fileOutOn: internalStream.
	self needsInitialize ifTrue:[
		internalStream cr; nextChunkPut: self name,' initialize'.
	].

	FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: false.
! !

!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'yo 7/5/2004 20:21'!
fileOutCategory: categoryName

	| internalStream |
	internalStream _ WriteStream on: (String new: 1000).
	self fileOutMethods: (self organization listAtCategoryNamed: categoryName)
			on: internalStream.
	FileStream writeSourceCodeFrom: internalStream baseName: (self name, '-', categoryName) isSt: true useHtml: false.
! !

!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'hg 9/6/2000 12:45'!
fileOutDefinitionOn: aStream
	self hasDefinition ifFalse:[^self].
	aStream nextChunkPut: self definition; cr.
	self hasComment
		ifTrue:
			[aStream cr.
			self organization commentRemoteStr fileOutOn:
aStream]! !

!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'yo 7/5/2004 20:21'!
fileOutMethod: selector
	| internalStream |

	internalStream _ WriteStream on: (String new: 1000).

	self fileOutMethods: (Array with: selector) on: internalStream.

	FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true useHtml: false.
! !

!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'ar 2/7/2004 01:04'!
fileOutMethods: aCollection on: aStream
	"FileOut all methods with selectors taken from aCollection"
	| cat categories |
	categories := Dictionary new.
	aCollection do:[:sel|
		cat := self organization categoryOfElement: sel.
		cat = self removedCategoryName ifFalse:[
			(categories includesKey: cat) 
				ifFalse:[categories at: cat put: Set new].
			(categories at: cat) add: sel].
	].
	categories associationsDo:[:assoc|
		cat := assoc key.
		assoc value do:[:sel|
			aStream cr.
			(self sourceCode at: sel) fileOutOn: aStream.
		].
	].! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileOutMethodsOn: aStream
	^self fileOutMethods: self selectors on: aStream.! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileOutOn: aStream
	"FileOut the receiver"
	self fileOutDefinitionOn: aStream.
	metaClass ifNotNil:[metaClass fileOutDefinitionOn: aStream].
	self fileOutMethods: self selectors on: aStream.
	metaClass ifNotNil:[metaClass fileOutMethods: metaClass selectors on: aStream].! !


!PseudoClass methodsFor: 'methods' stamp: 'sma 6/1/2000 14:54'!
addMethodChange: aChangeRecord
	| selector |
	selector _ self parserClass new parseSelector: aChangeRecord string.
	self organization classify: selector under: aChangeRecord category.
	self sourceCodeAt: selector put: aChangeRecord! !

!PseudoClass methodsFor: 'methods'!
methodChange: aChangeRecord
	aChangeRecord isMetaClassChange ifTrue:[
		^self metaClass addMethodChange: aChangeRecord.
	] ifFalse:[
		^self addMethodChange: aChangeRecord.
	].
! !

!PseudoClass methodsFor: 'methods'!
removeMethod: selector
	self organization removeElement: selector.
	self sourceCode removeKey: selector.
! !

!PseudoClass methodsFor: 'methods'!
removeSelector: aSelector
	| catName |
	catName := self removedCategoryName.
	self organization addCategory: catName before: self organization categories first.
	self organization classify: aSelector under: catName.
	self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! !

!PseudoClass methodsFor: 'methods'!
selectors
	^self sourceCode keys! !

!PseudoClass methodsFor: 'methods'!
sourceCode
	^source ifNil:[source := Dictionary new]! !

!PseudoClass methodsFor: 'methods'!
sourceCodeAt: sel
	^(self sourceCode at: sel) string! !

!PseudoClass methodsFor: 'methods'!
sourceCodeAt: sel put: object
	self sourceCode at: sel put: object! !

!PseudoClass methodsFor: 'methods'!
sourceCodeTemplate
	^''! !

!PseudoClass methodsFor: 'methods' stamp: 'sw 6/10/2003 17:31'!
stampAt: selector
	"Answer the authoring time-stamp of the change"

	| code |
	^ ((code _ self sourceCode at: selector) isKindOf: ChangeRecord)
		ifTrue:
			[code stamp]
		ifFalse:
			[code string]! !


!PseudoClass methodsFor: 'printing' stamp: 'sma 6/17/1999 00:00'!
literalScannedAs: scannedLiteral notifying: requestor 
	^ scannedLiteral! !

!PseudoClass methodsFor: 'printing' stamp: 'ar 2/5/2004 16:04'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(; print: name; nextPut:$)! !


!PseudoClass methodsFor: 'removing'!
removeAllUnmodified
	| stClass |
	self exists ifFalse:[^self].
	self removeUnmodifiedMethods: self selectors.
	stClass := self realClass.
	(self hasDefinition and:[stClass definition = self definition]) ifTrue:[definition := nil].
	(self hasComment and:[stClass comment asString = self commentString]) ifTrue:[ self classComment: nil].
	metaClass isNil ifFalse:[metaClass removeAllUnmodified].! !

!PseudoClass methodsFor: 'removing'!
removeUnmodifiedMethods: aCollection
	| stClass |
	self exists ifFalse:[^self].
	stClass := self realClass.
	aCollection do:[:sel|
		(self sourceCodeAt: sel) = (stClass sourceCodeAt: sel ifAbsent:['']) asString ifTrue:[
			self removeMethod: sel.
		].
	].
	self organization removeEmptyCategories.! !


!PseudoClass methodsFor: 'testing'!
exists
	^(Smalltalk at: self name asSymbol ifAbsent:[^false]) isKindOf: Behavior! !

!PseudoClass methodsFor: 'testing'!
hasChanges

	self sourceCode isEmpty ifFalse:[^true].
	self organization hasNoComment ifFalse:[^true].
	definition isNil ifFalse:[^true].
	metaClass isNil ifFalse:[^metaClass hasChanges].
	^false! !

!PseudoClass methodsFor: 'testing'!
hasComment
	^self organization commentRemoteStr notNil! !

!PseudoClass methodsFor: 'testing'!
hasDefinition
	^definition notNil! !

!PseudoClass methodsFor: 'testing'!
hasMetaclass
	^metaClass notNil! !

!PseudoClass methodsFor: 'testing' stamp: 'al 3/1/2006 22:26'!
isTrait
	^false! !

!PseudoClass methodsFor: 'testing'!
nameExists
	^Smalltalk includesKey: self name asSymbol! !

!PseudoClass methodsFor: 'testing'!
needsInitialize
	^self hasMetaclass and:[
		self metaClass selectors includes: #initialize]! !


!PseudoClass methodsFor: 'testing method dictionary' stamp: 'ar 5/17/2003 14:06'!
bindingOf: varName
	self exists ifTrue:[
		(self realClass bindingOf: varName) ifNotNilDo:[:binding| ^binding].
	].
	^Smalltalk bindingOf: varName asSymbol! !


!PseudoClass methodsFor: '*monticello' stamp: 'bf 7/25/2005 15:50'!
asClassDefinition
	^ MCClassDefinition
		name: self name
		superclassName: self superclass name
		category: self category 
		instVarNames: self instVarNames
		classVarNames: self classVarNames asSortedCollection
		poolDictionaryNames: self poolDictionaryNames
		classInstVarNames: self class instVarNames
		type: self typeOfClass
		comment: self organization classComment	 asString
		commentStamp: self organization commentStamp	! !


!PseudoClass methodsFor: '*monticello-override' stamp: 'nk 2/18/2004 18:30'!
isMeta
	^false! !


!PseudoClass methodsFor: 'private' stamp: 'nk 2/18/2004 18:33'!
allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level
	^ (self realClass ifNil: [ ^self ])  allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level! !

!PseudoClass methodsFor: 'private'!
confirmRemovalOf: aString
	^self confirm:'Remove ',aString,' ?'! !

!PseudoClass methodsFor: 'private'!
evaluate: aString
	^Compiler evaluate: aString for: nil logged: true! !

!PseudoClass methodsFor: 'private'!
makeSureClassExists: aString
	| theClass |
	theClass := Smalltalk at: (aString asSymbol) ifAbsent:[nil].
	theClass ifNotNil:[^true].
	^self confirm: aString,' does not exist in the system. Use nil instead?'.! !

!PseudoClass methodsFor: 'private'!
makeSureSuperClassExists: aString
	| theClass |
	theClass := Smalltalk at: (aString asSymbol) ifAbsent:[nil].
	theClass ifNotNil:[^true].
	^self confirm: 'The super class ',aString,' does not exist in the system. Use nil instead?'.! !

!PseudoClass methodsFor: 'private' stamp: 'ajh 1/21/2003 13:03'!
parserClass

	^ Compiler parserClass! !
BasicClassOrganizer subclass: #PseudoClassOrganizer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FilePackage'!

!PseudoClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 12:27'!
setDefaultList: aCollection
	super setDefaultList: aCollection.
	self classComment: nil.! !


!PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'NS 4/6/2004 16:44'!
classComment
	"Answer the comment associated with the object that refers to the receiver."
	classComment == nil ifTrue: [^''].
	^classComment! !

!PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'NS 4/6/2004 16:44'!
classComment: aChangeRecord
	classComment := aChangeRecord! !
ProtoObject variableSubclass: #PseudoContext
	instanceVariableNames: 'fixed fields never accessed from smalltalk'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'.
PseudoContext superclass: nil!
!PseudoContext commentStamp: '<historical>' prior: 0!
I represent cached context state within the virtual machine.  I have the same format as normal method and block contexts, but my fields are never referenced directly from Smalltalk.  Whenever a message is sent to me I will magically transform myself into a real context which will respond to all the usual messages.
	I rely on the fact that block and method contexts have exactly the same number of fixed fields.!


!PseudoContext methodsFor: 'system primitives' stamp: 'ikp 10/20/97 15:36'!
nextObject
	"See Object>>nextObject."

	<primitive: 139>
	self primitiveFailed.! !


!PseudoContext methodsFor: 'testing' stamp: 'ikp 9/26/97 14:45'!
isPseudoContext
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PseudoContext class
	instanceVariableNames: ''!

!PseudoContext class methodsFor: 'class initialization' stamp: 'ikp 1/10/98 02:33'!
initialize
	"It's tricky to do the necessary stuff with the regular file-in machinery."

	PseudoContext superclass = nil
		ifFalse: [
			(Smalltalk confirm: 'Shall I convert PseudoContext into a compact subclass of nil?
("yes" is almost always the correct response)')
				ifTrue: [
					PseudoContext becomeCompact.
					PseudoContext superclass removeSubclass: PseudoContext.
					PseudoContext superclass: nil]].
	Smalltalk recreateSpecialObjectsArray.
	Smalltalk specialObjectsArray size = 41
		ifFalse: [self error: 'Please check size of special objects array!!']! !


!PseudoContext class methodsFor: 'filing out' stamp: 'ikp 9/26/97 14:45'!
definition
	"Our superclass is really nil, but this causes problems when we try to become compact
	after filing in for the first time.  Fake the superclass as Object, and repair the situation
	during class initialisation."
	| defn |
	defn _ super definition.
	^(defn beginsWith: 'nil ')
		ifTrue: ['Object' , (defn copyFrom: 4 to: defn size)]
		ifFalse: [defn].! !


!PseudoContext class methodsFor: 'private' stamp: 'ikp 9/26/97 14:45'!
contextCacheDepth
	"Answer the number of entries in the context cache.  This requires a little insider
	knowledge.  Not intended for casual use, which is why it's private protocol."

	^self contextCacheDepth: thisContext yourself! !

!PseudoContext class methodsFor: 'private' stamp: 'ikp 9/26/97 14:45'!
contextCacheDepth: b
	^b isPseudoContext
		ifTrue: [1 + (self contextCacheDepth: b)]
		ifFalse: [1]! !
PseudoClass subclass: #PseudoMetaclass
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FilePackage'!

!PseudoMetaclass methodsFor: 'accessing'!
fullName
	^self name,' class'! !

!PseudoMetaclass methodsFor: 'accessing'!
realClass
	^super realClass class! !

!PseudoMetaclass methodsFor: 'accessing' stamp: 'FBS 3/4/2004 14:17'!
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^self realClass theNonMetaClass! !


!PseudoMetaclass methodsFor: '*monticello-override' stamp: 'nk 2/18/2004 18:30'!
isMeta
	^true! !
Object subclass: #PseudoPoolVariable
	instanceVariableNames: 'name getterBlock setterBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Contexts'!
!PseudoPoolVariable commentStamp: '<historical>' prior: 0!
The values of pool and global variables (traditionally Associations) are fetched by sending #poolValue and set by sending #setInPool: which send #poolValue:.  These sends are automatically added in by the Compiler (see PoolVarNode {code generation}).  So any object can act like a pool variable.  This class allows getter and setter blocks for poolValue and poolValue:.!


!PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 12:08'!
canAssign

	^ setterBlock notNil! !

!PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:01'!
getter: block

	getterBlock _ block! !

!PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 14:15'!
name

	^ name! !

!PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:00'!
name: string

	name _ string! !

!PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:01'!
setter: block

	setterBlock _ block! !

!PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 14:02'!
value

	^ getterBlock value! !

!PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 13:58'!
value: obj

	setterBlock value: obj! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PseudoPoolVariable class
	instanceVariableNames: ''!
TraitsTestCase subclass: #PureBehaviorTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:33'!
testIsAliasSelector
	self deny: (self t1 isAliasSelector: #m11).
	self deny: (self t1 isAliasSelector: #foo).

	"directly"
	self assert: (self t6 isAliasSelector: #m22Alias).
	self deny: (self t6 isAliasSelector: #m22).

	"indirectly"
	self c1 setTraitCompositionFrom: self t6.
	self assert: (self c1 isAliasSelector: #m22Alias).
	self deny: (self c1 isAliasSelector: #m22)! !

!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:33'!
testIsLocalAliasSelector
	self deny: (self t1 isLocalAliasSelector: #m11).
	self deny: (self t1 isLocalAliasSelector: #foo).

	"directly"
	self assert: (self t6 isLocalAliasSelector: #m22Alias).
	self deny: (self t6 isLocalAliasSelector: #m22).

	"indirectly"
	self c1 setTraitComposition: self t6 asTraitComposition.
	self deny: (self c1 isLocalAliasSelector: #m22Alias).
	self deny: (self c1 isLocalAliasSelector: #m22)! !

!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testLocalSelectors
	"self run: #testLocalSelectors"

	self assert: self t3 localSelectors size = 3.
	self assert: (self t3 localSelectors includesAllOf: #(#m31 #m32 #m33 )).
	self assert: (self t3 includesLocalSelector: #m32).
	self deny: (self t3 includesLocalSelector: #inexistantSelector).
	self assert: self t5 localSelectors size = 3.
	self assert: (self t5 localSelectors includes: #m51).
	self assert: (self t5 includesLocalSelector: #m51).
	self deny: (self t5 includesLocalSelector: #m11).
	self t5 removeSelector: #m51.
	self deny: (self t3 includesLocalSelector: #m51).
	self deny: (self t5 includesLocalSelector: #m11).
	self assert: self t5 localSelectors size = 2.
	self t5 compile: 'm52 ^self'.
	self assert: self t5 localSelectors size = 2.
	self assert: (self t5 localSelectors includes: #m52).

	"test that propagated methods do not get in as local methods"
	self t2 compile: 'local2 ^self'.
	self deny: (self t5 includesLocalSelector: #local2).
	self assert: self t5 localSelectors size = 2.
	self assert: (self t5 localSelectors includes: #m52).
	self assert: self c2 localSelectors size = 2.
	self assert: (self c2 localSelectors includesAllOf: #(#foo #bar ))! !

!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testMethodCategoryReorganization
	"self run: #testMethodCategory"

	self t1 compile: 'm1' classified: 'category1'.
	self assert: (self t5 organization categoryOfElement: #m1) = #category1.
	self assert: (self c2 organization categoryOfElement: #m1) = #category1.
	self t1 organization 
		classify: #m1
		under: #category2
		suppressIfDefault: true.
	self assert: (self t5 organization categoryOfElement: #m1) = #category2.
	self assert: (self c2 organization categoryOfElement: #m1) = #category2! !

!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testRemovingMethods
	"When removing a local method, assure that the method
	from the trait is installed instead and that the users are 
	updated."

	"self run: #testRemovingMethods"

	"Classes"

	self c2 compile: 'm12 ^0' classified: #xxx.
	self assert: (self c2 includesLocalSelector: #m12).
	self c2 removeSelector: #m12.
	self deny: (self c2 includesLocalSelector: #m12).
	self assert: (self c2 selectors includes: #m12).

	"Traits"
	self t5 compile: 'm12 ^0' classified: #xxx.
	self assert: self c2 new m12 = 0.
	self t5 removeSelector: #m12.
	self deny: (self t5 includesLocalSelector: #m12).
	self assert: (self t5 selectors includes: #m12).
	self assert: self c2 new m12 = 12! !

!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:33'!
traitOrClassOfSelector
	"self run: #traitOrClassOfSelector"

	"locally defined in trait or class"

	self assert: (self t1 traitOrClassOfSelector: #m12) = self t1.
	self assert: (self c1 traitOrClassOfSelector: #foo) = self c1.

	"not locally defined - simple"
	self assert: (self t4 traitOrClassOfSelector: #m21) = self t2.
	self assert: (self c2 traitOrClassOfSelector: #m51) = self t5.

	"not locally defined - into nested traits"
	self assert: (self c2 traitOrClassOfSelector: #m22) = self t2.

	"not locally defined - aliases"
	self assert: (self t6 traitOrClassOfSelector: #m22Alias) = self t2.

	"class side"
	self assert: (self t2 classSide traitOrClassOfSelector: #m2ClassSide:) 
				= self t2 classSide.
	self assert: (self t6 classSide traitOrClassOfSelector: #m2ClassSide:) 
				= self t2 classSide! !


!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'al 9/19/2005 23:00'!
testChangeSuperclass
	"self run: #testChangeSuperclass"

	"Test that when the superclass of a class is changed the non-local methods
	of the class sending super are recompiled to correctly store the new superclass."

	| aC2 newSuperclass |
	aC2 := self c2 new.

	"C1 is current superclass of C2"
	self assert: aC2 m51.
	self assert: self c2 superclass == self c1.
	self deny: (self c2 localSelectors includes: #m51).

	"change superclass of C2 from C1 to X"
	newSuperclass := self createClassNamed: #X superclass: Object uses: {}.
	newSuperclass
		subclass: self c2 name
		uses: self c2 traitComposition
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: self c2 category.

	self assert: self c2 superclass == newSuperclass.

	newSuperclass compile: 'foo ^17'.
	self assert: aC2 m51 = 17.
	self deny: (self c2 localSelectors includes: #m51).

	self c2 compile: 'm51 ^19'.
	self assert: aC2 m51 = 19.

	"Other methods than those sending super should not have been recompiled"
	self assert: self c2 >> #m52 == (self t5 >> #m52).

	
	! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'al 3/26/2006 12:24'!
testClassesWithTraits
	"self debug: #testClassesWithTraits"

	self assert: (self c1 methodDict includesKey: #foo).
	self assert: (self c2 methodDict includesKey: #bar).
	self assert: (self c2 methodDict includesKey: #m51).
	self assert: (self c2 methodDict includesKey: #m12).
	self assert: (self c2 methodDict includesKey: #m13).
	self assert: (self c2 methodDict includesKey: #m21).
	self assert: (self c2 methodDict includesKey: #m22).
	
	self deny: self c1 class hasTraitComposition.
	self assert: self c2 class hasTraitComposition.

	self assert: (self c2 class traitComposition size = 1).
	self assert: (self c2 class traitComposition includesTrait: self t5 classTrait)! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:21'!
testOwnMethodsTakePrecedenceOverTraitsMethods
	"First create a trait with no subtraits and then
	add subtrait t1 which implements m11 as well."

	| trait |
	trait := self createTraitNamed: #T
				uses: { }.
	trait compile: 'm11 ^999'.
	self assert: trait methodDict size = 1.
	self assert: (trait methodDict at: #m11) decompileString = 'm11
	^ 999'.
	Trait 
		named: #T
		uses: self t1
		category: self class category.
	self assert: trait methodDict size = 3.
	self assert: (trait methodDict keys includesAllOf: #(#m11 #m12 #m13 )).
	self assert: (trait methodDict at: #m11) decompileString = 'm11
	^ 999'.
	self assert: (trait methodDict at: #m12) decompileString = 'm12
	^ 12'! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:32'!
testPropagationOfChangesInTraits
	| aC2 |
	aC2 := self c2 new.
	self assert: self c2 methodDict size = 9.
	self t1 compile: 'zork ^false'.
	self assert: self c2 methodDict size = 10.
	self deny: aC2 zork.
	self t1 removeSelector: #m12.
	self assert: self c2 methodDict size = 9.
	self should: [aC2 m12] raise: MessageNotUnderstood.
	self assert: aC2 m21 = 21.
	self t2 compile: 'm21 ^99'.
	self assert: aC2 m21 = 99! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:33'!
testPropagationOfChangesInTraitsToAliasMethods
	| anObject |
	anObject := (self 
				createClassNamed: #AliasTestClass
				superclass: Object
				uses: self t6) new.
	self assert: anObject m22Alias = 22.

	"test update alias method"
	self t2 compile: 'm22 ^17'.
	self assert: anObject m22Alias = 17.

	"removing original method should also remove alias method"
	self t2 removeSelector: #m22.
	self should: [anObject m22Alias] raise: MessageNotUnderstood! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:21'!
testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded
	"Assert that alias method is updated although
	the original method is excluded from this user."

	| anObject |
	anObject := (self 
				createClassNamed: #AliasTestClass
				superclass: Object
				uses: self t1 @ { (#aliasM11 -> #m11) } - { #m11 }) new.
	self assert: anObject aliasM11 = 11.
	self deny: (anObject class methodDict includesKey: #m11).
	self t1 compile: 'm11 ^17'.
	self assert: anObject aliasM11 = 17! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:32'!
testPropagationWhenTraitCompositionModifications
	"Test that the propagation mechanism works when
	setting new traitCompositions."

	self assert: self c2 methodDict size = 9.	"2 + (3+(3+2))-1"

	"removing methods"
	Trait 
		named: #T5
		uses: self t1 + self t2 - { #m21. #m22 }
		category: self class category.
	self assert: self c2 methodDict size = 7.

	"adding methods"
	Trait 
		named: #T2
		uses: self t3
		category: self class category.
	self assert: self c2 methodDict size = 10.
	self assert: (self c2 methodDict keys includesAllOf: #(#m31 #m32 #m33 ))! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:32'!
testSuperSends
	| aC2 |
	aC2 := self c2 new.
	self assert: aC2 m51.
	self deny: aC2 foo.
	self deny: aC2 bar! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:33'!
testTraitCompositionModifications
	self assert: self t6 methodDict size = 6.
	self assert: (self t6 sourceCodeAt: #m22Alias) asString = 'm22Alias ^22'.
	self t6 setTraitComposition: self t2 asTraitComposition.
	self assert: self t6 methodDict size = 2.
	self deny: (self t6 methodDict includesKey: #m22Alias).
	self t6 
		setTraitCompositionFrom: self t1 @ { (#m13Alias -> #m13) } - { #m11. #m12 } 
				+ self t2.
	self assert: self t6 methodDict size = 4.
	self 
		assert: (self t6 methodDict keys includesAllOf: #(#m13 #m13Alias #m21 #m22 )).
	self 
		assert: (self t6 sourceCodeAt: #m13Alias) asString = 'm13Alias ^self m12'! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:31'!
testTraitCompositionWithCycles
	self should: [self t1 setTraitComposition: self t1 asTraitComposition]
		raise: Error.
	self t2 setTraitComposition: self t3 asTraitComposition.
	self should: [self t3 setTraitComposition: self t5 asTraitComposition]
		raise: Error! !

!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:32'!
testUpdateWhenLocalMethodRemoved
	| aC2 |
	aC2 := self c2 new.
	self t5 compile: 'foo ^123'.
	self deny: aC2 foo.
	self c2 removeSelector: #foo.
	self assert: aC2 foo = 123! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PureBehaviorTest class
	instanceVariableNames: ''!
Rectangle subclass: #Quadrangle
	instanceVariableNames: 'borderWidth borderColor insideColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Quadrangle commentStamp: '<historical>' prior: 0!
I represent a particular kind of Rectangle that has a border and inside color.!


!Quadrangle methodsFor: 'bordering'!
borderColor
	"Answer the form that is the borderColor of the receiver."

	^borderColor! !

!Quadrangle methodsFor: 'bordering'!
borderColor: aColor 
	"Set the borderColor of the receiver to aColor, a Form."

	borderColor _ aColor! !

!Quadrangle methodsFor: 'bordering'!
borderWidth
	"Answer the borderWidth of the receiver."

	^borderWidth! !

!Quadrangle methodsFor: 'bordering'!
borderWidth: anInteger 
	"Set the borderWidth of the receiver to anInteger."

	borderWidth _ anInteger! !

!Quadrangle methodsFor: 'bordering'!
borderWidthLeft: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4
	"Set the border width of the receiver to a Rectangle that represents the 
	left, right, top, and bottom border widths."

	borderWidth _ anInteger1 @ anInteger3 corner: anInteger2 @ anInteger4! !

!Quadrangle methodsFor: 'bordering'!
inside
	"Answer a Rectangle that is the receiver inset by the borderWidth."

	^self insetBy: borderWidth! !

!Quadrangle methodsFor: 'bordering'!
insideColor
	"Answer the form that is the insideColor of the receiver."

	^insideColor! !

!Quadrangle methodsFor: 'bordering'!
insideColor: aColor 
	"Set the insideColor of the receiver to aColor, a Form."

	insideColor _ aColor! !

!Quadrangle methodsFor: 'bordering'!
region
	"Answer a Rectangle that defines the area of the receiver."

	^origin corner: corner! !

!Quadrangle methodsFor: 'bordering'!
region: aRectangle 
	"Set the rectangular area of the receiver to aRectangle."

	origin _ aRectangle origin.
	corner _ aRectangle corner! !

!Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:30'!
setHeight: aNumber 
	"Set the receiver's height"

	self region: (origin extent: (self width @ aNumber))! !

!Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 17:54'!
setLeft: aNumber 
	"Move the receiver so that its left edge is given by aNumber.  An example of a setter to go with #left"

	self region: ((aNumber @ origin y) extent: self extent)! !

!Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:19'!
setRight: aNumber 
	"Move the receiver so that its right edge is given by aNumber.  An example of a setter to go with #right"

	self region: ((origin x + (aNumber - self right) @ origin y) extent: self extent)! !

!Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:26'!
setWidth: aNumber 
	"Set the receiver's width"

	self region: (origin extent: (aNumber @ self height))! !


!Quadrangle methodsFor: 'displaying-Display'!
display 
	"Display the border and insideRegion of the receiver on the Display."

	self displayOn: Display! !

!Quadrangle methodsFor: 'displaying-Display'!
displayAlign: aPoint1 with: aPoint2 clippingBox: aRectangle 
	"Display the border and region of the receiver on the Display so that its 
	position at aPoint1 is aligned with position aPoint2. The displayed 
	information should be clipped so that only information with the area 
	determined by aRectangle is displayed." 

	self displayOn: Display align: aPoint1 with: aPoint2 clippingBox: aRectangle! !

!Quadrangle methodsFor: 'displaying-Display'!
displayTransformation: aWindowingTransformation clippingBox: aRectangle 
	"Display the border and region of the receiver on the Display so that it 
	is scaled and translated with respect to aWindowingTransformation. The 
	displayed information should be clipped so that only information with 
	the area determined by aRectangle is displayed." 

	self displayOn: Display transformation: aWindowingTransformation clippingBox: aRectangle! !


!Quadrangle methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium
	"Display the border and insideRegion of the receiver."

	borderWidth ~~ 0
		ifTrue:	[aDisplayMedium
				border: self region
				widthRectangle: borderWidth
				rule: Form over
				fillColor: borderColor].
	insideColor ~~ nil
		ifTrue:	[aDisplayMedium fill: self inside fillColor: insideColor]! !

!Quadrangle methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium align: aPoint1 with: aPoint2 clippingBox: aRectangle
	"Display the border and region of the receiver so that its position at 
	aPoint1 is aligned with position aPoint2. The displayed information 
	should be clipped so that only information with the area determined by 
	aRectangle is displayed."

	| savedRegion |
	savedRegion _ self region.
	self region: ((savedRegion align: aPoint1 with: aPoint2) intersect: aRectangle).
	self displayOn: aDisplayMedium.
	self region: savedRegion! !

!Quadrangle methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: aWindowingTransformation clippingBox: aRectangle
	"Display the border and region of the receiver so that it is scaled and 
	translated with respect to aWindowingTransformation. The displayed 
	information should be clipped so that only information with the area 
	determined by aRectangle is displayed."

	| screenRectangle |
	screenRectangle _ 
		(aWindowingTransformation applyTo: self) intersect: aRectangle.
	borderWidth ~~ 0 & (insideColor ~~ nil)
		ifTrue: 
			[aDisplayMedium fill: screenRectangle fillColor: Color black "borderColor".
			aDisplayMedium
				fill: (screenRectangle insetBy: borderWidth)
				fillColor: insideColor]! !

!Quadrangle methodsFor: 'displaying-generic'!
displayOnPort: aPort at: p
	"Display the border and insideRegion of the receiver."

	(insideColor == nil or: [borderWidth <= 0])
		ifFalse: [aPort fill: (self region translateBy: p) 
			fillColor: borderColor rule: Form over].
	insideColor == nil
		ifFalse: [aPort fill: (self inside translateBy: p) 
			fillColor: insideColor rule: Form over]! !


!Quadrangle methodsFor: 'initialize-release'!
initialize
	"Initialize the region to a null Rectangle, the borderWidth to 1, the 
	borderColor to black, and the insideColor to white."

	origin _ 0 @ 0.
	corner _ 0 @ 0.
	borderWidth _ 1.
	borderColor _ Color black.
	insideColor _ Color white.
! !


!Quadrangle methodsFor: 'rectangle functions'!
intersect: aRectangle 
	"Answer a new Quadrangle whose region is the intersection of the 
	receiver's area and aRectangle.
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
	 	region: (super intersect: aRectangle)
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !


!Quadrangle methodsFor: 'transforming'!
align: aPoint1 with: aPoint2 
	"Answer a new Quadrangle translated by aPoint2 - aPoint1.
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
		region: (super translateBy: aPoint2 - aPoint1)
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !

!Quadrangle methodsFor: 'transforming'!
alignedTo: alignPointSelector
	"Return a copy with offset according to alignPointSelector which is one of...
	#(topLeft, topCenter, topRight, leftCenter, center, etc)
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
		region: (super translateBy: (0@0) - (self perform: alignPointSelector))
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !

!Quadrangle methodsFor: 'transforming'!
scaleBy: aPoint 
	"Answer a new Quadrangle scaled by aPoint.
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
		region: (super scaleBy: aPoint)
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !

!Quadrangle methodsFor: 'transforming'!
translateBy: aPoint 
	"Answer a new Quadrangle translated by aPoint.
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
		region: (super translateBy: aPoint)
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !


!Quadrangle methodsFor: '*eToys-vocabulary' stamp: 'sw 5/4/2001 16:45'!
vocabularyDemanded
	"Answer the vocabulary that the receiver really would like to use in a Viewer"

	^ Vocabulary quadVocabulary! !


!Quadrangle methodsFor: 'private'!
setRegion: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2

	origin _ aRectangle origin.
	corner _ aRectangle corner.
	borderWidth _ anInteger.
	borderColor _ aMask1.
	insideColor _ aMask2! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Quadrangle class
	instanceVariableNames: ''!

!Quadrangle class methodsFor: 'instance creation' stamp: 'sw 5/4/2001 17:12'!
exampleInViewer
	"Create a sample Quadrangle and open a Viewer on it"

	(self region: (100@100 extent: 100@50) borderWidth: (1 + (6 atRandom)) borderColor: Color black insideColor: (Color perform: #(green red blue yellow) atRandom)) beViewed

"Quadrangle exampleInViewer"! !

!Quadrangle class methodsFor: 'instance creation' stamp: 'fc 1/16/2005 21:20'!
origin: originPoint corner: cornerPoint 
	"Override Rectangles origin:corner: in order to get initialized.

	Answer an instance of me whose corners (top left and bottom right) are 
	determined by the arguments."

	^self new setOrigin: originPoint corner: cornerPoint! !

!Quadrangle class methodsFor: 'instance creation'!
region: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2
	"Answer an instance of me with rectangle, border width and color, and 
	inside color determined by the arguments."

	^super new
		setRegion: aRectangle
		borderWidth: anInteger
		borderColor: aMask1
		insideColor: aMask2! !
AbstractSound subclass: #QueueSound
	instanceVariableNames: 'startTime sounds currentSound done'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!QueueSound commentStamp: 'efc 1/2/2003 00:30' prior: 0!
I am a queue for sound - give me a bunch of sounds to play and I will play them one at a time in the order that they are received.

Example:
"Here is a simple example which plays two sounds three times."
| clink warble queue |
clink _ SampledSound soundNamed: 'clink'.
warble _ SampledSound soundNamed: 'warble'.
queue _ QueueSound new.
3 timesRepeat:[
	queue add: clink; add: warble
].
queue play.

Structure:
 startTime 		Integer -- if present, start playing when startTime <= Time millisecondClockValue
							(schedule the sound to play later)
 sounds			SharedQueue -- the synchronized list of sounds.
 currentSound	AbstractSound -- the currently active sound
 done			Boolean -- am I done playing ?

Other:
You may want to keep track of the queue's position so that you can feed it at an appropriate rate. To do this in an event driven way, modify or subclass nextSound to notify you when appropriate. You could also poll by checking currentSound, but this is not recommended for most applications.

!


!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 21:52'!
add: aSound
	self sounds nextPut: aSound.
	^ aSound! !

!QueueSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
currentSound
	currentSound isNil ifTrue: [currentSound := self nextSound].
	^ currentSound! !

!QueueSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
currentSound: aSound
	currentSound := aSound! !

!QueueSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
done: aBoolean
	done := aBoolean! !

!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 21:46'!
sounds
	^ sounds! !

!QueueSound methodsFor: 'accessing' stamp: 'len 9/26/1999 17:19'!
startTime
	^ startTime! !

!QueueSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
startTime: anInteger
	startTime := anInteger! !


!QueueSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	super initialize.
	sounds := SharedQueue new.
	done := false.
	startTime := Time millisecondClockValue! !


!QueueSound methodsFor: 'sound generation' stamp: 'len 8/29/1999 22:07'!
doControl
	super doControl.
	self currentSound notNil ifTrue: [self currentSound doControl]! !

!QueueSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a collection of sounds in sequence."

	| finalIndex i remaining count rate |
	self currentSound isNil ifTrue: [^ self].  "already done"
	self startTime > Time millisecondClockValue ifTrue: [^ self].
	rate := self samplingRate.
	finalIndex := (startIndex + n) - 1.
	i := startIndex.
	[i <= finalIndex] whileTrue: [
		[self currentSound isNil ifTrue: [^ self].
		(remaining := self currentSound samplesRemaining) <= 0]
			whileTrue: [self currentSound: self nextSound].
		count := (finalIndex - i) + 1.
		remaining < count ifTrue: [count := remaining].
		self currentSound mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol.
		i := i + count]! !

!QueueSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
nextSound
	| answer |
	sounds isEmpty ifTrue: [^ nil].
	answer := sounds next.
	answer reset.
	^ answer! !

!QueueSound methodsFor: 'sound generation' stamp: 'len 9/13/1999 00:26'!
reset
	super reset.
	self currentSound notNil
		ifTrue: [self currentSound reset]
		ifFalse: [self currentSound: self nextSound]! !

!QueueSound methodsFor: 'sound generation' stamp: 'len 8/29/1999 22:13'!
samplesRemaining
	(done and: [self sounds isEmpty])
		ifTrue: [^ 0]
		ifFalse: [^ 1000000].
! !
Array variableSubclass: #QuickIntegerDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!
!QuickIntegerDictionary commentStamp: 'dvf 8/4/2005 11:06' prior: 0!
This implementation serves as a very quick dictionary under the assumption that the keys are small natural numbers.!


!QuickIntegerDictionary methodsFor: 'accessing' stamp: 'apb 8/30/2003 18:33'!
includesKey: anIntegerKey
	^ (self at: anIntegerKey) notNil ! !

!QuickIntegerDictionary methodsFor: 'accessing' stamp: 'apb 8/30/2003 18:39'!
removeKey: anIntegerKey
	^ self at: anIntegerKey put: nil.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

QuickIntegerDictionary class
	instanceVariableNames: ''!
Array variableSubclass: #QuickStack
	instanceVariableNames: 'top'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!
!QuickStack commentStamp: 'apb 8/30/2003 10:55' prior: 0!
This class is a quick and dirty implementation of a stack, designed to be used in the
SendsInfo abstract interpreter.  As opposed to using an OrderedCollection, this stack is quick because it can be emptied in a single assignment, and dirty because elements above the logical top of the stack (i.e., those that have been popped off) are not nil'ed out.  For our application, these are important optimizations with no ill effects.

QuickStacks will expand beyond their initial size if required, but we intend that the initial size will always be sufficient, so the efficiency of this feature is not important.
!


!QuickStack methodsFor: 'accessing' stamp: 'apb 8/30/2003 18:09'!
addLast: aValue
	top = self basicSize ifTrue: [self grow].
	top _ top + 1.
	^ self at: top put: aValue! !

!QuickStack methodsFor: 'accessing' stamp: 'apb 9/7/2004 10:25'!
becomeEmpty
	top _ 0! !

!QuickStack methodsFor: 'accessing' stamp: 'apb 8/30/2003 11:36'!
isEmpty
	^ top = 0! !

!QuickStack methodsFor: 'accessing' stamp: 'apb 8/30/2003 11:43'!
removeLast
	| answer |
	answer _ self at: top.
	top _ top - 1.
	^ answer! !

!QuickStack methodsFor: 'accessing' stamp: 'apb 8/31/2003 21:42'!
removeLast: n

	top _ top - n! !

!QuickStack methodsFor: 'accessing' stamp: 'apb 8/30/2003 11:36'!
size
	^ top! !


!QuickStack methodsFor: 'copying' stamp: 'apb 9/7/2004 10:37'!
copy
	"Answer a copy of a myself"
	| newSize |
	newSize _ self basicSize.
	^ (self class new: newSize)
		replaceFrom: 1
		to: top
		with: self
		startingAt: 1;
		 setTop: top! !


!QuickStack methodsFor: 'initialization' stamp: 'apb 8/30/2003 11:34'!
initialize
	top _ 0! !


!QuickStack methodsFor: 'private' stamp: 'apb 8/30/2003 17:56'!
grow
	| newStack |
	newStack _ self class new: (self basicSize * 2).
	newStack replaceFrom: 1 to: top with: self startingAt: 1.
	newStack setTop: top.
	self becomeForward: newStack.
! !

!QuickStack methodsFor: 'private' stamp: 'apb 8/30/2003 11:55'!
setTop: t
	top _ t! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

QuickStack class
	instanceVariableNames: ''!

!QuickStack class methodsFor: 'instance creation' stamp: 'apb 8/30/2003 11:38'!
new
	^ (super new: 16) initialize
	"Why 16?  Because in performing an abstract interpretation of every
	method in every Class <= Object, the largest stack that was found 
	to be necessary was 15"! !
MimeConverter subclass: #QuotedPrintableMimeConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!QuotedPrintableMimeConverter commentStamp: '<historical>' prior: 0!
I do quoted printable MIME decoding as specified in RFC 2045 "MIME Part One: Format of Internet Message Bodies".

Short version of RFC2045, Sect. 6.7:

	(1) Any octet, except a CR or LF that is part of a CRLF line break of the canonical (standard) form of the data being encoded, may be represented by an "=" followed by a two digit hexadecimal representation of the octet's value. [...]

	(2) Octets with decimal values of 33 through 60 inclusive, and 62 through 126, inclusive, MAY be represented as the US-ASCII characters which correspond to those octets [...].

	(3) Octets with values of 9 and 32 MAY be represented as US-ASCII TAB (HT) and SPACE characters,
 respectively, but MUST NOT be so represented at the end of an encoded line.  [...]

	(4) A line break in a text body, represented as a CRLF sequence in the text canonical form, must be represented by a (RFC 822) line break, which is also a CRLF sequence, in the Quoted-Printable encoding.  [...]

	(5) The Quoted-Printable encoding REQUIRES that encoded lines be no more than 76 characters long.  If longer lines are to be encoded with the Quoted-Printable encoding, "soft" line breaks
 must be used.  An equal sign as the last character on a encoded line indicates such a non-significant ("soft") line break in the encoded text.


--bf 11/27/1998 16:50!


!QuotedPrintableMimeConverter methodsFor: 'conversion' stamp: 'bf 11/24/1998 20:33'!
mimeDecode
	"Do conversion reading from mimeStream writing to dataStream"

	| line s c1 v1 c2 v2 |
	[(line _ mimeStream nextLine) isNil] whileFalse: [
		line _ line withoutTrailingBlanks.
		line size = 0
			ifTrue: [dataStream cr]
			ifFalse: [
				s _ ReadStream on: line.
				[dataStream nextPutAll: (s upTo: $=).
				s atEnd] whileFalse: [
					c1 _ s next. v1 _ c1 digitValue.
					((v1 between: 0 and: 15) and: [s atEnd not])
						ifFalse: [dataStream nextPut: $=; nextPut: c1]
						ifTrue: [c2 _ s next. v2 _ c2 digitValue.
							(v2 between: 0 and: 15)
								ifFalse: [dataStream nextPut: $=; nextPut: c1; nextPut: c2]
								ifTrue: [dataStream nextPut: (Character value: v1 * 16 + v2)]]].
				line last = $= ifFalse: [dataStream cr]]].
	^ dataStream! !
QuotedPrintableMimeConverter subclass: #RFC2047MimeConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!RFC2047MimeConverter commentStamp: '<historical>' prior: 0!
I do quoted printable MIME decoding as specified in RFC 2047 ""MIME Part Three: Message Header Extensions for Non-ASCII Text". See String>>decodeMimeHeader!


!RFC2047MimeConverter methodsFor: 'conversion' stamp: 'bf 11/27/1998 17:04'!
mimeDecode
	"Do conversion reading from mimeStream writing to dataStream. See String>>decodeMimeHeader"

	| c |
	[mimeStream atEnd] whileFalse: [
		c _ mimeStream next.
		c = $=
			ifTrue: [c _ Character value: mimeStream next digitValue * 16
				+ mimeStream next digitValue]
			ifFalse: [c = $_ ifTrue: [c _ $ ]].
		dataStream nextPut: c].
	^ dataStream! !

!RFC2047MimeConverter methodsFor: 'conversion' stamp: 'bf 3/10/2000 16:06'!
mimeEncode
	"Do conversion reading from dataStream writing to mimeStream. Break long lines and escape non-7bit chars."

	| word pos wasGood isGood max |
	true ifTrue: [mimeStream nextPutAll: dataStream upToEnd].
	pos _ 0.
	max _ 72.
	wasGood _ true.
	[dataStream atEnd] whileFalse: [
		word _ self readWord.
		isGood _ word allSatisfy: [:c | c asciiValue < 128].
		wasGood & isGood ifTrue: [
			pos + word size < max
				ifTrue: [dataStream nextPutAll: word.
					pos _ pos + word size]
				ifFalse: []
		]
	].
	^ mimeStream! !


!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 23:16'!
encodeChar: aChar to: aStream

	aChar = Character space
		ifTrue: [^ aStream nextPut: $_].
	((aChar asciiValue between: 32 and: 127) and: [('?=_' includes: aChar) not])
		ifTrue: [^ aStream nextPut: aChar].
	aStream nextPut: $=;
		nextPut: (Character digitValue: aChar asciiValue // 16);
		nextPut: (Character digitValue: aChar asciiValue \\ 16)
! !

!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 23:13'!
encodeWord: aString

	(aString allSatisfy: [:c | c asciiValue < 128])
		ifTrue: [^ aString].
	^ String streamContents: [:stream |
		stream nextPutAll: '=?iso-8859-1?Q?'.
		aString do: [:c | self encodeChar: c to: stream].
		stream nextPutAll: '?=']! !

!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/12/2000 14:36'!
isStructuredField: aString

	| fName |
	fName _ aString copyUpTo: $:.
	('Resent' sameAs: (fName copyUpTo: $-))
		ifTrue: [fName _ fName copyFrom: 8 to: fName size].
	^#('Sender' 'From' 'Reply-To' 'To' 'cc' 'bcc') anySatisfy: [:each | fName sameAs: each]! !

!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 22:30'!
readWord

	| strm |
	strm _ WriteStream on: (String new: 20)
	dataStream skipSeparators.
	[dataStream atEnd] whileFalse: 
		[ | c |
		c _ dataStream next.
		strm nextPut: c.
		c isSeparator ifTrue: [^ strm contents]].
	^ strm contents! !
ReadWriteStream subclass: #RWBinaryOrTextStream
	instanceVariableNames: 'isBinary'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!RWBinaryOrTextStream commentStamp: '<historical>' prior: 0!
A simulation of a FileStream, but living totally in memory.  Hold the contents of a file or web page from the network.  Can then fileIn like a normal FileStream.

Need to be able to switch between binary and text, as a FileStream does, without recopying the whole collection.  Convert to binary upon input and output.  Always keep as text internally.!


!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 2/4/2000 09:15'!
asBinaryOrTextStream

	^ self! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/25/97 13:22'!
ascii
	isBinary _ false! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:46'!
binary
	isBinary _ true! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/21/97 12:49'!
contents
	"Answer with a copy of my collection from 1 to readLimit."

	| newArray |
	isBinary ifFalse: [^ super contents].	"String"
	readLimit _ readLimit max: position.
	newArray _ ByteArray new: readLimit.
	^ newArray replaceFrom: 1
		to: readLimit
		with: collection
		startingAt: 1.! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'jm 11/4/97 08:25'!
contentsOfEntireFile
	"For compatibility with file streams."

	^ self contents! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:47'!
isBinary
	^ isBinary! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 12/13/97 13:07'!
next

	| byte |
	^ isBinary 
			ifTrue: [byte _ super next.
				 byte ifNil: [nil] ifNotNil: [byte asciiValue]]
			ifFalse: [super next].
! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 19:26'!
next: anInteger 
	"Answer the next anInteger elements of my collection. Must override to get class right."

	| newArray |
	newArray _ (isBinary ifTrue: [ByteArray] ifFalse: [ByteString]) new: anInteger.
	^ self nextInto: newArray! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'ls 3/27/2000 22:24'!
next: n into: aCollection startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than n elements have been read."
	"Overriden for efficiency"
	| max |
	max _ (readLimit - position) min: n.
	aCollection 
		replaceFrom: startIndex 
		to: startIndex+max-1
		with: collection
		startingAt: position+1.
	position _ position + max.
	max = n
		ifTrue:[^aCollection]
		ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 07:38'!
nextPut: charOrByte

	super nextPut: charOrByte asCharacter! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 1/14/1999 20:16'!
padToEndWith: aChar
	"We don't have pages, so we are at the end, and don't need to pad."! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/21/97 13:04'!
reset
	"Set the receiver's position to the beginning of the sequence of objects."

	super reset.
	isBinary ifNil: [isBinary _ false].
	collection class == ByteArray ifTrue: ["Store as String and convert as needed."
		collection _ collection asString.
		isBinary _ true].
! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 10/1/1998 11:54'!
setFileTypeToObject
	"do nothing.  We don't have a file type"! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:47'!
text
	isBinary _ false! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 19:27'!
upToEnd
	"Must override to get class right."
	| newArray |
	newArray _ (isBinary ifTrue: [ByteArray] ifFalse: [ByteString]) new: self size - self position.
	^ self nextInto: newArray! !


!RWBinaryOrTextStream methodsFor: 'writing' stamp: 'ar 8/12/2003 16:54'!
next: anInteger putAll: aCollection startingAt: startIndex
	^super next: anInteger putAll: aCollection asString startingAt: startIndex! !

!RWBinaryOrTextStream methodsFor: 'writing' stamp: 'ar 8/12/2003 16:54'!
nextPutAll: aCollection
	^super nextPutAll: aCollection asString! !
SimpleBorder subclass: #RaisedBorder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Borders'!
!RaisedBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0!
see BorderedMorph!


!RaisedBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:34'!
bottomRightColor
	^width = 1 
		ifTrue: [color twiceDarker]
		ifFalse: [color darker]! !

!RaisedBorder methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:23'!
colorsAtCorners
	| c c14 c23 |
	c _ self color.
	c14 _ c lighter. c23 _ c darker.
	^Array with: c14 with: c23 with: c23 with: c14! !

!RaisedBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'!
style
	^#raised! !

!RaisedBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:34'!
topLeftColor
	^width = 1 
		ifTrue: [color twiceLighter]
		ifFalse: [color lighter]! !


!RaisedBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'!
trackColorFrom: aMorph
	baseColor ifNil:[self color: aMorph raisedColor].! !
Object subclass: #Random
	instanceVariableNames: 'seed a m q r'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Random commentStamp: 'md 4/26/2003 16:32' prior: 0!
This Random Number Generator graciously contributed by David N. Smith.  It is an adaptation of the Park-Miller RNG which uses Floats to avoid the need for LargeInteger arithmetic.

If you just want a quick random integer, use:
		10 atRandom
Every integer interval can give a random number:
		(6 to: 12) atRandom
SequenceableCollections can give randomly selected elements:
		'pick one of these letters randomly' atRandom
SequenceableCollections also respond to shuffled, as in:
		($A to: $Z) shuffled

The correct way to use class Random is to store one in an instance or class variable:
		myGenerator _ Random new.
Then use it every time you need another number between 0.0 and 1.0 (excluding)
		myGenerator next
You can also generate a positive integer
		myGenerator nextInt: 10!


!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:25'!
next
	"Answer a random Float in the interval [0 to 1)."

	^ (seed _ self nextValue) / m! !

!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:45'!
next: anInteger
	^ self next: anInteger into: (Array new: anInteger)! !

!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:46'!
next: anInteger into: anArray
	1 to: anInteger do: [:index | anArray at: index put: self next].
	^ anArray! !

!Random methodsFor: 'accessing' stamp: 'dns 8/26/2001 18:43'!
nextInt: anInteger
	"Answer a random integer in the interval [1, anInteger]."

	anInteger strictlyPositive ifFalse: [ self error: 'Range must be positive' ].
	^ (self next * anInteger) truncated + 1! !


!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:42'!
check: nDice
	"Roll some dice, WoD-style."

	^ self check: nDice difficulty: 6! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:47'!
check: nAttack against: nDefend
	"Roll some dice, WoD-style."

	^ self check: nAttack against: nDefend difficulty: 6! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:46'!
check: nAttack against: nDefend difficulty: diff
	"Roll some dice, WoD-style."

	| attacks defends |
	attacks _ self check: nAttack difficulty: diff.
	attacks < 0 ifTrue: [^ attacks].
	defends _ self check: nDefend difficulty: diff.
	^ attacks - defends min: 0! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:42'!
check: nDice difficulty: diff
	"Roll some dice, WoD-style."

	| result die |
	result _ 0.
	nDice timesRepeat: 
		[(die _ self nextInt: 10) = 1
			ifTrue: [result _ result - 1]
			ifFalse: [die >= diff ifTrue: [result _ result + 1]]].
	^ result! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:48'!
diceToken: stream
	"Private. Mini scanner, see #roll:"

	stream atEnd ifTrue: [^ nil].
	stream peek isDigit ifTrue: [^ Number readFrom: stream].
	^ stream next asLowercase! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:37'!
roll: diceString
	"Roll some dice, DnD-style, according to this mini-grammar:
		dice _ epxr {pm expr}
		pm _ '+' | '-'
		expr _ num | num dD | dD numP | num dD numP
		dD _ 'd' | 'D'
		num _ digit+
		numP _ num | '%'"

	| stream op result dice range res token |
	stream _ diceString readStream.
	result _ 0.
	op _ #+.
	[token _ self diceToken: stream.
	token isNumber
		ifTrue: [dice _ token.
				token _ self diceToken: stream]
		ifFalse: [token == $d
			ifTrue: [dice _ 1]
			ifFalse: [res _ 0]].
	token == $d
		ifTrue: [token _ self diceToken: stream.
				token isNumber
					ifTrue: [range _ token.
							token _ self diceToken: stream]
					ifFalse: [token == $%
						ifTrue: [range _ 100.
								token _ self diceToken: stream]
						ifFalse: [range _ 6]].
				res _ 0.
				dice timesRepeat: [res _ res + (self nextInt: range)]].
	result _ result perform: op with: res.
	token ifNil: [^ result].
	(token == $+ or: [token == $-])
		ifFalse: [self error: 'unknown token ' , token].
	op _ token asSymbol] repeat! !


!Random methodsFor: 'initialization' stamp: 'di 8/6/1999 15:32'!
initialize
	" Set a reasonable Park-Miller starting seed "
	[seed := (Time millisecondClockValue bitAnd: 16r3FFFFFFF) bitXor: self hash.
	seed = 0] whileTrue: ["Try again if ever get a seed = 0"].

	a := 16r000041A7 asFloat.    " magic constant =      16807 "
	m := 16r7FFFFFFF asFloat.    " magic constant = 2147483647 "
	q := (m quo: a) asFloat.
	r  := (m \\ a) asFloat.
! !

!Random methodsFor: 'initialization' stamp: 'sma 5/12/2000 12:29'!
seed: anInteger 
	seed _ anInteger! !


!Random methodsFor: 'private' stamp: 'sma 5/12/2000 12:28'!
nextValue
	"This method generates random instances of Integer 	in the interval
	0 to 16r7FFFFFFF. This method does NOT update the seed; repeated sends
	answer the same value.
	The algorithm is described in detail in 'Random Number Generators: 
	Good Ones Are Hard to Find' by Stephen K. Park and Keith W. Miller 
	(Comm. Asso. Comp. Mach., 31(10):1192--1201, 1988)."

	| lo hi aLoRHi answer |
	hi _ (seed quo: q) asFloat.
	lo _ seed - (hi * q).  " = seed rem: q"  
	aLoRHi _ (a * lo) - (r * hi).
	answer _ (aLoRHi > 0.0)
		ifTrue:  [aLoRHi]
		ifFalse: [aLoRHi + m].
	^ answer! !

!Random methodsFor: 'private' stamp: 'sma 5/12/2000 12:43'!
seed
	^ seed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Random class
	instanceVariableNames: ''!

!Random class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'!
seed: anInteger 
	^self new seed: anInteger! !


!Random class methodsFor: 'testing'!
bucketTest: randy
	"Execute this:   Random bucketTest: Random new"
	" A quick-and-dirty bucket test. Prints nbuckets values on the
Transcript.
	  Each should be 'near' the value of ntries. Any run with any value
'far' from ntries
	  indicates something is very wrong. Each run generates different
values.
	  For a slightly better test, try values of nbuckets of 200-1000 or
more; go get coffee.
	  This is a poor test; see Knuth.   Some 'OK' runs:
		1000 1023 998 969 997 1018 1030 1019 1054 985 1003
		1011 987 982 980 982 974 968 1044 976
		1029 1011 1025 1016 997 1019 991 954 968 999 991
		978 1035 995 988 1038 1009 988 993 976
"
	| nbuckets buckets ntrys slot |
	nbuckets := 20.
	buckets := Array new: nbuckets.
	buckets atAllPut: 0.
	ntrys :=  100.
	ntrys*nbuckets timesRepeat: [
		slot := (randy next * nbuckets) floor + 1.
		buckets at: slot put: (buckets at: slot) + 1 ].
	Transcript cr.
	1 to: nbuckets do: [ :nb |
		Transcript show: (buckets at: nb) printString, ' ' ]! !

!Random class methodsFor: 'testing'!
theItsCompletelyBrokenTest
	"Random theItsCompletelyBrokenTest"
	"The above should print as...
	(0.149243269650845 0.331633021743797 0.75619644800024 0.393701540023881 0.941783181364547 0.549929193942775 0.659962596213428 0.991354559078512 0.696074432551896 0.922987899707159 )
	If they are not these values (accounting for precision of printing) then something is horribly wrong: DO NOT USE THIS CODE FOR ANYTHING. "
	| rng |
	rng := Random new.
	rng seed: 2345678901.
	^ (1 to: 10) collect: [:i | rng next]! !
Envelope subclass: #RandomEnvelope
	instanceVariableNames: 'rand lowLimit highLimit delta'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:18'!
centerPitch: aNumber
	"If this envelope controls pitch, set its scale to the given number. Otherwise, do nothing."

	updateSelector = #pitch: ifTrue: [self scale: aNumber].
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'!
delta

	^ delta
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
delta: aNumber

	delta := aNumber.
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'!
highLimit

	^ highLimit
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
highLimit: aNumber

	highLimit := aNumber.
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:05'!
lowLimit

	^ lowLimit
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
lowLimit: aNumber

	lowLimit := aNumber.
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:17'!
volume: aNumber
	"If this envelope controls volume, set its scale to the given number. Otherwise, do nothing."

	updateSelector = #volume: ifTrue: [self scale: aNumber].
! !


!RandomEnvelope methodsFor: 'applying' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateTargetAt: mSecs
	"Send my updateSelector to the given target object with the value of this envelope at the given number of milliseconds from its onset. Answer true if the value changed."

	| r |
	r := rand next.
	r > 0.5
		ifTrue: [
			currValue := currValue + delta.
			currValue > highLimit ifTrue: [currValue := highLimit]]
		ifFalse: [
			currValue := currValue - delta.
			currValue < lowLimit ifTrue: [currValue := lowLimit]].
	currValue = lastValue ifTrue: [^ false].
	((target == nil) or: [updateSelector == nil]) ifTrue: [^ false].
	target
		perform: updateSelector
		with: scale * currValue.
	lastValue := currValue.
	^ true
! !


!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:29'!
duration

	^ 1.0
! !

!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:25'!
duration: seconds
	"Do nothing."
! !

!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 1/14/1999 13:17'!
name

	^ 'random ', updateSelector
! !

!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:30'!
sustainEnd: seconds
	"Do nothing."
! !


!RandomEnvelope methodsFor: 'envelopeEditor compatibility' stamp: 'stephaneducasse 2/4/2006 20:41'!
points

	| env |
	points isNil ifTrue: [
		env := self target envelopes first.
		points := OrderedCollection new.
		points
			add: 0@(self delta * 5 + 0.5);
			add: (env points at: env loopStartIndex)x@(self highLimit -1 * 5 + 0.5);
			add: (env points at: env loopEndIndex)x@(self highLimit -1 * 5 + 0.5);
			add: (env points last)x@(self lowLimit -1 * 5 + 0.5).
		loopStartIndex := 2.
		loopEndIndex := 3.
	].
	^points! !

!RandomEnvelope methodsFor: 'envelopeEditor compatibility' stamp: 'JMV 1/9/2001 13:08'!
setPoints: pointList loopStart: startIndex loopEnd: endIndex

	self delta: pointList first y - 0.5 / 5.
	self highLimit: (pointList at: startIndex) y - 0.5 / 5 + 1.
	self lowLimit: pointList last y - 0.5 / 5 + 1.
	^super setPoints: pointList loopStart: startIndex loopEnd: endIndex! !


!RandomEnvelope methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	rand := Random new.
	lowLimit := 0.994.
	highLimit := 1.006.
	delta := 0.0002.
	currValue := 1.0.
	scale := 1.0.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RandomEnvelope class
	instanceVariableNames: ''!

!RandomEnvelope class methodsFor: 'instance creation' stamp: 'jm 8/13/1998 18:21'!
for: aSelector
	"Answer a random envelope for the given selector."

	^ self new updateSelector: aSelector
! !
TileMorph subclass: #RandomNumberTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!RandomNumberTile methodsFor: 'accessing' stamp: 'sw 3/24/2000 00:43'!
labelMorph
	^ submorphs detect: [:m | m isKindOf: UpdatingStringMorph] ifNone: [nil].! !

!RandomNumberTile methodsFor: 'accessing' stamp: 'yo 9/16/2004 18:50'!
storeCodeOn: aStream indent: tabCount

	| phrase player costume |
	phrase _ self outermostMorphThat: [:m| m isKindOf: PhraseTileMorph].
	phrase ifNil: [^ self basicStoreCodeOn: aStream indent: tabCount].

	player _ phrase associatedPlayer.
	player ifNil: [^ self basicStoreCodeOn: aStream indent: tabCount].

	costume _ player costume.
	costume ifNil: [^ self basicStoreCodeOn: aStream indent: tabCount].

	(player isKindOf: KedamaExamplerPlayer) ifTrue: [
		^ self kedamaStoreCodeOn: aStream indent: tabCount actualObject: player costume renderedMorph kedamaWorld].

	(costume renderedMorph isMemberOf: KedamaMorph) ifTrue: [
		^ self kedamaStoreCodeOn: aStream indent: tabCount actualObject: costume renderedMorph].

	^ self basicStoreCodeOn: aStream indent: tabCount.! !


!RandomNumberTile methodsFor: 'code generation' stamp: 'yo 9/3/2004 00:45'!
basicStoreCodeOn: aStream indent: tabCount
	aStream
			nextPut: $(;
			nextPutAll: literal printString;
			nextPutAll: ' atRandom)'.! !

!RandomNumberTile methodsFor: 'code generation' stamp: 'yo 9/3/2004 00:54'!
kedamaStoreCodeOn: aStream indent: tabCount actualObject: obj
	aStream
			nextPut: $(;
			nextPutAll: obj uniqueNameForReference;
			nextPutAll: ' random: ';
			nextPutAll: literal printString;
			nextPut: $).
! !


!RandomNumberTile methodsFor: 'event handling' stamp: 'RAA 7/31/2001 12:02'!
handlesMouseDown: evt

	| aPoint |

	self inPartsBin ifTrue: [^false].
	aPoint _ evt cursorPoint.

	"This might actually be a suitable test for the superclass, but I'll do it here to minimize the downside"

	{upArrow. downArrow. suffixArrow. retractArrow} do: [ :each |
		(each notNil and: [each bounds containsPoint: aPoint]) ifTrue: [
			^true
		]
	].

	^false		"super handlesMouseDown: evt"! !


!RandomNumberTile methodsFor: 'initialization' stamp: 'dgd 9/20/2003 19:11'!
initialize
	"Initialize the receiver fully, including adding all its relevant submorphs"

	| m1 m2 |
	super initialize.
	self vResizing: #shrinkWrap.
	self typeColor: (ScriptingSystem colorForType: #Number).
	self addArrows.
	m1 _ StringMorph contents: 'random' translated font: ScriptingSystem fontForTiles.
	self addMorph: m1.
	m2 _ UpdatingStringMorph contents: '180' font: ScriptingSystem fontForTiles.
	m2 target: self; getSelector: #literal; putSelector: #literal:.
	m2 position: m1 topRight.
	self addMorphBack: m2.
	literal _ 180.
	self updateLiteralLabel.
	self makeAllTilesGreen! !

!RandomNumberTile methodsFor: 'initialization' stamp: 'yo 7/2/2004 20:59'!
updateWordingToMatchVocabulary

	| stringMorph |
	stringMorph _ submorphs
				detect: [:morph | morph class == StringMorph]
				ifNone: [^ self].
	stringMorph contents: 'random' translated.

! !


!RandomNumberTile methodsFor: 'misc' stamp: 'sw 6/25/1998 17:44'!
numericValue
	^ super numericValue atRandom! !


!RandomNumberTile methodsFor: 'player viewer' stamp: 'tk 8/14/2000 23:23'!
updateLiteralLabel
	| myReadout |
	(myReadout _ self labelMorph) ifNil: [^ self].
	myReadout contents: literal stringForReadout.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RandomNumberTile class
	instanceVariableNames: ''!

!RandomNumberTile class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:50'!
initialize

	self registerInFlapsRegistry.	! !

!RandomNumberTile class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:51'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(RandomNumberTile		new		'Random'		'A random-number tile for use with tile scripting')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(RandomNumberTile	new	'Random'		'A tile that will produce a random number in a given range')
						forFlapNamed: 'Scripting'.]! !

!RandomNumberTile class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:39'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !
ClassTestCase subclass: #RandomTest
	instanceVariableNames: 'gen'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!

!RandomTest methodsFor: 'setup' stamp: 'md 4/2/2003 12:32'!
setUp
	gen := Random seed: 112629.! !


!RandomTest methodsFor: 'tests' stamp: 'md 4/2/2003 12:50'!
testNext

	10000 timesRepeat: [
			| next | 
			next := gen next.
			self assert: (next >= 0).
			self assert: (next < 1).
	].! !
Object subclass: #RcsDiff
	instanceVariableNames: 'commandLines'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-utilities'!

!RcsDiff methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
commandLines: aString
	commandLines := aString! !


!RcsDiff methodsFor: 'applying' stamp: 'stephaneducasse 2/4/2006 20:38'!
applyTo: aString
	"Apply me to given String and return the patched String."

	| space commandStream originalStream nextCommand nextLine lineCount currentLine |
	space := Character space.
	commandStream := ReadStream on: commandLines.
	originalStream := ReadStream on: aString.
	currentLine := 1.
	^String streamContents: [:stream |
		[nextCommand := commandStream next.
		nextCommand isNil] whileFalse: [ 
			nextLine := (commandStream upTo: space) asNumber.
			lineCount := commandStream nextLine asNumber.
			[currentLine = nextLine]
				whileFalse: [stream nextPutAll: originalStream nextLine; cr. currentLine := currentLine + 1].
			nextCommand = $d
				ifTrue:[ lineCount timesRepeat: [originalStream nextLine. currentLine := currentLine + 1]]
				ifFalse:[ nextCommand = $a
							ifTrue:[ stream nextPutAll: originalStream nextLine; cr.
									currentLine := currentLine + 1.
									lineCount timesRepeat: [
										stream nextPutAll: commandStream nextLine; cr]]]].
		stream nextPutAll: originalStream upToEnd]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RcsDiff class
	instanceVariableNames: ''!

!RcsDiff class methodsFor: 'instance creation' stamp: 'gh 11/22/2001 23:44'!
lines: aString
	"Create a new RcsDiff file."
	^(self new) commandLines: aString; yourself! !
PluggableTextController subclass: #ReadOnlyTextController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!ReadOnlyTextController methodsFor: 'as yet unclassified' stamp: 'di 5/7/1998 13:41'!
accept 
	"Overridden to allow accept of clean text"
	(view setText: paragraph text from: self) ifTrue:
		[initialText _ paragraph text copy.
		view ifNotNil: [view hasUnacceptedEdits: false]].
! !

!ReadOnlyTextController methodsFor: 'as yet unclassified' stamp: 'di 5/7/1998 14:02'!
userHasEdited
	"Ignore this -- I stay clean"! !

!ReadOnlyTextController methodsFor: 'as yet unclassified' stamp: 'di 5/7/1998 13:45'!
zapSelectionWith: aText
	view flash  "no edits allowed"! !
LookupKey subclass: #ReadOnlyVariableBinding
	instanceVariableNames: 'value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!

!ReadOnlyVariableBinding methodsFor: 'accessing' stamp: 'ajh 9/12/2002 12:06'!
canAssign

	^ false! !

!ReadOnlyVariableBinding methodsFor: 'accessing' stamp: 'ar 8/14/2001 23:09'!
value
	^value! !

!ReadOnlyVariableBinding methodsFor: 'accessing' stamp: 'ar 8/17/2001 18:03'!
value: aValue
	(AttemptToWriteReadOnlyGlobal signal: 'Cannot store into read-only bindings') == true ifTrue:[
		value _ aValue.
	].! !


!ReadOnlyVariableBinding methodsFor: 'testing' stamp: 'ar 8/14/2001 23:08'!
isSpecialWriteBinding
	"Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages"
	^true! !


!ReadOnlyVariableBinding methodsFor: 'private' stamp: 'ar 8/14/2001 23:11'!
privateSetKey: aKey value: aValue
	key _ aKey.
	value _ aValue! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ReadOnlyVariableBinding class
	instanceVariableNames: ''!

!ReadOnlyVariableBinding class methodsFor: 'instance creation' stamp: 'ar 8/14/2001 23:11'!
key: key value: aValue
	^self new privateSetKey: key value: aValue! !
PositionableStream subclass: #ReadStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!ReadStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects that can only read objects from the sequence.!


!ReadStream methodsFor: 'accessing'!
ascii! !

!ReadStream methodsFor: 'accessing'!
binary! !

!ReadStream methodsFor: 'accessing'!
next
	"Primitive. Answer the next object in the Stream represented by the
	receiver. Fail if the collection of this stream is not an Array or a String.
	Fail if the stream is positioned at its end, or if the position is out of
	bounds in the collection. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 65>
	position >= readLimit
		ifTrue: [^nil]
		ifFalse: [^collection at: (position _ position + 1)]! !

!ReadStream methodsFor: 'accessing' stamp: 'ls 8/16/1998 00:46'!
next: anInteger 
	"Answer the next anInteger elements of my collection.  overriden for efficiency"

	| ans endPosition |

	endPosition _ position + anInteger  min:  readLimit.
	ans _ collection copyFrom: position+1 to: endPosition.
	position _ endPosition.
	^ans
! !

!ReadStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:01'!
next: n into: aCollection startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than
	n elements have been read."
	| max |
	max _ (readLimit - position) min: n.
	aCollection 
		replaceFrom: startIndex 
		to: startIndex+max-1
		with: collection
		startingAt: position+1.
	position _ position + max.
	max = n
		ifTrue:[^aCollection]
		ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]! !

!ReadStream methodsFor: 'accessing'!
nextPut: anObject

	self shouldNotImplement! !

!ReadStream methodsFor: 'accessing' stamp: 'ajh 9/5/2002 22:11'!
readStream
	"polymorphic with SequenceableCollection.  Return self"

	^ self! !

!ReadStream methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:20'!
size
	"Compatibility with other streams (e.g., FileStream)"
	^readLimit! !

!ReadStream methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:59'!
upTo: anObject
	"fast version using indexOf:"
	| start end |

	start _ position+1.
	end _ collection indexOf: anObject startingAt: start ifAbsent: [ 0 ].

	"not present--return rest of the collection"	
	end = 0 ifTrue: [ ^self upToEnd ].

	"skip to the end and return the data passed over"
	position _ end.
	^collection copyFrom: start to: (end-1)! !

!ReadStream methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:59'!
upToEnd
	| start |

	start _ position+1.
	position _ collection size.
	^collection copyFrom: start to: position! !


!ReadStream methodsFor: 'file stream compatibility' stamp: 'nk 12/13/2002 12:00'!
localName
	^'ReadStream'! !

!ReadStream methodsFor: 'file stream compatibility' stamp: 'nk 12/13/2002 12:01'!
openReadOnly! !

!ReadStream methodsFor: 'file stream compatibility' stamp: 'nk 12/13/2002 12:00'!
readOnly! !


!ReadStream methodsFor: '*packageinfo-base' stamp: 'ab 5/24/2003 14:28'!
untilEnd: aBlock displayingProgress: aString
	aString
		displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
			[:bar |
			[self atEnd] whileFalse:
				[bar value: self position.
				aBlock value]].! !


!ReadStream methodsFor: 'private'!
on: aCollection from: firstIndex to: lastIndex

	| len |
	collection _ aCollection.
	readLimit _  lastIndex > (len _ collection size)
						ifTrue: [len]
						ifFalse: [lastIndex].
	position _ firstIndex <= 1
				ifTrue: [0]
				ifFalse: [firstIndex - 1]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ReadStream class
	instanceVariableNames: ''!

!ReadStream class methodsFor: 'instance creation'!
on: aCollection from: firstIndex to: lastIndex 
	"Answer with a new instance streaming over a copy of aCollection from
	firstIndex to lastIndex."

	^self basicNew
		on: aCollection
		from: firstIndex
		to: lastIndex! !
TestCase subclass: #ReadStreamTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Streams'!
!ReadStreamTest commentStamp: 'tlk 12/5/2004 14:36' prior: 0!
I am an SUnit test for ReadStream.
I have no test fixtures.!


!ReadStreamTest methodsFor: 'tests' stamp: 'bp 10/29/2004 05:57'!
streamOn: collection upToAll: subcollection

	^(ReadStream on: collection) upToAll: subcollection! !

!ReadStreamTest methodsFor: 'tests' stamp: 'bp 10/29/2004 06:01'!
streamOn: collection upToAll: subcollection1 upToAll: subcollection2

	^(ReadStream on: collection)
		upToAll: subcollection1;
		upToAll: subcollection2! !

!ReadStreamTest methodsFor: 'tests' stamp: 'tlk 12/5/2004 14:34'!
testPositionOfSubCollection
	
	self assert: ('xyz' readStream positionOfSubCollection: 'q' ) = 0.
	self assert: ('xyz' readStream positionOfSubCollection: 'x' ) = 1.

	self assert: ('xyz' readStream positionOfSubCollection: 'y' ) = 2.
	self assert: ('xyz' readStream positionOfSubCollection: 'z' ) = 3.! !

!ReadStreamTest methodsFor: 'tests' stamp: 'bp 10/29/2004 06:16'!
testUpToAll

	self assert: (self streamOn: 'abcdefgh' upToAll: 'cd') = 'ab'.
	self assert: (self streamOn: 'abcdefgh' upToAll: 'cd' upToAll: 'gh') = 'ef'.

	self assert: (self streamOn: '' upToAll: '') = ''.

	self assert: (self streamOn: 'a' upToAll: '') = ''.
	self assert: (self streamOn: 'a' upToAll: 'a') = ''.
	self assert: (self streamOn: 'a' upToAll: 'b') = 'a'.

	self assert: (self streamOn: 'ab' upToAll: '') = ''.
	self assert: (self streamOn: 'ab' upToAll: 'a') = ''.
	self assert: (self streamOn: 'ab' upToAll: 'b') = 'a'.
	self assert: (self streamOn: 'ab' upToAll: 'c') = 'ab'.
	self assert: (self streamOn: 'ab' upToAll: 'ab') = ''.

	self assert: (self streamOn: 'abc' upToAll: '') = ''.
	self assert: (self streamOn: 'abc' upToAll: 'a') = ''.
	self assert: (self streamOn: 'abc' upToAll: 'b') = 'a'.
	self assert: (self streamOn: 'abc' upToAll: 'c') = 'ab'.
	self assert: (self streamOn: 'abc' upToAll: 'd') = 'abc'.
	self assert: (self streamOn: 'abc' upToAll: 'ab') = ''.
	self assert: (self streamOn: 'abc' upToAll: 'bc') = 'a'.
	self assert: (self streamOn: 'abc' upToAll: 'cd') = 'abc'.
! !
WriteStream subclass: #ReadWriteStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!ReadWriteStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects. My instances can both read and store objects.!


!ReadWriteStream methodsFor: 'accessing'!
contents
	"Answer with a copy of my collection from 1 to readLimit."

	readLimit _ readLimit max: position.
	^collection copyFrom: 1 to: readLimit! !

!ReadWriteStream methodsFor: 'accessing'!
name
	^ 'a stream'   "for fileIn compatibility"! !

!ReadWriteStream methodsFor: 'accessing'!
next
	"Primitive. Return the next object in the Stream represented by the
	receiver. Fail if the collection of this stream is not an Array or a String.
	Fail if the stream is positioned at its end, or if the position is out of
	bounds in the collection. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 65>
	"treat me as a FIFO"
	position >= readLimit
		ifTrue: [^nil]
		ifFalse: [^collection at: (position _ position + 1)]! !

!ReadWriteStream methodsFor: 'accessing' stamp: 'ar 8/5/2003 02:23'!
next: anInteger 
	"Answer the next anInteger elements of my collection.  overriden for efficiency"

	| ans endPosition |
	readLimit := readLimit max: position.

	endPosition _ position + anInteger  min:  readLimit.
	ans _ collection copyFrom: position+1 to: endPosition.
	position _ endPosition.
	^ans
! !


!ReadWriteStream methodsFor: 'converting' stamp: 'yo 7/16/2003 14:59'!
asUnZippedStream
	| isGZip outputStream first strm archive which |
	"Decompress this file if needed, and return a stream.  No file is written.  File extension may be .gz or anything else.  Also works on archives (.zip, .gZip)."

	strm _ self binary.
	strm isZipArchive ifTrue: [
		archive _ ZipArchive new readFrom: strm.
		which _ archive members detect: [:any | any fileName asLowercase endsWith: '.ttf'] 
								ifNone: [nil].
		which ifNil: [archive close.
					^ self error: 'Can''t find .ttf file in archive'].
		strm _ which contentStream.
		archive close].

	first _ strm next.
	isGZip _ (strm next * 256 + first) = (GZipConstants gzipMagic).
	strm skip: -2.
	isGZip 
		ifTrue: [outputStream _ (MultiByteBinaryOrTextStream with:
									(GZipReadStream on: strm) upToEnd) reset.
				strm close]
		ifFalse: [outputStream _ strm].
	^ outputStream! !

!ReadWriteStream methodsFor: 'converting' stamp: 'ajh 9/14/2002 20:37'!
readStream
	"polymorphic with SequenceableCollection.  Return self"

	^ self! !


!ReadWriteStream methodsFor: 'file status'!
close
	"Presumably sets the status of the receiver to be closed. This message does 
	nothing at this level, but is included for FileStream compatibility."

	^self! !

!ReadWriteStream methodsFor: 'file status'!
closed
	"If you have close (for FileStream compatibility), you must respond to closed.  The result in nonsense here.  TK 29 May 96"

	^ false! !


!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'di 7/17/97 16:12'!
fileInObjectAndCode
	"This file may contain:
1) a fileIn of code  
2) just an object in SmartReferenceStream format 
3) both code and an object.
	File it in and return the object.  Note that self must be a FileStream or RWBinaryOrTextStream.  Maybe ReadWriteStream incorporate RWBinaryOrTextStream?"
	| refStream object |
	self text.
	self peek asciiValue = 4
		ifTrue: [  "pure object file"
			refStream _ SmartRefStream on: self.
			object _ refStream nextAndClose]
		ifFalse: [  "objects mixed with a fileIn"
			self fileIn.  "reads code and objects, then closes the file"
			object _ SmartRefStream scannedObject].	"set by side effect of one of the chunks"
	SmartRefStream scannedObject: nil.  "clear scannedObject"
	^ object! !

!ReadWriteStream methodsFor: 'fileIn/Out'!
fileNameEndsWith: aString
	"See comment in FileStream fileNameEndsWith:"

	^false! !

!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'RAA 4/6/2001 18:32'!
fileOutChangeSet: aChangeSetOrNil andObject: theObject
	"Write a file that has both the source code for the named class and an object as bits.  Any instance-specific object will get its class written automatically."

	"An experimental version to fileout a changeSet first so that a project can contain its own classes"


	self setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	self header; timeStamp.

	aChangeSetOrNil ifNotNil: [
		aChangeSetOrNil fileOutPreambleOn: self.
		aChangeSetOrNil fileOutOn: self.
		aChangeSetOrNil fileOutPostscriptOn: self.
	].
	self trailer.	"Does nothing for normal files.  HTML streams will have trouble with object data"

	"Append the object's raw data"
	(SmartRefStream on: self)
		nextPut: theObject;  "and all subobjects"
		close.		"also closes me"
! !

!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:41'!
fileOutChanges
	"Append to the receiver a description of all class changes."
	Cursor write showWhile:
		[self header; timeStamp.
		ChangeSet current fileOutOn: self.
		self trailer; close]! !

!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'yo 8/16/2004 13:45'!
fileOutClass: extraClass andObject: theObject
	"Write a file that has both the source code for the named class and an object as bits.  Any instance-specific object will get its class written automatically."

	| class srefStream |
	self setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	self text.
	self header; timeStamp.

	extraClass ifNotNil: [
		class _ extraClass.	"A specific class the user wants written"
		class sharedPools size > 0 ifTrue:
			[class shouldFileOutPools
				ifTrue: [class fileOutSharedPoolsOn: self]].
		class fileOutOn: self moveSource: false toFile: 0].
	self trailer.	"Does nothing for normal files.  HTML streams will have trouble with object data"
	self binary.

	"Append the object's raw data"
	srefStream _ SmartRefStream on: self.
	srefStream nextPut: theObject.  "and all subobjects"
	srefStream close.		"also closes me"
! !

!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'tk 3/13/98 22:25'!
fileOutClass: extraClass andObject: theObject blocking: anIdentDict
	"Write a file that has both the source code for the named class and an object as bits.  Any instance-specific object will get its class written automatically.  Accept a list of objects to map to nil or some other object (blockers).  In addition to teh choices in each class's objectToStoreOnDataStream"

	| class srefStream |
	self setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	self header; timeStamp.

	extraClass ifNotNil: [
		class _ extraClass.	"A specific class the user wants written"
		class sharedPools size > 0 ifTrue:
			[class shouldFileOutPools
				ifTrue: [class fileOutSharedPoolsOn: self]].
		class fileOutOn: self moveSource: false toFile: 0].
	self trailer.	"Does nothing for normal files.  HTML streams will have trouble with object data"

	"Append the object's raw data"
	srefStream _ SmartRefStream on: self.
	srefStream blockers: anIdentDict.
	srefStream nextPut: theObject.  "and all subobjects"
	srefStream close.		"also closes me"
! !


!ReadWriteStream methodsFor: 'testing' stamp: 'tk 11/29/2001 12:47'!
= other

	(self class == ReadWriteStream and: [other class == ReadWriteStream]) ifFalse: [
		^ super = other].	"does an identity test.  Don't read contents of FileStream"
	^ self position = other position and: [self contents = other contents]! !

!ReadWriteStream methodsFor: 'testing' stamp: 'tk 12/2/2001 17:13'!
hash

	self class == ReadWriteStream ifFalse: [^ super hash].
	^ (self position + readLimit + 53) hash! !

!ReadWriteStream methodsFor: 'testing' stamp: 'nk 8/21/2004 15:47'!
isZipArchive
	"Determine if this appears to be a valid Zip archive"
	| sig |
	self binary.
	sig _ self next: 4.
	self position: self position - 4. "rewind"
	^ZipArchive validSignatures includes: sig! !


!ReadWriteStream methodsFor: '*packageinfo' stamp: 'ab 10/16/2002 15:56'!
untilEnd: aBlock displayingProgress: aString
	aString
		displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
			[:bar |
			[self atEnd] whileFalse:
				[bar value: self position.
				aBlock value]].! !
ClassTestCase subclass: #ReadWriteStreamTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Streams'!
!ReadWriteStreamTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class ReadWriteStream.
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!


!ReadWriteStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:24'!
testConstructionUsingWith
	"Use the with: constructor."

	| aStream |
	aStream := ReadWriteStream with: #(1 2).
	self assert: (aStream contents = #(1 2)) description: 'Ensure correct initialization.'! !

!ReadWriteStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:24'!
testNew

	self should: [ReadWriteStream new] raise: Error.! !
Object subclass: #RealEstateAgent
	instanceVariableNames: ''
	classVariableNames: 'ReverseStaggerOffset StaggerOffset StaggerOrigin StandardSize StandardWindowOrigins'
	poolDictionaries: ''
	category: 'System-Support'!
!RealEstateAgent commentStamp: '<historical>' prior: 0!
Responsible for real-estate management on the screen, which is to say, controlling where new windows appear, with what sizes, etc.  5/20/96 sw!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RealEstateAgent class
	instanceVariableNames: ''!

!RealEstateAgent class methodsFor: 'accessing' stamp: 'dgd 4/4/2006 16:42'!
maximumUsableArea

	| allowedArea |
	allowedArea _ Display usableArea.
	Smalltalk isMorphic ifTrue: [
		allowedArea := allowedArea intersect: ActiveWorld visibleClearArea.
	].
	^allowedArea! !

!RealEstateAgent class methodsFor: 'accessing' stamp: 'dgd 4/4/2006 16:42'!
maximumUsableAreaInWorld: aWorldOrNil

	| allowedArea |
	allowedArea _ Display usableArea.
	aWorldOrNil ifNotNil: [
		allowedArea := allowedArea intersect: aWorldOrNil visibleClearArea.
	].
	^allowedArea! !

!RealEstateAgent class methodsFor: 'accessing' stamp: 'RAA 5/25/2000 08:45'!
standardPositions
	
	self error: 'please use #standardPositionsInWorld:'! !

!RealEstateAgent class methodsFor: 'accessing' stamp: 'RAA 5/25/2000 08:43'!
standardPositionsInWorld: aWorldOrNil
	"Return a list of standard window positions -- this may have one, two, or four of them, depending on the size and shape of the display screen.  "

	| anArea aList  midX midY |

	anArea _ self maximumUsableAreaInWorld: aWorldOrNil.

	midX _ self scrollBarSetback +   ((anArea width - self scrollBarSetback)  // 2).
	midY _ self screenTopSetback + ((anArea height - self screenTopSetback) // 2).
	aList _ OrderedCollection with: (self scrollBarSetback @ self screenTopSetback).
	self windowColumnsDesired > 1
		ifTrue:
			[aList add: (midX @ self screenTopSetback)].
	self windowRowsDesired > 1
		ifTrue:
			[aList add: (self scrollBarSetback @ (midY+self screenTopSetback)).
			self windowColumnsDesired > 1 ifTrue:
				[aList add: (midX @ (midY+self screenTopSetback))]].
	^ aList! !


!RealEstateAgent class methodsFor: 'class initialization' stamp: 'tk 11/26/1998 09:34'!
initialize
	"Initialize the class variables in the receiver.  5/22/96 sw"
	"RealEstateAgent initialize"

	StaggerOffset _ 6 @ 20.
	ReverseStaggerOffset _ -6 @ 20.
	StaggerOrigin _ 200 @ 30.
	StandardSize _ 600@400.! !


!RealEstateAgent class methodsFor: 'framing' stamp: 'RAA 5/25/2000 08:17'!
initialFrameFor: aView
	"Find a plausible initial screen area for the supplied view.  See called method."

	self error: 'please use #initialFrameFor:world:'! !

!RealEstateAgent class methodsFor: 'framing' stamp: 'RAA 5/25/2000 08:18'!
initialFrameFor: aView initialExtent: initialExtent

	self error: 'please use #initialFrameFor:initialExtent:world:'! !

!RealEstateAgent class methodsFor: 'framing' stamp: 'nk 7/5/2003 08:32'!
initialFrameFor: aView initialExtent: initialExtent world: aWorld
	"Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen."

	| allOrigins screenRight screenBottom putativeOrigin putativeFrame allowedArea staggerOrigin otherFrames |

	Preferences reverseWindowStagger ifTrue:
		[^ self strictlyStaggeredInitialFrameFor: aView initialExtent: initialExtent world: aWorld].

	allowedArea _ self maximumUsableAreaInWorld: aWorld.
	screenRight _ allowedArea right.
	screenBottom _ allowedArea bottom.

	otherFrames _ Smalltalk isMorphic
		ifTrue: [(SystemWindow windowsIn: aWorld satisfying: [:w | w isCollapsed not])
					collect: [:w | w bounds]]
		ifFalse: [ScheduledControllers scheduledWindowControllers
				select: [:aController | aController view ~~ nil]
				thenCollect: [:aController | aController view isCollapsed
								ifTrue: [aController view expandedFrame]
								ifFalse: [aController view displayBox]]].

	allOrigins _ otherFrames collect: [:f | f origin].
	(self standardPositionsInWorld: aWorld) do:  "First see if one of the standard positions is free"
		[:aPosition | (allOrigins includes: aPosition)
			ifFalse:
				[^ (aPosition extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea]].

	staggerOrigin _ (self standardPositionsInWorld: aWorld) first.  "Fallback: try offsetting from top left"
	putativeOrigin _ staggerOrigin.

	[putativeOrigin _ putativeOrigin + StaggerOffset.
	putativeFrame _ putativeOrigin extent: initialExtent.
	(putativeFrame bottom < screenBottom) and:
					[putativeFrame right < screenRight]]
				whileTrue:
					[(allOrigins includes: putativeOrigin)
						ifFalse:
							[^ (putativeOrigin extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea]].
	^ (self scrollBarSetback @ self screenTopSetback extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea! !

!RealEstateAgent class methodsFor: 'framing' stamp: 'RAA 5/25/2000 08:13'!
initialFrameFor: aView world: aWorld
	"Find a plausible initial screen area for the supplied view.  See called method."

	^ self initialFrameFor: aView initialExtent: aView initialExtent world: aWorld! !

!RealEstateAgent class methodsFor: 'framing' stamp: 'RAA 5/25/2000 09:15'!
strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent

	self error: 'please use #strictlyStaggeredInitialFrameFor:initialExtent:world:'! !

!RealEstateAgent class methodsFor: 'framing' stamp: 'nk 7/5/2003 08:32'!
strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld
	"This method implements a staggered window placement policy that I (di) like.
	Basically it provides for up to 4 windows, staggered from each of the 4 corners.
	The windows are staggered so that there will always be a corner visible."

	| allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel |

	allowedArea _(self maximumUsableAreaInWorld: aWorld)
		insetBy: (self scrollBarSetback @ self screenTopSetback extent: 0@0).
	(Smalltalk isMorphic and: [Flaps sharedFlapsAllowed]) ifTrue:
		[allowedArea _ self reduceByFlaps: allowedArea].
	"Number to be staggered at each corner (less on small screens)"
	maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2].
	"Amount by which to stagger (less on small screens)"
	grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20].
	initialFrame _ 0@0 extent: ((initialExtent
							"min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))))
							min: 600@400")).
	otherFrames _ Smalltalk isMorphic
		ifTrue: [(SystemWindow windowsIn: aWorld satisfying: [:w | w isCollapsed not])
					collect: [:w | w bounds]]
		ifFalse: [ScheduledControllers scheduledWindowControllers
				select: [:aController | aController view ~~ nil]
				thenCollect: [:aController | aController view isCollapsed
								ifTrue: [aController view expandedFrame]
								ifFalse: [aController view displayBox]]].
	0 to: maxLevel do:
		[:level | 
		1 to: 4 do:
			[:ci | cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: ci.
			corner _ allowedArea perform: cornerSel.
			"The extra grid//2 in delta helps to keep title tabs distinct"
			delta _ (maxLevel-level*grid+(grid//2)) @ (level*grid).
			1 to: ci-1 do: [:i | delta _ delta rotateBy: #right centerAt: 0@0]. "slow way"
			putativeCorner _ corner + delta.
			free _ true.
			otherFrames do:
				[:w |
				free _ free & ((w perform: cornerSel) ~= putativeCorner)].
			free ifTrue:
				[^ (initialFrame align: (initialFrame perform: cornerSel)
								with: putativeCorner)
						 translatedAndSquishedToBeWithin: allowedArea]]].
	"If all else fails..."
	^ (self scrollBarSetback @ self screenTopSetback extent: initialFrame extent)
		translatedAndSquishedToBeWithin: allowedArea! !


!RealEstateAgent class methodsFor: 'settings' stamp: 'di 9/22/1998 20:58'!
screenTopSetback
	Smalltalk isMorphic
		ifTrue: [^ 0]
		ifFalse: [^ 18]! !

!RealEstateAgent class methodsFor: 'settings' stamp: 'di 9/22/1998 20:58'!
scrollBarSetback
	Smalltalk isMorphic
		ifTrue: [^ 16-3]  "width = 16; inset from border by 3"
		ifFalse: [^ 24]! !

!RealEstateAgent class methodsFor: 'settings' stamp: 'RAA 11/21/1999 22:55'!
standardWindowExtent
	"Answer the standard default extent for new windows.  "

	| effectiveExtent width strips height grid allowedArea maxLevel |
	effectiveExtent _ self maximumUsableArea extent
					- (self scrollBarSetback @ self screenTopSetback).
	Preferences reverseWindowStagger ifTrue:
		["NOTE: following copied from strictlyStaggeredInitialFrameFor:"
		allowedArea _ self maximumUsableArea insetBy: (
			self scrollBarSetback @ self screenTopSetback extent: 0@0
		).
		"Number to be staggered at each corner (less on small screens)"
		maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2].
		"Amount by which to stagger (less on small screens)"
		grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20].
		^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: StandardSize "600@400"].
	width _ (strips _ self windowColumnsDesired) > 1
		ifTrue:
			[effectiveExtent x // strips]
		ifFalse:
			[(3 * effectiveExtent x) // 4].
	height _ (strips _ self windowRowsDesired) > 1
		ifTrue:
			[effectiveExtent y // strips]
		ifFalse:
			[(3 * effectiveExtent y) //4].
	^ width @ height

"RealEstateAgent standardWindowExtent"! !

!RealEstateAgent class methodsFor: 'settings' stamp: 'RAA 11/21/1999 22:54'!
windowColumnsDesired
	"Answer how many separate vertical columns of windows are wanted.  5/22/96 sw"
	^ Preferences reverseWindowStagger
		ifTrue:
			[1]
		ifFalse:
			[(self maximumUsableArea width > 640)
				ifTrue:
					[2]
				ifFalse:
					[1]]! !

!RealEstateAgent class methodsFor: 'settings' stamp: 'RAA 11/21/1999 22:54'!
windowRowsDesired
	"Answer how many separate horizontal rows of windows are wanted.  5/22/96 sw"
	^ Preferences reverseWindowStagger
		ifTrue:
			[1]
		ifFalse:
			[(self maximumUsableArea height > 480)
				ifTrue:
					[2]
				ifFalse:
					[1]]! !


!RealEstateAgent class methodsFor: 'utilities' stamp: 'di 11/20/2001 00:16'!
assignCollapseFrameFor: aSSView 
	"Offer up a location along the left edge of the screen for a collapsed SSView. Make sure it doesn't overlap any other collapsed frames."

	| grid otherFrames topLeft viewBox collapsedFrame extent newFrame verticalBorderDistance top |
	grid _ 8.
	verticalBorderDistance _ 8.
	aSSView isMorph
		ifTrue: [otherFrames _ (SystemWindow windowsIn: aSSView world satisfying: [:w | w ~= aSSView])
						collect: [:w | w collapsedFrame]
						thenSelect: [:rect | rect notNil].
				viewBox _ self reduceByFlaps: aSSView world viewBox]
		ifFalse: [otherFrames _ ScheduledControllers scheduledWindowControllers
						collect: [:aController | aController view ~= aSSView ifTrue: [aController view collapsedFrame]]
						thenSelect: [:rect | rect notNil].
				viewBox _ Display boundingBox].
	collapsedFrame _ aSSView collapsedFrame.
	extent _ collapsedFrame notNil
				ifTrue: [collapsedFrame extent]
				ifFalse: [aSSView isMorph
					ifTrue: [aSSView getRawLabel width + aSSView labelWidgetAllowance @ (aSSView labelHeight + 2)]
					ifFalse: [(aSSView labelText extent x + 70) @ aSSView labelHeight
							min: aSSView labelDisplayBox extent]].
	collapsedFrame notNil
		ifTrue: [(otherFrames anySatisfy: [:f | collapsedFrame intersects: f])
				ifFalse: ["non overlapping"
					^ collapsedFrame]].
	top _ viewBox top + verticalBorderDistance.
	[topLeft _ viewBox left @ top.
	newFrame _ topLeft extent: extent.
	newFrame bottom <= (viewBox height - verticalBorderDistance)]
		whileTrue: 
			[(otherFrames anySatisfy: [:w | newFrame intersects: w])
				ifFalse: ["no overlap"
					^ newFrame].
			top _ top + grid].
	"If all else fails... (really to many wins here)"
	^ 0 @ 0 extent: extent! !

!RealEstateAgent class methodsFor: 'utilities' stamp: 'di 11/20/2001 00:17'!
assignCollapsePointFor: aSSView
	"Offer up a location along the left edge of the screen for a collapsed SSView.
	Make sure it doesn't overlap any other collapsed frames."

	| grid otherFrames y free topLeft viewBox |
	grid _ 24.  "should be mult of 8, since manual move is gridded by 8"
	aSSView isMorph
		ifTrue: [otherFrames _ (SystemWindow windowsIn: aSSView world satisfying: [:w | true])
					collect: [:w | w collapsedFrame]
					thenSelect: [:rect | rect notNil].
				viewBox _ self reduceByFlaps: aSSView world viewBox]
		ifFalse: [otherFrames _ ScheduledControllers scheduledWindowControllers
					collect: [:aController | aController view collapsedFrame]
					thenSelect: [:rect | rect notNil].
				viewBox _ Display boundingBox].
	y _ viewBox top.
	[(y _ y + grid) <= (viewBox height - grid)]
		whileTrue:
		[topLeft _ viewBox left@y.
		free _ true.
		otherFrames do: [:w | free _ free & (topLeft ~= w topLeft)].
		free ifTrue: [^ topLeft]].
	"If all else fails..."
	^ 0 @ 0! !

!RealEstateAgent class methodsFor: 'utilities' stamp: 'dgd 8/31/2003 19:52'!
reduceByFlaps: aScreenRect 
	"Return a rectangle that won't interfere with default shared flaps"

	Flaps sharedFlapsAllowed ifFalse: [^ aScreenRect copy].
	(Flaps globalFlapTabsIfAny allSatisfy:
			[:ft | ft flapID = 'Painting' translated or: [ft edgeToAdhereTo == #bottom]])
		ifTrue: [^ aScreenRect withHeight: aScreenRect height - 18]
		ifFalse: [^ aScreenRect insetBy: 18]! !
AbstractEvent subclass: #RecategorizedEvent
	instanceVariableNames: 'oldCategory'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!RecategorizedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 20:08'!
oldCategory

	^oldCategory! !

!RecategorizedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 20:08'!
oldCategory: aCategoryName

	oldCategory := aCategoryName! !


!RecategorizedEvent methodsFor: 'printing' stamp: 'rw 7/2/2003 09:12'!
printEventKindOn: aStream

	aStream nextPutAll: 'Recategorized'! !


!RecategorizedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:51'!
isRecategorized

	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RecategorizedEvent class
	instanceVariableNames: ''!

!RecategorizedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'!
changeKind

	^#Recategorized! !

!RecategorizedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:20'!
supportedKinds

	^Array with: self classKind with: self methodKind! !


!RecategorizedEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 14:21'!
class: aClass category: cat oldCategory: oldName

	^(self class: aClass category: cat) oldCategory: oldName! !

!RecategorizedEvent class methodsFor: 'instance creation' stamp: 'rw 7/31/2003 16:35'!
method: aMethod protocol: prot class: aClass oldProtocol: oldName

	^(self method: aMethod protocol: prot class: aClass) oldCategory: oldName! !
MessageSet subclass: #RecentMessageSet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!RecentMessageSet commentStamp: 'sw 8/1/2002 17:40' prior: 0!
RecentMessageSet is a message set that shows the most recently-submitted methods, in chronological order.!


!RecentMessageSet methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'!
contents: c notifying: n
	| result |
	result := super contents: c notifying: n.
	result == true ifTrue:
		[self reformulateList].
	^ result! !


!RecentMessageSet methodsFor: 'message functions' stamp: 'sw 9/26/2002 17:59'!
messageListMenu: aMenu shifted: shifted
	"Answer the message-list menu"

	shifted ifTrue: [^ self shiftedMessageListMenu: aMenu].
	aMenu addList:#(
			('what to show...'						offerWhatToShowMenu)
			-
			('browse full (b)' 						browseMethodFull)
			('browse hierarchy (h)'					classHierarchy)
			('browse method (O)'					openSingleMessageBrowser)
			('browse protocol (p)'					browseFullProtocol)
			-
			('fileOut (o)'							fileOutMessage)
			('printOut'								printOutMessage)
			('copy selector (c)'						copySelector)
			-
			('senders of... (n)'						browseSendersOfMessages)
			('implementors of... (m)'					browseMessages)
			('inheritance (i)'						methodHierarchy)
			('versions (v)'							browseVersions)
			-
			('inst var refs...'						browseInstVarRefs)
			('inst var defs...'						browseInstVarDefs)
			('class var refs...'						browseClassVarRefs)
			('class variables'						browseClassVariables)
			('class refs (N)'							browseClassRefs)
			-
			('remove method (x)'					removeMessage)
			('remove from RecentSubmissions'		removeFromRecentSubmissions)
			-
			('more...'								shiftedYellowButtonActivity)).
	^ aMenu! !

!RecentMessageSet methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:27'!
removeFromRecentSubmissions
	"Remove the currently-selected method from the RecentSubmissions list"

	| aClass methodSym |
	((aClass := self selectedClassOrMetaClass) notNil and: [(methodSym := self selectedMessageName) notNil])
		ifTrue: 
			[Utilities purgeFromRecentSubmissions: (MethodReference new setStandardClass: aClass methodSymbol: methodSym).
			self reformulateList]! !


!RecentMessageSet methodsFor: 'message list' stamp: 'sw 7/28/2002 23:20'!
addExtraShiftedItemsTo: aMenu
	"The shifted selector-list menu is being built.  Overridden here to defeat the presence of the items that add or change order, since RecentMessageSet defines methods & order explicitly based on external criteria"

	aMenu add: 'set size of recent history...' action: #setRecentHistorySize! !

!RecentMessageSet methodsFor: 'message list' stamp: 'rbb 3/1/2005 11:11'!
setRecentHistorySize
	"Let the user specify the recent history size"

	| aReply aNumber |
	aReply := UIManager default request: 'How many recent methods
should be maintained?' initialAnswer: Utilities numberOfRecentSubmissionsToStore asString.
	aReply isEmptyOrNil ifFalse:
		[aNumber := aReply asNumber rounded.
		(aNumber > 1 and: [aNumber <= 1000])
			ifTrue:
				[Utilities numberOfRecentSubmissionsToStore: aNumber.
				self inform: 'Okay, ', aNumber asString, ' is the new size of the recent method history']
			ifFalse:
				[self inform: 'Sorry, must be a number between 2 & 1000']]
			! !


!RecentMessageSet methodsFor: 'selection'!
maybeSetSelection
	"After a browser's message list is changed, this message is dispatched to the model, to give it a chance to refigure a selection"	
	self messageListIndex: 1! !


!RecentMessageSet methodsFor: 'update' stamp: 'sw 1/28/2001 20:59'!
growable
	"Answer whether the receiver can be changed by manual additions & deletions"

	^ false! !

!RecentMessageSet methodsFor: 'update' stamp: 'sd 11/20/2005 21:27'!
reformulateList
	| myList |
	"Reformulate the receiver's list.  Exclude methods now deleted"

	myList := Utilities recentMethodSubmissions reversed select: [ :each | each isValid].
	self initializeMessageList: myList.
	self messageListIndex: (messageList size min: 1).	"0 or 1"
	self changed: #messageList.
	self changed: #messageListIndex! !

!RecentMessageSet methodsFor: 'update' stamp: 'sd 11/20/2005 21:27'!
updateListsAndCodeIn: aWindow

	| recentFromUtilities |
	"RAA 20 june 2000 - a recent change to how messages were displayed in the list caused them not to match what was stored in Utilities. This caused the recent submissions to be continuously updated. The hack below fixed that problem"

	self flag: #mref.	"in second pass, use simpler test"

	self canDiscardEdits ifFalse: [^ self].
	recentFromUtilities := Utilities mostRecentlySubmittedMessage,' '.
	(messageList first asStringOrText asString beginsWith: recentFromUtilities)
		ifFalse:
			[self reformulateList]
		ifTrue:
			[self updateCodePaneIfNeeded]! !
AlignmentMorph subclass: #RecordingControlsMorph
	instanceVariableNames: 'recorder recordingStatusLight recordMeter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!RecordingControlsMorph methodsFor: 'accessing' stamp: 'jm 9/13/97 17:20'!
recorder

	^ recorder
! !


!RecordingControlsMorph methodsFor: 'button commands' stamp: 'jhm 10/15/97 15:28'!
done

	recorder stopRecording.
	self makeTile.
	self delete.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 6/10/2003 12:59'!
makeSoundMorph

	| m |
	recorder verifyExistenceOfRecordedSound ifFalse: [^ self].

	recorder pause.
	m _ SoundEventMorph new sound: recorder recordedSound.
	self world firstHand attachMorph: m.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 3/3/2004 19:49'!
makeTile
	"Make a tile representing my sound.  Get a sound-name from the user by which the sound is to be known."

	| newStyleTile sndName tile |
	recorder verifyExistenceOfRecordedSound ifFalse: [^ self].
	recorder pause.
	newStyleTile _ true.
	newStyleTile
		ifTrue:
			[sndName _ FillInTheBlank
				request: 'Please name your new sound' translated
				initialAnswer: 'sound' translated.
			sndName isEmpty ifTrue: [^ self].

			sndName _ SampledSound unusedSoundNameLike: sndName.
			SampledSound
				addLibrarySoundNamed: sndName
				samples: recorder condensedSamples
				samplingRate: recorder samplingRate.
			tile _ SoundTile new literal: sndName]
		ifFalse:
			[tile _ InterimSoundMorph new sound: 
				(SampledSound
					samples: recorder condensedSamples
					samplingRate: recorder samplingRate)].

	tile bounds: tile fullBounds.
	tile openInHand! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 6/10/2003 12:59'!
playback
	"The user hit the playback button"

	recorder verifyExistenceOfRecordedSound ifFalse: [^ self].
	recorder pause.
	recorder playback.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'jhm 10/15/97 14:30'!
record

	recorder clearRecordedSound.
	recorder resumeRecording.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 6/10/2003 12:59'!
show
	"Show my samples in a WaveEditor."

	| ed w |
	recorder verifyExistenceOfRecordedSound ifFalse: [^ self].
	recorder pause.
	ed _ WaveEditor new.
	ed data: recorder condensedSamples.
	ed samplingRate: recorder samplingRate.
	w _ self world.
	w activeHand
		ifNil: [w addMorph: ed]
		ifNotNil: [w activeHand attachMorph: ed].

! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 6/10/2003 12:59'!
trim
	"Show my samples in a GraphMorph."
	
	recorder verifyExistenceOfRecordedSound ifFalse: [^ self].
	recorder pause.
	recorder trim: 1400 normalizedVolume: 80.0.
! !


!RecordingControlsMorph methodsFor: 'copying' stamp: 'jm 10/17/97 15:17'!
updateReferencesUsing: aDictionary
	"Copy my recorder."

	super updateReferencesUsing: aDictionary.
	recorder _ SoundRecorder new.
! !


!RecordingControlsMorph methodsFor: 'initialization' stamp: 'dgd 9/19/2003 12:21'!
addButtonRows

	| r |
	r _ AlignmentMorph newRow vResizing: #shrinkWrap.


	r addMorphBack: (self buttonName: 'Morph' translated action: #makeSoundMorph).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Tile' translated action: #makeTile).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Trim' translated action: #trim).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Show' translated action: #show).
	self addMorphBack: r.

	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: (self buttonName: 'Record' translated action: #record).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' translated action: #stop).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Play' translated action: #playback).
	r addMorphBack: self makeStatusLight.
	self addMorphBack: r.
! !

!RecordingControlsMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:58'!
initialize

	| r |
	super initialize.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	borderWidth _ 2.
	self listDirection: #topToBottom.
	recorder _ SoundRecorder new.
	self addButtonRows.
	self addRecordLevelSlider.

	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: self makeRecordMeter.
	self addMorphBack: r.
	self extent: 10@10.  "make minimum size"
! !


!RecordingControlsMorph methodsFor: 'other' stamp: 'ar 11/9/2000 21:21'!
addRecordLevelSlider

	| levelSlider r |
	levelSlider _ SimpleSliderMorph new
		color: color;
		extent: 100@2;
		target: recorder;
		actionSelector: #recordLevel:;
		adjustToValue: recorder recordLevel.
	r _ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '0 ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' 10').
	self addMorphBack: r.
! !

!RecordingControlsMorph methodsFor: 'other' stamp: 'jhm 10/15/97 14:30'!
buttonName: aString action: aSymbol

	^ SimpleButtonMorph new
		target: self;
		label: aString;
		actionSelector: aSymbol
! !

!RecordingControlsMorph methodsFor: 'other' stamp: 'jm 8/24/97 21:31'!
makeRecordMeter

	| outerBox |
	outerBox _ Morph new extent: 102@18; color: Color gray.
	recordMeter _ Morph new extent: 1@16; color: Color yellow.
	recordMeter position: outerBox topLeft + (1@1).
	outerBox addMorph: recordMeter.
	^ outerBox
! !

!RecordingControlsMorph methodsFor: 'other' stamp: 'jhm 10/15/97 15:06'!
makeStatusLight

	recordingStatusLight _ Morph new extent: 18@18.
	recordingStatusLight color: Color transparent.
	^ recordingStatusLight
! !


!RecordingControlsMorph methodsFor: 'stepping and presenter' stamp: 'tk 6/24/1999 11:41'!
startStepping
	"Make the level meter active when dropped into the world. Do nothing if already recording. Note that this will cause other recorders to stop recording..."

	super startStepping.
	recorder isPaused ifTrue: [
		SoundRecorder allSubInstancesDo: [:r | r stopRecording].  "stop all other sound recorders"
		recorder pause].  "meter is updated while paused"
! !

!RecordingControlsMorph methodsFor: 'stepping and presenter' stamp: 'jm 10/17/97 15:00'!
step

	recorder isPaused
		ifTrue: [recordingStatusLight color: Color transparent]
		ifFalse: [recordingStatusLight color: Color red].
	recordMeter extent: (recorder meterLevel + 1) @ recordMeter height.
! !

!RecordingControlsMorph methodsFor: 'stepping and presenter' stamp: 'jhm 10/15/97 14:30'!
stop

	recorder pause.
! !

!RecordingControlsMorph methodsFor: 'stepping and presenter' stamp: 'jm 10/17/97 15:13'!
stopStepping
	"Turn off recording."

	super stopStepping.
	recorder stopRecording.
! !


!RecordingControlsMorph methodsFor: 'testing' stamp: 'jm 8/24/97 21:00'!
stepTime

	^ 50
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RecordingControlsMorph class
	instanceVariableNames: ''!

!RecordingControlsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:53'!
initialize

	self registerInFlapsRegistry.	! !

!RecordingControlsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:54'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(RecordingControlsMorph	authoringPrototype	'Sound' 	'A device for making sound recordings.')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(RecordingControlsMorph	authoringPrototype	'Sound' 	'A device for making sound recordings.')
						forFlapNamed: 'Widgets'.]! !

!RecordingControlsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:39'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!RecordingControlsMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 18:18'!
descriptionForPartsBin
	^ self partName:	'SoundRecorder'
		categories:		#('Multimedia')
		documentation:	'A device for making sound recordings.'! !
Object subclass: #Rectangle
	instanceVariableNames: 'origin corner'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Rectangle commentStamp: '<historical>' prior: 0!
I represent a rectangular area of the screen. Arithmetic functions take points as arguments and carry out scaling and translating operations to create new instances of me. Rectangle functions create new instances by determining intersections of rectangles with rectangles.!


!Rectangle methodsFor: 'accessing' stamp: 'acg 2/23/2000 00:52'!
aboveCenter
	"Answer the point slightly above the center of the receiver."

	^self topLeft + self bottomRight // (2@3)! !

!Rectangle methodsFor: 'accessing' stamp: 'di 11/17/2001 14:01'!
area
	"Answer the receiver's area, the product of width and height."
	| w |
	(w _ self width) <= 0 ifTrue: [^ 0].
	^ w * self height max: 0! !

!Rectangle methodsFor: 'accessing'!
bottom
	"Answer the position of the receiver's bottom horizontal line."

	^corner y! !

!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'!
bottom: aNumber
	^origin corner: corner x @ aNumber! !

!Rectangle methodsFor: 'accessing'!
bottomCenter
	"Answer the point at the center of the bottom horizontal line of the 
	receiver."

	^self center x @ self bottom! !

!Rectangle methodsFor: 'accessing'!
bottomLeft
	"Answer the point at the left edge of the bottom horizontal line of the 
	receiver."

	^origin x @ corner y! !

!Rectangle methodsFor: 'accessing'!
bottomRight
	"Answer the point at the right edge of the bottom horizontal line of the 
	receiver."

	^corner! !

!Rectangle methodsFor: 'accessing'!
boundingBox
	^ self! !

!Rectangle methodsFor: 'accessing'!
center
	"Answer the point at the center of the receiver."

	^self topLeft + self bottomRight // 2! !

!Rectangle methodsFor: 'accessing'!
corner
	"Answer the point at the bottom right corner of the receiver."

	^corner! !

!Rectangle methodsFor: 'accessing'!
corners
	"Return an array of corner points in the order of a quadrilateral spec for WarpBlt."

	^ Array
		with: self topLeft
		with: self bottomLeft
		with: self bottomRight
		with: self topRight
! !

!Rectangle methodsFor: 'accessing'!
extent
	"Answer with a rectangle with origin 0@0 and corner the receiver's 
	width @ the receiver's height."

	^corner - origin! !

!Rectangle methodsFor: 'accessing'!
height
	"Answer the height of the receiver."

	^corner y - origin y! !

!Rectangle methodsFor: 'accessing'!
innerCorners
	"Return an array of inner corner points,
	ie, the most extreme pixels included,
	in the order of a quadrilateral spec for WarpBlt"
	| r1 |
	r1 _ self topLeft corner: self bottomRight - (1@1).
	^ Array with: r1 topLeft with: r1 bottomLeft with: r1 bottomRight with: r1 topRight! !

!Rectangle methodsFor: 'accessing'!
left
	"Answer the position of the receiver's left vertical line."

	^origin x! !

!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:16'!
left: aNumber
	^aNumber @ origin y corner: corner! !

!Rectangle methodsFor: 'accessing'!
leftCenter
	"Answer the point at the center of the receiver's left vertical line."

	^self left @ self center y! !

!Rectangle methodsFor: 'accessing'!
origin
	"Answer the point at the top left corner of the receiver."

	^origin! !

!Rectangle methodsFor: 'accessing'!
right
	"Answer the position of the receiver's right vertical line."

	^corner x! !

!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'!
right: aNumber
	^origin corner: aNumber @ corner y! !

!Rectangle methodsFor: 'accessing'!
rightCenter
	"Answer the point at the center of the receiver's right vertical line."

	^self right @ self center y! !

!Rectangle methodsFor: 'accessing'!
top
	"Answer the position of the receiver's top horizontal line."

	^origin y! !

!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'!
top: aNumber
	^origin x @ aNumber corner: corner! !

!Rectangle methodsFor: 'accessing'!
topCenter
	"Answer the point at the center of the receiver's top horizontal line."

	^self center x @ self top! !

!Rectangle methodsFor: 'accessing'!
topLeft
	"Answer the point at the top left corner of the receiver's top horizontal line."

	^origin
! !

!Rectangle methodsFor: 'accessing'!
topRight
	"Answer the point at the top right corner of the receiver's top horizontal 
	line."

	^corner x @ origin y! !

!Rectangle methodsFor: 'accessing'!
width
	"Answer the width of the receiver."

	^corner x - origin x! !


!Rectangle methodsFor: 'comparing'!
= aRectangle 
	"Answer true if the receiver's species, origin and corner match aRectangle's."

	self species = aRectangle species
		ifTrue: [^origin = aRectangle origin and: [corner = aRectangle corner]]
		ifFalse: [^false]! !

!Rectangle methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^origin hash bitXor: corner hash! !

!Rectangle methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !


!Rectangle methodsFor: 'FMP' stamp: 'RAA 6/1/1999 17:41'!
deltaToEnsureInOrCentered: r extra: aNumber

	| dX dY halfXDiff halfYDiff |
	dX _ dY _ 0.
	halfXDiff _ (r width - self width * aNumber) truncated.
	halfYDiff _ (r height - self height  * aNumber) truncated.
	self left < r left
		ifTrue: [dX _ self left - r left - halfXDiff]
		ifFalse: [self right > r right ifTrue: [dX _ self right - r right + halfXDiff]].
	self top < r top
		ifTrue: [dY _ self top - r top - halfYDiff]
		ifFalse: [self bottom > r bottom ifTrue: [dY _ self bottom - r bottom + halfYDiff]].
	^dX @ dY
! !


!Rectangle methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	origin printOn: aStream.
	aStream nextPutAll: ' corner: '.
	corner printOn: aStream! !

!Rectangle methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:18'!
propertyListOn: aStream 
	" {x=a; y=b; width=c; height=d} "
	aStream print:'{ x='; write:origin x;
			print:' y='; write:origin y;
			print:' width='; write:self extent x;
			print:' height='; write:self extent y;
			print:'};'.
! !

!Rectangle methodsFor: 'printing'!
storeOn: aStream 
	"printed form is good for storing too"
	self printOn: aStream! !


!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/22/1998 16:11'!
adjustTo: newRect along: side 
	"Return a copy adjusted to fit a neighbor that has changed size."
	side = #left ifTrue: [^ self withRight: newRect left].
	side = #right ifTrue: [^ self withLeft: newRect right].
	side = #top ifTrue: [^ self withBottom: newRect top].
	side = #bottom ifTrue: [^ self withTop: newRect bottom].! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'ar 1/5/2002 18:04'!
allAreasOutsideList: aCollection do: aBlock
	"Enumerate aBlock with all areas of the receiver not overlapping 
	any rectangle in the given collection"
	^self allAreasOutsideList: aCollection startingAt: 1 do: aBlock! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'ar 1/5/2002 18:03'!
allAreasOutsideList: aCollection startingAt: startIndex do: aBlock
	"Enumerate aBlock with all areas of the receiver not overlapping 
	any rectangle in the given collection"
	| yOrigin yCorner aRectangle index rr |
	index _ startIndex.

	"Find the next intersecting rectangle from aCollection"
	[index <= aCollection size ifFalse:[^aBlock value: self].
	aRectangle _ aCollection at: index.
	origin <= aRectangle corner and: [aRectangle origin <= corner]] 
		whileFalse:[index _ index + 1].

	"aRectangle is intersecting; process it"
	aRectangle origin y > origin y 
		ifTrue: [rr _ origin corner: corner x @ (yOrigin _ aRectangle origin y).
				rr allAreasOutsideList: aCollection startingAt: index+1 do: aBlock]
		ifFalse: [yOrigin _ origin y].
	aRectangle corner y < corner y
		ifTrue: [rr _ origin x @ (yCorner _ aRectangle corner y) corner: corner.
				rr allAreasOutsideList: aCollection startingAt: index+1 do: aBlock]
		ifFalse: [yCorner _ corner y].
	aRectangle origin x > origin x 
		ifTrue: [rr _ origin x @ yOrigin corner: aRectangle origin x @ yCorner.
				rr allAreasOutsideList: aCollection startingAt: index+1 do: aBlock].
	aRectangle corner x < corner x 
		ifTrue: [rr _ aRectangle corner x @ yOrigin corner: corner x @ yCorner.
				rr allAreasOutsideList: aCollection startingAt: index+1 do: aBlock].! !

!Rectangle methodsFor: 'rectangle functions'!
amountToTranslateWithin: aRectangle
	"Answer a Point, delta, such that self + delta is forced within aRectangle."
	"Altered so as to prefer to keep self topLeft inside when all of self
	cannot be made to fit 7/27/96 di"
	| dx dy |
	dx _ 0.  dy _ 0.
	self right > aRectangle right ifTrue: [dx _ aRectangle right - self right].
	self bottom > aRectangle bottom ifTrue: [dy _ aRectangle bottom - self bottom].
	(self left + dx) < aRectangle left ifTrue: [dx _ aRectangle left - self left].
	(self top + dy) < aRectangle top ifTrue: [dy _ aRectangle top - self top].
	^ dx@dy! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'ar 10/25/2005 17:22'!
areasOutside: aRectangle
	"Answer an Array of Rectangles comprising the parts of the receiver not 
	intersecting aRectangle."

	| areas yOrigin yCorner |
	"Make sure the intersection is non-empty"
     (self intersects: aRectangle)
		ifFalse: [^Array with: self].
	areas _ OrderedCollection new.
	aRectangle origin y > origin y
		ifTrue: [areas addLast: (origin corner: corner x @ (yOrigin _ aRectangle origin y))]
		ifFalse: [yOrigin _ origin y].
	aRectangle corner y < corner y
		ifTrue: [areas addLast: (origin x @ (yCorner _ aRectangle corner y) corner: corner)]
		ifFalse: [yCorner _ corner y].
	aRectangle origin x > origin x 
		ifTrue: [areas addLast: (origin x @ yOrigin corner: aRectangle origin x @ yCorner)].
	aRectangle corner x < corner x 
		ifTrue: [areas addLast: (aRectangle corner x @ yOrigin corner: corner x @ yCorner)].
	^areas! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 16:00'!
bordersOn: her along: herSide 
	(herSide = #right and: [self left = her right])
	| (herSide = #left and: [self right = her left])
		ifTrue:
		[^ (self top max: her top) < (self bottom min: her bottom)].
	(herSide = #bottom and: [self top = her bottom])
	| (herSide = #top and: [self bottom = her top])
		ifTrue:
		[^ (self left max: her left) < (self right min: her right)].
	^ false! !

!Rectangle methodsFor: 'rectangle functions'!
encompass: aPoint 
	"Answer a Rectangle that contains both the receiver and aPoint.  5/30/96 sw"

	^ Rectangle 
		origin: (origin min: aPoint)
		corner: (corner max:  aPoint)! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'md 10/4/2005 14:42'!
expandBy: delta 
	"Answer a Rectangle that is outset from the receiver by delta. delta is a 
	Rectangle, Point, or scalar."

	(delta isRectangle)
		ifTrue: [^Rectangle 
					origin: origin - delta origin 
					corner: corner + delta corner]
		ifFalse: [^Rectangle 
					origin: origin - delta 
					corner: corner + delta]! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'md 10/4/2005 14:42'!
extendBy: delta 
	"Answer a Rectangle with the same origin as the receiver, but whose corner is offset by delta. delta is a 
	Rectangle, Point, or scalar."

	(delta isRectangle)
		ifTrue: [^Rectangle 
					origin: origin
					corner: corner + delta corner]
		ifFalse: [^Rectangle 
					origin: origin
					corner: corner + delta]! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 16:11'!
forPoint: aPoint closestSideDistLen: sideDistLenBlock
	"Evaluate the block with my side (symbol) closest to aPoint,
		the approx distance of aPoint from that side, and
		the length of the side (or 0 if aPoint is beyond the side)"
	| side |
	side _ self sideNearestTo: aPoint.
	side == #right ifTrue:
		[^ sideDistLenBlock value: side value: (self right - aPoint x) abs
			value: ((aPoint y between: self top and: self bottom)
						ifTrue: [self height] ifFalse: [0])].
	side == #left ifTrue:
		[^ sideDistLenBlock value: side value: (self left - aPoint x) abs
			value: ((aPoint y between: self top and: self bottom)
						ifTrue: [self height] ifFalse: [0])].
	side == #bottom ifTrue:
		[^ sideDistLenBlock value: side value: (self bottom - aPoint y) abs
			value: ((aPoint x between: self left and: self right)
						ifTrue: [self width] ifFalse: [0])].
	side == #top ifTrue:
		[^ sideDistLenBlock value: side value: (self top - aPoint y) abs
			value: ((aPoint x between: self left and: self right)
						ifTrue: [self width] ifFalse: [0])].! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'md 10/2/2005 21:51'!
insetBy: delta 
	"Answer a Rectangle that is inset from the receiver by delta. delta is a 
	Rectangle, Point, or scalar."

	
	(delta isRectangle)
		ifTrue: [^Rectangle 
					origin: origin + delta origin 
					corner: corner - delta corner]
		ifFalse: [^Rectangle 
					origin: origin + delta 
					corner: corner - delta]! !

!Rectangle methodsFor: 'rectangle functions'!
insetOriginBy: originDeltaPoint cornerBy: cornerDeltaPoint 
	"Answer a Rectangle that is inset from the receiver by a given amount in 
	the origin and corner."

	^Rectangle
		origin: origin + originDeltaPoint
		corner: corner - cornerDeltaPoint! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'ar 11/12/2000 19:10'!
intersect: aRectangle 
	"Answer a Rectangle that is the area in which the receiver overlaps with 
	aRectangle. Optimized for speed; old code read:
		^Rectangle 
			origin: (origin max: aRectangle origin)
			corner: (corner min: aRectangle corner)
	"
	| aPoint left right top bottom |
	aPoint _ aRectangle origin.
	aPoint x > origin x ifTrue:[left _ aPoint x] ifFalse:[left _ origin x].
	aPoint y > origin y ifTrue:[top _ aPoint y] ifFalse:[top _ origin y].
	aPoint _ aRectangle corner.
	aPoint x < corner x ifTrue:[right _ aPoint x] ifFalse:[right _ corner x].
	aPoint y < corner y ifTrue:[bottom _ aPoint y] ifFalse:[bottom _ corner y].
	^Rectangle
		origin: (left@top)
		corner: (right@bottom)
! !

!Rectangle methodsFor: 'rectangle functions'!
merge: aRectangle 
	"Answer a Rectangle that contains both the receiver and aRectangle."

	^Rectangle 
		origin: (origin min: aRectangle origin)
		corner: (corner max: aRectangle corner)! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'md 10/4/2005 14:41'!
outsetBy: delta 
	"Answer a Rectangle that is outset from the receiver by delta. delta is a 
	Rectangle, Point, or scalar."

	(delta isRectangle)
		ifTrue: [^Rectangle 
					origin: origin - delta origin 
					corner: corner + delta corner]
		ifFalse: [^Rectangle 
					origin: origin - delta 
					corner: corner + delta]! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 4/30/1998 11:22'!
pointNearestTo: aPoint
	"Return the point on my border closest to aPoint"
	| side |
	(self containsPoint: aPoint)
		ifTrue:
			[side _ self sideNearestTo: aPoint.
			side == #right ifTrue: [^ self right @ aPoint y].
			side == #left ifTrue: [^ self left @ aPoint y].
			side == #bottom ifTrue: [^ aPoint x @ self bottom].
			side == #top ifTrue: [^ aPoint x @ self top]]
		ifFalse:
			[^ aPoint adhereTo: self]! !

!Rectangle methodsFor: 'rectangle functions'!
quickMerge: aRectangle 
	"Answer the receiver if it encloses the given rectangle or the merge of the two rectangles if it doesn't. THis method is an optimization to reduce extra rectangle creations."

	| useRcvr rOrigin rCorner minX maxX minY maxY |
	useRcvr _ true.
	rOrigin _ aRectangle topLeft.
	rCorner _ aRectangle bottomRight.
	minX _ rOrigin x < origin x ifTrue: [useRcvr _ false. rOrigin x] ifFalse: [origin x].
	maxX _ rCorner x > corner x ifTrue: [useRcvr _ false. rCorner x] ifFalse: [corner x].
	minY _ rOrigin y < origin y ifTrue: [useRcvr _ false. rOrigin y] ifFalse: [origin y].
	maxY _ rCorner y > corner y ifTrue: [useRcvr _ false. rCorner y] ifFalse: [corner y].

	useRcvr
		ifTrue: [^ self]
		ifFalse: [^ Rectangle origin: minX@minY corner: maxX@maxY].
! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/20/97 23:01'!
rectanglesAt: y height: ht
	(y+ht) > self bottom ifTrue: [^ Array new].
	^ Array with: (origin x @ y corner: corner x @ (y+ht))! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 15:09'!
sideNearestTo: aPoint
	| distToLeft distToRight distToTop distToBottom closest side |
	distToLeft _ aPoint x - self left.
	distToRight _ self right - aPoint x.
	distToTop _ aPoint y - self top.
	distToBottom _ self bottom - aPoint y.
	closest _ distToLeft. side _ #left.
	distToRight < closest ifTrue: [closest _ distToRight. side _ #right].
	distToTop < closest ifTrue: [closest _ distToTop. side _ #top].
	distToBottom < closest ifTrue: [closest _ distToBottom. side _ #bottom].
	^ side
"
 | r | r _ Rectangle fromUser.
Display border: r width: 1.
[Sensor anyButtonPressed] whileFalse:
	[(r sideNearestTo: Sensor cursorPoint) , '      ' displayAt: 0@0]
"! !

!Rectangle methodsFor: 'rectangle functions'!
translatedToBeWithin: aRectangle
	"Answer a copy of the receiver that does not extend beyond aRectangle.  7/8/96 sw"

	^ self translateBy: (self amountToTranslateWithin: aRectangle)! !

!Rectangle methodsFor: 'rectangle functions'!
withBottom: y 
	"Return a copy of me with a different bottom y"
	^ origin x @ origin y corner: corner x @ y! !

!Rectangle methodsFor: 'rectangle functions'!
withHeight: height 
	"Return a copy of me with a different height"
	^ origin corner: corner x @ (origin y + height)! !

!Rectangle methodsFor: 'rectangle functions'!
withLeft: x 
	"Return a copy of me with a different left x"
	^ x @ origin y corner: corner x @ corner y! !

!Rectangle methodsFor: 'rectangle functions'!
withRight: x 
	"Return a copy of me with a different right x"
	^ origin x @ origin y corner: x @ corner y! !

!Rectangle methodsFor: 'rectangle functions'!
withSide: side setTo: value  "return a copy with side set to value"
	^ self perform: (#(withLeft: withRight: withTop: withBottom: )
							at: (#(left right top bottom) indexOf: side))
		with: value! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 9/8/1999 21:25'!
withSideOrCorner: side setToPoint: newPoint
	"Return a copy with side set to newPoint"

	^ self withSideOrCorner: side setToPoint: newPoint minExtent: 0@0! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'bf 9/10/1999 16:16'!
withSideOrCorner: side setToPoint: newPoint minExtent: minExtent
	"Return a copy with side set to newPoint"
	^self withSideOrCorner: side setToPoint: newPoint minExtent: minExtent
		limit: ((#(left top) includes: side) ifTrue: [SmallInteger minVal] ifFalse: [SmallInteger maxVal])! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'bf 9/10/1999 16:07'!
withSideOrCorner: side setToPoint: newPoint minExtent: minExtent limit: limit
	"Return a copy with side set to newPoint"
	side = #top ifTrue: [^ self withTop: (newPoint y min: corner y - minExtent y max: limit + minExtent y)].
	side = #bottom ifTrue: [^ self withBottom: (newPoint y min: limit - minExtent y max: origin y + minExtent y)].
	side = #left ifTrue: [^ self withLeft: (newPoint x min: corner x - minExtent x max: limit + minExtent x)].
	side = #right ifTrue: [^ self withRight: (newPoint x min: limit - minExtent x max: origin x + minExtent x)].
	side = #topLeft ifTrue: [^ (newPoint min: corner - minExtent) corner: self bottomRight].
	side = #bottomRight ifTrue: [^ self topLeft corner: (newPoint max: origin + minExtent)].
	side = #bottomLeft ifTrue: [^ self topRight rect: ((newPoint x min: corner x - minExtent x) @ (newPoint y max: origin y + minExtent y))].
	side = #topRight ifTrue: [^ self bottomLeft rect: ((newPoint x max: origin x + minExtent x) @ (newPoint y min: corner y - minExtent y))].! !

!Rectangle methodsFor: 'rectangle functions'!
withTop: y 
	"Return a copy of me with a different top y"
	^ origin x @ y corner: corner x @ corner y! !

!Rectangle methodsFor: 'rectangle functions'!
withWidth: width 
	"Return a copy of me with a different width"
	^ origin corner: (origin x + width) @ corner y! !


!Rectangle methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:49'!
isSelfEvaluating
	^ self class == Rectangle! !


!Rectangle methodsFor: 'testing'!
containsPoint: aPoint 
	"Answer whether aPoint is within the receiver."

	^origin <= aPoint and: [aPoint < corner]! !

!Rectangle methodsFor: 'testing'!
containsRect: aRect
	"Answer whether aRect is within the receiver (OK to coincide)."

	^ aRect origin >= origin and: [aRect corner <= corner]
! !

!Rectangle methodsFor: 'testing'!
hasPositiveExtent
	^ (corner x > origin x) and: [corner y > origin y]! !

!Rectangle methodsFor: 'testing' stamp: 'ar 9/10/2000 15:29'!
intersects: aRectangle 
	"Answer whether aRectangle intersects the receiver anywhere."
	"Optimized; old code answered:
		(origin max: aRectangle origin) < (corner min: aRectangle corner)"

	| rOrigin rCorner |
	rOrigin _ aRectangle origin.
	rCorner _ aRectangle corner.
	rCorner x <= origin x	ifTrue: [^ false].
	rCorner y <= origin y	ifTrue: [^ false].
	rOrigin x >= corner x	ifTrue: [^ false].
	rOrigin y >= corner y	ifTrue: [^ false].
	^ true
! !

!Rectangle methodsFor: 'testing' stamp: 'md 10/2/2005 21:51'!
isRectangle
	^true! !

!Rectangle methodsFor: 'testing'!
isTall
	^ self height > self width! !

!Rectangle methodsFor: 'testing'!
isWide
	^ self width > self height! !

!Rectangle methodsFor: 'testing' stamp: 'ar 10/29/2000 19:03'!
isZero
	^origin isZero and:[corner isZero]! !


!Rectangle methodsFor: 'transforming'!
align: aPoint1 with: aPoint2 
	"Answer a Rectangle that is a translated by aPoint2 - aPoint1."

	^self translateBy: aPoint2 - aPoint1! !

!Rectangle methodsFor: 'transforming'!
centeredBeneath: aRectangle
	 "Move the reciever so that its top center point coincides with the bottom center point of aRectangle.  5/20/96 sw:"

	^ self align: self topCenter with: aRectangle bottomCenter! !

!Rectangle methodsFor: 'transforming' stamp: 'di 6/11/97 16:24'!
flipBy: direction centerAt: aPoint 
	"Return a copy flipped #vertical or #horizontal, about aPoint."
	^ (origin flipBy: direction centerAt: aPoint)
		rect: (corner flipBy: direction centerAt: aPoint)! !

!Rectangle methodsFor: 'transforming' stamp: 'JMM 10/21/2003 17:26'!
newRectButtonPressedDo: newRectBlock 
	"Track the outline of a new rectangle until mouse button 
	changes. newFrameBlock produces each new rectangle from the 
	previous. Only tracks while mouse is down."
	| rect newRect buttonNow aHand delay |
	delay _ Delay forMilliseconds: 10.
	buttonNow _ Sensor anyButtonPressed.
	rect _ self.
	Display
		border: rect
		width: 2
		rule: Form reverse
		fillColor: Color gray.
	[buttonNow]
		whileTrue: [delay wait.
			buttonNow _ Sensor anyButtonPressed.
			newRect _ newRectBlock value: rect.
			newRect = rect
				ifFalse: [Display
						border: rect
						width: 2
						rule: Form reverse
						fillColor: Color gray.
					Display
						border: newRect
						width: 2
						rule: Form reverse
						fillColor: Color gray.
					rect _ newRect]].
	Display
		border: rect
		width: 2
		rule: Form reverse
		fillColor: Color gray.
	" pay the price for reading the sensor directly ; get this party started "
	Smalltalk isMorphic
		ifTrue: [aHand _ World activeHand.
			aHand newMouseFocus: nil;
				 showTemporaryCursor: nil;
				 flushEvents].
	Sensor processEvent: Sensor createMouseEvent.
	^ rect! !

!Rectangle methodsFor: 'transforming' stamp: 'JMM 10/21/2003 17:28'!
newRectFrom: newRectBlock
	"Track the outline of a new rectangle until mouse button changes.
	newFrameBlock produces each new rectangle from the previous"
	| rect newRect buttonStart buttonNow aHand delay |
	delay _ Delay forMilliseconds: 10.
	buttonStart _ buttonNow _ Sensor anyButtonPressed.
	rect _ self.
	Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
	[buttonNow == buttonStart] whileTrue: 
		[delay wait.
		buttonNow _ Sensor anyButtonPressed.
		newRect _ newRectBlock value: rect.
		newRect = rect ifFalse:
			[Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
			Display border: newRect width: 2 rule: Form reverse fillColor: Color gray.
			rect _ newRect]].
	Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
	" pay the price for reading the sensor directly ; get this party started "
	Smalltalk isMorphic
		ifTrue: [aHand _ World activeHand.
			aHand newMouseFocus: nil;
				 showTemporaryCursor: nil;
				 flushEvents].
	Sensor processEvent: Sensor createMouseEvent.
	^ rect! !

!Rectangle methodsFor: 'transforming' stamp: 'di 6/11/97 15:11'!
rotateBy: direction centerAt: aPoint
	"Return a copy rotated #right, #left, or #pi about aPoint"
	^ (origin rotateBy: direction centerAt: aPoint)
		rect: (corner rotateBy: direction centerAt: aPoint)! !

!Rectangle methodsFor: 'transforming'!
scaleBy: scale 
	"Answer a Rectangle scaled by scale, a Point or a scalar."

	^Rectangle origin: origin * scale corner: corner * scale! !

!Rectangle methodsFor: 'transforming'!
scaleFrom: rect1 to: rect2
	"Produce a rectangle stretched according to the stretch from rect1 to rect2"
	^ (origin scaleFrom: rect1 to: rect2)
		corner: (corner scaleFrom: rect1 to: rect2)! !

!Rectangle methodsFor: 'transforming' stamp: 'sw 5/21/96'!
squishedWithin: aRectangle
	"Return an adjustment of the receiver that fits within aRectangle by reducing its size, not by changing its origin.  "

	^ origin corner: (corner min: aRectangle bottomRight)

"(50 @ 50 corner: 160 @ 100) squishedWithin:  (20 @ 10 corner: 90 @ 85)"
! !

!Rectangle methodsFor: 'transforming'!
translateBy: factor 
	"Answer a Rectangle translated by factor, a Point or a scalar."

	^Rectangle origin: origin + factor corner: corner + factor! !

!Rectangle methodsFor: 'transforming' stamp: 'nk 7/5/2003 08:31'!
translatedAndSquishedToBeWithin: aRectangle
	"Return an adjustment of the receiver that fits within aRectangle by
		- translating it to be within aRectangle if necessary, then
		- reducing its size, if necessary"

	^ (self translatedToBeWithin: aRectangle) squishedWithin: aRectangle! !


!Rectangle methodsFor: 'truncation and round off'!
rounded
	"Answer a Rectangle whose origin and corner are rounded."

	^Rectangle origin: origin rounded corner: corner rounded! !

!Rectangle methodsFor: 'truncation and round off'!
truncateTo: grid
	"Answer a Rectangle whose origin and corner are truncated to grid x and grid y."

	^Rectangle origin: (origin truncateTo: grid)
				corner: (corner truncateTo: grid)! !

!Rectangle methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'!
truncated
	"Answer a Rectangle whose origin and corner have any fractional parts removed. Answer the receiver if its coordinates are already integral."

	(origin x isInteger and:
	[origin y isInteger and:
	[corner x isInteger and:
	[corner y isInteger]]])
		ifTrue: [^ self].

	^ Rectangle origin: origin truncated corner: corner truncated
! !


!Rectangle methodsFor: '*MorphicExtras-*morphic-Postscript Canvases' stamp: 'mpw 8/9/1930 08:00'!
encodePostscriptOn:aStream 
	aStream write:self origin; print:' '; write:self extent; print:' '.! !


!Rectangle methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'RAA 7/31/2000 17:25'!
encodeForRemoteCanvas

	| encoded |

	CanvasEncoder at: 2 count:  1.
	encoded := String new: 16.
	encoded putInteger32: origin x asInteger at: 1.
	encoded putInteger32: origin y asInteger at: 5.
	encoded putInteger32: corner x asInteger at: 9.
	encoded putInteger32: corner y asInteger at: 13.

	^encoded! !

!Rectangle methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'RAA 7/31/2000 16:39'!
encodeForRemoteCanvasB

	| encoded |

	encoded := Bitmap new: 4.
	encoded at: 1 put: origin x asInteger.
	encoded at: 2 put: origin y asInteger.
	encoded at: 3 put: corner x asInteger.
	encoded at: 4 put: corner y asInteger.

	^encoded! !


!Rectangle methodsFor: 'private'!
setOrigin: topLeft corner: bottomRight
	origin _ topLeft.
	corner _ bottomRight! !


!Rectangle methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'wiz 2/12/2006 15:58'!
ceiling
"Answer the integer rectange to the bottom right of receiver.
Return reciever if it already and integerRectange."

self isIntegerRectangle ifTrue: [ ^ self ] .

^origin ceiling corner: corner ceiling! !

!Rectangle methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'wiz 2/12/2006 01:37'!
compressed
	"Answer a Rectangle whose origin and corner are rounded to integers.
	Rounding is done by upper value on origin and lower value on corner so that
	rounded rectangle is inside self."

	^Rectangle origin: origin ceiling corner: corner floor! !

!Rectangle methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'wiz 2/12/2006 01:37'!
compressTo: grid
	"Answer a Rectangle whose origin and corner are rounded to grid x and grid y.
	Rounding is done by upper value on origin and lower value on corner so that
	rounded rectangle is inside self."

	^Rectangle origin: (origin roundUpTo: grid)
				corner: (corner roundDownTo: grid)! !

!Rectangle methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'nice 2/5/2006 16:52'!
expanded
	"Answer a Rectangle whose origin and corner are rounded to integers.
	Rounding is done by upper value on origin and lower value on corner so that
	self is inside rounded rectangle."

	^Rectangle origin: origin floor corner: corner ceiling! !

!Rectangle methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'nice 2/5/2006 16:51'!
expandTo: grid
	"Answer a Rectangle whose origin and corner are rounded to grid x and grid y.
	Rounding is done by upper value on origin and lower value on corner so that
	self is inside rounded rectangle."

	^Rectangle origin: (origin roundDownTo: grid)
				corner: (corner roundUpTo: grid)! !

!Rectangle methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'wiz 2/12/2006 15:56'!
floor
"Answer the integer rectange to the topleft of receiver.
Return reciever if it already and integerRectange."

self isIntegerRectangle ifTrue: [ ^ self ] .

^origin floor corner: corner floor! !

!Rectangle methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'wiz 1/11/2006 18:39'!
isIntegerRectangle
"Answer true if all component of receiver are integral."

^origin isIntegerPoint and: [ corner isIntegerPoint ]! !

!Rectangle methodsFor: '*Morphic-Truncation and Roundoff' stamp: 'nice 2/5/2006 16:53'!
roundTo: grid
	"Answer a Rectangle whose origin and corner are rounded to grid x and grid y."

	^Rectangle origin: (origin roundTo: grid)
				corner: (corner roundTo: grid)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Rectangle class
	instanceVariableNames: ''!

!Rectangle class methodsFor: 'instance creation' stamp: 'tk 3/9/97'!
center: centerPoint extent: extentPoint 
	"Answer an instance of me whose center is centerPoint and width 
	by height is extentPoint.  "

	^self origin: centerPoint - (extentPoint//2) extent: extentPoint! !

!Rectangle class methodsFor: 'instance creation' stamp: 'di 12/1/97 10:42'!
encompassing: listOfPoints
	"A number of callers of encompass: should use this method."
	| topLeft bottomRight |
	topLeft _ bottomRight _ nil.
	listOfPoints do:
		[:p | topLeft == nil
			ifTrue: [topLeft _ bottomRight _ p]
			ifFalse: [topLeft _ topLeft min: p.
					bottomRight _ bottomRight max: p]].
	^ topLeft corner: bottomRight! !

!Rectangle class methodsFor: 'instance creation'!
fromUser
	"Answer an instance of me that is determined by having the user 
	designate the top left and bottom right corners. The gridding for user 
	selection is 1@1."

	^self fromUser: 1 @ 1! !

!Rectangle class methodsFor: 'instance creation'!
fromUser: gridPoint
	"Answer a Rectangle that is determined by having the user 
	designate the top left and bottom right corners. 
	The cursor reamins linked with the sensor, but
	the outline is kept gridded."
	| originRect |
	originRect _ Cursor origin showWhile: 
		[((Sensor cursorPoint grid: gridPoint) extent: 0@0) newRectFrom:
			[:f | (Sensor cursorPoint grid: gridPoint) extent: 0@0]].
	^ Cursor corner showWhile:
		[originRect newRectFrom:
			[:f | f origin corner: (Sensor cursorPoint grid: gridPoint)]]! !

!Rectangle class methodsFor: 'instance creation' stamp: 'md 12/3/2004 00:02'!
left: leftNumber right: rightNumber top: topNumber bottom: bottomNumber 
	"Answer an instance of me whose left, right, top, and bottom coordinates 
	are determined by the arguments."

	^ self basicNew setOrigin: leftNumber @ topNumber corner: rightNumber @ bottomNumber! !

!Rectangle class methodsFor: 'instance creation' stamp: 'btr 2/14/2003 16:29'!
merging: listOfRects 
	"A number of callers of merge: should use this method."
	| minX minY maxX maxY |
	listOfRects
		do: [:r | minX
				ifNil: [minX _ r topLeft x. minY _ r topLeft y.
					maxX _ r bottomRight x. maxY _ r bottomRight y]
				ifNotNil: [minX _ minX min: r topLeft x. minY _ minY min: r topLeft y.
					maxX _ maxX max: r bottomRight x. maxY _ maxY max: r bottomRight y]].
	^ minX@minY corner: maxX@maxY! !

!Rectangle class methodsFor: 'instance creation' stamp: 'md 12/3/2004 00:04'!
origin: originPoint corner: cornerPoint 
	"Answer an instance of me whose corners (top left and bottom right) are 
	determined by the arguments."

	^self basicNew setOrigin: originPoint corner: cornerPoint! !

!Rectangle class methodsFor: 'instance creation' stamp: 'md 12/3/2004 00:03'!
origin: originPoint extent: extentPoint 
	"Answer an instance of me whose top left corner is originPoint and width 
	by height is extentPoint."

	^self basicNew setOrigin: originPoint corner: originPoint + extentPoint! !

!Rectangle class methodsFor: 'instance creation'!
originFromUser: extentPoint 
	"Answer an instance of me that is determined by having the user 
	designate the top left corner. The width and height are determined by 
	extentPoint. The gridding for user selection is 1@1."

	^self originFromUser: extentPoint grid: 1 @ 1! !

!Rectangle class methodsFor: 'instance creation'!
originFromUser: extentPoint grid: gridPoint 
	"Answer an instance of me that is determined by having the user 
	designate the top left corner. The width and height are determined by 
	extentPoint. The gridding for user selection is scaleFactor. Assumes that 
	the sender has determined an extent that is a proper multiple of 
	scaleFactor."

	^ Cursor origin showWhile: 
		[((Sensor cursorPoint grid: gridPoint) extent: extentPoint) newRectFrom:
			[:f | (Sensor cursorPoint grid: gridPoint) extent: extentPoint]].
! !
BorderedMorph subclass: #RectangleMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!RectangleMorph commentStamp: 'kfr 10/27/2003 11:12' prior: 0!
A subclass of BorderedMorph that supports different fillStyles.

RectangleMorph diagonalPrototype openInWorld.
RectangleMorph gradientPrototype openInWorld.!


!RectangleMorph methodsFor: 'accessing' stamp: 'ar 6/23/2001 16:06'!
wantsToBeCachedByHand
	"Return true if the receiver wants to be cached by the hand when it is dragged around."
	self hasTranslucentColor ifTrue:[^false].
	self bounds = self fullBounds ifTrue:[^true].
	self submorphsDo:[:m|
		(self bounds containsRect: m fullBounds) ifFalse:[
			m wantsToBeCachedByHand ifFalse:[^false].
		].
	].
	^true! !


!RectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.613
		g: 0.903
		b: 1.0! !


!RectangleMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:13'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^self class == RectangleMorph "no subclasses"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RectangleMorph class
	instanceVariableNames: ''!

!RectangleMorph class methodsFor: 'as yet unclassified' stamp: 'nk 9/7/2004 11:44'!
roundRectPrototype
	^ self authoringPrototype useRoundedCorners 
		color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5); 
		borderWidth: 1;
		setNameTo: 'RoundRect'! !


!RectangleMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:12'!
descriptionForPartsBin
	^ self partName:	'Rectangle'
		categories:		#('Graphics' 'Basic')
		documentation:	'A rectangular shape, with border and fill style'! !

!RectangleMorph class methodsFor: 'parts bin' stamp: 'tk 11/14/2001 20:09'!
diagonalPrototype

	| rr |
	rr _ self authoringPrototype.
	rr useGradientFill; borderWidth: 0.
	rr fillStyle direction: rr extent.
	^ rr! !

!RectangleMorph class methodsFor: 'parts bin' stamp: 'tk 11/14/2001 20:09'!
gradientPrototype

	| rr |
	rr _ self authoringPrototype.
	rr useGradientFill; borderWidth: 0.
	^ rr! !


!RectangleMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 10:23'!
initialize

	self registerInFlapsRegistry.	! !

!RectangleMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 10:27'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(RectangleMorph	roundRectPrototype		'RoundRect'		'A rectangle with rounded corners')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(RectangleMorph	authoringPrototype		'Rectangle' 		'A rectangle')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(RectangleMorph	roundRectPrototype		'RoundRect'		'A rectangle with rounded corners')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(RectangleMorph	authoringPrototype		'Rectangle' 		'A rectangle')
						forFlapNamed: 'PlugIn Supplies'.]! !

!RectangleMorph class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:39'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!RectangleMorph class methodsFor: '*MorphicExtras-parts bin' stamp: 'nk 8/23/2004 18:12'!
supplementaryPartsDescriptions
	^ {DescriptionForPartsBin
		formalName: 'RoundRect'
		categoryList: #('Graphics' 'Basic')
		documentation: 'A rectangle with rounded corners'
		globalReceiverSymbol: #RectangleMorph
		nativitySelector: #roundRectPrototype.

	DescriptionForPartsBin
		formalName: 'Gradient'
		categoryList: #('Graphics' 'Basic')
		documentation: 'A rectangle with a horizontal gradient'
		globalReceiverSymbol: #RectangleMorph
		nativitySelector: #gradientPrototype.

	DescriptionForPartsBin
		formalName: 'Gradient (slanted)'
		categoryList: #('Graphics' 'Basic')
		documentation: 'A rectangle with a diagonal gradient'
		globalReceiverSymbol: #RectangleMorph
		nativitySelector: #diagonalPrototype}! !
TestCase subclass: #RectangleTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'GraphicsTests-Primitives'!

!RectangleTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:16'!
testMergingDisjointRects

	| coll merge |
	coll := OrderedCollection new.
	coll add: (Rectangle left: -10 right: 0 top: -10 bottom: 0).
	coll add: (Rectangle left: 0 right: 10 top: 0 bottom: 10).
	merge := Rectangle merging: coll.
	self assert: merge = (Rectangle left: -10 right: 10 top: -10 bottom: 10).! !

!RectangleTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:17'!
testMergingNestedRects

	| coll merge |
	coll := OrderedCollection new.
	coll add: (Rectangle left: 1 right: 10 top: 1 bottom: 10).
	coll add: (Rectangle left: 4 right: 5 top: 4 bottom: 5).
	merge := Rectangle merging: coll.
	self assert: merge = coll first.! !

!RectangleTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:17'!
testMergingOverlappingRects

	| coll merge |
	coll := OrderedCollection new.
	coll add: (Rectangle left: 5 right: 10 top: 0 bottom: 15).
	coll add: (Rectangle left: 0 right: 15 top: 5 bottom: 10).
	merge := Rectangle merging: coll.
	self assert: merge = (Rectangle left: 0 right: 15 top: 0 bottom: 15).! !

!RectangleTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:17'!
testMergingTrivial

	| coll merge |
	coll := OrderedCollection new.
	coll add: (Rectangle left: 1 right: 1 top: 1 bottom: 1).

	merge := Rectangle merging: coll.
	self assert: merge = coll first.
! !

!RectangleTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:17'!
testMergingTwoRects

	| coll merge |
	coll := OrderedCollection new.
	coll add: (Rectangle left: 1 right: 1 top: 1 bottom: 1).
	coll add: (Rectangle left: 10 right: 10 top: 10 bottom: 10).

	merge := Rectangle merging: coll.
	self assert: merge = (Rectangle left: 1 right: 10 top: 1 bottom: 10).! !


!RectangleTest methodsFor: 'testing' stamp: 'BG 10/25/2005 06:48'!
testAreasOutside1
   "RectangleTest new testAreasOutside1"
    | frame rects visibleArea  |
    frame := 0@0 extent: 300@300.
    rects := OrderedCollection new: 80.
    0 to: 3 do: [:i |
      0 to: 2 do: [:j |
            rects add: (i@j * 20 extent: 10@10)
    ]  ].
  
   visibleArea := Array with: frame.
   rects do: [:rect |  | remnants |
      remnants := OrderedCollection new.
      visibleArea do: [:a | remnants addAll: (a areasOutside: rect)].
      visibleArea := remnants.
  ].
  visibleArea := visibleArea asArray.
  self assert: (visibleArea allSatisfy: [:r | r area ~= 0]).

   1 to: visibleArea size do: [:idx |
     idx + 1 to: visibleArea size do: [:idx2 |
        self deny: ((visibleArea at: idx) intersects: (visibleArea at: idx2)).
  ]  ].

  1 to: rects size do: [:idx |
     1 to: visibleArea size do: [:idx2 |
        self deny: ((rects at: idx) intersects: (visibleArea at: idx2)).
  ]  ].

! !

!RectangleTest methodsFor: 'testing' stamp: 'BG 10/25/2005 18:58'!
testAreasOutside2
   "RectangleTest new testAreasOutside2"
    | frame rects visibleArea  |
    frame := 0@0 extent: 300@300.
    rects := OrderedCollection new: 80.
    rects add: (50@50 corner: 200 @ 200);
          add: (100@100 corner: 250@250).
  
   visibleArea := Array with: frame.
   rects do: [:rect |  | remnants |
      remnants := OrderedCollection new.
      visibleArea do: [:a | remnants addAll: (a areasOutside: rect)].
      visibleArea := remnants.
  ].
  visibleArea := visibleArea asArray.
  self assert: (visibleArea allSatisfy: [:r | r area ~= 0]).

   1 to: visibleArea size do: [:idx |
     idx + 1 to: visibleArea size do: [:idx2 |
        self deny: ((visibleArea at: idx) intersects: (visibleArea at: idx2)).
  ]  ].

  1 to: rects size do: [:idx |
     1 to: visibleArea size do: [:idx2 |
        self deny: ((rects at: idx) intersects: (visibleArea at: idx2)).
  ]  ].

! !

!RectangleTest methodsFor: 'testing' stamp: 'BG 10/24/2005 20:24'!
testCorner1
   "RectangleTest new testCorner1"
    | rect |
   rect := 10@10 extent: 20@30.
   self deny: (rect containsPoint: rect corner).! !

!RectangleTest methodsFor: 'testing' stamp: 'BG 10/24/2005 20:28'!
testIntersection1
   "RectangleTest new testIntersection1"
    | rect1 rect2 |
   rect1 := 10@10 corner: 20@30.
   rect2 := rect1 corner extent: 20@40.
   self deny: (rect1 intersects: rect2).! !

!RectangleTest methodsFor: 'testing' stamp: 'BG 10/25/2005 06:36'!
testIntersection2
   "RectangleTest new testIntersection2"
    | rect1 rect2 |
   rect1 := 0@0 corner: 40@40.
   rect2 := 40@40 corner: 50@50.
   self deny: (rect1 intersects: rect2);
        deny: (rect2 intersects: rect1).! !
SmallLandColorTheme subclass: #RedSmallLandColorTheme
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!RedSmallLandColorTheme methodsFor: 'initialization' stamp: 'dgd 3/12/2006 14:31'!
baseColors
	" 
	RedSmallLandColorTheme apply.  
	"
	^ Array
		with: (Color fromArray: #(0.8 0.0 0.2 ))
		with: (Color fromArray: #(0.97 0.13 0.3 ))
		with: (Color fromArray: #(1.0 0.88 0.97 ))! !
BorderedMorph subclass: #ReferenceMorph
	instanceVariableNames: 'referent isHighlighted'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Palettes'!
!ReferenceMorph commentStamp: '<historical>' prior: 0!
Serves as a reference to any arbitrary morph; used, for example, as the tab in a tabbed palette  The wrapper intercepts mouse events and fields them, passing them on to their referent morph.!


!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 10/30/2000 11:11'!
borderWidth: aWidth
	"Set the receiver's border width as indicated, and trigger a fresh layout"

	super borderWidth: aWidth.
	self layoutChanged! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 13:20'!
highlight
	| str |
	isHighlighted := true.
	submorphs notEmpty 
		ifTrue: 
			[((str := submorphs first) isKindOf: StringMorph) 
				ifTrue: [str color: self highlightColor]
				ifFalse: 
					[self
						borderWidth: 1;
						borderColor: self highlightColor]]! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 10:03'!
isCurrentlyGraphical
	"Answer whether the receiver is currently showing a graphical face"

	| first |
	^submorphs notEmpty and: 
			[((first := submorphs first) isKindOf: ImageMorph) 
				or: [first isSketchMorph]]! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:47'!
morphToInstall
	^ referent! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 12/3/1998 10:06'!
referent
	^ referent! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'de 11/30/1998 09:58'!
referent: m
	referent _ m! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 13:21'!
unHighlight
	| str |
	isHighlighted := false.
	self borderWidth: 0.
	submorphs notEmpty 
		ifTrue: 
			[((str := submorphs first) isKindOf: StringMorph orOf: RectangleMorph) 
				ifTrue: [str color: self regularColor]]! !


!ReferenceMorph methodsFor: 'button' stamp: 'sw 12/21/1998 14:13'!
doButtonAction
	self tabSelected! !


!ReferenceMorph methodsFor: 'event handling' stamp: 'sw 11/30/1998 12:46'!
handlesMouseDown: evt
	^ true
! !

!ReferenceMorph methodsFor: 'event handling' stamp: 'sw 3/7/1999 00:29'!
mouseDown: evt
	self setProperty: #oldColor toValue: color! !

!ReferenceMorph methodsFor: 'event handling' stamp: 'sw 10/24/2000 14:45'!
mouseMove: evt
	"The mouse moved while the butten was down in the receiver"

	| aForm |
	aForm _ self imageForm.
	(self containsPoint: evt cursorPoint)
		ifTrue:
			[aForm reverse displayOn: Display]
		ifFalse:
			[aForm displayOn: Display]! !

!ReferenceMorph methodsFor: 'event handling' stamp: 'sw 10/26/2000 14:41'!
mouseUp: evt
	"The mouse came up in the receiver; If the mouse is still within the receiver at this point, do the corresponding action"

	| aColor |
	(aColor _ self valueOfProperty: #oldColor) ifNotNil: [self color: aColor].
	(self containsPoint: evt cursorPoint)
		ifTrue: [self doButtonAction].
	super mouseUp: evt "send to evt handler if any"
! !


!ReferenceMorph methodsFor: 'events' stamp: 'nb 6/17/2003 12:25'!
tabSelected
	"Called when the receiver is hit.  First, bulletproof against someone having taken the structure apart.  My own action basically requires that my grand-owner be a TabbedPalette.  Note that the 'opening' script concept has been left behind here."
	| gramps |
	(owner isKindOf: IndexTabs) ifFalse: [^ Beeper beep].
	((gramps _ owner owner) isKindOf: TabbedPalette)  ifTrue:
		[gramps selectTab: self]! !


!ReferenceMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:49'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 0! !

!ReferenceMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:48'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color transparent! !

!ReferenceMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:49'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	isHighlighted _ false.
	referent _ nil! !


!ReferenceMorph methodsFor: 'layout' stamp: 'sw 12/1/1998 13:20'!
layoutChanged
	self fitContents.
	super layoutChanged! !


!ReferenceMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:59'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add morph-specific items to the menu for the hand"

	| sketch |
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	self isCurrentlyTextual
		ifTrue:
			[aCustomMenu add: 'change label wording...' translated action: #changeTabText.
			aCustomMenu add: 'use graphical label' translated action: #useGraphicalTab]
		ifFalse:
			[aCustomMenu add: 'use textual label' translated action: #useTextualTab.
			aCustomMenu add: 'choose graphic...' translated action: #changeTabGraphic.
			(sketch _ self findA: SketchMorph) ifNotNil:
				[aCustomMenu add: 'repaint' translated target: sketch action: #editDrawing]]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 12/16/1998 14:02'!
changeTabGraphic
	submorphs first chooseNewGraphicCoexisting: true! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sma 6/18/2000 10:36'!
changeTabText
	| reply |
	reply _ FillInTheBlank
		request: 'new wording for this tab:'
		initialAnswer: submorphs first contents.
	reply isEmptyOrNil ifFalse: [submorphs first contents: reply]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 6/21/1999 11:43'!
existingWording
	^ submorphs first contents asString! !

!ReferenceMorph methodsFor: 'menu' stamp: 'di 2/17/2000 20:32'!
graphicalMorphForTab
	| formToUse |
	formToUse _ self valueOfProperty: #priorGraphic ifAbsent: [ScriptingSystem formAtKey: 'squeakyMouse'].
	^ SketchMorph withForm: formToUse! !

!ReferenceMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 12:51'!
isCurrentlyTextual
	| first |
	^((first := submorphs first) isKindOf: StringMorph) 
		or: [first isTextMorph]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 3/23/2000 10:47'!
preserveDetails
	"The receiver is being switched to use a different format.  Preserve the existing details (e.g. wording if textual, grapheme if graphical) so that if the user reverts back to the current format, the details will be right"

	self isCurrentlyTextual
		ifTrue:
			[self setProperty: #priorWording toValue: self existingWording.
			self setProperty: #priorColor toValue: color.
			self setProperty: #priorBorderWidth toValue: borderWidth]
		ifFalse:
			[self setProperty: #priorGraphic toValue: submorphs first form]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 10/30/2000 11:11'!
setLabelFontTo: aFont
	"Change the receiver's label font to be as indicated"

	| aLabel oldLabel |
	aLabel _ StringMorph contents:  (oldLabel _ self findA: StringMorph) contents font: aFont.
	self replaceSubmorph: oldLabel by: aLabel.
	aLabel position: self position.
	aLabel highlightColor: self highlightColor; regularColor: self regularColor.
	aLabel lock.
	self fitContents.
	self layoutChanged.
	(owner isKindOf: IndexTabs) ifTrue:
		[self borderWidth: 0.
		owner laySubpartsOutInOneRow.
		isHighlighted ifTrue:
			[self highlight]]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 7/7/1999 12:49'!
useGraphicalTab
	| aGraphic |
	self preserveDetails.
	self color: Color transparent.
	aGraphic _ self graphicalMorphForTab.
	self borderWidth: 0.
	self removeAllMorphs.
	self addMorphBack: aGraphic.
	aGraphic position: self position.
	aGraphic lock.
	self fitContents.
	self layoutChanged.
	(owner isKindOf: IndexTabs) ifTrue:
		[owner laySubpartsOutInOneRow.
		isHighlighted ifTrue: [self highlight]].! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 10/24/2000 14:39'!
useTextualTab
	"Use a textually-emblazoned tab"

	| aLabel stringToUse font aColor |
	self preserveDetails.
	stringToUse _ self valueOfProperty: #priorWording ifAbsent: [self externalName].
	font _ self valueOfProperty: #priorFont ifAbsent: [Preferences standardButtonFont].
	aColor _ self valueOfProperty: #priorColor ifAbsent: [Color green darker].
	aLabel _ StringMorph contents: stringToUse font: font.
	self replaceSubmorph: submorphs first by: aLabel.
	aLabel position: self position.
	self color: aColor.
	aLabel highlightColor: self highlightColor; regularColor: self regularColor.
	aLabel lock.
	self fitContents.
	self layoutChanged.
	(owner isKindOf: IndexTabs) ifTrue:
		[self borderWidth: 0.
		owner laySubpartsOutInOneRow.
		isHighlighted ifTrue:
			[self highlight]]! !


!ReferenceMorph methodsFor: 'misc' stamp: 'sw 2/11/1999 14:11'!
fitContents
	submorphs size == 1 ifTrue:
		[self extent: submorphs first extent + (2 * self borderWidth).
		submorphs first position: self position + self borderWidth]! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/2/1998 12:38'!
isHighlighted
	^ isHighlighted == true! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/21/1998 15:50'!
morphToInstall: aMorph
	"Create a new tab consisting of a string holding the morph's name"
	| aLabel nameToUse |
	aLabel _ StringMorph new contents: (nameToUse _ aMorph externalName).
	self addMorph: aLabel.
	aLabel lock.
	self referent: aMorph.
	self setNameTo: nameToUse.
	self fitContents.! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 1/11/2000 10:18'!
morphToInstall: aMorph font: aFont
	"Create a new tab consisting of a string holding the morph's name"
	| aLabel nameToUse |
	aLabel _ StringMorph contents: (nameToUse _ aMorph externalName) font: aFont.
	self addMorph: aLabel.
	aLabel lock.
	self referent: aMorph.
	self setNameTo: nameToUse.
	self fitContents.! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/1/1998 11:59'!
sorterToken
	^ SorterTokenMorph new forMorph: self! !


!ReferenceMorph methodsFor: 'naming' stamp: 'dgd 2/22/2003 13:21'!
setNameTo: aString 
	super setNameTo: aString.
	(submorphs notEmpty and: [submorphs first isKindOf: StringMorph]) 
		ifTrue: [submorphs first contents: aString]! !


!ReferenceMorph methodsFor: 'submorphs-accessing' stamp: 'tk 3/8/2000 17:39'!
allNonSubmorphMorphs
	"we hold extra morphs"

	^ Array with: referent! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ReferenceMorph class
	instanceVariableNames: ''!

!ReferenceMorph class methodsFor: 'instance creation' stamp: 'sw 11/30/1998 14:12'!
forMorph: aMorph
	"Create a new tab consisting of a string holding the morph's name"
	^ self new morphToInstall: aMorph! !

!ReferenceMorph class methodsFor: 'instance creation' stamp: 'sw 1/11/2000 10:19'!
forMorph: aMorph font: aFont
	"Create a new tab consisting of a string holding the morph's name"
	^ self new morphToInstall: aMorph font: aFont! !


!ReferenceMorph class methodsFor: 'printing' stamp: 'sw 11/30/1998 12:44'!
defaultNameStemForInstances
	^ 'ref'! !


!ReferenceMorph class methodsFor: '*eToys-scripting' stamp: 'sw 9/26/2001 04:04'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((paintbox ((command makeNewDrawingIn: 'make a new drawing in the specified playfield' Player))))



! !
DataStream subclass: #ReferenceStream
	instanceVariableNames: 'references objects currentReference fwdRefEnds blockers skipping insideASegment'
	classVariableNames: 'RefTypes'
	poolDictionaries: ''
	category: 'System-Object Storage'!
!ReferenceStream commentStamp: '<historical>' prior: 0!
This is a way of serializing a tree of objects into disk file. A ReferenceStream can store
one or more objects in a persistent form, including sharing and cycles.

Here is the way to use DataStream and ReferenceStream:
	rr _ ReferenceStream fileNamed: 'test.obj'.
	rr nextPut: <your object>.
	rr close.

To get it back:
	rr _ ReferenceStream fileNamed: 'test.obj'.
	<your object> _ rr next.
	rr close.

ReferenceStreams can now write "weak" references. nextPutWeak:
writes a "weak" reference to an object, which refers to that object
*if* it also gets written to the stream by a normal nextPut:.

A ReferenceStream should be treated as a read-stream *or* as a write-stream, *not* as a read/write-stream. The reference-remembering mechanism would probably do bad things if you tried to read and write from the same ReferenceStream.

[TBD] Should we override "close" to do (self forgetReferences)?

Instance variables
 references -- an IdentityDictionary mapping objects already written
	to their byteStream positions. If asked to write any object a
	second time, we just write a reference to its stream position.
	This handles shared objects and reference cycles between objects.
	To implement "weak references" (for Aliases), the references
	dictionary also maps objects not (yet?) written to a Collection
	of byteStream positions with hopeful weak-references to it. If
	asked to definitely write one of these objects, we'll fixup those
	weak references.
 objects -- an IdentityDictionary mapping relative byte stream positions to
	objects already read in. If asked to follow a reference, we
	return the object already read.
	This handles shared objects and reference cycles between objects.
 currentReference -- the current reference position. Positon relative to the 
	start of object data in this file.  (Allows user to cut and paste smalltalk 
	code from the front of the file without effecting the reference values.)  
	This variable is used to help install each new object in "objects" as soon
	as it's created, **before** we start reading its contents, in
	case any of its content objects reference it.
 fwdRefEnds -- A weak reference can be a forward reference, which
	requires advance-reading the referrent. When we later come to the
	object, we must get its value from "objects" and not re-read it so
	refs to it don't become refs to copies. fwdRefEnds remembers the
	ending byte stream position of advance-read objects.
 skipping -- true if <what?>
 insideASegment -- true if we are being used to collect objects that will be 
	included in an ImageSegment.  If so, UniClasses must be noted and traced.

If the object is referenced before it is done being created, it might get created twice.  Just store the object the moment it is created in the 'objects' dictionary.  If at the end, comeFullyUpOnReload returns a different object, some refs will have the temporary object (this is an unlikely case).  At the moment, no implementor of comeFullyUpOnReload returns a different object except DiskProxy, and that is OK.
!


!ReferenceStream methodsFor: 'reading' stamp: 'RAA 1/18/2001 11:52'!
beginReference: anObject
	"Remember anObject as the object we read at the position recorded by
	 noteCurrentReference:. This must be done after instantiating anObject but
	 before reading any of its contents that might (directly or indirectly) refer to
	 it. (It's ok to do this redundantly, which is convenient for #next.)
	 Answer the reference position."

	objects at: currentReference ifAbsent: [
		objects at: currentReference put: anObject.
		^ currentReference].
	(skipping includes: currentReference) ifFalse: [
		"If reading just to skip it, don't record this copy."
		objects at: currentReference put: anObject
	].
	^ currentReference		"position relative to start of data portion of file"! !

!ReferenceStream methodsFor: 'reading' stamp: '6/9/97 08:26 tk'!
getCurrentReference
    "PRIVATE -- Return the currentReference posn.  Always a relative position.  So user can cut and paste the Smalltalk source code at the beginning of the file."

    ^ currentReference	"relative position"! !

!ReferenceStream methodsFor: 'reading' stamp: 'tk 4/8/1999 13:11'!
maybeBeginReference: internalObject
	"See if need to record a reference.  In case in the file twice"

	(self isAReferenceType: (self typeIDFor: internalObject))
			ifTrue: [self beginReference: internalObject].
			"save the final object and give it out next time."
	^ internalObject! !

!ReferenceStream methodsFor: 'reading' stamp: 'RAA 1/18/2001 16:46'!
next
	"Answer the next object in the stream.  If this object was already read, don't re-read it.  File is positioned just before the object."
	| curPosn skipToPosn haveIt theObject wasSkipping |

	haveIt _ true.
	curPosn _ byteStream position - basePos.
	theObject _ objects at: curPosn ifAbsent: [haveIt _ false].
		"probe in objects is done twice when coming from objectAt:.  This is OK."
	skipToPosn _ fwdRefEnds at: curPosn ifAbsent: [nil].
	haveIt ifFalse: [ ^ super next].

	skipToPosn ifNotNil: [
		"Skip over the object and return the already-read-in value."
		byteStream position: skipToPosn + basePos		"make absolute"
	] ifNil: [
		"File is not positioned correctly.  Read object and throw it away."
		wasSkipping _ skipping includes: curPosn.
		skipping add: curPosn.
		"fake _" super next.
		wasSkipping ifFalse: [skipping remove: curPosn ifAbsent: []].
	].
	^ theObject
		! !

!ReferenceStream methodsFor: 'reading' stamp: '6/9/97 09:00 tk'!
noteCurrentReference: typeID
	"PRIVATE -- If we support references for type typeID, remember
	 the current byteStream position so beginReference: can add the
	 next object to the 'objects' dictionary of reference positions,
	 then return true. Else return false."
	| answer |

	(answer _ self isAReferenceType: typeID)
		ifTrue: [self setCurrentReference: (byteStream position - 1) - basePos "relative"
				"subtract 1 because we already read the object's type ID byte"].
	^ answer! !

!ReferenceStream methodsFor: 'reading' stamp: ' 6/9/97'!
objectAt: anInteger
    "PRIVATE -- Read & return the object at a given stream position.
     If we already read it, just get it from the objects dictionary.
     (Reading it again wouldn't work with cycles or sharing.)
     If not, go read it and put it in the objects dictionary.
     NOTE: This resolves a cross-reference in the ReferenceStream:
       1. A backward reference to an object already read (the normal case).
       2. A forward reference which is a sated weak reference (we record where
          the object ends so when we get to it normally we can fetch it from
          'objects' and skip over it).
       3. A backward reference to a 'non-reference type' per the long NOTE in
          nextPut: (we compensate here--seek back to re-read it and add the object
          to 'objects' to avoid seeking back to read it any more times).
       4. While reading a foward weak reference (case 2), we may recursively hit an
          ordinary backward reference to an object that we haven't yet read because
          we temporarily skipped ahead. Such a reference is forward in time so we
          treat it much like case 2.
     11/16-24/92 jhm: Handle forward refs. Cf. class comment and above NOTE.
	08:57 tk   anInteger is a relative position"
    | savedPosn refPosn anObject |

    ^ objects at: anInteger "relative position.  case 1: It's in 'objects'"
        ifAbsent:   "do like super objectAt:, but remember the fwd-ref-end position"
            [savedPosn _ byteStream position.		"absolute"
            refPosn _ self getCurrentReference.	"relative position"

            byteStream position: anInteger + basePos.	"was relative"
            anObject _ self next.

            (self isAReferenceType: (self typeIDFor: anObject))
                ifTrue:  [fwdRefEnds at: anInteger put: byteStream position - basePos] "cases 2, 4"
                ifFalse: [objects at: anInteger put: anObject]. "case 3"

            self setCurrentReference: refPosn.		"relative position"
            byteStream position: savedPosn.		"absolute"
            anObject]! !


!ReferenceStream methodsFor: 'statistics' stamp: 'ls 10/10/1999 13:27'!
statisticsOfRefs
	"Analyze the information in references, the objects being written out"

	| parents n kids nm ownerBags tallies owners objParent |
	parents _ IdentityDictionary new: references size * 2.
	n _ 0.
	'Finding Owners...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: references size
	during: [:bar |
	references keysDo:
		[:parent | bar value: (n _ n+1).
		kids _ parent class isFixed
			ifTrue: [(1 to: parent class instSize) collect: [:i | parent
instVarAt: i]]
			ifFalse: [parent class isBits ifTrue: [Array new]
					 ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt:
i]]].
		(kids select: [:x | references includesKey: x])
			do: [:child | parents at: child put: parent]]].
	ownerBags _ Dictionary new.
	tallies _ Bag new.
	n _ 0.
	'Tallying Owners...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: references size
	during: [:bar |
	references keysDo:  "For each class of obj, tally a bag of owner
classes"
		[:obj | bar value: (n _ n+1).
		nm _ obj class name.
		tallies add: nm.
		owners _ ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new].
		(objParent _ parents at: obj ifAbsent: [nil]) == nil
			ifFalse: [owners add: objParent class name]]].
	^ String streamContents:
		[:strm |  tallies sortedCounts do:
			[:assn | n _ assn key.  nm _ assn value.
			owners _ ownerBags at: nm.
			strm cr; nextPutAll: nm; space; print: n.
			owners size > 0 ifTrue:
				[strm cr; tab; print: owners sortedCounts]]]! !


!ReferenceStream methodsFor: 'writing' stamp: 'tk 10/2/2000 18:16'!
beginInstance: aClass size: anInteger
	"This is for use by storeDataOn: methods.  Cf. Object>>storeDataOn:."
	"Addition of 1 seems to make extra work, since readInstance has to compensate.  Here for historical reasons dating back to Kent Beck's original implementation in late 1988.
	In ReferenceStream, class is just 5 bytes for shared symbol.
	SmartRefStream puts out the names and number of class's instances variables for checking.
6/10/97 16:09 tk: See if we can put on a short header. Type = 16. "

	| short ref |
	short _ true.	"All tests for object header that can be written in 4 bytes"
	anInteger <= 254 ifFalse: [short _ false].	"one byte size"
	ref _ references at: aClass name ifAbsent: [short _ false. nil].
	ref isInteger ifFalse: [short _ false].
	short ifTrue: [short _ (ref < 65536) & (ref > 0) "& (ref ~= self vacantRef)"].  "vacantRef is big"
	short ifTrue: [
		byteStream skip: -1.
		short _ byteStream next = 9.
		byteStream skip: 0].	"ugly workaround"
	short 
		ifTrue: ["passed all the tests!!"
			byteStream skip: -1; nextPut: 16; "type = short header"
				nextPut: anInteger + 1;	"size is short"
				nextNumber: 2 put: ref]
		ifFalse: [
			"default to normal longer object header"
			byteStream nextNumber: 4 put: anInteger + 1.
			self nextPut: aClass name].
	insideASegment ifTrue: [
		aClass isSystemDefined ifFalse: [self nextPut: aClass]].
			"just record it to put it into roots"! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/15/98 19:54'!
blockers

	^ blockers! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/13/98 20:00'!
blockers: anIdentDict
	"maps objects -> nil if they should not be written.  object -> anotherObject if they need substitution."

	anIdentDict class == IdentityDictionary ifFalse: [self error: 'must be IdentityDictionary'].
	blockers _ anIdentDict! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/27/2000 11:37'!
insideASegment
	^ insideASegment! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/27/2000 11:36'!
insideASegment: aBoolean
	insideASegment _ aBoolean! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 2/3/2000 21:21'!
isAReferenceType: typeID
	"Return true iff typeID is one of the classes that can be written as a reference to an instance elsewhere in the stream."

	"too bad we can't put Booleans in an Array literal"
	^ (RefTypes at: typeID) == 1
		"NOTE: If you get a bounds error here, the file probably has bad bits in it.  The most common cause is a file unpacking program that puts linefeeds after carriage returns."! !

!ReferenceStream methodsFor: 'writing' stamp: 'jhm 11/15/92'!
nextPutWeak: anObject
    "Write a weak reference to anObject to the receiver stream. Answer anObject.
     If anObject is not a reference type of object, then just put it normally.
     A 'weak' reference means: If anObject gets written this stream via nextPut:,
     then its weak references will become normal references. Otherwise they'll
     read back as nil. -- "
    | typeID referencePosn |

    "Is it a reference type of object? If not, just write it normally."
    typeID _ self typeIDFor: anObject.
    (self isAReferenceType: typeID) ifFalse: [^ self nextPut: anObject].

    "Have we heard of and maybe even written anObject before?"
    referencePosn _ references at: anObject ifAbsent: [
			references at: anObject put: OrderedCollection new].

    "If referencePosn is an Integer, it's the stream position of anObject.
     Else it's a collection of hopeful weak-references to anObject."
    referencePosn isInteger ifFalse:
        [referencePosn add: byteStream position - basePos.		"relative"
        referencePosn _ self vacantRef].
    self outputReference: referencePosn.		"relative"

    ^ anObject! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/24/2000 09:18'!
objectIfBlocked: anObject
	"See if this object is blocked -- not written out and another object substituted."

	^ blockers at: anObject ifAbsent: [anObject]! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/23/2000 08:41'!
project
	"Return the project we are writing or nil"

	(topCall respondsTo: #isCurrentProject) ifTrue: [^ topCall].
	(topCall respondsTo: #do:) ifTrue: [1 to: 5 do: [:ii | 
		((topCall at: ii) respondsTo: #isCurrentProject) ifTrue: [^ topCall at: ii]]].
	^ nil! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/23/2000 08:40'!
projectChangeSet
	| pr |
	"The changeSet of the project we are writing"
	(pr _ self project) ifNil: [^ nil].
	^ pr projectChangeSet! !

!ReferenceStream methodsFor: 'writing'!
references
	^ references! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/24/2000 16:44'!
replace: original with: proxy
	"We may wish to remember that in some field, the original object is being replaced by the proxy.  For the hybred scheme that collects with a DummyStream and writes an ImageSegment, it needs to hold onto the originals so they will appear in outPointers, and be replaced."

	blockers at: original put: proxy! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 8/18/1998 08:38'!
reset
	"PRIVATE -- Reset my internal state.
	   11/15-17/92 jhm: Added transients and fwdRefEnds.
	   7/11/93 sw: Give substantial initial sizes to avoid huge time spent growing.
	   9/3/93 sw: monster version for Sasha"

	super reset.
	references _ IdentityDictionary new: 4096 * 5.
"	objects _ IdentityDictionary new: 4096 * 5.
	fwdRefEnds _ IdentityDictionary new.
"
	blockers ifNil: [blockers _ IdentityDictionary new].
 ! !

!ReferenceStream methodsFor: 'writing' stamp: '6/9/97 08:24 tk'!
setCurrentReference: refPosn
    "PRIVATE -- Set currentReference to refPosn.  Always a relative position."

    currentReference _ refPosn		"relative position"! !

!ReferenceStream methodsFor: 'writing' stamp: 'RAA 1/18/2001 11:51'!
setStream: aStream
	"PRIVATE -- Initialization method."

	super setStream: aStream.
	references _ IdentityDictionary new: 4096 * 5.
	objects _ IdentityDictionary new: 4096 * 5.
	fwdRefEnds _ IdentityDictionary new.
	skipping _ IdentitySet new.
	insideASegment _ false.
	blockers ifNil: [blockers _ IdentityDictionary new].	"keep blockers we just passed in"
! !

!ReferenceStream methodsFor: 'writing' stamp: 'RAA 1/18/2001 11:51'!
setStream: aStream reading: isReading
	"PRIVATE -- Initialization method."

	super setStream: aStream reading: isReading.
	"isReading ifFalse: [  when we are sure"
	references _ IdentityDictionary new: 4096 * 5.
	isReading ifTrue: [
		objects _ IdentityDictionary new: 4096 * 5.
		skipping _ IdentitySet new.
		insideASegment _ false.
		fwdRefEnds _ IdentityDictionary new].
	blockers ifNil: [blockers _ IdentityDictionary new].	"keep blockers we just passed in"
! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/28/2000 22:19'!
tryToPutReference: anObject typeID: typeID
	"PRIVATE -- If we support references for type typeID, and if
	   anObject already appears in my output stream, then put a
	   reference to the place where anObject already appears. If we
	   support references for typeID but didn't already put anObject,
	   then associate the current stream position with anObject in
	   case one wants to nextPut: it again.
	 Return true after putting a reference; false if the object still
	   needs to be put.
	 : Added support for weak refs. Split out outputReference:.
	08:42 tk  references stores relative file positions."
	| referencePosn nextPosn |

	"Is it a reference type of object?"
	(self isAReferenceType: typeID) ifFalse: [^ false].

	"Have we heard of and maybe even written anObject before?"
	referencePosn _ references at: anObject ifAbsent:
			["Nope. Remember it and let the sender write it."
			references at: anObject put: (byteStream position - basePos).	"relative"
			^ false].

	"If referencePosn is an Integer, it's the stream position of anObject."
	referencePosn isInteger ifTrue:
		[self outputReference: referencePosn.	"relative"
		^ true].

	referencePosn == #none ifTrue: ["for DiskProxy"
			references at: anObject put: (byteStream position - basePos).	"relative"
			^ false].


	"Else referencePosn is a collection of positions of weak-references to anObject.
	 Make them full references since we're about to really write anObject."
	references at: anObject put: (nextPosn _ byteStream position) - basePos.	"store relative"
	referencePosn do: [:weakRefPosn |
			byteStream position: weakRefPosn + basePos.		"make absolute"
			self outputReference: nextPosn - basePos].	"make relative"
	byteStream position: nextPosn.		"absolute"
	^ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ReferenceStream class
	instanceVariableNames: ''!

!ReferenceStream class methodsFor: 'accessing'!
refTypes: oc
	RefTypes _ oc! !

!ReferenceStream class methodsFor: 'accessing' stamp: 'tk 5/26/1998 14:51'!
versionCode
    "Answer a number representing the 'version' of the ReferenceStream facility; this is stashed at the beginning of ReferenceStreams, as a secondary versioning mechanism (the primary one is the fileTypeCode).   At present, it serves for information only, and is not checked for compatibility at reload time, but could in future be used to branch to variant code. "

	" 1 = original version 1992"
	" 2 = HyperSqueak.  PathFromHome used for Objs outside the tree.  SqueakSupport SysLibrary for shared globals like Display and StrikeFonts.  File has version number, class structure, then an IncomingObjects manager.  8/16/96 tk.  
	Extended to SmartRefStream.  class structure also keeps superclasse chain.  Does analysis on structure to see when translation methods are needed.  Embedable in file-ins.  (factored out HyperSqueak support)  Feb-May 97 tk"
	" 3 = Reference objects are byte offsets relative to the start of the object portion of the file.  Rectangles with values -2048 to 2047 are encoded compactly."
	" 4 = If UniClasses (subclasses of Player) have class instance variables, append their values in the form (#Class43 (val1 val2 vla3)).  An array of those.  Can still read version 3."
	^ 4! !


!ReferenceStream class methodsFor: 'examples'!
example2
"Here is the way to use DataStream and ReferenceStream:
	rr _ ReferenceStream fileNamed: ''test.obj''.
	rr nextPut: <your object>.
	rr close.

To get it back:
	rr _ ReferenceStream fileNamed: ''test.obj''.
	<your object> _ rr next.
	rr close.
"
"An example and test of DataStream/ReferenceStream.
	 11/19/92 jhm: Use self testWith:."
	"ReferenceStream example2"
	| input sharedPoint |

	"Construct the test data."
	input _ Array new: 9.
	input at: 1 put: nil.
	input at: 2 put: true.
	input at: 3 put: false.
	input at: 4 put: #(-4 -4.0 'four' four).
	input at: 5 put: (Form extent: 63 @ 50 depth: 8).
		(input at: 5) fillWithColor: Color lightOrange.
	input at: 6 put: 1024 @ -2048.
	input at: 7 put: input. "a cycle"
	input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)).
	input at: 9 put: sharedPoint.

	"Write it out, read it back, and return it for inspection."
	^ self testWith: input
! !


!ReferenceStream class methodsFor: 'instance creation' stamp: 'tk 4/19/2001 16:50'!
on: aStream
	"Open a new ReferenceStream on a place to put the raw data."

	aStream class == ReadWriteStream ifTrue: [
		self inform: 'Please consider using a RWBinaryOrTextStream 
instead of a ReadWriteStream'].

	^ super on: aStream
! !
Object subclass: #ReleaseBuilder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ReleaseBuilder'!
!ReleaseBuilder commentStamp: '<historical>' prior: 0!
I'm responsible to help people releasing various distribution of Squeak!


!ReleaseBuilder methodsFor: 'squeakland' stamp: 'sd 9/26/2004 13:35'!
makeSqueaklandRelease
	"ReleaseBuilder new makeSqueaklandRelease"

	self 
		makeSqueaklandReleasePhasePrepare; 		makeSqueaklandReleasePhaseStripping; 		makeSqueaklandReleasePhaseFinalSettings; 		makeSqueaklandReleasePhaseCleanup! !

!ReleaseBuilder methodsFor: 'squeakland' stamp: 'ar 9/27/2005 21:45'!
makeSqueaklandReleasePhaseCleanup
	"ReleaseBuilder new makeSqueaklandReleasePhaseCleanup"

	Smalltalk at: #Browser ifPresent:[:br| br initialize].
	ChangeSet 
		removeChangeSetsNamedSuchThat: [:cs | cs name ~= ChangeSet current name].
	ChangeSet current clear.
	ChangeSet current name: 'Unnamed1'.
	Smalltalk garbageCollect.
	"Reinitialize DataStream; it may hold on to some zapped entitities"
	DataStream initialize.
	"Remove existing player references"
	References keys do: [:k | References removeKey: k].
	Smalltalk garbageCollect.
	ScheduledControllers := nil.
	Behavior flushObsoleteSubclasses.
	Smalltalk
		garbageCollect;
		garbageCollect.
	SystemNavigation default obsoleteBehaviors isEmpty 
		ifFalse: [self error: 'Still have obsolete behaviors'].

	"Reinitialize DataStream; it may hold on to some zapped entitities"
	DataStream initialize.
	Smalltalk fixObsoleteReferences.
	Smalltalk abandonTempNames.
	Smalltalk zapAllOtherProjects.
	Smalltalk forgetDoIts.
	Smalltalk flushClassNameCache.
	3 timesRepeat: 
			[Smalltalk garbageCollect.
			Symbol compactSymbolTable]! !

!ReleaseBuilder methodsFor: 'squeakland' stamp: 'md 2/24/2006 15:18'!
makeSqueaklandReleasePhaseFinalSettings
	"ReleaseBuilder new makeSqueaklandReleasePhaseFinalSettings"

	| serverName serverURL serverDir updateServer highestUpdate newVersion |

	ProjectLauncher splashMorph: (FileDirectory default readOnlyFileNamed: 'scripts\SqueaklandSplash.morph') fileInObjectAndCode.

	"Dump all morphs so we don't hold onto anything"
	World submorphsDo:[:m| m delete].

	#(
		(honorDesktopCmdKeys false)
		(warnIfNoChangesFile false)
		(warnIfNoSourcesFile false)
		(showDirectionForSketches true)
		(menuColorFromWorld false)
		(unlimitedPaintArea true)
		(useGlobalFlaps false)
		(mvcProjectsAllowed false)
		(projectViewsInWindows false)
		(automaticKeyGeneration true)
		(securityChecksEnabled true)
		(showSecurityStatus false)
		(startInUntrustedDirectory true)
		(warnAboutInsecureContent false)
		(promptForUpdateServer false)
		(fastDragWindowForMorphic false)

		(externalServerDefsOnly true)
		(expandedFormat false)
		(eToyFriendly true)
		(eToyLoginEnabled true)
		(magicHalos true)
		(mouseOverHalos true)
		(biggerHandles false)
		(selectiveHalos true)
		(includeSoundControlInNavigator true)
		(readDocumentAtStartup true)
		(preserveTrash true)
		(slideDismissalsToTrash true)

	) do:[:spec|
		Preferences setPreference: spec first toValue: spec last].
	"Workaround for bug"
	Preferences enable: #readDocumentAtStartup.

	World color: (Color r: 0.9 g: 0.9 b: 1.0).

	"Clear all server entries"
	ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each].
	SystemVersion current resetHighestUpdate.

	"Add the squeakalpha update stream"
	serverName := 'Squeakalpha'.
	serverURL := 'squeakalpha.org'.
	serverDir := serverURL , '/'.

	updateServer := ServerDirectory new.
	updateServer
		server: serverURL;
		directory: 'updates/';
		altUrl: serverDir;
		user: 'sqland';
		password: nil.
	Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.

	"Add the squeakland update stream"
	serverName := 'Squeakland'.
	serverURL := 'squeakland.org'.
	serverDir := serverURL , '/'.

	updateServer := ServerDirectory new.
	updateServer
		server: serverURL;
		directory: 'public_html/updates/';
		altUrl: serverDir.
	Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.

	highestUpdate := SystemVersion current highestUpdate.
	(self confirm: 'Reset highest update (' , highestUpdate printString , ')?')
		ifTrue: [SystemVersion current highestUpdate: 0].

	newVersion := UIManager default request: 'New version designation:' initialAnswer: 'Squeakland 3.8.' , highestUpdate printString. 
	SystemVersion newVersion: newVersion.
	(self confirm: self version , '
Is this the correct version designation?
If not, choose no, and fix it.') ifFalse: [^ self].
! !

!ReleaseBuilder methodsFor: 'squeakland' stamp: 'ar 9/27/2005 21:45'!
makeSqueaklandReleasePhasePrepare
	"ReleaseBuilder new makeSqueaklandReleasePhasePrepare"

	Undeclared removeUnreferencedKeys.
	StandardScriptingSystem initialize.
	Preferences initialize.
	"(Object classPool at: #DependentsFields) size > 1 ifTrue: [self error:'Still have dependents']."
	Undeclared isEmpty ifFalse: [self error:'Please clean out Undeclared'].

	"Dump all projects"
	Project allSubInstancesDo:[:prj| prj == Project current ifFalse:[Project deletingProject: prj]].

	"Set new look so we don't need older fonts later"
	StandardScriptingSystem applyNewEToyLook.

	Smalltalk at: #Browser ifPresent:[:br| br initialize].
	ScriptingSystem deletePrivateGraphics.
	ChangeSet removeChangeSetsNamedSuchThat:
		[:cs| cs name ~= ChangeSet current name].
	ChangeSet current clear.
	ChangeSet current name: 'Unnamed1'.
	Smalltalk garbageCollect.
	"Reinitialize DataStream; it may hold on to some zapped entitities"
	DataStream initialize.
	"Remove existing player references"
	References keys do:[:k| References removeKey: k].

	Smalltalk garbageCollect.
	ScheduledControllers := nil.
	Smalltalk garbageCollect.
! !

!ReleaseBuilder methodsFor: 'squeakland' stamp: 'sd 9/26/2004 13:35'!
makeSqueaklandReleasePhaseStripping
	"ReleaseBuilder new makeSqueaklandReleasePhaseStripping"

	#(#Helvetica #Palatino #Courier #ComicSansMS )
		do: [:n | TextConstants
				removeKey: n
				ifAbsent: []].
	Smalltalk
		at: #Player
		ifPresent: [:superCls | superCls
				allSubclassesDo: [:cls | 
					cls isSystemDefined
						ifFalse: [cls removeFromSystem].
					cls := nil]].
	Smalltalk garbageCollect.
	Smalltalk discardFFI; discardSUnit; discardSpeech; yourself.
	"discardMVC;"
	SystemOrganization removeEmptyCategories.
	Smalltalk garbageCollect.
	ScheduledControllers := nil.
	Behavior flushObsoleteSubclasses.
	Smalltalk garbageCollect; garbageCollect.
	DataStream initialize.
	Smalltalk fixObsoleteReferences! !


!ReleaseBuilder methodsFor: 'utilities' stamp: 'ar 9/27/2005 20:10'!
cleanUpChanges
	"Clean up the change sets"

	"ReleaseBuilder new cleanUpChanges"
	
	| projectChangeSetNames |

	"Delete all changesets except those currently used by existing projects."
	projectChangeSetNames := Project allSubInstances collect: [:proj | proj changeSet name].
	ChangeSet removeChangeSetsNamedSuchThat:
		[:cs | (projectChangeSetNames includes: cs) not].
! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/26/2004 15:28'!
cleanUpEtoys
	"ReleaseBuilder new cleanUpEtoys"


	StandardScriptingSystem removeUnreferencedPlayers.

	(self confirm: 'Remove all projects and players?')
		ifFalse: [^self].
	Project removeAllButCurrent.

	#('Morphic-UserObjects' 'EToy-UserObjects' 'Morphic-Imported' )
		do: [:each | SystemOrganization removeSystemCategory: each]! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/26/2004 15:33'!
finalCleanup
	"ReleaseBuilder new finalCleanup"


	Smalltalk forgetDoIts.

	DataStream initialize.
	Behavior flushObsoleteSubclasses.

	"The pointer to currentMethod is not realy needed (anybody care to fix this) and often holds on to obsolete bindings"
	MethodChangeRecord allInstancesDo: [:each | each noteNewMethod: nil].

	self cleanUpEtoys.
	SmalltalkImage current fixObsoleteReferences.

	Smalltalk flushClassNameCache.
	3 timesRepeat: [
		Smalltalk garbageCollect.
		Symbol compactSymbolTable.
	].
! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:41'!
finalStripping
	"ReleaseBuilder new finalStripping"
! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'stephaneducasse 2/3/2006 22:23'!
fixObsoleteReferences
	"ReleaseBuilder new fixObsoleteReferences"

	| informee obsoleteBindings obsName realName realClass |
	Preference allInstances do: [:each | 
		informee := each instVarNamed: #changeInformee.
		((informee isKindOf: Behavior)
			and: [informee isObsolete])
			ifTrue: [
				Transcript show: each name; cr.
				each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]].
 
	CompiledMethod allInstances do: [:method |
		obsoleteBindings := method literals select: [:literal |
			literal isVariableBinding
				and: [literal value isBehavior]
				and: [literal value isObsolete]].
		obsoleteBindings do: [:binding |
			obsName := binding value name.
			Transcript show: obsName; cr.
			realName := obsName copyReplaceAll: 'AnObsolete' with: ''.
			realClass := Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject].
			binding isSpecialWriteBinding
				ifTrue: [binding privateSetKey: binding key value: realClass]
				ifFalse: [binding key: binding key value: realClass]]].


	Behavior flushObsoleteSubclasses.
	Smalltalk garbageCollect; garbageCollect.
	SystemNavigation default obsoleteBehaviors size > 0
		ifTrue: [SystemNavigation default inspect]! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'ar 9/27/2005 21:44'!
initialCleanup
	"Perform various image cleanups in preparation for making a Squeak gamma release candidate image."
	"ReleaseBuilder new initialCleanup"
	
	Undeclared removeUnreferencedKeys.
	StandardScriptingSystem initialize.

	(Object classPool at: #DependentsFields) size > 1 ifTrue: [self error:'Still have dependents'].
	Undeclared isEmpty ifFalse: [self error:'Please clean out Undeclared'].

	Smalltalk at: #Browser ifPresent:[:br| br initialize].
	ScriptingSystem deletePrivateGraphics.  "?"
	
	self cleanUpChanges.
	ChangeSet current clear.
	ChangeSet current name: 'Unnamed1'.
	Smalltalk garbageCollect.

	"Reinitialize DataStream; it may hold on to some zapped entitities"
	DataStream initialize.

	Smalltalk garbageCollect.
	ScheduledControllers := nil.
	Smalltalk garbageCollect.
	
	SMSqueakMap default purge.
	
! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/25/2004 16:25'!
installPreferences
	Preferences initialize.
	Preferences chooseInitialSettings.
! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/26/2004 11:02'!
installReleaseSpecifics
	"ReleaseBuilder new installReleaseSpecifics"
! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:53'!
installVersionInfo
	"ReleaseBuilder new installVersionInfo"
! !

!ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:58'!
prepareReleaseImage
	"Perform various image cleanups in preparation for making a Squeak gamma release candidate image."
	"ReleaseBuilder new prepareReleaseImage"
	
	(self confirm: 'Are you sure you want to prepare a release image?
This will perform several irreversible cleanups on this image.')
		ifFalse: [^ self].

	self
		initialCleanup;
		installPreferences;
		finalStripping;
		installReleaseSpecifics;
		finalCleanup;
		installVersionInfo
! !
ReleaseBuilder subclass: #ReleaseBuilderDeveloper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ReleaseBuilder'!
!ReleaseBuilderDeveloper commentStamp: 'gk 2/28/2005 13:27' prior: 0!
This release builder subclass is used for the official Squeak distribution Basic, which currently is the base image of Squeak.
Full is then built on top of Basic using a loadscript from SqueakMap. Minimal is constructed using another script from SqueakMap that removes packages that are included in Basic.!


!ReleaseBuilderDeveloper methodsFor: 'utilities' stamp: 'mir 11/26/2004 16:18'!
cleanUpChanges
	"Clean up the change sets"

	"ReleaseBuilderDeveloper new cleanUpChanges"
	
! !

!ReleaseBuilderDeveloper methodsFor: 'utilities' stamp: 'mir 4/7/2005 11:56'!
installPreferences
	super installPreferences.
	#(
		(updateFromServerAtStartup true)

	) do:[:spec|
		Preferences setPreference: spec first toValue: spec last]! !

!ReleaseBuilderDeveloper methodsFor: 'utilities' stamp: 'stephaneducasse 2/3/2006 22:23'!
installReleaseSpecifics
	"Currently just clear and add the ServerDirectories
	and update streams we want as default."

	"Clear all server entries"
	ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each].

	"Add default entries, added an entry for the new file area.
	The others are the current ones that see to work 
	as of 2005-02-28 and I recreated them using source."
	ServerDirectory addServer: (ServerDirectory new 
		type: #ftp;
		user: '';
		server: 'box1.squeakfoundation.org';
		altUrl: 'http://box1.squeakfoundation.org/files';
		directory: 'files';
		keepAlive: false) named: 'Squeak.org Archive'.
	ServerDirectory addServer: (ServerDirectory new 
		type: #ftp;
		server: 'st.cs.uiuc.edu';
		user: 'anonymous';
		directory: '/Smalltalk/Squeak';
		keepAlive: false) named: 'UIUC Archive'.	
	ServerDirectory addServer: (ServerDirectory new 
		type: #ftp;
		server: 'ftp.create.ucsb.edu';
		user: 'anonymous';
		directory: '/pub/Smalltalk/Squeak';
		keepAlive: false) named: 'UCSBCreate Archive'.
	ServerDirectory addServer: SuperSwikiServer defaultSuperSwiki named: 'Bob SuperSwiki'.
	ServerDirectory addServer: (SuperSwikiServer new 
		type: #http;
		server: 'squeakland.org:8080';
		altUrl: 'http://www.squeakland.org/uploads';
		directory: '/super/SuperSwikiProj';
		keepAlive: false;
		acceptsUploads: true) named: 'Squeakland SuperSwiki'.
	ServerDirectory addServer: (HTTPServerDirectory new 
		type: #ftp;
		user: 'sqland';
		server: 'www.squeakland.org';
		altUrl: 'http://www.squeakland.org/projects';
		directory: 'projects';
		keepAlive: false) named: 'Squeakland Projects'.

"Add the update streams here just as Squeakland does?
	serverName := 'Squeakland'.
	serverURL := 'squeakland.org'.
	serverDir := serverURL , '/'.
	updateServer := ServerDirectory new.
	updateServer
		server: serverURL;
		directory: 'public:=html/updates/';
		altUrl: serverDir.
	Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.
"
! !
ReleaseBuilder subclass: #ReleaseBuilderNihongo
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ReleaseBuilder'!

!ReleaseBuilderNihongo methodsFor: 'release' stamp: 'md 2/24/2006 15:59'!
release
	"self release"
	
	Utilities emptyScrapsBook.

	Display setExtent: 960@720 depth: 16.
	World color: (Color r: 0.935 g: 0.935 b: 0.935).

	"Preferences takanawa."
	Preferences setPreference: #magicHalos toValue: false.
	Preferences setPreference: #magicHalos toValue: true.
	Preferences setPreference: #mouseOverHalos toValue: false.
	Preferences setPreference: #mouseOverHalos toValue: true.

	Player abandonUnnecessaryUniclasses.
	Player freeUnreferencedSubclasses.
	Player removeUninstantiatedSubclassesSilently.

	PartsBin initialize.
	Flaps disableGlobalFlaps: false.
	Flaps addAndEnableEToyFlaps.
	ActiveWorld addGlobalFlaps.
	Flaps sharedFlapsAlongBottom.

	Locale currentPlatform: (Locale isoLanguage: 'ja').
	Locale switchToID: (LocaleID isoLanguage: 'ja').
	Preferences restoreDefaultFonts.
	StrikeFont setupDefaultFallbackFont.
	Project current updateLocaleDependents.

	"Dump all projects"
	Project allSubInstancesDo:[:prj| prj == Project current ifFalse:[Project deletingProject: prj]].

	ChangeSet current clear.
	ChangeSet current name: 'Unnamed1'.
	Smalltalk garbageCollect.


! !
ReleaseBuilder subclass: #ReleaseBuilderSqueakland
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ReleaseBuilder'!

!ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:14'!
finalCleanup
	"ReleaseBuilder new initialCleanup"


	Smalltalk abandonTempNames.
	Smalltalk zapAllOtherProjects.
	
	super finalCleanup! !

!ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:40'!
finalStripping
	"ReleaseBuilderSqueakland new finalStripping"

	#(#Helvetica #Palatino #Courier #ComicSansMS )
		do: [:n | TextConstants
				removeKey: n
				ifAbsent: []].
	Smalltalk
		at: #Player
		ifPresent: [:superCls | superCls
				allSubclassesDo: [:cls | 
					cls isSystemDefined
						ifFalse: [cls removeFromSystem].
					cls := nil]].
	Smalltalk garbageCollect.
	Smalltalk discardFFI; discardSUnit; discardSpeech; yourself.
	"discardMVC;"
	SystemOrganization removeEmptyCategories.
! !

!ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'ar 9/27/2005 21:45'!
initialCleanup
	"ReleaseBuilder new initialCleanup"

	Smalltalk at: #Browser ifPresent:[:br| br initialize].
	ChangeSet removeChangeSetsNamedSuchThat:
		[:cs| cs name ~= ChangeSet current name].

	super initialCleanup! !

!ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'md 2/24/2006 15:18'!
installPreferences

	#(
		(honorDesktopCmdKeys false)
		(warnIfNoChangesFile false)
		(warnIfNoSourcesFile false)
		(showDirectionForSketches true)
		(menuColorFromWorld false)
		(unlimitedPaintArea true)
		(useGlobalFlaps false)
		(mvcProjectsAllowed false)
		(projectViewsInWindows false)
		(automaticKeyGeneration true)
		(securityChecksEnabled true)
		(showSecurityStatus false)
		(startInUntrustedDirectory true)
		(warnAboutInsecureContent false)
		(promptForUpdateServer false)
		(fastDragWindowForMorphic false)

		(externalServerDefsOnly true)
		(expandedFormat false)
		(eToyFriendly true)
		(eToyLoginEnabled true)
		(magicHalos true)
		(mouseOverHalos true)
		(biggerHandles false)
		(selectiveHalos true)
		(includeSoundControlInNavigator true)
		(readDocumentAtStartup true)
		(preserveTrash true)
		(slideDismissalsToTrash true)
		(propertySheetFromHalo true)

	) do:[:spec|
		Preferences setPreference: spec first toValue: spec last].
	"Workaround for bug"
	Preferences enable: #readDocumentAtStartup.
! !

!ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'stephaneducasse 2/3/2006 22:24'!
installReleaseSpecifics
	"ReleaseBuilderSqueakland new installReleaseSpecifics"

	| serverName serverURL serverDir updateServer |

	ProjectLauncher splashMorph: (FileDirectory default readOnlyFileNamed: 'scripts\SqueaklandSplash.morph') fileInObjectAndCode.

	"Dump all morphs so we don't hold onto anything"
	World submorphsDo:[:m| m delete].

	World color: (Color r: 0.9 g: 0.9 b: 1.0).

	"Clear all server entries"
	ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each].
	SystemVersion current resetHighestUpdate.

	"Add the squeakalpha update stream"
	serverName := 'Squeakalpha'.
	serverURL := 'squeakalpha.org'.
	serverDir := serverURL , '/'.

	updateServer := ServerDirectory new.
	updateServer
		server: serverURL;
		directory: 'updates/';
		altUrl: serverDir;
		user: 'sqland';
		password: nil.
	Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.

	"Add the squeakland update stream"
	serverName := 'Squeakland'.
	serverURL := 'squeakland.org'.
	serverDir := serverURL , '/'.

	updateServer := ServerDirectory new.
	updateServer
		server: serverURL;
		directory: 'public_html/updates/';
		altUrl: serverDir.
	Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}.

! !

!ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'stephaneducasse 2/3/2006 22:23'!
installVersionInfo
	"ReleaseBuilderSqueakland new installVersionInfo"

	| highestUpdate newVersion |
	highestUpdate := SystemVersion current highestUpdate.
	(self confirm: 'Reset highest update (' , highestUpdate printString , ')?')
		ifTrue: [SystemVersion current highestUpdate: 0].

	newVersion := FillInTheBlank request: 'New version designation:' initialAnswer: 'Squeakland 3.8.' , highestUpdate printString. 
	SystemVersion newVersion: newVersion.
	(self confirm: self version , '
Is this the correct version designation?
If not, choose no, and fix it.') ifFalse: [^ self].
! !

!ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'tak 11/28/2005 17:25'!
setupLanguageSpecifics
	"ReleaseBuilderSqueakland new setupLanguageSpecifics"
	Locale current languageEnvironment setupSqueaklandSpecifics! !
TestCase subclass: #ReleaseTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Release'!

!ReleaseTest methodsFor: 'testing' stamp: 'md 2/12/2006 15:27'!
testUndeclared
	Smalltalk cleanOutUndeclared. 
	self assert: Undeclared isEmpty
	! !

!ReleaseTest methodsFor: 'testing' stamp: 'md 2/13/2006 11:21'!
testUnimplementedNonPrimitiveCalls
	"not really true.. there are for sure false positives. But those can be tested for"
	self assert: SystemNavigation default allUnimplementedNonPrimitiveCalls isEmpty.! !
Canvas subclass: #RemoteCanvas
	instanceVariableNames: 'innerClipRect outerClipRect transform connection shadowColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!RemoteCanvas commentStamp: '<historical>' prior: 0!
A canvas which draws to a terminal across the network.  Note that multiple RemoteCanvas's might exist for a single MREncoder, each having different transformations and clipping rectangles.!


!RemoteCanvas methodsFor: 'accessing' stamp: 'ls 3/19/2000 15:56'!
clipRect
	^innerClipRect! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'RAA 11/6/2000 14:17'!
contentsOfArea: aRectangle into: aForm
	"this should never be called; normally, RemoteCanvas's are used in conjunction with a CachingCanvas"

	self flag: #roundedRudeness.	

	"aForm fillWhite.
	^aForm"

	^Display getCanvas contentsOfArea: aRectangle into: aForm! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:33'!
extent
	self flag: #hack.
	^1500@1500! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'yo 10/6/2005 14:44'!
isShadowDrawing
	^ self shadowColor notNil! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:33'!
origin
	^0@0! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'RAA 3/4/2001 08:15'!
shadowColor

	^shadowColor! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
shadowColor: x

	connection shadowColor: (shadowColor := x).
! !


!RemoteCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/2000 08:17'!
apply: ignored

	"added for the convenience of BufferedCanvas"! !


!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 11/6/2000 15:26'!
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc

	self drawCommand: [ :executor |
		executor balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	].! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 7/28/2000 07:41'!
balloonFillRectangle: aRectangle fillStyle: aFillStyle

	self drawCommand: [ :executor |
		executor balloonFillRectangle: aRectangle fillStyle: aFillStyle
	].! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 8/25/2000 14:49'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self drawCommand: [ :c |
		c infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	]! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'ls 10/9/1999 18:25'!
line: point1 to: point2 width: width color: color
	"Draw a line using the given width and color"
	self drawCommand: [ :executor |
		executor line: point1 to: point2 width: width color: color ]! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:26'!
paragraph: paragraph bounds: bounds color: c

	| scanner |
	scanner := CanvasCharacterScanner new.
	scanner
		 canvas: self;
		text: paragraph text textStyle: paragraph textStyle;
		textColor: c; defaultTextColor: c.

	paragraph displayOn: self using: scanner at: bounds topLeft.
! !


!RemoteCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'!
roundCornersOf: aMorph in: bounds during: aBlock

	self flag: #roundedRudeness.	

	aMorph wantsRoundedCorners ifFalse:[^aBlock value].
	(self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds))
		ifTrue: ["Don't bother with corner logic if the region is inside them"
				^ aBlock value].
	CornerRounder roundCornersOf: aMorph on: self in: bounds
		displayBlock: aBlock
		borderWidth: aMorph borderWidthForRounding
		corners: aMorph roundedCorners! !


!RemoteCanvas methodsFor: 'drawing-images' stamp: 'ls 3/26/2000 13:25'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	self drawCommand: [ :executor |
		executor stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]! !


!RemoteCanvas methodsFor: 'drawing-ovals' stamp: 'ls 10/9/1999 18:36'!
fillOval: bounds color: color borderWidth: borderWidth borderColor: borderColor
	"Fill the given oval."
	self drawCommand: [ :executor |
		executor fillOval: bounds color: color borderWidth: borderWidth borderColor: borderColor
	].! !

!RemoteCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 15:25'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval."
	self shadowColor ifNotNil: [
		^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc
	].
	(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
		self flag: #fixThis.
		^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc
	].
	(aFillStyle isSolidFill) ifTrue:[
		^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc
	].
	"Use a BalloonCanvas instead"
	self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! !


!RemoteCanvas methodsFor: 'drawing-polygons' stamp: 'ls 3/25/2000 22:44'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	self drawCommand: [ :c |
		c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]! !


!RemoteCanvas methodsFor: 'drawing-rectangles' stamp: 'yo 10/6/2005 15:53'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle."
	| pattern |
	(self isShadowDrawing not and: [self shadowColor notNil]) ifTrue:
		[^self fillRectangle: aRectangle color: self shadowColor].

	(aFillStyle isKindOf: InfiniteForm) ifTrue: [
		^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	].

	(aFillStyle isSolidFill) 
		ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor].
	"We have a very special case for filling with infinite forms"
	(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
		pattern _ aFillStyle form.
		(aFillStyle direction = (pattern width @ 0) 
			and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
				"Can use an InfiniteForm"
				^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
	].
	"Use a BalloonCanvas instead"
	self balloonFillRectangle: aRectangle fillStyle: aFillStyle.! !

!RemoteCanvas methodsFor: 'drawing-rectangles' stamp: 'RAA 8/25/2000 13:13'!
frameAndFillRectangle: bounds fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Draw the rectangle using the given attributes"

	self drawCommand: [ :executor |
		executor 
			frameAndFillRectangle: bounds 
			fillColor: fillColor 
			borderWidth: borderWidth 
			borderColor: borderColor
	].! !


!RemoteCanvas methodsFor: 'drawing-support' stamp: 'sd 11/20/2005 21:26'!
clipBy: aRectangle during: aBlock
	| newCanvas newR |
	"Set a clipping rectangle active only during the execution of aBlock."

	newR := transform localBoundsToGlobal: aRectangle.

	newCanvas := RemoteCanvas 
		connection: connection 
		clipRect: (outerClipRect intersect: newR) 
		transform: transform.
	newCanvas privateShadowColor: shadowColor.
	aBlock value: newCanvas.
	connection shadowColor: shadowColor.! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'sd 11/20/2005 21:26'!
privateShadowColor: x

	shadowColor := x.
! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'ls 3/26/2000 00:07'!
showAt: pt invalidRects: updateRects
	updateRects do: [ :rect |
		self drawCommand: [ :exec |
			exec forceToScreen: rect ] ]! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'RAA 3/3/2001 18:43'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	| newCanvas |

	self flag: #bob.		"do tranform and clip work together properly?"
	newCanvas := RemoteCanvas 
		connection: connection 
		clipRect: (aClipRect intersect: outerClipRect)
		transform: (transform composedWith: aDisplayTransform).
	newCanvas privateShadowColor: shadowColor.
	aBlock value: newCanvas.
	connection shadowColor: shadowColor.! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'ls 3/26/2000 20:26'!
translateBy: delta during: aBlock
	self transformBy: (MorphicTransform offset: delta negated) clippingTo: outerClipRect during: aBlock smoothing: 1! !


!RemoteCanvas methodsFor: 'drawing-text' stamp: 'yo 10/6/2005 15:57'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	"Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used."
	"(innerClipRect intersects: (transform transformBoundsRect: boundsRect)) ifFalse: [ ^self ]."
		"clip rectangles seem to be all screwed up...."
	s isAllSeparators ifTrue: [ ^self ].   "is this correct??  it sure does speed things up!!"
	self drawCommand: [ :executor |
		executor drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: (self isShadowDrawing ifTrue: [self shadowColor] ifFalse: [c])]! !


!RemoteCanvas methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
asBufferedCanvas

	| bufferedCanvas |

	bufferedCanvas := BufferedCanvas new.
	connection cachingEnabled: false.
	bufferedCanvas
		connection: connection
		clipRect: NebraskaServer extremelyBigRectangle
		transform: MorphicTransform identity
		remoteCanvas: self.
	^bufferedCanvas! !

!RemoteCanvas methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
connection: connection0 clipRect: clipRect0 transform: transform0
	connection := connection0.
	outerClipRect := clipRect0.
	transform := transform0.


	innerClipRect := transform globalBoundsToLocal: outerClipRect. ! !

!RemoteCanvas methodsFor: 'initialization' stamp: 'ls 3/21/2000 23:22'!
flush
	connection ifNotNil: [ connection flush ]! !

!RemoteCanvas methodsFor: 'initialization' stamp: 'RAA 11/8/2000 15:06'!
purgeOutputQueue

	connection purgeOutputQueue.! !


!RemoteCanvas methodsFor: 'misc' stamp: 'ls 2/28/2000 00:16'!
processIO
	connection processIO! !


!RemoteCanvas methodsFor: 'Nebraska/embeddedWorlds' stamp: 'RAA 12/11/2000 12:30'!
transform2By: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	(aDisplayTransform isPureTranslation) ifTrue: [
		^self 
			transformBy: aDisplayTransform 
			clippingTo: aClipRect 
			during: aBlock 
			smoothing: cellSize
	].
	^super 
		transform2By: aDisplayTransform 
		clippingTo: aClipRect 
		during: aBlock 
		smoothing: cellSize
! !


!RemoteCanvas methodsFor: 'nil' stamp: 'RAA 8/1/2000 00:13'!
backlog

	^connection backlog! !


!RemoteCanvas methodsFor: 'other' stamp: 'RAA 7/20/2000 17:47'!
forceToScreen: rect

		self drawCommand: [ :exec |
			exec forceToScreen: rect ]! !


!RemoteCanvas methodsFor: 'private' stamp: 'ls 3/27/2000 18:50'!
drawCommand: aBlock
	"set up the connection for a drawing command, and then execute aBlock with the connection as an argument"
	connection updateTransform: transform andClipRect: outerClipRect.
	aBlock value: connection! !

!RemoteCanvas methodsFor: 'private' stamp: 'ls 10/9/1999 18:38'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the given form."
	self drawCommand: [ :executor |
		executor image: aForm at: aPoint sourceRect: sourceRect rule: rule
	].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RemoteCanvas class
	instanceVariableNames: ''!

!RemoteCanvas class methodsFor: 'instance creation' stamp: 'ls 10/20/1999 21:14'!
connection: connection  clipRect: clipRect  transform: transform
	^self new connection: connection clipRect: clipRect transform: transform! !
HandMorph subclass: #RemoteControlledHandMorph
	instanceVariableNames: 'eventDecoder viewExtent nebraskaClient'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Morphic-Remote'!
!RemoteControlledHandMorph commentStamp: '<historical>' prior: 0!
Used as part of the Nebraska system.  It is controlled by commands sent through a socket.  The encoding is interpreted via a MorphicEventDecoder.!


!RemoteControlledHandMorph methodsFor: 'drawing' stamp: 'RAA 12/12/2000 14:45'!
needsToBeDrawn

	^true! !


!RemoteControlledHandMorph methodsFor: 'event handling' stamp: 'ls 3/25/2000 16:51'!
processEvents
	| |
	eventDecoder processIO.
	eventDecoder applyMessagesTo: self.
! !


!RemoteControlledHandMorph methodsFor: 'events' stamp: 'RAA 11/8/2000 15:15'!
convertRemoteClientToBuffered

	self world convertRemoteClientToBuffered: nebraskaClient! !

!RemoteControlledHandMorph methodsFor: 'events' stamp: 'ar 10/25/2000 23:29'!
queueEvent: anEvent
	"add an event to be handled"

	anEvent setHand: self.
	self handleEvent: anEvent resetHandlerFields.! !

!RemoteControlledHandMorph methodsFor: 'events' stamp: 'ls 3/25/2000 16:44'!
setViewExtent: newExtent
	"set the extent of this hand's view of the world"
	viewExtent := newExtent! !


!RemoteControlledHandMorph methodsFor: 'geometry' stamp: 'ls 3/25/2000 16:44'!
worldBounds
	^0@0 extent: viewExtent! !


!RemoteControlledHandMorph methodsFor: 'initialization' stamp: 'ls 3/24/2000 21:53'!
decoder: aDecoder
	eventDecoder := aDecoder! !

!RemoteControlledHandMorph methodsFor: 'initialization' stamp: 'ls 3/25/2000 16:44'!
initialize
	super initialize.
	viewExtent := 100@100.! !

!RemoteControlledHandMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
nebraskaClient: aNebraskaClient

	nebraskaClient := aNebraskaClient! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RemoteControlledHandMorph class
	instanceVariableNames: ''!

!RemoteControlledHandMorph class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 18:10'!
on: aDecoder 
	^self new  decoder: aDecoder! !
RWBinaryOrTextStream subclass: #RemoteFileStream
	instanceVariableNames: 'remoteFile localDataValid'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RemoteDirectory'!
!RemoteFileStream commentStamp: '<historical>' prior: 0!
An in-memory stream that can be used to fileIn code from the network.  Knows its ServerFile, and thus its name, path, etc.

localDataValid -- false when have never read the file from the server.  Set to true after reading, when my contents has the true data.  When creating a remote file, set localDataValid to true so it will write to server.!


!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 12/3/2003 21:04'!
close
	"Write if we have data to write.  FTP files are always binary to preserve the data exactly.  The binary/text (ascii) flag is just for tell how the bits are delivered from a read."

	remoteFile writable ifTrue: [
			remoteFile putFile: (self as: RWBinaryOrTextStream) reset named: remoteFile fileName]! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:47'!
contentsOfEntireFile
	"Fetch the data off the server and store it in me.  But not if I already have it."

	readLimit _ readLimit max: position.
	localDataValid ifTrue: [^ super contentsOfEntireFile].
	collection size = 0 ifTrue: [self on: (String new: 2000)].
	remoteFile getFileNamed: remoteFile fileName into: self.	"sets localDataValid _ true"
	^ super contentsOfEntireFile! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:45'!
dataIsValid

	localDataValid _ true.! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 09:19'!
directory
	^ remoteFile! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 3/13/2000 16:51'!
directoryUrl
	^ remoteFile directoryUrl! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 14:30'!
localName
	^ remoteFile fileName! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:48'!
openReadOnly
	"If we have data, don't reread."

	self readOnly.
	readLimit _ readLimit max: position.
	localDataValid ifFalse: [remoteFile getFileNamed: remoteFile fileName into: self].
		"sets localDataValid _ true"! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 22:43'!
padToEndWith: aChar
	"On the Mac, files do not truncate, so pad it with a harmless character.  But Remote FTP files always replace, so no need to pad."

	self atEnd ifFalse: [self inform: 'Why is this stream not at its end?'].! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 14:32'!
readOnly
	^ remoteFile readOnly! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 09:18'!
remoteFile
	^ remoteFile! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:39'!
remoteFile: aServerFile
	remoteFile _ aServerFile.
	localDataValid _ false.	"need to read from the server"! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 9/11/2000 19:13'!
sleep
	"If we are done, then let the server know"

	self close.
	remoteFile sleep.! !


!RemoteFileStream methodsFor: '*MorphicExtras-as yet unclassified' stamp: 'tk 1/25/1999 15:16'!
url
	^ remoteFile url! !
HandMorph subclass: #RemoteHandMorph
	instanceVariableNames: 'remoteWorldExtent remoteAddress sendSocket sendBuffer sendState socket waitingForConnection receiveBuffer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalSupport'!

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:10'!
lastEventTransmitted
	^self valueOfProperty: #lastEventTransmitted! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:10'!
lastEventTransmitted: anEvent
	^self setProperty: #lastEventTransmitted toValue: anEvent! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:10'!
lastWorldExtent
	^self valueOfProperty: #lastWorldExtent! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:10'!
lastWorldExtent: extent
	^self setProperty: #lastWorldExtent toValue: extent! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 16:50'!
readyToTransmit
	"Return true if the receiver is ready to send."

	(sendState == #connected) ifTrue:[
		 sendSocket sendDone ifFalse:[^false].
		^true].

	sendState == #opening ifTrue:[
		sendSocket isConnected ifTrue:[^true].
		sendSocket isWaitingForConnection ifFalse:[
			Transcript show: 'trying connection again...'; cr.
			sendSocket destroy.
			sendSocket _ Socket new.
			sendSocket connectTo: self remoteHostAddress port: 54323]].

	sendState == #closing ifTrue:[
		sendSocket isUnconnectedOrInvalid ifTrue:[
			sendSocket destroy.
			sendState _ #unconnected]].

	^false! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 15:59'!
remoteHostAddress
	"Return the address of the remote host or zero if not connected."
	^remoteAddress ifNil:[0]! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'RAA 7/12/2000 11:46'!
startListening
	"Create a socket and start listening for a connection."

	self stopListening.
	Transcript show: 'My address is ', NetNameResolver localAddressString; cr.
	Transcript show: 'Remote hand ', self userInitials, ' waiting for a connection...'; cr.
	socket _ Socket new.
	socket listenOn: 54323.
	waitingForConnection _ true.
! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'mir 5/13/2003 10:44'!
startTransmittingEvents
	"Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer."
	(sendSocket notNil and:[sendSocket isConnected]) ifTrue:[^self].
	Transcript
		show: 'Connecting to remote WorldMorph at ';
		show: (NetNameResolver stringFromAddress: self remoteHostAddress), ' ...'; cr.
	sendSocket _ OldSimpleClientSocket new.
	sendSocket connectTo: self remoteHostAddress port: 54323.
	sendState _ #opening.
	owner primaryHand addEventListener: self.! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'mir 5/13/2003 10:45'!
startTransmittingEventsTo: remoteAddr
	"Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer."
	remoteAddress _ remoteAddr.
	(sendSocket notNil and:[sendSocket isConnected]) ifTrue:[^self].
	Transcript
		show: 'Connecting to remote WorldMorph at ';
		show: (NetNameResolver stringFromAddress: self remoteHostAddress), ' ...'; cr.
	sendSocket _ OldSimpleClientSocket new.
	sendSocket connectTo: self remoteHostAddress port: 54323.
	sendState _ #opening.
	owner primaryHand addEventListener: self.! !

!RemoteHandMorph methodsFor: 'connections'!
stopListening
	"Destroy the socket, if any, terminating the connection."

	socket ifNotNil: [
		socket destroy.
		socket _ nil].
! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:34'!
stopTransmittingEvents
	"Stop broadcasting events from this world's cursor to a remote cursor on the host with the given address. This method issues a 'close' but does not destroy the socket; it will be destroyed when the other end reads the last data and closes the connection."
	(sendSocket isUnconnectedOrInvalid) ifFalse:[
		sendSocket close.
		sendState _ #closing].
	owner primaryHand removeEventListener: self.! !


!RemoteHandMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:07'!
drawOn: aCanvas
	"For remote cursors, always draw the hand itself (i.e., the cursor)."

	super drawOn: aCanvas.
	aCanvas paintImage: NormalCursor at: self position.
! !

!RemoteHandMorph methodsFor: 'drawing' stamp: 'RAA 12/12/2000 14:45'!
needsToBeDrawn

	^true! !


!RemoteHandMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:51'!
processEvents
	"Process user input events from the remote input devices."

	| evt |
	evt := self getNextRemoteEvent.
	[evt notNil] whileTrue: 
			[evt type == #worldExtent 
				ifTrue: 
					[remoteWorldExtent := evt argument.
					^self].
			self handleEvent: evt.
			evt := self getNextRemoteEvent]! !

!RemoteHandMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 00:50'!
transmitEvent: aMorphicEvent
	"Transmit the given event to all remote connections."
	| firstEvt |
	self readyToTransmit ifFalse: [^ self].
	self lastEventTransmitted = aMorphicEvent ifTrue: [^ self].
	sendBuffer ifNil: [sendBuffer _ WriteStream on: (String new: 10000)].
	sendBuffer nextPutAll: aMorphicEvent storeString; cr.
	self lastEventTransmitted: aMorphicEvent.

	sendSocket isConnected ifTrue:[
		sendState = #opening ifTrue: [
			"connection established; disable TCP delays on sends"
			sendSocket setOption: 'TCP_NODELAY' value: true.
			"send worldExtent as first event"
			firstEvt _ MorphicUnknownEvent type: #worldBounds argument: self worldBounds extent.
			sendSocket sendData: firstEvt storeString, (String with: Character cr).
			Transcript
				show: 'Connection established with remote WorldMorph at ';
				show: (NetNameResolver stringFromAddress: sendSocket remoteAddress); cr.
			sendState _ #connected].
		sendSocket sendData: sendBuffer contents.
	] ifFalse: [
		owner primaryHand removeEventListener: self.
		sendState = #connected ifTrue: [
			"other end has closed; close our end"
			Transcript
				show: 'Closing connection with remote WorldMorph at ';
				show: (NetNameResolver stringFromAddress: sendSocket remoteAddress); cr.
			sendSocket close.
		sendState _ #closing]].

	sendBuffer reset.
! !


!RemoteHandMorph methodsFor: 'events-processing' stamp: 'ar 10/26/2000 01:12'!
handleListenEvent: anEvent
	"Transmit the event to interested listeners"
	| currentExtent |
	currentExtent _ self worldBounds extent.
	self lastWorldExtent ~= currentExtent ifTrue: [
		self transmitEvent: (MorphicUnknownEvent new setType: #worldExtent argument: currentExtent).
		self lastWorldExtent: currentExtent].
	self transmitEvent: anEvent.! !


!RemoteHandMorph methodsFor: 'geometry' stamp: 'jm 11/4/97 07:15'!
worldBounds

	^ 0@0 extent: remoteWorldExtent
! !


!RemoteHandMorph methodsFor: 'initialization' stamp: 'ar 10/24/2000 14:38'!
initialize

	super initialize.
	remoteWorldExtent _ 100@100.  "initial guess"
	socket _ nil.
	waitingForConnection _ false.
	receiveBuffer _ ''.
	sendState _ #unconnected.! !


!RemoteHandMorph methodsFor: 'other' stamp: 'ar 10/24/2000 14:34'!
withdrawFromWorld
	"Close the socket, if any, and remove this hand from the world."
	| addr |
	addr _ self remoteHostAddress.
	addr = 0 ifFalse: [self stopTransmittingEvents].
	self stopListening.
	Transcript show: 'Remote hand ', self userInitials, ' closed'; cr.
	owner ifNotNil: [owner removeHand: self].
! !


!RemoteHandMorph methodsFor: 'private' stamp: 'jm 11/4/97 07:15'!
appendNewDataToReceiveBuffer
	"Append all available raw data to my receive buffer. Assume that my socket is not nil."

	| newData tempBuf bytesRead |
	socket dataAvailable ifTrue: [
		"get all the data currently available"
		newData _ WriteStream on: (String new: receiveBuffer size + 1000).
		newData nextPutAll: receiveBuffer.
		tempBuf _ String new: 1000.
		[socket dataAvailable] whileTrue: [
			bytesRead _ socket receiveDataInto: tempBuf.
			1 to: bytesRead do: [:i | newData nextPut: (tempBuf at: i)]].
		receiveBuffer _ newData contents].
! !

!RemoteHandMorph methodsFor: 'private' stamp: 'ar 10/26/2000 01:55'!
getNextRemoteEvent
	"Return the next remote event, or nil if the receive buffer does not contain a full event record. An event record is the storeString for a MorphicEvent terminated by a <CR> character."

	| i s evt |
	self receiveData.
	receiveBuffer isEmpty ifTrue: [^ nil].

	i _ receiveBuffer indexOf: Character cr ifAbsent: [^ nil].
	s _ receiveBuffer copyFrom: 1 to: i - 1.
	receiveBuffer _ receiveBuffer copyFrom: i + 1 to: receiveBuffer size.
	evt _ (MorphicEvent readFromString: s).
	evt ifNil:[^nil].
	evt setHand: self.
	evt isKeyboard ifTrue:[evt setPosition: self position].
	^evt resetHandlerFields! !

!RemoteHandMorph methodsFor: 'private' stamp: 'jm 11/4/97 07:15'!
receiveData
	"Check my connection status and withdraw from the world if the connection has been broken. Append any data that has arrived to receiveBuffer. "

	socket ifNotNil: [
		socket isConnected
			ifTrue: [  "connected"
				waitingForConnection ifTrue: [
					Transcript show: 'Remote hand ', userInitials, ' connected'; cr.
					waitingForConnection _ false].
				self appendNewDataToReceiveBuffer]
			ifFalse: [  "not connected"
				waitingForConnection ifFalse: [
					"connection was established, then broken"
					self withdrawFromWorld.
					receiveBuffer _ '']]].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RemoteHandMorph class
	instanceVariableNames: ''!

!RemoteHandMorph class methodsFor: 'utilities' stamp: 'mir 11/14/2002 17:37'!
ensureNetworkConnected
	"Try to ensure that an intermittent network connection, such as a dialup or ISDN line, is actually connected. This is necessary to make sure a server is visible in order to accept an incoming connection."
	"RemoteHandMorph ensureNetworkConnected"

	Utilities
		informUser: 'Contacting domain name server...'
		during: [
			NetNameResolver
				addressForName: 'squeak.org'
				timeout: 30].
! !
Object subclass: #RemoteString
	instanceVariableNames: 'sourceFileNumber filePositionHi'
	classVariableNames: 'CurrentTextAttStructure CurrentTextAttVersion TextAttributeStructureVersions'
	poolDictionaries: ''
	category: 'Files-System'!
!RemoteString commentStamp: '<historical>' prior: 0!
My instances provide an external file reference to a piece of text.  It may be the sourceCode of a method, or the class comments of a class.

The changes file or file-in file usually has a chunk that is just the source string of a method:

max: aNumber
	^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!!

I can return either a String or a Text.  Some a chunk is followed by a second chunk (beginning with ]style[) containing style information.  The encoding is like this:

max: aNumber
	^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!!
]style[(14 50 312)f1,f1b,f1LInteger +;i!!

Allowed TextAttributes are TextFontChange, TextEmphasis, TextColor, TextDoIt, TextKern, TextLink, TextURL.  TextFontReference and TextAnchor are not supported.

See PositionableStream nextChunkText and RunArray class scanFrom:.!
]style[(748 32 5 24 1)f1,f1LPositionableStream nextChunkText;,f1,f1LRunArray class scanFrom:;,f1!


!RemoteString methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:32'!
fileStream 
	"Answer the file stream with position set at the beginning of my string"

	| theFile |
	(sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^ nil].
	theFile := SourceFiles at: sourceFileNumber.
	theFile position: filePositionHi.
	^ theFile! !

!RemoteString methodsFor: 'accessing' stamp: 'nk 11/26/2002 12:05'!
last
	^self string ifNotNilDo: [ :s | s last ]! !

!RemoteString methodsFor: 'accessing'!
position 
	"Answer the location of the string on a file."

	^ filePositionHi! !

!RemoteString methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'!
setSourcePointer: aSourcePointer
	sourceFileNumber := SourceFiles fileIndexFromSourcePointer: aSourcePointer.
	filePositionHi := SourceFiles filePositionFromSourcePointer: aSourcePointer! !

!RemoteString methodsFor: 'accessing'!
sourceFileNumber
	"Answer the index of the file on which the string is stored."

	^sourceFileNumber! !

!RemoteString methodsFor: 'accessing' stamp: 'hmm 4/26/2000 20:47'!
sourcePointer
	sourceFileNumber ifNil: [^ 0].
	^SourceFiles sourcePointerFromFileIndex: sourceFileNumber andPosition: filePositionHi! !

!RemoteString methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'!
string 
	"Answer the receiver's string if remote files are enabled."
	| theFile |
	(sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^''].
	theFile := SourceFiles at: sourceFileNumber.
	theFile position: filePositionHi.
	^ theFile nextChunk! !

!RemoteString methodsFor: 'accessing' stamp: 'ls 9/4/2003 12:37'!
text 
	"Answer the receiver's string asText if remote files are enabled."
	| theFile |
	(sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^ nil].
	theFile _ SourceFiles at: sourceFileNumber.
	theFile position: filePositionHi.
	theFile position > theFile size ifTrue: [
		self error: 'RemoteString past end of file' ].
	^ theFile nextChunkText! !


!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
checkSum: aString
	"Construct a checksum of the string.  A three byte number represented as Base64 characters."

| sum shift bytes ss bb |
sum := aString size.
shift := 0.
aString do: [:char |
	(shift := shift + 7) > 16 ifTrue: [shift := shift - 17].
		"shift by 7 to keep a change of adjacent chars from xoring to same value"
	sum := sum bitXor: (char asInteger bitShift: shift)].
bytes := ByteArray new: 3.
sum := sum + 16r10000000000.
1 to: 3 do: [:ind | bytes at: ind put: (sum digitAt: ind)].
ss := ReadWriteStream on: (ByteArray new: 3).
ss nextPutAll: bytes.
bb := Base64MimeConverter mimeEncode: ss.
^ bb contents! !

!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:32'!
fileNumber: fileNumber position: position 

	sourceFileNumber := fileNumber.
	filePositionHi := position! !

!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
makeNewTextAttVersion
	"Create a new TextAttributes version because some inst var has changed.  If no change, don't make a new one."
	"Don't delete this method even though it has no callers!!!!!!!!!!"

| obj cls struct tag |
"Note that TextFontReference and TextAnchor are forbidden."
obj := #(RunArray TextDoIt TextLink TextURL TextColor TextEmphasis TextFontChange TextKern TextLinkToImplementors 3 'a string') collect: [:each | 
		cls := Smalltalk at: each ifAbsent: [nil].
		cls ifNil: [each] ifNotNil: [cls new]].
struct := (SmartRefStream on: (RWBinaryOrTextStream on: String new)) instVarInfo: obj.
tag := self checkSum: struct printString.
TextAttributeStructureVersions ifNil: [TextAttributeStructureVersions := Dictionary new].
(struct = CurrentTextAttStructure) & (tag = CurrentTextAttVersion) 
	ifTrue: [^ false].
CurrentTextAttStructure := struct.
CurrentTextAttVersion := tag.
TextAttributeStructureVersions at: tag put: struct.
^ true! !

!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:32'!
string: aString onFileNumber: fileNumber
	"Store this as my string if source files exist."
	| theFile |
	(SourceFiles at: fileNumber) == nil ifFalse: 
		[theFile := SourceFiles at: fileNumber.
		theFile setToEnd; cr.
		self string: aString onFileNumber: fileNumber toFile: theFile]! !

!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
string: aStringOrText onFileNumber: fileNumber toFile: aFileStream 
	"Store this as the receiver's text if source files exist. If aStringOrText is a Text, store a marker with the string part, and then store the runs of TextAttributes in the next chunk."

	| position |
	position := aFileStream position.
	self fileNumber: fileNumber position: position.
	aFileStream nextChunkPutWithStyle: aStringOrText
	"^ self		(important)"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RemoteString class
	instanceVariableNames: ''!

!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:46'!
currentTextAttVersion
	"The current configuration of the TextAttributes classes has a structures array describing the inst vars of the classes (SmartRefStream instVarInfo:).  Return tag that indexes the TextAttributeStructureVersions dictionary (4 random characters)."

	^ CurrentTextAttVersion
	"Be sure to run makeNewTextAttVersion when any TextAttributes class changes inst vars"! !

!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/11/97 10:35'!
initialize
	"Derive the current TextAttributes classes object structure"

	self new makeNewTextAttVersion! !

!RemoteString class methodsFor: 'as yet unclassified'!
newFileNumber: sourceIndex position: anInteger 
	"Answer an instance of me fora file indexed by sourceIndex, at the 
	position anInteger. Assume that the string is already stored on the file 
	and the instance will be used to access it."

	^self new fileNumber: sourceIndex position: anInteger! !

!RemoteString class methodsFor: 'as yet unclassified'!
newString: aString onFileNumber: sourceIndex 
	"Answer an instance of me for string, aString, on file indexed by 
	sourceIndex. Put the string on the file and create the remote reference."

	^self new string: aString onFileNumber: sourceIndex! !

!RemoteString class methodsFor: 'as yet unclassified'!
newString: aString onFileNumber: sourceIndex toFile: aFileStream
	"Answer an instance of me for string, aString, on file indexed by 
	sourceIndex. Put the string on the file, aFileStream, and create the 
	remote reference. Assume that the index corresponds properly to 
	aFileStream."

	^self new string: aString onFileNumber: sourceIndex toFile: aFileStream! !

!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/13/97 13:36'!
structureAt: styleVersion

	^ TextAttributeStructureVersions at: styleVersion ifAbsent: [nil]! !
AbstractEvent subclass: #RemovedEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!RemovedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'!
printEventKindOn: aStream

	aStream nextPutAll: 'Removed'! !


!RemovedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'!
isRemoved

	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RemovedEvent class
	instanceVariableNames: ''!

!RemovedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'!
changeKind

	^#Removed! !

!RemovedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:28'!
supportedKinds
	"All the kinds of items that this event can take."
	
	^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! !
AbstractEvent subclass: #RenamedEvent
	instanceVariableNames: 'newName oldName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!RenamedEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:18'!
newName
	^ newName! !

!RenamedEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:18'!
newName: aName

	newName := aName! !

!RenamedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 12:00'!
oldName

	^oldName! !

!RenamedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 12:01'!
oldName: aName

	oldName := aName! !


!RenamedEvent methodsFor: 'printing' stamp: 'rw 7/1/2003 11:34'!
printEventKindOn: aStream

	aStream nextPutAll: 'Renamed'! !


!RenamedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:34'!
isRenamed

	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RenamedEvent class
	instanceVariableNames: ''!

!RenamedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'!
changeKind

	^#Renamed! !

!RenamedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:30'!
supportedKinds
	"All the kinds of items that this event can take."
	
	^ Array with: self classKind with: self categoryKind with: self protocolKind! !


!RenamedEvent class methodsFor: 'instance creation' stamp: 'ab 2/10/2005 16:49'!
classCategoryRenamedFrom: anOldClassCategoryName to: aNewClassCategoryName

	^(self classCategory: anOldClassCategoryName) oldName: anOldClassCategoryName; newName: aNewClassCategoryName! !

!RenamedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 12:19'!
class: aClass category: cat oldName: oldName newName: newName

	^(self class: aClass category: cat) oldName: oldName; newName: newName! !
AbstractEvent subclass: #ReorganizedEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!ReorganizedEvent methodsFor: 'printing' stamp: 'NS 1/27/2004 12:44'!
printEventKindOn: aStream

	aStream nextPutAll: 'Reorganized'! !


!ReorganizedEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'!
isReorganized
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ReorganizedEvent class
	instanceVariableNames: ''!

!ReorganizedEvent class methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:46'!
changeKind

	^#Reorganized! !

!ReorganizedEvent class methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:46'!
supportedKinds

	^Array with: self classKind! !
AbstractSound subclass: #RepeatingSound
	instanceVariableNames: 'sound iterationCount iteration samplesPerIteration'
	classVariableNames: 'CarMotorSamples'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!RepeatingSound methodsFor: 'accessing' stamp: 'jm 11/17/97 18:48'!
iterationCount

	^ iterationCount
! !

!RepeatingSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
iterationCount: aNumber

	iterationCount := aNumber.
! !

!RepeatingSound methodsFor: 'accessing' stamp: 'jm 11/17/97 18:48'!
sound

	^ sound
! !

!RepeatingSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
sound: aSound

	sound := aSound.
! !


!RepeatingSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:13'!
copy
	"Copy my component sound."

	^ super copy copySound
! !

!RepeatingSound methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:41'!
copySound
	"Private!! Support for copying. Copy my component sound."

	sound := sound copy.
! !


!RepeatingSound methodsFor: 'initialization' stamp: 'jm 9/12/97 15:54'!
setPitch: p dur: d loudness: l

	self error: 'RepeatingSounds do not support playing notes'.
! !

!RepeatingSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setSound: aSound iterations: anIntegerOrSymbol
	"Initialize the receiver to play the given sound the given number of times. If iteration count is the symbol #forever, then repeat indefinitely."
	"(RepeatingSound repeat: AbstractSound scaleTest count: 2) play"
	"(RepeatingSound repeatForever: PluckedSound lowMajorScale) play"

	super initialize.
	sound := aSound.
	iterationCount := anIntegerOrSymbol.
	self reset.
! !


!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:40'!
doControl

	super doControl.
	sound doControl.
! !

!RepeatingSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a collection of sounds in sequence."
	"(RepeatingSound new
		setSound: FMSound majorScale
		iterations: 2) play"

	| i count samplesNeeded |
	iteration <= 0 ifTrue: [^ self].
	i := startIndex.
	samplesNeeded := n.
	[samplesNeeded > 0] whileTrue: [
		count := sound samplesRemaining min: samplesNeeded.
		count = 0 ifTrue: [
			iterationCount == #forever
				ifFalse: [
					iteration := iteration - 1.
					iteration <= 0 ifTrue: [^ self]].  "done"
			sound reset.
			count := sound samplesRemaining min: samplesNeeded.
			count = 0 ifTrue: [^ self]].  "zero length sound"
		sound mixSampleCount: count
			into: aSoundBuffer
			startingAt: i
			leftVol: leftVol
			rightVol: rightVol.
		i := i + count.
		samplesNeeded := samplesNeeded - count].
! !

!RepeatingSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset

	super reset.
	sound reset.
	samplesPerIteration := sound samplesRemaining.
	iterationCount == #forever
		ifTrue: [iteration := 1]
		ifFalse: [iteration := iterationCount].
! !

!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 1/18/1999 10:31'!
samplesRemaining

	iterationCount == #forever ifTrue: [^ 1000000].
	iteration > 0
		ifTrue: [^ sound samplesRemaining + ((iteration - 1) * samplesPerIteration)]
		ifFalse: [^ 0].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RepeatingSound class
	instanceVariableNames: ''!

!RepeatingSound class methodsFor: 'car motor example' stamp: 'jm 1/29/1999 10:01'!
carMotorSound
	"Return a repeating sound for the sound of a car engine."
	"RepeatingSound carMotorSound play"

	^ self carMotorSound: 10.0! !

!RepeatingSound class methodsFor: 'car motor example' stamp: 'jm 1/29/1999 09:32'!
carMotorSound: speed
	"Return a repeating sound for the sound of a car engine running at the given speed."
	"(RepeatingSound carMotorSound: 2.0) play"

	CarMotorSamples ifNil: [self initializeCarMotor].
	^ RepeatingSound repeatForever:
		((LoopedSampledSound
			unloopedSamples: CarMotorSamples
			pitch: 20.0
			samplingRate: 22050)
				setPitch: speed dur: 100.0 loudness: 1.0)
! !

!RepeatingSound class methodsFor: 'car motor example' stamp: 'stephaneducasse 2/4/2006 20:41'!
initializeCarMotor
	"Initialize the samples array for the sound of a car engine."

	CarMotorSamples := SoundBuffer fromArray: #(
36 199 190 508 332 167 253 302 788 884 1233 1145 977 904 991 1371 1361 1495 1253 1346 1696 1454 1631 1784 1752 1826 1389 1234 1202 1152 1188 1000 1048 898 724 937 1145 1537 2023 2079 2371 2156 2098 1855 1843 2208 2126 2218 1664 1457 1389 1454 1481 1458 1661 1400 1548 1499 1949 2055 2130 2220 2038 1904 1750 1993 2114 2272 2418 2101 1976 1791 2161 2690 2958 3013 2888 2798 2792 2875 3207 3627 3732 3842 3791 3836 3964 4082 4351 4550 4755 4746 4851 5180 5507 6100 6491 6533 6133 5394 4627 3886 3133 2209 1073 -368 -1876 -3170 -4067 -4641 -4963 -5049 -4922 -4634 -4147 -3544 -2805 -1962 -1219 -592 -326 -374 -627 -901 -1075 -1159 -1252 -1312 -1444 -1397 -1338 -1142 -748 -541 -350 -314 -265 -143 52 464 653 927 1269 1617 2048 2365 2654 2924 3306 3669 3855 3799 3160 2372 1629 1289 1635 1841 1838 1557 987 630 557 857 1005 868 435 -309 -1083 -1765 -2025 -2055 -2219 -2388 -2409 -2438 -2314 -2002 -1687 -1477 -1533 -1641 -1878 -1885 -1776 -1580 -1005 -525 -164 -84 396 768 1160 1788 2219 2365 1836 1435 1097 988 1326 1423 2106 2191 1965 1829 1578 1835 1429 1570 1596 1301 1357 1233 1634 2386 2597 3037 3225 3406 3339 3049 2935 2611 2428 2340 2728 2621 2994 2599 2591 3010 3341 3922 3992 3824 2982 2128 1376 1455 1437 2022 1927 1730 1841 1832 2334 2942 3183 3124 3362 3342 3549 3322 3474 3686 4164 4550 4051 3701 2742 2656 3210 4011 4641 4416 3697 2998 3382 3715 3729 3687 3375 3521 3932 4273 4172 3970 3598 3675 4879 5887 6320 5794 4623 4179 4453 5626 6412 6353 5563 4689 4683 5058 5905 6270 6218 6134 5704 5297 4087 2627 1221 -181 -1351 -2616 -4341 -6598 -8702 -9888 -10087 -9286 -8357 -7568 -6878 -6063 -4839 -3540 -2281 -1176 -315 248 409 337 -353 -1326 -2135 -2392 -2324 -2288 -2486 -3272 -3618 -3573 -2804 -1503 -604 267 808 1389 2069 2643 3328 3964 4706 5502 6136 6163 5665 4956 4491 4507 4409 4042 3132 1996 998 330 -116 -475 -877 -1370 -1250 -1048 -851 -740 -1207 -1166 -1040 -395 405 441 342 -281 -763 -799 -774 -447 -319 -190 -120 115 182 91 207 387 959 1462 1811 1767 1335 972 730 979 1157 1338 1347 807 591 232 417 696 664 1406 1512 2065 2416 2374 2539 2395 2483 2677 2674 2585 2299 1134 320 -336 -65 676 743 538 16 -374 -515 138 463 1043 1533 1786 2332 2258 2566 2663 2961 3599 3498 3518 2952 2309 2045 1667 1571 1504 1213 1118 1029 874 843 710 977 1377 1816 2236 2114 1989 1698 1618 1672 1682 1602 1382 1044 689 364 55 -24 4 322 669 948 1148 1193 1280 1463 1873 2261 2578 2654 2543 2312 1976 1772 1738 1763 1855 1834 1664 1469 1312 1399 1484 1732 1880 2004 2124 2090 2056 2000 2048 2227 2464 2670 2721 2511 2234 2056 2081 2263 2522 2737 2768 2728 2693 2711 2768 2891 3068 3182 3126 2913 2545 2171 1950 1820 1765 1710 1538 1319 1020 764 600 538 607 742 808 710 517 307 162 62 17 -8 -205 -486 -858 -1288 -1581 -1720 -1795 -1834 -1863 -1906 -1966 -1895 -1855 -1651 -1350 -1049 -721 -464 -265 -65 75 189 306 412 472 458 374 222 113 101 178 309 481 568 576 516 497 582 724 844 964 914 774 662 509 472 576 610 572 554 517 605 785 1008 1312 1555 1786 1957 2044 2081 2118 2193 2264 2328 2335 2277 2205 2098 2002 1981 1982 2017 1972 1912 1788 1611 1519 1428 1393 1367 1209 1045 842 624 564 509 465 398 172 11 -157 -264 -259 -269 -248 -249 -222 -266 -355 -372 -288 -158 -55 1 71 91 102 228 420 619 798 829 930 1012 1047 1210 1359 1531 1676 1702 1787 1809 1729 1668 1653 1721 1808 1793 1747 1616 1485 1476 1516 1751 1961 2029 2057 2006 1955 1893 1904 1960 1967 1975 1934 1827 1814 1749 1809 1947 2037 2098 2067 1970 1754 1627 1667 1759 1904 1890 1819 1747 1644 1698 1746 1834 1959 1922 1887 1864 1712 1734 1770 1895 2029 2062 2153 2132 2203 2206 2202 2194 2075 2019 1889 1923 1930 2090 2250 2335 2372 2209 2085 1902 1805 1826 1843 1804 1761 1605 1580 1680 1713 1825 1904 2097 2269 2373 2384 2235 2351 2445 2530 2610 2560 2618 2511 2445 2374 2111 1959 1760 1602 1474 1208 1021 786 688 654 573 526 409 452 566 694 746 831 914 1008 1043 821 513 214 -45 -242 -453 -723 -898 -1103 -1078 -1081 -1087 -1015 -1073 -869 -884 -720 -555 -329 -24 -63 14 -96 5 260 412 636 623 611 785 788 1001 1025 989 1162 1215 1404 1408 1305 1311 1120 1076 956 785 740 371 389 164 202 522 478 770 483 259 250 79 497 987 1288 1453 1283 1350 1436 1441 1804 1861 2059 2156 1969 2142 2148 2384 2652 2470 2383 1883 1739 1618 1475 1523 1134 1167 1031 816 674 274 251 162 301 387 23 -176 -345 -333 -198 -356 -363 -444 -421 -192 -226 -230 -239 -326 10 106 195 132 95 202 79 -68 -222 -45 429 788 954 1256 1426 1521 1704 1729 2053 1867 1581 1434 1367 1554 1386 1221 1165 1253 1571 1394 1425 1390 948 1288 999 1421 1568 1292 1478 1019 1053 591 693 520 302 314 116 847 1340 1792 1883 1582 1474 1821 2140 2486 2651 2167 1728 1380 1345 1811 1993 2052 2325 2231 2148 2271 2450 2831 2866 2908 2721 2623 2252 2025 2393 2667 3015 2817 2668 2588 2540 2736 2761 3275 3232 3252 3168 3112 3284 3138 3458 3716 3876 3928 3824 3928 4040 4330 4923 5226 5205 5183 5172 5510 5926 6225 6306 6020 5433 4448 3261 2118 959 -239 -1741 -3208 -4507 -5623 -6134 -6133 -5617 -4931 -4192 -3378 -2817 -2219 -1588 -817 -110 199 281 -5 -417 -652 -749 -679 -890 -1261 -1549 -1905 -1928 -2002 -1885 -1552 -1185 -655 -235 222 793 1424 1992 2599 2940 3081 2982 2695 2667 2771 2919 2980 2662 2146 1537 1215 1217 1374 1337 1061 790 376 250 -97 -111 5 -149 -243 -733 -936 -1395 -1810 -1781 -1762 -1500 -1716 -2039 -2318 -2398 -1907 -1592 -1422 -1900 -2619 -3034 -3024 -2335 -1429 -557 323 1051 1587 2021 2282 2438 2207 1843 1789 1482 1392 1056 742 1220 1294 1464 1641 1731 1847 1291 1682 1970 2097 2253 1624 1474 1312 1312 1873 2315 2523 2486 2323 2385 2924 3638 4341 4431 4045 3644 2945 2939 2935 2867 3411 2886 2731 2211 1405 1001 640 1077 1430 1688 1803 1857 2036 2447 3394 3628 3702 3468 3361 3782 3668 3672 4050 3895 4188 4564 4217 3965 2693 1946 1878 2245 3152 3267 3120 2670 2675 3308 4567 5358 5556 5114 3953 3653 3658 4111 4688 4262 3819 3732 4224 4771 5579 5622 5585 5613 5501 5593 5452 5570 5632 6094 5985 5579 4982 4206 3878 3683 3274 2172 698 -1224 -2821 -3890 -4742 -5518 -6463 -7297 -7730 -8054 -7991 -7508 -6683 -5163 -3562 -2162 -1401 -1000 -650 -255 344 643 475 -347 -1530 -2545 -3189 -3506 -3525 -3563 -3239 -2710 -1975 -1174 -649 117 1250 2603 3929 4750 4920 4876 4692 4897 5263 5455 5008 4285 3535 2650 2480 2198 1908 1831 1412 1060 602 80 -281 -245 -37 518 694 559 449 134 264 395 501 454 294 14 -188 -258 -603 -471 -526 -212 202 413 643 447 674 1151 2015 2779 2830 2783 2349 2213 2223 1805 1467 750 640 762 709 685 202 48 360 1103 1707 1935 1604 992 986 883 1293 1285 840 880 25 72 -201 -568 -194 -266 416 698 748 1106 930 1391 2268 2672 3350 3207 3010 3183 2888 3077 3048 2737 2684 2102 1594 1047 146 -39 -397 -420 -237 -520 -465 -526 -247 398 929 1605 2176 2568 2979 3102 3165 3206 3205 3315 3167 2841 2330 1660 1172 909 881 992 1021 1063 1098 1184 1407 1681 1927 2245 2498 2652 2755 2740 2720 2600 2599 2547 2529 2425 2327 2216 1983 1798 1578 1501 1596 1707 1778 1775 1794 1832 1945 2157 2368 2534 2679 2726 2647 2546 2482 2500 2613 2715 2858 2909 2875 2798 2847 3002 3238 3544 3763 3906 3870 3762 3684 3570 3510 3375 3115 2665 2099 1534 1114 848 744 650 462 329 147 161 282 430 614 681 701 635 505 263 -31 -284 -523 -787 -1040 -1310 -1530 -1694 -1726 -1660 -1541 -1319 -1101 -872 -661 -468 -289 -53 235 439 581 607 542 488 496 442 476 539 528 480 404 353 383 409 514 643 801 911 1039 1099 1060 1002 1008 1079 1079 1088 1043 998 953 947 1077 1232 1417 1630 1737 1807 1861 1947 2139 2352 2521 2494 2388 2251 2163 2142 2183 2246 2312 2333 2215 2167 2080 1954 1856 1767 1725 1685 1560 1366 1157 915 754 677 570 434 268 50 -48 -106 -80 23 -6 3 -105 -143 -106 -86 -10 15 72 129 151 224 269 377 540 615 755 802 841 986 1126 1263 1430 1501 1565 1592 1629 1704 1769 1780 1815 1868 1875 1853 1767 1657 1676 1777 1954 2063 2033 2006 1997 2052 2132 2218 2192 2163 2068 1935 1832 1731 1692 1644 1603 1587 1656 1704 1735 1707 1693 1778 1855 1886 1808 1854 1866 2020 2082 2051 2063 1922 1994 2055 1979 1867 1654 1725 1958 2103 2250 2210 2181 2136 1990 1769 1538 1555 1690 1847 1927 1833 1861 1845 1916 1901 1878 1827 1965 2079 2011 1813 1442 1294 1314 1438 1527 1471 1351 1346 1433 1541 1742 1882 2055 2187 2137 2094 2026 2216 2547 2788 2910 2700 2476 2276 2271 2219 2140 2106 1948 1839 1563 1271 991 871 785 695 490 237 93 101 302 452 541 637 735 773 731 667 554 479 381 262 -30 -313 -571 -871 -940 -1094 -1156 -946 -946 -789 -822 -1016 -846 -729 -380 -130 -174 -291 -393 -459 -370 -385 -488 -235 -189 -29 66 20 251 506 931 1376 1399 1348 1192 940 1022 839 916 1173 1247 1303 1207 950 888 944 1151 1385 1216 1012 762 741 964 995 1072 1129 1201 1243 1189 1214 1209 1090 1188 1226 962 840 480 309 201 8 -27 -108 19 120 122 175 188 247 298 326 490 659 638 530 299 294 391 561 749 632 677 592 520 445 175 452 195 476 279 54 216 -444 -153 -497 -42 65 -76 89 -307 613 424 736 729 692 1203 923 1051 761 782 993 912 1361 971 671 640 713 1230 870 821 292 243 774 1172 1686 1286 1348 1303 1523 1622 1578 1833 1810 1913 1658 1535 1352 1375 1673 2156 2537 2408 2275 2078 2090 2117 2030 2120 2227 2296 2388 2667 2966 3152 3134 2987 2799 2665 2686 2666 2584 2637 2572 2631 2836 3106 3325 3066 2882 2869 3046 3325 3369 3339 3398 3350 3293 3457 3587 3759 3999 4191 4413 4437 4477 4519 4628 4905 5061 5239 5014 4922 5179 5616 6008 6053 5515 4650 3634 2615 2101 1403 430 -981 -2592 -4097 -5331 -6002 -6365 -6339 -5996 -5552 -4825 -4058 -3378 -2538 -1678 -858 -70 377 250 -342 -1019 -1354 -1355 -1196 -1361 -1521 -1624 -1862 -1561 -1109 -638 -510 -705 -845 -1026 -585 -35 768 1668 2308 2850 3002 3103 3216 3453 3876 4335 4501 4065 3249 2233 1669 1518 1717 1688 1115 370 -493 -662 -599 -225 85 -153 -466 -954 -1270 -1132 -935 -978 -1481 -2039 -2683 -3353 -3678 -3673 -3362 -2780 -2386 -2281 -2137 -2034 -1498 -801 -239 351 480 608 886 1176 1592 1788 2106 2205 2010 1893 1582 1539 1597 1795 1990 2158 2092 1255 800 1029 1404 1884 2085 1537 1103 919 870 2111 3220 3367 3480 2671 2319 2914 3620 4073 3498 2841 2067 1810 2225 2669 3168 2603 1347 499 729 1563 2063 1953 1175 432 458 1393 2521 3149 3279 2822 2467 2697 3005 3756 4386 4418 4555 3662 3241 3320 3520 3914 4087 3923 2896 2532 1732 1807 2221 2972 3933 3101 2464 1657 1615 2639 3948 4718 5026 4305 3909 3815 3811 4014 3853 4090 4153 4670 4783 4527 4113 4296 4866 5695 6258 6024 5748 5089 5020 5101 4974 4353 3499 2056 779 -738 -2628 -4028 -5515 -6213 -6815 -7376 -7953 -8558 -8565 -7680 -6158 -4573 -3152 -2390 -1579 -792 -128 414 470 360 165 -390 -1164 -2225 -3460 -4085 -4255 -3862 -3277 -2975 -2731 -2390 -1656 -387 1008 2146 3014 3428 3832 4526 4822 4875 4472 3941 3954 3945 3710 2856 1848 931 619 1054 1206 877 318 -270 -412 34 160 399 532 402 655 568 472 246 -92 356 716 776 540 -331 -730 -548 -242 338 202 -72 4 -6 637 885 1005 1330 1619 2174 2350 2069 1709 1412 1476 1747 1558 1230 711 321 398 293 313 92 81 454 659 806 581 346 351 585 870 851 436 -76 -479 -756 -907 -1190 -1414 -1586 -1628 -1483 -1389 -1238 -816 -177 556 1249 1735 2074 2385 2710 3065 3264 3285 3143 2928 2692 2297 1832 1387 1022 955 1088 1101 1028 872 870 1090 1475 1976 2316 2578 2716 2705 2557 2467 2367 2328 2364 2301 2073 1686 1366 1175 1116 1199 1196 1109 962 920 934 983 1051 1258 1536 1752 1836 1770 1680 1643 1800 1954 2082 2111 1986 1885 1813 1824 1898 2088 2236 2353 2399 2340 2255 2213 2244 2350 2365 2326 2266 2154 2072 2068 2093 2130 2223 2295 2394 2515 2449 2426 2527 2778 3021 3240 3286 3216 3108 3004 3042 3106 3147 2990 2690 2282 1902 1641 1457 1359 1172 825 473 189 106 166 377 569 634 551 403 364 415 437 366 107 -242 -524 -723 -824 -959 -1100 -1264 -1381 -1408 -1252 -1072 -932 -889 -819 -581 -341 -107 56 128 156 158 185 260 284 270 324 376 391 423 449 446 429 521 569 566 584 546 589 624 594 594 584 607 725 876 976 1004 1046 1082 1193 1341 1372 1434 1446 1409 1528 1618 1747 1911 1985 2090 2092 2110 2170 2230 2360 2411 2433 2402 2317 2280 2227 2126 2017 1878 1729 1564 1406 1237 1073 957 906 841 788 706 548 437 429 449 554 653 664 582 500 486 511 519 430 339 318 294 287 265 288 299 429 605 681 822 808 887 950 1042 1240 1348 1547 1638 1752 1787 1765 1864 1949 2025 2058 1990 1921 1818 1707 1755 1810 2007 2069 2017 1840 1623 1633 1646 1803 1962 2002 1985 1838 1694 1588 1493 1551 1685 1756 1784 1604 1458 1532 1660 1898 1986 1737 1551 1457 1665 1890 2078 2066 2082 2181 2156 2167 2174 2290 2341 2314 2302 2134 2114 2054 2020 2109 1974 1916 1841 1628 1718 1718 1860 1951 1774 1893 1745 1701 1769 1541 1733 1542 1509 1547 1370 1640 1572 1480 1679 1501 1747 1697 1748 1973 1763 1949 1795 2000 2185 2249 2600 2532 2713 2672 2558 2572 2506 2691 2760 2797 2680 2299 1992 1796 1558 1444 1055 663 489 6 -197 -508 -713 -632 -763 -579 -532 -472 -253 -174 -66 75 -39 72 208 312 339 87 16 -170 -198 -166 -227 -270 -498 -495 -406 -544 -569 -766 -656 -500 -344 -121 -161 -67 -60 97 96 47 31 -76 163 173 417 465 257 332 5 48 -14 -135 124 -51 17 -190 -361 -127 -23 352 410 491 632 489 608 746 1100 1463 1473 1668 1380 1289 1319 1575 1979 1935 1824 1385 1265 1351 1528 1675 1429 1018 548 133 -254 -466 -736 -796 -815 -994 -916 -948 -584 -366 -196 -132 -119 -108 -165 12 -235 -107 -353 -349 -579 -765 -953 -1235 -888 -764 -286 -769 -804 -787 -508 255 127 169 -177 -373 -111).
! !


!RepeatingSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 16:14'!
repeat: aSound count: anInteger
	"Return a RepeatingSound that will repeat the given sound for the given number of iterations."

	^ self new setSound: aSound iterations: anInteger
! !

!RepeatingSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 16:13'!
repeatForever: aSound
	"Return a RepeatingSound that will repeat the given sound forever."

	^ self new setSound: aSound iterations: #forever
! !
BasicRequestor subclass: #Requestor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base-Requestors'!
!Requestor commentStamp: 'rr 7/10/2006 15:19' prior: 0!
I am an implementation of BasicRequestor with some requests already implemented.!


!Requestor methodsFor: 'requests' stamp: 'rr 8/2/2005 14:53'!
getClass
	^Smalltalk at: self getSymbol! !

!Requestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:03'!
getClassCollection
	^ self getSymbolCollection collect: [:className | Smalltalk at: className]! !

!Requestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:07'!
getMethodBody
	| m |
	m := FillInTheBlankMorph new.
	m setQuery: 'Please enter the full body of the method you want to define' 
		initialAnswer:  self class sourceCodeTemplate
		answerExtent: 500@250
		acceptOnCR: false. 
	World addMorph: m centeredNear: World activeHand position.
	^ m getUserResponse.! !

!Requestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:15'!
getSelection
	"Sorry to feedle with fillInTheBlankMorph innards, but I had to"
	| text m |
	text := (MethodReference class: self getClass selector: self getSelector) sourceCode.
	m := FillInTheBlankMorph new.
	m setQuery: 'Highlight a part of the source code, and accept' initialAnswer: text
		answerExtent: 500@250
		acceptOnCR: true. 
	World addMorph: m centeredNear: World activeHand position.
	m getUserResponse.
	^ m selection! !


!Requestor methodsFor: 'services requests' stamp: 'rr 1/9/2006 11:59'!
getSelector
	^ self caption: 'enter selector'; getSymbol! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Requestor class
	instanceVariableNames: ''!

!Requestor class methodsFor: 'as yet unclassified' stamp: 'rr 3/23/2004 14:32'!
default
	"returns a default requestor"
	^ self new! !
CodeModelExtension subclass: #RequiredSelectors
	instanceVariableNames: 'dirty dirtyClasses newlyInterestingClasses'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Requires'!

!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/5/2005 13:37'!
calculateForClass: aClass 
	| rscc |
	rscc := RequiredSelectorsChangesCalculator onModificationOf: { aClass }
				withTargets: { aClass }.
	rscc doWork! !

!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/5/2005 14:21'!
for: aClass 
	"Somewhat weird control flow, and populates the dictionary even with non-interesting things, which it probably shouldn't"
	perClassCache at: aClass ifAbsentPut: [RequirementsCache new].
	(self haveInterestsIn: aClass) 
		ifTrue: [self ensureClean]
		ifFalse: [self calculateForClass: aClass].
	^(perClassCache at: aClass) requirements! !

!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/6/2005 15:40'!
lostInterest: client inAll: classes
	ProvidedSelectors current 
		lostInterest: self 
		inAll: (classes gather: [:cl | cl withAllSuperclasses]).
	LocalSends current 
		lostInterest: self 
		inAll: (classes gather: [:cl | cl withAllSuperclasses]).
	super lostInterest: client inAll: classes
! !

!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/14/2005 15:32'!
lostOneInterestIn: aClass
	self lostInterest: nil in: aClass.
! !

!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/6/2005 15:33'!
newCacheFor: aClass 
	^RequirementsCache new! !

!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/14/2005 17:02'!
noteInterestOf: client inAll: classes 
	| newlyInteresting |
	LocalSends current noteInterestOf: self
		inAll: (classes gather: [:cl | cl withAllSuperclasses]).
	ProvidedSelectors current noteInterestOf: self
		inAll: (classes gather: [:cl | cl withAllSuperclasses]).
	newlyInteresting _ classes copyWithoutAll: self classesOfInterest.
	super noteInterestOf: client inAll: classes.
	newlyInteresting do: [:cl | self newlyInteresting: cl]! !

!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/14/2005 16:50'!
registerLifelongInterestOf: client inAll: classes 
	self noteInterestOf: client inAll: classes.
	classes do: [:cl | client toFinalizeSend: #lostOneInterestIn: to: self with: cl].! !


!RequiredSelectors methodsFor: 'accessing' stamp: 'dvf 9/2/2005 14:22'!
dirtyClasses
	dirtyClasses ifNil: [dirtyClasses := WeakSet new].
	^dirtyClasses! !

!RequiredSelectors methodsFor: 'accessing' stamp: 'dvf 9/8/2005 18:46'!
newlyInterestingClasses
	newlyInterestingClasses ifNil: [newlyInterestingClasses _ IdentitySet new].
	^newlyInterestingClasses! !

!RequiredSelectors methodsFor: 'accessing' stamp: 'dvf 9/8/2005 18:41'!
newlyInterestingClasses: anObject
	newlyInterestingClasses := anObject! !


!RequiredSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/5/2005 14:21'!
classesOfInterest
	^interests asIdentitySet! !

!RequiredSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 14:22'!
dirtyWithChange: anEvent 
	dirty := true.
	self dirtyClasses add: anEvent itemClass! !

!RequiredSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 1/31/2006 23:38'!
ensureClean
	| rscc |
	dirty 
		ifTrue: 
			[rscc := RequiredSelectorsChangesCalculator 
						onModificationOf: self dirtyClasses
						withTargets: self classesOfInterest.
			rscc doWork.
			dirtyClasses := nil].
	dirty := false! !

!RequiredSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 20:05'!
newlyInteresting: aClass 
	dirty := true.
	self dirtyClasses add: aClass! !


!RequiredSelectors methodsFor: 'invalidation' stamp: 'dvf 1/31/2006 23:39'!
classChanged: modificationEvent 
	self dirtyWithChange: modificationEvent! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RequiredSelectors class
	instanceVariableNames: ''!
Object subclass: #RequiredSelectorsChangesCalculator
	instanceVariableNames: 'targetBehaviors classesToUpdate traitsToUpdate rootClasses modifiedBehaviors possiblyAffectedPerRoot originalSinsPerSelector targetClasses targetTraits'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Requires'!
!RequiredSelectorsChangesCalculator commentStamp: 'dvf 9/22/2005 14:20' prior: 0!
Nathanael implemented an efficient algorithm for updating the requirement status of a single selector for an inheritance subtree. However, the algorithm is not efficient enough to use as is for displaying abstractness of all the classes in a few class categories. 

To get to that performance level:
1. The RequiredSelectors class coordinates recalculation requests and tracks what classes have changed, and what classes are interesting. 
2. The current class handles a such request, by running the algorithm only on classes and selectors that may potentially be requirements.!


!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'!
classesToUpdate
	^classesToUpdate! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'!
classesToUpdate: anObject
	classesToUpdate := anObject! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 9/1/2005 20:44'!
modifiedBehaviors
	^modifiedBehaviors! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 9/1/2005 20:44'!
modifiedBehaviors: anObject 
	modifiedBehaviors := anObject! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'!
rootClasses
	^rootClasses! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'!
rootClasses: anObject
	rootClasses := anObject! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 15:58'!
targetBehaviors
	^targetBehaviors! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 15:58'!
targetBehaviors: anObject
	targetBehaviors := anObject! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'!
traitsToUpdate
	^traitsToUpdate! !

!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'!
traitsToUpdate: anObject
	traitsToUpdate := anObject! !


!RequiredSelectorsChangesCalculator methodsFor: 'as yet unclassified' stamp: 'dvf 9/9/2005 19:25'!
addUpdatePathTo: aClass from: highRoot 
	aClass withAllSuperclassesDo: [:sc | classesToUpdate add: sc. highRoot = sc ifTrue: [^self]]! !

!RequiredSelectorsChangesCalculator methodsFor: 'as yet unclassified' stamp: 'dvf 9/9/2005 18:49'!
sinsIn: aClass 
	| negativeDefined selfSent sins |
	negativeDefined := IdentitySet new.
	aClass selectorsAndMethodsDo: [:s :m | m isProvided ifFalse: [negativeDefined add: s]].
	selfSent := aClass sendCaches selfSenders ifNil: [^negativeDefined] ifNotNilDo: [:dict | dict keys].
	sins := negativeDefined union: (selfSent copyWithoutAll: aClass providedSelectors).
	^sins! !


!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 19:23'!
decideParameters
	"decide whos who"

	targetClasses := IdentitySet new.
	targetTraits := IdentitySet new.
	self targetBehaviors 
		do: [:b | b isTrait ifTrue: [targetTraits add: b] ifFalse: [targetClasses add: b]].
	self findAffectedTraitsFrom: targetTraits.
	self findRootsAndRoutes.
	self findOriginalSins! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 20:27'!
doWork
	| requiredSelectorsByClass oldRequiredSelectorsByClass classWithOldRequirementsRecorded rootsHandledBySel rootsHandled |
	requiredSelectorsByClass := IdentityDictionary new.
	oldRequiredSelectorsByClass := IdentityDictionary new.
	classWithOldRequirementsRecorded := IdentitySet new.
	rootsHandledBySel := IdentityDictionary new.
	originalSinsPerSelector keysAndValuesDo: 
			[:selector :sinners | 
			rootsHandled := rootsHandledBySel at: selector put: IdentitySet new.
			rootClasses do: 
					[:rc | 
					(self shouldProcess: rc forSinsIn: sinners) 
						ifTrue: 
							[rootsHandled add: rc.
							self 
								storeOldRequirementsUnder: rc
								into: oldRequiredSelectorsByClass
								ignoreSet: classWithOldRequirementsRecorded.
							self 
								storeRequirementsUnder: rc
								for: selector
								in: requiredSelectorsByClass]]].
	self 
		removeRequirements: oldRequiredSelectorsByClass
		thatAreNotIn: requiredSelectorsByClass
		ifIn: rootsHandledBySel.
	self setFoundRequirements: requiredSelectorsByClass! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'al 2/17/2006 08:54'!
findAffectedTraitsFrom: targetTraitsCollection
	traitsToUpdate := targetTraitsCollection 
				select: [:t | modifiedBehaviors anySatisfy: [:mb | t traitCompositionIncludes: mb]]! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 20:48'!
findOriginalSins
	| sinnedSelectors sinners checkedClasses |
	checkedClasses _ IdentitySet new.
	originalSinsPerSelector := IdentityDictionary new.
	rootClasses do: 
			[:rootClass | 
			rootClass withAllSuperclassesDo: [:superClass | 
				(checkedClasses includes: superClass) ifFalse: [
					checkedClasses add: superClass.
					sinnedSelectors := self sinsIn: superClass.
					sinnedSelectors do: 
							[:sinSel | 
							sinners := originalSinsPerSelector at: sinSel
										ifAbsentPut: [IdentitySet new].
							sinners add: superClass]]]]! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 16:52'!
findRootsAndRoutes
	"Based on the 
	1. target classes (ones considered interesting by our clients) and the 
	2. modifiedBehaviors (ones we are told might have changed), 
	decide the 
	A. rootClasses (superclasses of target classes that include methods from modifiedBehaviors) 
	B. classesToUpdate (classes that may have been affected AND are on an inheritance path between a root class and a target class, will be updated by the algorithm. This includes the every target class that may have been affected).
	C. mapping from root classes to its classesToUpdate."

	| highestSuperclassOfCurrentTarget modifiedClasses |
	classesToUpdate := IdentitySet new.
	rootClasses := IdentitySet new.
	modifiedClasses := (modifiedBehaviors gather: [:mb | mb classesComposedWithMe]) asIdentitySet.
	targetClasses do: [:currentTargetClass | 
		highestSuperclassOfCurrentTarget _ nil.
		currentTargetClass withAllSuperclassesDo: [:sc | 
			(modifiedClasses includes: sc) ifTrue: 
				[highestSuperclassOfCurrentTarget := sc.
				self noteRoot: sc possiblyAffected: currentTargetClass]].
			highestSuperclassOfCurrentTarget ifNotNilDo: [:highestRoot | 
				self addUpdatePathTo: currentTargetClass from: highestRoot]]! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/8/2005 16:14'!
initialize
	possiblyAffectedPerRoot _ IdentityDictionary new.! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 17:46'!
noteRoot: rootClass possiblyAffected: targetClass
	rootClasses add: rootClass.
	targetClass withAllSuperclassesDo: [:sc | 
		(self possiblyAffectedForRoot: rootClass) add: sc. rootClass = sc ifTrue: [^self]]
! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/8/2005 16:12'!
possiblyAffectedForRoot: rootClass
	^possiblyAffectedPerRoot at: rootClass ifAbsentPut: [IdentitySet new].! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 20:15'!
removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass
	| cache newRequirements |
	oldRequiredSelectorsByClass keysAndValuesDo: 
			[:class :requirements | 
			newRequirements := requiredSelectorsByClass at: class
						ifAbsent: 
							[#()].
			cache := class requiredSelectorsCache.
			requirements 
				do: [:sel | (newRequirements includes: sel) ifFalse: [cache removeRequirement: sel]]]! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 20:37'!
removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass ifIn: rootsHandledBySel
	| cache newRequirements unconfirmedRequirements roots affected |
	oldRequiredSelectorsByClass keysAndValuesDo: 
			[:class :oldRequirements | 
			newRequirements := requiredSelectorsByClass at: class
						ifAbsent: [#()].
			cache := class requiredSelectorsCache.
			unconfirmedRequirements := oldRequirements copyWithoutAll: newRequirements.
			unconfirmedRequirements do: [:sel | 
				roots := rootsHandledBySel at: sel ifAbsent: [#()].
				(roots anySatisfy: [:rc | 
					affected := possiblyAffectedPerRoot at: rc ifAbsent: #().
					(affected includes: class)]) ifTrue: [cache removeRequirement: sel]]]! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 18:22'!
selectorsToUpdateIn: aClass 
	^originalSinsPerSelector keys
! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 23:25'!
setFoundRequirements: requiredSelectorsByClass 
	| cache |
	requiredSelectorsByClass keysAndValuesDo: 
			[:class :requirements | 
			cache := class requiredSelectorsCache.
			requirements do: [:sel | cache addRequirement: sel]].
	^cache! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 23:36'!
shouldProcess: rc forSinsIn: sinners 
	rc withAllSuperclassesDo: [:rootSuperClass |
		(sinners includes: rootSuperClass) ifTrue: [^true].
		"theres a rootClass closer to the sin, we don't need to do it again."
		(rc ~= rootSuperClass and: [(rootClasses includes: rootSuperClass)]) ifTrue: [^false]].
	^false.! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 17:35'!
storeOldRequirementsUnder: rc into: oldRequiredSelectorsByClass ignoreSet: classWithOldRequirementsRecorded 
	classesToUpdate do: 
			[:someClass | 
			(rc == someClass or: [(someClass inheritsFrom: rc)])
				ifTrue: 
					[(classWithOldRequirementsRecorded includes: someClass) 
						ifFalse: 
							[oldRequiredSelectorsByClass at: someClass put: someClass requirements]]]! !

!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 23:27'!
storeRequirementsUnder: rc for: selector in: requiredSelectorsByClass 
	| requiringClasses selectorsForClass |
	requiringClasses := rc updateRequiredStatusFor: selector
				inSubclasses: (self possiblyAffectedForRoot: rc).
	^requiringClasses do: 
			[:requiringClass | 
			selectorsForClass := requiredSelectorsByClass at: requiringClass
						ifAbsentPut: [IdentitySet new].
			selectorsForClass add: selector]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RequiredSelectorsChangesCalculator class
	instanceVariableNames: ''!

!RequiredSelectorsChangesCalculator class methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 20:44'!
onModificationOf: behaviors withTargets: targetBehaviors 
	| i |
	i := self new.
	i
		targetBehaviors: targetBehaviors;
		modifiedBehaviors: behaviors;
		decideParameters.
	^i! !
Object subclass: #RequirementsCache
	instanceVariableNames: 'requirements superRequirements'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!

!RequirementsCache methodsFor: 'accessing' stamp: 'dvf 9/5/2005 11:37'!
newRequirementsObject
	^ IdentitySet new.! !

!RequirementsCache methodsFor: 'accessing' stamp: 'dvf 9/5/2005 11:37'!
requirements
	^ requirements isNil
		ifTrue: [self newRequirementsObject]
		ifFalse: [requirements].! !

!RequirementsCache methodsFor: 'accessing' stamp: 'dvf 9/5/2005 11:37'!
superRequirements
	"Answer the value of superRequirements"

	^ superRequirements isNil
		ifTrue: [IdentitySet new]
		ifFalse: [superRequirements].! !


!RequirementsCache methodsFor: 'updates' stamp: 'dvf 9/5/2005 11:34'!
addRequirement: selector
	requirements ifNil: [requirements := self newRequirementsObject].
	requirements add: selector.! !

!RequirementsCache methodsFor: 'updates' stamp: 'dvf 9/5/2005 11:37'!
removeRequirement: selector
	requirements ifNil: [^ self].
	requirements remove: selector ifAbsent: [].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RequirementsCache class
	instanceVariableNames: ''!
RequiresTestCase subclass: #RequiresOriginalTestCase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RequiresOriginalTestCase class
	instanceVariableNames: ''!

!RequiresOriginalTestCase class methodsFor: 'as yet unclassified' stamp: 'al 1/13/2006 00:02'!
updateRequiredStatusFor: selector in: aClass 
	aClass updateRequiredStatusFor: selector inSubclasses: self systemNavigation allClassesAndTraits ! !
TimeMeasuringTest subclass: #RequiresSpeedTestCase
	instanceVariableNames: 'displayedClasses focusedClasses interestingCategories'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Requires'!
!RequiresSpeedTestCase commentStamp: 'al 2/17/2006 08:50' prior: 0!
This class sets some performance requirements for the requirements algorithm. Subclasses set up and test different caching strategies.

Test methods are prefixed with "performance" to exclude them from normal test runs.!


!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 11:32'!
classesInCategories: currentCats 
	^currentCats gather: 
					[:c | 
					(SystemOrganization listAtCategoryNamed: c) 
						collect: [:name | Smalltalk at: name]]! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 11:32'!
decideInterestingClasses
	interestingCategories := {
				'Morphic-Basic'.
				'Morphic-Books'.
				'Morphic-Demo'.
				'System-Compression'.
				'System-Compiler'
			}.
	displayedClasses := self classesInCategories: interestingCategories.
	focusedClasses := {
				AtomMorph.
				AlignmentMorph.
				BookMorph.
				GZipReadStream.
				CommentNode
			}! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:46'!
performanceTestFileInScenario
	self prepareAllCaches.
	"decide the interesting sets"
	"set them up as such"
	"decide the classes and methods to be touched"
	self measure: 
		["touch the code as decided"
		"ask isAbsract of many classes"
		"ask requiredSelectors of a few"].
	self assert: realTime < 1000
! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:47'!
performanceTestFullRequires
	self prepareAllCaches.
	"note that we do not invalidate any caches"
	self measure: [AlignmentMorph requiredSelectors].
	"assuming we want 5 browsers to update their requiredSelectors list in 0.1 second"
	self assert: realTime < 20! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:45'!
performanceTestMethodChangeScenario
	RequiredSelectors doWithTemporaryInstance: [
		LocalSends doWithTemporaryInstance: [
			ProvidedSelectors doWithTemporaryInstance: [
				self prepareAllCaches.
				self measure: 
						[self touchObjectHalt.
						displayedClasses do: [:cl | cl hasRequiredSelectors].
						focusedClasses do: [:cl | cl requiredSelectors]].
				self assert: realTime < 200]]]! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:47'!
performanceTestMorphMethodChangeScenario
	RequiredSelectors doWithTemporaryInstance: 
			[LocalSends doWithTemporaryInstance: 
					[ProvidedSelectors doWithTemporaryInstance: 
							[self prepareAllCaches.
							self measure: 
									[self touchMorphStep.
									displayedClasses do: [:cl | cl hasRequiredSelectors].
									focusedClasses do: [:cl | cl requiredSelectors]].
							self assert: realTime < 200]]]! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:47'!
performanceTestParseNodeMethodChangeScenario
	RequiredSelectors doWithTemporaryInstance: 
			[LocalSends doWithTemporaryInstance: 
					[ProvidedSelectors doWithTemporaryInstance: 
							[self prepareAllCaches.
							self measure: 
									[self touchParseNodeComment.
									displayedClasses do: [:cl | cl hasRequiredSelectors].
									focusedClasses do: [:cl | cl requiredSelectors]].
							self assert: realTime < 100]]]! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:47'!
performanceTestSwitchToMorphClassCategoryScenario
	"When changing in one browser the selected category, we add some interesting classes, remove some others, and calculate some values. So this is a pretty full life cycle test."
	| noLongerInteresting newInteresting |
	RequiredSelectors doWithTemporaryInstance: 
			[LocalSends doWithTemporaryInstance: 
					[ProvidedSelectors doWithTemporaryInstance: 
							[self prepareAllCaches.
							noLongerInteresting := self classesInCategories: {'Morphic-Basic'}.
							newInteresting := self classesInCategories: {'Morphic-Kernel'}.
							self measure: 
									[self noteInterestInClasses: newInteresting.
									self loseInterestInClasses: noLongerInteresting.
									newInteresting do: [:cl | cl hasRequiredSelectors].
									self loseInterestInClasses: newInteresting.
									self noteInterestInClasses: noLongerInteresting.].
							self assert: realTime < 500]]]! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 13:01'!
prepareAllCaches
	self subclassResponsibility.! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 17:55'!
setUp
	self decideInterestingClasses.
! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 18:10'!
touchMorphStep
	Morph compile: (Morph sourceCodeAt: #step ifAbsent: []) asString! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 15:27'!
touchObjectHalt
	^Object compile: (Object sourceCodeAt: #halt ifAbsent: []) asString! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 18:12'!
touchParseNodeComment
	ParseNode compile: (ParseNode sourceCodeAt: #comment ifAbsent: []) asString! !

!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:58'!
workingCopyPredicate
	^[:e | {'TraitsOmniBrowser'. 'Traits'} includes: e package name]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RequiresSpeedTestCase class
	instanceVariableNames: ''!

!RequiresSpeedTestCase class methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 13:02'!
isAbstract
	^self == RequiresSpeedTestCase ! !
TraitsTestCase subclass: #RequiresTestCase
	instanceVariableNames: 't7 t8 t9 t10 t11 c9 c10 c11 c12 t13 c13 ta tb tc ca cb cc cd ce cf ch ci cg'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 15:09'!
for: ba classesComposedWith: aBehavior 
	^(ba includes: aBehavior) 
		or: [(ba gather: [:c | c traitComposition allTraits]) includes: aBehavior]! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 11:58'!
loseInterestsFor: behavior 
	RequiredSelectors current lostInterest: self in: behavior.
	LocalSends current lostInterest: self in: behavior.
	^ProvidedSelectors current lostInterest: self
		inAll: behavior withAllSuperclasses! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 14:16'!
loseInterestsInAll
	^self createdClassesAndTraits 
		, TraitsResource current createdClassesAndTraits 
			do: [:e | self loseInterestsFor: e]! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:32'!
noteInterestsForAll
	self createdClassesAndTraits 
		, TraitsResource current createdClassesAndTraits 
			do: [:e | self noteInterestsFor: e]! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 11:58'!
noteInterestsFor: behavior 
	RequiredSelectors current noteInterestOf: self in: behavior.
	LocalSends current noteInterestOf: self in: behavior.
	ProvidedSelectors current noteInterestOf: self
		inAll: behavior withAllSuperclasses! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 17:27'!
requiredMethodsForTrait: aTrait 
	^aTrait requiredSelectors! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 17:28'!
requiredMethodsOfTrait: basicTrait inContextOf: composedTrait 
	| interestingSelectors sss |
	interestingSelectors := (composedTrait traitComposition 
				transformationOfTrait: basicTrait) allSelectors.
	sss := composedTrait selfSentSelectorsFromSelectors: interestingSelectors.
	^sss copyWithoutAll: composedTrait allSelectors! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 17:45'!
selfSentSelectorsInTrait: aTrait 
	^self selfSentSelectorsInTrait: aTrait fromSelectors: aTrait allSelectors 
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 17:27'!
selfSentSelectorsInTrait: composedTrait fromSelectors: interestingSelectors 
	^composedTrait selfSentSelectorsFromSelectors: interestingSelectors 
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:32'!
setUp
	super setUp.
	t7 := self createTraitNamed: #T7
				uses: { }.
	t7 compile: 'm13 ^self m12' classified: #cat3.
	t8 := self createTraitNamed: #T8
				uses: { (t7 - { #m13 }) }.
	t9 := self createTraitNamed: #T9
				uses: { }.
	t9 compile: 'm13 ^self m12' classified: #cat3.
	t9 compile: 'm12 ^3' classified: #cat3.
	t10 := self createTraitNamed: #T10
				uses: { (t9 - { #m12 }) }.

	t11 := self createTraitNamed: #T11
				uses: { (t9 @ { (#m11 -> #m12) } - { #m12 }) }.

	c9 := self 
			createClassNamed: #C9
			superclass: ProtoObject
			uses: t7.

	
	c10 := self 
			createClassNamed: #C10
			superclass: ProtoObject
			uses: t7.
	c10 compile: 'm12 ^3'.

	c11 := self createClassNamed: #C11
			superclass: ProtoObject
			uses: {}.
	c11 compile: 'm12 ^3'.
	c12 := self createClassNamed: #C12
			superclass: c11
			uses: {t7}.
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 16:34'!
setUpHierarchy
	ta := self createTraitNamed: #TA
				uses: { }.
	tb := self createTraitNamed: #TB
				uses: { }.
	tc := self createTraitNamed: #TC uses: tb.
	ca := self 
				createClassNamed: #CA
				superclass: ProtoObject
				uses: { }.
	cb := self 
				createClassNamed: #CB
				superclass: ca
				uses: ta + tb.
	cc := self 
				createClassNamed: #CC
				superclass: cb
				uses: tb.
	cd := self 
				createClassNamed: #CD
				superclass: cc
				uses: { }.
	ce := self 
				createClassNamed: #CE
				superclass: cc
				uses: { }.
	cf := self 
				createClassNamed: #CF
				superclass: cb
				uses: { }.
	cg := self 
				createClassNamed: #CG
				superclass: cf
				uses: { }.
	ch := self 
				createClassNamed: #CH
				superclass: ca
				uses: { ta }.
	ci := self 
				createClassNamed: #CI
				superclass: ch
				uses: { }.

	ca compile: 'mca ^self ssca'.
	cb compile: 'mca ^3'.
	cb compile: 'mcb super mca'.
	cc compile: 'mcb ^3'.
	cc compile: 'mcb ^self sscc'.
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/12/2005 16:41'!
testAffectedClassesAndTraits
	| rscc |
	self setUpHierarchy.
	rscc := RequiredSelectorsChangesCalculator onModificationOf: {tb} withTargets: {ta. cg. ci. cd. tc}.
	self assert: rscc rootClasses asSet = (Set withAll: {cc. cb}).
	self assert: rscc classesToUpdate asSet = (Set withAll: {cg. cd. cf. cc. cb}).
	self assert: rscc traitsToUpdate asSet = (Set withAll: {tc}).
	self assert: (#(sscc) copyWithoutAll: (rscc selectorsToUpdateIn: cc)) isEmpty.
	self assert: (#(ssca) copyWithoutAll: (rscc selectorsToUpdateIn: cb)) isEmpty.! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 16:45'!
testExclusionWithAliasing
	self assert: ((self requiredMethodsForTrait: t11) = (Set with: #m12)).
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 16:34'!
testExlcusionInTraits
	self assert: ((self requiredMethodsForTrait: t8) = (Set new)).
	self assert: ((self requiredMethodsForTrait: t9) = (Set new)).
	self assert: ((self requiredMethodsForTrait: t10) = (Set with:#m12)).
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:33'!
testOneLevelRequires
	
	[self noteInterestsForAll.
	self assert: self c3 localSelectors size = 1.
	self assert: (self c3 sendCaches selfSendersOf: #bla) = #(#foo ).
	self c3 requiredSelectors.
	self assert: self c3 requirements = (Set withAll: #(#bla ))] 
			ensure: [self loseInterestsInAll]! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 11:02'!
testRequiresOfTraitInContextOfClass
	"a class providing nothing, leaves the requirements of the trait intact"
	self assert: (self requiredMethodsOfTrait: t7 inContextOf: c9) = (Set with: #m12).
	"a class can provide the Trait requirement"
	self assert: (self requiredMethodsOfTrait: t7 inContextOf: c10) = (Set new).
	"a class' superclass can provide the Trait requirement"
	self assert: (self requiredMethodsOfTrait: t7 inContextOf: c12) = (Set new).
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 17:55'!
testSimpleCompositionContexts
	self assert: (self requiredMethodsOfTrait: t7 inContextOf: t8) = (Set new).
	self assert: (self requiredMethodsOfTrait: t9 inContextOf: t10) = (Set with: #m12).
	self assert: (self requiredMethodsOfTrait: t9 inContextOf: t11) = (Set with: #m12).! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/12/2005 20:38'!
testSins
	| caa cab cac cad |
	caa := self 
				createClassNamed: #CAA
				superclass: ProtoObject
				uses: { }.
	caa superclass: nil.
	cab := self 
				createClassNamed: #CAB
				superclass: caa
				uses: {}.
	cac := self 
				createClassNamed: #CAC
				superclass: cab
				uses: {}.
	cad := self 
				createClassNamed: #CAD
				superclass: cac
				uses: { }.

	caa compile: 'ma self foo'.
	caa compile: 'md self explicitRequirement'.
	cac compile: 'mb self bar'.
	self noteInterestsFor: cad.
	self assert: (cad requiredSelectors = (Set withAll: #(foo bar md))).
	cab compile: 'mc ^3'.
	self assert: (cad requiredSelectors = (Set withAll: #(foo bar md))).
	self loseInterestsFor: cad.! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 16:33'!
testStandAloneTrait
	self assert: ((self requiredMethodsForTrait: t7) = (Set with: #m12)).! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 14:31'!
testTwoLevelRequires
	[self noteInterestsForAll.
	self assert: self c4 localSelectors size = 1.
	self assert: self c5 localSelectors size = 1.
	self assert: (self c4 sendCaches selfSendersOf: #blew) = #(#foo ).
	self assert: (self c5 sendCaches selfSendersOf: #blah) = #(#foo ).
	self c4 requiredSelectors.
	self assert: self c4 requirements = (Set withAll: #(#blew )).
	self assert: self c5 requirements = (Set withAll: #(#blah ))]
		ensure: [self loseInterestsInAll ]! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:35'!
testTwoLevelRequiresWithUnalignedSuperSends
	[self noteInterestsForAll.
	self updateRequiredStatusFor: #x in: self c6.
	self updateRequiredStatusFor: #blah in: self c8.
	self assert: self c6 requirements = (Set with: #x).
	self assert: self c7 requirements = (Set with: #x).
	self assert: self c8 requirements = (Set with: #blah).]
		ensure: [self loseInterestsInAll]
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:35'!
testTwoLevelRequiresWithUnalignedSuperSendsStartLate
	[self noteInterestsForAll.
	self updateRequiredStatusFor: #x in: self c8.
	self updateRequiredStatusFor: #blah in: self c8.
	self assert: self c8 requirements = (Set with: #blah).
	self updateRequiredStatusFor: #x in: self c7.
	self updateRequiredStatusFor: #blah in: self c7.
	self assert: self c7 requirements = (Set with: #x)]
		ensure: [self loseInterestsInAll]
! !

!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 14:46'!
updateRequiredStatusFor: selector in: aClass
	self class updateRequiredStatusFor: selector in: aClass
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RequiresTestCase class
	instanceVariableNames: ''!

!RequiresTestCase class methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 16:47'!
isAbstract
	^self == RequiresTestCase! !
Object subclass: #ResourceCollector
	instanceVariableNames: 'stubMap originalMap locatorMap localDirectory baseUrl resourceDirectory internalStubs'
	classVariableNames: 'Current'
	poolDictionaries: ''
	category: 'System-Support'!
!ResourceCollector commentStamp: '<historical>' prior: 0!
The ResourceCollector collects resources that are encountered during project loading or publishing. It merely decouples the places where resources are held from the core object enumeration so that resources can be stored independently from what is enumerated for publishing.!


!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:32'!
baseUrl
	^baseUrl! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:39'!
baseUrl: aString
	baseUrl _ aString.
	baseUrl isEmpty ifFalse:[
		baseUrl last = $/ ifFalse:[baseUrl _ baseUrl copyWith: $/].
	].! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:23'!
localDirectory
	^localDirectory! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:24'!
localDirectory: aDirectory
	localDirectory _ aDirectory! !

!ResourceCollector methodsFor: 'accessing' stamp: 'tk 6/28/2001 15:58'!
locatorMap
	"allow outsiders to store in it.  For files that are not resources that do want to live in the resource directory locally and on the server.  (.t files for example)"

	^locatorMap! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 22:54'!
locators
	^locatorMap values! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:07'!
locatorsDo: aBlock
	^locatorMap valuesDo: aBlock! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 17:01'!
noteResource: aResourceStub replacing: anObject
	"Remember the fact that we need to load aResource which will replace anObject."
	stubMap at: aResourceStub put: anObject.! !

!ResourceCollector methodsFor: 'accessing' stamp: 'mir 10/29/2003 13:33'!
objectForDataStream: refStream fromForm: aForm
	"Return a replacement for aForm to be stored instead"
	| stub fName copy loc fullSize nameAndSize |

	"First check if the form is one of the intrinsic Squeak forms"
	stub _ internalStubs at: aForm ifAbsent:[nil].
	stub ifNotNil:[
		refStream replace: aForm with: stub. 
		^stub].

	"Now see if we have created the stub already 
	(this may happen if for instance some form is shared)"
	stub _ originalMap at: aForm ifAbsent:[nil].
	stub ifNotNil:[^aForm].
	aForm hibernate.
	aForm bits class == FormStub ifTrue:[^nil].	"something is wrong"
	"too small to be of interest"
	"(aForm bits byteSize < 4096) ifTrue:[^aForm]."
	"We'll turn off writing out forms until we figure out how to reliably deal with resources"
	true ifTrue: [^aForm].

	"Create our stub form"
	stub _ FormStub 
		extent: (aForm width min: 32) @ (aForm height min: 32) 
		depth: (aForm depth min: 8).
	aForm displayScaledOn: stub.
	aForm hibernate.

	"Create a copy of the original form which we use to store those bits"
	copy _ Form extent: aForm extent depth: aForm depth bits: nil.
	copy setResourceBits: aForm bits.

	"Get the locator for the form (if we have any)"
	loc _ locatorMap at: aForm ifAbsent:[nil].

	"Store the resource file"
	nameAndSize _ self writeResourceForm: copy locator: loc.
	fName _ nameAndSize first.
	fullSize _ nameAndSize second.

	ProgressNotification signal: '2:resourceFound' extra: stub.
	stub hibernate.
	"See if we need to assign a new locator"
	(loc notNil and:[loc hasRemoteContents not]) ifTrue:[
		"The locator describes some local resource. 
		If we're preparing to upload the entire project to a
		remote server, make it a remote URL instead."
"		(baseUrl isEmpty not and:[baseUrl asUrl hasRemoteContents])
			ifTrue:[loc urlString: baseUrl, fName].
"
		baseUrl isEmpty not
			ifTrue:[loc urlString: self resourceDirectory , fName]].

	loc ifNil:[
		loc _ ResourceLocator new urlString: self resourceDirectory , fName.
		locatorMap at: aForm put: loc].
	loc localFileName: (localDirectory fullNameFor: fName).
	loc resourceFileSize: fullSize.
	stub locator: loc.

	"Map old against stub form"
	aForm setResourceBits: stub.
	originalMap at: aForm put: copy.
	stubMap at: stub put: aForm.
	locatorMap at: aForm put: loc.
	"note: *must* force aForm in out pointers if 
	in IS or else won't get #comeFullyUpOnReload:"
	refStream replace: aForm with: aForm.
	^aForm! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 22:59'!
removeLocator: loc
	locatorMap keys "copy" do:[:k|
		(locatorMap at: k) = loc ifTrue:[locatorMap removeKey: k]].! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:21'!
replaceAll
	"Replace all resources by their originals. Done after the resource have been collected to get back to the original state."
	originalMap keysAndValuesDo:[:k :v|
		v ifNotNil:[k replaceByResource: v].
	].! !

!ResourceCollector methodsFor: 'accessing' stamp: 'mir 6/21/2001 14:51'!
resourceDirectory
	resourceDirectory ifNil: [resourceDirectory _ self baseUrl copyFrom: 1 to: (self baseUrl lastIndexOf: $/)].
	^resourceDirectory! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:08'!
resourceFileNames
	"Return a list of all the resource files created"
	^locatorMap values asArray collect:[:loc| loc localFileName].! !

!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 17:01'!
stubMap
	^stubMap! !


!ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 23:08'!
forgetObsolete
	"Forget obsolete locators, e.g., those that haven't been referenced and not been stored on a file."
	locatorMap keys "copy" do:[:k|
		(locatorMap at: k) localFileName ifNil:[locatorMap removeKey: k]].! !

!ResourceCollector methodsFor: 'initialize' stamp: 'ar 3/3/2001 19:49'!
initialize
	| fd pvt |
	originalMap _ IdentityDictionary new.
	stubMap _ IdentityDictionary new.
	locatorMap _ IdentityDictionary new.
	internalStubs _ IdentityDictionary new.
	fd _ ScriptingSystem formDictionary.
	pvt _ ScriptingSystem privateGraphics asSet.
	fd keysAndValuesDo:[:sel :form|
		(pvt includes: sel) ifFalse:[
			internalStubs at: form put:
				(DiskProxy 
					global: #ScriptingSystem
					selector: #formAtKey:extent:depth:
					args: {sel. form extent. form depth})]].! !

!ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 22:36'!
initializeFrom: aResourceManager
	"Initialize the receiver from aResourceManager."
	aResourceManager resourceMap keysAndValuesDo:[:loc :res|
		(res notNil)
			ifTrue:[locatorMap at: res put:  loc.
					loc localFileName: nil].
	].! !


!ResourceCollector methodsFor: 'objects from disk' stamp: 'ar 2/24/2001 22:37'!
objectForDataStream: refStream
	"This should never happen; when projects get written they must be decoupled from the resource collector. If you get the error message below something is seriously broken."
	self error:'Cannot write resource manager'! !


!ResourceCollector methodsFor: 'resource writing' stamp: 'yo 11/13/2002 23:30'!
writeResourceForm: aForm fromLocator: aLocator
	"The given form has been externalized before. If it was reasonably compressed, use the bits of the original data - this allows us to recycle GIF, JPEG, PNG etc. data without using the internal compression (which is in most cases inferior). If necessary the data will be retrieved from its URL location. This retrieval is done only if the resouce comes from either
		* the local disk (in which case the file has never been published)
		* the browser cache (in which case we don't cache the resource locally)
	In any other case we will *not* attempt to retrieve it, because doing so can cause the system to connect to the network which is probably not what we want. It should be a rare case anyways; could only happen if one clears the squeak cache selectively."
	| fName fStream url data |
	"Try to be smart about the name of the file"
	fName _ (aLocator urlString includes: $:)
		ifTrue: [
			url _ aLocator urlString asUrl.
			url path last]
		ifFalse: [aLocator urlString].
	fName isEmptyOrNil ifFalse:[fName _ fName asFileName].
	(fName isEmptyOrNil or:[localDirectory isAFileNamed: fName]) ifTrue:[
		"bad luck -- duplicate name"
		fName _ localDirectory 
				nextNameFor:'resource' 
				extension: (FileDirectory extensionFor: aLocator urlString)].
	"Let's see if we have cached it locally"
	ResourceManager
		lookupCachedResource: self baseUrl , aLocator urlString
		ifPresentDo:[:stream | data _ stream upToEnd].
	"Check if the cache entry is without qualifying baseUrl. Workaround for older versions."
	data ifNil:[
		ResourceManager
			lookupCachedResource: aLocator urlString
			ifPresentDo:[:stream | data _ stream upToEnd]].
	data ifNil:[
		"We don't have it cached locally. Retrieve it from its original location."
		((url notNil and: [url hasRemoteContents]) and:[HTTPClient isRunningInBrowser not])
			ifTrue:[^nil]. "see note above"
		(Url schemeNameForString: aLocator urlString)
			ifNil: [^nil].
		data _ HTTPLoader default retrieveContentsFor: aLocator urlString.
		data ifNil:[^nil].
		data _ data content.
	].
	"data size > aForm bits byteSize ifTrue:[^nil]."
	fStream _ localDirectory newFileNamed: fName.
	fStream binary.
	fStream nextPutAll: data.
	fStream close.
	^{fName. data size}! !

!ResourceCollector methodsFor: 'resource writing' stamp: 'ar 9/23/2002 03:34'!
writeResourceForm: aForm locator: aLocator
	"Store the given form on a file. Return an array with the name and the size of the file"
	| fName fStream fullSize result writerClass |
	aLocator ifNotNil:[
		result _ self writeResourceForm: aForm fromLocator: aLocator.
		result ifNotNil:[^result]
		"else fall through"
	].
	fName _ localDirectory nextNameFor:'resource' extension:'form'.
	fStream _ localDirectory newFileNamed: fName.
	fStream binary.
	aForm storeResourceOn: fStream.
false ifTrue:[
	"What follows is a Really, REALLY bad idea. I leave it in as a reminder of what you should NOT do. 
	PART I: Using JPEG or GIF compression on forms where we don't have the original data means loosing both quality and alpha information if present..."
	writerClass _ ((Smalltalk includesKey: #JPEGReaderWriter2)
		and: [(Smalltalk at: #JPEGReaderWriter2) new isPluginPresent])
		ifTrue: [(Smalltalk at: #JPEGReaderWriter2)]
		ifFalse: [GIFReadWriter].
	writerClass putForm: aForm onStream: fStream.
	fStream open.
	fullSize _ fStream size.
	fStream close.
].

	"Compress contents here"
true ifTrue:[
	"...PART II: Using the builtin compression which combines RLE+ZIP is AT LEAST AS GOOD as PNG and how much more would you want???"
	fStream position: 0.
	fStream compressFile.
	localDirectory deleteFileNamed: fName.
	localDirectory rename: fName, FileDirectory dot, 'gz' toBe: fName.
	fStream _ localDirectory readOnlyFileNamed: fName.
	fullSize _ fStream size.
	fStream close.
].
	^{fName. fullSize}! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ResourceCollector class
	instanceVariableNames: ''!

!ResourceCollector class methodsFor: 'accessing' stamp: 'ar 2/24/2001 21:41'!
current
	^Current! !

!ResourceCollector class methodsFor: 'accessing' stamp: 'ar 2/24/2001 21:41'!
current: aResourceManager
	Current _ aResourceManager! !
Object subclass: #ResourceLocator
	instanceVariableNames: 'urlString fileSize localFileName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!ResourceLocator commentStamp: '<historical>' prior: 0!
Describes where a resource can be found.

Instance variables:
	urlString	<String> 	The URL of the resource
	fileSize		<Integer>	The size of the resource
	localFileName	<String>	When non-nil, the place where this resource was/is stored.!


!ResourceLocator methodsFor: 'accessing'!
adjustToDownloadUrl: downloadUrl
	"Adjust to the fully qualified URL for this resource."
	self urlString: (ResourceLocator make: self urlString relativeTo: downloadUrl) unescapePercents! !

!ResourceLocator methodsFor: 'accessing' stamp: 'mir 6/19/2001 16:55'!
adjustToRename: newName from: oldName
	"Adjust to the fully qualified URL for this resource."
	self urlString: (self urlString copyReplaceAll: oldName with: newName)! !

!ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:00'!
localFileName
	^localFileName! !

!ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:01'!
localFileName: aString
	localFileName _ aString! !

!ResourceLocator methodsFor: 'accessing' stamp: 'ar 3/2/2001 18:13'!
resourceFileSize
	^fileSize! !

!ResourceLocator methodsFor: 'accessing' stamp: 'ar 3/2/2001 18:13'!
resourceFileSize: aNumber
	fileSize _ aNumber! !

!ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 19:57'!
urlString
	^urlString! !

!ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 19:57'!
urlString: aString
	urlString _ aString.! !


!ResourceLocator methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:10'!
= aLocator

	^ self species == aLocator species and: [self urlString = aLocator urlString]
! !

!ResourceLocator methodsFor: 'comparing' stamp: 'ar 2/27/2001 20:02'!
hash
	^urlString hash! !

!ResourceLocator methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:10'!
species
	^ResourceLocator! !


!ResourceLocator methodsFor: 'printing' stamp: 'ar 2/27/2001 20:02'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(;
		print: urlString;
		nextPut: $)! !


!ResourceLocator methodsFor: 'testing' stamp: 'ar 2/27/2001 22:11'!
hasRemoteContents
	"Return true if we describe a resource which is non-local, e.g., on some remote server."
	(urlString indexOf: $:) = 0 ifTrue:[^false]. "no scheme"
	^urlString asUrl hasRemoteContents! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ResourceLocator class
	instanceVariableNames: ''!

!ResourceLocator class methodsFor: 'utilities' stamp: 'fbs 2/2/2005 13:24'!
make: newURLString relativeTo: oldURLString 
	"Local file refs are not handled well, so work around here"
	^((oldURLString includesSubString: '://') not
		and: [(newURLString includesSubString: '://') not])
		ifTrue: [oldURLString , (UnixFileDirectory localNameFor: newURLString)]
		ifFalse: [(newURLString asUrlRelativeTo: oldURLString asUrl) asString]! !
Object subclass: #ResourceManager
	instanceVariableNames: 'resourceMap loaded unloaded stopSemaphore stopFlag loaderProcess'
	classVariableNames: 'CachedResources LocalizedExternalResources'
	poolDictionaries: ''
	category: 'System-Support'!

!ResourceManager methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:50'!
addResource: anObject locator: aLocator
	resourceMap at: aLocator put: anObject.
	loaded add: aLocator.! !

!ResourceManager methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:56'!
addResource: anObject url: urlString
	^self addResource: anObject locator: (ResourceLocator new urlString: urlString)! !

!ResourceManager methodsFor: 'accessing' stamp: 'mir 6/26/2001 17:33'!
adjustToDownloadUrl: downloadUrl
	"Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server."

	downloadUrl isEmptyOrNil ifTrue: [^self].

	self resourceMap
		keysDo:[:locator | locator adjustToDownloadUrl: downloadUrl].
	self resourceMap rehash.
	unloaded rehash! !

!ResourceManager methodsFor: 'accessing'!
adjustToNewServer: newResourceUrl from: oldResourceUrl
	"Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server."
	| urlMap oldUrl newUrl |
	newResourceUrl isEmptyOrNil ifTrue: [^self].
	urlMap _ Dictionary new.
	self resourceMap
		keysDo: [:locator | 
			"Local file refs are not handled well, so work around here"
			oldUrl _ ResourceLocator make: locator urlString relativeTo: oldResourceUrl.
			newUrl _ ResourceLocator make: locator urlString relativeTo: newResourceUrl.
			oldUrl ~= newUrl
				ifTrue: [urlMap at: oldUrl asString unescapePercents put: newUrl asString unescapePercents]].
	self resourceMap rehash.
	unloaded rehash.
	urlMap keysAndValuesDo: [:old :new |
		ResourceManager renameCachedResource: old to: new]! !

!ResourceManager methodsFor: 'accessing' stamp: 'mir 6/21/2001 16:02'!
adjustToRename: newName from: oldName
	"Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server."
	| urlMap oldUrl |
	newName isEmptyOrNil ifTrue: [^self].
	urlMap _ Dictionary new.
	self resourceMap
		keysDo: [:locator | 
			oldUrl _ locator urlString.
			locator adjustToRename: newName from: oldName.
			urlMap at: oldUrl put: locator urlString].
	self resourceMap rehash.
	unloaded rehash.
	urlMap keysAndValuesDo: [:old :new |
		ResourceManager renameCachedResource: old to: new]! !

!ResourceManager methodsFor: 'accessing' stamp: 'mir 8/21/2001 17:07'!
makeAllProjectResourcesLocalTo: resourceUrl
	"Change the urls in the resource locators so project specific resources are stored and referenced locally. Project specific resources are all those that are kept locally in any of the project's versions."

	| locators locUrl locBase lastSlash projectBase localResource isExternal |
 	"Construct the version neutral project base"
	resourceUrl isEmptyOrNil ifTrue: [^self].
	projectBase _ resourceUrl copyFrom: 1 to: (resourceUrl lastIndexOf: $.) - 1.
	locators _ OrderedCollection new.
	self resourceMap
		keysAndValuesDo:[:loc :res | res ifNotNil: [locators add: loc]].
	locators do: [:locator |
		locUrl _ locator urlString.
		locUrl ifNotNil: [
			lastSlash _ locUrl lastIndexOf: $/.
			lastSlash > 0
				ifTrue: [
					locBase _ locUrl copyFrom: 1 to: lastSlash - 1.
					locBase _ locBase copyFrom: 1 to: (((locBase lastIndexOf: $.) - 1) max: 0).
					isExternal _ projectBase ~= locBase.
					(isExternal not
						or: [self localizeAllExternalResources])
						ifTrue: [
							localResource _ locUrl copyFrom: lastSlash+1 to: locUrl size.
							"Update the cache entry to point to the new resource location"
							ResourceManager renameCachedResource: locUrl to: (resourceUrl , localResource) external: isExternal.
							locator urlString: localResource]]]].
	self resourceMap rehash
! !

!ResourceManager methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:57'!
resourceMap
	^resourceMap! !


!ResourceManager methodsFor: 'backward-compatibility' stamp: 'nk 7/30/2004 21:46'!
convertMapNameForBackwardcompatibilityFrom: aString 
	(SmalltalkImage current platformName = 'Mac OS' 
		and: ['10*' match: SmalltalkImage current osVersion]) 
			ifTrue: [^aString convertFromWithConverter: ShiftJISTextConverter new].
	^aString convertFromSystemString! !


!ResourceManager methodsFor: 'initialize' stamp: 'ar 2/27/2001 16:54'!
initialize
	"So resources may get garbage collected if possible"
	self reset.! !

!ResourceManager methodsFor: 'initialize' stamp: 'mir 6/18/2001 22:49'!
initializeFrom: aCollector
	"Initialize the receiver from the given resource collector. None of the resources have been loaded yet, so make register all resources as unloaded."
	| newLoc |
	aCollector stubMap keysAndValuesDo:[:stub :res|
		newLoc _ stub locator.
		resourceMap at: newLoc put: res.
		"unloaded add: newLoc."
	].! !

!ResourceManager methodsFor: 'initialize' stamp: 'ar 2/27/2001 16:54'!
reset
	"Clean out everything"
	resourceMap _ WeakValueDictionary new.
	loaded _ Set new.
	unloaded _ Set new.! !


!ResourceManager methodsFor: 'loading' stamp: 'ar 5/30/2001 23:11'!
installResource: aResource from: aStream locator: loc
	| repl |
	aResource ifNil:[^false]. "it went away, so somebody might have deleted it"
	(aStream == nil or:[aStream size = 0]) ifTrue:[^false]. "error?!!"
	repl _ aResource clone readResourceFrom: aStream asUnZippedStream.
	repl ifNotNil:[
		aResource replaceByResource: repl.
		unloaded remove: loc.
		loaded add: loc.
		^true
	].
	^false! !

!ResourceManager methodsFor: 'loading' stamp: 'nk 4/17/2004 19:50'!
loadCachedResources
	"Load all the resources that we have cached locally"
	| resource |
	self class reloadCachedResources.
	self prioritizedUnloadedResources do:[:loc|
		self class lookupCachedResource: loc urlString ifPresentDo:[:stream|
			resource _ resourceMap at: loc ifAbsent:[nil].
			self installResource: resource
				from: stream
				locator: loc.
			(resource isForm) ifTrue:[
				self formChangedReminder value.
				World displayWorldSafely].
		].
	].! !

!ResourceManager methodsFor: 'loading' stamp: 'nk 4/17/2004 19:50'!
loaderProcess
	| loader requests req locator resource stream |
	loader _ HTTPLoader default.
	requests _ Dictionary new.
	self prioritizedUnloadedResources do:[:loc|
		req _ HTTPLoader httpRequestClass for: (self hackURL: loc urlString) in: loader.
		loader addRequest: req.
		requests at: req put: loc].
	[stopFlag or:[requests isEmpty]] whileFalse:[
		stopSemaphore waitTimeoutMSecs: 500.
		requests keys "need a copy" do:[:r|
			r isSemaphoreSignaled ifTrue:[
				locator _ requests at: r.
				requests removeKey: r.
				stream _ r contentStream.
				resource _ resourceMap at: locator ifAbsent:[nil].
				self class cacheResource: locator urlString stream: stream.
				self installResource: resource
					from: stream
					locator: locator.
				(resource isForm) ifTrue:[
					WorldState addDeferredUIMessage: self formChangedReminder]
ifFalse: [self halt].
			].
		].
	].
	"Either done downloading or terminating process"
	stopFlag ifTrue:[loader abort].
	loaderProcess _ nil.
	stopSemaphore _ nil.! !

!ResourceManager methodsFor: 'loading' stamp: 'tetha 3/6/2004 15:46'!
preLoadFromArchive: aZipArchive cacheName: aFileName
	"Load the resources from the given zip archive"
	| orig nameMap resMap loc stream |
	self class reloadCachedResources.
	resMap _ Dictionary new.
	nameMap _ Dictionary new.
	unloaded do:[:locator|
		locator localFileName: nil.
		nameMap at: locator urlString put: locator.
		resMap at: locator urlString put: (resourceMap at: locator)].

	aZipArchive members do:[:entry|
		stream _ nil.
		orig _ resMap at: (self convertMapNameForBackwardcompatibilityFrom: entry fileName ) ifAbsent:[nil].
		loc _ nameMap at: (self convertMapNameForBackwardcompatibilityFrom: entry fileName ) ifAbsent:[nil].
		"note: orig and loc may be nil for non-resource members"
		(orig notNil and:[loc notNil]) ifTrue:[
			stream _ entry contentStream.
			self installResource: orig from: stream locator: loc.
			stream reset.
			aFileName 
				ifNil:[self class cacheResource: loc urlString stream: stream]
				ifNotNil:[self class cacheResource: loc urlString inArchive: aFileName]].
	].! !

!ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 18:16'!
prioritizedUnloadedResources
	"Return an array of unloaded resource locators prioritized by some means"
	| list |
	list _ unloaded asArray.
	^list sort:[:l1 :l2|
		(l1 resourceFileSize ifNil:[SmallInteger maxVal]) <=
			(l2 resourceFileSize ifNil:[SmallInteger maxVal])]! !

!ResourceManager methodsFor: 'loading' stamp: 'mir 6/18/2001 22:49'!
registerUnloadedResources
	resourceMap keys do: [:newLoc |
		unloaded add: newLoc]
! !

!ResourceManager methodsFor: 'loading' stamp: 'ar 3/3/2001 18:01'!
startDownload
	"Start downloading unloaded resources"
	self stopDownload.
	unloaded isEmpty ifTrue:[^self].
	self loadCachedResources.
	unloaded isEmpty ifTrue:[^self].
	stopFlag _ false.
	stopSemaphore _ Semaphore new.
	loaderProcess _ [self loaderProcess] newProcess.
	loaderProcess priority: Processor lowIOPriority.
	loaderProcess resume.! !

!ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 17:09'!
stopDownload
	"Stop downloading unloaded resources"
	loaderProcess ifNil:[^self].
	stopFlag _ true.
	stopSemaphore signal.
	[loaderProcess == nil] whileFalse:[(Delay forMilliseconds: 10) wait].
	stopSemaphore _ nil.! !

!ResourceManager methodsFor: 'loading' stamp: 'ar 2/27/2001 21:42'!
updateResourcesFrom: aCollector
	"We just assembled all the resources in a project.
	Include all that were newly found"
	self reset. "start clean"
	aCollector stubMap keysAndValuesDo:[:stub :res|
		"update all entries"
		resourceMap at: stub locator put: res.
		loaded add: stub locator.
	].! !


!ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 19:25'!
abandonResourcesThat: matchBlock
	"Private. Forget resources that match the given argument block"
	resourceMap keys "need copy" do:[:loc|
		(matchBlock value: loc) ifTrue:[
			resourceMap removeKey: loc ifAbsent:[].
			loaded remove: loc ifAbsent:[].
			unloaded remove: loc ifAbsent:[].
		].
	].! !

!ResourceManager methodsFor: 'private' stamp: 'yo 1/12/2004 22:54'!
fixJISX0208Resource

	| keys value url |
	keys _ resourceMap keys.

	keys do: [:key |
		value _ resourceMap at: key.
		url _ key urlString copy.
		url isOctetString not ifTrue: [url mutateJISX0208StringToUnicode].
		resourceMap removeKey: key.
		key urlString: url.
		resourceMap at: key put: value.
	].
! !

!ResourceManager methodsFor: 'private' stamp: 'ar 3/3/2001 15:30'!
formChangedReminder
	^[World newResourceLoaded].! !

!ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 17:22'!
hackURL: urlString
	(urlString findString: '/SuperSwikiProj/') > 0 
		ifTrue:[^urlString copyReplaceAll: '/SuperSwikiProj/' with: '/uploads/']
		ifFalse:[^urlString]! !

!ResourceManager methodsFor: 'private' stamp: 'mir 8/20/2001 17:12'!
localizeAllExternalResources
	"Should be a preference later."
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ResourceManager class
	instanceVariableNames: ''!

!ResourceManager class methodsFor: 'resource caching' stamp: 'ar 5/30/2001 23:21'!
cacheResource: urlString inArchive: archiveName
	"Remember the given url as residing in the given archive"
	| fd file fullName |
	fullName _ 'zip://', archiveName.
	((self resourceCache at: urlString ifAbsent:[#()]) 
		anySatisfy:[:cache| cache = fullName]) ifTrue:[^self]. "don't cache twice"
	fd _ Project squeakletDirectory.
	"update cache"
	file _ [fd oldFileNamed: self resourceCacheName] 
			on: FileDoesNotExistException
			do:[:ex| fd forceNewFileNamed: self resourceCacheName].
	file setToEnd.
	file nextPutAll: urlString; cr.
	file nextPutAll: fullName; cr.
	file close.
	self addCacheLocation: fullName for: urlString.! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'yo 12/20/2003 02:12'!
cacheResource: urlString stream: aStream
	| fd localName file buf |
	HTTPClient shouldUsePluginAPI ifTrue:[^self]. "use browser cache"
	(self resourceCache at: urlString ifAbsent:[#()]) size > 0 
		ifTrue:[^self]. "don't waste space"
	fd _ Project squeakletDirectory.
	localName _ fd nextNameFor: 'resource' extension:'cache'.
	file _ fd forceNewFileNamed: localName.
	buf _ ByteArray new: 10000.
	aStream binary.
	file binary.
	[aStream atEnd] whileFalse:[
		buf _ aStream next: buf size into: buf.
		file nextPutAll: buf.
	].
	file close.
	"update cache"
	file _ [fd oldFileNamed: self resourceCacheName] 
			on: FileDoesNotExistException
			do:[:ex| fd forceNewFileNamed: self resourceCacheName].
	file setToEnd.
	file nextPutAll: urlString; cr.
	file nextPutAll: localName; cr.
	file close.
	self addCacheLocation: localName for: urlString.
	aStream position: 0.
! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 9/15/2002 15:59'!
lookupCachedResource: cachedUrlString ifPresentDo: streamBlock
	"See if we have cached the resource described by the given url and if so, evaluate streamBlock with the cached resource."
	|  urlString candidates url stream |
	CachedResources ifNil:[^self].

	candidates _ CachedResources at: cachedUrlString ifAbsent:[nil].
	(self lookupCachedResource: cachedUrlString in: candidates ifPresentDo: streamBlock)
		ifTrue: [^self].

	urlString _ self relocatedExternalResource: cachedUrlString.
	urlString ifNil: [^self].
	candidates _ CachedResources at: urlString ifAbsent:[nil].
	candidates
		ifNil: [
			(url _ urlString asUrl) schemeName = 'file'
				ifTrue: [
					stream _ [FileStream readOnlyFileNamed: url pathForFile] 
							on: FileDoesNotExistException do:[:ex| ex return: nil].
					stream
						ifNotNil: [[streamBlock value: stream] ensure: [stream close]]]]
		ifNotNil: [self lookupCachedResource: urlString in: candidates ifPresentDo: streamBlock]! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 8/21/2001 18:31'!
lookupCachedResource: urlString in: candidates ifPresentDo: streamBlock
	"See if we have cached the resource described by the given url and if so, evaluate streamBlock with the cached resource."
	| sortedCandidates dir file |
	(candidates isNil or:[candidates size = 0])
		ifTrue:[^false].
	"First, try non-zip members (faster since no decompression is involved)"
	sortedCandidates _ (candidates reject:[:each| each beginsWith: 'zip://']),
					(candidates select:[:each| each beginsWith: 'zip://']).
	dir _ Project squeakletDirectory.
	sortedCandidates do:[:fileName|
		file _ self loadResource: urlString fromCacheFileNamed: fileName in: dir.
		file ifNotNil:[
			[streamBlock value: file] ensure:[file close].
			^true]].
	^false! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 6/21/2001 22:49'!
lookupOriginalResourceCacheEntry: resourceFileName for: resourceUrl
	"See if we have cached the resource described by the given url in an earlier version of the same project on the same server. In that case we don't need to upload it again but rather link to it."
	| candidates resourceBase resourceMatch matchingUrls |
	
	CachedResources ifNil:[^nil].

	"Strip the version number from the resource url"
	resourceBase _ resourceUrl copyFrom: 1 to: (resourceUrl lastIndexOf: $.) .
	"Now collect all urls that have the same resource base"
	resourceMatch _ resourceBase , '*/' , resourceFileName.
	matchingUrls _ self resourceCache keys
		select: [:entry | (resourceMatch match: entry) and: [(entry beginsWith: resourceUrl) not]].
	matchingUrls isEmpty
		ifTrue: [^nil].
	matchingUrls asSortedCollection do: [:entry | 
			candidates _ (self resourceCache at: entry).
			candidates isEmptyOrNil
				ifFalse: [candidates do: [:candidate |
					candidate = resourceFileName
						ifTrue: [^entry]]]].
	^nil! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'sd 1/30/2004 15:21'!
reloadCachedResources	"ResourceManager reloadCachedResources"
	"Reload cached resources from the disk"
	| fd files stream url localName storeBack archiveName |
	CachedResources _ Dictionary new.
	LocalizedExternalResources _ nil.
	fd _ Project squeakletDirectory.
	files _ fd fileNames asSet.
	stream _ [fd readOnlyFileNamed: self resourceCacheName]
				on: FileDoesNotExistException 
				do:[:ex| fd forceNewFileNamed: self resourceCacheName].
	stream size < 50000 ifTrue:[stream _ ReadStream on: stream contentsOfEntireFile].
	storeBack _ false.
	[stream atEnd] whileFalse:[
		url _ stream upTo: Character cr.	
		localName _ stream upTo: Character cr.
		(localName beginsWith: 'zip://') ifTrue:[
			archiveName _ localName copyFrom: 7 to: localName size.
			(files includes: archiveName) 
				ifTrue:[self addCacheLocation: localName for: url]
				ifFalse:[storeBack _ true].
		] ifFalse:[
			(files includes: localName) 
				ifTrue:[self addCacheLocation: localName for: url]
				ifFalse:[storeBack _ true]
		].
	].
	stream close.
	storeBack ifTrue:[
		stream _ fd forceNewFileNamed: self resourceCacheName.
		CachedResources keysAndValuesDo:[:urlString :cacheLocs|
			cacheLocs do:[:cacheLoc|
				stream nextPutAll: urlString; cr.
				stream nextPutAll: cacheLoc; cr].
		].
		stream close.
	].! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 8/21/2001 17:24'!
renameCachedResource: urlString to: newUrlString
	"A project was renamed. Reflect this change by duplicating the cache entry to the new url."
	self renameCachedResource: urlString to: newUrlString external: true! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 12/3/2001 13:14'!
renameCachedResource: urlString to: newUrlString external: isExternal
	"A project was renamed. Reflect this change by duplicating the cache entry to the new url."
	| candidates |
	CachedResources
		ifNil:[
			isExternal
				ifTrue: [self resourceCache "force init" ]
				ifFalse: [^self]].
	candidates _ CachedResources at: urlString ifAbsent:[nil].
	(candidates isNil or:[candidates size = 0])
		ifFalse: [
		candidates do: [:candidate |
			self addCacheLocation: candidate for: newUrlString]].
	isExternal
		ifTrue: [self relocatedExternalResource: urlString to: newUrlString]! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'ar 8/23/2001 17:52'!
resourceCache
	^CachedResources ifNil:[
		CachedResources _ Dictionary new.
		self reloadCachedResources.
		CachedResources].! !

!ResourceManager class methodsFor: 'resource caching' stamp: 'ar 3/3/2001 17:27'!
resourceCacheName
	^'resourceCache.map'! !


!ResourceManager class methodsFor: 'private-resources' stamp: 'mir 11/29/2001 16:19'!
addCacheLocation: aString for: urlString
	| locations |
	locations _ CachedResources at: urlString ifAbsentPut: [#()].
	(locations includes: aString)
		ifFalse: [CachedResources at: urlString put: ({aString} , locations)]! !

!ResourceManager class methodsFor: 'private-resources' stamp: 'ar 5/30/2001 23:55'!
loadResource: urlString fromCacheFileNamed: fileName in: dir
	| archiveName file archive |
	(fileName beginsWith: 'zip://') ifTrue:[
		archiveName _ fileName copyFrom: 7 to: fileName size.
		archive _ [dir readOnlyFileNamed: archiveName] 
			on: FileDoesNotExistException
			do:[:ex| ex return: nil].
		archive ifNil:[^nil].
		archive isZipArchive ifTrue:[
			archive _ ZipArchive new readFrom: archive.
			file _ archive members detect:[:any| any fileName = urlString] ifNone:[nil]].
		file ifNotNil:[file _ file contentStream].
		archive close.
	] ifFalse:[
		file _ [dir readOnlyFileNamed: fileName] 
				on: FileDoesNotExistException
				do:[:ex| ex return: nil].
	].
	^file! !

!ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 15:50'!
localizedExternalResources
	^LocalizedExternalResources ifNil:[LocalizedExternalResources _ Dictionary new]! !

!ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 16:06'!
relocatedExternalResource: urlString
	^self localizedExternalResources at: urlString ifAbsent: [nil]! !

!ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 16:00'!
relocatedExternalResource: urlString to: newUrlString
	| originalURL |
	originalURL _ (self localizedExternalResources includesKey: urlString)
		ifTrue: [self localizedExternalResources at: urlString]
		ifFalse: [urlString].
	self localizedExternalResources at: newUrlString put: originalURL! !
AbstractSound subclass: #RestSound
	instanceVariableNames: 'initialCount count'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!RestSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:07'!
duration
	"Answer the duration of this sound in seconds."

	^ initialCount asFloat / self samplingRate
! !

!RestSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration: seconds

	super duration: seconds.
	count := initialCount := (seconds * self samplingRate) rounded.
! !

!RestSound methodsFor: 'accessing' stamp: 'di 2/17/1999 21:09'!
samples
	^ SoundBuffer newMonoSampleCount: initialCount! !


!RestSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setDur: d
	"Set rest duration in seconds."

	initialCount := (d * self samplingRate asFloat) rounded.
	count := initialCount.
	self reset.
! !


!RestSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play silence for a given duration."
	"(RestSound dur: 1.0) play"

	count := count - n.
! !

!RestSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset

	super reset.
	count := initialCount.
! !

!RestSound methodsFor: 'sound generation' stamp: 'jm 12/15/97 22:37'!
samplesRemaining

	^ count
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RestSound class
	instanceVariableNames: ''!

!RestSound class methodsFor: 'instance creation' stamp: 'jm 3/31/1999 21:05'!
dur: d
	"Return a rest of the given duration."

	^ self new setDur: d
! !

!RestSound class methodsFor: 'instance creation' stamp: 'jm 12/15/97 22:38'!
pitch: p dur: d loudness: l
	"Return a rest of the given duration."
	"Note: This message allows one to silence one or more voices of a multi-voice piece by using RestSound as their instrument."

	^ self new setDur: d
! !
ObjectWithDocumentation subclass: #ResultSpecification
	instanceVariableNames: 'type companionSetterSelector refetchFrequency'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!

!ResultSpecification methodsFor: 'companion setter' stamp: 'sw 2/27/2001 09:15'!
companionSetterSelector
	"Answer the companion setter, nil if none"

	^ companionSetterSelector! !

!ResultSpecification methodsFor: 'companion setter' stamp: 'stephaneducasse 2/4/2006 20:39'!
companionSetterSelector: aSetterSelector
	"Set the receiver's companionSetterSelector as indicated"

	companionSetterSelector := aSetterSelector! !


!ResultSpecification methodsFor: 'refetch' stamp: 'sw 5/3/2001 00:07'!
refetchFrequency
	"Answer the frequency with which the receiver should be refetched by a readout polling values from it, as in a Viewer.  Answer nil if not ever to be refetched automatically"

	^ refetchFrequency! !

!ResultSpecification methodsFor: 'refetch' stamp: 'stephaneducasse 2/4/2006 20:39'!
refetchFrequency: aFrequency
	"Set the refetch frequency"

	refetchFrequency := aFrequency! !


!ResultSpecification methodsFor: 'result type' stamp: 'sw 2/27/2001 09:14'!
resultType
	"Answer the reciever's result type"

	^ type! !

!ResultSpecification methodsFor: 'result type' stamp: 'stephaneducasse 2/4/2006 20:39'!
resultType: aType
	"Set the receiver's resultType as specified"

	type := aType! !

!ResultSpecification methodsFor: 'result type' stamp: 'sw 2/24/2001 12:12'!
type
	"Answer the reciever's type"

	^ type! !
TestFailure subclass: #ResumableTestFailure
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Kernel'!
!ResumableTestFailure commentStamp: '<historical>' prior: 0!
A ResumableTestFailure triggers a TestFailure, but lets execution of the TestCase continue. this is useful when iterating through collections, and #assert: ing on each element. in combination with methods like testcase>>#assert:description:, this lets you run through a whole collection and note which tests pass.

here''s an example:

	

	(1 to: 30) do: [ :each |
		self assert: each odd description: each printString, ' is even' resumable: true]

for each element where #odd returns <false>, the element will be printed to the Transcript. !


!ResumableTestFailure methodsFor: 'camp smalltalk'!
isResumable
	"Of course a ResumableTestFailure is resumable ;-)"

	^true! !

!ResumableTestFailure methodsFor: 'camp smalltalk'!
sunitExitWith: aValue
	self resume: aValue! !
TestCase subclass: #ResumableTestFailureTestCase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!

!ResumableTestFailureTestCase methodsFor: 'Not categorized'!
errorTest
	1 zork
			! !

!ResumableTestFailureTestCase methodsFor: 'Not categorized' stamp: 'md 2/22/2006 14:17'!
failureLog
	^Transcript
			! !

!ResumableTestFailureTestCase methodsFor: 'Not categorized'!
failureTest
	self
		assert: false description: 'You should see me' resumable: true; 
		assert: false description: 'You should see me too' resumable: true; 
		assert: false description: 'You should see me last' resumable: false; 
		assert: false description: 'You should not see me' resumable: true
			! !

!ResumableTestFailureTestCase methodsFor: 'Not categorized'!
isLogging
	^false
			! !

!ResumableTestFailureTestCase methodsFor: 'Not categorized'!
okTest
	self assert: true
			! !

!ResumableTestFailureTestCase methodsFor: 'Not categorized'!
regularTestFailureTest
	self assert: false description: 'You should see me'
			! !

!ResumableTestFailureTestCase methodsFor: 'Not categorized'!
resumableTestFailureTest
	self
		assert: false description: 'You should see me' resumable: true; 
		assert: false description: 'You should see me too' resumable: true; 
		assert: false description: 'You should see me last' resumable: false; 
		assert: false description: 'You should not see me' resumable: true
			! !

!ResumableTestFailureTestCase methodsFor: 'Not categorized'!
testResumable
	| result suite |
	suite := TestSuite new.
	suite addTest: (self class selector: #errorTest).
	suite addTest: (self class selector: #regularTestFailureTest).
	suite addTest: (self class selector: #resumableTestFailureTest).
	suite addTest: (self class selector: #okTest).
	result := suite run.
	self assert: result failures size = 2;
		assert: result errors size = 1
			! !
ParseNode subclass: #ReturnNode
	instanceVariableNames: 'expr'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!ReturnNode commentStamp: '<historical>' prior: 0!
I represent an expression of the form ^expr.!


!ReturnNode methodsFor: 'code generation'!
code

	^expr code! !

!ReturnNode methodsFor: 'code generation'!
emitForReturn: stack on: strm

	expr emitForReturn: stack on: strm.
	pc _ strm position! !

!ReturnNode methodsFor: 'code generation'!
emitForValue: stack on: strm

	expr emitForReturn: stack on: strm.
	pc _ strm position! !

!ReturnNode methodsFor: 'code generation'!
sizeForReturn: encoder

	^expr sizeForReturn: encoder! !

!ReturnNode methodsFor: 'code generation'!
sizeForValue: encoder

	^expr sizeForReturn: encoder! !


!ReturnNode methodsFor: 'converting'!
asReturnNode! !


!ReturnNode methodsFor: 'initialize-release'!
expr: e

	expr _ e! !

!ReturnNode methodsFor: 'initialize-release'!
expr: e encoder: encoder sourceRange: range

	expr _ e.
	encoder noteSourceRange: range forNode: self! !


!ReturnNode methodsFor: 'printing' stamp: 'yo 8/2/2004 17:21'!
expr

	^ expr.
! !

!ReturnNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:45'!
printOn: aStream indent: level

	aStream nextPutAll: '^ '.
	expr printOn: aStream indent: level.
	expr printCommentOn: aStream indent: level.
! !


!ReturnNode methodsFor: 'testing'!
isReturnSelf

	^expr == NodeSelf! !

!ReturnNode methodsFor: 'testing'!
isSpecialConstant

	^expr isSpecialConstant! !

!ReturnNode methodsFor: 'testing'!
isVariableReference

	^expr isVariableReference! !


!ReturnNode methodsFor: '*eToys-tiles' stamp: 'RAA 2/26/2001 06:44'!
asMorphicSyntaxIn: parent

	^parent returnNode: self expression: expr
! !

!ReturnNode methodsFor: '*eToys-tiles' stamp: 'RAA 8/15/1999 19:31'!
explanation

	^'Exit this method returning the value of ',expr explanation
! !
AbstractSound subclass: #ReverbSound
	instanceVariableNames: 'sound tapDelays tapGains tapCount bufferSize bufferIndex leftBuffer rightBuffer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!ReverbSound methodsFor: 'accessing' stamp: 'jm 1/7/98 22:41'!
sound

	^ sound
! !

!ReverbSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
sound: aSound

	sound := aSound.
! !

!ReverbSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
tapDelays: delayList gains: gainList
	"ReverbSound new tapDelays: #(537 691 1191) gains: #(0.07 0.07 0.07)"

	| maxDelay gain d |
	delayList size = gainList size
		ifFalse: [self error: 'tap delay and gains lists must be the same size'].
	tapCount := delayList size.
	tapDelays := Bitmap new: tapCount.
	tapGains := Bitmap new: tapCount.

	maxDelay := 0.
	1 to: tapGains size do: [:i |
		tapDelays at: i put: (delayList at: i) asInteger.
		gain := gainList at: i.
		gain >= 1.0 ifTrue: [self error: 'reverb tap gains must be under 1.0'].
		tapGains at: i put: (gain * ScaleFactor) asInteger.
		d := tapDelays at: i.
		d > maxDelay ifTrue: [maxDelay := d]].
	bufferSize := maxDelay.
	leftBuffer := SoundBuffer newMonoSampleCount: maxDelay.
	rightBuffer := SoundBuffer newMonoSampleCount: maxDelay.
	bufferIndex := 1.
! !


!ReverbSound methodsFor: 'copying' stamp: 'jm 1/21/98 14:29'!
copy
	"Copy my component sound."

	^ super copy copySound
! !

!ReverbSound methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:41'!
copySound
	"Private!! Support for copying. Copy my component sound."

	sound := sound copy.
	leftBuffer := leftBuffer clone.
	rightBuffer := rightBuffer clone.
! !


!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 14:32'!
doControl

	super doControl.
	sound doControl.
! !

!ReverbSound methodsFor: 'sound generation' stamp: 'zz 3/2/2004 08:26'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play my sound with reverberation."

	sound mixSampleCount: n
		into: aSoundBuffer
		startingAt: startIndex
		leftVol: leftVol
		rightVol: rightVol.
	self applyReverbTo: aSoundBuffer startingAt: startIndex count: n.
! !

!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 16:47'!
reset

	super reset.
	sound reset.
	1 to: bufferSize do: [:i |
		leftBuffer at: i put: 0.
		rightBuffer at: i put: 0].
! !

!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 17:02'!
samplesRemaining

	^ sound samplesRemaining
! !


!ReverbSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
applyReverbTo: aSoundBuffer startingAt: startIndex count: n

	| delayedLeft delayedRight i tapGain j out |
	<primitive: 'primitiveApplyReverb' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #tapDelays declareC: 'int *tapDelays'.
	self var: #tapGains declareC: 'int *tapGains'.
	self var: #leftBuffer declareC: 'short int *leftBuffer'.
	self var: #rightBuffer declareC: 'short int *rightBuffer'.

	startIndex to: ((startIndex + n) - 1) do: [:sliceIndex |
		delayedLeft := delayedRight := 0.
		1 to: tapCount do: [:tapIndex |
			i := bufferIndex - (tapDelays at: tapIndex).
			i < 1 ifTrue: [i := i + bufferSize].  "wrap"
			tapGain := tapGains at: tapIndex.
			delayedLeft := delayedLeft + (tapGain * (leftBuffer at: i)).
			delayedRight := delayedRight + (tapGain * (rightBuffer at: i))].

		"left channel"
		j := (2 * sliceIndex) - 1.
		out := (aSoundBuffer at: j) + (delayedLeft // ScaleFactor).
		out >  32767 ifTrue: [out :=  32767].  "clipping!!"
		out < -32767 ifTrue: [out := -32767].  "clipping!!"
		aSoundBuffer at: j put: out.
		leftBuffer at: bufferIndex put: out.

		"right channel"
		j := j + 1.
		out := (aSoundBuffer at: j) + (delayedRight // ScaleFactor).
		out >  32767 ifTrue: [out :=  32767].  "clipping!!"
		out < -32767 ifTrue: [out := -32767].  "clipping!!"
		aSoundBuffer at: j put: out.
		rightBuffer at: bufferIndex put: out.

		bufferIndex := (bufferIndex \\ bufferSize) + 1].
! !
SimpleButtonMorph subclass: #RolloverButtonMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:52'!
handlesMouseOver: evt

	^ true! !

!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:52'!
handlesMouseOverDragging: evt

	^ true! !

!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:53'!
mouseEnter: evt

	"0.09375 is exact in floating point so no cumulative rounding error will occur"
	self color: (self color adjustBrightness: -0.09375)! !

!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:54'!
mouseLeave: evt

	"0.09375 is exact in floating point so no cumulative rounding error will occur"
	self color: (self color adjustBrightness: 0.09375)! !

!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:53'!
mouseLeaveDragging: evt

	self mouseLeave: evt! !

!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 22:29'!
mouseUp: evt
	super mouseUp: evt.
	 (self containsPoint: evt cursorPoint) 
		ifFalse: [self mouseLeave: evt .
				" In the case of a balk,
				 we must also note that we have left
				 after color has been restored." ].
! !
RectangleMorph subclass: #RulerMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!RulerMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:38'!
drawOn: aCanvas

	| s |
	super drawOn: aCanvas.
	s _ self width printString, 'x', self height printString.
	aCanvas drawString: s in: (bounds insetBy: borderWidth + 5) font: nil color: Color red.
! !


!RulerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:50'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 1! !

!RulerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:50'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.8
		g: 1.0
		b: 1.0! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RulerMorph class
	instanceVariableNames: ''!

!RulerMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:52'!
descriptionForPartsBin
	^ self partName:	'Ruler'
		categories:		#('Useful')
		documentation:	'A rectangle which continuously reports its size in pixels'! !
ArrayedCollection subclass: #RunArray
	instanceVariableNames: 'runs values lastIndex lastRun lastOffset'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!RunArray commentStamp: '<historical>' prior: 0!
My instances provide space-efficient storage of data which tends to be constant over long runs of the possible indices. Essentially repeated values are stored singly and then associated with a "run" length that denotes the number of consecutive occurrences of the value.

My two important variables are
	runs	An array of how many elements are in each run
	values	An array of what the value is over those elements

The variables lastIndex, lastRun and lastOffset cache the last access
so that streaming through RunArrays is not an N-squared process.

Many complexities of access can be bypassed by using the method
	RunArray withStartStopAndValueDo:!
]style[(615 33)f1,f1LRunArray withStartStopAndValueDo:;!


!RunArray methodsFor: 'accessing' stamp: 'di 1/15/1999 00:04'!
= otherArray 
	"Test if all my elements are equal to those of otherArray"

	(otherArray isMemberOf: RunArray) ifFalse: [^ self hasEqualElements: otherArray].

	"Faster test between two RunArrays"
 	^ (runs hasEqualElements: otherArray runs)
		and: [values hasEqualElements: otherArray values]! !

!RunArray methodsFor: 'accessing'!
at: index

	self at: index setRunOffsetAndValue: [:run :offset :value | ^value]! !

!RunArray methodsFor: 'accessing' stamp: 'ar 10/16/2001 18:56'!
first
	^values at: 1! !

!RunArray methodsFor: 'accessing' stamp: 'ar 10/16/2001 18:56'!
last
	^values at: values size! !

!RunArray methodsFor: 'accessing'!
runLengthAt: index 
	"Answer the length remaining in run beginning at index."

	self at: index 
		setRunOffsetAndValue: [:run :offset :value | ^(runs at: run) - offset]! !

!RunArray methodsFor: 'accessing'!
size
	| size |
	size _ 0.
	1 to: runs size do: [:i | size _ size + (runs at: i)].
	^size! !

!RunArray methodsFor: 'accessing' stamp: 'di 11/10/97 13:34'!
withStartStopAndValueDo: aBlock
	| start stop |
	start _ 1.
	runs with: values do:
		[:len : val | stop _ start + len - 1.
		aBlock value: start value: stop value: val.
		start _ stop + 1]
		! !


!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:47'!
addFirst: value
	"Add value as the first element of the receiver."
	lastIndex _ nil.  "flush access cache"
	(runs size=0 or: [values first ~= value])
	  ifTrue:
		[runs _ {1}, runs.
		values _ {value}, values]
	  ifFalse:
		[runs at: 1 put: runs first+1]! !

!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 20:25'!
addLast: value
	"Add value as the last element of the receiver."
	lastIndex _ nil.  "flush access cache"
	(runs size=0 or: [values last ~= value])
	  ifTrue:
		[runs _ runs copyWith: 1.
		values _ values copyWith: value]
	  ifFalse:
		[runs at: runs size put: runs last+1]! !

!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:47'!
addLast: value  times: times
	"Add value as the last element of the receiver, the given number of times"
	times = 0 ifTrue: [ ^self ].
	lastIndex _ nil.  "flush access cache"
	(runs size=0 or: [values last ~= value])
	  ifTrue:
		[runs _ runs copyWith: times.
		values _ values copyWith: value]
	  ifFalse:
		[runs at: runs size put: runs last+times]! !

!RunArray methodsFor: 'adding' stamp: 'tk 1/28/98 09:28'!
coalesce
	"Try to combine adjacent runs"
	| ind |
	ind _ 2.
	[ind > values size] whileFalse: [
		(values at: ind-1) = (values at: ind) 
			ifFalse: [ind _ ind + 1]
			ifTrue: ["two are the same, combine them"
				values _ values copyReplaceFrom: ind to: ind with: #().
				runs at: ind-1 put: (runs at: ind-1) + (runs at: ind).
				runs _ runs copyReplaceFrom: ind to: ind with: #().
				"self error: 'needed to combine runs' "]].
			! !

!RunArray methodsFor: 'adding' stamp: 'BG 6/12/2003 11:07'!
rangeOf: attr startingAt: startPos
	"Answer an interval that gives the range of attr at index position  startPos. An empty interval with start value startPos is returned when the attribute attr is not present at position startPos.  self size > 0 is assumed, it is the responsibility of the caller to test for emptiness of self.
Note that an attribute may span several adjancent runs. "

	self at: startPos 
		setRunOffsetAndValue: 
            [:run :offset :value | 
               ^(value includes: attr)
                  ifFalse: [startPos to: startPos - 1]
                  ifTrue:
                    [ | firstRelevantPosition lastRelevantPosition idxOfCandidateRun |
                     lastRelevantPosition := startPos - offset + (runs at: run) - 1.
                     firstRelevantPosition := startPos - offset.
                     idxOfCandidateRun := run + 1.
                     [idxOfCandidateRun <= runs size 
                             and: [(values at: idxOfCandidateRun) includes: attr]]
                        whileTrue:
                          [lastRelevantPosition := lastRelevantPosition + (runs at: idxOfCandidateRun).
                           idxOfCandidateRun := idxOfCandidateRun + 1]. 
                     idxOfCandidateRun := run - 1.
                     [idxOfCandidateRun >= 1 
                             and: [(values at: idxOfCandidateRun) includes: attr]]
                        whileTrue:
                          [firstRelevantPosition := firstRelevantPosition - (runs at: idxOfCandidateRun).
                           idxOfCandidateRun := idxOfCandidateRun - 1]. 
 
                    firstRelevantPosition to: lastRelevantPosition]
		  ]! !

!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:48'!
repeatLast: times  ifEmpty: defaultBlock
	"add the last value back again, the given number of times.  If we are empty, add (defaultBlock value)"
	times = 0 ifTrue: [^self ].
	lastIndex _ nil.  "flush access cache"
	(runs size=0)
	  ifTrue:
		[runs _ runs copyWith: times.
		values _ values copyWith: defaultBlock value]
	  ifFalse:
		[runs at: runs size put: runs last+times] ! !

!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:48'!
repeatLastIfEmpty: defaultBlock
	"add the last value back again.  If we are empty, add (defaultBlock value)"
	lastIndex _ nil.  "flush access cache"
	(runs size=0)
	  ifTrue:[
		 runs _ runs copyWith: 1.
		values _ values copyWith: defaultBlock value]
	  ifFalse:
		[runs at: runs size put: runs last+1]! !


!RunArray methodsFor: 'converting' stamp: 'BG 6/8/2003 15:17'!
reversed

  ^self class runs: runs reversed values: values reversed! !


!RunArray methodsFor: 'copying' stamp: 'ar 10/16/2001 18:57'!
, aRunArray 
	"Answer a new RunArray that is a concatenation of the receiver and
	aRunArray."

	| new newRuns |
	(aRunArray isMemberOf: RunArray)
		ifFalse: 
			[new _ self copy.
			"attempt to be sociable"
			aRunArray do: [:each | new addLast: each].
			^new].
	runs size = 0 ifTrue: [^aRunArray copy].
	aRunArray runs size = 0 ifTrue: [^self copy].
	(values at: values size) ~= (aRunArray values at: 1)
		ifTrue: [^RunArray
					runs: runs , aRunArray runs
					values: values , aRunArray values].
	newRuns _ runs
					copyReplaceFrom: runs size
					to: runs size
					with: aRunArray runs.
	newRuns at: runs size put: (runs at: runs size) + (aRunArray runs at: 1).
	^RunArray
		runs: newRuns
		values: 
			(values
				copyReplaceFrom: values size
				to: values size
				with: aRunArray values)! !

!RunArray methodsFor: 'copying' stamp: 'ls 10/10/1999 13:15'!
copyFrom: start to: stop
	| newRuns run1 run2 offset1 offset2 | 
	stop < start ifTrue: [^RunArray new].
	self at: start setRunOffsetAndValue: [:r :o :value1 | run1 _ r. offset1
_ o.  value1].
	self at: stop setRunOffsetAndValue: [:r :o :value2 | run2 _ r. offset2
_ o. value2].
	run1 = run2
		ifTrue: 
			[newRuns _ Array with: offset2 - offset1 + 1]
		ifFalse: 
			[newRuns _ runs copyFrom: run1 to: run2.
			newRuns at: 1 put: (newRuns at: 1) - offset1.
			newRuns at: newRuns size put: offset2 + 1].
	^RunArray runs: newRuns values: (values copyFrom: run1 to: run2)! !

!RunArray methodsFor: 'copying'!
copyReplaceFrom: start to: stop with: replacement

	^(self copyFrom: 1 to: start - 1)
		, replacement 
		, (self copyFrom: stop + 1 to: self size)! !


!RunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:43'!
runsAndValuesDo: aBlock
	"Evaluate aBlock with run lengths and values from the receiver"
	^runs with: values do: aBlock.! !

!RunArray methodsFor: 'enumerating' stamp: 'ar 12/17/2001 00:00'!
runsFrom: start to: stop do: aBlock
	"Evaluate aBlock with all existing runs in the range from start to stop"
	| run value index |
	start > stop ifTrue:[^self].
	self at: start setRunOffsetAndValue:[:firstRun :offset :firstValue|
		run _ firstRun.
		value _ firstValue.
		index _ start + (runs at: run) - offset.
		[aBlock value: value.
		index <= stop] whileTrue:[
			run _ run + 1.
			value _ values at: run.
			index _ index + (runs at: run)]].
! !


!RunArray methodsFor: 'printing' stamp: 'sma 6/1/2000 09:47'!
printOn: aStream
	self printNameOn: aStream.
	aStream
		nextPutAll: ' runs: ';
		print: runs;
		nextPutAll: ' values: ';
		print: values! !

!RunArray methodsFor: 'printing'!
storeOn: aStream

	aStream nextPut: $(.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' runs: '.
	runs storeOn: aStream.
	aStream nextPutAll: ' values: '.
	values storeOn: aStream.
	aStream nextPut: $)! !

!RunArray methodsFor: 'printing'!
writeOn: aStream

	aStream nextWordPut: runs size.
	1 to: runs size do:
		[:x |
		aStream nextWordPut: (runs at: x).
		aStream nextWordPut: (values at: x)]! !

!RunArray methodsFor: 'printing' stamp: 'tk 12/16/97 09:18'!
writeScanOn: strm
	"Write out the format used for text runs in source files. (14 50 312)f1,f1b,f1LInteger +;i"

	strm nextPut: $(.
	runs do: [:rr | rr printOn: strm.  strm space].
	strm skip: -1; nextPut: $).
	values do: [:vv |
		vv do: [:att | att writeScanOn: strm].
		strm nextPut: $,].
	strm skip: -1.  "trailing comma"! !


!RunArray methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:49'!
isSelfEvaluating
	^ self class == RunArray! !


!RunArray methodsFor: 'private'!
at: index setRunOffsetAndValue: aBlock 
	"Supply all run information to aBlock."
	"Tolerates index=0 and index=size+1 for copyReplace: "
	| run limit offset |
	limit _ runs size.
	(lastIndex == nil or: [index < lastIndex])
		ifTrue:  "cache not loaded, or beyond index - start over"
			[run _ 1.
			offset _ index-1]
		ifFalse:  "cache loaded and before index - start at cache"
			[run _ lastRun.
			offset _ lastOffset + (index-lastIndex)].
	[run <= limit and: [offset >= (runs at: run)]]
		whileTrue: 
			[offset _ offset - (runs at: run).
			run _ run + 1].
	lastIndex _ index.  "Load cache for next access"
	lastRun _ run.
	lastOffset _ offset.
	run > limit
		ifTrue: 
			["adjustment for size+1"
			run _ run - 1.
			offset _ offset + (runs at: run)].
	^aBlock
		value: run	"an index into runs and values"
		value: offset	"zero-based offset from beginning of this run"
		value: (values at: run)	"value for this run"! !

!RunArray methodsFor: 'private'!
mapValues: mapBlock
	"NOTE: only meaningful to an entire set of runs"
	values _ values collect: [:val | mapBlock value: val]! !

!RunArray methodsFor: 'private'!
runs

	^runs! !

!RunArray methodsFor: 'private' stamp: 'ar 10/16/2001 18:47'!
setRuns: newRuns setValues: newValues
	lastIndex _ nil.  "flush access cache"
	runs _ newRuns asArray.
	values _ newValues asArray.! !

!RunArray methodsFor: 'private'!
values
	"Answer the values in the receiver."

	^values! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RunArray class
	instanceVariableNames: ''!

!RunArray class methodsFor: 'instance creation' stamp: 'ar 10/16/2001 19:03'!
new

	^self runs: Array new values: Array new! !

!RunArray class methodsFor: 'instance creation' stamp: 'ar 10/16/2001 19:04'!
new: size withAll: value 
	"Answer a new instance of me, whose every element is equal to the
	argument, value."

	size = 0 ifTrue: [^self new].
	^self runs: (Array with: size) values: (Array with: value)! !

!RunArray class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	| newCollection |
	newCollection _ self new.
	aCollection do: [:x | newCollection addLast: x].
	^newCollection

"	RunArray newFrom: {1. 2. 2. 3}
	{1. $a. $a. 3} as: RunArray
	({1. $a. $a. 3} as: RunArray) values
"! !

!RunArray class methodsFor: 'instance creation'!
readFrom: aStream
	"Answer an instance of me as described on the stream, aStream."

	| size runs values |
	size _ aStream nextWord.
	runs _ Array new: size.
	values _ Array new: size.
	1 to: size do:
		[:x |
		runs at: x put: aStream nextWord.
		values at: x put: aStream nextWord].
	^ self runs: runs values: values! !

!RunArray class methodsFor: 'instance creation'!
runs: newRuns values: newValues 
	"Answer an instance of me with runs and values specified by the 
	arguments."

	| instance |
	instance _ self basicNew.
	instance setRuns: newRuns setValues: newValues.
	^instance! !

!RunArray class methodsFor: 'instance creation' stamp: 'nk 9/3/2004 15:12'!
scanFrom: strm
	"Read the style section of a fileOut or sources file.  nextChunk has already been done.  We need to return a RunArray of TextAttributes of various kinds.  These are written by the implementors of writeScanOn:"
	| rr vv aa this |
	(strm peekFor: $( ) ifFalse: [^ nil].
	rr _ OrderedCollection new.
	[strm skipSeparators.
	 strm peekFor: $)] whileFalse: 
		[rr add: (Number readFrom: strm)].
	vv _ OrderedCollection new.	"Value array"
	aa _ OrderedCollection new.	"Attributes list"
	[(this _ strm next) == nil] whileFalse: [
		this == $, ifTrue: [vv add: aa asArray.  aa _ OrderedCollection new].
		this == $a ifTrue: [aa add: 
			(TextAlignment new alignment: (Integer readFrom: strm))].
		this == $f ifTrue: [aa add: 
			(TextFontChange new fontNumber: (Integer readFrom: strm))].
		this == $F ifTrue: [aa add: (TextFontReference toFont: 
			(StrikeFont familyName: (strm upTo: $#) size: (Integer readFrom: strm)))].
		this == $b ifTrue: [aa add: (TextEmphasis bold)].
		this == $i ifTrue: [aa add: (TextEmphasis italic)].
		this == $u ifTrue: [aa add: (TextEmphasis underlined)].
		this == $= ifTrue: [aa add: (TextEmphasis struckOut)].
		this == $n ifTrue: [aa add: (TextEmphasis normal)].
		this == $- ifTrue: [aa add: (TextKern kern: -1)].
		this == $+ ifTrue: [aa add: (TextKern kern: 1)].
		this == $c ifTrue: [aa add: (TextColor scanFrom: strm)]. "color"
		this == $L ifTrue: [aa add: (TextLink scanFrom: strm)].	"L not look like 1"
		this == $R ifTrue: [aa add: (TextURL scanFrom: strm)].
				"R capitalized so it can follow a number"
		this == $q ifTrue: [aa add: (TextSqkPageLink scanFrom: strm)].
		this == $p ifTrue: [aa add: (TextSqkProjectLink scanFrom: strm)].
		this == $P ifTrue: [aa add: (TextPrintIt scanFrom: strm)].
		this == $d ifTrue: [aa add: (TextDoIt scanFrom: strm)].
		"space, cr do nothing"
		].
	aa size > 0 ifTrue: [vv add: aa asArray].
	^ self runs: rr asArray values: vv asArray
"
RunArray scanFrom: (ReadStream on: '(14 50 312)f1,f1b,f1LInteger +;i')
"! !
TestCase subclass: #RunArrayTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Arrayed'!

!RunArrayTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 09:13'!
testScanFromANSICompatibility
	"self run: #testScanFromANSICompatibility"

	RunArray scanFrom: (ReadStream on: '()f1dNumber new;;').
	RunArray scanFrom: (ReadStream on: '()a1death;;').
	RunArray scanFrom: (ReadStream on: '()F1death;;').! !
Model subclass: #SARInstaller
	instanceVariableNames: 'zip directory fileName installed'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!SARInstaller commentStamp: 'nk 7/5/2003 21:12' prior: 0!
I am an object that handles the loading of SAR (Squeak ARchive) files.

A SAR file is a Zip file that follows certain simple conventions:

* it may have a member named "install/preamble".

This member, if present, will be filed in as Smalltalk source code at the beginning of installation.
Typically, the code in the preamble will make whatever installation preparations are necessary,
and will then call methods in the "client services" method category to extract or install other zip members.

* It may have a member named "install/postscript".

This member, if present, will be filed in as Smalltalk source code at the end of installation.
Typically, the code in the postscript will set up the operating environment,
and will perhaps put objects in flaps, open projects or README files, or launch samples.

Within the code in the preamble and postscript, "self" is set to the instance of the SARInstaller.

If neither an "install/preamble" nor an "install/postscript" file is present,
all the members will be installed after prompting the user,
based on a best guess of the member file types that is based on member filename extensions.

This is new behavior.!


!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'!
directory
	^directory! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'!
directory: anObject
	directory := anObject! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'!
fileName
	^fileName! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'!
fileName: anObject
	fileName := anObject! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 23:01'!
installedMemberNames
	"Answer the names of the zip members that have been installed already."
	^self installedMembers collect: [ :ea | ea fileName ]! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/10/2003 16:53'!
installedMembers
	"Answer the zip members that have been installed already."
	^installed ifNil: [ installed _ OrderedCollection new ]! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 21:57'!
memberNames
	^self zip memberNames! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 23:00'!
uninstalledMemberNames
	"Answer the names of the zip members that have not yet been installed."
	^self uninstalledMembers collect: [ :ea | ea fileName ]! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/10/2003 16:55'!
uninstalledMembers
	"Answer the zip members that haven't been installed or extracted yet."
	^zip members copyWithoutAll: self installedMembers! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'!
zip
	^zip! !

!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'!
zip: anObject
	^zip := anObject! !


!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:25'!
extractMember: aMemberOrName
	"Extract aMemberOrName to a file using its filename"
	(self zip extractMember: aMemberOrName)
		ifNil: [ self errorNoSuchMember: aMemberOrName ]
		ifNotNil: [ self installed: aMemberOrName ].! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:25'!
extractMember: aMemberOrName toFileNamed: aFileName
	"Extract aMemberOrName to a specified filename"
	(self zip extractMember: aMemberOrName toFileNamed: aFileName)
		ifNil: [ self errorNoSuchMember: aMemberOrName ]
		ifNotNil: [ self installed: aMemberOrName ].! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:40'!
extractMemberWithoutPath: aMemberOrName
	"Extract aMemberOrName to its own filename, but ignore any directory paths, using my directory instead."
	self extractMemberWithoutPath: aMemberOrName inDirectory: self directory.
! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:40'!
extractMemberWithoutPath: aMemberOrName inDirectory: aDirectory
	"Extract aMemberOrName to its own filename, but ignore any directory paths, using aDirectory instead"
	| member |
	member _ self memberNamed: aMemberOrName.
	member ifNil: [ ^self errorNoSuchMember: aMemberOrName ].
	self zip extractMemberWithoutPath: member inDirectory: aDirectory.
	self installed: member.! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 2/13/2004 12:12'!
fileInGenieDictionaryNamed: memberName 
	"This is to be used from preamble/postscript code to file in zip 
	members as Genie gesture dictionaries.
	Answers a dictionary."

	| member object crDictionary stream |

	crDictionary _ Smalltalk at: #CRDictionary ifAbsent: [ ^self error: 'Genie not installed' ].
	"don't know how to recursively load"

	member _ self memberNamed: memberName.
	member ifNil: [ ^self errorNoSuchMember: memberName ].

	stream _ ReferenceStream on: member contentStream.

	[ object _ stream next ]
		on: Error do: 
		[:ex |  stream close.
		self inform: 'Error on loading: ' , ex description. ^ nil ].
	stream close.

	(object notNil and: [object name isEmptyOrNil])
		ifTrue: [object _ crDictionary name: object storedName].

	self installed: member.

	^ object
! !

!SARInstaller methodsFor: 'client services' stamp: 'yo 8/17/2004 10:01'!
fileInMemberNamed: csName
	"This is to be used from preamble/postscript code to file in zip members as ChangeSets."
	| cs |
	cs _ self memberNamed: csName.
	cs ifNil: [ ^self errorNoSuchMember: csName ].
	self class fileIntoChangeSetNamed: csName fromStream: cs contentStream text setConverterForCode.
	self installed: cs.
! !

!SARInstaller methodsFor: 'client services' stamp: 'ar 9/27/2005 20:10'!
fileInMonticelloPackageNamed: memberName 
	"This is to be used from preamble/postscript code to file in zip 
	members as Monticello packages (.mc)."

	| member file mcPackagePanel mcRevisionInfo mcSnapshot mcFilePackageManager mcPackage info snapshot newCS mcBootstrap |

	mcPackagePanel := Smalltalk at: #MCPackagePanel ifAbsent: [ ].
	mcRevisionInfo := Smalltalk at: #MCRevisionInfo ifAbsent: [ ].
	mcSnapshot := Smalltalk at: #MCSnapshot ifAbsent: [ ].
	mcFilePackageManager := Smalltalk at: #MCFilePackageManager ifAbsent: [ ].
	mcPackage := Smalltalk at: #MCPackage ifAbsent: [ ].
	member := self memberNamed: memberName.
	member ifNil: [ ^self errorNoSuchMember: memberName ].

	"We are missing MCInstaller, Monticello and/or MonticelloCVS.
	If the bootstrap is present, use it. Otherwise interact with the user."
	({ mcPackagePanel. mcRevisionInfo. mcSnapshot. mcFilePackageManager. mcPackage } includes: nil)
		ifTrue: [
			mcBootstrap := self getMCBootstrapLoaderClass.
			mcBootstrap ifNotNil: [ ^self fileInMCVersion: member withBootstrap: mcBootstrap ].

			(self confirm: ('Monticello support is not installed, but must be to load member named ', memberName, '.
Load it from SqueakMap?'))
				ifTrue: [ self class loadMonticello; loadMonticelloCVS.
					^self fileInMonticelloPackageNamed: memberName ]
				ifFalse: [ ^false ] ].

	member extractToFileNamed: member localFileName inDirectory: self directory.
	file := (Smalltalk at: #MCFile)
				name: member localFileName
				directory: self directory.

	self class withCurrentChangeSetNamed: file name do: [ :cs |
		newCS := cs.
		file readStreamDo: [ :stream |
			info := mcRevisionInfo readFrom: stream nextChunk.
			snapshot := mcSnapshot fromStream: stream ].
			snapshot install.
			(mcFilePackageManager forPackage:
				(mcPackage named: info packageName))
					file: file
		].

	newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ].

	mcPackagePanel allSubInstancesDo: [ :ea | ea refresh ].
	World doOneCycle.

	self installed: member.
! !

!SARInstaller methodsFor: 'client services' stamp: 'ar 9/27/2005 20:10'!
fileInMonticelloVersionNamed: memberName 
	"This is to be used from preamble/postscript code to file in zip 
	members as Monticello version (.mcv) files."

	| member newCS mcMcvReader |
	mcMcvReader := Smalltalk at: #MCMcvReader ifAbsent: [].
	member := self memberNamed: memberName.
	member ifNil: [^self errorNoSuchMember: memberName].

	"If we don't have Monticello, offer to get it."
	mcMcvReader ifNil:  [
		(self confirm: 'Monticello is not installed, but must be to load member named ', memberName , '.
Load it from SqueakMap?') 
			ifTrue:  [ self class loadMonticello.
						^self fileInMonticelloVersionNamed: memberName]
					ifFalse: [^false]].

	self class withCurrentChangeSetNamed: member localFileName
		do: 
			[:cs | 
			newCS := cs.
			(mcMcvReader versionFromStream: member contentStream ascii) load ].
	newCS isEmpty ifTrue: [ChangeSet removeChangeSet: newCS].
	World doOneCycle.
	self installed: member! !

!SARInstaller methodsFor: 'client services' stamp: 'ar 9/27/2005 20:10'!
fileInMonticelloZipVersionNamed: memberName 
	"This is to be used from preamble/postscript code to file in zip 
	members as Monticello version (.mcz) files."

	| member mczInstaller newCS mcMczReader |
	mcMczReader := Smalltalk at: #MCMczReader ifAbsent: [].
	mczInstaller := Smalltalk at: #MczInstaller ifAbsent: [].
	member := self memberNamed: memberName.
	member ifNil: [^self errorNoSuchMember: memberName].

	"If we don't have Monticello, but have the bootstrap, use it silently."
	mcMczReader ifNil:  [
		mczInstaller ifNotNil: [ ^mczInstaller installStream: member contentStream ].
		(self confirm: 'Monticello is not installed, but must be to load member named ', memberName , '.
Load it from SqueakMap?') 
			ifTrue:  [ self class loadMonticello.
						^self fileInMonticelloZipVersionNamed: memberName]
					ifFalse: [^false]].

	self class withCurrentChangeSetNamed: member localFileName
		do: 
			[:cs | 
			newCS := cs.
			(mcMczReader versionFromStream: member contentStream) load ].
	newCS isEmpty ifTrue: [ChangeSet removeChangeSet: newCS].
	World doOneCycle.
	self installed: member! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:27'!
fileInMorphsNamed: memberName addToWorld: aBoolean
	"This will load the Morph (or Morphs) from the given member.
	Answers a Morph, or a list of Morphs, or nil if no such member or error.
	If aBoolean is true, also adds them and their models to the World."

	| member morphOrList |
	member _ self memberNamed: memberName.
	member ifNil: [ ^self errorNoSuchMember: memberName ].
	self installed: member.

	morphOrList _ member contentStream fileInObjectAndCode.
	morphOrList ifNil: [ ^nil ].
	aBoolean ifTrue: [ ActiveWorld addMorphsAndModel: morphOrList ].

	^morphOrList
! !

!SARInstaller methodsFor: 'client services' stamp: 'yo 8/17/2004 10:05'!
fileInPackageNamed: memberName 
	"This is to be used from preamble/postscript code to file in zip 
	members as DVS packages."
	| member current new baseName imagePackageLoader packageInfo streamPackageLoader packageManager |
	member _ self zip memberNamed: memberName.
	member ifNil: [ ^self errorNoSuchMember: memberName ].

	imagePackageLoader _ Smalltalk at: #ImagePackageLoader ifAbsent: [].
	streamPackageLoader _ Smalltalk at: #StreamPackageLoader ifAbsent: [].
	packageInfo _ Smalltalk at: #PackageInfo ifAbsent: [].
	packageManager _ Smalltalk at: #FilePackageManager ifAbsent: [].

	"If DVS isn't present, do a simple file-in"
	(packageInfo isNil or: [imagePackageLoader isNil or: [streamPackageLoader isNil]])
		ifTrue: [ ^ self fileInMemberNamed: memberName ].

	baseName _ memberName copyReplaceAll: '.st' with: '' asTokens: false.
	(packageManager allManagers anySatisfy: [ :pm | pm packageName = baseName ])
		ifTrue: [
			current _ imagePackageLoader new package: (packageInfo named: baseName).
			new _ streamPackageLoader new stream: member contentStream ascii.
			(new changesFromBase: current) fileIn ]
		ifFalse: [ self class fileIntoChangeSetNamed: baseName fromStream: member contentStream ascii setConverterForCode. ].

	packageManager registerPackage: baseName.

	self installed: member.! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 7/27/2003 09:49'!
fileInProjectNamed: projectOrMemberName createView: aBoolean 
	"This is to be used from preamble/postscript code to file in SAR members 
	as Projects. 
	Answers the loaded project, or nil. 
	Does not enter the loaded project. 
	If aBoolean is true, also creates a ProjectViewMorph 
	(possibly in a window, depending on your Preferences)."
	| member project triple memberName |
	member _ self memberNamed: projectOrMemberName.
	member
		ifNotNil: [ memberName _ member fileName ]
		ifNil: [ 	member _ self memberNamed: (memberName _ self memberNameForProjectNamed: projectOrMemberName) ].
	member ifNil: [ ^self errorNoSuchMember: projectOrMemberName ].
	triple _ Project parseProjectFileName: memberName unescapePercents.
	project _ nil.
	[[ProjectLoading
		openName: triple first
		stream: member contentStream
		fromDirectory: nil
		withProjectView: nil]
		on: ProjectViewOpenNotification
		do: [:ex | ex resume: aBoolean]]
		on: ProjectEntryNotification
		do: [:ex | 
			project _ ex projectToEnter.
			ex resume].
	self installed: member.
	^ project! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 9/26/2003 17:17'!
fileInTrueTypeFontNamed: memberOrName

	| member description |
	member := self memberNamed: memberOrName.
	member ifNil: [^self errorNoSuchMember: memberOrName].

	description _ TTFontDescription addFromTTStream: member contentStream.
	TTCFont newTextStyleFromTT: description.

	World doOneCycle.
	self installed: member! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 9/9/2003 11:56'!
getMCBootstrapLoaderClass
	^Smalltalk at: #MCBootstrapLoader
		ifAbsent: 
			[(self memberNamed: 'MCBootstrapLoader.st') 
				ifNotNilDo: [:m | self fileInMemberNamed: m.
					Smalltalk at: #MCBootstrapLoader ifAbsent: []]]! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 10/14/2003 15:40'!
importImage: memberOrName
	| member form |
	member _ self memberNamed: memberOrName.
	member ifNil: [ ^self errorNoSuchMember: memberOrName ].
	form _ ImageReadWriter formFromStream: member contentStream binary.
	form ifNil: [ ^self ].
	Imports default importImage: form named: (FileDirectory localNameFor: member fileName) sansPeriodSuffix.
	self installed: member.! !

!SARInstaller methodsFor: 'client services' stamp: 'tak 1/24/2005 19:12'!
installMember: memberOrName
	| memberName extension isGraphic stream member |
	member _ self memberNamed: memberOrName.
	member ifNil: [ ^false ].
	memberName _ member fileName.
	extension _ (FileDirectory extensionFor: memberName) asLowercase.
	Smalltalk at: #CRDictionary ifPresent: [ :crDictionary |
		(extension = crDictionary fileNameSuffix) ifTrue: [  self fileInGenieDictionaryNamed: memberName. ^true ] ].
	extension caseOf: {
		[ Project projectExtension ] -> [ self fileInProjectNamed: memberName createView: true ].
		[ FileStream st ] -> [ self fileInPackageNamed: memberName ].
		[ FileStream cs ] -> [  self fileInMemberNamed: memberName  ].
"		[ FileStream multiSt ] -> [  self fileInMemberNamedAsUTF8: memberName  ].
		[ FileStream multiCs ] -> [  self fileInMemberNamedAsUTF8: memberName  ].
"
		[ 'mc' ] -> [ self fileInMonticelloPackageNamed: memberName ].
		[ 'mcv' ] -> [ self fileInMonticelloVersionNamed: memberName ].
		[ 'mcz' ] -> [ self fileInMonticelloZipVersionNamed: memberName ].
		[ 'morph' ] -> [ self fileInMorphsNamed: member addToWorld: true ].
		[ 'ttf' ] -> [ self fileInTrueTypeFontNamed: memberName ].
		[ 'translation' ] -> [  self fileInMemberNamed: memberName  ].
	} otherwise: [
		('t*xt' match: extension) ifTrue: [ self openTextFile: memberName ]
			ifFalse: [ stream _ member contentStream.
		isGraphic _ ImageReadWriter understandsImageFormat: stream.
		stream reset.
		isGraphic
			ifTrue: [ self openGraphicsFile: member ]
			ifFalse: [ "now what?" ^false ]]
	].
	^true
! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 10:02'!
memberNameForProjectNamed: projectName
	"Answer my member name for the given project, or nil.
	Ignores version numbers and suffixes, and also unescapes percents in filenames."

	^self zip memberNames detect: [ :memberName | | triple |
		triple _ Project parseProjectFileName: memberName unescapePercents.
		triple first asLowercase = projectName asLowercase
	] ifNone: [ nil ].! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 10/14/2003 18:58'!
memberNamed: aString
	^(zip member: aString)
		ifNil: [ | matching |
			matching _ zip membersMatching: aString.
			matching isEmpty ifFalse: [ matching last ]].! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:34'!
membersMatching: aString
	^self zip membersMatching: aString! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 6/12/2004 10:03'!
openGraphicsFile: memberOrName
	| member morph |
	member _ self memberNamed: memberOrName.
	member ifNil: [ ^self errorNoSuchMember: memberOrName ].
	morph _ (World drawingClass fromStream: member contentStream binary).
	morph ifNotNil: [ morph openInWorld ].
	self installed: member.! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:28'!
openTextFile: memberOrName
	"Open a text window on the given member"
	| member |
	member _ self memberNamed: memberOrName.
	member ifNil: [ ^self errorNoSuchMember: memberOrName ].
	StringHolder new
		acceptContents: member contents;
		openLabel: member fileName.
	self installed: member.! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:36'!
prependedDataSize
	^self zip prependedDataSize! !

!SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:35'!
zipFileComment
	^self zip zipFileComment! !


!SARInstaller methodsFor: 'fileIn' stamp: 'ar 9/27/2005 20:10'!
fileIn
	"File in to a change set named like my file"
	| stream newCS |
	stream := directory readOnlyFileNamed: fileName.
	self class withCurrentChangeSetNamed: fileName
		do: [:cs | newCS := cs. self fileInFrom: stream].
	newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ]! !

!SARInstaller methodsFor: 'fileIn' stamp: 'yo 8/17/2004 00:33'!
fileInFrom: stream
	"The zip has been saved already by the download.
	Read the zip into my instvar, then file in the correct members"

	| preamble postscript |

	[
		stream position: 0.
		zip _ ZipArchive new readFrom: stream.

		preamble _ zip memberNamed: 'install/preamble'.
		preamble ifNotNil: [
			preamble contentStream text setConverterForCode fileInFor: self announcing: 'Preamble'.
			self class currentChangeSet preambleString: preamble contents.
		].

		postscript _ zip memberNamed: 'install/postscript'.
		postscript ifNotNil: [
			postscript contentStream text setConverterForCode fileInFor: self announcing: 'Postscript'.
			self class currentChangeSet postscriptString: postscript contents.
		].

		preamble isNil & postscript isNil ifTrue: [
			(self confirm: 'No install/preamble or install/postscript member were found.
	Install all the members automatically?') ifTrue: [ self installAllMembers ]
		].

	] ensure: [ stream close ].

! !

!SARInstaller methodsFor: 'fileIn' stamp: 'nk 7/27/2003 14:02'!
fileIntoChangeSetNamed: aString fromStream: stream
	"Not recommended for new code"
	^self class fileIntoChangeSetNamed: aString fromStream: stream! !

!SARInstaller methodsFor: 'fileIn' stamp: 'nk 10/12/2003 20:41'!
installAllMembers
	"Try to install all the members, in order, based on their filenames and/or contents."
	| uninstalled |
	uninstalled _ OrderedCollection new.
	zip members do: [ :member | self installMember: member ].
	uninstalled _ self uninstalledMembers.
	uninstalled isEmpty ifTrue: [ ^self ].
	uninstalled inspect.! !


!SARInstaller methodsFor: 'initialization' stamp: 'nk 7/5/2003 22:24'!
initialize
	installed _ OrderedCollection new.! !


!SARInstaller methodsFor: 'private' stamp: 'nk 10/13/2003 12:56'!
errorNoSuchMember: aMemberName
	(self confirm: 'No member named ', aMemberName, '. Do you want to stop loading?')
		== true ifTrue: [ self error: 'aborted' ].! !

!SARInstaller methodsFor: 'private' stamp: 'ar 9/27/2005 20:10'!
fileInMCVersion: member withBootstrap: mcBootstrap
	"This will use the MCBootstrapLoader to load a (non-compressed) Monticello file (.mc or .mcv)"
	| newCS |
	self class withCurrentChangeSetNamed: member localFileName
		do: [ :cs | 
			newCS := cs.
			mcBootstrap loadStream: member contentStream ascii ].

	newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ].

	World doOneCycle.

	self installed: member.! !

!SARInstaller methodsFor: 'private' stamp: 'nk 7/10/2003 16:55'!
installed: aMemberOrName
	self installedMembers add: (self zip member: aMemberOrName)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SARInstaller class
	instanceVariableNames: ''!

!SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 10/27/2002 12:44'!
basicNewChangeSet: newName
	Smalltalk at: #ChangeSorter ifPresentAndInMemory: [ :cs | ^cs basicNewChangeSet: newName ].
	(self changeSetNamed: newName) ifNotNil: [ self inform: 'Sorry that name is already used'. ^nil ].
	^ChangeSet basicNewNamed: newName.! !

!SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 10/27/2002 12:44'!
changeSetNamed: newName
	Smalltalk at: #ChangeSorter ifPresentAndInMemory: [ :cs | ^cs changeSetNamed: newName ].
	^ChangeSet allInstances detect: [ :cs | cs name = newName ] ifNone: [ nil ].! !

!SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 7/5/2003 22:49'!
currentChangeSet
	"Answer the current change set, in a way that should work in 3.5 as well"

	"SARInstaller currentChangeSet"

	^[ ChangeSet current ]
		on: MessageNotUnderstood
		do: [ :ex | ex return: Smalltalk changes ]! !

!SARInstaller class methodsFor: 'change set utilities' stamp: 'yo 8/17/2004 10:04'!
fileIntoChangeSetNamed: aString fromStream: stream 
	"We let the user confirm filing into an existing ChangeSet
	or specify another ChangeSet name if
	the name derived from the filename already exists.
	Duplicated from SMSimpleInstaller.
	Should be a class-side method."

	^self withCurrentChangeSetNamed: aString
		do: [ :cs | | newName |
			newName := cs name.
			stream setConverterForCode.
			stream 
				fileInAnnouncing: 'Loading ' , newName , ' into change set ''' , newName, ''''.
			stream close]! !

!SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 7/5/2003 22:51'!
newChanges: aChangeSet
	"Change the current change set, in a way that should work in 3.5 as well"
	"SARInstaller newChanges: SARInstaller currentChangeSet"

	^[ ChangeSet newChanges: aChangeSet ]
		on: MessageNotUnderstood
		do: [ :ex | ex return: (Smalltalk newChanges: aChangeSet) ]! !

!SARInstaller class methodsFor: 'change set utilities' stamp: 'rbb 3/1/2005 11:11'!
withCurrentChangeSetNamed: aString do: aOneArgumentBlock 
	"Evaluate the one-argument block aOneArgumentBlock while the named change set is active.
	We let the user confirm operating on an existing ChangeSet 
	or specify another ChangeSet name if 
	the name derived from the filename already exists. 
	Duplicated from SMSimpleInstaller. 
	Returns change set."

	| changeSet newName oldChanges |
	newName := aString.
	changeSet := self changeSetNamed: newName.
	changeSet ifNotNil: 
			[newName := UIManager default 
						request: 'ChangeSet already present, just confirm to overwrite or enter a new name:'
						initialAnswer: newName.
			newName isEmpty ifTrue: [self error: 'Cancelled by user'].
			changeSet := self changeSetNamed: newName].
	changeSet ifNil: [changeSet := self basicNewChangeSet: newName].
	changeSet 
		ifNil: [self error: 'User did not specify a valid ChangeSet name'].
	oldChanges := self currentChangeSet.
	
	[ self newChanges: changeSet.
	aOneArgumentBlock value: changeSet] 
			ensure: [ self newChanges: oldChanges].
	^changeSet! !


!SARInstaller class methodsFor: 'class initialization' stamp: 'nk 11/13/2002 07:33'!
fileReaderServicesForFile: fullName suffix: suffix 

	^(suffix = 'sar') | (suffix = '*') 
		ifTrue: [Array with: self serviceFileInSAR]
		ifFalse: [#()]
! !

!SARInstaller class methodsFor: 'class initialization' stamp: 'nk 7/5/2003 22:22'!
initialize
	"SARInstaller initialize"
	(FileList respondsTo: #registerFileReader:)
		ifTrue: [ FileList registerFileReader: self ]! !

!SARInstaller class methodsFor: 'class initialization' stamp: 'nk 7/5/2003 21:05'!
installSAR: relativeOrFullName
	FileDirectory splitName: (FileDirectory default fullNameFor: relativeOrFullName)
		to: [ :dir :fileName | (self directory: (FileDirectory on: dir) fileName: fileName) fileIn ]! !

!SARInstaller class methodsFor: 'class initialization' stamp: 'nk 11/13/2002 07:35'!
serviceFileInSAR
	"Answer a service for opening a changelist browser on a file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'install SAR'
		selector: #installSAR:
		description: 'install this Squeak ARchive into the image.'
		buttonLabel: 'install'! !

!SARInstaller class methodsFor: 'class initialization' stamp: 'nk 11/21/2002 09:46'!
services
	^Array with: self serviceFileInSAR
! !

!SARInstaller class methodsFor: 'class initialization' stamp: 'nk 7/5/2003 22:22'!
unload

	(FileList respondsTo: #unregisterFileReader:)
		ifTrue: [ FileList unregisterFileReader: self ]! !


!SARInstaller class methodsFor: 'instance creation' stamp: 'nk 10/27/2002 10:29'!
directory: dir fileName: fn
	^(self new) directory: dir; fileName: fn; yourself.! !


!SARInstaller class methodsFor: 'package format support' stamp: 'ar 9/27/2005 20:11'!
ensurePackageWithId: anIdString

	self squeakMapDo: [ :sm | | card newCS |
		self withCurrentChangeSetNamed: 'updates' do: [ :cs |
			newCS := cs.
			card := sm cardWithId: anIdString.
			(card isNil or: [ card isInstalled not or: [ card isOld ]])
				ifTrue: [ sm installPackageWithId: anIdString ]
		].
		newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ]
	].! !

!SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 14:05'!
loadDVS
	"Load the DVS support from SqueakMap"

	self ensurePackageWithId: '100d59d0-bf81-4e74-a4fe-5a2fd0c6b4ec'! !

!SARInstaller class methodsFor: 'package format support' stamp: 'nk 9/9/2003 12:08'!
loadMonticello
	"Load Monticello support (MCInstaller and Monticello) from SqueakMap"

	self ensurePackageWithId: 'af9d090d-2896-4a4e-82d0-c61cf2fdf40e'.
	self ensurePackageWithId: '66236497-7026-45f5-bcf6-ad00ba7a8a4e'.! !

!SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 14:39'!
loadMonticelloCVS
	"Load MonticelloCVS support from SqueakMap"

	self ensurePackageWithId: '2be9f7e2-1de2-4eb6-89bd-ec9b60593a93'.
! !

!SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 08:27'!
squeakMapDo: aBlock
	"If SqueakMap is installed, evaluate aBlock with the default map.
	Otherwise, offer to install SqueakMap and continue."

	Smalltalk at: #SMSqueakMap ifPresent: [ :smClass | ^aBlock value: smClass default ].

	(self confirm: 'SqueakMap is not installed in this image.
Would you like to load it from the network?')
		ifTrue: [ TheWorldMenu loadSqueakMap.
			^self squeakMapDo: aBlock ].

	^nil! !


!SARInstaller class methodsFor: 'SqueakMap' stamp: 'nk 7/21/2003 17:21'!
cardForSqueakMap: aSqueakMap
	"Answer the current card or a new card."

	(aSqueakMap cardWithId: self squeakMapPackageID)
		ifNotNilDo: [ :card |
			(card installedVersion = self squeakMapPackageVersion) ifTrue: [ ^card ]
		].

	^self newCardForSqueakMap: aSqueakMap
! !

!SARInstaller class methodsFor: 'SqueakMap' stamp: 'nk 7/21/2003 17:17'!
newCardForSqueakMap: aSqueakMap
	"Answer a new card."

	^(aSqueakMap newCardWithId: self squeakMapPackageID)
	created: 3236292323
	updated:3236292323
	name: 'SARInstaller for 3.6'
	currentVersion:'16'
	summary: 'Lets you load SAR (Squeak ARchive) files from SqueakMap and the File List. For 3.6 and later images.'
	description:'Support for installing SAR (Squeak ARchive) packages from SqueakMap and the File List.
For 3.6 and later images.

SMSARInstaller will use this if it''s present to load SAR packages.

Use SARBuilder for making these packages easily.'
	url: 'http://bike-nomad.com/squeak/'
	downloadUrl:'http://bike-nomad.com/squeak/SARInstallerFor36-nk.16.cs.gz'
	author: 'Ned Konz <ned@bike-nomad.com>'
	maintainer:'Ned Konz <ned@bike-nomad.com>'
	registrator:'Ned Konz <ned@bike-nomad.com>'
	password:240495131608326995113451940367316491071470713347
	categories: #('6ba57b6e-946a-4009-beaa-0ac93c08c5d1' '94277ca9-4d8f-4f0e-a0cb-57f4b48f1c8a' 'a71a6233-c7a5-4146-b5e3-30f28e4d3f6b' '8209da9b-8d6e-40dd-b23a-eb7e05d4677b' );
	modulePath: ''
	moduleVersion:''
	moduleTag:''
	versionComment:'v16: same as v16 of SARInstaller for 3.4 but doesn''t include any classes other than SARInstaller.

To be loaded into 3.6 images only. Will de-register the 3.4 version if it''s registered.

Added a default (DWIM) mode in which SAR files that are missing both a preamble and postscript have all their members loaded in a default manner.

Changed the behavior of #extractMemberWithoutPath: to use the same directory as the SAR itself.

Added #extractMemberWithoutPath:inDirectory:

Moved several change set methods to the class side.

Made change set methods work with 3.5 or 3.6a/b

Now supports the following file types:

Projects (with or without construction of a ViewMorph)
Genie gesture dictionaries
Change sets
DVS packages
Monticello packages
Graphics files (loaded as SketchMorphs)
Text files (loaded as text editor windows)
Morph(s) in files

Now keeps track of installed members.'! !

!SARInstaller class methodsFor: 'SqueakMap' stamp: 'nk 7/21/2003 17:16'!
squeakMapPackageID
	^'75c970ab-dca7-48ee-af42-5a013912c880'! !

!SARInstaller class methodsFor: 'SqueakMap' stamp: 'nk 7/21/2003 17:18'!
squeakMapPackageVersion
	^'16'! !
SMRootedObject subclass: #SMAccount
	instanceVariableNames: 'initials email signature password newPassword advogatoId objects coObjects isAdmin'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMAccount commentStamp: '<historical>' prior: 0!
SMAccount is the object representing a user account in SqueakMap - a Squeaker that owns information in SqueakMap.

It keeps track of the email address, developer initials and two passwords used to access the account. There is also an advogatoId (people.squeakfoundation.org username) and a signature field (not used yet). The flag isAdmin is a crude way of marking a user as a superuser, this will possibly be changed in the future and instead expressed using a category.

Passwords are stored as secure hashes. The extra password (newPassword) is used when the regular password is forgotten - it is then randomly set and an email is sent out containing it to the registered email. This enables the original password to still work. When logging in, the user gets a chance to enter a new regular password overwriting the old one and clearing the random new password in the process.

The instvar objects holds all SMPersonalObjects (instances of subclasses) that this account "owns" - these are typically instances of SMPackages and SMResources, but are not limited to be.

The instvar coObjects holds all SMPersonalObjects that this account is co-maintaining - these are typically instances of SMPackages and SMResources.

Finally the account also maintains a directory with uploaded files on the server. This directory has the UUID of the account as its name and it is located under sm/accounts!


!SMAccount methodsFor: 'accessing' stamp: 'gk 11/13/2003 23:06'!
advogatoId
	^advogatoId! !

!SMAccount methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
advogatoId: aString
	advogatoId := aString! !

!SMAccount methodsFor: 'accessing' stamp: 'gk 6/26/2003 14:26'!
email
	^email! !

!SMAccount methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
email: address
	email := address! !

!SMAccount methodsFor: 'accessing' stamp: 'gk 7/30/2003 14:10'!
initials
	^initials! !

!SMAccount methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
initials: aString
	"If these are changed we need to update the dictionary in the map."

	initials ~= aString ifTrue: [
		initials := aString.
		map clearUsernames]! !

!SMAccount methodsFor: 'accessing' stamp: 'gk 11/17/2003 11:49'!
isAdmin
	^isAdmin ifNil: [false] ifNotNil: [isAdmin]! !

!SMAccount methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
isAdmin: aBoolean
	isAdmin := aBoolean! !

!SMAccount methodsFor: 'accessing' stamp: 'gk 11/24/2005 11:09'!
nameAndEmail
	"This is not really correct, the name needs to be
	mime encoded."

	^name , ' <', email, '>'! !

!SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 16:34'!
newPassword
	"Get the parallell password hash."

	^newPassword! !

!SMAccount methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
newPassword: aHashNumber
	"Set the parallell password hash."

	newPassword := aHashNumber! !

!SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 15:42'!
password
	"Get the password hash."

	^password! !

!SMAccount methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
password: aHashNumber
	"Set the password hash."

	password := aHashNumber! !

!SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 15:56'!
signature
	"Get the signature."

	^signature! !

!SMAccount methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
signature: aSignature
	"Set the signature."

	signature := aSignature! !


!SMAccount methodsFor: 'files' stamp: 'gk 3/8/2004 19:26'!
delete
	"Delete this account. First delete all SM objects we own
	and disconnect this account from those we co-maintain."

	objects do: [:o | o delete].
	coObjects do: [:co | co removeMaintainer: self].
	super delete
! !

!SMAccount methodsFor: 'files' stamp: 'stephaneducasse 2/4/2006 20:38'!
deleteFiles: fileNames
	"Delete all fileNames from the uploads directory."

	| dir |
	dir := self uploadsDirectory.
	fileNames do: [:fn | dir deleteFileNamed: fn]
! !

!SMAccount methodsFor: 'files' stamp: 'stephaneducasse 2/4/2006 20:38'!
directory
	"Get the directory for the account."

	| dir |
	dir := (map directory directoryNamed: 'accounts') assureExistence; yourself.
	^(dir directoryNamed: id asString) assureExistence; yourself
! !

!SMAccount methodsFor: 'files' stamp: 'gk 3/8/2004 19:26'!
entries
	"Return all file entries in the upload directory."

	^self uploadsDirectory entries! !

!SMAccount methodsFor: 'files' stamp: 'gk 8/15/2003 12:08'!
files
	"Return filenames for uploaded files."

	^self uploadsDirectory fileNames
! !

!SMAccount methodsFor: 'files' stamp: 'gk 4/18/2006 22:53'!
newFile: fileName block: aBlock
	"Create a new file. Let <aBlock> fill the file with content by calling it with a stream."

	| dir stream |
	dir := self uploadsDirectory.
	[(dir fileExists: fileName) ifTrue:[dir deleteFileNamed: fileName].
	stream := dir newFileNamed: fileName.
	stream binary.
	aBlock value: stream] ensure: [stream close]! !

!SMAccount methodsFor: 'files' stamp: 'gk 4/3/2006 23:58'!
streamForFile: fileName
	"Return a readonly stream for file <fileName>.
	If the file does not exist return nil."

	| stream |
	[stream := StandardFileStream oldFileNamed: (self uploadsDirectory fullNameFor: fileName)]
		on: FileDoesNotExistException do: [^nil].
	^stream! !

!SMAccount methodsFor: 'files' stamp: 'gk 8/14/2003 14:23'!
uploadsDirectory
	"Get the directory for uploaded files, create it if missing."

	^(self directory directoryNamed: 'uploads') assureExistence; yourself
! !


!SMAccount methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:38'!
initialize
	"Initialize account."

	super initialize.
	initials := signature := advogatoId := ''.
	isAdmin := false.
	objects := OrderedCollection new.
	coObjects := OrderedCollection new! !


!SMAccount methodsFor: 'objects' stamp: 'gk 11/11/2003 16:16'!
addCoObject: anObject
	"Add <anObject> to this account.
	Only called from #addMaintainer:."
	
	(coObjects includes: anObject)
		ifFalse:[coObjects add: anObject]! !

!SMAccount methodsFor: 'objects' stamp: 'gk 11/11/2003 20:49'!
addObject: anObject
	"Add <anObject> to this account. Also makes sure the
	reverse reference is correct."
	
	(objects includes: anObject) ifFalse:[
		objects add: anObject.
		anObject owner: self.
		map addObject: anObject]! !

!SMAccount methodsFor: 'objects' stamp: 'gk 11/24/2005 11:13'!
coPackageWithId: anIdString
	"Return the correct package or nil."

	^self withId: anIdString in: self coPackages! !

!SMAccount methodsFor: 'objects' stamp: 'gk 11/24/2005 11:10'!
coPackages
	"Return all co-maintained packages."

	^coObjects select: [:o | o isPackage]! !

!SMAccount methodsFor: 'objects' stamp: 'gk 8/7/2003 21:00'!
moveObject: aPersonalObject toAccount: anAccount
	"Transfer the ownership of the given personal object to <anAccount>."

	self removeObject: aPersonalObject.
	anAccount addObject: aPersonalObject! !

!SMAccount methodsFor: 'objects' stamp: 'gk 11/24/2005 11:14'!
packageWithId: anIdString
	"Return the correct package or nil."

	^self withId: anIdString in: self packages! !

!SMAccount methodsFor: 'objects' stamp: 'gk 11/24/2005 11:14'!
packages
	"Return all owned packages."

	^objects select: [:o | o isPackage]! !

!SMAccount methodsFor: 'objects' stamp: 'gk 11/11/2003 16:16'!
removeCoObject: anObject
	"Remove <anObject> from this account.
	Only called from #removeMaintainer:."

	(coObjects includes: anObject) ifTrue: [
		coObjects remove: anObject]! !

!SMAccount methodsFor: 'objects' stamp: 'gk 8/7/2003 20:56'!
removeObject: anObject
	"Remove <anObject> from this account. Also makes sure the
	reverse reference is cleared."

	(objects includes: anObject) ifTrue: [
		anObject owner: nil.
		objects remove: anObject]! !


!SMAccount methodsFor: 'passwords' stamp: 'stephaneducasse 2/4/2006 20:38'!
correctPassword: aPassword
	"We store the password as a SHA hash so that we can let the slave maps
	have them too. Also check the optional new random password."

	| try |
	aPassword isEmptyOrNil ifTrue:[^false].
	try := SecureHashAlgorithm new hashMessage: aPassword.
	^password = try or: [newPassword = try]! !

!SMAccount methodsFor: 'passwords' stamp: 'gk 5/5/2006 02:07'!
createRandomPassword
	"Create a random password and set it
	in parallell to the regular one."

	| randomPass |
	randomPass := String streamContents: [:stream | 10 timesRepeat: [ stream nextPut: 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' atRandom]].
	self setNewPassword: randomPass.
	^randomPass! !

!SMAccount methodsFor: 'passwords' stamp: 'stephaneducasse 2/4/2006 20:38'!
setNewPassword: aString
	"Set a new parallell password the user can use to get in
	if the old password is forgotten. We don't delete the old
	password since the request for this new password is made
	anonymously. Note that the password is stored as a secured
	hash large integer."

	newPassword := SecureHashAlgorithm new hashMessage: aString! !

!SMAccount methodsFor: 'passwords' stamp: 'stephaneducasse 2/4/2006 20:38'!
setPassword: aString
	"We also clear the random extra password."

	password := SecureHashAlgorithm new hashMessage: aString.
	newPassword := nil! !


!SMAccount methodsFor: 'printing' stamp: 'gk 11/24/2005 11:09'!
type
	"Used in various views."

	^'Account'! !


!SMAccount methodsFor: 'testing' stamp: 'gk 6/26/2003 16:47'!
isAccount
	^true! !

!SMAccount methodsFor: 'testing' stamp: 'gk 11/11/2003 17:24'!
owns: anObject
	^objects includes: anObject! !


!SMAccount methodsFor: 'view' stamp: 'gk 10/12/2005 12:24'!
getLink: aBuilder
	"Return a link for using on the web.
	Always from the top."

	^aBuilder getLinkTop: 'accountbyid/', id asString text: self nameWithInitials! !

!SMAccount methodsFor: 'view' stamp: 'gk 8/4/2003 14:10'!
logout
	"Automatically called upon logout. Do nothing."! !

!SMAccount methodsFor: 'view' stamp: 'gk 8/5/2003 13:16'!
nameWithInitials
	"Return name and developer initials within parentheses."

	^name, ' (', (initials isEmptyOrNil ifTrue: ['not entered'] ifFalse: [initials]) , ')'! !

!SMAccount methodsFor: 'view' stamp: 'gk 8/8/2003 00:09'!
publicViewFor: uiObject
	"This is a double dispatch mechanism for multiple views
	for multiple uis."

	^uiObject publicAccountViewOn: self! !

!SMAccount methodsFor: 'view' stamp: 'gk 6/26/2003 16:01'!
viewFor: uiObject
	"This is a double dispatch mechanism for multiple views
	for multiple uis."

	^uiObject accountViewOn: self! !
SMObject subclass: #SMCategorizableObject
	instanceVariableNames: 'categories resources'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMCategorizableObject commentStamp: '<historical>' prior: 0!
A categorizable object can be associated with one or more SMCategories.
The relation between the categories and the SMCategorizableObject is bidirectional.
A categorizable object can also have attached resources, see SMResource.

The categories are used to classify the categorizable object for different purposes.
Package and package releases are classified in different ways, but so can resources and accounts be.
!


!SMCategorizableObject methodsFor: 'accessing' stamp: 'gk 9/23/2003 20:44'!
categories
	"Lazily initialized."

	^categories ifNil: [OrderedCollection new]! !

!SMCategorizableObject methodsFor: 'accessing' stamp: 'gk 7/27/2004 13:09'!
resources
	"Lazily initialized."

	^resources ifNil: [OrderedCollection new]! !


!SMCategorizableObject methodsFor: 'categories' stamp: 'gk 9/23/2003 20:45'!
categoriesDo: aBlock
	"Evaluate aBlock for each of the categories."

	categories ifNil: [^self].
	categories do: aBlock! !

!SMCategorizableObject methodsFor: 'categories' stamp: 'gk 11/24/2005 11:18'!
categoryForParent: aCategory
	"Answer one of my categories with parent <aCategory>, if I have it."

	categories ifNil: [^nil].
	^categories detect: [:cat | cat parent = aCategory ] ifNone: [nil]! !

!SMCategorizableObject methodsFor: 'categories' stamp: 'gh 11/27/2002 12:35'!
hasCategory: aCategory
	"Answer true if I am in it."

	^categories notNil and: [categories includes: aCategory]! !

!SMCategorizableObject methodsFor: 'categories' stamp: 'gk 7/9/2004 02:57'!
hasCategoryOrSubCategoryOf: aCategory
	"Answer true if I am in aCategory or if I am in any
	of its sub categories recursively."

	aCategory allCategoriesDo: [:cat |
		(self hasCategory: cat) ifTrue: [^ true]].
	^false! !



!SMCategorizableObject methodsFor: 'printing' stamp: 'dew 3/17/2004 16:28'!
describeCategoriesOn: aStream indent: tabs 
	"Show a full listing of categories and their dscription on aStream, indented by the given number of tabs."

	categories isEmptyOrNil
		ifFalse: [aStream cr;
				withAttribute: TextEmphasis bold
				do: [aStream nextPutAll: 'Categories: ']; cr.
			(self categories asSortedCollection: [:a :b | a path < b path])
				do: [:c | 
					aStream tab: tabs.
					c
						parentsDo: [:p | aStream nextPutAll: p name;
								 nextPut: $/].
					aStream nextPutAll: c name;
						 nextPutAll: ' - ';
						
						withAttributes: {TextEmphasis italic. TextIndent tabs: tabs + 1 }
						do: [aStream nextPutAll: c summary];
						 cr]]! !


!SMCategorizableObject methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
addCategory: aCategory
	"Add <aCategory> to me. If I already have it do nothing."

	categories ifNil: [categories := OrderedCollection new].
	(categories includes: aCategory) ifFalse:[
		aCategory addObject: self.
		categories add: aCategory].
	^aCategory! !

!SMCategorizableObject methodsFor: 'private' stamp: 'gk 8/8/2003 02:35'!
delete
	"Delete me. Disconnect me from my categories."

	super delete.
	self removeFromCategories! !

!SMCategorizableObject methodsFor: 'private' stamp: 'gh 11/27/2002 12:35'!
removeCategory: aCategory
	"Remove category from me if I am in it."

	(categories notNil and: [categories includes: aCategory]) ifTrue:[
		aCategory removeObject: self.
		categories remove: aCategory].
	^aCategory! !

!SMCategorizableObject methodsFor: 'private' stamp: 'gh 11/27/2002 12:35'!
removeFromCategories
	"Remove me from all my categories."

	categories ifNotNil:[
		categories copy do: [:cat | self removeCategory: cat ]]! !


!SMCategorizableObject methodsFor: 'resources' stamp: 'gk 5/5/2006 02:07'!
addResource: aResource
	"Lazily initialize the resources collection."
	
	resources ifNil: [resources := OrderedCollection new].
	aResource object: self.
	^resources add: aResource! !

!SMCategorizableObject methodsFor: 'resources' stamp: 'gk 7/27/2004 18:12'!
embeddedResources
	"Return all embedded resources."
	
	^resources ifNil: [#()]
		ifNotNil: [resources select: [:r | r isEmbedded ]]
	! !

!SMCategorizableObject methodsFor: 'resources' stamp: 'gk 11/24/2005 11:23'!
removeResource: aResource
	"Disconnect and remove the resource."
	
	aResource object: nil.
	^resources remove: aResource! !
SMObject subclass: #SMCategory
	instanceVariableNames: 'mandatory subCategories parent objects'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMCategory commentStamp: 'gk 3/8/2004 19:44' prior: 0!
An SMCategory is a "tag" that can be attached to SMCategorizableObjects in order to classify them.

The SMCategories are arranged in a strict hierarchy and each SMCategory both knows it's parent and it's subcategories.
The instvar objects holds all SMObjects belonging to this category.
Instvars name and summary are already inherited from SMObject and describe the category.
The instvar url can be used to refer to a web page that can explain the category in more detail, typically a page at the Squeak Swiki.
SMCategory adds an instance variable called mandatory holding a Set with the classes (SMPackage, SMPackageRelease, SMAccount, SMResource etc) that must belong to at least one subcategory of this SMCategory. Obviously not many categories will be mandatory for each class.

The category tree is maintained by a few trusted people so that chaos will not reign. :-)
!


!SMCategory methodsFor: 'accessing' stamp: 'gk 11/17/2003 13:51'!
mandatory
	^mandatory! !

!SMCategory methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
mandatory: aSet
	mandatory := aSet! !

!SMCategory methodsFor: 'accessing' stamp: 'gk 11/17/2003 21:35'!
mandatoryFor: aClass
	"Is this category mandatory for instances of <aClass>?"

	^mandatory ifNil: [false] ifNotNil: [mandatory includes: aClass]! !

!SMCategory methodsFor: 'accessing' stamp: 'gh 8/1/2002 16:54'!
objects
	"Return all objects in this category."

	^objects! !

!SMCategory methodsFor: 'accessing' stamp: 'gk 8/7/2003 23:42'!
packages
	"Return all packages in this category."

	^objects select: [:p | p isPackage]! !

!SMCategory methodsFor: 'accessing' stamp: 'gh 6/27/2002 16:01'!
parent
	^parent! !

!SMCategory methodsFor: 'accessing' stamp: 'gh 6/27/2002 12:25'!
subCategories
	subCategories ifNil: [^#()].
	^subCategories! !



!SMCategory methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:38'!
initialize
	super initialize.
	name := summary := url := ''.
	objects := OrderedCollection new! !


!SMCategory methodsFor: 'printing' stamp: 'gk 1/29/2004 00:14'!
path
	"Return my name with a full path of my
	parent names separated with slashes like:
		'Squeak versions/Squeak3.5' "

	^String streamContents: [:s |
		self parentsDo: [:cat |
			s nextPutAll: cat name; nextPutAll: '/'].
		s nextPutAll: self name]! !

!SMCategory methodsFor: 'printing' stamp: 'gh 8/16/2002 06:04'!
printOn: aStream

	aStream nextPutAll: self class name, ': ', name! !

!SMCategory methodsFor: 'printing' stamp: 'gk 11/14/2003 00:13'!
type

	^'Category'! !


!SMCategory methodsFor: 'services' stamp: 'gk 11/17/2003 10:48'!
allCategoriesDo: aBlock
	"Evaluate <aBlock> for all categories below me including me,
	bottom up breadth-first."

	self allSubCategoriesDo: aBlock.
	aBlock value: self! !

!SMCategory methodsFor: 'services' stamp: 'gk 7/9/2004 02:59'!
allSubCategoriesDo: aBlock
	"Evaluate <aBlock> for all categories below me NOT including me,
	bottom up breadth-first."

	subCategories ifNil: [^self].
	subCategories do: [:sub |
		sub allSubCategoriesDo: aBlock.
		aBlock value: sub]! !

!SMCategory methodsFor: 'services' stamp: 'gh 8/5/2002 17:10'!
categoryBefore
	"Return the category listed before me in my parent.
	If I am first or I have no parent, return nil."

	parent isNil ifTrue:[^nil].
	parent subCategories first = self ifTrue:[^nil].
	^parent subCategories before: self
	! !

!SMCategory methodsFor: 'services' stamp: 'gh 8/5/2002 14:36'!
move: cat toAfter: before
	"Move a category to be after the category <before>."

	subCategories remove: cat.
	before ifNil: [subCategories addFirst: cat] ifNotNil: [subCategories add: cat after: before]! !

!SMCategory methodsFor: 'services' stamp: 'gh 8/1/2002 17:30'!
parentsDo: aBlock
	"Run a block for all my parents starting from the top."

	parent ifNotNil: [
		parent parentsDo: aBlock.
		aBlock value: parent]! !


!SMCategory methodsFor: 'testing' stamp: 'gh 12/1/2002 20:24'!
hasSubCategories
	^subCategories isEmptyOrNil not! !

!SMCategory methodsFor: 'testing' stamp: 'gk 8/7/2003 22:31'!
includes: anObject
	"Answer if <anObject> is in this category."

	^objects includes: anObject! !

!SMCategory methodsFor: 'testing' stamp: 'gh 12/1/2002 19:51'!
isCategory
	^true! !

!SMCategory methodsFor: 'testing' stamp: 'gh 6/27/2002 13:31'!
isTopCategory
	^parent isNil! !


!SMCategory methodsFor: 'view' stamp: 'gk 10/12/2005 12:24'!
getLink: aBuilder
	"Return a link for using on the web.
	Always from the top."

	^aBuilder getLinkTop: 'category/', id asString text: name! !

!SMCategory methodsFor: 'view' stamp: 'gh 8/1/2002 16:38'!
viewFor: uiObject
	"This is a double dispatch mechanism for multiple views
	for multiple uis."

	^uiObject categoryViewOn: self! !


!SMCategory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
addCategory: cat
	"Add a category as a subcategory to self.
	The collection of subcategories is lazily instantiated."

	subCategories ifNil: [subCategories := OrderedCollection new].
	cat parent ifNotNil: [cat parent removeCategory: cat ].
	subCategories add: cat.
	cat parent: self.
	^cat! !

!SMCategory methodsFor: 'private' stamp: 'gk 9/23/2003 21:59'!
addObject: anObject
	"Add <anObject> to this category. This should only be called
	from SMCategorizableObject>>addCategory: to ensure consistency."
	
	(objects includes: anObject) ifFalse:[objects add: anObject]! !

!SMCategory methodsFor: 'private' stamp: 'gk 11/24/2005 11:37'!
delete
	"Delete me. Disconnect me from my objects and my parent.
	Then delete my subcategories."

	super delete.
	self removeFromObjects; removeFromParent.
	self subCategories do: [:c | c delete ]! !

!SMCategory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
parent: aCategory
	"Change the parent category.
	This method relies on that somebody else
	updates the parent's subCategories collection."
	
	parent := aCategory! !

!SMCategory methodsFor: 'private' stamp: 'gk 11/24/2005 11:34'!
removeDeepFromObjects
	"Remove myself from my objects and then ask
	my subCategories to do the same."

	self removeFromObjects.
	subCategories do: [:cat | cat removeDeepFromObjects]! !

!SMCategory methodsFor: 'private' stamp: 'gh 12/1/2002 20:03'!
removeFromObjects
	"Remove myself from my objects."

	objects copy do: [:obj | obj removeCategory: self]! !

!SMCategory methodsFor: 'private' stamp: 'gh 12/1/2002 20:28'!
removeFromParent
	"Remove me from my parent."

	parent ifNotNil: [parent removeCategory: self]! !

!SMCategory methodsFor: 'private' stamp: 'gh 12/1/2002 20:28'!
removeObject: anObject
	"Remove <anObject> from this category. This should only be called
	from SMCategorizableObject>>removeCategory: to ensure consistency."
	
	^objects remove: anObject! !
ListItemWrapper subclass: #SMCategoryWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMLoader'!
!SMCategoryWrapper commentStamp: '<historical>' prior: 0!
This is a wrapper for showing the SqueakMap categories (SMCategory) using the SimpleHierarchicalListMorph in the SMLoader, see SMLoader>>categoryWrapperList.!


!SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/9/2004 02:13'!
= anObject
	^self withoutListWrapper = anObject withoutListWrapper! !

!SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/9/2004 02:19'!
asString
	^item name! !

!SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/9/2004 02:35'!
category
	^item! !

!SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'gk 3/4/2004 10:18'!
contents
	"This is the message that returns the contents of this wrapper.
	We return a collection of wrappers around all the children of our model."

	^item subCategories collect: [:e | SMCategoryWrapper with: e]! !

!SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/9/2004 02:13'!
hash
	^self withoutListWrapper hash! !
SMDefaultInstaller subclass: #SMDVSInstaller
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-installer'!
!SMDVSInstaller commentStamp: '<historical>' prior: 0!
This is an installer class for DVS packages. It handles packages categorized with package
format as DVS and with a download filename with extensions .st or .st.gz.

This class can function without DVS installed, needed classes are looked up dynamically.!


!SMDVSInstaller methodsFor: 'services' stamp: 'stephaneducasse 2/4/2006 20:38'!
install
	"Install using DVS."

	| imagePackageLoader streamPackageLoader packageInfo packageManager baseName current new manager |
	self cache; unpack.
	imagePackageLoader := Smalltalk at: #ImagePackageLoader ifAbsent: [].
	streamPackageLoader := Smalltalk at: #StreamPackageLoader ifAbsent: [].
	packageInfo := Smalltalk at: #PackageInfo ifAbsent: [].
	packageManager := Smalltalk at: #FilePackageManager ifAbsent: [].

	({ imagePackageLoader. streamPackageLoader. packageInfo. packageManager } includes: nil)
		ifTrue: [ (self confirm: ('DVS support is not loaded, but would be helpful in loading ', unpackedFileName, '.
It isn''t necessary, but if you intend to use DVS later it would be a good idea to load it now.
Load it from SqueakMap?'))
			ifTrue: [ self class loadDVS. ^self install ]
			ifFalse: [ ^self fileIn ]].

	baseName := packageRelease name.
	dir rename: unpackedFileName toBe: (baseName, '.st').
	unpackedFileName := baseName, '.st'.

	(manager := packageManager allManagers detect: [ :pm | pm packageName = baseName ] ifNone: [])
		ifNotNil: [
			current := imagePackageLoader new package: (packageInfo named: baseName).
			new := streamPackageLoader new stream: (dir readOnlyFileNamed: unpackedFileName).
			(new changesFromBase: current) fileIn ]
		ifNil: [
			self fileIn.
			manager := packageManager named: baseName. ].

	manager directory: dir.
	packageManager changed: #allManagers.
	packageRelease noteInstalled! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMDVSInstaller class
	instanceVariableNames: ''!

!SMDVSInstaller class methodsFor: 'loading' stamp: 'gk 10/1/2003 13:51'!
loadDVS
	"Load the DVS package from SqueakMap."

	SMSqueakMap default installPackageWithId: '100d59d0-bf81-4e74-a4fe-5a2fd0c6b4ec'! !


!SMDVSInstaller class methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:38'!
canInstall: aPackage
	"Can I install this? First we check if class StreamPackageLoader
	is available, otherwise DVS isn't installed.
	Then we check if the package is categorized with package
	format DVS - currently we have hardcoded the id of that category."

	| fileName |
	Smalltalk at: #StreamPackageLoader ifPresentAndInMemory: [ :loader |
		fileName := aPackage downloadFileName.
		fileName ifNil: [^false].
		fileName := fileName asLowercase.
		^((fileName endsWith: '.st') or: [fileName endsWith: '.st.gz'])
			and: [aPackage categories includes: "The DVS format category"
					(SMSqueakMap default
						categoryWithId: 'b02f51f4-25b4-4117-9b65-f346215a8e41')]].
	^false! !
SMSimpleInstaller subclass: #SMDefaultInstaller
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-installer'!
!SMDefaultInstaller commentStamp: '<historical>' prior: 0!
An installer takes care of installing SqueakMap packages represented by SMCards.
This installer handles packages that consist of classical fileins (single changesets and .st-files) and optional gzip-decompression of those. Deciding if a package is installable and instantiating the correct installer class is done on the class side in SMInstaller, to see how this installer gets chosen - see SMDefaultInstaller class>>canInstall:.

!


!SMDefaultInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 20:52'!
install
	"This service should bring the package to the client,
	unpack it if necessary and install it into the image.
	The package is notified of the installation."

	self cache; unpack; fileIn.
	packageRelease noteInstalled
! !


!SMDefaultInstaller methodsFor: 'private' stamp: 'gk 4/18/2006 23:31'!
fileIn
	"Installing in the standard installer is simply filing in.
	Both .st and .cs files will file into a ChangeSet of their own.
	We let the user confirm filing into an existing ChangeSet
	or specify another ChangeSet name if
	the name derived from the filename already exists."
	
	| fileStream |
	(self class nonMultiSuffixes anySatisfy: [:each | unpackedFileName endsWith: (FileDirectory dot, each)])
		ifTrue:[
			fileStream := dir readOnlyFileNamed: unpackedFileName.
			(fileStream respondsTo: #setConverterCode) ifTrue: [fileStream setConverterForCode].
			self fileIntoChangeSetNamed: (fileStream localName sansPeriodSuffix) fromStream: fileStream.
			^self].
	(self class multiSuffixes anySatisfy: [:each | unpackedFileName endsWith: (FileDirectory dot, each)])
		ifTrue:[
			fileStream := dir readOnlyFileNamed: unpackedFileName.
			"Only images with converters should have multi suffixes"
			fileStream converter: (Smalltalk at: #UTF8TextConverter) new.
			self fileIntoChangeSetNamed: (fileStream localName sansPeriodSuffix) fromStream: fileStream.
			^self].
	self error: 'Filename should end with a proper extension'.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMDefaultInstaller class
	instanceVariableNames: ''!

!SMDefaultInstaller class methodsFor: 'testing' stamp: 'gk 3/31/2006 09:59'!
canInstall: aPackage
	"Answer if this class can install/upgrade the package.
	This installer handles .st, .cs, .mst, .mcs (Squeak 3.9+)
	with or without .gz suffix."

	| fileName |
	fileName := aPackage downloadFileName.
	fileName ifNil: [^false].
	fileName := fileName asLowercase.
	^self sourceFileSuffixes anySatisfy: [:each | 
			(fileName endsWith: (FileDirectory dot, each)) or: [
				fileName endsWith: (FileDirectory dot, each, '.gz')]]! !


!SMDefaultInstaller class methodsFor: 'private' stamp: 'gk 3/31/2006 10:05'!
multiSuffixes
	"Unfortunately we can not tell which suffixes use multibyte encoding.
	So we guess that they begin with $m."

	^self sourceFileSuffixes select: [:suff | suff first = $m]! !

!SMDefaultInstaller class methodsFor: 'private' stamp: 'gk 3/31/2006 10:06'!
nonMultiSuffixes
	"Unfortunately we can not tell which suffixes use multibyte encoding.
	So we guess that they begin with $m."

	^self sourceFileSuffixes reject: [:suff | suff first = $m]! !

!SMDefaultInstaller class methodsFor: 'private' stamp: 'gk 3/31/2006 09:59'!
sourceFileSuffixes
	"Trying to play nice with all Squeak versions."

	^(FileStream respondsTo: #sourceFileSuffixes)
			ifTrue: [FileStream sourceFileSuffixes]
			ifFalse: [#(cs st)].! !
Object subclass: #SMDependencyAnalysis
	instanceVariableNames: 'task map wantedReleases alreadyInstalled trivialToInstall alreadyInstallable combinations suggestedInstallSetsSet workingConfigurations workingConfigurationsSize conflictingInstallSetsSet trickyReleases subAnalysises success'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMDependencyAnalysis commentStamp: '<historical>' prior: 0!
A dependency analysis is instantiated by an SMInstallationTask as a step in calculating how the task can be performed.

The analysis is done using a map and some input - for example a list of package releases that the task wants to get installed. It can then be queried for the results. The analysis is performed in a series of steps and middle results are collected in instvars. It also uses sub instances so the analysis actually forms a tree of several instances of SMDependencyAnalysis where each node describes one level of dependencies.

Instvars:

task - the task that instantiated this analysis.
map - the SMSqueakMap to use, we get it by asking the task.
wantedReleases - the releases that we want to install.
alreadyInstalled - the subset of wantedReleases that are already installed.
trivialToInstall - the subset of wantedReleases that do not have dependencies and can be installed directly.
alreadyInstallable - 	the subset of wantedReleases that do have dependencies but for which at least one configuration is fulfilled and thus the release can already be installed.
trickyReleases - the subset of wantedReleases that do have configurations but none of them are fulfilled, so some dependencies first needs to be installed before these releases can be installed.

workingConfigurations - an OrderedCollection of OrderedCollections holding all working configurations for the trickyReleases.
workingConfigurationsSize - size of workingConfigurations.
combinations - all possible (unordered) combinations of picking one working configuration for each tricky release.
suggestedInstallSetsSet - computed from combinations above. A Set of Sets of required releases. Each Set is a unique combination of the required releases to install in order to fulfill one configuration for each of the tricky releases.
conflictingInstallSetsSet - the subset of suggestedInstallSetsSet that are invalid since it includes multiple releases from the same package.
 !


!SMDependencyAnalysis methodsFor: 'queries' stamp: 'gk 5/5/2006 02:07'!
allInstallPaths
	"For all paths, collect in reverse all releases to install.
	At each level, first we add trivially installable releases
	(those that have no dependencies), then installable releases
	(those that have one configuration fulfilled) and finally
	the tricky releases (those left).
	Note that we also return paths with conflicting releases
	of the same package and paths with releases that conflict with
	already installed releases - those paths can be tweaked - and
	paths that are supersets of other paths."

	| installPaths releases |
	installPaths := OrderedCollection new.
	self allPathsDo: [:path |
		releases := OrderedCollection new.
		path reverseDo: [:ana |
			releases addAll: (ana trivialToInstall difference: releases).
			releases addAll: (ana alreadyInstallable difference: releases).
			releases addAll: (ana trickyReleases difference: releases)
			"Below for debugging
			r := OrderedCollection new.
			r add: ana trivialToInstall; add: ana alreadyInstallable; add: ana trickyReleases.
			releases add: r"].
		installPaths add: releases].
	^ installPaths! !

!SMDependencyAnalysis methodsFor: 'queries' stamp: 'gk 5/5/2006 02:07'!
allNormalizedInstallPaths
	"Same as allInstallPaths, but with paths removed that
	are clear supersets of others."

	| installPaths |
	installPaths := self allInstallPaths.
	installPaths := installPaths reject: [:p1 |
					installPaths anySatisfy: [:p2 |
						(p1 ~~ p2) and: [p1 includesAllOf: p2]]].
	^installPaths! !

!SMDependencyAnalysis methodsFor: 'queries' stamp: 'gk 5/5/2006 02:07'!
bestInstallPath
	"Using some heuristics we suggest the best path:
		- No conflicts
		- Fewest releases
		- If same packages, the newest releases"

	| paths min points point package sc |
	paths := self installPathsWithoutConflicts.
	paths size = 1 ifTrue: [^paths first].
	min := paths inject: 999 into: [:mi :p | p size < mi ifTrue: [p size] ifFalse: [mi]].
	paths := paths select: [:p | p size = min].
	paths size = 1 ifTrue: [^paths first].
	"Try to pick the one with newest releases"
	points := Dictionary new.
	paths do: [:p |
		point := 0.
		p do: [:r |
			package := r package.
			paths do: [:p2 |
				p2 == p ifFalse: [
					(p2 anySatisfy: [:r2 |
						(r2 package == package) and: [r newerThan: r2]])
							ifTrue:[point := point + 1]]]].
		points at: p put: point].
	points isEmpty ifTrue: [^nil].
	sc := points associations asSortedCollection: [:a :b | a value >= b value].
	^ sc first key! !

!SMDependencyAnalysis methodsFor: 'queries' stamp: 'gk 9/26/2004 23:44'!
installPathsWithConflicts
	"Same as allInstallPaths, but we only return paths
	with multiple releases of the same package."

	^ self allInstallPaths select: [:path | self detectConflictingReleasesIn: path] ! !

!SMDependencyAnalysis methodsFor: 'queries' stamp: 'gk 9/22/2004 23:32'!
installPathsWithoutConflicts
	"Same as allInstallPaths, but we filter out paths
	with multiple releases of the same package."

	^ self allInstallPaths reject: [:path | self detectConflictingReleasesIn: path] ! !

!SMDependencyAnalysis methodsFor: 'queries' stamp: 'gk 9/26/2004 23:47'!
untestedInstallPaths
	"We take the paths with conflicts and remove the older releases."

	^self installPathsWithConflicts collect: [:p |
		 self removeOlderReleasesIn: p] ! !


!SMDependencyAnalysis methodsFor: 'private' stamp: 'gk 9/22/2004 20:22'!
allPathsDo: aBlock
	"For all paths down the tree, evaluate aBlock."

	^ self allPathsDo: aBlock trail: OrderedCollection new! !

!SMDependencyAnalysis methodsFor: 'private' stamp: 'gk 9/22/2004 20:59'!
allPathsDo: aBlock trail: trail
	"For all paths down the tree, evaluate aBlock."

	trail add: self.
	subAnalysises
		ifNil: [
			aBlock value: trail.]
		ifNotNil: [
			subAnalysises do: [:sub |
				sub allPathsDo: aBlock trail: trail]].
	trail removeLast! !

!SMDependencyAnalysis methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
allRoutesDo: aBlock currentRoute: currentRoute level: level
	"Recursively iterate over all routes down the tree."

	| newLevel |
	workingConfigurationsSize = level ifTrue: ["we reached the leaves"
		workingConfigurations last do: [:conf | 
			currentRoute addLast: conf.
			aBlock value: currentRoute.
			currentRoute removeLast].
		^self].
	newLevel := level + 1.
	(workingConfigurations at: level) do: [:conf |
		currentRoute addLast: conf.
		self allRoutesDo: aBlock currentRoute: currentRoute level: newLevel.
		currentRoute removeLast]! !

!SMDependencyAnalysis methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
collectCombinationsOfConfigurations
	"Given the wanted releases, find and return all possible combinations
	of working configurations for all those. Perhaps not possible to do
	given lots of releases and configurations, then we need smarter algorithms."
	
	"Pick out all working configurations first."
	workingConfigurations := (trickyReleases collect: [:r | r workingConfigurations]) asOrderedCollection.
	workingConfigurationsSize := workingConfigurations size.
	
	"We iterate over all possible combinations of configurations
	and collect the unique set of unordered configurations."
	combinations := Set new.
	self allRoutesDo: [:route |
		combinations add: route asSet copy] currentRoute: OrderedCollection new level: 1! !

!SMDependencyAnalysis methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
computeInstallSets
	"Given all combinations of configurations, compute all valid combinations
	of depdendency releases - all possible different Sets of required releases
	to install before the trickyReleases can be installed."
	
	"For each unique combination of configurations, collect all required releases
	and produce a Set of unique required release combinations." 
	suggestedInstallSetsSet := (combinations collect: [:comb |
								comb inject: Set new into: [:set :conf |
									set addAll: conf requiredReleases.
									set ]]) asSet.

	"Filter out those Sets that have multiple releases of the same package, they are conflicting
	and thus not valid - we can't have two different releases of the same package
	installed at the same time."
	
	"conflictingInstallSetsSet := suggestedInstallSetsSet select:
								[:set | self detectConflictingReleasesIn: set].
	suggestedInstallSetsSet removeAll: conflictingInstallSetsSet"! !

!SMDependencyAnalysis methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
detectConflictingReleasesIn: collectionOfReleases
	"Detect if the Set has multiple releases of the same package."

	| detectedPackages |
	detectedPackages := Set new.
	collectionOfReleases do: [:r |
		(detectedPackages includes: r package)
			ifTrue: [^ true]
			ifFalse: [detectedPackages add: r package]].
	^false! !

!SMDependencyAnalysis methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
partitionReleases
	"Move releases from wantedReleases to suitable other collections
	if they are either installed, trivial to install, or installable as is."
	
	trickyReleases := wantedReleases copy.
	alreadyInstalled := wantedReleases select: [:r | r isInstalled ].
	trickyReleases removeAll: alreadyInstalled. 
	trivialToInstall := trickyReleases select: [:r | r hasNoConfigurations ].
	trickyReleases removeAll: trivialToInstall.		
	alreadyInstallable := trickyReleases select: [:r | r hasFulfilledConfiguration ].
	trickyReleases removeAll: alreadyInstallable! !

!SMDependencyAnalysis methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
removeOlderReleasesIn: collectionOfReleases
	"Remove older multiple releases of the same package.
	2 scans to retain order."

	| newestReleases rel |
	newestReleases := Dictionary new.
	collectionOfReleases do: [:r |
		rel := newestReleases at: r package ifAbsent: [newestReleases at: r package put: r].
		(r newerThan: rel) ifTrue: [newestReleases at: r package put: r]].
	^collectionOfReleases select: [:r |
		(newestReleases at: r package) == r]! !


!SMDependencyAnalysis methodsFor: 'accessing' stamp: 'gk 7/27/2004 15:36'!
alreadyInstallable
	^alreadyInstallable
	! !

!SMDependencyAnalysis methodsFor: 'accessing' stamp: 'gk 7/27/2004 15:36'!
alreadyInstalled
	^alreadyInstalled
	! !

!SMDependencyAnalysis methodsFor: 'accessing' stamp: 'gk 9/20/2004 22:59'!
success
	^success
	! !

!SMDependencyAnalysis methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
task: ownerTask
	task := ownerTask.
	map := task map! !

!SMDependencyAnalysis methodsFor: 'accessing' stamp: 'gk 7/28/2004 15:32'!
trickyReleases
	^trickyReleases
	! !

!SMDependencyAnalysis methodsFor: 'accessing' stamp: 'gk 7/27/2004 15:36'!
trivialToInstall
	^trivialToInstall
	! !

!SMDependencyAnalysis methodsFor: 'accessing' stamp: 'gk 7/27/2004 15:35'!
wantedReleases
	^wantedReleases
	! !


!SMDependencyAnalysis methodsFor: 'printing' stamp: 'gk 9/21/2004 23:59'!
indent: level
	^'                                                  '
		last: level * 6! !

!SMDependencyAnalysis methodsFor: 'printing' stamp: 'gk 9/22/2004 22:44'!
printAllInstallPaths
	"Follow all install paths in the tree."

	^String streamContents: [:s |
		self allInstallPaths do: [:path |
			path do: [:rel |
				s nextPutAll: rel packageNameWithVersion, ', '].
			s cr]] ! !

!SMDependencyAnalysis methodsFor: 'printing' stamp: 'gk 9/21/2004 23:49'!
treeString
	"Return a indented String showing the tree
	structure of all possible scenarios."

	^String streamContents: [:s |
		self treeStringOn: s indent: 0]! !

!SMDependencyAnalysis methodsFor: 'printing' stamp: 'gk 5/5/2006 02:07'!
treeStringOn: stream indent: level
	"Print the tree
	structure of all possible scenarios."

	| i |
	i := self indent: level.
	stream nextPutAll: i, 'Wanted:'; cr.
	wantedReleases do: [:r |
		stream nextPutAll: i ,'  ' , r packageNameWithVersion;cr].
	stream nextPutAll: i, 'Tricky:'; cr.
	trickyReleases do: [:r |
		stream nextPutAll: i ,'  ' , r packageNameWithVersion;cr].
	stream cr.
	subAnalysises ifNotNil: [
		subAnalysises do: [:sub | sub treeStringOn: stream indent: level + 1]]! !


!SMDependencyAnalysis methodsFor: 'calculation' stamp: 'gk 5/5/2006 02:07'!
installPackageReleases: packageReleases
	"Given a Set of wanted SMPackageReleases, calculate all possible
	installation scenarios. If the analysis succeeds, return true, otherwise false."
	
	| result subAnalysis |
	wantedReleases := packageReleases copy.
	"First classify the releases in different groups."
	self partitionReleases.
	
	"If there are no tricky releases, we are already done.
	No extra required releases needs to be installed or upgraded."
	trickyReleases isEmpty ifTrue: [^success := true].

	"Ok, that was the easy part. The releases left now needs to be processed
	so that we can find out the different scenarios of required releases that we need
	to install first. First we calculate all combinations of available working configurations
	for the tricky releases."
	self collectCombinationsOfConfigurations.
	
	"Based on all configuration combinations,
	compute possible combinations of dependency releases."
	self computeInstallSets.
	
	"Check if we have failed - meaning that there are no valid scenarios without conflicts."
	suggestedInstallSetsSet isEmpty ifTrue: [^success := false].
	
	"Ok, this means we have at least one solution *on this level*!! But we need to do the
	analysis recursively for all these sets of required releases..."
	subAnalysises := OrderedCollection new.
	success := false.
	suggestedInstallSetsSet do: [:set |
		subAnalysis := SMDependencyAnalysis task: task.
		result := subAnalysis installPackageReleases: set.
		result ifTrue: [success := true].
		subAnalysises add: subAnalysis].
	
	"Did at least one succeed? If so, then we have at least one possible scenario!!
	If not, then we need to do tweaking."
	^success! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMDependencyAnalysis class
	instanceVariableNames: ''!

!SMDependencyAnalysis class methodsFor: 'instance creation' stamp: 'gk 7/29/2004 14:31'!
task: ownerTask

	^self new task: ownerTask! !
Object subclass: #SMDependencyEngine
	instanceVariableNames: 'map'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMDependencyEngine commentStamp: '<historical>' prior: 0!
A dependency engine is used to perform one or more installation, upgrade or uninstallation tasks.
After creation it is typically configured according to different strategies, policies etc based on the preferences of the user.
Then it is used to calculate what installations, uninstallations or upgrades are needed and in which order to reach certain stated goals, like installing a set of wanted packages or upgrading the installed packages.

The engine instantiates different SMInstallationTask subclasses depending on what it should calculate.

Todo: both the installation information for the image and the engine should probably be kept outside of the SMSqueakMap instance.
!


!SMDependencyEngine methodsFor: 'tasks' stamp: 'gk 7/29/2004 15:59'!
installPackages: wantedPackages
	"Given a Set of wanted SMPackages, create an installation task to compute
	possible installation scenarios.
	Returns an SMInstallationTask which can be further configured
	and then be sent #calculate after which it can be queried for results."
	
	^SMPackageInstallationTask engine: self wantedPackages: wantedPackages! !


!SMDependencyEngine methodsFor: 'accessing' stamp: 'gk 7/29/2004 14:47'!
map
	^map! !

!SMDependencyEngine methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
map: aMap
	map := aMap! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMDependencyEngine class
	instanceVariableNames: ''!

!SMDependencyEngine class methodsFor: 'instance creation' stamp: 'gk 7/29/2004 14:29'!
map: aMap

	^ self new map: aMap! !
TestCase subclass: #SMDependencyTest
	instanceVariableNames: 'engine map goranAccount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMDependencyTest commentStamp: '<historical>' prior: 0!
Tests for the dependency engine.!


!SMDependencyTest methodsFor: 'as yet unclassified' stamp: 'gk 5/5/2006 02:07'!
setUp
	| package trivial1rel installed1rel installed2rel tricky2rel conf1 conf2 tricky3rel1 tricky3rel2 tricky1rel seaside httpview kom1 kom2 |
	map := SMSqueakMap new reload.
	goranAccount := map newAccount: 'Goran' username: 'Goran' email: 'g@g.com'.
	
	"Add a few packages to test with:
	
	Tricky1 1
		Installed1 1
		Tricky2 1
	Tricky2 1
		Installed1 1
		TrivialToInstall1 1
		Tricky3 1
	
		Installed1 1
		TrivialToInstall1 1
		Tricky3 2
	Tricky3 2
		TrivialToInstall1 1

		Installed2 1
	
	Seaside
		KomHttpServer 1
	
	HttpView
		KomHttpServer 2
	"
	{
		{'A'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 3}.
		{'B'. {'Squeak3.6'. 'Stable'}. 2}.
		{'TrivialToInstall1'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'Installed1'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'Installed2'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'AlreadyInstallable1'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'Tricky1'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'Tricky2'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'Tricky3'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 2}.
		{'Circular1'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'Circular2'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'Circular3'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'Seaside'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
		{'KomHttpServer'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 2}.
		{'HttpView'. {'Squeak3.6'. 'Squeak3.7'. 'Stable'}. 1}.
	} do: [:arr |
			package := SMPackage newIn: map.
			package name: arr first.
			arr second do: [:cn | package addCategory: (map categoryWithNameBeginning: cn)].
			arr third timesRepeat: [package newRelease ].
			goranAccount addObject: package].
	
	trivial1rel := (map packageWithName: 'TrivialToInstall1') lastRelease.
	trivial1rel publisher: goranAccount.
	
	installed1rel := (map packageWithName: 'Installed1') lastRelease.
	installed1rel publisher: goranAccount; noteInstalled.
	installed2rel := (map packageWithName: 'Installed2') lastRelease.
	installed2rel publisher: goranAccount; noteInstalled.

	((map packageWithName: 'AlreadyInstallable1') lastRelease
		publisher: goranAccount;
		addConfiguration)
				addRequiredRelease: installed1rel.
	"Tricky1 has just a single configuration with one installed and one not installed."
	tricky1rel := (map packageWithName: 'Tricky1') lastRelease.
	tricky2rel := (map packageWithName: 'Tricky2') lastRelease.			
	(tricky1rel publisher: goranAccount; addConfiguration)
				addRequiredRelease: installed1rel; "already installed"
				addRequiredRelease: tricky2rel. "not installed"

	"Tricky2 has two configurations:
		1: an installed, a trivial one and Tricky3 r1.
		2: an installed, a trivial one and Tricky3 r2."
	conf1 := tricky2rel publisher: goranAccount; addConfiguration.
	conf2 := tricky2rel addConfiguration.
	
	tricky3rel1 := (map packageWithName: 'Tricky3') releases first.
	tricky3rel2 := (map packageWithName: 'Tricky3') lastRelease.
	tricky3rel1 publisher: goranAccount.
	tricky3rel2 publisher: goranAccount.

	conf1 addRequiredRelease: installed1rel; addRequiredRelease: trivial1rel; addRequiredRelease: tricky3rel1.
	conf2 addRequiredRelease: installed1rel; addRequiredRelease: trivial1rel; addRequiredRelease: tricky3rel2.
	
	"Tricky3rel2 has two configurations:
		1: trivial1
		2: installed2rel"
	conf1 := tricky3rel2 publisher: goranAccount; addConfiguration.
	conf2 := tricky3rel2 addConfiguration.
	conf1 addRequiredRelease: trivial1rel.
	conf2 addRequiredRelease: installed2rel.
	

	seaside := (map packageWithName: 'Seaside') lastRelease.
	seaside publisher: goranAccount.
	httpview := (map packageWithName: 'HttpView') lastRelease.
	httpview publisher: goranAccount.
	kom1 := (map packageWithName: 'KomHttpServer') firstRelease.
	kom1 publisher: goranAccount.
	kom2 := (map packageWithName: 'KomHttpServer') lastRelease.
	kom2 publisher: goranAccount.
	
	conf1 := seaside addConfiguration.
	conf2 := httpview addConfiguration.
	conf1 addRequiredRelease: kom1.
	conf2 addRequiredRelease: kom2! !

!SMDependencyTest methodsFor: 'as yet unclassified' stamp: 'gk 5/5/2006 02:07'!
test1
	"Test three different scenarios, a trivial, a simple
	and one with conflicting solutions."

	| task bestPath |
	engine := SMDependencyEngine map: map.
	task := engine installPackages: map installedPackages.
	self assert: (task calculate).
	self assert: (task analysis alreadyInstalled allSatisfy: [:r | r isInstalled]).
	self assert: (task analysis trivialToInstall isEmpty).
	self assert: (task analysis alreadyInstallable isEmpty).
	self assert: (task analysis trickyReleases isEmpty).
	self assert: (task allInstallPaths first isEmpty).
	self assert: (task allInstallPaths size = 1).

	"Test to install a trivial one, and an already installable one."
	engine := SMDependencyEngine map: map.
	task := engine installPackages: {map packageWithName: 'TrivialToInstall1'. map packageWithName: 'AlreadyInstallable1'}.
	self assert: (task calculate).
	self assert: (task analysis alreadyInstalled isEmpty).
	self assert: (task analysis trivialToInstall size = 1).
	self assert: (task analysis alreadyInstallable size = 1).
	self assert: (task analysis trickyReleases isEmpty).
	self assert: (task allInstallPaths size = 1).
	self assert: (task allInstallPaths first size = 2).
	
	"Test to install two packages, there are two solutions without conflicts."
	engine := SMDependencyEngine map: map.
	task := engine installPackages: {map packageWithName: 'Tricky1'. map packageWithName: 'Tricky2'}.
	self assert: (task calculate ).
	self assert: (task analysis alreadyInstalled isEmpty).
	self assert: (task analysis trivialToInstall isEmpty).
	self assert: (task analysis alreadyInstallable isEmpty).
	self assert: (task analysis trickyReleases size = 2).
	self assert: (task allInstallPaths size = 4).
	self assert: (task analysis allNormalizedInstallPaths size = 2).
	"Make sure the 4 different install paths are computed correctly. Since the algorithm uses Sets
	the actual installs can vary, that is why we sort etc to check it."
	self assert: ((task allInstallPaths collect: [:oc |
		(oc collect: [:r | r packageNameWithVersion ]) asSortedCollection asString]) asSortedCollection asString =  'a SortedCollection(''a SortedCollection(''''Tricky1 1'''' ''''Tricky2 1'''' ''''Tricky3 1'''' ''''Tricky3 2'''' ''''TrivialToInstall1 1'''')'' ''a SortedCollection(''''Tricky1 1'''' ''''Tricky2 1'''' ''''Tricky3 1'''' ''''Tricky3 2'''' ''''TrivialToInstall1 1'''')'' ''a SortedCollection(''''Tricky1 1'''' ''''Tricky2 1'''' ''''Tricky3 1'''' ''''TrivialToInstall1 1'''')'' ''a SortedCollection(''''Tricky1 1'''' ''''Tricky2 1'''' ''''Tricky3 2'''' ''''TrivialToInstall1 1'''')'')').
	self assert: (task analysis installPathsWithoutConflicts size = 2).
	bestPath := task analysis bestInstallPath.
	self assert: (bestPath size = 4).
	self assert: (bestPath anySatisfy: [:r | r packageNameWithVersion = 'Tricky3 2']).
	! !

!SMDependencyTest methodsFor: 'as yet unclassified' stamp: 'gk 5/5/2006 02:07'!
test2
	"Checking construction of model:
	- verify test for circular dependencies (not allowed)."

	"Circular1rel has a conf to Circular2rel, which in turn has one back."
	| circular1rel circular2rel circular3rel |
	circular1rel := (map packageWithName: 'Circular1') lastRelease.
	circular2rel := (map packageWithName: 'Circular2') lastRelease.
	circular3rel := (map packageWithName: 'Circular3') lastRelease.

	(circular1rel publisher: goranAccount; addConfiguration)
		addRequiredRelease: circular2rel.

	(circular2rel publisher: goranAccount; addConfiguration)
		addRequiredRelease: circular3rel.
	
	self should: [
		(circular3rel publisher: goranAccount; addConfiguration)
			addRequiredRelease: circular1rel]
		raise: Error! !

!SMDependencyTest methodsFor: 'as yet unclassified' stamp: 'gk 5/5/2006 02:07'!
test3
	"Test simplest conflict."

	| task |
	"Test to install two packages, there is one solution with one conflict."
	engine := SMDependencyEngine map: map.
	task := engine installPackages: {map packageWithName: 'Seaside'. map packageWithName: 'HttpView'}.
	self assert: (task calculate).
	self assert: (task allInstallPaths size = 1).
	self assert: (task analysis installPathsWithoutConflicts size = 0).
	self assert: (task analysis allNormalizedInstallPaths size = 1).
	self assert: (task analysis bestInstallPath = nil).
	self assert: (task analysis untestedInstallPaths size = 1).
	self assert: (task proposals size = 1).
	self assert: (task proposals first hasDeviations)! !
SMMaintainableObject subclass: #SMDocument
	instanceVariableNames: 'description author'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMDocument commentStamp: '<historical>' prior: 0!
An SMDocument refers typically to a piece of digital information accessible through a URL. :-)
This means it can be downloaded and cached.

The instvar description describes the document and instvar author references the name and/or email of the original author.

SMDocument has one subclasses - SMPackage. Since SqueakMap is primarily meant for
keeping track of installable source packages of Squeak software, a specific subclass handles those.!


!SMDocument methodsFor: 'accessing' stamp: 'gk 3/8/2004 19:51'!
author
	^author! !

!SMDocument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
author: aString
	author := aString! !

!SMDocument methodsFor: 'accessing' stamp: 'gk 3/8/2004 19:52'!
description
	^description! !

!SMDocument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
description: aString
	description := aString! !


!SMDocument methodsFor: 'cache' stamp: 'gk 3/8/2004 19:51'!
ensureInCache
	"Makes sure the file is in the cache."

	self subclassResponsibility ! !

!SMDocument methodsFor: 'cache' stamp: 'gk 8/12/2003 17:09'!
isCached
	"Is the file corresponding to me in the local file cache?"

	self subclassResponsibility ! !


!SMDocument methodsFor: 'initialize-release' stamp: 'gk 12/7/2005 13:51'!
initialize

	super initialize.
	description := author := ''! !


!SMDocument methodsFor: 'testing' stamp: 'gk 7/16/2004 11:08'!
isDownloadable
	"Answer if I can be downloaded.
	Default is false."
	
	^ false
	
	
! !
SMResource subclass: #SMEmbeddedResource
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMEmbeddedResource commentStamp: '<historical>' prior: 0!
An embedded resource is a resource that is stored inside the map. No download is needed.
This means that embedded resources should be "small" and typically only be used for information that
is needed to be available at all times without downloading. A typical example is meta data for other SMObjects.

!



!SMEmbeddedResource methodsFor: 'services' stamp: 'gk 3/8/2004 19:58'!
download
	"A dummy method to respond as other resources would."

	^true! !

!SMEmbeddedResource methodsFor: 'services' stamp: 'gk 7/16/2004 11:03'!
ensureInCache
	"Makes sure the file is in the cache.
	An embedded resource doesn't have a file."

	^true! !


!SMEmbeddedResource methodsFor: 'testing' stamp: 'gk 8/12/2003 17:10'!
isCached
	"Is the file corresponding to me in the local file cache?
	Well consider it as true since I am embedded in the map."

	^true! !

!SMEmbeddedResource methodsFor: 'testing' stamp: 'gk 7/27/2004 14:31'!
isEmbedded
	^ true! !
SMResource subclass: #SMExternalResource
	instanceVariableNames: 'downloadUrl'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMExternalResource commentStamp: 'gk 3/8/2004 20:09' prior: 0!
An external resource is a downloadable resource.
The instance variable downloadUrl holds the URL to the resource and the resource is cacheable in the FileCache for the SqueakMap.
An external resource can be used for any kind of document that is to be attached to another SMObject.!


!SMExternalResource methodsFor: 'accessing' stamp: 'btr 5/28/2003 04:13'!
cacheDirectory
	^ map cache directoryForResource: self! !

!SMExternalResource methodsFor: 'accessing' stamp: 'gk 4/19/2006 01:32'!
contents
	"Return the contents of a stream from the downloaded resource.
	Not yet tested, this resource returns the stream and not its contents."

	map cache add: self.
	^(self cacheDirectory readOnlyFileNamed: self downloadFileName) binary; yourself! !

!SMExternalResource methodsFor: 'accessing' stamp: 'btr 5/28/2003 04:13'!
downloadFileName
	"Cut out the filename from the url."

	downloadUrl isEmpty ifTrue: [^nil].
	^downloadUrl asUrl path last! !

!SMExternalResource methodsFor: 'accessing' stamp: 'btr 5/28/2003 04:14'!
downloadUrl
	^ downloadUrl! !

!SMExternalResource methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
downloadUrl: anUrl
	downloadUrl := anUrl! !

!SMExternalResource methodsFor: 'accessing' stamp: 'gk 7/16/2004 11:09'!
isDownloadable
	"Answer if I can be downloaded.
	We simply verify that the download url
	ends with a filename."

	^self downloadFileName isEmptyOrNil not! !


!SMExternalResource methodsFor: 'services' stamp: 'gk 8/13/2003 15:42'!
download
	"Force a download into the cache regardless if it is already there."

	^map cache download: self! !

!SMExternalResource methodsFor: 'services' stamp: 'gk 8/13/2003 15:54'!
ensureInCache
	"Makes sure the file is in the cache."

	^map cache add: self! !


!SMExternalResource methodsFor: 'testing' stamp: 'gk 8/13/2003 15:32'!
isCached
	"Is the file corresponding to me in the local file cache?"

	^map cache includes: self! !
Object subclass: #SMFileCache
	instanceVariableNames: 'map'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMFileCache commentStamp: 'gk 3/8/2004 20:10' prior: 0!
A repository for SMSqueakMap downloads. This behaves like a Set, responding to add: and include:, but also package contents may be forcibly refreshed with download:.

The SqueakMap determines what path the cache resides at. Within the cache, there is a 'packages' directory containing UUID-based directories for each package containing further directories for each release. A 'resources' directory stores UUID-based directories for each Resource, with the file stored within that by its original name. Because the cache follows a Set protocol, it can be automatically traversed within Smalltalk's collection protocol, avoiding manual hassles.!


!SMFileCache methodsFor: 'accessing' stamp: 'gk 1/23/2004 10:26'!
directory
	^map packageCacheDirectory! !

!SMFileCache methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
directoryForPackage: aPackage
	"Returns the local path for storing the package cache's package file area.
	This also ensures that the path exists."

	| slash path dir |
	slash := FileDirectory slash.
	path := 'packages' , slash , aPackage id asString36 , slash.
	dir := FileDirectory default on: self directory fullName, slash, path.
	dir assureExistence.
	^dir! !

!SMFileCache methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
directoryForPackageRelease: aPackageRelease
	"Returns the local path for storing the package cache's version of a  
	package file. This also ensures that the path exists."

	| slash path dir |
	slash := FileDirectory slash.
	path := 'packages' , slash , aPackageRelease package id asString36 , slash , aPackageRelease automaticVersionString.
	dir := FileDirectory default on: self directory fullName, slash, path.
	dir assureExistence.
	^dir! !

!SMFileCache methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
directoryForResource: aResource
	"Returns the local path for storing the package cache's version of a  
	resource file. This also ensures that the path exists."

	| slash path dir |
	slash := FileDirectory slash.
	path := 'resources' , slash , aResource id asString36.
	dir := FileDirectory default on: self directory fullName, slash, path.
	dir assureExistence.
	^dir! !

!SMFileCache methodsFor: 'accessing' stamp: 'btr 5/27/2003 16:24'!
map
	^ map! !


!SMFileCache methodsFor: 'initialize' stamp: 'stephaneducasse 2/4/2006 20:38'!
forMap: aMap
	"Initialize the ache, make sure the cache dir exists."

	map := aMap! !


!SMFileCache methodsFor: 'services' stamp: 'gk 7/16/2004 11:04'!
add: aDownloadable 
	"Conditionally download the downloadable object into the cache.
	Return true on success, otherwise false."

	^(self includes: aDownloadable)
		ifTrue: [true]
		ifFalse: [self download: aDownloadable]! !

!SMFileCache methodsFor: 'services' stamp: 'gk 4/19/2006 01:31'!
contents: anSMObject
	"Return contents of the file for the object
	or nil if not in cache."

	anSMObject isCached
		ifTrue: [^(anSMObject cacheDirectory readOnlyFileNamed: anSMObject downloadFileName) binary; contentsOfEntireFile]
		ifFalse: [^nil]
		! !

!SMFileCache methodsFor: 'services' stamp: 'gk 5/5/2006 02:07'!
download: aDownloadable 
	"Download the file for this SMObject into the local file cache.
	If the file already exists, delete it.
	No unpacking or installation into the running image."

	| stream file fileName dir |
	[fileName := aDownloadable downloadFileName.
	fileName
		ifNil: [self inform: 'No download url, can not download.'.
			^ false].
	fileName isEmpty
		ifTrue: [self inform: 'Download url lacks filename, can not download.'.
			^ false].
	dir := aDownloadable cacheDirectory.
	[stream := self getStream: aDownloadable.
	stream ifNil: [^ false].
	(dir fileExists: fileName)
		ifTrue: [dir deleteFileNamed: fileName].
	file := dir newFileNamed: fileName.
	file binary; nextPutAll: stream contents]
		ensure: [file ifNotNil: [file close]]]
		on: Error
		do: [^ false].
	^ true! !

!SMFileCache methodsFor: 'services' stamp: 'gk 7/16/2004 11:10'!
includes: anSMObject
	"Check if the cache holds the file for the object."
	
	^(anSMObject cacheDirectory)
		fileExists: anSMObject downloadFileName! !


!SMFileCache methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
cacheUrlFor: aDownloadable
	"Find a cache URL for this downloadable.
	Returns nil if no server is available.
	Could use #relativeUrl also."

	| server |
	server := aDownloadable map class findServer.
	server ifNil: [^ nil].
	^'http://', server, '/object/', aDownloadable id asString, '/cache'! !

!SMFileCache methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
getStream: aDownloadable 
	"Get the stream, either from the original url
	or if that fails, from the server cache - unless
	this is the actual server of course. :)
	We also verify that the sha1sum is correct."

	| stream |
	[stream := aDownloadable downloadUrl asUrl retrieveContents contentStream binary.
	(aDownloadable correctSha1sum: stream contents)
		ifFalse: [self error: 'Incorrect SHA checksum of file from orginal URL']]
		on: Exception do: [:ex |
			Transcript show: 'Download from original url (', aDownloadable downloadUrl, ') failed with this exception: ', ex messageText;cr.
			SMUtilities isServer
				ifTrue: [^nil]
				ifFalse: [
					Transcript show: 'Trying server cache instead.'; cr.
					[stream := (self cacheUrlFor: aDownloadable) asUrl retrieveContents contentStream binary.
					(stream contents size = 21 and: [stream contents asString = 'SMFILEMISSINGONSERVER'])
						ifTrue: [self error: 'File missing in server cache'].
					(stream contents size = 24 and: [stream contents asString = 'SMRELEASENOTDOWNLOADABLE'])
						ifTrue: [self error: 'Release not downloadable'].
					(aDownloadable correctSha1sum: stream contents)
						ifFalse: [self error: 'Incorrect SHA checksum of file from server']]
							on: Exception do: [:ex2 | | msg |
								msg := 'Download from server cache of ', aDownloadable printName, ' failed with this exception: ', ex2 messageText.
								Transcript show: msg; cr.
								self error: msg]]].
	^ stream! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMFileCache class
	instanceVariableNames: ''!

!SMFileCache class methodsFor: 'instance creation' stamp: 'gk 1/23/2004 10:21'!
newFor: aMap
	"This is the default creation method, responsible for ensuring the
	paths and such exist, and filling in defaults."

	^self new forMap: aMap
! !
SMEmbeddedResource subclass: #SMGenericEmbeddedResource
	instanceVariableNames: 'contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMGenericEmbeddedResource commentStamp: 'gk 10/12/2005 23:01' prior: 0!
A generic embedded resource is simply some kind of object, held in instvar #contents, that is stored inside the map. No download is needed.
Embedded resources should be "small" and typically only be used for resources that
are needed to be available at all times without downloading. A typical example is meta data for other SMObjects.

!


!SMGenericEmbeddedResource methodsFor: 'as yet unclassified' stamp: 'gk 10/12/2005 23:00'!
contents
	"Answers the contents object."

	^contents! !

!SMGenericEmbeddedResource methodsFor: 'as yet unclassified' stamp: 'gk 5/5/2006 02:07'!
contents: obj
	"Sets the actual contents of this resource.
	SM does not know what it is."
	
	contents := obj! !
Object subclass: #SMInstallationDeviation
	instanceVariableNames: 'brokenConfigurations selectedRelease'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMInstallationDeviation commentStamp: '<historical>' prior: 0!
An installation deviation is when the user decides to install or upgrade to a release that is newer than one or more used configurations specify.
This means that the other installed releases which configurations will be broken may not work correctly.
Instvar selectedRelease refers to the release selected to install, brokenConfigurations is a collection of all configurations that need another release of this package.!


!SMInstallationDeviation methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
otherReleases
	| package |
	package := selectedRelease package.
	^ brokenConfigurations collect: [:conf |
		conf releases detect: [:r | r package == package]]! !

!SMInstallationDeviation methodsFor: 'accessing' stamp: 'gk 10/4/2004 11:14'!
selectedRelease
	^ selectedRelease! !


!SMInstallationDeviation methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
selectedRelease: aRelease releases: releases

	| p others otherRequired |
	selectedRelease := aRelease.
	p := selectedRelease package.
	brokenConfigurations := OrderedCollection new.
	others := releases copyWithout: aRelease.
	others := others select: [:r | r package ~= p].
	others do: [:rel |
		rel workingConfigurations do: [:conf |
			otherRequired := conf requiredReleases select: [:r | r package ~= p].
			((others includesAllOf: otherRequired) and:
				[(conf requiredReleases includes: selectedRelease) not])
					ifTrue: [brokenConfigurations add: conf]]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMInstallationDeviation class
	instanceVariableNames: ''!

!SMInstallationDeviation class methodsFor: 'instance creation' stamp: 'gk 10/13/2004 00:51'!
selectedRelease: release releases: releases
	^self new selectedRelease: release releases: releases! !
Object subclass: #SMInstallationProposal
	instanceVariableNames: 'installList comment deviations task'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMInstallationProposal commentStamp: '<historical>' prior: 0!
This is primarily an ordered list of package release installations or upgrades to achieve a given installation task.
!


!SMInstallationProposal methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
calculateComment

	comment := ''! !

!SMInstallationProposal methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
calculateDeviations
	"Calculate deviations. Currently we just pick the newest release."

	| conflicts newest |
	deviations := OrderedCollection new.
	conflicts := self collectConflictsIn: installList.
	conflicts keysAndValuesDo: [:package :releases |
		newest := releases first.
		releases do: [:r | (r newerThan: newest) ifTrue: [newest := r]].
		deviations add: (SMInstallationDeviation selectedRelease: newest releases: installList)]! !

!SMInstallationProposal methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
collectConflictsIn: collectionOfReleases
	"Collect all conflicts where there are either
		- multiple releases of the same package and/or
		- another release of the same package already installed
	Return the conflicts as an IdentityDictionary with
	the package as key and the value being a Set of releases."

	| conflicts set |
	conflicts := IdentityDictionary new.
	collectionOfReleases do: [:r |
		set := conflicts at: r package ifAbsent: [
				conflicts at: r package put: OrderedCollection new].
		set add: r].
	"Add the installed releases too"
	conflicts keysAndValuesDo: [:key :value |
		key isInstalled ifTrue: [value add: key installedRelease]].
	"Prune release sets with only one member"
	^conflicts select: [:releaseSet | releaseSet size > 1]! !

!SMInstallationProposal methodsFor: 'initialize-release' stamp: 'gk 10/13/2004 01:26'!
hasDeviations
	^ deviations notEmpty! !

!SMInstallationProposal methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
installList: anOrderedCollection

	installList := anOrderedCollection.
	self calculateDeviations.
	self calculateComment! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMInstallationProposal class
	instanceVariableNames: ''!

!SMInstallationProposal class methodsFor: 'instance creation' stamp: 'gk 10/1/2004 10:01'!
installList: anOrderedCollection
	^ self new installList: anOrderedCollection! !
Object subclass: #SMInstallationRegistry
	instanceVariableNames: 'installedPackages installCounter map'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMInstallationRegistry commentStamp: '<historical>' prior: 0!
A registry instance keeps track of installations into an image. Typically used by the SMSqueakMap instance when installing package releases.!


!SMInstallationRegistry methodsFor: 'services' stamp: 'gk 5/5/2006 02:07'!
clearInstalledPackages
	"Simply clear the dictionary with information on installed packages.
	Might be good if things get corrupted etc. Also see
	SMSqueakMap class>>recreateInstalledPackagesFromChangeLog"

	installedPackages := nil.
	installCounter := 0! !


!SMInstallationRegistry methodsFor: 'queries' stamp: 'gk 8/1/2004 17:51'!
clearInstalledPackageWithId: aPackageId
	"Clear the fact that any release of this package is installed.
	Can be used even when the map isn't loaded."

	^installedPackages ifNotNil: [
		installedPackages removeKey: (UUID fromString: aPackageId) ifAbsent: [nil]]! !

!SMInstallationRegistry methodsFor: 'queries' stamp: 'gk 5/5/2006 02:07'!
installedPackages
	"Answer all packages that we know are installed.
	Lazily initialize. The Dictionary contains the installed packages
	using their UUIDs as keys and the version string as the value."

	| result p |
	result := OrderedCollection new.
	installedPackages ifNil: [^#()]
		ifNotNil: [installedPackages keys
					do: [:k |
						p := map object: k.
						p ifNotNil: [result add: p]]].
	^result! !

!SMInstallationRegistry methodsFor: 'queries' stamp: 'gk 5/5/2006 02:07'!
installedReleaseOf: aPackage
	"If the package is installed, return the release.
	Otherwise return nil. SM2 stores the version as
	an Association to be able to distinguish it."

	| autoVersionOrOld |
	installedPackages ifNil: [^nil].
	autoVersionOrOld := (installedPackages at: aPackage id ifAbsent: [^nil]) last first.
	(autoVersionOrOld isKindOf: Association)
		ifTrue: [
			^aPackage releaseWithAutomaticVersion: autoVersionOrOld value]
		ifFalse: [
			^aPackage releaseWithVersion: autoVersionOrOld]! !

!SMInstallationRegistry methodsFor: 'queries' stamp: 'gk 5/5/2006 02:07'!
installedVersionOfPackageWithId: anId
	"If the package is installed, return the automatic version or version String.
	Otherwise return nil. This can be used without the map loaded."

	| autoVersionOrOld |
	installedPackages ifNil: [^nil].
	autoVersionOrOld := (installedPackages at: anId ifAbsent: [^nil]) last first.
	(autoVersionOrOld isKindOf: Association)
		ifTrue: [
			^autoVersionOrOld value]
		ifFalse: [
			^autoVersionOrOld]! !

!SMInstallationRegistry methodsFor: 'queries' stamp: 'gk 5/5/2006 02:07'!
installedVersionOf: aPackage
	"If the package is installed, return the version as a String.
	If it is a package installed during SM1 it will return the manual version String,
	for SM2 it returns the automatic version as a String.
	If package is not installed - return nil. If you want it to work without the map loaded you
	should instead use #installedVersionOfPackageWithId:."

	| versionOrString |
	versionOrString := self installedVersionOfPackageWithId: aPackage id.
	versionOrString ifNil: [^nil].
	^versionOrString isString
		ifTrue: [versionOrString]
		ifFalse: [versionOrString versionString]! !


!SMInstallationRegistry methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
countInstall
	"Increase the install counter."

	installCounter ifNil: [installCounter := 0].
	^installCounter := installCounter + 1
! !

!SMInstallationRegistry methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
markInstalled: uuid version: version time: time counter: num
	"Private. Mark the installation. SM2 uses an Association
	to distinguish the automatic version from old versions."


	| installs |
	installedPackages ifNil: [installedPackages := Dictionary new].
	installs := installedPackages at: uuid
				ifAbsent: [installedPackages at: uuid put: OrderedCollection new].
	installs add:
		(Array with: 2->version
				with: time
				with: num)! !


!SMInstallationRegistry methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
installCounter: anInteger
	"Set counter directly."

	installCounter := anInteger! !

!SMInstallationRegistry methodsFor: 'accessing' stamp: 'gk 8/1/2004 17:44'!
installedPackagesDictionary
	"Access the dictionary directly. The UUID of the installed package is the key.
	The value is an OrderedCollection of Arrays.
	The arrays have the smartVersion of the package, the time of the
	installation in seconds and the sequence number (installCounter)."

	^installedPackages ifNil: [Dictionary new]! !

!SMInstallationRegistry methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
installedPackagesDictionary: aDict
	"Set dictionary directly."

	installedPackages := aDict! !

!SMInstallationRegistry methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
map: aMap

	map := aMap! !


!SMInstallationRegistry methodsFor: 'installation-changelog' stamp: 'gk 5/5/2006 02:07'!
noteInstalledPackageWithId: uuidString autoVersion: version atSeconds: time number: num
	"Mark a package as installed in the Dictionary.
	This method is called when replaying a logged installation.
	<time> is the point in time as totalSeconds of the installation.
	<num> is the installCount of the installation.
	This method is typically called from a doIt in the changelog
	in order to try to keep track of packages installed."

	num negative ifFalse: ["Not an emulated count from prior SM1.07"
		installCounter := num max: installCounter].
	self markInstalled: (UUID fromString: uuidString) version: version time: time counter: num! !

!SMInstallationRegistry methodsFor: 'installation-changelog' stamp: 'gk 5/5/2006 02:07'!
noteInstalledPackage: uuidString version: version
	"Mark a specific version of a package as installed.
	This method is called when replaying a logged installation
	from before SqueakMap 1.07. Such logged installations lacked
	a timestamp and a count. We take the current time and a
	count starting from -10000 and upwards. This should keep
	the sorting order correct."

	"Find the lowest installed count."
	| lowest |
	lowest := 0.
	installedPackages ifNotNil: [
		installedPackages valuesDo: [:oc |
			oc do: [:array |
				array last < lowest ifTrue: [lowest := array last]]]]
		ifNil: [lowest := -10000].
	lowest negative ifFalse: [lowest := -10000].
	^self noteInstalledPackage: uuidString version: version
		atSeconds: Time totalSeconds number: lowest + 1! !

!SMInstallationRegistry methodsFor: 'installation-changelog' stamp: 'gk 5/5/2006 02:07'!
noteInstalledPackage: uuidString version: version atSeconds: time number: num
	"Mark a package as installed in the Dictionary.
	This method is called when replaying a logged installation.
	<time> is the point in time as totalSeconds of the installation.
	<num> is the installCount of the installation.
	This method is typically called from a doIt in the changelog
	in order to try to keep track of packages installed."

	num negative ifFalse: ["Not an emulated count from prior SM1.07"
		installCounter := num max: installCounter].
	self markInstalled: (UUID fromString: uuidString) version: version time: time counter: num! !


!SMInstallationRegistry methodsFor: 'installation' stamp: 'gk 5/5/2006 02:07'!
noteInstalledPackageWithId: aPackageId autoVersion: aVersion name: aName
	"The package release was just successfully installed.
	Can be used to inform SM of an installation not been
	done using SM, even when the map isn't loaded.

	We record the fact in our Dictionary of installed packages
	and log a 'do it' to mark this in the changelog.
	The doit helps keeping track of the packages when
	recovering changes etc - not a perfect solution but should help.
	The map used is the default map.
	The id of the package is the key and the value is an OrderedCollection
	of Arrays with the release auto version, the point in time and the current installCounter."

	| time name id v |
	v := aVersion isString ifTrue: [aVersion asVersion] ifFalse: [aVersion].
	aName ifNil: [name := '<unknown package name>'] ifNotNil: [name := aName].
	id := UUID fromString: aPackageId.
	time := Time totalSeconds.
	self countInstall.
	self markInstalled: id version: v time: time counter: installCounter.
	(((Smalltalk classNamed: 'SmalltalkImage') ifNotNilDo: [:si | si current]) ifNil: [Smalltalk])
		logChange: '"Installed ', name, ' auto version ', v versionString, '".
(Smalltalk at: #SMSqueakMap ifAbsent: []) ifNotNil:[
	SMSqueakMap noteInstalledPackageWithId: ', id asString storeString, ' autoVersion: ', v storeString, ' atSeconds: ', time asString, ' number: ', installCounter asString, ']'! !

!SMInstallationRegistry methodsFor: 'installation' stamp: 'gk 5/5/2006 02:07'!
noteUninstalledPackageWithId: aPackageId autoVersion: aVersion name: aName
	"The package release was just successfully uninstalled.
	Can be used to inform SM of an uninstallation not been
	done using SM, even when the map isn't loaded.

	We record the fact in our Dictionary of installed packages
	and log a 'do it' to mark this in the changelog.
	The doit helps keeping track of the packages when
	recovering changes etc - not a perfect solution but should help.
	The map used is the default map.
	The id of the package is the key and the value is an OrderedCollection
	of Arrays with the release auto version, the point in time and the current installCounter."

	| time name id v |
	v := aVersion isString ifTrue: [aVersion asVersion] ifFalse: [aVersion].
	aName ifNil: [name := '<unknown package name>'] ifNotNil: [name := aName].
	id := UUID fromString: aPackageId.
	time := Time totalSeconds.
	self countInstall. "Used for both installs and uninstalls"
	self clearInstalled: id version: v time: time counter: installCounter.
	(((Smalltalk classNamed: 'SmalltalkImage') ifNotNilDo: [:si | si current]) ifNil: [Smalltalk])
		logChange: '"Uninstalled ', name, ' auto version ', v versionString, '".
(Smalltalk at: #SMSqueakMap ifAbsent: []) ifNotNil:[
	SMSqueakMap noteUninstalledPackageWithId: ', id asString storeString, ' autoVersion: ', v storeString, ' atSeconds: ', time asString, ' number: ', installCounter asString, ']'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMInstallationRegistry class
	instanceVariableNames: ''!

!SMInstallationRegistry class methodsFor: 'instance creation' stamp: 'gk 8/1/2004 17:42'!
map: aMap
	"Create a new registry and make it use the given map."

	^self new map: aMap! !
Object subclass: #SMInstallationTask
	instanceVariableNames: 'map engine'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMInstallationTask commentStamp: '<historical>' prior: 0!
An SMInstallationProposal is effectively a list of releases to install or upgrade to in a specific order to achieve an SMInstallationTask.
The task can be either an upgrade or a new installation - the proposal still involved an ordered list of installations or upgrades.
!


!SMInstallationTask methodsFor: 'calculation' stamp: 'gk 9/20/2004 20:49'!
calculate
	"Calculate how the task should be performed.
	After calculation the task can be inspected and presented
	to the user for confirmation. Actually performing the task
	is done by #execute."
	
	self subclassResponsibility ! !

!SMInstallationTask methodsFor: 'calculation' stamp: 'gk 9/20/2004 20:49'!
execute
	"Actually perform the task."

	self subclassResponsibility ! !


!SMInstallationTask methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
engine: anEngine
	engine := anEngine.
	map := engine map! !

!SMInstallationTask methodsFor: 'accessing' stamp: 'gk 7/29/2004 14:48'!
map
	^map! !
Object subclass: #SMInstaller
	instanceVariableNames: 'packageRelease'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-installer'!
!SMInstaller commentStamp: '<historical>' prior: 0!
An installer takes care of installing SqueakMap packages represented by SMCards.
Deciding if a package is installable and instantiating the correct installer class is done on the class side, see implementors of #canInstall:. Two methods need to be implemented by subclasses - download and install. Upgrade can also be specialized by implementing #upgrade, otherwise it will default to #install.!


!SMInstaller methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
packageRelease: aPackageRelease
	packageRelease := aPackageRelease! !


!SMInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:56'!
download
	"This service should bring the package release to
	the client and also unpack it on disk if needed.
	It will not install it into the running image though.
	Raises errors if operation does not succeed."

	self subclassResponsibility ! !

!SMInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:57'!
install
	"This service should bring the package release to the client,
	unpack it if necessary and install it into the image.
	The package release should be notified of the installation using
	'packageRelease noteInstalled'."

	self subclassResponsibility ! !

!SMInstaller methodsFor: 'services' stamp: 'gk 7/14/2004 15:38'!
upgrade
	"This service performs an upgrade to the selected release.
	Currently it just defaults to the same operation as an install -
	which is handled fine by Monticello, but not necessarily for
	other formats."

	^self install! !


!SMInstaller methodsFor: 'private' stamp: 'gk 7/13/2004 02:43'!
silent
	"Can we ask questions?"
	
	^packageRelease ifNotNil: [packageRelease map silent] ifNil: [false]! !


!SMInstaller methodsFor: 'testing' stamp: 'gk 11/23/2005 00:06'!
isCached
	"Check if it is in the cache."

	^packageRelease isCached! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMInstaller class
	instanceVariableNames: ''!

!SMInstaller class methodsFor: 'changeset utilities' stamp: 'nk 11/30/2002 17:18'!
basicNewChangeSet: newName 
	"This method copied here to ensure SqueakMap is independent of 
	ChangeSorter. "
	Smalltalk
		at: #ChangeSorter
		ifPresentAndInMemory: [:cs | ^ cs basicNewChangeSet: newName].
	(self changeSetNamed: newName)
		ifNotNil: [self error: 'The name ' , newName , ' is already used'].
	^ ChangeSet basicNewNamed: newName! !

!SMInstaller class methodsFor: 'changeset utilities' stamp: 'gh 10/31/2002 10:11'!
changeSetNamed: newName
	"This method copied here to ensure SqueakMap is independent of ChangeSorter."

	Smalltalk at: #ChangeSorter ifPresentAndInMemory: [ :cs | ^cs changeSetNamed: newName ].
	^ChangeSet allInstances detect: [ :cs | cs name = newName ] ifNone: [ nil ].! !


!SMInstaller class methodsFor: 'instance creation' stamp: 'gk 11/16/2003 23:33'!
classForPackageRelease: aPackageRelease
	"Decide which subclass to instantiate. 
	We detect and return the first subclass
	that wants to handle the release going
	recursively leaf first so that subclasses gets
	first chance if several classes compete over
	the same packages, like for example SMDVSInstaller
	that also uses the .st file extension."

	self subclasses do: [:ea |
		(ea classForPackageRelease: aPackageRelease)
			ifNotNilDo: [:class | ^ class]].
	^(self canInstall: aPackageRelease)
		ifTrue: [self]! !


!SMInstaller class methodsFor: 'testing' stamp: 'gk 11/16/2003 23:49'!
canInstall: aPackageRelease
	"Nope, I am an abstract class and can not install anything.
	But my subclasses should reimplement this."

	^ false! !

!SMInstaller class methodsFor: 'testing' stamp: 'gk 11/16/2003 23:50'!
isInstallable: aPackageRelease
	"Detect if any subclass can handle the package release."

	aPackageRelease ifNil: [^false].
	^(self classForPackageRelease: aPackageRelease) notNil! !

!SMInstaller class methodsFor: 'testing' stamp: 'gk 11/16/2003 23:49'!
isUpgradeable: aPackageRelease
	"Detect if any subclass can handle the release.
	Currently we assume that upgrade is the same as install."

	^self isInstallable: aPackageRelease! !


!SMInstaller class methodsFor: 'deprecated' stamp: 'gk 5/5/2006 02:07'!
forPackageRelease: aPackageRelease
	"Instantiate the first class suitable to install the package release.
	If no installer class is found we raise an Error."

	| class |
	aPackageRelease ifNil: [self error: 'No package release specified to find installer for.'].
	class := self classForPackageRelease: aPackageRelease.
	^class
		ifNil: [self error: 'No installer found for package ', aPackageRelease name, '.']
		ifNotNil: [class new packageRelease: aPackageRelease]! !
SMGenericEmbeddedResource subclass: #SMKabunguHint
	instanceVariableNames: 'type'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!

!SMKabunguHint methodsFor: 'as yet unclassified' stamp: 'gk 10/12/2005 20:47'!
account
	
	^ self owner! !

!SMKabunguHint methodsFor: 'as yet unclassified' stamp: 'mist 8/22/2005 23:52'!
type

	^ type! !

!SMKabunguHint methodsFor: 'as yet unclassified' stamp: 'gk 5/5/2006 02:07'!
type: t

	type := t! !
SMSimpleInstaller subclass: #SMLanguageInstaller
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-installer'!

!SMLanguageInstaller methodsFor: 'services' stamp: 'gk 3/31/2006 00:23'!
install
	"This service should bring the package to the client, 
	unpack it if necessary and install it into the image. 
	The package is notified of the installation."

	| translator |
	self cache; unpack.
	translator := Smalltalk at: #Language ifAbsent: [Smalltalk at: #NaturalLanguageTranslator].
	[translator mergeTranslationFileNamed: unpackedFileName]
			ensure: [packageRelease noteInstalled]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMLanguageInstaller class
	instanceVariableNames: ''!

!SMLanguageInstaller class methodsFor: 'testing' stamp: 'gk 3/31/2006 00:22'!
canInstall: aPackage
	"Answer if this class can install the package.
	We handle .translation files optionally compressed."

	| fileName |
	((Smalltalk includesKey: #Language)
		or: [Smalltalk includesKey: #NaturalLanguageTranslator]) ifFalse: [^false].
	fileName := aPackage downloadFileName.
	fileName ifNil: [^false].
	fileName := fileName asLowercase.
	^(fileName endsWith: '.translation') or: [
		(fileName endsWith: '.tra') or: [
			(fileName endsWith: '.tra.gz') or: [
				fileName endsWith: '.translation.gz']]]! !
SystemWindow subclass: #SMLoader
	instanceVariableNames: 'squeakMap packagesList selectedItemWrapper selectedCategoryWrapper filters categoriesToFilterIds'
	classVariableNames: 'DefaultCategoriesToFilterIds DefaultFilters'
	poolDictionaries: ''
	category: 'SMLoader'!
!SMLoader commentStamp: '<historical>' prior: 0!
A simple package loader that is currently the standard UI for SqueakMap (the model is an SMSqueakMap instance), you can open one with:

	SMLoader open!


!SMLoader methodsFor: 'accessing' stamp: 'gk 7/10/2004 15:45'!
changeFilters: anObject 
	"Update my selection."

	| oldItem index |
	oldItem := self selectedPackageOrRelease.
	filters := anObject.
	self packagesListIndex: ((index := self packageList indexOf: oldItem) 
				ifNil: [0]
				ifNotNil: [index]).
	self noteChanged! !

!SMLoader methodsFor: 'accessing' stamp: 'dvf 9/21/2003 16:34'!
packagesListIndex
	^self packageWrapperList indexOf: self selectedItemWrapper! !

!SMLoader methodsFor: 'accessing' stamp: 'dvf 9/21/2003 16:53'!
packagesListIndex: anObject
	self selectedItemWrapper: (anObject = 0 ifTrue:[nil] ifFalse: [(self packageWrapperList at: anObject)])
! !

!SMLoader methodsFor: 'accessing' stamp: 'gk 7/10/2004 03:58'!
selectedCategory
	"Return selected category."

	^(self selectedCategoryWrapper isNil)
		ifFalse: [self selectedCategoryWrapper withoutListWrapper]! !

!SMLoader methodsFor: 'accessing' stamp: 'ar 2/9/2004 02:14'!
selectedCategoryWrapper
	^selectedCategoryWrapper! !

!SMLoader methodsFor: 'accessing' stamp: 'ar 2/9/2004 02:53'!
selectedCategoryWrapper: aWrapper
	selectedCategoryWrapper := aWrapper.
	self selectedItemWrapper: nil.
	self changed: #selectedCategoryWrapper.
	self changed: #packageWrapperList.! !

!SMLoader methodsFor: 'accessing' stamp: 'dvf 9/21/2003 15:04'!
selectedItemWrapper
	^selectedItemWrapper! !

!SMLoader methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:05'!
selectedItemWrapper: aWrapper
	selectedItemWrapper := aWrapper.
	self changed: #selectedItemWrapper.
	self contentsChanged! !


!SMLoader methodsFor: 'actions' stamp: 'gk 7/12/2004 14:42'!
addSelectedCategoryAsFilter
	"Add a new filter that filters on the currently selected category.
	Make it enabled as default."

	categoriesToFilterIds add: self selectedCategory id! !

!SMLoader methodsFor: 'actions' stamp: 'gk 5/5/2006 02:05'!
askToLoadUpdates
	"Check how old the map is and ask to update it
	if it is older than 10 days or if there is no map on disk."

	| available |
	available := squeakMap isCheckpointAvailable.
	(available not or: [
		(Date today subtractDate: (Date fromSeconds:
			(squeakMap directory directoryEntryFor: squeakMap lastCheckpointFilename)
				modificationTime)) > 3])
		ifTrue: [
			(self confirm: 
				(available ifTrue: ['The map on disk is more than 10 days old,
update it from the Internet?'] ifFalse: ['There is no map on disk,
fetch it from the Internet?']))
				ifTrue: [self loadUpdates]]! !

!SMLoader methodsFor: 'actions' stamp: 'gk 5/5/2006 02:05'!
cachePackageReleaseAndOfferToCopy
	"Cache package release, then offer to copy it somewhere.
	Answer the chosen file's location after copy,
	or the cache location if no directory was chosen."

	| release installer newDir newName newFile oldFile oldName |
	release := self selectedPackageOrRelease.
	release isPackageRelease ifFalse: [ self error: 'Should be a package release!!'].
	installer := SMInstaller forPackageRelease: release.
	[Cursor wait showWhile: [installer cache]] on: Error do: [:ex |
		| msg |
		msg := ex messageText ifNil: [ex asString].
		self informException: ex msg: ('Error occurred during download:\', msg, '\') withCRs.
		^nil ].
	installer isCached ifFalse: [self inform: 'Download failed, see transcript for details'. ^nil].
	oldName := installer fullFileName.
	newDir := FileList2 modalFolderSelector: installer directory.
	newDir ifNil: [ ^oldName ].
	newDir = installer directory ifTrue: [ ^oldName ].
	newName := newDir fullNameFor: installer fileName.
	newFile := FileStream newFileNamed: newName.
	newFile ifNil: [ ^oldName ].
	newFile binary.
	oldFile := FileStream readOnlyFileNamed: oldName.
	oldFile ifNil: [ ^nil ].
	oldFile binary.
	[[ newDir copyFile: oldFile toFile: newFile ] ensure: [ oldFile close. newFile close ]] on: Error do: [ :ex | ^oldName ].
	^newName! !

!SMLoader methodsFor: 'actions' stamp: 'gk 5/5/2006 02:05'!
downloadPackageRelease
	"Force a download of the selected package release into the cache."

	| release |
	release := self selectedPackageOrRelease.
	release isPackageRelease ifFalse: [ self error: 'Should be a package release!!'].
	[Cursor wait showWhile: [
		(SMInstaller forPackageRelease: release) download]
	] on: Error do: [:ex |
		| msg | 
		msg := ex messageText ifNil: [ex asString].
		self informException: ex msg: ('Error occurred during download:\', msg, '\') withCRs]! !

!SMLoader methodsFor: 'actions' stamp: 'gk 5/5/2006 02:05'!
emailPackageMaintainers
	"Send mail to package owner and co-maintainers."

	| item package toAddresses |
	item := self selectedPackageOrRelease.
	package := item isPackageRelease ifTrue: [item package] ifFalse: [item].

	"(this logic should be moved to MailMessage as soon as it can handle 
multiple To: addresses)"
	toAddresses := '<', package owner email, '>'.
	package maintainers ifNotNil: [
		package maintainers do: [:maintainer |
			toAddresses := toAddresses, ', <', maintainer email, '>']].

	SMUtilities sendMailTo: toAddresses regardingPackageRelease: item! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/10/2004 16:04'!
findPackage: aString notifying: aView 
	"Search and select a package with the given (sub) string"

	| index list match |
	match := aString asString asLowercase.
	index := self packagesListIndex.
	list := self packageNameList.
	list isEmpty ifTrue: [^self].
	index + 1 to: list size
		do: 
			[:i | 
			((list at: i) asLowercase includesSubString: match) 
				ifTrue: [^self packagesListIndex: i]].
	"wrap around"
	1 to: index
		do: 
			[:i | 
			((list at: i) asLowercase includesSubString: match) 
				ifTrue: [^self packagesListIndex: i]].
	self inform: 'No package matching ' , aString asString! !

!SMLoader methodsFor: 'actions' stamp: 'gk 5/5/2006 02:05'!
installPackageRelease
	"Install selected package or release.
	The cache is used."

	| item release |
	item := self selectedPackageOrRelease.
	item isPackageRelease
		ifTrue: [
			(item isPublished or: [self confirm: 'Selected release is not published yet, install anyway?'])
				ifTrue: [^self installPackageRelease: item]]
		ifFalse: [
			release := item lastPublishedReleaseForCurrentSystemVersion.
			release ifNil: [
				(self confirm: 'The package has no published release for your Squeak version, try releases for any Squeak version?')
					ifTrue: [
						release := item lastPublishedRelease.
						release ifNil: [
							(self confirm: 'The package has no published release at all, take the latest of the unpublished releases?')
								ifTrue: [release := item lastRelease]]]].
			release ifNotNil: [^self installPackageRelease: release]]! !

!SMLoader methodsFor: 'actions' stamp: 'gk 11/18/2003 02:19'!
listInPasteBuffer
	"Useful when talking with people etc.
	Uses the map to produce a nice String."

	Clipboard clipboardText:
		(String streamContents: [:s |
			packagesList do: [:p |
				s nextPutAll: p nameWithVersionLabel; cr ]]) asText! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/10/2004 18:51'!
loadUpdates
	[Cursor wait showWhile: [
		squeakMap loadUpdates.
		self noteChanged ]
	] on: Error do: [:ex |
		self informException: ex msg: ('Error occurred when updating map:\', ex messageText, '\') withCRs]! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/12/2004 14:42'!
removeCategoryFilters
	"Remove all category filters."

	categoriesToFilterIds := OrderedCollection new! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/12/2004 14:42'!
removeSelectedCategoryAsFilter
	"Remove the filter that filters on the currently selected category."

	categoriesToFilterIds remove: self selectedCategory id! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/12/2004 14:42'!
saveFiltersAsDefault
	"Save the current filters as default so that they
	are selected the next time the loader is opened."

	DefaultFilters := filters copy.
	DefaultCategoriesToFilterIds := categoriesToFilterIds copy! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/13/2004 16:05'!
uncheckFilters
	"Uncheck all filters."
	
	filters := OrderedCollection new.
	self noteChanged! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/13/2004 15:25'!
upgradeInstalledPackages
	"Tries to upgrade all installed packages to the latest published release for this
	version of Squeak. So this is a conservative approach."

	| installed old myRelease toUpgrade info |
	installed := squeakMap installedPackages.
	old := squeakMap oldPackages.
	old isEmpty ifTrue: [
			^self inform: 'All ', installed size printString, ' installed packages are up to date.'].
	toUpgrade := squeakMap upgradeableAndOldPackages.
	toUpgrade isEmpty ifTrue: [
			^self inform: 'None of the ', old size printString, ' old packages of the ', installed size printString, ' installed can be automatically upgraded. You need to upgrade them manually.'].
	old size < toUpgrade size ifTrue: [
		info := 'Of the ', old size printString, ' old packages only ', toUpgrade size printString, ' can be upgraded.
The following packages will not be upgraded:
',  (String streamContents: [:s | (old removeAll: toUpgrade; yourself)
	do: [:p | s nextPutAll: p nameWithVersionLabel; cr]])]
		ifFalse: [info := 'All old packages upgradeable.'].
	(self confirm: info, '
About to upgrade the following packages:
', (String streamContents: [:s | toUpgrade do: [:p | s nextPutAll: p nameWithVersionLabel; cr]]), 'Proceed?') ifTrue: [
			myRelease := self installedReleaseOfMe.
			[Cursor wait showWhile: [
				squeakMap upgradeOldPackages.
				self inform: toUpgrade size printString, ' packages successfully upgraded.'.
				myRelease = self installedReleaseOfMe ifFalse: [self reOpen].
				self noteChanged]
			] on: Error do: [:ex |
				self informException: ex msg: ('Error occurred when upgrading old packages:\', ex messageText, '\') withCRs]]! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/14/2004 16:29'!
upgradeInstalledPackagesConfirm
	"Tries to upgrade all installed packages to the latest published release for this
	version of Squeak. Confirms on each upgrade."

	^ self upgradeInstalledPackagesConfirm: true! !

!SMLoader methodsFor: 'actions' stamp: 'gk 7/14/2004 16:29'!
upgradeInstalledPackagesNoConfirm
	"Tries to upgrade all installed packages to the latest published release for this
	version of Squeak. No confirmation on each upgrade."

	^ self upgradeInstalledPackagesConfirm: false! !


!SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:45'!
filterAdd: anObject

	self changeFilters: (self filters copyWith: anObject)
! !

!SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:45'!
filterRemove: anObject

	self changeFilters: (self filters copyWithout: anObject)
! !

!SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/13/2004 15:49'!
filterSpecs
	"Return a specification for the filter menu. Is called each time."

	| specs |
	specs := #(
	#('display only auto-installable packages' #filterAutoInstall 'display only packages that can be installed automatically')
	#('display only new available packages' #filterAvailable 'display only packages that are not installed or that have newer releases available.')
	#('display only new safely available packages' #filterSafelyAvailable 'display only packages that are not installed or that have newer releases available that are safe to install, meaning that they are published and meant for the current version of Squeak.')
	#('display only installed packages' #filterInstalled 'display only packages that are installed.')
	#('display only published packages' #filterPublished 'display only packages that have at least one published release.'))
		asOrderedCollection.
	categoriesToFilterIds do: [:catId |
		specs add: {'display only packages in ', (squeakMap object: catId) name. catId. 'display only packages that are in the category.'}].
	^ specs! !

!SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:47'!
filters
	^filters! !

!SMLoader methodsFor: 'filter utilities' stamp: 'dvf 10/25/2002 11:27'!
labelForFilter: aFilterSymbol 
	^(self filterSpecs detect: [:fs | fs second = aFilterSymbol]) first! !

!SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/11/2004 22:29'!
package: aPackage filteredByCategory: aCategory
	"Answer true if the package should be shown
	if we filter on <aCategory>. It should be shown
	if itself or any of its releases has the category."

	| releases |
	releases := aPackage releases.
	^(aPackage hasCategoryOrSubCategoryOf: aCategory) or: [
			releases anySatisfy: [:rel |
				rel hasCategoryOrSubCategoryOf: aCategory]]! !

!SMLoader methodsFor: 'filter utilities' stamp: 'dvf 10/25/2002 14:48'!
showFilterString: aFilterSymbol 
	^(self stateForFilter: aFilterSymbol), (self labelForFilter: aFilterSymbol)! !

!SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:45'!
stateForFilter: aFilterSymbol 
	^(self filters includes: aFilterSymbol) ifTrue: ['<yes>'] ifFalse: ['<no>']

! !

!SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:46'!
toggleFilterState: aFilterSymbol 

	^(self filters includes: (aFilterSymbol)) 
		ifTrue: [self filterRemove: aFilterSymbol]
		ifFalse: [self filterAdd: aFilterSymbol]! !


!SMLoader methodsFor: 'filters' stamp: 'dvf 10/25/2002 11:29'!
filterAutoInstall
	^[:package | package isInstallable]! !

!SMLoader methodsFor: 'filters' stamp: 'gk 7/13/2004 15:28'!
filterAvailable
	
	^[:package | package isAvailable]! !

!SMLoader methodsFor: 'filters' stamp: 'dvf 10/25/2002 17:08'!
filterInstalled
	^[:package | package isInstalled]! !

!SMLoader methodsFor: 'filters' stamp: 'dvf 10/25/2002 17:08'!
filterNotInstalledYet
	^[:package | package isInstalled not]! !

!SMLoader methodsFor: 'filters' stamp: 'dvf 10/25/2002 17:07'!
filterNotUptoDate
	
	^[:package | package isAvailable]! !

!SMLoader methodsFor: 'filters' stamp: 'gk 1/28/2004 23:42'!
filterPublished
	^[:package | package isPublished]! !

!SMLoader methodsFor: 'filters' stamp: 'gk 7/13/2004 15:28'!
filterSafelyAvailable
	
	^[:package | package isSafelyAvailable]! !

!SMLoader methodsFor: 'filters' stamp: 'gk 7/11/2004 03:02'!
filterVersion
	"Ignore spaces in the version string, they're sometimes spurious.

	Not used anymore."

	^[:package | package categories anySatisfy:  
		[:cat | (cat name, '*') match: (Smalltalk version copyWithout: $ ) ]]! !


!SMLoader methodsFor: 'gui building' stamp: 'gk 5/5/2006 02:05'!
addPackagesTo: window at: fractions plus: verticalOffset
	"Add the list for packages, and answer the verticalOffset plus the height added"

	| divider listMorph |
	listMorph := self buildMorphicPackagesList.
	listMorph borderWidth: 0.
	divider := BorderedSubpaneDividerMorph forBottomEdge.
	Preferences alternativeWindowLook ifTrue:[
		divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2.
	].
	window 
		addMorph: listMorph
		
	! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 5/5/2006 02:05'!
browseCacheDirectory
	"Open a FileList2 on the directory for the package or release."

	| item dir win |
	item := self selectedPackageOrRelease.
	item ifNil: [^nil].
	dir := item isPackage
				ifTrue: [squeakMap cache directoryForPackage: item]
				ifFalse: [squeakMap cache directoryForPackageRelease: item].
	win := FileList2 morphicViewOnDirectory: dir. " withLabel: item name, ' cache directory'."
	win openInWorld
! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 6/21/2005 15:04'!
buildMorphicCategoriesList
	"Create the hierarchical list holding the category tree."

	| list |
	list := (SimpleHierarchicalListMorph 
		on: self
		list: #categoryWrapperList
		selected: #selectedCategoryWrapper
		changeSelected: #selectedCategoryWrapper:
		menu: #categoriesMenu:
		keystroke: nil)
		autoDeselect: true;
		enableDrag: false;
		enableDrop: true;
		yourself.
	list setBalloonText: 'The categories are structured in a tree. Packages and package releases belong to several categories.
You can add one or more categories as filters and enable them in the menu.'.
"	list scroller submorphs do:[:each| list expandAll: each]."
	list adjustSubmorphPositions.
	^list! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 7/11/2004 03:04'!
buildMorphicPackagesList
	"Create the hierarchical list holding the packages and releases."

	^(SimpleHierarchicalListMorph 
		on: self
		list: #packageWrapperList
		selected: #selectedItemWrapper
		changeSelected: #selectedItemWrapper:
		menu: #packagesMenu:
		keystroke: nil)
		autoDeselect: false;
		enableDrag: false;
		enableDrop: true;
		setBalloonText: 'Here all packages with their releases are listed that should be displayed according the current filter.';
		yourself! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 5/5/2006 02:05'!
buildPackagePane
	"Create the text area to the right in the loader."

	| ptm |
	ptm := PluggableTextMorph 
		on: self 
		text: #contents
		accept: nil
		readSelection: nil "#packageSelection "
		menu: nil.
	ptm setBalloonText: 'This is where the selected package or package release is displayed.'.
	ptm lock.
	^ptm! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 5/5/2006 02:05'!
buildSearchPane
	| typeInView |
	typeInView := PluggableTextMorph on: self 
		text: nil accept: #findPackage:notifying:
		readSelection: nil menu: nil.
	typeInView setBalloonText:'To find a package type in a fragment of its name and hit return'.
	typeInView acceptOnCR: true.
	(typeInView respondsTo: #hideScrollBarsIndefinitely) ifTrue: [
		typeInView hideScrollBarsIndefinitely]
	ifFalse: [typeInView hideScrollBarIndefinitely].
	^typeInView! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 7/13/2004 16:14'!
createWindow
	"Create the package loader window."
	
	self addMorph: (self buildSearchPane borderWidth: 0)
		frame: (0.0 @ 0.0 corner: 0.3 @ 0.07).
	self addMorph: (self buildMorphicPackagesList borderWidth: 0)
		frame: (0.0 @ 0.07 corner: 0.3 @ 0.6).
	self addMorph: (self buildMorphicCategoriesList borderWidth: 0)
		frame: (0.0 @ 0.6 corner: 0.3 @ 1.0).
	self addMorph: (self buildPackagePane borderWidth: 0)
		frame: (0.3 @ 0.0 corner: 1.0 @ 1.0).
	self on: #mouseEnter send: #paneTransition: to: self.
	self on: #mouseLeave send: #paneTransition: to: self! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 7/12/2004 11:14'!
defaultButtonPaneHeight
	"Answer the user's preferred default height for new button panes."

	^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 5/5/2006 02:05'!
help
	"Present help text. If there is a web server available, offer to open it.
	Use the WebBrowser registry if possible, or Scamper if available."
	| message browserClass |
	message := 'Welcome to the SqueakMap package loader. 
The names of packages are followed by (installed version -> latest version). 
If there is no arrow, your installed version of the package is the latest.
The checkbox menu items at the bottom let you modify which packages 
you''ll see. Take a look at them - only some packages are shown initially. 
The options available for a package depend on how it was packaged. 
If you like a package or have comments on it, please contact
the author or the squeak mailing list.'.

	browserClass := Smalltalk at: #WebBrowser ifPresent: [ :registry | registry default ].
	browserClass := browserClass ifNil: [ Smalltalk at: #Scamper ifAbsent: [ ^self inform: message ]].

	(self confirm: message, '
Would you like to view more detailed help on the SqueakMap swiki page?') 
	ifTrue: [ browserClass openOnUrl: 'http://minnow.cc.gatech.edu/squeak/2726' asUrl]! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 4/5/2005 21:17'!
openAsMorph
	"Open the loader as a Morphic window."
	"SMLoader new openAsMorph"
	
	^self createWindow openInWorld! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 4/5/2005 21:43'!
paneColorOld
	^ Color yellow muchLighter duller! !

!SMLoader methodsFor: 'gui building' stamp: 'gk 4/5/2005 21:43'!
perform: selector orSendTo: otherTarget 
	"Selector was just chosen from a menu by a user. If can respond, then  
	perform it on myself. If not, send it to otherTarget, presumably the  
	editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ super perform: selector orSendTo: otherTarget]! !


!SMLoader methodsFor: 'initialization' stamp: 'gk 5/5/2006 02:05'!
on: aSqueakMap 
	"Initialize instance."

	squeakMap := aSqueakMap.
	squeakMap synchWithDisk.
	filters := DefaultFilters copy.
	categoriesToFilterIds := DefaultCategoriesToFilterIds copy.
	self askToLoadUpdates! !


!SMLoader methodsFor: 'lists' stamp: 'gk 7/12/2004 01:16'!
categoryWrapperList
	"Create the wrapper list for the hierarchical list.
	We sort the categories by name but ensure that 'Squeak versions'
	is first if it exists."
	 
	| list first |
	list := (((squeakMap categories select:[:each | each parent == nil]) asArray 
		sort:[:c1 :c2 | c1 name <= c2 name])).
	first := list detect:[:any | any name = 'Squeak versions'] ifNone:[nil].
	first ifNotNil:[
		list := list copyWithout: first.
		list := {first}, list].
	^list collect:[:cat | SMCategoryWrapper with: cat model: self].! !

!SMLoader methodsFor: 'lists' stamp: 'gk 7/13/2004 17:10'!
packageList
	"Return a list of the SMPackages that should be visible
	by applying all the filters. Also filter based on the currently
	selected category - if any."

	| list selectedCategory |
	list := packagesList ifNil: [
			packagesList := self packages select: [:p | 
				filters allSatisfy: [:currFilter |
					currFilter isSymbol
						ifTrue: [(self perform: currFilter) value: p]
						ifFalse: [
						self package: p
							filteredByCategory: (squeakMap object: currFilter)]]]].
	selectedCategoryWrapper ifNil:[self updateLabel: list. ^list].
	selectedCategory := selectedCategoryWrapper category.
	list := list select: [:each | self package: each filteredByCategory: selectedCategory].
	self updateLabel: list.
	^list! !

!SMLoader methodsFor: 'lists' stamp: 'dvf 9/21/2003 16:36'!
packageNameList
	^self packageWrapperList collect: [:e | e withoutListWrapper name]! !

!SMLoader methodsFor: 'lists' stamp: 'gk 7/9/2004 01:36'!
packageWrapperList
	"Return the list with each element wrapped so that it
	can be used in a SimpleHierarchicalListMorph."

	^self packageList collect: [:e | SMPackageWrapper with: e]! !

!SMLoader methodsFor: 'lists' stamp: 'gk 7/13/2004 17:10'!
updateLabel: packagesShown
	"Update the label of the window."

	self setLabel: 'SqueakMap Package Loader (', packagesShown size printString,
			'/', squeakMap packages size printString, ')'! !


!SMLoader methodsFor: 'menus' stamp: 'gk 7/13/2004 17:20'!
addFiltersToMenu: aMenu
	| filterSymbol help |
	self filterSpecs do: [:filterArray | 
		filterSymbol := filterArray second.
		help := filterArray third.
		aMenu addUpdating: #showFilterString: target: self selector: #toggleFilterState: argumentList: (Array with: filterSymbol).
		aMenu balloonTextForLastItem: help].
	aMenu addLine;
		addList: #(('uncheck all filters' uncheckFilters 'unchecks all filters so that all packages are listed'))
	! !

!SMLoader methodsFor: 'menus' stamp: 'gk 7/10/2004 03:58'!
categoriesMenu: aMenu 
	"Answer the categories-list menu."

	self selectedCategory 
		ifNotNil: [aMenu addList: self categorySpecificOptions; addLine].
	aMenu addList: self generalOptions.
	self addFiltersToMenu: aMenu.
	^aMenu! !

!SMLoader methodsFor: 'menus' stamp: 'md 7/13/2006 10:47'!
categorySpecificOptions
	| choices |
	choices := OrderedCollection new.
	(categoriesToFilterIds includes: self selectedCategory id)
		ifTrue: [
			choices add: #('remove filter' #removeSelectedCategoryAsFilter 'Remove the filter for the selected category.')]
		ifFalse: [
			choices add: #('add as filter' #addSelectedCategoryAsFilter 'Add the selected category as a filter so that only packages in that category are shown.')].
	categoriesToFilterIds isEmpty ifFalse: [
		choices add: #('remove all category filters' #removeCategoryFilters 'Remove all category filters.')].
	^ choices! !

!SMLoader methodsFor: 'menus' stamp: 'gk 7/14/2004 16:30'!
generalOptions
	^#(#('help' #help) 
		#('update map from the net' loadUpdates)
		#('upgrade all installed packages' upgradeInstalledPackagesNoConfirm)
		#('upgrade all installed packages confirming each' upgradeInstalledPackagesConfirm)
		#('put list in paste buffer' listInPasteBuffer)
		#('save filters as default' saveFiltersAsDefault)
		#- )

! !

!SMLoader methodsFor: 'menus' stamp: 'gk 7/9/2004 19:44'!
packageSpecificOptions
	| choices packageOrRelease |
	packageOrRelease := self selectedPackageOrRelease.
	choices := OrderedCollection new.
	packageOrRelease isInstallable ifTrue: [
		choices add: #('install' #installPackageRelease 'Install selected package or release, first downloading into the cache if needed.')].	
	(packageOrRelease isDownloadable and: [packageOrRelease isCached]) ifTrue: [
		choices add: #('browse cache' #browseCacheDirectory 'Browse cache directory of selected package or package release.')].

	(packageOrRelease isPackageRelease and: [packageOrRelease isDownloadable]) ifTrue: [
		choices add: #('copy from cache' #cachePackageReleaseAndOfferToCopy 'Download selected release into cache first if needed, and then offer to copy it somewhere else.' ).
		choices add: #('force download into cache' #downloadPackageRelease 'Force a download of the selected release into the cache.' )].
	choices add: #('email package maintainers' emailPackageMaintainers 'Open an editor to send an email to the owner and co-maintainers of this package.').
	^ choices! !

!SMLoader methodsFor: 'menus' stamp: 'gk 7/9/2004 03:04'!
packagesMenu: aMenu 
	"Answer the packages-list menu."

	self selectedPackageOrRelease 
		ifNotNil: [aMenu addList: self packageSpecificOptions; addLine].
	aMenu addList: self generalOptions.
	self addFiltersToMenu: aMenu.
	^aMenu! !


!SMLoader methodsFor: 'private' stamp: 'gk 5/5/2006 02:05'!
contents
	| packageOrRelease |
	packageOrRelease := self selectedPackageOrRelease.
	^packageOrRelease
		ifNil: ['<No package selected>']
		ifNotNil: [packageOrRelease fullDescription]
! !

!SMLoader methodsFor: 'private' stamp: 'gk 7/10/2004 04:04'!
informException: ex msg: msg 
	"Tell the user that an error has occurred.
	Offer to open debug notifier."

	(self confirm: msg, 'Would you like to open a debugger?')
		ifTrue: [ex pass]! !

!SMLoader methodsFor: 'private' stamp: 'gk 7/11/2004 03:58'!
installedReleaseOfMe
	"Return the release of the installed package loader."

	^squeakMap installedReleaseOf: (squeakMap packageWithId: '941c0108-4039-4071-9863-a8d7d2b3d4a3').! !

!SMLoader methodsFor: 'private' stamp: 'gk 7/11/2004 04:07'!
installPackageRelease: aRelease
	"Install a package release. The cache is used."

	| myRelease |
	aRelease isCompatibleWithCurrentSystemVersion ifFalse:
		[(self confirm:
'The package you are about to install is not listed as
being compatible with your image version (', SystemVersion current majorMinorVersion, '),
so the package may not work properly.
Do you still want to proceed with the install?')
			ifFalse: [^ self]].
	myRelease := self installedReleaseOfMe.
	[Cursor wait showWhile: [
		(SMInstaller forPackageRelease: aRelease) install.
		myRelease = self installedReleaseOfMe ifFalse: [self reOpen].
		self noteChanged]
	] on: Error do: [:ex |
		| msg |
		msg := ex messageText ifNil:[ex asString].
		self informException: ex msg: ('Error occurred during install:\', msg, '\') withCRs].! !

!SMLoader methodsFor: 'private' stamp: 'gk 7/13/2004 17:07'!
noteChanged
	packagesList := nil.
	selectedCategoryWrapper := nil.
	filters ifNil: [^self reOpen].
	self changed: #categoryWrapperList.
	self changed: #packageWrapperList.
	self changed: #packagesListIndex.	"update my selection"
	self contentsChanged! !

!SMLoader methodsFor: 'private' stamp: 'gk 11/18/2003 02:24'!
packages
	"We request the packages as sorted by name by default."

	^squeakMap packagesByName asArray
! !

!SMLoader methodsFor: 'private' stamp: 'gk 7/11/2004 04:06'!
reOpen
	"Close this package loader, probably because it has been updated,
	and open a new one."

	self inform: 'This package loader has been upgraded and will be closed and reopened to avoid strange side effects.'.
	self delete.
	SMLoader open! !

!SMLoader methodsFor: 'private' stamp: 'gk 11/16/2003 20:12'!
selectedPackageOrRelease
	"Return selected package or package release."

	^(self selectedItemWrapper isNil) ifFalse: [self selectedItemWrapper withoutListWrapper]! !

!SMLoader methodsFor: 'private' stamp: 'gk 5/5/2006 02:05'!
upgradeInstalledPackagesConfirm: confirmEach
	"Tries to upgrade all installed packages to the latest published release for this
	version of Squeak. If confirmEach is true we ask for every upgrade."

	| installed old myRelease toUpgrade info |
	installed := squeakMap installedPackages.
	old := squeakMap oldPackages.
	old isEmpty ifTrue: [
			^self inform: 'All ', installed size printString, ' installed packages are up to date.'].
	toUpgrade := squeakMap upgradeableAndOldPackages.
	toUpgrade isEmpty ifTrue: [
			^self inform: 'None of the ', old size printString, ' old packages of the ', installed size printString, ' installed can be automatically upgraded. You need to upgrade them manually.'].
	old size < toUpgrade size ifTrue: [
		info := 'Of the ', old size printString, ' old packages only ', toUpgrade size printString, ' can be upgraded.
The following packages will not be upgraded:
',  (String streamContents: [:s | (old removeAll: toUpgrade; yourself)
	do: [:p | s nextPutAll: p nameWithVersionLabel; cr]])]
		ifFalse: [info := 'All old packages upgradeable.'].
	(self confirm: info, '
About to upgrade the following packages:
', (String streamContents: [:s | toUpgrade do: [:p | s nextPutAll: p nameWithVersionLabel; cr]]), 'Proceed?') ifTrue: [
			myRelease := self installedReleaseOfMe.
			[Cursor wait showWhile: [
				confirmEach ifTrue: [
					squeakMap upgradeOldPackagesConfirmBlock: [:p |
						self confirm: 'Upgrade ', p installedRelease packageNameWithVersion, ' to ',
							(p lastPublishedReleaseForCurrentSystemVersionNewerThan: p installedRelease) listName, '?']]
						ifFalse: [squeakMap upgradeOldPackages].
				self inform: toUpgrade size printString, ' packages successfully processed.'.
				myRelease = self installedReleaseOfMe ifFalse: [self reOpen].
				self noteChanged]
			] on: Error do: [:ex |
				self informException: ex msg: ('Error occurred when upgrading old packages:\', ex messageText, '\') withCRs]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMLoader class
	instanceVariableNames: ''!

!SMLoader class methodsFor: 'instance creation' stamp: 'gk 6/21/2005 10:47'!
new
	"Create a SqueakMap loader on the default map."

	^self newOn: SMSqueakMap default! !

!SMLoader class methodsFor: 'instance creation' stamp: 'gk 6/21/2005 10:47'!
newOn: aMap
	"Create a SqueakMap loader on given map."

	^super new on: aMap; yourself! !

!SMLoader class methodsFor: 'instance creation' stamp: 'gk 6/21/2005 09:28'!
open
	"Create and open a SqueakMap Loader."
	
	"SMLoader open"

	^self new openAsMorph! !

!SMLoader class methodsFor: 'instance creation' stamp: 'gk 4/5/2005 21:18'!
openOn: aSqueakMap
	"Create and open a SqueakMap Loader on a given map."

	"self openOn: SqueakMap default"

	^(self newOn: aSqueakMap) openAsMorph! !





!SMLoader class methodsFor: 'parts bin' stamp: 'gk 4/5/2005 21:23'!
descriptionForPartsBin
	^self partName: 'Package Loader'
		categories: #(Tools)
		documentation: 'SqueakMap UI'
! !


!SMLoader class methodsFor: 'class initialization' stamp: 'gk 5/5/2006 02:05'!
initialize
	"Hook us up in the world menu."
	
	"self initialize"

	self registerInFlapsRegistry.
	(Preferences windowColorFor: #SMLoader) = Color white "not set"
		ifTrue: [ Preferences setWindowColorFor: #SMLoader to: (Color colorFrom: self windowColorSpecification brightColor) ].
	 (TheWorldMenu respondsTo: #registerOpenCommand:)
         ifTrue: [
		TheWorldMenu registerOpenCommand: {'SqueakMap Package Loader'. {self. #open}}.
		TheWorldMenu unregisterOpenCommand: 'Package Loader'].
	DefaultFilters := OrderedCollection new.
	DefaultCategoriesToFilterIds := OrderedCollection new
! !

!SMLoader class methodsFor: 'class initialization' stamp: 'gk 4/5/2005 22:19'!
unload
	(TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: 
		[TheWorldMenu unregisterOpenCommand: 'SqueakMap Package Loader'].
	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!SMLoader class methodsFor: 'new-morph participation' stamp: 'gk 4/5/2005 21:21'!
initializedInstance
	^self new createWindow extent: 400@400! !

!SMLoader class methodsFor: 'new-morph participation' stamp: 'gk 4/5/2005 21:21'!
newStandAlone
	^self new createWindow! !

!SMLoader class methodsFor: 'new-morph participation' stamp: 'gk 6/21/2005 11:06'!
prototypicalToolWindow
	^self new createWindow; applyModelExtent; yourself! !

!SMLoader class methodsFor: 'new-morph participation' stamp: 'gk 6/21/2005 10:43'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry."

	self environment
		at: #Flaps
		ifPresent: [:cl | (cl respondsTo: #registerQuad:forFlapNamed:)
				ifTrue: [cl registerQuad: #(#SMLoader #prototypicalToolWindow 'Package Loader' 'The SqueakMap Package Loader' ) forFlapNamed: 'Tools']]! !


!SMLoader class methodsFor: 'window color' stamp: 'gk 6/21/2005 09:44'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference."

	^WindowColorSpec
		classSymbol: self name
		wording: 'Package Loader'
		brightColor: Color yellow muchLighter duller
		pastelColor: Color yellow veryMuchLighter duller
		helpMessage: 'The SqueakMap Package Loader'! !
SMPersonalObject subclass: #SMMaintainableObject
	instanceVariableNames: 'maintainers rss feedbackEmail'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMMaintainableObject commentStamp: '<historical>' prior: 0!
A mainainable object is a personal object that is of such a complexity that it seems beneficial to optionally co-maintain with other people.
It thus has a potential list of maintainers - other accounts that also can modify the object. It also has a field to be able to refer to an RSS feed regarding the object.!


!SMMaintainableObject methodsFor: 'maintainers' stamp: 'gk 5/5/2006 02:07'!
addMaintainer: anAccount
	"Add anAccount as a maintainer."

	maintainers ifNil: [maintainers := OrderedCollection new].
	maintainers add: anAccount.
	anAccount addCoObject: self! !

!SMMaintainableObject methodsFor: 'maintainers' stamp: 'gk 10/12/2005 23:25'!
feedbackEmail
	^feedbackEmail! !

!SMMaintainableObject methodsFor: 'maintainers' stamp: 'gk 5/5/2006 02:07'!
feedbackEmail: anEmail
	feedbackEmail := anEmail! !

!SMMaintainableObject methodsFor: 'maintainers' stamp: 'gk 7/27/2004 13:26'!
maintainers
	"Return all maintainers."

	^maintainers ifNil: [#()]! !

!SMMaintainableObject methodsFor: 'maintainers' stamp: 'gk 7/27/2004 13:26'!
removeMaintainer: anAccount
	"Remove anAccount as a maintainer."

	maintainers ifNil: [^self].
	maintainers remove: anAccount.
	anAccount removeCoObject: self! !

!SMMaintainableObject methodsFor: 'maintainers' stamp: 'gk 7/27/2004 13:26'!
rss
	^rss! !

!SMMaintainableObject methodsFor: 'maintainers' stamp: 'gk 5/5/2006 02:07'!
rss: anUrl
	rss := anUrl! !


!SMMaintainableObject methodsFor: 'deletion' stamp: 'gk 7/27/2004 13:27'!
delete
	"Disconnect from maintainers."

	super delete.
	maintainers ifNotNil: [
		maintainers copy do: [:m | self removeMaintainer: m]]! !


!SMMaintainableObject methodsFor: 'testing' stamp: 'gk 7/27/2004 13:26'!
isOwnerOrMaintainer: anAccount
	^ owner = anAccount or: [self maintainers includes: anAccount]! !
SMSimpleInstaller subclass: #SMMcInstaller
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-installer'!
!SMMcInstaller commentStamp: 'gk 10/8/2003 14:28' prior: 0!
I am a SMInstaller that knows how to install .mcz (Monticello) files. If Monticello is installed I use that (MCMczReader), otherwise I file in the code more simply using the package MCInstaller (MczInstaller).!


!SMMcInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:55'!
install
	"This service should bring the package to the client,
	unpack it if necessary and install it into the image.
	The package is notified of the installation."

	self cache; fileIn.
	packageRelease noteInstalled! !


!SMMcInstaller methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
fileIn
	| extension |
	extension := (FileDirectory extensionFor: fileName) asLowercase.
	extension = 'mcz'
		ifTrue: [self installMcz]
		ifFalse: [self error: 'Cannot install file of type .', extension]! !

!SMMcInstaller methodsFor: 'private' stamp: 'ab 8/8/2003 18:33'!
fullFileName 
	^ dir fullNameFor: fileName! !

!SMMcInstaller methodsFor: 'private' stamp: 'gk 7/13/2004 02:44'!
installMcz
	"Install the package, we already know that either MCInstaller or Monticello is available."

	| installer monticello |
	installer := MczInstaller.
	(Smalltalk hasClassNamed: #MCMczReader) ifFalse: [
		packageRelease package isInstalled ifTrue: [
			(self silent ifFalse: [
				(self confirm:
'A release of package ''', packageRelease package name, ''' is already installed.
You only have MCInstaller and not Monticello
installed and MCInstaller can not properly upgrade packages.
Do you wish to install Monticello first and then proceed?
If you answer no MCInstaller will be used - but at your own risk.
Cancel cancels the installation.' orCancel: [self error: 'Installation cancelled.'])]
			ifTrue: [false])
				ifTrue: [
					monticello := packageRelease map packageWithName: 'Monticello'.
					monticello lastPublishedRelease
						ifNotNil: [monticello lastPublishedRelease install]
						ifNil: [monticello lastRelease install].
					installer := (Smalltalk at: #MCMczReader)]]
	] ifTrue: [installer := (Smalltalk at: #MCMczReader)].
	installer loadVersionFile: self fullFileName! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMMcInstaller class
	instanceVariableNames: ''!

!SMMcInstaller class methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:38'!
canInstall: aPackage
	"Is this a Monticello package and do I have MCInstaller
	or Monticello available?"

	| fileName |
	((Smalltalk includesKey: #MCMczReader) or: [
		 Smalltalk includesKey: #MczInstaller])
			ifTrue: [
				fileName := aPackage downloadFileName.
				fileName ifNil: [^false].
				^ 'mcz' = (FileDirectory extensionFor: fileName) asLowercase].
	^false! !
Object subclass: #SMObject
	instanceVariableNames: 'id map created updated name summary url'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMObject commentStamp: 'gk 9/23/2003 20:26' prior: 0!
SMObject is the abstract superclass for all objects living in an SMSqueakMap.

It has a unique UUID and a reference to the owning SMSqueakMap.
It has timestamps to record the birthtime and the last modification.
It has basic attributes like name, oneline summary and url.





!


!SMObject methodsFor: 'accessing' stamp: 'gh 3/16/2002 23:12'!
created
	^TimeStamp fromSeconds: created! !

!SMObject methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
created: c
	created := c! !

!SMObject methodsFor: 'accessing' stamp: 'gh 3/16/2002 23:12'!
createdAsSeconds
	^created! !

!SMObject methodsFor: 'accessing' stamp: 'gh 3/16/2002 23:12'!
id
	^id! !

!SMObject methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
id: anId
	id := anId! !

!SMObject methodsFor: 'accessing' stamp: 'gh 8/15/2002 08:50'!
map
	^map! !

!SMObject methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
map: aMap
	map := aMap! !

!SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:31'!
name
	^name! !

!SMObject methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
name: aName
	name := aName! !

!SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:33'!
summary
	^summary! !

!SMObject methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
summary: aString
	summary := aString! !

!SMObject methodsFor: 'accessing' stamp: 'gh 3/17/2002 01:44'!
updated
	^TimeStamp fromSeconds: updated! !

!SMObject methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
updated: c
	updated := c! !

!SMObject methodsFor: 'accessing' stamp: 'gh 3/17/2002 01:45'!
updatedAsSeconds
	^updated! !

!SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:36'!
url
	^url! !

!SMObject methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
url: aString
	url := aString! !

!SMObject methodsFor: 'accessing' stamp: 'gh 11/27/2002 12:21'!
userInterface
	"Return the object that we use for interacting with the user."

	^SMUtilities! !


!SMObject methodsFor: 'deletion' stamp: 'gk 8/8/2003 10:10'!
delete
	"Delete from map."

	map deleteObject: self! !


!SMObject methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:38'!
initialize
	"Initialize the receiver."

	updated := created := TimeStamp current asSeconds.
	name := summary := url := ''.! !

!SMObject methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:38'!
map: aMap id: anId
	"Initialize the receiver."

	self initialize.
	map := aMap.
	id := anId! !




!SMObject methodsFor: 'printing' stamp: 'gk 11/14/2003 14:22'!
describe: string withBoldLabel: label on: stream
	"Helper method for doing styled text."

	stream withAttribute: (TextEmphasis bold) do: [ stream nextPutAll: label ].
	stream nextPutAll: string; cr! !

!SMObject methodsFor: 'printing' stamp: 'gk 7/10/2004 03:39'!
printName
	"Return a String identifying receiver without a context.
	Default is name."

	^self name! !

!SMObject methodsFor: 'printing' stamp: 'gk 8/4/2003 11:56'!
printOn: aStream

	aStream nextPutAll: self class name, '[', name, ']'! !

!SMObject methodsFor: 'printing' stamp: 'gk 11/14/2003 00:11'!
type

	^'Object'! !


!SMObject methodsFor: 'testing' stamp: 'gk 6/26/2003 16:47'!
isAccount
	^false! !

!SMObject methodsFor: 'testing' stamp: 'gh 12/1/2002 19:51'!
isCategory
	^false! !

!SMObject methodsFor: 'testing' stamp: 'gh 12/1/2002 19:40'!
isPackage
	^false! !

!SMObject methodsFor: 'testing' stamp: 'gh 12/1/2002 19:51'!
isPackageRelease
	^false! !

!SMObject methodsFor: 'testing' stamp: 'gh 12/1/2002 19:51'!
isResource
	^false! !



!SMObject methodsFor: 'updating' stamp: 'stephaneducasse 2/4/2006 20:38'!
stampAsUpdated
	"This method should be called whenever the object is modified."

	updated := TimeStamp current asSeconds! !



!SMObject methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
withId: aUUIDString in: aCollection
	"Return the object with the corresponding id
	and nil if not found."

	| uuid |
	uuid := UUID fromString: aUUIDString.
	^aCollection detect: [:o | o id = uuid ] ifNone: [nil]! !


!SMObject methodsFor: 'comparing' stamp: 'gk 9/22/2004 23:21'!
<= anSMObject

	^name <= anSMObject name! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMObject class
	instanceVariableNames: ''!

!SMObject class methodsFor: 'instance creation' stamp: 'gk 12/7/2005 13:53'!
newIn: aMap
	"Create a new object in a given map with an UUID to ensure unique identity."

	^(super basicNew) map: aMap id: UUID new! !
SMDocument subclass: #SMPackage
	instanceVariableNames: 'releases packageInfoName repository'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMPackage commentStamp: '<historical>' prior: 0!
An SMPackage represents a named piece of an installable "thing" in the image. Typically it is a code package, but it can be other things too.
It owns a collection of SMPackageReleases. Each release represents a version of the package, and each release has a URL that refers to the actual content that can be installed.

An SMPackage also knows its packageInfoName which can tie it into the image.!


!SMPackage methodsFor: 'accessing' stamp: 'gk 7/12/2004 16:05'!
currentVersion
	^self isPublished ifTrue: [self lastPublishedRelease version]! !

!SMPackage methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
fullDescription
	"Return a full textual description of the package. 
	Most of the description is taken from the last release."
	| s publishedRelease |
	s := TextStream on: (Text new: 400).

	self
		describe: name
		withBoldLabel: 'Name:		'
		on: s.

	summary isEmptyOrNil
		ifFalse: [self
				describe: summary
				withBoldLabel: 'Summary:	'
				on: s ].

	author isEmptyOrNil
		ifFalse: [s
				withAttribute: TextEmphasis bold
				do: [s nextPutAll: 'Author:'];
				 tab;
				 tab.
			s
				withAttribute: (PluggableTextAttribute
						evalBlock: [self userInterface
										sendMailTo: (SMUtilities stripEmailFrom: author)
										regardingPackageRelease: self lastRelease])
				do: [s nextPutAll: author];
				 cr].
	self owner
		ifNotNil: [s
				withAttribute: TextEmphasis bold
				do: [s nextPutAll: 'Owner:'];
				 tab; tab.
			s
				withAttribute: (PluggableTextAttribute
						evalBlock: [self userInterface
										sendMailTo: self owner email
										regardingPackageRelease: self lastRelease])
				do: [s nextPutAll: self owner nameAndEmail];	
				 cr].

	self maintainers isEmpty ifFalse: [
		s withAttribute: TextEmphasis bold do: [s nextPutAll: 'Co-maintainers:']; tab.
		self maintainers do: [:com |
			com = self maintainers first ifFalse: [s nextPutAll: ', '].
			s
				withAttribute:
					(PluggableTextAttribute
						evalBlock: [self userInterface
									sendMailTo: com email
									regardingPackageRelease: self lastRelease])
				do: [s nextPutAll: com nameAndEmail]].
				s cr].

	description isEmptyOrNil
		ifFalse: [s cr.
			s
				withAttribute: TextEmphasis bold
				do: [s nextPutAll: 'Description:'].
			s cr.
			s
				withAttribute: (TextIndent tabs: 1)
				do: [s next: (description findLast: [ :c | c isSeparator not ]) putAll: description].
			s cr ].

	self describeCategoriesOn: s indent: 1.

	s cr.
	publishedRelease := self lastPublishedRelease.
	self
		describe: (self publishedVersion ifNil: ['<not published>'])
		withBoldLabel: 'Published version: '
		on: s.
	self isPublished ifTrue: [
		s
			withAttribute: TextEmphasis bold do: [ s nextPutAll: 'Created: ' ];
			print: publishedRelease created;
			cr.
			self note isEmptyOrNil
				ifFalse: [s
					withAttribute: TextEmphasis bold
					do: [s nextPutAll: 'Release note:'].
			s cr.
			s
				withAttribute: (TextIndent tabs: 1)
				do: [s nextPutAll: publishedRelease note].
			s cr ]].

	url isEmptyOrNil
		ifFalse: [s cr;
				withAttribute: TextEmphasis bold
				do: [s nextPutAll: 'Homepage:'];
				 tab;
				withAttribute: (TextURL new url: url)
				do: [s nextPutAll: url];
				 cr].

	^ s contents! !

!SMPackage methodsFor: 'accessing' stamp: 'gk 1/25/2004 16:23'!
maintainer
	"Deprecated"

	^self owner! !

!SMPackage methodsFor: 'accessing' stamp: 'gk 7/12/2004 17:15'!
note
	^self isPublished ifTrue: [self lastPublishedRelease note]! !

!SMPackage methodsFor: 'accessing' stamp: 'gk 11/6/2003 15:24'!
packageInfoName
	^packageInfoName! !

!SMPackage methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
packageInfoName: aString
	packageInfoName := aString! !

!SMPackage methodsFor: 'accessing' stamp: 'gk 7/12/2004 17:13'!
publishedVersion
	^self isPublished ifTrue: [self lastPublishedRelease version]! !

!SMPackage methodsFor: 'accessing' stamp: 'gh 12/1/2002 21:21'!
releases
	^releases! !

!SMPackage methodsFor: 'accessing' stamp: 'gk 10/12/2005 23:28'!
repository
	^repository! !

!SMPackage methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
repository: aString
	repository := aString! !


!SMPackage methodsFor: 'cache' stamp: 'gk 8/12/2003 17:20'!
cacheDirectory
	^ self lastRelease cacheDirectory! !

!SMPackage methodsFor: 'cache' stamp: 'gk 3/8/2004 19:56'!
download
	"Force download into cache."

	self isReleased ifFalse: [self error: 'There is no release for this package to download.'].
	^self lastRelease download! !

!SMPackage methodsFor: 'cache' stamp: 'gk 7/16/2004 11:01'!
ensureInCache
	"Makes sure all release files are in the cache."

	self releases do: [:rel | rel ensureInCache ]! !


!SMPackage methodsFor: 'deprecated' stamp: 'btr 11/20/2003 00:38'!
modulePath: p moduleVersion: v moduleTag: t versionComment: vc
	"Deprecated. Only kept for migration from SM 1.0x.
	Method used when recreating from storeOn: format."

	self isReleased ifTrue: [self lastRelease note: vc]! !


!SMPackage methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
initialize
	"Initialize package."

	super initialize.
	packageInfoName := ''.
	releases := OrderedCollection new! !


!SMPackage methodsFor: 'installation' stamp: 'gk 7/14/2004 17:32'!
install
	"Install the latest newer published version for this version of Squeak."

	^map installPackage: self! !

!SMPackage methodsFor: 'installation' stamp: 'gk 11/17/2003 02:27'!
installedRelease
	"Return the installed release.
	We ask the map. Return nil if this package is not installed."

	^map installedReleaseOf: self! !

!SMPackage methodsFor: 'installation' stamp: 'gk 11/18/2003 02:14'!
nameWithVersionLabel
	^name, ' (', self versionLabel, ')'! !

!SMPackage methodsFor: 'installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
upgrade
	"Upgrade to the latest newer published version for this version of Squeak."

	| installed |
	installed := self installedRelease.
	installed
		ifNil: [self error: 'No release installed, can not upgrade.']
		ifNotNil: [^installed upgrade]! !

!SMPackage methodsFor: 'installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
upgradeOrInstall
	"Upgrade to or install the latest newer published version for this version of Squeak."

	| installed |
	installed := self installedRelease.
	installed
		ifNil: [^self install]
		ifNotNil: [^installed upgrade]! !

!SMPackage methodsFor: 'installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
versionLabel
	"Return a label indicating installed and available version as:
		'1.0'      = 1.0 is installed and no new published version for this version of Squeak is available
		'1.0->1.1' = 1.0 is installed and 1.1 is published for this version of Squeak
		'->1.1'    = No version is installed and 1.1 is published for this version of Squeak
		'->(1.1)	 = No version is installed and there is only a non published version available for this version of Squeak

	The version showed is the one that #smartVersion returns.
	If a version name is in parenthesis it is not published."

	| installedVersion r r2 |
	r := self installedRelease.
	r ifNotNil: [
		installedVersion := r smartVersion.
		r2 := self lastPublishedReleaseForCurrentSystemVersionNewerThan: r]
	ifNil: [
		installedVersion := ''.
		r2 := self lastPublishedReleaseForCurrentSystemVersion ].
	^r2 ifNil: [installedVersion ] ifNotNil: [installedVersion, '->', r2 smartVersion].! !


!SMPackage methodsFor: 'printing' stamp: 'gk 11/17/2003 10:14'!
installedVersion
	"Return the version String for the installed version.
	We ask the map. Return nil if this package is not installed."

	^self installedRelease ifNotNilDo: [:r | r smartVersion]! !

!SMPackage methodsFor: 'printing' stamp: 'gk 11/14/2003 00:12'!
type

	^'Package'! !


!SMPackage methodsFor: 'services' stamp: 'gk 9/26/2004 23:34'!
firstRelease
	"Return the first release."

	^releases isEmpty ifTrue: [nil] ifFalse: [releases first]! !

!SMPackage methodsFor: 'services' stamp: 'gk 2/16/2004 20:14'!
lastPublishedRelease
	"Return the latest published release."

	^releases isEmpty ifTrue: [nil] ifFalse: [
		releases reversed detect: [:r | r isPublished] ifNone:[nil]]! !

!SMPackage methodsFor: 'services' stamp: 'gk 7/13/2004 13:28'!
lastPublishedReleaseForCurrentSystemVersion
	"Return the latest published release marked
	as compatible with the current SystemVersion."

	^releases isEmpty ifTrue: [nil] ifFalse: [
		releases reversed detect: [:r |
			r isPublished and: [r isCompatibleWithCurrentSystemVersion]]
				ifNone:[nil]]! !

!SMPackage methodsFor: 'services' stamp: 'gk 7/14/2004 17:15'!
lastPublishedReleaseForCurrentSystemVersionNewerThan: aRelease
	"Return the latest published release marked
	as compatible with the current SystemVersion
	that is newer than the given release."

	^releases isEmpty ifTrue: [nil] ifFalse: [
		releases reversed detect: [:r |
			(r isPublished and: [r newerThan: aRelease])
				and: [r isCompatibleWithCurrentSystemVersion]]
				 	ifNone:[nil]]! !

!SMPackage methodsFor: 'services' stamp: 'gk 8/4/2003 11:49'!
lastRelease
	"Return the latest release."

	^releases isEmpty ifTrue: [nil] ifFalse: [releases last]! !

!SMPackage methodsFor: 'services' stamp: 'gk 5/5/2006 02:07'!
parentReleaseFor: aPackageRelease
	"If there is none (the given release is automaticVersion '1'), return nil."

	| previousVersion |
	previousVersion := aPackageRelease automaticVersion previous.
	^releases detect: [:r | r automaticVersion = previousVersion] ifNone: [nil]! !

!SMPackage methodsFor: 'services' stamp: 'gh 11/27/2002 12:33'!
previousReleaseFor: aPackageRelease
	"If there is none, return nil."
	
	^releases before: aPackageRelease ifAbsent: [nil]! !

!SMPackage methodsFor: 'services' stamp: 'gk 11/18/2003 17:39'!
releaseWithAutomaticVersion: aVersion
	"Look up a specific package release of mine. Return nil if missing.
	They are few so we just do a #select:."

	^releases detect: [:rel | rel automaticVersion = aVersion ] ifNone: [nil]! !

!SMPackage methodsFor: 'services' stamp: 'gk 11/18/2003 17:39'!
releaseWithAutomaticVersionString: aVersionString
	"Look up a specific package release of mine. Return nil if missing.
	They are few so we just do a #select:."

	^self releaseWithAutomaticVersion: aVersionString asVersion! !

!SMPackage methodsFor: 'services' stamp: 'stephaneducasse 2/4/2006 20:38'!
releaseWithId: anIdString 
	"Look up a specific package release of mine. Return nil if missing.
	They are few so we just do a #select:."

	| anId |
	anId := UUID fromString: anIdString.
	releases detect: [:rel | rel id = anId ].
	^nil! !

!SMPackage methodsFor: 'services' stamp: 'gk 11/18/2003 17:41'!
releaseWithVersion: aVersionString
	"Look up a specific package release of mine. Return nil if missing.
	They are few so we just do a #select:."

	^releases detect: [:rel | rel version = aVersionString ] ifNone: [nil]! !

!SMPackage methodsFor: 'services' stamp: 'gk 7/13/2004 14:37'!
smartVersion
	"Delegate to last published release for this SystemVersion."

	| r |
	r := self lastPublishedReleaseForCurrentSystemVersion.
	^r ifNotNil: [r smartVersion] ifNil: ['']! !


!SMPackage methodsFor: 'testing' stamp: 'gk 7/13/2004 15:11'!
isAvailable
	"Answer if I am old or not installed regardless of
	if there is installer support for me. It also does
	not care if the newer release is not published
	or no for this Squeak version."

	^self isOld or: [self isInstalled not]! !

!SMPackage methodsFor: 'testing' stamp: 'gk 7/13/2004 14:55'!
isCached
	"Is the last release corresponding to me in the local file cache?
	NOTE: This doesn't honour #published nor if the release is
	intended for the current Squeak version."

	^self isReleased and: [self lastRelease isCached]! !

!SMPackage methodsFor: 'testing' stamp: 'gk 7/15/2004 17:21'!
isInstallable
	"Answer if any of my releases can be installed."

	^ releases anySatisfy: [:rel | rel isInstallable]! !

!SMPackage methodsFor: 'testing' stamp: 'gh 10/25/2002 11:08'!
isInstallableAndNotInstalled
	"Answer if there is any installer that
	can install me and I am not yet installed."

	^self isInstallable and: [self isInstalled not]! !

!SMPackage methodsFor: 'testing' stamp: 'gk 11/17/2003 11:02'!
isInstalled
	"Answer if any version of me is installed."

	^(map installedReleaseOf: self) notNil! !

!SMPackage methodsFor: 'testing' stamp: 'gk 7/13/2004 15:10'!
isOld
	"Answer if I am installed and there also is a
	newer version available *regardless* if it is
	not published or not for this Squeak version.
	This is for people who want to experiment!!"

	| installed |
	installed := map installedReleaseOf: self.
	^installed
		ifNil: [false]
		ifNotNil: [
			self releases anySatisfy: [:r |
				r newerThan: installed ]]! !

!SMPackage methodsFor: 'testing' stamp: 'gh 12/1/2002 19:40'!
isPackage
	^true! !

!SMPackage methodsFor: 'testing' stamp: 'gk 9/23/2003 21:35'!
isPublished
	"Answer if I have public releases."

	^releases anySatisfy: [:rel | rel isPublished]! !

!SMPackage methodsFor: 'testing' stamp: 'btr 11/20/2003 00:05'!
isReleased
	^ releases isEmpty not! !

!SMPackage methodsFor: 'testing' stamp: 'gk 7/13/2004 15:37'!
isSafeToInstall
	"Answer if I am NOT installed and there also is a
	published version for this version of Squeak available."

	^self isInstalled not and: [
		self lastPublishedReleaseForCurrentSystemVersion notNil]! !

!SMPackage methodsFor: 'testing' stamp: 'gk 7/14/2004 16:15'!
isSafelyAvailable
	"Answer if I am old or not installed regardless of
	if there is installer support for me. The
	newer release should be published
	and meant for this Squeak version."

	^self isSafeToInstall or: [self isSafelyOld]! !

!SMPackage methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:38'!
isSafelyOld
	"Answer if I am installed and there also is a
	newer published version for this version of Squeak available."

	| installed |
	installed := self installedRelease.
	^installed ifNil: [false] ifNotNil: [
		^(self lastPublishedReleaseForCurrentSystemVersionNewerThan: installed) notNil]! !

!SMPackage methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:38'!
isSafelyOldAndUpgradeable
	"Answer if I am installed and there also is a
	newer published version for this version of Squeak available
	that can be upgraded to (installer support)."

	| installed newRelease |
	installed := self installedRelease.
	^installed ifNil: [false] ifNotNil: [
		newRelease := self lastPublishedReleaseForCurrentSystemVersionNewerThan: installed.
		^newRelease ifNil: [false] ifNotNil: [newRelease isUpgradeable]]! !



!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:10'!
getCoEditLink: aBuilder
	"Return a link for using on the web.
	Relative to the current view."

	^self getCoEditLink: aBuilder view: aBuilder view! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:09'!
getCoEditLink: aBuilder view: aView
	"Return a link for using on the web."

	^aBuilder getLink: 'copackage/', id asString, '/edit' text: 'edit' view: aView! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:11'!
getCoEditReleasesLink: aBuilder
	"Return a link for using on the web.
	Relative to the current view."

	^self getCoEditReleasesLink: aBuilder view: aBuilder view! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:11'!
getCoEditReleasesLink: aBuilder view: aView
	"Return a link for using on the web."

	^aBuilder getLink: 'copackage/', id asString, '/editreleases' text: 'edit releases' view: aView! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:06'!
getCoLink: aBuilder
	"Return a link for using on the web.
	Relative to the current view."

	^self getCoLink: aBuilder view: aBuilder view! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:06'!
getCoLink: aBuilder view: aView
	"Return a link for using on the web."

	^aBuilder getLink: 'copackage/', id asString text: name view: aView! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:13'!
getEditLink: aBuilder
	"Return a link for using on the web.
	Relative to the current view."

	^self getEditLink: aBuilder view: aBuilder view! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:13'!
getEditLink: aBuilder view: aView
	"Return a link for using on the web."

	^aBuilder getLink: 'package/', id asString, '/edit' text: 'edit' view: aView! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:13'!
getEditReleasesLink: aBuilder
	"Return a link for using on the web.
	Relative to the current view."

	^self getEditReleasesLink: aBuilder view: aBuilder view! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 13:13'!
getEditReleasesLink: aBuilder view: aView
	"Return a link for using on the web."

	^aBuilder getLink: 'package/', id asString, '/editreleases' text: 'edit releases' view: aView! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 12:24'!
getLink: aBuilder
	"Return a link for using on the web.
	Relative to the current view."

	^self getLink: aBuilder view: aBuilder view! !

!SMPackage methodsFor: 'view' stamp: 'gk 10/12/2005 12:19'!
getLink: aBuilder view: aView
	"Return a link for using on the web."

	^aBuilder getLink: 'package/', id asString text: name view: aView! !

!SMPackage methodsFor: 'view' stamp: 'gh 3/15/2003 18:05'!
viewFor: uiObject
	"This is a double dispatch mechanism for multiple views
	for multiple uis."

	^uiObject packageViewOn: self! !


!SMPackage methodsFor: 'private' stamp: 'gk 10/12/2005 15:44'!
addRelease: aRelease
	"Add the release. Make sure package is set."

	releases add: aRelease.
	aRelease package: self.
	^aRelease! !

!SMPackage methodsFor: 'private' stamp: 'gh 11/28/2002 21:25'!
delete
	"Delete me. Delete my releases."

	super delete.
	self deleteReleases! !

!SMPackage methodsFor: 'private' stamp: 'gk 10/20/2005 00:17'!
deleteReleases
	"Delete my releases."

	releases copy do: [:release | release delete]! !

!SMPackage methodsFor: 'private' stamp: 'gk 12/7/2005 14:15'!
newChildReleaseFrom: aRelease
	"Create a new release."

	^self addRelease: (map newObject: (SMPackageRelease newFromRelease: aRelease package: self))! !

!SMPackage methodsFor: 'private' stamp: 'gk 12/7/2005 14:07'!
newRelease
	"Create a new release. Just use the last
	chronological release as parent, if this is the first release
	that is nil."

	^self newChildReleaseFrom: self lastRelease! !

!SMPackage methodsFor: 'private' stamp: 'gh 11/28/2002 21:33'!
removeRelease: aRelease
	"Remove the release."

	releases remove: aRelease! !
SMInstallationTask subclass: #SMPackageInstallationTask
	instanceVariableNames: 'wantedPackages wantedReleases analysis'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMPackageInstallationTask commentStamp: '<historical>' prior: 0!
A package installation task is to install one or more given SMPackages (not specified releases) into the image.

First it tries to calculate the ideal releases of the given packages that it will try to install given the policy and preferences set by the user. Then it runs an analysis to find how to install those wanted releases. This typically results in zero, one or more possible scenarios.
!


!SMPackageInstallationTask methodsFor: 'queries' stamp: 'gk 9/22/2004 22:47'!
allInstallPaths
	"Return all different ways to install - the ones requested plus all dependencies.
	This includes ways where different releases of the same package are combined."

	^analysis allInstallPaths! !

!SMPackageInstallationTask methodsFor: 'queries' stamp: 'gk 10/1/2004 10:06'!
proposals
	"Return all different possible proposals to install
	sorted with the best proposal first."

	^analysis allNormalizedInstallPaths collect: [:path | SMInstallationProposal installList: path]! !


!SMPackageInstallationTask methodsFor: 'accessing' stamp: 'gk 9/20/2004 20:50'!
analysis
	"Return the analysis of the task."

	^analysis! !

!SMPackageInstallationTask methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
wantedPackages: packages

	wantedPackages := packages! !


!SMPackageInstallationTask methodsFor: 'calculation' stamp: 'gk 5/5/2006 02:07'!
calculate
	"First calculate the wanted releases. Then perform a dependency analysis.
	We return the most basic result of the analysis - does there exist at least one
	working installation scenario without tweaks?"

	self calculateWantedReleases.
	analysis := SMDependencyAnalysis task: self.
	analysis installPackageReleases: wantedReleases.
	^analysis success! !


!SMPackageInstallationTask methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
calculateWantedReleases
	"The user gave us wanted packages.
	We need to figure out which actual releases of those
	we should try to install."

	| rel |
	wantedReleases := Set new.
	wantedPackages do: [:p | rel := self idealReleaseFor: p.
		rel ifNotNil: [wantedReleases add: rel]]! !

!SMPackageInstallationTask methodsFor: 'private' stamp: 'gk 9/20/2004 20:51'!
idealReleaseFor: aPackage
	"Return the most suitable release to install for <aPackage>."

	^ aPackage lastPublishedReleaseForCurrentSystemVersion! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMPackageInstallationTask class
	instanceVariableNames: ''!

!SMPackageInstallationTask class methodsFor: 'instance creation' stamp: 'gk 7/29/2004 12:37'!
engine: engine wantedPackages: wantedPackages
	^self new engine: engine; wantedPackages: wantedPackages! !
SMCategorizableObject subclass: #SMPackageRelease
	instanceVariableNames: 'publisher automaticVersion version note downloadUrl package repository sha1sum'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMPackageRelease commentStamp: '<historical>' prior: 0!
A package release refers to a specific version of the package.
Releases are auto numbered (with a VersionNumber) and also has a designated version name which can be whatever the maintainer wants.
There is also a release note and the URL for download. The inherited url is for any homepage for the release.
The instvar publisher refers to the SMAccount that owned the package at the time of the release and the instvar package refers to the owning package.
The instvar repository holds a String that is used to connect to the live repository for the package release, for example a Monticello repository.!


!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 11:22'!
automaticVersion
	"Return the VersionNumber for me."

	^automaticVersion! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 8/12/2003 17:21'!
automaticVersionString
	"Return my VersionNumber as a String."

	^automaticVersion versionString! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 8/13/2003 15:25'!
cacheDirectory
	^ map cache directoryForPackageRelease: self! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 11/23/2005 01:13'!
calculateSha1sum
	"Return the checksum of the currently cached file contents."

	^SecureHashAlgorithm new hashMessage: self contents
	
	
		! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 11/22/2005 22:41'!
contents
	"Return the contents of the cached file.
	If it is not downloadable, or if the file
	is not cached, return nil."

	^map cache contents: self! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 11/23/2005 01:50'!
correctSha1sum: content
	"Return if the checksum of the content is correct.
	If we have none, then we consider that to be correct."
	
	^sha1sum isNil or: [sha1sum = (SecureHashAlgorithm new hashMessage: content)]
	
	
		! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 14:03'!
downloadFileName
	"Cut out the filename from the url."

	downloadUrl isEmpty ifTrue: [^nil].
	^downloadUrl asUrl path last! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 15:31'!
downloadUrl
	^downloadUrl! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 15:31'!
downloadUrl: anObject
	^downloadUrl := anObject! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 12:43'!
note
	^note! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 12:43'!
note: anObject
	^note := anObject! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 3/15/2003 20:55'!
package
	"Get the package that I belong to."

	^package! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 6/26/2003 14:59'!
publisher
	^publisher! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 6/26/2003 15:00'!
publisher: anObject
	publisher := anObject! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 7/15/2004 16:26'!
repository
	^repository! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
repository: aString
	repository := aString! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 11/22/2005 22:29'!
sha1sum
	^sha1sum! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
sha1sum: aString
	sha1sum := aString! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 15:30'!
version
	^version! !

!SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 15:30'!
version: anObject
	^version := anObject! !


!SMPackageRelease methodsFor: 'deletion' stamp: 'gh 11/28/2002 21:32'!
delete
	super delete.
	package removeRelease: self! !


!SMPackageRelease methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
initializeFromRelease: parentRelease package: aPackage
	"Initialize package release from a given parent.
	Branch if needed."

	self map: aPackage map id: UUID new.
	package := aPackage.
	automaticVersion :=
		parentRelease
			ifNil: [VersionNumber first]
			ifNotNil: [parentRelease nextOrBranch].
	version := note := downloadUrl := ''! !


!SMPackageRelease methodsFor: 'printing' stamp: 'yo 7/26/2004 22:06'!
fullDescription
	"Return a full textual description of the package release."

	| s |
	s := TextStream on: (Text new: 400).
	self describe: self package name withBoldLabel: 'Package name: ' on: s.

	self 
		describe: self version
		withBoldLabel: 'version: '
		on: s.

	categories isEmptyOrNil 
		ifFalse: 
			[s
				cr;
				withAttribute: TextEmphasis bold do: [s nextPutAll: 'Categories: '];
				cr.
			self categoriesDo: 
					[:c | 
					s
						tab;
						withAttribute: TextEmphasis italic
							do: 
								[c parentsDo: 
										[:p | 
										s
											nextPutAll: p name;
											nextPutAll: '/'].
								s nextPutAll: c name];
						nextPutAll: ' - ' , c summary;
						cr].
			s cr].

	self note isEmptyOrNil 
		ifFalse: 
			[s
				cr;
				withAttribute: TextEmphasis bold do: [s nextPutAll: 'Version Comment:'].
			s cr.
			s withAttribute: (TextIndent tabs: 1) do: [s nextPutAll: self note].
			s
				cr;
				cr].
	url isEmptyOrNil 
		ifFalse: 
			[s
				withAttribute: TextEmphasis bold do: [s nextPutAll: 'Homepage:'];
				tab;
				withAttribute: (TextURL new url: url) do: [s nextPutAll: url];
				cr].
	self downloadUrl isEmptyOrNil 
		ifFalse: 
			[s
				withAttribute: TextEmphasis bold do: [s nextPutAll: 'Download:'];
				tab;
				withAttribute: (TextURL new url: self downloadUrl)
					do: [s nextPutAll: self downloadUrl];
				cr].
	^s contents.

! !

!SMPackageRelease methodsFor: 'printing' stamp: 'gk 7/10/2004 03:35'!
listName
	"Return something suitable for showing in lists.
	We list the manual version after a dash if it is available.
	We don't list the release name."

	^version isEmpty
		ifFalse: [self automaticVersion versionString , '-', version]
		ifTrue: [self automaticVersion versionString] ! !

!SMPackageRelease methodsFor: 'printing' stamp: 'gk 7/10/2004 03:38'!
packageNameWithVersion
	"Return '<packageName> <autoVersion>-<version>' like:
		'SqueakMap 5-0.92'	"

	^package name, ' ', self listName! !

!SMPackageRelease methodsFor: 'printing' stamp: 'gk 7/10/2004 03:38'!
printName
	"Return a String identifying object without context."

	^self packageNameWithVersion! !

!SMPackageRelease methodsFor: 'printing' stamp: 'gk 12/9/2003 00:13'!
printOn: aStream

	aStream nextPutAll: self class name, '[', self packageNameWithVersion, ']'! !

!SMPackageRelease methodsFor: 'printing' stamp: 'gk 11/14/2003 00:11'!
type

	^'Package release'! !


!SMPackageRelease methodsFor: 'services' stamp: 'gk 8/13/2003 15:43'!
download
	"Force a download into the cache regardless if it is already there."

	^map cache download: self! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 7/13/2004 00:48'!
eitherVersion
	"Return either version:
		1. If the maintainer entered a version then we use that.
		2. Otherwise we use the automatic version with an 'r' prepended."

	^version notEmpty
			ifTrue:[version]
			ifFalse:['r', automaticVersion versionString]! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 7/10/2004 03:53'!
ensureInCache
	"Makes sure the file is in the cache.
	Return true on success, otherwise false."

	^map cache add: self! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 7/12/2004 16:04'!
fullVersion
	"Return version followed by the automatic version
	with r prepended in parenthesis."

	^version, ' (r', automaticVersion versionString, ')'! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 2/16/2004 20:04'!
install
	"Install this package release."

	^map installPackageRelease: self! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 5/5/2006 02:07'!
nextOrBranch
	"Return a new automaticVersion that is either
	the next following my version, or if that is taken
	a branch, or if that is taken too - a branch from it and so on.
	Yes, it sucks, but I don't have time hacking VersionNumber right now."

	| nextVersion nextBranch |
	nextVersion := automaticVersion next.
	(package releaseWithAutomaticVersion: nextVersion) ifNil: [^nextVersion].
	nextBranch := automaticVersion branchNext.
	[(package releaseWithAutomaticVersion: nextBranch) notNil]
		whileTrue: [nextBranch := nextBranch branchNext].
	^nextBranch 
! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 11/17/2003 01:25'!
noteInstalled
	"This package release was just successfully installed.
	We tell the map so that it can keep track of what
	package releases are installed."

	map noteInstalled: self! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 1/23/2004 10:01'!
noteUninstalled
	"This package release was just successfully uninstalled.
	We tell the map so that it can keep track of what
	package releases are installed."

	self error: 'Uninstall is not working yet!!'.
	map noteUninstalled: self! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 10/12/2005 13:25'!
parentRelease
	"Return my parent release based on the automatic
	version number."

	^package parentReleaseFor: self! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 10/12/2005 13:23'!
previousRelease
	"Return the release before me.
	Returns nil if there is none.
	This is chronological order and not how they relate."

	^package previousReleaseFor: self! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 10/12/2005 00:24'!
relativeUrl
	"Return the relative url for this release on an SM server."
	
	^'package/', package id asString, '/autoversion/', automaticVersion versionString! !

!SMPackageRelease methodsFor: 'services' stamp: 'gk 7/13/2004 00:49'!
smartVersion
	"This method is used to ensure that we always have a
	version name for the package release even if the maintainer didn't
	bother to enter one. Is is calculated like this:
		1. If the maintainer entered a version then we use that.
		2. Otherwise we use the automatic version with an 'r' prepended.
		3. If the release is not published we enclose it in parenthesis."

	^ self isPublished ifTrue: [self eitherVersion] ifFalse: ['(', self eitherVersion, ')']! !

!SMPackageRelease methodsFor: 'services' stamp: 'stephaneducasse 2/4/2006 20:38'!
upgrade
	"Upgrade this package release if there is a new release available."

	| newRelease |
	newRelease := package lastPublishedReleaseForCurrentSystemVersionNewerThan: self.
	newRelease ifNotNil: [(SMInstaller forPackageRelease: newRelease) upgrade]! !


!SMPackageRelease methodsFor: 'testing' stamp: 'gk 8/13/2003 15:32'!
isCached
	"Delegate to last release."

	^map cache includes: self! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gk 5/5/2006 01:54'!
isCompatibleWithCurrentSystemVersion
	"Return true if this release is listed as being compatible with the SystemVersion of the current image.  Only checks major/minor version number; does not differentiate between alpha/beta/gamma releases.  Checks version categories of both the SMPackageRelease and the parent SMPackage."

	| current |
	current := self majorMinorVersionFrom: SystemVersion current version.
	self categories, self package categories do: [:c |
		((c parent name = 'Squeak versions') and: [
			(self majorMinorVersionFrom: c name) = current])
				ifTrue: [^true]].
	^ false
		
"	^ (self categories, self package categories
		detect:
			[:cat | (cat parent name = 'Squeak versions')
					and: [(SystemVersion new version: cat name) majorMinorVersion = SystemVersion current majorMinorVersion]]
		ifNone: []) notNil
"! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gk 10/15/2003 12:37'!
isDownloadable
	"Answer if I can be downloaded.
	We simply verify that the download url
	ends with a filename."

	^self downloadFileName isEmptyOrNil not! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gk 11/16/2003 23:48'!
isInstallable
	"Answer if there is any installer for me.
	This depends typically on the filename of
	the download url, but can in the future
	depend on other things too.
	It does *not* say if the release is installed or not."

	^SMInstaller isInstallable: self! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gk 7/13/2004 13:59'!
isInstalled
	"Answer if this release is installed."

	^(map installedReleaseOf: package) == self! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gh 12/1/2002 19:52'!
isPackageRelease
	^true! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gk 9/23/2003 21:09'!
isPublished
	"It is published when the publisher is set."

	^publisher notNil! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gk 11/17/2003 12:01'!
isUpgradeable
	"Answer if there is any installer that can upgrade me.
	This depends typically on the filename of
	the download url, but can in the future
	depend on other things too.
	It does *not* say if the package is installed or not
	or if there is a newer version available or not."

	^SMInstaller isUpgradeable: self! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gk 7/13/2004 13:24'!
newerThan: aRelease
	"Answer if this release was made after <aRelease>."
	
	^aRelease automaticVersion < automaticVersion! !

!SMPackageRelease methodsFor: 'testing' stamp: 'gk 7/13/2004 13:24'!
olderThan: aRelease
	"Answer if this release was made before <aRelease>."
	
	^automaticVersion < aRelease automaticVersion! !


!SMPackageRelease methodsFor: 'view' stamp: 'gk 10/12/2005 12:25'!
getLink: aBuilder
	"Return a link for using on the web."

	^self getLink: aBuilder view: aBuilder view! !

!SMPackageRelease methodsFor: 'view' stamp: 'gk 10/12/2005 12:27'!
getLink: aBuilder view: aView
	"Return a link for using on the web."

	^aBuilder getLinkTop: self relativeUrl text: self packageNameWithVersion! !

!SMPackageRelease methodsFor: 'view' stamp: 'gk 10/12/2005 12:27'!
getShortLink: aBuilder

	^aBuilder getLinkTop: self relativeUrl text: self listName! !

!SMPackageRelease methodsFor: 'view' stamp: 'gh 3/15/2003 19:37'!
viewFor: uiObject
	"This is a double dispatch mechanism for multiple views
	for multiple uis."

	^uiObject packageReleaseViewOn: self! !


!SMPackageRelease methodsFor: 'private' stamp: 'gk 5/5/2006 01:54'!
majorMinorVersionFrom: aVersionName

	| start |
	start := aVersionName indexOf: $..
	start = 0 ifTrue: [^ aVersionName].
	aVersionName size = start ifTrue: [^ aVersionName].
	start + 1 to: aVersionName size do: [:i |
		(aVersionName at: i) isDigit ifFalse: [^aVersionName copyFrom: 1 to: i - 1]].
	^aVersionName! !

!SMPackageRelease methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
package: aPackage
	"Set when I am created."

	package := aPackage! !


!SMPackageRelease methodsFor: 'configurations' stamp: 'gk 7/27/2004 17:58'!
addConfiguration
	"Create and add a new SMPackageReleaseConfiguration and return it."

	^ self addResource: (SMPackageReleaseConfiguration newIn: map)! !

!SMPackageRelease methodsFor: 'configurations' stamp: 'gk 7/27/2004 14:29'!
configurations
	"Return all SMPackageReleaseConfigurations attached to this release."


	^ self embeddedResources select: [:er | er isConfiguration]! !

!SMPackageRelease methodsFor: 'configurations' stamp: 'gk 9/20/2004 21:17'!
hasFulfilledConfiguration
	"Is any of the configurations already fulfilled?
	A fulfilled configuration has all required releases
	already installed, this means the release can be
	trivially installed."
	
	^self workingConfigurations anySatisfy: [:c | c isFulfilled]! !

!SMPackageRelease methodsFor: 'configurations' stamp: 'gk 9/20/2004 21:16'!
hasNoConfigurations
	"Does this release lack configurations,
	both working or failed ones? This is interpreted
	as if the release has no dependencies."

	^self configurations isEmpty! !

!SMPackageRelease methodsFor: 'configurations' stamp: 'gk 7/27/2004 14:55'!
workingConfigurations
	"Return all working configurations."
	
	^ self configurations select: [:c | c isWorking ]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMPackageRelease class
	instanceVariableNames: ''!

!SMPackageRelease class methodsFor: 'instance creation' stamp: 'gk 12/7/2005 14:16'!
newFromRelease: aPackageRelease package: aPackage
	"Create a new release from a given release."

	^super new initializeFromRelease: aPackageRelease package: aPackage! !
SMEmbeddedResource subclass: #SMPackageReleaseConfiguration
	instanceVariableNames: 'requiredReleases status'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMPackageReleaseConfiguration commentStamp: '<historical>' prior: 0!
A package release configuration describes the result of testing the specific release with a set of other releases that it depends on.
The status instvar holds a symbol which reflects the result. Currently there are two valid values:
	#working
	#failing
	
The intention is that users and maintainers post these configurations to the map as "known working combinations of required releases".
Each SMPackageRelease can then have multiple of these configurations.!


!SMPackageReleaseConfiguration methodsFor: 'dependencies' stamp: 'gk 5/5/2006 02:07'!
addRequiredRelease: aRelease
	"Add <aRelease> as a required release. The release added
	can not indirectly refer back to this release."
	
	(self isCircular: aRelease) ifTrue: [self error: 'Circular dependencies not allowed.'].
	requiredReleases := requiredReleases copyWith: aRelease.
	^aRelease! !

!SMPackageReleaseConfiguration methodsFor: 'dependencies' stamp: 'gk 5/5/2006 02:07'!
removeRequiredRelease: aRelease
	"Remove <aRelease> as a required release."
	
	requiredReleases := requiredReleases copyWithout: aRelease.
	^ aRelease! !


!SMPackageReleaseConfiguration methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
initialize
	super initialize.
	requiredReleases := #().
	status := #working! !


!SMPackageReleaseConfiguration methodsFor: 'private' stamp: 'gk 9/25/2004 00:22'!
isCircular: aRelease
	"Answer if there is a reference that goes back
	to the release of this configuration."

	"This is the base case"
	aRelease == object ifTrue: [^ true].
	
	aRelease configurations do: [:conf |
		conf requiredReleases do: [:rel |
			(self isCircular: rel) ifTrue: [^ true]]].
	^false! !


!SMPackageReleaseConfiguration methodsFor: 'testing' stamp: 'gk 7/27/2004 14:29'!
isConfiguration
	^true! !

!SMPackageReleaseConfiguration methodsFor: 'testing' stamp: 'gk 7/27/2004 18:23'!
isFailing
	^status == #failing! !

!SMPackageReleaseConfiguration methodsFor: 'testing' stamp: 'gk 7/27/2004 14:56'!
isFulfilled
	"Are all my required releases already installed?"
	
	^requiredReleases allSatisfy: [:r | r isInstalled ]! !

!SMPackageReleaseConfiguration methodsFor: 'testing' stamp: 'gk 7/27/2004 18:23'!
isWorking
	^status == #working! !


!SMPackageReleaseConfiguration methodsFor: 'printing' stamp: 'gk 7/28/2004 11:43'!
printOn: aStream

	aStream nextPutAll: 'Cfg['.
	requiredReleases do: [:r |
		aStream nextPutAll: r printString; space].
	aStream nextPutAll: ']'! !


!SMPackageReleaseConfiguration methodsFor: 'accessing' stamp: 'gk 7/27/2004 14:22'!
requiredReleases
	^ requiredReleases! !

!SMPackageReleaseConfiguration methodsFor: 'accessing' stamp: 'gk 7/27/2004 14:22'!
status
	^ status! !
ListItemWrapper subclass: #SMPackageReleaseWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMLoader'!
!SMPackageReleaseWrapper commentStamp: 'gk 6/21/2005 10:54' prior: 0!
This is a wrapper for showing the SqueakMap package releases (SMPackageRelease) using the SimpleHierarchicalListMorph in the SMLoader, see SMPackageWrapper>>contents.!


!SMPackageReleaseWrapper methodsFor: 'as yet unclassified' stamp: 'gk 7/13/2004 13:57'!
asString
	"Show installed releases with a trailing asterisk."
	
	^ item isInstalled
		ifTrue: [item smartVersion, ' *']
		ifFalse: [item smartVersion]! !
SMPackageInstallationTask subclass: #SMPackageUpgradeTask
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMPackageUpgradeTask commentStamp: '<historical>' prior: 0!
A package upgrade task is to upgrade one or more given SMPackages (not specified releases) in the image to newer releases.

First it tries to calculate the newest available releases of the given packages that it will try to upgrade given the policy and preferences set by the user. Then it runs an analysis to find how to upgrade to those wanted releases. This typically results in zero, one or more possible scenarios.
!

ListItemWrapper subclass: #SMPackageWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMLoader'!
!SMPackageWrapper commentStamp: '<historical>' prior: 0!
This is a wrapper for showing the SqueakMap packages (SMPackage) using the SimpleHierarchicalListMorph in the SMLoader, see SMLoader>>packageWrapperList.!


!SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'dvf 9/21/2003 16:25'!
= anObject
	^self withoutListWrapper = anObject withoutListWrapper! !

!SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'gk 7/13/2004 00:34'!
asString
	^item nameWithVersionLabel! !

!SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'dvf 10/14/2003 18:58'!
contents
	^item releases reversed collect: [:e | SMPackageReleaseWrapper with: e]! !

!SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'dvf 9/21/2003 16:25'!
hash
	^self withoutListWrapper hash! !

!SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'dvf 9/21/2003 16:22'!
printOn: aStream
	aStream nextPutAll: 'wrapper for: ', item printString! !
SMRootedObject subclass: #SMPersonalObject
	instanceVariableNames: 'owner'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMPersonalObject commentStamp: 'gk 7/27/2004 13:28' prior: 0!
SMPersonalObject is the abstract base class for things that belong/are owned by a user account in SqueakMap. Most things are personal objects - but the SMCategories aren't for example.

A personal object has a reference to the SMAccount owning it.!


!SMPersonalObject methodsFor: 'accessing' stamp: 'gk 8/7/2003 20:56'!
owner
	^owner! !

!SMPersonalObject methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
owner: anAccount
	owner := anAccount! !


!SMPersonalObject methodsFor: 'deletion' stamp: 'gk 10/20/2005 00:12'!
delete
	"Disconnect from owner."

	super delete.
	owner removeObject: self! !

SMSimpleInstaller subclass: #SMProjectInstaller
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-installer'!
!SMProjectInstaller commentStamp: '<historical>' prior: 0!
I am a SMInstaller that knows how to install .pr (Project) files.!


!SMProjectInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:55'!
install
	"This service should bring the package to the client, 
	unpack it if necessary and install it into the image. 
	The package is notified of the installation."

	Project canWeLoadAProjectNow ifFalse: [self error: 'Can not load Project now, probably because not in Morphic.'].
	self cache.
	[[ ProjectLoading openFromDirectory: dir andFileName: fileName ]
		on: ProgressTargetRequestNotification do: [ :ex | ex resume ]]
			ensure: [packageRelease noteInstalled]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMProjectInstaller class
	instanceVariableNames: ''!

!SMProjectInstaller class methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:38'!
canInstall: aPackage
	"Answer if this class can install the package.
	We handle .pr files (upper and lowercase)"

	| fileName |
	fileName := aPackage downloadFileName.
	fileName ifNil: [^false].
	^'pr' = (FileDirectory extensionFor: fileName) asLowercase! !
SMPersonalObject subclass: #SMResource
	instanceVariableNames: 'object version'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMResource commentStamp: '<historical>' prior: 0!
A resource is a document that is NOT a package. Thus, it is used for all the things interesting to register on SM that aren't packages. The are three major differences with resources:

- A resource keeps no track of version history like packages do with package releases. It only has a field for the current version.
- A resource can be embedded inside the map instead of being a document reached by a URL.
- A resource can be associated with another SMObject, the instvar object.

However, resources respond to some of the same actions as PackageReleases.!


!SMResource methodsFor: 'accessing' stamp: 'gk 7/27/2004 13:12'!
object
	^object! !

!SMResource methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
object: anSMCategorizableObject
	object := anSMCategorizableObject! !

!SMResource methodsFor: 'accessing' stamp: 'gk 9/23/2003 21:55'!
version
	^ version! !

!SMResource methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
version: aVersion
	version := aVersion! !


!SMResource methodsFor: 'testing' stamp: 'gk 7/27/2004 14:30'!
isConfiguration
	^ false! !

!SMResource methodsFor: 'testing' stamp: 'gk 7/27/2004 14:31'!
isEmbedded
	^false! !

!SMResource methodsFor: 'testing' stamp: 'btr 5/28/2003 04:25'!
isResource
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMResource class
	instanceVariableNames: ''!

!SMResource class methodsFor: 'instance creation' stamp: 'btr 5/28/2003 04:31'!
forString: aString
	^ SMEmbeddedResource new content: aString! !

!SMResource class methodsFor: 'instance creation' stamp: 'btr 5/28/2003 04:30'!
forUrl: anUrl
	^ SMExternalResource new downloadUrl: anUrl; yourself! !
SMCategorizableObject subclass: #SMRootedObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMRootedObject commentStamp: '<historical>' prior: 0!
An SMRootedObject is an SMObject that can be "rooted" in a given homeMap. This concept is for the upcoming new architecture with a tree of SM servers. Not used yet.!

SMSimpleInstaller subclass: #SMSARInstaller
	instanceVariableNames: 'zip'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-installer'!
!SMSARInstaller commentStamp: '<historical>' prior: 0!
I am a SqueakMap installer that knows how to deal with Zip format change-set archives.
I recognize them by the file extension ".sar" (Squeak Archive).

These have a couple of members with special names:

install/preamble
install/postscript

These are loaded in order. Either or both can further load other members using fileInMemberNamed:.

Inside a postscript or preamble, the pseudo-variable "self" is set to an instance of SARInstaller; you can then get to its ZipArchive using the method "zip". Or you can call its methods for filing in change sets, extracting files, etc.

You can test this loading with:
(SMSARInstaller new) directory: FileDirectory default; fileName: 'test.sar'; fileIn.

See ChangeSet>>fileOutAsZipNamed: for one way to make these files. Here is another way of creating a multi change set archive installable by SqueakMap:

"The following doit will create a .sar file with HVs preamble and postscript as
separate entries and the included changesets included as normal.
Given a preamble as described below this will autoinstall in SqueakMap."
(ChangeSorter changeSetNamed: 'HV')
	fileOutAsZipNamed: 'httpview-021023.sar'
	including: {
		ChangeSorter changeSetNamed: 'HVFixes'.
		ChangeSorter changeSetNamed: 'kom412'}

Preamble in changeset HV that will install the changesets:

"Change Set:		HV
Date:			23 October 2002
Author:			Göran Hultgren

This is my latest developer code drop of HttpView packaged as a Squeak selfextracting archive (courtesy Ned Konz)."

"Standard SqueakMap installing code follows:"
(self isKindOf: SARInstaller) ifTrue:[
	self fileInMemberNamed: 'HVFixes'.
	self fileInMemberNamed: 'kom412'.
	self fileInMemberNamed: 'HV'
]

!


!SMSARInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:55'!
install
	"This service should bring the package to the client,
	unpack it if necessary and install it into the image.
	The package is notified of the installation."

	self cache; fileIn.
	packageRelease noteInstalled! !


!SMSARInstaller methodsFor: 'private' stamp: 'gh 10/31/2002 11:19'!
fileIn

	Smalltalk at: #SARInstaller ifPresentAndInMemory: [:installer |
		(installer directory: dir fileName: fileName) fileIn. ^self].
	self error: 'SAR support not installed in image, can not install.'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMSARInstaller class
	instanceVariableNames: ''!

!SMSARInstaller class methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:38'!
canInstall: aPackage
	"Answer if this class can install the package.
	We handle it if the filename has the extension
	.sar (upper and lowercase) and SARInstaller is
	present in the image to handle the install."

	| fileName |
	fileName := aPackage downloadFileName.
	fileName ifNil: [^false].
	Smalltalk at: #SARInstaller ifPresentAndInMemory: [ :installer |
			^'sar' = (FileDirectory extensionFor: fileName) asLowercase].
	^false! !
SMInstaller subclass: #SMSimpleInstaller
	instanceVariableNames: 'fileName dir unpackedFileName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMBase-installer'!
!SMSimpleInstaller commentStamp: '<historical>' prior: 0!
This is a base class that you can subclass if your package format can be downloaded using
a single file url and possibly also be decompressed using gzip.!


!SMSimpleInstaller methodsFor: 'accessing' stamp: 'gh 10/23/2002 10:54'!
directory
	^dir! !

!SMSimpleInstaller methodsFor: 'accessing' stamp: 'gh 10/21/2002 14:39'!
fileName
	^fileName! !

!SMSimpleInstaller methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
fileName: aFileName
	fileName := aFileName! !

!SMSimpleInstaller methodsFor: 'accessing' stamp: 'nk 2/22/2004 13:12'!
fullFileName 
	^ self directory fullNameFor: self fileName! !

!SMSimpleInstaller methodsFor: 'accessing' stamp: 'gh 10/21/2002 14:39'!
unpackedFileName
	^unpackedFileName! !


!SMSimpleInstaller methodsFor: 'services' stamp: 'stephaneducasse 2/4/2006 20:38'!
cache
	"Download object into cache if needed.
	Set the directory and fileName for subsequent unpacking and install."

	packageRelease ensureInCache ifTrue: [
		fileName := packageRelease downloadFileName.
		dir := packageRelease cacheDirectory]! !

!SMSimpleInstaller methodsFor: 'services' stamp: 'stephaneducasse 2/4/2006 20:38'!
download
	"This service downloads the last release of the package
	even if it is in the cache already."

	packageRelease download ifTrue: [
		fileName := packageRelease downloadFileName.
		dir := packageRelease cacheDirectory]! !

!SMSimpleInstaller methodsFor: 'services' stamp: 'rbb 3/1/2005 11:12'!
fileIntoChangeSetNamed: aString fromStream: stream
	"We let the user confirm filing into an existing ChangeSet
	or specify another ChangeSet name if
	the name derived from the filename already exists."
	
	| changeSet newName oldChanges global |
	newName := aString.
	changeSet := SMInstaller changeSetNamed: newName.
	changeSet ifNotNil: [
		newName := self silent ifNil: [UIManager default
									request: 'ChangeSet already present, just confirm to overwrite or enter a new name:' 
									initialAnswer: newName]
						ifNotNil: [newName].
		newName isEmpty ifTrue:[self error: 'Cancelled by user'].
		changeSet := SMInstaller changeSetNamed: newName].
		changeSet ifNil:[changeSet := SMInstaller basicNewChangeSet: newName].
		changeSet ifNil:[self error: 'User did not specify a valid ChangeSet name'].
		oldChanges := (SystemVersion current highestUpdate < 5302)
						ifFalse: [global := ChangeSet. ChangeSet current]
						ifTrue: [global := Smalltalk. Smalltalk changes].
 		[global newChanges: changeSet.
		stream fileInAnnouncing: 'Loading ', newName, ' into change set ''', newName, ''''.
		stream close] ensure: [global newChanges: oldChanges]! !

!SMSimpleInstaller methodsFor: 'services' stamp: 'gk 4/18/2006 22:59'!
unpack
	"This basic installer simply checks the file extension of
	the downloaded file to choose suitable method for unpacking.
	Currently it only supports .gz decompression.
	If a file exists with the same name it is first deleted.
	The unpacked filename is set on succesfull decompression or
	if the file was not recognized as a compressed file."

	| unzipped zipped buffer |
	(fileName endsWith: '.gz')
		ifTrue:[
			unpackedFileName := fileName copyUpToLast: FileDirectory extensionDelimiter.
			(dir fileExists: unpackedFileName) ifTrue:[ dir deleteFileNamed: unpackedFileName ].
			unzipped := dir newFileNamed: unpackedFileName.
			unzipped binary.
			zipped := GZipReadStream on: ((dir readOnlyFileNamed: fileName) binary; yourself).
			buffer := ByteArray new: 50000.
			'Extracting ' , fileName
				displayProgressAt: Sensor cursorPoint
				from: 0
				to: zipped sourceStream size
				during: [:bar | 
					[zipped atEnd]
						whileFalse: 
							[bar value: zipped sourceStream position.
							unzipped nextPutAll: (zipped nextInto: buffer)].
					zipped close.
					unzipped close]]
		ifFalse:[unpackedFileName := fileName]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMSimpleInstaller class
	instanceVariableNames: ''!

!SMSimpleInstaller class methodsFor: 'testing' stamp: 'gh 10/22/2002 11:55'!
canInstall: aPackage
	"Answer if this class can install the package.
	This class is abstract so we return false."

	^false! !
Object subclass: #SMSqueakMap
	instanceVariableNames: 'packages accounts objects categories dir adminPassword fileCache users mutex isDirty checkpointNumber silent registry'
	classVariableNames: 'DefaultMap ServerList'
	poolDictionaries: ''
	category: 'SMBase-domain'!
!SMSqueakMap commentStamp: '<historical>' prior: 0!
SqueakMap is a Squeak meta catalog, primarily a catalog of all available Squeak packages.
SMSqueakMap is the class for the domain model.

One master instance lives on a server on the Internet at map1.squeakfoundation.org (but there are fallback servers too). Then each Squeak connected to the Internet has one instance that is synchronized against the master. This way every user can have an updated catalog of all available Squeak software on the planet locally on their machine. :-)

Typically you only need one instance of SMSqueakMap per image and it is held by a singleton class variable reached with "SMSqueakMap default". If it is not there it will then be created together with it's own directory on disk by default the "sm" directory created in your default directory.

Synching with the master is the only action that affects the map so you can actually use the same map from multiple images (they will by default use the same snapshot files if the images have the same default directory) and multiple tools (SMLoader, SMBrowser or others).

An instance of SMSqueakMap contains instances of SMPackage which which represent Squeak packages and SMCategories which are centrally registered values that can be included as attributes in an SMPackage. An example of such a category would be different kinds of licenses, topic etc. etc.

It also contains instances of SMAccount which are registered Squeak developers, the maintainers of the packages.

Finally SMSqueakMap also refers to a registry object (SMInstallationRegistry) which records what packages and releases of them have been installed in the image
--------------------
"Simplest use of SMSqueakMap - this will create a map if you don't have one and open a simple UI""
SMLoader open

Use these doits to play "hands on" with a SqueakMap.

"Creating another SqueakMap in directory 'slavemap' instead of default 'sm'"
Smalltalk at: #AnotherSqueakMap put: (SMSqueakMap newIn: 'slavemap')

"Update the default map by synching it with the master - check Transcript for some numbers."
SMSqueakMap default loadUpdates

"If the map is broken in some way, reload it from disk"
SMSqueakMap default reload

"Clear out the contents of the map to save image space, this does not remove the registry."
SMSqueakMap default purge
!


!SMSqueakMap methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
accounts
	"Lazily maintain a cache of all known account objects."

	accounts ifNotNil: [^accounts].
	accounts := objects select: [:o | o isAccount].
	^accounts! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
adminPassword: aString
	"We store the password as a SHA hash so that we can let the slave maps
	have it too."

	adminPassword := SecureHashAlgorithm new hashMessage: aString! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'btr 5/28/2003 02:16'!
cache
	^ fileCache! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
categories
	"Lazily maintain a cache of all known category objects."

	categories ifNotNil: [^categories].
	categories := objects select: [:o | o isCategory].
	^categories! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'gk 10/21/2003 23:02'!
checkpointNumber

	^checkpointNumber! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'gk 5/22/2004 21:56'!
directory
	"Return the subdirectory that SqueakMap uses."
	
	(FileDirectory default directoryExists: dir)
		ifFalse:[FileDirectory default createDirectory: dir].
	^FileDirectory default directoryNamed: dir! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'gh 11/28/2002 22:00'!
objects
	^objects! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
packageCacheDirectory
	"Return a FileDirectory for the package cache of the map.
	Creates it if it is missing."

	| dirName baseDir |
	dirName := self packageCacheDirectoryName.
	baseDir := self directory.
	(baseDir fileOrDirectoryExists: dirName)
		ifFalse:[baseDir createDirectory: dirName].
	^baseDir directoryNamed: dirName! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'gk 10/19/2005 23:53'!
packageReleases
	"Return subset of objects."

	objects ifNil: [^#()].
	^objects select: [:o | o isPackageRelease]! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
packages
	"Lazily maintain a cache of all known package objects."

	packages ifNotNil: [^packages].
	objects ifNil: [^#()].
	packages := objects select: [:o | o isPackage].
	^packages! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'gk 5/5/2006 02:07'!
registry
	^registry ifNil: [registry := SMInstallationRegistry map: self]! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'gk 7/13/2004 02:51'!
silent
	"Can installations ask questions or should they be silent
	and us good defaults?"

	^ silent ifNil: [false] ifNotNil: [true]! !

!SMSqueakMap methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:38'!
users
	"Lazily maintain a cache of all known account objects
	keyed by their developer initials."

	users ifNotNil: [^users].
	users := Dictionary new.
	self accounts do: [:a | users at: a initials put: a].
	^users! !


!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 3/31/2006 20:58'!
compressFile: aFileStream
	"Shamelessly copied and modified from StandardFileStream>>compressFile."
	
	| zipped buffer |
	aFileStream binary.
	zipped := StandardFileStream newFileNamed: (self directory fullNameFor: (aFileStream name, 'gz')).
	zipped binary; setFileTypeToObject.
	"Type and Creator not to be text, so can be enclosed in an email"
	zipped := GZipWriteStream on: zipped.
	buffer := ByteArray new: 50000.
	[[aFileStream atEnd] whileFalse: [
		zipped nextPutAll: (aFileStream nextInto: buffer)]]
		ensure: [zipped close. aFileStream close].
	self directory deleteFileNamed: aFileStream name! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 10/10/2003 14:47'!
createCheckpoint
	"Export a new checkpoint of me using an ImageSegment."

	^self createCheckpointNumber: 
		(self nextFileNameForCheckPoint findTokens: '.') second asNumber.
! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'stephaneducasse 2/4/2006 20:38'!
createCheckpointNumber: number
	"Export me using an ImageSegment.
	This is used for checkpointing the map on disk
	in a form that can be brought into an independent image.
	We do not overwrite older versions, since using ImageSegments
	is an intermediate hack anyway we don't care about the disk waste!!
	Sidenote: Some refactoring was needed to produce a .gz file directly so
	I didn't bother."

	| is fname stream oldMutex |
	fname := self filename, '.', number asString, '.s'.
	(self directory fileExists: fname) ifTrue: [self error: 'Checkpoint already exists!!'].
	stream := StandardFileStream newFileNamed: (self directory fullNameFor: fname).
	checkpointNumber := number.
	oldMutex := mutex.
	mutex := nil. self clearCaches.
	[is := ImageSegment new.
	is copyFromRoots: (Array with: self) sizeHint: 1000000 areUnique: true.
	is writeForExportOn: stream.
	self compressFile: (StandardFileStream oldFileNamed: (self directory fullNameFor: fname)).
	isDirty := false]
		ensure: [mutex := oldMutex].
	^is! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 10/10/2003 12:07'!
extension
	^'sgz'! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 10/10/2003 12:07'!
filename
	^'map'! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 3/31/2006 09:30'!
getLastCheckpointWithFilename
	"Return a readstream on a fresh checkpoint gzipped imagesegment.
	First we check if we are dirty and must create a new checkpoint.
	The filename is tacked on at the end so that the checkpoint number
	can be used on the client side too."

	| directory fname |
	isDirty ifTrue: [self createCheckpoint].
	directory := self directory.
	fname := self lastCheckpointFilename.
	fname ifNil: [self error: 'No checkpoint available'].
	^((StandardFileStream oldFileNamed: (directory fullNameFor: fname))
		contentsOfEntireFile), ':', fname! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 10/10/2003 15:02'!
isCheckpointAvailable
	"Check that there is an 'sm' directory
	and that it contains at least one checkpoint."

	[^self lastCheckpointFilename notNil] on: Error do: [:ex | ^false]! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 10/10/2003 14:21'!
lastCheckpointFilename
	"Return the filename for the newest checkpoint."

	^self directory lastNameFor: self filename extension: self extension! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 10/10/2003 14:52'!
lastCheckpointNumberOnDisk
	"Return the last checkpoint number on disk."

	^(self nextFileNameForCheckPoint findTokens: '.') second asNumber - 1! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 10/10/2003 12:12'!
nextFileNameForCheckPoint
	"Return the next available filename for a checkpoint."

	^self directory nextNameFor: self filename extension: self extension! !

!SMSqueakMap methodsFor: 'checkpoints' stamp: 'gk 3/31/2006 09:34'!
saveCheckpoint: contentWithFilename
	"Save the map checkpoint to disk if it is not there already."

	| file directory sz fname content |
	directory := self directory.
	sz := contentWithFilename size.
	fname := contentWithFilename last: sz - (contentWithFilename lastIndexOf: $:).
	content := contentWithFilename first: sz - fname size - 1.
	(directory fileExists: fname) ifFalse: [
		[file := StandardFileStream newFileNamed: (directory fullNameFor: fname).
		file nextPutAll: content]
			ensure: [file close]]! !




!SMSqueakMap methodsFor: 'initialize-release' stamp: 'gk 5/5/2006 02:07'!
initializeOn: directoryName
	"Create the local directory for SqueakMap."

	dir := directoryName.
	(FileDirectory default directoryExists: dir)
		ifFalse:[FileDirectory default createDirectory: dir].
	fileCache := SMFileCache newFor: self.
	checkpointNumber := 1! !



!SMSqueakMap methodsFor: 'public' stamp: 'gh 10/21/2002 14:08'!
loadFull
	"Go through the list of known master servers, ping
	each one using simple http get on a known 'ping'-url
	until one responds and then load the full map from it."
 
	self loadUpdatesFull: true! !

!SMSqueakMap methodsFor: 'public' stamp: 'gk 11/17/2003 23:16'!
loadUpdates
	"Go through the list of known master servers, ping
	each one using simple http get on a known 'ping'-url
	until one responds and then load updates from it."

	"SM2 starts with using full always"

	self loadFull! !

!SMSqueakMap methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:38'!
purge
	"Clear out the map from memory. Use this to reclaim space,
	no information is lost because it does not remove information
	about what packages are installed, and the map itself is checkpointed
	to disk. Use #reload to get it back from the latest checkpoint on disk."

	objects := accounts := users := packages := categories := nil.
	checkpointNumber := 0.! !

!SMSqueakMap methodsFor: 'public' stamp: 'gk 3/31/2006 10:32'!
reload
	"Reload the map from the latest checkpoint on disk.
	The opposite of #purge."

	| fname stream map |
	fname := self lastCheckpointFilename.
	fname ifNil: [self error: 'No checkpoint available!!'].
	"Code below uses good ole StandardFileStream to avoid m17n issues (this is binary data) and
	also uses #unzipped since it works in older Squeaks"
	stream := (StandardFileStream oldFileNamed: (self directory fullNameFor: fname)) asUnZippedStream.
	"stream := (RWBinaryOrTextStream with: contents) reset."
	stream ifNil: [self error: 'Couldn''t open stream on checkpoint file!!'].
	[map := (stream fileInObjectAndCode) install arrayOfRoots first] ensure: [stream close].
	self copyFrom: map! !


!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:24'!
clearInstalledPackageWithId: aPackageId
	"Clear the fact that any release of this package is installed.
	Can be used even when the map isn't loaded."

	^self registry clearInstalledPackageWithId: aPackageId! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:24'!
clearInstalledPackages
	"Simply clear the dictionary with information on installed packages.
	Might be good if things get corrupted etc. Also see
	SMSqueakMap class>>recreateInstalledPackagesFromChangeLog"

	^self registry clearInstalledPackages! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
installPackage: aPackage
	"Install the package.

	Note: This method should not be used anymore, better
	to specify a specific release."

	| rel |
	rel := aPackage lastPublishedReleaseForCurrentSystemVersion
			ifNil: [self error: 'No published release for this system version found to install.'].
	^self installPackageRelease: rel! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
installPackage: aPackage autoVersion: version
	"Install the release <version> of <aPackage.
	<version> is the automatic version name."

	| r |
	r := aPackage releaseWithAutomaticVersionString: version.
	r ifNil: [self error: 'No package release found with automatic version ', version].
	^self installPackageRelease: r! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
installPackageNamed: aString
	"Install the last published release
	for this Squeak version of the package with a name
	beginning with aString (see method comment
	of #packageWithNameBeginning:).

	Note: This method should not be used anymore.
	Better to specify a specific release."

	| p |
	p := self packageWithNameBeginning: aString.
	p ifNil: [self error: 'No package found with name beginning with ', aString].
	^self installPackage: p! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
installPackageNamed: aString autoVersion: version
	"Install the release <version> of the package with a name
	beginning with aString (see method comment
	of #packageWithNameBeginning:). <version> is the
	automatic version name."

	| p r |
	p := self packageWithNameBeginning: aString.
	p ifNil: [self error: 'No package found with name beginning with ', aString].
	r := p releaseWithAutomaticVersionString: version.
	r ifNil: [self error: 'No package release found with automatic version ', version].
	^self installPackageRelease: r! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 15:57'!
installPackageRelease: aPackageRelease
	"Install the given package release, no checks made."

	(SMInstaller forPackageRelease: aPackageRelease) install! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
installPackageReleaseWithId: anUUIDString
	"Look up and install the given release."

	| r |
	r := self packageReleaseWithId: anUUIDString.
	r ifNil: [self error: 'No package release available with id: ''', anUUIDString, ''''].
	^self installPackageRelease: r! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
installPackageWithId: anUUIDString
	"Look up and install the latest release of the given package.	

	Note: This method should not be used anymore.
	Better to specify a specific release."

	| package |
	package := self packageWithId: anUUIDString.
	package ifNil: [self error: 'No package available with id: ''', anUUIDString, ''''].
	^self installPackage: package! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
installPackageWithId: anUUIDString autoVersion: version
	"Install the release <version> of the package with id <anUUIDString>.
	<version> is the automatic version name."

	| p |
	p := self packageWithId: anUUIDString.
	p ifNil: [self error: 'No package available with id: ''', anUUIDString, ''''].
	^self installPackage: p autoVersion: version! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 1/18/2004 15:29'!
installedPackageReleases
	"Answer all package releases that we know are installed.
	Lazily initialize. The Dictionary contains the installed packages
	using their UUIDs as keys and the version string as the value."

	^self installedPackages collect: [:p | self installedReleaseOf: p]! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:24'!
installedPackages
	"Answer all packages that we know are installed."

	^self registry installedPackages! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:24'!
installedPackagesDictionary
	"Access the dictionary directly. The UUID of the installed package is the key.
	The value is an OrderedCollection of Arrays.
	The arrays have the smartVersion of the package, the time of the
	installation in seconds and the sequence number (installCounter)."

	^self registry installedPackagesDictionary! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:24'!
installedPackagesDictionary: aDict
	"Set dictionary directly."

	^self registry installedPackagesDictionary: aDict! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:23'!
installedReleaseOf: aPackage
	"If the package is installed, return the release.
	Otherwise return nil. SM2 stores the version as
	an Association to be able to distinguish it."

	^self registry installedReleaseOf: aPackage! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:24'!
installedVersionOf: aPackage
	"If the package is installed, return the version as a String.
	If it is a package installed during SM1 it will return the manual version String,
	for SM2 it returns the automatic version as a String.
	If package is not installed - return nil. If you want it to work without the map loaded you
	should instead use #installedVersionOfPackageWithId:."

	^self registry installedVersionOf: aPackage! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:24'!
installedVersionOfPackageWithId: anId
	"If the package is installed, return the automatic version or version String.
	Otherwise return nil. This can be used without the map loaded."

	^self registry installedVersionOfPackageWithId: anId! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/18/2003 17:49'!
noteInstalled: aPackageRelease
	"The package release was just successfully installed using SM.
	This is the method being called by SM upon a successful installation.

	We record this in our Dictionary of installed package releases
	and log a 'do it' to mark this in the changelog.
	The map used is the default map."

	^self noteInstalledPackageWithId: aPackageRelease package id asString
		autoVersion: aPackageRelease automaticVersion
		name: aPackageRelease package name! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/18/2003 17:50'!
noteInstalledPackage: aPackage autoVersion: aVersion
	"Mark that the package release was just successfully installed.
	Can be used to inform SM of an installation not been done using SM."

	
^self noteInstalledPackageWithId: aPackage id asString
		autoVersion: aVersion
		name: aPackage name! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
noteInstalledPackageNamed: aString autoVersion: aVersion
	"Mark that the package release was just successfully installed.
	<aVersion> is the automatic version as a String.
	Can be used to inform SM of an installation not been done using SM."

	| p |
	p := self packageWithNameBeginning: aString.
	p ifNil: [self error: 'No package found with name beginning with ', aString].
	
^self noteInstalledPackage: p autoVersion: aVersion asVersion! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/18/2003 11:59'!
noteInstalledPackageWithId: aPackageId autoVersion: aVersion
	"The package release was just successfully installed.
	Can be used to inform SM of an installation not been
	done using SM, even when the map isn't loaded."

	
^self noteInstalledPackageWithId: aPackageId
		autoVersion: aVersion
		name: '<unknown name>'! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 8/3/2004 13:24'!
noteInstalledPackageWithId: aPackageId autoVersion: aVersion name: aName
	"The package release was just successfully installed.
	Can be used to inform SM of an installation not been
	done using SM, even when the map isn't loaded.

	We record the fact in our Dictionary of installed packages
	and log a 'do it' to mark this in the changelog.
	The doit helps keeping track of the packages when
	recovering changes etc - not a perfect solution but should help.
	The map used is the default map.
	The id of the package is the key and the value is an OrderedCollection
	of Arrays with the release auto version, the point in time and the current installCounter."

	^self registry noteInstalledPackageWithId: aPackageId autoVersion: aVersion name: aName! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
silentlyDo: aBlock
	"Execute <aBlock> with the Silent flag set.
	This is a crude way of avoiding user interaction
	during batch operations, like loading updates."

	[silent := true.
	aBlock value]
		ensure: [silent := nil]! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/17/2003 13:06'!
upgradeOldPackages
	"Upgrade all upgradeable old packages without confirmation on each."

	^self upgradeOldPackagesConfirmBlock: [:package | true ]! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
upgradeOldPackagesConfirmBlock: aBlock
	"First we find out which of the installed packages are upgradeable and old.
	Then we upgrade them if confirmation block yields true.
	The block will be called with each SMPackage to upgrade.
	We return a Dictionary with the packages we tried to upgrade as keys
	and the value being the result of the upgrade, true or false."

	| result |
	result := Dictionary new.
	self upgradeableAndOldPackages
		do: [:package |
			(aBlock value: package)
				ifTrue:[ result at: package put: package upgrade]].
	^result
! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 5/5/2006 02:07'!
upgradeOrInstallPackageWithId: anUUIDString asOf: aTimeStamp
	"Upgrade package (or install) to the latest published release as it was
	on <aTimeStamp> for this Squeak version. This ensures that the same
	release will be installed (for all Squeak versions) as when it was tested."

	| package |
	package := self packageWithId: anUUIDString.
	package ifNil: [self error: 'No package available with id: ''', anUUIDString, ''''].
	^package upgradeOrInstall! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 17:33'!
upgradeOrInstallPackage: aPackage
	"Upgrade package (or install) to the latest published release for this Squeak version."

	^aPackage upgradeOrInstall! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
upgradeOrInstallPackageWithId: anUUIDString
	"Upgrade package (or install) to the latest published release for this Squeak version."

	| package |
	package := self packageWithId: anUUIDString.
	package ifNil: [self error: 'No package available with id: ''', anUUIDString, ''''].
	^package upgradeOrInstall! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 17:16'!
upgradePackage: aPackage
	"Upgrade package to the latest published release for this Squeak version."

	^aPackage upgrade! !

!SMSqueakMap methodsFor: 'public-installation' stamp: 'stephaneducasse 2/4/2006 20:38'!
upgradePackageWithId: anUUIDString
	"Upgrade package to the latest published release for this Squeak version.
	Will raise error if there is no release installed, otherwise use
	#upgradeOrInstallPackageWithId: "

	| package |
	package := self packageWithId: anUUIDString.
	package ifNil: [self error: 'No package available with id: ''', anUUIDString, ''''].
	^package upgrade! !


!SMSqueakMap methodsFor: 'public-master' stamp: 'gk 11/17/2003 10:30'!
addCategory: category inObject: object
	"Add a category in an object."

	^object addCategory: category
! !

!SMSqueakMap methodsFor: 'public-master' stamp: 'gk 2/7/2004 14:56'!
addObject: anSMObject 
	"Add a new object, only if not already added."

	(self object: anSMObject id) ifNil: [
		self transaction: [self newObject: anSMObject]]! !

!SMSqueakMap methodsFor: 'public-master' stamp: 'gh 11/28/2002 20:44'!
changeCategoriesTo: newCategories inObject: object
	"Remove or add categories in an object such that
	it belongs to the categories in <newCategories>.
	Logs the changes."

	newCategories do: [:cat |
		(object hasCategory: cat)
			ifFalse:[self addCategory: cat inObject: object]].
	object categories do: [:cat |
		(newCategories includes: cat)
			ifFalse: [self removeCategory: cat inObject: object]]
! !

!SMSqueakMap methodsFor: 'public-master' stamp: 'gk 11/17/2003 14:56'!
moveCategory: category toAfter: categoryBefore inParent: parent
	"Move a category to be listed after <categoryBefore> in <parent>."

	parent move: category toAfter: categoryBefore.
	^category
	
! !

!SMSqueakMap methodsFor: 'public-master' stamp: 'gk 5/22/2004 22:22'!
moveCategory: category toParent: parentCategory
	"Move a category into another parent category."

	parentCategory
		ifNil: [category parent: nil]
		ifNotNil: [parentCategory addCategory: category].
	^category
	
! !

!SMSqueakMap methodsFor: 'public-master' stamp: 'stephaneducasse 2/4/2006 20:38'!
newAccount: name username: username email: email
	"Create an account. Checking for previous account should already have been done.
	To add the account to the map, use SMSqueakMap>>addObject:"

	| account |
	account := self newAccount
					name: name;
					initials: username;
					email: email.
	^account
	
! !

!SMSqueakMap methodsFor: 'public-master' stamp: 'gk 11/17/2003 10:30'!
removeCategory: category inObject: object
	"Remove a category from an object."

	^object removeCategory: category
! !

!SMSqueakMap methodsFor: 'public-master' stamp: 'gk 5/5/2006 02:07'!
repair
	"Integrity repairs. This should not be neeed, but
	for some reason the map can obviously get messed up,
	not sure how."

	"SMSqueakMap default repair"
	
	"all objects should point back to me and not at another map"
	objects do: [:o | o map: self].
	
	"all releases should point back at the package they are in"
	self packages do: [:p | p releases do: [:r | r package: p]].
	
	"all releases in this map should point at a package in this map"
	self packageReleases do: [:r | | p |
		p := self object: r package id.
		p ifNil: [self error: 'Unknown package'].
		r package: p]! !


!SMSqueakMap methodsFor: 'public-packages' stamp: 'gk 11/14/2003 12:06'!
allPackages
	"Answer all packages."

	^self packages! !

!SMSqueakMap methodsFor: 'public-packages' stamp: 'gh 12/1/2002 19:53'!
availablePackages
	"Answer all packages that are old or not installed."

	^self packages select: [:package | package isAvailable]! !

!SMSqueakMap methodsFor: 'public-packages' stamp: 'gh 12/1/2002 19:54'!
installableAndNotInstalledPackages
	"Answer all installable but not installed packages."

	^self packages select: [:package | package isInstallableAndNotInstalled]! !

!SMSqueakMap methodsFor: 'public-packages' stamp: 'gh 12/1/2002 19:54'!
installablePackages
	"Answer all packages that can be (auto)installed -
	we have installers that can install them."

	^self packages select: [:package | package isInstallable]! !

!SMSqueakMap methodsFor: 'public-packages' stamp: 'gh 12/1/2002 19:54'!
notInstalledPackages
	"Answer all packages that are not installed."

	^self packages reject: [:package | package isInstalled]! !

!SMSqueakMap methodsFor: 'public-packages' stamp: 'gk 7/13/2004 15:12'!
oldPackages
	"Answer all packages that are installed with a
	newer published version for this Squeak version available."

	^self installedPackages select: [:package | package isSafelyOld]! !

!SMSqueakMap methodsFor: 'public-packages' stamp: 'gh 10/25/2002 11:33'!
upgradeableAndOldOrInstallableAndNotInstalledPackages
	"This would give you all packages that are available now
	for automatic install or automatic upgrade."

	^self upgradeableAndOldPackages union: self installableAndNotInstalledPackages! !

!SMSqueakMap methodsFor: 'public-packages' stamp: 'gk 7/14/2004 16:17'!
upgradeableAndOldPackages
	"Answer all packages that are installed and which have a
	newer published release for this Squeak version that also
	can be to by an installer."

	^self installedPackages select: [:package | package isSafelyOldAndUpgradeable]! !


!SMSqueakMap methodsFor: 'queries' stamp: 'gk 8/4/2003 11:50'!
accountForEmail: email
	"Find account given email."

	^self accounts detect: [:a | a email = email] ifNone: [nil]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:38'!
accountForName: name
	"Find account given full name. Disregarding case
	and allows up to 2 different characters.
	Size must match though, someone else can be smarter -
	this is just for migrating accounts properly."

	| lowerName size aName |
	lowerName := name asLowercase.
	size := lowerName size.
	^self accounts
		detect: [:a |
			aName := a name asLowercase.
			(aName size = size) and: [| errors |
				errors := 0.
				aName with: lowerName do: [:c1 :c2 |
					c1 ~= c2 ifTrue: [errors := errors + 1]].
				errors < 3
			]]
		ifNone: [nil]
		! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gk 7/30/2003 14:11'!
accountForUsername: username
	"Find account given username. The username used
	is the developer initials of the account."

	^self users at: username ifAbsent: [nil]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:38'!
accountWithId: anIdString 
	"Look up an account. Return nil if missing.
	Raise error if it is not an account."

	| account |
	account := self objectWithId: anIdString.
	account ifNil: [^nil].
	account isAccount ifTrue:[^account].
	self error: 'UUID did not map to a account.'! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gk 2/7/2004 14:55'!
accountWithName: aName
	"Look up an account by name. Return nil if missing."

	^self accounts values detect: [:a | a name = aName ] ifNone: [nil]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gk 12/3/2004 12:03'!
accountsByInitials
	"Return the accounts sorted by the developer initials."

	^self accounts asSortedCollection: [:x :y | x initials caseInsensitiveLessOrEqual: y initials]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gk 12/3/2004 12:03'!
accountsByName
	"Return the accounts sorted by their name."

	^self accounts asSortedCollection: [:x :y | x name caseInsensitiveLessOrEqual: y name].! !

!SMSqueakMap methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:38'!
categoryWithId: anIdString 
	"Look up a category. Return nil if missing.
	Raise error if it is not a category."

	| cat |
	cat := self objectWithId: anIdString.
	cat ifNil: [^nil].
	cat isCategory ifTrue:[^cat].
	self error: 'UUID did not map to a category.'! !

!SMSqueakMap methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:38'!
categoryWithNameBeginning: aString
	"Look up a category beginning with <aString>. Return nil if missing.
	We return the shortest matching one. We also strip out spaces and
	ignore case in both <aString> and the names."

	| candidates shortest answer searchString |
	searchString := (aString asLowercase) copyWithout: Character space.
	candidates := self categories select: [:cat |
		((cat name asLowercase) copyWithout: Character space)
			beginsWith: searchString ].
	shortest := 1000.
	candidates do: [:ca |
		ca name size < shortest ifTrue:[answer := ca. shortest := ca name size]].
	^answer	! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gk 5/5/2006 02:07'!
check
	"Sanity checks."

	"SMSqueakMap default check"
	
	(((self packages inject: 0 into: [:sum :p | sum := sum + p releases size]) +
	self accounts size +
	self packages size +
	self categories size) = SMSqueakMap default objects size)
		ifFalse: [self error: 'Count inconsistency in map'].
	
	objects do: [:o |
		o map == self
			ifFalse: [self error: 'Object with wrong map']].
	self packages do: [:p |
		(p releases allSatisfy: [:r | r map == self])
			ifFalse: [self error: 'Package with release pointing to wrong map']].
		
	self packageReleases do: [:r |
		r package map == self ifFalse: [self error: 'Release pointing to package in wrong map']]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gk 11/18/2003 02:06'!
object: aUUID
	"Look up a categorizable object. Return nil if missing."

	^objects at: aUUID ifAbsent: [nil]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 19:25'!
objectWithId: anIdString
	"Look up a categorizable object. Return nil if missing."

	^objects at: (UUID fromString: anIdString) ifAbsent: [nil]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:38'!
packageReleaseWithId: anIdString 
	"Look up a package release. Return nil if missing.
	Raise error if it is not a package release."

	| r |
	r := self objectWithId: anIdString.
	r ifNil: [^nil].
	r isPackageRelease ifTrue:[^r].
	self error: 'UUID did not map to a package release.'! !

!SMSqueakMap methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:38'!
packageWithId: anIdString 
	"Look up a package. Return nil if missing.
	Raise error if it is not a package."

	| package |
	package := self objectWithId: anIdString.
	package ifNil: [^nil].
	package isPackage ifTrue:[^package].
	self error: 'UUID did not map to a package.'! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 19:54'!
packageWithName: aName
	"Look up a package by exact match on name. Return nil if missing."

	^self packages detect: [:package | package name = aName ] ifNone: [nil]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:38'!
packageWithNameBeginning: aString
	"Look up a package beginning with <aString>. Return nil if missing.
	We return the shortest matching one. We also strip out spaces and
	ignore case in both <aString> and the names."

	| candidates shortest answer searchString |
	searchString := (aString asLowercase) copyWithout: Character space.
	candidates := self packages select: [:package |
		((package name asLowercase) copyWithout: Character space)
			beginsWith: searchString ].
	shortest := 1000.
	candidates do: [:package |
		package name size < shortest ifTrue:[answer := package. shortest := package name size]].
	^answer	! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gk 11/11/2003 18:37'!
packageWithPI: aPIName
	"Look up a package by exact match on PackageInfo name. Return nil if missing."

	aPIName isEmptyOrNil ifTrue: [^nil].
	^self packages detect: [:package | package packageInfoName = aPIName ] ifNone: [nil]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gk 12/3/2004 12:01'!
packagesByName
	"Return the packages sorted by their name."

	^self packages asSortedCollection: [:x :y | x name caseInsensitiveLessOrEqual: y name]! !

!SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 20:12'!
topCategories
	^self categories select: [:cat | cat isTopCategory]! !


!SMSqueakMap methodsFor: 'transactions' stamp: 'gk 10/10/2003 11:30'!
addDirty: anSMObject
	"Add the SMObject to the dirty list making
	sure it gets committed when transaction ends."

"In first SM2 version we do nothing"

"	dirtyList add: anSMObject"! !

!SMSqueakMap methodsFor: 'transactions' stamp: 'gk 11/4/2003 00:19'!
isDirty
	"Is the map modified but not yet checkpointed to disk?"

	^isDirty! !

!SMSqueakMap methodsFor: 'transactions' stamp: 'stephaneducasse 2/4/2006 20:38'!
mutex
	"Lazily initialize the Semaphore."

	^mutex ifNil: [mutex := Semaphore forMutualExclusion]! !

!SMSqueakMap methodsFor: 'transactions' stamp: 'stephaneducasse 2/4/2006 20:38'!
setDirty
	"Set the map modified so that it will get written to disk."

	isDirty := true! !

!SMSqueakMap methodsFor: 'transactions' stamp: 'stephaneducasse 2/4/2006 20:38'!
transaction: aBlock
	"Execute aBlock and then make sure any modified SMObjects
	are committed to disk. We do this inside a mutex in order to
	serialize transactions. Transactions must be initiated from
	service methods in this class and not from inside the domain
	objects - otherwise they could get nested and a deadlock occurs."

"In first version of SM2 we simply set the isDirty flag,
when next client asks for updates, or 30 minutes has passed,
we checkpoint."

"	self mutex critical: ["
		aBlock value.
		isDirty := true
"	]"

"	self mutex critical: [
		dirtyList := OrderedCollection new.
		aBlock value.
		dirtyList do: [:obj | obj commit].
		dirtyList := nil
	]"! !


!SMSqueakMap methodsFor: 'views' stamp: 'gh 11/28/2002 22:06'!
viewFor: uiObject
	"This is a double dispatch mechanism for multiple views
	for multiple uis. Used primarily by the web frontend."

	^uiObject squeakMapViewOn: self! !


!SMSqueakMap methodsFor: 'private' stamp: 'gh 10/31/2002 11:59'!
checkVersion: string
	"Check the content for a SqueakMap version conflict notification.
	Return true if no conflict is reported, otherwise ask user if we
	should upgrade SqueakMap using the bootstrap method."

	(string beginsWith: 'Server version:')
		ifTrue:[(self confirm: ('The SqueakMap master server is running another version (', (string last: (string size - 15)), ') than the client (', SMSqueakMap version, ').
You need to upgrade the SqueakMap package, would you like to do that now?'))
			ifTrue: [self class bootStrap. ^false]
			ifFalse: [^false]
	].
	^true! !

!SMSqueakMap methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
clearCaches
	"Clear the caches."

	packages := accounts := users := categories := nil
! !

!SMSqueakMap methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
clearCachesFor: anObject 
	"Clear the valid caches."

	anObject isPackage ifTrue:[packages := nil].
	anObject isAccount ifTrue:[accounts := users := nil].
	anObject isCategory ifTrue:[categories := nil]
! !

!SMSqueakMap methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
clearUsernames
	"Clear the username cache."

	users := nil! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
copyFrom: aMap
	"Copy all relevant info from the other map."

	objects := aMap objects.
	objects do: [:o | o map: self].
	accounts := users := packages := categories := nil.
	checkpointNumber := aMap checkpointNumber! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 8/8/2003 19:10'!
deleteObject: anObject 
	"Delete an object, remove it from objects.
	This method is called from the #delete method of
	anObject so it will take care of the rest of the
	cleaning up. Clear the valid caches."

	objects removeKey: anObject id.
	self clearCachesFor: anObject
! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 8/4/2003 15:22'!
emailOccupied: aUsername
	"Return true if email already taken."

	^(self accountForEmail: aUsername) notNil! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 5/5/2006 02:07'!
loadFullFrom: aServerName
	"Contact the SqueakMap at the url <aSqueakMapUrl>
	and load a full map from scratch."

	| url  zipped |
	url := 'http://', aServerName, '/loadgz?mapversion=', SMSqueakMap version, '&checkpoint=', checkpointNumber asString.
	Transcript show: 'Fetch: ', (Time millisecondsToRun: [ zipped := (HTTPSocket httpGet: url) contents]) asString, ' ms';cr.
	Transcript show: 'Size: ', zipped size asString, ' bytes';cr.
	((self checkVersion: zipped) and: [zipped ~= 'UPTODATE'])
		ifTrue:[
			Transcript show: 'Save checkpoint to disk: ', (Time millisecondsToRun: [
			self saveCheckpoint: zipped]) asString, ' ms';cr.
			Transcript show: 'Full reload from checkpoint: ', (Time millisecondsToRun: [
			self reload]) asString, ' ms';cr.]! !

!SMSqueakMap methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
loadUpdatesFull: full
	"Find a server and load updates from it."
 
	| server |
	server := self class findServer.
	server ifNotNil: [
		self synchWithDisk.
		full ifTrue: [self loadFullFrom: server]
			ifFalse:[self error: 'Not supported yet!!'."self loadUpdatesFrom: server"]]! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 11/17/2003 22:57'!
mandatoryCategoriesFor: aClass
	"Return the categories that are mandatory for instances of <aClass>."

	^self categories select: [:c | c mandatoryFor: aClass]! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 8/3/2003 23:23'!
newAccount
	"Create a new account."

	^SMAccount newIn: self! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 9/26/2003 00:04'!
newObject: anSMObject 
	"Add an SMObject to me. Clear the valid caches."

	self addDirty: anSMObject.
	self clearCachesFor: anSMObject.
	^objects at: anSMObject id put: anSMObject! !

!SMSqueakMap methodsFor: 'private' stamp: 'btr 5/28/2003 00:56'!
packageCacheDirectoryName
	"What is the name of the cache directory?"

	^'cache'! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 9/30/2003 17:03'!
pingServer: aServerName

	^self class pingServer: aServerName! !

!SMSqueakMap methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:38'!
synchWithDisk
	"Synchronize myself with the checkpoints on disk.
	If there is a newer checkpoint than I know of, load it.
	If there is no checkpoint or if I have a higher checkpoint number,
	create a new checkpoint from me.

	The end result is that I am in synch with the disk and we are both as
	updated as possible."

	| checkpointNumberOnDisk |
	 "If there is no checkpoint, save one from me."
	(self isCheckpointAvailable) ifFalse: [^self createCheckpointNumber: checkpointNumber].
	"If the one on disk is newer, load it"
	checkpointNumberOnDisk := self lastCheckpointNumberOnDisk.
	(checkpointNumber < checkpointNumberOnDisk)
		ifTrue: [^self reload].
	"If I am newer, recreate me on disk"
	(checkpointNumberOnDisk < checkpointNumber)
		ifTrue: [^self createCheckpointNumber: checkpointNumber]! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 8/3/2003 23:13'!
usernameOccupied: aUsername
	"Return true if name already taken."

	^(self accountForUsername: aUsername) notNil! !

!SMSqueakMap methodsFor: 'private' stamp: 'gk 10/21/2003 23:05'!
verifyAdminPassword: aString
	"Answer true if it is the correct password."

	^adminPassword = (SecureHashAlgorithm new hashMessage: aString)! !


!SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 8/3/2004 13:24'!
markInstalled: uuid version: version time: time counter: num
	"Private. Mark the installation. SM2 uses an Association
	to distinguish the automatic version from old versions."

	^self registry markInstalled: uuid version: version time: time counter: num! !

!SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 8/3/2004 13:24'!
noteInstalledPackage: uuidString version: version
	"Mark a specific version of a package as installed.
	This method is called when replaying a logged installation
	from before SqueakMap 1.07. Such logged installations lacked
	a timestamp and a count. We take the current time and a
	count starting from -10000 and upwards. This should keep
	the sorting order correct."

	^self registry noteInstalledPackage: uuidString version: version! !

!SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 8/3/2004 13:24'!
noteInstalledPackage: uuidString version: version atSeconds: time number: num
	"Mark a package as installed in the Dictionary.
	This method is called when replaying a logged installation.
	<time> is the point in time as totalSeconds of the installation.
	<num> is the installCount of the installation.
	This method is typically called from a doIt in the changelog
	in order to try to keep track of packages installed."

	^self registry noteInstalledPackage: uuidString version: version atSeconds: time number: num! !

!SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 8/3/2004 13:24'!
noteInstalledPackageWithId: uuidString autoVersion: version atSeconds: time number: num
	"Mark a package as installed in the Dictionary.
	This method is called when replaying a logged installation.
	<time> is the point in time as totalSeconds of the installation.
	<num> is the installCount of the installation.
	This method is typically called from a doIt in the changelog
	in order to try to keep track of packages installed."

	^self registry noteInstalledPackageWithId: uuidString autoVersion: version atSeconds: time number: num! !

!SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 1/22/2004 12:01'!
noteUninstalled: aPackageRelease
	"The package release was just successfully uninstalled using SM.
	This is the method being called by SM upon a successful uninstallation.

	We record this in our Dictionary of installed package releases
	and log a 'do it' to mark this in the changelog.
	The map used is the default map."

	^self noteUninstalledPackageWithId: aPackageRelease package id asString
		autoVersion: aPackageRelease automaticVersion
		name: aPackageRelease package name! !

!SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 8/3/2004 13:25'!
noteUninstalledPackageWithId: aPackageId autoVersion: aVersion name: aName
	"The package release was just successfully uninstalled.
	Can be used to inform SM of an uninstallation not been
	done using SM, even when the map isn't loaded.

	We record the fact in our Dictionary of installed packages
	and log a 'do it' to mark this in the changelog.
	The doit helps keeping track of the packages when
	recovering changes etc - not a perfect solution but should help.
	The map used is the default map.
	The id of the package is the key and the value is an OrderedCollection
	of Arrays with the release auto version, the point in time and the current installCounter."

	^self registry noteUninstalledPackageWithId: aPackageId autoVersion: aVersion name: aName! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMSqueakMap class
	instanceVariableNames: ''!

!SMSqueakMap class methodsFor: 'bootstrap upgrade' stamp: 'gk 3/31/2006 01:05'!
bootStrap
	"Bootstrap upgrade. Only used when SqueakMap itself is too old to
	communicate with the server. This relies on the existence of a package
	called SqueakMap that is a .st loadscript. The loadscript needs to do its
	own changeset management."

	| server url |
	server := self findServer.
	server ifNotNil: ["Ok, found a SqueakMap server"
		url := (('http://', server, '/packagebyname/squeakmap/downloadurl')
				asUrl retrieveContents content) asUrl.
		(url retrieveContents content unzipped readStream)
				fileInAnnouncing: 'Upgrading SqueakMap...']! !


!SMSqueakMap class methodsFor: 'changelog replay' stamp: 'stephaneducasse 2/4/2006 20:38'!
askUser
	"Ask user about how to handle a replayed installation note
	when there is no current SqueakMap in the image."

	| choice |
	[choice := UIManager default chooseFrom: #('Yes' 'No' 'More info')
				title:
'There is no SqueakMap in this image,
do you wish to create/recreate it? (typical answer is Yes)' .
			choice = 3] whileTrue: [self inform:
'When packages are installed using SqueakMap a little mark is made
in the change log. When an image is reconstructed from the changelog
these marks are intended to keep your map informed about what packages
are installed. You probably already have a map on disk which will automatically be
reloaded if you choose ''Yes'', otherwise an new empty map will be created.
If you choose ''No'', it will only result in that SqueakMap will not know that this package
is installed in your image.
If you are still unsure - answer ''Yes'' since that is probably the best.'].
	^choice = 1! !

!SMSqueakMap class methodsFor: 'changelog replay' stamp: 'stephaneducasse 2/4/2006 20:38'!
noteInstalledPackage: uuidString version: version
	"We are replaying a change that indicates that a package
	was just installed. If there is a map we let it record this,
	otherwise we ask the user if we should create/recreate the map."

	| choice |
	DefaultMap
		ifNotNil: [DefaultMap noteInstalledPackage: uuidString version: version]
		ifNil: [
			[choice := UIManager default chooseFrom: #('Yes' 'No' 'More info')
				title:
'There is no SqueakMap in this image,
do you wish to create/recreate it? (typical answer is Yes)' .
			choice = 3] whileTrue: [self inform:
'When packages are installed using SqueakMap a little mark is made
in the change log. When an image is reconstructed from the changelog
these marks are intended to keep your map informed about what packages
are installed. You probably already have a map on disk which will automatically be
reloaded if you choose ''Yes'', otherwise an new empty map will be created.
If you choose ''No'', it will only result in that SqueakMap will not know that this package
is installed in your image.
If you are still unsure - answer ''Yes'' since that is probably the best.'].
			choice = 1
				ifTrue:[self default noteInstalledPackage: uuidString version: version]]! !

!SMSqueakMap class methodsFor: 'changelog replay' stamp: 'gk 7/29/2003 01:01'!
noteInstalledPackage: uuidString version: version atSeconds: sec number: num
	"We are replaying a change that indicates that a package
	was just installed. If there is a map we let it record this,
	otherwise we ask the user if we should create/recreate the map."

	DefaultMap
		ifNotNil: [DefaultMap noteInstalledPackage: uuidString version: version
					atSeconds: sec number: num]
		ifNil: [
			self askUser
				ifTrue:[self default noteInstalledPackage: uuidString version: version
							atSeconds: sec number: num]]! !

!SMSqueakMap class methodsFor: 'changelog replay' stamp: 'gk 11/17/2003 01:20'!
noteInstalledPackageWithId: uuidString autoVersion: version atSeconds: sec number: num
	"We are replaying a change that indicates that a package release
	was just installed using SM2. If there is a map we let it record this,
	otherwise we ask the user if we should create/recreate the map."

	DefaultMap
		ifNotNil: [DefaultMap noteInstalledPackageWithId: uuidString autoVersion: version
					atSeconds: sec number: num]
		ifNil: [
			self askUser
				ifTrue:[self default noteInstalledPackageWithId: uuidString autoVersion: version
							atSeconds: sec number: num]]! !

!SMSqueakMap class methodsFor: 'changelog replay' stamp: 'gk 11/17/2003 01:18'!
noteInstalledPackageWithId: uuidString version: version atSeconds: sec number: num
	"We are replaying a change that indicates that a package release
	was just installed using SM2. If there is a map we let it record this,
	otherwise we ask the user if we should create/recreate the map."

	DefaultMap
		ifNotNil: [DefaultMap noteInstalledPackageWithId: uuidString version: version
					atSeconds: sec number: num]
		ifNil: [
			self askUser
				ifTrue:[self default noteInstalledPackageWithId: uuidString version: version
							atSeconds: sec number: num]]! !


!SMSqueakMap class methodsFor: 'class initialization' stamp: 'gk 5/5/2006 02:07'!
initialize
	"Initialize the list of master servers.
	The last one is for debugging/development."

	"self initialize"

	ServerList := #('map.squeak.org' 'map1.squeakfoundation.org' 'map2.squeakfoundation.org' '127.0.0.1:8080')! !


!SMSqueakMap class methodsFor: 'constants' stamp: 'gk 4/4/2006 01:13'!
version
	"This is the protocol version number used for clients to decide if
	they need to update SMSqueakMap before synching with
	the master. In short - only increase this if changes have made
	the clients incompatible so that they need to be updated.

	2.0: Removed Module stuff and added Package releases.
	2.1: Various changes/additions and class shape changes.
	2.2: Various 3.9 related fixes and bug fix in segment compression etc."

	^'2.2'! !


!SMSqueakMap class methodsFor: 'discarding' stamp: 'gk 7/14/2003 15:04'!
discardSM
	"Discard SqueakMapBase. All the map state is kept in
	the class var DefaultMap in SMSqueakMap and is thus also removed."

	"SMSqueakMap discardSM"

	SystemOrganization removeCategoriesMatching: 'SM-domain'.! !


!SMSqueakMap class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:38'!
clear
	"Clear out the model in the image. This will forget
	about what packages are installed and what versions.
	The map is itself on disk though and will be reloaded.
	
	If you only want to reload the map and not forget about
	installed packages then use 'SMSqueakMap default reload'.

	If you want to throw out the map perhaps when shrinking
	an image, then use 'SMSqueakMap default purge'."

	"SMSqueakMap clear"

	DefaultMap := nil! !

!SMSqueakMap class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:38'!
default
	"Return the default map, create one if missing."

	"SMSqueakMap default"

	^DefaultMap ifNil: [DefaultMap := self new]! !

!SMSqueakMap class methodsFor: 'instance creation' stamp: 'gh 10/21/2002 15:05'!
defaultNoCreate
	"Return the default map or nil if there is none."

	"SMSqueakMap defaultNoCreate"

	^DefaultMap! !

!SMSqueakMap class methodsFor: 'instance creation' stamp: 'gh 10/22/2002 17:41'!
new
	"Create a new server in a new directory
	under the default directory called 'sm'."

	^super new initializeOn: 'sm'! !

!SMSqueakMap class methodsFor: 'instance creation' stamp: 'gh 8/15/2002 07:02'!
newIn: directoryName
	"Create a new server in a new directory
	under the default directory called <directoryName>."

	^super new initializeOn: directoryName! !


!SMSqueakMap class methodsFor: 'migration' stamp: 'stephaneducasse 2/4/2006 20:38'!
recreateInstalledPackagesFromChangeLog
	"Clear and recreate the Dictionary with information on installed packages.

	NOTE: This takes some time to run and will only find packages installed using SM
	and since the last changelog condense.

	For packages installed prior to SqueakMap 1.07 there is no timestamp nor counter
	logged. These packages will be given the time of the replay and a separate count
	(from -10000 upwards) maintaining correct order of installation."

	"SMSqueakMap recreateInstalledPackagesFromChangeLog"

	| changesFile chunk |
	SMSqueakMap default clearInstalledPackages.
	changesFile := (SourceFiles at: 2) readOnlyCopy.
	[changesFile atEnd]
		whileFalse: [
			chunk := changesFile nextChunk.
			((chunk beginsWith: '"Installed') and: [
				(chunk indexOfSubCollection: 'SMSqueakMap noteInstalledPackage:'
					startingAt: 10) > 0])
				ifTrue: [Compiler evaluate: chunk logged: false]].
	changesFile close! !


!SMSqueakMap class methodsFor: 'server detection' stamp: 'stephaneducasse 2/4/2006 20:38'!
findServer
	"Go through the list of known master servers, ping 
	each one using simple http get on a known 'ping'-url 
	until one responds return the server name. 
	If some servers are bypassed we write that to Transcript. 
	If all servers are down we inform the user and return nil."

	| notAnswering deafServers |
	Socket initializeNetwork.
	notAnswering := OrderedCollection new.
	Cursor wait
		showWhile: [ServerList
				do: [:server | (self pingServer: server)
						ifTrue: [notAnswering isEmpty
								ifFalse: [deafServers := String
												streamContents: [:str | notAnswering
														do: [:srvr | str nextPutAll: srvr printString;
																 nextPut: Character cr]].
									Transcript show: ('These SqueakMap master servers did not respond:\' , deafServers , 'Falling back on ' , server printString , '.') withCRs].
							^ server]
						ifFalse: [notAnswering add: server]]].
	deafServers := String
				streamContents: [:str | notAnswering
						do: [:srvr | str nextPutAll: srvr printString;
								 nextPut: Character cr]].
	self error: ('All SqueakMap master servers are down:\' , deafServers , '\ \Can not update SqueakMap...') withCRs.
	^ nil! !

!SMSqueakMap class methodsFor: 'server detection' stamp: 'gk 5/5/2006 02:07'!
pingServer: aServerName
	"Check if the SqueakMap server is responding.
	For an old image we first make sure the name resolves -
	the #httpGet: had such a long timeout (and hanging?)
	for resolving the name."

	| url answer |
	"Only test name lookup first if image is before the network rewrite,
	after the rewrite it works."
	[(SystemVersion current highestUpdate < 5252)
		ifTrue: [NetNameResolver addressForName: (aServerName upTo: $:) timeout: 5].
	url := 'http://', aServerName, '/ping'.
	answer := HTTPSocket httpGet: url]
				on: Error do: [:ex | ^false].
	^answer isString not and: [answer contents = 'pong']! !
TelnetProtocolClient subclass: #SMTPClient
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!SMTPClient commentStamp: 'mir 2/21/2002 16:57' prior: 0!
This class implements the SMTP (mail sending) protocol specified in RFC 821.

HELO <SP> <domain> <CRLF>

MAIL <SP> FROM:<reverse-path> <CRLF>

RCPT <SP> TO:<forward-path> <CRLF>

DATA <CRLF>

RSET <CRLF>

SEND <SP> FROM:<reverse-path> <CRLF>

SOML <SP> FROM:<reverse-path> <CRLF>

SAML <SP> FROM:<reverse-path> <CRLF>

VRFY <SP> <string> <CRLF>

EXPN <SP> <string> <CRLF>

HELP [<SP> <string>] <CRLF>

NOOP <CRLF>

QUIT <CRLF>

TURN <CRLF>

!


!SMTPClient methodsFor: 'public protocol' stamp: 'mir 2/21/2002 15:43'!
mailFrom: sender to: recipientList text: messageText
	"deliver this mail to a list of users.  NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff"

	self mailFrom: sender.
	recipientList do: [ :recipient |
		self recipient: recipient ].
	self data: messageText.
! !


!SMTPClient methodsFor: 'utility' stamp: 'dvf 11/18/2002 23:39'!
encodeString: aString 
	| str dec |
	str _ String new: (aString size * 4 / 3 + 3) ceiling.
	dec _ Base64MimeConverter new.
	dec
		mimeStream: (WriteStream on: str);
		dataStream: (ReadStream on: aString);
		mimeEncode.
	^ str! !


!SMTPClient methodsFor: 'private protocol' stamp: 'mir 2/22/2002 16:42'!
data: messageData
	"send the data of a message"
	"DATA <CRLF>"

	| cookedLine |

	"inform the server we are sending the message data"
	self sendCommand: 'DATA'.
	self checkResponse.

	"process the data one line at a time"
	messageData linesDo:  [ :messageLine |
		cookedLine _ messageLine.
		(cookedLine beginsWith: '.') ifTrue: [ 
			"lines beginning with a dot must have the dot doubled"
			cookedLine _ '.', cookedLine ].
		self sendCommand: cookedLine ].

	"inform the server the entire message text has arrived"
	self sendCommand: '.'.
	self checkResponse.! !

!SMTPClient methodsFor: 'private protocol' stamp: 'mir 6/12/2003 15:47'!
initiateSession
	"HELO <SP> <domain> <CRLF>"

	"self checkResponse."
	self sendCommand: 'HELO ' , NetNameResolver localHostName.
	self checkResponse.
! !

!SMTPClient methodsFor: 'private protocol' stamp: 'mir 6/12/2003 15:39'!
login
	self user ifNil: [^self].
	self sendCommand: 'AUTH LOGIN ' , (self encodeString: self user).
	[self checkResponse]
		on: TelnetProtocolError
		do: [ :ex | ex isCommandUnrecognized ifTrue: [^ self] ifFalse: [ex pass]].
	self sendCommand: (self encodeString: self password).
	self checkResponse! !

!SMTPClient methodsFor: 'private protocol' stamp: 'fbs 3/23/2004 17:16'!
mailFrom: fromAddress
	" MAIL <SP> FROM:<reverse-path> <CRLF>"

	| address |
	address _ (MailAddressParser addressesIn: fromAddress) first.

	self sendCommand: 'MAIL FROM: <', address, '>'.
	self checkResponse.! !

!SMTPClient methodsFor: 'private protocol' stamp: 'mir 2/21/2002 17:52'!
quit
	"send a QUIT command.  This is polite to do, and indeed some servers might drop messages that don't have an associated QUIT"
	"QUIT <CRLF>"

	self sendCommand: 'QUIT'.
	self checkResponse.! !

!SMTPClient methodsFor: 'private protocol' stamp: 'mir 2/21/2002 17:52'!
recipient: aRecipient
	"specify a recipient for the message.  aRecipient should be a bare email address"
	"RCPT <SP> TO:<forward-path> <CRLF>"

	self sendCommand: 'RCPT TO: <', aRecipient, '>'.
	self checkResponse.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMTPClient class
	instanceVariableNames: ''!

!SMTPClient class methodsFor: 'accessing' stamp: 'mir 2/21/2002 17:22'!
defaultPortNumber
	^25! !

!SMTPClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:07'!
logFlag
	^#smtp! !


!SMTPClient class methodsFor: 'example' stamp: 'mir 2/22/2002 16:41'!
example
	"SMTPClient example"

	self deliverMailFrom: 'm.rueger@acm.org' to: #('m.rueger@acm.org') text:
'From: test
To: "not listed"
Subject: this is a test

Hello from Squeak!!
'	usingServer: 'smtp.concentric.net'! !

!SMTPClient class methodsFor: 'example' stamp: 'mir 2/22/2002 16:43'!
example2
	"SMTPClient example2"

	self deliverMailFrom: 'm.rueger@acm.org' to: #('m.rueger@acm.org') text:
'Subject: this is a test

Hello from Squeak!!
'	usingServer: 'smtp.concentric.net'! !


!SMTPClient class methodsFor: 'instance creation' stamp: 'mir 2/22/2002 17:37'!
openOnHost: hostIP port: portNumber

	| client |
	client _ super openOnHost: hostIP port: portNumber.
	client initiateSession.
	^client! !


!SMTPClient class methodsFor: 'sending mail' stamp: 'mir 2/22/2002 12:30'!
deliverMailFrom: fromAddress to: recipientList text: messageText usingServer: serverName
	"Deliver a single email to a list of users and then close the connection.  For delivering multiple messages, it is best to create a single connection and send all mail over it.  NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff"

	| smtpClient |
	smtpClient _ self openOnHostNamed: serverName.
	[smtpClient mailFrom: fromAddress to: recipientList text: messageText.
	smtpClient quit]
		ensure: [smtpClient close]
! !
TestCase subclass: #SMTPClientTest
	instanceVariableNames: 'smtp socket'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NetworkTests-Protocols'!

!SMTPClientTest methodsFor: 'running' stamp: 'fbs 3/22/2004 13:11'!
setUp
	socket := MockSocketStream on: ''.
	smtp := SMTPClient new.
	smtp stream: socket.! !


!SMTPClientTest methodsFor: 'testing' stamp: 'fbs 3/23/2004 17:15'!
testMailFrom
	smtp mailFrom: 'frank@angband.za.org'.
	self assert: socket outStream contents = ('MAIL FROM: <frank@angband.za.org>', String crlf).
	
	socket resetOutStream.
	smtp mailFrom: '<frank@angband.za.org>'.
	self assert: socket outStream contents = ('MAIL FROM: <frank@angband.za.org>', String crlf).
	
	socket resetOutStream.
	smtp mailFrom: 'Frank <frank@angband.za.org>'.
	self assert: socket outStream contents = ('MAIL FROM: <frank@angband.za.org>', String crlf).! !
Object subclass: #SMUtilities
	instanceVariableNames: ''
	classVariableNames: 'MailServer MasterServer'
	poolDictionaries: ''
	category: 'SMBase-UI'!
!SMUtilities commentStamp: 'gk 11/13/2003 23:39' prior: 0!
Various loose functions in SM.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMUtilities class
	instanceVariableNames: ''!

!SMUtilities class methodsFor: 'class initialization' stamp: 'gk 5/5/2006 02:07'!
initialize
	"Initialize server settings."

	"self initialize"

	MasterServer := nil.
	MailServer := nil! !

!SMUtilities class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:38'!
mailServer: ipName masterServer: httpUrl
	"Initialize server settings."

	MailServer := ipName.
	MasterServer := httpUrl! !


!SMUtilities class methodsFor: 'server' stamp: 'gk 10/13/2005 00:18'!
isServer
	"Is this a running server?"
	
	^MasterServer notNil! !

!SMUtilities class methodsFor: 'server' stamp: 'gk 8/4/2003 16:15'!
mailPassword: randomPass for: anAccount
	"Change the password to a random generated one
	and mail it to the holder of the account."

	self mail: anAccount subject: 'New password at SqueakMap!!' message:
'Hi!!
An extra random password has been added for the account held by "', anAccount name, '":
"', randomPass, '"

You can login to SqueakMap at:

', MasterServer, '/login

The regular password still works, so if it was not you who requested this extra
random password you can safely just delete this email.

This extra password will stop working when you change your regular password.

'! !

!SMUtilities class methodsFor: 'server' stamp: 'gk 8/4/2003 16:15'!
mailPassword: aPassword forNew: anAccount
	"Mail the password to the person who just registered the account."

	self mail: anAccount subject: 'Your new account at SqueakMap!!' message:
'Hi!!
You or someone else has registered an account on SqueakMap. You can login to it using this link:

',
MasterServer, '/autologin?u=', anAccount initials, '&p=', aPassword,
'

If it was not you who performed this registration you can safely just delete this email.

'! !

!SMUtilities class methodsFor: 'server' stamp: 'gk 8/15/2003 12:25'!
masterServer
	"Return the master server url."

	^MasterServer! !


!SMUtilities class methodsFor: 'utilities' stamp: 'gk 3/31/2006 09:50'!
sendMail: aString
	"Send the given mail message, but check for modern mail senders."

	| server |

	Smalltalk at: #MailSender ifPresent: [ :mailSender |
		^mailSender sendMessage: ((Smalltalk at: #MailMessage) from: aString).
	].

	Smalltalk at: #MailComposition ifPresent: [ :mailComposition |
		^mailComposition new
			messageText:  aString;
			open
	].
	
	Smalltalk at: #Celeste ifPresent: [ :celeste |
		celeste isSmtpServerSet ifTrue: [
			Smalltalk at: #CelesteComposition ifPresent: [ :celesteComposition |
				^celesteComposition
					openForCeleste: celeste current 
					initialText: aString
			]
		]
	].

	Smalltalk at: #AdHocComposition ifPresent: [ :adHocComposition |
		server := UIManager default request: 'What is your mail server for outgoing mail?'.
		^adHocComposition 
			openForCeleste: server
			initialText: aString
	].

	^self inform: 'Sorry, no known way to send the message'.
	 	! !

!SMUtilities class methodsFor: 'utilities' stamp: 'gk 7/10/2004 03:43'!
sendMailTo: recipient regardingPackageRelease: pr
	"Send mail to the given recipient. Try to use the first of:
	- MailSender (with its registered composition class)
	- Celeste
	- AdHocComposition
	for compatibility with 3.5 and 3.6 images"

	self sendMail: (String streamContents: [:stream |
		stream
			nextPutAll: 'From: '; nextPutAll: self mailUserName; cr;
			nextPutAll: 'To: '; nextPutAll: recipient; cr;
			nextPutAll: 'Subject: Regarding '; nextPutAll: pr printName; cr])! !

!SMUtilities class methodsFor: 'utilities' stamp: 'gk 3/31/2006 09:52'!
stripEmailFrom: aString
	"Picks out the email from:
		'Robert Robertson <rob@here.com>' => 'rob@here.com'
	Spamblockers 'no_spam', 'no_canned_ham' and 'spam_block'
	(case insensitive) will be filtered out."

	| lessThan moreThan email pos |
	lessThan := aString indexOf: $<.
	moreThan := aString indexOf: $>.
	(lessThan * moreThan = 0) ifTrue: [^ aString].
	email := (aString copyFrom: lessThan + 1 to: moreThan - 1) asLowercase.
	#('no_spam' 'no_canned_ham' 'spam_block') do: [:block |
		pos := email findString: block.
		pos = 0 ifFalse:[email := (email copyFrom: 1 to: pos - 1), (email copyFrom: pos + block size to: email size)]].
	^email! !

!SMUtilities class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:38'!
stripNameFrom: aString
	"Picks out the name from:
		'Robert Robertson <rob@here.com>' => 'Robert Robertson'
	"

	| lessThan |
	lessThan := aString indexOf: $<.
	^(aString copyFrom: 1 to: lessThan - 1) withBlanksTrimmed ! !


!SMUtilities class methodsFor: 'private' stamp: 'gk 10/12/2005 23:10'!
mail: anAccount subject: sub message: msg
	"Send a mail to the holder of <anAccount>."

	SMTPClient
		deliverMailFrom: 'squeakmap@squeak.org'
		to: {anAccount email}
		text:
('From: SqueakMap <squeakmap@squeak.org>
To: ', anAccount email, '
Subject: ', sub,
'
', msg, (self randomPhrase), ', SqueakMap') squeakToIso usingServer: MailServer! !

!SMUtilities class methodsFor: 'private' stamp: 'rbb 3/1/2005 11:12'!
mailUserName
	"Answer the mail user's name, but deal with some historical mail senders."

	| mailSender |
	mailSender := (Smalltalk at: #MailSender ifAbsent: [ Smalltalk at: #Celeste ifAbsent: []]).
	^mailSender
		ifNil: [ UIManager default request: 'What is your email address?' ]
		ifNotNil: [ mailSender userName ]! !

!SMUtilities class methodsFor: 'private' stamp: 'gh 11/27/2002 12:37'!
randomPhrase
	"Pick a nice phrase."

	^#('Debug safely' 'Happy Squeaking' 'Just do it' 'Yours truly' 'Stay a Squeaker' 'Squeak rocks') atRandom! !
TestCase subclass: #ST80MenusTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Menus-Tests'!
!ST80MenusTest commentStamp: 'tlk 5/2/2006 22:41' prior: 0!
I am an SUnit Test of PopUpMenu and FillInTheBlank.  The original motivation for my creation was the regression of functionality associated with allowing the non-interactive testing of these menus.  

My fixtures are: None

NOTES ABOUT AUTOMATING USER INPUTS (See MethodContextTest also for a discussion of this functionality.)

When executing non-interactive programs you will inevitably run into programs  that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program. This is particularly true in doing Sunit tests.

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 avoided and a answer provided by an array will be used instead. PopUpMenu and FillInTheBlankMorph take advantage of BlockContext helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept  requests for user interaction.  Of course,

 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} }!


!ST80MenusTest methodsFor: 'testing' stamp: 'tlk 5/2/2006 22:46'!
testSupplyAnswerOfFillInTheBlank

	self should: ['blue' = ([UIManager default request: 'Should not see this message or this test failed?'] 
		valueSupplyingAnswer: #('Should not see this message or this test failed?' 'blue'))]! !


!ST80MenusTest methodsFor: 'tests' stamp: 'tlk 5/2/2006 22:42'!
testSupplySpecificAnswerToQuestion

	self should: [false = ([self confirm: 'Should not see this message or this test failed?'] 
		valueSupplyingAnswer: #('Should not see this message or this test failed?' false))]! !

!ST80MenusTest methodsFor: 'tests' stamp: 'tlk 5/2/2006 22:28'!
testSuppressInform

	self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! !
TestCase subclass: #SUnitExtensionsTest
	instanceVariableNames: 'stream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!

!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'!
assertionFailedInRaiseWithExceptionDoTest

	self 
		should: [ Error signal ]
		raise: Error
		withExceptionDo: [ :anException | self assert: false ]! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'!
differentExceptionInShouldRaiseWithExceptionDoTest

	[ self 
		should: [ Error signal ]
		raise: Halt
		withExceptionDo: [ :anException | self assert: false description: 'should:raise:withExceptionDo: handled an exception that should not handle'] ]
	on: Error
	do: [ :anException | anException return: nil ]! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'!
errorInRaiseWithExceptionDoTest

	self 
		should: [ Error  signal ]
		raise: Error
		withExceptionDo: [ :anException | Error signal: 'A forced error' ]! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'md 8/2/2006 11:04'!
invalidShouldNotTakeMoreThan

	self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 50 milliSeconds.! !

!SUnitExtensionsTest methodsFor: 'real tests'!
invalidShouldNotTakeMoreThanMilliseconds

	self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 50! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'!
noExceptionInShouldRaiseWithExceptionDoTest

	self 
		should: [  ]
		raise: Error
		withExceptionDo: [ :anException | Error signal: 'Should not get here' ]! !

!SUnitExtensionsTest methodsFor: 'real tests'!
shouldFixTest

	self shouldFix: [ Error signal: 'any kind of error' ]
! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'!
shouldRaiseWithExceptionDoTest

	self 
		should: [ Error signal: '1' ]
		raise: Error
		withExceptionDo: [ :anException | self assert: anException messageText = '1' ]! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'!
shouldRaiseWithSignalDoTest

	self 
		should: [ Error signal: '1' ]
		raise: Error
		withExceptionDo: [ :anException | self assert: anException messageText = '1' ]! !

!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'md 8/2/2006 11:05'!
validShouldNotTakeMoreThan

	self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan:  200 milliSeconds.! !

!SUnitExtensionsTest methodsFor: 'real tests'!
validShouldNotTakeMoreThanMilliseconds

	self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 200! !


!SUnitExtensionsTest methodsFor: 'test support'!
failureLog
	^self stream! !


!SUnitExtensionsTest methodsFor: 'testing'!
isLogging
	^true! !


!SUnitExtensionsTest methodsFor: 'accessing'!
stream
	stream isNil ifTrue: [stream := WriteStream on: String new].
	^stream! !


!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:39'!
testAssertionFailedInRaiseWithExceptionDo

	| testCase testResult  |
	
	testCase := self class selector: #assertionFailedInRaiseWithExceptionDoTest.
	testResult := testCase run.
	
	self assert: (testResult failures includes: testCase).
	self assert: testResult failures size=1.
	self assert: testResult passed isEmpty.
	self assert: testResult errors isEmpty.
	
	! !

!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 21:15'!
testAutoAssertFalse
	| booleanCondition |
	self assert: self isLogging.
	self should: [ self assert: 1 = 2 description: 'self assert: 1 = 2' ] raise: TestResult failure.
	booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self assert: 1 = 2'.
	self assert: booleanCondition! !

!SUnitExtensionsTest methodsFor: 'test'!
testAutoAssertTrue
	self assert: 1 = 1.
	self assert: true! !

!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 21:16'!
testAutoDenyFalse
	| booleanCondition |
	self assert: self isLogging.
	self should: [ self deny: 1 = 1 description: 'self deny: 1 = 1'.] raise: TestResult failure.
	booleanCondition := (self stream contents subStrings:  {Character cr}) last = 'self deny: 1 = 1'.
	self assert: booleanCondition! !

!SUnitExtensionsTest methodsFor: 'test'!
testAutoDenyTrue
	self deny: 1 = 2.
	self deny: false! !

!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:40'!
testDifferentExceptionInShouldRaiseWithExceptionDo

	| testCase testResult  |
	
	testCase := self class selector: #differentExceptionInShouldRaiseWithExceptionDoTest.
	testResult := testCase run.
	
	self assert: (testResult passed includes: testCase).
	self assert: testResult errors isEmpty.
	self assert: testResult failures isEmpty.
	self assert: testResult passed size=1! !

!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:40'!
testErrorInRaiseWithExceptionDo

	| testCase testResult  |
	
	testCase := self class selector: #errorInRaiseWithExceptionDoTest.
	testResult := testCase run.
		
	self assert: (testResult errors includes: testCase).
	self assert: testResult errors size=1.
	self assert: testResult failures isEmpty.
	self assert: testResult passed isEmpty.
	
	! !

!SUnitExtensionsTest methodsFor: 'test' stamp: 'md 8/2/2006 11:06'!
testInvalidShouldNotTakeMoreThan

	| testCase testResult |

	testCase := self class selector: #invalidShouldNotTakeMoreThan.
	testResult := testCase run.

	self assert: testResult passed isEmpty.
	self assert: testResult failures size = 1.
	self assert: (testResult failures includes: testCase).
	self assert: testResult errors isEmpty

! !

!SUnitExtensionsTest methodsFor: 'test'!
testInvalidShouldNotTakeMoreThanMilliseconds

	| testCase testResult |

	testCase := self class selector: #invalidShouldNotTakeMoreThanMilliseconds.
	testResult := testCase run.

	self assert: testResult passed isEmpty.
	self assert: testResult failures size = 1.
	self assert: (testResult failures includes: testCase).
	self assert: testResult errors isEmpty

! !

!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:40'!
testNoExceptionInShouldRaiseWithExceptionDo

	| testCase testResult  |
	
	testCase := self class selector: #noExceptionInShouldRaiseWithExceptionDoTest.
	testResult := testCase run.
	
	self assert: (testResult failures includes: testCase).
	self assert: testResult failures size=1.
	self assert: testResult passed isEmpty.
	self assert: testResult errors isEmpty.
	
	! !

!SUnitExtensionsTest methodsFor: 'test'!
testShouldFix

	| testCase testResult  |
	
	testCase := self class selector: #shouldFixTest.
	testResult := testCase run.
	
	self assert: (testResult passed includes: testCase).
	self assert: testResult passed size=1.
	self assert: testResult failures isEmpty.
	self assert: testResult errors isEmpty.
	
	! !

!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:40'!
testShouldRaiseWithExceptionDo

	| testCase testResult  |
	
	testCase := self class selector: #shouldRaiseWithExceptionDoTest.
	testResult := testCase run.
	
	self assert: (testResult passed includes: testCase).
	self assert: testResult passed size=1.
	self assert: testResult failures isEmpty.
	self assert: testResult errors isEmpty.
	
	! !

!SUnitExtensionsTest methodsFor: 'test' stamp: 'md 8/2/2006 11:06'!
testValidShouldNotTakeMoreThan
	| testCase testResult |

	testCase := self class selector: #validShouldNotTakeMoreThan.
	testResult := testCase run.

	self assert: (testResult passed includes: testCase).
	self assert: testResult passed size = 1.
	self assert: testResult failures isEmpty.
	self assert: testResult errors isEmpty

! !

!SUnitExtensionsTest methodsFor: 'test'!
testValidShouldNotTakeMoreThanMilliseconds

	| testCase testResult |

	testCase := self class selector: #validShouldNotTakeMoreThanMilliseconds.
	testResult := testCase run.

	self assert: (testResult passed includes: testCase).
	self assert: testResult passed size = 1.
	self assert: testResult failures isEmpty.
	self assert: testResult errors isEmpty

! !


!SUnitExtensionsTest methodsFor: 'as yet unclassified' stamp: 'md 4/2/2006 14:02'!
testExceptionWithMatchingString
	self should: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'NOT obsolete' description: 'tested obsoleting Object'! !

!SUnitExtensionsTest methodsFor: 'as yet unclassified' stamp: 'md 4/2/2006 14:02'!
testExceptionWithoutMatchingString
	self should: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'Zero' description: 'tested obsoleting Object'! !

!SUnitExtensionsTest methodsFor: 'as yet unclassified' stamp: 'md 4/2/2006 14:02'!
testNoExceptionWithMatchingString
	self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'Zero' description: 'tested obsoleting Object'! !

!SUnitExtensionsTest methodsFor: 'as yet unclassified' stamp: 'md 4/2/2006 14:02'!
testNoExceptionWithNoMatchingString
	self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'NOT' description: 'tested obsoleting Object'! !
TestCase subclass: #SUnitTest
	instanceVariableNames: 'hasRun hasSetup hasRanOnce'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!
!SUnitTest commentStamp: '<historical>' prior: 0!
This is both an example of writing tests and a self test for the SUnit. The tests 
here are pretty strange, since you want to make sure things blow up. You should 
not generally have to write tests this complicated in structure, although they 
will be far more complicated in terms of your own objects- more assertions, more 
complicated setup. Kent says: "Never forget, however, that if the tests are hard 
to write, something is probably wrong with the design".!


!SUnitTest methodsFor: 'accessing'!
hasRun
	^hasRun
			! !

!SUnitTest methodsFor: 'accessing'!
hasSetup
	^hasSetup
			! !


!SUnitTest methodsFor: 'running'!
setUp
	hasSetup := true
			! !


!SUnitTest methodsFor: 'testing' stamp: 'md 2/22/2006 14:17'!
errorShouldntRaise
	self 
		shouldnt: [self someMessageThatIsntUnderstood] 
		raise: Notification new
			! !

!SUnitTest methodsFor: 'testing'!
testAssert
	self assert: true.
	self deny: false
			! !

!SUnitTest methodsFor: 'testing'!
testDefects
	| result suite error failure |
	suite := TestSuite new.
	suite addTest: (error := self class selector: #error).
	suite addTest: (failure := self class selector: #fail).
	result := suite run.
	self assert: result defects asArray = (Array with: error with: failure).
	self
		assertForTestResult: result
		runCount: 2
		passed: 0
		failed: 1
		errors: 1
			! !

!SUnitTest methodsFor: 'testing'!
testDialectLocalizedException

	self
		should: [TestResult signalFailureWith: 'Foo']
		raise: TestResult failure.
	self
		should: [TestResult signalErrorWith: 'Foo']
		raise: TestResult error.

			! !

!SUnitTest methodsFor: 'testing'!
testError

	| case result |

	case := self class selector: #error.
	result := case run.
	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1.

	case := self class selector: #errorShouldntRaise.
	result := case run.
	self 
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 0
		errors: 1
			! !

!SUnitTest methodsFor: 'testing'!
testException

	self
		should: [self error: 'foo']
		raise: TestResult error
			! !

!SUnitTest methodsFor: 'testing'!
testFail

	| case result |

	case := self class selector: #fail.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 0
		failed: 1
		errors: 0
			! !

!SUnitTest methodsFor: 'testing'!
testIsNotRerunOnDebug

	| case |

	case := self class selector: #testRanOnlyOnce.
	case run.
	case debug
			! !

!SUnitTest methodsFor: 'testing'!
testRan

	| case |

	case := self class selector: #setRun.
	case run.
	self assert: case hasSetup.
	self assert: case hasRun
			! !

!SUnitTest methodsFor: 'testing'!
testRanOnlyOnce

	self assert: hasRanOnce ~= true.
	hasRanOnce := true
			! !

!SUnitTest methodsFor: 'testing'!
testResult

	| case result |

	case := self class selector: #noop.
	result := case run.

	self
		assertForTestResult: result
		runCount: 1
		passed: 1
		failed: 0
		errors: 0
			! !

!SUnitTest methodsFor: 'testing' stamp: 'md 2/22/2006 14:16'!
testRunning

	(Delay forSeconds: 2) wait
			! !

!SUnitTest methodsFor: 'testing' stamp: 'md 2/22/2006 14:19'!
testSelectorWithArg: anObject
	"should not result in error"! !

!SUnitTest methodsFor: 'testing'!
testShould

	self
		should: [true];
		shouldnt: [false]
			! !

!SUnitTest methodsFor: 'testing'!
testSuite

	| suite result |

	suite := TestSuite new.
	suite 
		addTest: (self class selector: #noop);
		addTest: (self class selector: #fail);
		addTest: (self class selector: #error).

	result := suite run.

	self
		assertForTestResult: result
		runCount: 3
		passed: 1
		failed: 1
		errors: 1
			! !

!SUnitTest methodsFor: 'testing' stamp: 'DF 3/17/2006 01:30'!
testWithExceptionDo

	self
		should: [self error: 'foo']
		raise: TestResult error
		withExceptionDo: [:exception |
			self assert: (exception description includesSubString: 'foo')
		]
			! !


!SUnitTest methodsFor: 'private'!
assertForTestResult: aResult runCount: aRunCount passed: aPassedCount failed: aFailureCount errors: anErrorCount

	self
		assert: aResult runCount = aRunCount;
		assert: aResult passedCount = aPassedCount;
		assert: aResult failureCount = aFailureCount;
		assert: aResult errorCount = anErrorCount
			! !

!SUnitTest methodsFor: 'private'!
error
	3 zork
			! !

!SUnitTest methodsFor: 'private'!
fail
	self assert: false
			! !

!SUnitTest methodsFor: 'private'!
noop
			! !

!SUnitTest methodsFor: 'private'!
setRun
	hasRun := true
			! !
ToolBuilder subclass: #SUnitToolBuilder
	instanceVariableNames: 'widgets'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!
!SUnitToolBuilder commentStamp: 'cwp 6/7/2005 00:53' prior: 0!
I create a set of "stub" widgets that are useful for testing. Instead of drawing themselves in some GUI, they simulate graphical widgets for testing purposes. Through my widgets, unit tests can simulate user actions and make assertions about the state of the display.

See TestRunnerPlusTest for examples.!


!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'!
buildPluggableButton: aSpec
	| w |
	w := ButtonStub fromSpec: aSpec.
	self register: w id: aSpec name.
	^w! !

!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'!
buildPluggableList: aSpec 
	| w |
	w := ListStub fromSpec: aSpec.
	self register: w id: aSpec name.
	^w! !

!SUnitToolBuilder methodsFor: 'building' stamp: 'cwp 6/8/2005 23:34'!
buildPluggableMenu: aSpec 
	^ MenuStub fromSpec: aSpec! !

!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'!
buildPluggablePanel: aSpec
	| w |
	w := PanelStub fromSpec: aSpec.
	self register: w id: aSpec name.
	^w! !

!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'!
buildPluggableText: aSpec 
	| w |
	w := TextStub fromSpec: aSpec.
	self register: w id: aSpec name.
	^w! !

!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'!
buildPluggableTree: aSpec
	| w |
	w := TreeStub fromSpec: aSpec.
	self register: w id: aSpec name.
	^w! !

!SUnitToolBuilder methodsFor: 'building' stamp: 'stephaneducasse 2/3/2006 22:32'!
buildPluggableWindow: aSpec
	| window children |
	window := WindowStub fromSpec: aSpec.
	children := aSpec children.
	children isSymbol 
		ifFalse: [window children: (children collect: [:ea | ea buildWith: self])].
	self register: window id: aSpec name.
	^ window! !



!SUnitToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:32'!
register: widget id: id
	id ifNil:[^self].
	widgets ifNil:[widgets := Dictionary new].
	widgets at: id put: widget.! !

!SUnitToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:32'!
widgetAt: id ifAbsent: aBlock
	widgets ifNil:[^aBlock value].
	^widgets at: id ifAbsent: aBlock! !


!SUnitToolBuilder methodsFor: 'opening' stamp: 'cwp 7/14/2006 10:53'!
close: aWidget
	aWidget close! !

!SUnitToolBuilder methodsFor: 'opening' stamp: 'cwp 7/14/2006 10:48'!
open: anObject
	^ self build: anObject! !
ToolBuilderTests subclass: #SUnitToolBuilderTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!SUnitToolBuilderTests methodsFor: 'running' stamp: 'cwp 4/22/2005 21:14'!
setUp
	super setUp.
	builder := SUnitToolBuilder new.! !


!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 4/22/2005 22:47'!
acceptWidgetText
	widget accept: 'Some text'! !

!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:09'!
buttonWidgetEnabled
	^ widget isEnabled! !

!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 5/27/2005 08:22'!
changeListWidget
	widget clickItemAt: widget selectedIndex + 1! !

!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 4/22/2005 21:37'!
fireButtonWidget
	widget click! !

!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 6/9/2005 00:07'!
fireMenuItemWidget
	widget click: 'Menu Item'! !

!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 4/22/2005 22:44'!
widgetColor
	^ widget color! !


!SUnitToolBuilderTests methodsFor: 'tests' stamp: 'cwp 5/26/2005 08:40'!
testListCached
	
	self makeItemList.
	queries := Bag new.
	self changed: #getList.
	widget list.
	widget list.
	self assert: queries size = 1! !

!SUnitToolBuilderTests methodsFor: 'tests' stamp: 'cwp 5/27/2005 08:23'!
testListSelectionCached
	
	self makeItemList.
	queries := Bag new.
	self changed: #getListSelection.
	widget selectedIndex.
	widget selectedIndex.
	self assert: queries size = 1! !

!SUnitToolBuilderTests methodsFor: 'tests' stamp: 'cwp 5/30/2005 23:09'!
testTextCached
	
	self makeText.
	queries := Bag new.
	self changed: #getText.
	widget text.
	widget text.
	self assert: queries size = 1! !

Object subclass: #SampledInstrument
	instanceVariableNames: 'sustainedSoft sustainedLoud staccatoSoft staccatoLoud sustainedThreshold loudThreshold'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SampledInstrument commentStamp: '<historical>' prior: 0!
I represent a collection of individual notes at different pitches, volumes, and articulations. On request, I can select the best note to use for a given pitch, duration, and volume. I currently only support two volumes, loud and soft, and two articulations, normal and staccato, but I can easily be extended to include more. The main barrier to keeping more variations is simply the memory space (assuming my component notes are sampled sounds).
!


!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
allSampleSets: sortedNotes

	| keyMap |
	keyMap := self midiKeyMapFor: sortedNotes.
	sustainedSoft := keyMap.
	sustainedLoud := keyMap.
	staccatoSoft := keyMap.
	staccatoLoud := keyMap.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	sustainedThreshold := 0.15.
	loudThreshold := 0.5.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:21'!
loudThreshold

	^ loudThreshold
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
loudThreshold: aNumber

	loudThreshold := aNumber asFloat.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
staccatoLoudAndSoftSampleSet: sortedNotes

	staccatoLoud := self midiKeyMapFor: sortedNotes.
	staccatoSoft := staccatoLoud.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
staccatoLoudSampleSet: sortedNotes

	staccatoLoud := self midiKeyMapFor: sortedNotes.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
staccatoSoftSampleSet: sortedNotes

	staccatoSoft := self midiKeyMapFor: sortedNotes.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
sustainedLoudSampleSet: sortedNotes

	sustainedLoud := self midiKeyMapFor: sortedNotes.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
sustainedSoftSampleSet: sortedNotes

	sustainedSoft := self midiKeyMapFor: sortedNotes.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:21'!
sustainedThreshold

	^ sustainedThreshold
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
sustainedThreshold: aNumber

	sustainedThreshold := aNumber asFloat.
! !


!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
allNotes
	"Answer a collection containing of all the unique sampled sounds used by this instrument."

	| r |
	r := IdentitySet new.
	r addAll: sustainedLoud.
	sustainedSoft ~~ sustainedLoud ifTrue: [r addAll: sustainedSoft].
	staccatoLoud ~~ sustainedLoud ifTrue: [r addAll: staccatoLoud].
	staccatoSoft ~~ staccatoLoud ifTrue: [r addAll: staccatoSoft].
	^ (r asSortedCollection: [:n1 :n2 | n1 pitch < n2 pitch]) asArray
! !

!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
chooseSamplesForPitch: pitchInHz from: sortedNotes
	"From the given collection of LoopedSampledSounds, choose the best one to be pitch-shifted to produce the given pitch."
	"Assume: the given collection is sorted in ascending pitch order."

	| i lower higher |
	i := 1.
	[(i < sortedNotes size) and: [(sortedNotes at: i) pitch < pitchInHz]]
		whileTrue: [i := i + 1].
	i = 1 ifTrue: [^ sortedNotes at: 1].
	lower := sortedNotes at: i - 1.
	higher := sortedNotes at: i.
	"note: give slight preference for down-shifting a higher-pitched sample set"
	(pitchInHz / lower pitch) < ((0.95 * higher pitch) / pitchInHz)
		ifTrue: [^ lower]
		ifFalse: [^ higher].
! !

!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
memorySpace
	"Answer the number of bytes required to store the samples for this instrument."

	| total |
	total := 0.
	self allNotes do: [:n |
		total := total + (n leftSamples monoSampleCount * 2).
		n isStereo ifTrue: [total := total + (n leftSamples monoSampleCount * 2)]].
	^ total
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/3/1998 16:42'!
midiKeyMapFor: sortedNotes
	"Return a 128 element array that maps each MIDI key number to the sampled note from the given set with the closests pitch. A precise match isn't necessary because the selected note will be pitch shifted to play at the correct pitch."

	^ (0 to: 127) collect: [:k |
		self
			chooseSamplesForPitch: (AbstractSound pitchForMIDIKey: k)
			from: sortedNotes].
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/18/1998 10:57'!
playChromaticRunFrom: startPitch to: endPitch

	(AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play.
! !

!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
pruneNoteList: aNoteList notesPerOctave: notesPerOctave
	"Return a pruned version of the given note list with only the given number of notes per octave. Assume the given notelist is in sorted order."

	| r interval lastPitch |
	r := OrderedCollection new: aNoteList size.
	interval := (2.0 raisedTo: (1.0 / notesPerOctave)) * 0.995.
	lastPitch := 0.0.
	aNoteList do: [:n |
		n pitch > (lastPitch * interval) ifTrue: [
			r addLast: n.
			lastPitch := n pitch]].
	^ r
! !

!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
pruneToNotesPerOctave: notesPerOctave
	"Prune all my keymaps to the given number of notes per octave."

	sustainedLoud := self midiKeyMapFor:
		(self pruneNoteList: sustainedLoud notesPerOctave: notesPerOctave).
	sustainedSoft := self midiKeyMapFor:
		(self pruneNoteList: sustainedSoft notesPerOctave: notesPerOctave).
	staccatoLoud := self midiKeyMapFor:
		(self pruneNoteList: staccatoLoud notesPerOctave: notesPerOctave).
	staccatoSoft := self midiKeyMapFor:
		(self pruneNoteList: staccatoSoft notesPerOctave: notesPerOctave).
! !

!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
pruneToSingleNote: aNote
	"Fill all my keymaps with the given note."

	| oneNoteMap |
	oneNoteMap := Array new: 128 withAll: aNote.
	sustainedLoud := oneNoteMap.
	sustainedSoft := oneNoteMap.
	staccatoLoud := oneNoteMap.
	staccatoSoft := oneNoteMap.
! !

!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
readSampleSetFrom: dirName
	"Answer a collection of sounds read from AIFF files in the given directory and sorted in ascending pitch order."

	| all dir fullName snd |
	all := SortedCollection sortBlock: [:s1 :s2 | s1 pitch < s2 pitch].
	dir := FileDirectory default on: dirName.
	dir fileNames do: [:n |
		fullName := dir fullNameFor: n.
		Utilities
			informUser: 'Reading AIFF file ', n
			during:
				[snd := LoopedSampledSound new
					fromAIFFFileNamed: fullName
					mergeIfStereo: true].
		all add: snd].
	^ all asArray
! !

!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
readSampleSetInfoFrom: dirName
	"MessageTally spyOn: [SampledInstrument new readSampleSetFrom: 'Tosh:Desktop Folder:AAA Squeak2.0 Beta:Organ Samples:Flute8'] timeToRun"

	| all dir fullName info |
	all := OrderedCollection new.
	dir := FileDirectory default on: dirName.
	dir fileNames do: [:n |
		fullName := dir fullNameFor: n.
		info := AIFFFileReader new readFromFile: fullName
			mergeIfStereo: false
			skipDataChunk: true.
		all add: n -> info].
	^ all
! !

!SampledInstrument methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
testAtPitch: aPitch
	"SampledInstrument testAtPitch: 'c4'"

	| pattern |
	pattern := (#(
		(c4 0.64 100) 
		(c4 0.64 200) 
		(c4 0.64 400) 
		(c4 0.64 600) 
		(c4 0.64 800) 
		(c4 1.28 1000) 
		(c4 1.28 400) 
		(c4 0.32 500) 
		(c4 0.32 500) 
		(c4 0.32 500) 
		(c4 0.32 500) 
		(c4 0.16 500) 
		(c4 0.16 500) 
		(c4 0.16 500) 
		(c4 0.16 500) 
		(c4 0.16 500) 
		(c4 0.08 500) 
		(c4 0.08 500) 
		(c4 0.16 500) 
		(c4 0.08 500) 
		(c4 0.08 500) 
		(c4 0.64 500))
			collect: [:triple | triple copy at: 1 put: aPitch; yourself]).
	(AbstractSound noteSequenceOn: self from: pattern) play.
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/5/1998 15:16'!
trimAttackOf: sampleBuffer threshold: threshold
	"Trim 'silence' off the initial attacks of the given sound buffer."

	(sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd |
		snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold).
		snd isStereo ifTrue: [
			snd rightSamples:
				(self trimAttackOf: snd rightSamples threshold: threshold)]].
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/5/1998 11:07'!
trimAttacks: threshold
	"Trim 'silence' off the initial attacks all my samples."

	(sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd |
		snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold).
		snd isStereo ifTrue: [
			snd rightSamples:
				(self trimAttackOf: snd rightSamples threshold: threshold)]].
! !


!SampledInstrument methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
soundForMidiKey: midiKey dur: d loudness: l
	"Answer an initialized sound object that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)."

	| keymap note |
	l >= loudThreshold
		ifTrue: [
			d >= sustainedThreshold
				ifTrue: [keymap := sustainedLoud]
				ifFalse: [keymap := staccatoLoud]]
		ifFalse: [
			d >= sustainedThreshold
				ifTrue: [keymap := sustainedSoft]
				ifFalse: [keymap := staccatoSoft]].
	keymap ifNil: [keymap := sustainedLoud].
	note := (keymap at: midiKey) copy.
	^ note
		setPitch: (AbstractSound pitchForMIDIKey: midiKey)
		dur: d
		loudness: (l * note gain)
! !

!SampledInstrument methodsFor: 'playing' stamp: 'jm 8/3/1998 16:53'!
soundForPitch: pitchNameOrNumber dur: d loudness: l
	"Answer an initialized sound object that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0."
	"Note:  Generally, SampledInstruments are expected to be played via MIDI key numbers rather than by pitches, since finding the MIDI key for a given pitch is expensive."

	^ self soundForMidiKey: (AbstractSound midiKeyForPitch: pitchNameOrNumber)
		dur: d
		loudness: l
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SampledInstrument class
	instanceVariableNames: ''!

!SampledInstrument class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
buildSmallOrchestra
	"Example of how to build a skeleton orchestra that uses less memory (about 14 MBytes)."
	"SampledInstrument buildSmallOrchestra"

	| dir |
	AbstractSound unloadSampledTimbres.
	dir := 'Tosh:Not Backed Up:Sample Library:Orchestra'.
	#(clarinet oboe bassoon trombone tympani) do: [:instName |
		SampledInstrument
			readSimpleInstrument: instName
			fromDirectory: dir.
		(AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 1].
	#(flute bass) do: [:instName |
		SampledInstrument
			readSimpleInstrument: instName
			fromDirectory: dir.
		(AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 2].

	(AbstractSound soundNamed: 'bass-f') allNotes do: [:n |
		n firstSample: (n findStartPointForThreshold: 2500)].

	(AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n |
		n beUnlooped.
		n firstSample: (n findStartPointForThreshold: 0)].

	(AbstractSound soundNamed: 'trombone-f') allNotes do: [:n |
		n firstSample: (n findStartPointForThreshold: 1800)].

	AbstractSound soundNamed: 'trumpet-f' put: (AbstractSound soundNamed: 'trombone-f').
	AbstractSound soundNamed: 'horn-f' put: (AbstractSound soundNamed: 'trombone-f').
	AbstractSound soundNamed: 'violin-f' put: (AbstractSound soundNamed: 'bass-f').
	AbstractSound soundNamed: 'viola-f' put: (AbstractSound soundNamed: 'bass-f').
	AbstractSound soundNamed: 'cello-f' put: (AbstractSound soundNamed: 'bass-f').

	(AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n | n beUnlooped].

! !

!SampledInstrument class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
readLoudAndStaccatoInstrument: instName fromDirectory: orchestraDir
	"SampledInstrument
		readLoudAndStaccatoInstrument: 'oboe'
		fromDirectory: 'Tosh:Sample Library:Orchestra'"

	| sampleSetDir memBefore memAfter loud short snd |
	sampleSetDir := orchestraDir, ':', instName.
	memBefore := Smalltalk garbageCollect.
	loud := SampledInstrument new readSampleSetFrom: sampleSetDir, ' f'.
	short := SampledInstrument new readSampleSetFrom: sampleSetDir, ' stacc'.
	memAfter := Smalltalk garbageCollect.
	Transcript show:
		instName, ': ', (memBefore - memAfter) printString,
		' bytes; ', memAfter printString, ' bytes left'; cr.
	AbstractSound soundNamed: instName, '-f&stacc' put:
		(snd := SampledInstrument new
			allSampleSets: loud;
			staccatoLoudAndSoftSampleSet: short).
	"fix slow attacks"
	snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 500)].

	AbstractSound soundNamed: instName, '-f' put:
		(snd := SampledInstrument new
			allSampleSets: loud).
	"fix slow attacks"
	snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)].
! !

!SampledInstrument class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
readPizzInstrument: instName fromDirectory: orchestraDir
	"SampledInstrument
		readPizzInstrument: 'violin'
		fromDirectory: 'Tosh:Sample Library:Orchestra'"

	| sampleSetDir memBefore memAfter sampleSet snd |
	sampleSetDir := orchestraDir, ':', instName, ' pizz'.
	memBefore := Smalltalk garbageCollect.
	sampleSet := SampledInstrument new readSampleSetFrom: sampleSetDir.
	memAfter := Smalltalk garbageCollect.
	Transcript show:
		instName, ': ', (memBefore - memAfter) printString,
		' bytes; ', memAfter printString, ' bytes left'; cr.
	AbstractSound soundNamed: instName, '-pizz' put:
		(snd := SampledInstrument new allSampleSets: sampleSet).

	"fix slow attacks"
	snd allNotes do: [:n |
		n firstSample: (n findStartPointForThreshold: 1000)].

	^ snd
! !

!SampledInstrument class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
readSimpleInstrument: instName fromDirectory: orchestraDir
	"SampledInstrument
		readSimpleInstrument: 'oboe'
		fromDirectory: 'Tosh:Sample Library:Orchestra'"

	| sampleSetDir memBefore memAfter sampleSet snd |
	sampleSetDir := orchestraDir, ':', instName, ' f'.
	memBefore := Smalltalk garbageCollect.
	sampleSet := SampledInstrument new readSampleSetFrom: sampleSetDir.
	memAfter := Smalltalk garbageCollect.
	Transcript show:
		instName, ': ', (memBefore - memAfter) printString,
		' bytes; ', memAfter printString, ' bytes left'; cr.
	AbstractSound soundNamed: instName, '-f' put:
		(snd := SampledInstrument new allSampleSets: sampleSet).

	"fix slow attacks"
	snd allNotes do: [:n |
		n firstSample: (n findStartPointForThreshold: 1000)].

	^ snd
! !
AbstractSound subclass: #SampledSound
	instanceVariableNames: 'initialCount count samples originalSamplingRate samplesSize scaledIndex indexHighBits scaledIncrement'
	classVariableNames: 'CoffeeCupClink DefaultSampleTable IncrementFractionBits IncrementScaleFactor NominalSamplePitch ScaledIndexOverflow SoundLibrary'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!SampledSound methodsFor: 'accessing' stamp: 'di 12/7/2000 16:04'!
compressWith: codecClass
	^ codecClass new compressSound: self! !

!SampledSound methodsFor: 'accessing' stamp: 'RAA 12/24/2000 08:49'!
compressWith: codecClass atRate: aSamplingRate

	^ codecClass new compressSound: self atRate: aSamplingRate! !

!SampledSound methodsFor: 'accessing' stamp: 'jm 3/28/98 05:46'!
duration

	^ initialCount asFloat / self samplingRate asFloat
! !

!SampledSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration: seconds

	super duration: seconds.
	count := initialCount := (seconds * self samplingRate) rounded.
! !

!SampledSound methodsFor: 'accessing' stamp: 'jm 12/15/97 22:51'!
originalSamplingRate

	^ originalSamplingRate
! !

!SampledSound methodsFor: 'accessing' stamp: 'jm 9/12/97 16:46'!
samples

	^ samples
! !


!SampledSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:41'!
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)."

	| reverseBytes |
	self samplingRate ~= originalSamplingRate ifTrue: [
		^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream].

	"optimization: if sampling rates match, just store my buffer"
	reverseBytes := bigEndianFlag ~= SmalltalkImage current  isBigEndian.
	reverseBytes ifTrue: [samples reverseEndianness].
	(aBinaryStream isKindOf: StandardFileStream)
		ifTrue: [  "optimization for files: write sound buffer directly to file"
			aBinaryStream next: (samples size // 2) putAll: samples startingAt: 1]  "size in words"
		ifFalse: [  "for non-file streams:"
			1 to: samples monoSampleCount do: [:i | aBinaryStream int16: (samples at: i)]].
	reverseBytes ifTrue: [samples reverseEndianness].  "restore to original endianness"
! !


!SampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
pitch: pitchNameOrNumber

	| p |
	p := self nameOrNumberToPitch: pitchNameOrNumber.
	originalSamplingRate :=
		((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger.
	self reset.
! !

!SampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setPitch: pitchNameOrNumber dur: d loudness: vol
	"Used to play scores using the default sample table."
	"(SampledSound pitch: 880.0 dur: 1.5 loudness: 0.6) play"

	| p |
	super setPitch: pitchNameOrNumber dur: d loudness: vol.
	p := self nameOrNumberToPitch: pitchNameOrNumber.
	samples := DefaultSampleTable.
	samplesSize := samples size.
	initialCount := (d * self samplingRate asFloat) rounded.
	originalSamplingRate :=
		((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger.
	self loudness: vol.
	self reset.
! !

!SampledSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setSamples: anArray samplingRate: rate
	"Set my samples array to the given array with the given nominal sampling rate. Altering the rate parameter allows the sampled sound to be played back at different pitches."
	"Note: There are two ways to use sampled sound: (a) you can play them through once (supported by this method) or (b) you can make them the default waveform with which to play a musical score (supported by the class method defaultSampleTable:)."
	"Assume: anArray is either a SoundBuffer or a collection of signed 16-bit sample values."
	"(SampledSound
		samples: SampledSound coffeeCupClink
		samplingRate: 5000) play"

	"copy the array into a SoundBuffer if necessary"
	anArray class isWords
		ifTrue: [samples := anArray]
		ifFalse: [samples := SoundBuffer fromArray: anArray].

	samplesSize := samples size.
	samplesSize >= SmallInteger maxVal ifTrue: [  "this is unlikely..."
		self error: 'sample count must be under ',  SmallInteger maxVal printString].
	originalSamplingRate := rate.
	initialCount := (samplesSize * self samplingRate) // originalSamplingRate.
	self loudness: 1.0.
	self reset.
! !


!SampledSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
endGracefully
	"See stopGracefully, which affects initialCOunt, and I don't think it should (di)."

	| decayInMs env |
	envelopes isEmpty
		ifTrue: [
			self adjustVolumeTo: 0 overMSecs: 10.
			decayInMs := 10]
		ifFalse: [
			env := envelopes first.
			decayInMs := env attackTime + env decayTime].
	count := decayInMs * self samplingRate // 1000.
! !

!SampledSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1."

	| lastIndex outIndex sampleIndex sample i s overflow |
	<primitive:'primitiveMixSampledSound' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #samples declareC: 'short int *samples'.

	lastIndex := (startIndex + n) - 1.
	outIndex := startIndex.    "index of next stereo output sample pair"
	sampleIndex := indexHighBits + (scaledIndex >> IncrementFractionBits).
	[(sampleIndex <= samplesSize) and: [outIndex <= lastIndex]] whileTrue: [
		sample := ((samples at: sampleIndex) * scaledVol) // ScaleFactor.
		leftVol > 0 ifTrue: [
			i := (2 * outIndex) - 1.
			s := (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor).
			s >  32767 ifTrue: [s :=  32767].  "clipping!!"
			s < -32767 ifTrue: [s := -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
		rightVol > 0 ifTrue: [
			i := 2 * outIndex.
			s := (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
			s >  32767 ifTrue: [s :=  32767].  "clipping!!"
			s < -32767 ifTrue: [s := -32767].  "clipping!!"
			aSoundBuffer at: i put: s].

		scaledVolIncr ~= 0 ifTrue: [
			scaledVol := scaledVol + scaledVolIncr.
			((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
			 [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
				ifTrue: [  "reached the limit; stop incrementing"
					scaledVol := scaledVolLimit.
					scaledVolIncr := 0]].

		scaledIndex := scaledIndex + scaledIncrement.
		scaledIndex >= ScaledIndexOverflow ifTrue: [
			overflow := scaledIndex >> IncrementFractionBits.
			indexHighBits := indexHighBits + overflow.
			scaledIndex := scaledIndex - (overflow << IncrementFractionBits)].

		sampleIndex := indexHighBits + (scaledIndex >> IncrementFractionBits).
		outIndex := outIndex + 1].
	count := count - n.
! !

!SampledSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
playSilentlyUntil: startTime
	"Used to fast foward to a particular starting time.
	Overridden to be instant for sampled sounds."

"true ifTrue: [^ super playSilentlyUntil: startTime]."
	indexHighBits := (startTime * originalSamplingRate) asInteger.
	scaledIndex := IncrementScaleFactor.
	count := initialCount - (startTime * self samplingRate).
	mSecsSinceStart := (startTime * 1000) asInteger.

! !

!SampledSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset
	"Details: The sample index and increment are scaled to allow fractional increments without having to do floating point arithmetic in the inner loop."

	super reset.
	scaledIncrement :=
		((originalSamplingRate asFloat / self samplingRate) * IncrementScaleFactor) rounded.
	count := initialCount.
	scaledIndex := IncrementScaleFactor.  "index of the first sample, scaled"
	indexHighBits := 0.
! !

!SampledSound methodsFor: 'playing' stamp: 'jm 9/13/97 19:07'!
samplesRemaining

	^ count
! !

!SampledSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
setScaledIncrement: aNumber

	scaledIncrement := (aNumber * IncrementScaleFactor) rounded.

! !

!SampledSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds."

	count := (mSecs * self samplingRate) // 1000.
! !


!SampledSound methodsFor: 'sound tracks' stamp: 'stephaneducasse 2/4/2006 20:41'!
sonogramMorph: height from: start to: stop nPoints: nPoints
	"FYI:  It is very cool that we can do this, but for sound tracks on a movie,
	simple volume is easier to read, easier to scale, and way faster to compute.
	Code preserved here just in case it makes a useful example."
	"In an inspector of a samplesSound...
		self currentWorld addMorph: (self sonogramMorph: 32 from: 1 to: 50000 nPoints: 256)
	"
	| fft sonogramMorph data width |
	fft := FFT new: nPoints.
	width := stop-start//nPoints.
	sonogramMorph := Sonogram new
			extent: width@height
			minVal: 0.0
			maxVal: 1.0
			scrollDelta: width.
	start to: stop-nPoints by: nPoints do:
		[:i |
		data := fft transformDataFrom: samples startingAt: i.
		data := data collect: [:v | v sqrt].  "square root compresses dynamic range"
		data /= 200.0.
		sonogramMorph plotColumn: data].
	^ sonogramMorph
	
! !

!SampledSound methodsFor: 'sound tracks' stamp: 'stephaneducasse 2/4/2006 20:41'!
volumeForm: height from: start to: stop nSamplesPerPixel: nPerPixel
	"Note: nPerPixel can be Integer or Float for pixel-perfect alignment."
	"In an inspector of a samplesSound...
		self currentWorld addMorph: (ImageMorph new image:
			(self volumeForm: 32 from: 1 to: samples size nSamplesPerPixel: 225))
	"
	| volPlot width sample min max vol |
	width := stop-start//nPerPixel.
	volPlot := Form extent: width@height.
	(start max: 1) to: (stop min: samples size)-nPerPixel by: nPerPixel do:
		[:i | min:= max:= 0.
		i asInteger to: (i+nPerPixel-1) asInteger by: 4 do:  "by: 4 makes it faster yet looks the same"
			[:j | sample := samples at: j.
			sample < min ifTrue: [min := sample].
			sample > max ifTrue: [max := sample]].
		vol := (max - min) * height // 65536.
		volPlot fillBlack: ((i-start//nPerPixel) @ (height-vol//2) extent: 1@(vol+1))].
	^ volPlot
	
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SampledSound class
	instanceVariableNames: ''!

!SampledSound class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"SampledSound initialize"

	IncrementFractionBits := 16.
	IncrementScaleFactor := 2 raisedTo: IncrementFractionBits.
	ScaledIndexOverflow := 2 raisedTo: 29.  "handle overflow before needing LargePositiveIntegers"
	self useCoffeeCupClink.
	SoundLibrary ifNil: [SoundLibrary := Dictionary new].
	Beeper setDefault: (self new
						setSamples: self coffeeCupClink
						samplingRate: 12000).
! !


!SampledSound class methodsFor: 'coffee cup clink' stamp: 'jm 8/23/97 22:25'!
coffeeCupClink
	"Return the samples array for the sound of a spoon being tapped against a coffee cup."

	CoffeeCupClink ifNil: [self initializeCoffeeCupClink].
	^ CoffeeCupClink
! !

!SampledSound class methodsFor: 'coffee cup clink' stamp: 'stephaneducasse 2/4/2006 20:41'!
initializeCoffeeCupClink
	"Initialize the samples array for the sound of a spoon being tapped against a coffee cup."
	"SampledSound initializeCoffeeCupClink"

	| samples |
	samples := #(768 1024 -256 2304 -13312 26624 32512 19200 6400 -256 5888 32512 28928 32512 -32768 32512 -32768 18688 26368 -26112 32512 32512 2304 32512 5632 2816 10240 -4608 -1792 32512 32512 -5376 10752 32512 32512 32512 8192 15872 32512 -3584 -32768 -23296 -24832 -32768 -32768 -32768 -2304 32512 32512 -32768 32512 -15360 6400 8448 -18176 -32768 -256 -32768 -29440 9472 20992 17920 32512 32512 -256 32512 -32768 -32768 -23040 -32768 -25088 -32768 -27648 -1536 24320 -32768 32512 20480 27904 22016 16384 -32768 32512 -27648 -32768 -7168 28160 -6400 5376 32512 -256 32512 -7168 -11776 -19456 -27392 -24576 -32768 -24064 -19456 12800 32512 27136 2048 25344 15616 8192 -4608 -28672 -32768 -30464 -2560 17664 256 -8192 8448 32512 27648 -6144 -512 -7424 -18688 7936 -256 -22272 -14080 2048 27648 15616 -12288 -768 5376 3328 5632 3072 -6656 -20480 10240 27136 -10752 -11008 -768 -2048 6144 -7168 -3584 -1024 -7680 19712 26112 1024 -11008 3072 16384 -8960 -14848 -4864 -23808 -11264 12288 8192 7168 4864 23040 32512 512 -11776 -5632 -16896 -21504 -12800 -6144 -16896 -4352 32512 32512 23296 21760 5632 2816 -9472 -20992 -11264 -29440 -32768 -3584 7680 8448 15360 32512 32512 15616 15104 -2048 -27904 -27904 -25600 -12288 -12032 -13568 17152 22272 15360 30208 28160 7680 -5632 -8192 -16384 -31744 -25856 -10752 -3840 6656 13056 24320 26368 12800 20736 12288 -19200 -20992 -16640 -21504 -17920 -6912 8448 11264 14080 23040 18176 8192 -1024 0 256 -20992 -19712 -4608 -11264 -2048 14080 12032 8192 6912 13056 9216 -5632 -5376 -3840 -6656 -9984 -5632 4864 -3584 -1280 17408 7680 -1280 4096 2816 -1024 -4864 3328 8448 -768 -5888 -2048 5120 0 3072 11008 -7680 -15360 2560 6656 -3840 0 11776 7680 2816 1536 -1280 -3840 -8704 -1536 3584 -9728 -9728 11776 18688 7680 6656 6400 -4864 -3840 -256 -6912 -13312 -11264 2304 9728 1792 3328 18944 18432 6912 6144 -1536 -17664 -14336 -2304 -10496 -15616 -4096 9728 17152 14848 13312 11520 2304 -1024 2560 -8704 -26624 -18688 -256 -256 2816 14080 13824 12544 14080 9728 -512 -12032 -8960 -3328 -9984 -15872 -5120 8192 3584 10496 20224 7936 4608 6144 1280 -8704 -12800 -7424 -8448 -8960 -3840 7424 13056 8704 13312 13056 -2304 -4864 -768 -7168 -10496 -4608 -1536 -3072 -1280 6144 13312 11008 4864 4864 1536 -8960 -7680 1792 -4864 -7680 2816 5632 3328 2560 5376 7936 3584 -512 512 -4608 -9728 0 9216 768 -4096 7680 7168 256 4608 -768 -8704 -6400 2048 6144 -3072 -3328 6400 9472 3840 -768 1792 -3840 -5120 6144 768 -9984 -4352 5120 9472 6912 2816 1792 1280 768 512 -2816 -9728 -6912 6912 6912 -3328 -768 8448 11776 10752 3328 -6912 -10752 -8704 -1536 0 -6912 -3328 9984 13568 7424 6144 6656 256 0 256 -12032 -17920 -8192 3584 8960 4096 5632 12032 8704 6912 5632 -3584 -10496 -7936 -2048 -9216 -11776 2304 9472 15104 14848 5888 512 -2816 1024 2560 -9984 -13312 -5120 768 1792 768 8448 12032 11264 12800 -256 -11264 -9728 -2304 3072 -4352 -6912 256 2304 5376 9984 8192 2816 1280 3584 -2048 -11008 -8448 -2048 3072 4864 2304 3072 3072 3072 7168 3328 -5376 -4864 512 512 -1792 -1792 1792 5376 5888 5888 512 -5888 -3584 4096 3584 -6400 -4864 4608 3072 3840 5376 1024 768 2816 5888 -768 -12288 -7936 2304 5888 3328 2048 6144 3072 3072 6400 -3328 -7168 256 4096 -512 -9472 -6656 3328 6912 9216 8704 3840 -2560 -256 6656 -2560 -11264 -4608 -768 -1280 1536 3072 4096 5120 9984 11264 1024 -8192 -6144 -1024 -3840 -5632 -512 1024 2304 9728 9728 1280 512 4096 2816 -3584 -9984 -6912 -2304 512 5632 7680 3584 1024 5632 5888 -1280 -3584 -2304 -2560 -1536 -1024 -1792 -512 1536 7680 9984 2048 -2048 2048 3328 -1280 -4096 -3328 -4608 -1280 4352 3328 1280 1792 5120 6912 1024 -2560 0 -768 -1024 1280 -256 -4608 -1280 6400 5120 768 1792 2560 2048 0 -1536 -1280 -2304 1024 5376 2560 -2560 -512 4096 2048 512 768 -1280 -256 2560 2560 -256 -1024 768 3584 1280 -3328 -1536 1792 2816 3328 2304 -256 256 2816 2304 -1280 -3328 -1536 2304 2304 -256 -256 1024 1536 3840 5120 1024 -2048 0 1536 -768 -2560 -1792 256 2304 2048 1536 256 768 5888 6656 256 -3840 -2304 -1280 -1536 256 0 -512 2304 4352 3840 768 0 2304 3072 256 -3072 -2560 -2560 256 4608 2560 256 1536 3072 3072 1792 256 256 512 -256 -768 -1280 -1536 768 4352 2816 -512 768 2560 2560 2304 -256 -1792 -768 768 1792 256 -2304 -256 3328 3840 2304 2304 1536 256 2048 1024 -1536 -1792 -1024 512 256 -512 0 2304 4864 5120 4352 1024 -1280 0 -768 -2816 -2304 -512 1024 2048 2304 2048 3072 3840 2816 2048 -512 -3072 -1792 -1536 -1280 768 1280 1536 2304 2816 2048 1536 2048 1536 1536 -768 -3840 -2048 0 1280 2816 1792 1536 2560 3584 2816 1024 256 -768 -768 -1280 -2816 -768 1792 3328 5120 3072 1280 1536 1792 768 -1024 -1280 -1536 -768 512 256 1536 2560 2560 3328 1280 0 768 1536 768 -256 -512 -1536 -1280 768 1280 2304 2560 2560 2560 1024 -256 -512 0 1280 1536 768 -1280 -512 2048 1536 2048 1280 -256 256 512 768 768 1280 2304 1792 512 -1280 -1024 768 1536 1536 256 -768 1536 3584 3072 1792 -256 -1536 -512 256 -512 -512 768 2048 2048 1792 1280 1280 3072 2816 768 -1024 -2304 -1024 256 256 1280 1792 2304 2816 2304 1280 512 1024 768 -768 -1280 -1280 -512 1536 2560 2816 2048 512 1024 1792 1280 768 0 -768 -768 0 256 256 1280 2560 2304 2304 1536 512 512 1024 1280 0 -1792 -1536 -512 1280 3072 2816 1792 512 1024 1536 256 -256 768 768 256 256 -256 512 1280 1280 1536 768 1024 1792 1536 1024 0 256 -512 -256 1024 512 256 768 1792 2304 1280 256 768 1024 1280 1792 768 -768 -768 768 512 256 1024 1792 1536 1280 1536 1792 1280 768 512 -512 -1792 -512 512 768 2304 2816 1792 768 1536 2304 1536 0 -256 -256 -768 -768 256 1536 1536 2304 2048 256 768 2048 2304 1280 0 -256 -1024 -1024 0 1024 1792 2304 2304 1280 512 1280 2048 1280 256 -512 -1792 -1536 256 1536 1792 2048 2048 2048 1536 512 512 768 256 -256 0 -512 -1024 768 2048 2304 2304 1280 1280 1024 1024 1024 0 -512 256 768 0 -256 1536 2304 1792 2304 1280 -512 -256 768 1536 1024 256 512 512 1024 1792 1792 1536 1024 1280 0 -1280 256 2048 2560 2048 1024 -256 -256 1024 1280 1536 1024 0 0 256 768 1792 2304 2048 1280 1024 0 -512 -256 256 1024 1024 512 768 768 1280 2048 1792 1024 768 768 -256 -1024 0 256 1024 1536 1024 1280 1536 1792 1792 1024 512 512 0 -512 -256 512 768 1280 1280 1024 1280 1792 1792 1280 512 -256 -256 256 512 1280 1024 1280 1280 1024 1024 768 1024 1024 1024 1280 256 256 768 768 1024 512 256 768 1280 2560 2560 1280 512 -256 -512 -256 1024 1536 768 1024 1280 768 1024 1536 1536 1024 256 0 0 0 768 768 512 1280 1536 1280 1280 1280 1280 768 768 256 -256 768 768 256 768 1280 1792 1536 1536 1536 256 512 1024 0 -768 -256 768 512 1024 2048 1536 1024 1536 1536 768 0 0 -256).

	CoffeeCupClink := SoundBuffer fromArray: samples.
! !


!SampledSound class methodsFor: 'default sound' stamp: 'stephaneducasse 2/4/2006 20:41'!
defaultSampleTable: anArray
	"Set the sample table to be used as the default waveform for playing a score such as the Bach fugue. Array is assumed to contain monaural signed 16-bit sample values."

	DefaultSampleTable := SoundBuffer fromArray: anArray.
! !

!SampledSound class methodsFor: 'default sound' stamp: 'stephaneducasse 2/4/2006 20:41'!
defaultSamples: anArray repeated: n

	| data |
	data := WriteStream on: (SoundBuffer newMonoSampleCount: anArray size * n).
	n timesRepeat: [
		anArray do: [:sample | data nextPut: sample truncated]].
	DefaultSampleTable := data contents.
! !

!SampledSound class methodsFor: 'default sound' stamp: 'stephaneducasse 2/4/2006 20:41'!
nominalSamplePitch: aNumber
	"Record an estimate of the normal pitch of the sampled sound."

	NominalSamplePitch := aNumber.
! !

!SampledSound class methodsFor: 'default sound' stamp: 'stephaneducasse 2/4/2006 20:41'!
useCoffeeCupClink
	"Set the sample table to be used as the default waveform to the sound of a coffee cup being tapped with a spoon."
	"SampledSound useCoffeeCupClink bachFugue play"

	DefaultSampleTable := self coffeeCupClink.
	NominalSamplePitch := 400.
! !


!SampledSound class methodsFor: 'instance creation' stamp: 'gk 2/24/2004 08:50'!
beep
	"Beep in the presence of the sound system.
	Not to be used directly - use Beeper class>>beep
	or Beeper class>>beepPrimitive instead."

	(self new
			setSamples: self coffeeCupClink
			samplingRate: 12000) play
			! !

!SampledSound class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
fromAIFFfileNamed: fileName
	"Read a SampledSound from the AIFF file of the given name, merging stereo to mono if necessary."
	"(SampledSound fromAIFFfileNamed: '1.aif') play"
	"| snd |
	 FileDirectory default fileNames do: [:n |
		(n endsWith: '.aif')
			ifTrue: [
				snd := SampledSound fromAIFFfileNamed: n.
				snd play.
				SoundPlayer waitUntilDonePlaying: snd]]."

	| aiffFileReader |
	aiffFileReader := AIFFFileReader new.
	aiffFileReader readFromFile: fileName
		mergeIfStereo: true
		skipDataChunk: false.
	^ self
		samples: (aiffFileReader channelData at: 1)
		samplingRate: aiffFileReader samplingRate
! !

!SampledSound class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
fromWaveFileNamed: fileName
	"(SampledSound fromWaveFileNamed: 'c:\windows\media\chimes.wav') play"
	"| snd fd |
	fd := FileDirectory on:'c:\windows\media\'.
	fd fileNames do: [:n |
		(n asLowercase endsWith: '.wav')
			ifTrue: [
				snd := SampledSound fromWaveFileNamed: (fd pathName,n).
				snd play.
				SoundPlayer waitUntilDonePlaying: snd]]."

	^self fromWaveStream: (FileStream oldFileNamed: fileName)
! !

!SampledSound class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
fromWaveStream: fileStream

	| stream header data type channels samplingRate blockAlign bitsPerSample leftAndRight |
	header := self readWaveChunk: 'fmt ' inRIFF: fileStream.
	data := self readWaveChunk: 'data' inRIFF: fileStream.
	fileStream close.
	stream := ReadStream on: header.
	type := self next16BitWord: false from: stream.
	type = 1 ifFalse: [^ self error:'Unexpected wave format'].
	channels := self next16BitWord: false from: stream.
	(channels < 1 or: [channels > 2])
		ifTrue: [^ self error: 'Unexpected number of wave channels'].
	samplingRate := self next32BitWord: false from: stream.
	stream skip: 4. "skip average bytes per second"
	blockAlign := self next16BitWord: false from: stream.
	bitsPerSample := self next16BitWord: false from: stream.
	(bitsPerSample = 8 or: [bitsPerSample = 16])
		ifFalse: [  "recompute bits per sample"
			bitsPerSample := (blockAlign // channels) * 8].

	bitsPerSample = 8
		ifTrue: [data := self convert8bitUnsignedTo16Bit: data]
		ifFalse: [data := self convertBytesTo16BitSamples: data mostSignificantByteFirst: false].

	channels = 2 ifTrue: [
		leftAndRight := data splitStereo.
		^ MixedSound new
			add: (self samples: leftAndRight first samplingRate: samplingRate) pan: 0.0;
			add: (self samples: leftAndRight last samplingRate: samplingRate) pan: 1.0;
			yourself].

	^ self samples: data samplingRate: samplingRate
! !

!SampledSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 19:20'!
samples: anArrayOf16BitSamples samplingRate: samplesPerSecond
	"Return a SampledSound with the given samples array and sampling rate."

	^ self new setSamples: anArrayOf16BitSamples samplingRate: samplesPerSecond
! !


!SampledSound class methodsFor: 'sound library' stamp: 'stephaneducasse 2/4/2006 20:41'!
addLibrarySoundNamed: aString fromAIFFfileNamed: fileName
	"Add a sound from the given AIFF file to the library."
	"SampledSound
		addLibrarySoundNamed: 'shutterClick'
		fromAIFFfileNamed: '7.aif'"
	"Add all .aif files in the current directory to the sound library:
	| fileNames |
	fileNames := FileDirectory default fileNamesMatching: '*.aif'.
	fileNames do: [:fName |
		SampledSound
			addLibrarySoundNamed: (fName copyUpTo: $.)
			fromAIFFfileNamed: fName]"

	| snd |
	snd := self fromAIFFfileNamed: fileName.
	self addLibrarySoundNamed: aString
		samples: snd samples
		samplingRate: snd originalSamplingRate.
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:41'!
addLibrarySoundNamed: aString samples: sampleData samplingRate: samplesPerSecond
	"Add the given sound to the sound library. The sample data may be either a ByteArray or a SoundBuffer. If the former, it is take to be 8-bit unsigned samples. If the latter, it is taken to be 16 bit signed samples."

	SoundLibrary
		at: aString
		put: (Array with: sampleData with: samplesPerSecond).
! !

!SampledSound class methodsFor: 'sound library' stamp: 'sw 4/14/2003 00:01'!
assimilateSoundsFrom: aDictionary
	"assimilate sounds with new keys from the given dictionary"

	aDictionary associationsDo:
		[:assoc | (SoundLibrary includesKey: assoc key) ifFalse:
			[SoundLibrary add: assoc]]! !

!SampledSound class methodsFor: 'sound library' stamp: 'stephaneducasse 2/4/2006 20:41'!
playSoundNamed: aString
	"Play the sound with given name. Do nothing if there is no sound of that name in the library."
	"SampledSound playSoundNamed: 'croak'"

	| snd |
	snd := self soundNamed: aString.
	snd ifNotNil: [snd play].
	^ snd
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:40'!
putCoffeeCupClinkInSoundLibrary
	"SampledSound putCoffeeCupClinkInSoundLibrary"

	self addLibrarySoundNamed: 'clink'
		samples: self coffeeCupClink
		samplingRate: 11025! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 9/12/97 19:46'!
removeSoundNamed: aString
	"Remove the sound with the given name from the sound library."

	SoundLibrary removeKey: aString ifAbsent: [].
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:06'!
soundLibrary
	"Answer the sound library dictionary."

	^ SoundLibrary
! !

!SampledSound class methodsFor: 'sound library' stamp: 'sw 9/27/2001 14:46'!
soundNamed: aString
	"Answer the sound of the given name, or, if there is no sound of that name, put up an informer so stating, and answer nil"

	"(SampledSound soundNamed: 'shutterClick') play"

	^ self soundNamed: aString ifAbsent:
		[self inform: aString, ' not found in the Sound Library'.
		nil]! !

!SampledSound class methodsFor: 'sound library' stamp: 'stephaneducasse 2/4/2006 20:41'!
soundNamed: aString ifAbsent: aBlock
	"Answer the sound of the given name, or if there is no sound of that name, answer the result of evaluating aBlock"
	"(SampledSound soundNamed: 'shutterClick') play"

	| entry samples |
	entry := SoundLibrary
		at: aString
		ifAbsent:
			[^ aBlock value].
	entry ifNil: [^ aBlock value].
	samples := entry at: 1.
	samples class isBytes ifTrue: [samples := self convert8bitSignedTo16Bit: samples].
	^ self samples: samples samplingRate: (entry at: 2)
! !

!SampledSound class methodsFor: 'sound library' stamp: 'stephaneducasse 2/4/2006 20:41'!
soundNames
	"Answer a list of sound names for the sounds stored in the sound library."
	"| s |
	 SampledSound soundNames asSortedCollection do: [:n |
		n asParagraph display.
		s := SampledSound soundNamed: n.
		s ifNotNil: [s playAndWaitUntilDone]]"

	^ SoundLibrary keys asArray
! !

!SampledSound class methodsFor: 'sound library' stamp: 'sw 4/13/2003 20:58'!
universalSoundKeys
	"Answer a list of the sound-names that are expected to be found in the SoundLibrary of every image."

	^ #('splash' 'peaks' 'clink' 'croak' 'scratch' 'chirp' 'scritch' 'warble' 'scrape' 'camera' 'coyote' 'silence' 'motor')

! !

!SampledSound class methodsFor: 'sound library' stamp: 'stephaneducasse 2/4/2006 20:41'!
unusedSoundNameLike: desiredName
	"Pick an unused sound name based on the given string. If necessary, append digits to avoid name conflicts with existing sounds."
	"SampledSound unusedSoundNameLike: 'chirp'"

	| newName i |
	newName := desiredName.
	i := 2.
	[SoundLibrary includesKey: newName] whileTrue: [
		newName := desiredName, i printString.
		i := i + 1].
	^ newName
! !


!SampledSound class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
convert8bitSignedFrom: aByteArray to16Bit: aSoundBuffer
	"Copy the contents of the given array of signed 8-bit samples into the given array of 16-bit signed samples."

	| n s |
	<primitive: 'primitiveConvert8BitSigned' module: 'MiscPrimitivePlugin'>
	self var: #aByteArray declareC: 'unsigned char *aByteArray'.
	self var: #aSoundBuffer declareC: 'unsigned short *aSoundBuffer'.
	n := aByteArray size.
	1 to: n do: [:i |
		s := aByteArray at: i.
		s > 127
			ifTrue: [aSoundBuffer at: i put: ((s - 256) bitShift: 8)]
			ifFalse: [aSoundBuffer at: i put: (s bitShift: 8)]].
! !

!SampledSound class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
convert8bitSignedTo16Bit: aByteArray
	"Convert the given array of samples--assumed to be 8-bit signed, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed AIFF sound data."

	| result |
	result := SoundBuffer newMonoSampleCount: aByteArray size.
	self convert8bitSignedFrom: aByteArray to16Bit: result.
	^ result
! !

!SampledSound class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
convert8bitUnsignedTo16Bit: anArray
	"Convert the given array of samples--assumed to be 8-bit unsigned, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed WAVE sound data."

	| n samples s |
	n := anArray size.
	samples := SoundBuffer newMonoSampleCount: n.
	1 to: n do: [:i |
		s := anArray at: i.
		samples at: i put: (s - 128 * 256)].
	^ samples
! !

!SampledSound class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
convertBytesTo16BitSamples: aByteArray mostSignificantByteFirst: msbFirst
	"Convert the given ByteArray (with the given byte ordering) into 16-bit sample buffer."

	| n data src b1 b2 w |
	n := aByteArray size // 2.
	data := SoundBuffer newMonoSampleCount: n.
	src := 1.
	1 to: n do: [:i |
		b1 := aByteArray at: src.
		b2 := aByteArray at: src + 1.
		msbFirst
			ifTrue: [w := (b1 bitShift: 8) + b2]
			ifFalse: [w := (b2 bitShift: 8) + b1].
		w > 32767 ifTrue: [w := w - 65536].
		data at: i put: w.
		src := src + 2].
	^ data
! !

!SampledSound class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
uLawDecode: aByteArray
	"Convert the given array of uLaw-encoded 8-bit samples into a SoundBuffer of 16-bit signed samples."

	| n out decodingTable |
	n := aByteArray size.
	out := SoundBuffer newMonoSampleCount: n.
	decodingTable := self uLawDecodeTable.
	1 to: n do: [:i | out at: i put: (decodingTable at: (aByteArray at: i) + 1)].
	^ out
! !

!SampledSound class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
uLawDecodeTable
	"Return a 256 entry table to be used to decode 8-bit uLaw-encoded samples."
	"Details: This table was computed as follows:
		| d encoded lastEncodedPos lastEncodedNeg |
		d := Array new: 256.
		lastEncodedPos := nil.
		lastEncodedNeg := nil.
		4095 to: 0 by: -1 do: [:s |
			encoded := SampledSound uLawEncodeSample: s.
			lastEncodedPos = encoded
				ifFalse: [
					d at: (encoded + 1) put: (s bitShift: 3).
					lastEncodedPos := encoded].
			encoded := encoded bitOr: 16r80.
			lastEncodedNeg = encoded
				ifFalse: [
					d at: (encoded + 1) put: (s bitShift: 3) negated.
					lastEncodedNeg := encoded]].
		d "

	^ #(32760 31608 30584 29560 28536 27512 26488 25464 24440 23416 22392 21368 20344 19320 18296 17272 16248 15736 15224 14712 14200 13688 13176 12664 12152 11640 11128 10616 10104 9592 9080 8568 8056 7800 7544 7288 7032 6776 6520 6264 6008 5752 5496 5240 4984 4728 4472 4216 3960 3832 3704 3576 3448 3320 3192 3064 2936 2808 2680 2552 2424 2296 2168 2040 1912 1848 1784 1720 1656 1592 1528 1464 1400 1336 1272 1208 1144 1080 1016 952 888 856 824 792 760 728 696 664 632 600 568 536 504 472 440 408 376 360 344 328 312 296 280 264 248 232 216 200 184 168 152 136 120 112 104 96 88 80 72 64 56 48 40 32 24 16 8 0 -32760 -31608 -30584 -29560 -28536 -27512 -26488 -25464 -24440 -23416 -22392 -21368 -20344 -19320 -18296 -17272 -16248 -15736 -15224 -14712 -14200 -13688 -13176 -12664 -12152 -11640 -11128 -10616 -10104 -9592 -9080 -8568 -8056 -7800 -7544 -7288 -7032 -6776 -6520 -6264 -6008 -5752 -5496 -5240 -4984 -4728 -4472 -4216 -3960 -3832 -3704 -3576 -3448 -3320 -3192 -3064 -2936 -2808 -2680 -2552 -2424 -2296 -2168 -2040 -1912 -1848 -1784 -1720 -1656 -1592 -1528 -1464 -1400 -1336 -1272 -1208 -1144 -1080 -1016 -952 -888 -856 -824 -792 -760 -728 -696 -664 -632 -600 -568 -536 -504 -472 -440 -408 -376 -360 -344 -328 -312 -296 -280 -264 -248 -232 -216 -200 -184 -168 -152 -136 -120 -112 -104 -96 -88 -80 -72 -64 -56 -48 -40 -32 -24 -16 -8 0)
! !

!SampledSound class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
uLawEncode: anArray
	"Convert the given array of 16-bit signed samples into a ByteArray of uLaw-encoded 8-bit samples."

	| n out s |
	n := anArray size.
	out := ByteArray new: n.
	1 to: n do: [:i |
		s := anArray at: i.
		s := s bitShift: -3.  "drop 4 least significant bits"
		s < 0
			ifTrue: [s := (self uLawEncodeSample: s negated) bitOr: 16r80]
			ifFalse: [s := (self uLawEncodeSample: s)].
		out at: i put: s].
	^ out
! !

!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 15:40'!
uLawEncodeSample: s
	"Encode the given 16-bit signed sample using the uLaw 8-bit encoding."

	s < 496 ifTrue: [
		s < 112 ifTrue: [
			s < 48 ifTrue: [
				s < 16
					ifTrue: [^ 16r70 bitOr: (15 - s)]
					ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]].
			^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))].
		s < 240
			ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))]
			ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]].

	s < 2032 ifTrue: [
		s < 1008
			ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))]
			ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]].

	s < 4080
		ifTrue: [^ 15 - ((s - 2032) bitShift: -7)]
		ifFalse: [^ 0].
! !


!SampledSound class methodsFor: 'WAV reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
next16BitWord: msbFirst from: stream
	"Read a 16-bit positive integer from the input stream."
	"Assume: Stream has at least two bytes left."

	| n |
	n := stream next: 2.
	^msbFirst
		ifTrue:[(n at: 1) * 256 + (n at: 2)]
		ifFalse:[(n at: 2) * 256 + (n at: 1)]
! !

!SampledSound class methodsFor: 'WAV reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
next32BitWord: msbFirst from: stream
	"Read a 32-bit positive integer from the input stream."
	"Assume: Stream has at least four bytes left."

	| n |
	n := stream next: 4.
	^msbFirst
		ifTrue:[(n at: 1) * 256 + (n at: 2) * 256 + (n at: 3) * 256 + (n at: 4)]
		ifFalse:[(n at: 4) * 256 + (n at: 3) * 256 + (n at: 2) * 256 + (n at: 1)]
! !

!SampledSound class methodsFor: 'WAV reading' stamp: 'stephaneducasse 2/4/2006 20:41'!
readWaveChunk: chunkType inRIFF: stream
	"Search the stream for a format chunk of the given type and return its contents."

	| id count |
	stream reset; binary.
	stream skip: 8.  "skip 'RIFF' and total length"
	id := (stream next: 4) asString.  "contents type"
	id = 'WAVE' ifFalse: [^ ''].     "content type must be WAVE"

	"search for a chunk of the given type"
	[id := (stream next: 4) asString.
	 count := self next32BitWord: false from: stream.
	 id = chunkType] whileFalse: [
		"skip this chunk, rounding length up to a word boundary"
		stream skip: (count + 1 bitAnd: 16rFFFFFFFE).
		stream atEnd ifTrue: [^ '']].

	^ stream next: count  "return raw chunk data"
! !
RectangleMorph subclass: #ScaleMorph
	instanceVariableNames: 'caption start stop minorTick minorTickLength majorTick majorTickLength tickPrintBlock labelsAbove captionAbove'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!ScaleMorph commentStamp: '<historical>' prior: 0!
Rewrite of ScaleMorph - March 2000 (Russell Swan). Added accessors. Added two Booleans, labelsAbove and captionAbove. Determines where the labels and captions print, if they exist. Tick marks can either go up or down. For ticks going up, put in majorTickLength > 0. Negative value will make ticks go down. Examples on Class side.!


!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:41'!
caption
	^ caption.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:42'!
caption: aString
	caption _ aString.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/16/2000 00:38'!
captionAbove: aBoolean 
	captionAbove _ aBoolean! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/16/2000 00:38'!
labelsAbove: aBoolean
	labelsAbove _ aBoolean.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:46'!
majorTickLength: anInteger 
	majorTickLength _ anInteger! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:46'!
minorTickLength: anInteger
	minorTickLength _ anInteger.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:43'!
start: aNumber
	start _ aNumber.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:44'!
stop: aNumber
	stop _ aNumber.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:47'!
tickPrintBlock: aBlock
	tickPrintBlock _ aBlock.! !


!ScaleMorph methodsFor: 'drawing' stamp: 'gm 2/28/2003 00:14'!
buildLabels
	| scale x1 y1 y2 x captionMorph tickMorph loopStart offset |
	majorTickLength * minorTickLength < 0 
		ifTrue: [minorTickLength := 0 - minorTickLength].
	self removeAllMorphs.
	caption ifNotNil: 
			[captionMorph := StringMorph contents: caption.
			offset := captionAbove 
				ifTrue: [majorTickLength abs + captionMorph height + 7]
				ifFalse: [2].
			captionMorph align: captionMorph bounds bottomCenter
				with: self bounds bottomCenter - (0 @ offset).
			self addMorph: captionMorph].
	tickPrintBlock ifNotNil: 
			["Calculate the offset for the labels, depending on whether or not 
			  1) there's a caption   
			below, 2) the labels are above or below the ticks, and 3) the   
			ticks go up or down"

			offset := labelsAbove 
						ifTrue: [majorTickLength abs + minorTickLength abs + 2]
						ifFalse: [2].
			caption 
				ifNotNil: [captionAbove ifFalse: [offset := offset + captionMorph height + 2]].
			scale := (self innerBounds width - 1) / (stop - start) asFloat.
			x1 := self innerBounds left.
			y1 := self innerBounds bottom.
			y2 := y1 - offset.
			"Start loop on multiple of majorTick"
			loopStart := (start / majorTick) ceiling * majorTick.
			loopStart to: stop
				by: majorTick
				do: 
					[:v | 
					x := x1 + (scale * (v - start)).
					tickMorph := StringMorph contents: (tickPrintBlock value: v).
					tickMorph align: tickMorph bounds bottomCenter with: x @ y2.
					tickMorph left < self left 
						ifTrue: [tickMorph position: self left @ tickMorph top].
					tickMorph right > self right 
						ifTrue: [tickMorph position: (self right - tickMorph width) @ tickMorph top].
					self addMorph: tickMorph]]! !

!ScaleMorph methodsFor: 'drawing' stamp: 'aoy 2/15/2003 21:15'!
drawMajorTicksOn: aCanvas 
	| scale x1 y1 y2 x y3 even yy loopStart checkStart yoffset randomLabel |
	scale := (self innerBounds width - 1) / (stop - start) asFloat.
	yoffset := majorTickLength < 0 
		ifTrue: [ majorTickLength abs + 1]
		ifFalse: [1].
	caption ifNotNil: 
			[captionAbove 
				ifFalse: 
					[randomLabel := StringMorph contents: 'Foo'.
					yoffset := yoffset + randomLabel height + 2]].
	tickPrintBlock ifNotNil: 
			[labelsAbove 
				ifFalse: 
					[randomLabel := StringMorph contents: '50'.
					yoffset := yoffset + randomLabel height + 2]].
	x1 := self innerBounds left.
	y1 := self innerBounds bottom - yoffset.
	y2 := y1 - majorTickLength.
	y3 := y1 - ((minorTickLength + majorTickLength) // 2).
	even := true.
	"Make sure major ticks start drawing on a multiple of majorTick"
	loopStart := (start / majorTick) ceiling * majorTick.
	checkStart := (start / (majorTick / 2.0)) ceiling * majorTick.
	"Check to see if semimajor tick should be drawn before majorTick"
	checkStart = (loopStart * 2) 
		ifFalse: 
			[loopStart := checkStart / 2.0.
			even := false].
	loopStart to: stop
		by: majorTick / 2.0
		do: 
			[:v | 
			x := x1 + (scale * (v - start)).
			yy := even ifTrue: [y2] ifFalse: [y3].
			aCanvas 
				line: x @ y1
				to: x @ yy
				width: 1
				color: Color black.
			even := even not]! !

!ScaleMorph methodsFor: 'drawing' stamp: 'aoy 2/15/2003 21:16'!
drawMinorTicksOn: aCanvas 
	| scale x1 y1 y2 x loopStart yoffset randomLabel |
	scale := (self innerBounds width - 1) / (stop - start) asFloat.
	yoffset := majorTickLength < 0 
				ifTrue: [majorTickLength abs + 1]
				ifFalse: [1]. 
	caption ifNotNil: 
			[captionAbove 
				ifFalse: 
					[randomLabel := StringMorph contents: 'Foo'.
					yoffset := yoffset + randomLabel height + 2]].
	tickPrintBlock ifNotNil: 
			[labelsAbove 
				ifFalse: 
					[randomLabel := StringMorph contents: '50'.
					yoffset := yoffset + randomLabel height + 2]].
	x1 := self innerBounds left.
	y1 := self innerBounds bottom - yoffset.
	y2 := y1 - minorTickLength.
	loopStart := (start / minorTick) ceiling * minorTick.
	loopStart to: stop
		by: minorTick
		do: 
			[:v | 
			x := x1 + (scale * (v - start)).
			aCanvas 
				line: x @ y1
				to: x @ y2
				width: 1
				color: Color black]! !

!ScaleMorph methodsFor: 'drawing' stamp: 'RCS 3/15/2000 21:36'!
drawOn: aCanvas 
	| |
	super drawOn: aCanvas.
	
	self drawTicksOn: aCanvas.! !

!ScaleMorph methodsFor: 'drawing' stamp: 'RCS 3/16/2000 14:19'!
drawTicksOn: aCanvas 
	self drawMajorTicksOn: aCanvas.
	self drawMinorTicksOn: aCanvas! !


!ScaleMorph methodsFor: 'geometry' stamp: 'RCS 3/16/2000 13:58'!
checkExtent: newExtent 
	| pixPerTick newWidth |
	pixPerTick _ newExtent x - (self borderWidth * 2) - 1 / ((stop - start) asFloat / minorTick).
	pixPerTick _ pixPerTick
				detentBy: 0.1
				atMultiplesOf: 1.0
				snap: false.
	newWidth _ pixPerTick * ((stop - start) asFloat / minorTick) + (self borderWidth * 2) + 1.
	^ (newWidth @ newExtent y).! !

!ScaleMorph methodsFor: 'geometry' stamp: 'RCS 3/16/2000 13:59'!
extent: newExtent 
	| modExtent |
	modExtent _ self checkExtent: newExtent.
	super extent: modExtent.
	self buildLabels! !


!ScaleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 0! !

!ScaleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGreen! !

!ScaleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:00'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	start _ 0.
	stop _ 100.
	minorTick _ 1.
	majorTick _ 10.
	minorTickLength _ 3.
	majorTickLength _ 10.
	caption _ nil.
	tickPrintBlock _ [:v | v printString].
	labelsAbove _ true.
	captionAbove _ true! !

!ScaleMorph methodsFor: 'initialization' stamp: 'RCS 3/16/2000 14:55'!
start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen

	self start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen caption: nil tickPrintBlock: nil
	! !

!ScaleMorph methodsFor: 'initialization' stamp: 'RCS 3/16/2000 14:54'!
start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen caption: cap tickPrintBlock: blk 
	self start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen caption: cap tickPrintBlock: blk labelsAbove: true captionAbove: true.
	! !

!ScaleMorph methodsFor: 'initialization' stamp: 'RCS 3/16/2000 15:09'!
start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen caption: cap tickPrintBlock: blk labelsAbove: aBoolean captionAbove: notherBoolean 
	start _ strt.
	stop _ stp.
	minorTick _ mnt.
	minorTickLength _ mntLen.
	majorTick _ mjt.
	majorTickLength _ mjtLen.
	caption _ cap.
	tickPrintBlock _ blk.
	labelsAbove _ aBoolean.
	captionAbove _ notherBoolean.
	self buildLabels! !


!ScaleMorph methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:49'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	labelsAbove ifNil: [labelsAbove _ true].
	captionAbove ifNil: [captionAbove _ true].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !


!ScaleMorph methodsFor: 'stepping and presenter' stamp: 'RCS 3/15/2000 21:43'!
start
	^ start! !

!ScaleMorph methodsFor: 'stepping and presenter' stamp: 'RCS 3/15/2000 21:43'!
stop
	^ stop! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScaleMorph class
	instanceVariableNames: ''!

!ScaleMorph class methodsFor: 'examples' stamp: 'sma 3/24/2000 12:09'!
example1
	"Example 1 captions and labels above, ticks point up"
	^ (self new
		start: 0
		stop: 150
		minorTick: 1
		minorTickLength: 2
		majorTick: 10
		majorTickLength: 10
		caption: 'Example 1'
		tickPrintBlock: [:v | v printString];
		width: 300) openInWorld! !

!ScaleMorph class methodsFor: 'examples' stamp: 'sma 3/24/2000 12:09'!
example2
	"Example 2 captions and labels above, ticks point down"
	^ (self new
		start: 0
		stop: 150
		minorTick: 1
		minorTickLength: 2
		majorTick: 10
		majorTickLength: -10
		caption: 'Example 2'
		tickPrintBlock: [:v | v printString];
		width: 300) openInWorld! !

!ScaleMorph class methodsFor: 'examples' stamp: 'sma 3/24/2000 12:11'!
example3
	"Example 3 caption above, labels below, ticks point down"
	^ (self new
		start: -23
		stop: 47
		minorTick: 1
		minorTickLength: 2
		majorTick: 10
		majorTickLength: -10
		caption: 'Example 3'
		tickPrintBlock: [:v | v printString]
		labelsAbove: false
		captionAbove: true;
		color: Color lightBlue;
		width: 300) openInWorld! !

!ScaleMorph class methodsFor: 'examples' stamp: 'sma 3/24/2000 12:10'!
example4
	"Example 4 caption below, labels above, ticks point up"
	^ (self new
		start: 100000
		stop: 300000
		minorTick: 5000
		minorTickLength: 2
		majorTick: 50000
		majorTickLength: 10
		caption: 'Example 4'
		tickPrintBlock: [:v | '$' , v printString]
		labelsAbove: true
		captionAbove: false;
		color: Color lightOrange;
		width: 300) openInWorld! !
Number subclass: #ScaledDecimal
	instanceVariableNames: 'fraction scale'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!ScaledDecimal commentStamp: '<historical>' prior: 0!
ScaledDecimal provides a numeric representation of fixed point decimal numbers able to accurately represent decimal fractions.  It supports unbounded precision, with no limit to the number of digits before and after the decimal point.
	ScaledDecimal complies with the ANSI protocols:

	Object
	number
	ScaledDecimal
	????
#todo. "finish protocol list."

Implementation Notes:

	I implemented ScaledDecimal with the decimal fraction stored in instance variables numerator and denominator, and the number of digits after the decimal point in fractionalDigit as a positive Integer.  I implemented operations by first coercing the aurguments to fractions, doing the operations, then coercing the result to the proper numeric representation when necessary and scale.  This is because I assume the Fraction class is more likely to implement them correctly.  

Richard A. Harmon
!


!ScaledDecimal methodsFor: 'arithmetic' stamp: 'AFi 11/23/2002 19:12'!
* operand 
	"Implementation of Number 'arithmetic' method."
	(operand isKindOf: ScaledDecimal) ifTrue: [^ ScaledDecimal newFromNumber: fraction * operand asFraction scale: (scale max: operand scale)].
	^ operand adaptToScaledDecimal: self andSend: #*! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: 'AFi 11/23/2002 19:12'!
+ operand 
	"Implementation of Number 'arithmetic' method."
	(operand isKindOf: ScaledDecimal) ifTrue: [^ ScaledDecimal newFromNumber: fraction + operand asFraction scale: (scale max: operand scale)].
	^ operand adaptToScaledDecimal: self andSend: #+! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: 'AFi 11/23/2002 19:12'!
- operand 
	"Implementation of Number 'arithmetic' method."
	(operand isKindOf: ScaledDecimal) ifTrue: [^ ScaledDecimal newFromNumber: fraction - operand asFraction scale: (scale max: operand scale)].
	^ operand adaptToScaledDecimal: self andSend: #-! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: 'AFi 11/23/2002 19:12'!
/ operand 
	"Implementation of Number 'arithmetic' method."
	#ScalDec.
	"Protocol: ANSI <number>."
	operand = 0 ifTrue: [^ (ZeroDivide dividend: self) signal].
	(operand isKindOf: ScaledDecimal) ifTrue: [^ ScaledDecimal newFromNumber: fraction / operand asFraction scale: (scale max: operand scale)].
	^ operand adaptToScaledDecimal: self andSend: #/! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'!
// operand 
	"Answer the integer quotient after dividing the receiver by operand 
	with truncation towards negative infinity."
	^ fraction // operand! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'!
negated
	"Reimplementation of Number 'arithmetic' method."
	^ ScaledDecimal newFromNumber: fraction negated scale: scale! !

!ScaledDecimal methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'!
reciprocal
	"Reimplementation of Number 'arithmetic' method."
	self = 0 ifTrue: [^ (ZeroDivide dividend: 1) signal].
	^ ScaledDecimal newFromNumber: fraction reciprocal scale: scale! !


!ScaledDecimal methodsFor: 'comparing' stamp: 'AFi 11/23/2002 19:12'!
< operand 
	"Implementation of Number 'comparing' method."
	(operand isKindOf: ScaledDecimal) ifTrue: [^ fraction < operand asFraction].
	^ operand adaptToScaledDecimal: self andSend: #<! !

!ScaledDecimal methodsFor: 'comparing' stamp: 'AFi 11/23/2002 19:13'!
= comparand 
	"Implementation of Number 'comparing' method."
	comparand isNumber ifFalse: [^ false].
	(comparand isKindOf: ScaledDecimal) ifTrue: [^ fraction = comparand asFraction].
	^ comparand adaptToScaledDecimal: self andSend: #=! !

!ScaledDecimal methodsFor: 'comparing' stamp: 'RAH 4/25/2000 19:49'!
hash
	"Reimplementation of Object 'comparing' method."
	^ fraction hash! !

!ScaledDecimal methodsFor: 'comparing' stamp: 'RAH 4/25/2000 19:49'!
isZero
	"Answer whether the receiver is equal to its class' zero"
	^ fraction numerator = 0! !


!ScaledDecimal methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
adaptToFraction: receiver andSend: arithmeticOpSelector 
	"Convert me to a Fraction and do the arithmetic. 
	receiver arithmeticOpSelector self."
	^ receiver perform: arithmeticOpSelector with: fraction! !

!ScaledDecimal methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
adaptToInteger: receiver andSend: arithmeticOpSelector 
	"Convert receiver to a ScaledDecimal and do the arithmetic. 
	receiver arithmeticOpSelector self."
	^ (receiver asScaledDecimal: 0)
		perform: arithmeticOpSelector with: self! !

!ScaledDecimal methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asFloat
	"Reimplementation - Number 'converting' method."
	^ fraction asFloat! !

!ScaledDecimal methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asFraction
	"Implementation - Number 'converting' method."
	^ fraction! !

!ScaledDecimal methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asScaledDecimal: scaleIn 
	"Reimplementation - Number 'converting' method."
	^ ScaledDecimal newFromNumber: fraction scale: scaleIn! !

!ScaledDecimal methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'!
asSpecies: number 
	"Convert number to a ScaledDecimal."
	#Numeric.
	"add 200/01/19 For ANSI <number>support."
	^ ScaledDecimal newFromNumber: number scale: scale! !


!ScaledDecimal methodsFor: 'mathematical functions' stamp: 'RAH 4/25/2000 19:49'!
squared
	"Reimplementation - Number 'mathematical functions' method."
	"not used ->"
	^ ScaledDecimal newFromNumber: fraction squared scale: scale! !


!ScaledDecimal methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'!
printOn: aStream 
	"Reimplementation - Object 'printing' method."
	| aFraction tmpFractionPart |
	self < 0 ifTrue: [aStream nextPut: $-].
	aFraction := fraction abs.
	aStream nextPutAll: aFraction truncated printString.
	scale = 0 ifTrue: [^ aStream nextPutAll: 's0'].
	aStream nextPut: $..
	tmpFractionPart := aFraction fractionPart.
	1 to: scale
		do: 
			[:dummy | 
			tmpFractionPart := tmpFractionPart * 10.
			aStream nextPut: (Character digitValue: tmpFractionPart truncated).
			tmpFractionPart := tmpFractionPart fractionPart].
	aStream nextPut: $s.
	scale printOn: aStream! !

!ScaledDecimal methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'!
printString
	"Reimplementation - Number 'printing' method."
	| tempStream |
	tempStream := WriteStream on: (String new: 10).
	self printOn: tempStream.
	^ tempStream contents! !


!ScaledDecimal methodsFor: 'testing' stamp: 'RAH 4/25/2000 19:49'!
isScaledDecimal
	"Reimplementation - Number 'testing' method."
	^ true! !


!ScaledDecimal methodsFor: 'truncation and round off' stamp: 'RAH 4/25/2000 19:49'!
fractionPart
	"Answer the fractional part of the receiver."
	^ ScaledDecimal newFromNumber: fraction fractionPart scale: scale! !

!ScaledDecimal methodsFor: 'truncation and round off' stamp: 'RAH 4/25/2000 19:49'!
integerPart
	"Answer the fractional part of the receiver."
	^ ScaledDecimal newFromNumber: fraction integerPart scale: scale! !

!ScaledDecimal methodsFor: 'truncation and round off' stamp: 'RAH 4/25/2000 19:49'!
truncated
	"Reimplementation of Number 'truncation and round off' method."
	^ fraction truncated! !


!ScaledDecimal methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'!
denominator
	"Private - Answer an Integer, the denominator part of the receiver."
	^ fraction denominator! !

!ScaledDecimal methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'!
numerator
	"Private - Answer an Integer, the numerator part of the receiver."
	^ fraction numerator! !

!ScaledDecimal methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'!
scale
	"Private - Answer a integer which represents the total number of digits 
	used to represent the fraction part of the receiver, including trailing 
	zeroes. "
	^ scale! !

!ScaledDecimal methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'!
setFraction: fractionIn scale: scaleIn 
	"Private - Set the fraction to fractionIn and the total number of digits 
	used to represent the fraction part of the receiver, including trailing 
	zeroes, to the Integer scaleIn."
	fraction := fractionIn.
	scale := scaleIn! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScaledDecimal class
	instanceVariableNames: ''!

!ScaledDecimal class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'!
one
	"Answer the receiver's representation of one."
	^ self newFromNumber: 1 scale: 0! !

!ScaledDecimal class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'!
zero
	"Answer the receiver's representation of zero."
	^ self newFromNumber: 0 scale: 0! !


!ScaledDecimal class methodsFor: 'instance creation' stamp: 'RAH 4/25/2000 19:49'!
newFromNumber: aNumber scale: scaleIn 
	"Answer a new instance of me."
	| temp |
	temp := self basicNew.
	temp setFraction: aNumber asFraction scale: scaleIn.
	^ temp! !
ClassTestCase subclass: #ScaledDecimalTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!
!ScaledDecimalTest commentStamp: '<historical>' prior: 0!
I provide a test suite for ScaledDecimal values. Examine my tests to see how SmallIntegers should behave, and see how to use them.!


!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:22'!
testAsNumber
	"Ensure no loss of precision"

	| sd |
	sd _ '1.40s2' asNumber.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 2.
	self assert: '1.40s2' = sd printString.
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 15:51'!
testAsNumberNegatedWithoutDecimalPoint

	| sd |
	sd _ '-123s0' asNumber.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 0.
	self assert: '-123s0' = sd printString.
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 15:51'!
testAsNumberNegatedWithoutDecimalPoint2

	| sd |
	sd _ '-123s2' asNumber.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 2.
	self assert: '-123.00s2' = sd printString.
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:21'!
testAsNumberWithExtendedScale

	| sd |
	sd _ '123s2' asNumber.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 2.
	self assert: '123.00s2' = sd printString.
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 15:49'!
testAsNumberWithoutDecimalPoint

	| sd |
	sd _ '123s0' asNumber.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 0.
	self assert: '123s0' = sd printString.
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 15:51'!
testAsNumberWithoutDecimalPoint2

	| sd |
	sd _ '123s2' asNumber.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 2.
	self assert: '123.00s2' = sd printString.
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:28'!
testAsNumberWithRadix

	| sd |
	sd _ '10r-22.2s5' asNumber.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 5.
	self assert: '-22.20000s5' = sd printString.
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:20'!
testAsNumberWithSuperfluousDecimalPoint

	| sd |
	sd _ '123.s2' asNumber.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 2.
	self assert: '123.00s2' = sd printString.

! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:04'!
testConvertFromFloat

	| aFloat sd f2 diff |
	aFloat _ 11/13 asFloat.
	sd _ aFloat asScaledDecimal: 2.
	self assert: 2 == sd scale.
	self assert: '0.84s2' = sd printString.
	f2 _ sd asFloat.
	diff _ f2 - aFloat.
	self assert: diff < 1.0e-9. "actually, f = f2, but this is not a requirement"
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:24'!
testConvertFromFraction

	| sd |
	sd _ (13 / 11) asScaledDecimal: 6.
	self assert: ScaledDecimal == sd class.
	self assert: ('1.181818s6' = sd printString).
	self assert: 6 == sd scale
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 11:06'!
testConvertFromInteger
	"Converting an Integer to a ScaledDecimal yields a ScaledDecimal with
	scale 0, regardless of the scale specified in the #asScaledDecimal: message."

	| sd |
	sd _ 13 asScaledDecimal: 6.
	self assert: 0 = sd scale.
	self assert: ('13s0' = sd printString).
	sd _ -13 asScaledDecimal: 6.
	self assert: 0 = sd scale.
	self assert: ('-13s0' = sd printString).
	sd _ 130000000013 asScaledDecimal: 6.
	self assert: 0 = sd scale.
	self assert: ('130000000013s0' = sd printString).
	sd _ -130000000013 asScaledDecimal: 6.
	self assert: 0 = sd scale.
	self assert: ('-130000000013s0' = sd printString)
! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 13:38'!
testLiteral

	| sd |
	sd _ 1.40s2.
	self assert: ScaledDecimal == sd class.
	self assert: sd scale == 2.
	self assert: '1.40s2' = sd printString! !

!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 11:51'!
testPrintString
	"The printed representation of a ScaledDecimal is truncated, not rounded.
	Not sure if this is right, so this test describes the current Squeak implementation.
	If someone knows a reason that rounding would be preferable, then update
	this test."

	| sd |
	sd _ (13 / 11) asScaledDecimal: 6.
	self assert: ('1.181818s6' = sd printString).
	sd _ (13 / 11) asScaledDecimal: 5.
	self deny: ('1.18182s5' = sd printString).
	sd _ (13 / 11) asScaledDecimal: 5.
	self assert: ('1.18181s5' = sd printString)
! !
Object subclass: #Scanner
	instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable'
	classVariableNames: 'TypeTable'
	poolDictionaries: ''
	category: 'Compiler-Kernel'!
!Scanner commentStamp: '<historical>' prior: 0!
I scan a string or text, picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into the instance variable, token, and its type (a Symbol) into the variable, tokenType. At the end of the input stream, I pretend to see an endless sequence of special characters called doits.!


!Scanner methodsFor: 'error handling' stamp: 'yo 8/28/2002 17:43'!
errorMultibyteCharacter

	self error: 'multi-byte character is found at unexpected place'.
! !

!Scanner methodsFor: 'error handling'!
notify: string 
	"Refer to the comment in Object|notify:." 
	self error: string! !

!Scanner methodsFor: 'error handling'!
offEnd: aString 
	"Parser overrides this"

	^self notify: aString! !


!Scanner methodsFor: 'expression types'!
advance

	| prevToken |
	prevToken _ token.
	self scanToken.
	^prevToken! !

!Scanner methodsFor: 'expression types' stamp: 'di 4/23/2000 22:15'!
checkpoint
	"Return a copy of all changeable state.  See revertToCheckpoint:"

	^ {self clone. source clone. currentComment copy}! !

!Scanner methodsFor: 'expression types'!
nextLiteral
	"Same as advance, but -4 comes back as a number instead of two tokens"

	| prevToken |
	prevToken _ self advance.
	(prevToken == #- and: [token isKindOf: Number])
		ifTrue: 
			[^self advance negated].
	^prevToken! !

!Scanner methodsFor: 'expression types' stamp: 'di 4/23/2000 22:11'!
revertToCheckpoint: checkpoint
	"Revert to the state when checkpoint was made."

	| myCopy |
	myCopy _ checkpoint first.
	1 to: self class instSize do:
		[:i | self instVarAt: i put: (myCopy instVarAt: i)].
	source _ checkpoint second.
	currentComment _ checkpoint third! !

!Scanner methodsFor: 'expression types' stamp: 'yo 7/2/2004 14:04'!
scanLitVec

	| s |
	s _ WriteStream on: (Array new: 16).
	[tokenType = #rightParenthesis or: [tokenType = #doIt]]
		whileFalse: 
			[tokenType = #leftParenthesis
				ifTrue: 
					[self scanToken; scanLitVec]
				ifFalse: 
					[tokenType = #word | (tokenType = #keyword) | (tokenType = #colon)
						ifTrue: 
							[self scanLitWord.
							token = #true ifTrue: [token _ true].
							token = #false ifTrue: [token _ false].
							token = #nil ifTrue: [token _ nil]]
						ifFalse:
							[(token == #- 
									and: [((typeTable at: hereChar charCode ifAbsent: [#xLetter])) = #xDigit])
								ifTrue: 
									[self scanToken.
									token _ token negated]]].
			s nextPut: token.
			self scanToken].
	token _ s contents! !

!Scanner methodsFor: 'expression types' stamp: 'yo 8/28/2002 17:52'!
scanLitWord
	"Accumulate keywords and asSymbol the result."

	| t |
	[(typeTable at: hereChar asciiValue ifAbsent: [#xLetter]) = #xLetter] whileTrue: [
		t _ token.
		self xLetter.
		token _ t , token
	].
	token _ token asSymbol.
! !

!Scanner methodsFor: 'expression types'!
scanStringStruct

	| s |
	s _ WriteStream on: (Array new: 16).
	[tokenType = #rightParenthesis or: [tokenType = #doIt]]
		whileFalse: 
			[tokenType = #leftParenthesis
				ifTrue: 
					[self scanToken; scanStringStruct]
				ifFalse: 
					[tokenType = #word ifFalse:
						[^self error: 'only words and parens allowed']].
			s nextPut: token.
			self scanToken].
	token _ s contents! !

!Scanner methodsFor: 'expression types' stamp: 'yo 8/28/2002 22:21'!
scanToken

	[(tokenType _ typeTable at: hereChar asciiValue ifAbsent: [#xLetter]) == #xDelimiter]
		whileTrue: [self step].  "Skip delimiters fast, there almost always is one."
	mark _ source position - 1.
	(tokenType at: 1) = $x "x as first letter"
		ifTrue: [self perform: tokenType "means perform to compute token & type"]
		ifFalse: [token _ self step asSymbol "else just unique the first char"].
	^ token.
! !

!Scanner methodsFor: 'expression types'!
step

	| c |
	c _ hereChar.
	hereChar _ aheadChar.
	source atEnd
		ifTrue: [aheadChar _ 30 asCharacter "doit"]
		ifFalse: [aheadChar _ source next].
	^c! !


!Scanner methodsFor: 'initialize-release'!
initScanner

	buffer _ WriteStream on: (String new: 40).
	typeTable _ TypeTable! !

!Scanner methodsFor: 'initialize-release'!
scan: inputStream 
	"Bind the input stream, fill the character buffers and first token buffer."

	source _ inputStream.
	self step.
	self step.
	self scanToken! !


!Scanner methodsFor: 'multi-character scans' stamp: 'yo 8/28/2002 17:40'!
xBinary

	tokenType _ #binary.
	token _ self step asSymbol.
	[| type | 
	type _ typeTable at: hereChar asciiValue ifAbsent: [#xLetter].
	type == #xBinary and: [hereChar ~= $-]] whileTrue: [
		token _ (token, (String with: self step)) asSymbol].
! !

!Scanner methodsFor: 'multi-character scans' stamp: 'md 11/14/2003 17:14'!
xColon		"Allow := for assignment by converting to #_ "
	aheadChar = $= ifTrue:
		[self step.
		tokenType _ #leftArrow.
		self step.
		^ token _ #'_'].
	"Otherwise, just do what normal scan of colon would do"
	tokenType _ #colon.
	^ token _ self step asSymbol! !

!Scanner methodsFor: 'multi-character scans'!
xDelimiter
	"Ignore blanks, etc."

	self scanToken! !

!Scanner methodsFor: 'multi-character scans' stamp: 'tao 4/23/98 12:55'!
xDigit
	"Form a number."

	tokenType _ #number.
	(aheadChar = 30 asCharacter and: [source atEnd
			and:  [source skip: -1. source next ~= 30 asCharacter]])
		ifTrue: [source skip: -1 "Read off the end last time"]
		ifFalse: [source skip: -2].
	token _ [Number readFrom: source] ifError: [:err :rcvr | self offEnd: err].
	self step; step! !

!Scanner methodsFor: 'multi-character scans'!
xDollar
	"Form a Character literal."

	self step. "pass over $"
	token _ self step.
	tokenType _ #number "really should be Char, but rest of compiler doesn't know"! !

!Scanner methodsFor: 'multi-character scans' stamp: 'yo 8/28/2002 17:31'!
xDoubleQuote

    "Collect a comment."
    "wod 1/10/98: Allow 'empty' comments by testing the first character
for $"" rather than blindly adding it to the comment being collected."
    | aStream stopChar |
    stopChar _ 30 asCharacter.
    aStream _ WriteStream on: (String new: 200).
    self step.
    [hereChar = $"]
        whileFalse:
            [(hereChar = stopChar and: [source atEnd])
                ifTrue: [^self offEnd: 'Unmatched comment quote'].
            aStream nextPut: self step.].
    self step.
    currentComment == nil
        ifTrue: [currentComment _ OrderedCollection with: aStream
contents]
        ifFalse: [currentComment add: aStream contents].
    self scanToken.
! !

!Scanner methodsFor: 'multi-character scans' stamp: 'yo 8/28/2002 17:33'!
xLetter
	"Form a word or keyword."

	| type c |
	buffer reset.
	[c _ hereChar asciiValue.
	(type _ typeTable at: c ifAbsent: [#xLetter]) == #xLetter or: [type == #xDigit]]
		whileTrue: ["open code step for speed"
			buffer nextPut: hereChar.
			hereChar _ aheadChar.
			source atEnd
				ifTrue: [aheadChar _ 30 asCharacter
					"doit"]
				ifFalse: [aheadChar _ source next]].
	(type == #colon or: [type == #xColon and: [aheadChar ~= $=]])
		ifTrue: [buffer nextPut: self step.
			["Allow any number of embedded colons in literal symbols"
			(typeTable at: hereChar asciiValue ifAbsent: [#xLetter])
				== #xColon]
				whileTrue: [buffer nextPut: self step].
			tokenType _ #keyword]
		ifFalse: [tokenType _ #word].
	token _ buffer contents.
	token isOctetString ifTrue: [token _ token asOctetString].
! !

!Scanner methodsFor: 'multi-character scans' stamp: 'ar 4/10/2005 22:46'!
xLitQuote
	"Symbols and vectors: #(1 (4 5) 2 3) #ifTrue:ifFalse: #'abc'."

	| start |
	start _ mark.
	self step. "litQuote"
	self scanToken.
	tokenType = #leftParenthesis
		ifTrue: 
			[self scanToken; scanLitVec.
			mark _ start+1.
			tokenType == #doIt
				ifTrue: [self offEnd: 'Unmatched parenthesis']]
		ifFalse: 
			[(#(word keyword colon ) includes: tokenType) 
				ifTrue:
					[self scanLitWord]
				ifFalse:
					[(tokenType==#literal)
						ifTrue:
							[(token isSymbol)
								ifTrue: "##word"
									[token _ token "May want to move toward ANSI here"]]
						ifFalse:
							[tokenType==#string ifTrue: [token _ token asSymbol]]]].
	mark _ start.
	tokenType _ #literal

"	#(Pen)
	#Pen
	#'Pen'
	##Pen
	###Pen
"! !

!Scanner methodsFor: 'multi-character scans' stamp: 'yo 8/28/2002 17:43'!
xSingleQuote
	"String."

	self step.
	buffer reset.
	[hereChar = $' and: [aheadChar = $' ifTrue: [self step. false] ifFalse: [true]]] whileFalse: [
		buffer nextPut: self step.
		(hereChar = 30 asCharacter and: [source atEnd])
			ifTrue: [^self offEnd: 'Unmatched string quote']].
	self step.
	token _ buffer contents.
	token isOctetString ifTrue: [token _ token asOctetString].
	tokenType _ #string.
! !


!Scanner methodsFor: 'public access'!
scanFieldNames: stringOrArray
	"Answer an Array of Strings that are the identifiers in the input string, 
	stringOrArray. If passed an Array, just answer with that Array, i.e., 
	assume it has already been scanned."

	| strm |
	(stringOrArray isMemberOf: Array)
		ifTrue: [^stringOrArray].
	self scan: (ReadStream on: stringOrArray asString).
	strm _ WriteStream on: (Array new: 10).
	[tokenType = #doIt]
		whileFalse: 
			[tokenType = #word ifTrue: [strm nextPut: token].
			self scanToken].
	^strm contents

	"Scanner new scanFieldNames: 'abc  def ghi' ('abc' 'def' 'ghi' )"! !

!Scanner methodsFor: 'public access' stamp: 'sw 1/28/2001 23:31'!
scanMessageParts: sourceString
	"Return an array of the form (comment keyword comment arg comment keyword comment arg comment) for the message pattern of this method.  Courtesy of Ted Kaehler, June 1999"

	| coll nonKeywords |
	coll _ OrderedCollection new.
	self scan: (ReadStream on: sourceString asString).
	nonKeywords _ 0.
	[tokenType = #doIt] whileFalse:
		[(currentComment == nil or: [currentComment isEmpty])
			ifTrue: [coll addLast: nil]
			ifFalse: [coll addLast: currentComment removeFirst.
				[currentComment isEmpty] whileFalse:
					[coll at: coll size put: (coll last, ' ', currentComment removeFirst)]].
		(token numArgs < 1 or: [(token = #|) & (coll size > 1)])
			ifTrue: [(nonKeywords _ nonKeywords + 1) > 1 ifTrue: [^ coll]]
						"done with header"
			ifFalse: [nonKeywords _ 0].
		coll addLast: token.
		self scanToken].
	(currentComment == nil or: [currentComment isEmpty])
		ifTrue: [coll addLast: nil]
		ifFalse: [coll addLast: currentComment removeFirst.
			[currentComment isEmpty] whileFalse: [
				coll at: coll size put: (coll last, ' ', currentComment removeFirst)]].
	^ coll! !

!Scanner methodsFor: 'public access'!
scanStringStruct: textOrString 
	"The input is a string whose elements are identifiers and parenthesized
	 groups of identifiers.  Answer an array reflecting that structure, representing
	 each identifier by an uninterned string."

	self scan: (ReadStream on: textOrString asString).
	self scanStringStruct.
	^token

	"Scanner new scanStringStruct: 'a b (c d) (e f g)'"! !

!Scanner methodsFor: 'public access'!
scanTokens: textOrString 
	"Answer an Array that has been tokenized as though the input text, 
	textOrString, had appeared between the array delimitors #( and ) in a 
	Smalltalk literal expression."

	self scan: (ReadStream on: textOrString asString).
	self scanLitVec.
	^token

	"Scanner new scanTokens: 'identifier keyword: 8r31 ''string'' .'"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Scanner class
	instanceVariableNames: ''!

!Scanner class methodsFor: 'class initialization' stamp: 'dgd 8/24/2003 14:55'!
initialize
	| newTable |
	newTable _ Array new: 256 withAll: #xBinary. "default"
	newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space"
	newTable atAll: ($0 asciiValue to: $9 asciiValue) put: #xDigit.

	1 to: 255
		do: [:index |
			(Character value: index) isLetter
				ifTrue: [newTable at: index put: #xLetter]].

	newTable at: 30 put: #doIt.
	newTable at: $" asciiValue put: #xDoubleQuote.
	newTable at: $# asciiValue put: #xLitQuote.
	newTable at: $$ asciiValue put: #xDollar.
	newTable at: $' asciiValue put: #xSingleQuote.
	newTable at: $: asciiValue put: #xColon.
	newTable at: $( asciiValue put: #leftParenthesis.
	newTable at: $) asciiValue put: #rightParenthesis.
	newTable at: $. asciiValue put: #period.
	newTable at: $; asciiValue put: #semicolon.
	newTable at: $[ asciiValue put: #leftBracket.
	newTable at: $] asciiValue put: #rightBracket.
	newTable at: ${ asciiValue put: #leftBrace.
	newTable at: $} asciiValue put: #rightBrace.
	newTable at: $^ asciiValue put: #upArrow.
	newTable at: $_ asciiValue put: #leftArrow.
	newTable at: $| asciiValue put: #verticalBar.
	TypeTable _ newTable "bon voyage!!"

	"Scanner initialize"! !


!Scanner class methodsFor: 'instance creation'!
new

	^super new initScanner! !


!Scanner class methodsFor: 'testing' stamp: 'sd 3/30/2005 22:00'!
inviolateInstanceVariableNames
	"Answer a list of instance variable names not to be used.  (Place holder for real list)"
	^ #('thisContext' 'self')! !

!Scanner class methodsFor: 'testing' stamp: 'sd 3/30/2005 22:00'!
isLegalInstVarName: aString
	"Answer whether aString is a legal instance variable name."

	^ ((self isLiteralSymbol: aString) and: [(aString includes: $:) not]) and:
		[(self inviolateInstanceVariableNames includes:  aString) not]! !

!Scanner class methodsFor: 'testing' stamp: 'ar 4/11/2005 00:12'!
isLiteralSymbol: aSymbol 
	"Test whether a symbol can be stored as # followed by its characters.  
	Symbols created internally with asSymbol may not have this property, 
	e.g. '3' asSymbol."
	| i ascii type |
	i _ aSymbol size.
	i = 0 ifTrue: [^ false].
	i = 1 ifTrue: [('$''"()#0123456789' includes: (aSymbol at: 1))
		ifTrue: [^ false] ifFalse: [^ true]].
	ascii _ (aSymbol at: 1) asciiValue.
	"TypeTable should have been origined at 0 rather than 1 ..."
	ascii = 0 ifTrue: [^ false].
	type _ TypeTable at: ascii ifAbsent:[#xLetter].
	(type == #xColon or: [type == #verticalBar or: [type == #xBinary]]) ifTrue: [
		i = 1 ifTrue: [^ true] ifFalse: [^ false]
	].
	type == #xLetter ifTrue: 
			[[i > 1]
				whileTrue: 
					[ascii _ (aSymbol at: i) asciiValue.
					ascii = 0 ifTrue: [^ false].
					type _ TypeTable at: ascii ifAbsent:[#xLetter].
					(type == #xLetter or: [type == #xDigit or: [type == #xColon]])
						ifFalse: [^ false].
					i _ i - 1].
			^ true].
	^ false! !

!Scanner class methodsFor: 'testing' stamp: 'fbs 2/13/2006 22:33'!
wellFormedInstanceVariableNameFrom: aString
	"Answer a legal instance variable name, derived from aString"

	| cleansedString |
	cleansedString _ aString select: [:ch | ch isDigit or: [ch isLetter]].
	(cleansedString isEmpty or: [cleansedString first isDigit])
		ifTrue: [cleansedString _ 'a', cleansedString]
		ifFalse:	[cleansedString _ cleansedString withFirstCharacterDownshifted].

	[self isLegalInstVarName: cleansedString] whileFalse:
		[cleansedString _ cleansedString, 'x'].
	^ cleansedString

"Scanner wellFormedInstanceVariableNameFrom:  '234 xx\ Uml /ler42342380-4'"! !
Timespan subclass: #Schedule
	instanceVariableNames: 'schedule'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Chronology'!
!Schedule commentStamp: 'brp 5/13/2003 09:48' prior: 0!
I represent a powerful class for implementing recurring schedules.!


!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:50'!
between: aStart and: anEnd do: aBlock

	| element end i |
	end _ self end min: anEnd.
	element _ self start.
	
	i _ 1.
	[ element < aStart ] whileTrue:
	
	[ element _ element + (schedule at: i).
		i _ i + 1. (i > schedule size) ifTrue: [i _ 1]].
	i _ 1.
	[ element <= end ] whileTrue:
	
	[ aBlock value: element.
		element _ element + (schedule at: i).
		i _ i + 1.
		(i > schedule size) ifTrue: [i _ 1]]
.
! !

!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:50'!
dateAndTimes

	| dateAndTimes |
	dateAndTimes _ OrderedCollection new.
	self scheduleDo: [ :e | dateAndTimes add: e ].
	^ dateAndTimes asArray.! !

!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:50'!
schedule
	^ schedule
! !

!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:50'!
schedule: anArrayOfDurations

	schedule _ anArrayOfDurations
! !

!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:51'!
scheduleDo: aBlock

	self between: (self start) and: (self end) do: aBlock.
! !


!Schedule methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:38'!
includes: aDateAndTime

	| dt |
	dt _ aDateAndTime asDateAndTime.
	self scheduleDo: [ :e | e = dt ifTrue: [^true] ].
	^ false.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Schedule class
	instanceVariableNames: ''!
ClassTestCase subclass: #ScheduleTest
	instanceVariableNames: 'firstEvent aSchedule restoredTimeZone'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!

!ScheduleTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 16:03'!
classToBeTested

	^ Schedule

! !

!ScheduleTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 16:03'!
selectorsToBeIgnored

	| private | 
	private := #( #printOn: ).

	^ super selectorsToBeIgnored, private
! !


!ScheduleTest methodsFor: 'running' stamp: 'brp 9/26/2004 19:30'!
setUp
 	 "Schedule is a type of Timespan representing repeated occurences of the same event. 
	The beginning of the schedule is the first occurrence of the event.
	A schedule maintains an array of Durations. 
	Each durations specify the offset to the next scheduled each. 
	The duration of each occurence of the event is not specified. 
	Nor are any other attributes such as name"

	restoredTimeZone := DateAndTime localTimeZone.
	DateAndTime localTimeZone: (TimeZone timeZones detect: [:tz | tz abbreviation = 'GMT']).

	"Create aSchedule with an event scheduled for 8:30pm every Saturday 
	and Sunday for the year 2003. "
	"Create the first event occurring on the first Saturday at 8:30 pm: 1/4/03"
	firstEvent :=  DateAndTime year: 2003 month: 1 day: 4 hour: 20 minute: 30. 
	
	"Create a schedule for one year starting with the first event" 
	aSchedule := Schedule starting: firstEvent duration: 52 weeks.

	"Schedule the recurring events by scheduling the time in between each one.  
	One day for Sat-Sun. 6 days for Sun-Sat" 
	aSchedule schedule: { Duration days: 1. Duration days: 6 }.
! !

!ScheduleTest methodsFor: 'running' stamp: 'brp 9/26/2004 19:30'!
tearDown

	DateAndTime localTimeZone: restoredTimeZone.
! !


!ScheduleTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 16:08'!
testFromDateAndTime

	| oc1 oc2 |
	oc1 _ OrderedCollection new.
	DateAndTime today to: DateAndTime tomorrow by: 10 hours do: [ :dt | oc1 add: dt ].

	oc2 _ { DateAndTime today. 
			(DateAndTime today + 10 hours). 
				(DateAndTime today + 20 hours) }.

	self assert: (oc1 asArray = oc2)! !

!ScheduleTest methodsFor: 'Tests' stamp: 'nk 3/30/2004 10:34'!
testMonotonicity

	| t1 t2 t3 t4 |
	t1 := DateAndTime now.
	t2 := DateAndTime now.
	t3 := DateAndTime now.
	t4 := DateAndTime now.

	self 
		assert: (	t1 <= t2);
		assert: (	t2 <= t3);
		assert: (	t3 <= t4).
! !


!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'!
testBetweenAndDoDisjointWithSchedule
	| count |
	count := 0.
	aSchedule
		between: (DateAndTime
				year: 2004
				month: 4
				day: 1)
		and: (DateAndTime
				year: 2004
				month: 4
				day: 30)
		do: [:each | count := count + 1].
	self assert: count = 0! !

!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'!
testBetweenAndDoIncludedInSchedule
	| count |
	count := 0.
	aSchedule
		between: (DateAndTime
				year: 2003
				month: 4
				day: 1)
		and: (DateAndTime
				year: 2003
				month: 4
				day: 30)
		do: [:each | count := count + 1].
	self assert: count = 8! !

!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'!
testBetweenAndDoOverlappingSchedule
	| count |
	count := 0.
	aSchedule
		between: (DateAndTime
				year: 2002
				month: 12
				day: 1)
		and: (DateAndTime
				year: 2003
				month: 1
				day: 31)
		do: [:each | count := count + 1].
	self assert: count = 8! !

!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'!
testDateAndTimes
	| answer |
	self assert: aSchedule dateAndTimes size  = 104.
	self assert: aSchedule dateAndTimes first = firstEvent.
	answer _ true.
	aSchedule dateAndTimes do: [:each | (each dayOfWeekName = 'Saturday'
		or: [each dayOfWeekName = 'Sunday']) ifFalse: [^false]].
	self assert: answer
! !

!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'!
testExampleFromSwikiPage
	"It is often neccessary to schedule repeated events, like airline flight schedules, TV programmes, and file backups.
	 Schedule is a Timespan which maintains an array of Durations.
	 The durations specify the offset to the next scheduled DateAndTime. "
	"Consider a TV programme scheduled for 8:30pm every Saturday and Sunday for the current year. "
	"Find the first Saturday and set its time to 20h30"
	| sat shows |
	sat := Year current asMonth dates detect: [ :d | d dayOfWeekName = #Saturday ].
	sat := sat start + (Duration hours: 20.5).
	"Create a schedule" 
	shows := Schedule starting: sat ending: Year current end.
	shows schedule: { Duration days: 1. Duration days: 6 }.
	"To inspect:"
	shows dateAndTimes.
	shows dateAndTimes collect: [ :dt | dt dayOfWeekName ].

! !

!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'!
testIncludes
	self assert: (aSchedule includes: (DateAndTime year: 2003 month: 6 day: 15 hour: 20 minute: 30 second: 0 offset: 0 hours))
	
! !

!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'!
testSchedule
	self assert: aSchedule schedule size = 2.
	self assert: aSchedule schedule first = 1 days.	
	self assert: aSchedule schedule second = 6 days.
! !
AbstractSound subclass: #ScorePlayer
	instanceVariableNames: 'score instruments overallVolume leftVols rightVols muted rate tempo secsPerTick done repeat ticksSinceStart ticksClockIncr trackEventIndex tempoMapIndex activeSounds activeMIDINotes midiPort midiPlayerProcess durationInTicks'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!ScorePlayer commentStamp: '<historical>' prior: 0!
This is a real-time player for MIDI scores (i.e., scores read from MIDI files). Score can be played using either the internal sound synthesis or an external MIDI synthesizer on platforms that support MIDI output.
!


!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration
	"Answer the duration in seconds of my MIDI score when played at the current rate. Take tempo changes into account."

	| totalSecs currentTempo lastTempoChangeTick |
	totalSecs := 0.0.
	currentTempo := 120.0.  "quarter notes per minute"
	lastTempoChangeTick := 0.
	score tempoMap ifNotNil: [
		score tempoMap do: [:tempoEvt |
			"accumulate time up to this tempo change event"
			secsPerTick := 60.0 / (currentTempo * rate * score ticksPerQuarterNote).
			totalSecs := totalSecs + (secsPerTick * (tempoEvt time - lastTempoChangeTick)).

			"set the new tempo"
			currentTempo := (120.0 * (500000.0 / tempoEvt tempo)) roundTo: 0.01.
			lastTempoChangeTick := tempoEvt time]].

	"add remaining time through end of score"
	secsPerTick := 60.0 / (currentTempo * rate * score ticksPerQuarterNote).
	totalSecs := totalSecs + (secsPerTick * (score durationInTicks - lastTempoChangeTick)).
	^ totalSecs
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'di 6/15/1999 11:37'!
durationInTicks

	durationInTicks == nil ifTrue: [^ 1000].
	^ durationInTicks! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 3/3/98 12:14'!
infoForTrack: i
	"Return the info string for the given track."
	"Note: MIDI files follow varying conventions on their use of comment strings. Often, the first string in the track suggests the role of that track in the score, such as 'flute 1' or 'soprano'."

	^ score trackInfo at: i
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:37'!
instrumentForTrack: trackIndex

	^ instruments at: trackIndex
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/1/1999 20:33'!
instrumentForTrack: trackIndex put: aSoundProto

	trackIndex > instruments size ifTrue: [^ self].
	instruments at: trackIndex put: aSoundProto.
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 12/16/2001 20:20'!
isStereo

	^ true
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:58'!
midiPort

	^ midiPort
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'di 5/30/1999 12:46'!
millisecondsSinceStart
	"Answer the approximate number of milliseconds of real time since the beginning of the score. Since this calculation uses the current tempo, which can change throughout the piece, it is safer to use ticksSinceStart for synchronization."

	^ (secsPerTick * ticksSinceStart * 1000) asInteger
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/29/98 18:33'!
mutedForTrack: trackIndex

	^ muted at: trackIndex
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/1/1999 20:33'!
mutedForTrack: trackIndex put: aBoolean

	trackIndex > muted size ifTrue: [^ self].
	muted at: trackIndex put: aBoolean.
	aBoolean ifFalse: [^ self].

	"silence any currently sounding notes for this track"
	activeSounds do: [:pair |
		pair last = trackIndex ifTrue: [activeSounds remove: pair ifAbsent: []]].
	midiPort ifNotNil: [
		activeMIDINotes do: [:pair |
			pair last = trackIndex ifTrue: [
				pair first endNoteOnMidiPort: midiPort.
				activeMIDINotes remove: pair ifAbsent: []]]].
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 5/30/1999 17:16'!
mutedState

	^ muted
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 08:17'!
overallVolume

	^ overallVolume
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
overallVolume: aNumber
	"Set the overally playback volume to a value between 0.0 (off) and 1.0 (full blast)."

	overallVolume := (aNumber asFloat min: 1.0) max: 0.0.

! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
panForTrack: i

	| left right fullVol pan |
	left := leftVols at: i.
	right := rightVols at: i.
	left = right ifTrue: [^ 0.5].  "centered"
	fullVol := left max: right.
	left < fullVol
		ifTrue: [pan := left asFloat / (2.0 * fullVol)]
		ifFalse: [pan := 1.0 - (right asFloat / (2.0 * fullVol))].
	^ pan roundTo: 0.001

! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
panForTrack: trackIndex put: aNumber
	"Set the left-right pan for this track to a value in the range [0.0..1.0], where 0.0 means full-left."

	| fullVol pan left right |
	trackIndex > leftVols size ifTrue: [^ self].
	fullVol := (leftVols at: trackIndex) max: (rightVols at: trackIndex).
	pan := (aNumber asFloat min: 1.0) max: 0.0.
	pan <= 0.5
		ifTrue: [  "attenuate right channel"
			left := fullVol.
			right := 2.0 * pan * fullVol]
		ifFalse: [  "attenuate left channel"
			left := 2.0 * (1.0 - pan) * fullVol.
			right := fullVol].
	rightVols at: trackIndex put: right asInteger.
	leftVols at: trackIndex put: left asInteger.
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'di 6/20/1999 00:42'!
positionInScore

	^ self ticksSinceStart asFloat / (self durationInTicks max: 1)! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
positionInScore: pos

	self isPlaying ifTrue: [^ self "ignore rude intrusion"].
	ticksSinceStart := pos * durationInTicks.
	done := false.

! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:33'!
rate

	^ rate
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
rate: aNumber
	"Set the playback rate. For example, a rate of 2.0 will playback at twice normal speed."

	rate := aNumber asFloat.
	self tempoOrRateChanged.
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 3/4/98 09:30'!
repeat
	"Return true if this player will repeat when it gets to the end of the score, false otherwise."

	^ repeat
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
repeat: aBoolean
	"Turn repeat mode on or off."

	repeat := aBoolean.
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:33'!
score

	^ score
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'di 10/19/2000 21:12'!
secsPerTick

	^ secsPerTick! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
settingsString

	| s |
	s := WriteStream on: (String new: 1000).
	s nextPutAll: 'player'; cr.
	s tab; nextPutAll: 'rate: ', self rate printString, ';'; cr.
	s tab; nextPutAll: 'overallVolume: ', self overallVolume printString, ';'; cr.
	1 to: self trackCount do: [:t |
		s tab; nextPutAll: 'instrumentForTrack: ', t printString,
			' put: (AbstractSound soundNamed: #default);'; cr.
		s tab; nextPutAll: 'mutedForTrack: ', t printString,
			' put: ', (self mutedForTrack: t) printString, ';'; cr.
		s tab; nextPutAll: 'volumeForTrack: ', t printString,
			' put: ', (self volumeForTrack: t) printString, ';'; cr.
		s tab; nextPutAll: 'panForTrack: ', t printString,
			' put: ', (self panForTrack: t) printString, ';'; cr].
	s tab; nextPutAll: 'repeat: ', self repeat printString, '.'; cr.
	^ s contents
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/4/98 10:10'!
tempo
	"Return the current tempo in beats (quarter notes) per minute. The tempo at any given moment is defined by the score and cannot be changed by the client. To change the playback speed, the client may change the rate parameter."

	^ tempo
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/22/1998 09:32'!
ticksForMSecs: mSecs

	^ (mSecs asFloat / (1000.0 * secsPerTick)) rounded
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/10/1998 20:48'!
ticksSinceStart
	"Answer the number of score ticks that have elapsed since this piece started playing. The duration of a tick is determined by the MIDI score."

	^ ticksSinceStart
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
ticksSinceStart: newTicks
	"Adjust ticks to folow, eg, piano roll autoscrolling"

	self isPlaying ifFalse: [ticksSinceStart := newTicks]
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:35'!
trackCount

	^ score tracks size
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
volumeForTrack: i

	| vol |
	vol := (leftVols at: i) max: (rightVols at: i).
	^ (vol asFloat / ScaleFactor) roundTo: 0.0001
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
volumeForTrack: trackIndex put: aNumber

	| newVol oldLeft oldRight oldFullVol left right |
	trackIndex > leftVols size ifTrue: [^ self].
	newVol := ((aNumber asFloat max: 0.0) min: 1.0) * ScaleFactor.
	oldLeft := leftVols at: trackIndex.
	oldRight := rightVols at: trackIndex.
	oldFullVol := oldLeft max: oldRight.
	oldFullVol = 0 ifTrue: [oldFullVol := 1.0].
	oldLeft < oldFullVol
		ifTrue: [
			left := newVol * oldLeft / oldFullVol.
			right := newVol]
		ifFalse: [
			left := newVol.
			right := newVol * oldRight / oldFullVol].
	leftVols at: trackIndex put: left asInteger.
	rightVols at: trackIndex put: right asInteger.
! !


!ScorePlayer methodsFor: 'copying' stamp: 'jm 12/15/97 19:13'!
copy
	"Copy my component sounds."

	^ super copy copySounds
! !

!ScorePlayer methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:41'!
copySounds
	"Private!! Support for copying."

	instruments := instruments copy.
	leftVols := leftVols copy.
	rightVols := rightVols copy.
	muted := muted copy.
	self reset.
! !


!ScorePlayer methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	super initialize.
	score := MIDIScore new initialize.
	instruments := Array new.
	overallVolume := 0.5.
	leftVols := Array new.
	rightVols := Array new.
	muted := Array new.
	rate := 1.0.
	repeat := false.
	durationInTicks := 100.! !

!ScorePlayer methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
onScore: aMIDIScore

	| trackCount totalVol incr curr pan |
	score := aMIDIScore.
	trackCount := score tracks size.
	durationInTicks := score durationInTicks.
	instruments := (1 to: trackCount) collect: [:i | FMSound oboe1].
	leftVols := Array new: trackCount.
	rightVols := Array new: trackCount.
	muted  := Array new: trackCount withAll: false.
	rate := 1.0.
	repeat := false.
	tempo := 120.0.

	trackCount = 0 ifTrue: [^ self].
	1 to: trackCount do: [:i |
		leftVols at: i put: ScaleFactor // 4.
		rightVols at: i put: ScaleFactor // 4].

	"distribute inital panning of tracks left-to-right"
	totalVol := 1.0.
	incr := totalVol / (((trackCount // 2) + 1) * 2).
	curr := 0.
	1 to: trackCount do: [:t |
		t even
			ifTrue: [pan := curr]
			ifFalse: [
				curr := curr + incr.
				pan := totalVol - curr].
		self panForTrack: t put: pan].

! !

!ScorePlayer methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateDuration

	durationInTicks := score durationInTicks.
! !


!ScorePlayer methodsFor: 'midi output' stamp: 'stephaneducasse 2/4/2006 20:41'!
closeMIDIPort
	"Stop using MIDI for output. Music will be played using the built-in sound synthesis."

	self pause.
	midiPort := nil.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'stephaneducasse 2/4/2006 20:41'!
midiPlayLoop

	| mSecsPerStep tStart mSecs |
	mSecsPerStep := 5.
	[done] whileFalse: [
		tStart := Time millisecondClockValue.
		self processAllAtTick: ticksSinceStart asInteger.
		(Delay forMilliseconds: mSecsPerStep) wait.
		mSecs := Time millisecondClockValue - tStart.
		mSecs < 0 ifTrue: [mSecs := mSecsPerStep].  "clock wrap"
		ticksSinceStart := ticksSinceStart + (mSecs asFloat / (1000.0 * secsPerTick))].
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'stephaneducasse 2/4/2006 20:41'!
openMIDIPort: portNum
	"Open the given MIDI port. Music will be played as MIDI commands to the given MIDI port."

	midiPort := SimpleMIDIPort openOnPortNumber: portNum.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'stephaneducasse 2/4/2006 20:41'!
processMIDIEventsAtTick: scoreTick
	"Process note events through the given score tick using MIDI."

	| j evt |
	1 to: score tracks size do: [:i |
		j := trackEventIndex at: i.
		[evt := score eventForTrack: i after: j ticks: scoreTick.
		 evt ~~ nil] whileTrue: [
			evt isNoteEvent
				ifTrue: [
					(muted at: i) ifFalse: [
						evt startNoteOnMidiPort: midiPort.
						activeMIDINotes add: (Array with: evt with: i)]]
				ifFalse: [evt outputOnMidiPort: midiPort].
			j := j + 1.
			trackEventIndex at: i put: j]].
	self turnOffActiveMIDINotesAt: scoreTick.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'stephaneducasse 2/4/2006 20:41'!
startMIDIPlaying
	"Start up a process to play this score via MIDI."

	midiPort ensureOpen.
	midiPlayerProcess ifNotNil: [midiPlayerProcess terminate].
	midiPlayerProcess := [self midiPlayLoop] newProcess.
	midiPlayerProcess
		priority: Processor userInterruptPriority;
		resume.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopMIDIPlaying
	"Terminate the MIDI player process and turn off any active notes."

	midiPlayerProcess ifNotNil: [midiPlayerProcess terminate].
	midiPlayerProcess := nil.
	activeMIDINotes do: [:pair | pair first endNoteOnMidiPort: midiPort].
	activeMIDINotes := activeMIDINotes species new.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'stephaneducasse 2/4/2006 20:41'!
turnOffActiveMIDINotesAt: scoreTick
	"Turn off any active MIDI notes that should be turned off at the given score tick."

	| evt someNoteEnded |
	midiPort ifNil: [^ self].
	someNoteEnded := false. 
	activeMIDINotes do: [:pair |
		evt := pair first.
		evt endTime <= scoreTick ifTrue: [
			evt endNoteOnMidiPort: midiPort.
			someNoteEnded := true]].

	someNoteEnded ifTrue: [
		activeMIDINotes := activeMIDINotes select: [:p | p first endTime > scoreTick]].
! !


!ScorePlayer methodsFor: 'operating' stamp: 'jm 1/30/98 14:03'!
disableReverb: aBoolean

	aBoolean
		ifTrue: [SoundPlayer stopReverb]
		ifFalse: [SoundPlayer startReverb].
! !

!ScorePlayer methodsFor: 'operating' stamp: 'stephaneducasse 2/4/2006 20:41'!
pause
	"Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."

	score pauseFrom: self.
	super pause.
	activeSounds := activeSounds species new.
	midiPort ifNotNil: [self stopMIDIPlaying].
! !

!ScorePlayer methodsFor: 'operating' stamp: 'jm 6/16/1999 22:45'!
resumePlaying
	"Resume playing. Start over if done."

	done ifTrue: [self reset].
	self jumpToTick: ticksSinceStart.  "Play up to here in case we got scrolled to new position."
	score resumeFrom: self.
	midiPort
		ifNil: [super resumePlaying]  "let the sound player drive sound generation" 
		ifNotNil: [self startMIDIPlaying].  "start a process to drive MIDI output"
! !

!ScorePlayer methodsFor: 'operating' stamp: 'stephaneducasse 2/4/2006 20:41'!
tempoOrRateChanged
	"This method should be called after changing the tempo or rate."

	secsPerTick := 60.0 / (tempo * rate * score ticksPerQuarterNote).
	ticksClockIncr := (1.0 / self controlRate) / secsPerTick.
! !


!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
doControl

	super doControl.
	1 to: activeSounds size do: [:i | (activeSounds at: i) first doControl].
	ticksSinceStart := ticksSinceStart + ticksClockIncr.
	self processAllAtTick: ticksSinceStart asInteger.
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
isDone

	| track |
	activeSounds size > 0 ifTrue: [^ false].
	activeMIDINotes size > 0 ifTrue: [^ false].
	1 to: score tracks size do: [:i |
		track := score tracks at: i.
		(trackEventIndex at: i) <= track size ifTrue: [^ false]].
	(trackEventIndex last) <= score ambientTrack size ifTrue: [^ false].
	^ true
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'di 8/5/1998 23:07'!
isPlaying
	^ SoundPlayer isPlaying: self! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
jumpToTick: startTick


	self reset.
	self processTempoMapAtTick: startTick.
	self skipNoteEventsThruTick: startTick.
	self skipAmbientEventsThruTick: startTick.
	ticksSinceStart := startTick.
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels."

	| myLeftVol myRightVol someSoundIsDone pair snd trk left right |
	myLeftVol := (leftVol * overallVolume) asInteger.
	myRightVol := (rightVol * overallVolume) asInteger.
	someSoundIsDone := false.
	1 to: activeSounds size do: [:i |
		pair := activeSounds at: i.
		snd := pair at: 1.
		trk := pair at: 2.
		left := (myLeftVol * (leftVols at: trk)) // ScaleFactor.
		right := (myRightVol * (rightVols at: trk)) // ScaleFactor.
		snd samplesRemaining > 0
			ifTrue: [
				snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right]
			ifFalse: [someSoundIsDone := true]].

	someSoundIsDone ifTrue: [
		activeSounds := activeSounds select: [:p | p first samplesRemaining > 0]].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
processAllAtTick: scoreTick

	self processTempoMapAtTick: scoreTick.
	midiPort
		ifNil: [self processNoteEventsAtTick: scoreTick]
		ifNotNil: [self processMIDIEventsAtTick: scoreTick].
	self processAmbientEventsAtTick: scoreTick.
	self isDone ifTrue: [
		repeat
			ifTrue: [self reset]
			ifFalse: [done := true]].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
processAmbientEventsAtTick: scoreTick
	"Process ambient events through the given tick."

	| i evt |
	i := trackEventIndex at: trackEventIndex size.
	[evt := score ambientEventAfter: i ticks: scoreTick.
	 evt ~~ nil] whileTrue: [
		i := i + 1.
		evt occurAtTime: scoreTick inScorePlayer: self atIndex: i inEventTrack: score ambientTrack secsPerTick: secsPerTick].
	trackEventIndex at: trackEventIndex size put: i.
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
processNoteEventsAtTick: scoreTick
	"Process note events through the given score tick using internal Squeak sound synthesis."

	| instr j evt snd |
	1 to: score tracks size do: [:i |
		instr := instruments at: i.
		j := trackEventIndex at: i.
		[evt := score eventForTrack: i after: j ticks: scoreTick.
		 evt ~~ nil] whileTrue: [
			(evt isNoteEvent and: [(muted at: i) not]) ifTrue: [
				snd := instr
					soundForMidiKey: evt midiKey
					dur: secsPerTick * evt duration
					loudness: evt velocity asFloat / 127.0.
				activeSounds add: (Array with: snd with: i)].
			j := j + 1.
			trackEventIndex at: i put: j]].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
processTempoMapAtTick: scoreTick
	"Process tempo changes through the given score tick."

	| map tempoChanged |
	map := score tempoMap.
	map ifNil: [^ self].
	tempoChanged := false.
	[(tempoMapIndex <= map size) and:
	 [(map at: tempoMapIndex) time <= scoreTick]] whileTrue: [
		tempoChanged := true.
		tempoMapIndex := tempoMapIndex + 1].

	tempoChanged ifTrue: [
		tempo := (120.0 * (500000.0 / (map at: tempoMapIndex - 1) tempo)) roundTo: 0.01.
		self tempoOrRateChanged].

! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset

	super reset.
	tempo := 120.0.
	self tempoOrRateChanged.
	done := false.
	ticksSinceStart := 0.
	"one index for each sound track, plus one for the ambient track..."
	trackEventIndex := Array new: score tracks size+1 withAll: 1.
	tempoMapIndex := 1.
	activeSounds := OrderedCollection new.
	activeMIDINotes := OrderedCollection new.
	score resetFrom: self.
	overallVolume ifNil: [overallVolume := 0.5].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 12/30/97 17:38'!
samplesRemaining

	done
		ifTrue: [^ 0]
		ifFalse: [^ 1000000].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'di 10/22/2000 17:19'!
skipAmbientEventsThruTick: startTick
	"Skip ambient events through the given score tick."

	score ambientTrack withIndexDo:
		[:evt :i | evt time > startTick ifTrue:
			[^ trackEventIndex at: trackEventIndex size put: i]].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
skipNoteEventsThruTick: startTick
	"Skip note events through the given score tick using internal Squeak sound synthesis."

	| j evt |
	1 to: score tracks size do: [:i |
		j := trackEventIndex at: i.
		[evt := score eventForTrack: i after: j ticks: startTick.
		 evt == nil] whileFalse: [
			evt isNoteEvent
				ifTrue: [
					(((evt time + evt duration) > startTick) and: [(muted at: i) not]) ifTrue: [
						self startNote: evt forStartTick: startTick trackIndex: i]]
				ifFalse: [
					midiPort == nil ifFalse: [evt outputOnMidiPort: midiPort]].
			j := j + 1].
		trackEventIndex at: i put: j].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
startNote: noteEvent forStartTick: startTick trackIndex: trackIndex
	"Prepare a note to begin playing at the given tick. Used to start playing at an arbitrary point in the score. Handle both MIDI and built-in synthesis cases."

	| snd |
	midiPort
		ifNil: [
			snd := (instruments at: trackIndex)
				soundForMidiKey: noteEvent midiKey
				dur: secsPerTick * (noteEvent endTime - startTick)
				loudness: noteEvent velocity asFloat / 127.0.
			activeSounds add: (Array with: snd with: trackIndex)]
		ifNotNil: [
			noteEvent startNoteOnMidiPort: midiPort.
			activeMIDINotes add: (Array with: noteEvent with: trackIndex)].
! !


!ScorePlayer methodsFor: 'volume' stamp: 'stephaneducasse 2/4/2006 20:41'!
adjustVolumeTo: vol overMSecs: mSecs
	| normalizedVolume incr block |
	normalizedVolume := (vol asFloat min: 1.0) max: 0.0.
	incr := (self overallVolume - normalizedVolume) / mSecs * 50.0.
	block := normalizedVolume > 0.0
		ifTrue: [
			[[(normalizedVolume - self overallVolume) abs > 0.01] whileTrue: [self overallVolume: self overallVolume - incr. (Delay forMilliseconds: 50) wait]]]
		ifFalse: [
			[[self overallVolume > 0.0] whileTrue: [self overallVolume: self overallVolume - incr. (Delay forMilliseconds: 50) wait]. self pause]].
	block fixTemps; fork
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScorePlayer class
	instanceVariableNames: ''!

!ScorePlayer class methodsFor: 'instance creation' stamp: 'jm 1/29/98 18:18'!
onScore: aMIDIScore

	^ self new onScore: aMIDIScore
! !
AlignmentMorph subclass: #ScorePlayerMorph
	instanceVariableNames: 'scorePlayer trackInstNames instrumentSelector scrollSlider'
	classVariableNames: 'LastMIDIPort'
	poolDictionaries: ''
	category: 'Sound-Scores'!
!ScorePlayerMorph commentStamp: '<historical>' prior: 0!
A ScorePlayerMorph mediates between a score such as a MIDIScore, a PianoRollScoreMorph, and the actual SoundPlayer synthesizer.

It provides control over volume, tempo, instrumentation, and location in the score.!


!ScorePlayerMorph methodsFor: 'accessing' stamp: 'jm 6/1/1998 09:10'!
scorePlayer

	^ scorePlayer
! !


!ScorePlayerMorph methodsFor: 'controls' stamp: 'gm 2/28/2003 00:28'!
atTrack: trackIndex from: aPopUpChoice selectInstrument: selection 
	| oldSnd name snd |
	oldSnd := scorePlayer instrumentForTrack: trackIndex.
	(selection beginsWith: 'edit ') 
		ifTrue: 
			[name := selection copyFrom: 6 to: selection size.
			aPopUpChoice contentsClipped: name.
			(oldSnd isKindOf: FMSound) | (oldSnd isKindOf: LoopedSampledSound) 
				ifTrue: [EnvelopeEditorMorph openOn: oldSnd title: name].
			(oldSnd isKindOf: SampledInstrument) 
				ifTrue: [EnvelopeEditorMorph openOn: oldSnd allNotes first title: name].
			^self].
	snd := nil.
	1 to: instrumentSelector size
		do: 
			[:i | 
			(trackIndex ~= i and: [selection = (instrumentSelector at: i) contents]) 
				ifTrue: [snd := scorePlayer instrumentForTrack: i]].	"use existing instrument prototype"
	snd ifNil: 
			[snd := (selection = 'clink' 
				ifTrue: 
					[(SampledSound samples: SampledSound coffeeCupClink
								samplingRate: 11025) ]
				ifFalse: [(AbstractSound soundNamed: selection)]) copy].
	scorePlayer instrumentForTrack: trackIndex put: snd.
	(instrumentSelector at: trackIndex) contentsClipped: selection! !

!ScorePlayerMorph methodsFor: 'controls' stamp: 'jm 10/12/1998 17:18'!
rewind

	scorePlayer pause; reset.
! !

!ScorePlayerMorph methodsFor: 'controls' stamp: 'jm 1/30/98 15:23'!
setLogRate: logOfRate

	scorePlayer rate: (3.5 raisedTo: logOfRate).
! !


!ScorePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
closeMIDIPort

	scorePlayer closeMIDIPort.
	LastMIDIPort := nil.
! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 2! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color veryLightGray! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:25'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 wrapCentering: #center;
		 cellPositioning: #topCenter;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 layoutInset: 3;
		 onScorePlayer: ScorePlayer new initialize title: ' ';
		 extent: 20 @ 20 ! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
onScorePlayer: aScorePlayer title: scoreName
	| divider col r |
	scorePlayer := aScorePlayer.
	scorePlayer ifNotNil:
		[scorePlayer  reset.
		instrumentSelector := Array new: scorePlayer score tracks size].

	self removeAllMorphs.
	self addMorphBack: self makeControls.
	scorePlayer ifNil: [^ self].

	r := self makeRow
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	r addMorphBack: self rateControl;
		addMorphBack: (Morph newBounds: (0@0 extent: 20@0) color: Color transparent);
		addMorphBack: self volumeControl.
	self addMorphBack: r.
	self addMorphBack: self scrollControl.

	col := AlignmentMorph newColumn color: color; layoutInset: 0.
	self addMorphBack: col.
	1 to: scorePlayer trackCount do: [:trackIndex |
		divider := AlignmentMorph new
			extent: 10@1;
			borderWidth: 1;
			layoutInset: 0;
			borderColor: #raised;
			color: color;
			hResizing: #spaceFill;
			vResizing: #rigid.
		col addMorphBack: divider.
		col addMorphBack: (self trackControlsFor: trackIndex)].

	LastMIDIPort ifNotNil: [
		"use the most recently set MIDI port"
		scorePlayer openMIDIPort: LastMIDIPort].
! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
openMIDIFile
	"Open a MIDI score and re-init controls..."
	| score fileName f player |
	fileName := Utilities chooseFileWithSuffixFromList: #('.mid' '.midi')
					withCaption: 'Choose a MIDI file to open' translated.
	(fileName isNil or: [ fileName == #none ])
		ifTrue: [^ self inform: 'No .mid/.midi files found in the Squeak directory' translated].
	f := FileStream readOnlyFileNamed: fileName.
	score := (MIDIFileReader new readMIDIFrom: f binary) asScore.
	f close.
	player := ScorePlayer onScore: score.
	self onScorePlayer: player title: fileName! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
openMIDIPort

	| portNum |
	portNum := SimpleMIDIPort outputPortNumFromUser.
	portNum ifNil: [^ self].
	scorePlayer openMIDIPort: portNum.
	LastMIDIPort := portNum.
! !


!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
makeControls

	| bb r reverbSwitch repeatSwitch |
	r := AlignmentMorph newRow.
	r color: color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
			borderWidth: 2; color: color.
	r addMorphBack: (bb label: '<>'; actWhen: #buttonDown;
												actionSelector: #invokeMenu).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
			borderWidth: 2; color: color.
	r addMorphBack: (bb label: 'Piano Roll' translated;		actionSelector: #makePianoRoll).
	bb := SimpleButtonMorph new target: self; borderColor: #raised;
			borderWidth: 2; color: color.
	r addMorphBack: (bb label: 'Rewind' translated;		actionSelector: #rewind).
	bb := SimpleButtonMorph new target: scorePlayer; borderColor: #raised;
			borderWidth: 2; color: color.
	r addMorphBack: (bb label: 'Play' translated;			actionSelector: #resumePlaying).
	bb := SimpleButtonMorph new target: scorePlayer; borderColor: #raised;
			borderWidth: 2; color: color.
	r addMorphBack: (bb label: 'Pause' translated;			actionSelector: #pause).
	reverbSwitch := SimpleSwitchMorph new
		offColor: color;
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		borderWidth: 2;
		label: 'Reverb Disable' translated;
		actionSelector: #disableReverb:;
		target: scorePlayer;
		setSwitchState: SoundPlayer isReverbOn not.
	r addMorphBack: reverbSwitch.
	scorePlayer ifNotNil:
		[repeatSwitch := SimpleSwitchMorph new
			offColor: color;
			onColor: (Color r: 1.0 g: 0.6 b: 0.6);
			borderWidth: 2;
			label: 'Repeat' translated;
			actionSelector: #repeat:;
			target: scorePlayer;
			setSwitchState: scorePlayer repeat.
		r addMorphBack: repeatSwitch].
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'jm 9/28/1998 23:05'!
makeMIDIController: evt

	self world activeHand attachMorph:
		(MIDIControllerMorph new midiPort: scorePlayer midiPort).
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
makePianoRoll
	"Create a piano roll viewer for this score player."

	| pianoRoll hand |
	pianoRoll := PianoRollScoreMorph new on: scorePlayer.
	hand := self world activeHand.
	hand ifNil: [self world addMorph: pianoRoll]
		ifNotNil: [hand attachMorph: pianoRoll.
				hand lastEvent shiftPressed ifTrue:
					["Special case for NOBM demo"
					pianoRoll contractTime; contractTime; enableDragNDrop]].
	pianoRoll startStepping.
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 21:23'!
makeRow

	^ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
panAndVolControlsFor: trackIndex

	| volSlider panSlider c r middleLine pianoRollColor |
	pianoRollColor := (Color wheel: scorePlayer score tracks size) at: trackIndex.
	volSlider := SimpleSliderMorph new
		color: color;
		sliderColor: pianoRollColor;
		extent: 101@2;
		target: scorePlayer;
		arguments: (Array with: trackIndex);
		actionSelector: #volumeForTrack:put:;
		minVal: 0.0;
		maxVal: 1.0;
		adjustToValue: (scorePlayer volumeForTrack: trackIndex).
	panSlider := SimpleSliderMorph new
		color: color;
		sliderColor: pianoRollColor;
		extent: 101@2;
		target: scorePlayer;
		arguments: (Array with: trackIndex);
		actionSelector: #panForTrack:put:;
		minVal: 0.0;
		maxVal: 1.0;		
		adjustToValue: (scorePlayer panForTrack: trackIndex).
	c := AlignmentMorph newColumn
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap.
	middleLine := Morph new  "center indicator for pan slider"
		color: (Color r: 0.4 g: 0.4 b: 0.4);
		extent: 1@(panSlider height - 4);
		position: panSlider center x@(panSlider top + 2).
	panSlider addMorphBack: middleLine.
	r := self makeRow.
	r addMorphBack: (StringMorph contents: '0').
	r addMorphBack: volSlider.
	r addMorphBack: (StringMorph contents: '10').
	c addMorphBack: r.
	r := self makeRow.
	r addMorphBack: (StringMorph contents: 'L' translated).
	r addMorphBack: panSlider.
	r addMorphBack: (StringMorph contents: 'R' translated).
	c addMorphBack: r.
	^ c
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
rateControl

	| rateSlider middleLine r |
	rateSlider := SimpleSliderMorph new
		color: color;
		sliderColor: Color gray;
		extent: 180@2;
		target: self;
		actionSelector: #setLogRate:;
		minVal: -1.0;
		maxVal: 1.0;
		adjustToValue: 0.0.
	middleLine := Morph new  "center indicator for pan slider"
		color: (Color r: 0.4 g: 0.4 b: 0.4);
		extent: 1@(rateSlider height - 4);
		position: rateSlider center x@(rateSlider top + 2).
	rateSlider addMorphBack: middleLine.
	r := self makeRow
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: 'slow ' translated).
	r addMorphBack: rateSlider.
	r addMorphBack: (StringMorph contents: ' fast' translated).
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
scrollControl

	| r |
	scrollSlider := SimpleSliderMorph new
		color: color;
		sliderColor: Color gray;
		extent: 360@2;
		target: scorePlayer;
		actionSelector: #positionInScore:;
		adjustToValue: scorePlayer positionInScore.
	r := self makeRow
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: 'start ' translated).
	r addMorphBack: scrollSlider.
	r addMorphBack: (StringMorph contents: ' end' translated).
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
showResumeButtonInTheWorld

	| w |

	WorldState addDeferredUIMessage: [
		w := self world.
		w ifNotNil: [
			w addMorphFront:
				(self standaloneResumeButton position: (w right - 100) @ (w top + 10)).
			scorePlayer pause.
			].
	]
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
standaloneResumeButton

	| r |

	r := AlignmentMorph newRow.
	r color: Color red; borderWidth: 0; layoutInset: 6; useRoundedCorners.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (
		SimpleButtonMorph new
			target: [
				scorePlayer resumePlaying.
				r delete
			];
			borderColor: #raised;
			borderWidth: 2;
			color: Color green;
			label: 'Continue' translated;
			actionSelector: #value
	).
	r setBalloonText: 'Continue playing a paused presentation' translated.
	^r


! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
trackControlsFor: trackIndex

	| r |
	r := self makeRow
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	r addMorphBack: (self trackNumAndMuteButtonFor: trackIndex).
	r addMorphBack: (Morph new extent: 10@5; color: color).  "spacer"
	r addMorphBack: (self panAndVolControlsFor: trackIndex).
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
trackNumAndMuteButtonFor: trackIndex

	| muteButton instSelector pianoRollColor r |
	muteButton := SimpleSwitchMorph new
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		offColor: color;
		color: color;
		label: 'Mute' translated;
		target: scorePlayer;
		actionSelector: #mutedForTrack:put:;
		arguments: (Array with: trackIndex).
	instSelector := PopUpChoiceMorph new
		extent: 95@14;
		contentsClipped: 'oboe1';
		target: self;
		actionSelector: #atTrack:from:selectInstrument:;
		getItemsSelector: #instrumentChoicesForTrack:;
		getItemsArgs: (Array with: trackIndex).
	instSelector arguments:
		(Array with: trackIndex with: instSelector).
	instrumentSelector at: trackIndex put: instSelector.

	"select track color using same color list as PianoRollScoreMorph"
	pianoRollColor := (Color wheel: scorePlayer score tracks size) at: trackIndex.

	r := self makeRow
		hResizing: #rigid;
		vResizing: #spaceFill;
		extent: 70@10.
	r addMorphBack:
		((StringMorph
			contents: trackIndex printString
			font: (TextStyle default fontOfSize: 24)) color: pianoRollColor).
	trackIndex < 10
		ifTrue: [r addMorphBack: (Morph new color: color; extent: 19@8)]  "spacer"
		ifFalse: [r addMorphBack: (Morph new color: color; extent: 8@8)].  "spacer"
	r addMorphBack:
		(StringMorph new
			extent: 140@14;
			contentsClipped: (scorePlayer infoForTrack: trackIndex)).
	r addMorphBack: (Morph new color: color; extent: 8@8).  "spacer"
	r addMorphBack: instSelector.
	r addMorphBack: (AlignmentMorph newRow color: color).  "spacer"
	r addMorphBack: muteButton.
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'stephaneducasse 2/4/2006 20:41'!
volumeControl

	| volumeSlider r |
	volumeSlider := SimpleSliderMorph new
		color: color;
		sliderColor: Color gray;
		extent: 80@2;
		target: scorePlayer;
		actionSelector: #overallVolume:;
		adjustToValue: scorePlayer overallVolume.
	r := self makeRow
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: 'soft  ' translated).
	r addMorphBack: volumeSlider.
	r addMorphBack: (StringMorph contents: ' loud' translated).
	^ r
! !


!ScorePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
instrumentChoicesForTrack: trackIndex
	| names inst |

	names := AbstractSound soundNames asOrderedCollection.
	names := names collect: [:n |
		inst := AbstractSound soundNamed: n.
		(inst isKindOf: UnloadedSound)
			ifTrue: [n, '(out)']
			ifFalse: [n]].
	names add: 'clink'.
	names add: 'edit ', (instrumentSelector at: trackIndex) contents.
	^ names asArray
! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
invokeMenu
	"Invoke a menu of additonal functions for this ScorePlayer."

	| aMenu |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu add: 'open a MIDI file' translated action: #openMIDIFile.
	aMenu addList: {
		#-.
		{'save as AIFF file' translated.	#saveAsAIFF}.
		{'save as WAV file' translated.		#saveAsWAV}.
		{'save as Sun AU file' translated.	#saveAsSunAudio}.
		#-}.
	aMenu add: 'reload instruments' translated target: AbstractSound selector: #updateScorePlayers.
	aMenu addLine.
	scorePlayer midiPort
		ifNil: [
			aMenu add: 'play via MIDI' translated action: #openMIDIPort]
		ifNotNil: [
			aMenu add: 'play via built in synth' translated action: #closeMIDIPort.
			aMenu add: 'new MIDI controller' translated action: #makeMIDIController:].
	aMenu addLine.
	aMenu add: 'make a pause marker' translated action: #makeAPauseEvent:.

	aMenu popUpInWorld: self world.
! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
makeAPauseEvent: evt

	| newWidget |

	newWidget := AlignmentMorph newRow.
	newWidget 
		color: Color orange; 
		borderWidth: 0; 
		layoutInset: 0;
		hResizing: #shrinkWrap; 
		vResizing: #shrinkWrap; 
		extent: 5@5;
		addMorph: (StringMorph contents: '[pause]' translated) lock;
		addMouseUpActionWith: (
			MessageSend receiver: self selector: #showResumeButtonInTheWorld
		).

	evt hand attachMorph: newWidget.! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
saveAsAIFF
	"Create a stereo AIFF audio file with the result of performing my score."

	| fileName |
	fileName := FillInTheBlank request: 'New file name?' translated.
	fileName isEmpty ifTrue: [^ self].
	(fileName asLowercase endsWith: '.aif') ifFalse: [
		fileName := fileName, '.aif'].

	scorePlayer storeAIFFOnFileNamed: fileName.
! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
saveAsSunAudio
	"Create a stereo Sun audio file with the result of performing my score."

	| fileName |
	fileName := FillInTheBlank request: 'New file name?' translated.
	fileName isEmpty ifTrue: [^ self].
	(fileName asLowercase endsWith: '.au') ifFalse: [
		fileName := fileName, '.au'].

	scorePlayer storeSunAudioOnFileNamed: fileName.
! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
saveAsWAV
	"Create a stereo WAV audio file with the result of performing my score."

	| fileName |
	fileName := FillInTheBlank request: 'New file name?' translated.
	fileName isEmpty ifTrue: [^ self].
	(fileName asLowercase endsWith: '.wav') ifFalse: [
		fileName := fileName, '.wav'].

	scorePlayer storeWAVOnFileNamed: fileName.
! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateInstrumentsFromLibraryExcept: soundsBeingEdited
	"The instrument library has been modified. Update my instruments with the new versions from the library. Use a single instrument prototype for all parts with the same name; this allows the envelope editor to edit all the parts by changing a single sound prototype."

	"soundsBeingEdited is a collection of sounds being edited (by an EnvelopeEditor).  If any of my instruments share one of these, then they will be left alone so as not to disturb that dynamic linkage."

	| unloadPostfix myInstruments name displaysAsUnloaded isUnloaded |
	unloadPostfix := '(out)'.
	myInstruments := Dictionary new.
	1 to: instrumentSelector size do: [:i |
		name := (instrumentSelector at: i) contents.
		displaysAsUnloaded := name endsWith: unloadPostfix.
		displaysAsUnloaded ifTrue: [
			name := name copyFrom: 1 to: name size - unloadPostfix size].
		(myInstruments includesKey: name) ifFalse: [
			myInstruments at: name put:
				(name = 'clink'
					ifTrue: [
						(SampledSound
							samples: SampledSound coffeeCupClink
							samplingRate: 11025) copy]
					ifFalse: [
						(AbstractSound
							soundNamed: name
							ifAbsent: [
								(instrumentSelector at: i) contentsClipped: 'default'.
								FMSound default]) copy])].
		(soundsBeingEdited includes: (scorePlayer instrumentForTrack: i)) ifFalse:
			["Do not update any instrument that is currently being edited"
			scorePlayer instrumentForTrack: i put: (myInstruments at: name)].

		"update loaded/unloaded status in instrumentSelector if necessary"
		isUnloaded := (myInstruments at: name) isKindOf: UnloadedSound.
		(displaysAsUnloaded and: [isUnloaded not])
			ifTrue: [(instrumentSelector at: i) contentsClipped: name].
		(displaysAsUnloaded not and: [isUnloaded])
			ifTrue: [(instrumentSelector at: i) contentsClipped: name, unloadPostfix]].
! !


!ScorePlayerMorph methodsFor: 'rounding' stamp: 'di 10/22/2000 23:42'!
wantsRoundedCorners
	^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! !


!ScorePlayerMorph methodsFor: 'stepping and presenter' stamp: 'di 6/15/1999 11:48'!
step

	scrollSlider adjustToValue: scorePlayer positionInScore.

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScorePlayerMorph class
	instanceVariableNames: ''!

!ScorePlayerMorph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 17:27'!
initialize

	FileList registerFileReader: self! !

!ScorePlayerMorph class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
playMidiFile: fullName
	"Play a MIDI file."
 
	| f score |
	Smalltalk at: #MIDIFileReader ifPresent: [:midiReader |
			f := (FileStream oldFileNamed: fullName) binary.
			score := (midiReader new readMIDIFrom: f) asScore.
			f close.
			self openOn: score title: (FileDirectory localNameFor: fullName)]
! !

!ScorePlayerMorph class methodsFor: 'class initialization' stamp: 'sw 2/17/2002 02:45'!
servicePlayMidiFile
	"Answer a service for opening player on a midi file"

	^ SimpleServiceEntry 
		provider: self 
		label: 'open in midi player'
		selector: #playMidiFile:
		description: 'open the midi-player tool on this file'
		buttonLabel: 'open'! !


!ScorePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:37'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'mid') | (suffix = '*') 
		ifTrue: [ self services]
		ifFalse: [#()]
! !

!ScorePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:21'!
services

	^ Array with: self servicePlayMidiFile

	! !


!ScorePlayerMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'!
unload

	FileList unregisterFileReader: self ! !


!ScorePlayerMorph class methodsFor: 'parts bin' stamp: 'sw 10/20/2001 17:17'!
descriptionForPartsBin
	^ self partName: 	'ScorePlayer'
		categories:		#('Multimedia')
		documentation:	' Mediates between a score such as a MIDIScore, a PianoRollScoreMorph, and the actual SoundPlayer synthesizer'! !


!ScorePlayerMorph class methodsFor: 'system hookup' stamp: 'stephaneducasse 2/4/2006 20:41'!
onMIDIFileNamed: fileName
	"Return a ScorePlayerMorph on the score from the MIDI file of the given name."

	| score player |
	score := MIDIFileReader scoreFromFileNamed: fileName	.
	player := ScorePlayer onScore: score.
	^ self new onScorePlayer: player title: fileName
! !

!ScorePlayerMorph class methodsFor: 'system hookup' stamp: 'stephaneducasse 2/4/2006 20:41'!
openOn: aScore title: aString

	| player |
	player := ScorePlayer onScore: aScore.
	(self new onScorePlayer: player title: aString) openInWorld.
! !
Controller subclass: #ScreenController
	instanceVariableNames: ''
	classVariableNames: 'LastScreenModeSelected'
	poolDictionaries: ''
	category: 'ST80-Kernel-Remnants'!
!ScreenController commentStamp: '<historical>' prior: 0!
I am the controller for the parts of the display screen that have no view on them. I only provide a standard yellow button menu. I view (a FormView of) an infinite gray form.  (ScheduledControllers screenController) is the way to find me.!


!ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:21'!
controlActivity
	"Any button opens the screen's menu.
	If the shift key is down, do find window."

	sensor leftShiftDown ifTrue: [^ self findWindow].
	(self projectScreenMenu invokeOn: self) ifNil: [super controlActivity]! !

!ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:06'!
isControlActive
	^ self isControlWanted! !

!ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:05'!
isControlWanted
	^ self viewHasCursor and: [sensor anyButtonPressed]! !


!ScreenController methodsFor: 'cursor'!
centerCursorInView
	"Override so this doesn't happen when taking control"! !


!ScreenController methodsFor: 'file in/out' stamp: 'tk 9/28/2000 15:47'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	dp _ DiskProxy global: #ScheduledControllers selector: #screenController args: #().
	refStrm replace: self with: dp.
	^ dp! !


!ScreenController methodsFor: 'menu messages' stamp: 'nk 7/29/2004 10:12'!
aboutThisSystem 
	SmalltalkImage current aboutThisSystem! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 10/13/1998 16:03'!
absorbUpdatesFromServer 
	Utilities updateFromServer! !

!ScreenController methodsFor: 'menu messages' stamp: 'dao 10/1/2004 13:23'!
beIsolated
	"Establish this project as an isolation layer.
	Further method changes made here will be revoked when you leave the project."

	Project current beIsolated
	! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:25'!
bitCachingString
	^ StandardSystemView cachingBits
		ifTrue: ['don''t save bits (compact)']
		ifFalse: ['save bits (fast)']! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 5/23/2003 15:17'!
browseChangedMessages
	ChangeSet  browseChangedMessages! !

!ScreenController methodsFor: 'menu messages'!
browseRecentSubmissions
	"Open a method-list browser on recently-submitted methods.  5/16/96 sw"

	Utilities browseRecentSubmissions! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:50'!
changeWindowPolicy
	Preferences toggleWindowPolicy! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 4/13/1998 23:13'!
chooseDirtyWindow
	"Put up a list of windows with unaccepted edits and let the user chose one to activate."
	"ScheduledControllers screenController chooseDirtyWindow"

	ScheduledControllers findWindowSatisfying:
		[:c | c model canDiscardEdits not].
! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 4/13/1998 23:13'!
closeUnchangedWindows
	"Close any window that doesn't have unaccepted input."

	| clean |
	(SelectionMenu confirm:
'Do you really want to close all windows
except those with unaccepted edits?')
		ifFalse: [^ self].

	clean _ ScheduledControllers scheduledControllers select:
		[:c | c model canDiscardEdits and: [(c isKindOf: ScreenController) not]].
	clean do: [:c | c closeAndUnscheduleNoTerminate].
	self restoreDisplay.
! !

!ScreenController methodsFor: 'menu messages'!
collapseAll
	"Collapses all open windows"
	ScheduledControllers scheduledControllers do:
		[:controller | controller == self ifFalse:
			[controller view isCollapsed ifFalse:
					[controller collapse.
					controller view deEmphasize]]]! !

!ScreenController methodsFor: 'menu messages'!
commonRequests 
	"Put up a popup of common requests, and perform whatever the user request.  2/1/96 sw"
	Utilities offerCommonRequests! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 12/10/1999 11:29'!
configureFonts
	Preferences presentMvcFontConfigurationMenu! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 9/22/1998 15:09'!
durableChangesMenu 
	Utilities windowFromMenu: self changesMenu target: self title: 'Changes'! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:01'!
durableHelpMenu 
	| aMenu selectionList labelList targetList i wordingList colorPattern |
	aMenu _ self helpMenu.
	selectionList _ aMenu selections.
	labelList _ (1 to: selectionList size) collect:
		[:ind | aMenu labelString lineNumber: ind].
	targetList _  (1 to: selectionList size) collect: [:ind | self].

	(i _ labelList indexOf: 'keep this menu up') > 0 ifTrue:
		[selectionList _ selectionList copyReplaceFrom: i to: i with: Array new.
		labelList _ labelList copyReplaceFrom: i to: i with: Array new.
		targetList _ targetList copyReplaceFrom: i to: i with: Array new].

	colorPattern _ #(lightRed lightGreen lightBlue lightYellow lightGray lightCyan lightMagenta lightOrange).

	wordingList _ selectionList collect:
		[:aSelection |
			(aSelection == #soundOnOrOff) ifTrue: [#soundEnablingString] ifFalse: [nil]].
	^ Utilities windowMenuWithLabels: labelList colorPattern: colorPattern  targets: targetList selections: selectionList wordingSelectors: wordingList title: 'Help'

! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 11/25/1998 12:21'!
durableOpenMenu 
	| colorPattern |
	colorPattern _ #(blue lightGreen lightYellow lightMagenta  lightOrange lightCyan) asOrderedCollection.
	colorPattern add: Project someInstance backgroundColorForMvcProject.
	colorPattern add: Project someInstance backgroundColorForMorphicProject.
	colorPattern add: #orange.
	Utilities windowFromMenu: self openMenu target: self title: 'Openers'
		colorPattern: colorPattern! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 9/22/1998 14:36'!
durableScreenMenu 
	Utilities windowFromMenu: self projectScreenMenu target: self title: 'Squeak'! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:28'!
durableWindowMenu 
	| aMenu selectionList labelList targetList i wordingList colorPattern |
	aMenu _ self windowMenu.
	selectionList _ aMenu selections.
	labelList _ (1 to: selectionList size) collect:
		[:ind | aMenu labelString lineNumber: ind].
	targetList _  (1 to: selectionList size) collect: [:ind | self].

	(i _ labelList indexOf: 'keep this menu up') > 0 ifTrue:
		[selectionList _ selectionList copyReplaceFrom: i to: i with: Array new.
		labelList _ labelList copyReplaceFrom: i to: i with: Array new.
		targetList _ targetList copyReplaceFrom: i to: i with: Array new].

	colorPattern _ #(lightRed lightGreen lightBlue lightYellow lightGray lightCyan lightMagenta lightOrange).

	wordingList _ selectionList collect:
		[:aSelection |
			(#(fastWindows changeWindowPolicy) includes: aSelection)
				ifFalse:
					[nil]
				ifTrue:
					[aSelection == #fastWindows
						ifFalse:
							[#staggerPolicyString]
						ifTrue:
							[#bitCachingString]]].
	^ Utilities windowMenuWithLabels: labelList colorPattern: colorPattern  targets: targetList selections: selectionList wordingSelectors: wordingList title: 'windows'

! !

!ScreenController methodsFor: 'menu messages'!
editPreferences
	"Open up a Preferences inspector.  2/7/96 sw"

	Preferences openPreferencesInspector! !

!ScreenController methodsFor: 'menu messages'!
emergencyCollapse
	"Emergency collapse of a selected window"
	| controller |
	(controller _ ScheduledControllers windowFromUser) notNil
		ifTrue:
			[controller collapse.
			controller view deEmphasize]! !

!ScreenController methodsFor: 'menu messages' stamp: 'dao 10/1/2004 13:14'!
exitProject 
	"Leave the current Project and enter the Project in which the receiver's 
	view is scheduled."

	Project current exit! !

!ScreenController methodsFor: 'menu messages'!
expandAll
	"Reopens all collapsed windows"
	ScheduledControllers scheduledControllers reverseDo:
		[:controller | controller == self ifFalse:
			[controller view isCollapsed
				ifTrue:  [controller view expand]
				ifFalse: [controller view displayDeEmphasized]]]! !

!ScreenController methodsFor: 'menu messages'!
fastWindows
	StandardSystemView cachingBits
		ifTrue: [StandardSystemView dontCacheBits]
		ifFalse: [StandardSystemView doCacheBits]! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 2/3/2000 16:23'!
fileForRecentLog
	Smalltalk writeRecentToFile! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 1/16/2004 21:32'!
fileOutChanges
	ChangeSet current verboseFileOut.! !

!ScreenController methodsFor: 'menu messages'!
findWindow
	"Put up a menu of all windows on the screen, and let the user select one.
	 1/18/96 sw: the real work devolved to ControlManager>>findWindowSatisfying:"

	ScheduledControllers findWindowSatisfying: [:c | true]! !

!ScreenController methodsFor: 'menu messages' stamp: 'nk 6/17/2003 14:39'!
fontSizeSummary
	TextStyle fontSizeSummary! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 6/7/2003 19:49'!
fullScreenOff

	Display fullScreenMode: (LastScreenModeSelected _ false).
	DisplayScreen checkForNewScreenSize.
	self restoreDisplay.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 6/7/2003 19:49'!
fullScreenOn

	Display fullScreenMode: (LastScreenModeSelected _ true).
	DisplayScreen checkForNewScreenSize.
	self restoreDisplay.! !

!ScreenController methodsFor: 'menu messages' stamp: 'nk 2/15/2004 09:37'!
garbageCollect
	"Do a garbage collection, and report results to the user."

	Utilities garbageCollectAndReport! !

!ScreenController methodsFor: 'menu messages' stamp: 'jm 5/20/1998 23:28'!
jumpToProject

	Project jumpToProject.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 5/23/2003 14:41'!
lookForSlips
	ChangeSet current lookForSlips! !

!ScreenController methodsFor: 'menu messages' stamp: 'ar 9/27/2005 20:11'!
newChangeSet
	ChangeSet newChangeSet! !

!ScreenController methodsFor: 'menu messages' stamp: 'ar 9/27/2005 20:33'!
openBrowser 
	"Create and schedule a Browser view for browsing code."
	ToolSet browse: nil selector: nil! !

!ScreenController methodsFor: 'menu messages'!
openCommandKeyHelp
	"1/18/96 sw Open a window that explains command-keys"

	Utilities openCommandKeyHelp! !

!ScreenController methodsFor: 'menu messages' stamp: 'md 8/28/2005 00:20'!
openMorphicProject
	"Open a morphic project from within a MVC project"
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].
	ProjectView open: Project newMorphic.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 11/26/1999 08:56'!
openMorphicWorld 
	"Create and schedule a StringHolderView for use as a workspace."
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].
	MorphWorldView openWorld.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 4/24/2001 12:00'!
openProject 
	"Create and schedule a Project."

	| proj |
	Smalltalk at: #ProjectView ifPresent:
		[:c | proj _ Project new.
		c open: proj].
! !

!ScreenController methodsFor: 'menu messages'!
openStandardWorkspace
	"Open a standard, throwaway window chock full of useful expressions.  1/17/96 sw"

	Utilities openStandardWorkspace! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 5/8/1998 12:49'!
openTranscript 
	"Create and schedule the System Transcript."
	Transcript open! !

!ScreenController methodsFor: 'menu messages' stamp: 'ar 9/27/2005 20:46'!
openWorkspace 
	"Create and schedule workspace."

	UIManager default edit:'' label: 'Workspace'! !

!ScreenController methodsFor: 'menu messages' stamp: 'dao 10/1/2004 13:38'!
propagateChanges
	"The changes made in this isolated project will be propagated to projects above."

	Project current propagateChanges! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 11/16/2003 14:17'!
quit
	SmalltalkImage current
		snapshot:
			(self confirm: 'Save changes before quitting?' translated
				orCancel: [^ self])
		andQuit: true! !

!ScreenController methodsFor: 'menu messages' stamp: 'ar 3/18/2001 00:00'!
restoreDisplay 
	"Clear the screen to gray and then redisplay all the scheduled views."

	Smalltalk isMorphic ifTrue: [^ World restoreMorphicDisplay].

	Display extent = DisplayScreen actualScreenSize
		ifFalse:
			[DisplayScreen startUp.
			ScheduledControllers unCacheWindows].
	ScheduledControllers restore! !

!ScreenController methodsFor: 'menu messages' stamp: 'jm 5/22/1998 06:45'!
returnToPreviousProject

	Project returnToPreviousProject.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 11/16/2003 13:17'!
saveAs
	^ SmalltalkImage current saveAs! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 5/10/96'!
setAuthorInitials
	"Put up a dialog allowing the user to specify the author's initials.  "
	Utilities setAuthorInitials! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 11/26/96'!
setDesktopColor
	"Let the user choose a new color for the desktop.   Based on an idea by Georg Gollmann.   "

	Preferences desktopColor: Color fromUser.
	ScheduledControllers updateGray; restore! !

!ScreenController methodsFor: 'menu messages' stamp: 'bf 9/18/1999 20:01'!
setDisplayDepth
	"Let the user choose a new depth for the display. "
	| result |
	(result _ (SelectionMenu selections: Display supportedDisplayDepths) startUpWithCaption: 'Choose a display depth
(it is currently ' , Display depth printString , ')') == nil ifFalse:
		[Display newDepth: result]! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 11/16/2003 14:17'!
snapshot
	SmalltalkImage current snapshot: true andQuit: false! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 11/16/2003 14:17'!
snapshotAndQuit
	"Snapshot and quit without bother the user further.  2/4/96 sw"

	SmalltalkImage current
		snapshot: true
		andQuit: true! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:01'!
soundEnablingString
	^ Preferences soundEnablingString! !

!ScreenController methodsFor: 'menu messages' stamp: 'bf 3/16/2000 18:26'!
soundOnOrOff
	Preferences setPreference: #soundsEnabled
		toValue: Preferences soundsEnabled not! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:23'!
staggerPolicyString
	^ Preferences staggerPolicyString! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 5/29/2000 00:26'!
standardGraphicsLibrary
	"Open a standard, throwaway window chock full of useful expressions.  1/17/96 sw"

	ScriptingSystem inspectFormDictionary! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 5/11/2003 22:04'!
viewImageImports
	"Open an inspector on forms imported from Image files."

	Imports default viewImages! !

!ScreenController methodsFor: 'menu messages' stamp: 'sd 9/30/2003 13:53'!
vmStatistics
	"Open a string view on a report of vm statistics"

	(StringHolder new contents: SmalltalkImage current  vmStatisticsReportString)
		openLabel: 'VM Statistics'! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 7/13/1999 20:19'!
windowSpecificationPanel
	Smalltalk hasMorphic ifFalse:
		[^ self inform: 'Sorry, this feature requires the presence of Morphic.'].
	Preferences windowSpecificationPanel! !


!ScreenController methodsFor: 'nested menus' stamp: 'sw 12/10/1999 11:29'!
appearanceMenu 
	"Answer the appearance menu to be put up as a screen submenu"

	^ SelectionMenu labelList:
		#(	'window colors...'
			'system fonts...'
			'full screen on'
			'full screen off'
			'set display depth...'
			'set desktop color...' ) 

		lines: #(2 4)
		selections: #(windowSpecificationPanel configureFonts
fullScreenOn fullScreenOff setDisplayDepth setDesktopColor)
"
ScreenController new appearanceMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 6/4/2000 23:47'!
changesMenu
	"Answer a menu for changes-related items"
	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'simple change sorter'
			'dual change sorter'

			'file out current change set'
			'create new change set...'
			'browse changed methods'
			'check change set for slips'

			'isolate methods of this project'
			'propagate changes above'

			'browse recent submissions'
			'recently logged changes...'
			'recent log file...'
			)
		lines: #(1 3 7 9)
		selections: #(durableChangesMenu
openSimpleChangeSorter openChangeManager
fileOutChanges newChangeSet browseChangedMessages lookForSlips
beIsolated propagateChanges
browseRecentSubmissions browseRecentLog fileForRecentLog)
"
ScreenController new changesMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'md 7/22/2005 21:30'!
helpMenu 
	"Answer the help menu to be put up as a screen submenu"

	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'about this system...'
			'update code from server'
			'preferences...'

			'command-key help'
			'font size summary'
			'useful expressions'
			'view graphical imports'
			'standard graphics library'),

			(Array with: (Preferences soundsEnabled
							ifFalse: ['turn sound on']
							ifTrue: ['turn sound off'])) ,

		#(	'set author initials...'
			'vm statistics'
			'space left')
		lines: #(1 4 6 11)
		selections: #(durableHelpMenu aboutThisSystem absorbUpdatesFromServer
editPreferences  openCommandKeyHelp fontSizeSummary openStandardWorkspace viewImageImports
standardGraphicsLibrary soundOnOrOff setAuthorInitials vmStatistics garbageCollect)
"
ScreenController new helpMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 6/5/2000 17:21'!
openMenu
	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'browser'
			'package browser'
			'method finder'
			'workspace'
			'file list'
			'file...'
			'transcript'
			'morphic world'

			'simple change sorter'
			'dual change sorter'

			'mvc project'
			'morphic project'
			)
		lines: #(1 9 11)
		selections: #(durableOpenMenu
openBrowser openPackageBrowser openSelectorBrowser openWorkspace openFileList openFile openTranscript openMorphicWorld
openSimpleChangeSorter openChangeManager
openProject  openMorphicProject  )
"
ScreenController  new openMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sma 3/11/2000 12:23'!
popUpMenuFor: aSymbol
	(self perform: aSymbol) invokeOn: self! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/13/1999 18:07'!
presentAppearanceMenu
	self popUpMenuFor: #appearanceMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:14'!
presentChangesMenu
	self popUpMenuFor: #changesMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:15'!
presentHelpMenu
	self popUpMenuFor: #helpMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:15'!
presentOpenMenu
	self popUpMenuFor: #openMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:16'!
presentWindowMenu
	self popUpMenuFor: #windowMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/13/1999 18:07'!
projectScreenMenu
	"Answer the project screen menu."

	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'previous project'
			'jump to project...'
			'restore display'

			'open...'
			'windows...'
			'changes...'
			'help...'
			'appearance...'
			'do...'

			'save'
			'save as...'
			'save and quit'
			'quit')
		lines: #(1 4 10)
		selections: #(durableScreenMenu
returnToPreviousProject jumpToProject restoreDisplay
presentOpenMenu presentWindowMenu presentChangesMenu presentHelpMenu presentAppearanceMenu commonRequests
snapshot saveAs snapshotAndQuit quit )
"
ScreenController new projectScreenMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 6/11/1999 20:25'!
windowMenu
	"Answer a menu for windows-related items.  "

	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'find window...'
			'find changed browsers...'
			'find changed windows...'

			'collapse all windows'
			'expand all windows'
			'close unchanged windows' ) , 
			(Array
				with: self bitCachingString
				with: self staggerPolicyString)
		lines: #(1 4 7)
		selections: #(durableWindowMenu
findWindow chooseDirtyBrowser chooseDirtyWindow
collapseAll expandAll closeUnchangedWindows
fastWindows changeWindowPolicy)
"
ScreenController new windowMenu startUp
"! !


!ScreenController methodsFor: '*Tools' stamp: 'ab 8/22/2003 18:39'!
browseRecentLog
	"Open a changelist browser on changes submitted since the last snapshot.  1/17/96 sw"

	ChangeList browseRecentLog! !

!ScreenController methodsFor: '*Tools' stamp: 'tk 4/13/1998 23:12'!
chooseDirtyBrowser
	"Put up a list of browsers with unsubmitted edits and activate the one selected by the user, if any."
	"ScheduledControllers screenController chooseDirtyBrowser"

	ScheduledControllers findWindowSatisfying:
		[:c | (c model isKindOf: Browser) and: [c model canDiscardEdits not]].
 ! !

!ScreenController methodsFor: '*Tools'!
openChangeManager
	"Open a dual change sorter.  For looking at two change sets at once."
	DualChangeSorter new open! !

!ScreenController methodsFor: '*Tools' stamp: 'sw 6/9/1999 12:30'!
openFile
	FileList openFileDirectly! !

!ScreenController methodsFor: '*Tools'!
openFileList
	"Create and schedule a FileList view for specifying files to access."

	FileList open! !

!ScreenController methodsFor: '*Tools' stamp: 'ar 1/31/2001 17:06'!
openPackageBrowser 
	"Create and schedule a Browser view for browsing code."

	PackagePaneBrowser openBrowser! !

!ScreenController methodsFor: '*Tools' stamp: 'tk 8/31/1998 16:18'!
openSelectorBrowser
	"Create and schedule a selector fragment window."

	SelectorBrowser new open! !

!ScreenController methodsFor: '*Tools' stamp: 'sw 7/6/1998 18:59'!
openSimpleChangeSorter
	ChangeSorter new open! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScreenController class
	instanceVariableNames: ''!

!ScreenController class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 09:28'!
lastScreenModeSelected

	^LastScreenModeSelected! !
FullVocabulary subclass: #ScreenedVocabulary
	instanceVariableNames: 'methodScreeningBlock categoryScreeningBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!

!ScreenedVocabulary methodsFor: 'enumeration' stamp: 'sw 1/5/2001 06:55'!
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
	"Answer a list of all methods in the vocabulary which are in the given category, on behalf of the given class and object"

	^ (super allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass) select:
		[:aSelector | self includesSelector: aSelector]! !

!ScreenedVocabulary methodsFor: 'enumeration' stamp: 'sw 12/14/2000 14:03'!
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given object/class, considering only code implemented in mostGenericClass and lower"

	^ (super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass) select:
		[:aCategory | categoryScreeningBlock value: aCategory]! !


!ScreenedVocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoryScreeningBlock: aBlock
	"Set the receiver's categoryScreeningBlock to the block provided"

	categoryScreeningBlock := aBlock! !

!ScreenedVocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	vocabularyName :=  #Public.
	self documentation: '"Public" is vocabulary that excludes categories that start with "private" and methods that start with "private" or "pvt"'! !

!ScreenedVocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
methodScreeningBlock: aBlock
	"Set the receiver's methodScreeningBlock to the block provided"

	methodScreeningBlock := aBlock! !


!ScreenedVocabulary methodsFor: 'queries' stamp: 'sw 12/14/2000 14:06'!
includesSelector: aSelector
	"Answer whether the given selector is known to the vocabulary"

	^ methodScreeningBlock value: aSelector! !

!ScreenedVocabulary methodsFor: 'queries' stamp: 'sw 12/14/2000 06:01'!
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
	"Answer whether the vocabulary includes the given selector for the given object, only considering method implementations in mostGenericClass and lower"

	^ (super includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass) and:
		[self includesSelector: aSelector]! !
Morph subclass: #ScreeningMorph
	instanceVariableNames: 'screenForm displayMode passingColor passElseBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!ScreeningMorph commentStamp: '<historical>' prior: 0!
ScreeningMorph uses its first submorph as a screen, and its second submorph as a source.  It also wants you to choose (when showing only the screen) the passing color in the screen.  It then makes up a 1-bit mask which clips the source, and displays transparently outside it.!


!ScreeningMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 13:43'!
passElseBlock: aBool
	passElseBlock _ aBool.! !

!ScreeningMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 13:42'!
passingColor: aColor
	passingColor _ aColor.! !


!ScreeningMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:57'!
fullDrawOn: aCanvas 
	| mergeForm |
	submorphs isEmpty ifTrue: [^super fullDrawOn: aCanvas].
	(aCanvas isVisible: self fullBounds) ifFalse: [^self].
	(submorphs size = 1 or: [displayMode == #showScreenOnly]) 
		ifTrue: [^aCanvas fullDrawMorph: self screenMorph].
	displayMode == #showSourceOnly 
		ifTrue: [^aCanvas fullDrawMorph: self sourceMorph].
	displayMode == #showScreenOverSource 
		ifTrue: 
			[aCanvas fullDrawMorph: self sourceMorph.
			^aCanvas fullDrawMorph: self screenMorph].
	displayMode == #showScreened 
		ifTrue: 
			[aCanvas fullDrawMorph: self screenMorph.
			self flag: #fixCanvas.	"There should be a more general way than this"
			mergeForm := self sourceMorph 
						imageFormForRectangle: self screenMorph bounds.
			(BitBlt current toForm: mergeForm) 
				copyForm: self screenForm
				to: 0 @ 0
				rule: Form and
				colorMap: (Bitmap with: 0 with: 4294967295).
			aCanvas paintImage: mergeForm at: self screenMorph position]! !


!ScreeningMorph methodsFor: 'e-toy support' stamp: 'dgd 8/29/2004 11:04'!
wantsRecolorHandle
	"Answer whether the receiver would like a recolor handle to be  
	put up for it. We'd want to disable this but for the moment  
	that would cut off access to the button part of the properties  
	sheet. So this remains a loose end."
	^ false! !


!ScreeningMorph methodsFor: 'geometry testing'!
containsPoint: aPoint
	submorphs size = 2 ifFalse: [^ super containsPoint: aPoint].
	^ self screenMorph containsPoint: aPoint! !


!ScreeningMorph methodsFor: 'initialization' stamp: 'panda 4/25/2000 15:42'!
initialize
	super initialize.
	passingColor _ Color black.
	passElseBlock _ true.
	displayMode _ #showScreened.
	self enableDragNDrop! !


!ScreeningMorph methodsFor: 'layout' stamp: 'panda 4/25/2000 15:43'!
layoutChanged

	screenForm _ nil.
	submorphs size >= 2
		ifTrue: [self disableDragNDrop]
		ifFalse: [self enableDragNDrop].
	submorphs size = 2 ifTrue:
		[bounds _ ((self sourceMorph bounds merge: self screenMorph bounds) expandBy: 4)].
	^ super layoutChanged! !


!ScreeningMorph methodsFor: 'menu' stamp: 'dgd 10/8/2003 19:51'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	submorphs isEmpty ifTrue:
		[^ aCustomMenu add: '*Please add a source morph*' translated action: #itself].
	submorphs size = 1 ifTrue:
		[^ aCustomMenu add: '*Please add a screen morph*' translated action: #itself].
	submorphs size > 2 ifTrue:
		[^ aCustomMenu add: '*I have too many submorphs*' translated action: #itself].
	aCustomMenu add: 'show screen only' translated action: #showScreenOnly.
	aCustomMenu add: 'show source only' translated action: #showSourceOnly.
	aCustomMenu add: 'show screen over source' translated action: #showScreenOverSource.
	aCustomMenu add: 'show source screened' translated action: #showScreened.
	aCustomMenu add: 'exchange source and screen' translated action: #exchange.
	displayMode == #showScreenOnly ifTrue:
		[aCustomMenu add: 'choose passing color' translated action: #choosePassingColor.
		aCustomMenu add: 'choose blocking color' translated action: #chooseBlockingColor].
! !

!ScreeningMorph methodsFor: 'menu' stamp: 'di 6/3/1999 16:41'!
chooseBlockingColor
	passingColor _ Color fromUser.
	passElseBlock _ false.
	self layoutChanged! !

!ScreeningMorph methodsFor: 'menu' stamp: 'di 6/3/1999 16:41'!
choosePassingColor
	passingColor _ Color fromUser.
	passElseBlock _ true.
	self layoutChanged! !

!ScreeningMorph methodsFor: 'menu'!
exchange
	submorphs swap: 1 with: 2.
	self changed! !

!ScreeningMorph methodsFor: 'menu'!
showScreenOnly
	displayMode _ #showScreenOnly.
	self changed! !

!ScreeningMorph methodsFor: 'menu'!
showScreenOverSource
	displayMode _ #showScreenOverSource.
	self changed! !

!ScreeningMorph methodsFor: 'menu'!
showScreened
	displayMode _ #showScreened.
	self changed! !

!ScreeningMorph methodsFor: 'menu'!
showSourceOnly
	displayMode _ #showSourceOnly.
	self changed! !


!ScreeningMorph methodsFor: 'submorphs-add/remove' stamp: 'di 6/4/1999 08:25'!
addMorph: aMorph

	| f |
	super addMorph: aMorph.
	submorphs size <= 2 ifTrue:
		[self bounds: submorphs last bounds].
	submorphs size = 2 ifTrue:
		["The screenMorph has just been added.
		Choose as the passingColor the center color of that morph"
		f _ self screenMorph imageForm.
		passingColor _ f colorAt: f boundingBox center.
		passElseBlock _ true]! !


!ScreeningMorph methodsFor: 'private' stamp: 'ar 8/10/2003 18:12'!
removedMorph: aMorph

	submorphs size = 1 ifTrue:
		[self bounds: submorphs first bounds].
	super removedMorph: aMorph.! !

!ScreeningMorph methodsFor: 'private' stamp: 'aoy 2/15/2003 21:40'!
screenForm
	| screenImage colorMap pickValue elseValue |
	screenForm ifNotNil: [^screenForm].
	passElseBlock ifNil: [passElseBlock := true].
	passingColor ifNil: [passingColor := Color black].
	elseValue := passElseBlock 
		ifTrue: 
			[pickValue := 4294967295.
			 0]
		ifFalse: 
			[pickValue := 0.
			 4294967295].
	screenImage := self screenMorph 
				imageFormForRectangle: self screenMorph bounds.
	colorMap := screenImage newColorMap atAllPut: elseValue.
	colorMap at: (passingColor indexInMap: colorMap) put: pickValue.
	screenForm := Form extent: screenImage extent.
	screenForm 
		copyBits: screenForm boundingBox
		from: screenImage
		at: 0 @ 0
		colorMap: colorMap.
	^screenForm! !

!ScreeningMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:57'!
screenMorph
	^submorphs first! !

!ScreeningMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:53'!
sourceMorph
	^submorphs second! !
SimpleButtonMorph subclass: #ScriptActivationButton
	instanceVariableNames: 'uniclassScript'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!ScriptActivationButton commentStamp: 'sw 3/11/2003 00:24' prior: 0!
A button associated with a particular player and script.  You can "tear off" such a button for any etoy script, using menu items available in both Viewers and Scriptors.  The button initially is given a label reflecting its player and script name, but this can be edited via the button's halo menu, as can its other appearance parameters.  Such buttons are automatically kept in synch when the object's name or the script name change.!


!ScriptActivationButton methodsFor: 'access' stamp: 'sw 3/10/2003 23:57'!
uniclassScript
	"Answer the receiver's uniclassScript.  For old buttons, this might initially be nil but will get set, when possible herein."

	^ uniclassScript ifNil:
		[uniclassScript _ target class scripts at: arguments first ifAbsent: [nil]]! !


!ScriptActivationButton methodsFor: 'e-toy support' stamp: 'nk 9/3/2004 16:06'!
localeChanged
	"Do nothing"! !


!ScriptActivationButton methodsFor: 'initialization' stamp: 'sw 3/11/2003 00:31'!
initializeForPlayer: aPlayer uniclassScript: aUniclassScript
	"Initialize the receiver for the given player and uniclass script"

	target _ aPlayer.
	uniclassScript _ aUniclassScript.
	actionSelector _ #runScript:.
	arguments _ Array with: uniclassScript selector.
	self establishLabelWording
	! !


!ScriptActivationButton methodsFor: 'label' stamp: 'yo 11/30/2005 14:14'!
establishLabelWording
	"Set the label wording, unless it has already been manually edited"

	| itsName |
	itsName _ target externalName.
	(self hasProperty: #labelManuallyEdited)
		ifFalse:
			[self label: (itsName, ' ', arguments first)].
	self setBalloonText: 
		('click to run the script "{1}" in player named "{2}"' translated format: {arguments first. itsName}).
! !

!ScriptActivationButton methodsFor: 'label' stamp: 'sw 10/1/1999 21:42'!
isTileScriptingElement
	^ true! !


!ScriptActivationButton methodsFor: 'menu' stamp: 'sw 3/2/2004 20:58'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add morph-specific items to the given menu which was invoked by the given hand."

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu addLine.
	aMenu add: 'open underlying scriptor' translated target: target selector: #openUnderlyingScriptorFor: argument: arguments first

! !


!ScriptActivationButton methodsFor: 'miscellaneous' stamp: 'sw 3/11/2003 00:35'!
bringUpToDate
	"The object's name, or the script name, or both, may have changed.  Make sure I continue to look and act right"

	uniclassScript ifNotNil:
		[arguments _ Array with: uniclassScript selector].
	self establishLabelWording! !

!ScriptActivationButton methodsFor: 'miscellaneous' stamp: 'sw 2/28/2001 21:42'!
setLabel
	"Allow the user to enter a new label for this button"

	| newLabel existing |
	existing _ self label.
	newLabel _ FillInTheBlank
		request: 'Please enter a new label for this button'
		initialAnswer: existing.
	(newLabel isEmptyOrNil not and: [newLabel ~= existing]) ifTrue:
		[self setProperty: #labelManuallyEdited toValue: true.
		self label: newLabel].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScriptActivationButton class
	instanceVariableNames: ''!

!ScriptActivationButton class methodsFor: 'scripting' stamp: 'sw 9/26/2001 04:26'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (
			(slot color 'The color of the object' Color readWrite Player getColor  Player  setColor:)
			(slot height  'The height' Number readWrite Player getHeight  Player  setHeight:) 
			(slot borderColor 'The color of the object''s border' Color readWrite Player getBorderColor Player  setBorderColor:)
			(slot borderWidth 'The width of the object''s border' Number readWrite Player getBorderWidth Player setBorderWidth:)
			(slot roundedCorners 'Whether corners should be rounded' Boolean readWrite Player getRoundedCorners Player setRoundedCorners:) 
			(slot actWhen 'When the script should fire' ButtonPhase  readWrite Player getActWhen Player setActWhen: ))))! !
AlignmentMorph subclass: #ScriptEditorMorph
	instanceVariableNames: 'scriptName firstTileRow timeStamp playerScripted handWithTile showingMethodPane threadPolygon'
	classVariableNames: 'WritingUniversalTiles'
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!ScriptEditorMorph commentStamp: '<historical>' prior: 0!
Presents an EToy script to the user on the screen.  Has in it:

a Morph with the controls for the script.
a Morph with the tiles.  Either PhraseMorphs and TileMorphs, 
	or a TwoWayScroller with SyntaxMorphs in it.

WritingUniversalTiles -- only vlaid while a project is being written out.  
		True if using UniversalTiles in that project.!


!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 2/16/98 02:03'!
morph
	^ self playerScripted costume! !

!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 11/3/1998 17:20'!
myMorph
	"Answer the morph that serves as the costume of my associated player.  If for some reason I have no associated player, answer nil"

	| aPlayer |
	^ (aPlayer _ self playerScripted) ifNotNil: [aPlayer costume]! !

!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 12/15/2004 15:19'!
printOn: aStream
	^ aStream nextPutAll: 'ScriptEditor for #', scriptName asString, ' player: ', playerScripted externalName! !

!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 4/30/1998 14:34'!
scriptInstantiation
	^ playerScripted scriptInstantiationForSelector: scriptName! !


!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 9/2/2004 18:45'!
addDestroyButtonTo: aRowMorph 
	"Add the destroiy button at the end of the header provided"

	| aButton |
	aButton _ self pinkXButton.
	aRowMorph addMorphBack: aButton.
	aButton actionSelector: #destroyScript;
			 setBalloonText: 'Destroy this script
(CAUTION!!!!)' translated.
	^ aRowMorph! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 8/31/2004 14:05'!
addDismissButtonTo: aRowMorph
	"Add the brown dismiss button to the header"

	| aButton |
	aButton _ self tanOButton.
	aRowMorph addMorphBack: aButton.
	aButton actionSelector: #dismiss;
			setBalloonText: 
'Remove this script
from the screen
(you can open it
again from a Viewer)' translated.
	^ aRowMorph! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'kfr 1/24/2006 21:23'!
addYesNoToHand
	"Place a test/yes/no complex in the hand of the beloved user"

	| ms messageNodeMorph aMorph |
	Preferences universalTiles
		ifTrue:
			[ms _ MessageSend receiver: true selector: #ifTrue:ifFalse:
						arguments: {['do nothing']. ['do nothing']}.
			messageNodeMorph _ ms asTilesIn: playerScripted class globalNames: true.
			self primaryHand attachMorph: messageNodeMorph]
		ifFalse:
			[aMorph _ CompoundTileMorph new.
			ActiveHand attachMorph: aMorph.
			aMorph setNamePropertyTo: 'TestTile' translated.
			aMorph position: ActiveHand position.
			aMorph formerPosition: ActiveHand position.
			self startSteppingSelector: #trackDropZones.]! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'tak 12/22/2004 12:59'!
buttonRowForEditor
	"Answer a row of buttons that comprise the header at the top of the Scriptor"

	| aRow aString buttonFont aStatusMorph aButton aColumn aTile |
	buttonFont _ Preferences standardButtonFont.
	aRow _ AlignmentMorph newRow color: Color transparent; layoutInset: 0.
	aRow hResizing: #shrinkWrap.
	aRow vResizing: #shrinkWrap.
	self hasParameter ifFalse:
		[aRow addMorphFront:
			(SimpleButtonMorph new
				label: '!!' font: Preferences standardEToysFont;
				target: self;
				color: Color yellow;
				borderWidth: 0;
				actWhen: #whilePressed;
				actionSelector: #tryMe;
				balloonTextSelector: #tryMe).
		aRow addTransparentSpacerOfSize: 6@10].
	self addDismissButtonTo: aRow.
	aRow addTransparentSpacerOfSize: 6@1.
	aColumn _ AlignmentMorph newColumn beTransparent.
	aColumn addTransparentSpacerOfSize: 0@4.
	aButton _ UpdatingThreePhaseButtonMorph checkBox.
	aButton
		target: self;
		actionSelector: #toggleWhetherShowingTiles;
		getSelector: #showingMethodPane.
	aButton setBalloonText: 'toggle between showing tiles and showing textual code' translated.
	aColumn addMorphBack: aButton.
	aRow addMorphBack: aColumn.

	aRow addTransparentSpacerOfSize: 6@10.

	aString _ playerScripted externalName.
	aRow addMorphBack:
		(aButton _ SimpleButtonMorph new useSquareCorners label: aString font: buttonFont; target: self; setNameTo: 'title').
	aButton actWhen: #buttonDown; actionSelector: #offerScriptorMenu.
	aButton
		on: #mouseEnter send: #menuButtonMouseEnter: to: aButton;
		on: #mouseLeave send: #menuButtonMouseLeave: to: aButton.

	aButton borderColor: (Color fromRgbTriplet: #(0.065 0.258 1.0)).
	aButton color: ScriptingSystem uniformTileInteriorColor.
	aButton balloonTextSelector: #offerScriptorMenu.
	aRow addTransparentSpacerOfSize: 4@1.
	aButton _ (Preferences universalTiles ifTrue: [SyntaxUpdatingStringMorph] 
					ifFalse: [UpdatingStringMorph]) new.
	aButton useStringFormat;
		target:  self;
		getSelector: #scriptTitle;
		setNameTo: 'script name';
		font: ScriptingSystem fontForNameEditingInScriptor;
		putSelector: #setScriptNameTo:;
		setProperty: #okToTextEdit toValue: true;
		step;
		yourself.
	aRow addMorphBack: aButton.
	aButton setBalloonText: 'Click here to edit the name of the script.' translated.
	aRow addTransparentSpacerOfSize: 6@0.
	self hasParameter
		ifTrue:
			[aTile _ TypeListTile new choices: Vocabulary typeChoices dataType: nil.
			aTile addArrows.
			aTile setLiteral: #Number.
	"(aButton _ SimpleButtonMorph new useSquareCorners label: 'parameter' translated font: buttonFont; target: self; setNameTo: 'parameter').
			aButton actWhen: #buttonDown; actionSelector: #handUserParameterTile.

"
			aRow addMorphBack: aTile.
			aTile borderColor: Color red.
			aTile color: ScriptingSystem uniformTileInteriorColor.
			aTile setBalloonText: 'Drag from here to get a parameter tile' translated]
		ifFalse:
			[aRow addMorphBack: (aStatusMorph _ self scriptInstantiation statusControlMorph)].

	aRow addTransparentSpacerOfSize: 6@1.

	aRow addMorphBack:
		(IconicButton new borderWidth: 0;
			labelGraphic: (ScriptingSystem formAtKey: 'AddTest'); color: Color transparent; 
			actWhen: #buttonDown;
			target: self;
			actionSelector: #addYesNoToHand;
			shedSelvedge;
			balloonTextSelector: #addYesNoToHand).
	aRow addTransparentSpacerOfSize: 12@10.
	self addDestroyButtonTo: aRow.
	(playerScripted existingScriptInstantiationForSelector: scriptName)
		ifNotNilDo:
			[:inst | inst updateStatusMorph: aStatusMorph].
	^ aRow! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'dgd 9/1/2003 14:00'!
chooseFrequency
	| currentFrequency aMenu |
	currentFrequency _ self scriptInstantiation frequency.
	currentFrequency = 0 ifTrue: [currentFrequency _ 1].
	aMenu _ MenuMorph new defaultTarget: self.
	#(1 2 5 10 25 50 100 1000 5000 10000) do:
		[:i | aMenu add: i printString selector: #setFrequencyTo: argument: i].
	
	aMenu add: 'other...' translated action: #typeInFrequency.
	aMenu addTitle: ('Choose frequency (current: {1})' translated format: {currentFrequency}).
	aMenu  popUpEvent: self currentEvent in: self world! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/23/2001 10:53'!
chooseTrigger
	"NB; the keyStroke branch commented out temporarily until keystrokes can actually be passed along to the user's scripting code"
	
	self presentScriptStatusPopUp! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'dgd 9/1/2003 14:59'!
destroyScript
	"At user request, and only after confirmation, destroy the script, thus removing it from the uniclass's method dictionary and removing its instantiations from all instances of uniclass, etc."

	(self confirm: 'Caution -- this destroys this script
permanently; are you sure you want to do this?' translated) ifFalse: [^ self].
	true ifTrue: [^ playerScripted removeScript: scriptName fromWorld: self world].

	self flag: #deferred.  "revisit"
	(playerScripted okayToDestroyScriptNamed: scriptName)
		ifFalse:
			[^ self inform: 'Sorry, this script is being called
from another script.' translated].

	self actuallyDestroyScript! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 11/2/2004 16:41'!
dismiss
	"Dismiss the scriptor, usually nondestructively"

	owner ifNil: [^ self].
	scriptName ifNil: [^ self delete].  "ad hoc fixup for bkwrd compat"
	(playerScripted isExpendableScript: scriptName) ifTrue: [playerScripted removeScript: scriptName  fromWorld: self world].
	handWithTile _ nil.
	self delete! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 3/24/2005 01:55'!
editMethodDescription
	"Edit the balloon help associated with the script"

	self userScriptObject editDescription.
	playerScripted updateAllViewers! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 7/18/2002 02:42'!
hasParameter
	"Answer whether the receiver has a parameter"

	^ scriptName numArgs > 0! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/20/2001 00:43'!
install
	"Accept the current classic tiles as the new source code for the script.  In the case of universalTiles, initialize the method and its methodInterface if not already done."

	Preferences universalTiles ifFalse:
		[self removeSpaces].
	scriptName ifNotNil:
		[playerScripted acceptScript: self topEditor for:  scriptName asSymbol]! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/12/98 13:25'!
installWithNewLiteral

	self removeSpaces.
	scriptName ifNotNil:
		[playerScripted ifNotNil: [playerScripted acceptScript: self topEditor for:  scriptName]]! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 10/21/1999 12:34'!
makeIsolatedCodePane
	MethodHolder makeIsolatedCodePaneForClass: playerScripted class selector: scriptName! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/29/98 18:30'!
playerScripted
	^ playerScripted! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'RAA 9/24/2000 17:50'!
replaceRow1

	submorphs first delete.  "the button row"
	self addMorphFront: self buttonRowForEditor.  "up to date"
! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 12/15/2004 20:37'!
restoreScriptName: aScriptName
	"For fixup only..."

	scriptName _ aScriptName! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/29/98 18:37'!
scriptee
	| editor |
	playerScripted ifNotNil: [^ playerScripted].
	(editor _ self topEditor) == self ifTrue: [self error: 'unattached script editor'. ^ nil].
	^ editor scriptee! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/29/98 03:26'!
scriptName
	^ scriptName! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'tk 3/9/2001 10:42'!
scriptTitle

	^ Preferences universalTiles 
		ifTrue: [SyntaxMorph new substituteKeywordFor: scriptName] 
				"spaces instead of capitals, no colons"
				"Don't use property #syntacticallyCorrectContents.  
				  scriptName here holds the truth"
		ifFalse: [scriptName].
! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/15/2001 20:04'!
showSourceInScriptor
	"Remove tile panes, if any, and show textual source instead"

	| aCodePane |

	self isTextuallyCoded ifFalse: [self becomeTextuallyCoded].
		"Mostly to fix up grandfathered ScriptEditors"

	self removeAllButFirstSubmorph.

	aCodePane _ MethodHolder 
		isolatedCodePaneForClass: playerScripted class 
		selector: scriptName.

	aCodePane
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		minHeight: 100.
	self 
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	self addMorphBack: aCodePane.
	self fullBounds.
	self 
		listDirection: #topToBottom;
		hResizing: #rigid;
		vResizing: #rigid;
		rubberBandCells: true;
		minWidth: self width.

	showingMethodPane _ true.
	self currentWorld startSteppingSubmorphsOf: self! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'nk 8/21/2004 12:16'!
tryMe
	"Evaluate the given script on behalf of the scripted object"

	scriptName numArgs = 0
		ifTrue:
			[self playerScripted performScriptIfCan: scriptName ]

! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 5/25/2004 16:57'!
updateStatus
	"Update that status in the receiver's header.  "

	(self topEditor == self and: [firstTileRow ~~ 1]) ifTrue:
		[(submorphs size == 0 or: [(self firstSubmorph findA: ScriptStatusControl) isNil])
			ifTrue:
				[self replaceRow1].
		self updateStatusMorph: (self firstSubmorph findA: ScriptStatusControl)]! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 7/20/2002 14:30'!
updateStatusMorph: statusMorph
	"My status button may need to reflect an externally-induced change in status"

	(playerScripted existingScriptInstantiationForSelector: scriptName) ifNotNilDo:
		[:scriptInstantiation |
			scriptInstantiation updateStatusMorph: statusMorph]! !


!ScriptEditorMorph methodsFor: 'caching' stamp: 'sw 11/2/2004 16:40'!
releaseCachedState
	"Release any state that could be recomputed"

	super releaseCachedState.
	handWithTile _ nil.
	self hibernate! !

!ScriptEditorMorph methodsFor: 'caching' stamp: 'sw 11/2/2004 17:00'!
resetHandWithTile
	"Set the handWithTile back to nil, in case it somehow got to be nonnil"

	handWithTile _ nil! !


!ScriptEditorMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 16:57'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
playerScripted _ deepCopier references at: playerScripted ifAbsent: [playerScripted].
! !

!ScriptEditorMorph methodsFor: 'copying' stamp: 'yo 3/11/2005 22:18'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	scriptName _ scriptName veryDeepCopyWith: deepCopier.
	firstTileRow _ firstTileRow veryDeepCopyWith: deepCopier.
	timeStamp _ timeStamp veryDeepCopyWith: deepCopier.
	playerScripted _ playerScripted.		"Weakly copied"
	handWithTile _ nil.  "Just a cache"
	showingMethodPane _ showingMethodPane.	"boolean"
	threadPolygon _ nil. "Just a cache".

! !


!ScriptEditorMorph methodsFor: 'customevents-buttons' stamp: 'nk 4/23/2004 07:28'!
actuallyDestroyScript
	"Carry out the actual destruction of the associated script."

	| aHandler itsCostume |
	self delete.
	playerScripted class removeScriptNamed: scriptName.
	playerScripted actorState instantiatedUserScriptsDictionary removeKey: scriptName ifAbsent: [].
		"not quite enough yet in the multiple-instance case..."
	itsCostume _ playerScripted costume.
	(aHandler _ itsCostume renderedMorph eventHandler) ifNotNil:
		[aHandler forgetDispatchesTo: scriptName].
	itsCostume removeActionsSatisfying: [ :act | act receiver == playerScripted and: [ act selector == scriptName ]].
	itsCostume currentWorld removeActionsSatisfying: [ :act | act receiver == playerScripted and: [ act selector == scriptName ]].
	playerScripted updateAllViewersAndForceToShow: ScriptingSystem nameForScriptsCategory! !


!ScriptEditorMorph methodsFor: 'customevents-other' stamp: 'nk 11/1/2004 08:13'!
explainStatusAlternatives
	(StringHolder new contents: (ScriptingSystem statusHelpStringFor: playerScripted))
		openLabel: 'Script Status' translated! !


!ScriptEditorMorph methodsFor: 'drawing' stamp: 'sw 2/14/2001 18:12'!
drawOn: aCanvas
	"may need to unhibernate the script lazily here."

	(Preferences universalTiles and: [self submorphs size < 2])
		ifTrue:
			[WorldState addDeferredUIMessage: [self unhibernate] fixTemps].

	^ super drawOn: aCanvas! !


!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'ar 12/14/2001 17:41'!
acceptDroppingMorph: aMorph event: evt
	"Allow the user to add tiles and program fragments just by dropping them on this morph."

	| i slideMorph p1 p2 |

	self prepareToUndoDropOf: aMorph.
	"Find where it will go, and prepare to animate the move..."
	i _ self rowInsertionIndexFor: aMorph fullBounds center.
	slideMorph _ aMorph imageForm offset: 0@0.
	p1 _ aMorph screenRectangle topLeft.
	aMorph delete.
	self stopSteppingSelector: #trackDropZones.
	self world displayWorld.  "Clear old image prior to animation"

	(aMorph isKindOf: PhraseTileMorph) ifTrue:
		[aMorph justGrabbedFromViewer: false].
	aMorph tileRows do: [:tileList |
		self insertTileRow: (Array with:
				(tileList first rowOfRightTypeFor: owner forActor: aMorph associatedPlayer))
			after: i.
		i _ i + 1].
	self removeSpaces.
	self enforceTileColorPolicy.
	self layoutChanged.
	self fullBounds. "force layout"

	"Now animate the move, before next Morphic update.
		NOTE: This probably should use ZoomMorph instead"
	p2 _ (self submorphs atPin: (i-1 max: firstTileRow)) screenRectangle topLeft.
	slideMorph slideFrom: p1 to: p2 nSteps: 5 delay: 50 andStay: true.
	self playSoundNamed: 'scritch'.
	self topEditor install  "Keep me for editing, a copy goes into lastAcceptedScript"! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 7/22/2002 17:49'!
assureParameterTilesValid
	"Make certain that parameter tiles in my interior are still type valid; replace any that now intimate type errors"

	self isTextuallyCoded ifFalse:
		[(self allMorphs select: [:m | m isKindOf: ParameterTile]) do:
			[:aTile | aTile assureTypeStillValid].
		self install]! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'di 10/20/97 08:22'!
indexOfMorphAbove: aPoint
	"Return index of lowest morph whose bottom is above aPoint.
	Will return 0 if the first morph is not above aPoint"
	submorphs doWithIndex:
		[:m :i | m fullBounds bottom >= aPoint y ifTrue:
					[^ (i max: firstTileRow) - 1]].
	^ submorphs size! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/24/98 17:28'!
prepareToUndoDropOf: aMorph
	"No longer functional"! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 4/10/2004 23:12'!
removeSpaces
	"Remove vertical space"

	self submorphsDo:
		[:m | (m isMemberOf: Morph) ifTrue: [m delete]].
	self removeEmptyRows.
	submorphs isEmpty ifTrue: [self height: 14]! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/14/2001 18:16'!
repelsMorph: aMorph event: ev
	"Answer whether the receiver shoul repel the given morph"

	^ Preferences universalTiles
		ifTrue:
			[(aMorph respondsTo: #parseNode) not]
		ifFalse:
			[aMorph isTileLike not]! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'ar 12/14/2001 17:42'!
trackDropZones
	"The fundamental heart of script-editor layout, by Dan Ingalls in fall 1997, though many hands have touched it since."

	| hand insertion i space1 d space2 insHt nxtHt prevBot ht2 c1 c2 ii where |
	hand _ handWithTile ifNil: [self primaryHand].
	((self hasOwner: hand) not and: [hand submorphCount > 0])
		ifTrue:
			[insertion _ hand firstSubmorph renderedMorph.
			insHt _ insertion fullBounds height.			self removeSpaces.
			where _ self globalPointToLocal: hand position"insertion fullBounds topLeft".
			i _ (ii _ self indexOfMorphAbove: where) min: submorphs size-1.
			prevBot _ i <= 0 ifTrue: [(self innerBounds) top]
							ifFalse: [(self submorphs at: i) bottom].
			nxtHt _ (submorphs isEmpty
				ifTrue: [insertion]
				ifFalse: [self submorphs at: i+1]) height.
			d _ ii > i ifTrue: [nxtHt "for consistent behavior at bottom"]
					ifFalse: [0 max: (where y - prevBot min: nxtHt)].

			"Top and bottom spacer heights cause continuous motion..."
			c1 _ Color green.  c2 _ Color transparent.
			ht2 _ d*insHt//nxtHt.
			space1 _ Morph newBounds: (0@0 extent: 30@(insHt-ht2))
                                        color: ((insHt-ht2) > (insHt//2+1) ifTrue: [c1] ifFalse: [c2]).
			self privateAddMorph: space1 atIndex: (i+1 max: 1).
			space2 _ Morph newBounds: (0@0 extent: 30@ht2)
                                        color: (ht2 > (insHt//2+1) ifTrue: [c1] ifFalse: [c2]).
			self privateAddMorph: space2 atIndex: (i+3 min: submorphs size+1)]
		ifFalse:
			[self stopSteppingSelector: #trackDropZones.
			self removeSpaces]! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 9/28/2001 07:07'!
wantsDroppedMorph: aMorph event: evt
	"Answer whether the receiver would be interested in accepting the morph"

	^ (aMorph isTileLike and: [self isTextuallyCoded not]) and:
		[(#(Command Unknown) includes: aMorph resultType capitalized)]! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 8/15/2000 16:58'!
willingToBeDiscarded
	"Resist the drag-into-trash gesture"

	^ false! !


!ScriptEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:51'!
handlesMouseOverDragging: evt

	^ true
! !

!ScriptEditorMorph methodsFor: 'event handling' stamp: 'tk 9/30/97 14:15'!
handlesMouseOver: evt

	^ true
! !

!ScriptEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:07'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!ScriptEditorMorph methodsFor: 'event handling' stamp: 'ar 12/14/2001 17:44'!
mouseEnter: evt
	| hand tile |

	self flag: #bob.		"needed renderedMorph due to transformations"
	hand _ evt hand.
	hand submorphs size = 1 ifFalse: [^self].
	tile _ hand firstSubmorph renderedMorph.
	(self wantsDroppedMorph: tile event: evt) ifFalse: [^self].
	handWithTile _ hand.
	self startSteppingSelector: #trackDropZones.! !

!ScriptEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!ScriptEditorMorph methodsFor: 'event handling' stamp: 'ar 12/14/2001 17:41'!
mouseLeave: evt
	owner ifNil: [^ self].	"left by being removed, not by mouse movement"
	(self hasProperty: #justPickedUpPhrase) ifTrue:[
		self removeProperty: #justPickedUpPhrase.
		^self].
	self stopSteppingSelector: #trackDropZones.
	handWithTile _ nil.
	self removeSpaces.! !


!ScriptEditorMorph methodsFor: 'e-toy support' stamp: 'tk 2/1/2001 22:37'!
adaptToWorld: aWorld

	self unhibernate	"for universal tiles"! !

!ScriptEditorMorph methodsFor: 'e-toy support' stamp: 'sw 7/28/1999 17:02'!
isCandidateForAutomaticViewing
	^ false! !

!ScriptEditorMorph methodsFor: 'e-toy support' stamp: 'ar 2/7/2001 17:57'!
isTileEditor
	"Yes I am"
	^true! !

!ScriptEditorMorph methodsFor: 'e-toy support' stamp: 'mir 7/15/2004 15:19'!
localeChanged
	"Update myself to reflect the change in locale"

	self fixLayout! !

!ScriptEditorMorph methodsFor: 'e-toy support' stamp: 'sw 12/4/1998 15:46'!
objectViewed
	^ self playerScripted costume! !

!ScriptEditorMorph methodsFor: 'e-toy support' stamp: 'yo 1/18/2004 10:34'!
replaceReferencesToSlot: oldSlotName inPlayer: aPlayer with: newSlotName
	"An instance variable has been renamed in a player; replace all references to the old instance variable of that player such that they become references to the new slot"

	self tileRows do: [:row |
		row do: [:c | c traverseRowTranslateSlotOld: oldSlotName of: aPlayer to: newSlotName]].
	self install.
	self fixLayout! !


!ScriptEditorMorph methodsFor: 'frequency' stamp: 'sw 4/21/1999 09:12'!
setFrequencyTo: aNumber
	self scriptInstantiation frequency: aNumber! !

!ScriptEditorMorph methodsFor: 'frequency' stamp: 'yo 2/14/2005 13:51'!
typeInFrequency
	| reply aNumber |
	reply _ FillInTheBlank request: 'Number of firings per tick: ' translated initialAnswer: self scriptInstantiation frequency printString.

	reply ifNotNil:
		[aNumber _ reply asNumber.
		aNumber > 0 ifTrue:
			[self setFrequencyTo: aNumber]]! !


!ScriptEditorMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ ScriptingSystem colorBehindTiles! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 8/28/2004 20:57'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 cellPositioning: #topLeft;
		 setProperty: #autoFitContents toValue: true;
	 layoutInset: 2;
	 useRoundedCorners.
	self setNameTo: 'Script Editor' translated.
	firstTileRow _ 1.
	"index of first tile-carrying submorph"
	self addNewRow.
	showingMethodPane _ false! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 4/10/2004 00:59'!
phrase: aPhraseTileMorph
	"Make the receiver be a Scriptor for a new script whose initial contents is the given phrase."

	| aHolder |
	firstTileRow _ 2.
	aHolder _ AlignmentMorph newRow.
	aHolder beTransparent; layoutInset: 0.
	aHolder addMorphBack: aPhraseTileMorph.
	self addMorphBack: aHolder.
	self install! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 2/4/98 00:45'!
playerScripted: aPlayer
	playerScripted _ aPlayer ! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 8/11/1998 16:58'!
setMorph: anActorMorph
	"Not really the way to do this any more"
	playerScripted _ anActorMorph player
! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 2/13/98 16:35'!
setMorph: anActorMorph scriptName: aString
	"Create a script editor for editing a named script."

	self setMorph: anActorMorph.
	scriptName _ aString.
	self addMorphFront: self buttonRowForEditor.
	self updateStatus.
	firstTileRow _ 2
! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 5/17/2001 15:40'!
updateHeader
	"Replace my header morph with another one assured of being structurally au courant"
	
	(firstTileRow notNil and: [firstTileRow > 1]) ifTrue:
		[self replaceRow1]! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 10/24/2004 17:41'!
updateToPlayer: newPlayer 
	"Make certain that the script name and the names of actors within are up to date"

	playerScripted ifNil: 
		["likely a naked test/yes/no fragment!!"
		^ self].
	newPlayer == playerScripted ifTrue: [^ self].	"Already points to him"
	self allMorphs do:  [:m | 
		(m isKindOf: TileMorph)  ifTrue: 
			[m retargetFrom: playerScripted to: newPlayer.
			m bringUpToDate]].
	playerScripted _ newPlayer.
	self replaceRow1! !


!ScriptEditorMorph methodsFor: 'menu' stamp: 'tk 8/22/2001 10:49'!
autoFitOnOff
	"Toggle between auto fit to size of code and manual resize with scrolling"
	| tw |
	(tw _ self findA: TwoWayScrollPane) ifNil: [^ self].
	(self hasProperty: #autoFitContents)
		ifTrue: [self removeProperty: #autoFitContents.
			self hResizing: #rigid; vResizing: #rigid]
		ifFalse: [self setProperty: #autoFitContents toValue: true.
			self hResizing: #shrinkWrap; vResizing: #shrinkWrap].
	tw layoutChanged! !

!ScriptEditorMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:06'!
autoFitString
	"Answer the string to put in a menu that will invite the user to 
	switch autoFit mode"
	^ ((self hasProperty: #autoFitContents)
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'auto fit' translated! !

!ScriptEditorMorph methodsFor: 'menu'!
fixLayout
	self fixLayoutOfSubmorphsNotIn: IdentitySet new! !

!ScriptEditorMorph methodsFor: 'menu'!
fixLayoutOfSubmorphsNotIn: aCollection 
	self
		allMorphsDo: [:m | (aCollection includes: m)
				ifFalse: [m ~~ self
						ifTrue: [(m respondsTo: #fixLayoutOfSubmorphsNotIn:)
								ifTrue: [m fixLayoutOfSubmorphsNotIn: aCollection]].
					m layoutChanged.
					aCollection add: m]]! !


!ScriptEditorMorph methodsFor: 'menus' stamp: 'yo 3/11/2005 22:19'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add custom menu items to a menu"

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addUpdating: #autoFitString target: self action: #autoFitOnOff.
	aCustomMenu addLine.
	aCustomMenu add: 'fix layout' target: self action: #fixLayout.
	threadPolygon ifNil: [
		aCustomMenu add: 'show thread' target: self action: #createThreadShowing.
	] ifNotNil: [
		aCustomMenu add: 'hide thread' target: self action: #deleteThreadShowing.
	].! !

!ScriptEditorMorph methodsFor: 'menus' stamp: 'sw 8/28/2004 20:55'!
wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph
	"Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)"

	(#(addDupHandle: addMakeSiblingHandle:) includes: aSelector) ifTrue:
		[^ false].

	^ super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph! !


!ScriptEditorMorph methodsFor: 'objects from disk' stamp: 'tk
11/29/2004 17:27'!
fixUponLoad: aProject seg: anImageSegment
	"We are in an old project that is being loaded from disk.
Fix up conventions that have changed."

	(aProject projectParameters at: #substitutedFont ifAbsent: [#none])
		 ~~ #none ifTrue: [ self setProperty:
#needsLayoutFixed toValue: true ].

	^ super fixUponLoad: aProject seg: anImageSegment! !


!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 11/1/2004 22:50'!
addParameter
	"Transform the receiver so that it bears a parameter.  This will require a selector change, e.g. from #script3 to #script3:"

	playerScripted startHavingParameterFor: scriptName asSymbol! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/16/2001 00:39'!
becomeTextuallyCoded
	"If the receiver is not currently textually coded, make it become so now, and show its source in place in the Scriptor"

	self isTextuallyCoded ifTrue: [^ self].
	self saveScriptVersion.
	Preferences universalTiles ifFalse: [self userScriptObject becomeTextuallyCoded].
	(submorphs copyFrom: 2 to: submorphs size) do: [:m | m delete]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 7/18/2002 10:26'!
ceaseHavingAParameter
	"Cease having a parameter"

	playerScripted ceaseHavingAParameterFor: scriptName! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 9/2/1999 15:16'!
codeString
	^ String streamContents: [:aStream | self storeCodeOn: aStream indent: 1]
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'dgd 9/1/2003 14:47'!
extent: x

	| newExtent tw menu |
	newExtent _ x max: self minWidth@self minHeight.
	(tw _ self findA: TwoWayScrollPane) ifNil:
		["This was the old behavior"
		^ super extent: newExtent].

	(self hasProperty: #autoFitContents) ifTrue: [
		menu _ MenuMorph new defaultTarget: self.
		menu addUpdating: #autoFitString target: self action: #autoFitOnOff.
		menu addTitle: 'To resize the script, uncheck the box below' translated.
		menu popUpEvent: nil in: self world	.
		^ self].

	"Allow the user to resize to any size"
	tw extent: ((newExtent x max: self firstSubmorph width)
				@ (newExtent y - self firstSubmorph height)) - (borderWidth*2) + (-4@-4).  "inset?"
	^ super extent: newExtent! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'dgd 9/1/2003 14:48'!
handUserButtonDownTile
	"Hand the user a button-down tile, presumably to drop in the script"
	
	
	self currentHand attachMorph:
		(self presenter systemQueryPhraseWithActionString: '(Sensor anyButtonPressed)' labelled: 'button down?' translated)
	! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'yo 3/15/2005 12:11'!
handUserButtonUpTile
	"Hand the user a button-up tile, presumably to drop in the script"
	
	
	self currentHand attachMorph:
		(self presenter systemQueryPhraseWithActionString: '(Sensor noButtonPressed)' labelled: 'button up?' translated)
	! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 7/2/2002 21:04'!
handUserParameterTile
	"Hand the user a parameter, presumably to drop in the script"
	
	| aTileMorph |
	aTileMorph _ ParameterTile new forScriptEditor: self.
	self currentHand attachMorph: aTileMorph! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/12/2001 21:50'!
handUserRandomTile
	"Hand the user a random-number tile, presumably to drop in the script"

	self currentHand attachMorph: RandomNumberTile new markAsPartsDonor makeAllTilesGreen

	! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 5/4/2001 07:25'!
handUserTileForSelf
	"Hand the user a tile representing the player who is current the 'self' of this script"

	playerScripted tileToRefer openInHand! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/23/98 01:07'!
hasScriptInvoking: aScriptName ofPlayer: aPlayer
	"Answer whether the receiver has any tiles in it which invoke the given script of the given player.  Place-holder for now, needs to be implemented"
	^ false! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'yo 1/14/2004 10:50'!
hasScriptReferencing: aSlotName ofPlayer: aPlayer
	"Answer whether the receiver has any tiles in it which reference the given slot of the given player.  By doing a text search on the decompiled method, this is able to work both with text and with tiles.  The approach is still not perfect, because we can't really know until run-time whom the getters and setters are sent to.  But practically speaking, this is all presumably a positive."

	| stringToSearch |
	"(aPlayer isKindOf: playerScripted class) ifFalse: [^ false]."

	stringToSearch _ (playerScripted class compiledMethodAt: scriptName) decompileString.
	{Utilities getterSelectorFor: aSlotName. Utilities setterSelectorFor: aSlotName} do:
		[:searchee |
			(stringToSearch findString: searchee startingAt: 1) = 0
				ifFalse:
					[^ true]]. 

	^ false! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'dgd 2/21/2003 23:03'!
hibernate
	"Possibly delete the tiles, but only if using universal tiles."

	| tw |
	Preferences universalTiles ifFalse: [^self].
	(tw := self findA: TwoWayScrollPane) isNil 
		ifFalse: 
			[self setProperty: #sizeAtHibernate toValue: self extent.	"+ tw xScrollerHeight"
			submorphs size > 1 ifTrue: [tw delete]]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'RAA 2/27/2001 15:55'!
insertUniversalTiles
	"Insert universal tiles for the method at hand"

	self removeAllButFirstSubmorph.
	"fix a broken header in weasel"
	submorphs isEmpty ifFalse: [
		self firstSubmorph vResizing: #shrinkWrap.
	].
	self insertUniversalTilesForClass: playerScripted class selector: scriptName! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'tk 3/11/2002 16:11'!
insertUniversalTilesForClass: aClass selector: aSelector
	"Add a submorph which holds the universal-tiles script for the given class and selector"

	| source tree syn widget header |
	source _ aClass sourceCodeAt: aSelector ifAbsent: [
		Transcript cr; show: aClass name, 'could not find selector ', aSelector.
		^ self delete].    
	tree _ Compiler new 
		parse: source 
		in: aClass 
		notifying: nil.
	(syn _ tree asMorphicSyntaxUsing: SyntaxMorph)
		parsedInClass: aClass.
	aSelector numArgs = 0 ifTrue: [
		"remove method header line"
		(header _ syn findA: SelectorNode) ifNotNil: [header delete]].
	syn removeReturnNode.		"if ^ self at end, remove it"
	widget _ syn inAScrollPane.
	widget hResizing: #spaceFill;
		vResizing: #spaceFill;
		color: Color transparent;
		setProperty: #hideUnneededScrollbars toValue: true.
	self addMorphBack: widget.
	(self hasProperty: #autoFitContents) ifFalse:
		[self valueOfProperty: #sizeAtHibernate ifPresentDo:
			[:oldExtent | self extent: oldExtent]].
	syn finalAppearanceTweaks.! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 7/16/1999 16:35'!
isEmpty
	^ submorphs size < firstTileRow! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 8/3/1998 15:08'!
isTextuallyCoded
	(self topEditor isKindOf: ScriptEditorMorph) ifFalse: [^ false].  "workaround for the case where the receiver is embedded in a free-standing CompoundTileMorph.  Yecch!!"
	^ self userScriptObject isTextuallyCoded! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'gm 2/22/2003 18:59'!
methodNodeMorph
	"Answer the morph that constitutes the receiver's method node"

	submorphs size < 2  ifTrue: [^ nil].
	^ self findDeepSubmorphThat:
		[:aMorph | (aMorph isSyntaxMorph) and:
				[aMorph parseNode isKindOf: MethodNode]]
			ifAbsent: [nil]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 10/20/2004 23:09'!
methodString
	"Answer the source-code string for the receiver.  This is for use by classic tiles, but is also used in universal tiles to formulate an initial method declaration for a nascent user-defined script; in universalTiles mode, the codeString (at present anyway) is empty -- the actual code derives from the SyntaxMorph in that case"

	| k methodNode string |
	playerScripted class compileSilently: (string _ String streamContents:
		[:aStream |
			aStream nextPutAll: scriptName.
			scriptName endsWithAColon ifTrue:
				[aStream nextPutAll: ' parameter'].
			aStream cr; cr; tab.
			aStream nextPutAll: self codeString.
	]) classified: 'temporary'.

	k _ KedamaVectorizer new initialize.
	(k includesTurtlePlayer: (playerScripted class decompile: scriptName) for: playerScripted) ifFalse: [^ string].

	methodNode _ k vectorize: (playerScripted class decompile: scriptName) 	object: playerScripted.
	^ methodNode decompileString.
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/20/2001 03:30'!
modernize
	"If the receiver appears to date from the past, try to fix it up"
	
	Preferences universalTiles ifFalse:
		[(self isTextuallyCoded and: [self showingMethodPane not]) ifTrue:
			["Fix up old guys that  are not showing the code in place"
			self showSourceInScriptor]]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'dgd 9/1/2003 14:54'!
offerScriptorMenu
	"Put up a menu in response to the user's clicking in the menu-request area of the scriptor's heaer"

	| aMenu  count |

	self modernize.
	ActiveHand showTemporaryCursor: nil.

	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: scriptName asString.

	Preferences universalTiles ifFalse:
		[count _ self savedTileVersionsCount.
		self showingMethodPane
			ifFalse:				"currently showing tiles"
				[aMenu add: 'show code textually' translated action: #showSourceInScriptor.
				count > 0 ifTrue: 
					[aMenu add: 'revert to tile version...' translated action:	 #revertScriptVersion].
				aMenu add: 'save this version' translated	action: #saveScriptVersion]

			ifTrue:				"current showing textual source"
				[count >= 1 ifTrue:
					[aMenu add: 'revert to tile version' translated action: #revertToTileVersion]]].

	aMenu addList: {
		#-.
		{'destroy this script' translated.					#destroyScript}.
		{'rename this script' translated.					#renameScript}.
		}.

	self hasParameter ifFalse:
		[aMenu addList: {{'button to fire this script' translated.			#tearOfButtonToFireScript}}].

	aMenu addList: {
		{'edit balloon help for this script' translated.		#editMethodDescription}.
		#-.
		{'explain status alternatives' translated. 			#explainStatusAlternatives}.
		#-.
		{'hand me a tile for self' translated.					#handUserTileForSelf}.
		{'hand me a "random number" tile' translated.		#handUserRandomTile}.
		{'hand me a "button down?" tile' translated.		#handUserButtonDownTile}.
		{'hand me a "button up?" tile' translated.			#handUserButtonUpTile}.
		}.

	aMenu addList: (self hasParameter
		ifTrue: [{
			#-.
			{'remove parameter' translated.					#ceaseHavingAParameter}}]
		ifFalse: [{
			{'fires per tick...' translated.						#chooseFrequency}.
			#-.
			{'add parameter' translated.						#addParameter}}]).

	aMenu popUpInWorld: self currentWorld.
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'ar 2/6/2001 22:07'!
recompileScript
	"A hook called in several places in the UI when something has been dragged & dropped into or out of the script."

	self install.
	"self stopScript"! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'di 2/19/2001 10:12'!
recreateScript
	| aUserScript |
	aUserScript _ playerScripted class userScriptForPlayer: playerScripted selector: scriptName.
	aUserScript recreateScriptFrom: self! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/30/2001 18:56'!
reinsertSavedTiles: savedTiles
	"Revert the scriptor to show the saved tiles"

	self submorphs doWithIndex: [:m :i | i > 1 ifTrue: [m delete]].
	self addAllMorphs: savedTiles.
	self allMorphsDo: [:m | m isTileScriptingElement ifTrue: [m bringUpToDate]].
	self install.
	self showingMethodPane: false! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/22/2001 15:22'!
renameScript
	"Rename the current script.  Invoked at user menu request"

	playerScripted renameScript: self scriptName! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 7/20/2002 14:34'!
renameScriptTo: newSelector
	"Rename the receiver's script so that it bears a new selector"

	| aMethodNodeMorph methodMorph methodSource pos newMethodSource |

	scriptName _ newSelector.
	self updateHeader.
	Preferences universalTiles
		ifFalse:  "classic tiles"
			[self showingMethodPane
				ifTrue:
					["textually coded -- need to change selector"
					methodMorph _ self findA: MethodMorph.
					methodSource _ methodMorph text string.
					pos _ methodSource indexOf: Character cr ifAbsent: [self error: 'no cr'].
					newMethodSource _ newSelector.
					newSelector numArgs > 0 ifTrue: [newMethodSource _ newMethodSource, ' t1'].  "for the parameter"
					newMethodSource _ newMethodSource, (methodSource copyFrom: pos to: methodSource size).
					methodMorph editString: newMethodSource.
					methodMorph model changeMethodSelectorTo: newSelector.
					playerScripted class compile: newMethodSource classified: 'scripts'.
					methodMorph accept]
				ifFalse:
					[self install]]
		ifTrue:  "universal tiles..."
			[(aMethodNodeMorph _ self methodNodeMorph) ifNotNil:
				[aMethodNodeMorph acceptInCategory: 'scripts']]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 4/30/1998 13:46'!
revertScriptVersion
	| aUserScript |
	aUserScript _ playerScripted class userScriptForPlayer: playerScripted selector: scriptName.
	aUserScript revertScriptVersionFrom: self! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 7/20/2002 14:31'!
setScriptNameTo: aNewName
	"The user has typed into the script-name pane.  Accept the changed contents as the new script name, and take action accordingly"

	playerScripted renameScript: self scriptName newSelector:
		(playerScripted acceptableScriptNameFrom: aNewName forScriptCurrentlyNamed:  self scriptName)! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 12/31/1998 17:54'!
setTimeStamp
	timeStamp _ Date today mmddyyyy, ' ', (Time now print24 copyFrom: 1 to: 8).
	^ timeStamp! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'aoy 2/15/2003 21:13'!
storeCodeOn: aStream indent: tabCount 
	| lastOwner |
	lastOwner := nil.
	self tileRows do: 
			[:r | 
			r do: 
					[:m | 
					((m isKindOf: TileMorph) 
						or: [(m isKindOf: CompoundTileMorph) or: [m isKindOf: PhraseTileMorph]]) 
							ifTrue: 
								[tabCount timesRepeat: [aStream tab].
								(m owner ~= lastOwner and: [lastOwner ~= nil]) 
									ifTrue: 
										[aStream
											nextPut: $.;
											cr;
											tab.
										]
									ifFalse: 
										[lastOwner ~= nil ifTrue: [aStream space].
										].
								m storeCodeOn: aStream indent: tabCount.
								lastOwner := m owner]]]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/5/2001 14:11'!
tearOfButtonToFireScript
	"Tear off a button to fire this script"

	playerScripted tearOffButtonToFireScriptForSelector: scriptName! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/20/2001 00:34'!
tileRows
	"If using classic tiles, return a collection of arrays of Tiles in which each array is one line of tiles.  (John Maloney's original design and code)."

	| rows r |
	rows _ OrderedCollection new.
	Preferences universalTiles ifTrue: [^ rows].
	firstTileRow to: submorphs size do: [:i |
		r _ submorphs at: i.
		r submorphCount > 0 ifTrue: [rows addLast: r submorphs]].
	^ rows
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/29/98 18:02'!
timeStamp
	^ timeStamp! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'em 3/29/2005 14:30'!
toggleWhetherShowingTiles
	"Toggle between showing the method pane and showing the tiles pane"

	self showingMethodPane
		ifFalse:				"currently showing tiles"
			[self showSourceInScriptor]

		ifTrue:				"current showing textual source"
			[Preferences universalTiles
				ifTrue: [^ self revertToTileVersion].
			self savedTileVersionsCount >= 1
				ifTrue:
					[(self userScriptObject lastSourceString = (playerScripted class compiledMethodAt: scriptName) decompileString)
						ifFalse:
							[(self confirm: 
'Caution -- this script was changed
textually; if you revert to tiles at this
point you will lose all the changes you
may have made textually.  Do you
really want to do this?' translated) ifFalse: [^ self]].
					self revertToTileVersion]
				ifFalse:
					[Beeper beep]]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'ar 11/25/2004 15:20'!
unhibernate
	"I have been loaded as part of an ImageSegment.
	Make sure that I am fixed up properly."
	| fixMe |
	(fixMe := self valueOfProperty: #needsLayoutFixed ifAbsent: [ false ])
		ifTrue: [self removeProperty: #needsLayoutFixed ].

	self topEditor == self
		ifFalse: [^ self]. "Part of a compound test"

	self updateHeader.
	fixMe ifTrue: [ self fixLayout. self removeProperty: #needsLayoutFixed ].

	"Recreate my tiles from my method if i have new universal tiles."

	self world
		ifNil: [(playerScripted isNil
					or: [playerScripted isUniversalTiles not])
				ifTrue: [^ self]]
		ifNotNil: [Preferences universalTiles
				ifFalse: [^ self]].
	self insertUniversalTiles.
	self showingMethodPane: false! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 4/10/2001 18:56'!
userScriptObject
	"Answer the user-script object associated with the receiver"

	| aPlayerScripted topEd |
	aPlayerScripted _ (topEd _ self topEditor) playerScripted.
	^ aPlayerScripted class userScriptForPlayer: aPlayerScripted selector: topEd scriptName ! !


!ScriptEditorMorph methodsFor: 'save & revert' stamp: 'RAA 1/16/2001 01:34'!
revertToTileVersion
	"The receiver, currently showing textual code,  is asked to revert to the last-saved tile version"

	| aUserScript |

	self 
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	aUserScript _ playerScripted class userScriptForPlayer: playerScripted selector: scriptName.
	aUserScript revertToLastSavedTileVersionFor: self.
	self currentWorld startSteppingSubmorphsOf: self! !

!ScriptEditorMorph methodsFor: 'save & revert' stamp: 'sw 1/30/2001 12:18'!
savedTileVersionsCount
	"Answer the number of saved tile versions that currently exist for this script"

	^ self userScriptObject savedTileVersionsCount! !

!ScriptEditorMorph methodsFor: 'save & revert' stamp: 'sw 5/19/1998 14:12'!
saveScriptVersion
	self userScriptObject saveScriptVersion: self setTimeStamp! !


!ScriptEditorMorph methodsFor: 'scripting' stamp: 'dgd 2/21/2003 23:03'!
bringUpToDate
	"Make certain that the player name in my header is up to date.  Names emblazoned on submorphs of mine are handled separately by direct calls to their #bringUpToDate methods -- the responsibility here is strictly for the name in the header."

	| currentName |
	playerScripted ifNil: 
			["likely a naked test/yes/no fragment!!"

			^self].
	currentName := playerScripted externalName.
	submorphs isEmpty ifTrue: [^self].
	(self firstSubmorph findDeepSubmorphThat: [:m | m knownName = 'title']
		ifAbsent: [^self]) label: currentName font: ScriptingSystem fontForTiles! !

!ScriptEditorMorph methodsFor: 'scripting' stamp: 'sw 4/21/1998 21:34'!
isTileScriptingElement
	^ true! !


!ScriptEditorMorph methodsFor: 'submorphs-add/remove' stamp: 'sw 11/15/2001 12:30'!
dismissViaHalo
	"The user has clicked in the delete halo-handle.  This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example."

	self resistsRemoval ifTrue: [^ self].
	self destroyScript! !


!ScriptEditorMorph methodsFor: 'testing' stamp: 'sw 7/18/2002 02:43'!
setParameterType: typeChosen
	"Set the parameter type as indicated"

	playerScripted setParameterFor: scriptName toType: typeChosen! !

!ScriptEditorMorph methodsFor: 'testing' stamp: 'tk 9/30/97 14:09'!
stepTime

	^ 0! !

!ScriptEditorMorph methodsFor: 'testing' stamp: 'sw 7/22/2002 18:24'!
typeForParameter
	"Answer a symbol representing the type of my parameter"

	scriptName numArgs > 0 ifTrue:
		[(playerScripted class scripts at: scriptName ifAbsent: [nil]) ifNotNilDo:
			[:aScript | ^ aScript argumentVariables first variableType]].

	^ #Error! !


!ScriptEditorMorph methodsFor: 'textually-coded scripts' stamp: 'sw 10/30/2000 11:09'!
showingMethodPane
	"Answer whether the receiver is currently showing the textual method pane"

	^ showingMethodPane ifNil: [showingMethodPane _ false]! !

!ScriptEditorMorph methodsFor: 'textually-coded scripts' stamp: 'tk 11/14/2000 13:54'!
showingMethodPane: val
	"Whether the receiver will show the textual method pane"

	showingMethodPane _ val! !


!ScriptEditorMorph methodsFor: 'tiles from method' stamp: 'sw 2/20/2001 02:03'!
fromExistingMethod: aSelector forPlayer: aPlayer 
	"Create tiles for this method.  "

	self initialize.
	playerScripted _ aPlayer.
	self setMorph: aPlayer costume scriptName: aSelector.
	self insertUniversalTiles! !


!ScriptEditorMorph methodsFor: 'private' stamp: 'ar 11/9/2000 20:43'!
addNewRow

	| row |
	row _ AlignmentMorph newRow
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		extent: (bounds width)@(TileMorph defaultH);
		color: Color transparent.
	self addMorphBack: row.
	^ row
! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'ar 11/9/2000 20:43'!
insertTileRow: tileList after: index
	"Return a row to be used to insert an entire row of tiles."

	| row |
	row _ AlignmentMorph newRow
		vResizing: #spaceFill;
		layoutInset: 0;
		extent: (bounds width)@(TileMorph defaultH);
		color: Color transparent.
	row addAllMorphs: tileList.
	self privateAddMorph: row atIndex: index + 1.
! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'ar 1/27/2001 14:44'!
removeEmptyRows
	submorphs copy do: [:m |
		(m isAlignmentMorph and: [m submorphCount = 0])
			ifTrue: [m delete]].
self flag: #arNote. "code below lead to large and unnecessary recomputations of layouts; without it things just fly"
"	self fullBounds.
	self layoutChanged."

	self flag: #noteToJohn.  "Screws up when we have nested IFs.  got broken in 11/97 when you made some emergency fixes for some other reason, and has never worked since...  Would be nice to have a more robust reaction to this!!"
"
	self removeEmptyLayoutMorphs.

	spacer _ LayoutMorph new extent: 10@12.
	spacer vResizing: #rigid.
	self privateAddMorph: spacer atIndex: self indexForLeadingSpacer.

	spacer _ LayoutMorph new  extent: 10@12.
	spacer vResizing: #rigid.
	self privateAddMorph: spacer atIndex: (submorphs size + 1).

	self fullBounds; layoutChanged."
! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'sw 2/13/98 15:44'!
rowInsertionIndexFor: aPoint
	"Return the row into which the given morph should be inserted."

	| m |
	firstTileRow to: submorphs size do: [:i |
		m _ submorphs at: i.
		((m top <= aPoint y) and: [m bottom >= aPoint y]) ifTrue:
			[(aPoint y > m center y)
				ifTrue: [^ i]
				ifFalse: [^ (i - 1) max: firstTileRow]]].
	^ firstTileRow > submorphs size
		ifTrue:
			[submorphs size]
		ifFalse:
			[(submorphs at: firstTileRow) top > aPoint y 
				ifTrue: [firstTileRow - 1]
				ifFalse: [submorphs size]]
! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'ar 2/6/2001 22:07'!
scriptEdited

	| anEditor |
	(anEditor _ self topEditor) ifNotNil: [anEditor recompileScript]! !


!ScriptEditorMorph methodsFor: 'menu commands' stamp: 'yo 1/26/2005 14:56'!
createThreadShowing

	| vertices b |
	self deleteThreadShowing.
	vertices _ OrderedCollection new.
	self tileRows do: [:row |
		row first isTurtleRow ifTrue: [
			b _ row first bounds.
			vertices add: ((b topLeft + (4@0)) + ((0 * 0.1 * b width)@0)).
			0 to: 9 do: [:i |
				vertices add: ((b topLeft + (4@4))+ ((i * 0.1 * b width )@0)).
				vertices add: ((b bottomLeft + (4@-4)) + ((i * 0.1 * b width)@0)).
			].	
			vertices add: ((b bottomLeft + (4@0)) + ((9 * 0.1 * b width)@0)).
		] ifFalse: [
			b _ row first bounds.
			vertices add: ((b origin x + b corner x)//2)@(b origin y).
			vertices add: ((b origin x + b corner x)//2)@(b origin y + 4).
			vertices add: ((b origin x + b corner x)//2)@(b corner y - 4).
			vertices add: ((b origin x + b corner x)//2)@(b corner y).
		].
	].
	threadPolygon _ PolygonMorph vertices: vertices color: Color black borderWidth: 2 borderColor: Color black.
	threadPolygon makeOpen.
	threadPolygon openInWorld.
! !

!ScriptEditorMorph methodsFor: 'menu commands' stamp: 'yo 1/26/2005 14:56'!
deleteThreadShowing

	threadPolygon ifNotNil: [threadPolygon delete. threadPolygon _ nil].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScriptEditorMorph class
	instanceVariableNames: ''!

!ScriptEditorMorph class methodsFor: 'instance creation' stamp: 'tk 1/31/2001 09:48'!
writingUniversalTiles
	"Only valid during the write of a Project."

	^ WritingUniversalTiles! !

!ScriptEditorMorph class methodsFor: 'instance creation' stamp: 'tk 1/31/2001 09:48'!
writingUniversalTiles: boolean

	WritingUniversalTiles _ boolean! !


!ScriptEditorMorph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
Object subclass: #ScriptInstantiation
	instanceVariableNames: 'player selector status frequency anonymous tickingRate lastTick'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!ScriptInstantiation commentStamp: '<historical>' prior: 0!
One of these is associated with each user-defined script for each Player.   Holds the state that defines when the script should be run automatically by the system.

	player				The player whose script this is.
	selector				The message to send my player to activate this script
	status				#ticking, #paused, #normal, #mouseDown, #mouseStillDown, #mouseUp,
							#mouseEnter, #mouseLeave, #keyStroke
	frequency			For ticking scripts, their frequency.  Place-holder: not implemented yet
	anonymous			If true, the script has is unnamed -- in this case, the selector is private to the implementation!


!ScriptInstantiation methodsFor: 'anonymity' stamp: 'sw 10/30/2000 11:08'!
initializePermanentScriptFor: aPlayer selector: aSelector
	"Initialize the receiver on behalf of the player, setting its status to #normal and giving it the given selector"

	player _ aPlayer.
	status _ #normal.
	selector _ aSelector! !


!ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'nk 6/30/2004 19:00'!
addStatusChoices: choices toMenu: menu
	choices isEmpty ifFalse: [
		choices	 do: [ :choice || label sym |
			(choice isKindOf: Array) 
				ifTrue: [ label := choice first translated. sym := choice second ]
				ifFalse: [ label := choice translated. sym := choice ].
			menu add: label target: menu selector: #modalSelection: argument: sym ].
		menu addLine. ].
	^menu.
! !

!ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'nk 7/17/2004 09:01'!
addStatusChoices: choices toSubMenu: submenu forMenu: menu
	choices isEmpty ifFalse: [
		choices	 do: [ :choice || label sym |
			(choice isKindOf: Array) 
				ifTrue: [ label := choice first translated. sym := choice second ]
				ifFalse: [ label := choice translated. sym := choice ].
			submenu add: label target: menu selector: #modalSelection: argument: sym ].
		menu addLine. ].
	^menu.
! !

!ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'nk 7/21/2003 20:07'!
defineNewEvent
	| newEventName newEventHelp |
	"Prompt the user for the name of a new event and install it into the custom event table"
	newEventName _ FillInTheBlankMorph request: 'What is the name of your new event?'.
	newEventName isEmpty ifTrue: [ ^self ].
	newEventName _ newEventName asSymbol.
	(ScriptingSystem customEventStati includes: newEventName) ifTrue: [
		self inform: 'That event is already defined.'. ^self ].
	newEventHelp _ FillInTheBlankMorph request: 'Please describe this event:'.
	ScriptingSystem addUserCustomEventNamed: newEventName help: newEventHelp.! !

!ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'nk 7/21/2003 20:32'!
deleteCustomEvent
	| userEvents eventName |
	userEvents _  ScriptingSystem userCustomEventNames.
	eventName _ (SelectionMenu selections: userEvents) startUpWithCaption: 'Remove which event?' at: ActiveHand position allowKeyboard: true.
	eventName ifNotNil: [ ScriptingSystem removeUserCustomEventNamed: eventName ].
	self class allSubInstancesDo: [ :ea | ea status = eventName ifTrue: [ ea status: #normal ]]! !

!ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'nk 11/1/2004 08:13'!
explainStatusAlternatives
	"Open a little window that explains the various status 
	alternatives "
	(StringHolder new contents: (ScriptingSystem statusHelpStringFor: player))
		openLabel: 'Script Status' translated! !

!ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'nk 11/1/2004 07:53'!
presentScriptStatusPopUp
	"Put up a menu of status alternatives and carry out the request"

	| reply  m menu submenu |

	menu _ MenuMorph new.
	self addStatusChoices: #( normal " -- run when called" ) toMenu: menu.
	self addStatusChoices: 
		#(	paused 		"ready to run all the time"
			ticking			"run all the time" )
		toMenu: menu.
	self addStatusChoices: (ScriptingSystem standardEventStati copyFrom: 1 to: 3) toMenu: menu.
	self addStatusChoices: (ScriptingSystem standardEventStati allButFirst: 3) toMenu: menu.
	self addStatusChoices: 
		#(opening			"when I am being opened"
			closing			"when I am being closed" )
		toMenu: menu.
	
	submenu _ MenuMorph new.
	self addStatusChoices: (ScriptingSystem globalCustomEventNamesFor: player) toSubMenu: submenu forMenu: menu.
	menu add: 'more... ' translated subMenu: submenu.

	(Preferences allowEtoyUserCustomEvents) ifTrue: [
		submenu addLine.
		self addStatusChoices: ScriptingSystem userCustomEventNames toSubMenu: submenu forMenu: menu.
		submenu addLine.
		self addStatusChoices:
			(Array streamContents: [ :s | s nextPut: { 'define a new custom event'. #defineNewEvent }.
			ScriptingSystem userCustomEventNames isEmpty
				ifFalse: [ s nextPut: { 'delete a custom event'. #deleteCustomEvent } ]])
			toSubMenu: submenu forMenu: menu ].
	
	menu addLine.

	self addStatusChoices: #(
		('what do these mean?'explainStatusAlternatives)
		('apply my status to all siblings' assignStatusToAllSiblings) ) toMenu: menu.

	menu addTitle: 'When should this script run?' translated.
	menu submorphs last delete.
	menu invokeModal.
	
	reply := menu modalSelection.

	reply == #explainStatusAlternatives ifTrue: [^ self explainStatusAlternatives].
	reply == #assignStatusToAllSiblings ifTrue: [^ self assignStatusToAllSiblings].
	reply == #defineNewEvent ifTrue: [ ^self defineNewEvent ].
	reply == #deleteCustomEvent ifTrue: [ ^self deleteCustomEvent ].

	reply ifNotNil: 
		[self status: reply.  "Gets event handlers fixed up"
		reply == #paused ifTrue:
			[m _ player costume.
			(m isKindOf: SpeakerMorph) ifTrue: [m stopSound]].
		self updateAllStatusMorphs]
! !

!ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'nk 9/25/2003 11:35'!
removeEventTriggersForMorph: actualMorph 
	"user custom events are triggered at the World, while system custom events are triggered on individual Morphs."

	actualMorph removeActionsSatisfying: 
			[:action | 
			action receiver == player and: 
					[(#(#doScript: #triggerScript:) includes: action selector) 
						and: [action arguments first == selector]]]
		forEvent: status.
	self currentWorld removeActionsSatisfying: 
			[:action | 
			action receiver == player and: 
					[(#(#doScript: #triggerScript:) includes: action selector) 
						and: [action arguments first == selector]]]
		forEvent: status! !

!ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'nk 9/25/2003 11:38'!
status: newStatus 
	"Set the receiver's status as indicated"

	| stati actualMorph |
	actualMorph := player costume renderedMorph.

	"standard (EventHandler) events"
	stati := ScriptingSystem standardEventStati.
	(stati includes: status) 
		ifTrue: 
			[actualMorph 
				on: status
				send: nil
				to: nil
			"remove old link in event handler"].
	(stati includes: newStatus) 
		ifTrue: 
			[actualMorph 
				on: newStatus
				send: selector
				to: player.
			"establish new link in evt handler"
			player assureNoScriptOtherThan: self hasStatus: newStatus].

	"user custom events are triggered at the World, while system custom events are triggered on individual Morphs."
	self removeEventTriggersForMorph: actualMorph.
	stati := ScriptingSystem customEventStati.
	(stati includes: newStatus) 
		ifTrue: 
			[(ScriptingSystem userCustomEventNames includes: newStatus) 
				ifTrue: 
					[self currentWorld 
						when: newStatus
						send: #triggerScript:
						to: player
						withArguments: { 
								selector}]
				ifFalse: 
					[actualMorph when: newStatus
						evaluate: (MessageSend 
								receiver: player
								selector: #triggerScript:
								arguments: { 
										selector})]].
	status := newStatus.
	self pausedOrTicking ifTrue: [lastTick := nil].
	self flag: #arNote.	"this from fall 2000"
	self flag: #workaround.	"Code below was in #chooseTriggerFrom: which did not reflect status changes from other places (e.g., the stepping/pause buttons). It is not clear why this is necessary though - theoretically, any morph should step when it has a player but alas!! something is broken and I have no idea why and where."

	"14 feb 2001 - bob - I reinstated this after alan noticed that a newly drawn car would not go until you picked it up and dropped it. The reason is that unscripted players have #wantSteps ^false. If a morph enters the world with an unscripted player and then acquires a scripted player, that would be a good time to change, but this will work too"
	status == #ticking 
		ifTrue: 
			[player costume isStepping ifFalse: [player costume arrangeToStartStepping]]! !


!ScriptInstantiation methodsFor: 'frequency' stamp: 'dgd 2/22/2003 14:50'!
frequency
	(frequency isNil or: [frequency = 0]) ifTrue: [frequency := 1].
	^frequency! !

!ScriptInstantiation methodsFor: 'frequency' stamp: 'sw 4/21/1999 09:13'!
frequency: aNumber
	frequency _ aNumber! !

!ScriptInstantiation methodsFor: 'frequency' stamp: 'ar 2/12/2001 18:26'!
tickingRate
	"Return the number of ticks per second this script should get"
	^tickingRate ifNil:[8]! !

!ScriptInstantiation methodsFor: 'frequency' stamp: 'ar 2/12/2001 18:26'!
tickingRate: aNumber
	"See the comment in #tickingRate"
	tickingRate _ aNumber.
	self updateAllStatusMorphs.! !


!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 10/24/2004 17:05'!
assignStatusToAllSiblings
	"Let all sibling instances of my player have the same status that I do.  The stati affected are both the event stati and the tickingStati"

	| aScriptInstantiation |
	(player class allInstances copyWithout: player) do:
		[:aPlayer |
			aScriptInstantiation _ aPlayer scriptInstantiationForSelector: selector.
			aScriptInstantiation status: status.
			aScriptInstantiation frequency: self frequency.
			aScriptInstantiation tickingRate: self tickingRate.
			aScriptInstantiation updateAllStatusMorphs]! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 11/14/2001 00:32'!
assignStatusToAllSiblingsIn: aStatusViewer
	"Let all sibling instances of my player have the same status that I do"

	self assignStatusToAllSiblings.
	self updateAllStatusMorphs.
	aStatusViewer presenter reinvigorateAllScriptsTool: aStatusViewer ! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 5/13/1998 13:06'!
assureEventHandlerRepresentsStatus
	self status: self status! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'dgd 12/15/2003 10:11'!
offerMenuIn: aStatusViewer
	"Put up a menu."

	| aMenu |
	ActiveHand showTemporaryCursor: nil.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu title: player knownName, ' ', selector.
	aMenu addStayUpItem.
	(player class instanceCount > 1) ifTrue:
		[aMenu add: 'propagate status to siblings' translated selector: #assignStatusToAllSiblingsIn: argument: aStatusViewer.
		aMenu balloonTextForLastItem: 'Make the status of this script in all of my sibling instances be the same as the status you see here' translated].

	aMenu add: 'reveal this object' translated target: player selector: #revealPlayerIn: argument: ActiveWorld.
	aMenu balloonTextForLastItem: 'Make certain this object is visible on the screen; flash its image for a little while, and give it the halo.' translated.
	aMenu add: 'open this script''s Scriptor' translated target: player selector: #grabScriptorForSelector:in: argumentList: {selector. aStatusViewer world}.
	aMenu balloonTextForLastItem: 'Open up the Scriptor for this script' translated.
	aMenu add: 'open this object''s Viewer' translated target: player selector: #beViewed.
	aMenu balloonTextForLastItem: 'Open up a Viewer for this object' translated.
	aMenu addLine.
	aMenu add: 'more...' translated target: self selector: #offerShiftedMenuIn: argument: aStatusViewer.
	aMenu balloonTextForLastItem: 'The "more..." branch offers you menu items that are less frequently used.' translated.
	aMenu popUpInWorld: ActiveWorld! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'dgd 12/15/2003 10:12'!
offerShiftedMenuIn: aStatusViewer
	"Put up the shifted menu"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu title: player knownName, ' ', selector.
	aMenu add: 'grab this object' translated target: player selector: #grabPlayerIn: argument: self currentWorld.
	aMenu balloonTextForLastItem: 'Wherever this object currently is, the "grab" command will rip it out, and place it in your "hand".  This is a very drastic step, that can disassemble things that may be very hard to put back together!!' translated.
	aMenu add: 'destroy this script' translated target: player selector: #removeScriptWithSelector: argument: selector.
	aMenu balloonTextForLastItem: 'Caution!!  This is irreversibly destructive -- it removes the script from the system.' translated.
	aMenu addLine.
	aMenu add: 'inspect morph' translated target: player costume selector: #inspect.
	aMenu add: 'inspect player' translated target: player selector: #inspect.
	aMenu popUpInWorld: ActiveWorld! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 1/19/2001 17:45'!
playersExternalName
	"Answer the external name of my player"

	^ player externalName! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'ar 2/12/2001 18:58'!
prepareToBeRunning
	lastTick _ nil.! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'dgd 12/15/2003 10:09'!
statusControlRowIn: aStatusViewer
	"Answer an object that reports my status and lets the user change it"

	| aRow aMorph buttonWithPlayerName |
	aRow _ ScriptStatusLine newRow beTransparent.
	buttonWithPlayerName _ UpdatingSimpleButtonMorph new.
	buttonWithPlayerName
		on: #mouseEnter send: #menuButtonMouseEnter: to: buttonWithPlayerName;
		 on: #mouseLeave send: #menuButtonMouseLeave: to: buttonWithPlayerName.

	buttonWithPlayerName target: self; wordingSelector: #playersExternalName; actionSelector: #offerMenuIn:; arguments: {aStatusViewer}; beTransparent; actWhen: #buttonDown.
	buttonWithPlayerName setBalloonText: 'This is the name of the player to which this script belongs; if you click here, you will get a menu of interesting options pertaining to this player and script' translated.
	buttonWithPlayerName borderWidth: 1; borderColor: Color blue.
	aRow addMorphBack: buttonWithPlayerName.
	aRow addTransparentSpacerOfSize: 10@0.
	aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.

	aMorph _ UpdatingStringMorph on: self selector: #selector.
	aMorph color: Color brown lighter; useStringFormat.
	aMorph setBalloonText: 'This is the name of the script to which this entry pertains.' translated.
	aRow addMorphBack: aMorph.
	aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
	aRow addTransparentSpacerOfSize: 10@0.

	aRow addMorphBack: self statusControlMorph.
	aRow submorphsDo: [:m | m wantsSteps ifTrue: [m step]].
	^ aRow! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 4/30/1998 13:47'!
userScriptObject
	"Answer the UserScript object in the receiver's class that holds on to the editing state for this script"

	^ player class userScriptForPlayer: player selector: selector! !


!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 1/28/2001 16:06'!
changeSelectorTo: aNewSelector
	"Change the selector associated with the receiver to the new one provided"

	selector _ aNewSelector! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'dgd 2/16/2003 21:42'!
player
	"answer the receiver's player"
	^ player! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 5/13/1998 10:43'!
player: p
	"Needed for making duplicate players, otherwise private"
	player _ p! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 5/1/1998 21:33'!
player: p selector: s status: st
	frequency _ 0.
	status _ st.
	player _ p.
	selector _ s! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 4/30/1998 14:07'!
selector
	^ selector! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 4/30/1998 14:07'!
selector: sel
	selector _ sel! !


!ScriptInstantiation methodsFor: 'printing' stamp: 'sw 5/24/2001 16:01'!
printOn: aStream
	"Print the receiver on aStream"

	super printOn: aStream.
	aStream nextPutAll: ' (', self oopString, ') '.
	aStream nextPutAll: ' for #', selector asString! !


!ScriptInstantiation methodsFor: 'running' stamp: 'sw 11/13/2001 10:33'!
pausedOrTicking
	"Answer true if the receiver is either in paused or ticking status, false otherwise"

	^ #(paused ticking) includes: status! !

!ScriptInstantiation methodsFor: 'running' stamp: 'nk 8/21/2004 12:08'!
runIfClosing
	| result |
	(result _ status == #closing) ifTrue:
		[player triggerScript: selector].
	^ result! !

!ScriptInstantiation methodsFor: 'running' stamp: 'nk 8/21/2004 12:08'!
runIfOpening
	| result |
	(result _ status == #opening) ifTrue:
		[player triggerScript: selector].
	^ result! !

!ScriptInstantiation methodsFor: 'running' stamp: 'sw 11/16/2004 13:55'!
runIfTicking: nowTick 
	"If the receiver is meant to be ticking, run it if it's time"

	| ticks rate |
	status == #ticking ifFalse: [^self].
	rate := self tickingRate.
	ticks := (lastTick isNil or: [nowTick < lastTick]) 
				ifTrue: 
					[lastTick := nowTick.
					1]
				ifFalse: [((nowTick - lastTick) * rate * 0.001) asInteger].
	ticks <= 0 ifTrue: [^self].

	"Scripts which have been out of the world and then return can have a huge number of ticks accumulated. A better fix would be to reset <lastTick> when a script leaves/enters the world. Also, if the system is falling behind, this attempt to catch up can result in falling further behind, leading to sluggish behavior and termination of ticking status. Whether the user really wants this catch up behavior needs to be determined (often she will not, I suspect) and better ways of doing it need to be found.  (This comment inserted by Bob Arning on 3/5/2001)"
	ticks := 1.
	1 to: ticks * self frequency do: [:i | player triggerScript: selector].
	lastTick := nowTick.
	ticks > 10 
		ifTrue: 
			["check if we're lagging behind"

			ticks <= ((Time millisecondClockValue - lastTick) * rate / 1000) asInteger 
				ifTrue: 
					["e.g., time to run script is higher than number of ticks"

					self status: #paused.
					self updateAllStatusMorphs]]! !

!ScriptInstantiation methodsFor: 'running' stamp: 'ar 2/12/2001 17:00'!
startRunningIfPaused
	"If the receiver is paused, start it ticking"

	status == #paused ifTrue:
		[self status: #ticking.
		self updateAllStatusMorphs]! !

!ScriptInstantiation methodsFor: 'running' stamp: 'ar 2/12/2001 17:00'!
stopTicking
	"If I'm ticking stop, else do nothing"

	status == #ticking ifTrue:
		[self status: #paused.
		self updateAllStatusMorphs]! !


!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 1/31/2001 19:16'!
chooseTriggerFrom: ignored
	"Backward compatibility for old scriptors"

	^ self presentScriptStatusPopUp! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'nk 8/21/2004 12:08'!
fireOnce
	"Run this script once"

	player triggerScript: selector! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'dgd 9/6/2003 18:15'!
presentTickingMenu
	"Put up a menu of status alternatives and carry out the request"
	| aMenu ticks item any |
	ticks _ self tickingRate.
	ticks = ticks asInteger ifTrue:[ticks _ ticks asInteger].
	aMenu _ MenuMorph new defaultTarget: self.
	any _ false.
	#(1 2 5 8 10 25 50 100) do:[:i | 
		item _ aMenu addUpdating: nil target: self selector: #tickingRate: argumentList: {i}.
		item contents:
			((ticks = i) ifTrue:[ any _ true. '<on>', i printString]
					ifFalse:['<off>', i printString])].
	item _ aMenu addUpdating: nil target: self selector: #typeInTickingRate argumentList: #().
	item contents: (any ifTrue:['<off>'] ifFalse:['<on>']), 'other...' translated.
	aMenu addTitle: ('Ticks (now: {1}/sec)' translated format:{ticks}).
	aMenu  popUpEvent: self currentEvent in: self currentWorld! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 6/13/2002 15:14'!
resetToNormalIfCurrently: aStatus
	"If my status *had been* aStatus, quietly reset it to normal, without tampering with event handlers.  But get the physical display of all affected status morphs right"

	status == aStatus ifTrue:
		[status _ #normal.
		self updateAllStatusMorphs]! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 4/30/1998 14:10'!
status
	status ifNil: [status _ #normal].
	^ status! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 9/21/2000 10:38'!
statusControlMorph
	"Answer a control that will serve to reflect (and allow the user to change) the status of the receiver"

	^ ScriptStatusControl new initializeFor: self
! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'dgd 9/21/2003 15:59'!
translatedStatus
	^ self status translated! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'em 3/24/2005 14:49'!
typeInTickingRate
	| reply aNumber |
	reply _ FillInTheBlank request: 'Number of ticks per second: ' translated initialAnswer: self tickingRate printString.

	reply ifNotNil:
		[aNumber _ reply asNumber.
		aNumber > 0 ifTrue:
			[self tickingRate: aNumber]]! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 9/21/2000 10:37'!
updateAllStatusMorphs
	"Update all status morphs bound to the receiver.  Done with a sledge-hammer at present."

	(self currentWorld allMorphs select: [:m | (m isKindOf: ScriptStatusControl) and:
			[m scriptInstantiation == self]]) do:
		[:aStatusControl | self updateStatusMorph: aStatusControl]! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'dgd 9/21/2003 16:04'!
updateStatusMorph: statusControlMorph
	"the status control may need to reflect an externally-induced change in status"

	| colorSelector statusReadoutButton |
	statusControlMorph ifNil: [^ self].

	self pausedOrTicking
		ifTrue:
			[statusControlMorph assurePauseTickControlsShow]
		ifFalse:
			[statusControlMorph maybeRemovePauseTickControls].
	statusReadoutButton _ statusControlMorph submorphs last.
	colorSelector _ ScriptingSystem statusColorSymbolFor: self status.
	statusReadoutButton color: (Color perform: colorSelector) muchLighter.
	statusReadoutButton label: self translatedStatus asString font: Preferences standardButtonFont! !
Object subclass: #ScriptLoader
	instanceVariableNames: 'repository'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ScriptLoader'!
!ScriptLoader commentStamp: 'stephaneducasse 9/29/2005 18:48' prior: 0!
I'm a dummy class that is used to load packages to create release.
I should be merged into ReleaseBuilder in the future and ReleaseBuilder should be moved
out of system-support so that we do not create a new version of it each time!


!ScriptLoader methodsFor: 'accessing' stamp: 'sd 10/31/2005 17:59'!
inboxRepository
	repository isNil 
		ifTrue: [ repository := 
					MCHttpRepository
						location: 'http://source.squeakfoundation.org/inbox'
						user: ''
						password: ''].
	^ repository! !

!ScriptLoader methodsFor: 'accessing' stamp: 'sd 12/20/2005 15:15'!
repository
	repository isNil  
		ifTrue: [ repository := 
					MCHttpRepository
						location:  'http://source.squeakfoundation.org/39a'
						user: ''
						password: ''].
	^ repository! !


!ScriptLoader methodsFor: 'from bert' stamp: 'stephaneducasse 10/28/2005 19:57'!
bertLoadOneAfterTheOther: aCollection merge: aBoolean
 
	^ (self configurationFrom: aCollection) upgrade! !

!ScriptLoader methodsFor: 'from bert' stamp: 'md 8/10/2006 12:18'!
configurationFrom: aCollection

	| spec | 
	spec := Array streamContents: [:s |
         s nextPut: #repository; nextPut: {self repository description}.
         aCollection do: [:ea | | pkg ver id |
             pkg := ea copyUpToLast: $- .
             ver := ea copyUpToLast: $. .
             id := UUID nilUUID asString.
             s nextPut: #dependency; nextPut: {pkg . ver . id}]].
    ^MCConfiguration fromArray: spec.! !


!ScriptLoader methodsFor: 'log' stamp: 'sd 7/15/2006 20:39'!
packagesToUnload

	^ #('*PlusTools*' '*FixInvisible*')! !

!ScriptLoader methodsFor: 'log' stamp: 'stephaneducasse 2/4/2006 21:29'!
packagesWithProblemsForAssignments
	"FixUnderscores fixPackages: #()"
	"when I tried to reload with the package fixed with underscores
	I got problems so I just rollbacked for now."
	
	^#('PackageInfo')! !

!ScriptLoader methodsFor: 'log' stamp: 'stephaneducasse 2/4/2006 21:29'!
treatedPackagesForAssignments
	"FixUnderscores fixPackages: #()"
	
	^#('38Deprecated' 'Tests' 'SUnit' 'SUnitGUI' '39Deprecated' 'CollectionsTests' 'Compression' 'Files' 'FlexibleVocabularies' 'Monticello' 'MonticelloConfigurations' 'Movies' 'Nebraska' 'PackageInfo' 'PreferenceBrowser'  'Protocols' 'ToolBuilder-Kernel' 'StarSqueak' 'Sound' 'VersionNumber' 'Tools' 'ToolBuilder-SUnit' 'ToolBuilder-MVC' 'Services-Base' 'SmaCC' 'SMLoader' 'SMBase' 'ToolBuilder-Morphic' 'Speech' 'ReleaseBuilder')! !

!ScriptLoader methodsFor: 'log' stamp: 'stephaneducasse 2/10/2006 21:37'!
unloadableFailedPackages
	"list of the packages that I succeeded to remove pressing unload"
	
	^ #('Nebraska' 'TrueType')! !

!ScriptLoader methodsFor: 'log' stamp: 'stephaneducasse 2/10/2006 22:24'!
unloadablePackages
	"list of the packages that I succeeded to remove pressing unload"
	"Note that this does not mean that the system is working after, just that it
	was possible to unload the package without crashing Squeak"
	
	^ #('OmniBrowser' 'PlusTools' 'Flash' 'FFI' 'StarSqueak' 'Speech' 'Movie' 'FlexibleVocabularies' '39Deprecated' '39Deprecated' 'PreferenceBrowser' 'ReleaseBuilder' 
	'SUnitUI' 'Protocols' 'Sounds')! !


!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/16/2006 16:43'!
script1
	"morphic splitter"
	
	| vm names  |
repository _ MCHttpRepository
                location: 'http://source.squeakfoundation.org/39a'
                user: ''
                password: ''.

names _ '
38Deprecated-sd.2.mcz
39Deprecated-sd.2.mcz
Balloon-stephaneducasse.6.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-stephaneducasse.29.mcz
CollectionsTests-md.8.mcz
Compiler-stephaneducasse.12.mcz
Compression-md.2.mcz
Exceptions-md.3.mcz
EToys-stephaneducasse.2.mcz
FFI-tbn.3.mcz
Files-stephaneducasse.8.mcz
FlexibleVocabularies-stephaneducasse.1.mcz
Graphics-stephaneducasse.13.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.36.mcz
KernelTests-md.9.mcz
Morphic-stephaneducasse.47.mcz
MorphicExtras-stephaneducasse.2.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.6.mcz
Nebraska-stephaneducasse.4.mcz
Network-stephaneducasse.16.mcz
NetworkTests-md.7.mcz
PackageInfo-md.3.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-stephaneducasse.4.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-md.26.mcz
SmaCC-md.5.mcz
Sound-stephaneducasse.2.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.19.mcz
StarSqueak-stephaneducasse.4.mcz
SUnit-md.26.mcz
System-stephaneducasse.42.mcz
Tests-md.8.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
Tools-stephaneducasse.30.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

vm _ MCVersionMerger new.
names
    do: [:fn | vm addVersion: (repository loadVersionFromFileNamed: fn)]
    displayingProgress: 'Adding versions...'.
vm merge

! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 11/1/2005 15:47'!
script10
	"I should have introduced a new name when  I did updateFrom6696: I'm messy (sd)
	
	Load System (with LogStreamFile reintorudce and Tools without ab and merged
	Needed from here: the four changesets and PlusTools
	"
	
	| names |
	
	

	names _ '
38Deprecated-CdG.4.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-CdG.35.mcz
CollectionsTests-md.10.mcz
Compiler-CdG.19.mcz 
Compression-CdG.3.mcz
Exceptions-CdG.4.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-CdG.49.mcz
KernelTests-CdG.13.mcz
Morphic-CdG.55.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.277.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-CdG.5.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-CdG.23.mcz
StarSqueak-CdG.5.mcz
SUnit-CdG.28.mcz
System-stephaneducasse.47.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.38.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.
	
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 11/3/2005 15:57'!
script11
	"With paragraphEditor and ChangeSorter classVariables back"
	
	| names |
	

	names _ '
38Deprecated-CdG.4.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-CdG.35.mcz
CollectionsTests-md.10.mcz
Compiler-CdG.19.mcz 
Compression-CdG.3.mcz
Exceptions-CdG.4.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-CdG.49.mcz
KernelTests-CdG.13.mcz
Morphic-CdG.55.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.277.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-CdG.5.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.24.mcz
StarSqueak-CdG.5.mcz
SUnit-CdG.28.mcz
System-stephaneducasse.47.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.39.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.
	
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 11/4/2005 13:07'!
script12
	"With  ChangeSorter classVariables removed"
	
	| names |
	

	names _ '
38Deprecated-CdG.4.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-CdG.35.mcz
CollectionsTests-md.10.mcz
Compiler-CdG.19.mcz 
Compression-CdG.3.mcz
Exceptions-CdG.4.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-CdG.49.mcz
KernelTests-CdG.13.mcz
Morphic-CdG.55.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.277.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-CdG.5.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.24.mcz
StarSqueak-CdG.5.mcz
SUnit-CdG.28.mcz
System-stephaneducasse.47.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.40.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.
	
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 11/5/2005 15:30'!
script13
	"An experience: loading first with classvar and reloading without to see if we get 
	the result expected: no wanring and no classvariable in ChangeSorter"
	
	| names |
	

	names _ '
38Deprecated-CdG.4.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-CdG.35.mcz
CollectionsTests-md.10.mcz
Compiler-stephaneducasse.20.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.50.mcz
KernelTests-CdG.13.mcz
Morphic-CdG.55.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.277.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-CdG.5.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.24.mcz
StarSqueak-CdG.5.mcz
SUnit-CdG.28.mcz
System-stephaneducasse.47.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.39.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.

"an experience to remove the classvariable without having warning"	

	names _ '
Tools-stephaneducasse.40.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 11/20/2005 21:09'!
script14
	"loading back the packages that have been marked as dirty because of cs 
	pushed into the stream. Such a configuration may not work with another image
	than 6703
	
	Compiler-stephaneducasse.21.mcz includes the fixes to load MC code and keep some cleans of marcus
	System-stephaneducasse.48 fixes flaps
	Morphic.56 0002147: Too many keystroke events
	
	Tools.41: browser fixes...
	
	FixUnderscores
	
	System.50 System Edgar fixes.
	"
	
	| names |
	

	names _ '
38Deprecated-CdG.4.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-CdG.35.mcz
CollectionsTests-md.10.mcz
Compiler-stephaneducasse.21.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.50.mcz
KernelTests-CdG.13.mcz
Morphic-stephaneducasse.56.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.277.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-CdG.5.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.24.mcz
StarSqueak-CdG.5.mcz
SUnit-CdG.28.mcz
System-sd.50.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.41.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 11/29/2005 09:40'!
script15
	"Fixing underscores
	Fixing explore
	"
	
	| names |
	

	names _ '
38Deprecated-sd.5.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-CdG.35.mcz
CollectionsTests-md.10.mcz
Compiler-stephaneducasse.21.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.50.mcz
KernelTests-CdG.13.mcz
Morphic-stephaneducasse.56.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.277.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.24.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
System-al.51.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-sd.42.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'al 12/19/2005 11:11'!
script16
	"Traits introduction:
	The packages need to be loaded in the following order, one by one.
	"
	
	self loadOneAfterTheOther: 	
			#('Traits.bootstrap-al.1.mcz'
				'Kernel.bootstrap-al.1.mcz'
				'Kernel.bootstrap-al.2.mcz'
				'Monticello-al.287.mcz'
				'Traits-al.198.mcz'
				'Kernel-al.70.mcz'
				'System-al.52.mcz'
				'Tools-al.43.mcz') merge: false.
	
	
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 12/20/2005 15:06'!
script17
	"
	integer printOn:padded 2229
	character fixes 2254
	date fixes 2117
	compiler fix of lukas evaluate:in:to:notifying:
	http://bugs.impara.de/view.php?id=1041 LowSpaceAndInterruptHandler-3-dtl
	
	"
	"
	| res |
	res := ReadWriteStream on: String new. 
	MCWorkingCopy allManagers collect: [:each | res nextPutAll: each ancestry ancestors first name ; nextPutAll: '.mcz' ; cr].
	res contents"
	
	"| names |
	names _ '
38Deprecated-sd.5.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-sd.36.mcz
CollectionsTests-sd.11.mcz
Compiler-sd.22.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-sd.71.mcz
KernelTests-sd.14.mcz
Morphic-stephaneducasse.56.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.287.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.24.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
System-al.52.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-al.43.mcz
Traits-al.198.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
' "

| names |
	names _
'Tools-al.43.mcz
SUnit-CdG.28.mcz
Movies-stephaneducasse.3.mcz
FlexibleVocabularies-CdG.2.mcz
ToolBuilder-Kernel-ar.13.mcz
BalloonMMFlash-stephaneducasse.3.mcz
SmaCC-md.5.mcz
KernelTests-sd.14.mcz
39Deprecated-stephaneducasse.3.mcz
VersionNumber-dew.1.mcz
ToolBuilder-MVC-ar.8.mcz
MonticelloConfigurations-md.37.mcz
ToolBuilder-SUnit-ar.9.mcz
ST80-stephaneducasse.24.mcz
ToolBuilder-Morphic-md.15.mcz
Files-CdG.13.mcz
Exceptions-stephaneducasse.5.mcz
Balloon-stephaneducasse.7.mcz
GraphicsTests-md.3.mcz
PlusTools-CdG.22.mcz
Sound-CdG.3.mcz
SMBase-stephaneducasse.69.mcz
Traits-al.198.mcz
Protocols-CdG.7.mcz
CollectionsTests-sd.11.mcz
PackageInfo-stephaneducasse.4.mcz
FFI-CdG.4.mcz
Kernel-sd.71.mcz
Network-CdG.21.mcz
PreferenceBrowser-hpt.27.mcz
MorphicExtras-CdG.7.mcz
FixUnderscores-stephaneducasse.7.mcz
MorphicTests-stephaneducasse.4.mcz
Nebraska-sd.6.mcz
ScriptLoader-sd.58.mcz
StarSqueak-sd.6.mcz
Graphics-CdG.16.mcz
Speech-stephaneducasse.5.mcz
System-al.52.mcz
38Deprecated-sd.5.mcz
Multilingual-CdG.10.mcz
Monticello-al.287.mcz
Compression-CdG.3.mcz
SMLoader-bp.27.mcz
Compiler-sd.22.mcz
Tests-CdG.9.mcz
Collections-sd.36.mcz
EToys-stephaneducasse.2.mcz
NetworkTests-md.7.mcz
Morphic-stephaneducasse.56.mcz
'
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 12/20/2005 22:03'!
script18
	"
	integer printOn:padded 2229
	character fixes 2254
	date fixes 2117
	compiler fix of lukas evaluate:in:to:notifying:
	http://bugs.impara.de/view.php?id=1041 LowSpaceAndInterruptHandler-3-dtl
	added omnibrowser.273
	"
	"
	| res |
	res := ReadWriteStream on: String new. 
	MCWorkingCopy allManagers collect: [:each | res nextPutAll: each ancestry ancestors first name ; nextPutAll: '.mcz' ; cr].
	res contents"
	
| names |
	names _ '
38Deprecated-sd.5.mcz
39Deprecated-sd.4.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-sd.36.mcz
CollectionsTests-sd.11.mcz
Compiler-sd.22.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-sd.71.mcz
KernelTests-sd.14.mcz
Morphic-stephaneducasse.56.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-cwp.273.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-sd.25.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
System-sd.53.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-al.43.mcz
Traits-al.198.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 1/13/2006 19:22'!
script19
	"
	Morphic team new versions
		Mantis-1092-MorphDropFix, fix by Edgar De Cleene (edc) and Scott  Wallace (sw)
Mantis-0503-TargetSighting, fix by Jerome Peace (wiz)
Mantis-1015-SnapView, fix by Jerome Peace (wiz)
Mantis-1771-ClickExerciser, fix by Jerome Peace (wiz)
Mantis-1625-Thumbnails, fix by Jerome Peace (wiz)
Mantis-1484-TrashHalo, fix by Jerome Peace (wiz)
Mantis-1454-ArrowPrototypeFix, fix by Jerome Peace (wiz)
Mantis-1347-ListDoubleClick, fix by Jerome Peace (wiz)
Reviewed by Juan Vuletich (jmv)
		
		Pay attention the order is important: first Etoys, then Morphic then Morphic Extra and
		this is not working with merging (ie default MC behavior.
	"
	self loadOneAfterTheOther: #('EToys-jmv.5.mcz' 'Morphic-jmv.58.mcz' 'MorphicExtras-jmv.9.mcz') merge: false.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/16/2006 16:43'!
script2
	"deprecated + CurrentProjectRefactoring + collection tests"
	
	| vm names  |
repository _ MCHttpRepository
                location: 'http://source.squeakfoundation.org/39a'
                user: ''
                password: ''.

names _ '
38Deprecated-md.3.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-stephaneducasse.29.mcz
CollectionsTests-stephaneducasse.9.mcz
Compiler-stephaneducasse.12.mcz
Compression-md.2.mcz
Exceptions-md.3.mcz
EToys-stephaneducasse.2.mcz
FFI-tbn.3.mcz
Files-stephaneducasse.8.mcz
FlexibleVocabularies-stephaneducasse.1.mcz
Graphics-stephaneducasse.13.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.36.mcz
KernelTests-md.9.mcz
Morphic-stephaneducasse.47.mcz
MorphicExtras-stephaneducasse.2.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.6.mcz
Nebraska-stephaneducasse.4.mcz
Network-stephaneducasse.16.mcz
NetworkTests-md.7.mcz
PackageInfo-md.3.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-stephaneducasse.4.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-md.26.mcz
SmaCC-md.5.mcz
Sound-stephaneducasse.2.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.19.mcz
StarSqueak-stephaneducasse.4.mcz
SUnit-md.26.mcz
System-stephaneducasse.43.mcz
Tests-md.8.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
Tools-stephaneducasse.30.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

vm _ MCVersionMerger new.
names
    do: [:fn | vm addVersion: (repository loadVersionFromFileNamed: fn)]
    displayingProgress: 'Adding versions...'.
vm merge

! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 1/13/2006 23:44'!
script20
	"
	traits fixes
	"
	"
	| res |
	res := ReadWriteStream on: String new. 
	MCWorkingCopy allManagers collect: [:each | res nextPutAll: each ancestry ancestors first name ; nextPutAll: '.mcz' ; cr].
	res contents"
	
| names |
	names _ '
38Deprecated-sd.5.mcz
39Deprecated-sd.4.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-sd.36.mcz
CollectionsTests-sd.11.mcz
Compiler-sd.24.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-jmv.5.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-al.72.mcz
KernelTests-sd.14.mcz
Morphic-jmv.58.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-cwp.273.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-sd.25.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
System-al.55.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-al.44.mcz
Traits-al.200.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 1/14/2006 12:45'!
script21
	"
	TIM VMMaker related fixes:
		6669VMM38-64bit-imageUpdates.1.cs
		6669VMM38-gc-instrument-image.1.cs
		LocalePluginAddins.1.cs
		RemoveLeftoverVMMbits-38b4.1.cs
		WideStringPrimKill.1.cs
	"
	"
	| res |
	res := ReadWriteStream on: String new. 
	MCWorkingCopy allManagers collect: [:each | res nextPutAll: each ancestry ancestors first name ; nextPutAll: '.mcz' ; cr].
	res contents"
	
| names |
	names _ '
38Deprecated-sd.5.mcz
39Deprecated-sd.4.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-sd.36.mcz
CollectionsTests-sd.11.mcz
Compiler-sd.24.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-jmv.5.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.73.mcz
KernelTests-sd.14.mcz
Morphic-jmv.58.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-cwp.273.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.26.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
System-stephaneducasse.56.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.45.mcz
Traits-al.200.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 1/14/2006 18:39'!
script22
	"
	Preferences (rr)
	PreferenceBrowser (rr)
	Services (rr)
	Debugger fix (md)
	"
	"
	| res |
	res := ReadWriteStream on: String new. 
	MCWorkingCopy allManagers collect: [:each | res nextPutAll: each ancestry ancestors first name ; nextPutAll: '.mcz' ; cr].
	res contents"
	
| names |
	names _ '
38Deprecated-sd.5.mcz
39Deprecated-sd.4.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-sd.36.mcz
CollectionsTests-sd.11.mcz
Compiler-sd.24.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-jmv.5.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.73.mcz
KernelTests-sd.14.mcz
Morphic-jmv.58.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-stephaneducasse.21.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.26.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
System-stephaneducasse.57.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.46.mcz
Traits-al.200.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 1/14/2006 21:01'!
script23
	"
	new SUnit UI. 
	merged Tools-md-44
	"
	"
	| res |
	res := ReadWriteStream on: String new. 
	MCWorkingCopy allManagers collect: [:each | res nextPutAll: each ancestry ancestors first name ; nextPutAll: '.mcz' ; cr].
	res contents"
	
| names |
Flaps unregisterQuad: #(#TestRunner #prototypicalToolWindow 'Test Runner' 'The SUnit Test Runner' ) forFlapNamed: 'Tools'.
	names _ '
38Deprecated-sd.5.mcz
39Deprecated-sd.4.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-sd.36.mcz
CollectionsTests-sd.11.mcz
Compiler-sd.24.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-jmv.5.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.73.mcz
KernelTests-sd.14.mcz
Morphic-jmv.58.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-stephaneducasse.21.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.26.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
SUnitGUI-md.3.mcz
System-stephaneducasse.57.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.47.mcz
Traits-al.200.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 1/15/2006 18:25'!
script24
	"
	Method annotations
	"
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-sd.4.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-sd.36.mcz
CollectionsTests-sd.11.mcz
Compiler-stephaneducasse.25.mcz 
Compression-CdG.3.mcz
Exceptions-stephaneducasse.5.mcz
EToys-jmv.5.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.75.mcz
KernelTests-stephaneducasse.15.mcz
Morphic-jmv.58.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-stephaneducasse.21.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.26.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
SUnitGUI-md.3.mcz
System-stephaneducasse.57.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.47.mcz
Traits-al.200.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 1/18/2006 09:38'!
script25
	"
	Packages made dirty by the cs for method annotation: 6713.
	"
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-sd.4.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-sd.36.mcz
CollectionsTests-sd.11.mcz
Compiler-md.27.mcz 
Compression-CdG.3.mcz
Exceptions-sd.6.mcz
EToys-jmv.5.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-sd.76.mcz
KernelTests-stephaneducasse.15.mcz
Morphic-jmv.58.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-stephaneducasse.21.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.26.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
SUnitGUI-md.3.mcz
System-stephaneducasse.57.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-stephaneducasse.47.mcz
Traits-al.200.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 1/18/2006 19:42'!
script26
	"Bugfixes:
	move scopeHas:ifTrue: to *39Deprecated, fix the senders
	JMMRemoveExtraIndexCheck: faster second...8th 
	fix open File directly
	WindowColorRegistry (Hernán Tylim)
	Fix to open real Workspace
	"
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-md.5.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-md.37.mcz
CollectionsTests-sd.11.mcz
Compiler-md.27.mcz 
Compression-CdG.3.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-md.77.mcz
KernelTests-stephaneducasse.15.mcz
Morphic-md.59.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-CdG.22.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-md.22.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.26.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
SUnitGUI-md.3.mcz
System-md.58.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-md.48.mcz
Traits-al.200.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 1/19/2006 18:50'!
script27
	""
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-md.5.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-md.38.mcz
CollectionsTests-sd.11.mcz
Compiler-md.28.mcz 
Compression-CdG.3.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-md.14.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-md.79.mcz
KernelTests-stephaneducasse.15.mcz
Morphic-md.61.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-md.23.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-md.22.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
ST80-md.27.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
SUnitGUI-md.3.mcz
System-md.59.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-md.49.mcz
Traits-al.200.mcz
Speech-md.6.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 1/21/2006 11:18'!
script28
	""
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-md.5.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-md.40.mcz
CollectionsTests-md.12.mcz
Compiler-md.29.mcz 
Compression-CdG.3.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-md.14.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-md.83.mcz
KernelTests-stephaneducasse.15.mcz
Morphic-md.62.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-md.24.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-md.22.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
ST80-md.27.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
SUnitGUI-lr.4.mcz
System-md.60.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-md.51.mcz
Traits-al.200.mcz
Speech-md.6.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 1/22/2006 19:48'!
script29
	""
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-md.5.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-md.41.mcz
CollectionsTests-md.12.mcz
Compiler-md.31.mcz 
Compression-CdG.3.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-md.14.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-md.83.mcz
KernelTests-stephaneducasse.15.mcz
Morphic-md.63.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-md.24.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-md.23.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
ST80-md.27.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
SUnitGUI-lr.4.mcz
System-md.60.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-md.51.mcz
Traits-al.200.mcz
Speech-md.6.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/16/2006 16:43'!
script3
	"explore label + print fixes + Network +starMorph + SMloadder + double initi"
	
	| vm names  |
repository _ MCHttpRepository
                location: 'http://source.squeakfoundation.org/39a'
                user: ''
                password: ''.

names _ '
38Deprecated-md.3.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-stephaneducasse.29.mcz
CollectionsTests-stephaneducasse.9.mcz
Compiler-stephaneducasse.12.mcz
Compression-md.2.mcz
Exceptions-md.3.mcz
EToys-stephaneducasse.2.mcz
FFI-tbn.3.mcz
Files-stephaneducasse.8.mcz
FlexibleVocabularies-stephaneducasse.1.mcz
Graphics-stephaneducasse.13.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.38.mcz
KernelTests-md.9.mcz
Morphic-stephaneducasse.47.mcz
MorphicExtras-stephaneducasse.3.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.6.mcz
Nebraska-stephaneducasse.4.mcz
Network-stephaneducasse.17.mcz
NetworkTests-md.7.mcz
PackageInfo-md.3.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-stephaneducasse.4.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-md.26.mcz
SmaCC-md.5.mcz
Sound-stephaneducasse.2.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.19.mcz
StarSqueak-stephaneducasse.4.mcz
SUnit-md.26.mcz
System-stephaneducasse.43.mcz
Tests-md.8.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
Tools-stephaneducasse.32.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

vm _ MCVersionMerger new.
names
    do: [:fn | vm addVersion: (repository loadVersionFromFileNamed: fn)]
    displayingProgress: 'Adding versions...'.
vm merge

! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 1/23/2006 17:11'!
script30
	"adding andreas packages"
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-md.5.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.41.mcz
CollectionsTests-md.12.mcz
Compiler-md.31.mcz 
Compression-CdG.3.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-md.14.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-ar.25.mcz
GraphicsTests-md.3.mcz
Kernel-md.83.mcz
KernelTests-stephaneducasse.15.mcz
Morphic-md.63.mcz
MorphicExtras-jmv.9.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
PlusTools-md.24.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-md.23.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
ST80-md.27.mcz
StarSqueak-sd.6.mcz
SUnit-CdG.28.mcz
SUnitGUI-lr.4.mcz
System-md.60.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-md.51.mcz
Traits-al.200.mcz
Speech-md.6.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 2/3/2006 22:46'!
script31
	"0002135: Cmd-. don't work with various Mac Os X keyboard layout
	lukas TextAnchor fixes"
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-md.5.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.41.mcz
CollectionsTests-md.12.mcz
Compiler-md.31.mcz 
Compression-CdG.3.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-md.14.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-sd.84.mcz
KernelTests-stephaneducasse.15.mcz
Morphic-stephaneducasse.64.mcz
MorphicExtras-stephaneducasse.10.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.287.mcz
MonticelloConfigurations-md.37.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.24.mcz
PreferenceBrowser-stephaneducasse.28.mcz
Protocols-CdG.7.mcz
Services-Base-md.23.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
ST80-md.27.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-lr.4.mcz
System-stephaneducasse.61.mcz
Tests-stephaneducasse.10.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.51.mcz
Traits-al.200.mcz
Speech-stephaneducasse.7.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/12/2006 20:23'!
script32
	
| names |
names _ '
38Deprecated-sd.5.mcz
39Deprecated-md.5.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.44.mcz
CollectionsTests-md.14.mcz
Compiler-md.31.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.88.mcz
KernelTests-md.19.mcz
Morphic-md.65.mcz
MorphicExtras-stephaneducasse.10.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-stephaneducasse.288.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.25.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-stephaneducasse.24.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.27.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-lr.4.mcz
System-md.62.mcz
Tests-md.11.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.54.mcz
Traits-md.201.mcz
Speech-stephaneducasse.7.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/14/2006 21:11'!
script33
	
| names |
names := '
39Deprecated-md.6.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.45.mcz
CollectionsTests-md.14.mcz
Compiler-md.33.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.90.mcz
KernelTests-md.20.mcz
Morphic-md.68.mcz
MorphicExtras-stephaneducasse.10.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-stephaneducasse.288.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.27.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-stephaneducasse.24.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.28.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-lr.4.mcz
System-md.65.mcz
Tests-md.12.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.55.mcz
Traits-md.202.mcz
Speech-stephaneducasse.7.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/16/2006 14:29'!
script34
	
| names |
names := '
39Deprecated-md.7.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.46.mcz
CollectionsTests-md.15.mcz
Compiler-md.35.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.92.mcz
KernelTests-md.22.mcz
Morphic-md.68.mcz
MorphicExtras-md.11.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.291.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.27.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-stephaneducasse.24.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.28.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-lr.4.mcz
System-md.66.mcz
Tests-md.13.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.55.mcz
Traits-md.203.mcz
Speech-stephaneducasse.7.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/16/2006 19:25'!
script35
	
| names |
names := '
39Deprecated-md.8.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.47.mcz
CollectionsTests-md.16.mcz
Compiler-md.36.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.94.mcz
KernelTests-md.23.mcz
Morphic-md.68.mcz
MorphicExtras-md.11.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.291.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.28.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-stephaneducasse.24.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.28.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-lr.4.mcz
System-md.66.mcz
Tests-md.13.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.55.mcz
Traits-md.203.mcz
Speech-stephaneducasse.7.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/18/2006 13:54'!
script36
	
| names |
names := '
39Deprecated-md.9.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.47.mcz
CollectionsTests-md.16.mcz
Compiler-md.37.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.95.mcz
KernelTests-md.24.mcz
Morphic-md.68.mcz
MorphicExtras-md.11.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.291.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.29.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-stephaneducasse.24.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.29.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-lr.4.mcz
System-md.67.mcz
Tests-md.13.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.57.mcz
Traits-md.203.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/19/2006 11:35'!
script37
	
| names |
names := '
39Deprecated-md.10.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.47.mcz
CollectionsTests-md.17.mcz
Compiler-md.38.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-sd.6.mcz
EToys-md.6.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.98.mcz
KernelTests-md.26.mcz
Morphic-md.69.mcz
MorphicExtras-md.11.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.291.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-stephaneducasse.274.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.29.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.25.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.29.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-md.5.mcz
System-md.68.mcz
Tests-md.13.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.58.mcz
Traits-md.205.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/22/2006 10:38'!
script38
	
| names |
names := '
39Deprecated-md.10.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.47.mcz
CollectionsTests-md.17.mcz
Compiler-md.38.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-sd.6.mcz
EToys-jmv.9.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.98.mcz
KernelTests-md.26.mcz
Morphic-jmv.72.mcz
MorphicExtras-jmv.14.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.291.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-cwp.274.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.29.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.25.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.29.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-md.5.mcz
System-md.68.mcz
Tests-md.13.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.58.mcz
Traits-md.205.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/22/2006 11:56'!
script39
	
| names |
names := '
39Deprecated-md.10.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.47.mcz
CollectionsTests-md.17.mcz
Compiler-md.39.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-sd.6.mcz
EToys-jmv.9.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.99.mcz
KernelTests-md.27.mcz
Morphic-jmv.72.mcz
MorphicExtras-jmv.14.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.292.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.275.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.30.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.25.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.29.mcz
StarSqueak-sd.6.mcz
SUnit-stephaneducasse.29.mcz
SUnitGUI-md.5.mcz
System-md.69.mcz
Tests-md.13.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.59.mcz
Traits-md.205.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/16/2006 16:43'!
script4
	"Removed dictionary fixes + Delay class comment + TTCFont speedup + menuMorph enh
	+ handMorph cursor enh"
	
	| vm names  |
repository _ MCHttpRepository
                location: 'http://source.squeakfoundation.org/39a'
                user: ''
                password: ''.

names _ '
38Deprecated-md.3.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-stephaneducasse.31.mcz
CollectionsTests-stephaneducasse.9.mcz
Compiler-stephaneducasse.12.mcz
Compression-md.2.mcz
Exceptions-md.3.mcz
EToys-stephaneducasse.2.mcz
FFI-tbn.3.mcz
Files-stephaneducasse.8.mcz
FlexibleVocabularies-stephaneducasse.1.mcz
Graphics-stephaneducasse.13.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.39.mcz
KernelTests-md.9.mcz
Morphic-stephaneducasse.50.mcz
MorphicExtras-stephaneducasse.3.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.8.mcz
Nebraska-stephaneducasse.4.mcz
Network-stephaneducasse.17.mcz
NetworkTests-md.7.mcz
PackageInfo-md.3.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-stephaneducasse.4.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-md.26.mcz
SmaCC-md.5.mcz
Sound-stephaneducasse.2.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.19.mcz
StarSqueak-stephaneducasse.4.mcz
SUnit-md.26.mcz
System-stephaneducasse.43.mcz
Tests-md.8.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
Tools-stephaneducasse.32.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

vm _ MCVersionMerger new.
names
    do: [:fn | vm addVersion: (repository loadVersionFromFileNamed: fn)]
    displayingProgress: 'Adding versions...'.
vm merge

! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/22/2006 22:50'!
script40
	
| names |
names := '
39Deprecated-md.10.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.48.mcz
CollectionsTests-md.17.mcz
Compiler-md.40.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.10.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.100.mcz
KernelTests-md.28.mcz
Morphic-md.73.mcz
MorphicExtras-md.15.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.292.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-sd.6.mcz
Network-CdG.21.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.275.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-stephaneducasse.2.mcz
PlusTools-md.32.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.25.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-stephaneducasse.28.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.30.mcz
StarSqueak-sd.6.mcz
SUnit-md.30.mcz
SUnitGUI-md.5.mcz
System-md.71.mcz
Tests-md.14.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.60.mcz
Traits-md.207.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/25/2006 00:12'!
script41
	
| names |
names := '
39Deprecated-md.10.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Morphic-Balloon-ar.1.mcz
Morphic-TrueType-ar.1.mcz
Collections-md.49.mcz
CollectionsTests-md.17.mcz
Compiler-md.41.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.10.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.101.mcz
KernelTests-md.28.mcz
Morphic-md.74.mcz
MorphicExtras-md.16.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.292.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-md.7.mcz
Network-md.22.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.33.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.25.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.30.mcz
StarSqueak-sd.6.mcz
SUnit-md.30.mcz
SUnitGUI-md.5.mcz
System-md.72.mcz
Tests-md.14.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.61.mcz
Traits-md.207.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 2/28/2006 12:23'!
script42
	
| names |
names := '
39Deprecated-md.10.mcz
Balloon-ar.9.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.49.mcz
CollectionsTests-md.17.mcz
Compiler-md.42.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.11.mcz
FFI-CdG.4.mcz
Files-stephaneducasse.15.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-stephaneducasse.26.mcz
GraphicsTests-md.3.mcz
Kernel-md.102.mcz
KernelTests-md.28.mcz
Morphic-md.75.mcz
MorphicExtras-md.17.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.293.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-md.7.mcz
Network-md.22.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.4.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.33.mcz
PreferenceBrowser-stephaneducasse.29.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.26.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-stephaneducasse.4.mcz
ST80-md.30.mcz
StarSqueak-sd.6.mcz
SUnit-md.30.mcz
SUnitGUI-md.5.mcz
System-md.73.mcz
Tests-md.14.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.62.mcz
Traits-md.208.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/4/2006 09:41'!
script43
	
| names |
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.50.mcz
CollectionsTests-md.17.mcz
Compiler-md.43.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.12.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-ar.30.mcz
GraphicsTests-ar.8.mcz
Kernel-md.103.mcz
KernelTests-md.29.mcz
Morphic-md.76.mcz
MorphicExtras-md.17.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.293.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-md.7.mcz
Network-md.22.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.26.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-md.5.mcz
ST80-md.30.mcz
StarSqueak-sd.6.mcz
SUnit-md.30.mcz
SUnitGUI-md.5.mcz
System-md.74.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.63.mcz
Traits-md.210.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/5/2006 21:11'!
script44
	
| names |
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.50.mcz
CollectionsTests-md.17.mcz
Compiler-md.43.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.12.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-ar.30.mcz
GraphicsTests-ar.8.mcz
Kernel-md.104.mcz
KernelTests-md.29.mcz
Morphic-md.77.mcz
MorphicExtras-md.17.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.293.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-md.7.mcz
Network-md.23.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.26.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-md.5.mcz
ST80-md.30.mcz
StarSqueak-sd.6.mcz
SUnit-md.30.mcz
SUnitGUI-md.5.mcz
System-md.74.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.63.mcz
Traits-md.211.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/9/2006 16:49'!
script45
	
| names |
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.50.mcz
CollectionsTests-md.17.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.12.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-ar.30.mcz
GraphicsTests-ar.8.mcz
Kernel-md.105.mcz
KernelTests-md.30.mcz
Morphic-md.77.mcz
MorphicExtras-md.17.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.293.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-md.7.mcz
Network-md.23.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.26.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.30.mcz
SUnitGUI-md.5.mcz
System-md.76.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.64.mcz
Traits-md.212.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/14/2006 19:06'!
script46
	
| names |
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.51.mcz
CollectionsTests-md.17.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.12.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-ar.30.mcz
GraphicsTests-ar.8.mcz
Kernel-md.105.mcz
KernelTests-md.30.mcz
Morphic-md.79.mcz
MorphicExtras-md.19.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.293.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-md.7.mcz
Network-md.23.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-stephaneducasse.8.mcz
Services-Base-md.26.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.30.mcz
SUnitGUI-md.5.mcz
System-md.76.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.65.mcz
Traits-md.212.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/15/2006 20:10'!
script47
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.52.mcz
CollectionsTests-md.17.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.13.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.31.mcz
GraphicsTests-ar.8.mcz
Kernel-md.106.mcz
KernelTests-md.30.mcz
Morphic-md.80.mcz
MorphicExtras-md.20.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-stephaneducasse.11.mcz
Nebraska-md.7.mcz
Network-md.23.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.9.mcz
Services-Base-md.26.mcz
SMBase-stephaneducasse.71.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.30.mcz
SUnitGUI-md.5.mcz
System-md.77.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.65.mcz
Traits-md.212.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/17/2006 18:16'!
script48
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.53.mcz
CollectionsTests-md.18.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.14.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.32.mcz
GraphicsTests-ar.8.mcz
Kernel-md.107.mcz
KernelTests-md.30.mcz
Morphic-md.81.mcz
MorphicExtras-md.21.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-md.12.mcz
Nebraska-md.8.mcz
Network-md.24.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.9.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.31.mcz
SUnitGUI-md.5.mcz
System-md.78.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.66.mcz
Traits-md.212.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/18/2006 18:31'!
script49
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.53.mcz
CollectionsTests-md.18.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.14.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.32.mcz
GraphicsTests-ar.8.mcz
Kernel-al.109.mcz
KernelTests-md.30.mcz
Morphic-md.82.mcz
MorphicExtras-md.21.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-md.12.mcz
Nebraska-md.8.mcz
Network-md.24.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.9.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.31.mcz
SUnitGUI-md.5.mcz
System-md.78.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.66.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'al 10/14/2005 11:50'!
script5
	"0000854: Long Delay schedules a deferred image crash
	0001552: [FIX] WorldState>>runStepMethodsIn:
	"
	
	| names |

	names _ '
38Deprecated-md.3.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-stephaneducasse.31.mcz
CollectionsTests-stephaneducasse.9.mcz
Compiler-stephaneducasse.12.mcz
Compression-md.2.mcz
Exceptions-md.3.mcz
EToys-stephaneducasse.2.mcz
FFI-tbn.3.mcz
Files-stephaneducasse.8.mcz
FlexibleVocabularies-stephaneducasse.1.mcz
Graphics-stephaneducasse.13.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.40.mcz
KernelTests-stephaneducasse.10.mcz
Morphic-stephaneducasse.51.mcz
MorphicExtras-stephaneducasse.3.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.8.mcz
Nebraska-stephaneducasse.4.mcz
Network-stephaneducasse.17.mcz
NetworkTests-md.7.mcz
PackageInfo-md.3.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-stephaneducasse.4.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-md.26.mcz
SmaCC-md.5.mcz
Sound-stephaneducasse.2.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.19.mcz
StarSqueak-stephaneducasse.4.mcz
SUnit-md.26.mcz
System-stephaneducasse.43.mcz
Tests-md.8.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
Tools-stephaneducasse.32.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true. 

! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/19/2006 14:27'!
script50
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.53.mcz
CollectionsTests-md.18.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.15.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.33.mcz
GraphicsTests-ar.8.mcz
Kernel-md.111.mcz
KernelTests-md.30.mcz
Morphic-md.83.mcz
MorphicExtras-md.22.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-stephaneducasse.4.mcz
Multilingual-md.12.mcz
Nebraska-md.8.mcz
Network-md.24.mcz
NetworkTests-gk.8.mcz
OmniBrowser-md.276.mcz
OB-Standard-cwp.93.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.9.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-stephaneducasse.6.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.31.mcz
SUnitGUI-md.5.mcz
System-md.79.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.66.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/20/2006 20:05'!
script51
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.54.mcz
CollectionsTests-md.18.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.16.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.33.mcz
GraphicsTests-ar.8.mcz
Kernel-md.111.mcz
KernelTests-md.31.mcz
Morphic-md.84.mcz
MorphicExtras-md.23.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-fbs.6.mcz
Multilingual-md.13.mcz
Nebraska-md.8.mcz
Network-md.24.mcz
NetworkTests-gk.8.mcz
OmniBrowser-cwp.279.mcz
OB-Standard-lr.99.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.3.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.11.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.31.mcz
SUnitGUI-md.5.mcz
System-md.80.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.66.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/21/2006 15:15'!
script52
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-ar.10.mcz
Flash-ar.1.mcz
TrueType-ar.1.mcz
Collections-md.55.mcz
CollectionsTests-md.18.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.17.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.33.mcz
GraphicsTests-ar.8.mcz
Kernel-md.111.mcz
KernelTests-md.31.mcz
Morphic-md.85.mcz
MorphicExtras-md.24.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-fbs.6.mcz
Multilingual-md.14.mcz
Nebraska-md.9.mcz
Network-md.25.mcz
NetworkTests-gk.8.mcz
OmniBrowser-cwp.279.mcz
OB-Standard-lr.99.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.31.mcz
SUnitGUI-md.5.mcz
System-md.81.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.66.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/22/2006 21:48'!
script53
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-mir.2.mcz
TrueType-ar.1.mcz
Collections-md.56.mcz
CollectionsTests-md.18.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.17.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.33.mcz
GraphicsTests-ar.8.mcz
Kernel-md.111.mcz
KernelTests-md.31.mcz
Morphic-md.86.mcz
MorphicExtras-md.25.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-fbs.6.mcz
Multilingual-md.15.mcz
Nebraska-md.9.mcz
Network-md.26.mcz
NetworkTests-gk.8.mcz
OmniBrowser-cwp.279.mcz
OB-Standard-lr.99.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.31.mcz
SUnitGUI-lr.6.mcz
System-md.81.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.66.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/22/2006 22:54'!
script54
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-mir.2.mcz
TrueType-ar.1.mcz
Collections-md.56.mcz
CollectionsTests-md.18.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.17.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.34.mcz
GraphicsTests-ar.8.mcz
Kernel-md.111.mcz
KernelTests-md.31.mcz
Morphic-md.87.mcz
MorphicExtras-md.25.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-fbs.6.mcz
Multilingual-md.16.mcz
Nebraska-md.10.mcz
Network-md.26.mcz
NetworkTests-gk.8.mcz
OmniBrowser-cwp.279.mcz
OB-Standard-lr.99.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.31.mcz
SUnitGUI-lr.6.mcz
System-md.81.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.66.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 3/28/2006 21:16'!
script55
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-mir.2.mcz
TrueType-ar.1.mcz
Collections-md.58.mcz
CollectionsTests-sd.22.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.17.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.34.mcz
GraphicsTests-ar.8.mcz
Kernel-md.112.mcz
KernelTests-md.32.mcz
Morphic-md.88.mcz
MorphicExtras-md.26.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.294.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-fbs.6.mcz
Multilingual-md.17.mcz
Nebraska-md.10.mcz
Network-md.26.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-lr.102.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.5.mcz
ST80-md.31.mcz
StarSqueak-sd.6.mcz
SUnit-md.31.mcz
SUnitGUI-lr.6.mcz
System-md.81.mcz
Tests-md.15.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.67.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 4/5/2006 20:01'!
script56
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-mir.2.mcz
TrueType-ar.1.mcz
Collections-md.58.mcz
CollectionsTests-sd.22.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.18.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.34.mcz
GraphicsTests-ar.8.mcz
Kernel-md.112.mcz
KernelTests-md.32.mcz
Morphic-md.90.mcz
MorphicExtras-md.26.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.295.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-md.7.mcz
Multilingual-md.17.mcz
Nebraska-md.10.mcz
Network-md.26.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-lr.103.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.5.mcz
ST80-md.32.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-lr.6.mcz
System-md.81.mcz
Tests-md.16.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.67.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 4/9/2006 22:04'!
script57
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-mir.2.mcz
TrueType-ar.1.mcz
Collections-md.58.mcz
CollectionsTests-sd.23.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.18.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-stephaneducasse.3.mcz
Graphics-md.34.mcz
GraphicsTests-ar.8.mcz
Kernel-sd.113.mcz
KernelTests-md.32.mcz
Morphic-md.90.mcz
MorphicExtras-md.26.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.295.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-md.7.mcz
Multilingual-sd.18.mcz
Nebraska-md.10.mcz
Network-md.26.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-lr.103.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.26.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.5.mcz
ST80-md.32.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-lr.6.mcz
System-md.81.mcz
Tests-md.16.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.67.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
SystemChangeNotification-Tests-sd.5.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 4/21/2006 17:38'!
script58
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-md.3.mcz
TrueType-md.2.mcz
Collections-md.59.mcz
CollectionsTests-sd.23.mcz
Compiler-md.44.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.19.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-md.4.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-md.114.mcz
KernelTests-md.32.mcz
Morphic-md.92.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.295.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-md.7.mcz
Multilingual-md.19.mcz
Nebraska-md.10.mcz
Network-md.27.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-lr.103.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.27.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-lr.6.mcz
System-md.82.mcz
Tests-md.16.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
SystemChangeNotification-Tests-sd.5.mcz
FixUnderscores-stephaneducasse.7.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 4/25/2006 18:51'!
script59
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-md.3.mcz
TrueType-md.2.mcz
Collections-md.60.mcz
CollectionsTests-md.24.mcz
Compiler-md.47.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.20.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-md.4.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-md.116.mcz
KernelTests-md.33.mcz
Morphic-md.93.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.295.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-md.27.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-lr.105.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.27.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-lr.6.mcz
System-md.83.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-stephaneducasse.14.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
SystemChangeNotification-Tests-sd.5.mcz
FixUnderscores-md.9.mcz
FixInvisible-bf.1.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 10/16/2005 17:28'!
script6
	"to work script 5 should be loaded first."
	
	"Change Set:		scanFor
	Change Set:		withOutLeadingBlanks
	SharedQueue2 : An implementation of a shared queue based on class Monitor. 
	Change Set:		FasterRectangelInsetBy
	Change Set:		Complex-ln-bug-1815-v1
	Change Set:		DebuggerCreateFix-md
	"
	
	| names |
	
	self loadOneAfterTheOther: #('Kernel-md.42.mcz') merge: false.

	names _ '
38Deprecated-md.3.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-md.32.mcz
CollectionsTests-md.10.mcz
Compiler-md.13.mcz
Compression-md.2.mcz
Exceptions-md.3.mcz
EToys-stephaneducasse.2.mcz
FFI-tbn.3.mcz
Files-stephaneducasse.8.mcz
FlexibleVocabularies-stephaneducasse.1.mcz
Graphics-md.14.mcz
GraphicsTests-md.3.mcz
Kernel-md.42.mcz
KernelTests-md.11.mcz
Morphic-stephaneducasse.51.mcz
MorphicExtras-md.4.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.275.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.8.mcz
Nebraska-stephaneducasse.4.mcz
Network-stephaneducasse.17.mcz
NetworkTests-md.7.mcz
PackageInfo-md.3.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-stephaneducasse.4.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-stephaneducasse.2.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.19.mcz
StarSqueak-stephaneducasse.4.mcz
SUnit-md.26.mcz
System-stephaneducasse.43.mcz
Tests-md.8.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
Tools-md.33.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 4/29/2006 22:59'!
script60
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-md.3.mcz
TrueType-md.2.mcz
Collections-md.60.mcz
CollectionsTests-md.24.mcz
Compiler-sd.48.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.20.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-md.4.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-sd.118.mcz
KernelTests-sd.34.mcz
Morphic-md.93.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.295.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-md.27.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-lr.105.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.27.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
System-md.83.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
SystemChangeNotification-Tests-sd.5.mcz
FixUnderscores-md.9.mcz
FixInvisible-bf.1.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 5/2/2006 21:57'!
script61
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-md.3.mcz
TrueType-md.2.mcz
Collections-md.60.mcz
CollectionsTests-sd.27.mcz
Compiler-sd.48.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.20.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-md.4.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-sd.122.mcz
KernelTests-sd.37.mcz
Morphic-sd.94.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.295.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-md.27.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-lr.105.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.27.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
System-md.83.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
SystemChangeNotification-Tests-sd.5.mcz
FixUnderscores-md.9.mcz
FixInvisible-bf.1.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 5/4/2006 15:58'!
script62
	
	"0003426: init: method should be renamed initialize: for consistency"
	"0003505: Context menus in ImageBrowser (OmniBrowser) crash due to missing methods in MenuIcons"
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-md.3.mcz
TrueType-md.2.mcz
Collections-sd.63.mcz
CollectionsTests-sd.27.mcz
Compiler-sd.48.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.20.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-md.4.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-sd.124.mcz
KernelTests-sd.37.mcz
Morphic-sd.96.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.295.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-md.27.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-sd.106.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.27.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
System-sd.84.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
SystemChangeNotification-Tests-sd.5.mcz
FixUnderscores-md.9.mcz
FixInvisible-bf.1.mcz
'  
findTokens: ' ', String cr.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 5/29/2006 20:59'!
script63
	"restore canUnderstand: + introduce canPerform:"
	
| names | 
names := '
39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Flash-md.3.mcz
TrueType-md.2.mcz
Collections-sd.63.mcz
CollectionsTests-sd.27.mcz
Compiler-sd.48.mcz 
Compression-stephaneducasse.4.mcz
Exceptions-md.7.mcz
EToys-md.20.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FlexibleVocabularies-md.4.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-sd.125.mcz
KernelTests-sd.37.mcz
Morphic-sd.96.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-al.295.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-md.27.mcz
NetworkTests-gk.8.mcz
OmniBrowser-lr.281.mcz
OB-Standard-sd.106.mcz
PackageInfo-stephaneducasse.5.mcz
ReleaseBuilder-md.4.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
Services-Base-md.27.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
System-sd.84.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.214.mcz
Speech-md.8.mcz
VersionNumber-dew.1.mcz
SystemChangeNotification-Tests-sd.5.mcz
FixUnderscores-md.9.mcz
FixInvisible-bf.1.mcz
'  
findTokens: ' ', String cr.

self halt.

	self loadTogether: names merge: true.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'al 5/7/2006 19:35'!
script64
	
	"See updateFrom7030"
	
| names | 
names := 'Kernel-al.126.mcz
Traits-al.220.mcz
FlexibleVocabularies-al.5.mcz
Monticello-al.296.mcz
System-al.85.mcz'  
findTokens: ' ', String cr.

	self loadOneAfterTheOther: names merge: false.
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 6/20/2006 18:16'!
script65
	"network team + new version of MC with merging 296-297->303
		
	Name: System-gk.45
Author: gk
Time: 21 October 2005, 11:58:31 am
UUID: f8210799-b1de-5f46-b675-8c7b83550503
Ancestors: System-gk.44

Two good refactorings based on work from Bernard Pieber for Mantis #861 in the Network package. These depend on changes in the Network package:
 
- Project class>>fromUrl:
- ProjectLoading class>>bestAccessToFileName:andDirectory:

This also removes the only sender of Project class>>serverFileFromURL: and we could nuke it, but we leave that decision for the System stewards. :)"

"Name: Network-sd.30
Author: sd
Time: 29 May 2006, 9:29:37 pm
UUID: 6da57032-4ee0-412e-830a-e6169251929e
Ancestors: Network-KLC.27, Network-tb.28, Network-tb.29

merge 
Network-tb-29, tb-28, KLC27 with netweork-md.27

Name: Network-tb.29
Author: tb
Time: 24 May 2006, 10:23:58 pm
UUID: dfdd5a1c-4494-41da-afff-925a1597b1c3
Ancestors: Network-md.27

Fixes to address http://bugs.impara.de/view.php?id=2107  FileDirectory class>>retrieveMIMEDocument: class non-existent MIMEType class>forExtension:

Name: Network-tb.28
Author: tb
Time: 24 May 2006, 9:10:03 pm
UUID: 75f7e92a-6087-4223-a373-9d6516cd35e1
Ancestors: Network-md.27

Fix for http://bugs.impara.de/view.php?id=2454 - correctly set accent-type in HttpUrl retrieveContents so fetches of .css files succeed

Name: Network-KLC.27
Author: KLC
Time: 3 April 2006, 11:18 am
UUID: b2510551-ffee-4449-94c5-48d8c31bef77
Ancestors: Network-md.26, Network-gk.18, Network-KLC.21, Network-gk.23

This is a merge of:

Network-gk.18.mcz
Network-KLC.21.mcz
Network-gk.23.mcz

Combined notes:

Network-gk.18:

Changes:

- Adds #fileName to FileUrl and HierarchicalUrl (with HttpUrl as subclass), ok - I think that is fair even if the last part of the path not necessarily denotes a file.
- Adds Url class>>directoryUrl to FileUrl and HierarchicalUrl (with HttpUrl as subclass) which simply returns a new URL with the last element in the path removed.
- Adds #absoluteFromFileNameOrUrlString: which then is used from two different places (refactoring).
- A fix so that copying a URL does not share the path collection with the original. Not sure exactly if this has caused an actual bug yet, but I agree it is a good idea to not share.
- Fix bug in FileUrl>>pathForDirectory which used an explicit pathname delimiter in one place. Duh.
- Removed class MswUrl, sorry but this should not be in standard Network package IMHO. There is no use of it in the current image.

Non behavior changes:

- Refactoring adding Url class>>urlClassForScheme:.
- Improved naming in ServerDirectory class>>serverForURL:, no actual code change.
- Refines and adds lots of comments here and there.

Differences from proposed changes from Bernard Pieber in Mantis #861:

- Did not include the proposed HierarchicalPath>>pathForDirectory because it doesn t return a path (like the same method in FileUrl does), instead it returns a URL turned into a String. I changed the few senders that Bernard Pieber (Mantis #861) introduced to directoryUrl asString instead.
- Did not add isSuperSwikiUrl, it does not belong there. It is a hack from the start.

Network-KLC.19:

This is an adaptation of the updated provided by Patrick Mauritz at Mantis ID #0411:

Change Set: Enh-ConnectionQueue
Date: 16 October 2004
Author: Patrick Mauritz

Allow classes to subscribe to the ConnectionQueue via addDependent: to get notifications when new connections are opened.
Receivers need to implement update:aSocket for this to work.
Thanks to Ken Causey for guidance on IRC.

I adapted Patrick s changes to ConnectionQueue>>listenLoop the result being that a check for a ConnectedTimedOut exception is added and a call to self changed on successful connection. Otherwise this should be the same as previously in the image.

Network-KLC.20:

As reported in Mantis ID #2106 this method included a call to the now non-existent Notification class>deprecated method. I ve replaced that call. With what I think is the appropriate mechanism.

The next question is at what point do deprecated methods get removed entirely?

Network-KLC.21:

This removes 3 methods that had no implementation other than calls to self halt. None of the 3 methods were being used and it didn t appear that they would likely ever be used.

Network-gk.23:

Fix for Mantis #2119, the simplest one described.

Fix for Mantis #1585, moved 3 test methods from OldSocket class to Socket and updated the code so that it works.

Doing the above I also fixed an issue in
Socket>>waitForDisconnectionFor:, it was wrongly waiting on semaphore instead of self readSemaphore. I also removed an unnecessary call to dataAvailable, unneeded temp var #extraBytes etc. The problem was that loopbackTest randomly hung in this method.

Optimized Socket>>discardReceivedData, unneeded call to dataAvailable removed.

Better class comments in ProtocolClient, Socket and SocketStream.

Improved comment in Socket>>closeAndDestroy:'


	Name: Monticello-al.297
	
	Time: 9 May 2006, 4:54:21 pm
	UUID: bc893983-a6cd-430c-bf5d-a4d60fdb04b3
	Ancestors: Monticello-al.295

	- fix loading traits with empty trait composition

New version merging 296 and 297 -> MC 303!!
"

	| names|
names := '39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Collections-sd.63.mcz
CollectionsTests-sd.27.mcz
Compiler-sd.48.mcz
Compression-stephaneducasse.4.mcz
EToys-md.20.mcz
Exceptions-md.7.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FixInvisible-bf.1.mcz
FixUnderscores-md.9.mcz
Flash-md.3.mcz
FlexibleVocabularies-al.5.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-al.126.mcz
KernelTests-sd.37.mcz
Monticello-sd.303.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.96.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-sd.106.mcz
OmniBrowser-lr.281.mcz
PackageInfo-stephaneducasse.5.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
ScriptLoader-sd.189.mcz
Services-Base-md.27.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
Speech-md.8.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
System-sd.86.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.220.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: true.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 6/21/2006 11:39'!
script66

	| names|
names := '39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Collections-sd.63.mcz
CollectionsTests-sd.27.mcz
Compiler-sd.48.mcz
Compression-stephaneducasse.4.mcz
EToys-md.20.mcz
Exceptions-md.7.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FixInvisible-bf.1.mcz
FixUnderscores-md.9.mcz
Flash-md.3.mcz
FlexibleVocabularies-al.5.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-sd.128.mcz
KernelTests-sd.37.mcz
Monticello-sd.304.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.96.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-sd.109.mcz
OmniBrowser-lr.281.mcz
PackageInfo-stephaneducasse.5.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
ScriptLoader-sd.200.mcz
Services-Base-md.27.mcz
SMBase-md.72.mcz
SMLoader-md.29.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
Speech-md.8.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
System-sd.86.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.220.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: true.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/4/2006 15:21'!
script67

	| names|
names := '39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Collections-sd.63.mcz
CollectionsTests-sd.27.mcz
Compiler-lr.49.mcz
Compression-stephaneducasse.4.mcz
EToys-md.20.mcz
Exceptions-md.7.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FixInvisible-bf.1.mcz
FixUnderscores-md.9.mcz
Flash-md.3.mcz
FlexibleVocabularies-al.5.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-sd.128.mcz
KernelTests-lr.38.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.96.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-sd.109.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
ScriptLoader-sd.202.mcz
Services-Base-md.27.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
Speech-md.8.mcz
ST80-md.33.mcz
StarSqueak-sd.6.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
System-sd.87.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.220.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: true.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/8/2006 11:17'!
script68

	| names|
names := '39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Collections-lr.64.mcz
CollectionsTests-lr.28.mcz
Compiler-lr.49.mcz
Compression-stephaneducasse.4.mcz
EToys-md.20.mcz
Exceptions-md.7.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FixInvisible-bf.1.mcz
FixUnderscores-md.9.mcz
Flash-md.3.mcz
FlexibleVocabularies-al.5.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-pmm.130.mcz
KernelTests-lr.38.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.96.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-al.112.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
ST80-md.33.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
ScriptLoader-al.206.mcz
Services-Base-md.27.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
Speech-md.8.mcz
StarSqueak-sd.6.mcz
System-sd.87.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.220.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: true.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/8/2006 11:13'!
script68Log

"
Name: Kernel-pmm.130
Author: pmm
Time: 6 July 2006, 8:59:24 pm
UUID: ca825d54-f890-4bcb-be38-4a718f29459b
Ancestors: Kernel-al.129

- fix browsing with alt+b for globals like Smalltalk
- push #isTrait to Object like #isBehavior

Name: Kernel-al.129
Author: al
Time: 3 July 2006, 3:58:12 pm
UUID: ea1c48cf-2455-4fa5-ad13-75616626321b
Ancestors: Kernel-sd.128

- small fix of the ClassBuilder (when redefining a class, its class side traits were lost)

Name: Collections-lr.64
Author: lr
Time: 7 July 2006, 11:33:53 am
UUID: b45346c1-0d9b-11db-a7b8-000a9573eae2
Ancestors: Collections-sd.63

- revert string comparison to the 3.7 behavior


Name: CollectionsTests-lr.28
Author: lr
Time: 7 July 2006, 11:34:31 am
UUID: cac623bf-0d9b-11db-a7b8-000a9573eae2
Ancestors: CollectionsTests-sd.27

- revert string comparison to the 3.7 behavior

Name: OB-Standard-al.112
Author: al
Time: 7 July 2006, 11:14:56 am
UUID: fd3a8638-1e50-45b5-ad4a-f5224054a331
Ancestors: OB-Standard-pmm.111

- manually merged in Alex' enhancement:

Enhancement: When you find a class by pressing Alt-f for example, you may have a very long list. Even if you type the exact name of the class. This changeset place as the first choice the class you entered.

For instance, try to search for Object. You have a very long list, this change makes Object the first entry of the menu
"
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/8/2006 19:09'!
script69

	| names|
names := '39Deprecated-md.11.mcz
Balloon-mir.11.mcz
Collections-sd.67.mcz
CollectionsTests-sd.30.mcz
Compiler-lr.49.mcz
Compression-stephaneducasse.4.mcz
EToys-md.20.mcz
Exceptions-md.7.mcz
FFI-CdG.4.mcz
Files-md.16.mcz
FixInvisible-bf.1.mcz
FixUnderscores-md.9.mcz
Flash-md.3.mcz
FlexibleVocabularies-al.5.mcz
Graphics-md.35.mcz
GraphicsTests-ar.8.mcz
Kernel-sd.132.mcz
KernelTests-sd.39.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.97.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-al.112.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
ST80-md.33.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
ScriptLoader-sd.210.mcz
Services-Base-md.27.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
Speech-md.8.mcz
StarSqueak-sd.6.mcz
System-sd.87.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.220.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: true.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/8/2006 19:08'!
script69Log

"
0003784: String>>unescapePercentsWithTextEncoding: is subtle broken
http://bugs.impara.de/view.php?id=3784

0003568: [FIX] Fraction>>asFloat does not answer nearest floating point number

0003564: LargeInteger>>asFloat does not honour IEEE rounding mode

0004078: Misuse of #inject:into: in DependentsArray>>size

0003339: [Fix] Simple button morphs don't reset their color properly when balked.

0003531: [Fix] In 7027 Scriptable button now turns wrong color when balked.

"
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 10/19/2005 09:37'!
script7
	"test..."
	
	"Compiler al: 0001820: Parser>>parseArgsAndTemps: broken
	removed Package list
	hardcoded fileList reference
	"
	
	| names |
	
	self loadOneAfterTheOther: #('Kernel-md.42.mcz') merge: false.

	names _ '
38Deprecated-md.3.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-md.32.mcz
CollectionsTests-md.10.mcz
Compiler-sd.14.mcz 
Compression-md.2.mcz
Exceptions-md.3.mcz
EToys-stephaneducasse.2.mcz
FFI-tbn.3.mcz
Files-stephaneducasse.8.mcz
FlexibleVocabularies-stephaneducasse.1.mcz
Graphics-md.14.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.43.mcz
KernelTests-md.11.mcz
Morphic-stephaneducasse.51.mcz
MorphicExtras-md.4.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-md.275.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.8.mcz
Nebraska-stephaneducasse.4.mcz
Network-stephaneducasse.17.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-stephaneducasse.4.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-stephaneducasse.2.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.19.mcz
StarSqueak-stephaneducasse.4.mcz
SUnit-md.26.mcz
System-stephaneducasse.43.mcz
Tests-md.8.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
Tools-stephaneducasse.34.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/10/2006 20:25'!
script70

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-pmm.68.mcz
CollectionsTests-sd.30.mcz
Compiler-lr.50.mcz
Compression-ar.8.mcz
EToys-md.20.mcz
Exceptions-md.7.mcz
FFI-ar.11.mcz
Files-md.16.mcz
FixInvisible-bf.1.mcz
FixUnderscores-md.9.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.38.mcz
GraphicsTests-ar.9.mcz
Kernel-sd.132.mcz
KernelTests-lr.40.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.97.mcz
MorphicExtras-md.27.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-md.10.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-al.112.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
ST80-md.33.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
ScriptLoader-sd.216.mcz
Services-Base-md.27.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
Speech-md.8.mcz
StarSqueak-sd.6.mcz
System-sd.87.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.220.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/9/2006 23:02'!
script70Log

"
Name: Compiler-lr.50
Author: lr
Time: 9 July 2006, 7:56:43 pm
UUID: 47ef9423-0f74-11db-b64a-000a9573eae2
Ancestors: Compiler-lr.49

- fixed more pragma bugs (throw an error for <1> and <foo bar>)
Name: Collections-pmm.68
Author: pmm
Time: 9 July 2006, 11:53:56 am
UUID: 20686bef-7acd-4afc-a610-a4485c82ffb1
Ancestors: Collections-sd.67

changes with respect to: http://bugs.impara.de/view.php?id=1876
- changed Set class >> #new: according to comments of ar, this fixes the hiccup at around 4k elements
- removed the progress bar from Set class >> #rehash all sets. This allows to load the changesets and makes in possibly faster (old version waits 2ms for each set when querying the mouse position)

Name: Balloon-ar.13
Author: ar
Time: 5 April 2006, 12:23:02 am
UUID: bdaaa697-27c2-4049-a7e8-13e44a41f929
Ancestors: Balloon-ar.11

- replace underscore assignment with colon-equals
Name: Compression-ar.8
Author: ar
Time: 5 April 2006, 12:25:07 am
UUID: 3c075d58-b256-704c-9870-6998a0c8e9ce
Ancestors: Compression-ar.6

- replace underscore assignment with colon-equals

Name: FFI-ar.11
Author: ar
Time: 8 July 2006, 9:25:14 pm
UUID: e964ce57-a9a6-2a4e-9572-685f6b711fba
Ancestors: FFI-ar.10

- include non-Mantis fixes

Name: Flash-ar.5
Author: ar
Time: 8 July 2006, 9:21:53 pm
UUID: d7099247-3e7a-d742-921d-8dd73cf0fa07
Ancestors: Flash-ar.4

- include improved image supports

Name: Graphics-ar.38
Author: ar
Time: 8 July 2006, 8:51:07 pm
UUID: 38143d92-893f-ec4f-9882-0e7d947ca710
Ancestors: Graphics-ar.37

- include fix for BitBlt rounding

Name: GraphicsTests-ar.9
Author: ar
Time: 8 July 2006, 7:08:18 pm
UUID: ce2beab2-9473-4d49-8302-b959486e7bf8
Ancestors: GraphicsTests-ar.8

- Integrate http://bugs.impara.de/view.php?id=3804
"
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/12/2006 22:57'!
script71

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-pmm.68.mcz
CollectionsTests-sd.30.mcz
Compiler-lr.50.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-md.7.mcz
FFI-ar.11.mcz
Files-md.16.mcz
FixInvisible-bf.1.mcz
FixUnderscores-md.9.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.38.mcz
GraphicsTests-ar.9.mcz
Kernel-sd.134.mcz
KernelTests-sd.41.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.99.mcz
MorphicExtras-sd.28.mcz
MorphicTests-stephaneducasse.4.mcz
Movies-md.7.mcz
Multilingual-md.20.mcz
Nebraska-sd.11.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-al.112.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-md.30.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
ST80-md.33.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
ScriptLoader-sd.231.mcz
Services-Base-md.27.mcz
SmaCC-fbs.8.mcz
Sound-md.6.mcz
Speech-md.8.mcz
StarSqueak-sd.6.mcz
System-sd.87.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-al.221.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/12/2006 19:13'!
script71Log

"
0004166: Fix for rejected Graphics extensions
Description
The following extensions to the graphics packages have been proposed and rejected:
  Color class>>saturatedRandom
  Form>>dominantColorWithoutTransparent
The attached CS provides code such that Kedama works correctly without the rejected extensions.
'From Squeak3.9alpha of 4 July 2005 [latest update: #7035] on 8 July 2006 at 8:35:26 pm'!!
Change Set:		KedamaFix
Date:			8 July 2006
Author:			Andreas Raab

Change set for rejected extensions Color class>>saturatedRandomColor and Form>>dominantColorWithoutTransparent


0004168: Fix for Color's colorPalette: removal
Description
Color>>colorPaletteForDepth: has been removed to avoid the dependency between Color and NaturalLanguageTranslator. The attached change set provides an implementation in ColorPickerMorph and fixes the existing references.

0004169: StrikeFont>>decodedFromRemoteCanvas: does not belong to Graphics
Description
StrikeFont>>decodedFromRemoteCanvas: was included in the graphics package. The attached change set puts it under Nebraska, where it belongs.

0004170: Fix for rejected SmallLand extensions of Graphics
Description
The following proposed extensions of the Graphics package have been rejected:
- Color>>iconOrThumbnailOfSize:
- Form>>iconOrThumbnailOfSize:
- Form>>scaledIntoFormOfSize:
The attached change sets provides them as *Morphic extensions.

0003821: addMonths: does not handle leap years correctly

"
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/13/2006 17:22'!
script72

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-pmm.68.mcz
CollectionsTests-sd.30.mcz
Compiler-lr.50.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-ar.11.mcz
Files-md.17.mcz
FixInvisible-bf.1.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.38.mcz
GraphicsTests-ar.9.mcz
Kernel-sd.138.mcz
KernelTests-sd.42.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.99.mcz
MorphicExtras-sd.29.mcz
MorphicTests-md.5.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-al.112.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
ST80-sd.34.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
ScriptLoader-sd.243.mcz
Services-Base-md.27.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.8.mcz
StarSqueak-sd.6.mcz
System-md.88.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-sd.15.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-stephaneducasse.16.mcz
ToolBuilder-SUnit-stephaneducasse.10.mcz
Tools-md.68.mcz
Traits-sd.222.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/13/2006 17:16'!
script72Log

	"Smacc
	preferenceBrowser
	underscore
	
	Name: Kernel-md.135
Author: md
Time: 12 July 2006, 10:25:06 pm
UUID: 61de8206-a937-4ad9-a401-c82f20946fa0
Ancestors: Kernel-sd.134

fix CompiledMethod>>#= to ignore the last two literals
(we may want to extend it to take pragmas into account
for equality later...)
	
	Name: Files-md.17
Author: md
Time: 12 July 2006, 11:10:35 pm
UUID: e4f7668b-a5ed-4a46-b9ce-a100fc0985fd
Ancestors: Files-md.16

0003723: [FIX] DosFileDirectoryTests>>testFileDirectoryNonExistence
Description
The change set included with this bug report fixes the test DosFileDirectoryTests>>testFileDirectoryNonExistence

Name: MorphicTests-md.5
Author: md
Time: 12 July 2006, 11:09:16 pm
UUID: f2394cd3-e068-4a37-acfd-0258e0937a9a
Ancestors: MorphicTests-stephaneducasse.4

0003566: TileMoprhTest>>testSoundMorph fails; fix attached
Description
in 3.9a 7029 (and 3.8 6665) TileMoprhTest>>testSoundMorph fails because it expects 'silence' to be one up from 'croak' but the menu provides 'horn'. This just fixes the test.
	
	0003571: EventManager commen
Description
In 3.9a 7029 (and earlier) EventManagerTest produces one failure because of missing class comments. This cs adds reasonable class comments for EventManager and two related classes as part of the effort to get all tests to run green.

0003729: [FIX] FontTest>>testResetAfterEmphasized

Name: Exceptions-sd.8
Author: sd
Time: 13 July 2006, 3:15:11 pm
UUID: 169d4c2b-c7f8-44bd-8621-ffcf2feb1c97
Ancestors: Exceptions-md.7

0000530: ExceptionTests>>#testTimeout works only some of the time
Description
When I run this test several times with the SUnit Test Runner it sometimes works and sometimes fails

0003648: explicit ^self in #yourself
Description
... when it's important to return self, write it. (from the best practice patterns). yourself would
be a nice example to show this in a lecture.

0003628: refactoring for hasInstVarRef
Description
hasInstVarRef was only defined on the Context, this one moved the implementation from
MethodContext to compiledMethod (and just forwards from MethodContext).

Additionally, the changeset has a small refactoring to use BlockContext>>#endPC in BlockContext>>#hasInstVarRef

0003529: BlockContextTest tests fail in 7025; fix attached
Description
In 3.9a 7025 four BlockContextTest tests failed because Jerome Peace's valueSupplyingAnswers: functionality was regressed out of PopUpMenu when icons where added to the menu. I suspect that the reason this wasn't caught is that the change was made to PopUp but the relevant s-unit tests were in BlockContextTest, so I added an test few method for the so called ST80-Menus. There was also one trivial error in a single BlockContextTest which I fixed.
Without this fix running the test requires user responses on the four failing tests and several other.

	"! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/14/2006 13:36'!
script73

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.69.mcz
CollectionsTests-md.31.mcz
Compiler-lr.50.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-ar.11.mcz
Files-md.17.mcz
FixInvisible-bf.1.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.139.mcz
KernelTests-sd.42.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-sd.99.mcz
MorphicExtras-sd.29.mcz
MorphicTests-md.5.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-sd.30.mcz
NetworkTests-gk.8.mcz
OB-Standard-al.112.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
ST80-sd.35.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
ScriptLoader-sd.247.mcz
Services-Base-md.27.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.8.mcz
StarSqueak-sd.6.mcz
System-md.88.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-ar.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-ar.11.mcz
Tools-md.68.mcz
Traits-sd.222.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/14/2006 13:35'!
script73Log

	"	
	Name: Graphics-ar.39
Author: ar
Time: 13 July 2006, 11:01:44 am
UUID: 8493073d-14aa-7643-9a13-574d84f7b2c3
Ancestors: Graphics-ar.38

- include fix from http://bugs.impara.de/view.php?id=3570
+ test

http://squeaksource.com/ToolBuilder/ToolBuilder-Kernel-ar.16.mcz
http://squeaksource.com/ToolBuilder/ToolBuilder-Morphic-ar.19.mcz
http://squeaksource.com/ToolBuilder/ToolBuilder-SUnit-ar.11.mcz
http://squeaksource.com/ToolBuilder/ToolBuilder-MVC-dtl.12.mcz

The main change is that some support for menus has been added.

Name: CollectionsTests-md.31
Author: md
Time: 14 July 2006, 12:38:43 pm
UUID: 58b1f6ed-6778-4e8b-a006-6a3a42c75b5a
Ancestors: CollectionsTests-sd.30, CollectionsTests-dc.29


0003829: [FIX] Better tests for Stack
Description
I modify my tests for the Stack class. They do not call private methods anymore.

----------------------------


Name: Collections-md.69
Author: md
Time: 14 July 2006, 12:36:25 pm
UUID: 6164f840-096e-4191-b280-9a492bea167f
Ancestors: Collections-pmm.68

0003887: SequenceableCollection>>, wrong comment

----------------------------

Name: Kernel-md.139
Author: md
Time: 14 July 2006, 12:42:52 pm
UUID: 7de16533-743b-438b-84ac-e57243b709a4
Ancestors: Kernel-sd.138

In 3.9b-7029, WeakMessageSendTest fails for lack of class comments. I spent about a hour studying the class and provided a reasonable class comment.
All KernalTests-Objects now run green.

- fix for Paragrapheditor>>#prettyPrint:

----------------------------

	
	"! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/14/2006 20:50'!
script74


	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.69.mcz
CollectionsTests-md.31.mcz
Compiler-md.51.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-ar.11.mcz
Files-md.17.mcz
FixInvisible-bf.1.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.140.mcz
KernelTests-sd.42.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.102.mcz
MorphicExtras-md.30.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard-al.112.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
ST80-sd.35.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.27.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.8.mcz
StarSqueak-sd.6.mcz
System-md.89.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-ar.16.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-ar.11.mcz
Tools-md.69.mcz
Traits-sd.222.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: true.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/14/2006 19:54'!
script74Log

	"
	Name: Compiler-md.51
Author: md
Time: 14 July 2006, 4:39:56 pm
UUID: be84aa2e-c1fc-4783-886b-42ba38142007
Ancestors: Compiler-lr.50

removed broken tests

===================================

Name: Kernel-md.140
Author: md
Time: 14 July 2006, 4:41:50 pm
UUID: f3d2af43-b5d8-4404-b1a8-fa2c562dee3b
Ancestors: Kernel-md.139

0003993: Number does not read '1.0e-10 .txt' from file

====================================

Name: Network-md.32
Author: md
Time: 14 July 2006, 4:55 pm
UUID: 44e40f51-06fe-4d40-8b7a-33ca8d0157b1
Ancestors: Network-md.31

0003762: (Fast)SocketStream's class comment has not been updated since image inclusion


Name: Morphic-md.102
Author: md
Time: 14 July 2006, 4:52:08 pm
UUID: 1ada4657-9c73-47ec-b9c3-0f68d6c1a8d7
Ancestors: Morphic-md.101, Morphic-md.100

merge with 100

Name: Morphic-md.101
Author: md
Time: 14 July 2006, 4:44:01 pm
UUID: 55361be6-6ac2-4005-a77c-9b56ee4f02b0
Ancestors: Morphic-sd.99

0003747: TransformMorph crashes when picked up by handMorph after scaleFactor: is called

0003533: [Enh] Targetsighting menu items want to use a target sight as a cursor.


====================================
Name: NetworkTests-md.9
Author: md
Time: 14 July 2006, 4:56:20 pm
UUID: 8ce5bafc-7d80-4ea8-9730-beeced99ff08
Ancestors: NetworkTests-gk.8

0003589: [BUG][FIX] UUIDPrimitivesTest>>testCreationRandom


====================================

Name: Tools-md.69
Author: md
Time: 14 July 2006, 4:58:37 pm
UUID: b40e0d66-5103-449d-946d-7cc8bdb4c6c6
Ancestors: Tools-md.68

Fix for FilecontentsBrowser>>browseStream

	
	
	Name: Morphic-md.100
Author: md
Time: 14 July 2006, 2:52:06 pm
UUID: da4fe617-8ded-40e8-810e-6d60c3a8e551
Ancestors: Morphic-sd.99

0003530: SimpleSwitchMorph does not actually implement switch functionality
0003690: CircleMorph has inimplemented message sends

========================================

Name: MorphicExtras-md.30
Author: md
Time: 14 July 2006, 2:57:01 pm
UUID: fdd65f8d-6bae-41aa-acaa-505086574ca4
Ancestors: MorphicExtras-sd.29

0003530: SimpleSwitchMorph does not actually implement switch functionality

=========================================

Name: MorphicTests-md.6
Author: md
Time: 14 July 2006, 3:02:09 pm
UUID: 12154457-e61a-4c5c-bc48-828ee1a9d733
Ancestors: MorphicTests-md.5

0003530: SimpleSwitchMorph does not actually implement switch functionality

0003690: CircleMorph has inimplemented message sends

0003699: [BUG][FIX]ClockMorph toggleRoman broken

=========================================

Name: Network-md.31
Author: md
Time: 14 July 2006, 3:04:24 pm
UUID: 427298a6-340d-4916-ad92-1b0303a4dbff
Ancestors: Network-sd.30

0003264: (Fast)SocketStream SocketStream>>print: missing

=============================================

Name: System-md.89
Author: md
Time: 14 July 2006, 3:08:03 pm
UUID: 4e78aa2c-2640-44bd-9c19-814b516c15d7
Ancestors: System-md.88

0003647: Smalltalk>>version should not be deprecated

- Commenrt for MessageSend
"! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/15/2006 21:54'!
script75

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.69.mcz
CollectionsTests-md.32.mcz
Compiler-md.51.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-md.12.mcz
Files-md.18.mcz
FixInvisible-bf.1.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.142.mcz
KernelTests-md.44.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.104.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard-al.112.mcz
OmniBrowser-lr.281.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-gk.84.mcz
SMLoader-gk.31.mcz
ST80-sd.35.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.27.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.90.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.69.mcz
Traits-sd.222.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/15/2006 18:39'!
script75Log


	"ToolBuilder colin fixes
		http://bugs.impara.de/view.php?id=3588 was bogus
		
	Name: Morphic-md.103
Author: md
Time: 14 July 2006, 9:32:32 pm
UUID: e9a3551d-a01a-4129-959a-87afdea47a97
Ancestors: Morphic-md.102

0003753: Loading a .morph file from FileList causes error: Invalid utf8 input detected

=================================

Name: MorphicExtras-md.31
Author: md
Time: 14 July 2006, 9:35:39 pm
UUID: 28f52c31-f38d-4cd2-b659-2fa4d9eb0f8d
Ancestors: MorphicExtras-md.30

0003753: Loading a .morph file from FileList causes error: Invalid utf8 input detected

====================================


Name: KernelTests-md.43
Author: md
Time: 14 July 2006, 9:31:17 pm
UUID: 3b672bd1-ae61-4344-b4e9-e5400a269725
Ancestors: KernelTests-sd.42

0003512: Number>>readFrom: does not handle error cases correctly


===================================


Name: Kernel-md.141
Author: md
Time: 14 July 2006, 9:29:25 pm
UUID: 00e649d3-606d-4d42-b9e5-548e765bf1fd
Ancestors: Kernel-md.140

0002151: Max number of literals checked in MethodNode instead of CompiledMethod

0003512: Number>>readFrom: does not handle error cases correctly

================================

Name: CollectionsTests-md.32
Author: md
Time: 15 July 2006, 6:12:47 pm
UUID: b44f4f02-6ab0-40cf-8717-3604be42fdf6
Ancestors: CollectionsTests-md.31

test from 0003574: String>>findFirstInString:inSet:startingAt: does not work if character of interest is last character in String, also WideString

0004265: SUnit test WeakIdentityKeyDictionaryTest>>testNoNils fails


===================================

Name: Files-md.18
Author: md
Time: 15 July 2006, 6:13:59 pm
UUID: 50358b69-2700-4d87-a768-b80af0d4bc68
Ancestors: Files-md.17

0004266: AsyncFile class variable Error collides with global class name

======================================


Name: Kernel-md.142
Author: md
Time: 15 July 2006, 6:16:17 pm
UUID: bc06ef54-5012-4b93-805f-f0ea2a234cd7
Ancestors: Kernel-md.141

0002120: Remove Object>>externalCallFailed from Kernel package
0004138: ScaledDecimals are parsed incorrectly in 3.9b-7036
0003609: Integer >> crossSumBase: aBase\
0003820: Code or comment in Date>>fromString: incorrect

=======================

Name: KernelTests-md.44
Author: md
Time: 15 July 2006, 6:17:58 pm
UUID: 7fa2d72a-b000-4964-9607-7e92f885ba35
Ancestors: KernelTests-md.43

0004138: ScaledDecimals are parsed incorrectly in 3.9b-7036
0003609: Integer >> crossSumBase: aBase\
0004260: SUnit test ClassBuilderChangeClassTypeTest>>testClassCreationAndChange fails

===========================

Name: Morphic-md.104
Author: md
Time: 15 July 2006, 6:19:45 pm
UUID: b6fe7c5a-13b0-447f-af8b-a2bce9939684
Ancestors: Morphic-md.103

0003526: DNU when detaching a submenu

==============================

Name: Speech-md.9
Author: md
Time: 15 July 2006, 6:21:12 pm
UUID: d8ae2a9c-d222-4eac-b069-6d31a5c457f9
Ancestors: Speech-md.8

0003506: some _ wrongly converted to _

Name: FFI-md.12
Author: md
Time: 15 July 2006, 6:27:16 pm
UUID: b53777ee-054a-4055-9730-7b9b92874d8d
Ancestors: FFI-ar.11

add Object>>#externalCallFailed

Name: System-md.90
Author: md
Time: 15 July 2006, 6:30:58 pm
UUID: e1372493-ff32-47ca-b091-4685e893552a
Ancestors: System-md.89

0003790: Text cursor too bright
First part	
	
	"! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/16/2006 16:40'!
script76

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.69.mcz
CollectionsTests-md.32.mcz
Compiler-md.51.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-md.12.mcz
Files-md.18.mcz
FixInvisible-bf.1.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.142.mcz
KernelTests-md.44.mcz
Monticello-al.305.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.104.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard.39-cwp.3.mcz
OmniBrowser.39-cwp.1.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-sd.85.mcz
SMLoader-gk.31.mcz
ST80-sd.35.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.27.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.90.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.69.mcz
Traits-sd.223.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 7/16/2006 16:39'!
script76Log

	"smbase fixed
	traits undeclared fixed
	http://source.squeakfoundation.org/inbox/OmniBrowser.39-cwp.1.mcz
http://source.squeakfoundation.org/inbox/OB-Standard.39-cwp.3.mcz"! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 7/23/2006 12:37'!
script77

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.70.mcz
CollectionsTests-md.33.mcz
Compiler-md.51.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-md.12.mcz
Files-md.18.mcz
FixInvisible-bf.1.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.144.mcz
KernelTests-md.45.mcz
Monticello-md.308.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.107.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard.39-cwp.3.mcz
OmniBrowser.39-cwp.1.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-sd.85.mcz
SMLoader-md.32.mcz
ST80-sd.35.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.27.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.90.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.71.mcz
Traits-al.224.mcz
TrueType-md.2.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 7/23/2006 12:34'!
script77Log

	"
0004312: Refactoring for behavior>>#new
0004307: DependentsArray>>copyWith:
0003133: [BUG][FIX] Float>>#asIEEE32BitWord and #fromIEEE32Bit:
0003309: In 7008 Requesting setTarget for menus can get a UndefinedObject DNU>isHandMorph
004249: SmLoader>>#categorySpecificOptions has a . after the variable definition
0004298: OrderedCollection>>#removeLast: 2; size is negative	
0004314: CleanUpMacOptionKeyPressed-md.cs
0003765: ChangeLists and VersionBrowsers don't respect standardCodeFont preference.
0003777: In 7033 In ImageBrowser (omnibrowser) copyListToClipboard menu item causes a DNU.
0004273: small fix for prettyprinting (for 3.9)

=============
	Name: Monticello-al.306
Author: al
Time: 18 July 2006, 3:53:31 pm
UUID: 2db4087e-d6a1-46d2-92bc-04f50020ff54
Ancestors: Monticello-al.305

merge in changes of Monticello-avi.276 and Monticello-avi.277 from the SqS MC repository:

- Don't allow the active repo to be switched mid commit.
- Minor optimization to dependency commits.
=================
Name: Traits-al.224
Author: al
Time: 21 July 2006, 10:06:32 pm
UUID: 3e5920f4-7cd8-40e4-b69f-7441f240f68b
Ancestors: Traits-sd.223

- expected sentinfo test failures
================




	"! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 7/23/2006 13:29'!
script78

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.70.mcz
CollectionsTests-md.33.mcz
Compiler-md.51.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-md.12.mcz
Files-md.18.mcz
FixInvisible-bf.1.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.144.mcz
KernelTests-md.45.mcz
Monticello-md.308.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.107.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard.39-cwp.3.mcz
OmniBrowser.39-cwp.1.mcz
PackageInfo-al.6.mcz
PlusTools-md.34.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-sd.85.mcz
SMLoader-md.32.mcz
ST80-sd.35.mcz
SUnit-md.32.mcz
SUnitGUI-sd.7.mcz
Services-Base-rr.29.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.91.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.71.mcz
Traits-al.224.mcz
TrueType-ar.4.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 7/23/2006 13:29'!
script78Log

	"
- Load: TrueType-ar.4
- load 0003766: Hundreds of methods have source containing LF characters
- Services-Base-rr.29
	"! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 8/2/2006 18:04'!
script79

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.70.mcz
CollectionsTests-md.33.mcz
Compiler-md.53.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-md.12.mcz
Files-md.18.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.146.mcz
KernelTests-md.47.mcz
Monticello-md.308.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.110.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard.39-cwp.3.mcz
OmniBrowser.39-cwp.1.mcz
PackageInfo-al.6.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-sd.85.mcz
SMLoader-md.32.mcz
ST80-sd.35.mcz
SUnit-md.33.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.33.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.91.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.74.mcz
Traits-al.224.mcz
TrueType-ar.4.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 10/28/2005 21:25'!
script8
	"test..."
	
	"MC277
	kernel 44 fix classbuilder for traits
	"
	
	| names |
	
	self loadOneAfterTheOther: #('Kernel-md.42.mcz') merge: false.

	names _ '
38Deprecated-md.3.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-md.32.mcz
CollectionsTests-md.10.mcz
Compiler-sd.14.mcz 
Compression-md.2.mcz
Exceptions-md.3.mcz
EToys-stephaneducasse.2.mcz
FFI-tbn.3.mcz
Files-stephaneducasse.8.mcz
FlexibleVocabularies-stephaneducasse.1.mcz
Graphics-md.14.mcz
GraphicsTests-md.3.mcz
Kernel-stephaneducasse.44.mcz
KernelTests-md.11.mcz
Morphic-stephaneducasse.51.mcz
MorphicExtras-md.4.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.277.mcz
Movies-stephaneducasse.3.mcz
Multilingual-stephaneducasse.8.mcz
Nebraska-stephaneducasse.4.mcz
Network-stephaneducasse.17.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-stephaneducasse.4.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-stephaneducasse.2.mcz
Speech-stephaneducasse.5.mcz
ST80-stephaneducasse.19.mcz
StarSqueak-stephaneducasse.4.mcz
SUnit-md.26.mcz
System-stephaneducasse.45.mcz
Tests-md.8.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
Tools-stephaneducasse.34.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.
	
! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 8/2/2006 20:52'!
script80

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.70.mcz
CollectionsTests-md.33.mcz
Compiler-md.53.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-md.12.mcz
Files-md.18.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.147.mcz
KernelTests-md.47.mcz
Monticello-md.308.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.111.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-sd.11.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard.39-cwp.3.mcz
OmniBrowser.39-cwp.1.mcz
PackageInfo-al.6.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-sd.85.mcz
SMLoader-md.32.mcz
ST80-sd.35.mcz
SUnit-md.33.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.33.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.91.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.74.mcz
Traits-al.224.mcz
TrueType-ar.4.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 8/10/2006 12:03'!
script81

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.70.mcz
CollectionsTests-md.33.mcz
Compiler-md.53.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-md.12.mcz
Files-md.18.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.147.mcz
KernelTests-md.47.mcz
Monticello-md.308.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.112.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-md.13.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard.39-cwp.3.mcz
OmniBrowser.39-cwp.1.mcz
PackageInfo-al.6.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-sd.85.mcz
SMLoader-md.32.mcz
ST80-sd.35.mcz
SUnit-md.33.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.33.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.94.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.74.mcz
Traits-al.224.mcz
TrueType-ar.4.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 8/10/2006 12:03'!
script82

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.70.mcz
CollectionsTests-md.33.mcz
Compiler-md.53.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
FFI-md.12.mcz
Files-md.18.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.147.mcz
KernelTests-md.47.mcz
Monticello-md.308.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.112.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-md.13.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard.39-cwp.3.mcz
OmniBrowser.39-cwp.1.mcz
PackageInfo-al.6.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-sd.85.mcz
SMLoader-md.32.mcz
ST80-sd.35.mcz
SUnit-md.33.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.33.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.94.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.74.mcz
Traits-al.224.mcz
TrueType-ar.4.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'md 9/7/2006 22:44'!
script83

	| names|
names := '39Deprecated-md.11.mcz
Balloon-ar.13.mcz
Collections-md.70.mcz
CollectionsTests-md.33.mcz
Compiler-md.53.mcz
Compression-ar.8.mcz
EToys-sd.21.mcz
Exceptions-sd.8.mcz
Files-md.18.mcz
FixUnderscores-cmm.10.mcz
Flash-ar.5.mcz
FlexibleVocabularies-al.5.mcz
Graphics-ar.39.mcz
GraphicsTests-ar.9.mcz
Kernel-md.148.mcz
KernelTests-md.47.mcz
Monticello-md.308.mcz
MonticelloConfigurations-stephaneducasse.38.mcz
Morphic-md.112.mcz
MorphicExtras-md.31.mcz
MorphicTests-md.6.mcz
Movies-md.7.mcz
Multilingual-sd.21.mcz
Nebraska-md.13.mcz
Network-md.32.mcz
NetworkTests-md.9.mcz
OB-Standard.39-cwp.3.mcz
OmniBrowser.39-cwp.1.mcz
PackageInfo-al.6.mcz
PreferenceBrowser-hpt.32.mcz
Protocols-md.12.mcz
ReleaseBuilder-md.4.mcz
SMBase-sd.85.mcz
SMLoader-md.32.mcz
ST80-sd.35.mcz
SUnit-md.33.mcz
SUnitGUI-sd.7.mcz
Services-Base-md.33.mcz
SmaCC-md.9.mcz
Sound-md.6.mcz
Speech-md.9.mcz
StarSqueak-sd.6.mcz
System-md.94.mcz
SystemChangeNotification-Tests-sd.5.mcz
Tests-md.17.mcz
ToolBuilder-Kernel-cwp.17.mcz
ToolBuilder-MVC-dtl.12.mcz
ToolBuilder-Morphic-ar.19.mcz
ToolBuilder-SUnit-cwp.12.mcz
Tools-md.74.mcz
Traits-al.224.mcz
TrueType-ar.4.mcz
VersionNumber-dew.1.mcz'
findTokens: ' ', String cr.

	self loadTogether: names merge: false.! !

!ScriptLoader methodsFor: 'scripts' stamp: 'sd 8/13/2006 19:43'!
script83Log

	"unloading FFI"! !

!ScriptLoader methodsFor: 'scripts' stamp: 'stephaneducasse 11/1/2005 14:21'!
script9
	"This version loads Tools-CdG.36 to avoid the merge of Tools.ab28"
	
	"PlusTools Mantis 1915
	did not touch 
	
	PackageInfo-CdG.4.mcz is not needed since PackageList has been removed.
	
	Needed from here: the four changesets and PlusTools
	"
	
	| names |
	
	"sd: it is not needed: self loadOneAfterTheOther: #('Kernel-md.42.mcz') merge: false."

	names _ '
38Deprecated-CdG.4.mcz
39Deprecated-stephaneducasse.3.mcz
Balloon-stephaneducasse.7.mcz
BalloonMMFlash-stephaneducasse.3.mcz
Collections-CdG.35.mcz
CollectionsTests-md.10.mcz
Compiler-CdG.19.mcz 
Compression-CdG.3.mcz
Exceptions-CdG.4.mcz
EToys-stephaneducasse.2.mcz
FFI-CdG.4.mcz
Files-CdG.13.mcz
FlexibleVocabularies-CdG.2.mcz
Graphics-CdG.16.mcz
GraphicsTests-md.3.mcz
Kernel-CdG.49.mcz
KernelTests-CdG.13.mcz
Morphic-CdG.55.mcz
MorphicExtras-CdG.7.mcz
MorphicTests-stephaneducasse.4.mcz
Monticello-bf.277.mcz
Movies-stephaneducasse.3.mcz
Multilingual-CdG.10.mcz
Nebraska-CdG.5.mcz
Network-CdG.21.mcz
NetworkTests-md.7.mcz
PackageInfo-stephaneducasse.4.mcz
PreferenceBrowser-hpt.27.mcz
Protocols-CdG.7.mcz
SMBase-stephaneducasse.69.mcz
SMLoader-bp.27.mcz
SmaCC-md.5.mcz
Sound-CdG.3.mcz
Speech-stephaneducasse.5.mcz
ST80-CdG.23.mcz
StarSqueak-CdG.5.mcz
SUnit-CdG.28.mcz
System-CdG.46.mcz
Tests-CdG.9.mcz
ToolBuilder-Kernel-ar.13.mcz
ToolBuilder-Morphic-md.15.mcz
ToolBuilder-MVC-ar.8.mcz
ToolBuilder-SUnit-ar.9.mcz
Tools-CdG.36.mcz
VersionNumber-dew.1.mcz
' findTokens: ' ', String cr.

	self loadTogether: names merge: true.
	
! !


!ScriptLoader methodsFor: 'updates' stamp: 'stephaneducasse 10/28/2005 20:21'!
updateFrom6693
	"self new updateFrom6693"
	
	self script5.
	self script7.
	self flushCaches.
	
	"does not work with script 8 instead of 7 from an 6693 image"! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 10/31/2005 18:03'!
updateFrom6695
	"self new updateFrom6695"
	
	"previous version was tested by adrian and works
	this one with script9 was not..."
	self addRepositoryToPackageNamed: 'FlexibleVocabularies'.
	self addRepositoryToPackageNamed: 'EToys'.
	self addRepositoryToPackageNamed: 'BalloonMMFlash'.
	self addRepositoryToPackageNamed: 'MorphicExtras'.
	self script9.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'stephaneducasse 11/4/2005 18:19'!
updateFrom6696
	"self new updateFrom6696"
	
	self addRepositoryToPackageNamed: 'FlexibleVocabularies'.
	self addRepositoryToPackageNamed: 'EToys'.
	self addRepositoryToPackageNamed: 'BalloonMMFlash'.
	self addRepositoryToPackageNamed: 'MorphicExtras'.
	self script13.
	self addRepositoryToPackageNamed: 'PlusTools'.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'stephaneducasse 11/5/2005 19:34'!
updateFrom6703
	"self new updateFrom6703"
	
	self addRepositoryToPackageNamed: 'FlexibleVocabularies'.
	self addRepositoryToPackageNamed: 'EToys'.
	self addRepositoryToPackageNamed: 'BalloonMMFlash'.
	self addRepositoryToPackageNamed: 'MorphicExtras'.
	self script14.
	self addRepositoryToPackageNamed: 'PlusTools'.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 11/20/2005 21:43'!
updateFrom6704
	"self new updateFrom6704"
	
	self addRepositoryToPackageNamed: 'FlexibleVocabularies'.
	self addRepositoryToPackageNamed: 'EToys'.
	self addRepositoryToPackageNamed: 'BalloonMMFlash'.
	self addRepositoryToPackageNamed: 'MorphicExtras'.
	"to report what has been changed use also script14 "
	self script15.
	self addRepositoryToPackageNamed: 'PlusTools'.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'al 12/8/2005 21:21'!
updateFrom6705
	"self new updateFrom6705"
	
	self addRepositoryToPackageNamed: 'Traits'.
	self script16.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 12/20/2005 15:13'!
updateFrom6706
	"self new updateFrom6706"
	
	self addRepositoryToPackageNamed: 'Traits'.
	self script18.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 1/12/2006 19:34'!
updateFrom6707
	"self new updateFrom6707"
	
	self script19.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'stephaneducasse 1/14/2006 12:47'!
updateFrom6708
	"self new updateFrom6708"
	"traits fix"
	"VMMaker fixes"
	
	self resetToolSet.
	self script21.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'stephaneducasse 1/14/2006 21:10'!
updateFrom6709
	"self new updateFrom6709"
	"PreferenceBrowser + Preference + Debugger fix + Services 
	+ SUnitGUI"
	
	self addRepositoryToPackageNamed: 'Services-Base'.
	self addRepositoryToPackageNamed: 'SUnitGUI'.
	self resetToolSet.
	self script23.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'stephaneducasse 1/15/2006 18:10'!
updateFrom6710
	"self new updateFrom6710"
	"Method annotations:
		Pay attention
	two important cs should be loaded after the cs that will trigger this update.
	one to recompile the image and to load the manually ordered CS."
	
	self addRepositoryToPackageNamed: 'Services-Base'.
	self addRepositoryToPackageNamed: 'SUnitGUI'.
	self resetToolSet.
	self script24.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 1/15/2006 19:18'!
updateFrom6714
	"self new updateFrom6714"
	"Some packages have been made dirty by the cs put directly in the stream: 6713"
	
	self script25.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 1/18/2006 19:42'!
updateFrom6715
	"Bugfixes:
	move scopeHas:ifTrue: to *39Deprecated, fix the senders
	JMMRemoveExtraIndexCheck: faster second...8th 
	fix open File directly
	WindowColorRegistry (Hernán Tylim)
	Fix to open real Workspace
	"
	self script26.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 1/19/2006 18:27'!
updateFrom6716
	"Bugfixes"
	
	"Change Set:		isSourceFileSuffix-M1407
	Date:			15 September 2005
	Author:			tim@rowledge.org
	A trivial change to FileStream class>isSourceFileSuffix: to remove the spurious seeming   
	inclusion of '*' as a legitimate source file suffix.  Seems to break nothing.
	----
	Change Set:		selectorsWithArgs-md
	Date:			2 January 2006
	Author:			Marcus Denker
	Make Behavior>>#selectorsWithArgs: use symbol>>#numArgs.
	Much simpler: one line. And it fixes a bug.
	----
	Change Set:		removeUndefTest
	Date:			14 January 2006
	Author:			Marcus Denker
	removes UndefinedObject>>#test, which was a test method for alternate syntax
	-----
	0002373: ParagraphEditor >> #makeCapitalized: comment is not correct
	-----
	Change Set:		SysWindowClean01-wiz
	Date:			18 January 2006
	Author:			(wiz) Jerome Peace
	wiz 1/18/2006 15:34
	Ok. I think that does it.
	Removed unused preference and SystemWindow methods that use it Mantis # 2532.
	------
	Change Set:		decompileBlock-md
	Date:			24 November 2005
	Author:			Marcus Denker
	A  simplification for BlockContext>>decompileBlock:
	The Method got the tempNames by compiling the source of the method. This
	is already implemented in methodNode tempNames... thus not needed here.
	------
	remove emptycheck for Heap>>fist and SequencableCollection
	#first, #last, #middle
	------
	0002514: [FIX] condenseSources (was: Re: [Q] Removing changes file content.
	------
	Delay startTimerInterruptWatcher
	to fix
	0002379: BlockContext>>decompile broken, ProcessBrowser does not work
	------
	0002377: Cannot rename a project from its window menu
	0002497: MNU when changing title on Morphic Project
	0002415: Error after one presses ESC key two times.
	0002145: KlattFrame: ZeroDivide exception when the value of ro, rk or ra is 0
	-----
	Change Set:		FileListCodeDNUfix-efc
	Author:			Eddie Cottongim
	Apparently Object got (errantly?) registered with FileList as a file reader. This was throwing 	some DNUs. This simple doit unregisters Object and appears to solve the problem.
	-----
	Change Set:		RemoveAlternateSynPref
	-----
	Change Set:		PlusToolsAlternateSyntaxFix
	Date:			14 January 2006
	Author:			Marcus Denker
	The horrible alternateSyntax hack has been removed in 3.9. This fixes
	three methods in the plustools to not use definitionST80: but definitionST80
	------
	"
	self script27.
	self flushCaches.
	Delay startTimerInterruptWatcher.
	FileList unregisterFileReader: Object.
	Preferences removePreference: #printAlternateSyntax.

	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 1/21/2006 10:57'!
updateFrom6717
	"self new updateFrom6717"
	"Some Changes form the ClosureCompiler
	 ----
	Name: SUnitGUI-lr.4
	- changed the label from 'Essential Test Runner' to 'Test Runner', since there is no other 	anymore this makes no sense to distinguish
	- renamed the button 'Run All' to 'Run Selected' to avoid confusion
	-----
	Change Set:		fileinUndeclared-bf
	Date:			12 January 2006
	Author:			Bert Freudenberg
	When filing in, do not ask whether it's okay to moveclass var to Undeclared. Just move it.
	-----
	Change Set:		DebuggerMVCSchedulingFix-dtl
	Date:			12 December 2005
	Author:			David T. Lewis
	Mantis bug 0002359: Debugger in MVC opens in next available Morphic world
	-----
	Name: CollectionsTests-zz.11
	Author: zz
	Add more tests to several Collection classes : Array, Association, Dictionary, Heap, Interval, 	LinkedList, OrderedCollection, SequenceableCollection, SortedCollection
	All tests are green ;-)
	-----
	added haltOnce (with halt on count, inspect at count, and inspect until count)
	-----
	removed emptyCheck from OrderedCollection removeLast, removeFirst
	"
	
	self script28.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'stephaneducasse 1/23/2006 15:23'!
updateFrom6718
	"self new updateFrom6718"
	"
	call 'TheWorldMenu removeObsolete' to cleanout obsolete ref.
	-----
	0002542: Morphic testing failure, Morph>>overlapsShadowFormbounds
	-----
	revert Decompiler>>#decompileBlock:
	-----
	ServiceAction>>perform:orSendTo: for romain
	----- Adding andreas packages
	"
	
	self script30.
	self flushCaches.
	TheWorldMenu removeObsolete.
	
	Undeclared removeUnreferencedKeys.
	Smalltalk garbageCollect.
	ScheduledControllers := nil.
	Smalltalk garbageCollect.
	
	SMSqueakMap default purge.
	Smalltalk forgetDoIts.

	DataStream initialize.
	Behavior flushObsoleteSubclasses.
	MethodChangeRecord allInstancesDo: [:each | each noteNewMethod: nil].
	
	SmalltalkImage current fixObsoleteReferences.

	Smalltalk flushClassNameCache.
	3 timesRepeat: [
		Smalltalk garbageCollect.
		Symbol compactSymbolTable.
	].
! !

!ScriptLoader methodsFor: 'updates' stamp: 'stephaneducasse 2/2/2006 19:47'!
updateFrom6719
	"self new updateFrom6719"
	"
	0002135: Cmd-. don't work with various Mac Os X keyboard layout
	"
	
	self script31.
	self flushCaches.
	TheWorldMenu removeObsolete.
	
	Undeclared removeUnreferencedKeys.
	Smalltalk garbageCollect.
	ScheduledControllers := nil.
	Smalltalk garbageCollect.
	
	SMSqueakMap default purge.
	Smalltalk forgetDoIts.

	DataStream initialize.
	Behavior flushObsoleteSubclasses.
	MethodChangeRecord allInstancesDo: [:each | each noteNewMethod: nil].
	
	SmalltalkImage current fixObsoleteReferences.

	Smalltalk flushClassNameCache.
	3 timesRepeat: [
		Smalltalk garbageCollect.
		Symbol compactSymbolTable.
	].
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/12/2006 20:25'!
updateFrom6720
	"self new updateFrom6720"
	"
	- Tools for traits fixes from adrian
	- underscore fixing
	- integer printing fixes + tests
	- 0002708: SharedQueue does not nil out unused slots when flushing
	- 0002154: Light-weight mutex implementation
	- tests from 0002688: aNumber = (aNumber + 0 i) answer false
	- Adds a test for the new Url class>>absoluteFromFileNameOrUrlString: 
	- Set new now uses new: 5
	- delete Undefined>>languagePrefs, broken code
	- tests for primesUpTo: and isPrime
	- turn on Deprecation warnings
	- Move Heap examples to HeapTest (and call them in a test)
	- remove double entry for TestRunner from open Menu
	- clean a bit old unneded tests
	- remove empty class and method categories
	- fix a call to deprecated #bringFlapTabsToFront
	- Change Set:		fixPntrFinder-bf
	  Author:			Bert Freudenberg
	  The PointerFinder (aka 'chase pointers' menu item) did not find references in   
	  CompiledMethods, which are the only objects in the system that answer false to isPointers  
	  but still *do* have pointers"
	
	self script32.
	self flushCaches.
	
	Preferences setPreference: #showDeprecationWarnings toValue: true.
	TheWorldMenu unregisterOpenCommand: 'SUnit Test Runner'.
	Smalltalk removeEmptyMessageCategories.
	SystemOrganization removeEmptyCategories.
	
	Undeclared removeUnreferencedKeys.
	Smalltalk garbageCollect.
	ScheduledControllers := nil.
	Smalltalk garbageCollect.
	
	SMSqueakMap default purge.
	Smalltalk forgetDoIts.

	DataStream initialize.
	Behavior flushObsoleteSubclasses.
	MethodChangeRecord allInstancesDo: [:each | each noteNewMethod: nil].
	
	SmalltalkImage current fixObsoleteReferences.

	Smalltalk flushClassNameCache.
	3 timesRepeat: [
		Smalltalk garbageCollect.
		Symbol compactSymbolTable.
	].
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/14/2006 20:58'!
updateFrom6721
	"self new updateFrom6721"
	"
	- remove Deprecated Methods from 3.8
	- moved all new deprecated method to *39Deprecated
	- remove MethodNode>>#generateNative
	- add generate (to call generate: #(0 0 0 0), fix senders to use it
	- add CompiledMethod>>#equivalentTo:
	- fix for 0002513: arcTan: returns angle in strange intervale
	- fix for 0002118: Integer class >> #primesUpTo: 
	- fix for 0001109: ScrollPane code/comment mismatch
	- start of a ReleaseTest (testing for Undeclareds etc...)
	- Change Set:		versionCats-bf
	  Author:			Bert Freudenberg
       Show method categories in version listing. Particularily useful when checking 
       overrides, where the only thing changed is the categorization.
	- BorderedMoph.st from Connectors
	- fixes from 0001734: [ENH] remove deprecated Chronology methods in 3.9 [cd][su][sm]
	- Change Set:		systemSupportFixes-bf
	  Author:			Bert Freudenberg
	  Fixes to SmalltalkImage
	  - rename readDocumentFile to recordStartupStamp, which is what it does nowadays
	  - changesName is full path now, like imageName
	  - derive full name for new image or changes from image path primitive, rather 
	    than default directory (in all regular cases they are identical)
	- 0002570: [Fix] When Color pret†y printing it is hard to read the light tan literals against 
	 the white background.
	- Change Set:		AnnotationMorphFix-wiz
	 Author:			(wiz) Jerome Peace
	 Made some style changes to the annotation preference widget.  Two things. put the 
	 extra button in a better place. Made a more harmonious aspect ratio for the panels.

	
	"
	Smalltalk removeEmptyMessageCategories.
	ColoredCodeStream initialize.
	
	self script33.
	self flushCaches.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/15/2006 17:36'!
updateFrom6723
	"self new updateFrom6723"
	"
	- 0002498: In Sq6713 Strange behaviours when asking for class ref.
	- Latest Properties/Pragmas from Lukas
	
	
	"
	Smalltalk removeEmptyMessageCategories.
	
	self script34.
	self flushCaches.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/16/2006 14:32'!
updateFrom6724
	"self new updateFrom6724"
	"
	- 0002345: Cannot open Workspace from world menu in MVC
	- fixes to MC tests by Adrian
	- CompiledMethod>>decompileTree deprecated
	- String>>numArgs: for building selectors easily
	- cleaned up unused old propertu code in parser
	- first cut at a fast #who (see Changelog Kernel-md.92)
	- cleanups in CompiledMethod (see Changelog Kernel-md.92)
	- some first refactorings to not call #who
	
	
	"
	Smalltalk removeEmptyMessageCategories.
	
	self script34.
	self flushCaches.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/16/2006 19:33'!
updateFrom6726
	"self new updateFrom6726"
	"
	-Put back in the simplified Decompiler>>#decompileBlock:
	- deprecated #who
	- CompiledMethod>>#methodNode now sets Class and Selector for non-installed 
	  methods to Object/ CompiledMethod>>#defaultSelector
     - refactored ContextPart to not call #who
	- refactored ProcessBrowserPlus to not use #who
	- refactored ProcessBrowser to not use #who
	- simplified CompiledMethod>>#defaultSelector
	- String>>#hash now uses identityHasch as initial hash (needed for Behavior>>#hash)
	- moved numArgs: to Symbol, faster
	- add Behavior hash
	- simplify CompiledMethod: #defaultSelector, #equivalentTo:, #methodNode
	- add CompiledMethod>>#selector:
	- add iVarselector to MethodProperties, accessors
	- make MethodProperties compact again.
	"
	
	"I added a Variable... "
	MethodProperties becomeCompact.

	self script35.
	self flushCaches.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/18/2006 14:05'!
updateFrom6727
	"self new updateFrom6727"
	"
	- deprecate behavior>>#selectorAtMethod:setClass: 
	- deprecate ContextPart>>#mclass (use methodClass, like in CompiledMethod)
	- deprecate ContextPart>>#methodSelector (use #selector, like in CompiledMethod)
	- deprecate MethodContext>>#answer: (comment indicates 'will soon be removed'
	- refactor to not call deprecated methods.
	- Fast #who part 2: Selector from compiledMethod.
	- Forward from ContextPart to method (selector, decompile.)
       no need to search anymore 
     - installed methods now get selector/class set.
	"
	"recompile"
	self script36.
	self flushCaches.
	Compiler recompileAll.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/19/2006 08:07'!
updateFrom6728
	"self new updateFrom6728"
	
	"
	- fixed override of Services to not revert Traits browser change
	- 0002868: Copying the text of a list morph via the halo menu does return empty
	- 
	
	Change Set:		TestRunnerEnh
	Date:			18 February 2006
	Author:			Alexandre Bergel

	With this fix, the TestRunner now update its list of classes and categories accordingly to 	system changes. It uses the SystemChangeNotifier.
	
	Name: CollectionsTests-fbs.16
	Author: fbs
	Time: 14 February 2006, 5:44:42 pm
	UUID: bfeee468-b072-1048-9409-ed02f938ff47
	Ancestors: CollectionsTests-md.14

	This version converts == <integer literal> to = <integer literal> in response to Dan Ingalls' 	note: http://lists.squeakfoundation.org/pipermail/squeak-dev/2006-February/100600.html


	Traits: Change log:
	- fixed marker methods that were broken because of new default literals in CompiledMethod
	- removed obsolete requries algorithm tests
	- prefixed all requires performance tests to exclude them from normal test runs
	- fixed issue [0002814] (targetTraits is shadowed in RequiredSelectorsChangesCalculator)
	- requires algorithm bugfix (requirements are not dynamically updated for classes) by 	Daniel
	- all traits and requires tests should run green again except for 	TraitCompositionTest>>testProvidedMethodBindingsWithConflicts

	Fast #who changes / cleanups
	- deprecate CompiledMethod>>#decompileClass:selector:
	- delete Compiler>>#cacheDoItNode
	- remove ivar cacheDoItNode
     - remove CompiledMethod>>#blockNode, blockNodeIn,   
	- remove Message>>catcher
	- remove MethodContext>>methodNode (use inherited version from MethodContext)


	Name: SmaCC-fbs.8
	Author: fbs
	Time: 14 February 2006, 6:00:22 pm
	UUID: baaa0a47-646f-8345-bede-968f4cdaaff2
	Ancestors: SmaCC-stephaneducasse.6

	This version converts == <integer literal> to = <integer literal> in response to Dan Ingalls' 	note: http://lists.squeakfoundation.org/pipermail/squeak-dev/2006-February/100600.html
"
	self script37.
	self flushCaches.
	
	RequiredSelectors initialize.
	LocalSends initialize.
	ProvidedSelectors initialize.
	Compiler recompileAll.
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/22/2006 10:37'!
updateFrom6729
	"self new updateFrom6729"
	
	"
	New OB
	- Mantis-0504-CurvierMorph, fix by Jerome Peace (wiz)
	- Resizing SystemWindows on any corner, fix by Juan Vuletich (jmv) and Robin (rl)
	- Removal CDScreenShotMorph, indicated by Jerome Peace (wiz)
	Reviewed by Juan Vuletich (jmv)
	-md: second try with fixed packaged...

	"
	self script38.
	self flushCaches.
	
	
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/21/2006 10:07'!
updateFrom7000
	"self new updateFrom7000"
	
	"
	- load older version of eToy to fix bug.
	- 0002922: Debugger shows only pretty printed code
	- decompileString for BlockNode and BlockClosure
	- Class class>>#rootsOfTheWorld (from RB/VW)
	- More changes from NewCompiler package
	- refactorings and cleanups related to decompiling in the Tools
	"
	self script39.
	self flushCaches.
	
	
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/22/2006 22:50'!
updateFrom7001
	"self new updateFrom7001"
	
	"
	- updated SUnit packge (refactorings and a small bugfix)
	- SequenceableCollection.st from Connectors
	- BlockContext.st from Connectors
	- MessageSend.st from Connectors
	- TwoWayScrollPane.st from Connectors
	- Object.st from Connectors
	- CircleMorph.st from Connectors
	- TextMorph.st from Connectors
	- TileMorph.st from Connectors
	- SketchMorph.st from Connectors
	- StringMorphEditor.st from Connectors
	- EllipseMorph.st from Connectors
	- TTSampleStringMorph.st from Connectors
	- TTSampleFontMorph.st from Connectors
	- HandMorph.st from Connectors
	- SketchMorph.mir.1.cs from SqueakLand
	- TextMorph.mir.1.cs from SqueakLand
	Change Set:		PersMenuFix-wiz
	Author:			(wiz) Jerome Peace
	The Yellow button personal menu item  'about this system' throws up a DNU.
	The message is being sent to SmallTalk (the dictionary) instead of SmallTalkImage current.
	As I was here anyway I also took the time to remove the only reference to the isFlagship 	
	preference and the hardcoded preference method itself as per discussions with sw in mantis 	#2690.
	Change Set:		watcherTypeChange-sw
	Date:			24 March 2005
	Author:			Scott Wallace

	If the user changes the type of a Variable, watchers looking at that variable are now fixed 	up.   
	Any existing Watcher for the variable gets replaced by a labeled watcher appropriate 	for the new type.
	This is a fix for Squeakland Mantis bug #1001.
	- remove Preferences:  #selectionsMayShrink #warningForMacOSFileNameLength #celesteHasStatusPane.
	#celesteShowsAttachmentsFlag #autoAccessors #classicNewMorphMenu #morphicProgressStyle
	 #showLinesInHierarchyViews #testRunnerShowAbstractClasses
	- fix BlockContext>>#decompile to not reference Decompiler
	- add CompiledMethod#decompileWithTemps (logic was in 	Tools... sigh!!)
	- ContextPart>>sourceCode simplified.
	"
	self script40.
	self flushCaches.
	Preferences removePreference: #selectionsMayShrink.
	Preferences removePreference: #warningForMacOSFileNameLength.
	Preferences removePreference: #celesteHasStatusPane.
	Preferences removePreference: #celesteShowsAttachmentsFlag.
	Preferences removePreference: #autoAccessors.
	Preferences removePreference: #classicNewMorphMenu.
	Preferences removePreference: #morphicProgressStyle.
	Preferences removePreference: #showLinesInHierarchyViews.
	Preferences removePreference: #testRunnerShowAbstractClasses.
	
	
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/24/2006 23:31'!
updateFrom7002
	"self new updateFrom7002"
	"
	Change Set:		decorateFix-bf
	Date:			24 February 2006
	Author:			Bert Freudenberg

	Bullet-proof browser against removed class
	---------
	0001913: Make all implementors of #nextPut: to return the argument (instead of self)
	Changed some implementors of #nextPut: to return the argument (and not return self). 
	This to be consistent with primitiveNextPut and all other implementors of #nextPut:
	kwl: As dicusses with Ken and Craig on #squeak IRC.
	--------
	0001733: [ENH][FIX] String-upToDep-huma
	Really deprecates SequenceableCollection>>#upTo: to #copyUpTo:
	--------
	PlusTools do not register in Filelist when not active
	-------
	0003049: fast window resizing needed
	0001596: [BUG][FIX] lurking signals in EventSensor
	-------
	- PolygonMorph.st from Connectors
	- cleanups for preference removal
	
	"
	self script41.
	self flushCaches.
	Preferences removePreference: #allowCelesteTell.
	Preferences removePreference: #useFileList2.
	Preferences removePreference: #enableInternetConfig.
	Preferences removePreference: #browserNagIfNoClassComment.
	Preferences removePreference: #alternativeWindowLook.
	Preferences removePreference: #alternativeScrollbarLook.
	Preferences removePreference: #inboardScrollbars.
	Preferences removePreference: #fastSplitterResize.
	FileList initialize.
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 2/28/2006 12:16'!
updateFrom7003
	"self new updateFrom7003"
	"
	fasterMorpic: optimized extension/properties code for number of sends
	-------
	Change Set:		AutoDeselectToolFixes-wiz
	Author:			(wiz) Jerome Peace
	For doubleClick to work in lists autoDeselect must be explicitly disabled. There are four places 	where This needs to be done on the tool end of thing.	
	-------
	0003108: [quickFix] In 7002 selecting connector catagory or alpha p catagory gets a
	 debug box.
	-------
	0002500: In6713 Sometimes a Legitimate request generates DNU PseudoClass>>isTraits
	0002991: [Fix] Workspaces initial extent is too large for most uses.
	0002151: Max number of literals checked in MethodNode instead of CompiledMethod
	0003128: [Fix] In 7002 Using browser buttons to ask for prettyprinting gets DNU 	Compiler>>asText
	0001048: [ENH] SystemNavigation>>allImplementorsOf:localTo:
	0002779: 3.9a-6721 theme... button on Services Browser gives 'key not found' walkback
	
	------
	
	"
	self script42.
	self flushCaches.
	
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/3/2006 16:58'!
updateFrom7004
	"self new updateFrom7004"
	"
	0001613: [ENH] truncatedChanges-ls
	Date: 4 September 2003
	Author: Lex Spoon

	Handle truncated changes files more gracefully. The problem actually
	can happen, and has been observed at Georgia Tech, e.g. if someone
	downloads a file but does not complete the download. The current
	behavior is that pink debuggers pop up; this is extremely confusing for
	new users when it happens in places like the Browser.

	The solution in this changeset is to fall back on the decompiler. A
	more thorough solution should probably trigger a systematic invalidation
	of all source pointers past the end of the changes file, because as time
	goes on the changes file will eventually grow large enough to cover the
	lost code and the routine will start returning random method code for
	the invalid source pointers.
	----------------
	0001354: MIDI port name is garbled in selection dialog
	Change Set:		AddTransMIDIPort
	Date:			31 May 2005
	Author:			Tooru Nosse
	
	fix for query of MIDI portName with SJIS name
	enable translation for midi port selection
	----------------
	0002341: MorphicEventDispatcher minor refactoring
	0001284: Smalltalk condenseSources leads to UndefinedObject(Object)>>error:
	0003180: Selector requester does not strip blanks
	tests from 0001798: #critical:ifError: on Semaphore does not always signal the semaphore
	test from 0003133: [BUG][FIX] Float>>#asIEEE32BitWord and #fromIEEE32Bit:
	----------------
	Change Set: dupAllCtrlAltKeysPref-dew
	Date: 13 December 2004
	Author: Doug Way

	Adds a new preference duplicateAllCtrlAndAltkeys to duplicate all Ctrl and Alt modifier key 	
	commands, which causes all Ctrl key commands to behave the same as Alt-key commands. 	
	The original Ctrl (a.k.a. 'shift') key commands are still available via Ctrl-Shift and Alt-Shift.

	This differs from the existing ctrlAlt prefs which only duplicate/swap the eight editing keys. 	
	Also includes code to prevent these other two conflicting prefs from being activated at the 
	same time.

	The three related prefs (swapCtrlAndAltKeys, duplicateCtrlAndAltKeys, 	
	duplicateAllCtrlAndAltKeys) should really be made into a radio button preferences set 
	sometime in the future (like the Halo look preferences), since only one can be turned on at 
	a time. This would eliminate the need for the #changed methods.

	See 'modifier' discussion on squeak-dev from 12/3/2004 for more details on why this was 	provided.
	-----------
	- postCopy for MethodProperties
	- Preferences panel size
	- remove Preference #ansiAssignmentOperatorWhenPrettyPrinting
	- remove Preference #resizeOnAllSides, #twoSidedPoohTextures
	- set selector when evaluating a #Doit. Fixes MessageTally tallySends:
	- cleanups in Parser: remove old Properties code
	- cleanups in Encoder: use #binding, not #associationFor:. 
	- remove the last new initialize cases
	- Fix ClassTestCase to not turn off Deprecation
	- Fix Tests for ObjectsAsMethods
	- Refactor/deprecate old environment methods in SystemDictionary
	Graphics:
	-----------
	- 0002449: [Enh] Adds a target-sighting cursor to the menagerie of cursors.
	- 0002450: [Fix] Form fromUser can create a form w/ zero area if user specifies
	   a corner to upper left of origin.
	- bullet-proof ImageReadWriter class>>understandsImageFormat:
	- 0002684: [Fix] In 6719 rotateBy: #right or #left returns wrong aspect ratio.
	- 0003060: Graphics-md.27: additions from Connectors / merge with image
	--------
	Traits:
	- Fix PackageInfo: extension methods defined in traits were missing in package
	- Move traits related changes of methods from Monticello into correct package PackageInfo 
	"
	self script43.
	self flushCaches.
	Preferences removePreference: #ansiAssignmentOperatorWhenPrettyPrinting.
	Preferences removePreference: #resizeOnAllSides.
	Preferences removePreference: #twoSidedPoohTextures.
	Smalltalk removeEmptyMessageCategories.	
	SystemOrganization removeEmptyCategories.
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/5/2006 21:10'!
updateFrom7005
	"self new updateFrom7005"
	"
	- fixed #binding
	- 0003249: Mac VM pops up debugger on every launch (InternetConfiguration broken?)
	- 0003246: In 7005 Getting objects from Object morph not behaving as expected.
	- 0003245: 7005: ProcessBrowser DNU
	"
	self script44.
	self flushCaches.
	Compiler recompileAll.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/9/2006 17:10'!
updateFrom7006
	"self new updateFrom7006"
	"
	- pretty print use := by default
	0003249: Mac VM pops up debugger on every launch (InternetConfiguration broken?)
	0003254: faster #binding
	0003258: [ENH] Entry in Fonts menu for easily getting all big fonts
	0003150: In 7002 Asking for priorVersions causes browsing some primitive methods 
			to get a DNU
	0003268: NumberTest>>testPrintShowingDecimalPlaces: broken
	"
	self script45.
	self flushCaches.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/14/2006 19:07'!
updateFrom7007
	"self new updateFrom7007"
	"
	Mantis-3061-SnapPop, fix by Jerome Peace (wiz)
	Mantis-3075-MixedCurves, fix by Jerome Peace (wiz)
	Mantis-2589-ButtonTargets, fix by Jerome Peace (wiz)
	Mantis-2709-CurveBoundsTRFix, fix by Jerome Peace (wiz)
	Mantis-2496-Halos-Menus, fix by Jerome Peace (wiz)
	0003294: KeyedSet>>add: cand send #errorKeyAlreadyExists: which is not implemented
	0003301: FileList has two install buttons
	0003303: Browser --> open does allways open Browser (not SystemBrowser default)
	"
	self script46.
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/14/2006 23:29'!
updateFrom7008
	"self new updateFrom7008"
	"
	Change Set:		kedama2.7-yo
	Date:			9 May 2005
	Author:			Yoshiki Ohshima	
	-------------------------------------------
	Change Set:		flexFix-sw
	Date:			30 March 2005
	Author:			Scott Wallace

	Fix for Mantis bug 993: 'rotating morph changes z-order.'  This is a bug that dates to the 	original implementaiton of 'flexing' (generic Morph rotation) in early 1998.  After this fix, 	when a flex shell is added, we now remember the z-position of the original morph and 	ascribe that same z-position to the TransformationMorph that replaces it.

	This update also fixes the dual of that bug, which is that when a TransformationMorph 	decides it's no longer needed, and gets itself replaced by the morph it formerly had been 	governing, the unrotated morph had not been getting inserted in the z-ordering in the same 	place.	
	---------------------------------------------
	Change Set:		noScritch-sw
	Date:			6 April 2005
	Author:			Scott Wallace

	The Scritch sound is supressed
	----------------------------------------------
	Change Set:		dupFixes-sw
	Date:			19 April 2005
	Author:			Scott Wallace

	When the user chooses 'duplicate' from the halo-actions submenu of the halo menu of a 	rotated object, the result had formerly been an unrotated object that was not known to the 	allExtantPlayers list of the project's presenter, so would not come up ticking, etc.  This 	update fixes those glitches.
	Also:  When you dismiss a morph via its halo, its player gets removed from the project's 	allExtantPlayers list -- an optimization.
	-----------------------------
	Change Set:		selectionSibFix-sw
	Date:			19 April 2005
	Author:			Scott Wallace

	Fix for Mantis bug  981: Making a sibling of SelectionMorph causes error.
	Version 4 of this fileout also fixes bugs involving use of the 'duplicate' feature from the 	'halo actions' submenu of a SelectionMorph -- such duplicates were flawed in a couple of 	way.
	-------------------------------
	Change Set:		tickingPainting-sw
	Date:			30 April 2005
	Author:			Scott Wallace

	Two responses to the concern about ticking-while-painting:

	(1)  Adds the #keepTickingWhilePainting preference; when true, scripts will continue to tick 	while the user is in a painting session.
	(2)  If this new preference is *false*, scripts that had been ticking when painting was 	initiated now resume ticking once painting is done.
	------------
	Change Set:		acceptPlayerTile-sw
	Date:			1 May 2005
	Author:			Scott Wallace

	Implements a short-cut feature requested by Alan (or rather 'remembered' by him ;-) as 	follows:  a player-valued tile can now be dropped onto a graphic-valued pad, whereup it 	expands into appropriate retrieval tiles for obtaining a graphic from the player.
	---------------
	Change Set:		unCustoming-sw
	Date:			17 June 2005
	Author:			Scott Wallace

	When the allowEtoyUserCustomEvents preference is false, refrain from showing the 	triggeringObject item in the Viewer and from offering the CustomEvents type in type-list 	popups.
	Also now makes the allowEtoyUserCustomEvents preference behave like a normal preference, 	i.e. independently of eToyFriendly, but sets it appropriately whenever eToyFriendly is 	changed -- after which it *can* subsequently be changed manually if desired, thus making 	it possible to set things up to operate with eToyFriendly on yet offering those CustomEvents.
	------------------------
	Change Set:		vectorAccess-sw
	Date:			9 July 2005
	Author:			Scott Wallace

	Gives easier access to the command for turning on the vector vocabulary.  Makes it possible 	to set an image up such that the vector vocbulary is always in use by default.  The 	primary access to this control is now via the World's Viewer, which now gets a 	'preferences' category, into which is also put a #dropProducesWatcher control.
	"
	self script47.
	self flushCaches.
	MCDefinition clearInstances.
	
	Preferences addPreference: #useVectorVocabulary categories: #(scripting) default: false  balloonHelp:  'When true, the vector vocabulary, allowing players to be used as vectors, is used.' projectLocal: true changeInformee: Preferences  changeSelector: #vectorVocabularySettingChanged.
Vocabulary initialize.
Preferences addPreference: #keepTickingWhilePainting category: #scripting default: false balloonHelp: 'If true, ticking scripts will keep running while in a painting session.'.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/17/2006 17:49'!
updateFrom7010
	"self new updateFrom7010"
	"
	Change Set:		watcherTypeChgFix-sw
	Date:			25 July 2005
	Author:			Scott Wallace

	Makes the new watchers launched to replace existing ones upon a type-change to a variable 	conform to the new protocol for creating watchers; also fixes the bug that simple watchers 	were being replaced by fancy ones after a type change.
	---------------------------
	Change Set:		StringEqual2
	Date:			15 December 2005
	Author:			Yoshiki Ohshima

	'abc' = 'abc' asWideString wasn't returning true after the String refactoring.  Supposedly, 	primitiveCompareString should fail when the argument or receiver isn't a byte object, but 	currently the primitive just traverses the internal of the word object.  The right fix would 	be to fix the primitive, but so far the Squeak side code should cope with it.
	------------------------------
	Change Set:		tileFix-sw
	Date:			18 July 2005
	Author:			Scott Wallace
	The tear-off-a-tile halo handle could sometimes tear off a bogus tile, if a non-Sketch object 	was rotated before a player was allocated to it.  This update fixes that.  Thanks to Dave 	Briccetti for pointing out this bug.
	--------
	Change Set:		FixMorphDelete
	Date:			28 July 2005
	Author:			Andreas Raab

	Always #dismissViaHalo even if #preserveTrash is true.
	--------
	Change Set:		ProjectViewDismiss
	Date:			1 August 2005
	Author:			Yoshiki Ohshima

	Match the wording when a ProjectViewMorph is dismissed via halo.
	-------
	Change Set:		turnTowardFix-sw
	Date:			29 July 2005
	Author:			Scott Wallace

	As per suggestion from Randy Heiland, Squeakland mailing list 7/29/05, makes 'turn toward' 	always carry out the turn (unless the positions of the two objects coincide), whether or not 	the objects overlap.
	--------
	0461MophDissmissal.cs
	--------
	Change Set:		LocaleRefactoring
	Date:			8 August 2005
	Author:			Takashi Yamamiya
	-------
	Change Set:		localeEnabler
	Date:			31 August 2005
	Author:			Michael Rueger

	Enables the use of the language setting through the locale plugin. If no plugin is found, 	the current locale is used.
	The preference useLocale turns the automatic settings on or off.
	-----------
	Change Set:		smWorkaround-sw
	Date:			16 March 2006
	Author:			Scott Wallace, Michael Rueger

	Adapted for 3.9.
	A change to allow SqueakMap to load packages successfully into images whose version 	numbers are less than 5302, which is the Squeak.org update level at which the convention 	about where the system changes were stored changed.  Goran's version of this code (7/13/04) 	assumed that any version number less than 5302 indicated an ancient Squeak, whereas in 	practice nowadays it is much more likely to indicate a recent Squeak that has a different 	formal version name, such as 'Tweak1.2' or Squeakland3.8', and which has its own 	sequence of update numbers.  This workaround was prompted a need to load Monticello into 	the Squeakland image.
	"
	self script48.
	self flushCaches.
	MCDefinition clearInstances.
	
	Preferences enable: #dropProducesWatcher.
	Preferences addPreference: #showAdvancedNavigatorButtons category: #morphic default: true balloonHelp: 'If true, an advanced version of the navigator is shown, otherwise a simplified version.'.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/18/2006 18:27'!
updateFrom7011
	"self new updateFrom7011"
	"
	Refactoring of Class|Trait>>category lookup. Improves category lookup by a factor of 10 and 	for example loading of a Monticello package by a factor of 2.
	"
	self script49.
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/19/2006 14:01'!
updateFrom7012
	"self new updateFrom7012"
	"
	Change Set:		nihongo7ModalWindows
	Date:			22 July 2005
	Author:			Takashi Yamamiya and Kazuhiro Abe

	Make some UI elements modal so that the user don't see multiple project saving dialog, etc.
	-------------
	Change Set:		nihongo7BitBlt
	Date:			22 July 2005
	Author:			Yoshiki Ohshima

	Prevents simple crash with errorneous numbers in geometory.
	-----------
	Change Set:		nihongo7WatchersAndReadouts
	Date:			22 July 2005
	Author:			Takashi Yamamiya and Yoshiki Ohshima

	The proposed improvement for watchers and readouts. The areas are:

	* Simple watcher bahves better with Alt-Click.
	* Allows type-in of non-ascii number strings.
	* Should handle ok with translated symbols in symbol tiles.
	----------------
	Change Set:		nihongo7SimpleButtons
	Date:			22 July 2005
	Author:			Takashi Yamamiya

	Hide more buttons in the nav-bar.  Controlled by a preference called 	showAdvancedNavigatorButtons.
	----------------
	Change Set:		ExtNamesStay-tk
	Date:			27 July 2005
	Author:			Ted Kaehler

	When an object is being brought in from a saved project, if its name is already in use, 
	make a new unique internal name (as before).  Set the external name in the costume to its 
	old name.  Internal name is the key for it in References.
	----------------
	Change Set:		SketchFix
	Date:			28 July 2005
	Author:			Andreas Raab

	Restore two missing methods from SketchMorph.
	---------------
	Change Set:		undo-kedama
	Date:			17 March 2006
	Author:			Michael Rueger

	Undoes two squeakland changes that broke etoys
	-----------
	Change Set:		polygonFix-tak	
	Date:			10 February 2006
	Author:			Takashi Yamamiya

	Fixes a bug in generic handling of cached morph state, which manifested itself in a variety
	 of ways involving PolygonMorphs, such as the fact that a drop of a Star always required \
	a second click. 

	Reverts Morph>>releaseCachedState so that it no longer resets formerOwner, formerPosition, 
	and undoGrabCommand, thus making #releaseCachedState once again safe to call while 
	drag is  underway, The resetting of formerOwner, etc. is moved to #prepareToBeSaved
	----------
	0003295: In 7006 MorphicMenuItem>>keystroke: code versions reveal a conflict.
	"
	self script50.
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/20/2006 19:56'!
updateFrom7013
	"self new updateFrom7013"
	"
	updated to latest OmniBrowser
	-------
	Change Set:		AddLineToTTCFont-yo
	Date:			1 August 2005
	Author:			Yoshiki Ohshima

	call #addLined on demand.  It should be handled more statically, but I have a feeling that 
	writing out TTCFont with LinedTTC in their derivative may not be handled very cleverly.
	--------------
	Change Set:		TTCRegistry-yo
	Date:			1 August 2005
	Author:			Yoshiki Ohshima

	A class variable (Registry) was missing from the class definition of TTCFont.  This change 
	set re-instate that, and register everything in postscript.
	--------------
	Change Set:		ttcNewSizeFix
	Date:			3 August 2005
	Author:			Yoshiki Ohshima

	Fallback font handling for new sized font has a bug.  The main problem is that 
	FixedFaceFont doesn't have the corresponding TextStyle.  I could add it, but so far I gave nil 
	to some implicit semantics in the methods in this change set.
	------------------
	Change Set:		searchPaneFix-sw
	Date:			3 August 2005
	Author:			Scott Wallace

	Make viewer search panes clip their submorphs, thus avoiding an ugly green artifact that 
	had crept in.  (Thanks to Andreas for supplying the fix.)
	-------------------
	Change Set:		AddTranslationNov30
	Date:			30 November 2005
	Author:			Yoshiki Ohshima

	Adds #translated to the ? halo of buttons.
	-------------------
	Change Set:		fixFileList2-bf
	Date:			5 December 2005
	Author:			Bert Freudenberg

	Fix image opening in FileList2
	--------------------
	0446ProjLoadFixes.cs 
	---------------------
	Change Set:		joystickEnh-mir-bf
	Date:			5 September 2005
	Author:			Michael Rueger, Bert Freudenberg

	Make joystick buttons available in Etoys.
	---------------------
	Change Set:		URLEncodingAttempt
	Date:			29 July 2005
	Author:			Yoshiki Ohshima

	An attempt to support more characters in encodeForHTTP.  However, this introduces another 
	backward compatibility problem.  The default behavior of #encodeForHTTP uses UTF-8 as the 
	byte sequence interpretation, but it was Latin-1 for older implementation.

	To get the backward compatible behavior, the senders of #encodeForHTTP should use an 	expression:

	aString encodeForHTTPWithTextEncoding: 'latin1'.

	instead.

	This changeset suppress the trivial error, but may cause the problem when somebody tries 
	to load a project from older image with latin-1 characters in its name.
	------------------
	0448loadNihongo4Projects.cs
	------------------
	Change Set:		worldPreferences-sw
	Date:			3 August 2005
	Author:			Scott Wallace

	Don't show the Preferences category in the world's viewer in eToyFriendly mode.

	When *not* in eToyFriendly mode, do show the category, to which othe alternatives have
 	now been added.
	------------
	Change Set:		vectorError-sw
	Date:			3 August 2005
	Author:			Scott Wallace

	Circumvents error condition when clicking on the menu icon of some of the 
	vector-vocabulary phrases.
	-------------
	Change Set:		EditableWatcher
	Date:			2 August 2005
	Author:			Takashi Yamamiya

	This fix allows you to edit variables with simple watchers
	-------------
	Change Set:		playfieldPrefBug-sw
	Date:			12 August 2005
	Author:			Scott Wallace

	Fixes the bug that the Preferences category could show up in the viewer of a non-world.
	-----------
	Change Set:		KedamaFixesAug
	Date:			15 August 2005
	Author:			Yoshiki Ohshima

	some fixes for a few known bugs.
	------------
	Change Set:		KedamaFixesAug2
	Date:			17 August 2005
	Author:			Yoshiki Ohshima

	suppress the dup halo for turtle exemplars, and make the forms in patches behaves better.
	------------
	Change Set:		symbolTranslationFix
	Date:			18 August 2005
	Author:			Yoshiki Ohshima

	Fix a few more problems with language transition.
	-------------
	Change Set:		KedamaFixesAug3
	Date:			19 August 2005
	Author:			Yoshiki Ohshima

	The backup code for a primitive was wrong.  It shows wrong boundary behavior when the 	
	plugin is not present.
	--------------
	Change Set:		fixObsDefault
	Date:			1 September 2005
	Author:			Michael Rueger

	Removes obsolete default messages and references still using them.
	------------
	"
	self script51.
	self flushCaches.
	MCDefinition clearInstances.
	TTCFont registerAll! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/20/2006 23:13'!
updateFrom7014
	"self new updateFrom7013"
	"
	Change Set:		0479iso3Countries.cs
	Date:			1 September 2005
	Author:			John Mcintosh, Michael Rueger

	Add ISO3 country codes to the iso definitions
	-------------
	Change Set:	phraseDupFix-sw
	Date:			23 October 2005
	Author:		Scott Wallace

	Fixes a bug that broke the duplication of phrase tiles that don't reside in viewers
	-------------
	Change Set:		suppliesTwoLiner
	Date:			7 October 2005
	Author:			Scott Wallace, Michael Rueger

	changes the supplies flap to show two lines of items by default
	--------------
	0498MacUnicodeIInterp.cs
	---------------
	Change Set:		FontRegistryFix
	Date:			9 October 2005
	Author:			Yoshiki Ohshima

	registry wasn't properly used for TTCFont.
	----------------
	Change Set:		percentEncodingFix
	Date:			22 September 2005
	Author:			Korakurider

	+ When Squeak is launched by openning .pr file, passed filename is systemString
	 (shift-jis on windows for instance).  That has to be converted to Squeak-native string.
	+ reimplementation of decoding percent-encoded-string has to be modified to support
	  utf8 based encoding.
	------------------
	0502nebraskaBuffer-yo.cs 
	-------------------
	Change Set:		NebraskaTextAndImageFix
	Date:			6 October 2005
	Author:			Yoshiki Ohshima

	* DropShadow + Text + Nebraska wasn't working right.
	* Form depth = 32 wasn't working right.  It isn't right or optimal but better in many ways.
	------------------
	Change Set:		revertStamp-tak
	Date:			28 November 2005
	Author:			Takashi Yamamiya

	Revert stampOnTransformedOwner.cs (it is included in 6580changesFromSql38ToJa)
	to fix a problem of stamp of rotated object.
	--------------------
	Change Set:		nebraskaBuffer2-yo
	Date:			10 October 2005
	Author:			Yoshiki Oshima

	Republished as Squeakland update 0506 to make certain that the code will be present in 
	images that had already loaded SqueakAlpha update 0502testPercentEncoding before it was 
	rescinded.
	--------------------
	Change Set:		FixKedamaBundle
	Date:			23 October 2005
	Author:			Yoshiki Ohshima

	KedamaBundle used to create an extra patch.
	---------------------
	Change Set:		BOMLangEditor
	Date:			29 November 2005
	Author:			Yoshiki Ohshima

	Fix BOM problem in Language Editor.
	--------------------
	Change Set:		ProjectManifest
	Date:			29 November 2005
	Author:			Yoshiki Ohshima

	Put a 'manifest' file that stores some additional infomation about the project.
	----------------------
	Change Set:		macosxJaMarks
	Date:			22 November 2005
	Author:			Tetsuya Hayashi

	Fixes Japanese input method related problem.
	It dealsd with special case involved in unicode conversion.
	-----------------------
	Change Set:		setupLanguageSpec-tak
	Date:			28 November 2005
	Author:			Takashi Yamamiya

	- Add language specific settings.
	- Remove setup scripts for old Japanese image.
	---------------------
	Change Set:		variableCategory-ka
	Date:			29 November 2005
	Author:			Kazuhiro Abe

	Patch for 'variable category doesn't apper when it's needed'.
	It occurs because missing 'translated' message after 'ScriptingSystem 
	nameForInstanceVariablesCategory' in StandardViewer>>likelyCategoryToShow.
	------------------------
	Change Set:		Use32BitPatch
	Date:			30 November 2005
	Author:			Yoshiki Ohshima
	-------------------------
	Change Set:		TextAlignEmphMenu-KR
	Date:			5 December 2005
	Author:			Korakurider

	fix problem that current alignment is shown wrongly on emphasis/alignment Menu for 
	TextMorph
	------------------------
	Change Set:		colorPickerFix-KR
	Date:			14 December 2005
	Author:			Korakurider

	Get the alpha setting on a morph's property sheet's fill-color colorpicker set properly.
	------------------------------
	Change Set:		shouldntBeRounded-ka
	Date:			4 December 2005
	Author:			Kazuhiro Abe

	Some morph, such as an Ellipse or a Polygon, shouldn't have rounded corners.
	They drew fake corners.
	------------------------------------
	Change Set:		FixAssignmentSuffix
	Date:			15 December 2005
	Author:			Takashi Yamamiya

	Fixed duplicated assignment arrows in old project.

	To load old project which is made in 3.2 era, assignment arrows (_) are
	duplicated. The reason is sometimes symbols and strings are confused in
	#translatedWordingFor:.
	----------------------------
	Change Set:		fixCharConv128-255
	Date:			5 November 2005
	Author:			Takashi Yamamiya

	Some characters could not be converted from Squeak to OS encoding.

	To reproduce:
	- Open workspace.
	- Input MULTIPLICATION SIGN character with your IME.
	- select and copy a few times for copying to the system paste buffer.
	- You would see an error.

	Reason: A charactor which value is 128-255 should be converted.

	e.g.
	00D7 MULTIPLICATION SIGN 
	00F7 DIVISION SIGN
	see http://www.unicode.org/charts/PDF/U0080.pdf
	-------------------------
	Change Set:		fixManifest
	Date:			16 December 2005
	Author:			Korakurider

	fix and enhance the facility to save manifest of project:
	  + Original implementation use constant filename 'MANIFEST'.
	    That behavior causes conflict of filename on server(Swiki etc).
	    This patch use basename of project for file name for manifest
 	+ save latest update number of SmalltalkImage in manifest (enhancement)
	----------------------------
	0528FixAPartOfBobConv.cs 
	"
	
	self script52.
	self flushCaches.
	MCDefinition clearInstances.
	
	ISOLanguageDefinition initISOCountries.
	
	Preferences addPreference: #duplicateAllControlAndAltKeys category: #keyboard default: true balloonHelp: 'If true, duplicates all alt- keys as ctrl-keys (making ctrl-c be copy as well as alt-c).
Cannot be true if swapControlAndAltKeys or duplicateControlAndAltKeys are true.'.

Preferences addPreference: #duplicateControlAndAltKeys category: #keyboard default: false balloonHelp: 'If true, duplicates some alt- keys as ctrl- keys (making ctrl-c be copy as well as alt-c).
Cannot be true if swapControlAndAltKeys or duplicateAllControlAndAltKeys are true.'.

Preferences addPreference: #swapControlAndAltKeys category: #keyboard default: false balloonHelp:  'If true, swaps some control- and alt-keys (making ctrl-c be copy instead of alt-c). 
Cannot be true if duplicateControlAndAltKeys or duplicateAllControlAndAltKeys is true.'.

(Preferences preferenceAt: #honorDesktopCmdKeys) categoryList: #(#keyboard #menus).

(Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false.
(Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false.
(Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false.

(Preferences preferenceAt: #duplicateAllControlAndAltKeys) changeInformee: InputSensor changeSelector: #duplicateAllControlAndAltKeysChanged.
(Preferences preferenceAt: #duplicateControlAndAltKeys) changeInformee: InputSensor changeSelector: #duplicateControlAndAltKeysChanged.
(Preferences preferenceAt: #swapControlAndAltKeys) changeInformee: InputSensor changeSelector: #swapControlAndAltKeysChanged.

(Preferences preferenceAt: #duplicateAllControlAndAltKeys) preferenceValue: true.
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/22/2006 20:17'!
updateFrom7015
	"self new updateFrom7015"
	"
	Change Set:		ProportionalSplitter-honor-boundaries-jrp
	Date:			21 March 2006
	Author:			John Pierce

	Keep splitter from moving outside the natural window boundaries
	-----------
	Change Set:		projectViewMenuFix-yo.cs
	Date:			2 August 2005
	Author:			Kazuhiro Abe and Yoshiki Ohshima

	The project name of menu label was incorrect.
	------------
	Change Set:		testTileFix-kfr
	Date:			24 January 2006
	Author:			Karl Ramberg

	When clicking the button to add a new TestTile the ScriptEditor is unresponsive to place the TestTile 	
	because the tile never signaled a mouseEnter to the ScriptEditor. This is a fix for that.
	-------------
	Change Set:		retainRotationCenter-sw
	Date:			25 January 2006
	Author:			Scott Wallace

	When repainting a sketch, retain any existing rotation-center that may have been specified.
	--------------
	Change Set:		undoFixes-sw
	Date:			2 February 2006
	Author:			Scott Wallace

	Implements uindo for 'dismiss via halo', which works even if trash is not being preserved.
	Make the Undo button in the NavBar dynamically show what action it *would* undo.
	Makes that button work propery in a redo situation (formerly it had malfunctioned  when in redo 
	mode.)
	Elaborates the wording of the 'undo' item to include identification of the target, for resize and rotate 	now, as it always has done for move.
	Fixes some bugs encountered along the way.
	Fixes the bug that could break undo of a rotation, if an addition or removal of a flex shell was 	involved.
	------------------
	Change Set:		SuperSwikiString-KR
	Date:			1 February 2006
	Author:			Korakurider

	Current m18n implementation assumes shift_jis encoding is used in wire protocol between
	SuperSwiki server and client.  Then some existing projects encoded in other than shift_jis
	cause walkback. 

	This patch introduces 'encodingName' for ServerDirectory entry (even in knownServer entry) 
	so that appropriate encoding can be specified for each server.  If not specified, encoding is 	
	determined based on current locale.
	------------------
	Change Set:		rotCenterHaloHelp-sw
	Date:			16 February 2006
	Author:			Scott Wallace

	Supplements the balloon help for the rotation-center handle with the additional informaiton that the 
	user should hold down the shift key to move it.
	-------------------
	Name: Balloon-mir.11
	Author: mir
	Time: 22 March 2006, 2:14:18 pm

	(backported from Jan Fietz' changes)

	FlashFileReader support for more image tags:
		processDefineBitsJPEG3 (JPEG + alpha channel)
		processDefineLossless2
	---------------------
	Name: Flash-mir.2
	Author: mir
	Time: 22 March 2006, 3:04 pm

	merge with iSqueak flash enh. (was ballon)
	-----------------------
	Name: SUnitGUI-lr.6
	Author: lr
	Time: 22 March 2006, 7:49:27 pm

	- fixed a couple of issues related to the change-notifications
		- no more debugger if the system contains classes that are not categorized yet (can happen 				when loading mcz files)
		- register for some different change events that were missed
	- unregister for changes when window closes
	-------------------
	"
	
	self script53.
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/22/2006 22:40'!
updateFrom7019
	"self new updateFrom7019"
	"
	sync from update stream. changesets:
	
	7019-DNUFixScrollBar-md.1.cs
	7018-0525nebraskaFontSet.cs
	7017-0445ja-forms.cs
	
	"
	
	self script54.
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 3/28/2006 21:08'!
updateFrom7020
	"self new updateFrom7020"
	"
	- 0003215: saving and reloading a string morph with a true type font breaks the font
	- 0003354: Can't select some colors in PaintBoxColorPicker
	- 0003355: [BUG] Fresh 3.9a image (build 7020) has text morphs in objects window wrong size
	- added CollectionsTests from stef
	- OmniBrowser (fixed by Lukas)
		- makes it possible to drag meta-classes to new categories
		- add missing OBClassActor to OBMetaclassNode
		- fix as published in http://bugs.impara.de/view.php?id=3269
		- fix a debugger when selecting omnibrowser as default browser 
		- made the buttons in omnibrowser look like they do in 3.9
		- fixes an infinite recursion occuring when a drag&drop operation is started
	- fix for the SlowRedraw bug (Adrian)
	- valueWithExit for BlockContex / BlockClosure
	- added Symbol>>#value:
	-------
	Change Set:		SuperSwikiFixKR
	Date:			20 February 2006
	Author:			Korakurider

	A one-method fix to the recent SuperSwikiStr update.
	-------
	Change Set:		TTCFont-fix-ascent-jrp
	Date:			27 March 2006
	Author:			John Pierce

	Add ascent instance variable back to the class so method ascent will work again.
	"
	
	self script55.
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 4/9/2006 21:21'!
updateFrom7021
	"self new updateFrom7021"
	"
	NOT YET RELEASED
	Tests for Heap
	Tests for SystemChangeNotifications
	Fix of roel for double event notification when class recategorisation
	0003440: UTF8TextConverter>>nextFromStream: silently truncates input
	0003375: mcz files saved in 3.9 don't load in 3.8
	0003376: mpeg plugin has changes to image to support read from buffer versus file
	0000521: [BUG] Button properties Morph need to be fixed or removed.
	0002116: Halo rotation of a true type font throws up a debug window.
	0001608: [BUG][FIX] Morphic: File Selection Dialog
	0003378: Add FloatMathPluginTests class to Tests-VM package/category
	0003377: mpeg plugin has changes to image to support dropping bits into an offset into a 
			form so you can write to say Display
	OmniBrowser:
		- format non-local methods (e.g from traits) in italic (does also work in images that do 		not have support for traits)
	0001604: [FIX] [BUG] smoothOrSegmentedPhrase-wiz
	0001200: Outdent/Indent issue if code contains WideStrings
	SUnit: Merged in SUnit extensions by Mercap Software.

	"
	
	self script57.
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 4/21/2006 16:09'!
updateFrom7022

	"self new updateFrom7022"
	""
	
	self script58.
	self flushCaches.
	MCDefinition clearInstances.

	MenuIcons initializeIcons.

	"Postscript from Changeset:  1044-TrashCanMorphCleanUp-dgd"
	World submorphs
		select: [:each | each isKindOf: TrashCanMorph]
		thenDo: [:each | each delete].

	World restoreFlapsDisplay.

	Preferences setNotificationParametersForStandardPreferences.
	World roundUpStrays.
	ParagraphEditor initialize.
	SystemProgressMorph reset.
	MenuIcons initializeIcons.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 4/25/2006 18:28'!
updateFrom7024

	"self new updateFrom7024"
	"
	Compiler:
	 	- Small refactoring of MethodNode>>generate and related methods (needed by 		 
		  MethodWrappers) (Diego Fernandez (and Andrian Lienhard (NetStyle.ch)) )
		- == <integer literal> to = <integer literal> in response to Dan Ingalls' note (fbs)
	OmniBrowser: (Lukas Renggli of NetStyle.ch)
	    - fixes an bug when the browser is opened (Ctrl+B) from non OmniBrowser windows 
		(Debugger, Workspace, ...)
	    - drag and drop methods and categories onto classes
	--------------
	SUnit:
	0003489: ClassTestCase >> selectorsTested misses 'special' methods.

	The method ClassTestCase >> selectorsTested computes the sent messages in a test incorrectly. It 	looks in the literals array, and so misses the 32 'special' message selectors. The correct code 
	is both shorter and simpler. (Andrew Black)
	---------------
	Morphic:
		- 0003416: Faster Moprhic invalidation
		  Morph>>invalidRect:from: was testing for wonderland textures (which where stored in 
		  a property...). (Thanks to Andrew Black for reporting this).
		- Better looking menu title bar (from a mail to the list that I can't find anymore...
		   please use mantis if you want your name to appear here ;-))
	---------------
	Change Set:		ExternalSettingsReorg-tpr
	Date:			5 April 2006
	Author:			tim@rowledge.org

	Reorganise the categories in ExternalSettings to get rid of an explcit '--all--' that can make a 	real mess of filing out the code
	--------------	
	Change Set:		KedamaMissing-KR
	Date:			14 April 2006
	Author:			Korakurider

	add missing method for Kedama
	----------------
	Change Set:		KedamaWODepreciated-KR
	Date:			14 April 2006
	Author:			Korakurider

	refactor kedama not to call depreciated methods.
	note: As showDeprecationWarnings preferece is set to false in Squeakland image, 
	original kedama code run without no problem.
	------------------
	renamed BlockContext>>endpc to be endOC and fix the one sender (md)
	------------------
	Change Set:		MacRomanFix
	Date:			5 April 2006
	Author:			Andreas Raab

	Raise an error if somebody tries to write wide characters.
	----------------------
	0003458: PositionableStream>>copyPreamble:from:at: broken  (Andreas)
	---------
	0003415: Changeset is not updated when renaming a class (Noury)
	After renaming a class, the changeset is not updated to refer to the new name. Therefore, 	
	one virtually lose recorded changes.
	The fix also cleans a bit SystemDictionary. It removes method 	SystemDictionary>>renameClass:from: and uses instead SystemDictionary>>renameClass:as: used 	by traits
	-----------
	0003492: Complete the job of changing the way that arrays are printed (Andrew Black)
	Description
	The new array printing logic introduced in 3.9 had some holes, and needed some cleanup. 	The attached changeset provides it. Tests are included.
	Additional Information
	Specifically, the changeset

	- marks Fractions as selfEveluating and Booleans as literals
	- puts Array>>printOn: back in the printing ctaegory, where someone might expect to find it
	- removes duplicated logic from Collection>>printElementsOn:
	- adds tests for all of the above.
	--------------
	faster asUTC from Avi
	-------------- 
	"
	self script59.
	self flushCaches.
	MCDefinition clearInstances.
	FixInvisible fixFonts! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 4/29/2006 22:56'!
updateFrom7025

	"self new updateFrom7025"
	"
	NOT RELEASED YET
	---------------------------------
	See Mantis bug 1840 and 854.
	This changeset allows a too-long Delay to fail the relevant primitive and schedules a fake 	delay to keep the timer system going. I claim this is preferable to disallowing long delays.
	---------------------------------
	3515 - Parser fails in #defineClass: becasue Metaclass doest not understand #category
	---------------------------------
	003513: [ENH] ToolBuilderBldEnh-KR
Description
ToolBuilder>>(class)build: 
enable default builder to build objects without opening.
It's useful for building authoring prototypes for ToolBuilder-based tools in parts bin.
	---------------------------------
	0003510: In 3.9a requesting a language change leads to infinite generation of testRunners
	---------------------------------
	0003504: Float asInteger conversion is inexact...
	"
	self script60.
	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 5/2/2006 21:57'!
updateFrom7026

	"self new updateFrom7026"
	"
	New version....because of problems
	---------------------------------
	0003520: Chronology Tests for hash failed in 7025; fixes included (by Tom Koenig)
	---------------------------------
	0003518: SkipListTests fails/errors in 7025;SkipListTestsFixes (by Tom Koenig)
	---------------------------------
	0003373: Float asFraction does not handle gradual underflow
	---------------------------------
	0003339: [Fix] Simple button morphs don't reset their color properly when balked.
	---------------------------------
	
	"
	self script61.
	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 5/4/2006 16:09'!
updateFrom7028

	"self new updateFrom7028"
	"
	in 7028 we pushed in the update stream 
	0003426: init: method should be renamed initialize: for consistency
	------------------------------------------------------------------------------
	0003527: infinite loop on locale change (Mantis 0003510 ) not fixed yet in 7027
	------------------------------------------------------------------------------
	0003505: Context menus in ImageBrowser (OmniBrowser) crash due to missing methods in MenuIcons
	------------------------------------------------------------------------------
	0003519: Duration isZero gets MNU in 7026;fix failed
	
	"
	self script62.
	self flushCaches.
	MCDefinition clearInstances.
	Flaps initializeFlapsQuads.
     FileList registerInFlapsRegistry.  "if needed "
     TestRunner registerInToolsFlap.    "if needed "
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 5/7/2006 10:04'!
updateFrom7029

	"self new updateFrom7029"
	"
	restore canUnderstand: + introduce canPerform:
	
	"
	self script63.
	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 5/9/2006 22:29'!
updateFrom7030

	"7030 was generated by cs on the update stream"
	
	
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 5/9/2006 22:28'!
updateFrom7031

	"self new updateFrom7031"
	"
	- Shift ivars traitComposition and localSelectors because of problem with hardcoded indexes in VM (this is accomplished in combination with a cs which has to be loaded first)
	- refactor accessing trait compositions to avoid unnecessary lazy initialization
	- recategorizing methods from *Traits extensions to local packages
	- new requires algorithm tests by Andrew Black
	"
	
	self script64.
	
	"To get rid of already created empty compositions in the image"
	Smalltalk allClassesAndTraitsDo: [ :each |
	(each instVarNamed: 'traitComposition') notNil and: [
		each traitComposition allTraits isEmpty ifTrue: [
			each instVarNamed: 'traitComposition' put: nil ] ] ].

	"Initialization required for tests"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 5/29/2006 20:22'!
updateFrom7032

	"self new updateFrom7032"
	"
	Networks fixes provided by the network IO team
	"
	
	self script65.
	
	
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 6/20/2006 16:48'!
updateFrom7033
	"self new updateFrom7033"
	
	"Some MC fixes"
	
	self script66.
	
	
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'al 7/5/2006 16:09'!
updateFrom7035
	"self new updateFrom7035"
	
	"Pragrams fixes lr
	PackageInfo al
	System al
	Kernel Tests lr"
	
	self
		loadOneAfterTheOther: #('System-sd.87.mcz' 'Monticello-al.305.mcz' 'PackageInfo-al.6.mcz')
		merge: true.
		
	self script67.
	
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/8/2006 18:56'!
updateFrom7036
	"self new updateFrom7036"
	
	self script68.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/8/2006 18:38'!
updateFrom7037
	"self new updateFrom7037"
	
	self script69.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/9/2006 22:46'!
updateFrom7038
	"self new updateFrom7038"
	
	self script70.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/12/2006 16:52'!
updateFrom7039
	"self new updateFrom7039"
	
	self loadTogether: #('Kernel-sd.133.mcz' 'Traits-al.221.mcz') merge: true.
	
	Smalltalk allClassesAndTraits do: [:t | 
		(t methodDict keys select: [:s | t includesLocalSelector: s]) do: [:s | 
		t notifyUsersOfChangedSelectors: {s}].
	(t classSide methodDict keys select: [:s | t classSide includesLocalSelector: s]) do: [:s |
          t classSide notifyUsersOfChangedSelectors: {s}]].	
	
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/12/2006 19:11'!
updateFrom7040
	"self new updateFrom7040"
	
	self script71.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/12/2006 23:07'!
updateFrom7041
	"self new updateFrom7041"
	
	self script72.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.

	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/14/2006 12:24'!
updateFrom7042
	"self new updateFrom7042"
	
	self script73.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.
	
	Preferences disable: #higherPerformance.
	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/14/2006 19:57'!
updateFrom7043
	"self new updateFrom7043"
	
	self script74.
	ServiceRegistry rebuild.

	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.
	
	self flushCaches.
	MCDefinition clearInstances.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/15/2006 17:58'!
updateFrom7044

	"self new updateFrom7044"
	self script75.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.
	
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 7/15/2006 21:54'!
updateFrom7045

	"self new updateFrom7045"
	self script76.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.
	
	self flushCaches.
	MCDefinition clearInstances.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 7/23/2006 12:00'!
updateFrom7046
	"self new updateFrom7046"
	
	self script77.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.
	
	self flushCaches.
	MCDefinition clearInstances.
	"uncomment for the final version"
	Utilities emptyScrapsBook.
	"self prepareReleaseImage."! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 7/23/2006 14:09'!
updateFrom7047

	"self new updateFrom7047"
	self script78.
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.
	ServiceRegistry initialize.
	
	self unloadPackages.
	AppRegistry removeObsolete.
	FileServices removeObsolete. 
	Undeclared removeUnreferencedKeys.
	self flushCaches.
	MCDefinition clearInstances.
	Preferences addPreference: #multipleTextUndo
		categories: #('general') default: false 
		balloonHelp: 'Editors track a multiple undo history'.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 8/2/2006 17:38'!
updateFrom7048

	"self new updateFrom7048"
	self script79.
	
	self flushCaches.
	
	self cleanUpMethods.
	"recompile some methods"
	(nil systemNavigation allMethodsSelect: [:method |
	    (method methodClass methodDictionary includesIdentity: method) not])
	   do: [:cltr | cltr actualClass compileAll]
! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 8/2/2006 20:40'!
updateFrom7049

	"self new updateFrom7049"
	self script80.
	self flushCaches.
	Preferences initializeTextHighlightingParameters.
	self finalCleanup.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 8/10/2006 12:03'!
updateFrom7050

	"self new updateFrom7050"
	self script81.
	self flushCaches.
	! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 8/11/2006 11:26'!
updateFrom7051

	"self new updateFrom7051"
	self script82.
	
	Preferences disable: #maintainHalos.
	SMSqueakMap default loadFull.
	self flushCaches.
	ChangeSet removeEmptyUnnamedChangeSets.
	ChangeSet newChanges: (ChangeSorter basicNewChangeSet: 'Unnamed').
	ChangeSet current name: 'Unnamed'.! !

!ScriptLoader methodsFor: 'updates' stamp: 'sd 8/13/2006 20:12'!
updateFrom7052
	"self new updateFrom7052"
	self unloadFFI.
	
	Preferences disable: #maintainHalos.
	SMSqueakMap default loadFull.
	self flushCaches.
	ChangeSet removeEmptyUnnamedChangeSets.
	ChangeSet newChanges: (ChangeSorter basicNewChangeSet: 'Unnamed').
	ChangeSet current name: 'Unnamed'.! !

!ScriptLoader methodsFor: 'updates' stamp: 'md 9/7/2006 22:43'!
updateFrom7053
	"self new updateFrom7053"
	
	Smalltalk allClassesAndTraits do: [:t | 
		(t methodDict keys select: [:s | t includesLocalSelector: s]) do: [:s | 
		t notifyUsersOfChangedSelectors: {s}].
	(t classSide methodDict keys select: [:s | t classSide includesLocalSelector: s]) do: [:s |
          t classSide notifyUsersOfChangedSelectors: {s}]].	

	"[Explanation: It originates in the update from 7048 to 7049 where some classes are recompiled. This also recompiles the trait methods in those classes. This breaks the assumption in #moveChangesTo: that a method needs to be moved to the new changes file only if it is not from a trait or if it is from a trait but with a supersend (this is assumed to be the only case for which traits methods are not identical with the original method in the trait). Since this is not the case after the recompilation, now there are some old methods not moved to the new changes and hence they still have old pointers].
"
	self script83.

	self installingDefaultRepositoriesToPackages. 
	
	self flushCaches.! !



!ScriptLoader methodsFor: 'public helpers' stamp: 'sd 7/14/2006 21:40'!
compileNewUpdateMethod

	self class compile: 
		(self generateNewUpdateMethod)
		classified: 'updates'! !

!ScriptLoader methodsFor: 'public helpers' stamp: 'sd 7/14/2006 21:32'!
compileScriptMethodWithCurrentPackages: aNumber 
	"ScriptLoader new compileScriptMethodWithCurrentPackages: 9999"
	
	self class compile: 
		(self generateScriptTemplateWithCurrentPackages: aNumber)
		classified: 'scripts'! !

!ScriptLoader methodsFor: 'public helpers' stamp: 'sd 7/14/2006 17:52'!
compileScriptMethodXXXWithCurrentPackages
	"ScriptLoader new compileScriptMethodXXXWithCurrentPackages"
	
	self class compile: self generateScriptTemplateWithCurrentPackages classified: 'scripts'! !

!ScriptLoader methodsFor: 'public helpers' stamp: 'sd 7/14/2006 21:41'!
methodsForNewVersion
	"self new methodsForNewVersion"
	
	self compileScriptMethodWithCurrentPackages: (self getLatestScriptNumber + 1).
	self compileNewUpdateMethod.! !

!ScriptLoader methodsFor: 'public helpers' stamp: 'md 8/2/2006 18:06'!
writeCS: extensionAndNumber forUpdate: updateNumber withName: aSt
	"ScriptLoader new writeCS: '-md.2929' forUpdate: 7049 withName: 'cleanUpMethods'"
	
	| str |
	str := FileDirectory default forceNewFileNamed:  updateNumber asString, 'update', aSt, '.cs'.
	self generateCS: extensionAndNumber fromUpdate: updateNumber on: str.
	str close.! !


!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 10/31/2005 18:01'!
addRepositoryToPackageNamed: aString
	
	|pa|
	pa := MCPackage named: aString.
	pa workingCopy repositoryGroup addRepository: self repository.
	! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/15/2006 20:30'!
currentPackages
	"ScriptLoader new currentPackages"
	
	| copies |
	copies := MCWorkingCopy allManagers asSortedCollection:
		[ :a :b | a package name <= b package name ].
	^ copies select: [:each | '*Plus*' match: each package name ].! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 5/29/2006 20:52'!
currentVersions
	"ScriptLoader new currentVersions"
	
	| copies |
	copies := MCWorkingCopy allManagers asSortedCollection:
		[ :a :b | a package name <= b package name ].
	^ copies collect:
		[:ea |  ea ancestry ancestorString ]! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/12/2006 15:46'!
generateCS: extensionAndNumber fromUpdate: updateNumber on: st
	
	st nextPutAll:
'"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!!!).
Be sure to put any further comments in double-quotes, like this one."

|repository|
repository := MCHttpRepository
                location: ''http://source.squeakfoundation.org/39a''
                user: ''''
                password: ''''.
(repository loadVersionFromFileNamed:' .
	st nextPut: $' ; nextPutAll: 'ScriptLoader', extensionAndNumber, '.mcz'') load.'; cr.
	st nextPutAll: 'ScriptLoader new updateFrom', (updateNumber-1) asString; nextPutAll: '.' ; cr.
	st nextPutAll: 'ChangeSet newChanges: ChangeSet new' ; cr.
	st nextPutAll: '!!'.
	^ st contents
! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'md 8/2/2006 17:38'!
generateNewUpdateMethod
	"ScriptLoader new compileNewUpdateMethod"
	
	| str mthName |
	str := ReadWriteStream on: (String new: 1000).
	mthName := 'updateFrom', (self getLatestUpdateNumber + 1) asString.
	str nextPutAll: mthName ; cr ; cr ; tab.
	str nextPutAll: '"self new ', mthName, '"' ; cr.
	
	str nextPutAll: '	self script' , self getLatestScriptNumber asString, '.'.
	str nextPutAll: '
	self flushCaches.
	'.
	
	^ str contents! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/14/2006 17:19'!
generateScriptTemplateWithAllCurrentPackages
	"ScriptLoader new generateScriptTemplateWithAllCurrentPackages"
	
	| str |
	str := ReadWriteStream on: (String new: 1000).
	str nextPutAll: 'scriptXXX' ; cr ; cr ; tab.
	str nextPutAll: '| names|'; cr.
	str nextPutAll: 'names := '.
	str nextPut: $'.
	self currentVersions do: 
		[:each |
			str nextPutAll: each ; nextPutAll: '.mcz']
		separatedBy: [str nextPut: Character cr].
	str nextPut: $'; nextPut: Character cr.
	str nextPutAll: 'findTokens: '' '', String cr.

	self loadTogether: names merge: false.'.
	^ str contents! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/14/2006 17:25'!
generateScriptTemplateWithCurrentPackages
	"ScriptLoader new generateScriptTemplateWithCurrentPackages"
	
	| str withoutScriptLoader |
	str := ReadWriteStream on: (String new: 1000).
	str nextPutAll: 'scriptXXX' ; cr ; cr ; tab.
	str nextPutAll: '| names|'; cr.
	str nextPutAll: 'names := '.
	str nextPut: $'.
	withoutScriptLoader := self currentVersions reject: [:each| ('*ScriptLoader*' match: each)].
	withoutScriptLoader 
		do: [ :each |
			str nextPutAll: each ; nextPutAll: '.mcz']
		separatedBy: [str nextPut: Character cr].
	str nextPut: $'; nextPut: Character cr.
	str nextPutAll: 'findTokens: '' '', String cr.

	self loadTogether: names merge: false.'.
	^ str contents! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/14/2006 17:33'!
generateScriptTemplateWithCurrentPackages: aNumber
	"ScriptLoader new generateScriptTemplateWithCurrentPackages"
	
	| str withoutScriptLoader |
	str := ReadWriteStream on: (String new: 1000).
	str nextPutAll: 'script', aNumber asString ; cr ; cr ; tab.
	str nextPutAll: '| names|'; cr.
	str nextPutAll: 'names := '.
	str nextPut: $'.
	withoutScriptLoader := self currentVersions reject: [:each| ('*ScriptLoader*' match: each)].
	withoutScriptLoader 
		do: [ :each |
			str nextPutAll: each ; nextPutAll: '.mcz']
		separatedBy: [str nextPut: Character cr].
	str nextPut: $'; nextPut: Character cr.
	str nextPutAll: 'findTokens: '' '', String cr.

	self loadTogether: names merge: false.'.
	^ str contents! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/14/2006 18:00'!
getLatestScriptNumber

	| upfroms |
	upfroms := ScriptLoader selectors select: [:each | 'script*' match: each ].
	upfroms := upfroms collect: [:each | (each asString allButFirst: 6)].
	upfroms := upfroms reject: [:each | '*Log*' match: each ].
	upfroms := upfroms reject: [:each | '*XXX*' match: each ].
	upfroms := upfroms collect: [:each | each asNumber].
	^ upfroms asSortedCollection last
	! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/14/2006 17:46'!
getLatestUpdateNumber

	| upfroms |
	upfroms := ScriptLoader selectors select: [:each | 'updateFrom*' match: each ].
	upfroms := upfroms collect: [:each | (each asString last: 4) asNumber].
	^ upfroms asSortedCollection last! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'al 12/8/2005 21:18'!
loadOneAfterTheOther: aCollection merge: aBoolean
	| loader |
	(self newerVersionsIn: aCollection)
		do: [:fn |
			loader := aBoolean
				ifTrue: [ MCVersionMerger new ]
				ifFalse: [ MCVersionLoader new].
			loader addVersion: (self repository loadVersionFromFileNamed: fn).
			aBoolean
				ifTrue: [[loader merge] on: MCMergeResolutionRequest do: [:request |
							request merger conflicts isEmpty
								ifTrue: [request resume: true]
								ifFalse: [request pass]]]
				ifFalse: [loader load]]
  	  	displayingProgress: 'Loading versions...'.
	

! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'dvf 10/14/2005 09:17'!
loadTogether: aCollection merge: aBoolean
	| loader |
	loader _ aBoolean
		ifTrue: [ MCVersionMerger new ]
		ifFalse: [ MCVersionLoader new].
	(self newerVersionsIn: aCollection)
		do: [:fn | loader addVersion: (self repository loadVersionFromFileNamed: fn)]
  	  	displayingProgress: 'Adding versions...'.
	aBoolean
		ifTrue: [[loader merge] on: MCMergeResolutionRequest do: [:request |
					request merger conflicts isEmpty
						ifTrue: [request resume: true]
						ifFalse: [request pass]]]
		ifFalse: [loader load]

! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'md 2/16/2006 16:43'!
mergePackagesNamed: names
	| vm  |
	repository _ MCHttpRepository
                location: 'http://source.squeakfoundation.org/39a'
                user: ''
                password: ''.

	vm _ MCVersionMerger new.
	names
		do: [:fn | vm addVersion: (repository loadVersionFromFileNamed: fn)]
		displayingProgress: 'Adding versions...'.

	[vm merge]
		on: MCMergeResolutionRequest do: [:request |
			request merger conflicts isEmpty
				ifTrue: [request resume: true]
				ifFalse: [request pass]]! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'al 10/13/2005 21:44'!
newerVersionsIn: aCollection
	^aCollection reject: [:each |
		MCWorkingCopy allManagers anySatisfy: [:workingcopy |
			workingcopy ancestry ancestorString , '.mcz' = each]].! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'stephaneducasse 1/14/2006 12:46'!
resetToolSet

	ToolSet default: nil! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 10/31/2005 18:00'!
test
	"self new test"
	
	|pa|
	pa := MCPackage named: 'FlexibleVocabularies'.
	pa workingCopy repositoryGroup addRepository: self repository.
	! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 8/13/2006 19:46'!
unloadFFI
	"ScriptLoader new unloadFFI"
	
	| copies namesOfpackagesToUnload |
	namesOfpackagesToUnload := #('*FFI*'). 
	copies := MCWorkingCopy allManagers asSortedCollection:
		[ :a :b | a package name <= b package name ].
	(copies select: [:each | namesOfpackagesToUnload anySatisfy: [:ea | ea match: each package name ]])
		do: [:z | z unload].
	Smalltalk recreateSpecialObjectsArray! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/15/2006 20:39'!
unloadPackages
	"ScriptLoader new unloadPackages"
	
	| copies namesOfpackagesToUnload |
	namesOfpackagesToUnload := self packagesToUnload. 
	copies := MCWorkingCopy allManagers asSortedCollection:
		[ :a :b | a package name <= b package name ].
	(copies select: [:each | namesOfpackagesToUnload anySatisfy: [:ea | ea match: each package name ]])
		do: [:z | z unload].! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/15/2006 23:07'!
unloadToolPlus
	"ScriptLoader new unloadToolPlus"
	
	ToolSet unregister: PlusToolSet.
	self resetToolSet! !

!ScriptLoader methodsFor: 'private helpers' stamp: 'sd 7/8/2006 18:20'!
writeCS: extensionAndNumber forUpdate: updateNumber
	"ScriptLoader new writeCS: '-sd.210' forUpdate: 7037"
	
	self writeCS: extensionAndNumber forUpdate: updateNumber withName: 'changeMe'! !


!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 8/28/2006 23:17'!
cleanOldRepositories
	"self new cleanOldRepositories"
	
	MCWorkingCopy allManagers do: [:each | 
		each  repositoryGroup
			removeRepository: (MCHttpRepository new location: 'http://kilana.unibe.ch:8888/Monticello');
			removeRepository: (MCHttpRepository new location: 'http://modules.squeakfoundation.org/People/gk/')].
	! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 7/15/2006 20:45'!
cleanUpChanges
	"Clean up the change sets"
	"self new cleanUpChanges"
	
	| projectChangeSetNames |
	"Delete all changesets except those currently used by existing projects."
	projectChangeSetNames := Project allSubInstances collect: [:proj | proj changeSet name].
	ChangeSet removeChangeSetsNamedSuchThat:
		[:cs | (projectChangeSetNames includes: cs) not].
! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 7/15/2006 20:57'!
cleanUpEtoys
	"self new cleanUpEtoys"

	StandardScriptingSystem removeUnreferencedPlayers.

	(self confirm: 'Remove all projects and players?')
		ifFalse: [^self].
	Project removeAllButCurrent.

	#('Morphic-UserObjects' 'EToy-UserObjects' 'Morphic-Imported' )
		do: [:each | SystemOrganization removeSystemCategory: each].
		
	Smalltalk
		at: #Player
		ifPresent: [:superCls | superCls
				allSubclassesDo: [:cls | 
					cls isSystemDefined
						ifFalse: [cls removeFromSystem].
					cls := nil]].! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'md 7/27/2006 15:27'!
cleanUpMethods
	"Make sure that all methods in use are restarted"

	WeakArray restartFinalizationProcess.
	MethodChangeRecord allInstancesDo:[:x| x noteNewMethod: nil].
	Delay startTimerInterruptWatcher.
	WorldState allInstancesDo:[:ws| ws convertAlarms; convertStepList].
	ExternalDropHandler initialize.
	ScrollBar initializeImagesCache.
	Vocabulary initialize.
	GradientFillStyle initPixelRampCache.
	ProcessBrowser initialize.
	Smalltalk garbageCollect.

	self assert: (CompiledMethod allInstances
	reject:[:cm| cm hasNewPropertyFormat]) isEmpty.! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 7/15/2006 20:57'!
finalCleanup
	"self new finalCleanup"

	Smalltalk forgetDoIts.
	DataStream initialize.
	Behavior flushObsoleteSubclasses.
	"The pointer to currentMethod is not realy needed (anybody care to fix this) and often holds on to obsolete bindings"
	MethodChangeRecord allInstancesDo: [:each | each noteNewMethod: nil].
	self cleanUpEtoys.
	SmalltalkImage current fixObsoleteReferences.
	Smalltalk flushClassNameCache.
	SystemOrganization removeEmptyCategories.
	3 timesRepeat: [
		Smalltalk garbageCollect.
		Symbol compactSymbolTable.
	].
	
! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 7/16/2006 09:54'!
finalStripping
	"self new finalStripping"
! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 7/16/2006 14:58'!
fixObsoleteReferences
	"self new fixObsoleteReferences"

	| informee obsoleteBindings obsName realName realClass |
	Preference allInstances do: [:each | 
		informee := each instVarNamed: #changeInformee.
		((informee isKindOf: Behavior)
			and: [informee isObsolete])
			ifTrue: [
				Transcript show: each name; cr.
				each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]].
 
	CompiledMethod allInstances do: [:method |
		obsoleteBindings := method literals select: [:literal |
			literal isVariableBinding
				and: [literal value isBehavior]
				and: [literal value isObsolete]].
		obsoleteBindings do: [:binding |
			obsName := binding value name.
			Transcript show: obsName; cr.
			realName := obsName copyReplaceAll: 'AnObsolete' with: ''.
			realClass := Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject].
			binding isSpecialWriteBinding
				ifTrue: [binding privateSetKey: binding key value: realClass]
				ifFalse: [binding key: binding key value: realClass]]].


	Behavior flushObsoleteSubclasses.
	Smalltalk garbageCollect; garbageCollect.
	SystemNavigation default obsoleteBehaviors size > 0
		ifTrue: [SystemNavigation default obsoleteBehaviors inspect]! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'md 8/2/2006 18:12'!
flushCaches

	MCFileBasedRepository flushAllCaches.
	MCDefinition clearInstances.
	Smalltalk garbageCollect.
	
	"Initialization required for tests: strange why this is not a teardwon method"
	SendCaches initializeAllInstances.! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'md 8/10/2006 12:10'!
initialCleanup
	"Perform various image cleanups in preparation for making a Squeak gamma release candidate image."
	"self new initialCleanup"
	
	Undeclared removeUnreferencedKeys.
	StandardScriptingSystem initialize.
	self resetToolSet.
	AppRegistry removeObsolete.
	FileServices removeObsolete. 

	(Object classPool at: #DependentsFields) size > 1 ifTrue: [self error:'Still have dependents'].
	Undeclared isEmpty ifFalse: [self error:'Please clean out Undeclared'].

	Smalltalk at: #Browser ifPresent:[:br| br initialize].
	ScriptingSystem deletePrivateGraphics.  "?"
	 
	self cleanUpChanges.
	ChangeSet current clear.
	ChangeSet current name: 'Unnamed'. 
	Smalltalk garbageCollect.
 
	"Reinitialize DataStream; it may hold on to some zapped entitities"
	DataStream initialize. 

	Smalltalk garbageCollect.
	ScheduledControllers := nil.
	Smalltalk garbageCollect.
	
	"SMSqueakMap default purge.  does not work"
	
! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 8/28/2006 23:08'!
installInBoxAnd39
	"self new installInBoxAnd39"
	
	MCWorkingCopy allManagers do: [:each | 
		each  repositoryGroup
			addRepository: (MCHttpRepository new location: 'http://source.squeakfoundation.org/39a');
			addRepository: (MCHttpRepository new location: 'http://source.squeakfoundation.org/inbox')].
	
	! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 7/15/2006 21:02'!
installPreferences

	Preferences initialize.
	"Preferences chooseInitialSettings."
! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 8/28/2006 23:10'!
installRepository: aString for: packageName

	(MCWorkingCopy allManagers select: [:each | each package name = packageName])
		first repositoryGroup
		addRepository: (MCHttpRepository new location: aString)
		! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 7/15/2006 22:43'!
installVersionInfo
	"self new installVersionInfo"

	| highestUpdate newVersion |
	highestUpdate := SystemVersion current highestUpdate.
	(self confirm: 'Reset highest update (' , highestUpdate printString , ')?')
		ifTrue: [SystemVersion current highestUpdate: 0].

	newVersion := FillInTheBlank request: 'New version designation:' initialAnswer: '3.9' , highestUpdate printString. 
	SystemVersion newVersion: newVersion.
	
! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 8/28/2006 23:10'!
installingDefaultRepositoriesToPackages
	"self new installingDefaultRepositoriesToPackages"
	
	self installInBoxAnd39.
	self packagesAndHome do: [:each | 
								self installRepository: each second for: each first].! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 8/29/2006 08:41'!
packagesAndHome

^ #(
('MonticelloConfigurations' 
'http://source.impara.de/mc')
('Balloon' 
'http://source.squeakfoundation.org/Balloon')
('Compression'
'http://source.squeakfoundation.org/Compression')
('Flash'
'http://source.squeakfoundation.org/Balloon')
('Graphics'
'http://source.squeakfoundation.org/Graphics')
('GraphicsTests' 
'http://source.squeakfoundation.org/Graphics')
('ToolBuilder-Kernel'
'http://squeaksource.com/ToolBuilder')
('ToolBuilder-MVC'
'http://squeaksource.com/ToolBuilder')
('ToolBuilder-Morphic'
'http://squeaksource.com/ToolBuilder')
('ToolBuilder-SUnit'
'http://squeaksource.com/ToolBuilder')
('TrueType'
'http://source.squeakfoundation.org/Balloon')
('PackageInfo'
'http://www.squeaksource.com/PackageInfo')
('SMBase'
'http://source.squeakfoundation.org/SqueakMap')
('SMLoader'
'http://source.squeakfoundation.org/SqueakMap')
('Network'
'http://source.squeakfoundation.org/network')
('NetworkTests'
'http://source.squeakfoundation.org/network')
('VersionNumber'
'http://source.squeakfoundation.org/SqueakMap')
('OB-Standard'
'http://source.wiresong.ca/ob/')
('OmniBrowser'
'http://source.wiresong.ca/ob/')
('Monticello'
'http://source.wiresong.ca/mc/')
)
! !

!ScriptLoader methodsFor: 'cleaning' stamp: 'md 7/23/2006 14:06'!
prepareReleaseImage
	"Perform various image cleanups in preparation for making a Squeak gamma release candidate image."
	"self new prepareReleaseImage"
	
	(self confirm: 'Are you sure you want to prepare a release image?
This will perform several irreversible cleanups on this image.')
		ifFalse: [^ self].

	self
		"unloadPackages;"
		initialCleanup;
		installPreferences;
		finalStripping;
		finalCleanup
		"installVersionInfo"
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScriptLoader class
	instanceVariableNames: ''!
SymbolListTile subclass: #ScriptNameTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!ScriptNameTile commentStamp: '<historical>' prior: 0!
A tile which refers to a script name.  The choices available to the user, via the arrows and via the pop-up she gets when she clicks on the current script-name, are the names of all the user scripts in any Players in the active World.!


!ScriptNameTile methodsFor: 'initialization' stamp: 'sw 12/19/2003 23:30'!
choices
	"Answer the current list of choices"

	^ ActiveWorld presenter allKnownUnaryScriptSelectors! !

!ScriptNameTile methodsFor: 'initialization' stamp: 'sw 12/19/2003 23:09'!
dataType: aDataType
	"Initialize the receiver with the given data type"

	dataType _ aDataType.
	literal _ #emptyScript! !


!ScriptNameTile methodsFor: 'user interface' stamp: 'sw 3/9/2004 18:46'!
adjustHelpMessage
	"Adjust the help message to reflect the new literal"

	self labelMorph setBalloonText: 'The name of the script to which this operation applies' translated! !
SymbolListType subclass: #ScriptNameType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Protocols-Type Vocabularies'!
!ScriptNameType commentStamp: '<historical>' prior: 0!
ScriptNameType is a data type representing selectors of user-written scripts.  The choices offered as values for data of this type are all the symbols that are implemented as names of user-written scripts in the current project.!


!ScriptNameType methodsFor: 'initialization' stamp: 'sw 12/3/2001 21:30'!
initialize
	"Initialize the ScriptNameType vocabulary"

	super initialize.
	self vocabularyName: #ScriptName! !


!ScriptNameType methodsFor: 'queries' stamp: 'sw 12/19/2003 23:42'!
choices
	"Answer an alphabetized list of known script selectors in the current project"

	^ ActiveWorld presenter allKnownUnaryScriptSelectors
! !

!ScriptNameType methodsFor: 'queries' stamp: 'mir 7/15/2004 10:35'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^true! !


!ScriptNameType methodsFor: 'tile' stamp: 'sw 12/19/2003 23:07'!
newReadoutTile
	"Answer a tile that can serve as a readout for data of this type"

	^ ScriptNameTile new dataType: self vocabularyName
! !


!ScriptNameType methodsFor: 'tiles' stamp: 'sw 12/19/2003 23:11'!
defaultArgumentTile
	"Answer a tile to represent the type"

	| aTile  |
	aTile _ ScriptNameTile new dataType: self vocabularyName.
	aTile addArrows.
	aTile setLiteral: #emptyScript.
	^ aTile! !
AlignmentMorph subclass: #ScriptStatusControl
	instanceVariableNames: 'tickPauseWrapper tickPauseButtonsShowing scriptInstantiation'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!

!ScriptStatusControl methodsFor: 'access' stamp: 'sw 9/21/2000 10:41'!
scriptInstantiation
	"Answer the scriptInstantiation object with which the receiver is associated"

	^ scriptInstantiation! !

!ScriptStatusControl methodsFor: 'access' stamp: 'ar 3/3/2001 20:32'!
updateStatus
	scriptInstantiation updateStatusMorph: self! !


!ScriptStatusControl methodsFor: 'initialization' stamp: 'dgd 9/21/2003 15:54'!
assurePauseTickControlsShow
	"Add two little buttons that allow the user quickly to toggle between paused and ticking state"

	| colorSelector status |
	self beTransparent.
	(tickPauseWrapper isKindOf: TickIndicatorMorph) ifFalse:[
		"this was an old guy"
		tickPauseWrapper ifNotNil:[tickPauseWrapper delete].
		tickPauseWrapper _ TickIndicatorMorph new.
		tickPauseWrapper on: #mouseDown send: #mouseDownTick:onItem: to: self.
		tickPauseWrapper on: #mouseUp send: #mouseUpTick:onItem: to: self.
		tickPauseWrapper setBalloonText:'Press to toggle ticking state. Hold down to set tick rate.' translated.
		self addMorphFront: tickPauseWrapper.
	].
	status _ scriptInstantiation status.
	colorSelector _ ScriptingSystem statusColorSymbolFor: status.
	tickPauseWrapper color: (Color perform: colorSelector) muchLighter.
	tickPauseWrapper stepTime: (1000 // scriptInstantiation tickingRate max: 0).
	tickPauseWrapper isTicking: status == #ticking.
	tickPauseButtonsShowing _ true.! !

!ScriptStatusControl methodsFor: 'initialization' stamp: 'dgd 11/26/2003 15:02'!
initializeFor: aScriptInstantiation
	"Answer a control that will serve to reflect and allow the user to change the status of the receiver"

	|  statusReadout |
	self hResizing: #shrinkWrap.
	self cellInset: 2@0.
	scriptInstantiation _ aScriptInstantiation.
	tickPauseButtonsShowing _ false.

	self addMorphBack: (statusReadout _ UpdatingSimpleButtonMorph new).
	statusReadout label: aScriptInstantiation status asString font: Preferences standardButtonFont.
	statusReadout setNameTo: 'trigger'.
	statusReadout target: aScriptInstantiation; wordingSelector: #translatedStatus; actionSelector: #presentScriptStatusPopUp.
	statusReadout setBalloonText: 'when this script should run' translated.
	statusReadout actWhen: #buttonDown.

	self assurePauseTickControlsShow.
	aScriptInstantiation updateStatusMorph: self! !

!ScriptStatusControl methodsFor: 'initialization' stamp: 'ar 3/3/2001 20:34'!
intoWorld: aWorld
	super intoWorld: aWorld.
	aWorld ifNotNil:[self updateStatus].! !

!ScriptStatusControl methodsFor: 'initialization' stamp: 'ar 2/12/2001 18:24'!
maybeRemovePauseTickControls
	"If we're in the business of removing pauseTick controls when we're neither paused nor ticking, then do it now.  The present take is not to remove these controls, which explains why the body of this method is currently commented out."
	tickPauseButtonsShowing _ false.
	"note: the following is to change color of the tick control appropriately"
	self assurePauseTickControlsShow.! !


!ScriptStatusControl methodsFor: 'mouse gestures' stamp: 'ar 4/27/2001 11:33'!
mouseDownTick: evt onItem: aMorph
	aMorph color: Color veryLightGray.
	self addAlarm: #offerTickingMenu: with: aMorph after: 1000.! !

!ScriptStatusControl methodsFor: 'mouse gestures' stamp: 'ar 2/11/2001 21:02'!
mouseUpTick: evt onItem: aMorph
	self removeAlarm: #offerTickingMenu:.
	aMorph color: (Color r: 0.767 g: 0.767 b: 1.0).
	(scriptInstantiation status == #ticking) ifTrue:[
		scriptInstantiation status: #paused. 
		aMorph color: (Color r: 1.0 g: 0.774 b: 0.774).
		aMorph isTicking: false.
	] ifFalse:[
		scriptInstantiation status: #ticking. 
		aMorph color: (Color r: 0.767 g: 0.767 b: 1.0).
		aMorph isTicking: true.
	].
	scriptInstantiation updateAllStatusMorphs.! !

!ScriptStatusControl methodsFor: 'mouse gestures' stamp: 'ar 2/12/2001 18:40'!
offerTickingMenu: aMorph
	self assurePauseTickControlsShow. "to set the color"
	^scriptInstantiation presentTickingMenu! !

!ScriptStatusControl methodsFor: 'mouse gestures' stamp: 'sw 9/18/2000 19:42'!
pausedUp: ignored with: alsoIgnored
	"The paused button was hit -- respond to it"

	(scriptInstantiation status == #paused)
		ifFalse:
			[scriptInstantiation status: #paused; updateAllStatusMorphs]
! !

!ScriptStatusControl methodsFor: 'mouse gestures' stamp: 'sw 9/18/2000 19:42'!
tickingUp: ignored with: alsoIgnored
	"The user hit the ticking control; make the status become one of ticking"

	scriptInstantiation status == #ticking
		ifFalse:
			[scriptInstantiation status: #ticking; updateAllStatusMorphs]
! !


!ScriptStatusControl methodsFor: 'script status' stamp: 'sw 9/18/2000 16:55'!
scriptIsPaused
	"Answer whether the script is paused"

	^ scriptInstantiation status == #paused! !

!ScriptStatusControl methodsFor: 'script status' stamp: 'sw 9/18/2000 16:55'!
scriptIsTicking
	"Answer whether the script is ticking"

	^ scriptInstantiation status == #ticking! !
AlignmentMorph subclass: #ScriptStatusLine
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!

!ScriptStatusLine methodsFor: 'event handling' stamp: 'sw 11/13/2001 17:45'!
wantsKeyboardFocusFor: aSubmorph
	"No thanks"

	^ false! !
UpdatingSimpleButtonMorph subclass: #ScriptableButton
	instanceVariableNames: 'scriptSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!ScriptableButton commentStamp: '<historical>' prior: 0!
A button intended for use with the card architecture and the user-scripting system.!


!ScriptableButton methodsFor: 'accessing' stamp: 'sw 10/30/2000 11:02'!
label
	"Answer a string representing the label of the receiver, returning an empty string if necessary"

	| aStringMorph |
	^ (aStringMorph _ self findA: StringMorph)
		ifNil:		['']
		ifNotNil:	[aStringMorph contents]! !

!ScriptableButton methodsFor: 'accessing' stamp: 'sw 10/30/2000 10:59'!
label: aString
	"Set the receiver's label as indicated"

	| aLabel |
	(aLabel _ self findA: StringMorph)
		ifNotNil:
			[aLabel contents: aString]
		ifNil:
			[aLabel _ StringMorph contents: aString font: TextStyle defaultFont.
			self addMorph: aLabel].

	self extent: aLabel extent + (borderWidth + 6).
	aLabel position: self center - (aLabel extent // 2).

	aLabel lock! !

!ScriptableButton methodsFor: 'accessing' stamp: 'tk 9/28/2001 21:09'!
scriptSelector
	^ scriptSelector! !

!ScriptableButton methodsFor: 'accessing' stamp: 'tk 9/28/2001 21:09'!
scriptSelector: aSymbol
	scriptSelector _ aSymbol! !


!ScriptableButton methodsFor: 'button' stamp: 'bf 9/20/2004 11:10'!
doButtonAction
	"The user has pressed the button.  Dispatch to the actual user script, if any."

	scriptSelector ifNil: [^ super doButtonAction].
	self pasteUpMorph player performScriptIfCan: scriptSelector! !


!ScriptableButton methodsFor: 'halos and balloon help' stamp: 'sw 10/10/2000 08:09'!
wantsScriptorHaloHandle
	"Answer whether the receiver would like to have a Scriptor halo handle put up on its behalf.  Initially, only the ScriptableButton says yes"

	^ true! !


!ScriptableButton methodsFor: 'label' stamp: 'yo 11/4/2002 22:13'!
label: aString font: aFontOrNil
	"Set the receiver's label and font as indicated"

	| oldLabel m aFont |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	aFont _ aFontOrNil ifNil: [TextStyle defaultFont].
	m _ StringMorph contents: aString font: aFont.
	self extent: (m width + 6) @ (m height + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock
! !


!ScriptableButton methodsFor: 'menu' stamp: 'sw 10/30/2000 11:02'!
setLabel
	"Invoked from a menu, let the user change the label of the button"

	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Enter a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self label: newLabel font: nil].
! !


!ScriptableButton methodsFor: 'miscellaneous' stamp: 'dgd 9/6/2003 17:37'!
initializeToStandAlone
	super initializeToStandAlone.
	self borderWidth: 1;
		borderColor: Color black;
		useRoundedCorners;
		color: Color yellow;
		label: 'Press me' translated! !


!ScriptableButton methodsFor: 'script' stamp: 'yo 2/10/2005 20:09'!
editButtonsScript
	"The user has touched my Scriptor halo-handle.  Bring up a Scriptor on the script of the button."

	| cardsPasteUp cardsPlayer anEditor |
	cardsPasteUp := self pasteUpMorph.
	(cardsPlayer := cardsPasteUp assuredPlayer) assureUniClass.
	anEditor := scriptSelector ifNil: 
					[scriptSelector := cardsPasteUp scriptSelectorToTriggerFor: self.
					cardsPlayer newTextualScriptorFor: scriptSelector.
					cardsPlayer scriptEditorFor: scriptSelector
					]
				ifNotNil: 
					[(cardsPlayer class selectors includes: scriptSelector) 
						ifTrue: [cardsPlayer scriptEditorFor: scriptSelector]
						ifFalse: 
							["Method somehow got removed; I guess we start afresh"

							scriptSelector := nil.
							^self editButtonsScript]].
	anEditor showingMethodPane ifTrue: [anEditor toggleWhetherShowingTiles].
	self currentHand attachMorph: anEditor! !

!ScriptableButton methodsFor: 'script' stamp: 'yo 2/10/2005 20:04'!
isLikelyRecipientForMouseOverHalos

	self player ifNil: [^ false].
	self player getHeading = 0.0 ifTrue: [^ false].
	^ true.
! !


!ScriptableButton methodsFor: 'thumbnail' stamp: 'sw 10/30/2000 16:07'!
demandsThumbnailing
	"Answer whether the receiver, if in a thumbnailable parts bin, wants to be thumbnailed whether or not size requires it.  This is set to true here because the recent event rework somehow made it possible for a scriptable button to be draggable from a parts bin otherwise, maddeningly"

	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScriptableButton class
	instanceVariableNames: ''!

!ScriptableButton class methodsFor: 'authoring prototype' stamp: 'dgd 9/6/2003 17:38'!
authoringPrototype
	"Answer a scriptable button that can serve as a prototype for a parts bin"

	^ super authoringPrototype
		borderWidth: 1;
		borderColor: Color black;
		useRoundedCorners;
		color: Color yellow;
		label: 'Press me' translated;
		setNameTo: ('script{1}' translated format: {'1'});
		yourself

"ScriptableButton authoringPrototype openInHand"! !


!ScriptableButton class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:56'!
initialize

	self registerInFlapsRegistry.	! !

!ScriptableButton class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:58'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(ScriptableButton		authoringPrototype	'Button' 		'A Scriptable button')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(ScriptableButton		authoringPrototype	'Button' 		'A Scriptable button')
						forFlapNamed: 'Scripting'.
						cl registerQuad: #(ScriptableButton		authoringPrototype		'Scriptable Button'	'A button whose script will be a method of the background Player')
						forFlapNamed: 'Stack Tools'.
						cl registerQuad: #(ScriptableButton		authoringPrototype	'Button' 		'A Scriptable button')
						forFlapNamed: 'Supplies'.]! !

!ScriptableButton class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:40'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!ScriptableButton class methodsFor: 'name' stamp: 'nk 8/23/2004 18:12'!
descriptionForPartsBin
	^ self partName:	'Button'
		categories:		#('Scripting' 'Basic')
		documentation:	'A button to use with tile scripting; its script will be a method of its containing playfield'! !


!ScriptableButton class methodsFor: 'printing' stamp: 'sw 10/30/2000 10:29'!
defaultNameStemForInstances
	"Answer the default name stem to use for instances of the receiver"

	^ 'button'! !


!ScriptableButton class methodsFor: 'scripting' stamp: 'sw 9/26/2001 04:26'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (

			(slot label 'The wording on the button' String readWrite Player getLabel Player setLabel:)
			(slot color 'The color of the object' Color readWrite Player getColor  Player  setColor:)
			(slot height  'The height' Number readWrite Player getHeight  Player  setHeight:) 
			(slot borderColor 'The color of the object''s border' Color readWrite Player getBorderColor Player  setBorderColor:)
			(slot borderWidth 'The width of the object''s border' Number readWrite Player getBorderWidth Player setBorderWidth:)
			(slot  height  'The height' Number readWrite Player getHeight  Player  setHeight:)
			(slot roundedCorners 'Whether corners should be rounded' Boolean readWrite Player getRoundedCorners Player setRoundedCorners:) 
			(slot actWhen 'When the script should fire' ButtonPhase  readWrite Player getActWhen Player setActWhen: ))))! !
Model subclass: #ScriptingDomain
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!

!ScriptingDomain methodsFor: 'user interface' stamp: 'dgd 8/30/2003 21:54'!
addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph 
	super addModelMenuItemsTo: aCustomMenu forMorph: self hand: aHandMorph.  "nominally nothing"
	aCustomMenu add: 'take out of window' translated action: #takeOutOfWindow

	! !

!ScriptingDomain methodsFor: 'user interface' stamp: 'sw 10/27/1999 11:39'!
defaultBackgroundColor
	^ Color r: 0.91 g: 0.91 b: 0.91! !

!ScriptingDomain methodsFor: 'user interface' stamp: 'sw 9/30/1998 13:00'!
initialExtent
	^ 640 @ 480! !
Slider subclass: #ScrollBar
	instanceVariableNames: 'menuButton upButton downButton pagingArea scrollDelta pageDelta interval menuSelector timeOfMouseDown timeOfLastScroll nextPageDirection currentScrollDelay'
	classVariableNames: 'ArrowImagesCache BoxesImagesCache UpArrow UpArrow8Bit'
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ScrollBar commentStamp: '<historical>' prior: 0!
Inspired by an oiginal design of Hans-Martin Mosner, this ScrollBar is intended to exercise the handling of input events in Morphic.  With sufficient flexibility in this area, all particular behavior can be concentrated in this single class with no need to specialize any other morphs to achieve button, slider and menu-button behavior.

Once we have this working, put in logic for horizontal operation as well.

CachedImages was added to reduce the number of forms created and thrown away. This will be helpful for Nebraska and others as well.!


!ScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 16:27'!
adoptPaneColor: aColor
	"Adopt the given pane color"
	aColor ifNil:[^self].
	self sliderColor: aColor.! !

!ScrollBar methodsFor: 'access' stamp: 'dew 2/21/1999 03:08'!
interval: d
	"Supply an optional floating fraction so slider can expand to indicate range"
	interval _ d min: 1.0.
	self expandSlider.
	self computeSlider.! !

!ScrollBar methodsFor: 'access' stamp: 'dew 2/15/1999 18:25'!
pagingArea
	^pagingArea! !

!ScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 21:26'!
roundedScrollbarLook
	"Rounded look currently only shows up in flop-out mode"
	^false and: [
		self class alwaysShowFlatScrollbarForAlternativeLook not]
! !

!ScrollBar methodsFor: 'access'!
scrollDelta
	^ scrollDelta! !

!ScrollBar methodsFor: 'access'!
scrollDelta: d1 pageDelta: d2
	"Supply optional increments for better scrolling of, eg, text"
	scrollDelta _ d1.
	pageDelta _ d2.! !

!ScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 16:25'!
sliderColor: aColor 
	"Change the color of the scrollbar to go with aColor."
	| buttonColor |
	super sliderColor: aColor.
	buttonColor := self thumbColor.
	menuButton
		ifNotNil: [menuButton color: buttonColor].
	upButton color: buttonColor.
	downButton color: buttonColor.
	slider color: buttonColor slightlyLighter.
	
	self class updateScrollBarButtonsAspect: {menuButton. upButton. downButton} color: buttonColor.
	
	self updateMenuButtonImage.
	self updateUpButtonImage.
	self updateDownButtonImage.
	
	self roundedScrollbarLook
				ifTrue: [
					self color: Color transparent.
					pagingArea color: aColor muchLighter.
					self borderStyle style == #simple
						ifTrue: [self borderColor: aColor darker darker]
						ifFalse: [self borderStyle baseColor: aColor]]
				ifFalse: [
					pagingArea
						color: (aColor alphaMixed: 0.3 with: Color white).
					self borderWidth: 0]! !

!ScrollBar methodsFor: 'access' stamp: 'dew 3/4/2002 01:17'!
sliderShadowColor
	^ self roundedScrollbarLook
		ifTrue: [self sliderColor darker]
		ifFalse: [super sliderShadowColor]
! !

!ScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 16:26'!
thumbColor
	"Problem: Part of the ScrollBar/Slider code uses 'slider' to mean the entire scrollbar/slider widget, and part of it uses 'slider' to mean only the draggable 'thumb'.  This should be cleaned up so that 'thumb' is used instead of 'slider' where appropriate.  For now, the meaning of thumbColor is clear, at least."

	^ self sliderColor alphaMixed: 0.5 with: (Color gray: 0.95)
! !


!ScrollBar methodsFor: 'geometry' stamp: 'dew 7/16/2004 19:33'!
buttonExtent
	| size |
	size := Preferences scrollBarsNarrow
				ifTrue: [11]
				ifFalse: [15].
	^ bounds isWide
		ifTrue: [size @ self innerBounds height]
		ifFalse: [self innerBounds width @ size]! !

!ScrollBar methodsFor: 'geometry' stamp: 'dew 2/27/1999 18:22'!
expandSlider
	"Compute the new size of the slider (use the old sliderThickness as a minimum)."
	| r |
	r _ self totalSliderArea.
	slider extent: (bounds isWide
		ifTrue: [((r width * interval) asInteger max: self sliderThickness) @ slider height]
		ifFalse: [slider width @ ((r height * interval) asInteger max: self sliderThickness)])! !

!ScrollBar methodsFor: 'geometry' stamp: 'dgd 3/26/2003 09:13'!
extent: p 
	p x > p y
		ifTrue: [super
				extent: (p max: 42 @ 8)]
		ifFalse: [super
				extent: (p max: 8 @ 42)].
	! !

!ScrollBar methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'!
sliderExtent
	"The sliderExtent is now stored in the slider itself, not hardcoded as it is in the superclass."
	^slider extent! !

!ScrollBar methodsFor: 'geometry' stamp: 'dew 3/4/2002 01:18'!
sliderThickness
	^ self roundedScrollbarLook ifTrue:[15] ifFalse:[super sliderThickness]! !

!ScrollBar methodsFor: 'geometry' stamp: 'hpt 4/3/2003 19:18'!
totalSliderArea
	| upperBoundsButton |
	upperBoundsButton _ menuButton ifNil: [upButton].
	bounds isWide
		ifTrue: [
			upButton right > upperBoundsButton right
				ifTrue: [upperBoundsButton _ upButton].
			^upperBoundsButton bounds topRight corner: downButton bounds bottomLeft]
		ifFalse:[
			upButton bottom > upperBoundsButton bottom
				ifTrue: [upperBoundsButton _ upButton].
			^upperBoundsButton bounds bottomLeft corner: downButton bounds topRight].
! !


!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:13'!
downImage
	"answer a form to be used in the down button"
	^ self class
		arrowOfDirection: (bounds isWide
				ifTrue: [#right]
				ifFalse: [#bottom])
		size: (self buttonExtent x min: self buttonExtent y)
		color: self thumbColor! !

!ScrollBar methodsFor: 'initialize' stamp: 'dew 3/4/2002 01:11'!
initialize
	super initialize.
	scrollDelta _ 0.02.
	pageDelta _ 0.2.
	self roundedScrollbarLook ifTrue:[
		self borderStyle: ((BorderStyle complexFramed width: 2) "baseColor: Color gray")].! !

!ScrollBar methodsFor: 'initialize' stamp: 'jrp 8/3/2005 09:55'!
initializeDownButton
	"initialize the receiver's downButton"

	downButton _ RectangleMorph 
				newBounds: (self innerBounds bottomRight - self buttonExtent 
						extent: self buttonExtent)
				color: self thumbColor.
	downButton 
		on: #mouseDown
		send: #scrollDownInit
		to: self.
	downButton 
		on: #mouseUp
		send: #finishedScrolling
		to: self.
	self updateDownButtonImage.
	self roundedScrollbarLook 
		ifTrue: 
			[downButton color: Color veryLightGray.
			downButton borderStyle: (BorderStyle complexRaised width: 3)]
		ifFalse: [downButton setBorderWidth: 1 borderColor: Color lightGray].
	self addMorph: downButton! !

!ScrollBar methodsFor: 'initialize' stamp: 'dew 3/4/2002 01:13'!
initializeEmbedded: aBool
	"aBool == true => inboard scrollbar
	aBool == false => flop-out scrollbar"
	self roundedScrollbarLook ifFalse:[^self].
	aBool ifTrue:[
		self borderStyle: (BorderStyle inset width: 2).
		self cornerStyle: #square.
	] ifFalse:[
		self borderStyle: (BorderStyle width: 1 color: Color black).
		self cornerStyle: #rounded.
	].
	self removeAllMorphs.
	self initializeSlider.! !

!ScrollBar methodsFor: 'initialize' stamp: 'jrp 8/3/2005 10:17'!
initializeMenuButton
"initialize the receiver's menuButton"
	"Preferences disable: #scrollBarsWithoutMenuButton"
	"Preferences enable: #scrollBarsWithoutMenuButton"
	(Preferences valueOfFlag: #scrollBarsWithoutMenuButton)
		ifTrue: [^ self].
	menuButton _ self roundedScrollbarLook
		ifTrue: [RectangleMorph
					newBounds: ((bounds isWide
							ifTrue: [upButton bounds topRight]
							ifFalse: [upButton bounds bottomLeft])
							extent: self buttonExtent)]
		ifFalse: [RectangleMorph
					newBounds: (self innerBounds topLeft extent: self buttonExtent)
					color: self thumbColor].
	menuButton
		on: #mouseEnter
		send: #menuButtonMouseEnter:
		to: self.
	menuButton
		on: #mouseDown
		send: #menuButtonMouseDown:
		to: self.
	menuButton
		on: #mouseLeave
		send: #menuButtonMouseLeave:
		to: self.
	"menuButton 
	addMorphCentered: (RectangleMorph 
	newBounds: (0 @ 0 extent: 4 @ 2) 
	color: Color black)."
	self updateMenuButtonImage.
	self roundedScrollbarLook
		ifTrue: [menuButton color: Color veryLightGray.
			menuButton
				borderStyle: (BorderStyle complexRaised width: 3)]
		ifFalse: [menuButton setBorderWidth: 1 borderColor: Color lightGray].
	self addMorph: menuButton! !

!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:44'!
initializePagingArea
"initialize the receiver's pagingArea"
	pagingArea := RectangleMorph
				newBounds: self totalSliderArea
				color: (Color
						r: 0.6
						g: 0.6
						b: 0.8).
	pagingArea borderWidth: 0.
	pagingArea
		on: #mouseDown
		send: #scrollPageInit:
		to: self.
	pagingArea
		on: #mouseUp
		send: #finishedScrolling
		to: self.
	self addMorph: pagingArea.
	self roundedScrollbarLook
		ifTrue: [pagingArea
				color: (Color gray: 0.9)]! !

!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:44'!
initializeSlider
"initialize the receiver's slider"
	self roundedScrollbarLook
		ifTrue: [self initializeUpButton; initializeMenuButton; initializeDownButton; initializePagingArea]
		ifFalse: [self initializeMenuButton; initializeUpButton; initializeDownButton; initializePagingArea].
	super initializeSlider.
	self roundedScrollbarLook
		ifTrue: [slider cornerStyle: #rounded.
			slider
				borderStyle: (BorderStyle complexRaised width: 3).
			sliderShadow cornerStyle: #rounded].
	self sliderColor: self sliderColor! !

!ScrollBar methodsFor: 'initialize' stamp: 'jrp 8/3/2005 09:57'!
initializeUpButton
"initialize the receiver's upButton"
	upButton _ self roundedScrollbarLook
		ifTrue: [RectangleMorph
						newBounds: (self innerBounds topLeft extent: self buttonExtent)]
		ifFalse: [RectangleMorph
						newBounds: ((menuButton
								ifNil: [self innerBounds topLeft]
								ifNotNil: [bounds isWide
										ifTrue: [menuButton bounds topRight]
										ifFalse: [menuButton bounds bottomLeft]])
								extent: self buttonExtent)].
	upButton color: self thumbColor.
	upButton
		on: #mouseDown
		send: #scrollUpInit
		to: self.
	upButton
		on: #mouseUp
		send: #finishedScrolling
		to: self.
	self updateUpButtonImage.
	self roundedScrollbarLook
		ifTrue: [upButton color: Color veryLightGray.
			upButton
				borderStyle: (BorderStyle complexRaised width: 3)]
		ifFalse: [upButton setBorderWidth: 1 borderColor: Color lightGray].
	self addMorph: upButton! !

!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:13'!
menuImage
	"answer a form to be used in the menu button"
	^ self class
		boxOfSize: (self buttonExtent x min: self buttonExtent y)
		color: self thumbColor! !

!ScrollBar methodsFor: 'initialize' stamp: 'RAA 7/28/2000 10:12'!
upArrow8Bit

	"convert to 8-bit and convert white to transparent to avoid gratuitous conversion every time we put one in an ImageMorph"

	^UpArrow8Bit ifNil: [
		UpArrow8Bit _ (ColorForm mappingWhiteToTransparentFrom: UpArrow) asFormOfDepth: 8
	]! !

!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:13'!
upImage
	"answer a form to be used in the up button"
	^ self class
		arrowOfDirection: (bounds isWide
				ifTrue: [#left]
				ifFalse: [#top])
		size: (self buttonExtent x min: self buttonExtent y)
		color: self thumbColor! !

!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 10:24'!
updateDownButtonImage
	"update the receiver's downButton.  put a new image inside"
	downButton removeAllMorphs.
	downButton
		addMorphCentered: (ImageMorph new image: self downImage)! !

!ScrollBar methodsFor: 'initialize' stamp: 'sd 11/8/2003 16:01'!
updateMenuButtonImage
	"update the receiver's menuButton. put a new image inside"
menuButton isNil ifTrue:[^ self].

	menuButton removeAllMorphs.
	menuButton
		addMorphCentered: (ImageMorph new image: self menuImage)! !

!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:13'!
updateUpButtonImage
"update the receiver's upButton. put a new image inside"
	upButton removeAllMorphs.
	upButton
		addMorphCentered: (ImageMorph new image: self upImage)! !


!ScrollBar methodsFor: 'model access' stamp: 'dew 2/21/1999 03:08'!
setValue: newValue
	"Using roundTo: instead of truncateTo: ensures that scrollUp will scroll the same distance as scrollDown."
	^ super setValue: (newValue roundTo: scrollDelta)! !


!ScrollBar methodsFor: 'other events'!
menuButtonMouseDown: event
	event hand showTemporaryCursor: nil.
	self use: menuSelector orMakeModelSelectorFor: 'MenuButtonPressed:'
		in: [:sel | menuSelector _ sel.  model perform: sel with: event]! !

!ScrollBar methodsFor: 'other events' stamp: 'sps 3/10/2004 10:14'!
mouseDownInSlider: event
	interval = 1.0 ifTrue:
		["make the entire scrollable area visible if a full scrollbar is clicked on"
		self setValue: 0.
		self model hideOrShowScrollBars.].
	super mouseDownInSlider: event
! !


!ScrollBar methodsFor: 'scroll timing' stamp: 'di 8/17/1998 09:22'!
resetTimer
	timeOfMouseDown _ Time millisecondClockValue.
	timeOfLastScroll _ timeOfMouseDown - 1000 max: 0.
	nextPageDirection _ nil.
	currentScrollDelay _ nil! !

!ScrollBar methodsFor: 'scroll timing' stamp: 'dgd 2/21/2003 23:05'!
waitForDelay1: delay1 delay2: delay2 
	"Return true if an appropriate delay has passed since the last scroll operation.
	The delay decreases exponentially from delay1 to delay2."

	| now scrollDelay |
	timeOfLastScroll isNil ifTrue: [self resetTimer].	"Only needed for old instances"
	now := Time millisecondClockValue.
	(scrollDelay := currentScrollDelay) isNil 
		ifTrue: [scrollDelay := delay1	"initial delay"].
	currentScrollDelay := scrollDelay * 9 // 10 max: delay2.	"decrease the delay"
	timeOfLastScroll := now.
	^true! !


!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:13'!
doScrollByPage
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 300 delay2: 100) ifFalse: [^ self].
	nextPageDirection
		ifTrue: [self setValue: (value + pageDelta min: 1.0)]
		ifFalse: [self setValue: (value - pageDelta max: 0.0)]
! !

!ScrollBar methodsFor: 'scrolling' stamp: 'di 4/22/2001 18:28'!
doScrollDown
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 200 delay2: 40) ifFalse: [^ self].
	self setValue: (value + scrollDelta + 0.000001 min: 1.0)! !

!ScrollBar methodsFor: 'scrolling' stamp: 'di 4/22/2001 18:28'!
doScrollUp
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 200 delay2: 40) ifFalse: [^ self].
	self setValue: (value - scrollDelta - 0.000001 max: 0.0)! !

!ScrollBar methodsFor: 'scrolling' stamp: 'jrp 8/3/2005 10:20'!
finishedScrolling
	self stopStepping.
	self scrollBarAction: nil.
	self roundedScrollbarLook ifTrue:[
		upButton borderStyle: (BorderStyle complexRaised width: upButton borderWidth).
		downButton borderStyle: (BorderStyle complexRaised width: downButton borderWidth).
	] ifFalse:[
		downButton borderStyle: BorderStyle thinGray.
		upButton borderStyle: BorderStyle thinGray.
	].

! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 14:56'!
scrollBarAction
	^self valueOfProperty: #scrollBarAction! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 14:56'!
scrollBarAction: aSymbol
	self setProperty: #scrollBarAction toValue: aSymbol! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:12'!
scrollDown
	self flag: #obsolete.
	downButton eventHandler: nil.
	downButton on: #mouseDown send: #scrollDownInit to: self.
	downButton on: #mouseUp send: #finishedScrolling to: self.
	^self scrollDownInit! !

!ScrollBar methodsFor: 'scrolling' stamp: 'bf 4/14/1999 12:03'!
scrollDown: count
	self setValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:05'!
scrollDownInit
	downButton borderInset.
	self resetTimer.
	self scrollBarAction: #doScrollDown.
	self startStepping.! !

!ScrollBar methodsFor: 'scrolling' stamp: 'RAA 12/29/2000 11:56'!
scrollPageInit: evt
	self resetTimer.
	self setNextDirectionFromEvent: evt.
	self scrollBarAction: #doScrollByPage.
	self startStepping.! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:11'!
scrollUp
	self flag: #obsolete.
	upButton eventHandler: nil.
	upButton on: #mouseDown send: #scrollUpInit to: self.
	upButton on: #mouseUp send: #finishedScrolling to: self.
	^self scrollUpInit! !

!ScrollBar methodsFor: 'scrolling' stamp: 'bf 4/14/1999 12:03'!
scrollUp: count
	self setValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:05'!
scrollUpInit
	upButton borderInset.
	self resetTimer.
	self scrollBarAction: #doScrollUp.
	self startStepping.! !

!ScrollBar methodsFor: 'scrolling' stamp: 'RAA 12/29/2000 11:56'!
setNextDirectionFromEvent: event

	nextPageDirection _ bounds isWide ifTrue: [
		event cursorPoint x >= slider center x
	]
	ifFalse: [
		event cursorPoint y >= slider center y
	]

! !


!ScrollBar methodsFor: 'stepping and presenter' stamp: 'ar 10/7/2000 15:02'!
step
	| action |
	action _ self scrollBarAction.
	action ifNotNil:[self perform: action].! !


!ScrollBar methodsFor: 'testing' stamp: 'di 4/22/2001 18:30'!
stepTime
	^ currentScrollDelay ifNil: [300]! !

!ScrollBar methodsFor: 'testing' stamp: 'ar 10/7/2000 15:02'!
wantsSteps
	^self scrollBarAction notNil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScrollBar class
	instanceVariableNames: ''!

!ScrollBar class methodsFor: 'as yet unclassified' stamp: 'dew 3/23/2002 01:30'!
alwaysShowFlatScrollbarForAlternativeLook
	"Set this value to true, if you want to see the flat scrollbar look in flop-out mode as well as inboard.  Otherwise the flop-out scrollbar will be rounded and inboard will be flat."
	^ false! !


!ScrollBar class methodsFor: 'class initialization' stamp: 'dgd 3/28/2003 10:13'!
createArrowImagesCache
	"creates the cache to store the arrow forms"
	^ LRUCache
		size: 40
		factory: [:key | ""
			self
				createArrowOfDirection: key first
				size: key second
				color: key third]! !

!ScrollBar class methodsFor: 'class initialization' stamp: 'dgd 3/28/2003 10:13'!
createBoxImagesCache
	"creates the cache to store the arrow forms"
	^ LRUCache
		size: 20
		factory: [:key | self createBoxOfSize: key first color: key second]! !

!ScrollBar class methodsFor: 'class initialization' stamp: 'dgd 3/27/2003 10:05'!
initialize
	"ScrollBar initialize"
	UpArrow := Form
				extent: 6 @ 3
				fromArray: #(805306368 2013265920 4227858432 )
				offset: 0 @ 0.
	""
	self initializeImagesCache! !

!ScrollBar class methodsFor: 'class initialization' stamp: 'md 3/23/2006 15:55'!
initializeImagesCache
	"initialize the receiver's ImagesCache. 
	 
	normally this method is not evaluated more than in the class 
	initializazion. "

	" 
	ScrollBar initializeImagesCache.
	"

	ArrowImagesCache := self createArrowImagesCache.
	BoxesImagesCache := self createBoxImagesCache! !


!ScrollBar class methodsFor: 'coloring morphs' stamp: 'dgd 3/28/2003 20:29'!
updateScrollBarButtonAspect: aMorph color: aColor 
	"update aMorph with aColor"
	| fill direction |
	aMorph isNil
		ifTrue: [^ self].
	""
aMorph color: aColor.
	Preferences gradientScrollBars
		ifFalse: [^ self].
	""
	fill := GradientFillStyle ramp: {0.0 -> aColor twiceLighter twiceLighter. 1.0 -> aColor twiceDarker}.
	""
	direction := ((aMorph width min: aMorph height)
				+ ((aMorph width - aMorph height) abs * 0.3)) rounded.
	""
	fill origin: aMorph topLeft + (direction // 8).
	fill direction: direction @ direction.
	fill radial: true.
	""
	aMorph fillStyle: fill! !

!ScrollBar class methodsFor: 'coloring morphs' stamp: 'dgd 3/28/2003 20:29'!
updateScrollBarButtonsAspect: aCollection color: aColor 
	"update aCollection of morphs with aColor"
	
	
	aCollection
		do: [:each | self updateScrollBarButtonAspect: each color: aColor]! !


!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 10:22'!
arrowOfDirection: aSymbol size: finalSizeInteger color: aColor 
	"answer a form with an arrow based on the parameters"
	^ ArrowImagesCache at: {aSymbol. finalSizeInteger. aColor}! !

!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 10:22'!
boxOfSize: finalSizeInteger color: aColor 
	"answer a form with an box based on the parameters"
	^ BoxesImagesCache at: {finalSizeInteger. aColor}! !

!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 20:54'!
changesInPreferences
	"the related preferences changed"
	self initializeImagesCache
	" ScrollBar allInstances do: [:each | each removeAllMorphs; initializeSlider] "! !

!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 20:43'!
createArrowOfDirection: aSymbol in: aRectangle 
	"PRIVATE - create an arrow bounded in aRectangle"

	| arrow vertices |
	vertices := Preferences alternativeButtonsInScrollBars 
				ifTrue: [self verticesForComplexArrow: aRectangle]
				ifFalse: [self verticesForSimpleArrow: aRectangle].
	""
	arrow := PolygonMorph 
				vertices: vertices
				color: Color transparent
				borderWidth: 0
				borderColor: Color black.
	""
	arrow bounds: (arrow bounds insetBy: (aRectangle width / 6) rounded).
	""
	Preferences alternativeButtonsInScrollBars 
		ifTrue: [arrow rotationDegrees: 45].
	""
	aSymbol == #right 
		ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 90].
	aSymbol == #bottom 
		ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 180].
	aSymbol == #left 
		ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 270].
	""
	^arrow! !

!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 19:32'!
createArrowOfDirection: aSymbolDirection size: finalSizeInteger color: aColor 
	"PRIVATE - create an arrow with aSymbolDirectionDirection,  
	finalSizeInteger and aColor  
	 
	aSymbolDirectionDirection = #top, #bottom. #left or #right  
	 
	Try with:  
	(ScrollBar createArrowOfDirection: #top size: 32 color: Color  
	lightGreen) asMorph openInHand.  
	"
	| resizeFactor outerBox arrow resizedForm |
	resizeFactor := 4.
	outerBox := RectangleMorph new.
	outerBox extent: finalSizeInteger asPoint * resizeFactor;
		 borderWidth: 0;
		 color: aColor.
	""
	arrow := self createArrowOfDirection: aSymbolDirection in: outerBox bounds.
	self updateScrollBarButtonAspect: arrow color: aColor muchDarker.
	outerBox addMorphCentered: arrow.
	""
	resizedForm := outerBox imageForm
				magnify: outerBox imageForm boundingBox
				by: 1 / resizeFactor
				smoothing: 4.
	""
	^ (resizedForm replaceColor: aColor withColor: Color transparent)
		trimBordersOfColor: Color transparent! !

!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 10:29'!
createBoxIn: aRectangle 
	"PRIVATE - create an box bounded in aRectangle"
	| box |
	box := RectangleMorph new.
	box extent: (aRectangle scaleBy: 1 / 2) extent rounded;
		 borderWidth: 0.
	""
	^ box! !

!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 19:32'!
createBoxOfSize: finalSizeInteger color: aColor 
	"PRIVATE - create a box with finalSizeInteger and aColor  
	 
	Try with:  
	(ScrollBar createBoxOfSize: 32 color: Color lightGreen) asMorph  
	openInHand.  
	"
	| resizeFactor outerBox innerBox resizedForm |
	resizeFactor := 4.
	outerBox := RectangleMorph new.
	outerBox extent: finalSizeInteger asPoint * resizeFactor;
		 borderWidth: 0;
		 color: aColor.
	""
	innerBox := self createBoxIn: outerBox bounds.
	self updateScrollBarButtonAspect: innerBox color: aColor muchDarker.
	outerBox addMorphCentered: innerBox.
	""
	resizedForm := outerBox imageForm
				magnify: outerBox imageForm boundingBox
				by: 1 / resizeFactor
				smoothing: 4.
	""
	^ (resizedForm replaceColor: aColor withColor: Color transparent)
		trimBordersOfColor: Color transparent! !

!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 10:21'!
verticesForComplexArrow: aRectangle 
	"PRIVATE - answer a collection of vertices to draw a complex arrow"
	| vertices aux |
	vertices := OrderedCollection new.
	""
	vertices add: aRectangle bottomLeft.
	vertices add: aRectangle topLeft.
	vertices add: aRectangle topRight.
	""
	aux := (aRectangle width / 3) rounded.
	vertices add: aRectangle topRight + (0 @ aux).
	vertices add: aRectangle topLeft + aux.
	vertices add: aRectangle bottomLeft + (aux @ 0).
	""
	^ vertices! !

!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 10:21'!
verticesForSimpleArrow: aRectangle 
	"PRIVATE - answer a collection of vertices to draw a simple arrow"
	| vertices |
	vertices := OrderedCollection new.
	""
	vertices add: aRectangle bottomLeft.
	vertices add: aRectangle center x @ (aRectangle top + (aRectangle width / 8)).
	vertices add: aRectangle bottomRight.
	""
	^ vertices! !


!ScrollBar class methodsFor: 'images - samples' stamp: 'sd 11/8/2003 16:02'!
arrowSamples
	"create a set of arrow with different sizes, colors and directions"
	" 
	ScrollBar arrowSamples.  
	"
	| column |
	column := AlignmentMorph newColumn vResizing: #shrinkWrap;
				 hResizing: #shrinkWrap;
				 layoutInset: 1;
				 borderColor: Color black;
				 borderWidth: 0;
				 wrapCentering: #center;
				 cellPositioning: #center;
				 color: Color white;
				 yourself.
	
	self sampleSizes
		do: [:size | 
			| row | 
			row := AlignmentMorph newRow color: Color transparent;
						 vResizing: #shrinkWrap;
						 cellInset: 2 @ 0 yourself.
			
			self sampleColors
				do: [:color | 
					#(#top #right #bottom #left )
						do: [:direction | 
							row addMorphBack: (ScrollBar
									arrowOfDirection: direction
									size: size
									color: color) asMorph]].
			
			column addMorphBack: row].
	
	column openInHand! !

!ScrollBar class methodsFor: 'images - samples' stamp: 'dgd 3/28/2003 10:18'!
boxSamples
	"create a set of box with different sizes and colors"
	" 
	ScrollBar boxSamples.  
	"
	| column |
	column := AlignmentMorph newColumn vResizing: #shrinkWrap;
				 hResizing: #shrinkWrap;
				 layoutInset: 1;
				 borderColor: Color black;
				 borderWidth: 0;
				 wrapCentering: #center;
				 cellPositioning: #center;
				 color: Color white;
				 yourself.
	""
	self sampleSizes
		do: [:size | 
			| row | 
			row := AlignmentMorph newRow color: Color transparent;
						 vResizing: #shrinkWrap;
						 cellInset: 2 @ 0 yourself.
			""
			self sampleColors
				do: [:color | 
					row addMorphBack: (ScrollBar boxOfSize: size color: color) asMorph].
			""
			column addMorphBack: row].
	""
	""
	column openInHand! !

!ScrollBar class methodsFor: 'images - samples' stamp: 'dgd 3/28/2003 10:18'!
sampleColors
	"private"
	^ (Color lightCyan wheel: 5)! !

!ScrollBar class methodsFor: 'images - samples' stamp: 'dgd 3/28/2003 10:17'!
sampleSizes
	
"private"
	^ #(10 12 14 16 18 32 64 )! !
MouseMenuController subclass: #ScrollController
	instanceVariableNames: 'scrollBar marker savedArea menuBar savedMenuBarArea'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Kernel-Remnants'!
!ScrollController commentStamp: '<historical>' prior: 0!
I represent control for scrolling using a scrollBar. I am a MouseMenuController that creates a scrollBar, rather than menus. My subclasses add the button menus. I keep control as long as the cursor is inside the view or the scrollBar area.
	
A scrollBar is a rectangular area representing the length of the information being viewed. It contains an inner rectangle whose top y-coordinate represents the relative position of the information visible on the screen with respect to all of the information, and whose size represents the relative amount of that information visible on the screen. The user controls which part of the information is visible by pressing the red button. If the cursor is to the right of the inner rectangle, the window onto the visible information moves upward, if the cursor is to the left, the window moves downward, and if the cursor is inside, the inner rectangle is grabbed and moved to a desired position.!


!ScrollController methodsFor: 'basic control sequence'!
controlInitialize
	"Recompute scroll bars.  Save underlying image unless it is already saved."
	| |
	super controlInitialize.
	scrollBar region: (0 @ 0 extent: 24 @ view apparentDisplayBox height).
	scrollBar insideColor: view backgroundColor.
	marker region: self computeMarkerRegion.
	scrollBar _ scrollBar align: scrollBar topRight with: view apparentDisplayBox topLeft.
	marker _ marker align: marker topCenter with: self upDownLine @ (scrollBar top + 2).
	savedArea isNil ifTrue: [savedArea _ Form fromDisplay: scrollBar].
	scrollBar displayOn: Display.

	"Show a border around yellow-button (menu) region"
"
	yellowBar _ Rectangle left: self yellowLine right: scrollBar right + 1
		top: scrollBar top bottom: scrollBar bottom.
	Display border: yellowBar width: 1 mask: Form veryLightGray.
"
	self moveMarker
! !

!ScrollController methodsFor: 'basic control sequence'!
controlTerminate

	super controlTerminate.
	savedArea notNil 	
		ifTrue: 
			[savedArea displayOn: Display at: scrollBar topLeft.
			savedArea _ nil].! !


!ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:17'!
controlActivity
	self scrollByKeyboard ifTrue: [^ self].
	self scrollBarContainsCursor
		ifTrue: [self scroll]
		ifFalse: [self normalActivity]! !

!ScrollController methodsFor: 'control defaults' stamp: 'ar 3/24/2000 00:45'!
isControlActive 
	super isControlActive ifTrue: [^ true].
	sensor blueButtonPressed ifTrue: [^ false].
	^ (scrollBar inside merge: view insetDisplayBox) containsPoint: sensor cursorPoint! !

!ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:31'!
isControlWanted
	^ self viewHasCursor! !

!ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:16'!
normalActivity
	super controlActivity! !


!ScrollController methodsFor: 'cursor'!
changeCursor: aCursor 
	"The current cursor should be set to be aCursor."

	sensor currentCursor ~~ aCursor ifTrue: [aCursor show]! !

!ScrollController methodsFor: 'cursor'!
markerContainsCursor
	"Answer whether the gray area inside the scroll bar area contains the 
	cursor."

	^marker inside containsPoint: sensor cursorPoint! !

!ScrollController methodsFor: 'cursor'!
menuBarContainsCursor
	"Answer whether the cursor is anywhere within the menu bar area."

	^ menuBar notNil and:
			[menuBar containsPoint: sensor cursorPoint]! !

!ScrollController methodsFor: 'cursor'!
scrollBarContainsCursor
	"Answer whether the cursor is anywhere within the scroll bar area."

	^scrollBar containsPoint: sensor cursorPoint! !


!ScrollController methodsFor: 'initialize-release'!
initialize
	super initialize.
	scrollBar _ Quadrangle new.
	scrollBar borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	marker _ Quadrangle new.
	marker insideColor: Preferences scrollBarColor.
	menuBar _ Quadrangle new.
	menuBar borderWidthLeft:  2 right: 0 top: 2 bottom: 2.! !


!ScrollController methodsFor: 'marker adjustment'!
computeMarkerRegion
	"Answer the rectangular area in which the gray area of the scroll bar 
	should be displayed."

	^0@0 extent: Preferences scrollBarWidth @
			((view window height asFloat /
						view boundingBox height *
							scrollBar inside height)
				 rounded min: scrollBar inside height)! !

!ScrollController methodsFor: 'marker adjustment'!
markerDelta
	^ marker top 
		- scrollBar inside top  
		- ((view window top - view boundingBox top) asFloat 
			/ view boundingBox height asFloat *
				scrollBar inside height asFloat) rounded! !

!ScrollController methodsFor: 'marker adjustment'!
markerRegion: aRectangle 
	"Set the area defined by aRectangle as the marker. Fill it with gray tone."

	Display fill: marker fillColor: scrollBar insideColor.
	marker region: aRectangle.
	marker _ marker align: marker topCenter 
			with: self upDownLine @ (scrollBar top + 2) ! !

!ScrollController methodsFor: 'marker adjustment'!
moveMarker
	"The view window has changed. Update the marker."

	self moveMarker: self markerDelta negated anchorMarker: nil! !

!ScrollController methodsFor: 'marker adjustment'!
moveMarker: anInteger anchorMarker: anchorMarker
	"Update the marker so that is is translated by an amount corresponding to 
	a distance of anInteger, constrained within the boundaries of the scroll 
	bar.  If anchorMarker ~= nil, display the border around the area where the
	marker first went down."

	Display fill: marker fillColor: scrollBar insideColor.
	anchorMarker = nil
		ifFalse: [Display border: anchorMarker width: 1 fillColor: Color gray].
	marker _ marker translateBy: 0 @
				((anInteger min: scrollBar inside bottom - marker bottom) max:
					scrollBar inside top - marker top).
	marker displayOn: Display! !

!ScrollController methodsFor: 'marker adjustment'!
moveMarkerTo: aRectangle 
	"Same as markerRegion: aRectangle; moveMarker, except a no-op if the marker
	 would not move."

	(aRectangle height = marker height and: [self viewDelta = 0]) ifFalse:
		[self markerRegion: aRectangle.
		self moveMarker]! !


!ScrollController methodsFor: 'scrolling'!
anyButtonActivity
	"deal with red button down in scrollBar beyond yellowLine"

	self yellowButtonActivity! !

!ScrollController methodsFor: 'scrolling'!
downLine
	"if cursor before downLine, display down cursor and scroll down on button down"

	^scrollBar left + 6 ! !

!ScrollController methodsFor: 'scrolling' stamp: 'ls 7/11/1998 06:33'!
scroll
	"Check to see whether the user wishes to jump, scroll up, or scroll down."
	| savedCursor |
	savedCursor _ sensor currentCursor.
			[self scrollBarContainsCursor]
				whileTrue: 
					[self interActivityPause.
					sensor cursorPoint x <= self downLine
								ifTrue: [self scrollDown]
								ifFalse: [sensor cursorPoint x <= self upLine
										ifTrue: [self scrollAbsolute]
										ifFalse: [sensor cursorPoint x <= self yellowLine
												ifTrue: [self scrollUp]
												ifFalse: [sensor cursorPoint x <= scrollBar right
														ifTrue: "Might not be, with touch pen"
														[self changeCursor: Cursor menu.
														sensor anyButtonPressed 
														ifTrue: [self changeCursor: savedCursor. 
																self anyButtonActivity]]]]]].
	savedCursor show! !

!ScrollController methodsFor: 'scrolling'!
scrollAmount
	"Answer the number of bits of y-coordinate should be scrolled. This is a 
	default determination based on the view's preset display transformation."

	^((view inverseDisplayTransform: sensor cursorPoint)
		- (view inverseDisplayTransform: scrollBar inside topCenter)) y! !

!ScrollController methodsFor: 'scrolling' stamp: 'th 12/11/1999 16:57'!
scrollByKeyboard
	| keyEvent |
	keyEvent _ sensor keyboardPeek.
	keyEvent ifNil: [^ false].
	(sensor controlKeyPressed or:[sensor commandKeyPressed]) ifFalse: [^ false].
	keyEvent asciiValue = 30
		ifTrue: 
			[sensor keyboard.
			self scrollViewDown ifTrue: [self moveMarker].
			^ true].
	keyEvent asciiValue = 31
		ifTrue: 
			[sensor keyboard.
			self scrollViewUp ifTrue: [self moveMarker].
			^ true].
	^ false! !

!ScrollController methodsFor: 'scrolling'!
scrollView
	"The scroll bar jump method was used so that the view should be 
	updated to correspond to the location of the scroll bar gray area.
	Return true only if scrolling took place."
	^ self scrollView: self viewDelta! !

!ScrollController methodsFor: 'scrolling'!
scrollView: anInteger 
	"Tell the reciever's view to scroll by anInteger amount.
	Return true only if scrolling actually resulted."
	(view scrollBy: 0 @ 
				((anInteger min: view window top - view boundingBox top)
						max: view window top - view boundingBox bottom))
		ifTrue: [view clearInside; display.  ^ true]
		ifFalse: [^ false]! !

!ScrollController methodsFor: 'scrolling'!
scrollViewDown
	"Scroll the receiver's view down the default amount.
	Return true only if scrolling actually took place."
	^ self scrollView: self scrollAmount! !

!ScrollController methodsFor: 'scrolling'!
scrollViewUp
	"Scroll the receiver's view up the default amount.
	Return true only if scrolling actually took place."
	^ self scrollView: self scrollAmount negated! !

!ScrollController methodsFor: 'scrolling'!
upDownLine
	"Check to see whether the user wishes to jump, scroll up, or scroll down."

	^scrollBar left + 12! !

!ScrollController methodsFor: 'scrolling'!
upLine
	"if cursor beyond upLine, display up cursor and scroll up on button down"

	^scrollBar left + 12! !

!ScrollController methodsFor: 'scrolling'!
viewDelta
	"Answer an integer that indicates how much the view should be scrolled. 
	The scroll bar has been moved and now the view must be so the amount 
	to scroll is computed as a ratio of the current scroll bar position."

	^view window top - view boundingBox top -
		((marker top - scrollBar inside top) asFloat /
			scrollBar inside height asFloat *
				view boundingBox height asFloat) rounded! !

!ScrollController methodsFor: 'scrolling'!
yellowLine
	"Check to see whether the user wishes to jump, scroll up, or scroll down."

	^scrollBar left + 16! !


!ScrollController methodsFor: 'private'!
scrollAbsolute
	| markerOutline oldY markerForm |
	self changeCursor: Cursor rightArrow.

	oldY _ -1.
	sensor anyButtonPressed ifTrue: 
	  [markerOutline _ marker deepCopy.
	  markerForm _ Form fromDisplay: marker.
	  Display fill: marker fillColor: scrollBar insideColor.
	  Display border: markerOutline width: 1 fillColor: Color gray.
	  markerForm 
		follow: 
			[oldY ~= sensor cursorPoint y
				ifTrue: 
					[oldY _ sensor cursorPoint y.
					marker _ marker translateBy: 
					  0 @ ((oldY - marker center y 
						min: scrollBar inside bottom - marker bottom) 
						max: scrollBar inside top - marker top).
					self scrollView].
				marker origin] 
		while: [sensor anyButtonPressed].

	  Display fill: markerOutline fillColor: scrollBar insideColor.
	  self moveMarker]! !

!ScrollController methodsFor: 'private'!
scrollDown
	| markerForm firstTime |
	self changeCursor: Cursor down.
	sensor anyButtonPressed ifTrue:
	  [markerForm _ Form fromDisplay: marker.
	  Display fill: marker fillColor: scrollBar insideColor.
	  firstTime _ true.
	  markerForm 
		follow: 
			[self scrollViewDown ifTrue:
				[marker _ marker translateBy: 0 @
					((self markerDelta negated 
						min: scrollBar inside bottom - marker bottom) 
						max: scrollBar inside top - marker top).
				firstTime
					ifTrue: [
						"pause before scrolling repeatedly"
						(Delay forMilliseconds: 250) wait.
						firstTime _ false.
					] ifFalse: [
						(Delay forMilliseconds: 50) wait.
					].
				].
			marker origin] 
		while: [sensor anyButtonPressed].
	  self moveMarker.]! !

!ScrollController methodsFor: 'private'!
scrollUp
	| markerForm firstTime |
	self changeCursor: Cursor up.
	sensor anyButtonPressed ifTrue:
	  [markerForm _ Form fromDisplay: marker.
	  Display fill: marker fillColor: scrollBar insideColor.
	  firstTime _ true.
	  markerForm 
		follow: 
			[self scrollViewUp ifTrue:
				[marker _ marker translateBy: 0 @
					((self markerDelta negated 
						min: scrollBar inside bottom - marker bottom) 
						max: scrollBar inside top - marker top).
				firstTime
					ifTrue: [
						"pause before scrolling repeatedly"
						(Delay forMilliseconds: 250) wait.
						firstTime _ false.
					] ifFalse: [
						(Delay forMilliseconds: 50) wait.
					].
				].
			marker origin] 
		while: [sensor anyButtonPressed].
	  self moveMarker.]! !
ComponentLikeModel subclass: #ScrollPane
	instanceVariableNames: 'scrollBar scroller retractableScrollBar scrollBarOnLeft getMenuSelector getMenuTitleSelector scrollBarHidden hasFocus hScrollBar'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ScrollPane commentStamp: 'mk 8/9/2005 10:34' prior: 0!
The scroller (a transform) of a scrollPane is driven by the scrollBar.  The scroll values vary from 0.0, meaning zero offset to 1.0 meaning sufficient offset such that the bottom of the scrollable material appears 3/4 of the way down the pane.  The total distance to achieve this range is called the totalScrollRange.

Basic clue about utilization of the ScrollPane class is given in:
	ScrollPane example1.
	ScrollPane example2.!


!ScrollPane methodsFor: 'access' stamp: 'sps 12/28/2002 01:07'!
adoptPaneColor: paneColor
	super adoptPaneColor: paneColor.
	scrollBar adoptPaneColor: paneColor.
	hScrollBar adoptPaneColor: paneColor.
! !

!ScrollPane methodsFor: 'access' stamp: 'md 2/24/2006 16:25'!
flatColoredScrollBarLook
	"Currently only show the flat (not rounded) + colored-to-match-window scrollbar look when inboard."
	^ retractableScrollBar not or: [ScrollBar alwaysShowFlatScrollbarForAlternativeLook]
! !

!ScrollPane methodsFor: 'access' stamp: 'dew 10/17/1999 19:40'!
hasFocus
	"hasFocus is currently set by mouse enter/leave events.
	This inst var should probably be moved up to a higher superclass."

	^ hasFocus ifNil: [false]! !

!ScrollPane methodsFor: 'access' stamp: 'sps 3/10/2004 11:32'!
hMargin
"pixels of whitespace at to the left of the scroller when the hScrollBar offset is 0"
	^3
! !

!ScrollPane methodsFor: 'access' stamp: 'LC 6/12/2000 09:28'!
retractableScrollBar
	^ retractableScrollBar! !

!ScrollPane methodsFor: 'access' stamp: 'LC 6/12/2000 09:28'!
scrollBarOnLeft
	^ scrollBarOnLeft! !

!ScrollPane methodsFor: 'access'!
scroller
	^ scroller! !

!ScrollPane methodsFor: 'access' stamp: 'ar 5/19/1999 18:06'!
scroller: aTransformMorph
	scroller ifNotNil:[scroller delete].
	scroller _ aTransformMorph.
	self addMorph: scroller.
	self resizeScroller.! !

!ScrollPane methodsFor: 'access' stamp: '6/7/97 10:42 di'!
wantsSlot
	"For now do it the old way, until we sort this out"
	^ true! !


!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:23'!
alwaysShowHScrollBar: bool
	self setProperty: #hScrollBarAlways toValue: bool.
	self hHideOrShowScrollBar.
! !

!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:25'!
alwaysShowScrollBars: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self 
		alwaysShowHScrollBar: bool;
		alwaysShowVScrollBar: bool.
! !

!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:23'!
alwaysShowVScrollBar: bool

	self setProperty: #vScrollBarAlways toValue: bool.
	self vHideOrShowScrollBar.
! !

!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:23'!
hideHScrollBarIndefinitely: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noHScrollBarPlease toValue: bool.
	self hHideOrShowScrollBar.
! !

!ScrollPane methodsFor: 'access options' stamp: 'nk 4/28/2004 10:08'!
hideScrollBarsIndefinitely
	self hideScrollBarsIndefinitely: true
! !

!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:21'!
hideScrollBarsIndefinitely: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self hideVScrollBarIndefinitely: bool.
	self hideHScrollBarIndefinitely: bool.
! !

!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:23'!
hideVScrollBarIndefinitely: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noVScrollBarPlease toValue: bool.
	self vHideOrShowScrollBar.
! !

!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:22'!
showHScrollBarOnlyWhenNeeded: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noHScrollBarPlease toValue: bool.
	self setProperty: #hScrollBarAlways toValue: bool.
	
	self hHideOrShowScrollBar.
! !

!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:29'!
showScrollBarsOnlyWhenNeeded: bool

	self showHScrollBarOnlyWhenNeeded: bool.
	self showVScrollBarOnlyWhenNeeded: bool.
! !

!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:25'!
showVScrollBarOnlyWhenNeeded: bool
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noVScrollBarPlease toValue: bool.
	self setProperty: #vScrollBarAlways toValue: bool.
	self vHideOrShowScrollBar.
! !


!ScrollPane methodsFor: 'accessing' stamp: 'dgd 10/1/2004 12:53'!
borderStyle: aBorderStyle 
	super borderStyle: aBorderStyle.
	self setScrollDeltas! !

!ScrollPane methodsFor: 'accessing' stamp: 'dgd 10/1/2004 12:52'!
borderWidth: aNumber 
	super borderWidth: aNumber.
	self setScrollDeltas! !

!ScrollPane methodsFor: 'accessing' stamp: 'nk 3/8/2004 11:07'!
numSelectionsInView
	"Answer the scroller's height based on the average number of submorphs."
	
	^scroller numberOfItemsPotentiallyInView! !


!ScrollPane methodsFor: 'event handling' stamp: 'sps 3/10/2004 10:23'!
handlesMouseDown: evt
	^ true
! !

!ScrollPane methodsFor: 'event handling' stamp: 'ar 9/18/2000 22:11'!
handlesMouseOver: evt
	"Could just ^ true, but this ensures that scroll bars won't flop out
	if you mouse-over appendages such as connecting pins."
	self flag: #arNote. "I have no idea how the code below could've ever worked. If the receiver does not handle mouse over events then it should not receive any #mouseLeave if the mouse leaves the receiver for real. This is because 'evt cursorPoint' describes the *end* point of the movement and considering that the code would return false if the move ends outside the receiver the scroll bars should never pop back in again. Which is exactly what happens with the new event logic if you don't just ^true. I'm leaving the code in for reference - perhaps somebody can make sense from it; I sure cannot."
	^true
"
	| cp |
	cp _ evt cursorPoint.
	(bounds containsPoint: cp)
		ifTrue: [^ true]			
		ifFalse: [self submorphsDo:
					[:m | (m containsPoint: cp) ifTrue:
							[m == scrollBar
								ifTrue: [^ true]
								ifFalse: [^ false]]].
				^ false]
"! !

!ScrollPane methodsFor: 'event handling' stamp: 'md 2/13/2006 11:53'!
keyStroke: evt
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"

	(self scrollByKeyboard: evt) ifTrue: [^self].
	scroller submorphs last keyStroke: evt! !

!ScrollPane methodsFor: 'event handling' stamp: 'md 2/13/2006 11:53'!
mouseDown: evt
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseDown: (evt transformedBy: (scroller transformFrom: self))]! !

!ScrollPane methodsFor: 'event handling' stamp: 'sps 3/9/2004 17:51'!
mouseEnter: event
	hasFocus _ true.
	(owner isSystemWindow) ifTrue: [owner paneTransition: event].
	retractableScrollBar ifTrue:[ self hideOrShowScrollBars ].
! !

!ScrollPane methodsFor: 'event handling' stamp: 'sps 3/9/2004 17:52'!
mouseLeave: event
	hasFocus _ false.
	retractableScrollBar ifTrue: [self hideScrollBars].
	(owner isSystemWindow) ifTrue: [owner paneTransition: event]
! !

!ScrollPane methodsFor: 'event handling' stamp: 'md 2/13/2006 11:53'!
mouseMove: evt
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)."
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseMove: (evt transformedBy: (scroller transformFrom: self))]! !

!ScrollPane methodsFor: 'event handling' stamp: 'md 2/13/2006 11:53'!
mouseUp: evt
	"If pane is not empty, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseUp: (evt transformedBy: (scroller transformFrom: self))]! !

!ScrollPane methodsFor: 'event handling' stamp: 'th 12/11/1999 17:21'!
scrollByKeyboard: event 
	"If event is ctrl+up/down then scroll and answer true"
	(event controlKeyPressed or:[event commandKeyPressed]) ifFalse: [^ false].
	event keyValue = 30
		ifTrue: 
			[scrollBar scrollUp: 3.
			^ true].
	event keyValue = 31
		ifTrue: 
			[scrollBar scrollDown: 3.
			^ true].
	^ false! !


!ScrollPane methodsFor: 'geometry' stamp: 'sps 5/3/2004 13:49'!
extent: newExtent
	
	| oldW oldH wasHShowing wasVShowing noVPlease noHPlease minH minW |
	
	oldW _ self width.
	oldH _ self height.
	wasHShowing _ self hIsScrollbarShowing.
	wasVShowing _ self vIsScrollbarShowing.

	"Figure out the minimum width and height for this pane so that scrollbars will appear"
	noVPlease _ self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]. 
	noHPlease _ self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]. 
	minH _ self scrollBarThickness + 16.
	minW _ self scrollBarThickness + 20.
	noVPlease ifTrue:[ 
		noHPlease
			ifTrue:[minH _ 1. minW _ 1 ]
			ifFalse:[minH _ self scrollBarThickness ].
	] ifFalse:[
		noHPlease
			ifTrue:[minH _ self scrollBarThickness + 5].
	].
	super extent: (newExtent max: (minW@minH)).

	"Now reset widget sizes"
	self resizeScrollBars; resizeScroller; hideOrShowScrollBars.
	
	"Now resetScrollDeltas where appropriate, first the vScrollBar..."
	((self height ~~ oldH) or: [ wasHShowing ~~ self hIsScrollbarShowing]) ifTrue:
		[(retractableScrollBar or: [ self vIsScrollbarShowing ]) ifTrue:
			[ self vSetScrollDelta ]].
			
	"...then the hScrollBar"
	((self width ~~ oldW) or: [wasVShowing ~~ self vIsScrollbarShowing]) ifTrue:
		[(retractableScrollBar or: [ self hIsScrollbarShowing ]) ifTrue:
			[ self hSetScrollDelta ]].

! !

!ScrollPane methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:06'!
extraScrollRange
	"Return the amount of extra blank space to include below the bottom of the scroll content."
	"The classic behavior would be ^bounds height - (bounds height * 3 // 4)"
	^ self scrollDeltaHeight! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/24/2002 00:13'!
hExtraScrollRange
	"Return the amount of extra blank space to include below the bottom of the scroll content."
	^ self scrollDeltaWidth
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 13:17'!
hLeftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	| w |
	scroller hasSubmorphs ifFalse:[^0].
	w _  bounds width.
	self vIsScrollbarShowing ifTrue:[ w _ w - self scrollBarThickness ].
	^ (self hTotalScrollRange - w roundTo: self scrollDeltaHeight) max: 0
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/27/2002 01:30'!
hResizeScrollBar

	| topLeft h border |

"TEMPORARY: IF OLD SCROLLPANES LYING AROUND THAT DON'T HAVE A hScrollBar, INIT THEM"
	hScrollBar ifNil: [ self hInitScrollBarTEMPORARY].
	
	(self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]) ifTrue: [^self].
	bounds ifNil: [ self fullBounds ].
	
	h _ self scrollBarThickness.
	border _ borderWidth.
	
	topLeft _ retractableScrollBar
				ifTrue: [bounds bottomLeft + (border @ border negated)]
				ifFalse: [bounds bottomLeft + (border @ (h + border) negated)].

	hScrollBar bounds: (topLeft extent: self hScrollBarWidth@ h)
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 16:16'!
hScrollBarWidth
"Return the width of the horizontal scrollbar"


	| w |
	
	w _ bounds width - (2 * borderWidth).
	
	(retractableScrollBar not and: [self vIsScrollbarNeeded])
		ifTrue: [w _ w - self scrollBarThickness ].
		
	^w 
! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 3/23/2004 23:23'!
hSetScrollDelta
	"Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
	| range delta |

	scroller hasSubmorphs ifFalse:[scrollBar interval: 1.0. ^self].
	
	delta _ self scrollDeltaWidth.
	range _ self hLeftoverScrollRange.
	range = 0 ifTrue: [ hScrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; setValue: 0. ^self].

	"Set up for one line (for arrow scrolling), or a full pane less one line (for paging)."

	hScrollBar 
			scrollDelta: (delta / range) asFloat 
			pageDelta: ((self innerBounds width - delta) / range) asFloat.
	hScrollBar interval: ((self innerBounds width) / self hTotalScrollRange) asFloat.
	hScrollBar setValue: ((scroller offset x / range) min: 1.0) asFloat.
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 11:51'!
hTotalScrollRange
	"Return the entire scrolling range."
	^ self hUnadjustedScrollRange + self hExtraScrollRange + self hMargin
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/24/2002 16:07'!
hUnadjustedScrollRange
	"Return the width extent of the receiver's submorphs."

	| submorphBounds |
	submorphBounds := scroller localSubmorphBounds ifNil: [^ 0].
	^ submorphBounds right
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/24/2002 16:18'!
innerBounds
	| inner |
	inner _ super innerBounds.
	retractableScrollBar | (submorphs includes: scrollBar) not ifFalse:[
		inner _ (scrollBarOnLeft
					ifTrue: [scrollBar right @ inner top corner: inner bottomRight]
					ifFalse: [inner topLeft corner: scrollBar left @ inner bottom])
	].
	(retractableScrollBar | self hIsScrollbarShowing not)
		ifTrue: [^ inner]
		ifFalse: [^ inner topLeft corner: (inner bottomRight - (0@self scrollBarThickness))].
! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 10/17/1999 19:41'!
resetExtent
	"Reset the extent. (may be overridden by subclasses which need to do more than this)"
	self resizeScroller! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 16:34'!
resizeScrollBars
	self vResizeScrollBar; hResizeScrollBar
! !

!ScrollPane methodsFor: 'geometry' stamp: 'di 11/11/1998 09:48'!
resizeScroller

	scroller bounds: self innerBounds! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 7/16/2004 19:25'!
scrollBarThickness
	"Includes border"
	| result |
	result := Preferences scrollBarsNarrow
				ifTrue: [10]
				ifFalse: [14].

	self flatColoredScrollBarLook
		ifFalse: [result := result + 2].
	
	^ result! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 13:26'!
scrollDeltaHeight
	"Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)."
	^ 10
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/9/2004 17:29'!
scrollDeltaWidth
	"Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)."
	
	^10
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 11:46'!
setScrollDeltas
	"Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."

	scroller hasSubmorphs ifFalse: 
		[scrollBar interval: 1.0. 
		hScrollBar interval: 1.0. 
		^ self].
	
"NOTE: fullbounds commented out now -- trying to find a case where this expensive step is necessary -- perhaps there is a less expensive way to handle that case."
	"scroller fullBounds." "force recompute so that leftoverScrollRange will be up-to-date"
	self hideOrShowScrollBars.
	
	(retractableScrollBar or: [ self vIsScrollbarShowing ]) ifTrue:[ self vSetScrollDelta ].
	(retractableScrollBar or: [ self hIsScrollbarShowing ]) ifTrue:[ self hSetScrollDelta ].
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 14:40'!
vExtraScrollRange
	"Return the amount of extra blank space to include below the bottom of the scroll content."
	"The classic behavior would be ^bounds height - (bounds height * 3 // 4)"
	^ self scrollDeltaHeight
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 13:14'!
vLeftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	| h |

	scroller hasSubmorphs ifFalse:[^0].
	h _ self vScrollBarHeight.
	^ (self vTotalScrollRange - h roundTo: self scrollDeltaHeight) max: 0
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 13:12'!
vResizeScrollBar
	| w topLeft borderHeight innerWidth |
	w := self scrollBarThickness.
	innerWidth := self flatColoredScrollBarLook 
		ifTrue: 
			[borderHeight := borderWidth.
			0]
		ifFalse: 
			[borderHeight := 0.
			 1].
	topLeft := scrollBarOnLeft 
				ifTrue: 
					[retractableScrollBar 
						ifTrue: [bounds topLeft - ((w - borderWidth) @ (0 - borderHeight))]
						ifFalse: [bounds topLeft + ((borderWidth - innerWidth) @ borderHeight)]]
				ifFalse: 
					[retractableScrollBar 
						ifTrue: [bounds topRight - (borderWidth @ (0 - borderHeight))]
						ifFalse: 
							[bounds topRight - ((w + borderWidth - innerWidth) @ (0 - borderHeight))]].
			
	scrollBar 
		bounds: (topLeft extent: w @ self vScrollBarHeight)
	
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 16:14'!
vScrollBarHeight
	| h |

	h _ bounds height - (2 * borderWidth).
	(retractableScrollBar not and: [self hIsScrollbarNeeded]) 
		ifTrue:[ h _ h - self scrollBarThickness. ].
	
	^h
! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 3/23/2004 23:25'!
vSetScrollDelta
	"Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
	| range delta |

	scroller hasSubmorphs ifFalse:[scrollBar interval: 1.0. ^self].
	
	delta _ self scrollDeltaHeight.
	range _ self vLeftoverScrollRange.
	range = 0 ifTrue: [^ scrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; setValue: 0].

	"Set up for one line (for arrow scrolling), or a full pane less one line (for paging)."
	scrollBar scrollDelta: (delta / range) asFloat 
			pageDelta: ((self innerBounds height - delta) / range) asFloat.
	scrollBar interval: ((self innerBounds height) / self vTotalScrollRange) asFloat.
	scrollBar setValue: (scroller offset y / range min: 1.0) asFloat.
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 11:06'!
vTotalScrollRange
	"Return the entire scrolling range."
	^ self vUnadjustedScrollRange + self vExtraScrollRange
! !

!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 14:43'!
vUnadjustedScrollRange
	"Return the height extent of the receiver's submorphs."
	| submorphBounds |
	submorphBounds := scroller localSubmorphBounds ifNil: [^ 0].
	^ submorphBounds bottom
! !


!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'!
containsPoint: aPoint

	(super containsPoint: aPoint) ifTrue: [^ true].
	
	"Also include v scrollbar when it is extended..."
	((retractableScrollBar and: [submorphs includes: scrollBar]) and:
		[scrollBar containsPoint: aPoint])
			ifTrue:[ ^true ].
		
	"Also include hScrollbar when it is extended..."
	^(retractableScrollBar and: [self hIsScrollbarShowing]) and:
		[hScrollBar containsPoint: aPoint]
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 13:46'!
hIsScrollable

	"If the contents of the pane are too small to scroll, return false."
	^ self hLeftoverScrollRange > 0
	
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'!
hIsScrollbarShowing
	"Return true if a horz scroll bar is currently showing"

	^submorphs includes: hScrollBar
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'!
hIsScrolled
	"If the scroller is not set to x = 0, then the pane has been h-scrolled."
	^scroller offset x > 0
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'!
isAScrollbarShowing
	"Return true if a either retractable scroll bar is currently showing"
	retractableScrollBar ifFalse:[^true].
	^self hIsScrollbarShowing or: [self vIsScrollbarShowing]
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'!
isScrolledFromTop
	"Have the contents of the pane been scrolled, so that the top of the contents are not visible?"
	^scroller offset y > 0
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'!
scrollBarFills: aRectangle
	"Return true if a flop-out scrollbar fills the rectangle"

	retractableScrollBar ifFalse:[^false].
	
	((submorphs includes: scrollBar) and: [scrollBar bounds containsRect: aRectangle])
				ifTrue:[ ^true ].
	^((submorphs includes: hScrollBar) and: [hScrollBar bounds containsRect: aRectangle])
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 13:23'!
vIsScrollable
"Return whether the verticle scrollbar is scrollable"

	"If the contents of the pane are too small to scroll, return false."
	^ self vLeftoverScrollRange > 0
		"treat a single line as non-scrollable"
		and: [self vTotalScrollRange > (self scrollDeltaHeight * 3/2)]
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'!
vIsScrollbarShowing
	"Return true if a retractable scroll bar is currently showing"

	^submorphs includes: scrollBar
! !

!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:23'!
vIsScrolled
	"If the scroller is not set to y = 0, then the pane has been scrolled."
	^scroller offset y > 0
! !


!ScrollPane methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color black! !

!ScrollPane methodsFor: 'initialization' stamp: 'sps 4/3/2005 15:21'!
defaultExtent
	^150@120
! !

!ScrollPane methodsFor: 'initialization' stamp: 'sps 3/9/2004 18:02'!
hInitScrollBarTEMPORARY
"This is called lazily before the hScrollBar is accessed in a couple of places. It is provided to transition old ScrollPanes lying around that do not have an hScrollBar. Once it has been in the image for awhile, and all ScrollPanes have an hScrollBar, this method and it's references can be removed. "

		"Temporary method for filein of changeset"
		hScrollBar ifNil: 
			[hScrollBar := ScrollBar new model: self slotName: 'hScrollBar'.
			hScrollBar borderWidth: 1; borderColor: Color black.
			self 
				resizeScrollBars;
				setScrollDeltas;
				hideOrShowScrollBars].
! !

!ScrollPane methodsFor: 'initialization' stamp: 'sps 4/3/2005 15:21'!
initialize
	
	"initialize the state of the receiver"
	super initialize.
	""
	self initializePreferences.
	hasFocus _ false.
	self initializeScrollBars.
	""
	self extent: self defaultExtent.
	self hideOrShowScrollBars.


! !

!ScrollPane methodsFor: 'initialization' stamp: 'md 2/24/2006 21:26'!
initializePreferences
	"initialize the receiver's Preferences"
	retractableScrollBar _ false.
	scrollBarOnLeft _ (Preferences valueOfFlag: #scrollBarsOnRight) not.
	

! !

!ScrollPane methodsFor: 'initialization' stamp: 'sps 4/4/2004 12:18'!
initializeScrollBars
"initialize the receiver's scrollBar"

	(scrollBar _ ScrollBar new model: self slotName: 'vScrollBar')
			borderWidth: 1; 
			borderColor: Color black.
	(hScrollBar _ ScrollBar new model: self slotName: 'hScrollBar')
			borderWidth: 1; 
			borderColor: Color black.

	""
	scroller _ TransformMorph new color: Color transparent.
	scroller offset: -3 @ 0.
	self addMorph: scroller.
	""
	scrollBar initializeEmbedded: retractableScrollBar not.
	hScrollBar initializeEmbedded: retractableScrollBar not.
	retractableScrollBar ifFalse: 
			[self 
				addMorph: scrollBar;
				addMorph: hScrollBar].

	Preferences alwaysShowVScrollbar ifTrue:
		[ self alwaysShowVScrollBar: true ].
		
	Preferences alwaysHideHScrollbar
		ifTrue:[self hideHScrollBarIndefinitely: true ]
		ifFalse:
			[Preferences alwaysShowHScrollbar ifTrue:
				[ self alwaysShowHScrollBar: true ]].
! !


!ScrollPane methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:06'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	retractableScrollBar
		ifTrue: [aCustomMenu add: 'make scrollbar inboard' translated action: #retractableOrNot]
		ifFalse: [aCustomMenu add: 'make scrollbar retractable' translated action: #retractableOrNot].
	scrollBarOnLeft
		ifTrue: [aCustomMenu add: 'scroll bar on right' translated action: #leftOrRight]
		ifFalse: [aCustomMenu add: 'scroll bar on left' translated action: #leftOrRight]! !

!ScrollPane methodsFor: 'menu' stamp: 'sw 9/23/1998 08:47'!
getMenu: shiftKeyState
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."
	| menu aMenu aTitle |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ MenuMorph new defaultTarget: model.
	aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
	getMenuSelector numArgs = 1 ifTrue:
		[aMenu _ model perform: getMenuSelector with: menu.
		aTitle ifNotNil:  [aMenu addTitle: aTitle].
		^ aMenu].
	getMenuSelector numArgs = 2 ifTrue:
		[aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
		aTitle ifNotNil:  [aMenu addTitle: aTitle].
		^ aMenu].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!ScrollPane methodsFor: 'menu' stamp: 'di 11/14/97 09:09'!
leftOrRight  "Change scroll bar location"
	scrollBarOnLeft _ scrollBarOnLeft not.
	self extent: self extent! !

!ScrollPane methodsFor: 'menu' stamp: 'sw 8/18/1998 12:38'!
menuTitleSelector: aSelector
	getMenuTitleSelector _ aSelector! !

!ScrollPane methodsFor: 'menu' stamp: 'sps 3/9/2004 17:47'!
retractableOrNot
	"Change scroll bar operation"

	retractableScrollBar _ retractableScrollBar not.
	retractableScrollBar
		ifTrue: [self removeMorph: scrollBar]
		ifFalse: [(submorphs includes: scrollBar) 
					ifFalse: 
						[self privateAddMorph: scrollBar atIndex: 1.
						self privateAddMorph: hScrollBar atIndex: 1]].
	self extent: self extent.
! !

!ScrollPane methodsFor: 'menu' stamp: 'sw 11/5/1998 14:14'!
retractable: aBoolean
	retractableScrollBar == aBoolean ifFalse: [self retractableOrNot "toggles it"]! !

!ScrollPane methodsFor: 'menu' stamp: 'sw 1/13/98 21:27'!
scrollBarOnLeft: aBoolean
	scrollBarOnLeft _ aBoolean.
	self extent: self extent! !

!ScrollPane methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:29'!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	^ getMenuSelector notNil! !



!ScrollPane methodsFor: 'scroll bar events' stamp: 'sps 12/27/2002 00:13'!
hScrollBarMenuButtonPressed: event
	^ self scrollBarMenuButtonPressed: event
! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'!
scrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'sw 3/22/2001 12:03'!
shiftedTextPaneMenuRequest
	"The more... button was hit from the text-pane menu"

	^ self yellowButtonActivity: true! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'!
shiftedYellowButtonActivity
	^ self yellowButtonActivity: true! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:32'!
unshiftedYellowButtonActivity
	^ self yellowButtonActivity: false! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'sps 12/27/2002 00:13'!
vScrollBarMenuButtonPressed: event
	^ self scrollBarMenuButtonPressed: event
! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 6/12/2000 09:02'!
yellowButtonActivity: shiftKeyState
	| menu |
	(menu _ self getMenu: shiftKeyState) ifNotNil:
		[menu setInvokingView: self.
		menu popUpEvent: self activeHand lastEvent in: self world]! !


!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 01:10'!
hHideOrShowScrollBar
	"Hide or show the scrollbar depending on if the pane is scrolled/scrollable."

	self hIsScrollbarNeeded
		ifTrue:[ self hShowScrollBar ]
		ifFalse: [ self hHideScrollBar ].
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 12:08'!
hHideScrollBar
	self hIsScrollbarShowing ifFalse: [^scroller offset: (self hMargin negated@scroller offset y)].
	self removeMorph: hScrollBar.
	scroller offset: (self hMargin negated@scroller offset y).
	retractableScrollBar ifFalse: [self resetExtent].

! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 13:33'!
hIsScrollbarNeeded
"Return whether the horz scrollbar is needed"

	"Don't do anything with the retractable scrollbar unless we have focus"
	retractableScrollBar & self hasFocus not ifTrue: [^false].
	
	"Don't show it if we were told not to."
	(self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]) ifTrue: [^false].

	"Always show it if we were told to"
	(self valueOfProperty: #hScrollBarAlways ifAbsent: [false]) ifTrue: [^true].

	^self hIsScrollable
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'nk 6/12/2004 16:27'!
hideOrShowScrollBar
	"Hide or show the scrollbar depending on if the pane is scrolled/scrollable."

	"Don't do anything with the retractable scrollbar unless we have focus"
	retractableScrollBar & self hasFocus not ifTrue: [^self].
	"Don't show it if we were told not to."
	(self valueOfProperty: #noScrollBarPlease ifAbsent: [false]) ifTrue: [^self].

	self vIsScrollable not & self isScrolledFromTop not ifTrue: [self vHideScrollBar].
	self vIsScrollable | self isScrolledFromTop ifTrue: [self vShowScrollBar].
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 12:07'!
hideOrShowScrollBars

	| wasHShowing wasVShowing |

	wasVShowing _ self vIsScrollbarShowing.
	wasHShowing _ self hIsScrollbarShowing.

	self 
		vHideOrShowScrollBar; 
		hHideOrShowScrollBar; 
		resizeScrollBars.

	(wasVShowing and: [self vIsScrollbarShowing not]) ifTrue:
		["Make sure the delta is 0"
		(scroller offset y == 0) 
				ifFalse:[ scroller offset: (scroller offset x@0) ]].
			
	(wasHShowing and: [self hIsScrollbarShowing not]) ifTrue:
		[(scroller offset x <= 0)
				ifFalse:[ scroller offset: (self hMargin negated@scroller offset y)]].
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 16:30'!
hideScrollBars
	self
		vHideScrollBar;
		hHideScrollBar
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 11:50'!
hScrollBarValue: scrollValue

	| x |
	self hIsScrollbarShowing ifFalse: 
		[^scroller offset: (0 - self hMargin)@scroller offset y].
	((x _ self hLeftoverScrollRange * scrollValue) <= 0)
		ifTrue:[x _ 0 - self hMargin].
	scroller offset: (x@scroller offset y)
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 13:42'!
hShowScrollBar

	self hIsScrollbarShowing ifTrue: [^self].
	self hResizeScrollBar.
	self privateAddMorph: hScrollBar atIndex: 1.
	retractableScrollBar ifFalse: [self resetExtent].
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 11:09'!
scrollBy: delta
	"Move the contents in the direction delta."

	| newYoffset r newXoffset |
	
	"Set the offset on the scroller"
	newYoffset _ scroller offset y - delta y max: 0.
	newXoffset _ scroller offset x - delta x max: -3.
	
	scroller offset: newXoffset@ newYoffset.

	"Update the scrollBars"
	(r _ self vLeftoverScrollRange) = 0
		ifTrue: [scrollBar value: 0.0]
		ifFalse: [scrollBar value: newYoffset asFloat / r].
	(r _ self hLeftoverScrollRange) = 0
		ifTrue: [hScrollBar value: -3.0]
		ifFalse: [hScrollBar value: newXoffset asFloat / r]
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'kfr 11/14/2004 10:29'!
scrollToShow: aRectangle
	"scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space"
	| range |
	((aRectangle top - scroller offset y) >= 0 and: [
		(aRectangle bottom - scroller offset y) <= (self innerBounds height) ])
		ifTrue:[ "already visible"^self ].

	range _ self vLeftoverScrollRange.
	scrollBar value: (range > 0
		ifTrue: [((aRectangle top) / self vLeftoverScrollRange)
							truncateTo: scrollBar scrollDelta]
		ifFalse: [0]).
	scroller offset: -3 @ (range * scrollBar value).! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 16:35'!
showScrollBars
	self  vShowScrollBar; hShowScrollBar
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 16:31'!
vHideOrShowScrollBar

	self vIsScrollbarNeeded
		ifTrue:[ self vShowScrollBar ]
		ifFalse:[ self vHideScrollBar ].
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 12:07'!
vHideScrollBar
	self vIsScrollbarShowing ifFalse: [^self].
	self removeMorph: scrollBar.
	retractableScrollBar ifFalse: [self resetExtent].
	
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 10:26'!
vIsScrollbarNeeded
"Return whether the verticle scrollbar is needed"

	"Don't do anything with the retractable scrollbar unless we have focus"
	retractableScrollBar & self hasFocus not ifTrue: [^false].
	
	"Don't show it if we were told not to."
	(self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]) ifTrue: [^false].

	"Always show it if we were told to"
	(self valueOfProperty: #vScrollBarAlways ifAbsent: [false]) ifTrue: [^true].
	
	^self vIsScrollable
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 16:32'!
vScrollBarValue: scrollValue
	scroller hasSubmorphs ifFalse: [^ self].
	scroller offset: (scroller offset x @ (self vLeftoverScrollRange * scrollValue) rounded)
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 13:22'!
vShowScrollBar

	self vIsScrollbarShowing ifTrue: [^ self].
	self vResizeScrollBar.
	self privateAddMorph: scrollBar atIndex: 1.
	retractableScrollBar ifFalse: [self resetExtent]
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScrollPane class
	instanceVariableNames: ''!

!ScrollPane class methodsFor: 'examples' stamp: 'mk 8/9/2005 10:28'!
example1
	| window scrollPane pasteUpMorph |
	window := SystemWindow new.
	scrollPane := ScrollPane new.
	pasteUpMorph := PasteUpMorph new.
	pasteUpMorph extent: 1000@1000.
	scrollPane scroller addMorph: pasteUpMorph.
	window addMorph: scrollPane frame: (0@0 corner: 1@1).
	window openInWorld.! !

!ScrollPane class methodsFor: 'examples' stamp: 'mk 8/9/2005 10:29'!
example2
	| window scrollPane pasteUpMorph point textMorph |
	window := SystemWindow new.
	scrollPane := ScrollPane new.
	pasteUpMorph := PasteUpMorph new.
	pasteUpMorph extent: 1000@1000.
	scrollPane scroller addMorph: pasteUpMorph.
	window addMorph: scrollPane frame: (0@0 corner: 1@1).
	0 to: 1000 by: 100 do: 
		[:x | 0 to: 1000 by: 100 do:
			[:y |
				point :=  x@y.
				textMorph := TextMorph new contents: point asString.
				textMorph position: point.
				pasteUpMorph addMorph: textMorph
			]
		].
	window openInWorld.! !


!ScrollPane class methodsFor: 'new-morph participation' stamp: 'di 2/21/98 11:02'!
includeInNewMorphMenu
	"OK to instantiate"
	^ true! !
PluggableTextMorphWithModel subclass: #ScrollableField
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!ScrollableField methodsFor: 'contents' stamp: 'sw 4/7/2002 18:48'!
setMyText: someText
	"Set my text, as indicated"

	| toUse |
	toUse _ someText ifNil: [''].
	myContents _ toUse.
	self setText: toUse.
	^ true! !


!ScrollableField methodsFor: 'parts bin' stamp: 'dgd 4/3/2006 13:28'!
initializeToStandAlone
	super initializeToStandAlone.
	self  color: (Color r: 0.972 g: 0.972 b: 0.662).
	self retractable: false; scrollBarOnLeft: false.

	self wantsFrameAdornments: false.! !


!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 19:08'!
adjustTextAnchor: aMorph 
	textMorph
		ifNotNil: [textMorph adjustTextAnchor: aMorph]! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 19:05'!
contents
	^ textMorph contents! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:27'!
cursor
	"Answer the receiver's logical cursor position"
	^ textMorph cursor! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:31'!
cursorWrapped: aNumber 
"Set the cursor as indicated"
	textMorph cursorWrapped: aNumber! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 19:00'!
editor
	^ textMorph editor! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:13'!
elementCount
	"Answer how many sub-objects are within me"
	^ textMorph elementCount! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:14'!
getAllButFirstCharacter
	"Obtain all but the first character from the receiver; if that  
	would be empty, return a black dot"
	^ textMorph getAllButFirstCharacter ! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:31'!
getCharacters
"obtain a string value from the receiver"
	^ textMorph getCharacters! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:14'!
getFirstCharacter
	"obtain the first character from the receiver if it is empty, 
	return a black dot"
	^ textMorph getFirstCharacter! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:14'!
getLastCharacter
	"obtain the last character from the receiver if it is empty,  
	return a black dot"
	^ textMorph getLastCharacter ! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:27'!
getNumericValue
	"Obtain a numeric value from the receiver; if no digits, return  
	zero"
	^ textMorph getNumericValue ! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:28'!
insertCharacters: aString 
	"Insert the characters from the given source at my current  
	cursor position"
	textMorph insertCharacters: aString ! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:28'!
insertContentsOf: aPlayer 
	"Insert the characters from the given player at my current  
	cursor position"
	textMorph insertContentsOf: aPlayer ! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 19:03'!
isAutoFit
	^ textMorph isAutoFit! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 19:03'!
isWrapped
	^ textMorph isWrapped! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 19:04'!
margins
	^ textMorph margins! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:25'!
paragraph
	^ textMorph paragraph! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:30'!
setCharacters: chars 
	"obtain a string value from the receiver"
	textMorph setCharacters: chars ! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:28'!
setNumericValue: aValue 
	"Set the contents of the receiver to be a string obtained from  
	aValue"
	textMorph setNumericValue: aValue ! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 19:05'!
textStyle
	^ textMorph textStyle! !

!ScrollableField methodsFor: 'accessing' stamp: 'dgd 10/14/2004 18:28'!
updateFromParagraph
	"A change has taken place in my paragraph, as a result of  
	editing and I must be updated. If a line break causes  
	recomposition of the current paragraph, or it the selection has 
	entered a different paragraph, then the current editor will be  
	released, and must be reinstalled with the resulting new  
	paragraph, while retaining any editor state, such as selection,  
	undo state, and current typing emphasis."
	textMorph updateFromParagraph ! !


!ScrollableField methodsFor: 'editing' stamp: 'dgd 10/14/2004 19:21'!
anchorMorph: aMorph at: aPoint type: anchorType 
	textMorph anchorMorph: aMorph at: aPoint type: anchorType ! !

!ScrollableField methodsFor: 'editing' stamp: 'dgd 10/14/2004 18:57'!
chooseEmphasisOrAlignment
	textMorph chooseEmphasisOrAlignment! !

!ScrollableField methodsFor: 'editing' stamp: 'dgd 10/14/2004 18:59'!
chooseFont
	textMorph chooseFont! !

!ScrollableField methodsFor: 'editing' stamp: 'dgd 10/14/2004 18:58'!
chooseStyle
	textMorph chooseStyle! !


!ScrollableField methodsFor: 'updating' stamp: 'dgd 10/14/2004 19:18'!
changed
	super changed.
	textMorph changed.! !


!ScrollableField methodsFor: 'menu' stamp: 'dgd 10/1/2004 11:44'!
getMenu: shiftKeyState 
	^ (shiftKeyState not
			or: [Preferences noviceMode])
		ifTrue: [ParagraphEditor yellowButtonMenu]
		ifFalse: [ParagraphEditor shiftedYellowButtonMenu]! !

!ScrollableField methodsFor: 'menu' stamp: 'dgd 10/1/2004 11:57'!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	^ true! !


!ScrollableField methodsFor: 'classification' stamp: 'dgd 10/14/2004 18:56'!
isTextMorph
	^ true! !


!ScrollableField methodsFor: 'private' stamp: 'dgd 10/14/2004 19:19'!
releaseParagraph
	textMorph releaseParagraph ! !

!ScrollableField methodsFor: 'private' stamp: 'dgd 10/14/2004 19:05'!
text: aText textStyle: aTextStyle 
	textMorph text: aText textStyle: aTextStyle ! !


!ScrollableField methodsFor: 'containment' stamp: 'dgd 10/14/2004 19:19'!
setContainer: newContainer 
	self changed.
	textMorph setContainer: newContainer.
self releaseParagraph! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScrollableField class
	instanceVariableNames: ''!

!ScrollableField class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:59'!
initialize

	self registerInFlapsRegistry.	! !

!ScrollableField class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:01'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(ScrollableField			newStandAlone		'Scrolling Text'		'Holds any amount of text; has a scroll bar')
						forFlapNamed: 'Stack Tools'.]! !

!ScrollableField class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:40'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!ScrollableField class methodsFor: 'parts bin' stamp: 'sw 4/2/2002 12:21'!
descriptionForPartsBin
	^ self partName:	'Scrolling Text'
		categories:		#('Text' )
		documentation:	'A scrollable, editable body of text'! !


!ScrollableField class methodsFor: 'scripting' stamp: 'dgd 10/14/2004 18:08'!
additionsToViewerCategories
	^ TextMorph additionsToViewerCategories! !
Object subclass: #ScrollingToolHolder
	instanceVariableNames: 'pickupButtons stampButtons stamps thumbnailPics start'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Support'!
!ScrollingToolHolder commentStamp: '<historical>' prior: 0!
Used to hold stamp images in the PaintBox. Displays a small number of the available stamps and allows scrolling to access the others. One stamp is always kept blank as a way to create new stamps.

Note:
	stamps are the full size Forms
	thumbnailPics are the shrunken ones
	nil in both lists means no stamp yet, so user can create one
!


!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 15:00'!
clear
	"wipe out all existing stamps"

	stamps _ OrderedCollection new: 16.
	thumbnailPics _ OrderedCollection new: 16.
	stampButtons do: [:each | 
		stamps addLast: nil.	"hold a space"
		thumbnailPics addLast: nil].
	start _ 1.
	self normalize.! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 3/9/98 13:17'!
normalize
	"Correspondence between buttons and stamp forms has changed.  Make all thumbnails show up right."

	| shrunkForm button trans |
	1 to: stampButtons size do: [:ind |
		shrunkForm _ thumbnailPics atWrap: ind+start-1.
		button _ stampButtons at: ind.
		shrunkForm 
			ifNil: [trans _ Form extent: button extent depth: 8.
				trans fill: trans boundingBox fillColor: Color transparent.
				button onImage: trans]
			ifNotNil: [button onImage: shrunkForm].
		button offImage: shrunkForm; pressedImage: shrunkForm.	"later modify them"
		].! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 11:46'!
otherButtonFor: aButton
	"Find the corresponding button for either a pickup or a stamp button"

	| ii |
	(ii _ pickupButtons indexOf: aButton) > 0 ifTrue: [^ stampButtons at: ii].
	(ii _ stampButtons indexOf: aButton) > 0 ifTrue: [^ pickupButtons at: ii].
	self error: 'stamp button not found'.! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/16/97 19:22'!
pickupButtons

	^ pickupButtons! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 10:51'!
pickupButtons: anArray
	"Save the list of buttons that are for making a new stamp.  Left to right"

	pickupButtons _ anArray! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 10/11/97 17:04'!
remove: tool
	"Remove a stamp.  Make this stamp blank.  OK to have a bunch of blank ones."

	| which |
	which _ stampButtons indexOf: tool ifAbsent: [
				pickupButtons indexOf: tool ifAbsent: [^ self]].
	stamps atWrap: which+start-1 put: nil.
	thumbnailPics atWrap: which+start-1 put: nil.
	self normalize.	"show them"! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 14:37'!
scroll: amt
	"Move the stamps over"

	start _ start - 1 + amt \\ stamps size + 1.
	self normalize.	"show them"! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/16/97 19:22'!
stampButtons

	^ stampButtons! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 10/11/97 10:21'!
stampButtons: anArray
	"Pop in a new list of buttons that are the tools for stamping.  Left to right"

	stampButtons _ anArray.
	self clear.! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/17/97 09:59'!
stampForm: stampForm for: aPickupButton
	"Install this form to stamp. Find its index.  Make a thumbnail."

	| which scale shrunkForm stampBtn mini |
	which _ pickupButtons indexOf: aPickupButton.
	which = 0 ifTrue: [which _ stampButtons indexOf: aPickupButton].
	stamps atWrap: which+start-1 put: stampForm.

	"Create the thumbnail"
	stampBtn _ stampButtons at: which.
	scale _ stampBtn width / (stampForm extent x max: stampForm extent y).
	scale _ scale min: 1.0.	"do not expand it"
	mini _ stampForm magnify: stampForm boundingBox by: scale smoothing: 1.
	shrunkForm _ mini class extent: stampBtn extent depth: stampForm depth.
	mini displayOn: shrunkForm at: (stampBtn extent - mini extent)//2.
	thumbnailPics atWrap: which+start-1 put: shrunkForm.
	stampBtn offImage: shrunkForm; onImage: shrunkForm; pressedImage: shrunkForm.
		"Emphasis is done by border of enclosing layoutMorph, not modifying image"

	(stamps indexOf: nil) = 0 ifTrue: ["Add an extra blank place"
		"Keep stamp we just installed in the same location!!"
		start+which-1 > stamps size ifTrue: [start _ start + 1].
		stamps addLast: nil.
		thumbnailPics addLast: nil.
		self normalize].
! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 14:04'!
stampFormFor: aButton

	| which |
	which _ stampButtons indexOf: aButton ifAbsent: [1].
	^ stamps atWrap: which+start-1! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'jm 7/28/97 11:54'!
updateReferencesUsing: aDictionary
	"Fix up the Morphs I own"
	"Note: Update this method when adding new inst vars that could contain Morphs."

	stampButtons _ stampButtons collect:
		[:old | aDictionary at: old ifAbsent: [old]].
	pickupButtons _ pickupButtons collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !
CategoryViewer subclass: #SearchingViewer
	instanceVariableNames: 'searchString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!SearchingViewer commentStamp: 'sw 8/16/2002 22:43' prior: 0!
A SearchingViewer is a custom Viewer which has a type-in 'search' pane; the user types a word or fragment into the search pane and hits the 'search' button (or hits Return or Enter) and the pane gets populated with all the phrases that match (in the currently-installed language) the search-string.!


!SearchingViewer methodsFor: 'categories' stamp: 'sw 12/11/2001 15:52'!
categoryWording: aCategoryWording
	"okay, thanks"! !

!SearchingViewer methodsFor: 'categories' stamp: 'sw 12/11/2001 19:13'!
currentCategory
	"Answer the symbol associated with the pane"

	^ #search! !

!SearchingViewer methodsFor: 'categories' stamp: 'tak 8/8/2005 11:31'!
updateCategoryNameTo: aName
	"Update the category name, because of a language change."

	self doSearchFrom: (namePane findA: PluggableTextMorph) text interactive: false.
	self updateSearchButtonLabel
! !

!SearchingViewer methodsFor: 'categories' stamp: 'tak 8/8/2005 11:30'!
updateSearchButtonLabel
	| button |
	button := self
				findDeepSubmorphThat: [:e | e class = SimpleButtonMorph]
				ifAbsent: [].
	button label: 'Search' translated.
	button setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list below.' translated! !


!SearchingViewer methodsFor: 'header pane' stamp: 'sw 12/11/2001 19:12'!
maybeAddArrowsTo: header
	"Maybe add up/down arrows to the header"

	header addTransparentSpacerOfSize: 5@5! !


!SearchingViewer methodsFor: 'initialization' stamp: 'tak 8/8/2005 11:31'!
addNamePaneTo: header
	"Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer"

	| plugTextMor searchButton |
	namePane _ AlignmentMorph newRow vResizing: #spaceFill; height: 14.
	namePane hResizing: #spaceFill.
	namePane listDirection: #leftToRight.

	plugTextMor _ PluggableTextMorph on: self
					text: #searchString accept: #searchString:notifying:
					readSelection: nil menu: nil.
	plugTextMor setProperty: #alwaysAccept toValue: true.
	plugTextMor askBeforeDiscardingEdits: false.
	plugTextMor acceptOnCR: true.
	plugTextMor setTextColor: Color brown.
	plugTextMor setNameTo: 'Search' translated.
	plugTextMor vResizing: #spaceFill; hResizing: #spaceFill.
	plugTextMor hideScrollBarsIndefinitely.
	plugTextMor setTextMorphToSelectAllOnMouseEnter.

	searchButton _ SimpleButtonMorph new 
		target: self;
		beTransparent;
		actionSelector: #doSearchFrom:;
		arguments: {plugTextMor}.

	namePane addMorphFront: searchButton.
	namePane addTransparentSpacerOfSize: 6@0.
	namePane addMorphBack: plugTextMor.
	header addMorphBack: namePane.
	self updateSearchButtonLabel.! !

!SearchingViewer methodsFor: 'initialization' stamp: 'sw 10/15/2004 02:34'!
establishContents 
	"Perform any initialization steps that needed to wait until I am installed in my outer viewer"

	searchString isEmptyOrNil ifFalse: [self doSearchFrom: searchString interactive: false]! !

!SearchingViewer methodsFor: 'initialization' stamp: 'sw 8/3/2005 11:16'!
initializeFor: aPlayer categoryChoice: aChoice
	"Initialize the receiver to be associated with the player and category specified"

	super initializeFor: aPlayer categoryChoice: #search.
	self clipSubmorphs: true.
	(namePane findA: PluggableTextMorph) setText: aChoice second asText.
	self setCategorySymbolFrom: aChoice! !

!SearchingViewer methodsFor: 'initialization' stamp: 'sw 8/22/2002 23:09'!
setCategorySymbolFrom: aChoice
	"Set my category symbol"

	self chosenCategorySymbol: #search.
	self rawSearchString: aChoice second! !


!SearchingViewer methodsFor: 'search' stamp: 'sw 4/10/2003 21:36'!
doSearchFrom:  aSource
	"Perform the search operation"

	^ self doSearchFrom: aSource interactive: true! !

!SearchingViewer methodsFor: 'search' stamp: 'nk 8/29/2004 17:21'!
doSearchFrom:  aSource interactive: isInteractive
	"Perform the search operation.  If interactive is true, this actually happened because a search button was pressed; if false, it was triggered some other way for which an informer would be inappropriate."

	| searchFor aVocab aList all anInterface useTranslations scriptNames addedMorphs |
	searchString _ (aSource isKindOf: PluggableTextMorph)
		ifFalse:
			[aSource]
		ifTrue:
			[aSource text string].
	searchFor _ searchString asString asLowercase withBlanksTrimmed.

	aVocab _ self outerViewer currentVocabulary.
	(useTranslations _ (scriptedPlayer isPlayerLike) and: [aVocab isEToyVocabulary])
		ifTrue:
			[all _ scriptedPlayer costume selectorsForViewer.
			all addAll: (scriptNames _ scriptedPlayer class namedTileScriptSelectors)]
		ifFalse:
			[all _ scriptNames _ scriptedPlayer class allSelectors].
	aList _ all select:
		[:aSelector | (aVocab includesSelector: aSelector forInstance: scriptedPlayer ofClass: scriptedPlayer class limitClass: ProtoObject) and:
			[(useTranslations and: [(anInterface _ aVocab methodInterfaceAt: aSelector ifAbsent: [nil]) notNil and: [anInterface wording includesSubstring: searchFor caseSensitive: false]])
				or:
					[((scriptNames includes: aSelector) or: [useTranslations not]) and:
						[aSelector includesSubstring: searchFor caseSensitive: false]]]].
	aList _ aList asSortedArray.

	self removeAllButFirstSubmorph. "that being the header"
	self addAllMorphs:
		((addedMorphs _ scriptedPlayer tilePhrasesForSelectorList: aList inViewer: self)).
	self enforceTileColorPolicy.
	self secreteCategorySymbol.
	self world ifNotNil: [self world startSteppingSubmorphsOf: self].
	self adjustColorsAndBordersWithin.

	owner ifNotNil: [owner isStandardViewer ifTrue: [owner fitFlap].

	(isInteractive and: [addedMorphs isEmpty]) ifTrue:
		[self inform: ('No matches found for "' translated), searchFor, '"']]! !

!SearchingViewer methodsFor: 'search' stamp: 'sw 8/22/2002 15:14'!
rawSearchString: aString
	"Set the search string as indicated"

	searchString _ aString asString! !

!SearchingViewer methodsFor: 'search' stamp: 'sw 8/11/2002 02:14'!
searchString
	"Answer the search string"

	^ searchString ifNil: [searchString _ '']! !

!SearchingViewer methodsFor: 'search' stamp: 'sw 8/22/2002 20:30'!
searchString: aString notifying: znak
	"Set the search string as indicated and carry out a search"

	searchString _ aString asString.
	self doSearchFrom: searchString! !


!SearchingViewer methodsFor: 'support' stamp: 'sw 8/17/2002 01:13'!
categoryRestorationInfo
	"Answer info needed to reincarnate myself"

	^ Array with: self chosenCategorySymbol with: self searchString! !
Object subclass: #SecureHashAlgorithm
	instanceVariableNames: 'totalA totalB totalC totalD totalE totals'
	classVariableNames: 'K1 K2 K3 K4'
	poolDictionaries: ''
	category: 'System-Digital Signatures'!
!SecureHashAlgorithm commentStamp: '<historical>' prior: 0!
This class implements the Secure Hash Algorithm (SHA) described in the U.S. government's Secure Hash Standard (SHS). This standard is described in FIPS PUB 180-1, "SECURE HASH STANDARD", April 17, 1995.

The Secure Hash Algorithm is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996.

See the comment in class DigitalSignatureAlgorithm for details on its use.

Implementation notes:
The secure hash standard was created with 32-bit hardware in mind. All arithmetic in the hash computation must be done modulo 2^32. This implementation uses ThirtyTwoBitRegister objects to simulate hardware registers; this implementation is about six times faster than using LargePositiveIntegers (measured on a Macintosh G3 Powerbook). Implementing a primitive to process each 64-byte buffer would probably speed up the computation by a factor of 20 or more.
!


!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 20:11'!
primExpandBlock: aByteArray into: wordBitmap
	"Expand the given 64-byte buffer into the given Bitmap of length 80."

	<primitive: 'primitiveExpandBlock' module: 'DSAPrims'>
	^ self primitiveFailed
! !

!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 22:58'!
primHasSecureHashPrimitive
	"Answer true if this platform has primitive support for the Secure Hash Algorithm."

	<primitive: 'primitiveHasSecureHashPrimitive' module: 'DSAPrims'>
	^ false
! !

!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 20:13'!
primHashBlock: blockBitmap using: workingTotalsBitmap
	"Hash the given block (a Bitmap) of 80 32-bit words, using the given workingTotals."

	<primitive: 'primitiveHashBlock' module: 'DSAPrims'>
	^ self primitiveFailed
! !


!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 11:56'!
hashInteger: aPositiveInteger
	"Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in key generation."

	| buffer dstIndex |
	self initializeTotals.

	"pad integer with zeros"
	aPositiveInteger highBit <= 512
		ifFalse: [self error: 'integer cannot exceed 512 bits'].
	buffer _ ByteArray new: 64.
	dstIndex _ 0.
	aPositiveInteger digitLength to: 1 by: -1 do: [:i |
		buffer at: (dstIndex _ dstIndex + 1) put: (aPositiveInteger digitAt: i)].

	"process that one block"
	self processBuffer: buffer.

	^ self finalHash
! !

!SecureHashAlgorithm methodsFor: 'public' stamp: 'md 11/14/2003 17:17'!
hashInteger: aPositiveInteger seed: seedInteger
	"Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in the production of random numbers"

	| buffer dstIndex |
	"Initialize totalA through totalE to their seed values."
	totalA _ ThirtyTwoBitRegister new
		load: ((seedInteger bitShift: -128) bitAnd: 16rFFFFFFFF).
	totalB _ ThirtyTwoBitRegister new
		load: ((seedInteger bitShift: -96) bitAnd: 16rFFFFFFFF).
	totalC _ ThirtyTwoBitRegister new
		load: ((seedInteger bitShift: -64) bitAnd: 16rFFFFFFFF).
	totalD _ ThirtyTwoBitRegister new
		load: ((seedInteger bitShift: -32) bitAnd: 16rFFFFFFFF).
	totalE _ ThirtyTwoBitRegister new
		load: (seedInteger bitAnd: 16rFFFFFFFF).
	self initializeTotalsArray.

	"pad integer with zeros"
	buffer _ ByteArray new: 64.
	dstIndex _ 0.
	aPositiveInteger digitLength to: 1 by: -1 do: [:i |
		buffer at: (dstIndex _ dstIndex + 1) put: (aPositiveInteger digitAt: i)].

	"process that one block"
	self processBuffer: buffer.

	^ self finalHash
! !

!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 11:28'!
hashMessage: aStringOrByteArray
	"Hash the given message using the Secure Hash Algorithm."

	^ self hashStream: (ReadStream on: aStringOrByteArray asByteArray)
! !

!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 11:41'!
hashStream: aPositionableStream
	"Hash the contents of the given stream from the current position to the end using the Secure Hash Algorithm. The SHA algorithm is defined in FIPS PUB 180-1. It is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996."
	"SecureHashAlgorithm new hashStream: (ReadStream on: 'foo')"

	| startPosition buf bitLength |
	self initializeTotals.

	aPositionableStream atEnd ifTrue: [self error: 'empty stream'].

	startPosition _ aPositionableStream position.
	[aPositionableStream atEnd] whileFalse: [
		buf _ aPositionableStream next: 64.
		(aPositionableStream atEnd not and: [buf size = 64])
			ifTrue: [self processBuffer: buf]
			ifFalse: [
				bitLength _ (aPositionableStream position - startPosition) * 8.
				self processFinalBuffer: buf bitLength: bitLength]].

	^ self finalHash
! !


!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/7/1999 23:25'!
constantForStep: i
	"Answer the constant for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard."

	i <= 20 ifTrue: [^ K1].
	i <= 40 ifTrue: [^ K2].
	i <= 60 ifTrue: [^ K3].
	^ K4
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 20:06'!
expandedBlock: aByteArray
	"Convert the given 64 byte buffer into 80 32-bit registers and answer the result." 
	| out src v |
	out _ Array new: 80.
	src _ 1.
	1 to: 16 do: [:i |
		out at: i put: (ThirtyTwoBitRegister new loadFrom: aByteArray at: src).
		src _ src + 4].

	17 to: 80 do: [:i |
		v _ (out at: i - 3) copy.
		v	bitXor: (out at: i - 8);
			bitXor: (out at: i - 14);
			bitXor: (out at: i - 16);
			leftRotateBy: 1.
		out at: i put: v].
	^ out
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 20:02'!
finalHash
	"Concatenate the final totals to build the 160-bit integer result."
	"Details: If the primitives are supported, the results are in the totals array. Otherwise, they are in the instance variables totalA through totalE."

	| r |
	totals ifNil: [  "compute final hash when not using primitives"
		^ (totalA asInteger bitShift: 128) +
		  (totalB asInteger bitShift:  96) +
		  (totalC asInteger bitShift:  64) +
		  (totalD asInteger bitShift:  32) +
		  (totalE asInteger)].

	"compute final hash when using primitives"
	r _ 0.
	1 to: 5 do: [:i |
		r _ r bitOr: ((totals at: i) bitShift: (32 * (5 - i)))].
	^ r
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/7/1999 22:15'!
hashFunction: i of: x with: y with: z
	"Compute the hash function for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard."
	"Details: There are four functions, one for each 20 iterations. The second and fourth are the same."

	i <= 20 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitInvert; bitAnd: z)].
	i <= 40 ifTrue: [^ x copy bitXor: y; bitXor: z].
	i <= 60 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitAnd: z); bitOr: (y copy bitAnd: z)].
	^ x copy bitXor: y; bitXor: z
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:38'!
initializeTotals
	"Initialize totalA through totalE to their seed values."

	"total registers for use when primitives are absent"
	totalA _ ThirtyTwoBitRegister new load: 16r67452301.
	totalB _ ThirtyTwoBitRegister new load: 16rEFCDAB89.
	totalC _ ThirtyTwoBitRegister new load: 16r98BADCFE.
	totalD _ ThirtyTwoBitRegister new load: 16r10325476.
	totalE _ ThirtyTwoBitRegister new load: 16rC3D2E1F0.
	self initializeTotalsArray.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:38'!
initializeTotalsArray
	"Initialize the totals array from the registers for use with the primitives."

	totals _ Bitmap new: 5.
	totals at: 1 put: totalA asInteger.
	totals at: 2 put: totalB asInteger.
	totals at: 3 put: totalC asInteger.
	totals at: 4 put: totalD asInteger.
	totals at: 5 put: totalE asInteger.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:43'!
processBuffer: aByteArray
	"Process given 64-byte buffer, accumulating the results in totalA through totalE."

	| a b c d e w tmp |
	self primHasSecureHashPrimitive
		ifTrue: [^ self processBufferUsingPrimitives: aByteArray]
		ifFalse: [totals _ nil].

	"initialize registers a through e from the current totals" 
	a _ totalA copy.
	b _ totalB copy.
	c _ totalC copy.
	d _ totalD copy.
	e _ totalE copy.

	"expand and process the buffer"
	w _ self expandedBlock: aByteArray.
	1 to: 80 do: [:i |
		tmp _ (a copy leftRotateBy: 5)
			+= (self hashFunction: i of: b with: c with: d);
			+= e;
			+= (w at: i);
			+= (self constantForStep: i).
		e _ d.
		d _ c.
		c _ b copy leftRotateBy: 30.
		b _ a.
		a _ tmp].

	"add a through e into total accumulators"
	totalA += a.
	totalB += b.
	totalC += c.
	totalD += d.
	totalE += e.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 23:32'!
processBufferUsingPrimitives: aByteArray
	"Process given 64-byte buffer using the primitives, accumulating the results in totals."

	| w |
	"expand and process the buffer"
	w _ Bitmap new: 80.
	self primExpandBlock: aByteArray into: w.
	self primHashBlock: w using: totals.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/14/1999 11:40'!
processFinalBuffer: buffer bitLength: bitLength
	"Process given buffer, whose length may be <= 64 bytes, accumulating the results in totalA through totalE. Also process the final padding bits and length."

	| out |
	out _ ByteArray new: 64.
	out replaceFrom: 1 to: buffer size with: buffer startingAt: 1.
	buffer size < 56 ifTrue: [  "padding and length fit in last data block"
		out at: buffer size + 1 put: 128.  "trailing one bit"
		self storeLength: bitLength in: out.  "end with length"
		self processBuffer: out.
		^ self].

	"process the final data block"
	buffer size < 64 ifTrue: [
		out at: buffer size + 1 put: 128].  "trailing one bit"
	self processBuffer: out.

	"process one additional block of padding ending with the length"
	out _ ByteArray new: 64.  "filled with zeros"
	buffer size = 64 ifTrue: [
		"add trailing one bit that didn't fit in final data block"
		out at: 1 put: 128].
	self storeLength: bitLength in: out.
	self processBuffer: out.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/14/1999 11:10'!
storeLength: bitLength in: aByteArray
	"Fill in the final 8 bytes of the given ByteArray with a 64-bit big-endian representation of the original message length in bits."

	| n i |
	n _ bitLength.
	i _ aByteArray size.
	[n > 0] whileTrue: [
		aByteArray at: i put: (n bitAnd: 16rFF).
		n _ n bitShift: -8.
		i _ i - 1].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SecureHashAlgorithm class
	instanceVariableNames: ''!

!SecureHashAlgorithm class methodsFor: 'class initialization' stamp: 'jm 12/7/1999 23:25'!
initialize
	"SecureHashAlgorithm initialize"
	"For the curious, here's where these constants come from:
	  #(2 3 5 10) collect: [:x | ((x sqrt / 4.0) * (2.0 raisedTo: 32)) truncated hex]"

	K1 _ ThirtyTwoBitRegister new load: 16r5A827999.
	K2 _ ThirtyTwoBitRegister new load: 16r6ED9EBA1.
	K3 _ ThirtyTwoBitRegister new load: 16r8F1BBCDC.
	K4 _ ThirtyTwoBitRegister new load: 16rCA62C1D6.
! !
ClassTestCase subclass: #SecureHashAlgorithmTest
	instanceVariableNames: 'hash'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Digital Signatures-Tests'!
!SecureHashAlgorithmTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class SecureHashAlgorithm. 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!


!SecureHashAlgorithmTest methodsFor: 'testing - examples' stamp: 'md 4/21/2003 12:23'!
testExample1

	"This is the first example from the specification document (FIPS PUB 180-1)"

	hash _ SecureHashAlgorithm new hashMessage: 'abc'.
	self assert: (hash = 16rA9993E364706816ABA3E25717850C26C9CD0D89D).
		! !

!SecureHashAlgorithmTest methodsFor: 'testing - examples' stamp: 'md 4/21/2003 12:23'!
testExample2

	"This is the second example from the specification document (FIPS PUB 180-1)"

	hash _ SecureHashAlgorithm new hashMessage:
		'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'.
	self assert: (hash = 16r84983E441C3BD26EBAAE4AA1F95129E5E54670F1).! !

!SecureHashAlgorithmTest methodsFor: 'testing - examples' stamp: 'md 4/21/2003 12:25'!
testExample3

	"This is the third example from the specification document (FIPS PUB 180-1). 
	This example may take several minutes."

	hash _ SecureHashAlgorithm new hashMessage: (String new: 1000000 withAll: $a).
	self assert: (hash = 16r34AA973CD4C4DAA4F61EEB2BDBAD27316534016F).! !
Object subclass: #SecurityManager
	instanceVariableNames: 'privateKeyPair trustedKeys keysFileName'
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'System-Support'!

!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:19'!
addTrustedKey: aPublicKey
	"Add a public key to the list of trusted keys"
	trustedKeys _ (trustedKeys copyWithout: aPublicKey) copyWith: aPublicKey.! !

!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:17'!
keysFileName
	^keysFileName! !

!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:17'!
keysFileName: aFileName
	keysFileName _ aFileName! !

!SecurityManager methodsFor: 'accessing' stamp: 'tak 3/15/2005 00:45'!
primSecureUserDirectory
	<primitive: 'primitiveGetSecureUserDirectory' module: 'SecurityPlugin'>
	^ nil! !

!SecurityManager methodsFor: 'accessing' stamp: 'tak 3/15/2005 00:46'!
secureUserDirectory
	"SecurityManager default secureUserDirectory"
	| dir |
	dir := self primSecureUserDirectory.
	^ dir
		ifNil: [FileDirectory default pathName]
		ifNotNil: [(FilePath pathName: dir isEncoded: true) asSqueakPathName]! !

!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:20'!
signingKey
	"Return the key used for signing projects"
	^privateKeyPair ifNotNil:[privateKeyPair first]! !

!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:42'!
trustedKeys
	"Return an array of trusted public keys for verifying some project"
	privateKeyPair ifNil:[^trustedKeys].
	^{privateKeyPair second}, trustedKeys! !

!SecurityManager methodsFor: 'accessing' stamp: 'tak 12/17/2004 14:19'!
untrustedUserDirectory
	"SecurityManager default untrustedUserDirectory"
	| dir |
	dir := self primUntrustedUserDirectory.
	^ dir
		ifNil: [FileDirectory default pathName]
		ifNotNil: [(FilePath pathName: dir isEncoded: true) asSqueakPathName]! !


!SecurityManager methodsFor: 'fileIn/out' stamp: 'ar 3/5/2001 01:55'!
loadSecurityKeys
	"SecurityManager default loadSecurityKeys"
	"Load the keys file for the current user"
	| fd loc file keys |
	self isInRestrictedMode ifTrue:[^self]. "no point in even trying"
	loc _ self secureUserDirectory. "where to get it from"
	loc last = FileDirectory pathNameDelimiter ifFalse:[
		loc _ loc copyWith: FileDirectory pathNameDelimiter.
	].
	fd _ FileDirectory on: loc.
	file _ [fd readOnlyFileNamed: keysFileName] 
			on: FileDoesNotExistException do:[:ex| nil].
	file ifNil:[^self]. "no keys file"
	keys _ Object readFrom: file.
	privateKeyPair _ keys first.
	trustedKeys _ keys last.
	file close.! !

!SecurityManager methodsFor: 'fileIn/out' stamp: 'hg 9/29/2001 14:35'!
storeSecurityKeys
	"SecurityManager default storeSecurityKeys"
	"Store the keys file for the current user"
	| fd loc file |
	self isInRestrictedMode ifTrue:[^self]. "no point in even trying"
	loc _ self secureUserDirectory. "where to put it"
	loc last = FileDirectory pathNameDelimiter ifFalse:[
		loc _ loc copyWith: FileDirectory pathNameDelimiter.
	].
	fd _ FileDirectory on: loc.
	fd assureExistence.
	fd deleteFileNamed: self keysFileName ifAbsent:[].
	file _ fd newFileNamed: self keysFileName.
	{privateKeyPair. trustedKeys} storeOn: file.
	file close.! !


!SecurityManager methodsFor: 'initialize-release' stamp: 'ar 2/6/2001 16:24'!
flushSecurityKey: aKey
	"Flush a security key"
	| n |
	n _ aKey first.
	1 to: n basicSize do:[:i| n basicAt: i put: 0].
	n _ aKey second.
	1 to: n basicSize do:[:i| n basicAt: i put: 0].
! !

!SecurityManager methodsFor: 'initialize-release' stamp: 'ar 2/6/2001 16:23'!
flushSecurityKeys
	"Flush all keys"
	privateKeyPair ifNotNil:[
		self flushSecurityKey: privateKeyPair first.
		self flushSecurityKey: privateKeyPair last.
	].
	privateKeyPair _ nil.
	trustedKeys do:[:key| self flushSecurityKey: key].
	trustedKeys _ #().! !

!SecurityManager methodsFor: 'initialize-release' stamp: 'ar 2/6/2001 16:20'!
initialize
	privateKeyPair _ nil.
	trustedKeys _ #().
	keysFileName _ 'Squeak.keys'.! !

!SecurityManager methodsFor: 'initialize-release' stamp: 'ar 2/6/2001 16:22'!
shutDown
	"Flush existing keys"
	self flushSecurityKeys.! !

!SecurityManager methodsFor: 'initialize-release' stamp: 'ar 2/6/2001 18:28'!
startUp
	"Attempt to load existing keys"
	self loadSecurityKeys.
	(privateKeyPair == nil 
		and:[self isInRestrictedMode not
		and:[Preferences automaticKeyGeneration]]) ifTrue:[
			self generateKeyPairInBackground.
	].! !


!SecurityManager methodsFor: 'security operations' stamp: 'ar 2/6/2001 16:14'!
disableFileAccess
	"SecurityManager default disableFileAccess"
	"Primitive. Disable unlimited access to files.
	Cannot be revoked from the image."
	<primitive: 'primitiveDisableFileAccess' module: 'FilePlugin'>
	^self primitiveFailed! !

!SecurityManager methodsFor: 'security operations' stamp: 'ar 2/6/2001 16:15'!
disableImageWrite
	"SecurityManager default disableImageWrite"
	"Primitive. Disable writing to an image file.
	Cannot be revoked from the image."
	<primitive: 'primitiveDisableImageWrite' module: 'SecurityPlugin'>
	^self primitiveFailed! !

!SecurityManager methodsFor: 'security operations' stamp: 'ar 2/6/2001 16:15'!
disableSocketAccess
	"SecurityManage default disableSocketAccess"
	"Primitive. Disable access to sockets.
	Cannot be revoked from the image."
	<primitive: 'primitiveDisableSocketAccess' module: 'SocketPlugin'>
	^self primitiveFailed! !

!SecurityManager methodsFor: 'security operations' stamp: 'rbb 2/18/2005 14:27'!
enterRestrictedMode
	"Some insecure contents was encountered. Close all doors and proceed."
	self isInRestrictedMode ifTrue:[^true].
	Preferences securityChecksEnabled ifFalse:[^true]. "it's been your choice..."
	Preferences warnAboutInsecureContent ifTrue:[
		( UIManager default chooseFrom: #('Load it anyways' 'Do not load it')
			title: 
'You are about to load some insecure content.
If you continue, access to files as well as
some other capabilities will be limited.')
			 = 1 ifFalse:[
				"user doesn't really want it"
				^false.
			].
	].
	"here goes the actual restriction"
	self flushSecurityKeys.
	self disableFileAccess.
	self disableImageWrite.
	"self disableSocketAccess."
	FileDirectory setDefaultDirectory: self untrustedUserDirectory.
	^true
! !

!SecurityManager methodsFor: 'security operations' stamp: 'sd 1/30/2004 15:22'!
fileInObjectAndCode: aStream
	| trusted |
	trusted _ self positionToSecureContentsOf: aStream.
	trusted ifFalse:[self enterRestrictedMode ifFalse:[
		aStream close.
		^nil]].
	^aStream fileInObjectAndCode! !

!SecurityManager methodsFor: 'security operations' stamp: 'RAA 3/2/2002 14:33'!
positionToSecureContentsOf: aStream
	| bytes trusted part1 part2 sig hash dsa okay pos |
	aStream binary.
	pos _ aStream position.
	bytes _ aStream next: 4.
	bytes = 'SPRJ' asByteArray ifFalse:[
		"was not signed"
		aStream position: pos.
		^false].
	part1 _ (aStream nextInto: (LargePositiveInteger basicNew: 20)) normalize.
	part2 _ (aStream nextInto: (LargePositiveInteger basicNew: 20)) normalize.
	sig _ Array with: part1 with: part2.
	hash _ SecureHashAlgorithm new hashStream: aStream.
	dsa _ DigitalSignatureAlgorithm new.
	trusted _ self trustedKeys.
	okay _ (trusted detect:[:key| dsa verifySignature: sig ofMessageHash: hash publicKey: key]
			ifNone:[nil]) notNil.
	aStream position: pos+44.
	^okay! !

!SecurityManager methodsFor: 'security operations' stamp: 'RAA 3/2/2002 14:32'!
signFile: fileName directory: fileDirectory
	"Sign the given project in the directory"
	| bytes file dsa hash sig key |
	Preferences signProjectFiles ifFalse:[^self]. "signing turned off"
	key _ self signingKey.
	key ifNil:[^self].
	file _ FileStream readOnlyFileNamed: (fileDirectory fullNameFor: fileName).
	bytes _ file binary; contentsOfEntireFile.
	fileDirectory deleteFileNamed: fileName ifAbsent:[].
	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandom: Time millisecondClockValue + Date today julianDayNumber.
	hash _ SecureHashAlgorithm new hashStream: (ReadStream on: bytes).
	sig _ dsa computeSignatureForMessageHash: hash privateKey: key.
	file _ FileStream newFileNamed: (fileDirectory fullNameFor: fileName).
	file binary.
	"store a header identifying the signed file first"
	file nextPutAll: 'SPRJ' asByteArray.
	"now the signature"
	file 
		nextPutAll: (sig first withAtLeastNDigits: 20); 
		nextPutAll: (sig last withAtLeastNDigits: 20).
	"now the contents"
	file nextPutAll: bytes.
	file close.! !


!SecurityManager methodsFor: 'testing' stamp: 'ar 2/6/2001 16:14'!
canWriteImage
	"SecurityManager default canWriteImage"
	"Primitive. Return true if the right to write an image hasn't been revoked."
	<primitive: 'primitiveCanWriteImage' module: 'SecurityPlugin'>
	^true "assume so unless otherwise proven"! !

!SecurityManager methodsFor: 'testing' stamp: 'ar 2/6/2001 16:16'!
hasFileAccess
	"SecurityManager default hasFileAccess"
	"Return true if the right to access arbitrary files hasn't been revoked"
	<primitive: 'primitiveHasFileAccess' module: 'FilePlugin'>
	^true "assume so unless otherwise proven"! !

!SecurityManager methodsFor: 'testing' stamp: 'ar 2/6/2001 16:16'!
hasSocketAccess
	"SecurityManager default hasSocketAccess"
	"Return true if the right to access sockets hasn't been revoked"
	<primitive: 'primitiveHasSocketAccess' module: 'SocketPlugin'>
	^true "assume so unless otherwise proven"! !

!SecurityManager methodsFor: 'testing' stamp: 'ar 2/6/2001 16:13'!
isInRestrictedMode
	"Return true if we're in restricted mode"
	^(self canWriteImage 
		or:[self hasFileAccess 
		"or:[self hasSocketAccess]"]) not! !


!SecurityManager methodsFor: 'private' stamp: 'ar 5/8/2001 16:41'!
generateKeyPairInBackground
	"SecurityManager default generateKeyPairInBackground"
	"Silently generate a key set on the local machine while running in the background."
	| guesstimate startTime |
	guesstimate _ [10 benchmark] timeToRun * 150.
	startTime _ Time millisecondClockValue.
	privateKeyPair _ nil.
	[self generateLocalKeyPair] fork.
	Utilities informUserDuring:[:bar|
		[privateKeyPair == nil] whileTrue:[
			bar value:'Initializing Squeak security system (', (Time millisecondClockValue - startTime * 100 // guesstimate) printString,'%)'.
			(Delay forSeconds: 1) wait.
		].
	].
! !

!SecurityManager methodsFor: 'private' stamp: 'sd 9/30/2003 13:58'!
generateLocalKeyPair
	"SecurityManager default generateLocalKeyPair"
	"Generate a key set on the local machine."
	| dsa |
	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandomFromString: 
		Time millisecondClockValue printString, 
		Date today printString, 
		SmalltalkImage current platformName printString.
	privateKeyPair _ dsa generateKeySet.
	self storeSecurityKeys.! !

!SecurityManager methodsFor: 'private' stamp: 'tak 12/17/2004 14:15'!
primUntrustedUserDirectory
	"Primitive. Return the untrusted user directory that is the root directory for files that are visible even in restricted mode."
	<primitive: 'primitiveGetUntrustedUserDirectory' module: 'SecurityPlugin'>
	^ nil! !

!SecurityManager methodsFor: 'private' stamp: 'mir 11/10/2003 16:14'!
printStateOn: stream
	"Print the current state of myself onto stream.
	Used to gather information in the debug log."

	stream
		nextPutAll: 'SecurityManager state:'; cr;
		nextPutAll: 'Restricted: '; nextPutAll: self isInRestrictedMode asString; cr;
		nextPutAll: 'FileAccess: '; nextPutAll: self hasFileAccess asString; cr;
		nextPutAll: 'SocketAccess: '; nextPutAll: self hasSocketAccess asString; cr;
		nextPutAll: 'Working Dir '; nextPutAll: FileDirectory default pathName asString; cr;
		nextPutAll: 'Trusted Dir '; nextPutAll: self secureUserDirectory asString; cr;
		nextPutAll: 'Untrusted Dir '; nextPutAll: self untrustedUserDirectory asString; cr;
		cr! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SecurityManager class
	instanceVariableNames: ''!

!SecurityManager class methodsFor: 'accessing' stamp: 'nk 7/30/2004 21:50'!
default
	^Default ifNil: [Default := self new]! !


!SecurityManager class methodsFor: 'class initialization' stamp: 'nk 7/30/2004 21:50'!
initialize
	"SecurityManager initialize"

	"Order: ExternalSettings, SecurityManager, AutoStart"

	Default := self new.
	Smalltalk addToStartUpList: self after: ExternalSettings.
	Smalltalk addToShutDownList: self! !

!SecurityManager class methodsFor: 'class initialization' stamp: 'ar 2/6/2001 16:46'!
shutDown
	self default shutDown.! !

!SecurityManager class methodsFor: 'class initialization' stamp: 'ar 2/6/2001 17:12'!
startUp
	self default startUp.! !
CompositionScanner subclass: #SegmentScanner
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Text'!

!SegmentScanner methodsFor: 'as yet unclassified' stamp: 'ar 5/18/2000 16:48'!
setFont
	super setFont.
	"Make a local copy of stop conditions so we don't modify the default"
	stopConditions == DefaultStopConditions 
		ifTrue:[stopConditions _ stopConditions copy].
	stopConditions at: Space asciiValue + 1 put: nil.! !
ImageMorph subclass: #SelectedObjectThumbnail
	instanceVariableNames: 'noSelectedThumbnail noSelectedBalloonText'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!SelectedObjectThumbnail methodsFor: 'initialization' stamp: 'dgd 9/10/2004 19:00'!
initialize
	"Initialize the receiver"
	super initialize.
	""
	self
		image: (Form extent:32@32).
	self color: Color transparent! !

!SelectedObjectThumbnail methodsFor: 'initialization' stamp: 'dgd 9/10/2004 19:29'!
initializeExtent: aPoint noSelectedThumbnail: aForm noSelectedBalloonText: aString 
	self
		image: (Form extent: aPoint).
""
	noSelectedThumbnail := aForm.
	noSelectedBalloonText := aString! !


!SelectedObjectThumbnail methodsFor: 'private' stamp: 'dgd 9/10/2004 18:43'!
makeEmptyThumbnail

^ self makeThumbnailOfColor: Color veryLightGray.
! !

!SelectedObjectThumbnail methodsFor: 'private' stamp: 'dgd 9/10/2004 18:43'!
makeErrorThumbnail
	^ self makeThumbnailOfColor: Color red! !

!SelectedObjectThumbnail methodsFor: 'private' stamp: 'dgd 9/13/2004 12:57'!
makeThumbnailFrom: aMorphOrNil 
	| thumbnail |
	thumbnail := aMorphOrNil isNil
				ifTrue: [noSelectedThumbnail
						ifNil: [self makeEmptyThumbnail]]
				ifFalse: [aMorphOrNil iconOrThumbnail]. 
	""
	self
		image: (thumbnail scaledIntoFormOfSize: self extent)! !

!SelectedObjectThumbnail methodsFor: 'private' stamp: 'dgd 9/10/2004 18:43'!
makeThumbnailOfColor: aColor 
	| form |
	form := Form extent: self extent depth: 32.
	form getCanvas fillColor: aColor.
	self image: form! !


!SelectedObjectThumbnail methodsFor: 'accessing' stamp: 'dgd 9/10/2004 19:28'!
noSelectedBalloonText: aString 
	"Set the balloon text to be used when no object is selected"
	noSelectedBalloonText := aString! !

!SelectedObjectThumbnail methodsFor: 'accessing' stamp: 'dgd 9/10/2004 19:27'!
noSelectedThumbnail: aForm 
	"Set the form to be used when no object is selected"
	noSelectedThumbnail := aForm! !


!SelectedObjectThumbnail methodsFor: 'stepping and presenter' stamp: 'dgd 9/10/2004 19:29'!
step
	| current |
	current := self selectedObject.

	self setBalloonText: (current isNil
				ifTrue: [noSelectedBalloonText]
				ifFalse: [current externalName]).
	""
	self makeThumbnailFrom: current! !

!SelectedObjectThumbnail methodsFor: 'stepping and presenter' stamp: 'dgd 9/10/2004 18:36'!
stepTime
	^ 125! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SelectedObjectThumbnail class
	instanceVariableNames: ''!

!SelectedObjectThumbnail class methodsFor: 'instance creation' stamp: 'dgd 9/10/2004 19:31'!
extent: aPoint noSelectedThumbnail: aForm noSelectedBalloonText: aString 
	^ self new
		initializeExtent: aPoint
		noSelectedThumbnail: aForm
		noSelectedBalloonText: aString ! !
PopUpMenu subclass: #SelectionMenu
	instanceVariableNames: 'selections'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Menus'!

!SelectionMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:38'!
selections
	^ selections! !

!SelectionMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:38'!
selections: selectionArray
	selections _ selectionArray! !


!SelectionMenu methodsFor: 'basic control sequence' stamp: 'sma 5/28/2000 15:28'!
invokeOn: targetObject
	"Pop up this menu and return the result of sending to the target object 
	the selector corresponding to the menu item selected by the user. Return 
	nil if no item is selected."

	| sel |
	sel _ self startUp.
	sel = nil ifFalse: [^ targetObject perform: sel].
	^ nil

"Example:
	(SelectionMenu labels: 'sin
cos
neg' lines: #() selections: #(sin cos negated)) invokeOn: 0.7"! !

!SelectionMenu methodsFor: 'basic control sequence' stamp: 'sw 12/17/2001 17:26'!
startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean
	"Overridden to return value returned by manageMarker.  The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)"

	| index |
	index _ super startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean.
	(selections = nil or: [(index between: 1 and: selections size) not])
		ifTrue: [^ nil].
	^ selections at: index! !


!SelectionMenu methodsFor: 'invocation' stamp: 'sw 11/18/2002 16:24'!
invokeOn: targetObject orSendTo: anObject
	"Pop up the receiver, obtaining a selector; return the result of having the target object perform the selector.  If it dos not understand the selector, give the alternate object a chance"

	| aSelector |
	^ (aSelector _ self startUp) ifNotNil:
		[(targetObject respondsTo: aSelector)
			ifTrue:
				[targetObject perform: aSelector]
			ifFalse:
				[anObject perform: aSelector]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SelectionMenu class
	instanceVariableNames: ''!

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sw 11/8/1999 17:52'!
fromArray: anArray
	"Construct a menu from anArray.  The elements of anArray must be either:
	*  A pair of the form: <label> <selector>
or	*  The 'dash' (or 'minus sign') symbol

	Refer to the example at the bottom of the method"

	| labelList lines selections anIndex |
	labelList _ OrderedCollection new.
	lines _ OrderedCollection new.
	selections _ OrderedCollection new.
	anIndex _ 0.
	anArray do:
		[:anElement |
			anElement size == 1
				ifTrue:
					[(anElement == #-) ifFalse: [self error: 'badly-formed menu constructor'].
					lines add: anIndex]
				ifFalse:
					[anElement size == 2 ifFalse: [self error: 'badly-formed menu constructor'].
					anIndex _ anIndex + 1.
					labelList add: anElement first.
					selections add: anElement second]].
	^ self labelList: labelList lines: lines selections: selections

"(SelectionMenu fromArray:
	#(	('first label'		moja)
		('second label'	mbili)
		-
		('third label' 	tatu)
		-
		('fourth label'	nne)
		('fifth label'	tano))) startUp"! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'!
labelList: labelList
	^ self labelArray: labelList! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'!
labelList: labelList lines: lines
	^ self labelArray: lines lines: lines! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'!
labelList: labelList lines: lines selections: selections
	^ (self labelArray: labelList lines: lines) selections: selections! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'!
labelList: labelList selections: selections
	^ self
		labelList: labelList
		lines: #()
		selections: selections! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 17:00'!
labels: labels lines: linesArray
	"Answer an instance of me whose items are in labels, with lines drawn  
	after each item indexed by linesArray. Labels can be either a string 
	with embedded CRs, or a collection of strings."

	(labels isString)
		ifTrue: [^ super labels: labels lines: linesArray]
		ifFalse: [^ super labelArray: labels lines: linesArray]! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 17:02'!
labels: labels lines: linesArray selections: selectionsArray
	"Answer an instance of me whose items are in labels, with lines drawn  
	after each item indexed by linesArray. Labels can be either a string  
	with embedded CRs, or a collection of strings. Record the given array of 
	selections corresponding to the items in labels."

	| labelString |
	(labels isString)
		ifTrue: [labelString _ labels]
		ifFalse: [labelString _ String streamContents:
					[:s |
					labels do: [:l | s nextPutAll: l; cr].
					s skip: -1]].
	^ (self labels: labelString lines: linesArray) selections: selectionsArray
! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'!
labels: labels selections: selectionsArray
	"Answer an instance of me whose items are in labels, recording 
	the given array of selections corresponding to the items in labels."

	^ self
		labels: labels
		lines: #()
		selections: selectionsArray! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'!
selections: selectionsArray
	"Answer an instance of me whose labels and selections are identical."

	^ self selections: selectionsArray lines: nil! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'!
selections: selectionsArray lines: linesArray
	"Answer an instance of me whose labels and selections are identical."

	^ self
		labelList: (selectionsArray collect: [:each | each asString])
		lines: linesArray
		selections: selectionsArray! !
BorderedMorph subclass: #SelectionMorph
	instanceVariableNames: 'selectedItems slippage dupLoc dupDelta itemsAlreadySelected otherSelection undoProperties'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!SelectionMorph commentStamp: '<historical>' prior: 0!
A selectionMorph supports the selection of multiple objects in a morphic world or pasteUp.

Structure:
	selectedItems	an OrderedCollection of Morphs
					These are the morphs that have been selected
	slippage		a Point
					Keeps track of actual movement between the 
					steps of gridded movement
	dupLoc		a Point
					Notes the position when first duplicate request occurs from halo
	dupDelta	a Point
					Holds the final delta of the first duplicate plus subsequent moves.
!


!SelectionMorph methodsFor: 'accessing' stamp: 'nk 9/4/2004 17:33'!
borderColor: aColor

	| bordered |
	bordered _ selectedItems.
	undoProperties ifNil: [undoProperties _ bordered collect: [:m | m borderColor]].
	bordered do: [:m | m borderColor: aColor]! !

!SelectionMorph methodsFor: 'accessing' stamp: 'di 9/19/2000 18:25'!
borderWidth: aWidth

	| bordered |
	bordered _ selectedItems select: [:m | m isKindOf: BorderedMorph].
	undoProperties ifNil: [undoProperties _ bordered collect: [:m | m borderWidth]].
	bordered do: [:m | m borderWidth: aWidth]! !

!SelectionMorph methodsFor: 'accessing' stamp: 'dgd 9/11/2004 21:57'!
wantsToBeTopmost
	"Answer if the receiver want to be one of the topmost objects in 
	its owner"
	^ true! !



!SelectionMorph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:25'!
drawOn: aCanvas

	| canvas form1 form2 box |
	super drawOn: aCanvas.
	box _ self bounds.
	selectedItems do: [:m | box _ box merge: m fullBounds].
	box _ box expandBy: 1.
	canvas _ Display defaultCanvasClass extent: box extent depth: 8.
	canvas translateBy: box topLeft negated
		during: [:tempCanvas | selectedItems do: [:m | tempCanvas fullDrawMorph: m]].
	form1 _ (Form extent: box extent) copyBits: (0@0 extent: box extent) from: canvas form at: 0@0 colorMap: (Color maskingMap: 8).
	form2 _ Form extent: box extent.
	(0@0) fourNeighbors do: [:d | form1 displayOn: form2 at: d rule: Form under].
	form1 displayOn: form2 at: 0@0 rule: Form erase.
	aCanvas stencil: form2
		at: box topLeft
		sourceRect: form2 boundingBox
		color: self borderColor
! !


!SelectionMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/10/2000 15:02'!
aboutToBeGrabbedBy: aHand
	slippage _ 0@0.
	^ super aboutToBeGrabbedBy: aHand
! !

!SelectionMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 9/11/2004 22:00'!
justDroppedInto: newOwner event: evt

	selectedItems isEmpty ifTrue:
		["Hand just clicked down to draw out a new selection"
		^ self extendByHand: evt hand].
	dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
	selectedItems reverseDo: [:m | 
		WorldState addDeferredUIMessage:
			[m referencePosition: (newOwner localPointToGlobal: m referencePosition).
			newOwner handleDropMorph:
				(DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)] fixTemps].
	evt wasHandled: true! !

!SelectionMorph methodsFor: 'dropping/grabbing' stamp: 'nk 6/26/2002 08:23'!
slideToTrash: evt
	self delete.
	selectedItems do: [:m | m slideToTrash: evt]! !


!SelectionMorph methodsFor: 'geometry' stamp: 'jcg 2/14/2001 08:58'!
bounds: newBounds
	"Make sure position: gets called before extent:; Andreas' optimization for growing/shrinking in ChangeSet 3119 screwed up selection of morphs from underlying pasteup."

	selectedItems _ OrderedCollection new.  "Avoid repostioning items during super position:"
	self position: newBounds topLeft; extent: newBounds extent
! !

!SelectionMorph methodsFor: 'geometry' stamp: 'di 8/31/2000 18:39'!
extent: newExtent

	super extent: newExtent.
	self selectSubmorphsOf: self pasteUpMorph! !


!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:53'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add custom menu items to the menu"

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu addLine.
	aMenu add: 'add or remove items' translated target: self selector: #addOrRemoveItems: argument: aHandMorph.
	aMenu addList: {
		#-.
		{'place into a row' translated. #organizeIntoRow}.
		{'place into a column' translated. #organizeIntoColumn}.
		#-.
		{'align left edges' translated. #alignLeftEdges}.
		{'align top edges' translated. #alignTopEdges}.
		{'align right edges' translated. #alignRightEdges}.
		{'align bottom edges' translated. #alignBottomEdges}.
		#-.
		{'align centers vertically' translated. #alignCentersVertically}.
		{'align centers horizontally' translated. #alignCentersHorizontally}.
		}.

	self selectedItems size > 2
		ifTrue:[
			aMenu addList: {
				#-.
				{'distribute vertically' translated. #distributeVertically}.
				{'distribute horizontally' translated. #distributeHorizontally}.
				}.
		].
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 10/26/2004 14:53'!
addOrRemoveItems: handOrEvent 
	"Make a new selection extending the current one."

	| hand |
	hand := (handOrEvent isMorphicEvent) 
				ifFalse: [handOrEvent]
				ifTrue: [handOrEvent hand].
	hand 
		addMorphBack: ((self class 
				newBounds: (hand lastEvent cursorPoint extent: 16 @ 16)) 
					setOtherSelection: self).
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:40'!
alignBottomEdges
	"Make the bottom coordinate of all my elements be the same"

	| maxBottom |
	maxBottom _ (selectedItems collect: [:itm | itm bottom]) max.
	selectedItems do:
		[:itm | itm bottom: maxBottom].

	self changed
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:41'!
alignCentersHorizontally
	"Make every morph in the selection have the same vertical center as the topmost item."

	| minLeft leftMost |
	selectedItems size > 1 ifFalse: [^ self].
	minLeft _ (selectedItems collect: [:itm | itm left]) min.
	leftMost _ selectedItems detect: [:m | m left = minLeft].
	selectedItems do:
		[:itm | itm center: (itm center x @ leftMost center y)].

	self changed
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:41'!
alignCentersVertically
	"Make every morph in the selection have the same horizontal center as the topmost item."

	| minTop topMost |
	selectedItems size > 1 ifFalse: [^ self].
	minTop _ (selectedItems collect: [:itm | itm top]) min.
	topMost _ selectedItems detect: [:m | m top = minTop].
	selectedItems do:
		[:itm | itm center: (topMost center x @ itm center y)].

	self changed
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:41'!
alignLeftEdges
	"Make the left coordinate of all my elements be the same"

	| minLeft |
	minLeft _ (selectedItems collect: [:itm | itm left]) min.
	selectedItems do:
		[:itm | itm left: minLeft].

	self changed
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:41'!
alignRightEdges
	"Make the right coordinate of all my elements be the same"

	| maxRight |
	maxRight _ (selectedItems collect: [:itm | itm right]) max.
	selectedItems do:
		[:itm | itm right: maxRight].

	self changed
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:50'!
alignTopEdges
	"Make the top coordinate of all my elements be the same"

	| minTop |
	minTop _ (selectedItems collect: [:itm | itm top]) min.
	selectedItems do:
		[:itm | itm top: minTop].

	self changed
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:50'!
distributeHorizontally
	"Distribute the empty vertical space in a democratic way."
	| minLeft maxRight totalWidth currentLeft space |

	self selectedItems size > 2
		ifFalse: [^ self].

	minLeft := self selectedItems anyOne left.
	maxRight := self selectedItems anyOne right.
	totalWidth := 0.
	self selectedItems
		do: [:each | 
			minLeft := minLeft min: each left.
			maxRight := maxRight max: each right.
			totalWidth := totalWidth + each width].

	currentLeft := minLeft.
	space := (maxRight - minLeft - totalWidth / (self selectedItems size - 1)) rounded.
	(self selectedItems
		asSortedCollection: [:x :y | x left <= y left])
		do: [:each | 
			each left: currentLeft.
			currentLeft := currentLeft + each width + space].

	self changed
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:51'!
distributeVertically
	"Distribute the empty vertical space in a democratic way."
	| minTop maxBottom totalHeight currentTop space |
	self selectedItems size > 2
		ifFalse: [^ self].

	minTop := self selectedItems anyOne top.
	maxBottom := self selectedItems anyOne bottom.
	totalHeight := 0.
	self selectedItems
		do: [:each | 
			minTop := minTop min: each top.
			maxBottom := maxBottom max: each bottom.
			totalHeight := totalHeight + each height].

	currentTop := minTop.
	space := (maxBottom - minTop - totalHeight / (self selectedItems size - 1)) rounded.
	(self selectedItems asSortedCollection:[:x :y | x top <= y top])
		do: [:each | 
			each top: currentTop.
			currentTop := currentTop + each height + space].

	self changed
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'md 11/14/2003 17:18'!
doDup: evt fromHalo: halo handle: dupHandle

	selectedItems _ self duplicateMorphCollection: selectedItems.
	selectedItems do: [:m | self owner addMorph: m].
	dupDelta isNil
		ifTrue: ["First duplicate operation -- note starting location"
				dupLoc _ self position.
				evt hand grabMorph: self.
				halo removeAllHandlesBut: dupHandle]
		ifFalse: ["Subsequent duplicate does not grab, but only moves me and my morphs"
				dupLoc _ nil.
				self position: self position + dupDelta]
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'sw 4/19/2005 18:14'!
duplicate
	"Make a duplicate of the receiver and havbe the hand grab it"

	selectedItems _ self duplicateMorphCollection: selectedItems.
	selectedItems reverseDo: [:m | (owner ifNil: [ActiveWorld]) addMorph: m].
	dupLoc _ self position.
	ActiveHand grabMorph: self.
	ActiveWorld presenter flushPlayerListCache! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'tb 8/10/2003 14:47'!
organizeIntoColumn
	"Place my objects in a column-enforcing container"

	((AlignmentMorph inAColumn: (selectedItems asSortedCollection: [:x :y | x top < y top])) setNameTo: 'Column'; color: Color orange muchLighter; enableDragNDrop: true; yourself) openInHand
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'tb 8/10/2003 14:48'!
organizeIntoRow
	"Place my objects in a row-enforcing container"

	((AlignmentMorph inARow: (selectedItems asSortedCollection: [:x :y | x left < y left])) setNameTo: 'Row'; color: Color orange muchLighter; enableDragNDrop: true; yourself) openInHand
! !


!SelectionMorph methodsFor: 'halos and balloon help' stamp: 'di 8/31/2000 22:29'!
addHandlesTo: aHaloMorph box: box
	| onlyThese |
	aHaloMorph haloBox: box.
	onlyThese _ #(addDismissHandle: addMenuHandle: addGrabHandle: addDragHandle: addDupHandle: addHelpHandle: addGrowHandle: addFontSizeHandle: addFontStyleHandle: addFontEmphHandle: addRecolorHandle:).
	Preferences haloSpecifications do:
		[:aSpec | (onlyThese includes: aSpec addHandleSelector) ifTrue:
				[aHaloMorph perform: aSpec addHandleSelector with: aSpec]].
	aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! !

!SelectionMorph methodsFor: 'halos and balloon help' stamp: 'di 8/31/2000 22:59'!
addOptionalHandlesTo: aHalo box: box
	aHalo addHandleAt: box leftCenter color: Color blue icon: nil
		on: #mouseUp send: #addOrRemoveItems: to: self.! !

!SelectionMorph methodsFor: 'halos and balloon help' stamp: 'di 8/31/2000 22:59'!
balloonHelpTextForHandle: aHandle
	aHandle eventHandler firstMouseSelector == #addOrRemoveItems:
		ifTrue: [^'Add items to, or remove them from, this selection.'].
	^ super balloonHelpTextForHandle: aHandle! !

!SelectionMorph methodsFor: 'halos and balloon help' stamp: 'dgd 9/11/2004 18:29'!
hasHalo: aBool 
	super hasHalo: aBool.
	aBool
		ifFalse: [ (self hasProperty: #deleting) ifFalse: [self delete] ]
! !


!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 9/20/2004 13:57'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ (Preferences menuSelectionColor ifNil: [Color blue]) twiceDarker alpha: 0.75! !

!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 8/28/2004 19:00'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 2! !

!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 9/20/2004 14:00'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ (Preferences menuSelectionColor ifNil: [Color blue]) alpha: 0.08
! !

!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 9/11/2004 21:07'!
extendByHand: aHand
	"Assumes selection has just been created and added to some pasteUp or world"
	| startPoint handle |

	startPoint := self position.

	handle := NewHandleMorph new followHand: aHand
		forEachPointDo: [:newPoint |
					| localPt |
					localPt := (self transformFrom: self world) globalPointToLocal: newPoint.
					self bounds: (startPoint rect: localPt)
				]
		lastPointDo: [:newPoint |
					selectedItems isEmpty
						ifTrue: [self delete]
						ifFalse: [
							selectedItems size = 1
								ifTrue:[self delete.  selectedItems anyOne addHalo]
								ifFalse:[self doneExtending]
						]
				].

	aHand attachMorph: handle.
	handle startStepping.! !

!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:23'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	selectedItems _ OrderedCollection new.
	itemsAlreadySelected _ OrderedCollection new.
	slippage _ 0 @ 0! !


!SelectionMorph methodsFor: 'menus' stamp: 'di 8/31/2000 20:50'!
maybeAddCollapseItemTo: aMenu
	"... don't "! !


!SelectionMorph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/11/2004 18:27'!
delete
	self setProperty: #deleting toValue: true.
	super delete.
	! !

!SelectionMorph methodsFor: 'submorphs-add/remove' stamp: 'di 8/23/2000 17:06'!
dismissViaHalo

	super dismissViaHalo.
	selectedItems do: [:m | m dismissViaHalo]! !


!SelectionMorph methodsFor: 'undo' stamp: 'di 8/31/2000 00:24'!
borderColorForItems: colorCollection

	(selectedItems select: [:m | m isKindOf: BorderedMorph])
		with: colorCollection
		do: [:m :c | m borderColor: c]! !

!SelectionMorph methodsFor: 'undo' stamp: 'di 8/31/2000 00:26'!
borderWidthForItems: widthCollection

	(selectedItems select: [:m | m isKindOf: BorderedMorph])
		with: widthCollection
		do: [:m :c | m borderWidth: c]! !

!SelectionMorph methodsFor: 'undo' stamp: 'di 9/19/2000 21:53'!
fillStyleForItems: fillStyleCollection

	selectedItems with: fillStyleCollection do: [:m :c | m fillStyle: c]! !

!SelectionMorph methodsFor: 'undo' stamp: 'di 9/19/2000 21:52'!
refineUndoTarget: target selector: selector arguments: arguments in: refineBlock
	"Any morph can override this method to refine its undo specification"
	selector == #fillStyle: ifTrue:
		[refineBlock value: target value: #fillStyleForItems: value: {undoProperties}.
		^ undoProperties _ nil].
	selector == #borderColor: ifTrue:
		[refineBlock value: target value: #borderColorForItems: value: {undoProperties}.
		^ undoProperties _ nil].
	selector == #borderWidth: ifTrue:
		[refineBlock value: target value: #borderWidthForItems: value: {undoProperties}.
		^ undoProperties _ nil].
	selector == #undoMove:redo:owner:bounds:predecessor: ifTrue:
		["This is the biggy.  Need to gather parameters for all selected items"
		refineBlock value: target
			value: #undoMove:redo:owner:bounds:predecessor:
			value: {arguments first.
					arguments second.
					selectedItems collect: [:m | m owner].
					selectedItems collect: [:m | m bounds].
					selectedItems collect: [:m | m owner morphPreceding: m]}].
	refineBlock value: target value: selector value: arguments! !

!SelectionMorph methodsFor: 'undo' stamp: 'jm 2/25/2003 16:27'!
undoMove: cmd redo: redo owner: oldOwners bounds: oldBoundses predecessor: oldPredecessors 
	"Handle undo and redo of move commands in morphic"

	| item |
	redo 
		ifFalse: 
			["undo sets up the redo state first"

			cmd 
				redoTarget: self
				selector: #undoMove:redo:owner:bounds:predecessor:
				arguments: { 
						cmd.
						true.
						selectedItems collect: [:m | m owner].
						selectedItems collect: [:m | m bounds].
						selectedItems collect: [:m | m owner morphPreceding: m]}].
	1 to: selectedItems size do: 
				[:i | 
				item := selectedItems at: i.
				(oldOwners at: i) ifNotNil: 
						[(oldPredecessors at: i) ifNil: [(oldOwners at: i) addMorphFront: item]
							ifNotNil: [(oldOwners at: i) addMorph: item after: (oldPredecessors at: i)]].
				item bounds: (oldBoundses at: i).
				item isSystemWindow ifTrue: [item activate]]! !


!SelectionMorph methodsFor: 'viewer' stamp: 'dgd 8/29/2004 12:34'!
externalName
	^ 'Selected {1} objects' translated format:{self selectedItems size}! !


!SelectionMorph methodsFor: 'visual properties' stamp: 'di 9/19/2000 21:53'!
fillStyle: aColor
	undoProperties ifNil: [undoProperties _ selectedItems collect: [:m | m fillStyle]].
	selectedItems do: [:m | m fillStyle: aColor]! !


!SelectionMorph methodsFor: 'private' stamp: 'dgd 9/20/2004 14:01'!
doneExtending

	otherSelection ifNotNil:
		[selectedItems _ otherSelection selectedItems , selectedItems.
		otherSelection delete.
		self setOtherSelection: nil].
	self changed.
	self layoutChanged.
	super privateBounds:
		((Rectangle merging: (selectedItems collect: [:m | m fullBounds]))
			expandBy: 8).
	self changed.
	self addHalo.! !

!SelectionMorph methodsFor: 'private' stamp: 'nk 8/14/2003 08:12'!
privateFullMoveBy: delta

	| griddedDelta griddingMorph |
	selectedItems isEmpty ifTrue: [^ super privateFullMoveBy: delta].
	griddingMorph _ self pasteUpMorph.
	griddingMorph ifNil: [^ super privateFullMoveBy: delta].
	griddedDelta _ (griddingMorph gridPoint: self position + delta + slippage) -
					(griddingMorph gridPoint: self position).
	slippage _ slippage + (delta - griddedDelta).  "keep track of how we lag the true movement."
	griddedDelta = (0@0) ifTrue: [^ self].
	super privateFullMoveBy: griddedDelta.
	selectedItems do:
		[:m | m position: (m position + griddedDelta) ]
! !

!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 21:36'!
selectedItems

	^ selectedItems! !

!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 22:12'!
selectSubmorphsOf: aMorph

	| newItems removals |
	newItems _ aMorph submorphs select:
		[:m | (bounds containsRect: m fullBounds) 
					and: [m~~self
					and: [(m isKindOf: HaloMorph) not]]].
	otherSelection ifNil: [^ selectedItems _ newItems].

	removals _ newItems intersection: itemsAlreadySelected.
	otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
	selectedItems _ (newItems copyWithoutAll: removals).
! !

!SelectionMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 23:18'!
setOtherSelection: otherOrNil 
	otherSelection := otherOrNil.
	otherOrNil isNil 
		ifTrue: [super borderColor: Color blue]
		ifFalse: 
			[itemsAlreadySelected := otherSelection selectedItems.
			super borderColor: Color green]! !

!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 21:45'!
setSelectedItems: items

	selectedItems _ items.
	self changed! !


!SelectionMorph methodsFor: 'testing' stamp: 'sw 3/30/2005 04:17'!
couldMakeSibling
	"Answer whether it is appropriate to ask the receiver to make a sibling"

	^ false! !

!SelectionMorph methodsFor: 'testing' stamp: 'sw 3/30/2005 04:30'!
preferredDuplicationHandleSelector
	"Answer the selector, to be offered as the default in a halo open on me"

	^ #addDupHandle:! !


!SelectionMorph methodsFor: 'WiW support' stamp: 'dgd 9/11/2004 21:58'!
morphicLayerNumber
	"helpful for insuring some morphs always appear in front of or  
	behind others. smaller numbers are in front"
	^ 8! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SelectionMorph class
	instanceVariableNames: ''!

!SelectionMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'!
defaultNameStemForInstances
	^ 'Selection'! !
StringHolder subclass: #SelectorBrowser
	instanceVariableNames: 'selectorIndex selectorList classListIndex classList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 12/1/2000 10:38'!
byExample
	"The comment in the bottom pane"

	false ifTrue: [MethodFinder methodFor: #( (4 3) 7  (0 5) 5  (5 5) 10)].
		"to keep the method methodFor: from being removed from the system"

	^ 'Type a fragment of a selector in the top pane.  Accept it.

Or, use an example to find a method in the system.  Type receiver, args, and answer in the top pane with periods between the items.  3. 4. 7

Or, in this pane, use examples to find a method in the system.  Select the line of code and choose "print it".  

	MethodFinder methodFor: #( (4 3) 7  (0 5) 5  (5 5) 10).
This will discover (data1 + data2).

You supply inputs and answers and the system will find the method.  Each inner array is a list of inputs.  It contains the receiver and zero or more arguments.  For Booleans and any computed arguments, use brace notation.

	MethodFinder methodFor: { {1. 3}. true.  {20. 10}. false}.
This will discover the expressions (data1 < data2), (data2 > data1), and many others.

	MethodFinder methodFor: { {''29 Apr 1999'' asDate}. ''Thursday''.  
		{''30 Apr 1999'' asDate}. ''Friday'' }.
This will discover the expression (data1 weekday)

Receiver and arguments do not have to be in the right order.
See MethodFinder.verify for more examples.'! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 3/29/1999 22:12'!
byExample: newText
	"Don't save it"
	^ true! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 14:20'!
classList
	^ classList! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 14:23'!
classListIndex
	^ classListIndex! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
classListIndex: anInteger

	classListIndex := anInteger.
	classListIndex > 0 ifTrue:
		[self dependents do:
			[:dep | ((dep isKindOf: PluggableListView) and:
				[dep setSelectionSelectorIs: #classListIndex:])
					ifTrue: [dep controller controlTerminate]].
		Browser fullOnClass: self selectedClass selector: self selectedMessageName.
		"classListIndex := 0"]
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 14:33'!
classListSelectorTitle
	^ 'Class List Menu'! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
contents: aString notifying: aController
	"Take what the user typed and find all selectors containing it"

	| tokens raw sorted |
	contents := aString.
	classList := #().  classListIndex := 0.
	selectorIndex := 0.
	tokens := contents asString findTokens: ' .'.
	selectorList := Cursor wait showWhile: [
		tokens size = 1 
			ifTrue: [raw := (Symbol selectorsContaining: contents asString).
				sorted := raw as: SortedCollection.
				sorted sortBlock: [:x :y | x asLowercase <= y asLowercase].
				sorted asArray]
			ifFalse: [self quickList]].	"find selectors from a single example of data"
	self changed: #messageList.
	self changed: #classList.
	^ true! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
implementors
	| aSelector |
	(aSelector := self selectedMessageName) ifNotNil:
		[self systemNavigation browseAllImplementorsOf: aSelector]! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 11/9/1999 10:07'!
initialExtent

	^ 350@250
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 1/8/2001 18:21'!
listFromResult: resultOC
	"ResultOC is of the form #('(data1 op data2)' '(...)'). Answer a sorted array."

	(resultOC first beginsWith: 'no single method') ifTrue: [^ #()].
	^ resultOC sortBy: [:a :b | 
		(a copyFrom: 6 to: a size) < (b copyFrom: 6 to: b size)].

! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
markMatchingClasses
	"If an example is used, mark classes matching the example instance with an asterisk."

	| unmarkedClassList firstPartOfSelector receiverString receiver |

	self flag: #mref.	"allows for old-fashioned style"

	"Only 'example' queries can be marked."
	(contents asString includes: $.) ifFalse: [^ self].

	unmarkedClassList := classList copy.

	"Get the receiver object of the selected statement in the message list."
	firstPartOfSelector := (Scanner new scanTokens: (selectorList at: selectorIndex)) second.
	receiverString := (ReadStream on: (selectorList at: selectorIndex))
						upToAll: firstPartOfSelector.
	receiver := Compiler evaluate: receiverString.

	unmarkedClassList do: [ :classAndMethod | | class |
		(classAndMethod isKindOf: MethodReference) ifTrue: [
			(receiver isKindOf: classAndMethod actualClass) ifTrue: [
				classAndMethod stringVersion: '*', classAndMethod stringVersion.
			]
		] ifFalse: [
			class := Compiler evaluate:
					((ReadStream on: classAndMethod) upToAll: firstPartOfSelector).
			(receiver isKindOf: class) ifTrue: [
				classList add: '*', classAndMethod.
				classList remove: classAndMethod
			]
		].
	].
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 14:19'!
messageList
	"Find all the selectors containing what the user typed in."

	^ selectorList! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 10:58'!
messageListIndex
	"Answer the index of the selected message selector."

	^ selectorIndex! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
messageListIndex: anInteger 
	"Set the selected message selector to be the one indexed by anInteger. 
	Find all classes it is in."
	selectorIndex := anInteger.
	selectorIndex = 0
		ifTrue: [^ self].
	classList := self systemNavigation allImplementorsOf: self selectedMessageName.
	self markMatchingClasses.
	classListIndex := 0.
	self changed: #messageListIndex.
	"update my selection"
	self changed: #classList! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sma 2/6/2000 11:42'!
messageListKey: aChar from: view
	"Respond to a command key. Handle (m) and (n) here,
	else defer to the StringHolder behaviour."

	aChar == $m ifTrue: [^ self implementors].
	aChar == $n ifTrue: [^ self senders].
	super messageListKey: aChar from: view
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
morphicWindow
	"Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spawns a full browser on it.  Answer the window
	SelectorBrowser new open "

	| window typeInView selectorListView classListView |
	window := (SystemWindow labelled: 'later') model: self.
	window setStripeColorsFrom: self defaultBackgroundColor.
	selectorIndex := classListIndex := 0.

	typeInView := PluggableTextMorph on: self 
		text: #contents accept: #contents:notifying:
		readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	typeInView acceptOnCR: true.
	typeInView hideScrollBarsIndefinitely.
	window addMorph: typeInView frame: (0@0 corner: 0.5@0.14).

	selectorListView := PluggableListMorph on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #selectorMenu:
		keystroke: #messageListKey:from:.
	selectorListView menuTitleSelector: #selectorMenuTitle.
	window addMorph: selectorListView frame: (0@0.14 corner: 0.5@0.6).

	classListView := PluggableListMorph on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: nil
		keystroke: #arrowKey:from:.
	classListView menuTitleSelector: #classListSelectorTitle.
	window addMorph: classListView frame: (0.5@0 corner: 1@0.6).
	window addMorph: ((PluggableTextMorph on: self text: #byExample 
				accept: #byExample:
				readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
					askBeforeDiscardingEdits: false)
		frame: (0@0.6 corner: 1@1).

	window setLabel: 'Method Finder'.
	^ window! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
open
	"Create a Browser that lets you type part of a selector, shows a list of selectors,
	shows the classes of the one you chose, and spwns a full browser on it.
		SelectorBrowser new open
	"

	| selectorListView typeInView topView classListView exampleView |
	Smalltalk isMorphic ifTrue: [^ self openAsMorph].

	selectorIndex := classListIndex := 0.
	topView := (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	typeInView := PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	typeInView window: (0@0 extent: 50@14);
		askBeforeDiscardingEdits: false.
	topView addSubView: typeInView.

	selectorListView := PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #selectorMenu:
		keystroke: #messageListKey:from:.
	selectorListView menuTitleSelector: #selectorMenuTitle.
	selectorListView window: (0 @ 0 extent: 50 @ 46).
	topView addSubView: selectorListView below: typeInView.

	classListView := PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: nil	"never anything selected"
		keystroke: #arrowKey:from:.
	classListView menuTitleSelector: #classListSelectorTitle.
	classListView window: (0 @ 0 extent: 50 @ 60).
	topView addSubView: classListView toRightOf: typeInView.

	exampleView := PluggableTextView on: self 
			text: #byExample accept: #byExample:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	exampleView window: (0@0 extent: 100@40);
		askBeforeDiscardingEdits: false.
	topView addSubView: exampleView below: selectorListView.


	topView label: 'Method Finder'.
	"topView minimumSize: 350@250; maximumSize: 350@250."
	topView subViews do: [:each | each controller].
	topView controller open.

! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 11/4/1999 13:55'!
openAsMorph
	"Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spwns a full browser on it.
	SelectorBrowser new open   "
	^ self morphicWindow openInWorld! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'ms 8/1/2006 16:48'!
quickList
	"Compute the selectors for the single example of receiver and args, in the very top pane" 

	| data result resultArray newExp dataStrings mf dataObjects aa statements |
	data := contents asString.
	"delete t
 railing period. This should be fixed in the Parser!!"
 	[data last isSeparator] whileTrue: [data := data allButLast]. 
	data last = $. ifTrue: [data := data allButLast]. 	"Eval"
	mf := MethodFinder new.
	data := mf cleanInputs: data.	"remove common mistakes"
	dataObjects := Compiler evaluate: '{', data, '}'. "#( data1 data2 result )"
	statements := (Compiler new parse: 'zort ' , data in: Object notifying: nil)
				body statements select: [:each | (each isKindOf: ReturnNode) not].
 	dataStrings := statements collect:
				[:node | String streamContents:
					[:strm | (node isMessage) ifTrue: [strm nextPut: $(].
					node shortPrintOn: strm.
					(node isMessage) ifTrue: [strm nextPut: $)].]].
	dataObjects size < 2 ifTrue: [self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^#()].
 	dataObjects := Array with: dataObjects allButLast with: dataObjects last. "#( (data1
  data2) result )" 
	result := mf load: dataObjects; findMessage.
	(result first beginsWith: 'no single method') ifFalse: [
		aa := self testObjects: dataObjects strings: dataStrings.
		dataObjects := aa second.  dataStrings := aa third].
	resultArray := self listFromResult: result. 
	resultArray isEmpty ifTrue: [self inform: result first].

	dataStrings size = (dataObjects first size + 1) ifTrue:
		[resultArray := resultArray collect: [:expression |
		newExp := expression.
		dataObjects first withIndexDo: [:lit :i |
			newExp := newExp copyReplaceAll: 'data', i printString
							with: (dataStrings at: i)].
		newExp, ' --> ', dataStrings last]].

 	^ resultArray! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
searchResult: anExternalSearchResult

	self contents: ''.
	classList := #(). classListIndex := 0.
	selectorIndex := 0.
	selectorList := self listFromResult: anExternalSearchResult.
 	self changed: #messageList.
	self changed: #classList.
	Smalltalk isMorphic ifTrue: [self changed: #contents.]. 
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
selectedClass
	"Answer the currently selected class."

	| pairString |

	self flag: #mref.	"allows for old-fashioned style"

	classListIndex = 0 ifTrue: [^nil].
	pairString := classList at: classListIndex.
	(pairString isKindOf: MethodReference) ifTrue: [
		^pairString actualClass
	].
	(pairString includes: $*) ifTrue: [pairString := pairString allButFirst].
	MessageSet 
		parse: pairString
		toClassAndSelector: [:cls :sel | ^ cls].! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/27/1998 17:48'!
selectedClassName
	"Answer the name of the currently selected class."

	classListIndex = 0 ifTrue: [^nil].
	^ self selectedClass name! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
selectedMessageName
	"Answer the name of the currently selected message."

	| example tokens |
	selectorIndex = 0 ifTrue: [^nil].
	example := selectorList at: selectorIndex.
	tokens := Scanner new scanTokens: example.
	tokens size = 1 ifTrue: [^ tokens first].
	tokens first == #'^' ifTrue: [^ nil].
	(tokens second includes: $:) ifTrue: [^ example findSelector].
	Symbol hasInterned: tokens second ifTrue: [:aSymbol | ^ aSymbol].
	^ nil! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
selectorList: anExternalList

	self contents: ''.
	classList := #(). classListIndex := 0.
	selectorIndex := 0.
	selectorList := anExternalList.
	self changed: #messageList.
	self changed: #classList.
	Smalltalk isMorphic ifTrue: [self changed: #contents.]. 

! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'hh 1/20/2000 00:15'!
selectorMenu: aMenu
	^ aMenu labels:
'senders (n)
implementors (m)
copy selector to clipboard'
	lines: #()
	selections: #(senders implementors copyName)! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sw 9/2/1998 16:37'!
selectorMenuTitle
	^ self selectedMessageName ifNil: ['<no selection>']! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
senders
	| aSelector |
	(aSelector := self selectedMessageName) ifNotNil:
		[self systemNavigation browseAllCallsOn: aSelector]! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
testObjects: dataObjects strings: dataStrings
	| dataObjs dataStrs selectors classes didUnmodifiedAnswer answerMod do ds result ddo dds |
	"Try to make substitutions in the user's inputs and search for the selector again.
1 no change to answer.
2 answer Array -> OrderedCollection.
2 answer Character -> String
4 answer Symbol or String of len 1 -> Character
	For each of these, try straight, and try converting args:
Character -> String
Symbol or String of len 1 -> Character
	Return array with result, dataObjects, dataStrings.  Don't ever do a find on the same set of data twice."

dataObjs := dataObjects.  dataStrs := dataStrings.
selectors := {#asString. #first. #asOrderedCollection}.
classes := {Character. String. Array}.
didUnmodifiedAnswer := false.
selectors withIndexDo: [:ansSel :ansInd | "Modify the answer object"
	answerMod := false.
	do := dataObjs copyTwoLevel.  ds := dataStrs copy.
	(dataObjs last isKindOf: (classes at: ansInd)) ifTrue: [
		((ansSel ~~ #first) or: [dataObjs last size = 1]) ifTrue: [
			do at: do size put: (do last perform: ansSel).	"asString"
			ds at: ds size put: ds last, ' ', ansSel.
			result := MethodFinder new load: do; findMessage.
			(result first beginsWith: 'no single method') ifFalse: [
				"found a selector!!"
				^ Array with: result first with: do with: ds].	
			answerMod := true]].

	selectors allButLast withIndexDo: [:argSel :argInd | "Modify an argument object"
			"for args, no reason to do Array -> OrderedCollection.  Identical protocol."
		didUnmodifiedAnswer not | answerMod ifTrue: [
		ddo := do copyTwoLevel.  dds := ds copy.
		dataObjs first withIndexDo: [:arg :ind |
			(arg isKindOf: (classes at: argInd))  ifTrue: [
				((argSel ~~ #first) or: [arg size = 1]) ifTrue: [
					ddo first at: ind put: ((ddo first at: ind) perform: argSel).	"asString"
					dds at: ind put: (dds at: ind), ' ', argSel.
					result := MethodFinder new load: ddo; findMessage.
					(result first beginsWith: 'no single method') ifFalse: [
						"found a selector!!"
						^ Array with: result first with: ddo with: dds]	.	
					didUnmodifiedAnswer not & answerMod not ifTrue: [
						didUnmodifiedAnswer := true].
					]]]]].
	].
^ Array with: 'no single method does that function' with: dataObjs with: dataStrs! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SelectorBrowser class
	instanceVariableNames: ''!

!SelectorBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
prototypicalToolWindow
	"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"

	| aWindow |
	aWindow := self new morphicWindow.
	aWindow setLabel: 'Selector Browser'.
	aWindow applyModelExtent.
	^ aWindow! !


!SelectorBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:43'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Method Finder' brightColor: #lightCyan	pastelColor: #palePeach helpMessage: 'A tool for finding methods by giving sample arguments and values.'! !


!SelectorBrowser class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 11:01'!
initialize

	self registerInFlapsRegistry.	! !

!SelectorBrowser class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 11:03'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(SelectorBrowser			prototypicalToolWindow		'Method Finder'		'A tool for discovering methods by providing sample values for arguments and results')
						forFlapNamed: 'Tools']
! !

!SelectorBrowser class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:40'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !
LeafNode subclass: #SelectorNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!SelectorNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a selector.!


!SelectorNode methodsFor: 'code generation'!
emit: stack args: nArgs on: strm

	self emit: stack
		args: nArgs
		on: strm
		super: false! !

!SelectorNode methodsFor: 'code generation'!
emit: stack args: nArgs on: aStream super: supered
	| index |
	stack pop: nArgs.
	(supered not and: [code - Send < SendLimit and: [nArgs < 3]]) ifTrue:
		["short send"
		code < Send
			ifTrue: [^ aStream nextPut: code "special"]
			ifFalse: [^ aStream nextPut: nArgs * 16 + code]].
	index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256].
	(index <= 31 and: [nArgs <= 7]) ifTrue: 
		["extended (2-byte) send [131 and 133]"
		aStream nextPut: SendLong + (supered ifTrue: [2] ifFalse: [0]).
		^ aStream nextPut: nArgs * 32 + index].
	(supered not and: [index <= 63 and: [nArgs <= 3]]) ifTrue:
		["new extended (2-byte) send [134]"
		aStream nextPut: SendLong2.
		^ aStream nextPut: nArgs * 64 + index].
	"long (3-byte) send"
	aStream nextPut: DblExtDoAll.
	aStream nextPut: nArgs + (supered ifTrue: [32] ifFalse: [0]).
	aStream nextPut: index! !

!SelectorNode methodsFor: 'code generation' stamp: 'di 1/7/2000 12:32'!
size: encoder args: nArgs super: supered
	| index |
	self reserve: encoder.
	(supered not and: [code - Send < SendLimit and: [nArgs < 3]])
		ifTrue: [^1]. "short send"
	(supered and: [code < Send]) ifTrue: 
		["super special:"
		code _ self code: (encoder sharableLitIndex: key) type: 5].
	index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256].
	(index <= 31 and: [nArgs <= 7])
		ifTrue: [^ 2]. "medium send"
	(supered not and: [index <= 63 and: [nArgs <= 3]])
		ifTrue: [^ 2]. "new medium send"
	^ 3 "long send"! !


!SelectorNode methodsFor: 'inappropriate'!
emitForEffect: stack on: strm

	self shouldNotImplement! !

!SelectorNode methodsFor: 'inappropriate'!
emitForValue: stack on: strm

	self shouldNotImplement! !

!SelectorNode methodsFor: 'inappropriate'!
sizeForEffect: encoder

	self shouldNotImplement! !

!SelectorNode methodsFor: 'inappropriate'!
sizeForValue: encoder

	self shouldNotImplement! !


!SelectorNode methodsFor: 'printing' stamp: 'di 11/8/2000 10:04'!
printOn: aStream indent: level 
	aStream withStyleFor: #keyword
		do: [key == nil
				ifTrue: [aStream nextPutAll: '<key==nil>']
				ifFalse: [aStream nextPutAll: key]]! !


!SelectorNode methodsFor: 'testing'!
isPvtSelector
	"Answer if this selector node is a private message selector."

	^key isPvtSelector! !
TestCase subclass: #SelfEvaluatingObjectTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Objects'!

!SelfEvaluatingObjectTest methodsFor: 'tests' stamp: 'sd 7/31/2005 21:50'!
testArray
	"self run: #testArray"

	self assertCode: '#(1 2 3)' print: '#(1 2 3)'.
	self assertCode: '{1 . 2 . 3}' print: '#(1 2 3)'.
	self assertCode: '{1 + 0 . 2 . 3}' print: '#(1 2 3)'.
	self assertCode: '{1 + 0 . 1 @ 2 . 3}' print: '{1 . 1@2 . 3}'.
	self assertCode: '{2@3}' print: '{2@3}'.
	self assertCode: '{Object new}' print:  'an Array(an Object)'.
	self assertCode: '{Rectangle new . Object new}' print:  'an Array(nil corner: nil an Object)'.
	self assertCode: '{10@10 corner: 20@20 . 100@100 corner: 200@200}' print: '{10@10 corner: 20@20 . 100@100 corner: 200@200}'! !

!SelfEvaluatingObjectTest methodsFor: 'tests' stamp: 'sd 7/31/2005 22:04'!
testObjects
	"self debug: #testObjects"

	self assert: 10 isSelfEvaluating.
	self assert: $a isSelfEvaluating.
	self assert: 3.14157 isSelfEvaluating.
	self assert: #(1 2 3) isSelfEvaluating.
	self assert: #abc isSelfEvaluating.
	self assert: 'abc' isSelfEvaluating.

	self assert: Object isSelfEvaluating.
	self assert: Object new isSelfEvaluating not.

	self assert: (Array with: 10) isSelfEvaluating.
	self assert: (Array with: Object new) isSelfEvaluating not.

	self assert: true isSelfEvaluating.
	self assert: false isSelfEvaluating.

	self assert: nil isSelfEvaluating.

	self assert: (1 to: 10) isSelfEvaluating.
	self assert: (1->2) isSelfEvaluating.
	self assert: Color red isSelfEvaluating.
	self assert: RunArray new isSelfEvaluating.! !


!SelfEvaluatingObjectTest methodsFor: 'utilities' stamp: 'sd 7/31/2005 21:43'!
assertCode: code print: aString
	self assert: (self compile: code) printString = aString! !

!SelfEvaluatingObjectTest methodsFor: 'utilities' stamp: 'sd 7/31/2005 21:42'!
compile: aString
	^ Compiler evaluate: aString! !
LinkedList subclass: #Semaphore
	instanceVariableNames: 'excessSignals'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!Semaphore commentStamp: '<historical>' prior: 0!
I provide synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the message signal and received by sending the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent.!


!Semaphore methodsFor: 'communication'!
signal
	"Primitive. Send a signal through the receiver. If one or more processes 
	have been suspended trying to receive a signal, allow the first one to 
	proceed. If no process is waiting, remember the excess signal. Essential. 
	See Object documentation whatIsAPrimitive."

	<primitive: 85>
	self primitiveFailed

	"self isEmpty    
		ifTrue: [excessSignals _ excessSignals+1]    
		ifFalse: [Processor resume: self removeFirstLink]"

! !

!Semaphore methodsFor: 'communication'!
wait
	"Primitive. The active Process must receive a signal through the receiver 
	before proceeding. If no signal has been sent, the active Process will be 
	suspended until one is sent. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 86>
	self primitiveFailed

	"excessSignals>0  
		ifTrue: [excessSignals _ excessSignals-1]  
		ifFalse: [self addLastLink: Processor activeProcess suspend]"
! !

!Semaphore methodsFor: 'communication' stamp: 'jf 12/2/2003 19:29'!
waitTimeoutMSecs: anInteger
	"Wait on this semaphore for up to the given number of milliseconds, then timeout. It is up to the sender to determine the difference between the expected event and a timeout."

	| waitingProcess wakeupProcess |
	waitingProcess _ Processor activeProcess.
	wakeupProcess _
		[(Delay forMilliseconds: (anInteger max: 0)) wait.
		self resumeProcess: waitingProcess] fork.

	self wait.
	wakeupProcess terminate.! !

!Semaphore methodsFor: 'communication' stamp: 'jm 9/12/97 11:39'!
waitTimeoutSeconds: anInteger
	"Wait on this semaphore for up to the given number of seconds, then timeout. It is up to the sender to determine the difference between the expected event and a timeout."

	self waitTimeoutMSecs: anInteger * 1000.
! !


!Semaphore methodsFor: 'comparing' stamp: 'sma 4/22/2000 18:48'!
= anObject
	^ self == anObject! !

!Semaphore methodsFor: 'comparing' stamp: 'sma 4/22/2000 18:48'!
hash
	^ self identityHash! !


!Semaphore methodsFor: 'initialize-release'!
initSignals
	"Consume any excess signals the receiver may have accumulated."

	excessSignals _ 0.! !

!Semaphore methodsFor: 'initialize-release' stamp: 'jf 12/2/2003 18:53'!
resumeProcess: aProcess
	"Remove the given process from the list of waiting processes (if it's there) and resume it.  This is used when a process asked for its wait to be timed out."

	| process |
	process _ self remove: aProcess ifAbsent: [nil].
	process ifNotNil: [process resume].! !

!Semaphore methodsFor: 'initialize-release'!
terminateProcess
	"Terminate the process waiting on this semaphore, if any."

	self isEmpty ifFalse: [ self removeFirst terminate ].! !


!Semaphore methodsFor: 'mutual exclusion' stamp: 'mir 9/22/2001 10:54'!
critical: mutuallyExcludedBlock 
	"Evaluate mutuallyExcludedBlock only if the receiver is not currently in 
	the process of running the critical: message. If the receiver is, evaluate 
	mutuallyExcludedBlock after the other critical: message is finished."

	| blockValue |
	self wait.
	[blockValue _ mutuallyExcludedBlock value]
		ensure: [self signal].
	^blockValue! !

!Semaphore methodsFor: 'mutual exclusion' stamp: 'ar 10/8/1998 11:16'!
critical: mutuallyExcludedBlock ifError: errorBlock
	"Evaluate mutuallyExcludedBlock only if the receiver is not currently in 
	the process of running the critical: message. If the receiver is, evaluate 
	mutuallyExcludedBlock after the other critical: message is finished."

	| blockValue hasError errMsg errRcvr |
	self wait.
	hasError _ false.
	blockValue _ [mutuallyExcludedBlock value] ifError:[:msg :rcvr|
		hasError _ true.
		errMsg _ msg.
		errRcvr _ rcvr].
	hasError ifTrue:[
		self signal.
		^errorBlock value: errMsg value: errRcvr].
	self signal.
	^blockValue! !


!Semaphore methodsFor: 'testing' stamp: 'ar 3/2/2001 16:51'!
isSignaled
	"Return true if this semaphore is currently signaled"
	^excessSignals > 0! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Semaphore class
	instanceVariableNames: ''!

!Semaphore class methodsFor: 'instance creation'!
forMutualExclusion
	"Answer an instance of me that contains a single signal. This new 
	instance can now be used for mutual exclusion (see the critical: message 
	to Semaphore)."

	^self new signal! !

!Semaphore class methodsFor: 'instance creation'!
new
	"Answer a new instance of Semaphore that contains no signals."

	^self basicNew initSignals! !
ClassTestCase subclass: #SemaphoreTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Processes'!
!SemaphoreTest commentStamp: 'tlk 5/5/2006 13:32' prior: 0!
A SemaphoreTest is sunit test for simple and multiEx semaphores

Instance Variables none; does not have common test fixture accross all tests (because its testing differenct sorts of semaphores (could refactor into muliple testcases if there were more test conditions.
!


!SemaphoreTest methodsFor: 'private' stamp: 'tlk 5/5/2006 13:26'!
criticalError
	Processor activeProcess terminate! !


!SemaphoreTest methodsFor: 'testing' stamp: 'tlk 5/5/2006 13:27'!
testCritical
	| lock |
	lock := Semaphore forMutualExclusion.
	[lock critical: [self criticalError]] forkAt: Processor userInterruptPriority.
	self assert: lock isSignaled! !

!SemaphoreTest methodsFor: 'testing' stamp: 'tlk 5/5/2006 13:28'!
testCriticalIfError
	| lock |
	lock := Semaphore forMutualExclusion.
	[lock critical: [self criticalError ifError:[]]] forkAt: Processor userInterruptPriority.
	self assert: lock isSignaled! !

!SemaphoreTest methodsFor: 'testing' stamp: 'jf 12/2/2003 19:31'!
testWaitAndWaitTimeoutTogether
	| semaphore value waitProcess waitTimeoutProcess |
	semaphore _ Semaphore new.
	
	waitProcess _ [semaphore wait. value _ #wait] fork.

	waitTimeoutProcess _ [semaphore waitTimeoutMSecs: 50. value _ #waitTimeout] fork.

	"Wait for the timeout to happen"
	(Delay forMilliseconds: 100) wait.

	"The waitTimeoutProcess should already have timed out.  This should release the waitProcess"
	semaphore signal.

	[waitProcess isTerminated and: [waitTimeoutProcess isTerminated]]
		whileFalse: [(Delay forMilliseconds: 100) wait].

	self assert: value = #wait.
	! !
TimeMeasuringTest subclass: #SendCachePerformanceTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!

!SendCachePerformanceTest methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:42'!
performanceTestBaseline
	LocalSends current for: Morph.
	self assert: [LocalSends current for: Morph] timeToRun < 1.
	Morph clearSendCaches.
	self measure: [LocalSends current for: Morph].
	self assert: realTime < 100.
	self assert: [LocalSends current for: Morph] timeToRun < 1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SendCachePerformanceTest class
	instanceVariableNames: ''!
Object subclass: #SendCaches
	instanceVariableNames: 'selfSenders superSenders classSenders'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!
!SendCaches commentStamp: 'NS 5/27/2005 15:13' prior: 0!
Instances of this class are used to keep track of selectors that are sent to self, sent to super, and sent to the class-side in any of the methods of a certain class. It also keeps track of the requirements of a class.

It's important to understand that this class just serves as storage for these sets of selectors. It does not contain any logic to actually compute them. In particular, it cannot compute the requirements.!


!SendCaches methodsFor: 'accessing' stamp: 'apb 3/2/2006 23:28'!
classSendersOf: selector
	^ classSenders at: selector ifAbsent: [#()].! !

!SendCaches methodsFor: 'accessing' stamp: 'apb 3/2/2006 22:59'!
initialize
	selfSenders := IdentityDictionary new.
	superSenders := IdentityDictionary new.
	classSenders := IdentityDictionary new.! !

!SendCaches methodsFor: 'accessing' stamp: 'dvf 8/8/2005 11:20'!
selfSenders
	^selfSenders! !

!SendCaches methodsFor: 'accessing' stamp: 'dvf 8/8/2005 11:20'!
selfSenders: anObject
	^selfSenders := anObject! !

!SendCaches methodsFor: 'accessing' stamp: 'dvf 8/8/2005 11:24'!
superSenders
	^superSenders! !

!SendCaches methodsFor: 'accessing' stamp: 'dvf 8/8/2005 11:24'!
superSenders: anObject
	^superSenders := anObject! !


!SendCaches methodsFor: 'accessing-specific' stamp: 'NS 5/24/2005 20:58'!
allSentSelectorsAndSendersDo: aBlock
	self selfSentSelectorsAndSendersDo: aBlock.
	self superSentSelectorsAndSendersDo: aBlock.
	self classSentSelectorsAndSendersDo: aBlock.! !

!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:29'!
classSentSelectorsAndSendersDo: aBlock
	classSenders keysAndValuesDo: aBlock! !

!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:25'!
selfSendersOf: selector
	^ selfSenders at: selector ifAbsent: [#()].! !

!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:26'!
selfSentSelectorsAndSendersDo: aBlock
	selfSenders keysAndValuesDo: aBlock! !

!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:28'!
superSendersOf: selector
	^ superSenders at: selector ifAbsent: [#()].! !

!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:27'!
superSentSelectorsAndSendersDo: aBlock
	superSenders keysAndValuesDo: aBlock! !


!SendCaches methodsFor: 'updates' stamp: 'apb 3/2/2006 23:29'!
addClassSender: sendingSelector of: sentSelector
	| senders |
	senders _ classSenders at: sentSelector ifAbsent: [#()].
	classSenders at: sentSelector put: (senders copyWith: sendingSelector).! !

!SendCaches methodsFor: 'updates' stamp: 'apb 3/2/2006 23:27'!
addSelfSender: sendingSelector of: sentSelector
	| senders |
	senders _ selfSenders at: sentSelector ifAbsent: [#()].
	selfSenders at: sentSelector put: (senders copyWith: sendingSelector).! !

!SendCaches methodsFor: 'updates' stamp: 'apb 3/2/2006 23:28'!
addSuperSender: sendingSelector of: sentSelector
	| senders |
	senders _ superSenders at: sentSelector ifAbsent: [#()].
	superSenders at: sentSelector put: (senders copyWith: sendingSelector).! !


!SendCaches methodsFor: 'fixup' stamp: 'apb 3/2/2006 23:16'!
printOn: aStream 
	super printOn: aStream.
	aStream nextPut: $[.
	selfSenders printOn: aStream.
	aStream nextPut: $|.
	superSenders printOn: aStream.
	aStream nextPut: $|.
	classSenders printOn: aStream.
	aStream nextPut: $]! !

!SendCaches methodsFor: 'fixup' stamp: 'apb 3/2/2006 23:18'!
properlyInitialize
	selfSenders isEmptyOrNil ifTrue: [selfSenders := IdentityDictionary new].
	superSenders isEmptyOrNil ifTrue: [superSenders := IdentityDictionary new].
	classSenders isEmptyOrNil ifTrue: [classSenders := IdentityDictionary new].
	
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SendCaches class
	instanceVariableNames: ''!

!SendCaches class methodsFor: 'fixup' stamp: 'apb 3/2/2006 23:24'!
initializeAllInstances
	self allSubInstancesDo: [ : each | each properlyInitialize ]! !
InstructionStream subclass: #SendInfo
	instanceVariableNames: 'stack savedStacks selfSentSelectors superSentSelectors classSentSelectors isStartOfBlock numBlockArgs nr1 nr2 nr3 nr4 nr5'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-LocalSends'!
!SendInfo commentStamp: '<historical>' prior: 0!
SendInfo objects perform an abstract interpretation of a compiled method to ascertain the messages that are self-sent, super-sent and class-sent.

The idea is to simulate the execution of the instruction stream in the compiled method, keeping track of whether the values on the stack are self or some other value.  IN one place we have to keep track of the small integers that are on the stack,  becuase they determine how many elements are to be popped off of the stack.

Everything is fairly straighforward except for jumps.

Conditional forward jumps, as generated by ifTrue: and ifFalse:, are fairly easy.  At the site of the conditional jump, we copy the stack, and use one copy on each path.  When the paths eventually merge, the stacks should be the same size (if they aren't it's a compiler error!!).  We build a new stack that has #self on it every place where either of the old stacks had #self.  Thus, expressions like

	(aBoolean ifTrue: self ifFalse: other) foo: 3

that might send foo: 3 to self are recognized.

For unconditional jumps, we save the stack for use at the join point, and continue execution at the instruciton after the jump with an empty stack, which will be immediately overwritten by the stack that comes with the arriving execution.

The bottlenecks in this algorithm turned out to be detecting join points and simulating the stack.  Using an OrderedCollection for a stack caused a lot of redundant work, especially when emptying the stack.  Using a dictionary to detect join points turned out to be very slow, because of the possibility of having to scan through the hash table.

QuickIntegerDictionary and QuickStack provide the same core functionality, but in much more efficient forms.


Use SendInfo as follows:

				(SendInfo on: aCompiledMethod) collectSends

aSendInfo is both an InstructionStream and an InstructionStream client.

Structure:
 stack --	the simulated execution stack
 savedStacks -- The dictionary on which the extra stacks waiting to be merged in are saved.

  sentSelectors		-- an Identity Set accumulating the set of sent selectors.
  superSentSelectors	-- an Identity Set accumulating the set of super sent selectors.

  classSentSelectors -- an Identity Set accumulating the set of selectors sent to self class.
  isStartOfBlock -- a flag indicating that we have found the start of a block, and that the next jump will skip over it.
  numBlockArgs --  
nr1' 'nr2' 'nr3' 'nr4')
!


!SendInfo methodsFor: 'accessing' stamp: 'NS 5/23/2005 11:04'!
classSentSelectors
	^  classSentSelectors ifNil: [#()] ifNotNil: [classSentSelectors].! !

!SendInfo methodsFor: 'accessing' stamp: 'apb 8/28/2003 16:52'!
home
	"Answer the context in which the receiver was defined."

	^ sender! !

!SendInfo methodsFor: 'accessing' stamp: 'apb 8/28/2003 16:47'!
method
	"Answer the method of this context."

	^ sender! !

!SendInfo methodsFor: 'accessing' stamp: 'NS 5/23/2005 11:03'!
selfSentSelectors
	^ selfSentSelectors ifNil: [#()] ifNotNil: [selfSentSelectors].! !

!SendInfo methodsFor: 'accessing' stamp: 'NS 5/23/2005 11:04'!
superSentSelectors
	^  superSentSelectors ifNil: [#()] ifNotNil: [superSentSelectors].! !


!SendInfo methodsFor: 'initialization' stamp: 'apb 8/28/2003 17:32'!
collectSends
	| end |
	end _ self method endPC.
	[pc <= end]
		whileTrue: [self interpretNextInstructionFor: self]! !

!SendInfo methodsFor: 'initialization' stamp: 'NS 2/15/2005 15:58'!
method: method pc: initialPC
	super method: method pc: initialPC.
	self prepareState.! !

!SendInfo methodsFor: 'initialization' stamp: 'NS 5/23/2005 11:12'!
prepareState
	| nrsArray |
	self newEmptyStack.
	savedStacks _ QuickIntegerDictionary new: (sender endPC).
	isStartOfBlock _ false.
	nrsArray _ self class neverRequiredSelectors.
	self assert:[nrsArray size = 5] because: 'Size of neverRequiredSelectors has been changed; re-optimize (by hand) #tallySelfSendsFor:'.
	nr1 _ nrsArray at: 1.
	nr2 _ nrsArray at: 2.
	nr3 _ nrsArray at: 3.
	nr4 _ nrsArray at: 4.
	nr5 _ nrsArray at: 5.! !


!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 13:40'!
blockReturnTop
	"Return from a block with Top Of Stack as result.
	The following instruction will be branched to from somewhere, and will
	therefore trigger a stackMerge, so it is important that the stack be emptied."

	self pop.
	self emptyStack.! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 19:28'!
doDup
	"Simulate the action of a 'duplicate top of stack' bytecode."

	self push: self top! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'NS 5/23/2005 11:14'!
doPop

	stack isEmpty ifFalse: [self pop]! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 12:41'!
interpretNextInstructionFor: client 
	self atMergePoint
		ifTrue: [self mergeStacks].
	super interpretNextInstructionFor: client! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 9/7/2004 10:42'!
jump: distance 
	"Simulate the action of a 'unconditional jump' bytecode whose  
	offset is the argument, distance."
	distance < 0
		ifTrue: [^ self].
	distance = 0
		ifTrue: [self error: 'bad compiler!!'].
	savedStacks at: (self pc + distance) put: stack.
	"We empty the stack to signify that execution cannot 'fall through' to the
	next statement.  Note that since we just stored the current stack, not a copy, in
	the savedStacks dictionary, here we need to allocate a new stack."
	self newEmptyStack.  
	isStartOfBlock
		ifTrue: [isStartOfBlock _ false.
			numBlockArgs	timesRepeat: [self push: #stuff]]! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 21:50'!
jump: distance if: aBooleanConstant 
	"Simulate the action of a 'conditional jump' bytecode whose offset is 
	distance, and whose condition is aBooleanConstant."

	| destination |
	distance < 0 ifTrue:[^ self].
	distance = 0 ifTrue:[self error: 'bad compiler!!'].
	destination _ self pc + distance.
	"remove the condition from the stack."
	self pop.
	savedStacks at: destination put: stack copy.
! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 21:25'!
methodReturnConstant: aConstant
	"Simulate the action of a 'return receiver' bytecode. This corresponds to 
	the source expression '^aConstant'."

	self push: aConstant.
	self emptyStack! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 21:25'!
methodReturnReceiver
	"Simulate the action of a 'return receiver' bytecode. This corresponds to 
	the source expression '^self'."

	self push: #self.	
	self emptyStack ! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 21:25'!
methodReturnTop
	"Simulate the action of a 'return receiver' bytecode. This corresponds to 
	the source expression '^ <result of the last evaluation>'."

	self emptyStack ! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 15:37'!
popIntoLiteralVariable: value 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into a literal variable of my method."

	self pop! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 14:51'!
popIntoReceiverVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into an instance variable of my receiver."

	self pop! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 14:51'!
popIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into an instance variable of my receiver."

	self pop! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 15:53'!
pushActiveContext
	"Simulate the action of bytecode that pushes the active context on the 
	top of its own stack."

	self push: #block.! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 01:57'!
pushConstant: value 

	self push: value! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 14:49'!
pushLiteralVariable: value 

	self push: #stuff! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 17:55'!
pushReceiver
	self push: #self.! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 07:50'!
pushReceiverVariable: anOffset
	"Push the value of one of the receiver's instance variables."

	self push: #stuff.! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 14:47'!
pushTemporaryVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the 
	temporary variable whose index is the argument, index, on the top of 
	the stack."

	self push: #stuff! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'NS 5/23/2005 11:01'!
send: selector super: superFlag numArgs: numArgs 
	"Simulate the action of bytecodes that send a message with  
	selector. superFlag, tells whether the receiver of the  
	message was 'super' in the source. The arguments  
	of the message are found in the top numArgs locations on the  
	stack and the receiver just below them."
	| stackTop |
	selector == #blockCopy:
		ifTrue: ["self assert: [numArgs = 1]."
			isStartOfBlock _ true.
			numBlockArgs _ self pop.
			^ self].
	self pop: numArgs.
	stackTop _ self pop.
	superFlag
		ifTrue: [self addSuperSentSelector: selector]
		ifFalse: [stackTop == #self
				ifTrue: [self tallySelfSendsFor: selector].
			stackTop == #class
				ifTrue: [self addClassSentSelector: selector]].
	self
		push: ((selector == #class and: [stackTop == #self])
				ifTrue: [#class]
				ifFalse: [#stuff])! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 15:39'!
storeIntoLiteralVariable: value 
	"Simulate the action of bytecode that stores the top of the stack into a 
	literal variable of my method."
! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 15:34'!
storeIntoReceiverVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into an 
	instance variable of my receiver."
! !

!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 19:48'!
storeIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into one 
	of my temporary variables."
! !


!SendInfo methodsFor: 'printing' stamp: 'NS 5/23/2005 10:57'!
printOn: aStream
	aStream nextPut: $[.
	aStream print: self selfSentSelectors asArray.
	aStream space.
	aStream print: self superSentSelectors asArray.
	aStream space.
	aStream print: self  classSentSelectors asArray.
	aStream nextPut: $].! !


!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/29/2003 02:13'!
atMergePoint
	^ savedStacks includesKey: pc! !

!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/28/2003 16:44'!
blockReturn
	"we could empty the stack, but what's the point?"! !

!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 9/7/2004 10:24'!
emptyStack
	stack becomeEmpty! !

!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/31/2003 21:30'!
mergeStacks
	| otherStack |
	otherStack _ savedStacks at: pc.
	savedStacks removeKey: pc.
	stack isEmpty ifTrue: [
		"This happens at the end of a block, or a short circuit conditional.  
		In these cases, it is not possible for execution to 'fall through' to 
		the merge point.  In other words, this is not a real merge point at all, 
		and we just continue execution with the saved stack."
		^ stack _ otherStack ]. 
	"self assert: [stack size = otherStack size].  This assertion was true for every
	method in every subclass of Object, so I think that we can safely omit it!!"
	1 to: stack size
		do: [:i | ((stack at: i) ~~ #self
					and: [(otherStack at: i) == #self])
				ifTrue: [stack at: i put: #self]]! !

!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 9/7/2004 10:41'!
newEmptyStack
	stack _ QuickStack new! !

!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/28/2003 17:41'!
pop
	^ stack removeLast! !

!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/31/2003 21:43'!
pop: n 
	stack removeLast: n! !

!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/30/2003 11:38'!
push: aValue
	stack addLast: aValue.! !

!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/28/2003 19:28'!
top
	^ stack last! !


!SendInfo methodsFor: 'private' stamp: 'NS 5/23/2005 11:01'!
addClassSentSelector: aSymbol
	classSentSelectors ifNil: [classSentSelectors _ IdentitySet new].
	classSentSelectors add: aSymbol.! !

!SendInfo methodsFor: 'private' stamp: 'NS 5/23/2005 11:15'!
addSelfSentSelector: aSymbol
	selfSentSelectors ifNil: [selfSentSelectors _ IdentitySet new].
	selfSentSelectors add: aSymbol.! !

!SendInfo methodsFor: 'private' stamp: 'NS 5/23/2005 11:15'!
addSuperSentSelector: aSymbol
	superSentSelectors ifNil: [superSentSelectors _ IdentitySet new].
	superSentSelectors add: aSymbol.! !

!SendInfo methodsFor: 'private' stamp: 'apb 8/30/2003 10:36'!
assert: aBlock because: aMessage
	"Throw an assertion error if aBlock does not evaluates to true."

	aBlock value ifFalse: [AssertionFailure signal: aMessage]! !

!SendInfo methodsFor: 'private' stamp: 'NS 5/23/2005 10:59'!
tallySelfSendsFor: selector 
	"Logically, we do the following test: 
		(self neverRequiredSelectors includes: selector) ifTrue: [^ self].
	However, since this test alone was reponsible for 2.8% of the execution time,
	we replace it with the following:"
	selector == nr1 ifTrue:[^ self].
	selector == nr2 ifTrue:[^ self].
	selector == nr3 ifTrue:[^ self].
	selector == nr4 ifTrue:[^ self].
	selector == nr5 ifTrue:[^ self].
	selector == #class ifTrue:[^ self].
	self addSelfSentSelector: selector.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SendInfo class
	instanceVariableNames: ''!

!SendInfo class methodsFor: 'accessing' stamp: 'NS 5/23/2005 10:53'!
neverRequiredSelectors
	| nrs |
	nrs _ Array new: 5.
	nrs at: 1 put: CompiledMethod conflictMarker.
	nrs at: 2 put: CompiledMethod disabledMarker.
	nrs at: 3 put: CompiledMethod explicitRequirementMarker.
	nrs at: 4 put: CompiledMethod implicitRequirementMarker.
	nrs at: 5 put: CompiledMethod subclassResponsibilityMarker.
	^ nrs.
! !
TestCase subclass: #SendsInfoTest
	instanceVariableNames: 'state'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 22:28'!
assert: levelSymbol sendsIn: aSelector are: anArrayOfSelectors 

! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 22:39'!
assert: alevel sendsIn: aSendInfo for: aSelector are: aCollectionOfSelectors
	| detectedSends message |
	detectedSends := aSendInfo perform: (alevel, 'SentSelectors') asSymbol.
	message := alevel, ' sends wrong for ', aSelector.
	self assert: ((detectedSends isEmpty and: [aCollectionOfSelectors isEmpty]) or:
				[detectedSends = (aCollectionOfSelectors asIdentitySet)]) description: message! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 22:29'!
assert: aSelector sends: sendsCollection supersends: superCollection classSends: classCollection
	| theMethod info |
	theMethod := self class >> aSelector.
	info := (SendInfo on: theMethod) collectSends.
	self assert: #self sendsIn: info for: aSelector are: sendsCollection.
	self assert: #super sendsIn: info for: aSelector are: superCollection.
	self assert: #class sendsIn: info for: aSelector are: classCollection.
! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/3/2006 01:03'!
branch
	"This method is never run. It is here just so that the sends in it can be
	tallied by the SendInfo interpreter."
	(state
		ifNil: [self]
		ifNotNil: [state]) clip.
	(state isNil
		ifTrue: [self]
		ifFalse: [state]) truncate.
! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/3/2006 00:36'!
classBranch
	self
		shouldnt: [state isNil
				ifTrue: [self tell]
				ifFalse: [self class tell]]
		raise: MessageNotUnderstood! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 23:55'!
clip	
	"This method is never run. It is here just so that the sends in it can be
	tallied by the SendInfo interpreter."
	| temp |
	self printString.
	temp _ self.
	temp error: 4 + 5! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 23:55'!
clipRect: aRectangle 
	"This method is never run. It is here just so that the sends in it can be
	tallied by the SendInfo interpreter."
	super clipRect: aRectangle.
	(state notNil
			and: [self bitBlt notNil])
		ifTrue: [state bitBlt clipRect: aRectangle]! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 23:55'!
pseudoCopy
	"This method is never run. It is here just so that the sends in it can be
	tallied by the SendInfo interpreter."
	| array |
	array := self class new: self basicSize.
	self
		instVarsWithIndexDo: [:each :i | array at: i put: each].
	^ array! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/3/2006 00:30'!
superBranch
	self
		should: [state isNil
				ifTrue: [super tell]
				ifFalse: [self tell]]
		raise: MessageNotUnderstood! !

!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/3/2006 00:14'!
tell
	"this method should not be defined in super"! !


!SendsInfoTest methodsFor: 'tests' stamp: 'al 7/21/2006 21:45'!
expectedFailures
	"See #testCompileSuperBranch"

	^#(testCompileSuperBranch testTestCompileSuperBranch)! !

!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:10'!
testBranch
	self assert: #branch sends: #(clip truncate) supersends: #() classSends: #()! !

!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:39'!
testClassBranch
	self assert: #classBranch sends: #(tell shouldnt:raise:) supersends: #() classSends: #(tell).
	self classBranch.! !

!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/2/2006 22:18'!
testClip
	self assert: #clip sends: #(printString) supersends: #() classSends: #()! !

!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:03'!
testClipRect
	self assert: #clipRect:  sends: #(bitBlt)  supersends: #(clipRect:)  classSends: #() 
! !

!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:38'!
testCompileSuperBranch
	"The compiler accepts this code 
		condition ifTrue: [super] ifFalse: [self]
	but compiles it as 
		condition ifTrue: [super] ifFalse: [self].
	(Use the show decompiled button).  So the SendsInfo interpreter, interpretting 
	the bad code, comes up with the wrong answer."

	self should: [(state isNil
		ifTrue: [super]
		ifFalse: [self]) tell] raise: MessageNotUnderstood description: 'Compiler treats super as self'
	! !

!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/2/2006 23:38'!
testPseudoCopy
	self assert: #pseudoCopy sends: #(instVarsWithIndexDo: basicSize) supersends: #() classSends: #(#new:)! !

!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:33'!
testSuperBranch
	self assert: #superBranch sends: #(tell should:raise:) supersends: #(tell) classSends: #().
	self superBranch.! !

!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:24'!
testTestCompileSuperBranch
	
	self assert: #testCompileSuperBranch sends: #(tell) supersends: #(tell) classSends: #()! !
Collection subclass: #SequenceableCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!
!SequenceableCollection commentStamp: '<historical>' prior: 0!
I am an abstract superclass for collections that have a well-defined order associated with their elements. Thus each element is externally-named by integers referred to as indices.!


!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 18:00'!
after: target
	"Answer the element after target.  Raise an error if target is not
	in the receiver, or if there are no elements after it."

	^ self after: target ifAbsent: [self errorNotFound: target]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ac 7/5/2004 22:35'!
after: target ifAbsent: exceptionBlock
	"Answer the element after target.  Answer the result of evaluation
	the exceptionBlock if target is not in the receiver, or if there are 
	no elements after it."

	| index |
	index _ self indexOf: target.
	^ (index == 0 or: [index = self size])
		ifTrue: [exceptionBlock value]
		ifFalse: [self at: index + 1]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:34'!
allButFirst
	"Answer a copy of the receiver containing all but the first
	element. Raise an error if there are not enough elements."

	^ self allButFirst: 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'!
allButFirst: n
	"Answer a copy of the receiver containing all but the first n
	elements. Raise an error if there are not enough elements."

	^ self copyFrom: n + 1 to: self size! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'!
allButLast
	"Answer a copy of the receiver containing all but the last
	element. Raise an error if there are not enough elements."

	^ self allButLast: 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'!
allButLast: n
	"Answer a copy of the receiver containing all but the last n
	elements. Raise an error if there are not enough elements."

	^ self copyFrom: 1 to: self size - n! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:33'!
anyOne
	^ self first! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:45'!
atAllPut: anObject 
	"Put anObject at every one of the receiver's indices."

	| size |
	(size _ self size) > 26 "first method faster from 27 accesses and on"
		ifTrue: [self from: 1 to: size put: anObject]
		ifFalse: [1 to: size do: [:index | self at: index put: anObject]]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'apb 11/4/2000 22:51'!
atAll: indexArray
	"Answer a new collection like the receiver which contains all elements
	of the receiver at the indices of indexArray."
	"#('one' 'two' 'three' 'four') atAll: #(3 2 4)"

	| newCollection |
	newCollection _ self species ofSize: indexArray size.
	1 to: indexArray size do:
		[:index |
		newCollection at: index put: (self at: (indexArray at: index))].
	^ newCollection! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:18'!
atAll: indexArray putAll: valueArray
	"Store the elements of valueArray into the slots
	of this collection selected by indexArray."

	indexArray with: valueArray do: [:index :value | self at: index put: value].
	^ valueArray! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:17'!
atAll: aCollection put: anObject 
	"Put anObject at every index specified by the elements of aCollection."

	aCollection do: [:index | self at: index put: anObject].
	^ anObject! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'nk 6/12/2004 17:06'!
atLast: indexFromEnd
	"Return element at indexFromEnd from the last position.
	 atLast: 1, returns the last element"

	^ self atLast: indexFromEnd ifAbsent: [self error: 'index out of range']! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 6/27/2002 17:52'!
atLast: indexFromEnd ifAbsent: block
	"Return element at indexFromEnd from the last position.
	 atLast: 1 ifAbsent: [] returns the last element"

	^ self at: self size + 1 - indexFromEnd ifAbsent: block! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 6/27/2002 18:10'!
atLast: indexFromEnd put: obj
	"Set the element at indexFromEnd from the last position.
	 atLast: 1 put: obj, sets the last element"

	^ self at: self size + 1 - indexFromEnd put: obj! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'di 11/6/1998 14:32'!
atPin: index 
	"Return the index'th element of me if possible.
	Return the first or last element if index is out of bounds."

	index < 1 ifTrue: [^ self first].
	index > self size ifTrue: [^ self last].
	^ self at: index! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:50'!
atRandom: aGenerator
	"Answer a random element of the receiver.  Uses aGenerator which
	should be kept by the user in a variable and used every time. Use
	this instead of #atRandom for better uniformity of random numbers 
	because only you use the generator.  Causes an error if self has no 
	elements."

	^ self at: (aGenerator nextInt: self size)! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:51'!
atWrap: index 
	"Answer the index'th element of the receiver.  If index is out of bounds,
	let it wrap around from the end to the beginning until it is in bounds."

	^ self at: index - 1 \\ self size + 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:52'!
atWrap: index put: value
	"Store value into the index'th element of the receiver.  If index is out
	of bounds, let it wrap around from the end to the beginning until it 
	is in bounds. Answer value."

	^ self at: index  - 1 \\ self size + 1 put: value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:11'!
at: index ifAbsent: exceptionBlock 
	"Answer the element at my position index. If I do not contain an element 
	at index, answer the result of evaluating the argument, exceptionBlock."

	(index between: 1 and: self size) ifTrue: [^ self at: index].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'raok 11/22/2002 12:34'!
at: index incrementBy: value
	^self at: index put: (self at: index) + value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 18:04'!
before: target
	"Answer the receiver's element immediately before target. Raise an
	error if target is not an element of the receiver, or if there are no 
	elements before it (i.e. it is the first element)."

	^ self before: target ifAbsent: [self errorNotFound: target]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ac 7/5/2004 22:36'!
before: target ifAbsent: exceptionBlock
	"Answer the receiver's element immediately before target. Answer
	the result of evaluating the exceptionBlock if target is not an element
	of the receiver, or if there are no elements before it."

	| index |
	index _ self indexOf: target.
	^ (index == 0 or: [index == 1])
		ifTrue: [exceptionBlock value]
		ifFalse: [self at: index - 1]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'!
eighth
	"Answer the eighth element of the receiver.
	Raise an error if there are not enough elements."

	^ self at: 8! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'!
fifth
	"Answer the fifth element of the receiver.
	Raise an error if there are not enough elements."

	^ self at: 5! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'md 1/19/2006 09:57'!
first
	"Answer the first element of the receiver"

	^ self at: 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:31'!
first: n
	"Answer the first n elements of the receiver.
	Raise an error if there are not enough elements."

	^ self copyFrom: 1 to: n! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'!
fourth
	"Answer the fourth element of the receiver.
	Raise an error if there are not enough elements."

	^ self at: 4! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'SqR 10/30/2000 22:06'!
from: startIndex to: endIndex put: anObject
	"Put anObject in all indexes between startIndex 
	and endIndex. Very fast. Faster than to:do: for
	more than 26 positions. Answer anObject"

	| written toWrite thisWrite |

	startIndex > endIndex ifTrue: [^self].
	self at: startIndex put: anObject.
	written _ 1.
	toWrite _ endIndex - startIndex + 1.
	[written < toWrite] whileTrue:
		[
			thisWrite _ written min: toWrite - written.
			self 
				replaceFrom: startIndex + written
				to: startIndex + written + thisWrite - 1
				with: self startingAt: startIndex.
			written _ written + thisWrite
		].
	^anObject! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 8/14/1998 21:20'!
identityIndexOf: anElement 
	"Answer the index of anElement within the receiver. If the receiver does 
	not contain anElement, answer 0."

	^self identityIndexOf: anElement ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 8/14/1998 21:21'!
identityIndexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of anElement within the receiver. If the receiver does 
	not contain anElement, answer the result of evaluating the argument, 
	exceptionBlock."
	1 to: self size do:
		[:i | (self at: i) == anElement ifTrue: [^ i]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing'!
indexOfSubCollection: aSubCollection startingAt: anIndex 
	"Answer the index of the receiver's first element, such that that element 
	equals the first element of aSubCollection, and the next elements equal 
	the rest of the elements of aSubCollection. Begin the search at element 
	anIndex of the receiver. If no such match is found, answer 0."

	^self
		indexOfSubCollection: aSubCollection
		startingAt: anIndex
		ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'accessing'!
indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the receiver's first element, such that that element 
	equals the first element of sub, and the next elements equal 
	the rest of the elements of sub. Begin the search at element 
	start of the receiver. If no such match is found, answer the result of 
	evaluating argument, exceptionBlock."
	| first index |
	sub isEmpty ifTrue: [^ exceptionBlock value].
	first _ sub first.
	start to: self size - sub size + 1 do:
		[:startIndex |
		(self at: startIndex) = first ifTrue:
			[index _ 1.
			[(self at: startIndex+index-1) = (sub at: index)]
				whileTrue:
				[index = sub size ifTrue: [^startIndex].
				index _ index+1]]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:46'!
indexOf: anElement
	"Answer the index of the first occurence of anElement within the  
	receiver. If the receiver does not contain anElement, answer 0."

	^ self indexOf: anElement ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:47'!
indexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of the first occurence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the 
	result of evaluating the argument, exceptionBlock."

	^ self indexOf: anElement startingAt: 1 ifAbsent: exceptionBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:47'!
indexOf: anElement startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the first occurence of anElement after start
	within the receiver. If the receiver does not contain anElement, 
	answer the 	result of evaluating the argument, exceptionBlock."

	start to: self size do:
		[:index |
		(self at: index) = anElement ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:43'!
integerAt: index
	"Return the integer at the given index"
	^self at: index! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:43'!
integerAt: index put: value
	"Return the integer at the given index"
	^self at: index put: value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'md 1/19/2006 09:56'!
last
	"Answer the last element of the receiver"

	^ self at: self size! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 12/16/2001 01:06'!
lastIndexOf: anElement
	"Answer the index of the last occurence of anElement within the 
	receiver. If the receiver does not contain anElement, answer 0."

	^ self lastIndexOf: anElement startingAt: self size ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 12/16/2001 01:06'!
lastIndexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of the last occurence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the
	result of evaluating the argument, exceptionBlock."
	^self lastIndexOf: anElement startingAt: self size ifAbsent: exceptionBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 12/16/2001 01:05'!
lastIndexOf: anElement startingAt: lastIndex ifAbsent: exceptionBlock
	"Answer the index of the last occurence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the
	result of evaluating the argument, exceptionBlock."

	lastIndex to: 1 by: -1 do:
		[:index |
		(self at: index) = anElement ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:30'!
last: n
	"Answer the last n elements of the receiver.  
	Raise an error if there are not enough elements."

	| size |
	size _ self size.
	^ self copyFrom: size - n + 1 to: size! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'md 1/19/2006 09:56'!
middle
	"Answer the middle element of the receiver."
	^ self at: self size // 2 + 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'!
ninth
	"Answer the ninth element of the receiver.
	Raise an error if there are not enough elements."

	^ self at: 9! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 1/20/98 16:22'!
replaceAll: oldObject with: newObject 
	"Replace all occurences of oldObject with newObject"
	| index |
	index _ self
				indexOf: oldObject
				startingAt: 1
				ifAbsent: [0].
	[index = 0]
		whileFalse: 
			[self at: index put: newObject.
			index _ self
						indexOf: oldObject
						startingAt: index + 1
						ifAbsent: [0]]! !

!SequenceableCollection methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement 
	"This destructively replaces elements from start to stop in the receiver. 
	Answer the receiver itself. Use copyReplaceFrom:to:with: for 
	insertion/deletion which may alter the size of the result."

	replacement size = (stop - start + 1)
		ifFalse: [self error: 'Size of replacement doesnt match'].
	^self replaceFrom: start to: stop with: replacement startingAt: 1! !

!SequenceableCollection methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"This destructively replaces elements from start to stop in the receiver 
	starting at index, repStart, in the sequenceable collection, 
	replacementCollection. Answer the receiver. No range checks are 
	performed."

	| index repOff |
	repOff _ repStart - start.
	index _ start - 1.
	[(index _ index + 1) <= stop]
		whileTrue: [self at: index put: (replacement at: repOff + index)]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'!
second
	"Answer the second element of the receiver.
	Raise an error if there are not enough elements."

	^ self at: 2! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'!
seventh
	"Answer the seventh element of the receiver.
	Raise an error if there are not enough elements."

	^ self at: 7! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:22'!
sixth
	"Answer the sixth element of the receiver.
	Raise an error if there are not enough elements."

	^ self at: 6! !

!SequenceableCollection methodsFor: 'accessing'!
swap: oneIndex with: anotherIndex 
	"Move the element at oneIndex to anotherIndex, and vice-versa."

	| element |
	element _ self at: oneIndex.
	self at: oneIndex put: (self at: anotherIndex).
	self at: anotherIndex put: element! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:22'!
third
	"Answer the third element of the receiver.
	Raise an error if there are not enough elements."

	^ self at: 3! !


!SequenceableCollection methodsFor: 'comparing' stamp: 'tk 12/6/2000 11:39'!
hasEqualElements: otherCollection
	"Answer whether the receiver's size is the same as otherCollection's
	size, and each of the receiver's elements equal the corresponding 
	element of otherCollection.
	This should probably replace the current definition of #= ."

	| size |
	(otherCollection isKindOf: SequenceableCollection) ifFalse: [^ false].
	(size _ self size) = otherCollection size ifFalse: [^ false].
	1 to: size do:
		[:index |
		(self at: index) = (otherCollection at: index) ifFalse: [^ false]].
	^ true! !

!SequenceableCollection methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:39'!
hash
	| hash |

	hash _ self species hash.
	1 to: self size do: [:i | hash _ (hash + (self at: i) hash) hashMultiply].
	^hash! !

!SequenceableCollection methodsFor: 'comparing' stamp: 'sma 5/12/2000 14:04'!
= otherCollection 
	"Answer true if the receiver is equivalent to the otherCollection.
	First test for identity, then rule out different species and sizes of
	collections. As a last resort, examine each element of the receiver
	and the otherCollection."

	self == otherCollection ifTrue: [^ true].
	self species == otherCollection species ifFalse: [^ false].
	^ self hasEqualElements: otherCollection! !


!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'!
asArray
	"Answer an Array whose elements are the elements of the receiver."

	^ Array withAll: self! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:36'!
asByteArray
	"Answer a ByteArray whose elements are the elements of the receiver."

	^ ByteArray withAll: self! !

!SequenceableCollection methodsFor: 'converting' stamp: 'ar 3/3/2001 20:06'!
asColorArray
	^ColorArray withAll: self! !

!SequenceableCollection methodsFor: 'converting' stamp: 'ar 9/14/1998 23:47'!
asFloatArray
	"Answer a FloatArray whose elements are the elements of the receiver, in 
	the same order."

	| floatArray |
	floatArray _ FloatArray new: self size.
	1 to: self size do:[:i| floatArray at: i put: (self at: i) asFloat ].
	^floatArray! !

!SequenceableCollection methodsFor: 'converting' stamp: 'ar 10/10/1998 16:19'!
asIntegerArray
	"Answer an IntegerArray whose elements are the elements of the receiver, in 
	the same order."

	| intArray |
	intArray _ IntegerArray new: self size.
	1 to: self size do:[:i| intArray at: i put: (self at: i)].
	^intArray! !

!SequenceableCollection methodsFor: 'converting' stamp: 'NS 5/30/2001 20:56'!
asPointArray
	"Answer an PointArray whose elements are the elements of the receiver, in 
	the same order."

	| pointArray |
	pointArray _ PointArray new: self size.
	1 to: self size do:[:i| pointArray at: i put: (self at: i)].
	^pointArray! !

!SequenceableCollection methodsFor: 'converting' stamp: 'ar 4/10/2005 18:02'!
asStringWithCr
	"Convert to a string with returns between items.  Elements are
usually strings.
	 Useful for labels for PopUpMenus."
	| labelStream |
	labelStream _ WriteStream on: (String new: 200).
	self do: [:each |
		each isString
			ifTrue: [labelStream nextPutAll: each; cr]
			ifFalse: [each printOn: labelStream. labelStream cr]].
	self size > 0 ifTrue: [labelStream skip: -1].
	^ labelStream contents! !

!SequenceableCollection methodsFor: 'converting' stamp: 'ar 10/10/1998 16:20'!
asWordArray
	"Answer a WordArray whose elements are the elements of the receiver, in 
	the same order."

	| wordArray |
	wordArray _ WordArray new: self size.
	1 to: self size do:[:i| wordArray at: i put: (self at: i)].
	^wordArray! !

!SequenceableCollection methodsFor: 'converting' stamp: 'raok 6/23/2003 12:51'!
concatenation
	|result index|

	result _ Array new: (self inject: 0 into: [:sum :each | sum + each size]).
	index _ 0.
	self do: [:each | each do: [:item | result at: (index _ index+1) put: item]].
	^result! !

!SequenceableCollection methodsFor: 'converting' stamp: 'di 11/6/1998 09:35'!
isSequenceable
	^ true! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 12:51'!
readStream
	^ ReadStream on: self! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:56'!
reverse
	^ self reversed! !

!SequenceableCollection methodsFor: 'converting' stamp: 'jm 4/27/98 04:09'!
reversed
	"Answer a copy of the receiver with element order reversed."
	"Example: 'frog' reversed"

	| n result src |
	n _ self size.
	result _ self species new: n.
	src _ n + 1.
	1 to: n do: [:i | result at: i put: (self at: (src _ src - 1))].
	^ result
! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 12:52'!
writeStream
	^ WriteStream on: self! !

!SequenceableCollection methodsFor: 'converting' stamp: 'TAG 11/6/1998 15:55'!
@ aCollection 
	^ self with: aCollection collect: [:a :b | a @ b]! !


!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:05'!
copyAfterLast: anElement
	"Answer a copy of the receiver from after the last occurence
	of anElement up to the end. If no such element exists, answer 
	an empty copy."

	^ self allButFirst: (self lastIndexOf: anElement ifAbsent: [^ self copyEmpty])! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:05'!
copyAfter: anElement
	"Answer a copy of the receiver from after the first occurence
	of anElement up to the end. If no such element exists, answer 
	an empty copy."

	^ self allButFirst: (self indexOf: anElement ifAbsent: [^ self copyEmpty])! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:07'!
copyEmpty
	^ self species new: 0! !

!SequenceableCollection methodsFor: 'copying'!
copyFrom: start to: stop 
	"Answer a copy of a subset of the receiver, starting from element at 
	index start until element at index stop."

	| newSize |
	newSize _ stop - start + 1.
	^(self species new: newSize)
		replaceFrom: 1
		to: newSize
		with: self
		startingAt: start! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:06'!
copyLast: num
	"Deprecated. Use #last:"

	^ self last: num! !

!SequenceableCollection methodsFor: 'copying'!
copyReplaceAll: oldSubstring with: newSubstring 
	"Default is not to do token matching.
	See also String copyReplaceTokens:with:"
	^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: false
	"'How now brown cow?' copyReplaceAll: 'ow' with: 'ello'"
	"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Pile'"! !

!SequenceableCollection methodsFor: 'copying' stamp: 'ar 10/16/2001 19:03'!
copyReplaceFrom: start to: stop with: replacementCollection 
	"Answer a copy of the receiver satisfying the following conditions: If 
	stop is less than start, then this is an insertion; stop should be exactly 
	start-1, start = 1 means insert before the first character, start = size+1 
	means append after last character. Otherwise, this is a replacement; start 
	and stop have to be within the receiver's bounds."

	| newSequenceableCollection newSize endReplacement |
	newSize _ self size - (stop - start + 1) + replacementCollection size.
	endReplacement _ start - 1 + replacementCollection size.
	newSequenceableCollection _ self species new: newSize.
	start > 1 ifTrue:[
		newSequenceableCollection
			replaceFrom: 1
			to: start - 1
			with: self
			startingAt: 1].
	start <= endReplacement ifTrue:[
		newSequenceableCollection
			replaceFrom: start
			to: endReplacement
			with: replacementCollection
			startingAt: 1].
	endReplacement < newSize ifTrue:[
		newSequenceableCollection
			replaceFrom: endReplacement + 1
			to: newSize
			with: self
			startingAt: stop + 1].
	^newSequenceableCollection! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:02'!
copyUpToLast: anElement
	"Answer a copy of the receiver from index 1 to the last occurrence of 
	anElement, not including anElement."

	^ self first: (self lastIndexOf: anElement ifAbsent: [^ self copy]) - 1! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:00'!
copyUpTo: anElement 
	"Answer all elements up to but not including anObject. If there
	is no such object, answer a copy of the receiver."

	^ self first: (self indexOf: anElement ifAbsent: [^ self copy]) - 1! !

!SequenceableCollection methodsFor: 'copying' stamp: 'ajh 9/27/2002 12:09'!
copyWithFirst: newElement 
	"Answer a copy of the receiver that is 1 bigger than the receiver with newElement as the first element."

	| newIC |
	newIC _ self species ofSize: self size + 1.
	newIC 
		replaceFrom: 2
		to: self size + 1
		with: self
		startingAt: 1.
	newIC at: 1 put: newElement.
	^ newIC! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 15:38'!
copyWithoutFirst
	"Deprecatd. Return a copy of the receiver which doesn't include
	the first element."

	^ self allButFirst! !

!SequenceableCollection methodsFor: 'copying' stamp: 'rhi 12/6/2001 14:04'!
copyWithoutIndex: index
	"Return a copy containing all elements except the index-th."

	| copy |
	copy := self species ofSize: self size - 1.
	copy replaceFrom: 1 to: index-1 with: self startingAt: 1.
	copy replaceFrom: index to: copy size with: self startingAt: index+1.
	^ copy! !

!SequenceableCollection methodsFor: 'copying'!
copyWith: newElement 
	"Answer a copy of the receiver that is 1 bigger than the receiver and has 
	newElement at the last element."

	| newIC |
	newIC _ self species new: self size + 1.
	newIC 
		replaceFrom: 1
		to: self size
		with: self
		startingAt: 1.
	newIC at: newIC size put: newElement.
	^newIC! !

!SequenceableCollection methodsFor: 'copying' stamp: 'fcs 1/20/2002 16:03'!
forceTo: length paddingStartWith: elem 
	"Force the length of the collection to length, padding  
	the beginning of the result if necessary with elem.  
	Note that this makes a copy."
	| newCollection padLen |
	newCollection _ self species new: length.
	padLen _ length - self size max: 0.
	newCollection
		from: 1
		to: padLen
		put: elem.
	newCollection
		replaceFrom: padLen + 1
		to: ((padLen + self size) min: length)
		with: self
		startingAt:  1.
	^ newCollection! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 4/22/2000 18:01'!
forceTo: length paddingWith: elem
	"Force the length of the collection to length, padding
	if necessary with elem.  Note that this makes a copy."

	| newCollection copyLen |
	newCollection _ self species new: length.
	copyLen _ self size min: length.
	newCollection replaceFrom: 1 to: copyLen with: self startingAt: 1.
	newCollection from: copyLen + 1 to: length put: elem.
	^ newCollection! !

!SequenceableCollection methodsFor: 'copying'!
shallowCopy

	^self copyFrom: 1 to: self size! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 5/12/2000 12:36'!
shuffled
	^ self shuffledBy: Collection randomForPicking

"Examples:
	($A to: $Z) shuffled
"! !

!SequenceableCollection methodsFor: 'copying' stamp: 'djp 10/23/1999 22:12'!
shuffledBy: aRandom
	| copy | 
	copy _ self shallowCopy.
	copy size to: 1 by: -1 do: 
		[:i | copy swap: i with: ((1 to: i) atRandom: aRandom)].
	^ copy! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 4/28/2000 18:34'!
sortBy: aBlock
	"Create a copy that is sorted.  Sort criteria is the block that accepts two arguments.
	When the block is true, the first arg goes first ([:a :b | a > b] sorts in descending
	order)."

	^ (self asSortedCollection: aBlock) asOrderedCollection! !

!SequenceableCollection methodsFor: 'copying' stamp: 'md 7/14/2006 12:11'!
, otherCollection 
	"Concatenate two Strings or Collections."
	
	^ self copyReplaceFrom: self size + 1
		  to: self size
		  with: otherCollection
"
#(2 4 6 8) , #(who do we appreciate)
((2989 storeStringBase: 16) copyFrom: 4 to: 6) , ' boy!!'
"! !


!SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 15:03'!
allButFirstDo: block

	2 to: self size do:
		[:index | block value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 15:01'!
allButLastDo: block

	1 to: self size - 1 do:
		[:index | block value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 7/30/97 12:41'!
asDigitsToPower: anInteger do: aBlock
	"Repeatedly value aBlock with a single Array.  Adjust the collection
	so that aBlock is presented all (self size raisedTo: anInteger) possible 
	combinations of the receiver's elements taken as digits of an anInteger long number."
	"(0 to: 1) asDigitsToPower: 4 do: [:each | Transcript cr; show: each printString]"

	| aCollection |
	aCollection _ Array new: anInteger.
	self asDigitsAt: 1 in: aCollection do: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:44'!
collectWithIndex: elementAndIndexBlock
	"Use the new version with consistent naming"
	^ self withIndexCollect: elementAndIndexBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:46'!
collect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Collect the resulting values into a collection like the receiver. Answer  
	the new collection."

	| newCollection |
	newCollection _ self species new: self size.
	1 to: self size do:
		[:index |
		newCollection at: index put: (aBlock value: (self at: index))].
	^ newCollection! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 6/1/2000 11:47'!
collect: aBlock from: firstIndex to: lastIndex
	"Refer to the comment in Collection|collect:."

	| size result j |
	size _ lastIndex - firstIndex + 1.
	result _ self species new: size.
	j _ firstIndex.
	1 to: size do: [:i | result at: i put: (aBlock value: (self at: j)). j _ j + 1].
	^ result! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 7/30/97 12:52'!
combinations: kk atATimeDo: aBlock
	"Take the items in the receiver, kk at a time, and evaluate the block for each combination.  Hand in an array of elements of self as the block argument.  Each combination only occurs once, and order of the elements does not matter.  There are (self size take: kk) combinations."
	" 'abcde' combinations: 3 atATimeDo: [:each | Transcript cr; show: each printString]"

	| aCollection |
	aCollection _ Array new: kk.
	self combinationsAt: 1 in: aCollection after: 0 do: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:43'!
doWithIndex: elementAndIndexBlock
	"Use the new version with consistent naming"
	^ self withIndexDo: elementAndIndexBlock! !

!SequenceableCollection methodsFor: 'enumerating'!
do: aBlock 
	"Refer to the comment in Collection|do:."
	1 to: self size do:
		[:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ab 9/17/2002 01:02'!
do: aBlock displayingProgress: aString
	aString
		displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
			[:bar |
			self withIndexDo:
				[:each :i |
				bar value: i.
				aBlock value: each]]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:56'!
do: elementBlock separatedBy: separatorBlock
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."

	1 to: self size do:
		[:index |
		index = 1 ifFalse: [separatorBlock value].
		elementBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 5/1/1999 05:01'!
do: aBlock without: anItem
	"Enumerate all elements in the receiver.
	Execute aBlock for those elements that are not equal to the given item"
	"Refer to the comment in Collection|do:."
	1 to: self size do:
		[:index | anItem = (self at: index) ifFalse:[aBlock value: (self at: index)]]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:54'!
findBinaryIndex: aBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, raise an error.
	Examples:
		#(1 3 5 7 11 15 23) findBinaryIndex:[:arg| 11 - arg]
	"
	^self findBinaryIndex: aBlock ifNone: [self errorNotFound: aBlock]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:54'!
findBinaryIndex: aBlock ifNone: exceptionBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, evaluate exceptionBlock."
	| index low high test |
	low _ 1.
	high _ self size.
	[index _ high + low // 2.
	low > high] whileFalse:[
		test _ aBlock value: (self at: index).
		test = 0 
			ifTrue:[^index]
			ifFalse:[test > 0
				ifTrue: [low _ index + 1]
				ifFalse: [high _ index - 1]]].
	^exceptionBlock value! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:53'!
findBinary: aBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, raise an error.
	Examples:
		#(1 3 5 7 11 15 23) findBinary:[:arg| 11 - arg]
	"
	^self findBinary: aBlock ifNone: [self errorNotFound: aBlock]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:52'!
findBinary: aBlock ifNone: exceptionBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, evaluate exceptionBlock."
	| index low high test item |
	low _ 1.
	high _ self size.
	[index _ high + low // 2.
	low > high] whileFalse:[
		test _ aBlock value: (item _ self at: index).
		test = 0 
			ifTrue:[^item]
			ifFalse:[test > 0
				ifTrue: [low _ index + 1]
				ifFalse: [high _ index - 1]]].
	^exceptionBlock value! !

!SequenceableCollection methodsFor: 'enumerating'!
findFirst: aBlock
	"Return the index of my first element for which aBlock evaluates as true."

	| index |
	index _ 0.
	[(index _ index + 1) <= self size] whileTrue:
		[(aBlock value: (self at: index)) ifTrue: [^index]].
	^ 0! !

!SequenceableCollection methodsFor: 'enumerating'!
findLast: aBlock
	"Return the index of my last element for which aBlock evaluates as true."

	| index |
	index _ self size + 1.
	[(index _ index - 1) >= 1] whileTrue:
		[(aBlock value: (self at: index)) ifTrue: [^index]].
	^ 0! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 18:11'!
from: start to: stop do: aBlock
	"Evaluate aBlock for all elements between start and stop (inclusive)."

	start to: stop do: [:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 12/30/2003 15:39'!
groupsOf: n atATimeCollect: aBlock 
	"Evaluate aBlock with my elements taken n at a time. Ignore any 
	leftovers at the end. 
	Allows use of a flattened  
	array for things that naturally group into groups of n. 
	If aBlock has a single argument, pass it an array of n items, 
	otherwise, pass the items as separate arguments. 
	See also pairsDo:"
	| passArray args  |
	passArray := aBlock numArgs = 1.
	^(n
		to: self size
		by: n)
		collect: [:index | 
			args := (self copyFrom: index - n + 1 to: index) asArray.
			passArray
				ifTrue: [aBlock value: args]
				ifFalse: [aBlock valueWithArguments: args]]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 12/30/2003 15:37'!
groupsOf: n atATimeDo: aBlock 
	"Evaluate aBlock with my elements taken n at a time. Ignore any leftovers at the end.
	Allows use of a flattened 
	array for things that naturally group into groups of n.
	If aBlock has a single argument, pass it an array of n items,
	otherwise, pass the items as separate arguments.
	See also pairsDo:"
	| passArray args |
	passArray := (aBlock numArgs = 1).
	n
		to: self size
		by: n
		do: [:index | 
			args := (self copyFrom: index - n + 1 to: index) asArray.
			passArray ifTrue: [ aBlock value: args ]
				ifFalse: [ aBlock valueWithArguments: args ]].! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 18:13'!
keysAndValuesDo: aBlock 
	"Enumerate the receiver with all the keys (aka indices) and values."

	1 to: self size do: [:index | aBlock value: index value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 8/23/2003 10:42'!
nextToLast
	^self at: self size - 1! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 7/17/2003 17:55'!
overlappingPairsCollect: aBlock 
	"Answer the result of evaluating aBlock with all of the overlapping pairs of my elements."
	| retval |
	retval _ self species new: self size - 1.
	1 to: self size - 1
		do: [:i | retval at: i put: (aBlock value: (self at: i) value: (self at: i + 1)) ].
	^retval! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 7/17/2003 17:55'!
overlappingPairsDo: aBlock 
	"Emit overlapping pairs of my elements into aBlock"

	1 to: self size - 1
		do: [:i | aBlock value: (self at: i) value: (self at: i + 1)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 7/17/2003 17:54'!
overlappingPairsWithIndexDo: aBlock 
	"Emit overlapping pairs of my elements into aBlock, along with an index."

	1 to: self size - 1
		do: [:i | aBlock value: (self at: i) value: (self at: i + 1) value: i ]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 3/30/2002 12:45'!
paddedWith: otherCollection do: twoArgBlock 
	"Evaluate twoArgBlock with corresponding elements from this collection and otherCollection.
	Missing elements from either will be passed as nil."
	1 to: (self size max: otherCollection size) do:
		[:index | twoArgBlock value: (self at: index ifAbsent: [])
				value: (otherCollection at: index ifAbsent: [])]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 11/12/1998 15:01'!
pairsCollect: aBlock 
	"Evaluate aBlock with my elements taken two at a time, and return an Array with the results"

	^ (1 to: self size // 2) collect:
		[:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)]
"
#(1 'fred' 2 'charlie' 3 'elmer') pairsCollect:
	[:a :b | b, ' is number ', a printString]
"! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 11/12/1998 15:01'!
pairsDo: aBlock 
	"Evaluate aBlock with my elements taken two at a time.  If there's an odd number of items, ignore the last one.  Allows use of a flattened array for things that naturally group into pairs.  See also pairsCollect:"

	1 to: self size // 2 do:
		[:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)]
"
#(1 'fred' 2 'charlie' 3 'elmer') pairsDo:
	[:a :b | Transcript cr; show: b, ' is number ', a printString]
"! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ward 7/28/97 09:41'!
permutationsDo: aBlock
	"Repeatly value aBlock with a single copy of the receiver. Reorder the copy
	so that aBlock is presented all (self size factorial) possible permutations."
	"(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]"

	self shallowCopy permutationsStartingAt: 1 do: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 12/27/2000 09:53'!
polynomialEval: thisX
	| sum valToPower |
	"Treat myself as the coeficients of a polynomial in X.  Evaluate it with thisX.  First element is the constant and last is the coeficient for the highest power."
	"  #(1 2 3) polynomialEval: 2   "   "is 3*X^2 + 2*X + 1 with X = 2"

	sum _ self first.
	valToPower _ thisX.
	2 to: self size do: [:ind | 
		sum _ sum + ((self at: ind) * valToPower).
		valToPower _ valToPower * thisX].
	^ sum! !

!SequenceableCollection methodsFor: 'enumerating'!
reverseDo: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument, 
	starting with the last element and taking each in sequence up to the 
	first. For SequenceableCollections, this is the reverse of the enumeration 
	for do:."

	self size to: 1 by: -1 do: [:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating'!
reverseWith: aSequenceableCollection do: aBlock 
	"Evaluate aBlock with each of the receiver's elements, in reverse order, 
	along with the  
	corresponding element, also in reverse order, from 
	aSequencableCollection. "

	self size ~= aSequenceableCollection size ifTrue: [^ self errorNoMatch].
	self size
		to: 1
		by: -1
		do: [:index | aBlock value: (self at: index)
				value: (aSequenceableCollection at: index)]! !

!SequenceableCollection methodsFor: 'enumerating'!
select: aBlock 
	"Refer to the comment in Collection|select:."
	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	1 to: self size do: 
		[:index |
		(aBlock value: (self at: index))
			ifTrue: [aStream nextPut: (self at: index)]].
	^ aStream contents! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'huma 12/11/2004 20:43'!
upTo: anObject
	"Deprecated. Use copyUpTo:"
	self deprecated: 'Use #copyUpTo:'.
	^ self copyUpTo: anObject! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 5/17/1998 13:34'!
withIndexCollect: elementAndIndexBlock 
	"Just like with:collect: except that the iteration index supplies the second argument to the block."
	| result |
	result _ self species new: self size.
	1 to: self size do:
		[:index | result at: index put:
		(elementAndIndexBlock
			value: (self at: index)
			value: index)].
	^ result! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:35'!
withIndexDo: elementAndIndexBlock 
	"Just like with:do: except that the iteration index supplies the second argument to the block."
	1 to: self size do:
		[:index |
		elementAndIndexBlock
			value: (self at: index)
			value: index]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'!
with: otherCollection collect: twoArgBlock 
	"Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection."
	| result |
	otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
	result _ self species new: self size.
	1 to: self size do:
		[:index | result at: index put:
		(twoArgBlock
			value: (self at: index)
			value: (otherCollection at: index))].
	^ result! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 8/3/1999 15:26'!
with: otherCollection do: twoArgBlock 
	"Evaluate twoArgBlock with corresponding elements from this collection and otherCollection."
	otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
	1 to: self size do:
		[:index |
		twoArgBlock value: (self at: index)
				value: (otherCollection at: index)]! !


!SequenceableCollection methodsFor: 'explorer' stamp: 'hg 9/7/2001 12:01'!
explorerContents

	^self asOrderedCollection withIndexCollect: [:value :index |
		ObjectExplorerWrapper
			with: value
			name: index printString
			model: self]! !


!SequenceableCollection methodsFor: 'removing'!
remove: oldObject ifAbsent: anExceptionBlock 
	"SequencableCollections cannot implement removing."

	self shouldNotImplement! !


!SequenceableCollection methodsFor: 'testing' stamp: 'bp 2/23/2004 21:47'!
beginsWith: aSequenceableCollection

	(aSequenceableCollection isEmpty or: [self size < aSequenceableCollection size]) ifTrue: [^false].
	aSequenceableCollection withIndexDo: [:each :index | (self at: index) ~= each ifTrue: [^false]].
	^true! !

!SequenceableCollection methodsFor: 'testing' stamp: 'bp 2/23/2004 21:48'!
endsWith: aSequenceableCollection

	| start |
	(aSequenceableCollection isEmpty or: [self size < aSequenceableCollection size]) ifTrue: [^false].
	start _ self size - aSequenceableCollection size.
	aSequenceableCollection withIndexDo: [:each :index | (self at: start + index) ~= each ifTrue: [^false]].
	^true! !

!SequenceableCollection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:08'!
includes: anObject
	"Answer whether anObject is one of the receiver's elements."

	^ (self indexOf: anObject) ~= 0! !


!SequenceableCollection methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:59'!
startsWith: start 
	| comp |
	self size < start size ifTrue: [^ false].
	comp := true.
	(self first: start size) with: start
		do: [:ea :ea2 | ea = ea2 ifFalse: [comp := false]].
	^ comp! !


!SequenceableCollection methodsFor: '*Traits' stamp: 'apb 8/22/2005 17:07'!
asTraitComposition
	"For convenience the composition {T1. T2 ...} is the same as T1 + T2 + ..."
	^self isEmpty
		ifFalse: [
			self size = 1
				ifTrue: [self first asTraitComposition]
				ifFalse: [
					self copyWithoutFirst 
						inject: self first
						into: [:left :right | left + right]]]
		ifTrue: [
			TraitComposition new]! !


!SequenceableCollection methodsFor: 'private' stamp: 'tk 7/30/97 12:42'!
asDigitsAt: anInteger in: aCollection do: aBlock
	"(0 to: 1) asDigitsToPower: 4 do: [:each | Transcript cr; show: each printString]"

	self do: 
		[:each | 
		aCollection at: anInteger put: each.
		anInteger = aCollection size 
			ifTrue: [aBlock value: aCollection]
			ifFalse: [self asDigitsAt: anInteger + 1 in: aCollection do: aBlock]].! !

!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 13:57'!
checkedAt: index
	index > self size ifTrue: [self error: 'not enough elements'].
	^ self at: index! !

!SequenceableCollection methodsFor: 'private' stamp: 'tk 7/30/97 12:42'!
combinationsAt: jj in: aCollection after: nn do: aBlock
	"Choose k of N items and put in aCollection.  jj-1 already chosen.  Indexes of items are in numerical order, to avoid the same combo being used twice.  In this slot, we are allowed to use items in self indexed by nn+1 to self size.  nn is the index used for position jj-1."
	"(1 to: 6) combinationsSize: 3 do: [:each | Transcript cr; show: each printString]"

nn+1 to: self size do: [:index | 
		aCollection at: jj put: (self at: index).
		jj = aCollection size 
			ifTrue: [aBlock value: aCollection]
			ifFalse: [self combinationsAt: jj + 1 in: aCollection after: index do: aBlock]].! !

!SequenceableCollection methodsFor: 'private' stamp: 'yo 9/2/2002 18:22'!
copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens
	"Answer a copy of the receiver in which all occurrences of
	oldSubstring have been replaced by newSubstring.
	ifTokens (valid for Strings only) specifies that the characters
	surrounding the recplacement must not be alphanumeric.
		Bruce Simth,  must be incremented by 1 and not 
	newSubstring if ifTokens is true.  See example below. "

	| aString startSearch currentIndex endIndex |
	(ifTokens and: [(self isString) not])
		ifTrue: [(self isKindOf: Text) ifFalse: [
			self error: 'Token replacement only valid for Strings']].
	aString _ self.
	startSearch _ 1.
	[(currentIndex _ aString indexOfSubCollection: oldSubstring startingAt: startSearch)
			 > 0]
		whileTrue: 
		[endIndex _ currentIndex + oldSubstring size - 1.
		(ifTokens not
			or: [(currentIndex = 1
					or: [(aString at: currentIndex-1) isAlphaNumeric not])
				and: [endIndex = aString size
					or: [(aString at: endIndex+1) isAlphaNumeric not]]])
			ifTrue: [aString _ aString
					copyReplaceFrom: currentIndex
					to: endIndex
					with: newSubstring.
				startSearch _ currentIndex + newSubstring size]
			ifFalse: [
				ifTokens 
					ifTrue: [startSearch _ currentIndex + 1]
					ifFalse: [startSearch _ currentIndex + newSubstring size]]].
	^ aString

"Test case:
	'test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true   "
! !

!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 18:06'!
errorFirstObject: anObject
	self error: 'specified object is first object'! !

!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 18:03'!
errorLastObject: anObject
	self error: 'specified object is last object'! !

!SequenceableCollection methodsFor: 'private'!
errorOutOfBounds

	self error: 'indices are out of bounds'! !

!SequenceableCollection methodsFor: 'private' stamp: 'ward 7/28/97 09:38'!
permutationsStartingAt: anInteger do: aBlock
	"#(1 2 3 4) permutationsDo: [:each | Transcript cr; show: each printString]"

	anInteger > self size ifTrue: [^self].
	anInteger = self size ifTrue: [^aBlock value: self].
	anInteger to: self size do:
		[:i | self swap: anInteger with: i.
		self permutationsStartingAt: anInteger + 1 do: aBlock.
		self swap: anInteger with: i]! !


!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 7/18/2004 23:12'!
asCubic
	"Convert this point array to a Cubic object"
	self
		assert: [self size = 4].
	self
		assert: [self
				allSatisfy: [:each | each isPoint]].
	^ Cubic withAll: self! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/18/2006 12:57'!
assertSlopesWith: knots from: start to: end
   "
	We trust everything has been checked. 
	The following assertions should hold at this point: "
	
	
	| slope |
	self assert: [ self size = knots size ] . 
	"Sizes must be consistent." 
	self assert: [ end > start]. 
	"There must be at least one slope to clamp." 
	self assert: [ 0 < start and: [start <= knots size] ]. 
	"The clamped slope may be the last one."
	self assert: [  end  <= knots size + start ] . 
	"We can wrap. There may be only one known slope."
	"xxx self assert: [ end = knots size + start ifTrue: [ (self at: start) notNil ] ] . xxx"
		"xxx If we overlap slope must be known. xxx"
	{ start . end } 
		do: [ :index | slope := (self at: index )
	self assert: [ slope isNil 
				or: [ slope isNumber 
				or: [ slope isPoint ] ] ] ] . 
	"And a known and reasonalble value or nil." 
		^true 
	! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 1/30/2005 21:04'!
changeInSlopes: slopes 
	"A message to knots of a spline. Returns an array with the 3rd cubic coeff."
	"The last nth item is correct iff this is a closed cubic.
	Presumably that is the only time we care.
	We always return the same sized array as self."
	| n slopeChanges |
	n := self size.
	n = slopes size
		ifFalse: [^ self error: 'vertices and slopes differ in number'].
	slopeChanges := Array new: n.
	(1 to: n)
		do: [:i | slopeChanges at: i put: (self atWrap: i + 1)
					- (self at: i) * 3 - ((slopes at: i)
						* 2)
					- (slopes atWrap: i + 1)].
	
	^ slopeChanges! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 1/30/2005 21:04'!
changeOfChangesInSlopes: slopes 
	"A message to knots of a spline. Returns an array with the 4rd 
	cubic coeff."
	"The last nth item is correct iff this is a closed cubic. 
	Presumably that is the only time we care. 
	We always return the same sized array as self."
	| n changes |
	n := self size.
	n = slopes size
		ifFalse: [^ self error: 'vertices and slopes differ in number'].
	changes := Array new: n.
	(1 to: n)
		do: [:i | changes at: i put: (self at: i)
					- (self atWrap: i + 1) * 2
					+ (slopes at: i)
					+ (slopes atWrap: i + 1)].
	
	^ changes! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 1/30/2005 22:03'!
closedCubicSlopes
	"Sent to knots returns the slopes of a closed cubic spline.
	From the same set of java sources as naturalCubic. This is a squeak  
	transliteration of the java code."
	"from java code NatCubicClosed extends NatCubic  
	solves for the set of equations for all knots: 
	b1+4*b2+b3=3*(a3-a1)
	where a1 is (knots atWrap: index + 1) etc.
	and the b's are the slopes .
	
	by decomposing the matrix into upper triangular and lower matrices  
	and then back sustitution. See Spath 'Spline Algorithms for Curves  
	and Surfaces' pp 19--21. The D[i] are the derivatives at the knots.  
	"
	
	| v w x y z n1  D F G H |
	n1 := self size.
	n1 < 3
		ifTrue: [self error: 'Less than 3 points makes a poor curve'].
	v := Array new: n1.
	w := Array new: n1.
	y := Array new: n1.
	
	D := Array new: n1.
	x := self.
	z := 1.0 / 4.0.
	v at: 2 put: z.
	w at: 2 put: z.
	y at: 1 put: z * 3.0 * ((x at: 2)
				- (x at: n1)).
	H := 4.0.
	F := 3 * ((x at: 1)
					- (x at: n1 - 1)).
	G := 1.
	(2 to: n1 - 1)
		do: [:k | 
			z := 1.0 / (4.0
							- (v at: k)).
			v at: k + 1 put: z.
			w at: k + 1 put: z negated
					* (w at: k).
			y at: k put: z * (3.0 * ((x at: k + 1)
							- (x at: k - 1))
						- (y at: k - 1)).
			H := H - (G
						* (w at: k)).
			F := F - (G
						* (y at: k - 1)).
			G := (v at: k) negated * G].
	H := H - (G + 1 * ((v at: n1)
						+ (w at: n1))).
	y at: n1 put: F - (G + 1
				* (y at: n1 - 1)).
	D at: n1 put: (y at: n1)
			/ H.
	D at: n1 - 1 put: (y at: n1 - 1)
			- ((v at: n1)
					+ (w at: n1)
					* (D at: n1)).
	(1 to: n1 - 2)
		reverseDo: [:k | D at: k put: (y at: k)
					- ((v at: k + 1)
							* (D at: k + 1)) - ((w at: k + 1)
						* (D at: n1))].
^ D .

! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/18/2006 12:54'!
closedCubicSlopes: clampedSlopes
	"Sent to knots returns a copy of clampedSlopes with the values of the undefined (nil)  slopes filled in.
	"
	" clampedSlopes must be the same size as knots)" 
	
	"/* Between known slopes we solve the equation for knots with end conditions:  
	4*b1+b2 = 3(a2 - a0) - b0 
	bN2+4*bN1 = 3*(aN-aN2) - bN
	and inbetween:
	b2+4*b3+b4=3*(a4-a2)
	where a2 is (knots atWrap: index + 1) etc.
	and the b's are the slopes .
	N is the last index (knots size)
	N1 is N-1.
	 
	by using row operations to convert the matrix to upper  
	triangular and then back substitution. 
	"
	| slopes tripleKnots list |
	(list := clampedSlopes closedFillinList) = { 0 to: self size } ifTrue: [ ^ self closedCubicSlopes ] .
	"Special case all unknown."
	
	tripleKnots := self * 3.0 . 
	" Premultiply and convert numbers or point coords to Floats "
	slopes := clampedSlopes copy. "slopes contents will be modified."
	
	list do: [ :r | slopes slopesWith: tripleKnots from: r first to: r last ] .
	
	^ slopes! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/17/2006 01:42'!
closedFillinList
	"Answers a list of ranges between which values are undertermined.
	Reciever is a list that combines known values and nil entries for
	undetermined values.
	Answer a list of ranges. Each range starts and ends with a known
	value. 
	The range inbetween the known values are nil. The ranges start and
	ends may overlap. 
	Each nil element in the list appears in exactly one range. 
	If the list starts or ends with nil the last range will wrap around to the
	next known value. There may be only one known value in the list but
	there must be atleast one know value.
	
	(self allsatisfy: [ :e | e isNil ] ) ifTrue: [ self error: 'list must contain at
	least one known value' ] 
	"
	| changes n |
	changes := self nilTransitions .
	changes isEmpty ifTrue: [ ^ { 0 to: self size } "Special case. All unknowns." ] .
	 
	changes = #(1) ifTrue: [ ^ #() "Special case. no unknowns." ] . 
	changes = { n :=  self size } ifTrue: [ ^ { n to: n + n } ] .
	"Special case. Only last element known."
	
	changes size even ifTrue: 
			[changes add: self size
							+ (changes at: 1)]
						ifFalse: [
		changes first = 1 ifFalse: [ changes add: self size + 1;
											add: self size + changes first ]
						
		].
	^ changes allButFirst pairsCollect: [ :s :e | ( s - 1 to: e ) ] .

	! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 7/18/2004 23:18'!
cubicPointPolynomialAt: vIndex
	"From curve information assemble a 4-array of points representing the coefficents for curve segment between to points. Beginning point is first point in array endpoint is the pointSum of the array. Meant to be sent to newcurves idea of curve coefficents." 
	^ ((1 to: 4)
		collect: [:i | ((self at: i)
				at: vIndex)
				@ ((self at: 4 + i)
						at: vIndex)]) asCubic! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/12/2006 23:21'!
naturalCubicSlopes
	"Sent to knots returns the slopes of a natural cubic curve fit.
	This is a direct  squeak  
	transliteration of the java code."
	" public class NatCubic extends ControlCurve
	
	/* We solve the equation for knots with end conditions:  
	2*b1+b2 = 3(a1 - a0) 
	bN1+2*bN = 3*(aN-aN1)
	and inbetween:
	b2+4*b3+b4=3*(a4-a2)
	where a2 is (knots atWrap: index + 1) etc.
	and the b's are the slopes .
	N is the last index (knots size)
	N1 is N-1.
	 
	by using row operations to convert the matrix to upper  
	triangular  
	and then back sustitution. The D[i] are the derivatives at the  
	knots.  
	"
	| x gamma delta D n1 |
	n1 := self size.
	n1 < 3
		ifTrue: [self error: 'Less than 3 points makes a poor curve'].
	x := self.
	gamma := Array new: n1.
	delta := Array new: n1.
	
	D := Array new: n1.
	gamma at: 1 put: 1.0 / 2.0.
	(2 to: n1 - 1)
		do: [:i | gamma at: i put: 1.0 / (4.0
						- (gamma at: i - 1))].
	gamma at: n1 put: 1.0 / (2.0
				- (gamma at: n1 - 1)).
	delta at: 1 put: 3.0 * ((x at: 2)
				- (x at: 1))
			* (gamma at: 1).
	(2 to: n1 - 1)
		do: [:i | delta at: i put: 3.0 * ((x at: i + 1)
						- (x at: i - 1))
					- (delta at: i - 1)
					* (gamma at: i)].
	delta at: n1 put: 3.0 * ((x at: n1)
				- (x at: n1 - 1))
			- (delta at: n1 - 1)
			* (gamma at: n1).
	D
		at: n1
		put: (delta at: n1).
	(1 to: n1 - 1)
		reverseDo: [:i | D at: i put: (delta at: i)
					- ((gamma at: i)
							* (D at: i + 1))].
	^ D! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/18/2006 12:55'!
naturalCubicSlopes: clampedSlopes
	"Sent to knots returns a copy of clampedSlopes with the values of the undefined (nil)  slopes filled in.
	"
	" clampedSlopes must be the same size as knots)" 
	
	"/* Between known slopes we solve the equation for knots with end conditions:  
	4*b1+b2 = 3(a2 - a0) - b0 
	bN2+4*bN1 = 3*(aN-aN2) - bN
	and inbetween:
	b2+4*b3+b4=3*(a4-a2)
	where a2 is (knots atWrap: index + 1) etc.
	and the b's are the slopes .
	N is the last index (knots size)
	N1 is N-1.
	 
	by using row operations to convert the matrix to upper  
	triangular and then back substitution. 
	"
	| slopes tripleKnots |
	tripleKnots := self * 3.0 . 
	" Premultiply and convert numbers or point coords to Floats "
	slopes := clampedSlopes copy. "slopes will be modified."
	clampedSlopes naturalFillinList do: [ :r | slopes slopesWith: tripleKnots from: r first to: r last ] .
	
	^ slopes! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/9/2006 00:46'!
naturalFillinList
	"Return a list of fillin ranges to be used to calculate natural or clamped slopes.
	Note that this list is slightly different in mission from the closedFillinList"
	"Answers a list of ranges between which value are undertermined.
	Reciever is a list that combines known values and nil entries for
	undetermined values.
	Answer a list of ranges. Each range starts and ends with a known value. 
	With the exception of the first and last slopes on the list which may be unknown.
	If no slopes are known then the only range is the whole list.
	If all slopes are known then the fillin list is empty.
	The range inbetween the known values are nil. The ranges start and
	ends may overlap if the slope at the overlap is known.
	Each nil element in the list appears in exactly one range.  
	"
	| changes  |
	changes := self nilTransitions .
	changes isEmpty ifTrue: [ ^ { 1 to: self size } "Special case all unknown." ] .
	 
	changes = #(1) ifTrue: [ ^ #() "Special case. no unknowns." ] . 
	
	changes size even 
			ifTrue: [changes add: self size ] .  "Last slope is unknown"
	changes first = 1
			ifTrue: [ ^ changes allButFirst pairsCollect: [ :s :e | (  s - 1 to: e ) ] ] .
	 
		"Otherwise first slope is unknown."
				
						
			^ { 1 to: changes first } , 
					(changes allButFirst pairsCollect: [ :s :e | ( ( s - 1) to: e ) ]) 

	! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 1/29/2006 20:51'!
nilTransitions
	"Return an OrderedCollection of transition indexes.  
	Indexes represent where the list elements transitions 
	from nil to nonNil 
		or from nonNil to nil.
	1 is an index in the list iff the first element is nonNil. "
	
	| changes nilSkip |

	changes := OrderedCollection new.
	nilSkip := true .
	
	(1 to: self size)
		do: [:i | (self atWrap: i) isNil == nilSkip
				ifFalse: [changes add: i.
					nilSkip := nilSkip not]].

	^ changes ! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 5/2/2004 22:43'!
segmentedSlopes
	"For a collection of floats. Returns the slopes for straight 
	segments between vertices."
	"last slope closes the polygon. Always return same size as 
	self. "
	^ self
		collectWithIndex: [:x :i | (self atWrap: i + 1)
				- x]! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/18/2006 12:54'!
slopesWith: tripleKnots from: start to: end 
	"Sent to modifiable list of slopes. Fills in the slope values between start
	and end. Start and end slopes can be either clamped or nil. 
	If nil the natural slope for that value will be filled in. 
	We expect that the parameters meets the assertions in
	self assertSlopesWith: knots from: start to: end."
	"
	
	/* We solve the equation for knots with end conditions either known or unknown: 
	4*b1+b2 = 3*(a2 - a0) - b0			b0 known
	Or
	2*b0+b1 = 3*(a1 - a0) .			b0 == nil
	
	bN2+4*bN1 = 3*(aN-aN2)-bN		bN known
	Or
	bN1+2*bN = 3*(aN-aN1)			bN == nil
	 .
	b0, bN are starting and ending slopes.
	
	We now handle the special closed cubic case where a0 == aN ( i.e. N = knots size )
	and b0 == bN == nil .
	
	
	
	
	and inbetween:
	b2+4*b3+b4=3*(a4-a2)
	where a2 is (knots  atWrap: index + 1) etc.
	and the b's are the slopes .
	by using row operations to convert the matrix to upper 
	triangular and then back substitution. 
	"
	| gamma delta n range isOpenRange |
	n := self size.
	gamma := Array new: n.
	delta := Array new: n.
	isOpenRange := end < (start + self size) .
	(self at: start)
		ifNotNil: [
			gamma at: start put: 0.0.
			delta
				at: start
				put: (self at: start).
			range := ( start + 1 to: end - 1 ) .
			] " clamped initial conditions"
		ifNil: [
				isOpenRange
				ifTrue:	
			[gamma at: start put: 2.0 reciprocal.
			delta
				at: start
				put:  ((tripleKnots atWrap: start + 1)
					- tripleKnots at: start ) * (gamma at: start) .
			range := ( start  to: end - 1 ) . ]  "natural initial conditions "
				ifFalse: 
			[ gamma at: start put: 4.0 reciprocal.
			delta
				at: start
				put:  ((tripleKnots atWrap: start + 1)
					- tripleKnots atWrap: start - 1 ) * (gamma at: start) .
			range := ( start + 1  to: end - 1 ) .
				]  "closed initial conditions "
				] .
	(start + 1 to: end - 1)
		do: [:i | gamma atWrap: i put: 1.0 / (4.0
						- (gamma atWrap: i - 1))].
	(start + 1 to: end - 1)
		do: [:i | delta atWrap: i put: ((tripleKnots atWrap: i + 1)
						- (tripleKnots atWrap: i - 1))
					- (delta atWrap: i - 1)
					* (gamma atWrap: i)].
	(self atWrap: end) 
		ifNil: [ isOpenRange
			ifTrue: [
			gamma atWrap: end put: 1.0 / (2.0  
										- (gamma atWrap: end - 1 )).
			delta
				atWrap: end
				put:  ((tripleKnots atWrap: end )
							- tripleKnots atWrap: end - 1 )
					 	- (delta at: end - 1 ) * (gamma atWrap: end)] "natural end conditions"
					ifFalse: [
			gamma atWrap: end put: 1.0 / (4.0  
										- (gamma atWrap: end - 1 )).
			delta
				atWrap: end
				put:  ((tripleKnots atWrap: end + 1 )
							- tripleKnots atWrap: end - 1 ) 
						- (delta at: end - 1 ) * (gamma atWrap: end)] "closed end conditions"  
					.
			self atWrap: end put: (delta atWrap: end ) .
				] 
	ifNotNil: [ 
			gamma atWrap: end put: 0.0 .
			delta
				atWrap: end
				put: (self atWrap: end)  .
		
			] "clamped end conditions" .
		
	range
		reverseDo: [:i | self atWrap: i put: 
					(delta atWrap: i)
					- ((gamma atWrap: i)
							* (self atWrap: i + 1)) ] .
	" reciever now contains the filled in slopes."
	^ self ! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/16/2006 20:08'!
transitions
	"Sent to a list of boolean values. 
	Return an OrderedCollection of transition indexes.  
	Indexes represent where the list elements transitions 
	from true to false
		or from false to true.
	1 is an index in the list iff the first element is false. "
	
	| changes boolSkip |

	changes := OrderedCollection new.
	boolSkip := true .
	
	self
		withIndexDo: [:truth :i | truth  == boolSkip
				ifFalse: [changes add: i.
					boolSkip := boolSkip not]].

	^ changes ! !

!SequenceableCollection methodsFor: '*Morphic-NewCurves-cubic support' stamp: 'wiz 2/16/2006 20:09'!
transitions: aSelectBlock
	"Sent to a list. Select block returns a boolean 
	Return an OrderedCollection of transition indexes.  
	Indexes represent where the list elements transitions 
	from true to false
		or from false to true.
	1 is an index in the list iff the first element tests false. "
	
	| changes boolSkip |

	changes := OrderedCollection new.
	boolSkip := true .
	
	self withIndexDo: 
		 [:e :i | (aSelectBlock value: e ) == boolSkip
				ifFalse: [changes add: i.
					boolSkip := boolSkip not]].

	^ changes ! !


!SequenceableCollection methodsFor: '*Morphic-fliprotate' stamp: 'wiz 4/7/2004 09:31'!
flipRotated: flipIndex 
	"Answer a copy of the receiver with element order indicated by  
	flipIndex."
	"Examples:"
	"'frog' flipRotated: 1"
	"[ :c | (1 to: c size * 2) collect:  
	[ :i | c flipRotated: i ]  
	] value: 'frog'."
	"Lsb of flipIndex indicates whether list is reversed"
	"The flipIndex // 2 gives how much to rotate by after reversing"
	"A good way to think of this is a piece of pie in a pie plate being flip  
	over its leading edge successively."
	"flipIndex > 2 * n are allowed to make it possible to store an array of  
	indexes in an integer."
	| n result src twist |
	n := self size.
	flipIndex \\ (n * 2) = 0
		ifTrue: [^ self].
	"allow for doing nothing"
	result := self species new: n.
	twist := flipIndex // 2 \\ n.
	src := 0.
	(flipIndex even
		ifTrue: [1 + twist to: n + twist]
		ifFalse: [n - 1 - twist to: twist negated by: -1])
		do: [:i | result
				at: (src := src + 1)
				put: (self atWrap: i)].
	^ result! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SequenceableCollection class
	instanceVariableNames: ''!

!SequenceableCollection class methodsFor: 'stream creation'!
streamContents: blockWithArg
	| stream |
	stream _ WriteStream on: (self new: 100).
	blockWithArg value: stream.
	^stream contents! !

!SequenceableCollection class methodsFor: 'stream creation' stamp: 'di 6/20/97 09:07'!
streamContents: blockWithArg limitedTo: sizeLimit
	| stream |
	stream _ LimitedWriteStream on: (self new: (100 min: sizeLimit)).
	stream setLimit: sizeLimit limitBlock: [^ stream contents].
	blockWithArg value: stream.
	^ stream contents
"
String streamContents: [:s | 1000 timesRepeat: [s nextPutAll: 'Junk']] limitedTo: 25
 'JunkJunkJunkJunkJunkJunkJ'
"! !
ClassTestCase subclass: #SequenceableCollectionTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Sequenceable'!

!SequenceableCollectionTest methodsFor: 'testing - testing' stamp: 'sd 6/5/2005 09:21'!
testAfterIfAbsent

	| col |
	col := #(2 3 4).
	self assert: ((col after: 4 ifAbsent: ['block']) = 'block').
	self assert: ((col after: 5 ifAbsent: ['block']) = 'block').
	self assert: ((col after: 2 ifAbsent: ['block']) = 3).! !

!SequenceableCollectionTest methodsFor: 'testing - testing' stamp: 'sd 6/5/2005 09:22'!
testBeforeIfAbsent

	| col |
	col := #(2 3 4).	
	self assert: ((col before: 2 ifAbsent: ['block']) = 'block').
	self assert: ((col before: 5 ifAbsent: ['block']) = 'block').
	self assert: ((col before: 3 ifAbsent: ['block']) = 2).! !

!SequenceableCollectionTest methodsFor: 'testing - testing' stamp: 'sd 6/5/2005 09:22'!
testBeginsWith
	"We can't test SequenceableCollection directly. However, we can test a sampling of its descendants."

	| la prefix oc |
	la := #(1 2 3 4 5 6).
	oc := OrderedCollection new.
	oc add: 1; add: 2; add: 3.

	self assert: (la beginsWith: #(1)).
	self assert: (la beginsWith: #(1 2)).
	self assert: (la beginsWith: #(1 2 3)).
	self assert: (la beginsWith: oc).
	self deny: (la beginsWith: #()).
	self deny: (la beginsWith: '').
	self deny: (la beginsWith: OrderedCollection new).
	
	self assert: (oc beginsWith: #(1 2)).
	
	prefix := OrderedCollection new.
	self deny: (oc beginsWith: prefix).
	prefix add: 1.
	self assert: (oc beginsWith: prefix).
	prefix add: 2.
	self assert: (oc beginsWith: prefix).
	prefix add: 3.
	self assert: (oc beginsWith: prefix).
	prefix add: 4.
	self deny: (oc beginsWith: prefix).! !

!SequenceableCollectionTest methodsFor: 'testing - testing' stamp: 'sd 6/5/2005 09:22'!
testEndsWith
	"We can't test SequenceableCollection directly. However, we can test a sampling of its descendants."

	| la oc suffix |
	la := #(1 2 3 4 5 6).
	oc := OrderedCollection new.
	oc add: 4; add: 5; add: 6.
	
	self assert: (la endsWith: #(6)).
	self assert: (la endsWith: #(5 6)).
	self assert: (la endsWith: #(4 5 6)).
	self assert: (la endsWith: oc).
	self deny: (la endsWith: #()).
	self deny: (la endsWith: '').
	
	suffix := OrderedCollection new.
	suffix add: 6.
	self assert: (oc endsWith: suffix).
	suffix addFirst: 5.
	self assert: (oc endsWith: suffix).
	suffix addFirst: 4.
	self assert: (oc endsWith: suffix).
	suffix addFirst: 3.
	self deny: (oc endsWith: suffix).! !
AbstractSound subclass: #SequentialSound
	instanceVariableNames: 'sounds currentIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!SequentialSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
duration
	"Answer the duration of this sound in seconds."

	"7 dec 2000 - handle compressed sounds. better way??"

	| dur |
	dur := 0.
	sounds do: [:snd | dur := dur + snd asSound duration].
	^ dur
! !

!SequentialSound methodsFor: 'accessing' stamp: 'jm 2/4/98 13:36'!
sounds

	^ sounds
! !


!SequentialSound methodsFor: 'composition'!
, aSound
	"Return the concatenation of the receiver and the argument sound."

	^ self add: aSound
! !

!SequentialSound methodsFor: 'composition' stamp: 'stephaneducasse 2/4/2006 20:41'!
add: aSound

	sounds := sounds copyWith: aSound.
! !

!SequentialSound methodsFor: 'composition' stamp: 'di 12/7/2000 16:03'!
compressWith: codecClass
	^ self copy transformSounds: [:s | s compressWith: codecClass]! !

!SequentialSound methodsFor: 'composition' stamp: 'RAA 12/24/2000 08:42'!
compressWith: codecClass atRate: aSamplingRate
	^ self copy transformSounds: [:s | s compressWith: codecClass atRate: aSamplingRate]! !

!SequentialSound methodsFor: 'composition' stamp: 'stephaneducasse 2/4/2006 20:41'!
pruneFinishedSounds
	"Remove any sounds that have been completely played."

	| newSnds |
	(currentIndex > 1 and: [currentIndex < sounds size]) ifFalse: [^ self].
	newSnds := sounds copyFrom: currentIndex to: sounds size.
	currentIndex := 1.
	sounds := newSnds.
! !

!SequentialSound methodsFor: 'composition' stamp: 'stephaneducasse 2/4/2006 20:41'!
removeFirstCompleteSoundOrNil
	"Remove the first sound if it has been completely recorded."

	| firstSound |

	sounds size > 0 ifFalse: [^ nil].
	firstSound := sounds first.
	sounds := sounds copyFrom: 2 to: sounds size.
	^firstSound
! !


!SequentialSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:10'!
copy
	"Copy my component sounds."

	^ super copy copySounds
! !

!SequentialSound methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:41'!
copySounds
	"Private!! Support for copying. Copy my component sounds."

	sounds := sounds collect: [:s | s copy].
! !

!SequentialSound methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:41'!
transformSounds: tfmBlock
	"Private!! Support for copying. Copy my component sounds."

	sounds := sounds collect: [:s | tfmBlock value: s].
! !


!SequentialSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	super initialize.
	sounds := Array new.
	currentIndex := 0.
! !


!SequentialSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:41'!
doControl

	super doControl.
	currentIndex > 0
		ifTrue: [(sounds at: currentIndex) doControl].
! !

!SequentialSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a collection of sounds in sequence."
	"PluckedSound chromaticScale play"

	| finalIndex i snd remaining count |
	currentIndex = 0 ifTrue: [^ self].  "already done"
	finalIndex := (startIndex + n) - 1.
	i := startIndex.
	[i <= finalIndex] whileTrue: [
		snd := (sounds at: currentIndex).
		[(remaining := snd samplesRemaining) <= 0] whileTrue: [
			"find next undone sound"
			currentIndex < sounds size
				ifTrue: [
					currentIndex := currentIndex + 1.
					snd := (sounds at: currentIndex)]
				ifFalse: [
					currentIndex := 0.
					^ self]].  "no more sounds"
		count := (finalIndex - i) + 1.
		remaining < count ifTrue: [count := remaining].
		snd mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol.
		i := i + count].
! !

!SequentialSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset

	super reset.
	sounds do: [:snd | snd reset].
	sounds size > 0 ifTrue: [currentIndex := 1].
! !

!SequentialSound methodsFor: 'sound generation' stamp: 'jm 12/15/97 22:47'!
samplesRemaining

	currentIndex = 0
		ifTrue: [^ 0]
		ifFalse: [^ 1000000].
! !
Object subclass: #SerialPort
	instanceVariableNames: 'port baudRate stopBitsType parityType dataBits outputFlowControlType inputFlowControlType xOnByte xOffByte'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Serial Port'!
!SerialPort commentStamp: '<historical>' prior: 0!
This class supports a simple interface to the serial ports of the underlying platform, if it supports serial ports. The mapping of port numbers to hardware ports is platform specific, but typically follows platform ordering conventions. For example, on the Macintosh, port 0 is the modem port and port 1 is the printer port, since in the programmers documentation these ports are referred to as ports A and B.
!


!SerialPort methodsFor: 'initialization' stamp: 'jm 5/5/1998 15:49'!
initialize
	"Default port settings."

	port _ nil.					"set when opened"
	baudRate _ 9600.			"9600 baud"
	stopBitsType _ 1.				"one stop bit"
	parityType _ 0.				"no parity"
	dataBits _ 8.					"8 bits"
	outputFlowControlType _ 0.	"none"
	inputFlowControlType _ 0.	"none"
	xOnByte _ 19.				"ctrl-S"
	xOffByte _ 24.				"ctrl-X"
! !


!SerialPort methodsFor: 'input/output' stamp: 'yo 2/2/2001 15:13'!
nextPutAll: aStringOrByteArray
	"Send the given bytes out this serial port. The port must be open."

	^ self primWritePort: port
		from: aStringOrByteArray
		startingAt: 1
		count: aStringOrByteArray size.
! !

!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:44'!
readByteArray
	"Answer a ByteArray read from this serial port. Answer an empty ByteArray if no data is available. The port must be open."

	| buf count |
	buf _ ByteArray new: 1000.
	count _ self primReadPort: port into: buf startingAt: 1 count: buf size.
	^ buf copyFrom: 1 to: count
! !

!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:46'!
readInto: aStringOrByteArray startingAt: index
	"Read data into the given String or ByteArray object starting at the given index, and answer the number of bytes read. Does not go past the end of the given String or ByteArray."

	^ self primReadPort: port
		into: aStringOrByteArray
		startingAt: index
		count: (aStringOrByteArray size - index) + 1.
! !

!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:43'!
readString
	"Answer a String read from this serial port. Answer the empty String if no data is available. The port must be open."

	| buf count |
	buf _ String new: 1000.
	count _ self primReadPort: port into: buf startingAt: 1 count: buf size.
	^ buf copyFrom: 1 to: count
! !


!SerialPort methodsFor: 'open/close' stamp: 'jm 5/18/1998 15:40'!
close
	"Close the serial port. Do nothing if the port is not open."

	port ifNotNil: [self primClosePort: port].
	port _ nil.
! !

!SerialPort methodsFor: 'open/close' stamp: 'dns 6/27/2000 19:49'!
openPort: portNumber
	"Open the given serial port, using the settings specified by my instance variables. If the port cannot be opened, such as when it is alreay in use, answer nil."  "(DNS)"

	self close.
	(self primClosePort: portNumber) isNil ifTrue: [
		^ nil ].
	(self primOpenPort: portNumber
		baudRate: baudRate
		stopBitsType: stopBitsType
		parityType: parityType
		dataBits: dataBits
		inFlowControlType: inputFlowControlType
		outFlowControlType: outputFlowControlType
		xOnByte: xOnByte
		xOffByte: xOffByte) isNil ifTrue: [
			^ nil ].
	port _ portNumber
! !


!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primClosePort: portNumber

	<primitive: 'primitiveSerialPortClose' module: 'SerialPlugin'>
	^ nil  "(DNS)"
	"self primitiveFailed."
! !

!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primOpenPort: portNumber baudRate: baud stopBitsType: stop
	parityType: parity dataBits: numDataBits
	inFlowControlType: inFlowCtrl outFlowControlType: outFlowCtrl
	xOnByte: xOn xOffByte: xOff

	<primitive: 'primitiveSerialPortOpen' module: 'SerialPlugin'>
	^ nil  "(DNS)"
! !

!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primReadPort: portNumber into: byteArray startingAt: startIndex count: count

	<primitive: 'primitiveSerialPortRead' module: 'SerialPlugin'>
	self primitiveFailed.
! !

!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primWritePort: portNumber from: byteArray startingAt: startIndex count: count

	<primitive: 'primitiveSerialPortWrite' module: 'SerialPlugin'>
	self primitiveFailed.
! !


!SerialPort methodsFor: 'printing' stamp: 'jm 5/1/1998 18:02'!
printOn: aStream

	aStream
		nextPutAll: 'SerialPort(';
		nextPutAll:
			(port ifNil: ['closed'] ifNotNil: ['#', port printString]);
		nextPutAll: ', ';
		print: baudRate; nextPutAll: ' baud, ';
		print: dataBits; nextPutAll: ' bits, ';
		nextPutAll: (#('1.5' '1' '2') at: stopBitsType + 1); nextPutAll: ' stopbits, ';
		nextPutAll: (#('no' 'odd' 'even') at: parityType + 1); nextPutAll: ' parity)'.
! !


!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
baudRate

	^ baudRate
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'!
baudRate: anInteger
	"Set the baud rate for this serial port."

	baudRate _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
dataBits

	^ dataBits
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'!
dataBits: anInteger
	"Set the number of data bits for this serial port to 5, 6, 7, or 8."

	dataBits _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:21'!
inputFlowControlType

	^ inputFlowControlType
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:38'!
inputFlowControlType: anInteger
	"Set the type of input flow control, where:
		0 - none
		1 - XOn/XOff
		2 - hardware handshaking"

	inputFlowControlType _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
outputFlowControlType

	^ outputFlowControlType
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:38'!
outputFlowControlType: anInteger
	"Set the type of output flow control, where:
		0 - none
		1 - XOn/XOff
		2 - hardware handshaking"

	outputFlowControlType _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
parityType

	^ parityType
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'!
parityType: anInteger
	"Set the parity type for this serial port, where:
		0 - no parity
		1 - odd parity
		2 - even parity"

	parityType _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
stopBitsType

	^ stopBitsType
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 18:02'!
stopBitsType: anInteger
	"Set the stop bits type for this serial port, where:
		0 - 1.5 stop bits
		1 - one stop bit
		2 - two stop bits"

	stopBitsType _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:20'!
xOffByte

	^ xOffByte
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:28'!
xOffByte: anInteger
	"Set the value of the XOff byte to be used if XOn/XOff flow control is enabled."

	xOffByte _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:20'!
xOnByte

	^ xOnByte
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:28'!
xOnByte: anInteger
	"Set the value of the XOn byte to be used if XOn/XOff flow control is enabled."

	xOnByte _ anInteger.
! !
Object subclass: #ServerDirectory
	instanceVariableNames: 'server directory type user passwordHolder group moniker altURL urlObject client loaderUrl eToyUserListUrl eToyUserList keepAlive encodingName'
	classVariableNames: 'LocalEToyBaseFolderSpecs LocalEToyUserListUrls LocalProjectDirectories Servers'
	poolDictionaries: ''
	category: 'Network-RemoteDirectory'!
!ServerDirectory commentStamp: '<historical>' prior: 0!
Holds all the information needed to read or write on a directory of an internet server.  I am used for FTP and HTTP (and STMP?  NNTP?).  The password policy is: unless it is a public password (like annomyous), clear all passwords before any snapshot.  There is a way to store passwords on the disk.

server 		'www.disney.com'  or '123.34.56.08' or the ServerDirectory above me 
			(if I am a subdirectory sharing the info in a master directory)
directory 	'ftp/pubs/'  name of my directory within the server or superdirectory.
			(for file://, directory is converted to local delimiters.)
type 		#ftp	what you can do in this directory
user 		'Jones45'
password 	an instance of Password.  
group 		an Association ('group name' -> an array of ServerDirectorys)
			If this first one is down, try the next one.  Store on all of them.  I am in the list.
moniker 	'Main Squeak Directory'  Description of this directory.
altURL		When a FTP server holds some web pages, the altURL of those pages is often
			different from the FTP directory.  Put the altURL here.  If the directory is 
			'public_html/Squeak/', the altURL might be 'www.webPage.com/~kaehler2/
			Squeak/'.
urlObject	An instance of a subclass of Url.  It is very good at parsing complex urls.
			Relative references.  file:// uses this.  Use this in the future instead of 
			server and directory inst vars.
socket		nil or an FTPSocket.  Only non-nil if the connection is being kept open
			for multiple stores or retrievals.  
loaderUrl	a partial url that is ised to invoke squeak in a browser and load a project.

A normal call on some command like (aServer getFileNamed: 'foo') does not set 'socket'.  Socket being nil tells it to close the connection and destroy the socket after this one transcation.  If the caller stores into 'socket', then the same command does NOT close the 
connection.  
	Call 'openKeepFTP' or 'openGroup' to store into socket and keep the connection open.  It is up to the user to call 'quit' or 'closeGroup' later.

DD openKeepFTP.
Transcript cr; show: ((DD getFileNamed: '1198misc-tkKG.cs') next: 100).
Transcript cr; show: ((DD getFileNamed: '1192multFinder-tkKF.cs') next: 100).
DD quit.!


!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 12:43'!
acceptsUploads: aBoolean
	"Do nothing yet"! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/14/1999 21:01'!
altUrl
	"When a ftp server also has http access, use this to store the http url"
	^ altURL! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/14/1999 20:56'!
altUrl: aString
	altURL _ aString! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/18/1998 23:24'!
bareDirectory

	^ directory first == $/ 
		ifTrue: [directory copyFrom: 2 to: directory size]
		ifFalse: [directory]! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/19/1998 18:54'!
copy

	| new |
	new _ self clone.
	new urlObject: urlObject copy.
	^ new! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 15:00'!
directory
	"String of part of url that is the directory. Has slashes as separators"

	urlObject ifNotNil: [^ urlObject pathDirString].
	^ directory! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'!
directory: anObject
	directory _ anObject! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 10/17/2000 14:57'!
directoryObject

	^self! !

!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 10:45'!
downloadUrl
	"The url under which files will be accessible."
	^(self altUrl
		ifNil: [self realUrl]
		ifNotNil: [self altUrl]) , '/'! !

!ServerDirectory methodsFor: 'accessing' stamp: 'KR 2/1/2006 12:46'!
encodingName
	^encodingName.! !

!ServerDirectory methodsFor: 'accessing' stamp: 'KR 1/30/2006 22:15'!
encodingName: aName
	encodingName _ aName! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:26'!
fullPath: serverAndDirectory
	"Parse and save a full path.  Convention:  if ftp://user@server/dir, then dir is relative to user's directory.  dir has no slash at beginning.  If ftp://server/dir, then dir is absolute to top of machine, give dir a slash at the beginning."

	| start bare sz userAndServer both slash score match best sd |
	bare _ serverAndDirectory.
	sz _ serverAndDirectory size.
	bare size > 0 ifTrue: [ 
		start _ (bare copyFrom: 1 to: (8 min: sz)) asLowercase.
		((start beginsWith: 'ftp:') or: [start beginsWith: 'nil:']) "fix bad urls"
			ifTrue: [type _ #ftp.
				bare _ bare copyFrom: (7 min: sz) to: bare size].
		(start beginsWith: 'http:') 
			ifTrue: [type _ #http.
				bare _ bare copyFrom: (8 min: sz) to: serverAndDirectory size].
		((start beginsWith: 'file:') or: [type == #file])
			ifTrue: [type _ #file.
				urlObject _ FileUrl absoluteFromText: serverAndDirectory.
				^ self]].
	userAndServer _ bare copyUpTo: self pathNameDelimiter.
	both _ userAndServer findTokens: '@'.
	slash _ both size.	"absolute = 1, relative = 2"
	server _ both last.
	both size > 1 ifTrue: [user _ both at: 1].
	bare size > (userAndServer size + 1) 
		ifTrue: [directory _ bare copyFrom: userAndServer size + slash to: bare size]
		ifFalse: [directory _ ''].

	"If this server is already known, copy in its userName and password"
	type == #ftp ifFalse: [^ self].
	score _ -1.
	ServerDirectory serverNames do: [:name |
		sd _ ServerDirectory serverNamed: name.
		server = sd server ifTrue: [
			match _ directory asLowercase charactersExactlyMatching: sd directory asLowercase.
			match > score ifTrue: [score _ match.  best _ sd]]].
	best ifNil: [
		self fromUser
	] ifNotNil: [
		user _ best user.
		altURL _ best altUrl.
		loaderUrl _ best loaderUrl.
		self password: best password
	].
! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:40'!
isTypeFTP

	^self typeWithDefault == #ftp! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:41'!
isTypeFile

	^self typeWithDefault == #file! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:46'!
isTypeHTTP

	^self typeWithDefault == #http! !

!ServerDirectory methodsFor: 'accessing' stamp: 'mir 12/8/2003 14:18'!
keepAlive: aBoolean
	keepAlive := aBoolean! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:22'!
loaderUrl

	^loaderUrl! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:24'!
loaderUrl: aString

	loaderUrl _ aString! !

!ServerDirectory methodsFor: 'accessing' stamp: 'fbs 2/2/2005 13:24'!
moniker
	"a plain language name for this directory"

	moniker ifNotNil: [^ moniker].
	directory ifNotNil: [^ self server].
	urlObject ifNotNil: [^ urlObject asString].
	^ ''! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 5/20/1998 12:26'!
moniker: nickName
	"a plain language name for this directory"

	moniker _ nickName! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 2/14/1999 20:44'!
password

	passwordHolder ifNil: [passwordHolder _ Password new].
	^ passwordHolder passwordFor: self	"may ask the user"! !

!ServerDirectory methodsFor: 'accessing' stamp: 'ar 4/10/2005 18:52'!
password: pp

	passwordHolder _ Password new.
	pp isString 
		ifTrue: [passwordHolder cache: pp. ^ self].
	pp isInteger 
		ifTrue: [passwordHolder sequence: pp]
		ifFalse: [passwordHolder _ pp].! !

!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:04'!
passwordSequence

	^passwordHolder
		ifNotNil: [passwordHolder sequence]! !

!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:16'!
passwordSequence: aNumber

	passwordHolder ifNil: [passwordHolder _ Password new].
	passwordHolder sequence: aNumber! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 5/23/1998 09:41'!
printOn: aStrm
	aStrm nextPutAll: self class name; nextPut: $<.
	aStrm nextPutAll: self moniker.
	aStrm nextPut: $>.
! !

!ServerDirectory methodsFor: 'accessing' stamp: 'fbs 2/2/2005 13:24'!
realUrl
	"a fully expanded version of the url we represent.  Prefix the path with http: or ftp: or file:"

	self isTypeFile ifTrue: [
		self fileNameRelativeTo: self.
		^ urlObject asString
	].
	^ self typeWithDefault asString, '://', self pathName
	! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 18:18'!
server
	^ server! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'!
server: anObject
	server _ anObject! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/18/1998 23:22'!
slashDirectory

	^ directory first == $/ 
		ifTrue: [directory]
		ifFalse: ['/', directory]! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 2/14/1999 21:44'!
type: aSymbol
	type _ aSymbol! !

!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 17:16'!
typeForPrefs

	^self typeWithDefault! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:30'!
typeWithDefault

	^ type ifNil: [type _ #ftp]! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/5/1998 17:20'!
url: aString
	altURL _ aString! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/6/1998 00:44'!
urlObject
	^ urlObject! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/8/1998 11:56'!
urlObject: aUrl

	urlObject _ aUrl! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 22:16'!
user
	^ user! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'!
user: anObject
	user _ anObject! !


!ServerDirectory methodsFor: 'dis/connect' stamp: 'rbb 2/18/2005 14:41'!
openFTPClient

	| loginSuccessful what |
	client
		ifNotNil: [client isConnected
			ifTrue: [^client]
			ifFalse: [client := nil]].
	client _ FTPClient openOnHostNamed: server.
	loginSuccessful := false.
	[loginSuccessful]
		whileFalse: [
			[loginSuccessful := true.
			client loginUser: self user password: self password]
				on: LoginFailedException
				do: [:ex | 
					passwordHolder _ nil.
					what _ UIManager default 
						chooseFrom: #('enter password' 'give up') 
						title: 'Would you like to try another password?'.
					what = 1 ifFalse: [self error: 'Login failed.'. ^nil].
					loginSuccessful := false]].
	client changeDirectoryTo: directory.
	^client! !

!ServerDirectory methodsFor: 'dis/connect' stamp: 'mir 12/8/2003 12:53'!
quit
	"break the connection"

	self keepAlive
		ifFalse: [self quitClient]! !

!ServerDirectory methodsFor: 'dis/connect' stamp: 'mir 12/8/2003 12:53'!
quitClient
	"break the connection"

	client ifNotNil: [client quit].
	client := nil! !


!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:08'!
asServerFileNamed: aName

	| rFile |
	rFile _ self as: ServerFile.
	(aName includes: self pathNameDelimiter)
		ifTrue: [rFile fullPath: aName]
			"sets server, directory(path), fileName.  If relative, merge with self."
		ifFalse: [rFile fileName: aName].	"JUST a single NAME, already have the rest"
			"Mac files that include / in name, must encode it as %2F "
	^rFile
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tpr 4/28/2004 17:32'!
assureExistence
	"Make sure the current directory exists. If necessary, create all parts inbetween"
	
	self exists ifFalse: [
		self isRoot ifFalse: [
			self containingDirectory assureExistenceOfPath: self localName]]! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tpr 4/28/2004 17:31'!
assureExistenceOfPath: localPath
	"Make sure the local directory exists. If necessary, create all parts inbetween"

	localPath = (String with: self pathNameDelimiter) ifTrue: [^self].
	self assureExistence.
	(self localPathExists: localPath) ifFalse: [
		self createDirectory: localPath].! !

!ServerDirectory methodsFor: 'file directory' stamp: 'hg 9/29/2001 15:23'!
containingDirectory

	self splitName: directory to: [:parentPath :localName |
		^self copy directory: parentPath]! !

!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:16'!
createDirectory: localName
	"Create a new sub directory within the current one"

	self isTypeFile ifTrue: [
		^FileDirectory createDirectory: localName
	].

	client := self openFTPClient.
	[client makeDirectory: localName]
		ensure: [self quit].
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'!
deleteDirectory: localName
	"Delete the sub directory within the current one.  Call needs to ask user to confirm."

	self isTypeFile ifTrue: [
		^FileDirectory deleteFileNamed: localName
	].
		"Is this the right command???"

	client := self openFTPClient.
	[client deleteDirectory: localName]
		ensure: [self quit].
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'!
deleteFileNamed: fullName
	"Detete a remote file.  fullName is directory path, and does include name of the server.  Or it can just be a fileName."
	| file |
	file _ self asServerFileNamed: fullName.
	file isTypeFile ifTrue: [
		^ (FileDirectory forFileName: (file fileNameRelativeTo: self)) 
			deleteFileNamed: file fileName
	].
	
	client := self openFTPClient.
	[client deleteFileNamed: fullName]
		ensure: [self quit].
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'hg 2/8/2002 17:44'!
directoryNamed: localFileName 
	"Return a copy of me pointing at this directory below me"
	| new newPath newAltUrl |
	new _ self copy.
	urlObject
		ifNotNil: [new urlObject path: new urlObject path copy.
			new urlObject path removeLast; addLast: localFileName; addLast: ''.
			^ new].
	"sbw.  When working from an FTP server, the first time we access
	a subdirectory the <directory> variable is empty.  In that case we
	cannot begin with a leading path delimiter since that leads us to
	the wrong place."
	newPath _ directory isEmpty
				ifTrue: [localFileName]
				ifFalse: [directory , self pathNameDelimiter asString , localFileName].
	self altUrl ifNotNil: [
		newAltUrl _ self altUrl, self pathNameDelimiter asString , localFileName].
	new directory: newPath; altUrl: newAltUrl.
	^ new! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 2/22/2000 19:51'!
directoryNames
	"Return a collection of names for the subdirectories of this directory."
	"(ServerDirectory serverNamed: 'UIUCArchive') directoryNames"

	^ (self entries select: [:entry | entry at: 4])
		collect: [:entry | entry first]
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'mir 5/13/2003 10:44'!
entries 
	"Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: (<name> <creationTime> <modificationTime> <dirFlag> <fileSize>)."
	| dir ftpEntries |
	"We start with ftp directory entries of the form...
d---------   1 owner    group               0 Apr 27 22:01 blasttest
----------   1 owner    group           93812 Jul 21  1997 COMMAND.COM
    1        2   3           4                 5    6  7    8       9   -- token index"
	self isTypeFile ifTrue: [
		urlObject isAbsolute ifFalse: [urlObject default].
		^ (FileDirectory on: urlObject pathForDirectory) entries
	].

	dir _ self getDirectory.
	(dir respondsTo: #contentsOfEntireFile) ifFalse: [^ #()].
	ftpEntries _ dir contentsOfEntireFile findTokens: String crlf.
"ftpEntries inspect."
	^ ftpEntries 
		collect:[:ftpEntry | self class parseFTPEntry: ftpEntry]
		thenSelect: [:entry | entry notNil]! !

!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'!
exists
	"It is difficult to tell if a directory exists.  This is ugly, but it works for writable directories.  http: will fall back on ftp for this"

	| probe success |
	success _ false.
	self isTypeFile ifTrue: [
		self entries size > 0 ifTrue: [^ true].
		probe _ self newFileNamed: 'withNoName23'. 
		probe ifNotNil: [
			probe close.
			probe directory deleteFileNamed: probe localName].
		^success _ probe notNil].
	[client := self openFTPClient.
	[client pwd]
		ensure: [self quit].
		success := true]
		on: Error
		do: [:ex | ].
	^success! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 11/20/1998 12:28'!
fileAndDirectoryNames
	"FileDirectory default fileAndDirectoryNames"

	^ self entries collect: [:entry | entry first]
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:31'!
fileNamed: fullName
	"Create a RemoteFileStream for writing.  If the file exists, do not complain.  fullName is directory path, and does include name of the server.  Or it can just be a fileName.  Only write the data upon close."

	| file remoteStrm |
	file _ self asServerFileNamed: fullName.
	file readWrite.
	file isTypeFile ifTrue: [
		^ FileStream fileNamed: (file fileNameRelativeTo: self)
	].

	remoteStrm _ RemoteFileStream on: (String new: 2000).
	remoteStrm remoteFile: file.
	^ remoteStrm	"no actual writing till close"
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'hg 2/8/2002 00:04'!
fileNames
	"Return a collection of names for the files (but not directories) in this directory."
	"(ServerDirectory serverNamed: 'UIUCArchive') fileNames"

	^ self entries select: [:entry | (entry at: 4) not]
		thenCollect: [:entry | entry first]
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'hg 2/8/2002 17:39'!
fullNameFor: aFileName
	"Convention: 
	If it is an absolute path, directory stored with a leading slash, and url has no user@.
	If relative path, directory stored with no leading slash, and url begins user@.
	Should we include ftp:// on the front?"

	urlObject ifNotNil: [^ urlObject pathString, aFileName].
	(aFileName includes: self pathNameDelimiter)
		ifTrue: [^ aFileName].
	self isTypeHTTP ifTrue: [
		^ self downloadUrl, aFileName].
	directory isEmpty ifTrue: [^ server, 
		self pathNameDelimiter asString, aFileName].
	^ (directory first == $/ ifTrue: [''] ifFalse: [user,'@']), 
		server, self slashDirectory, 
		self pathNameDelimiter asString, aFileName! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:47'!
getOnly: nnn from: fileNameOnServer
	| file ff resp |
	"Use FTP to just capture the first nnn characters of the file.  Break the connection after that.  Goes faster for long files.  Return the contents, not a stream."

	self isTypeFile ifTrue: [
		file _ self as: ServerFile.
		file fileName: fileNameOnServer.
		ff _ FileStream oldFileOrNoneNamed: (file fileNameRelativeTo: self).
		^ ff next: nnn].
	self isTypeHTTP ifTrue: [
		resp _ HTTPSocket httpGet: (self fullNameFor: fileNameOnServer) 
				accept: 'application/octet-stream'.
			"For now, get the whole file.  This branch not used often."
		^ resp truncateTo: nnn].
	
	^ self getOnlyBuffer: (String new: nnn) from: fileNameOnServer! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 11/20/1998 12:28'!
includesKey: localName
	"Answer true if this directory includes a file or directory of the given name. Note that the name should be a local file name, in contrast with fileExists:, which takes either local or full-qualified file names."

	^ self fileAndDirectoryNames includes: localName
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'hg 9/29/2001 15:35'!
localName

	directory isEmpty ifTrue: [self error: 'no directory'].
	^self localNameFor: directory! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:46'!
localNameFor: fullName
	"Return the local part the given name."

	self
		splitName: fullName
		to: [:dirPath :localName | ^ localName]
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'hg 9/29/2001 14:57'!
localPathExists: localPath

	^self directoryNames includes: localPath! !

!ServerDirectory methodsFor: 'file directory' stamp: 'mir 8/24/2001 12:01'!
matchingEntries: criteria
	"Ignore the filter criteria for now"
	^self entries! !

!ServerDirectory methodsFor: 'file directory' stamp: 'rbb 3/1/2005 11:12'!
newFileNamed: fullName
	"Create a RemoteFileStream.  If the file exists, and complain.  fullName is directory path, and does include name of the server.  Or it can just be a fileName.  Only write the data upon close."

	| file remoteStrm selection |

	file := self asServerFileNamed: fullName.
	file readWrite.
	file isTypeFile ifTrue: [
		^ FileStream newFileNamed: (file fileNameRelativeTo: self)].
	file exists 
		ifTrue: [
			selection := UIManager default 
				chooseFrom: #('overwrite that file' 'choose another name' 'cancel')
				title: (file fullNameFor: file fileName) , '
already exists.']
		ifFalse: [selection := 1].

	selection = 1 ifTrue:
		[remoteStrm := RemoteFileStream on: (String new: 2000).
		remoteStrm remoteFile: file.
		remoteStrm dataIsValid.	"empty stream is the real contents!!"
		^ remoteStrm].	"no actual writing till close"
	selection = 2 ifTrue: [
		^ self newFileNamed:
			(UIManager default request: 'Enter a new file name'
				initialAnswer: file fileName)].
	^ nil	"cancel"! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:10'!
oldFileNamed: aName
	"If the file exists, answer a read-only RemoteFileStream on it.  aName is directory path, and does include name of the server.  Or it can just be a fileName.  For now, pre-read the file."

	| rFile |

	rFile _ self asServerFileNamed: aName.
	rFile readOnly.
	rFile isTypeFile ifTrue: [
		^ FileStream oldFileNamed: (rFile fileNameRelativeTo: self)].

	^self streamOnBeginningOf: rFile
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'di 3/9/2001 01:25'!
oldFileOrNoneNamed: fullName
	"If the file exists, answer a read-only RemoteFileStream on it. If it doesn't, answer nil.  fullName is directory path, and does include name of the server.  Or just a simple fileName.  Do prefetch the data."
 
	| file |
	^ Cursor wait showWhile:
		[file _ self asServerFileNamed: fullName.
		file readOnly.
		"file exists ifFalse: [^ nil]."		"on the server"
		file isTypeFile
			ifTrue: [FileStream oldFileOrNoneNamed: (file fileNameRelativeTo: self)]
			ifFalse: [self streamOnBeginningOf: file]]! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/19/1998 18:59'!
on: fullName
	"Answer another ServerDirectory on the partial path name.  fullName is directory path, and does include the name of the server."

	| new |
	new _ self copy.
	new fullPath: fullName.		"sets server, directory(path)"
	^ new! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 1/14/1999 20:54'!
pathName
	"Path name as used in reading the file.  with slashes for ftp, with local file delimiter (:) for a file: url"

	urlObject ifNotNil: [^ urlObject pathForFile].
	directory size = 0 ifTrue: [^ server].
	^ (directory at: 1) = self pathNameDelimiter
		ifTrue: [server, directory]
		ifFalse: [user, '@', server, self pathNameDelimiter asString, directory]! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/3/1998 12:34'!
pathNameDelimiter
	"the separator that is used in URLs"

	^ $/! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/8/1998 12:12'!
pathParts
	"Return the path from the root of the file system to this directory as an array of directory names.  On a remote server."

	urlObject ifNotNil: [^ (urlObject path copy) removeLast; yourself].
	^ (OrderedCollection with: server) addAll: 
		(directory findTokens: self pathNameDelimiter asString);
			yourself.
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:08'!
readOnlyFileNamed: aName
	"If the file exists, answer a read-only RemoteFileStream on it.  aName is directory path, and does include name of the server.  Or it can just be a fileName.  For now, pre-read the file."

	| rFile |

	rFile _ self asServerFileNamed: aName.
	rFile readOnly.
	rFile isTypeFile ifTrue: [
		^ FileStream oldFileNamed: (rFile fileNameRelativeTo: self)].

	^self streamOnBeginningOf: rFile! !

!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'!
rename: fullName toBe: newName
	"Rename a remote file.  fullName is just be a fileName, or can be directory path that includes name of the server.  newName is just a fileName"
	| file |

	file _ self asServerFileNamed: fullName.
	file isTypeFile ifTrue: [
		(FileDirectory forFileName: (file fileNameRelativeTo: self)) 
			rename: file fileName toBe: newName
	].
	
	client := self openFTPClient.
	[client renameFileNamed: fullName to: newName]
		ensure: [self quit].
	! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:45'!
serverDelimiter
	"the separator that is used in the place where the file actually is.  ftp server or local disk."

	^ self isTypeFile 
		ifTrue: [FileDirectory default pathNameDelimiter]
		ifFalse: [$/]	"for ftp, http"! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:46'!
splitName: fullName to: pathAndNameBlock
	"Take the file name and convert it to the path name of a directory and a local file name within that directory. FileName must be of the form: <dirPath><delimiter><localName>, where <dirPath><delimiter> is optional. The <dirPath> part may contain delimiters."

	| delimiter i dirName localName |
	delimiter _ self pathNameDelimiter.
	(i _ fullName findLast: [:c | c = delimiter]) = 0
		ifTrue:
			[dirName _ String new.
			localName _ fullName]
		ifFalse:
			[dirName _ fullName copyFrom: 1 to: (i - 1 max: 1).
			localName _ fullName copyFrom: i + 1 to: fullName size].

	^ pathAndNameBlock value: dirName value: localName! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:03'!
streamOnBeginningOf: serverFile

	| remoteStrm |
	remoteStrm _ RemoteFileStream on: (String new: 2000).
	remoteStrm remoteFile: serverFile.
	serverFile getFileNamed: serverFile fileName into: remoteStrm.	"prefetch data"
	^ remoteStrm! !


!ServerDirectory methodsFor: 'file-in/out' stamp: 'KR 2/1/2006 12:40'!
storeServerEntryOn: stream
	
	stream
		nextPutAll: 'name:'; tab; nextPutAll: (ServerDirectory nameForServer: self); cr;
		nextPutAll: 'directory:'; tab; nextPutAll: self directory; cr;
		nextPutAll: 'type:'; tab; nextPutAll: self typeForPrefs; cr;
		nextPutAll: 'server:'; tab; nextPutAll: self server; cr.
	group
		ifNotNil: [stream nextPutAll: 'group:'; tab; nextPutAll: self groupName; cr].
	self user
		ifNotNil: [stream nextPutAll: 'user:'; tab; nextPutAll: self user; cr].
	self passwordSequence
		ifNotNil: [stream nextPutAll: 'passwdseq:'; tab; nextPutAll: self passwordSequence asString; cr].
	self altUrl
		ifNotNil: [stream nextPutAll: 'url:'; tab; nextPutAll: self altUrl; cr].
	self loaderUrl
		ifNotNil: [stream nextPutAll: 'loaderUrl:'; tab; nextPutAll: self loaderUrl; cr].
	self acceptsUploads
		ifTrue: [stream nextPutAll: 'acceptsUploads:'; tab; nextPutAll: 'true'; cr].
	self encodingName
		ifNotNil: [stream nextPutAll: 'encodingName:'; tab; nextPutAll: self encodingName; cr].! !


!ServerDirectory methodsFor: 'initialize' stamp: 'tk 11/26/1998 09:50'!
fromUser
	"Ask the user for all data on a new server.  Save it in a named server."  ! !


!ServerDirectory methodsFor: 'multi-action sessions' stamp: 'mir 11/19/2002 17:51'!
reset
	! !

!ServerDirectory methodsFor: 'multi-action sessions' stamp: 'mir 12/8/2003 12:54'!
sleep
	"If still connected, break the connection"

	self quitClient.
	self keepAlive: false! !

!ServerDirectory methodsFor: 'multi-action sessions' stamp: 'mir 12/8/2003 12:55'!
wakeUp
	"Start a multi-action session: Open for FTP and keep the connection open"

	self isTypeFTP
		ifTrue: [client := self openFTPClient].
	self keepAlive: true
! !


!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 11:56'!
closeGroup
	"Close connection with all servers in the group."

	self serversInGroup do: [:aDir | aDir quit].
! !

!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:25'!
convertGroupName
	group
		ifNotNil: [self groupName: self groupName]! !

!ServerDirectory methodsFor: 'server groups' stamp: 'nk 8/30/2004 08:00'!
groupName

	^group
		ifNil: [self moniker]
		ifNotNil: [
			(group isString)
				ifTrue: [group]
				ifFalse: [group key]]! !

!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:13'!
groupName: groupName
	group _ groupName! !

!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 11:57'!
openGroup
	"Open all servers in the group.  Don't forget to close later."

	self serversInGroup do: [:aDir | aDir wakeUp].
! !

!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 11:56'!
serversInGroup
	^self groupName
		ifNil: [Array with: self]
		ifNotNil: [self class serversInGroupNamed: self groupName]! !


!ServerDirectory methodsFor: 'squeaklets' stamp: 'RAA 2/2/2001 08:29'!
directoryWrapperClass

	^FileDirectoryWrapper! !

!ServerDirectory methodsFor: 'squeaklets' stamp: 'tk 2/20/2000 18:34'!
moveAllButYoungest: young in: versions to: repository
	| all fName aVers bVers |
	"Specialized to files with names of the form 'aName_vvv.ext'.  Where vvv is a mime-encoded base 64 version number.  Versions is an array of file names tokenized into three parts (aName vvv ext).  Move the files by renaming them on the server."

	versions size <= young ifTrue: [^ self].
	all _ SortedCollection sortBlock: [:aa :bb | 
		aVers _ Base64MimeConverter decodeInteger: aa second unescapePercents.
		bVers _ Base64MimeConverter decodeInteger: bb second unescapePercents.
		aVers < bVers].
	all addAll: versions.
	young timesRepeat: [all removeLast].	"ones we keep"
	all do: [:vv |
		fName _ vv first, '_', vv second, '.', vv third.
		repository rename: self fullName,fName toBe: fName].
! !

!ServerDirectory methodsFor: 'squeaklets' stamp: 'yo 7/2/2004 21:18'!
upLoadProject: projectName members: archiveMembers retry: aBool
	| dir okay m dirName idx |
	m _ archiveMembers detect:[:any| any fileName includes: $/] ifNone:[nil].
	m == nil ifFalse:[
		dirName _ m fileName copyUpTo: $/.
		self createDirectory: dirName.
		dir _ self directoryNamed: dirName].
	archiveMembers do:[:entry|
		ProgressNotification signal: '4:uploadingFile'
			extra: ('(uploading {1}...)' translated format: {entry fileName}).
		idx _ entry fileName indexOf: $/.
		okay _ (idx > 0
			ifTrue:[
				dir putFile: entry contentStream 
					named: (entry fileName copyFrom: idx+1 to: entry fileName size) 
					retry: aBool]
			ifFalse:[
				self putFile: entry contentStream
					named: entry fileName
					retry: aBool]).
		(okay == false
			or: [okay isString])
			ifTrue: [
				self inform: ('Upload for {1} did not succeed ({2}).' translated format: {entry fileName printString. okay}).
				^false].
	].
	ProgressNotification signal: '4:uploadingFile' extra:''.
	^true! !

!ServerDirectory methodsFor: 'squeaklets' stamp: 'ar 3/2/2001 19:08'!
upLoadProject: projectFile named: fileNameOnServer resourceUrl: resUrl retry: aBool
	"Upload the given project file. If it's an archive, upload only the files that are local to the project."
	| archive members upload prefix |
	self isTypeFile ifTrue:[
 		^(FileDirectory on: urlObject pathForDirectory)
			upLoadProject: projectFile named: fileNameOnServer resourceUrl: resUrl retry: aBool].
	projectFile isZipArchive
		ifFalse:[^self putFile: projectFile named: fileNameOnServer retry: aBool].
	projectFile binary.
	archive _ ZipArchive new readFrom: projectFile.
	resUrl last = $/ 
		ifTrue:[prefix _ resUrl copyFrom: 1 to: resUrl size-1] "remove last slash"
		ifFalse:[prefix _ resUrl].
	prefix _ prefix copyFrom: 1 to: (prefix lastIndexOf: $/).
	members _ archive members select:[:entry|
		"figure out where it's coming from"
		upload _ false.
		(entry fileName indexOf: $:) = 0 ifTrue:[
			upload _ true. "one of the core files, e.g., project itself, resource map, meta info"
		] ifFalse:[
			(entry fileName asLowercase beginsWith: resUrl asLowercase) ifTrue:[
				upload _ true.
				entry fileName: (entry fileName copyFrom: prefix size+1 to: entry fileName size).
			].
		].
		upload].
	members _ members asArray sort:[:m1 :m2| m1 compressedSize < m2 compressedSize].
	^self upLoadProject: fileNameOnServer members: members retry: aBool.! !

!ServerDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/12/2000 17:17'!
updateProjectInfoFor: aProject

	"only swiki servers for now"! !

!ServerDirectory methodsFor: 'squeaklets' stamp: 'dgd 12/23/2003 16:21'!
writeProject: aProject inFileNamed: fileNameString fromDirectory: localDirectory 
	"write aProject (a file version can be found in the file named fileNameString in localDirectory)"
	aProject
		writeFileNamed: fileNameString
		fromDirectory: localDirectory
		toServer: self! !


!ServerDirectory methodsFor: 'testing' stamp: 'mir 6/25/2001 12:52'!
acceptsUploads
	^true! !

!ServerDirectory methodsFor: 'testing' stamp: 'mir 4/16/2001 17:41'!
isProjectSwiki
	^false! !

!ServerDirectory methodsFor: 'testing' stamp: 'dgd 12/27/2003 10:47'!
isRemoteDirectory
	"answer whatever the receiver is a remote directory"
	^ true! !

!ServerDirectory methodsFor: 'testing' stamp: 'hg 9/29/2001 15:58'!
isRoot
	^directory = (String with: self pathNameDelimiter)! !

!ServerDirectory methodsFor: 'testing' stamp: 'mir 11/14/2001 16:25'!
isSearchable
	^false! !

!ServerDirectory methodsFor: 'testing' stamp: 'mir 12/8/2003 12:28'!
keepAlive
	keepAlive ifNil: [keepAlive := false].
	^keepAlive! !


!ServerDirectory methodsFor: 'updates' stamp: 'tk 1/7/2001 11:58'!
checkNames: list
	"Look at these names for update and see if they are OK"

list do: [:local |
	(local count: [:char | char == $.]) > 1 ifTrue: [
		self inform: 'File name ',local,'
may not have more than one period'.
	^ false].
	local size > 26 ifTrue: ["allows for 5 digit update numbers"
		self inform: 'File name ',local,'
is too long.  Please rename it.'.
	^ false].
	(local at: 1) isDigit ifTrue: [
		self inform: 'File name ',local,'
may not begin with a number'.
	^ false].
	(local findDelimiters: '%/* ' startingAt: 1) <= local size ifTrue: [
		self inform: 'File name ',local,'
may not contain % / * or space'.
	^ false]].
^ true
! !

!ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:40'!
checkServersWithPrefix: prefix andParseListInto: listBlock
	"Check that all servers are up and have the latest Updates.list.
	Warn user when can't write to a server that can still be read.
	The contents of updates.list is parsed into {{vers. {fileNames*}}*},
	and returned via the listBlock."

	|  serverList updateLists listContents maxSize outOfDateServers |
	serverList _ self serversInGroup.
	serverList isEmpty
		ifTrue: [^Array new].

	updateLists := Dictionary new.
	serverList do: [:updateServer |
		[listContents := updateServer getFileNamed: prefix , 'updates.list'.
		updateLists at: updateServer put: listContents]
			on: Error
			do: [:ex | 
				UIManager default chooseFrom: #('Cancel entire update')
					title: 'Server ', updateServer moniker,
					' is unavailable.\Please consider phoning the administator.\' withCRs, listContents.
				^Array new]].

	maxSize := (updateLists collect: [:each | each size]) max.
	outOfDateServers := updateLists keys select: [:updateServer |
		(updateLists at: updateServer) size < maxSize].

	outOfDateServers do: [:updateServer |
		(self outOfDate: updateServer) ifTrue: [^Array new]].

	listBlock value: (Utilities parseListContents: listContents).

	serverList removeAll: outOfDateServers.
	^serverList

! !

!ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:33'!
copyUpdatesNumbered: selectList toVersion: otherVersion
	"Into the section of updates.list corresponding to otherVersion,
	copy all the fileNames from this version matching the selectList."
"
		(ServerDirectory serverInGroupNamed: 'Disney Internal Updates*')
			copyUpdatesNumbered: #(4411 4412) to version: 'Squeak3.1beta'.
"
	| myServers updateStrm seq indexPrefix listContents version versIndex lastNum otherVersIndex additions outOfOrder |
	self openGroup.
	indexPrefix _ (self groupName includes: $*) 
		ifTrue: [(self groupName findTokens: ' ') first]	"special for internal updates"
		ifFalse: ['']. 	"normal"
	myServers _ self checkServersWithPrefix: indexPrefix
					andParseListInto: [:x | listContents _ x].
	myServers size = 0 ifTrue: [self closeGroup.  ^ self].

	version _ SystemVersion current version.
	versIndex _ (listContents collect: [:pair | pair first]) indexOf: version.
	versIndex = 0 ifTrue:
		[self inform: 'There is no section in updates.list for your version'.
		self closeGroup.  ^ nil].	"abort"
	otherVersIndex _ (listContents collect: [:pair | pair first]) indexOf: otherVersion.
	otherVersIndex = 0 ifTrue:
		[self inform: 'There is no section in updates.list for the target version'.
		self closeGroup.  ^ nil].	"abort"
	versIndex < listContents size ifTrue:
		[(self confirm: 'This system, ', version ,
				' is not the latest version.\OK to copy updates from that old version?' withCRs)
			ifFalse: [self closeGroup.  ^ nil]].	"abort"

	"Append all fileNames in my list that are not in the export list"
	additions _ OrderedCollection new.
	outOfOrder _ OrderedCollection new.
	lastNum _ (listContents at: otherVersIndex) last isEmpty
		ifTrue: [0]  "no checking if the current list is empty"
		ifFalse: [(listContents at: otherVersIndex) last last initialIntegerOrNil].
	(listContents at: versIndex) last do:
		[:fileName | seq _ fileName initialIntegerOrNil.
		(selectList includes: seq) ifTrue:
			[seq > lastNum
				ifTrue: [additions addLast: fileName]
				ifFalse: [outOfOrder addLast: seq]]].
	outOfOrder isEmpty ifFalse:
		[UIManager default inform: 'Updates numbered ' , outOfOrder asArray printString,
		' are out of order.\ The last update in ' withCRs,
		otherVersion, ' is ', lastNum printString,
		'.\No update will take place.' withCRs.
		self closeGroup.  ^ nil].	"abort"

	"Save old copy of updates.list on local disk"
	FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'.
	Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk').

	"Write a new copy of updates.list on all servers..."
	listContents at: otherVersIndex put:
		{otherVersion. (listContents at: otherVersIndex) last , additions}.
	updateStrm _ ReadStream on:
		(String streamContents: [:s | Utilities writeList: listContents toStream: s]).
	myServers do:
		[:aServer |
		updateStrm reset.
		aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true.
		Transcript show: 'Update succeeded on server ', aServer moniker; cr].
	self closeGroup.
		
	Transcript cr; show: 'Be sure to test your new update!!'; cr.
! !

!ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:31'!
exportUpdatesExcept: skipList
	"Into the section of updates.list corresponding to this version,
	copy all the fileNames in the named updates.list for this group
	that are more recently numbered."
"
		(ServerDirectory serverInGroupNamed: 'Disney Internal Updates*')
			exportUpdatesExcept: #(3959).
"
	| myServers updateStrm response seq indexPrefix listContents version versIndex lastNum expContents expVersIndex additions |
	self openGroup.
	indexPrefix _ (self groupName includes: $*) 
		ifTrue: [(self groupName findTokens: ' ') first]	"special for internal updates"
		ifFalse: ['']. 	"normal"
	myServers _ self checkServersWithPrefix: indexPrefix
					andParseListInto: [:x | listContents _ x].
	myServers size = 0 ifTrue: [self closeGroup.  ^ self].

	version _ SystemVersion current version.
	versIndex _ (listContents collect: [:pair | pair first]) indexOf: version.
	versIndex = 0 ifTrue:
		[self inform: 'There is no section in updates.list for your version'.
		self closeGroup.  ^ nil].	"abort"
	versIndex < listContents size ifTrue:
		[response _ UIManager default 
			chooseFrom: #('Make update from an older version' 'Cancel update')
			title: 'This system, ', SystemVersion current version,
				' is not the latest version'.
		response = 1 ifFalse: [self closeGroup.  ^ nil]].	"abort"

	"Get the old export updates.list."
	expContents _  Utilities parseListContents: 
			(myServers first getFileNamed: 'updates.list').
	expVersIndex _ (expContents collect: [:pair | pair first]) indexOf: version.
	expVersIndex = 0 ifTrue:
		[self inform: 'There is no section in updates.list for your version'.
		self closeGroup.  ^ nil].	"abort"
	lastNum _ (expContents at: expVersIndex) last isEmpty
		ifTrue: [0]  "no checking if the current list is empty"
		ifFalse: [(expContents at: expVersIndex) last last initialIntegerOrNil].

	"Save old copy of updates.list on local disk"
	FileDirectory default deleteFileNamed: 'updates.list.bk'.
	Utilities writeList: expContents toStream: (FileStream fileNamed: 'updates.list.bk').

	"Append all fileNames in my list that are not in the export list"
	additions _ OrderedCollection new.
	(listContents at: versIndex) last do:
		[:fileName | seq _ fileName initialIntegerOrNil.
		(seq > lastNum and: [(skipList includes: seq) not]) ifTrue:
			[additions addLast: fileName]].
	expContents at: expVersIndex put:
		{version. (expContents at: expVersIndex) last , additions}.
	(self confirm: 'Do you really want to export ' , additions size printString , ' recent updates?')
		ifFalse: [self closeGroup.  ^ nil].	"abort"

	"Write a new copy of updates.list on all servers..."
	updateStrm _ ReadStream on:
		(String streamContents: [:s | Utilities writeList: expContents toStream: s]).
	myServers do:
		[:aServer |
		updateStrm reset.
		aServer putFile: updateStrm named: 'updates.list' retry: true.
		Transcript show: 'Update succeeded on server ', aServer moniker; cr].
	self closeGroup.
		
	Transcript cr; show: 'Be sure to test your new update!!'; cr.
! !

!ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:39'!
outOfDate: aServer
	"Inform the user that this server does not have a current version of 'Updates.list'  Return true if the user does not want any updates to happen."

| response |
response _ UIManager default chooseFrom: #('Install on others' 'Cancel entire update')
		title: 'The server ', aServer moniker, ' is not up to date.
Please store the missing updates maually.'.
^ response ~= 1! !

!ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:42'!
putUpdate: fileStrm
	"Put this file out as an Update on the servers of my group.  Each version of the system may have its own set of update files, or they may all share the same files.  'updates.list' holds the master list.  Each update is a fileIn whose name begins with a number.  See Utilities class readServerUpdatesThrough:saveLocally:updateImage:.
	When two sets of updates are stored on the same directory, one of them has a * in its 
serverUrls description.  When that is true, the first word of the description is put on
the front of 'updates.list', and that index file is used."

	| myServers updateStrm newName response localName seq indexPrefix listContents version versIndex lastNum stripped |
	localName _ fileStrm localName.
	fileStrm size = 0 ifTrue:
		[^ self inform: 'That file has zero bytes!!  May have a new name.'].
	(fileStrm contentsOfEntireFile includes: Character linefeed)
		ifTrue: [self notifyWithLabel:  'That file contains linefeeds.  Proceed if...
you know that this is okay (e.g. the file contains raw binary data).'].
	fileStrm reset.
	(self checkNames: {localName}) ifFalse: [^ nil].	"illegal characters"
	response _ UIManager default chooseFrom: #('Install update' 'Cancel update')
		title: 'Do you really want to broadcast the file ', localName, 
			'\to every Squeak user who updates from ' withCRs, self groupName, '?'.
	response = 1 ifFalse: [^ nil].	"abort"

	self openGroup.
	indexPrefix _ (self groupName includes: $*) 
		ifTrue: [(self groupName findTokens: ' ') first]	"special for internal updates"
		ifFalse: ['']. 	"normal"
	myServers _ self checkServersWithPrefix: indexPrefix
					andParseListInto: [:x | listContents _ x].
	myServers size = 0 ifTrue: [self closeGroup.  ^ self].

	version _ SystemVersion current version.
	versIndex _ (listContents collect: [:pair | pair first]) indexOf: version.
	versIndex = 0 ifTrue:
		[self inform: 'There is no section in updates.list for your version'.
		self closeGroup.  ^ nil].	"abort"

	"A few affirmations..."
	versIndex < listContents size ifTrue:
		[(self confirm: 'This system, ', version ,
				' is not the latest version.\Make update for an older version?' withCRs)
			ifFalse: [self closeGroup.  ^ nil]].	"abort"
	(listContents at: versIndex) last isEmpty ifTrue:
		[(self confirm: 'Please confirm that you mean to issue the first update for ' ,
						version , '\(otherwise something is wrong).' withCRs)
			ifFalse: [self closeGroup.  ^ nil]].

	"We now determine next update number to be max of entire index"
	lastNum _ listContents inject: 0 into:
		[:max :pair | pair last isEmpty
					ifTrue: [max]
					ifFalse: [max max: pair last last initialIntegerOrNil]].

	"Save old copy of updates.list on local disk"
	FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'.
	Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk').

	"append name to updates with new sequence number"
	seq _ (lastNum + 1) printString padded: #left to: 4 with: $0.
	"strip off any old seq number"
	stripped _ localName copyFrom: (localName  findFirst: [:c | c isDigit not]) to: localName size.
	newName _ seq , stripped.
	listContents at: versIndex put:
		{version. (listContents at: versIndex) last copyWith: newName}.

	"Write a new copy on all servers..."
	updateStrm _ ReadStream on:
		(String streamContents: [:s | Utilities writeList: listContents toStream: s]).
	myServers do:
		[:aServer |
		fileStrm reset.	"reopen"
		aServer putFile: fileStrm named: newName retry: true.
		updateStrm reset.
		aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true.
		Transcript show: 'Update succeeded on server ', aServer moniker; cr].
	self closeGroup.
		
	Transcript cr; show: 'Be sure to test your new update!!'; cr.
	"rename the file locally (may fail)"
	fileStrm directory rename: localName toBe: newName.
! !

!ServerDirectory methodsFor: 'updates' stamp: 'rbb 3/1/2005 11:13'!
putUpdateMulti: list fromDirectory: updateDirectory 
	"Put these files out as an Update on the servers of my group.  List is an array of local file names with or without number prefixes.  Each version of the system has its own set of update files.  'updates.list' holds the master list.  Each update is a fileIn whose name begins with a number.  See Utilities class absorbUpdatesFromServer."

	| myServers updateStrm lastNum response newNames file numStr indexPrefix listContents version versIndex seq stripped |
	(self checkNames: (list collect: "Check the names without their numbers"
		[:each | each copyFrom: (each findFirst: [:c | c isDigit not]) to: each size]))
		ifFalse: [^ nil].
	response := UIManager default chooseFrom: #('Install update' 'Cancel update')
		title: 'Do you really want to broadcast ', list size printString, ' updates',
			'\to every Squeak user who updates from ' withCRs, self groupName, '?'.
	response = 1 ifFalse: [^ nil].	"abort"

	self openGroup.
	indexPrefix := (self groupName includes: $*) 
		ifTrue: [(self groupName findTokens: ' ') first]	"special for internal updates"
		ifFalse: ['']. 	"normal"
	myServers := self checkServersWithPrefix: indexPrefix
					andParseListInto: [:x | listContents := x].
	myServers size = 0 ifTrue: [self closeGroup.  ^ self].

	version := SystemVersion current version.
	versIndex := (listContents collect: [:pair | pair first]) indexOf: version.
	versIndex = 0 ifTrue:
		[self inform: 'There is no section in updates.list for your version'.
		self closeGroup.  ^ nil].	"abort"
	lastNum := (listContents at: versIndex) last last initialIntegerOrNil.
	versIndex < listContents size ifTrue:
		[response := UIManager default chooseFrom: #('Make update for an older version' 'Cancel update')
			title: 'This system, ', SystemVersion current version,
				' is not the latest version'.
		response = 1 ifFalse: [self closeGroup.  ^ nil].
		numStr := UIManager default 
			request: 'Please confirm or change the starting update number' 
			initialAnswer: (lastNum+1) printString.
		lastNum := numStr asNumber - 1].	"abort"
	"Save old copy of updates.list on local disk"
	FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'.
	Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk').

	"Append names to updates with new sequence numbers"
	newNames := list with: (lastNum+1 to: lastNum+list size) collect:
		[:each :num | seq := num printString padded: #left to: 4 with: $0.
		"strip off any old seq number"
		stripped := each copyFrom: (each  findFirst: [:c | c isDigit not]) to: each size.
		seq , stripped].
	listContents at: versIndex put:
		{version. (listContents at: versIndex) second , newNames}.

	"Write a new copy on all servers..."
	updateStrm := ReadStream on:
		(String streamContents: [:s | Utilities writeList: listContents toStream: s]).
	myServers do:
		[:aServer |
		list doWithIndex: [:local :ind |
			file := updateDirectory oldFileNamed: local.
			aServer putFile: file named: (newNames at: ind) retry: true.
			file close].
		updateStrm reset.
		aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true.
		Transcript show: 'Update succeeded on server ', aServer moniker; cr].
	self closeGroup.

	Transcript cr; show: 'Be sure to test your new update!!'; cr.
	"rename the file locally"
	list with: newNames do:
		[:local :newName | updateDirectory rename: local toBe: newName].
! !

!ServerDirectory methodsFor: 'updates' stamp: 'mir 6/26/2001 12:07'!
updateInstallVersion: newVersion
	"For each server group, ask whether we want to put the new version marker (eg 'Squeak2.3') at the end of the file.  Current version of Squeak must be the old one when this is done.
		ServerDirectory new updateInstallVersion: 'Squeak9.9test'
"
	| myServers updateStrm names choice indexPrefix listContents version versIndex |
	[names _ ServerDirectory groupNames asSortedArray.
	choice _ (SelectionMenu labelList: names selections: names) startUp.
	choice == nil]
		whileFalse:
		[indexPrefix _ (choice endsWith: '*') 
			ifTrue: [(choice findTokens: ' ') first]	"special for internal updates"
			ifFalse: ['']. 	"normal"
		myServers _ (ServerDirectory serverInGroupNamed: choice)
						checkServersWithPrefix: indexPrefix
						andParseListInto: [:x | listContents _ x].
		myServers size = 0 ifTrue: [^ self].

		version _ SystemVersion current version.
		versIndex _ (listContents collect: [:pair | pair first]) indexOf: version.
		versIndex = 0 ifTrue:
			[^ self inform: 'There is no section in updates.list for your version'].  "abort"

		"Append new version to updates following my version"
		listContents _ listContents copyReplaceFrom: versIndex+1 to: versIndex with: {{newVersion. {}}}.
		updateStrm _ ReadStream on:
			(String streamContents: [:s | Utilities writeList: listContents toStream: s]).

		myServers do:
			[:aServer | updateStrm reset.
			aServer putFile: updateStrm named: indexPrefix ,'updates.list'.
			Transcript cr; show: indexPrefix ,'updates.list written on server ', aServer moniker].
		self closeGroup]! !


!ServerDirectory methodsFor: 'up/download' stamp: 'hg 2/5/2002 16:50'!
fileExists: fileName
	"Does the file exist on this server directory?  fileName must be simple with no / or references to other directories."

	| stream |
	self isTypeFile ifTrue: [^ self fileNames includes: fileName].
	self isTypeHTTP ifTrue: [
		stream _ self readOnlyFileNamed: fileName.
		^stream contents notEmpty].
	"ftp"
	^ self entries anySatisfy: [:entry | entry name = fileName]! !

!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:17'!
getDirectory
	"Return a stream with a listing of the current server directory.  (Later -- Use a proxy server if one has been registered.)"

	| listing |
	client := self openFTPClient.
	[listing := client getDirectory]
		ensure: [self quit].
	^ReadStream on: listing! !

!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:16'!
getFileList
	"Return a stream with a list of files in the current server directory.  (Later -- Use a proxy server if one has been registered.)"

	| listing |
	client := self openFTPClient.
	[listing := client getFileList]
		ensure: [self quit].
	^ReadStream on: listing! !

!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:17'!
getFileNamed: fileNameOnServer
	"Just FTP a file from a server.  Return contents.
	(Later -- Use a proxy server if one has been registered.)"

	| result |
	client := self openFTPClient.
	[result := client getFileNamed: fileNameOnServer]
		ensure: [self quit].
	^result! !

!ServerDirectory methodsFor: 'up/download' stamp: 'hg 2/12/2002 11:44'!
getFileNamed: fileNameOnServer into: dataStream
	
	^self getFileNamed: fileNameOnServer into: dataStream 
		httpRequest: 'Pragma: no-cache', String crlf! !

!ServerDirectory methodsFor: 'up/download' stamp: 'ar 4/10/2005 18:52'!
getFileNamed: fileNameOnServer into: dataStream httpRequest: requestString
	"Just FTP a file from a server.  Return a stream.  (Later -- Use a proxy server if one has been registered.)"

	| resp |
	self isTypeFile ifTrue: [
		dataStream nextPutAll: 
			(resp _ FileStream oldFileNamed: server,(self serverDelimiter asString), 
				self bareDirectory, (self serverDelimiter asString),
				fileNameOnServer) contentsOfEntireFile.
		dataStream dataIsValid.
		^ resp].
	self isTypeHTTP ifTrue: [
		resp _ HTTPSocket httpGet: (self fullNameFor: fileNameOnServer) 
				args: nil accept: 'application/octet-stream' request: requestString.
		resp isString ifTrue: [^ dataStream].	"error, no data"
		dataStream copyFrom: resp.
		dataStream dataIsValid.
		^ dataStream].

	client _ self openFTPClient.	"Open passive.  Do everything up to RETR or STOR"
	[client getFileNamed: fileNameOnServer into: dataStream]
		ensure: [self quit].

	dataStream dataIsValid.
! !

!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:17'!
getOnlyBuffer: buffer from: fileNameOnServer
	"Open ftp, fill the buffer, and close the connection.  Only first part of a very long file."

	| dataStream |
	client := self openFTPClient.
	dataStream := WriteStream on: buffer.
	[client getPartial: buffer size fileNamed: fileNameOnServer into: dataStream]
		ensure: [self quit].
	^buffer! !

!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 16:39'!
putFile: fileStream named: fileNameOnServer
	"Just FTP a local fileStream to the server.  (Later -- Use a proxy server if one has been registered.)"

	client := self openFTPClient.
	client binary.
	[client putFileStreamContents: fileStream as: fileNameOnServer]
		ensure: [self quit]! !

!ServerDirectory methodsFor: 'up/download' stamp: 'nk 8/30/2004 08:00'!
putFile: fileStream named: fileNameOnServer retry: aBool
	"ar 11/24/1998 Do the usual putFile:named: operation but retry if some error occurs and aBool is set. Added due to having severe transmission problems on shell.webpage.com."
	| resp |
	self isTypeFile ifTrue: [
		^ (FileDirectory on: urlObject pathForDirectory)
			putFile: fileStream named: fileNameOnServer].

	[[resp _ self putFile: fileStream named: fileNameOnServer] 
		ifError:[:err :rcvr| resp _ '5xx ',err]. "Report as error"
	aBool and:[((resp isString) and: [resp size > 0]) and:[resp first ~= $2]]] whileTrue:[
		(self confirm:('Error storing ',fileNameOnServer,' on the server.\(',resp,',)\Retry operation?') withCRs) ifFalse:[^resp].
	].
	^resp! !

!ServerDirectory methodsFor: 'up/download' stamp: 'di 3/14/2001 15:34'!
putFileSavingOldVersion: fileStream named: fileNameOnServer

	| tempName oldName |
	"Put a copy of this file out after saving the prior version.
	Nothing happens to the old version until the new vers is successfully stored."
 	tempName _ fileNameOnServer , '.beingWritten'.
	oldName _ fileNameOnServer , '.prior'.
	self putFile: fileStream named: tempName retry: true.
	(self includesKey: oldName) ifTrue: [self deleteFileNamed: oldName].
	self rename: fileNameOnServer toBe: oldName.
	self rename: tempName toBe: fileNameOnServer.
! !


!ServerDirectory methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 15:45'!
eToyUserList
	"Return a list of all known users for eToy login support"
	| urlString |
	eToyUserList ifNotNil:[^eToyUserList].
	urlString _ self eToyUserListUrl.
	urlString ifNil:[^nil].
	eToyUserList _ self class parseEToyUserListFrom: urlString.
	^eToyUserList! !

!ServerDirectory methodsFor: '*eToys-school support' stamp: 'ar 8/24/2001 14:29'!
eToyUserListUrl
	^eToyUserListUrl! !

!ServerDirectory methodsFor: '*eToys-school support' stamp: 'ar 8/24/2001 14:31'!
eToyUserListUrl: aString
	eToyUserListUrl _ aString.
	eToyUserList _ nil.! !

!ServerDirectory methodsFor: '*eToys-school support' stamp: 'ar 8/24/2001 14:31'!
eToyUserList: aCollectionOrNil
	"Set a list of all known users for eToy login support"
	eToyUserList _ aCollectionOrNil.! !

!ServerDirectory methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 16:05'!
eToyUserName: aString
	"Ignored here"! !

!ServerDirectory methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 16:12'!
hasEToyUserList
	^eToyUserListUrl notNil! !


!ServerDirectory methodsFor: '*MorphicExtras-accessing' stamp: 'tk 1/25/1999 15:12'!
url
	"This was mis-named at the beginning.  Eventually convert over to altUrl and use this for the real url."
	^ self realUrl! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServerDirectory class
	instanceVariableNames: ''!

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 5/24/2001 17:49'!
addLocalProjectDirectory: aFileDirectory
	self localProjectDirectories add: aFileDirectory
! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:46'!
addServer: server named: nameString
	self servers at: nameString put: server! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 5/24/2001 17:48'!
localProjectDirectories
	LocalProjectDirectories ifNil: [LocalProjectDirectories _ OrderedCollection new].
	^LocalProjectDirectories! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:45'!
nameForServer: aServer
	^self servers keyAtValue: aServer! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 11/14/2001 16:26'!
projectServers
	"ServerDirectory projectServers"

	| projectServers projectServer |
	projectServers _ OrderedCollection new.
	self serverNames do: [ :n | 
		projectServer _ ServerDirectory serverNamed: n.
		(projectServer isProjectSwiki and: [projectServer isSearchable])
			ifTrue: [projectServers add: projectServer]].
	^projectServers! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:47'!
removeServerNamed: nameString
	self
		removeServerNamed: nameString
		ifAbsent: [self error: 'Server "' , nameString asString , '" not found']! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:46'!
removeServerNamed: nameString ifAbsent: aBlock
	self servers removeKey: nameString ifAbsent: [aBlock value]! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'ar 9/5/2001 16:11'!
resetLocalProjectDirectories
	LocalProjectDirectories _ nil.
	LocalEToyUserListUrls _ nil.
	LocalEToyBaseFolderSpecs _ nil.
! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:45'!
resetServers
	Servers _ nil! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'gk 10/21/2005 10:29'!
serverForURL: aURLString
	| serversForURL server urlPath serverPath relPath |
	serversForURL _ self servers values select: [:each |
		(aURLString beginsWith: each downloadUrl)
		or: [(aURLString beginsWith: each realUrl)
		or: [aURLString , '/' beginsWith: each downloadUrl]]].
	serversForURL isEmpty
		ifTrue: [^nil].
	server _ serversForURL first.
	urlPath _ aURLString asUrl path.
	(urlPath isEmpty not
		and: [urlPath last isEmpty])
		ifTrue: [urlPath removeLast].
	serverPath _ server downloadUrl asUrl path.
	(serverPath isEmpty not
		and: [serverPath last isEmpty])
		ifTrue: [serverPath removeLast].
	urlPath size < serverPath size
		ifTrue: [^nil].
	relPath _ String new.
	serverPath size +1 to: urlPath size do: [:i | relPath _ relPath , '/' , (urlPath at: i)].
	^relPath isEmpty
		ifTrue: [server]
		ifFalse: [server directoryNamed: (relPath copyFrom: 2 to: relPath size)]! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 14:06'!
serverNamed: nameString
	^self serverNamed: nameString ifAbsent: [self error: 'Server name not found']! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:44'!
serverNamed: nameString ifAbsent: aBlock
	^self servers at: nameString asString ifAbsent: [aBlock value]! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:48'!
serverNames
	^self servers keys asSortedArray! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:45'!
servers
	Servers ifNil: [Servers _ Dictionary new].
	^Servers! !


!ServerDirectory class methodsFor: 'class initialization' stamp: 'mir 6/25/2001 18:46'!
initialize
	"ServerDirectory initialize"
	"ServerDirectory resetLocalProjectDirectories.
	Servers _ Dictionary new."

	ExternalSettings registerClient: self! !


!ServerDirectory class methodsFor: 'misc' stamp: 'tk 12/29/1998 22:46'!
defaultStemUrl
	"For writing on an FTP directory.  Users should insert their own server url here."
"ftp://jumbo.rd.wdi.disney.com/raid1/people/dani/Books/Grp/Grp"
"	ServerDirectory defaultStemUrl	"

| rand dir |
rand _ String new: 4.
1 to: rand size do: [:ii |
	rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)].
dir _ self serverNamed: 'DaniOnJumbo'.
^ 'ftp://', dir server, dir slashDirectory, '/BK', rand! !

!ServerDirectory class methodsFor: 'misc' stamp: 'tk 9/8/1998 11:57'!
newFrom: aSimilarObject
	"Must copy the urlObject, so they won't be shared"

	| inst |
	inst _ super newFrom: aSimilarObject.
	inst urlObject: aSimilarObject urlObject copy.
	^ inst! !

!ServerDirectory class methodsFor: 'misc' stamp: 'hg 9/21/2001 16:40'!
on: pathString

	^self new on: pathString! !

!ServerDirectory class methodsFor: 'misc' stamp: 'kfr 7/18/2003 11:18'!
parseFTPEntry: ftpEntry
	| tokens longy dateInSeconds thisYear thisMonth |
	thisYear _ Date today year.
	thisMonth _ Date today monthIndex.
	tokens _ ftpEntry findTokens: ' '. 

	tokens size = 8 ifTrue:
		[((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue:
			["Fix for case that group is blank (relies on month being 3 chars)"
			tokens _ tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]].
	tokens size >= 9 ifFalse:[^nil].

	((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue:
		["Fix for case that group is blank (relies on month being 3 chars)"
		tokens _ tokens copyReplaceFrom: 4 to: 3 with: {'blank'}].

	tokens size > 9 ifTrue:
		[longy _ tokens at: 9.
		10 to: tokens size do: [:i | longy _ longy , ' ' , (tokens at: i)].
		tokens at: 9 put: longy].
	dateInSeconds _ self
		secondsForDay: (tokens at: 7) 
		month: (tokens at: 6) 
		yearOrTime: (tokens at: 8) 
		thisMonth: thisMonth 
		thisYear: thisYear. 

	^DirectoryEntry name: (tokens last)  "file name"
		creationTime: dateInSeconds "creation date"
		modificationTime: dateInSeconds "modification time"
		isDirectory:( (tokens first first) = $d or: [tokens first first =$l]) "is-a-directory flag"
		fileSize: tokens fifth asNumber "file size"
! !

!ServerDirectory class methodsFor: 'misc' stamp: 'mir 4/13/2001 12:44'!
secondsForDay: dayToken month: monthToken yearOrTime: ytToken 
thisMonth: thisMonth thisYear: thisYear

	| ftpDay ftpMonth pickAYear jDateToday trialJulianDate |

	ftpDay _ dayToken asNumber.
	ftpMonth _ Date indexOfMonth: monthToken.
	(ytToken includes: $:) ifFalse: [
		^(Date newDay: ftpDay month: ftpMonth year: ytToken asNumber) asSeconds
	].
	jDateToday _ Date today dayOfYear.
	trialJulianDate _ (Date newDay: ftpDay month: ftpMonth year: thisYear) dayOfYear.
	
	"Date has no year if within six months (do we need to check the day, too?)"

	"Well it appear to be pickier than that... it isn't just 6 months or 6 months and the day of the month, put perhaps the julian date AND the time as well. I don't know what the precise standard is, but this seems to produce better results"

	pickAYear _ (jDateToday - trialJulianDate) > 182 ifTrue: [
		thisYear + 1	"his clock could be ahead of ours??"
	] ifFalse: [
		pickAYear _ (trialJulianDate - jDateToday) > 182 ifTrue: [
			thisYear - 1
		] ifFalse: [
			thisYear
		].
	].
	^(Date newDay: ftpDay month: ftpMonth year: pickAYear) asSeconds +
		(Time readFrom: (ReadStream on: ytToken)) asSeconds

! !


!ServerDirectory class methodsFor: 'school support' stamp: 'mir 9/5/2001 18:39'!
projectDefaultDirectory
	^Preferences eToyLoginEnabled
		ifTrue: [
			(ServerDirectory localProjectDirectories, ServerDirectory servers values)
						detect:[:any| any hasEToyUserList]
						ifNone:[FileDirectory default]]
		ifFalse: [FileDirectory default]! !


!ServerDirectory class methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:26'!
convertGroupNames
	"ServerDirectory convertGroupNames"
	self servers do: [:each | each convertGroupName]! !

!ServerDirectory class methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:11'!
groupNames
	"Return the names of all registered groups of servers, including individual servers not in any group."
	"ServerDirectory groupNames"
	| names |
	names _ Set new.
	self servers do: [:server |
		names add: server groupName].
	^names asSortedArray
! !

!ServerDirectory class methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:06'!
serverInGroupNamed: groupName
	"Return the first (available) server in the group of this name."

	| servers |
	servers _ self serversInGroupNamed: groupName.
	servers isEmpty
		ifTrue: [self error: 'No server found in group "' , groupName asString , '".'].
	^servers first! !

!ServerDirectory class methodsFor: 'server groups' stamp: 'mir 6/26/2001 11:55'!
serversInGroupNamed: nameString
	"Return the servers in the group of this name."
	"ServerDirectory serversInGroupNamed: 'Squeak Public Updates' "

	^self servers values select: [:server |
		nameString = server groupName].
! !


!ServerDirectory class methodsFor: 'server prefs' stamp: 'sd 9/30/2003 13:58'!
determineLocalServerDirectory: directoryName
	"This is part of a workaround for Mac file name oddities regarding relative file names.
	The real fix should be in fullNameFor: but that seems to break other parts of the system."

	| dirName |
	dirName _ directoryName.
	(SmalltalkImage current platformName = 'Mac OS'
		and: [directoryName beginsWith: ':'])
			ifTrue: [
				dirName _ (FileDirectory default pathName endsWith: directoryName)
					ifTrue: [FileDirectory default pathName]
					ifFalse: [(FileDirectory default pathName , directoryName) replaceAll: '::' with: ':']].
	^FileDirectory default directoryNamed: dirName! !

!ServerDirectory class methodsFor: 'server prefs' stamp: 'mir 5/30/2001 15:28'!
fetchExternalSettingsIn: aDirectory
	"Scan for server configuration files"
	"ServerDirectory fetchExternalSettingsIn: (FileDirectory default directoryNamed: 'prefs')"

	| serverConfDir stream |
	(aDirectory directoryExists: self serverConfDirectoryName)
		ifFalse: [^self].
	self resetLocalProjectDirectories.
	serverConfDir _ aDirectory directoryNamed: self serverConfDirectoryName.
	serverConfDir fileNames do: [:fileName |
		stream _ serverConfDir readOnlyFileNamed: fileName.
		stream
			ifNotNil: [
				[self parseServerEntryFrom: stream] ifError: [:err :rcvr | ].
				stream close]]! !

!ServerDirectory class methodsFor: 'server prefs' stamp: 'KR 1/30/2006 22:16'!
parseServerEntryFrom: stream
	
	| server type directory entries serverName |

	entries _ ExternalSettings parseServerEntryArgsFrom: stream.

	serverName _ entries at: 'name' ifAbsent: [^nil].
	directory _ entries at: 'directory' ifAbsent: [^nil].
	type _ entries at: 'type' ifAbsent: [^nil].
	type = 'file'
		ifTrue: [
			server _ self determineLocalServerDirectory: directory.
			entries at: 'userListUrl' ifPresent:[:value | server eToyUserListUrl: value].
			entries at: 'baseFolderSpec' ifPresent:[:value | server eToyBaseFolderSpec: value].
			^self addLocalProjectDirectory: server].
	type = 'bss'
		ifTrue: [server _ SuperSwikiServer new type: #http].
	type = 'http'
		ifTrue: [server _ HTTPServerDirectory new type: #ftp].
	type = 'ftp'
		ifTrue: [server _ ServerDirectory new type: #ftp].

	server directory: directory.
	entries at: 'server' ifPresent: [:value | server server: value].
	entries at: 'user' ifPresent: [:value | server user: value].
	entries at: 'group' ifPresent: [:value | server groupName: value].
	entries at: 'passwdseq' ifPresent: [:value | server passwordSequence: value asNumber].
	entries at: 'url' ifPresent: [:value | server altUrl: value].
	entries at: 'loaderUrl' ifPresent: [:value | server loaderUrl: value].
	entries at: 'acceptsUploads' ifPresent: [:value | server acceptsUploads: value asLowercase = 'true'].
	entries at: 'userListUrl' ifPresent:[:value | server eToyUserListUrl: value].
	entries at: 'encodingName' ifPresent:[:value | server encodingName: value].
	ServerDirectory addServer: server named: serverName.
! !

!ServerDirectory class methodsFor: 'server prefs' stamp: 'mir 8/22/2001 17:01'!
releaseExternalSettings
	"Release for server configurations"
	"ServerDirectory releaseExternalSettings"

	Preferences externalServerDefsOnly
		ifTrue: [
			self resetLocalProjectDirectories.
			Servers _ Dictionary new]! !

!ServerDirectory class methodsFor: 'server prefs' stamp: 'mir 5/24/2001 17:08'!
serverConfDirectoryName
	^'knownServers'! !

!ServerDirectory class methodsFor: 'server prefs' stamp: 'mir 6/26/2001 09:49'!
storeCurrentServersIn: aDirectory

	| file |
	self servers do: [:each |
		file _ aDirectory fileNamed: (ServerDirectory nameForServer: each).
		each storeServerEntryOn: file.
		file close].
	self localProjectDirectories do: [:each |
		file _ aDirectory fileNamed: each localName.
		each storeServerEntryOn: file.
		file close].
! !

!ServerDirectory class methodsFor: 'server prefs' stamp: 'hg 9/29/2001 14:35'!
transferServerDefinitionsToExternal
	"ServerDirectory transferServerDefinitionsToExternal"

	| serverDir |
	serverDir _ ExternalSettings preferenceDirectory directoryNamed: self serverConfDirectoryName.
	serverDir assureExistence.
	ServerDirectory storeCurrentServersIn: serverDir! !


!ServerDirectory class methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 16:10'!
eToyBaseFolderSpecForFileDirectory: aFileDirectory
	^self localEToyBaseFolderSpecs at: aFileDirectory ifAbsent:[nil]! !

!ServerDirectory class methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 16:30'!
eToyBaseFolderSpecForFileDirectory: aFileDirectory put: aString
	^self localEToyBaseFolderSpecs at: aFileDirectory put: aString! !

!ServerDirectory class methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 16:38'!
eToyUserListForFileDirectory: aFileDirectory
	| urlString |
	urlString _ self eToyUserListUrlForFileDirectory: aFileDirectory.
	urlString ifNil:[^nil].
	^self parseEToyUserListFrom: urlString! !

!ServerDirectory class methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 15:46'!
eToyUserListUrlForFileDirectory: aFileDirectory
	^self localEToyUserListUrls at: aFileDirectory ifAbsent:[nil]! !

!ServerDirectory class methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 15:48'!
eToyUserListUrlForFileDirectory: aFileDirectory put: urlString
	^self localEToyUserListUrls at: aFileDirectory put: urlString! !

!ServerDirectory class methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 16:11'!
localEToyBaseFolderSpecs
	^LocalEToyBaseFolderSpecs ifNil:[LocalEToyBaseFolderSpecs _ IdentityDictionary new]! !

!ServerDirectory class methodsFor: '*eToys-school support' stamp: 'ar 9/5/2001 15:47'!
localEToyUserListUrls
	^LocalEToyUserListUrls ifNil:[LocalEToyUserListUrls _ IdentityDictionary new].! !

!ServerDirectory class methodsFor: '*eToys-school support' stamp: 'fbs 2/2/2005 13:24'!
parseEToyUserListFrom: urlString
	| url userString userList |
	urlString ifNil:[^nil].
	url _ urlString asUrl.
	["Note: We need to prevent going through the plugin API 
	when retrieving a local (file) URL, since the plugin API
	(correctly) rejects file:// downloads."
		Cursor wait showWhile:[
			(url hasRemoteContents) ifTrue:[
				"Go through the browser (if present)"
				userString _ (HTTPClient httpGet: url asString) contents.
			] ifFalse:[
				"Go grab it directly"
				userString _ url retrieveContents contents.
			].
		].
	] on: Error do:[:ex| userString _ nil. ex return].
	userString ifNil:[^nil].
	"Get rid of any line ending problems"
	userString _ userString copyReplaceAll: String crlf with: String cr.
	userString _ userString copyReplaceAll: String lf with: String cr.
	userList _ (userString findTokens: Character cr) collect:[:each| each withBlanksTrimmed].
	userList _ userList reject:[:any| any isEmpty].
	(userList first = '##user list##') ifFalse:[^nil].
	userList _ userList copyFrom: 2 to: userList size.
	^userList! !
ServerDirectory subclass: #ServerFile
	instanceVariableNames: 'fileName rwmode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RemoteDirectory'!
!ServerFile commentStamp: '<historical>' prior: 0!
Represents the non-data part of a file on a server on the internet.  I am owned by a RemoteFileStream, who has the data.

Since FileStream is a Stream and I am not, use this to always get a stream:
	xxx isStream ifFalse: [^ xxx asStream].

!


!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 2/23/2000 19:16'!
asStream
	"Return a RemoteFileStream (subclass of RWBinaryOrTextStream) on the contents of the remote file I represent.  For reading only.  This method is probably misnamed.  Maybe call it makeStream"

	^ self readOnlyFileNamed: self fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 3/13/2000 16:53'!
directoryUrl
	| ru |
	"A url to the directory this file is in"

	ru _ self realUrl.
	^ ru copyFrom: 1 to: (ru size - fileName size)! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:12'!
exists
	"Return true if the file exists on the server already"

	^ self fileExists: fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 15:01'!
fileName
	"should this be local or as in a url?"

	urlObject ifNotNil: [^ urlObject path last].	"path last encodeForHTTP ?"
	^ fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 14:45'!
fileName: aString

urlObject ~~ nil  "type == #file" 
	ifTrue: [urlObject path at: urlObject path size put: aString]
	ifFalse: [fileName _ aString]! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/23/1998 17:24'!
fileNameRelativeTo: aServerDir
	"Produce an absolute fileName from me and an absolute directory"
	urlObject isAbsolute ifFalse: [
		(aServerDir urlObject ~~ nil and: [aServerDir urlObject isAbsolute]) 
			ifTrue: [urlObject 
				privateInitializeFromText: urlObject pathString 
				relativeTo: aServerDir urlObject]
			ifFalse: [urlObject default]].	"relative to Squeak directory"
	^ urlObject pathForDirectory, self fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:45'!
fullPath: serverAndDirectory
	"Parse and save a full path.  Separate out fileName at the end."

	| delim ii |
	super fullPath: serverAndDirectory.		"set server and directory"
	self isTypeFile ifTrue: [
		fileName _  ''.
		^ self
	].
	delim _ self pathNameDelimiter.
	ii _ directory findLast: [:c | c = delim].
	ii = 0
		ifTrue: [self error: 'expecting directory and fileName']
		ifFalse: [fileName _ directory copyFrom: ii+1 to: directory size.
			directory _ (directory copyFrom: 1 to: directory size - fileName size - 1)].! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 4/13/2000 17:12'!
localName

	^ self fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/18/1998 16:42'!
readOnly
	"Set the receiver to be read-only"

	rwmode _ false! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:35'!
readWrite
	"Set the receiver to be writable"

	rwmode _ true! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'fbs 2/2/2005 13:27'!
realUrl
	"a fully expanded version of the url we represent.  Prefix the path with http: or ftp: or file:"

	self isTypeFile ifTrue: [
		self fileNameRelativeTo: self.
		^ urlObject asString
	].
	^ self typeWithDefault asString, '://', self pathName, '/', fileName	"note difference!!"
	! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:35'!
writable
	^ rwmode! !
Object subclass: #ServiceAction
	instanceVariableNames: 'condition action requestor label shortLabel description id provider enabled'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base'!
!ServiceAction commentStamp: 'rr 7/10/2006 14:58' prior: 0!
ServiceAction are executable objects in various contexts.
They can be displayed as buttons or menu items or bounded to keyboard shortcuts.

ServiceActions are defined in methods in an instance of a ServiceProvider class (in the 'services' method category), using the following template:

serviceIdentifierAndMethodName
	^ ServiceAction
		text: 'Menu item text'
		button: 'Button text'
		description: 'Longer text that appears in help balloons'
		action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"]
		
or, alternatively:

serviceIdentifierAndMethodName
	^ ServiceAction
		text: 'Menu item text'
		button: 'Button text'
		description: 'Longer text that appears in help balloons'
		action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"]
		condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"]
		
The method name in which the service is defined becomes its identifier. To build the hierarchy of services and to assign them to shortcuts, you will need to type this names in the relevant fields of the Services Browser.
		
Services are arranged in a hierarchy. and bound to keyboard shortcuts using the ServicesBrowser.
!


!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:40'!
action: aBlock
	action := aBlock fixTemps! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/8/2006 09:10'!
buttonLabel
	^ shortLabel
		ifNil: [self text]
		ifNotNil: [shortLabel ifEmpty: [self text] ifNotEmpty: [shortLabel]]! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 7/5/2005 17:34'!
buttonLabel: anObject
	shortLabel := anObject! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 10/23/2005 14:33'!
categories
	^ ServiceRegistry current categories select: [:e | e services includes: self]! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:40'!
condition: aBlock
	condition := aBlock fixTemps! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/9/2006 16:47'!
description

	^ description ifNil: [self text] ifNotNil: [description]! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/17/2004 16:49'!
description: anObject
	description := anObject select: [:each | (each = Character cr) not] 
						thenCollect: [:each | each = Character tab ifTrue: [Character space]
															ifFalse: [each]].! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/2/2005 17:14'!
id
	^id! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/2/2005 17:15'!
id: aSymbol
	id := aSymbol! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/12/2006 17:55'!
menuLabel
	| l sh |
	l := self text.
	l size > 50 ifTrue: [l := (l first: 47), '...'].	
	sh := self shortcut.
	sh := (sh isNil or: [sh isEmpty]) ifTrue: [''] ifFalse: [' (', sh, ')'].
	^ l capitalized, sh! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/14/2006 09:45'!
menuLabelNumbered: i
	| l sh str |
	l := self text.
	l size > 50
		ifTrue: [l := (l first: 47)
						, '...'].
	sh := self shortcut.
	sh := (sh isNil
					or: [sh isEmpty])
				ifTrue: ['']
				ifFalse: [' (' , sh , ')'].
	str := i isZero ifTrue: [''] ifFalse: [i asString, '. '].
	^ str, l capitalized , sh! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/8/2006 08:22'!
provider
	^ provider
		ifNil: [nil]
		ifNotNil: [provider new]! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/12/2006 17:58'!
provider: p
	provider := p! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/16/2004 20:59'!
requestor
	^requestor! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/16/2004 20:59'!
requestor: anObject
	requestor := anObject! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/9/2006 16:47'!
text
	^label isBlock ifTrue: [label fixTemps value: requestor] ifFalse: [label]! !

!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:52'!
text: aString
	label := aString! !


!ServiceAction methodsFor: 'executing' stamp: 'rr 11/14/2005 11:11'!
condExecuteWith: aRequestor
	self requestor: aRequestor.
	self executeCondition 
			ifTrue: [self execute] 
			ifFalse: [Beeper beep]! !

!ServiceAction methodsFor: 'executing' stamp: 'rr 3/10/2006 14:26'!
execute
	^ action clone valueWithRequestor: World topRequestor! !

!ServiceAction methodsFor: 'executing' stamp: 'rr 3/10/2006 14:26'!
executeCondition
	^ [condition clone valueWithRequestor: World topRequestor]
		on: Error
		do: [false]! !

!ServiceAction methodsFor: 'executing' stamp: 'rr 1/22/2006 12:55'!
perform: selector orSendTo: otherTarget
	^ self perform: selector! !


!ServiceAction methodsFor: 'initialize-release' stamp: 'rr 3/10/2006 10:40'!
initialize
	self
		action: [].
	self
		condition: [true].
	self text: 'no op'.
	self requestor: Requestor new.
	self id: #none.
	enabled := true! !


!ServiceAction methodsFor: 'preferences' stamp: 'rr 1/12/2006 17:52'!
addPreference: name category: cat selector: sel
	
	ServicePreferences 
		 addPreference: name
		 categories: {cat asSymbol. self providerCategory}
		 default: ''
		 balloonHelp:self description
		 projectLocal:false
		 changeInformee: self id -> sel
		 changeSelector: #serviceUpdate
		 viewRegistry: PreferenceViewRegistry ofTextPreferences! !

!ServiceAction methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:08'!
insertPreferences
	ServicePreferences
		addPreference: self id
		categories: (Array with: self providerCategory)
		default: true
		balloonHelp: self description
		projectLocal: false
		changeInformee: self id -> #updateEnable
		changeSelector: #serviceUpdate
		viewRegistry: PreferenceViewRegistry ofBooleanPreferences! !

!ServiceAction methodsFor: 'preferences' stamp: 'rr 1/9/2006 14:08'!
preferences
	^ {ServicePreferences preferenceAt: self shortcutPreference} select: [:e | e notNil]! !

!ServiceAction methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:00'!
providerCategory
	^ provider name! !

!ServiceAction methodsFor: 'preferences' stamp: 'rr 1/9/2006 16:49'!
shortcut
	^ ServicePreferences valueOfPreference: self shortcutPreference! !

!ServiceAction methodsFor: 'preferences' stamp: 'rr 12/30/2005 19:24'!
shortcutPreference 
		^ ('Shortcut for ', self id, ':') asSymbol! !

!ServiceAction methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:10'!
updateEnable
	enabled _ ServicePreferences
				valueOfPreference: self id
				ifAbsent: [true]! !


!ServiceAction methodsFor: 'testing' stamp: 'rr 3/2/2005 11:12'!
isCategory
	^ false! !

!ServiceAction methodsFor: 'testing' stamp: 'rr 3/10/2006 10:46'!
isEnabled
	^ enabled! !


!ServiceAction methodsFor: 'updating' stamp: 'rr 1/12/2006 18:16'!
updateShortcut
	(self systemNavigation allImplementorsOf: #processService:newShortcut:) 
		do: [:ref | | cls |
			cls := ref actualClass.
			cls isMeta ifTrue: [cls soleInstance processService: self newShortcut: self shortcut]].
	ServiceRegistry ifInteractiveDo: [self provider savePreferencesFor: self]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServiceAction class
	instanceVariableNames: ''!

!ServiceAction class methodsFor: 'class initialization' stamp: 'rr 8/19/2005 14:31'!
initialize
	#(
	(inlineServicesInMenu true 'Inline the services the squeak menus') 
	(useOnlyServicesInMenu false 'Use only services and not regular menu items')
	(useServicesInBrowserButtonBar false 'Use a service-based button bar')) 
		do: [:tr |
				Preferences 
						addPreference: tr first
						categories: #(#services)
						default: tr second
						balloonHelp: tr third] 
	! !


!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 3/2/2005 17:20'!
id: aSymbol text: aStringOrBlock button: buttonString description: aString action: aBlock
	^ self id: aSymbol 
		text: aStringOrBlock 
		button: buttonString 
		description: aString 
		action: aBlock 
		condition: [:r | true]! !

!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 1/9/2006 15:11'!
id: aSymbol text: aStringOrBlock button: buttonString description: aString action: aBlock condition: cBlock
	^ (self new) 
		id: aSymbol;
		text: aStringOrBlock; 
		buttonLabel: buttonString; 
		description: aString; 
		action: aBlock;
		condition: cBlock;
		yourself! !

!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 5/24/2005 17:23'!
text: aStringOrBlock button: buttonString description: aString action: aBlock
	"use when id can be automatically generated"
	^ self id: nil 
		text: aStringOrBlock 
		button: buttonString 
		description: aString 
		action: aBlock 
		condition: [:r | true]! !

!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 5/24/2005 17:26'!
text: aStringOrBlock button: buttonString description: aString action: aBlock condition: cBlock
	"use when id can be generated"
	^ self 
		id: nil 
		text: aStringOrBlock 
		button: buttonString 
		description: aString 
		action: aBlock
		condition: cBlock! !

!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 5/24/2005 17:24'!
text: textString description: aString action: aBlock
	"use when id can be generated"
	^ self id: nil text: textString button: textString description: aString action: aBlock! !
PreferenceBrowserMorph subclass: #ServiceBrowserMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base-GUI'!
!ServiceBrowserMorph commentStamp: 'rr 7/10/2006 15:28' prior: 0!
I subclass the PreferenceBrowserMorph to adapt the interface to services. So far the changes are minimal.!


!ServiceBrowserMorph methodsFor: 'as yet unclassified' stamp: 'rr 7/10/2006 15:26'!
newButtonRow
	^BorderedMorph new
		color: Color transparent; 
		cellInset: 2;
		layoutInset: 2;
		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
		listCentering: #topLeft;
		cellPositioning: #topLeft;
		on: #mouseEnter send: #paneTransition: to: self;
		on: #mouseLeave send: #paneTransition: to: self;
		"addMorphBack: self defaultButton;
		addMorphBack: self newSeparator;
		addMorphBack: self saveButton;
		addMorphBack: self loadButton;
		addMorphBack: self newSeparator;
		addMorphBack: self saveToDiskButton;
		addMorphBack: self loadFromDiskButton;
		addMorphBack: self newSeparator;
		addMorphBack: self newTransparentFiller;
		addMorphBack: self helpButton;"
		yourself.! !
Warning subclass: #ServiceCancelled
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base'!
!ServiceCancelled commentStamp: 'rr 4/1/2004 18:24' prior: 0!
Exception raised when a service is cancelled, to inform the user.!


!ServiceCancelled methodsFor: 'as yet unclassified' stamp: 'rr 3/10/2006 17:04'!
defaultAction
	Transcript cr; show: 'service has been cancelled'! !

!ServiceCancelled methodsFor: 'as yet unclassified' stamp: 'rr 3/14/2004 19:14'!
messageText
	^ 'Service has been cancelled'! !
ServiceAction subclass: #ServiceCategory
	instanceVariableNames: 'services'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base'!
!ServiceCategory commentStamp: 'rr 7/10/2006 15:06' prior: 0!
I represent a category of services that can be added to a menu.
I can be displayed as a menu or button bar containing my services.
I am also a subclass of ServiceAction, so I can form a subcategory of another service category.

Like services, I am created in methods of a ServiceProvider, in the 'services' method protocol.
The template to create a service category is the following:

methodNameAndServiceCategoryId
	^ ServiceCategory 
		text: 'Menu text' 
		button: 'Button  text' 
		description: 'Longer descriptive text appearing in help balloons'
	
To put services in a service category, you have to use the Service Browser, located in the word menu, under the 'Preferences and Services' menu item.
In it, you can look up for the name of your category, and enter service identifiers as children
of the category in the associatedd text field, separating them with spaces.!


!ServiceCategory methodsFor: 'accessing' stamp: 'rr 3/10/2006 10:47'!
enabledServices
	^ services
		select: [:e | e isEnabled]! !

!ServiceCategory methodsFor: 'accessing' stamp: 'rr 4/11/2005 17:22'!
requestor: aRequestor
	super requestor: aRequestor.
	self services do: [:s | s requestor: aRequestor]! !

!ServiceCategory methodsFor: 'accessing' stamp: 'rr 3/25/2004 20:43'!
services
	^services! !


!ServiceCategory methodsFor: 'executing' stamp: 'rr 10/14/2005 17:15'!
execute
	"displays the subservices as a submenu"
	ServiceGui openMenuFor: self! !


!ServiceCategory methodsFor: 'initialize-release' stamp: 'rr 1/4/2006 16:12'!
initialize

	services := OrderedCollection new.
	super initialize.
	
! !


!ServiceCategory methodsFor: 'preferences' stamp: 'rr 12/30/2005 19:24'!
childrenPreferences
		^ ('Items in ', self id, ':') asSymbol! !

!ServiceCategory methodsFor: 'preferences' stamp: 'rr 1/16/2006 07:32'!
externalPreferences
	| p |
	p := ServicePreferences valueOfPreference: self childrenPreferences ifAbsent: [''].
	^ (p findTokens: ' ') collect: [:e | e service]! !

!ServiceCategory methodsFor: 'preferences' stamp: 'rr 3/10/2006 09:51'!
insertPreferences
	super insertPreferences.
	ServicePreferences 
		addPreference: self childrenPreferences
		categories: { 
				('-- menu contents --' asSymbol).
				(self providerCategory)}
		default: ''
		balloonHelp: self description
		projectLocal: false
		changeInformee: self id -> #updateChildren
		changeSelector: #serviceUpdate
		viewRegistry: PreferenceViewRegistry ofTextPreferences! !

!ServiceCategory methodsFor: 'preferences' stamp: 'rr 1/19/2006 10:09'!
newChildren
	| s |
	s := ServicePreferences valueOfPreference: self childrenPreferences.
	^ (s findTokens: ' ') collect: [:str | str serviceOrNil]! !

!ServiceCategory methodsFor: 'preferences' stamp: 'rr 1/19/2006 10:13'!
newChildrenValid
	| s |
	s := ServicePreferences valueOfPreference: self childrenPreferences.
	^ (s findTokens: ' ') allSatisfy: [:str | 
		str serviceOrNil 
			ifNil: [ServiceRegistry ifInteractiveDo: 
						[self inform: str, ' is not a valid service name']. 
					false]
			ifNotNil: [true]]! !

!ServiceCategory methodsFor: 'preferences' stamp: 'rr 1/12/2006 18:10'!
prefServices
	| s |
	s := ServicePreferences valueOfPreference: self childrenPreferences.
	^ (s findTokens: ' ') collect: [:str | str service]! !

!ServiceCategory methodsFor: 'preferences' stamp: 'rr 3/12/2006 15:29'!
replaceChildren
	ServiceRegistry ifInteractiveDo: [services
		do: [:s | s provider
				ifNotNilDo: [:p | p class removeSelector: (self id , s id) asSymbol]]].
	services _ self newChildren.
	services
		do: [:e | 
			(ServicePreferences preferenceAt: e shortcutPreference)
				ifNotNilDo: [:p | p categoryList: {'-- keyboard shortcuts --'. self id asString}].
			ServiceRegistry
				ifInteractiveDo: [self provider savePreferencesFor: self]]! !

!ServiceCategory methodsFor: 'preferences' stamp: 'rr 3/12/2006 15:13'!
updateChildren

	self newChildrenValid
		ifTrue: [self replaceChildren].
	"PreferenceBrowserMorph updateBrowsers."
	ServiceGui updateBar: self! !


!ServiceCategory methodsFor: 'testing' stamp: 'rr 3/21/2004 18:25'!
isCategory
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServiceCategory class
	instanceVariableNames: ''!

!ServiceCategory class methodsFor: 'instance creation' stamp: 'rr 5/24/2005 17:29'!
text: aStringOrBlock button: buttonString description: aString
	"use when id can be generated"
	^ self id: nil text: aStringOrBlock button: buttonString description: aString action: [] ! !
Object subclass: #ServiceGui
	instanceVariableNames: 'menu bar service n'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base-GUI'!
!ServiceGui commentStamp: 'rr 7/10/2006 15:29' prior: 0!
I abstract all the UI-related behaviors for the services framework.
In the future I could be changed to be compatible with ToolBuilder!


!ServiceGui methodsFor: 'accessing' stamp: 'rr 7/5/2005 18:16'!
bar
	^ bar! !

!ServiceGui methodsFor: 'accessing' stamp: 'rr 7/5/2005 18:50'!
menu
	^ menu last! !


!ServiceGui methodsFor: 'building' stamp: 'rr 7/8/2005 16:28'!
buildButtonBar
	bar := self buttonBarFor: service.
	self class registerBar: bar for: service.
	^ bar! !

!ServiceGui methodsFor: 'building' stamp: 'rr 3/10/2006 16:39'!
inlineInMenu: aMenu 
	^ self class inlineServices
		ifTrue: [self inlineInMenu: aMenu for: service]
		ifFalse: [aMenu]! !


!ServiceGui methodsFor: 'initialize-release' stamp: 'rr 3/8/2006 10:00'!
for: caller id: id 
	service _ id service.
	caller ifNotNil: [service requestor: caller requestor]! !

!ServiceGui methodsFor: 'initialize-release' stamp: 'rr 3/13/2006 23:13'!
initialize
	menu _ OrderedCollection new.
	bar _ AlignmentMorph newRow.
	n := OrderedCollection with: 0! !


!ServiceGui methodsFor: 'serviceactions' stamp: 'rr 7/5/2005 18:59'!
buttonForAction: aService 
	"see getstate for availability?"

	| aButton |
	aButton := PluggableButtonMorph 
				on: aService
				getState: nil
				action: #execute.
	self styleButton: aButton.
	aButton
		label: aService buttonLabel;
		setBalloonText: aService description.
	^aButton! !

!ServiceGui methodsFor: 'serviceactions' stamp: 'rr 3/13/2006 23:16'!
menuItemForAction: aServiceAction 
	"Returns a menuItem triggering self"
	self menu
		add: (aServiceAction menuLabelNumbered: self n)
		target: aServiceAction
		selector: #execute.
	self menu lastItem isEnabled: aServiceAction executeCondition.
	self menu balloonTextForLastItem: aServiceAction description! !


!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/10/2006 10:47'!
buttonBarFor: aServiceCategory 
	self styleBar: self bar.
	aServiceCategory enabledServices
		do: [:each | self bar
				addMorphBack: (self buttonFor: each)].
	^ self bar! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 8/4/2005 15:25'!
buttonForCategory: aService 
	"see getstate for availability?"

	| aButton |
	aButton := PluggableButtonMorph 
				on: [:button | aService requestor: button requestor. 
								self class openMenuFor: aService] fixTemps
				getState: nil
				action: #value:.
	aButton arguments: (Array with: aButton).
	self styleButton: aButton.
	aButton
		label: aService buttonLabel.
	^aButton! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/10/2006 10:47'!
inlineInMenu: aMenu for: aServiceCategory 
	menu addLast: aMenu.
	aServiceCategory enabledServices
		do: [:each | self menuItemFor: each].
	^ self popMenu! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/10/2006 15:35'!
menuFor: aServiceCategory 
	| submenu |
	submenu _ self subMenuFor: aServiceCategory.
	^ submenu
		addTitle: (aServiceCategory menuLabel)! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:16'!
menuItemForCategory: aServiceCategory 
	"Returns a menuItem triggering self"
	| submenu |
	submenu _ self subMenuFor: aServiceCategory.
	self menu add: (aServiceCategory menuLabelNumbered: self n) subMenu: submenu! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:15'!
n
	^ n last! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:15'!
n: nn
	n removeLast.
	n addLast: nn! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:15'!
popMenu
	| aMenu |
	aMenu := menu removeLast.
	n removeLast.
	self styleMenu: aMenu.
	^ aMenu! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:14'!
pushMenu
	menu addLast: MenuMorph new.
	n addLast: 0! !

!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:16'!
subMenuFor: aServiceCategory 
	self pushMenu.
	aServiceCategory enabledServices
		ifEmpty: [self menuItemFor: ServiceAction new].
	aServiceCategory enabledServices
		doWithIndex: [:each :i | self n: i. self menuItemFor: each].
	^ self popMenu! !


!ServiceGui methodsFor: 'services' stamp: 'rr 7/6/2005 14:47'!
buttonFor: aService
	^ aService isCategory ifTrue: [self buttonForCategory: aService]
							ifFalse: [self buttonForAction: aService]! !

!ServiceGui methodsFor: 'services' stamp: 'rr 1/7/2006 11:43'!
menuItemFor: aService
	[aService isCategory ifTrue: [self menuItemForCategory: aService]
							ifFalse: [self menuItemForAction: aService]] 
		on: Error
		do: [:er | (self confirm: 'menuItemFor: error. debug?') ifTrue: [er signal]]! !


!ServiceGui methodsFor: 'styling' stamp: 'rr 7/5/2005 19:07'!
styleBar: aBar
	aBar setNameTo: 'button bar'.
	aBar beSticky;
		 hResizing: #spaceFill;
		wrapCentering: #center;
		cellPositioning: #leftCenter;
		clipSubmorphs: true;
		cellInset: 1;
		color: Color white.! !

!ServiceGui methodsFor: 'styling' stamp: 'rr 3/8/2006 14:29'!
styleButton: aButton 
	aButton color: Color transparent;
	onColor: Color transparent offColor: Color transparent;
	
	borderStyle: (BorderStyle width: 1 color: Color gray);
	askBeforeChanging: true;
	clipSubmorphs: true;
	hResizing: #spaceFill;
	vResizing: #spaceFill.
	^ self! !

!ServiceGui methodsFor: 'styling' stamp: 'rr 3/12/2006 11:20'!
styleMenu: aMenu 
	"gradient, etc ..?"
	"aMenu color: Color white;
		
		borderStyle: (BorderStyle width: 1 color: Color gray);
		 clipSubmorphs: true;
		 addDropShadow;
		
		shadowColor: (TranslucentColor
				r: 0.0
				g: 0.0
				b: 0.0
				alpha: 0.666);
		 shadowOffset: 1 @ 1"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServiceGui class
	instanceVariableNames: 'bars'!

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/10/2006 10:13'!
browserButtonRow: aBrowser
	^ (self new for: aBrowser id: #browserButtonBar) buildButtonBar ! !

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:00'!
browser: b classCategoryMenu: aMenu 
	^ (self new  for:b  id:#browserClassCategoryMenu)  inlineInMenu:aMenu! !

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:00'!
browser: b classMenu: aMenu 
	^ (self new  for:b  id:#browserClassMenu)  inlineInMenu:aMenu! !

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:02'!
browser: b codePaneMenu: aMenu 

	^(self new for: b id: #browserCodePaneMenu) inlineInMenu: aMenu! !

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:00'!
browser: b messageCategoryMenu: aMenu 
	^ (self new  for:b  id:#browserMethodCategoryMenu)  inlineInMenu:aMenu! !

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:01'!
browser: b messageListMenu: aMenu 
	^ (self new  for:b  id:#browserMethodMenu)  inlineInMenu:aMenu! !

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 3/10/2006 16:42'!
browserButtonRow: aBrowser inlinedIn: row 
	| bar |
	self buttonBarServices 
		ifTrue: [bar _ (self new for: aBrowser id: #browserButtonBar) buildButtonBar.
			row addMorphBack: bar].
	^ row! !

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:08'!
updateMenu: aMenu forModel: aModel selector: selector
	('codePane*' match: selector) ifTrue: [
	(self new for: aModel id: #codeSelectionRefactorings) inlineInMenu: aMenu].
	^ aMenu
	! !

!ServiceGui class methodsFor: 'hooks' stamp: 'rr 8/19/2005 14:50'!
worldMenu: aMenu
	^ (self new for: aMenu id: #world) inlineInMenu: aMenu! !


!ServiceGui class methodsFor: 'opening menus' stamp: 'rr 7/6/2005 16:09'!
openMenuFor: aServiceCategory
	(self new menuFor: aServiceCategory) invokeModal! !


!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 8/24/2005 12:01'!
bars
	^ bars! !

!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 3/10/2006 16:49'!
initialize
	bars _ OrderedCollection new.
	(TheWorldMenu respondsTo: #registerOpenCommand:)
		ifTrue: [TheWorldMenu unregisterOpenCommand: 'Services Browser'.
			TheWorldMenu registerOpenCommand: {'Services Browser'. {PreferenceBrowser. #openForServices}}]! !

!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 8/4/2005 15:02'!
registerBar: aBar for: service
	
	self bars removeAllSuchThat: [:a | a value isNil].
	self bars add: (WeakValueAssociation key: service value: aBar).! !

!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 1/12/2006 17:41'!
updateBars
	| cat newBar bar oldCat |
	self bars do: [:assoc | 
		(bar := assoc value) ifNotNil: [
			oldCat := assoc key.
			cat := oldCat id service.
			cat requestor: oldCat requestor.
			newBar := self new buttonBarFor: cat.
			bar removeAllMorphs.
			newBar submorphsDo: [:m | bar addMorphBack: m]].
		]! !

!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 1/10/2006 10:24'!
updateBar: cat
	| newBar |
	self bars 
		select: [:assoc | (assoc key id = cat id) & assoc value notNil] 
		thenDo: [:assoc | 
			cat requestor: assoc key requestor.
			newBar := self new buttonBarFor: cat.
			assoc value removeAllMorphs.
			newBar submorphsDo: [:m | assoc value addMorphBack: m]]! !


!ServiceGui class methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:38'!
buttonBarServices
	^ ServicePreferences valueOfPreference: #useServicesInBrowserButtonBar ! !

!ServiceGui class methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:37'!
inlineServices
	^ ServicePreferences valueOfPreference: #inlineServicesInMenu ! !

!ServiceGui class methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:38'!
onlyServices
	^ ServicePreferences valueOfPreference: #useOnlyServicesInMenu! !
Preferences subclass: #ServicePreferences
	instanceVariableNames: ''
	classVariableNames: 'ServiceDictionaryOfPreferences'
	poolDictionaries: ''
	category: 'Services-Base-GUI'!
!ServicePreferences commentStamp: 'rr 7/10/2006 15:36' prior: 0!
I store the preferences related to the servicse framework. The preferences are editable via the Services Browser, based on Hernan Tylim's Preference Browser.

The main preference categories for services are: 

-- keyboard shortcuts -- : several text preferences, one per keyboard shortcuts. To edit them,  enter a service identifier (equal to the method name under which it is defined in its ServiceProvider), and accept with alt-s or enter

-- menu contents -- : All the service categories in the image have a text preference under here. To edit it, enter the services identifiers you wish to put in this category, separating them with a single space character. The order is important: it defines the order of the items in menus.

-- settings -- : general boolean preferences.

Then there is a preference category for each provider in the image. Under each, you will find:
A boolean preference for each service in the image. If it is false, the service will not appear in menus. 
The text preference for each service category defined by the service provider. This is the same as the one appearing in the menu contents preference category.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServicePreferences class
	instanceVariableNames: ''!

!ServicePreferences class methodsFor: 'accessing' stamp: 'rr 10/11/2005 15:10'!
compileAccessMethodForPreference: aPreference
	"do nothing"! !

!ServicePreferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:18'!
dictionaryOfPreferences
	ServiceDictionaryOfPreferences 
		ifNil: [ServiceDictionaryOfPreferences := IdentityDictionary new].
	^ ServiceDictionaryOfPreferences ! !

!ServicePreferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:18'!
dictionaryOfPreferences: aDictionary
	ServiceDictionaryOfPreferences := aDictionary! !

!ServicePreferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:22'!
wipe
	self dictionaryOfPreferences: nil! !


!ServicePreferences class methodsFor: 'replaying' stamp: 'rr 3/12/2006 15:10'!
replayPreferences: preferences 
	| s v |
	s _ SortedCollection new
				sortBlock: [:a :b | a last < b last].
	s addAll: preferences;
		 reSort.
	s
		do: [:e | 
			v _ self valueOfPreference: e first ifAbsent: ''.
			self setPreference: e first toValue: (v
					ifEmpty: ['']
					ifNotEmpty: [v , ' '])
					, e second]! !
Object subclass: #ServiceProvider
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base'!
!ServiceProvider commentStamp: 'rr 7/10/2006 15:08' prior: 0!
A ServiceProvider references services that are relevant to a given application.

Each application that wishes to use the Services framework must subclass a ServiceProvider.
This class must define a 'services' method category.
Each method implemented in this category will be automatically called by the framework.
Each of these method should be a unary message (taking no argument), and return a fully initialised instance of ServiceAction or ServiceCategory. There are three possible patterns:

1)

serviceIdentifierAndMethodName
	^ ServiceAction
		text: 'Menu item text'
		button: 'Button text'
		description: 'Longer text that appears in help balloons'
		action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"]
		

2)

serviceIdentifierAndMethodName
	^ ServiceAction
		text: 'Menu item text'
		button: 'Button text'
		description: 'Longer text that appears in help balloons'
		action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"]
		condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"]
		
3)

methodNameAndServiceCategoryId
	^ ServiceCategory 
		text: 'Menu text' 
		button: 'Button  text' 
		description: 'Longer descriptive text appearing in help balloons'
	

The organisation of services into categories, and the services bound to keyboard shortcuts are
specified using the Services Browser (see the comment on the class ServicesPreferences for more details). When editing preferences, they are saved as methods on the ServiceProvider, all defined
in the 'saved preferences' method category. Each of thesse methods stores preferences that the provider can replay.
!


!ServiceProvider methodsFor: 'accessing' stamp: 'rr 8/2/2005 17:33'!
performAndSetId: aSymbol 
	| service |
	service := self perform: aSymbol.
	service id: aSymbol.
	^service! !

!ServiceProvider methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:23'!
registeredServices
	
	^ self services collect: [:each | self performAndSetId: each]! !

!ServiceProvider methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:23'!
services
	^ self class organization listAtCategoryNamed: #services! !


!ServiceProvider methodsFor: 'persistence' stamp: 'rr 1/10/2006 09:22'!
replayPreferences
	ServicePreferences replayPreferences: self savedPreferences! !

!ServiceProvider methodsFor: 'persistence' stamp: 'rr 1/11/2006 16:11'!
savedPreferences
	 ^ (self class organization listAtCategoryNamed: #'saved preferences')
			collect: [:e | self perform: e]! !

!ServiceProvider methodsFor: 'persistence' stamp: 'rr 3/10/2006 15:04'!
savePreferencesFor: aService 
	| strm |
	"pref _ ServicePreferences preferenceAt: aService shortcutPreference.
	strm _ WriteStream with: ''.
	strm nextPutAll: aService id;
		 nextPutAll: 'shortcut';
		 cr;
		 tab;
		 nextPutAll: '^ ';
		 nextPutAll: {pref name. pref preferenceValue. 1000} storeString.
	self class compileSilently: strm contents classified: 'saved preferences'."
	aService isCategory
		ifTrue: [aService externalPreferences
				doWithIndex: [:e :i | 
					strm _ WriteStream with: aService id asString.
					strm nextPutAll: e id asString;
						 cr;
						 tab;
						 nextPutAll: '^ ';
						 nextPutAll: {aService childrenPreferences. e id. i} storeString.
					e provider class compileSilently: strm contents classified: 'saved preferences']]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServiceProvider class
	instanceVariableNames: ''!

!ServiceProvider class methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:20'!
registeredProviders
	^ self allSubclasses collect: [:each | each new]! !


!ServiceProvider class methodsFor: 'provider creation' stamp: 'rr 1/10/2006 10:41'!
newProviderFor: packageName
	| cls clsName |
	clsName := ((packageName copyWithout: $-) , 'ServiceProvider') asSymbol.
	cls := self subclass: clsName
		instanceVariableNames: '' 
		classVariableNames: '' 
		poolDictionaries: ''
		category: packageName.
	cls class compile: 'initialize 
	ServiceRegistry buildProvider: self new' classified: 'initialization'.
	^ cls! !
Object subclass: #ServiceRegistry
	instanceVariableNames: 'services interactive'
	classVariableNames: 'Current'
	poolDictionaries: ''
	category: 'Services-Base'!
!ServiceRegistry commentStamp: 'rr 7/10/2006 15:10' prior: 0!
The ServiceRegistry is the repository in which services are stored. They are stored in
a dictionary, and keyed by their identifier (which is the name of the method they were defined in).

The registry handles the intialization, building and referencing processes as well.!


!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 3/2/2005 11:19'!
categories
	^ self serviceCollection select: [:s | s isCategory]! !

!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 10/20/2005 18:45'!
isInteractive
	^ interactive! !

!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 3/2/2005 11:18'!
serviceCollection
	^ services asArray! !

!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 3/2/2005 11:26'!
services
	^ self serviceCollection reject: [:s | s isCategory]! !

!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 1/16/2006 07:36'!
serviceWithId: aSymbol
	^ services at: aSymbol 
				ifAbsent: [nil]! !


!ServiceRegistry methodsFor: 'building' stamp: 'rr 1/11/2006 16:37'!
addService: aService provider: p
	services  at:aService id  put:aService.
	aService provider: p.
	aService insertPreferences
! !

!ServiceRegistry methodsFor: 'building' stamp: 'rr 1/10/2006 12:10'!
beNotInteractiveDuring: aBlock
	interactive := false.
	aBlock value.
	interactive := true! !

!ServiceRegistry methodsFor: 'building' stamp: 'rr 5/17/2006 16:02'!
build
	"ServicePreferences wipe."
	| pr |
	self
		beNotInteractiveDuring: [ServiceProvider registeredProviders
				do: [:p | p registeredServices
						do: [:each | self addService: each provider: p class]].
			pr := ServiceProvider registeredProviders
						gather: [:p | p savedPreferences].
			ServicePreferences replayPreferences: pr.
			].
	ServiceGui updateBars.
	ServiceShortcuts setPreferences! !

!ServiceRegistry methodsFor: 'building' stamp: 'rr 1/11/2006 16:38'!
buildProvider: p
	self beNotInteractiveDuring: [
		p registeredServices do: [:each | self addService: each provider: p class].
		p replayPreferences]
	! !


!ServiceRegistry methodsFor: 'initialize-release' stamp: 'rr 1/10/2006 12:18'!
initialize
	services := Dictionary new.
	interactive := true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServiceRegistry class
	instanceVariableNames: ''!

!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 1/10/2006 13:00'!
current
	^ Current ifNil: [Current := self new]! !

!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 1/12/2006 12:48'!
ifInteractiveDo: aBlock
	self current isInteractive ifTrue: [aBlock value]! !

!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 1/10/2006 13:01'!
initialize

	self rebuild.
	SystemChangeNotifier uniqueInstance
		notify: self
		ofSystemChangesOfItem: #method 
		using: #methodChanged:
		! !

!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 1/12/2006 12:35'!
methodChanged: event
	| cls | 
	self ifInteractiveDo: [
	cls := event itemClass. 
	((event changeKind = #removed) not & (cls inheritsFrom: ServiceProvider) and: [cls new services includes: event itemSelector])
		ifTrue: [[self current addService: (cls new performAndSetId: event itemSelector)
					provider: cls]
			on: Error do: [self inform: 'Service format seems to be incorrect']]]! !

!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 3/12/2006 15:19'!
rebuild
	| old |
	old := Current.
	[Current _ self new.
	Current build]
		on: Error
		do: [:err | (self confirm: 'An error occured during build. 
								Debug it?')
				ifTrue: [err signal].
				Current := old]! !
Object subclass: #ServiceShortcuts
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base'!
!ServiceShortcuts commentStamp: 'rr 7/10/2006 15:14' prior: 0!
A data structures implementing a simple form of keyboard shortucts is defined on the class side.

Available keyboard shortcuts are: 

command-0 to command-9 (command is also called alt on some systems).
control-0 to control-0
command-control-0 to command-control-9 (command is also alt)
control-command-left arrow
control-command-up arrow
control-command-right arrow
control-command-down arrow

Using the Services Browser (see class ServicePreferences), these shortcuts can be bound to service identifiers.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServiceShortcuts class
	instanceVariableNames: 'map'!

!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/11/2006 19:05'!
arrowShortcut: str event: event 
	| key s |
	key _ event keyCharacter caseOf: {
				[Character arrowDown] -> ['down'].
				[Character arrowUp] -> ['up'].
				[Character arrowLeft] -> ['left'].
				[Character arrowRight] -> ['right']}.
	s _ self map
				at: str , key
				ifAbsent: [^ self].
	s serviceOrNil
		ifNotNilDo: [:sv | sv execute.
	event wasHandled: true]! !

!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/20/2006 14:39'!
changeShortcut: shortcut to: aString
	aString isBlock ifTrue: [^self map at: shortcut put: aString].
	(aString startsWith: '[') ifTrue: [^self map at: shortcut put: aString].
	aString isEmpty ifTrue: [self map removeKey: shortcut ifAbsent: []]
				ifFalse: [self map at: shortcut put: aString]! !

!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/10/2006 14:20'!
handleKeystroke: event 
	[event isKeystroke
		ifTrue: [self process: event]]
		on: Error
		do: [:e | (self confirm: 'shortcut error. debug?') ifTrue: [e signal]]! !

!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/11/2006 14:03'!
insertPrefShortcut: short
					ServicePreferences
						addPreference: short
						categories: #('-- keyboard shortcuts --' )
						default: ''
						balloonHelp: 'enter a service id to bind it to this shortcut'
						projectLocal: false
						changeInformee: [self
								changeShortcut: short
								to: (ServicePreferences valueOfPreference: short)] fixTemps
						changeSelector: #value
						viewRegistry: PreferenceViewRegistry ofTextPreferences! !

!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/9/2006 16:31'!
map
	^ map ifNil: [map := Dictionary new]! !

!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/11/2006 19:04'!
process: event 
	event keyCharacter isDigit
		ifTrue: [event commandKeyPressed & event controlKeyPressed
				ifTrue: [^ self shortcut: 'ctrl-cmd-' event: event].
			event commandKeyPressed
				ifTrue: [^ self shortcut: 'cmd-' event: event].
			event controlKeyPressed
				ifTrue: [^ self shortcut: 'ctrl-' event: event]].
	({Character arrowUp. Character arrowDown. Character arrowLeft. Character arrowRight} includes: event keyCharacter)
		ifTrue: [event commandKeyPressed & event controlKeyPressed
				ifTrue: [^ self arrowShortcut: 'ctrl-cmd-' event: event].
			]! !

!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/11/2006 19:05'!
setPreferences
	| mm |
	mm _ self map copy.
	(0 to: 9)
		do: [:i | #('ctrl-' 'cmd-' 'ctrl-cmd-' )
				do: [:str | 
					| short | 
					short _ (str , i asString) asSymbol.
					self insertPrefShortcut: short]].
	#(#up #down #left #right )
		do: [:s | 
			self insertPrefShortcut: ('ctrl-cmd-' , s) asSymbol.].
	mm
		keysAndValuesDo: [:k :v | ServicePreferences setPreference: k toValue: v].
	((Array new: 3) at: 1 put: ((Array new: 3) at: 1 put: #inlineServicesInMenu;
			 at: 2 put: true;
			 at: 3 put: 'Inline the services the squeak menus';
			 yourself);
		 at: 2 put: ((Array new: 3) at: 1 put: #useOnlyServicesInMenu;
			 at: 2 put: false;
			 at: 3 put: 'Use only services and not regular menu items';
			 yourself);
		 at: 3 put: ((Array new: 3) at: 1 put: #useServicesInBrowserButtonBar;
			 at: 2 put: true;
			 at: 3 put: 'Use a service-based button bar';
			 yourself);
		 yourself)
		do: [:tr | ServicePreferences
				addPreference: tr first
				categories: #('-- settings --' )
				default: tr second
				balloonHelp: tr third]! !

!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/20/2006 22:01'!
shortcut: str event: event 
	| s |
	Transcript cr.
	s := self map
				at: str , event keyCharacter asString
				ifAbsent: [^ self].
	(s startsWith: '[') ifTrue: [^ (Compiler evaluateUnloggedForSelf:  s) value].
	s serviceOrNil
		ifNotNilDo: [:sv | sv execute.
	event wasHandled: true]! !
Collection subclass: #Set
	instanceVariableNames: 'tally array'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!Set commentStamp: '<historical>' prior: 0!
I represent a set of objects without duplicates.  I can hold anything that responds to
#hash and #=, except for nil.  My instances will automatically grow, if necessary,
Note that I rely on #=, not #==.  If you want a set using #==, use IdentitySet.

Instance structure:

  array	An array whose non-nil elements are the elements of the set,
		and whose nil elements are empty slots.  There is always at least one nil.
		In fact I try to keep my "load" at 75% or less so that hashing will work well.

  tally	The number of elements in the set.  The array size is always greater than this.

The core operation is #findElementOrNil:, which either finds the position where an
object is stored in array, if it is present, or finds a suitable position holding nil, if
its argument is not present in array,!


!Set methodsFor: 'accessing' stamp: 'md 7/31/2005 08:56'!
atRandom: aGenerator
	"Answer a random element of the receiver. Uses aGenerator which
    should be kept by the user in a variable and used every time. Use
    this instead of #atRandom for better uniformity of random numbers because 
	only you use the generator. Causes an error if self has no elements."
	| rand |

	self emptyCheck.
	rand _ aGenerator nextInt: self size.
	self doWithIndex:[:each :ind |
		ind == rand ifTrue:[^each]].
	^ self errorEmptyCollection
! !

!Set methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:40'!
capacity
	"Answer the current capacity of the receiver."

	^ array size! !

!Set methodsFor: 'accessing' stamp: 'SqR 8/23/2000 13:51'!
like: anObject
	"Answer an object in the receiver that is equal to anObject,
	nil if no such object is found. Relies heavily on hash properties"

	| index |

	^(index _ self scanFor: anObject) = 0
		ifFalse: [array at: index]! !

!Set methodsFor: 'accessing'!
size
	^ tally! !

!Set methodsFor: 'accessing' stamp: 'sma 5/12/2000 14:34'!
someElement
	"Deprecated. Use anyOne."

	^ self anyOne! !


!Set methodsFor: 'adding' stamp: 'sma 5/12/2000 17:28'!
add: newObject
	"Include newObject as one of the receiver's elements, but only if
	not already present. Answer newObject."

	| index |
	newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
	index _ self findElementOrNil: newObject.
	(array at: index) ifNil: [self atNewIndex: index put: newObject].
	^ newObject! !

!Set methodsFor: 'adding' stamp: 'sma 5/12/2000 17:29'!
add: newObject withOccurrences: anInteger
	^ self add: newObject! !


!Set methodsFor: 'converting' stamp: 'ar 11/20/1998 16:34'!
asSet
	^self! !


!Set methodsFor: 'copying' stamp: 'sma 5/12/2000 14:54'!
copy
	^ self shallowCopy withArray: array shallowCopy! !


!Set methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:49'!
collect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Collect the resulting values into a collection like the receiver. Answer  
	the new collection."

	| newSet |
	newSet _ Set new: self size.
	array do: [:each | each ifNotNil: [newSet add: (aBlock value: each)]].
	^ newSet! !

!Set methodsFor: 'enumerating' stamp: 'sma 5/12/2000 14:36'!
do: aBlock 
	tally = 0 ifTrue: [^ self].
	1 to: array size do:
		[:index |
		| each |
		(each _ array at: index) ifNotNil: [aBlock value: each]]! !

!Set methodsFor: 'enumerating'!
doWithIndex: aBlock2
	"Support Set enumeration with a counter, even though not ordered"
	| index |
	index _ 0.
	self do: [:item | aBlock2 value: item value: (index _ index+1)]! !

!Set methodsFor: 'enumerating' stamp: 'jcg 6/7/2003 02:01'!
union: aCollection
	"Answer the set theoretic union of the receiver and aCollection, using the receiver's notion of equality and not side effecting the receiver at all."

	^ self copy addAll: aCollection; yourself

! !


!Set methodsFor: 'explorer' stamp: 'hg 9/7/2001 11:51'!
explorerContents 

	^self asOrderedCollection withIndexCollect: [:each :index |
		ObjectExplorerWrapper
			with: each
			name: index printString
			model: self]! !

!Set methodsFor: 'explorer' stamp: 'hg 9/7/2001 11:51'!
hasContentsInExplorer

	^self isEmpty not! !


!Set methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 13:05'!
comeFullyUpOnReload: smartRefStream
	"Symbols have new hashes in this image."

	self rehash.
	"^ self"
! !


!Set methodsFor: 'removing' stamp: 'sma 5/12/2000 14:45'!
copyWithout: oldElement 
	"Answer a copy of the receiver that does not contain any
	elements equal to oldElement."

	^ self copy
		remove: oldElement ifAbsent: [];
		yourself! !

!Set methodsFor: 'removing'!
remove: oldObject ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: oldObject.
	(array at: index) == nil ifTrue: [ ^ aBlock value ].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ oldObject! !


!Set methodsFor: 'testing' stamp: 'tk 11/8/2001 15:35'!
= aSet
	self == aSet ifTrue: [^ true].	"stop recursion"
	(aSet isKindOf: Set) ifFalse: [^ false].
	self size = aSet size ifFalse: [^ false].
	self do: [:each | (aSet includes: each) ifFalse: [^ false]].
	^ true! !

!Set methodsFor: 'testing'!
includes: anObject 
	^ (array at: (self findElementOrNil: anObject)) ~~ nil! !

!Set methodsFor: 'testing' stamp: 'sma 5/12/2000 14:46'!
occurrencesOf: anObject 
	^ (self includes: anObject) ifTrue: [1] ifFalse: [0]! !


!Set methodsFor: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:33'!
inspectorClass 
	"Answer the class of the inspector to be used on the receiver.  Called by inspect; 
	use basicInspect to get a normal (less useful) type of inspector."

	^ SetInspector! !


!Set methodsFor: 'private'!
array
	^ array! !

!Set methodsFor: 'private'!
atNewIndex: index put: anObject
	array at: index put: anObject.
	tally _ tally + 1.
	self fullCheck! !

!Set methodsFor: 'private' stamp: 'SqR 8/23/2000 14:39'!
findElementOrNil: anObject
	"Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found."

	| index |

	index _ self scanFor: anObject.
	index > 0 ifTrue: [^index].

	"Bad scene.  Neither have we found a matching element
	nor even an empty slot.  No hashed set is ever supposed to get
	completely full."
	self error: 'There is no free space in this set!!'.! !

!Set methodsFor: 'private' stamp: 'SqR 8/23/2000 14:28'!
fixCollisionsFrom: index
	"The element at index has been removed and replaced by nil.
	This method moves forward from there, relocating any entries
	that had been placed below due to collisions with this one"

	| length oldIndex newIndex element |

	oldIndex _ index.
	length _ array size.
	[oldIndex = length
			ifTrue: [oldIndex _ 1]
			ifFalse: [oldIndex _ oldIndex + 1].
	(element _ self keyAt: oldIndex) == nil]
		whileFalse: 
			[newIndex _ self findElementOrNil: element.
			oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! !

!Set methodsFor: 'private' stamp: 'di 11/4/97 20:11'!
fullCheck
	"Keep array at least 1/4 free for decent hash behavior"
	array size - tally < (array size // 4 max: 1)
		ifTrue: [self grow]! !

!Set methodsFor: 'private'!
grow
	"Grow the elements array and reinsert the old elements"
	| oldElements |
	oldElements _ array.
	array _ Array new: array size + self growSize.
	tally _ 0.
	oldElements do:
		[:each | each == nil ifFalse: [self noCheckAdd: each]]! !

!Set methodsFor: 'private'!
growSize
	^ array size max: 2! !

!Set methodsFor: 'private' stamp: 'nice 4/4/2006 22:09'!
initialize: n
	"Initialize array to an array size of n"
	array _ Array new: n.
	tally _ 0! !

!Set methodsFor: 'private'!
keyAt: index
	"May be overridden by subclasses so that fixCollisions will work"
	^ array at: index! !

!Set methodsFor: 'private'!
noCheckAdd: anObject
	array at: (self findElementOrNil: anObject) put: anObject.
	tally _ tally + 1! !

!Set methodsFor: 'private'!
rehash
	| newSelf |
	newSelf _ self species new: self size.
	self do: [:each | newSelf noCheckAdd: each].
	array _ newSelf array! !

!Set methodsFor: 'private' stamp: 'md 10/5/2005 15:44'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	finish _ array size.
	start _ (anObject hash \\ finish) + 1.
	
	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!Set methodsFor: 'private'!
swap: oneIndex with: otherIndex
	"May be overridden by subclasses so that fixCollisions will work"

	array swap: oneIndex with: otherIndex
! !

!Set methodsFor: 'private'!
withArray: anArray
	"private -- for use only in copy"
	array _ anArray! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Set class
	instanceVariableNames: ''!

!Set class methodsFor: 'initialization' stamp: 'SqR 8/3/2000 13:19'!
quickRehashAllSets  "Set rehashAllSets"
	| insts |
	self withAllSubclassesDo:
		[:c |
			insts _ c allInstances.
			(insts isEmpty or: [c = MethodDictionary]) ifFalse:
			['Rehashing instances of ' , c name
				displayProgressAt: Sensor cursorPoint
				from: 1 to: insts size
				during: [:bar | 1 to: insts size do: [:x | bar value: x. (insts at: x) rehash]]
			]
		]! !

!Set class methodsFor: 'initialization' stamp: 'pmm 7/9/2006 11:48'!
rehashAllSets
	"Set rehashAllSets"	
	self withAllSubclassesDo: [ :setClass |
		| instances |
		instances := setClass allInstances.
		instances isEmpty ifFalse: [
			1 to: instances size do: [ :index |
				(instances at: index) rehash ] ] ]! !


!Set class methodsFor: 'instance creation' stamp: 'pmm 7/9/2006 11:46'!
new
	^ self basicNew initialize: 5! !

!Set class methodsFor: 'instance creation' stamp: 'nice 4/4/2006 22:10'!
new: nElements
	"Create a Set large enough to hold nElements without growing"
	^ super basicNew initialize: (self sizeFor: nElements)! !

!Set class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."
	| newCollection |
	newCollection _ self new: aCollection size.
	newCollection addAll: aCollection.
	^ newCollection
"
	Set newFrom: {1. 2. 3}
	{1. 2. 3} as: Set
"! !

!Set class methodsFor: 'instance creation'!
sizeFor: nElements
	"Large enough size to hold nElements with some slop (see fullCheck)"
	nElements <= 0 ifTrue: [^ 1].
	^ nElements+1*4//3! !
Inspector subclass: #SetInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!
!SetInspector commentStamp: '<historical>' prior: 0!
A verison of the Inspector specialized for inspecting Sets.  It displays the elements of the set like elements of an array.  Note that the indices, being phyical locations in the hash table, are not meaningful outside of the set.!


!SetInspector methodsFor: 'accessing' stamp: 'PHK 6/29/2004 14:50'!
fieldList
	object
		ifNil: [^ Set new].
	^ self baseFieldList
		, (object array
				withIndexCollect: [:each :i | each ifNotNil: [i printString]])
		  select: [:each | each notNil]! !


!SetInspector methodsFor: 'menu' stamp: 'PHK 6/30/2004 12:16'!
fieldListMenu: aMenu

	^ aMenu labels:
'inspect
copy name
objects pointing to this value
refresh view
remove
basic inspect'
	lines: #( 5 8)
	selections: #(inspectSelection copyName objectReferencesToSelection update removeSelection inspectBasic)
! !

!SetInspector methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'!
removeSelection
	(selectionIndex <= object class instSize) ifTrue: [^ self changed: #flash].
	object remove: self selection.
	selectionIndex := 0.
	contents := ''.
	self changed: #inspectObject.
	self changed: #fieldList.
	self changed: #selection.
	self changed: #selectionIndex.! !


!SetInspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
copyName
	"Copy the name of the current variable, so the user can paste it into the 
	window below and work with is. If collection, do (xxx at: 1)."
	| sel |
	self selectionIndex <= (2 + object class instSize)
		ifTrue: [super copyName]
		ifFalse: [sel := '(self array at: '
						, (String streamContents: 
							[:strm | self arrayIndexForSelection storeOn: strm]) , ')'.
			Clipboard clipboardText: sel asText]! !


!SetInspector methodsFor: 'selecting' stamp: 'PHK 6/29/2004 15:33'!
arrayIndexForSelection
	^ (self fieldList at: selectionIndex) asInteger! !

!SetInspector methodsFor: 'selecting' stamp: 'PHK 6/29/2004 15:38'!
replaceSelectionValue: anObject
	^ object array at: self arrayIndexForSelection put: anObject! !

!SetInspector methodsFor: 'selecting' stamp: 'PHK 6/29/2004 15:35'!
selection
	selectionIndex = 0 ifTrue: [^ ''].
	selectionIndex = 1 ifTrue: [^ object].
	selectionIndex = 2 ifTrue: [^ object longPrintString].
	(selectionIndex - 2) <= object class instSize
		ifTrue: [^ object instVarAt: selectionIndex - 2].

	^ object array at: self arrayIndexForSelection! !
ClassTestCase subclass: #SetTest
	instanceVariableNames: 'full empty'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Unordered'!
!SetTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Set. 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!


!SetTest methodsFor: 'running' stamp: 'GL 2/27/2006 21:30'!
setUp
	empty := Set new.
	full := Set with: 5 with: #abc! !

!SetTest methodsFor: 'running' stamp: 'md 4/16/2003 15:03'!
tearDown
	"I am called whenever your test ends. 
I am the place where you release the ressources"! !


!SetTest methodsFor: 'Sunit original tests' stamp: 'GL 2/28/2006 08:26'!
testAdd
	empty add: 5.
	self assert: (empty includes: 5).! !

!SetTest methodsFor: 'Sunit original tests' stamp: 'GL 2/28/2006 08:27'!
testGrow
	empty addAll: (1 to: 100).
	self assert: (empty size = 100).
			! !

!SetTest methodsFor: 'Sunit original tests' stamp: 'GL 2/28/2006 08:23'!
testIllegal
	self 
		should: [empty at: 5] raise: TestResult error.
	self 
		should: [empty at: 5 put: #abc] raise: TestResult error.
			! !

!SetTest methodsFor: 'Sunit original tests' stamp: 'GL 2/27/2006 21:42'!
testIncludes
	self assert: (full includes: 5).
	self assert: (full includes: #abc).
	self deny: (full includes: 3).
			! !

!SetTest methodsFor: 'Sunit original tests' stamp: 'GL 2/28/2006 08:27'!
testOccurrences
	self assert: ((empty occurrencesOf: 0) = 0).
	self assert: ((full occurrencesOf: 5) = 1).
	full add: 5.
	self assert: ((full occurrencesOf: 5) = 1).! !

!SetTest methodsFor: 'Sunit original tests' stamp: 'GL 3/8/2006 08:20'!
testRemove
	full remove: 5.
	self assert: (full includes: #abc).
	self deny: (full includes: 5).! !


!SetTest methodsFor: 'tests' stamp: 'GL 3/16/2006 10:36'!
testAddWithOccurences

	empty add: 2 withOccurrences: 3.
	self assert: (empty includes: 2).
	self assert: ((empty occurrencesOf: 2) = 1).! !

!SetTest methodsFor: 'tests' stamp: 'GL 3/16/2006 10:37'!
testAsSet
	"could be moved in Array or Collection"

	| newFull |
	newFull := #(#abc 5) asSet.
	newFull add: 5.
	self assert: (newFull = full).! !

!SetTest methodsFor: 'tests' stamp: 'GL 2/28/2006 09:25'!
testAtRandom
	| rand |
	rand := Random new.
	full add: 3.
	full add: 2.
	full add: 4.
	full add: 1.
	self assert: (full includes: (full atRandom: rand)).
	! !

!SetTest methodsFor: 'tests' stamp: 'GL 3/8/2006 09:09'!
testCollect
	| newFull result |
	newFull := Set withAll: (1 to: 10).
	result := newFull collect: [:each | each >= 1 ifTrue: [each] ifFalse: ['no']].
	self assert: (result = newFull).
	result := newFull collect: [:each | each >= 5 ifTrue: [each] ifFalse: ['no']].
	self assert: (result = ((Set withAll: (5 to: 10)) add: 'no'; yourself)).! !

!SetTest methodsFor: 'tests' stamp: 'GL 2/28/2006 09:46'!
testCopy
	| newFull |
	full add: 3.
	full add: 2.
	newFull := full copy.
	self assert: (full size = newFull size).
	self assert: ((full select: [:each | (newFull includes: each) not]) isEmpty).
	self assert: ((newFull select: [:each | (full includes: each) not]) isEmpty).! !

!SetTest methodsFor: 'tests' stamp: 'GL 3/8/2006 00:06'!
testCopyWithout
	| newFull |
	full add: 3.
	full add: 2.
	newFull := full copyWithout: 3.
	self assert: (newFull size = (full size - 1)).
	self deny: (newFull includes: 3).
	self assert: ((newFull select: [:each | (full includes: each) not]) isEmpty).
	self assert: ((full select: [:each | (newFull includes: each) not]) = (Set with: 3)).
	! !

!SetTest methodsFor: 'tests' stamp: 'GL 3/8/2006 09:23'!
testDo
	| newFull result |
	newFull := Set withAll: (1 to: 5).
	result := 0.
	newFull do: [:each | result := (result + each)].
	self assert: (result = 15).! !

!SetTest methodsFor: 'tests' stamp: 'GL 3/8/2006 09:55'!
testIntersection
	| newFull col |
	full add: 3; add: 2.
	col := full intersection: full.
	self assert: (full = col).

	newFull := Set with: 8 with: 9 with: #z.
	col := newFull intersection: full.
	self assert: (col isEmpty).
	
	newFull add: 5; add: #abc; add: 7.
	col := newFull intersection: full.
	self assert: ((full select: [:each | (newFull includes: each)]) = col).
	
	
	! !

!SetTest methodsFor: 'tests' stamp: 'GL 2/28/2006 09:07'!
testLike
	self assert: ((full like: 5) = 5).
	self assert: ((full like: 8) isNil).! !

!SetTest methodsFor: 'tests' stamp: 'GL 3/8/2006 08:27'!
testRemoveIfAbsent
	| result1 result2  |
	result1 := true.
	result2 := true.
	full remove: 8 ifAbsent: [ result1 := false ].
	self assert: (result1 = false).
	full remove: 5 ifAbsent: [ result2 := false ].
	self assert: (result2 = true).
	
	
	! !

!SetTest methodsFor: 'tests' stamp: 'GL 2/28/2006 09:51'!
testSize
	self assert: (empty size = 0).
	self assert: (full size = 2).
	empty add: 2.
	empty add: 1.
	full add: 2.
	self assert: (empty size = 2).
	self assert: (full size = 3).
	empty remove: 2.
	self assert: (empty size = 1).! !

!SetTest methodsFor: 'tests' stamp: 'GL 3/8/2006 00:50'!
testUnion
	| newFull col newCol |
	full add: 3.
	full add: 2.
	col := full union: full.
	self assert: (full = col).

	newFull := Set with: 8 with: 9 with: #z.
	col := newFull union: full.
	self assert: (col size = (full size + newFull size)).
	self assert: ((col select: [:each | (full includes: each) not]) = newFull).
	self assert: ((col select: [:each | (newFull includes: each) not]) = full).

	full add: 9.
	col := newFull union: full.
	newCol := newFull copy.
	newCol remove: 9.
	self assert: (col size = (full size + newFull size - 1)).
	self assert: ((col select: [:each | (full includes: each) not]) = newCol).
	newCol := full copy.
	newCol remove: 9.
	self assert: ((col select: [:each | (newFull includes: each) not]) = newCol).
	
	
	! !
ColorMappingCanvas subclass: #ShadowDrawingCanvas
	instanceVariableNames: 'shadowColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:14'!
shadowColor
	^shadowColor! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:14'!
shadowColor: aColor
	shadowColor _ aColor! !


!ShadowDrawingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:14'!
on: aCanvas
	myCanvas _ aCanvas.
	shadowColor _ Color black.! !


!ShadowDrawingCanvas methodsFor: 'testing' stamp: 'ar 8/8/2001 14:16'!
isShadowDrawing
	^true! !


!ShadowDrawingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:13'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle."
	rule = Form paint ifTrue:[
		^myCanvas
			stencil: aForm
			at: aPoint
			sourceRect: sourceRect
			color: shadowColor
	] ifFalse:[
		^myCanvas
			fillRectangle: (sourceRect translateBy: aPoint)
			color: shadowColor
	].! !

!ShadowDrawingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:14'!
mapColor: aColor
	aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..."
	^aColor isTransparent
		ifTrue:[aColor]
		ifFalse:[shadowColor]! !
Object subclass: #SharedPool
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Pools'!
!SharedPool commentStamp: '<historical>' prior: 0!
A shared pool represents a set of bindings which are accessible to all classes which import the pool in its 'pool dictionaries'. SharedPool is NOT a dictionary but rather a name space. Bindings are represented by 'class variables' - as long as we have no better way to represent them at least.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SharedPool class
	instanceVariableNames: ''!

!SharedPool class methodsFor: 'enumerating' stamp: 'tpr 12/14/2004 12:34'!
keysDo: aBlock
"A hopefully temporary fix for an issue arising from miss-spelled variable names in code being compiled. The correction code (see Class>possibleVariablesFor:continuedFrom: assumes that sharedPools are Dictionaries. The proper fix would involve making sure all pools are actually subclasses of SharedPool, which they are not currently."
	self bindingsDo:[:b|
		aBlock value: b key]! !


!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 17:46'!
bindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver"
	| aSymbol binding |
	aSymbol := varName asSymbol.

	"First look in classVar dictionary."
	binding := self classPool bindingOf: aSymbol.
	binding ifNotNil:[^binding].

	"Next look in shared pools."
	self sharedPools do:[:pool | 
		binding := pool bindingOf: aSymbol.
		binding ifNotNil:[^binding].
	].

	"subclassing and environment are not preserved"
	^nil! !

!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 20:33'!
bindingsDo: aBlock
	^self classPool bindingsDo: aBlock! !

!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 18:14'!
classBindingOf: varName
	"For initialization messages grant the regular scope"
	^super bindingOf: varName! !

!SharedPool class methodsFor: 'name lookup' stamp: 'tween 9/13/2004 10:10'!
hasBindingThatBeginsWith: aString
	"Answer true if the receiver has a binding that begins with aString, false otherwise"

	"First look in classVar dictionary."
	(self classPool hasBindingThatBeginsWith: aString) ifTrue:[^true].
	"Next look in shared pools."
	self sharedPools do:[:pool | 
		(pool hasBindingThatBeginsWith: aString) ifTrue: [^true]].
	^false! !

!SharedPool class methodsFor: 'name lookup' stamp: 'tpr 5/29/2003 18:12'!
includesKey: aName
	"does this pool include aName"
	^(self bindingOf: aName) notNil! !
Object subclass: #SharedQueue
	instanceVariableNames: 'contentsArray readPosition writePosition accessProtect readSynch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!SharedQueue commentStamp: '<historical>' prior: 0!
I provide synchronized communication of arbitrary objects between Processes. An object is sent by sending the message nextPut: and received by sending the message next. If no object has been sent when a next message is sent, the Process requesting the object will be suspended until one is sent.!


!SharedQueue methodsFor: 'accessing' stamp: 'bf 2/11/2006 15:17'!
flush
	"Throw out all pending contents"
	accessProtect critical: [
		"nil out flushed slots --bf 02/11/2006"
		contentsArray from: readPosition to: writePosition-1 put: nil.
		readPosition _ 1.
		writePosition _ 1.
		"Reset the read synchronization semaphore"
		readSynch initSignals].! !

!SharedQueue methodsFor: 'accessing' stamp: 'NS 6/18/2002 11:15'!
flushAllSuchThat: aBlock
	"Remove from the queue all objects that satisfy aBlock."
	| value newReadPos |
	accessProtect critical: [
		newReadPos _ writePosition.
		writePosition-1 to: readPosition by: -1 do:
			[:i | value _ contentsArray at: i.
			contentsArray at: i put: nil.
			(aBlock value: value) ifTrue: [
				"We take an element out of the queue, and therefore, we need to decrement 
				the readSynch signals"
				readSynch wait.
			] ifFalse: [
				newReadPos _ newReadPos - 1.
				contentsArray at: newReadPos put: value]].
		readPosition _ newReadPos].
	^value
! !

!SharedQueue methodsFor: 'accessing'!
next
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone. If no object has been sent, suspend the 
	requesting process until one is."

	| value |
	readSynch wait.
	accessProtect
		critical: [readPosition = writePosition
					ifTrue: 
						[self error: 'Error in SharedQueue synchronization'.
						 value _ nil]
					ifFalse: 
						[value _ contentsArray at: readPosition.
						 contentsArray at: readPosition put: nil.
						 readPosition _ readPosition + 1]].
	^value! !

!SharedQueue methodsFor: 'accessing' stamp: 'RAA 12/14/2000 10:25'!
nextOrNil
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone. If no object has been sent, answer <nil>."

	| value |

	accessProtect critical: [
		readPosition >= writePosition ifTrue: [
			value _ nil
		] ifFalse: [
			value _ contentsArray at: readPosition.
			contentsArray at: readPosition put: nil.
			readPosition _ readPosition + 1
		].
		readPosition >= writePosition ifTrue: [readSynch initSignals].
	].
	^value! !

!SharedQueue methodsFor: 'accessing' stamp: 'di 10/1/2001 20:58'!
nextOrNilSuchThat: aBlock
	"Answer the next object that satisfies aBlock, skipping any intermediate objects.
	If no object has been sent, answer <nil> and leave me intact.
	NOTA BENE:  aBlock MUST NOT contain a non-local return (^)."

	| value readPos |
	accessProtect critical: [
		value _ nil.
		readPos _ readPosition.
		[readPos < writePosition and: [value isNil]] whileTrue: [
			value _ contentsArray at: readPos.
			readPos _ readPos + 1.
			(aBlock value: value) ifTrue: [
				readPosition to: readPos - 1 do: [ :j |
					contentsArray at: j put: nil.
				].
				readPosition _ readPos.
			] ifFalse: [
				value _ nil.
			].
		].
		readPosition >= writePosition ifTrue: [readSynch initSignals].
	].
	^value
"===
q _ SharedQueue new.
1 to: 10 do: [ :i | q nextPut: i].
c _ OrderedCollection new.
[
	v _ q nextOrNilSuchThat: [ :e | e odd].
	v notNil
] whileTrue: [
	c add: {v. q size}
].
{c. q} explore
==="! !

!SharedQueue methodsFor: 'accessing'!
nextPut: value 
	"Send value through the receiver. If a Process has been suspended 
	waiting to receive a value through the receiver, allow it to proceed."

	accessProtect
		critical: [writePosition > contentsArray size
						ifTrue: [self makeRoomAtEnd].
				 contentsArray at: writePosition put: value.
				 writePosition _ writePosition + 1].
	readSynch signal.
	^value! !

!SharedQueue methodsFor: 'accessing' stamp: 'tpr 1/5/2005 18:22'!
peek
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone but do not remove it from the receiver. If 
	no object has been sent, return nil"

	| value |
	accessProtect
		critical: [readPosition >= writePosition
					ifTrue: [readPosition _ 1.
							writePosition _ 1.
							value _ nil]
					ifFalse: [value _ contentsArray at: readPosition]].
	^value! !

!SharedQueue methodsFor: 'accessing'!
size
	"Answer the number of objects that have been sent through the
	receiver and not yet received by anyone."

	^writePosition - readPosition! !


!SharedQueue methodsFor: 'testing'!
isEmpty
	"Answer whether any objects have been sent through the receiver and 
	not yet received by anyone."

	^readPosition = writePosition! !


!SharedQueue methodsFor: 'private' stamp: 'nice 4/4/2006 22:09'!
initialize: size

	contentsArray _ Array new: size.
	readPosition _ 1.
	writePosition _ 1.
	accessProtect _ Semaphore forMutualExclusion.
	readSynch _ Semaphore new! !

!SharedQueue methodsFor: 'private' stamp: 'bf 10/25/2005 15:33'!
makeRoomAtEnd
	| contentsSize |
	readPosition = 1
		ifTrue: [contentsArray _ contentsArray , (Array new: 10)]
		ifFalse: 
			[contentsSize _ writePosition - readPosition.
			"BLT direction ok for this. Lots faster!!!!!!!!!!!! SqR!!!! 4/10/2000 10:47"
			contentsArray
				replaceFrom: 1
				to: contentsSize
				with: contentsArray
				startingAt: readPosition.
			"nil out remainder --bf 10/25/2005"
			contentsArray
				from: contentsSize+1
				to: contentsArray size
				put: nil.
			readPosition _ 1.
			writePosition _ contentsSize + 1]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SharedQueue class
	instanceVariableNames: ''!

!SharedQueue class methodsFor: 'instance creation'!
new
	"Answer a new instance of SharedQueue that has 10 elements."

	^self new: 10! !

!SharedQueue class methodsFor: 'instance creation' stamp: 'nice 4/4/2006 22:10'!
new: anInteger 
	^super new initialize: anInteger! !
Stream subclass: #SharedQueue2
	instanceVariableNames: 'monitor items'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!SharedQueue2 commentStamp: 'ls 6/25/2005 13:48' prior: 0!
An implementation of a shared queue based on class Monitor.  Clients may may place items on the queue using nextPut: or remove them using methods like next or nextOrNil.  Items are removed in first-in first-out (FIFO) order.  It is safe for multiple threads to access the same shared queue, which is why this is a "shared" queue.

[monitor] is used to synchronize access from multiple threads.

[items] is an ordered collection holding the items that are in the queue.  New items are added  at the end, and old items are removed from the beginning.

All methods must hold the monitor while they run.
!


!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 14:00'!
next
	^monitor critical: [
		monitor waitUntil: [ items isEmpty not ].
		items removeFirst ]
! !

!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 14:00'!
nextOrNil
	^monitor critical: [
		items isEmpty ifTrue: [ nil ] ifFalse: [ items removeFirst ] ]! !

!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 14:16'!
nextOrNilSuchThat: aBlock
	"Answer the next object that satisfies aBlock, skipping any intermediate objects.
	If no such object has been queued, answer <nil> and leave me intact."

	| index |
	^monitor critical: [
		index _ items findFirst: aBlock.
		index = 0 ifTrue: [
			nil ]
		ifFalse: [
			items removeAt: index ] ].
! !

!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 13:58'!
nextPut: item
	monitor critical: [
		items addLast: item.
		monitor signalAll.  ]
! !

!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 14:00'!
peek
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone but do not remove it from the receiver. If 
	no object has been sent, return nil"
	^monitor critical: [
		items isEmpty ifTrue: [ nil ] ifFalse: [ items first ] ]
! !


!SharedQueue2 methodsFor: 'initializing' stamp: 'ls 6/25/2005 13:48'!
initialize
	monitor _ Monitor new.
	items _ OrderedCollection new.
! !


!SharedQueue2 methodsFor: 'printing' stamp: 'ls 6/25/2005 13:56'!
printOn: aStream
	monitor critical: [
		aStream 
			nextPutAll: self class name;
			nextPutAll: ' with ';
			print: items size;
		 	nextPutAll: ' items' ].! !


!SharedQueue2 methodsFor: 'size' stamp: 'ls 6/25/2005 14:03'!
isEmpty
	^monitor critical: [ items isEmpty ]! !

!SharedQueue2 methodsFor: 'size' stamp: 'ls 6/25/2005 14:04'!
size
	^monitor critical: [ items size ]! !


!SharedQueue2 methodsFor: '*39Deprecated' stamp: 'ls 6/25/2005 14:07'!
flush
	self deprecated: 'use removeAll'.
	^self removeAll! !

!SharedQueue2 methodsFor: '*39Deprecated' stamp: 'ls 6/25/2005 14:02'!
flushAllSuchThat: aBlock
	self deprecated: 'use removeAllSuchThat:'.

	^self removeAllSuchThat: aBlock! !

!SharedQueue2 methodsFor: '*39Deprecated' stamp: 'ls 6/25/2005 14:03'!
removeAll
	monitor critical: [
		items next: (items size) ].! !

!SharedQueue2 methodsFor: '*39Deprecated' stamp: 'ls 6/25/2005 14:01'!
removeAllSuchThat: aBlock
	"Remove from the queue all objects that satisfy aBlock."
	monitor critical: [
		items removeAllSuchThat: aBlock ]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SharedQueue2 class
	instanceVariableNames: ''!

!SharedQueue2 class methodsFor: 'instance creation' stamp: 'ls 6/25/2005 13:53'!
new
	^self basicNew initialize! !
TestCase subclass: #SharedQueue2Test
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Sequenceable'!

!SharedQueue2Test methodsFor: 'testing' stamp: 'ls 6/25/2005 13:49'!
testBasics
	| q |
	q := SharedQueue2 new.

	self should: [ q nextOrNil = nil ].

	q nextPut: 5.
	self should: [ q nextOrNil = 5 ].
	self should: [ q nextOrNil = nil ].

! !

!SharedQueue2Test methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testContention1
	"here is a test case that breaks the standard SharedQueue from Squeak 3.8"

	| q r1 r2 |
	q := SharedQueue2 new.
	q nextPut: 5.
	q nextPut: 10.

	self should: [ q nextOrNil = 5 ].

	[ r1 := q next ] fork.
	[ r2 := q next ] fork.
	Processor  yield.   "let the above two threads block"
	
	q nextPut: 10.
	Processor yield.

	self should: [ r1 = 10 ].
	self should: [ r2 = 10 ].
	self should: [ q nextOrNil = nil ].
! !

!SharedQueue2Test methodsFor: 'testing' stamp: 'ls 6/25/2005 14:15'!
testNextOrNilSuchThat
	| q item |
	q := SharedQueue2 new.
	q nextPut: 5.
	q nextPut: 6.

	item := q nextOrNilSuchThat: [ :x | x even ].
	self should: [ item = 6 ].

	self should: [ q nextOrNil = 5 ].
	self should: [ q nextOrNil = nil ].
! !
TextConverter subclass: #ShiftJISTextConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!ShiftJISTextConverter commentStamp: '<historical>' prior: 0!
Text converter for Shift-JIS.  Mac and Windows in Japanese mode use this encoding.!


!ShiftJISTextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:31'!
nextFromStream: aStream 
	| character1 character2 value1 value2 char1Value result |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	char1Value _ character1 asciiValue.
	(char1Value < 16r81) ifTrue: [^ character1].
	(char1Value > 16rA0 and: [char1Value < 16rE0]) ifTrue: [^ self katakanaValue: char1Value].

	character2 _ aStream basicNext.
	character2 = nil ifTrue: [^ nil "self errorMalformedInput"].
	value1 _ character1 asciiValue.
	character1 asciiValue >= 224 ifTrue: [value1 _ value1 - 64].
	value1 _ value1 - 129 bitShift: 1.
	value2 _ character2 asciiValue.
	character2 asciiValue >= 128 ifTrue: [value2 _ value2 - 1].
	character2 asciiValue >= 158 ifTrue: [
		value1 _ value1 + 1.
		value2 _ value2 - 158
	] ifFalse: [value2 _ value2 - 64].
	result _ Character leadingChar: self leadingChar code: value1 * 94 + value2.
	^ self toUnicode: result
! !

!ShiftJISTextConverter methodsFor: 'conversion' stamp: 'ar 4/12/2005 14:10'!
nextPut: aCharacter toStream: aStream 
	| value leadingChar aChar |
	aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream].
	aCharacter isTraditionalDomestic ifTrue: [	
		aChar _ aCharacter.
		value _ aCharacter charCode.
	] ifFalse: [
		value _ aCharacter charCode.
		(16rFF61 <= value and: [value <= 16rFF9F]) ifTrue: [
			aStream basicNextPut: (self sjisKatakanaFor: value).
			^ aStream
		].
		aChar _ JISX0208 charFromUnicode: value.
		aChar ifNil: [^ aStream].
		value _ aChar charCode.
	].
	leadingChar _ aChar leadingChar.
	leadingChar = 0 ifTrue: [
		aStream basicNextPut: (Character value: value).
		^ aStream.
	].
	leadingChar == self leadingChar ifTrue: [
		| upper lower | 
		upper _ value // 94 + 33.
		lower _ value \\ 94 + 33.
		upper \\ 2 == 1 ifTrue: [
			upper _ upper + 1 / 2 + 112.
			lower _ lower + 31
		] ifFalse: [
			upper _ upper / 2 + 112.
			lower _ lower + 125
		].
		upper >= 160 ifTrue: [upper _ upper + 64].
		lower >= 127 ifTrue: [lower _ lower + 1].
		aStream basicNextPut: (Character value: upper).
		aStream basicNextPut: (Character value: lower).
		^ aStream
	].
! !


!ShiftJISTextConverter methodsFor: 'friend' stamp: 'yo 10/23/2002 15:28'!
leadingChar

	^ JISX0208 leadingChar
! !


!ShiftJISTextConverter methodsFor: 'private' stamp: 'ar 4/9/2005 22:31'!
katakanaValue: code

	^ Character leadingChar: JapaneseEnvironment leadingChar code: (#(
	16rFFFD 16rFF61 16rFF62 16rFF63 16rFF64 16rFF65 16rFF66 16rFF67
	16rFF68 16rFF69 16rFF6A 16rFF6B 16rFF6C 16rFF6D 16rFF6E 16rFF6F
	16rFF70 16rFF71 16rFF72 16rFF73 16rFF74 16rFF75 16rFF76 16rFF77
	16rFF78 16rFF79 16rFF7A 16rFF7B 16rFF7C 16rFF7D 16rFF7E 16rFF7F
	16rFF80 16rFF81 16rFF82 16rFF83 16rFF84 16rFF85 16rFF86 16rFF87
	16rFF88 16rFF89 16rFF8A 16rFF8B 16rFF8C 16rFF8D 16rFF8E 16rFF8F
	16rFF90 16rFF91 16rFF92 16rFF93 16rFF94 16rFF95 16rFF96 16rFF97
	16rFF98 16rFF99 16rFF9A 16rFF9B 16rFF9C 16rFF9D 16rFF9E 16rFF9F
) at: (code - 16r9F)).
! !

!ShiftJISTextConverter methodsFor: 'private' stamp: 'yo 3/1/2004 22:05'!
sjisKatakanaFor: value

	^ Character value: (#(
		16rA0 16rA1 16rA2 16rA3 16rA4 16rA5 16rA6 16rA7
		16rA8 16rA9 16rAA 16rAB 16rAC 16rAD 16rAE 16rAF
		16rB0 16rB1 16rB2 16rB3 16rB4 16rB5 16rB6 16rB7
		16rB8 16rB9 16rBA 16rBB 16rBC 16rBD 16rBE 16rBF
		16rC0 16rC1 16rC2 16rC3 16rC4 16rC5 16rC6 16rC7
		16rC8 16rC9 16rCA 16rCB 16rCC 16rCD 16rCE 16rCF
		16rD0 16rD1 16rD2 16rD3 16rD4 16rD5 16rD6 16rD7
		16rD8 16rD9 16rDA 16rDB 16rDC 16rDD 16rDE 16rDF
	) at: value - 16rFF5F).

! !

!ShiftJISTextConverter methodsFor: 'private' stamp: 'ar 4/9/2005 22:31'!
toUnicode: aChar

	^ Character leadingChar: JapaneseEnvironment leadingChar code: aChar asUnicode.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ShiftJISTextConverter class
	instanceVariableNames: ''!

!ShiftJISTextConverter class methodsFor: 'utilities' stamp: 'yo 12/25/2003 21:33'!
encodingNames 

	^ #('shift-jis' 'shift_jis' 'sjis') copy
! !
ArrayedCollection variableWordSubclass: #ShortIntegerArray
	instanceVariableNames: ''
	classVariableNames: 'LastSaveOrder'
	poolDictionaries: ''
	category: 'Balloon-Collections'!
!ShortIntegerArray commentStamp: '<historical>' prior: 0!
ShortIntegerArray is an array for efficiently representing integers in the 16bit range.!


!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'!
at: index
	"Return the 16-bit integer value at the given index of the receiver."

	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber ifTrue: [^ self at: index truncated].
	self errorNonIntegerIndex.
! !

!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'!
at: index put: value
	"Store the given 16-bit integer at the given index in the receiver."

	<primitive: 144>
	index isInteger
		ifTrue: [
			(index >= 1 and: [index <= self size])
				ifTrue: [self errorImproperStore]
				ifFalse: [self errorSubscriptBounds: index]].
	index isNumber ifTrue: [^ self at: index truncated put: value].
	self errorNonIntegerIndex.
! !

!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'!
defaultElement
	^0! !

!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'!
size
	^super size * 2! !


!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:11'!
bytesPerBasicElement
	^4! !

!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/7/2004 13:54'!
bytesPerElement
	^2! !

!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:41'!
restoreEndianness
	"This word object was just read in from a stream.  It was stored in Big Endian (Mac) format.  Swap each pair of bytes (16-bit word), if the current machine is Little Endian.
	Why is this the right thing to do?  We are using memory as a byteStream.  High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory.  Different from a Bitmap."

	| hack blt |
	SmalltalkImage current  isLittleEndian ifTrue: [
		"The implementation is a hack, but fast for large ranges"
		hack := Form new hackBits: self.
		blt := (BitBlt toForm: hack) sourceForm: hack.
		blt combinationRule: Form reverse.  "XOR"
		blt sourceY: 0; destY: 0; height: hack height; width: 1.
		blt sourceX: 0; destX: 1; copyBits.  "Exchange bytes 0 and 1"
		blt sourceX: 1; destX: 0; copyBits.
		blt sourceX: 0; destX: 1; copyBits.
		blt sourceX: 2; destX: 3; copyBits.  "Exchange bytes 2 and 3"
		blt sourceX: 3; destX: 2; copyBits.
		blt sourceX: 2; destX: 3; copyBits
	].
! !

!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:55'!
writeOn: aStream 

	aStream nextInt32Put: self basicSize.

	1 to: self basicSize do: [ :i | | w |
		w := self basicAt: i.
		SmalltalkImage current  isLittleEndian
			ifFalse: [ aStream nextNumber: 4 put:  w ]
			ifTrue: [ aStream
				nextPut: (w digitAt: 2);
				nextPut: (w digitAt: 1);
				nextPut: (w digitAt: 4);
				nextPut: (w digitAt: 3) ]].! !


!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:35'!
pvtAt: index
	"Private -- for swapping only"
	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber ifTrue: [^ self at: index truncated].
	self errorNonIntegerIndex.
! !

!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:35'!
pvtAt: index put: value
	"Private -- for swapping only"
	<primitive: 144>
	index isInteger
		ifTrue: [
			(index >= 1 and: [index <= self size])
				ifTrue: [self errorImproperStore]
				ifFalse: [self errorSubscriptBounds: index]].
	index isNumber ifTrue: [^ self at: index truncated put: value].
	self errorNonIntegerIndex.
! !

!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:37'!
swapShortObjects
	"Private -- swap all the short quantities in the receiver"
	| tmp |
	1 to: self basicSize do:[:i|
		tmp := (self pvtAt: i * 2).
		self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1).
		self pvtAt: i * 2 - 1 put: tmp.
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ShortIntegerArray class
	instanceVariableNames: ''!

!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'bf 1/7/2005 16:39'!
initialize
	"ShortIntegerArray initialize"
	Smalltalk addToStartUpList: self after: Delay.
	LastSaveOrder := self new: 2.
	LastSaveOrder at: 1 put: 42.
	LastSaveOrder at: 2 put: 13.! !

!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'ar 1/15/1999 17:33'!
startUp
	"Check if the word order has changed from the last save"
	((LastSaveOrder at: 1) = 42 and:[(LastSaveOrder at: 2) = 13]) 
		ifTrue:[^self]. "Okay"
	((LastSaveOrder at: 2) = 42 and:[(LastSaveOrder at: 1) = 13]) 
		ifTrue:[^self swapShortObjects]. "Reverse guys"
	^self error:'This must never happen'! !

!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'sd 9/30/2003 13:46'!
startUpFrom: anImageSegment
	"In this case, do we need to swap word halves when reading this segement?"

	^ (SmalltalkImage current  endianness) ~~ (anImageSegment endianness)
			ifTrue: [Message selector: #swapShortObjects]		"will be run on each instance"
			ifFalse: [nil].
! !

!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'ar 1/15/1999 17:40'!
swapShortObjects
	self allSubInstancesDo:[:inst| inst swapShortObjects]! !


!ShortIntegerArray class methodsFor: 'instance creation' stamp: 'ar 1/15/1999 17:28'!
new: n
	^super new: n + 1 // 2! !
ShortIntegerArray variableWordSubclass: #ShortPointArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Collections'!
!ShortPointArray commentStamp: '<historical>' prior: 0!
This class stores points that are in short integer range (e.g., -32767 <= value <= 32768). It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.!


!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'!
at: index
	"Return the element (e.g., point) at the given index"
	^(super at: index * 2 - 1) @ (super at: index * 2)! !

!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'!
at: index put: aPoint
	"Store the argument aPoint at the given index"
	super at: index * 2 - 1 put: aPoint x asInteger.
	super at: index * 2 put: aPoint y asInteger.
	^aPoint! !

!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/10/1998 19:41'!
bounds
	| min max |
	min := max := self at: 1.
	self do:[:pt|
		min := min min: pt.
		max := max max: pt].
	^min corner: max
		! !

!ShortPointArray methodsFor: 'accessing' stamp: 'yo 3/6/2004 12:56'!
bytesPerElement

	^ 4.
	! !

!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'!
defaultElement
	"Return the default element of the receiver"
	^0@0! !

!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'!
size
	^self basicSize! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ShortPointArray class
	instanceVariableNames: ''!

!ShortPointArray class methodsFor: 'instance creation' stamp: 'ar 1/15/1999 17:40'!
new: n
	^super new: n * 2! !
ArrayedCollection variableWordSubclass: #ShortRunArray
	instanceVariableNames: ''
	classVariableNames: 'LastSaveOrder'
	poolDictionaries: ''
	category: 'Balloon-Collections'!
!ShortRunArray commentStamp: '<historical>' prior: 0!
This class is run-length encoded representation of short integer (e.g., 16bit signed integer values)!


!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:26'!
at: index
	"Return the short value at the given index"
	| rlIndex |
	index < 1 ifTrue:[^self errorSubscriptBounds: index].
	rlIndex := index.
	self lengthsAndValuesDo:[:runLength :runValue|
		rlIndex <= runLength ifTrue:[^runValue].
		rlIndex := rlIndex - runLength].
	"Not found. Must be out of range"
	^self errorSubscriptBounds: index! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:18'!
at: index put: value
	"ShortRunArrays are read-only"
	^self shouldNotImplement.! !

!ShortRunArray methodsFor: 'accessing' stamp: 'yo 3/6/2004 14:19'!
bytesPerElement

	^ 4
! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:39'!
compressionRatio
	"Return the compression ratio.
	The compression ratio is computed based
	on how much space would be needed to
	store the receiver in a ShortIntegerArray"
	^(self size asFloat * 0.5) "Would need only half of the amount in ShortIntegerArray"
		/ (self runSize max: 1)! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:21'!
lengthAtRun: index
	"Return the length of the run starting at the given index"
	^(self basicAt: index) bitShift: -16! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:28'!
runSize
	"Return the number of runs in the receiver"
	^self basicSize! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:28'!
size
	"Return the number of elements stored in the receiver"
	| n |
	n := 0.
	"Note: The following loop is open-coded for speed"
	1 to: self basicSize do:[:i|
		n := n + ((self basicAt: i) bitShift: -16).
	].
	^n! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:29'!
species
	"Answer the preferred class for reconstructing the receiver."
	^ShortIntegerArray! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:22'!
valueAtRun: index
	"Return the value of the run starting at the given index"
	| uShort |
	uShort := (self basicAt: index) bitAnd: 16rFFFF.
	^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)! !


!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/3/1998 17:31'!
do: aBlock
	"Evaluate aBlock with all elements of the receiver"
	self lengthsAndValuesDo:[:runLength :runValue|
		"Use to:do: instead of timesRepeat: for compiler optimization"
		1 to: runLength do:[:i|
			aBlock value: runValue.
		].
	].! !

!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:44'!
lengthsAndValuesDo: aBlock
	"Evaluate aBlock with the length and value of each run in the receiver"
	^self runsAndValuesDo: aBlock! !

!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:44'!
runsAndValuesDo: aBlock
	"Evaluate aBlock with the length and value of each run in the receiver"
	| basicValue length value |
	1 to: self basicSize do:[:i|
		basicValue := self basicAt: i.
		length := basicValue bitShift: -16.
		value := basicValue bitAnd: 16rFFFF.
		value := (value bitAnd: 16r7FFF) - (value bitAnd: 16r8000).
		aBlock value: length value: value.
	].! !

!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/3/1998 21:05'!
valuesCollect: aBlock
	"Evaluate aBlock with each of the receiver's values as the argument. 
	Collect the resulting values into a collection like the receiver. Answer 
	the new collection."
	| newArray newValue |
	newArray := self class basicNew: self basicSize.
	1 to: self runSize do:[:i|
		newValue := aBlock value: (self valueAtRun: i).
		newArray setRunAt: i toLength: (self lengthAtRun: i) value: newValue.
	].
	^newArray! !

!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/15/1998 17:22'!
valuesDo: aBlock
	self lengthsAndValuesDo:[:runLength :runValue| aBlock value: runValue]! !


!ShortRunArray methodsFor: 'objects from disk' stamp: 'yo 3/6/2004 15:10'!
restoreEndianness
	"This word object was just read in from a stream.  It was stored in Big Endian (Mac) format.  Swap each pair of bytes (16-bit word), if the current machine is Little Endian.
	Why is this the right thing to do?  We are using memory as a byteStream.  High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory.  Different from a Bitmap."

	| w b1 b2 b3 b4 |
	SmalltalkImage current  isLittleEndian ifTrue: [
		1 to: self basicSize do: [:i |
			w := self basicAt: i.
			b1 := w digitAt: 1.
			b2 := w digitAt: 2.
			b3 := w digitAt: 3.
			b4 := w digitAt: 4.
			w := (b1 << 24) + (b2 << 16) + (b3 << 8) + b4.
			self basicAt: i put: w.
		]
	].

! !


!ShortRunArray methodsFor: 'printing' stamp: 'ar 11/3/1998 17:41'!
printOn: aStream
	aStream nextPutAll: self class name; nextPutAll:' ( '.
	self lengthsAndValuesDo:[:runLength :runValue |
		aStream
			nextPutAll:' (';
			print: runLength;
			space;
			print: runValue;
			nextPut:$).
	].
	aStream nextPutAll:' )'.! !


!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:47'!
pvtAt: index
	"Private -- for swapping only"
	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber ifTrue: [^ self at: index truncated].
	self errorNonIntegerIndex.
! !

!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:47'!
pvtAt: index put: value
	"Private -- for swapping only"
	<primitive: 144>
	index isInteger
		ifTrue: [
			(index >= 1 and: [index <= self size])
				ifTrue: [self errorImproperStore]
				ifFalse: [self errorSubscriptBounds: index]].
	index isNumber ifTrue: [^ self at: index truncated put: value].
	self errorNonIntegerIndex.
! !

!ShortRunArray methodsFor: 'private' stamp: 'ar 11/3/1998 21:02'!
setRunAt: i toLength: runLength value: value
	(value < -16r7FFF or:[value > 16r8000]) ifTrue:[^self errorImproperStore].
	(runLength < 0 or:[runLength > 16rFFFF]) ifTrue:[^self errorImproperStore].
	self basicAt: i put: (runLength bitShift: 16) + 
		((value bitAnd: 16r7FFF) - (value bitAnd: -16r8000)).! !

!ShortRunArray methodsFor: 'private' stamp: 'ar 11/3/1998 21:00'!
setRuns: runArray values: valueArray
	| runLength value |
	1 to: runArray size do:[:i|
		runLength := runArray at: i.
		value := valueArray at: i.
		self setRunAt: i toLength: runLength value: value.
	].! !

!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:48'!
swapRuns
	"Private -- swap length/value pairs in the receiver"
	| tmp |
	1 to: self basicSize do:[:i|
		tmp := (self pvtAt: i * 2).
		self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1).
		self pvtAt: i * 2 - 1 put: tmp.
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ShortRunArray class
	instanceVariableNames: ''!

!ShortRunArray class methodsFor: 'class initialization' stamp: 'bf 1/7/2005 16:40'!
initialize
	"ShortRunArray initialize"
	Smalltalk addToStartUpList: self after: Delay.
	LastSaveOrder := #(42 42 42) as: self.! !

!ShortRunArray class methodsFor: 'class initialization' stamp: 'ar 1/15/1999 17:46'!
startUp
	"Check if the word order has changed from the last save"
	((LastSaveOrder valueAtRun: 1) = 42 and:[(LastSaveOrder lengthAtRun: 1) = 3]) 
		ifTrue:[^self]. "Okay"
	((LastSaveOrder lengthAtRun: 1) = 42 and:[(LastSaveOrder valueAtRun: 1) = 3]) 
		ifTrue:[^self swapRuns]. "Reverse guys"
	^self error:'This must never happen'! !

!ShortRunArray class methodsFor: 'class initialization' stamp: 'nk 2/22/2005 15:29'!
startUpFrom: anImageSegment 
	"In this case, do we need to swap word halves when reading this segement?"

	^SmalltalkImage current endianness ~~ anImageSegment endianness 
		ifTrue: [Message selector: #swapRuns	"will be run on each instance"]
		ifFalse: [nil]! !

!ShortRunArray class methodsFor: 'class initialization' stamp: 'ar 1/15/1999 17:47'!
swapRuns
	self allSubInstancesDo:[:inst| inst swapRuns]! !


!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:12'!
new: n
	"ShortRunArrays must be created with either
		someCollection as: ShortRunArray
	or by using
		ShortRunArray runs: runCollection values: valueCollection.
	"
	^self shouldNotImplement! !

!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:35'!
newFrom: aCollection
	"Compress aCollection into a ShortRunArray"
	| lastValue lastRun runs values |
	aCollection isEmpty ifTrue:[^self runs:#() values: #()].
	runs := WriteStream on: (WordArray new: 100).
	values := WriteStream on: (ShortIntegerArray new: 100).
	lastValue := aCollection first.
	lastRun := 0.
	aCollection do:[:item|
		(item = lastValue and:[lastRun < 16r8000]) ifTrue:[
			lastRun := lastRun + 1.
		] ifFalse:[
			runs nextPut: lastRun.
			values nextPut: lastValue.
			lastRun := 1.
			lastValue := item.
		].
	].
	runs nextPut: lastRun.
	values nextPut: lastValue.
	^self runs: runs contents values: values contents! !

!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:12'!
runs: runCollection values: valueCollection
	^(self basicNew: runCollection size) setRuns: runCollection values: valueCollection! !
TextMorph subclass: #ShowEmptyTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!
!ShowEmptyTextMorph commentStamp: '<historical>' prior: 0!
A slight modification on TextMorph to show empty fields just as one would fields with data: with a cursor and without the pink field!


!ShowEmptyTextMorph methodsFor: 'drawing' stamp: 'RAA 2/6/2001 14:09'!
drawOn: aCanvas
	self setDefaultContentsIfNil.
	aCanvas paragraph: self paragraph bounds: bounds color: color.
! !
BorderStyle subclass: #SimpleBorder
	instanceVariableNames: 'baseColor color width'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Borders'!
!SimpleBorder commentStamp: 'kfr 10/27/2003 10:17' prior: 0!
see BorderedMorph!


!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:19'!
baseColor
	^baseColor ifNil:[Color transparent]! !

!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:23'!
baseColor: aColor
	| cc |
	cc _ aColor isTransparent ifTrue:[nil] ifFalse:[aColor].
	baseColor = cc ifTrue:[^self].
	baseColor _ cc.
	self releaseCachedState.
	self color: cc.
! !

!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:09'!
bottomRightColor
	^color! !

!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:19'!
color
	^color ifNil:[Color transparent]! !

!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:10'!
color: aColor
	color = aColor ifTrue:[^self].
	color _ aColor.
	self releaseCachedState.! !

!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:52'!
style
	^#simple! !

!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:09'!
topLeftColor
	^color! !

!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:35'!
width
	^width! !

!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:10'!
width: aNumber
	width = aNumber ifTrue:[^self].
	width _ aNumber truncated max: (width isPoint ifTrue:[0@0] ifFalse:[0]).
	self releaseCachedState.! !


!SimpleBorder methodsFor: 'drawing' stamp: 'aoy 2/17/2003 01:14'!
drawLineFrom: startPoint to: stopPoint on: aCanvas 
	| lineColor |
	lineColor := (stopPoint truncated quadrantOf: startPoint truncated) > 2 
				ifTrue: [self topLeftColor]
				ifFalse: [self bottomRightColor].
	aCanvas 
		line: startPoint
		to: stopPoint 
		width: self width
		color: lineColor! !

!SimpleBorder methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:27'!
frameRectangle: aRectangle on: aCanvas
	aCanvas frameAndFillRectangle: aRectangle
		fillColor: Color transparent
		borderWidth: self width
		topLeftColor: self topLeftColor
		bottomRightColor: self bottomRightColor.! !
SimpleButtonMorph subclass: #SimpleButtonDelayedMenuMorph
	instanceVariableNames: 'didMenu'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!SimpleButtonDelayedMenuMorph methodsFor: 'event handling' stamp: 'RAA 10/26/2000 12:19'!
handlesMouseStillDown: evt

	^true! !

!SimpleButtonDelayedMenuMorph methodsFor: 'event handling' stamp: 'nk 1/11/2004 12:35'!
mouseDown: evt

	didMenu _ nil.
	super mouseDown: evt.
! !

!SimpleButtonDelayedMenuMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:08'!
mouseStillDown: evt
	(mouseDownTime isNil or: [(Time millisecondClockValue - mouseDownTime) abs < 1000]) ifTrue: [
		^super mouseStillDown: evt
	].
	didMenu ifNotNil: [^super mouseStillDown: evt].
	self color: oldColor.		"in case menu never returns"
	didMenu _ target showMenuFor: actionSelector event: evt.
! !

!SimpleButtonDelayedMenuMorph methodsFor: 'event handling' stamp: 'RAA 7/5/2000 16:50'!
mouseUp: evt

	didMenu == true ifFalse: [^super mouseUp: evt].
	oldColor ifNotNil: [
		self color: oldColor.
		oldColor _ nil
	].! !
RectangleMorph subclass: #SimpleButtonMorph
	instanceVariableNames: 'target actionSelector arguments actWhen oldColor mouseDownTime'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!SimpleButtonMorph commentStamp: 'efc 3/7/2003 17:46' prior: 0!
I am labeled, rectangular morph which allows the user to click me. I can be configured to send my "target" the message "actionSelector" with "arguments" when I am clicked. I may have a label, implemented as a StringMorph.

Example:

	SimpleButtonMorph new
		target: Smalltalk;
		label: 'Beep!!';
		actionSelector: #beep; 
		openInWorld

Structure:
instance var 	Type		Description 
target 			Object 		The Object to notify upon a click 
actionSelector 	Symbol 		The message to send to Target (#messageName) 
arguments 		Array 		Arguments to send with #actionSelection (optional) 
actWhen 		Symbol 		When to take action: may be #buttonUp (default), #buttonDown,
								#whilePressed, or #startDrag 
oldColor 		Color 		Used to restore color after click 

Another example: a button which quits the image without saving it.

	SimpleButtonMorph new
		target: Smalltalk;
		label: 'quit';
		actionSelector: #snapshot:andQuit:;
		arguments: (Array with: false with: true); 
		openInWorld

!
]style[(209 11 13 101 13 31 12 6 54 6 61 5 65 6 114 5 107 158 2)f1,f1LStringMorph Comment;,f1,f1d	SimpleButtonMorph new
		target: Smalltalk;
		label: 'Beep!!';
		actionSelector: #beep; 
		openInWorld;;,f1,f1i,f1,f1LObject Comment;,f1,f1LSymbol Comment;,f1,f1LArray Comment;,f1,f1LSymbol Comment;,f1,f1LColor Comment;,f1,f1d	SimpleButtonMorph new
		target: Smalltalk;
		label: 'quit';
		actionSelector: #snapshot:andQuit:;
		arguments: (Array with: false with: true); 
		openInWorld;;,f1!


!SimpleButtonMorph methodsFor: 'accessing'!
actionSelector

	^ actionSelector
! !

!SimpleButtonMorph methodsFor: 'accessing'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!SimpleButtonMorph methodsFor: 'accessing'!
arguments

	^ arguments
! !

!SimpleButtonMorph methodsFor: 'accessing'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:57'!
fitContents
	| aMorph aCenter |
	aCenter := self center.
	submorphs isEmpty ifTrue: [^self].
	aMorph := submorphs first.
	self extent: aMorph extent + (borderWidth + 6).
	self center: aCenter.
	aMorph position: aCenter - (aMorph extent // 2)! !

!SimpleButtonMorph methodsFor: 'accessing'!
label

	| s |
	s _ ''.
	self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [s _ m contents]].
	^ s! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 12/7/1999 18:11'!
label: aString

	| oldLabel m |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	m _ StringMorph contents: aString font: TextStyle defaultFont.
	self extent: m extent + (borderWidth + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 12/10/1999 09:06'!
label: aString font: aFont

	| oldLabel m |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	m _ StringMorph contents: aString font: (aFont ifNil: [Preferences standardButtonFont]).
	self extent: (m width + 6) @ (m height + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock
! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 6/11/1999 18:40'!
labelString: aString

	| existingLabel |
	(existingLabel _ self findA: StringMorph)
		ifNil:
			[self label: aString]
		ifNotNil:
			[existingLabel contents: aString.
			self fitContents]
! !

!SimpleButtonMorph methodsFor: 'accessing'!
target

	^ target
! !

!SimpleButtonMorph methodsFor: 'accessing'!
target: anObject

	target _ anObject
! !


!SimpleButtonMorph methodsFor: 'button' stamp: 'dgd 2/22/2003 18:53'!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target notNil and: [actionSelector notNil]) 
		ifTrue: 
			[Cursor normal 
				showWhile: [target perform: actionSelector withArguments: arguments]].
	actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]! !


!SimpleButtonMorph methodsFor: 'copying' stamp: 'sw 2/15/98 03:49'!
recolor: c
	self color: c.
	oldColor _ c! !

!SimpleButtonMorph methodsFor: 'copying' stamp: 'tk 1/6/1999 17:55'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!SimpleButtonMorph methodsFor: 'copying' stamp: 'nk 1/23/2004 17:14'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		a Symbol"
"arguments _ arguments.		All weakly copied"
actWhen _ actWhen veryDeepCopyWith: deepCopier.
oldColor _ oldColor veryDeepCopyWith: deepCopier.
mouseDownTime _ nil.! !


!SimpleButtonMorph methodsFor: 'event handling' stamp: 'sw 8/16/97 22:10'!
handlesMouseDown: evt
	^  self isPartsDonor not
! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:15'!
handlesMouseStillDown: evt
	^actWhen == #whilePressed! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 21:36'!
mouseDown: evt

	super mouseDown: evt.
	evt yellowButtonPressed ifTrue: [ ^self ] .
	mouseDownTime _ Time millisecondClockValue.
	oldColor _ self fillStyle. 
	actWhen == #buttonDown
		ifTrue: [ self doButtonAction]
		ifFalse: [ self updateVisualState: evt ].
	self mouseStillDown: evt.! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:10'!
mouseMove: evt
	actWhen == #buttonDown ifTrue: [^ self].
	self updateVisualState: evt.! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:15'!
mouseStillDown: evt
	actWhen == #whilePressed ifFalse:[^self].
	(self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! !

!SimpleButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 03:33'!
mouseUp: evt
	super mouseUp: evt.
	oldColor ifNotNil:
		["if oldColor nil, it signals that mouse had not gone DOWN
		inside me, e.g. because of a cmd-drag; in this case we want
		to avoid triggering the action!!"
		self color: oldColor.
		oldColor _ nil.
		(self containsPoint: evt cursorPoint) 
				ifTrue: [ actWhen == #buttonUp 
							ifTrue: [self doButtonAction]  ]
				ifFalse: [ self mouseLeave: evt "This is a balk. Note that we have left." ]]
		
! !


!SimpleButtonMorph methodsFor: 'events-processing' stamp: 'nk 1/11/2004 13:25'!
mouseStillDownStepRate
	"Answer how often I want the #handleMouseStillDown: stepped"
	^200! !


!SimpleButtonMorph methodsFor: 'geometry' stamp: '6/7/97 10:53 di'!
extent: newExtent
	| label |
	super extent: newExtent.
	submorphs size = 1 ifTrue:
		["keep the label centered"
		"NOTE: may want to test more that it IS a label..."
		label _ self firstSubmorph.
		label position: self center - (label extent // 2)]! !


!SimpleButtonMorph methodsFor: 'initialization' stamp: 'di 6/5/2000 09:08'!
initialize

	self initializeAllButLabel; setDefaultLabel! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: 'jrp 7/28/2005 20:37'!
initializeAllButLabel

	super initialize.
	self borderWidth: 1.
	self color: (Color r: 0.4 g: 0.8 b: 0.6).
	self borderColor: self color darker.
	self borderStyle: BorderStyle thinGray.
	target _ nil.
	actionSelector _ #flash.
	arguments _ EmptyArray.
	actWhen _ #buttonUp
! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: 'di 6/5/2000 09:09'!
initializeWithLabel: labelString

	self initializeAllButLabel; label: labelString
! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: 'sw 9/28/1999 14:05'!
setDefaultLabel
	self label: 'Flash'.
! !


!SimpleButtonMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 20:06'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addLabelItemsTo: aCustomMenu hand: aHandMorph.
	(target isKindOf: BookMorph)
		ifTrue:
			[aCustomMenu add: 'set page sound' translated action: #setPageSound:.
			aCustomMenu add: 'set page visual' translated action: #setPageVisual:]
		ifFalse:
			[aCustomMenu add: 'change action selector' translated action: #setActionSelector.
			aCustomMenu add: 'change arguments' translated action: #setArguments.
			aCustomMenu add: 'change when to act' translated action: #setActWhen.
			self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:06'!
addLabelItemsTo: aCustomMenu hand: aHandMorph 
	aCustomMenu add: 'change label' translated action: #setLabel! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 20:10'!
addTargetingMenuItems: aCustomMenu hand: aHandMorph 
	"Add targeting menu items"
	aCustomMenu addLine.

	aCustomMenu add: 'set target' translated action: #targetWith:.
	aCustomMenu add: 'sight target' translated action: #sightTargets:.
	target
		ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 20:05'!
clearTarget

	target _ nil.
! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'yo 3/16/2005 21:00'!
setActWhen

	| selections |
	selections _ #(buttonDown buttonUp whilePressed startDrag).
	actWhen := (SelectionMenu 
				labels: (selections collect: [:t | t translated]) selections: selections) 
					startUpWithCaption: 'Choose one of the following conditions' translated! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'yo 3/16/2005 20:54'!
setActionSelector

	| newSel |
	newSel _ FillInTheBlank
		request:
'Please type the selector to be sent to
the target when this button is pressed' translated
		initialAnswer: actionSelector.
	newSel isEmpty ifFalse: [self actionSelector: newSel].
! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:09'!
setArguments

	| s newArgs newArgsArray |
	s _ WriteStream on: ''.
	arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
	newArgs _ FillInTheBlank
		request:
'Please type the arguments to be sent to the target
when this button is pressed separated by periods' translated
		initialAnswer: s contents.
	newArgs isEmpty ifFalse: [
		newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.
		self arguments: newArgsArray].
! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'sge 3/12/2004 05:51'!
setLabel

	| newLabel |
	newLabel _ FillInTheBlank
		request: 'Please enter a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self labelString: newLabel].
! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'!
setPageSound: event

	^ target menuPageSoundFor: self event: event! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'!
setPageVisual: event

	^ target menuPageVisualFor: self event: event! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'yo 1/14/2005 19:49'!
setTarget
	
	| newLabel |
	newLabel := FillInTheBlank request: 'Enter an expression that create the target' translated initialAnswer: 'World'.
	newLabel isEmpty
		ifFalse: [self target: (Compiler evaluate: newLabel)]! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:54'!
setTarget: evt 
	| rootMorphs |
	rootMorphs := self world rootMorphsAt: evt hand targetOffset.
	target := rootMorphs size > 1 
		ifTrue: [rootMorphs second]
		ifFalse: [nil]! !


!SimpleButtonMorph methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:49'!
objectForDataStream: refStrm
	"I am about to be written on an object file.  If I send a message to a BookMorph, it would be bad to write that object out.  Create and write out a URLMorph instead."

	| bb thatPage um stem ind sqPg |
	(actionSelector == #goToPageMorph:fromBookmark:) | 
		(actionSelector == #goToPageMorph:) ifFalse: [
			^ super objectForDataStream: refStrm].	"normal case"

	target url ifNil: ["Later force target book to get a url."
		bb _ SimpleButtonMorph new.	"write out a dummy"
		bb label: self label.
		bb bounds: bounds.
		refStrm replace: self with: bb.
		^ bb].

	(thatPage _ arguments first) url ifNil: [
			"Need to assign a url to a page that will be written later.
			It might have bookmarks too.  Don't want to recurse deeply.  
			Have that page write out a dummy morph to save its url on the server."
		stem _ target getStemUrl.	"know it has one"
		ind _ target pages identityIndexOf: thatPage.
		thatPage reserveUrl: stem,(ind printString),'.sp'].
	um _ URLMorph newForURL: thatPage url.
	sqPg _ thatPage sqkPage clone.
	sqPg contentsMorph: nil.
	um setURL: thatPage url page: sqPg.
	(SqueakPage stemUrl: target url) = (SqueakPage stemUrl: thatPage url) 
		ifTrue: [um book: true]
		ifFalse: [um book: target url].  	"remember which book"
	um privateOwner: owner.
	um bounds: bounds.
	um isBookmark: true; label: self label.
	um borderWidth: borderWidth; borderColor: borderColor.
	um color: color.
	refStrm replace: self with: um.
	^ um! !


!SimpleButtonMorph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/8/2000 08:14'!
actWhen
	"acceptable symbols:  #buttonDown, #buttonUp, and #whilePressed"

	^ actWhen! !

!SimpleButtonMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 6/13/2004 13:46'!
actWhen: condition
	"Accepts symbols:  #buttonDown, #buttonUp, and #whilePressed, #startDrag"
	actWhen _ condition.
	actWhen == #startDrag
		ifFalse: [self on: #startDrag send: nil to: nil ]
		ifTrue:[self on: #startDrag send: #doButtonAction to: self].! !


!SimpleButtonMorph methodsFor: 'visual properties' stamp: 'hg 6/27/2000 13:58'!
updateVisualState: evt
	
	oldColor ifNotNil: [
		 self color: 
			((self containsPoint: evt cursorPoint)
				ifTrue: [oldColor mixed: 1/2 with: Color white]
				ifFalse: [oldColor])]
! !


!SimpleButtonMorph methodsFor: '*MorphicExtras-copying' stamp: 'jm 7/28/97 11:52'!
updateReferencesUsing: aDictionary
	"If the arguments array points at a morph we are copying, then point at the new copy.  And also copies the array, which is important!!"

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !


!SimpleButtonMorph methodsFor: '*MorphicExtras-e-toy support' stamp: 'ar 3/17/2001 20:17'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	target _ target adaptedToWorld: aWorld.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleButtonMorph class
	instanceVariableNames: ''!

!SimpleButtonMorph class methodsFor: 'as yet unclassified' stamp: 'di 6/5/2000 08:42'!
newWithLabel: labelString

	^ self basicNew initializeWithLabel: labelString
! !


!SimpleButtonMorph class methodsFor: 'printing' stamp: 'apb 5/3/2006 14:37'!
defaultNameStemForInstances
	^ self = SimpleButtonMorph
		ifTrue: ['Button']
		ifFalse: [^ super defaultNameStemForInstances]! !


!SimpleButtonMorph class methodsFor: 'scripting' stamp: 'sw 5/6/1998 14:07'!
authoringPrototype
	^ super authoringPrototype label: 'Button'! !


!SimpleButtonMorph class methodsFor: '*eToys-scripting' stamp: 'sw 2/6/2001 23:54'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (
			(command fire 'trigger any and all of this object''s button actions'))))
! !
ScrollPane subclass: #SimpleHierarchicalListMorph
	instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect columns sortingSelector getSelectionSelector setSelectionSelector potentialDropMorph lineColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!
!SimpleHierarchicalListMorph commentStamp: 'ls 3/1/2004 12:15' prior: 0!
Display a hierarchical list of items.  Each item should be wrapped with a ListItemWrapper.

For a simple example, look at submorphsExample.  For beefier examples, look at ObjectExplorer or FileList2.!


!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'RAA 7/24/1998 22:52'!
columns

	^columns! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'RAA 7/18/1998 23:18'!
columns: anArray

	columns _ anArray! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'nk 3/8/2004 09:55'!
lineColor
	"Answer a good color to use for drawing the lines that connect members of the hierarchy view.
	Used the cached color, or derive it if necessary by finding the first owner (up to my root) that is not transparent, then picking a contrasting color.
	Fall back to veryLightGray if all my owners are transparent."

	| coloredOwner targetLuminance ownerColor darken |
	lineColor ifNotNil: [ ^lineColor ].
	coloredOwner _ self firstOwnerSuchThat: [ :o | o isWorldOrHandMorph not and: [ o color isTransparent not ]].
	coloredOwner ifNil: [ ^Color veryLightGray ].
	ownerColor _ coloredOwner color.
	darken _ ownerColor luminance > 0.5.
	targetLuminance _ ownerColor luminance + (darken ifTrue: [ -0.2 ] ifFalse: [ 0.2 ]).
	^darken
		ifTrue: [ ownerColor atMostAsLuminentAs: targetLuminance ]
		ifFalse: [ ownerColor atLeastAsLuminentAs: targetLuminance ]
	
! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'sps 12/28/2002 02:27'!
lineColor: aColor
	^lineColor _ aColor
! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:23'!
roots
	"Answer the receiver's roots"
	^ scroller submorphs
		select: [:each | each indentLevel isZero]! !

!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'RAA 7/20/1998 12:09'!
sortingSelector: s

	sortingSelector _ s! !


!SimpleHierarchicalListMorph methodsFor: 'debug and other' stamp: 'di 5/6/1998 21:19'!
installModelIn: aWorld
	"No special inits for new components"
	^ self! !


!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'sps 12/22/2002 00:03'!
drawLinesOn: aCanvas
	| lColor |
	lColor _ self lineColor.
	aCanvas 
		transformBy: scroller transform
		clippingTo: scroller innerBounds
		during:[:clippedCanvas |
			scroller submorphs do: [ :submorph |
				( 
					(submorph isExpanded) or: [
					(clippedCanvas isVisible: submorph fullBounds) or: [
					(submorph nextSibling notNil and: [clippedCanvas isVisible: submorph nextSibling]) 				]]) ifTrue:[
					submorph drawLinesOn: clippedCanvas lineColor: lColor.
				]
			].
		]
		smoothing: scroller smoothing.
! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'md 2/22/2006 21:27'!
drawOn: aCanvas
	super drawOn: aCanvas.
	selectedMorph ifNotNil:
		[aCanvas fillRectangle:
			(((scroller transformFrom: self) invertBoundsRect: selectedMorph bounds)
						intersect: scroller bounds)
				color: color blacker].
	self drawLinesOn: aCanvas.
	


! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 10:05'!
expandedForm

	^self class expandedForm! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:44'!
highlightSelection

	selectedMorph ifNotNil: [selectedMorph highlight]! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 10:06'!
notExpandedForm

	^self class notExpandedForm! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:44'!
unhighlightSelection
	selectedMorph ifNotNil: [selectedMorph unhighlight]! !


!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'nk 6/15/2003 11:49'!
acceptDroppingMorph: aMorph event: evt

	self model
		acceptDroppingMorph: aMorph
		event: evt
		inMorph: self.
	self resetPotentialDropMorph.
	evt hand releaseMouseFocus: self.
	Cursor normal show.
! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 17:39'!
potentialDropMorph
	^potentialDropMorph! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/8/2000 15:37'!
potentialDropMorph: aMorph
	potentialDropMorph _ aMorph.
	aMorph highlightForDrop! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/8/2000 15:38'!
resetPotentialDropMorph
	potentialDropMorph ifNotNil: [
		potentialDropMorph resetHighlightForDrop.
		potentialDropMorph _ nil]
! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 17:38'!
wantsDroppedMorph: aMorph event: anEvent 
	^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! !


!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 22:58'!
handlesKeyboard: evt
	^true! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:27'!
handlesMouseOverDragging: evt
	^self dropEnabled! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:25'!
itemFromPoint: aPoint
	"Return the list element (morph) at the given point or nil if outside"
	| ptY |
	scroller hasSubmorphs ifFalse:[^nil].
	(scroller fullBounds containsPoint: aPoint) ifFalse:[^nil].
	ptY _ (scroller firstSubmorph point: aPoint from: self) y.
	"note: following assumes that submorphs are vertical, non-overlapping, and ordered"
	scroller firstSubmorph top > ptY ifTrue:[^nil].
	scroller lastSubmorph bottom < ptY ifTrue:[^nil].
	"now use binary search"
	^scroller 
		findSubmorphBinary:[:item|
			(item top <= ptY and:[item bottom >= ptY])
				ifTrue:[0] "found"
				ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'nk 6/29/2004 14:48'!
keyStroke: event 
	"Process potential command keys"

	| args aCharacter |
	(self scrollByKeyboard: event) ifTrue: [^self].
	aCharacter := event keyCharacter.
	(self arrowKey: aCharacter) ifTrue: [^true].
	keystrokeActionSelector isNil ifTrue: [^false].
	(args := keystrokeActionSelector numArgs) = 1 
		ifTrue: [^model perform: keystrokeActionSelector with: aCharacter].
	args = 2 
		ifTrue: 
			[^model 
				perform: keystrokeActionSelector
				with: aCharacter
				with: self].
	^self 
		error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'jcg 9/21/2001 13:23'!
mouseDown: evt
	| aMorph selectors |
	aMorph _ self itemFromPoint: evt position.
	(aMorph notNil and:[aMorph inToggleArea: (aMorph point: evt position from: self)])
		ifTrue:[^self toggleExpandedState: aMorph event: evt]. 
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
	aMorph ifNil:[^super mouseDown: evt].
	aMorph highlightForMouseDown.
	selectors _ Array 
		with: #click:
		with: nil
		with: nil
		with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]).
	evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: 10 "pixels".! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:05'!
mouseEnter: event
	super mouseEnter: event.
	event hand newKeyboardFocus: self! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:26'!
mouseEnterDragging: evt
	| aMorph |
	(evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d"
		^super mouseEnterDragging: evt].
	(self wantsDroppedMorph: evt hand firstSubmorph event: evt )
		ifTrue:[
			aMorph _ self itemFromPoint: evt position.
			aMorph ifNotNil:[self potentialDropMorph: aMorph].
			evt hand newMouseFocus: self.
			"above is ugly but necessary for now"
		].! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:27'!
mouseLeaveDragging: anEvent
	(self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d"
		^ super mouseLeaveDragging: anEvent].
	self resetPotentialDropMorph.
	anEvent hand releaseMouseFocus: self.
	"above is ugly but necessary for now"
! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:27'!
mouseMove: evt

	(self dropEnabled and:[evt hand hasSubmorphs]) 
		ifFalse:[^super mouseMove: evt].
	potentialDropMorph ifNotNil:[
		(potentialDropMorph containsPoint: (potentialDropMorph point: evt position from: self))
			ifTrue:[^self].
	].
	self mouseLeaveDragging: evt.
	(self containsPoint: evt position) 
		ifTrue:[self mouseEnterDragging: evt].! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 23:16'!
mouseUp: event 
	| aMorph |
	aMorph := self itemFromPoint: event position.
	aMorph ifNil: [^self].
	aMorph highlightedForMouseDown ifFalse: [^self].
	aMorph highlightForMouseDown: false.
	model okToChange ifFalse: [^self].
	"No change if model is locked"
	((autoDeselect isNil or: [autoDeselect]) and: [aMorph == selectedMorph]) 
		ifTrue: [self setSelectedMorph: nil]
		ifFalse: [self setSelectedMorph: aMorph].
	Cursor normal show! !

!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'nk 6/12/2004 17:56'!
startDrag: evt 
	| ddm itemMorph passenger |
	self dragEnabled
		ifTrue: [itemMorph := scroller submorphs
						detect: [:any | any highlightedForMouseDown]
						ifNone: []].
	(itemMorph isNil
			or: [evt hand hasSubmorphs])
		ifTrue: [^ self].
	itemMorph highlightForMouseDown: false.
	itemMorph ~= self selectedMorph
		ifTrue: [self setSelectedMorph: itemMorph].
	passenger := self model dragPassengerFor: itemMorph inMorph: self.
	passenger
		ifNotNil: [ddm := TransferMorph withPassenger: passenger from: self.
			ddm
				dragTransferType: (self model dragTransferTypeForMorph: self).
			Preferences dragNDropWithAnimation
				ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm].
			evt hand grabMorph: ddm].
	evt hand releaseMouseFocus: self! !


!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'dgd 9/26/2004 18:24'!
expandRoots
	"Expand all the receiver's roots"
	self roots
		do: [:each |
			(each canExpand and: [each isExpanded not])
				ifTrue: [each toggleExpandedState]].
	self adjustSubmorphPositions! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'ar 3/17/2001 17:39'!
expand: aMorph to: level
	| allChildren |
	aMorph toggleExpandedState.
	allChildren _ OrderedCollection new: 10.
	aMorph recursiveAddTo: allChildren.
	allChildren do: [:each | 
		((each canExpand
			and: [each isExpanded not])
			and: [level > 0])
			ifTrue: [self expand: each to: level-1]].! !

!SimpleHierarchicalListMorph methodsFor: 'events'!
expandAll
	(selectedMorph isNil
		or: [selectedMorph isExpanded])
		ifTrue: [^self].
	self expandAll: selectedMorph.
	self adjustSubmorphPositions! !

!SimpleHierarchicalListMorph methodsFor: 'events'!
expandAll: aMorph
	| allChildren |
	aMorph toggleExpandedState.
	allChildren _ OrderedCollection new: 10.
	aMorph recursiveAddTo: allChildren.
	allChildren do: [:each | 
		(each canExpand and: [each isExpanded not])
			ifTrue: [self expandAll: each]].
! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'ar 3/17/2001 17:39'!
expandAll: aMorph except: aBlock
	| allChildren |
	(aBlock value: aMorph complexContents)
		ifFalse: [^self].
	aMorph toggleExpandedState.
	allChildren _ OrderedCollection new: 10.
	aMorph recursiveAddTo: allChildren.
	allChildren do: [:each | 
		(each canExpand
			and: [each isExpanded not])
			ifTrue: [self expandAll: each except: aBlock]].! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'ar 3/17/2001 17:39'!
toggleExpandedState: aMorph event: event
	| oldState |
	"self setSelectedMorph: aMorph."
	event yellowButtonPressed ifTrue: [
		oldState _ aMorph isExpanded.
		scroller submorphs copy do: [ :each |
			(each canExpand and: [each isExpanded = oldState]) ifTrue: [
				each toggleExpandedState.
			].
		].
	] ifFalse: [
		aMorph toggleExpandedState.
	].
	self adjustSubmorphPositions.
	! !


!SimpleHierarchicalListMorph methodsFor: 'events-processing' stamp: 'ar 3/17/2001 17:26'!
handleMouseMove: anEvent
	"Reimplemented because we really want #mouseMove when a morph is dragged around"
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
	anEvent wasHandled: true.
	self mouseMove: anEvent.
	(self handlesMouseStillDown: anEvent) ifTrue:[
		"Step at the new location"
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].
! !


!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: 'nk 7/11/2004 20:07'!
extent: newExtent
	bounds extent = newExtent ifTrue: [^ self].
	super extent: newExtent.
	self setScrollDeltas ! !

!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: 'dew 11/5/2000 00:15'!
scrollDeltaHeight
	^ scroller firstSubmorph height! !

!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 17:31'!
scrollDeltaWidth
"A guess -- assume that the width of a char is approx 1/2 the height of the font"
	^ self scrollDeltaHeight // 2


! !


!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'di 4/10/98 16:20'!
autoDeselect: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	autoDeselect _ trueOrFalse.! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 3/30/1999 22:29'!
currentlyExpanded

	^(scroller submorphs select: [ :each | each isExpanded]) collect: [ :each |
		each complexContents
	].
	! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 7/29/2000 22:15'!
indentingItemClass
	
	^IndentingListItemMorph! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:26'!
initialize
	"initialize the state of the receiver"
	super initialize.
	self
		on: #mouseMove
		send: #mouseStillDown:onItem:
		to: self! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'ar 3/17/2001 17:39'!
list: aCollection

	| wereExpanded morphList |
	wereExpanded _ self currentlyExpanded.
	scroller removeAllMorphs.
	(aCollection isNil or: [aCollection isEmpty]) ifTrue: [^ self selectedMorph: nil].
	morphList _ OrderedCollection new.
	self 
		addMorphsTo: morphList
		from: aCollection 
		allowSorting: false
		withExpandedItems: wereExpanded
		atLevel: 0.
	self insertNewMorphs: morphList.! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'di 5/22/1998 00:32'!
listItemHeight
	"This should be cleaned up.  The list should get spaced by this parameter."
	^ 12! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 8/1/1998 00:19'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel

	self model: anObject.
	getListSelector _ getListSel.
	getSelectionSelector _ getSelectionSel.
	setSelectionSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	self list: self getList.! !


!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'ar 10/14/2003 23:38'!
arrowKey: aChar
	"Handle a keyboard navigation character. Answer true if handled, false if not."
	| keyEvent |
	keyEvent := aChar asciiValue.
     keyEvent == 31 ifTrue:["down"
		self setSelectionIndex: self getSelectionIndex+1.
		^true].
     keyEvent == 30 ifTrue:["up"
		self setSelectionIndex: (self getSelectionIndex-1 max: 1).
		^true].
     keyEvent == 1  ifTrue: ["home"
		self setSelectionIndex: 1.
		^true].
     keyEvent == 4  ifTrue: ["end"
		self setSelectionIndex: scroller submorphs size.
		^true].
      keyEvent == 11 ifTrue: ["page up"
		self setSelectionIndex: (self getSelectionIndex - self numSelectionsInView max: 1).
		^true].
     keyEvent == 12  ifTrue: ["page down"
		self setSelectionIndex: self getSelectionIndex + self numSelectionsInView.
		^true].
	keyEvent == 29 ifTrue:["right"
		selectedMorph ifNotNil:[
			(selectedMorph canExpand and:[selectedMorph isExpanded not])
				ifTrue:[self toggleExpandedState: selectedMorph]
				ifFalse:[self setSelectionIndex: self getSelectionIndex+1].
		].
		^true].
	keyEvent == 28 ifTrue:["left"
		selectedMorph ifNotNil:[
			(selectedMorph isExpanded)
				ifTrue:[self toggleExpandedState: selectedMorph]
				ifFalse:[self setSelectionIndex: (self getSelectionIndex-1 max: 1)].
		].
		^true].
	^false! !

!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'ar 10/14/2003 23:38'!
getSelectionIndex
	^scroller submorphs indexOf: selectedMorph! !

!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'ar 10/14/2003 23:39'!
setSelectionIndex: idx
	"Called internally to select the index-th item."
	| theMorph index |
	idx ifNil: [^ self].
	index := idx min: scroller submorphs size max: 0.
	theMorph _ index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index].
	self setSelectedMorph: theMorph.! !

!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'ar 10/14/2003 23:39'!
toggleExpandedState: aMorph
	aMorph toggleExpandedState.
	self adjustSubmorphPositions.
! !


!SimpleHierarchicalListMorph methodsFor: 'model access' stamp: 'RAA 8/1/1998 00:10'!
getList 
	"Answer the list to be displayed."

	^(model perform: (getListSelector ifNil: [^#()])) ifNil: [#()]

! !


!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:40'!
mouseDown: event onItem: aMorph
	self removeObsoleteEventHandlers.
! !

!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:40'!
mouseEnterDragging: anEvent onItem: aMorph 
	self removeObsoleteEventHandlers.! !

!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:39'!
mouseLeaveDragging: anEvent onItem: aMorph 
	self removeObsoleteEventHandlers.! !

!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:38'!
removeObsoleteEventHandlers
	scroller submorphs do:[:m|
		m eventHandler: nil; highlightForMouseDown: false; resetExtension].! !

!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:39'!
startDrag: evt onItem: itemMorph 
	self removeObsoleteEventHandlers.! !


!SimpleHierarchicalListMorph methodsFor: 'scrolling' stamp: 'sps 12/24/2002 18:31'!
hExtraScrollRange
	"Return the amount of extra blank space to include below the bottom of the scroll content."
	^5
! !

!SimpleHierarchicalListMorph methodsFor: 'scrolling' stamp: 'sps 3/23/2004 15:51'!
hUnadjustedScrollRange
"Return the width of the widest item in the list"

	| max right stringW count |

	max _ 0.
	count _ 0.
	scroller submorphsDo: [ :each |
		stringW _ each font widthOfStringOrText: each contents.
		right _ (each toggleRectangle right + stringW + 10).
		max _ max max: right.
		
"NOTE: need to optimize this method by caching list item morph widths (can init that cache most efficiently in the #list: method before the item widths are reset to 9999).  For now, just punt on really long lists"
		((count _ count + 1) > 200) ifTrue:[ ^max * 3].
	].

	^max 
! !

!SimpleHierarchicalListMorph methodsFor: 'scrolling' stamp: 'sps 12/26/2002 13:37'!
vUnadjustedScrollRange
"Return the width of the widest item in the list"

	(scroller submorphs size > 0) ifFalse:[ ^0 ].
	^scroller submorphs last fullBounds bottom
! !


!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 8/1/1998 00:19'!
getCurrentSelectionItem

	^model perform: (getSelectionSelector ifNil: [^nil])
	! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 7/31/1998 00:25'!
maximumSelection

	^ scroller submorphs size
! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'!
minimumSelection
	^ 1! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'panda 4/25/2000 18:56'!
selectedMorph
	^selectedMorph! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 8/1/1998 00:13'!
selectedMorph: aMorph

	self unhighlightSelection.
	selectedMorph _ aMorph.
	self highlightSelection! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 8/31/1999 08:36'!
selection: item
	"Called from outside to request setting a new selection.
	Assumes scroller submorphs is exactly our list.
	Note: MAY NOT work right if list includes repeated items"

	| i |
	item ifNil: [^self selectionIndex: 0].
	i _ scroller submorphs findFirst: [:m | m complexContents == item].
	i > 0 ifTrue: [^self selectionIndex: i].
	i _ scroller submorphs findFirst: [:m | m withoutListWrapper = item withoutListWrapper].
	self selectionIndex: i! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'nk 4/28/2004 10:26'!
selectionIndex: idx
	"Called internally to select the index-th item."
	| theMorph range index |
	idx ifNil: [^ self].
	index := idx min: scroller submorphs size max: 0.
	(theMorph _ index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index])
		ifNotNil:
		[((theMorph bounds top - scroller offset y) >= 0
			and: [(theMorph bounds bottom - scroller offset y) <= bounds height]) ifFalse:
			["Scroll into view -- should be elsewhere"
			range _ self vTotalScrollRange.
			scrollBar value: (range > 0
				ifTrue: [((index-1 * theMorph height) / self vTotalScrollRange)
									truncateTo: scrollBar scrollDelta]
				ifFalse: [0]).
			scroller offset: -3 @ (range * scrollBar value)]].
	self selectedMorph: theMorph! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 3/31/1999 12:15'!
selectionOneOf: aListOfItems
	"Set the selection to the first item in the list which is represented by one of my submorphs"

	| index |
	aListOfItems do: [ :item |
		index _ scroller submorphs findFirst: [:m | 
			m withoutListWrapper = item withoutListWrapper
		].
		index > 0 ifTrue: [^self selectionIndex: index].
	].
	self selectionIndex: 0.! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 3/31/1999 21:28'!
setSelectedMorph: aMorph

	model 
		perform: (setSelectionSelector ifNil: [^self]) 
		with: aMorph complexContents	"leave last wrapper in place"

 ! !


!SimpleHierarchicalListMorph methodsFor: 'updating' stamp: 'dgd 2/21/2003 23:16'!
update: aSymbol 
	aSymbol == getSelectionSelector 
		ifTrue: 
			[self selection: self getCurrentSelectionItem.
			^self].
	aSymbol == getListSelector 
		ifTrue: 
			[self list: self getList.
			^self].
	((aSymbol isKindOf: Array) 
		and: [aSymbol notEmpty and: [aSymbol first == #openPath]]) 
			ifTrue: 
				[^(scroller submorphs at: 1 ifAbsent: [^self]) 
					openPath: aSymbol allButFirst]! !


!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 7/30/2000 19:49'!
addMorphsTo: morphList from: aCollection allowSorting: sortBoolean withExpandedItems: expandedItems atLevel: newIndent

	| priorMorph newCollection firstAddition |
	priorMorph _ nil.
	newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [
		(aCollection asSortedCollection: [ :a :b | 
			(a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection
	] ifFalse: [
		aCollection
	].
	firstAddition _ nil.
	newCollection do: [:item | 
		priorMorph _ self indentingItemClass basicNew 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: newIndent.
		firstAddition ifNil: [firstAddition _ priorMorph].
		morphList add: priorMorph.
		((item hasEquivalentIn: expandedItems) or: [priorMorph isExpanded]) ifTrue: [
			priorMorph isExpanded: true.
			priorMorph 
				addChildrenForList: self 
				addingTo: morphList
				withExpandedItems: expandedItems.
		].
	].
	^firstAddition
	
! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 7/30/2000 19:15'!
addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean

	| priorMorph morphList newCollection |
	priorMorph _ nil.
	newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [
		(aCollection asSortedCollection: [ :a :b | 
			(a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection
	] ifFalse: [
		aCollection
	].
	morphList _ OrderedCollection new.
	newCollection do: [:item | 
		priorMorph _ self indentingItemClass basicNew 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: parentMorph indentLevel + 1.
		morphList add: priorMorph.
	].
	scroller addAllMorphs: morphList after: parentMorph.
	^morphList
	
! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 6/21/1999 11:25'!
adjustSubmorphPositions

	| p h |

	p _ 0@0.
	scroller submorphsDo: [ :each |
		h _ each height.
		each privateBounds: (p extent: 9999@h).
		p _ p + (0@h)
	].
	self 
		changed;
		layoutChanged;
		setScrollDeltas.
! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 4/2/1999 15:33'!
insertNewMorphs: morphList

	scroller addAllMorphs: morphList.
	self adjustSubmorphPositions.
	self selection: self getCurrentSelectionItem.
	self setScrollDeltas.
! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 8/2/1999 12:42'!
noteRemovalOfAll: aCollection

	scroller removeAllMorphsIn: aCollection.
	(aCollection includes: selectedMorph) ifTrue: [self setSelectedMorph: nil].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleHierarchicalListMorph class
	instanceVariableNames: 'expandedForm notExpandedForm'!

!SimpleHierarchicalListMorph class methodsFor: 'examples' stamp: 'ls 3/1/2004 17:32'!
submorphsExample
	"display a hierarchical list of the World plus its submorphs plus its submorphs' submorphs etc."
	"[SimpleHierarchicalListMorph submorphsExample]"
	| morph |
	morph :=
		SimpleHierarchicalListMorph
			on: [ Array with:  (MorphWithSubmorphsWrapper with: World)  ]
			list: #value
			selected: nil
			changeSelected: nil
			menu: nil
			keystroke: nil.

	morph openInWindow! !


!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'nk 3/8/2004 10:05'!
expandedForm

	expandedForm ifNotNil: [ expandedForm depth ~= Display depth ifTrue: [ expandedForm _ nil ]].

	^expandedForm ifNil: [expandedForm _ 
			(Form
				extent: 10@9
				depth: 8
				fromArray: #( 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760 4278255873 16843009 16842752 4294902089 1229539657 33488896 4294967041 1229539585 4294901760 4294967295 21561855 4294901760 4294967295 4278321151 4294901760 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760)
				offset: 0@0)
					asFormOfDepth: Display depth;
					replaceColor: Color white withColor: Color transparent;
					yourself
	].
! !

!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'nk 3/8/2004 10:06'!
notExpandedForm

	notExpandedForm ifNotNil: [ notExpandedForm depth ~= Display depth ifTrue: [ notExpandedForm _ nil ]].

	^notExpandedForm ifNil: [notExpandedForm _ 
			(Form
				extent: 10@9
				depth: 8
				fromArray: #( 4294967041 4294967295 4294901760 4294967041 33554431 4294901760 4294967041 1224867839 4294901760 4294967041 1229521407 4294901760 4294967041 1229539585 4294901760 4294967041 1229521407 4294901760 4294967041 1224867839 4294901760 4294967041 33554431 4294901760 4294967041 4294967295 4294901760)
				offset: 0@0)
					asFormOfDepth: Display depth;
					replaceColor: Color white withColor: Color transparent;
					yourself
	].
! !

!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:34'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: nil
		keystroke: #arrowKey:from:		"default"! !

!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:34'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: #arrowKey:from:		"default"
! !

!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:34'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel
! !
Object subclass: #SimpleMIDIPort
	instanceVariableNames: 'portNumber accessSema lastCommandByteOut'
	classVariableNames: 'DefaultPortNumber InterfaceClockRate'
	poolDictionaries: ''
	category: 'Sound-Scores'!
!SimpleMIDIPort commentStamp: '<historical>' prior: 0!
This is a first cut at a simple MIDI output port.
!


!SimpleMIDIPort methodsFor: 'input' stamp: 'jm 10/8/1998 19:47'!
bufferTimeStampFrom: aByteArray
	"Return the timestamp from the given MIDI input buffer. Assume the given buffer is at least 4 bytes long."

	^ ((aByteArray at: 1) bitShift: 24) +
	  ((aByteArray at: 2) bitShift: 16) +
	  ((aByteArray at: 3) bitShift: 8) +
	   (aByteArray at: 4)
! !

!SimpleMIDIPort methodsFor: 'input' stamp: 'stephaneducasse 2/4/2006 20:41'!
flushInput
	"Read any lingering MIDI data from this port's input buffer."

	| buf |
	buf := ByteArray new: 1000.
	[(self readInto: buf) > 0] whileTrue.
! !

!SimpleMIDIPort methodsFor: 'input' stamp: 'jm 10/12/1998 15:49'!
readInto: aByteArray
	"Read any data from this port into the given buffer."

	^ self primMIDIReadPort: portNumber into: aByteArray
! !


!SimpleMIDIPort methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:41'!
close
	"Close this MIDI port."

	portNumber ifNotNil: [self primMIDIClosePort: portNumber].
	accessSema := nil.
	lastCommandByteOut := nil.
! !

!SimpleMIDIPort methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:41'!
ensureOpen
	"Make sure this MIDI port is open. It is good to call this before starting to use a port in case an intervening image save/restore has caused the underlying hardware port to get closed."

	portNumber ifNil: [^ self error: 'Use "openOn:" to open a MIDI port initially'].
	self primMIDIClosePort: portNumber.
	self primMIDIOpenPort: portNumber readSemaIndex: 0 interfaceClockRate: InterfaceClockRate.
	accessSema := Semaphore forMutualExclusion.
	lastCommandByteOut := Array new: 16 withAll: 0.  "clear running status"
! !

!SimpleMIDIPort methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:41'!
openOnPortNumber: portNum
	"Open this MIDI port on the given port number."

	self close.
	portNumber := portNum.
	accessSema := Semaphore forMutualExclusion.
	self ensureOpen.
! !

!SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 10/12/1998 15:48'!
portNumber
	"Answer my port number."

	^ portNumber
! !

!SimpleMIDIPort methodsFor: 'open/close'!
useInstrument: aName onChannel: aChannel
	self useInstrumentNumber: (self class midiInstruments indexOf: aName)-1 onChannel: aChannel! !

!SimpleMIDIPort methodsFor: 'open/close'!
useInstrumentNumber: aNumber onChannel: aChannel
	self ensureOpen.
	self midiCmd: 192 channel: aChannel byte: aNumber ! !


!SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'!
midiCmd: cmd channel: channel byte: dataByte
	"Immediately output the given MIDI command with the given channel and argument byte to this MIDI port. Assume that the port is open."

	accessSema critical: [
		self primMIDIWritePort: portNumber
			from: (ByteArray
					with: (cmd bitOr: channel)
					with: dataByte)
			at: 0].
! !

!SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'!
midiCmd: cmd channel: channel byte: dataByte1 byte: dataByte2
	"Immediately output the given MIDI command with the given channel and argument bytes to this MIDI port. Assume that the port is open."

	accessSema critical: [
		self primMIDIWritePort: portNumber
			from: (ByteArray
					with: (cmd bitOr: channel)
					with: dataByte1
					with: dataByte2)
			at: 0].
! !

!SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'!
midiOutput: aByteArray
	"Output the given bytes to this MIDI port immediately. Assume that the port is open."

	accessSema critical: [
		self primMIDIWritePort: portNumber from: aByteArray at: 0].
! !


!SimpleMIDIPort methodsFor: 'primitives' stamp: 'mga 10/1/2004 01:49'!
playNote: aNote onChannel: aChannel
	self playNote: aNote velocity: 64 onChannel: aChannel! !

!SimpleMIDIPort methodsFor: 'primitives'!
playNote: aNote velocity: aVel onChannel: aChannel
	self midiCmd: 144 channel: aChannel byte: aNote byte: aVel! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'mga 10/1/2004 01:52'!
playNoteNamed: aNotename onChannel: aChannel
	self playNoteNamed: aNotename velocity: 64 onChannel: aChannel! !

!SimpleMIDIPort methodsFor: 'primitives'!
playNoteNamed: aNotename velocity: aVel onChannel: aChannel
	self playNote: (AbstractSound midiKeyForPitch: aNotename) velocity: aVel onChannel: aChannel

	! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIClosePort: portNum
	"Close the given MIDI port. Don't fail if port is already closed."

	<primitive: 'primitiveMIDIClosePort' module: 'MIDIPlugin'>
! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIOpenPort: portNum readSemaIndex: readSemaIndex interfaceClockRate: interfaceClockRate
	"Open the given MIDI port. If non-zero, readSemaIndex specifies the index in the external objects array of a semaphore to be signalled when incoming MIDI data is available. Not all platforms support signalling the read semaphore. InterfaceClockRate specifies the clock rate of the external MIDI interface adaptor on Macintosh computers; it is ignored on other platforms."

	<primitive: 'primitiveMIDIOpenPort' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIReadPort: portNum into: byteArray
	"Read any available MIDI data into the given buffer (up to the size of the buffer) and answer the number of bytes read."

	<primitive: 'primitiveMIDIRead' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIWritePort: portNum from: byteArray at: midiClockValue
	"Queue the given data to be sent through the given MIDI port at the given time. If midiClockValue is zero, send the data immediately."

	<primitive: 'primitiveMIDIWrite' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'mga 10/1/2004 01:50'!
stopNote: aNote onChannel: aChannel
	self stopNote: aNote velocity: 64 onChannel: aChannel! !

!SimpleMIDIPort methodsFor: 'primitives'!
stopNote: aNote velocity: aVel onChannel: aChannel
	self midiCmd: 128 channel: aChannel byte: aNote byte: aVel! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'mga 10/1/2004 01:50'!
stopNoteNamed: aNotename onChannel: aChannel
	self stopNoteNamed: aNotename velocity: 64 onChannel: aChannel! !

!SimpleMIDIPort methodsFor: 'primitives'!
stopNoteNamed: aNotename velocity: aVel onChannel: aChannel
	self stopNote: (AbstractSound midiKeyForPitch: aNotename) velocity: aVel onChannel: aChannel
	 ! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleMIDIPort class
	instanceVariableNames: ''!

!SimpleMIDIPort class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"SimpleMIDIPort initialize"

	InterfaceClockRate := 1000000.
	DefaultPortNumber := 0.
! !


!SimpleMIDIPort class methodsFor: 'examples' stamp: 'mga 10/1/2004 01:51'!
examplePlayNoteNamedVelocityOnChannel
	"self examplePlayNoteNamedVelocityOnChannel"
	
	|aPort|
	aPort:= self openOnPortNumber: 0.
	#('Bottle Blow' 'Shakuhachi' 'Whistle' 'Ocarina' 'Lead 1 (square)' 'Lead 2 (sawtooth)' 'Lead 3 (caliope lead)' 'Lead 4 (chiff lead)' 'Lead 5 (charang)' 'Lead 6 (voice)' 'Lead 7 (fifths)' 'Lead 8 (brass + lead)' 'Pad 1 (new age)' 'Pad 2 (warm)' 'Pad 3 (polysynth)' 'Pad 4 (choir)' 'Pad 5 (bowed)' 'Pad 6 (metallic)' 'Pad 7 (halo)' 'Pad 8 (sweep)' 'FX 1 (rain)' 'FX 2 (soundtrack)' 'FX 3 (crystal)' 'FX 4 (atmosphere)' 'FX 5 (brightness)' 'FX 6 (goblins)' 'FX 7 (echoes)' 'FX 8 (sci-fi)' 'Sitar' 'Banjo' 'Shamisen' 'Koto' 'Kalimba' 'Bagpipe' 'Fiddle' 'Shanai' 'Tinkle Bell' 'Agogo' 'Steel Drums' 'Woodblock' 'Taiko Drum' 'Melodic Tom' 'Synth Drum' 'Reverse Cymbal' 'Guitar Fret Noise' 'Breath Noise' 'Seashore' 'Bird Tweet' 'Telephone Ring' 'Helicopter' 'Applause' 'Gunshot' ) do: [:anInstrumentName | 
	[aPort useInstrument: anInstrumentName onChannel: 0.
	aPort playNoteNamed: 'c4' onChannel: 0.
	(Delay forMilliseconds: 250) wait.
	aPort stopNoteNamed: 'c4' onChannel: 0] ensure: [aPort close]]! !


!SimpleMIDIPort class methodsFor: 'instance creation' stamp: 'jm 9/10/1998 18:36'!
openDefault
	"Answer a new instance of me opened on the default MIDI port."

	^ self openOnPortNumber: DefaultPortNumber
! !

!SimpleMIDIPort class methodsFor: 'instance creation' stamp: 'tk 6/24/1999 11:42'!
openOnPortNumber: portNum
	"Answer a new instance of me for the given MIDI port number."
	"Details: All clients of a particular MIDI port should share the same instance of me. This allows accesses to the port to be serialized and shared port-related state state to be maintained."

	SimpleMIDIPort allSubInstancesDo: [:p |
		p portNumber = portNum ifTrue: [
			"share the existing port object for this port number"
			^ p]].

	^ super new openOnPortNumber: portNum
! !


!SimpleMIDIPort class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primPortCount
	"Answer the number of MIDI ports supported by this platform, or zero if this primitive is not implemented."

	<primitive: 'primitiveMIDIGetPortCount' module: 'MIDIPlugin'>
	^ 0
! !

!SimpleMIDIPort class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primPortDirectionalityOf: portNum
	"Answer the platform-specific name for the given MIDI port."

	<primitive: 'primitiveMIDIGetPortDirectionality' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!SimpleMIDIPort class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primPortNameOf: portNum
	"Answer the platform-specific name for the given MIDI port."

	<primitive: 'primitiveMIDIGetPortName' module: 'MIDIPlugin'>
	self primitiveFailed.
! !


!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
closeAllPorts
	"Close all MIDI ports."
	"SimpleMIDIPort closeAllPorts"

	| lastPortNum |
	lastPortNum := self primPortCount - 1.
	0 to: lastPortNum do: [:portNum | self basicNew primMIDIClosePort: portNum].
! !

!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'TN 5/31/2005 00:51'!
inputPortNumFromUser
	"Prompt the user for a MIDI input port. Answer a port number, or nil if the user does not select a port or if MIDI is not supported on this platform."
	"SimpleMIDIPort inputPortNumFromUser"

	| portCount aMenu dir |
	portCount _ self primPortCount.
	portCount = 0 ifTrue: [^ nil].
	aMenu _ CustomMenu new title: 'MIDI port for input:' translated.
	0 to: portCount - 1 do:[:i |
		dir _ self primPortDirectionalityOf: i.
		(dir = 1) | (dir = 3) ifTrue:[
			aMenu add: (self portDescription: i) action: i]].
	 ^ aMenu startUp
! !

!SimpleMIDIPort class methodsFor: 'utilities'!
midiInstruments
	"self midiInstruments"
	^ #('Acoustic Grand Piano' 'Bright Acoustic Piano' 'Electric Grand Piano' 'Honky-tonk Piano' 'Rhodes Piano' 'Chorused Piano' 'Harpsichord' 'Clavinet' 'Celesta' 'Glockenspiel' 'Music box' 'Vibraphone' 'Marimba' 'Xylophone' 'Tubular Bells' 'Dulcimer' 'Hammond Organ' 'Percussive Organ' 'Rock Organ' 'Church Organ' 'Reed Organ' 'Accordian' 'Harmonica' 'Tango Accordian' 'Acoustic Guitar (nylon)' 'Acoustic Guitar (steel)' 'Electric Guitar (jazz)' 'Electric Guitar (clean)' 'Electric Guitar (muted)' 'Overdriven Guitar' 'Distortion Guitar' 'Guitar Harmonics' 'Acoustic Bass' 'Electric Bass (finger)' 'Electric Bass (pick)' 'Fretless Bass' 'Slap Bass 1' 'Slap Bass 2' 'Synth Bass 1' 'Synth Bass 2' 'Violin' 'Viola' 'Cello' 'Contrabass' 'Tremolo Strings' 'Pizzicato Strings' 'Orchestral Harp' 'Timpani' 'String Ensemble 1' 'String Ensemble 2' 'Synth Strings 1' 'Synth Strings 2' 'Choir Aahs' 'Voice Oohs' 'Synth Voice' 'Orchestra Hit' 'Trumpet' 'Trombone' 'Tuba' 'Muted Trumpet' 'French Horn' 'Brass Section' 'Synth Brass 1' 'Synth Brass 2' 'Soprano Sax' 'Alto Sax' 'Tenor Sax' 'Baritone Sax' 'Oboe' 'English Horn' 'Bassoon' 'Clarinet' 'Piccolo' 'Flute' 'Recorder' 'Pan Flute' 'Bottle Blow' 'Shakuhachi' 'Whistle' 'Ocarina' 'Lead 1 (square)' 'Lead 2 (sawtooth)' 'Lead 3 (caliope lead)' 'Lead 4 (chiff lead)' 'Lead 5 (charang)' 'Lead 6 (voice)' 'Lead 7 (fifths)' 'Lead 8 (brass + lead)' 'Pad 1 (new age)' 'Pad 2 (warm)' 'Pad 3 (polysynth)' 'Pad 4 (choir)' 'Pad 5 (bowed)' 'Pad 6 (metallic)' 'Pad 7 (halo)' 'Pad 8 (sweep)' 'FX 1 (rain)' 'FX 2 (soundtrack)' 'FX 3 (crystal)' 'FX 4 (atmosphere)' 'FX 5 (brightness)' 'FX 6 (goblins)' 'FX 7 (echoes)' 'FX 8 (sci-fi)' 'Sitar' 'Banjo' 'Shamisen' 'Koto' 'Kalimba' 'Bagpipe' 'Fiddle' 'Shanai' 'Tinkle Bell' 'Agogo' 'Steel Drums' 'Woodblock' 'Taiko Drum' 'Melodic Tom' 'Synth Drum' 'Reverse Cymbal' 'Guitar Fret Noise' 'Breath Noise' 'Seashore' 'Bird Tweet' 'Telephone Ring' 'Helicopter' 'Applause' 'Gunshot' )! !

!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 18:10'!
midiIsSupported
	"Answer true if this platform supports MIDI."

	^ self primPortCount > 0
! !

!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
outputPortNumFromUser
	"Prompt the user for a MIDI output port. Answer a port number, or nil if the user does not select a port or if MIDI is not supported on this platform."
	"SimpleMIDIPort outputPortNumFromUser"

	| portCount aMenu dir |
	portCount := self primPortCount.
	portCount = 0 ifTrue: [^ nil].
	aMenu := CustomMenu new title: 'MIDI port for output:' translated.
	0 to: portCount - 1 do:[:i |
		dir := self primPortDirectionalityOf: i.
		(dir = 2) | (dir = 3) ifTrue:[
			aMenu add: (self portDescription: i) action: i]].
	 ^ aMenu startUp
! !

!SimpleMIDIPort class methodsFor: 'utilities'!
percussionInstruments
	"self percussionInstruments"
	^ #('Bottle Blow' 'Shakuhachi' 'Whistle' 'Ocarina' 'Lead 1 (square)' 'Lead 2 (sawtooth)' 'Lead 3 (caliope lead)' 'Lead 4 (chiff lead)' 'Lead 5 (charang)' 'Lead 6 (voice)' 'Lead 7 (fifths)' 'Lead 8 (brass + lead)' 'Pad 1 (new age)' 'Pad 2 (warm)' 'Pad 3 (polysynth)' 'Pad 4 (choir)' 'Pad 5 (bowed)' 'Pad 6 (metallic)' 'Pad 7 (halo)' 'Pad 8 (sweep)' 'FX 1 (rain)' 'FX 2 (soundtrack)' 'FX 3 (crystal)' 'FX 4 (atmosphere)' 'FX 5 (brightness)' 'FX 6 (goblins)' 'FX 7 (echoes)' 'FX 8 (sci-fi)' 'Sitar' 'Banjo' 'Shamisen' 'Koto' 'Kalimba' 'Bagpipe' 'Fiddle' 'Shanai' 'Tinkle Bell' 'Agogo' 'Steel Drums' 'Woodblock' 'Taiko Drum' 'Melodic Tom' 'Synth Drum' 'Reverse Cymbal' 'Guitar Fret Noise' 'Breath Noise' 'Seashore' 'Bird Tweet' 'Telephone Ring' 'Helicopter' 'Applause' 'Gunshot' )! !

!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'TN 5/31/2005 00:54'!
portDescription: portNum
	"Answer a string indicating the directionality of the given MIDI port."
	"(0 to: SimpleMIDIPort primPortCount - 1) collect:
		[:i | SimpleMIDIPort portDescription: i]"

	| portName dir |
	portName _ (self primPortNameOf: portNum) convertFromSystemString.
	dir _ self primPortDirectionalityOf: portNum.
	dir = 1 ifTrue: [^ portName, ' (in)'].
	dir = 2 ifTrue: [^ portName, ' (out)'].
	dir = 3 ifTrue: [^ portName, ' (in/out)'].
	^ self error: 'unknown MIDI port directionality'
! !
Model subclass: #SimpleServiceEntry
	instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FileRegistry'!
!SimpleServiceEntry commentStamp: '<historical>' prior: 0!
I represent a service

provider : the service provider
label : to be display in a menu
selector : to do the service
useLineAfter
stateSelector : a secondary selector (to be able to query state of the provider for example)
description : a description for balloon for example
argumentGetter : a selector to get additional arguments with (if selector requres them)
buttonLabel : a short label

The entire client interface (provided by FileList and other users of the registry)
is this (browse #getArgumentsFrom: and the 
senders of #argumentGetter:):

fullName (returns a String with the full filename)
dirAndFileName (returns {directory. fileName})
readOnlyStream (returns an open read-only stream)
!


!SimpleServiceEntry methodsFor: 'accessing' stamp: 'RAA 2/2/2002 08:14'!
argumentGetter: aBlock

	argumentGetter _ aBlock! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sw 2/15/2002 17:53'!
buttonLabel
	"Answer the label to be emblazoned on a button representing the service in a file list, for example"

	^ buttonLabel ifNil: [label]! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'dgd 9/1/2003 12:16'!
buttonLabel: aString 
	"Set the receiver's buttonLabel, to be used on a button in a 
	tool-pane; this is split out so that a more abbreviated wording 
	can be deployed if desired"
	buttonLabel := aString translated! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:03'!
description
	"may be used for balloon or other"

	^ description
! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:03'!
description: aString
	"may be used for balloon or other"

	description := aString
! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:10'!
extraSelector
	"normally should not be used directly"

	^stateSelector! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:11'!
extraSelector: aSymbol

	stateSelector := aSymbol! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'hg 8/3/2000 13:06'!
label

	^label! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:38'!
provider

	^ provider! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'dgd 9/1/2003 12:12'!
provider: anObject label: aString selector: aSymbol 
	"basic initialization message"
	provider := anObject.
	label := aString translated.
	selector := aSymbol.
	stateSelector := #none.
	description := ''! !

!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:09'!
selector
	"normally should not be used directly"

	^selector! !


!SimpleServiceEntry methodsFor: 'extra' stamp: 'nk 6/8/2004 16:42'!
performExtraFor: anObject
	"carry out the extra service I provide"
	"the stateSelector can be used to ask state of the provider to be reflected in button or other"

	^stateSelector numArgs = 0
		ifTrue: [provider perform: stateSelector]
		ifFalse: [provider perform: stateSelector with: (self getArgumentsFrom: anObject) ]
! !

!SimpleServiceEntry methodsFor: 'extra' stamp: 'sd 1/31/2002 21:08'!
requestExtraSelector
	"send me this message to ask me to perform secondary service"

	^#performExtraFor:
! !


!SimpleServiceEntry methodsFor: 'performing service' stamp: 'jrp 7/30/2005 22:35'!
buttonToTriggerIn: aFileList
	"Answer a button that will trigger the receiver service in a file list"

	| aButton |
	aButton _  PluggableButtonMorph
					on: self
					getState: nil
					action: #performServiceFor:.
	aButton 
		arguments: { aFileList }.

	aButton
		color: Color transparent;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: self buttonLabel;
		askBeforeChanging: true;
		onColor: Color white offColor: Color white.
		aButton setBalloonText: self description.

	^ aButton! !

!SimpleServiceEntry methodsFor: 'performing service' stamp: 'RAA 2/2/2002 08:31'!
getArgumentsFrom: aProvider

	argumentGetter ifNil: [^aProvider fullName].
	^argumentGetter value: aProvider! !

!SimpleServiceEntry methodsFor: 'performing service' stamp: 'nk 8/31/2004 19:30'!
performServiceFor: anObject
	"carry out the service I provide"

	^selector numArgs = 0
		ifTrue: [provider perform: selector]
		ifFalse: [
			selector numArgs = 1
				ifTrue: [ provider perform: selector with: (self getArgumentsFrom: anObject) ]
				ifFalse: [ provider perform: selector withArguments: (self getArgumentsFrom: anObject) ]]! !

!SimpleServiceEntry methodsFor: 'performing service' stamp: 'dgd 9/1/2003 12:13'!
provider: anObject label: aString selector: aSymbol description: anotherString 
	"basic initialization message"
	self
		provider: anObject
		label: aString
		selector: aSymbol.
	stateSelector := #none.
	description := anotherString translated! !

!SimpleServiceEntry methodsFor: 'performing service' stamp: 'hg 8/1/2000 19:49'!
requestSelector
	"send me this message to ask me to perform my service"

	^#performServiceFor:
! !


!SimpleServiceEntry methodsFor: 'printing' stamp: 'nk 10/14/2003 10:04'!
printOn: aStream

	aStream nextPutAll: self class name; nextPutAll: ': ('.
	self provider notNil
		ifTrue: [aStream nextPutAll: provider printString].
	aStream nextPutAll: ' --- '. 
	self selector notNil
		ifTrue: [aStream nextPutAll: selector asString].
	aStream nextPut: $)

! !


!SimpleServiceEntry methodsFor: 'services menu' stamp: 'nk 2/15/2004 16:16'!
addServiceFor: served toMenu: aMenu
	aMenu add: self label 
		target: self 
		selector: self requestSelector 
		argument: served.
	self useLineAfter ifTrue: [ aMenu addLine ].! !

!SimpleServiceEntry methodsFor: 'services menu' stamp: 'hg 8/1/2000 19:53'!
useLineAfter

	^useLineAfter == true! !

!SimpleServiceEntry methodsFor: 'services menu' stamp: 'hg 8/1/2000 19:54'!
useLineAfter: aBoolean

	useLineAfter _ aBoolean
! !


!SimpleServiceEntry methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:34'!
buildWith: builder in: aModel
	"Answer a button spec that will trigger the receiver service in aModel"
	| buttonSpec |
	buttonSpec := builder pluggableActionButtonSpec new.
	buttonSpec 
		model: self; 
		label: self buttonLabel;
		help: self description;
		action: (MessageSend receiver: aModel selector: #executeService: argument: self).
	^builder build: buttonSpec! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleServiceEntry class
	instanceVariableNames: ''!

!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'hg 8/1/2000 18:57'!
provider: anObject label: aString selector: aSymbol

	^self new provider: anObject label: aString selector: aSymbol! !

!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'sd 1/31/2002 22:05'!
provider: anObject label: aString selector: aSymbol description: anotherString

	^self new provider: anObject label: aString selector: aSymbol description: anotherString! !

!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'sw 2/17/2002 02:48'!
provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel
	"Answer a new service object with the given initializations.  This variant allows a custom button label to be provided, in order to preserve precious horizontal real-estate in the button pane, while still allowing more descriptive wordings in the popup menu"

	^ self new provider: anObject label: aString selector: aSymbol description: anotherString; buttonLabel: aLabel; yourself! !
Slider subclass: #SimpleSliderMorph
	instanceVariableNames: 'target arguments minVal maxVal truncate'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 14:17'!
actionSelector

	^ setValueSelector
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 14:17'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ setValueSelector _ nil].

	setValueSelector _ aSymbolOrString asSymbol.
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 16:17'!
arguments

	^ arguments
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 16:16'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/30/98 12:41'!
maxVal

	^ maxVal
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/30/98 12:41'!
maxVal: aNumber

	maxVal _ aNumber.
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/30/98 12:40'!
minVal

	^ minVal
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/30/98 12:41'!
minVal: aNumber

	minVal _ aNumber.
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 14:09'!
target

	^ target
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 14:09'!
target: anObject

	target _ anObject
! !


!SimpleSliderMorph methodsFor: 'copying' stamp: 'jm 1/29/98 16:18'!
updateReferencesUsing: aDictionary
	"Copy and update references in the arguments array during copying."

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !

!SimpleSliderMorph methodsFor: 'copying' stamp: 'tk 1/6/1999 19:24'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!SimpleSliderMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:35'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"arguments _ arguments.		All weakly copied"
minVal _ minVal veryDeepCopyWith: deepCopier.		"will be fast if integer"
maxVal _ maxVal veryDeepCopyWith: deepCopier.
truncate _ truncate veryDeepCopyWith: deepCopier.
! !


!SimpleSliderMorph methodsFor: 'e-toy support' stamp: 'yo 2/10/2005 20:38'!
isLikelyRecipientForMouseOverHalos

	self player ifNil: [^ false].
	self player getHeading = 0.0 ifTrue: [^ false].
	^ true.
! !


!SimpleSliderMorph methodsFor: 'initialization' stamp: 'jm 1/29/98 16:16'!
initialize

	super initialize.
	target _ nil.
	arguments _ EmptyArray.
	minVal _ 0.0.
	maxVal _ 1.0.
	truncate _ false.
! !


!SimpleSliderMorph methodsFor: 'menu' stamp: 'wiz 1/2/2006 10:02'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"To all the other Custom menu items add slider and targeting items."
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addSliderMenuItems: aCustomMenu hand: aHandMorph .
	self addTargetingMenuItems: aCustomMenu hand: aHandMorph .! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'wiz 1/2/2006 09:37'!
addSliderMenuItems: aCustomMenu hand: aHandMorph 
	"Add items to set slider parameters"
	aCustomMenu addLine.
	""
	aCustomMenu add: 'set action selector' translated action: #setActionSelector.
	aCustomMenu add: 'change arguments' translated action: #setArguments.
	""
	aCustomMenu add: 'set minimum value' translated action: #setMinVal.
	aCustomMenu add: 'set maximum value' translated action: #setMaxVal.
	""
	aCustomMenu addUpdating: #descendingString action: #toggleDescending.
	aCustomMenu addUpdating: #truncateString action: #toggleTruncate.
	! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'wiz 1/2/2006 09:29'!
addTargetingMenuItems: aCustomMenu hand: aHandMorph 
	"Add targeting menu items"
	aCustomMenu addLine.

	aCustomMenu add: 'set target' translated action: #targetWith:.
	aCustomMenu add: 'sight target' translated action: #sightTargets:.
	target
		ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:08'!
clearTarget

	target _ nil.
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:13'!
descendingString
	^ (self descending
		ifTrue: ['switch to ascending']
		ifFalse: ['switch to descending']) translated! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:06'!
setActionSelector
	| oldSel newSel |
	oldSel := setValueSelector isNil ifTrue: [''] ifFalse: [setValueSelector].
	newSel := FillInTheBlank 
				request: 'Please type the selector to be sent to
the target when this slider is changed' translated
				initialAnswer: oldSel.
	newSel isEmpty ifFalse: [self actionSelector: newSel]! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:09'!
setArguments

	| s newArgs newArgsArray |
	s _ WriteStream on: ''.
	arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
	newArgs _ FillInTheBlank
		request:
'Please type the arguments to be sent to the target
when this button is pressed separated by periods' translated
		initialAnswer: s contents.
	newArgs isEmpty ifFalse: [
		newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.
		self arguments: newArgsArray].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:05'!
setLabel

	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Please a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self label: newLabel].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:41'!
setMaxVal

	| newMaxVal |
	newMaxVal _ FillInTheBlank
		request: 'Maximum value?'
		initialAnswer: maxVal printString.
	newMaxVal isEmpty ifFalse: [
		maxVal _ newMaxVal asNumber.
		minVal _ minVal min: maxVal].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:42'!
setMinVal

	| newMinVal |
	newMinVal _ FillInTheBlank
		request: 'Minimum value?'
		initialAnswer: minVal printString.
	newMinVal isEmpty ifFalse: [
		minVal _ newMinVal asNumber.
		maxVal _ maxVal max: minVal].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/6/2000 17:13'!
setMinVal: newMinVal
	minVal _ newMinVal asNumber.
	maxVal _ maxVal max: minVal
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:55'!
setTarget: evt 
	| rootMorphs |
	rootMorphs _ self world rootMorphsAt: evt hand targetOffset.
	target _ rootMorphs size > 1
				ifTrue: [rootMorphs second]! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 11:40'!
toggleDescending

	descending _ self descending not
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:46'!
toggleTruncate

	truncate _ truncate not.
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:13'!
truncateString
	^ (truncate
		ifTrue: ['turn off truncation']
		ifFalse: ['turn on truncation'])  translated! !


!SimpleSliderMorph methodsFor: 'model access' stamp: 'dgd 2/22/2003 18:58'!
setValue: newValue 
	"Update the target with this sliders new value."

	| scaledValue |
	self value: newValue.
	scaledValue := newValue * (maxVal - minVal) + minVal.
	truncate ifTrue: [scaledValue := scaledValue truncated].
	(target notNil and: [setValueSelector notNil]) 
		ifTrue: 
			[Cursor normal showWhile: 
					[target perform: setValueSelector
						withArguments: (arguments copyWith: scaledValue)]]! !


!SimpleSliderMorph methodsFor: 'parts bin' stamp: 'sw 6/29/2001 12:24'!
initializeToStandAlone
	| nominalColor |

	self initialize.
	self beSticky.
	self extent: 14@120.
	nominalColor _ Color r: 0.452 g: 0.645 b: 0.935.
	self color: nominalColor.
	self borderColor: Color veryDarkGray.
	self sliderColor: nominalColor muchLighter.
	self descending: true.
	self setScaledValue: 0.3! !


!SimpleSliderMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 7/4/2004 01:53'!
arrowDeltaFor: aGetter
	"Here just for testing the arrowDelta feature.  To test, re-enable the code below by commenting out the first line, and you should see the minVal slot of the slider go up and down in increments of 5 as you work the arrows on its readout tile in a freshly-launched Viewer or detailed watcher"
	
	true ifTrue: [^ super arrowDeltaFor: aGetter]. 
	
	^ (aGetter == #getMinVal)
		ifTrue:
			[5]
		ifFalse:
			[1]! !

!SimpleSliderMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 9/1/2000 10:38'!
getNumericValue
	"Answer the numeric value of the receiver"

	^ self getScaledValue! !

!SimpleSliderMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 9/1/2000 10:38'!
setNumericValue: aValue
	"Set the numeric value of the receiver to be as indicated"

	^ self setScaledValue: aValue! !


!SimpleSliderMorph methodsFor: 'private' stamp: 'jm 1/30/98 13:17'!
adjustToValue: aNumber
	"Adjust the position of this slider to correspond to the given value in the range minVal..maxVal."
	"Details: Internal values are normalized to the range 0..1."

	self value:
		(aNumber - minVal) asFloat / (maxVal - minVal).
! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:48'!
getScaledValue
	| aValue |
	aValue _ (value * (maxVal - minVal)) + minVal.
	^ truncate ifTrue: [aValue truncated] ifFalse: [aValue]! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/6/2000 17:19'!
setMaxVal: newMaxVal
	maxVal _ newMaxVal asNumber.
	minVal _ maxVal min: minVal
! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/8/2000 16:22'!
setScaledValue: aNumber
	| denom |
	(denom _ maxVal - minVal) > 0
		ifTrue:
			[self setValue: (aNumber - minVal) / denom]
		ifFalse:
			[self setValue: maxVal]
	"If minVal = maxVal, that value is the only one this (rather unuseful!!) slider can bear"! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:54'!
truncate
	^ truncate == true! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:53'!
truncate: aBoolean
	truncate _ aBoolean! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleSliderMorph class
	instanceVariableNames: ''!

!SimpleSliderMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:04'!
initialize

	self registerInFlapsRegistry.	! !

!SimpleSliderMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:29'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(SimpleSliderMorph		authoringPrototype		'Slider'			'A slider for showing and setting numeric values.')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(SimpleSliderMorph		authoringPrototype		'Slider'			'A slider for showing and setting numeric values.')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(SimpleSliderMorph		authoringPrototype		'Slider'			'A slider for showing and setting numeric values.')
						forFlapNamed: 'Scripting']! !

!SimpleSliderMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:40'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!SimpleSliderMorph class methodsFor: 'parts bin' stamp: 'sw 8/12/2001 17:53'!
descriptionForPartsBin
	^ self partName:	'Slider'
		categories:		#('Scripting')
		documentation:	'A scriptable control that allows you to choose a numeric value by dragging a knob.'! !


!SimpleSliderMorph class methodsFor: 'printing' stamp: 'sw 3/8/2000 12:56'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ 'Slider'! !


!SimpleSliderMorph class methodsFor: 'scripting' stamp: 'sw 3/10/2000 13:45'!
authoringPrototype
	| aSlider nominalColor |
	"self currentHand attachMorph: SimpleSliderMorph authoringPrototype"

	aSlider _ super authoringPrototype beSticky.
	aSlider extent: 14@120.
	nominalColor _ Color r: 0.4 g: 0.86 b: 0.7.
	aSlider color: nominalColor.
	aSlider sliderColor: nominalColor muchLighter.
	aSlider descending: true.
	aSlider setScaledValue: 0.3.
	^ aSlider! !


!SimpleSliderMorph class methodsFor: '*eToys-scripting' stamp: 'nk 6/9/2003 06:05'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(
(slider (

(slot numericValue 'A number representing the current position of the knob.' Number readWrite Player getNumericValue Player setNumericValue:)

(slot minVal	 'The number represented when the knob is at the left or top of the slider; the smallest value returned by the slider.' Number readWrite	Player getMinVal Player setMinVal:)

(slot maxVal 'The number represented when the knob is at the right or bottom of the slider; the largest value returned by the slider.' Number readWrite	Player getMaxVal Player setMaxVal:)

(slot descending 'Tells whether the smallest value is at the top/left (descending = false) or at the bottom/right (descending = true)' Boolean readWrite Player getDescending Player setDescending:)

(slot truncate 'If true, only whole numbers are used as values; if false, fractional values are allowed.' Boolean readWrite	Player getTruncate Player setTruncate:)

(slot color 'The color of the slider' Color readWrite Player getColor  Player  setColor:)

(slot knobColor 'The color of the slider' Color readWrite Player getKnobColor Player setKnobColor:)
(slot  width  'The width' Number readWrite Player getWidth  Player  setWidth:)
(slot  height  'The height' Number readWrite Player getHeight  Player  setHeight:)))

(basic	(
(slot numericValue 'A number representing the current position of the knob.' Number readWrite Player getNumericValue Player setNumericValue:))))

! !
SimpleButtonMorph subclass: #SimpleSwitchMorph
	instanceVariableNames: 'onColor offColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!SimpleSwitchMorph commentStamp: 'apb 5/3/2006 16:04' prior: 0!
I represent a switch that can be either on or off.  I chnage my state in response to a mouse click.  When clicked, I also send my actionSelector to my target, just like a SimpleButtonMorph.!


!SimpleSwitchMorph methodsFor: 'button' stamp: 'dgd 2/22/2003 18:40'!
doButtonAction
	"Perform the action of this button. The last argument of the message sent to the target is the new state of this switch."

	| newState |
	(target notNil and: [actionSelector notNil]) 
		ifTrue: 
			[newState := color = onColor.
			target perform: actionSelector
				withArguments: (arguments copyWith: newState)]! !


!SimpleSwitchMorph methodsFor: 'copying' stamp: 'jm 1/29/98 16:15'!
updateReferencesUsing: aDictionary
	"Copy and update references in the arguments array during copying."

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !


!SimpleSwitchMorph methodsFor: 'event handling' stamp: 'ar 6/4/2001 00:39'!
mouseDown: evt

	oldColor _ self fillStyle.! !

!SimpleSwitchMorph methodsFor: 'event handling' stamp: 'jm 1/30/98 13:55'!
mouseMove: evt

	(self containsPoint: evt cursorPoint)
		ifTrue: [self setSwitchState: (oldColor = offColor)]
		ifFalse: [self setSwitchState: (oldColor = onColor)].
! !

!SimpleSwitchMorph methodsFor: 'event handling' stamp: 'jm 1/30/98 13:58'!
mouseUp: evt

	(self containsPoint: evt cursorPoint)
		ifTrue: [  "toggle and do action"
			self setSwitchState: (oldColor = offColor).
			self doButtonAction]
		ifFalse: [  "restore old appearance"
			self setSwitchState: (oldColor = onColor)].
! !


!SimpleSwitchMorph methodsFor: 'initialization' stamp: 'di 6/5/2000 08:44'!
initialize

	^ self initializeWithLabel: 'Toggle'
! !

!SimpleSwitchMorph methodsFor: 'initialization' stamp: 'apb 5/3/2006 15:51'!
initializeWithLabel: labelString

	super initializeWithLabel: labelString.
	self borderWidth: 3.
	self extent: self extent + 2.
	onColor := Color r: 1.0 g: 0.6 b: 0.6.
	offColor := Color lightGray.
	color := offColor
! !


!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:45'!
isOff
	^ color ~= onColor! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:45'!
isOn
	^ color = onColor! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'jm 1/29/98 20:18'!
offColor

	^ offColor
! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'jm 1/29/98 20:18'!
offColor: aColor

	offColor _ aColor.
! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'jm 1/29/98 20:18'!
onColor

	^ onColor
! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'jm 1/29/98 20:18'!
onColor: aColor

	onColor _ aColor.
! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:46'!
setSwitchState: aBoolean

	aBoolean
		ifTrue: [self turnOn]
		ifFalse: [self turnOff].
! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 16:11'!
toggleState
	self isOn
		ifTrue: [self turnOff]
		ifFalse: [self turnOn]! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:44'!
turnOff
	self borderColor: #raised.
	self color: offColor! !

!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:44'!
turnOn
	self borderColor: #inset.
	self color: onColor! !
ClassTestCase subclass: #SimpleSwitchMorphTest
	instanceVariableNames: 'testSwitch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Widgets'!
!SimpleSwitchMorphTest commentStamp: '<historical>' prior: 0!
I test the behavior of SimpleSwitchMorph!


!SimpleSwitchMorphTest methodsFor: 'as yet unclassified' stamp: 'apb 5/3/2006 16:05'!
classToBeTested
	^ SimpleSwitchMorph ! !

!SimpleSwitchMorphTest methodsFor: 'as yet unclassified' stamp: 'apb 5/3/2006 16:08'!
setUp
	super setUp.
	testSwitch := SimpleSwitchMorph new! !

!SimpleSwitchMorphTest methodsFor: 'as yet unclassified' stamp: 'apb 5/3/2006 16:17'!
testName

	self assert: testSwitch externalName = 'SimpleSwitch'! !

!SimpleSwitchMorphTest methodsFor: 'as yet unclassified' stamp: 'apb 5/3/2006 16:11'!
testState
	self assert: testSwitch isOff.
	self deny: testSwitch isOn.
	testSwitch toggleState.
	self assert: testSwitch isOn.
	self deny: testSwitch isOff! !

!SimpleSwitchMorphTest methodsFor: 'as yet unclassified' stamp: 'apb 5/3/2006 16:14'!
testSwitching

	testSwitch setSwitchState: false.
	self assert: testSwitch isOff.
	self assert: testSwitch color = testSwitch offColor.
	testSwitch setSwitchState: true.
	self assert: testSwitch isOn.
	self assert: testSwitch color = testSwitch onColor.! !
TestResource subclass: #SimpleTestResource
	instanceVariableNames: 'runningState hasRun hasSetup hasRanOnce'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!

!SimpleTestResource methodsFor: 'accessing'!
runningState

	^runningState
			! !

!SimpleTestResource methodsFor: 'accessing'!
runningState: aSymbol

	runningState := aSymbol
			! !


!SimpleTestResource methodsFor: 'running'!
setRun
	hasRun := true
			! !

!SimpleTestResource methodsFor: 'running'!
setUp
	
	self runningState: self startedStateSymbol.
	hasSetup := true
			! !

!SimpleTestResource methodsFor: 'running'!
startedStateSymbol

	^#started
			! !

!SimpleTestResource methodsFor: 'running'!
stoppedStateSymbol

	^#stopped
			! !

!SimpleTestResource methodsFor: 'running'!
tearDown

	self runningState: self stoppedStateSymbol
			! !


!SimpleTestResource methodsFor: 'testing'!
hasRun
	^hasRun
			! !

!SimpleTestResource methodsFor: 'testing'!
hasSetup
	^hasSetup
			! !

!SimpleTestResource methodsFor: 'testing'!
isAvailable
	
	^self runningState == self startedStateSymbol
			! !
TestCase subclass: #SimpleTestResourceTestCase
	instanceVariableNames: 'resource'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!

!SimpleTestResourceTestCase methodsFor: 'Not categorized'!
dummy
	self assert: true
			! !

!SimpleTestResourceTestCase methodsFor: 'Not categorized'!
error
	'foo' odd
			! !

!SimpleTestResourceTestCase methodsFor: 'Not categorized'!
fail
	self assert: false
			! !

!SimpleTestResourceTestCase methodsFor: 'Not categorized'!
setRun
	resource setRun
			! !

!SimpleTestResourceTestCase methodsFor: 'Not categorized'!
setUp
	resource := SimpleTestResource current
			! !

!SimpleTestResourceTestCase methodsFor: 'Not categorized'!
testRan
	| case |

	case := self class selector: #setRun.
	case run.
	self assert: resource hasSetup.
	self assert: resource hasRun
			! !

!SimpleTestResourceTestCase methodsFor: 'Not categorized'!
testResourceInitRelease
	| result suite error failure |
	suite := TestSuite new.
	suite addTest: (error := self class selector: #error).
	suite addTest: (failure := self class selector: #fail).
	suite addTest: (self class selector: #dummy).
	result := suite run.
	self assert: resource hasSetup
			! !

!SimpleTestResourceTestCase methodsFor: 'Not categorized'!
testResourcesCollection
	| collection |
	collection := self resources.
	self assert: collection size = 1
			! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleTestResourceTestCase class
	instanceVariableNames: ''!

!SimpleTestResourceTestCase class methodsFor: 'Not categorized'!
resources
	^Set new add: SimpleTestResource; yourself
			! !
TextContainer subclass: #SimplerTextContainer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Outliner'!

!SimplerTextContainer methodsFor: 'container protocol' stamp: 'RAA 7/30/2000 13:09'!
bottom

	^textMorph owner bottom! !

!SimplerTextContainer methodsFor: 'container protocol' stamp: 'RAA 7/30/2000 14:45'!
left 
	^ textMorph owner textMorphLeft! !

!SimplerTextContainer methodsFor: 'container protocol' stamp: 'RAA 7/30/2000 14:46'!
rectanglesAt: lineY height: lineHeight
	"Return a list of rectangles that are at least minWidth wide
	in the specified horizontal strip of the shadowForm.
	Cache the results for later retrieval if the owner does not change."
	| rects |

	lineY > textMorph owner bottom ifTrue: [^#()].
	rects _ Array with: (self left@lineY extent: textMorph width@lineHeight).
	"rects _ rects collect: [:r | r insetBy: OuterMargin@0]."
	^ rects! !

!SimplerTextContainer methodsFor: 'container protocol' stamp: 'RAA 7/30/2000 13:09'!
top

	^textMorph owner top! !
LanguageEnvironment subclass: #SimplifiedChineseEnvironment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Languages'!
!SimplifiedChineseEnvironment commentStamp: '<historical>' prior: 0!
This class provides the Simplified Chinese support (Used mainly in Mainland China).  Unfortunately, we haven't tested this yet, but as soon as we find somebody who understand the language, probably we can make it work in two days or so, as we have done for Czech support.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimplifiedChineseEnvironment class
	instanceVariableNames: ''!

!SimplifiedChineseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/16/2004 14:55'!
traditionalCharsetClass

	^ GB2312
! !


!SimplifiedChineseEnvironment class methodsFor: 'public query' stamp: 'nk 7/30/2004 21:46'!
defaultEncodingName
	| platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy].
	(#('Win32' 'Mac OS' 'ZaurusOS') includes: platformName) 
		ifTrue: [^'gb2312' copy].
	(#('unix') includes: platformName) ifTrue: [^'euc-cn' copy].
	^'mac-roman'! !


!SimplifiedChineseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'nk 7/30/2004 21:46'!
clipboardInterpreterClass
	| platformName osVersion |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) 
		ifTrue: [^NoConversionClipboardInterpreter].
	platformName = 'Win32' ifTrue: [^WinGB2312ClipboardInterpreter].
	platformName = 'Mac OS' 
		ifTrue: 
			[('10*' match: SmalltalkImage current osVersion) 
				ifTrue: [^NoConversionClipboardInterpreter]
				ifFalse: [^WinGB2312ClipboardInterpreter]].
	platformName = 'unix' 
		ifTrue: 
			[(ShiftJISTextConverter encodingNames includes: X11Encoding getEncoding) 
				ifTrue: [^MacShiftJISClipboardInterpreter]
				ifFalse: [^NoConversionClipboardInterpreter]].
	^NoConversionClipboardInterpreter! !

!SimplifiedChineseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'nk 7/30/2004 21:46'!
inputInterpreterClass
	| platformName osVersion encoding |
	platformName := SmalltalkImage current platformName.
	osVersion := SmalltalkImage current getSystemAttribute: 1002.
	(platformName = 'Win32' and: [osVersion = 'CE']) 
		ifTrue: [^MacRomanInputInterpreter].
	platformName = 'Win32' ifTrue: [^WinGB2312InputInterpreter].
	platformName = 'Mac OS' 
		ifTrue: 
			[('10*' match: SmalltalkImage current osVersion) 
				ifTrue: [^MacUnicodeInputInterpreter]
				ifFalse: [^WinGB2312InputInterpreter]].
	platformName = 'unix' 
		ifTrue: 
			[encoding := X11Encoding encoding.
			(EUCJPTextConverter encodingNames includes: encoding) 
				ifTrue: [^MacRomanInputInterpreter].
			(UTF8TextConverter encodingNames includes: encoding) 
				ifTrue: [^MacRomanInputInterpreter].
			(ShiftJISTextConverter encodingNames includes: encoding) 
				ifTrue: [^MacRomanInputInterpreter]].
	^MacRomanInputInterpreter! !

!SimplifiedChineseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:22'!
supportedLanguages
	"Return the languages that this class supports. 
	Any translations for those languages will use this class as their environment."
	
	^#('zh' )! !
Morph subclass: #SketchEditorMorph
	instanceVariableNames: 'hostView palette ticksToDwell rotationCenter registrationPoint newPicBlock emptyPicBlock paintingForm dimForm formCanvas rotationButton scaleButton cumRot cumMag undoBuffer enclosingPasteUpMorph forEachHand'
	classVariableNames: 'SketchTimes'
	poolDictionaries: ''
	category: 'MorphicExtras-Support'!
!SketchEditorMorph commentStamp: '<historical>' prior: 0!
Inst vars (converting to morphic events)
hostView -- SketchMorph we are working on.
stampForm -- Stamp is stored here.
canvasRectangle -- later use bounds
palette -- the PaintBox interface Morph
dirty -- not used
currentColor 
ticksToDwell rotationCenter registrationPoint 
newPicBlock -- do this after painting
action -- selector of painting action
paintingForm -- our copy
composite -- now paintArea origin.  world relative.  stop using it.
dimForm -- SketchMorph of the dimmed background.  Opaque.  
		installed behind the editor morph.
buff 
brush -- 1-bit Form of the brush, 
paintingFormPen 
formCanvas -- Aim it at paintingForm to allow it to draw ovals, rectangles, lines, etc.
picToComp dimToComp compToDisplay -- used to composite -- obsolete
picToBuff brushToBuff buffToBuff buffToPic 
rotationButton scaleButton -- submorphs, handles to do these actions.
strokeOrigin -- During Pickup, origin of rect. 
cumRot cumMag -- cumulative for multiple operations from same original
undoBuffer 
lastEvent 
currentNib -- 1 bit deep form.


For now, we do not carry the SketchMorph's registration point, rotation center, or ticksToDwell.

New -- using transform morphs to rotate the finished player.  How get it rotated back and the rotationDegrees to be right?  We cancel out rotationDegrees, so how remember it?

Registration point convention:  
In a GraphicFrame, reg point is relative to this image's origin.
During painting, it is relative to canvasRectangle origin, and thus us absolute within the canvas.  To convert back, subract newBox origin.

Be sure to convert back and forth correctly.  In deliverPainting. initializeFromFrame:inView: !


!SketchEditorMorph methodsFor: 'access' stamp: 'sw 9/2/1999 11:03'!
enclosingPasteUpMorph
	^ enclosingPasteUpMorph! !

!SketchEditorMorph methodsFor: 'access'!
hostView
	^ hostView! !

!SketchEditorMorph methodsFor: 'access'!
painting
	^ paintingForm! !

!SketchEditorMorph methodsFor: 'access'!
palette
	^palette! !

!SketchEditorMorph methodsFor: 'access'!
registrationPoint
	^ registrationPoint! !

!SketchEditorMorph methodsFor: 'access'!
registrationPoint: aPoint
	registrationPoint _ aPoint! !

!SketchEditorMorph methodsFor: 'access' stamp: 'dgd 2/21/2003 23:07'!
ticksToDwell
	ticksToDwell isNil ifTrue: [ticksToDwell := 1].
	^ticksToDwell! !

!SketchEditorMorph methodsFor: 'access'!
ticksToDwell: t
	ticksToDwell _ t! !


!SketchEditorMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 20:35'!
forwardDirection
	"The direction object will go when issued a sent forward:.  Up is
zero.  Clockwise like a compass.  From the arrow control."
	^ hostView forwardDirection! !


!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 10/21/97 16:32'!
clear
	"wipe out all the paint"

	self polyFreeze.		"end polygon mode"
	paintingForm fillWithColor: Color transparent.
	self invalidRect: bounds.! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 4/21/2004 13:23'!
ellipse: evt
	"Draw an ellipse from the center. "

	| rect oldRect ww ext oldExt cColor sOrigin priorEvt |

	sOrigin _ self get: #strokeOrigin for: evt.
	cColor _ self getColorFor: evt.
	ext _ (sOrigin - evt cursorPoint) abs * 2.
	evt shiftPressed ifTrue: [ext _ self shiftConstrainPoint: ext].
	rect _ Rectangle center: sOrigin extent: ext.
	ww _ (self getNibFor: evt) width.
	(priorEvt _ self get: #lastEvent for: evt) ifNotNil: [
		oldExt _ (sOrigin - priorEvt cursorPoint) abs + ww * 2.
		priorEvt shiftPressed ifTrue: [oldExt _ self shiftConstrainPoint: oldExt].
		(oldExt < ext) ifFalse: ["Last draw sticks out, must erase the area"
			oldRect _ Rectangle center: sOrigin extent: oldExt.
			self restoreRect: oldRect]].
	cColor == Color transparent
		ifFalse:
			[formCanvas fillOval: rect color: Color transparent borderWidth: ww borderColor: cColor]
		ifTrue:
			[formCanvas fillOval: rect color: cColor borderWidth: ww borderColor: Color black].

	self invalidRect: rect.

! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 7/2/97 09:02'!
erase: evt
	"Pen is set up to draw transparent squares"
	self paint: evt
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:30'!
erasePrep: evt
	"Transparent paint, square brush.  Be careful not to let this be undone by asking palette for brush and color."

	| size pfPen myBrush |

	pfPen _ self get: #paintingFormPen for: evt.
	size _ (self getNibFor: evt) width.
	self set: #brush for: evt to: (myBrush _ Form extent: size@size depth: 1).
	myBrush offset: (0@0) - (myBrush extent // 2).
	myBrush fillWithColor: Color black.
	pfPen sourceForm: myBrush.
	"transparent"
	pfPen combinationRule: Form erase1bitShape.
	pfPen color: Color black.
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 12/19/2000 19:53'!
fill: evt 
	"Find the area that is the same color as where you clicked. Fill it with 
	the current paint color."
	| box |
	evt isMouseUp
		ifFalse: [^ self].
	"Only fill upon mouseUp"
	"would like to only invalidate the area changed, but can't find out what it is."
	Cursor execute
		showWhile: [
			box _ paintingForm
				floodFill: (self getColorFor: evt)
				at: evt cursorPoint - bounds origin.
			self render: (box translateBy: bounds origin)]! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'!
flipHoriz: evt 
	"Flip the image"
	| temp myBuff |

	myBuff _ self get: #buff for: evt.
	temp _ myBuff deepCopy flipBy: #horizontal centerAt: myBuff center.
	temp offset: 0 @ 0.
	paintingForm fillWithColor: Color transparent.
	temp displayOn: paintingForm at: paintingForm center - myBuff center + myBuff offset.
	rotationButton position: evt cursorPoint x - 6 @ rotationButton position y.
	self render: bounds! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'!
flipVert: evt 
	"Flip the image"
	| temp myBuff |

	myBuff _ self get: #buff for: evt.
	temp _ myBuff deepCopy flipBy: #vertical centerAt: myBuff center.
	temp offset: 0 @ 0.
	paintingForm fillWithColor: Color transparent.
	temp displayOn: paintingForm at: paintingForm center - myBuff center + myBuff offset.
	rotationButton position: evt cursorPoint x - 6 @ rotationButton position y.
	self render: bounds! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'aoy 2/15/2003 21:46'!
forward: evt direction: button 
	"Move the forward direction arrow of this painting.  When the user
says forward:, the object moves in the direction of the arrow.  evt may be
an Event (from the user moving the arrow), or an initial number ofdegrees."

	| center dir ww ff |
	center := bounds center.	"+ (rotationButton width - 6 @ 0)"
	dir := evt isNumber 
				ifTrue:  
					[Point r: 100 degrees: evt - 90.0
					"convert to 0 on X axis"]
				ifFalse: [evt cursorPoint - center].
	ww := (bounds height min: bounds width) // 2 - 7.
	button 
		setVertices: (Array with: center + (Point r: ww degrees: dir degrees)
				with: center + (Point r: ww - 15 degrees: dir degrees)).
	(ff := self valueOfProperty: #fwdToggle) 
		position: center + (Point r: ww - 7 degrees: dir degrees + 6.5) 
				- (ff extent // 2).
	self showDirType! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:54'!
line: evt 
	"Draw a line on the paintingForm using formCanvas aimed at it."
	| rect oldRect ww now diff cor cColor sOrigin priorEvt |
	sOrigin _ self get: #strokeOrigin for: evt.
	rect _ sOrigin rect: (now _ evt cursorPoint).
	evt shiftPressed
		ifTrue: [diff _ evt cursorPoint - sOrigin.
			now _ sOrigin
						+ (Point r: diff r degrees: diff degrees + 22.5 // 45 * 45).
			rect _ sOrigin rect: now].
	ww _ (self getNibFor: evt) width.
	(priorEvt _ self get: #lastEvent for: evt)
		ifNotNil: [oldRect _ sOrigin rect: priorEvt cursorPoint.
			priorEvt shiftPressed
				ifTrue: [diff _ priorEvt cursorPoint - sOrigin.
					cor _ sOrigin
								+ (Point r: diff r degrees: diff degrees + 22.5 // 45 * 45).
					oldRect _ sOrigin rect: cor].
			oldRect _ oldRect expandBy: ww @ ww.
			"Last draw will always stick out, must erase the area"
			self restoreRect: oldRect].
	cColor _ self getColorFor: evt.
	formCanvas
		line: sOrigin
		to: now
		width: ww
		color: cColor.
	self invalidRect: rect! !

!SketchEditorMorph methodsFor: 'actions & preps'!
notes
	"
Singleton costumes.
Registration points
"! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:22'!
paint: evt
	"While the mouse is down, lay down paint, but only within window bounds.
	 11/28/96 sw: no longer stop painting when pen strays out of window; once it comes back in, resume painting rather than waiting for a mouse up"

	|  mousePoint startRect endRect startToEnd pfPen myBrush |

	pfPen _ self get: #paintingFormPen for: evt.
	myBrush _ self getBrushFor: evt.
	mousePoint _ evt cursorPoint.
	startRect _ pfPen location + myBrush offset extent: myBrush extent.
	pfPen goto: mousePoint - bounds origin.
	endRect _ pfPen location + myBrush offset extent: myBrush extent.
	"self render: (startRect merge: endRect).	Show the user what happened"
	startToEnd _ startRect merge: endRect.
	self invalidRect: (startToEnd translateBy: bounds origin).
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'dgd 2/21/2003 23:06'!
pickup: evt 
	"Grab a part of the picture (or screen) and store it in a known place.  Note where we started.  Use a rubberband rectangle to show what is being selected."

	| rect oldRect sOrigin priorEvt |
	sOrigin := self get: #strokeOrigin for: evt.
	rect := sOrigin rect: evt cursorPoint + (14 @ 14).
	(priorEvt := self get: #lastEvent for: evt) isNil 
		ifFalse: 
			["Last draw will stick out, must erase the area"

			oldRect := sOrigin rect: priorEvt cursorPoint + (14 @ 14).
			self restoreRect: (oldRect insetBy: -2)].
	formCanvas 
		frameAndFillRectangle: (rect insetBy: -2)
		fillColor: Color transparent
		borderWidth: 2
		borderColor: Color gray.
	self invalidRect: (rect insetBy: -2)! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'dgd 2/21/2003 23:06'!
pickupMouseUp: evt 
	"Grab a part of the picture (or screen) and store it in a known place. Like Copy on the Mac menu. Then switch to the stamp tool."

	| rr pForm ii oldRect sOrigin priorEvt |
	sOrigin := self get: #strokeOrigin for: evt.
	(priorEvt := self get: #lastEvent for: evt) isNil 
		ifFalse: 
			["Last draw will stick out, must erase the area"

			oldRect := sOrigin rect: priorEvt cursorPoint + (14 @ 14).
			self restoreRect: (oldRect insetBy: -2)].
	self primaryHand showTemporaryCursor: nil.	"later get rid of this"
	rr := sOrigin rect: evt cursorPoint + (14 @ 14).
	ii := rr translateBy: 0 @ 0 - bounds origin.
	(rr intersects: bounds) 
		ifTrue: 
			[pForm := paintingForm copy: ii.
			pForm isAllWhite 
				ifFalse: 
					["means transparent"

					"normal case.  Can be transparent in parts"

					]
				ifTrue: 
					[pForm := nil
					"Get an un-dimmed picture of other objects on the playfield"
					"don't know how yet"]].
	pForm ifNil: [pForm := Form fromDisplay: rr].	"Anywhere on the screen"
	palette pickupForm: pForm evt: evt.
	evt hand showTemporaryCursor: (self getCursorFor: evt)! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:40'!
polyEdit: evt
	"Add handles and let user drag'em around"
	| poly |
	poly _ self valueOfProperty: #polygon.
	poly ifNil:[^self].
	poly addHandles.
	self polyEditing: true.
	self setProperty: #polyCursor toValue: palette plainCursor.
	palette plainCursor: Cursor normal event: evt.! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:28'!
polyEditing
	^self valueOfProperty: #polyEditing ifAbsent:[false]! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:28'!
polyEditing: aBool
	aBool
		ifTrue:[self setProperty: #polyEditing toValue: aBool]
		ifFalse:[self removeProperty: #polyEditing]! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:29'!
polyFreeze
	"A live polygon is on the painting.  Draw it into the painting and
delete it."

	| poly |
	self polyEditing ifFalse:[^self].
	(poly _ self valueOfProperty: #polygon) ifNil: [^ self].
	poly drawOn: formCanvas.
	poly delete.
	self setProperty: #polygon toValue: nil.
	self polyEditing: false.! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 7/5/2004 03:20'!
polyNew: evt
	"Create a new polygon.  Add it to the sketch, and let the user drag
its vertices around!!  Freeze it into the painting when the user chooses
another tool."

	| poly cColor |
	self polyEditing ifTrue:[
		self polyFreeze.
		(self hasProperty: #polyCursor)
			ifTrue:[palette plainCursor: (self valueOfProperty: #polyCursor) event: evt.
					self removeProperty: #polyCursor].
		^self].
	cColor _ self getColorFor: evt.
	self polyFreeze.		"any old one we were working on"
	poly _ PolygonMorph new "addHandles".
	poly referencePosition: poly bounds origin.
	poly align: poly bounds center with: evt cursorPoint.
	poly borderWidth: (self getNibFor: evt) width.
	poly borderColor: (cColor isTransparent ifTrue: [Color black] ifFalse: [cColor]).
	poly color: Color transparent.
	self addMorph: poly.
	poly changed.
	self setProperty: #polygon toValue: poly.! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:22'!
polygon: evt
	| poly |
	poly _ self valueOfProperty: #polygon.
	poly ifNil:[^self].
	evt cursorPoint > poly bounds origin ifTrue:[
		poly extent: ((evt cursorPoint - poly bounds origin) max: 5@5)].! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 7/25/2004 03:16'!
rect: evt 
	"While moving corner, just write on the canvas. When done, write on the paintingForm"

	| rect oldRect now diff cor cColor sOrigin priorEvt |
	sOrigin _ self get: #strokeOrigin for: evt.
	rect _ sOrigin rect: (now _ evt cursorPoint).
	cColor _ self getColorFor: evt.
	evt shiftPressed
		ifTrue: [diff _ evt cursorPoint - sOrigin.
			now _ sOrigin
						+ (Point r: (diff x abs min: diff y abs)
									* 2 degrees: diff degrees // 90 * 90 + 45).
			rect _ sOrigin rect: now].
	(priorEvt _ self get: #lastEvent for: evt) isNil
		ifFalse: [oldRect _ sOrigin rect: priorEvt cursorPoint.
			priorEvt shiftPressed
				ifTrue: [diff _ priorEvt cursorPoint - sOrigin.
					cor _ sOrigin
								+ (Point r: (diff x abs min: diff y abs)
											* 2 degrees: diff degrees // 90 * 90 + 45).
					oldRect _ sOrigin rect: cor].
		self restoreRect: oldRect].  		"Last draw will stick out, must erase the area"

	cColor == Color transparent
		ifTrue: [formCanvas
				frameAndFillRectangle: rect
				fillColor: Color transparent
				borderWidth: (self getNibFor: evt) width
				borderColor: Color black]
		ifFalse: [formCanvas
				frameAndFillRectangle: rect
				fillColor: Color transparent
				borderWidth: (self getNibFor: evt) width
				borderColor: cColor].
	self invalidRect: rect! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 17:13'!
render: damageRect
	"Compose the damaged area again and store on the display.  damageRect is relative to paintingForm origin.  3/19/97 tk"

	self invalidRect: damageRect.	"Now in same coords as self bounds"
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 6/16/97 15:38'!
replaceOnly: initialMousePoint
	"Paint replacing only one color!!  Call this each stroke.  Also works for replacing all but one color.  "

! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 2/12/2000 18:35'!
restoreRect: oldRect
	"Restore the given rectangular area of the painting Form from the undo buffer."

	formCanvas drawImage: undoBuffer
		at: oldRect origin
		sourceRect: (oldRect translateBy: self topLeft negated).
	self invalidRect: oldRect.
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:07'!
rotateBy: evt 
	"Left-right is rotation. 3/26/97 tk Slider at top of window. 4/3/97 tk"
	| pt temp amt smooth myBuff |

	myBuff _ self get: #buff for: evt.
	evt cursorPoint x - self left < 20
		ifTrue: [^ self flipHoriz: evt].
	"at left end flip horizontal"
	evt cursorPoint x - self right > -20
		ifTrue: [^ self flipVert: evt].
	"at right end flip vertical"
	pt _ evt cursorPoint - bounds center.
	smooth _ 2.
	"paintingForm depth > 8 ifTrue: [2] ifFalse: [1]."
	"Could go back to 1 for speed"
	amt _ pt x abs < 12
				ifTrue: ["detent"
					0]
				ifFalse: [pt x - (12 * pt x abs // pt x)].
	amt _ amt * 1.8.
	temp _ myBuff
				rotateBy: amt
				magnify: cumMag
				smoothing: smooth.
	temp displayOn: paintingForm at: paintingForm center - temp center + myBuff offset.
	rotationButton position: evt cursorPoint x - 6 @ rotationButton position y.
	self render: bounds.
	cumRot _ amt! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: '6/13/97 17:55 '!
rotateDone: evt
	"MouseUp, snap box back to center."

"
self render: rotationButton bounds.
rotationButton position: (canvasRectangle width // 2 + composite x) @ rotationButton position y.
self render: rotationButton bounds.
"		"Not snap back..."! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/29/2000 10:01'!
rotateScalePrep: evt
	"Make a source that is the paintingForm.  Work from that.  3/26/97 tk"

	| newBox myBuff |

	(self getActionFor: evt) == #scaleOrRotate ifTrue: [^ self].	"Already doing it"
	paintingForm width > 120 
		ifTrue: [newBox _ paintingForm rectangleEnclosingPixelsNotOfColor: Color transparent.
			"minimum size"
			newBox _ newBox insetBy: 
				((18 - newBox width max: 0)//2) @ ((18 - newBox height max: 0)//2) * -1]
		ifFalse: [newBox _ paintingForm boundingBox].
	newBox _ newBox expandBy: 1.
	self set: #buff for: evt to: (myBuff _ Form extent: newBox extent depth: paintingForm depth).
	myBuff offset: newBox center - paintingForm center.
	myBuff copyBits: newBox from: paintingForm at: 0@0 
		clippingBox: myBuff boundingBox rule: Form over fillColor: nil.
	"Could just run up owner chain asking colorUsed, but may not be embedded"
	cumRot _ 0.0.  cumMag _ 1.0.	"start over"
	self set: #changed for: evt to: true.
	self set: #action for: evt to: #scaleOrRotate.
		"Only changed by mouseDown with tool in paint area"! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'!
scaleBy: evt 
	"up-down is scale. 3/26/97 tk Now a slider on the right."
	| pt temp cy oldRect amt myBuff |

	myBuff _ self get: #buff for: evt.
	pt _ evt cursorPoint - bounds center.
	cy _ bounds height * 0.5.
	oldRect _ myBuff boundingBox expandBy: myBuff extent * cumMag / 2.
	amt _ pt y abs < 12
				ifTrue: ["detent"
					1.0]
				ifFalse: [pt y - (12 * pt y abs // pt x)].
	amt _ amt asFloat / cy + 1.0.
	temp _ myBuff
				rotateBy: cumRot
				magnify: amt
				smoothing: 2.
	cumMag > amt
		ifTrue: ["shrinking"
			oldRect _ oldRect translateBy: paintingForm center - oldRect center + myBuff offset.
			paintingForm
				fill: (oldRect expandBy: 1 @ 1)
				rule: Form over
				fillColor: Color transparent].
	temp displayOn: paintingForm at: paintingForm center - temp center + myBuff offset.
	scaleButton position: scaleButton position x @ (evt cursorPoint y - 6).
	self render: bounds.
	cumMag _ amt! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 2/15/2001 07:18'!
shiftConstrainPoint: aPoint

	"answer a point with x and y equal for shift-constrained drawing"

	^aPoint max: aPoint transposed! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 9/3/97 21:11'!
showDirType
	"Display the proper symbol for this direction type.  rotationStyle
is one of #(normal leftRight upDown none)."

| rr poly |
rr _ self rotationStyle.
poly _ self valueOfProperty: #fwdButton.
rr == #normal ifTrue: [^ poly makeBackArrow].
rr == #leftRight ifTrue: [
	poly makeBothArrows.
	^ poly setVertices: (Array with: poly center - (7@0) with:  poly
center + (7@0))].
rr == #upDown ifTrue: [
	poly makeBothArrows.
	^ poly setVertices: (Array with: poly center - (0@7) with:  poly
center + (0@7))].
rr == #none ifTrue: [
	poly makeNoArrows.
	^ poly setVertices: (Array with: poly center - (7@0) with:  poly
center + (7@0)
		 with: poly center with: poly center - (0@7) with:  poly
center + (0@7))].
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 17:43'!
stamp: evt
	"plop one copy of the user's chosen Form down."

	"Check depths"
	| pt sForm |

	sForm _ self get: #stampForm for: evt.
	pt _ evt cursorPoint - (sForm extent // 2).
	sForm displayOn: paintingForm 
		at: pt - bounds origin
		clippingBox: paintingForm boundingBox
		rule: Form paint
		fillColor: nil.
	self render: (pt extent: sForm extent).
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 7/5/2004 03:10'!
star: evt 
	"Draw an star from the center."
	| poly ext ww rect oldExt oldRect oldR verts pt cColor sOrigin priorEvt |
	sOrigin _ self get: #strokeOrigin for: evt.
	cColor _ self getColorFor: evt.
	ww _ (self getNibFor: evt) width.
	ext _ (pt _ sOrigin - evt cursorPoint) r + ww * 2.
	rect _ Rectangle center: sOrigin extent: ext.
	(priorEvt _ self get: #lastEvent for: evt)
		ifNotNil: [oldExt _ (sOrigin - priorEvt cursorPoint) r + ww * 2.
			"Last draw sticks out, must erase the area"
			oldRect _ Rectangle center: sOrigin extent: oldExt.
			self restoreRect: oldRect].
	ext _ pt r.
	oldR _ ext.
	verts _ (0 to: 350 by: 36)
				collect: [:angle | (Point r: (oldR _ oldR = ext
									ifTrue: [ext * 5 // 12]
									ifFalse: [ext]) degrees: angle + pt degrees)
						+ sOrigin].
	poly _ PolygonMorph new addHandles.
	poly borderColor: (cColor isTransparent ifTrue: [Color black] ifFalse: [cColor]).
	poly borderWidth: (self getNibFor: evt) width.
	poly fillStyle: Color transparent.

	"can't handle thick brushes"
	self invalidRect: rect.
	"self addMorph: poly."
	poly privateOwner: self.
	poly
		bounds: (sOrigin extent: ext).
	poly setVertices: verts.
	poly drawOn: formCanvas.
	"poly delete."
	self invalidRect: rect! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 9/3/97 21:17'!
toggleDirType: evt in: handle
	"Toggle from 'rotate' to 'to and fro' to 'up and down' to 'none'
for the kind of rotation the object does.  An actor's rotationStyle is one
of #(normal leftRight upDown none)."

| rr ii |
"Clear the indicator"

"Find new style, store it, install the indicator"
rr _ self rotationStyle.
ii _ #(normal leftRight upDown none) indexOf: rr.
self setProperty: #rotationStyle toValue:
	(#(leftRight upDown none normal) at: ii).
ii = 4 ifTrue: ["normal" self forward: self forwardDirection
			direction: (self valueOfProperty: #fwdButton)]
	ifFalse: [self showDirType.].! !


!SketchEditorMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:24'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
hostView _ deepCopier references at: hostView ifAbsent: [hostView].
enclosingPasteUpMorph _ deepCopier references at: enclosingPasteUpMorph 
			ifAbsent: [enclosingPasteUpMorph].! !

!SketchEditorMorph methodsFor: 'copying' stamp: 'RAA 8/16/2000 12:29'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"hostView _ hostView.		Weakly copied"
	"stampForm _ stampForm veryDeepCopyWith: deepCopier."
	"canvasRectangle _ canvasRectangle veryDeepCopyWith: deepCopier."
palette _ palette veryDeepCopyWith: deepCopier.
	"currentColor _ currentColor veryDeepCopyWith: deepCopier."
ticksToDwell _ ticksToDwell veryDeepCopyWith: deepCopier.
rotationCenter _ rotationCenter veryDeepCopyWith: deepCopier.
registrationPoint _ registrationPoint veryDeepCopyWith: deepCopier.
newPicBlock _ newPicBlock veryDeepCopyWith: deepCopier.
emptyPicBlock _ emptyPicBlock veryDeepCopyWith: deepCopier.
	"action _ action veryDeepCopyWith: deepCopier."
paintingForm _ paintingForm veryDeepCopyWith: deepCopier.
dimForm _ dimForm veryDeepCopyWith: deepCopier.
	"buff _ buff veryDeepCopyWith: deepCopier."
	"brush _ brush veryDeepCopyWith: deepCopier."
	"paintingFormPen _ paintingFormPen veryDeepCopyWith: deepCopier."
formCanvas _ formCanvas veryDeepCopyWith: deepCopier.
	"picToBuff _ picToBuff veryDeepCopyWith: deepCopier."
	"brushToBuff _ brushToBuff veryDeepCopyWith: deepCopier."
	"buffToBuff _ buffToBuff veryDeepCopyWith: deepCopier."
	"buffToPic _ buffToPic veryDeepCopyWith: deepCopier."
rotationButton _ rotationButton veryDeepCopyWith: deepCopier.
scaleButton _ scaleButton veryDeepCopyWith: deepCopier.
	"strokeOrigin _ strokeOrigin veryDeepCopyWith: deepCopier."
cumRot _ cumRot veryDeepCopyWith: deepCopier.
cumMag _ cumMag veryDeepCopyWith: deepCopier.
undoBuffer _ undoBuffer veryDeepCopyWith: deepCopier.
	"lastEvent _ lastEvent veryDeepCopyWith: deepCopier."
	"currentNib _ currentNib veryDeepCopyWith: deepCopier."
enclosingPasteUpMorph _ enclosingPasteUpMorph.	"weakly copied"
forEachHand _ nil.	"hmm..."                              ! !


!SketchEditorMorph methodsFor: 'drawing' stamp: 'RAA 8/31/2000 13:49'!
drawOn: aCanvas
	"Put the painting on the display"

	color isTransparent ifFalse: [
		aCanvas fillRectangle: bounds color: color
	].
	paintingForm ifNotNil: [
		aCanvas paintImage: paintingForm at: bounds origin].

 ! !


!SketchEditorMorph methodsFor: 'event handling' stamp: 'jm 7/28/97 11:49'!
handlesMouseDown: evt

	^ true
! !

!SketchEditorMorph methodsFor: 'event handling'!
handlesMouseOver: evt
	^true! !

!SketchEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:51'!
handlesMouseOverDragging: evt
	^true! !

!SketchEditorMorph methodsFor: 'event handling' stamp: 'sw 7/5/2004 03:23'!
mouseEnter: evt
	"Set the cursor.  Reread colors if embedded editable polygon needs it."

	| poly cColor |
	super mouseEnter: evt.
	(self get: #action for: evt) == #scaleOrRotate ifTrue: [
		self set: #action for: evt to: (self get: #priorAction for: evt).
		].	"scale and rotate are not real modes.  If we enter with one, wear the previous tool."
	evt hand showTemporaryCursor: (self getCursorFor: evt).
	palette getSpecial == #polygon: ifFalse: [^self].
	(poly _ self valueOfProperty: #polygon) ifNil: [^ self].
	cColor _ self getColorFor: evt.
	poly borderColor: cColor; borderWidth: (self getNibFor: evt) width.
	poly changed.! !

!SketchEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:07'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!SketchEditorMorph methodsFor: 'event handling' stamp: 'jm 5/22/1998 10:15'!
mouseLeave: evt
	"Revert to the normal hand cursor."

	super mouseLeave: evt.
	evt hand showTemporaryCursor: nil.  "back to normal"
	"If this is modified to close down the SketchEditorMorph in any way, watch out for how it is called when entering a rotationButton and a scaleButton."
! !

!SketchEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!SketchEditorMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:45'!
mouseMove: evt 
	"In the middle of drawing a stroke.  6/11/97 19:51 tk"

	| pt priorEvt |
	WorldState canSurrenderToOS: false.	"we want maximum responsiveness"
	pt := evt cursorPoint.
	priorEvt := self get: #lastEvent for: evt.
	(priorEvt notNil and: [pt = priorEvt cursorPoint]) ifTrue: [^self].
	self perform: (self getActionFor: evt) with: evt.
	"Each action must do invalidRect:"
	self 
		set: #lastEvent
		for: evt
		to: evt.
	false 
		ifTrue: 
			["So senders will find the things performed here"

			self
				paint: nil;
				fill: nil;
				erase: nil;
				pickup: nil;
				stamp: nil.
			self
				rect: nil;
				ellipse: nil;
				polygon: nil;
				line: nil;
				star: nil]! !

!SketchEditorMorph methodsFor: 'event handling' stamp: 'ar 12/19/2000 00:20'!
mouseUp: evt
	| myAction |
	"Do nothing except those that work on mouseUp."

	myAction _ self getActionFor: evt.
	myAction == #fill: ifTrue: [
		self perform: myAction with: evt.
		"Each action must do invalidRect:"
		].
	myAction == #pickup: ifTrue: [
		self pickupMouseUp: evt].
	myAction == #polygon: ifTrue: [self polyEdit: evt].	"a mode lets you drag vertices"
	self set: #lastEvent for: evt to: nil.
! !


!SketchEditorMorph methodsFor: 'e-toy support' stamp: 'tk 9/3/97 17:12'!
rotationStyle

^ (self valueOfProperty: #rotationStyle) ifNil: [#normal]! !

!SketchEditorMorph methodsFor: 'e-toy support' stamp: 'yo 2/17/2005 14:31'!
wantsHaloFromClick

	^ Preferences eToyFriendly not.
! !


!SketchEditorMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color white alpha: 0.5! !

!SketchEditorMorph methodsFor: 'initialization' stamp: 'ar 6/2/2001 16:54'!
initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph
	| aPaintBox newPaintBoxBounds worldBounds requiredWidth newOrigin aPosition aPal aTab paintBoxFullBounds |
	(aTab _ self world paintingFlapTab) ifNotNil:
		[aTab showFlap.
		^ self initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph paintBoxPosition: nil].

	aPaintBox _ self world paintBox.
	worldBounds _ self world bounds.
	requiredWidth _ aPaintBox width.

	aPosition _ (aPal _ aPasteUpMorph standardPalette)
		ifNotNil:
			[aPal showNoPalette.
			aPal topRight + (aPaintBox width negated @ 0 "aPal tabsMorph height")]
		ifNil:
			[boundsToUse topRight].

	newOrigin _ ((aPosition x  + requiredWidth <= worldBounds right) or: [Preferences unlimitedPaintArea])
			ifTrue:  "will fit to right of aPasteUpMorph"
				[aPosition]
			ifFalse:  "won't fit to right, try left"
				[boundsToUse topLeft - (requiredWidth @ 0)].
	paintBoxFullBounds _ aPaintBox maxBounds.
	paintBoxFullBounds _ (newOrigin - aPaintBox offsetFromMaxBounds) extent: 
					paintBoxFullBounds extent.
	newPaintBoxBounds _ paintBoxFullBounds translatedToBeWithin: worldBounds.
	

	self initializeFor: aSketchMorph inBounds: boundsToUse 
		pasteUpMorph: aPasteUpMorph 
		paintBoxPosition: newPaintBoxBounds origin + aPaintBox offsetFromMaxBounds.! !

!SketchEditorMorph methodsFor: 'initialization' stamp: 'yo 7/16/2003 15:10'!
initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph paintBoxPosition: aPosition
	"NB: if aPosition is nil, then it's assumed that the paintbox is obtained from a flap or some such, so do nothing special regarding a palette in this case.  The palette needs already to be in the world for this to work."
	| w  |
	(w _ aPasteUpMorph world) addMorphInLayer: self.	"in back of palette"
	enclosingPasteUpMorph _ aPasteUpMorph.
	hostView _ aSketchMorph.  "may be ownerless"
	self bounds: boundsToUse.
	palette _ w paintBox focusMorph: self.
	palette beStatic.		"give Nebraska whatever help we can"
	palette fixupButtons.
	palette addWeakDependent: self.
	aPosition ifNotNil:
		[w addMorphFront: palette.  "bring to front"
		palette position: aPosition].
	paintingForm _ Form extent: bounds extent depth: w assuredCanvas depth.
	self dimTheWindow.
	self addRotationScaleHandles.
	aSketchMorph ifNotNil:
		[
		aSketchMorph form
			displayOn: paintingForm
			at: (hostView boundsInWorld origin - bounds origin - hostView form offset)
			clippingBox: (0@0 extent: paintingForm extent)
			rule: Form over
			fillColor: nil.  "assume they are the same depth".
			undoBuffer _ paintingForm deepCopy.
		rotationCenter _ aSketchMorph rotationCenter]! !


!SketchEditorMorph methodsFor: 'morphic' stamp: 'yo 11/17/2002 21:32'!
mouseDown: evt
	"Start a new stroke.  Check if any palette setting have changed.  6/11/97 20:30 tk"
	| cur pfPen myAction |
	"verify that we are in a good state"
	self verifyState: evt.		"includes prepareToPaint and #scalingOrRotate"
	pfPen _ self get: #paintingFormPen for: evt.
	paintingForm extent = undoBuffer extent ifTrue: [
		paintingForm displayOn: undoBuffer at: 0@0 rule: Form over.
	] ifFalse: [
		undoBuffer _ paintingForm deepCopy.	"know we will draw something"
	].
	pfPen place: (evt cursorPoint - bounds origin).
	myAction _ self getActionFor: evt.
	myAction == #paint: ifTrue:[
		palette recentColor: (self getColorFor: evt)].
	self set: #strokeOrigin for: evt to: evt cursorPoint.
		"origin point for pickup: rect: ellispe: polygon: line: star:.  Always take it."
	myAction == #pickup: ifTrue: [
		cur _ Cursor corner clone.
		cur offset: 0@0  "cur offset abs".
		evt hand showTemporaryCursor: cur].
	myAction == #polygon: ifTrue: [self polyNew: evt].	"a mode lets you drag vertices"
	self mouseMove: evt.! !


!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 15:13'!
get: aSymbol for: anEventOrHand

	| valuesForHand |

	valuesForHand _ self valuesForHand: anEventOrHand.
	^valuesForHand at: aSymbol ifAbsent: [nil].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/16/2000 11:14'!
getActionFor: anEventOrHand

	^(self get: #action for: anEventOrHand) ifNil: [
		self set: #action for: anEventOrHand to: palette action
	].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 17:56'!
getBrushFor: anEventOrHand

	^(self get: #brush for: anEventOrHand) ifNil: [
		self set: #brush for: anEventOrHand to: palette getNib
	].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/16/2000 11:20'!
getColorFor: anEventOrHand

	^(self get: #currentColor for: anEventOrHand) ifNil: [
		self set: #currentColor for: anEventOrHand to: palette getColor
	].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/16/2000 13:40'!
getCursorFor: anEventOrHand

	| plainCursor |
	plainCursor _ (self get: #currentCursor for: anEventOrHand) ifNil: [
		self set: #currentCursor for: anEventOrHand to: palette plainCursor
	].
	^palette
		cursorFor: (self getActionFor: anEventOrHand) 
		oldCursor: plainCursor 
		currentNib: (self getNibFor: anEventOrHand) 
		color: (self getColorFor: anEventOrHand)

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 17:16'!
getNibFor: anEventOrHand

	^(self get: #currentNib for: anEventOrHand) ifNil: [
		self set: #currentNib for: anEventOrHand to: palette getNib
	].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'ar 10/10/2000 17:30'!
set: aSymbol for: anEventOrHand to: anObject

	| valuesForHand |

	valuesForHand _ self valuesForHand: anEventOrHand.
	aSymbol == #action ifTrue: [
		valuesForHand at: #priorAction put: (valuesForHand at: #action ifAbsent: [#paint:]).
		(anObject ~~ #polygon: and:[self polyEditing]) ifTrue:[self polyFreeze].
	].
	valuesForHand at: aSymbol put: anObject.
	^anObject

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 15:12'!
valuesForHand: anEventOrHand

	| hand valuesForHand |
	forEachHand ifNil: [forEachHand _ IdentityDictionary new].
	hand _ (anEventOrHand isKindOf: HandMorph) 
				ifTrue: [anEventOrHand] ifFalse: [anEventOrHand hand].
	valuesForHand _ forEachHand at: hand ifAbsentPut: [Dictionary new].
	^valuesForHand

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'gm 2/22/2003 12:59'!
valuesForHandIfPresent: anEventOrHand 
	| hand |
	forEachHand ifNil: [forEachHand := IdentityDictionary new].
	hand := (anEventOrHand isHandMorph) 
				ifTrue: [anEventOrHand]
				ifFalse: [anEventOrHand hand].
	^forEachHand at: hand ifAbsent: [nil]! !


!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 01:47'!
cancelPainting: aPaintBoxMorph evt: evt
	"Undo the operation after user issued #cancel in aPaintBoxMorph"
	^self cancel: evt! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:25'!
clearPainting: aPaintBoxMorph
	"Clear the image after user issued #clear in aPaintBoxMorph"
	^self clear! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/31/2000 14:03'!
dimTheWindow

	"Updated to use TranslucentColor by kfr 10/5 00"
	"Do not call twice!! Installs a morph with an 'onion-skinned' copy of the pixels behind me." 

	"create an 'onion-skinned' version of the stuff on the screen"
	owner outermostMorphThat: [:morph | morph resumeAfterDrawError. false].

	"an experiment for Nebraska to see if opaque background speeds things up"

"----- now using the color variable to control background
	bgColor _ false ifTrue: [TranslucentColor r:1.0 g:1.0 b:1.0 alpha:0.5] ifFalse: [Color white].
	dimForm _ (RectangleMorph new color: bgColor; bounds: self bounds; borderWidth: 0).
	dimForm position: self position.
	owner
		privateAddMorph: dimForm
		atIndex: (owner submorphs indexOf: self) + 1.
-----"
! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/15/2000 18:02'!
paintBoxChanged: arguments

	self set: arguments first for: arguments second to: arguments third.
! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:37'!
paletteAttached: aPaintBoxMorph
	"A new palette has been attached to the receiver.
	Don't know what to do here..."! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:33'!
paletteDetached: aPaintBoxMorph
	"The palette has been detached to the receiver.
	Don't know what to do here...."! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 01:48'!
savePainting: aPaintBoxMorph evt: evt
	"Save the image after user issued #keep in aPaintBoxMorph"
	^self save: evt! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 11:17'!
undoPainting: aPaintBoxMorph evt: evt
	"Undo the operation after user issued #undo in aPaintBoxMorph"
	^self undo: evt! !


!SketchEditorMorph methodsFor: 'start & finish' stamp: 'dgd 9/19/2003 14:50'!
addRotationScaleHandles

	"Rotation and scaling handles"

	rotationButton _ SketchMorph withForm: (palette rotationTabForm).
	rotationButton position: bounds topCenter - (6@0).
	rotationButton on: #mouseDown send: #rotateScalePrep: to: self.
	rotationButton on: #mouseMove send: #rotateBy: to: self.
	rotationButton on: #mouseUp send: #rotateDone: to: self.
	rotationButton on: #mouseEnter send: #mouseLeave: to: self.
	"Put cursor back"
	rotationButton on: #mouseLeave send: #mouseEnter: to: self.
	self addMorph: rotationButton.
	rotationButton setBalloonText: 'Drag me sideways to
rotate your
picture.' translated.

	scaleButton _ SketchMorph withForm: (palette scaleTabForm).
	scaleButton position: bounds rightCenter - ((scaleButton width)@6).
	scaleButton on: #mouseDown send: #rotateScalePrep: to: self.
	scaleButton on: #mouseMove send: #scaleBy: to: self.
	scaleButton on: #mouseEnter send: #mouseLeave: to: self.
	"Put cursor back"
	scaleButton on: #mouseLeave send: #mouseEnter: to: self.
	self addMorph: scaleButton.
	scaleButton setBalloonText: 'Drag me up and down to change
the size
of your picture.' translated.

"REMOVED:
	fwdButton _ PolygonMorph new.
	pt _ bounds topCenter.
	fwdButton borderWidth: 2; makeOpen; makeBackArrow; borderColor:
(Color r: 0 g: 0.8 b: 0).
	fwdButton removeHandles; setVertices: (Array with: pt+(0@7) with:
pt+(0@22)).
	fwdButton on: #mouseMove send: #forward:direction: to: self.
	fwdButton on: #mouseEnter send: #mouseLeave: to: self.	
	fwdButton on: #mouseLeave send: #mouseEnter: to: self.
	self setProperty: #fwdButton toValue: fwdButton.
	self addMorph: fwdButton.
	fwdButton setBalloonText: 'Drag me around to point
in the direction
I go forward.' translated.

	toggle _ EllipseMorph
		newBounds: (Rectangle center: fwdButton vertices last +
(-4@4) extent: 8@8)
		color: Color gray.
	toggle on: #mouseUp send: #toggleDirType:in: to: self.
	toggle on: #mouseEnter send: #mouseLeave: to: self.
	toggle on: #mouseLeave send: #mouseEnter: to: self.
	self setProperty: #fwdToggle toValue: toggle.
	fwdButton addMorph: toggle.
	toggle setBalloonText: 'When your object turns,
how should its
picture change?
It can rotate, face left or right,
face up or down, or not
change.' translated.
	"
	self setProperty: #rotationStyle toValue: hostView rotationStyle.
"	self forward: hostView setupAngle direction: fwdButton.	"
	"Set to its current value"

! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 10/28/97 15:31'!
afterNewPicDo: goodBlock ifNoBits: badBlock
	"If the user said 'Save' at the end of drawing, do this block to save the picture.
goodBlock takes 2 args, the painted form and the bounding rectangle of its bits.
badBlock takes no args.  "

	newPicBlock _ goodBlock.
	emptyPicBlock _ badBlock.! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 01:46'!
cancel: evt
	"Palette is telling us that the use wants to end the painting session.  "

	Cursor blank show.
	self deliverPainting: #cancel evt: evt.! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 4/30/2005 23:05'!
cancelOutOfPainting
	"The user requested to back out of a painting session without saving"

	self deleteSelfAndSubordinates.
	emptyPicBlock ifNotNil: [emptyPicBlock value].	"note no args to block!!"
	hostView ifNotNil: [hostView changed].
	ActiveWorld resumeScriptsPausedByPainting.
	^ nil! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 9/2/1999 12:54'!
deleteSelfAndSubordinates
	"Delete the receiver and, if it has one, its subordinate dimForm"
	self delete.
	dimForm ifNotNil: [dimForm delete]! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 5/1/2005 00:13'!
deliverPainting: result evt: evt
	"Done painting.  May come from resume, or from original call.  Execute user's post painting instructions in the block.  Always use this standard one.  4/21/97 tk"

	| newBox newForm ans |
	palette ifNotNil: "nil happens" [palette setAction: #paint: evt: evt].	"Get out of odd modes"
	"rot _ palette getRotations."	"rotate with heading, or turn to and fro"
	"palette setRotation: #normal."
	result == #cancel ifTrue: [
		ans _ PopUpMenu withCaption: 'Do you really want to throw away 
what you just painted?' translated 
				chooseFrom: 'throw it away\keep painting it' translated.
		^ ans = 1 ifTrue: [self cancelOutOfPainting]
				ifFalse: [nil]].	"cancelled out of cancelling."

	"hostView rotationStyle: rot."		"rotate with heading, or turn to and fro"
	newBox _ paintingForm rectangleEnclosingPixelsNotOfColor: Color transparent.
	registrationPoint ifNotNil:
		[registrationPoint _ registrationPoint - newBox origin]. "relative to newForm origin"
	newForm _ 	Form extent: newBox extent depth: paintingForm depth.
	newForm copyBits: newBox from: paintingForm at: 0@0 
		clippingBox: newForm boundingBox rule: Form over fillColor: nil.
	newForm isAllWhite ifTrue: [
		(self valueOfProperty: #background) == true 
			ifFalse: [^ self cancelOutOfPainting]].

	newForm fixAlpha. "so alpha channel stays intact for 32bpp"

	self delete.	"so won't find me again"
	dimForm ifNotNil: [dimForm delete].
	newPicBlock value: newForm value: (newBox copy translateBy: bounds origin).
	ActiveWorld resumeScriptsPausedByPainting

! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 11:28'!
prepareToPaint: evt
	"Figure out what the current brush, fill, etc is.  Return an action to take every mouseMove.  Set up instance variable and pens.  Prep for normal painting is inlined here.  tk 6/14/97 21:11"

	| specialMode pfPen cColor cNib myBrush |
	"Install the brush, color, (replace mode), and cursor."
	specialMode _ self getActionFor: evt.
 	cColor  _ self getColorFor: evt.
	cNib _ self getNibFor: evt.
	self set: #brush for: evt to: (myBrush _ cNib).
	self set: #paintingFormPen for: evt to: (pfPen _ Pen newOnForm: paintingForm).
	self set: #stampForm for: evt to: nil.	"let go of stamp"
	formCanvas _ paintingForm getCanvas.	"remember to change when undo"
	formCanvas _ formCanvas
		copyOrigin: self topLeft negated
		clipRect: (0@0 extent: bounds extent).

	specialMode == #paint: ifTrue: [
		"get it to one bit depth.  For speed, instead of going through a colorMap every time ."
		self set: #brush for: evt to: (myBrush _ Form extent: myBrush extent depth: 1).
		myBrush offset: (0@0) - (myBrush extent // 2).
		cNib displayOn: myBrush at: (0@0 - cNib offset).

		pfPen sourceForm: myBrush.
		pfPen combinationRule: Form paint.
		pfPen color: cColor.
		cColor isTransparent ifTrue: [
			pfPen combinationRule: Form erase1bitShape.
			pfPen color: Color black].
		^ #paint:].

	specialMode == #erase: ifTrue: [
		self erasePrep: evt.
		^ #erase:].
	specialMode == #stamp: ifTrue: [
		self set: #stampForm for: evt to: palette stampForm.	"keep it"
		^ #stamp:].

	(self respondsTo: specialMode) 
		ifTrue: [^ specialMode]	"fill: areaFill: pickup: (in mouseUp:) 
				rect: ellipse: line: polygon: star:"
		ifFalse: ["Don't recognise the command"
			palette setAction: #paint: evt: evt.	"set it to Paint"
			^ self prepareToPaint: evt].! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 11:14'!
save: evt
	"Palette is telling us that the use wants to end the painting session.  "

	Cursor blank show.
	(self getActionFor: evt) == #polygon: ifTrue: [self polyFreeze].		"end polygon mode"
	^ self deliverPainting: #okay evt: evt.! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 4/3/97'!
setRotations: num
	"Tell the palette what number of rotations (or background) to show.  "

	| key |
	key _ 'ItTurns'.	"default and value for num > 1"
	num == 1 ifTrue: [key _ 'JustAsIs'].
	num == 18 ifTrue: [key _ 'ItTurns'].
	num == 99 ifTrue: [key _ 'ToAndFro'].
	num == #Background ifTrue: [key _ 'Background'].
	num == #Repeated ifTrue: [key _ 'Repeated'].
	palette setRotations: (palette contentsAtKey: key).! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'nk 7/30/2004 17:55'!
undo: evt 
	"revert to a previous state.  "

	| temp poly pen |
	self flag: #bob.	"what is undo in multihand environment?"
	undoBuffer ifNil: [^Beeper beep].	"nothing to go back to"
	(poly := self valueOfProperty: #polygon) ifNotNil: 
			[poly delete.
			self setProperty: #polygon toValue: nil.
			^self].
	temp := paintingForm.
	paintingForm := undoBuffer.
	undoBuffer := temp.	"can get back to what you had by undoing again"
	pen := self get: #paintingFormPen for: evt.
	pen ifNil: [^Beeper  beep].
	pen setDestForm: paintingForm.
	formCanvas := paintingForm getCanvas.	"used for lines, ovals, etc."
	formCanvas := formCanvas copyOrigin: self topLeft negated
				clipRect: (0 @ 0 extent: bounds extent).
	self render: bounds! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'ar 10/10/2000 16:47'!
verifyState: evt
	| myAction |
	"We are sure we will make a mark now.  Make sure the palette has not changed state while we were away.  If so, end this action and start another one.  6/11/97 19:52 tk  action, currentColor, brush"

	"Install the brush, color, (replace mode), and cursor."
	palette isInWorld ifFalse:
		[self world addMorphFront: palette].  "It happens.  might want to position it also"
	myAction _ self getActionFor: evt.
	(self get: #changed for: evt) == false ifFalse: [
		self set: #changed for: evt to: false.
		self invalidRect: rotationButton bounds.	"snap these back"
		rotationButton position: bounds topCenter - (6@0).		"later adjust by button width?"
		self invalidRect: rotationButton bounds.
		self invalidRect: scaleButton bounds.
		scaleButton position: bounds rightCenter - ((scaleButton width)@6).
		self invalidRect: scaleButton bounds.
		myAction == #polygon: ifFalse: [self polyFreeze].		"end polygon mode"
		^ self set: #action for: evt to: (self prepareToPaint: evt)].

! !


!SketchEditorMorph methodsFor: 'WiW support' stamp: 'tk 8/6/2002 20:19'!
morphicLayerNumber
	"Place the painting behind the paint palette"

	^ 28! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SketchEditorMorph class
	instanceVariableNames: ''!

!SketchEditorMorph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
Morph subclass: #SketchMorph
	instanceVariableNames: 'originalForm rotationStyle scalePoint framesToDwell rotatedForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!SketchMorph commentStamp: '<historical>' prior: 0!
The morph that results when the user draws a color bitmap using the PaintBox (SketchEditorMorph and PaintBoxMorph).  

forwardDirection is the angle at which the object will go forward.  When the rotationStyle is not #normal, then forwardDirection is any angle, while the rotation is highly restricted.  If flexed, this is remembered by the Transform morph.  For non-normal rotationStyle, it is rotationDegrees.

setupAngle (a property) is where the user put the green arrow to indicate which direction on the picture is forward.  When #normal, draw the morph initially at (0.0 - setupAngle).  The enclosing TransformationMorph then rotates it to the true angle.
 
rotationDegrees  In a #normal object, rotationDegrees is constant an equal to setupAngle.
	For non-normal, it is the direction the object is going.

When repainting, set it back to its original state. The green arrow is set to setupAngle, and the sketch is shown as drawn originally (rotationDegrees = 0). 

rotationStyle = normal (turns), leftRight, upDown, fixed.  
When leftRight upDown or fixed, bit map has severe restrictions.
!


!SketchMorph methodsFor: 'accessing'!
form

	^ originalForm
! !

!SketchMorph methodsFor: 'accessing' stamp: 'sw 12/13/2001 12:10'!
form: aForm
	"Set the receiver's form"

	| oldForm topRenderer |
	oldForm _ originalForm.
	(self hasProperty: #baseGraphic) ifFalse: [self setProperty: #baseGraphic toValue: aForm].
	originalForm _ aForm.
	self rotationCenter: 0.5@0.5.
	self layoutChanged.
	topRenderer _ self topRendererOrSelf.

	oldForm ifNotNil: [topRenderer position: topRenderer position + (oldForm extent - aForm extent // 2)].
! !

!SketchMorph methodsFor: 'accessing'!
framesToDwell

	^ framesToDwell
! !

!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'!
framesToDwell: anInteger

	framesToDwell _ anInteger.
! !

!SketchMorph methodsFor: 'accessing' stamp: 'sw 12/12/2001 10:49'!
nominalForm: aForm
	"Ascribe the blank nominal form"

	originalForm _ aForm.
	self rotationCenter: 0.5@0.5.
	self layoutChanged
! !

!SketchMorph methodsFor: 'accessing' stamp: 'sw 9/9/1998 13:15'!
originalForm: aForm
	originalForm _ aForm! !

!SketchMorph methodsFor: 'accessing'!
rotatedForm

	rotatedForm ifNil: [self layoutChanged].
	^ rotatedForm
! !

!SketchMorph methodsFor: 'accessing' stamp: 'gm 2/22/2003 13:14'!
scaleFactor
	"Answer the number representing my scaleFactor, assuming the receiver to be unflexed (if flexed, the renderer's scaleFactor is called instead"

	| qty |
	((qty := self scalePoint) isPoint) ifTrue: [^1.0].
	^qty! !

!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'!
scalePoint

	scalePoint ifNil: [scalePoint _ 1.0@1.0].
	^ scalePoint
! !

!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'!
scalePoint: aPoint

	scalePoint _ aPoint.
	self layoutChanged.
! !

!SketchMorph methodsFor: 'accessing' stamp: 'sw 10/24/2000 05:55'!
setNewFormFrom: formOrNil
	"Set the receiver's form as indicated.   If nil is provided, then a default form will be used, possibly retrieved from the receiver's defaultValue property"

	| defaultImage |
	formOrNil ifNotNil: [^ self form: formOrNil].
	defaultImage _ self defaultValueOrNil ifNil: [ScriptingSystem squeakyMouseForm].
	self form: defaultImage
! !

!SketchMorph methodsFor: 'accessing' stamp: 'ar 11/16/2002 19:22'!
useInterpolation
	^(self valueOfProperty: #useInterpolation ifAbsent:[false]) 
		and:[Smalltalk includesKey: #B3DRenderEngine]! !

!SketchMorph methodsFor: 'accessing' stamp: 'nk 1/24/2004 23:46'!
useInterpolation: aBool
	(aBool == true and: [ Smalltalk includesKey: #B3DRenderEngine ])
		ifTrue:[self setProperty: #useInterpolation toValue: aBool]
		ifFalse:[self removeProperty: #useInterpolation].
	self layoutChanged. "to regenerate the form"
! !

!SketchMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 09:32'!
wantsSimpleSketchMorphHandles
	"Answer true if my halo's simple handles should include the simple sketch morph handles."
	^self isMemberOf: SketchMorph! !


!SketchMorph methodsFor: 'caching' stamp: 'di 3/2/98 14:14'!
releaseCachedState
	"Clear cache of rotated, scaled Form."

	super releaseCachedState.
	rotatedForm _ nil.
	originalForm hibernate! !


!SketchMorph methodsFor: 'drawing' stamp: 'RAA 12/17/2000 12:53'!
canBeEnlargedWithB3D

	| answer |

	^self 
		valueOfProperty: #canBeEnlargedWithB3D
		ifAbsent: [
			answer _ self rotatedForm colorsUsed allSatisfy: [ :c | c isTranslucent not].
			self setProperty: #canBeEnlargedWithB3D toValue: answer.
			answer
		]! !

!SketchMorph methodsFor: 'drawing' stamp: 'RAA 12/17/2000 14:24'!
drawHighResolutionOn: aCanvas in: aRectangle

	| r finalClipRect scale sourceOrigin sourceExtent sourceRect biggerSource biggerDestExtent interForm offsetInBigger |

	r _ aRectangle translateBy: aCanvas origin.
	finalClipRect _ r intersect: (aCanvas clipRect translateBy: aCanvas origin).
	self canBeEnlargedWithB3D ifTrue: [
		(WarpBlt toForm: aCanvas form)
			clipRect: finalClipRect;
			sourceForm: originalForm;
			cellSize: 2;  "installs a colormap"
			combinationRule: Form paint;

			copyQuad: originalForm boundingBox innerCorners 
			toRect: r.
		^self
	].
	scale _ aRectangle extent / originalForm extent.
	sourceOrigin _ originalForm offset + (aCanvas clipRect origin - aRectangle origin / scale).
	sourceExtent _ aCanvas clipRect extent / scale.
	sourceRect _ sourceOrigin rounded extent: sourceExtent rounded.
	biggerSource _ sourceRect expandBy: 1.
	biggerDestExtent _ (biggerSource extent * scale) rounded.
	offsetInBigger _ (sourceOrigin - biggerSource origin * scale) rounded.

	interForm _ Form extent: biggerDestExtent depth: aCanvas depth.
	(originalForm copy: biggerSource)
		displayInterpolatedIn: interForm boundingBox
		on: interForm.
	aCanvas 
		drawImage: interForm 
		at: aCanvas clipRect origin 
		sourceRect: (offsetInBigger extent: aCanvas clipRect extent).


! !

!SketchMorph methodsFor: 'drawing' stamp: 'ar 7/28/2005 16:51'!
drawInterpolatedImage: aForm on: aCanvas
	"Draw the given form onto the canvas using the Balloon 3D engine"
	| engine |
	engine _ Smalltalk at: #B3DRenderEngine 
		ifPresent:[:b3d | b3d defaultForPlatformOn: aCanvas form].
	engine == nil ifTrue:[
		self useInterpolation: false.
		^self generateRotatedForm].
	"Setup the engine"
	engine viewport: aCanvas form boundingBox.
	"Install the material to be used (using a plain white emission color)"
	engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white).
	"Install the texture"
	engine texture: aForm.
	"Draw the mesh"
	engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect).
	"and finish"
	engine finish.! !

!SketchMorph methodsFor: 'drawing' stamp: 'tk 10/9/2002 09:15'!
drawOn: aCanvas
	aCanvas translucentImage: self rotatedForm at: bounds origin
! !

!SketchMorph methodsFor: 'drawing' stamp: 'nk 8/18/2004 19:07'!
generateInterpolatedForm
	"Draw the given form onto the canvas using the Balloon 3D engine"
	| aCanvas extent |
	extent _ (originalForm extent * scalePoint) asIntegerPoint.
	rotatedForm _ Form extent: extent asIntegerPoint depth: originalForm depth.
	aCanvas _ rotatedForm getCanvas.
	^self drawInterpolatedImage: originalForm on: aCanvas! !

!SketchMorph methodsFor: 'drawing' stamp: 'gm 2/28/2003 00:27'!
generateRotatedForm
	"Compute my rotatedForm and offsetWhenRotated."

	| scalePt smoothPix pair |
	scalePoint ifNil: [scalePoint := 1 @ 1].
	scalePt := scalePoint x abs @ scalePoint y abs.
	rotationStyle == #none ifTrue: [scalePt := 1 @ 1].
	smoothPix := (scalePt x < 1.0 or: [scalePt y < 1.0]) 
		ifTrue: [2]
		ifFalse: [1].
	rotationStyle = #leftRight 
		ifTrue: 
			[self heading asSmallAngleDegrees < 0.0 
				ifTrue: [scalePt := scalePt x negated @ scalePt y]].
	rotationStyle = #upDown 
		ifTrue: 
			[self heading asSmallAngleDegrees abs > 90.0 
				ifTrue: [scalePt := scalePt x @ scalePt y negated]].
	rotatedForm := scalePt = (1 @ 1) 
				ifTrue: [originalForm]
				ifFalse: 
					["ar 11/19/2001: I am uncertain what happens in the case of rotationStyle ~~ normal"

					(rotationStyle == #normal and: [self useInterpolation]) 
						ifTrue: [^self generateInterpolatedForm].
					pair := WarpBlt current 
								rotate: originalForm
								degrees: 0
								center: originalForm boundingBox center
								scaleBy: scalePt
								smoothing: smoothPix.
					pair first]! !


!SketchMorph methodsFor: 'e-toy support' stamp: 'sw 12/12/2001 13:10'!
baseGraphic
	"Answer my base graphic"

	^ self valueOfProperty: #baseGraphic ifAbsent:
		[self setProperty: #baseGraphic toValue: originalForm.
		^ originalForm]! !

!SketchMorph methodsFor: 'e-toy support' stamp: 'sw 12/12/2001 13:15'!
baseGraphic: aForm
	"Remember the given form as the receiver's base graphic"

	^ self setProperty: #baseGraphic toValue: aForm! !

!SketchMorph methodsFor: 'e-toy support' stamp: 'mga 11/18/2003 09:54'!
flipHorizontal

	self form: (self form flipBy: #horizontal centerAt: self form center)! !

!SketchMorph methodsFor: 'e-toy support' stamp: 'mga 11/18/2003 09:54'!
flipVertical

	self form: (self form flipBy: #vertical centerAt: self form center)! !

!SketchMorph methodsFor: 'e-toy support'!
rotationStyle

	^ rotationStyle
! !

!SketchMorph methodsFor: 'e-toy support' stamp: 'jm 7/24/97 15:06'!
rotationStyle: aSymbol
	"Set my rotation style to #normal, #leftRight, #upDown, or #none. Styles mean:
		#normal		-- continuous 360 degree rotation
		#leftRight		-- quantize angle to left or right facing
		#upDown		-- quantize angle to up or down facing
		#none			-- do not rotate"

	rotationStyle _ aSymbol.
	self layoutChanged.
! !

!SketchMorph methodsFor: 'e-toy support' stamp: 'dgd 8/29/2004 11:05'!
wantsRecolorHandle
	"Answer whether the receiver would like a recolor handle to be  
	put up for it. We'd want to disable this but for the moment  
	that would cut off access to the button part of the properties  
	sheet. So this remains a loose end."
	^ false! !


!SketchMorph methodsFor: 'geometry' stamp: 'nk 1/10/2004 14:51'!
extent: newExtent
	"Change my scale to fit myself into the given extent.
	Avoid extents where X or Y is zero."
	(newExtent y = 0 or: [ newExtent x = 0 ]) ifTrue: [ ^self ].
	self extent = newExtent ifTrue:[^self].
	scalePoint _ newExtent asFloatPoint / (originalForm extent max: 1@1).
	self layoutChanged.
! !

!SketchMorph methodsFor: 'geometry' stamp: 'nk 6/21/2003 14:00'!
firstIntersectionWithLineFrom: start to: end
	| intersections last |
	intersections _ self fullBounds extrapolatedIntersectionsWithLineFrom: start to: end.
	intersections size = 1 ifTrue: [ ^intersections anyOne ].
	intersections isEmpty ifTrue: [ ^nil ].
	intersections _ intersections asSortedCollection: [ :a :b | (start dist: a) < (start dist: b) ].
	last _ intersections first rounded.
	last pointsTo: intersections last rounded do: [ :pt |
		(self rotatedForm isTransparentAt: (pt - bounds origin)) ifFalse: [ ^last ].
		last _ pt.
	].
	^intersections first rounded! !


!SketchMorph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 22:31'!
forwardDirection: degrees
	"If not rotating normally, update my rotatedForm"
	super forwardDirection: degrees.
	rotationStyle == #normal ifFalse:[self layoutChanged].! !


!SketchMorph methodsFor: 'geometry testing'!
containsPoint: aPoint

	^ (self bounds containsPoint: aPoint) and:
	  [(self rotatedForm isTransparentAt: aPoint - bounds origin) not]
! !


!SketchMorph methodsFor: 'halos and balloon help' stamp: 'sw 7/3/1999 20:06'!
isLikelyRecipientForMouseOverHalos
	^ true! !

!SketchMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:51'!
wantsDirectionHandles
	^self valueOfProperty: #wantsDirectionHandles ifAbsent:[
		Preferences showDirectionHandles or:[Preferences showDirectionForSketches]]! !

!SketchMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:52'!
wantsDirectionHandles: aBool
	aBool == (Preferences showDirectionHandles or:[Preferences showDirectionForSketches])
		ifTrue:[self removeProperty: #wantsDirectionHandles]
		ifFalse:[self setProperty: #wantsDirectionHandles toValue: aBool].! !


!SketchMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:51'!
initialize
"initialize the state of the receiver"
	^ self initializeWith: (ScriptingSystem formAtKey: 'Painting') deepCopy! !

!SketchMorph methodsFor: 'initialization' stamp: 'ar 9/22/2000 20:38'!
initializeWith: aForm

	super initialize.
	originalForm _ aForm.
	self rotationCenter: 0.5@0.5.		"relative to the top-left corner of the Form"
	rotationStyle _ #normal.		"styles: #normal, #leftRight, #upDown, or #none"
	scalePoint _ 1.0@1.0.
	framesToDwell _ 1.
	rotatedForm _ originalForm.	"cached rotation of originalForm"
	self extent: originalForm extent.
! !


!SketchMorph methodsFor: 'layout' stamp: 'ar 9/22/2000 14:00'!
layoutChanged
	"Update rotatedForm and compute new bounds."
	self changed.
	self generateRotatedForm.
	bounds _ bounds origin extent: rotatedForm extent.
	super layoutChanged.
	self changed.
! !


!SketchMorph methodsFor: 'menu' stamp: 'yo 2/12/2005 19:11'!
addBorderToShape: evt
	| str borderWidth borderedForm r |
	str _ FillInTheBlank
		request: 'Please enter the desired border width' translated
		initialAnswer: '0'.
	borderWidth _ Integer readFrom: (ReadStream on: str).
	(borderWidth between: 1 and: 10) ifFalse: [^ self].

	"Take care of growing appropriately.  Does this lose the reg point?"
	borderedForm _ originalForm shapeBorder: Color black width: borderWidth.
	r _ borderedForm rectangleEnclosingPixelsNotOfColor: Color transparent.
	self form: (borderedForm copy: r).
! !

!SketchMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:16'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add custom menu items"

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'restore base graphic' translated target: self action: #restoreBaseGraphicFromMenu.
	aCustomMenu add: 'call this my base graphic' translated target: self action: #callThisBaseGraphic.
	aCustomMenu add: 'choose new graphic...' translated target: self action: #chooseNewGraphic.
	aCustomMenu addLine.
	aCustomMenu add: 'set as background' translated target: rotatedForm action: #setAsBackground.
	self addPaintingItemsTo: aCustomMenu hand: aHandMorph! !

!SketchMorph methodsFor: 'menu' stamp: 'yo 3/15/2005 12:04'!
callThisBaseGraphic
	"Set my baseGraphic to be the current form"

	| aGraphic |
	self isInWorld ifFalse: [^ self inform: 

'oops, this menu is a for a morph that
has been replaced, probably because a
"look like" script was run.  Please dismiss
the menu and get a new one!!.  Sorry!!' translated].

	((aGraphic _ self valueOfProperty: #baseGraphic)
				notNil and: [aGraphic ~= originalForm])
		ifTrue:
			[self setProperty: #baseGraphic toValue: originalForm]
		ifFalse:
			[self inform: 'this already *was* your baseGraphic' translated]! !

!SketchMorph methodsFor: 'menu' stamp: 'tk 7/6/1998 15:31'!
editDrawing
	self flag: #deferred.  "Don't allow this if the user is already in paint mode, because it creates a very strange situation."
	"costumee ifNotNil: [self forwardDirection: costumee direction]."  "how say this?"
	self editDrawingIn: self pasteUpMorph forBackground: false
! !

!SketchMorph methodsFor: 'menu' stamp: 'sw 1/25/2006 21:41'!
editDrawingIn: aPasteUpMorph forBackground: forBackground
	"Edit an existing sketch."

	| w bnds sketchEditor pal aPaintTab aWorld aPaintBox tfx rotCenter |
	self world assureNotPaintingElse: [^self].
	w := aPasteUpMorph world.
	w prepareToPaint.
	w displayWorld.
	self visible: false.
	bnds := forBackground 
				ifTrue: [aPasteUpMorph boundsInWorld]
				ifFalse: 
					[bnds := self boundsInWorld expandBy: 60 @ 60.
					(aPasteUpMorph paintingBoundsAround: bnds center) merge: bnds]. 
	sketchEditor := SketchEditorMorph new.
	forBackground 
		ifTrue: [sketchEditor setProperty: #background toValue: true].
	w addMorphFront: sketchEditor.
	sketchEditor 
		initializeFor: self
		inBounds: bnds
		pasteUpMorph: aPasteUpMorph.
	rotCenter _ self rotationCenter.

	sketchEditor afterNewPicDo: 
			[:aForm :aRect | 
			self visible: true.
			self form: aForm.
			tfx := aPasteUpMorph transformFrom: aPasteUpMorph world.
			self topRendererOrSelf position: (tfx globalPointToLocal: aRect origin).
			self rotationStyle: sketchEditor rotationStyle.
			self forwardDirection: sketchEditor forwardDirection.
			(rotCenter notNil and: [(rotCenter = (0.5 @ 0.5)) not]) ifTrue:
				[self rotationCenter: rotCenter].
			(aPaintTab := (aWorld := self world) paintingFlapTab) 
				ifNotNil: [aPaintTab hideFlap]
				ifNil: [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]].
			self presenter drawingJustCompleted: self.

			forBackground ifTrue: [self goBehind	"shouldn't be necessary"]]
		ifNoBits: 
			["If no bits drawn.  Must keep old pic.  Can't have no picture"

			self visible: true.
			aWorld := self currentWorld.
			"sometimes by now I'm no longer in a world myself, but we still need
				 to get ahold of the world so that we can deal with the palette"
			((pal := aPasteUpMorph standardPalette) notNil and: [pal isInWorld]) 
				ifTrue: 
					[(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete].
					pal viewMorph: self]
				ifFalse: 
					[(aPaintTab := (aWorld := self world) paintingFlapTab) 
						ifNotNil: [aPaintTab hideFlap]
						ifNil: [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]]]]! !

!SketchMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:53'!
erasePixelsOfColor: evt
	"Let the user specifiy a color such that all pixels of that color should be erased; then do the erasure"

	| c r |
	self changeColorTarget: self selector: #rememberedColor: originalColor: nil hand: evt hand.   "color to erase"
	c _ self rememberedColor ifNil: [Color red].
	originalForm mapColor: c to: Color transparent.
	r _ originalForm rectangleEnclosingPixelsNotOfColor: Color transparent.
	self form: (originalForm copy: r).

! !

!SketchMorph methodsFor: 'menu' stamp: 'nk 6/12/2004 10:04'!
insertIntoMovie: evt

	| movies aTarget |
	movies _
		(self world rootMorphsAt: evt hand targetOffset)
			select: [:m | ((m isKindOf: MovieMorph) or:
						 [m isSketchMorph]) and: [m ~= self]].
	movies isEmpty ifTrue: [^ self].
	aTarget _ movies first.
	(aTarget isSketchMorph) ifTrue: [
		aTarget _ aTarget replaceSelfWithMovie].
	aTarget insertFrames: (Array with: self).
	self delete.
! !

!SketchMorph methodsFor: 'menu' stamp: 'yo 2/12/2005 19:08'!
recolorPixelsOfColor: evt
	"Let the user select a color to be remapped, and then a color to map that color to, then carry it out."

	| c d newForm map newC |
	self inform: 'choose the color you want to replace' translated.
	self changeColorTarget: self selector: #rememberedColor: originalColor: nil hand: evt hand.   "color to replace"
	c _ self rememberedColor ifNil: [Color red].
	self inform: 'now choose the color you want to replace it with' translated.
	self changeColorTarget: self selector:  #rememberedColor: originalColor: c hand: evt hand.  "new color"
	newC _ self rememberedColor ifNil: [Color blue].
	d _ originalForm depth.
	newForm _ Form extent: originalForm extent depth: d.
	map _ (Color cachedColormapFrom: d to: d) copy.
	map at: (c indexInMap: map) put: (newC pixelValueForDepth: d).
	newForm copyBits: newForm boundingBox
		from: originalForm at: 0@0
		colorMap: map.
	self form: newForm.
! !

!SketchMorph methodsFor: 'menu' stamp: 'yo 2/12/2005 19:11'!
reduceColorPalette: evt
	"Let the user ask for a reduced number of colors in this sketch"

	| str nColors |
	str _ FillInTheBlank
		request: 'Please enter a number greater than one.
(note: this cannot be undone, so answer zero
to abort if you need to make a backup first)' translated
		initialAnswer: '256'.
	nColors _ Integer readFrom: (ReadStream on: str).
	(nColors between: 2 and: 256) ifFalse: [^ self].

	originalForm _ originalForm copyWithColorsReducedTo: nColors.
	rotatedForm _ nil.
	self changed! !

!SketchMorph methodsFor: 'menu' stamp: 'sw 12/12/2001 13:14'!
restoreBaseGraphic
	"Restore the receiver's base graphic"

	| aGraphic |
	((aGraphic _ self baseGraphic) notNil and:
				[aGraphic ~= originalForm])
		ifTrue:
			[self form: aGraphic]! !

!SketchMorph methodsFor: 'menu' stamp: 'yo 3/15/2005 13:57'!
restoreBaseGraphicFromMenu
	"Restore the base graphic -- invoked from a menu, so give interactive feedback if appropriate"

	self isInWorld ifFalse: [^ self inform: 

'oops, this menu is a for a morph that
has been replaced, probably because a
"look like" script was run.  Please dismiss
the menu and get a new one!!.  Sorry!!' translated].

	 self baseGraphic = originalForm ifTrue: [^ self inform: 'This object is *already* showing its baseGraphic' translated].
	self restoreBaseGraphic! !

!SketchMorph methodsFor: 'menu' stamp: 'yo 2/12/2005 19:04'!
setRotationStyle
	| selections labels sel reply |
	selections _ #(normal leftRight upDown none).
	labels _ #('rotate smoothly' 'left-right flip only' 'top-down flip only' 'don''t rotate').
	sel _ labels at: (selections indexOf: self rotationStyle ifAbsent:[1]).
	labels _ labels collect:[:lbl| sel = lbl ifTrue:['<on>', lbl translated] ifFalse:['<off>', lbl translated]].
	reply _ (SelectionMenu labelList: labels selections: selections) startUp.
	reply ifNotNil: [self rotationStyle: reply].
! !

!SketchMorph methodsFor: 'menu' stamp: 'ar 11/19/2001 22:38'!
toggleInterpolation
	^self useInterpolation: self useInterpolation not! !

!SketchMorph methodsFor: 'menu' stamp: 'dgd 9/6/2003 18:27'!
useInterpolationString
	^ (self useInterpolation
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'smooth image' translated! !


!SketchMorph methodsFor: 'menus' stamp: 'ar 6/18/1999 06:40'!
addFillStyleMenuItems: aMenu hand: aHand
	"Do nothing here - we do not allow changing the fill style of a SketchMorph yet."! !

!SketchMorph methodsFor: 'menus' stamp: 'dgd 9/18/2004 19:56'!
addToggleItemsToHaloMenu: aCustomMenu 
	"Add toggle-items to the halo menu"
	super addToggleItemsToHaloMenu: aCustomMenu.
	Preferences noviceMode
		ifFalse: [""aCustomMenu
				addUpdating: #useInterpolationString
				target: self
				action: #toggleInterpolation]! !

!SketchMorph methodsFor: 'menus' stamp: 'nk 3/27/2001 17:57'!
changePixelsOfColor: c toColor: newColor

	| r |
	originalForm mapColor: c to: newColor.
	r _ originalForm rectangleEnclosingPixelsNotOfColor: Color transparent.
	self form: (originalForm copy: r).

! !

!SketchMorph methodsFor: 'menus' stamp: 'RAA 11/14/2000 13:44'!
collapse
	
	| priorPosition w collapsedVersion a |

	(w _ self world) ifNil: [^self].
	collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
	collapsedVersion setProperty: #uncollapsedMorph toValue: self.
	collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
	collapsedVersion setBalloonText: 'A collapsed version of ',self name.
			
	self delete.
	w addMorphFront: (
		a _ AlignmentMorph newRow
			hResizing: #shrinkWrap;
			vResizing: #shrinkWrap;
			borderWidth: 4;
			borderColor: Color white;
			addMorph: collapsedVersion
	).
	collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.

	(priorPosition _ self valueOfProperty: #collapsedPosition ifAbsent: [nil])
	ifNotNil:
		[a position: priorPosition].
! !


!SketchMorph methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:49'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	scalePoint ifNil: [scalePoint _ 1.0@1.0].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!SketchMorph methodsFor: 'other' stamp: 'sw 12/1/1998 18:16'!
newForm: aForm
	self originalForm: aForm.
	self layoutChanged! !

!SketchMorph methodsFor: 'other' stamp: 'jm 7/24/97 15:06'!
replaceSelfWithMovie
	"Replace this SketchMorph in its owner with a MovieMorph containing this sketch as its only frame. This allows a SketchMorph to be turned into a MovieMorph by just insering additional frames."

	| o movie |
	self changed.
	o _ self owner.
	movie _ MovieMorph new position: self referencePosition.
	movie insertFrames: (Array with: self).
	o ifNil: [^ movie].
	o addMorphFront: movie.
	^ movie
! !


!SketchMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:33'!
initializeToStandAlone
	super initializeToStandAlone.
	self initializeWith: (ScriptingSystem formAtKey: 'Painting') deepCopy

! !


!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 17:14'!
clearExtent: aPoint fillColor: aColor
	"Make this sketch have the given pixel dimensions and fill it with given color. Its previous contents are replaced."

	self form:
		((Form extent: aPoint depth: Display depth) fillColor: aColor).
! !

!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 09:26'!
penOnMyForm
	"Support for experiments with drawing under program control. To get started, make a new SketchMorph in a morphic world. In an inspector, give it the desired pixel dimensions with clearExtent:fillColor:. Then use this method to get a pen to which you can send normal pen commands. Reveal the resulting drawing with revealPenStrokes."

	^ Pen newOnForm: originalForm
! !

!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 09:08'!
revealPenStrokes
	"This message must be sent after a sequence of pen strokes to make the resulting changes visible."

	rotatedForm _ nil.
	self changed.
! !


!SketchMorph methodsFor: 'testing' stamp: 'tk 11/1/2001 12:42'!
basicType
	"Answer a symbol representing the inherent type I hold"

	"Number String Boolean player collection sound color etc"
	^ #Image! !


!SketchMorph methodsFor: '*eToys-accessing' stamp: 'RAA 3/15/2001 09:11'!
wearCostume: anotherMorph

	self form: anotherMorph form.
! !


!SketchMorph methodsFor: '*eToys-card in a stack' stamp: 'sw 10/30/2000 10:29'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')  SketchMorphs answer true, because they can serve as 'picture-holding' fields"

	^ true! !


!SketchMorph methodsFor: '*eToys-e-toy support' stamp: 'nk 6/12/2004 10:04'!
acquirePlayerSimilarTo: aSketchMorphsPlayer
	"Retrofit into the receiver a player derived from the existing scripted player of a different morph.  Works only between SketchMorphs. Maddeningly complicated by potential for transformations or native sketch-morph scaling in donor or receiver or both"

	| myName myTop itsTop newTop newSketch |
	myTop _ self topRendererOrSelf.
	aSketchMorphsPlayer belongsToUniClass ifFalse: [^ Beeper beep].
	itsTop _ aSketchMorphsPlayer costume.
	(itsTop renderedMorph isSketchMorph)
		ifFalse:	[^ Beeper beep].

	newTop _ itsTop veryDeepCopy.  "May be a sketch or a tranformation"
	myName _ myTop externalName.  "Snag before the replacement is added to the world, because otherwise that could affect this"

	newSketch _ newTop renderedMorph.
	newSketch form: self form.
	newSketch scalePoint: self scalePoint.
	newSketch bounds: self bounds.
	myTop owner addMorph: newTop after: myTop.

	newTop heading ~= myTop heading ifTrue:
		"avoids annoying round-off error in what follows"
			[newTop player setHeading: myTop heading]. 
	(newTop isFlexMorph and: [myTop == self])
		ifTrue:
			[newTop removeFlexShell].
	newTop _ newSketch topRendererOrSelf.
	newTop bounds: self bounds.
	(newTop isFlexMorph and:[myTop isFlexMorph]) ifTrue:[
		"Note: This completely dumps the above #bounds: information.
		We need to recompute the bounds based on the transform."
		newTop transform: myTop transform copy.
		newTop computeBounds].
	newTop setNameTo: myName.
	newTop player class bringScriptsUpToDate.
	myTop delete! !

!SketchMorph methodsFor: '*eToys-e-toy support' stamp: 'RAA 1/13/2001 11:38'!
appearsToBeSameCostumeAs: aMorph

	(aMorph isKindOf: self class) ifFalse: [^false].
	^originalForm == aMorph form or: [
		originalForm appearsToBeSameCostumeAs: aMorph form
	]! !

!SketchMorph methodsFor: '*eToys-e-toy support' stamp: 'nk 6/12/2004 10:04'!
asWearableCostume
	"Return a wearable costume for some player"
	^(World drawingClass withForm: originalForm) copyCostumeStateFrom: self! !


!SketchMorph methodsFor: '*eToys-geometry eToy' stamp: 'ar 9/22/2000 21:19'!
heading: newHeading
	"If not rotating normally, change forward direction rather than heading"
	rotationStyle == #normal ifTrue:[^super heading: newHeading].
	self isFlexed
		ifTrue:[self forwardDirection: newHeading - owner rotationDegrees]
		ifFalse:[self forwardDirection: newHeading].
	self layoutChanged! !


!SketchMorph methodsFor: '*eToys-player' stamp: 'sw 10/30/2000 10:28'!
currentDataValue
	"Answer the object which bears the current datum for the receiver"

	^ originalForm! !

!SketchMorph methodsFor: '*eToys-player' stamp: 'sw 10/25/2000 07:01'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield"

	^ Array with: (VariableDock new variableName: self defaultVariableName  type: #form definingMorph: self morphGetSelector: #form morphPutSelector: #setNewFormFrom:)! !


!SketchMorph methodsFor: '*MorphicExtras-testing' stamp: 'RAA 12/4/2000 10:56'!
canDrawAtHigherResolution
	
	| pt |
	pt _ self scalePoint.
	^pt x < 1.0 or: [pt y < 1.0]! !


!SketchMorph methodsFor: '*MorphicExtras-*morphic-Postscript Canvases' stamp: 'RAA 9/22/2000 15:14'!
drawPostscriptOn: aCanvas

	| top f2 c2 tfx clrs |

	tfx _ self transformFrom: self world.
	tfx angle = 0.0 ifFalse: [^super drawPostscriptOn: aCanvas].	"can't do rotated yet"
	clrs _ self rotatedForm colorsUsed.
	(clrs includes: Color transparent) 
		ifFalse: [^super drawPostscriptOn: aCanvas].		"no need for this, then"

"Smalltalk at: #Q put: OrderedCollection new"
"Q add: {self. tfx. clrs}."
"(self hasProperty: #BOB) ifTrue: [self halt]."

	top _ aCanvas topLevelMorph.
	f2 _ Form extent: self extent depth: self rotatedForm depth.
	c2 _ f2 getCanvas.
	c2 fillColor: Color white.
	c2 translateBy: bounds origin negated clippingTo: f2 boundingBox during: [ :c |
		top fullDrawOn: c
	].
	aCanvas paintImage: f2 at: bounds origin

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SketchMorph class
	instanceVariableNames: ''!

!SketchMorph class methodsFor: 'instance creation' stamp: 'ar 3/4/2001 20:59'!
fromFile: aFileName
	^self fromStream: (FileStream readOnlyFileNamed: aFileName)! !

!SketchMorph class methodsFor: 'instance creation' stamp: 'ar 3/4/2001 21:00'!
fromStream: aStream
	^self withForm: (ImageReadWriter formFromStream: aStream)! !

!SketchMorph class methodsFor: 'instance creation' stamp: 'nk 11/9/2003 08:11'!
openEditor
	"Create a new SketchMorph and open a SketchMorphEditor on it. 
	Answers the painted SketchMorph."
	"SketchMorph openEditor"
	| newSketch |
	newSketch := (self
				withForm: (Form extent: 100 @ 100 depth: Display depth)) center: self currentWorld center;
				 openInWorld;
				 editDrawing.
	^ newSketch! !

!SketchMorph class methodsFor: 'instance creation' stamp: 'di 2/17/2000 20:21'!
withForm: aForm
	"Note: 'SketchMorph withForm: zz' is MUCH faster
	than 'SketchMorph new form: zz'."

	^ self basicNew initializeWith: aForm! !


!SketchMorph class methodsFor: 'new-morph participation' stamp: 'sw 9/28/1998 17:15'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !


!SketchMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'!
defaultNameStemForInstances
	^ 'Sketch'! !


!SketchMorph class methodsFor: 'testing' stamp: 'nk 6/12/2004 09:16'!
isSketchMorphClass
	^true! !


!SketchMorph class methodsFor: '*eToys-instance creation' stamp: 'sw 6/13/2001 22:50'!
exampleBackgroundSketch
	"Answer an instance suitable for serving as a prototype for a background-field incarnation of a sketch"


	| aSketch |
	aSketch _ self newSticky form: (ScriptingSystem formAtKey: #squeakyMouse).
	aSketch setProperty: #shared toValue: true.
	aSketch setProperty: #holdsSeparateDataForEachInstance toValue: true.
	^ aSketch
! !


!SketchMorph class methodsFor: '*eToys-scripting' stamp: 'sw 7/14/2004 21:11'!
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."

	^ #((graphics (
(slot graphic 	'The picture currently being worn' Graphic	 readWrite Player getGraphic Player setGraphic:)
(command wearCostumeOf: 'wear the costume of...' Player)
(slot baseGraphic 	'The picture originally painted for this object, but can subsequently be changed via menu or script' Graphic	 readWrite Player getBaseGraphic Player setBaseGraphic:)
(command restoreBaseGraphic 'Make my picture be the one I remember in my baseGraphic')

(slot rotationStyle 'How the picture should change when the heading is modified' RotationStyle readWrite Player getRotationStyle Player setRotationStyle:)
)))


! !
Collection subclass: #SkipList
	instanceVariableNames: 'sortBlock pointers numElements level splice'
	classVariableNames: 'Rand'
	poolDictionaries: ''
	category: 'Collections-SkipLists'!
!SkipList commentStamp: 'sac 1/23/2002 19:41' prior: 0!
A skiplist is a sorted data structure that allows one to search for any element in o(log n) time.

It also allows one to enumerate forward to the next element. Basically, its a tree-like algorithm, except it doesn't use trees.

The implementation here is similar to a Dictionary, in that it indexes (a subclass of) Associations. Thus, you can do    foo at: key put: value   You can also search for a key, if the key does not exist, it will report the first key greater than the search, or nil.
!


!SkipList methodsFor: 'accessing' stamp: 'sac 1/22/2002 19:11'!
at: element 
        ^self at: element ifAbsent: []! !

!SkipList methodsFor: 'accessing' stamp: 'sac 1/22/2002 18:18'!
at: element ifAbsent: aBlock
        "Get the key if it exists, or if it doesn't exist, get the key just after it."
        | node forward |
        node _ self.
        level to: 1 by: -1 do: [:i |
                        [forward _ node forward: i.
                        self is: forward before: element] whileTrue: [node _ forward]].
        node _ node next.
        (self is: node theNodeFor: element) ifFalse: [^aBlock value].
        ^node value
! !

!SkipList methodsFor: 'accessing' stamp: 'sac 1/22/2002 17:19'!
first
        ^pointers first.
! !

!SkipList methodsFor: 'accessing' stamp: 'LC 6/18/2001 19:22'!
level
	^ level! !

!SkipList methodsFor: 'accessing' stamp: 'LC 6/17/2001 12:05'!
maxLevel
	^ pointers size! !

!SkipList methodsFor: 'accessing' stamp: 'LC 6/18/2001 20:18'!
maxLevel: n
	| newLevel oldPointers |
	newLevel _ n max: level.
	oldPointers _ pointers.
	pointers _ Array new: newLevel.
	splice _ Array new: newLevel.
	1 to: level do: [:i | pointers at: i put: (oldPointers at: i)]
! !

!SkipList methodsFor: 'accessing' stamp: 'sac 1/22/2002 18:33'!
search: element 
        "Get the key if it exists, or if it doesn't exist, get the key just after it. If no key after it, return nil."
        | node forward |
        node _ self.
        level to: 1 by: -1 do: [:i |
                        [forward _ node forward: i.
                        self is: forward before: element] whileTrue: [node _ forward]].
        node _ node next.
        ^node! !

!SkipList methodsFor: 'accessing' stamp: 'LC 6/18/2001 15:40'!
size
	^ numElements! !

!SkipList methodsFor: 'accessing' stamp: 'LC 6/18/2001 20:19'!
sortBlock
	^ sortBlock! !

!SkipList methodsFor: 'accessing' stamp: 'LC 6/18/2001 17:30'!
sortBlock: aBlock
	sortBlock _ aBlock! !


!SkipList methodsFor: 'adding' stamp: 'sac 1/22/2002 18:22'!
add: element 
        "Add an association or key on to the skiplist"
        ^self add: element ifPresent: [].
        ! !

!SkipList methodsFor: 'adding' stamp: 'sac 1/25/2002 12:26'!
add: element ifPresent: aBlock
        ^self at: element put: element ifPresent: aBlock.
! !

!SkipList methodsFor: 'adding' stamp: 'sac 1/22/2002 18:22'!
at: key put: value 
        "Add an association or key on to the skiplist"
        ^self at: key put: value ifPresent: [].
        ! !

!SkipList methodsFor: 'adding' stamp: 'sac 1/22/2002 18:23'!
at: key put: value ifPresent: aBlock
        | node lvl s |
        node _ self search: key updating: splice.
        node ifNotNil: [^ aBlock value].
        lvl _ self randomLevel.
        node _ SkipListNode key: key value: value level: lvl.
        level + 1 to: lvl do: [:i | splice at: i put: self].
        1 to: lvl do: [:i |
                                s _ splice at: i.
                                node atForward: i put: (s forward: i).
                                s atForward: i put: node].
        numElements _ numElements + 1.
        splice atAllPut: nil.
        ^ node
! !


!SkipList methodsFor: 'element comparison' stamp: 'LC 6/18/2001 10:14'!
is: element1 equalTo: element2
	^ element1 = element2! !


!SkipList methodsFor: 'enumerating' stamp: 'sac 1/23/2002 20:24'!
associationsDo: aBlock
        self nodesDo: [:node | aBlock value: node]! !

!SkipList methodsFor: 'enumerating' stamp: 'sac 1/23/2002 20:21'!
do: aBlock
        self nodesDo: [:node | aBlock value: node value]! !

!SkipList methodsFor: 'enumerating' stamp: 'sac 1/25/2002 00:18'!
keysAndValuesDo: aBlock
        ^self associationsDo:[:assoc|
                aBlock value: assoc key value: assoc value].! !

!SkipList methodsFor: 'enumerating' stamp: 'sac 1/23/2002 20:22'!
keysDo: aBlock
        self nodesDo: [:node | aBlock value: node key]! !


!SkipList methodsFor: 'initialization' stamp: 'LC 6/18/2001 20:08'!
initialize: maxLevel
	pointers _ Array new: maxLevel.
	splice _ Array new: maxLevel.
	numElements _ 0.
	level _ 0.
	Rand ifNil: [Rand _ Random new]! !


!SkipList methodsFor: 'node enumeration' stamp: 'LC 6/18/2001 19:30'!
nodesDo: aBlock
	| node |
	node _ pointers first.
	[node notNil]
		whileTrue:
			[aBlock value: node.
			node _ node next]! !


!SkipList methodsFor: 'removing' stamp: 'LC 6/18/2001 17:28'!
remove: element 
	^ self remove: element ifAbsent: [self errorNotFound: element]! !

!SkipList methodsFor: 'removing' stamp: 'sac 1/22/2002 16:58'!
remove: key ifAbsent: aBlock
        | node i s |
        "Remove and return th association containing key."
        node _ self search: key updating: splice.
        node ifNil: [^ aBlock value].
        i _ 1.
        [s _ splice at: i.
        i <= level and: [(s forward: i) == node]]
                                whileTrue:
                                        [s atForward: i put: (node forward: i).
                                        i _ i + 1].
        numElements _ numElements - 1.
        splice atAllPut: nil.
        ^ node.
! !

!SkipList methodsFor: 'removing' stamp: 'LC 6/18/2001 20:25'!
removeAll
	pointers atAllPut: nil.
	splice atAllPut: nil.
	numElements _ 0.
	level _ 0.! !


!SkipList methodsFor: 'testing' stamp: 'sac 1/22/2002 17:49'!
includes: key
        ^ (self search: key updating: nil) notNil! !

!SkipList methodsFor: 'testing' stamp: 'LC 6/18/2001 12:53'!
isEmpty
	^ numElements = 0! !


!SkipList methodsFor: 'private' stamp: 'LC 6/18/2001 19:26'!
atForward: i put: node
	level _ node
		ifNil: [pointers findLast: [:n | n notNil]]
		ifNotNil: [level max: i].
	^ pointers at: i put: node! !

!SkipList methodsFor: 'private' stamp: 'LC 6/18/2001 11:21'!
forward: i 
	^ pointers at: i! !

!SkipList methodsFor: 'private' stamp: 'sac 1/22/2002 17:50'!
is: node before: element 
        | key |
        node ifNil: [^ false].
        key _ node key.
        ^ sortBlock
                ifNil: [key < element]
                ifNotNil: [(self is: key equalTo: element) ifTrue: [^ false].
                        sortBlock value: key value: element]! !

!SkipList methodsFor: 'private' stamp: 'sac 1/22/2002 18:04'!
is: node theNodeFor: key 
        node ifNil: [^ false].
        node == self ifTrue: [^ false].
        
        ^ self is: node key equalTo: key! !

!SkipList methodsFor: 'private' stamp: 'LC 6/18/2001 16:15'!
next
	^ pointers first! !

!SkipList methodsFor: 'private' stamp: 'LC 6/18/2001 15:37'!
randomLevel
	| p answer max |
	p _ 0.5.
	answer _ 1.
	max _ self maxLevel.
	[Rand next < p and: [answer < max]]
		whileTrue: [answer _ answer + 1].
	^ answer! !

!SkipList methodsFor: 'private' stamp: 'sac 1/22/2002 18:01'!
search: element updating: array
        | node forward |
        node _ self.
        level to: 1 by: -1 do: [:i |
                        [forward _ node forward: i.
                        self is: forward before: element] whileTrue: [node _ forward].
                        "At this point: node < element <= forward"
                        array ifNotNil: [array at: i put: node]].
        node _ node next.
        ^ (self is: node theNodeFor: element) ifTrue: [node]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SkipList class
	instanceVariableNames: ''!

!SkipList class methodsFor: 'instance creation' stamp: 'LC 6/18/2001 17:33'!
maxLevel: maxLevel
	"
	SkipList maxLevel: 5
	"
	^ super new initialize: maxLevel! !

!SkipList class methodsFor: 'instance creation' stamp: 'LC 6/18/2001 17:34'!
maxLevel: anInteger sortBlock: aBlock
	^ (self maxLevel: anInteger) sortBlock: aBlock! !

!SkipList class methodsFor: 'instance creation' stamp: 'LC 6/17/2001 11:52'!
new
	"
	SkipList new
	"
	^ super new initialize: 10! !

!SkipList class methodsFor: 'instance creation' stamp: 'LC 6/18/2001 17:39'!
new: anInteger
	^ self maxLevel: (anInteger log: 2) ceiling! !

!SkipList class methodsFor: 'instance creation' stamp: 'LC 6/18/2001 18:40'!
new: anInteger sortBlock: aBlock
	^ (self new: anInteger) sortBlock: aBlock! !

!SkipList class methodsFor: 'instance creation' stamp: 'LC 6/18/2001 18:48'!
newFrom: aCollection 
	| skipList |
	skipList _ self new: aCollection size.
	skipList addAll: aCollection.
	^ skipList! !

!SkipList class methodsFor: 'instance creation' stamp: 'LC 6/18/2001 17:32'!
sortBlock: aBlock
	^ self new sortBlock: aBlock! !
Association subclass: #SkipListNode
	instanceVariableNames: 'pointers object'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-SkipLists'!
!SkipListNode commentStamp: 'sac 1/23/2002 19:39' prior: 0!
This is a skiplist node. It can be treated as an association that allows a 'next' operator to go to the next node in the skiplist.

!


!SkipListNode methodsFor: 'accessing' stamp: 'LC 6/17/2001 12:55'!
atForward: i put: node
	^ pointers at: i put: node! !

!SkipListNode methodsFor: 'accessing' stamp: 'LC 6/18/2001 13:34'!
forward: i 
	^ pointers at: i! !

!SkipListNode methodsFor: 'accessing' stamp: 'LC 6/18/2001 12:21'!
level
	^ pointers size! !

!SkipListNode methodsFor: 'accessing' stamp: 'LC 6/18/2001 19:20'!
next
	^ pointers first! !

!SkipListNode methodsFor: 'accessing' stamp: 'sac 1/22/2002 17:22'!
printOn: aStream
        | first |
        aStream
                nextPut: $[.
        super printOn: aStream.
        aStream
                nextPutAll: ']-->('.
        first _ true.
        pointers do: [:node |
                first ifTrue: [first _ false] ifFalse: [aStream space].
                node ifNil: [aStream nextPutAll: '*'] 
                ifNotNil: [node printOn: aStream]].
        aStream nextPut: $)
! !


!SkipListNode methodsFor: 'initialization' stamp: 'LC 6/17/2001 11:54'!
initialize: maxLevel
	pointers _ Array new: maxLevel! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SkipListNode class
	instanceVariableNames: ''!

!SkipListNode class methodsFor: 'instance creation' stamp: 'sac 1/22/2002 17:53'!
key: key value: value level: maxLevel 
        ^ (super key: key value: value) initialize: maxLevel! !

!SkipListNode class methodsFor: 'instance creation' stamp: 'LC 6/17/2001 09:16'!
new: maxLevel
	^ super new initialize: maxLevel! !

!SkipListNode class methodsFor: 'instance creation' stamp: 'sac 1/22/2002 17:57'!
on: element level: maxLevel 
        ^ self key: element value: element level: maxLevel
! !

!SkipListNode class methodsFor: 'instance creation' stamp: 'LC 6/18/2001 12:44'!
tailOfLevel: n
	^ self on: nil level: n! !
ClassTestCase subclass: #SkipListTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-SkipLists'!
!SkipListTest commentStamp: 'tlk 4/30/2006 21:49' prior: 0!
A SkipListTest is tests basic functionality of SkipList

Instance Variables: none
!


!SkipListTest methodsFor: 'implementationTests' stamp: 'sd 3/25/2006 14:32'!
testAdd
	"tests size after adding element"
	
	"self run:#testAdd"
	| s |
	s := SkipList new.
	s add: 1.
	self assert: s size = 1
! !

!SkipListTest methodsFor: 'implementationTests' stamp: 'sd 3/25/2006 14:32'!
testAddIfPresent
	"adds an already existing element. Decides to add another one in the
	ifPresent block"
	
	| s |
	s := SkipList new.
	s add: 1.
	self
		shouldnt: [s
					add: 1
					ifPresent: [s add: 2]]
		raise: Exception.
	self assert: s size = 2
! !

!SkipListTest methodsFor: 'implementationTests' stamp: 'tlk 4/30/2006 21:37'!
testMaxLevel
	"No node should have a level greater than the skiplist maxLevel"
	"self run: #testMaxLevel"
	| s |
	s := SkipList new.
	s add: 12.
	s add: 53.
	s add: 14.
	s
		nodesDo: [:n | 
			      self
   					assert: n level <= s maxLevel]! !

!SkipListTest methodsFor: 'implementationTests' stamp: 'sd 5/2/2006 20:45'!
testNavigation
	"self run: #testNavigation"
	| node1 node2 node3 node4 skip |
	node1 := SkipListNode
				key: 1
				value: 3
				level: 1.
	node2 := SkipListNode
				key: 2
				value: 7
				level: 2.
	node3 := SkipListNode
				key: 3
				value: 11
				level: 1.
	node4 := SkipListNode
				key: 4
				value: 23
				level: 2.
	node1 atForward: 1 put: node2.
	node2 atForward: 1 put: node3.
	node2 atForward: 2 put: node4.
	node4 atForward: 1 put: nil.
	skip := SkipList new.
	skip atForward: 1 put: node1.
	skip atForward: 2 put: node2.
	self assert: skip first = node1.
	self
		assert: (skip at: 2) = node2 value! !

!SkipListTest methodsFor: 'implementationTests' stamp: 'YE 2/28/2006 09:45'!
testRandomLevel
	"a randomLevel should not be greater than maxLevel"
	"self run: #testRandomLevel"
	| s |
	s := SkipList new.
	s maxLevel: 5.
	self assert: s randomLevel <= 5! !


!SkipListTest methodsFor: 'public' stamp: 'sd 5/2/2006 20:45'!
testAt
	"self run: #testAt"
	"self debug: #testAt"

	| sk |
	sk := SkipList new.
	sk at: 11 put: '111111'.
	sk at: 3 put: '3333'.
	sk at: 7 put: '77777'.
	sk at: 3 put: '666'.
	self assert: (sk at: 7) = '77777'.
	self assert: (sk includes: 7). 
	self assert: (sk at: 3) = '3333'.
	self assert: (sk includes: 3). 
	self assert: (sk size) = 3

	! !

!SkipListTest methodsFor: 'public' stamp: 'YE 3/8/2006 10:00'!
testAtPutAlreadyPresent
	"self run: #testAtPutAlreadyPresent"
	"self debug: #testAtPutAlreadyPresent"

	| sk |
	sk := SkipList new.
	sk at: 11 put: '111111'.
	sk at: 3 put: '3333'.
	sk at: 7 put: '77777'.
	sk at: 3 put: '666'.
	
	self assert: (sk at: 7) = '77777'.
	self assert: (sk includes: 7). 
	
	self assert: (sk at: 3) = '3333'.
	
	self assert: (sk includes: 3). 
	self assert: (sk size) = 3

	! !

!SkipListTest methodsFor: 'public' stamp: 'YE 3/8/2006 09:56'!
testCreation
	"self run: #testCreation"
	"self debug: #testCreation"

	| sk |
	sk := SkipList new.
	sk at: 11 put: '111111'.
	sk at: 3 put: '3333'.
	sk at: 7 put: '77777'.
	self assert: (sk at: 7) = '77777'.
	self assert: (sk includes: 7). 

	! !

!SkipListTest methodsFor: 'public' stamp: 'YE 3/16/2006 10:50'!
testIfAbsent
	"self run: #testIfAbsent"
	"self debug: #testIfAbsent"

	| sk temp |
	sk := SkipList new.
	sk at: 11 put: '111111'.
	sk at: 3 put: '3333'.
	sk at: 7 put: '77777'.
	sk add: 7 ifPresent: [sk at: 8 put: '88'].
	temp := sk at: 9 ifAbsent: [sk at: 8].
	self assert: (temp = '88')
	
	

	! !

!SkipListTest methodsFor: 'public' stamp: 'YE 3/16/2006 10:49'!
testIfPresent
	"self run: #testIfPresent"
	"self debug: #testIfPresent"

	| sk |
	sk := SkipList new.
	sk at: 11 put: '111111'.
	sk at: 3 put: '3333'.
	sk at: 7 put: '77777'.
	sk add: 7 ifPresent: [sk at: 8 put: '88'].
	self assert: (sk at: 7) = '77777'.
	self assert: (sk at: 8) = '88'.
	

	! !

!SkipListTest methodsFor: 'public' stamp: 'YE 3/16/2006 11:47'!
testIsEqualTo
	"self run: #testIsEqualTo"
	"self debug: #testIsEqualTo"

	| sk sk2 |
	sk := SkipList new.
	sk2 := SkipList new.
	sk at: 11 put: '111111'.
	sk at: 3 put: '3333'.
	sk at: 7 put: '77777'.
	sk at: 9 put: '3333'.
	
	sk2 at: 3 put: '3333'.
	sk2 at: 5 put: '3333'.
	self assert: (sk is: (sk at: 3) equalTo: (sk at: 9)).
	self assert: (sk is: (sk at: 3) equalTo: (sk2 at: 3)).
	self assert: (sk is: (sk at: 3) equalTo: (sk2 at: 5))
	
	
	

	! !

!SkipListTest methodsFor: 'public' stamp: 'sd 3/25/2006 14:36'!
testRemove
	"tests size after removing element"
	"self run:#testRemove"
	
	| s |
	s := SkipList new.
	s add: 1.
	self assert: s size = 1.
	self
		should: [s remove: 2]
		raise: Exception.
	s remove: 1.
	self assert: s size = 0
! !
MorphicModel subclass: #Slider
	instanceVariableNames: 'slider value setValueSelector sliderShadow sliderColor descending'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!Slider methodsFor: 'access' stamp: 'sw 3/10/2000 13:05'!
descending
	^ descending == true! !

!Slider methodsFor: 'access' stamp: 'sw 3/12/2000 11:57'!
descending: aBoolean
	descending _ aBoolean.
	self value: value! !

!Slider methodsFor: 'access' stamp: 'dew 2/15/1999 18:24'!
pagingArea
	^self! !

!Slider methodsFor: 'access' stamp: 'dew 3/23/2002 01:38'!
sliderColor
	"color scheme for the whole slider widget"
	sliderColor ifNil: [^ (color alphaMixed: 0.7 with: Color white) slightlyLighter].
	^ sliderColor! !

!Slider methodsFor: 'access' stamp: 'sw 3/7/2000 15:39'!
sliderColor: newColor

	sliderColor _ newColor.
	slider ifNotNil: [slider color: sliderColor]! !

!Slider methodsFor: 'access' stamp: 'dew 3/4/2002 00:50'!
sliderShadowColor
	^ self sliderColor alphaMixed: 0.2 with: self pagingArea color! !

!Slider methodsFor: 'access' stamp: 'dew 1/21/2002 01:31'!
thumbColor
	"Color of the draggable 'thumb'"
	^ self sliderColor! !

!Slider methodsFor: 'access'!
value
	^ value! !

!Slider methodsFor: 'access' stamp: '6/7/97 10:42 di'!
wantsSlot
	"For now do it the old way, until we sort this out"
	^ true! !


!Slider methodsFor: 'geometry' stamp: 'sw 3/10/2000 13:44'!
computeSlider
	| r |
	r _ self roomToMove.
	self descending
		ifFalse:
			[slider position: (bounds isWide
				ifTrue: [r topLeft + ((r width * value) asInteger @ 0)]
				ifFalse: [r topLeft + (0 @ (r height * value)  asInteger)])]
		ifTrue:
			[slider position: (bounds isWide
				ifTrue:	[r bottomRight - ((r width * value) asInteger @ 0)]
				ifFalse:	[r bottomRight - ((0 @ (r height * value) asInteger))])].
	slider extent: self sliderExtent! !

!Slider methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'!
extent: newExtent
	newExtent = bounds extent ifTrue: [^ self].
	bounds isWide
		ifTrue: [super extent: (newExtent x max: self sliderThickness * 2) @ newExtent y]
		ifFalse: [super extent: newExtent x @ (newExtent y max: self sliderThickness * 2)].
	self removeAllMorphs; initializeSlider! !

!Slider methodsFor: 'geometry'!
roomToMove
	^ self totalSliderArea insetBy: (0@0 extent: self sliderExtent)! !

!Slider methodsFor: 'geometry'!
sliderExtent
	^ bounds isWide
		ifTrue: [self sliderThickness @ self innerBounds height]
		ifFalse: [self innerBounds width @ self sliderThickness]! !

!Slider methodsFor: 'geometry' stamp: 'ar 12/18/2001 21:19'!
sliderThickness
	^ 7! !

!Slider methodsFor: 'geometry'!
totalSliderArea
	^ self innerBounds! !


!Slider methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #inset! !

!Slider methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!Slider methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 corner: 16 @ 100! !

!Slider methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!Slider methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:30'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	value _ 0.0.
	descending _ false.
	self initializeSlider! !

!Slider methodsFor: 'initialization' stamp: 'jrp 8/3/2005 10:13'!
initializeSlider
	slider _ RectangleMorph newBounds: self totalSliderArea color: self thumbColor.
	sliderShadow _ RectangleMorph newBounds: self totalSliderArea
						color: self pagingArea color.
	slider on: #mouseMove send: #scrollAbsolute: to: self.
	slider on: #mouseDown send: #mouseDownInSlider: to: self.
	slider on: #mouseUp send: #mouseUpInSlider: to: self.
	slider setBorderWidth: 1 borderColor: Color lightGray..
	sliderShadow setBorderWidth: 1 borderColor: #inset.
	"(the shadow must have the pagingArea as its owner to highlight properly)"
	self pagingArea addMorph: sliderShadow.
	sliderShadow hide.
	self addMorph: slider.
	self computeSlider.
! !


!Slider methodsFor: 'model access'!
setValue: newValue
	"Called internally for propagation to model"
	self value: newValue.
	self use: setValueSelector orMakeModelSelectorFor: 'Value:'
		in: [:sel | setValueSelector _ sel.  model perform: sel with: value]! !

!Slider methodsFor: 'model access'!
value: newValue
	"Drive the slider position externally..."
	value _ newValue min: 1.0 max: 0.0.
	self computeSlider! !


!Slider methodsFor: 'other events' stamp: 'sd 11/8/2003 16:02'!
mouseDownInSlider: event 

	slider borderStyle style == #raised
		ifTrue: [slider borderColor: #inset].
	
	sliderShadow color: self sliderShadowColor.
	sliderShadow cornerStyle: slider cornerStyle.
	sliderShadow bounds: slider bounds.
	sliderShadow show! !

!Slider methodsFor: 'other events' stamp: 'sd 11/8/2003 16:02'!
mouseUpInSlider: event 

	slider borderStyle style == #inset
		ifTrue: [slider borderColor: #raised].
	
	sliderShadow hide! !


!Slider methodsFor: 'scrolling' stamp: 'sw 3/10/2000 13:37'!
scrollAbsolute: event
	| r p |
	r _ self roomToMove.
	bounds isWide
		ifTrue: [r width = 0 ifTrue: [^ self]]
		ifFalse: [r height = 0 ifTrue: [^ self]].
	p _ event targetPoint adhereTo: r.
	self descending
		ifFalse:
			[self setValue: (bounds isWide 
				ifTrue: [(p x - r left) asFloat / r width]
				ifFalse: [(p y - r top) asFloat / r height])]
		ifTrue:
			[self setValue: (bounds isWide
				ifTrue: [(r right - p x) asFloat / r width]
				ifFalse:	[(r bottom - p y) asFloat / r height])]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Slider class
	instanceVariableNames: ''!

!Slider class methodsFor: 'new-morph participation' stamp: 'di 2/21/98 11:03'!
includeInNewMorphMenu
	"OK to instantiate"
	^ true! !
StarSqueakTurtle subclass: #SlimeMoldTurtle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!SlimeMoldTurtle methodsFor: 'demons' stamp: 'jm 2/5/2001 17:25'!
breakLoose
	"If I smell pheromone, turn in the direction that it gets stronger. Otherwise, turn a random amount right or left. In either case, move forward one step."

	((self random: 100) < 10) ifTrue: [
		self turnRight: (self random: 360).
		self forward: 3].
! !

!SlimeMoldTurtle methodsFor: 'demons' stamp: 'jm 1/23/2001 12:06'!
dropPheromone

	self increment: 'pheromone' by: 100.
! !

!SlimeMoldTurtle methodsFor: 'demons' stamp: 'jm 2/5/2001 17:31'!
followPheromone
	"If I smell pheromone, turn in the direction that it gets stronger. Otherwise, turn a random amount right or left. In either case, move forward one step."

	((self get: 'pheromone') > 60)
		ifTrue: [self turnTowardsStrongest: 'pheromone']
		ifFalse: [
			self turnRight: (self random: 45).
			self turnLeft: (self random: 45)].
	self forward: 1.
! !

!SlimeMoldTurtle methodsFor: 'demons' stamp: 'jm 3/10/2001 11:19'!
walk

	self forward: 1.
! !
Object subclass: #SlotInformation
	instanceVariableNames: 'type documentation floatPrecision variableDock variableDefinition'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!SlotInformation commentStamp: '<historical>' prior: 0!
Holds information about user-defined instance variables in Players.!


!SlotInformation methodsFor: 'access' stamp: 'yo 8/1/2004 02:05'!
documentation
	"Answer the receiver's documentation"

	documentation ifNil: [documentation _ 'This is a variable defined by you.  Please edit this into your own meaningful documentation.' translated].
	^ documentation! !

!SlotInformation methodsFor: 'access' stamp: 'sw 11/6/1998 10:33'!
documentation: d
	documentation _ d! !

!SlotInformation methodsFor: 'access' stamp: 'sw 7/27/2001 18:19'!
floatPrecision
	"Answer the floatPrecision for the slot:
		1.0 ->	show whole number
		0.1	->	show one digit of precision
		.01 ->	show two digits of precision
		etc.
	Initialize the precision to 1 if it is not present"

	^ floatPrecision isNumber ifTrue: [floatPrecision] ifFalse: [floatPrecision _ 1]! !

!SlotInformation methodsFor: 'access' stamp: 'sw 9/8/1999 18:31'!
floatPrecision: prec
	floatPrecision _ prec! !

!SlotInformation methodsFor: 'access' stamp: 'sw 4/22/2002 15:10'!
type
	"Answer the type of the receiver, initializing it to Number if it is nil"

	type isEmptyOrNil ifTrue: [^ type _ #Number].
	type first isUppercase ifFalse: [^ type _ type capitalized].
		"because of lingering, annoying issue of projects created in a plug-in image"
	^ type! !

!SlotInformation methodsFor: 'access' stamp: 'sw 11/6/1998 10:31'!
type: aType
	type _ aType! !

!SlotInformation methodsFor: 'access' stamp: 'sw 10/30/2000 10:15'!
variableDock
	"Answer the variable dock associated with the receiver, or nil if none"

	^ variableDock! !

!SlotInformation methodsFor: 'access' stamp: 'sw 10/30/2000 10:16'!
variableDock: vd
	"Set the receiver's variableDock as indicated"

	variableDock _ vd! !


!SlotInformation methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:44'!
initialize
	"Initialize the receiver's instance variables to default values"

	documentation _ 'as yet undocumented'.
	type _ #Number.
	floatPrecision _ 0.1.! !


!SlotInformation methodsFor: 'printing' stamp: 'sw 9/8/1999 22:11'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' precision: ', floatPrecision asString, ' ; type = ', type asString! !
Stream subclass: #SmaCCLineNumberStream
	instanceVariableNames: 'sourceStream previousWasCR eolPositions lastPosition'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SmaCC-Runtime'!
!SmaCCLineNumberStream commentStamp: 'jmb' prior: 0!
SmaCCLineNumberStream is a wrapper for streams that calculates line numbers.

Instance Variables:
	eolPositions	<OrderedCollection of: Integer>	the positions of each end of line
	lastPosition	<Integer>	the position of the last character that we have calculated the end of line information for (we know the line number for all characters before this position and don't know anything about the characters after this position)
	previousWasCR	<Boolean>	was the previous character a CR. This is used for CR LF streams. A CR LF combination should only increment the line counter by 1
	sourceStream	<Stream>	the stream that we are wrapping

!


!SmaCCLineNumberStream methodsFor: 'accessing'!
contents
	^sourceStream contents! !

!SmaCCLineNumberStream methodsFor: 'accessing'!
flush
	^sourceStream flush! !

!SmaCCLineNumberStream methodsFor: 'accessing'!
lineNumber
	| index start stop pos |
	pos := sourceStream position.
	pos >= eolPositions last ifTrue: [^eolPositions size].
	start := 1.
	stop := eolPositions size.
	[start + 1 < stop] whileTrue: 
			[index := (start + stop) // 2.
			(eolPositions at: index) <= pos 
				ifTrue: [start := index]
				ifFalse: [stop := index]].
	^start! !

!SmaCCLineNumberStream methodsFor: 'accessing'!
next
	| character |
	character := sourceStream next.
	sourceStream position - 1 == lastPosition 
		ifTrue: 
			[lastPosition := lastPosition + 1.
			character == Character cr 
				ifTrue: 
					[eolPositions add: sourceStream position.
					previousWasCR := true]
				ifFalse: 
					[(previousWasCR not and: [character == Character lf]) 
						ifTrue: [eolPositions add: sourceStream position].
					previousWasCR := false]].
	^character! !

!SmaCCLineNumberStream methodsFor: 'accessing'!
nextPut: anObject 
	^sourceStream nextPut: anObject! !

!SmaCCLineNumberStream methodsFor: 'accessing'!
position
	^sourceStream position! !

!SmaCCLineNumberStream methodsFor: 'accessing'!
position: anInteger 
	anInteger > lastPosition 
		ifTrue: 
			[sourceStream position: lastPosition.
			[sourceStream position < anInteger and: [sourceStream atEnd not]] 
				whileTrue: [self next]]
		ifFalse: [sourceStream position: anInteger]! !

!SmaCCLineNumberStream methodsFor: 'accessing'!
skip: anInteger
	^self position: self position + anInteger! !

!SmaCCLineNumberStream methodsFor: 'accessing' stamp: 'jmb 1/20/2003 21:45'!
upTo: aCharacter 
	| stream char |
	stream := WriteStream on: String new.
	[self atEnd or: [(char := self next) == aCharacter]] 
		whileFalse: [stream nextPut: char].
	^stream contents! !


!SmaCCLineNumberStream methodsFor: 'error handling'!
doesNotUnderstand: aMessage 
	^sourceStream perform: aMessage selector withArguments: aMessage arguments! !


!SmaCCLineNumberStream methodsFor: 'initialize-release'!
on: aReadStream 
	sourceStream := aReadStream.
	eolPositions := OrderedCollection with: aReadStream position.
	lastPosition := aReadStream position.
	previousWasCR := false! !


!SmaCCLineNumberStream methodsFor: 'testing'!
atEnd
	^sourceStream atEnd! !

!SmaCCLineNumberStream methodsFor: 'testing'!
isReadable
	^sourceStream isReadable! !

!SmaCCLineNumberStream methodsFor: 'testing'!
isWritable
	^sourceStream isWritable! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmaCCLineNumberStream class
	instanceVariableNames: ''!

!SmaCCLineNumberStream class methodsFor: 'instance creation'!
on: aReadStream 
	^(self basicNew)
		on: aReadStream;
		yourself! !
Object subclass: #SmaCCParser
	instanceVariableNames: 'scanner currentToken errorToken stateStack nodeStack'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SmaCC-Runtime'!
!SmaCCParser commentStamp: 'jmb' prior: 0!
SmaCCParser is an abstract class that defines most of the parsing actions. Subclasses will define methods that specify their transitions and reduction actions. These are normally defined automatically when compiling the parser.

Subclasses must implement the following messages:
	accessing
		emptySymbolTokenId
		reduceTable
		transitionTable

Instance Variables:
	currentToken	<SmaCCToken>	the token last returned by the scanner that has not been shifted (reduce actions leave the current token alone)
	nodeStack	<OrderedCollection>	collection of items on stack. These items are specific to the parser and can be any object. 
	scanner	<SmaCCScanner>	our scanner
	stateStack	<OrderedCollection of: Integer>	the stack of states for our parser (standard LR state stack)

!


!SmaCCParser methodsFor: 'accessing'!
emptySymbolTokenId
	^scanner emptySymbolTokenId! !

!SmaCCParser methodsFor: 'accessing'!
errorTable
	^#()! !

!SmaCCParser methodsFor: 'accessing'!
errorTokenId
	^scanner errorTokenId! !

!SmaCCParser methodsFor: 'accessing'!
parse
	self setDefaultStartingStateIfNone.
	self performParsingLoop.
	^nodeStack last! !

!SmaCCParser methodsFor: 'accessing'!
position
	^currentToken isNil 
		ifTrue: [scanner position]
		ifFalse: [currentToken startPosition]! !

!SmaCCParser methodsFor: 'accessing'!
reduceTable
	^self subclassResponsibility! !

!SmaCCParser methodsFor: 'accessing' stamp: 'md 11/9/2004 11:11'!
stringValue: anOrderedCollection
	^anOrderedCollection first value.! !

!SmaCCParser methodsFor: 'accessing'!
transitionTable
	^self subclassResponsibility! !


!SmaCCParser methodsFor: 'initialize-release'!
initialize
	nodeStack := OrderedCollection new! !

!SmaCCParser methodsFor: 'initialize-release'!
scanner: aScanner 
	scanner := aScanner! !

!SmaCCParser methodsFor: 'initialize-release'!
setStartingState: startingState 
	stateStack := OrderedCollection with: startingState! !


!SmaCCParser methodsFor: 'testing'!
isEOFToken
	^currentToken id first = self emptySymbolTokenId! !


!SmaCCParser methodsFor: 'private'!
acceptAction
	^0! !

!SmaCCParser methodsFor: 'private'!
actionFor: aSymbolIndex 
	^self actionForState: self currentState and: aSymbolIndex! !

!SmaCCParser methodsFor: 'private'!
actionForCurrentToken
	^self actionFor: currentToken id first! !

!SmaCCParser methodsFor: 'private' stamp: 'fbs 2/13/2006 23:08'!
actionForState: stateIndex and: aSymbolIndex 
	| index row |
	row := self transitionTable at: stateIndex.
	(row at: 1) = 2 
		ifTrue: 
			[index := self 
						binarySearchIn: row
						for: aSymbolIndex
						size: 1.
			index = 0 ifTrue: [^self errorAction] ifFalse: [^row at: 2]]
		ifFalse: 
			[index := self 
						binarySearchIn: row
						for: aSymbolIndex
						size: 2.
			index = 0 ifTrue: [^self errorAction] ifFalse: [^row at: index - 1]]! !

!SmaCCParser methodsFor: 'private'!
actionMask
	^2r11! !

!SmaCCParser methodsFor: 'private'!
binarySearchIn: aRow for: aSymbolIndex size: step 
	| start mid length midItem stop |
	start := 3.
	stop := aRow size.
	length := (stop - start) // step.
	[length > 4] whileTrue: 
			[length := length bitShift: -1.
			mid := length * step + start.
			midItem := aRow at: mid.
			midItem <= aSymbolIndex ifTrue: [start := mid] ifFalse: [stop := mid]].
	[start <= stop] whileTrue: 
			[(aRow at: start) == aSymbolIndex ifTrue: [^start].
			start := start + step].
	^0! !

!SmaCCParser methodsFor: 'private'!
currentState
	^stateStack last! !

!SmaCCParser methodsFor: 'private'!
errorAction
	^3! !

!SmaCCParser methodsFor: 'private'!
findErrorHandlerIfNoneUseErrorNumber: anInteger 
	| handlerStates index startingErrorToken newStack |
	handlerStates := self errorHandlerStates reverse.
	startingErrorToken := currentToken.
	
	[index := (1 to: handlerStates size) detect: 
					[:each | 
					| state |
					state := handlerStates at: each.
					state ~= 0 and: 
							[newStack := stateStack copyFrom: 1 to: handlerStates size - each + 1.
							newStack add: state.
							self willShift: newStack]]
				ifNone: [nil].
	index isNil] 
			whileTrue: 
				[self dismissErrorToken.
				currentToken id first = self emptySymbolTokenId 
					ifTrue: 
						[currentToken := startingErrorToken.
						self reportError: anInteger]].
	index - 1 timesRepeat: [self dismissStackTopForErrorRecovery].
	stateStack addLast: (handlerStates at: index).
	nodeStack addLast: startingErrorToken! !

!SmaCCParser methodsFor: 'private'!
getNextToken
	currentToken isNil ifTrue: [currentToken := scanner next]! !

!SmaCCParser methodsFor: 'private'!
liftFirstValue: aCollection 
	^aCollection first! !

!SmaCCParser methodsFor: 'private'!
liftLastValue: aCollection 
	^aCollection last! !

!SmaCCParser methodsFor: 'private'!
liftSecondValue: aCollection 
	^aCollection at: 2! !

!SmaCCParser methodsFor: 'private'!
performParsingLoop
	| action actionType |
	
	[self getNextToken.
	action := self actionForCurrentToken.
	action = self acceptAction] 
			whileFalse: 
				[actionType := action bitAnd: self actionMask.
				action := action bitShift: -2.
				actionType == self shiftAction 
					ifTrue: [self shift: action]
					ifFalse: 
						[actionType == self reduceAction 
							ifTrue: [self reduce: action]
							ifFalse: [self handleError: action]]].
	self checkForErrors! !

!SmaCCParser methodsFor: 'private'!
performReduceMethod: aSymbol with: items 
	^aSymbol last == $: 
		ifTrue: [self perform: aSymbol with: items]
		ifFalse: [self perform: aSymbol]! !

!SmaCCParser methodsFor: 'private'!
reduce: anInteger 
	| reduceEntry items size |
	reduceEntry := self reduceTable at: anInteger.
	items := OrderedCollection new: (size := reduceEntry at: 2).
	size timesRepeat: 
			[items addFirst: nodeStack removeLast.
			stateStack removeLast].
	nodeStack add: (self performReduceMethod: (reduceEntry at: 3) with: items).
	stateStack add: ((self actionFor: (reduceEntry at: 1)) bitShift: -2)! !

!SmaCCParser methodsFor: 'private'!
reduceAction
	^2r10! !

!SmaCCParser methodsFor: 'private'!
reduceFor: aCollection 
	| newCollection item |
	(aCollection allSatisfy: [:each | each class ~~ OrderedCollection]) 
		ifTrue: [^aCollection].
	aCollection first class == OrderedCollection 
		ifTrue: 
			[newCollection := aCollection first.
			2 to: aCollection size
				do: 
					[:i | 
					item := aCollection at: i.
					item class = OrderedCollection 
						ifTrue: [newCollection addAll: item]
						ifFalse: [newCollection add: item]].
			^newCollection].
	newCollection := OrderedCollection new.
	aCollection do: 
			[:each | 
			each class == OrderedCollection 
				ifTrue: [newCollection addAll: each]
				ifFalse: [newCollection add: each]].
	^newCollection! !

!SmaCCParser methodsFor: 'private'!
setDefaultStartingStateIfNone
	stateStack isNil 
		ifTrue: [self setStartingState: self class defaultStartingState]! !

!SmaCCParser methodsFor: 'private'!
shift: stateIndex 
	stateStack add: stateIndex.
	nodeStack add: currentToken.
	currentToken := nil! !

!SmaCCParser methodsFor: 'private'!
shiftAction
	^2r01! !


!SmaCCParser methodsFor: 'private-error handling'!
checkForErrors
	"If we have an error correction installed, we might have handled the errors. If we did, we don't 
	want to return the result, so we raise a final exception that can't be proceeded."

	errorToken isNil ifTrue: [^self].
	currentToken := errorToken.
	self reportErrorMessage: 'Token not expected'! !

!SmaCCParser methodsFor: 'private-error handling'!
dismissErrorToken
	currentToken := nil.
	self getNextToken! !

!SmaCCParser methodsFor: 'private-error handling'!
dismissStackTopForErrorRecovery
	stateStack removeLast.
	^nodeStack removeLast! !

!SmaCCParser methodsFor: 'private-error handling'!
errorHandlerStates
	^stateStack collect: 
			[:each | 
			| action |
			action := self actionForState: each and: self errorTokenId.
			(action bitAnd: self actionMask) = 1 
				ifTrue: [action bitShift: -2]
				ifFalse: [0]]! !

!SmaCCParser methodsFor: 'private-error handling'!
handleError: anInteger 
	errorToken isNil ifTrue: [errorToken := currentToken].
	(currentToken id first = self emptySymbolTokenId 
		or: [self hasErrorHandler not]) ifTrue: [self reportError: anInteger].
	self findErrorHandlerIfNoneUseErrorNumber: anInteger! !

!SmaCCParser methodsFor: 'private-error handling'!
hasErrorHandler
	^self errorHandlerStates anySatisfy: [:each | each ~~ 0]! !

!SmaCCParser methodsFor: 'private-error handling'!
reportError: anInteger 
	self reportErrorMessage: (anInteger = 0 
				ifTrue: ['Token not expected']
				ifFalse: [self errorTable at: anInteger])! !

!SmaCCParser methodsFor: 'private-error handling' stamp: 'jmb 1/20/2003 21:52'!
reportErrorMessage: aString 
	(SmaCCParserError new)
		tag: self;
		signal: aString! !

!SmaCCParser methodsFor: 'private-error handling'!
willShift: potentialStateStack 
	| action compoundAction reduceEntry size |
	compoundAction := self actionForState: potentialStateStack last
				and: currentToken id first.
	action := compoundAction bitAnd: self actionMask.
	action == self shiftAction ifTrue: [^true].
	action == self reduceAction 
		ifTrue: 
			[reduceEntry := self reduceTable at: (compoundAction bitShift: -2).
			size := reduceEntry at: 2.
			size timesRepeat: [potentialStateStack removeLast].
			potentialStateStack 
				add: ((self actionForState: potentialStateStack last
						and: (reduceEntry at: 1)) bitShift: -2).
			^self willShift: potentialStateStack].
	^false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmaCCParser class
	instanceVariableNames: ''!

!SmaCCParser class methodsFor: 'accessing'!
parse: aString 
	^self parse: aString startingAt: self defaultStartingState! !

!SmaCCParser class methodsFor: 'accessing' stamp: 'jmb 1/20/2003 22:09'!
parse: aString onError: aBlock 
	^[self parse: aString] on: SmaCCParserError
		do: [:ex | ex return: (aBlock value: ex description value: ex tag position)]! !

!SmaCCParser class methodsFor: 'accessing'!
parse: aString startingAt: anInteger 
	^self parseStream: (ReadStream on: aString) startingAt: anInteger! !

!SmaCCParser class methodsFor: 'accessing' stamp: 'jmb 1/20/2003 22:04'!
parse: aString startingAt: anInteger onError: aBlock 
	^[self parse: aString startingAt: anInteger] on: SmaCCParserError
		do: [:ex | ex return: (aBlock value: ex description value: ex tag position)]! !

!SmaCCParser class methodsFor: 'accessing'!
parseStream: aStream 
	^self parseStream: aStream startingAt: self defaultStartingState! !

!SmaCCParser class methodsFor: 'accessing' stamp: 'jmb 1/20/2003 22:11'!
parseStream: aStream onError: aBlock 
	^[self parseStream: aStream] on: SmaCCParserError
		do: [:ex | ex return: (aBlock value: ex description value: ex tag position)]! !

!SmaCCParser class methodsFor: 'accessing'!
parseStream: aStream startingAt: anInteger 
	| parser |
	parser := self on: aStream.
	parser setStartingState: anInteger.
	^parser parse! !

!SmaCCParser class methodsFor: 'accessing' stamp: 'md 9/4/2005 16:58'!
parseStream: aStream startingAt: anInteger onError: aBlock 
	^[self parseStream: aStream startingAt: anInteger] 
		on: SmaCCParserError
		do: [:ex | ex return: (aBlock value: ex description value: ex tag position)]! !


!SmaCCParser class methodsFor: 'instance creation'!
on: aStream 
	| parser scanner |
	scanner := self scannerClass on: aStream.
	parser := self new.
	parser scanner: scanner.
	^parser! !


!SmaCCParser class methodsFor: 'private'!
defaultStartingState
	^1! !

!SmaCCParser class methodsFor: 'private'!
scannerClass
	^self subclassResponsibility! !
Error subclass: #SmaCCParserError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SmaCC-Runtime'!
!SmaCCParserError commentStamp: 'jmb' prior: 0!
SmaCCParserException is the exception raised when a parsing error occurs. The description of the exception will be the error message and the parameter of the exception is the parser. With this information, you can insert a custom error message in your text view that you are parsing. For example, in VisualWorks, the following code will insert an error message into your text view:
	textController insertAndSelect: ex description , ' ->' at: ex parameter position!

Object subclass: #SmaCCScanner
	instanceVariableNames: 'stream start matchActions matchEnd currentCharacter outputStream lastOutputStreamMatchPosition lastMatchWasEmpty returnMatchBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SmaCC-Runtime'!
!SmaCCScanner commentStamp: 'jmb' prior: 0!
SmaCCScanner is an abstract class that represents a scanner for the parser. The scanner converts its string input into SmaCCToken objects that the parser then uses for its parsing.

Subclasses must implement the following messages:
	accessing
		scanForToken

Instance Variables:
	currentCharacter	<Character>	the current character we are scanning
	lastMatchWasEmpty	<Boolean>	was our last scanning match an empty string -- don't allow two empty matches in a row
	lastOutputStreamMatchPosition	<Integer>	the position in the outputStream of the last match
	matchActions	<Array | Symbol>	the actions for the last match (a symbol means that the action should be performed on the scanner)
	matchEnd	<Integer>	the position of the last match in the stream (our input stream)
	outputStream	<PositionableStream>	the matched characters go in this stream. After a match is made, we take this stream's contents and create a token object.
	returnMatchBlock	<BlockClosure>	when we match a token evaluate this block with the token (hack to return from multiple levels)
	start	<Integer>	the starting position of a match in the stream
	stream	<Stream>	our input

!


!SmaCCScanner methodsFor: 'accessing'!
contents
	| writeStream token |
	writeStream := WriteStream on: Array new.
	[self atEnd] whileFalse: 
			[token := self next.
			token notNil ifTrue: [writeStream nextPut: token]].
	^writeStream contents! !

!SmaCCScanner methodsFor: 'accessing'!
emptySymbolTokenId
	^self subclassResponsibility! !

!SmaCCScanner methodsFor: 'accessing'!
errorTokenId
	^self subclassResponsibility! !

!SmaCCScanner methodsFor: 'accessing'!
lineNumber
	"This requires the stream to be a line number stream (see the #needsLineNumbers class method)."

	^stream lineNumber! !

!SmaCCScanner methodsFor: 'accessing'!
next
	self resetScanner.
	returnMatchBlock := [:match | ^match].
	self scanForToken! !

!SmaCCScanner methodsFor: 'accessing'!
position
	^stream position! !

!SmaCCScanner methodsFor: 'accessing'!
position: anInteger
	^stream position: anInteger! !

!SmaCCScanner methodsFor: 'accessing'!
scanForToken
	^self subclassResponsibility! !


!SmaCCScanner methodsFor: 'default token handling'!
comment
	"In case someone wants to record the comments"

	self whitespace! !

!SmaCCScanner methodsFor: 'default token handling'!
whitespace
	"By default, eat the whitespace"

	self resetScanner.
	self scanForToken! !


!SmaCCScanner methodsFor: 'initialize-release'!
initialize
	outputStream := WriteStream on: (String new: self initialBufferSize).
	lastMatchWasEmpty := true! !

!SmaCCScanner methodsFor: 'initialize-release' stamp: 'ajh 3/17/2003 12:05'!
on: aStream 
	stream := aStream.
	start := stream position + 1.! !


!SmaCCScanner methodsFor: 'testing'!
atEnd
	^stream atEnd! !


!SmaCCScanner methodsFor: 'private'!
checkForKeyword: aString 
	| stateMap action |
	action := matchActions isSymbol 
				ifTrue: [matchActions]
				ifFalse: [matchActions first].
	stateMap := self class keywordMap at: action ifAbsent: [nil].
	stateMap isNil ifTrue: [^self].
	matchActions := stateMap at: (self keywordFor: aString)
				ifAbsent: [matchActions].
	matchActions isInteger 
		ifTrue: [matchActions := Array with: matchActions with: action]! !

!SmaCCScanner methodsFor: 'private'!
checkForValidMatch
	matchActions isNil ifTrue: [self scannerError]! !

!SmaCCScanner methodsFor: 'private'!
createTokenFor: string 
	| token |
	token := SmaCCToken 
				value: string
				start: start
				id: matchActions.
	outputStream reset.
	matchActions := nil.
	returnMatchBlock value: token! !

!SmaCCScanner methodsFor: 'private'!
initialBufferSize
	^128! !

!SmaCCScanner methodsFor: 'private'!
recordAndReportMatch: aCollection 
	self
		recordMatch: aCollection;
		reportLastMatch! !

!SmaCCScanner methodsFor: 'private'!
recordMatch: aCollection 
	matchActions := aCollection.
	matchEnd := stream position.
	lastOutputStreamMatchPosition := outputStream position! !

!SmaCCScanner methodsFor: 'private'!
reportLastMatch
	"The scanner has found the end of a token and must report it"

	| string |
	self checkForValidMatch.
	self resetOutputToLastMatch.
	stream position: matchEnd.
	string := outputStream contents.
	self checkForKeyword: string.
	matchActions isSymbol 
		ifTrue: [self perform: matchActions]
		ifFalse: [self createTokenFor: string]! !

!SmaCCScanner methodsFor: 'private' stamp: 'fbs 2/13/2006 22:31'!
resetOutputToLastMatch
	outputStream position: lastOutputStreamMatchPosition.
	lastOutputStreamMatchPosition = 0 
		ifTrue: 
			[lastMatchWasEmpty ifTrue: [self scannerError].
			lastMatchWasEmpty := true]
		ifFalse: [lastMatchWasEmpty := false]! !

!SmaCCScanner methodsFor: 'private' stamp: 'ajh 3/17/2003 12:04'!
resetScanner
	start := stream position + 1.
	outputStream reset.
	lastOutputStreamMatchPosition := 0! !

!SmaCCScanner methodsFor: 'private'!
scannerError
	(stream atEnd and: [start == (stream position + 1)]) 
		ifTrue: 
			[returnMatchBlock value: (SmaCCToken 
						value: ''
						start: start
						id: (Array with: self emptySymbolTokenId))].
	stream position: start - 1.
	returnMatchBlock value: (SmaCCToken 
				value: (String with: stream next)
				start: start
				id: #(0))! !

!SmaCCScanner methodsFor: 'private'!
step
	stream atEnd ifTrue: [^self reportLastMatch].
	currentCharacter := stream next.
	outputStream nextPut: currentCharacter! !


!SmaCCScanner methodsFor: 'private-utility'!
keywordFor: aString 
	"Subclasses can override this to ignore case"

	^aString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmaCCScanner class
	instanceVariableNames: 'keywordMap'!

!SmaCCScanner class methodsFor: 'accessing' stamp: 'mga 2/8/2004 22:35'!
frequencyTable
	^#(1)! !

!SmaCCScanner class methodsFor: 'accessing'!
keywordMap
	keywordMap isNil ifTrue: [self initializeKeywordMap].
	^keywordMap! !


!SmaCCScanner class methodsFor: 'class initialization'!
initialize
	self initializeKeywordMap! !

!SmaCCScanner class methodsFor: 'class initialization'!
initializeKeywordMap
	keywordMap := Dictionary new! !


!SmaCCScanner class methodsFor: 'instance creation'!
on: aStream 
	^(self new)
		on: (self needsLineNumbers 
					ifTrue: [SmaCCLineNumberStream on: aStream]
					ifFalse: [aStream]);
		yourself! !


!SmaCCScanner class methodsFor: 'testing'!
needsLineNumbers
	"Redefine to return true, if you need line number information"

	^false! !
Object subclass: #SmaCCToken
	instanceVariableNames: 'start id value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SmaCC-Runtime'!
!SmaCCToken commentStamp: 'jmb' prior: 0!
SmaCCTokens are used as the interface objects between scanner and parser. They hold the string that was scanned and its position information. Also, included in the token is its id. The id specifies what type of token it is.

Instance Variables:
	id	<Array of: Integer>	the list of possible token types this represents. There can be overlapping tokens, so we list all of the id here. The default parser only looks at the first id, but we can redefine this behavior in a subclass to look at all possibilities until we find a valid token.
	start	<Integer>	the starting position of the token in the original input
	value	<Object>	the value of our token (normally a string, but could be anything)
!


!SmaCCToken methodsFor: 'accessing'!
id
	^id! !

!SmaCCToken methodsFor: 'accessing' stamp: 'ajh 2/27/2003 17:55'!
length

	^ value size! !

!SmaCCToken methodsFor: 'accessing' stamp: 'md 8/12/2005 15:09'!
realValue
	^value! !

!SmaCCToken methodsFor: 'accessing' stamp: 'ajh 3/11/2003 23:05'!
sourceInterval

	^ self start to: self stop! !

!SmaCCToken methodsFor: 'accessing' stamp: 'ajh 3/17/2003 12:03'!
start

	^ start! !

!SmaCCToken methodsFor: 'accessing' stamp: 'ajh 3/17/2003 12:03'!
startPosition
	^ start! !

!SmaCCToken methodsFor: 'accessing' stamp: 'ajh 3/17/2003 12:03'!
stop

	^ start ifNotNil: [start + value size - 1]! !

!SmaCCToken methodsFor: 'accessing' stamp: 'md 7/12/2006 19:41'!
stopPosition
	^ start ifNotNil: [start + value size - 1].! !

!SmaCCToken methodsFor: 'accessing'!
value
	^value! !


!SmaCCToken methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:36'!
start: startPositionInteger

	start := startPositionInteger
! !

!SmaCCToken methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:36'!
value: anObject

	value := anObject! !

!SmaCCToken methodsFor: 'initialize-release'!
value: anObject start: startPositionInteger id: anInteger 
	value := anObject.
	start := startPositionInteger.
	id := anInteger! !


!SmaCCToken methodsFor: 'printing'!
printOn: aStream 
	aStream
		nextPut: ${;
		nextPutAll: self value;
		nextPut: $(;
		nextPutAll: self startPosition printString;
		nextPut: $,;
		nextPutAll: self stopPosition printString;
		nextPut: $,;
		nextPutAll: self id printString;
		nextPutAll: ')}'! !


!SmaCCToken methodsFor: 'testing' stamp: 'md 9/6/2005 17:22'!
isRBToken
	^false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmaCCToken class
	instanceVariableNames: ''!

!SmaCCToken class methodsFor: 'instance creation' stamp: 'md 7/12/2006 19:29'!
value: aString

	^ self value: aString start: 0 id: nil! !

!SmaCCToken class methodsFor: 'instance creation' stamp: 'ajh 3/11/2003 23:28'!
value: aString start: anInteger

	^ self value: aString start: anInteger id: nil! !

!SmaCCToken class methodsFor: 'instance creation'!
value: aString start: anInteger id: anObject 
	^(self new)
		value: aString
			start: anInteger
			id: anObject;
		yourself! !
Integer subclass: #SmallInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!SmallInteger commentStamp: '<historical>' prior: 0!
My instances are 31-bit numbers, stored in twos complement form. The allowable range is approximately +- 1 billion (see SmallInteger minVal, maxVal).!


!SmallInteger methodsFor: 'arithmetic' stamp: 'di 2/1/1999 21:29'!
* aNumber 
	"Primitive. Multiply the receiver by the argument and answer with the
	result if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 9>
	^ super * aNumber! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'di 2/1/1999 21:31'!
+ aNumber 
	"Primitive. Add the receiver to the argument and answer with the result
	if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger  Essential  No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 1>
	^ super + aNumber! !

!SmallInteger methodsFor: 'arithmetic'!
- aNumber 
	"Primitive. Subtract the argument from the receiver and answer with the
	result if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger. Essential. No Lookup. See Object documentation
	whatIsAPrimitive."

	<primitive: 2>
	^super - aNumber! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'hh 10/3/2000 11:47'!
/ aNumber 
	"Primitive. This primitive (for /) divides the receiver by the argument
	and returns the result if the division is exact. Fail if the result is not a
	whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional.
	No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 10>
	aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal].
	(aNumber isMemberOf: SmallInteger)
		ifTrue: [^(Fraction numerator: self denominator: aNumber) reduced]
		ifFalse: [^super / aNumber]! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'tk 11/30/2001 11:55'!
// aNumber 
	"Primitive. Divide the receiver by the argument and answer with the
	result. Round the result down towards negative infinity to make it a
	whole integer. Fail if the argument is 0 or is not a SmallInteger.
	Essential. No Lookup. See Object documentation whatIsAPrimitive. "

	<primitive: 12>
	^ super // aNumber 	"Do with quo: if primitive fails"! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'tk 11/30/2001 11:53'!
\\ aNumber 
	"Primitive. Take the receiver modulo the argument. The result is the
	remainder rounded towards negative infinity, of the receiver divided by
	the argument Fail if the argument is 0 or is not a SmallInteger. Optional.
	No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 11>
	^ super \\ aNumber 	"will use // to compute it if primitive fails"! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'LC 4/22/1998 14:21'!
gcd: anInteger 
	"See SmallInteger (Integer) | gcd:"
	| n m |
	n _ self.
	m _ anInteger.
	[n = 0]
		whileFalse: 
			[n _ m \\ (m _ n)].
	^ m abs! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'sr 5/28/2000 04:41'!
quo: aNumber 
	"Primitive. Divide the receiver by the argument and answer with the 
	result. Round the result down towards zero to make it a whole integer. 
	Fail if the argument is 0 or is not a SmallInteger. Optional. See Object 
	documentation whatIsAPrimitive."
	<primitive: 13>
	aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal].
	(aNumber isMemberOf: SmallInteger)
		ifFalse: [^ super quo: aNumber].
	(aNumber == -1 and: [self == self class minVal])
		ifTrue: ["result is aLargeInteger" ^ self negated].
	self primitiveFailed! !


!SmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'!
bitAnd: arg 
	"Primitive. Answer an Integer whose bits are the logical OR of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 14>
	self >= 0 ifTrue: [^ arg bitAnd: self].
	^ (self bitInvert bitOr: arg bitInvert) bitInvert! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:33'!
bitOr: arg 
	"Primitive. Answer an Integer whose bits are the logical OR of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 15>
	self >= 0 ifTrue: [^ arg bitOr: self].
	^ arg < 0
		ifTrue: [(self bitInvert bitAnd: arg bitInvert) bitInvert]
		ifFalse: [(self bitInvert bitClear: arg) bitInvert]! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'!
bitShift: arg 
	"Primitive. Answer an Integer whose value is the receiver's value shifted
	left by the number of bits indicated by the argument. Negative arguments
	shift right. The receiver is interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 17>
	self >= 0 ifTrue: [^ super bitShift: arg].
	^ arg >= 0
		ifTrue: [(self negated bitShift: arg) negated]
		ifFalse: [(self bitInvert bitShift: arg) bitInvert]! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'!
bitXor: arg 
	"Primitive. Answer an Integer whose bits are the logical XOR of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 16>
	self >= 0 ifTrue: [^ arg bitXor: self].
	^ arg < 0
		ifTrue: [self bitInvert bitXor: arg bitInvert]
		ifFalse: [(self bitInvert bitXor: arg) bitInvert]! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'SqR 8/3/2000 13:29'!
hashMultiply
	| low |

	low _ self bitAnd: 16383.
	^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384))
			bitAnd: 16r0FFFFFFF! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:07'!
highBit
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. Raise an error if the receiver is negative, since  
	negative integers are defined to have an infinite number of leading 1's 
	in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to 
	get the highest bit of the magnitude."
	self < 0 ifTrue: [^ self error: 'highBit is not defined for negative integers'].
	^ self highBitOfPositiveReceiver! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:08'!
highBitOfMagnitude
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. This method is used for negative SmallIntegers as well,  
	since Squeak's LargeIntegers are sign/magnitude."
	^ self abs highBitOfPositiveReceiver! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'jm 2/19/98 12:11'!
lowBit
	" Answer the index of the low order one bit.
		2r00101000 lowBit       (Answers: 4)
		2r-00101000 lowBit      (Answers: 4)
	  First we skip bits in groups of 4, then single bits.
	  While not optimal, this is a good tradeoff; long
	  integer #lowBit always invokes us with bytes."
	| n result |
	n := self.
	n = 0 ifTrue: [ ^ 0 ].
	result := 1.
	[ (n bitAnd: 16rF) = 0 ]
		whileTrue: [
			result := result + 4.
			n := n bitShift: -4 ].
	[ (n bitAnd: 1) = 0 ]
		whileTrue: [
			result := result + 1.
			n := n bitShift: -1 ].
	^ result! !


!SmallInteger methodsFor: 'comparing'!
< aNumber 
	"Primitive. Compare the receiver with the argument and answer with
	true if the receiver is less than the argument. Otherwise answer false.
	Fail if the argument is not a SmallInteger. Essential. No Lookup. See
	Object documentation whatIsAPrimitive."

	<primitive: 3>
	^super < aNumber! !

!SmallInteger methodsFor: 'comparing'!
<= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is less than or equal to the argument. Otherwise answer
	false. Fail if the argument is not a SmallInteger. Optional. No Lookup.
	See Object documentation whatIsAPrimitive. "

	<primitive: 5>
	^super <= aNumber! !

!SmallInteger methodsFor: 'comparing'!
= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is equal to the argument. Otherwise answer false. Fail if the
	argument is not a SmallInteger. Essential. No Lookup. See Object
	documentation whatIsAPrimitive. "

	<primitive: 7>
	^super = aNumber! !

!SmallInteger methodsFor: 'comparing'!
> aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is greater than the argument. Otherwise answer false. Fail if
	the argument is not a SmallInteger. Essential. No Lookup. See Object
	documentation whatIsAPrimitive."

	<primitive: 4>
	^super > aNumber! !

!SmallInteger methodsFor: 'comparing'!
>= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is greater than or equal to the argument. Otherwise answer
	false. Fail if the argument is not a SmallInteger. Optional. No Lookup.
	See Object documentation whatIsAPrimitive."

	<primitive: 6>
	^super >= aNumber! !

!SmallInteger methodsFor: 'comparing'!
hash

	^self! !

!SmallInteger methodsFor: 'comparing'!
identityHash

	^self! !

!SmallInteger methodsFor: 'comparing' stamp: 'di 9/27/97 20:32'!
identityHashMappedBy: map

	^ self! !

!SmallInteger methodsFor: 'comparing'!
~= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is not equal to the argument. Otherwise answer false. Fail if
	the argument is not a SmallInteger. Essential. No Lookup. See Object
	documentation whatIsAPrimitive."

	<primitive: 8>
	^super ~= aNumber! !


!SmallInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:34'!
as31BitSmallInt
	"Polymorphic with LargePositiveInteger (see comment there).
	 Return self since all SmallIntegers are 31 bits"

	^ self! !

!SmallInteger methodsFor: 'converting'!
asFloat
	"Primitive. Answer a Float that represents the value of the receiver.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 40>
	self primitiveFailed! !


!SmallInteger methodsFor: 'copying' stamp: 'tk 6/26/1998 11:34'!
clone
! !

!SmallInteger methodsFor: 'copying'!
deepCopy! !

!SmallInteger methodsFor: 'copying'!
shallowCopy! !

!SmallInteger methodsFor: 'copying' stamp: 'tk 8/19/1998 16:04'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !


!SmallInteger methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:15'!
destinationBuffer:digitLength
  ^ LargePositiveInteger new: digitLength.! !

!SmallInteger methodsFor: 'printing' stamp: 'RAA 8/24/2001 13:59'!
threeDigitName

	| units answer |

	self = 0 ifTrue: [^''].
	units _ #('one' 'two' 'three' 'four' 'five' 'six' 'seven' 'eight' 'nine' 'ten' 
		'eleven' 'twelve' 'thirteen' 'fourteen' 'fifteen' 'sixteen' 'seventeen' 
		'eighteen' 'nineteen').
	self > 99 ifTrue: [
		answer _ (units at: self // 100),' hundred'.
		(self \\ 100) = 0 ifFalse: [
			answer _ answer,' ',(self \\ 100) threeDigitName
		].
		^answer
	].
	self < 20 ifTrue: [
		^units at: self
	].
	answer _ #('twenty' 'thirty' 'forty' 'fifty' 'sixty' 'seventy' 'eighty' 'ninety')
			at: self // 10 - 1.
	(self \\ 10) = 0 ifFalse: [
		answer _ answer,'-',(units at: self \\ 10)
	].
	^answer! !


!SmallInteger methodsFor: 'system primitives'!
asOop
	"Answer an object pointer as an integer, return negative number for SmallInteger"

	^ self! !

!SmallInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'!
digitAt: n 
	"Answer the value of an indexable field in the receiver.  LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256.  Fail if the argument (the index) is not an Integer or is out of bounds."
	n>4 ifTrue: [^ 0].
	self < 0
		ifTrue: 
			[self = SmallInteger minVal ifTrue:
				["Can't negate minVal -- treat specially"
				^ #(0 0 0 64) at: n].
			^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF]
		ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]! !

!SmallInteger methodsFor: 'system primitives' stamp: 'md 6/5/2003 10:42'!
digitAt: n put: value 
	"Fails. The digits of a small integer can not be modified."

	self error: 'You can''t store in a SmallInteger'! !

!SmallInteger methodsFor: 'system primitives'!
digitLength
	"Answer the number of indexable fields in the receiver. This value is the 
	same as the largest legal subscript. Included so that a SmallInteger can 
	behave like a LargePositiveInteger or LargeNegativeInteger."

	(self < 16r100 and: [self > -16r100]) ifTrue: [^ 1].
	(self < 16r10000 and: [self > -16r10000]) ifTrue: [^ 2].
	(self < 16r1000000 and: [self > -16r1000000]) ifTrue: [^ 3].
	^ 4! !

!SmallInteger methodsFor: 'system primitives'!
instVarAt: i 
	"Small integer has to be specially handled."

	i = 1 ifTrue: [^self].
	self error: 'argument too big for small integer instVarAt:'! !

!SmallInteger methodsFor: 'system primitives' stamp: 'tk 5/14/1999 20:54'!
nextInstance
	"SmallIntegers can't be enumerated this way.  There are a finite number of them from from (SmallInteger minVal) to (SmallInteger maxVal), but you'll have to enumerate them yourself with:
	(SmallInteger minVal) to: (SmallInteger maxVal) do: [:integer | <your code here>].
	"

	self shouldNotImplement ! !

!SmallInteger methodsFor: 'system primitives' stamp: 'je 10/22/2002 12:10'!
nextObject
	"SmallIntegers are immediate objects, and, as such, do not have successors in object memory."

	self shouldNotImplement ! !


!SmallInteger methodsFor: 'testing'!
even

	^(self bitAnd: 1) = 0! !

!SmallInteger methodsFor: 'testing'!
odd

	^(self bitAnd: 1) = 1! !


!SmallInteger methodsFor: '*eToys-printing' stamp: 'sw 10/26/2000 09:01'!
uniqueNameForReference
	"Answer a nice name by which the receiver can be referred to by other objects.   For SmallIntegers, we can actually just use the receiver's own printString, though this is pretty strange in some ways."

	^ self asString! !


!SmallInteger methodsFor: 'private'!
fromString: str radix: radix

	| maxdigit c val |
	maxdigit _ 
		radix + (radix > 10
					ifTrue: [55 - 1]
					ifFalse: [48 - 1]).
	val _ 0.
	1 to: str size do: 
		[:i | 
		c _ str at: i.
		(c < 48 ifFalse: [c > maxdigit])
			ifTrue: [^false].
		val _ val * radix + (c <= 57
							ifTrue: [c - 48]
							ifFalse: 
								[c < 65 ifTrue: [^false].
								c - 55])].
	^val! !

!SmallInteger methodsFor: 'private' stamp: 'sr 6/8/2000 01:14'!
highBitOfPositiveReceiver
	| shifted bitNo |
	"Answer the index of the high order bit of the receiver, or zero if the 
	receiver is zero. Receiver has to be positive!!"
	shifted _ self.
	bitNo _ 0.
	[shifted < 16]
		whileFalse: 
			[shifted _ shifted bitShift: -4.
			bitNo _ bitNo + 4].
	[shifted = 0]
		whileFalse: 
			[shifted _ shifted bitShift: -1.
			bitNo _ bitNo + 1].
	^ bitNo! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmallInteger class
	instanceVariableNames: ''!

!SmallInteger class methodsFor: 'constants'!
maxVal
	"Answer the maximum value for a SmallInteger."
	^ 16r3FFFFFFF! !

!SmallInteger class methodsFor: 'constants'!
minVal
	"Answer the minimum value for a SmallInteger."
	^ -16r40000000! !


!SmallInteger class methodsFor: 'documentation'!
guideToDivision
	"Handy guide to the kinds of Integer division: 
	/  exact division, returns a fraction if result is not a whole integer. 
	//  returns an Integer, rounded towards negative infinity. 
	\\ is modulo rounded towards negative infinity. 
	quo:  truncated division, rounded towards zero."! !


!SmallInteger class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:17'!
basicNew

	self error: 'SmallIntegers can only be created by performing arithmetic'! !

!SmallInteger class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'!
new

	self basicNew	"generates an error"! !


!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:04'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg generateCoerceToSmallIntegerObjectFrom: aNode on: aStream! !

!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:11'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg generateCoerceToSmallIntegerValueFrom: aNode on: aStream! !

!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 17:09'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asIntegerValueFrom: anInteger! !

!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 11:20'!
ccgCanConvertFrom: anObject

	^anObject class == self! !
ClassTestCase subclass: #SmallIntegerTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!
!SmallIntegerTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0!
I provide a test suite for SmallInteger values. Examine my tests to see how SmallIntegers should behave, and see how to use them.!


!SmallIntegerTest methodsFor: 'testing - arithmetic' stamp: 'sd 6/5/2005 08:59'!
testDivide

	self assert: 2 / 1 = 2.
	self assert: (3 / 2) isFraction.
	self assert: 4 / 2 = 2.
	self should: [ 1 / 0 ] raise: ZeroDivide.! !


!SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 08:59'!
testBasicNew

	self should: [SmallInteger basicNew] raise: TestResult error. ! !

!SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 08:59'!
testMaxVal

	self assert: (SmallInteger maxVal = 16r3FFFFFFF).! !

!SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 08:59'!
testMinVal

	self assert: (SmallInteger minVal = -16r40000000).! !

!SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 08:59'!
testNew

	self should: [SmallInteger new] raise: TestResult error. ! !


!SmallIntegerTest methodsFor: 'testing - printing' stamp: 'fbs 12/8/2005 12:58'!
testPrintPaddedWith

self assert: (123 printPaddedWith: $0 to: 10 base: 2)  = '0001111011'.
self assert: (123 printPaddedWith: $0 to: 10 base: 8)  = '0000000173'.
self assert: (123 printPaddedWith: $0 to: 10 base: 10) = '0000000123'.
self assert: (123 printPaddedWith: $0 to: 10 base: 16) = '000000007B'.! !
ColorTheme subclass: #SmallLandColorTheme
	instanceVariableNames: 'darks normals lights'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!SmallLandColorTheme methodsFor: 'applying' stamp: 'dgd 3/12/2006 14:13'!
apply
	Preferences installBrightWindowColors.
	""
	super apply.
	""
	self updateTopProject.
	self updateFlaps.
	self updateWorldMainDockingBar! !

!SmallLandColorTheme methodsFor: 'applying' stamp: 'dgd 3/12/2006 14:20'!
updateFlaps
	Flaps globalFlapTabs
		select: [:each | each flapID = 'Supplies' translated]
		thenDo: [:each | 
			each
				color: (self normal: 1);
				
				borderColor: (self normal: 1);
				 borderWidth: (self menuBorderWidth).
			""
			each referent
				color: (self light: 1);
				 borderWidth: (self menuBorderWidth);
				
				borderColor: (self normal: 1)]! !

!SmallLandColorTheme methodsFor: 'applying' stamp: 'dgd 3/12/2006 13:42'!
updateTopProject
	Project current == Project topProject
	ifFalse:[^ self].

""
			World color: Preferences defaultWorldColor.
			World submorphs
				select: [:each | ""
					(each isKindOf: StringMorph)
						and: [each contents = 'Squeak']]
				thenDo: [:each | each
						color: (self dark: 1)].
! !

!SmallLandColorTheme methodsFor: 'applying' stamp: 'dgd 3/12/2006 13:43'!
updateWorldMainDockingBar
	| oldPreference |
	oldPreference := Project current showWorldMainDockingBar.
	""
	Project current showWorldMainDockingBar: false.
	Project current showWorldMainDockingBar: oldPreference.
	TheWorldMainDockingBar updateInstances! !


!SmallLandColorTheme methodsFor: 'theme' stamp: 'dgd 3/12/2006 14:28'!
balloonColor
	^ (self light: 1) twiceLighter alpha: 0.95"Color white alpha: 0.95"! !

!SmallLandColorTheme methodsFor: 'theme' stamp: 'dgd 3/12/2006 14:23'!
cancelColor
	^ super cancelColor"self normal: 8"! !

!SmallLandColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 19:03'!
defaultWorldColor
	^ (self light: 1) twiceLighter twiceLighter ! !

!SmallLandColorTheme methodsFor: 'theme' stamp: 'dgd 1/7/2005 18:38'!
helpColor
^ self okColor! !

!SmallLandColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 18:00'!
insertionPointColor
	^ self normal: 7! !

!SmallLandColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 18:00'!
keyboardFocusColor
	^ self normal: 8! !

!SmallLandColorTheme methodsFor: 'theme' stamp: 'dgd 3/12/2006 14:23'!
okColor
	^ super okColor "self normal: 2"! !

!SmallLandColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 18:01'!
textHighlightColor
	^self normal: 1! !


!SmallLandColorTheme methodsFor: 'initialization' stamp: 'dgd 3/12/2006 12:12'!
baseColors
	"Answer a collection of the 3 base colors"
	^ self subclassResponsibility! !

!SmallLandColorTheme methodsFor: 'initialization' stamp: 'dgd 3/12/2006 12:11'!
initialize
	"Initialize the receiver"
	| baseColors |
	super initialize.
	""
	baseColors := self baseColors.
	""
	darks := baseColors first wheel: 8.
	normals := baseColors second wheel: 8.
	lights := baseColors third wheel: 8! !


!SmallLandColorTheme methodsFor: 'private - colors' stamp: 'dgd 11/2/2004 17:41'!
dark: index
	^ darks at: index! !

!SmallLandColorTheme methodsFor: 'private - colors' stamp: 'dgd 11/2/2004 17:56'!
labelForColor: aColor 
	^ (aColor red roundTo: 0.01) asString , ' ' , (aColor green roundTo: 0.01) asString , ' ' , (aColor blue roundTo: 0.01) asString! !

!SmallLandColorTheme methodsFor: 'private - colors' stamp: 'dgd 11/2/2004 17:41'!
light: index 
	^ lights at: index! !

!SmallLandColorTheme methodsFor: 'private - colors' stamp: 'dgd 11/2/2004 17:41'!
normal: index 
	^ normals at: index! !

!SmallLandColorTheme methodsFor: 'private - colors' stamp: 'dgd 11/2/2004 17:57'!
rowOf: colors 
	| row |
	row := AlignmentMorph newRow.
	row cellInset: 5.
	row color: Color white.
	""
	colors
		do: [:each | 
			| box label | 
			box := RectangleMorph new.
			box extent: 100 @ 60.
			box color: each.
			box borderWidth: 2.
			box borderColor: box color muchDarker.
			""
			label := StringMorph
						contents: (self labelForColor: each).
			label color: each negated.
			box addMorphCentered: label.
			""
			row addMorphBack: box].
	""
	^ row ! !

!SmallLandColorTheme methodsFor: 'private - colors' stamp: 'dgd 3/12/2006 12:09'!
showColors
	" 
	BlueSmallLandColorTheme new showColors. 
	"
	| col |
	col := AlignmentMorph newColumn.
	col color: Color white.
	col
		addMorphBack: (self rowOf: darks).
	col
		addMorphBack: (self rowOf: normals).
	col
		addMorphBack: (self rowOf: lights).
	""
	col openInWorld! !


!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:29'!
dialog3DTitles
	^ false! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 21:21'!
dialogBorderColor
	^ (self dark: 5) ! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 19:54'!
dialogBorderWidth
	^ 2! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 20:06'!
dialogButtonBorderWidth
	^ 1! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 21:21'!
dialogColor
	^ self light: 3! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:50'!
dialogPaneBorderColor
	^ self dialogTextBoxBorderColor ! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:44'!
dialogPaneBorderWidth
	^ 1! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:43'!
dialogPaneRampOrColor
	^ self dialogTextBoxColor! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:38'!
dialogRampOrColor
	^ self dialogColor! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 21:37'!
dialogTextBoxBorderColor
	^ self normal: 1! !

!SmallLandColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 21:36'!
dialogTextBoxColor
	^ self light: 1! !


!SmallLandColorTheme methodsFor: 'theme - dockingbar' stamp: 'dgd 11/2/2004 17:54'!
dockingBarAutoGradient
	^ true! !

!SmallLandColorTheme methodsFor: 'theme - dockingbar' stamp: 'dgd 11/2/2004 18:02'!
dockingBarColor
	^self normal:1! !

!SmallLandColorTheme methodsFor: 'theme - dockingbar' stamp: 'dgd 11/2/2004 18:03'!
dockingBarGradientRamp
	^ {0.0 -> Color white. 1.0
		-> (self normal:1)}! !


!SmallLandColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 18:03'!
menuBorderColor
	^self dark: 1! !

!SmallLandColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:22'!
menuBorderWidth ^ 2.! !

!SmallLandColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 18:25'!
menuColor
	^ self light: 1! !

!SmallLandColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 18:25'!
menuLineColor
	^ self normal: 1! !

!SmallLandColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 18:34'!
menuSelectionColor
	^ self dark: 1! !

!SmallLandColorTheme methodsFor: 'theme - menus' stamp: 'dgd 3/12/2006 12:32'!
menuTitleBorderColor
	^ self menuTitleColor ! !

!SmallLandColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 18:35'!
menuTitleBorderWidth
	^ 6! !

!SmallLandColorTheme methodsFor: 'theme - menus' stamp: 'dgd 3/12/2006 12:31'!
menuTitleColor
	^ self normal: 1! !


!SmallLandColorTheme methodsFor: 'printing' stamp: 'dgd 3/12/2006 12:43'!
printOn: aStream 
	aStream nextPutAll: 'Small-Land Color Theme: ', self class themeName! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmallLandColorTheme class
	instanceVariableNames: ''!

!SmallLandColorTheme class methodsFor: 'accessing' stamp: 'dgd 3/12/2006 12:42'!
allThemes
	"
SmallLandColorTheme allThemes.
	"
	^ self withAllSubclasses
		reject: [:each | each == self]! !

!SmallLandColorTheme class methodsFor: 'accessing' stamp: 'dgd 3/12/2006 13:09'!
chooseTheme
	" 
	SmallLandColorTheme chooseTheme.  
	"
	| themes menu |
	menu := MenuMorph new defaultTarget: self.
	menu addTitle: 'choose color theme' translated.
	Preferences noviceMode
		ifFalse: [menu addStayUpItem].
	""
	themes := self allThemes
				asSortedCollection: [:x :y | x themeName translated <= y themeName translated].
	themes
		do: [:each | ""menu
				addUpdating: #stringForTheme:
				target: each
				selector: #applyTheme:
				argumentList: {each}].
	""
	menu popUpInWorld! !

!SmallLandColorTheme class methodsFor: 'accessing' stamp: 'dgd 3/12/2006 13:07'!
stringForTheme: aTheme 

	^ (aTheme == ColorTheme current class
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, aTheme themeName translated.! !

!SmallLandColorTheme class methodsFor: 'accessing' stamp: 'dgd 3/12/2006 12:42'!
themeName
	" 
	self themeName. 
	 
	BlueSmallLandColorTheme themeName.  
	GreenSmallLandColorTheme themeName.  
	"
	^ self name allButLast: 'SmallLandColorTheme' size.
! !
Object subclass: #SmalltalkImage
	instanceVariableNames: ''
	classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats SourceFileVersionString StartupStamp'
	poolDictionaries: ''
	category: 'System-Support'!
!SmalltalkImage commentStamp: 'sd 7/2/2003 21:50' prior: 0!
I represent the SmalltalkImage and partly the VM. Using my current instance you can 
	- get the value of some VM parameters, system arguments, vm profiling,
	endianess status, external objects,....

	- save the image, manage sources

As you will notice browsing my code I'm a fat class having still too much responsibility.
But this is life. sd-2 July 2003

PS: if someone wants to split me go ahead.!


!SmalltalkImage methodsFor: 'endian' stamp: 'yo 2/18/2004 18:24'!
calcEndianness
	| bytes word blt |
	"What endian-ness is the current hardware?  The String '1234' will be stored into a machine word.  On BigEndian machines (the Mac), $1 will be the high byte if the word.  On LittleEndian machines (the PC), $4 will be the high byte."
	"SmalltalkImage current endianness"

	bytes _ ByteArray withAll: #(0 0 0 0).  "(1 2 3 4) or (4 3 2 1)"
	word _ WordArray with: 16r01020304.
	blt _ (BitBlt toForm: (Form new hackBits: bytes)) 
				sourceForm: (Form new hackBits: word).
	blt combinationRule: Form over.  "store"
	blt sourceY: 0; destY: 0; height: 1; width: 4.
	blt sourceX: 0; destX: 0.
	blt copyBits.  "paste the word into the bytes"
	bytes first = 1 ifTrue: [^ #big].
	bytes first = 4 ifTrue: [^ #little].
	self error: 'Ted is confused'.! !

!SmalltalkImage methodsFor: 'endian' stamp: 'yo 2/18/2004 18:24'!
endianness

	EndianCache ifNil: [EndianCache _ self calcEndianness].
	^ EndianCache.
! !

!SmalltalkImage methodsFor: 'endian' stamp: 'sd 6/27/2003 23:25'!
isBigEndian
	^self endianness == #big! !

!SmalltalkImage methodsFor: 'endian' stamp: 'sd 6/27/2003 23:25'!
isLittleEndian
	^self endianness == #little! !


!SmalltalkImage methodsFor: 'external' stamp: 'sd 6/28/2003 18:23'!
exitToDebugger
	"Primitive. Enter the machine language debugger, if one exists. Essential.
	See Object documentation whatIsAPrimitive. This primitive is to access the
	debugger when debugging the vm or a plugging in C"

	<primitive: 114>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'external' stamp: 'sd 6/28/2003 17:38'!
unbindExternalPrimitives
	"Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found."
	<primitive: 570>
	"Do nothing if the primitive fails for compatibility with older VMs"
! !


!SmalltalkImage methodsFor: 'housekeeping' stamp: 'yo 7/25/2003 17:50'!
reconstructChanges2
	"Move all the changes and its histories onto another sources file."
	"SmalltalkImage reconstructChanges2"

	| f oldChanges classCount |
	f _ FileStream fileNamed: 'ST80.temp'.
	f header; timeStamp.
	(SourceFiles at: 2) converter: MacRomanTextConverter new.
'Recoding Changes File...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: Smalltalk classNames size
	during:
		[:bar | classCount _ 0.
		Smalltalk allClassesDo:
			[:class | bar value: (classCount _ classCount + 1).
			class moveChangesWithVersionsTo: f.
			class putClassCommentToCondensedChangesFile: f.
			class class moveChangesWithVersionsTo: f]].
	self lastQuitLogPosition: f position.
	f trailer; close.
	oldChanges _ SourceFiles at: 2.
	oldChanges close.
	FileDirectory default 
		deleteFileNamed: oldChanges name , '.old';
		rename: oldChanges name toBe: oldChanges name , '.old';
		rename: f name toBe: oldChanges name.
	Smalltalk setMacFileInfoOn: oldChanges name.
	SourceFiles at: 2
			put: (FileStream oldFileNamed: oldChanges name)! !


!SmalltalkImage methodsFor: 'image cleanup' stamp: 'mir 11/26/2004 15:33'!
fixObsoleteReferences
	"SmalltalkImage current fixObsoleteReferences"
	| informee obsoleteBindings obsName realName realClass |

	Smalltalk garbageCollect; garbageCollect.

	Preference allInstances do: [:each | 
		informee _ each instVarNamed: #changeInformee.
		((informee isKindOf: Behavior)
			and: [informee isObsolete])
			ifTrue: [
				Transcript show: 'Preference: '; show: each name; cr.
				each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]].
 
	CompiledMethod allInstances do: [:method |
		obsoleteBindings _ method literals select: [:literal |
			literal isVariableBinding
				and: [literal value isBehavior]
				and: [literal value isObsolete]].
		obsoleteBindings do: [:binding |
			obsName _ binding value name.
			Transcript show: 'Binding: '; show: obsName; cr.
			realName _ obsName copyReplaceAll: 'AnObsolete' with: ''.
			realClass _ Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject].
			binding isSpecialWriteBinding
				ifTrue: [binding privateSetKey: binding key value: realClass]
				ifFalse: [binding key: binding key value: realClass]]].


	Behavior flushObsoleteSubclasses.
	Smalltalk garbageCollect; garbageCollect.
	SystemNavigation default obsoleteBehaviors size > 0
		ifTrue: [
			SystemNavigation default obsoleteBehaviors inspect.
			self error:'Still have obsolete behaviors. See inspector'].

! !


!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:24'!
changeImageNameTo: aString
	
	self imageName: aString asSqueakPathName.
	LastImageName := self imageName! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'bf 1/12/2006 19:43'!
changesName
	"Answer the name for the changes file corresponding to the image file name."
	"Smalltalk changesName"

	| imName |
	imName := FileDirectory baseNameFor: self imageName.
	^ imName, FileDirectory dot, 'changes'! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'em 3/31/2005 11:48'!
currentChangeSetString
	"SmalltalkImage current currentChangeSetString"
	^ 'Current Change Set: ' translated, ChangeSet current name! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'bf 1/12/2006 19:45'!
fullNameForChangesNamed: aName

	| imgDir newName |
	imgDir := FileDirectory on: self imagePath.
	newName := FileDirectory baseNameFor: (imgDir fullNameFor: aName).
	^newName , FileDirectory dot, FileDirectory changeSuffix.! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'bf 1/12/2006 19:45'!
fullNameForImageNamed: aName

	| imgDir newName |
	imgDir := FileDirectory on: self imagePath.
	newName := FileDirectory baseNameFor: (imgDir fullNameFor: aName).
	^newName , FileDirectory dot, FileDirectory imageSuffix.! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:24'!
imageName
	"Answer the full path name for the current image."
	"SmalltalkImage current imageName"

	| str |
	str _ self primImageName.
	^ (FilePath pathName: str isEncoded: true) asSqueakPathName.
! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 2/24/2005 18:34'!
imageName: newName
	"Set the the full path name for the current image.  All further snapshots will use this."

	| encoded |
	encoded _ (FilePath pathName: newName isEncoded: false) asVmPathName.
	self primImageName: encoded.
! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'sd 11/16/2003 13:57'!
imagePath
	"Answer the path for the directory containing the image file."
	"SmalltalkImage current imagePath"

	^ FileDirectory dirPathFor: self imageName
! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:23'!
primImageName
	"Answer the full path name for the current image."
	"SmalltalkImage current imageName"

	<primitive: 121>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:30'!
primImageName: newName
	"Set the the full path name for the current image.  All further snapshots will use this."

	<primitive: 121>
	^ self primitiveFailed! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:35'!
primVmPath
	"Answer the path for the directory containing the Smalltalk virtual machine. Return the 	empty string if this primitive is not implemented."
	"SmalltalkImage current vmPath"

	<primitive: 142>
	^ ''! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'sd 9/24/2003 12:43'!
sourceFileVersionString

	^ SourceFileVersionString! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'sd 9/24/2003 12:44'!
sourcesName
	"Answer the full path to the version-stable source code"
	^ self vmPath , SourceFileVersionString , FileDirectory dot , 'sources'! !

!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:36'!
vmPath
	"Answer the path for the directory containing the Smalltalk virtual machine. Return the 	empty string if this primitive is not implemented."
	"SmalltalkImage current vmPath"

	^ (FilePath pathName: (self primVmPath) isEncoded: true) asSqueakPathName.
! !


!SmalltalkImage methodsFor: 'modules' stamp: 'dvf 6/30/2005 12:11'!
forgetModule: aString
	"Primitive. If the module named aString is loaded, unloaded. If not, and it is marked an unloadable, unmark it so the VM will try to load it again next time. See comment for #unloadModule:."
	<primitive: 571>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: 'modules' stamp: 'sd 6/27/2003 23:47'!
listBuiltinModule: index
	"Return the name of the n-th builtin module.
	This list is not sorted!!"
	<primitive: 572>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: 'modules' stamp: 'sd 9/30/2003 14:00'!
listBuiltinModules
	"SmalltalkImage current listBuiltinModules"
	"Return a list of all builtin modules (e.g., plugins). Builtin plugins are those that are 	compiled with the VM directly, as opposed to plugins residing in an external shared library. 	The list will include all builtin plugins regardless of whether they are currently loaded 
	or not. Note that the list returned is not sorted!!"

	| modules index name |
	modules _ WriteStream on: Array new.
	index _ 1.
	[true] whileTrue:[
		name _ self listBuiltinModule: index.
		name ifNil:[^modules contents].
		modules nextPut: name.
		index _ index + 1.
	].! !

!SmalltalkImage methodsFor: 'modules' stamp: 'sd 6/27/2003 23:48'!
listLoadedModule: index
	"Return the name of the n-th loaded module.
	This list is not sorted!!"
	<primitive: 573>
	^self primitiveFailed! !

!SmalltalkImage methodsFor: 'modules' stamp: 'sd 9/30/2003 14:00'!
listLoadedModules
	"SmalltalkImage current listLoadedModules"
	"Return a list of all currently loaded modules (e.g., plugins). Loaded modules are those that currently in use (e.g., active). The list returned will contain all currently active modules regardless of whether they're builtin (that is compiled with the VM) or external (e.g., residing in some external shared library). Note that the returned list is not sorted!!"
	| modules index name |
	modules _ WriteStream on: Array new.
	index _ 1.
	[true] whileTrue:[
		name _ self listLoadedModule: index.
		name ifNil:[^modules contents].
		modules nextPut: name.
		index _ index + 1.
	].! !

!SmalltalkImage methodsFor: 'modules' stamp: 'sd 6/27/2003 23:49'!
unloadModule: aString
	"Primitive. Unload the given module.
	This primitive is intended for development only since some
	platform do not implement unloading of DLL's accordingly.
	Also, the mechanism for unloading may not be supported
	on all platforms."
	<primitive: 571>
	^self primitiveFailed! !


!SmalltalkImage methodsFor: 'preferences' stamp: 'laza 12/6/2004 13:55'!
setPlatformPreferences
	"Set some platform specific preferences on system startup"
	| platform specs |
	Preferences automaticPlatformSettings ifFalse:[^self].
	platform _ self platformName.
	specs _ 	#(	
					(soundStopWhenDone false)
					(soundQuickStart false)
			).
	platform = 'Win32' ifTrue:[
		specs _ #(	
					(soundStopWhenDone true)
					(soundQuickStart false)
				)].
	platform = 'Mac OS' ifTrue:[
		specs _ #(	
					(soundStopWhenDone false)
					(soundQuickStart true)
				)].
	specs do:[:tuple|
		Preferences setPreference: tuple first toValue: (tuple last == true).
	].
! !


!SmalltalkImage methodsFor: 'quit' stamp: 'sd 6/28/2003 17:32'!
quitPrimitive
	"Primitive. Exit to another operating system on the host machine, if one
	exists. All state changes in the object space since the last snapshot are lost.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 113>
	self primitiveFailed! !


!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'rbb 3/1/2005 11:13'!
getFileNameFromUser

	| newName |
	newName := UIManager default
		request: 'New File Name?' translated
		initialAnswer: (FileDirectory localNameFor: self imageName).
	newName isEmpty ifTrue: [^nil].
	((FileDirectory default fileOrDirectoryExists: (self fullNameForImageNamed: newName)) or:
	 [FileDirectory default fileOrDirectoryExists: (self fullNameForChangesNamed: newName)]) ifTrue: [
		(self confirm: ('{1} already exists. Overwrite?' translated format: {newName})) ifFalse: [^nil]].
	^newName
! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'bf 1/12/2006 19:20'!
recordStartupStamp
	
	StartupStamp _ '----STARTUP----', Time dateAndTimeNow printString, ' as ', self imageName.
! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 14:12'!
saveSession
	self snapshot: true andQuit: false! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 14:20'!
shutDown

	^ self closeSourceFiles! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 14:12'!
snapshot: save andQuit: quit
	^self snapshot: save andQuit: quit embedded: false! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'bf 1/12/2006 19:20'!
snapshot: save andQuit: quit embedded: embeddedFlag
	"Mark the changes file and close all files as part of #processShutdownList.
	If save is true, save the current state of this Smalltalk in the image file.
	If quit is true, then exit to the outer OS shell.
	The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up."
	| resuming msg |
	Object flushDependents.
	Object flushEvents.

	(SourceFiles at: 2) ifNotNil:[
		msg _ String streamContents: [ :s |
			s nextPutAll: '----';
			nextPutAll: (save ifTrue: [ quit ifTrue: [ 'QUIT' ] ifFalse: [ 'SNAPSHOT' ] ]
							ifFalse: [quit ifTrue: [ 'QUIT/NOSAVE' ] ifFalse: [ 'NOP' ]]);
			nextPutAll: '----';
			print: Date dateAndTimeNow; space;
			nextPutAll: (FileDirectory default localNameFor: self imageName);
			nextPutAll: ' priorSource: ';
			print: LastQuitLogPosition ].
		self assureStartupStampLogged.
		save ifTrue: [ LastQuitLogPosition _ (SourceFiles at: 2) setToEnd; position ].
		self logChange: msg.
		Transcript cr; show: msg
	].

	Smalltalk processShutDownList: quit.
	Cursor write show.
	save ifTrue: [resuming _ embeddedFlag 
					ifTrue: [self snapshotEmbeddedPrimitive] 
					ifFalse: [self snapshotPrimitive].  "<-- PC frozen here on image file"
				resuming == false "guard against failure" ifTrue:
					["Time to reclaim segment files is immediately after a save"
					Smalltalk at: #ImageSegment
						ifPresent: [:theClass | theClass reclaimObsoleteSegmentFiles]]]
		ifFalse: [resuming _ false].
	quit & (resuming == false) ifTrue: [self quitPrimitive].
	Cursor normal show.
	Smalltalk setGCParameters.
	resuming == true ifTrue: [Smalltalk clearExternalObjects].
	Smalltalk processStartUpList: resuming == true.
	resuming == true ifTrue:[
		self setPlatformPreferences.
		self recordStartupStamp].
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup].
	"Now it's time to raise an error"
	resuming == nil ifTrue: [self error:'Failed to write image file (disk full?)'].
	^ resuming! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 13:58'!
snapshotEmbeddedPrimitive
	<primitive: 247>
	^nil "indicates error writing embedded image file"! !

!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 13:59'!
snapshotPrimitive
	"Primitive. Write the current state of the object memory on a file in the
	same format as the Smalltalk-80 release. The file can later be resumed,
	returning you to this exact state. Return normally after writing the file.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 97>
	^nil "indicates error writing image file"! !


!SmalltalkImage methodsFor: 'sources, change log' stamp: 'ar 4/10/2005 18:02'!
logChange: aStringOrText 
	"Write the argument, aString, onto the changes file."
	| aString changesFile |
	(SourceFiles isNil or: [(SourceFiles at: 2) == nil]) ifTrue: [^ self].
	self assureStartupStampLogged.

	aString := aStringOrText asString.
	(aString findFirst: [:char | char isSeparator not]) = 0
		ifTrue: [^ self].  "null doits confuse replay"
	(changesFile _ SourceFiles at: 2).
	changesFile isReadOnly ifTrue:[^self].
	changesFile setToEnd; cr; cr.
	changesFile nextChunkPut: aString.
		"If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here"
	self forceChangesToDisk.! !


!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'mir 8/5/2004 11:59'!
aboutThisSystem 
	"Identify software version"

	^ self inform: self systemInformationString withCRs.! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'NS 1/16/2004 15:34'!
assureStartupStampLogged
	"If there is a startup stamp not yet actually logged to disk, do it now."
	| changesFile |
	StartupStamp ifNil: [^ self].
	(SourceFiles isNil or: [(changesFile _ SourceFiles at: 2) == nil]) ifTrue: [^ self].
	changesFile isReadOnly ifTrue:[^self].
	changesFile setToEnd; cr; cr.
	changesFile nextChunkPut: StartupStamp asString; cr.
	StartupStamp _ nil.
	self forceChangesToDisk.! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 13:12'!
closeSourceFiles
	"Shut down the source files if appropriate.  1/29/96 sw: changed so that the closing and nilification only take place if the entry was a FileStream, thus allowing stringified sources to remain in the saved image file"

	1 to: 2 do: [:i |
		((SourceFiles at: i) isKindOf: FileStream)
			ifTrue:
				[(SourceFiles at: i) close.
				SourceFiles at: i put: nil]]! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:03'!
datedVersion
	"Answer the version of this release."

	^SystemVersion current datedVersion! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'NS 1/27/2004 15:55'!
event: anEvent
	"Hook for SystemChangeNotifier"

	(anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [
		anEvent item acceptsLoggingOfCompilation 
			ifTrue: [self logChange: 'Smalltalk removeClassNamed: #' , anEvent item name].
	].
	anEvent isDoIt 
		ifTrue: [self logChange: anEvent item].
	(anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [
		anEvent itemClass acceptsLoggingOfCompilation 
			ifTrue: [self logChange: anEvent itemClass name , ' removeSelector: #' , anEvent itemSelector]].! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'NS 1/16/2004 15:35'!
forceChangesToDisk
	"Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot."

	| changesFile |
	changesFile _ SourceFiles at: 2.
	(changesFile isKindOf: FileStream) ifTrue: [
		changesFile flush.
		SecurityManager default hasFileAccess ifTrue:[
			changesFile close.
			changesFile open: changesFile name forWrite: true].
		changesFile setToEnd.
	].
! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 14:02'!
lastQuitLogPosition
	^ LastQuitLogPosition! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 14:03'!
lastQuitLogPosition: aNumber
	"should be only use to ensure the transition from SystemDictionary to SmalltalkImage, then  	be removed"
		
	LastQuitLogPosition := aNumber! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'em 3/31/2005 11:46'!
lastUpdateString
	"SmalltalkImage current lastUpdateString"
	^'latest update: #' translated, SystemVersion current highestUpdate printString! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 12:00'!
openSourceFiles

	self imageName = LastImageName ifFalse:
		["Reset the author initials to blank when the image gets moved"
		LastImageName _ self imageName.
		Utilities setAuthorInitials: ''].
	FileDirectory
		openSources: self sourcesName
		andChanges: self changesName
		forImage: LastImageName.
	StandardSourceFileArray install! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'tpr 12/15/2003 12:21'!
saveAs
	"Put up the 'saveAs' prompt, obtain a name, and save the image  under that new name."

	| newName |
	newName _ self getFileNameFromUser.
	newName isNil ifTrue: [^ self].
	(SourceFiles at: 2) ifNotNil:
		[self closeSourceFiles; "so copying the changes file will always work"
			 saveChangesInFileNamed: (self fullNameForChangesNamed: newName)].
	self saveImageInFileNamed: (self fullNameForImageNamed: newName)! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'rbb 3/1/2005 11:13'!
saveAsEmbeddedImage
	"Save the current state of the system as an embedded image"

	| dir newName newImageName newImageSegDir oldImageSegDir haveSegs |
	dir := FileDirectory default.
	newName := UIManager default request: 'Select existing VM file'
				initialAnswer: (FileDirectory localNameFor: '').
	newName = '' ifTrue: [^Smalltalk].
	newName := FileDirectory baseNameFor: newName asFileName.
	newImageName := newName.
	(dir includesKey: newImageName) 
		ifFalse: 
			[^self 
				inform: 'Unable to find name ' , newName , ' Please choose another name.'].
	haveSegs := false.
	Smalltalk at: #ImageSegment
		ifPresent: 
			[:theClass | 
			(haveSegs := theClass instanceCount ~= 0) 
				ifTrue: [oldImageSegDir := theClass segmentDirectory]].
	self logChange: '----SAVEAS (EMBEDDED) ' , newName , '----' 
				, Date dateAndTimeNow printString.
	self imageName: (dir fullNameFor: newImageName) asSqueakPathName.
	LastImageName := self imageName.
	self closeSourceFiles.
	haveSegs 
		ifTrue: 
			[Smalltalk at: #ImageSegment
				ifPresent: 
					[:theClass | 
					newImageSegDir := theClass segmentDirectory.	"create the folder"
					oldImageSegDir fileNames do: 
							[:theName | 
							"copy all segment files"

							newImageSegDir 
								copyFileNamed: oldImageSegDir pathName , FileDirectory slash , theName
								toFileNamed: theName]]].
	self 
		snapshot: true
		andQuit: true
		embedded: true! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'tpr 12/15/2003 12:25'!
saveAsNewVersion
	"Save the image/changes using the next available version number."
	"SmalltalkImage current saveAsNewVersion"
	
	| newName changesName aName anIndex |
	aName := FileDirectory baseNameFor: (FileDirectory default localNameFor: self imageName).
	anIndex := aName lastIndexOf: FileDirectory dot asCharacter ifAbsent: [nil].
	(anIndex notNil and: [(aName copyFrom: anIndex + 1 to: aName size) isAllDigits])
		ifTrue:
			[aName := aName copyFrom: 1 to: anIndex - 1].

	newName := FileDirectory default nextNameFor: aName extension: FileDirectory imageSuffix.
	changesName := self fullNameForChangesNamed: newName.

	"Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number"
	(FileDirectory default fileOrDirectoryExists: changesName)
		ifTrue:
			[^ self inform:
'There is already .changes file of the desired name,
', newName, '
curiously already present, even though there is
no corresponding .image file.   Please remedy
manually and then repeat your request.'].

	(SourceFiles at: 2) ifNotNil:
		[self closeSourceFiles; "so copying the changes file will always work"
			saveChangesInFileNamed: (self fullNameForChangesNamed: newName)].
	self saveImageInFileNamed: (self fullNameForImageNamed: newName)


! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'tpr 12/15/2003 16:01'!
saveChangesInFileNamed: aString
	| fullChangesName |
	fullChangesName _ (FileDirectory default fullNameFor: aString).
	(FileDirectory default directoryNamed:(FileDirectory dirPathFor: fullChangesName )) assureExistence.
	FileDirectory default 
		copyFileWithoutOverwriteConfirmationNamed: SmalltalkImage current changesName 
		toFileNamed: fullChangesName.
	Smalltalk setMacFileInfoOn: fullChangesName.! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'tpr 12/15/2003 15:58'!
saveImageInFileNamed: aString
	| fullImageName |
	fullImageName _ (FileDirectory default fullNameFor: aString).
	(FileDirectory default directoryNamed:(FileDirectory dirPathFor: fullImageName )) assureExistence.
	self
		changeImageNameTo: fullImageName;
		closeSourceFiles;
		openSourceFiles;  "so SNAPSHOT appears in new changes file"
		saveImageSegments;
		snapshot: true andQuit: false! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 13:29'!
saveImageSegments

	| haveSegs oldImageSegDir newImageSegDir |
	haveSegs _ false.
	Smalltalk at: #ImageSegment ifPresent: [:theClass | 
		(haveSegs _ theClass instanceCount ~= 0) ifTrue: [
			oldImageSegDir _ theClass segmentDirectory]].
	haveSegs ifTrue: [
		Smalltalk at: #ImageSegment ifPresent: [:theClass |
			newImageSegDir _ theClass segmentDirectory.	"create the folder"
			oldImageSegDir fileNames do: [:theName | "copy all segment files"
				| imageSegmentName |
				imageSegmentName _ oldImageSegDir pathName, FileDirectory slash, theName.
				newImageSegDir 
					copyFileWithoutOverwriteConfirmationNamed: imageSegmentName
					toFileNamed: theName]]].
! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:09'!
systemInformationString
	"Identify software version"
	^ SystemVersion current version, String cr, self lastUpdateString, String cr, self currentChangeSetString

"
	(eToySystem _ self at: #EToySystem ifAbsent: [nil]) ifNotNil:
		[aString _ aString, '
Squeak-Central version: ', eToySystem version, ' of ', eToySystem versionDate]."! !

!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:09'!
timeStamp: aStream 
	"Writes system version and current time on stream aStream."

	| dateTime |
	dateTime _ Time dateAndTimeNow.
	aStream nextPutAll: 'From ', SmalltalkImage current datedVersion, ' [', SmalltalkImage current lastUpdateString, '] on ', (dateTime at: 1) printString,
						' at ', (dateTime at: 2) printString! !


!SmalltalkImage methodsFor: 'system attribute' stamp: 'sd 9/24/2003 11:40'!
extractParameters

	| pName value index globals |
	globals := Dictionary new.
	index := 3. "Muss bei 3 starten, da 2 documentName ist"
	[pName := self  getSystemAttribute: index.
	pName isEmptyOrNil] whileFalse:[
		index := index + 1.
		value := self getSystemAttribute: index.
		value ifNil: [value _ ''].
 		globals at: pName asUppercase put: value.
		index := index + 1].
	^globals! !

!SmalltalkImage methodsFor: 'system attribute' stamp: 'md 10/26/2003 13:08'!
getSystemAttribute: attributeID 
	"Optional. Answer the string for the system attribute with the given 
	integer ID. Answer nil if the given attribute is not defined on this 
	platform. On platforms that support invoking programs from command 
	lines (e.g., Unix), this mechanism can be used to pass command line 
	arguments to programs written in Squeak.

	By convention, the first command line argument that is not a VM
	configuration option is considered a 'document' to be filed in. Such a
	document can add methods and classes, can contain a serialized object,
	can include code to be executed, or any combination of these.

	Currently defined attributes include: 
	-1000...-1 - command line arguments that specify VM options 
	0 - the full path name for currently executing VM 
	(or, on some platforms, just the path name of the VM's directory) 
	1 - full path name of this image 
	2 - a Squeak document to open, if any 
	3...1000 - command line arguments for Squeak programs 
	1001 - this platform's operating system 
	1002 - operating system version 
	1003 - this platform's processor type
	1004 - vm version"

	<primitive: 149>
	^ nil! !

!SmalltalkImage methodsFor: 'system attribute' stamp: 'dtl 8/5/2006 09:48'!
osVersion
	"Return the version number string of the platform we're running on"
	"SmalltalkImage current osVersion"

	^(self getSystemAttribute: 1002) asString! !

!SmalltalkImage methodsFor: 'system attribute' stamp: 'sd 6/27/2003 23:38'!
platformName
	"Return the name of the platform we're running on"

	^self getSystemAttribute: 1001! !

!SmalltalkImage methodsFor: 'system attribute' stamp: 'sd 6/27/2003 23:43'!
platformSubtype
	"Return the subType of the platform we're running on"

	^self getSystemAttribute: 1003! !

!SmalltalkImage methodsFor: 'system attribute' stamp: 'dtl 8/5/2006 09:47'!
vmVersion	
	"Return a string identifying the interpreter version"
	"SmalltalkImage current vmVersion"

	^self getSystemAttribute: 1004! !


!SmalltalkImage methodsFor: 'utilities' stamp: 'sd 1/16/2004 20:54'!
stripMethods: tripletList messageCode: messageString
	"Used to 'cap' methods that need to be protected for proprietary reasons, etc.; call this with a list of triplets of symbols of the form  (<class name>  <#instance or #class> <selector name>), and with a string to be produced as part of the error msg if any of the methods affected is reached"

	| aClass sel keywords codeString |
	tripletList do:
		[:triplet |  
			(aClass _ (Smalltalk at: triplet first ifAbsent: [nil])) notNil ifTrue:
				[triplet second == #class ifTrue:
					[aClass _ aClass class].
				sel _ triplet third.
				keywords _ sel keywords.
				(keywords size == 1 and: [keywords first asSymbol isKeyword not])
					ifTrue:
						[codeString _ keywords first asString]
					ifFalse:
						[codeString _ ''.
						keywords withIndexDo:
							[:kwd :index |
								codeString _ codeString, ' ', (keywords at: index), ' ',
									'arg', index printString]].
				codeString _ codeString, '
	self codeStrippedOut: ', (messageString surroundedBySingleQuotes).

				aClass compile: codeString classified: 'stripped']]! !


!SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'!
extraVMMemory
	"Answer the current setting of the 'extraVMMemory' VM parameter. See the comment in extraVMMemory: for details."

	^ self vmParameterAt: 23
! !

!SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'!
extraVMMemory: extraBytesToReserve
	"Request that the given amount of extra memory be reserved for use by the virtual machine to leave extra C heap space available for things like plugins, network and file buffers, and so on. This request is stored when the image is saved and honored when the image is next started up. Answer the previous value of this parameter."

	extraBytesToReserve < 0
		ifTrue: [self error: 'VM memory reservation must be non-negative'].
	^ self vmParameterAt: 23 put: extraBytesToReserve
! !

!SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:47'!
getVMParameters	
	"Answer an Array containing the current values of the VM's internal
	parameter/metric registers.  Each value is stored in the array at the
	index corresponding to its VM register.  (See #vmParameterAt: and
	#vmParameterAt:put:.)"
	"SmalltalkImage current getVMParameters"
	
	<primitive: 254>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'vm parameters' stamp: 'tpr 4/27/2005 11:03'!
vmParameterAt: parameterIndex
	"parameterIndex is a positive integer corresponding to one of the VM's internal
	parameter/metric registers.  Answer with the current value of that register.
	Fail if parameterIndex has no corresponding register.
	VM parameters are numbered as follows:
		1	end of old-space (0-based, read-only)
		2	end of young-space (read-only)
		3	end of memory (read-only)
		4	allocationCount (read-only)
		5	allocations between GCs (read-write)
		6	survivor count tenuring threshold (read-write)
		7	full GCs since startup (read-only)
		8	total milliseconds in full GCs since startup (read-only)
		9	incremental GCs since startup (read-only)
		10	total milliseconds in incremental GCs since startup (read-only)
		11	tenures of surving objects since startup (read-only)
		12-20 specific to the translating VM
		21	root table size (read-only)
		22	root table overflows since startup (read-only)
		23	bytes of extra memory to reserve for VM buffers, plugins, etc.

		24	memory threshold above which shrinking object memory (rw)
		25	memory headroom when growing object memory (rw)
		26  interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image  is not calling getNextEvent often (rw)
		27	number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking
		28	number of times sweep loop iterated  for current IGC/FGC (read-only)
		29	number of times make forward loop iterated for current IGC/FGC (read-only)
		30	number of times compact move loop iterated for current IGC/FGC (read-only)
		31	number of grow memory requests (read-only)
		32	number of shrink memory requests (read-only)
		33	number of root table entries used for current IGC/FGC (read-only)
		34	number of allocations done before current IGC/FGC (read-only)
		35	number of survivor objects after current IGC/FGC (read-only)
		36  millisecond clock when current IGC/FGC completed (read-only)
		37  number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only)
		38  milliseconds taken by current IGC  (read-only)
		39  Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only)
		40  VM word size - 4 or 8 (read-only)"

	<primitive: 254>
	self primitiveFailed! !

!SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'!
vmParameterAt: parameterIndex put: newValue
	"parameterIndex is a positive integer corresponding to one of the VM's internal
	parameter/metric registers.  Store newValue (a positive integer) into that
	register and answer with the previous value that was stored there.
	Fail if newValue is out of range, if parameterIndex has no corresponding
	register, or if the corresponding register is read-only."

	<primitive: 254>
	self primitiveFailed! !


!SmalltalkImage methodsFor: 'vm profiling' stamp: 'sd 9/24/2003 11:54'!
clearProfile
	"Clear the profile database."

	<primitive: 250>
! !

!SmalltalkImage methodsFor: 'vm profiling' stamp: 'sd 9/24/2003 11:54'!
dumpProfile
	"Dump the profile database to a file."

	<primitive: 251>
! !

!SmalltalkImage methodsFor: 'vm profiling' stamp: 'sd 9/24/2003 11:54'!
profile: aBlock
	"Make a virtual machine profile of the given block."
	"Note: Profiling support is provided so that VM implementors
	 can better understand and improve the efficiency of the virtual
	 machine. To use it, you must be running a version of the
	 virtual machine compiled with profiling enabled (which
	 makes it much slower than normal even when not profiling).
	 You will also need the CodeWarrior profile reader application."

	self stopProfiling.
	self clearProfile.
	self startProfiling.
	aBlock value.
	self stopProfiling.
	self dumpProfile.! !

!SmalltalkImage methodsFor: 'vm profiling' stamp: 'sd 9/24/2003 11:55'!
startProfiling
	"Start profiling the virtual machine."

	<primitive: 252>
! !

!SmalltalkImage methodsFor: 'vm profiling' stamp: 'sd 9/24/2003 11:55'!
stopProfiling
	"Stop profiling the virtual machine."

	<primitive: 253>
! !


!SmalltalkImage methodsFor: 'vm statistics' stamp: 'sd 7/2/2003 21:45'!
textMarkerForShortReport

	^  'Since last view	'! !

!SmalltalkImage methodsFor: 'vm statistics' stamp: 'sd 9/30/2003 13:53'!
vmStatisticsReportString
	"StringHolderView open: (StringHolder new contents:
		SmalltalkImage current vmStatisticsReportString) label: 'VM Statistics'"

	| params oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount mcMisses mcHits icHits upTime sendCount tms tmSize upTime2 fullGCs2 fullGCTime2 incrGCs2 incrGCTime2 tenureCount2 str |
	params _ self getVMParameters.
	oldSpaceEnd			_ params at: 1.
	youngSpaceEnd		_ params at: 2.
	memoryEnd			_ params at: 3.
	fullGCs				_ params at: 7.
	fullGCTime			_ params at: 8.
	incrGCs				_ params at: 9.
	incrGCTime			_ params at: 10.
	tenureCount			_ params at: 11.
	mcMisses			_ params at: 15.
	mcHits				_ params at: 16.
	icHits				_ params at: 17.
	upTime _ Time millisecondClockValue.
	sendCount _ mcMisses + mcHits + icHits.
	tms _ TranslatedMethod allSubInstances.
	tmSize _ tms inject: 0 into: [:sum :tm | sum + (tm size * 4)].

	str _ WriteStream on: (String new: 1000).
	str	nextPutAll: 'uptime			';
		print: (upTime / 1000 / 60 // 60); nextPut: $h;
		print: (upTime / 1000 / 60 \\ 60) asInteger; nextPut: $m;
		print: (upTime / 1000 \\ 60) asInteger; nextPut: $s; cr.

	str	nextPutAll: 'memory			';
		nextPutAll: memoryEnd asStringWithCommas; nextPutAll: ' bytes'; cr.
	str	nextPutAll:	'	old			';
		nextPutAll: oldSpaceEnd asStringWithCommas; nextPutAll: ' bytes (';
		print: ((oldSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
	str	nextPutAll: '	young		';
		nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommas; nextPutAll: ' bytes (';
		print: ((youngSpaceEnd - oldSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
	str	nextPutAll: '	used		';
		nextPutAll: youngSpaceEnd asStringWithCommas; nextPutAll: ' bytes (';
		print: ((youngSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
	str	nextPutAll: '	free		';
		nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommas; nextPutAll: ' bytes (';
		print: ((memoryEnd - youngSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr.

	str	nextPutAll: 'GCs				';
		nextPutAll: (fullGCs + incrGCs) asStringWithCommas.
	fullGCs + incrGCs > 0 ifTrue: [
		str
			nextPutAll: ' ('; 
			print: ((upTime / (fullGCs + incrGCs)) roundTo: 1); 
			nextPutAll: 'ms between GCs)'
	].
	str cr.
	str	nextPutAll: '	full			';
		print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms (';
		print: ((fullGCTime / upTime * 100) roundTo: 1.0);
		nextPutAll: '% uptime)'.
	fullGCs = 0 ifFalse:
		[str	nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms'].
	str	cr.
	str	nextPutAll: '	incr		';
		print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms (';
		print: ((incrGCTime / upTime * 100) roundTo: 1.0);
		nextPutAll: '% uptime), avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms'; cr.
	str	nextPutAll: '	tenures		';
		nextPutAll: tenureCount asStringWithCommas.
	tenureCount = 0 ifFalse:
		[str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)'].
	str	cr.

LastStats ifNil: [LastStats _ Array new: 6]
ifNotNil: [
	upTime2 _ upTime - (LastStats at: 1).
	fullGCs2 _ fullGCs - (LastStats at: 2).
	fullGCTime2 _ fullGCTime - (LastStats at: 3).
	incrGCs2 _ incrGCs - (LastStats at: 4).
	incrGCTime2 _ incrGCTime - (LastStats at: 5).
	tenureCount2 _ tenureCount - (LastStats at: 6).

	str	nextPutAll: self textMarkerForShortReport ;
		nextPutAll: (fullGCs2 + incrGCs2) asStringWithCommas.
	fullGCs2 + incrGCs2 > 0 ifTrue: [
		str
			nextPutAll: ' ('; 
			print: ((upTime2 / (fullGCs2 + incrGCs2)) roundTo: 1); 
			nextPutAll: 'ms between GCs)'.
	].
	str cr.
	str	nextPutAll: '	uptime		'; print: ((upTime2 / 1000.0) roundTo: 0.1); nextPutAll: 's'; cr.
	str	nextPutAll: '	full			';
		print: fullGCs2; nextPutAll: ' totalling '; nextPutAll: fullGCTime2 asStringWithCommas; nextPutAll: 'ms (';
		print: ((fullGCTime2 / upTime2 * 100) roundTo: 1.0);
		nextPutAll: '% uptime)'.
	fullGCs2 = 0 ifFalse:
		[str	nextPutAll: ', avg '; print: ((fullGCTime2 / fullGCs2) roundTo: 1.0); nextPutAll: 'ms'].
	str	cr.
	str	nextPutAll: '	incr		';
		print: incrGCs2; nextPutAll: ' totalling '; nextPutAll: incrGCTime2 asStringWithCommas; nextPutAll: 'ms (';
		print: ((incrGCTime2 / upTime2 * 100) roundTo: 1.0);
		nextPutAll: '% uptime), avg '.
	incrGCs2 > 0 ifTrue: [
		 str print: ((incrGCTime2 / incrGCs2) roundTo: 1.0); nextPutAll: 'ms'
	].
	str cr.
	str	nextPutAll: '	tenures		';
		nextPutAll: tenureCount2 asStringWithCommas.
	tenureCount2 = 0 ifFalse:
		[str nextPutAll: ' (avg '; print: (incrGCs2 / tenureCount2) asInteger; nextPutAll: ' GCs/tenure)'].
	str	cr.
].
	LastStats at: 1 put: upTime.
	LastStats at: 2 put: fullGCs.
	LastStats at: 3 put: fullGCTime.
	LastStats at: 4 put: incrGCs.
	LastStats at: 5 put: incrGCTime.
	LastStats at: 6 put: tenureCount.

	sendCount > 0 ifTrue: [
		str	nextPutAll: 'sends			';
			nextPutAll: sendCount asStringWithCommas; cr.
		str	nextPutAll: '	full			';
			nextPutAll: mcMisses asStringWithCommas;
			nextPutAll: ' ('; print: ((mcMisses / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
		str	nextPutAll: '	m-cache	';
			nextPutAll: mcHits asStringWithCommas;
			nextPutAll: ' ('; print: ((mcHits / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
		str	nextPutAll: '	i-cache		';
			nextPutAll: icHits asStringWithCommas;
			nextPutAll: ' ('; print: ((icHits / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr].

	icHits > 0 ifTrue: [
		str	nextPutAll: 'methods			';
			nextPutAll: tms size asStringWithCommas; nextPutAll: ' translated'; cr.
		str	nextPutAll: '	size			';
			nextPutAll: tmSize asStringWithCommas; nextPutAll: ' bytes, avg ';
			print: ((tmSize / tms size) roundTo: 0.1); nextPutAll: ' bytes/method'; cr.
		str	nextPutAll: '	memory		';
			print: ((tmSize / youngSpaceEnd * 100) roundTo: 0.1); nextPutAll: '% of used, ';
			print: ((tmSize / memoryEnd * 100) roundTo: 0.1); nextPutAll: '% of available'; cr].

	^ str contents
! !

!SmalltalkImage methodsFor: 'vm statistics' stamp: 'sd 9/30/2003 13:54'!
vmStatisticsShortString
	"Convenience item for access to recent statistics only"
	"StringHolderView open: (StringHolder new contents: SmalltalkImage current vmStatisticsShortString)
		label: 'VM Recent Statistics'"

	^ (ReadStream on: self vmStatisticsReportString) upToAll: 'Since'; upTo: Character cr; upToEnd
! !


!SmalltalkImage methodsFor: 'private source file' stamp: 'sd 9/24/2003 12:42'!
sourceFileVersionString: aString

	SourceFileVersionString := aString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmalltalkImage class
	instanceVariableNames: 'current'!

!SmalltalkImage class methodsFor: 'class initialization' stamp: 'yo 2/18/2004 18:26'!
initialize
"
	self initialize
"
	Smalltalk addToStartUpList: SmalltalkImage.
	SmalltalkImage startUp.
! !

!SmalltalkImage class methodsFor: 'class initialization' stamp: 'yo 2/18/2004 18:25'!
startUp

	EndianCache _ nil.
! !


!SmalltalkImage class methodsFor: 'instance creation' stamp: 'sd 9/30/2003 14:28'!
current
	"Note that this could be implemented differently to avoid the test"

	current isNil
		ifTrue: [current := self basicNew].
	^ current! !

!SmalltalkImage class methodsFor: 'instance creation' stamp: 'sd 9/30/2003 13:39'!
new

	self error: 'Use current'.! !
ReferenceStream subclass: #SmartRefStream
	instanceVariableNames: 'structures steady reshaped renamed renamedConv superclasses progressBar objCount classInstVars'
	classVariableNames: 'ScannedObject'
	poolDictionaries: ''
	category: 'System-Object Storage'!
!SmartRefStream commentStamp: '<historical>' prior: 0!
Ordinary ReferenceStreams assume that the names and order of instance variables is exactly the same when an object file is written and read.  
	SmartRefStream allows object files to be read even after instance variables have changed or the entire class has been renamed.

When an object file is written, no one knows how the classes will change in the future.  Therefore, all conversion must be done when the file is read.  The key is to store enough information in the file about the names of the instance variables of all outgoing classes.  

SmartRefStream works best with only one tree of objects per file.  You can nextPut: more than once, but each object tree gets its own class structure description, which is big.  

Conversion of old objects is done by a method in each class called (convertToCurrentVersion: varDict refStream: smartRefStrm).  At fileOut time, ChangeSet>>checkForConversionMethods creates a prototype of this method (if Preference #conversionMethodsAtFileOut is true).  The programmer must edit this method to (1) test if the incoming object needs conversion, (2) put non-nil values into any new inst vars that need them, and (3) save the data of any inst vars that are being deleted. 

Determining which old version is represented by the incoming object can be done in several ways: noticing that a current inst var is nil when it should have data, noticing that there is an older inst var name in the variable dictionary (varDict), checking kinds of objects in one or more inst vars, or retrieving the classVersion of the incoming object from the ref stream.  

If a class is renamed, a method goes into SmartRefStream telling the new name.  The conversion method of the new class must be prepared to accept instances of the old class also.  If no inst var names have changed, the conversion method does nothing.

An example:  
	Suppose we change the representation of class Rectangle from ('origin' 'corner') to ('origin' 'extent').  Suppose lots of Rectangle instances are already out on files (in .pr project files, especially).  
	The programmer changes the class definition, modifies all the methods, and filesOut.  A series of dialogs appear, asking if instances Rectangle might be in an object file, if 'extent' needs to be non-nil (yes), and if the info in 'corner' needs to be preserved (yes).  This method appears:

Rectangle >> convertToCurrentVersion: varDict refStream: smartRefStrm
	"These variables are automatically stored into the new instance: #('origin').
	Test for this particular conversion.  Get values using expressions like (varDict at: 'foo')."

	"New variables: #('extent').  If a non-nil value is needed, please assign it."
	"These are going away #('corner').  Possibly store their info in some other variable?"
	"Move your code above the ^ super...  Delete extra comments."
	^ super convertToCurrentVersion: varDict refStream: smartRefStrm

The programmer modifies it to be:

Rectangle >> convertToCurrentVersion: varDict refStream: smartRefStrm

(varDict includesKey: 'extent') ifFalse: ["old version!!"
	"Create the new extent, and preserve the info from the old corner"
	extent _ (varDict at: 'corner') - origin.
	].
^ super convertToCurrentVersion: varDict refStream: smartRefStrm

	This conversion method stays in the system and is ready to convert the old format of Rectangle whenever one is encountered in an object file.  Note that the subclasses of Rectangle, (B3DViewport, CharacterBlock, and Quadrangle) do not need conversion methods.  Their instances will be converted by the code in Rectangle.  

	Files written by SmartRefStream are in standard fileout format.  You can mix raw objects with code to be filed in.  The file starts out in the normal fileOut format.  Definitions of new classes on the front.

structures 	Dictionary of (#Rectangle -> #(<classVersionInteger> 'origin' 'corner')).  Inst 
				var names are strings.
steady 		Set of Classes who have the same structure now as on the incoming file.
				Includes classes with same inst vars except for new ones added on the end.
reshaped 	Dictionary of Classes who have a different structure now from the incoming file.  
				Includes those with same inst vars but new version number.
				(old class name -> method selector to fill in data for version to version)
renamed	Dictionary of Classes who have a different name.  Make an instance of the new
			class, and send it the conversion call.
				(old class name symbol -> new class name).  
renamedConv	Dictionary of conversion selector for Classes who have a different name.
				(old class name symbol -> conversion selector).  
topCall		Tells if next or nextPut: are working on the top object in the tree.  
			nil if outside, the top object if deep inside.

See DataStream.typeIDFor: for where the tangle of objects is clipped, so the whole system will not be written on the file.

No object that is written on the file is ever a class.  All class definitions are filed in.  A class may be stored inside an ImageSegment that itself is stored in a SmartRefStream.

UniClasses are classes for the instance specific behavior of just one instance.  Subclasses of Player are an example.  When a UniClass is read in, and a class of the same name already exists, the incoming one is renamed.  ObjectScanner converts the filed-in code.

Values in instance variables of UniClasses are stored in the array that tells the class structure.  It is the fourth of the four top level objects.  #(version (class-structure) the-object ((#Player25 scripts slotInfo costumeDictionary) (#Player26 scripts slotInfo costumeDictionary))).

There is a separate subclass for doing veryDeepCopy (in memory).  Currently, any object for which objectToStoreOnDataStream return an object other than self, does this:  The new object (a DiskProxy) is traced.  When it comes time to go through the fields of the old object, they are not found as keys in references (DiskProxies are there instead).  So the old field value is left in the new object.  That is OK for StrikeFont, Class, MetaClass, DisplayScreen.  But the DiskProxies are evaluated, which takes a lot of time.

Some metaclasses are put into the structures table.  This is for when a block has a receiver that is a class.  See checkFatalReshape:.

ImageSegments:
	A ReferenceStream is used to enumerate objects to put inside an ImageSegment.  If an instance of a UniClass is seen, the class is put in also.
	A SmartRefStream is used to store the ImageSegment.  Roots are nil, and the segment is a wordArray.  We are encoding the outPointers.  Structures contains all classes from both places.  Must filter out UniClasses for some things, and do include them for putting source code at end of file.  Do not write any class inst vars in file.

--Ted Kaehler and Bob Arning.
!


!SmartRefStream methodsFor: 'accessing' stamp: 'tk 5/19/1999 15:47'!
structures: anObject
	structures _ anObject! !

!SmartRefStream methodsFor: 'accessing' stamp: 'tk 5/19/1999 15:47'!
superclasses: anObject
	superclasses _ anObject! !


!SmartRefStream methodsFor: 'class changed shape' stamp: 'tk 1/7/97'!
catalogValues: instVarList size: varsOnDisk
	"Create a dictionary of (name -> value) for the inst vars of this reshaped object.  Indexed vars as (1 -> val) etc.  "

	| dict sz |
	dict _ Dictionary new.
	2 to: instVarList size do: [:ind |
		dict at: (instVarList at: ind) put: self next].
	sz _ varsOnDisk - (instVarList size - 1).
	1 to: sz do: [:ii | 
		dict at: ii put: self next].
	"Total number read MUST be equal to varsOnDisk!!"
	sz > 0 ifTrue: [dict at: #SizeOfVariablePart put: sz].
	^ dict! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'ar 9/27/2005 22:41'!
conversionMethodsFor: classList
	| oldStruct newStruct list |
	"Each of these needs a conversion method.  Hard part is the comment in it.  Return a MessageSet."

	list _ OrderedCollection new.
	classList do: [:cls |
		oldStruct _ structures at: cls name ifAbsent: [#()].
		newStruct _ (Array with: cls classVersion), (cls allInstVarNames).
		self writeConversionMethodIn: cls fromInstVars: oldStruct to: newStruct 
				renamedFrom: nil.
		list add: cls name, ' convertToCurrentVersion:refStream:'.
		].

	^list.! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'tk 5/26/97'!
storeInstVarsIn: anObject from: dict
	"For instance variables with the same names, store them in the new instance.  Values in variable-length part also.  This is NOT the normal inst var transfer!!  See Object.readDataFrom:size:.  This is for when inst var names have changed and some additional conversion is needed.  Here we handle the unchanged vars.  "

	(anObject class allInstVarNames) doWithIndex: [:varName :index |
		(dict includesKey: varName) ifTrue: [
			anObject instVarAt: index put: (dict at: varName)]].
	"variable part"
	(dict includesKey: #SizeOfVariablePart) ifFalse: [^ anObject].
	1 to: (dict at: #SizeOfVariablePart) do: [:index | 
		anObject basicAt: index put: (dict at: index)].
	^ anObject! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'tk 6/8/2001 09:57'!
writeClassRename: newName was: oldName
	"Write a method that tells which modern class to map instances to."
	| oldVer sel code |

	oldVer _ self versionSymbol: (structures at: oldName).
	sel _ oldName asString.
	sel at: 1 put: (sel at: 1) asLowercase.
	sel _ sel, oldVer.	"i.e. #rectangleoc4"

	code _ WriteStream on: (String new: 500).
	code nextPutAll: sel; cr.
	code cr; tab; nextPutAll: '^ ', newName.	"Return new class"

	self class compile: code contents classified: 'conversion'.

! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'CdG 10/17/2005 21:01'!
writeClassRenameMethod: sel was: oldName fromInstVars: oldList
	"The class coming is unknown.  Ask the user for the existing class it maps to.  If got one, write a method, and restart the obj fileIn.  If none, write a dummy method and get the user to complete it later.  "

| tell choice  newName answ code |

	self flag: #bobconv.	


tell := 'Reading an instance of ', oldName, '.
Which modern class should it translate to?'.
answ := (UIManager default 
		chooseFrom: #('Let me type the name now' 'Let me think about it'
'Let me find a conversion file on the disk') 
		title: tell). 

answ = 1 ifTrue: [
	tell := 'Name of the modern class {1} should translate to:' translated format: {oldName}.
	choice := UIManager default request: tell.		"class name"
	(choice size = 0) 
		ifTrue: [answ := 'conversion method needed']
		ifFalse: [newName := choice.
			answ := Smalltalk at: newName asSymbol 
				ifAbsent: ['conversion method needed'].
			answ isString ifFalse: [renamed at: oldName asSymbol put: answ name]]].
(answ = 3) | (answ = 0) ifTrue: [self close.
		^ 'conversion method needed'].
answ = 2 ifTrue: [answ := 'conversion method needed'].
answ = 'conversion method needed' ifTrue: [
		self close.  
		newName := 'PutNewClassHere'].

code := WriteStream on: (String new: 500).
code nextPutAll: sel; cr.
code cr; tab; nextPutAll: '^ ', newName.	"Return new class"

self class compile: code contents classified: 'conversion'.

newName = 'PutNewClassHere' ifTrue: [
	self inform: 'Please complete the following method and 
then read-in the object file again.'.
	SystemNavigation default browseAllImplementorsOf: sel asSymbol]. 

	"The class version number only needs to change under one specific circumstance.  That is when the first letters of the instance variables have stayed the same, but their meaning has changed.  A conversion method is needed, but this system does not know it.  
	If this is true for class Foo, define classVersion in Foo class.  
	Beware of previous object fileouts already written after the change in meaning, but before bumping the version number.  They have the old (wrong) version number, say 2.  If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3."

	^ answ! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'tk 6/7/2001 13:02'!
writeConversionMethod: sel class: newClass was: oldName fromInstVars: oldList to: newList
	"The method convertToCurrentVersion:refStream: was not found in newClass.  Write a default conversion method for the author to modify."

	| code newOthers oldOthers copied |

	code _ WriteStream on: (String new: 500).
	code nextPutAll: 'convertToCurrentVersion: varDict refStream: smartRefStrm'; cr; tab.
	newOthers _ newList asOrderedCollection "copy".
	oldOthers _ oldList asOrderedCollection "copy".
	copied _ OrderedCollection new.
	newList do: [:instVar |
		(oldList includes: instVar) ifTrue: [
			instVar isInteger ifFalse: [copied add: instVar].
			newOthers remove: instVar.
			oldOthers remove: instVar]].
	code nextPutAll: '"These variables are automatically stored into the new instance '.
	code nextPutAll: copied asArray printString; nextPut: $. .
	code cr; tab; nextPutAll: 'This method is for additional changes.'; 
		nextPutAll: ' Use statements like (foo _ varDict at: ''foo'')."'; cr; cr; tab.
	(newOthers size = 0) & (oldOthers size = 0) ifTrue: [^ self].
		"Instance variables are the same.  Only the order changed.  No conversion needed."
	(newOthers size > 0) ifTrue: [code nextPutAll: '"New variables: ', newOthers asArray printString, '  If a non-nil value is needed, please assign it."\' withCRs].
	(oldOthers size > 0) ifTrue: [code nextPutAll: '	"These are going away ', oldOthers asArray printString, '.  Possibly store their info in some other variable?"'].

	code cr; tab.
	code nextPutAll: '^ super convertToCurrentVersion: varDict refStream: smartRefStrm'.
	newClass compile: code contents classified: 'object fileIn'.


	"If you write a conversion method beware that the class may need a version number change.  This only happens when two conversion methods in the same class have the same selector name.  (A) The inst var lists of the new and old versions intials as some older set of new and old inst var lists.  or (B) Twice in a row, the class needs a conversion method, but the inst vars stay the same the whole time.  (For an internal format change.)
	If either is the case, fileouts already written with the old (wrong) version number, say 2.  Your method must be able to read files that say version 2 but are really 3, until you expunge the erroneous version 2 files from the universe."

 ! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'nk 7/29/2004 10:10'!
writeConversionMethodIn: newClass fromInstVars: oldList to: newList renamedFrom: oldName
	"The method convertToCurrentVersion:refStream: was not found in newClass.  Write a default conversion method for the author to modify.  If method exists, append new info into the end."

	| code newOthers oldOthers copied newCode |

	newOthers _ newList asOrderedCollection "copy".
	oldOthers _ oldList asOrderedCollection "copy".
	copied _ OrderedCollection new.
	newList do: [:instVar |
		(oldList includes: instVar) ifTrue: [
			instVar isInteger ifFalse: [copied add: instVar].
			newOthers remove: instVar.
			oldOthers remove: instVar]].
	code _ WriteStream on: (String new: 500).
	code cr; cr; tab; nextPutAll: '"From ', SystemVersion current version, ' [', SmalltalkImage current lastUpdateString;
			nextPutAll: '] on ', Date today printString, '"'; cr.
	code tab; nextPutAll: '"These variables are automatically stored into the new instance: '.
	code nextPutAll: copied asArray printString; nextPut: $.; cr.
	code tab; nextPutAll: 'Test for this particular conversion.'; 
		nextPutAll: '  Get values using expressions like (varDict at: ''foo'')."'; cr; cr.
	(newOthers size = 0) & (oldOthers size = 0) & (oldName == nil) ifTrue: [^ self].
		"Instance variables are the same.  Only the order changed.  No conversion needed."
	(newOthers size > 0) ifTrue: [
		code tab; nextPutAll: '"New variables: ', newOthers asArray printString, 
			'.  If a non-nil value is needed, please assign it."'; cr].
	(oldOthers size > 0) ifTrue: [
		code tab; nextPutAll: '"These are going away ', oldOthers asArray printString, 
			'.  Possibly store their info in some other variable?"'; cr].
	oldName ifNotNil: [
		code tab; nextPutAll: '"Test for instances of class ', oldName, '.'; cr.
		code tab; nextPutAll: 'Instance vars with the same name have been moved here."'; cr.
		].
	code tab; nextPutAll: '"Move your code above the ^ super...  Delete extra comments."'; cr. 

	(newClass includesSelector: #convertToCurrentVersion:refStream:) 
		ifTrue: ["append to old methods"
			newCode _ (newClass sourceCodeAt: #convertToCurrentVersion:refStream:),
				code contents]
		ifFalse: ["new method"
			newCode _ 'convertToCurrentVersion: varDict refStream: smartRefStrm',
				code contents, 
				'	^ super convertToCurrentVersion: varDict refStream: smartRefStrm'].
	newClass compile: newCode classified: 'object fileIn'.


	"If you write a conversion method beware that the class may need a version number change.  This only happens when two conversion methods in the same class have the same selector name.  (A) The inst var lists of the new and old versions intials as some older set of new and old inst var lists.  or (B) Twice in a row, the class needs a conversion method, but the inst vars stay the same the whole time.  (For an internal format change.)
	If either is the case, fileouts already written with the old (wrong) version number, say 2.  Your method must be able to read files that say version 2 but are really 3, until you expunge the erroneous version 2 files from the universe."

 ! !


!SmartRefStream methodsFor: 'conversion' stamp: 'ar 4/10/2005 15:44'!
abstractStringx0

	^ String! !

!SmartRefStream methodsFor: 'conversion' stamp: 'ar 7/29/2005 18:41'!
alansTextPlusMorphbosfcebbmsopssrsggshtt0

	^ TextPlusMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'jm 5/21/1998 06:44'!
bookPageMorphbosfcepcbbfgcc0
	"BookPageMorph->PasteUpMorph. For reading in old BookMorphs."

	^ PasteUpMorph
! !

!SmartRefStream methodsFor: 'conversion' stamp: 'di 5/22/1998 15:03'!
clippingMorphbosfcep0
	^ PasteUpMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'jm 5/21/1998 06:44'!
clippingMorphbosfcepc0
	"ClippingMorph->PasteUpMorph. For reading in old BookMorphs."

	^ PasteUpMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'tk 11/3/2000 18:47'!
dropShadowMorphbosfces0

	^ Morph ! !

!SmartRefStream methodsFor: 'conversion' stamp: 'jm 11/13/97 10:32'!
gradientFillbosfcepbbfgcc0
	^ GradientFillMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'di 5/21/1998 19:24'!
layoutMorphbosfcepbbochvimol0
	^ AlignmentMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'tk 5/12/1998 16:18'!
layoutMorphbosfcepcbbochvimol0
	^ AlignmentMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'ar 10/26/2000 01:55'!
morphicEventtcbks0
	^ MorphicEvent! !

!SmartRefStream methodsFor: 'conversion' stamp: 'ar 10/26/2000 00:48'!
morphicSoundEventtcbkss0
	^ MorphicUnknownEvent! !

!SmartRefStream methodsFor: 'conversion' stamp: 'ar 4/12/2005 17:38'!
multiStringx0

	^ WideString! !

!SmartRefStream methodsFor: 'conversion' stamp: 'ar 4/12/2005 17:38'!
multiSymbolx0

	^ WideSymbol! !

!SmartRefStream methodsFor: 'conversion' stamp: 'ar 7/8/2001 17:11'!
myMorphbosfce0

	reshaped at: #MyMorph put: #convertbosfce0:bosfce0:.
		"Be sure to define that conversion method in class Morph"
	^ Morph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'RAA 10/26/2000 09:43'!
newMorphicEventts0

	^ MorphicEvent! !

!SmartRefStream methodsFor: 'conversion' stamp: 'mir 7/12/2002 18:03'!
scrollControllermvslrrsmsms0

	^ MouseMenuController! !

!SmartRefStream methodsFor: 'conversion' stamp: 'tk 1/14/1999 13:16'!
transparentColorrcc0
	^ TranslucentColor! !

!SmartRefStream methodsFor: 'conversion' stamp: 'di 8/16/2000 16:37'!
worldMorphbosfcebbfgccpmcpbttloiairfidcuwhavcdsll0
	^ 'PutNewClassHere'  " <-- Replace this by a class name (no string quotes)"! !


!SmartRefStream methodsFor: 'import image segment' stamp: 'tk
11/26/2004 05:53'!
applyConversionMethodsTo: objectIn className: className varMap: varMap
	"Modify the object's instance vars to have the proper values
for its new shape.  Mostly, fill in defaut values of new inst vars.
Can substitute an object of a different class.  (Beware: if
substituted, varMap will not be correct when the new object is asked
to convert.)"
	| anObject prevObject |

	self flag: #bobconv.

	anObject _ objectIn.
	[
		prevObject _ anObject.
		anObject _ anObject convertToCurrentVersion: varMap
refStream: self.
		prevObject == anObject
	] whileFalse.
	^anObject
! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:08'!
checkFatalReshape: setOfClasses
	| suspects oldInstVars newInstVars bad className |
	"Inform the user if any of these classes were reshaped.  A block has a method from the old system whose receiver is of this class.  The method's inst var references might be wrong.  OK if inst vars were only added."

	self flag: #bobconv.	

	setOfClasses isEmpty ifTrue: [^ self].
	suspects _ OrderedCollection new.
	setOfClasses do: [:aClass |
		className _ renamed keyAtValue: aClass name ifAbsent: [aClass name].
		oldInstVars _ (structures at: className ifAbsent: [#(0)]) allButFirst.		"should be there"
		newInstVars _ aClass allInstVarNames.
		oldInstVars size > newInstVars size ifTrue: [bad _ true].
		oldInstVars size = newInstVars size ifTrue: [
			bad _ oldInstVars ~= newInstVars].
		oldInstVars size < newInstVars size ifTrue: [
			bad _ oldInstVars ~= (newInstVars copyFrom: 1 to: oldInstVars size)].
		bad ifTrue: [suspects add: aClass]].

	suspects isEmpty ifFalse: [
		self inform: ('Imported foreign methods will run on instances of:\',
			suspects asArray printString, 
			'\whose shape has changed.  Errors may occur.') withCRs].! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:06'!
convert1: misShapenInst to: goodClass allVarMaps: allVarMaps
	"Go through the normal instance conversion process and return a modern object."

	| className oldInstVars anObject varMap |

	self flag: #bobconv.	

	goodClass isVariable ifTrue: [
		goodClass error: 'shape change for variable class not implemented yet'
	].
	(misShapenInst class name beginsWith: 'Fake37') ifFalse: [self error: 'why mapping?'].
	className _ (misShapenInst class name allButFirst: 6) asSymbol.
	oldInstVars _ structures at: className.
	anObject _ goodClass basicNew.

	varMap _ Dictionary new.	"later, indexed vars as (1 -> val) etc."
	2 to: oldInstVars size do: [:ind |
		varMap at: (oldInstVars at: ind) put: (misShapenInst instVarAt: ind-1)].
	varMap at: #ClassName put: className.	"original"
	varMap at: #NewClassName put: goodClass name.	"new"
	self storeInstVarsIn: anObject from: varMap. 	"ones with the same names"
	allVarMaps at: misShapenInst put: varMap.
	^ anObject
! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 17:15'!
convert2: partiallyCorrectInst allVarMaps: allVarMaps
	"Go through the normal instance conversion process and return a modern object."

	| className varMap |

	self flag: #bobconv.	

	varMap _ allVarMaps at: partiallyCorrectInst.
	className _ varMap at: #ClassName.	"original"
	^self applyConversionMethodsTo: partiallyCorrectInst className: className varMap: varMap.

! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'ar 4/12/2005 18:06'!
mapClass: newClass origName: originalName
	"See if instances changed shape.  If so, make a fake class for the old shape and return it.  Remember the original class name."

	| newName oldInstVars fakeClass |
	newClass isMeta ifTrue: [^ newClass].
	newName _ newClass name.
	(steady includes: newClass) & (newName == originalName) ifTrue: [^ newClass].
		"instances in the segment have the right shape"
	oldInstVars _ structures at: originalName ifAbsent: [
			self error: 'class is not in structures list'].	"Missing in object file"

	"Allow mapping from old to new string names"
	(newName == #ByteString and:[originalName == #String]) ifTrue:[^newClass].
	(newName == #WideString and:[originalName == #MultiString]) ifTrue:[^newClass].
	(newName == #WideSymbol and:[originalName == #MultiSymbol]) ifTrue:[^newClass].

	fakeClass _ Object subclass: ('Fake37', originalName) asSymbol
		instanceVariableNames: oldInstVars allButFirst
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Obsolete'.
	ChangeSet current removeClassChanges: fakeClass name.	"reduce clutter"
	^ fakeClass
! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:09'!
reshapedClassesIn: outPointers
	"Look for classes in the outPointer array that have changed shape.  Make a fake class for the old shape.  Return a dictionary mapping Fake classes to Real classes.  Substitute fake classes for real ones in outPointers."

	| mapFakeClassesToReal fakeCls originalName |

	self flag: #bobconv.	


	mapFakeClassesToReal _ IdentityDictionary new.
	outPointers withIndexDo: [:outp :ind | 
		outp isBehavior ifTrue: [
			originalName _ renamedConv at: ind ifAbsent: [outp name].
				"in DiskProxy>>comeFullyUpOnReload: we saved the name at the index"
			fakeCls _ self mapClass: outp origName: originalName.
			fakeCls == outp ifFalse: [
				mapFakeClassesToReal at: fakeCls put: outp.
				outPointers at: ind put: fakeCls]]].
	^ mapFakeClassesToReal! !


!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/15/98 20:28'!
appendClassDefns
	"Make this a fileOut format file.  For each UniClass mentioned, prepend its source code to the file.  Class name conflicts during reading will be resolved then.  Assume instVarInfo: has already been done."

byteStream ascii.
byteStream position = 0 ifTrue: [
	byteStream setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	byteStream header; timeStamp].

byteStream cr; nextPutAll: '!!ObjectScanner new initialize!!'; cr; cr.
self uniClasesDo: [:class | class
		class sharedPools size > 0 ifTrue:  "This never happens"
			[class shouldFileOutPools
				ifTrue: [class fileOutSharedPoolsOn: self]].
		class fileOutOn: byteStream moveSource: false toFile: 0].	
		"UniClasses are filed out normally, no special format."

	byteStream trailer.	"Does nothing for normal files.  
		HTML streams will have trouble with object data"

	"Append the object's raw data"
	byteStream cr; cr; nextPutAll: '!!self smartRefStream!!'.
	byteStream binary.		"get ready for objects"
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/19/2000 21:22'!
checkCrLf
	| save isCrLf cc prev loneLf |
	"Watch for a file that has had all of its Cr's converted to CrLf's.  Some unpacking programs like Stuffit 5.0 do this by default!!"

	save _ byteStream position.
	isCrLf _ false.  loneLf _ false.
	cc _ 0.
	350 timesRepeat: [
		prev _ cc.
		(cc _ byteStream next) = 16r0A "Lf" ifTrue: [
			prev = 16r0D "Cr" ifTrue: [isCrLf _ true] ifFalse: [loneLf _ true]].
		].
	isCrLf & (loneLf not) ifTrue: [
		self inform: 'Carriage Returns in this file were converted to CrLfs 
by an evil unpacking utility.  Please set the preferences in 
StuffIt Expander to "do not convert file formats"'].
	byteStream position: save.
! !

!SmartRefStream methodsFor: 'read write' stamp: 'mir 9/12/2002 10:59'!
initKnownRenames
	renamed
		at: #FlasherMorph put: #Flasher;
		yourself! !

!SmartRefStream methodsFor: 'read write' stamp: 'ar 4/10/2005 19:27'!
initShapeDicts
	"Initialize me. "

	self flag: #bobconv.	

	"These must stay constant.  When structures read in, then things can change."
	steady _ {Array. Dictionary. Association. ByteString. SmallInteger} asSet.

	renamed ifNil: [
		renamed _ Dictionary new.  "(old class name symbol -> new class name)"
		renamedConv _ Dictionary new "(oldClassNameSymbol -> conversionSelectorInNewClass)"
	].
	self initKnownRenames! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/7/2001 18:17'!
instVarInfo: anObject
	"Return the object to write on the outgoing file that contains the structure of each class we are about to write out.  Must be an Array whose first element is 'class structure'.  Its second element is a Dictionary of pairs of the form #Rectangle -> #(<classVersion> 'origin' 'corner').  "

	"Make a pass through the objects, not writing, but recording the classes.  Construct a database of their inst vars and any version info (classVersion)."

	| dummy refs cls newSupers |
	structures _ Dictionary new.
	superclasses _ Dictionary new.
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	refs _ dummy references.
	objCount _ refs size.		"for progress bar"
		"Note that Dictionary must not change its implementation!!  If it does, how do we read this reading information?"
	(refs includesKey: #AnImageSegment) 
		ifFalse: [
			self uniClassInstVarsRefs: dummy.	"catalog the extra objects in UniClass inst vars"
			refs keysDo: [:each | 
				cls _ each class.
				"cls isObsolete ifTrue: [self error: 'Trying to write ', cls name]."
				(cls class ~~ Metaclass) & (cls isObsolete not) ifTrue: [
					structures at: cls name put: false]]]
		ifTrue: [self recordImageSegment: refs].
	"Save work by only computing inst vars once for each class"
	newSupers _ Set new.
	structures at: #Point put: false.	"writeRectangle: does not put out class pointer"
	structures at: #Rectangle put: false.
	structures at: #LargePositiveInteger put: false.	"used in slow case of WordArray"
	structures keysDo: [:nm | 
		cls _ (nm endsWith: ' class') 
			ifFalse: [Smalltalk at: nm]
			ifTrue: [(Smalltalk at: nm substrings first asSymbol) class].
		cls allSuperclasses do: [:aSuper |
			structures at: aSuper name ifAbsent: [newSupers add: aSuper name]]].
			"Don't modify structures during iteration"
	newSupers do: [:nm | structures at: nm put: 3].	"Get all superclasses into list"
	structures keysDo: [:nm | "Nothing added to classes during loop"
		cls _ (nm endsWith: ' class') 
			ifFalse: [Smalltalk at: nm]
			ifTrue: [(Smalltalk at: nm substrings first asSymbol) class].
		structures at: nm put: 
			((Array with: cls classVersion), (cls allInstVarNames)).
		superclasses at: nm ifAbsent: [
				superclasses at: nm put: cls superclass name]].
	(refs includesKey: #AnImageSegment) 
		ifTrue: [classInstVars _ #()]
		ifFalse: [self saveClassInstVars].	"of UniClassses"
	^ (Array with: 'class structure' with: structures with: 'superclasses' with: superclasses)! !

!SmartRefStream methodsFor: 'read write' stamp: 'ar 4/10/2005 18:52'!
mapClass: incoming
	"See if the old class named nm exists.  If so, return it.  If not, map it to a new class, and save the mapping in renamed.  "

	| cls oldVer sel nm |

	self flag: #bobconv.	


	nm _ renamed at: incoming ifAbsent: [incoming].	"allow pre-mapping around collisions"
	(nm endsWith: ' class') 
		ifFalse: [cls _ Smalltalk at: nm ifAbsent: [nil].
			cls ifNotNil: [^ cls]]  	"Known class.  It will know how to translate the instance."
		ifTrue: [cls _ Smalltalk at: nm substrings first asSymbol ifAbsent: [nil].
			cls ifNotNil: [^ cls class]]. 	"Known class.  It will know how to translate the instance."
	oldVer _ self versionSymbol: (structures at: nm).
	sel _ nm asString.
	sel at: 1 put: (sel at: 1) asLowercase.
	sel _ sel, oldVer.	"i.e. #rectangleoc4"
	Symbol hasInterned: sel ifTrue: [:symb | 
		(self class canUnderstand: sel asSymbol) ifTrue: [
			reshaped ifNil: [reshaped _ Dictionary new].
			cls _ self perform: sel asSymbol]].	"This class will take responsibility"
	cls ifNil: [cls _ self writeClassRenameMethod: sel was: nm
					fromInstVars: (structures at: nm).
			   cls isString ifTrue: [cls _ nil]].
	cls ifNotNil: [renamed at: nm put: cls name].
	^ cls
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 5/26/1998 15:09'!
moreObjects
	"Return true if there appears to be another object following this one on the file."

	| byte |
	byteStream atEnd ifTrue: [^ false].	"off end of file"
	(byte _ byteStream peek) ifNil: [^ false].	"off end of file"
	byte = 33 "$!! asciiValue" ifTrue: [^ false].
	byte = 0 ifTrue: [^ false].
	^ byte <= RefTypes size		"between 1 and 16"! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/19/2000 17:06'!
next
	"Really write three objects: (version, class structure, object). But only when called from the outside.  "

	| version ss object |
	^ topCall == nil 
		ifTrue: 
			[topCall _ #marked.
			version _ super next.
			version class == SmallInteger ifFalse: [^ version].	
				"version number, else just a regular object, not in our format, "
			self checkCrLf.
			ss _ super next.
			ss class == Array ifFalse: [^ ss].  "just a regular object"
			(ss at: 1) = 'class structure' ifFalse: [^ ss].
			structures _ ss at: 2.
			superclasses _ (ss size > 3 and: [(ss at: 3) = 'superclasses']) 
				ifTrue: [ss at: 4]		"class name -> superclass name"
				ifFalse: [Dictionary new].
			(self verifyStructure = 'conversion method needed') ifTrue: [^ nil].
			object _ super next.	"all the action here"
			self restoreClassInstVars.		"for UniClasses. version 4"

			topCall _ nil.	"reset it"
			object]
		ifFalse:
			[super next]
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/5/2002 09:52'!
nextAndClose
	"Speedy way to grab one object.  Only use when we are inside an object binary file.  If used for the start of a SmartRefStream mixed code-and-object file, tell the user and then do the right thing."

	| obj |
	byteStream peek = ReferenceStream versionCode "4" ifFalse: [
		"OK it is a fileIn afterall..."
		self inform: 'Should be using fileInObjectAndCode'.
		byteStream ascii.
		byteStream fileIn.
		obj _ SmartRefStream scannedObject.
		SmartRefStream scannedObject: nil.
		^ obj].

	obj _ self next.
	self close.
	^ obj! !

!SmartRefStream methodsFor: 'read write' stamp: 'md 2/24/2006 19:52'!
nextPut: anObject
	"Really write three objects: (version, class structure, object).  But only when called from the outside.  If any instance-specific classes are present, prepend their source code.  byteStream will be in fileOut format.
	You can see an analysis of which objects are written out by doing: 
	(SmartRefStream statsOfSubObjects: anObject)
	(SmartRefStream tallyOfSubObjects: anObject)
	(SmartRefStream subObjects: anObject ofClass: aClass)"

| info |
topCall == nil 
	ifTrue:
		[topCall _ anObject.
		'Please wait while objects are counted' 
			displayProgressAt: Sensor cursorPoint
			from: 0 to: 10
			during: [:bar | info _ self instVarInfo: anObject].
		self appendClassDefns.	"For instance-specific classes"
		'Writing an object file' displayProgressAt: Sensor cursorPoint
			from: 0 to: objCount*4	"estimate"
			during: [:bar |
				objCount _ 0.
				progressBar _ bar.
				self setStream: byteStream reading: false.
					"set basePos, but keep any class renames"
				super nextPut: ReferenceStream versionCode.
				super nextPut: info.
				super nextPut: anObject.		"<- the real writing"
				classInstVars size > 0 ifTrue: [super nextPut: classInstVars]].
					"Note: the terminator, $!!, is not doubled inside object data"
		"references is an IDict of every object that got written"
		byteStream ascii.
		byteStream nextPutAll: '!!'; cr; cr.
		byteStream padToEndWith: $ .	"really want to truncate file, but can't"
		topCall _ progressBar _ nil]	"reset it"
	ifFalse:
		[super nextPut: anObject.
		progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].
		"return the argument - added by kwl"
	^ anObject
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/23/1998 11:00'!
nextPutObjOnly: anObject
	"Really write three objects: (version, class structure, object).  But only when called from the outside.  Not in fileOut format.  No class definitions will be written for instance-specific classes.  Error if find one.  (Use nextPut: instead)"

	| info |
	topCall == nil 
		ifTrue:
			[topCall _ anObject.
			super nextPut: ReferenceStream versionCode.
			'Please wait while objects are counted' displayProgressAt: Sensor cursorPoint
				from: 0 to: 10
				during: [:bar |
					info _ self instVarInfo: anObject].
			self uniClasesDo: [:cls | cls error: 'Class defn not written out.  Proceed?'].
			'Writing an object file' displayProgressAt: Sensor cursorPoint
				from: 0 to: objCount*4	"estimate"
				during: [:bar |
					objCount _ 0.
					progressBar _ bar.
					super nextPut: info.
					super nextPut: anObject.	"<- the real writing"
					"Class inst vars not written here!!"].
			"references is an IDict of every object that got written
			(in case you want to take statistics)"
			"Transcript cr; show: structures keys printString."		"debug"
			topCall _ progressBar _ nil]	"reset it"
		ifFalse:
			[super nextPut: anObject.
			progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/23/1998 11:13'!
noHeader
	"Signal that we've already dealt with the version and structure array, and are now reading objects."

	topCall _ #marked.
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 11/3/2000 17:59'!
readInstance
	"Read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
Three cases for files from older versions of the system:
1) Class has not changed shape, read it straight.
2) Class has changed instance variables (or needs fixup).  Call a particular method to do it.
3) There is a new class instead.  Find it, call a particular method to read.
	All classes used to construct the structures dictionary *itself* need to be in 'steady' and they must not change!!  See setStream:"
	| instSize className refPosn |

	instSize _ (byteStream nextNumber: 4) - 1.
	refPosn _ self getCurrentReference.
	className _ self next asSymbol.
	^ self readInstanceSize: instSize clsname: className refPosn: refPosn
! !

!SmartRefStream methodsFor: 'read write' stamp: 'yo 1/21/2006 19:27'!
readInstanceSize: instSize clsname: className refPosn: refPosn
	"The common code to read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
Three cases for files from older versions of the system:
1) Class has not changed shape, read it straight.
2) Class has changed instance variables (or needs fixup).  Call a particular method to do it.
3) There is a new class instead.  Find it, call a particular method to read.
	All classes used to construct the structures dictionary *itself* need to be in 'steady' and they must not change!!  See setStream:"
	| anObject newName newClass dict oldInstVars isMultiSymbol |

	self flag: #bobconv.	

	self setCurrentReference: refPosn.  "remember pos before readDataFrom:size:"
	newName _ renamed at: className ifAbsent: [className].
	isMultiSymbol _ newName = #MultiSymbol or: [newName = #WideSymbol].
	"isMultiSymbol ifTrue: [self halt]."
	newClass _ Smalltalk at: newName asSymbol.
	(steady includes: newClass) & (newName == className) ifTrue: [
	 	anObject _ newClass isVariable "Create it here"
			ifFalse: [newClass basicNew]
			ifTrue: [newClass basicNew: instSize - (newClass instSize)].

		anObject _ anObject readDataFrom: self size: instSize.
		self setCurrentReference: refPosn.  "before returning to next"
		isMultiSymbol ifTrue: [^ Symbol intern: anObject asString].
		^ anObject].
	oldInstVars _ structures at: className ifAbsent: [
			self error: 'class is not in structures list'].	"Missing in object file"
	anObject _ newClass createFrom: self size: instSize version: oldInstVars.
		"only create the instance"
	self beginReference: anObject.
	dict _ self catalogValues: oldInstVars size: instSize.
		"indexed vars as (1 -> val) etc."
	dict at: #ClassName put: className.	"so conversion method can know it"

	"Give each superclass a chance to make its changes"
	self storeInstVarsIn: anObject from: dict.	"ones with the same names"

	anObject _ self applyConversionMethodsTo: anObject className: className varMap: dict.

	self setCurrentReference: refPosn.  "before returning to next"
	isMultiSymbol ifTrue: [^ Symbol intern: anObject asString].
	^ anObject! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 11/3/2000 18:04'!
readShortInst
	"Instance has just one byte of size.  Class symbol is encoded in two bytes of file position.  See readInstance."
	| instSize className refPosn |

	instSize _ (byteStream next) - 1.	"one byte of size"
	refPosn _ self getCurrentReference.
	className _ self readShortRef.	"class symbol in two bytes of file pos"
	^ self readInstanceSize: instSize clsname: className refPosn: refPosn
! !

!SmartRefStream methodsFor: 'read write' stamp: 'ar 7/25/2005 21:30'!
readWordLike
	| refPosn newClass anObject className |
	"Can be used by any class that is bits and not bytes (WordArray, Bitmap, SoundBuffer, etc)."

	refPosn _ self getCurrentReference.
	className _ self next asSymbol.
	className _ renamed at: className ifAbsent: [className].
	newClass _ Smalltalk at: className.
	anObject _ newClass newFromStream: byteStream.
	"Size is number of long words."
	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 10/10/2000 13:36'!
recordImageSegment: refs
	"Besides the objects being written out, record the structure of instances inside the image segment we are writing out."

	| cls list |
	"Do not record Player class inst vars.  They are in the segement."
	refs keysDo: [:each | 
		cls _ each class.
		cls isObsolete ifTrue: [self error: 'Trying to write ', cls name].
		cls class == Metaclass 
			ifFalse: [structures at: cls name put: false.
				(each isKindOf: ImageSegment) ifTrue: [
					each outPointers do: [:out |
						(out isKindOf: Class) ifTrue: [
							structures at: out theNonMetaClass name put: false].
						out class == DiskProxy ifTrue: [
							out simpleGlobalOrNil ifNotNil: [
								(out simpleGlobalOrNil isKindOf: Class) ifTrue: [
									structures at: out simpleGlobalOrNil name put: false]]]].
					"each arrayOfRoots do: [:rr | (rr isKindOf: Class) ifTrue: [
							structures at: rr theNonMetaClass name put: false]]."
					 	"all classes in roots are local to seg"]]].
	list _ refs at: #BlockReceiverClasses ifAbsent: [^ self].
	list do: [:meta | structures at: meta name put: false].
		"Just the metaclasses whose instances are block receivers.  Otherwise metaclasses are not allowed."! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 11:08'!
renamed

	self flag: #bobconv.	


	^ renamed! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 11:10'!
renamedConv
	self flag: #bobconv.	


	^ renamedConv! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/22/2000 15:14'!
restoreClassInstVars
	"Install the values of the class instance variables of UniClasses
(i.e. scripts slotInfo).  classInstVars is ((#Player25 scripts slotInfo)
...).  Thank you Mark Wai for the bug fix."

	| normal aName newName newCls trans rList start |

	self flag: #bobconv.	


	self moreObjects ifFalse: [^ self]. 	"are no UniClasses with class inst vars"
	classInstVars _ super next.	"Array of arrays"
	normal _ Object class instSize.	"might give trouble if Player class superclass changes size"
	(structures at: #Player ifAbsent: [#()]) = #(0 'dependents' 'costume') ifTrue:
		[trans _ 1].	"now (0 costume costumes).  Do the conversion of Player class
			inst vars in Update 509."
	classInstVars do: [:list |
		aName _ (list at: 1) asSymbol.
		rList _ list.
		newName _ renamed at: aName ifAbsent: [aName].
		newCls _ Smalltalk at: newName
				ifAbsent: [self error: 'UniClass definition missing'].
		("old conversion" trans == 1 and: [newCls inheritsFrom: Player]) ifTrue: [
			"remove costumeDictionary from Player class inst vars"
			rList _ rList asOrderedCollection.
			rList removeAt: 4].	"costumeDictionary's value"
		start _ list second = 'Update to read classPool' ifTrue: [4] ifFalse: [2].
		newCls class instSize = (normal + (rList size) - start + 1) ifFalse:
			[self error: 'UniClass superclass class has changed size'].
			"Need to install a conversion method mechanism"
		start = 4 ifTrue: [newCls instVarAt: normal - 1 "classPool" put: (list at: 3)].
		start to: rList size do: [:ii |
			newCls instVarAt: normal + ii - start + 1 put: (rList at: ii)]].
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/6/2000 18:17'!
saveClassInstVars
	"Install the values of the instance variables of UniClasses.
classInstVars is an array of arrays (#Player3 (Player3 class's inst var
scripts) (Player3 class's inst var slotInfo) ...) "

	| normal mySize list clsPoolIndex |
	classInstVars _ OrderedCollection new: 100.
	normal _ Object class instSize.
	clsPoolIndex _ Object class allInstVarNames indexOf: 'classPool'.
	self uniClasesDo: [:aUniClass |
		list _ OrderedCollection new.
		mySize _ aUniClass class instSize.
		mySize = normal ifFalse:
			[list add: aUniClass name.	"a symbol"
			list add: 'Update to read classPool'.	"new
convention for saving the classPool"
			list add: (aUniClass instVarAt: clsPoolIndex)
"classPool".
						"write actual value of nil
instead of Dictionary()"
			normal + 1 to: mySize do: [:ii |
				list addLast: (aUniClass instVarAt: ii)].
			classInstVars add: list asArray]].
	classInstVars _ classInstVars asArray.
	! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 8/18/1998 09:02'!
scanFrom: aByteStream
	"During a code fileIn, we need to read in an object, and stash it in ScannedObject.  "

	self setStream: aByteStream reading: true.
	ScannedObject _ self next.
	byteStream ascii.
	byteStream next == $!! ifFalse: [
		byteStream close.
		self error: 'Object did not end correctly']. 
	"caller will close the byteStream"
	"HandMorph.readMorphFile will retrieve the ScannedObject"! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 16:57'!
setStream: aStream
	"Initialize me. "

	self flag: #bobconv.	

	super setStream: aStream.
	self initShapeDicts.

! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 16:57'!
setStream: aStream reading: isReading
	"Initialize me. "

	self flag: #bobconv.	

	super setStream: aStream reading: isReading.
	isReading ifFalse: [^ false].
	self initShapeDicts.

! !

!SmartRefStream methodsFor: 'read write'!
structures
	^ structures! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 9/28/97 11:17'!
superclasses
	^superclasses! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/6/2000 17:15'!
uniClasesDo: aBlock
	"Examine structures and execute the block with each instance-specific class"

	| cls |
	structures keysDo: [:clsName | 
		(clsName endsWith: ' class') ifFalse: [
			(cls _ Smalltalk at: clsName) isSystemDefined ifFalse: [
					aBlock value: cls]]]! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 1/18/2001 15:54'!
uniClassInstVarsRefs: dummy
	"If some of the objects seen so far are instances UniClasses, check the UniClasses for extra class inst vars, and send them to the steam also.  The new objects get added to (dummy references), where they will be noticed by the caller.  They will wind up in the structures array and will be written on the disk by class.
	Return all classes seen." 
| uniClasses normal more aUniClass mySize allClasses |

"Note: Any classes used in the structure of classInstVars must be written out also!!"
uniClasses _ Set new.
allClasses _ IdentitySet new.
normal _ Object class instSize.
more _ true.
[more] whileTrue: [
	more _ false.
	dummy references keysDo: [:each | "any faster way to do this?"
		(aUniClass _ each class) isSystemDefined ifFalse: [
			(uniClasses includes: aUniClass name) ifFalse: [
				mySize _ aUniClass class instSize.
				normal+1 to: mySize do: [:ii | 
					more _ true.
					dummy nextPut: (aUniClass instVarAt: ii)].
				uniClasses add: aUniClass name]].
		each class class isMeta ifFalse: ["it is a class" allClasses add: each]]].
"References dictionary is modified as the loop proceeds, but we will catch any we missed on the next cycle."

^ allClasses! !

!SmartRefStream methodsFor: 'read write' stamp: 'ar 4/10/2005 18:52'!
verifyStructure
	"Compare the incoming inst var name lists with the existing classes.  Prepare tables that will help to restructure those who need it (renamed, reshaped, steady).    If all superclasses are recorded in the file, only compare inst vars of this class, not of superclasses.  They will get their turn.  "


	| newClass newList oldList converting |

	self flag: #bobconv.	

	converting _ OrderedCollection new.
	structures keysDo: [:nm "an old className (symbol)" |
		"For missing classes, there needs to be a method in SmartRefStream like 
			#rectangleoc2 that returns the new class."
		newClass _ self mapClass: nm.	   "does (renamed at: nm put: newClass name)"
		newClass isString ifTrue: [^ newClass].  "error, fileIn needed"
		newList _ (Array with: newClass classVersion), (newClass allInstVarNames).
		oldList _ structures at: nm.
		newList = oldList 
			ifTrue: [steady add: newClass]  "read it in as written"
			ifFalse: [converting add: newClass name]
	].
	false & converting isEmpty not ifTrue: ["debug" 
			self inform: 'These classes are being converted from existing methods:\' withCRs,
				converting asArray printString].
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 1/7/97'!
versionSymbol: instVarList
	"Create the symbolic code (like a version number) for this class in some older version.  First initials of all the inst vars, followed by the class version number.  Returns a string, caller makes it into a compound selector.  "

	| str |
	str _ instVarList size = 1 ifFalse: [''] ifTrue: ['x'].		"at least one letter"
	2 to: instVarList size do: [:ind |
		str _ str, (instVarList at: ind) first asString].
	str _ str, instVarList first printString.	"the number"
	^ str

" | list | list _ (Array with: Paragraph classVersion), (Paragraph alistInstVarNames).
(SmartRefStream  on: (DummyStream on: nil)) versionSymbol: list
"! !


!SmartRefStream methodsFor: '*starSqueak-*starSqueak' stamp: 'RAA 5/16/2001 18:35'!
starLogoAntColonybosfcedppplppppttwssdlgrstta0

	^ StarSqueakAntColony! !

!SmartRefStream methodsFor: '*starSqueak-*starSqueak' stamp: 'RAA 5/16/2001 18:31'!
starLogoMorphbosfcedppplppppttwssdlgrstt0

	^ StarSqueakMorph! !

!SmartRefStream methodsFor: '*starSqueak-*starSqueak' stamp: 'RAA 5/16/2001 18:32'!
starLogoTreesbosfcedppplppppttwssdlgrsttdt0

	^ StarSqueakTrees! !

!SmartRefStream methodsFor: '*starSqueak-*starSqueak' stamp: 'RAA 5/16/2001 18:32'!
starLogoTurtlewwxywwhcpn0

	^ StarSqueakTurtle! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmartRefStream class
	instanceVariableNames: ''!

!SmartRefStream class methodsFor: 'accessing' stamp: 'tk 5/20/97'!
scannedObject
	"The most recently read in object.  Watch out for read-in that is interrupted and resumed.  May want to make this a dictionary?  "

	^ ScannedObject! !

!SmartRefStream class methodsFor: 'accessing' stamp: 'tk 5/20/97'!
scannedObject: objOrNil
	"Used to free up the last object stashed here.  "

	ScannedObject _ objOrNil! !

!SmartRefStream class methodsFor: 'accessing' stamp: 'tk 3/11/98 09:45'!
subObjects: anObject ofClass: aClass
	"Return a collection of all instances of aClass that would be written out with anObject.  Does not actually write on the disk.  Inspect the result and ask for 'references to this object'."

	| dummy coll |
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	coll _ OrderedCollection new.
	dummy references keysDo: [:each |
		each class == aClass ifTrue: [coll add: each]].
	^ coll! !


!SmartRefStream class methodsFor: 'initialize-release' stamp: 'dvf 8/23/2003 12:18'!
cleanUpCategories
	| list valid removed newList newVers |
	"Look for all conversion methods that can't be used any longer.  Delete them."
	" SmartRefStream cleanUpCategories "

	"Two part selectors that begin with convert and end with a digit."
	"convertasossfe0: varDict asossfeu0: smartRefStrm"
	list _ Symbol selectorsContaining: 'convert'.
	list _ list select: [:symb | (symb beginsWith: 'convert') & (symb allButLast last isDigit)
				ifTrue: [(symb numArgs = 2)]
				ifFalse: [false]].
	valid _ 0.  removed _ 0.
	list do: [:symb |
		(self systemNavigation allClassesImplementing: symb) do: [:newClass |
			newList _ (Array with: newClass classVersion), (newClass allInstVarNames).
			newVers _ self new versionSymbol: newList.
			(symb endsWith: (':',newVers,':')) 
				ifFalse: [
					"method is useless because can't convert to current shape"
					newClass removeSelector: symb.	"get rid of it"
					removed _ removed + 1]
				ifTrue: [valid _ valid + 1]]].
	Transcript cr; show: 'Removed: '; print: removed; 
		show: '		Kept: '; print: valid; show: ' '.! !


!SmartRefStream class methodsFor: 'i/o' stamp: 'RAA 7/9/2000 05:48'!
objectFromStreamedRepresentation: someBytes

	| file |

	file _ RWBinaryOrTextStream with: someBytes.
	file reset.
	^file fileInObjectAndCode! !

!SmartRefStream class methodsFor: 'i/o' stamp: 'tk 12/9/97 21:31'!
read: aByteStream withClasses: structureArray
	"Read an object off the stream, but first check structureArray against the current system."

	| me |
	me _ self on: aByteStream.
	me noHeader.
	me structures: (structureArray at: 2).
	me superclasses: (structureArray at: 4).
	(me verifyStructure = 'conversion method needed') ifTrue: [^ nil].
	^ super next
! !

!SmartRefStream class methodsFor: 'i/o' stamp: 'tk 5/20/97'!
scanFrom: aByteStream
	"During a code fileIn, we need to read in an object, and stash it in ScannedObject.  "

	| me |
	me _ self on: aByteStream.
	ScannedObject _ me next.
	aByteStream ascii.
	aByteStream next == $!! ifFalse: [
		aByteStream close.
		self error: 'Object did not end correctly']. 
	"caller will close the byteStream"
	"HandMorph.readMorphFile will retrieve the ScannedObject"! !


!SmartRefStream class methodsFor: 'utilities' stamp: 'tk 5/4/1998 17:34'!
statsOfSubObjects: anObject
	"Open a window with statistics on what objects would be written out with anObject.  Does not actually write on the disk.  Stats in the form:
	ScriptEditorMorph 51
		SortedCollection (21->LayoutMorph 15->SimpleButtonMorph 9->Array 4->CompoundTileMorph 2->StringMorph )"

	| dummy printOut |
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	"(dummy references) is the raw data"
	printOut _ dummy statisticsOfRefs.
	(StringHolder new contents: printOut) 
		openLabel: 'ReferenceStream statistics'.! !

!SmartRefStream class methodsFor: 'utilities' stamp: 'RAA 7/9/2000 05:35'!
streamedRepresentationOf: anObject

	| file |
	file _ (RWBinaryOrTextStream on: (ByteArray new: 5000)).
	file binary.
	(self on: file) nextPut: anObject.
	file close.
	^file contents! !

!SmartRefStream class methodsFor: 'utilities' stamp: 'tk 5/4/1998 17:34'!
tallyOfSubObjects: anObject
	"Open a window with statistics on what objects would be written out with anObject.  Does not actually write on the disk.  Stats are simply the number of instances of each class:
	1450->Point   835->Rectangle   549->Array   300->String"

	| dummy bag |
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	bag _ Bag new.
	dummy references keysDo: [:key | bag add: key class name].
	"(bag sortedCounts) is the SortedCollection"
	(StringHolder new contents: bag sortedCounts printString) 
		openLabel: 'ReferenceStream statistics'.! !
Object subclass: #Socket
	instanceVariableNames: 'semaphore socketHandle readSemaphore writeSemaphore primitiveOnlySupportsOneSemaphore'
	classVariableNames: 'Connected DeadServer InvalidSocket OtherEndClosed Registry RegistryThreshold TCPSocketType ThisEndClosed UDPSocketType Unconnected WaitingForConnection'
	poolDictionaries: ''
	category: 'Network-Kernel'!
!Socket commentStamp: 'gk 12/13/2005 00:43' prior: 0!
A Socket represents a network connection point. Current sockets are designed to support the TCP/IP and UDP protocols. Sockets are the lowest level of networking object in Squeak and are not normally used directly. SocketStream is a higher level object wrapping a Socket in a stream like protocol.

ProtocolClient and subclasses are in turn wrappers around a SocketStream to provide support for specific network protocols such as POP, NNTP, HTTP, and FTP.!


!Socket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'!
address
	"Shortcut"
	^self localAddress! !

!Socket methodsFor: 'accessing' stamp: 'MU 11/26/2003 16:53'!
localAddress
	self isWaitingForConnection
		ifFalse: [[self waitForConnectionFor: Socket standardTimeout]
				on: ConnectionTimedOut
				do: [:ex | ^ ByteArray new: 4]].
	^ self primSocketLocalAddress: socketHandle! !

!Socket methodsFor: 'accessing' stamp: 'MU 11/26/2003 16:53'!
localPort
	self isWaitingForConnection
		ifFalse: [[self waitForConnectionFor: Socket standardTimeout]
				on: ConnectionTimedOut
				do: [:ex | ^ 0]].
	^ self primSocketLocalPort: socketHandle! !

!Socket methodsFor: 'accessing' stamp: 'jm 3/13/98 12:11'!
peerName
	"Return the name of the host I'm connected to, or nil if its name isn't known to the domain name server or the request times out."
	"Note: Slow. Calls the domain name server, taking up to 20 seconds to time out. Even when sucessful, delays of up to 13 seconds have been observed during periods of high network load." 

	^ NetNameResolver
		nameForAddress: self remoteAddress
		timeout: 20
! !

!Socket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'!
port
	"Shortcut"
	^self localPort! !

!Socket methodsFor: 'accessing' stamp: 'JMM 6/5/2000 10:12'!
primitiveOnlySupportsOneSemaphore
	^primitiveOnlySupportsOneSemaphore! !

!Socket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'!
readSemaphore
	primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore].
	^readSemaphore! !

!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!
remoteAddress

	^ self primSocketRemoteAddress: socketHandle
! !

!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!
remotePort

	^ self primSocketRemotePort: socketHandle
! !

!Socket methodsFor: 'accessing' stamp: 'JMM 5/9/2000 15:32'!
semaphore
	^semaphore! !

!Socket methodsFor: 'accessing' stamp: 'ar 7/16/1999 17:22'!
socketHandle
	^socketHandle! !

!Socket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'!
writeSemaphore
	primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore].
	^writeSemaphore! !


!Socket methodsFor: 'connection open/close' stamp: 'bolot 7/16/1999 14:36'!
accept
	"Accept a connection from the receiver socket.
	Return a new socket that is connected to the client"
	^Socket acceptFrom: self.! !

!Socket methodsFor: 'connection open/close' stamp: 'jm 9/11/97 20:29'!
close
	"Close this connection gracefully. For TCP, this sends a close request, but the stream remains open until the other side also closes it."

	self primSocketCloseConnection: socketHandle.  "close this end"
! !

!Socket methodsFor: 'connection open/close' stamp: 'jm 11/4/97 07:15'!
closeAndDestroy
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	self closeAndDestroy: 20.

! !

!Socket methodsFor: 'connection open/close' stamp: 'gk 12/13/2005 00:05'!
closeAndDestroy: timeoutSeconds
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle = nil
		ifFalse: [
			self isConnected ifTrue: [
				self close.  "close this end"
				(self waitForDisconnectionFor: timeoutSeconds)
					ifFalse: [
						"The other end didn't close so we just abort the connection"
						self primSocketAbortConnection: socketHandle]].
			self destroy].
! !

!Socket methodsFor: 'connection open/close' stamp: 'mir 5/9/2003 18:13'!
connectNonBlockingTo: hostAddress port: port
	"Initiate a connection to the given port at the given host address. This operation will return immediately; follow it with waitForConnectionUntil: to wait until the connection is established."

	| status |
	self initializeNetwork.
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before opening a new connection'].

	self primSocket: socketHandle connectTo: hostAddress port: port.
! !

!Socket methodsFor: 'connection open/close' stamp: 'mir 5/15/2003 18:29'!
connectTo: hostAddress port: port
	"Initiate a connection to the given port at the given host address.
	Waits until the connection is established or time outs."

	self connectTo: hostAddress port: port waitForConnectionFor: Socket standardTimeout! !

!Socket methodsFor: 'connection open/close' stamp: 'mu 8/14/2003 15:15'!
connectTo: hostAddress port: port waitForConnectionFor: timeout 
	"Initiate a connection to the given port at the given host 
	address. Waits until the connection is established or time outs."
	self connectNonBlockingTo: hostAddress port: port.
	self
		waitForConnectionFor: timeout
		ifTimedOut: [ConnectionTimedOut signal: 'Cannot connect to '
					, (NetNameResolver stringFromAddress: hostAddress) , ':' , port asString]! !

!Socket methodsFor: 'connection open/close' stamp: 'mir 5/8/2003 16:03'!
connectToHostNamed: hostName port: portNumber
	| serverIP |
	serverIP _ NetNameResolver addressForName: hostName timeout: 20.
	^self connectTo: serverIP port: portNumber
! !

!Socket methodsFor: 'connection open/close' stamp: 'jm 3/10/98 11:56'!
disconnect
	"Break this connection, no matter what state it is in. Data that has been sent but not received will be lost."

	self primSocketAbortConnection: socketHandle.
! !

!Socket methodsFor: 'connection open/close' stamp: 'mir 2/22/2002 16:25'!
listenOn: port
	"Listen for a connection on the given port. This operation will return immediately; follow it with waitForConnectionUntil: to wait until a connection is established."

	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection'].

	self primSocket: socketHandle listenOn: port.
! !

!Socket methodsFor: 'connection open/close' stamp: 'mir 2/22/2002 16:25'!
listenOn: portNumber backlogSize: backlog
	"Listen for a connection on the given port.
	If this method succeeds, #accept may be used to establish a new connection"
	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection'].
	self primSocket: socketHandle listenOn: portNumber backlogSize: backlog.
! !

!Socket methodsFor: 'connection open/close' stamp: 'ikp 9/1/2003 20:32'!
listenOn: portNumber backlogSize: backlog interface: ifAddr
	"Listen for a connection on the given port.
	If this method succeeds, #accept may be used to establish a new connection"
	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection'].
	self primSocket: socketHandle listenOn: portNumber backlogSize: backlog interface: ifAddr.
! !


!Socket methodsFor: 'datagrams' stamp: 'JMM 6/7/2000 14:58'!
receiveDataInto: aStringOrByteArray fromHost: hostAddress port: portNumber
	| datagram |
	"Receive a UDP packet from the given hostAddress/portNumber, storing the data in the given buffer, and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	primitiveOnlySupportsOneSemaphore ifTrue:
		[self setPeer: hostAddress port: portNumber.
		^self receiveDataInto: aStringOrByteArray].
	[true] whileTrue: 
		[datagram _ self receiveUDPDataInto: aStringOrByteArray.
		((datagram at: 2) = hostAddress and: [(datagram at: 3) = portNumber]) 
			ifTrue: [^datagram at: 1]
			ifFalse: [^0]]! !

!Socket methodsFor: 'datagrams' stamp: 'JMM 6/3/2000 21:54'!
receiveUDPDataInto: aStringOrByteArray
	"Receive UDP data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data. What is returned is an array, the first element is the bytes read, the second the sending bytearray address, the third the senders port, the fourth, true if more of the datagram awaits reading"

	^ self primSocket: socketHandle
		receiveUDPDataInto: aStringOrByteArray
		startingAt: 1
		count: aStringOrByteArray size
! !

!Socket methodsFor: 'datagrams' stamp: 'JMM 5/25/2000 00:05'!
sendData: aStringOrByteArray toHost: hostAddress port: portNumber
	"Send a UDP packet containing the given data to the specified host/port."

	primitiveOnlySupportsOneSemaphore ifTrue:
		[self setPeer: hostAddress port: portNumber.
		^self sendData: aStringOrByteArray].
	^self sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber! !

!Socket methodsFor: 'datagrams' stamp: 'mir 5/15/2003 18:34'!
sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber
	"Send a UDP packet containing the given data to the specified host/port."
	| bytesToSend bytesSent count |

	bytesToSend _ aStringOrByteArray size.
	bytesSent _ 0.
	[bytesSent < bytesToSend] whileTrue: [
		(self waitForSendDoneFor: 20)
			ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent'].
		count _ self primSocket: socketHandle
			sendUDPData: aStringOrByteArray
			toHost: hostAddress
			port: portNumber
			startIndex: bytesSent + 1
			count: bytesToSend - bytesSent.
		bytesSent _ bytesSent + count].

	^ bytesSent
! !

!Socket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'!
setPeer: hostAddress port: port
	"Set the default send/recv address."

	self primSocket: socketHandle connectTo: hostAddress port: port.
! !

!Socket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'!
setPort: port
	"Associate a local port number with a UDP socket.  Not applicable to TCP sockets."

	self primSocket: socketHandle setPort: port.
! !


!Socket methodsFor: 'finalization' stamp: 'JMM 5/22/2000 22:52'!
finalize
	self primSocketDestroyGently: socketHandle.
	Smalltalk unregisterExternalObject: semaphore.
	Smalltalk unregisterExternalObject: readSemaphore.
	Smalltalk unregisterExternalObject: writeSemaphore.
! !


!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:47'!
acceptFrom: aSocket
	"Initialize a new socket handle from an accept call"
	| semaIndex readSemaIndex writeSemaIndex |

	primitiveOnlySupportsOneSemaphore _ false.
	semaphore _ Semaphore new.
	readSemaphore _ Semaphore new.
	writeSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	readSemaIndex _ Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore.
	socketHandle _ self primAcceptFrom: aSocket socketHandle
						receiveBufferSize: 8000
						sendBufSize: 8000
						semaIndex: semaIndex
						readSemaIndex: readSemaIndex
						writeSemaIndex: writeSemaIndex.
	socketHandle = nil ifTrue: [  "socket creation failed"
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		readSemaphore _ writeSemaphore _ semaphore _ nil
	] ifFalse:[self register].
! !

!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:54'!
destroy
	"Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle = nil ifFalse: 
		[self isValid ifTrue: [self primSocketDestroy: socketHandle].
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		socketHandle _ nil.
		readSemaphore _ writeSemaphore _ semaphore _ nil.
		self unregister].
! !

!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 23:04'!
initialize: socketType
	"Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil."
	| semaIndex readSemaIndex writeSemaIndex |

	primitiveOnlySupportsOneSemaphore _ false.
	semaphore _ Semaphore new.
	readSemaphore _ Semaphore new.
	writeSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	readSemaIndex _ Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore.
	socketHandle _
		self primSocketCreateNetwork: 0
			type: socketType
			receiveBufferSize: 8000
			sendBufSize: 8000
			semaIndex: semaIndex
			readSemaIndex: readSemaIndex
			writeSemaIndex: writeSemaIndex.

	socketHandle = nil ifTrue: [  "socket creation failed"
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		readSemaphore _ writeSemaphore _ semaphore _ nil
	] ifFalse:[self register].
! !

!Socket methodsFor: 'initialize-destroy' stamp: 'mir 2/22/2002 15:48'!
initializeNetwork
	self class initializeNetwork! !


!Socket methodsFor: 'other' stamp: 'mir 2/22/2002 16:25'!
getOption: aName 
	"Get options on this socket, see Unix man pages for values for 
	sockets, IP, TCP, UDP. IE SO_KEEPALIVE
	returns an array, element one is an status number (0 ok, -1 read only option)
	element two is the resulting of the requested option"

	(socketHandle == nil or: [self isValid not])
		ifTrue: [InvalidSocketStatusException signal: 'Socket status must valid before getting an option'].
	^self primSocket: socketHandle getOption: aName

"| foo options |
Socket initializeNetwork.
foo _ Socket newTCP.
foo connectTo: (NetNameResolver addressFromString: '192.168.1.1') port: 80.
foo waitForConnectionUntil: (Socket standardDeadline).

options _ {
'SO_DEBUG'. 'SO_REUSEADDR'. 'SO_REUSEPORT'. 'SO_DONTROUTE'.
'SO_BROADCAST'. 'SO_SNDBUF'. 'SO_RCVBUF'. 'SO_KEEPALIVE'.
'SO_OOBINLINE'. 'SO_PRIORITY'. 'SO_LINGER'. 'SO_RCVLOWAT'.
'SO_SNDLOWAT'. 'IP_TTL'. 'IP_HDRINCL'. 'IP_RCVOPTS'.
'IP_RCVDSTADDR'. 'IP_MULTICAST_IF'. 'IP_MULTICAST_TTL'.
'IP_MULTICAST_LOOP'. 'UDP_CHECKSUM'. 'TCP_MAXSEG'.
'TCP_NODELAY'. 'TCP_ABORT_THRESHOLD'. 'TCP_CONN_NOTIFY_THRESHOLD'. 
'TCP_CONN_ABORT_THRESHOLD'. 'TCP_NOTIFY_THRESHOLD'.
'TCP_URGENT_PTR_TYPE'}.

1 to: options size do: [:i | | fum |
	fum _foo getOption: (options at: i).
	Transcript show: (options at: i),fum printString;cr].

foo _ Socket newUDP.
foo setPeer: (NetNameResolver addressFromString: '192.168.1.9') port: 7.
foo waitForConnectionUntil: (Socket standardDeadline).

1 to: options size do: [:i | | fum |
	fum _foo getOption: (options at: i).
	Transcript show: (options at: i),fum printString;cr].
"! !

!Socket methodsFor: 'other' stamp: 'mir 2/22/2002 16:30'!
setOption: aName value: aValue 
	| value |
	"setup options on this socket, see Unix man pages for values for 
	sockets, IP, TCP, UDP. IE SO_KEEPALIVE
	returns an array, element one is the error number
	element two is the resulting of the negotiated value.
	See getOption for list of keys"

	(socketHandle == nil or: [self isValid not])
		ifTrue: [InvalidSocketStatusException signal: 'Socket status must valid before setting an option'].
	value _ aValue asString.
	aValue == true ifTrue: [value _ '1'].
	aValue == false ifTrue: [value _ '0'].
	^ self primSocket: socketHandle setOption: aName value: value! !


!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex
	"Create and return a new socket handle based on accepting the connection from the given listening socket"
	<primitive: 'primitiveSocketAccept' module: 'SocketPlugin'>
	^self primitiveFailed! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:55'!
primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	"Create and return a new socket handle based on accepting the connection from the given listening socket"
	<primitive: 'primitiveSocketAccept3Semaphores' module: 'SocketPlugin'>
	primitiveOnlySupportsOneSemaphore _ true.
	^self primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex ! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID connectTo: hostAddress port: port
	"Attempt to establish a connection to the given port of the given host. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."

	<primitive: 'primitiveSocketConnectToPort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 21:48'!
primSocket: socketID getOption: aString 
	"Get some option information on this socket. Refer to the UNIX 
	man pages for valid SO, TCP, IP, UDP options. In case of doubt
	refer to the source code.
	TCP_NODELAY, SO_KEEPALIVE are valid options for example
	returns an array containing the error code and the option value"

	<primitive: 'primitiveSocketGetOptions' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID listenOn: port
	"Listen for a connection on the given port. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."

	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: aHandle listenOn: portNumber backlogSize: backlog
	"Primitive. Set up the socket to listen on the given port.
	Will be used in conjunction with #accept only."
	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self destroy. "Accept not supported so clean up"! !

!Socket methodsFor: 'primitives' stamp: 'ikp 9/1/2003 20:33'!
primSocket: aHandle listenOn: portNumber backlogSize: backlog interface: ifAddr
	"Primitive. Set up the socket to listen on the given port.
	Will be used in conjunction with #accept only."
	<primitive: 'primitiveSocketListenOnPortBacklogInterface' module: 'SocketPlugin'>
	self destroy. "Accept not supported so clean up"! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID receiveDataInto: aStringOrByteArray startingAt: startIndex count: count
	"Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available."

	<primitive: 'primitiveSocketReceiveDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/24/2000 17:19'!
primSocket: socketID receiveUDPDataInto: aStringOrByteArray startingAt: startIndex count: count
	"Receive data from the given socket into the given array starting at the given index. 
	Return an Array containing the amount read, the host address byte array, the host port, and the more flag"

	<primitive: 'primitiveSocketReceiveUDPDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID sendData: aStringOrByteArray startIndex: startIndex count: count
	"Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."
	"Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."

	<primitive: 'primitiveSocketSendDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 00:08'!
primSocket: socketID sendUDPData: aStringOrByteArray toHost: hostAddress  port: portNumber startIndex: startIndex count: count
	"Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."
	"Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."

	<primitive:  'primitiveSocketSendUDPDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed

! !

!Socket methodsFor: 'primitives' stamp: 'ar 7/18/2000 11:42'!
primSocket: socketID setOption: aString value: aStringValue
	"Set some option information on this socket. Refer to the UNIX 
	man pages for valid SO, TCP, IP, UDP options. In case of doubt
	refer to the source code.
	TCP_NODELAY, SO_KEEPALIVE are valid options for example
	returns an array containing the error code and the negotiated value"

	<primitive: 'primitiveSocketSetOptions' module: 'SocketPlugin'>
	^nil! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID setPort: port
	"Set the local port associated with a UDP socket.
	Note: this primitive is overloaded.  The primitive will not fail on a TCP socket, but
	the effects will not be what was desired.  Best solution would be to split Socket into
	two subclasses, TCPSocket and UDPSocket."

	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketAbortConnection: socketID
	"Terminate the connection on the given port immediately without going through the normal close sequence. This is an asynchronous call; query the socket status to discover if and when the connection is actually terminated."

	<primitive: 'primitiveSocketAbortConnection' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketCloseConnection: socketID
	"Close the connection on the given port. The remote end is informed that this end has closed and will do no further sends. This is an asynchronous call; query the socket status to discover if and when the connection is actually closed."

	<primitive: 'primitiveSocketCloseConnection' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketConnectionStatus: socketID
	"Return an integer reflecting the connection status of this socket. For a list of possible values, see the comment in the 'initialize' method of this class. If the primitive fails, return a status indicating that the socket handle is no longer valid, perhaps because the Squeak image was saved and restored since the socket was created. (Sockets do not survive snapshots.)"

	<primitive: 'primitiveSocketConnectionStatus' module: 'SocketPlugin'>
	^ InvalidSocket
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex
	"Return a new socket handle for a socket of the given type and buffer sizes. Return nil if socket creation fails.
	The netType parameter is platform dependent and can be used to encode both the protocol type (IP, Xerox XNS, etc.) and/or the physical network interface to use if this host is connected to multiple networks. A zero netType means to use IP protocols and the primary (or only) network interface.
	The socketType parameter specifies:
		0	reliable stream socket (TCP if the protocol is IP)
		1	unreliable datagram socket (UDP if the protocol is IP)
	The buffer size parameters allow performance to be tuned to the application. For example, a larger receive buffer should be used when the application expects to be receiving large amounts of data, especially from a host that is far away. These values are considered requests only; the underlying implementation will ensure that the buffer sizes actually used are within allowable bounds. Note that memory may be limited, so an application that keeps many sockets open should use smaller buffer sizes. Note the macintosh implementation ignores this buffer size. Also see setOption to get/set socket buffer sizes which allows you to set/get the current buffer sizes for reading and writing.
 	If semaIndex is > 0, it is taken to be the index of a Semaphore in the external objects array to be associated with this socket. This semaphore will be signalled when the socket status changes, such as when data arrives or a send completes. All processes waiting on the semaphore will be awoken for each such event; each process must then query the socket state to figure out if the conditions they are waiting for have been met. For example, a process waiting to send some data can see if the last send has completed."

	<primitive: 'primitiveSocketCreate' module: 'SocketPlugin'>
	^ nil  "socket creation failed"
! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:48'!
primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	"See comment in primSocketCreateNetwork: with one semaIndex. However you should know that some implementations
	ignore the buffer size and this interface supports three semaphores,  one for open/close/listen and the other two for
	reading and writing"

	<primitive: 'primitiveSocketCreate3Semaphores' module: 'SocketPlugin'>
	primitiveOnlySupportsOneSemaphore _ true.
	^ self primSocketCreateNetwork: netType
			type: socketType
			receiveBufferSize: rcvBufSize
			sendBufSize: sendBufSize
			semaIndex: semaIndex! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketDestroy: socketID
	"Release the resources associated with this socket. If a connection is open, it is aborted."

	<primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketDestroyGently: socketID
	"Release the resources associated with this socket. If a connection is open, it is aborted.
	Do not fail if the receiver is already closed."

	<primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'>
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketError: socketID
	"Return an integer encoding the most recent error on this socket. Zero means no error."

	<primitive: 'primitiveSocketError' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketLocalAddress: socketID
	"Return the local host address for this socket."

	<primitive: 'primitiveSocketLocalAddress' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketLocalPort: socketID
	"Return the local port for this socket, or zero if no port has yet been assigned."

	<primitive: 'primitiveSocketLocalPort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketReceiveDataAvailable: socketID
	"Return true if data may be available for reading from the current socket."

	<primitive: 'primitiveSocketReceiveDataAvailable' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketRemoteAddress: socketID
	"Return the remote host address for this socket, or zero if no connection has been made."

	<primitive: 'primitiveSocketRemoteAddress' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketRemotePort: socketID
	"Return the remote port for this socket, or zero if no connection has been made."

	<primitive: 'primitiveSocketRemotePort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketSendDone: socketID
	"Return true if there is no send in progress on the current socket."

	<primitive: 'primitiveSocketSendDone' module: 'SocketPlugin'>
	self primitiveFailed
! !


!Socket methodsFor: 'printing' stamp: 'jm 11/23/1998 11:57'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '[', self statusString, ']'.
! !


!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'!
dataAvailable
	"Return true if this socket has unread received data."

	socketHandle == nil ifTrue: [^ false].
	^ self primSocketReceiveDataAvailable: socketHandle
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'!
isConnected
	"Return true if this socket is connected."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Connected
! !

!Socket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:15'!
isOtherEndClosed
	"Return true if this socket had the other end closed."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == OtherEndClosed
! !

!Socket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:17'!
isThisEndClosed
	"Return true if this socket had the this end closed."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == ThisEndClosed
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isUnconnected
	"Return true if this socket's state is Unconnected."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Unconnected
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isUnconnectedOrInvalid
	"Return true if this socket is completely disconnected or is invalid."

	| status |
	socketHandle == nil ifTrue: [^ true].
	status _ self primSocketConnectionStatus: socketHandle.
	^ (status = Unconnected) | (status = InvalidSocket)
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:51'!
isValid
	"Return true if this socket contains a valid, non-nil socket handle."

	| status |
	socketHandle == nil ifTrue: [^ false].
	status _ self primSocketConnectionStatus: socketHandle.
	^ status ~= InvalidSocket
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isWaitingForConnection
	"Return true if this socket is waiting for a connection."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == WaitingForConnection
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
sendDone
	"Return true if the most recent send operation on this socket has completed."

	socketHandle == nil ifTrue: [^ false].
	^ self primSocketSendDone: socketHandle
! !

!Socket methodsFor: 'queries' stamp: 'JMM 5/8/2000 23:24'!
socketError
	^self primSocketError: socketHandle! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:56'!
statusString
	"Return a string describing the status of this socket."

	| status |
	socketHandle == nil ifTrue: [^ 'destroyed'].
	status _ self primSocketConnectionStatus: socketHandle.
	status = InvalidSocket ifTrue: [^ 'invalidSocketHandle'].
	status = Unconnected ifTrue: [^ 'unconnected'].
	status = WaitingForConnection ifTrue: [^ 'waitingForConnection'].
	status = Connected ifTrue: [^ 'connected'].
	status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd'].
	status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd'].
	^ 'unknown socket status'
! !


!Socket methodsFor: 'receiving' stamp: 'gk 12/14/2005 10:02'!
discardReceivedData
	"Discard any data received up until now, and return the number of bytes discarded."

	| buf totalBytesDiscarded |
	buf _ String new: 10000.
	totalBytesDiscarded _ 0.
	[self isConnected] whileTrue: [
		totalBytesDiscarded _
			totalBytesDiscarded + (self receiveDataInto: buf)].
	^ totalBytesDiscarded
! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:52'!
receiveAvailableData
	"Receive all available data (if any). Do not wait."
 
	| buffer bytesRead |
	buffer _ String new: 2000.
	bytesRead _ self receiveAvailableDataInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'receiving' stamp: 'yo 10/10/2005 18:47'!
receiveAvailableDataIntoBuffer: buffer
	"Receive all available data (if any). Do not wait."
 
	| bytesRead |
	bytesRead _ self receiveAvailableDataInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:52'!
receiveAvailableDataInto: buffer
	"Receive all available data into the given buffer and return the number of bytes received.
	Note the given buffer may be only partially filled by the received data.
	Do not wait for data."

	^self receiveAvailableDataInto: buffer startingAt: 1! !

!Socket methodsFor: 'receiving' stamp: 'mu 8/9/2003 18:04'!
receiveAvailableDataInto: buffer startingAt: startIndex
	"Receive all available data into the given buffer and return the number of bytes received.
	Note the given buffer may be only partially filled by the received data.
	Do not wait for data."

	| bufferPos bytesRead |
	bufferPos := startIndex.
	[self dataAvailable
		and: [bufferPos-1 < buffer size]] 
		whileTrue: [
			bytesRead := self receiveSomeDataInto: buffer startingAt: bufferPos.
			bufferPos := bufferPos + bytesRead].
	^bufferPos - startIndex! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 16:05'!
receiveData
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.
	Either returns data or signals a time out or connection close."

	| buffer bytesRead |
	buffer _ String new: 2000.
	bytesRead _ self receiveDataInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 16:05'!
receiveDataInto: aStringOrByteArray
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.
	Either returns data or signals a time out or connection close."

	^self receiveDataInto: aStringOrByteArray startingAt: 1! !

!Socket methodsFor: 'receiving' stamp: 'svp 9/23/2003 00:12'!
receiveDataInto: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.  The answer may be zero (indicating that no data was 
	available before the socket closed)."

	| bytesRead closed |
	bytesRead := 0.
	closed := false.
	[closed not and: [bytesRead == 0]]
		whileTrue: [
			self waitForDataIfClosed: [closed := true].
			bytesRead := self primSocket: socketHandle
				receiveDataInto: aStringOrByteArray
				startingAt: aNumber
				count: aStringOrByteArray size-aNumber+1].
	^bytesRead
! !

!Socket methodsFor: 'receiving' stamp: 'gk 2/9/2005 12:33'!
receiveDataSignallingClosedInto: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data until something is read or the socket is closed, upon which
	we signal."

	| bytesRead |
	bytesRead := 0.
	[bytesRead == 0]
		whileTrue: [
			self waitForData.
			bytesRead := self primSocket: socketHandle
				receiveDataInto: aStringOrByteArray
				startingAt: aNumber
				count: aStringOrByteArray size-aNumber+1].
	^bytesRead
! !

!Socket methodsFor: 'receiving' stamp: 'gk 2/9/2005 12:24'!
receiveDataSignallingTimeout: timeout into: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Wait for data once for the specified nr of seconds.  This method will
	throw exceptions on timeout or the socket closing."

	self waitForDataFor: timeout.
	^self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size-aNumber+1
! !

!Socket methodsFor: 'receiving' stamp: 'svp 9/23/2003 00:03'!
receiveDataTimeout: timeout
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once."

	| buffer bytesRead |
	buffer _ String new: 2000.
	bytesRead _ self receiveDataTimeout: timeout into: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'receiving' stamp: 'svp 9/23/2003 00:01'!
receiveDataTimeout: timeout into: aStringOrByteArray 
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once."

	^self receiveDataTimeout: timeout into: aStringOrByteArray startingAt: 1! !

!Socket methodsFor: 'receiving' stamp: 'svp 9/22/2003 23:58'!
receiveDataTimeout: timeout into: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Wait for data once for the specified nr of seconds.  The answer may be 
	zero (indicating that there was no data available within the given timeout)."

	self waitForDataFor: timeout ifClosed: [] ifTimedOut: [].
	^self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size-aNumber+1
! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 16:18'!
receiveDataWithTimeout
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.
	Either returns data or signals a time out or connection close."

	| buffer bytesRead |
	buffer _ String new: 2000.
	bytesRead _ self receiveDataWithTimeoutInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 16:18'!
receiveDataWithTimeoutInto: aStringOrByteArray
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once.
	Either returns data or signals a time out or connection close."

	^self receiveDataWithTimeoutInto: aStringOrByteArray startingAt: 1! !

!Socket methodsFor: 'receiving' stamp: 'svp 9/23/2003 00:01'!
receiveDataWithTimeoutInto: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. 
	Note the given buffer may be only partially filled by the received data.
	Waits for data once."

	^self receiveDataTimeout: Socket standardTimeout into: aStringOrByteArray startingAt: aNumber 
! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:46'!
receiveSomeData
	"Receive currently available data (if any). Do not wait."
 
	| buffer bytesRead |
	buffer _ String new: 2000.
	bytesRead _ self receiveSomeDataInto: buffer.
	^buffer copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:46'!
receiveSomeDataInto: aStringOrByteArray
	"Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	^self receiveSomeDataInto: aStringOrByteArray startingAt: 1! !

!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:46'!
receiveSomeDataInto: aStringOrByteArray startingAt: aNumber
	"Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	^ self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size-aNumber+1
! !


!Socket methodsFor: 'registry' stamp: 'ar 3/21/98 17:40'!
register
	^self class register: self! !

!Socket methodsFor: 'registry' stamp: 'ar 3/21/98 17:41'!
unregister
	^self class unregister: self! !


!Socket methodsFor: 'sending' stamp: 'mir 5/15/2003 18:33'!
sendData: aStringOrByteArray
	"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent."

	"An experimental version use on slow lines: Longer timeout and smaller writes to try to avoid spurious timeouts."

	| bytesSent bytesToSend count |
	bytesToSend _ aStringOrByteArray size.
	bytesSent _ 0.
	[bytesSent < bytesToSend] whileTrue: [
		(self waitForSendDoneFor: 60)
			ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent'].
		count _ self primSocket: socketHandle
			sendData: aStringOrByteArray
			startIndex: bytesSent + 1
			count: (bytesToSend - bytesSent min: 5000).
		bytesSent _ bytesSent + count].

	^ bytesSent
! !

!Socket methodsFor: 'sending' stamp: 'ar 7/20/1999 17:23'!
sendData: buffer count: n
	"Send the amount of data from the given buffer"
	| sent |
	sent _ 0.
	[sent < n] whileTrue:[
		sent _ sent + (self sendSomeData: buffer startIndex: sent+1 count: (n-sent))].! !

!Socket methodsFor: 'sending' stamp: 'ls 1/5/1999 15:05'!
sendSomeData: aStringOrByteArray
	"Send as much of the given data as possible and answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self
		sendSomeData: aStringOrByteArray
		startIndex: 1
		count: aStringOrByteArray size! !

!Socket methodsFor: 'sending' stamp: 'ls 3/3/1999 18:59'!
sendSomeData: aStringOrByteArray startIndex: startIndex
	"Send as much of the given data as possible starting at the given index. Answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self
		sendSomeData: aStringOrByteArray
		startIndex: startIndex
		count: (aStringOrByteArray size - startIndex + 1)! !

!Socket methodsFor: 'sending' stamp: 'mir 5/15/2003 18:34'!
sendSomeData: aStringOrByteArray startIndex: startIndex count: count
	"Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	| bytesSent |
	(self waitForSendDoneFor: 20)
		ifTrue: [
			bytesSent _ self primSocket: socketHandle
				sendData: aStringOrByteArray
				startIndex: startIndex
				count: count]
		ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent'].
	^ bytesSent
! !

!Socket methodsFor: 'sending' stamp: 'mir 2/19/2002 18:33'!
sendStreamContents: stream
	"Send the data in the stream. Close the stream.
	Usefull for directly sending contents of a file without reading into memory first."

	self sendStreamContents: stream checkBlock: [true]! !

!Socket methodsFor: 'sending' stamp: 'mir 2/19/2002 18:31'!
sendStreamContents: stream checkBlock: checkBlock
	"Send the data in the stream. Close the stream after you are done. After each block of data evaluate checkBlock and abort if it returns false.
	Usefull for directly sending contents of a file without reading into memory first."

	| chunkSize buffer |
	chunkSize _ 5000.
	buffer _ ByteArray new: chunkSize.
	stream binary.
	[[stream atEnd and: [checkBlock value]]
		whileFalse: [
			buffer _ stream next: chunkSize into: buffer.
			self sendData: buffer]]
		ensure: [stream close]! !


!Socket methodsFor: 'waiting' stamp: 'mu 8/9/2003 15:17'!
waitForAcceptFor: timeout
	"Wait and accept an incoming connection. Return nil if it falis"
	[self waitForConnectionFor: timeout] on: ConnectionTimedOut do: [:ex | ^nil].
	^self isConnected
		ifTrue:[self accept]
		! !

!Socket methodsFor: 'waiting' stamp: 'svp 7/27/2003 00:23'!
waitForAcceptFor: timeout ifTimedOut: timeoutBlock
	"Wait and accept an incoming connection"
	self waitForConnectionFor: timeout ifTimedOut: [^timeoutBlock value].
	^self accept! !

!Socket methodsFor: 'waiting' stamp: 'mu 8/19/2003 02:57'!
waitForConnectionFor: timeout
	"Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not."

	^self 
		waitForConnectionFor: timeout 
		ifTimedOut: [ConnectionTimedOut signal: 'Failed to connect in ', timeout asString, ' seconds']
! !

!Socket methodsFor: 'waiting' stamp: 'gk 12/15/2005 01:09'!
waitForConnectionFor: timeout ifTimedOut: timeoutBlock
	"Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not."

	| status deadline |
	deadline := Socket deadlineSecs: timeout.
	status _ self primSocketConnectionStatus: socketHandle.
	[(status = WaitingForConnection) and: [Time millisecondClockValue < deadline]]
		whileTrue: [
			semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
			status _ self primSocketConnectionStatus: socketHandle].

	status = Connected ifFalse: [^timeoutBlock value]
! !

!Socket methodsFor: 'waiting' stamp: 'svp 9/23/2003 00:09'!
waitForData
	"Wait for data to arrive.  This method will block until
	data is available or the socket is closed.  If the socket is closed
	a ConnectionClosed exception will be signaled."

	^self waitForDataIfClosed:
		[ConnectionClosed signal: 'Connection close while waiting for data.']! !

!Socket methodsFor: 'waiting' stamp: 'svp 7/27/2003 00:18'!
waitForDataFor: timeout
	"Wait for the given nr of seconds for data to arrive.
	Signal a time out or connection close exception if either happens before data becomes available."

	^self
		waitForDataFor: timeout
		ifClosed: [ConnectionClosed signal: 'Connection closed while waiting for data.']
		ifTimedOut: [ConnectionTimedOut signal: 'Data receive timed out.']
! !

!Socket methodsFor: 'waiting' stamp: 'svp 7/27/2003 00:16'!
waitForDataFor: timeout ifClosed: closedBlock ifTimedOut: timedOutBlock
	"Wait for the given nr of seconds for data to arrive."

	| deadline |
	deadline := Socket deadlineSecs: timeout.

	[Time millisecondClockValue < deadline]
		whileTrue: [
			(self primSocketReceiveDataAvailable: socketHandle)
				ifTrue: [^self].
			self isConnected
				ifFalse: [^closedBlock value].
			self readSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)].

	(self primSocketReceiveDataAvailable: socketHandle)
		ifFalse: [
			self isConnected
				ifTrue: [^timedOutBlock value]
				ifFalse: [^closedBlock value]]! !

!Socket methodsFor: 'waiting' stamp: 'svp 9/23/2003 00:08'!
waitForDataIfClosed: closedBlock
	"Wait indefinitely for data to arrive.  This method will block until
	data is available or the socket is closed."

	[true]
		whileTrue: [
			(self primSocketReceiveDataAvailable: socketHandle)
				ifTrue: [^self].
			self isConnected
				ifFalse: [^closedBlock value].
			self readSemaphore wait].
! !

!Socket methodsFor: 'waiting' stamp: 'gk 12/14/2005 09:59'!
waitForDisconnectionFor: timeout
	"Wait for the given nr of seconds for the connection to be broken.
	Return true if it is broken by the deadline, false if not.
	The client should know the connection is really going to be closed
	(e.g., because he has called 'close' to send a close request to the other end)
	before calling this method."

	| status deadline |
	status _ self primSocketConnectionStatus: socketHandle.
	deadline := Socket deadlineSecs: timeout.
	[((status == Connected) or: [(status == ThisEndClosed)]) and:
	 [Time millisecondClockValue < deadline]] whileTrue: [
		self discardReceivedData.
		self readSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
		status _ self primSocketConnectionStatus: socketHandle].

	^ status ~= Connected
! !

!Socket methodsFor: 'waiting' stamp: 'mir 5/15/2003 18:33'!
waitForSendDoneFor: timeout
	"Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not."

	| sendDone deadline |
	deadline := Socket deadlineSecs: timeout.
	[self isConnected & (sendDone _ self primSocketSendDone: socketHandle) not
			"Connection end and final data can happen fast, so test in this order"
		and: [Time millisecondClockValue < deadline]] whileTrue: [
			self writeSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)].

	^ sendDone! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Socket class
	instanceVariableNames: ''!

!Socket class methodsFor: 'class initialization' stamp: 'ar 12/12/2001 19:12'!
initialize
	"Socket initialize"

	"Socket Types"
	TCPSocketType _ 0.
	UDPSocketType _ 1.

	"Socket Status Values"
	InvalidSocket _ -1.
	Unconnected _ 0.
	WaitingForConnection _ 1.
	Connected _ 2.
	OtherEndClosed _ 3.
	ThisEndClosed _ 4.

	RegistryThreshold _ 100. "# of sockets"! !


!Socket class methodsFor: 'instance creation' stamp: 'ls 9/24/1999 09:45'!
acceptFrom: aSocket
	^[ super new acceptFrom: aSocket ]
		repeatWithGCIf: [ :sock | sock isValid not ]! !

!Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:15'!
createIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."
	"Note: The default creates a TCP socket"
	^self tcpCreateIfFail: failBlock! !

!Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:13'!
new
	"Return a new, unconnected Socket. Note that since socket creation may fail, it is safer to use the method createIfFail: to handle such failures gracefully; this method is primarily for backward compatibility and may be disallowed in a future release."
	"Note: The default creates a TCP socket - this is also backward compatibility."
	^self newTCP! !

!Socket class methodsFor: 'instance creation' stamp: 'mir 2/22/2002 15:48'!
newTCP
	"Create a socket and initialise it for TCP"
	self initializeNetwork.
	^[ super new initialize: TCPSocketType ]
		repeatWithGCIf: [ :socket | socket isValid not ]! !

!Socket class methodsFor: 'instance creation' stamp: 'mir 2/22/2002 15:49'!
newUDP
	"Create a socket and initialise it for UDP"
	self initializeNetwork.
	^[ super new initialize: UDPSocketType ]
		repeatWithGCIf: [ :socket | socket isValid not ]! !

!Socket class methodsFor: 'instance creation' stamp: 'mir 2/22/2002 15:49'!
tcpCreateIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."

	| sock |
	self initializeNetwork.
	sock _ super new initialize: TCPSocketType.
	sock isValid ifFalse: [^ failBlock value].
	^ sock
! !

!Socket class methodsFor: 'instance creation' stamp: 'mir 2/22/2002 15:49'!
udpCreateIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."

	| sock |
	self initializeNetwork.
	sock _ super new initialize: UDPSocketType.
	sock isValid ifFalse: [^ failBlock value].
	^ sock
! !


!Socket class methodsFor: 'network initialization' stamp: 'mir 2/22/2002 15:01'!
initializeNetwork
	"Initialize the network drivers and the NetNameResolver. Do nothing if the network is already initialized."
	"Note: The network must be re-initialized every time Squeak starts up, so applications that persist across snapshots should be prepared to re-initialize the network as needed. Such applications should call 'Socket initializeNetwork' before every network transaction. "

	NetNameResolver initializeNetwork! !

!Socket class methodsFor: 'network initialization' stamp: 'mir 2/22/2002 14:59'!
primInitializeNetwork: resolverSemaIndex
	"Initialize the network drivers on platforms that need it, such as the Macintosh, and return nil if network initialization failed or the reciever if it succeeds. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed."
	"Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests."

	<primitive: 'primitiveInitializeNetwork' module: 'SocketPlugin'>
	^ nil  "return nil if primitive fails"
! !


!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'!
register: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry add: anObject! !

!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'!
registry
	WeakArray isFinalizationSupported ifFalse:[^nil].
	^Registry isNil
		ifTrue:[Registry := WeakRegistry new]
		ifFalse:[Registry].! !

!Socket class methodsFor: 'registry' stamp: 'ar 12/12/2001 19:12'!
registryThreshold
	"Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails."
	^RegistryThreshold! !

!Socket class methodsFor: 'registry' stamp: 'ar 12/12/2001 19:12'!
registryThreshold: aNumber
	"Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails."
	RegistryThreshold _ aNumber! !

!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:22'!
unregister: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry remove: anObject ifAbsent:[]! !


!Socket class methodsFor: 'utilities' stamp: 'tk 4/9/98 15:54'!
deadServer

	^ DeadServer! !

!Socket class methodsFor: 'utilities' stamp: 'tk 4/9/98 15:56'!
deadServer: aStringOrNil
	"Keep the machine name of the most recently encoutered non-responding machine.  Next time the user can move it to the last in a list of servers to try."

	DeadServer _ aStringOrNil! !

!Socket class methodsFor: 'utilities' stamp: 'mir 5/15/2003 18:28'!
deadlineSecs: secs
	"Return a deadline time the given number of seconds from now."

	^ Time millisecondClockValue + (secs * 1000) truncated
! !

!Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 12:13'!
nameForWellKnownTCPPort: portNum
	"Answer the name for the given well-known TCP port number. Answer a string containing the port number if it isn't well-known."

	| portList entry |
	portList _ #(
		(7 'echo') (9 'discard') (13 'time') (19 'characterGenerator')
		(21 'ftp') (23 'telnet') (25 'smtp')
		(80 'http') (110 'pop3') (119 'nntp')).
	entry _ portList detect: [:pair | pair first = portNum] ifNone: [^ 'port-', portNum printString].
	^ entry last
! !

!Socket class methodsFor: 'utilities' stamp: 'mir 5/15/2003 18:30'!
ping: hostName
	"Ping the given host. Useful for checking network connectivity. The host must be running a TCP echo server."
	"Socket ping: 'squeak.cs.uiuc.edu'"

	| tcpPort sock serverAddr startTime echoTime |
	tcpPort _ 7.  "7 = echo port, 13 = time port, 19 = character generator port"

	serverAddr _ NetNameResolver addressForName: hostName timeout: 10.
	serverAddr = nil ifTrue: [
		^ self inform: 'Could not find an address for ', hostName].

	sock _ Socket new.
	sock connectNonBlockingTo: serverAddr port: tcpPort.
	[sock waitForConnectionFor: 10]
		on: ConnectionTimedOut
		do: [:ex |
			(self confirm: 'Continue to wait for connection to ', hostName, '?')
				ifTrue: [ex retry]
				ifFalse: [
					sock destroy.
					^ self]].

	sock sendData: 'echo!!'.
	startTime _ Time millisecondClockValue.
	[sock waitForDataFor: 15]
		on: ConnectionTimedOut
		do: [:ex | (self confirm: 'Packet sent but no echo yet; keep waiting?')
			ifTrue: [ex retry]].
	echoTime _ Time millisecondClockValue - startTime.

	sock destroy.
	self inform: hostName, ' responded in ', echoTime printString, ' milliseconds'.
! !

!Socket class methodsFor: 'utilities' stamp: 'mir 2/22/2002 15:49'!
pingPorts: portList on: hostName timeOutSecs: timeOutSecs
	"Attempt to connect to each of the given sockets on the given host. Wait at most timeOutSecs for the connections to be established. Answer an array of strings indicating the available ports."
	"Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: 'squeak.cs.uiuc.edu' timeOutSecs: 15"

	| serverAddr sockets sock deadline done unconnectedCount connectedCount waitingCount result |
	serverAddr _ NetNameResolver addressForName: hostName timeout: 10.
	serverAddr = nil ifTrue: [
		self inform: 'Could not find an address for ', hostName.
		^ #()].

	sockets _ portList collect: [:portNum |
		sock _ Socket new.
		sock connectTo: serverAddr port: portNum].

	deadline _ self deadlineSecs: timeOutSecs.
	done _ false.
	[done] whileFalse: [
		unconnectedCount _ 0.
		connectedCount _ 0.
		waitingCount _ 0.
		sockets do: [:s |
			s isUnconnectedOrInvalid
				ifTrue: [unconnectedCount _ unconnectedCount + 1]
				ifFalse: [
					s isConnected ifTrue: [connectedCount _ connectedCount + 1].
					s isWaitingForConnection ifTrue: [waitingCount _ waitingCount + 1]]].
		waitingCount = 0 ifTrue: [done _ true].
		connectedCount = sockets size ifTrue: [done _ true].
		Time millisecondClockValue > deadline ifTrue: [done _ true]].

	result _ (sockets select: [:s | s isConnected])
		collect: [:s | self nameForWellKnownTCPPort: s remotePort].
	sockets do: [:s | s destroy].
	^ result
! !

!Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 17:25'!
pingPortsOn: hostName
	"Attempt to connect to a set of well-known sockets on the given host, and answer the names of the available ports."
	"Socket pingPortsOn: 'www.disney.com'"

	^ Socket
		pingPorts: #(7 13 19 21 23 25 80 110 119)
		on: hostName
		timeOutSecs: 20
! !

!Socket class methodsFor: 'utilities' stamp: 'mir 5/15/2003 16:17'!
standardDeadline
	"Return a default deadline time some seconds into the future."

	^ self deadlineSecs: self standardTimeout
! !

!Socket class methodsFor: 'utilities' stamp: 'mir 5/15/2003 16:16'!
standardTimeout

	^45
! !

!Socket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'!
wildcardAddress
	"Answer a don't-care address for use with UDP sockets."

	^ByteArray new: 4		"0.0.0.0"! !

!Socket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'!
wildcardPort
	"Answer a don't-care port for use with UDP sockets.  (The system will allocate an
	unused port number to the socket.)"

	^0! !


!Socket class methodsFor: 'tests' stamp: 'gk 12/15/2005 01:18'!
loopbackTest
	"Send data from one socket to another on the local machine.
	Tests most of the socket primitives."

	"100 timesRepeat: [Socket loopbackTest]"

	| sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived t extraBytes packetsSent packetsRead |
	Transcript
		cr;
		show: 'starting loopback test';
		cr.
	Transcript
		show: '---------- Connecting ----------';
		cr.
	self initializeNetwork.
	sock1 := self new.
	sock2 := self new.
	sock1 listenOn: 54321.
	sock2 connectTo: NetNameResolver localHostAddress port: 54321.
	sock1 waitForConnectionFor: self standardTimeout.
	sock2 waitForConnectionFor: self standardTimeout.
	sock1 isConnected ifFalse: [self error: 'sock1 not connected'].
	sock2 isConnected ifFalse: [self error: 'sock2 not connected'].
	Transcript
		show: 'connection established';
		cr.
	bytesToSend := 5000000.
	sendBuf := String new: 5000 withAll: $x.
	receiveBuf := String new: 50000.
	done := false.
	packetsSent := packetsRead := bytesSent := bytesReceived := 0.
	t := Time millisecondsToRun: 
					[[done] whileFalse: 
							[(sock1 sendDone and: [bytesSent < bytesToSend]) 
								ifTrue: 
									[packetsSent := packetsSent + 1.
									bytesSent := bytesSent + (sock1 sendSomeData: sendBuf)].
							sock2 dataAvailable 
								ifTrue: 
									[packetsRead := packetsRead + 1.
									bytesReceived := bytesReceived + (sock2 receiveDataInto: receiveBuf)].
							done := bytesSent >= bytesToSend and: [bytesReceived = bytesSent]]].
	Transcript
		show: 'closing connection';
		cr.
	sock1 waitForSendDoneFor: self standardTimeout.
	sock1 close.
	sock2 waitForDisconnectionFor: self standardTimeout.
	extraBytes := sock2 discardReceivedData.
	extraBytes > 0 
		ifTrue: 
			[Transcript
				show: ' *** received ' , extraBytes size printString , ' extra bytes ***';
				cr].
	sock2 close.
	sock1 waitForDisconnectionFor: self standardTimeout.
	sock1 isUnconnectedOrInvalid ifFalse: [self error: 'sock1 not closed'].
	sock2 isUnconnectedOrInvalid ifFalse: [self error: 'sock2 not closed'].
	Transcript
		show: '---------- Connection Closed ----------';
		cr.
	sock1 destroy.
	sock2 destroy.
	Transcript
		show: 'loopback test done; time = ' , t printString;
		cr.
	Transcript
		show: (bytesToSend asFloat / t roundTo: 0.01) printString 
					, '* 1000 bytes/sec';
		cr.
	Transcript endEntry! !

!Socket class methodsFor: 'tests' stamp: 'gk 12/15/2005 01:03'!
newAcceptCheck
	"Check if the platform has support for the BSD style accept()."

	"Socket newAcceptCheck"
	
	| socket |
	self initializeNetwork.
	socket _ self newTCP.
	socket listenOn: 44444 backlogSize: 4.
	socket isValid ifTrue: [
		self inform: 'Everything looks OK for the BSD style accept()'
	] ifFalse: [
		self inform: 'It appears that you DO NOT have support for the BSD style accept()'].
	socket destroy! !

!Socket class methodsFor: 'tests' stamp: 'gk 12/15/2005 01:10'!
sendTest
	"Send data to the 'discard' socket of the given host.
	Tests the speed of one-way data transfers across the
	network to the given host. Note that most hosts
	do not run a discard server."

	"Socket sendTest"

	| sock bytesToSend sendBuf bytesSent t serverName serverAddr |
	Transcript cr; show: 'starting send test'; cr.
	self initializeNetwork.
	serverName := UIManager default request: 'What is the destination server?' initialAnswer: 'create.ucsb.edu'.
	serverAddr := NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil 
		ifTrue: [^self inform: 'Could not find an address for ' , serverName].
	sock := self new.
	Transcript show: '---------- Connecting ----------';cr.
	sock connectTo: serverAddr port: 9.
	sock isConnected ifFalse: [
		sock destroy.
		^self inform: 'could not connect'].
	Transcript show: 'connection established; sending data'; cr.
	bytesToSend := 1000000.
	sendBuf := String new: 64 * 1024 withAll: $x.
	bytesSent := 0.
	t := Time millisecondsToRun: 
					[[bytesSent < bytesToSend] whileTrue: 
							[sock sendDone 
								ifTrue: [bytesSent := bytesSent + (sock sendSomeData: sendBuf)]]].
	sock waitForSendDoneFor: self standardTimeout.
	sock destroy.
	Transcript show: '---------- Connection Closed ----------'; cr;
		show: 'send test done; time = ' , t printString; cr;
		show: (bytesToSend asFloat / t roundTo: 0.01) printString, ' * 1000 bytes/sec';cr;endEntry! !
Object subclass: #SocketStream
	instanceVariableNames: 'recentlyRead socket inBuffer outBuffer inNextToWrite outNextToWrite lastRead timeout autoFlush bufferSize binary shouldSignal'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!SocketStream commentStamp: 'md 7/14/2006 16:32' prior: 0!
SocketStream is a wrapper for class Socket making it easy to write networking code by giving the programmer a stream-like protocol. A Socket is a two way communication link with two logically separate channels - input and output. The Socket class is the lowest level in Squeak for network communication and using it directly can be difficult and bug prone.

A SocketStream can be in binary or ascii mode, ascii is the default which means you are transmitting and receiving Strings. Most Internet protocols are in clear text ascii, like for example HTTP. Another setting is what timeout you want to use - default is the standardTimeout from Socket. More settings can be found in the method category 'configuration'.

Simplest example of connecting, sending/receiving and closing:

| stream result |
stream := SocketStream openConnectionToHostNamed: 'www.squeak.org' port: 80.
[[stream nextPutAll: 'GET / HTTP/1.0'; crlf; crlf; flush.
result := stream upToEnd. "Give us all data until the socket is closed."
Transcript show: result; cr.]
	ensure: [stream close]]
		on: ConnectionTimedOut
		do: [:ex | Transcript show: ex asString;cr. ex resume]

There are two important things to note above:
	- The methods in category "stream in" can signal two exceptions (unless turned off with #shouldSignal:):
		ConnectionClosed and ConnectionTimedOut
	- We close the stream using #ensure:, that is to make sure it isn't left opened.
	- We use #on:do: to catch any signal. In this case we do not need to catch ConnectionClosed since #upToEnd does that for us intrinsically.

----------------
SocketStream (below called SS) is a reimplementation of 'Old'-SocketStream (below called OSS) - the class that originates from the original Comanche implementation but now is included in standard Squeak. SS has the same protocol as OSS and is meant to replace it. SS is faster, more flexible, is better documented and adds a few features:

1. #shouldSignal:, which decides if SS should signal low level Socket exceptions (true) or if it should swallow them like original OSS did. Default is true. The only reason I added this is for backwards compatibility - not signalling causes problems - see bug 4 below.

2. #nextAllInBuffer, #nextInBuffer:, #skip:, #receiveData:, #nextPutAllFlush: and #recentlyRead are new additions to the public protocol.


It also fixes various bugs:

1. #isDataAvailable could theoretically answer false, when there actually is some in the buffer in OSS. If #receiveDataIfAvailable reads the last byte then the following "socket dataAvailable" would answer false. So the last byte would be sitting in the inStream missed.

2. #upToAll: in OSS has several problems, for example - #positionOfSubCollection:ifAbsent: which was introduced answers one position too low. This was compensated in upToAll:, but only in the pushBack: call, not the actual result being returned which was cut short 1 byte. Amusingly this makes KomHttpServer not use "Keep-Alive" since the last $e in 'Alive' was cut short. :)

3. SS doesn't inherit from PositionableStream since that just breaks various inherited messages, like for example #skip:. OSS should IMHO be changed to inherit from Object - or of course, replaced in full with SS. :)

4. Since SocketStream by default signals closes and timeouts the SocketStreamTest now passes. The reason for SocketStream to fail is that while it does timeout on a low level (#SocketStream>>receiveData doesn't hang forever) - the callers of #receiveData sometimes loop - like in #next:, and thus eliminates the timeout. SS warns about some methods (in their method comments) not honouring timeouts if shouldSignal is false, I really don't know what they should do in that case:
	#next:, #upTo:, #upToAll: and #upToEnd (and #receiveData:)


The primary reason for the SS implementation is optimal performance. The main differences in implementation with the old OSS are:

1. SS uses two buffers directly (inBuffer and outBuffer) with pointers marking start and stop within the buffer. OSS instead uses two regular streams, a ReadStream and a WriteStream. Using internal buffers makes it possible to avoid copying and reallocation in various ways, it also makes SS be able to have specialized growing/buffer moving behaviour.

2. #upTo:, #upToAll: and #peekForAll: uses selectged String messages that in turn uses fast primitives for searching. OSS used other messages that fell back on byte per byte reading.

3. #receiveData in OSS creates a temporary buffer stream for each call!! During a long read operation, like say #upToAll: (which for example is used when uploading files using HTTP POST forms), this is devastating - especially since the default size is only 2000 bytes - and leads to a very high number of low level read operations on the Socket, typically 100 times more calls than with OSS. The buffer in OSS is held in an instvar (not recreated for each call), is larger from the start and above all - grows dynamically by doubling. OSS can also avoid a grow/reallocation by doing a "move down" if data has been read from the SS as it comes in and through that making room in the lower part of the inBuffer. The net result is that upToAll: for large files is about 10 times faster.

4. The implementation of upTo: and upToAll: tries to avoid doing unnecessary find operations in the buffer and is greedy by default, which means it favors reading more data - if available - before searching for the stop sequence. If we had #findString:startingAt:stoppingAt: this wouldn't have to be greedy and we wouldn't be needlessly scanning dead buffer area. VM hackers? Also, while you are at it - make it work for ByteArrays too. :)


SS can not be run unbuffered, since that seems unneeded. The option to autoFlush is still available, with it set to true SocketStream (just like OSS) will flush on its own on each nextPut:/nextPutAll:, otherwise flushing it will have to be done manually but is done on close.

The first performance tests shows that, as noted above, receiving large amounts of data using #upToAll: is greatly improved - factor of 10. Serving HTTP with small payloads seemed at first not be faster at all - but this is due to the high overhead of Socket connect/close and other things. Increasing payloads show a difference and especially with keep alive on - where the new SS roughly doubles the throughput!!!


!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:37'!
ascii
	"Tell the SocketStream to send data
	as Strings instead of ByteArrays.
	This is default."

	binary := false.
	self resetBuffers! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:26'!
autoFlush
	"If autoFlush is enabled data will be sent through
	the socket (flushed) when the bufferSize is reached
	or the SocketStream is closed. Otherwise the user
	will have to send #flush manually.
	Close will always flush. Default is false."

	^autoFlush! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:27'!
autoFlush: aBoolean
	"If autoFlush is enabled data will be sent through
	the socket (flushed) when the bufferSize is reached
	or the SocketStream is closed. Otherwise the user
	will have to send #flush manually.
	Close will always flush. Default is false."

	autoFlush := aBoolean! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:37'!
binary
	"Tell the SocketStream to send data
	as ByteArrays instead of Strings.
	Default is ascii."

	binary := true.
	self resetBuffers! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:28'!
bufferSize
	"Default buffer size is 4kb.
	increased from earlier 2000 bytes."
	
	^bufferSize! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:28'!
bufferSize: anInt
	"Default buffer size is 4kb.
	increased from earlier 2000 bytes."

	bufferSize := anInt! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 17:58'!
inBufferSize
	"Answers the current size of data in the inBuffer."

	^inNextToWrite - lastRead - 1! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 17:59'!
noTimeout
	"Do not use timeout."

	timeout := 0! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 17:59'!
outBufferSize
	"Answers the current size of data in the outBuffer."

	^outNextToWrite - 1! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 18:00'!
shouldSignal
	"If shouldSignal is enabled the Socket Exceptions
	ConnectionClosed and ConnectionTimedOut
	will not be swallowed. Default is true.
	For more info, see #shouldSignal:"

	^shouldSignal! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 18:03'!
shouldSignal: aBoolean
	"If shouldSignal is enabled the Socket Exceptions
	ConnectionClosed and ConnectionTimedOut will not be swallowed.
	Default is true. And please - don't set it to false - it is better to
	use an exception handler (see below)  and several methods
	in this class will not honour timeouts (says so in their method comments).
	Also, it is quite hard to understand what for example #upToEnd
	should return to indicate a timeout.
	
	Wrap your use of SocketStream with a handler like:
	
	[stuff _ mySocketStream next: 10]
		on: ConnectionClosed, ConnectionTimedOut
		do: [:ex |
			Transcript show: 'Oops!! Did not get my ten bytes!!;cr]
	"

	shouldSignal := aBoolean! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/3/2005 20:35'!
socket
	^socket! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/3/2005 20:35'!
socket: aSocket
	socket _ aSocket! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/7/2005 08:41'!
timeout
	"Lazily initialized unless it has been set explicitly."

	timeout ifNil: [timeout := Socket standardTimeout].
	^timeout! !

!SocketStream methodsFor: 'configuration' stamp: 'gk 2/3/2005 20:35'!
timeout: seconds
	timeout := seconds! !


!SocketStream methodsFor: 'control' stamp: 'gk 2/24/2005 11:55'!
close
	"Flush any data still not sent
	and take care of the socket."

	self flush.
	socket closeAndDestroy: 30! !

!SocketStream methodsFor: 'control' stamp: 'gk 9/9/2005 09:33'!
flush
	"If the other end is connected and we have something
	to send, then we send it and reset the outBuffer."

	((outNextToWrite > 1) and: [socket isOtherEndClosed not])
		ifTrue: [
			[socket sendData: outBuffer count: outNextToWrite - 1]
				on: ConnectionTimedOut
				do: [:ex | shouldSignal ifFalse: ["swallow"]].
			outNextToWrite _ 1]! !

!SocketStream methodsFor: 'control' stamp: 'gk 4/14/2005 09:49'!
receiveData: nBytes
	"Keep reading the socket until we have nBytes
	in the inBuffer or we reach the end. This method
	does not return data, but can be used to make sure
	data has been read into the buffer from the Socket
	before actually reading it from the FastSocketStream.
	Mainly used internally. We could also adjust the buffer
	to the expected amount of data and avoiding several
	incremental grow operations.

	NOTE: This method doesn't honor timeouts if shouldSignal
	is false!! And frankly, I am not sure how to handle that
	case or if I care - I think we should always signal."

	[self atEnd not and: [nBytes > self inBufferSize]]
		whileTrue: [self receiveData]! !

!SocketStream methodsFor: 'control' stamp: 'gk 2/9/2005 23:08'!
recentlyRead
	"Return the number of bytes read
	during the last socket operation."
	
	^recentlyRead! !


!SocketStream methodsFor: 'initialize-release' stamp: 'gk 2/25/2005 14:20'!
initialize
	autoFlush _ true.
	shouldSignal _ true.
	recentlyRead _ 0.
	bufferSize _ 4096.
	self ascii! !


!SocketStream methodsFor: 'printing' stamp: 'gk 2/25/2005 14:19'!
debug
	"Display debug info."

	| data |
	data _ self inBufferSize.
	^String streamContents: [:s |
		s
			nextPutAll: 'Buffer size: ', inBuffer size asString;cr;
			nextPutAll: 'InBuffer data size: ', data asString; cr;
			nextPutAll: 'In data (20):', (inBuffer copyFrom: lastRead + 1 to: lastRead + (data min: 20)); cr;
			nextPutAll: 'OutBuffer data size: ', (outNextToWrite - 1) asString; cr;
			nextPutAll: 'Out data (20):', (outBuffer copyFrom: 1 to: ((outNextToWrite - 1) min: 20)); cr]! !

!SocketStream methodsFor: 'printing' stamp: 'md 7/14/2006 12:28'!
print: anObject
	anObject printOn: self! !

!SocketStream methodsFor: 'printing' stamp: 'gk 2/10/2005 11:44'!
printOn: aStream
	"Display buffer sizes."

	aStream nextPutAll: self class name.
	inBuffer ifNotNil: [
		aStream nextPutAll: '[inbuf:',
		(inBuffer size / 1024) rounded asString, 'kb/outbuf:',
		(outBuffer size / 1024) rounded asString, 'kb]']! !


!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 13:33'!
next
	"Return next byte, if inBuffer is empty
	we recieve some more data and try again."

	self atEnd ifTrue: [^nil].
	self isInBufferEmpty ifTrue:
		[self receiveData.
		self atEnd ifTrue: [^nil]].
	lastRead _ lastRead + 1.
	^inBuffer at: lastRead! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 21:26'!
nextAllInBuffer
	"Return all data currently in the inBuffer,"

	^self nextInBuffer: inNextToWrite - lastRead - 1! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 12:51'!
nextInBuffer: anInteger
	"Answer anInteger bytes of data at most,
	but only from the inBuffer."

	| start amount |
	amount _ anInteger min: (inNextToWrite - lastRead - 1).
	start _ lastRead + 1.
	lastRead _ lastRead + amount.
	^inBuffer copyFrom: start to: lastRead! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:17'!
next: anInteger
	"Answer anInteger bytes of data.

	NOTE: This method doesn't honor timeouts if shouldSignal is false!!"

	| start |
	self receiveData: anInteger.
	start _ lastRead + 1.
	lastRead _ (lastRead + anInteger) min: inNextToWrite - 1.
	^inBuffer copyFrom: start to: lastRead! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 13:47'!
nextAvailable
	"Answer all the data currently available,
	in buffer or in socket."

	self isInBufferEmpty ifFalse: [^self nextAllInBuffer].
	self isDataAvailable ifTrue: [self receiveData].
	^self nextAllInBuffer! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 13:02'!
nextAvailable: howMany
	"Answer all the data currently available,
	in buffer or in socket - but limited to <howMany>."

	self isInBufferEmpty ifFalse: [^self nextInBuffer: howMany].
	self isDataAvailable ifTrue: [self receiveData].
	^self nextInBuffer: howMany! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/3/2005 20:35'!
nextLine
	^self nextLineCrLf! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/24/2005 12:01'!
nextLineCrLf
	^self upToAll: String crlf! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:16'!
nextLineLf
	| nextLine |
	nextLine := self upToAll: String lf.
	^nextLine! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:09'!
peek
	"Return next byte, if inBuffer is empty
	we recieve some more data and try again.
	Do not consume the byte."

	self atEnd ifTrue: [^nil].
	self isInBufferEmpty ifTrue:
		[self receiveData.
		self atEnd ifTrue: [^nil]].
	^inBuffer at: lastRead! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 14:04'!
peekFor: aCharacterOrByte
	"Read and return next character or byte
	if it is equal to the argument.
	Otherwise return false."

	| nextObject |
	self atEnd ifTrue: [^false].
	self isInBufferEmpty ifTrue: 
		[self receiveData.
		self atEnd ifTrue: [^false]].
	nextObject _ inBuffer at: lastRead.
	nextObject = aCharacterOrByte ifTrue: [
		lastRead _ lastRead + 1.
		^true].
	^false
! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:16'!
peekForAll: aString
	"Answer whether or not the next string of characters in the receiver
	matches aString. If a match is made, advance over that string in the receiver and
	answer true. If no match, then leave the receiver alone and answer false.
	We use findString:startingAt: to avoid copying.

	NOTE: This method doesn't honor timeouts if shouldSignal is false!!"

	| sz start |
	sz _ aString size.
	self receiveData: sz.
	(inNextToWrite - lastRead - 1) < sz ifTrue: [^false].
	start _ lastRead + 1.
	(inBuffer findString: aString startingAt: start) = start
		ifFalse: [^false].
	lastRead _ lastRead + sz.
	^true! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:16'!
peek: anInteger
	"Answer anInteger bytes of data.
	Do not consume data.

	NOTE: This method doesn't honor timeouts if shouldSignal is false!!"

	| start |
	self receiveData: anInteger.
	start _ lastRead + 1.
	^inBuffer copyFrom: start to: ((lastRead + anInteger) min: inNextToWrite - 1).! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:15'!
skip: anInteger
	"Skip a number of bytes.
	This is faster than #next: since it does not
	have to copy and return a new String or ByteArray.

	NOTE: This method doesn't honor timeouts if shouldSignal is false!!"

	self receiveData: anInteger.
	lastRead _ (lastRead + anInteger) min: inNextToWrite - 1! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 9/9/2005 02:57'!
upTo: aCharacterOrByte
	"Return data up to, but not including given character or byte.
	
	NOTE: Does not honour timeouts if shouldSignal is false!!
	
	This method looks a bit complicated, and this is mainly because there is no fast search method
	in String that takes a stoppingAt: argument. This means we need to ignore getting hits in the
	dead buffer area above inNextToWrite.
	Another measure is that this implementation is greedy and will load data into the buffer
	until there is nothing more available, or it has loaded 100kb - and not until then we search the buffer.

	A totally non greedy variant would search on every loop."

	| index result lastRecentlyRead searchedSoFar |
	searchedSoFar _ 0.
	lastRecentlyRead _ 0.
	index _ 0.
	[self atEnd not and: [
		((lastRecentlyRead = 0 and: [self isInBufferEmpty not]) or: [self inBufferSize > 100000]) ifTrue: [
			"Data begins at lastRead + 1, we add searchedSoFar as offset."
			index _ inBuffer indexOf: aCharacterOrByte startingAt: lastRead + searchedSoFar + 1.
			searchedSoFar _ self inBufferSize.
			(index > 0 and: [(index + 1) > inNextToWrite]) ifTrue: [
				"Oops, hit in dead buffer area.
				This is probably due to old data, so we ignore it.
				No point in cleaning the dead area to avoid hits - it will still search it."
				index _ 0]].
		index = 0]]
				whileTrue: [
					recentlyRead = 0
						ifTrue: ["blocking call for now, we don't want to poll"
							self receiveData]
						ifFalse: [
							self receiveAvailableData].
					lastRecentlyRead _ recentlyRead].
	index > 0
		ifTrue: ["found it"
			result _ self nextInBuffer: index - lastRead - 1.
			self skip: 1.
			^ result]
		ifFalse: ["atEnd"
			^ self nextAllInBuffer]! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 9/9/2005 02:55'!
upToAll: aStringOrByteArray
	"Answer a subcollection from the current access position to the occurrence (if any, but not
	inclusive) of aStringOrByteArray. If aCollection is not in the stream, answer the entire rest of
	the stream.
	
	NOTE: Does not honour timeouts if shouldSignal is false!!
	
	This method looks a bit complicated, and this is mainly because there is no fast search method
	in String that takes a stoppingAt: argument. This means we need to ignore getting hits in the
	dead buffer area above inNextToWrite.
	Another measure is that this implementation is greedy and will load data into the buffer
	until there is nothing more available, or it has loaded 100kb - and not until then we search the buffer.

	A totally non greedy variant would search on every loop."

	| index sz result lastRecentlyRead searchedSoFar |
	sz _ aStringOrByteArray size.
	searchedSoFar _ 0.
	lastRecentlyRead _ 0.
	index _ 0.
	[self atEnd not and: [
		((lastRecentlyRead = 0 and: [self isInBufferEmpty not]) or: [self inBufferSize > 100000]) ifTrue: [
			"Data begins at lastRead + 1, we add searchedSoFar as offset and backs up sz - 1
			so that we can catch any borderline hits."
			index _ inBuffer indexOfSubCollection: aStringOrByteArray
						startingAt: lastRead + searchedSoFar - sz + 2.
			searchedSoFar _ self inBufferSize.
			(index > 0 and: [(index + sz) > inNextToWrite]) ifTrue: [
				"Oops, hit partially or completely in dead buffer area.
				This is probably due to old data, so we ignore it.
				No point in cleaning the dead area to avoid hits - it will still search it."
				index _ 0]].
		index = 0]]
				whileTrue: [
					recentlyRead = 0
						ifTrue: ["blocking call for now, we don't want to poll"
							self receiveData]
						ifFalse: [
							self receiveAvailableData].
					lastRecentlyRead _ recentlyRead].
	index > 0
		ifTrue: ["found it"
			result _ self nextInBuffer: index - lastRead - 1.
			self skip: sz.
			^ result]
		ifFalse: ["atEnd"
			^ self nextAllInBuffer]! !

!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:14'!
upToEnd
	"Answer all data coming in on the socket until the socket
	is closed by the other end, or we get a timeout.
	This means this method catches ConnectionClosed by itself.
	
	NOTE: Does not honour timeouts if shouldSignal is false!!"

	[[self atEnd] whileFalse: [self receiveData]]
		on: ConnectionClosed
		do: [:ex | "swallow it"]. 
	^self nextAllInBuffer! !


!SocketStream methodsFor: 'stream out' stamp: 'gk 2/3/2005 20:35'!
cr
	self nextPutAll: String cr! !

!SocketStream methodsFor: 'stream out' stamp: 'gk 2/3/2005 20:35'!
crlf
	self nextPutAll: String crlf! !

!SocketStream methodsFor: 'stream out' stamp: 'gk 2/10/2005 11:14'!
nextPutAllFlush: aCollection
	"Put a String or a ByteArray onto the stream.
	You can use this if you have very large data - it avoids
	copying into the buffer (and avoids buffer growing)
	and also flushes any other pending data first."

	| toPut |
	toPut _ binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString].
	self flush. "first flush pending stuff, then directly send"
	socket isOtherEndClosed ifFalse: [
		[socket sendData: toPut count: toPut size]
			on: ConnectionTimedOut
			do: [:ex | shouldSignal ifFalse: ["swallow"]]]! !

!SocketStream methodsFor: 'stream out' stamp: 'md 2/24/2006 19:51'!
nextPut: char
	"Put a single Character or byte onto the stream."

	| toPut |
	toPut _ binary ifTrue: [char asInteger] ifFalse: [char asCharacter].
	self adjustOutBuffer: 1.
	outBuffer at: outNextToWrite put: toPut.
	outNextToWrite _ outNextToWrite + 1.
	self checkFlush.
	"return the argument - added by kwl"
	^ char! !

!SocketStream methodsFor: 'stream out' stamp: 'gk 2/7/2005 22:51'!
nextPutAll: aCollection
	"Put a String or a ByteArray onto the stream.
	Currently a large collection will allocate a large buffer."

	| toPut |
	toPut _ binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString].
	self adjustOutBuffer: toPut size.
	outBuffer replaceFrom: outNextToWrite to: outNextToWrite + toPut size - 1 with: toPut startingAt: 1.
	outNextToWrite _ outNextToWrite + toPut size.
	self checkFlush! !

!SocketStream methodsFor: 'stream out' stamp: 'gk 9/9/2005 09:32'!
sendCommand: aString
	"Sends a String ending it with CR LF and then flush
	causing it to block until sent."

	self nextPutAll: aString, String crlf; flush! !

!SocketStream methodsFor: 'stream out' stamp: 'gk 2/3/2005 20:35'!
space
	self nextPut: Character space! !


!SocketStream methodsFor: 'testing' stamp: 'gk 2/25/2005 14:23'!
atEnd
	"There is nothing more to read when
	there is no more data in our inBuffer, the socket
	is disconnected and there is none available on the socket.
	Note that we need to check isConnected before isDataAvailable,
	otherwise data may sneak in in the meantime. But we check the
	buffer first, because it is faster."

	self isInBufferEmpty ifFalse: [^false].
	^self isConnected not
		and: [self isDataAvailable not]! !

!SocketStream methodsFor: 'testing' stamp: 'gk 2/3/2005 20:35'!
isBinary
	^binary! !

!SocketStream methodsFor: 'testing' stamp: 'gk 2/7/2005 12:24'!
isConnected
	"The stream is connected if the socket is."

	^socket isConnected! !

!SocketStream methodsFor: 'testing' stamp: 'gk 2/24/2005 12:23'!
isDataAvailable
	"It the inbuffer is empty, we check the socket for data.
	If it claims to have data available to read, we try to read
	some once and recursively call this method again.
	If something really was available it is now in the inBuffer.
	This is because there has been spurious
	dataAvailable when there really is no data to get."
 
	self isInBufferEmpty ifFalse: [^true].
	^socket dataAvailable
		ifFalse: [false]
		ifTrue: [self receiveDataIfAvailable; isDataAvailable]! !

!SocketStream methodsFor: 'testing' stamp: 'gk 2/7/2005 13:02'!
isEmpty
	"Test if there are more data to read."

	^self isInBufferEmpty and: [self isDataAvailable not]! !

!SocketStream methodsFor: 'testing' stamp: 'gk 2/7/2005 13:02'!
isInBufferEmpty
	"Any data in the buffer?"
 
	^lastRead + 1 = inNextToWrite! !

!SocketStream methodsFor: 'testing' stamp: 'gk 2/7/2005 08:59'!
isOtherEndConnected
	^socket isOtherEndClosed not! !

!SocketStream methodsFor: 'testing' stamp: 'gk 2/3/2005 20:35'!
shouldTimeout
	^self timeout > 0! !


!SocketStream methodsFor: 'private' stamp: 'gk 2/9/2005 22:44'!
adjustInBuffer: bytesRead
	"Adjust markers and possibly grow inBuffer or move data down.
	Currently grows through doubling when less than 1024 bytes are left.
	Never shrinks. Returns the position in the buffer where any new
	data can be found."

	| old |
	bytesRead = 0 ifTrue: [^inNextToWrite].
	old _ inNextToWrite.
	inNextToWrite _ inNextToWrite + bytesRead.
	(inBuffer size - inNextToWrite) < 1024
		ifTrue: [
			"Hit the roof, move data down (if enough has been read) or do we grow?"
			(lastRead > 512)
				ifTrue: [^old - self moveInBufferDown]
				ifFalse: [self growInBuffer]].
	^old! !

!SocketStream methodsFor: 'private' stamp: 'gk 2/9/2005 22:42'!
adjustOutBuffer: bytesToWrite
	"Possibly grow outBuffer to accommodate the new data.
	Currently grows through doubling when less
	than 1024 bytes are left. If bytesToWrite is even
	larger we double that instead. Never shrinks."

	(outBuffer size - outNextToWrite - bytesToWrite) < 1024 ifTrue: [
		outBuffer _ (self streamBuffer: ((outBuffer size max: bytesToWrite) * 2))
						replaceFrom: 1 to: outBuffer size with: outBuffer startingAt: 1]! !

!SocketStream methodsFor: 'private' stamp: 'gk 2/7/2005 13:09'!
checkFlush
	"If autoFlush is true we flush if
	we have reached the bufferSize
	of data in the outBuffer."

	(autoFlush and: [outNextToWrite > bufferSize])
		ifTrue: [self flush]! !

!SocketStream methodsFor: 'private' stamp: 'gk 2/7/2005 23:05'!
growInBuffer
	"Grows through doubling."

	self resizeInBuffer: inBuffer size * 2! !

!SocketStream methodsFor: 'private' stamp: 'gk 2/8/2005 22:15'!
moveInBufferDown
	"Move down contents of inBuffer to the start.
	Return distance moved."

	| sz distanceMoved |
	sz _ inNextToWrite - lastRead - 1.
	inBuffer replaceFrom: 1 to: sz with: inBuffer startingAt: lastRead + 1.
	distanceMoved _ lastRead.
	lastRead _ 0.
	inNextToWrite _ sz + 1.
	^distanceMoved
! !

!SocketStream methodsFor: 'private' stamp: 'gk 2/9/2005 22:36'!
resetBuffers
	"Recreate the buffers with default start sizes."

	inBuffer _ self streamBuffer: bufferSize.
	lastRead _ 0.
	inNextToWrite _ 1.
	outBuffer _ self streamBuffer: bufferSize.
	outNextToWrite _ 1! !

!SocketStream methodsFor: 'private' stamp: 'gk 9/9/2005 02:29'!
resizeInBuffer: newSize
	"Resize the inBuffer by recreating it.
	This also has the effect of getting rid of
	dead data above inNextToWrite.
	<newSize> must >= inBuffer size!!"

	inBuffer _ (self streamBuffer: newSize)
					replaceFrom: 1 to: inNextToWrite - 1 with: inBuffer startingAt: 1! !

!SocketStream methodsFor: 'private' stamp: 'gk 2/9/2005 22:35'!
streamBuffer: size
	"Create a buffer of the correct class and given size."

	^(self isBinary
		ifTrue: [ByteArray]
		ifFalse: [String]) new: size! !


!SocketStream methodsFor: 'private-socket' stamp: 'gk 2/25/2005 14:20'!
receiveAvailableData
	"Receive available data (as much as fits in the inBuffer)
	but not waiting for more to arrive.
	Return the position in the buffer where the
	new data starts, regardless if anything
	was read, see #adjustInBuffer."
	
	recentlyRead _ socket receiveAvailableDataInto: inBuffer startingAt: inNextToWrite.
	^self adjustInBuffer: recentlyRead! !

!SocketStream methodsFor: 'private-socket' stamp: 'gk 2/25/2005 14:20'!
receiveData
	"Receive data with timeout if it has been set.
	If shouldSignal is false we use the Socket methods
	that swallow those Exceptions, if it is true the
	caller will have to handle those Exceptions.
	Return the position in the buffer where the
	new data starts, regardless if anything
	was read, see #adjustInBuffer."
	
	recentlyRead := shouldSignal ifTrue: [
		self shouldTimeout ifTrue: [
				socket receiveDataSignallingTimeout: timeout
					into: inBuffer startingAt: inNextToWrite]
			ifFalse: [
				socket receiveDataSignallingClosedInto: inBuffer
					startingAt: inNextToWrite]]
				ifFalse: [
		self shouldTimeout ifTrue: [
			"This case is tricky, if it times out and is swallowed
			how does other methods calling this method repeatedly
			get to know that? And what should they do?"
				socket receiveDataTimeout: timeout
					into: inBuffer startingAt: inNextToWrite]
			ifFalse: [
				socket receiveDataInto: inBuffer
					startingAt: inNextToWrite]].
	^self adjustInBuffer: recentlyRead! !

!SocketStream methodsFor: 'private-socket' stamp: 'gk 2/9/2005 22:53'!
receiveDataIfAvailable
	"Only used to check that there really is data to read
	from the socket after it signals dataAvailable.
	It has been known to signal true and then still
	not have anything to read. See also isDataAvailable.
	Return the position in the buffer where the
	new data starts, regardless if anything
	was read, see #adjustInBuffer."

	recentlyRead _ socket receiveSomeDataInto: inBuffer startingAt: inNextToWrite.
	^self adjustInBuffer: recentlyRead! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SocketStream class
	instanceVariableNames: ''!

!SocketStream class methodsFor: 'example' stamp: 'md 8/14/2005 18:25'!
finger: userName
	"SocketStream finger: 'stp'"

	| addr s |
	addr _ NetNameResolver promptUserForHostAddress.
	s _ SocketStream openConnectionToHost: addr port: 79.  "finger port number"
	Transcript show: '---------- Connecting ----------'; cr.
	s sendCommand: userName.
	Transcript show: s getLine.
	s close.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
! !


!SocketStream class methodsFor: 'instance creation' stamp: 'gk 2/3/2005 22:19'!
on: socket
	"Create a socket stream on a connected server socket."

	^self basicNew initialize socket: socket! !

!SocketStream class methodsFor: 'instance creation' stamp: 'gk 2/3/2005 20:35'!
openConnectionToHost: hostIP port: portNumber
	| socket |
	socket _ Socket new.
	socket connectTo: hostIP port: portNumber.
	^self on: socket! !

!SocketStream class methodsFor: 'instance creation' stamp: 'gk 2/3/2005 20:35'!
openConnectionToHostNamed: hostName port: portNumber
	| hostIP |
	hostIP _ NetNameResolver addressForName: hostName timeout: 20.
	^self openConnectionToHost: hostIP port: portNumber! !
Socket subclass: #SocksSocket
	instanceVariableNames: 'vers method socksIP socksPort dstPort dstIP dstName'
	classVariableNames: 'DefaultSocksVersion'
	poolDictionaries: ''
	category: 'Network-Kernel'!
!SocksSocket commentStamp: '<historical>' prior: 0!
This class implements the socks 4 and partially socks 5 connection protocol.
For backward compatibility the socks protocol is disabled by default, so subclasses still work.
For further documentation check out:

Socks4: http://spiderman.socks.nec.com/protocol/socks4.protocol

Socks5: http://spiderman.socks.nec.com/rfc/rfc1928.txt!


!SocksSocket methodsFor: 'connection open/close' stamp: 'mir 2/22/2002 15:49'!
connectTo: hostAddress port: port
	self initializeNetwork.
	self shouldUseSocks
		ifFalse: [^super connectTo: hostAddress port: port].
	super connectTo: socksIP port: socksPort.
	self waitForConnectionUntil: Socket standardDeadline.
	dstIP _ hostAddress.
	dstPort _ port.
	vers == 4
		ifTrue: [self connectSocks4]
		ifFalse: [self connectSocks5]
	! !

!SocksSocket methodsFor: 'connection open/close' stamp: 'mir 3/6/2000 15:17'!
connectToHostNamed: hostName port: port
	super connectTo: socksIP port: socksPort.
	self waitForConnectionUntil: Socket standardDeadline.
	dstName _ hostName.
	dstPort _ port.
	vers == 4
		ifTrue: [self connectSocks4]
		ifFalse: [self connectSocks5]
	! !


!SocksSocket methodsFor: 'initialize' stamp: 'mir 9/26/2000 00:05'!
socks4
	vers _ 4.
	method _ nil.
	socksIP _ self class defaultSocksHostAddress.
	socksPort _ self class defaultSocksPort! !

!SocksSocket methodsFor: 'initialize' stamp: 'mir 9/26/2000 00:05'!
socks5
	vers _ 5.
	method _ self class noAutorizationMethod.
	socksIP _ self class defaultSocksHostAddress.
	socksPort _ self class defaultSocksPort! !


!SocksSocket methodsFor: 'methods' stamp: 'mir 3/6/2000 13:24'!
noAutorizationMethod
	^0! !


!SocksSocket methodsFor: 'socks4' stamp: 'mir 3/6/2000 15:07'!
connectSocks4
	self
		sendSocks4ConnectionRequestUserId: '';
		waitForSocks4ConnectionReply.
! !

!SocksSocket methodsFor: 'socks4' stamp: 'mir 2/22/2002 15:49'!
sendSocks4ConnectionRequestUserId: userId
	"The client connects to the SOCKS server and sends a CONNECT request when
it wants to establish a connection to an application server. The client
includes in the request packet the IP address and the port number of the
destination host, and userid, in the following format.

	+----+----+----+----+----+----+----+----+----+----+....+----+
	| VN | CD | DSTPORT |      DSTIP        | USERID       |NULL|
	+----+----+----+----+----+----+----+----+----+----+....+----+
	   1    1      2              4           variable       1
	"

	| requestString |
	requestString _ WriteStream on: ByteArray new.
	dstIP
		ifNil: [dstIP _ NetNameResolver addressForName: dstName].
	requestString
		nextPut: 4;
		nextPut: self connectCommandCode;
		nextWordPut: dstPort;
		nextPutAll: self dstIP;
		nextPutAll: userId asByteArray;
		nextPut: 0.
	self sendData: requestString contents! !

!SocksSocket methodsFor: 'socks4' stamp: 'mir 3/6/2000 15:11'!
waitForSocks4ConnectionReply

	| response |
	response _ self waitForReply: 8 for: self defaultTimeOutDuration.

	(response at: 2) = self requestGrantedCode
		ifFalse: [^self socksError: 'Connection failed: ' , (response at: 2) printString].! !


!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:42'!
connectSocks5
	self
		socks5MethodSelection;
		sendSocks5ConnectionRequest;
		socks5RequestReply
! !

!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:29'!
hostIP6Code
	^4! !

!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 15:20'!
hostIPCode
	^1! !

!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 15:15'!
qualifiedHostNameCode
	^3! !

!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:25'!
sendSocks5ConnectionRequest
	"Once the method-dependent subnegotiation has completed, the client
   sends the request details."

	| requestString |
	requestString _ WriteStream on: ByteArray new.
	requestString
		nextPut: 5;
		nextPut: self connectCommandCode;
		nextPut: 0. "Reserved slot"
	dstName isNil
		ifTrue: [
			requestString
				nextPutAll: self hostIPCode;
				nextPutAll: dstIP]
		ifFalse: [
			requestString
				nextPut: self qualifiedHostNameCode;
				nextPut: dstName size;
				nextPutAll: dstName asByteArray].
	requestString nextWordPut: dstPort.
	self sendData: requestString contents! !

!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:35'!
skipQualifiedHostName

	| startTime response bytesRead |
	startTime _ Time millisecondClockValue.
	response _ ByteArray new: 1.

	[(bytesRead _ self receiveDataInto: response) < 1
		and: [(Time millisecondClockValue - startTime) < self defaultTimeOutDuration]] whileTrue.

	bytesRead < 1
		ifTrue: [self socksError: 'Time out reading data'].

	self waitForReply: (response at: 1) + 2 for: self defaultTimeOutDuration! !

!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 15:16'!
socks5MethodSelection
	"The client connects to the server, and sends a version
   identifier/method selection message.
	The server selects from one of the methods given in METHODS, and
   sends a METHOD selection message."

	| requestString response |
	requestString _ WriteStream on: ByteArray new.
	requestString
		nextPut: 5;
		nextPut: 1;
		nextPut: 0.
	self sendData: requestString contents.

	response _ self waitForReply: 2 for: self defaultTimeOutDuration.
	(response at: 2) == 16rFF
		ifTrue: [self socksError: 'No acceptable methods.']
		ifFalse: [method _ response at: 2]! !

!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:28'!
socks5RequestReply

	| response |
	response _ self waitForReply: 4 for: self defaultTimeOutDuration.
	"Skip rest for now."
	(response at: 4) = self hostIPCode
		ifTrue: [self waitForReply: 6 for: self defaultTimeOutDuration].
	(response at: 4) = self qualifiedHostNameCode
		ifTrue: [self skipQualifiedHostName].
	(response at: 4) = self hostIP6Code
		ifTrue: [self waitForReply: 18 for: self defaultTimeOutDuration].
	(response at: 2) ~= 0
		ifTrue: [^self socksError: 'Connection failed: ', (response at: 2) printString].
! !


!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 13:34'!
connectCommandCode
	^1! !

!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 15:07'!
defaultTimeOutDuration
	^20000! !

!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 15:29'!
dstIP
	^dstIP! !

!SocksSocket methodsFor: 'private' stamp: 'mir 2/22/2002 16:23'!
dstPort
	^dstPort! !

!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 14:03'!
requestGrantedCode
	^90! !

!SocksSocket methodsFor: 'private' stamp: 'mir 9/26/2000 11:23'!
shouldUseSocks
	^vers notNil! !

!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 15:11'!
socksError: errorString
	self close; destroy.
	self error: errorString! !

!SocksSocket methodsFor: 'private' stamp: 'len 12/14/2002 11:39'!
waitForReply: replySize for: timeOutDuration
	| startTime response delay bytesRead |
	startTime _ Time millisecondClockValue.
	response _ ByteArray new: replySize.
	bytesRead _ 0.
	delay _ Delay forMilliseconds: 500.
	[bytesRead < replySize
		and: [(Time millisecondClockValue - startTime) < timeOutDuration]] whileTrue: [
		bytesRead _ bytesRead + (self receiveDataInto: response).
		delay wait.
		Transcript show: '.'].
	bytesRead < replySize
		ifTrue: [self close; destroy.
				^ (ConnectionRefused host: self dstIP port: self dstPort) signal].
	^response! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SocksSocket class
	instanceVariableNames: ''!

!SocksSocket class methodsFor: 'accessing' stamp: 'nk 7/6/2003 07:30'!
defaultSocksHostAddress

	^NetNameResolver addressForName: HTTPSocket httpProxyServer! !

!SocksSocket class methodsFor: 'accessing' stamp: 'nk 7/6/2003 07:30'!
defaultSocksPort
	^HTTPSocket httpProxyPort! !

!SocksSocket class methodsFor: 'accessing' stamp: 'mir 9/26/2000 00:06'!
defaultSocksVersion
	"nil means no socks"
	^DefaultSocksVersion! !

!SocksSocket class methodsFor: 'accessing' stamp: 'mir 9/26/2000 00:07'!
defaultSocksVersion: anInteger
	"nil means no socks"
	DefaultSocksVersion _ anInteger! !
FillStyle subclass: #SolidFillStyle
	instanceVariableNames: 'color pixelValue32'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!
!SolidFillStyle commentStamp: '<historical>' prior: 0!
SolidFillStyle is a fill which represents a color for the BalloonEngine.

Instance variables:
	color	<Color>	The color to use.
	pixelValue32 <Integer>	The cached pixel value to use.!


!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:24'!
color: aColor
	color := aColor.
	pixelValue32 := aColor scaledPixelValue32! !

!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 03:29'!
display
	^color display! !

!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:25'!
scaledPixelValue32
	"Return the alpha scaled pixel value for depth 32"
	^pixelValue32! !


!SolidFillStyle methodsFor: 'converting' stamp: 'ar 11/9/1998 13:55'!
asColor
	^color! !


!SolidFillStyle methodsFor: 'printing' stamp: 'ar 11/17/1998 00:29'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(; print: color; nextPut:$).! !


!SolidFillStyle methodsFor: 'testing' stamp: 'ar 11/8/1998 18:34'!
isSolidFill
	^true! !

!SolidFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:30'!
isTranslucent
	^color isTranslucent! !

!SolidFillStyle methodsFor: 'testing' stamp: 'ar 10/26/2000 19:25'!
isTransparent
	^color isTransparent! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SolidFillStyle class
	instanceVariableNames: ''!

!SolidFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/8/1998 18:31'!
color: aColor
	^self new color: aColor! !
ImageMorph subclass: #Sonogram
	instanceVariableNames: 'lastX scrollDelta columnForm minVal maxVal pixValMap'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!Sonogram commentStamp: '<historical>' prior: 0!
Sonograms are imageMorphs that will repeatedly plot arrays of values as black on white columns moving to the right in time and scrolling left as necessary.!


!Sonogram methodsFor: 'all' stamp: 'stephaneducasse 2/4/2006 20:41'!
extent: extent minVal: min maxVal: max scrollDelta: d
	minVal := min.
	maxVal := max.
	scrollDelta := d.
	self extent: extent.

" try following with scrolldelta = 1, 20, 200
	| s data |
	s := Sonogram new extent: 200@50
				minVal: 0.0 maxVal: 1.0 scrollDelta: 20.
	World addMorph: s.
	data := (1 to: 133) collect: [:i | 0.0].
	1 to: 300 do:
		[:i | data at: (i\\133)+1 put: 1.0.
		s plotColumn: data.
		data at: (i\\133)+1 put: 0.0.
		World doOneCycleNow].
	s delete	
"! !

!Sonogram methodsFor: 'all' stamp: 'jdl 3/28/2003 09:30'!
plotColumn: dataArray 
	| chm1 i normVal r |
	columnForm unhibernate.
	chm1 := columnForm height - 1.
	0 to: chm1
		do: 
			[:y | 
			i := y * (dataArray size - 1) // chm1 + 1.
			normVal := ((dataArray at: i) - minVal) / (maxVal - minVal).
			normVal := normVal max: 0.0.
			normVal := normVal min: 1.0.
			columnForm bits at: chm1 - y + 1
				put: (pixValMap at: (normVal * 255.0) truncated + 1)].
	(lastX := lastX + 1) > (image width - 1) ifTrue: [self scroll].
	image 
		copy: (r := lastX @ 0 extent: 1 @ image height)
		from: (32 // image depth - 1) @ 0
		in: columnForm
		rule: Form over.
	"self changed."
	self invalidRect: (r translateBy: self position)! !

!Sonogram methodsFor: 'all' stamp: 'stephaneducasse 2/4/2006 20:41'!
scroll
	image copy: (scrollDelta@0 extent: (image width-scrollDelta)@image height)
			from: image to: 0@0 rule: Form over.
	lastX := lastX - scrollDelta.
	self changed! !


!Sonogram methodsFor: 'geometry' stamp: 'stephaneducasse 2/4/2006 20:41'!
extent: newExtent
	super image: (Form extent: newExtent depth: Display depth).
	lastX := -1.
	columnForm := Form extent: (32//image depth)@(image height) depth: image depth.
	pixValMap := ((1 to: 256) collect:
			[:i | columnForm pixelValueFor: (Color gray: (256-i)/255.0)])
		as: Bitmap.
! !
OrderedCollection subclass: #SortedCollection
	instanceVariableNames: 'sortBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!SortedCollection commentStamp: '<historical>' prior: 0!
I represent a collection of objects ordered by some property of the objects themselves. The ordering is specified in a BlockContext.!


!SortedCollection methodsFor: 'accessing' stamp: 'sma 4/28/2000 17:47'!
at: anInteger put: anObject
	self shouldNotImplement! !

!SortedCollection methodsFor: 'accessing' stamp: 'tk 3/28/1999 22:55'!
median
	"Return the middle element, or as close as we can get."

	^ self at: self size + 1 // 2! !

!SortedCollection methodsFor: 'accessing'!
sortBlock
	"Answer the blockContext which is the criterion for sorting elements of 
	the receiver."

	^sortBlock! !

!SortedCollection methodsFor: 'accessing' stamp: 'stp 12/05/1999 07:09'!
sortBlock: aBlock 
	"Make the argument, aBlock, be the criterion for ordering elements of the 
	receiver."

	aBlock
		ifNotNil: [sortBlock := aBlock fixTemps]
		ifNil: [sortBlock := aBlock].
	"The sortBlock must copy its home context, so as to avoid circularities!!"
	"Therefore sortBlocks with side effects may not work right"
	self size > 0 ifTrue: [self reSort]! !


!SortedCollection methodsFor: 'adding' stamp: 'go 4/27/2000 13:19'!
add: newObject
	^ super insert: newObject before: (self indexForInserting: newObject)! !

!SortedCollection methodsFor: 'adding' stamp: 'sma 4/28/2000 18:35'!
addAll: aCollection
	aCollection size > (self size // 3)
		ifTrue:
			[aCollection do: [:each | self addLast: each].
			self reSort]
		ifFalse: [aCollection do: [:each | self add: each]].
	^ aCollection! !

!SortedCollection methodsFor: 'adding' stamp: 'go 4/26/2000 17:26'!
addFirst: newObject
	self shouldNotImplement! !

!SortedCollection methodsFor: 'adding' stamp: 'MPH 10/23/2000 13:31'!
copyEmpty
	"Answer a copy of the receiver without any of the receiver's elements."

	^self species sortBlock: sortBlock! !


!SortedCollection methodsFor: 'comparing'!
= aSortedCollection
	"Answer true if my and aSortedCollection's species are the same,
	and if our blocks are the same, and if our elements are the same."

	self species = aSortedCollection species ifFalse: [^ false].
	sortBlock = aSortedCollection sortBlock
		ifTrue: [^ super = aSortedCollection]
		ifFalse: [^ false]! !


!SortedCollection methodsFor: 'copying'!
copy

	| newCollection |
	newCollection _ self species sortBlock: sortBlock.
	newCollection addAll: self.
	^newCollection! !


!SortedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'!
collect: aBlock 
	"Evaluate aBlock with each of my elements as the argument. Collect the 
	resulting values into an OrderedCollection. Answer the new collection. 
	Override the superclass in order to produce an OrderedCollection instead
	of a SortedCollection."

	| newCollection | 
	newCollection _ OrderedCollection new: self size.
	self do: [:each | newCollection addLast: (aBlock value: each)].
	^ newCollection! !


!SortedCollection methodsFor: 'topological sort' stamp: 'hg 1/2/2002 13:34'!
sortTopologically
	"Plenty of room for increased efficiency in this one."

	| remaining result pick |
	remaining _ self asOrderedCollection.
	result _ OrderedCollection new.
	[remaining isEmpty] whileFalse: [
		pick _ remaining select: [:item |
			remaining allSatisfy: [:anotherItem |
				item == anotherItem or: [self should: item precede: anotherItem]]].
		pick isEmpty ifTrue: [self error: 'bad topological ordering'].
		result addAll: pick.
		remaining removeAll: pick].
	^self copySameFrom: result! !


!SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:36'!
indexForInserting: newObject

	| index low high |
	low _ firstIndex.
	high _ lastIndex.
	sortBlock isNil
		ifTrue: [[index _ high + low // 2.  low > high]
			whileFalse: 
				[((array at: index) <= newObject)
					ifTrue: [low _ index + 1]
					ifFalse: [high _ index - 1]]]
		ifFalse: [[index _ high + low // 2.  low > high]
			whileFalse: 
				[(sortBlock value: (array at: index) value: newObject)
					ifTrue: [low _ index + 1]
					ifFalse: [high _ index - 1]]].
	^low! !

!SortedCollection methodsFor: 'private' stamp: 'go 4/26/2000 17:17'!
insert: anObject before: spot
	self shouldNotImplement! !

!SortedCollection methodsFor: 'private' stamp: 'sma 4/28/2000 17:46'!
reSort
	self sort: firstIndex to: lastIndex! !

!SortedCollection methodsFor: 'private' stamp: 'hg 12/17/2001 19:30'!
should: a precede: b

	^sortBlock ifNil: [a <= b] ifNotNil: [sortBlock value: a value: b]
! !

!SortedCollection methodsFor: 'private' stamp: 'hg 12/17/2001 20:22'!
sort: i to: j 
	"Sort elements i through j of self to be nondescending according to
	sortBlock."

	| di dij dj tt ij k l n |
	"The prefix d means the data at that index."
	(n _ j + 1  - i) <= 1 ifTrue: [^self].	"Nothing to sort." 
	 "Sort di,dj."
	di _ array at: i.
	dj _ array at: j.
	(self should: di precede: dj)
		ifFalse: 
			[array swap: i with: j.
			 tt _ di.
			 di _ dj.
			 dj _ tt].
	n > 2
		ifTrue:  "More than two elements."
			[ij _ (i + j) // 2.  "ij is the midpoint of i and j."
			 dij _ array at: ij.  "Sort di,dij,dj.  Make dij be their median."
			 (self should: di precede: dij)
			   ifTrue: 
				[(self should: dij precede: dj)
				  ifFalse: 
					[array swap: j with: ij.
					 dij _ dj]]
			   ifFalse:
				[array swap: i with: ij.
				 dij _ di].
			n > 3
			  ifTrue:  "More than three elements."
				["Find k>i and l<j such that dk,dij,dl are in reverse order.
				Swap k and l.  Repeat this procedure until k and l pass each other."
				 k _ i.
				 l _ j.
				 [[l _ l - 1.  k <= l and: [self should: dij precede: (array at: l)]]
				   whileTrue.  "i.e. while dl succeeds dij"
				  [k _ k + 1.  k <= l and: [self should: (array at: k) precede: dij]]
				   whileTrue.  "i.e. while dij succeeds dk"
				  k <= l]
				   whileTrue:
					[array swap: k with: l]. 
	"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments."
				self sort: i to: l.
				self sort: k to: j]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SortedCollection class
	instanceVariableNames: ''!

!SortedCollection class methodsFor: 'instance creation' stamp: 'stp 04/23/1999 05:34'!
new: anInteger 
	"The default sorting function is a <= comparison on elements."

	^(super new: anInteger) "sortBlock: [:x :y | x <= y]" 		"nil sortBlock OK"! !

!SortedCollection class methodsFor: 'instance creation'!
sortBlock: aBlock 
	"Answer an instance of me such that its elements are sorted according to 
	the criterion specified in aBlock."

	^(super new: 10) sortBlock: aBlock! !
TestCase subclass: #SortedCollectionTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Unordered'!

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:27'!
testAdd
	"self run: #testAdd"
	"self debug: #testAdd"
	
	| collection |
	collection := #(10 9 8 7 5 4 4 2) asSortedCollection.
	self assert: collection first = 2.
	self assert: collection last = 10.
	self assert: (collection size = 8).
	collection add:1.
	self assert: (collection size = 9).
	collection add: 6.
	self assert: ((collection at: 5) = 5).
	self assert: (collection size = 10).
	collection add: 3.
	! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:30'!
testAddAll
	"self run: #testAddAll"
	"self debug: #testAddAll"
	
	| sorted2 sorted|
	sorted2 := SortedCollection new.
	sorted2 add: 'brochet'; add:'truitelle'.
	sorted := SortedCollection new.
	sorted addAll: sorted2.
	self assert: (sorted hasEqualElements: sorted2).
	 ! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:32'!
testAddAll2
	"self run: #testAddAll2"
	"self debug: #testAddAll2"
	
	| sorted2 sorted|
	sorted2 := SortedCollection new.
	sorted2 add: 'brochet'; add:'truitelle'.
	sorted := SortedCollection new.
	sorted add: 'perche'.
	sorted addAll: sorted2.
	self assert: (sorted size = (sorted2 size + 1)).
	sorted2 do: 
			[ :each | self assert: (sorted includes: each)]
	 ! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:33'!
testCollect
	"self run: #testCollect"
	
	|result aSortedCollection|
	aSortedCollection := SortedCollection new.
	result := OrderedCollection new.
	result add:true ; add: true ; add: true ;add: false ; add: false.
	aSortedCollection := (1 to: 5) asSortedCollection.
	self assert: (result = (aSortedCollection collect: [:each | each < 4])).
	! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:39'!
testCopy
	"self run: #testCopy"
	"self debug: #testCopy"
	
	|aSortedCollection copySorted|
	aSortedCollection := SortedCollection new.
	aSortedCollection sortBlock: [:a :b | a < b].
	aSortedCollection add: 'truite' ; add: 'brochet'.
	self assert: aSortedCollection first = 'brochet'.
	
	copySorted := aSortedCollection copy.
	
	self assert: (copySorted  hasEqualElements: aSortedCollection).
	self assert: (copySorted  species = aSortedCollection species).
	self assert: (copySorted  sortBlock = aSortedCollection sortBlock).
	self assert: copySorted first = 'brochet'.! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:30'!
testCreation
	"self run: #testCreation"
	"self debug: #testCreation"
	
	| collection |
	collection := #(10 9 3 6 1 8 7 5 4 2) asSortedCollection.
	self assert: collection = (1 to: 10) asSortedCollection.
	! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:42'!
testEquals
	"self run: #testEquals"
	"self debug: #testEquals"
	
	|aSortedCollection|
	aSortedCollection := SortedCollection new.
	aSortedCollection add:'truite' ; add: 'brochet'.
	self assert: aSortedCollection copy = aSortedCollection.! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:43'!
testMedian
	"self run: #testMedian"
	"self debug: #testMedian"
	
	|aSortedCollection|
	aSortedCollection := (1 to: 10) asSortedCollection.
	self assert: aSortedCollection median=5.
	
	aSortedCollection := SortedCollection new.
	aSortedCollection add:'truite' ; add:'porcinet' ; add:'carpe'.
	self assert: (aSortedCollection median = 'porcinet').
	! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:46'!
testShouldPrecede
	"self run: #testShouldPrecede"
	
	|aSortedCollection|
	aSortedCollection := SortedCollection new.
	self assert: (aSortedCollection should: 'za' precede: 'zb').
	self assert: (aSortedCollection isEmpty).
	self assert: (aSortedCollection should: 1 precede: 2).
	
	aSortedCollection sortBlock: [:a :b | a > b].
	aSortedCollection reSort.
	self assert: (aSortedCollection should: 'zb' precede: 'za').
	self assert: (aSortedCollection isEmpty).
	self assert: (aSortedCollection should: 2 precede: 1).
		! !

!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:38'!
testSortBlock
	"self run: #testSortBlock"
	"self debug: #testSortBlock"
	
	|aSortedCollection|
	aSortedCollection := SortedCollection new.
	aSortedCollection sortBlock: [:a :b | a < b].
	aSortedCollection add: 'truite' ; add: 'brochet' ; add: 'tortue'.
	self assert: aSortedCollection first = 'brochet'.
	
	aSortedCollection := SortedCollection new.
	aSortedCollection sortBlock: [:a :b | a >b].
	aSortedCollection add: 'truite' ; add: 'brochet' ; add: 'tortue'.
	self assert: aSortedCollection first = 'truite'.
	
	
	! !
BorderedMorph subclass: #SorterTokenMorph
	instanceVariableNames: 'morphRepresented'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Palettes'!

!SorterTokenMorph methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 12:38'!
fitContents
	submorphs size == 1 ifTrue: [self bounds: (submorphs first bounds insetBy: (-1 @ -1))]! !

!SorterTokenMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 23:16'!
forMorph: aMorph 
	| it |
	morphRepresented := aMorph.
	aMorph submorphs notEmpty 
		ifTrue: 
			[self addMorphBack: (it := aMorph submorphs first veryDeepCopy).
			it position: self position + (1 @ 1).
			it lock].
	self fitContents! !


!SorterTokenMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color blue! !

!SorterTokenMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!SorterTokenMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color transparent! !


!SorterTokenMorph methodsFor: 'thumbnail' stamp: 'sw 12/1/1998 12:27'!
morphRepresented
	^ morphRepresented! !
ArrayedCollection variableWordSubclass: #SoundBuffer
	instanceVariableNames: ''
	classVariableNames: 'SineTable'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SoundBuffer commentStamp: '<historical>' prior: 0!
SoundBuffers store 16 bit unsigned quantities.  !


!SoundBuffer methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'!
bytesPerElement
	"Number of bytes in each item.  This multiplied by (self size)*8 gives the number of bits stored."
	^ 2! !

!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:00'!
monoSampleCount
	"Return the number of monaural 16-bit samples that fit into this SoundBuffer."

	^ super size * 2
! !

!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:28'!
size
	"Return the number of 16-bit sound samples that fit in this sound buffer. To avoid confusion, it is better to get the size of SoundBuffer using monoSampleCount or stereoSampleCount."

	^ self monoSampleCount
! !

!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:01'!
stereoSampleCount
	"Return the number of stereo slices that fit into this SoundBuffer. A stereo 'slice' consists of two 16-bit samples, one for each channel."

	^ super size
! !


!SoundBuffer methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:31'!
writeOnGZIPByteStream: aStream 
	
	aStream nextPutAllWordArray: self! !


!SoundBuffer methodsFor: 'objects from disk' stamp: 'stephaneducasse 2/4/2006 20:41'!
restoreEndianness
	"This word object was just read in from a stream.  It was stored in Big Endian (Mac) format.  Swap each pair of bytes (16-bit word), if the current machine is Little Endian.
	Why is this the right thing to do?  We are using memory as a byteStream.  High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory.  Different from a Bitmap."

	| hack blt |
	SmalltalkImage current  isLittleEndian ifTrue: [
		"The implementation is a hack, but fast for large ranges"
		hack := Form new hackBits: self.
		blt := (BitBlt toForm: hack) sourceForm: hack.
		blt combinationRule: Form reverse.  "XOR"
		blt sourceY: 0; destY: 0; height: self size; width: 1.
		blt sourceX: 0; destX: 1; copyBits.  "Exchange bytes 0 and 1"
		blt sourceX: 1; destX: 0; copyBits.
		blt sourceX: 0; destX: 1; copyBits.
		blt sourceX: 2; destX: 3; copyBits.  "Exchange bytes 2 and 3"
		blt sourceX: 3; destX: 2; copyBits.
		blt sourceX: 2; destX: 3; copyBits].

! !

!SoundBuffer methodsFor: 'objects from disk' stamp: 'stephaneducasse 2/4/2006 20:41'!
reverseEndianness
	"Swap the bytes of each 16-bit word, using a fast BitBlt hack."

	| hack blt |
	hack := Form new hackBits: self.
	blt := (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.  "XOR"
	blt sourceY: 0; destY: 0; height: self size; width: 1.
	blt sourceX: 0; destX: 1; copyBits.  "Exchange bytes 0 and 1"
	blt sourceX: 1; destX: 0; copyBits.
	blt sourceX: 0; destX: 1; copyBits.
	blt sourceX: 2; destX: 3; copyBits.  "Exchange bytes 2 and 3"
	blt sourceX: 3; destX: 2; copyBits.
	blt sourceX: 2; destX: 3; copyBits.
! !


!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/17/97 13:03'!
at: index
	"Return the 16-bit integer value at the given index of the receiver."

	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber ifTrue: [^ self at: index truncated].
	self errorNonIntegerIndex.
! !

!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/17/97 13:03'!
at: index put: value
	"Store the given 16-bit integer at the given index in the receiver."

	<primitive: 144>
	index isInteger
		ifTrue: [
			(index >= 1 and: [index <= self size])
				ifTrue: [self errorImproperStore]
				ifFalse: [self errorSubscriptBounds: index]].
	index isNumber ifTrue: [^ self at: index truncated put: value].
	self errorNonIntegerIndex.
! !

!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/2/97 16:07'!
primFill: aPositiveInteger
	"Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."
	"Note: Since 16-bit word arrays are not built into the virtual machine, this primitive fills by 32-bit words."

	<primitive: 145>
	self errorImproperStore.
! !


!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
asByteArray
	"Answer a ByteArray containing my sample data serialized in most-significant byte first order."

	| sampleCount bytes dst s |
	sampleCount := self monoSampleCount.
	bytes := ByteArray new: 2 * sampleCount.
	dst := 0.
	1 to: sampleCount do: [:src |
		s := self at: src.
		bytes at: (dst := dst + 1) put: ((s bitShift: -8) bitAnd: 255).
		bytes at: (dst := dst + 1) put: (s bitAnd: 255)].
	^ bytes

	! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
averageEvery: nSamples from: anotherBuffer upTo: inCount

	| fromIndex sum |

	fromIndex := 1.
	1 to: inCount // nSamples do: [ :i |
		sum := 0.
		nSamples timesRepeat: [
			sum := sum + (anotherBuffer at: fromIndex).
			fromIndex := fromIndex + 1.
		].
		self at: i put: sum // nSamples.
	].
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
downSampledLowPassFiltering: doFiltering
	"Answer a new SoundBuffer half the size of the receiver consisting of every other sample. If doFiltering is true, a simple low-pass filter is applied to avoid aliasing of high frequencies. Assume that receiver is monophonic."
	"Details: The simple low-pass filter in the current implementation could be improved, at some additional cost."

	| n resultBuf j |
	n := self monoSampleCount.
	resultBuf := SoundBuffer newMonoSampleCount: n // 2.
	j := 0.
	doFiltering
		ifTrue: [
			1 to: n by: 2 do: [:i |
				resultBuf at: (j := j + 1) put:
					(((self at: i) + (self at: i + 1)) bitShift: -1)]]
		ifFalse: [
			1 to: n by: 2 do: [:i |
				resultBuf at: (j := j + 1) put: (self at: i)]].

	^ resultBuf! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
extractLeftChannel
	"Answer a new SoundBuffer half the size of the receiver consisting of only the left channel of the receiver, which is assumed to contain stereo sound data."

	| n resultBuf j |
	n := self monoSampleCount.
	resultBuf := SoundBuffer newMonoSampleCount: n // 2.
	j := 0.
	1 to: n by: 2 do: [:i | resultBuf at: (j := j + 1) put: (self at: i)].
	^ resultBuf! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
extractRightChannel
	"Answer a new SoundBuffer half the size of the receiver consisting of only the right channel of the receiver, which is assumed to contain stereo sound data."

	| n resultBuf j |
	n := self monoSampleCount.
	resultBuf := SoundBuffer newMonoSampleCount: n // 2.
	j := 0.
	2 to: n by: 2 do: [:i | resultBuf at: (j := j + 1) put: (self at: i)].
	^ resultBuf! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'!
indexOfFirstSampleOver: threshold
	"Return the index of the first sample whose absolute value is over the given threshold value. Return an index one greater than my size if no sample is over the threshold."

	1 to: self size do: [:i |
		(self at: i) abs > threshold ifTrue: [^ i]].
	^ self size + 1! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'!
indexOfLastSampleOver: threshold
	"Return the index of the last sample whose absolute value is over the given threshold value. Return zero if no sample is over the threshold."

	self size to: 1 by: -1 do: [:i |
		(self at: i) abs > threshold ifTrue: [^ i]].
	^ 0
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
lowPassFiltered
	"Answer a simple low-pass filtered copy of this buffer. Assume it is monophonic."

	| sz out last this |
	sz := self monoSampleCount.
	out := self clone.
	last := self at: 1.
	2 to: sz do: [:i |
		this := self at: i.
		out at: i put: (this + last) // 2.
		last := this].
	^ out
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
mergeStereo
	"Answer a new SoundBuffer half the size of the receiver that mixes the left and right stereo channels of the receiver, which is assumed to contain stereo sound data."

	| n resultBuf j |
	n := self monoSampleCount.
	resultBuf := SoundBuffer newMonoSampleCount: n // 2.
	j := 0.
	1 to: n by: 2 do: [:i | resultBuf at: (j := j + 1) put: (((self at: i) + (self at: i + 1)) // 2)].
	^ resultBuf
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
normalized: percentOfFullVolume
	"Increase my amplitudes so that the highest peak is the given percent of full volume. For example 's normalized: 50' would normalize to half of full volume."

	| peak s mult |
	peak := 0.
	1 to: self size do: [:i |
		s := (self at: i) abs.
		s > peak ifTrue: [peak := s]].
	mult := (32767.0 * percentOfFullVolume) / (100.0 * peak).
	1 to: self size do: [:i | self at: i put: (mult * (self at: i)) asInteger].
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
saveAsAIFFFileSamplingRate: rate on: aBinaryStream
	"Store this mono sound buffer in AIFF file format with the given sampling rate on the given stream."

	| sampleCount s swapBytes |
	sampleCount := self monoSampleCount.
	aBinaryStream nextPutAll: 'FORM' asByteArray.
	aBinaryStream nextInt32Put: (2 * sampleCount) + ((7 * 4) + 18).
	aBinaryStream nextPutAll: 'AIFF' asByteArray.
	aBinaryStream nextPutAll: 'COMM' asByteArray.
	aBinaryStream nextInt32Put: 18.
	aBinaryStream nextNumber: 2 put: 1.  "channels"
	aBinaryStream nextInt32Put: sampleCount.
	aBinaryStream nextNumber: 2 put: 16.  "bits/sample"
	self storeExtendedFloat: rate on: aBinaryStream.
	aBinaryStream nextPutAll: 'SSND' asByteArray.
	aBinaryStream nextInt32Put: (2 * sampleCount) + 8.
	aBinaryStream nextInt32Put: 0.
	aBinaryStream nextInt32Put: 0.

	(aBinaryStream isKindOf: StandardFileStream) ifTrue: [
		"optimization: write sound buffer directly to file"
		swapBytes := SmalltalkImage current  isLittleEndian.
		swapBytes ifTrue: [self reverseEndianness].  "make big endian"
		aBinaryStream next: (self size // 2) putAll: self startingAt: 1.  "size in words"
		swapBytes ifTrue: [self reverseEndianness].  "revert to little endian"
		^ self].

	1 to: sampleCount do: [:i |
		s := self at: i.
		aBinaryStream nextPut: ((s bitShift: -8) bitAnd: 16rFF).
		aBinaryStream nextPut: (s bitAnd: 16rFF)].
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
splitStereo
	"Answer an array of two SoundBuffers half the size of the receiver consisting of the left and right channels of the receiver (which is assumed to contain stereo sound data)."

	| n leftBuf rightBuf leftIndex rightIndex |
	n := self monoSampleCount.
	leftBuf := SoundBuffer newMonoSampleCount: n // 2.
	rightBuf := SoundBuffer newMonoSampleCount: n // 2.
	leftIndex := rightIndex := 0.
	1 to: n by: 2 do: [:i |
		leftBuf at: (leftIndex := leftIndex + 1) put: (self at: i).
		rightBuf at: (rightIndex := rightIndex + 1) put: (self at: i + 1)].
	^ Array with: leftBuf with: rightBuf
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
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)].! !

!SoundBuffer methodsFor: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
trimmedThreshold: threshold

	| start end |
	start := self indexOfFirstSampleOver: threshold.
	end :=  self indexOfLastSampleOver: threshold.
	start > end ifTrue: [^ SoundBuffer new].
	start := (start - 200) max: 1.
	end := (end + 200) min: self size.
	^ self copyFrom: start to: end
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundBuffer class
	instanceVariableNames: ''!

!SoundBuffer class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"Build a sine wave table."
	"SoundBuffer initialize"

	| tableSize radiansPerStep peak |
	tableSize := 4000.
	SineTable := self newMonoSampleCount: tableSize.
	radiansPerStep := (2.0 * Float pi) / tableSize asFloat.
	peak := ((1 bitShift: 15) - 1) asFloat.  "range is +/- (2^15 - 1)"
	1 to: tableSize do: [:i |
		SineTable at: i put: (peak * (radiansPerStep * (i - 1)) sin) rounded].
! !

!SoundBuffer class methodsFor: 'class initialization' stamp: 'ads 7/31/2003 11:13'!
sineTable
	"Answer a SoundBuffer containing one complete cycle of a sine wave."

	^ SineTable
! !


!SoundBuffer class methodsFor: 'instance creation' stamp: 'RAA 12/30/2000 18:20'!
averageEvery: nSamples from: anotherBuffer upTo: inCount

	^(self newMonoSampleCount: inCount // nSamples)
		averageEvery: nSamples 
		from: anotherBuffer 
		upTo: inCount! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
fromArray: anArray
	"Return a new SoundBuffer whose contents are copied from the given Array or ByteArray."

	| new |
	new := SoundBuffer newMonoSampleCount: anArray size.
	1 to: anArray size do: [:i | new at: i put: (anArray at: i)].
	^ new
! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
fromByteArray: aByteArray
	"Convert the given ByteArray (stored with the most significant byte first) into 16-bit sample buffer."

	| n buf src w |
	n := aByteArray size // 2.
	buf := SoundBuffer newMonoSampleCount: n.
	src := 1.
	1 to: n do: [:i |
		w := ((aByteArray at: src) bitShift: 8) + (aByteArray at: src + 1).
		w > 32767 ifTrue: [w := w - 65536].
		buf at: i put: w.
		src := src + 2].
	^ buf
! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 13:25'!
new: anInteger
	"See the comment in newMonoSampleCount:. To avoid confusion, it is best to create new instances using newMonoSampleCount: or newStereoSampleCount:."

	^ self newMonoSampleCount: anInteger
! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:44'!
newMonoSampleCount: anInteger
	"Return a SoundBuffer large enough to hold the given number of monaural samples (i.e., 16-bit words)."
	"Details: The size is rounded up to an even number, since the underlying representation is in terms of 32-bit words."

	^ self basicNew: (anInteger + 1) // 2
! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:52'!
newStereoSampleCount: anInteger
	"Return a SoundBuffer large enough to hold the given number of stereo slices. A stereo 'slice' consists of two 16-bit samples, one for each channel."

	^ self basicNew: anInteger
! !


!SoundBuffer class methodsFor: 'objects from disk' stamp: 'stephaneducasse 2/4/2006 20:41'!
startUp
	"Check if the word order has changed from the last save."

	| la |
	la := ShortIntegerArray classPool at: #LastSaveOrder.
	((la at: 2) = 42 and: [(la at: 1) = 13]) 
		ifTrue: [^self swapHalves]. "Reverse the two 16-bit halves."
				"Another reversal happened automatically which reversed the bytes."
! !

!SoundBuffer class methodsFor: 'objects from disk' stamp: 'nk 2/22/2005 15:29'!
startUpFrom: anImageSegment 
	"In this case, do we need to swap word halves when reading this segment?"

	^SmalltalkImage current endianness ~~ anImageSegment endianness 
		ifTrue: [Message selector: #swapHalves	"will be run on each instance"]
		ifFalse: [nil]! !
Object subclass: #SoundCodec
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SoundCodec commentStamp: '<historical>' prior: 0!
I am an abstract class that describes the protocol for sound codecs. Each codec (the name stems from "COder/DECoder") describes a particular algorithm for compressing and decompressing sound data. Most sound codecs are called 'lossy' because they lose information; the decompressed sound data is not exactly the same as the original data.
!


!SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 2/2/1999 16:01'!
compressAndDecompress: aSound
	"Compress and decompress the given sound. Useful for testing."
	"(MuLawCodec new compressAndDecompress: (SampledSound soundNamed: 'camera')) play"

	^ (self compressSound: aSound) asSound
! !

!SoundCodec methodsFor: 'compress/decompress' stamp: 'stephaneducasse 2/4/2006 20:41'!
compressSound: aSound
	"Compress the entirety of the given sound with this codec. Answer a CompressedSoundData."

	| compressed channels |
	compressed := CompressedSoundData new
		codecName: self class name;
		soundClassName: aSound class name.
	(aSound isKindOf: SampledSound) ifTrue: [
		channels := Array new: 1.
		channels at: 1 put: (self encodeSoundBuffer: aSound samples).
		compressed
			channels: channels;
			samplingRate: aSound originalSamplingRate;
			firstSample: 1;
			loopEnd: aSound samples size;
			loopLength: 0.0;
			perceivedPitch: 100.0;
			gain: aSound loudness.
		^ compressed].
	(aSound isKindOf: LoopedSampledSound) ifTrue: [
		aSound isStereo
			ifTrue: [
				channels := Array new: 2.
				channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples).
				channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)]
			ifFalse: [
				channels := Array new: 1.
				channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)].
		compressed
			channels: channels;
			samplingRate: aSound originalSamplingRate;
			firstSample: aSound firstSample;
			loopEnd: aSound loopEnd;
			loopLength: aSound loopLength;
			perceivedPitch: aSound perceivedPitch;
			gain: aSound gain.
		^ compressed].
	self error: 'you can only compress sampled sounds'.
! !

!SoundCodec methodsFor: 'compress/decompress' stamp: 'stephaneducasse 2/4/2006 20:41'!
compressSound: aSound atRate: desiredSampleRate
	"Compress the entirety of the given sound with this codec. Answer a CompressedSoundData."

	| compressed channels samples newRate ratio buffer |

	compressed := CompressedSoundData new
		codecName: self class name;
		soundClassName: aSound class name.
	(aSound isKindOf: SampledSound) ifTrue: [
		(desiredSampleRate isNil or: 
				[(ratio := aSound originalSamplingRate // desiredSampleRate) <= 1]) ifTrue: [
			samples := aSound samples.
			newRate := aSound originalSamplingRate.
		] ifFalse: [
			buffer := aSound samples.
			samples := SoundBuffer 
				averageEvery: ratio 
				from: buffer 
				upTo: buffer monoSampleCount.
			newRate := aSound originalSamplingRate / ratio.
		].

		channels := Array new: 1.
		channels at: 1 put: (self encodeSoundBuffer: samples).
		compressed
			channels: channels;
			samplingRate: newRate;
			firstSample: 1;
			loopEnd: samples size;
			loopLength: 0.0;
			perceivedPitch: 100.0;
			gain: aSound loudness.
		^ compressed].
	(aSound isKindOf: LoopedSampledSound) ifTrue: [
		aSound isStereo
			ifTrue: [
				channels := Array new: 2.
				channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples).
				channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)]
			ifFalse: [
				channels := Array new: 1.
				channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)].
		compressed
			channels: channels;
			samplingRate: aSound originalSamplingRate;
			firstSample: aSound firstSample;
			loopEnd: aSound loopEnd;
			loopLength: aSound loopLength;
			perceivedPitch: aSound perceivedPitch;
			gain: aSound gain.
		^ compressed].
	self error: 'you can only compress sampled sounds'.
! !

!SoundCodec methodsFor: 'compress/decompress' stamp: 'stephaneducasse 2/4/2006 20:41'!
decompressSound: aCompressedSound
	"Decompress the entirety of the given compressed sound with this codec and answer the resulting sound."

	| channels sound |
	channels := aCompressedSound channels
		collect: [:compressed | self decodeCompressedData: compressed].
	'SampledSound' = aCompressedSound soundClassName ifTrue: [
		sound := SampledSound
			samples: channels first
			samplingRate: (aCompressedSound samplingRate).
		sound loudness: aCompressedSound gain.
		^ sound].
	'LoopedSampledSound' = aCompressedSound soundClassName ifTrue: [
		aCompressedSound loopLength = 0
			ifTrue: [
				sound := LoopedSampledSound
					unloopedSamples: channels first
					pitch: aCompressedSound perceivedPitch
					samplingRate: aCompressedSound samplingRate]
			ifFalse: [
				sound := LoopedSampledSound
					samples: channels first
					loopEnd: aCompressedSound loopEnd
					loopLength: aCompressedSound loopLength
					pitch: aCompressedSound perceivedPitch
					samplingRate: aCompressedSound samplingRate].
		channels size > 1 ifTrue: [sound rightSamples: channels last].
		sound
			firstSample: aCompressedSound firstSample;
			gain: aCompressedSound gain.
		sound
			setPitch: 100.0
			dur: (channels first size / aCompressedSound samplingRate)
			loudness: 1.0.
		^ sound].
	self error: 'unknown sound class'.
! !


!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 14:23'!
bytesPerEncodedFrame
	"Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."

	self subclassResponsibility.
! !

!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:38'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
	"Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	self subclassResponsibility.
! !

!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:39'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
	"Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	self subclassResponsibility.
! !

!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:30'!
reset
	"Reset my encoding and decoding state. Optional. This default implementation does nothing."
! !

!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:45'!
samplesPerFrame
	"Answer the number of sound samples per compression frame."

	self subclassResponsibility.
! !


!SoundCodec methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
decodeCompressedData: aByteArray
	"Decode the entirety of the given encoded data buffer with this codec. Answer a monophonic SoundBuffer containing the uncompressed samples."

	| frameCount result increments |
	frameCount := self frameCount: aByteArray.
	result := SoundBuffer newMonoSampleCount: frameCount * self samplesPerFrame.
	self reset.
	increments := self decodeFrames: frameCount from: aByteArray at: 1 into: result at: 1.
	((increments first = aByteArray size) and: [increments last = result size]) ifFalse: [
		self error: 'implementation problem; increment sizes should match buffer sizes'].
	^ result
! !

!SoundCodec methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
encodeSoundBuffer: aSoundBuffer
	"Encode the entirety of the given monophonic SoundBuffer with this codec. Answer a ByteArray containing the compressed sound data."

	| codeFrameSize frameSize fullFrameCount lastFrameSamples result increments finalFrame i lastIncs |
	frameSize := self samplesPerFrame.
	fullFrameCount := aSoundBuffer monoSampleCount // frameSize.
	lastFrameSamples := aSoundBuffer monoSampleCount - (fullFrameCount * frameSize).
	codeFrameSize := self bytesPerEncodedFrame.
	codeFrameSize = 0 ifTrue:
		["Allow room for 1 byte per sample for variable-length compression"
		codeFrameSize := frameSize].
	lastFrameSamples > 0
		ifTrue: [result := ByteArray new: (fullFrameCount + 1) * codeFrameSize]
		ifFalse: [result := ByteArray new: fullFrameCount * codeFrameSize].
	self reset.
	increments := self encodeFrames: fullFrameCount from: aSoundBuffer at: 1 into: result at: 1.
	lastFrameSamples > 0 ifTrue: [
		finalFrame := SoundBuffer newMonoSampleCount: frameSize.
		i := fullFrameCount * frameSize.
		1 to: lastFrameSamples do: [:j |
			finalFrame at: j put: (aSoundBuffer at: (i := i + 1))].
		lastIncs := self encodeFrames: 1 from: finalFrame at: 1 into: result at: 1 + increments second.
		increments := Array with: increments first + lastIncs first
							with: increments second + lastIncs second].
	increments second < result size
		ifTrue: [^ result copyFrom: 1 to: increments second]
		ifFalse: [^ result]
! !

!SoundCodec methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
frameCount: aByteArray
	"Compute the frame count for this byteArray.  This default computation will have to be overridden by codecs with variable frame sizes."

	| codeFrameSize |
	codeFrameSize := self bytesPerEncodedFrame.
	(aByteArray size \\ codeFrameSize) = 0 ifFalse:
		[self error: 'encoded buffer is not an even multiple of the encoded frame size'].
	^ aByteArray size // codeFrameSize! !
AlignmentMorph subclass: #SoundDemoMorph
	instanceVariableNames: 'soundColumn'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2001 17:49'!
makeControls

	| bb r cc |
	cc _ Color black.
	r _ AlignmentMorph newRow.
	r color: cc; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	r addMorphBack: (bb label: 'V1';			actionSelector: #playV1).
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	r addMorphBack: (bb label: 'V2';			actionSelector: #playV2).
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	r addMorphBack: (bb label: 'V3';			actionSelector: #playV3).
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	r addMorphBack: (bb label: 'All';			actionSelector: #playAll).
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	r addMorphBack: (bb label: 'Stop';		actionSelector: #stopSound).
	^ r
! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 13:34'!
playAll
	| snd |
	soundColumn submorphs isEmpty
		ifTrue: [^ self].
	self setTimbreFromTile: soundColumn submorphs first.
	snd _ SampledSound bachFugueVoice1On: SampledSound new.
	soundColumn submorphs size >= 2
		ifTrue: [""self setTimbreFromTile: soundColumn submorphs second.
			snd _ snd
						+ (AbstractSound bachFugueVoice2On: SampledSound new)].
	soundColumn submorphs size >= 3
		ifTrue: [""self setTimbreFromTile: soundColumn submorphs third.
			snd _ snd
						+ (AbstractSound bachFugueVoice3On: SampledSound new)].
	snd play! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 13:35'!
playV1
	soundColumn submorphs isEmpty
		ifTrue: [^ self].
	self
		setTimbreFromTile: (soundColumn submorphs first).
	(SampledSound bachFugueVoice1On: SampledSound new) play! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 13:35'!
playV2
	soundColumn submorphs size < 2
		ifTrue: [^ self].
	self
		setTimbreFromTile: (soundColumn submorphs second).
	(SampledSound bachFugueVoice2On: SampledSound new) playSilentlyUntil: 4.8;
		 resumePlaying! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 13:35'!
playV3
	soundColumn submorphs size < 3
		ifTrue: [^ self].
	self
		setTimbreFromTile: (soundColumn submorphs third).
	(AbstractSound bachFugueVoice3On: SampledSound new) playSilentlyUntil: 14.4;
		 resumePlaying! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:09'!
setTimbreFromTile: aSoundTile

	SampledSound defaultSampleTable: aSoundTile sound samples.
	SampledSound nominalSamplePitch: 400.
! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:09'!
stopSound

	SoundPlayer shutDown.
! !


!SoundDemoMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 2! !

!SoundDemoMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!SoundDemoMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:04'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self listDirection: #topToBottom;
		 wrapCentering: #center;
		 cellPositioning: #topCenter;
		 hResizing: #spaceFill;
		 vResizing: #spaceFill;
		 layoutInset: 3;
		 addMorph: self makeControls;
	initializeSoundColumn.
	self extent: 118 @ 150! !

!SoundDemoMorph methodsFor: 'initialization' stamp: 'jam 3/9/2003 17:52'!
initializeSoundColumn
"initialize the receiver's soundColumn"
	soundColumn _ AlignmentMorph newColumn.
	soundColumn enableDragNDrop.
	self addMorphBack: soundColumn! !
AbstractMediaEventMorph subclass: #SoundEventMorph
	instanceVariableNames: 'sound'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!SoundEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 13:01'!
sound: aSound

	sound _ aSound.
	self setBalloonText: 'a sound of duration ',(sound duration roundTo: 0.1) printString,' seconds'.! !


!SoundEventMorph methodsFor: 'caching' stamp: 'RAA 12/8/2000 09:52'!
releaseCachedState

	super releaseCachedState.
	sound _ sound compressWith: GSMCodec.
! !


!SoundEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGreen! !

!SoundEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:39'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self height: 10! !


!SoundEventMorph methodsFor: 'piano rolls' stamp: 'RAA 12/7/2000 12:36'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	| startX lengthInTicks endX |

	startTimeInScore > rightTime ifTrue: [^ self].  
	lengthInTicks _ pianoRoll scorePlayer ticksForMSecs: sound duration * 1000.0.
	startTimeInScore + lengthInTicks < leftTime ifTrue: [^ self].
	startX _ pianoRoll xForTime: startTimeInScore.
	endX _ pianoRoll xForTime: startTimeInScore + lengthInTicks.
	morphList add: 
		(self left: startX; width: endX - startX).

! !

!SoundEventMorph methodsFor: 'piano rolls' stamp: 'RAA 12/7/2000 12:29'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	"hack... since we are called from within the SoundPlayer loop, the Semaphore will
	block attempts to play directly from here"
	WorldState addDeferredUIMessage: [sound play].! !

!SoundEventMorph methodsFor: 'piano rolls' stamp: 'RAA 12/9/2000 18:48'!
justDroppedIntoPianoRoll: newOwner event: evt
	
	| startX lengthInTicks endX |

	super justDroppedIntoPianoRoll: newOwner event: evt.

	startTimeInScore _ newOwner timeForX: self left.
	lengthInTicks _ newOwner scorePlayer ticksForMSecs: sound duration * 1000.0.
	endTimeInScore _ startTimeInScore + lengthInTicks.

	endTimeInScore > newOwner scorePlayer durationInTicks ifTrue:
		[newOwner scorePlayer updateDuration].

	startX _ newOwner xForTime: startTimeInScore.
	endX _ newOwner xForTime: endTimeInScore.
	self width: endX - startX.

! !
SoundRecorder subclass: #SoundInputStream
	instanceVariableNames: 'bufferSize mutex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SoundInputStream commentStamp: '<historical>' prior: 0!
This subclass of SoundRecorder supports real-time processing of incoming sound data. The sound input process queues raw sound buffers, allowing them to be read and processed by the client as they become available. A semaphore is used to synchronize between the record process and the client process. Since sound data is buffered, the client process may lag behind the input process without losing data.
!


!SoundInputStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
bufferCount
	"Answer the number of sound buffers that have been queued."

	| n |
	mutex ifNil: [^ 0].  "not recording"
	mutex critical: [n := recordedBuffers size].
	^ n
! !

!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/6/1999 10:36'!
bufferSize

	^ bufferSize
! !

!SoundInputStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
bufferSize: aNumber
	"Set the sound buffer size. Buffers of this size will be queued for the client to process."

	bufferSize := aNumber truncated.
! !

!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:23'!
isRecording
	"Answer true if the sound input process is running."

	^ recordProcess ~~ nil
! !

!SoundInputStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
nextBufferOrNil
	"Answer the next input buffer or nil if no buffer is available."

	| result |
	mutex ifNil: [^ nil].  "not recording"
	mutex critical: [
		recordedBuffers size > 0
			ifTrue: [result := recordedBuffers removeFirst]
			ifFalse: [result := nil]].
	^ result
! !


!SoundInputStream methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize

	super initialize.
	bufferSize := 1024.
	mutex := nil.
! !


!SoundInputStream methodsFor: 'recording controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
startRecording
	"Start the sound input process."

	recordProcess ifNotNil: [self stopRecording].
	recordedBuffers := OrderedCollection new: 100.
	mutex := Semaphore forMutualExclusion.
	super startRecording.
	paused := false.
! !

!SoundInputStream methodsFor: 'recording controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopRecording
	"Turn off the sound input process and close the driver."

	super stopRecording.
	recordedBuffers := nil.
	mutex := nil.
! !


!SoundInputStream methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
allocateBuffer
	"Allocate a new buffer and reset nextIndex. This message is sent by the sound input process."

	currentBuffer := SoundBuffer newMonoSampleCount: bufferSize.
	nextIndex := 1.
! !

!SoundInputStream methodsFor: 'private' stamp: 'jm 9/8/1999 15:24'!
emitBuffer: buffer
	"Queue a buffer for later processing. This message is sent by the sound input process."

	mutex critical: [recordedBuffers addLast: buffer].
! !
RectangleMorph subclass: #SoundLoopMorph
	instanceVariableNames: 'samplesUntilNextControl seqSound cursor controlIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:21'!
addCursorMorph
	self addMorph:
		(cursor _ (RectangleMorph
				newBounds: (self innerBounds topLeft extent: 1@self innerBounds height)
				color: Color red)
						borderWidth: 0)! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:11'!
allowSubmorphExtraction

	^ true! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/5/98 17:31'!
buildSound
	"Build a compound sound for the next iteration of the loop."

	| mixer soundMorphs startTime pan |
	mixer _ MixedSound new.
	mixer add: (RestSound dur: (self width - (2 * borderWidth)) / 128.0).
	soundMorphs _ self submorphs select: [:m | m respondsTo: #sound].
	soundMorphs do: [:m |
		startTime _ (m position x - (self left + borderWidth)) / 128.0.
		pan _ (m position y - (self top + borderWidth)) asFloat / (self height - (2 * borderWidth) - m height).
		mixer add: ((RestSound dur: startTime), m sound copy) pan: pan].
	^ mixer
! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:11'!
play
	"Play this sound to the sound ouput port in real time."

	self reset.
	SoundPlayer playSound: self.
! !


!SoundLoopMorph methodsFor: 'dropping/grabbing' stamp: 'jm 11/14/97 11:11'!
wantsDroppedMorph: aMorph event: evt

	^ aMorph respondsTo: #sound
! !


!SoundLoopMorph methodsFor: 'geometry' stamp: 'jm 11/14/97 11:21'!
extent: newExtent
	super extent: (newExtent truncateTo: 128@128) + (self borderWidth*2)! !


!SoundLoopMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!SoundLoopMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'!
defaultBounds
"answer the default bounds for the receiver"
	^ 0 @ 0 corner: 128 @ 128 + (self defaultBorderWidth * 2)! !

!SoundLoopMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightBlue! !

!SoundLoopMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:50'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	controlIndex _ 0.
	self addCursorMorph! !


!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
controlRate
	"Answer the number of control changes per second."

	^ 32
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
doControl

	seqSound doControl.
	controlIndex _ controlIndex + 1.
	controlIndex >= (self controlRate * (self innerBounds width // 128))
		ifTrue: [controlIndex _ 0].
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 1/5/98 13:40'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Repeatedly play my sounds."

	| i count samplesNeeded |
	i _ startIndex.
	samplesNeeded _ n.
	[samplesNeeded > 0] whileTrue: [
		count _ seqSound samplesRemaining min: samplesNeeded.
		count = 0 ifTrue: [
			self reset.
			count _ seqSound samplesRemaining min: samplesNeeded.
			count = 0 ifTrue: [^ self]].  "zero length sound"
		seqSound mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol.
		i _ i + count.
		samplesNeeded _ samplesNeeded - count].
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'!
playSampleCount: n into: aSoundBuffer startingAt: startIndex
	"Mixes the next count samples of this sound into the given buffer starting at the given index, updating the receiver's control parameters at periodic intervals."

	| fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count |
	fullVol _ AbstractSound scaleFactor.
	samplesBetweenControlUpdates _ self samplingRate // self controlRate.
	pastEnd _ startIndex + n.  "index just index of after last sample"
	i _ startIndex.
	[i < pastEnd] whileTrue: [
		remainingSamples _ self samplesRemaining.
		remainingSamples <= 0 ifTrue: [^ self].
		count _ pastEnd - i.
		samplesUntilNextControl < count ifTrue: [count _ samplesUntilNextControl].
		remainingSamples < count ifTrue: [count _ remainingSamples].
		self mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: fullVol rightVol: fullVol.
		samplesUntilNextControl _ samplesUntilNextControl - count.
		samplesUntilNextControl <= 0 ifTrue: [
			self doControl.
			samplesUntilNextControl _ samplesBetweenControlUpdates].
		i _ i + count].
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
positionCursor
	| x |
	x _ controlIndex * 128 // self controlRate.
	cursor position: self innerBounds topLeft + (x@0)
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
reset
	"Reset my internal state for a replay."

	seqSound _ self buildSound reset.
	samplesUntilNextControl _ (self samplingRate // self controlRate).
	controlIndex _ 0.
	self positionCursor! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:11'!
samplesRemaining

	^ 1000000
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:11'!
samplingRate
	"Answer the sampling rate in samples per second."

	^ SoundPlayer samplingRate! !


!SoundLoopMorph methodsFor: 'stepping and presenter' stamp: 'jm 11/14/97 11:21'!
step
	self positionCursor! !

!SoundLoopMorph methodsFor: 'stepping and presenter' stamp: 'jm 11/14/97 11:11'!
stop
	"Stop playing this sound."

	SoundPlayer pauseSound: self.
! !


!SoundLoopMorph methodsFor: 'testing' stamp: 'jm 11/14/97 11:21'!
stepTime

	^ 50
! !
ImageMorph subclass: #SoundMorph
	instanceVariableNames: 'sound'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!
!SoundMorph commentStamp: '<historical>' prior: 0!
Note: as of December 2000, this does not work. SoundMorph>>buildImage requires the sound to implement #volumeEnvelopeScaledTo: and as yet, no one does.!


!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:21'!
buildImage
	| scale env h imageColor |
	owner ifNil: [scale _ 128@128]  "Default is 128 pix/second, 128 pix fullscale"
		ifNotNil: [scale _ owner soundScale].
	env _ sound volumeEnvelopeScaledTo: scale.
	self image: (ColorForm extent: env size @ env max).
	1 to: image width do:
		[:x | h _ env at: x.
		image fillBlack: ((x-1)@(image height-h//2) extent: 1@h)].
	imageColor _ #(black red orange green blue) atPin:
						(sound pitch / 110.0) rounded highBit.
	image colors: (Array with: Color transparent with: (Color perform: imageColor)).
! !

!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
reset
	sound reset! !

!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
sound
	^ sound! !

!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
sound: aSound
	sound _ aSound copy.
	sound reset.
	self buildImage! !


!SoundMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 20:05'!
justDroppedInto: aMorph event: anEvent
	| relPosition |
	relPosition _ self position - aMorph innerBounds topLeft.
	relPosition _ (relPosition x roundTo: 8) @ relPosition y.
	self position: aMorph innerBounds topLeft + relPosition.
	sound copy play.
	^super justDroppedInto: aMorph event: anEvent! !


!SoundMorph methodsFor: 'initialization' stamp: 'jm 12/17/97 22:43'!
initialize

	super initialize.
	self sound: (FMSound pitch: 880.0 dur: 0.2 loudness: 0.8).
! !
Object subclass: #SoundPlayer
	instanceVariableNames: ''
	classVariableNames: 'ActiveSounds Buffer BufferIndex BufferMSecs LastBuffer PlayerProcess PlayerSemaphore ReadyForBuffer ReverbState SamplingRate SoundJustStarted SoundSupported Stereo UseReadySemaphore UseReverb'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundPlayer class
	instanceVariableNames: ''!

!SoundPlayer class methodsFor: 'accessing' stamp: 'jm 8/13/1998 15:00'!
bufferMSecs

	^ BufferMSecs
! !

!SoundPlayer class methodsFor: 'accessing' stamp: 'jm 1/27/98 09:28'!
reverbState

	^ ReverbState! !

!SoundPlayer class methodsFor: 'accessing'!
samplingRate

	^ SamplingRate! !

!SoundPlayer class methodsFor: 'accessing' stamp: 'JMM 11/6/2000 10:16'!
setVolumeLeft: aLeftVolume volumeRight: aRightVolume
	"Set sound pass in float 0.0-1.0 for left and right channel, with possible 2.0 or  higher to overdrive sound channel "
	self primSoundSetVolumeLeft: aLeftVolume volumeRight: aRightVolume! !

!SoundPlayer class methodsFor: 'accessing' stamp: 'JMM 11/6/2000 10:17'!
soundVolume
	"Return sound as array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven"
	^self primSoundGetVolume! !

!SoundPlayer class methodsFor: 'accessing'!
stereo

	^ Stereo
! !


!SoundPlayer class methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"SoundPlayer initialize; shutDown; startUp"
	"Details: BufferMSecs represents a tradeoff between latency and quality. If BufferMSecs is too low, the sound will not play smoothly, especially during long-running primitives such as large BitBlts. If BufferMSecs is too high, there will be a long time lag between when a sound buffer is submitted to be played and when that sound is actually heard. BufferMSecs is typically in the range 50-200."

	SamplingRate := 22050.
	BufferMSecs := 120.
	Stereo := true.
	UseReverb ifNil: [UseReverb := true].
! !

!SoundPlayer class methodsFor: 'initialization' stamp: 'ar 1/24/2002 18:40'!
useLastBuffer
	^LastBuffer notNil! !

!SoundPlayer class methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
useLastBuffer: aBool
	Buffer ifNil:[^self].
	aBool 
		ifTrue:[LastBuffer := SoundBuffer basicNew: Buffer basicSize]
		ifFalse:[LastBuffer := nil]	! !

!SoundPlayer class methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
useShortBuffer
	"Experimental support for real-time MIDI input. This only works on platforms whose hardware allows very short buffer sizes. It has been tested on a Macintosh Powerbook G3."
	"SoundPlayer useShortBuffer"

	self shutDown.
	BufferMSecs := 15.
	SoundPlayer
		startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000
		rate: SamplingRate
		stereo: Stereo.
! !


!SoundPlayer class methodsFor: 'player process' stamp: 'jm 1/29/98 18:56'!
isReverbOn

	^ ReverbState ~~ nil
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'ar 1/24/2002 18:41'!
lastPlayBuffer
	^LastBuffer! !

!SoundPlayer class methodsFor: 'player process' stamp: 'stephaneducasse 2/4/2006 20:41'!
oldStylePlayLoop
	"This version of the play loop is used if the VM does not yet support sound primitives that signal a semaphore when a sound buffer becomes available."

	| bytesPerSlice count |
	bytesPerSlice := Stereo ifTrue: [4] ifFalse: [2].
	[true] whileTrue: [
		[(count := self primSoundAvailableBytes // bytesPerSlice) > 100]
			whileFalse: [(Delay forMilliseconds: 1) wait].

		count := count min: Buffer stereoSampleCount.
		PlayerSemaphore critical: [
			ActiveSounds := ActiveSounds select: [:snd | snd samplesRemaining > 0].
			ActiveSounds do: [:snd |
				snd ~~ SoundJustStarted ifTrue: [
					snd playSampleCount: count into: Buffer startingAt: 1]].
			ReverbState == nil ifFalse: [
				ReverbState applyReverbTo: Buffer startingAt: 1 count: count].
			self primSoundPlaySamples: count from: Buffer startingAt: 1.
			Buffer primFill: 0.
			SoundJustStarted := nil]].
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'stephaneducasse 2/4/2006 20:41'!
playLoop
	"The sound player process loop."

	| bytesPerSlice count willStop mayStop |
	mayStop := Preferences soundStopWhenDone.
	bytesPerSlice := Stereo ifTrue: [4] ifFalse: [2].
	[true] whileTrue: [
		[(count := self primSoundAvailableBytes // bytesPerSlice) > 100]
			whileFalse: [ReadyForBuffer wait].

		count := count min: Buffer stereoSampleCount.
		PlayerSemaphore critical: [
			ActiveSounds := ActiveSounds select: [:snd | snd samplesRemaining > 0].
			ActiveSounds do: [:snd |
				snd ~~ SoundJustStarted ifTrue: [
					snd playSampleCount: count into: Buffer startingAt: 1]].
			ReverbState == nil ifFalse: [
				ReverbState applyReverbTo: Buffer startingAt: 1 count: count].
			self primSoundPlaySamples: count from: Buffer startingAt: 1.
			willStop := mayStop and:[
						(ActiveSounds size = 0) and:[
							self isAllSilence: Buffer size: count]].
			LastBuffer ifNotNil:[
				LastBuffer replaceFrom: 1 to: LastBuffer size with: Buffer startingAt: 1.
			].
			willStop
				ifTrue:[self shutDown. PlayerProcess := nil]
				ifFalse:[Buffer primFill: 0].
			SoundJustStarted := nil].
		willStop ifTrue:[^self].
	].
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'nk 2/16/2001 13:26'!
playerProcess
	^PlayerProcess! !

!SoundPlayer class methodsFor: 'player process' stamp: 'ar 2/4/2001 18:01'!
startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag
	"Start the sound player process. Terminate the old process, if any."
	"SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false"
	^self startPlayerProcessBufferSize: bufferSize 
			rate: samplesPerSecond 
			stereo: stereoFlag 
			sound: nil! !

!SoundPlayer class methodsFor: 'player process' stamp: 'stephaneducasse 2/4/2006 20:41'!
startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag sound: aSound
	"Start the sound player process. Terminate the old process, if any."
	"SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false"

	self stopPlayerProcess.
	aSound
		ifNil:[ActiveSounds := OrderedCollection new]
		ifNotNil:[ActiveSounds := OrderedCollection with: aSound].
	Buffer := SoundBuffer newStereoSampleCount: (bufferSize // 4) * 4.
	LastBuffer ifNotNil:[LastBuffer := SoundBuffer basicNew: Buffer basicSize].
	PlayerSemaphore := Semaphore forMutualExclusion.
	SamplingRate := samplesPerSecond.
	Stereo := stereoFlag.
	ReadyForBuffer := Semaphore new.
	SoundSupported := true. "Assume so"
	UseReadySemaphore := true.  "set to false if ready semaphore not supported by VM"
	self primSoundStartBufferSize: Buffer stereoSampleCount
		rate: samplesPerSecond
		stereo: Stereo
		semaIndex: (Smalltalk registerExternalObject: ReadyForBuffer).
	"Check if sound start prim was successful"
	SoundSupported ifFalse:[^self].
	UseReadySemaphore
		ifTrue: [PlayerProcess := [SoundPlayer playLoop] newProcess]
		ifFalse: [PlayerProcess := [SoundPlayer oldStylePlayLoop] newProcess].
	UseReverb ifTrue: [self startReverb].

	PlayerProcess priority: Processor userInterruptPriority.
	PlayerProcess resume.! !

!SoundPlayer class methodsFor: 'player process' stamp: 'stephaneducasse 2/4/2006 20:41'!
startReverb
	"Start a delay-line style reverb with the given tap delays and gains. Tap delays are given in samples and should be prime integers; the following comment gives an expression that generates primes."
	"Integer primesUpTo: 22050"

	UseReverb := true.
	ReverbState := ReverbSound new
		tapDelays: #(1601 7919) gains: #(0.12 0.07).
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopPlayerProcess
	"Stop the sound player process."
	"SoundPlayer stopPlayerProcess"

	(PlayerProcess == nil or:[PlayerProcess == Processor activeProcess]) 
		ifFalse:[PlayerProcess terminate].
	PlayerProcess := nil.
	self primSoundStop.
	ActiveSounds := OrderedCollection new.
	Buffer := nil.
	PlayerSemaphore := Semaphore forMutualExclusion.
	ReadyForBuffer ifNotNil:
		[Smalltalk unregisterExternalObject: ReadyForBuffer].
	ReadyForBuffer := nil.
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopReverb

	UseReverb := false.
	ReverbState := nil.
! !


!SoundPlayer class methodsFor: 'playing' stamp: 'ar 2/1/2001 15:20'!
canStartPlayer
	"Some platforms do no support simultaneous record and play. If this is one of those platforms, return false if there is a running SoundRecorder."

	Preferences canRecordWhilePlaying ifTrue: [^ true].
	SoundRecorder anyActive ifTrue:[^false].
	^ true
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'di 8/5/1998 23:08'!
isPlaying: aSound
	^ ActiveSounds includes: aSound! !

!SoundPlayer class methodsFor: 'playing' stamp: 'jm 8/23/97 20:38'!
pauseSound: aSound
	"Stop playing the given sound. Playing can be resumed from this point later."

	PlayerSemaphore critical: [
		ActiveSounds remove: aSound ifAbsent: []].
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'ar 2/19/2001 01:28'!
playSound: aSound
	"Reset and start playing the given sound from its beginning."

	aSound reset.
	aSound samplesRemaining = 0 ifTrue:[^self].
	self resumePlaying: aSound.
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/8/1998 17:54'!
resumePlaying: aSound
	"Start playing the given sound without resetting it; it will resume playing from where it last stopped."
	"Implementation detail: On virtual machines that don't support the quickstart primitive, you may need to edit this method to pass false to resumePlaying:quickStart:."

	self resumePlaying: aSound quickStart: true.
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
resumePlaying: aSound quickStart: quickStart
	"Start playing the given sound without resetting it; it will resume playing from where it last stopped. If quickStart is true, then try to start playing the given sound immediately."

	| doQuickStart |
	Preferences soundsEnabled ifFalse: [^ self].
	doQuickStart := quickStart.
	Preferences soundQuickStart ifFalse: [doQuickStart := false].
	PlayerProcess == nil ifTrue: [
		self canStartPlayer ifFalse: [^ self].
		^self startUpWithSound: aSound].

	PlayerSemaphore critical: [
		(ActiveSounds includes: aSound)
			ifTrue: [doQuickStart := false]
			ifFalse: [
				doQuickStart ifFalse: [ActiveSounds add: aSound]]].

	"quick-start the given sound, unless the sound player has just started"
	doQuickStart ifTrue: [self startPlayingImmediately: aSound].
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopPlayingAll
	"Stop playing all sounds."

	PlayerSemaphore critical: [
		ActiveSounds := ActiveSounds species new].
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/13/97 19:49'!
waitUntilDonePlaying: aSound
	"Wait until the given sound is no longer playing."

	[PlayerSemaphore critical: [ActiveSounds includes: aSound]]
		whileTrue: [(Delay forMilliseconds: 100) wait].
! !


!SoundPlayer class methodsFor: 'primitive test' stamp: 'stephaneducasse 2/4/2006 20:41'!
boinkPitch: p dur: d loudness: l waveTable: waveTable pan: pan
	"Play a decaying note on the given stream using the given wave table. Used for testing only."

	| decay tableSize amplitude increment cycles i |
	decay := 0.96.
	tableSize := waveTable size.
	amplitude := l asInteger min: 1000.
	increment := ((p asFloat * tableSize asFloat) / SamplingRate asFloat) asInteger.
	increment := (increment max: 1) min: (tableSize // 2).
	cycles := (d * SamplingRate asFloat) asInteger.

	i := 1.
	1 to: cycles do: [:cycle |
		(cycle \\ 100) = 0
			ifTrue: [amplitude := (decay * amplitude asFloat) asInteger].
		i := (((i - 1) + increment) \\ tableSize) + 1.
		self playTestSample: (amplitude * (waveTable at: i)) // 1000 pan: pan].
! !

!SoundPlayer class methodsFor: 'primitive test' stamp: 'stephaneducasse 2/4/2006 20:41'!
boinkScale
	"Tests the sound output primitives by playing a scale."
	"SoundPlayer boinkScale"

	| sineTable pan |
	self shutDown.
	SamplingRate := 11025.
	Stereo := true.
	sineTable := self sineTable: 1000.
	Buffer := SoundBuffer newStereoSampleCount: 1000.
	BufferIndex := 1.
	self primSoundStartBufferSize: Buffer stereoSampleCount
		rate: SamplingRate
		stereo: Stereo.
	pan := 0.
	#(261.626 293.665 329.628 349.229 391.996 440.001 493.884 523.252) do: [:p |
		self boinkPitch: p dur: 0.3 loudness: 300 waveTable: sineTable pan: pan.
		pan := pan + 125].

	self boinkPitch: 261.626 dur: 1.0 loudness: 300 waveTable: sineTable pan: 500.
	self primSoundStop.
	self shutDown.
	SoundPlayer initialize.  "reset sampling rate, buffer size, and stereo flag"
! !

!SoundPlayer class methodsFor: 'primitive test' stamp: 'stephaneducasse 2/4/2006 20:41'!
playTestSample: s pan: pan
	"Append the given sample in the range [-32767..32767] to the output buffer, playing the output buffer when it is full. Used for testing only."

	| sample leftSample |
	BufferIndex >= Buffer size
		ifTrue: [
			"current buffer is full; play it"
			[self primSoundAvailableBytes > 0]
				whileFalse. "wait for space to be available"
			self primSoundPlaySamples: Buffer stereoSampleCount from: Buffer startingAt: 1.
			Buffer primFill: 0.
			BufferIndex := 1].

	sample := s.
	sample >  32767 ifTrue: [ sample :=  32767 ]. 
	sample < -32767 ifTrue: [ sample := -32767 ].

	Stereo
		ifTrue: [
			leftSample := (sample * pan) // 1000.
			Buffer at: BufferIndex		put: sample - leftSample.
			Buffer at: BufferIndex + 1	put: leftSample]
		ifFalse: [
			Buffer at: BufferIndex + 1 put: sample].
	BufferIndex := BufferIndex + 2.
! !

!SoundPlayer class methodsFor: 'primitive test' stamp: 'stephaneducasse 2/4/2006 20:41'!
sineTable: size
	"Compute a sine table of the given size. Used for testing only."

	| radiansPerStep table |
	table := Array new: size.
	radiansPerStep := (2.0 * Float pi) / table size asFloat.
	1 to: table size do: [:i |
		table at: i put:
			(32767.0 * (radiansPerStep * i) sin) asInteger].

	^ table
! !


!SoundPlayer class methodsFor: 'snapshotting' stamp: 'stephaneducasse 2/4/2006 20:41'!
shutDown
	"Stop player process, for example before snapshotting."

	self stopPlayerProcess.
	ReverbState := nil.
! !

!SoundPlayer class methodsFor: 'snapshotting' stamp: 'jm 7/11/97 12:17'!
startUp
	"Start up the player process."

	SoundPlayer initialize.
	SoundPlayer
		startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000
		rate: SamplingRate
		stereo: Stereo.
! !

!SoundPlayer class methodsFor: 'snapshotting' stamp: 'ar 2/4/2001 17:59'!
startUpWithSound: aSound
	"Start up the player process."

	SoundPlayer initialize.
	SoundPlayer
		startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000
		rate: SamplingRate
		stereo: Stereo
		sound: aSound.
! !


!SoundPlayer class methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
isAllSilence: buffer size: count
	"return true if the buffer is all silence after reverb has ended"
	| value |
	value := buffer at: 1.
	2 to: count do:[:i| (buffer at: i) = value ifFalse:[^false]].
	^true! !

!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSoundAvailableBytes
	"Return the number of bytes of available space in the sound output buffer."
	"Note: Squeak always uses buffers containing 4-bytes per sample (2 channels at 2 bytes per channel) regardless of the state of the Stereo flag."

	<primitive: 'primitiveSoundAvailableSpace' module: 'SoundPlugin'>
	^ self primitiveFailed
! !

!SoundPlayer class methodsFor: 'private' stamp: 'JMM 11/6/2000 10:17'!
primSoundGetVolume
	"Return sound as array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven"
	<primitive: 'primitiveSoundGetVolume' module: 'SoundPlugin'>
	^Array with: 1.0 with: 1.0! !

!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSoundInsertSamples: count from: aSoundBuffer samplesOfLeadTime: anInteger
	"Mix the given number of sample frames from the given sound buffer into the queue of samples that has already been submitted to the sound driver. This primitive is used to start a sound playing with minimum latency, even if large sound output buffers are being used to ensure smooth sound output. Returns the number of samples consumed, or zero if the primitive is not implemented or fails."

	<primitive: 'primitiveSoundInsertSamples' module: 'SoundPlugin'>
	^ 0
! !

!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSoundPlaySamples: count from: aSampleBuffer startingAt: index
	"Copy count bytes into the current sound output buffer from the given sample buffer starting at the given index."

	<primitive: 'primitiveSoundPlaySamples' module: 'SoundPlugin'>
	^ self primitiveFailed
! !

!SoundPlayer class methodsFor: 'private' stamp: 'JMM 11/6/2000 10:14'!
primSoundSetVolumeLeft: aLeftVolume volumeRight: aRightVolume
	"Set sound pass in float 0.0-1.0 for left and right channel, with possible 2.0 or  higher to overdrive sound channel "
	<primitive: 'primitiveSoundSetLeftVolume' module: 'SoundPlugin'>
! !

!SoundPlayer class methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag
	"Start double-buffered sound output with the given buffer size and sampling rate. This version has been superceded by primitive 171 (primSoundStartBufferSize:rate:stereo:semaIndex:)."
	"ar 12/5/1998 Turn off the sound if not supported"
	<primitive: 'primitiveSoundStart' module: 'SoundPlugin'>
	SoundSupported := false.! !

!SoundPlayer class methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag semaIndex: anInteger
	"Start double-buffered sound output with the given buffer size and sampling rate. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled when the sound driver is ready to accept another buffer of samples."
	"Details: If this primitive fails, this method tries to use the older version instead."

	<primitive: 'primitiveSoundStartWithSemaphore' module: 'SoundPlugin'>
	UseReadySemaphore := false.
	self primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag.
! !

!SoundPlayer class methodsFor: 'private' stamp: 'tpr 2/2/2001 19:46'!
primSoundStop
	"Stop double-buffered sound output. Must not raise an error because it is used inside error handling and at system shutdown"

	<primitive: 'primitiveSoundStop' module: 'SoundPlugin'>! !

!SoundPlayer class methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
startPlayingImmediately: aSound
	"Private!! Start playing the given sound as soon as possible by mixing it into the sound output buffers of the underlying sound driver."

	| totalSamples buf n leftover src rest |
	"first, fill a double-size buffer with samples"
	"Note: The code below assumes that totalSamples contains two
	 buffers worth of samples, and the insertSamples primitive is
	 expected to consume at least one buffer's worth of these
	 samples. The remaining samples are guaranteed to fit into
	 a single buffer."
	totalSamples := Buffer stereoSampleCount * 2.  "two buffer's worth"
	buf := SoundBuffer newStereoSampleCount: totalSamples.
	aSound playSampleCount: totalSamples into: buf startingAt: 1.
	ReverbState == nil ifFalse: [
		ReverbState applyReverbTo: buf startingAt: 1 count: totalSamples].

	PlayerSemaphore critical: [
		"insert as many samples as possible into the sound driver's buffers"
		n := self primSoundInsertSamples: totalSamples
			from: buf
			samplesOfLeadTime: 1024.
		n > 0 ifTrue:[
			leftover := totalSamples - n.

			"copy the remainder of buf into Buffer"
			"Note: the following loop iterates over 16-bit words, not two-word stereo slices"
			"assert: 0 < leftover <= Buffer stereoSampleCount"
			src := 2 * n.
			1 to: 2 * leftover do:
				[:dst | Buffer at: dst put: (buf at: (src := src + 1))].

			"generate enough additional samples to finish filling Buffer"
			rest := Buffer stereoSampleCount - leftover.
			aSound playSampleCount: rest into: Buffer startingAt: leftover + 1.
			ReverbState == nil ifFalse: [
				ReverbState applyReverbTo: Buffer startingAt: leftover + 1 count: rest].

			"record the fact that this sound has already been played into Buffer so that we don't process it again this time around"
			SoundJustStarted := aSound.
		] ifFalse:[
			"quick start failed; reset the sound so we start over"
			aSound reset.
		].
		ActiveSounds add: aSound].
! !
StringReadoutTile subclass: #SoundReadoutTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!SoundReadoutTile commentStamp: 'sw 11/24/2003 15:25' prior: 0!
A tile comprising a readout for a sound-valued instance variable in a Viewer.  It sports up/down  arrows, and a click on the sound name results in a pop-up menu, offering the user the opportunity to choose a new one.!


!SoundReadoutTile methodsFor: 'arrows' stamp: 'sw 1/28/2005 00:57'!
arrowAction: delta
	"Do what is appropriate when an arrow on the tile is pressed; delta will be +1 or -1"

	| soundChoices index |
	soundChoices _ self soundChoices.
	index _ soundChoices indexOf: literal.
	self literal: (soundChoices atWrap: (index + delta)).
	self playSoundNamed: literal! !

!SoundReadoutTile methodsFor: 'arrows' stamp: 'sw 11/24/2003 14:54'!
handlerForMouseDown: anEvent
	"Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event"

	^ ((self findA: UpdatingStringMorph) bounds containsPoint: anEvent cursorPoint)
		ifTrue:
			[self]
		ifFalse:
			[super handlerForMouseDown: anEvent]! !

!SoundReadoutTile methodsFor: 'arrows' stamp: 'sw 1/28/2005 00:56'!
mouseDown: evt
	"Handle a mouse down event"

	| aPoint index isUp soundChoices adjustment |
	upArrow ifNotNil: [((isUp _ upArrow containsPoint: (aPoint _ evt cursorPoint)) or:  [downArrow containsPoint: aPoint])
		ifTrue:
			[soundChoices _ self soundChoices.
			index _ soundChoices indexOf: literal ifAbsent: [1].
			index > 0 ifTrue:
				[adjustment _ isUp ifTrue: [1] ifFalse: [-1].
				self literal: (soundChoices atWrap: (index + adjustment))].
			self playSoundNamed: literal.
			^ self]].
	self soundNameFromUser ifNotNilDo:
		[:aSoundName |
			self literal: aSoundName.
			self playSoundNamed: literal]! !

!SoundReadoutTile methodsFor: 'arrows' stamp: 'yo 2/11/2005 16:12'!
setLiteral: aLiteral
	super  setLiteral: aLiteral.
	(self findA: UpdatingStringMorph) useSymbolFormat; lock! !

!SoundReadoutTile methodsFor: 'arrows' stamp: 'yo 2/11/2005 16:08'!
soundNameFromUser
	"Obtain a sound from the user.  Exclude the items designated as being discouraged, except that if the current selection is one of those, show it anyway"

	| choices |
	choices _ self soundChoices.
	^ (SelectionMenu labels: (choices collect: [:t | t translated]) selections: self soundChoices) startUpWithCaption: 'Sounds' translated! !


!SoundReadoutTile methodsFor: 'literal' stamp: 'sw 1/28/2005 00:57'!
setLiteralTo: anObject width: w
	"Set the literal and width of the tile as indicated"

	| soundChoices index |
	soundChoices _ self soundChoices.
	index _ soundChoices indexOf: anObject.
	self setLiteral: (soundChoices atWrap: index)! !


!SoundReadoutTile methodsFor: 'private' stamp: 'yo 2/11/2005 16:13'!
updateLiteralLabel
	"Update the wording emblazoned on the tile, if needed"

	super updateLiteralLabel.
	(self findA: UpdatingStringMorph) useSymbolFormat; lock! !
Object subclass: #SoundRecorder
	instanceVariableNames: 'stereo samplingRate recordLevel recordedBuffers recordedSound recordProcess bufferAvailableSema paused meteringBuffer meterLevel soundPlaying currentBuffer nextIndex codec desiredSampleRate'
	classVariableNames: 'CanRecordWhilePlaying RecorderActive'
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!SoundRecorder methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
codec: aSoundCodec

	codec := aSoundCodec! !

!SoundRecorder methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
desiredSampleRate: newRate

	"use of this method indicates a strong desire for the specified rate, even if
	the OS/hardware are not cooperative"

	desiredSampleRate := samplingRate := newRate  "Best are 44100 22050 11025"
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jj 10/20/97 15:30'!
isActive
	"Return true if I have a recordProcess running."

	^ recordProcess ~~ nil
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 9/2/97 16:16'!
isPaused
	"Return true if recording is paused."

	^ paused
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 9/18/97 19:19'!
meterLevel
	"Return the meter level, an integer in the range [0..100] where zero is silence and 100 represents the maximum signal level possible without clipping."

	^ (100 * meterLevel) // 32768
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 7/4/1998 15:03'!
recordLevel

	^ recordLevel
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
recordLevel: level
	"Set the desired recording level to the given value in the range 0.0 to 1.0, where 0.0 is the lowest recording level and 1.0 is the maximum. Do nothing if the sound input hardware does not support changing the recording level."
	"Details: On the Macintosh, the lowest possible record level attenuates the input signal, but does not silence it entirely." 

	recordLevel := (level asFloat min: 1.0) max: 0.0.
	recordProcess ifNotNil: [
		self primSetRecordLevel: (1000.0 * recordLevel) asInteger].
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 12/15/97 14:28'!
samplingRate

	^ samplingRate
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
samplingRate: newRate

	samplingRate := newRate  "Best are 44100 22050 11025"
! !


!SoundRecorder methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"SoundRecorder new"

	stereo := false.
	samplingRate := 11025.
	recordLevel := 0.5.
	self initializeRecordingState.
! !

!SoundRecorder methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initializeRecordingState

	recordProcess := nil.
	bufferAvailableSema := nil.
	paused := true.
	meteringBuffer := nil.
	meterLevel := 0.
	soundPlaying := nil.
	currentBuffer := nil.
	nextIndex := 1.
! !


!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primGetActualRecordingSampleRate
	"Return the actual sample rate being used for recording. This primitive fails unless sound recording is currently in progress."

	<primitive: 'primitiveSoundGetRecordingSampleRate' module: 'SoundPlugin'>
	self primitiveFailed
! !

!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primRecordSamplesInto: aWordArray startingAt: index
	"Record a sequence of 16-bit sound samples into the given array starting at the given sample index. Return the number of samples recorded, which may be zero if no samples are currently available."

	<primitive: 'primitiveSoundRecordSamples' module: 'SoundPlugin'>
	self primitiveFailed
! !

!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSetRecordLevel: anInteger
	"Set the desired recording level to the given value in the range 0-1000, where 0 is the lowest recording level and 1000 is the maximum. Do nothing if the sound input hardware does not support changing the recording level."

	<primitive: 'primitiveSoundSetRecordLevel' module: 'SoundPlugin'>
	self primitiveFailed
! !

!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primStartRecordingDesiredSampleRate: samplesPerSec stereo: stereoFlag semaIndex: anInteger
	"Start sound recording with the given stereo setting. Use a sampling rate as close to the desired rate as the underlying platform will support. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled every time a recording buffer is filled."

	<primitive: 'primitiveSoundStartRecording' module: 'SoundPlugin'>
	self primitiveFailed
! !

!SoundRecorder methodsFor: 'primitives' stamp: 'tpr 2/15/2001 17:13'!
primStopRecording
	"Stop sound recording. Does nothing if recording is not currently in progress. Do not fail if plugin is not available"

	<primitive: 'primitiveSoundStopRecording' module: 'SoundPlugin'>! !


!SoundRecorder methodsFor: 'recording controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
clearRecordedSound
	"Clear the sound recorded thus far. Go into pause mode if currently recording."

	paused := true.
	recordedSound := SequentialSound new.
	self allocateBuffer.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'sw 6/10/2003 12:34'!
hasRecordedSound
	"Answer whether the receiver currently has any recorded sound"

	^ self recordedSound notNil! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
pause
	"Go into pause mode. The record level continues to be updated, but no sound is recorded."

	paused := true.
	((currentBuffer ~~ nil) and: [nextIndex > 1])
		ifTrue: [self emitPartialBuffer.
				self allocateBuffer].

	soundPlaying ifNotNil: [
		soundPlaying pause.
		soundPlaying := nil].
	"Note: there can be problems if canRecordWhilePlaying is true. Recorders which only pause will inhibit other recorders from recording. I chose to make #stopPlaying unconditional in a subclass. The same might be appropriate here at the expense of making recorders resumable"

	Preferences canRecordWhilePlaying ifFalse: [self stopRecording].
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
playback
	"Playback the sound that has been recorded."

	self pause.
	soundPlaying := self recordedSound.
	soundPlaying play.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
resumeRecording
	"Continue recording from the point at which it was last paused."

	self flag: #bob.
	"Note: If canRecordWhilePlaying is true, then recordings may never get started (at least by this method). One possibility, used in a subclass, is to make the #startPlaying unconditional. Another would be to use #startPlaying instead of #resumePlaying in appropriate cases"

	Preferences canRecordWhilePlaying ifFalse: [self startRecording].
	paused := false.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
startRecording
	"Turn of the sound input driver and start the recording process. Initially, recording is paused."

	| semaIndex |
	recordLevel ifNil: [recordLevel := 0.5].  "lazy initialization"
	Preferences canRecordWhilePlaying ifFalse: [SoundPlayer shutDown].
	recordProcess ifNotNil: [self stopRecording].
	paused := true.
	meteringBuffer := SoundBuffer newMonoSampleCount: 1024.
	meterLevel := 0.
	self allocateBuffer.
	bufferAvailableSema := Semaphore new.
	semaIndex := Smalltalk registerExternalObject: bufferAvailableSema.
	self primStartRecordingDesiredSampleRate: samplingRate asInteger
		stereo: stereo
		semaIndex: semaIndex.
	RecorderActive := true.
	samplingRate := self primGetActualRecordingSampleRate.
	self primSetRecordLevel: (1000.0 * recordLevel) asInteger.
	recordProcess := [self recordLoop] newProcess.
	recordProcess priority: Processor userInterruptPriority.
	recordProcess resume.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'stephaneducasse 2/4/2006 20:41'!
stopRecording
	"Stop the recording process and turn of the sound input driver."

	recordProcess ifNotNil: [recordProcess terminate].
	recordProcess := nil.
	self primStopRecording.
	RecorderActive := false.
	Smalltalk unregisterExternalObject: bufferAvailableSema.
	((currentBuffer ~~ nil) and: [nextIndex > 1])
		ifTrue: [self emitPartialBuffer].
	self initializeRecordingState.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'sw 3/3/2004 19:49'!
verifyExistenceOfRecordedSound
	"If the receiver has a recorded sound, answer true; if not, put up an informer and answer false"

	^ self recordedSound
		ifNotNil:
			[true]
		ifNil:
			[self inform: 'please record a sound first' translated.
			false]! !


!SoundRecorder methodsFor: 'results' stamp: 'stephaneducasse 2/4/2006 20:41'!
condensedSamples
	"Return a single SoundBuffer that is the contatenation of all my recorded buffers."

	| sz newBuf i |
	recordedBuffers := recordedSound sounds collect: [:snd | snd samples].
	recordedBuffers isEmpty ifTrue: [^ SoundBuffer new: 0].
	recordedBuffers size = 1 ifTrue: [^ recordedBuffers first copy].
	sz := recordedBuffers inject: 0 into: [:tot :buff | tot + buff size].
	newBuf := SoundBuffer newMonoSampleCount: sz.
	i := 1.
	recordedBuffers do: [:b |
		1 to: b size do: [:j |
			newBuf at: i put: (b at: j).
			i := i + 1]].
	recordedBuffers := nil.
	^ newBuf
! !

!SoundRecorder methodsFor: 'results' stamp: 'stephaneducasse 2/4/2006 20:41'!
condensedStereoSound
	"Decompose my buffers into left and right channels and return a mixed sound consisting of the those two channels. This may be take a while, since the data must be copied into new buffers."

	| sz leftBuf rightBuf leftI rightI left |
	sz := recordedBuffers inject: 0 into: [:tot :buff | tot + buff size].
	leftBuf := SoundBuffer newMonoSampleCount: (sz + 1) // 2.
	rightBuf := SoundBuffer newMonoSampleCount: (sz + 1) // 2.
	leftI := rightI := 1.
	left := true.
	recordedBuffers do: [:b |
		1 to: b size do: [:j |
			left
				ifTrue: [leftBuf at: leftI put: (b at: j). leftI := leftI + 1. left := false]
				ifFalse: [rightBuf at: rightI put: (b at: j). rightI := rightI + 1. left := true]]].
	^ MixedSound new
		add: (SampledSound new setSamples: leftBuf samplingRate: samplingRate) pan: 0.0;
		add: (SampledSound new setSamples: rightBuf samplingRate: samplingRate) pan: 1.0
! !

!SoundRecorder methodsFor: 'results' stamp: 'di 2/17/1999 11:07'!
recordedSound
	"Return the sound that was recorded."

	^ recordedSound
! !

!SoundRecorder methodsFor: 'results' stamp: 'di 2/17/1999 21:24'!
soundSegments

	^ self segmentsAbove: 1000 normalizedVolume: 80.0
! !


!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset
	"Return a new SoundBuffer containing the samples in the given range."

	| startBufIndex startSampleIndex endBufIndex endSampleIndex
	 count resultBuf j buf firstInBuf n |
	startBufIndex := startPlace at: 1.
	startSampleIndex := startPlace at: 2.
	endBufIndex := endPlace at: 1.
	endSampleIndex := endPlace at: 2.

	startBufIndex = endBufIndex
		ifTrue: [count := endSampleIndex + 1 - startSampleIndex]
		ifFalse: [
			count := ((recordedBuffers at: startBufIndex) size + 1 - startSampleIndex).  "first buffer"
			count := count + endSampleIndex.  "last buffer"
			startBufIndex + 1 to: endBufIndex - 1 do:
				[:i | count := count + (recordedBuffers at: i) size]].  "middle buffers"
	resultBuf := SoundBuffer newMonoSampleCount: count.

	j := 1.  "next destination index in resultBuf"
	startBufIndex to: endBufIndex do: [:i |
		buf := recordedBuffers at: i.
		firstInBuf := 1.
	 	n := buf size.
		i = startBufIndex ifTrue: [
			n := (recordedBuffers at: startBufIndex) size + 1 - startSampleIndex.
			firstInBuf := startSampleIndex].
		i = endBufIndex ifTrue: [
			i = startBufIndex
				ifTrue: [n := endSampleIndex + 1 - startSampleIndex]
				ifFalse: [n := endSampleIndex]].
		self copyTo: resultBuf from: j to: (j + n - 1)
			from: buf startingAt: firstInBuf
			normalize: nFactor dcOffset: dcOffset.
		j := j + n].
	^ resultBuf
! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
copyTo: resultBuf from: startIndex to: endIndex from: buf startingAt: firstInBuf normalize: nFactor dcOffset: dcOffset
	"Copy samples from buf to resultBuf removing the DC offset and normalizing their volume in the process."

	| indexOffset |
	indexOffset := firstInBuf - startIndex.
	startIndex to: endIndex do: [:i |
		resultBuf at: i put: (((buf at: (i + indexOffset)) - dcOffset) * nFactor) // 1000].
! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 22:11'!
endPlace

	^ Array with: recordedBuffers size with: recordedBuffers last size! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
firstSampleOverThreshold: threshold dcOffset: dcOffset startingAt: startPlace
	"Beginning at startPlace, this routine will return the first place at which a sample exceeds the given threshold."

	| buf s iStart jStart nThreshold |
	nThreshold := threshold negated.
	iStart := startPlace first.
	jStart := startPlace second.
	iStart to: recordedBuffers size do:
		[:i | buf := recordedBuffers at: i.
		jStart to: buf size do:
			[:j | s := (buf at: j) - dcOffset.
			(s < nThreshold or: [s > threshold]) ifTrue:
				["found a sample over threshold"
				^ Array with: i with: j]].
		jStart := 1].
	^ self endPlace! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset
	"Return a normalization factor for the range of sample values and DC offset. A normalization factor is a fixed-point number that will be divided by 1000 after multiplication with each sample value."

	| peak factor |
	peak := (max - dcOffset) max: (min - dcOffset) negated.
	peak = 0 ifTrue: [^ 1000].
	factor := (32767.0 * percentOfMaxVolume) / (100.0 * peak).
	^ (factor * 1000.0) asInteger
! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
place: startPlace plus: nSamples
	"Return the place that is nSamples (may be negative) beyond thisPlace."

	| i j remaining buf |
	i := startPlace first.
	j := startPlace second.
	nSamples >= 0
	ifTrue: [remaining := nSamples.
			[buf := recordedBuffers at: i.
			(j + remaining) <= buf size ifTrue: [^ Array with: i with: j + remaining].
			i < recordedBuffers size]
				whileTrue: [remaining := remaining - (buf size - j + 1).
							i := i+1.  j := 1].
			^ self endPlace]
	ifFalse: [remaining := nSamples negated.
			[buf := recordedBuffers at: i.
			(j - remaining) >= 1 ifTrue: [^ Array with: i with: j - remaining].
			i > 1]
				whileTrue: [remaining := remaining - j.
							i := i-1.  j := (recordedBuffers at: i) size].
			^ #(1 1)]! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
scanForEndThreshold: threshold dcOffset: dcOffset minLull: lull startingAt: startPlace
	"Beginning at startPlace, this routine will find the last sound that exceeds threshold, such that if you look lull samples later you will not find another sound over threshold within the following block of lull samples.
	Return the place that is lull samples beyond to that last sound.
	If no end of sound is found, return endPlace."

	| buf s iStart jStart nThreshold n |
	nThreshold := threshold negated.
	iStart := startPlace first.
	jStart := startPlace second.
	n := 0.
	iStart to: recordedBuffers size do:
		[:i | buf := recordedBuffers at: i.
		jStart to: buf size do:
			[:j | s := (buf at: j) - dcOffset.
			(s < nThreshold or: [s > threshold])
				ifTrue: ["found a sample over threshold"
						n := 0]
				ifFalse: ["still not over threshold"
						n := n + 1.
						n >= lull ifTrue: [^ Array with: i with: j]]].
		jStart := 1].
	^ self endPlace! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
scanForStartThreshold: threshold dcOffset: dcOffset minDur: duration startingAt: startPlace
	"Beginning at startPlace, this routine will find the first sound that exceeds threshold, such that if you look duration samples later you will find another sound over threshold within the following block of duration samples.
	Return the place that is duration samples prior to that first sound.
	If no sound is found, return endPlace."

	| soundPlace lookPlace nextSoundPlace thirdPlace |
	soundPlace := self firstSampleOverThreshold: threshold dcOffset: dcOffset
					startingAt: startPlace.
	[soundPlace = self endPlace ifTrue: [^ soundPlace].
	"Found a sound -- look duration later"
	lookPlace := self place: soundPlace plus: duration.
	nextSoundPlace := self firstSampleOverThreshold: threshold dcOffset: dcOffset
					startingAt: lookPlace.
	thirdPlace := self place: lookPlace plus: duration.
	nextSoundPlace first < thirdPlace first
		or: [nextSoundPlace first = thirdPlace first
			and: [nextSoundPlace second < thirdPlace second]]]
		whileFalse: [soundPlace := nextSoundPlace].

	"Yes, there is sound in the next interval as well"
	^ self place: soundPlace plus: 0-duration
! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
segmentsAbove: threshold normalizedVolume: percentOfMaxVolume
	"Break the current recording up into a sequence of sound segments separated by silences."

	| max min sum totalSamples bufSize s dcOffset firstPlace endPlace resultBuf nFactor lastPlace segments gapSize minDur minLull soundSize restSize |
	stereo ifTrue: [self error: 'stereo trimming is not yet supported'].
	paused ifFalse: [self error: 'must stop recording before trimming'].
	(recordedSound == nil or: [recordedSound sounds isEmpty]) ifTrue:[^ self].
	"Reconstruct buffers so old trimming code will work"
	recordedBuffers := recordedSound sounds collect: [:snd | snd samples].
	soundSize := restSize := 0.

	max := min := sum := totalSamples := 0.
	recordedBuffers do: [:buf |
		bufSize := buf size.
		totalSamples := totalSamples + buf size.
		1 to: bufSize do: [:i |
			s := buf at: i.
			s > max ifTrue: [max := s].
			s < min ifTrue: [min := s].
			sum := sum + s]].
	dcOffset := sum // totalSamples.

	minDur := (samplingRate/20.0) asInteger.  " 1/20 second "
	minLull := (samplingRate/4.0) asInteger.  " 1/2 second "
	segments := SequentialSound new.
	endPlace := self endPlace.
	lastPlace := #(1 1).
	[firstPlace := self scanForStartThreshold: threshold
						dcOffset: dcOffset
						minDur: minDur
						startingAt: lastPlace.
	firstPlace = endPlace]
		whileFalse:
		[firstPlace = lastPlace ifFalse:
			["Add a silence equal to the gap size"
			"Wasteful but simple way to get gap size..."
			gapSize := (self copyFrom: lastPlace to: firstPlace
						normalize: 1000 dcOffset: dcOffset) size - 2.
			"... -2 makes up for overlap of one sample on either end"
			segments add: (RestSound dur: gapSize asFloat / samplingRate).
			restSize := restSize + gapSize.
"Transcript cr; print: firstPlace; space; print: lastPlace; space; print: gapSize; space; show: 'gap'."
			].
		lastPlace := self scanForEndThreshold: threshold
						dcOffset: dcOffset
						minLull: minLull + minDur
						startingAt: firstPlace.
		"Allow room for lead time of next sound"
		lastPlace := self place: lastPlace plus: minDur negated.
		nFactor := self normalizeFactorFor: percentOfMaxVolume
						min: min max: max dcOffset: dcOffset.
		resultBuf := self copyFrom: firstPlace to: lastPlace
						normalize: nFactor dcOffset: dcOffset.
		soundSize := soundSize + resultBuf size.
"Transcript cr; print: firstPlace; space; print: lastPlace; space; print: resultBuf size; space; show: 'sound'."
		segments add: (codec == nil
			ifTrue: [SampledSound new setSamples: resultBuf samplingRate: samplingRate]
			ifFalse: [codec compressSound: (SampledSound new setSamples: resultBuf samplingRate: samplingRate)])].

	"Final gap for consistency"
	gapSize := (self copyFrom: lastPlace to: self endPlace
				normalize: 1000 dcOffset: dcOffset) size - 1.
	segments add: (RestSound dur: gapSize asFloat / samplingRate).
	restSize := restSize + gapSize.
	self inform: ((soundSize+restSize/samplingRate) roundTo: 0.1) printString , ' secs reduced to ' , ((soundSize/samplingRate) roundTo: 0.1) printString.
	recordedBuffers := nil.
	^ segments! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
suppressSilence

	recordedSound := self soundSegments! !

!SoundRecorder methodsFor: 'trimming' stamp: 'stephaneducasse 2/4/2006 20:41'!
trim: threshold normalizedVolume: percentOfMaxVolume
	"Remove the leading and trailing parts of this recording that are below the given threshold. Remove any DC offset and scale the recording so that its peaks are the given percent of the maximum volume."

	| max min sum totalSamples bufSize s dcOffset startPlace endPlace resultBuf nFactor |
	stereo ifTrue: [self error: 'stereo trimming is not yet supported'].
	paused ifFalse: [self error: 'must stop recording before trimming'].
	recordedBuffers := recordedSound sounds collect: [:snd | snd samples].
	recordedBuffers isEmpty ifTrue: [^ self].

	max := min := sum := totalSamples := 0.
	recordedBuffers do: [:buf |
		bufSize := buf size.
		totalSamples := totalSamples + buf size.
		1 to: bufSize do: [:i |
			s := buf at: i.
			s > max ifTrue: [max := s].
			s < min ifTrue: [min := s].
			sum := sum + s]].
	dcOffset := sum // totalSamples.

	"a place is an array of <buffer index><index of sample in buffer>"
	startPlace := self scanForStartThreshold: threshold
					dcOffset: dcOffset
					minDur: (samplingRate/60.0) asInteger "at least 1/60th of a second"
					startingAt: #(1 1).
	startPlace = self endPlace ifTrue:
		["no samples above threshold"
		recordedBuffers := nil.  ^ self].

	endPlace := self scanForEndThreshold: threshold
					dcOffset: dcOffset
					minLull: (samplingRate/5) asInteger
					startingAt: startPlace.
	nFactor := self normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset.
	resultBuf := self copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset.
	recordedSound := SampledSound new setSamples: resultBuf samplingRate: samplingRate.
	recordedBuffers := nil
! !


!SoundRecorder methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
allocateBuffer
	"Allocate a new buffer and reset nextIndex."

	| bufferTime |
	bufferTime := stereo  "Buffer time = 1/2 second"
		ifTrue: [self samplingRate asInteger]
		ifFalse: [self samplingRate asInteger // 2].
	currentBuffer := SoundBuffer newMonoSampleCount:
		"Multiple of samplesPerFrame that is approx. bufferTime long"
		(bufferTime truncateTo: self samplesPerFrame).
	nextIndex := 1.
! !

!SoundRecorder methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
emitBuffer: buffer

	| sound ratio resultBuf |

	"since some sound recording devices cannot (or will not) record below a certain sample rate,
	trim the samples down if the user really wanted fewer samples"

	(desiredSampleRate isNil or: [(ratio := samplingRate // desiredSampleRate) <= 1]) ifTrue: [
		sound := SampledSound new setSamples: buffer samplingRate: samplingRate.
	] ifFalse: [
		resultBuf := SoundBuffer 
			averageEvery: ratio 
			from: buffer 
			upTo: buffer monoSampleCount.
		sound := SampledSound new setSamples: resultBuf samplingRate: samplingRate / ratio.
	].

	recordedSound add: (codec ifNil: [sound] ifNotNil: [codec compressSound: sound])! !

!SoundRecorder methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
emitPartialBuffer
	| s |
	s := self samplesPerFrame.
	self emitBuffer: (currentBuffer copyFrom: 1 to: ((nextIndex-1) +( s-1) truncateTo: s))! !

!SoundRecorder methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
meterFrom: start count: count in: buffer
	"Update the meter level with the maximum signal level in the given range of the given buffer."

	| last max sample |
	count = 0 ifTrue: [^ self].  "no new samples"
	last := start + count - 1.
	max := 0.
	start to: last do: [:i |
		sample := buffer at: i.
		sample < 0 ifTrue: [sample := sample negated].
		sample > max ifTrue: [max := sample]].
	meterLevel := max.
! !

!SoundRecorder methodsFor: 'private' stamp: 'dgd 4/4/2006 16:15'!
recordLoop
	"Record process loop that records samples."

	| n sampleCount |

	n := 0.
	[true] whileTrue: [
		n = 0 ifTrue: [bufferAvailableSema wait].
		paused
			ifTrue: [
				n := self primRecordSamplesInto: meteringBuffer startingAt: 1.
				self meterFrom: 1 count: n in: meteringBuffer]
			ifFalse: [
				n := self primRecordSamplesInto: currentBuffer startingAt: nextIndex.
				self meterFrom: nextIndex count: n in: currentBuffer.
				nextIndex := nextIndex + n.
				stereo
					ifTrue: [sampleCount := currentBuffer stereoSampleCount]
					ifFalse: [sampleCount := currentBuffer monoSampleCount].
				nextIndex > sampleCount
					ifTrue: [
						self emitBuffer: currentBuffer.
						self allocateBuffer]].

		"workaround for OSS emulation on top on ALSA (on Linux environments)"
		(Delay forMilliseconds: 20) wait.
	].
! !

!SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 10:39'!
samplesPerFrame
	"Can be overridden to quantize buffer size for, eg, fixed-frame codecs"

	codec == nil
		ifTrue: [^ 1]
		ifFalse: [^ codec samplesPerFrame]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundRecorder class
	instanceVariableNames: ''!

!SoundRecorder class methodsFor: 'accessing' stamp: 'ar 2/1/2001 15:20'!
anyActive
	"Return true if any sound recorder is actively recording"
	^RecorderActive == true! !

!SoundRecorder class methodsFor: 'accessing' stamp: 'RAA 8/7/2000 19:23'!
canRecordWhilePlaying
	"Return true if this platform supports simultaneous sound recording and playback."

	^Preferences canRecordWhilePlaying.		"now in preferences"
! !


!SoundRecorder class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initialize
	"SoundRecorder initialize"
	"Details: Some computers cannot record and playback sound at the same time. If CanRecordWhilePlaying is false, then the SoundRecorder alternates between recording and playing. If it is true, sounds can be playing during recording."

	CanRecordWhilePlaying := #ignoredNowInPreferences.
! !
RectangleMorph subclass: #SoundSequencerMorph
	instanceVariableNames: 'controlPanel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!SoundSequencerMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2001 18:14'!
makeControlPanel
	| bb cc |
	cc _ Color black.
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	controlPanel _ AlignmentMorph newRow.
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	controlPanel color: bb color; borderWidth: 0; layoutInset: 0.
	controlPanel hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	controlPanel addMorphBack: (bb label: 'reset';	actionSelector: #reset).
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	controlPanel addMorphBack: (bb label: 'stop';		actionSelector: #stop).
	bb _ SimpleButtonMorph new target: self; borderColor: cc.
	controlPanel addMorphBack: (bb label: 'play';	actionSelector: #play).
! !

!SoundSequencerMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
play
	self submorphsDo: [:m | m == controlPanel ifFalse: [m play]]! !

!SoundSequencerMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
reset
	self submorphsDo: [:m | m == controlPanel ifFalse: [m reset]]! !


!SoundSequencerMorph methodsFor: 'initialization' stamp: 'jm 11/14/97 11:21'!
initialize
	super initialize.
	self extent: 550@350.
	self makeControlPanel.
	self addMorph: controlPanel.
	self addMorph: ((SoundLoopMorph newBounds: (10@40 extent: 128@128)) extent: 128@128).
	self addMorph: ((SoundLoopMorph newBounds: (10@200 extent: 512@128)) extent: 512@128).! !


!SoundSequencerMorph methodsFor: 'stepping and presenter' stamp: 'jm 11/14/97 11:21'!
stop
	self submorphsDo: [:m | m == controlPanel ifFalse: [m stop]].
	SoundPlayer shutDown! !
AppRegistry subclass: #SoundService
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Applications'!
!SoundService commentStamp: 'gk 2/24/2004 23:14' prior: 0!
This is the AppRegistry class for the 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 this registry and can be accessed by "SoundService default". 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.!

TileMorph subclass: #SoundTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!SoundTile commentStamp: 'sw 1/28/2005 01:42' prior: 0!
A scripting tile representing a 'sound' constant.  Sounds are represented by their names, which are strings; the actual sounds live in SampleSound's SoundLibrary.!


!SoundTile methodsFor: 'access' stamp: 'gk 2/23/2004 21:08'!
sound

	^ SoundService default soundNamed: literal
! !


!SoundTile methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:28'!
resultType
	"Answer the result type of the receiver"

	^ #Sound! !


!SoundTile methodsFor: 'event handling' stamp: 'sw 1/28/2005 01:49'!
options
	"Answer the options of the tile for an arrow"

	| soundChoices |
	soundChoices _ self soundChoices.
	^ {soundChoices. soundChoices}! !

!SoundTile methodsFor: 'event handling' stamp: 'tak 12/5/2004 02:09'!
value: anObject 
	super value: anObject.
	self playSoundNamed: anObject! !

!SoundTile methodsFor: 'event handling' stamp: 'sw 11/3/97 02:11'!
wantsKeyboardFocusFor: aSubmorph
	^ false! !


!SoundTile methodsFor: 'initialization' stamp: 'yo 7/22/2005 15:51'!
initialize
	"Initialize the state of the receiver. Pick the croak sound
	if available, otherwise any sound."
	
	| soundChoices startingSoundName |
	super initialize.
	soundChoices _ self soundChoices.
	startingSoundName _ (soundChoices includes: 'croak')
							ifTrue: ['croak']
							ifFalse: [[soundChoices anyOne] ifError: ['silence']].
	self addArrows; setLiteral: startingSoundName.
	self labelMorph useSymbolFormat! !

!SoundTile methodsFor: 'initialization' stamp: 'yo 4/6/2005 16:34'!
setLiteral: anObject

	super setLiteral: anObject.
	self labelMorph useSymbolFormat
! !


!SoundTile methodsFor: 'mouse handling' stamp: 'sw 11/24/2003 14:44'!
handlerForMouseDown: anEvent
	"Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event"

	^ ((self findA: UpdatingStringMorph) bounds containsPoint: anEvent cursorPoint)
		ifTrue:
			[self]
		ifFalse:
			[super handlerForMouseDown: anEvent]! !
DataType subclass: #SoundType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!

!SoundType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:29'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ 'croak'! !


!SoundType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:24'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	self vocabularyName: #Sound! !


!SoundType methodsFor: '*eToys-color' stamp: 'sw 9/27/2001 17:21'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(1.0 0.06 0.84)	! !


!SoundType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:30'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ SoundTile new typeColor: self typeColor! !

!SoundType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:37'!
newReadoutTile
	"Answer a tile that can serve as a readout for data of this type"

	^ SoundReadoutTile new typeColor: Color lightGray lighter! !

!SoundType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:33'!
setFormatForDisplayer: aDisplayer
	"Set up the displayer to have the right format characteristics"

	aDisplayer useStringFormat
	! !
SequenceableCollection subclass: #SourceFileArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-System'!
!SourceFileArray commentStamp: '<historical>' prior: 0!
This class is an abstract superclass for source code access mechanisms. It defines the messages that need to be understood by those subclasses that store and retrieve source chunks on files, over the network or in databases.
The first concrete subclass, StandardSourceFileArray, supports access to the traditional sources and changes files. Other subclasses might implement multiple source files for different applications, or access to a network source server.!
]style[(254 23 184)f1,f1LStandardSourceFileArray Comment;,f1!


!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:42'!
at: index
	self subclassResponsibility! !

!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:43'!
at: index put: aFileStream
	self subclassResponsibility! !

!SourceFileArray methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:32'!
collect: aBlock
	| copy |
	copy := self species new: self size.
	1 to: self size do:[:i| copy at: i put: (aBlock value: (self at: i))].
	^copy! !

!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:43'!
size
	self subclassResponsibility! !


!SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:00'!
fileIndexFromSourcePointer: anInteger
	"Return the index of a source file corresponding to the given source pointer."
	self subclassResponsibility! !

!SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:00'!
filePositionFromSourcePointer: anInteger
	"Return the position within a source file for the given source pointer."
	self subclassResponsibility! !

!SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:01'!
sourcePointerFromFileIndex: index andPosition: position
	"Return a sourcePointer encoding the given file index and position"
	self subclassResponsibility! !
Object subclass: #SpaceTally
	instanceVariableNames: 'results'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Tools'!
!SpaceTally commentStamp: 'sd 6/20/2003 22:31' prior: 0!
I'm responsible to help getting information about system space usage. The information I compute is represented by a spaceTallyItem

try something like: 

((SpaceTally new spaceTally: (Array with: TextMorph with: Point)) 
	asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) 

SpaceTally new systemWideSpaceTally


This class has been created from a part of SystemDictionary. It still deserves a nice
clean, such as using object instead of array having 4 slots.

sd-20 June 2003!


!SpaceTally methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:31'!
results

	^ results! !


!SpaceTally methodsFor: 'class analysis' stamp: 'efc 7/6/2004 00:30'!
computeSpaceUsage

	| entry c instanceCount |
	1 to: results size do: [:i |
		entry := results at: i.
		c := self class environment at: entry analyzedClassName.
		instanceCount _ c instanceCount.
		entry codeSize: c spaceUsed.
		entry instanceCount: instanceCount.
		entry spaceForInstances: (self spaceForInstancesOf: c withInstanceCount: instanceCount).
		Smalltalk garbageCollectMost].
	
! !

!SpaceTally methodsFor: 'class analysis' stamp: 'sd 6/20/2003 22:54'!
preAllocateResultsFor: classes

	results := OrderedCollection new: classes size.
	classes do: [:cl | results add: (SpaceTallyItem analyzedClassName: cl name)].
	results _ results asArray.
! !

!SpaceTally methodsFor: 'class analysis' stamp: 'sd 6/20/2003 22:24'!
spaceTally: classes
	"Answer a collection of SpaceTallyItems representing the memory space (in bytes) consumed 	by the code and instances of each class in the system. Note that code sizes do not currently 	report memory consumed by class variables. "

	"((SpaceTally new spaceTally: (Array with: TextMorph with: Point)) asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) asArray"

	self preAllocateResultsFor: classes.
	Smalltalk garbageCollect.
	self computeSpaceUsage.
	^ results
! !

!SpaceTally methodsFor: 'class analysis' stamp: 'efc 7/6/2004 00:25'!
systemWideSpaceTally
	"Answer a collection of SpaceTallyItems representing the memory space (in bytes) consumed 	by the code and instances of each class in the system. Note that code sizes do not currently 	report memory consumed by class variables. "

	"(SpaceTally new systemWideSpaceTally asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) asArray"

	^self spaceTally: Smalltalk allClasses.

! !


!SpaceTally methodsFor: 'fileOut' stamp: 'sd 6/20/2003 22:39'!
compareTallyIn: beforeFileName to: afterFileName
	"SpaceTally new compareTallyIn: 'tally' to: 'tally2'"

	| answer s beforeDict a afterDict allKeys before after diff |
	beforeDict _ Dictionary new.
	s _ FileDirectory default fileNamed: beforeFileName.
	[s atEnd] whileFalse: [
		a _ Array readFrom: s nextLine.
		beforeDict at: a first put: a allButFirst.
	].
	s close.
	afterDict _ Dictionary new.
	s _ FileDirectory default fileNamed: afterFileName.
	[s atEnd] whileFalse: [
		a _ Array readFrom: s nextLine.
		afterDict at: a first put: a allButFirst.
	].
	s close.
	answer _ WriteStream on: String new.
	allKeys _ (Set new addAll: beforeDict keys; addAll: afterDict keys; yourself) asSortedCollection.
	allKeys do: [ :each |
		before _ beforeDict at: each ifAbsent: [#(0 0 0)].
		after _ afterDict at: each ifAbsent: [#(0 0 0)].
		diff _ before with: after collect: [ :vBefore :vAfter | vAfter - vBefore].
		diff = #(0 0 0) ifFalse: [
			answer nextPutAll: each,'  ',diff printString; cr.
		].
	].
	StringHolder new contents: answer contents; openLabel: 'space diffs'.
	


! !

!SpaceTally methodsFor: 'fileOut' stamp: 'sd 6/20/2003 23:04'!
printSpaceAnalysis	
	"SpaceTally new printSpaceAnalysis"

	^ self printSpaceAnalysis: 0 on: 'STspace.text'! !

!SpaceTally methodsFor: 'fileOut' stamp: 'sd 6/20/2003 23:03'!
printSpaceAnalysis: threshold on: fileName
	"SpaceTally new printSpaceAnalysis: 1000 on: 'STspace.text1'"

	"sd-This method should be rewrote to be more coherent within the rest of the class 
	ie using preAllocate and spaceForInstanceOf:"

	"If threshold > 0, then only those classes with more than that number
	of instances will be shown, and they will be sorted by total instance space.
	If threshold = 0, then all classes will appear, sorted by name."

	| f codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n totalPercent percent |
	Smalltalk garbageCollect.
	totalCodeSpace _ totalInstCount _ totalInstSpace _ n _ 0.
	results _ OrderedCollection new: Smalltalk classNames size.
'Taking statistics...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: Smalltalk classNames size
	during: [:bar |
	Smalltalk allClassesDo:
		[:cl | codeSpace _ cl spaceUsed.
		bar value: (n _ n+1).
		Smalltalk garbageCollectMost.
		instCount _ cl instanceCount.
		instSpace _ (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8])*instCount. "Object headers"
		cl isVariable
			ifTrue: [eltSize _ cl isBytes ifTrue: [1] ifFalse: [4].
					cl allInstancesDo: [:x | instSpace _ instSpace + (x basicSize*eltSize)]]
			ifFalse: [instSpace _ instSpace + (cl instSize*instCount*4)].
		results add: (SpaceTallyItem analyzedClassName: cl name codeSize: codeSpace instanceCount:  instCount spaceForInstances: instSpace).
		totalCodeSpace _ totalCodeSpace + codeSpace.
		totalInstCount _ totalInstCount + instCount.
		totalInstSpace _ totalInstSpace + instSpace]].
	totalPercent _ 0.0.

	f _ FileStream newFileNamed: fileName.
	f timeStamp.
	f nextPutAll: ('Class' padded: #right to: 30 with: $ );
			nextPutAll: ('code space' padded: #left to: 12 with: $ );
			nextPutAll: ('# instances' padded: #left to: 12 with: $ );
			nextPutAll: ('inst space' padded: #left to: 12 with: $ );
			nextPutAll: ('percent' padded: #left to: 8 with: $ ); cr.

	threshold > 0 ifTrue:
		["If inst count threshold > 0, then sort by space"
		results _ (results select: [:s | s instanceCount >= threshold or: [s spaceForInstances > (totalInstSpace // 500)]])
				asSortedCollection: [:s :s2 | s spaceForInstances > s2 spaceForInstances]].

	results do:
		[:s | f nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ );
			nextPutAll: (s codeSize printString padded: #left to: 12 with: $ );
			nextPutAll: (s instanceCount printString padded: #left to: 12 with: $ );
			nextPutAll: (s spaceForInstances printString padded: #left to: 14 with: $ ).
		percent _ s spaceForInstances*100.0/totalInstSpace roundTo: 0.1.
		totalPercent _ totalPercent + percent.
		percent >= 0.1 ifTrue:
			[f nextPutAll: (percent printString padded: #left to: 8 with: $ )].
		f cr].

	f cr; nextPutAll: ('Total' padded: #right to: 30 with: $ );
		nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ );
		nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ );
		nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ );
		nextPutAll: ((totalPercent roundTo: 0.1) printString padded: #left to: 8 with: $ ).
	f close! !

!SpaceTally methodsFor: 'fileOut' stamp: 'sd 6/20/2003 23:07'!
printSpaceDifferenceFrom: fileName1 to: fileName2
	"For differential results, run printSpaceAnalysis twice with different fileNames,
	then run this method...
		SpaceTally new printSpaceAnalysis: 0 on: 'STspace.text1'.
			--- do something that uses space here ---
		SpaceTally new printSpaceAnalysis: 0 on: 'STspace.text2'.
		SpaceTally new printSpaceDifferenceFrom: 'STspace.text1' to: 'STspace.text2'
"
	| f coll1 coll2 item |
	f _ FileStream readOnlyFileNamed: fileName1.
	coll1 _ OrderedCollection new.
	[f atEnd] whileFalse: [coll1 add: (f upTo: Character cr)].
	f close.
	f _ FileStream readOnlyFileNamed: fileName2.
	coll2 _ OrderedCollection new.
	[f atEnd] whileFalse:
		[item _ (f upTo: Character cr).
		((coll1 includes: item) and: [(item endsWith: 'percent') not])
			ifTrue: [coll1 remove: item]
			ifFalse: [coll2 add: item]].
	f close.
	(StringHolder new contents: (String streamContents: 
			[:s | 
			s nextPutAll: fileName1; cr.
			coll1 do: [:x | s nextPutAll: x; cr].
			s cr; cr.
			s nextPutAll: fileName2; cr.
			coll2 do: [:x | s nextPutAll: x; cr]]))
		openLabel: 'Differential Space Analysis'.
! !

!SpaceTally methodsFor: 'fileOut' stamp: 'sd 6/20/2003 22:59'!
saveTo: aFileName
	"| st |
	st := SpaceTally new.
	st spaceTally: (Array with: TextMorph with: Point).
	st saveTo: 'spaceTally2'"
	| s |
	(FileDirectory default fileExists: aFileName) ifTrue: [
		FileDirectory default deleteFileNamed: aFileName].
	s _ FileDirectory default fileNamed: aFileName.
	results do: [:each | s nextPutAll: each analyzedClassName asString ; 
						nextPutAll: ' '; nextPutAll: each codeSize printString; 
						nextPutAll: ' '; nextPutAll: each instanceCount printString; 
						nextPutAll: ' '; nextPutAll: each spaceForInstances printString; cr].
	s close! !


!SpaceTally methodsFor: 'instance size' stamp: 'efc 7/6/2004 00:30'!
spaceForInstancesOf: aClass withInstanceCount: instCount
	"Answer the number of bytes consumed by all instances of the given class, including their object headers."

	| isCompact instVarBytes bytesPerElement contentBytes headerBytes total |
	instCount = 0 ifTrue: [^ 0].
	isCompact _ aClass indexIfCompact > 0.
	instVarBytes _ aClass instSize * 4.
	aClass isVariable
		ifTrue: [
			bytesPerElement _ aClass isBytes ifTrue: [1] ifFalse: [4].
			total _ 0.
			aClass allInstancesDo: [:inst |
				contentBytes _ instVarBytes + (inst size * bytesPerElement).
				headerBytes _
					contentBytes > 255
						ifTrue: [12]
						ifFalse: [isCompact ifTrue: [4] ifFalse: [8]].
				total _ total + headerBytes + contentBytes].
			^ total]
		ifFalse: [
			headerBytes _
				instVarBytes > 255
					ifTrue: [12]
					ifFalse: [isCompact ifTrue: [4] ifFalse: [8]].
			^ instCount * (headerBytes + instVarBytes)].
! !
Object subclass: #SpaceTallyItem
	instanceVariableNames: 'analyzedClassName codeSize instanceCount spaceForInstances'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Tools'!
!SpaceTallyItem commentStamp: 'sd 6/20/2003 22:02' prior: 0!
I'm represent an entry in the spaceTally.!


!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:59'!
analyzedClassName

	^ analyzedClassName! !

!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:59'!
analyzedClassName: aClassName

	analyzedClassName := aClassName! !

!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:08'!
codeSize

	^ codeSize! !

!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:09'!
codeSize: aNumber

	codeSize := aNumber! !

!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:09'!
instanceCount

	^ instanceCount! !

!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:09'!
instanceCount: aNumber

	instanceCount := aNumber! !

!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:10'!
spaceForInstances

	^ spaceForInstances! !

!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:10'!
spaceForInstances: aNumber

	spaceForInstances := aNumber! !


!SpaceTallyItem methodsFor: 'printing' stamp: 'sd 6/20/2003 22:52'!
printOn: aStream

	analyzedClassName isNil
		ifFalse: [aStream nextPutAll: analyzedClassName asString]. 
	aStream nextPutAll: ' ('.
	codeSize isNil
		ifFalse: [aStream nextPutAll: 'code size: ' ;  nextPutAll: codeSize asString]. 
	instanceCount isNil
		ifFalse: [aStream nextPutAll: ' instance count: ' ;  nextPutAll: instanceCount asString]. 
	spaceForInstances isNil
		ifFalse: [aStream nextPutAll: ' space for instances: ' ;  nextPutAll: spaceForInstances asString]. 
	aStream nextPut: $).
	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SpaceTallyItem class
	instanceVariableNames: ''!

!SpaceTallyItem class methodsFor: 'instance creation' stamp: 'sd 6/20/2003 22:54'!
analyzedClassName: aClassName

	^ self new
		analyzedClassName: aClassName ; yourself
		! !

!SpaceTallyItem class methodsFor: 'instance creation' stamp: 'sd 6/20/2003 22:54'!
analyzedClassName: aClassName codeSize: codeSize instanceCount: instanceCount spaceForInstances: spaceForInstances

	^ self new
		analyzedClassName: aClassName ;
		codeSize: codeSize ;
		instanceCount: instanceCount ;
		spaceForInstances: spaceForInstances ; yourself! !
ArrayedCollection variableSubclass: #SparseLargeTable
	instanceVariableNames: 'base size chunkSize defaultValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!SparseLargeTable commentStamp: '<historical>' prior: 0!
Derivated from Stephan Pair's LargeArray, but to hold a sparse table, in which most of the entries are the same default value, it uses some tricks.!


!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'!
arrayClass

	^(self basicAt: 1) class
! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'!
at: index

	self pvtCheckIndex: index.
	^self noCheckAt: index.
! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'!
at: index put: value
	
	self pvtCheckIndex: index.
	^self noCheckAt: index put: value
! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 17:56'!
base

	^ base.
! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'!
chunkSize

	^chunkSize
! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'tak 12/21/2004 16:59'!
noCheckAt: index
	| chunkIndex t |

	chunkIndex := index - base // chunkSize + 1.
	(chunkIndex > self basicSize or: [chunkIndex < 1]) ifTrue: [^ defaultValue].
	t _ self basicAt: chunkIndex.
	t ifNil: [^ defaultValue].
	^ t at: (index - base + 1 - (chunkIndex - 1 * chunkSize))
! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 19:18'!
noCheckAt: index put: value
	| chunkIndex t |

	chunkIndex := index - base // chunkSize + 1.
	chunkIndex > self basicSize ifTrue: [^ value].
	t _  self basicAt: chunkIndex.
	t ifNil: [^ value].
	^ t at: (index - base + 1 - (chunkIndex - 1 * chunkSize)) put: value
! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'!
size

	^size
! !

!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 22:34'!
zapDefaultOnlyEntries

	| lastIndex newInst |
	1 to: self basicSize do: [:i |
		(self allDefaultValueSubtableAt: i) ifTrue: [self basicAt: i put: nil].
	].

	lastIndex _ self findLastNonNilSubTable.
	lastIndex = 0 ifTrue: [^ self].
	
	newInst _ self class new: lastIndex*chunkSize chunkSize: chunkSize arrayClass: (self basicAt: lastIndex) class base: base defaultValue: defaultValue.
	newInst privateSize: self size.
	base to: newInst size do: [:i | newInst at: i put: (self at: i)].
	1 to: newInst basicSize do: [:i |
		(newInst allDefaultValueSubtableAt: i) ifTrue: [newInst basicAt: i put: nil].
	].

	self becomeForward: newInst.
	^ newInst.
! !


!SparseLargeTable methodsFor: 'initialization' stamp: 'yo 12/1/2003 16:58'!
initChunkSize: aChunkSize size: aSize arrayClass: aClass base: b defaultValue: d

	| lastChunkSize |
	chunkSize := aChunkSize.
	size := aSize.
	base _ b.
	defaultValue _ d.
	1 to: (self basicSize - 1) do: [ :in | self basicAt: in put: (aClass new: chunkSize withAll: defaultValue) ].
	lastChunkSize := size \\ chunkSize.
	lastChunkSize = 0 ifTrue: [lastChunkSize := chunkSize].
	size = 0 
		ifTrue: [self basicAt: 1 put: (aClass new: 0)]
		ifFalse: [self basicAt: self basicSize put: (aClass new: lastChunkSize withAll: defaultValue)].
! !


!SparseLargeTable methodsFor: 'printing' stamp: 'yo 12/1/2003 17:06'!
printElementsOn: aStream
	| element |
	aStream nextPut: $(.
	base to: size do: [:index | element _ self at: index. aStream print: element; space].
	self isEmpty ifFalse: [aStream skip: -1].
	aStream nextPut: $)
! !

!SparseLargeTable methodsFor: 'printing' stamp: 'yo 12/1/2003 15:58'!
printOn: aStream

	(#(String) includes: self arrayClass name) 
		ifTrue: [^self storeOn: aStream].
	^super printOn: aStream
! !

!SparseLargeTable methodsFor: 'printing' stamp: 'yo 12/1/2003 15:59'!
storeOn: aStream

	| x |
	(#(String) includes: self arrayClass name) ifTrue: 
		[aStream nextPut: $'.
		1 to: self size do:
			[:i |
			aStream nextPut: (x _ self at: i).
			x == $' ifTrue: [aStream nextPut: x]].
		aStream nextPutAll: ''' asLargeArrayChunkSize: '.
		aStream nextPutAll: self chunkSize asString.
		^self].
	^super storeOn: aStream
! !


!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 18:58'!
allDefaultValueSubtableAt: index

	| t |
	t _ self basicAt: index.
	t ifNil: [^ true].
	t do: [:e |
		e ~= defaultValue ifTrue: [^ false].
	].
	^ true.
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 17:10'!
analyzeSpaceSaving

	| total elems tablesTotal nonNilTables |
	total _ size - base + 1.
	elems _ 0.
	base to: size do: [:i | (self at: i) ~= defaultValue ifTrue: [elems _ elems + 1]].
	tablesTotal _ self basicSize.
	nonNilTables _ 0.
	1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [nonNilTables _ nonNilTables + 1]].

	^ String streamContents: [:strm |
		strm nextPutAll: 'total: '.
		strm nextPutAll: total printString.
		strm nextPutAll: ' elements: '.
		strm nextPutAll: elems printString.
		strm nextPutAll: ' tables: '.
		strm nextPutAll: tablesTotal printString.
		strm nextPutAll: ' non-nil: '.
		strm nextPutAll: nonNilTables printString.
	].

! !

!SparseLargeTable methodsFor: 'private' stamp: 'nk 8/31/2004 08:34'!
copyEmpty
	"Answer a copy of the receiver that contains no elements."
	^self speciesNew: 0
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 22:34'!
findLastNonNilSubTable

	(self basicAt: self basicSize) ifNotNil: [^ self basicSize].

	self basicSize - 1 to: 1 by: -1 do: [:lastIndex |
		(self basicAt: lastIndex) ifNotNil: [^ lastIndex].
	].
	^ 0.
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 19:19'!
privateSize: s

	size _ s.
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 17:34'!
pvtCheckIndex: index 

	index isInteger ifFalse: [self errorNonIntegerIndex].
	index < 1 ifTrue: [self errorSubscriptBounds: index].
	index > size ifTrue: [self errorSubscriptBounds: index].
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 15:59'!
similarInstance

	^self class
		new: self size 
		chunkSize: self chunkSize 
		arrayClass: self arrayClass
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 15:59'!
similarInstance: newSize

	^self class
		new: newSize 
		chunkSize: self chunkSize 
		arrayClass: self arrayClass
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 15:59'!
similarSpeciesInstance

	^self similarInstance
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 16:00'!
similarSpeciesInstance: newSize

	^self similarInstance: newSize
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 16:00'!
speciesNew

	^self species
		new: self size 
		chunkSize: self chunkSize 
		arrayClass: self arrayClass
! !

!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 16:00'!
speciesNew: newSize

	^self species
		new: newSize 
		chunkSize: self chunkSize 
		arrayClass: self arrayClass
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SparseLargeTable class
	instanceVariableNames: ''!

!SparseLargeTable class methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:54'!
defaultChunkSize

	^100! !

!SparseLargeTable class methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:54'!
defaultChunkSizeForFiles

	^8000! !


!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:06'!
new: size

	^self new: size chunkSize: self defaultChunkSize
! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:07'!
new: size chunkSize: chunkSize

	^self new: size chunkSize: chunkSize arrayClass: Array
! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:08'!
new: size chunkSize: chunkSize arrayClass: aClass

	^self new: size chunkSize: chunkSize arrayClass: Array base: 1.
! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:37'!
new: size chunkSize: chunkSize arrayClass: aClass base: b

	^self new: size chunkSize: chunkSize arrayClass: Array base: 1 defaultValue: nil.
! !

!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:37'!
new: size chunkSize: chunkSize arrayClass: aClass base: b defaultValue: d

	| basicSize |
	(basicSize := ((size - 1) // chunkSize) + 1) = 0
		ifTrue: [basicSize := 1].
	^(self basicNew: basicSize)
		initChunkSize: chunkSize size: size arrayClass: aClass base: b defaultValue: d;
		yourself
! !
Object subclass: #SparseXTable
	instanceVariableNames: 'tables xTables'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!SparseXTable methodsFor: 'as yet unclassified' stamp: 'yo 7/30/2003 17:38'!
tableFor: code

	| div t table |
	div _ code // 65536.
	t _ xTables at: div ifAbsent: [table _ Array new: 65536 withAll: 0. xTables at: div put: table. table].
	^ t.
! !
Object subclass: #Speaker
	instanceVariableNames: 'pitch range loudness speed transcriber voice visitors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:33'!
loudness
	^ loudness! !

!Speaker methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
loudness: aNumber
	loudness := aNumber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/13/1999 03:02'!
phonemes
	"Answer the phoneme set of the receiver."
	^ self transcriber phonemes! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/12/1999 23:18'!
pitch
	"Answer the average pitch."
	^ pitch! !

!Speaker methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
pitch: aNumber
	"Set the average pitch."
	pitch := aNumber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/12/1999 23:18'!
range
	"Answer the pitch range (variation)."
	^ range! !

!Speaker methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
range: aNumber
	"Set the pitch range (variation)."
	range := aNumber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:33'!
speed
	^ speed! !

!Speaker methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
speed: aNumber
	speed := aNumber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:31'!
transcriber
	^ transcriber! !

!Speaker methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
transcriber: aPhoneticTranscriber
	transcriber := aPhoneticTranscriber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/12/1999 23:02'!
visitors
	^ visitors! !

!Speaker methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
visitors: aCollection
	visitors := aCollection! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:32'!
voice
	^ voice! !

!Speaker methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
voice: aVoice
	voice := aVoice! !


!Speaker methodsFor: 'editing' stamp: 'stephaneducasse 2/3/2006 22:23'!
edit
	| answer buttons |
	answer := (self findAVoice: KlattVoice) editor.
	buttons := AlignmentMorph new listDirection: #leftToRight; color: answer color.
	buttons
		addMorphFront: (SimpleButtonMorph new target: self; actWhen: #buttonDown; actionSelector:  #newHead; labelString: 'new head');
		addMorphFront: (SimpleButtonMorph new target: self; actWhen: #buttonDown; actionSelector:  #saySomething; labelString: 'test').
	answer
		addSliderForParameter: #speed target: self min: 0.1 max: 2.0 description: 'Speed';
		addSliderForParameter: #loudness target: self min: 0.0 max: 1.0 description: 'Loudness';
		addSliderForParameter: #range target: self min: 0.0 max: 1.0 description: 'Pitch Range';
		addSliderForParameter: #pitch target: self min: 20.0 max: 800.0 description: 'Pitch';
		addMorphFront: buttons;
		openInWorld! !

!Speaker methodsFor: 'editing' stamp: 'len 12/2/1999 03:19'!
findAVoice: aClass
	(self voice isKindOf: aClass) ifTrue: [^ self voice].
	(self voice isKindOf: CompositeVoice)
		ifTrue: [self voice do: [ :each | (each isKindOf: aClass) ifTrue: [^ each]]].
	^ nil! !

!Speaker methodsFor: 'editing' stamp: 'len 12/2/1999 03:27'!
makeGestural
	(self findAVoice: GesturalVoice) isNil ifFalse: [^ self].
	self voice: self voice + GesturalVoice new! !

!Speaker methodsFor: 'editing' stamp: 'len 12/2/1999 03:27'!
newHead
	self makeGestural.
	(self findAVoice: GesturalVoice) newHead! !

!Speaker methodsFor: 'editing' stamp: 'len 12/14/1999 05:24'!
saySomething
	self say: #('This is my voice.' 'I am speaking.' 'Do you like my voice?' 'Listen to my voice.' 'Hello.' 'Hay. What are you doing?' 'How are you?' 'Is this my voice?' 'Are you there?' 'Help, please.' 'Howdy.' 'Ha ha he he hi.') atRandom! !


!Speaker methodsFor: 'initialization' stamp: 'len 11/27/2000 09:59'!
initialize
	self pitch: 100.0; range: 0.3; loudness: 1.0; speed: 0.6; "normalizer: TextNormalizer new;" transcriber: PhoneticTranscriber default; visitors: {IntonationVisitor default. DurationsVisitor default. F0RenderingVisitor default}! !


!Speaker methodsFor: 'parsing' stamp: 'len 12/14/1999 02:13'!
clauseFromString: aString
	^ Clause new
		string: aString;
		phrases: ((aString findTokens: '!!?.,;()') collect: [ :each | self phraseFromString: each])! !

!Speaker methodsFor: 'parsing' stamp: 'stephaneducasse 2/3/2006 22:23'!
eventsFromString: aString
	| clause |
	clause := self clauseFromString: aString.
	clause phrases do: [ :each | each lastSyllable events add: (PhoneticEvent new phoneme: self phonemes silence; duration: 0.1)].
	clause lastSyllable events last duration: 0.5.
	visitors do: [ :each | each speaker: self. clause accept: each].
	clause eventsDo: [ :each | each loudness: self loudness].
	^ clause events! !

!Speaker methodsFor: 'parsing' stamp: 'len 12/13/1999 03:19'!
phraseFromString: aString
	^ Phrase new
		string: aString;
		words: ((aString findTokens: ' !!?.,;()') collect: [ :each | self wordFromString: each])! !

!Speaker methodsFor: 'parsing' stamp: 'stephaneducasse 2/3/2006 22:23'!
syllabizationOf: phonemes
	| syllable stream last answer |
	answer := OrderedCollection new.
	syllable := Syllable new phonemes: (OrderedCollection new: 4).
	stream := ReadStream on: phonemes.
	[stream atEnd]
		whileFalse: [syllable phonemes add: (last := stream next).
					(stream atEnd not and: [last isConsonant not and: [stream peek isConsonant]])
						ifTrue: [answer add: syllable. syllable := Syllable new phonemes: (OrderedCollection new: 4)]].
	syllable phonemes isEmpty ifFalse: [answer add: syllable].
	^ answer! !

!Speaker methodsFor: 'parsing' stamp: 'len 12/8/1999 18:24'!
wordFromString: aString
	^ Word new
		string: aString;
		syllables: (self syllabizationOf: (self transcriber transcriptionOf: aString))! !


!Speaker methodsFor: 'playing' stamp: 'nk 2/19/2004 16:50'!
numberSignDelay
	"Answer the number of milliseconds that a # symbol in the string given to say: will generate."
	^200! !

!Speaker methodsFor: 'playing' stamp: 'stephaneducasse 2/3/2006 22:23'!
say: aString 
	"aString may contain characters and punctuation.
	You may also include the # symbol in aString;
	for each one of these, a 200msec delay will be generated."

	| events stream string token delay |

	stream := ReadStream
				on: ((aString
						copyReplaceAll: '-'
						with: ' '
						asTokens: false)
						findTokens: '?# '
						keep: '?#').
	string := ''.
	delay := 0.
	[stream atEnd]
		whileFalse: [token := stream next.
			token = '#'
				ifTrue: [ self voice playSilenceMSecs: self numberSignDelay.
					delay := delay + self numberSignDelay ]
				ifFalse: [string := string , ' ' , token.
					(token = '?' or: [stream atEnd])
						ifTrue: [
							events := CompositeEvent new.
							events addAll: (self eventsFromString: string).
							events playOn: self voice delayed: delay.
							delay := delay + (events duration * 1000).
							string := ''  ]]].
	self voice flush! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Speaker class
	instanceVariableNames: ''!

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:17'!
bicyclic
	"
	Speaker bicyclic say: 'This is my voice. I am a woman with bicyclic voice.'
	"

	^ self new
		pitch: 200.0;
		voice: (KlattVoice new diplophonia: 0.4; tract: 14.4)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:56'!
bigMan
	"
	Speaker bigMan say: 'I am the child? No. I am the big man speaking.'
	"

	^ self new
		pitch: 90.0;
		range: 0.5;
		voice: (KlattVoice new tract: 20)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:19'!
breathy
	"
	Speaker breathy say: 'This is my breathy voice.'
	"

	^ self new
		pitch: 100.0;
		voice: (KlattVoice new ro: 0.6; turbulence: 70)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:07'!
child
	"
	Speaker child say: 'Hello. I am a child speaking.'
	"

	^ self new
		pitch: 320.0;
		voice: (KlattVoice new tract: 12)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:21'!
creaky
	"
	Speaker creaky say: 'This is my creaky voice with hight jitter and shimmer.'
	"

	^ self new
		pitch: 90.0;
		speed: 0.5;
		voice: (KlattVoice new jitter: 0.5; shimmer: 0.5)! !

!Speaker class methodsFor: 'examples' stamp: 'len 11/27/2000 10:01'!
default
	"
	Speaker default say: 'This is the default voice.'
	"

	^ self new voice: KlattVoice new! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:13'!
exorsist
	"
	Speaker exorsist say: 'This is an scary voice. Boo.'
	"

	^ self new
		pitch: 40.0;
		speed: 0.5;
		voice: (KlattVoice new tract: 10; diplophonia: 0.4; jitter: 0.3; shimmer: 0.5; turbulence: 50)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:13'!
fly
	"
	Speaker fly say: 'Haaaaaalp.'
	"

	^ self new
		pitch: 650.0;
		loudness: 0.5;
		speed: 0.8;
		voice: (KlattVoice new flutter: 1.0; tract: 1)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:01'!
kid
	"
	Speaker kid say: 'Do you like my voice? I am the kid speaking.'
	"

	^ self new
		pitch: 170.0;
		range: 0.4;
		voice: (KlattVoice new tract: 16)! !

!Speaker class methodsFor: 'examples' stamp: 'len 11/27/2000 10:01'!
man
	"
	Speaker man say: 'Listen to my voice. I am a man speaking.'
	"

	^ self default pitch: 90.0! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:26'!
notPressed
	"
	Speaker notPressed say: 'This is a non pressed voice.'
	"

	^ self new
		pitch: 100.0;
		voice: (KlattVoice new ro: 0.9)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:26'!
pressed
	"
	Speaker pressed say: 'This is a pressed voice.'
	"

	^ self new
		pitch: 100.0;
		voice: (KlattVoice new ro: 0.1)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:27'!
whispery
	"
	Speaker whispery say: 'This is my whispery voice.'
	"

	^ self new
		voice: (KlattVoice new breathiness: 1.0)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:10'!
woman
	"
	Speaker woman say: 'Do you listen? I am a woman speaking.'
	"

	^ self new
		pitch: 230.0;
		range: 0.5;
		speed: 0.7;
		voice: (KlattVoice new flutter: 0.5; ro: 0.3; ra: 0.003; tract: 14.4)! !


!Speaker class methodsFor: 'examples-others' stamp: 'len 12/2/1999 03:46'!
manWithEditor
	"
	Speaker manWithEditor say: 'With this editor you can change my voice.'
	"

	^ self man edit! !

!Speaker class methodsFor: 'examples-others' stamp: 'len 12/14/1999 05:10'!
manWithHead
	"
	Speaker manWithHead say: 'This is my voice. Can you see my lips?'
	"

	^ self man newHead! !
Morph subclass: #SpeakerMorph
	instanceVariableNames: 'bufferSize buffer lastConePosition sound'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!

!SpeakerMorph methodsFor: 'initialization' stamp: 'nk 6/12/2004 10:05'!
addGraphic

	| graphic |
	graphic _ World drawingClass withForm: self speakerGraphic.
	graphic position: bounds center - (graphic extent // 2).
	self addMorph: graphic.
! !

!SpeakerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:51'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 1.0
		g: 0.484
		b: 0.258! !

!SpeakerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:51'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self addGraphic.
	bufferSize _ 5000.
	buffer _ WriteStream
				on: (SoundBuffer newMonoSampleCount: bufferSize).
	lastConePosition _ 0.
	sound _ SequentialSound new! !

!SpeakerMorph methodsFor: 'initialization' stamp: 'jm 4/22/1999 22:58'!
speakerGraphic

	^ Form
		extent: 19@18
		depth: 8
		fromArray: #(0 0 1493172224 2816 0 0 0 1493172224 11 0 0 138 1493172224 184549376 184549376 0 35509 2315255808 720896 720896 0 9090522 2315255808 2816 720896 0 2327173887 2315255819 2816 720896 138 3051028442 2315255819 2816 2816 1505080590 4294957786 2315255808 184549387 2816 3053453311 4292532917 1493172224 184549387 2816 1505080714 3048584629 1493172224 184549387 2816 9079434 3048584629 1493172224 184549387 2816 138 2327164341 1493172235 2816 2816 0 2324346293 1493172235 2816 720896 0 9079477 1493172224 2816 720896 0 35466 1493172224 720896 720896 0 138 0 184549376 184549376 0 0 0 11 0 0 0 0 2816 0)
		offset: 0@0
! !


!SpeakerMorph methodsFor: 'speaker' stamp: 'jdl 3/28/2003 09:38'!
appendSample: aFloat 
	"Append the given sample, a number between -100.0 and 100.0, to my buffer. Flush the buffer if it is full."

	lastConePosition := aFloat.
	lastConePosition := lastConePosition min: 100.0.
	lastConePosition := lastConePosition max: -100.0.
	buffer nextPut: (327.67 * lastConePosition) truncated.
	buffer position >= bufferSize ifTrue: [self flushBuffer]
! !

!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/21/1999 10:18'!
conePosition

	^ lastConePosition
! !

!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/22/1999 16:46'!
conePosition: aNumber

	self appendSample: aNumber asFloat.  "sets lastConePosition"
! !

!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/22/1999 13:29'!
flushBuffer

	| buf |
	buf _ buffer contents.
	buffer resetContents.
	sound isPlaying ifFalse: [sound _ SequentialSound new].
	sound add: (SampledSound samples: buf samplingRate: 11025).
	sound isPlaying
		ifTrue: [sound pruneFinishedSounds]
		ifFalse: [sound play].
! !

!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/22/1999 15:33'!
stopSound

	sound pause.
	buffer resetContents.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SpeakerMorph class
	instanceVariableNames: ''!

!SpeakerMorph class methodsFor: '*eToys-scripting' stamp: 'sw 9/26/2001 04:27'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^  #((speaker

((slot conePosition  'the position of the speaker cone' Number readWrite Player getConePosition Player setConePosition:))))



! !
AlignmentMorph subclass: #SpectrumAnalyzerMorph
	instanceVariableNames: 'soundInput statusLight levelMeter graphMorph sonogramMorph fft displayType'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!
!SpectrumAnalyzerMorph commentStamp: '<historical>' prior: 0!
I am a tool for analyzing sound data from a microphone, CD, or other input source in real time. I have several display modes:

	signal		snapshots of the raw signal data as it arrives
	spectrum	frequency spectrum of the signal data as it arrives
	sonogram	scrolling plot of the frequency spectrum over time,
			      where the vertical axis is frequency, the horizontal
				  axis is time, and amount of energy at a given
				  frequency is shown as a grayscale value with
				  larger values being darker

To use this tool, be sure that you have selected the proper sound source using you host OS facilities. Set the desired sampling rate and FFT size (try 22050 samples/sec and an FFT size of 512) then click on the 'start' button. Use the slider to adjust the level so that the yellow level indicator peaks somewhere between the middle and the right edge at the maximum signal level.

Note that if the level meter peaks hit the right edge, you will get 'clipping', which creates a bunch of spurious high frequency noise in the frequency spectrum. If the display is set to 'signal' mode, you can actually see the tops and bottoms of the waveform being cut off when clipping occurs.

Many machines may not be able to perform spectrum analysis in real time, especially at higher sampling rates and larger FFT sizes. In both 'signal' and 'spectrum' modes, this tool will skip data to try to keep up with real time. However, in 'sonogram' mode it always processes all the data, even if it falls behind. This allows you to get a complete sonogram without dropouts even on a slower machine. However, as the sonogram display falls behind there will be a larger and larger time lag between when a sound is input and when it appears on the display.

The smaller the FFT size, the less frequency resolution you get. The lower the sampling rate, the less total frequency range you get. For an FFT size of N and a sampling rate of R, each of the N/2 'bins' of the frequency spectrum has a frequency resolution of R / N. For example, at a sampleing rate of 22050 samples/second, the total frequency range is 0 to 11025 Hz and an FFT of size 256 would divide this range into 128 bins (the output of an FFT of size N has N/2 bins), each of which covers a frequency band about 86 Hz wide.

To increase time resolution, increase the sampling rate and decrease the FFT size.
!


!SpectrumAnalyzerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:52'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 2! !

!SpectrumAnalyzerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:52'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self listDirection: #topToBottom.
	soundInput _ SoundInputStream new samplingRate: 22050.
	fft _ FFT new: 512.
	displayType _ 'sonogram'.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self addButtonRow.
	self addLevelSlider.
	self addMorphBack: self makeLevelMeter.
	self addMorphBack: (Morph new extent: 10 @ 10;
			 color: Color transparent).
	"spacer"
	self resetDisplay! !


!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'dgd 9/19/2003 13:25'!
invokeMenu
	"Invoke the settings menu."

	| aMenu |
	aMenu _ CustomMenu new.
	aMenu addList:	{
		{'set sampling rate' translated.		#setSamplingRate}.
		{'set FFT size' translated.			#setFFTSize}.
		{'set display type' translated.		#setDisplayType}}.
	aMenu invokeOn: self defaultSelection: nil.
! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 12:52'!
resetDisplay
	"Recreate my display after changing some parameter such as FFT size."

	displayType = 'signal' ifTrue: [self showSignal].
	displayType = 'spectrum' ifTrue: [self showSpectrum].
	displayType = 'sonogram' ifTrue: [self showSonogram].
! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'dgd 9/19/2003 13:29'!
setDisplayType
	"Set the display type."

	| aMenu choice on |
	aMenu _ CustomMenu new title: ('display type (currently {1})' translated format:{displayType}).
	aMenu addList:	{
		{'signal' translated.	'signal'}.
		{'spectrum' translated.	'spectrum'}.
		{'sonogram' translated.	'sonogram'}}.
	choice _ aMenu startUp.
	choice ifNil: [^ self].

	on _ soundInput isRecording.
	self stop.
	displayType _ choice.
	self resetDisplay.
	on ifTrue: [self start].

! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'dgd 9/19/2003 13:27'!
setFFTSize
	"Set the size of the FFT used for frequency analysis."

	| aMenu sz on |
	aMenu _ CustomMenu new title: ('FFT size (currently {1})' translated format:{fft n}).
	((7 to: 10) collect: [:n | 2 raisedTo: n]) do:[:r | aMenu add: r printString action: r].
	sz _ aMenu startUp.
	sz ifNil: [^ self].
	on _ soundInput isRecording.
	self stop.
	fft _ FFT new: sz.
	self resetDisplay.
	on ifTrue: [self start].
! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'dgd 9/19/2003 13:26'!
setSamplingRate
	"Set the sampling rate to be used for incoming sound data."

	| aMenu rate on |
	aMenu _ CustomMenu new title:
		('Sampling rate (currently {1})' translated format:{soundInput samplingRate}).
	#(11025 22050 44100) do:[:r | aMenu add: r printString action: r].
	rate _ aMenu startUp.
	rate ifNil: [^ self].
	on _ soundInput isRecording.
	self stop.
	soundInput samplingRate: rate.
	self resetDisplay.
	on ifTrue: [self start].

! !


!SpectrumAnalyzerMorph methodsFor: 'stepping and presenter' stamp: 'jm 9/8/1999 15:12'!
start
	"Start displaying sound data."

	displayType = 'signal'
		ifTrue: [soundInput bufferSize: graphMorph width - (2 * graphMorph borderWidth)]
		ifFalse: [soundInput bufferSize: fft n].
	soundInput startRecording.
! !

!SpectrumAnalyzerMorph methodsFor: 'stepping and presenter' stamp: 'jm 9/8/1999 19:05'!
step
	"Update the record light, level meter, and display."

	| w |
	"update the record light and level meter"
	soundInput isRecording
		ifTrue: [statusLight color: Color yellow]
		ifFalse: [statusLight color: Color gray].
	w _ ((121 * soundInput meterLevel) // 100) max: 1.
	levelMeter width ~= w ifTrue: [levelMeter width: w].

	"update the display if any data is available"
	self updateDisplay.
! !

!SpectrumAnalyzerMorph methodsFor: 'stepping and presenter' stamp: 'jm 9/8/1999 15:12'!
stop
	"Stop displaying sound data."

	soundInput stopRecording.
! !

!SpectrumAnalyzerMorph methodsFor: 'stepping and presenter' stamp: 'jm 9/6/1999 12:12'!
stopStepping
	"Turn off recording."

	super stopStepping.
	soundInput stopRecording.
! !


!SpectrumAnalyzerMorph methodsFor: 'submorphs-add/remove' stamp: 'jm 9/6/1999 14:40'!
delete
	"Turn off recording when this morph is deleted."

	super delete.
	soundInput stopRecording.
! !


!SpectrumAnalyzerMorph methodsFor: 'testing' stamp: 'jm 9/7/1999 22:26'!
stepTime

	^ 0
! !


!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'dgd 9/19/2003 13:30'!
addButtonRow

	| r |
	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: (self buttonName: 'Menu' translated action: #invokeMenu).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Start' translated action: #start).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' translated action: #stop).
	r addMorphBack: (Morph new extent: 12@1; color: Color transparent).
	r addMorphBack: self makeStatusLight.
	self addMorphBack: r.
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'ar 11/9/2000 21:23'!
addLevelSlider

	| levelSlider r |
	levelSlider _ SimpleSliderMorph new
		color: color;
		extent: 100@2;
		target: soundInput;
		actionSelector: #recordLevel:;
		adjustToValue: soundInput recordLevel.
	r _ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '0 ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' 10').
	self addMorphBack: r.
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jhm 10/15/97 14:30'!
buttonName: aString action: aSymbol

	^ SimpleButtonMorph new
		target: self;
		label: aString;
		actionSelector: aSymbol
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 13:27'!
makeLevelMeter

	| outerBox |
	outerBox _ RectangleMorph new extent: 125@14; color: Color lightGray.
	levelMeter _ Morph new extent: 2@10; color: Color yellow.
	levelMeter position: outerBox topLeft + (2@2).
	outerBox addMorph: levelMeter.
	^ outerBox
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'dgd 9/19/2003 13:31'!
makeStatusLight

	| s |
	statusLight _ RectangleMorph new extent: 24@19.
	statusLight color: Color gray.
	s _ StringMorph contents: 'On' translated.
	s position: statusLight center - (s extent // 2).
	statusLight addMorph: s.
	^ statusLight
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'gm 2/28/2003 00:11'!
processBuffer: buf 
	"Analyze one buffer of data."

	| data |
	data := displayType = 'signal' 
		ifTrue: [buf]
		ifFalse: [fft transformDataFrom: buf startingAt: 1].
	graphMorph ifNotNil: 
			[graphMorph
				data: data;
				changed].
	sonogramMorph ifNotNil: 
			[data := data collect: [:v | v sqrt].	"square root compresses dynamic range"
			data /= 400.0.
			sonogramMorph plotColumn: (data copyFrom: 1 to: data size // 1)]! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 12:49'!
removeAllDisplays
	"Remove all currently showing displays."

	sonogramMorph ifNotNil: [sonogramMorph delete].
	graphMorph ifNotNil: [graphMorph delete].
	sonogramMorph _ graphMorph _ nil.
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:56'!
showSignal
	"Display the actual signal waveform."

	displayType _ 'signal'.
	self removeAllDisplays.
	graphMorph _ GraphMorph new.
	graphMorph extent: (400 + (2 * graphMorph borderWidth))@128.
	graphMorph data: (Array new: 100 withAll: 0).
	graphMorph color: (Color r: 0.8 g: 1.0 b: 1.0).
	self addMorphBack: graphMorph.
	self extent: 10@10.  "shrink to minimum size"
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:43'!
showSonogram
	"Display a sonogram showing the frequency spectrum versus time."

	| zeros h w |
	displayType _ 'sonogram'.
	self removeAllDisplays.
	h _ fft n // 2.
	h _ h min: 512 max: 64.
	w _ 400.
	sonogramMorph _
		Sonogram new
			extent: w@h
			minVal: 0.0
			maxVal: 1.0
			scrollDelta: w.
	zeros _ Array new: sonogramMorph height withAll: 0.
	sonogramMorph width timesRepeat: [sonogramMorph plotColumn: zeros].
	self addMorphBack: sonogramMorph.
	self extent: 10@10.  "shrink to minimum size"
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 15:10'!
showSpectrum
	"Display the frequency spectrum."

	displayType _ 'spectrum'.
	self removeAllDisplays.
	graphMorph _ GraphMorph new.
	graphMorph extent: ((fft n // 2) + (2 * graphMorph borderWidth))@128.
	graphMorph data: (Array new: fft n // 2 withAll: 0).
	self addMorphBack: graphMorph.
	self extent: 10@10.  "shrink to minimum size"
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:39'!
updateDisplay
	"Update the display if any data is available."

	| buf bufCount |
	soundInput bufferCount = 0 ifTrue: [^ self].

	graphMorph ifNotNil: [
		[soundInput bufferCount > 0] whileTrue: [
			"skip to the most recent buffer"
			buf _ soundInput nextBufferOrNil].
		^ self processBuffer: buf].

	sonogramMorph ifNotNil: [
		"at small buffer sizes we have to update the sonogram in
		 batches or we may get behind; shoot for 8 updates/second"
		bufCount _ (soundInput samplingRate / (8 * soundInput bufferSize)) truncated max: 1.
		[bufCount > 0 and: [soundInput bufferCount > 0]] whileTrue: [
			self processBuffer: (soundInput nextBufferOrNil)]].
! !
Path subclass: #Spline
	instanceVariableNames: 'coefficients'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Spline commentStamp: '<historical>' prior: 0!
I represent a collection of Points through which a cubic spline curve is fitted.!


!Spline methodsFor: 'accessing'!
coefficients
	"Answer an eight-element Array of Arrays each of which is the length 
	of the receiver. The first four arrays are the values, first, second and 
	third derivatives, respectively, for the parametric spline in x. The last 
	four elements are for y."

	^coefficients! !


!Spline methodsFor: 'displaying'!
computeCurve
	"Compute an array for the coefficients."

	| length extras |
	length _ self size.
	extras _ 0.
	coefficients _ Array new: 8.
	1 to: 8 do: [:i | coefficients at: i put: (Array new: length + extras)].
	1 to: 5 by: 4 do: 
		[:k | 
		1 to: length do:
			[:i | (coefficients at: k)
					at: i put: (k = 1
						ifTrue: [(self at: i) x asFloat]
						ifFalse: [(self at: i) y asFloat])].
			1 to: extras do: [:i | (coefficients at: k)
					at: length + i put: ((coefficients at: k)
						at: i + 1)].
			self derivs: (coefficients at: k)
				first: (coefficients at: k + 1)
				second: (coefficients at: k + 2)
				third: (coefficients at: k + 3)].
	extras > 0 
		ifTrue: [1 to: 8 do: 
					[:i | 
					coefficients at: i put: ((coefficients at: i)
											copyFrom: 2 to: length + 1)]]! !

!Spline methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Display the receiver, a spline curve, approximated by straight line
	segments."

	| n line t x y x1 x2 x3 y1 y2 y3 |
	collectionOfPoints size < 1 ifTrue: [self error: 'a spline must have at least one point'].
	line _ Line new.
	line form: self form.
	line beginPoint: 
		(x _ (coefficients at: 1) at: 1) rounded @ (y _ (coefficients at: 5) at: 1) rounded.
	1 to: (coefficients at: 1) size - 1 do: 
		[:i | 
		"taylor series coefficients"
		x1 _ (coefficients at: 2) at: i.
		y1 _ (coefficients at: 6) at: i.
		x2 _ ((coefficients at: 3) at: i) / 2.0.
		y2 _ ((coefficients at: 7) at: i) / 2.0.
		x3 _ ((coefficients at: 4) at: i) / 6.0.
		y3 _ ((coefficients at: 8) at: i) / 6.0.
		"guess n"
		n _ 5 max: (x2 abs + y2 abs * 2.0 + ((coefficients at: 3)
							at: i + 1) abs + ((coefficients at: 7)
							at: i + 1) abs / 100.0) rounded.
		1 to: n - 1 do: 
			[:j | 
			t _ j asFloat / n.
			line endPoint: 
				(x3 * t + x2 * t + x1 * t + x) rounded 
							@ (y3 * t + y2 * t + y1 * t + y) rounded.
			line
				displayOn: aDisplayMedium
				at: aPoint
				clippingBox: clipRect
				rule: anInteger
				fillColor: aForm.
			line beginPoint: line endPoint].
		line beginPoint: 
				(x _ (coefficients at: 1) at: i + 1) rounded 
					@ (y _ (coefficients at: 5) at: i + 1) rounded.
		line
			displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!Spline methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Get the scaled and translated path of newKnots."

	| newKnots newSpline |
	newKnots _ aTransformation applyTo: self.
	newSpline _ Spline new.
	newKnots do: [:knot | newSpline add: knot].
	newSpline form: self form.
	newSpline
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !


!Spline methodsFor: 'private'!
derivs: a first: point1 second: point2 third: point3
	"Compute the first, second and third derivitives (in coefficients) from
	the Points in this Path (coefficients at: 1 and coefficients at: 5)."

	| l v anArray |
	l _ a size.
	l < 2 ifTrue: [^self].
	l > 2
	  ifTrue:
		[v _ Array new: l.
		 v  at:  1 put: 4.0.
		 anArray _ Array new: l.
		 anArray  at:  1 put: (6.0 * ((a  at:  1) - ((a  at:  2) * 2.0) + (a  at:  3))).
		 2 to: l - 2 do:
			[:i | 
			v  at:  i put: (4.0 - (1.0 / (v  at:  (i - 1)))).
			anArray
				at:  i 
				put: (6.0 * ((a  at:  i) - ((a  at:  (i + 1)) * 2.0) + (a  at:  (i + 2)))
						- ((anArray  at:  (i - 1)) / (v  at:  (i - 1))))].
		 point2  at: (l - 1) put: ((anArray  at:  (l - 2)) / (v  at:  (l - 2))).
		 l - 2 to: 2 by: 0-1 do: 
			[:i | 
			point2 
				at: i 
				put: ((anArray  at:  (i - 1)) - (point2  at:  (i + 1)) / (v  at:  (i - 1)))]].
	point2 at: 1 put: (point2  at:  l put: 0.0).
	1 to: l - 1 do:
		[:i | point1 
				at: i 
				put: ((a at: (i + 1)) - (a  at:  i) - 
						((point2  at:  i) * 2.0 + (point2  at:  (i + 1)) / 6.0)).
		      point3 at: i put: ((point2  at:  (i + 1)) - (point2  at:  i))]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Spline class
	instanceVariableNames: ''!

!Spline class methodsFor: 'examples' stamp: '6/8/97 13:55 di'!
example
	"Designate points on the Path by clicking the red button. Terminate by
	pressing any other button. A curve will be displayed, through the
	selected points, using a long black form."

	| splineCurve aForm flag|
	aForm _ Form extent: 2@2.
	aForm  fillBlack.
	splineCurve _ Spline new.
	splineCurve form: aForm.
	flag _ true.
	[flag] whileTrue:
		[Sensor waitButton.
		 Sensor redButtonPressed
			ifTrue: 
				[splineCurve add: Sensor waitButton. 
				 Sensor waitNoButton.
				 aForm displayOn: Display at: splineCurve last]
			ifFalse: [flag_false]].
	splineCurve computeCurve.
	splineCurve isEmpty 
		ifFalse: [splineCurve displayOn: Display.
				Sensor waitNoButton].
 
	"Spline example"! !
Object subclass: #SqNumberParser
	instanceVariableNames: 'sourceStream base neg integerPart fractionPart exponent scale nDigits lastNonZero requestor failBlock'
	classVariableNames: 'BelllerophonBase10'
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!SqNumberParser commentStamp: 'nice 4/27/2006 22:38' prior: 0!
This is a class specialized in parsing and building numbers.
Number syntax should follow Smalltalk syntax.

If you have to read foreign number syntax, create a subclass.!


!SqNumberParser methodsFor: 'error' stamp: 'nice 4/28/2006 00:20'!
expected: errorString 
	requestor isNil
		ifFalse: [requestor
				notify: errorString , ' ->'
				at: sourceStream position
				in: sourceStream].
	self fail! !

!SqNumberParser methodsFor: 'error' stamp: 'nice 4/28/2006 00:19'!
fail
	failBlock isNil ifFalse: [^failBlock value].
	self error: 'Reading a number failed'! !


!SqNumberParser methodsFor: 'accessing' stamp: 'nice 4/27/2006 22:57'!
exponentLetters
	"answer the list of possible exponents for Numbers.
	Note: this parser will not honour precision attached to the exponent.
	different exponent do not lead to different precisions.
	only IEEE 754 floating point numbers will be created"
	
	^'edq'! !

!SqNumberParser methodsFor: 'accessing' stamp: 'nice 5/1/2006 01:58'!
failBlock: aBlockOrNil
	failBlock := aBlockOrNil! !

!SqNumberParser methodsFor: 'accessing' stamp: 'nice 5/1/2006 01:59'!
requestor: anObjectOrNil
	requestor := anObjectOrNil! !


!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 5/7/2006 17:33'!
makeFloatFromMantissa: m exponent: k base: aRadix 
	"Convert infinite precision arithmetic into Floating point.
	This alogrithm rely on correct IEEE rounding mode
	being implemented in Integer>>asFloat and Fraction>>asFloat"

	^(k positive
		ifTrue: [m * (aRadix raisedTo: k)]
		ifFalse: [Fraction numerator: m denominator: (aRadix raisedTo: k negated)]) asFloat! !

!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 4/28/2006 00:52'!
makeIntegerOrScaledInteger
	"at this point, there is no digit, nor fractionPart.
	maybe it can be a scaled decimal with fraction omitted..."
	
	neg
		ifTrue: [integerPart := integerPart negated].
	self readExponent
		ifTrue: [integerPart := integerPart
						* (base raisedTo: exponent)]
		ifFalse: [self readScale
				ifTrue: [nil.
					^ ScaledDecimal newFromNumber: integerPart scale: scale]].
	^ integerPart! !

!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 4/28/2006 01:14'!
readExponent
	"read the exponent if any (stored in instVar).
	Answer true if found, answer false if none.
	If exponent letter is not followed by a digit,
	this is not considered as an error.
	Exponent are always read in base 10, though i do not see why..."
	
	| eneg |
	exponent := 0.
	sourceStream atEnd
		ifTrue: [^ false].
	(self exponentLetters includes: sourceStream next)
		ifFalse: [sourceStream skip: -1.
			^ false].
	eneg := sourceStream peekFor: $-.
	exponent := self
				nextUnsignedIntegerBase: 10
				ifFail: [sourceStream
						skip: (eneg
								ifTrue: [-2]
								ifFalse: [-1]).
					^ false].
	eneg
		ifTrue: [exponent := exponent negated].
	^ true! !

!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 4/28/2006 03:08'!
readScale
	"read the scale if any (stored in instVar).
	Answer true if found, answer false if none.
	If scale letter is not followed by a digit,
	this is not considered as an error.
	Scales are always read in base 10, though i do not see why..."
	
	scale := 0.
	sourceStream atEnd ifTrue: [^ false].
	('s' includes: sourceStream next)
		ifFalse: [sourceStream skip: -1.
			^ false].
	scale := self
				nextUnsignedIntegerBase: 10
				ifFail: [sourceStream skip: -1.
					^ false].
	^ true! !


!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 4/27/2006 23:08'!
nextIntegerBase: aRadix
	"Form an integer with following digits"
	
	| isNeg value |
	isNeg := sourceStream peekFor: $-.
	value := self nextUnsignedIntegerBase: aRadix.
	^isNeg
		ifTrue: [value negated]
		ifFalse: [value]! !

!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 4/28/2006 01:12'!
nextIntegerBase: aRadix ifFail: aBlock
	"Form an integer with following digits"
	
	| isNeg value |
	isNeg := sourceStream peekFor: $-.
	value := self nextUnsignedIntegerBase: aRadix ifFail: [^aBlock value].
	^isNeg
		ifTrue: [value negated]
		ifFalse: [value]! !

!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 4/28/2006 03:38'!
nextNumber
	"main method for reading a number.
	This one can read Float Integer and ScaledDecimal"
	
	| numberOfTrailingZeroInIntegerPart numberOfNonZeroFractionDigits mantissa decimalMultiplier decimalFraction value numberOfTrailingZeroInFractionPart |
	(sourceStream nextMatchAll: 'NaN')
		ifTrue: [^ Float nan].
	neg := sourceStream peekFor: $-.
	(sourceStream nextMatchAll: 'Infinity')
		ifTrue: [^ neg
				ifTrue: [Float infinity negated]
				ifFalse: [Float infinity]].
	integerPart := self nextUnsignedIntegerBase: base.
	numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero.
	(sourceStream peekFor: $r)
		ifTrue: ["<base>r<integer>"
			(base := integerPart) < 2
				ifTrue: [^ self expected: 'an integer greater than 1 as valid radix'].
			(sourceStream peekFor: $-)
				ifTrue: [neg := neg not].
			integerPart := self nextUnsignedIntegerBase: base.
			numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero].
	^ (sourceStream peekFor: $.)
		ifTrue: [fractionPart := self
						nextUnsignedIntegerBase: base
						ifFail: [sourceStream skip: -1.
							^ neg
								ifTrue: [integerPart negated]
								ifFalse: [integerPart]].
			numberOfNonZeroFractionDigits := lastNonZero.
			numberOfTrailingZeroInFractionPart := nDigits - lastNonZero.
			self readExponent
				ifFalse: [self readScale
						ifTrue: [decimalMultiplier := base raisedTo: numberOfNonZeroFractionDigits.
							decimalFraction := integerPart * decimalMultiplier + fractionPart / decimalMultiplier.
							neg
								ifTrue: [decimalFraction := decimalFraction negated].
							^ ScaledDecimal newFromNumber: decimalFraction scale: scale]].
			fractionPart isZero
				ifTrue: [mantissa := integerPart
								// (base raisedTo: numberOfTrailingZeroInIntegerPart).
					exponent := exponent + numberOfTrailingZeroInIntegerPart]
				ifFalse: [mantissa := integerPart
								* (base raisedTo: numberOfNonZeroFractionDigits) + (fractionPart // (base raisedTo: numberOfTrailingZeroInFractionPart)).
					exponent := exponent - numberOfNonZeroFractionDigits].
			"very naive algorithm"
			value := self makeFloatFromMantissa: mantissa exponent: exponent base: base.
			^ neg
				ifTrue: [value isZero
						ifTrue: [Float negativeZero]
						ifFalse: [value negated]]
				ifFalse: [value]]
		ifFalse: [self makeIntegerOrScaledInteger]! !

!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 4/28/2006 01:10'!
nextUnsignedIntegerBase: aRadix 
	"Form an unsigned integer with incoming digits from sourceStream.
	Count the number of digits and the lastNonZero digit and store int in
	instVar "
	
	^ self
		nextUnsignedIntegerBase: aRadix
		ifFail: [self expected: 'a digit between 0 and 9']! !

!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 4/28/2006 03:14'!
nextUnsignedIntegerBase: aRadix ifFail: errorBlock
	"Form an unsigned integer with incoming digits from sourceStream.
	Count the number of digits and the lastNonZero digit and store int in instVar"
	
	| value digit |
	value := 0.
	nDigits := 0.
	lastNonZero := 0.
	[sourceStream atEnd
		or: [digit := sourceStream next digitValue.
			(digit < 0
					or: [digit >= aRadix])
				and: [sourceStream skip: -1.
					true]]]
		whileFalse: [nDigits := nDigits + 1.
			digit isZero
				ifFalse: [lastNonZero := nDigits].
			value := value * aRadix + digit].
	nDigits = 0
		ifTrue: [errorBlock value].
	^value! !


!SqNumberParser methodsFor: 'initialize-release' stamp: 'nice 5/1/2006 00:41'!
on: aStringOrStream
	sourceStream := aStringOrStream isString
		ifTrue: [ReadStream on: aStringOrStream]
		ifFalse: [aStringOrStream].
	base := 10.
	neg := false.
	integerPart := fractionPart := exponent := scale := 0.
	requestor := failBlock := nil.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SqNumberParser class
	instanceVariableNames: ''!

!SqNumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 00:45'!
on: aStringOrStream
	^self new on: aStringOrStream! !

!SqNumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 02:02'!
parse: aStringOrStream 
	^(self new)
		on: aStringOrStream;
		nextNumber! !

!SqNumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 02:02'!
parse: aStringOrStream onError: failBlock 
	^(self new)
		on: aStringOrStream;
		failBlock: failBlock;
		nextNumber! !
ClassTestCase subclass: #SqNumberParserTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Numbers'!
!SqNumberParserTest commentStamp: 'nice 5/7/2006 17:54' prior: 0!
Provide tests for new clas aimed at parsing numbers.

It duplicates NumberParsingTest, with few more tests.!


!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/7/2006 17:46'!
testFloatFromStreamAsNumber
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs := '10r-12.3456' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: -12.3456 = aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456e2' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456e2e2' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs upToEnd = 'e2'.

	rs := '10r-12.3456d2' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs atEnd.

	rs := '10r-12.3456q2' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs atEnd.

	rs := '-12.3456q2' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: -1234.56 = aFloat.
	self assert: rs atEnd.

	rs := '12.3456q2' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: 1234.56 = aFloat.
	self assert: rs atEnd.

	rs := '12.3456z2' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: 12.3456 = aFloat.
	self assert: rs upToEnd = 'z2'.
! !

!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/7/2006 17:46'!
testFloatFromStreamWithExponent
	"This covers parsing in Number>>readFrom:"

	| rs aFloat |
	rs := '1.0e-14' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: 1.0e-14 = aFloat.
	self assert: rs atEnd.

	rs := '1.0e-14 1' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: 1.0e-14 = aFloat.
	self assert: rs upToEnd = ' 1'.

	rs := '1.0e-14eee' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: 1.0e-14 = aFloat.
	self assert: rs upToEnd = 'eee'.

	rs := '1.0e14e10' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: 1.0e14 = aFloat.
	self assert: rs upToEnd = 'e10'.

	rs := '1.0e+14e' readStream. "Plus sign is not parseable"
	aFloat := SqNumberParser parse: rs.
	self assert: 1.0 = aFloat.
	self assert: rs upToEnd = 'e+14e'.

	rs := '1.0e' readStream.
	aFloat := SqNumberParser parse: rs.
	self assert: 1.0 = aFloat.
	self assert: rs upToEnd = 'e'.! !

!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/1/2006 00:40'!
testFloatPrintString
	"self debug: #testFloatPrintString"
	
	| f r |
	f := Float basicNew: 2.
	r := Random new seed: 1234567.
	100
		timesRepeat: [f basicAt: 1 put: (r nextInt: 16r100000000)- 1.
			f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
			#(2 8 10 16)
				do: [:base | | str |
						str := (String new: 64) writeStream.
						f negative ifTrue: [str nextPut: $-].
						str print: base; nextPut: $r.
						f absPrintExactlyOn: str base: base.
						self assert: (SqNumberParser parse: str contents) = f]].
	"test big num near infinity"
	10
		timesRepeat: [f basicAt: 1 put: 16r7FE00000 + ((r nextInt: 16r100000) - 1).
			f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
			#(2 8 10 16)
				do: [:base | | str |
						str := (String new: 64) writeStream.
						f negative ifTrue: [str nextPut: $-].
						str print: base; nextPut: $r.
						f absPrintExactlyOn: str base: base.
						self assert: (SqNumberParser parse: str contents) = f]].
	"test infinitesimal (gradual underflow)"
	10
		timesRepeat: [f basicAt: 1 put: 0 + ((r nextInt: 16r100000) - 1).
			f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
			#(2 8 10 16)
				do: [:base | | str |
						str := (String new: 64) writeStream.
						f negative ifTrue: [str nextPut: $-].
						str print: base; nextPut: $r.
						f absPrintExactlyOn: str base: base.
						self assert: (SqNumberParser parse: str contents) = f]].! !

!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/1/2006 00:40'!
testFloatReadError
	"This covers parsing in Number>>readFrom:"

	| rs num |
	rs := '1e' readStream.
	num := SqNumberParser parse: rs.
	self assert: 1 = num.
	self assert: rs upToEnd = 'e'.
	
	rs := '1s' readStream.
	num := SqNumberParser parse: rs.
	self assert: 1 = num.
	self assert: rs upToEnd = 's'.

	rs := '1.' readStream.
	num := SqNumberParser parse: rs.
	self assert: 1 = num.
	self assert: num isInteger.
	self assert: rs upToEnd = '.'.
	
	rs := '' readStream.
	self should: [SqNumberParser parse: rs] raise: Error.
	
	rs := 'foo' readStream.
	self should: [SqNumberParser parse: rs] raise: Error.

	rs := 'radix' readStream.
	self should: [SqNumberParser parse: rs] raise: Error.
	
	rs := '.e0' readStream.
	self should: [SqNumberParser parse: rs] raise: Error.
	
	rs := '-.e0' readStream.
	self should: [SqNumberParser parse: rs] raise: Error.
	
	rs := '--1' readStream.
	self should: [SqNumberParser parse: rs] raise: Error.! !

!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/7/2006 17:46'!
testFloatReadWithRadix
	"This covers parsing in Number>>readFrom:
	Note: In most Smalltalk dialects, the radix notation is not used for numbers
	with exponents. In Squeak, a string with radix and exponent can be parsed,
	and the exponent is always treated as base 10 (not the base indicated in the
	radix prefix). I am not sure if this is a feature, a bug, or both, but the
	Squeak behavior is documented in this test. -dtl"

	| aNumber rs |
	aNumber := '2r1.0101e9' asNumber.
	self assert: 672.0 = aNumber.
	self assert: (SqNumberParser parse: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)).
	rs := ReadStream on: '2r1.0101e9e9'.
	self assert: (SqNumberParser parse: rs) = 672.0.
	self assert: rs upToEnd = 'e9'
! !


!SqNumberParserTest methodsFor: 'tests - Integer' stamp: 'nice 5/7/2006 17:46'!
testIntegerReadFrom
	"Ensure remaining characters in a stream are not lost when parsing an integer."

	| rs i s |
	rs := ReadStream on: '123s could be confused with a ScaledDecimal'.
	i := SqNumberParser parse: rs.
	self assert: i == 123.
	s := rs upToEnd.
	self assert: 's could be confused with a ScaledDecimal' = s.
	rs := ReadStream on: '123.s could be confused with a ScaledDecimal'.
	i := SqNumberParser parse: rs.
	self assert: i == 123.
	s := rs upToEnd.
	self assert: '.s could be confused with a ScaledDecimal' = s
! !

!SqNumberParserTest methodsFor: 'tests - Integer' stamp: 'nice 5/7/2006 17:46'!
testIntegerReadWithRadix
	"This covers parsing in Number>>readFrom:
	Note: In most Smalltalk dialects, the radix notation is not used for numbers
	with exponents. In Squeak, a string with radix and exponent can be parsed,
	and the exponent is always treated as base 10 (not the base indicated in the
	radix prefix). I am not sure if this is a feature, a bug, or both, but the
	Squeak behavior is documented in this test. -dtl"

	| aNumber rs |
	aNumber := '2r1e26' asNumber.
	self assert: 67108864 = aNumber.
	self assert: (SqNumberParser parse: '2r1e26') = (2 raisedTo: 26).
	rs := '2r1e26eee' readStream.
	self assert: (SqNumberParser parse: rs) = 67108864.
	self assert: rs upToEnd = 'eee'
! !
Object subclass: #SqueakPage
	instanceVariableNames: 'url title comment thumbnail contentsMorph creationTime creationAuthor lastChangeTime lastChangeAuthor policy dirty'
	classVariableNames: 'MaxThumbnailWidthOrHeight RecentMaxNum RecentStem'
	poolDictionaries: ''
	category: 'MorphicExtras-SqueakPage'!
!SqueakPage commentStamp: '<historical>' prior: 0!
A SqueakPage is holder for a page of morphs that live on the disk or on a server.
A URLMorph is a thumbnail sized stand-in for the page.  Clicking on it gets the page.
An ObjectOut is a fake object that stands for an object that is out on the disk.  (Like ObjectTracer or ObjectViewer.)
A MorphObjectOut is a subclass that stands for a Morph that is out on the disk.

To find out how to make the pages of any BookMorph go out to the disk (or a server), see 	http://minnow.cc.gatech.edu/SqueakDoc.1 then go to 'SqueakPages'.

A SqueakPage is always in-memory.  Its contentsMorph will be 'become-ed' to a MorphObjectOut tombstone when it goes out.  (A page may or may not be in the cache.  First put it in, then ask it for the data.)  Sending any message to the contentsMorph triggers the fetch.  Many URLMorphs may hold onto one page.  A page has a thumbnail.  A URLMorph points at its page object.

States of a SqueakPage, and the transitions to another state:
1) have a url as a string.  Then: (URLMorph grabURL: 'file://Ted''s/books/tryThis/p1').  
	Drop it into any morph.
2) have a URLMorph, with page==nil.     Click it.  (makes an empty page, installs 
	it in the global page cache)
3) have a URLMorph with a SqueakPage, with contentsMorph==nil, 
	but page is not in the cache (this is a rare case).  ask page contentsMorph.
4) OUT: have a URLMorph with a SqueakPage, with contentsMorph being a MorphObjectOut, 
	and its page is in the cache.  Sending the contentsMorph any message brings it in and
	becomes it to the morph.  (fix up morph's pointer to the page.)
5) Totally IN:  a morph, owned by a SqueakPage, has a page in the cache.  
	The morph is clean.   
	Whenever someone triggers a purge (when?), contentsMorph is becomed
	to a MorphObjectOut. (go to 4)
	Causing the morph to execute layoutChanged marks the morph as dirty.
	(morph's property #pageDirty is set to true) (go to 6)
6) Totally IN and dirty.  
	Whenever any other page is fetched from the disk or the net, all other 
	dirty pages are written and marked clean.  (go to 5)

Note that the entire tree of submorphs goes out -- hundreds of objects.  Bringing the object back in brings in the SqueakPage, installs it in the cache.  Classes other than PasteUpMorph can easily be made to send their contents out if there is any need.

Note that every book is now automatically a WebBook.  We simply give a page a url and tell it to purge.

url		a string
title		
comment		
thumbnail		
contentsMorph		(1) a pasteUpMorph with other morphs in it.
					(2) a MorphObjectOut.  Sending any message brings it in. 
					(3) nil if the page has never been in this image.
creationTime		
creationAuthor		
lastChangeTime		
lastChangeAuthor 
policy		#alwaysWrite, #neverWrite, #ask.  (cache can override with a global policy)
			(Explicit writing by user has policy #neverWrite)
dirty 		(Morph>>layoutChanged sends changed: #SqueakPage. If policy==#check, 
				then the page sets dirty_true.)
			(If policy==#alwaysWrite, then set dirty when the page is retrieved from the cache.)

Class MorphObjectOut has an instance variable called page.
All messages to an MorphObjectOut cause it to be brought in.  Except the messages needed to write the MorphObjectOut on the disk as part of a parent's being sent out.  (size, class, instSize, instVar:at:.  Can rename these and call from its own version of the writing routine.)
	To purge, go through the clean pages, and any that have world not equal to this world, entomb them.  
	(If an object in the subtree is held by an object outside the tree, it will remain,  And will be duplicated when the tree comes back in.  This is a problem already in normal uses of SmartRefStream.)


!


!SqueakPage methodsFor: 'accessing' stamp: 'tk 2/5/1999 16:47'!
asMorph
	^ self fetchContents! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 13:47'!
comment

	comment ifNil: [^ ''] ifNotNil: [^ comment].
! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 18:12'!
comment: aString

	aString isEmpty
		ifTrue: [comment _ nil]
		ifFalse: [comment _ aString].
! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 10/2/1998 11:27'!
contentsMorph
	"Return what it is now.  If the morph is out on the disk, return nil.  Use fetchContents to get the data for sure."

	^ contentsMorph
! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 11/11/1998 12:54'!
contentsMorph: aPasteUpMorph

	contentsMorph _ aPasteUpMorph! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 2/23/1999 14:39'!
copyForSaving
	"Make a copy and configure me to be put out on the disk.  When it is brought in and touched, it will turn into the object at the url."

	| forDisk holder |
	forDisk _ self clone.
	holder _ MorphObjectOut new xxxSetUrl: url page: forDisk.
	forDisk contentsMorph: holder.
	^ holder		"directly representing the object"! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 10/30/1998 15:08'!
fetchContents
	"Make every effort to get contentsMorph."

	self isContentsInMemory ifTrue: [^ contentsMorph].
	^ self fetchInformIfError! !

!SqueakPage methodsFor: 'accessing' stamp: 'ar 4/10/2005 18:52'!
fetchContentsIfAbsent: failBlock
	"Make every effort to get contentsMorph.  Assume I am in the cache already."
	| strm page temp temp2 |
	SqueakPageCache write.		"sorry about the pause"
	Cursor wait showWhile: [
		strm _ (ServerFile new fullPath: url) asStream].
	strm isString ifTrue: [^ failBlock value].		
	page _ strm fileInObjectAndCode.
	page isMorph ifTrue: [contentsMorph _ page].	"may be a bare morph"
	"copy over the state"
	temp _ url.
	temp2 _ policy.
	self copyAddedStateFrom: page.
	url _ temp.	"don't care what it says"
	temp2 ifNotNil: [policy _ temp2].		"use mine"
	contentsMorph setProperty: #pageDirty toValue: nil.
	self dirty: false.
	^ contentsMorph! !

!SqueakPage methodsFor: 'accessing' stamp: 'ar 4/10/2005 18:52'!
fetchInformIfError
	"Make every effort to get contentsMorph.  Put up a good notice if can't get it.  Assume page is in the cache already.  Overwrite the contentsMorph no matter what."
	| strm page temp temp2 |

	SqueakPageCache write.		"sorry about the pause"
	Cursor wait showWhile: [
		strm _ (ServerFile new fullPath: url) asStream].
	strm isString ifTrue: [self inform: 'Sorry, ',strm. ^ nil].	"<<<<< Note Diff"
	(url beginsWith: 'file:') ifTrue: [Transcript show: 'Fetching  ', url; cr].	
	page _ strm fileInObjectAndCode.
	page isMorph 
		ifTrue: [contentsMorph _ page]	"may be a bare morph"
		ifFalse: ["copy over the state"
			temp _ url.
			temp2 _ policy.
			self copyFrom: page.	"including contentsMorph"
			url _ temp.	"I know best!!"
			temp2 ifNotNil: [policy _ temp2]].		"use mine"
	contentsMorph setProperty: #pageDirty toValue: nil.
	contentsMorph setProperty: #SqueakPage toValue: self.
	self dirty: false.
	^ contentsMorph! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 10/30/1998 15:08'!
isContentsInMemory
	"Is my contentsMorph in memory, or is it an ObjectOut tombstone?  Be careful not to send it any message."

	^ (contentsMorph xxxClass inheritsFrom: Object) and: [(contentsMorph == nil) not]! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 12/4/1998 01:00'!
lastChangeTime
	^ lastChangeTime! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 2/24/1999 12:06'!
saveMorph: aMorph author: authorString
	"Save the given morph as this page's contents. Update its thumbnail and inform references to this URL that the page has changed."
	"Details: updateThumbnail releases the cached state of the saved page contents after computing the thumbnail."

	| n |
	contentsMorph _ aMorph.
	n _ aMorph knownName.
	n ifNotNil: [self title: n].
	creationAuthor ifNil: [
		creationAuthor _ authorString.
		creationTime _ Time totalSeconds].
"	lastChangeAuthor _ authorString.
	lastChangeTime _ Time totalSeconds.	do it when actually write"
	self computeThumbnail.
	self postChangeNotification.
! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 17:45'!
thumbnail

	^ thumbnail
! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 13:47'!
title

	title ifNil: [^ ''] ifNotNil: [^ title].
! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 18:12'!
title: aString

	aString isEmpty
		ifTrue: [title _ nil]
		ifFalse: [title _ aString].
! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 11/4/1998 20:34'!
url

	^ url! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 1/14/1999 23:50'!
url: aString

	| sd |
	aString isEmpty ifTrue: [url _ nil. ^ self].

	"Expand ./ and store as an absolute url"
	sd _ ServerFile new.
	sd fullPath: aString.
	url _ sd realUrl.! !


!SqueakPage methodsFor: 'saving' stamp: 'tk 9/30/1998 22:40'!
dirty: aBool
	dirty _ aBool! !

!SqueakPage methodsFor: 'saving' stamp: 'tk 10/8/1998 13:18'!
policy
	^ policy! !

!SqueakPage methodsFor: 'saving' stamp: 'tk 9/30/1998 22:39'!
policy: aSymbol
	policy _ aSymbol! !

!SqueakPage methodsFor: 'saving' stamp: 'ar 3/17/2001 23:36'!
prePurge
	"Return self if ready to be purged, or nil if not"

	self isContentsInMemory ifFalse: [^ nil].
	contentsMorph ifNil: [^ nil].  "out already"
	url ifNil: [^ nil].	"just to be safe"
	^ (World ~~ nil and: [contentsMorph world == World]) 
		ifTrue: [nil "showing now"] ifFalse: [self]! !

!SqueakPage methodsFor: 'saving' stamp: 'tk 12/16/1998 08:24'!
purge
	"Replace my morph with a tombstone, if I am not in a world that is being shown."

	(self prePurge) ifNotNil: [
		contentsMorph become: (MorphObjectOut new xxxSetUrl: url page: self)].
		"Simple, isn't it!!"! !

!SqueakPage methodsFor: 'saving' stamp: 'tk 1/23/1999 13:19'!
urlNoOverwrite: suggested
	"Look in the directory.  If there is a file of this name, create a new name.  Keep track of highest numbers used as a hint."

	| dir ll stem num local trial suffix |
	(suggested endsWith: '.sp') ifTrue: [suffix _ '.sp'].
	(suggested endsWith: '.bo') ifTrue: [suffix _ '.bo'].
	suffix ifNil: [self error: 'unknown suffix'].
	dir _ ServerFile new fullPath: suggested.
	(dir includesKey: dir fileName) ifFalse: [^ url _ suggested].
	"File already exists!!  Create a new name"
	"Find the stem file name"
	stem _ SqueakPage stemUrl: suggested.
	num _ stem = RecentStem ifTrue: [RecentMaxNum+1] ifFalse: [1].

	local _ dir fileName.	"ugh, take stem again..."
	ll _ local findLast: [:char | char == $.].
	ll = 0 ifFalse: [local _ local copyFrom: 1 to: ll-1].	"remove .sp"
	local _ (local splitInteger) at: 1.		"remove trailing number"
	local last == $x ifFalse: [local _ local , 'x'].
	[trial _ local, num printString, suffix.
		dir includesKey: trial] whileTrue: [num _ num + 1].
	RecentStem _ stem.  RecentMaxNum _ num.
	^ url _ stem, 'x', num printString, suffix! !

!SqueakPage methodsFor: 'saving' stamp: 'RAA 8/30/2000 11:43'!
write
	"Decide whether to write this page on the disk."
	| sf remoteFile |
	policy == #neverWrite ifTrue: [^ self].
		"demo mode, or write only when user explicitly orders it"

	"All other policies do write:   #now"
	contentsMorph ifNil: [^ self].
	dirty _ dirty | ((contentsMorph valueOfProperty: #pageDirty) == true).
		"set by layoutChanged"
	dirty == true ifTrue: [ 
		sf _ ServerDirectory new fullPath: url.
		"check for shared password"
		"contentsMorph allMorphsDo: [:m | m prepareToBeSaved].
				done in objectToStoreOnDataStream"
		lastChangeAuthor _ Utilities authorInitialsPerSe ifNil: ['*'].
		lastChangeTime _ Time totalSeconds.
		Cursor wait showWhile: [
			remoteFile _ sf fileNamed: url.	"no notification when overwriting"
			remoteFile dataIsValid.
			remoteFile fileOutClass: nil andObject: self.
			"remoteFile close"].
		contentsMorph setProperty: #pageDirty toValue: nil.
		dirty _ false].! !


!SqueakPage methodsFor: 'private' stamp: 'tk 2/25/1999 09:13'!
computeThumbnail
	"Make a thumbnail from my morph."

	(contentsMorph isKindOf: PasteUpMorph) 
		ifTrue: [thumbnail _ contentsMorph smallThumbnailForPageSorter]
		ifFalse: [self updateThumbnail]! !

!SqueakPage methodsFor: 'private' stamp: 'tk 6/24/1999 11:42'!
postChangeNotification
	"Inform all thumbnails and books that this page has been updated."

	URLMorph allSubInstancesDo: [:m | m pageHasChanged: self].
! !

!SqueakPage methodsFor: 'private' stamp: 'jm 6/18/1998 11:31'!
updateThumbnail
	"Update my thumbnail from my morph."

	| f scale scaleX scaleY shrunkF |
	contentsMorph ifNil: [thumbnail _ nil. ^ self].
	f _ contentsMorph imageForm.
	scaleX _ MaxThumbnailWidthOrHeight asFloat / f height.
	scaleY _ MaxThumbnailWidthOrHeight asFloat/ f width.
	scale _ scaleX min: scaleY.  "choose scale that maintains aspect ratio"
	shrunkF _ (f magnify: f boundingBox by: scale@scale smoothing: 2).
	thumbnail _ Form extent: shrunkF extent depth: 8.  "force depth to be 8"
	shrunkF displayOn: thumbnail.
	contentsMorph allMorphsDo: [:m | m releaseCachedState].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SqueakPage class
	instanceVariableNames: ''!

!SqueakPage class methodsFor: 'as yet unclassified' stamp: 'jm 6/18/1998 11:15'!
initialize
	"SqueakPage initialize"

	MaxThumbnailWidthOrHeight _ 60.
! !

!SqueakPage class methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 11:49'!
newURLAndPageFor: aMorph
	"Create a new SqueakPage whose contents is the given morph. Assign a URL for that page, record it in the page cache, and answer its URL."

	| pg newURL stamp |
	pg _ self new.
	stamp _ Utilities authorInitialsPerSe ifNil: ['*'].
	pg saveMorph: aMorph author: stamp.
	newURL _ SqueakPageCache generateURL.
	SqueakPageCache atURL: newURL put: pg.
	^ newURL 
! !

!SqueakPage class methodsFor: 'as yet unclassified' stamp: 'tk 1/15/1999 08:13'!
stemUrl: aUrlString
	"Peel off the 'x5.sp'  or '.bo' from the end of a url of a SqueakPage or a BookMorph index file"

	| ll aUrl |
	ll _ aUrlString findLast: [:char | char == $.].
	ll = 0 
		ifTrue: [aUrl _ aUrlString]
		ifFalse: [aUrl _ aUrlString copyFrom: 1 to: ll-1].	"remove .sp"
	aUrl _ (aUrl stemAndNumericSuffix) at: 1.
			"remove trailing number"
	aUrl size = 0 ifTrue: [^ aUrl].	"empty"
	[aUrl last == $x] whileTrue: [aUrl _ aUrl allButLast].
	^ aUrl! !
Object subclass: #SqueakPageCache
	instanceVariableNames: ''
	classVariableNames: 'GlobalPolicy PageCache'
	poolDictionaries: ''
	category: 'MorphicExtras-SqueakPage'!
!SqueakPageCache commentStamp: '<historical>' prior: 0!
A global cache of web pages known to this Squeak image.  Since there is a single, global page cache, it is implemented entirely as class methods.

Once a page has an entry, keep it.  (url string -> A SqueakPage)  The SqueakPage has a thumbnail and other info, but may not have the contentsMorph.  The morph is purged when space is needed, and fetched from the server as needed.

See SqueakPage's comment for the stages of in/out.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SqueakPageCache class
	instanceVariableNames: ''!

!SqueakPageCache class methodsFor: 'cache access' stamp: 'jm 6/25/1998 11:06'!
allURLs
	"Answer a collection of URLs for all pages in the cache."

	^ PageCache keys

! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/2/1998 12:07'!
atURL: aURLString
	"Answer the page corresponding to this URL. Evaluate the given block if there is no entry for the given URL."

	| pg |
	^ PageCache at: aURLString ifAbsent: [
		pg _ SqueakPage new.
		"stamp _ Utilities authorInitialsPerSe ifNil: ['*']."
		"pg author: stamp."
		"Need to deal with inst vars if we turn out to be new!!"
		"pg url: aURLString. 	done by atURL:put:"
		self atURL: aURLString put: pg.
		pg]
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/2/1998 12:06'!
atURL: aURLString ifAbsent: failBlock
	"Answer the page corresponding to this URL. Evaluate the given block if there is no entry for the given URL."

	self halt.  "use atURL:"
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/20/1998 15:51'!
atURL: aURLString oldPage: aPage
	"Bring in page and return the object.  First try looking up my url in the pageCache.  Then try the page (and install it, under its url).  Then start from scratch with the url."

	| myPage |
	(myPage _ PageCache at: aURLString ifAbsent: [nil]) ifNotNil: [
		^ myPage].
	aPage url: aURLString.	"for consistancy"
	PageCache at: aPage url put: aPage.
	^ aPage! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 12/8/1998 21:51'!
atURL: aURLString put: aSqueakPage
	"Store the given page in the cache entry for the given URL."

	aSqueakPage url: aURLString.
	aSqueakPage contentsMorph isInMemory ifTrue: [
		aSqueakPage contentsMorph ifNotNil: [
			aSqueakPage contentsMorph setProperty: #SqueakPage 
				toValue: aSqueakPage]].
	PageCache at: aURLString put: aSqueakPage.
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/30/1998 15:08'!
doPagesInMemory: aBlock
	"Evaluate aBlock for each page whose contentsMorph is in-memory.  Don't add or remove pages while in this loop."

	PageCache do: [:sqkPage |
		sqkPage isContentsInMemory ifTrue: [aBlock value: sqkPage]].! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 11/24/1998 14:52'!
generateURL
	"Generate an unused URL for an in-memory page."
	"SqueakPageCache generateURL"

	| sd |
	sd _ ServerFile new on: 'file:./'.
	sd fileName: 'page1.sp'.
	^ SqueakPage new urlNoOverwrite: sd pathForFile
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/1/1998 13:02'!
includesMorph: aPasteUp

	PageCache do: [:squeakPage |
		squeakPage contentsMorph == aPasteUp ifTrue: [^ true]].
	^ false! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/20/1998 15:11'!
pageCache

	^ PageCache! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/1/1998 13:04'!
pageForMorph: aPasteUp

	PageCache do: [:squeakPage |
		squeakPage contentsMorph == aPasteUp ifTrue: [^ squeakPage]].
	^ nil! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 12/16/1998 08:30'!
purge
	"Replace morphs with tombstones in all pages that are clean and not being shown.  Write any dirty ones first, if allowed to."

	| list |
	list _ OrderedCollection new.
	GlobalPolicy == #neverWrite 
		ifTrue: [PageCache doPagesInMemory: [:aPage | list add: aPage prePurge]]
			"Writing only done by user's command"
		ifFalse: [
			PageCache doPagesInMemory: [:aPage | aPage write
					 list add: aPage prePurge]].
	list _ list select: [:each | each notNil].
	"do bulk become:"
	(list collect: [:each | each contentsMorph])
		elementsExchangeIdentityWith:
			(list collect: [:pg | MorphObjectOut new xxxSetUrl: pg url page: pg])
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/21/1998 13:28'!
purge: megs
	"Replace morphs with tombstones in all pages that are clean and not being shown.  Do this until megs of new memory have been recovered.  Write any dirty ones first, if allowed to."

	| goal |
	goal _ Smalltalk garbageCollect + (megs * 1000000) asInteger.
	PageCache doPagesInMemory: [:aPage | 
		GlobalPolicy == #neverWrite ifFalse: [aPage write].
		aPage purge.
		Smalltalk garbageCollect > goal ifTrue: [^ true]].	"got enough"
	^ false	"caller may want to tell the user to write out more pages"! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'jm 6/16/1998 18:12'!
removeURL: aURLString
	"Remove the cache entry for the given URL. Do nothing if it has no cache entry."

	PageCache removeKey: aURLString ifAbsent: [].
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/22/1998 11:07'!
write
	"Write out all dirty pages"
	GlobalPolicy == #neverWrite ifTrue: [^ self].
	self doPagesInMemory: [:aPage | aPage write].! !


!SqueakPageCache class methodsFor: 'class initialization' stamp: 'tk 11/24/1998 14:53'!
initialize
	"SqueakPageCache initialize"

	GlobalPolicy _ #neverWrite.
	PageCache _ Dictionary new: 100.
		"forgets urls of pages, but ObjectOuts still remember them"
! !


!SqueakPageCache class methodsFor: 'housekeeping' stamp: 'tk 6/24/1999 11:42'!
deleteUnreferencedPages
	"Remove any pages that are not current referred to by any book or URL morph."
	"Details: Since unreferenced pages could refer to other pages, this process is iterated until no unreferenced pages can be found. It currently does not collect cycles."
	"SqueakPageCache deleteUnreferencedPages"

	| unreferenced |
	[true] whileTrue: [
		Smalltalk garbageCollect.
		unreferenced _ PageCache keys.
		URLMorph allSubInstancesDo: [:m | unreferenced remove: m url ifAbsent: []].
		MorphObjectOut allInstancesDo: [:ticklish |
			unreferenced remove: ticklish url ifAbsent: []].
		unreferenced size = 0 ifTrue: [^ self].
		unreferenced do: [:url | PageCache removeKey: url ifAbsent: []]].
! !

!SqueakPageCache class methodsFor: 'housekeeping' stamp: 'jm 6/25/1998 13:00'!
releaseCachedStateOfPages
	"Note: This shouldn't be necessary if we are doing a good job of releasing cached state as we go. If running this doesn't do very much, we're doing well!!"
	"SqueakPageCache releaseCachedStateOfPages"

	| memBytes |
	memBytes _ Smalltalk garbageCollect.
	PageCache do: [:pg |
		pg contentsMorph allMorphsDo: [:m | m releaseCachedState]].
	^ (Smalltalk garbageCollect - memBytes) printString, ' bytes recovered'
! !
Morph subclass: #SquishedNameMorph
	instanceVariableNames: 'target getSelector setSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Navigators'!

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:19'!
colorAroundName

	^Color gray: 0.8! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:18'!
fontForName

	| pickem |
	pickem _ 3.

	pickem = 1 ifTrue: [
		^(((TextStyle named: #Helvetica) ifNil: [TextStyle default]) fontOfSize: 13) emphasized: 1.
	].
	pickem = 2 ifTrue: [
		^(((TextStyle named: #Palatino) ifNil: [TextStyle default]) fontOfSize: 12) emphasized: 1.
	].
	^((TextStyle default) fontAt: 1) emphasized: 1
! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:17'!
isEditingName

	^((self findA: UpdatingStringMorph) ifNil: [^false]) hasFocus
! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:32'!
stringToShow

	(target isNil or: [getSelector isNil]) ifTrue: [^'????'].
	^target perform: getSelector! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:31'!
target: aTarget getSelector: symbol1 setSelector: symbol2

	target _ aTarget.
	getSelector _ symbol1.
	setSelector _ symbol2.! !


!SquishedNameMorph methodsFor: 'drawing' stamp: 'RAA 11/11/2000 23:17'!
drawOn: aCanvas

	| font stringToShow nameForm rectForName |

	super drawOn: aCanvas.
	self isEditingName ifTrue: [^self].

	font _ self fontForName.
	stringToShow _ self stringToShow.
	nameForm _ (StringMorph contents: stringToShow font: font) imageForm.
	nameForm _ nameForm scaledToSize: (self extent - (4@2) min: nameForm extent).
	rectForName _ self bottomLeft + 
			(self width - nameForm width // 2 @ (nameForm height + 2) negated)
				extent: nameForm extent.
	rectForName topLeft eightNeighbors do: [ :pt |
		aCanvas
			stencil: nameForm 
			at: pt
			color: self colorAroundName.
	].
	aCanvas
		stencil: nameForm 
		at: rectForName topLeft 
		color: Color black.


	
! !
Object subclass: #Stack
	instanceVariableNames: 'linkedList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Stack'!
!Stack commentStamp: 'dc 7/24/2005 15:41' prior: 0!
I implement a simple Stack. #push: adds a new object of any kind on top of the stack. #pop returns the first element and remove it from the stack. #top answer the first element of the stack without removing it.!


!Stack methodsFor: 'accessing' stamp: 'dc 7/25/2005 10:04'!
size
	"How many objects in me ?"
	^ self linkedList size! !

!Stack methodsFor: 'accessing' stamp: 'sd 3/25/2006 15:05'!
top
	"Answer the first element of the stack without removing it."
	self notEmptyCheck.
	^ self linkedList first element! !


!Stack methodsFor: 'adding' stamp: 'dc 7/25/2005 10:22'!
push: anObject 
	"Adds a new object of any kind on top of the stack."
	self linkedList
		addFirst: (StackLink with: anObject).
	^ anObject.! !


!Stack methodsFor: 'initialize-release' stamp: 'dc 7/25/2005 11:39'!
initialize
	super initialize.
	linkedList := LinkedList new! !


!Stack methodsFor: 'removing' stamp: 'dc 7/24/2005 16:16'!
pop
	"Returns the first element and remove it from the stack."

	self notEmptyCheck.
	^self linkedList removeFirst element! !


!Stack methodsFor: 'testing' stamp: 'dc 7/25/2005 10:05'!
isEmpty
	^ self linkedList isEmpty! !


!Stack methodsFor: 'private' stamp: 'dc 7/25/2005 10:05'!
errorEmptyStack
	self error: 'this stack is empty'! !

!Stack methodsFor: 'private' stamp: 'dc 7/25/2005 10:20'!
linkedList
	"The stack is implemented with a LinkedList. Do NOT call this function, it  
	is for private use !!"
	^ linkedList! !

!Stack methodsFor: 'private' stamp: 'dc 7/25/2005 10:05'!
notEmptyCheck
	"Ensure the stack is not empty."
	self isEmpty
		ifTrue: [self errorEmptyStack]! !
Link subclass: #StackLink
	instanceVariableNames: 'element'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Stack'!
!StackLink commentStamp: '<historical>' prior: 0!
I implement an element of a stack. I'm a container for any type of object, saved into the 'element' variable. My superclass Link allows me to be part of a LinkedList.!


!StackLink methodsFor: 'accessing' stamp: 'dc 7/24/2005 15:34'!
element
	^element! !

!StackLink methodsFor: 'accessing' stamp: 'dc 7/25/2005 10:16'!
element: anObject 
	"Any kind of Object."
	element := anObject! !


!StackLink methodsFor: 'printing' stamp: 'dc 7/25/2005 10:15'!
printOn: aStream 
	aStream nextPutAll: self class printString;
		 nextPutAll: ' with: ';
		 nextPutAll: self element printString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StackLink class
	instanceVariableNames: ''!

!StackLink class methodsFor: 'instance creation' stamp: 'dc 7/25/2005 10:15'!
with: anObject 
	^ self new element: anObject! !
BookMorph subclass: #StackMorph
	instanceVariableNames: 'cards'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Stacks'!
!StackMorph commentStamp: '<historical>' prior: 0!
A book that is very much like a HyperCard stack.  

Each book page represents a different background.  The page stays while different cards are projected onto it.  
	The data for a single card is stored in a CardPlayer.  There is a list of objects that only appear on this card (privateMorphs) and the card-specific text to be inserted into the background fields.

Item					How it is stored
a background			a page of the StackMorph
a card					data is in an instance of a subclass of CardPlayer.
						A list of CardPlayers is in the 'cards' inst var of the StackMorph.
a background field		a TextMorph on a page of the StackMorph
a background picture	a morph of any kind on a page of the StackMorph
script for bkgnd button		method in Player.  Button is its costume.
text in a background field		value of inst var 'field1' in a CardPlayer.
								(The CardPlayer is also pointed at by the #cardInstance 
								property of the bkgnd field (TextMorph))
text in a card field		in the TextMorph in privateMorphs in the CardPlayer.
picture on a card		a morph of any kind in privateMorphs in the CardPlayer.
script for card button	method in the CardPlayer.  Button is its costume.

See VariableDock.!


!StackMorph methodsFor: 'accessing' stamp: 'sw 11/2/2002 15:51'!
cardNumberOf: aPlayer
	"Answer the card-number of the given player, in the which-card-of-the-stack sense."

	^ self cards identityIndexOf: aPlayer ifAbsent: [0]! !

!StackMorph methodsFor: 'accessing' stamp: 'sw 3/18/2002 02:09'!
cardsOrPages
	"The turnable and printable entities"

	^ self cards! !


!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/23/2000 16:27'!
commitCardData
	"Make certain that the player data are written back to the player instance"

	^ self currentCard commitCardPlayerData 
! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'em 3/31/2005 10:56'!
insertCardOfBackground
	"Prompt the user for choice of a background, and insert a new card of that background"

	| bgs aMenu aBackground |
	(bgs _ self backgrounds) size == 1 ifTrue:
		[self inform: 
'At this time, there IS only one kind of
background in this stack, so that''s
what you''ll get' translated.
		^ self insertCard].
	aMenu _ SelectionMenu
		labels: 		(bgs collect: [:bg | bg externalName])
		selections: 	bgs.
	(aBackground _ aMenu startUp) ifNotNil:
		[self insertCardOfBackground: aBackground]! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/18/2002 02:02'!
insertCardOfBackground: aBackground
	"Insert a new card of the given background and have it become the current card"

	| newCard |
	newCard _  aBackground newCard.
	self privateCards add: newCard after: self currentCard.
	self goToCard: newCard! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 10:08'!
openInsideLook
	"Open an inside-look at the current page.  This is a previously-demoed feature not presently incorporated in released code,"

	true ifTrue: [self notYetImplemented] ifFalse: [self currentPage openInsideLook]
! !


!StackMorph methodsFor: 'background' stamp: 'nb 6/17/2003 12:25'!
addCardsFromAFile
	"Using the current background, create new cards by reading in data from a fileThe data are in each record are expected to be tab-delimited, and to occur in the same order as the instance variables of the current-background's cards "

	| aFileStream |
	(aFileStream _ FileList2 modalFileSelector) ifNil: [^ Beeper beep].
	self addCardsFromString: aFileStream contentsOfEntireFile.
	aFileStream close! !

!StackMorph methodsFor: 'background' stamp: 'nb 6/17/2003 12:25'!
addCardsFromClipboardData
	"Using the current background, paste data from the (textual) clipboard to create new records.  The data are in each record are expected to be tab-delimited, and to occur in the same order as the instance variables of the current-background's cards "

	| clip |
	(clip _ Clipboard clipboardText) isEmptyOrNil ifTrue: [^ Beeper beep].
	self addCardsFromString: clip! !

!StackMorph methodsFor: 'background' stamp: 'nb 6/17/2003 12:25'!
addCardsFromClipboardDataForInstanceVariables: slotNames
	"Using the current background, paste data from the (textual) clipboard to create new records.  No senders, but can be usefully called manually for selectively bringing in data in oddball format."

	| clip |
	(clip _ Clipboard clipboardText) isEmptyOrNil ifTrue: [^ Beeper beep].
	self addCardsFromString: clip slotNames: slotNames! !

!StackMorph methodsFor: 'background' stamp: 'nb 6/17/2003 12:25'!
addCardsFromFile: fileStream
	"Using the current background, take tab delimited data from the file to create new records."

	| aString |
	(aString _ fileStream contentsOfEntireFile) isEmptyOrNil ifTrue: [^ Beeper beep].
	self addCardsFromString: aString! !

!StackMorph methodsFor: 'background' stamp: 'sw 12/18/2001 11:35'!
addCardsFromString: aString
	"Using the current background, add cards from a string, which is expected be tab- and return-delimited.  The data are in each record are expected to be tab-delimited, and to occur in the same order as the instance variables of the current-background's cards "

	self addCardsFromString: aString slotNames: self currentCard slotNames
 
! !

!StackMorph methodsFor: 'background' stamp: 'em 3/31/2005 10:23'!
addCardsFromString: aString slotNames: slotNames 
	"Using the current background, add cards from a string, which is expected be tab- and return-delimited"

	| count |
	count := 0.
	aString asString linesDo: 
			[:aLine | 
			aLine notEmpty 
				ifTrue: 
					[count := count + 1.
					self 
						insertCardOfBackground: self currentPage
						withDataFrom: aLine
						forInstanceVariables: slotNames]].
	self inform: count asString , ' card(s) added' translated! !

!StackMorph methodsFor: 'background' stamp: 'sw 10/26/2000 14:41'!
backgroundWithCard: aCard
	"Answer the background which contains aCard."

	^ self backgrounds detect:
		[:aBackground | aBackground containsCard: aCard] ifNone: [nil]! !

!StackMorph methodsFor: 'background' stamp: 'sw 10/30/2000 10:04'!
backgrounds
	"Answer the list of backgrounds available in the receiver"

	^ self pages! !

!StackMorph methodsFor: 'background' stamp: 'sw 12/6/2001 21:26'!
beDefaultsForNewCards
	"Make the values that I see here all be accepted as defaults for new cards"

	self currentPage submorphs do:
		[:aMorph | aMorph holdsSeparateDataForEachInstance ifTrue:
			[aMorph setAsDefaultValueForNewCard]]! !

!StackMorph methodsFor: 'background' stamp: 'sw 11/2/2002 17:56'!
changeInstVarOrder
	"Change the order of the receiver's instance variables"

	| reply |
	reply _ FillInTheBlank request: 'rearrange, then accept; or cancel' initialAnswer:
		((self currentPage player class instVarNames asArray collect: [:v | v asSymbol]) storeString copyWithoutAll: #($# $( $))) asString.
	reply isEmptyOrNil ifTrue: [^ self].
	self flag: #deferred.  "Error checking and graceful escape wanted"
	self currentPage player class resortInstanceVariables: (Compiler evaluate:
		('#(', reply, ')'))! !

!StackMorph methodsFor: 'background' stamp: 'em 3/30/2005 14:47'!
insertAsBackground: newPage resize: doResize
	"Make a new background for the stack.  Obtain a name for it from the user.  It starts out life empty"

	| aName |
	aName _ FillInTheBlank request: 'What should we call this new background?' translated initialAnswer: 'alternateBackground' translated.
	aName isEmptyOrNil ifTrue: [^ self].
	newPage beSticky.
	doResize ifTrue: [newPage extent: currentPage extent].
	newPage beAStackBackground.
	newPage setNameTo: aName.
	newPage vResizeToFit: false.
	pages isEmpty
		ifTrue: [pages add: newPage]
		ifFalse: [pages add: newPage after: currentPage].
	self privateCards add: newPage currentDataInstance after: currentPage currentDataInstance.
	self nextPage.
! !

!StackMorph methodsFor: 'background' stamp: 'tk 10/30/2001 19:01'!
makeNewBackground
	"Make a new background for the stack.  Obtain a name for it from the user.  It starts out life empty"

	| newPage |
	(newPage _ PasteUpMorph newSticky) color: self color muchLighter.
	newPage borderWidth: currentPage borderWidth; borderColor: currentPage borderColor.
	self insertAsBackground: newPage resize: true. 
! !

!StackMorph methodsFor: 'background' stamp: 'sw 3/18/2002 02:14'!
sortByField: varName
	"Perform a simple reordering of my cards, sorting by the given field name.  If there are multiple backgrounds, then sort the current one, placing all its cards first, followed by all others in unchanged order"

	| holdCards thisClassesInstances sortedList |
	holdCards _ self privateCards copy.

	thisClassesInstances _ self privateCards select: [:c | c isKindOf: self currentCard class].
	sortedList _ thisClassesInstances asSortedCollection:
		[:a :b | (a instVarNamed: varName) asString <= (b instVarNamed: varName) asString].
	sortedList _ sortedList asOrderedCollection.
	holdCards removeAllFoundIn: sortedList.
	self privateCards:  (sortedList asOrderedCollection, holdCards).
	self goToFirstCardOfStack
! !

!StackMorph methodsFor: 'background' stamp: 'sw 12/6/2001 22:08'!
sortCards
	"Let the user provide an inst var on which to sort the cards of a background."

	| names aMenu |
	names _ self currentPage player class instVarNames.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Choose field by which to sort:'.
	names do: [:n | aMenu add: n selector: #sortByField: argument: n].
	aMenu popUpInWorld! !


!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:24'!
browseCardClass
	"Browse the class of the current card"

	| suffix |
	suffix _ self currentCard class name numericSuffix.
	HierarchyBrowser newFor: self currentCard class labeled: 'Background ', suffix asString
! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:20'!
cardIndexOf: aCard
	"Answer the ordinal position of aCard in the receiver's list"

	^ self privateCards indexOf: aCard ifAbsent: [nil]! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:12'!
cards
	"Answer a list of the cards of the receiver, in order"

	^ self privateCards copy! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:27'!
currentCard
	"Answer the current card of the current background of the receiver"

	^ currentPage currentDataInstance! !

!StackMorph methodsFor: 'card access' stamp: 'em 3/31/2005 10:24'!
deleteAllCardsExceptThisOne
	"Delete all cards except the current one"

	self privateCards size <= 1 ifTrue: [^ Beeper beep].
	(self confirm: 'Really delete ' translated, self privateCards size asString, ' card(s) and all of their data?' translated) ifTrue:
		[self privateCards: (OrderedCollection with: self currentCard)].! !

!StackMorph methodsFor: 'card access' stamp: 'sd 11/13/2003 21:03'!
deleteCard
	"Delete the current card from the stack"

	| aCard |
	aCard _ self currentCard.
	self privateCards size = 1 ifTrue: [^ Beeper beep].
	(self confirm: 'Really delete this card and all of its data?' translated) ifTrue:
		[self goToNextCardInStack.
		self privateCards remove: aCard].! !

!StackMorph methodsFor: 'card access' stamp: 'nb 6/17/2003 12:25'!
deleteCard: aCard
	"Delete the current card from the stack."

	self privateCards size = 1 ifTrue: [^ Beeper beep].
	(aCard == self currentCard) ifTrue: [^ self deleteCard].

	self privateCards remove: aCard ifAbsent: []! !

!StackMorph methodsFor: 'card access' stamp: 'em 3/31/2005 10:23'!
goToCard
	"prompt the user for an ordinal number, and use that as a basis for choosing a new card to install in the receiver"

	| reply index |
	reply _ FillInTheBlank request: 'Which card number? ' translated initialAnswer: '1'.
	reply isEmptyOrNil ifTrue: [^ self].
	((index _ reply asNumber) > 0 and: [index <= self privateCards size])
		ifFalse: [^ self inform: 'no such card'].
	self goToCard: (self privateCards at: index)! !

!StackMorph methodsFor: 'card access' stamp: 'sw 11/8/2002 15:15'!
goToCard: destinationCard
	"Install the indicated destinationCard as the current card in the receiver.  Any viewer currently open on the current card will get retargeted to look at the new one."

	| aBackground existingCard oldViewers |
	destinationCard == self currentCard ifTrue: [^ self].
	self currentPlayerDo:
		[:aPlayer | aPlayer runAllClosingScripts].   "Like HyperCard 'on closeCard'"

	aBackground _ self backgroundWithCard: destinationCard.
	existingCard _ aBackground currentDataInstance.
	oldViewers _ existingCard ifNil: [#()] ifNotNil: [existingCard allOpenViewers].

	aBackground installAsCurrent: destinationCard.
	aBackground setProperty: #myStack toValue: self.	"pointer cardMorph -> stack"

	aBackground ~~ currentPage ifTrue:
		[self goToPageMorph: aBackground runTransitionScripts: false].
	self currentPlayerDo:
		[:aPlayer | aPlayer runAllOpeningScripts] .  "Like HyperCard 'on opencard'"

	oldViewers do: [:aViewer | aViewer retargetFrom: existingCard to: destinationCard]! !

!StackMorph methodsFor: 'card access' stamp: 'sw 11/11/2002 03:07'!
goToCardNumber: aCardNumber
	"Install the card whose ordinal number is provided as the current card in the stack"

	self goToCard: (self privateCards atWrap: aCardNumber)! !

!StackMorph methodsFor: 'card access' stamp: 'nb 6/17/2003 12:25'!
goToFirstCardInBackground
	"Install the initial card in the current background as the current card in the stack"

	| kind |
	kind _ currentPage player class baseUniclass.
	self goToCard: (self privateCards detect: [:aCard | aCard isKindOf: kind] ifNone: [^ Beeper beep])! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:01'!
goToFirstCardOfStack
	"Install the initial card in the stack as the current card"

	self goToCard: self privateCards first! !

!StackMorph methodsFor: 'card access' stamp: 'nb 6/17/2003 12:25'!
goToLastCardInBackground
	"Install the final card in the current background as the current card"

	| kind |
	kind _ currentPage player class baseUniclass.
	self goToCard: (self privateCards reversed detect: [:aCard | aCard isKindOf: kind] ifNone: [^ Beeper beep])! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:09'!
goToLastCardOfStack
	"Install the final card in the stack as the current card"

	self goToCard: self privateCards last! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:03'!
insertCardOfBackground: aBackground withDataFrom: aLine forInstanceVariables: slotNames
	"Insert a new card of the given background and have it become the current card. "

	| newCard |
	newCard _  aBackground newCard.
	self privateCards add: newCard after: self currentCard.
	newCard absorbBackgroundDataFrom: aLine forInstanceVariables: slotNames.
	self goToCard: newCard! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 01:57'!
makeCurrentCardFirstInStack
	"Move the current card such that it becomes the first card in the stack"

	| aCard |
	aCard _ self currentCard.
	self privateCards remove: aCard ifAbsent: [];
		addFirst: aCard.
	self currentPage flash! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:03'!
makeCurrentCardLastInStack
	"Move the current card such that it becomes the last card in the stack"

	| aCard |
	aCard _ self currentCard.
	self privateCards remove: aCard ifAbsent: [];
		addLast: aCard.
	self currentPage flash! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:08'!
moveCardOnePositionEarlier
	"Move the current card such that its ordinal position is one fewer than it formerly was.  If the current card is already the first one one in the stack, then do nothing"

	| aCard aPosition |
	aCard _ self currentCard.
	aCard == self privateCards first ifTrue: [^ self].
	aPosition _ self privateCards indexOf: aCard.
	self privateCards remove: aCard;
		add: aCard afterIndex: (aPosition - 2).
	self currentPage flash! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:05'!
moveCardOnePositionLater
	"Move the current card such that its ordinal position is one greater than it formerly was.  If the current card is already the last one one in the stack, then do nothing"

	| aCard aPosition privateCards |
	aCard _ self currentCard.
	privateCards _ self privateCards.
	aCard == privateCards last ifTrue: [^ self].
	aPosition _ privateCards indexOf: aCard.
	privateCards remove: aCard.
	privateCards add: aCard afterIndex: aPosition.
	self currentPage flash! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 01:56'!
privateCards
	"Private - answer the collection object that sits in my cards instance variable"

	^ cards! !

!StackMorph methodsFor: 'card access' stamp: 'sw 3/18/2002 02:51'!
privateCards: aCollection
	"Private - Make my cards be te given colllection"

	cards _ aCollection! !


!StackMorph methodsFor: 'card in a stack' stamp: 'sw 10/30/2000 10:03'!
explainDesignations
	"Give the user an explanation of what the designations mean"

	self currentPage explainDesignations
! !

!StackMorph methodsFor: 'card in a stack' stamp: 'sw 3/18/2002 02:03'!
goToNextCardInStack
	"Make the card *after* the current card become the current card"

	| anIndex newCard |
	anIndex _ self privateCards indexOf: currentPage currentDataInstance.
	newCard _ self privateCards atWrap: anIndex + 1.
	self goToCard: newCard! !

!StackMorph methodsFor: 'card in a stack' stamp: 'sw 3/18/2002 02:01'!
goToPreviousCardInStack
	"Install the previous card as my current one"

	| anIndex newCard |
	anIndex _ self privateCards indexOf: currentPage currentDataInstance.
	newCard _ self privateCards atWrap: anIndex - 1.
	self goToCard: newCard! !

!StackMorph methodsFor: 'card in a stack' stamp: 'sw 10/23/2000 16:02'!
insertCard
	"Create a new card of the current background and make it become the current card"

	self insertCardOfBackground: currentPage! !

!StackMorph methodsFor: 'card in a stack' stamp: 'tk 10/5/2001 06:27'!
reassessBackgroundShape
	"Have the current page reconsider its cards' instance structure"

	currentPage setProperty: #myStack toValue: self. 	"pointer cardMorph -> stack"
	^ self currentPage reassessBackgroundShape 
! !

!StackMorph methodsFor: 'card in a stack' stamp: 'sw 10/30/2000 10:04'!
relaxGripOnVariableNames
	"Have the current background relax its grip on existing variable name"

	^ self currentPage relaxGripOnVariableNames 
! !

!StackMorph methodsFor: 'card in a stack' stamp: 'sw 10/30/2000 10:15'!
reshapeBackground
	"Abandon any memory of variable-name preferences for the current background, and reassess its instance structure"

	^ self currentPage reshapeBackground 
! !

!StackMorph methodsFor: 'card in a stack' stamp: 'sw 10/30/2000 10:10'!
showDesignationsOfObjects
	"Momentarily show which objects on the current card belong to which designation category"

	self currentPage showDesignationsOfObjects
! !

!StackMorph methodsFor: 'card in a stack' stamp: 'sw 10/23/2000 17:37'!
stackDo: aBlock
	"Evaluate aBlock on behalf of the receiver stack"

	^ aBlock value: self! !


!StackMorph methodsFor: 'controls' stamp: 'sw 10/30/2000 16:31'!
pageControlsMorphFrom: controlSpecs
	"Answer a controls morph derived from the spec supplied"

	| controls |
	controls _ super pageControlsMorphFrom: controlSpecs.
	controls eventHandler: nil.  "not grabbable"
	^ controls! !


!StackMorph methodsFor: 'debugging' stamp: 'sw 10/30/2000 10:13'!
inspectCurrentBackground
	"Open an inspector on the corrent background.  Ideally should put include the background name in the inspector's title."

	^ self currentPage inspectWithLabel: 'A Background'
! !

!StackMorph methodsFor: 'debugging' stamp: 'sw 10/23/2000 16:37'!
inspectCurrentCard
	"For debugging: open an Inspector on the receiver's current card"

	^ self currentCard inspectWithLabel: 'A Card'
! !

!StackMorph methodsFor: 'debugging' stamp: 'sw 10/30/2000 10:09'!
inspectCurrentStack
	"Triggered from the stack-debug menu, open an Inspector on the receiver"

	^ self inspectWithLabel: 'A Stack'
! !


!StackMorph methodsFor: 'initialization' stamp: 'sw 6/5/2003 04:04'!
addPane: aPane paneType: aType
	| anIndex |
	anIndex _ self insertionIndexForPaneOfType: aType.
	self privateAddMorph: aPane atIndex: anIndex! !

!StackMorph methodsFor: 'initialization' stamp: 'sw 3/18/2002 02:12'!
initialize
	"Initialize the stack"

	| initialBackground |
	super initialize.
	initialBackground _ pages first.
	initialBackground extent: (640@480); beSticky.
	initialBackground beAStackBackground.
	self beUnsticky.
	self setProperty: #controlsAtBottom toValue: true.
	self privateCards: (OrderedCollection with: initialBackground currentDataInstance).

"self currentHand attachMorph: StackMorph authoringPrototype"! !

!StackMorph methodsFor: 'initialization' stamp: 'sw 3/18/2002 02:13'!
initializeWith: aCardMorph
	"Install the card inside a new stack.  Make no border or controls, so I the card's look is unchanged.  Card already has a CardPlayer."
	
	| wld |
	wld _ aCardMorph world.
	self initialize.
	self pageSize: aCardMorph extent.
	self borderWidth: 0; layoutInset: 0; color: Color transparent.
	pages _ Array with: aCardMorph.
	currentPage _ aCardMorph.
	self privateCards: (OrderedCollection with: currentPage currentDataInstance).
	currentPage beAStackBackground.
	self position: aCardMorph position.
	submorphs last delete.
	self addMorph: currentPage.	
	self showPageControls: self fullControlSpecs.
	wld addMorph: self.
! !


!StackMorph methodsFor: 'insert and delete' stamp: 'sw 10/30/2000 10:10'!
defaultNameStemForNewPages
	"Answer the stem to use as the default for names of cards in the stack"

	^ 'card'
! !


!StackMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:14'!
addBookMenuItemsTo: aMenu hand: aHandMorph
	"Add book-related items to the given menu"

	| controlsShowing subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'previous card' translated action: #goToPreviousCardInStack.
	subMenu add: 'next card' translated action: #goToNextCardInStack.
	subMenu add: 'go to card...' translated action: #goToCard.
	subMenu add: 'insert a card' translated action: #insertCard.
	subMenu add: 'delete this card' translated action: #deleteCard.

	controlsShowing _ self hasSubmorphWithProperty: #pageControl.
	controlsShowing
		ifTrue:
			[subMenu add: 'hide card controls' translated action: #hidePageControls.
			subMenu add: 'fewer card controls' translated action: #fewerPageControls]
		ifFalse:
			[subMenu add: 'show card controls' translated action: #showPageControls].

	subMenu addLine.
	subMenu add: 'sound effect for all backgrounds' translated action: #menuPageSoundForAll:.
	subMenu add: 'sound effect this background only' translated action: #menuPageSoundForThisPage:.
	subMenu add: 'visual effect for all backgrounds' translated action: #menuPageVisualForAll:.
	subMenu add: 'visual effect this background 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  addUpdating: #showingFullScreenString action: #toggleFullScreen.
	subMenu addLine.
	subMenu add: 'search for text' translated action: #textSearch.
	(self primaryHand 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
! !

!StackMorph methodsFor: 'menu' stamp: 'sw 3/18/2002 02:06'!
findText: wants
	"Turn to the next card 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 _ self privateCards identityIndexOf: self currentCard ifAbsent: [1].
	fromHereOn _ here+1 to: self privateCards 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 findWordStart: searchString startingAt: 1) > 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 
				cardNum: here) ifTrue: [
					self setProperty: #searchKey toValue: wants.
					^ true]]]
		ifFalse: [fromHereOn _ here to: self privateCards size].	"do search this page"
	"other pages"
	fromHereOn do: [:cardNum |
		(self findText: wants inStrings: (allText at: cardNum) startAt: 1 container: nil 
				cardNum: cardNum) 
					ifTrue: [^ true]].
	startToHere do: [:cardNum |
		(self findText: wants inStrings: (allText at: cardNum) startAt: 1 container: nil 
				cardNum: cardNum) 
					ifTrue: [^ true]].
	"if fail"
	self setProperty: #searchContainer toValue: nil.
	self setProperty: #searchOffset toValue: nil.
	self setProperty: #searchKey toValue: nil.
	^ false! !

!StackMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:13'!
findText: keys inStrings: rawStrings startAt: startIndex container: oldContainer cardNum: cardNum 
	"Call once to search a card of the stack.  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 strings old |
	good := true.
	start := startIndex.
	strings := oldContainer ifNil: 
					["normal case"

					rawStrings]
				ifNotNil: [self currentPage allStringsAfter: oldContainer text].
	keys do: 
			[:searchString | 
			"each key"

			good 
				ifTrue: 
					[thisWord := false.
					strings do: 
							[:longString | 
							(index := longString findWordStart: searchString startingAt: start) > 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 goToCardNumber: cardNum
			"wasIn ifFalse: ['search again, on the real current text.  Know page is in.'.
			^ self findText: keys 
				inStrings: ((pages at: pageNum) allStringsAfter: nil)         recompute it	
				startAt: startIndex container: oldContainer 
				pageNum: pageNum]"].
	(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! !

!StackMorph methodsFor: 'menu' stamp: 'em 3/31/2005 10:20'!
findViaTemplate
	| list pl cardInst |
	"Current card is the template.  Only search cards in this background. Look at cards directly (not allText). Key must be found in the same field as in the template.  HyperCard style (multiple starts of words).  
	Put results in a list, outside the stack."

	list _ self templateMatches.
	list isEmpty ifTrue: [^ self inform: 'No matches were found.
Be sure the current card is mostly blank
and only has text you want to match.' translated]. 
	"put up a PluggableListMorph"
	cardInst _ self currentCard.
	cardInst matchIndex: 0.	"establish entries"
	cardInst results at: 1 put: list.
	self currentPage setProperty: #myStack toValue: self.	"way to get back"

	pl _ PluggableListMorph new
			on: cardInst list: #matchNames
			selected: #matchIndex changeSelected: #matchIndex:
			menu: nil "#matchMenu:shifted:" keystroke: nil.
	ActiveHand attachMorph: (self formatList: pl).
! !

!StackMorph methodsFor: 'menu' stamp: 'tk 6/2/2001 11:40'!
formatList: pl
	| rr ff |
	"Turn this plugglable list into a good looking morph."

	pl color: Color transparent; borderWidth: 0.
	pl font: ((TextStyle named: #Palatino) fontOfSize: 14).
	pl toggleCornerRounding; width: 252; retractableOrNot; hResizing: #spaceFill.
	rr _ (RectangleMorph new) toggleCornerRounding; extent: pl extent + (30@30).
	rr color: self currentPage color; fillStyle: (ff _ self currentPage fillStyle copy).
	ff isGradientFill ifTrue: [
		rr fillStyle direction: (ff direction * self currentPage extent / rr extent) rounded.
		rr fillStyle origin: rr bounds origin].
	rr addMorph: pl.
	rr layoutPolicy: TableLayout new.
	rr layoutInset: 10@15; cellInset: 10@15; wrapDirection: #leftToRight.
	rr listCentering: #center; borderWidth: 5; borderColor: #raised.
	"Up and down buttons on left with arrows in a holder."
	"lb _ (RectangleMorph new) color: transparent; borderWidth: 0."
	^ rr! !

!StackMorph methodsFor: 'menu' stamp: 'sw 3/18/2002 02:07'!
getAllText
	"Collect the text for each card.  Just point at strings so don't have to recopy them.  (Parallel array of urls for ID of cards.  Remote cards not working yet.)
	allText = Array (cards size) of arrays (fields in it) of strings of text.
	allTextUrls = Array (cards size) of urls or card numbers."

	| oldUrls oldStringLists allText allTextUrls aUrl which |
	self writeSingletonData.
	oldUrls _ self valueOfProperty: #allTextUrls ifAbsent: [#()].
	oldStringLists _ self valueOfProperty: #allText ifAbsent: [#()].
	allText _ self privateCards collect: [:pg | OrderedCollection new].
	allTextUrls _ Array new: self privateCards size.
	self privateCards doWithIndex: [:aCard :ind | aUrl _ aCard url.  aCard isInMemory 
		ifTrue: [(allText at: ind) addAll: (aCard allStringsAfter: nil).
			aUrl ifNil: [aUrl _ ind].
			allTextUrls at: ind put: aUrl]
		ifFalse: ["Order of cards on server may be different.  (later keep up to date?)"
			"*** bug in this algorithm if delete a page?"
			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! !

!StackMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:47'!
invokeBookMenu
	"Invoke the book's control panel menu."

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Stack' translated.
	Preferences noviceMode
		ifFalse: [aMenu addStayUpItem].
	aMenu addList: {
		{'find...' translated.					#textSearch}.
		{'find via this template' translated.			#findViaTemplate}.
		{'show designations' translated. 			#showDesignationsOfObjects}.
		{'explain designations' translated.			#explainDesignations}.
		#-.
		{'previous card' translated. 				#goToPreviousCardInStack}.
		{'next card' translated. 				#goToNextCardInStack}.
		{'first card' translated. 				#goToFirstCardOfStack}.
		{'last card' translated. 				#goToLastCardOfStack}.
		{'go to card...' translated. 				#goToCard}.
		#-.
		{'add a card of this background' translated. 		#insertCard}.
		{'add a card of background...' translated.		#insertCardOfBackground}.
		{'make a new background...' translated. 		#makeNewBackground}.
		#-.
		{'insert cards from clipboard data' translated.		#addCardsFromClipboardData.	'Create new cards from a formatted string on the clipboard' translated}.
		{'insert cards from a file...' translated.		#addCardsFromAFile.		'Create new cards from data in a file' translated}.
		#-.
		{'instance variable order...' translated.		#changeInstVarOrder.		'Caution -- DANGER. Change the order of the variables on the cards' translated}.
		{'be defaults for new cards' translated. 		#beDefaultsForNewCards.		'Make these current field values be the defaults for their respective fields on new cards' translated}.
		    {'sort cards by...' translated.			#sortCards.			'Sort all the cards of the current background using some field as the sort key' translated}.
		#-.
		{'delete this card' translated. 			#deleteCard}.
		{'delete all cards *except* this one' translated.	#deleteAllCardsExceptThisOne}.
		#-.
		{'move card to front of stack' translated.		#makeCurrentCardFirstInStack}.
		{'move card to back of stack' translated.		#makeCurrentCardLastInStack}.
		{'move card one position earlier' translated.		#moveCardOnePositionEarlier}.
		{'move card one position later' translated.		#moveCardOnePositionLater}.
		#-.
		{'scripts for this background' translated.		#browseCardClass}.
		#-.
		{'debug...' translated.					#offerStackDebugMenu}.
		{'bookish items...' translated. 			#offerBookishMenu}}.

	aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls.
	aMenu addUpdating: #showingFullScreenString action: #toggleFullScreen.

	aMenu popUpEvent: self world activeHand lastEvent in: self world
! !

!StackMorph methodsFor: 'menu' stamp: 'dgd 4/4/2006 16:49'!
offerBookishMenu
	"Offer a menu with book-related items in it"

	| aMenu |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Stack / Book' translated.
	Preferences noviceMode
		ifFalse: [aMenu addStayUpItem].
	aMenu addList:
		#(('sort pages' sortPages)
		('uncache page sorter' 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'	 bookmarkForThisPage)
		('make thumbnail' thumbnailForThisPage)).

	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' translated ] ifFalse: ['open' translated]) , ' dragNdrop' translated
			action: #toggleDragNDrop.
	aMenu addLine.
	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 popUpEvent: self world activeHand lastEvent in: self world
! !

!StackMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:47'!
offerStackDebugMenu
	"Put up a menu offering debugging items for the stack"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Stack debugging'.
	Preferences noviceMode
		ifFalse: [aMenu addStayUpItem].
	aMenu addList: #(
		('reassess'								reassessBackgroundShape)
		('relax grip on variable names'			relaxGripOnVariableNames)
		('commit card data'						commitCardData)
		-
		('browse card uniclass'					browseCardClass)
		('inspect card'							inspectCurrentCard)
		('inspect background'					inspectCurrentBackground)
		('inspect stack'							inspectCurrentStack)).
	aMenu popUpInWorld: (self world ifNil: [self currentWorld])
! !

!StackMorph methodsFor: 'menu' stamp: 'sw 3/18/2002 01:58'!
templateMatches
	| template docks keys bkg |
	"Current card is the template.  Only search cards in this background. Look at cards directly (not allText). Key must be found in the same field as in the template.  HyperCard style (multiple starts of words).  
	Put results in a list, outside the stack."

	template _ self currentCard.
	template commitCardPlayerData.
	docks _ template class variableDocks.
	(keys _ template asKeys) ifNil: [^ #()]. "nothing to match against"
	bkg _ self currentPage.
	^ self privateCards select: [:cardPlayer | 
		(((cardPlayer == template) not) and: [cardPlayer costume == bkg]) 
			and: [cardPlayer match: keys fields: docks]].
! !

!StackMorph methodsFor: 'menu' stamp: 'sw 3/18/2002 02:00'!
writeSingletonData
	"Backgrounds that have just one card, may never get their data written into a CardPlayer. Make sure we do it."

	| sieve |
	sieve _ IdentityDictionary new.
	pages do: [:pp | sieve at: pp put: 0].
	self privateCards do: [:cc | sieve at: cc costume put: (sieve at: cc costume) + 1].
	sieve associationsDo: [:ass | 
		ass value = 1 ifTrue:
			[ass key player commitCardPlayerDataFrom: ass key]].
			"If currently showing card, may be some trouble... <- tk note 5/01"! !


!StackMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 13:59'!
addPageControlMorph: aMorph
	"Add the given morph as a page-control, at the appropriate place"

	aMorph setProperty: #pageControl toValue: true.
	self addPane: aMorph paneType: #pageControl! !

!StackMorph methodsFor: 'page controls' stamp: 'tk 11/5/2001 08:21'!
fullControlSpecs
	"Answer specifications for the long form of iconic stack/book controls"

	^ #(
		spacer
		variableSpacer
		('-'			deleteCard					'Delete this card')
		spacer
		( '«'		goToFirstCardOfStack			'First card')
		spacer
		( '<' 		goToPreviousCardInStack		'Previous card')
		spacer
		('·'			invokeBookMenu 			'Click here to get a menu of options for this stack.')
		"spacer	('¶'			reshapeBackground  		'Reshape')	"

		spacer
		('§'			showDesignationsOfObjects 	'Show designations')
		spacer
		('>'			goToNextCardInStack			'Next card')
		spacer
		( '»'		goToLastCardOfStack			'Final card')
		spacer
		('+'			insertCard					'Add a new card after this one')
		variableSpacer
		('³'			fewerPageControls			'Fewer controls
(if shift key pressed,
deletes controls)')
)! !

!StackMorph methodsFor: 'page controls' stamp: 'sw 10/30/2000 10:09'!
shortControlSpecs
	"Answer specficiations for the shorter form of stack controls"

	^ #(
		spacer
		variableSpacer
		( '<'		goToPreviousCardInStack		'Previous card')
		spacer
		('·'		invokeBookMenu 			'Click here to get a menu for this stack.')
		spacer
		('>'		goToNextCardInStack			'Next card')
		variableSpacer
		('³'	showMoreControls				'More controls
(if shift key pressed,
deletes controls)'))! !


!StackMorph methodsFor: 'parts bin' stamp: 'sw 8/2/2001 18:14'!
initializeToStandAlone
	
	self initialize.
	self pageSize: (480 @ 320); color: (Color gray: 0.7).
	self borderWidth: 1; borderColor: Color black.
	self currentPage extent: self pageSize.
	self showPageControls: self fullControlSpecs.
	^ self

"StackMorph initializedInstance openInHand"! !


!StackMorph methodsFor: 'submorphs-accessing' stamp: 'sw 3/18/2002 02:20'!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy.  Especially the non-showing pages in BookMorphs."

	| coll |
	coll _ OrderedCollection new.
	self privateCards do: [:cd | 
		cd privateMorphs ifNotNil: [coll addAll: cd privateMorphs]].
	^ coll! !

!StackMorph methodsFor: 'submorphs-accessing' stamp: 'sw 6/5/2003 04:01'!
insertionIndexForPaneOfType: aType
	| naturalIndex insertionIndex |
	naturalIndex _ self naturalPaneOrder indexOf: aType.
	insertionIndex _ 1.
	(self naturalPaneOrder copyFrom: 1 to: (naturalIndex - 1)) do: "guys that would precede"
		[:sym | (self hasSubmorphWithProperty: sym)
			ifTrue:
				[insertionIndex _ insertionIndex + 1]].
	^ insertionIndex! !

!StackMorph methodsFor: 'submorphs-accessing' stamp: 'sw 6/5/2003 04:02'!
naturalPaneOrder
	^ #(header pageControl retrieve search index content)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StackMorph class
	instanceVariableNames: ''!

!StackMorph class methodsFor: 'authoring prototype' stamp: 'nk 7/12/2003 08:59'!
designationsExplainer
	"Answer a morph that contains designation explanation"

	| aMorph aSwatch aTextMorph |
	aMorph _ AlignmentMorph newColumn color: Color black; layoutInset: 1.
	#((green		
'Shared items on
Background.
Exact same item
shared by every card')
	(orange
'Data items on
Background
Each card has its
own data')
	(red
'Instance-specific
items
unique
to this card')) do:

	[:aPair |
		aSwatch _ AlignmentMorph new extent: 132 @80; color: (Color perform: aPair first); lock.
		aSwatch hResizing: #rigid; vResizing: #rigid; layoutInset: 0.
		aSwatch borderColor: Color black.
		aTextMorph _ TextMorph new string: aPair second fontName: Preferences standardEToysFont familyName size: 18.
		aTextMorph width: 130.
		aTextMorph centered.
		aSwatch addMorphBack: aTextMorph.
		aMorph addMorphBack: aSwatch].
	aMorph hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	^ aMorph

	"StackMorph designationsExplainer openInHand"
! !


!StackMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:30'!
initialize

	self registerInFlapsRegistry.	! !

!StackMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:36'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(StackMorph	authoringPrototype	'Stack'		'A multi-card data base'	)
						forFlapNamed: 'Scripting'.
						cl registerQuad: #(StackMorph	authoringPrototype	'Stack'		'A multi-card data base'	)
						forFlapNamed: 'Stack Tools'.
						cl registerQuad: #(StackMorph	stackHelpWindow	'Stack Help'	'Some hints about how to use Stacks')
						forFlapNamed: 'Stack Tools'.
						cl registerQuad: #(StackMorph	previousCardButton	'Previous Card'	'A button that takes the user to the previous card in the stack')
						forFlapNamed: 'Stack Tools'.
						cl registerQuad: #(StackMorph	nextCardButton	'Next Card'		'A button that takes the user to the next card in the stack')
						forFlapNamed: 'Stack Tools']! !

!StackMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:40'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!StackMorph class methodsFor: 'misc' stamp: 'tk 12/14/2001 19:23'!
discoverSlots: aMorph
	"Examine the parts of the morph for ones that couldHoldSeparateData.  Return a pair of lists: Named morphs, and unnamed morphs (which may be labels, and non-data).  Examine all submorphs."

	| named unnamed got sn generic |
	named _ OrderedCollection new.
	unnamed _ OrderedCollection new.
	aMorph submorphsDo: [:direct | 
		got _ false.
		direct allMorphsDo: [:sub |
			sub couldHoldSeparateDataForEachInstance ifTrue: [
				(sn _ sub knownName) ifNotNil: [
					generic _ (#('Number (fancy)' 'Number (mid)' 'Number (bare)')
									includes: sn).
					(sn beginsWith: 'shared' "label") | generic ifFalse: [
						named add: sub.
						got _ true]]]].
		got ifFalse: [unnamed add: direct]].
	^ Array with: named with: unnamed
		! !


!StackMorph class methodsFor: 'navigation buttons' stamp: 'sw 10/27/2000 10:53'!
nextCardButton
	"Answer a button that advances the user to the next card in the stack"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aButton; actionSelector: #goToNextCardInStack; label: '>'; color: Color yellow; borderWidth: 0.
	aButton setNameTo: 'next'.
	^ aButton! !

!StackMorph class methodsFor: 'navigation buttons' stamp: 'sw 10/27/2000 10:53'!
previousCardButton
	"Answer a button that will take the user to the preceding card in the stack"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aButton; actionSelector: #goToPreviousCardInStack; label: '<'; color: Color yellow ; borderWidth: 0.
	aButton setNameTo: 'previous'.
	^ aButton! !


!StackMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:52'!
descriptionForPartsBin
	^ self partName:	'Stack'
		categories:		#('Presentation')
		documentation:	'A database of any sort -- slide show, rolodex, and any point in between'! !

!StackMorph class methodsFor: 'parts bin' stamp: 'sw 4/8/2002 09:30'!
stackHelpWindow
	^ (Workspace new contents: 'A "stack" is a place where you can create, store, view and retrieve data "fields" from a set of "cards".  Data that you want to occur on every card (such as a name and an address in an Address Stack) are represented by objects such as "Simple Text", "Fancy Text", and "Scrolling Text" that you obtain from the Stack Tools flap.

When you look at a card in a Stack, you may be seeing three different kinds of material.  Press the § button in the stack''s controls to see the current designations, and use the "explain designations" to get a reminder of what the three different colors mean.
·  Things that are designated to be seen on every card, and have the same contents whichever card is being shown. (green)
·  Things that are designated to be seen on every card, with each card having its own value for them. (orange)
·  Things that are designated to occur only on the particular card at hand. (red)

Use the "stack/cards" menu (in an object''s halo menu) to change the designation of any object.  For example, if you have an object that is private to just one card, and you want to make it visible on all cards, use "place onto background".  If you further want it to hold a separate value for each separate card, use "start holding separate data for each instance".

The normal sequence to define a Stack''s structure is to obtain a blank Stack, then create your fields by grabbing what you want from the Stack Tools flap and dropping it where you want it in the stack.  For easiest use, give a name to each field (by editing the name in its halo) *before* you put it onto the background..  Those fields that you want to represent the basic data of the stack need to be given names, placed on the background, and then told to hold separate data.

When you hit the + button in a stack''s controls, a new card is created with default values in all the fields.  You can arrange for a particular default value to be used in a field -- do this either for one field at a time with "be default value on new card", or you can request that the all the values seen on a particular card serve as default by choosing "be defaults for new cards" from the stack''s · menu.

It is also possible to have multiple "backgrounds" in the same stack -- each different background defines a different data structure, and cards from multiple backgrounds can be freely mixed in the same stack.

Besides text fields, it is also possible to have picture-valued fields -- and potentially fields with data values of any other type as well.')

	embeddedInMorphicWindowLabeled: 'Stack Help'

	"StackMorph stackHelpWindow"! !


!StackMorph class methodsFor: 'scripting' stamp: 'sw 11/2/2002 15:47'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ # ((#'stack navigation'
			((command goToNextCardInStack 'Go to the next card')
			(command goToPreviousCardInStack  'Go to the previous card')
			(command goToFirstCardInBackground 'Go to the first card of the current background')
			(command goToFirstCardOfStack 'Go to the first card of the entire stack')
			(command goToLastCardInBackground 'Go to the last card of the current background')
			(command goToLastCardOfStack 'Go to the last card of the entire stack')
			(command deleteCard 'Delete the current card')
			(command insertCard 'Create a new card')
			(slot cardNumber 'The ordinal number of the current card' Number readWrite Player getCardNumber Player setCardNumber:))))! !

!StackMorph class methodsFor: 'scripting' stamp: 'sw 10/9/2000 07:43'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	| book |
	book _ self new markAsPartsDonor.
	book pageSize: (480 @ 320); color: (Color gray: 0.7).
	book borderWidth: 1; borderColor: Color black.
	book currentPage extent: book pageSize.
	book showPageControls: book fullControlSpecs.
	^ book

"self currentHand attachMorph: StackMorph authoringPrototype"! !
TestCase subclass: #StackTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Stack'!

!StackTest methodsFor: 'test' stamp: 'dc 6/21/2006 10:55'!
testEmptyError

	| aStack |
	aStack := Stack new.
	self should: [ aStack top ] raise: Error.
	self should: [ aStack pop] raise: Error.
	
	aStack push: 'element'.
	
	self shouldnt: [ aStack top ] raise: Error.
	self shouldnt: [ aStack pop] raise: Error.
	
	
	"The stack is empty again due to previous pop"
	self should: [ aStack top ] raise: Error.
	self should: [ aStack pop] raise: Error.! !

!StackTest methodsFor: 'test' stamp: 'sd 3/21/2006 22:13'!
testPop

	| aStack res elem |
	elem := 'anElement'.	
	aStack := Stack new.
	self assert: aStack isEmpty.
	
	aStack push: 'a'.
	aStack push: elem.
	res := aStack pop.	
	self assert: res = elem.
	self assert: res == elem.
	
	self assert: aStack size = 1.
	aStack pop.
	self assert: aStack isEmpty.

! !

!StackTest methodsFor: 'test' stamp: 'sd 3/21/2006 22:13'!
testPush
	
	| aStack |
	aStack := Stack new.
	aStack push: 'a'.
	self assert: aStack size = 1.	
	aStack push: 'b'.
	self assert: aStack size = 2.
	! !

!StackTest methodsFor: 'test' stamp: 'sd 3/21/2006 22:13'!
testSize
	
	| aStack |
	aStack := Stack new.
	self assert: aStack size = 0.
	aStack push: 'a'.
	self assert: aStack size = 1.
	aStack push: 'b'.
	self assert: aStack size = 2.
	aStack pop.
	self assert: aStack size = 1.
	aStack pop.
	self assert: aStack size = 0.

 
	


! !

!StackTest methodsFor: 'test' stamp: 'sd 3/21/2006 22:13'!
testTop

	| aStack |
	aStack := Stack new.
	self assert: aStack isEmpty.
	aStack push: 'a'.
	aStack push: 'b'.
	self assert: aStack top = 'b'.
	self assert: aStack top = 'b'.
	self assert: aStack size = 2.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StackTest class
	instanceVariableNames: 'testSize'!
SelectionMenu subclass: #StandardFileMenu
	instanceVariableNames: 'canTypeFileName pattern'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-FileList'!
!StandardFileMenu commentStamp: 'mp 8/15/2005 18:44' prior: 0!
I represent a SelectionMenu which operates like a modal dialog for selecting files, somewhat similar to the StandardFile dialogs in MacOS and Java Swing.

Try for example, the following:

	StandardFileMenu oldFile inspect

	StandardFileMenu oldFileStream inspect

	StandardFileMenu newFile inspect

	StandardFileMenu newFileStream inspect
	
	(StandardFileMenu oldFileMenu: FileDirectory default withPattern: '*') startUpWithCaption: 'Select a file:'
	
	(StandardFileMenu oldFileMenu: (FileDirectory default) withPatternList: {'*.txt'. '*.changes'}) startUpWithCaption: 'Select a file:'
!


!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'rbb 2/16/2005 16:59'!
confirmExistingFiles: aResult

	|choice|
	(aResult directory fileExists: aResult name) ifFalse: [^aResult].
	
	choice _ (UIManager default chooseFrom: #('overwrite that file' 'choose another name'
 'cancel')
		title: aResult name, '
already exists.').

	choice = 1 ifTrue: [
		aResult directory 
			deleteFileNamed: aResult name
			ifAbsent: 
				[^self startUpWithCaption: 
'Can''t delete ', aResult name, '
Select another file'].
		^aResult].
	choice = 2 ifTrue: [^self startUpWithCaption: 'Select Another File'].
	^nil
 ! !

!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'rbb 3/1/2005 11:14'!
getTypedFileName: aResult

	| name |
	name := UIManager default 
		request: 'Enter a new file name' 
		initialAnswer: ''.
	name = '' ifTrue: [^self startUpWithCaption: 'Select a File:' translated].
	name := aResult directory fullNameFor: name.
	^ StandardFileMenuResult
			directory: (FileDirectory forFileName: name)
			name: (FileDirectory localNameFor: name)
! !

!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'acg 9/28/1999 23:34'!
startUpWithCaption: aString at: location

	|result|
	result _ super startUpWithCaption: aString at: location.
	result ifNil: [^nil].
	result isDirectory ifTrue:
		[self makeFileMenuFor: result directory.
		 self computeForm.
		 ^self startUpWithCaption: aString at: location].
	result isCommand ifTrue: 
		[result _ self getTypedFileName: result.
		result ifNil: [^nil]].
	canTypeFileName ifTrue: [^self confirmExistingFiles: result].
	^result
	! !


!StandardFileMenu methodsFor: 'menu building' stamp: 'di 5/12/2000 10:31'!
directoryNamesString: aDirectory
"Answer a string concatenating the directory name strings in aDirectory, each string followed by a '[...]' indicator, and followed by a cr."

	^ String streamContents:
		[:s | aDirectory directoryNames do: 
				[:dn | s nextPutAll: dn withBlanksTrimmed , ' [...]'; cr]]

! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'zz 8/15/2005 17:33'!
fileNamesString: aDirectory
"Answer a string concatenating the file name strings in aDirectory, each string followed by a cr."

	^String streamContents:
		[:s | 
			aDirectory fileNames do: 
				[:fn |
					pattern do:[:each | (each match: fn) ifTrue: [
						s nextPutAll: fn withBlanksTrimmed; cr]]]]
		! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'zz 8/15/2005 16:28'!
makeFileMenuFor: aDirectory
"Initialize an instance of me to operate on aDirectory"

	| theMenu |
	pattern ifNil: [pattern := {'*'}].
	Cursor wait showWhile: 
		[self 
			labels: 	(self menuLabelsString: aDirectory)
			font: 	(MenuStyle fontAt: 1) 
			lines: 	(self menuLinesArray: aDirectory).
		theMenu := self selections: (self menuSelectionsArray: aDirectory)].
	^theMenu! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'acg 4/15/1999 21:57'!
menuLabelsString: aDirectory
"Answer a menu labels object corresponding to aDirectory"

	^ String streamContents: 
		[:s | 
			canTypeFileName ifTrue: 
				[s nextPutAll: 'Enter File Name...'; cr].
			s nextPutAll: (self pathPartsString: aDirectory).
			s nextPutAll: (self directoryNamesString: aDirectory).
			s nextPutAll: (self fileNamesString: aDirectory).
			s skip: -1]! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'tpr 11/28/2003 15:12'!
menuLinesArray: aDirectory
"Answer a menu lines object corresponding to aDirectory"

	| typeCount nameCnt dirDepth|
	typeCount _ canTypeFileName 
		ifTrue: [1] 
		ifFalse: [0].
	nameCnt _ aDirectory directoryNames size.
	dirDepth _ aDirectory pathParts size.
	^Array streamContents: [:s |
		canTypeFileName ifTrue: [s nextPut: 1].
		s nextPut: dirDepth + typeCount + 1.
		s nextPut: dirDepth + nameCnt + typeCount + 1]! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'zz 8/15/2005 18:18'!
menuSelectionsArray: aDirectory
"Answer a menu selections object corresponding to aDirectory.  The object is an array corresponding to each item, each element itself constituting a two-element array, the first element of which contains a selector to operate on and the second element of which contains the parameters for that selector."

	|dirSize|
	dirSize := aDirectory pathParts size.
	^Array streamContents: [:s |
		canTypeFileName ifTrue:
			[s nextPut: (StandardFileMenuResult
				directory: aDirectory
				name: nil)].
		s nextPut: (StandardFileMenuResult
			directory: (FileDirectory root)
			name: '').
		aDirectory pathParts doWithIndex: 
			[:d :i | s nextPut: (StandardFileMenuResult
					directory: (self 
						advance: dirSize - i
						containingDirectoriesFrom: aDirectory)
					name: '')].
		aDirectory directoryNames do: 
			[:dn |  s nextPut: (StandardFileMenuResult
						directory: (FileDirectory on: (aDirectory fullNameFor: dn))
						name: '')].
		aDirectory fileNames do: 
			[:fn | pattern do: [:pat | (pat match: fn) ifTrue: [
					s nextPut: (StandardFileMenuResult
						directory: aDirectory
						name: fn)]]]]! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'acg 4/15/1999 21:03'!
pathPartsString: aDirectory
"Answer a string concatenating the path parts strings in aDirectory, each string followed by a cr."

	^String streamContents:
		[:s | 
			s nextPutAll: '[]'; cr.
			aDirectory pathParts asArray doWithIndex: 
				[:part :i |
					s next: i put: $ .
					s nextPutAll: part withBlanksTrimmed; cr]]! !


!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 00:32'!
advance: anInteger containingDirectoriesFrom: aDirectory

	| theDirectory |
	theDirectory _ aDirectory.
	1 to: anInteger do: [:i | theDirectory _ theDirectory containingDirectory].
	^theDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 20:50'!
computeLabelParagraph
	"Answer a Paragraph containing this menu's labels, one per line and centered."

	^ Paragraph withText: labelString asText style: (MenuStyle leftFlush)! !

!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 22:03'!
newFileFrom: aDirectory

	canTypeFileName _ true.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 18:25'!
newFileFrom: aDirectory withPatternList: aPatternList

	canTypeFileName := true.
	pattern := aPatternList.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 16:29'!
newFileFrom: aDirectory withPattern: aPattern

	canTypeFileName := true.
	pattern := {aPattern}.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 22:03'!
oldFileFrom: aDirectory

	canTypeFileName _ false.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 17:28'!
oldFileFrom: aDirectory withPatternList: aPatternList

	canTypeFileName := false.
	pattern := aPatternList.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 16:28'!
oldFileFrom: aDirectory withPattern: aPattern

	canTypeFileName := false.
	pattern := {aPattern}.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 17:29'!
patternList: aPatternList

	pattern := aPatternList! !

!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 16:31'!
pattern: aPattern
	" * for all files, or '*.cs' for changeSets, etc.  Just like fileLists"

	pattern := {aPattern}! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardFileMenu class
	instanceVariableNames: ''!

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:14'!
newFileMenu: aDirectory
	Smalltalk isMorphic ifFalse: [^ PluggableFileList newFileMenu: aDirectory].
	^ super new newFileFrom: aDirectory! !

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'zz 8/15/2005 18:21'!
newFileMenu: aDirectory withPatternList: aPatternList
	Smalltalk isMorphic ifFalse: [^ PluggableFileList newFileMenu: aDirectory].
	^ super new newFileFrom: aDirectory withPatternList: aPatternList! !

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'rww 9/23/2001 09:56'!
newFileMenu: aDirectory withPattern: aPattern
	Smalltalk isMorphic ifFalse: [^ PluggableFileList newFileMenu: aDirectory].
	^ super new newFileFrom: aDirectory withPattern: aPattern! !

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:15'!
oldFileMenu: aDirectory
	Smalltalk isMorphic ifFalse: [^ PluggableFileList oldFileMenu: aDirectory].
	^ super new oldFileFrom: aDirectory! !

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'zz 8/15/2005 17:41'!
oldFileMenu: aDirectory withPatternList: aPatternList

	Smalltalk isMorphic ifFalse: [^PluggableFileList oldFileMenu: aDirectory].
	^super new oldFileFrom: aDirectory withPatternList: aPatternList! !

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'RAA 5/25/2000 09:30'!
oldFileMenu: aDirectory withPattern: aPattern

	Smalltalk isMorphic ifFalse: [^PluggableFileList oldFileMenu: aDirectory].
	^super new oldFileFrom: aDirectory withPattern: aPattern! !


!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'!
newFile

	^self newFileFrom: (FileDirectory default)! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'dgd 9/21/2003 13:17'!
newFileFrom: aDirectory

	^(self newFileMenu: aDirectory)
		startUpWithCaption: 'Select a File:' translated! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'acg 4/15/1999 22:18'!
newFileStream

	^self newFileStreamFrom: (FileDirectory default)! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'!
newFileStreamFrom: aDirectory

	| sfmResult fileStream |
	sfmResult _ self newFileFrom: aDirectory.
	sfmResult ifNil: [^nil].
	fileStream _ sfmResult directory newFileNamed: sfmResult name.
	[fileStream isNil] whileTrue:
		[sfmResult _ self newFileFrom: aDirectory.
		sfmResult ifNil: [^nil].
		fileStream _ sfmResult directory newFileNamed: sfmResult name].
	^fileStream
! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'!
oldFile

	^self oldFileFrom: (FileDirectory default)! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'dgd 9/21/2003 13:17'!
oldFileFrom: aDirectory

	^(self oldFileMenu: aDirectory)
		startUpWithCaption: 'Select a File:' translated! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'MM 4/6/2004 22:56'!
oldFileFrom: aDirectory withPattern: aPattern
"
Select an existing file from a selection conforming to aPattern.
"
	^(self oldFileMenu: aDirectory withPattern: aPattern)
		startUpWithCaption: 'Select a File:' translated! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'acg 4/15/1999 22:17'!
oldFileStream

	^self oldFileStreamFrom: (FileDirectory default)
! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:27'!
oldFileStreamFrom: aDirectory

	| sfmResult fileStream |
	sfmResult _ self oldFileFrom: aDirectory.
	sfmResult ifNil: [^nil].
	fileStream _ sfmResult directory oldFileNamed: sfmResult name.
	[fileStream isNil] whileTrue:
		[sfmResult _ self oldFileFrom: aDirectory.
		sfmResult ifNil: [^nil].
		fileStream _ sfmResult directory oldFileNamed: sfmResult name].
	^fileStream
! !
Object subclass: #StandardFileMenuResult
	instanceVariableNames: 'directory name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-FileList'!

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'!
directory

	^directory! !

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'!
directory: aDirectory

	^directory _ aDirectory! !

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'!
name

	^name! !

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'!
name: aString

	^name _ aString! !

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'sw 6/9/1999 11:50'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' with directory: '.
	directory printOn: aStream.
	aStream nextPutAll: ' name: '.
	name printOn: aStream

"StandardFileMenu oldFile"! !


!StandardFileMenuResult methodsFor: 'testing' stamp: 'acg 4/15/1999 09:05'!
isCommand

	^name isNil! !

!StandardFileMenuResult methodsFor: 'testing' stamp: 'acg 4/15/1999 20:57'!
isDirectory

	^name = ''! !


!StandardFileMenuResult methodsFor: 'private' stamp: 'acg 4/15/1999 08:42'!
directory: aDirectory name: aString

	directory _ aDirectory.
	name _ aString.
	^self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardFileMenuResult class
	instanceVariableNames: ''!

!StandardFileMenuResult class methodsFor: 'instance creation' stamp: 'acg 4/15/1999 08:42'!
directory: aDirectory name: aString

	^super new directory: aDirectory name: aString! !
FileStream subclass: #StandardFileStream
	instanceVariableNames: 'name fileID buffer1'
	classVariableNames: 'Registry'
	poolDictionaries: ''
	category: 'Files-Kernel'!
!StandardFileStream commentStamp: '<historical>' prior: 0!
Provides a simple, platform-independent, interface to a file system.  This initial version ignores issues of Directories etc.  The instance-variable fallbackStream at the moment holds an instance of HFSMacFileStream, to bridge us to the new world while in the old.  The instance variable rwmode, inherited from class PositionableStream, here is used to hold a Boolean -- true means opened for read-write, false means opened for read-only.  2/12/96 sw!


!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:16'!
directory
	"Return the directory containing this file."

	^ FileDirectory forFileName: self fullName
! !

!StandardFileStream methodsFor: 'access' stamp: 'tk 3/14/2000 23:31'!
directoryUrl

	^ self directory url! !

!StandardFileStream methodsFor: 'access'!
file
	"Answer the object representing the receiver's file.  Need for compatibility with some calls -- check senders.  2/14/96 sw"

	^ self! !

!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:19'!
fullName
	"Answer this file's full path name."

	^ name
! !

!StandardFileStream methodsFor: 'access'!
isDirectory
	"Answer whether the receiver represents a directory.  For the post-transition case, uncertain what to do.  2/14/96 sw"
	^ false! !

!StandardFileStream methodsFor: 'access' stamp: 'ar 11/24/1998 14:00'!
localName
	^ name ifNotNil: [(name findTokens: FileDirectory pathNameDelimiter asString) last]! !

!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:19'!
name
	"Answer this file's full path name."

	^ name
! !

!StandardFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:32'!
peekFor: item 
	"Answer false and do not advance if the next element is not equal to item, or if this stream is at the end.  If the next element is equal to item, then advance over it and return true"
	| next |
	"self atEnd ifTrue: [^ false]. -- SFStream will give nil"
	(next := self next) == nil ifTrue: [^ false].
	item = next ifTrue: [^ true].
	self skip: -1.
	^ false! !

!StandardFileStream methodsFor: 'access'!
printOn: aStream
	"Put a printed version of the receiver onto aStream.  1/31/96 sw"

	aStream nextPutAll: self class name; nextPutAll: ': '; print: name! !

!StandardFileStream methodsFor: 'access' stamp: 'ar 6/16/2002 18:58'!
reset
	self ensureOpen.
	self position: 0.! !

!StandardFileStream methodsFor: 'access'!
size
	"Answer the size of the file in characters.  2/12/96 sw"

	^ self primSize: fileID! !


!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 1/11/2000 10:44'!
defaultBrowserReadyWait
	^5000! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
post: data target: target url: url ifError: errorBlock
	"Post data to the given URL. The returned file stream contains the reply of the server.
	If Squeak is not running in a browser evaluate errorBlock"
	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema := Semaphore new.
	index := Smalltalk registerExternalObject: sema.
	request := self primURLPost: url target: target data: data semaIndex: index.
	request == nil ifTrue:[
	
	Smalltalk unregisterExternalObject: sema.
		^errorBlock value.
	] ifFalse:[
		[sema wait. "until something happens"
		result := self primURLRequestState: request.
		result == nil] whileTrue.
		result ifTrue:[fileID := self primURLRequestFileHandle: request].
		self primURLRequestDestroy: request.
	].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name := url.
	rwmode := false.
	buffer1 := String new: 1.! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 2/2/2001 14:22'!
post: data url: url ifError: errorBlock

	self post: data target: nil url: url ifError: errorBlock! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'ar 2/26/2001 15:58'!
primBrowserReady
	<primitive:'primitivePluginBrowserReady'>
	^nil! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 9/21/2000 16:58'!
primURLPost: url data: contents semaIndex: index
	^self primURLPost: url target: nil data: contents semaIndex: index! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 9/21/2000 16:58'!
primURLPost: url target: target data: contents semaIndex: index
	"Post the data (url might be 'mailto:' etc)"
	<primitive:'primitivePluginPostURL'>
	^nil
 ! !

!StandardFileStream methodsFor: 'browser requests'!
primURLRequest: url semaIndex: index
	<primitive:'primitivePluginRequestURLStream'>
	^nil! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
primURLRequest: url target: target semaIndex: index
	"target - String (frame, also ':=top', ':=parent' etc)"
	<primitive:'primitivePluginRequestURL'>
	^nil
 ! !

!StandardFileStream methodsFor: 'browser requests'!
primURLRequestDestroy: request
	<primitive:'primitivePluginDestroyRequest'>
	^nil! !

!StandardFileStream methodsFor: 'browser requests'!
primURLRequestFileHandle: request
	<primitive: 'primitivePluginRequestFileHandle'>
	^nil! !

!StandardFileStream methodsFor: 'browser requests'!
primURLRequestState: request
	<primitive:'primitivePluginRequestState'>
	^false! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 2/29/2000 11:22'!
requestURL: url target: target
	^self requestURL: url target: target ifError: [nil]! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
requestURL: url target: target ifError: errorBlock
	"Request to go to the target for the given URL.
	If Squeak is not running in a browser evaluate errorBlock"

	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema := Semaphore new.
	index := Smalltalk registerExternalObject: sema.
	request := self primURLRequest: url target: target semaIndex: index.
	request == nil ifTrue:[
	
	Smalltalk unregisterExternalObject: sema.
		^errorBlock value.
	] ifFalse:[
		[sema wait. "until something happens"
		result := self primURLRequestState: request.
		result == nil] whileTrue.
		self primURLRequestDestroy: request.
	].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name := url.
	rwmode := false.
	buffer1 := String new: 1.! !

!StandardFileStream methodsFor: 'browser requests'!
requestURLStream: url
	"FileStream requestURLStream:'http://www.squeak.org'"
	^self requestURLStream: url ifError:[nil]! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
requestURLStream: url ifError: errorBlock
	"Request a FileStream for the given URL.
	If Squeak is not running in a browser evaluate errorBlock"
	"FileStream requestURLStream:'http://www.squeak.org'"
	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema := Semaphore new.
	index := Smalltalk registerExternalObject: sema.
	request := self primURLRequest: url semaIndex: index.
	request == nil ifTrue:[
	
	Smalltalk unregisterExternalObject: sema.
		^errorBlock value.
	] ifFalse:[
		[sema wait. "until something happens"
		result := self primURLRequestState: request.
		result == nil] whileTrue.
		result ifTrue:[fileID := self primURLRequestFileHandle: request].
		self primURLRequestDestroy: request.
	].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name := url.
	rwmode := false.
	buffer1 := String new: 1.! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
waitBrowserReadyFor: timeout ifFail: errorBlock
	| startTime delay okay |
	okay := self primBrowserReady.
	okay ifNil:[^errorBlock value].
	okay ifTrue: [^true].
	startTime := Time millisecondClockValue.
	delay := Delay forMilliseconds: 100.
	[(Time millisecondsSince: startTime) < timeout]
		whileTrue: [
			delay wait.
			okay := self primBrowserReady.
			okay ifNil:[^errorBlock value].
			okay ifTrue: [^true]].
	^errorBlock value! !


!StandardFileStream methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 20:01'!
primDropRequestFileHandle: dropIndex
	"Primitive. Return the (read-only) file handle for some file that was just dropped onto Squeak.
	Fail if dropIndex is out of range or the primitive is not supported."
	<primitive: 'primitiveDropRequestFileHandle' module:'DropPlugin'>
	^nil! !

!StandardFileStream methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 20:01'!
primDropRequestFileName: dropIndex
	"Primitive. Return the file name for some file that was just dropped onto Squeak.
	Fail if dropIndex is out of range or the primitive is not supported."
	<primitive: 'primitiveDropRequestFileName' module:'DropPlugin'>
	^nil! !

!StandardFileStream methodsFor: 'dnd requests' stamp: 'stephaneducasse 2/4/2006 20:32'!
requestDropStream: dropIndex
	"Return a read-only stream for some file the user has just dropped onto Squeak."
	name := self primDropRequestFileName: dropIndex.
	fileID := self primDropRequestFileHandle: dropIndex.
	fileID == nil ifTrue:[^nil].
	self register.
	rwmode := false.
	buffer1 := String new: 1.

! !


!StandardFileStream methodsFor: 'finalization' stamp: 'ar 3/21/98 18:16'!
actAsExecutor
	super actAsExecutor.
	name := nil.! !

!StandardFileStream methodsFor: 'finalization' stamp: 'ar 10/7/1998 15:44'!
finalize
	self primCloseNoError: fileID.! !


!StandardFileStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:32'!
close
	"Close this file."

	fileID ifNotNil: [
		self primClose: fileID.
		self unregister.
		fileID := nil].
! !

!StandardFileStream methodsFor: 'open/close' stamp: 'jm 2/6/2002 08:33'!
closed
	"Answer true if this file is closed."

	^ fileID isNil or: [(self primSizeNoError: fileID) isNil]
! !

!StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/21/1998 16:20'!
ensureOpen
	"Make sure that this file really is open."

	self closed ifTrue: [^ self reopen].
	(self primSizeNoError: fileID) ifNotNil: [^ self].
	self reopen.
! !

!StandardFileStream methodsFor: 'open/close'!
open
	"For compatibility with a few existing things.  2/14/96 sw"

	^ self reopen! !

!StandardFileStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:32'!
open: fileName forWrite: writeMode 
	"Open the file with the given name. If writeMode is true, allow writing, otherwise open the file in read-only mode."
	"Changed to do a GC and retry before failing ar 3/21/98 17:25"
	| f |
	f := fileName asVmPathName.

	fileID := StandardFileStream retryWithGC:[self primOpen: f writable: writeMode] 
					until:[:id| id notNil] 
					forFileNamed: fileName.
	fileID ifNil: [^ nil].  "allows sender to detect failure"
	self register.
	name := fileName.
	rwmode := writeMode.
	buffer1 := String new: 1.
! !

!StandardFileStream methodsFor: 'open/close'!
openReadOnly
	"Open the receiver as a read-only file.  1/31/96 sw"

	^ self open: name forWrite: false! !

!StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/21/1998 13:58'!
reopen
	"Close and reopen this file. The file position is reset to zero."
	"Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened."

	fileID ifNotNil: [self primCloseNoError: fileID].
	self open: name forWrite: rwmode.
! !


!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAtEnd: id
	"Answer true if the file position is at the end of the file."

	<primitive: 'primitiveFileAtEnd' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primClose: id
	"Close this file."

	<primitive: 'primitiveFileClose' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primCloseNoError: id
	"Close this file. Don't raise an error if the primitive fails."

	<primitive: 'primitiveFileClose' module: 'FilePlugin'>
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'stephaneducasse 2/4/2006 20:32'!
primFlush: id
	"Flush pending changes to the disk"
	| p |
	<primitive: 'primitiveFileFlush' module: 'FilePlugin'>
	"In some OS's seeking to 0 and back will do a flush"
	p := self position.
	self position: 0; position: p! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primGetPosition: id
	"Get this files current position."

	<primitive: 'primitiveFileGetPosition' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primOpen: fileName writable: writableFlag
	"Open a file of the given name, and return the file ID obtained.
	If writableFlag is true, then
		if there is none with this name, then create one
		else prepare to overwrite the existing from the beginning
	otherwise
		if the file exists, open it read-only
		else return nil"

	<primitive: 'primitiveFileOpen' module: 'FilePlugin'>
	^ nil
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primRead: id into: byteArray startingAt: startIndex count: count
	"Read up to count bytes of data from this file into the given string or byte array starting at the given index. Answer the number of bytes actually read."

	<primitive: 'primitiveFileRead' module: 'FilePlugin'>
	self closed ifTrue: [^ self error: 'File is closed'].
	self error: 'File read failed'.
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSetPosition: id to: anInteger
	"Set this file to the given position."

	<primitive: 'primitiveFileSetPosition' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSize: id
	"Answer the size of this file."

	<primitive: 'primitiveFileSize' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSizeNoError: id
	"Answer the size of this file. Answer nil if the primitive fails; this indicates that the file handle has become stale."

	<primitive: 'primitiveFileSize' module: 'FilePlugin'>
	^ nil
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'JMM 5/24/2001 21:55'!
primTruncate: id to: anInteger
	"Truncate this file to the given position."

	<primitive: 'primitiveFileTruncate' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primWrite: id from: stringOrByteArray startingAt: startIndex count: count
	"Write count bytes onto this file from the given string or byte array starting at the given index. Answer the number of bytes written."

	<primitive: 'primitiveFileWrite' module: 'FilePlugin'>
	self closed ifTrue: [^ self error: 'File is closed'].
	self error: 'File write failed'.
! !


!StandardFileStream methodsFor: 'properties-setting'!
asHtml
	"Convert me in to an HtmlFileStream. 4/11/96 tk"

	^ self as: HtmlFileStream 
! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'!
ascii
	"opposite of binary"
	buffer1 := String new: 1! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'!
binary
	buffer1 := ByteArray new: 1! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'JMM 1/28/2001 18:44'!
getFileType
	"On the Macintosh, get the file type and creator of this file. On other platforms, do nothing."

	^FileDirectory default
		getMacFileTypeAndCreator: self fullName
		
! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'!
insertLineFeeds
	"(FileStream oldFileNamed: 'BBfix2.st') insertLineFeeds"
	| s crLf f |
	crLf := String with: Character cr with: (Character value: 10).
	s := ReadStream on: (self next: self size).
	self close.
	f := FileStream newFileNamed: self name.
	[s atEnd] whileFalse: 
		[f nextPutAll: (s upTo: Character cr); nextPutAll: crLf].
	f close! !

!StandardFileStream methodsFor: 'properties-setting'!
isBinary
	^ buffer1 class == ByteArray! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'tk 11/4/1998 19:17'!
isReadOnly

	^ rwmode not
! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'!
readOnly
	"Make this file read-only."

	rwmode := false.
! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'!
readWrite
	"Make this file writable."

	rwmode := true.
! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'jm 12/5/97 15:14'!
setFileTypeToObject
	"On the Macintosh, set the file type and creator of this file to be a Squeak object file. On other platforms, do nothing. Setting the file type allows Squeak object files to be sent as email attachments and launched by double-clicking. On other platforms, similar behavior is achieved by creating the file with the '.sqo' file name extension."

	FileDirectory default
		setMacFileNamed: self fullName
		type: 'SOBJ'
		creator: 'FAST'.
! !


!StandardFileStream methodsFor: 'read, write, position' stamp: 'sw 2/12/96'!
atEnd
	"Answer whether the receiver is at its end.  "
	^ self primAtEnd: fileID! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
basicNext
	"Answer the next byte from this file, or nil if at the end of the file."

	| count |
	count := self primRead: fileID into: buffer1 startingAt: 1 count: 1.
	count = 1
		ifTrue: [^ buffer1 at: 1]
		ifFalse: [^ nil].
! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
compressFile
	"Write a new file that has the data in me compressed in GZip format."
	| zipped buffer |

	self readOnly; binary.
	zipped := self directory newFileNamed: (self name, FileDirectory dot, 'gz').
	zipped binary; setFileTypeToObject.
		"Type and Creator not to be text, so can be enclosed in an email"
	zipped := GZipWriteStream on: zipped.
	buffer := ByteArray new: 50000.
	'Compressing ', self fullName displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during: [:bar |
			[self atEnd] whileFalse: [
				bar value: self position.
				zipped nextPutAll: (self nextInto: buffer)].
			zipped close.
			self close].
	^zipped! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
findString: string
	"Fast version of #upToAll: to find a String in a file starting from the beginning.
	Returns the position and also sets the position there.
	If string is not found 0 is returned and position is unchanged."

	| pos buffer count oldPos sz |
	oldPos := self position.
	self reset.
	sz := self size.
	pos := 0.
	buffer := String new: 2000.
	[ buffer := self nextInto: buffer.
	(count := buffer findString: string) > 0
		ifTrue: ["Found the string part way into buffer"
			self position: pos.
			self next: count - 1.
			^self position ].
	pos := ((pos + 2000 - string size) min: sz).
	self position: pos.
	pos = sz] whileFalse.
	"Never found it, and hit end of file"
	self position: oldPos.
	^0! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
findStringFromEnd: string
	"Fast version to find a String in a file starting from the end.
	Returns the position and also sets the position there.
	If string is not found 0 is returned and position is unchanged."

	| pos buffer count oldPos |
	oldPos := self position.
	self setToEnd.
	pos := self position.
	[ pos := ((pos - 2000 + string size) max: 0).  "the [+ string size] allows for the case where the end of the search string is at the beginning of the current buffer"
	self position: pos.
	buffer := self next: 2000.
	(count := buffer findString: string) > 0
		ifTrue: ["Found the string part way into buffer"
			self position: pos.
			self next: count-1.  "use next instead of position:, so that CrLfFileStream can do its magic if it is being used"
			^self position].
	pos = 0] whileFalse.
	"Never found it, and hit beginning of file"
	self position: oldPos.
	^0! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 2/6/2001 17:59'!
flush
	"Flush pending changes"
	^self primFlush: fileID! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'mir 2/25/2000 12:37'!
next
	"Answer the next byte from this file, or nil if at the end of the file."

	^ self basicNext! !

!StandardFileStream methodsFor: 'read, write, position'!
next: n
	"Return a string with the next n characters of the filestream in it.  1/31/96 sw"
	^ self nextInto: (buffer1 class new: n)! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
next: n into: aString startingAt: startIndex
	"Read n bytes into the given string.
	Return aString or a partial copy if less than
	n elements have been read."
	| count |
	count := self primRead: fileID into: aString
				startingAt: startIndex count: n.
	count = n
		ifTrue:[^aString]
		ifFalse:[^aString copyFrom: 1 to: startIndex+count-1]! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 1/2/2000 15:33'!
next: anInteger putAll: aString startingAt: startIndex
	"Store the next anInteger elements from the given collection."
	rwmode ifFalse: [^ self error: 'Cannot write a read-only file'].
	self primWrite: fileID from: aString startingAt: startIndex count: anInteger.
	^aString! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'jm 9/21/1998 13:55'!
nextPut: char
	"Write the given character to this file."

	rwmode ifFalse: [^ self error: 'Cannot write a read-only file'].
	buffer1 at: 1 put: char.
	self primWrite: fileID from: buffer1 startingAt: 1 count: 1.
	^ char
! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 2/5/2000 21:43'!
nextPutAll: aString
	"Write all the characters of the given string to this file."

	rwmode ifFalse: [^ self error: 'Cannot write a read-only file'].
	self primWrite: fileID from: aString startingAt: 1 count: aString basicSize.
	^ aString
! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 2/5/2000 21:58'!
nextWordsInto: aBitmap
	"Note: The file primitives automatically adjust for word based objects."

	self next: aBitmap basicSize into: aBitmap startingAt: 1.
	aBitmap restoreEndianness.
	^ aBitmap! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
padToEndWith: aChar
	"On the Mac, files do not truncate.  One can delete the old file and write a new one, but sometime deletion fails (file still open? file stale?).  This is a sad compromise.  Just let the file be the same length but pad it with a harmless character."

	| pad |
	self atEnd ifTrue: [^ self].
	pad := self isBinary 
		ifTrue: [aChar asCharacter asciiValue]	"ok for char or number"
		ifFalse: [aChar asCharacter].
	self nextPutAll: (buffer1 class new: ((self size - self position) min: 20000) 
							withAll: pad).! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
peek
	"Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil.  "
	| next |
	self atEnd ifTrue: [^ nil].
	next := self basicNext.
	self position: self position - 1.
	^ next! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 10/19/2001 11:29'!
peekLast
	"Return that item just put at the end of the stream"

	^ buffer1 size > 0 
		ifTrue: [buffer1 last]
		ifFalse: [nil]
! !

!StandardFileStream methodsFor: 'read, write, position'!
position
	"Return the receiver's current file position.  2/12/96 sw"

	^ self primGetPosition: fileID! !

!StandardFileStream methodsFor: 'read, write, position'!
position: pos
	"Set the receiver's position as indicated.  2/12/96 sw"

	^ self primSetPosition: fileID to: pos! !

!StandardFileStream methodsFor: 'read, write, position'!
readInto: byteArray startingAt: startIndex count: count
	"Read into the given array as specified, and return the count
	actually transferred.  index and count are in units of bytes or
	longs depending on whether the array is Bitmap, String or ByteArray"
	^ self primRead: fileID into: byteArray
			startingAt: startIndex count: count
! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'yo 10/31/2002 22:33'!
readOnlyCopy

	^ self class readOnlyFileNamed: self name.
! !

!StandardFileStream methodsFor: 'read, write, position'!
setToEnd
	"Set the position of the receiver to the end of file.  1/31/96 sw"

	self position: self size! !

!StandardFileStream methodsFor: 'read, write, position'!
skip: n
	"Set the character position to n characters from the current position.
	Error if not enough characters left in the file.  1/31/96 sw"

	self position: self position + n! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'JMM 5/24/2001 22:00'!
truncate
	"Truncate to zero"

	^ self truncate: 0! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'JMM 5/24/2001 22:47'!
truncate: pos
	"Truncate to this position"

	self position: pos.
	^self primTruncate: fileID to: pos! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
upTo: delim 
	"Fast version to speed up nextChunk"
	| pos buffer count |
	pos := self position.
	buffer := self next: 2000.
	(count := buffer indexOf: delim) > 0 ifTrue: 
		["Found the delimiter part way into buffer"
		self position: pos + count.
		^ buffer copyFrom: 1 to: count - 1].
	self atEnd ifTrue:
		["Never found it, and hit end of file"
		^ buffer].
	"Never found it, but there's more..."
	^ buffer , (self upTo: delim)! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'!
upToEnd
	"Answer a subcollection from the current access position through the last element of the receiver."

	| newStream buffer |
	buffer := buffer1 species new: 1000.
	newStream := WriteStream on: (buffer1 species new: 100).
	[self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)].
	^ newStream contents! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'jm 9/21/1998 13:56'!
verbatim: aString
	"A version of nextPutAll that can be called knowing it won't call nextPut: "

	^ self nextPutAll: aString
! !


!StandardFileStream methodsFor: 'registry' stamp: 'ar 3/21/98 17:23'!
register
	^self class register: self! !

!StandardFileStream methodsFor: 'registry' stamp: 'ar 3/21/98 17:23'!
unregister
	^self class unregister: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardFileStream class
	instanceVariableNames: ''!

!StandardFileStream class methodsFor: 'browser requests' stamp: 'mir 3/8/2001 16:28'!
isRunningAsBrowserPlugin
	self new waitBrowserReadyFor: 1000 ifFail: [^false].
	^true! !

!StandardFileStream class methodsFor: 'browser requests' stamp: 'mir 9/7/2000 16:08'!
privateCheckForBrowserPrimitives
	<primitive:'primitivePluginBrowserReady'>
	^false! !


!StandardFileStream class methodsFor: 'error handling' stamp: 'stephaneducasse 2/4/2006 20:32'!
fileDoesNotExistUserHandling: fullFileName

	| selection newName |
	selection := (PopUpMenu labels:
'create a new file
choose another name
cancel')
			startUpWithCaption: (FileDirectory localNameFor: fullFileName) , '
does not exist.'.
	selection = 1 ifTrue:
		[^ self new open: fullFileName forWrite: true].
	selection = 2 ifTrue:
		[ newName := FillInTheBlank request: 'Enter a new file name'
						initialAnswer:  fullFileName.
		^ self oldFileNamed:
			(self fullName: newName)].
	self halt! !

!StandardFileStream class methodsFor: 'error handling' stamp: 'stephaneducasse 2/4/2006 20:32'!
fileExistsUserHandling: fullFileName
	| dir localName choice newName newFullFileName |
	dir := FileDirectory forFileName: fullFileName.
	localName := FileDirectory localNameFor: fullFileName.
	choice := (PopUpMenu
		labels:
'overwrite that file\choose another name\cancel' withCRs)
		startUpWithCaption: localName, '
already exists.'.

	choice = 1 ifTrue: [
		dir deleteFileNamed: localName
			ifAbsent: [self error: 'Could not delete the old version of that file'].
		^ self new open: fullFileName forWrite: true].

	choice = 2 ifTrue: [
		newName := FillInTheBlank request: 'Enter a new file name' initialAnswer: fullFileName.
		newFullFileName := self fullName: newName.
		^ self newFileNamed: newFullFileName].

	self error: 'Please close this to abort file opening'! !

!StandardFileStream class methodsFor: 'error handling' stamp: 'stephaneducasse 2/4/2006 20:32'!
readOnlyFileDoesNotExistUserHandling: fullFileName

	| dir files choices selection newName fileName |
	dir := FileDirectory forFileName: fullFileName.
	files := dir fileNames.
	fileName := FileDirectory localNameFor: fullFileName.
	choices := fileName correctAgainst: files.
	choices add: 'Choose another name'.
	choices add: 'Cancel'.
	selection := (PopUpMenu labelArray: choices lines: (Array with: 5) )
		startUpWithCaption: (FileDirectory localNameFor: fullFileName), '
does not exist.'.
	selection = choices size ifTrue:["cancel" ^ nil "should we raise another exception here?"].
	selection < (choices size - 1) ifTrue: [
		newName := (dir pathName , FileDirectory slash , (choices at: selection))].
	selection = (choices size - 1) ifTrue: [
		newName := FillInTheBlank 
							request: 'Enter a new file name' 
							initialAnswer: fileName].
	newName = '' ifFalse: [^ self readOnlyFileNamed: (self fullName: newName)].
	^ self error: 'Could not open a file'! !


!StandardFileStream class methodsFor: 'file creation' stamp: 'TPR 8/13/1999 21:22'!
fileNamed: fileName
	"Open a file with the given name for reading and writing. If the name has no directory part, then the file will be created in the default directory. If the file already exists, its prior contents may be modified or replaced, but the file will not be truncated on close."

	^ self new open: (self fullName: fileName) forWrite: true
! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
forceNewFileNamed: fileName 
	"Create a new file with the given name, and answer a stream opened 
	for writing on that file. If the file already exists, delete it without 
	asking before creating the new file."
	| dir localName fullName f |
	fullName := self fullName: fileName.
	(self isAFileNamed: fullName)
		ifFalse: [f := self new open: fullName forWrite: true.
			^ f isNil
				ifTrue: ["Failed to open the file"
					(FileDoesNotExistException fileName: fullName) signal]
				ifFalse: [f]].
	dir := FileDirectory forFileName: fullName.
	localName := FileDirectory localNameFor: fullName.
	dir
		deleteFileNamed: localName
		ifAbsent: [(CannotDeleteFileException new
			messageText: 'Could not delete the old version of file ' , fullName) signal].
	f := self new open: fullName forWrite: true.
	^ f isNil
		ifTrue: ["Failed to open the file"
			(FileDoesNotExistException fileName: fullName) signal]
		ifFalse: [f]! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
isAFileNamed: fileName
	"Answer true if a file of the given name exists."

	| f |
	f := self new open: fileName forWrite: false.
	f ifNil: [^ false].
	f close.
	^ true
! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
newFileNamed: fileName
 	"Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, ask the user what to do."

	| fullName |
	fullName := self fullName: fileName.

	^(self isAFileNamed: fullName)
		ifTrue: ["file already exists:"
			(FileExistsException fileName: fullName fileClass: self) signal]
		ifFalse: [self new open: fullName forWrite: true]

! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
oldFileNamed: fileName
	"Open an existing file with the given name for reading and writing. If the name has no directory part, then the file will be created in the default directory. If the file already exists, its prior contents may be modified or replaced, but the file will not be truncated on close."

	| fullName |
	fullName := self fullName: fileName.

	^(self isAFileNamed: fullName)
		ifTrue: [self new open: fullName forWrite: true]
		ifFalse: ["File does not exist..."
			(FileDoesNotExistException fileName: fullName) signal]! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'!
readOnlyFileNamed: fileName 
	"Open an existing file with the given name for reading."

	| fullName f |
	fullName := self fullName: fileName.
	f := self new open: fullName forWrite: false.
	^ f isNil
		ifFalse: [f]
		ifTrue: ["File does not exist..."
			((FileDoesNotExistException fileName: fullName) readOnly: true) signal].

	"StandardFileStream readOnlyFileNamed: 'kjsd.txt' "! !


!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:41'!
register: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry add: anObject! !

!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:41'!
registry
	WeakArray isFinalizationSupported ifFalse:[^nil].
	^Registry isNil
		ifTrue:[Registry := WeakRegistry new]
		ifFalse:[Registry].! !

!StandardFileStream class methodsFor: 'registry' stamp: 'stephaneducasse 2/4/2006 20:32'!
retryWithGC: execBlock until: testBlock forFileNamed: fullName
	"Re-implemented to only force GC if a file with the given name exists"
	| blockValue foundIt |
	blockValue := execBlock value.
	(testBlock value: blockValue) ifTrue:[^blockValue].
	"See if we have a file with the given name"
	foundIt := Registry keys "hold on strongly for now" 
		anySatisfy:[:file| file name sameAs: fullName].
	foundIt ifFalse:[^blockValue].
	Smalltalk garbageCollectMost.
	blockValue := execBlock value.
	(testBlock value: blockValue) ifTrue:[^blockValue].
	Smalltalk garbageCollect.
	^execBlock value.! !

!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:23'!
unregister: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry remove: anObject ifAbsent:[]! !
Object subclass: #StandardScriptingSystem
	instanceVariableNames: ''
	classVariableNames: 'ClassVarNamesInUse FormDictionary HelpStrings StandardPartsBin'
	poolDictionaries: ''
	category: 'Morphic-Refactoring Candidates'!
!StandardScriptingSystem commentStamp: '<historical>' prior: 0!
An instance of this is installed as the value of the global variable "ScriptingSystem".  Client subclasses are invited, such as one used internally by squeak team for ongoing internal work.!


!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'ar 3/3/2001 19:45'!
deletePrivateGraphics
	"ScriptingSystem deletePrivateGraphics"
	self deletePrivateGraphics: self privateGraphics
		afterStoringToFileNamed: 'disGraphics'! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'di 2/3/2001 20:10'!
deletePrivateGraphics: nameList afterStoringToFileNamed: aFileName
	"This method is used to strip private graphics from the FormDictionary and store them on a file of the given name"

	|  replacement toRemove aReferenceStream keySymbol |
	toRemove _ Dictionary new.
	replacement _ FormDictionary at: #Gets.

	nameList do:
		[:aKey |
			keySymbol _ aKey asSymbol.
			(toRemove at: keySymbol put: (self formAtKey: keySymbol)).
			FormDictionary at: keySymbol put: replacement].

	aReferenceStream _ ReferenceStream fileNamed: aFileName.
	aReferenceStream nextPut: toRemove.
	aReferenceStream close! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 2/24/2003 16:28'!
formAtKey: aString
	"Answer the form saved under the given key"

	Symbol hasInterned: aString ifTrue:
		[:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
	^ nil! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'ar 3/3/2001 19:46'!
formAtKey: aKey extent: extent depth: depth
	"ScriptingSystem saveForm: (TileMorph downPicture) atKey: 'downArrow'"
	^ FormDictionary at: aKey asSymbol ifAbsent: [Form extent: extent depth: depth]! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'ar 3/3/2001 19:49'!
formDictionary
	^FormDictionary! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sd 5/11/2003 21:32'!
inspectFormDictionary
	"ScriptingSystem inspectFormDictionary"
	
	GraphicalDictionaryMenu openOn: FormDictionary withLabel: 'Testing One Two Three'! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'ar 3/3/2001 19:44'!
privateGraphics
	"ScriptingSystem deletePrivateGraphics"
	^#(#BadgeMiniPic #BadgePic #Broom #CedarPic #CollagePic #CoverMain #CoverSpiral #CoverTexture #Fred #ImagiPic #KayaPic #StudioPic)! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/6/1999 20:57'!
saveForm: aForm atKey: aKey
	FormDictionary at: aKey asSymbol put: aForm! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/24/1998 14:12'!
squeakyMouseForm
	^ self formAtKey: 'squeakyMouse'

"
	ScriptingSystem saveForm: (Form
	extent: 30@29
	depth: 16
	fromArray: #( 1811114995 1878286257 2012637171 1811180532 1811180533 1811179508 1811180532 1811179508 1744006133 1878289396 1811180533 1878289396 1744007156 1674736630 1744006132 1811114995 1811181556 1744006131 1811246068 1811180532 1811179508 1811180532 1744071668 1811113972 1811180532 1811180532 1811179507 1878288338 1945529332 1744071668 1743941620 1811112945 1811179506 1811114995 1744006131 1744006130 1744005106 1811048434 1811113969 1743939570 1811179506 1743939571 1676833782 1676765171 1811047410 1744006131 1811048435 1811116020 1811180531 1743939571 1811048435 1743939570 1743939570 1743939570 1743940594 1744005106 1811181556 1811180532 1676766196 1743939570 1878420468 1676963830 1189896082 1811245044 1744137204 1744070644 1811179508 1811113971 1743939571 1811179508 1811246070 1811309524 1811302093 1811310580 1811246068 1674867703 1744049472 1120606594 1118465013 1744137205 1811179508 1811180532 1744071667 1744006132 1811112947 1811247095 1605584589 358761132 289435638 1676830707 1741975543 1462778473 1811312631 702891724 1811310548 1945528308 1811178450 1945528307 1878288372 1878353875 1878421494 1051471335 1809213397 1118524175 1811246068 1945659348 1185698607 1878486005 1672694510 1118531574 1607626741 1878420467 1811180533 1743942645 1744072693 1811301035 1185770487 1878486006 1324239597 1811180533 1811116019 1120623438 1878352818 1945462739 704868339 1878289395 1811049459 1878221808 1878223859 1743876083 1811162563 1945463796 1811181556 1464746666 1811116018 1809019893 1120551562 1945464821 1741844468 1466842760 1878289395 1811048434 1811050483 1811050483 1878223859 1049188174 1741910004 1811181556 1256998634 1811114994 1878289396 1466840647 1744007156 1744006131 1676877216 1743940596 1878222835 1743938545 1878351792 1676833781 358641652 1743940596 1811050484 845566798 1811113970 1811114995 1811163652 1811112913 1878420468 1878282028 1811179506 1607560178 1878289395 1676900342 1878351825 1466853330 1811113971 1811116019 635659217 1811179506 1811245045 1676942754 1744137206 1744201717 1676962806 1676962805 1811310581 1676896245 1744199635 1811376117 1744072695 1744005109 1811244019 499279861 1811310581 1811244020 1811293668 1399943159 1605528567 1744136181 982063522 986342388 1744070645 1744189066 430063308 1744071669 1744070644 1744067504 566519797 1744136181 1744137205 1743999854 912813044 1811311606 1742162607 4195488 283139922 1945531382 1253113857 144710948 1601400791 1811246069 1811167879 1464821747 1744136180 1674799094 1811178482 843473875 1811311606 1878533542 2106790 2080066222 1876193270 696845376 627472380 1185772536 1878355957 1743990309 1744007157 1676898294 1744006132 1811114996 1743941620 1811180533 1809204941 4194368 4217681 1878290421 1252982848 4194336 1670540278 1739811795 1878353906 1744006131 1811179506 1744007157 1744005106 1945462771 1811182582 1811311574 1393641133 1462856629 2012638196 1876382449 1112301394 1742041045 1945596917 1676833781 1811113970 1811179507 1811180532 1672705014 1674735606 1672697648 1945725943 1878551479 1809215479 1811312629 1809216504 1809215479 1809215478 1462853490 1878487029 1744007158 1744005075 1811239726 704979363 495004132 700789287 562372997 631646663 1739998892 4194400 1116497846 698688932 562375109 770124262 633609569 495070758 1257010166 562315916 1809279958 2012894002 1047280171 980237901 910966381 1668677696 4194400 6314867 1047281260 908804749 910968495 1393719290 1809279959 1185750370 1809214455 1878469062 423836236 1532188466 1601592148 1462986647 1672937568 4194368 6319062 1603622706 1601525554 1601522417 1047336194 770206679 1878487031 1878409899 977955830 1809145716 1118586509 980105834 980045584 1811372914 980104778 1605526483 1395605131 910769804 1118651052 1534358520 1809136234 1118596053 1532059506 1878485973 1326456163 1945660374 1742106615 1811311607 1945725942 1742107641 1744072693 1811311605 1744203767 1878551543 564478604 1878553591 1603428242 1811048433 1811049459 1051290611 1744006131 1811049459 1878156273 1743874034 1744007156 1743874033 1811048434 1811113970 1743939571 1743933228 1603301363 1743875059 1811049458 1945461745 1811181556 1811113971 1811049458 1811048434 1811116020 1878287346 1878223857 1743940594 1744006130 1744007157 1945395153 1945400309 1811048434 1743810547 1676765170 1878353906 1811113970 1743874032 1810983921 1743874033 1811113971 1676765169 1743874034 1743940593 1743939569 1811047409 1676765168 1743940595 1810981872 1945397235 1607560179 1743941620 1810982897 1810983921 1811048433 1744007155 1743875059 1811048434 1743875058 1743939568 1676832754 1811116019 1811114994 1811244019 1676962805 1677029367 1811244020 1744005106 1743940594 1811246068 1744070645 1676961781 1744004084 1676897269 1811180533 1878353908 1744004083 1744070645)
	offset: 0@0) atKey: 'squeakyMouse'"! !


!StandardScriptingSystem methodsFor: 'help dictionary' stamp: 'dgd 9/1/2003 14:25'!
helpStringOrNilFor: aSymbol 
	"If my HelpStrings dictionary has an entry at the given symbol, 
	answer that entry's value, else answer nil"
	HelpStrings
		at: aSymbol
		ifPresent:[:string | ^ string translated].
^ nil! !

!StandardScriptingSystem methodsFor: 'help dictionary' stamp: 'sw 6/15/1999 17:03'!
initializeHelpStrings
	"Initialize the data structure that determines, for the etoy system, help messages for various scripting elements.  The structure is built up by letting every Morph subclass contribute elements simply by implementing method #helpContributions.  Consult implementors of #helpContributions for examples of how this goes."

	"ScriptingSystem initializeHelpStrings"

	| aDictionary |
	aDictionary _ IdentityDictionary new.  
	"For safety, the new copy is built up in this temp first, so that if an error occurs during the creation of the structure, the old version will remain remain in place"

	Morph withAllSubclasses do:
		[:aClass | (aClass class selectors includes: #helpContributions)
			ifTrue:
				[aClass helpContributions do:
					[:pair | aDictionary at: pair first put: pair second]]].

		HelpStrings _ aDictionary! !


!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 10/30/2000 16:33'!
allClassVarNamesInSystem
	"Compute and answer a set of all the class variable names known to the sytem from any class"

	| aList |
	aList _ OrderedCollection new.
	Object withAllSubclasses do:
		[:c | aList addAll: c allClassVarNames].
	^ aList asSet

	"ScriptingSystem allClassVarNamesInSystem"
! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 6/16/2005 01:35'!
customizeForEToyUsers: aBoolean
	"If aBoolean is true, set things up for etoy users.  If it's false, unset some of those things.  Some things are set when switching into etoy mode but not reversed when switching out of etoy mode."
 
	#(	
		(allowEtoyUserCustomEvents	no		reverse)
		(balloonHelpEnabled			yes		dontReverse)
		(debugHaloHandle			no		reverse)
		(modalColorPickers			yes		dontReverse)
		(oliveHandleForScriptedObjects	no	dontReverse)
		(uniqueNamesInHalos		yes		reverse)
		(useUndo					yes		dontReverse)
		(infiniteUndo				no		dontReverse)
		(warnIfNoChangesFile		no		reverse)
		(warnIfNoSourcesFile		no		reverse)) do:
			[:trip |
				(aBoolean or: [trip third == #reverse]) ifTrue:
					[Preferences enableOrDisable: trip first asPer:
						((trip second == #yes) & aBoolean) | ((trip second == #no) & aBoolean not)]]! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 4/6/2005 09:30'!
soundNamesToSuppress
	"Answer a list of sound-names that are not to be offered in sound-choice pop-ups unless they are the current choice"

	^ #('scrape' 'scritch' 'peaks')! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 11/26/1999 15:44'!
stripGraphicsForExternalRelease
	"ScriptingSystem stripGraphicsForExternalRelease"

	|  replacement |
	replacement _ FormDictionary at: #Gets.

	#('BadgeMiniPic' 'BadgePic' 'Broom' 'CedarPic' 'CollagePic' 'CoverMain' 'CoverSpiral' 'CoverTexture' 'Fred' 'ImagiPic' 'KayaPic' 'StudioPic')
		do:
			[:aKey | FormDictionary at: aKey asSymbol put: replacement]! !


!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 11/1/2004 07:47'!
addCustomEventFor: registrantClass named: aSymbol help: helpString targetMorphClass: targetClass
	| registration |
	registration _ self customEventsRegistry at: aSymbol ifAbsentPut: [ IdentityDictionary new ].
	registration at: registrantClass put: { helpString. targetClass }.
! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 9/26/2003 23:23'!
addUserCustomEventNamed: aSymbol help: helpString
	self currentWorld addUserCustomEventNamed: aSymbol help: helpString.
	"Vocabulary addStandardVocabulary: UserCustomEventNameType new."
	Vocabulary customEventsVocabulary.
	SymbolListTile updateAllTilesForVocabularyNamed: #CustomEvents! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 11/1/2004 08:19'!
customEventNamesAndHelpStringsFor: aPlayer
	| retval help helpStrings morph |
	morph := aPlayer costume renderedMorph.
	retval := SortedCollection sortBlock: [ :a :b | a first < b first ].
	self customEventsRegistry
		keysAndValuesDo: [ :k :v |
			helpStrings := Array streamContents: [ :hsStream |
				v keysAndValuesDo: [ :registrant :array |
					(morph isKindOf: array second) ifTrue: [
						help := String streamContents: [ :stream |
										v size > 1
											ifTrue: [ stream nextPut: $(;
													nextPutAll: array second name;
													nextPut: $);
													space ].
										stream nextPutAll: array first ].
						hsStream nextPut: help ]]].
			helpStrings isEmpty ifFalse: [retval add: { k. helpStrings } ]].
	^ retval! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 9/26/2003 23:31'!
customEventStati
	^self globalCustomEventNames,
	self userCustomEventNames! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 10/12/2003 13:14'!
customEventsRegistry
	^Smalltalk at: #CustomEventsRegistry ifAbsentPut: [ IdentityDictionary new ].! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 9/26/2003 23:30'!
globalCustomEventNames
	^self customEventsRegistry keys asArray sort! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 11/1/2004 07:56'!
globalCustomEventNamesFor: aPlayer
	| morph names |
	morph := aPlayer costume renderedMorph.
	names := SortedCollection new.
	self customEventsRegistry keysAndValuesDo: [ :k :v |
		(v anySatisfy: [ :array | morph isKindOf: array second ])
			ifTrue: [ names add: k ]].
	^names asArray! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 7/20/2003 12:37'!
removeCustomEventNamed: aSymbol for: registrant
	| registration helpString |
	registration _ self customEventsRegistry at: aSymbol ifAbsent: [ ^nil ].
	helpString _ registration removeKey: registrant ifAbsent: [].
	registration isEmpty ifTrue: [ self customEventsRegistry removeKey: aSymbol ].
	^helpString! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 9/26/2003 23:26'!
removeUserCustomEventNamed: eventName
	| retval |
	retval _ self currentWorld removeUserCustomEventNamed: eventName.
	"Vocabulary addStandardVocabulary: UserCustomEventNameType new."
	Vocabulary customEventsVocabulary.
	SymbolListTile updateAllTilesForVocabularyNamed: #CustomEvents.
	^retval! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 6/30/2004 18:16'!
standardEventStati
	"Answer the events that can be directed to a particular morph by its event handler."
	^ #(mouseDown	"run when mouse goes down on me"
		mouseStillDown	"while mouse still down"
		mouseUp		"when mouse comes back up"
		mouseEnter	"when mouse enters my bounds, button up"
		mouseLeave	"when mouse exits my bounds, button up"
		mouseEnterDragging	"when mouse enters my bounds, button down"
		mouseLeaveDragging	"when mouse exits my bounds, button down"
		"keyStroke"
		"gesture"
	)
! !

!StandardScriptingSystem methodsFor: '*eToys-customevents-custom events' stamp: 'nk 9/26/2003 23:22'!
userCustomEventNames
	^ self currentWorld userCustomEventNames! !


!StandardScriptingSystem methodsFor: '*eToys-customevents-help dictionary' stamp: 'nk 11/1/2004 08:21'!
statusHelpStringFor: aPlayer
	^String streamContents: [ :stream |
		stream nextPutAll: 'normal -- run when called
paused -- ready to run all the time
ticking -- run all the time
mouseDown -- run when mouse goes down on me
mouseStillDown -- while mouse still down
mouseUp -- when mouse comes back up
mouseEnter -- when mouse enters my bounds, button up
mouseLeave -- when mouse exits my bounds, button up
mouseEnterDragging -- when mouse enters my bounds, button down
mouseLeaveDragging -- when mouse exits my bounds, button down
opening -- when I am being opened
closing -- when I am being closed' translated.

"'keyStroke -- run when user hits a key' "

	stream cr; cr; nextPutAll: 'More events:' translated; cr.

	(self customEventNamesAndHelpStringsFor: aPlayer) do: [ :array |
		stream cr;
		nextPutAll: array first;
		nextPutAll: ' -- '.
		array second do: [ :help | stream nextPutAll: help translated ]
			separatedBy: [ stream nextPutAll: ' or ' translated ]].

	(Preferences allowEtoyUserCustomEvents) ifTrue: [
	self userCustomEventNames isEmpty ifFalse: [
		stream cr; cr; nextPutAll: 'User custom events:' translated; cr.
		self currentWorld userCustomEventsRegistry keysAndValuesDo: [ :key :value |
			stream cr; nextPutAll: key; nextPutAll: ' -- '; nextPutAll: value ]]]]! !


!StandardScriptingSystem methodsFor: '*eToys-font & color choices' stamp: 'sw 5/2/1998 14:26'!
colorBehindTiles
	^ Color r: 0.903 g: 1.0 b: 0.903! !

!StandardScriptingSystem methodsFor: '*eToys-font & color choices' stamp: 'dgd 7/12/2003 12:06'!
fontForNameEditingInScriptor
	^ Preferences standardEToysFont! !

!StandardScriptingSystem methodsFor: '*eToys-font & color choices' stamp: 'dgd 7/12/2003 12:05'!
fontForTiles
	^ Preferences standardEToysFont! !

!StandardScriptingSystem methodsFor: '*eToys-font & color choices' stamp: 'nk 7/12/2003 08:59'!
smallBoldFont
	"Answer a small bold font for use in some standard scripting-support structures"

	^ StrikeFont familyName: Preferences standardEToysFont familyName size: 12! !

!StandardScriptingSystem methodsFor: '*eToys-font & color choices' stamp: 'sw 9/14/1998 14:41'!
statusColorSymbolFor: statusSymbol
	#(	(normal					green)
		(ticking					blue)
		(paused					red)
		(mouseDown				yellow)
		(mouseStillDown			lightYellow)
		(mouseUp				lightBlue)
		(mouseEnter				lightBrown)
		(mouseLeave			lightRed)
		(mouseEnterDragging	lightGray)
		(mouseLeaveDragging	darkGray)
		(keyStroke				lightGreen)) do:

			[:pair | statusSymbol == pair first ifTrue: [^ pair second]].

		^ #blue! !

!StandardScriptingSystem methodsFor: '*eToys-font & color choices' stamp: 'sw 5/2/1998 14:23'!
uniformTileInteriorColor
	^ Color r: 0.806 g: 1.0 b: 0.806! !


!StandardScriptingSystem methodsFor: '*eToys-form dictionary' stamp: 'sw 5/12/1999 10:09'!
installSolidMenuForm
	"ScriptingSystem installSolidMenuForm"
	self saveForm:
		(Form extent: 14@16 depth: 16
	fromArray: #( 1 0 0 0 0 0 0 65537 65536 0 0 0 65537 0 65537 65537 65537 65537 65537 65537 65536 65537 65537 65537 65537 65537 1600061441 65536 65537 1600085855 1600085855 1600085855 1600085855 1600061441 65536 65537 1600085855 65537 65537 65537 65537 65536 65537 1600085855 65537 65537 65537 1600061441 65536 65537 1600085855 1600085855 1600085855 1600085855 1600085855 65537 65537 1600085855 65537 65537 65537 1600085855 65537 65537 1600085855 1600061441 65537 65537 89951 65537 65537 1600085855 1600085855 1600085855 1600085855 1600085855 65537 65537 1600085855 1600061441 65537 65537 65537 65537 65537 1600085855 65537 65537 65537 65536 65537 65537 65537 65537 65537 65537 65537 65537 1 65537 65537 65537 65537 65537 65536 0 65536 0 0 0 0 0) offset: 0@0)
		atKey: 'SolidMenu'! !

!StandardScriptingSystem methodsFor: '*eToys-form dictionary' stamp: 'sw 11/26/1999 15:37'!
mergeGraphicsFrom: aDictionary
	"aDictionary is assumed to hold associations of the form <formName> -> <form>.   Merge the graphics held by that dictionary into the internal FormDictionary, overlaying any existing entries with the ones found in aDictionary"

	aDictionary associationsDo:
		[:assoc | self saveForm: assoc value atKey: assoc key]

		"works ok even if keys in aDictionary are strings rather than symbols"! !

!StandardScriptingSystem methodsFor: '*eToys-form dictionary' stamp: 'sw 2/20/2002 01:09'!
patchInNewStandardPlayerForm
	"Patch in a darker and larger representation of a Dot.  No senders -- called from the postscript of an update"

	"ScriptingSystem patchInNewStandardPlayerForm"

	FormDictionary at: #standardPlayer put:
		(Form
	extent: 13@13
	depth: 16
	fromArray: #( 0 0 0 65536 0 0 0 0 0 65537 65537 65536 0 0 0 65537 65537 65537 65537 65536 0 0 65537 65537 65537 65537 65536 0 1 65537 65537 65537 65537 65537 0 1 65537 65537 65537 65537 65537 0 65537 65537 65537 65537 65537 65537 65536 1 65537 65537 65537 65537 65537 0 1 65537 65537 65537 65537 65537 0 0 65537 65537 65537 65537 65536 0 0 65537 65537 65537 65537 65536 0 0 0 65537 65537 65536 0 0 0 0 0 65536 0 0 0)
	offset: 0@0)! !

!StandardScriptingSystem methodsFor: '*eToys-form dictionary' stamp: 'sw 5/2/1998 14:01'!
readFormsFromFileNamed: aFileName
	"Read the entire FormDictionary in from a designated file on disk"

	| aReferenceStream |
	aReferenceStream _ ReferenceStream fileNamed: aFileName.
	FormDictionary _ aReferenceStream next.
	aReferenceStream close

	"ScriptingSystem readFormsFromFileNamed: 'EToyForms22Apr'"! !

!StandardScriptingSystem methodsFor: '*eToys-form dictionary' stamp: 'sw 9/14/2000 21:29'!
readFormsFromFileNamed: aFileName andStoreIntoGlobal: globalName
	"Read the a FormDictionary in from a designated file on disk and save it in the designated global"

	| aReferenceStream |
	aReferenceStream _ ReferenceStream fileNamed: aFileName.
	Smalltalk at: globalName put: aReferenceStream next.
	aReferenceStream close

	"ScriptingSystem readFormsFromFileNamed: 'SystemFormsFromFwdF.forms' andStoreIntoGlobal: #FormsTemp"

	"ScriptingSystem saveForm:  (FormsTemp at: #StackElementDesignationHelp) atKey: #StackElementDesignationHelp"! !

!StandardScriptingSystem methodsFor: '*eToys-form dictionary' stamp: 'sw 4/23/1999 11:24'!
restorePrivateGraphics
	"ScriptingSystem restorePrivateGraphics"
	| aReferenceStream |
	aReferenceStream _ ReferenceStream fileNamed: 'disGraphics'.
	self mergeGraphicsFrom: aReferenceStream next.
	aReferenceStream close.
! !

!StandardScriptingSystem methodsFor: '*eToys-form dictionary' stamp: 'sw 5/6/1998 17:46'!
saveFormsToFileNamed: aFileName
	"Save the current state of form dictionary to disk for possible later retrieval"
  	 (ReferenceStream fileNamed: aFileName) nextPut: FormDictionary; close

	"ScriptingSystem saveFormsToFileNamed: 'SystemForms06May98.forms'"! !

!StandardScriptingSystem methodsFor: '*eToys-form dictionary' stamp: 'sw 12/7/1998 16:47'!
standardForms
	"ScriptingSystem standardForms"
	^ FormDictionary collect: [:f | f]! !


!StandardScriptingSystem methodsFor: '*eToys-parts bin' stamp: 'tk 10/20/2004 15:52'!
anyButtonPressedTiles
	"Answer tiles representing the query 'is any button pressed?'"

	^ self tilesForQuery: '(ActiveHand anyButtonPressed)' label: 'button down?' translated! !

!StandardScriptingSystem methodsFor: '*eToys-parts bin' stamp: 'sw 11/16/2004 13:56'!
noButtonPressedTiles
	"Answer tiles representing the query 'is no button pressed?'"

	^ self tilesForQuery: '(ActiveHand noButtonPressed)' label: 'button up?' translated! !

!StandardScriptingSystem methodsFor: '*eToys-parts bin' stamp: 'sw 5/3/1999 22:40'!
prototypicalHolder
	| aHolder |
	aHolder _ PasteUpMorph authoringPrototype color: Color orange muchLighter; borderColor: Color orange lighter.
	aHolder setNameTo: 'holder'; extent: 160 @ 110.
	^ aHolder behaveLikeHolder.
! !

!StandardScriptingSystem methodsFor: '*eToys-parts bin' stamp: 'sw 10/27/1998 13:35'!
resetStandardPartsBin
	"ScriptingSystem resetStandardPartsBin"

	StandardPartsBin _ nil! !

!StandardScriptingSystem methodsFor: '*eToys-parts bin' stamp: 'sw 7/3/2001 08:01'!
tilesForQuery: expressionString label: aLabel
	"Answer scripting tiles that represent the query,"

	| aPhrase aTile |
	aPhrase _ SystemQueryPhrase new.
	aTile _ BooleanTile new.
	aTile setExpression: expressionString  label: aLabel.
	aPhrase addMorph: aTile.
	^ aPhrase
! !


!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'dgd 9/19/2003 14:40'!
goButton
	| aButton |
	aButton _  ThreePhaseButtonMorph new.
	aButton image:  (ScriptingSystem formAtKey: 'GoPicOn');
			offImage: (ScriptingSystem formAtKey: 'GoPic');
			pressedImage: (ScriptingSystem formAtKey: 'GoPicOn');
			actionSelector: #goUp:with:; 
			arguments: (Array with: nil with: aButton);
			actWhen: #buttonUp;
			target: self;
			setNameTo: 'Go Button';
			setBalloonText:
'Resume running all paused scripts' translated.
	^ aButton! !

!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'sw 11/11/1998 15:24'!
goUp: evt with: aGoButton
	aGoButton presenter startRunningScriptsFrom: aGoButton! !

!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'sw 1/23/2001 11:39'!
scriptControlButtons
	"Answer a composite object that serves to control the stop/stop/go status of a Presenter"

	| wrapper |
	wrapper _ AlignmentMorph newRow setNameTo: 'script controls'.
	wrapper vResizing: #shrinkWrap.
	wrapper hResizing: #shrinkWrap.
	wrapper addMorph: self stopButton.
	wrapper addMorphBack: self stepButton.
	wrapper addMorphBack: self goButton.
	wrapper beTransparent.
	^ wrapper! !

!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'dgd 9/19/2003 14:41'!
stepButton
	| aButton |
	self flag: #deferred.  "ambiguity about recipients"
	aButton _ ThreePhaseButtonMorph new.
		aButton
			image:  (ScriptingSystem formAtKey: 'StepPicOn');
			offImage: (ScriptingSystem formAtKey: 'StepPic');
			pressedImage:  (ScriptingSystem formAtKey: 'StepPicOn');
			arguments: (Array with: nil with: aButton);
		 	actionSelector: #stepStillDown:with:; 
			target: self;
			setNameTo: 'Step Button'; 
			actWhen: #whilePressed;
			on: #mouseDown send: #stepDown:with: to: self;
			on: #mouseStillDown send: #stepStillDown:with: to: self;
			on: #mouseUp send: #stepUp:with: to: self;
			setBalloonText:
'Run every paused script exactly once.  Keep the mouse button down over "Step" and everything will keep running until you release it' translated.
	^ aButton! !

!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'sw 10/30/1998 15:33'!
stepDown: evt with: aMorph
	aMorph presenter stopRunningScripts! !

!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'sw 10/30/1998 15:35'!
stepStillDown: dummy with: theButton
	theButton presenter stepStillDown: dummy with: theButton! !

!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'sw 10/30/1998 15:35'!
stepUp: evt with: aMorph
	aMorph presenter stepUp: evt with: aMorph! !

!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'dgd 9/19/2003 14:41'!
stopButton
	"Answer a new button that can serve as a stop button"
	| aButton |
	aButton _ ThreePhaseButtonMorph new.
	aButton
		image:  (ScriptingSystem formAtKey: 'StopPic');
		offImage: (ScriptingSystem formAtKey: 'StopPic');
		pressedImage:  (ScriptingSystem formAtKey: 'StopPicOn').
		aButton actionSelector: #stopUp:with:; 
		arguments: (Array with: nil with: aButton);
		actWhen: #buttonUp;
		target: self;
		setNameTo: 'Stop Button'; 
		setBalloonText: 'Pause all ticking scripts.' translated.
	^ aButton! !

!StandardScriptingSystem methodsFor: '*eToys-script-control' stamp: 'sw 11/11/1998 15:16'!
stopUp: dummy with: theButton
	| aPresenter |
	(aPresenter _ theButton presenter) flushPlayerListCache.  "catch guys not in cache but who're running"
	aPresenter stopRunningScriptsFrom: theButton! !


!StandardScriptingSystem methodsFor: '*eToys-tile colors' stamp: 'sw 8/28/2004 15:19'!
colorForType: typeSymbol
	"Answer the color to use to represent the given type symbol"

	true ifTrue:
		[^ self standardTileBorderColor].

	typeSymbol capitalized = #Command ifTrue:
		[^ Color fromRgbTriplet: #(0.065 0.258 1.0)].
	"Command is historical and idiosyncratic and should be regularized"

	^ (Vocabulary vocabularyForType: typeSymbol) typeColor! !

!StandardScriptingSystem methodsFor: '*eToys-tile colors' stamp: 'sw 10/29/1998 16:18'!
colorFudge
	^ 0.4! !

!StandardScriptingSystem methodsFor: '*eToys-tile colors' stamp: 'sw 8/28/2004 20:31'!
standardTileBorderColor
	"Answer the color to use for tile borders"

	^ Color r: 0.804 g: 0.76 b: 0.564! !


!StandardScriptingSystem methodsFor: '*eToys-universal slots & scripts' stamp: 'sw 1/4/2005 02:20'!
acceptableSlotNameFrom: originalString forSlotCurrentlyNamed: currentName asSlotNameIn: aPlayer world: aWorld
	"Produce an acceptable slot name, derived from the current name, for aPlayer.  This method will always return a valid slot name that will be suitable for use in the given situation, though you might not like its beauty sometimes."

	| aString stemAndSuffix proscribed stem suffix putative |
	aString _ originalString asIdentifier: false.  "get an identifier not lowercase"
	stemAndSuffix _ aString stemAndNumericSuffix.
	proscribed _ #(self super thisContext costume costumes dependents #true #false size), aPlayer class allInstVarNames.

	stem _ stemAndSuffix first.
	suffix _ stemAndSuffix last.
	putative _ aString asSymbol.
	
	[(putative ~~ currentName) and: [(proscribed includes: putative)
		or:	[(aPlayer respondsTo: putative)
		or:	[Smalltalk includesKey: putative]]]]
	whileTrue:
		[suffix _ suffix + 1.
		putative _ (stem, suffix printString) asSymbol].
	^ putative! !

!StandardScriptingSystem methodsFor: '*eToys-universal slots & scripts' stamp: 'kfr 9/23/2003 09:29'!
doesOperatorWantArrows: aSymbol
	aSymbol = #, ifTrue:[^ false].
	^ aSymbol isInfix or: [#(isDivisibleBy:) includes: aSymbol]! !

!StandardScriptingSystem methodsFor: '*eToys-universal slots & scripts' stamp: 'sw 9/27/2001 04:08'!
systemSlotNamesOfType: aType
	"Answer the type of the slot name, or nil if not found."
	
	| aList |
	self flag: #deferred.  "Hard-coded etoyVocabulary needed here to make this work."
	aList _ OrderedCollection new.
	Vocabulary eToyVocabulary methodInterfacesDo:
		 [:anInterface |
			anInterface resultType = aType ifTrue:
				[aList add: anInterface selector]].
	^ aList! !


!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 10/30/2000 16:37'!
allKnownClassVariableNames
	"Answer a set of all the knwon class variable names in the system.  This normally retrieves them from a cache, and at present there is no organized mechanism for invalidating the cache.  The idea is to avoid, in the References scheme, names that may create a conflict"

	^ ClassVarNamesInUse ifNil: [ClassVarNamesInUse _ self allClassVarNamesInSystem]

	"ClassVarNamesInUse _ nil.
	Time millisecondsToRun: [ScriptingSystem allKnownClassVariableNames]"
! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'kfr 9/23/2003 09:44'!
arithmeticalOperatorsAndHelpStrings
	"Answer an array consisting of lists of the standard arithmetical operator tiles and of the corresponding balloon help for them"

	^ #((+ - * / // \\ max: min:)
	 	('add' 'subtract' 'multiply' 'divide' 'divide & truncate' 'remainder when divided by' 'larger value' 'smaller value' ))! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'tk 10/20/2004 15:52'!
buttonDownTile
	"Answer a boolean-valued tile which reports whether the button is down"

	^ self systemQueryPhraseWithActionString: '(ActiveHand anyButtonPressed)' labelled: 'button down?' translated! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'tk 10/20/2004 15:52'!
buttonUpTile
	"Answer a boolean-valued tile which reports whether the button is up"

	^ self systemQueryPhraseWithActionString: '(ActiveHand noButtonPressed)' labelled: 'button up?' translated! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'tk 8/21/2000 12:59'!
cleanupsForRelease
	"Miscellaneous space cleanups to do before a release."
	"EToySystem cleanupsForRelease"

	Socket deadServer: ''.  "Don't reveal any specific server name"
	HandMorph initialize.  "free cached ColorChart"
	PaintBoxMorph initialize.	"forces Prototype to let go of extra things it might hold"
	Smalltalk removeKey: #AA ifAbsent: [].
	Smalltalk removeKey: #BB ifAbsent: [].
	Smalltalk removeKey: #CC ifAbsent: [].
	Smalltalk removeKey: #DD ifAbsent: [].
	Smalltalk removeKey: #Temp ifAbsent: [].

	ScriptingSystem reclaimSpace.
	Smalltalk cleanOutUndeclared.
	Smalltalk reclaimDependents.
	Smalltalk forgetDoIts.
	Smalltalk removeEmptyMessageCategories.
	Symbol rehash! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 3/10/2004 23:24'!
helpStringForOperator: anOperator
	"Answer the help string associated with the given operator. If none found, return a standard no-help-available reply"

	^ (self helpStringOrNilForOperator: anOperator) ifNil:
		['Sorry, no help available here' translated]  "This should never be seen, but is provided as a backstop"! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 6/27/2004 11:11'!
helpStringOrNilForOperator: anOperator
	"Answer the help string associated with the given operator, nil if none found."

	| anIndex opsAndHelp |
	(anIndex _ (opsAndHelp _ self arithmeticalOperatorsAndHelpStrings) first indexOf: anOperator) > 0
		ifTrue:	[^ (opsAndHelp second at: anIndex) translated].

	(anIndex _ (opsAndHelp _ self numericComparitorsAndHelpStrings) first indexOf: anOperator) > 0
		ifTrue:	[^ (opsAndHelp second at: anIndex) translated].

	anOperator = #, ifTrue:
		[^ 'Concatenate two Strings' translated].

	^ nil! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'nk 7/12/2003 08:59'!
holderWithAlphabet
	"Answer a fully instantiated Holder that has submorphs that represent the letters of the uppercase alphabet, with each one having an 'index' slot which bears the letter's index in the alphabet -- 1 for A, 2 for B, etc.   A few special characters are provided as per ack request 10/00; for these the index provided is rather arbitrarily assigned"

	| aMorph aPlayer newMorph oneCharString aContainer aWrapper |

	"ScriptingSystem holderWithAlphabet openInHand"

	aContainer _ self prototypicalHolder useRoundedCorners.
	aContainer borderColor: Color blue lighter.

	aWrapper _ AlignmentMorph new hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0.
	aWrapper addMorphBack: (aMorph _ TextMorph new contents: 'A').
	aMorph beAllFont: ((TextStyle named: Preferences standardEToysFont familyName) fontOfSize: 24).
	aMorph width: 14; lock.
	aWrapper beTransparent; setNameTo: 'A'.
	aPlayer _ aWrapper assuredPlayer.
	aPlayer addInstanceVariableNamed: #index type: #Number value: 1.
	aContainer addMorphBack: aWrapper.
	2 to: 26 do:
		[:anIndex |
			newMorph _ aWrapper usableSiblingInstance.
			newMorph player perform: #setIndex: with: anIndex.
			newMorph firstSubmorph contents: (oneCharString _ ($A asciiValue + anIndex - 1) asCharacter asString).
			newMorph setNameTo: oneCharString.

			aContainer addMorphBack: newMorph].

	#(' ' '.' '#') with: #(27 28 29) do:
		[:aString :anIndex |
			newMorph _ aWrapper usableSiblingInstance.
			newMorph player perform: #setIndex: with: anIndex.
			newMorph firstSubmorph contents: aString.
			aString = ' '
				ifTrue:
					[newMorph setNameTo: 'space'.
					newMorph color: (Color gray alpha: 0.2)]
				ifFalse:
					[newMorph setNameTo: aString].
			aContainer addMorphBack: newMorph].

	aContainer setNameTo: 'alphabet'.
	aContainer isPartsBin: true.
	aContainer enableDrop: false.
	aContainer indicateCursor: false; width: 162.
	aContainer color: (Color r: 0.839 g: 1.0 b: 1.0).  "Color fromUser"
	^ aContainer! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 9/15/2000 06:24'!
informScriptingUser: aString
	"This provides a hook for logging messages that the user or the developer may wish to see; at present it simply logs the message to the Transcript, with a standard prefix to signal their provenance.  Such messages will fall on the floor if there is no Transcript window open"

	Transcript cr; show: 'SCRIPT NOTE: ', aString! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 2/26/2003 22:44'!
nameForInstanceVariablesCategory
	"Answer the name to use for the viewer category that contains instance variables"

	^ #variables    
	"^ #'instance variables'"

"ScriptingSystem nameForInstanceVariablesCategory"! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 2/6/2003 18:00'!
nameForScriptsCategory
	"Answer the name to use for the viewer category that contains scripts"

	^ #scripts! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 2/18/2001 17:50'!
newScriptingSpace
	"Answer a complete scripting space - raa 19 sept 2000 - experiment for Alan, a variant *not* in a window, now adopted as the only true scripting space"

	^ self newScriptingSpace2! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 11/13/2001 14:41'!
newScriptingSpace2
	"Answer a complete scripting space"

	| aTemplate  aPlayfield aControl |
	
	(aTemplate _ PasteUpMorph new)
		setNameTo: 'etoy';
		extent: 638 @ 470;
		color: Color white;
		impartPrivatePresenter;
		setProperty: #automaticPhraseExpansion toValue: true;
		beSticky.
	aTemplate useRoundedCorners; borderWidth: 2. 
	aControl _  ScriptingSystem scriptControlButtons setToAdhereToEdge: #bottomLeft.
	aControl beSticky; borderWidth: 0; beTransparent.
	aTemplate addMorphBack: aControl.
	aTemplate presenter addTrashCan.

	aTemplate addMorph: (aPlayfield _ PasteUpMorph new).
	aPlayfield
		setNameTo: 'playfield';
		useRoundedCorners;
		setToAdhereToEdge: #topLeft;
		extent: 340@300;
		position: aTemplate topRight - (400@0);
		beSticky;
		automaticViewing: true;
		wantsMouseOverHalos: true.
	aTemplate presenter standardPlayfield: aPlayfield.
	
	^ aTemplate

! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 9/21/2000 22:39'!
numericComparitorsAndHelpStrings
	"Answer an array whose first element is the list of comparitors, and whose second element is a list of the corresponding help strings"

	^ #((< <= = ~= > >= isDivisibleBy:)
	 	('less than' 'less than or equal' 'equal' 'not equal' 'greater than' 'greater than or equal' 'divisible by' ))! !

!StandardScriptingSystem methodsFor: '*eToys-utilities'!
prepareForExternalReleaseNamed: aReleaseName
	"ScriptingSystem prepareForExternalReleaseNamed: '2.2Beta'"

	EToySystem stripMethodsForExternalRelease.

	ScriptingSystem saveFormsToFileNamed: aReleaseName, '.Dis.Forms'.
	ScriptingSystem stripGraphicsForExternalRelease.
	ScriptingSystem cleanupsForRelease.
	ScreenController initialize.
! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 5/2/1998 14:17'!
reclaimSpace
	"Reclaim space from the scripting system, and report the result in an informer"
	"ScriptingSystem reclaimSpace"

	| reclaimed |
	(reclaimed _ self spaceReclaimed)  > 0
		ifTrue:	[self inform: reclaimed printString, ' bytes reclaimed']
		ifFalse:	[self inform: 'Hmm...  Nothing gained this time.']! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 10/30/2000 09:08'!
referenceAt: aSymbol
	"Answer the object referred to by aSymbol in the 'References' scheme of things, or nil if none"

	^ References at: aSymbol ifAbsent: [nil]! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 10/30/2000 09:33'!
referenceAt: aSymbol put: anObject
	"Store a reference to anObject at the given symbol in the References directory"

	^ References at: aSymbol put: anObject! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 6/9/2000 18:44'!
reinvigorateThumbnailsInViewerFlapTabs
	"It has happened that the thumbnail in a viewer flap tab will go solid gray because it got associated with some passing and disused player temporarily created during the initial painting process.  This method takes a sledge hammer to repair such thumbnails.   At its genesis, this method is called only from the postscript of its defining fileout."
	| vwr thumbnail |
	ViewerFlapTab allInstancesDo:
		[:aTab | 
			vwr _ aTab referent findA: StandardViewer.
			thumbnail _ aTab findA: ThumbnailMorph.
			(vwr notNil and: [thumbnail notNil]) ifTrue:
				[thumbnail objectToView: vwr scriptedPlayer]]

	"ScriptingSystem reinvigorateThumbnailsInViewerFlapTabs"! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 12/20/2003 18:02'!
reportToUser: aString
	"Make a message accessible to the user.  For the moment, we simply defer to the Transcript mechanism"

	Transcript cr; show: aString! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 10/30/2000 16:47'!
resetAllScriptingReferences
	"Clear out all the elements in the References directory"
	
	Smalltalk at: #References put: IdentityDictionary new

	"ScriptingSystem resetAllScriptingReferences"! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 10/30/2000 16:45'!
resetStaleScriptingReferences
	"Remove all scripting references that are no longer needed"

	References  removeUnreferencedKeys

	"ScriptingSystem resetStaleScriptingReferences"
! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 7/25/2004 17:27'!
restoreClassicEToyLook
	"Restore classic EToy look, as closely as possible.  If ComicBold is present, restore it as the standard etoy and button font.  Substitute ComicSansMS and Accuny as respective alternatives if the classic fonts are absent.  If those also aren't available, do nothing."

	| aTextStyle aFont | 
	(aTextStyle _ TextStyle named: #ComicBold)
		ifNotNil:
			[aFont _ aTextStyle fontOfSize: 16.
			Preferences setEToysFontTo: aFont.
			Preferences setButtonFontTo: aFont]
		ifNil:
			[(aTextStyle _ TextStyle named: #ComicSansMS) ifNotNil:
				[Preferences setEToysFontTo: (aTextStyle fontOfSize: 18)].
			(aTextStyle _ TextStyle named: #Accuny) ifNotNil:
				[Preferences setButtonFontTo: (aTextStyle fontOfSize: 12)]].

	(aTextStyle _ TextStyle named: #NewYork)
		ifNotNil:
			[Preferences setSystemFontTo: (aTextStyle fontOfSize: 12)]! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 5/16/2001 12:58'!
setterSelectorForGetter: aGetterSymbol
	"Answer the setter selector corresponding to a given getter"

	^ (('s', (aGetterSymbol copyFrom: 2 to: aGetterSymbol size)), ':') asSymbol

	"ScriptingSystem setterSelectorForGetter: #getCursor"! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'di 3/3/2001 08:47'!
spaceReclaimed
	"Reclaim space from the EToy system, and return the number of bytes reclaimed"
	"ScriptingSystem spaceReclaimed"

	| oldFree  |
	oldFree _ Smalltalk garbageCollect.
	ThumbnailMorph recursionReset.
	Player removeUninstantiatedSubclassesSilently.
	Smalltalk cleanOutUndeclared.
	Smalltalk reclaimDependents.
	^ Smalltalk garbageCollect - oldFree.! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'sw 9/27/2001 13:28'!
tileForArgType: aType
	"Anwer a default tile to represent a datum of the given argument type, which may be either a symbol (e.g. #Color) or a class"

	(aType isKindOf: Class)  "Allowed in Ted's work"
		ifTrue:
			[^ aType name asString newTileMorphRepresentative typeColor: Color gray].

	^ (Vocabulary vocabularyForType: aType) defaultArgumentTile! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'dgd 7/12/2003 12:05'!
tryButtonFor: aPhraseTileMorph 
	| aButton |
	aButton := SimpleButtonMorph new.
	aButton target: aPhraseTileMorph;
		 actionSelector: #try;
		
		label: '!!'
		font: Preferences standardEToysFont;
		 color: Color yellow;
		 borderWidth: 0.
	aButton actWhen: #whilePressed.
	aButton balloonTextSelector: #try.
	^ aButton! !

!StandardScriptingSystem methodsFor: '*eToys-utilities' stamp: 'nk 10/14/2004 11:19'!
wordingForOperator: aString
	"Answer the wording to be seen by the user for the given operator symbol/string"

	| toTest |
	toTest _ aString asString.
	#(	(append:				'include at end')
		(arrowheadsOnAllPens	'arrowheads on all pens')
		(beep:					'make sound')
		(bounce:				'bounce')
		(clearTurtleTrails		'clear pen trails')
		(clearOwnersPenTrails	'clear all pen trails')
		(colorSees				'color  sees')
		(color:sees:				'color sees')
		(doMenuItem:			'do menu item')
		(doScript:				'do')
		(forward:				'forward by')
		(goToRightOf:			'align after')
		(includeAtCursor:		'include at cursor')
		(isDivisibleBy:			'is divisible by')
		(liftAllPens				'lift all pens')
		(lowerAllPens			'lower all pens')
		(makeNewDrawingIn:	'start painting in')
		(max:					'max')
		(min:					'min')
		(moveToward:			'move toward')
		(noArrowheadsOnAllPens	'no arrowheads on pens')
		(overlapsAny			'overlaps any')
		(pauseAll:				'pause all')
		(pauseScript:			'pause script')
		(prepend:				'include at beginning')
		(seesColor:				'is over color')
		(startAll:				'start all')
		(startScript:				'start script')
		(stopProgramatically	'stop')
		(stopAll:					'stop all')
		(stopScript:				'stop script')
		(tellAllSiblings:			'tell all siblings')
		(tellSelfAndAllSiblings:	'send to all')
		(turn:					'turn by')
		(turnToward:				'turn toward')
		(wearCostumeOf:		'look like'))

	do:
		[:pair | toTest = pair first ifTrue: [^ pair second]].

	^ toTest

	"StandardScriptingSystem initialize"

! !


!StandardScriptingSystem methodsFor: '*eToys-viewer' stamp: 'sw 10/30/2000 09:07'!
uniqueNameForReference
	"Answer a more-or-less global name by which the receiver can be referred to in scripts"

	^ #ScriptingSystem! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardScriptingSystem class
	instanceVariableNames: ''!

!StandardScriptingSystem class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 19:04'!
initialize
	"Initialize the scripting system.  Sometimes this method is vacuously changed just to get it in a changeset so that its invocation will occur as part of an update"

	(self environment at: #ScriptingSystem ifAbsent: [nil]) ifNil:
		[self environment at: #ScriptingSystem put: self new].

	ScriptingSystem
		initializeHelpStrings.

	self registerInFlapsRegistry.

"StandardScriptingSystem initialize"! !


!StandardScriptingSystem class methodsFor: 'utilities' stamp: 'nk 9/1/2004 10:53'!
applyNewEToyLook
	"Apply the new EToy look based on free fonts, approximating the classic look as closely as possible."

	"StandardScriptingSystem applyNewEToyLook"

"	| aTextStyle aFont | 
	aTextStyle _ TextStyle named: #BitstreamVeraSansMono.
	aFont _ aTextStyle fontOfSize: 12.
	aFont _ aFont emphasis: 1.
	Preferences setEToysFontTo: aFont.
	Preferences setButtonFontTo: aFont.

	aTextStyle _ TextStyle named: #Accushi.
	aFont _ aTextStyle fontOfSize: 12.
	Preferences setFlapsFontTo: aFont.

	(aTextStyle _ TextStyle named: #Accuny)
		ifNotNil:
			[Preferences setSystemFontTo: (aTextStyle fontOfSize: 12)]"

	Preferences setDefaultFonts: #(
		(setEToysFontTo:			BitstreamVeraSansBold	10)
		(setButtonFontTo:		BitstreamVeraSansMono	9)
		(setFlapsFontTo:			Accushi				12)
		(setSystemFontTo:		Accuny				10)
		(setWindowTitleFontTo:	BitstreamVeraSansBold	12)
	)
! !

!StandardScriptingSystem class methodsFor: 'utilities' stamp: 'mir 11/26/2004 16:14'!
removePlayersIn: project
	"Remove existing player references for project"

	References keys do: 
		[:key | (References at: key) costume pasteUpMorph == project world
			ifTrue: [References removeKey: key]].
! !

!StandardScriptingSystem class methodsFor: 'utilities' stamp: 'mir 11/25/2004 19:01'!
removeUnreferencedPlayers
	"Remove existing but unreferenced player references"
	"StandardScriptingSystem removeUnreferencedPlayers"
	References keys do: 
		[:key | (References at: key) costume pasteUpMorph
			ifNil: [References removeKey: key]].
! !


!StandardScriptingSystem class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 19:08'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(ScriptingSystem	prototypicalHolder	'Holder'		'A place for storing alternative pictures in an animation, etc.')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(ScriptingSystem	prototypicalHolder	'Holder'		'A place for storing alternative pictures in an animation, etc.')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(ScriptingSystem	newScriptingSpace	'Scripting'	'A confined place for drawing and scripting, with its own private stop/step/go buttons.')
						forFlapNamed: 'Widgets'.
						cl registerQuad: #(ScriptingSystem	holderWithAlphabet	'Alphabet'	'A source for single-letter objects')
						forFlapNamed: 'Widgets'.]! !

!StandardScriptingSystem class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/12/2003 14:38'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: ScriptingSystem] ! !



!StandardScriptingSystem class methodsFor: '*flexibleVocabularies-flexibleVocabularies' stamp: 'NS 4/8/2004 19:06'!
noteAddedSelector: aSelector meta: isMeta
	aSelector == #wordingForOperator: ifTrue:
		[Vocabulary changeMadeToViewerAdditions].
	super noteAddedSelector: aSelector meta: isMeta! !

!StandardScriptingSystem class methodsFor: '*flexibleVocabularies-flexibleVocabularies' stamp: 'NS 4/15/2004 12:41'!
noteCompilationOf: aSelector meta: isMeta
	"This method does nothing and should be removed."

	^ super noteCompilationOf: aSelector meta: isMeta! !
SourceFileArray subclass: #StandardSourceFileArray
	instanceVariableNames: 'files'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-System'!
!StandardSourceFileArray commentStamp: '<historical>' prior: 0!
This class implements the source file management behavior of traditional Squeak, with a sources file and a changes file. File positions are mapped such that those files can be up to 32MBytes in size.

Structure:
 files		Array -- storing the actual source files
!


!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'!
at: index
	^files at: index! !

!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'!
at: index put: aFile
	files at: index put: aFile! !

!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'!
size
	^files size! !


!StandardSourceFileArray methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:32'!
initialize
	files := Array new: 2.
	files at: 1 put: (SourceFiles at: 1).
	files at: 2 put: (SourceFiles at: 2)! !

!StandardSourceFileArray methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:32'!
initialize: nFiles
	files := Array new: nFiles! !


!StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'stephaneducasse 2/4/2006 20:32'!
fileIndexFromSourcePointer: anInteger
	"Return the index of the source file which contains the source chunk addressed by anInteger"
	"This implements the recent 32M source file algorithm"

	| hi |
	hi := anInteger // 16r1000000.
	^hi < 3
		ifTrue: [hi]
		ifFalse: [hi - 2]! !

!StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'stephaneducasse 2/4/2006 20:32'!
filePositionFromSourcePointer: anInteger
	"Return the position of the source chunk addressed by anInteger"
	"This implements the recent 32M source file algorithm"

	| hi lo |
	hi := anInteger // 16r1000000.
	lo := anInteger \\ 16r1000000.
	^hi < 3
		ifTrue: [lo]
		ifFalse: [lo + 16r1000000]! !

!StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'stephaneducasse 2/4/2006 20:32'!
sourcePointerFromFileIndex: index andPosition: position
	| hi lo |
	"Return a source pointer according to the new 32M algorithm"
	((index between: 1 and: 2) and: [position between: 0 and: 16r1FFFFFF])
		ifFalse: [self error: 'invalid source code pointer'].
	hi := index.
	lo := position.
	lo >= 16r1000000 ifTrue: [
		hi := hi+2.
		lo := lo - 16r1000000].
	^hi * 16r1000000 + lo! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardSourceFileArray class
	instanceVariableNames: ''!

!StandardSourceFileArray class methodsFor: 'initialize-release' stamp: 'nk 7/30/2004 21:50'!
install
	"Replace SourceFiles by an instance of me with the standard sources and changes files.
	This only works if SourceFiles is either an Array or an instance of this class"

	"StandardSourceFileArray install"

	SourceFiles := self new! !

!StandardSourceFileArray class methodsFor: 'initialize-release' stamp: 'ar 5/17/2000 18:27'!
new: nFiles
	^self new initialize: nFiles.! !
MouseMenuController subclass: #StandardSystemController
	instanceVariableNames: 'status'
	classVariableNames: 'HBorderCursor ScheduledBlueButtonMenu ScheduledBlueButtonMessages VBorderCursor'
	poolDictionaries: ''
	category: 'ST80-Support'!
!StandardSystemController commentStamp: '<historical>' prior: 0!
I am a controller for StandardSystemViews, that is, those views that are at the top level of a project in the system user interface. I am a kind of MouseMenuController that creates a blue button menu for moving, framing, collapsing, and closing ScheduledViews, and for selecting views under the view of my instance.!


!StandardSystemController methodsFor: 'basic control sequence' stamp: 'sw 10/20/1999 09:52'!
controlInitialize
	view displayEmphasized.
	view uncacheBits.  "Release cached bitmap while active"
	model windowActiveOnFirstClick ifFalse: [sensor waitNoButton].
	status _ #active.
	view isCollapsed ifFalse: [model modelWakeUpIn: view]! !

!StandardSystemController methodsFor: 'basic control sequence' stamp: 'di 5/11/1999 22:05'!
controlTerminate
	status == #closed
		ifTrue: 
			[view ~~ nil ifTrue: [view release].
			ScheduledControllers unschedule: self.
			^self].
	view deEmphasize; cacheBits.
	view isCollapsed ifFalse: [model modelSleep].! !


!StandardSystemController methodsFor: 'borders' stamp: 'ls 7/11/1998 07:45'!
adjustPaneBorders 
	| side sub newRect outerFrame |
	outerFrame _ view displayBox.
	side _ #none.
	VBorderCursor showWhile:
		[ [sub _ view subviewWithLongestSide: [:s | side _ s]
						near: sensor cursorPoint.
		  self cursorOnBorder and: [(side = #left) | (side = #right)]]
			whileTrue: [
				self interActivityPause.
				sensor redButtonPressed ifTrue:
				[side = #left ifTrue:
					[newRect _ sub stretchFrame:
						[:f | (f withLeft: sensor cursorPoint x)
								intersect: outerFrame]
						startingWith: sub displayBox].
				side = #right ifTrue:
					[newRect _ sub stretchFrame:
						[:f | (f withRight: sensor cursorPoint x)
								intersect: outerFrame]
						startingWith: sub displayBox].
				view reframePanesAdjoining: sub along: side to: newRect]]].
	HBorderCursor showWhile:
		[ [sub _ view subviewWithLongestSide: [:s | side _ s]
						near: sensor cursorPoint.
		  self cursorOnBorder and: [(side = #top) | (side = #bottom)]]
			whileTrue: [
				self interActivityPause.
				sensor redButtonPressed ifTrue:
				[side = #top ifTrue:
					[newRect _ sub stretchFrame:
						[:f | (f withTop: sensor cursorPoint y)
								intersect: outerFrame]
						startingWith: sub displayBox].
				side = #bottom ifTrue:
					[newRect _ sub stretchFrame:
						[:f | (f withBottom: sensor cursorPoint y)
								intersect: outerFrame]
						startingWith: sub displayBox].
				view reframePanesAdjoining: sub along: side to: newRect]]]! !

!StandardSystemController methodsFor: 'borders' stamp: 'di 11/16/2001 22:22'!
adjustWindowBorders 
	| side noClickYet |
	noClickYet _ true.
	VBorderCursor showWhile:
		[ [side _ view displayBox sideNearestTo: sensor cursorPoint.
		  self cursorOnBorder
			and: [(side = #left) | (side = #right)
			and: [noClickYet or: [sensor redButtonPressed]]]]
			whileTrue:
			[sensor redButtonPressed ifTrue:
				[noClickYet _ false.
				side = #left ifTrue:
					[view newFrame: [:f | f withLeft: sensor cursorPoint x]].
				side = #right ifTrue:
					[view newFrame: [:f | f withRight: sensor cursorPoint x]]].
			self interActivityPause]].
	HBorderCursor showWhile:
		[ [side _ view displayBox sideNearestTo: sensor cursorPoint.
		  self cursorOnBorder
			and: [(side = #top) | (side = #bottom)
			and: [noClickYet or: [sensor redButtonPressed]]]]
			whileTrue:
			[sensor redButtonPressed ifTrue:
				[noClickYet _ false.
				side = #top ifTrue:
					[view newFrame: [:f | f withTop: sensor cursorPoint y]].
				side = #bottom ifTrue:
					[view newFrame: [:f | f withBottom: sensor cursorPoint y]]].
		  self interActivityPause]]! !

!StandardSystemController methodsFor: 'borders' stamp: 'ls 7/11/1998 07:38'!
adjustWindowCorners 
	| box cornerBox p clicked f2 |
	box _ view windowBox.
	clicked _ false.
	#(topLeft topRight bottomRight bottomLeft)
		do: [:readCorner |
			cornerBox _ ((box insetBy: 2) perform: readCorner) - (10@10) extent: 20@20.
			(cornerBox containsPoint: sensor cursorPoint)
				ifTrue: 
				["Display reverse: cornerBox."
				(Cursor perform: readCorner) showWhile:
					[[(cornerBox containsPoint: (p _ sensor cursorPoint))
						and: [(clicked _ sensor anyButtonPressed) not]]
						whileTrue: [ self interActivityPause ].
				"Display reverse: cornerBox."
				clicked ifTrue:
					[view newFrame:
						[:f | p _ sensor cursorPoint.
						readCorner = #topLeft ifTrue:
							[f2 _ p corner: f bottomRight].
						readCorner = #bottomLeft ifTrue:
							[f2 _ (f withBottom: p y) withLeft: p x].
						readCorner = #bottomRight ifTrue:
							[f2 _ f topLeft corner: p].
						readCorner = #topRight ifTrue:
							[f2 _ (f withTop: p y) withRight: p x].
						f2]]]]].
	^ clicked! !

!StandardSystemController methodsFor: 'borders' stamp: 'di 11/16/2001 22:30'!
checkForReframe
	| cp |
	view isCollapsed ifTrue: [^ self].
	cp _ sensor cursorPoint.
	((view closeBoxFrame expandBy: 2) containsPoint: cp)
		| ((view growBoxFrame expandBy: 2) containsPoint: cp)
		ifTrue: [^ self].  "Dont let reframe interfere with close/grow"
	self adjustWindowCorners.
	self cursorOnBorder ifFalse: [^ self].
	((view insetDisplayBox insetBy: 2@2) containsPoint: cp)
		ifFalse: [^ self adjustWindowBorders].
	view subViews size <= 1 ifTrue: [^ self].
	(view subviewWithLongestSide: [:s | ] near: cp) == nil
		ifFalse: [^ self adjustPaneBorders].! !

!StandardSystemController methodsFor: 'borders'!
cursorOnBorder 
	| cp i box |
	view isCollapsed ifTrue: [^ false].
	cp _ sensor cursorPoint.
	((view labelDisplayBox insetBy: (0@2 corner: 0@-2)) containsPoint: cp)
		ifTrue: [^ false].
	(i _ view subViews findFirst: [:v | v displayBox containsPoint: cp]) = 0
		ifTrue: [box _ view windowBox]
		ifFalse: [box _ (view subViews at: i) insetDisplayBox].
	^ ((box insetBy: 3) containsPoint: cp) not
		and: [(box expandBy: 4) containsPoint: cp]! !

!StandardSystemController methodsFor: 'borders'!
fullScreen
	"Make the receiver's window occupy jes' about the full screen.  6/10/96 sw"

	view fullScreen! !


!StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:01'!
blueButtonActivity
	ScheduledBlueButtonMenu ifNil: [^ super controlActivity].
	ScheduledBlueButtonMenu invokeOn: self! !

!StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:20'!
controlActivity
	self checkForReframe.
	^ super controlActivity! !

!StandardSystemController methodsFor: 'control defaults'!
isControlActive
	status == #active ifFalse: [^ false].
	sensor anyButtonPressed ifFalse: [^ true].
	self viewHasCursor
		ifTrue: [^ true]
		ifFalse: [ScheduledControllers noteNewTop.
				^ false]! !

!StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/15/2000 22:19'!
redButtonActivity
	"If cursor is in label of a window when red button is pushed,
	check for closeBox or growBox, else drag the window frame
	or edit the label."

	| box p |
	p _ sensor cursorPoint.
	self labelHasCursor ifFalse: [super redButtonActivity. ^ self].
	((box _ view closeBoxFrame) containsPoint: p)
		ifTrue:
			[Utilities
				awaitMouseUpIn: box
				repeating: []
				ifSucceed: [self close. ^ self].
			^ self].
	((box _ view growBoxFrame) containsPoint: p)
		ifTrue:
			[Utilities
				awaitMouseUpIn: box
				repeating: []
				ifSucceed:
					[Sensor controlKeyPressed ifTrue: [^ self expand; fullScreen].
					^ view isCollapsed
						ifTrue: [self expand]
						ifFalse: [self collapse]].
			^ self].
	(((box _ view labelTextRegion expandBy: 1) containsPoint: p)
			and: [Preferences clickOnLabelToEdit or: [sensor leftShiftDown]])
		ifTrue:
			[Utilities
				awaitMouseUpIn: box
				repeating: []
				ifSucceed: [^ self label].
			^ self].
	self move! !


!StandardSystemController methodsFor: 'cursor'!
labelHasCursor
	"Answer true if the cursor is within the window's label"
	^view labelContainsPoint: sensor cursorPoint! !


!StandardSystemController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 11:48'!
initialize
	super initialize.
	status _ #inactive! !


!StandardSystemController methodsFor: 'menu messages'!
chooseColor
	"Allow the user to specify a new background color for the receiver's window.  5/6/96 sw.
	 7/31/96 sw: use Color fromUser"

	view backgroundColor: Color fromUser; uncacheBits; display! !

!StandardSystemController methodsFor: 'menu messages'!
close
	"The receiver's view should be removed from the screen and from the 
	collection of scheduled views."

	model okToChange ifFalse: [^self].
	status _ #closed.
	view erase! !

!StandardSystemController methodsFor: 'menu messages'!
collapse
	"Get the receiver's view to change to a collapsed view on the screen."
	view collapseToPoint: view chooseCollapsePoint! !

!StandardSystemController methodsFor: 'menu messages'!
expand
	"The receiver's view was collapsed; open it again and ask the user to 
	designate its rectangular area."
	view expand; emphasize! !

!StandardSystemController methodsFor: 'menu messages' stamp: 'rbb 3/1/2005 11:14'!
label

	| newLabel |
	newLabel := UIManager default
		request: 'Edit the label, then type RETURN'
		initialAnswer: view label.
	newLabel isEmpty ifFalse: [view relabel: newLabel].
! !

!StandardSystemController methodsFor: 'menu messages'!
move
	"Ask the user to designate a new origin position for the receiver's view.
	6/10/96 sw: tell the view that it has moved"

	| oldBox | 
	oldBox _ view windowBox.
	view uncacheBits.
	view align: view windowBox topLeft
		with: view chooseMoveRectangle topLeft.
	view displayEmphasized.
	view moved.  "In case its model wishes to take note."
	(oldBox areasOutside: view windowBox) do:
		[:rect | ScheduledControllers restore: rect]! !

!StandardSystemController methodsFor: 'menu messages'!
reframe
	^ view reframeTo: view getFrame! !

!StandardSystemController methodsFor: 'menu messages'!
toggleTwoTone
	(view isMemberOf: StandardSystemView) ifTrue:
		[^ view become: (view as: ColorSystemView)].
	(view isMemberOf: ColorSystemView) ifTrue:
		[^ view become: (view as: StandardSystemView)].
! !

!StandardSystemController methodsFor: 'menu messages'!
under
	"Deactive the receiver's scheduled view and pass control to any view that 
	might be positioned directly underneath it and the cursor."

	status _ #inactive! !


!StandardSystemController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 15:12'!
getPluggableYellowButtonMenu: shiftKeyState
	^ nil! !


!StandardSystemController methodsFor: 'scheduling' stamp: 'sw 9/30/97 22:04'!
closeAndUnschedule
	"Erase the receiver's view and remove it from the collection of scheduled 
	views."

	status _ #closed.
	view erase.
	view release.
	ScheduledControllers unschedule: self; searchForActiveController
! !

!StandardSystemController methodsFor: 'scheduling'!
closeAndUnscheduleNoErase
	"Remove the scheduled view from the collection of scheduled views. Set 
	its status to closed but do not erase."

	status _ #closed.
	view release.
	ScheduledControllers unschedule: self! !

!StandardSystemController methodsFor: 'scheduling' stamp: 'jm 3/18/98 19:21'!
closeAndUnscheduleNoTerminate
	"Erase the receiver's view and remove it from the collection of scheduled views, but do not terminate the current process."

	status _ #closed.
	view erase.
	view release.
	ScheduledControllers unschedule: self.
! !

!StandardSystemController methodsFor: 'scheduling'!
open
	"Create an area on the screen in which the receiver's scheduled view can 
	be displayed. Make it the active view."

	view resizeInitially.
	status _ #open.
	ScheduledControllers scheduleActive: self! !

!StandardSystemController methodsFor: 'scheduling'!
openDisplayAt: aPoint 
	"Create an area with origin aPoint in which the receiver's scheduled 
	view can be displayed. Make it the active view."

	view align: view viewport center with: aPoint.
	view translateBy:
		(view displayBox amountToTranslateWithin: Display boundingBox).
	status _ #open.
	ScheduledControllers scheduleActive: self! !

!StandardSystemController methodsFor: 'scheduling' stamp: 'jm 10/22/97 08:16'!
openNoTerminate
	"Create an area in which the receiver's scheduled view can be displayed. 
	Make it the active view. Do not terminate the currently active process."

	view resizeInitially.
	status _ #open.
	ScheduledControllers scheduleActiveNoTerminate: self! !

!StandardSystemController methodsFor: 'scheduling'!
openNoTerminateDisplayAt: aPoint 
	"Create an area with origin aPoint in which the receiver's scheduled 
	view can be displayed. Make it the active view. Do not terminate the 
	currently active process."

	view resizeMinimumCenteredAt: aPoint.
	status _ #open.
	ScheduledControllers scheduleActiveNoTerminate: self! !

!StandardSystemController methodsFor: 'scheduling'!
status: aSymbol
	status _ aSymbol! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardSystemController class
	instanceVariableNames: ''!

!StandardSystemController class methodsFor: 'class initialization' stamp: 'sma 3/11/2000 11:57'!
initialize
	"StandardSystemController initialize"

	ScheduledBlueButtonMenu _ SelectionMenu
		labels:
'edit label
choose color...
two-tone/full color
move
frame
full screen
collapse
close'
	lines: #(3 7)
	selections: #(label chooseColor toggleTwoTone move reframe fullScreen collapse close).

	VBorderCursor _ Cursor extent: 16@16 fromArray: #(
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010010000100000
		2r1010110000110000
		2r1011111111111000
		2r1010110000110000
		2r1010010000100000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000)
			offset: 0@0.
	HBorderCursor _ Cursor extent: 16@16 fromArray: #(
		2r1111111111111111
		2r0000000000000000
		2r1111111111111111
		2r0000000100000000
		2r0000001110000000
		2r0000011111000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000011111000000
		2r0000001110000000
		2r0000000100000000
		2r0000000000000000
		2r0000000000000000
		2r0000000000000000)
			offset: 0@0.! !
TestCase subclass: #StandardSystemFontsTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support-Tests'!

!StandardSystemFontsTest methodsFor: 'testing' stamp: 'bp 11/6/2004 23:15'!
testRestoreDefaultFonts

	self saveStandardSystemFontsDuring: [
		Preferences restoreDefaultFonts.
		self assert: #standardDefaultTextFont familyName: 'Accuny' pointSize: 10.
		self assert: #standardListFont familyName: 'Accuny' pointSize: 10.
		self assert: #standardFlapFont familyName: 'Accushi' pointSize: 12.
		self assert: #standardEToysFont familyName: 'BitstreamVeraSans' pointSize: 9.
		self assert: #standardMenuFont familyName: 'Accuny' pointSize: 10.
		self assert: #windowTitleFont familyName: 'BitstreamVeraSans' pointSize: 12.
		self assert: #standardBalloonHelpFont familyName: 'Accujen' pointSize: 9.
		self assert: #standardCodeFont familyName: 'Accuny' pointSize: 10.
		self assert: #standardButtonFont familyName: 'BitstreamVeraSansMono' pointSize: 9]! !


!StandardSystemFontsTest methodsFor: 'utilities' stamp: 'bp 6/13/2004 18:22'!
assert: selector familyName: aString pointSize: anInteger

	| font |
	font _ Preferences perform: selector.
	self assert: font familyName = aString.
	self assert: font pointSize = anInteger
	! !

!StandardSystemFontsTest methodsFor: 'utilities' stamp: 'bp 6/13/2004 21:51'!
saveStandardSystemFontsDuring: aBlock

	| standardDefaultTextFont standardListFont standardEToysFont standardMenuFont 
	windowTitleFont standardBalloonHelpFont standardCodeFont standardButtonFont |

	standardDefaultTextFont _ Preferences standardDefaultTextFont.
	standardListFont _ Preferences standardListFont.
	standardEToysFont _ Preferences standardEToysFont.
	standardMenuFont _ Preferences standardMenuFont.
	windowTitleFont _ Preferences windowTitleFont.
	standardBalloonHelpFont _ Preferences standardBalloonHelpFont.
	standardCodeFont _ Preferences standardCodeFont.
	standardButtonFont _ Preferences standardButtonFont.
	[aBlock value] ensure: [
		Preferences setSystemFontTo: standardDefaultTextFont.
		Preferences setListFontTo: standardListFont.
		Preferences setEToysFontTo: standardEToysFont.
		Preferences setMenuFontTo: standardMenuFont.
		Preferences setWindowTitleFontTo: windowTitleFont.
		Preferences setBalloonHelpFontTo: standardBalloonHelpFont.
		Preferences setCodeFontTo: standardCodeFont.
		Preferences setButtonFontTo: standardButtonFont].
! !
View subclass: #StandardSystemView
	instanceVariableNames: 'labelFrame labelText isLabelComplemented savedSubViews minimumSize maximumSize collapsedViewport expandedViewport labelBits windowBits bitsValid updatablePanes'
	classVariableNames: 'CacheBits LabelStyle'
	poolDictionaries: ''
	category: 'ST80-Support'!
!StandardSystemView commentStamp: '<historical>' prior: 0!
I represent a view that has a label above its top left corner. The text in the label identifies the kind of view. In addition to a label, I add control over the maximum and minimum size of the display box of my instance. My default controller is StandardSystemController. The elements of ScheduledControllers, the sole instance of ControlManager, are usually controllers for instances of me.!


!StandardSystemView methodsFor: 'clipping box access'!
clippingBox
	"Answer the rectangular area in which the receiver can show its label."

	^self isTopView
		ifTrue: [self labelDisplayBox]
		ifFalse: [super insetDisplayBox]! !

!StandardSystemView methodsFor: 'clipping box access' stamp: 'BG 12/5/2003 11:13'!
constrainFrame: aRectangle
	"Constrain aRectangle, to the minimum and maximum size
	for this window"

   | adjustmentForLabel |
   adjustmentForLabel := 0 @ (labelFrame height  - labelFrame borderWidth).
	^ aRectangle origin extent:
		((aRectangle extent max: minimumSize + adjustmentForLabel)
		      min: maximumSize + adjustmentForLabel).! !


!StandardSystemView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^StandardSystemController! !


!StandardSystemView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."

	isLabelComplemented ifTrue:
		[self deEmphasizeLabel.
		isLabelComplemented _ false]! !

!StandardSystemView methodsFor: 'deEmphasizing'!
emphasizeView 
	"Refer to the comment in View|emphasizeView."

	self emphasizeLabel! !


!StandardSystemView methodsFor: 'displaying'!
cacheBits
	| oldLabelState |
	CacheBits ifFalse: [^ self uncacheBits].
	(oldLabelState _ isLabelComplemented) ifTrue: [ self deEmphasize ].
	self cacheBitsAsIs.
	(isLabelComplemented _ oldLabelState) ifTrue: [ self emphasize ].
! !

!StandardSystemView methodsFor: 'displaying'!
cacheBitsAsIs
	CacheBits ifFalse: [^ self uncacheBits].
	windowBits _ (self cacheBitsAsTwoTone and: [Display depth > 1])
		ifTrue: [ColorForm
					twoToneFromDisplay: self windowBox
					using: windowBits
					backgroundColor: self backgroundColor]
		ifFalse: [Form fromDisplay: self windowBox using: windowBits].
	bitsValid _ true.
! !

!StandardSystemView methodsFor: 'displaying'!
cacheBitsAsTwoTone
	^ true! !

!StandardSystemView methodsFor: 'displaying'!
deEmphasizeForDebugger
	"Carefully de-emphasis this window because a debugger is being opened. Care must be taken to avoid invoking potentially buggy window display code that could cause a recursive chain of errors eventually resulting in a virtual machine crash. In particular, do not de-emphasize the subviews."

	self deEmphasizeView.  "de-emphasize this top-level view"
	self uncacheBits.
	Smalltalk garbageCollectMost > 1000000 ifTrue: [
		"if there is enough space, cache current window screen bits"
		self cacheBitsAsIs].
! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 10/3/97 13:18'!
deEmphasizeLabel
	"Un-Highlight the label."
	labelFrame height = 0 ifTrue: [^ self].  "no label"
	self displayLabelBackground: false.
	self displayLabelText.! !

!StandardSystemView methodsFor: 'displaying'!
display
	isLabelComplemented
		ifTrue: [self displayEmphasized]
		ifFalse: [self displayDeEmphasized]! !

!StandardSystemView methodsFor: 'displaying' stamp: 'hmm 7/21/1999 07:37'!
displayDeEmphasized 
	"Display this view with emphasis off.
	If windowBits is not nil, then simply BLT if possible,
		but force full display for top window so color is preserved."
	(bitsValid and: [controller ~~ ScheduledControllers activeController])
		ifTrue: [self lock.
				windowBits displayAt: self windowOrigin]
		ifFalse: [Display deferUpdates: true.
				super display.
				Display deferUpdates: false; forceToScreen: self windowBox.
				CacheBits ifTrue: [self cacheBitsAsIs]]
! !

!StandardSystemView methodsFor: 'displaying'!
displayEmphasized
	"Display with label highlighted to indicate that it is active."

	self displayDeEmphasized; emphasize.
	isLabelComplemented _ true! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 5/15/1998 21:55'!
displayLabelBackground: emphasized
	"Clear or emphasize the inner region of the label"
	| r1 r2 r3 c3 c2 c1 |
	emphasized ifFalse:
		["Just clear the label if not emphasized"
		^ Display fill: (self labelDisplayBox insetBy: 2) fillColor: self labelColor].
	r1 _ self labelDisplayBox insetBy: 2.
	r2 _ r1 insetBy: 0@2.
	r3 _ r2 insetBy: 0@3.
	c3 _ self labelColor.
	c2 _ c3 dansDarker.
	c1 _ c2 dansDarker.
	Display fill: r1 fillColor: c1.
	Display fill: r2 fillColor: c2.
	Display fill: r3 fillColor: c3.
 
"	Here is the Mac racing stripe code
	stripes _ Bitmap with: (self labelColor pixelWordForDepth: Display depth)
					with: (Form black pixelWordForDepth: Display depth).
	self windowOrigin y even ifTrue: [stripes swap: 1 with: 2].
	Display fill: (self labelDisplayBox insetBy: 3) fillColor: stripes.
"! !

!StandardSystemView methodsFor: 'displaying'!
displayLabelBoxes
	"closeBox, growBox."
	| aRect smallRect backColor |
	aRect _ self closeBoxFrame.
	backColor _ self labelColor.
	Display fill: (aRect insetBy: -2) fillColor: backColor.
	Display fillBlack: aRect.
	Display fill: (aRect insetBy: 1) fillColor: backColor.

	aRect _ self growBoxFrame.
	smallRect _ aRect origin extent: 7@7.
	Display fill: (aRect insetBy: -2) fillColor: backColor.
	aRect _ aRect insetOriginBy: 2@2 cornerBy: 0@0.
	Display fillBlack: aRect.
	Display fill: (aRect insetBy: 1) fillColor: backColor.
	Display fillBlack: smallRect.
	Display fill: (smallRect insetBy: 1) fillColor: backColor! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 9/10/1998 09:43'!
displayLabelText
	"The label goes in the center of the window"
	| labelRect |
	labelText foregroundColor: self foregroundColor
			backgroundColor: self labelColor.
	labelRect _ self labelTextRegion.
	Display fill: (labelRect expandBy: 3@0) fillColor: self labelColor.
	labelText displayOn: Display at: labelRect topLeft clippingBox: labelRect
			rule: labelText rule fillColor: labelText fillColor.
	labelText destinationForm: nil! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 8/29/97 18:57'!
displayOn: aPort
	bitsValid ifFalse:
		[^ Display clippingTo: aPort clipRect do: [super display]].
	windowBits displayOnPort: aPort at: self windowOrigin! !

!StandardSystemView methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:40'!
displayRacingStripes
	"Display Racing Stripes in the label"
	| labelDisplayBox stripes top bottom left box right |
	labelDisplayBox _ self labelDisplayBox.
	top _ labelDisplayBox top + 3.
	bottom _ labelDisplayBox bottom - 3.
	stripes _ Bitmap with: (Display pixelWordFor: self labelColor)
			with: (Display pixelWordFor: Color black).
	top even ifFalse: [stripes swap: 1 with: 2].

	left _ labelDisplayBox left + 3.

	box _ self closeBoxFrame.
	right _ box left - 2.
	Display fill: (Rectangle left: left right: right top: top bottom: bottom)
			fillColor: stripes.
	left _ box right + 2.

	box _ self labelTextRegion.
	right _ box left - 3.
	Display fill: (Rectangle left: left right: right top: top bottom: bottom)
			fillColor: stripes.
	left _ box right + 2.

	box _ self growBoxFrame.
	right _ box left - 2.
	Display fill: (Rectangle left: left right: right top: top bottom: bottom)
			fillColor: stripes.
	left _ box right + 2.

	right _ labelDisplayBox right - 3.
	Display fill: (Rectangle left: left right: right top: top bottom: bottom)
			fillColor: stripes.
! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 10/3/97 13:14'!
displayView
	"Refer to the comment in View|displayView. "
	labelFrame height = 0 ifTrue: [^ self].  "no label"
	self displayBox width = labelFrame width ifFalse:
		["recompute label width when window changes size"
		self setLabelRegion].
	(labelFrame align: labelFrame topLeft with: self windowOrigin)
		insideColor: self labelColor;
		displayOn: Display.
	self displayLabelText! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 10/3/97 13:18'!
emphasizeLabel
	"Highlight the label."
	labelFrame height = 0 ifTrue: [^ self].  "no label"
	self displayLabelBackground: true.
	self displayLabelBoxes.
	self displayLabelText.! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 8/30/97 11:07'!
erase
	"Clear the display box of the receiver to be gray, as the screen background."
	| oldValid |
	CacheBits
		ifTrue:
			[oldValid _ bitsValid.
			bitsValid _ false.
			ScheduledControllers restore: self windowBox without: self.
			bitsValid _ oldValid]
		ifFalse:
			[ScheduledControllers restore: self windowBox without: self]! !

!StandardSystemView methodsFor: 'displaying' stamp: 'RAA 6/14/2000 17:27'!
makeMeVisible

        | newLoc portRect |
        ((Display boundingBox insetBy: (0@0 corner: self labelHeight asPoint))
                containsPoint: self displayBox topLeft) ifTrue: [^ self "OK -- my top left is visible"].

        "window not on screen (probably due to reframe) -- move it now"
        newLoc _ self isCollapsed
                ifTrue: [RealEstateAgent assignCollapsePointFor: self]
                ifFalse: [(RealEstateAgent initialFrameFor: self world: nil) topLeft].
        portRect _ newLoc + self labelOffset
                                extent: self windowBox extent - self labelOffset.
        self resizeTo: portRect.
        self setLabelRegion.
! !

!StandardSystemView methodsFor: 'displaying'!
uncacheBits
	windowBits _ nil.
	bitsValid _ false.! !

!StandardSystemView methodsFor: 'displaying'!
windowBits
	^ windowBits! !


!StandardSystemView methodsFor: 'framing' stamp: 'sr 3/26/2000 03:47'!
chooseCollapsePoint
	"Answer the point at which to place the collapsed window."
	| pt labelForm beenDown offset |
	labelForm _ Form fromDisplay: self labelDisplayBox.
	self uncacheBits.
	self erase.
	beenDown _ Sensor anyButtonPressed.
	self isCollapsed ifTrue:
		[offset _ self labelDisplayBox topLeft - self growBoxFrame topLeft.
		labelForm follow: [pt _ (Sensor cursorPoint + offset max: 0@0) truncateTo: 8]
				while: [Sensor anyButtonPressed
							ifTrue: [beenDown _ true]
							ifFalse: [beenDown not]].
		^ pt].
	^ (RealEstateAgent assignCollapseFrameFor: self) origin.
! !

!StandardSystemView methodsFor: 'framing'!
chooseFrame
	"Answer a new frame, depending on whether the view is currently 
	collapsed or not."
	| labelForm f |
	self isCollapsed & expandedViewport notNil
		ifTrue:
			[labelForm _ bitsValid
				ifTrue: [windowBits]
				ifFalse: [Form fromDisplay: self labelDisplayBox].
			bitsValid _ false.
			self erase.
			labelForm slideFrom: self labelDisplayBox origin
					to: expandedViewport origin-self labelOffset
					nSteps: 10.
			^ expandedViewport]
		ifFalse:
			[f _ self getFrame.
			bitsValid _ false.
			self erase.
			^ f topLeft + self labelOffset extent: f extent]! !

!StandardSystemView methodsFor: 'framing'!
chooseMoveRectangle
	"Ask the user to designate a new window rectangle."
	| offset p |
	offset _ Sensor anyButtonPressed "Offset if draggin, eg, label"
		ifTrue: [self windowBox topLeft - Sensor cursorPoint]
		ifFalse: [0@0].
	self isCollapsed
		ifTrue: [^ self labelDisplayBox newRectFrom:
					[:f | p _ Sensor cursorPoint + offset.
					p _ (p max: 0@0) truncateTo: 8.
					p extent: f extent]]
		ifFalse: [^ self windowBox newRectFrom:
					[:f | p _ Sensor cursorPoint + offset.
					self constrainFrame: (p extent: f extent)]]! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 5/11/1999 22:09'!
collapse
	"If the receiver is not already collapsed, change its view to be that of its 
	label only."

	self isCollapsed ifFalse:
			[model modelSleep.
			(subViews ~~ nil and: [subViews size = 1 and: [subViews first isKindOf: MorphWorldView]])
				ifTrue: [subViews first deEmphasizeView].
			expandedViewport _ self viewport.
			savedSubViews _ subViews.
			self resetSubViews.
			labelText isNil ifTrue: [self label: nil.  bitsValid _ false.].
			self window: (self inverseDisplayTransform:
					((self labelDisplayBox topLeft extent: (labelText extent x + 70) @ self labelHeight)
						 intersect: self labelDisplayBox))]! !

!StandardSystemView methodsFor: 'framing'!
collapseToPoint: collapsePoint
	self collapse.
	self align: self displayBox topLeft with: collapsePoint.
	collapsedViewport _ self viewport.
	self displayEmphasized! !

!StandardSystemView methodsFor: 'framing'!
collapsedFrame
	"Answer the rectangle occupied by this window when collapsed."
	^ collapsedViewport  "NOTE may be nil"! !

!StandardSystemView methodsFor: 'framing' stamp: 'sw 10/20/1999 09:46'!
expand
	"If the receiver is collapsed, change its view to be that of all of its subviews, not its label alone."
	| newFrame |
	self isCollapsed
		ifTrue:
			[newFrame _ self chooseFrame expandBy: borderWidth.
			collapsedViewport _ self viewport.
			subViews _ savedSubViews.
			labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
			savedSubViews _ nil.
			self setWindow: nil.
			self resizeTo: newFrame.
			self displayDeEmphasized.
			model modelWakeUpIn: self]! !

!StandardSystemView methodsFor: 'framing'!
expandedFrame
	"Answer the rectangle occupied by this window when expanded."
	^ expandedViewport  "NOTE may be nil"! !

!StandardSystemView methodsFor: 'framing' stamp: 'sw 8/15/97 17:18'!
fullScreen
	"Expand the receiver to fill the screen.  Let the model decide how big is full -- allows for flop-out scrollbar on left if desired"

	self isCollapsed ifFalse:
		[self reframeTo: model fullScreenSize]! !

!StandardSystemView methodsFor: 'framing'!
getFrame
	"Ask the user to designate a rectangular area in which
	the receiver should be displayed."
	| minFrame |
	minFrame _ Cursor origin showWhile: 
		[(Sensor cursorPoint extent: self minimumSize) newRectFrom:
			[:f | Sensor cursorPoint extent: self minimumSize]].
	self maximumSize <= self minimumSize ifTrue: [^ minFrame].
	^ Cursor corner showWhile:
		[minFrame newRectFrom:
			[:f | self constrainFrame: (f origin corner: Sensor cursorPoint)]]! !

!StandardSystemView methodsFor: 'framing' stamp: 'sw 1/22/96'!
initialExtent
	"Answer the desired extent for the receiver when it is first opened on the screen.  "

	^ model initialExtent min: maximumSize max: minimumSize! !

!StandardSystemView methodsFor: 'framing' stamp: 'RAA 6/14/2000 17:27'!
initialFrame
        "Find a plausible initial screen area for the receiver, taking into account user preference, the size needed, and other windows currently on the screen.  5/22/96 sw: let RealEstateAgent do it for us"

        ^ RealEstateAgent initialFrameFor: self world: nil! !

!StandardSystemView methodsFor: 'framing'!
moved
	"The user has moved the receiver; after a new view rectangle is chosen, this method is called to allow certain views to take note of the change.  6/10/96 sw" ! !

!StandardSystemView methodsFor: 'framing'!
newFrame: frameChangeBlock
	self reframeTo: (self windowBox newRectFrom:
		[:f | self constrainFrame: (frameChangeBlock value: f)])! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 10/22/1998 16:15'!
reframePanesAdjoining: subView along: side to: aDisplayBox 
	| newBox delta newRect minDim theMin |
	newRect _ aDisplayBox.
	theMin _ 16.
	"First check that this won't make any pane smaller than theMin screen dots"
	minDim _ ((subViews select: [:sub | sub displayBox bordersOn: subView displayBox along: side])
		collect: [:sub | sub displayBox adjustTo: newRect along: side])
			inject: 999 into: [:was :rect | (was min: rect width) min: rect height].
	"If so, amend newRect as required"
	minDim < theMin ifTrue:
		[delta _ minDim - theMin.
		newRect _ newRect withSide: side setTo: 
				((newRect perform: side) > (subView displayBox perform: side)
					ifTrue: [(newRect perform: side) + delta]
					ifFalse: [(newRect perform: side) - delta])].
	"Now adjust all adjoining panes for real"
	subViews do:
		[:sub | (sub displayBox bordersOn: subView displayBox along: side) ifTrue:
			[newBox _ sub displayBox adjustTo: newRect along: side.
			sub window: sub window viewport:
				(sub transform: (sub inverseDisplayTransform: newBox)) rounded]].
	"And adjust the growing pane itself"
	subView window: subView window viewport:
			(subView transform: (subView inverseDisplayTransform: newRect)) rounded.

	"Finally force a recomposition of the whole window"
	viewport _ nil.
	self resizeTo: self viewport.
	self uncacheBits; displayEmphasized! !

!StandardSystemView methodsFor: 'framing' stamp: 'BG 12/4/2003 13:14'!
reframeTo: newFrame
	"Reframe the receiver to the given screen rectangle.  
	Repaint difference after the change.  "
	| oldBox newBox portRect |
	self uncacheBits.
	oldBox _ self windowBox.
	portRect _ newFrame topLeft + self labelOffset
				corner: newFrame corner.
	self setWindow: nil.
	self resizeTo: portRect.
	self setLabelRegion.
	newBox _ self windowBox.
	(oldBox areasOutside: newBox) do:
		[:rect | ScheduledControllers restore: rect].
	self displayEmphasized! !

!StandardSystemView methodsFor: 'framing'!
resize
	"Determine the rectangular area for the receiver, adjusted to the 
	minimum and maximum sizes."
	| f |
	f _ self getFrame.
	self resizeTo: (f topLeft + self labelOffset extent: f extent)
! !

!StandardSystemView methodsFor: 'framing'!
resizeInitially
	"Determine the rectangular area for the receiver, adjusted to the 
	minimum and maximum sizes."
	self resizeTo: self initialFrame
! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 4/6/98 15:12'!
resizeMinimumCenteredAt: aPoint 
	"Determine the rectangular area for the receiver, adjusted so that it is 
	centered a position, aPoint."
	| aRectangle |
	aRectangle _ 0 @ 0 extent: self minimumSize.
	aRectangle _ aRectangle align: aRectangle center with: aPoint.
	self resizeTo: aRectangle! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 4/6/98 15:29'!
resizeTo: aRectangle
	"Resize this view to aRectangle"

	"First get scaling right inside borders"
	self window: (self window insetBy: borderWidth)
		viewport: (aRectangle insetBy: borderWidth).

	"Then ensure window maps to aRectangle"
	window _ transformation applyInverseTo: aRectangle! !

!StandardSystemView methodsFor: 'framing'!
standardWindowOffset
	^ Preferences standardWindowOffset! !

!StandardSystemView methodsFor: 'framing'!
windowBox
	^ self displayBox merge: self labelDisplayBox! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 10/3/97 14:19'!
windowOrigin
	^ (self isCollapsed or: [labelFrame height = 0  "no label"])
		ifTrue: [self displayBox topLeft]
		ifFalse: [self displayBox topLeft - self labelOffset]! !


!StandardSystemView methodsFor: 'initialize-release' stamp: 'sw 10/29/1999 12:58'!
initialize 
	"Refer to the comment in View|initialize."
	super initialize.
	labelFrame _ Quadrangle new.
	labelFrame region: (Rectangle origin: 0 @ 0 extent: 50 @ self labelHeight).
	labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	self label: nil.
	isLabelComplemented _ false.
	minimumSize _ 50 @ 50.
	maximumSize _ Display extent.
	collapsedViewport _ nil.
	expandedViewport _ nil.
	bitsValid _ false.
	updatablePanes _ #()! !

!StandardSystemView methodsFor: 'initialize-release'!
model: aModel
	"Set the receiver's model.  For a Standard System View, we also at this time get the default background color set up.  7/30/96 sw"
	super model: aModel.
	self setDefaultBackgroundColor! !

!StandardSystemView methodsFor: 'initialize-release' stamp: 'jm 8/20/1998 18:29'!
release

	model windowIsClosing.
	self isCollapsed ifTrue: [savedSubViews do: [:v | v release]].
	super release.
! !


!StandardSystemView methodsFor: 'label access' stamp: 'di 6/16/97 12:30'!
closeBoxFrame
	^ Rectangle origin: (self labelDisplayBox leftCenter + (10@-5)) extent: (11@11)! !

!StandardSystemView methodsFor: 'label access' stamp: 'di 6/16/97 12:29'!
growBoxFrame
	^ Rectangle origin: (self labelDisplayBox rightCenter + (-22@-5)) extent: (11@11)! !

!StandardSystemView methodsFor: 'label access'!
label
	"Answer the string that appears in the receiver's label."
	labelText isNil
		ifTrue: [^ 'Untitled' copy]
		ifFalse: [^ labelText asString]! !

!StandardSystemView methodsFor: 'label access' stamp: 'sw 12/9/1999 17:44'!
label: aString 
	"Set aString to be the receiver's label."
	labelText _ Paragraph
			withText: (Text string: ((aString == nil or: [aString isEmpty])
								ifTrue: ['Untitled' copy]
								ifFalse: [aString])
							attributes: (Array with: TextEmphasis bold))
			style: LabelStyle.
	insetDisplayBox == nil ifTrue: [^ self].  "wait for further initialization"
	self setLabelRegion! !

!StandardSystemView methodsFor: 'label access'!
labelColor
	"Answer the color to use as the background for the receiver's label.  By default, this is the same as the background color of the window, but need not be.  7/16/96 sw"

	^ self backgroundColor! !

!StandardSystemView methodsFor: 'label access'!
labelDisplayBox
	"Answer the rectangle that borders the visible parts of the receiver's label 
	on the display screen."

	^ labelFrame region
		align: labelFrame topLeft
		with: self windowOrigin! !

!StandardSystemView methodsFor: 'label access'!
labelFrame
	^labelFrame! !

!StandardSystemView methodsFor: 'label access' stamp: 'sw 12/9/1999 17:47'!
labelHeight
	^ ((LabelStyle fontAt: 1) height + 4) max: 20! !

!StandardSystemView methodsFor: 'label access'!
labelOffset
	^ 0 @ (self labelHeight-2)! !

!StandardSystemView methodsFor: 'label access' stamp: 'sr 3/26/2000 04:26'!
labelText
	^labelText! !

!StandardSystemView methodsFor: 'label access'!
labelTextRegion
	labelText == nil ifTrue: [^ self labelDisplayBox center extent: 0@0].
	^ (labelText boundingBox
			align: labelText boundingBox center
			with: self labelDisplayBox center)
		intersect: (self labelDisplayBox insetBy: 35@0)! !

!StandardSystemView methodsFor: 'label access' stamp: 'di 10/3/97 14:20'!
noLabel
	"A label of zero height indicates no label"
	labelFrame height > 0
		ifTrue: [labelFrame region: (labelFrame bottomLeft + (0@1) extent: labelFrame width@0).
				labelFrame borderWidth: 0.
				self uncacheBits]! !

!StandardSystemView methodsFor: 'label access' stamp: 'di 6/10/1998 13:18'!
relabel: aString 
	"A new string for the label.  Window is assumed to be active.
	Window will redisplay only if label bar has to grow."
	| oldRegion oldWidth |
	(model windowReqNewLabel: aString) ifFalse: [^ self].
	oldRegion _ self labelTextRegion.
	oldWidth _ self insetDisplayBox width.
	self label: aString.
	Display fill: ((oldRegion merge: self labelTextRegion) expandBy: 3@0)
			fillColor: self labelColor.
	self insetDisplayBox width = oldWidth
		ifTrue: [self displayLabelText; emphasizeLabel]
		ifFalse: [self uncacheBits; displayEmphasized].
! !

!StandardSystemView methodsFor: 'label access' stamp: 'sw 1/19/2001 20:13'!
setLabel: aLabel
	"For compatibility with morphic"

	self relabel: aLabel! !

!StandardSystemView methodsFor: 'label access' stamp: 'di 10/3/97 13:35'!
setLabelRegion
	"Always follows view width"

	labelFrame region: (0 @ 0 extent: self displayBox width @ self labelHeight).
	labelFrame borderWidth: 2! !

!StandardSystemView methodsFor: 'label access' stamp: 'sumim 2/8/2002 14:36'!
setLabelTo: aString 
	"Force aString to be the new label of the receiver, bypassing any logic about whether it is acceptable and about propagating information about the change."

	| oldRegion oldWidth |
	self label: aString.
	self controller isControlActive ifFalse: [^ self].
	oldRegion _ self labelTextRegion.
	oldWidth _ self insetDisplayBox width.
	Display fill: ((oldRegion merge: self labelTextRegion) expandBy: 3@0)
			fillColor: self labelColor.
	self insetDisplayBox width = oldWidth
		ifTrue: [self displayLabelText; emphasizeLabel]
		ifFalse: [self uncacheBits; displayEmphasized]! !


!StandardSystemView methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:49'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	updatablePanes ifNil: [updatablePanes _ #()].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!StandardSystemView methodsFor: 'size'!
maximumSize
	"Answer a point representing the maximum width and height of the 
	receiver."

	^maximumSize! !

!StandardSystemView methodsFor: 'size'!
maximumSize: aPoint 
	"Set the argument, aPoint, to be the maximum width and height of the 
	receiver."

	maximumSize _ aPoint! !

!StandardSystemView methodsFor: 'size'!
minimumSize
	"Answer a point representing the minimum width and height of the 
	receiver."

	^minimumSize! !

!StandardSystemView methodsFor: 'size'!
minimumSize: aPoint 
	"Set the argument, aPoint, to be the minimum width and height of the 
	receiver."

	minimumSize _ aPoint! !


!StandardSystemView methodsFor: 'testing'!
containsPoint: aPoint 
	"Refer to the comment in View|containsPoint:."

	^(super containsPoint: aPoint) | (self labelContainsPoint: aPoint)! !

!StandardSystemView methodsFor: 'testing'!
isCollapsed
	"Answer whether the receiver is collapsed (true) or expanded (false)."

	^savedSubViews ~~ nil! !

!StandardSystemView methodsFor: 'testing'!
labelContainsPoint: aPoint 
	"Answer TRUE if aPoint is in the label box."

	^self labelDisplayBox containsPoint: aPoint! !


!StandardSystemView methodsFor: 'updating' stamp: 'sw 10/29/1999 12:57'!
setUpdatablePanesFrom: getSelectors
	| aList aPane |
	"Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors.  Order is important here!!  Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case"

	aList _ OrderedCollection new.
	getSelectors do:
		[:sel | aPane _ self subViewSatisfying:
				[:pane | (pane isKindOf: PluggableListView) and: [pane getListSelector == sel]].
			aPane
				ifNotNil:
					[aList add: aPane]
				ifNil:
					[Transcript cr; show: 'Warning: view ', sel, ' not found.']].
	updatablePanes _ aList asArray! !

!StandardSystemView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:20'!
updatablePanes
	"Answer the list of panes, in order, which might be sent the #verifyContents message upon window activation or expansion."
	^ updatablePanes ifNil: [updatablePanes _ #()]! !

!StandardSystemView methodsFor: 'updating' stamp: 'sw 1/11/2000 15:30'!
update: aSymbol
	aSymbol = #relabel
		ifTrue: [^ self setLabelTo: model labelString].
	^ super update: aSymbol! !


!StandardSystemView methodsFor: 'private'!
setTransformation: aTransformation 
	"Override to support label size changes "
	super setTransformation: aTransformation.
	self label: self label! !

!StandardSystemView methodsFor: 'private' stamp: 'di 10/21/1998 16:12'!
subviewWithLongestSide: sideBlock near: aPoint 
	| theSub theSide theLen box |
	theLen _ 0.
	subViews do:
		[:sub | box _ sub insetDisplayBox.
		box forPoint: aPoint closestSideDistLen:
			[:side :dist :len |
			(dist <= 5 and: [len > theLen]) ifTrue:
				[theSub _ sub.
				theSide _ side.
				theLen _ len]]].
	sideBlock value: theSide.
	^ theSub! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardSystemView class
	instanceVariableNames: ''!

!StandardSystemView class methodsFor: 'class initialization'!
cachingBits
	^ CacheBits! !

!StandardSystemView class methodsFor: 'class initialization'!
doCacheBits
	"StandardSystemView doCacheBits - Enable fast window repaint feature"
	CacheBits _ true.
	ScheduledControllers unCacheWindows.
	ScheduledControllers restore! !

!StandardSystemView class methodsFor: 'class initialization'!
dontCacheBits
	"StandardSystemView dontCacheBits - Disable fast window repaint feature.
	Return true iff bits were cached, ie if space was been recovered"
	CacheBits ifFalse: [^ false].
	CacheBits _ false.
	ScheduledControllers unCacheWindows.
	^ true! !

!StandardSystemView class methodsFor: 'class initialization' stamp: 'sw 12/6/1999 23:42'!
initialize		"StandardSystemView initialize"
	self doCacheBits.
	self setLabelStyle! !

!StandardSystemView class methodsFor: 'class initialization' stamp: 'nk 9/1/2004 10:26'!
setLabelStyle
	| aFont |
	"StandardSystemView setLabelStyle"
	aFont _ Preferences windowTitleFont.
	LabelStyle _ TextStyle fontArray: { aFont }.
	LabelStyle gridForFont: 1 withLead: 0! !
Object subclass: #StandardToolSet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Base'!
!StandardToolSet commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardToolSet class
	instanceVariableNames: ''!

!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/16/2005 15:20'!
browseChangeSetsWithClass: aClass selector: aSelector
	"Browse all the change sets with the given class/selector"
	^ChangeSorter browseChangeSetsWithClass: aClass selector: aSelector! !

!StandardToolSet class methodsFor: 'browsing' stamp: 'md 3/10/2006 21:42'!
browseHierarchy: aClass selector: aSelector
	"Open a browser"
	| newBrowser |
	(aClass == nil)  ifTrue: [^ self].
	(newBrowser := SystemBrowser default new) setClass: aClass selector: aSelector.
	newBrowser spawnHierarchy.! !

!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:12'!
browseMessageNames: aString
	^(MessageNames methodBrowserSearchingFor: aString) openInWorld! !

!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:13'!
browseMessageSet: messageList name: title autoSelect: autoSelectString
	"Open a message set browser"
	^MessageSet
		openMessageList: messageList 
		name: title 
		autoSelect: autoSelectString! !

!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:35'!
browseVersionsOf: aClass selector: aSelector
	"Open a browser"
	VersionsBrowser
		browseVersionsOf: (aClass compiledMethodAt: aSelector)
		class: aClass theNonMetaClass
		meta: aClass isMeta
		category: (aClass organization categoryOfElement: aSelector)
		selector: aSelector! !

!StandardToolSet class methodsFor: 'browsing' stamp: 'md 3/10/2006 21:43'!
browse: aClass selector: aSelector
	"Open a browser"
	^SystemBrowser default fullOnClass: aClass selector: aSelector! !

!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/15/2005 18:58'!
openChangedMessageSet: aChangeSet
	"Open a ChangedMessageSet for aChangeSet"
	ChangedMessageSet openFor: aChangeSet! !

!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/15/2005 18:58'!
openClassListBrowser: anArray title: aString
	"Open a class list browser"
	^ClassListBrowser new initForClassesNamed: anArray title: aString
! !


!StandardToolSet class methodsFor: 'class initialization' stamp: 'ar 7/17/2005 01:04'!
initialize
	ToolSet register: self.
	Preferences installMissingWindowColors.! !

!StandardToolSet class methodsFor: 'class initialization' stamp: 'ar 7/16/2005 16:18'!
unload
	ToolSet unregister: self.! !


!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 7/15/2005 19:15'!
debugContext: aContext label: aString contents: contents
	"Open a debugger on the given process and context."
	^Debugger openContext: aContext label: aString contents: contents! !

!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 11:16'!
debugError: anError
	"Handle an otherwise unhandled error"
	^Processor activeProcess
		debug: anError signalerContext
		title: anError description! !

!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 9/27/2005 19:18'!
debugSyntaxError: anError
	"Handle a syntax error"
	| notifier |
	notifier :=  SyntaxError new
		setClass: anError errorClass
		code: anError errorCode
		debugger: (Debugger context: anError signalerContext)
		doitFlag: anError doitFlag.
	notifier category: anError category.
	SyntaxError open: notifier.! !

!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 7/15/2005 18:57'!
debug: aProcess context: aContext label: aString contents: contents fullView: aBool
	"Open a debugger on the given process and context."
	^Debugger openOn: aProcess context: aContext label: aString contents: contents fullView: aBool! !

!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 11:16'!
interrupt: aProcess label: aString
	"Open a debugger on the given process and context."
	Debugger
		openInterrupt: aString
		onProcess: aProcess! !


!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 18:57'!
basicInspect: anObject
	"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
	^BasicInspector openOn: anObject! !

!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 19:34'!
explore: anObject
	"Open an explorer on the given object."
	^ObjectExplorer new openExplorerFor: anObject! !

!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 19:54'!
inspectorClassOf: anObject
	"Answer the inspector class for the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
	| map |
	map := Dictionary new.
	#(
		(CompiledMethod		CompiledMethodInspector)
		(CompositeEvent		OrderedCollectionInspector)
		(Dictionary			DictionaryInspector)
		(ExternalStructure	ExternalStructureInspector)
		(FloatArray			OrderedCollectionInspector)
		(OrderedCollection	OrderedCollectionInspector)
		(Set					SetInspector)
		(WeakSet			WeakSetInspector)
	) do:[:spec|
		map at: spec first put: spec last.
	].
	anObject class withAllSuperclassesDo:[:cls|
		map at: cls name ifPresent:[:inspectorName| ^Smalltalk classNamed: inspectorName].
	].
	^Inspector! !

!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 18:58'!
inspect: anObject
	"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
	^(self inspectorClassOf: anObject) openOn: anObject! !

!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 19:57'!
inspect: anObject label: aString
	"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
	^(self inspectorClassOf: anObject) openOn: anObject withEvalPane: true withLabel: aString! !


!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:19'!
menuItems
	"Answer the menu items available for this tool set"
	^#(
		('class browser' 			#openClassBrowser)
		('workspace'				#openWorkspace)
		('file list'					#openFileList)
		('package pane browser' 	#openPackagePaneBrowser)
		('process browser' 			#openProcessBrowser)
		-
		('method finder'				#openSelectorBrowser)
		('message names'			#openMessageNames)
		-
		('simple change sorter'		#openChangeSorter)
		('dual change sorter'		#openDualChangeSorter)
	)
! !

!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:05'!
openChangeSorter
	ChangeSorter new morphicWindow openInWorld! !

!StandardToolSet class methodsFor: 'menu' stamp: 'md 3/10/2006 21:47'!
openClassBrowser
	SystemBrowser default open! !

!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:05'!
openDualChangeSorter
	DualChangeSorter new morphicWindow openInWorld! !

!StandardToolSet class methodsFor: 'menu' stamp: 'md 2/24/2006 15:21'!
openFileList
	FileList2 prototypicalToolWindow openInWorld.! !

!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 12:59'!
openMessageNames
	"Bring a MessageNames tool to the front"
	MessageNames openMessageNames! !

!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:04'!
openPackagePaneBrowser
	PackagePaneBrowser openBrowser.! !

!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 12:59'!
openProcessBrowser
	ProcessBrowser open! !

!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:00'!
openSelectorBrowser
	SelectorBrowser new morphicWindow openInWorld! !

!StandardToolSet class methodsFor: 'menu' stamp: 'md 1/18/2006 19:08'!
openWorkspace
	Workspace open! !
Viewer subclass: #StandardViewer
	instanceVariableNames: 'firstPanel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!StandardViewer commentStamp: 'sw 8/17/2002 02:04' prior: 0!
A structure that allows you to view state and behavior of an object; it consists of a header and then any number of CategoryViewers.!


!StandardViewer methodsFor: 'categories' stamp: 'sw 12/28/1998 15:22'!
addCategoryViewer	
	self addCategoryViewerFor: self likelyCategoryToShow! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 8/23/2002 14:50'!
addCategoryViewerFor: categoryInfo
	"Add a category viewer for the given category info"

	self addCategoryViewerFor: categoryInfo atEnd: true! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 8/23/2002 14:56'!
addCategoryViewerFor: categoryInfo atEnd: atEnd
	"Add a category viewer for the given category info.  If atEnd is true, add it at the end, else add it just after the header morph"

	| aViewer |
	aViewer _ self categoryViewerFor: categoryInfo.
	atEnd
		ifTrue:
			[self addMorphBack: aViewer]
		ifFalse:
			[self addMorph: aViewer after: submorphs first].
	aViewer establishContents.
	self world ifNotNil: [self world startSteppingSubmorphsOf: aViewer].
	self fitFlap! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 8/23/2002 14:18'!
addSearchPane
	"Add a search pane"

	self addCategoryViewerFor: #(search '') atEnd: false! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 11/18/1999 16:00'!
categoriesCurrentlyShowing
	^ self categoryMorphs collect: [:m | m currentCategory]! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 10/30/1998 18:38'!
categoryMorphs
	^ self submorphsSatisfying: [:m | m isKindOf: CategoryViewer]! !

!StandardViewer methodsFor: 'categories' stamp: 'gm 2/22/2003 13:01'!
categoryViewerFor: categoryInfo 
	"Answer a category viewer for the given category info"

	| aViewer |
	aViewer := ((categoryInfo isCollection) 
				and: [categoryInfo first == #search]) 
					ifFalse: [CategoryViewer new]
					ifTrue: [SearchingViewer new].
	aViewer initializeFor: scriptedPlayer categoryChoice: categoryInfo.
	^aViewer! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 8/3/2001 18:22'!
chooseLimitClass
	"Put up a menu allowing the user to choose the most generic class to show"

	| aMenu limitClass |
	aMenu _ MenuMorph new defaultTarget: self.
	limitClass _ self limitClass.
	scriptedPlayer class withAllSuperclasses do:
		[:aClass | 
			aClass == ProtoObject
				ifTrue:
					[aMenu addLine].
			aMenu add: aClass name selector: #setLimitClass: argument: aClass.
			aClass == limitClass ifTrue:
				[aMenu lastItem color: Color red].
			aClass == limitClass ifTrue: [aMenu addLine]].
	aMenu addTitle: 'Show only methods
implemented at or above...'.  "heh heh -- somebody please find nice wording here!!"
	aMenu popUpInWorld: self currentWorld! !

!StandardViewer methodsFor: 'categories' stamp: 'ka 11/29/2005 20:53'!
likelyCategoryToShow
	"Choose a category to show based on what's already showing and on some predefined heuristics"

	| possible all aCat currVocab |
	all := (scriptedPlayer categoriesForViewer: self) asOrderedCollection.
	possible _ all copy.

	currVocab := self currentVocabulary.
	self categoryMorphs do: 
			[:m | 
			aCat := currVocab categoryWhoseTranslatedWordingIs: m currentCategory.
			aCat ifNotNil: [possible remove: aCat wording ifAbsent: []]].

	(possible includes: ScriptingSystem nameForInstanceVariablesCategory translated) ifTrue:
		[^ ScriptingSystem nameForInstanceVariablesCategory].

	(currVocab isEToyVocabulary) 
		ifTrue: 
			[(possible includes: ScriptingSystem nameForScriptsCategory translated) 
				ifTrue: [^ ScriptingSystem nameForScriptsCategory]].
	{'kedama' translated. #basic translated} 
		do: [:preferred | (possible includes: preferred) ifTrue: [^ preferred]].
	((scriptedPlayer isPlayerLike) 
		and: [scriptedPlayer hasOnlySketchCostumes]) 
			ifTrue: [(possible includes: #tests translated) ifTrue: [^#tests translated]].
	{#'color & border' translated. #tests translated. #color translated. #flagging translated. #comparing translated.} 
		do: [:preferred | (possible includes: preferred) ifTrue: [^ preferred]].
	^ possible isEmpty ifFalse: [possible first] ifTrue: [all first]! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 8/3/2001 18:17'!
limitClass
	"Answer the limit class to use in this viewer"

	| aClass |
	(aClass _ self valueOfProperty: #limitClass)  ifNotNil:
		[^ aClass].

	aClass _ scriptedPlayer defaultLimitClassForVocabulary: self currentVocabulary.
	self setProperty: #limitClass toValue: aClass.
	^ aClass! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 8/3/2001 18:31'!
limitClass: aClass
	"Set aClass as the limit class for this viewer, without side effects"

	self setProperty: #limitClass toValue: aClass
! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 12/11/2000 10:51'!
outerViewer
	"Answer the StandardViewer or equivalent that contains this object"

	^ self! !

!StandardViewer methodsFor: 'categories' stamp: 'di 2/19/2001 10:39'!
recreateCategories
	"To change from old to new tiles"
	| cats |
	cats _ self categoriesCurrentlyShowing.
	self removeAllMorphsIn: self categoryMorphs.
	cats do: [:cat | self addCategoryViewerFor: cat]! !

!StandardViewer methodsFor: 'categories' stamp: 'yo 4/4/2005 14:42'!
searchingViewerMorphs
	^ self submorphsSatisfying: [:m | m isKindOf: SearchingViewer].! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 8/3/2001 18:31'!
setLimitClass: aClass
	"Set aClass as the limit class for this viewer"

	self limitClass: aClass.
	self relaunchViewer
! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 5/29/2001 22:43'!
symbolsOfCategoriesCurrentlyShowing
	"Answer the category symbols of my categoryMorphs"

	^ self categoryMorphs collect: [:m | m chosenCategorySymbol]! !


!StandardViewer methodsFor: 'classification' stamp: 'ar 6/30/2001 13:13'!
isStandardViewer
	^true! !


!StandardViewer methodsFor: 'debug and other' stamp: 'sw 6/20/2001 12:47'!
viewMorphDirectly
	"Launch a new viewer to replace the receiver."

	self delete.
	self presenter viewObjectDirectly: scriptedPlayer costume renderedMorph! !


!StandardViewer methodsFor: 'initialization' stamp: 'nk 9/2/2004 11:30'!
addHeaderMorphWithBarHeight: anInteger includeDismissButton: aBoolean
	"Add the header morph to the receiver, using anInteger as a guide for its height, and if aBoolean is true, include a dismiss buton for it"

	| header aFont aButton aTextMorph nail wrpr costs headWrapper |
	header _ AlignmentMorph newRow color: self color muchLighter; wrapCentering: #center; cellPositioning: #leftCenter.
	aFont _ Preferences standardButtonFont.
	aBoolean ifTrue:
		[aButton _ self tanOButton.
		header addMorph: aButton.
		aButton target: self;
				actionSelector: #dismiss;
				setBalloonText: 'remove this entire Viewer from the screen
don''t worry -- nothing will be lost!!.' translated.
		header addTransparentSpacerOfSize: 4@1].

	aButton _ IconicButton new borderWidth: 0;
			labelGraphic: (ScriptingSystem formAtKey: #AddCategoryViewer); color: Color transparent; 
			actWhen: #buttonDown;
			target: self;
			actionSelector: #addCategoryViewer;
			setBalloonText: 'click here to add
another category pane' translated;
			shedSelvedge.
	header addMorphBack: aButton.
	header addTransparentSpacerOfSize: 4@1.

	costs _ scriptedPlayer costumes.
	costs ifNotNil:
	[(costs size > 1 or: [costs size = 1 and: [costs first ~~ scriptedPlayer costume]]) ifTrue:
		[header addUpDownArrowsFor: self.
		(wrpr _ header submorphs last) submorphs second setBalloonText: 'switch to previous costume' translated.	
		wrpr submorphs first  setBalloonText: 'switch to next costume' translated]].	

	nail _ (self hasProperty: #noInteriorThumbnail)
		ifFalse:
			[ThumbnailMorph new objectToView: scriptedPlayer viewSelector: #costume]
		ifTrue:
			[ImageMorph new image: Cursor menu].
	nail on: #mouseDown send: #offerViewerMenuForEvt:morph: to: scriptedPlayer.
	header addMorphBack: nail.
	nail setBalloonText: 'click here to get a menu
that will allow you to
add a variable,
tear off a tile, etc..' translated.
	(self hasProperty: #noInteriorThumbnail)
		ifFalse:
			[nail borderWidth: 3; borderColor: #raised].

	header addTransparentSpacerOfSize: 5@5.

"	aButton _ SimpleButtonMorph new target: self; actionSelector: #newEmptyScript; label: 'S' translated font: (aFont _ StrikeFont familyName: #ComicBold size: 16);  color: Color transparent; borderWidth: 0; actWhen: #buttonDown.
	aButton setBalloonText: 'drag from here to
create a new script
for this object' translated.	
	header addMorphBack: aButton.

	header addTransparentSpacerOfSize: 8@5."
	
	aButton _ SimpleButtonMorph new target: scriptedPlayer; actionSelector: #addInstanceVariable; label: 'v' translated font: (aFont emphasized: 1);  color: Color transparent; borderWidth: 1; actWhen: #buttonUp.
	"aButton firstSubmorph color: Color gray."
	aButton setBalloonText: 'click here to add a variable
to this object.' translated.
	header addMorphBack: aButton.

	header addTransparentSpacerOfSize: 5@5.
	self viewsMorph ifTrue: [scriptedPlayer costume assureExternalName].
	aTextMorph _ UpdatingStringMorph new
		useStringFormat;
		target:  scriptedPlayer;
		getSelector: #nameForViewer;
		setNameTo: 'name';
		font: ScriptingSystem fontForNameEditingInScriptor.
	self viewsMorph ifTrue:
		[aTextMorph putSelector: #setName:.
		aTextMorph setProperty: #okToTextEdit toValue: true].
	aTextMorph step.
	header  addMorphBack: aTextMorph.
	aTextMorph setBalloonText: 'Click here to edit the player''s name.' translated.	

	header beSticky.
	anInteger > 0
		ifTrue:
			[headWrapper _ AlignmentMorph newColumn color: self color.
			headWrapper addTransparentSpacerOfSize: (0 @ anInteger).
			headWrapper addMorphBack: header.
			self addMorph: headWrapper]
		ifFalse:
			[self addMorph: header]! !

!StandardViewer methodsFor: 'initialization' stamp: 'gm 2/22/2003 13:44'!
affordsUniclass
	"Answer true iff the receiver operates on behalf of an object that is, or could become, a member of a Uniclass"

	| viewee |
	^(viewee := self objectViewed) belongsToUniClass or: 
			[((viewee isInteger) not and: [viewee isBehavior not]) 
				and: [self userLevel > 0]]! !

!StandardViewer methodsFor: 'initialization' stamp: 'ar 6/30/2001 13:23'!
fitFlap
	(owner notNil and:[owner isFlap]) ifTrue:[
		owner width < self fullBounds width ifTrue:[
			owner assureFlapWidth: self fullBounds width + 25.
		].
	].! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 12/23/1998 23:26'!
initialHeightToAllow
	^ 300! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 6/25/1999 23:04'!
initializeFor: aPlayer barHeight: anInteger
	^ self initializeFor: aPlayer barHeight: anInteger includeDismissButton: true! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 8/4/2000 13:02'!
initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean
	self initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean showCategories: nil! !

!StandardViewer methodsFor: 'initialization' stamp: 'yo 8/18/2005 13:43'!
initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean showCategories: categoryInfo
	"Initialize the receiver to be a look inside the given Player.  The categoryInfo, if present, describes which categories should be present in it, in which order"

	scriptedPlayer _ aPlayer.
	self listDirection: #topToBottom;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		borderWidth: 1.
	self color: self standardViewerColor.
	self addHeaderMorphWithBarHeight: anInteger includeDismissButton: aBoolean.

	categoryInfo isEmptyOrNil
		ifFalse:  "Reincarnating an pre-existing list"
			[categoryInfo do:
				[:aCat | self addCategoryViewerFor: aCat]]
		ifTrue:  "starting fresh"
			[self addSearchPane. 
			self addCategoryViewer.
			self addCategoryViewer.
			(scriptedPlayer costume isMemberOf: KedamaMorph) ifTrue: [self addCategoryViewer].
		].! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 6/4/2001 18:06'!
rawVocabulary: aVocabulary
	"Mark the receiver as having aVocabulary as its vocabulary"

	self setProperty: #currentVocabularySymbol toValue: aVocabulary vocabularyName! !

!StandardViewer methodsFor: 'initialization' stamp: 'nk 8/29/2004 17:18'!
switchToVocabulary: aVocabulary
	"Make the receiver show categories and methods as dictated by aVocabulary.  If this constitutes a switch, then wipe out existing category viewers, which may be showing the wrong thing."

	self adoptVocabulary: aVocabulary.  "for benefit of submorphs"
	self setProperty: #currentVocabularySymbol toValue: aVocabulary vocabularyName.
	((scriptedPlayer isPlayerLike) and: [self isUniversalTiles not]) ifTrue:
		[scriptedPlayer allScriptEditors do:
			[:aScriptEditor |
				aScriptEditor adoptVocabulary: aVocabulary]]! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 6/4/2001 19:40'!
useVocabulary: aVocabulary
	"Make the receiver show categories and methods as dictated by aVocabulary"

	| itsName |
	((self valueOfProperty: #currentVocabularySymbol ifAbsent: [nil]) == (itsName _ aVocabulary vocabularyName)) ifFalse:
		[self setProperty: #currentVocabularySymbol toValue: itsName.
		self removeProperty: #currentVocabulary.  "grandfathered"
		(self submorphs select: [:m | m isKindOf: CategoryViewer]) do: [:m | m delete]]! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 10/26/2000 09:42'!
userLevel
	"Answer the user level for this viewer, which can be used in figuring out what to display in the viewer.  Initially, we make little use of this, but in past prototypes, and in future deployments, it may be handy."

	^ self valueOfProperty: #userLevel ifAbsent: [1]! !

!StandardViewer methodsFor: 'initialization' stamp: 'nk 8/29/2004 17:18'!
viewsMorph
	"Answer whether the receiver views a morph.  Traditional viewers up until late 2000 *all* viewed morphs (as per the morph/player architecture), but viewers on non-morph/players have now become possible"

	^ scriptedPlayer isPlayerLike! !


!StandardViewer methodsFor: 'macpal' stamp: 'sw 6/4/2001 18:05'!
currentVocabulary
	"Answer the vocabulary currently associated with the receiver"

	| aSym aVocab |
	aSym _ self valueOfProperty: #currentVocabularySymbol ifAbsent: [nil].
	aSym ifNil:
		[aVocab _ self valueOfProperty: #currentVocabulary ifAbsent: [nil].
		aVocab ifNotNil:
			[aSym _ aVocab vocabularyName.
			self removeProperty: #currentVocabulary.
			self setProperty: #currentVocabularySymbol toValue: aSym]].
	^ aSym
		ifNotNil:
			[Vocabulary vocabularyNamed: aSym]
		ifNil:
			[(self world ifNil: [ActiveWorld]) currentVocabularyFor: scriptedPlayer]! !


!StandardViewer methodsFor: 'user interface' stamp: 'sw 10/25/1999 22:08'!
dismiss
	| aFlapTab |
	"User hit the dismiss button."
	(owner isKindOf: TabbedPalette)
		ifTrue:
			[^ owner showNoPalette].
	(aFlapTab _ self pasteUpMorph correspondingFlapTab) ifNotNil:
		[^ aFlapTab dismissViaHalo].
	self topRendererOrSelf delete! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 10/24/1998 14:34'!
downArrowHit
	self nextCostume! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 10/26/1999 01:07'!
hasDismissButton
	submorphs isEmptyOrNil ifTrue: [^ false].
	^ (submorphs first allMorphs detect:
		[:possible |  (possible isKindOf: SimpleButtonMorph) and: [possible actionSelector == #dismiss]]
			ifNone: [nil]) notNil! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 5/18/2001 10:46'!
openLexicon
	"Open a lexicon browser on the receiver, showing its current vocabulary"

	| littleHim | 
	littleHim _ scriptedPlayer assureUniClass.

	(InstanceBrowser new useVocabulary: self currentVocabulary) openOnObject: littleHim  inWorld: ActiveWorld showingSelector: nil! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 4/20/2001 21:22'!
relaunchViewer
	"Launch a new viewer to replace the receiver."

	self presenter updateViewer: self forceToShow: nil! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 12/23/1998 22:45'!
standardViewerColor
	 ^ Color r: 0.572 g: 0.883 b: 0.572! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 10/24/1998 14:33'!
upArrowHit
	self previousCostume! !
PolygonMorph subclass: #StarMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!StarMorph commentStamp: 'wiz 9/6/2005 12:30' prior: 0!
I am a very flexible star..

Grab me from the supplies flap or from the graphic objects.
Add my handles and you can move and resize me.
The up and down arrows increase or reduce the number of my sides.
The right and left arrows cycle thru different amounts of  pointiness.


Use the arrows right and left of my center or get stars with a specific amount of pointyness.  The left side goes from fat to thin and then cycles around again. The right goes from thin to fat. Hold down the shift key if you wish to stop the cycling at the extremes.

Use the arrows up and down to change the number of sides if you would like a different number of points.

To add or remove just one side hold the shift key down as you use the arrows or use the menu items for that purpose.


If you add or remove just one point I will have an odd number of sides.  When that happens I can only look like a regular polygon. The right and left arrows will have no effect.  Add or remove just one more side and you can shift drag the outer handle or use the arrows to restore my pointiness. 

That was too complicated. It is gone. You can get regular polygon shapes by adjusting my pointiness. For example the extreme of a five pointed star is a dodecahedron (10 sided regular polygon) and one step less extreme is a pentagon (5 sided regular polygon).


At some time you will probably shift drag the outer handle thru the center handle.
While I looked round as you shrunk me, I will look very much like an asterisk as you pull me away.  What happens is that inside bend shrunk on the way down because it can never be larger than the outer point (or it wouldn't be the innerbend would it).
But on the way out it is perfectly happy to remain small. So I look like an asterisk.

To fatten me up  (if you haven't already figured this out by fooling around)  hold the shift down an move the outer handle towards the center (but not quite all the way) then let the shift up and move the outer handle away.  A couple of cycles like this and I'll be looking fat and jolly again. Or you can now just use the right arrow to make me fatter.

This is also the reason I don't let the inside bend get larger than the outer point.
If I did the same process that fattened me when I was an asterisk would also grow an asterisk so large squeak would complain about not having enough memory.

Historical note:

The former star had two bugs that are fixed here.
The outer handle now no longer jumps from one point to another.
The other bug prevented some higher order stars from looking right. 
Which is why the former star didn't allow you to change the number of points. !


!StarMorph methodsFor: 'access' stamp: 'wiz 1/11/2005 03:58'!
skipRatios
"Return an array of  ratios  of the inner radius to the outer radius.
Ratios are in ascending order from 0.0 to 1.0."
"Assume we have at least one vertex.
All ways return a number <= 1.0"

| n  alpha  |
"Odd vertices sizes can not be stars only regular polygons"
n:= vertices size . n odd ifTrue: [ ^ #(  1.0) ] .

alpha := Float pi / (n//2)  asFloat .

^ ((((    Float halfPi -alpha  to: alpha /2.0  by: alpha  negated ) 
	collect:  [:angle |( (angle) sin )/
					(angle + alpha ) sin ]
	) copyWith: 0.0) copyWithFirst: 1.0) reversed .! !

!StarMorph methodsFor: 'access' stamp: 'wiz 1/4/2005 20:14'!
starRatio
"Return the ratio of the inner radius to the outer radius."
"Assume we have at least one vertex.
All ways return a number <= 1.0"
| r c |
c := vertices average rounded .
r := (c dist: vertices last) / (c dist:  vertices first)  .
^ r > 1.0  ifTrue: [  r reciprocal ] ifFalse: [r ] .! !


!StarMorph methodsFor: 'accessing' stamp: 'wiz 1/4/2005 19:47'!
starRatio: r
"Set the star s.t. the ratio of the inner radius to the outer radius is r.
If r is > 1 use the reciprocal to keep the outer radius first."
"Assume we have at least one vertex.
set
All ways return a number <= 1.0"
self makeVertices: vertices size starRatio:( r > 1.0  ifTrue: [  r reciprocal ] ifFalse: [r ] ).! !


!StarMorph methodsFor: 'editing' stamp: 'wiz 12/15/2004 00:59'!
addHandles
	self addStarHandles! !

!StarMorph methodsFor: 'editing' stamp: 'wiz 1/15/2005 00:20'!
addStarHandles
	"Outer handle must not be blocked so it comes first. 
	The editing routine expects to find the center handle second.
	The side and shape changing handles follow these."
	| center |
	self removeHandles.
	"Check for old stars and correct order of vertices."
	self insureCompatability .
	handles := OrderedCollection new.
	center := vertices average rounded.
	self withCenterOuterHandles; withUpDownLeftRightHandlesAround: 6 center: center.
	self placeHandles.
	self changed.
	! !

!StarMorph methodsFor: 'editing' stamp: 'wiz 9/5/2005 23:12'!
changeVertices: label event: evt fromHandle: handle 
	| |
	label == #more
		ifTrue: [evt shiftPressed
				ifTrue: [self moreVertices "not oneMoreVertex"]
				ifFalse: [self moreVertices]].
	label == #less
		ifTrue: [evt shiftPressed
				ifTrue: [self lessVertices "not oneLessVertex"]
				ifFalse: [self lessVertices]].
	label == #next
		ifTrue: [evt shiftPressed
				ifTrue: [self makeVertices: vertices size starRatio: self nextSkip]
				ifFalse: [self makeVertices: vertices size starRatio: self nextTwinkleSkip]].
	label == #prev
		ifTrue: [evt shiftPressed
				ifTrue: [self makeVertices: vertices size starRatio: self prevSkip]
				ifFalse: [self makeVertices: vertices size starRatio: self prevTwinkleSkip]].
	self computeBounds! !

!StarMorph methodsFor: 'editing' stamp: 'wiz 1/20/2005 19:07'!
dragVertex: label event: evt fromHandle: handle 
	| center r1 rN rNext a1 rTotal |
	label == #outside
		ifTrue: [center := handles second center.
			r1 := center dist: vertices first.
			"Rounding and what happens as the outer handle
			approached the center, 
			requires we guard the inner radius 
			from becoming larger than the outer radius."
			rN := r1
						min: (center dist: vertices last).
			rNext := 1
						max: (center dist: evt cursorPoint).
			a1 := 270.0
						+ (center bearingToPoint: evt cursorPoint).
			rTotal := vertices size even
						ifTrue: [evt shiftPressed
								ifTrue: [rNext + rNext min: rNext + rN]
								ifFalse: [r1 + rN * rNext / r1]]
						ifFalse: [rNext + rNext].
			rNext := rTotal - rNext.
			vertices := ((a1 to: a1 + 359.999 by: 360.0 / vertices size)
						collect: [:angle | center
								+ (Point r: (rNext := rTotal - rNext) degrees: angle)]) .
			handle align: handle center with: evt cursorPoint].
	label == #center
		ifTrue: [evt shiftPressed
				ifTrue: [self updateFormFromUser]
				ifFalse: [self position: self position + (evt cursorPoint - handle center)]].
	self computeBounds! !

!StarMorph methodsFor: 'editing' stamp: 'wiz 1/15/2005 00:19'!
placeHandles
	"Add the handles to my submorphs."
	handles reverseDo: [:each | self addMorphFront: each ] .
	
	! !

!StarMorph methodsFor: 'editing' stamp: 'di 9/26/97 11:11'!
updateHandles! !

!StarMorph methodsFor: 'editing' stamp: 'wiz 1/11/2005 19:39'!
withCenterOuterHandles
	"Add to our handles the center positioning and outer resizing
	handles. Outer handle must not be blocked so it comes first. 
	The editing routine expects to find the center handle second.
	The side and shape changing handles follow these."
	| center v1 hExtent holder |
	center := vertices average rounded.
	hExtent := 8 @ 8.
	v1 := vertices first.
	holder := {(EllipseMorph
				newBounds: (Rectangle center: v1 extent: hExtent)
				color: Color yellow)
				setBalloonText: 'Move me to adjust size. Shift move to adjust pointiness'. (EllipseMorph
				newBounds: (Rectangle center: center extent: hExtent)
				color: Color yellow)
				setBalloonText: 'Move me to adjust position'}.
	holder
		with: {#outside. #center}
		do: [:handle :which | handle
				on: #mouseDown
				send: #dragVertex:event:fromHandle:
				to: self
				withValue: which;
				
				on: #mouseMove
				send: #dragVertex:event:fromHandle:
				to: self
				withValue: which].
	handles addAll: holder! !

!StarMorph methodsFor: 'editing' stamp: 'wiz 1/11/2005 19:47'!
withUpDownLeftRightHandlesAround: radius center: center
	"Add to our handles the side and shape changing handles."
	| tri  above holder  triAbove triBelow triRight triLeft |
	above := 0 @ radius negated.
	
	tri := Array
				with: 0 @ -5
				with: 4 @ 3
				with: -4 @ 3.
	triAbove := tri + (center + above).
	triBelow := triAbove
				collect: [:pt | pt rotateBy: #pi centerAt: center].
	triRight := triAbove
				collect: [:pt | pt rotateBy: #right centerAt: center].
	triLeft := triAbove
				collect: [:pt | pt rotateBy: #left centerAt: center].
				
	holder := { (PolygonMorph
				vertices: triAbove
				color: Color green
				borderWidth: 1
				borderColor: Color black)
				 setBalloonText: 'More points.'. 
				
				(PolygonMorph
				vertices: triBelow
				color: Color magenta
				borderWidth: 1
				borderColor: Color black)
				 setBalloonText: 'Fewer points.'. 
				
				(PolygonMorph
				vertices: triRight
				color: Color green
				borderWidth: 1
				borderColor: Color black)
				 setBalloonText: 'Twinkle fatter.'. 
				
				(PolygonMorph
				vertices: triLeft
				color: Color magenta
				borderWidth: 1
				borderColor: Color black)
				 setBalloonText: 'Twinkle thinner.'}.
	
	holder
		with: {#more. #less. #next. #prev}
		do: [:handle :which | handle
				on: #mouseDown
				send: #changeVertices:event:fromHandle:
				to: self
				withValue: which;
				
				on: #mouseMove
				send: #changeVertices:event:fromHandle:
				to: self
				withValue: which].
	^ handles addAll: holder! !


!StarMorph methodsFor: 'geometry' stamp: 'wiz 1/19/2005 22:34'!
nextSkip
	"Set starRatio to next skip wrapping if needed."
	| skips n c r1 rN |
	c := vertices average rounded.
	r1 := (c dist: vertices first) truncated asFloat.
	rN := c dist: vertices last.
	skips := self skipRatios.
	n := skips * r1
				findFirst: [:r | r > (rN + 1.0)].
	"n = 0
		ifTrue: [n := skips size]."
	^ skips atWrap: n! !

!StarMorph methodsFor: 'geometry' stamp: 'wiz 1/19/2005 22:42'!
nextTwinkleSkip
	"Set starRatio to next skip wrapping if needed."
	| skips n c r1 rN |
	c := vertices average rounded.
	r1 := (c dist: vertices first) truncated asFloat.
	rN := c dist: vertices last.
	skips := self skipRatios.
	n := skips * r1
				findFirst: [:r | r > (rN + 1.0)].
	n = 0
		ifTrue: [ n := 1].
	^ skips atWrap: n! !

!StarMorph methodsFor: 'geometry' stamp: 'wiz 1/19/2005 22:41'!
prevSkip
	"Set starRatio to next skip wrapping if necessary"
	| skips n c r1 rN |
	c := vertices average rounded.
	r1 := c dist: vertices first.
	rN := (c dist: vertices last) truncated asFloat.
	skips := self skipRatios.
	n := skips * r1
				findLast: [:r | r + 1.0 < rN].
	n = 0
		ifTrue: [n := 1].
	^ skips at: n! !

!StarMorph methodsFor: 'geometry' stamp: 'wiz 1/19/2005 22:19'!
prevTwinkleSkip
	"Set starRatio to next skip wrapping if necessary"
	| skips n c r1 rN |
	c := vertices average rounded.
	r1 := c dist: vertices first.
	rN := (c dist: vertices last) truncated asFloat.
	skips := self skipRatios.
	n := skips * r1
				findLast: [:r | r + 1.0 < rN].
	"n = 0
	ifTrue: [^ oldR]."
	^ skips atWrap: n! !


!StarMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color black! !

!StarMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 1/11/2005 14:33'!
defaultCenter
	"answer the default center for the receiver"
	^ 0 asPoint! !

!StarMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightBlue! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 1/11/2005 14:33'!
defaultFirstVertex
	"answer the default first outer point for the receiver.
	This with the center determines the angle and size of the outer radius."
	^ 10 asPoint! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 1/11/2005 14:28'!
defaultSides
	"answer the default number of sides for the receiver"
	^ 10! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 1/11/2005 14:29'!
defaultStarRatio
	"answer the default ratio of outer radius to inner radius for the receiver"
	^ 5.0 / 12.0! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 1/11/2005 14:36'!
initialize
	"initialize the state of the receiver"
	super initialize.
	self
		makeVertices: self defaultSides
		starRatio: self defaultStarRatio
		withCenter: self defaultCenter
		withPoint: self defaultFirstVertex.
	self computeBounds! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 1/9/2005 20:15'!
insureCompatability
"The old stars had the point on the second not the first vertex. So we need to check for this special case."
 | c v1 v2 |
c := vertices average rounded.
 v1 := vertices first .
 v2 := vertices second .
(c dist: v1) + 0.001 < (c dist: v2) ifTrue: [vertices := vertices allButFirst copyWith: v1]

! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 12/30/2004 02:57'!
makeVertices: nSides 
	"Assuming vertices has at least one point, make a new star 
	or regular polygon (for odd sided polygons).
	The center of the polygon and the first vertex remain in
	place. The inner distances for stars remain the same also if
	possible."
	| center r1 rN rNext a1 rTotal |
	center := vertices average rounded.
	r1 := center dist: vertices first.
	rN := center dist: vertices last.
	rNext := 1 max: r1.
	a1 := 270.0
				+ (center bearingToPoint: vertices first).
	rTotal := nSides even
				ifTrue: [rNext + rNext min: rNext + rN]
				ifFalse: [rNext + rNext].
	rNext := rTotal - rNext.
	self changed .
	vertices := (a1 to: a1 + 359.999 by: 360.0 / nSides)
				collect: [:angle | center
						+ (Point r: (rNext := rTotal - rNext) degrees: angle)].
	self computeBounds.
	self changed! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 1/4/2005 19:31'!
makeVertices: nSides starRatio: fraction
	"Assuming vertices has at least one point, make a new star 
	or regular polygon (for odd sided polygons).
	The center of the polygon and the first vertex remain in
	place. The inner distances for stars remain the same also if
	possible."
	| center r1 rN rNext a1 rTotal |
	center := vertices average rounded.
	r1 := center dist: vertices first.
	rNext := 1 max: r1.
	rN := (1.0 min: fraction) * rNext.
	a1 := 270.0
				+ (center bearingToPoint: vertices first).
	rTotal := nSides even
				ifTrue: [rNext + rNext min: rNext + rN]
				ifFalse: [rNext + rNext].
	rNext := rTotal - rNext.
	self changed .
	vertices := (a1 to: a1 + 359.999 by: 360.0 / nSides)
				collect: [:angle | center
						+ (Point r: (rNext := rTotal - rNext) degrees: angle)].
	self computeBounds.
	self changed! !

!StarMorph methodsFor: 'initialization' stamp: 'wiz 1/11/2005 21:36'!
makeVertices: nSides starRatio: fraction withCenter: center withPoint: aPoint 
	"Make a new star or regular polygon (for odd sided polygons).
	This makes star vertices from scratch without any feedback from existing vertices."
	| r1 rN rNext a1 rTotal |
	r1 := center dist: aPoint.
	rNext := 1 max: r1.
	rN := (1.0 min: fraction)
				* rNext.
	a1 := 270.0
				+ (center bearingToPoint: aPoint).
	rTotal := nSides even
				ifTrue: [rNext + rNext min: rNext + rN]
				ifFalse: [rNext + rNext].
	rNext := rTotal - rNext.
	self changed.
	vertices := (a1 to: a1 + 359.999 by: 360.0 / nSides)
				collect: [:angle | center
						+ (Point r: (rNext := rTotal - rNext) degrees: angle)].
	self computeBounds.
	self changed! !


!StarMorph methodsFor: 'menu' stamp: 'wiz 9/5/2005 23:08'!
addChangeSidesMenuItems: aCustomMenu hand: aHandMorph 
	"Menu items to change number of sides."
	aCustomMenu addLine.
	aCustomMenu add: 'more sides' translated action: #moreVertices.
	aCustomMenu add: 'fewer sides' translated action: #lessVertices.
"	Regular polygons can be simulated with the one of the skip stars 
	and it would confuse users to have stars be limited to Regular polygons.
	So we've removed those menu items - wiz"
"	aCustomMenu add: 'one more side' translated action: #oneMoreVertex.
	aCustomMenu add: 'one fewer side' translated action: #oneLessVertex"! !

!StarMorph methodsFor: 'menu' stamp: 'wiz 1/11/2005 14:55'!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
self addChangeSidesMenuItems: aCustomMenu hand: aHandMorph.
self addTwinkleMenuItems: aCustomMenu hand: aHandMorph.
	! !

!StarMorph methodsFor: 'menu' stamp: 'wiz 1/11/2005 20:38'!
addTwinkleMenuItems: aCustomMenu hand: aHandMorph 
	"Menu items to change the sharpness of the star."
	aCustomMenu addLine.
	aCustomMenu add: 'twinkle fatter' translated action: #nextTwinkle.
	aCustomMenu add: 'twinkle thinner' translated action: #prevTwinkle.
"	aCustomMenu add: 'fatter star' translated action: #nextFatter.
	aCustomMenu add: 'thinner star' translated action: #prevThinner"
	
	


! !

!StarMorph methodsFor: 'menu' stamp: 'wiz 12/11/2004 16:45'!
oneLessVertex
	self
		makeVertices: (3 max: 1 negated + vertices size)! !

!StarMorph methodsFor: 'menu' stamp: 'wiz 12/11/2004 16:46'!
oneMoreVertex
	self makeVertices: 1 + vertices size! !


!StarMorph methodsFor: 'menus' stamp: 'wiz 12/12/2004 16:43'!
lessVertices
"Reduce the number of points by one until we are  a diamond. If odd reduce the number of sides by two until we become a triangle. See class comment."
	| nVerts |
	( nVerts := 2 negated + vertices size) < 3 ifFalse: [
	self
		makeVertices: nVerts]! !

!StarMorph methodsFor: 'menus' stamp: 'wiz 12/11/2004 16:45'!
moreVertices
	self makeVertices: 2+ vertices size! !

!StarMorph methodsFor: 'menus' stamp: 'wiz 1/11/2005 20:37'!
nextTwinkle
	self makeVertices: vertices size starRatio: self nextTwinkleSkip .
	self computeBounds.! !

!StarMorph methodsFor: 'menus' stamp: 'wiz 1/11/2005 20:37'!
prevTwinkle
	self makeVertices: vertices size starRatio: self prevTwinkleSkip .
	self computeBounds.! !

!StarMorph methodsFor: 'menus' stamp: 'wiz 1/15/2005 02:26'!
updateFormFromUser
"Does nothing here. Overridden in subclasses e.g. Kaleidoscope."
^ self.! !


!StarMorph methodsFor: 'parts bin' stamp: 'sw 7/2/2001 11:07'!
initializeToStandAlone
	^ self initialize removeHandles! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StarMorph class
	instanceVariableNames: ''!

!StarMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:37'!
initialize

	self registerInFlapsRegistry.	! !

!StarMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:39'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(StarMorph		authoringPrototype	'Star'	'A star')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(StarMorph	authoringPrototype	'Star'	'A star')
						forFlapNamed: 'Supplies'.]! !

!StarMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:41'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!StarMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:22'!
descriptionForPartsBin
	^ self partName:	'Star'
		categories:		#('Graphics')
		documentation:	'A symmetrical polygon in the shape of a star'! !
StarSqueakMorph subclass: #StarSqueakAntColony
	instanceVariableNames: 'antCount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!StarSqueakAntColony methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initialize

	antCount := 50.
	super initialize.
! !


!StarSqueakAntColony methodsFor: 'menu' stamp: 'jm 2/7/2001 18:41'!
sliderParameters
	"Answer a list of parameters that the user can change via a slider. Each parameter is described by an array of: <name> <min value> <max value> <balloon help string>."

	^ super sliderParameters, #(
		(antCount 10 500 'The number of ants searching for food.'))
! !


!StarSqueakAntColony methodsFor: 'other' stamp: 'jm 1/19/2001 10:30'!
diffusePheromone

	self diffusePatchVariable: 'pheromone'.
! !

!StarSqueakAntColony methodsFor: 'other' stamp: 'jm 1/19/2001 18:02'!
evaporatePheromone

	self decayPatchVariable: 'pheromone'.
! !

!StarSqueakAntColony methodsFor: 'other' stamp: 'jm 2/7/2001 08:03'!
setupFood: aPatch
	"Create several food caches."

	aPatch set: 'food' to: 0.  "patch default is no food"

	((aPatch distanceTo: 15@15) <= 1 or:
	 [(aPatch distanceTo: 80@20) <= 1 or:
	 [(aPatch distanceTo: 25@80) <= 1 or:
	 [(aPatch distanceTo: 70@70) <= 1]]]) ifTrue: [
		aPatch set: 'food' to: 10.
		aPatch color: Color red].

! !

!StarSqueakAntColony methodsFor: 'other' stamp: 'sd 11/20/2005 21:26'!
setupNest: aPatch
	"Create a nest of radius 5 centered at 50@50."

	| distanceToNest |
	distanceToNest := aPatch distanceTo: 50@50.
	distanceToNest <= 4
		ifTrue: [
			aPatch set: 'isNest' to: 1.
			aPatch color: Color brown lighter]
		ifFalse: [aPatch set: 'isNest' to: 0].

	"create a 'hill' of nest scent centered on the nest"
	distanceToNest > 0 ifTrue: [
		aPatch set: 'nestScent' to: 10000.0 // distanceToNest].

! !

!StarSqueakAntColony methodsFor: 'other' stamp: 'jm 3/8/2001 14:23'!
setupPatches
	"Create patch variables for sensing the nest and food caches. The nestScent variable is diffused so that it forms a 'hill' of scent over the entire world with its peak at the center of the nest. That way, the ants always know which way the nest is."

	self createPatchVariable: 'food'.			"greater than zero if patch has food"
	self createPatchVariable: 'isNest'.		"greater than zero if patch is nest"
	self createPatchVariable: 'nestScent'.	"circular gradient with peak centered on nest"
	self createPatchVariable: 'pheromone'.	"dropped by ants when carrying food"
	self displayPatchVariable: 'pheromone'.
	self patchesDo: [:p |
		p color: self backgroundColor.
		self setupNest: p.
		self setupFood: p].

! !

!StarSqueakAntColony methodsFor: 'other' stamp: 'jm 3/8/2001 14:24'!
setupTurtles

	self makeTurtles: antCount class: AntColonyTurtle.
	turtles do: [:t |
		t goto: 50@50.
		t color: Color black.
		t isCarryingFood: false.
		t pheromoneDropSize: 100].
! !


!StarSqueakAntColony methodsFor: 'parameters' stamp: 'jm 2/7/2001 14:45'!
antCount

	^ antCount
! !

!StarSqueakAntColony methodsFor: 'parameters' stamp: 'sd 11/20/2005 21:26'!
antCount: aNumber

	antCount := aNumber.
! !

!StarSqueakAntColony methodsFor: 'parameters' stamp: 'jm 3/11/2001 17:10'!
backgroundColor

	^ Color brown lighter lighter lighter! !


!StarSqueakAntColony methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
setup

	self clearAll.
	self setupPatches.
	self setupTurtles.
	turtleDemons := #(searchForFood pickUpFood returnToNest dropFoodInNest).
	worldDemons := #(evaporatePheromone diffusePheromone).
! !
StarSqueakMorph subclass: #StarSqueakDiffusion
	instanceVariableNames: 'waterCount dyeCount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!StarSqueakDiffusion methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initialize

	dyeCount := 200.
	waterCount := 2000.
	super initialize.
! !


!StarSqueakDiffusion methodsFor: 'menu' stamp: 'jm 3/8/2001 14:08'!
sliderParameters
	"Answer a list of parameters that the user can change via a slider. Each parameter is described by an array of: <name> <min value> <max value> <balloon help string>."

	^ super sliderParameters, #(
		(dyeCount 50 1000 'The number of dye particles.')
		(waterCount 100 4000 'The number of water particles.'))
! !


!StarSqueakDiffusion methodsFor: 'other' stamp: 'sd 11/20/2005 21:26'!
setupTurtles

	| radius t |
	dyeCount ifNil: [dyeCount := 200].
	waterCount ifNil: [waterCount := 2000].
	radius := 10.
	self makeTurtles: waterCount class: DiffusionTurtle.
	turtles do: [:each |
		each color: (Color gray: 0.7).
		(each distanceTo: 50@50) < radius ifTrue: [each die]].

	self makeTurtles: dyeCount class: DiffusionTurtle.
	turtles size - (dyeCount - 1) to: turtles size do: [:i |
		t := turtles at: i.
		t goto: 50@50.
		t forward: (self random: radius).
		t color: Color green darker darker].
! !


!StarSqueakDiffusion methodsFor: 'parameters' stamp: 'jm 3/8/2001 14:07'!
dyeCount

	^ dyeCount
! !

!StarSqueakDiffusion methodsFor: 'parameters' stamp: 'sd 11/20/2005 21:26'!
dyeCount: aNumber

	dyeCount := aNumber asInteger max: 1.
! !

!StarSqueakDiffusion methodsFor: 'parameters' stamp: 'jm 3/8/2001 14:07'!
waterCount

	^ waterCount
! !

!StarSqueakDiffusion methodsFor: 'parameters' stamp: 'sd 11/20/2005 21:26'!
waterCount: aNumber

	waterCount := aNumber asInteger max: 1.
! !


!StarSqueakDiffusion methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
setup

	self clearAll.
	self patchesDo: [:p | p color: (Color gray: 0.9)].
	self setupTurtles.
	turtleDemons := #(move bounce).
! !
StarSqueakMorph subclass: #StarSqueakForestFire
	instanceVariableNames: 'treePercentage'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!StarSqueakForestFire methodsFor: 'demons' stamp: 'sd 11/20/2005 21:26'!
consumeFuel

	| level |
	self patchesDo: [:p |
		level := p get: #flameLevel.
		level > 0 ifTrue: [
			level := (level - 15) max: 0.
			p set: #flameLevel to: level.
			p brightness: level]].
! !

!StarSqueakForestFire methodsFor: 'demons' stamp: 'jm 1/28/2001 16:33'!
spreadFire

	self patchesDo: [:p |
		(p get: #isUnburnt) > 0  ifTrue: [
			((p neighborN get: #flameLevel) +
			 (p neighborS get: #flameLevel) +
			 (p neighborE get: #flameLevel) +
			 (p neighborW get: #flameLevel)) > 0 ifTrue: [
				p set: #isUnburnt to: 0.
				p set: #flameLevel to: 100.
				p color: Color red]]].
! !


!StarSqueakForestFire methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initialize

	treePercentage := 70.
	super initialize.
! !


!StarSqueakForestFire methodsFor: 'menu' stamp: 'jm 3/10/2001 11:06'!
sliderParameters
	"Answer a list of parameters that the user can change via a slider. Each parameter is described by an array of: <name> <min value> <max value> <balloon help string>."

	^ super sliderParameters, #(
		(treePercentage 0 100 'The probability of that a given patch has a tree.'))
! !


!StarSqueakForestFire methodsFor: 'parameters' stamp: 'jm 3/10/2001 11:06'!
treePercentage

	^ treePercentage
! !

!StarSqueakForestFire methodsFor: 'parameters' stamp: 'sd 11/20/2005 21:26'!
treePercentage: aNumber

	treePercentage := aNumber.
! !


!StarSqueakForestFire methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
setup

	self clearAll.
	self createPatchVariable: #isUnburnt.
	self createPatchVariable: #flameLevel.
	self setupTrees.
	self setupFire.
	self setupBorder.
	worldDemons := #(spreadFire consumeFuel).

! !

!StarSqueakForestFire methodsFor: 'setup' stamp: 'jm 1/28/2001 16:32'!
setupBorder

	self patchesDo: [:p |
		p isLeftEdge | p isRightEdge |
		p isTopEdge | p isBottomEdge ifTrue: [
			p set: #isUnburnt to: 0.
			p color: Color blue]].
! !

!StarSqueakForestFire methodsFor: 'setup' stamp: 'jm 1/28/2001 16:32'!
setupFire

	self patchesDo: [:p |
		p neighborW isLeftEdge ifTrue: [
			p set: #isUnburnt to: 0.
			p set: #flameLevel to: 100.
			p color: Color red]].
! !

!StarSqueakForestFire methodsFor: 'setup' stamp: 'jm 3/10/2001 11:09'!
setupTrees
	"Setup a forest with treePercentage of trees."

	self patchesDo: [:p |
		p set: #isUnburnt to: 0.
		p set: #flameLevel to: 0.
		(10 * treePercentage) > (self random: 1000) ifTrue: [
			p set: #isUnburnt to: 1.
			p color: Color green]].
! !
Morph subclass: #StarSqueakMorph
	instanceVariableNames: 'dimensions pixelsPerPatch patchVariables patchVariableToDisplay logPatchVariableScale patchVarDisplayForm patchForm patchColorSetter patchColorGetter turtles turtleDemons worldDemons sniffRange scaledEvaporationRate diffusionRate lastTurtleID generation running stepTime turtlesAtPatchCache turtlesAtPatchCacheValid'
	classVariableNames: 'RandomSeed'
	poolDictionaries: ''
	category: 'StarSqueak-Kernel'!
!StarSqueakMorph commentStamp: '<historical>' prior: 0!
I implement a StarSqueak simulation. StarSqueak is a Squeak version of Mitchel Resnick's Star Logo, a simulation environment designed to explore massively parallel simulations with hundreds or thousands of turtles. See the excellent book "Turtles, Termites, and Traffic Jams: Explorations in Massively Parallel Microworlds" by Mitchel Resnick, MIT Press, 1994.
!


!StarSqueakMorph methodsFor: 'accessing' stamp: 'jm 2/7/2001 13:48'!
diffusionRate

	^ diffusionRate
! !

!StarSqueakMorph methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
diffusionRate: newRate
	"Set the diffusion rate to an integer between 0 and 10. The diffusion rate gives the number of patches on one size of the area averaged to compute the next value of the variable for a given patch. Larger numbers cause faster diffusion. Zero means no diffusion."

	diffusionRate := (newRate rounded max: 0) min: 10.
! !

!StarSqueakMorph methodsFor: 'accessing' stamp: 'jm 2/7/2001 18:59'!
evaporationRate

	^ 1024 - scaledEvaporationRate! !

!StarSqueakMorph methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
evaporationRate: newRate
	"Set the evaporation rate. The useful range is 0 to 25 or so. Larger numbers cause faster evaporation. Zero means no evaporization."

	scaledEvaporationRate := ((1024 - newRate truncated) max: 1) min: 1024.

! !

!StarSqueakMorph methodsFor: 'accessing' stamp: 'jm 3/3/2001 12:50'!
pixelsPerPatch

	^ pixelsPerPatch
! !

!StarSqueakMorph methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
pixelsPerPatch: anInteger
	"Set the width of one patch in pixels. Larger numbers scale up this StarSqueak world, but numbers larger than 2 or 3 result in a blocky look. The useful range is 1 to 10."

	pixelsPerPatch := (anInteger rounded max: 1) min: 10.
! !


!StarSqueakMorph methodsFor: 'drawing' stamp: 'jm 3/3/2001 12:55'!
areasRemainingToFill: aRectangle
	"Drawing optimization. Since I completely fill my bounds with opaque pixels, this method tells Morphic that it isn't necessary to draw any morphs covered by me."
	
	^ aRectangle areasOutside: self bounds
! !

!StarSqueakMorph methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:26'!
display
	"Display this world on the Display. Used for debugging."

	| c |
	c := FormCanvas extent: (dimensions * pixelsPerPatch) depth: 32.
	c := c copyOffset: bounds origin negated.
	self drawOn: c.
	c form display.

! !

!StarSqueakMorph methodsFor: 'drawing' stamp: 'sd 11/20/2005 21:26'!
drawOn: aCanvas
	"Display this StarSqueak world."

	| tmpForm bitBlt t |
	"copy the patches form"
	tmpForm := patchForm deepCopy.

	"draw patchVariableToDisplay on top of tmpForm as translucent color"
	self displayPatchVariableOn: tmpForm color: Color yellow shift: logPatchVariableScale.

	"draw turtles on top of tmpForm"
	bitBlt := (BitBlt toForm: tmpForm)
		clipRect: tmpForm boundingBox;
		combinationRule: Form over.
	1 to: turtles size do: [:i |
		t := turtles at: i.
		bitBlt
			destX: (pixelsPerPatch * t x truncated)
			destY: (pixelsPerPatch * t y truncated)
			width: pixelsPerPatch
			height: pixelsPerPatch.
		bitBlt
			fillColor: t color;
			copyBits].

	"display tmpForm"
	aCanvas paintImage: tmpForm at: bounds origin.

! !


!StarSqueakMorph methodsFor: 'geometry' stamp: 'jm 2/7/2001 13:31'!
extent: aPoint
	"Do nothing; my extent is determined by my StarSqueak world dimensions and pixelsPerPatch."
! !


!StarSqueakMorph methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initialize

	super initialize.
	dimensions := self starSqueakDimensions.  "dimensions of this StarSqueak world in patches"
	pixelsPerPatch := 2.
	super extent: dimensions * pixelsPerPatch.
	self evaporationRate: 6.
	self diffusionRate: 1.
	self clearAll.  "be sure this is done once in case setup fails to do it"
	self setup.
! !


!StarSqueakMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'start' translated action: #startRunning.
	aCustomMenu add: 'stop' translated action: #stopRunning.
	aCustomMenu add: 'step' translated action: #singleStep.
	aCustomMenu add: 'start over' translated action: #startOver.
	aCustomMenu addLine.
	aCustomMenu add: 'full speed' translated action: #fullSpeed.
	aCustomMenu add: 'slow speed' translated action: #slowSpeed.
	aCustomMenu addLine.
	aCustomMenu add: 'set scale' translated action: #setScale.
	aCustomMenu add: 'make parameter slider' translated action: #makeParameterSlider.
! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
fullSpeed
	"Run at maximum speed."

	stepTime := 0.
! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 22:53'!
makeParameterSlider
	| menu choice s |
	menu := CustomMenu new title: 'Parameter?'.
	self sliderParameters do: [:rec | menu add: rec first action: rec].
	choice := menu startUp.
	choice ifNil: [^self].
	s := self 
				newSliderForParameter: choice first
				target: self
				min: (choice second)
				max: (choice third)
				description: (choice fourth).
	self world activeHand attachMorph: s! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
setScale

	| reply |
	reply := FillInTheBlank
		request: 'Set the number of pixels per patch (a number between 1 and 10)?'
		 initialAnswer: pixelsPerPatch printString.
	reply isEmpty ifTrue: [^ self].
	pixelsPerPatch := ((reply asNumber rounded) max: 1) min: 10.
	self changed.
	super extent: dimensions * pixelsPerPatch.
	self clearAll.  "be sure this is done once in case setup fails to do it"
	self setup.
	self startOver.
! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'jm 2/5/2001 17:52'!
singleStep
	"Take one step and redisplay."

	self oneStep.
	self changed.

! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'jm 2/7/2001 19:07'!
sliderParameters
	"Answer a list of parameters that the user can change via a slider. Each parameter is described by an array of: <name> <min value> <max value> <balloon help string>."

	^ #((evaporationRate 0 40
			'The rate at which chemicals evaporate in this world. Larger numbers give faster evaporation.')
		(diffusionRate 0 5
			'The rate of chemical diffusion. Larger numbers give quicker diffusion.'))
! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
slowSpeed
	"Run at slow speed."

	stepTime := 250.
! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'jm 2/6/2001 22:04'!
startOver
	"Restart this StarSqueak simulation from its initial conditions."

	self clearAll.
	self setup.
	self changed.
! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
startRunning
	"Start running this StarSqueak simulation."

	running := true.
! !

!StarSqueakMorph methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
stopRunning
	"STop running this StarSqueak simulation."

	running := false.
! !


!StarSqueakMorph methodsFor: 'parts bin' stamp: 'sw 7/13/2001 22:22'!
initializeToStandAlone
	self initialize.
	self startRunning! !


!StarSqueakMorph methodsFor: 'patches' stamp: 'jm 3/8/2001 13:47'!
clearPatches
	"Clear patch colors, including turtle trails."

	patchForm fill: patchForm boundingBox fillColor: Color black.

! !

!StarSqueakMorph methodsFor: 'patches' stamp: 'jm 1/22/2001 16:52'!
createPatchVariable: patchVarName
	"Create a patch variable of the given name. It is initialized to a value of zero for every patch."

	patchVariables
		at: patchVarName
		put: (Bitmap new: (dimensions x * dimensions y) withAll: 0).
! !

!StarSqueakMorph methodsFor: 'patches' stamp: 'sd 11/20/2005 21:26'!
decayPatchVariable: patchVarName
	"Decay the values of the patch variable of the given name. That is, the value of each patch is replaced by a fraction of its former value, resulting in an expontial decay each patch's value over time. This can be used to model evaporation of a pheromone."

	| patchVar |
	patchVar := patchVariables at: patchVarName ifAbsent: [^ self].
	self primEvaporate: patchVar rate: scaledEvaporationRate.

! !

!StarSqueakMorph methodsFor: 'patches' stamp: 'sd 11/20/2005 21:26'!
diffusePatchVariable: patchVarName
	"Diffuse the patch variable of the given name."

	| v newV |
	diffusionRate = 0 ifTrue: [^ self].  "no diffusion"
	v := patchVariables at: patchVarName ifAbsent: [^ self].
	newV := Bitmap new: v size.
	self primDiffuseFrom: v
		to: newV
		width: dimensions x
		height: dimensions y
		delta: diffusionRate truncated.
	patchVariables at: patchVarName put: newV.
! !

!StarSqueakMorph methodsFor: 'patches' stamp: 'sd 11/20/2005 21:26'!
patchesDo: aBlock
	"Evaluate the given block for every patch in this world."

	| patch |
	patch := StarSqueakPatch new world: self.
	0 to: dimensions y - 1 do: [:y |
		patch y: y.
		0 to: dimensions x - 1 do: [:x |
			patch x: x.
			aBlock value: patch]].
! !


!StarSqueakMorph methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
addTurtleDemon: aSelector
	"Add the given selector to the list of selectors sent to every turtle on every step."

	turtleDemons := turtleDemons copyWith: aSelector.
! !

!StarSqueakMorph methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
addWorldDemon: aSelector
	"Add the given selector to the list of selectors sent to the world on every step."

	worldDemons := worldDemons copyWith: aSelector.
! !

!StarSqueakMorph methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
clearAll
	"Reset this StarSqueak world. All patch variables are cleared, all turtles are removed, and all demons are turned off."

	patchVariables := Dictionary new: 10.
	patchVariableToDisplay := nil.
	logPatchVariableScale := 0.
	patchForm := Form extent: (dimensions * pixelsPerPatch) depth: 32.
	self createPatchFormGetterAndSetter.
	patchVarDisplayForm := nil.
	self clearPatches.
	turtles := #().
	turtleDemons := #().
	worldDemons := #().
	sniffRange := 1.
	lastTurtleID := -1.
	generation := 0.
	running := false.
	stepTime := 0.  "full speed"
	turtlesAtPatchCache := nil.
	turtlesAtPatchCacheValid := false.
! !

!StarSqueakMorph methodsFor: 'setup' stamp: 'jm 1/24/2001 12:42'!
displayPatchVariable: patchVarName
	"Make this StarSqueak world display the patch variable of the given name. Only one patch variable can be displayed at any given time."

	self displayPatchVariable: patchVarName logScale: -2.
! !

!StarSqueakMorph methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
displayPatchVariable: patchVarName logScale: logBase2OfScaleFactor
	"Make this StarSqueak world display the patch variable of the given name. Only one patch variable can be displayed at any given time. Values are scaled by 2^logBase2OfScaleFactor. For example, a value of 5 scales by 32 and a value of -2 scales by 1/4."

	(patchVariables includesKey: patchVarName) ifFalse: [
		patchVariableToDisplay := nil.
		patchVarDisplayForm := nil.
		^ self].
	patchVariableToDisplay := patchVarName.
	patchVarDisplayForm := Form extent: (dimensions * pixelsPerPatch) depth: 32.
	logPatchVariableScale := logBase2OfScaleFactor.
	self clearPatches.

! !

!StarSqueakMorph methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
random: range
	"Answer a random integer between 0 and range."

	RandomSeed := ((RandomSeed * 1309) + 13849) bitAnd: 65535.
	^ (RandomSeed * (range + 1)) // 65536
! !

!StarSqueakMorph methodsFor: 'setup' stamp: 'jm 1/23/2001 07:24'!
setup
	"Subclasses should override this to setup the initial conditions of this StarSqueak world. The method should start with 'self clearAll'."

	self clearAll.
! !

!StarSqueakMorph methodsFor: 'setup' stamp: 'jm 3/3/2001 12:54'!
starSqueakDimensions
	"Answer the dimensions of this StarSqueak simulation. Subclasses can override this method to define their own world size."

	^ 100@100
! !


!StarSqueakMorph methodsFor: 'stepping and presenter' stamp: 'dgd 2/21/2003 22:53'!
oneStep
	"Perform one step of the StarSqueak world. Execute all turtle and world demons."

	"run demons in random order and increment the generation counter"

	| currentTurtles |
	turtleDemons notEmpty 
		ifTrue: 
			["Note: Make a copy of turtles list that won't change if turtles are created/deleted."

			currentTurtles := turtles copy.
			turtleDemons shuffled 
				do: [:sel | 1 to: currentTurtles size do: [:i | (currentTurtles at: i) perform: sel]]].
	worldDemons shuffled do: [:sel | self perform: sel].
	generation := generation + 1.
	turtlesAtPatchCacheValid := false! !

!StarSqueakMorph methodsFor: 'stepping and presenter' stamp: 'jm 1/26/2001 17:21'!
step

	running ifTrue: [
		self oneStep.
		self changed].
! !


!StarSqueakMorph methodsFor: 'testing' stamp: 'jm 1/22/2001 17:52'!
stepTime

	^ stepTime
! !


!StarSqueakMorph methodsFor: 'turtles' stamp: 'jm 3/12/2001 09:44'!
makeTurtles: count
	"Create the given number of generic turtles."

	self makeTurtles: count class: StarSqueakTurtle.
! !

!StarSqueakMorph methodsFor: 'turtles' stamp: 'sd 11/20/2005 21:26'!
makeTurtles: count class: turtleClass
	"Create the given number of turtles of the given turtle class."

	turtles := turtles,
		((1 to: count) collect: [:i |
			turtleClass new
				initializeWorld: self
				who: (lastTurtleID := lastTurtleID + 1)]).
	self changed.
! !

!StarSqueakMorph methodsFor: 'turtles' stamp: 'jm 1/28/2001 10:55'!
turtles

	^ turtles
! !

!StarSqueakMorph methodsFor: 'turtles' stamp: 'dgd 2/21/2003 22:53'!
turtlesAtX: x y: y do: aBlock 
	"Evaluate the given block for each turtle at the given location."

	| t |
	t := self firstTurtleAtX: x y: y.
	[t isNil] whileFalse: 
			[aBlock value: t.
			t := t nextTurtle]! !

!StarSqueakMorph methodsFor: 'turtles' stamp: 'jm 3/3/2001 18:08'!
turtlesDo: aBlock
	"Evaluate the given block for every turtle. For example:
		w turtlesDo: [:t | t forward: 1]
	will tell every turtle to go forward by one turtle step."

	turtles do: aBlock.
	self changed.
! !


!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
createPatchFormGetterAndSetter
	"Create BitBlt's for getting and setting patch colors."

	patchColorGetter := BitBlt bitPeekerFromForm: patchForm.
	patchColorSetter :=
		(BitBlt toForm: patchForm)
			combinationRule: Form over;
			clipRect: patchForm boundingBox;
			width: pixelsPerPatch;
			height: pixelsPerPatch.
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
deleteTurtle: aTurtle
	"Delete the given turtle from this world."

	turtles := turtles copyWithout: aTurtle.
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'jm 1/22/2001 16:58'!
dimensions

	^ dimensions
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 09:32'!
displayPatchVariableOn: aForm color: aColor shift: shiftAmount 
	"Display patchVariableToDisplay in the given color. The opacity (alpha) of of each patch is determined by the patch variable value for that patch and shiftAmount. If shiftAmount is zero, the source value is unscaled. Positive shiftAmount values result in right shifting the source value by the given number of bits (That is, multiplying by 2^N. Negative values perform right shifts, dividing by 2^N)."

	| patchVar bitBlt w rowOffset alpha |
	patchVariableToDisplay ifNil: [^self].
	patchVar := patchVariables at: patchVariableToDisplay ifAbsent: [^self].

	"set up the BitBlt"
	bitBlt := (BitBlt toForm: aForm)
				sourceRect: (0 @ 0 extent: pixelsPerPatch);
				fillColor: aColor;
				combinationRule: 30.
	w := dimensions x.
	0 to: dimensions y - 1
		do: 
			[:y | 
			rowOffset := y * w + 1.
			0 to: w - 1
				do: 
					[:x | 
					alpha := (patchVar at: rowOffset + x) bitShift: shiftAmount.
					alpha := alpha min: 255.
					alpha > 1 
						ifTrue: 
							["if not transparent, fill using the given alpha"

							bitBlt destOrigin: (x * pixelsPerPatch) @ (y * pixelsPerPatch).
							bitBlt copyBitsTranslucent: alpha]]]! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
firstTurtleAtX: xPos y: yPos 

	| w t x y index |
	"create turtlesAtPatchCache if necessary"
	turtlesAtPatchCache ifNil: [
		turtlesAtPatchCache := Array new: (dimensions x * dimensions y) withAll: nil.
		turtlesAtPatchCacheValid := false].

	w := dimensions y.
	turtlesAtPatchCacheValid ifFalse: [
		turtlesAtPatchCache atAllPut: nil.
		"cache not yet computed for this step; make linked list of turtles for each patch"
		1 to: turtles size do: [:i |
			t := turtles at: i.
			x := t x truncated.
			y := t y truncated.
			index := (w * y) + x + 1.
			t nextTurtle: (turtlesAtPatchCache at: index).
			turtlesAtPatchCache at: index put: t].
		turtlesAtPatchCacheValid := true].

	x := xPos truncated.
	y := yPos truncated.
	index := (w * y) + x + 1.
	^ turtlesAtPatchCache at: index
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
getPatchBrightnessAtX: x y: y
	"Answer the brightness of the patch at the given location, a number from 0 to 100."

	| c |
	c := self getPatchColorAtX: x y: y.
	^ (c brightness * 100.0) rounded
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
getPatchColorAtX: x y: y
	"Answer the color of the patch at the given location."

	| pixel |
	pixel := patchColorGetter pixelAt:
		(pixelsPerPatch * x truncated)@(pixelsPerPatch * y truncated).
	^ Color colorFromPixelValue: pixel depth: patchForm depth
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
getPatchVariable: patchVarName atX: xPos y: yPos
	"Answer the value of the given patch variable at the given turtle. Answer zero if the turtle is out of bounds."

	| x y i |
	x := xPos truncated.
	y := yPos truncated.
	((x < 0) or: [y < 0]) ifTrue: [^ 0].
	((x >= dimensions x) or: [y >= dimensions y]) ifTrue: [^ 0].
	i := ((y * dimensions x) + x) truncated + 1.
	^ (patchVariables at: patchVarName ifAbsent: [^ 0]) at: i
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
incrementPatchVariable: patchVarName atX: xPos y: yPos by: amount
	"Increment the value of the given patch variable at the given location by the given amount. Do nothing if the location is out of bounds."

	| x y i var |
	x := xPos truncated.
	y := yPos truncated.
	((x < 0) or: [y < 0]) ifTrue: [^ self].
	((x >= dimensions x) or: [y >= dimensions y]) ifTrue: [^ self].
	i := ((y * dimensions x) + x) truncated + 1.
	var := patchVariables at: patchVarName ifAbsent: [^ self].
	var at: i put: ((var at: i) + amount).
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
newSliderForParameter: parameter target: target min: min max: max description: description

	| c slider r s |
	c := (AlignmentMorph newColumn)
		color: Color lightBlue;
		borderWidth: 2;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		useRoundedCorners.
	slider := SimpleSliderMorph new
		color: (Color r: 0.065 g: 0.548 b: 0.645);
		extent: 150@2;
		target: target;
		actionSelector: (parameter, ':') asSymbol;
		minVal: min;
		maxVal: max;
		adjustToValue: (target perform: parameter asSymbol).
	c addMorphBack: slider.
	r := (AlignmentMorph newRow)
		color: Color lightBlue;
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	s := StringMorph new contents: parameter, ': '.
	r addMorphBack: s.
	s := UpdatingStringMorph new
		target: target;
		getSelector: parameter asSymbol;
		putSelector: (parameter, ':') asSymbol;
		floatPrecision: (10.0 raisedTo: (((max - min) / 150.0) log: 10) floor);
		step.
	r addMorphBack: s.
	c addMorphBack: r.
	c setBalloonText: description.
	^ c
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'jm 1/18/2001 21:58'!
patchVariable: patchVarName ifAbsent: aBlock
	"Answer the patch variable array of the given name. If no such patch variables exists, answer the result of evaluating the given block."

	^ patchVariables at: patchVarName ifAbsent: aBlock
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
replicateTurtle: aTurtle
	"Create an exact copy of the given turtle and add it to this world."

	| newTurtle |
	newTurtle := aTurtle clone who: (lastTurtleID := lastTurtleID + 1).
	turtles := turtles copyWith: newTurtle.
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 09:34'!
setPatchBrightnessAtX: x y: y to: percent 
	"Set the brightness of the patch at the given location to the given level, where 0 is black and 100 is full brightness."

	| c brightness |
	c := self getPatchColorAtX: x y: y.
	brightness := percent / 100.0.
	brightness := brightness max: 0.03125.
	self 
		setPatchColorAtX: x
		y: y
		to: (Color 
				h: c hue
				s: c saturation
				v: brightness)! !

!StarSqueakMorph methodsFor: 'private' stamp: 'jm 2/7/2001 07:20'!
setPatchColorAtX: x y: y to: aColor
	"Paint the patch at the given location with the given color."

	patchColorSetter
		fillColor: aColor;
		destX: (pixelsPerPatch * x truncated);
		destY: (pixelsPerPatch * y truncated);
		copyBits.
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
setPatchVariable: patchVarName atX: xPos y: yPos to: newValue
	"Set the value of the given patch variable below the given turtle to the given value. Do nothing if the turtle is out of bounds."

	| x y i var |
	x := xPos truncated.
	y := yPos truncated.
	((x < 0) or: [y < 0]) ifTrue: [^ self].
	((x >= dimensions x) or: [y >= dimensions y]) ifTrue: [^ self].
	i := ((y * dimensions x) + x) truncated + 1.
	var := patchVariables at: patchVarName ifAbsent: [^ self].
	var at: i put: newValue.
! !

!StarSqueakMorph methodsFor: 'private' stamp: 'sd 11/20/2005 21:26'!
sumPatchVariable: patchVarName neighborsAtX: xPos y: yPos
	"Answer the sum of the given patch variable for the eight neighbors of the patch at the given location. Answer zero if the location is out of bounds."

	| patchVar x y w h xLeft xRight rowOffset sum |
	patchVar := patchVariables at: patchVarName ifAbsent: [^ 0].
	x := xPos truncated.
	y := yPos truncated.
	w := dimensions x.
	h := dimensions y.
	((x < 0) or: [y < 0]) ifTrue: [^ 0].
	((x >= w) or: [y >= h]) ifTrue: [^ 0].
	xLeft := (x - 1) \\ w.  "column before x, wrapped"
	xRight := (x + 1) \\ w.  "column after x, wrapped"
	rowOffset := y * w.
	sum :=
		(patchVar at: rowOffset + xLeft) +
		(patchVar at: rowOffset + xRight).
	rowOffset := ((y - 1) \\ h) * w.  "row above y, wrapped"
	sum := sum +
		(patchVar at: rowOffset + xLeft) +
		(patchVar at: rowOffset + x) +
		(patchVar at: rowOffset + xRight).
	rowOffset := ((y + 1) \\ h) * w.  "row below y, wrapped"
	sum := sum +
		(patchVar at: rowOffset + xLeft) +
		(patchVar at: rowOffset + x) +
		(patchVar at: rowOffset + xRight).
	^ sum

! !

!StarSqueakMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 09:36'!
uphillOf: patchVarName forTurtle: aTurtle 
	"Answer the heading the points in the direction of increasing value for the given patch variable. If there is no gradient, or if the turtle is outside the world bounds, answer the turtles current heading."

	| patchVar turtleX turtleY startX endX startY endY maxVal rowOffset thisVal maxValX maxValY |
	patchVar := patchVariables at: patchVarName ifAbsent: [^aTurtle heading].
	turtleX := aTurtle x truncated + 1.
	turtleY := aTurtle y truncated + 1.
	turtleX := turtleX max: 1.
	turtleY := turtleY max: 1.
	turtleX := turtleX min: dimensions x.
	turtleY := turtleY min: dimensions y.
	startX := turtleX - sniffRange max: 1.
	endX := turtleX + sniffRange min: dimensions x.
	startY := turtleY - sniffRange max: 1.
	endY := turtleY + sniffRange min: dimensions y.
	maxVal := patchVar at: (turtleY - 1) * dimensions x + turtleX.
	maxValX := nil.
	startY to: endY
		do: 
			[:y | 
			rowOffset := (y - 1) * dimensions x.
			startX to: endX
				do: 
					[:x | 
					thisVal := patchVar at: rowOffset + x.
					thisVal > maxVal 
						ifTrue: 
							[maxValX := x.
							maxValY := y.
							maxVal := thisVal]]].
	nil = maxValX ifTrue: [^aTurtle heading].
	^(((maxValX - turtleX) @ (maxValY - turtleY)) degrees + 90.0) \\ 360.0! !


!StarSqueakMorph methodsFor: 'private-primitives' stamp: 'jdl 3/28/2003 09:46'!
primDiffuseFrom: srcBitmap to: dstBitmap width: width height: height delta: delta 
	"Diffuse the integer values of the source patch variable Bitmap into the output Bitmap. Each cell of the output is the average of the NxN area around it in the source, where N = (2 * delta) + 1."

	| area startY endY startX endX sum rowStart |
	<primitive: 'primitiveDiffuseFromToWidthHeightDelta' module: 'StarSqueakPlugin'>
	area := (2 * delta + 1) * (2 * delta + 1).
	1 to: height
		do: 
			[:y | 
			startY := y - delta.
			startY := startY max: 1.
			endY := y + delta.
			endY := endY min: height.
			1 to: width
				do: 
					[:x | 
					startX := x - delta.
					startX := startX max: 1.
					endX := x + delta.
					endX := endX min: width.
					sum := 0.
					startY to: endY
						do: 
							[:y2 | 
							rowStart := (y2 - 1) * width.
							startX to: endX do: [:x2 | sum := sum + (srcBitmap at: rowStart + x2)]].
					dstBitmap at: (y - 1) * width + x put: sum // area]]! !

!StarSqueakMorph methodsFor: 'private-primitives' stamp: 'jm 3/12/2001 09:45'!
primEvaporate: aBitmap rate: rate
	"Evaporate the integer values of the source Bitmap at the given rate, an integer between 0 and 1024, where 1024 is a scale factor of 1.0 (i.e., no evaporation). That is, replace each integer element v with (rate * v) / 1024."

	<primitive: 'primitiveEvaporateRate' module: 'StarSqueakPlugin'>
	1 to: aBitmap size do: [:i |
		aBitmap at: i put: (((aBitmap at: i) * rate) bitShift: -10)].
! !

!StarSqueakMorph methodsFor: 'private-primitives' stamp: 'sd 11/20/2005 21:26'!
primMapFrom: srcBitmap to: dstBitmap width: w height: h patchSize: patchSize rgbFlags: rgbFlags shift: shiftAmount 
	"Map values in the source bitmap (interpreted as unsigned 32-bit integers) to 2x2 patches of color in the destination bitmap. The color brightness level is determined by the source value and the color hue is determined by the bottom three bits of the rgbFlags value. For example, if rgbFlags is 1, you get shades of blue, if it is 6 you get shades of yellow, and if it is 7, you get shades of gray. The shiftAmount is used to scale the source data values by a power of two. If shiftAmount is zero, the data is unscaled. Positive shiftAmount values result in right shifting the source data by the given number of bits (multiplying by 2^N, negative values perform right shifts (dividing by 2^N). The width parameter gives the width of the Form that owns the destination bitmap."

	| rgbMult srcIndex level pixel offset |
	<primitive: 'primitiveMapFromToWidthHeightPatchSizeRgbFlagsShift' module: 'StarSqueakPlugin'>
	rgbMult := 0.
	(rgbFlags bitAnd: 4) > 0 ifTrue: [rgbMult := rgbMult + 65536].
	(rgbFlags bitAnd: 2) > 0 ifTrue: [rgbMult := rgbMult + 256].
	(rgbFlags bitAnd: 1) > 0 ifTrue: [rgbMult := rgbMult + 1].
	srcIndex := 0.
	0 to: h // patchSize - 1
		do: 
			[:y | 
			0 to: w // patchSize - 1
				do: 
					[:x | 
					level := (srcBitmap at: (srcIndex := srcIndex + 1)) bitShift: shiftAmount.
					level := level min: 255.
					pixel := level <= 0 
								ifTrue: 
									["non-transparent black"

									1]
								ifFalse: [level * rgbMult].

					"fill a patchSize x patchSize square with the pixel value"
					offset := (y * w + x) * patchSize.
					offset to: offset + ((patchSize - 1) * w)
						by: w
						do: 
							[:rowStart | 
							rowStart + 1 to: rowStart + patchSize
								do: [:dstIndex | dstBitmap at: dstIndex put: pixel]]]]! !

!StarSqueakMorph methodsFor: 'private-primitives' stamp: 'sd 11/20/2005 21:26'!
testDiffusePrim
	"This test should diffuse the initial value in the center cell so that each cell has 1000."
	"StarSqueakMorph new testDiffusePrim"

	| src dst |
	src := Bitmap new: 49.
	src at: 25 put: 49000.
	dst := Bitmap new: 49.
	self primDiffuseFrom: src to: dst width: 7 height: 7 delta: 3.
	^ dst asArray
! !

!StarSqueakMorph methodsFor: 'private-primitives' stamp: 'sd 11/20/2005 21:26'!
testEvaporatePrim
	"This test should result in reducing each element of the array to 75% of its initial value."
	"StarSqueakMorph new testEvaporatePrim"

	| data |
	data := Bitmap new: 10.
	1 to: data size do: [:i | data at: i put: (10000 * i)].
	self primEvaporate: data rate: (75 * 1024) // 100.
	^ data asArray

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StarSqueakMorph class
	instanceVariableNames: ''!

!StarSqueakMorph class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:26'!
initialize
	"StarSqueakMorph initialize"

	RandomSeed := 17.
! !
Object subclass: #StarSqueakPatch
	instanceVariableNames: 'world worldWidth worldHeight x y'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Kernel'!
!StarSqueakPatch commentStamp: '<historical>' prior: 0!
I represent a patch in a StarSqueak world. Patch objects are not retained, but are created as needed, such as in patchesDo:.
!


!StarSqueakPatch methodsFor: 'accessing' stamp: 'jm 1/27/2001 08:59'!
asPoint

	^ x @ y
! !

!StarSqueakPatch methodsFor: 'accessing' stamp: 'jm 1/19/2001 08:28'!
world

	^ world
! !

!StarSqueakPatch methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
world: aStarSqueakMorph
	"Set the world for this patch. Also record the world's width and height."

	| dims |
	world := aStarSqueakMorph.
	dims := world dimensions.
	worldWidth := dims x.
	worldHeight := dims y.
! !

!StarSqueakPatch methodsFor: 'accessing' stamp: 'jm 1/18/2001 21:27'!
x

	^ x
! !

!StarSqueakPatch methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
x: anInteger

	x := anInteger.
! !

!StarSqueakPatch methodsFor: 'accessing' stamp: 'jm 1/18/2001 21:27'!
y

	^ y
! !

!StarSqueakPatch methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
y: anInteger

	y := anInteger.
! !


!StarSqueakPatch methodsFor: 'geometry' stamp: 'jm 1/28/2001 15:27'!
isBottomEdge

	^ y = (worldHeight - 1)
! !

!StarSqueakPatch methodsFor: 'geometry' stamp: 'jm 1/28/2001 15:27'!
isLeftEdge

	^ x = 0
! !

!StarSqueakPatch methodsFor: 'geometry' stamp: 'jm 1/28/2001 15:27'!
isRightEdge

	^ x = (worldWidth - 1)
! !

!StarSqueakPatch methodsFor: 'geometry' stamp: 'jm 1/28/2001 15:27'!
isTopEdge

	^ y = 0
! !


!StarSqueakPatch methodsFor: 'neighborhood' stamp: 'jm 1/28/2001 15:06'!
neighborE
	"Answer the neightboring patch directly south of (below) this patch."

	^ self clone x: ((x + 1) \\ worldWidth)
! !

!StarSqueakPatch methodsFor: 'neighborhood' stamp: 'jm 1/28/2001 15:06'!
neighborN
	"Answer the neightboring patch directly north of (above) this patch."

	^ self clone y: ((y - 1) \\ worldHeight)
! !

!StarSqueakPatch methodsFor: 'neighborhood' stamp: 'hh 8/26/2001 17:03'!
neighborNE
	"Answer the neightboring patch directly south of (below) this patch."

	^ self clone
		x: ((x + 1) \\ worldWidth);
		y: ((y - 1) \\ worldHeight)
! !

!StarSqueakPatch methodsFor: 'neighborhood' stamp: 'hh 8/26/2001 17:03'!
neighborNW
	"Answer the neightboring patch directly south of (below) this patch."

	^ self clone
		x: ((x - 1) \\ worldWidth);
		y: ((y - 1) \\ worldHeight)
! !

!StarSqueakPatch methodsFor: 'neighborhood' stamp: 'jm 1/28/2001 15:06'!
neighborS
	"Answer the neightboring patch directly south of (below) this patch."

	^ self clone y: ((y + 1) \\ worldHeight)
! !

!StarSqueakPatch methodsFor: 'neighborhood' stamp: 'hh 8/26/2001 17:03'!
neighborSE
	"Answer the neightboring patch directly south of (below) this patch."

	^ self clone
		x: ((x + 1) \\ worldWidth);
		y: ((y + 1) \\ worldHeight)
! !

!StarSqueakPatch methodsFor: 'neighborhood' stamp: 'hh 8/26/2001 17:04'!
neighborSW
	"Answer the neightboring patch directly south of (below) this patch."

	^ self clone
		x: ((x - 1) \\ worldWidth);
		y: ((y + 1) \\ worldHeight)
! !

!StarSqueakPatch methodsFor: 'neighborhood' stamp: 'jm 1/28/2001 15:06'!
neighborW
	"Answer the neightboring patch directly south of (below) this patch."

	^ self clone x: ((x - 1) \\ worldWidth)
! !


!StarSqueakPatch methodsFor: 'patch color' stamp: 'jm 1/24/2001 15:57'!
brightness
	"Answer the brightness of this patch, a number from 0 to 100."

	^ world getPatchBrightnessAtX: x y: y
! !

!StarSqueakPatch methodsFor: 'patch color' stamp: 'jm 1/24/2001 15:56'!
brightness: percent
	"Set the brightness of this patch to the given level, where 0 is nearly black and 100 is full brightness."

	world setPatchBrightnessAtX: x y: y to: percent.
! !

!StarSqueakPatch methodsFor: 'patch color' stamp: 'jm 1/24/2001 15:58'!
color
	"Answer the color of this patch."

	^ world getPatchColorAtX: x y: y
! !

!StarSqueakPatch methodsFor: 'patch color' stamp: 'jm 1/24/2001 15:58'!
color: aColor
	"Paint this patch the given color."

	world setPatchColorAtX: x y: y to: aColor.
! !


!StarSqueakPatch methodsFor: 'patch variables' stamp: 'jm 1/18/2001 21:31'!
distanceTo: aPoint
	"Answer the distance from this patch to the given point."

	^ ((x - aPoint x) squared + (y - aPoint y) squared) sqrt
! !

!StarSqueakPatch methodsFor: 'patch variables' stamp: 'sd 11/20/2005 21:26'!
get: patchVarName
	"Answer the value of the given patch variable for this patch."

	| patchVar |
	patchVar := world patchVariable: patchVarName ifAbsent: [^ 0].
	^ patchVar at: (y * world dimensions x) + x + 1
! !

!StarSqueakPatch methodsFor: 'patch variables' stamp: 'sd 11/20/2005 21:26'!
set: patchVarName to: newValue
	"Set the value of the given patch variable for this patch to the given value."

	| patchVar |
	patchVar := world patchVariable: patchVarName ifAbsent: [^ self].
	patchVar at: (y * world dimensions x) + x + 1 put: newValue.
! !
StarSqueakMorph subclass: #StarSqueakSlimeMold
	instanceVariableNames: 'cellCount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!StarSqueakSlimeMold methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initialize

	cellCount := 200.
	super initialize.
! !


!StarSqueakSlimeMold methodsFor: 'menu' stamp: 'jm 2/7/2001 19:51'!
sliderParameters
	"Answer a list of parameters that the user can change via a slider. Each parameter is described by an array of: <name> <min value> <max value> <balloon help string>."

	^ super sliderParameters, #(
		(cellCount 50 2000 'The number of slime mold cells.'))
! !


!StarSqueakSlimeMold methodsFor: 'other' stamp: 'jm 1/19/2001 18:36'!
diffusePheromone

	self diffusePatchVariable: 'pheromone'.
! !

!StarSqueakSlimeMold methodsFor: 'other' stamp: 'jm 1/19/2001 18:36'!
evaporatePheromone

	self decayPatchVariable: 'pheromone'.
! !


!StarSqueakSlimeMold methodsFor: 'parameters' stamp: 'jm 2/7/2001 19:28'!
cellCount

	^ cellCount
! !

!StarSqueakSlimeMold methodsFor: 'parameters' stamp: 'sd 11/20/2005 21:26'!
cellCount: aNumber

	cellCount := aNumber asInteger.

! !


!StarSqueakSlimeMold methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
setup

	self clearAll.
	self makeTurtles: cellCount class: SlimeMoldTurtle.
	self createPatchVariable: 'pheromone'.  "emitted by slime mold cells"
	turtleDemons := #(dropPheromone followPheromone breakLoose).
	worldDemons := #(evaporatePheromone diffusePheromone).
	self displayPatchVariable: 'pheromone'.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StarSqueakSlimeMold class
	instanceVariableNames: ''!

!StarSqueakSlimeMold class methodsFor: 'parts bin' stamp: 'sw 10/24/2001 16:36'!
descriptionForPartsBin
	"Answer a description of the receiver for use in a parts bin"

	^ self partName:	'SlimeMold'
		categories:		#('StarSqueak')
		documentation:	'A slime-mold simulation using StarSqueak'
		sampleImageForm: (Form
	extent: 92@96
	depth: 8
	fromArray: #( 673720360 676154664 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1398364499 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1396729208 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 1294477352 674900008 673720360 673720360 673720360 673720360 673720360 673729869 1918072946 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 1296902184 674900008 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 1296902184 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 673720360 673720360 673720360 673720360 1296921202 1920103026 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296911693 1294477352 673720360 673720360 673720360 673720360 673720397 1296911693 1296911693 1296902184 673720360 673720360 673720397 1296921239 2021169010 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296911693 1294477352 673720360 673720360 673720360 673720360 673720397 1296921202 1917668685 1296911656 673720360 673720360 673720397 1299346040 1701148786 1917668685 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729832 673720360 673720360 673720360 673720360 673720360 673729869 1299355580 2543284850 1296911656 673720360 673720360 673720397 1296921276 2122234994 1917668685 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1920121883 3784808306 1296911656 673720360 673720360 673720397 1296921202 2543294322 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1922530886 3787233138 1296911656 673720360 673720360 673720397 1296911730 1920103026 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1918442267 3784808306 1296911656 673720360 673720360 673720397 1296911693 1920093517 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1299365052 3164041842 1296911656 673720360 673720360 673720397 1296911693 1296911693 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296902184 673720360 673720360 673720360 673720360 673720397 1299346034 2540859981 1296911656 673720360 673720360 673720397 1296911693 1296911693 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 1294477352 673720360 673720360 673720360 673720397 1296911730 1920093517 1296911656 673720360 673720360 673729869 1296911693 1296911693 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 1296902184 673720360 673720360 673720360 673720360 1296911693 1296911693 1296911656 673720360 673720360 676154701 1296911693 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1299336525 1296911693 673720360 673720360 673720360 673720360 1296911693 1296911693 1296911656 673720360 673720360 1296911693 1296911693 1294477352 673720360 1179002920 673720360 673720360 673720360 673720360 673720360 673720360 1296911730 1920103026 1917668685 1296902184 673720360 673720360 673720360 676154701 1296911693 1296911656 673720360 673720397 1296911693 1179471181 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296921202 2543294359 1920093517 1296911693 1294477352 673720360 673720360 673729869 1296911693 1296911656 673720360 673720397 1296462450 1917668685 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296921177 1189199036 2540850509 1296911693 1296911656 673720360 673720360 673729869 1296911693 1296911693 673720360 673720397 1299346071 1917668685 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296921276 3779479228 2540859981 1296911693 1296911693 673720360 673720360 673729869 1296921202 1917668685 1294477352 673720397 1299334726 1179471181 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1299346108 1179050465 2543284850 1920103026 1917668685 1294477352 673720360 673729869 1299346034 1920093517 1294477352 673720397 1299346071 1917668685 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296921276 3779518908 2540860018 1920103001 1500663117 1294477352 673720360 673729869 1920112454 2540859981 1296902184 673720397 1296921202 1917668648 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296921239 3166485692 1920103026 1920104537 1501065805 1296902184 673720360 673729869 1922530886 2123854413 1296902184 673720360 1296911693 1296911656 673720360 673720360 975710248 673720360 673720360 673720360 673720360 673720360 673720397 1296921202 1920103026 1920093554 1920104549 1702392397 1296902184 673720360 673729869 1922530886 1503097421 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673721896 673720360 673720360 673720360 673720360 1296911693 1920103026 1296911693 1920103032 2020756813 1296902184 673720360 673729869 1920121945 2540859981 1294477352 673720360 673720360 673720360 673720360 774383656 673720360 673720360 673721896 673720360 673720360 673720360 673720360 676154701 1296911693 1296911693 1299346040 2020756813 1294477352 673720360 673729869 1299346034 1500663117 1294477352 673720360 673720360 673720360 673720360 774383656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 1296911693 1296911699 1397574989 1294477352 673720360 673729869 1296911693 877481293 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 774776872 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 1296911693 1296911693 673720360 673720360 673720397 1296911693 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 774776872 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1296902184 673720360 673720360 673720397 1296911693 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296911693 1296911693 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296911693 1296911693 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1299346034 1920102989 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1299355580 3164041842 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1922546845 2646382450 1296911656 673720360 673720360 673720360 674900008 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1924981019 454777202 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1920917787 454777202 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1920122044 3166466674 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1920103001 1180267085 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1299346034 1920093517 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911730 1296911693 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 1296911693 1294477352 673720360 673720360 673724968 673720360 673720397 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 1296911693 673720360 673720360 673720360 673720360 673720360 676154701 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 1296902184 673720360 673720360 673720360 673720360 673720360 1296911693 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296911693 1296911693 1296902184 673720360 673720360 673720360 673720360 673720397 1296921202 1499024717 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296911693 1296911693 1294477352 673720360 673720360 673720360 673720360 673720397 1296921239 2540850509 1294477352 673720360 673720360 673720360 673720360 675686440 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 1296911693 1294477352 673720360 673720360 673720360 673720360 673729869 1296914758 1180257613 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296462450 1917668685 1294477352 673720360 673720360 673720360 673720360 673729869 1299346009 1500663117 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1920112535 2540850509 1294477352 673720360 673720360 673720360 673720360 676154701 1296921202 1920093517 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1920112454 2539205709 1294477352 673720360 673720360 673720360 673720360 676154701 1296921202 1917668685 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1922516550 3161607501 1294477352 673720360 673720360 673720360 673720360 1296911693 1299345997 1296911693 1294477352 673720360 673720360 673720360 673720390 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1299339609 2540850509 1294477352 673720360 673720360 673720360 673720360 1296911730 1920093517 1296911693 1294477352 673729832 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1299346009 1917668685 1294477352 673720360 673720360 673720360 673720360 1296921202 1500672589 1296911693 673720397 1296911693 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911705 1296911693 673720360 673720360 673720360 673720360 673720397 1296914839 1181905491 1397574989 673729869 1296911668 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296911693 1296911656 673720360 673720360 673720360 673720360 673720360 1296914802 1181896019 1397574952 676154701 1296921177 1917668685 1294477352 673720360 673720360 673720366 673720360 673720360 673720360 673720360 673720360 673720360 1296911693 1296902184 673720360 673720360 673720360 673720360 673720360 1296911730 1181896013 1296902184 673729869 1299346009 1397969741 1296902184 673720360 673720360 673720366 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 674900008 673720360 673720360 676154701 877481293 1294477352 673729869 1296914777 1397969741 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 674900008 673720360 673720360 673729869 1296911693 673720360 673720397 1296914802 1917668685 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296911705 1296911693 1294477352 673729844 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154676 1296911656 673720360 673729844 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 673720360 673720360 673720360 673720360 673729869 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 674113576 673720360 673720360 673720360 673720360 673720360 676154701 1296911693 1294477352 673720360 673720360 673720360 1296911693 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 674113576 673720360 673720360 673720360 673720360 673720360 1296911693 1296911693 1296902184 673724986 673720360 673720397 1296921202 1917668685 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296921202 1920103026 1296911656 673720360 673720360 673720397 1299355543 1917668685 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1299346071 2543294322 1917668648 673720360 673720360 673720397 1299334726 1498238285 673720360 673720360 673720360 673720360 673720360 673720360 673720378 975710248 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1920112572 3789676988 1917668648 673720360 673720360 673720397 1299339609 1917668685 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1922546913 3779518908 1920093480 673720360 673720360 673720397 1296921202 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1922516705 3779468121 1499024717 673720360 673720360 673720360 1296911693 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1922546913 3779518908 1920093480 673720360 673720360 673720360 676154701 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1920112572 3789676988 1917668648 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 674904616 673720397 1299334726 2543294322 1917668648 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1299346034 1920103026 1296911656 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673724986 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296911730 1920093517 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1294477352 673720360 673720360 673720360 1296911693 1296911693 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676148294 877471784 673720360 673720360 673720360 676154701 1296911693 673720360 673720360 673720360 675686440 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296911668 877013032 673720360 673720360 673720360 673720360 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296911693 1296902184 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720397 1296911656 673720360 673720360 676154701 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1397968205 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1497387853 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1497387853 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676154701 1397968205 1294477352 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673729869 1296911693 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1296911668 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720378 673720360 673720360 673720360 673720360 673720360 673720360 673721896 673720360 673720360 673720360)
	offset: 152@256)! !
StarSqueakMorph subclass: #StarSqueakTermites
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!StarSqueakTermites methodsFor: 'all' stamp: 'jm 1/24/2001 08:50'!
setupPatches
	"Create patch variables for sensing the nest and food caches. The nestScent variable is diffused so that it forms a 'hill' of scent over the entire world with its peak at the center of the nest. That way, the ants always know which way the nest is."

	self createPatchVariable: 'woodChips'.  "number of wood chips on patch"
	self displayPatchVariable: 'woodChips' logScale: 5.
	self patchesDo: [:p |
		(self random: 8) = 0
			ifTrue: [p set: 'woodChips' to: 1]
			ifFalse: [p set: 'woodChips' to: 0]].
! !

!StarSqueakTermites methodsFor: 'all' stamp: 'jm 1/28/2001 15:35'!
setupTurtles
	"Create an initialize my termites."

	self makeTurtles: 400 class: TermiteTurtle.
	self turtlesDo: [:t | t isCarryingChip: false].
! !


!StarSqueakTermites methodsFor: 'setup' stamp: 'sd 11/20/2005 21:26'!
setup

	self clearAll.
	self setupPatches.
	self setupTurtles.
	turtleDemons := #(walk wiggle lookForChip lookForPile).
! !
StarSqueakMorph subclass: #StarSqueakTrees
	instanceVariableNames: 'depth treeTypeSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!StarSqueakTrees methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initialize

	super initialize.
	depth := 8.
	treeTypeSelector := #tree1.
	self setup.
! !


!StarSqueakTrees methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'set tree depth' translated action: #setTreeDepth.
	aCustomMenu add: 'set tree type' translated action: #setTreeType.
! !

!StarSqueakTrees methodsFor: 'menu' stamp: 'rbb 3/1/2005 11:15'!
setTreeDepth

	| reply |
	reply := UIManager default
		request: 'Tree depth (a number between 1 and 12)?'
		initialAnswer: depth printString.
	reply isEmpty ifTrue: [^ self].
	depth := ((reply asNumber rounded) max: 1) min: 12.
	self startOver.
! !

!StarSqueakTrees methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
setTreeType

	| menu choice |
	menu := CustomMenu new title: 'Choose tree type:'.
	menu add: 'tree1' action: #tree1.
	menu add: 'tree2' action: #tree2.
	choice := menu startUp.
	choice ifNotNil: [
		treeTypeSelector := choice.
		self startOver].
! !


!StarSqueakTrees methodsFor: 'parts bin' stamp: 'sd 11/20/2005 21:26'!
initializeToStandAlone
	self initialize.
	treeTypeSelector := #tree2.
	self setup.  "Run earlier, but need to run again to get the #tree2 used"
	self startRunning! !


!StarSqueakTrees methodsFor: 'setup' stamp: 'jm 3/12/2001 09:59'!
setup

	self clearAll.
	self makeTurtles: 1 class: TreeTurtle.
	self turtlesDo: [:t |
		t goto: 50@90.
		t penDown.
		t color: Color red.
		t heading: 0.
		t length: 15.
		t depth: depth].
	self addTurtleDemon: treeTypeSelector.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StarSqueakTrees class
	instanceVariableNames: ''!

!StarSqueakTrees class methodsFor: 'parts bin' stamp: 'sw 10/24/2001 16:37'!
descriptionForPartsBin
	"Answer a description of the receiver for use in a parts bin"

	^ self partName:	'Trees'
		categories:		#('StarSqueak')
		documentation:	'A tree-growing simulation using StarSqueak'
		sampleImageForm: (Form
	extent: 70@72
	depth: 8
	fromArray: #( 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 681453608 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 681453608 673720360 673720360 673720360 673710080 673720360 673720360 673720360 1313744936 2661165134 2655922216 673720360 676241054 673720360 673720360 673720360 673720360 2653431848 1311284776 673720398 673720360 673720360 673710080 673720360 673720360 673720398 1313744936 2661195342 1311254568 673720360 676241054 2653431848 673750686 2661174862 2653431848 2655931944 1318987816 673720398 681453608 673720360 673710080 673720360 673720360 673750686 1313754664 2661195342 1311254568 673750606 673750686 673720360 673750686 2655931982 1318987816 2655922254 2653462174 673720398 2653431848 673720360 673710080 673720360 673720360 681453646 1319018024 2653431966 1311254568 673750686 1311284894 673720360 673720478 2661174862 2661165096 2653441694 2661195422 673720398 673750568 673720360 673710080 673720360 673720360 2661195342 676220574 2653431886 1313775262 681483934 1311284776 2653441576 673720478 681463374 2653431848 3257421470 2653462174 1311264334 681453726 673720360 673710080 673720360 673720398 2661195342 673730206 2653431848 1318997662 2661174862 3262300712 2653462174 1311254722 683852402 673720514 683843230 2661195422 1311264334 2661195304 673720360 673710080 673720360 673720360 2661195342 1313754782 2661165096 1920093854 2653441614 3262300712 681483854 1313744936 3262300786 673720514 3257411662 2661195304 673730206 673720360 673720360 673710080 673720360 673720398 681483934 2661195422 2661165096 1319018142 2653462094 678609448 681463454 2655922216 3262280232 673759938 3257421470 3267504286 676220456 673750568 673720360 673710080 673720360 673730206 673750606 2655922370 673759902 2661174942 3257421352 678570024 683852366 673720360 3245437224 683786792 683831848 1915264670 1316123176 673750686 673720360 673710080 673720360 673720360 2661165134 678589122 673750686 3267514049 2663524392 678504488 683812904 673720360 683766056 683747368 3267543746 2661195304 3262261288 2661165214 1311254568 673710080 673720360 673720360 673750606 673739304 3265175118 2661174977 3267504168 678504488 3240634408 673720360 678504488 1898496449 673720433 3265175198 3267543746 2661195422 1311254568 673710080 673720360 673730206 673720398 673720514 3257411742 2663563969 683812904 673759681 3240634408 673720360 678504488 1908484136 673720433 1898487490 1915234344 673720360 673720360 673710080 673720360 676241054 673720434 3262261288 3257441832 673739458 683747368 673759528 673720360 673720360 678504561 1898457128 673720433 1908484136 673720360 2661165096 673720360 673710080 673720360 676220456 2661195304 1920084008 3250661416 673720513 3250661416 673759528 673720360 673720360 678504561 1898457128 673739121 1898457128 673720360 2661195422 673720360 673710080 673720360 673730206 2653432002 3267523112 673759528 673720360 3250661416 673759528 673720360 673720360 678523249 673720360 673739201 1898457128 673720360 2661195304 673720360 673710080 673720360 676154958 1311254642 1920103025 1898496296 673720360 3245428008 676163880 673720360 673720360 681341261 673720360 676163953 1294477352 673720397 1313754702 673720360 673710080 673720360 676154664 673720360 673729905 1903280461 673720360 3240653133 678504488 673720360 673720360 681332008 673720360 681341224 673720360 676164253 676220574 673720360 673710080 673720360 673720360 673720360 673720360 678523292 1294477352 3240653212 1299261480 673720360 673720360 1903241256 673720360 681332008 673720360 1302109554 1319018142 673720360 673710080 673720360 673720360 673720360 673720360 673720433 1903250728 3240643996 1903241256 673720360 673720360 3243059240 673720360 1900881960 673720433 1903250728 1313775262 673720360 673710080 673720360 673720360 673720360 673720360 673720360 1299280168 3240634445 1906059304 673720360 673720360 3223857192 673720433 1898457165 1903260097 1898457128 1917754958 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673739121 1903241256 1302079528 673720360 673720360 3223857192 673739121 1903260017 1903260017 1903260274 1917734440 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673729905 1908484136 678504488 673720360 673720360 3223857192 678543729 1903259981 673720360 1299280498 1917724712 1296902184 673710080 673720360 673720360 673720360 673720360 673720360 673720360 1908418600 678504488 673720360 673720360 3223857192 1287680369 673720360 673720360 673720360 1922977358 1313679400 673710080 673720360 673720360 673720360 673720360 673720360 673720360 678513704 678504488 673720360 673720360 3223857228 1903241256 673720360 673720360 673720360 676240974 1313679400 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673739084 678504488 673720360 673720433 1898466417 1277700136 673720360 673720360 673720360 673750606 1296902184 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673739163 1282484264 673720360 673720512 676098380 673720360 673720360 673720360 673720360 673730206 1294477352 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673729691 1903241256 673720360 673720512 1903250472 673720360 673720360 673720360 673720360 673720478 1294477352 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720396 1905993768 673720360 673720512 1900816424 673720360 673720360 673720360 673720360 673720398 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1285236776 673720360 673739200 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 678504488 673720360 673759345 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 678504488 673720360 673759272 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 676098344 673720360 676098344 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673739121 673720360 678504488 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720512 673720360 1282484264 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720433 1898457128 1903241256 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 3223857192 1903241256 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 3223857228 1900816424 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 1903241329 1898457128 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 683681905 1898457128 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 683681905 1898457128 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673759345 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673759345 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673739121 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673738864 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673720360 673710080)
	offset: 478@345)! !
Object subclass: #StarSqueakTurtle
	instanceVariableNames: 'world who x y wrapX wrapY headingRadians color penDown nextTurtle'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Kernel'!
!StarSqueakTurtle commentStamp: '<historical>' prior: 0!
I represent a "creature" that can move about on the surface of a StarSqueak world. I have a position and a heading (direction), and respond commands such as "turnRight:" and "forward:" by turning or moving. I also have an imaginary pen that can draw a trail as I move. In StarSqueak, turtles are born with random positions and headings.

Here are some expressions to try in a workspace:
	w _ StarSqueakMorph new openInWorld.	"make an empty world"
	w makeTurtles: 100.						"create 100 turtles"
	w turtlesDo: [:t | t forward: 1].			"tell all turtles to take a step"
	w turtlesDo: [:t | t goto: 50@50].			"tell all turtles to go to 50@50"
	w turtlesDo: [:t | t forward: 10].			"tell all turtles to take 10 steps"

Structure:
  world				StarSqueakMorph		the world that owns this turtle
  who				integer					unique id
  x					number					x position in world
  y					number					y position in world
  wrapX				float					private; used for wrapping in x
  wrapY			float					private; used for wrapping in y
  headingRadians	float					heading in radians
  color				color					turtle color and its pen color
  penDown			boolean					true if drawing a pen trail
  nextTurtle			StarSqueaktTurtle		private; used to make linked list of turtles
!


!StarSqueakTurtle methodsFor: 'accessing' stamp: 'jm 1/27/2001 08:59'!
asPoint

	^ x truncated @ y truncated
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'jm 2/25/2000 16:03'!
color

	^ color
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
color: aColor

	color := aColor.
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
heading
	"Answer my heading in degrees."

	| degrees |
	degrees := 90.0 - headingRadians radiansToDegrees.
	^ degrees >= 0.0 ifTrue: [degrees] ifFalse: [degrees + 360.0].
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
heading: angleInDegrees
	"Set my heading in degrees. Like a compass, up or north is 0 degrees and right or east is 90 degrees."

	headingRadians := ((90.0 - angleInDegrees) \\ 360.0) degreesToRadians.
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'jm 3/3/2001 17:49'!
nextTurtle
	"The nextTurtle slot is used to make a linked list of turtles at a given patch."

	^ nextTurtle
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
nextTurtle: aStarSqueakTurtle
	"The nextTurtle slot is used to make a linked list of turtles at a given patch."

	nextTurtle := aStarSqueakTurtle.
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'jm 1/26/2001 17:36'!
who

	^ who
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
who: anInteger

	who := anInteger.
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'jm 2/25/2000 16:02'!
x

	^ x
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
x: aNumber

	x := aNumber.
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'jm 2/25/2000 16:02'!
y

	^ y
! !

!StarSqueakTurtle methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
y: aNumber

	y := aNumber.
! !


!StarSqueakTurtle methodsFor: 'commands' stamp: 'jm 1/26/2001 17:39'!
die
	"Delete this turtle at the end of the current cycle. The turtle will finish running all demons for the current cycle before it dies."

	world deleteTurtle: self.
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'jm 1/23/2001 17:26'!
forward: dist
	"Move the given distance in the direction of my heading."

	1 to: dist do: [:i | self forwardOne].
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'sd 11/20/2005 21:26'!
forwardOne
	"Move one turtle step in the direction of my heading."

	penDown ifTrue: [world setPatchColorAtX: x y: y to: color].
	x := x + headingRadians cos.
	y := y - headingRadians sin.
	x < 0.0 ifTrue: [x := x + wrapX].
	y < 0.0 ifTrue: [y := y + wrapY].
	x >= wrapX ifTrue: [x := x - wrapX].
	y >= wrapY ifTrue: [y := y - wrapY].
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'sd 11/20/2005 21:26'!
goto: aPoint
	"Jump to the given location."

	x := aPoint x.
	y := aPoint y.
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'sd 11/20/2005 21:26'!
penDown
	"Put down this turtle's pen. That is, the turtle will leave a trail the same color as itself when it moves."

	penDown := true.
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'sd 11/20/2005 21:26'!
penUp
	"Lift this turtle's pen. The turtle will stop leaving a trail."

	penDown := false.
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'jm 1/19/2001 19:20'!
random: range
	"Answer a random integer between 0 and range."

	^ world random: range
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'jm 1/27/2001 08:47'!
replicate
	"Add an exact replica of this turtle to the world. The new turtle does not become active until the next cycle."
	"Note: We call this operation 'replicate' instead of Mitch Resnick's term 'clone' because Squeak already used the message 'clone' for cloning a generic object."

	world replicateTurtle: self.
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'jm 1/29/2001 10:11'!
stop
	"Stop running."

	world stopRunning.
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'jm 1/19/2001 19:14'!
turnLeft: degrees
	"Turn left by the given number of degrees."

	self heading: (self heading - degrees).
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'jm 2/27/2000 18:19'!
turnRight: degrees
	"Turn right by the given number of degrees."

	self heading: (self heading + degrees).
! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'sd 11/20/2005 21:26'!
turnTowards: aPointTurtleOrPatch
	"Turn to face the given point, turtle, or patch."

	| degrees |
	degrees := (aPointTurtleOrPatch asPoint - self asPoint) degrees.
	headingRadians := (0.0 - degrees) degreesToRadians.

! !

!StarSqueakTurtle methodsFor: 'commands' stamp: 'jm 1/27/2001 08:58'!
turnTowardsStrongest: patchVarName
	"Turn to point toward the nearby patch having the highest value of the given patch variable. This command uses only local information. In particular, it only considers patches within 'sniffRange' of this turtles location. For example, with the default 'sniffRange' of 1, it only considers the immediate neighbors of the patch this turtle is on."

	self heading: (world uphillOf: patchVarName forTurtle: self).
! !


!StarSqueakTurtle methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initializeWorld: aStarSqueakWorld who: anInteger

	| dims |
	dims := aStarSqueakWorld dimensions.
	world := aStarSqueakWorld.
	who := anInteger.
	x := world random: dims x - 1.
	y := world random: dims y - 1.
	wrapX := dims x asFloat.
	wrapY := dims y asFloat.
	headingRadians := ((self random: 36000) / 100.0) degreesToRadians.
	color := Color blue.
	penDown := false.
	nextTurtle := nil.
! !


!StarSqueakTurtle methodsFor: 'patches' stamp: 'jm 1/19/2001 19:08'!
get: patchVar
	"Answer the value of the given patch variable below this turtle."

	^ world getPatchVariable: patchVar atX: x y: y
! !

!StarSqueakTurtle methodsFor: 'patches' stamp: 'jm 1/27/2001 08:49'!
increment: patchVar by: delta
	"Increment the value of the given patch variable below this turtle by the given amount (positive or negative)."

	 world incrementPatchVariable: patchVar atX: x y: y by: delta.
! !

!StarSqueakTurtle methodsFor: 'patches' stamp: 'hh 8/26/2001 19:49'!
patchBrightness
	"Answer the brightness of the patch below this turtle, where 0 is black and 100 is full brightness."

	^world getPatchBrightnessAtX: x y: y.
! !

!StarSqueakTurtle methodsFor: 'patches' stamp: 'jm 1/24/2001 13:28'!
patchBrightness: percent
	"Set the brightness of the patch below this turtle to the given value, where 0 is black and 100 is full brightness."

	world setPatchBrightnessAtX: x y: y to: percent.
! !

!StarSqueakTurtle methodsFor: 'patches' stamp: 'jm 1/23/2001 17:17'!
patchColor
	"Answer the color of the patch below this turtle."

	^ world getPatchColorAtX: x y: y.
! !

!StarSqueakTurtle methodsFor: 'patches' stamp: 'jm 1/24/2001 13:37'!
patchColor: aColor
	"Paint the patch below this turtle with the given color."

	world setPatchColorAtX: x y: y to: aColor.
! !

!StarSqueakTurtle methodsFor: 'patches' stamp: 'jm 1/19/2001 19:09'!
set: patchVar to: newValue
	"Set the value of the given patch variable below this turtle to the given value."

	 world setPatchVariable: patchVar atX: x y: y to: newValue.
! !


!StarSqueakTurtle methodsFor: 'sensing' stamp: 'jm 2/5/2001 19:42'!
distanceTo: aPoint
	"Answer the distance from this turtle to the given point."

	^ ((x - aPoint x) squared + (y - aPoint y) squared) sqrt
! !

!StarSqueakTurtle methodsFor: 'sensing' stamp: 'sd 11/20/2005 21:26'!
turtleCountHere
	"Answer a collection of turtles at this turtle's current location, including this turtle itself."

	| n |
	n := 0.
	world turtlesAtX: x y: y do: [:t | n := n + 1].
	^ n
! !
ChangeSetCategory subclass: #StaticChangeSetCategory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!StaticChangeSetCategory commentStamp: '<historical>' prior: 0!
StaticChangeSetCategory is a user-defined change-set category that has in it only those change sets specifically placed there.!


!StaticChangeSetCategory methodsFor: 'add' stamp: 'sw 4/11/2001 15:58'!
addChangeSet: aChangeSet
	"Add the change set manually"

	self elementAt: aChangeSet name put: aChangeSet! !


!StaticChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/11/2001 16:10'!
acceptsManualAdditions
	"Answer whether the user is allowed manually to manipulate the contents of the change-set-category."

	^ true! !

!StaticChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/11/2001 16:00'!
includesChangeSet: aChangeSet
	"Answer whether the receiver includes aChangeSet in its retrieval list"

	^ elementDictionary includesKey: aChangeSet name! !


!StaticChangeSetCategory methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'!
reconstituteList
	"Reformulate the list.  Here, since we have a manually-maintained list, at this juncture we only make sure change-set-names are still up to date, and we purge moribund elements"

	|  survivors |
	survivors := elementDictionary select: [:aChangeSet | aChangeSet isMoribund not].
	self clear.
	(survivors asSortedCollection: [:a :b | a name <= b name]) reverseDo:
		[:aChangeSet | self addChangeSet: aChangeSet]! !
Form subclass: #StaticForm
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!StaticForm commentStamp: '<historical>' prior: 0!
An optimization for Nebraska - a StaticForm does not change once created so it may be cached on the remote end.!


!StaticForm methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 09:59'!
isStatic

	^true! !
MorphicAlarm subclass: #StepMessage
	instanceVariableNames: 'stepTime'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!StepMessage methodsFor: 'accessing' stamp: 'ar 10/22/2000 16:56'!
stepTime: aNumber
	"Set the step time for this message. If nil, the receiver of the message will be asked for its #stepTime."
	stepTime _ aNumber! !


!StepMessage methodsFor: 'printing' stamp: 'ar 10/22/2000 15:59'!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPut: $(;
		print: receiver;
		space;
		print: selector;
		space;
		print: scheduledTime;
		nextPut: $).! !


!StepMessage methodsFor: 'testing' stamp: 'ar 10/22/2000 16:56'!
stepTime
	"Return the step time for this message. If nil, the receiver of the message will be asked for its #stepTime."
	^stepTime! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StepMessage class
	instanceVariableNames: ''!

!StepMessage class methodsFor: 'instance creation' stamp: 'ar 10/22/2000 15:48'!
scheduledAt: scheduledTime stepTime: stepTime receiver: aTarget selector: aSelector arguments: argArray
	^(self receiver: aTarget selector: aSelector arguments: argArray)
		scheduledTime: scheduledTime;
		stepTime: stepTime! !
RectangleMorph subclass: #StickyPadMorph
	instanceVariableNames: ''
	classVariableNames: 'Colors LastColorIndex'
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!StickyPadMorph commentStamp: 'sw 3/3/2004 13:31' prior: 0!
A custom item for the  Squeakland Supplies bin, as defined by Kim Rose and BJ Con.A parts bin will deliver up translucent, borderless Rectangles in a sequence of 6 colors.  It offers some complication to the parts-bin protocols in two ways::
* The multi-colored icon seen in the parts bin is not a thumbnail of any actual instance, all of which are monochrome
* New instances need to be given default names that are not the same as the name seen in the parts bin.!


!StickyPadMorph methodsFor: 'visual properties' stamp: 'dgd 9/18/2004 18:52'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just 
	colors. This method is for gradually converting old morphs."
	^ true! !


!StickyPadMorph methodsFor: 'parts bin' stamp: 'sw 4/3/2003 15:25'!
initializeToStandAlone
	"Initialize the receiver to stand alone.  Use the next color in the standard sequence."

	Colors ifNil: [self initialize].
	LastColorIndex _ 
		LastColorIndex
			ifNil:
				[1]
			ifNotNil:
				[(LastColorIndex \\ Colors size) + 1].
	super initializeToStandAlone.
	self assureExternalName.
	self color: (Colors at: LastColorIndex).
	self extent: 100@80.
	self borderWidth: 0
	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StickyPadMorph class
	instanceVariableNames: ''!

!StickyPadMorph class methodsFor: 'as yet unclassified' stamp: 'sw 3/3/2004 13:42'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(StickyPadMorph		newStandAlone			'Sticky Pad'			'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.')
						forFlapNamed: 'Supplies'.
				cl registerQuad: #(StickyPadMorph		newStandAlone			'Sticky Pad'			'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.')
						forFlapNamed: 'PlugIn Supplies'.]! !


!StickyPadMorph class methodsFor: 'class initialization' stamp: 'sw 3/3/2004 13:44'!
initialize
	"Class initialization"

	LastColorIndex _ 0.
	Colors _  {
		TranslucentColor r: 0.0 g: 0.0 b: 0.839 alpha: 0.267.
		TranslucentColor r: 0.484 g: 1.0 b: 0.452 alpha: 0.706.
		TranslucentColor r: 1.0 g: 0.355 b: 0.71 alpha: 0.569.
		TranslucentColor r: 1.0 g: 1.0 b: 0.03 alpha: 0.561.
		TranslucentColor r: 0.484 g: 0.161 b: 1.0 alpha: 0.529.
		TranslucentColor r: 0.097 g: 0.097 b: 0.097 alpha: 0.192.
	}.
	
	self registerInFlapsRegistry.	

"StickyPadMorph initialize"! !


!StickyPadMorph class methodsFor: 'parts bin' stamp: 'sw 4/3/2003 14:26'!
defaultNameStemForInstances
	"Answer the default name stem to use"

	^ 'tear off'! !

!StickyPadMorph class methodsFor: 'parts bin' stamp: 'sw 4/4/2003 11:12'!
descriptionForPartsBin
	"Answer a description of the receiver for use in a parts bin"

	^ self partName: 	'Sticky Pad'
		categories:		#('Graphics')
		documentation:	'A translucent, borderless rectangle of a standard size, delivered in a predictable sequence of pastel colors'
		sampleImageForm: (Form extent: 50@40 depth: 16
	fromArray: #( 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1796762392 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1796762392 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1599692633 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1599692633 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1662149394 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1662149394 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1389318863 1389318863 1389318863 1460426508 1460426508 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521903284 1389318863 1389318863 1389317938 1460426508 1460426508 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1723098804 1389318863 1389318863 1328697138 1460426508 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521903284 1723098804 1389318863 1389317938 1328697138 1460426508 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1723098804 1723098804 1389318863 1328697138 1328697138 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521903284 1723098804 1723098804 1389317938 1328697138 1328697138 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1723098804 1723098804 1723098804 1328697138 1328697138 1328697138 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461414680 1723098804 1723098804 1723096921 1328697138 1328697138 1328702226 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1796762392 1723098804 1723098804 1599692633 1328697138 1328697138 1662149394 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461414680 1796762392 1723098804 1723096921 1599692633 1328697138 1328702226 1662149394 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1796762392 1796762392 1723098804 1599692633 1599692633 1328697138 1662149394 1662149394 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461414680 1796762392 1796762392 1723096921 1599692633 1599692633 1328702226 1662149394 1662149394 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741)
	offset: 0@0)! !

!StickyPadMorph class methodsFor: 'parts bin' stamp: 'sw 7/5/2004 18:09'!
launchPartVia: aSelector label: aString
	"Obtain a morph by sending aSelector to self, and attach it to the morphic hand.  This provides a general protocol for parts bins.  Overridden here so that all instances will be given the name, unlike the prevailing convention for other object types"

	| aMorph |
	aMorph _ self perform: aSelector.
	aMorph setNameTo: self defaultNameStemForInstances.  "i.e., circumvent uniqueness in this case"
	aMorph setProperty: #beFullyVisibleAfterDrop toValue: true.
	aMorph openInHand! !
SketchMorph subclass: #StickySketchMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Support'!

!StickySketchMorph methodsFor: 'e-toy support' stamp: 'sw 4/16/1998 13:44'!
mustBeBackmost
	^ true! !


!StickySketchMorph methodsFor: 'halos and balloon help' stamp: 'sw 9/18/97 15:37'!
wantsHalo
	^ false! !


!StickySketchMorph methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:32'!
permitsThumbnailing
	^ false! !
Object subclass: #Stopwatch
	instanceVariableNames: 'timespans state'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Chronology'!
!Stopwatch commentStamp: '<historical>' prior: 0!
A Stopwatch maintains a collection of timespans.!


!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 23:12'!
activate

	self isSuspended ifTrue:
		[self timespans add: 
			(Timespan starting: DateAndTime now duration: Duration zero).
		self state: #active]
! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 23:45'!
duration

	| ts last |
	self isSuspended 
		ifTrue:
			[ (ts _ self timespans) isEmpty ifTrue: 
				[ ts _ { Timespan starting: DateAndTime now duration: Duration zero } ] ]
		ifFalse:
			[ last _ self timespans last.
			ts _ self timespans allButLast
				add: (last duration: (DateAndTime now - last start); yourself);
				yourself ].
		
	^ (ts collect: [ :t | t duration ]) sum
! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 11:21'!
end

	^ self timespans last next

! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:48'!
isActive

	^ self state = #active
! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:48'!
isSuspended

	^ self state = #suspended

! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:25'!
printOn: aStream

	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self state;
		nextPut: $:;
		print: self duration;
		nextPut: $).

! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 12:03'!
reActivate

	self 
		suspend;
		activate.
! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 11:54'!
reset

	self suspend.
	timespans _ nil.

! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 23:18'!
start

	^ self timespans first start

! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:47'!
state

	^ state ifNil: [ state _ #suspended ]
! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:46'!
state: aSymbol

	state _ aSymbol
! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 23:13'!
suspend

	| ts |
	self isActive ifTrue:
		[ ts _ self timespans last.
		ts duration: (DateAndTime now - ts start).
		self state: #suspended]
! !

!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:44'!
timespans

	^ timespans ifNil: [ timespans _ OrderedCollection new ]
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Stopwatch class
	instanceVariableNames: ''!
ClassTestCase subclass: #StopwatchTest
	instanceVariableNames: 'aStopwatch aDelay'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!

!StopwatchTest methodsFor: 'Coverage' stamp: 'brp 9/24/2003 22:49'!
classToBeTested

	^ Stopwatch

! !

!StopwatchTest methodsFor: 'Coverage' stamp: 'brp 9/24/2003 23:01'!
selectorsToBeIgnored

	| private | 
	private := #( #printOn: #state: ).

	^ super selectorsToBeIgnored, private
! !


!StopwatchTest methodsFor: 'running' stamp: 'brp 1/21/2004 18:49'!
setUp
	aStopwatch := Stopwatch new.
	aDelay := Delay forMilliseconds: 1.! !


!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 11:45'!
testActive

	| sw |
	sw _ Stopwatch new.
	sw activate.
	
	1 seconds asDelay wait.
	self 
		assert: (sw duration >= 1 seconds).

	2 seconds asDelay wait.
	self 
		assert: (sw duration >= 3 seconds).

	sw suspend.! !

!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/24/2003 22:56'!
testNew

	| sw |
	sw _ Stopwatch new.
	
	self 
		assert: (sw isSuspended);
		assert: (sw state = #suspended);
		deny: (sw isActive);
		assert: (sw timespans isEmpty)

! !

!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 12:02'!
testReActivate

	| sw |
	sw _ Stopwatch new.
	sw 
		activate;
		suspend;
		reActivate.
	
	self 
		assert: (sw isActive).
! !

!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 11:56'!
testReset

	| sw |
	sw _ Stopwatch new.
	sw activate.
	
	sw reset.
	self 
		assert: (sw isSuspended);
		assert: (sw timespans isEmpty)
! !

!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/26/2004 19:36'!
testStartStop

	| sw t1 t2 t3 t4 |
	sw := Stopwatch new.
	t1 := DateAndTime now.
	(Delay forMilliseconds: 10) wait.
	sw activate; activate.
	(Delay forMilliseconds: 10) wait.
	t2 := DateAndTime now.
	
	self 
		deny: (sw isSuspended);
		assert: (sw isActive);
		assert: (sw timespans size = 1);
		assert: (t1 <= sw start);
		assert: (sw start <= t2).

	(Delay forMilliseconds: 10) wait.
	t3 := DateAndTime now.
	(Delay forMilliseconds: 10) wait.
	sw suspend; suspend.
	(Delay forMilliseconds: 10) wait.
	t4 := DateAndTime now.

	self 
		assert: (sw isSuspended);
		deny: (sw isActive);
		assert: (sw timespans size = 1);
		assert: (sw end between: t3 and: t4);
		assert: (t3 <= sw end);
		assert: (sw end <= t4).
! !


!StopwatchTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:49'!
testChangingStatus
	aStopwatch activate.
	self assert: aStopwatch isActive.
	self assert: aStopwatch timespans size = 1.
	aStopwatch suspend.
	self assert: aStopwatch isSuspended.
	self assert: aStopwatch timespans size = 1.
	aStopwatch activate.
	aStopwatch reActivate.
	self assert: aStopwatch isActive.
	self assert: aStopwatch timespans size = 3.
	aStopwatch reset.
	self assert: aStopwatch isSuspended.
	self assert: aStopwatch timespans size = 0.! !

!StopwatchTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:49'!
testInitialStatus
	self assert: aStopwatch isSuspended.
	self deny: aStopwatch isActive.
	self assert: aStopwatch duration = 0 seconds! !

!StopwatchTest methodsFor: 'testing' stamp: 'brp 9/26/2004 19:32'!
testMultipleTimings
	aStopwatch activate.
	aDelay wait.
	aStopwatch suspend.
	aStopwatch activate.
	aDelay wait.
	aStopwatch suspend.
	self assert: aStopwatch timespans size = 2. 
	self assert: aStopwatch timespans first asDateAndTime <= 
					aStopwatch timespans last asDateAndTime.
! !

!StopwatchTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:49'!
testPrintOn
	| cs rw |
	cs := ReadStream on: 'a Stopwatch(suspended:0:00:00:00)'.
	rw := ReadWriteStream on: ''.
	aStopwatch printOn: rw.
	self assert: rw contents = cs contents! !

!StopwatchTest methodsFor: 'testing' stamp: 'brp 9/26/2004 19:32'!
testSingleTiming
	| timeBefore |
	timeBefore := DateAndTime now.
	aStopwatch activate.
	aDelay wait.
	aStopwatch suspend.
	self assert: aStopwatch timespans size = 1. 
	self assert: aStopwatch timespans first asDateAndTime >= timeBefore. 
	self assert: aStopwatch timespans first asDateAndTime <= aStopwatch end.
! !
PrintableEncoder subclass: #StoreEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Postscript Filters'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StoreEncoder class
	instanceVariableNames: ''!

!StoreEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 01:52'!
filterSelector
    ^#storeOnStream:.
! !
BookMorph subclass: #StoryboardBookMorph
	instanceVariableNames: 'alansSliders panAndTiltFactor zoomFactor zoomController'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Books'!
!StoryboardBookMorph commentStamp: '<historical>' prior: 0!
A BookMorph variant whose pages are instances of ZoomAndScrollMorph. I have a control area where the user may pan, tilt and zoom over the image shown in the page.

- drag up and down to zoom in and out
- drag left and right to pan
- shift-drag up and down to tilt.!


!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:37'!
changeTiltFactor: x

	currentPage changeTiltFactor: x.
	panAndTiltFactor _ x.

! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:37'!
changeZoomFactor: x

	currentPage changeZoomFactor: x.
	zoomFactor _ x.! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:38'!
getTiltFactor

	^panAndTiltFactor ifNil: [panAndTiltFactor _ 0.5].! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:38'!
getZoomFactor

	^zoomFactor ifNil: [zoomFactor _ 0.5]! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:41'!
offsetX

	^currentPage offsetX! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:41'!
offsetX: aNumber

	currentPage offsetX: aNumber! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:41'!
offsetY

	^currentPage offsetY! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:41'!
offsetY: aNumber

	currentPage offsetY: aNumber! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:35'!
scale

	^currentPage scale! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:26'!
scale: aValue

	currentPage scale: aValue! !


!StoryboardBookMorph methodsFor: 'initialization' stamp: 'RAA 12/1/2000 15:22'!
initialize

	newPagePrototype _ ZoomAndScrollMorph new extent: Display extent // 3.
	zoomController _ ZoomAndScrollControllerMorph new
			setBalloonText: 'Drag in here to zoom, tilt and pan the page above'.

	super initialize.

	self addMorphBack: zoomController.

	alansSliders _ {
		{#changeTiltFactor: . #getTiltFactor . 'Pan and tilt sensitivity'}.
		{#changeZoomFactor: . #getZoomFactor . 'Zoom sensitivity'}.
	} collect: [ :sData |
		{
			SimpleSliderMorph new
				extent: 150@10;
				color: Color orange;
				sliderColor: Color gray;
				target: self; 
				actionSelector: sData first;
				setBalloonText: sData third;
				adjustToValue: (self perform: sData second).
			sData second
		}
	].
	alansSliders do: [ :each | self addMorphBack: each first]
! !


!StoryboardBookMorph methodsFor: 'navigation' stamp: 'sw 7/25/2003 16:47'!
insertPageMorphInCorrectSpot: aPageMorph
	"Insert the page morph at the correct spot"
	
	| place |
	place _ submorphs size > 1 ifTrue: [submorphs second] ifFalse: [submorphs first].
	"Old architecture had a tiny spacer morph as the second morph; now architecture does not"
	self addMorph: (currentPage _ aPageMorph) behind: place.
	self changeTiltFactor: self getTiltFactor.
	self changeZoomFactor: self getZoomFactor.
	zoomController target: currentPage.

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StoryboardBookMorph class
	instanceVariableNames: ''!

!StoryboardBookMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:53'!
descriptionForPartsBin
	^ self partName:	'Storyboard'
		categories:		#('Presentation')
		documentation:	'A storyboard authoring tool'! !
Object subclass: #Stream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!Stream commentStamp: '<historical>' prior: 0!
I am an abstract class that represents an accessor for a sequence of objects. This sequence is referred to as my "contents".!


!Stream methodsFor: 'accessing' stamp: 'yo 8/30/2002 17:13'!
basicNext

	^ self next.
! !

!Stream methodsFor: 'accessing' stamp: 'yo 8/30/2002 17:13'!
basicNextPut: anObject 

	^ self nextPut: anObject! !

!Stream methodsFor: 'accessing' stamp: 'yo 8/30/2002 17:13'!
basicNextPutAll: aCollection 

	^ self nextPutAll: aCollection.
! !

!Stream methodsFor: 'accessing' stamp: 'nk 2/24/2001 17:31'!
binary! !

!Stream methodsFor: 'accessing'!
contents
	"Answer all of the contents of the receiver."

	self subclassResponsibility! !

!Stream methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:07'!
flush
	"Do nothing by default"! !

!Stream methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:38'!
localName
	^'a stream'! !

!Stream methodsFor: 'accessing'!
next
	"Answer the next object accessible by the receiver."

	self subclassResponsibility! !

!Stream methodsFor: 'accessing'!
next: anInteger 
	"Answer the next anInteger number of objects accessible by the receiver."

	| aCollection |
	aCollection _ OrderedCollection new.
	anInteger timesRepeat: [aCollection addLast: self next].
	^aCollection! !

!Stream methodsFor: 'accessing'!
next: anInteger put: anObject 
	"Make anObject be the next anInteger number of objects accessible by the 
	receiver. Answer anObject."

	anInteger timesRepeat: [self nextPut: anObject].
	^anObject! !

!Stream methodsFor: 'accessing'!
nextMatchAll: aColl
    "Answer true if next N objects are the ones in aColl,
     else false.  Advance stream of true, leave as was if false."
    | save |
    save _ self position.
    aColl do: [:each |
       (self next) = each ifFalse: [
            self position: save.
            ^ false]
        ].
    ^ true! !

!Stream methodsFor: 'accessing'!
nextMatchFor: anObject 
	"Gobble the next object and answer whether it is equal to the argument, 
	anObject."

	^anObject = self next! !

!Stream methodsFor: 'accessing'!
nextPut: anObject 
	"Insert the argument, anObject, as the next object accessible by the 
	receiver. Answer anObject."

	self subclassResponsibility! !

!Stream methodsFor: 'accessing'!
nextPutAll: aCollection 
	"Append the elements of aCollection to the sequence of objects accessible 
	by the receiver. Answer aCollection."

	aCollection do: [:v | self nextPut: v].
	^aCollection! !

!Stream methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:40'!
openReadOnly
	^self! !

!Stream methodsFor: 'accessing' stamp: 'ajh 7/31/2001 20:34'!
printOn: stream

	super printOn: stream.
	stream space.
	self contents printOn: stream.
! !

!Stream methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:41'!
readOnly
	^self! !

!Stream methodsFor: 'accessing' stamp: 'ls 9/12/1998 20:55'!
upToEnd
	"answer the remaining elements in the string"
	| elements |
	elements _ OrderedCollection new.
	[ self atEnd ] whileFalse: [ 
		elements add: self next ].
	^elements! !


!Stream methodsFor: 'alternate syntax' stamp: 'RAA 6/20/2000 12:52'!
dialect

	^#ST80		"in case a regular stream is used to print parse nodes"! !

!Stream methodsFor: 'alternate syntax' stamp: 'RAA 6/20/2000 12:54'!
withStyleFor: elementType do: aBlock

	^aBlock value		"in case a regular stream is used to print parse nodes"
">>
(Compiler new compile: 'blah ^self' in: String notifying: nil ifFail: []) printString
<<"! !


!Stream methodsFor: 'as yet unclassified' stamp: 'RAA 9/11/2000 19:12'!
sleep

	"an FTP-based stream might close the connection here"! !


!Stream methodsFor: 'enumerating'!
do: aBlock 
	"Evaluate aBlock for each of the objects accessible by receiver."

	[self atEnd]
		whileFalse: [aBlock value: self next]! !


!Stream methodsFor: 'file open/close' stamp: 'mir 8/10/1999 12:04'!
close! !


!Stream methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:48'!
write:encodedObject
	^encodedObject putOn:self.
! !


!Stream methodsFor: 'printing' stamp: 'sma 6/1/2000 09:56'!
print: anObject
	"Have anObject print itself on the receiver."

	anObject printOn: self! !

!Stream methodsFor: 'printing' stamp: 'djp 7/21/1998 17:13'!
printHtml: anObject
	anObject printHtmlOn: self! !


!Stream methodsFor: 'testing'!
atEnd
	"Answer whether the receiver can access any more objects."

	self subclassResponsibility! !

!Stream methodsFor: 'testing' stamp: 'ab 8/28/2003 18:30'!
closed
	^ false! !

!Stream methodsFor: 'testing' stamp: 'ar 12/23/1999 15:43'!
isStream
	"Return true if the receiver responds to the stream protocol"
	^true! !

!Stream methodsFor: 'testing' stamp: 'mir 11/10/2003 18:22'!
isTypeHTTP
	^false! !

!Stream methodsFor: 'testing' stamp: 'ar 5/17/2001 19:07'!
nextWordsPutAll: aCollection
	"Write the argument a word-like object in big endian format on the receiver.
	May be used to write other than plain word-like objects (such as ColorArray)."
	aCollection class isPointers | aCollection class isWords not 
		ifTrue: [^self error: aCollection class name,' is not word-like'].
	1 to: aCollection basicSize do:[:i|
		self nextNumber: 4 put: (aCollection basicAt: i).
	].
	^aCollection! !


!Stream methodsFor: '*monticello' stamp: 'cwp 8/9/2003 12:02'!
isMessageStream
	^ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Stream class
	instanceVariableNames: ''!

!Stream class methodsFor: 'instance creation'!
new

	self error: 'Streams are created with on: and with:'! !
TestCase subclass: #StreamBugz
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Bugs'!

!StreamBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/5/2003 02:25'!
testReadWriteStreamNextNBug
	| aStream |
	aStream := ReadWriteStream on: String new.
	aStream nextPutAll: 'Hello World'.
	self shouldnt:[aStream next: 5] raise: Error.
! !
AbstractSound subclass: #StreamingMP3Sound
	instanceVariableNames: 'volume repeat mpegFile mpegStreamIndex totalSamples streamSamplingRate mixer lastBufferMSecs mutex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Kernel'!
!StreamingMP3Sound commentStamp: '<historical>' prior: 0!
I implement a streaming player for MPEG or MP3 files.
Example of use:
	(StreamingMP3Sound onFileNamed: 'song.mp3') play.
!


!StreamingMP3Sound methodsFor: 'accessing' stamp: 'jm 11/16/2001 17:16'!
duration
	"Answer the duration of this sound in seconds."

	^ totalSamples asFloat / streamSamplingRate
! !

!StreamingMP3Sound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
repeat
	"Answer the repeat flag."

	repeat ifNil: [repeat := false].
	^ repeat
! !

!StreamingMP3Sound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
repeat: aBoolean
	"Set the repeat flag. If true, this sound will loop back to the beginning when it gets to the end."

	repeat := aBoolean.
! !

!StreamingMP3Sound methodsFor: 'accessing' stamp: 'jm 11/16/2001 16:18'!
soundPosition
	"Answer the relative position of sound playback as a number between 0.0 and 1.0."

	self mpegFileIsOpen ifFalse: [^ 0.0].
	mpegFile hasAudio ifFalse: [^ 0.0].
	^ (mpegFile audioGetSample: 0) asFloat / totalSamples
! !

!StreamingMP3Sound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
soundPosition: fraction
	"Jump to the position the given fraction through the sound file. The argument is a number between 0.0 and 1.0."

	| sampleIndex |
	self mpegFileIsOpen ifFalse: [^ self].
	mpegFile hasAudio ifTrue: [
		sampleIndex := ((totalSamples * fraction) truncated max: 0) min: totalSamples.
		mpegFile audioSetSample: 0 stream: 0.  "work around for library bug: first seek to zero"
		mpegFile audioSetSample: sampleIndex stream: 0].
! !

!StreamingMP3Sound methodsFor: 'accessing' stamp: 'jm 11/16/2001 15:34'!
streamSamplingRate
	"Answer the sampling rate of the MP3 stream."

	^ streamSamplingRate
! !

!StreamingMP3Sound methodsFor: 'accessing' stamp: 'jm 9/26/2000 07:49'!
volume
	"Answer my volume."

	^ volume
! !

!StreamingMP3Sound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:48'!
volume: aNumber
	"Set my volume to the given number between 0.0 and 1.0."

	volume := aNumber.
	self createMixer.
! !


!StreamingMP3Sound methodsFor: 'converting' stamp: 'stephaneducasse 2/4/2006 20:48'!
saveAsFileNamed: newFileName compressionType: compressionTypeString
	"Store this MP3 sound in a SunAudio file with the given name using the given compression type."

	| outFile |
	outFile := (FileStream newFileNamed: newFileName) binary.
	self storeSunAudioOn: outFile compressionType: compressionTypeString.
	outFile close.
! !

!StreamingMP3Sound methodsFor: 'converting' stamp: 'stephaneducasse 2/4/2006 20:48'!
storeSunAudioOn: aBinaryStream compressionType: compressionName
	"Store myself on the given stream as a monophonic sound compressed with the given type of compression. The sampling rate is reduced to 22050 samples/second if it is higher."

	| fmt inBufSize samplesPerFrame codec inBuf compressed outSamplingRate audioWriter samplesRemaining outBuf counts byteCount |
	self pause; reset.  "stop playing and return to beginning"

	fmt := SunAudioFileWriter formatCodeForCompressionType: compressionName.
	inBufSize := 64000.
	samplesPerFrame := 1.
	codec := SunAudioFileWriter codecForFormatCode: fmt.
	codec ifNotNil: [
		samplesPerFrame := codec samplesPerFrame.
		inBufSize := inBufSize roundUpTo: (2 * samplesPerFrame).
		compressed := ByteArray new:
			(inBufSize // samplesPerFrame) * codec bytesPerEncodedFrame].
	inBuf := SoundBuffer newMonoSampleCount: inBufSize.
	outSamplingRate := streamSamplingRate.
	streamSamplingRate > 22050 ifTrue: [
		streamSamplingRate = 44100 ifFalse: [self error: 'unexpected MP3 sampling rate'].
		outSamplingRate := 22050].

	"write audio header"
	audioWriter := SunAudioFileWriter onStream: aBinaryStream.
	audioWriter writeHeaderSamplingRate: outSamplingRate format: fmt.

	"convert and write sound data"
	'Storing audio...' displayProgressAt: Sensor cursorPoint
		from: 0 to: totalSamples during: [:bar |
			samplesRemaining := totalSamples.
			[samplesRemaining > 0] whileTrue: [
				bar value: totalSamples - samplesRemaining.
				samplesRemaining < inBuf monoSampleCount ifTrue: [
					inBuf := SoundBuffer newMonoSampleCount:
						(samplesRemaining roundUpTo: 2 * samplesPerFrame)].
				mpegFile audioReadBuffer: inBuf stream: 0 channel: 0.
				outSamplingRate < streamSamplingRate
					ifTrue: [outBuf := inBuf downSampledLowPassFiltering: true]
					ifFalse: [outBuf := inBuf].
				codec
					ifNil: [audioWriter appendSamples: outBuf]
					ifNotNil: [
						counts := codec
							encodeFrames: (outBuf size // samplesPerFrame)
							from: outBuf at: 1
							into: compressed at: 1.
						byteCount := counts last.
						byteCount = compressed size
							ifTrue: [audioWriter appendBytes: compressed]
							ifFalse: [audioWriter appendBytes: (compressed copyFrom: 1 to: byteCount)]].
				samplesRemaining := samplesRemaining - inBuf monoSampleCount]].

	"update audio header"
	audioWriter updateHeaderDataSize.
! !


!StreamingMP3Sound methodsFor: 'file ops' stamp: 'stephaneducasse 2/4/2006 20:48'!
closeFile
	"Close the MP3 or MPEG file."

	self pause.
	mpegFile ifNil: [^ self].
	mpegFile closeFile.
	mpegFile := nil.
	mixer := nil.
! !

!StreamingMP3Sound methodsFor: 'file ops' stamp: 'stephaneducasse 2/4/2006 20:48'!
mpegFileIsOpen
	"Answer true if I have an open, valid MPEG file handle. If the handle is not valid, try to re-open the file."

	mpegFile ifNil: [^ false].
	mpegFile fileHandle ifNil: [
		"try to reopen the file, which may have been saved in a snapshot"
		mpegFile openFile: mpegFile fileName.
		mpegFile fileHandle ifNil: [mpegFile := nil]].
	^ mpegFile notNil
! !


!StreamingMP3Sound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
initMPEGFile: anMPEGFile streamIndex: anInteger
	"Initialize for playing the given stream of the given MPEG or MP3 file."

	volume := 0.3.
	repeat := false.
	mpegFile := anMPEGFile.
	mpegStreamIndex := anInteger.
	totalSamples := mpegFile audioSamples: mpegStreamIndex.
	self reset.
! !


!StreamingMP3Sound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:48'!
millisecondsSinceStart
	"Answer the number of milliseconds since this sound started playing."

	| i mSecs |
	mpegFile ifNil: [^ 0].
	mpegFile fileHandle ifNil: [^ 0].  "mpeg file not open"
	i := mpegFile audioGetSample: mpegStreamIndex.
	i < 0 ifTrue: [^ 0].  "movie file has no audio"
	mSecs := i * 1000 // streamSamplingRate.
	(self isPlaying and: [lastBufferMSecs > 0]) ifTrue: [
		"adjust mSecs by the milliseconds since the last buffer"
		mutex critical: [
			mSecs := i * 1000 // streamSamplingRate.
			mSecs := mSecs + ((Time millisecondClockValue - lastBufferMSecs) max: 0)]].
	^ mSecs + 350 - (2 * SoundPlayer bufferMSecs)
! !

!StreamingMP3Sound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:48'!
playSampleCount: n into: aSoundBuffer startingAt: startIndex
	"Mix the next n samples of this sound into the given buffer starting at the given index"

	| current |
	self repeat ifTrue: [  "loop if necessary"
		current := mpegFile audioGetSample: mpegStreamIndex.
		(totalSamples - current) < n ifTrue: [
			mpegFile audioSetSample: 0 stream: mpegStreamIndex]].

	mutex critical: [
		lastBufferMSecs := Time millisecondClockValue.
		self loadBuffersForSampleCount: (n * streamSamplingRate) // SoundPlayer samplingRate.
		mixer playSampleCount: n into: aSoundBuffer startingAt: startIndex].
! !

!StreamingMP3Sound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:48'!
reset

	super reset.
	self createMixer.
	mpegFile audioSetSample: 0 stream: mpegStreamIndex.
	lastBufferMSecs := 0.
	mutex := Semaphore forMutualExclusion.
! !

!StreamingMP3Sound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:48'!
samplesRemaining

	| samplesPlayed |
	mpegFile ifNil: [^ 0].
	self repeat ifTrue: [^ 1000000].
	samplesPlayed := mpegFile audioGetSample: mpegStreamIndex.
	samplesPlayed > totalSamples ifTrue: [^ 0].
	^ totalSamples - samplesPlayed
! !


!StreamingMP3Sound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
createMixer
	"Create a mixed sound consisting of sampled sounds with one sound buffer's worth of samples. The sound has the same sampling rate and number of channels as the MPEG or MP3 file."

	| channels pan snd |
	mpegFile ifNil: [^ self error: 'No MPEG or MP3 file'].
	channels := mpegFile audioChannels: mpegStreamIndex.
	streamSamplingRate := mpegFile audioSampleRate: mpegStreamIndex.
	mixer := MixedSound new.
	1 to: channels do: [:c |
		channels = 1
			ifTrue: [pan := 0.5]
			ifFalse: [pan := (c - 1) asFloat / (channels - 1)].
		snd := SampledSound
			samples: (SoundBuffer newMonoSampleCount: 2)  "buffer size will be adjusted dynamically"
			samplingRate: streamSamplingRate.
		mixer add: snd pan: pan volume: volume].
! !

!StreamingMP3Sound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:48'!
loadBuffersForSampleCount: count
        "Load the sound buffers for all tracks with the next count
samples from the MPEG
file sound track."

        | snd buf |
        1 to: mixer sounds size do: [:i |
                snd := mixer sounds at: i.
                buf := snd samples.
                buf monoSampleCount = count ifFalse: [
                        buf := SoundBuffer newMonoSampleCount: count.
                        snd setSamples: buf samplingRate:
streamSamplingRate].
                i = 1 ifTrue: [  "first channel"
                                mpegFile
                                        audioReadBuffer: buf
                                        stream: mpegStreamIndex
                                        channel: 0]
                        ifFalse: [  "all other channels"
                                mpegFile
                                        audioReReadBuffer: buf
                                        stream: mpegStreamIndex
                                        channel: 1]].
        mixer reset.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StreamingMP3Sound class
	instanceVariableNames: ''!

!StreamingMP3Sound class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:48'!
onFileNamed: fileName
	"Answer an instance of me for playing the sound track of the MPEG or MP3 file with the given name. Answer nil the file is not a valid MPEG or MP3 file."

	| mpegFile |
	(MPEGFile isFileValidMPEG: fileName) ifFalse: [^ nil].
	mpegFile := MPEGFile openFile: fileName.
	^ self new initMPEGFile: mpegFile streamIndex: 0  "assume sound track is in stream 0"
! !
AbstractSound subclass: #StreamingMonoSound
	instanceVariableNames: 'stream volume repeat headerStart audioDataStart streamSamplingRate totalSamples codec mixer leftoverSamples lastBufferMSecs mutex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!StreamingMonoSound commentStamp: '<historical>' prior: 0!
I implement a streaming player for monophonic Sun (.au) and AIFF (.aif) audio files.
Example of use:
	(StreamingMonoSound onFileNamed: 'song.aif') play.
!


!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/16/2001 17:12'!
duration
	"Answer the duration of this sound in seconds."

	^ totalSamples asFloat / streamSamplingRate
! !

!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 10/18/2001 15:46'!
repeat
	"Answer the repeat flag."

	^ repeat
! !

!StreamingMonoSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
repeat: aBoolean
	"Set the repeat flag. If true, this sound will loop back to the beginning when it gets to the end."

	repeat := aBoolean.
! !

!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/16/2001 17:05'!
soundPosition
	"Answer the relative position of sound playback as a number between 0.0 and 1.0."

	(stream isNil or: [stream closed]) ifTrue: [^ 0.0].
	^ self currentSampleIndex asFloat / totalSamples
! !

!StreamingMonoSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
soundPosition: fraction
	"Jump to the position the given fraction through the sound file. The argument is a number between 0.0 and 1.0."

	| desiredSampleIndex |
	(stream isNil or: [stream closed]) ifTrue: [^ self].
	desiredSampleIndex := ((totalSamples * fraction) truncated max: 0) min: totalSamples.
	codec
		ifNil: [stream position: audioDataStart + (desiredSampleIndex * 2)]
		ifNotNil: [self positionCodecTo: desiredSampleIndex].
	leftoverSamples := SoundBuffer new.
! !

!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/20/2001 16:59'!
streamSamplingRate
	"Answer the sampling rate of the MP3 stream."

	^ streamSamplingRate
! !

!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 9/26/2000 07:49'!
volume
	"Answer my volume."

	^ volume
! !

!StreamingMonoSound methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:41'!
volume: aNumber
	"Set my volume to the given number between 0.0 and 1.0."

	volume := aNumber.
	self createMixer.
! !


!StreamingMonoSound methodsFor: 'converting' stamp: 'stephaneducasse 2/4/2006 20:41'!
saveAsFileNamed: newFileName compressionType: compressionTypeString
	"Store this sound in a new file with the given name using the given compression type. Useful for converting between compression formats."

	| outFile |
	outFile := (FileStream newFileNamed: newFileName) binary.
	self storeSunAudioOn: outFile compressionType: compressionTypeString.
	outFile close.
! !

!StreamingMonoSound methodsFor: 'converting' stamp: 'stephaneducasse 2/4/2006 20:41'!
storeSunAudioOn: aBinaryStream compressionType: compressionName
	"Store myself on the given stream as a monophonic sound compressed with the given type of compression. The sampling rate is reduced to 22050 samples/second if it is higher."

	| fmt inBufSize samplesPerFrame outCodec compressed outSamplingRate audioWriter samplesRemaining inBuf outBuf counts byteCount |
	self pause; reset.  "stop playing and return to beginning"

	fmt := SunAudioFileWriter formatCodeForCompressionType: compressionName.
	inBufSize := 64000.
	samplesPerFrame := 1.
	outCodec := SunAudioFileWriter codecForFormatCode: fmt.
	outCodec ifNotNil: [
		samplesPerFrame := outCodec samplesPerFrame.
		inBufSize := inBufSize roundUpTo: (2 * samplesPerFrame).
		compressed := ByteArray new:
			(inBufSize // samplesPerFrame) * outCodec bytesPerEncodedFrame].
	outSamplingRate := streamSamplingRate.
	streamSamplingRate > 22050 ifTrue: [
		streamSamplingRate = 44100 ifFalse: [self error: 'unexpected MP3 sampling rate'].
		outSamplingRate := 22050].

	"write audio header"
	audioWriter := SunAudioFileWriter onStream: aBinaryStream.
	audioWriter writeHeaderSamplingRate: outSamplingRate format: fmt.

	"convert and write sound data"
	'Storing audio...' displayProgressAt: Sensor cursorPoint
		from: 0 to: totalSamples during: [:bar |
			samplesRemaining := totalSamples.
			[samplesRemaining > 0] whileTrue: [
				bar value: totalSamples - samplesRemaining.
				self loadBuffersForSampleCount: (inBufSize min: samplesRemaining).
				inBuf := mixer sounds first samples.
				outSamplingRate < streamSamplingRate
					ifTrue: [outBuf := inBuf downSampledLowPassFiltering: true]
					ifFalse: [outBuf := inBuf].
				outCodec
					ifNil: [audioWriter appendSamples: outBuf]
					ifNotNil: [
						counts := outCodec
							encodeFrames: (outBuf size // samplesPerFrame)
							from: outBuf at: 1
							into: compressed at: 1.
						byteCount := counts last.
						byteCount = compressed size
							ifTrue: [audioWriter appendBytes: compressed]
							ifFalse: [audioWriter appendBytes: (compressed copyFrom: 1 to: byteCount)]].
				samplesRemaining := samplesRemaining - inBuf monoSampleCount]].

	"update audio header"
	audioWriter updateHeaderDataSize.
! !


!StreamingMonoSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
initStream: aStream headerStart: anInteger
	"Initialize for streaming from the given stream. The audio file header starts at the given stream position."

	stream := aStream.
	volume := 1.0.
	repeat := false.
	headerStart := anInteger.
	self reset.
! !


!StreamingMonoSound methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
closeFile
	"Close my stream, if it responds to close."

	stream ifNotNil: [
		(stream respondsTo: #close) ifTrue: [stream close]].
	mixer := nil.
	codec := nil.
! !

!StreamingMonoSound methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
extractFrom: startSecs to: endSecs
	"Extract a portion of this sound between the given start and end times. The current implementation only works if the sound is uncompressed."

	| emptySound first last sampleCount byteStream sndBuf |
	codec ifNotNil: [^ self error: 'only works on uncompressed sounds'].
	emptySound := SampledSound samples: SoundBuffer new samplingRate: streamSamplingRate.
	first := (startSecs * streamSamplingRate) truncated max: 0.
	last := ((endSecs * streamSamplingRate) truncated min: totalSamples) - 1.
	first >= last ifTrue: [^ emptySound].
	codec ifNotNil: [self error: 'extracting from compressed sounds is not supported'].
	sampleCount := last + 1 - first.
	stream position: audioDataStart + (2 * first).
	byteStream := ReadStream on: (stream next: 2 * sampleCount).
	sndBuf := SoundBuffer newMonoSampleCount: sampleCount.
	1 to: sampleCount do: [:i | sndBuf at: i put: byteStream int16].
	^ SampledSound samples: sndBuf samplingRate: streamSamplingRate
! !


!StreamingMonoSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
millisecondsSinceStart
	"Answer the number of milliseconds of this sound started playing."

	| mSecs |
	(stream isNil or: [stream closed]) ifTrue: [^ 0].
	mSecs := self currentSampleIndex * 1000 // streamSamplingRate.
	(self isPlaying and: [lastBufferMSecs > 0]) ifTrue: [
		"adjust mSecs by the milliseconds since the last buffer"
		mutex critical: [
			mSecs := self currentSampleIndex * 1000 // streamSamplingRate.
			mSecs := mSecs + ((Time millisecondClockValue - lastBufferMSecs) max: 0)]].
	^ mSecs + 350 - (2 * SoundPlayer bufferMSecs)
! !

!StreamingMonoSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
playSampleCount: n into: aSoundBuffer startingAt: startIndex
	"Mix the next n samples of this sound into the given buffer starting at the given index"

	self repeat ifTrue: [  "loop if necessary"
		(totalSamples - self currentSampleIndex) < n ifTrue: [self startOver]].

	mutex critical: [
		lastBufferMSecs := Time millisecondClockValue.
		self loadBuffersForSampleCount: (n * streamSamplingRate) // SoundPlayer samplingRate.
		mixer playSampleCount: n into: aSoundBuffer startingAt: startIndex].
! !

!StreamingMonoSound methodsFor: 'playing' stamp: 'jm 10/21/2001 09:45'!
reset

	super reset.
	self startOver.
	self createMixer.
! !

!StreamingMonoSound methodsFor: 'playing' stamp: 'stephaneducasse 2/4/2006 20:41'!
samplesRemaining
	"Answer the number of samples remaining to be played."

	| result |
	(stream isNil or: [stream closed]) ifTrue: [^ 0].
	self repeat ifTrue: [^ 1000000].
	result := (totalSamples - self currentSampleIndex) max: 0.
	result <= 0 ifTrue: [self closeFile].
	^ result
! !


!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
createMixer
	"Create a mixed sound consisting of sampled sounds with one sound buffer's worth of samples."

	| snd |
	mixer := MixedSound new.
	snd := SampledSound
		samples: (SoundBuffer newMonoSampleCount: 2)  "buffer size will be adjusted dynamically"
		samplingRate: streamSamplingRate.
	mixer add: snd pan: 0.5 volume: volume.
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
currentSampleIndex
	"Answer the index of the current sample."

	| bytePosition frameIndex |
	bytePosition := stream position - audioDataStart.
	codec
		ifNil: [^ bytePosition // 2]
		ifNotNil: [
			frameIndex := bytePosition // codec bytesPerEncodedFrame.
			^ (frameIndex * codec samplesPerFrame) - leftoverSamples monoSampleCount].
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
loadBuffer: aSoundBuffer compressedSampleCount: sampleCount
	"Load the given sound buffer from the compressed sample stream."
	"Details: Most codecs decode in multi-sample units called 'frames'. Since the requested sampleCount is typically not an even multiple of the frame size, we need to deal with partial frames. The unused samples from a partial frame are retained until the next call to this method."

	| n samplesNeeded frameCount encodedBytes r decodedCount buf j |
	"first, use any leftover samples"
	n := self loadFromLeftovers: aSoundBuffer sampleCount: sampleCount.
	samplesNeeded := sampleCount - n.
	samplesNeeded <= 0 ifTrue: [^ self].

	"decode an integral number of full compression frames"
	frameCount := samplesNeeded // codec samplesPerFrame.
	encodedBytes := stream next: (frameCount * codec bytesPerEncodedFrame).
	r := codec decodeFrames: frameCount from: encodedBytes at: 1 into: aSoundBuffer at: n + 1.
	decodedCount := r last.
	decodedCount >= samplesNeeded ifTrue: [^ self].

	"decode one last compression frame to finish filling the buffer"
	buf := SoundBuffer newMonoSampleCount: codec samplesPerFrame.
	encodedBytes := stream next: codec bytesPerEncodedFrame.
	codec decodeFrames: 1 from: encodedBytes at: 1 into: buf at: 1.
	j := 0.
	(n + decodedCount + 1) to: sampleCount do: [:i |
		aSoundBuffer at: i put: (buf at: (j := j + 1))].

	"save the leftover samples"
	leftoverSamples := buf copyFrom: (j + 1) to: buf monoSampleCount.
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 08:03'!
loadBuffer: aSoundBuffer uncompressedSampleCount: sampleCount
	"Load the given sound buffer from the uncompressed sample stream."

	"read directly into the sample buffer; count is in 32-bit words"
	stream next: sampleCount // 2 into: aSoundBuffer startingAt: 1.
	aSoundBuffer restoreEndianness.

	"read the final sample if sampleCount is odd:"
	sampleCount odd ifTrue: [aSoundBuffer at: sampleCount put: stream int16].
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
loadBuffersForSampleCount: count
	"Load the sound buffers from the stream."

	| snd buf sampleCount |
	snd := mixer sounds first.
	buf := snd samples.
	buf monoSampleCount = count ifFalse: [
		buf := SoundBuffer newMonoSampleCount: count.
		snd setSamples: buf samplingRate: streamSamplingRate].
	sampleCount := count min: (totalSamples - self currentSampleIndex).
	sampleCount < count ifTrue: [buf primFill: 0].

	codec
		ifNil: [self loadBuffer: buf uncompressedSampleCount: sampleCount]
		ifNotNil: [self loadBuffer: buf compressedSampleCount: sampleCount].

	mixer reset.
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
loadFromLeftovers: aSoundBuffer sampleCount: sampleCount
	"Load the given sound buffer from the samples leftover from the last frame. Answer the number of samples loaded, which typically is less than sampleCount."

	| leftoverCount n |
	leftoverCount := leftoverSamples monoSampleCount.
	leftoverCount = 0 ifTrue: [^ 0].

	n := leftoverCount min: sampleCount.
	1 to: n do: [:i | aSoundBuffer at: i put: (leftoverSamples at: i)].
	n < sampleCount
		ifTrue: [leftoverSamples := SoundBuffer new]
		ifFalse: [leftoverSamples := leftoverSamples copyFrom: n + 1 to: leftoverSamples size].
	^ n
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
positionCodecTo: desiredSampleIndex
	"Position to the closest frame before the given sample index when using a codec. If using the ADPCM codec, try to ensure that it is in sync with the compressed sample stream."

	| desiredFrameIndex desiredPosition tmpStream tmpCodec byteBuf bufFrames sampleBuf frameCount n startOffset |
	(codec isKindOf: ADPCMCodec) ifFalse: [
		"stateless codecs (or relatively stateless ones, like GSM: just jump to frame boundary"
		desiredFrameIndex := desiredSampleIndex // codec samplesPerFrame.
		stream position: audioDataStart + (desiredFrameIndex * codec bytesPerEncodedFrame).
		codec reset.
		^ self].

	"compute the desired stream position"
	desiredFrameIndex := desiredSampleIndex // codec samplesPerFrame.
	desiredPosition := audioDataStart + (desiredFrameIndex * codec bytesPerEncodedFrame).

	"copy stream and codec"
	(stream isKindOf: FileStream)
		ifTrue: [tmpStream := (FileStream readOnlyFileNamed: stream name) binary]
		ifFalse: [tmpStream := stream deepCopy].
	tmpCodec := codec copy reset.

	"reset the codec and start back about 30 seconds to try to get codec in sync"
	startOffset := ((desiredFrameIndex - 80000) max: 0) * codec bytesPerEncodedFrame.
	tmpStream position: audioDataStart + startOffset.

	"decode forward to the desired position"
	byteBuf := ByteArray new: (32000 roundTo: codec bytesPerEncodedFrame).
	bufFrames := byteBuf size // codec bytesPerEncodedFrame.
	sampleBuf := SoundBuffer newMonoSampleCount: bufFrames * codec samplesPerFrame.
	frameCount := (desiredPosition - tmpStream position) // codec bytesPerEncodedFrame.
	[frameCount > 0] whileTrue: [
		n := bufFrames min: frameCount.
		tmpStream next: n * codec bytesPerEncodedFrame into: byteBuf startingAt: 1.
		tmpCodec decodeFrames: n from: byteBuf at: 1 into: sampleBuf at: 1.
		frameCount := frameCount - n].

	codec := tmpCodec.
	stream position: tmpStream position.
	(tmpStream isKindOf: FileStream) ifTrue: [tmpStream close].! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
readAIFFHeader
	"Read an AIFF file header from stream."

	| aiffReader |
	aiffReader := AIFFFileReader new.
	aiffReader readFromStream: stream mergeIfStereo: false skipDataChunk: true.
	aiffReader channelCount = 1 ifFalse: [self error: 'not monophonic'].
	aiffReader bitsPerSample = 16 ifFalse: [self error: 'not 16-bit'].

	audioDataStart := headerStart + aiffReader channelDataOffset.
	streamSamplingRate := aiffReader samplingRate.
	totalSamples := aiffReader frameCount min: (stream size - audioDataStart) // 2.
	codec := nil.
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
readHeader
	"Read the sound file header from my stream."

	| id |
	stream position: headerStart.
	id := (stream next: 4) asString.
	stream position: headerStart.
	id = '.snd' ifTrue: [^ self readSunAudioHeader].
	id = 'FORM' ifTrue: [^ self readAIFFHeader].
	self error: 'unrecognized sound file format'.
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
readSunAudioHeader
	"Read a Sun audio file header from my stream."

	| id headerBytes dataBytes format channelCount |
	id := (stream next: 4) asString.
	headerBytes := stream uint32.  "header bytes"
	dataBytes := stream uint32.
	format := stream uint32.
	streamSamplingRate := stream uint32.
	channelCount := stream uint32.

	id = '.snd' ifFalse: [self error: 'not Sun audio format'].
	dataBytes := dataBytes min: (stream size - headerBytes).
	channelCount = 1 ifFalse: [self error: 'not monophonic'].
	audioDataStart := headerStart + headerBytes.
	codec := nil.
	format = 1 ifTrue: [  "8-bit u-LAW"
		codec := MuLawCodec new.
		totalSamples := dataBytes.
		^ self].
	format = 3 ifTrue: [  "16-bit linear"
		totalSamples := dataBytes // 2.
		^ self].
	format = 23 ifTrue: [  "ADPCM-4 bit (CCITT G.721)"
		codec := ADPCMCodec new
			initializeForBitsPerSample: 4 samplesPerFrame: 0.
		totalSamples := (dataBytes // 4) * 8.
		^ self].
	format = 25 ifTrue: [  "ADPCM-3 bit (CCITT G.723)"
		codec := ADPCMCodec new
			initializeForBitsPerSample: 3 samplesPerFrame: 0.
		totalSamples := (dataBytes // 3) * 8.
		^ self].
	format = 26 ifTrue: [  "ADPCM-5 bit (CCITT G.723)"
		codec := ADPCMCodec new
			initializeForBitsPerSample: 5 samplesPerFrame: 0.
		totalSamples := (dataBytes // 5) * 8.
		^ self].
	format = 610 ifTrue: [  "GSM 06.10 (this format was added by Squeak)"
		codec := GSMCodec new.
		totalSamples := (dataBytes // 33) * 160.
		^ self].
	self error: 'unsupported Sun audio format ', format printString
! !

!StreamingMonoSound methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:41'!
startOver
	"Jump back to the first sample."

	stream reopen; binary.
	self readHeader.
	stream position: audioDataStart.
	leftoverSamples := SoundBuffer new.
	lastBufferMSecs := 0.
	mutex := Semaphore forMutualExclusion.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StreamingMonoSound class
	instanceVariableNames: ''!

!StreamingMonoSound class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
onFileNamed: fileName
	"Answer an instance of me for playing the file with the given name."

	| f |
	f := FileDirectory default readOnlyFileNamed: fileName.
	f ifNil: [^ self error: 'could not open ', fileName].
	^ self new initStream: f headerStart: 0
! !

!StreamingMonoSound class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
onFileNamed: fileName headerStart: anInteger
	"Answer an instance of me for playing audio data starting at the given position in the file with the given name."

	| f |
	f := FileDirectory default readOnlyFileNamed: fileName.
	f ifNil: [^ self error: 'could not open ', fileName].
	^ self new initStream: f headerStart: anInteger
! !
AlignmentMorphBob1 subclass: #StretchyImageMorph
	instanceVariableNames: 'form cache'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!
!StretchyImageMorph commentStamp: '<historical>' prior: 0!
I draw a form to fill whatever bounds I have.!


!StretchyImageMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 16:20'!
form: aForm

	form _ aForm! !


!StretchyImageMorph methodsFor: 'drawing' stamp: 'nk 1/3/2004 17:40'!
drawOn: aCanvas
| t |
"
Smalltalk at: #Q4 put: OrderedCollection new.
"
	form ifNil: [form _ (Form extent: 32@32 depth: 8) fillColor: Color green].
	(cache isNil or: [cache extent ~= bounds extent]) ifTrue: [
		t _ [cache _ Form extent: bounds extent depth: form depth.
		form displayInterpolatedIn: cache boundingBox on: cache.
		cache _ cache asFormOfDepth: aCanvas depth] timeToRun.
		"Q4 add: {t. form. cache}."
	].
	aCanvas paintImage: cache at: bounds origin.
! !


!StretchyImageMorph methodsFor: 'initialization' stamp: 'ar 10/30/2000 15:31'!
initialize

	super initialize.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
! !
AbstractFont subclass: #StrikeFont
	instanceVariableNames: 'characterToGlyphMap xTable glyphs name type minAscii maxAscii maxWidth strikeLength ascent descent xOffset raster subscript superscript emphasis derivativeFonts pointSize fallbackFont charIndex'
	classVariableNames: 'DefaultStringScanner'
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Fonts'!
!StrikeFont commentStamp: '<historical>' prior: 0!
I represent a compact encoding of a set of Forms corresponding to characters in the ASCII character set. All the forms are placed side by side in a large form whose height is the font height, and whose width is the sum of all the character widths. The xTable variable gives the left-x coordinates of the subforms corresponding to the glyphs. Characters are mapped to glyphs by using the characterToGyphMap.

Subclasses can have non-trivial mapping rules as well as different representations for glyphs sizes (e.g., not using an xTable). If so, these classes should return nil when queried for xTable and/or the characterToGlyphMap. This will cause the CharacterScanner primitive to fail and query the font for the width of a character (so that a more programatical approach can be implemented).

For display, fonts need to implement two messages:
	#installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
This method installs the receiver (a font) on the given DisplayContext (which may be an instance of BitBlt or Canvas (or any of it's subclasses). The font should take the appropriate action to initialize the display context so that further display operations can be optimized.
	#displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta
This method is called for each subsequent run of characters in aString which is to be displayed with the (previously installed) settings.
!


!StrikeFont methodsFor: 'accessing'!
ascent
	"Answer the receiver's maximum extent of characters above the baseline."

	^ascent! !

!StrikeFont methodsFor: 'accessing' stamp: 'di 9/2/2000 13:06'!
ascentKern
	"Return the kern delta for ascenders."
	(emphasis noMask: 2) ifTrue: [^ 0].
	^ (self ascent-5+4)//4 max: 0  "See makeItalicGlyphs"

! !

!StrikeFont methodsFor: 'accessing' stamp: 'yo 1/6/2005 04:19'!
ascentOf: aCharacter

	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont ascentOf: aCharacter.
		].
	].
	^ self ascent.
! !

!StrikeFont methodsFor: 'accessing' stamp: 'di 9/1/2000 17:17'!
baseKern
	"Return the base kern value to be used for all characters."
	(emphasis noMask: 2) ifTrue: [^ 0].
	^ ((self height-1-self ascent+4)//4 max: 0)  "See makeItalicGlyphs"
		+ (((self ascent-5+4)//4 max: 0))
! !

!StrikeFont methodsFor: 'accessing' stamp: 'ar 5/23/2000 12:52'!
characterToGlyphMap
	^characterToGlyphMap ifNil:[characterToGlyphMap _ self createCharacterToGlyphMap].! !

!StrikeFont methodsFor: 'accessing' stamp: 'ar 5/23/2000 12:52'!
characterToGlyphMap: anArray
	characterToGlyphMap _ anArray.! !

!StrikeFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'!
derivativeFonts
	^derivativeFonts copyWithout: nil! !

!StrikeFont methodsFor: 'accessing'!
descent
	"Answer the receiver's maximum extent of characters below the baseline."

	^descent! !

!StrikeFont methodsFor: 'accessing' stamp: 'di 9/2/2000 13:06'!
descentKern
	"Return the kern delta for descenders."
	(emphasis noMask: 2) ifTrue: [^ 0].
	^ (self height-1-self ascent+4)//4 max: 0  "See makeItalicGlyphs"

! !

!StrikeFont methodsFor: 'accessing' stamp: 'yo 1/6/2005 04:19'!
descentOf: aCharacter

	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont descentOf: aCharacter.
		].
	].
	^ self descent.
! !

!StrikeFont methodsFor: 'accessing' stamp: 'tak 12/22/2004 01:25'!
fallbackFont
	^ fallbackFont
		ifNil: [fallbackFont _ FixedFaceFont new errorFont fontSize: self height]! !

!StrikeFont methodsFor: 'accessing' stamp: 'yo 5/20/2004 11:01'!
fallbackFont: aFontSetOrNil

	fallbackFont _ aFontSetOrNil.
! !

!StrikeFont methodsFor: 'accessing'!
familyName
	^self name withoutTrailingDigits.

! !

!StrikeFont methodsFor: 'accessing' stamp: 'tk 6/26/1998 16:45'!
familySizeFace
	"Answer an array with familyName, a String, pointSize, an Integer, and
	faceCode, an Integer."

	^Array with: name
		with: self height
		with: emphasis

	"(1 to: 12) collect: [:x | (TextStyle default fontAt: x) familySizeFace]"! !

!StrikeFont methodsFor: 'accessing' stamp: 'ar 9/21/2000 11:53'!
fontNameWithPointSize
	^self name withoutTrailingDigits, ' ', self pointSize printString! !

!StrikeFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:15'!
glyphInfoOf: aCharacter into: glyphInfoArray
	"Answer the width of the argument as a character in the receiver."

	| code |
	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont glyphInfoOf: aCharacter into: glyphInfoArray.
		].
		code _ 0.
	] ifTrue: [
		code _ aCharacter charCode.
	].
	glyphInfoArray at: 1 put: glyphs;
		at: 2 put: (xTable at: code + 1);
		at: 3 put: (xTable at: code + 2);
		at: 4 put: (self ascentOf: aCharacter);
		at: 5 put: self.
	^ glyphInfoArray.
! !

!StrikeFont methodsFor: 'accessing' stamp: 'yo 1/6/2005 04:19'!
glyphOf: aCharacter 
	"Answer the width of the argument as a character in the receiver."

	| code |
	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont glyphOf: aCharacter.
		].
		^ (Form extent: 1@self height) fillColor: Color white
	].
	code _ aCharacter charCode.
	^ glyphs copy: (((xTable at: code + 1)@0) corner: (xTable at: code +2)@self height).
! !

!StrikeFont methodsFor: 'accessing'!
glyphs
	"Answer a Form containing the bits representing the characters of the 
	receiver."

	^glyphs! !

!StrikeFont methodsFor: 'accessing'!
height
	"Answer the height of the receiver, total of maximum extents of 
	characters above and below the baseline."

	^self ascent + self descent! !

!StrikeFont methodsFor: 'accessing' stamp: 'yo 1/6/2005 04:19'!
heightOf: aCharacter

	(self hasGlyphOf: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont heightOf: aCharacter.
		].
	].
	^ self height.
! !

!StrikeFont methodsFor: 'accessing'!
lineGrid
	^ ascent + descent! !

!StrikeFont methodsFor: 'accessing'!
maxAscii
	"Answer the integer that is the last Ascii character value of the receiver."

	^maxAscii! !

!StrikeFont methodsFor: 'accessing'!
maxWidth
	"Answer the integer that is the width of the receiver's widest character."

	^maxWidth! !

!StrikeFont methodsFor: 'accessing'!
minAscii
	"Answer the integer that is the first Ascii character value of the receiver."

	^minAscii! !

!StrikeFont methodsFor: 'accessing' stamp: 'ls 3/27/2000 19:54'!
name
	"Answer the receiver's name."

	^name ifNil: ['(unnamed)']! !

!StrikeFont methodsFor: 'accessing'!
name: aString
	"Set the receiver's name."

	name _ aString! !

!StrikeFont methodsFor: 'accessing' stamp: 'sw 1/18/2000 20:54'!
pointSize
	^ pointSize! !

!StrikeFont methodsFor: 'accessing' stamp: 'sma 5/5/2000 14:21'!
pointSize: anInteger
	pointSize _ anInteger! !

!StrikeFont methodsFor: 'accessing'!
raster
	"Answer an integer that specifies the layout of the glyphs' form."

	^raster! !

!StrikeFont methodsFor: 'accessing'!
setGlyphs: newGlyphs
	"Replace the glyphs form.  Used to make a synthetic bold or italic font quickly."

	glyphs _ newGlyphs! !

!StrikeFont methodsFor: 'accessing'!
subscript
	"Answer an integer that is the further vertical offset relative to the 
	baseline for positioning characters as subscripts."

	^subscript! !

!StrikeFont methodsFor: 'accessing'!
superscript
	"Answer an integer that is the further vertical offset relative to the 
	baseline for positioning characters as superscripts."

	^superscript! !

!StrikeFont methodsFor: 'accessing' stamp: 'nk 6/17/2003 14:26'!
textStyle
	^ TextStyle actualTextStyles detect:
		[:aStyle | aStyle fontArray includes: self] ifNone: [nil]! !

!StrikeFont methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:12'!
widthOf: aCharacter 
	"Answer the width of the argument as a character in the receiver."
	| code |
	code := aCharacter charCode.
	((code < minAscii or: [maxAscii < code]) 
		or: [(xTable at: code + 1) < 0])
			ifTrue: [^ self fallbackFont widthOf: aCharacter].
	^ (xTable at: code + 2) - (xTable at: code + 1)! !

!StrikeFont methodsFor: 'accessing'!
xTable
	"Answer an Array of the left x-coordinate of characters in glyphs."

	^xTable! !

!StrikeFont methodsFor: 'accessing' stamp: 'yo 8/28/2002 16:33'!
xTable: anObject

	xTable _ anObject.
! !


!StrikeFont methodsFor: 'character shapes'!
alter: char formBlock: formBlock
	self characterFormAt: char 
		put: (formBlock value: (self characterFormAt: char))! !

!StrikeFont methodsFor: 'character shapes' stamp: 'yo 12/28/2002 22:37'!
characterFormAtMulti: character 
	"Answer a Form copied out of the glyphs for the argument, character."
	| ascii leftX rightX |
	ascii _ character charCode.
	(ascii between: minAscii and: maxAscii) ifFalse: [ascii _ maxAscii + 1].
	leftX _ xTable at: ascii + 1.
	rightX _ xTable at: ascii + 2.
	^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! !

!StrikeFont methodsFor: 'character shapes' stamp: 'yo 12/1/2003 17:01'!
characterFormAt: character 
	"Answer a Form copied out of the glyphs for the argument, character."
	| ascii leftX rightX |
	ascii _ character charCode.
	(ascii between: minAscii and: maxAscii) ifFalse: [ascii _ maxAscii + 1].
	leftX _ xTable at: ascii + 1.
	rightX _ xTable at: ascii + 2.
	leftX < 0 ifTrue: [^ glyphs copy: (0@0 corner: 0@self height)].
	^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! !

!StrikeFont methodsFor: 'character shapes' stamp: 'di 8/30/2000 10:00'!
characterFormAt: character put: characterForm
	"Copy characterForm over the glyph for the argument, character."
	| ascii leftX rightX widthDif newGlyphs |
	ascii _ character asciiValue.
	ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii'].
	ascii > maxAscii ifTrue:
		[(self confirm:
'This font does not accomodate ascii values higher than ' , maxAscii printString , '.
Do you wish to extend it permanently to handle values up to ' , ascii printString)
			ifTrue: [self extendMaxAsciiTo: ascii]
			ifFalse: [^ self error: 'No change made']].
	leftX _ xTable at: ascii + 1.
	rightX _ xTable at: ascii + 2.
	widthDif _ characterForm width - (rightX - leftX).
	widthDif ~= 0 ifTrue:
		["Make new glyphs with more or less space for this char"
		newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height.
		newGlyphs copy: (0@0 corner: leftX@glyphs height)
			from: 0@0 in: glyphs rule: Form over.
		newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height)
			from: rightX@0 in: glyphs rule: Form over.
		glyphs _ newGlyphs.
		"adjust further entries on xTable"
		xTable _ xTable copy.
		ascii+2 to: xTable size
			do: [:i | xTable at: i put: (xTable at: i) + widthDif]].
	glyphs copy: (leftX @ 0 extent: characterForm extent)
		from: 0@0 in: characterForm rule: Form over
"
| f |  f _ TextStyle defaultFont.
f characterFormAt: $  put: (Form extent: (f widthOf: $ )+10@f height)
"! !

!StrikeFont methodsFor: 'character shapes'!
characterForm: char pixelValueAt: pt put: val
	| f |
	f _ self characterFormAt: char.
	f pixelAt: pt put: val.
	self characterFormAt: char put: val! !

!StrikeFont methodsFor: 'character shapes' stamp: 'btr 11/18/2002 15:00'!
edit: character 
	"Open a Bit Editor on the given character. Note that you must do an accept 
	(in the option menu of the bit editor) if you want this work. 
	Accepted edits will not take effect in the font until you leave or close the bit editor. 
	Also note that unaccepted edits will be lost when you leave or close."
	"Note that BitEditor only works in MVC currently."

	"(TextStyle default fontAt: 1) edit: $_"

	| charForm editRect scaleFactor bitEditor savedForm r |
	charForm _ self characterFormAt: character.
	editRect _ BitEditor locateMagnifiedView: charForm scale: (scaleFactor _ 8 @ 8).
	bitEditor _ BitEditor
				bitEdit: charForm
				at: editRect topLeft
				scale: scaleFactor
				remoteView: nil.
	savedForm _ Form fromDisplay: (r _ bitEditor displayBox
							expandBy: (0 @ 23 corner: 0 @ 0)).
	bitEditor controller startUp.
	bitEditor release.
	savedForm displayOn: Display at: r topLeft.
	self characterFormAt: character put: charForm! !

!StrikeFont methodsFor: 'character shapes' stamp: 'BG 12/6/2004 19:22'!
ensureCleanBold
	"This ensures that all character glyphs have at least one pixel of white space on the right
	so as not to cause artifacts in neighboring characters in bold or italic."

	| newGlyphs newXTable newGlyphPos startPos newWidth widthOfGlyph increment lastCol |
	emphasis = 0 ifFalse: [^ self].
    newWidth := glyphs width + maxAscii - minAscii + 1.
    lastCol := Form extent: 1@ glyphs height.
    newGlyphs := Form extent: newWidth @ glyphs height.
    newXTable := Array new: xTable size.
    1 to: minAscii do: [:idx | newXTable at: idx put: (xTable at: idx)].
   
    newGlyphPos := startPos := 0.
    minAscii to: maxAscii do:
      [:idx | 
         newXTable at: idx + 1 put: newGlyphPos.
         widthOfGlyph := (xTable at: idx + 2 ) - (xTable at: idx + 1).
         widthOfGlyph > 0
           ifTrue:
             [newGlyphs copy: (newGlyphPos @ 0 extent: widthOfGlyph @ glyphs height)
                          from: startPos@0 in: glyphs rule: Form over.
              lastCol copy: (0 @ 0 extent: 1 @ glyphs height)
                          from: startPos + widthOfGlyph - 1 @0 in: glyphs rule: Form over.
              increment := lastCol isAllWhite ifTrue: [0] ifFalse: [1].
              startPos := startPos + widthOfGlyph.
              newGlyphPos := newGlyphPos + widthOfGlyph + increment.
             ].
      ].
    maxAscii + 2 to: newXTable size do: [:idx | newXTable at: idx put: newGlyphPos.].
    glyphs := Form extent: newGlyphPos @ glyphs height.
    glyphs copy: (0 @ 0 extent: glyphs extent)
            from: 0@0 in: newGlyphs rule: Form over.
    xTable := newXTable.
"
StrikeFont allInstancesDo: [:f | f ensureCleanBold].
(StrikeFont familyName: 'NewYork' size: 21) ensureCleanBold.
StrikeFont shutDown.  'Flush synthetic fonts'.
"
! !

!StrikeFont methodsFor: 'character shapes' stamp: 'ar 5/23/2000 12:48'!
extendMaxAsciiTo: newMax
	"Extend the range of this font so that it can display glyphs up to newMax."

	(newMax+3) <= xTable size ifTrue: [^ self].  "No need to extend."
	xTable size = (maxAscii+3) ifFalse:
		[^ self error: 'This font is not well-formed.'].

	"Insert a bunch of zero-width characters..."
	xTable _ (xTable copyFrom: 1 to: maxAscii+2) ,
			((maxAscii+1 to: newMax) collect: [:i | xTable at: maxAscii+2]) ,
			{ xTable at: maxAscii+3 }.
	maxAscii _ newMax.
	self fillZeroWidthSlots.
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'character shapes' stamp: 'di 3/27/2000 16:10'!
fillZeroWidthSlots
	| nullGlyph |
	"Note: this is slow because it copies the font once for every replacement."

	nullGlyph _ (Form extent: 1@glyphs height) fillGray.
	"Now fill the empty slots with narrow box characters."
	minAscii to: maxAscii do:
		[:i | (self widthOf: (Character value: i)) = 0 ifTrue:
			[self characterFormAt: (Character value: i) put: nullGlyph]].
! !

!StrikeFont methodsFor: 'character shapes' stamp: 'di 4/28/2000 16:10'!
fixOneWideChars 
	"This fixes all 1-wide characters to be 2 wide with blank on the right
	so as not to cause artifacts in neighboring characters in bold or italic."
	| twoWide |
	minAscii to: maxAscii do:
		[:i | (self widthOf: (Character value: i)) = 1 ifTrue:
			[twoWide _ Form extent: 2@glyphs height.
			(self characterFormAt: (Character value: i)) displayOn: twoWide at: 0@0.
			self characterFormAt: (Character value: i) put: twoWide]].
"
StrikeFont allInstancesDo: [:f | f fixOneWideChars].
StrikeFont shutDown.  'Flush synthetic fonts'.
"
! !

!StrikeFont methodsFor: 'character shapes' stamp: 'RAA 7/6/2000 16:50'!
makeCarriageReturnsWhite
	| crForm |
	"Some larger fonts have a gray carriage return (from the zero wide fixup) make it white so it doesn't show"

	crForm _ self characterFormAt: 13 asCharacter.
	crForm fillWhite.
	self characterFormAt: 13 asCharacter put: crForm.
! !

!StrikeFont methodsFor: 'character shapes'!
widen: char by: delta
	| newForm |
	^ self alter: char formBlock:  "Make a new form, wider or narrower..."
		[:charForm | newForm _ Form extent: charForm extent + (delta@0).
		charForm displayOn: newForm.  "Copy this image into it"
		newForm]    "and substitute it in the font"! !


!StrikeFont methodsFor: 'copying' stamp: 'BG 12/9/2004 17:27'!
deepCopy
 " there is a circular reference from the derivative fonts back to the receiver. It is therefore not possible to make a deep copy. We make a sahllow copy. The method postCopy can be used to modify the shallow copy. " 
  ^self copy! !

!StrikeFont methodsFor: 'copying' stamp: 'BG 12/9/2004 17:35'!
postCopy
 " the receiver is a just created shallow copy. This method gives it the final touch. " 
 
    glyphs := glyphs copy.
    xTable := xTable copy.
    characterToGlyphMap := characterToGlyphMap copy.
 
    self reset.  " takes care of the derivative fonts "! !

!StrikeFont methodsFor: 'copying' stamp: 'tk 8/19/1998 16:15'!
veryDeepCopyWith: deepCopier
	"Return self.  I am shared.  Do not record me."! !


!StrikeFont methodsFor: 'displaying' stamp: 'yo 5/19/2004 11:34'!
characters: anInterval in: sourceString displayAt: aPoint clippedBy: clippingRectangle rule: ruleInteger fillColor: aForm kernDelta: kernDelta on: aBitBlt
	"Simple, slow, primitive method for displaying a line of characters.
	No wrap-around is provided."
	| ascii destPoint leftX rightX sourceRect |
	destPoint _ aPoint.
	anInterval do: 
		[:i |
		self flag: #yoDisplay.
		"if the char is not supported, fall back to the specified fontset."
		ascii _ (sourceString at: i) charCode.
		(ascii < minAscii or: [ascii > maxAscii])
			ifTrue: [ascii _ maxAscii].
		leftX _ xTable at: ascii + 1.
		rightX _ xTable at: ascii + 2.
		sourceRect _ leftX@0 extent: (rightX-leftX) @ self height.
		aBitBlt copyFrom: sourceRect in: glyphs to: destPoint.
		destPoint _ destPoint + ((rightX-leftX+kernDelta)@0).
		"destPoint printString displayAt: 0@(i*20)"].
	^ destPoint! !

!StrikeFont methodsFor: 'displaying' stamp: 'yo 5/19/2004 11:36'!
displayLine: aString at: aPoint 
	"Display the characters in aString, starting at position aPoint."

	self characters: (1 to: aString size)
		in: aString
		displayAt: aPoint
		clippedBy: Display boundingBox
		rule: Form over
		fillColor: nil
		kernDelta: 0
		on: (BitBlt current toForm: Display).
! !

!StrikeFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 15:16'!
displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY

	| destPoint leftX rightX glyphInfo char displayInfo destY |
	destPoint _ aPoint.
	charIndex _ startIndex.
	glyphInfo _ Array new: 5.
	[charIndex <= stopIndex] whileTrue: [
		char _ aString at: charIndex.
		(self hasGlyphOf: char) not ifTrue: [
				displayInfo _ self fallbackFont displayString: aString on: aBitBlt from: charIndex to: stopIndex at: destPoint kern: kernDelta from: self baselineY: baselineY.
				charIndex _ displayInfo first.
				destPoint _ displayInfo second.
		] ifFalse: [
			self glyphInfoOf: char into: glyphInfo.
			leftX _ glyphInfo second.
			rightX _ glyphInfo third.
			(glyphInfo fifth ~= aBitBlt lastFont) ifTrue: [
				glyphInfo fifth installOn: aBitBlt.
			].
			aBitBlt sourceForm: glyphInfo first.
			destY _ baselineY - glyphInfo fourth. 
			aBitBlt destX: destPoint x.
			aBitBlt destY: destY.
			aBitBlt sourceOrigin: leftX @ 0.
			aBitBlt width: rightX - leftX.
			aBitBlt height: self height.
			aBitBlt copyBits.
			destPoint _ destPoint + (rightX - leftX + kernDelta @ 0).
			charIndex _ charIndex + 1.
		].
	].
	^ Array with: charIndex with: destPoint.
! !

!StrikeFont methodsFor: 'displaying' stamp: 'yo 12/20/2002 18:54'!
displayStringR2L: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta
	"You are screwed if you reach this method."
	self halt.
	aBitBlt displayString: aString 
			from: startIndex 
			to: stopIndex 
			at: aPoint 
			strikeFont: self
			kern: kernDelta.! !

!StrikeFont methodsFor: 'displaying' stamp: 'ar 4/10/2005 18:06'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) BitBlt."
	
	(aString isByteString) ifFalse: [^ self displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent.].

	^ aBitBlt displayString: aString 
			from: startIndex 
			to: stopIndex 
			at: aPoint 
			strikeFont: self
			kern: kernDelta.! !

!StrikeFont methodsFor: 'displaying' stamp: 'ar 4/10/2005 18:06'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) BitBlt."
	
	(aString isByteString) ifFalse:[^ self displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY.].

	^ aBitBlt displayString: aString 
			from: startIndex 
			to: stopIndex 
			at: aPoint 
			strikeFont: self
			kern: kernDelta.! !

!StrikeFont methodsFor: 'displaying' stamp: 'BG 3/16/2005 08:27'!
fontDisplay
	"TextStyle default defaultFont fontDisplay."

	Display restoreAfter:
		[(Form extent: 440@400) displayAt: 90@90.
		 0 to: 15 do:
			[:i |
			i storeStringHex displayAt: 100 @ (20 * i + 100).
			0 to: 15 do:
				[:j |
				((16*i+j) between: 1 and: (self xTable size - 2)) ifTrue:
					[(self characterFormAt: (16 * i + j) asCharacter)
						displayAt: (20 * j + 150) @ (20 * i + 100)]]].
			'Click to continue...' asDisplayText displayAt: 100@450]! !

!StrikeFont methodsFor: 'displaying' stamp: 'yo 1/5/2005 13:59'!
installOn: aDisplayContext

	^aDisplayContext installStrikeFont: self.
! !

!StrikeFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 15:08'!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	^aDisplayContext 
		installStrikeFont: self
		foregroundColor: foregroundColor 
		backgroundColor: backgroundColor! !

!StrikeFont methodsFor: 'displaying' stamp: 'tak 1/11/2005 18:03'!
widthOfString: aString from: firstIndex to: lastIndex
	| resultX |
	resultX _ 0.
	firstIndex to: lastIndex do:[:i | 
		resultX _ resultX + (self widthOf: (aString at: i))].
	^ resultX.
! !


!StrikeFont methodsFor: 'emphasis' stamp: 'yo 12/18/2003 23:30'!
bonk: glyphForm with: bonkForm
	"Bonking means to run through the glyphs clearing out black pixels
	between characters to prevent them from straying into an adjacent
	character as a result of, eg, bolding or italicizing"
	"Uses the bonkForm to erase at every character boundary in glyphs."
	| bb offset x |
	offset _ bonkForm offset x.
	bb _ BitBlt current toForm: glyphForm.
	bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox;
		combinationRule: Form erase; destY: 0.
	x _ self xTable.
	(x isMemberOf: SparseLargeTable) ifTrue: [
		x base to: x size-1 do: [:i | bb destX: (x at: i) + offset; copyBits].
	] ifFalse: [
		1 to: x size-1 do: [:i | bb destX: (x at: i) + offset; copyBits].
	].
! !

!StrikeFont methodsFor: 'emphasis'!
emphasis
	"Answer the integer code for synthetic bold, italic, underline, and 
	strike-out."

	^emphasis! !

!StrikeFont methodsFor: 'emphasis'!
emphasis: code 
	"Set the integer code for synthetic bold, itallic, underline, and strike-out, 
	where bold=1, italic=2, underlined=4, and struck out=8."

	emphasis _ code! !

!StrikeFont methodsFor: 'emphasis' stamp: 'di 9/3/2000 13:22'!
emphasized: code 
	"Answer a copy of the receiver with emphasis set to include code."
	| derivative addedEmphasis base safeCode |
	code = 0 ifTrue: [^ self].
	(derivativeFonts == nil or: [derivativeFonts size = 0]) ifTrue: [^ self].
	derivative _ derivativeFonts at: (safeCode _ code min: derivativeFonts size).
	derivative == nil ifFalse: [^ derivative].  "Already have this style"

	"Dont have it -- derive from another with one with less emphasis"
	addedEmphasis _ 1 bitShift: safeCode highBit - 1.
	base _ self emphasized: safeCode - addedEmphasis.  "Order is Bold, Ital, Under, Narrow"
	addedEmphasis = 1 ifTrue:   "Compute synthetic bold version of the font"
		[derivative _ (base copy ensureCleanBold name: base name , 'B') makeBoldGlyphs].
	addedEmphasis = 2 ifTrue:   "Compute synthetic italic version of the font"
		[ derivative _ (base copy name: base name , 'I') makeItalicGlyphs].
	addedEmphasis = 4 ifTrue:   "Compute underlined version of the font"
		[derivative _ (base copy name: base name , 'U') makeUnderlinedGlyphs].
	addedEmphasis = 8 ifTrue:   "Compute narrow version of the font"
		[derivative _ (base copy name: base name , 'N') makeCondensedGlyphs].
	addedEmphasis = 16 ifTrue:   "Compute struck-out version of the font"
		[derivative _ (base copy name: base name , 'X') makeStruckOutGlyphs].
	derivative emphasis: safeCode.
	derivativeFonts at: safeCode put: derivative.
	^ derivative! !

!StrikeFont methodsFor: 'emphasis' stamp: 'yo 5/24/2004 17:54'!
makeBoldGlyphs
	"Make a bold set of glyphs with same widths by ORing 1 bit to the right
		(requires at least 1 pixel of intercharacter space)"
	| g bonkForm |
	g _ glyphs deepCopy.
	bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0.
	self bonk: g with: bonkForm.
	g copyBits: g boundingBox from: g at: (1@0)
		clippingBox: g boundingBox rule: Form under fillColor: nil.
	glyphs _ g.
	fallbackFont ifNotNil: [
		fallbackFont _ fallbackFont emphasized: 1
	].
! !

!StrikeFont methodsFor: 'emphasis' stamp: 'yo 5/24/2004 17:51'!
makeCondensedGlyphs
	"Make a condensed set of glyphs with same widths.
	NOTE: this has been superceded by kerning -- should not get called"
	| g newXTable x x1 w |
	g _ glyphs deepCopy.
	newXTable _ Array new: xTable size.
	newXTable at: 1 put: (x _ xTable at: 1).
	1 to: xTable size-1 do:
		[:i | x1 _ xTable at: i.  w _ (xTable at: i+1) - x1.
		w > 1 ifTrue: [w _ w-1].  "Shrink every character wider than 1"
		g copy: (x@0 extent: w@g height) from: x1@0 in: glyphs rule: Form over.
		newXTable at: i+1 put: (x _ x + w)].
	xTable _ newXTable.
	glyphs _ g.
	fallbackFont ifNotNil: [
		fallbackFont emphasized: 8
	].

"
(TextStyle default fontAt: 1) copy makeCondensedGlyphs
	displayLine: 'The quick brown fox jumps over the lazy dog'
	at: Sensor cursorPoint
"! !

!StrikeFont methodsFor: 'emphasis' stamp: 'yo 5/24/2004 17:54'!
makeItalicGlyphs
	"Make an italic set of glyphs with same widths by skewing left and right.
	In the process, characters would overlap, so we widen them all first.
	"
	| extraWidth newGlyphs newXTable x newX w extraOnLeft |  
	extraOnLeft _ (self height-1-self ascent+4)//4 max: 0.
	extraWidth _ ((self ascent-5+4)//4 max: 0) + extraOnLeft.
	newGlyphs _ Form extent: (glyphs width + (maxAscii + 1 - minAscii*extraWidth)) @ glyphs height.
	newXTable _ xTable copy.

	"Copy glyphs into newGlyphs with room on left and right for overlap."
	minAscii to: maxAscii+1 do:
		[:ascii | x _ xTable at: ascii+1.  w _ (xTable at: ascii+2) - x.
		newX _ newXTable at: ascii+1.
		newGlyphs copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height)
			from: x @ 0 in: glyphs rule: Form over.
		newXTable at: ascii+2 put: newX + w + extraWidth].		
	glyphs _ newGlyphs. 
	xTable _ newXTable.
	"Slide the bitmaps left and right for synthetic italic effect."
	4 to: self ascent-1 by: 4 do:
		[:y | 		"Slide ascenders right..."
		glyphs copy: (1@0 extent: glyphs width @ (self ascent - y))
			from: 0@0 in: glyphs rule: Form over].
	self ascent to: self height-1 by: 4 do:
		[:y | 		"Slide descenders left..."
		glyphs copy: (0@y extent: glyphs width @ glyphs height)
			from: 1@y in: glyphs rule: Form over].
	fallbackFont ifNotNil: [
		fallbackFont _ fallbackFont emphasized: 2
	].

! !

!StrikeFont methodsFor: 'emphasis' stamp: 'yo 5/24/2004 17:54'!
makeStruckOutGlyphs
	"Make a struck-out set of glyphs with same widths"
	| g |
	g _ glyphs deepCopy.
	g fillBlack: (0 @ (self ascent - (self ascent//3)) extent: g width @ 1).
	glyphs _ g.
	fallbackFont ifNotNil: [
		fallbackFont _ fallbackFont emphasized: 16
	].
! !

!StrikeFont methodsFor: 'emphasis' stamp: 'yo 5/24/2004 17:54'!
makeUnderlinedGlyphs
	"Make an underlined set of glyphs with same widths"
	| g |
	g _ glyphs deepCopy.
	g fillBlack: (0 @ (self ascent+1) extent: g width @ 1).
	glyphs _ g.
	fallbackFont ifNotNil: [
		fallbackFont _ fallbackFont emphasized: 4
	].
! !

!StrikeFont methodsFor: 'emphasis' stamp: 'nk 3/15/2004 18:46'!
releaseCachedState

	self reset.! !

!StrikeFont methodsFor: 'emphasis' stamp: 'tak 3/11/2005 17:09'!
reset
	"Reset the cache of derivative emphasized fonts"

	| style font |
	fallbackFont class = FixedFaceFont
		ifTrue: [fallbackFont _ nil].
	derivativeFonts _ Array new: 32.
	#('B' 'I' 'BI') doWithIndex:
		[:tag :index | 
		(style _ TextStyle named: self familyName) ifNotNil:
			[(font _ style fontArray
				detect: [:each | each name = (self name , tag)]
				ifNone: [nil]) ifNotNil: [derivativeFonts at: index put: font]]]! !


!StrikeFont methodsFor: 'file in/out' stamp: 'ar 5/23/2000 12:50'!
buildfontNamed: nm fromForms: forms startingAtAscii: startAscii
	ascent: a descent: d maxWid: m
	"This builds a StrikeFont instance from existing forms."

	| lastAscii width ascii charForm missingForm tempGlyphs |
	name _ nm.
	ascent _ 11.
	descent _ 3.
	maxWidth _ 16.
	pointSize _ 8.
	name _ (name copyWithout: Character space) ,
				(pointSize < 10
					ifTrue: ['0' , pointSize printString]
					ifFalse: [pointSize printString]).
	minAscii _ 258.
	maxAscii _ 0.
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ 0.
	type _ 0.  "ignored for now"

	tempGlyphs _ Form extent: (maxWidth*257) @ self height.
	xTable _ (Array new: 258) atAllPut: 0.
	xTable at: 1 put: 0.

	"Read character forms and blt into tempGlyphs"
	lastAscii _ -1.
	1 to: forms size do:
		[:i | charForm _ forms at: i. width _ charForm width.
		ascii _ startAscii-1+i.
		self displayChar: ascii form: charForm.
		ascii = 256
			ifTrue: [missingForm _ charForm deepCopy]
			ifFalse:
			[minAscii _ minAscii min: ascii.
			maxAscii _ maxAscii max: ascii.
			lastAscii+1 to: ascii-1 do: [:as | xTable at: as+2 put: (xTable at: as+1)].
			tempGlyphs copy: ((xTable at: ascii+1)@0
									extent: charForm extent)
						from: 0@0 in: charForm rule: Form over.
			xTable at: ascii+2 put: (xTable at: ascii+1) + width.
			lastAscii _ ascii]].
	lastAscii+1 to: maxAscii+1 do: [:as | xTable at: as+2 put: (xTable at: as+1)].
	missingForm == nil ifFalse:
		[tempGlyphs copy: missingForm boundingBox from: missingForm
				to: (xTable at: maxAscii+2)@0 rule: Form over.
		xTable at: maxAscii+3 put: (xTable at: maxAscii+2) + missingForm width].
	glyphs _ Form extent: (xTable at: maxAscii+3) @ self height.
	glyphs copy: glyphs boundingBox from: 0@0 in: tempGlyphs rule: Form over.
	xTable _ xTable copyFrom: 1 to: maxAscii+3.
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'file in/out'!
displayChar: ascii form: charForm
	"Convenience utility used during conversion of BitFont files"
	| m bigForm |
	Display fillBlack: (0@0 extent: 20@14).
	ascii printString displayAt: 0@2.
	charForm width > 0 ifTrue:
		[m _ 5.
		bigForm _ charForm magnify: charForm boundingBox by: m@m.
		Display border: ((bigForm boundingBox expandBy: m) translateBy: 50@2) width: m.
		bigForm displayAt: 50@2.
		Display fillBlack: ((50@2)+((m*charForm width)@0) extent: 1@(m*self height))].! !

!StrikeFont methodsFor: 'file in/out' stamp: 'md 11/14/2003 17:25'!
newFromStrike: fileName
	"Build an instance from the strike font file name. The '.strike' extension
	is optional."

	| strike startName raster16 |
	name _ fileName copyUpTo: $..	"assumes extension (if any) is '.strike'"
	strike _ FileStream readOnlyFileNamed: name, '.strike.'.
	strike binary.

	"strip off direcory name if any"
	startName _ name size.
	[startName > 0 and: [((name at: startName) ~= $>) & ((name at: startName) ~= $])]]
		whileTrue: [startName _ startName - 1].
	name _ name copyFrom: startName+1 to: name size.

	type			_		strike nextWord.		"type is ignored now -- simplest
												assumed.  Kept here to make
												writing and consistency more
												straightforward."
	minAscii		_		strike nextWord.
	maxAscii		_		strike nextWord.
	maxWidth		_		strike nextWord.
	strikeLength	_		strike nextWord.
	ascent			_		strike nextWord.
	descent			_		strike nextWord.
	"xOffset			_"		strike nextWord. 	
	raster16			_		strike nextWord.	
	superscript		_		ascent - descent // 3.	
	subscript		_		descent - ascent // 3.	
	emphasis		_		0.
	glyphs			_	Form extent: (raster16 * 16) @ (self height)  
							offset: 0@0.
		glyphs bits fromByteStream: strike.

	xTable _ (Array new: maxAscii + 3) atAllPut: 0.
	(minAscii + 1 to: maxAscii + 3) do:
		[:index | xTable at: index put: strike nextWord].

	"Set up space character"
	((xTable at: (Space asciiValue + 2))  = 0 or:
			[(xTable at: (Space asciiValue + 2)) = (xTable at: (Space asciiValue + 1))])
		ifTrue:	[(Space asciiValue + 2) to: xTable size do:
					[:index | xTable at: index put: ((xTable at: index) + DefaultSpace)]].
	strike close.
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'file in/out' stamp: 'tk 9/28/2000 15:50'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to a known Font in the other system instead.  "

	"A path to me"
	(TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self].
		"special case for saving the default fonts on the disk.  See collectionFromFileNamed:"

	dp _ DiskProxy global: #StrikeFont selector: #familyName:size:emphasized:
			args: (Array with: self familyName   with: self height
					with: self emphasis).
	refStrm replace: self with: dp.
	^ dp! !

!StrikeFont methodsFor: 'file in/out' stamp: 'sma 6/1/2000 09:32'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self name;
		space;
		print: self height;
		nextPut: $)! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ar 10/25/2005 00:21'!
readBDFFromFile: fileName name: aString 
	"This builds a StrikeFont instance by reading the X11 Binary 
	Distribution Format font source file.  See the BDFFontReader class
	comment."

	"StrikeFont new readBDFFromFile: 'helvR12' name: 'Helvetica12'."

	| fontReader stream |
	fontReader := BDFFontReader openFileNamed: fileName.
	stream := ReadStream on: fontReader read.
	xTable := stream next.
	glyphs := stream next.
	minAscii := stream next.
	maxAscii := stream next.
	maxWidth := stream next.
	ascent := stream next.
	descent := stream next.
	pointSize := stream next.
	name := aString.
"	xTable size <= 256 ifTrue: [self setStopConditions]."
	type := 0.	"no one see this"
	superscript := (ascent - descent) // 3.
	subscript := (descent - ascent) // 3.
	emphasis := 0.
	self reset! !

!StrikeFont methodsFor: 'file in/out'!
readBFHeaderFrom: f
	name _ self restOfLine: 'Font name = ' from: f.
	ascent _ (self restOfLine: 'Ascent = ' from: f) asNumber.
	descent _ (self restOfLine: 'Descent = ' from: f) asNumber.
	maxWidth _ (self restOfLine: 'Maximum width = ' from: f) asNumber.
	pointSize _ (self restOfLine: 'Font size = ' from: f) asNumber.
	name _ (name copyWithout: Character space) ,
				(pointSize < 10
					ifTrue: ['0' , pointSize printString]
					ifFalse: [pointSize printString]).
	minAscii _ 258.
	maxAscii _ 0.
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ 0.
	type _ 0.  "ignored for now"
! !

!StrikeFont methodsFor: 'file in/out' stamp: 'yo 11/30/2003 17:08'!
readEFontBDFForJapaneseFromFile: fileName name: aString overrideWith: otherFileName

	| fontReader stream |
	fontReader _ EFontBDFFontReaderForRanges readOnlyFileNamed: fileName.
	stream _ ReadStream on: (fontReader readRanges: fontReader rangesForJapanese overrideWith: otherFileName otherRanges: {Array with: 8481 with: 12320} additionalOverrideRange: fontReader additionalRangesForJapanese).
	xTable _ stream next.
	glyphs _ stream next.
	minAscii _ stream next.
	maxAscii _ stream next.
	maxWidth _ stream next.
	ascent _ stream next.
	descent _ stream next.
	pointSize _ stream next.
	name _ aString.
	type _ 0. "no one see this"
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ 0.
	self reset.
! !

!StrikeFont methodsFor: 'file in/out' stamp: 'yo 1/15/2004 16:48'!
readEFontBDFForKoreanFromFile: fileName name: aString overrideWith: otherFileName

	| fontReader stream |
	fontReader _ EFontBDFFontReaderForRanges readOnlyFileNamed: fileName.
	stream _ ReadStream on: (fontReader readRanges: fontReader rangesForKorean overrideWith: otherFileName otherRanges: {Array with: 8481 with: 12320} additionalOverrideRange: fontReader additionalRangesForKorean).
	xTable _ stream next.
	glyphs _ stream next.
	minAscii _ stream next.
	maxAscii _ stream next.
	maxWidth _ stream next.
	ascent _ stream next.
	descent _ stream next.
	pointSize _ stream next.
	name _ aString.
	type _ 0. "no one see this"
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ 0.
	self reset.
! !

!StrikeFont methodsFor: 'file in/out' stamp: 'yo 12/28/2002 21:02'!
readEFontBDFFromFile: fileName name: aString rangeFrom: startRange to: endRange

	| fontReader stream |
	fontReader _ EFontBDFFontReader readOnlyFileNamed: fileName.
	stream _ ReadStream on: (fontReader readFrom: startRange to: endRange).
	xTable _ stream next.
	glyphs _ stream next.
	minAscii _ stream next.
	maxAscii _ stream next.
	maxWidth _ stream next.
	ascent _ stream next.
	descent _ stream next.
	pointSize _ stream next.
	name _ aString.
	type _ 0. "no one see this"
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ 0.
	self reset.
! !

!StrikeFont methodsFor: 'file in/out' stamp: 'yo 1/19/2005 11:22'!
readEFontBDFFromFile: fileName name: aString ranges: ranges

	| fontReader stream |
	fontReader _ EFontBDFFontReaderForRanges readOnlyFileNamed: fileName.
	stream _ ReadStream on: (fontReader readRanges: ranges).
	xTable _ stream next.
	glyphs _ stream next.
	minAscii _ stream next.
	maxAscii _ stream next.
	maxWidth _ stream next.
	ascent _ stream next.
	descent _ stream next.
	pointSize _ stream next.
	name _ aString.
	type _ 0. "no one see this"
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ 0.
	self reset.
! !

!StrikeFont methodsFor: 'file in/out' stamp: 'yo 9/23/2002 16:30'!
readF12FromStream: aStream

	| box blt |
	minAscii _ 0.
	maxAscii _ 94*94.
	ascent _ 12.
	descent _ 0.
	pointSize _ 12.
	superscript _ 0.
	subscript _ 0.
	emphasis _ 0.
	maxWidth _ 12.
	
	box _ Form extent: 12@12.
	glyphs  _ Form extent: (94*94*12)@12.
	blt _ BitBlt toForm: glyphs. 
	xTable _ XTableForFixedFont new.
	xTable maxAscii: maxAscii + 3.
	xTable width: 12.
	1 to: 256 do:  [:index | 
		1 to: 12 do: [:i |
			aStream next.
		].
	].
	(minAscii + 1 to: 94*94) do:  [:index | 
		self readCharacter: (box bits) from: aStream.
		blt copy: ((12*(index-1))@0 extent: 12@12) from: 0@0 in: box.
	].
! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ar 5/23/2000 12:50'!
readFromBitFont: fileName
	"This builds a StrikeFont instance by reading the data file format
	produced by BitFont, a widely available font conversion utility
	written by Peter DiCamillo at Brown University"
	"StrikeFont new readFromBitFont: 'Palatino10.BF' "
	| f lastAscii charLine width ascii charForm line missingForm tempGlyphs iRect p rectLine left tokens right |
	f _ FileStream readOnlyFileNamed: fileName.
	self readBFHeaderFrom: f.

	"NOTE: if font has been scaled (and in any case),
	the REAL bitmap dimensions come after the header."
	self restOfLine: 'Extent information for entire font' from: f.
	"Parse the following line (including mispelling!!)"
	"Image rectange: left = -2, right = 8, bottom = -2, top = 7"
	tokens _ (f upTo: Character cr)  findTokens: ' '.
	iRect _ Rectangle left: (tokens at: 5) asNumber right: (tokens at: 8) asNumber
				top: (tokens at: 14) asNumber bottom: (tokens at: 11) asNumber.
	ascent _ iRect top.
	descent _ iRect bottom negated.
	
	tempGlyphs _ Form extent: (maxWidth*257) @ self height.
	xTable _ (Array new: 258) atAllPut: 0.
	xTable at: 1 put: 0.

	"Read character forms and blt into tempGlyphs"
	lastAscii _ -1.
	[charLine _ self restOfLine: 'Character: ' from: f.
	charLine == nil ifFalse:
		[p _ f position.
		rectLine _ f upTo: Character cr.
		(rectLine beginsWith: 'Image rectange: left = ')
			ifTrue: [tokens _ rectLine findTokens: ' '.
					left _ (tokens at: 5) asNumber. right _ (tokens at: 8) asNumber]
			ifFalse: [left _ right _ 0. f position: p].
		width_ (self restOfLine: 'Width (final pen position) = ' from: f) asNumber - left
					max: (right-left+1).
		(charLine beginsWith: 'Missing character') ifTrue: [ascii _ 256].
		('x''*' match: charLine) ifTrue:
			[ascii _ Number readFrom: (charLine copyFrom: 3 to: 4) asUppercase base: 16].
		charForm _ Form extent: width@self height.
		('*[all blank]' match: charLine) ifFalse:
			[self restOfLine: '  +' from: f.
			1 to: self height do:
				[:y | line _ f upTo: Character cr.
				4 to: (width + 3 min: line size + iRect left - left) do:
					[:x | (line at: x - iRect left + left) = $*
						ifTrue: [charForm pixelValueAt: (x-4)@(y-1) put: 1]]]]].
	charLine == nil]
		whileFalse:
			[self displayChar: ascii form: charForm.
			ascii = 256
				ifTrue: [missingForm _ charForm deepCopy]
				ifFalse:
				[minAscii _ minAscii min: ascii.
				maxAscii _ maxAscii max: ascii.
				lastAscii+1 to: ascii-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)].
				tempGlyphs copy: ((xTable at: ascii+1)@0
										extent: charForm extent)
							from: 0@0 in: charForm rule: Form over.
				xTable at: ascii+2 put: (xTable at: ascii+1) + width.
				lastAscii _ ascii]].
	f close.
	lastAscii+1 to: maxAscii+1 do: [:a | xTable at: a+2 put: (xTable at: a+1)].
	missingForm == nil ifFalse:
		[tempGlyphs copy: missingForm boundingBox from: missingForm
				to: (xTable at: maxAscii+2)@0 rule: Form over.
		xTable at: maxAscii+3 put: (xTable at: maxAscii+2) + missingForm width].
	glyphs _ Form extent: (xTable at: maxAscii+3) @ self height.
	glyphs copy: glyphs boundingBox from: 0@0 in: tempGlyphs rule: Form over.
	xTable _ xTable copyFrom: 1 to: maxAscii+3.
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ar 5/23/2000 12:53'!
readFromStrike2Stream: file 
	"Build an instance from the supplied binary stream on data in strike2 format"
	type _ file nextInt32.  type = 2 ifFalse: [file close. self error: 'not strike2 format'].
	minAscii _ file nextInt32.
	maxAscii _ file nextInt32.
	maxWidth _ file nextInt32.
	ascent _ file nextInt32.
	descent _ file nextInt32.
	pointSize _ file nextInt32.
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ file nextInt32.
	xTable _ (Array new: maxAscii + 3) atAllPut: 0.
	(minAscii + 1 to: maxAscii + 3) do:
		[:index | xTable at: index put: file nextInt32].
	glyphs _ Form new readFrom: file.

	"Set up space character"
	((xTable at: (Space asciiValue + 2))  = 0 or:
			[(xTable at: (Space asciiValue + 2)) = (xTable at: (Space asciiValue + 1))])
		ifTrue:	[(Space asciiValue + 2) to: xTable size do:
					[:index | xTable at: index put: ((xTable at: index) + DefaultSpace)]].
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'file in/out' stamp: 'sma 12/30/1999 14:20'!
readFromStrike2: fileName  "StrikeFont new readFromStrike2: 'Palatino14.sf2'"
	"Build an instance from the strike font stored in strike2 format.
	fileName is of the form: <family name><pointSize>.sf2"
	| file |
	('*.sf2' match: fileName) ifFalse: [self halt.  "likely incompatible"].
	name _ fileName copyUpTo: $. .  "Drop filename extension"
	file _ FileStream readOnlyFileNamed: fileName.
	file binary.
	[self readFromStrike2Stream: file] ensure: [file close]! !

!StrikeFont methodsFor: 'file in/out'!
restOfLine: leadString from: file
	"Utility method to assist reading of BitFont data files"
	| line |
	[line _ file upTo: Character cr.
	line size < leadString size or: [leadString ~= (line copyFrom: 1 to: leadString size)]]
	whileTrue: [file atEnd ifTrue: [^ nil]].
	^ line copyFrom: leadString size+1 to: line size! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ls 4/11/2000 18:57'!
writeAsStrike2named: fileName
	"Write me onto a file in strike2 format.
	fileName should be of the form: <family name><pointSize>.sf2"
	| file |
	file _ FileStream fileNamed: fileName.
	self writeAsStrike2On: file.
	file close.! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ls 3/27/2000 17:43'!
writeAsStrike2On: file
	"Write me onto a file in strike2 format.
	fileName should be of the form: <family name><pointSize>.sf2"
	file binary.
	file nextInt32Put: 2.
	file nextInt32Put: minAscii.
	file nextInt32Put: maxAscii.
	file nextInt32Put: maxWidth.
	file nextInt32Put: ascent.
	file nextInt32Put: descent.
	file nextInt32Put: pointSize.
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	file nextInt32Put: emphasis.
	(minAscii + 1 to: maxAscii + 3) do:
		[:index | file nextInt32Put: (xTable at: index)].
	glyphs writeOn: file.
	file close.
! !


!StrikeFont methodsFor: 'Mac reader'!
aComment
	"To read Mac font resources.  
1) Use ResEdit in the Fonts folder in the System Folder.  Open the file of the Font you want.  (A screen font, not a TrueType outline font).
2) Open the FOND resource and scroll down to the list of sizes and resource numbers. Note the resource number of the size you want.
3) Open the NFNT resource.  Click on the number you have noted.
4) Choose 'Open Using Hex Editor' from the resource editor.
5) Copy all of the hex numbers and paste into a text editor.  Save the file into the Smalltalk folder under the name 'FontName 12 hex' (or other size).
6) Enter the fileName below and execute: 

TextStyle default fontAt: 8 put: (StrikeFont new readMacFontHex: 'fileName').

Select text and type Command-7 to change it to your new font.

(There is some problem in the ParagraphEditor with the large size of Cairo 18.  Its line heights are not the right.)
	"! !

!StrikeFont methodsFor: 'Mac reader'!
fixKerning: extraWidth
	"Insert one pixel (extraWidth) between each character.  And add the bits for the space character"
	"Create a space character Form.  Estimate width by ascent / 2 - 1"
	| characterForm char leftX |
	characterForm _ Form extent: (ascent//2 - 1) @ self height.
	self characterFormAt: $  put: characterForm.

	"Put one pixel of space after every character.  Mac fonts have no space in the bitmap."
	extraWidth <= 0 ifTrue: [^ self].
	minAscii to: maxAscii do: [:ascii |
		char _ Character value: ascii.
		leftX _ xTable at: ascii + 1.
		characterForm _ Form extent: 
			((self widthOf: char) + extraWidth) @ self height.
		characterForm 
			copy: (characterForm boundingBox extendBy: 
				(0-extraWidth@0))
			from: leftX@0 in: glyphs rule: Form over.
		self characterFormAt: char put: characterForm.
		].	! !

!StrikeFont methodsFor: 'Mac reader' stamp: 'ar 5/23/2000 12:49'!
readMacFontHex: fileName
	"Read the hex version of a Mac FONT type resource.  See the method aComment for how to prepare the input file. 4/26/96 tk"
	| file hh fRectWidth |
	name _ fileName.	"Palatino 12"
	file _ FileStream readOnlyFileNamed: fileName, ' hex'.

	"See Inside Macintosh page IV-42 for this record"
	"FontType _ " Number readFrom: (file next: 4) base: 16.
	emphasis		_		0.
	minAscii _ Number readFrom: (file next: 4) base: 16.
	maxAscii _ Number readFrom: (file next: 4) base: 16.
	maxWidth		_ Number readFrom: (file next: 4) base: 16.
	"kernMax _ " Number readFrom: (file next: 4) base: 16.
	"NDescent _ " Number readFrom: (file next: 4) base: 16.
	fRectWidth _  Number readFrom: (file next: 4) base: 16.
	hh _  Number readFrom: (file next: 4) base: 16.
	"OWTLoc _ " Number readFrom: (file next: 4) base: 16.
	ascent			_ Number readFrom: (file next: 4) base: 16.
	descent			_ Number readFrom: (file next: 4) base: 16.
	"leading _ " Number readFrom: (file next: 4) base: 16.
	xOffset			_		0. 	
	raster			_ Number readFrom: (file next: 4) base: 16.

	strikeLength	_		raster*16.
	superscript		_		ascent - descent // 3.	
	subscript		_		descent - ascent // 3.	
	self strikeFromHex: file width: raster height: hh.
	self xTableFromHex: file.
	file close.

	"Insert one pixel between each character.  And add space character."
	self fixKerning: (fRectWidth - maxWidth).	

	"Recompute character to glyph mapping"
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'Mac reader'!
strikeFromHex: file width: w height: h
	"read in just the raw strike bits from a hex file.  No spaces or returns.  W is in words (2 bytes), h in pixels." 
	| newForm theBits offsetX offsetY str num cnt |
	offsetX  _ 0.
	offsetY _ 0.
	offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536]. "stored two's-complement"
	offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536]. "stored two's-complement"
	newForm _ Form extent: strikeLength @ h offset: offsetX @ offsetY.
	theBits _ newForm bits.
	cnt _ 0.		"raster may be 16 bits, but theBits width is 32" 
	1 to: theBits size do: [:i | 
		(cnt _ cnt + 32) > strikeLength 
		  ifTrue: [cnt _ 0.
			num _ Number readFrom: (str _ file next: 4) base: 16]
		  ifFalse: [
			cnt = strikeLength ifTrue: [cnt _ 0].
			num _ Number readFrom: (str _ file next: 8) base: 16].
		theBits at: i put: num].
	glyphs _ newForm.! !

!StrikeFont methodsFor: 'Mac reader'!
xTableFromHex: file

	| strike num str wid |
	strike _ file.
	xTable _ (Array new: maxAscii + 3) atAllPut: 0.
	(minAscii + 1 to: maxAscii + 3) do:
		[:index | 
			num _ Number readFrom: (str _ strike next: 4) base: 16. 
			xTable at: index put: num].

	1 to: xTable size - 1 do: [:ind |
		wid _ (xTable at: ind+1) - (xTable at: ind).
		(wid < 0) | (wid > 40) ifTrue: [
			file close.
			self error: 'illegal character width']].
! !


!StrikeFont methodsFor: 'make arrows' stamp: 'sps 10/15/2003 17:06'!
makeAssignArrow
"Replace the underline character with an arrow for this font"

	| arrowForm arrowCanvas arrowY arrowLeft arrowRight arrowHeadLength |

	arrowForm _ (self characterFormAt: $_) copy.
	arrowCanvas _ arrowForm getCanvas.
	arrowCanvas fillColor: Color white.
	arrowY _ arrowForm height // 2.
	arrowLeft _ 0. 
	arrowRight _ arrowForm width - 2.
	arrowHeadLength _ (arrowRight - arrowLeft) * 2 // 5.
	"Draw the lines"
	arrowCanvas line: (arrowLeft@arrowY) to: (arrowRight@arrowY) color: Color black.
	arrowCanvas 
		line: (arrowLeft@arrowY) 
		to: ((arrowLeft + arrowHeadLength)@(arrowY - arrowHeadLength)) 
		color: Color black.
	arrowCanvas 
		line: (arrowLeft@arrowY) 
		to: ((arrowLeft + arrowHeadLength)@(arrowY + arrowHeadLength)) 
		color: Color black.

	"Replace the glyph"
	self characterFormAt: $_ put: arrowForm.

! !

!StrikeFont methodsFor: 'make arrows' stamp: 'sps 10/15/2003 17:06'!
makeReturnArrow
"Replace the caret character with an arrow"

	| arrowForm arrowCanvas arrowHeadLength arrowX arrowTop arrowBottom |

	arrowForm _ (self characterFormAt: $^) copy.
	arrowCanvas _ arrowForm getCanvas.
	arrowCanvas fillColor: Color white.

	arrowHeadLength _ ((arrowForm width - 2)// 2).
	arrowX _ (arrowHeadLength max: (arrowForm width // 2)).
	arrowTop _ arrowForm height // 4. 
	arrowBottom _ (arrowTop + (arrowForm width * 4 // 5 )).
	arrowBottom _ (arrowBottom min: arrowForm height) max: (arrowForm height * 2 // 3).

	"Draw the lines"
	arrowCanvas line: (arrowX@arrowTop) to: (arrowX@arrowBottom) color: Color black.
	arrowCanvas 
		line: (arrowX@arrowTop) 
		to: ((arrowX - arrowHeadLength)@(arrowTop + arrowHeadLength)) 
		color: Color black.
	arrowCanvas 
		line: (arrowX@arrowTop) 
		to: ((arrowX + arrowHeadLength)@(arrowTop + arrowHeadLength)) 
		color: Color black.

	"Replace the glyph"
	self characterFormAt: $^ put: arrowForm.

! !


!StrikeFont methodsFor: 'multibyte character methods' stamp: 'yo 3/18/2004 00:10'!
fixAccuISO8859From: aStrikeFont

	| f |
	self reset.
	xTable _ aStrikeFont xTable copy.
	glyphs _ Form extent: aStrikeFont glyphs extent.
	maxAscii _ 255.
	minAscii _ 0.
	"stopConditions _ nil."

	0 to: 127 do: [:i |
		f _ aStrikeFont characterFormAt: (Character value: i) isoToSqueak.
		f width  = 0 ifTrue: [f _ Form extent: 1@f height].
		
		self characterFormAt: (Character value: i) put: f.
	].
	128 to: 159 do: [:i |
		f _ Form extent: 1@f height.
		self characterFormAt: (Character value: i) put: f.
	].
	160 to: 255 do: [:i |
		f _ aStrikeFont characterFormAt: (Character value: i) isoToSqueak.
		f width  = 0 ifTrue: [f _ Form extent: 1@f height].
		
		self characterFormAt: (Character value: i) put: f.
	].
		
	^ self.	
! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: 'yo 11/12/2002 12:56'!
fixAscent: a andDescent: d head: h

	| bb newGlyphs |
	"(a + d) = (ascent + descent) ifTrue: ["
		ascent _ a.
		descent _ d.
		newGlyphs _ Form extent: (glyphs width@(h + glyphs height)).
		bb _ BitBlt toForm: newGlyphs.
		bb copy: (0@h extent: (glyphs extent)) from: 0@0 in: glyphs
			fillColor: nil rule: Form over.
		glyphs _ newGlyphs.
	"]."
! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: 'yo 9/16/2002 15:07'!
fixForISO8859From: aStrikeFont

	| fixer m mappingTable |
	fixer _ StrikeFontFixer newOn: aStrikeFont.
	self reset.
	xTable _ aStrikeFont xTable copy.
	glyphs _ Form extent: aStrikeFont glyphs extent.
	maxAscii _ 255.
	minAscii _ 0.
	mappingTable _ fixer mappingTable.
	"stopConditions _ nil."

	0 to: 255 do: [:i |
		(m _ mappingTable at: i+1) ~= nil ifTrue: [
			self characterFormAt: (Character value: i)
				put: (aStrikeFont characterFormAt: (Character value: m)).
		] ifFalse: [
			self characterFormAt: (Character value: i)
				put: (aStrikeFont characterFormAt: (Character space)).
		]
	].
	^self.	
! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: 'yo 8/28/2002 16:35'!
fixXTable

	| newXTable val |
	xTable size >= 258 ifTrue: [
		^ self.
	].

	newXTable _ Array new: 258.
	1 to: xTable size do: [:i |
		newXTable at: i put: (xTable at: i).
	].

	val _ xTable at: (xTable size).
	
	xTable size + 1 to: 258 do: [:i |
		newXTable at: i put: val.
	].
	minAscii _ 0.
	maxAscii _ 255.
	xTable _ newXTable.
! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: 'yo 1/6/2005 04:18'!
hasGlyphOf: aCharacter

	| code |
	code _ aCharacter charCode.
	((code between: self minAscii and: self maxAscii) not) ifTrue: [
		^ false.
	].
	(xTable at: code + 1) < 0 ifTrue: [
		^ false.
	].
	^ true.
! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: 'yo 8/28/2002 16:37'!
readCharacter: aBits from: aStream

	| pos |
	pos _ 0.
	12 timesRepeat: [
		1 to: 2 do: [ :w |
			aBits byteAt: (pos+w) put: (aStream next ). 
		].
		pos _ pos + 4.
	].
! !

!StrikeFont methodsFor: 'multibyte character methods' stamp: 'yo 5/24/2004 23:11'!
setupDefaultFallbackFont

	| fonts f |
	fonts _ TextStyle default fontArray.
	f _ fonts first.
	1 to: fonts size do: [:i |
		self height > (fonts at: i) height ifTrue: [f _ fonts at: i].
	].
	self fallbackFont: f.
	self reset.

! !


!StrikeFont methodsFor: 'testing'!
checkCharacter: character 
	"Answer a Character that is within the ascii range of the receiver--either 
	character or the last character in the receiver."

	| ascii |  
	ascii _ character asciiValue.
	((ascii < minAscii) or: [ascii > maxAscii])
			ifTrue: [^maxAscii asCharacter]
			ifFalse:	[^character]
! !


!StrikeFont methodsFor: '*nebraska-file in/out' stamp: 'yo 12/17/2005 20:36'!
encodedForRemoteCanvas

	| stream |
	stream := RWBinaryOrTextStream on: ''.
	stream nextPutAll: self familyName.
	stream nextPut: Character space.
	stream nextPutAll: self name.
	stream nextPut: Character space.
	stream nextPutAll: self height.
	stream nextPut: Character space.
	stream nextPutAll: self emphasis asString.
	^ stream contents asString.
! !


!StrikeFont methodsFor: 'private' stamp: 'yo 3/11/2005 07:38'!
createCharacterToGlyphMap
        "Private. Create the character to glyph mapping for a font that didn't have any before. This is basically equivalent to what the former setStopCondition did, only based on indexes."

        maxAscii < 256 ifTrue: [^ (1 to: 256) collect: [:i | i - 1]].
        ^ nil.
! !

!StrikeFont methodsFor: 'private' stamp: 'yo 5/20/2004 10:51'!
leftAndRighOrNilFor: char

	| code leftX |
	code _ char charCode.
	((code between: self minAscii and: self maxAscii) not) ifTrue: [
		code _ $? charCode.
	].
	leftX _ xTable at: code + 1.
	leftX < 0 ifTrue: [
		code _ $? charCode.
		leftX _ xTable at: code + 1.
	].
	^ Array with: leftX with: (xTable at: code + 2).
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StrikeFont class
	instanceVariableNames: ''!

!StrikeFont class methodsFor: 'accessing' stamp: 'nk 9/1/2004 11:00'!
actualFamilyNames
	"Answer a sorted list of actual family names, without the Default aliases"

	^(self familyNames copyWithoutAll: TextStyle defaultFamilyNames) asOrderedCollection! !

!StrikeFont class methodsFor: 'accessing' stamp: 'ar 2/3/2002 23:04'!
familyName: aName pointSize: aSize
	"Answer a font (or the default font if the name is unknown) in the specified size."

	^ ((TextStyle named: aName asSymbol) ifNil: [TextStyle default]) fontOfPointSize: aSize! !

!StrikeFont class methodsFor: 'accessing' stamp: 'ar 11/25/2004 15:19'!
familyName: aName size: aSize
	"Answer a font (or the default font if the name is unknown) in the specified size."
	| style |
	style := TextStyle named: aName asSymbol.
	style ifNil: [^(FontSubstitutionDuringLoading forFamilyName: aName pixelSize: aSize)
			signal: 'missing font' ].
	^style fontOfSize: aSize! !

!StrikeFont class methodsFor: 'accessing' stamp: 'sma 12/30/1999 13:48'!
familyNames
	^ (TextConstants select: [:each | each isKindOf: TextStyle]) keys asSortedCollection! !

!StrikeFont class methodsFor: 'accessing' stamp: 'tak 11/11/2004 21:14'!
setupDefaultFallbackFont
"
	StrikeFont setupDefaultFallbackFont
"

	(#(#Accuat #Accujen #Accula #Accumon #Accusf #Accushi #Accuve #Atlanta) collect: [:e | TextStyle named: e]) do: [:style |
		style fontArray do: [:e |
			e reset.
			e setupDefaultFallbackFont.
		].
	].
	TTCFont allSubInstances
		do: [:font | font reset.
			font setupDefaultFallbackFont]

! !


!StrikeFont class methodsFor: 'derivative font caching' stamp: 'tak 3/11/2005 16:27'!
shutDown  "StrikeFont shutDown"
	"Deallocate synthetically derived copies of base fonts to save space"
	self allSubInstancesDo: [:sf | sf reset].
	StrikeFontSet allSubInstancesDo: [:sf | sf reset].
	DefaultStringScanner _ nil.
! !


!StrikeFont class methodsFor: 'examples'!
convertFontsNamed: familyName  " StrikeFont convertFontsNamed: 'NewYork' "
	"This utility is for use after you have used BitFont to produce data files 
	for the fonts you wish to use.  It will read the BitFont files and then 
	write them out in strike2 (*.sf2) format which is much more compact,
	and which can be read in again very quickly."
	"For this utility to work as is, the BitFont data files must be named
	'familyNN.BF', and must reside in the same directory as the image."
	| f |
	(FileDirectory default fileNamesMatching: familyName , '*.BF') do:
		[:fname | Transcript cr; show: fname.
		f _ StrikeFont new readFromBitFont: fname.
		f writeAsStrike2named: f name , '.sf2']! !

!StrikeFont class methodsFor: 'examples'!
example
	"Displays a line of text on the display screen at the location of the cursor.
	Example depends on the strike font file, 'TimesRoman10.strike'. existing."

	(StrikeFont new readFromStrike2: 'NewYork12.sf2')
		displayLine: 'A line of 12-pt text in New York style' at: Sensor cursorPoint
	 
	"StrikeFont example."! !

!StrikeFont class methodsFor: 'examples' stamp: 'tpr 6/10/2005 16:07'!
readStrikeFont2Family: familyName 
	"StrikeFont readStrikeFont2Family: 'Lucida'"
	^self readStrikeFont2Family: familyName fromDirectory: FileDirectory default! !

!StrikeFont class methodsFor: 'examples' stamp: 'tpr 6/10/2005 16:07'!
readStrikeFont2Family: familyName fromDirectory: aDirectory
	"StrikeFont readStrikeFont2Family: 'Lucida' fromDirectory: FileDirectory default"
	"This utility reads all available .sf2 StrikeFont files for a given family from  
	the current directory. It returns an Array, sorted by size, suitable for handing 
	to TextStyle newFontArray: ."
	"For this utility to work as is, the .sf2 files must be named 'familyNN.sf2'."
	| fileNames strikeFonts fontArray |
	fileNames _ aDirectory fileNamesMatching: familyName , '##.sf2'.
	strikeFonts _ fileNames collect: [:fname | StrikeFont new readFromStrike2: fname].
	strikeFonts do: [ :font | font reset ].
	strikeFonts _ strikeFonts asSortedCollection: [:a :b | a height < b height].
	fontArray _ strikeFonts asArray.
	^ fontArray

"TextConstants at: #Lucida put: (TextStyle fontArray: (StrikeFont 
	readStrikeFont2Family: 'Lucida'))."! !


!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 22:27'!
fromHostFont: fontName size: fontSize flags: fontFlags weight: fontWeight
	"
		^StrikeFont fromHostFont: (StrikeFont hostFontFromUser)
					size: 12 flags: 0 weight: 4.
	"
	| fontHandle glyphs xTable xStart maxWidth w glyphForm ascent descent fontHeight |
	fontHandle _ self primitiveCreateFont: fontName size: fontSize flags: fontFlags weight: fontWeight.
	ascent _ self primitiveFontAscent: fontHandle.
	descent _ self primitiveFontDescent: fontHandle.
	fontHeight _ ascent + descent.
	xTable _ Array new: 258.
	xStart _ maxWidth _ 0.
	0 to: 255 do:[:i|
		xTable at: i+1 put: xStart.
		w _ self primitiveFont: fontHandle widthOfChar: i.
		w > maxWidth ifTrue:[maxWidth _ w].
		xStart _ xStart + w].
	xTable at: 256 put: xStart.
	xTable at: 257 put: xStart.
	xTable at: 258 put: xStart.
	glyphs _ Form extent: xTable last @ fontHeight depth: 1.
	glyphForm _ Form extent: maxWidth @ fontHeight depth: 1.
	0 to: 255 do:[:i|
		glyphForm fillWhite.
		self primitiveFont: fontHandle glyphOfChar: i into: glyphForm.
		xStart _ xTable at: i+1.
		glyphForm displayOn: glyphs at: xStart@0.
		glyphForm displayOn: Display at: xStart@0.
	].
	self primitiveDestroyFont: fontHandle.
	^Array with: glyphs with: xTable! !

!StrikeFont class methodsFor: 'font creation' stamp: 'rbb 2/18/2005 13:21'!
hostFontFromUser
	"StrikeFont hostFontFromUser"
	| fontNames index labels |
	fontNames _ self listFontNames asSortedCollection.
	labels _ WriteStream on: (String new: 100).
	fontNames do:[:fn| labels nextPutAll: fn] separatedBy:[labels cr].
	index _ (UIManager default chooseFrom: (labels contents substrings) 
				title: 'Choose your font').
	index = 0 ifTrue:[^nil].
	^fontNames at: index! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:12'!
listFont: index
	<primitive:'primitiveListFont' module:'FontPlugin'>
	^nil! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:12'!
listFontNames
	"StrikeFont listFontNames"
	"List all the OS font names"
	| font fontNames index |
	fontNames _ WriteStream on: Array new.
	index _ 0.
	[font _ self listFont: index.
	font == nil] whileFalse:[
		fontNames nextPut: font.
		index _ index + 1].
	^fontNames contents! !

!StrikeFont class methodsFor: 'font creation' stamp: 'tak 8/3/2005 21:11'!
localeChanged
	self setupDefaultFallbackFont! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:13'!
primitiveCreateFont: fontName size: fontSize flags: fontFlags weight: fontWeight
	<primitive:'primitiveCreateFont' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:13'!
primitiveDestroyFont: fontHandle
	<primitive:'primitiveDestroyFont' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:14'!
primitiveFont: fontHandle glyphOfChar: charIndex into: glyphForm
	<primitive:'primitiveFontGlyphOfChar' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:15'!
primitiveFont: fontHandle widthOfChar: charIndex
	<primitive:'primitiveFontWidthOfChar' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 22:25'!
primitiveFontAscent: fontHandle
	<primitive:'primitiveFontAscent' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 22:25'!
primitiveFontDescent: fontHandle
	<primitive:'primitiveFontDescent' module:'FontPlugin'>
	^self primitiveFailed! !

!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:14'!
primitiveFontEncoding: fontHandle
	<primitive:'primitiveFontEncoding' module:'FontPlugin'>
	^self primitiveFailed! !


!StrikeFont class methodsFor: 'instance creation' stamp: 'ar 2/3/2002 23:06'!
familyName: aName pointSize: aSize emphasized: emphasisCode
	"Create the font with this emphasis"

	^ (self familyName: aName pointSize: aSize) emphasized: emphasisCode! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'tk 1/28/1999 11:31'!
familyName: aName size: aSize emphasized: emphasisCode
	"Create the font with this emphasis"

	^ (self familyName: aName size: aSize) emphasized: emphasisCode! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'yo 3/18/2004 00:10'!
fixAccuISO8859From: aStrikeFont

	^aStrikeFont copy fixAccuISO8859From: aStrikeFont.
! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'yo 9/16/2002 15:55'!
fixForISO8859From: aStrikeFont

	^aStrikeFont copy fixForISO8859From: aStrikeFont.
! !

!StrikeFont class methodsFor: 'instance creation'!
fromStrike: fileName 
	"Read a font from disk in the old ST-80 'strike' format.
	Note: this is an old format; use strike2 format instead"

	^self new newFromStrike: fileName! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'ar 1/5/2002 21:41'!
fromUser
	"StrikeFont fromUser"
	^self fromUser: TextStyle defaultFont! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'nk 9/1/2004 14:29'!
fromUser: priorFont
	^self fromUser: priorFont allowKeyboard: true! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'nk 9/1/2004 14:28'!
fromUser: priorFont allowKeyboard: aBoolean
	"rr 3/23/2004 10:02 : made the menu invoked modally, thus allowing
	keyboard control" 
	"StrikeFont fromUser"
	"Present a menu of available fonts, and if one is chosen, return it.
	Otherwise return nil."

	| fontList fontMenu style active ptMenu label spec font |
	fontList _ StrikeFont actualFamilyNames.
	fontMenu _ MenuMorph new defaultTarget: self.
	fontList do: [:fontName |
		style _ TextStyle named: fontName.
		active _ priorFont familyName sameAs: fontName.
		ptMenu _ MenuMorph new defaultTarget: self.
		style pointSizes do: [:pt |
			(active and:[pt = priorFont pointSize]) 
				ifTrue:[label _ '<on>'] 
				ifFalse:[label _ '<off>'].
			label _ label, pt printString, ' pt'.
			ptMenu add: label 
				target: fontMenu
				selector: #modalSelection:
				argument: {fontName. pt}].
		style isTTCStyle ifTrue: [
			ptMenu add: 'new size'
				target: style selector: #addNewFontSizeDialog: argument: {fontName. fontMenu}.
		].
		active ifTrue:[label _ '<on>'] ifFalse:[label _ '<off>'].
		label _ label, fontName.
		fontMenu add: label subMenu: ptMenu].
	spec _ fontMenu invokeModalAt: ActiveHand position in: ActiveWorld allowKeyboard: aBoolean.
	spec ifNil: [^ nil].
	style _ TextStyle named: spec first.
	style ifNil: [^ self].
	font _ style fonts detect: [:any | any pointSize = spec last] ifNone: [nil].
	^ font! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'yo 8/5/2003 13:11'!
newForJapaneseFromEFontBDFFile: fileName name: aString overrideWith: otherFileName

	| n |
	n _ self new.
	n readEFontBDFForJapaneseFromFile: fileName name: aString overrideWith: otherFileName.
	^ n.
! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'yo 1/15/2004 16:48'!
newForKoreanFromEFontBDFFile: fileName name: aString overrideWith: otherFileName

	| n |
	n _ self new.
	n readEFontBDFForKoreanFromFile: fileName name: aString overrideWith: otherFileName.
	^ n.
! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'nop 1/23/2000 19:21'!
newFromBDFFile: aFileName name: aString  "StrikeFont newFromBDFFile: 'helvR12.bdf' name: 'Helvetica12'"
	"Read a font from disk in the X11 Bitmap Distribution Format."

	| n |
	n _ self new.
	n readBDFFromFile: aFileName name: aString.
	^n.

	"TextConstants at: #Helvetica put: (TextStyle fontArray: {StrikeFont newFromBDFFile: 'helvR12.bdf' name: 'Helvetica12'})"
	"TextConstants at: #Lucida put: (TextStyle fontArray: {StrikeFont newFromBDFFile: 'luRS12.bdf' name: 'Lucida'})"
	"TextStyle default fontAt: 5 put: (StrikeFont new readFromStrike2: 'helv12.sf2')."

! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'yo 1/19/2005 11:22'!
newFromEFontBDFFile: fileName name: aString ranges: ranges

	| n |
	n _ self new.
	n readEFontBDFFromFile: fileName name: aString ranges: ranges.
	^ n.
! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'yo 12/27/2002 16:57'!
newFromEFontBDFFile: aFileName name: aString startRange: start endRange: end

	| n |
	n _ self new.
	n readEFontBDFFromFile: aFileName name: aString rangeFrom: start to: end.
	^n.

	"TextConstants at: #Helvetica put: (TextStyle fontArray: {StrikeFont newFromBDFFile: 'helvR12.bdf' name: 'Helvetica12'})"
	"TextConstants at: #Lucida put: (TextStyle fontArray: {StrikeFont newFromBDFFile: 'luRS12.bdf' name: 'Lucida'})"
	"TextStyle default fontAt: 5 put: (StrikeFont new readFromStrike2: 'helv12.sf2')."

! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'yo 9/23/2002 16:28'!
newFromF12File: aFileName
	"StrikeFont newFromF12File: 'kaname.f12'"

	| file n |
	('*.F12' match: aFileName) ifFalse: ["self halt. " "likely incompatible"].
	file _ FileStream readOnlyFileNamed: aFileName.
	file binary.
	n _ self new.
	n name: (FileDirectory baseNameFor: (FileDirectory localNameFor: aFileName)).
	n readF12FromStream: file.
	^ n.
! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'tak 12/20/2004 10:23'!
passwordFontSize: aSize 
	^ FixedFaceFont new passwordFont fontSize: aSize! !


!StrikeFont class methodsFor: '*nebraska-instance creation' stamp: 'yo 12/17/2005 22:41'!
decodedFromRemoteCanvas: aString

	| array style base |
	array _ aString findTokens: #($ ).
	style _ TextStyle named: (array at: 1) asSymbol.
	style ifNil: [^ TextStyle defaultFont].
	(style fontArray first name = style fontArray first name withoutTrailingDigits) ifTrue: [
			^ self familyName: (array at: 1) size: (array at: 3) asNumber emphasized: (array at: 4) asNumber].
	base _ style fontArray detect: [:f | (array at: 2) beginsWith: f name].
	^ base emphasized: (array at: 4) asNumber.

	"^ self familyName: (array at: 1) size: (array at: 2) asNumber emphasized: (array at: 3) asNumber."
! !
Object subclass: #StrikeFontFixer
	instanceVariableNames: 'strikeFont charForms newFont'
	classVariableNames: 'MappingTable NoFontTable'
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:03'!
characterFormAt: aCharacter at: aPoint

	| f |
	f _ charForms at: aCharacter asciiValue + 1.
	(f magnifyBy: 3) displayAt: aPoint.
	^ f.
! !

!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:03'!
displayOn: aDisplayObject at: aPoint magnifyBy: aNumber

	| form hStep vStep bb source nextPoint |
	hStep _ (strikeFont maxWidth * aNumber * 1.2) asInteger.
	vStep _ (strikeFont height * aNumber *  1.2) asInteger.
	
	form _ Form extent: (hStep * 16)@(vStep * 16).
	bb _ BitBlt toForm: form.
	0 to: 15 do: [:i |
		1 to: 16 do: [:j |
			source _ ((charForms at: (i * 16 + j)) magnifyBy: aNumber).
			nextPoint _ (hStep * (j - 1)@(vStep * i)).
			bb copy: ((nextPoint+((hStep@vStep - source extent) // 2)) extent: source extent)
				from: 0@0 in: source fillColor: Color black rule: Form over.
		].
	].
	form displayOn: aDisplayObject at: aPoint.
! !

!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:03'!
font: aStrikeFont

	strikeFont _ aStrikeFont.
	self forms.
! !

!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:04'!
forms

	1 to: 256 do: [:i |
		charForms at: i put: (strikeFont characterFormAt: (Character value: (i - 1)))
	].
! !

!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:04'!
initialize

	charForms _ Array new: 256.
! !

!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:04'!
mappingTable

	^ MappingTable.
! !

!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:04'!
storeEditedGlyphsOn: aStream

	| n |
	NoFontTable do: [:i |
		n _ strikeFont name.
		(n beginsWith: 'NewYork') ifTrue: [n _ 'NewYork'].
		aStream nextPutAll: '((StrikeFont familyName: ''', n, ''' size: ',
			strikeFont height asString, ')'.
		aStream nextPutAll: ' characterFormAt: '.
		aStream nextPutAll: '(Character value: ', i asString, ')'.
		aStream nextPutAll: ' put: '.
		(strikeFont characterFormAt: (Character value: i)) storeOn: aStream base: 2.
		aStream nextPutAll: ')!!'.
		aStream nextPut: Character cr.
		aStream nextPut: Character cr.
	].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StrikeFontFixer class
	instanceVariableNames: ''!

!StrikeFontFixer class methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:06'!
initialize
"
	StrikeFontFixer initialize
"

	| d |
	self initializeNoFontTable.
	d _ Array new: 256.
	0 to: 127 do: [:i | d at: i+1 put: i].
	16r80 to: 16r9F do: [:i | d at: i+1 put: nil].
	d at: 16rA0+1 put: 16r20.
	d at: 16rA1+1 put: 16rC1.
	d at: 16rA2+1 put: 16rA2.
	d at: 16rA3+1 put: 16rA3.
	d at: 16rA4+1 put: 16rA9. "CURRENCY SIGN"
	d at: 16rA5+1 put: 16rB4.
	d at: 16rA6+1 put: 16r7C. "BROKEN BAR"
	d at: 16rA7+1 put: 16rA4.
	d at: 16rA8+1 put: 16r80. "DIAERESIS"
	d at: 16rA9+1 put: 16rA9.
	d at: 16rAA+1 put: 16rBB.
	d at: 16rAB+1 put: 16rC7.
	d at: 16rAC+1 put: 16rD1. "NOT SIGN"
	d at: 16rAD+1 put: 16rD0.
	d at: 16rAE+1 put: 16rA8.
	d at: 16rAF+1 put: 16rD1. "MACRON"
	d at: 16rB0+1 put: 16rA1.
	d at: 16rB1+1 put: 16r2B. "PLUS-MINUS SIGN"
	d at: 16rB2+1 put: 16rAB. "SUPERSCRIPT TWO"
	d at: 16rB3+1 put: 16rAB. "SUPERSCRIPT THREE"
	d at: 16rB4+1 put: 16rAB.
	d at: 16rB5+1 put: 16r75. "MICRO SIGN"
	d at: 16rB6+1 put: 16rA6.
	d at: 16rB7+1 put: 16rA5.
	d at: 16rB8+1 put: 16r82. "CEDILLA"
	d at: 16rB9+1 put: 16rAB. "SUPERSCRIPT ONE"
	d at: 16rBA+1 put: 16rBC.
	d at: 16rBB+1 put: 16rC8.
	d at: 16rBC+1 put: 16r4D. "VULGAR FRACTION ONE QUARTER"
	d at: 16rBD+1 put: 16r4D. "VULGAR FRACTIOIN ONE HALF"
	d at: 16rBE+1 put: 16r4D. "VALGAR FRACTION THREE QUARTERS"
	d at: 16rBF+1 put: 16rC0.
	d at: 16rC0+1 put: 16rCB.
	d at: 16rC1+1 put: 16rCB. "CAPITAL A WITH ACUTE"
	d at: 16rC2+1 put: 16rCB. "CAPITAL A WITH CIRCUMFLEX"
	d at: 16rC3+1 put: 16rCC.
	d at: 16rC4+1 put: 16r80.
	d at: 16rC5+1 put: 16r81.
	d at: 16rC6+1 put: 16rAE.
	d at: 16rC7+1 put: 16r82.
	d at: 16rC8+1 put: 16r83. "CAPITAL E WITH GRAVE"
	d at: 16rC9+1 put: 16r83.
	d at: 16rCA+1 put: 16r83. "CAPITAL E WITH CIRCUMFLEX"
	d at: 16rCB+1 put: 16r83. "CAPITAL E WITH DIAERESIS"
	d at: 16rCC+1 put: 16r49. "CAPITAL I WITH GRAVE"
	d at: 16rCD+1 put: 16r49. "CAPITAL I WITH ACUTE"
	d at: 16rCE+1 put: 16r49. "CAPITAL I WITH CIRCUMFLEX"
	d at: 16rCF+1 put: 16r49. "CAPITAL I WITH DIAERESIS"
	d at: 16rD0+1 put: 16r44. "CAPITAL ETH"
	d at: 16rD1+1 put: 16r84.
	d at: 16rD2+1 put: 16rCD. "CAPITAL O WITH GRAVE"
	d at: 16rD3+1 put: 16rCD. "CAPITAL O WITH ACUTE"
	d at: 16rD4+1 put: 16rCD. "CAPITAL O WITH CIRCUMFLEX"
	d at: 16rD5+1 put: 16rCD.
	d at: 16rD6+1 put: 16r85.
	d at: 16rD7+1 put: 16r2B. "MULTIPLICATION SIGN"
	d at: 16rD8+1 put: 16rBF.
	d at: 16rD9+1 put: 16r86. "CAPITAL U WITH GRAVE"
	d at: 16rDA+1 put: 16r86. "CAPITAL U WITH ACUTE"
	d at: 16rDB+1 put: 16r86. "CAPITAL U WITH CIRCUMFLEX"
	d at: 16rDC+1 put: 16r86. "CAPTIAL U WITH DIAERESIS"
	d at: 16rDD+1 put: 16r59. "CAPITAL Y WITH ACUTE"
	d at: 16rDE+1 put: 16r50. "CAPITAL THORN"
	d at: 16rDF+1 put: 16rA7.
	d at: 16rE0+1 put: 16r88.
	d at: 16rE1+1 put: 16r87.
	d at: 16rE2+1 put: 16r89.
	d at: 16rE3+1 put: 16r8B.
	d at: 16rE4+1 put: 16r8A.
	d at: 16rE5+1 put: 16r8C.
	d at: 16rE6+1 put: 16rBE.
	d at: 16rE7+1 put: 16r8D.
	d at: 16rE8+1 put: 16r8F.
	d at: 16rE9+1 put: 16r8E.
	d at: 16rEA+1 put: 16r90.
	d at: 16rEB+1 put: 16r91.
	d at: 16rEC+1 put: 16r93.
	d at: 16rED+1 put: 16r92.
	d at: 16rEE+1 put: 16r94.
	d at: 16rEF+1 put: 16r95.
	d at: 16rF0+1 put: 16r64. "SMALL ETH"
	d at: 16rF1+1 put: 16r96.
	d at: 16rF2+1 put: 16r98.
	d at: 16rF3+1 put: 16r97.
	d at: 16rF4+1 put: 16r99.
	d at: 16rF5+1 put: 16r9B.
	d at: 16rF6+1 put: 16r9A.
	d at: 16rF7+1 put: 16r2D. "DIVISION SIGN"
	d at: 16rF8+1 put: 16rBF.
	d at: 16rF9+1 put: 16r9D.
	d at: 16rFA+1 put: 16r9C.
	d at: 16rFB+1 put: 16r9E.
	d at: 16rFC+1 put: 16r9F.
	d at: 16rFD+1 put: 16rD8. "SMALL Y WITH ACUTE"
	d at: 16rFE+1 put: 16r70. "SMALL THORN"
	d at: 16rFF+1 put: 16rD8.

	MappingTable _ d.
! !

!StrikeFontFixer class methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:05'!
initializeNoFontTable

	| n |
	n _ #(
	16rA4 "CURRENCY SIGN"
	16rA6 "BROKEN BAR"
	16rA8 "DIAERESIS"
	16rAC "NOT SIGN"
	16rAF "MACRON"
	16rB1 "PLUS-MINUS SIGN"
	16rB2 "SUPERSCRIPT TWO"
	16rB3 "SUPERSCRIPT THREE"
	16rB5 "MICRO SIGN"
	16rB8 "CEDILLA"
	16rB9 "SUPERSCRIPT ONE"
	16rBC "VULGAR FRACTION ONE QUARTER"
	16rBD "VULGAR FRACTIOIN ONE HALF"
	16rBE "VALGAR FRACTION THREE QUARTERS"
	16rC1 "CAPITAL A WITH ACUTE"
	16rC2 "CAPITAL A WITH CIRCUMFLEX"
	16rC8 "CAPITAL E WITH GRAVE"
	16rCA "CAPITAL E WITH CIRCUMFLEX"
	16rCB "CAPITAL E WITH DIAERESIS"
	16rCC "CAPITAL I WITH GRAVE"
	16rCD "CAPITAL I WITH ACUTE"
	16rCE "CAPITAL I WITH CIRCUMFLEX"
	16rCF "CAPITAL I WITH DIAERESIS"
	16rD0 "CAPITAL ETH"
	16rD2 "CAPITAL O WITH GRAVE"
	16rD3 "CAPITAL O WITH ACUTE"
	16rD4 "CAPITAL O WITH CIRCUMFLEX"
	16rD7 "MULTIPLICATION SIGN"
	16rD9 "CAPITAL U WITH GRAVE"
	16rDA "CAPITAL U WITH ACUTE"
	16rDB "CAPITAL U WITH CIRCUMFLEX"
	16rDD "CAPITAL Y WITH ACUTE"
	16rDE "CAPITAL THORN"
	16rF0 "SMALL ETH"
	16rF7 "DIVISION SIGN"
	16rFD "SMALL Y WITH ACUTE"
	16rFE "SMALL THORN"
	).
	NoFontTable _ n.

! !

!StrikeFontFixer class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 18:09'!
newOn: aStrikeFont 
	^self new  font: aStrikeFont! !
AbstractFont subclass: #StrikeFontSet
	instanceVariableNames: 'fontArray emphasis derivativeFonts name rIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:14'!
ascentOf: aCharacter
	^(self fontOf: aCharacter) ascent! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:15'!
descentOf: aCharacter
	^(self fontOf: aCharacter) descent! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'yo 9/23/2002 20:08'!
fontArray

	^ fontArray
! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:14'!
fontOf: aCharacter
	"Answer the actual font to use for aCharacter"
	^self fontOf: aCharacter ifAbsent:[fontArray at: 1]! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:14'!
fontOf: aCharacter ifAbsent: aBlock
	"Answer the actual font to use for aCharacter"
	| encoding font |
	encoding := aCharacter leadingChar + 1.
	encoding <= fontArray size 
		ifTrue:[font := fontArray at: encoding].
	font ifNil:[^aBlock value].
	^font
! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:15'!
heightOf: aCharacter
	^(self fontOf: aCharacter) height! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'tak 12/21/2004 16:43'!
latin1
	"Answer primary font"
	^ fontArray at: 1! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'yo 11/15/2002 14:22'!
maxAsciiFor: encoding

	| f |
	f _ (fontArray at: encoding+1).
	f ifNotNil: [^ f maxAscii].
	^ 0.
! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'yo 8/5/2003 15:31'!
textStyle

	^ TextStyle actualTextStyles detect: [:aStyle | (aStyle fontArray collect: [:s | s name]) includes: self name]
		ifNone: [].
! !

!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:15'!
widthOf: aCharacter 
	"Answer the width of the argument as a character in the receiver."
	^(self fontOf: aCharacter) widthOf: aCharacter! !


!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 16:43'!
ascent

	^ fontArray first ascent.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 16:49'!
ascentKern

	^ fontArray first ascentKern.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 16:49'!
baseKern

	^ fontArray first baseKern.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 12/1/2003 18:00'!
bonk: glyphForm with: bonkForm at: j
	"Bonking means to run through the glyphs clearing out black pixels
	between characters to prevent them from straying into an adjacent
	character as a result of, eg, bolding or italicizing"
	"Uses the bonkForm to erase at every character boundary in glyphs."

	| bb offset font x |
	font _ (fontArray at: j).
	offset _ bonkForm offset x.
	bb _ BitBlt toForm: glyphForm.
	bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox;
		combinationRule: Form erase; destY: 0.
	x _ font xTable.
	(x isMemberOf: SparseLargeTable) ifTrue: [
		x base to: x size-1 do: [:i | bb destX: (x at: i) + offset; copyBits].
	] ifFalse: [
		1 to: x size-1 do: [:i | bb destX: (x at: i) + offset; copyBits].
	].
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:15'!
copy

	| s a |
	s _ self class new.
	s name: self name.
	s emphasis: self emphasis.
	s reset.
	a _ Array new: fontArray size.
	1 to: a size do: [:i |
		a at: i put: (fontArray at: i) copy.
	].
	s fontArray: a.
	^ s.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'nk 9/1/2004 12:06'!
derivativeFonts
	^derivativeFonts copyWithout: nil! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:02'!
descent

	^ fontArray first descent.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:02'!
descentKern

	^ fontArray first descentKern.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 5/19/2004 11:36'!
displayLine: aString at: aPoint 
	"Display the characters in aString, starting at position aPoint."

	self characters: (1 to: aString size)
		in: aString
		displayAt: aPoint
		clippedBy: Display boundingBox
		rule: Form over
		fillColor: nil
		kernDelta: 0
		on: (BitBlt current toForm: Display).
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:06'!
emphasis
	"Answer the integer code for synthetic bold, italic, underline, and 
	strike-out."

	^ emphasis.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:07'!
emphasis: code 
	"Set the integer code for synthetic bold, itallic, underline, and strike-out, 
	where bold=1, italic=2, underlined=4, and struck out=8."

	emphasis _ code.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:15'!
emphasized: code 

	"Answer a copy of the receiver with emphasis set to include code."
	| derivative addedEmphasis base safeCode |
	code = 0 ifTrue: [^ self].
	(derivativeFonts == nil or: [derivativeFonts size = 0]) ifTrue: [^ self].
	derivative _ derivativeFonts at: (safeCode _ code min: derivativeFonts size).
	derivative == nil ifFalse: [^ derivative].  "Already have this style"

	"Dont have it -- derive from another with one with less emphasis"
	addedEmphasis _ 1 bitShift: safeCode highBit - 1.
	base _ self emphasized: safeCode - addedEmphasis.  "Order is Bold, Ital, Under, Narrow"
	addedEmphasis = 1 ifTrue:   "Compute synthetic bold version of the font"
		[derivative _ (base copy name: base name , 'B') makeBoldGlyphs].
	addedEmphasis = 2 ifTrue:   "Compute synthetic italic version of the font"
		[ derivative _ (base copy name: base name , 'I') makeItalicGlyphs].
	addedEmphasis = 4 ifTrue:   "Compute underlined version of the font"
		[derivative _ (base copy name: base name , 'U') makeUnderlinedGlyphs].
	addedEmphasis = 8 ifTrue:   "Compute narrow version of the font"
		[derivative _ (base copy name: base name , 'N') makeCondensedGlyphs].
	addedEmphasis = 16 ifTrue:   "Compute struck-out version of the font"
		[derivative _ (base copy name: base name , 'X') makeStruckOutGlyphs].
	derivative emphasis: safeCode.
	derivativeFonts at: safeCode put: derivative.
	^ derivative
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 20:59'!
familyName

	^ fontArray first familyName.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:38'!
familySizeFace

	^ Array
		with: fontArray first name
		with: self height
		with: fontArray first emphasis
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:49'!
fontArray: anArray

	fontArray _ anArray.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:49'!
fontNameWithPointSize

	^ fontArray first fontNameWithPointSize.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:50'!
glyphs

	^ fontArray first glyphs
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:50'!
glyphsEncoding: anInteger

	^ (fontArray at: (anInteger+1)) glyphs.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:50'!
height

	^ fontArray first height.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'tak 12/16/2004 19:15'!
initializeWithFontArray: anArray 
	"Initialize with given font array, the ascent of primary font is modified 
	if another font has higher size"
	| primaryFont maxHeight newFont |
	fontArray := anArray.
	primaryFont := anArray first.
	emphasis := 0.
	name := primaryFont name.
	maxHeight := anArray
				inject: 0
				into: [:theHeight :font | (font notNil
							and: [theHeight < font height])
						ifTrue: [font height]
						ifFalse: [theHeight]].
	primaryFont height < maxHeight
		ifTrue: [newFont := primaryFont copy
						fixAscent: primaryFont ascent + (maxHeight - primaryFont height)
						andDescent: primaryFont descent
						head: 0.
			fontArray at: 1 put: newFont].
	self reset! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/5/2005 13:59'!
installOn: aDisplayContext

	^ aDisplayContext installStrikeFont: self.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:50'!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor 

	^ aDisplayContext
		installStrikeFont: self
		foregroundColor: foregroundColor
		backgroundColor: backgroundColor.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:50'!
lineGrid

	| f |
	f _ fontArray first.
	^ f ascent + f descent.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:52'!
maxEncoding

	^ fontArray size.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 2/24/2005 15:45'!
maxWidth

	^ (fontArray at: 1) maxWidth.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:52'!
name

	^ name
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:52'!
name: aString

	name _ aString
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 21:17'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to a known Font in the other system instead.  "

	"A path to me"
	(TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self].
		"special case for saving the default fonts on the disk.  See collectionFromFileNamed:"

	dp _ DiskProxy global: #StrikeFontSet selector: #familyName:size:emphasized:
			args: (Array with: self familyName with: self pointSize
					with: self emphasis).
	refStrm replace: self with: dp.
	^ dp.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:53'!
pointSize

	^ fontArray first pointSize.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:53'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '(' , self name.
	aStream space.
	self height printOn: aStream.
	aStream nextPut: $).
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:53'!
reset
	"Reset the cache of derivative emphasized fonts"

	derivativeFonts _ Array new: 32.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:53'!
subscript

	^ fontArray first subscript
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:53'!
superscript

	^ fontArray first superscript
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 18:53'!
widthOfString: aString

	aString ifNil:[^0].
	"Optimizing"
	(aString isByteString) ifTrue: [
		^ self fontArray first widthOfString: aString from: 1 to: aString size].
	^ self widthOfString: aString from: 1 to: aString size.
"
	TextStyle default defaultFont widthOfString: 'zort' 21
"
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'tak 1/11/2005 17:59'!
widthOfString: aString from: startIndex to: stopIndex
	"Measure the length of the given string between start and stop index"

	| resultX |
	resultX _ 0.
	startIndex to: stopIndex do:[:i | 
		resultX _ resultX + (self widthOf: (aString at: i))].
	^ resultX.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:56'!
xTable
	"Answer an Array of the left x-coordinate of characters in glyphs."

	^ fontArray first xTable.
! !

!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:56'!
xTableEncoding: anInteger
	"Answer an Array of the left x-coordinate of characters in glyphs."

	^(fontArray at: anInteger + 1) xTable.
! !


!StrikeFontSet methodsFor: 'character shapes' stamp: 'yo 12/27/2002 04:35'!
characterFormAt: character 

	| encoding ascii xTable leftX rightX |
	encoding _ character leadingChar + 1.
	ascii _ character charCode.
	(ascii < (fontArray at: encoding) minAscii or: [ascii > (fontArray at: encoding) maxAscii])
		ifTrue: [ascii _ (fontArray at: encoding) maxAscii].
	xTable _ (fontArray at: encoding) xTable.
	leftX _ xTable at: ascii + 1.
	rightX _ xTable at: ascii + 2.
	^ (fontArray at: encoding) glyphs copy: (leftX @ 0 corner: rightX @ self height).
! !

!StrikeFontSet methodsFor: 'character shapes' stamp: 'yo 12/27/2002 04:35'!
characterFormAt: character put: characterForm 

	| ascii leftX rightX widthDif newGlyphs encoding xTable glyphs |
	encoding _ character leadingChar + 1.
	ascii _ character charCode.
	ascii < (fontArray at: encoding) minAscii ifTrue: [
		^ self error: 'Cant store characters below min ascii'
	].
	ascii > (fontArray at: encoding) maxAscii ifTrue: [
		^ self error: 'No change made'
	].
	xTable _ (fontArray at: encoding) xTable.
	leftX _ xTable at: ascii + 1.
	rightX _ xTable at: ascii + 2.
	glyphs _ (fontArray at: encoding) glyphs.
	widthDif _ characterForm width - (rightX - leftX).
	widthDif ~= 0 ifTrue: [
		newGlyphs _ Form extent: glyphs width + widthDif @ glyphs height.
		newGlyphs copy: (0 @ 0 corner: leftX @ glyphs height) from: 0 @ 0
			in: glyphs rule: Form over.
		newGlyphs
				copy: (rightX + widthDif @ 0 corner: newGlyphs width @ glyphs height)
				from: rightX @ 0 in: glyphs rule: Form over.
		glyphs _ newGlyphs.
		"adjust further entries on xTable"
		xTable _ xTable copy.
		ascii + 2 to: xTable size do: [:i |
			xTable at: i put: (xTable at: i) + widthDif]].
	glyphs copy: (leftX @ 0 extent: characterForm extent) from: 0 @ 0 in: characterForm rule: Form over.
! !


!StrikeFontSet methodsFor: 'displaying' stamp: 'yo 5/19/2004 11:35'!
characters: anInterval in: sourceString displayAt: aPoint clippedBy: clippingRectangle rule: ruleInteger fillColor: aForm kernDelta: kernDelta on: aBitBlt
	"Simple, slow, primitive method for displaying a line of characters.
	No wrap-around is provided."

	| ascii encoding destPoint leftX rightX sourceRect xTable noFont f |
	destPoint _ aPoint.
	anInterval do: 
		[:i |
		encoding _ (sourceString at: i) leadingChar + 1.
		noFont _ false.
		[f _ fontArray at: encoding]
			on: Exception do: [:ex | noFont _ true. f _ fontArray at: 1].
		f ifNil: [noFont _ true. f _ fontArray at: 1].
		ascii _ noFont ifTrue: [$?] ifFalse: [(sourceString at: i) charCode].
		(ascii < f minAscii
			or: [ascii > f maxAscii])
			ifTrue: [ascii _ f maxAscii].
		xTable _ f xTable.
		leftX _ xTable at: ascii + 1.
		rightX _ xTable at: ascii + 2.
		sourceRect _ leftX@0 extent: (rightX-leftX) @ self height.
		aBitBlt copyFrom: sourceRect in: f glyphs to: destPoint.
		destPoint _ destPoint + ((rightX-leftX+kernDelta)@0).
		"destPoint printString displayAt: 0@(i*20)."
	].
	^ destPoint.
! !

!StrikeFontSet methodsFor: 'displaying' stamp: 'efc 8/6/2005 11:45'!
displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY

	| destPoint leftX rightX glyphInfo g destY |
	destPoint := aPoint.
	glyphInfo := Array new: 5.
	startIndex to: stopIndex do: [:charIndex |
		self glyphInfoOf: (aString at: charIndex) into: glyphInfo.
		g := glyphInfo at:1.
		leftX := glyphInfo at:2.
		rightX := glyphInfo at:3.
		((glyphInfo at:5) ~= aBitBlt lastFont) ifTrue: [
			(glyphInfo at:5) installOn: aBitBlt.
		].
		aBitBlt sourceForm: g.
		destY := baselineY - (glyphInfo at:4).
		aBitBlt destX: (destPoint x) destY: destY width: (rightX - leftX) height: (self height).
		aBitBlt sourceOrigin: leftX @ 0.
		aBitBlt copyBits.
		destPoint := destPoint + (rightX - leftX + kernDelta @ 0).
	].
	^ destPoint.! !

!StrikeFontSet methodsFor: 'displaying' stamp: 'yo 12/27/2002 04:35'!
displayStringR2L: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 

	| destPoint font |
	destPoint _ aPoint.
	startIndex to: stopIndex do: [:charIndex | 
		| encoding ascii xTable leftX rightX | 
		encoding _ (aString at: charIndex) leadingChar + 1.
		ascii _ (aString at: charIndex) charCode.
		font _ fontArray at: encoding.
		((ascii between: font minAscii and: font maxAscii) not) ifTrue: [
			ascii _ font maxAscii].
		xTable _ font xTable.
		leftX _ xTable at: ascii + 1.
		rightX _ xTable at: ascii + 2.
		aBitBlt sourceForm: font glyphs.
		aBitBlt destX: destPoint x - (rightX - leftX).
		aBitBlt destY: destPoint y.
		aBitBlt sourceOrigin: leftX @ 0.
		aBitBlt width: rightX - leftX.
		aBitBlt height: self height.
		aBitBlt copyBits.
		destPoint _ destPoint - (rightX - leftX + kernDelta @ 0).
	].
! !

!StrikeFontSet methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:04'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 

	^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent.
! !

!StrikeFontSet methodsFor: 'displaying' stamp: 'efc 8/6/2005 13:35'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) BitBlt."
	
	"Assume this is a wide string"
	| isMulti |
	isMulti _ true.

	"Look for an excuse to use the fast primitive"
 	(aString isKindOf: ByteString) 
		ifTrue:[ isMulti _ false]
		ifFalse:[ (aString isKindOf: Text) 
			ifTrue:[ (aString string isKindOf: ByteString) 
				ifTrue:[ isMulti _ false ] 
	]].

	isMulti ifTrue:[^ self displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY].

	^ aBitBlt displayString: aString 
			from: startIndex 
			to: stopIndex 
			at: aPoint 
			strikeFont: self
			kern: kernDelta! !

!StrikeFontSet methodsFor: 'displaying' stamp: 'yo 1/7/2005 15:17'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY

	| destPoint leftX rightX glyphInfo g tag char destY |
	destPoint _ aPoint.
	rIndex _ startIndex.
	tag _ (aString at: rIndex) leadingChar.
	glyphInfo _ Array new: 5.
	[rIndex <= stopIndex] whileTrue: [
		char _ aString at: rIndex.
		((fromFont hasGlyphOf: char) or: [char leadingChar ~= tag]) ifTrue: [^ Array with: rIndex with: destPoint].
		self glyphInfoOf: char into: glyphInfo.
		g _ glyphInfo first.
		leftX _ glyphInfo second.
		rightX _ glyphInfo third.
		(glyphInfo fifth ~= aBitBlt lastFont) ifTrue: [
			glyphInfo fifth installOn: aBitBlt.
		].
		aBitBlt sourceForm: g.
		destY _ baselineY - glyphInfo fourth. 
		aBitBlt destX: destPoint x.
		aBitBlt destY: destY.
		aBitBlt sourceOrigin: leftX @ 0.
		aBitBlt width: rightX - leftX.
		aBitBlt height: self height.
		aBitBlt copyBits.
		destPoint _ destPoint + (rightX - leftX + kernDelta @ 0).
		rIndex _ rIndex + 1.
	].
	^ Array with: rIndex with: destPoint.
! !

!StrikeFontSet methodsFor: 'displaying' stamp: 'BG 3/16/2005 08:27'!
fontDisplay
	"TextStyle default defaultFont fontDisplay."

	Display restoreAfter:
		[(Form extent: 440@400) displayAt: 90@90.
		 0 to: 15 do:
			[:i |
			i storeStringHex displayAt: 100 @ (20 * i + 100).
			0 to: 15 do:
				[:j |
				((16*i+j) between: 1 and: (self xTable size - 2)) ifTrue:
					[(self characterFormAt: (16 * i + j) asCharacter)
						displayAt: (20 * j + 150) @ (20 * i + 100)]]].
			'Click to continue...' asDisplayText displayAt: 100@450]! !


!StrikeFontSet methodsFor: 'emphasis' stamp: 'yo 12/27/2002 13:52'!
makeBoldGlyphs
	"Make a bold set of glyphs with same widths by ORing 1 bit to the right
		(requires at least 1 pixel of intercharacter space)"

	| g bonkForm font |
	1 to: fontArray size do: [:i |
		font _ fontArray at: i.
		font ifNotNil: [
			g _ font glyphs deepCopy.
			bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0.
			self bonk: g with: bonkForm at: i.
			g copyBits: g boundingBox from: g at: (1@0)
				clippingBox: g boundingBox rule: Form under fillColor: nil.
			(fontArray at: i) setGlyphs: g.
		].
	].
! !

!StrikeFontSet methodsFor: 'emphasis' stamp: 'yo 12/27/2002 13:51'!
makeItalicGlyphs
	"Make an italic set of glyphs with same widths by skewing left and right
		(may require more intercharacter space)"

	| g bonkForm bc font |
	1 to: fontArray size do: [:j |
		font _ (fontArray at: j).
		font ifNotNil: [
			g _ font glyphs deepCopy.
			"BonkForm will have bits where slanted characters overlap their neighbors."
			bonkForm _ Form extent: (self height//4+2) @ self height.
			bc _ font descent//4 + 1.  "Bonker x-coord corresponding to char boundary."
			bonkForm fill: (0 @ 0 corner: (bc+1) @ font ascent) fillColor: Color black.
			4 to: font ascent-1 by: 4 do:
				[:y | 		"Slide ascenders right..."
				g copy: (1@0 extent: g width @ (font ascent - y))
					from: 0@0 in: g rule: Form over.
				bonkForm copy: (1@0 extent: bonkForm width @ (font ascent - y))
					from: 0@0 in: bonkForm rule: Form over].
			bonkForm fill: (0 @ 0 corner: (bc+1) @ font ascent) fillColor: Color white.
			bonkForm fill: (bc @ font ascent corner: bonkForm extent) fillColor: Color black.
			font ascent to: font height-1 by: 4 do:
				[:y | 		"Slide descenders left..."
				g copy: (0@y extent: g width @ g height)
					from: 1@y in: g rule: Form over.
				bonkForm copy: (0@0 extent: bonkForm width @ bonkForm height)
					from: 1@0 in: bonkForm rule: Form over].
			bonkForm fill: (bc @ font ascent corner: bonkForm extent) fillColor: Color white.
			"Now use bonkForm to erase at every character boundary in glyphs."
			bonkForm offset: (0-bc) @ 0.
			font bonk: g with: bonkForm.
			font setGlyphs: g
		].
	].
! !

!StrikeFontSet methodsFor: 'emphasis' stamp: 'yo 12/27/2002 13:53'!
makeStruckOutGlyphs
	"Make a struck-out set of glyphs with same widths"

	| g font |
	1 to: fontArray size do: [:i |
		font _ (fontArray at: i).
		font ifNotNil: [
			g _ font glyphs deepCopy.
			g fillBlack: (0 @ (font ascent - (font ascent//3)) extent: g width @ 1).
			font setGlyphs: g
		].
	].
! !

!StrikeFontSet methodsFor: 'emphasis' stamp: 'yo 12/27/2002 13:51'!
makeUnderlinedGlyphs
	"Make an underlined set of glyphs with same widths"

	| g font |
	1 to: fontArray size do: [:i |
		font _ (fontArray at: i).
		font ifNotNil: [
			g _ font glyphs deepCopy.
			g fillBlack: (0 @ (font ascent+1) extent: g width @ 1).
			font setGlyphs: g
		].
	].
! !


!StrikeFontSet methodsFor: '*nebraska-as yet unclassified' stamp: 'yo 12/17/2005 20:19'!
encodedForRemoteCanvas

	| stream |
	stream := RWBinaryOrTextStream on: ''.
	stream nextPutAll: self familyName.
	stream nextPut: Character space.
	stream nextPutAll: self pointSize asString.
	stream nextPut: Character space.
	stream nextPutAll: self emphasis asString.
	^ stream contents asString.
! !


!StrikeFontSet methodsFor: 'private' stamp: 'yo 12/27/2002 13:39'!
addNewFont: aFont at: encodingIndex

	| newArray |
	encodingIndex > fontArray size ifTrue: [
		newArray _ Array new: encodingIndex.
		newArray replaceFrom: 1 to: fontArray size with: fontArray startingAt: 1.
	] ifFalse: [
		newArray _ fontArray.
	].

	newArray at: encodingIndex put: aFont.

	self initializeWithFontArray: newArray.
! !

!StrikeFontSet methodsFor: 'private' stamp: 'yo 1/7/2005 11:16'!
glyphInfoOf: aCharacter into: glyphInfoArray

	| index f code leftX |
	index _ aCharacter leadingChar + 1.
	fontArray size < index ifTrue: [^ self questionGlyphInfoInto: glyphInfoArray].
	(f _ fontArray at: index) ifNil: [^ self questionGlyphInfoInto: glyphInfoArray].

	code _ aCharacter charCode.
	((code between: f minAscii and: f maxAscii) not) ifTrue: [
		^ self questionGlyphInfoInto: glyphInfoArray.
	].
	leftX _ f xTable at: code + 1.
	leftX < 0 ifTrue: [
		^ self questionGlyphInfoInto: glyphInfoArray.
	].
	glyphInfoArray at: 1 put: f glyphs;
		at: 2 put: leftX;
		at: 3 put: (f xTable at: code + 2);
		at: 4 put: (f ascentOf: aCharacter);
		at: 5 put: self.
	^ glyphInfoArray.
! !

!StrikeFontSet methodsFor: 'private' stamp: 'yo 1/13/2005 16:43'!
questionGlyphInfoInto: glyphInfoArray

	| f ascii |
	f _ fontArray at: 1.
	ascii _ $? asciiValue.
	glyphInfoArray at: 1 put: f glyphs;
		at: 2 put: (f xTable at: ascii + 1);
		at: 3 put: (f xTable at: ascii + 2);
		at: 4 put: (self ascentOf: $?);
		at: 5 put: self.
	^ glyphInfoArray.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StrikeFontSet class
	instanceVariableNames: ''!

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:25'!
createExternalFontFileForLatin2: fileName
"
	StrikeFontSet createExternalFontFileForLatin2: 'latin2.out'.
"

	| file array f installDirectory |
	file _ FileStream newFileNamed: fileName.
	installDirectory _ Smalltalk at: #M17nInstallDirectory ifAbsent: [].
	installDirectory _ installDirectory
		ifNil: [String new]
		ifNotNil: [installDirectory , FileDirectory pathNameDelimiter asString].
	array _ Array
				with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b10.bdf' name: 'LatinTwo9' ranges: EFontBDFFontReaderForRanges rangesForLatin2)
				with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b12.bdf' name: 'LatinTwo10' ranges: EFontBDFFontReaderForRanges rangesForLatin2)
				with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b14.bdf' name: 'LatinTwo12' ranges: EFontBDFFontReaderForRanges rangesForLatin2)
				with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b16.bdf' name: 'LatingTwo14' ranges: EFontBDFFontReaderForRanges rangesForLatin2)
				with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b24.bdf' name: 'LatinTwo20' ranges: EFontBDFFontReaderForRanges rangesForLatin2).
	TextConstants at: #forceFontWriting put: true.
	f _ ReferenceStream on: file.
	f nextPut: array.
	file close.
	TextConstants removeKey: #forceFontWriting.
! !

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 5/25/2004 11:05'!
createExternalFontFileForUnicodeJapanese: fileName
"
	StrikeFontSet createExternalFontFileForUnicodeJapanese: 'uJapaneseFont.out'.
"

	| file array f installDirectory |
	file _ FileStream newFileNamed: fileName.
	installDirectory _ Smalltalk at: #M17nInstallDirectory ifAbsent: [].
	installDirectory _ installDirectory
		ifNil: [String new]
		ifNotNil: [installDirectory , FileDirectory pathNameDelimiter asString].
	array _ Array
				with: (StrikeFont newForJapaneseFromEFontBDFFile: installDirectory , 'b12.bdf' name: 'Japanese10' overrideWith: 'shnmk12.bdf')
				with: ((StrikeFont newForJapaneseFromEFontBDFFile: installDirectory , 'b14.bdf' name: 'Japanese12' overrideWith: 'shnmk14.bdf') "fixAscent: 14 andDescent: 1 head: 1")
				with: ((StrikeFont newForJapaneseFromEFontBDFFile: 'b16.bdf' name: 'Japanese14' overrideWith: 'shnmk16.bdf') "fixAscent: 16 andDescent: 4 head: 4")
				with: (StrikeFont newForJapaneseFromEFontBDFFile: installDirectory , 'b24.bdf' name: 'Japanese18' overrideWith: 'kanji24.bdf').
	TextConstants at: #forceFontWriting put: true.
	f _ ReferenceStream on: file.
	f nextPut: array.
	file close.
	TextConstants removeKey: #forceFontWriting.
! !

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 1/15/2004 16:58'!
createExternalFontFileForUnicodeKorean: fileName
"
	Smalltalk garbageCollect.
	StrikeFontSet createExternalFontFileForUnicodeKorean: 'uKoreanFont.out'.
"

	| file array f installDirectory |
	file _ FileStream newFileNamed: fileName.
	installDirectory _ Smalltalk at: #M17nInstallDirectory ifAbsent: [].
	installDirectory _ installDirectory
		ifNil: [String new]
		ifNotNil: [installDirectory , FileDirectory pathNameDelimiter asString].
	array _ Array
				with: (StrikeFont newForKoreanFromEFontBDFFile: installDirectory , 'b12.bdf' name: 'Japanese10' overrideWith: 'shnmk12.bdf')
				with: ((StrikeFont newForKoreanFromEFontBDFFile: installDirectory , 'b14.bdf' name: 'Japanese12' overrideWith: 'shnmk14.bdf') "fixAscent: 14 andDescent: 1 head: 1")
				with: ((StrikeFont newForKoreanFromEFontBDFFile: installDirectory , 'b16.bdf' name: 'Japanese14' overrideWith: 'hanglg16.bdf') fixAscent: 16 andDescent: 4 head: 4)
				with: (StrikeFont newForKoreanFromEFontBDFFile: installDirectory , 'b24.bdf' name: 'Japanese18' overrideWith: 'hanglm24.bdf').
	TextConstants at: #forceFontWriting put: true.
	f _ ReferenceStream on: file.
	f nextPut: array.
	file close.
	TextConstants removeKey: #forceFontWriting.
! !

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/17/2005 22:42'!
decodedFromRemoteCanvas: aString

	| array |
	array _ aString findTokens: #($ ).
	^ self familyName: (array at: 1) size: (array at: 2) asNumber emphasized: (array at: 3) asNumber.
! !

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/27/2002 14:08'!
duplicateArrayElementsForLeadingCharShift
"
	self duplicateArrayElementsForLeadingCharShift
"
	| array font |
	self allInstances do: [:s |
		s emphasis = 0 ifTrue: [
			array _ s fontArray.
			2 to: (4 min: array size) do: [:i |
				font _ array at: i.
				s addNewFont: font at: ((i - 1) << 2) + 1.
			].
		] ifFalse: [
			s reset
		].
	].
! !

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 8/19/2003 13:04'!
familyName: aName size: aSize
	"Answer a font (or the default font if the name is unknown) in the specified size."

	| collection |
	collection _  self allInstances select: [:inst | (inst name beginsWith: aName) and: [inst emphasis = 0]].
	collection isEmpty ifTrue: [
		(aName = 'DefaultMultiStyle') ifTrue: [
			collection _ (TextConstants at: #DefaultMultiStyle) fontArray.
		] ifFalse: [
			^ TextStyle defaultFont
		]
	].
	collection _ collection asSortedCollection: [:a :b | a pointSize <= b pointSize].
	collection do: [:s | (s pointSize >= aSize) ifTrue: [^ s]].
	^ TextStyle defaultFont.
! !

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 21:03'!
familyName: aName size: aSize emphasized: emphasisCode
	"Create the font with this emphasis"

	^ (self familyName: aName size: aSize) emphasized: emphasisCode
! !

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 5/25/2004 14:32'!
findMaximumLessThan: f in: array

	array size to: 1 by: -1 do: [:i |
		f height >= (array at: i) height ifTrue: [^ array at: i].
	].
	^ array first.
! !

!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 9/23/2002 16:32'!
newFontArray: anArray
 
	^super new initializeWithFontArray: anArray
! !


!StrikeFontSet class methodsFor: 'fileIn/Out' stamp: 'yo 1/18/2005 16:00'!
installExternalFontFileName6: fileName encoding: encoding encodingName: aString textStyleName: styleName

	^ self installExternalFontFileName6: fileName inDir: FileDirectory default encoding: encoding encodingName: aString textStyleName: styleName.

"
StrikeFontSet createExternalFontFileForCyrillic: 'cyrillicFont.out'.

StrikeFontSet installExternalFontFileName6: 'latin2.out' encoding: Latin2Environment leadingChar encodingName: #Latin2 textStyleName: #DefaultMultiStyle.
StrikeFontSet installExternalFontFileName6: 'uJapaneseFont.out' encoding: JapaneseEnvironment leadingChar encodingName: #Japanese textStyleName: #DefaultMultiStyle.

StrikeFontSet installExternalFontFileName6: 'uKoreanFont.out' encoding: UnicodeKorean leadingChar encodingName: #Korean textStyleName: #DefaultMultiStyle.

StrikeFontSet removeFontsForEncoding: 2 encodingName: #Gb2312.
self halt.
StrikeFontSet removeFontsForEncoding: 3 encodingName: #KsX1001.
"
! !

!StrikeFontSet class methodsFor: 'fileIn/Out' stamp: 'tak 8/3/2005 17:40'!
installExternalFontFileName6: fileName inDir: dir encoding: encoding encodingName: aString textStyleName: styleName 
	| aStream |
	aStream := dir readOnlyFileNamed: fileName.
	[self
		installExternalFontOn: aStream
		encoding: encoding
		encodingName: aString
		textStyleName: styleName]
		ensure: [aStream close]! !

!StrikeFontSet class methodsFor: 'fileIn/Out' stamp: 'yo 3/17/2004 10:32'!
installExternalFontFileName: fileName encoding: encoding encodingName: aString textStyleName: styleName

	^ self installExternalFontFileName: fileName inDir: FileDirectory default encoding: encoding encodingName: aString textStyleName: styleName.

"
StrikeFontSet createExternalFontFileForCyrillic: 'cyrillicFont.out'.

StrikeFontSet installExternalFontFileName: 'chineseFont.out' encoding: 2 encodingName: #Gb2312 textStyleName: #DefaultMultiStyle.
StrikeFontSet installExternalFontFileName: 'japaneseFont.out' encoding: 1 encodingName: #JisX0208 textStyleName: #DefaultMultiStyle.
StrikeFontSet installExternalFontFileName: 'defaultFont.out' encoding: 0 encodingName: #Latin1 textStyleName: #DefaultMultiStyle.
StrikeFontSet installExternalFontFileName: 'cyrillicFont.out' encoding: UnicodeCyrillic leadingChar encodingName: #Cyrillic textStyleName: #DefaultMultiStyle.
StrikeFontSet installExternalFontFileName: 'extendedLatinFont.out' encoding: UnicodeLatinExtendedAB leadingChar encodingName: #ExtendedLatin textStyleName: #DefaultMultiStyle.
StrikeFontSet installExternalFontFileName: 'ipaExtensionsFont.out' encoding: UnicodeIPA leadingChar encodingName: #IPAExtensions textStyleName: #DefaultMultiStyle.
StrikeFontSet installExternalFontFileName: 'armenianFont.out' encoding: UnicodeArmenian leadingChar encodingName: #Armenian textStyleName: #DefaultMultiStyle.
StrikeFontSet installExternalFontFileName: 'greekFont.out' encoding: UnicodeGreek leadingChar encodingName: #Greek textStyleName: #DefaultMultiStyle.

StrikeFontSet installExternalFontFileName: 'arrowFont.out' encoding: UnicodeArrows leadingChar encodingName: #Arrow textStyleName: #DefaultMultiStyle.

StrikeFontSet installExternalFontFileName: 'uJapaneseFont.out' indir: FileDirectory default encoding: JapaneseEnvironment leadingChar encodingName: #Japanese textStyleName: #DefaultMultiStyle.

StrikeFontSet installExternalFontFileName: 'uKoreanFont.out' encoding: UnicodeKorean leadingChar encodingName: #Korean textStyleName: #DefaultMultiStyle.

StrikeFontSet removeFontsForEncoding: 2 encodingName: #Gb2312.
self halt.
StrikeFontSet removeFontsForEncoding: 3 encodingName: #KsX1001.
"
! !

!StrikeFontSet class methodsFor: 'fileIn/Out' stamp: 'yo 8/19/2003 00:32'!
installExternalFontFileName: fileName inDir: dir encoding: encoding encodingName: aString textStyleName: styleName

	| array arrayFour oldStyle arrayOfFS fs fonts newFonts |
	array _ (ReferenceStream on: (dir readOnlyFileNamed: fileName)) next.

	arrayFour _ Array new: 4 withAll: array last.
	arrayFour replaceFrom: 1 to: array size with: array startingAt: 1.
	TextConstants at: aString asSymbol put: arrayFour.

	oldStyle _ TextConstants at: styleName asSymbol.
	arrayOfFS _ oldStyle fontArray.
	arrayOfFS _ (1 to: 4) collect: [:i |
		fs _ arrayOfFS at: i.
		fonts _ fs fontArray.
		encoding + 1 > fonts size ifTrue: [
			newFonts _ Array new: encoding + 1.
			newFonts replaceFrom: 1 to: fonts size with: fonts startingAt: 1.
			newFonts at: encoding + 1 put: (arrayFour at: i).
			fs initializeWithFontArray: newFonts.
		] ifFalse: [
			fonts at: encoding + 1 put: (arrayFour at: i).
		].
		fs.
	].

	TextConstants at: styleName asSymbol put: (TextStyle fontArray: arrayOfFS).
	oldStyle becomeForward: (TextConstants at: styleName asSymbol).

! !

!StrikeFontSet class methodsFor: 'fileIn/Out' stamp: 'tak 8/5/2005 10:34'!
installExternalFontOn: aStream encoding: encoding encodingName: aString textStyleName: styleName

	| array fonts encodingIndex textStyle |

	array _ aStream
		untilEndWithFork: [(ReferenceStream on: aStream) next]
		displayingProgress: 'Font reading...'. 
	
	TextConstants at: aString asSymbol put: array.

	textStyle _ TextConstants at: styleName asSymbol.
	encodingIndex _ encoding + 1.
	textStyle fontArray do: [:fs |
		fonts _ fs fontArray.
		encodingIndex > fonts size
			ifTrue: [fonts _  (Array new: encodingIndex)
				replaceFrom: 1 to: fonts size with: fonts startingAt: 1].
		fonts at: encodingIndex put: (self findMaximumLessThan: fs fontArray first in: array).
		fs initializeWithFontArray: fonts.
	].
! !

!StrikeFontSet class methodsFor: 'fileIn/Out' stamp: 'tak 8/4/2005 11:03'!
installExternalFontOn: aStream forLocale: locale 
	self
		installExternalFontOn: aStream
		encoding: locale languageEnvironment leadingChar
		encodingName: locale languageEnvironment fontEncodingName
		textStyleName: #DefaultMultiStyle! !

!StrikeFontSet class methodsFor: 'fileIn/Out' stamp: 'yo 1/15/2004 16:06'!
installNewFontAtIndex: newIndex fromOld: oldIndex

	| fontArray newArray |
	self allInstances do: [:set |
		fontArray _ set fontArray.
		newIndex + 1 > fontArray size ifTrue: [
			newArray _ Array new: newIndex + 1.
			newArray replaceFrom: 1 to: fontArray size with: fontArray startingAt: 1.
			newArray at: newIndex + 1 put: (fontArray at: oldIndex + 1).
			set initializeWithFontArray: newArray.
		] ifFalse: [
			fontArray at: newIndex + 1 put: (fontArray at: oldIndex + 1).
		].
	].

"
StrikeFontSet installNewFontAtIndex: UnicodeSimplifiedChinese leadingChar fromOld: UnicodeJapanese leadingChar
StrikeFontSet installNewFontAtIndex: UnicodeKorean leadingChar fromOld: UnicodeJapanese leadingChar
"
! !

!StrikeFontSet class methodsFor: 'fileIn/Out' stamp: 'tak 8/4/2005 14:41'!
removeFontsForEncoding: leadingChar encodingName: encodingSymbol

	| insts fonts newFonts index |
	leadingChar = 0 ifTrue: [^ self error: 'you cannot delete the intrinsic fonts'].
	insts _ self allInstances.
	insts do: [:inst |
		fonts _ inst fontArray.
		fonts size >= (leadingChar + 1) ifTrue: [
			leadingChar + 1 = fonts size ifTrue: [
				newFonts _ fonts copyFrom: 1 to: fonts size - 1.
				index _ newFonts indexOf: nil.
				index > 0 ifTrue: [newFonts _ newFonts copyFrom: 1 to: index - 1].
				inst initializeWithFontArray: newFonts.
			] ifFalse: [
				fonts at: leadingChar + 1 put: nil.
			].
		].
	].

	TextConstants removeKey: encodingSymbol asSymbol ifAbsent: [].
! !
ArrayedCollection subclass: #String
	instanceVariableNames: ''
	classVariableNames: 'AsciiOrder CSLineEnders CSNonSeparators CSSeparators CaseInsensitiveOrder CaseSensitiveOrder HtmlEntities LowercasingTable Tokenish UppercasingTable'
	poolDictionaries: ''
	category: 'Collections-Strings'!
!String commentStamp: '<historical>' prior: 0!
A String is an indexed collection of Characters. Class String provides the abstract super class for ByteString (that represents an array of 8-bit Characters) and WideString (that represents an array of  32-bit characters).  In the similar manner of LargeInteger and SmallInteger, those subclasses are chosen accordingly for a string; namely as long as the system can figure out so, the String is used to represent the given string.

Strings support a vast array of useful methods, which can best be learned by browsing and trying out examples as you find them in the code.

Here are a few useful methods to look at...
	String match:
	String contractTo:

String also inherits many useful methods from its hierarchy, such as
	SequenceableCollection ,
	SequenceableCollection copyReplaceAll:with:
!
]style[(55 376 188 13 2 18 72 24 2 44)f1,f2,f1,f1LString match:;,f1,f1LString contractTo:;,f1,f1LSequenceableCollection ,;,f1,f1LSequenceableCollection copyReplaceAll:with:;!


!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:30'!
byteAt: index
	^self subclassResponsibility! !

!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:30'!
byteAt: index put: value
	^self subclassResponsibility! !

!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:30'!
byteSize
	^self subclassResponsibility! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
do: aBlock toFieldNumber: aNumber
	"Considering the receiver as a holder of tab-delimited fields, evaluate aBlock on behalf of a field in this string"

	| start end index |
	start _ 1.
	index _ 1.
	[start <= self size] whileTrue: 
		[end _ self indexOf: Character tab startingAt: start ifAbsent: [self size + 1].
		end _ end - 1.
		aNumber = index ifTrue:
			[aBlock value: (self copyFrom: start  to: end).
			^ self].
		index _ index + 1.
		start _ end + 2]

"
1 to: 6 do:
	[:aNumber |
		'fred	charlie	elmo		wimpy	friml' do:
			[:aField | Transcript cr; show: aField] toFieldNumber: aNumber]
"! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
endsWithDigit
	"Answer whether the receiver's final character represents a digit.  3/11/96 sw"

	^ self size > 0 and: [self last isDigit]! !

!String methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:12'!
findAnySubStr: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that begins a substring matching one of the delimiters.  delimiters is an Array of Strings (Characters are permitted also).  If the receiver does not contain any of the delimiters, answer size + 1."

	| min ind |
	min _ self size + 1.
	delimiters do: [:delim |	"May be a char, a string of length 1, or a substring"
		delim isCharacter 
			ifTrue: [ind _ self indexOfSubCollection: (String with: delim) 
						startingAt: start ifAbsent: [min]]
			ifFalse: [ind _ self indexOfSubCollection: delim 
						startingAt: start ifAbsent: [min]].
			min _ min min: ind].
	^ min! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findBetweenSubStrs: delimiters
	"Answer the collection of String tokens that result from parsing self.  Tokens are separated by 'delimiters', which can be a collection of Strings, or a collection of Characters.  Several delimiters in a row are considered as just one separation."

	| tokens keyStart keyStop |
	tokens _ OrderedCollection new.
	keyStop _ 1.
	[keyStop <= self size] whileTrue:
		[keyStart _ self skipAnySubStr: delimiters startingAt: keyStop.
		keyStop _ self findAnySubStr: delimiters startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findCloseParenthesisFor: startIndex
	"assume (self at: startIndex) is $(.  Find the matching $), allowing parentheses to nest."
	" '(1+(2-3))-3.14159' findCloseParenthesisFor: 1 "
	" '(1+(2-3))-3.14159' findCloseParenthesisFor: 4 "
	| pos nestLevel |
	pos := startIndex+1.
	nestLevel := 1.
	[ pos <= self size ] whileTrue: [
		(self at: pos) = $( ifTrue: [ nestLevel := nestLevel + 1 ].
		(self at: pos) = $) ifTrue: [ nestLevel := nestLevel - 1 ].
		nestLevel = 0 ifTrue: [ ^pos ].
		pos := pos + 1.
	].
	^self size + 1! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findDelimiters: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1."

	start to: self size do: [:i |
		delimiters do: [:delim | delim = (self at: i) ifTrue: [^ i]]].
	^ self size + 1! !

!String methodsFor: 'accessing' stamp: 'yo 10/15/2003 15:32'!
findLastOccuranceOfString: subString startingAt: start 
	"Answer the index of the last occurance of subString within the receiver, starting at start. If 
	the receiver does not contain subString, answer 0."

	| last now |
	last _ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder.
	last = 0 ifTrue: [^ 0].
	[last > 0] whileTrue: [
		now _ last.
		last _ self findSubstring: subString in: self startingAt: last + subString size matchTable: CaseSensitiveOrder.
	].

	^ now.
! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findString: subString
	"Answer the index of subString within the receiver, starting at start. If 
	the receiver does not contain subString, answer 0."
	^self findString: subString startingAt: 1.! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findString: subString startingAt: start 
	"Answer the index of subString within the receiver, starting at start. If 
	the receiver does not contain subString, answer 0."

	^ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findString: key startingAt: start caseSensitive: caseSensitive
	"Answer the index in this String at which the substring key first occurs, at or beyond start.  The match can be case-sensitive or not.  If no match is found, zero will be returned."

	caseSensitive
	ifTrue: [^ self findSubstring: key in: self startingAt: start matchTable: CaseSensitiveOrder]
	ifFalse: [^ self findSubstring: key in: self startingAt: start matchTable: CaseInsensitiveOrder]! !

!String methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:13'!
findTokens: delimiters
	"Answer the collection of tokens that result from parsing self.  Return strings between the delimiters.  Any character in the Collection delimiters marks a border.  Several delimiters in a row are considered as just one separation.  Also, allow delimiters to be a single character."

	| tokens keyStart keyStop separators |

	tokens _ OrderedCollection new.
	separators _ delimiters isCharacter 
		ifTrue: [Array with: delimiters]
		ifFalse: [delimiters].
	keyStop _ 1.
	[keyStop <= self size] whileTrue:
		[keyStart _ self skipDelimiters: separators startingAt: keyStop.
		keyStop _ self findDelimiters: separators startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: 'accessing' stamp: 'dtl 8/14/2004 11:27'!
findTokens: delimiters escapedBy: quoteDelimiters 
	"Answer a collection of Strings separated by the delimiters, where  
	delimiters is a Character or collection of characters. Two delimiters in a  
	row produce an empty string (compare this to #findTokens, which  
	treats sequential delimiters as one).  
	 
	The characters in quoteDelimiters are treated as quote characters, such  
	that any delimiter within a pair of matching quoteDelimiter characters  
	is treated literally, rather than as a delimiter.  
	 
	The quoteDelimiter characters may be escaped within a quoted string.  
	Two sequential quote characters within a quoted string are treated as  
	a single character.  
	 
	This method is useful for parsing comma separated variable strings for  
	spreadsheet import and export."

	| tokens rs activeEscapeCharacter ts char token delimiterChars quoteChars |
	delimiterChars _ (delimiters isNil
				ifTrue: ['']
				ifFalse: [delimiters]) asString.
	quoteChars _ (quoteDelimiters isNil
				ifTrue: ['']
				ifFalse: [quoteDelimiters]) asString.
	tokens _ OrderedCollection new.
	rs _ ReadStream on: self.
	activeEscapeCharacter _ nil.
	ts _ WriteStream on: ''.
	[rs atEnd]
		whileFalse: [char _ rs next.
			activeEscapeCharacter isNil
				ifTrue: [(quoteChars includes: char)
						ifTrue: [activeEscapeCharacter _ char]
						ifFalse: [(delimiterChars includes: char)
								ifTrue: [token _ ts contents.
									tokens add: token.
									ts _ WriteStream on: '']
								ifFalse: [ts nextPut: char]]]
				ifFalse: [char == activeEscapeCharacter
						ifTrue: [rs peek == activeEscapeCharacter
								ifTrue: [ts nextPut: rs next]
								ifFalse: [activeEscapeCharacter _ nil]]
						ifFalse: [ts nextPut: char]]].
	token _ ts contents.
	(tokens isEmpty and: [token isEmpty])
		ifFalse: [tokens add: token].
	^ tokens! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findTokens: delimiters includes: subString
	"Divide self into pieces using delimiters.  Return the piece that includes subString anywhere in it.  Is case sensitive (say asLowercase to everything beforehand to make insensitive)."

^ (self findTokens: delimiters) 
	detect: [:str | (str includesSubString: subString)] 
	ifNone: [nil]! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findTokens: delimiters keep: keepers
	"Answer the collection of tokens that result from parsing self.  The tokens are seperated by delimiters, any of a string of characters.  If a delimiter is also in keepers, make a token for it.  (Very useful for carriage return.  A sole return ends a line, but is also saved as a token so you can see where the line breaks were.)"

	| tokens keyStart keyStop |
	tokens _ OrderedCollection new.
	keyStop _ 1.
	[keyStop <= self size] whileTrue:
		[keyStart _ self skipDelimiters: delimiters startingAt: keyStop.
		keyStop to: keyStart-1 do: [:ii | 
			(keepers includes: (self at: ii)) ifTrue: [
				tokens add: (self copyFrom: ii to: ii)]].	"Make this keeper be a token"
		keyStop _ self findDelimiters: delimiters startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
findWordStart: key startingAt: start
	| ind |
	"HyperCard style searching.  Answer the index in self of the substring key, when that key is preceeded by a separator character.  Must occur at or beyond start.  The match is case-insensitive.  If no match is found, zero will be returned."

	ind _ start.
	[ind _ self findSubstring: key in: self startingAt: ind matchTable: CaseInsensitiveOrder.
	ind = 0 ifTrue: [^ 0].	"not found"
	ind = 1 ifTrue: [^ 1].	"First char is the start of a word"
	(self at: ind-1) isSeparator] whileFalse: [ind _ ind + 1].
	^ ind	"is a word start"! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
includesSubString: subString
	^ (self findString: subString startingAt: 1) > 0! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
includesSubstring: aString caseSensitive: caseSensitive
	
	^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! !

!String methodsFor: 'accessing' stamp: 'yo 8/28/2002 16:45'!
indexOf: aCharacter

	aCharacter isCharacter ifFalse: [^ 0].
	^ self class
		indexOfAscii: aCharacter asciiValue
		inString: self
		startingAt: 1.
! !

!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:31'!
indexOf: aCharacter startingAt: start

	(aCharacter isCharacter) ifFalse: [^ 0].
	^ self class indexOfAscii: aCharacter asciiValue inString: self startingAt: start! !

!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:31'!
indexOf: aCharacter  startingAt: start  ifAbsent: aBlock
	| ans |
	(aCharacter isCharacter) ifFalse: [ ^ aBlock value ].
	ans _ self class indexOfAscii: aCharacter asciiValue inString: self  startingAt: start.
	ans = 0
		ifTrue: [ ^ aBlock value ]
		ifFalse: [ ^ ans ]! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOfAnyOf: aCharacterSet
	"returns the index of the first character in the given set.  Returns 0 if none are found"
	^self indexOfAnyOf: aCharacterSet  startingAt: 1! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOfAnyOf: aCharacterSet  ifAbsent: aBlock
	"returns the index of the first character in the given set.  Returns the evaluation of aBlock if none are found"
	^self indexOfAnyOf: aCharacterSet  startingAt: 1  ifAbsent: aBlock! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOfAnyOf: aCharacterSet  startingAt: start
	"returns the index of the first character in the given set, starting from start.  Returns 0 if none are found"
	^self indexOfAnyOf: aCharacterSet  startingAt: start  ifAbsent: [ 0 ]! !

!String methodsFor: 'accessing' stamp: 'ar 4/10/2005 16:22'!
indexOfAnyOf: aCharacterSet  startingAt: start ifAbsent: aBlock
	"returns the index of the first character in the given set, starting from start"

	| ans |
	ans _ self class findFirstInString: self  inSet: aCharacterSet byteArrayMap startingAt: start.

	ans = 0 
		ifTrue: [ ^aBlock value ]
		ifFalse: [ ^ans ]! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOfSubCollection: sub 
	#Collectn.
	"Added 2000/04/08 For ANSI <sequenceReadableCollection> protocol."
	^ self
		indexOfSubCollection: sub
		startingAt: 1
		ifAbsent: [0]! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock
	| index |
	index _ self findSubstring: sub in: self startingAt: start matchTable: CaseSensitiveOrder.
	index = 0 ifTrue: [^ exceptionBlock value].
	^ index! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
lastIndexOfPKSignature: aSignature
	"Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found"
	| a b c d |
	a _ aSignature first.
	b _ aSignature second.
	c _ aSignature third.
	d _ aSignature fourth.
	(self size - 3) to: 1 by: -1 do: [ :i |
		(((self at: i) = a)
			and: [ ((self at: i + 1) = b)
				and: [ ((self at: i + 2) = c)
					and: [ ((self at: i + 3) = d) ]]])
						ifTrue: [ ^i ]
	].
	^0! !

!String methodsFor: 'accessing' stamp: 'yo 12/17/2002 16:56'!
leadingCharRunLengthAt: index

	| leadingChar |
	leadingChar _ (self at: index) leadingChar.
	index to: self size do: [:i |
		(self at: i) leadingChar ~= leadingChar ifTrue: [^ i - index].
	].
	^ self size - index + 1.
! !

!String methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:33'!
lineCorrespondingToIndex: anIndex
	"Answer a string containing the line at the given character position.  1/15/96 sw:  Inefficient first stab at this"

	| cr aChar answer |
	cr _ Character cr.
	answer _ ''.
	1 to: self size do:
		[:i | 
			aChar _ self at: i.
			aChar = cr
				ifTrue:
					[i > anIndex
						ifTrue:
							[^ answer]
						ifFalse:
							[answer _ '']]
				ifFalse:
					[answer _ answer copyWith: aChar]].
	^ answer! !

!String methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34'!
lineCount
	"Answer the number of lines represented by the receiver, where every cr adds one line.  5/10/96 sw"

	| cr count |
	cr _ Character cr.
	count _ 1  min: self size..
	1 to: self size do:
		[:i | (self at: i) = cr ifTrue: [count _ count + 1]].
	^ count

"
'Fred
the
Bear' lineCount
"! !

!String methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34'!
lineNumber: anIndex
	"Answer a string containing the characters in the given line number.  5/10/96 sw"

	| crString pos finalPos |
	crString _ String with: Character cr.
	pos _ 0.
	1 to: anIndex - 1 do:
		[:i | pos _ self findString: crString startingAt: pos + 1.
			pos = 0 ifTrue: [^ nil]].
	finalPos _ self findString: crString startingAt: pos + 1.
	finalPos = 0 ifTrue: [finalPos _ self size + 1].
	^ self copyFrom: pos + 1 to: finalPos - 1

"
'Fred
the
Bear' lineNumber: 3
"! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
linesDo: aBlock
	"execute aBlock with each line in this string.  The terminating CR's are not included in what is passed to aBlock"
	| start end |
	start _ 1.
	[ start <= self size ] whileTrue: [
		end _ self indexOf: Character cr  startingAt: start  ifAbsent: [ self size + 1 ].
		end _ end - 1.

		aBlock value: (self copyFrom: start  to: end).
		start _ end + 2. ].! !

!String methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:28'!
skipAnySubStr: delimiters startingAt: start 
	"Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed).  If the receiver is all delimiters, answer size + 1."

	| any this ind ii |
	ii _ start-1.
	[(ii _ ii + 1) <= self size] whileTrue: [ "look for char that does not match"
		any _ false.
		delimiters do: [:delim |
			delim isCharacter 
				ifTrue: [(self at: ii) == delim ifTrue: [any _ true]]
				ifFalse: ["a substring"
					delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was."
						[ind _ 0.
						this _ true.
						delim do: [:dd | 
							dd == (self at: ii+ind) ifFalse: [this _ false].
							ind _ ind + 1].
						this ifTrue: [ii _ ii + delim size - 1.  any _ true]]
							ifTrue: [any _ false] "if the delim is too big, it can't match"]].
		any ifFalse: [^ ii]].
	^ self size + 1! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
skipDelimiters: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that does NOT match one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1.  Assumes the delimiters to be a non-empty string."

	start to: self size do: [:i |
		delimiters detect: [:delim | delim = (self at: i)]
				ifNone: [^ i]].
	^ self size + 1! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
startsWithDigit
	"Answer whether the receiver's first character represents a digit"

	^ self size > 0 and: [self first isDigit]! !

!String methodsFor: 'accessing' stamp: 'md 5/26/2005 13:35'!
string
	^self! !

!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'!
tabDelimitedFieldsDo: aBlock
	"Considering the receiver as a holder of tab-delimited fields, evaluate execute aBlock with each field in this string.  The separatilng tabs are not included in what is passed to aBlock"

	| start end |
	"No senders but was useful enough in earlier work that it's retained for the moment."
	start _ 1.
	[start <= self size] whileTrue: 
		[end _ self indexOf: Character tab startingAt: start ifAbsent: [self size + 1].
		end _ end - 1.
		aBlock value: (self copyFrom: start  to: end).
		start _ end + 2]

"
'fred	charlie	elmo		2' tabDelimitedFieldsDo: [:aField | Transcript cr; show: aField]
"! !


!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
* arg

	^ arg adaptToString: self andSend: #*! !

!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
+ arg

	^ arg adaptToString: self andSend: #+! !

!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
- arg

	^ arg adaptToString: self andSend: #-! !

!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
/ arg

	^ arg adaptToString: self andSend: #/! !

!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
// arg

	^ arg adaptToString: self andSend: #//! !

!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'!
\\ arg

	^ arg adaptToString: self andSend: #\\! !


!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:19'!
< aString 
	"Answer whether the receiver sorts before aString.
	The collation order is simple ascii (with case differences)."

	^ (self compare: self with: aString collated: AsciiOrder) = 1! !

!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:20'!
<= aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is simple ascii (with case differences)."
	
	^ (self compare: self with: aString collated: AsciiOrder) <= 2! !

!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:21'!
= aString 
	"Answer whether the receiver sorts equally as aString.
	The collation order is simple ascii (with case differences)."
	
	aString isString ifFalse: [ ^ false ].
	^ (self compare: self with: aString collated: AsciiOrder) = 2! !

!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:21'!
> aString 
	"Answer whether the receiver sorts after aString.
	The collation order is simple ascii (with case differences)."

	^ (self compare: self with: aString collated: AsciiOrder) = 3! !

!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:21'!
>= aString 
	"Answer whether the receiver sorts after or equal to aString.
	The collation order is simple ascii (with case differences)."

	^ (self compare: self with: aString collated: AsciiOrder) >= 2! !

!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
alike: aString 
	"Answer some indication of how alike the receiver is to the argument,  0 is no match, twice aString size is best score.  Case is ignored."

	| i j k minSize bonus |
	minSize _ (j _ self size) min: (k _ aString size).
	bonus _ (j - k) abs < 2 ifTrue: [ 1 ] ifFalse: [ 0 ].
	i _ 1.
	[(i <= minSize) and: [((super at: i) bitAnd: 16rDF)  = ((aString at: i) asciiValue bitAnd: 16rDF)]]
		whileTrue: [ i _ i + 1 ].
	[(j > 0) and: [(k > 0) and:
		[((super at: j) bitAnd: 16rDF) = ((aString at: k) asciiValue bitAnd: 16rDF)]]]
			whileTrue: [ j _ j - 1.  k _ k - 1. ].
	^ i - 1 + self size - j + bonus. ! !

!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
beginsWith: prefix
	"Answer whether the receiver begins with the given prefix string.
	The comparison is case-sensitive."

	self size < prefix size ifTrue: [^ false].
	^ (self findSubstring: prefix in: self startingAt: 1
			matchTable: CaseSensitiveOrder) = 1
! !

!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 16:39'!
caseInsensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case insensitive."
	^(self compare: aString caseSensitive: false) <= 2! !

!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 16:39'!
caseSensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case sensitive."
	^(self compare: aString caseSensitive: true) <= 2! !

!String methodsFor: 'comparing' stamp: 'yo 8/27/2002 14:15'!
charactersExactlyMatching: aString
	"Do a character-by-character comparison between the receiver and aString.  Return the index of the final character that matched exactly."

	| count |
	count _ self size min: aString size.
	1 to: count do: [:i | 
		(self at: i) = (aString at: i) ifFalse: [
			^ i - 1]].
	^ count! !

!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 16:38'!
compare: aString 
	"Answer a comparison code telling how the receiver sorts relative to aString:
		1 - before
		2 - equal
		3 - after.
	The collation sequence is ascii with case differences ignored.
	To get the effect of a <= b, but ignoring case, use (a compare: b) <= 2."
	^self compare: aString caseSensitive: false! !

!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 16:42'!
compare: aString caseSensitive: aBool
	"Answer a comparison code telling how the receiver sorts relative to aString:
		1 - before
		2 - equal
		3 - after.
	"
	| map |
	map := aBool ifTrue:[CaseSensitiveOrder] ifFalse:[CaseInsensitiveOrder].
	^self compare: self with: aString collated: map! !

!String methodsFor: 'comparing' stamp: 'yo 12/15/2005 14:28'!
compare: string1 with: string2 collated: order

	(string1 isByteString and: [string2 isByteString]) ifTrue: [
		^ ByteString compare: string1 with: string2 collated: order
	].
     "Primitive does not fail properly right now"
      ^ String compare: string1 with: string2 collated: order

"
self assert: 'abc' = 'abc' asWideString.
self assert: 'abc' asWideString = 'abc'.
self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString ~= 'a000' asWideString).
self assert: ('a000' asWideString ~= (ByteArray with: 97 with: 0 with: 0 with: 0) asString).

self assert: ('abc' sameAs: 'aBc' asWideString).
self assert: ('aBc' asWideString sameAs: 'abc').
self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString sameAs: 'Abcd' asWideString) not.
self assert: ('a000' asWideString sameAs: (ByteArray with: 97 with: 0 with: 0 with: 0) asString) not.

"! !

!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 17:27'!
crc16
	"Compute a 16 bit cyclic redundancy check."

	| crc |
	crc := 0.
	1 to: self byteSize do: [:i |
		crc := (crc bitShift: -8) bitXor: (
		 #(	16r0000	16rC0C1	16rC181	16r0140	16rC301	16r03C0	16r0280	16rC241
			16rC601	16r06C0	16r0780	16rC741	16r0500	16rC5C1	16rC481	16r0440
			16rCC01	16r0CC0	16r0D80	16rCD41	16r0F00	16rCFC1	16rCE81	16r0E40
			16r0A00	16rCAC1	16rCB81	16r0B40	16rC901	16r09C0	16r0880	16rC841
			16rD801	16r18C0	16r1980	16rD941	16r1B00	16rDBC1	16rDA81	16r1A40
			16r1E00	16rDEC1	16rDF81	16r1F40	16rDD01	16r1DC0	16r1C80	16rDC41
			16r1400	16rD4C1	16rD581	16r1540	16rD701	16r17C0	16r1680	16rD641
			16rD201	16r12C0	16r1380	16rD341	16r1100	16rD1C1	16rD081	16r1040
			16rF001	16r30C0	16r3180	16rF141	16r3300	16rF3C1	16rF281	16r3240
			16r3600	16rF6C1	16rF781	16r3740	16rF501	16r35C0	16r3480	16rF441
			16r3C00	16rFCC1	16rFD81	16r3D40	16rFF01	16r3FC0	16r3E80	16rFE41
			16rFA01	16r3AC0	16r3B80	16rFB41	16r3900	16rF9C1	16rF881	16r3840
			16r2800	16rE8C1	16rE981	16r2940	16rEB01	16r2BC0	16r2A80	16rEA41
			16rEE01	16r2EC0	16r2F80	16rEF41	16r2D00	16rEDC1	16rEC81	16r2C40
			16rE401	16r24C0	16r2580	16rE541	16r2700	16rE7C1	16rE681	16r2640
			16r2200	16rE2C1	16rE381	16r2340	16rE101	16r21C0	16r2080	16rE041
			16rA001	16r60C0	16r6180	16rA141	16r6300	16rA3C1	16rA281	16r6240
			16r6600	16rA6C1	16rA781	16r6740	16rA501	16r65C0	16r6480	16rA441
			16r6C00	16rACC1	16rAD81	16r6D40	16rAF01	16r6FC0	16r6E80	16rAE41
			16rAA01	16r6AC0	16r6B80	16rAB41	16r6900	16rA9C1	16rA881	16r6840
			16r7800	16rB8C1	16rB981	16r7940	16rBB01	16r7BC0	16r7A80	16rBA41
			16rBE01	16r7EC0	16r7F80	16rBF41	16r7D00	16rBDC1	16rBC81	16r7C40
			16rB401	16r74C0	16r7580	16rB541	16r7700	16rB7C1	16rB681	16r7640
			16r7200	16rB2C1	16rB381	16r7340	16rB101	16r71C0	16r7080	16rB041
			16r5000	16r90C1	16r9181	16r5140	16r9301	16r53C0	16r5280	16r9241
			16r9601	16r56C0	16r5780	16r9741	16r5500	16r95C1	16r9481	16r5440
			16r9C01	16r5CC0	16r5D80	16r9D41	16r5F00	16r9FC1	16r9E81	16r5E40
			16r5A00	16r9AC1	16r9B81	16r5B40	16r9901	16r59C0	16r5880	16r9841
			16r8801	16r48C0	16r4980	16r8941	16r4B00	16r8BC1	16r8A81	16r4A40
			16r4E00	16r8EC1	16r8F81	16r4F40	16r8D01	16r4DC0	16r4C80	16r8C41
			16r4400	16r84C1	16r8581	16r4540	16r8701	16r47C0	16r4680	16r8641
			16r8201	16r42C0	16r4380	16r8341	16r4100	16r81C1	16r8081	16r4040)
			 at: ((crc bitXor: (self byteAt: i)) bitAnd: 16rFF) + 1) ].
	^crc! !

!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
endsWith: suffix
	"Answer whether the tail end of the receiver is the same as suffix.
	The comparison is case-sensitive."
	| extra |
	(extra _ self size - suffix size) < 0 ifTrue: [^ false].
	^ (self findSubstring: suffix in: self startingAt: extra + 1
			matchTable: CaseSensitiveOrder) > 0
"
  'Elvis' endsWith: 'vis'
"! !

!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
endsWithAnyOf: aCollection
	aCollection do:[:suffix|
		(self endsWith: suffix) ifTrue:[^true].
	].
	^false! !

!String methodsFor: 'comparing' stamp: 'md 2/16/2006 17:49'!
hash
	"#hash is implemented, because #= is implemented"
	"ar 4/10/2005: I had to change this to use ByteString hash as initial 
	hash in order to avoid having to rehash everything and yet compute
	the same hash for ByteString and WideString.
	md 16/10/2006: use identityHash as initialHash, as behavior hash will 
    use String hash (name) to have a better hash soon"
	^ self class stringHash: self initialHash: ByteString identityHash! !

!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !

!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
howManyMatch: string 
	"Count the number of characters that match up in self and aString."
	| count shorterLength |
	
	count  _  0 .
	shorterLength  _  ((self size ) min: (string size ) ) .
	(1 to: shorterLength  do: [:index |
		 (((self at: index ) = (string at: index )  ) ifTrue: [count  _  (count + 1 ) .
			]   ).
		]   ).
	^  count 
	
	! !

!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
match: text
	"Answer whether text matches the pattern in this string.
	Matching ignores upper/lower case differences.
	Where this string contains #, text may contain any character.
	Where this string contains *, text may contain any sequence of characters."

	^ self startingAt: 1 match: text startingAt: 1
"
	'*'			match: 'zort' true
	'*baz'		match: 'mobaz' true
	'*baz'		match: 'mobazo' false
	'*baz*'		match: 'mobazo' true
	'*baz*'		match: 'mozo' false
	'foo*'		match: 'foozo' true
	'foo*'		match: 'bozo' false
	'foo*baz'	match: 'foo23baz' true
	'foo*baz'	match: 'foobaz' true
	'foo*baz'	match: 'foo23bazo' false
	'foo'		match: 'Foo' true
	'foo*baz*zort' match: 'foobazort' false
	'foo*baz*zort' match: 'foobazzort' false
	'*foo#zort'	match: 'afoo3zortthenfoo3zort' true
	'*foo*zort'	match: 'afoodezortorfoo3zort' true
"! !

!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 17:35'!
sameAs: aString 
	"Answer whether the receiver sorts equal to aString. The 
	collation sequence is ascii with case differences ignored."
	^(self compare: aString caseSensitive: false) = 2! !

!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'!
startingAt: keyStart match: text startingAt: textStart
	"Answer whether text matches the pattern in this string.
	Matching ignores upper/lower case differences.
	Where this string contains #, text may contain any character.
	Where this string contains *, text may contain any sequence of characters."
	| anyMatch matchStart matchEnd i matchStr j ii jj |
	i _ keyStart.
	j _ textStart.

	"Check for any #'s"
	[i > self size ifTrue: [^ j > text size "Empty key matches only empty string"].
	(self at: i) = $#] whileTrue:
		["# consumes one char of key and one char of text"
		j > text size ifTrue: [^ false "no more text"].
		i _ i+1.  j _ j+1].

	"Then check for *"
	(self at: i) = $*
		ifTrue: [i = self size ifTrue:
					[^ true "Terminal * matches all"].
				"* means next match string can occur anywhere"
				anyMatch _ true.
				matchStart _ i + 1]
		ifFalse: ["Otherwise match string must occur immediately"
				anyMatch _ false.
				matchStart _ i].

	"Now determine the match string"
	matchEnd _ self size.
	(ii _ self indexOf: $* startingAt: matchStart) > 0 ifTrue:
		[ii = 1 ifTrue: [self error: '** not valid -- use * instead'].
		matchEnd _ ii-1].
	(ii _ self indexOf: $# startingAt: matchStart) > 0 ifTrue:
		[ii = 1 ifTrue: [self error: '*# not valid -- use #* instead'].
		matchEnd _ matchEnd min: ii-1].
	matchStr _ self copyFrom: matchStart to: matchEnd.

	"Now look for the match string"
	[jj _ text findString: matchStr startingAt: j caseSensitive: false.
	anyMatch ifTrue: [jj > 0] ifFalse: [jj = j]]
		whileTrue:
		["Found matchStr at jj.  See if the rest matches..."
		(self startingAt: matchEnd+1 match: text startingAt: jj + matchStr size) ifTrue:
			[^ true "the rest matches -- success"].
		"The rest did not match."
		anyMatch ifFalse: [^ false].
		"Preceded by * -- try for a later match"
		j _ j+1].
	^ false "Failed to find the match string"! !


!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with a collection, convert me to a number."

	^ rcvr perform: selector with: self asNumber! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
adaptToNumber: rcvr andSend: selector
	"If I am involved in arithmetic with a number, convert me to a number."

	^ rcvr perform: selector with: self asNumber! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
adaptToPoint: rcvr andSend: selector
	"If I am involved in arithmetic with a point, convert me to a number."

	^ rcvr perform: selector with: self asNumber! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
adaptToString: rcvr andSend: selector
	"If I am involved in arithmetic with a string, convert us both to
	numbers, and return the printString of the result."

	^ (rcvr asNumber perform: selector with: self asNumber) printString! !

!String methodsFor: 'converting' stamp: 'mw 1/30/2004 11:53'!
asAlphaNumeric: totalSize extraChars: additionallyAllowed mergeUID: minimalSizeOfRandomPart
	"Generates a String with unique identifier ( UID ) qualities, the difference to a
	 UUID is that its beginning is derived from the receiver, so that it has a meaning
	 for a human reader.

	 Answers a String of totalSize, which consists of 3 parts
	 1.part: the beginning of the receiver only consisting of
		a-z, A-Z, 0-9 and extraChars in Collection additionallyAllowed ( which can be nil )
	 2.part: a single _
	 3.part: a ( random ) UID of size >= minimalSizeOfRandomPart consisting of
		a-z, A-Z, 0-9

	 Starting letters are capitalized. 
	 TotalSize must be at least 1.
	 Exactly 1 occurrence of $_ is guaranteed ( unless additionallyAllowed includes $_ ).
	 The random part has even for small sizes good UID qualitites for many practical purposes.
	 If only lower- or uppercase letters are demanded, simply convert the answer with
	 say #asLowercase. The probability of a duplicate will rise only moderately ( see below ).

	 Example: 
		size of random part = 10
		in n generated UIDs the chance p of having non-unique UIDs is
			n = 10000 ->  p < 1e-10		if answer is reduced to lowerCase: p < 1.4 e-8
			n = 100000 -> p < 1e-8
		at the bottom is a snippet for your own calculations  
		Note: the calculated propabilites are theoretical,
			for the actually used random generator they may be much worse"

	| stream out sizeOfFirstPart index ascii ch skip array random |
	totalSize > minimalSizeOfRandomPart 
		ifFalse: [ self errorOutOfBounds ].
	stream := ReadStream on: self.
	out := WriteStream on: ( String new: totalSize ).
	index := 0.
	skip := true.
	sizeOfFirstPart := totalSize - minimalSizeOfRandomPart - 1.
	[ stream atEnd or: [ index >= sizeOfFirstPart ]]
	whileFalse: [
		((( ascii := ( ch := stream next ) asciiValue ) >= 65 and: [ ascii <= 90 ]) or: [
			( ascii >= 97 and: [ ascii <= 122 ]) or: [			 
			ch isDigit or: [
			additionallyAllowed notNil and: [ additionallyAllowed includes: ch ]]]])
		ifTrue: [
			skip
				ifTrue: [ out nextPut: ch asUppercase ]
				ifFalse: [ out nextPut: ch ].
			index := index + 1.
			skip := false ]
		ifFalse: [ skip := true ]].
	out nextPut: $_.
	array := Array new: 62.
	1 to: 26 do: [ :i |
		array at: i put: ( i + 64 ) asCharacter.
		array at: i + 26 put: ( i + 96 ) asCharacter ].
	53 to: 62 do: [ :i |
		array at: i put: ( i - 5 ) asCharacter ].
	random := UUIDGenerator default randomGenerator. 
	totalSize - index - 1 timesRepeat: [
		out nextPut: ( array atRandom: random )].
	^out contents

	"	calculation of probability p for failure of uniqueness in n UIDs
		Note: if answer will be converted to upper or lower case replace 62 with 36
	| n i p all |
	all := 62 raisedTo: sizeOfRandomPart.
	i := 1.
	p := 0.0 .
	n := 10000.
	[ i <= n ]
	whileTrue: [
		p := p + (( i - 1 ) / all ).
		i := i + 1 ].
	p   

	approximation formula: n squared / ( 62.0 raisedTo: sizeOfRandomPart ) / 2 
	" 

	"'Crop SketchMorphs and Grab Screen Rect to JPG' 
			asAlphaNumeric: 31 extraChars: nil mergeUID: 10  
	 			'CropSketchMorphsAndG_iOw94jquN6'
	 'Monticello' 
			asAlphaNumeric: 31 extraChars: nil mergeUID: 10    
				'Monticello_kp6aV2l0IZK9uBULGOeG' 
	 'version-', ( '1.1.2' replaceAll: $. with: $- )
			asAlphaNumeric: 31 extraChars: #( $- ) mergeUID: 10    
				'Version-1-1-2_kuz2tMg2xX9iRLDVR'"
		! !

!String methodsFor: 'converting' stamp: 'ar 4/10/2005 17:18'!
asByteArray
	"Convert to a ByteArray with the ascii values of the string."
	| b |
	b _ ByteArray new: self byteSize.
	1 to: self size * 4 do: [:i |
		b at: i put: (self byteAt: i).
	].
	^ b.
! !

!String methodsFor: 'converting' stamp: 'ar 4/10/2005 16:22'!
asByteString
	"Convert the receiver into a ByteString"
	^self asOctetString! !

!String methodsFor: 'converting' stamp: 'ar 4/10/2005 17:03'!
asCharacter
	"Answer the receiver's first character, or '*' if none.  Idiosyncratic, provisional."

	^ self size > 0 ifTrue: [self first] ifFalse:[$·]! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asDate
	"Many allowed forms, see Date>>#readFrom:"

	^ Date fromString: self! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asDateAndTime

	"Convert from UTC format" 	^ DateAndTime fromString: self! !

!String methodsFor: 'converting' stamp: 'yo 10/22/2002 17:38'!
asDefaultDecodedString

	^ self
! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asDisplayText
	"Answer a DisplayText whose text string is the receiver."

	^DisplayText text: self asText! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asDuration
	"convert from [nnnd]hh:mm:ss[.nanos] format. [] implies optional elements"

	^ Duration fromString: self
! !

!String methodsFor: 'converting' stamp: 'ar 4/12/2005 13:55'!
asFileName
	"Answer a String made up from the receiver that is an acceptable file 
	name."

	| string checkedString |
	string _ FileDirectory checkName: self fixErrors: true.
	checkedString _ (FilePath pathName: string) asVmPathName.
	^ (FilePath pathName: checkedString isEncoded: true) asSqueakPathName.
! !

!String methodsFor: 'converting' stamp: 'yo 8/27/2002 14:38'!
asFourCode

	| result |
	self size = 4 ifFalse: [^self error: 'must be exactly four characters'].
	result _ self inject: 0 into: [:val :each | 256 * val + each asciiValue].
	(result bitAnd: 16r80000000) = 0 
		ifFalse: [self error: 'cannot resolve fourcode'].
	(result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000].
	^ result
! !

!String methodsFor: 'converting' stamp: 'yo 8/26/2002 23:06'!
asHex
	| stream |
	stream _ WriteStream on: (String new: self size * 4).
	self do: [ :ch | stream nextPutAll: ch hex ].
	^stream contents! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asHtml
	"Do the basic character conversion for HTML.  Leave all original return 
	and tabs in place, so can conver back by simply removing bracked 
	things. 4/4/96 tk"
	| temp |
	temp _ self copyReplaceAll: '&' with: '&amp;'.
	HtmlEntities keysAndValuesDo:
		[:entity :char |
		char = $& ifFalse:
			[temp _ temp copyReplaceAll: char asString with: '&' , entity , ';']].
	temp _ temp copyReplaceAll: '	' with: '	<IMG SRC="tab.gif" ALT="    ">'.
	temp _ temp copyReplaceAll: '
' with: '
<BR>'.
	^ temp

"
	'A<&>B' asHtml
"! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asIRCLowercase
	"Answer a String made up from the receiver whose characters are all 
	lowercase, where 'lowercase' is by IRC's definition"

	^self collect: [ :c | c asIRCLowercase ]! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asIdentifier: shouldBeCapitalized
	"Return a legal identifier, with first character in upper case if shouldBeCapitalized is true, else lower case.  This will always return a legal identifier, even for an empty string"

	| aString firstChar firstLetterPosition |
	aString _ self select: [:el | el isAlphaNumeric].
	firstLetterPosition _ aString findFirst: [:ch | ch isLetter].
	aString _ firstLetterPosition == 0
		ifFalse:
			[aString copyFrom: firstLetterPosition to: aString size]
		ifTrue:
			['a', aString].
	firstChar _ shouldBeCapitalized ifTrue: [aString first asUppercase] ifFalse: [aString first asLowercase].

	^ firstChar asString, (aString copyFrom: 2 to: aString size)
"
'234Fred987' asIdentifier: false
'235Fred987' asIdentifier: true
'' asIdentifier: true
'()87234' asIdentifier: false
'())z>=PPve889  U >' asIdentifier: false

"! !

!String methodsFor: 'converting' stamp: 'laza 10/1/2004 09:55'!
asInteger 
	^self asSignedInteger
! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asLegalSelector
	| toUse |
	toUse _ ''.
	self do:
		[:char | char isAlphaNumeric ifTrue: [toUse _ toUse copyWith: char]].
	(self size == 0 or: [self first isLetter not])
		ifTrue:		[toUse _ 'v', toUse].

	^ toUse withFirstCharacterDownshifted

"'234znak 43 ) 2' asLegalSelector"! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asLowercase
	"Answer a String made up from the receiver whose characters are all 
	lowercase."

	^ self copy asString translateToLowercase! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asNumber 
	"Answer the Number created by interpreting the receiver as the string 
	representation of a number."

	^Number readFromString: self! !

!String methodsFor: 'converting' stamp: 'ar 4/10/2005 20:55'!
asOctetString
	"Convert the receiver into an octet string"
	| string |
	string _ String new: self size.
	1 to: self size do: [:i | string at: i put: (self at: i)].
	^string! !

!String methodsFor: 'converting' stamp: 'yo 8/27/2002 14:39'!
asPacked
	"Convert to a longinteger that describes the string"

	^ self inject: 0 into: [ :pack :next | pack _ pack * 256 + next asInteger ].! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asParagraph
	"Answer a Paragraph whose text string is the receiver."

	^Paragraph withText: self asText! !

!String methodsFor: 'converting' stamp: 'dew 9/13/2001 01:17'!
asPluralBasedOn: aNumberOrCollection
	"Append an 's' to this string based on whether aNumberOrCollection is 1 or of size 1."

	^ (aNumberOrCollection = 1 or:
		[aNumberOrCollection isCollection and: [aNumberOrCollection size = 1]])
			ifTrue: [self]
			ifFalse: [self, 's']
! !

!String methodsFor: 'converting' stamp: 'laza 10/1/2004 09:54'!
asSignedInteger 
	"Returns the first signed integer it can find or nil."

	| start stream |
	start := self findFirst: [:char | char isDigit].
	start isZero ifTrue: [^nil].
	stream := (ReadStream on: self) position: start.
	stream back = $- ifTrue: [stream back].
	^Integer readFrom: stream! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asSmalltalkComment
	"return this string, munged so that it can be treated as a comment in Smalltalk code.  Quote marks are added to the beginning and end of the string, and whenever a solitary quote mark appears within the string, it is doubled"

	^String streamContents:  [ :str |
		| quoteCount first |

		str nextPut: $".
	
		quoteCount := 0.
		first := true.
		self do: [ :char |
			char = $"
				ifTrue: [
					first ifFalse: [
						str nextPut: char.
						quoteCount := quoteCount + 1 ] ]
				ifFalse: [
					quoteCount odd ifTrue: [
						"add a quote to even the number of quotes in a row"
						str nextPut: $" ].
					quoteCount := 0.
					str nextPut: char ].
			first := false ]. 

		quoteCount odd ifTrue: [
			"check at the end"
			str nextPut: $". ].

		str nextPut: $".
	].
	! !

!String methodsFor: 'converting' stamp: 'yo 12/19/2003 21:16'!
asSqueakPathName

	^ self.
! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asString
	"Answer this string."

	^ self
! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asStringOrText
	"Answer this string."

	^ self
! !

!String methodsFor: 'converting' stamp: 'ar 4/10/2005 19:24'!
asSymbol
	"Answer the unique Symbol whose characters are the characters of the 
	string."
	^Symbol intern: self! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asText
	"Answer a Text whose string is the receiver."

	^Text fromString: self! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asTime
	"Many allowed forms, see Time>>readFrom:"

	^ Time fromString: self.! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asTimeStamp
	"Convert from obsolete TimeStamp format"

	^ TimeStamp fromString: self! !

!String methodsFor: 'converting' stamp: 'ar 4/10/2005 17:05'!
asUnHtml
	"Strip out all Html stuff (commands in angle brackets <>) and convert
the characters &<> back to their real value.  Leave actual cr and tab as
they were in text."
	| in out char rest did |
	in _ ReadStream on: self.
	out _ WriteStream on: (String new: self size).
	[in atEnd] whileFalse:
		[in peek = $<
			ifTrue: [in unCommand] 	"Absorb <...><...>"
			ifFalse: [(char _ in next) = $&
						ifTrue: [rest _ in upTo: $;.
								did _ out position.
								rest = 'lt' ifTrue: [out nextPut: $<].
								rest = 'gt' ifTrue: [out nextPut: $>].
								rest = 'amp' ifTrue: [out nextPut: $&].
								rest = 'deg' ifTrue: [out nextPut: $°].
								rest = 'quot' ifTrue: [out nextPut: $"].
								did = out position ifTrue: [
									self error: 'unknown encoded HTML char'.
									"Please add it to this method"]]
						ifFalse: [out nextPut: char]].
		].
	^ out contents! !

!String methodsFor: 'converting' stamp: 'laza 10/1/2004 10:02'!
asUnsignedInteger 
	"Returns the first integer it can find or nil."

	| start stream |
	start := self findFirst: [:char | char isDigit].
	start isZero ifTrue: [^nil].
	stream := (ReadStream on: self) position: start - 1.
	^Integer readFrom: stream! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asUppercase
	"Answer a String made up from the receiver whose characters are all 
	uppercase."

	^self copy asString translateToUppercase! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asUrl
	"convert to a Url"
	"'http://www.cc.gatech.edu/' asUrl"
	"msw://chaos.resnet.gatech.edu:9000/' asUrl"
	^Url absoluteFromText: self! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
asUrlRelativeTo: aUrl
	^aUrl newFromRelativeText: self! !

!String methodsFor: 'converting' stamp: 'yo 2/24/2005 18:33'!
asVmPathName

	^ (FilePath pathName: self) asVmPathName.
! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
askIfAddStyle: priorMethod req: requestor
	^ self   "we are a string with no text style"! !

!String methodsFor: 'converting' stamp: 'ar 4/12/2005 17:36'!
asWideString 
	self isWideString
		ifTrue:[^self]
		ifFalse:[^WideString from: self]! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
capitalized
	"Return a copy with the first letter capitalized"
	| cap |
	self isEmpty ifTrue: [ ^self copy ].
	cap _ self copy.
	cap at: 1 put: (cap at: 1) asUppercase.
	^ cap! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
compressWithTable: tokens
	"Return a string with all substrings that occur in tokens replaced
	by a character with ascii code = 127 + token index.
	This will work best if tokens are sorted by size.
	Assumes this string contains no characters > 127, or that they
	are intentionally there and will not interfere with this process."
	| str null finalSize start result ri c ts |
	null _ Character value: 0.
	str _ self copyFrom: 1 to: self size.  "Working string will get altered"
	finalSize _ str size.
	tokens doWithIndex:
		[:token :tIndex |
		start _ 1.
		[(start _ str findString: token startingAt: start) > 0]
			whileTrue:
			[ts _ token size.
			((start + ts) <= str size
				and: [(str at: start + ts) = $  and: [tIndex*2 <= 128]])
				ifTrue: [ts _ token size + 1.  "include training blank"
						str at: start put: (Character value: tIndex*2 + 127)]
				ifFalse: [str at: start put: (Character value: tIndex + 127)].
			str at: start put: (Character value: tIndex + 127).
			1 to: ts-1 do: [:i | str at: start+i put: null].
			finalSize _ finalSize - (ts - 1).
			start _ start + ts]].
	result _ String new: finalSize.
	ri _ 0.
	1 to: str size do:
		[:i | (c _ str at: i) = null ifFalse: [result at: (ri _ ri+1) put: c]].
	^ result! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
contractTo: smallSize
	"return myself or a copy shortened by ellipsis to smallSize"
	| leftSize |
	self size <= smallSize
		ifTrue: [^ self].  "short enough"
	smallSize < 5
		ifTrue: [^ self copyFrom: 1 to: smallSize].    "First N characters"
	leftSize _ smallSize-2//2.
	^ self copyReplaceFrom: leftSize+1		"First N/2 ... last N/2"
		to: self size - (smallSize - leftSize - 3)
		with: '...'
"
	'A clear but rather long-winded summary' contractTo: 18
"! !

!String methodsFor: 'converting' stamp: 'KR 1/30/2006 21:47'!
convertFromEncoding: encodingName
	^self convertFromWithConverter: (TextConverter newForEncoding: encodingName)! !

!String methodsFor: 'converting' stamp: 'KR 1/30/2006 21:47'!
convertFromSuperSwikiServerString
	^self convertFromEncoding: 'shift_jis'! !

!String methodsFor: 'converting' stamp: 'yo 7/8/2004 12:02'!
convertFromWithConverter: converter

	| readStream writeStream c |
	readStream _ self readStream.
	writeStream _ String new writeStream.
	converter ifNil: [^ self].
	[readStream atEnd] whileFalse: [
		c _ converter nextFromStream: readStream.
		c ifNotNil: [writeStream nextPut: c] ifNil: [^ writeStream contents]
	].
	^ writeStream contents
! !

!String methodsFor: 'converting' stamp: 'KR 1/30/2006 21:49'!
convertToEncoding: encodingName
	^self convertToWithConverter: (TextConverter newForEncoding: encodingName).! !

!String methodsFor: 'converting' stamp: 'KR 1/30/2006 21:50'!
convertToSuperSwikiServerString
	^self convertToEncoding: 'shift_jis'! !

!String methodsFor: 'converting' stamp: 'ar 4/12/2005 14:01'!
convertToSystemString

	| readStream writeStream converter |
	readStream _ self readStream.
	writeStream _ String new writeStream.
	converter _ LanguageEnvironment defaultSystemConverter.
	converter ifNil: [^ self].
	[readStream atEnd] whileFalse: [
		converter nextPut: readStream next toStream: writeStream
	].
	converter emitSequenceToResetStateIfNeededOn: writeStream.
	^ writeStream contents.
! !

!String methodsFor: 'converting' stamp: 'yo 7/8/2004 12:01'!
convertToWithConverter: converter

	| readStream writeStream |
	readStream _ self readStream.
	writeStream _ String new writeStream.
	converter ifNil: [^ self].
	[readStream atEnd] whileFalse: [
		converter nextPut: readStream next toStream: writeStream
	].
	converter emitSequenceToResetStateIfNeededOn: writeStream.
	^ writeStream contents.
! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
correctAgainst: wordList
	"Correct the receiver: assume it is a misspelled word and return the (maximum of five) nearest words in the wordList.  Depends on the scoring scheme of alike:"
	| results |
	results _ self correctAgainst: wordList continuedFrom: nil.
	results _ self correctAgainst: nil continuedFrom: results.
	^ results! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
correctAgainst: wordList continuedFrom: oldCollection
	"Like correctAgainst:.  Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList."

	^ wordList isNil
		ifTrue: [ self correctAgainstEnumerator: nil
					continuedFrom: oldCollection ]
		ifFalse: [ self correctAgainstEnumerator: [ :action | wordList do: action without: nil]
					continuedFrom: oldCollection ]! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
correctAgainstDictionary: wordDict continuedFrom: oldCollection
	"Like correctAgainst:continuedFrom:.  Use when you want to correct against a dictionary."

	^ wordDict isNil
		ifTrue: [ self correctAgainstEnumerator: nil
					continuedFrom: oldCollection ]
		ifFalse: [ self correctAgainstEnumerator: [ :action | wordDict keysDo: action ]
					continuedFrom: oldCollection ]! !

!String methodsFor: 'converting' stamp: 'yo 7/29/2005 16:04'!
encodeForHTTP
	"change dangerous characters to their %XX form, for use in HTTP transactions"

	^ self encodeForHTTPWithTextEncoding: 'utf-8' conditionBlock: [:c | c isSafeForHTTP].
! !

!String methodsFor: 'converting' stamp: 'yo 7/29/2005 16:04'!
encodeForHTTPWithTextEncoding: encodingName

	^ self encodeForHTTPWithTextEncoding: encodingName conditionBlock: [:c | c isSafeForHTTP].
! !

!String methodsFor: 'converting' stamp: 'yo 7/29/2005 16:03'!
encodeForHTTPWithTextEncoding: encodingName conditionBlock: conditionBlock
	"change dangerous characters to their %XX form, for use in HTTP transactions"

	| httpSafeStream encodedStream cont |
	httpSafeStream _ WriteStream on: (String new).
	encodedStream _ MultiByteBinaryOrTextStream on: (String new: 6).
	encodedStream converter: (TextConverter newForEncoding: encodingName).
	self do: [:c |
		(conditionBlock value: c)
			ifTrue: [httpSafeStream nextPut: (Character value: c charCode)]
			ifFalse: [
				encodedStream text; reset.
				encodedStream nextPut: c.
				encodedStream position: 0.
				encodedStream binary.
				cont _ encodedStream contents.
				cont do: [:byte |
					httpSafeStream nextPut: $%.
					httpSafeStream nextPut: (byte // 16) asHexDigit.
					httpSafeStream nextPut: (byte \\ 16) asHexDigit.
				].
			].
	].
	^ httpSafeStream contents.
! !

!String methodsFor: 'converting' stamp: 'yo 7/5/2004 16:48'!
findSelector
	"Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it."
	| sel possibleParens level n |
	sel _ self withBlanksTrimmed.
	(sel includes: $:) ifTrue:
		[sel _ sel copyReplaceAll: ':' with: ': '.	"for the style (aa max:bb) with no space"
		possibleParens _ sel findTokens: Character separators.
		sel _ self class streamContents:
			[:s | level _ 0.
			possibleParens do:
				[:token |
				(level = 0 and: [token endsWith: ':'])
					ifTrue: [s nextPutAll: token]
					ifFalse: [(n _ token occurrencesOf: $( ) > 0 ifTrue: [level _ level + n].
							(n _ token occurrencesOf: $[ ) > 0 ifTrue: [level _ level + n].
							(n _ token occurrencesOf: $] ) > 0 ifTrue: [level _ level - n].
							(n _ token occurrencesOf: $) ) > 0 ifTrue: [level _ level - n]]]]].

	sel isEmpty ifTrue: [^ nil].
	sel isOctetString ifTrue: [sel _ sel asOctetString].
	Symbol hasInterned: sel ifTrue:
		[:aSymbol | ^ aSymbol].
	^ nil! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
initialIntegerOrNil
	"Answer the integer represented by the leading digits of the receiver, or nil if the receiver does not begin with a digit"
	| firstNonDigit |
	(self size == 0 or: [self first isDigit not]) ifTrue: [^ nil].
	firstNonDigit _ (self findFirst: [:m | m isDigit not]).
	firstNonDigit = 0 ifTrue: [firstNonDigit _ self size + 1].
	^ (self copyFrom: 1  to: (firstNonDigit - 1)) asNumber
"
'234Whoopie' initialIntegerOrNil
'wimpy' initialIntegerOrNil
'234' initialIntegerOrNil
'2N' initialIntegerOrNil
'2' initialIntegerOrNil
'  89Ten ' initialIntegerOrNil
'78 92' initialIntegerOrNil
"
! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
keywords
	"Answer an array of the keywords that compose the receiver."
	| kwd char keywords |
	keywords _ Array streamContents:
		[:kwds | kwd _ WriteStream on: (String new: 16).
		1 to: self size do:
			[:i |
			kwd nextPut: (char _ self at: i).
			char = $: ifTrue: 
					[kwds nextPut: kwd contents.
					kwd reset]].
		kwd isEmpty ifFalse: [kwds nextPut: kwd contents]].
	(keywords size >= 1 and: [(keywords at: 1) = ':']) ifTrue:
		["Has an initial keyword, as in #:if:then:else:"
		keywords _ keywords allButFirst].
	(keywords size >= 2 and: [(keywords at: keywords size - 1) = ':']) ifTrue:
		["Has a final keyword, as in #nextPut::andCR"
		keywords _ keywords copyReplaceFrom: keywords size - 1
								to: keywords size with: {':' , keywords last}].
	^ keywords! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
numericSuffix
	^ self stemAndNumericSuffix last

"
'abc98' numericSuffix
'98abc' numericSuffix
"! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
onlyLetters
	"answer the receiver with only letters"
	^ self select:[:each | each isLetter]! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
romanNumber
	| value v1 v2 |
	value _ v1 _ v2 _ 0.
	self reverseDo:
		[:each |
		v1 _ #(1 5 10 50 100 500 1000) at: ('IVXLCDM' indexOf: each).
		v1 >= v2
			ifTrue: [value _ value + v1]
			ifFalse: [value _ value - v1].
		v2 _ v1].
	^ value! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
sansPeriodSuffix
	"Return a copy of the receiver up to, but not including, the first period.  If the receiver's *first* character is a period, then just return the entire receiver. "

	| likely |
	likely _ self copyUpTo: $..
	^ likely size == 0
		ifTrue:	[self]
		ifFalse:	[likely]! !

!String methodsFor: 'converting' stamp: 'yo 8/27/2002 11:13'!
splitInteger
	"Answer an array that is a splitting of self into a string and an integer.
	'43Sam' ==> #(43 'Sam').  'Try90' ==> #('Try' 90)
	BUT NOTE: 'Sam' ==> #('Sam' 0), and '90' ==> #('' 90)  ie, (<string> <integer>)."

	| pos |
	(pos _ self findFirst: [:d | d isDigit not]) = 0 ifTrue: [^ Array with: '' with: self asNumber].
	self first isDigit ifTrue: [
		^ Array with: (self copyFrom: 1 to: pos - 1) asNumber 
				with: (self copyFrom: pos to: self size)].
	(pos _ self findFirst: [:d | d isDigit]) = 0 ifTrue: [^ Array with: self with: 0].
	^ Array with: (self copyFrom: 1 to: pos - 1)
			with: (self copyFrom: pos to: self size) asNumber! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
stemAndNumericSuffix
	"Parse the receiver into a string-valued stem and a numeric-valued suffix.  6/7/96 sw"

	| stem suffix position |

	stem _ self.
	suffix _ 0.
	position _ 1.
	[stem endsWithDigit and: [stem size > 1]] whileTrue:
		[suffix _  stem last digitValue * position + suffix.
		position _ position * 10.
		stem _ stem copyFrom: 1 to: stem size - 1].
	^ Array with: stem with: suffix

"'Fred2305' stemAndNumericSuffix"! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
subStrings
	"Answer an array of the substrings that compose the receiver."
	#Collectn.
	"Added 2000/04/08 For ANSI <readableString> protocol."
	^ self substrings! !

!String methodsFor: 'converting' stamp: 'ar 4/12/2005 16:32'!
subStrings: separators 
	"Answer an array containing the substrings in the receiver separated 
	by the elements of separators."
	| char result sourceStream subString |
	#Collectn.
	"Changed 2000/04/08 For ANSI <readableString> protocol."
	(separators isString or:[separators allSatisfy: [:element | element isKindOf: Character]])
		ifFalse: [^ self error: 'separators must be Characters.'].
	sourceStream := ReadStream on: self.
	result := OrderedCollection new.
	subString := String new.
	[sourceStream atEnd]
		whileFalse: 
			[char := sourceStream next.
			(separators includes: char)
				ifTrue: [subString notEmpty
						ifTrue: 
							[result add: subString copy.
							subString := String new]]
				ifFalse: [subString := subString , (String with: char)]].
	subString notEmpty ifTrue: [result add: subString copy].
	^ result asArray! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
substrings
	"Answer an array of the substrings that compose the receiver."
	| result end beginning |

	result _ WriteStream on: (Array new: 10).



	end _ 0.
	"find one substring each time through this loop"
	[ 
		"find the beginning of the next substring"
		beginning _ self indexOfAnyOf: CSNonSeparators startingAt: end+1 ifAbsent: [ nil ].
		beginning ~~ nil ] 
	whileTrue: [
		"find the end"
		end _ self indexOfAnyOf: CSSeparators startingAt: beginning ifAbsent: [ self size + 1 ].
		end _ end - 1.

		result nextPut: (self copyFrom: beginning to: end).

	].


	^result contents! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
surroundedBySingleQuotes
	"Answer the receiver with leading and trailing quotes.  "

	^ $' asString, self, $' asString! !

!String methodsFor: 'converting' stamp: 'yo 8/28/2002 15:14'!
translateFrom: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"
	self class translate: self from: start to: stop table: table! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
translateToLowercase
	"Translate all characters to lowercase, in place"

	self translateWith: LowercasingTable! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
translateToUppercase
	"Translate all characters to lowercase, in place"

	self translateWith: UppercasingTable! !

!String methodsFor: 'converting' stamp: 'yo 8/28/2002 15:13'!
translateWith: table
	"translate the characters in the string by the given table, in place"
	^ self translateFrom: 1 to: self size table: table! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
truncateTo: smallSize
	"return myself or a copy shortened to smallSize.  1/18/96 sw"

	^ self size <= smallSize
		ifTrue:
			[self]
		ifFalse:
			[self copyFrom: 1 to: smallSize]! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
truncateWithElipsisTo: maxLength
	"Return myself or a copy suitably shortened but with elipsis added"

	^ self size <= maxLength
		ifTrue:
			[self]
		ifFalse:
			[(self copyFrom: 1 to: (maxLength - 3)), '...']


	"'truncateWithElipsisTo:' truncateWithElipsisTo: 20"! !

!String methodsFor: 'converting' stamp: 'KR 9/22/2005 23:06'!
unescapePercents
	"decode %xx form.  This is the opposite of #encodeForHTTP"
	^ self unescapePercentsWithTextEncoding: 'utf-8'.! !

!String methodsFor: 'converting' stamp: 'ky 7/8/2006 17:56'!
unescapePercentsWithTextEncoding: encodingName 
	"decode string including %XX form"
	| unescaped char asciiVal specialChars oldPos pos converter |
	unescaped := ReadWriteStream on: String new.
	specialChars := '+%' asCharacterSet.
	oldPos := 1.
	[pos := self indexOfAnyOf: specialChars startingAt: oldPos.
	pos > 0]
		whileTrue: [unescaped
				nextPutAll: (self copyFrom: oldPos to: pos - 1).
			char := self at: pos.
			(char = $%
					and: [pos + 2 <= self size])
				ifTrue: [asciiVal := (self at: pos + 1) asUppercase digitValue * 16 + (self at: pos + 2) asUppercase digitValue.
					asciiVal > 255
						ifTrue: [^ self].
					unescaped
						nextPut: (Character value: asciiVal).
					pos := pos + 3.
					pos <= self size
						ifFalse: [char := nil].
					oldPos := pos]
				ifFalse: [char = $+
						ifTrue: [unescaped nextPut: Character space]
						ifFalse: [unescaped nextPut: char].
					oldPos := pos + 1]].
	oldPos <= self size
		ifTrue: [unescaped
				nextPutAll: (self copyFrom: oldPos to: self size)].
	converter := (TextConverter newForEncoding: encodingName)
				ifNil: [TextConverter newForEncoding: nil].
	^ [unescaped contents convertFromWithConverter: converter]
		on: Error
		do: ["the contents may be squeak-encoded"
			unescaped contents]! !

!String methodsFor: 'converting' stamp: 'yo 8/27/2002 11:20'!
unparenthetically
	"If the receiver starts with (..( and ends with matching )..), strip them"

	| curr |
	curr _ self.
	[((curr first = $() and: [curr last = $)])] whileTrue:
		[curr _ curr copyFrom: 2 to: (curr size - 1)].

	^ curr

"

'((fred the bear))' unparenthetically

"
		! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
unzipped
	| magic1 magic2 |
	magic1 _ (self at: 1) asInteger.
	magic2 _ (self at: 2) asInteger.
	(magic1 = 16r1F and:[magic2 = 16r8B]) ifFalse:[^self].
	^(GZipReadStream on: self) upToEnd! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
withBlanksCondensed
	"Return a copy of the receiver with leading/trailing blanks removed
	 and consecutive white spaces condensed."

	| trimmed lastBlank |
	trimmed _ self withBlanksTrimmed.
	^String streamContents: [:stream |
		lastBlank _ false.
		trimmed do: [:c | (c isSeparator and: [lastBlank]) ifFalse: [stream nextPut: c].
			lastBlank _ c isSeparator]].

	" ' abc  d   ' withBlanksCondensed"
! !

!String methodsFor: 'converting' stamp: 'yo 7/5/2004 16:43'!
withBlanksTrimmed
	"Return a copy of the receiver from which leading and trailing blanks have been trimmed."

	| first result |
	first _ self findFirst: [:c | c isSeparator not].
	first = 0 ifTrue: [^ ''].  "no non-separator character"
	result _  self
		copyFrom: first
		to: (self findLast: [:c | c isSeparator not]).
	result isOctetString ifTrue: [^ result asOctetString] ifFalse: [^ result].

	" ' abc  d   ' withBlanksTrimmed"
! !

!String methodsFor: 'converting' stamp: 'md 9/19/2004 15:19'!
withFirstCharacterDownshifted
	"Return a copy with the first letter downShifted"
	
	| answer |
	
	self ifEmpty: [^ self copy].
	answer _ self copy.
	answer at: 1 put: (answer at: 1) asLowercase.
	^ answer. ! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
withNoLineLongerThan: aNumber
	"Answer a string with the same content as receiver, but rewrapped so that no line has more characters than the given number"
	| listOfLines currentLast currentStart resultString putativeLast putativeLine crPosition |
	aNumber isNumber not | (aNumber < 1) ifTrue: [self error: 'too narrow'].
	listOfLines _ OrderedCollection new.
	currentLast _ 0.
	[currentLast < self size] whileTrue:
		[currentStart _ currentLast + 1.
		putativeLast _ (currentStart + aNumber - 1) min: self size.
		putativeLine _ self copyFrom: currentStart to: putativeLast.
		(crPosition _ putativeLine indexOf: Character cr) > 0 ifTrue:
			[putativeLast _ currentStart + crPosition - 1.
			putativeLine _ self copyFrom: currentStart to: putativeLast].
		currentLast _ putativeLast == self size
			ifTrue:
				[putativeLast]
			ifFalse:
				[currentStart + putativeLine lastSpacePosition - 1].
		currentLast <= currentStart ifTrue:
			["line has NO spaces; baleout!!"
			currentLast _ putativeLast].
		listOfLines add: (self copyFrom: currentStart to: currentLast) withBlanksTrimmed].

	listOfLines size > 0 ifFalse: [^ ''].
	resultString _ listOfLines first.
	2 to: listOfLines size do:
		[:i | resultString _ resultString, String cr, (listOfLines at: i)].
	^ resultString

"#(5 7 20) collect:
	[:i | 'Fred the bear went down to the brook to read his book in silence' withNoLineLongerThan: i]"! !

!String methodsFor: 'converting' stamp: 'md 10/5/2005 11:01'!
withoutLeadingBlanks
	
	"Return a copy of the receiver from which leading blanks have been
trimmed."

	
	| first |
	
	first := self findFirst: [:c | c isSeparator not ].

	first = 0 ifTrue: [^ ''].  
	
	"no non-separator character"
	
	^ self copyFrom: first to: self size

	
		
	" '    abc  d' withoutLeadingBlanks"
! !

!String methodsFor: 'converting' stamp: 'tak 4/25/2004 12:57'!
withSeparatorsCompacted
	"replace each sequences of whitespace by a single space character"
	"' test ' withSeparatorsCompacted = ' test '"
	"' test test' withSeparatorsCompacted = ' test test'"
	"'test test		' withSeparatorsCompacted = 'test test '"

	| out in next isSeparator |
	self isEmpty ifTrue: [^ self].

	out _ WriteStream on: (String new: self size).
	in _ self readStream.
	isSeparator _ [:char | char asciiValue < 256
				and: [CSSeparators includes: char]].
	[in atEnd] whileFalse: [
		next _ in next.
		(isSeparator value: next)
			ifTrue: [
				out nextPut: $ .
				[in atEnd or:
					[next _ in next.
					(isSeparator value: next)
						ifTrue: [false]
						ifFalse: [out nextPut: next. true]]] whileFalse]
			ifFalse: [out nextPut: next]].
	^ out contents! !

!String methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06'!
withoutLeadingDigits
	"Answer the portion of the receiver that follows any leading series of digits and blanks.  If the receiver consists entirely of digits and blanks, return an empty string"
	| firstNonDigit |
	firstNonDigit _ (self findFirst: [:m | m isDigit not and: [m ~= $ ]]).
	^ firstNonDigit > 0
		ifTrue:
			[self copyFrom: firstNonDigit  to: self size]
		ifFalse:
			['']

"
'234Whoopie' withoutLeadingDigits
' 4321 BlastOff!!' withoutLeadingDigits
'wimpy' withoutLeadingDigits
'  89Ten ' withoutLeadingDigits
'78 92' withoutLeadingDigits
"
! !

!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'!
withoutTrailingBlanks
	"Return a copy of the receiver from which trailing blanks have been trimmed."

	| last |
	last _ self findLast: [:c | c isSeparator not].
	last = 0 ifTrue: [^ ''].  "no non-separator character"
	^ self copyFrom: 1 to: last

	" ' abc  d   ' withoutTrailingBlanks"
! !

!String methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06'!
withoutTrailingDigits
	"Answer the portion of the receiver that precedes any trailing series of digits and blanks.  If the receiver consists entirely of digits and blanks, return an empty string"
	| firstDigit |
	firstDigit _ (self findFirst: [:m | m isDigit or: [m = $ ]]).
	^ firstDigit > 0
		ifTrue:
			[self copyFrom: 1 to: firstDigit-1]
		ifFalse:
			[self]

"
'Whoopie234' withoutTrailingDigits
' 4321 BlastOff!!' withoutLeadingDigits
'wimpy' withoutLeadingDigits
'  89Ten ' withoutLeadingDigits
'78 92' withoutLeadingDigits
"
! !


!String methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'!
copyReplaceTokens: oldSubstring with: newSubstring 
	"Replace all occurrences of oldSubstring that are surrounded
	by non-alphanumeric characters"
	^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true
	"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! !

!String methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'!
deepCopy
	"DeepCopy would otherwise mean make a copy of the character;  since 
	characters are unique, just return a shallowCopy."

	^self shallowCopy! !

!String methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'!
padded: leftOrRight to: length with: char
	leftOrRight = #left ifTrue:
		[^ (String new: (length - self size max: 0) withAll: char) , self].
	leftOrRight = #right ifTrue:
		[^ self , (String new: (length - self size max: 0) withAll: char)].! !


!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'!
displayAt: aPoint 
	"Display the receiver as a DisplayText at aPoint on the display screen."

	self displayOn: Display at: aPoint! !

!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'!
displayOn: aDisplayMedium
	"Display the receiver on the given DisplayMedium.  5/16/96 sw"

	self displayOn: aDisplayMedium at: 0 @ 0! !

!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'!
displayOn: aDisplayMedium at: aPoint 
	"Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, using black-colored text."

	self displayOn: aDisplayMedium at: aPoint textColor: Color black! !

!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'!
displayOn: aDisplayMedium at: aPoint textColor: aColor
	"Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, rendering the text in the designated color"

	(self asDisplayText foregroundColor: (aColor ifNil: [Color black]) backgroundColor: Color white)
		displayOn: aDisplayMedium at: aPoint! !

!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'!
displayProgressAt: aPoint from: minVal to: maxVal during: workBlock 
	"Display this string as a caption over a progress bar while workBlock is evaluated.

EXAMPLE (Select next 6 lines and Do It)
'Now here''s some Real Progress'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: 10
	during: [:bar |
	1 to: 10 do: [:x | bar value: x.
			(Delay forMilliseconds: 500) wait]].

HOW IT WORKS (Try this in any other language :-)
Since your code (the last 2 lines in the above example) is in a block,
this method gets control to display its heading before, and clean up 
the screen after, its execution.
The key, though, is that the block is supplied with an argument,
named 'bar' in the example, which will update the bar image every 
it is sent the message value: x, where x is in the from:to: range.
"
	^ProgressInitiationException 
		display: self
		at: aPoint 
		from: minVal 
		to: maxVal 
		during: workBlock! !


!String methodsFor: 'encoding' stamp: 'ar 4/10/2005 17:16'!
getInteger32: location
	| integer |
	<primitive: 'getInteger' module: 'IntegerPokerPlugin'>
	"^IntegerPokerPlugin doPrimitive: #getInteger"

	"the following is about 7x faster than interpreting the plugin if not compiled"

	integer := 
		((self at: location) asInteger bitShift: 24) +
		((self at: location+1) asInteger bitShift: 16) +
		((self at: location+2) asInteger bitShift: 8) +
		(self at: location+3) asInteger.

	integer > 1073741824 ifTrue: [^1073741824 - integer ].
	^integer
! !

!String methodsFor: 'encoding' stamp: 'ar 4/10/2005 17:17'!
putInteger32: anInteger at: location
	| integer |
	<primitive: 'putInteger' module: 'IntegerPokerPlugin'>
	"IntegerPokerPlugin doPrimitive: #putInteger"

	"the following is close to 20x faster than the above if the primitive is not compiled"
	"PUTCOUNTER _ PUTCOUNTER + 1."
	integer _ anInteger.
	integer < 0 ifTrue: [integer :=  1073741824 - integer. ].
	self at: location+3 put: (Character value: (integer \\ 256)).
	self at: location+2 put: (Character value: (integer bitShift: -8) \\ 256).
	self at: location+1 put: (Character value: (integer bitShift: -16) \\ 256).
	self at: location put: (Character value: (integer bitShift: -24) \\ 256).

"Smalltalk at: #PUTCOUNTER put: 0"! !

!String methodsFor: 'encoding' stamp: 'ar 4/10/2005 17:18'!
writeLeadingCharRunsOn: stream

	| runLength runValues runStart leadingChar |
	self isEmpty ifTrue: [^ self].

	runLength _ OrderedCollection new.
	runValues _ OrderedCollection new.
	runStart _ 1.
	leadingChar _ (self at: runStart) leadingChar.
	2 to: self size do: [:index |
		(self at: index) leadingChar = leadingChar ifFalse: [
			runValues add: leadingChar.
			runLength add: (index - runStart).
			leadingChar _ (self at: index) leadingChar.
			runStart _ index.
		].
	].
	runValues add: (self last) leadingChar.
	runLength add: self size + 1 -  runStart.

	stream nextPut: $(.
	runLength do: [:rr | rr printOn: stream. stream space].
	stream skip: -1; nextPut: $).
	runValues do: [:vv | vv printOn: stream. stream nextPut: $,].
	stream skip: -1.
! !


!String methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31'!
byteEncode:aStream

	^aStream writeString: self.
! !

!String methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31'!
putOn:aStream

	^aStream nextPutAll: self.
! !


!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'!
expandMacros
	^self expandMacrosWithArguments: #()! !

!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'!
expandMacrosWithArguments: anArray 
	| newStream readStream char index |
	newStream := WriteStream on: (String new: self size).
	readStream := ReadStream on: self.
	[readStream atEnd] whileFalse: 
			[char := readStream next.
			char == $< 
				ifTrue: 
					[| nextChar |
					nextChar := readStream next asUppercase.
					nextChar == $N ifTrue: [newStream cr].
					nextChar == $T ifTrue: [newStream tab].
					nextChar isDigit 
						ifTrue: 
							[index := nextChar digitValue.
							
							[readStream atEnd 
								or: [(nextChar := readStream next asUppercase) isDigit not]] 
									whileFalse: [index := index * 10 + nextChar digitValue]].
					nextChar == $? 
						ifTrue: 
							[| trueString falseString |
							trueString := readStream upTo: $:.
							falseString := readStream upTo: $>.
							readStream position: readStream position - 1.
							newStream 
								nextPutAll: ((anArray at: index) ifTrue: [trueString] ifFalse: [falseString])].
					nextChar == $P 
						ifTrue: [newStream nextPutAll: (anArray at: index) printString].
					nextChar == $S ifTrue: [newStream nextPutAll: (anArray at: index)].
					readStream skipTo: $>]
				ifFalse: 
					[newStream nextPut: (char == $% ifTrue: [readStream next] ifFalse: [char])]].
	^newStream contents! !

!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'!
expandMacrosWith: anObject 
	^self expandMacrosWithArguments: (Array with: anObject)! !

!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'!
expandMacrosWith: anObject with: anotherObject 
	^self 
		expandMacrosWithArguments: (Array with: anObject with: anotherObject)! !

!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'!
expandMacrosWith: anObject with: anotherObject with: thirdObject 
	^self expandMacrosWithArguments: (Array 
				with: anObject
				with: anotherObject
				with: thirdObject)! !

!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'!
expandMacrosWith: anObject with: anotherObject with: thirdObject with: fourthObject 
	^self expandMacrosWithArguments: (Array 
				with: anObject
				with: anotherObject
				with: thirdObject
				with: fourthObject)! !

!String methodsFor: 'formatting' stamp: 'yo 11/3/2004 19:24'!
format: aCollection 
	"format the receiver with aCollection  
	 
	simplest example:  
	'foo {1} bar' format: {Date today}.
	 
	complete example:  
	'\{ \} \\ foo {1} bar {2}' format: {12. 'string'}.  
	"
	| result stream |
	result := String new writeStream.
	stream := self readStream.

	[stream atEnd]
		whileFalse: [| currentChar | 
			currentChar := stream next.
			currentChar == ${
				ifTrue: [| expression | 
					expression := self getEnclosedExpressionFrom: stream.
					result
						nextPutAll: (self evaluateExpression: expression parameters: aCollection)]
				ifFalse: [
					currentChar == $\
						ifTrue: [stream atEnd
								ifFalse: [result nextPut: stream next]]
						ifFalse: [result nextPut: currentChar]]].

	^ result contents! !

!String methodsFor: 'formatting' stamp: 'yo 11/3/2004 19:24'!
withCRs
	"Return a copy of the receiver in which backslash (\) characters have been replaced with carriage returns."

	^ self collect: [ :c | c = $\ ifTrue: [ Character cr ] ifFalse: [ c ]].! !


!String methodsFor: 'internet' stamp: 'yo 12/28/2003 01:17'!
decodeMimeHeader
	"See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII  
	Text. Text containing non-ASCII characters is encoded by the sequence  
	=?character-set?encoding?encoded-text?=  
	Encoding is Q (quoted printable) or B (Base64), handled by  
	Base64MimeConverter / RFC2047MimeConverter.

	Thanks to Yokokawa-san, it works in m17n package.  Try the following:

	'=?ISO-2022-JP?B?U1dJS0lQT1AvGyRCPUJDKyVpJXMlQRsoQi8=?= =?ISO-2022-JP?B?GyRCJVElRiUjJSobKEIoUGF0aW8p?=' decodeMimeHeader.
"
	| input output temp charset decoder encodedStream encoding pos |
	input _ ReadStream on: self.
	output _ WriteStream on: String new.
	[output
		nextPutAll: (input upTo: $=).
	"ASCII Text"
	input atEnd]
		whileFalse: [(temp _ input next) = $?
				ifTrue: [charset _ input upTo: $?.
					encoding _ (input upTo: $?) asUppercase.
					temp _ input upTo: $?.
					input next.
					"Skip final ="
					(charset isNil or: [charset size = 0]) ifTrue: [charset _ 'LATIN-1'].
					encodedStream _ MultiByteBinaryOrTextStream on: String new encoding: charset.
					decoder _ encoding = 'B'
								ifTrue: [Base64MimeConverter new]
								ifFalse: [RFC2047MimeConverter new].
					decoder
						mimeStream: (ReadStream on: temp);
						 dataStream: encodedStream;
						 mimeDecode.
					output nextPutAll: encodedStream reset contents.
					pos _ input position.
					input skipSeparators.
					"Delete spaces if followed by ="
					input peek = $=
						ifFalse: [input position: pos]]
				ifFalse: [output nextPut: $=;
						 nextPut: temp]].
	^ output contents! !

!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
decodeQuotedPrintable
	"Assume receiver is in MIME 'quoted-printable' encoding, and decode it."
  
	^QuotedPrintableMimeConverter mimeDecode: self as: self class! !

!String methodsFor: 'internet' stamp: 'ar 4/9/2005 22:16'!
isoToSqueak
	^self "no longer needed"! !

!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
isoToUtf8
	"Convert ISO 8559-1 to UTF-8"
	| s v |
	s _ WriteStream on: (String new: self size).

	self do: [:c |
		v _ c asciiValue.
		(v > 128)
			ifFalse: [s nextPut: c]
			ifTrue: [
				s nextPut: (192+(v >> 6)) asCharacter.
				s nextPut: (128+(v bitAnd: 63)) asCharacter]].
	^s contents. 
! !

!String methodsFor: 'internet' stamp: 'ar 4/10/2005 15:58'!
macToSqueak
	"Convert the receiver from MacRoman to Squeak encoding"
	^ self collect: [:each | each macToSqueak]! !

!String methodsFor: 'internet' stamp: 'ar 4/9/2005 22:16'!
squeakToIso
	^self "no longer needed"! !

!String methodsFor: 'internet' stamp: 'ar 4/10/2005 15:55'!
squeakToMac
	"Convert the receiver from Squeak to MacRoman encoding"
	^ self collect: [:each | each squeakToMac]! !

!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
utf8ToIso
	"Only UTF-8 characters that maps to 8-bit ISO-8559-1 values are converted. Others raises an error"
	| s i c v c2 v2 |
	s _ WriteStream on: (String new: self size).
	
	i _ 1.
	[i <= self size] whileTrue: [
		c _ self at: i. i_i+1.
		v _ c asciiValue.
		(v > 128)
			ifFalse: [ s nextPut: c ]
			ifTrue: [((v bitAnd: 252) == 192)
				ifFalse: [self error: 'illegal UTF-8 ISO character']
				ifTrue: [
					(i > self size) ifTrue: [ self error: 'illegal end-of-string, expected 2nd byte of UTF-8'].
					c2 _ self at: i. i_i+1.
					v2 _ c2 asciiValue.
					((v2 bitAnd: 192) = 128) ifFalse: [self error: 'illegal 2nd UTF-8 char']. 
					s nextPut: ((v2 bitAnd: 63) bitOr: ((v << 6) bitAnd: 192)) asCharacter]]].
	^s contents. 
! !

!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
withInternetLineEndings
	"change line endings from CR's to CRLF's.  This is probably in
prepration for sending a string over the Internet"
	| cr lf |
	cr _ Character cr.
	lf _ Character linefeed.
	^self class streamContents: [ :stream |
		self do: [ :c |
			stream nextPut: c.
			c = cr ifTrue:[ stream nextPut: lf ]. ] ].! !

!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
withSqueakLineEndings
	"assume the string is textual, and that CR, LF, and CRLF are all 
	valid line endings.  Replace each occurence with a single CR"
	| cr lf input c crlf inPos outPos outString lineEndPos newOutPos |
	cr _ Character cr.
	lf _ Character linefeed.
	crlf _ CharacterSet new.
	crlf add: cr; add: lf.

	inPos _ 1.
	outPos _ 1.
	outString _
 String new: self size.

	[ lineEndPos _ self indexOfAnyOf: crlf startingAt: inPos ifAbsent: [0].
		lineEndPos ~= 0 ] whileTrue: [
			newOutPos _ outPos + (lineEndPos - inPos + 1).
			outString replaceFrom: outPos to: newOutPos - 2 with: self startingAt: inPos.
			outString at: newOutPos-1 put: cr.
			outPos _ newOutPos.

			((self at: lineEndPos) = cr and: [ lineEndPos < self size and: [ (self at: lineEndPos+1) = lf ] ]) ifTrue: [
				"CRLF ending"
				inPos _ lineEndPos + 2 ]
			ifFalse: [ 
				"CR or LF ending"
				inPos _ lineEndPos + 1 ]. ].

	"no more line endings.  copy the rest"
	newOutPos _ outPos + (self size - inPos + 1).
	outString replaceFrom: outPos to: newOutPos-1 with: self startingAt: inPos.

	^outString copyFrom: 1 to: newOutPos-1
	! !

!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'!
withoutQuoting
	"remove the initial and final quote marks, if present"
	"'''h''' withoutQuoting"
	| quote |
	self size < 2 ifTrue: [ ^self ].
	quote _ self first.
	(quote = $' or: [ quote = $" ])
		ifTrue: [ ^self copyFrom: 2 to: self size - 1 ]
		ifFalse: [ ^self ].! !


!String methodsFor: 'paragraph support' stamp: 'yo 8/26/2002 22:19'!
indentationIfBlank: aBlock
	"Answer the number of leading tabs in the receiver.  If there are
	 no visible characters, pass the number of tabs to aBlock and return its value."

	| reader leadingTabs lastSeparator cr tab ch |
	cr _ Character cr.
	tab _ Character tab.
	reader _ ReadStream on: self.
	leadingTabs _ 0.
	[reader atEnd not and: [(ch _ reader next) = tab]]
		whileTrue: [leadingTabs _ leadingTabs + 1].
	lastSeparator _ leadingTabs + 1.
	[reader atEnd not and: [ch isSeparator and: [ch ~= cr]]]
		whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next].
	lastSeparator = self size | (ch = cr)
		ifTrue: [^aBlock value: leadingTabs].
	^ leadingTabs.
! !


!String methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	"Number String Boolean player collection sound color etc"
	^ #String! !

!String methodsFor: 'printing' stamp: 'yo 8/26/2002 22:57'!
encodeDoublingQuoteOn: aStream 
	"Print inside string quotes, doubling inbedded quotes."
	| x |
	aStream print: $'.
	1 to: self size do:
		[:i |
		aStream print: (x _ self at: i).
		x = $' ifTrue: [aStream print: x]].
	aStream print: $'! !

!String methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'!
isLiteral

	^true! !

!String methodsFor: 'printing' stamp: 'sd 7/8/2006 18:06'!
printOn: aStream 
	"Print inside string quotes, doubling inbedded quotes."
 
	self storeOn: aStream! !

!String methodsFor: 'printing' stamp: 'yo 8/26/2002 22:58'!
storeOn: aStream 
	"Print inside string quotes, doubling inbedded quotes."
	| x |
	aStream nextPut: $'.
	1 to: self size do:
		[:i |
		aStream nextPut: (x _ self at: i).
		x = $' ifTrue: [aStream nextPut: x]].
	aStream nextPut: $'! !

!String methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'!
stringRepresentation
	"Answer a string that represents the receiver.  For most objects this is simply its printString, but for strings themselves, it's themselves, to avoid the superfluous extra pair of quotes.  6/12/96 sw"

	^ self ! !


!String methodsFor: 'system primitives' stamp: 'sw 10/20/2004 17:51'!
endsWithAColon 
	"Answer whether the final character of the receiver is a colon"

	^ self size > 0 and: [self last == $:]

"
#fred: endsWithAColon
'fred' endsWithAColon
"! !

!String methodsFor: 'system primitives' stamp: 'ar 4/10/2005 16:55'!
findSubstring: key in: body startingAt: start matchTable: matchTable
	"Answer the index in the string body at which the substring key first occurs, at or beyond start.  The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches.  If no match is found, zero will be returned."
	| index c1 c2 |
	matchTable == nil ifTrue: [
		key size = 0 ifTrue: [^ 0].
		start to: body size - key size + 1 do:
			[:startIndex |
			index _ 1.
				[(body at: startIndex+index-1)
					= (key at: index)]
					whileTrue:
					[index = key size ifTrue: [^ startIndex].
					index _ index+1]].
		^ 0
	].

	key size = 0 ifTrue: [^ 0].
	start to: body size - key size + 1 do:
		[:startIndex |
		index _ 1.
		[c1 _ body at: startIndex+index-1.
		c2 _ key at: index.
		((c1 leadingChar = 0) ifTrue: [(matchTable at: c1 asciiValue + 1)]
						ifFalse: [c1 asciiValue + 1])
			= ((c2 leadingChar = 0) ifTrue: [(matchTable at: c2 asciiValue + 1)]
								ifFalse: [c2 asciiValue + 1])]
			whileTrue:
				[index = key size ifTrue: [^ startIndex].
				index _ index+1]].
	^ 0
! !

!String methodsFor: 'system primitives' stamp: 'yo 11/3/2004 19:24'!
numArgs 
	"Answer either the number of arguments that the receiver would take if considered a selector.  Answer -1 if it couldn't be a selector.  Note that currently this will answer -1 for anything begining with an uppercase letter even though the system will accept such symbols as selectors.  It is intended mostly for the assistance of spelling correction."

	| firstChar numColons excess start ix |
	self size = 0 ifTrue: [^ -1].
	firstChar _ self at: 1.
	(firstChar isLetter or: [firstChar = $:]) ifTrue:
		["Fast reject if any chars are non-alphanumeric"
		(self findSubstring: '~' in: self startingAt: 1 matchTable: Tokenish) > 0 ifTrue: [^ -1].
		"Fast colon count"
		numColons _ 0.  start _ 1.
		[(ix _ self findSubstring: ':' in: self startingAt: start matchTable: CaseSensitiveOrder) > 0]
			whileTrue:
				[numColons _ numColons + 1.
				start _ ix + 1].
		numColons = 0 ifTrue: [^ 0].
		firstChar = $:
			ifTrue: [excess _ 2 "Has an initial keyword, as #:if:then:else:"]
			ifFalse: [excess _ 0].
		self last = $:
			ifTrue: [^ numColons - excess]
			ifFalse: [^ numColons - excess - 1 "Has a final keywords as #nextPut::andCR"]].
	firstChar isSpecial ifTrue:
		[self size = 1 ifTrue: [^ 1].
		2 to: self size do: [:i | (self at: i) isSpecial ifFalse: [^ -1]].
		^ 1].
	^ -1.! !


!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'!
hasContentsInExplorer

	^false! !

!String methodsFor: 'testing' stamp: 'ar 4/10/2005 16:49'!
includesUnifiedCharacter
	^false! !

!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'!
isAllDigits
	"whether the receiver is composed entirely of digits"
	self do: [:c | c isDigit ifFalse: [^ false]].
	^ true! !

!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'!
isAllSeparators
	"whether the receiver is composed entirely of separators"
	self do: [ :c | c isSeparator ifFalse: [ ^false ] ].
	^true! !

!String methodsFor: 'testing' stamp: 'yo 8/4/2003 12:26'!
isAsciiString

	| c |
	c _ self detect: [:each | each asciiValue > 127] ifNone: [nil].
	^ c isNil.
! !

!String methodsFor: 'testing' stamp: 'ar 4/10/2005 16:23'!
isByteString
	"Answer whether the receiver is a ByteString"
	^false! !

!String methodsFor: 'testing' stamp: 'ar 4/10/2005 23:25'!
isOctetString
	"Answer whether the receiver can be represented as a byte string. 
	This is different from asking whether the receiver *is* a ByteString 
	(i.e., #isByteString)"
	1 to: self size do: [:pos |
		(self at: pos) asInteger >= 256 ifTrue: [^ false].
	].
	^ true.
! !

!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'!
isString
	^ true! !

!String methodsFor: 'testing' stamp: 'ar 4/12/2005 19:52'!
isWideString
	"Answer whether the receiver is a WideString"
	^false! !

!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'!
lastSpacePosition
	"Answer the character position of the final space or other separator character in the receiver, and 0 if none"
	self size to: 1 by: -1 do:
		[:i | ((self at: i) isSeparator) ifTrue: [^ i]].
	^ 0

"
'fred the bear' lastSpacePosition
'ziggie' lastSpacePosition
'elvis ' lastSpacePosition
'wimpy  ' lastSpacePosition
'' lastSpacePosition
"! !


!String methodsFor: 'translating' stamp: 'dgd 8/24/2004 19:42'!
translated
	"answer the receiver translated to the default language"
	^ NaturalLanguageTranslator current  translate: self! !

!String methodsFor: 'translating' stamp: 'dgd 8/27/2004 18:43'!
translatedIfCorresponds
	"answer the receiver translated to the default language only if 
	the receiver begins and ends with an underscore (_)"
	^ ('_*_' match: self)
		ifTrue: [(self copyFrom: 2 to: self size - 1) translated]
		ifFalse: [self]! !

!String methodsFor: 'translating' stamp: 'dgd 8/24/2004 19:38'!
translatedTo: localeID 
	"answer the receiver translated to the given locale id"
	^ localeID translator translate: self! !


!String methodsFor: 'user interface' stamp: 'md 7/28/2005 20:42'!
asExplorerString

	^ self printString! !

!String methodsFor: 'user interface' stamp: 'ar 9/27/2005 20:02'!
openInWorkspaceWithTitle: aTitle
	"Open up a workspace with the receiver as its contents, with the given title"
	UIManager default edit: self label: aTitle! !


!String methodsFor: '*eToys-*Morphic' stamp: 'ar 4/10/2005 17:06'!
newTileMorphRepresentative
	^ TileMorph new setLiteral: self;addSuffixIfCan! !


!String methodsFor: '*Morphic' stamp: 'ar 4/10/2005 17:07'!
asMorph 
	"Answer the receiver as a StringMorph"

	^ StringMorph contents: self

"'bugs black blood' asMorph openInHand"! !

!String methodsFor: '*Morphic' stamp: 'ar 4/10/2005 17:07'!
asStringMorph 
	"Answer the receiver as a StringMorph"

	^ StringMorph contents: self

"'bugs black blood' asStringMorph openInHand"! !


!String methodsFor: '*MorphicExtras-*morphic-Postscript Canvases' stamp: 'yo 11/3/2004 19:24'!
asPostscript

	| temp |
	temp _ self asString copyReplaceAll: '(' with: '\('.
	temp _ temp copyReplaceAll: ')' with: '\)'.
	temp _ temp copyReplaceAll: '
' 
			with: ''.
	^ PostscriptEncoder mapMacStringToPS: temp! !


!String methodsFor: '*Morphic-converting' stamp: 'yo 11/3/2004 19:24'!
openAsMorph
	"Open the receiver as a morph"

	^ self asMorph openInHand ! !


!String methodsFor: '*monticello' stamp: 'avi 2/4/2004 14:14'!
extractNumber
	^ ('0', self select: [:ea | ea isDigit]) asNumber! !


!String methodsFor: '*network-uri' stamp: 'mir 2/26/2002 14:59'!
asURI
	"convert to a Url"
	"'http://www.cc.gatech.edu/' asURI"
	"'msw://chaos.resnet.gatech.edu:9000/' asURI"
	^URI fromString: self! !


!String methodsFor: '*packageinfo-base' stamp: 'nk 8/30/2004 09:02'!
escapeEntities
	^ self species streamContents: [:s | self do: [:c | s nextPutAll: c escapeEntities]]
! !


!String methodsFor: '*services-base' stamp: 'rr 3/21/2006 12:00'!
service
	^ self serviceOrNil ifNil: [ServiceCategory new id: self asSymbol]! !

!String methodsFor: '*services-base' stamp: 'rr 3/21/2006 12:00'!
serviceOrNil
	^ ServiceRegistry current serviceWithId: self asSymbol! !


!String methodsFor: '*versionnumber' stamp: 'yo 11/3/2004 19:24'!
asVersion
	"Answer a VersionNumber"

	^VersionNumber fromString: self! !


!String methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'!
correctAgainstEnumerator: wordBlock continuedFrom: oldCollection
	"The guts of correction, instead of a wordList, there is a block that should take another block and enumerate over some list with it."

	| choices scoreMin results score maxChoices |
	scoreMin _ self size // 2 min: 3.
	maxChoices _ 10.
	oldCollection isNil
		ifTrue: [ choices _ SortedCollection sortBlock: [ :x :y | x value > y value ] ]
		ifFalse: [ choices _ oldCollection ].
	wordBlock isNil
		ifTrue:
			[ results _ OrderedCollection new.
			1 to: (maxChoices min: choices size) do: [ :i | results add: (choices at: i) key ] ]
		ifFalse:
			[ wordBlock value: [ :word |
				(score _ self alike: word) >= scoreMin ifTrue:
					[ choices add: (Association key: word value: score).
						(choices size >= maxChoices) ifTrue: [ scoreMin _ (choices at: maxChoices) value] ] ].
			results _ choices ].
	^ results! !

!String methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'!
evaluateExpression: aString parameters: aCollection 
	"private - evaluate the expression aString with  
	aCollection as the parameters and answer the  
	evaluation result as an string"
	| index |
	index := ('0' , aString) asNumber.

	index isZero
		ifTrue: [^ '[invalid subscript: {1}]' format: {aString}].

	index > aCollection size
		ifTrue: [^ '[subscript is out of bounds: {1}]' format: {aString}].

	^ (aCollection at: index) asString! !

!String methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'!
getEnclosedExpressionFrom: aStream 
	"private - get the expression enclosed between '{' and 
	'}' and remove all the characters from the stream"
	| result currentChar |
	result := String new writeStream.

	[aStream atEnd 
		or: [(currentChar := aStream next) == $}]]
		whileFalse: [result nextPut: currentChar].

	^ result contents withBlanksTrimmed! !

!String methodsFor: 'private' stamp: 'yo 8/26/2002 22:53'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

!String methodsFor: 'private' stamp: 'yo 8/28/2002 15:22'!
stringhash

	^ self hash.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

String class
	instanceVariableNames: ''!

!String class methodsFor: 'examples' stamp: 'yo 11/3/2004 19:24'!
example
	"To see the string displayed at the cursor point, execute this expression
	and select a point by pressing a mouse button."

	'this is some text' displayOn: Display at: Sensor waitButton! !


!String class methodsFor: 'formatting' stamp: 'md 6/5/2005 07:49'!
expandMacro: macroType argument: argument withExpansions: expansions 
	macroType = $s ifTrue: [^expansions at: argument].
	macroType = $p ifTrue: [^(expansions at: argument) printString].
	macroType = $n ifTrue: [^String cr].
	macroType = $t ifTrue: [^String tab].
	self error: 'unknown expansion type'! !


!String class methodsFor: 'initialization' stamp: 'ar 4/9/2005 22:37'!
initialize   "self initialize"

	| order |
	AsciiOrder _ (0 to: 255) as: ByteArray.

	CaseInsensitiveOrder _ AsciiOrder copy.
	($a to: $z) do:
		[:c | CaseInsensitiveOrder at: c asciiValue + 1
				put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)].

	"Case-sensitive compare sorts space, digits, letters, all the rest..."
	CaseSensitiveOrder _ ByteArray new: 256 withAll: 255.
	order _ -1.
	' 0123456789' do:  "0..10"
		[:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)].
	($a to: $z) do:     "11-64"
		[:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order+1).
		CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)].
	1 to: CaseSensitiveOrder size do:
		[:i | (CaseSensitiveOrder at: i) = 255 ifTrue:
			[CaseSensitiveOrder at: i put: (order _ order+1)]].
	order = 255 ifFalse: [self error: 'order problem'].

	"a table for translating to lower case"
	LowercasingTable _ String withAll: (Character allByteCharacters collect: [:c | c asLowercase]).

	"a table for translating to upper case"
	UppercasingTable _ String withAll: (Character allByteCharacters collect: [:c | c asUppercase]).

	"a table for testing tokenish (for fast numArgs)"
	Tokenish _ String withAll: (Character allByteCharacters collect:
									[:c | c tokenish ifTrue: [c] ifFalse: [$~]]).

	"CR and LF--characters that terminate a line"
	CSLineEnders _ CharacterSet empty.
	CSLineEnders add: Character cr.
	CSLineEnders add: Character lf.

 	"separators and non-separators"
	CSSeparators _ CharacterSet separators.
	CSNonSeparators _ CSSeparators complement.! !

!String class methodsFor: 'initialization' stamp: 'yo 8/11/2003 21:11'!
initializeHtmlEntities
	"self initializeHtmlEntities"

	HtmlEntities _ (Dictionary new: 128)
		at: 'amp'	put: $&;
		at: 'lt'		put: $<;
		at: 'gt'		put: $>;
		at: 'quot'	put: $";
		at: 'euro'	put: Character euro;
		yourself.
	#('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo: [:each :index | HtmlEntities at: each put: (index + 159) asCharacter]! !


!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
cr
	"Answer a string containing a single carriage return character."

	^ self with: Character cr
! !

!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
crlf
	"Answer a string containing a carriage return and a linefeed."

	^ self with: Character cr with: Character lf
! !

!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
crlfcrlf
	^self crlf , self crlf.
! !

!String class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 16:24'!
fromByteArray: aByteArray

	^ aByteArray asString
! !

!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
fromPacked: aLong
	"Convert from a longinteger to a String of length 4."

	| s |
	s _ self new: 4.
	s at: 1 put: (aLong digitAt: 4) asCharacter.
	s at: 2 put: (aLong digitAt: 3) asCharacter.
	s at: 3 put: (aLong digitAt: 2) asCharacter.
	s at: 4 put: (aLong digitAt: 1) asCharacter.
	^s

"String fromPacked: 'TEXT' asPacked"
! !

!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
fromString: aString 
	"Answer an instance of me that is a copy of the argument, aString."
	
	^ aString copyFrom: 1 to: aString size! !

!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
lf
	"Answer a string containing a single carriage return character."

	^ self with: Character lf! !

!String class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 23:26'!
new: sizeRequested 
	"Answer an instance of this class with the number of indexable
	variables specified by the argument, sizeRequested."
	self == String 
		ifTrue:[^ByteString new: sizeRequested]
		ifFalse:[^self basicNew: sizeRequested].! !

!String class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:27'!
readFrom: inStream
	"Answer an instance of me that is determined by reading the stream, 
	inStream. Embedded double quotes become the quote Character."

	| outStream char done |
	outStream _ WriteStream on: (self new: 16).
	"go to first quote"
	inStream skipTo: $'.
	done _ false.
	[done or: [inStream atEnd]]
		whileFalse: 
			[char _ inStream next.
			char = $'
				ifTrue: 
					[char _ inStream next.
					char = $'
						ifTrue: [outStream nextPut: char]
						ifFalse: [done _ true]]
				ifFalse: [outStream nextPut: char]].
	^outStream contents! !

!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'!
tab
	"Answer a string containing a single tab character."

	^ self with: Character tab
! !

!String class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:29'!
value: anInteger

	^ self with: (Character value: anInteger).
! !

!String class methodsFor: 'instance creation' stamp: 'ar 4/12/2005 17:34'!
with: aCharacter
	| newCollection |
	aCharacter asInteger < 256
		ifTrue:[newCollection _ ByteString new: 1]
		ifFalse:[newCollection _ WideString new: 1].
	newCollection at: 1 put: aCharacter.
	^newCollection! !


!String class methodsFor: 'primitives' stamp: 'yo 12/15/2005 13:41'!
compare: string1 with: string2 collated: order
	"Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array."

	| len1 len2 c1 c2 |
	order == nil ifTrue: [
		len1 _ string1 size.
		len2 _ string2 size.
		1 to: (len1 min: len2) do:[:i |
			c1 _ (string1 at: i) asInteger.
			c2 _ (string2 at: i) asInteger.
			c1 = c2 ifFalse: [c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]].
		].
		len1 = len2 ifTrue: [^ 2].
		len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3].
	].
	len1 _ string1 size.
	len2 _ string2 size.
	1 to: (len1 min: len2) do:[:i |
		c1 _ (string1 at: i) asInteger.
		c2 _ (string2 at: i) asInteger.
		c1 < 256 ifTrue: [c1 _ order at: c1 + 1].
		c2 < 256 ifTrue: [c2 _ order at: c2 + 1].
		c1 = c2 ifFalse:[c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]].
	].
	len1 = len2 ifTrue: [^ 2].
	len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3].
! !

!String class methodsFor: 'primitives' stamp: 'ar 4/10/2005 16:36'!
findFirstInString: aString inSet: inclusionMap startingAt: start
	"Trivial, non-primitive version"
	| i stringSize ascii more |
	inclusionMap size ~= 256 ifTrue: [^ 0].
	stringSize _ aString size.
	more _ true.
	i _ start - 1.
	[more and: [i + 1 <= stringSize]] whileTrue: [
		i _ i + 1.
		ascii _ (aString at: i) asciiValue.
		more _ ascii < 256 ifTrue: [(inclusionMap at: ascii + 1) = 0] ifFalse: [true].
	].

	i + 1 > stringSize ifTrue: [^ 0].
	^ i! !

!String class methodsFor: 'primitives' stamp: 'ar 4/10/2005 16:36'!
indexOfAscii: anInteger inString: aString startingAt: start
	"Trivial, non-primitive version"
	| stringSize |
	stringSize _ aString size.
	start to: stringSize do: [:pos |
		(aString at: pos) asInteger = anInteger ifTrue: [^ pos]].
	^ 0
! !

!String class methodsFor: 'primitives' stamp: 'ar 4/10/2005 16:29'!
stringHash: aString initialHash: speciesHash
	| stringSize hash low |
	stringSize _ aString size.
	hash _ speciesHash bitAnd: 16rFFFFFFF.
	1 to: stringSize do: [:pos |
		hash _ hash + (aString at: pos) asInteger.
		"Begin hashMultiply"
		low _ hash bitAnd: 16383.
		hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF.
	].
	^ hash.
! !

!String class methodsFor: 'primitives' stamp: 'ar 4/10/2005 16:36'!
translate: aString from: start  to: stop  table: table
	"Trivial, non-primitive version"
	| char |
	start to: stop do: [:i |
		char _ (aString at: i) asInteger.
		char < 256 ifTrue: [aString at: i put: (table at: char+1)].
	].
! !
StringMorph subclass: #StringButtonMorph
	instanceVariableNames: 'target actionSelector arguments actWhen oldColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!StringButtonMorph methodsFor: 'accessing'!
actionSelector

	^ actionSelector
! !

!StringButtonMorph methodsFor: 'accessing'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!StringButtonMorph methodsFor: 'accessing'!
arguments

	^ arguments
! !

!StringButtonMorph methodsFor: 'accessing'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!StringButtonMorph methodsFor: 'accessing'!
target

	^ target
! !

!StringButtonMorph methodsFor: 'accessing'!
target: anObject

	target _ anObject
! !


!StringButtonMorph methodsFor: 'button' stamp: 'dgd 2/22/2003 18:45'!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target notNil and: [actionSelector notNil]) 
		ifTrue: 
			[Cursor normal 
				showWhile: [target perform: actionSelector withArguments: arguments]]! !


!StringButtonMorph methodsFor: 'copying' stamp: 'jm 7/28/97 11:55'!
updateReferencesUsing: aDictionary
	"If the arguments array points at a morph we are copying, then point at the new copy.  And also copies the array, which is important!!"

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !

!StringButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:47'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!StringButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:46'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		a Symbol"
"arguments _ arguments.		All weakly copied"
actWhen _ actWhen veryDeepCopyWith: deepCopier.
oldColor _ oldColor veryDeepCopyWith: deepCopier.! !


!StringButtonMorph methodsFor: 'event handling'!
handlesMouseDown: evt

	^ true
! !

!StringButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:14'!
handlesMouseStillDown: evt
	^actWhen == #whilePressed! !

!StringButtonMorph methodsFor: 'event handling'!
mouseDown: evt

	oldColor _ color.
	actWhen == #buttonDown
		ifTrue: [self doButtonAction].
! !

!StringButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:15'!
mouseMove: evt
	actWhen == #buttonDown ifTrue: [^ self].
	(self containsPoint: evt cursorPoint)
		ifTrue:[self color: (oldColor alphaMixed: 1/2 with: Color white)]
		ifFalse: [self color: oldColor].
! !

!StringButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:15'!
mouseStillDown: evt
	actWhen == #whilePressed ifFalse: [^ self].
	(self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! !

!StringButtonMorph methodsFor: 'event handling'!
mouseUp: evt

	self color: oldColor.
	(actWhen == #buttonUp and: [self containsPoint: evt cursorPoint])
		ifTrue: [self doButtonAction].
! !


!StringButtonMorph methodsFor: 'e-toy support' stamp: 'ar 3/17/2001 20:17'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	target _ target adaptedToWorld: aWorld.! !


!StringButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:44'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	target _ nil.
	actionSelector _ #flash.
	arguments _ EmptyArray.
	actWhen _ #buttonUp.
	self contents: 'Flash' ! !


!StringButtonMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 19:57'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change label' translated action: #setLabel.
	aCustomMenu add: 'change action selector' translated action: #setActionSelector.
	aCustomMenu add: 'change arguments' translated action: #setArguments.
	aCustomMenu add: 'change when to act' translated action: #setActWhen.
	self addTargetingMenuItems: aCustomMenu hand: aHandMorph .! !

!StringButtonMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 19:56'!
addTargetingMenuItems: aCustomMenu hand: aHandMorph 
	"Add targeting menu items"
	aCustomMenu addLine.

	aCustomMenu add: 'set target' translated action: #targetWith:.
	aCustomMenu add: 'sight target' translated action: #sightTargets:.
	target
		ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]! !

!StringButtonMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 19:55'!
clearTarget

	target _ nil.
! !

!StringButtonMorph methodsFor: 'menu' stamp: 'yo 3/16/2005 21:02'!
setActWhen

	| selections |
	selections _ #(buttonDown buttonUp whilePressed).
	actWhen _ (SelectionMenu labelList: (selections collect: [:t | t translated]) selections: selections)
		startUpWithCaption: 'Choose one of the following conditions' translated.
! !

!StringButtonMorph methodsFor: 'menu' stamp: 'yo 3/16/2005 20:54'!
setActionSelector

	| newSel |
	newSel _ FillInTheBlank
		request:
'Please type the selector to be sent to
the target when this button is pressed' translated
		initialAnswer: actionSelector.
	newSel isEmpty ifFalse: [self actionSelector: newSel].
! !

!StringButtonMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:09'!
setArguments

	| s newArgs newArgsArray |
	s _ WriteStream on: ''.
	arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
	newArgs _ FillInTheBlank
		request:
'Please type the arguments to be sent to the target
when this button is pressed separated by periods' translated
		initialAnswer: s contents.
	newArgs isEmpty ifFalse: [
		newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.
		self arguments: newArgsArray].
! !

!StringButtonMorph methodsFor: 'menu'!
setLabel

	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Please type a new label for this button'
		initialAnswer: self contents.
	newLabel isEmpty ifFalse: [self contents: newLabel].
! !

!StringButtonMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:55'!
setTarget: evt 
	| rootMorphs |
	rootMorphs _ self world rootMorphsAt: evt hand targetOffset.
	target _ rootMorphs size > 1
		ifTrue: [rootMorphs second]
		ifFalse: [nil]! !


!StringButtonMorph methodsFor: 'submorphs-add/remove'!
actWhen: aSymbol
	"Set the condition under which to invoke my action to one of: #buttonDown, #buttonUp, and #whilePressed."

	actWhen _ aSymbol.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringButtonMorph class
	instanceVariableNames: ''!

!StringButtonMorph class methodsFor: 'printing' stamp: 'sw 2/16/98 03:02'!
defaultNameStemForInstances
	^ 'SButton'! !
Model subclass: #StringHolder
	instanceVariableNames: 'contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Kernel-Remnants'!
!StringHolder commentStamp: '<historical>' prior: 0!
I am a kind of Model that includes a piece of text.  In some cases, the text can be edited, and in some the text is a method.

Categories 'code pane menu' and 'message list menu' are messages that may be called by my menus when the text is a method, and when some pane is a list of methods.  Other of my subclasses may ignore these two catagories altogether.!


!StringHolder methodsFor: 'accessing' stamp: 'di 5/19/1998 15:34'!
acceptContents: aString 
	"Set aString to be the contents of the receiver.  Return true cuz happy"

	self contents: aString.
	^ true! !

!StringHolder methodsFor: 'accessing' stamp: 'nk 4/29/2004 12:32'!
classCommentIndicated
	"Answer true iff we're viewing the class comment."
	^false! !

!StringHolder methodsFor: 'accessing'!
contents
	"Answer the contents that the receiver is holding--presumably a string."

	^contents! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 1/12/1999 11:47'!
contents: textOrString 
	"Set textOrString to be the contents of the receiver."

	contents _ textOrString "asString"! !

!StringHolder methodsFor: 'accessing' stamp: 'tk 4/3/98 22:50'!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	^ 1 to: 0  "null selection"! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 12/9/2000 23:59'!
noteAcceptanceOfCodeFor: aSelector
	"A method has possibly been submitted for the receiver with aSelector as its selector; If the receiver wishes to take soem action here is a chance for it to do so"
! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 12/1/2000 11:04'!
reformulateList
	"If the receiver has a way of reformulating its message list, here is a chance for it to do so"! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 12/6/2000 17:48'!
reformulateListNoting: newSelector
	"A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so"

	^ self reformulateList! !

!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 14:59'!
selectedClassName
	"I may know what class is currently selected"

	self selectedClass ifNotNil: [^ self selectedClass name].
	^ nil! !

!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:01'!
selectedClassOrMetaClass

	^ self selectedClass	"I don't know any better"! !

!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:22'!
selectedMessageName

	^ nil! !

!StringHolder methodsFor: 'accessing' stamp: 'di 11/23/1998 15:21'!
textContents: aStringOrText 
	"Set aStringOrText to be the contents of the receiver."

	contents _ aStringOrText! !


!StringHolder methodsFor: 'code pane menu' stamp: 'dgd 10/1/2004 13:43'!
codePaneMenu: aMenu shifted: shifted 
	"Note that unless we override perform:orSendTo:, 
	PluggableTextController will respond to all menu items in a 
	text pane"
	| donorMenu |
	donorMenu := shifted
				ifTrue: [ParagraphEditor shiftedYellowButtonMenu]
				ifFalse: [ParagraphEditor yellowButtonMenu].
	^ aMenu addAllFrom: donorMenu! !

!StringHolder methodsFor: 'code pane menu' stamp: 'wod 5/29/1998 16:35'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !

!StringHolder methodsFor: 'code pane menu' stamp: 'tk 4/6/98 11:43'!
showBytecodes
	"We don't know how to do this"

	^ self changed: #flash! !

!StringHolder methodsFor: 'code pane menu' stamp: 'ar 9/27/2005 20:47'!
spawn: contentsString

	UIManager default edit: contentsString label: 'Workspace'
! !


!StringHolder methodsFor: 'evaluation'!
doItContext
	"Answer the context in which a text selection can be evaluated."

	^nil! !

!StringHolder methodsFor: 'evaluation'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a 
	text selection."

	^nil! !


!StringHolder methodsFor: 'initialize-release'!
defaultContents

	^''! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sw 10/16/1998 11:36'!
embeddedInMorphicWindowLabeled: labelString
	| window |
	window _ (SystemWindow labelled: labelString) model: self.
	window addMorph: (PluggableTextMorph on: self text: #contents accept: #acceptContents:
			readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0@0 corner: 1@1).
	^ window! !

!StringHolder methodsFor: 'initialize-release' stamp: 'jm 3/24/98 17:56'!
initialize
	"Initialize the state of the receiver with its default contents."

	contents _ self defaultContents.
! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sw 10/16/1998 11:37'!
openAsMorphLabel: labelString 
	"Workspace new openAsMorphLabel: 'Workspace'"
	(self embeddedInMorphicWindowLabeled: labelString) openInWorld! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sw 12/22/1998 00:16'!
openLabel: aString 
	"Create a standard system view of the model, me, a StringHolder and open it.  If in mvc, terminate the active controller so that the new window will immediately be activated."
	self openLabel: aString andTerminate: true! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sma 4/30/2000 10:15'!
openLabel: aString andTerminate: terminateBoolean
	"Create a standard system view of the model, me, a StringHolder and open it.; do not terminate the active process if in mvc"
	| topView codeView |

	Smalltalk isMorphic ifTrue: [^ self openAsMorphLabel: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
	topView label: aString.
	topView minimumSize: 100 @ 50.

	codeView _ PluggableTextView on: self 
			text: #contents accept: #acceptContents:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	codeView window: (0@0 extent: 200@200).
	topView addSubView: codeView.
	"self contents size > 0 ifTrue: [
			codeView hasUnacceptedEdits: true].  Is it already saved or not??"
	terminateBoolean
		ifTrue:
			[topView controller open]
		ifFalse:
			[topView controller openNoTerminate]! !


!StringHolder methodsFor: 'optional panes' stamp: 'sw 1/24/2001 21:25'!
wantsAnnotationPane
	"Answer whether the receiver, seen in some browser window, would like to have the so-called  annotationpane included.  By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary."

	^ Preferences annotationPanes! !

!StringHolder methodsFor: 'optional panes' stamp: 'sw 1/24/2001 18:57'!
wantsOptionalButtons
	"Answer whether the receiver, seen in some browser window, would like to have the so-called optional button pane included.  By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary."

	^ Preferences optionalButtons! !


!StringHolder methodsFor: 'tiles' stamp: 'di 11/4/2000 11:07'!
openSyntaxView
	"Open a syntax view on the current method"

	| class selector |

	(selector _ self selectedMessageName) ifNotNil: [
		class _ self selectedClassOrMetaClass.
		SyntaxMorph testClass: class andMethod: selector.
	]! !


!StringHolder methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 20:36'!
buildWith: builder
	| windowSpec textSpec |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'Workspace'.
	windowSpec children: OrderedCollection new.
	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		getText: #contents; 
		setText: #acceptContents:; 
		selection: nil; 
		menu: #codePaneMenu:shifted:;
		frame: (0@0corner: 1@1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !


!StringHolder methodsFor: 'user edits' stamp: 'di 4/21/1998 11:30'!
clearUserEditFlag
	"Clear the hasUnacceptedEdits flag in all my dependent views."

	self changed: #clearUserEdits! !

!StringHolder methodsFor: 'user edits' stamp: 'tk 4/13/1998 23:07'!
okToChange

	self canDiscardEdits ifTrue: [^ true].
	self changed: #wantToChange.  "Solicit cancel from view"
	^ self canDiscardEdits
! !


!StringHolder methodsFor: '*services-base' stamp: 'rr 3/15/2004 09:17'!
codeTextMorph
	^ self dependents
		detect: [:dep | (dep isKindOf: PluggableTextMorph)
				and: [dep getTextSelector == #contents]]
		ifNone: []! !

!StringHolder methodsFor: '*services-base' stamp: 'rr 6/9/2005 10:47'!
requestor
	^ (TextRequestor new) model: self; yourself! !

!StringHolder methodsFor: '*services-base' stamp: 'rr 3/15/2004 09:17'!
selectedInterval
	^self codeTextMorph selectionInterval! !


!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
browseAllMessages
	"Create and schedule a message set browser on all implementors of all the messages sent by the current method."

	| aClass aName method filteredList |
	(aName := self selectedMessageName) ifNotNil: [
		method := (aClass := self selectedClassOrMetaClass) compiledMethodAt: aName.
		filteredList := method messages reject: 
			[:each | #(new initialize = ) includes: each].
		self systemNavigation browseAllImplementorsOfList: filteredList asSortedCollection
			 title: 'All messages sent in ', aClass name, '.', aName]
! !

!StringHolder methodsFor: '*Tools' stamp: 'tk 4/18/1998 16:11'!
browseClass
	"Open an class browser on this class and method"

	self selectedClassOrMetaClass ifNotNil: [
		Browser newOnClass: self selectedClassOrMetaClass 
			selector: self selectedMessageName]! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 4/16/2003 08:42'!
browseLocalImplementors
	"Present a menu of all messages sent by the currently selected message. 
	Open a message set browser of all implementors of the message chosen in or below
	the selected class.
	Do nothing if no message is chosen."
	self getSelectorAndSendQuery: #browseAllImplementorsOf:localTo:
		to: self systemNavigation
		with: { self selectedClass }! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 4/16/2003 20:41'!
browseLocalSendersOfMessages
	"Present a menu of the currently selected message, as well as all
	messages sent by it.  Open a message set browser of all implementors
	of the message chosen in or below the selected class"

	self getSelectorAndSendQuery: #browseAllCallsOn:localTo:
		to: self systemNavigation
		with: { self selectedClass }! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 4/16/2003 08:45'!
browseMessages
	"Present a menu of all messages sent by the currently selected message. 
	Open a message set browser of all implementors of the message chosen."

	self getSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
browseMethodFull
	"Create and schedule a full Browser and then select the current class and message."

	| myClass |
	(myClass := self selectedClassOrMetaClass) ifNotNil:
		[Browser fullOnClass: myClass selector: self selectedMessageName]! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 4/16/2003 20:40'!
browseSendersOfMessages
	"Present a menu of the currently selected message, as well as all messages sent by it.  Open a message set browser of all senders of the selector chosen."

	self getSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
browseUnusedMethods
	| classes unsent messageList cls |
	(cls := self selectedClass)
		ifNil: [^ self].
	classes := Array with: cls with: cls class.
	unsent := Set new.
	classes
		do: [:c | unsent addAll: c selectors].
	unsent := self systemNavigation allUnSentMessagesIn: unsent.
	messageList := OrderedCollection new.
	classes
		do: [:c | (c selectors
				select: [:s | unsent includes: s]) asSortedCollection
				do: [:sel | messageList add: c name , ' ' , sel]].
	self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , cls name! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
browseVersions
	"Create and schedule a Versions Browser, showing all versions of the 
	currently selected message. Answer the browser or nil."
	| selector class | 
	self classCommentIndicated
		ifTrue: [ ClassCommentVersionsBrowser browseCommentOf: self selectedClass.
			^nil ].

	(selector := self selectedMessageName)
		ifNil:[ self inform: 'Sorry, only actual methods have retrievable versions.'. ^nil ]
		ifNotNil: [
			class := self selectedClassOrMetaClass.
			^VersionsBrowser
				browseVersionsOf: (class compiledMethodAt: selector)
				class: self selectedClass
				meta: class isMeta
				category: (class organization categoryOfElement: selector)
				selector: selector]! !

!StringHolder methodsFor: '*Tools' stamp: 'tk 4/28/1998 19:14'!
buildMessageBrowser
	"Create and schedule a message browser."

	self selectedMessageName ifNil: [^ self].
	Browser openMessageBrowserForClass: self selectedClassOrMetaClass 
		selector: self selectedMessageName editString: nil! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 1/16/2004 21:14'!
classHierarchy
	"Create and schedule a class list browser on the receiver's hierarchy."

	self systemNavigation
		spawnHierarchyForClass: self selectedClassOrMetaClass "OK if nil"
		selector: self selectedMessageName
! !

!StringHolder methodsFor: '*Tools' stamp: 'sw 5/8/2000 02:16'!
classListKey: aChar from: view 
	"Respond to a Command key.  I am a model with a list of classes and a 
	code pane, and I also have a listView that has a list of methods.  The 
	view knows how to get the list and selection."

	aChar == $f ifTrue: [^ self findMethod].
	aChar == $r ifTrue: [^ self recent].
	aChar == $h ifTrue: [^ self spawnHierarchy].
	aChar == $x ifTrue: [^ self removeClass].
	^ self messageListKey: aChar from: view! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
copyName
	"Copy the current selector to the clipboard"
	| selector |
	(selector := self selectedMessageName) ifNotNil:
		[Clipboard clipboardText: selector asString asText]! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
copySelector
	"Copy the selected selector to the clipboard"

	| selector |
	(selector := self selectedMessageName) ifNotNil:
		[Clipboard clipboardText: selector asString]! !

!StringHolder methodsFor: '*Tools' stamp: 'sw 7/1/2001 08:24'!
fileOutMessage
	"Put a description of the selected message on a file"

	self selectedMessageName ifNotNil:
		[Cursor write showWhile:
			[self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]]! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
findMethodInChangeSets
	"Find and open a changeSet containing the current method."

	| aName |
	(aName := self selectedMessageName) ifNotNil: [
		ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass
					selector: aName]! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
inspectInstances
	"Inspect all instances of the selected class."

	| myClass |
	(myClass := self selectedClassOrMetaClass) ifNotNil:
		[myClass theNonMetaClass inspectAllInstances]. 
! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
inspectSubInstances
	"Inspect all instances of the selected class and all its subclasses"

	| aClass |
	(aClass := self selectedClassOrMetaClass) ifNotNil: [
		aClass theNonMetaClass inspectSubInstances].
! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
makeIsolatedCodePane
	| msgName |

	(msgName := self selectedMessageName) ifNil: [^ Beeper beep].
	MethodHolder makeIsolatedCodePaneForClass: self selectedClassOrMetaClass selector: msgName! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
messageListKey: aChar from: view
	"Respond to a Command key.  I am a model with a code pane, and I also
	have a listView that has a list of methods.  The view knows how to get
	the list and selection."

	| sel class |
	aChar == $D ifTrue: [^ self toggleDiffing].

	sel := self selectedMessageName.
	aChar == $m ifTrue:  "These next two put up a type in if no message selected"
		[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation].
	aChar == $n ifTrue: 
		[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation].

	"The following require a class selection"
	(class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view].
	aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel].
	aChar == $N ifTrue: [^ self browseClassRefs].
	aChar == $i ifTrue: [^ self methodHierarchy].
	aChar == $h ifTrue: [^ self classHierarchy].
	aChar == $p ifTrue: [^ self browseFullProtocol].

	"The following require a method selection"
	sel ifNotNil: 
		[aChar == $o ifTrue: [^ self fileOutMessage].
		aChar == $c ifTrue: [^ self copySelector].
		aChar == $v ifTrue: [^ self browseVersions].
		aChar == $O ifTrue: [^ self openSingleMessageBrowser].
		aChar == $x ifTrue: [^ self removeMessage]].

	^ self arrowKey: aChar from: view! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
messageListSelectorTitle
	| selector aString aStamp aSize |

	(selector := self selectedMessageName)
		ifNil:
			[aSize := self messageList size.
			^ (aSize == 0 ifTrue: ['no'] ifFalse: [aSize printString]), ' message', (aSize == 1 ifTrue: [''] ifFalse: ['s'])]
		ifNotNil:
			[Preferences timeStampsInMenuTitles
				ifFalse:	[^ nil].
			aString := selector truncateWithElipsisTo: 28.
			^ (aStamp := self timeStamp) size > 0
				ifTrue:
					[aString, String cr, aStamp]
				ifFalse:
					[aString]]! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 1/16/2004 21:10'!
methodHierarchy
	"Create and schedule a method browser on the hierarchy of implementors."

	self systemNavigation 
			methodHierarchyBrowserForClass: self selectedClassOrMetaClass 
			selector: self selectedMessageName
! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
offerDurableMenuFrom: menuRetriever shifted: aBoolean
	"Pop up (morphic only) a menu whose target is the receiver and whose contents are provided by sending the menuRetriever to the receiver.  The menuRetriever takes two arguments: a menu, and a boolean representing the shift state; put a stay-up item at the top of the menu."

	| aMenu |
	aMenu := MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	self perform: menuRetriever with: aMenu with: aBoolean.
		aMenu popUpInWorld! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
offerMenuFrom: menuRetriever shifted: aBoolean
	"Pop up, in morphic or mvc as the case may be, a menu whose target is the receiver and whose contents are provided by sending the menuRetriever to the receiver.  The menuRetriever takes two arguments: a menu, and a boolean representing the shift state."

	| aMenu |
	Smalltalk isMorphic
		ifTrue:
			[aMenu := MenuMorph new defaultTarget: self.
			self perform: menuRetriever with: aMenu with: aBoolean.
			aMenu popUpInWorld]
		ifFalse:
			[aMenu := CustomMenu new.
			self perform: menuRetriever with: aMenu with: aBoolean.
			aMenu invokeOn: self]! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
openSingleMessageBrowser
	| msgName mr |
	"Create and schedule a message list browser populated only by the currently selected message"

	(msgName := self selectedMessageName) ifNil: [^ self].

	mr := MethodReference new
		setStandardClass: self selectedClassOrMetaClass
		methodSymbol: msgName.

	self systemNavigation 
		browseMessageList: (Array with: mr)
		name: mr asStringOrText
		autoSelect: nil! !

!StringHolder methodsFor: '*Tools' stamp: 'RAA 12/10/1999 09:36'!
packageListKey: aChar from: view
	"Respond to a Command key in the package pane in the PackageBrowser"
	aChar == $f ifTrue: [^ self findClass].
	^ self classListKey: aChar from: view
! !

!StringHolder methodsFor: '*Tools' stamp: 'tk 4/28/1998 18:16'!
printOutMessage
	"Write a file with the text of the selected message, for printing by a web browser"

	self selectedMessageName ifNotNil: [
		self selectedClassOrMetaClass fileOutMethod: self selectedMessageName
							asHtml: true]! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 5/23/2003 14:42'!
removeFromCurrentChanges
	"Tell the changes mgr to forget that the current msg was changed."

	ChangeSet current removeSelectorChanges: self selectedMessageName 
			class: self selectedClassOrMetaClass.
	self changed: #annotation! !

!StringHolder methodsFor: '*Tools' stamp: 'sw 1/28/1999 12:34'!
revertAndForget
	"Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed.  Danger!!  Use only if you really know what you're doing!!"

	self okToChange ifFalse: [^ self].
	self revertToPreviousVersion.
	self removeFromCurrentChanges.
	self contentsChanged
! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
revertToPreviousVersion
	"Revert to the previous version of the current method"
	| aClass aSelector  changeRecords |
	self okToChange ifFalse: [^ self].
	aClass := self selectedClassOrMetaClass.
	aClass ifNil: [^ self changed: #flash].
	aSelector := self selectedMessageName.
	changeRecords := aClass changeRecordsAt: aSelector.
	(changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [self changed: #flash.  ^ Beeper beep].
	changeRecords second fileIn.
	self contentsChanged
! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
selectMessageAndEvaluate: aBlock
	"Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector.  If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any"

	| selector method messages |
	(selector := self selectedMessageName) ifNil: [^ self].
	method := (self selectedClassOrMetaClass ifNil: [^ self])
		compiledMethodAt: selector
		ifAbsent: [].
	(method isNil or: [(messages := method messages) size == 0])
		 ifTrue: [^ aBlock value: selector].
	(messages size == 1 and: [messages includes: selector])
		ifTrue:
			[^ aBlock value: selector].  "If only one item, there is no choice"

	self systemNavigation 
		showMenuOf: messages
		withFirstItem: selector
		ifChosenDo: [:sel | aBlock value: sel]! !

!StringHolder methodsFor: '*Tools' stamp: 'nk 11/15/2002 12:23'!
systemCatListKey: aChar from: view
	"Respond to a Command key.  I am a model with a code pane, and I also have a listView that has a list of methods.  The view knows how to get the list and selection."

	aChar == $f ifTrue: [^ self findClass].
	aChar == $x ifTrue: [^ self removeSystemCategory].
	^ self classListKey: aChar from: view! !

!StringHolder methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
timeStamp
	"Answer the time stamp for the chosen class and method, if any, else an empty string"

	|  selector  aMethod |
	(selector := self selectedMessageName) ifNotNil:
		[self selectedClassOrMetaClass 
			ifNil:
				[^ String new]
			ifNotNil:
				[aMethod := self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [nil].
				aMethod ifNotNil: [^ Utilities timeStampForMethod: aMethod]]].
	^ String new! !


!StringHolder methodsFor: '*Tools-traits' stamp: 'al 12/6/2005 22:22'!
browseClassRefs

	| cls |
	cls := self selectedClass.
	(cls notNil and: [cls isTrait not])
		ifTrue: [self systemNavigation browseAllCallsOnClass: cls theNonMetaClass]
! !

!StringHolder methodsFor: '*Tools-traits' stamp: 'al 12/6/2005 22:22'!
browseClassVariables
	"Browse the class variables of the selected class. 2/5/96 sw"
	| cls |
	cls := self selectedClass.
	(cls notNil and: [cls isTrait not])
		ifTrue: [self systemNavigation  browseClassVariables: cls]
! !

!StringHolder methodsFor: '*Tools-traits' stamp: 'al 12/6/2005 22:23'!
browseClassVarRefs
	"1/17/96 sw: devolve responsibility to the class, so that the code that does the real work can be shared"

	| cls |
	cls := self selectedClass.
	(cls notNil and: [cls isTrait not])
		ifTrue: [self systemNavigation  browseClassVarRefs: cls]! !

!StringHolder methodsFor: '*Tools-traits' stamp: 'al 12/6/2005 22:23'!
browseFullProtocol
	"Open up a protocol-category browser on the value of the receiver's current selection.    If in mvc, an old-style protocol browser is opened instead.  Someone who still uses mvc might wish to make the protocol-category-browser work there too, thanks."

	| aClass |

	(Smalltalk isMorphic and: [Smalltalk includesKey: #Lexicon]) ifFalse: [^ self spawnFullProtocol].
	((aClass := self selectedClassOrMetaClass) notNil and: [aClass isTrait not]) ifTrue:
		[(Smalltalk at: #Lexicon) new openOnClass: aClass inWorld: ActiveWorld showingSelector: self selectedMessageName]! !

!StringHolder methodsFor: '*Tools-traits' stamp: 'al 12/6/2005 22:24'!
browseInstVarDefs 

	| cls |
	cls := self selectedClassOrMetaClass.
	(cls notNil and: [cls isTrait not])
		ifTrue: [self systemNavigation browseInstVarDefs: cls]! !

!StringHolder methodsFor: '*Tools-traits' stamp: 'al 12/6/2005 22:24'!
browseInstVarRefs
	"1/26/96 sw: real work moved to class, so it can be shared"
	| cls |
	cls := self selectedClassOrMetaClass.
	(cls notNil and: [cls isTrait not])
		ifTrue: [self systemNavigation browseInstVarRefs: cls]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringHolder class
	instanceVariableNames: ''!

!StringHolder class methodsFor: 'class initialization'!
initialize
	"The class variables were initialized once, and subsequently filled with
	information. Re-executing this method is therefore dangerous." 
	 
	"workSpace _ StringHolder new"

	"StringHolder initialize"! !


!StringHolder class methodsFor: 'instance creation' stamp: 'ar 9/27/2005 20:48'!
open
	(Smalltalk at: #Workspace ifAbsent:[self]) new openLabel: 'Workspace'
		"Not to be confused with our own class var 'Workspace'"! !

!StringHolder class methodsFor: 'instance creation' stamp: 'tk 5/4/1998 16:41'!
openLabel: aString

	self new openLabel: aString! !


!StringHolder class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:44'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Workspace' brightColor: #lightYellow pastelColor: #paleYellow helpMessage: 'A place for text in a window.'! !
ParagraphEditor subclass: #StringHolderController
	instanceVariableNames: ''
	classVariableNames: 'CodeYellowButtonMenu CodeYellowButtonMessages'
	poolDictionaries: ''
	category: 'ST80-Support'!
!StringHolderController commentStamp: '<historical>' prior: 0!
I represent a ParagraphEditor for a single paragraph of text, omitting alignment commands. I provide items in the yellow button menu so that the text selection can be evaluated and so that the contents of the model can be stored or restored.
	doIt	evaluate the text selection as an expression
	printIt	same as doIt but insert a description of the result after the selection
	accept	store the contents of the StringHolder into the model
	cancel	store the contents of the model into the StringHolder!


!StringHolderController methodsFor: 'accessing' stamp: 'di 6/21/2001 10:32'!
changeText: aText
	"The paragraph to be edited is changed to aText."
	paragraph text: aText.
	self resetState.
	self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size.
	self selectAndScroll.
	self deselect! !

!StringHolderController methodsFor: 'accessing'!
model: aModel

	super model: aModel.
	view displayContents == nil
		ifFalse: [self changeParagraph: view displayContents]! !


!StringHolderController methodsFor: 'compiler access'!
bindingOf: aString
	^model bindingOf: aString! !


!StringHolderController methodsFor: 'edit flag' stamp: 'di 10/9/1998 15:41'!
hasUnacceptedEdits: aBoolean
	^ view hasUnacceptedEdits: aBoolean! !

!StringHolderController methodsFor: 'edit flag' stamp: 'tk 4/13/1998 23:09'!
userHasEdited
	"Note that the user has edited my text."

	view hasUnacceptedEdits: true
! !

!StringHolderController methodsFor: 'edit flag' stamp: 'tk 4/13/1998 23:08'!
userHasNotEdited
	"Note that my text is free of user edits."

	model clearUserEditFlag
! !


!StringHolderController methodsFor: 'menu messages' stamp: 'jm 3/18/98 20:53'!
accept 
	"Refer to the comment in ParagraphEditor|accept."

	super accept.
	model contents: paragraph string.
	self userHasNotEdited.
! !

!StringHolderController methodsFor: 'menu messages' stamp: 'jm 3/18/98 20:54'!
cancel 
	"Refer to the comment in ParagraphEditor|cancel."

	super cancel.
	self userHasNotEdited.
! !

!StringHolderController methodsFor: 'menu messages' stamp: 'tk 4/13/1998 23:14'!
performMenuMessage: aSelector
	"Intercept #again so the model does not get locked by keying the search text."

	| hadEdits |
	hadEdits _ view canDiscardEdits not.
	super performMenuMessage: aSelector.
	(hadEdits not and:
	 [aSelector == #again and:
	 [(UndoMessage sends: #undoAgain:andReselect:typedKey:) and:
	 [UndoMessage arguments at: 3]]])
		ifTrue: [self userHasNotEdited].
! !


!StringHolderController methodsFor: 'private' stamp: 'jm 3/18/98 20:43'!
closeTypeIn
	"Note edit if something actually was typed."

	beginTypeInBlock ~~ nil ifTrue: [self userHasEdited].
	super closeTypeIn.
! !

!StringHolderController methodsFor: 'private' stamp: 'jm 3/18/98 20:45'!
zapSelectionWith: aText
	"Note edit except during typeIn, which notes edits at close."

	super zapSelectionWith: aText.
	beginTypeInBlock == nil ifTrue: [self userHasEdited].
! !
View subclass: #StringHolderView
	instanceVariableNames: 'displayContents hasUnacceptedEdits askBeforeDiscardingEdits'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!StringHolderView commentStamp: '<historical>' prior: 0!
I am a View of a String that is an aspect of a more structured object. This String should not be changed by any editing unless the user issues the accept command. Thus my instances provide a working copy of the String. This copy is edited. When the user issues the accept command, the String is copied from the working version; or if the user issues the cancel command, the working version is restored from the String. StringHolderController is my default controller. It is initialized specially by passing the string viewed which is then converted to a Paragraph for editing.!


!StringHolderView methodsFor: 'controller access'!
defaultController 
	"Refer to the comment in View|defaultController."

	^self defaultControllerClass newParagraph: displayContents! !

!StringHolderView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^StringHolderController! !

!StringHolderView methodsFor: 'controller access'!
displayContents

	^displayContents! !


!StringHolderView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."

	(self controller isKindOf: ParagraphEditor)
	 	ifTrue: [controller deselect]! !


!StringHolderView methodsFor: 'displaying'!
display 
	"Refer to the comment in View.display."
	(self isUnlocked and: [self insetDisplayBox ~= displayContents clippingRectangle])
		ifTrue:  "Recompose the text if the window changed"
				[self positionDisplayContents. 
				(self controller isKindOf: ParagraphEditor)
					ifTrue: [controller recomputeSelection]].
	super display! !

!StringHolderView methodsFor: 'displaying' stamp: 'hmm 6/18/2000 19:24'!
displayView 
	"Refer to the comment in View|displayView."

	Display deferUpdatesIn: self displayBox while: [
		self clearInside.
		(self controller isKindOf: ParagraphEditor)
			ifTrue: [controller display]
			ifFalse: [displayContents display]]! !

!StringHolderView methodsFor: 'displaying'!
lock
	"Refer to the comment in view|lock.  Must do at least what display would do to lock the view."
	(self isUnlocked and: [self insetDisplayBox ~= displayContents clippingRectangle])
		ifTrue:  "Recompose the text if the window changed"
				[self positionDisplayContents. 
				(self controller isKindOf: ParagraphEditor)
					ifTrue: [controller recomputeSelection]].
	super lock! !

!StringHolderView methodsFor: 'displaying'!
positionDisplayContents
	"Presumably the text being displayed changed so that the wrapping box 
	and clipping box should be reset."

	displayContents 
		wrappingBox: (self insetDisplayBox insetBy: 6 @ 0)
		clippingBox: self insetDisplayBox! !


!StringHolderView methodsFor: 'initialize-release' stamp: 'jm 3/24/98 14:39'!
initialize 
	"Refer to the comment in View|initialize."

	super initialize.
	displayContents _ '' asParagraph.
	hasUnacceptedEdits _ false.
	askBeforeDiscardingEdits _ true.
! !


!StringHolderView methodsFor: 'model access'!
editString: aString 
	"The paragraph to be displayed is created from the characters in aString."

	displayContents _ Paragraph withText: aString asText
		style: TextStyle default copy
		compositionRectangle: (self insetDisplayBox insetBy: 6 @ 0)
		clippingRectangle: self insetDisplayBox
		foreColor: self foregroundColor backColor: self backgroundColor.
	(self controller isKindOf: ParagraphEditor)
		ifTrue: [controller changeParagraph: displayContents]! !

!StringHolderView methodsFor: 'model access' stamp: 'sma 5/28/2000 23:25'!
getMenu: shiftKeyState
	^ nil! !

!StringHolderView methodsFor: 'model access'!
model: aLockedModel 
	"Refer to the comment in View|model:."
 
	super model: aLockedModel.
	self editString: model contents! !


!StringHolderView methodsFor: 'updating' stamp: 'jm 3/24/98 14:38'!
askBeforeDiscardingEdits: aBoolean
	"Set the flag that determines whether the user should be asked before discarding unaccepted edits."

	askBeforeDiscardingEdits _ aBoolean.
! !

!StringHolderView methodsFor: 'updating' stamp: 'tk 4/13/1998 22:58'!
canDiscardEdits
	"Return true if this view either has no text changes or does not care."

	^ (hasUnacceptedEdits & askBeforeDiscardingEdits) not
! !

!StringHolderView methodsFor: 'updating' stamp: 'jm 3/24/98 17:49'!
hasUnacceptedEdits
	"Return true if this view has unaccepted edits."

	^ hasUnacceptedEdits
! !

!StringHolderView methodsFor: 'updating' stamp: 'tk 4/13/1998 17:17'!
hasUnacceptedEdits: aBoolean
	"Set the hasUnacceptedEdits flag to the given value."

	hasUnacceptedEdits _ aBoolean.
! !

!StringHolderView methodsFor: 'updating' stamp: 'dgd 9/21/2003 17:42'!
promptForCancel
	"Ask if it is OK to cancel changes to text"
	| okToCancel stripes |
	self topView isCollapsed ifTrue:
		[(self confirm: 'Changes have not been saved.
Is it OK to cancel those changes?' translated) ifTrue: [model clearUserEditFlag].
		^ self].
	stripes _ (Form extent: 16@16 fromStipple: 16r36C9) bits.
	Display border: self insetDisplayBox width: 4
			rule: Form reverse fillColor: stripes.
	okToCancel _ self confirm: 'Changes have not been saved.
Is it OK to cancel those changes?' translated.
	Display border: self insetDisplayBox width: 4
			rule: Form reverse fillColor: stripes.
	okToCancel ifTrue:
		[self updateDisplayContents.
		model clearUserEditFlag].
! !

!StringHolderView methodsFor: 'updating' stamp: 'di 4/21/1998 11:30'!
update: aSymbol
	"Refer to the comment in View|update:."
	aSymbol == #wantToChange ifTrue: [^ self promptForCancel].
	aSymbol == #clearUserEdits ifTrue: [^ self hasUnacceptedEdits: false].
	aSymbol == #flash ifTrue: [^ controller flash].
	self updateDisplayContents! !

!StringHolderView methodsFor: 'updating'!
updateDisplayContents
	"Make the text that is displayed be the contents of the receiver's model."

	self editString: model contents.
	self displayView! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringHolderView class
	instanceVariableNames: ''!

!StringHolderView class methodsFor: 'instance creation'!
container
	"Answer an instance of me with a new instance of StringHolder as the 
	model."

	^self container: StringHolder new! !

!StringHolderView class methodsFor: 'instance creation'!
container: aContainer 
	"Answer an instance of me whose model is aContainer. Give it a 2-dot 
	border."

	| aCodeView |
	aCodeView _ self new model: aContainer.
	aCodeView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	^aCodeView! !

!StringHolderView class methodsFor: 'instance creation' stamp: 'ar 9/27/2005 20:48'!
open
	"Create a standard system view of a workspace on the screen."

	self open: StringHolder new label: 'Workspace'! !

!StringHolderView class methodsFor: 'instance creation'!
open: aStringHolder 
	"Create a standard system view of the argument, aStringHolder, as viewed 
	by an instance of me. The view has label 'StringHolder'."

	self open: aStringHolder label: 'StringHolder'! !

!StringHolderView class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:15'!
open: aStringHolder label: labelString 
	"NOTE this should be in the model class, and all senders so redirected,
	in order that the view class can be discarded in a morphic world."

	"Create a standard system view of the model, aStringHolder, as viewed by 
	an instance of me. The label of the view is aString."
	| aStringHolderView topView |

	Smalltalk isMorphic ifTrue: [^ aStringHolder openAsMorphLabel: labelString].

	aStringHolderView _ self container: aStringHolder.
	topView _ StandardSystemView new.
	topView model: aStringHolderView model.
	topView addSubView: aStringHolderView.
	topView label: labelString.
	topView minimumSize: 100 @ 50.
	topView controller open! !
Morph subclass: #StringMorph
	instanceVariableNames: 'font emphasis contents hasFocus'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!StringMorph commentStamp: 'efc 3/7/2003 17:34' prior: 0!
StringMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextMorph.

Structure:
instance var    	Type              Description 
font 			StrikeFont 		(normally nil; then the accessor #font gives back TextStyle 
				or nil			defaultFont) 
emphasis 		SmallInteger	bitmask determining character attributes (underline, bold, 								italics, narrow, struckout) 
contents 		String 			The text that will be displayed. 
hasFocus 		Boolean 		Do I have the keyboard focus or not? 

If you shift-click on a StringMorph you can edit its string. This is accomplished the following way: StringMorph can launch a StringMorphEditor if it receives a #mouseDown event.

A StringMorph may also be used like a SimpleButtonMorph to do an action when clicked. Use the menu 'extras' / 'add mouseUpAction'.

The following propery will be defined:
aStringMorph valueOfProperty: #mouseUpCodeToRun!
]style[(11 20 5 14 6 97 9 14 47 9 10 53 9 40 12 108 6 49 7 168 17 75 17 163)f1LStringMorph Hierarchy;,f1,f1LMorph Comment;,f1,f1LString Comment;,f1,f1LTextMorph Comment;,f1,f1i,f1,f1LStrikeFont Comment;,f1,f1LTextStyle Comment;,f1,f1LSmallInteger Comment;,f1,f1LString Comment;,f1,f1LBoolean Comment;,f1,f1LStringMorphEditor Comment;,f1,f1LSimpleButtonMorph Comment;,f1!


!StringMorph methodsFor: 'accessing'!
contents

	^ contents! !

!StringMorph methodsFor: 'accessing'!
contentsClipped: aString
	"Change my text, but do not change my size as a result"
	contents = aString ifTrue: [^ self].  "No substantive change"
	contents _ aString.
	self changed! !

!StringMorph methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:15'!
contents: newContents 
	| scanner |
	contents := newContents isText
				ifTrue: [scanner := StringMorphAttributeScanner new initializeFromStringMorph: self.
					(newContents attributesAt: 1 forStyle: self font textStyle)
						do: [:attr | attr emphasizeScanner: scanner].
					emphasis := scanner emphasis.
					font := scanner font emphasis: emphasis.
					color := scanner textColor.
					newContents string]
				ifFalse: [contents = newContents
						ifTrue: [^ self].
					"no substantive change"
					newContents].
	self fitContents! !

!StringMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 02:44'!
fitContents

	| newBounds boundsChanged |
	newBounds _ self measureContents.
	boundsChanged _ bounds extent ~= newBounds.
	self extent: newBounds.		"default short-circuits if bounds not changed"
	boundsChanged ifFalse: [self changed]! !

!StringMorph methodsFor: 'accessing' stamp: 'ar 1/31/2001 19:33'!
font
	"who came up with #fontToUse rather than font?!!"
	^self fontToUse! !

!StringMorph methodsFor: 'accessing' stamp: 'tk 8/28/2000 13:59'!
fontName: fontName size: fontSize

	^ self font: (StrikeFont familyName: fontName size: fontSize) 
			emphasis: 0! !

!StringMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 23:07'!
fontToUse
	| fontToUse |
	fontToUse := font isNil ifTrue: [TextStyle defaultFont] ifFalse: [font].
	(emphasis isNil or: [emphasis = 0]) 
		ifTrue: [^fontToUse]
		ifFalse: [^fontToUse emphasized: emphasis]! !

!StringMorph methodsFor: 'accessing' stamp: 'di 4/2/1999 16:11'!
font: aFont emphasis: emphasisCode
	font _ aFont.
	emphasis _ emphasisCode.
	self fitContents.
"
in inspector say,
	 self font: (TextStyle default fontAt: 2) emphasis: 1
"! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 11:10'!
interimContents: aString
	"The receiver is under edit and aString represents the string the user sees as she edits, which typically will not have been accepted and indeed may be abandoned"

	self contents: aString! !

!StringMorph methodsFor: 'accessing' stamp: 'ar 12/30/2001 20:45'!
measureContents
	| f |
	f _ self fontToUse.
	^(((f widthOfString: contents) max: self minimumWidth)  @ f height).! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 13:44'!
minimumWidth
	"Answer the minimum width that the receiver can have.  A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!!  Obeyed by fitContents."

	^ 3! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 12/6/1999 13:16'!
setWidth: width

	self extent: width @ (font ifNil: [TextStyle defaultFont]) height! !

!StringMorph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:55'!
userString
	"Do I have a text string to be searched on?"

	^ contents! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/16/1999 22:57'!
valueFromContents
	"Return a new value from the current contents string."
	^ contents! !


!StringMorph methodsFor: 'connectors-layout' stamp: 'dgd 2/16/2003 21:52'!
minHeight
"answer the receiver's minHeight"
	^ self fontToUse height! !


!StringMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:38'!
drawOn: aCanvas

	aCanvas drawString: contents in: bounds font: self fontToUse color: color.! !

!StringMorph methodsFor: 'drawing' stamp: 'tk 8/1/2001 14:15'!
lookTranslucent

	"keep the text the same color (black)"! !


!StringMorph methodsFor: 'editing'!
acceptContents
	"The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation does nothing."
! !

!StringMorph methodsFor: 'editing' stamp: 'sw 9/8/1999 17:04'!
acceptValue: aValue
	| val |
	self contents: (val _ aValue asString).
	^ val! !

!StringMorph methodsFor: 'editing' stamp: 'sw 9/17/1999 13:27'!
cancelEdits

	self doneWithEdits! !

!StringMorph methodsFor: 'editing' stamp: 'di 9/6/1999 22:44'!
doneWithEdits

	hasFocus _ false! !

!StringMorph methodsFor: 'editing' stamp: 'nk 2/24/2005 20:11'!
launchMiniEditor: evt

	| textMorph |
	hasFocus _ true.  "Really only means edit in progress for this morph"
	textMorph _ StringMorphEditor new contentsAsIs: contents.
	textMorph beAllFont: self fontToUse.
	textMorph bounds: (self bounds expandBy: 0@2).
	self addMorphFront: textMorph.
	evt hand newKeyboardFocus: textMorph.
	textMorph editor selectFrom: 1 to: textMorph paragraph text string size! !

!StringMorph methodsFor: 'editing' stamp: 'sw 9/8/1999 10:42'!
lostFocusWithoutAccepting
	"The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits."

	self acceptContents! !

!StringMorph methodsFor: 'editing' stamp: 'sw 7/21/1999 14:59'!
wantsKeyboardFocusOnShiftClick
	^ owner topRendererOrSelf wantsKeyboardFocusFor: self
! !


!StringMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 00:16'!
handlesMouseDown: evt
	^ (evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick])
		ifTrue: [true]
		ifFalse: [super handlesMouseDown: evt].
! !

!StringMorph methodsFor: 'event handling' stamp: 'sw 9/8/1999 11:26'!
hasFocus
	^ hasFocus! !

!StringMorph methodsFor: 'event handling' stamp: 'di 9/5/1999 17:25'!
mouseDown: evt
	"If the shift key is pressed, make this string the keyboard input focus."

	(evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick])
		ifTrue: [self launchMiniEditor: evt]
		ifFalse: [super mouseDown: evt].
! !

!StringMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:45'!
wouldAcceptKeyboardFocus
	^ self isLocked not! !


!StringMorph methodsFor: 'font' stamp: 'efc 2/22/2003 21:35'!
emphasis: aNumber
	"Set the receiver's emphasis as indicated. aNumber is a bitmask with the following format:

	bit	attribute
	1	bold
	2	italic
	4	underlined
	8	narrow
	16	struckOut"

	"examples: 0 -> plain.  
	1 -> bold.  2 -> italic.  3 -> bold italic.  4 -> underlined  
	5 -> bold underlined.  6 -> italic underlined.   7 -> bold italic underlined   
	etc..."

	emphasis _ aNumber.
	^ self font: font emphasis: emphasis! !


!StringMorph methodsFor: 'halos and balloon help' stamp: 'sw 6/15/1998 15:34'!
addOptionalHandlesTo: aHalo box: box
	self flag: #deferred.

	"Eventually...
	self addFontHandlesTo: aHalo box: box"! !

!StringMorph methodsFor: 'halos and balloon help' stamp: 'sw 6/6/2001 13:34'!
boundsForBalloon
	"Some morphs have bounds that are way too big.  This is a contorted way of making things work okay in PluggableListMorphs, whose list elements historically have huge widths"

	| ownerOwner |
	^ ((owner notNil and: [(ownerOwner _ owner owner) notNil]) and:
			[ownerOwner isKindOf: PluggableListMorph])
		ifTrue:
			[self boundsInWorld intersect: ownerOwner boundsInWorld]
		ifFalse:
			[super boundsForBalloon]! !


!StringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color black! !

!StringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	font _ nil.
	emphasis _ 0.
	hasFocus _ false! !

!StringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:57'!
initWithContents: aString font: aFont emphasis: emphasisCode 
	super initialize.
	
	font _ aFont.
	emphasis _ emphasisCode.
	hasFocus _ false.
	self contents: aString! !


!StringMorph methodsFor: 'layout' stamp: 'nk 5/11/2001 09:33'!
fullBounds
	self contents ifNil: [ self contents: 'String Morph' ].
	^super fullBounds! !


!StringMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change font' translated action: #changeFont.
	aCustomMenu add: 'change emphasis' translated action: #changeEmphasis.
! !

!StringMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:03'!
changeEmphasis

	| reply aList |
	aList _ #(normal bold italic narrow underlined struckOut).
	reply _ (SelectionMenu labelList: (aList collect: [:t | t translated]) selections: aList) startUp.
	reply ifNotNil:[
		self emphasis: (TextEmphasis perform: reply) emphasisCode.
	].
! !

!StringMorph methodsFor: 'menu' stamp: 'ar 1/5/2002 21:45'!
changeFont
	| newFont |
	newFont _ StrikeFont fromUser: self fontToUse.
	newFont ifNotNil:[self font: newFont].! !


!StringMorph methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 16:52'!
fixUponLoad: aProject seg: anImageSegment
	"We are in an old project that is being loaded from disk.
Fix up conventions that have changed."

	| substituteFont |
	substituteFont _ aProject projectParameters at:
#substitutedFont ifAbsent: [#none].
	(substituteFont ~~ #none and: [self font == substituteFont])
			ifTrue: [ self fitContents ].

	^ super fixUponLoad: aProject seg: anImageSegment! !


!StringMorph methodsFor: 'parts bin' stamp: 'dgd 2/14/2003 21:58'!
initializeToStandAlone
	super initializeToStandAlone.
	
	font _ nil.
	emphasis _ 0.
	hasFocus _ false.
	self contents: 'String: Shift-click on me to edit'! !


!StringMorph methodsFor: 'printing' stamp: 'efc 2/22/2003 21:35'!
font: aFont 
	"Set the font my text will use. The emphasis remains unchanged."

	font _ aFont.
	^ self font: font emphasis: emphasis! !

!StringMorph methodsFor: 'printing' stamp: 'jm 11/3/97 16:52'!
printOn: aStream

	super printOn: aStream.
	aStream print: contents.
! !


!StringMorph methodsFor: '*MorphicExtras-accessing' stamp: 'sw 2/18/2003 02:55'!
getCharacters
	"obtain a string value from the receiver."

	^ self contents! !

!StringMorph methodsFor: '*MorphicExtras-accessing' stamp: 'sw 9/9/1999 18:09'!
handsWithMeForKeyboardFocus
	| foc |
	"Answer the hands that have me as their keyboard focus"

	hasFocus ifFalse: [^ #()].
	^ self currentWorld hands select:
		[:aHand | (foc _ aHand keyboardFocus) notNil and: [foc owner == self]]! !


!StringMorph methodsFor: '*MorphicExtras-printing'!
fullPrintOn: aStream

	aStream nextPutAll: '('.
	super fullPrintOn: aStream.
	aStream nextPutAll: ') contents: '; print: contents! !


!StringMorph methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
balloonTextForClassAndMethodString
	"Answer suitable balloon text for the receiver thought of as an encoding of the form
		<className>  [ class ] <selector>"

	| aComment |
	Preferences balloonHelpInMessageLists
		ifFalse: [^ nil].
	MessageSet parse: self contents asString toClassAndSelector:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) ifTrue:
				[aComment := aClass precodeCommentOrInheritedCommentFor: aSelector]].
	^ aComment
! !

!StringMorph methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
balloonTextForLexiconString
	"Answer suitable balloon text for the receiver thought of as an encoding (used in Lexicons) of the form
		<selector> <spaces> (<className>>)"

	| aComment contentsString aSelector aClassName |
	Preferences balloonHelpInMessageLists
		ifFalse: [^ nil].
	contentsString := self contents asString.
	aSelector := contentsString upTo: $ .
	aClassName := contentsString copyFrom: ((contentsString indexOf: $() + 1) to: ((contentsString indexOf: $)) - 1).
	MessageSet parse: (aClassName, ' dummy') toClassAndSelector:
		[:cl :sel | cl ifNotNil:
			[aComment := cl precodeCommentOrInheritedCommentFor: aSelector]].
	^ aComment
! !

!StringMorph methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
balloonTextForMethodString
	"Answer suitable balloon text for the receiver thought of as a method belonging to the currently-selected class of a browser tool."

	| aWindow aCodeHolder aClass |
	Preferences balloonHelpInMessageLists
		ifFalse: [^ nil].
	aWindow := self ownerThatIsA: SystemWindow.
	(aWindow isNil or: [((aCodeHolder := aWindow model) isKindOf: CodeHolder) not])
		ifTrue:	[^ nil].
	((aClass := aCodeHolder selectedClassOrMetaClass) isNil or:
		[(aClass includesSelector: contents asSymbol) not])
			ifTrue: [^ nil].
	^ aClass precodeCommentOrInheritedCommentFor: contents asSymbol
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringMorph class
	instanceVariableNames: ''!

!StringMorph class methodsFor: 'instance creation' stamp: 'sw 8/22/97 22:19'!
contents: aString
	" 'StringMorph contents: str' is faster than 'StringMorph new contents: str' "
	^ self contents: aString font: nil! !

!StringMorph class methodsFor: 'instance creation' stamp: 'di 4/1/1999 17:15'!
contents: aString font: aFont
	^ self basicNew initWithContents: aString font: aFont emphasis: 0! !

!StringMorph class methodsFor: 'instance creation' stamp: 'di 4/1/1999 17:15'!
contents: aString font: aFont emphasis: emphasisCode
	^ self basicNew initWithContents: aString font: aFont emphasis: emphasisCode! !


!StringMorph class methodsFor: 'scripting' stamp: 'sw 5/6/1998 14:00'!
authoringPrototype
	^ super authoringPrototype contents: 'String'! !


!StringMorph class methodsFor: 'testing' stamp: 'di 5/6/1998 21:07'!
test
	"Return a morph with lots of strings for testing display speed."
	| c |
	c _ AlignmentMorph newColumn.
	SystemOrganization categories do:
		[:cat | c addMorph: (StringMorph new contents: cat)].
	^ c! !

!StringMorph class methodsFor: 'testing' stamp: 'di 5/6/1998 21:08'!
test2
	"Return a morph with lots of strings for testing display speed."
	| c r |
	c _ AlignmentMorph newColumn.
	SystemOrganization categories reverseDo:
		[:cat | c addMorph: (StringMorph new contents: cat)].
	r _ RectangleMorph new extent: c fullBounds extent.
	c submorphsDo: [:m | r addMorph: m].
	^ r
! !
Object subclass: #StringMorphAttributeScanner
	instanceVariableNames: 'fontNumber textColor emphasis alignment actualFont indent kern'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!StringMorphAttributeScanner commentStamp: '<historical>' prior: 0!
A StringMorphAttributeScanner provides the interface of a CharacterScanner so that text attributes may be collected from a Text and used elsewhere, like in setting the attributes of a StringMorph.
!
]style[(2 195)cblack;,f3cblack;!


!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:12'!
actualFont
	"Answer the value of actualFont"

	^ actualFont ifNil: [ TextStyle defaultFont ]! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'!
alignment
	"Answer the value of alignment"

	^ alignment! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'!
emphasis
	"Answer the value of emphasis"

	^ emphasis! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:14'!
font
	"Answer the value of font"

	^self textStyle fontAt: self fontNumber! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:11'!
fontNumber
	"Answer the value of font"

	^ fontNumber! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'!
indent
	"Answer the value of indent"

	^ indent! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'!
kern
	"Answer the value of kern"

	^ kern! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'!
textColor
	"Answer the value of textColor"

	^ textColor! !

!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:12'!
textStyle
	^self actualFont textStyle ifNil: [ TextStyle default ]! !


!StringMorphAttributeScanner methodsFor: 'initialize-release' stamp: 'nk 2/26/2004 13:10'!
initialize
	emphasis _ 0.
	indent _ 0.
	kern _ 0.
	fontNumber _ 1.
	actualFont _ TextStyle defaultFont! !


!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:40'!
addEmphasis: anInteger
	"Set the value of emphasis"

	emphasis _ emphasis bitOr: anInteger! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:41'!
addKern: kernDelta
	"Set the current kern amount."
	kern _ kern + kernDelta! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:37'!
indentationLevel: anInteger
	"Set the value of indent"

	indent _ anInteger! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 13:09'!
setActualFont: aFont
	"Set the value of actualFont, from a TextFontReference"

	actualFont _ aFont.
	aFont textStyle ifNotNilDo: [ :ts | fontNumber _ ts fontIndexOf: aFont ]! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:39'!
setAlignment: aSymbol
	"Set the value of alignment"

	alignment _ aSymbol! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 13:10'!
setFont: fontNum
	"Set the value of font"

	fontNumber _ fontNum! !

!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:34'!
textColor: anObject
	"Set the value of textColor"

	textColor _ anObject! !


!StringMorphAttributeScanner methodsFor: 'string morph' stamp: 'nk 2/26/2004 13:09'!
initializeFromStringMorph: aStringMorph
	| style |
	actualFont _ aStringMorph font ifNil: [ TextStyle defaultFont ].
	style _ actualFont textStyle.
	emphasis _ actualFont emphasis.
	fontNumber _ (style fontIndexOf: actualFont) ifNil: [ 1 ].
	textColor _ aStringMorph color.
! !
TextMorph subclass: #StringMorphEditor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!StringMorphEditor commentStamp: '<historical>' prior: 0!
I am a textMorph used as a pop-up editor for StringMorphs.  I present a yellow background and I go away when a CR is typed or when the user clicks elsewhere.!


!StringMorphEditor methodsFor: 'display' stamp: 'sw 4/20/2003 15:46'!
initialize
	"Initialize the receiver.  Give it a white background"

	super initialize.
	self backgroundColor: Color white.
	self color: Color red! !


!StringMorphEditor methodsFor: 'drawing' stamp: 'sw 9/7/1999 16:22'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds color: Color yellow muchLighter.
	^ super drawOn: aCanvas! !


!StringMorphEditor methodsFor: 'event handling' stamp: 'nk 6/12/2004 22:07'!
keyStroke: evt
	"This is hugely inefficient, but it seems to work, and it's unlikely it will ever need
	to be any more efficient -- it's only intended to edit single-line strings."

	| char priorEditor newSel |
	(((char _ evt keyCharacter) = Character enter) or: [(char = Character cr)
			or: [char = $s and: [evt commandKeyPressed]]])
				ifTrue: [owner doneWithEdits; acceptContents.
	self flag: #arNote. "Probably unnecessary"
						evt hand releaseKeyboardFocus.
						^ self delete].
	
	(char = $l and: [evt commandKeyPressed]) ifTrue:   "cancel"
		[owner cancelEdits.
		evt hand releaseKeyboardFocus.
		^ self delete].

	super keyStroke: evt.
	owner interimContents: self contents asString.
	newSel _ self editor selectionInterval.

	priorEditor _ self editor.  "Save editor state"
	self releaseParagraph.  "Release paragraph so it will grow with selection."
	self paragraph.      "Re-instantiate to set new bounds"
	self installEditorToReplace: priorEditor.  "restore editor state"
	self editor selectFrom: newSel first to: newSel last.
! !

!StringMorphEditor methodsFor: 'event handling' stamp: 'nk 1/23/2004 13:18'!
keyboardFocusChange: aBoolean
	| hadFocus |
	owner ifNil: [ ^self ].
	hadFocus _ owner hasFocus.
	super keyboardFocusChange: aBoolean.
	aBoolean ifFalse:
		[hadFocus ifTrue:
			[owner lostFocusWithoutAccepting; doneWithEdits].
		^ self delete]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringMorphEditor class
	instanceVariableNames: ''!

!StringMorphEditor class methodsFor: 'new-morph participation' stamp: 'kfr 5/1/2000 13:41'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
TileMorph subclass: #StringReadoutTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!StringReadoutTile methodsFor: 'accessing' stamp: 'sw 11/1/97 13:15'!
literal: anObject
	literal _ anObject.
	self updateLiteralLabel.
	submorphs last informTarget! !


!StringReadoutTile methodsFor: 'literal' stamp: 'sw 9/15/1999 15:14'!
setLiteralTo: anObject width: w
	"like literal:width: but does not inform the target"
	literal _ anObject.
	self updateLiteralLabel.
	submorphs last setWidth: w.
	self updateLiteralLabel! !


!StringReadoutTile methodsFor: 'misc' stamp: 'sw 9/17/1999 08:01'!
basicWidth
	^ 26! !


!StringReadoutTile methodsFor: 'event handling' stamp: 'tak 8/2/2005 18:20'!
handlesMouseDown: evt 
	^ true! !

!StringReadoutTile methodsFor: 'event handling' stamp: 'tak 8/2/2005 23:38'!
mouseStillDown: evt 
	(self labelMorph notNil
			and: [self labelMorph containsPoint: evt cursorPoint])
		ifTrue: [^ self labelMorph mouseDown: evt].
	^ super mouseStillDown: evt! !
ObjectSocket subclass: #StringSocket
	instanceVariableNames: 'numStringsInNextArray stringsForNextArray nextStringSize files startTime stringCounter socketWriterProcess outputQueue bytesInOutputQueue extraUnsentBytes transmissionError readBuffer'
	classVariableNames: 'MaxRatesSeen RecentSendHistory RunningSendCount'
	poolDictionaries: ''
	category: 'Nebraska-Network-ObjectSocket'!
!StringSocket commentStamp: 'ls 8/4/2004 15:15' prior: 0!
This is a socket which sends arrays of strings back and forth.  This is less convenient than ObjectSockets, but it is more secure and it makes it easier to reason about updates to the protocol.

An array of strings is represented on the network as:

	4-bytes		number of strings in the array
	4-byte		number of bytes in the first string
	n1-bytes		characters in the first string
	4-bytes		number of bytes in the second string
	n2-bytes	characters in the second string
	...

!


!StringSocket methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
destroy

	socketWriterProcess ifNotNil: [socketWriterProcess terminate. socketWriterProcess := nil].
	outputQueue := nil.
	bytesInOutputQueue := 0.
	socket ifNotNil: [socket destroy. socket := nil.].
! !

!StringSocket methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
initialize: aSocket

	transmissionError := false.
	super initialize: aSocket.
	outputQueue := SharedQueue new.
	extraUnsentBytes := bytesInOutputQueue := 0.
	socketWriterProcess := [
		[self transmitQueueNext] whileTrue.
		socketWriterProcess := nil.
		outputQueue := nil.
		bytesInOutputQueue := 0.
	] forkAt: Processor lowIOPriority.! !

!StringSocket methodsFor: 'as yet unclassified' stamp: 'yo 10/10/2005 18:47'!
readBuffer

	^ readBuffer ifNil: [readBuffer _ String new: 20000].
! !


!StringSocket methodsFor: 'private-IO' stamp: 'yo 10/10/2005 18:49'!
addToInBuf: aString

	| newAlloc |
	newAlloc _ aString size * 2 max: 80000.
	inBuf ifNil: [
		inBuf _ String new: newAlloc.
		inBufIndex _ 1.
		inBufLastIndex _ 0.
	].
	aString size > (inBuf size - inBufLastIndex) ifTrue: [
		inBuf _ inBuf , (String new: newAlloc)
	].
	inBuf 
		replaceFrom: inBufLastIndex + 1 
		to: inBufLastIndex + aString size
		with: aString 
		startingAt: 1.
	inBufLastIndex _ inBufLastIndex + aString size.
! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
addToOutBuf: arrayToWrite

	| size newAlloc |
	size := self spaceToEncode: arrayToWrite.
	newAlloc := size * 2 max: 8000.	"gives us room to grow"
	outBuf ifNil: [
		outBuf := String new: newAlloc.
		outBufIndex := 1.
	].
	outBuf size - outBufIndex + 1 < size ifTrue: [
		outBuf := outBuf , (String new: newAlloc).
	].
	CanvasEncoder at: 1 count: arrayToWrite size + 1.
	outBuf putInteger32: arrayToWrite size at: outBufIndex.
	outBufIndex := outBufIndex + 4.
	arrayToWrite do: [ :each |
		outBuf putInteger32: each size at: outBufIndex.
		outBufIndex := outBufIndex + 4.
		outBuf 
			replaceFrom: outBufIndex 
			to: outBufIndex + each size - 1 
			with: each 
			startingAt: 1.
		outBufIndex := outBufIndex + each size.
	].
	^size! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/13/2000 08:29'!
backlog

	^bytesInOutputQueue + extraUnsentBytes! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
gotSomething

	numStringsInNextArray ifNil: [^self tryForNumStringsInNextArray ].
	numStringsInNextArray = 0 ifTrue: [
		inObjects add: #().
		numStringsInNextArray := nil.
		^true ].
	nextStringSize ifNil: [^ self tryForNextStringSize ].
	^self tryForString
! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
inBufNext: anInteger
	
	| answer |
	answer := inBuf copyFrom: inBufIndex to: inBufIndex + anInteger - 1.
	inBufIndex := inBufIndex + anInteger.
	^answer! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/20/2000 15:55'!
inBufSize

	inBuf ifNil: [^0].
	^inBufLastIndex - inBufIndex + 1! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/14/2000 09:54'!
isConnected

	^super isConnected and: [socketWriterProcess notNil]! !

!StringSocket methodsFor: 'private-IO' stamp: 'md 2/24/2006 19:51'!
nextPut: anObject

	socketWriterProcess ifNil: [^self].
	outObjects addLast: anObject.
	"return the argument - added by kwl"
	^ anObject! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/14/2000 09:46'!
processIO
	"do some as much network IO as possible"

	socketWriterProcess ifNil: [^self].
	self processOutput.
	self processInput.! !

!StringSocket methodsFor: 'private-IO' stamp: 'yo 10/10/2005 18:47'!
processInput
	| totalReceived chunkOfData |
	"do as much input as possible"

	self flag: #XXX.  "should have resource limits here--no more than X objects and Y bytes"

	chunkOfData _ socket receiveAvailableDataIntoBuffer: self readBuffer.
	self addToInBuf: chunkOfData.
	totalReceived _ chunkOfData size.

	totalReceived > 0 ifTrue: [
		NebraskaDebug at: #SendReceiveStats add: {'GET'. totalReceived}.
	].

	[ self gotSomething ] whileTrue: [].		"decode as many string arrays as possible"

	self shrinkInBuf.! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
processOutput

	| arrayToWrite size bytesSent timeStartSending t itemsSent now timeSlot bucketAgeInMS bytesThisSlot |

	outBufIndex := 1.
	itemsSent := bytesSent := 0.
	timeStartSending := Time millisecondClockValue.
	[outObjects isEmpty not and: [self isConnected]] whileTrue: [
		arrayToWrite := outObjects removeFirst.
		size := self addToOutBuf: arrayToWrite.
		bytesSent := bytesSent + size.
		itemsSent := itemsSent + 1.
		outBufIndex > 10000 ifTrue: [self queueOutBufContents].
	].
	outBufIndex > 1 ifTrue: [self queueOutBufContents].
	bytesSent > 0 ifTrue: [
		MaxRatesSeen ifNil: [MaxRatesSeen := Dictionary new].
		now := Time millisecondClockValue.
		t := now - timeStartSending.
		timeSlot := now // 10000.	"ten second buckets"
		bucketAgeInMS := now \\ 10.
		bytesThisSlot := (MaxRatesSeen at: timeSlot ifAbsent: [0]) + bytesSent.
		MaxRatesSeen 
			at: timeSlot 
			put: bytesThisSlot.
		NebraskaDebug 
			at: #SendReceiveStats 
			add: {'put'. bytesSent. t. itemsSent. bytesThisSlot // (bucketAgeInMS max: 100)}.
	].
! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
purgeOutputQueue

	bytesInOutputQueue := 0.
	[outputQueue nextOrNil notNil] whileTrue.! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
queueOutBufContents

	bytesInOutputQueue := bytesInOutputQueue + outBufIndex - 1.
	outputQueue nextPut: {outBuf. outBufIndex - 1}.
	NebraskaDebug at: #queuedbufferSizes add: {outBufIndex - 1}.
	outBufIndex := 1.
	outBuf := String new: 11000.
	
! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
sendDataCautiously: aStringOrByteArray bytesToSend: bytesToSend
	"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent. Try not to send too much at once since this seemed to cause problems talking to a port on the same machine"

	| bytesSent count |

	bytesSent := 0.
	[bytesSent < bytesToSend] whileTrue: [
		extraUnsentBytes := bytesToSend - bytesSent.
		count := socket 
			sendSomeData: aStringOrByteArray 
			startIndex: bytesSent + 1  
			count: (bytesToSend - bytesSent min: 6000).
		bytesSent := bytesSent + count.
		(Delay forMilliseconds: 1) wait.
	].
	extraUnsentBytes := 0.
	^ bytesSent
! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
shrinkInBuf

	inBuf ifNil: [^self].
	inBufLastIndex < inBufIndex ifTrue: [
		inBufLastIndex := 0.
		inBufIndex := 1.
		inBuf size > 20000 ifTrue: [inBuf := nil].	"if really big, kill it"
		^self
	].
	inBuf := inBuf copyFrom: inBufIndex to: inBufLastIndex.
	inBufLastIndex := inBuf size.
	inBufIndex := 1.

! !

!StringSocket methodsFor: 'private-IO' stamp: 'ls 4/25/2000 18:36'!
spaceToEncode: anArray
	"return the number of characters needed to encode the given string array"
	^anArray inject: 4 into: [ :sum :array |
		sum + (array size + 4) ].! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
transmitQueueNext

	| bufTuple |

	bufTuple := outputQueue next.
	bytesInOutputQueue := bytesInOutputQueue - bufTuple second max: 0.
	[
		self 
			sendDataCautiously: bufTuple first 
			bytesToSend: bufTuple second.
	]
		on: Error
		do: [ :ex |
			transmissionError := true.
		].
	^transmissionError not

! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
tryForNextStringSize
	"grab the size of the next string, if it's available"

	self inBufSize >= 4 ifFalse: [^false].

	nextStringSize := inBuf getInteger32: inBufIndex.
	"nextStringSize > 100000 ifTrue: [self barf]."
	inBufIndex := inBufIndex + 4.
	
	nextStringSize < 0 ifTrue: [
		socket disconnect.
		^false ].
	
	^true
! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
tryForNumStringsInNextArray
	"input numStringsInNextARray, if 4 bytes are available"

	self inBufSize >= 4 ifFalse: [^false].

	numStringsInNextArray := inBuf getInteger32: inBufIndex.
	"(numStringsInNextArray > 100 or: [numStringsInNextArray < 1]) ifTrue: [self barf]."
	inBufIndex := inBufIndex + 4.

	numStringsInNextArray < 0 ifTrue: [
		socket disconnect.
		^false ].
	
	stringsForNextArray := Array new: numStringsInNextArray.
	stringCounter := 0.
	nextStringSize := nil. 
	^true! !

!StringSocket methodsFor: 'private-IO' stamp: 'sd 11/20/2005 21:26'!
tryForString
	"try to grab an actual string"

	self inBufSize >= nextStringSize ifFalse: [^false].

	stringsForNextArray 
		at: (stringCounter := stringCounter + 1)
		put: (self inBufNext: nextStringSize) asString.

	stringCounter = numStringsInNextArray ifTrue: [	"we have finished another array!!"
		inObjects addLast: stringsForNextArray.
		stringCounter := stringsForNextArray := numStringsInNextArray := nextStringSize := nil.
	] ifFalse: [	"still need more strings for this array"
		nextStringSize := nil.
	].

	^true
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringSocket class
	instanceVariableNames: ''!

!StringSocket class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
clearRatesSeen
"
StringSocket clearRatesSeen
"
	MaxRatesSeen := nil ! !

!StringSocket class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
compareFiles
"
StringSocket compareFiles
"
	| data1 data2 |

	data1 := (FileStream fileNamed: 'Macintosh HD:bob:nebraska test:58984048.1')
			contentsOfEntireFile.
	data2 := (FileStream fileNamed: 'BobsG3:squeak:dsqueak:DSqueak2.7 folder:58795431.3')
			contentsOfEntireFile.
	1 to: (data1 size min: data2 size) do: [ :i |
		(data1 at: i) = (data2 at: i) ifFalse: [self halt].
	].
! !

!StringSocket class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
showRatesSeen
"
StringSocket showRatesSeen
"
	| answer |

	MaxRatesSeen ifNil: [^Beeper beep].
	answer := WriteStream on: String new.
	MaxRatesSeen keys asSortedCollection do: [ :key |
		answer nextPutAll: key printString,'  ',((MaxRatesSeen at: key) // 10000) printString; cr
	].
	StringHolder new contents: answer contents; openLabel: 'send rates at 10 second intervals'.! !
TestCase subclass: #StringSocketTestCase
	instanceVariableNames: 'socket1 socket2 end1 end2'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Network-ObjectSocket'!

!StringSocketTestCase methodsFor: 'running' stamp: 'sd 11/20/2005 21:26'!
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 := StringSocket on: socket1.
	end2 := StringSocket on: socket2.
	! !

!StringSocketTestCase methodsFor: 'running' stamp: 'ls 8/4/2004 15:22'!
tearDown
	end1 destroy.
	end2 destroy.
	! !

!StringSocketTestCase methodsFor: 'running' stamp: 'ls 8/4/2004 15:21'!
testBasics
	end1 nextPut: #().
	end1 nextPut: #('').
	end1 nextPut: #('hello' 'world').
	end1 processIO.
	
	end2 processIO.

	self should: [ end2 next = #() ].
	self should: [ end2 next = #('') ].
	self should: [ end2 next = #('hello' 'world') ].
	! !

!StringSocketTestCase methodsFor: 'running' stamp: 'sd 11/20/2005 21:26'!
testBogusInput1
	| negString |
	negString := String new: 4.
	negString putInteger32: -10 at: 1.
	socket1 sendData: negString.
	end2 processIO.
	
	self should: [ end2 isConnected not ].
	! !

!StringSocketTestCase methodsFor: 'running' stamp: 'sd 11/20/2005 21:26'!
testBogusInput2
	| bogoString |
	bogoString := String new: 8.
	bogoString putInteger32: 2 at: 1.
	bogoString putInteger32: -10 at: 5.
	socket1 sendData: bogoString.
	end2 processIO.
	
	self should: [ end2 isConnected not ].
	! !
ClassTestCase subclass: #StringTest
	instanceVariableNames: 'string'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!
!StringTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class String. 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!


!StringTest methodsFor: 'initialize-release' stamp: 'md 4/18/2003 10:00'!
setUp
	string := 'Hi, I am a String'! !


!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy01

	| tokens |
	string := 'this, is, "a, test"'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size == 3! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:20'!
testFindTokensEscapedBy02

	| tokens |
	string := ''.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens isEmpty! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy03

	| tokens |
	string := 'this, is, a, test'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size == 4! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy04

	| tokens |
	string := 'this, is, a"," test'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size == 3.
	self assert: tokens third = ' a, test'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'!
testFindTokensEscapedBy05

	| tokens |
	string := 'this, /is, a"," test/'.
	tokens := string findTokens: ',#' escapedBy: '"/'.
	self assert: tokens size = 2.
	self assert: tokens first = 'this'.
	self assert: tokens second = ' is, a"," test'.! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy06

	| tokens |
	string := 'this, is, "a, test'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size == 3.
	self assert: tokens third = ' a, test'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy07

	| tokens |
	string := 'a:b::c'.
	tokens := string findTokens: ':' escapedBy: '"'.
	self assert: tokens size == 4.
	self assert: tokens first = 'a'.
	self assert: tokens second = 'b'.
	self assert: tokens third = ''.
	self assert: tokens fourth = 'c'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy08

	| tokens |
	string := 'this, is, ##a, test'.
	tokens := string findTokens: ',' escapedBy: '#'.
	self assert: tokens size == 4.
	self assert: tokens third = ' a'.
	self assert: tokens fourth = ' test'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy09

	| tokens |
	string := 'this, is, ###a, test#'.
	tokens := string findTokens: ',' escapedBy: '#'.
	self assert: tokens size == 3.
	self assert: tokens third = ' #a, test'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy10

	| tokens |
	string := 'this, is, ###a, test'.
	tokens := string findTokens: ',' escapedBy: '#'.
	self assert: tokens size == 3.
	self assert: tokens third = ' #a, test'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy11

	| tokens |
	string := 'this, is, """a, test"'.
	tokens := string findTokens: ',' escapedBy: '"'.
	self assert: tokens size == 3.
	self assert: tokens third = ' "a, test'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy12

	| tokens |
	string := 'one, two# three; four. five'.
	tokens := string findTokens: ',#;.' escapedBy: '"'.
	self assert: tokens size == 5.
	self assert: tokens third = ' three'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy13

	| tokens |
	string := 'one, two# three; four. five'.
	tokens := string findTokens: ',#;.' escapedBy: nil.
	self assert: tokens size == 5.
	self assert: tokens third = ' three'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy14

	| tokens |
	string := 'one, "two# three"; &four. five&'.
	tokens := string findTokens: ',#;.' escapedBy: '"&'.
	self assert: tokens size == 3.
	self assert: tokens second = ' two# three'.
	self assert: tokens third = ' four. five'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'!
testFindTokensEscapedBy15

	| tokens |
	string := 'one, "two# three"; &four. five&'.
	tokens := string findTokens: nil escapedBy: '"&'.
	self assert: tokens size = 1.
	self assert: tokens first = 'one, two# three; four. five'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'!
testFindTokensEscapedBy16

	| tokens |
	string := 'one, "two# three"; &four. five&'.
	tokens := string findTokens: nil escapedBy: nil.
	self assert: tokens size = 1.
	self assert: tokens first = string! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy21

	| tokens |
	string := 'this, is, "a, test"'.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size == 3! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'!
testFindTokensEscapedBy22

	| tokens |
	string := ''.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size = 0! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy23

	| tokens |
	string := 'this, is, a, test'.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size == 4! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy24

	| tokens |
	string := 'this, is, a"," test'.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size == 3.
	self assert: tokens third = ' a, test'! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'!
testFindTokensEscapedBy25

	| tokens |
	string := 'this, /is, a"," test/'.
	tokens := string findTokens: $, escapedBy: $/.
	self assert: tokens size = 2.
	self assert: tokens first = 'this'.
	self assert: tokens second = ' is, a"," test'.! !

!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'!
testFindTokensEscapedBy26

	| tokens |
	string := 'this, is, "a, test'.
	tokens := string findTokens: $, escapedBy: $".
	self assert: tokens size == 3.
	self assert: tokens third = ' a, test'! !


!StringTest methodsFor: 'tests - accessing' stamp: 'sd 6/5/2005 09:27'!
testAt

	self assert: (string at: 1) = $H.! !


!StringTest methodsFor: 'tests - converting' stamp: 'sd 6/5/2005 09:26'!
testAsInteger

	self assert: '1796exportFixes-tkMX' asInteger = 1796.
	self assert: 'donald' asInteger isNil.
	self assert: 'abc234def567' asInteger = 234.
	self assert: '-94' asInteger = -94.
	self assert: 'foo-bar-92' asInteger = -92! !

!StringTest methodsFor: 'tests - converting' stamp: 'sd 6/5/2005 09:27'!
testAsSmalltalkComment

	| exampleStrings  |
	exampleStrings := #(
		''
		' '
		'"'
		'""'
		'"""'
		'abc"abc'
		'abc""abc'
		'abc"hello"abc'
		'abc"'
		'"abc' ).

	"check that the result of scanning the comment is empty"
	exampleStrings do: [ :s |
		| tokens  |
		tokens :=  Scanner new scanTokens: s asSmalltalkComment.
		self assert: (tokens isEmpty) ].

	"check that the result has the same non-quote characters as the original"
	exampleStrings do: [ :s |
		self assert: ( (s copyWithout: $") = (s asSmalltalkComment copyWithout: $"))].

	"finnaly, test for some common kinds of inputs"
	self assert: ( 'abc' asSmalltalkComment = '"abc"').
	self assert: ( 'abc"abc' asSmalltalkComment = '"abc""abc"').
	self assert: ('abc""abc' asSmalltalkComment = '"abc""abc"' ).
		! !

!StringTest methodsFor: 'tests - converting' stamp: 'sd 6/5/2005 09:27'!
testCapitalized

	| uc lc empty |		
	uc := 'MElViN'.
	lc := 'mElViN'.
	empty := ' '.
	self assert:  lc capitalized = uc.
	self assert: uc capitalized = uc.
	"the string gets copied"
	self deny: uc capitalized == uc.
	self deny: empty capitalized == empty.! !

!StringTest methodsFor: 'tests - converting' stamp: 'ky 7/8/2006 15:28'!
testUnescapePercents
	self assert: '' unescapePercents = ''.
	self assert: 'x' unescapePercents = 'x'.

	self assert: '+' unescapePercents = ' '.
	self assert: 'x+' unescapePercents = 'x '.
	self assert: '+x' unescapePercents = ' x'.
	self assert: 'x+x' unescapePercents = 'x x'.

	self assert: '%' unescapePercents = '%'.
	self assert: '%3' unescapePercents = '%3'.
	self assert: '%3C' unescapePercents = '<'.
	
	self assert: '%3Cx%3E4%3C%2Fx%3E' unescapePercents = '<x>4</x>'.
	
	self assert: '!!@#$%25%5E&*()%7B%7D%5B%5D=:/;?+''%22' unescapePercents  = '!!@#$%^&*(){}[]=:/;? ''"'.
	self assert: '!!%40%23%24%25%5E%26*()%7B%7D%5B%5D%3D%3A%2F%3B%3F%2B''%22' unescapePercents  = '!!@#$%^&*(){}[]=:/;?+''"'.
	self assert: '%21@%23%24%25%5E%26*%28%29%7B%7D%5B%5D%3D%3A/%3B%3F+%27%22' unescapePercents = '!!@#$%^&*(){}[]=:/;? ''"'! !

!StringTest methodsFor: 'tests - converting' stamp: 'ky 7/8/2006 18:01'!
testUnescapePercentsWithTextEncoding
	| leading kataTe kataSu kataTo |
	leading := JapaneseEnvironment leadingChar.
	"Katakana letter Te"
	kataTe := (Character leadingChar: leading code: 12486) asString.
	"Katakana letter Su"
	kataSu := (Character leadingChar: leading code: 12473) asString.
	"Katakana letter To"
	kataTo := (Character leadingChar: leading code: 12488) asString.
	self assert: ('%83e%83X%83g' unescapePercentsWithTextEncoding: 'shift_jis')
			= (kataTe , kataSu , kataTo).
	self assert: ('%83e%83X%83g%20and%20%83e%83X%83g' unescapePercentsWithTextEncoding: 'shift_jis')
			= (kataTe , kataSu , kataTo , ' and ' , kataTe , kataSu , kataTo)! !

!StringTest methodsFor: 'tests - converting' stamp: 'sd 6/5/2005 09:27'!
testWithFirstCharacterDownshifted

	| uc lc empty |		
	uc := 'MElViN'.
	lc := 'mElViN'.
	empty := ' '.
	self assert:  uc withFirstCharacterDownshifted = lc.
	self assert: lc withFirstCharacterDownshifted = lc.
	"the string gets copied"
	self deny: lc withFirstCharacterDownshifted == lc.
	self deny: empty withFirstCharacterDownshifted == empty.! !


!StringTest methodsFor: 'as yet unclassified' stamp: 'md 3/16/2006 22:12'!
testEquality

	self assert: 'abc' = 'abc' asWideString.
	self assert: 'abc' asWideString = 'abc'.
	self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString ~= 'a000' asWideString).
	self assert: ('a000' asWideString ~= (ByteArray with: 97 with: 0 with: 0 with: 0) asString).

	self assert: ('abc' sameAs: 'aBc' asWideString).
	self assert: ('aBc' asWideString sameAs: 'abc').
	self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString 
						sameAs: 'Abcd' asWideString) not.
	self assert: ('a000' asWideString sameAs: 
					(ByteArray with: 97 with: 0 with: 0 with: 0) asString) not.! !


!StringTest methodsFor: 'test-comparing' stamp: 'lr 7/7/2006 11:32'!
testComparing
	self assert: 'foo' < 'foo:'.
	self assert: 'foo' < 'fooBar'.
	self assert: 'foo' <= 'foo:'.
	self assert: 'foo' <= 'fooBar'.
	self assert: 'foo:' > 'foo'.
	self assert: 'fooBar' > 'foo'.
	self assert: 'foo:' >= 'foo'.
	self assert: 'fooBar' >= 'foo'! !


!StringTest methodsFor: 'testing - converting' stamp: 'KR 06/24/2005 11:21'!
testPercentEncodingJa
	| leading hiraA hiraO hiraAO encodedHiraA encodedHiraO encodedHiraAO |

    "Make Japanese String from unicode. see http://www.unicode.org/charts/PDF/U3040.pdf"
     leading _ JapaneseEnvironment leadingChar.
	hiraA _ (Character leadingChar: leading code: 16r3042) asString.  "HIRAGANA LETTER A"
	hiraO _ (Character leadingChar: leading code: 16r304A) asString.  "HIRAGANA LETTER O"
	hiraAO _ hiraA, hiraO.

	"Percent Encoded Japanese String"
	encodedHiraA _ hiraA encodeForHTTP.
	self assert: encodedHiraA = '%E3%81%82'.
	encodedHiraO _ hiraO encodeForHTTP.
	self assert: encodedHiraO = '%E3%81%8A'.
	encodedHiraAO _ hiraAO encodeForHTTP.
	self assert: encodedHiraAO =  '%E3%81%82%E3%81%8A'.

     "without percent encoded string"
	self assert: '' unescapePercents = ''.
	self assert: 'abc' unescapePercents = 'abc'.	"latin1 character"
	self assert: hiraAO unescapePercents = hiraAO.  "multibyte character"

	"encoded latin1 string"
	self assert: '%61' unescapePercents = 'a'.
	self assert: '%61%62%63' unescapePercents = 'abc'.

	"encoded multibyte string"
	Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ 
		self assert: encodedHiraA unescapePercents = hiraA.
		self assert: encodedHiraAO unescapePercents = hiraAO].

	"mixed string"
	Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ 
		self assert: (encodedHiraAO,'a') unescapePercents = (hiraAO, 'a').
		self assert: ('a', encodedHiraA) unescapePercents = ('a', hiraA).
		self assert: ('a', encodedHiraA, 'b')  unescapePercents = ('a', hiraA, 'b').
		self assert: ('a', encodedHiraA, 'b', encodedHiraO) unescapePercents = ('a', hiraA, 'b', hiraO).
		self assert: (encodedHiraA, encodedHiraO, 'b', encodedHiraA) unescapePercents = (hiraA, hiraO, 'b', hiraA)].


	"for Seaside"
	Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ 
		self assert: (encodedHiraA, '+', encodedHiraO) unescapePercents = (hiraA, ' ', hiraO)].

! !


!StringTest methodsFor: 'tests - indexOf' stamp: 'nice 5/9/2006 23:55'!
testIndexOf
	
	"test for http://bugs.impara.de/view.php?id=3574"
	self assert: ('abc-' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 4.
	self assert: ('ab7' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 3.
	self assert: ('a2c' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 2.
	self assert: ('3bc' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 1.
	self assert: ('abc' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 0.
	
	"extension to wide characters"
	self assert: ((String with: 803 asCharacter with: 811 asCharacter) indexOfAnyOf: (CharacterSet newFrom: (String with: 811 asCharacter with: 812 asCharacter))) = 2.
	
	self assert: ('abc' indexOfAnyOf: (CharacterSet newFrom: (String with: 811 asCharacter with: 812 asCharacter))) = 0.
	
	self assert: ('abc' indexOfAnyOf: (CharacterSet newFrom: (String with: 811 asCharacter with: $c))) = 3.! !
DataType subclass: #StringType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!

!StringType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:29'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ 'abc'! !


!StringType methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	| aMethodCategory aMethodInterface |
	super initialize.
	self vocabularyName: #String.

#((accessing 			'The basic info'
		(at: at:put: size endsWithDigit findString: findTokens: includesSubString: indexOf: indexOf:startingAt: indexOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: startsWithDigit numArgs))
(#'more accessing' 		'More basic info'
		(allButFirst allButFirst: allButLast allButLast: at:ifAbsent: atAllPut: atPin: atRandom: atWrap: atWrap:put: fifth first first: fourth from:to:put: last last: lastIndexOf: lastIndexOf:ifAbsent: middle replaceAll:with: replaceFrom:to:with: replaceFrom:to:with:startingAt: second sixth third))
(comparing				'Determining which comes first alphabeticly'
		(< <= = > >= beginsWith: endsWith: endsWithAnyOf: howManyMatch: match:))
(testing 				'Testing'
		(includes: isEmpty ifNil: ifNotNil: isAllDigits isAllSeparators isString lastSpacePosition))
(converting 			'Converting it to another form'
		(asCharacter asDate asInteger asLowercase asNumber asString asStringOrText asSymbol asText asTime asUppercase asUrl capitalized keywords numericSuffix romanNumber reversed splitInteger surroundedBySingleQuotes withBlanksTrimmed withSeparatorsCompacted withoutTrailingBlanks withoutTrailingDigits asSortedCollection))
(copying 				'Make another one like me'
		(copy copyFrom:to: copyUpTo: copyUpToLast: shuffled))
(enumerating		'Passing over the letters'
		(collect: collectWithIndex: do: from:to:do: reverseDo: select: withIndexDo: detect: detect:ifNone:))
) do: [:item | 
			aMethodCategory := ElementCategory new categoryName: item first.
			aMethodCategory documentation: item second.
			item third do:
				[:aSelector | 
					aMethodInterface := MethodInterface new initializeFor: aSelector.
					self atKey: aSelector putMethodInterface: aMethodInterface.
					aMethodCategory elementAt: aSelector put: aMethodInterface].
			self addCategory: aMethodCategory].
! !


!StringType methodsFor: '*eToys-color' stamp: 'sw 9/27/2001 17:21'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(0.0 0.0 1.0)	! !


!StringType methodsFor: '*eToys-tiles' stamp: 'yo 3/14/2005 21:27'!
defaultArgumentTile
        "Answer a tile to represent the type"

        ^ 'abc' translated newTileMorphRepresentative typeColor: self typeColor! !

!StringType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:33'!
setFormatForDisplayer: aDisplayer
	"Set up the displayer to have the right format characteristics"

	aDisplayer useStringFormat
	! !

!StringType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:33'!
wantsArrowsOnTiles
	"Answer whether this data type wants up/down arrows on tiles representing its values"

	^ false! !
Morph subclass: #SubpaneDividerMorph
	instanceVariableNames: 'resizingEdge'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!SubpaneDividerMorph commentStamp: '<historical>' prior: 0!
A morph which presents a visible separator between subpanes of a SystemWindow which have zero edgeWidth.  Subpanes are submorphs of a SystemWindow's paneMorphs.

A SubpaneDividerMorph may also initiate reframe handles for the subpanes.  For resizing, it is expected that the main paneMorph has a ProportionalLayout LayoutPolicy, and that the subpanes to be resized have LayoutFrames with equal topFractions and bottomFractions, but different topOffsets and bottomOffsets.  It is the offsets that are changed, and the change is propagated through sibling morphs up to the first resizable morph (with different nominal frame fractions).

The direction of propagation is determined by the value of resizingEdge, which is one of: nil (for non-adjustible subpane divisions), #bottom or #top (which acts a though the divider is the corresponding edge of the subpane directly above or below it).  Does not currently support #left or #right binding, or subpanes in a TableLayout.
!


!SubpaneDividerMorph methodsFor: 'accessing' stamp: 'sw 5/18/2001 11:27'!
borderColor
	"I behave like a border for the purpose of browser beautifying, so I obey this protocol, to advantage"

	^ self color! !

!SubpaneDividerMorph methodsFor: 'accessing' stamp: 'sw 5/18/2001 11:26'!
borderColor: aColor
	"I behave like a border for the purpose of browser beautifying, so I obey this protocol, to advantage"

	self color: aColor! !

!SubpaneDividerMorph methodsFor: 'accessing' stamp: 'JW 2/3/2001 09:39'!
resizingEdge

	^resizingEdge
! !


!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:53'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color black! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:26'!
firstEnter: evt
	"The first time this divider is activated, find its window and redirect further interaction there."
	| window |

	window := self firstOwnerSuchThat: [:m | m respondsTo: #secondaryPaneTransition:divider:].
	window ifNil: [ self suspendEventHandler. ^ self ]. "not working out"
	window secondaryPaneTransition: evt divider: self.
	self on: #mouseEnter send: #secondaryPaneTransition:divider: to: window.
! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:07'!
horizontal

	self hResizing: #spaceFill.! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:53'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: 1 @ 1! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:12'!
resizingEdge: edgeSymbol

	(#(top bottom) includes: edgeSymbol) ifFalse:
		[ self error: 'resizingEdge must be #top or #bottom' ].
	resizingEdge := edgeSymbol.
	self on: #mouseEnter send: #firstEnter: to: self.
! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:07'!
vertical

	self vResizing: #spaceFill.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SubpaneDividerMorph class
	instanceVariableNames: ''!

!SubpaneDividerMorph class methodsFor: 'instance creation' stamp: 'JW 2/3/2001 09:35'!
forBottomEdge
	^self new horizontal resizingEdge: #bottom! !

!SubpaneDividerMorph class methodsFor: 'instance creation' stamp: 'JW 2/3/2001 09:35'!
forTopEdge
	^self new horizontal resizingEdge: #top! !

!SubpaneDividerMorph class methodsFor: 'instance creation' stamp: 'JW 2/3/2001 09:31'!
horizontal
	^self new horizontal! !

!SubpaneDividerMorph class methodsFor: 'instance creation' stamp: 'JW 2/3/2001 09:31'!
vertical
	^self new vertical! !
Object subclass: #SunAudioFileWriter
	instanceVariableNames: 'stream headerStart'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SunAudioFileWriter commentStamp: '<historical>' prior: 0!
I encode monophonic sampled sounds in Sun audio (.au) file format. Sun audio files have a very simple format but can store both compressed and uncompressed sample data. I can write this format either directly into a file or onto any writable binary stream.
!


!SunAudioFileWriter methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
setStream: aBinaryStream
	"Initialize myself for writing on the given stream."

	stream := aBinaryStream.
	headerStart := aBinaryStream position.
! !


!SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 18:02'!
appendBytes: aByteArray
	"Append the given sample data to my stream."

	stream nextPutAll: aByteArray.
! !

!SunAudioFileWriter methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
appendSamples: aSoundBuffer
	"Append the given SoundBuffer to my stream."

	| swapBytes s |
	(stream isKindOf: StandardFileStream) ifTrue: [
		"optimization: write sound buffer directly to file"
		swapBytes := SmalltalkImage current  isLittleEndian.
		swapBytes ifTrue: [aSoundBuffer reverseEndianness].  "make big endian"
		stream next: (aSoundBuffer size // 2) putAll: aSoundBuffer startingAt: 1.  "size in words"
		swapBytes ifTrue: [aSoundBuffer reverseEndianness].  "revert to little endian"
		^ self].

	"for non-file streams:"
	s := WriteStream on: (ByteArray new: 2 * aSoundBuffer monoSampleCount).
	1 to: aSoundBuffer monoSampleCount do: [:i | s int16: (aSoundBuffer at: i)].
	self appendBytes: s contents.
! !

!SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 22:09'!
closeFile
	"Update the Sun audio file header to reflect the final size of the sound data. If my stream is a file stream, close it and, on a Macintosh, set the file type and creator to that used by SoundApp for Sun Audio files. (This does nothing on other platforms.)"

	self ensureOpen.
	self updateHeaderDataSize.
	(stream isKindOf: StandardFileStream) ifTrue: [
		stream close.
		FileDirectory default setMacFileNamed: stream name type: 'ULAW' creator: 'SCPL'].
! !

!SunAudioFileWriter methodsFor: 'other' stamp: 'sd 1/30/2004 15:23'!
ensureOpen
	"Ensure that my stream is open."

	stream closed ifTrue: [stream reopen; binary].
! !

!SunAudioFileWriter methodsFor: 'other' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateHeaderDataSize
	"Update the Sun audio file header to reflect the final size of the sound data."

	| byteCount |
	byteCount := stream position - (headerStart + 24).
	stream position: headerStart + 8.
	stream uint32: byteCount.
! !

!SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 17:55'!
writeHeaderSamplingRate: samplingRate
	"Write a Sun audio file header for 16-bit linear format."

	self writeHeaderSamplingRate: samplingRate format: 3.
! !

!SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 22:10'!
writeHeaderSamplingRate: samplingRate format: audioFormat
	"Write a Sun audio file header for the given sampling rate and format. Currently, only monophonic files are supported."

	self ensureOpen.
	stream position: headerStart.
	stream nextPutAll: '.snd' asByteArray.
	stream uint32: 24.	"header size in bytes"
	stream uint32: 0.	"sample data size in bytes; fill in later"
	stream uint32: audioFormat.
	stream uint32: samplingRate truncated.
	stream uint32: 1.	"channel count"
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SunAudioFileWriter class
	instanceVariableNames: ''!

!SunAudioFileWriter class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:41'!
onFileNamed: fileName
	"Answer an instance of me on a newly created file with the given name."

	| file |
	file := (FileStream newFileNamed: fileName) binary.
	^ self new setStream: file
! !

!SunAudioFileWriter class methodsFor: 'instance creation' stamp: 'jm 11/16/2001 17:50'!
onStream: aBinaryStream
	"Answer an instance of me on the given binary stream."

	^ self new setStream: aBinaryStream
! !


!SunAudioFileWriter class methodsFor: 'sound storing' stamp: 'jm 11/21/2001 15:42'!
codecForFormatCode: formatCode
	"Answer the codec for the given Sun audio file format number."

	formatCode = 1 ifTrue: [^ MuLawCodec new].
	formatCode = 3 ifTrue: [^ nil].  "uncompressed"
	formatCode = 23 ifTrue: [^ ADPCMCodec newBitsPerSample: 4].
	formatCode = 25 ifTrue: [^ ADPCMCodec newBitsPerSample: 3].
	formatCode = 26 ifTrue: [^ ADPCMCodec newBitsPerSample: 5].
	formatCode = 610 ifTrue: [^ GSMCodec new].
	self error: 'unsupported Sun audio format'
! !

!SunAudioFileWriter class methodsFor: 'sound storing' stamp: 'stephaneducasse 2/4/2006 20:41'!
formatCodeForCompressionType: aString
	"Answer the Sun audio file format number for the given compression type name."

	| lowercase |
	lowercase := aString asLowercase.
	'mulaw' = lowercase ifTrue: [^ 1].
	'none' = lowercase ifTrue: [^ 3].
	'adpcm3' = lowercase ifTrue: [^ 25].
	'adpcm4' = lowercase ifTrue: [^ 23].
	'adpcm5' = lowercase ifTrue: [^ 26].
	'gsm' = lowercase ifTrue: [^ 610].
	self error: 'unknown compression style'
! !

!SunAudioFileWriter class methodsFor: 'sound storing' stamp: 'stephaneducasse 2/4/2006 20:41'!
storeSampledSound: aSampledSound onFileNamed: fileName compressionType: aString
	"Store the samples of the given sampled sound on a file with the given name using the given type of compression. See formatCodeForCompressionType: for the list of compression types."

	| fmt codec f compressed |
	fmt := self formatCodeForCompressionType: aString.
	codec := self codecForFormatCode: fmt.
	f := self onFileNamed: fileName.
	f writeHeaderSamplingRate: aSampledSound originalSamplingRate format: fmt.
	codec
		ifNil: [f appendSamples: aSampledSound samples]
		ifNotNil: [
			compressed := codec encodeSoundBuffer: aSampledSound samples.
			f appendBytes: compressed].
	f closeFile.
! !
FileDirectoryWrapper subclass: #SuperSwikiDirectoryWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!
!SuperSwikiDirectoryWrapper commentStamp: '<historical>' prior: 0!
The super swiki does not at present have subdirectories!


!SuperSwikiDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 2/2/2001 08:28'!
contents

	^#()		"we have no sundirectories"! !

!SuperSwikiDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 2/2/2001 08:28'!
hasContents

	^false		"we have no sundirectories"! !
ProjectSwikiServer subclass: #SuperSwikiServer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RemoteDirectory'!

!SuperSwikiServer methodsFor: 'accessing' stamp: 'KR 2/1/2006 13:07'!
encodingName
	(super encodingName) ifNil: [ ^SuperSwikiServer defaultEncodingName ] ifNotNil: [^super encodingName].! !

!SuperSwikiServer methodsFor: 'accessing' stamp: 'mir 6/25/2001 17:17'!
typeForPrefs

	^'bss'! !


!SuperSwikiServer methodsFor: 'for real' stamp: 'mir 8/23/2001 22:15'!
allEntries

	| answer |

	answer _ self sendToSwikiProjectServer: {
		'action: listallprojects'.
	}.
	(answer beginsWith: 'OK') ifFalse: [^#()].
	^self parseListEntries: answer! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'ar 3/2/2001 14:36'!
directoryNames

	^self entries select:[:each| each isDirectory] thenCollect: [ :each | each name]! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 2/2/2001 08:29'!
directoryWrapperClass

	^SuperSwikiDirectoryWrapper! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'mir 8/23/2001 22:16'!
entries

	^self allEntries! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'KR 1/30/2006 21:59'!
fastParseEntriesFrom: aString

	| c first strm xEntryName xCreationTime xModificationTime xIsDirectory xFileSize ch |

	c _ OrderedCollection new.
	first _ true.
	aString linesDo: [ :x |
		first ifFalse: [
			strm _ ReadStream on: x.
			(strm upTo: $ ) = '(DirectoryEntry' ifFalse: [^nil].
			(strm upTo: $ ) = 'name:' ifFalse: [^nil].
			xEntryName _ WriteStream on: String new.
			strm next = $' ifFalse: [^nil].
			[
				ch _ strm next.
				ch = $' and: [(strm peekFor: $') not]
			] whileFalse: [
				xEntryName nextPut: ch.
			].
			xEntryName _ xEntryName contents.
			strm skipSeparators.
			(strm upTo: $ ) = 'creationTime:' ifFalse: [^nil].
			xCreationTime _ (strm upTo: $ ) asNumber.
			(strm upTo: $ ) = 'modificationTime:' ifFalse: [^nil].
			xModificationTime _ (strm upTo: $ ) asNumber.
			(strm upTo: $ ) = 'isDirectory:' ifFalse: [^nil].
			xIsDirectory _ (strm upTo: $ ) = 'true'.
			(strm upTo: $ ) = 'fileSize:' ifFalse: [^nil].
			xFileSize _ (strm upTo: $ ) asNumber.

			c add: (DirectoryEntry 
				name: (xEntryName convertFromEncoding: self encodingName)
				creationTime: xCreationTime 
				modificationTime: xModificationTime 
				isDirectory: xIsDirectory 
				fileSize: xFileSize
			)
		].
		first _ false.
	].
	^c
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'ar 3/2/2001 14:36'!
fileNames

	^self entries select:[:each| each isDirectory not] thenCollect: [ :each | each name]! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/17/2000 12:49'!
getOnly: numberOfBytes from: aName

	| answer |

	answer _ self sendToSwikiProjectServer: {
		'action: readnamedfile'.
		'projectname: ',aName.
		'bytestoread: ',numberOfBytes printString.
	}.
	(answer beginsWith: 'OK') ifFalse: [ ^nil].
	^answer allButFirst: 3
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'md 11/14/2003 17:28'!
matchingEntries: criteria
	| result |
	eToyUserListUrl ifNil:[^self entries].
	result _ self sendToSwikiProjectServer: {
		'action: listmatchingprojects'.
	}  , criteria.
	(result beginsWith: 'OK')
		ifFalse: [^self entries]. "If command not supported"
	^self parseListEntries: result! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'KR 1/30/2006 22:02'!
oldFileNamed: aName

	| answer |

	answer _ self sendToSwikiProjectServer: {
		'action: readnamedfile'.
		'projectname: ',aName convertToEncoding: self encodingName.
	}.
	(answer beginsWith: 'OK') ifFalse: [ ^nil].
	^(SwikiPseudoFileStream with: (answer allButFirst: 3))
		reset;
		directory: self;
		localName: (aName convertToEncoding: self encodingName);
		yourself
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/17/2000 14:54'!
oldFileOrNoneNamed: fullName

	| answer aName |

	self flag: #bob.		"fix this up for full names"

	aName _ fullName.
	answer _ self sendToSwikiProjectServer: {
		'action: readnamedfile'.
		'projectname: ',(self localNameFor: aName).
	}.
	(answer beginsWith: 'OK') ifFalse: [^nil].
	^(SwikiPseudoFileStream with: (answer allButFirst: 3))
		reset;
		directory: self;
		localName: aName;
		yourself
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'KR 1/30/2006 21:57'!
putFile: fileStream named: fileNameOnServer

	
	^(
		self sendToSwikiProjectServer: {
			'uploadproject: ',fileNameOnServer convertToEncoding: self encodingName.
			'password: ',ProjectPasswordNotification signal.
			fileStream contentsOfEntireFile.
		}
	) beginsWith: 'OK'
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/13/2000 16:53'!
readOnlyFileNamed: aName

	^self oldFileNamed: aName
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 2/16/2001 18:22'!
sendToSwikiProjectServer: anArray

	| argsDict answer buildStream |

	buildStream _ WriteStream on: String new.
	anArray do: [ :each | 
		buildStream 
			nextPutAll: each size printString;
			space;
			nextPutAll: each
	].
	(argsDict _ Dictionary new)
		at: 'swikicommands'
		put: {buildStream contents}.
	answer _ HTTPSocket 
		httpPostToSuperSwiki: self url
		args: argsDict
		accept: 'application/octet-stream' 
		request: ''.
	^(answer isKindOf: MIMEDocument) ifTrue: [answer content] ifFalse: [answer]
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'KR 2/20/2006 12:50'!
updateProjectInfoFor: aProject

	| data details projectLinks linkString uploader |

	data _ OrderedCollection new.
	data add: 'action: updatepage'.
	data add: 'password: ',ProjectPasswordNotification signal.
	data add: 'projectimage: ', (aProject name convertToEncoding: self encodingName) , '.gif'.
	uploader _ Utilities authorNamePerSe.
	uploader isEmptyOrNil ifTrue: [uploader _ Utilities authorInitialsPerSe].
	uploader isEmptyOrNil ifFalse: [
		data add: ('submittedBy: ',uploader convertToEncoding: self encodingName).
	].
	projectLinks _ Set new.
	aProject world allMorphsDo: [ :each |
		(each isKindOf: ProjectViewMorph) ifTrue: [
			projectLinks add: each safeProjectName.
		].
	].
	details _ aProject world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new].
	details at: 'projectname' ifAbsentPut: [aProject name].
	projectLinks isEmpty ifTrue: [
		details removeKey: 'projectlinks' ifAbsent: []
	] ifFalse: [
		linkString _ String streamContents: [ :strm |
			projectLinks asSortedCollection do: [ :each |
				strm nextPutAll: each
			] separatedBy: [
				strm nextPut: $.
			].
		].
		details at: 'projectlinks' put: linkString
	].
	details keysAndValuesDo: [ :k :v |
		data add: k , ': ' , (v convertToEncoding: self encodingName). self flag: #yoFlag.
	].
	^self sendToSwikiProjectServer: data! !



!SuperSwikiServer methodsFor: 'squeaklets' stamp: 'KR 1/30/2006 22:15'!
upLoadProject: projectName members: archiveMembers retry: aBool
	| answer |
	archiveMembers do:[:entry|
		ProgressNotification signal: '4:uploadingFile' extra:'(uploading ' translated, entry fileName convertFromSystemString , '...)' translated.
		answer _ self sendToSwikiProjectServer: {
			'uploadproject2: ', entry fileName convertFromSystemString convertToEncoding: self encodingName.
			'password: ',ProjectPasswordNotification signal.
			entry contents.
		}.
		answer = 'OK' ifFalse:[
			self inform:'Server responded ' translated, answer.
			^false].
	].
	ProgressNotification signal: '4:uploadingFile' extra:''.
	^true! !


!SuperSwikiServer methodsFor: 'testing' stamp: 'mir 11/14/2001 16:25'!
isSearchable
	^true! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'ar 8/24/2001 15:12'!
parseQueryResult: resultStream

	| projectInfos projectName  downloadUrl |
	projectInfos _ OrderedCollection new.
	downloadUrl _ self downloadUrl.
	resultStream reset; nextLine.
	[resultStream atEnd] whileFalse: [
		projectName _ resultStream nextLine.
		projectInfos add: projectName.
		"Transcript show: projectName; cr."
		].
	"Transcript show: 'done'; cr."
	^projectInfos
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/17/2000 16:10'!
queryAllProjects

"answer a collection of DirectoryEntry objects for each file on server"

"SuperSwikiServer testOnlySuperSwiki queryAllProjects"

	^self sendToSwikiProjectServer: {
		'action: listallprojects'.
	}! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'md 11/14/2003 17:28'!
queryProjects: criteria
	| result |
	"SuperSwikiServer defaultSuperSwiki queryProjects: #('submittedBy: mir' )"
	result _ self sendToSwikiProjectServer: {
		'action: findproject'.
	}  , criteria.
	(result beginsWith: 'OK') ifFalse: [^self inform: result printString].
	^self parseQueryResult: (ReadStream on: result).
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/17/2000 19:23'!
queryProjectsAndShow
	| result |
"SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow"

	result _ self sendToSwikiProjectServer: {
		'action: findproject'.
		"'projectname: *proj*'."
	}.
	(result beginsWith: 'OK') ifFalse: [^self inform: result printString].
	self showQueryAsPVM: (ReadStream on: result).
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/18/2000 12:23'!
queryProjectsAndShow: thingsToSearchFor
	| result |
"SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow"

	result _ self sendToSwikiProjectServer: {
		'action: findproject'.
	}, thingsToSearchFor.
	(result beginsWith: 'OK') ifFalse: [^self inform: result printString].
	self showQueryAsPVM: (ReadStream on: result).
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/12/2000 17:01'!
queryPythagoras
"SuperSwikiServer testOnlySuperSwiki queryPythagoras"

	^self sendToSwikiProjectServer: {
		'action: findproject'.
		'projectsubcategory: *geometry*'.
		"'projectname: *pythagoras*'."
	}! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'KR 1/30/2006 21:59'!
showQueryAsPVM: resultStream
	| answer gif whatToShow projectName fileName firstURL wrapper currX currY maxX maxY rawProjectName |
"SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow"

	resultStream reset; nextLine.
	answer _ RectangleMorph new
		useRoundedCorners;
		borderWidth: 0;
		borderColor: Color blue;
		color: Color paleBlue.
	currX _ currY _ maxX _ maxY _ 10.
	[resultStream atEnd] whileFalse: [
		rawProjectName _ resultStream nextLine.
		projectName _ rawProjectName convertFromEncoding: self encodingName.
		fileName _ resultStream nextLine convertFromEncoding: self encodingName.
		gif _ self oldFileOrNoneNamed: rawProjectName,'.gif'.
		gif ifNotNil: [gif _ GIFReadWriter formFromStream: gif].
		currX > 600 ifTrue: [
			currX _ 10.
			currY _ maxY + 10.
		].
		gif ifNil: [
			gif _ AlignmentMorph newColumn
				hResizing: #shrinkWrap;
				vResizing: #shrinkWrap;
				borderWidth: 8;
				borderColor: Color red;
				color: Color lightRed;
				addMorph: (StringMorph contents: 'No GIF for ',projectName);
				fullBounds;
				imageForm
		].
		firstURL _ self url.
		firstURL last == $/ ifFalse: [firstURL _ firstURL, '/'].

		whatToShow _ ProjectViewMorph new
			image: (gif asFormOfDepth: Display depth);
			lastProjectThumbnail: gif;
			setProperty: #SafeProjectName toValue: projectName;
			project: (DiskProxy 
				global: #Project 
				selector: #namedUrl: 
				args: {firstURL,fileName}
			).

		answer addMorphBack: (whatToShow position: currX @ currY).
		currX _ currX + whatToShow width + 10.
		maxX _ maxX max: currX.
		maxY _ maxY max: currY + whatToShow height.
	].
	maxX = 10 ifTrue: [
		^self inform: 'No projects found for your criteria'
	].
	answer extent: (maxX @ maxY) + (0@10).
	wrapper _ ScrollPane new extent: (answer width + 10) @ (answer height min: 400).
	wrapper color: Color white.
	wrapper scroller addMorph: answer.
	wrapper 
		becomeModal;
		openCenteredInWorld;
		useRoundedCorners;
		setScrollDeltas.! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/25/2000 12:14'!
speedTest1

"SuperSwikiServer testOnlySuperSwiki speedTest1"

	| answer t totalTime |

	totalTime _ [
		answer _ (1 to: 10) collect: [ :x |
			t _ [answer _ self sendToSwikiProjectServer: {
				'action: readnamedfile'.
				'projectname: xyz.002.pr'.
			}] timeToRun.
			{t. answer size}
		].
	] timeToRun.
	^{totalTime. answer}
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'ar 7/8/2001 17:06'!
speedTest2

"SuperSwikiServer testOnlySuperSwiki speedTest2"

"==observed results
10 forks of 10 reads of 88K in 12.7 seconds
100 * 88110 / 12.7 ===> 693779 bytes per second
---
10 forks of 10 reads of 88K in 10.7 seconds
100 * 88110 / 10.7 ===> 823457 bytes per second
---at priority 5
10 forks of 10 reads of 88K in 9.8 seconds
100 * 88110 / 9.8 ===> 899081 bytes per second
==="

	| answer bigAnswer tRealBegin tRealEnd |

	bigAnswer _ SharedQueue new.
	tRealBegin _ tRealEnd _ Time millisecondClockValue.
	10 timesRepeat: [
		[
			answer _ SuperSwikiServer testOnlySuperSwiki speedTest1.
			tRealEnd _ Time millisecondClockValue.
			bigAnswer nextPut: {
				{tRealBegin. tRealEnd. tRealEnd - tRealBegin}.
				answer
			}.
		] forkAt: Processor userInterruptPriority.
	].
	bigAnswer inspect.
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/7/2000 16:12'!
test1

	| localDirectory localFileName local resp |

	localDirectory _ FileDirectory default.
	localFileName _ 'superTest1.07Oct1611.cs'.
	local _ localDirectory oldFileNamed: localFileName.
	resp _ self putFile: local named: localFileName retry: false.
	local close.
	^resp
! !


!SuperSwikiServer methodsFor: 'private' stamp: 'mir 8/23/2001 22:04'!
parseListEntries: listResult

	| c first |
	c _ self fastParseEntriesFrom: listResult.
	c ifNotNil: [^c].
	c _ OrderedCollection new.
	first _ true.
	listResult linesDo: [ :x |
		first ifFalse: [c add: (Compiler evaluate: x)].
		first _ false.
	].
	^c
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SuperSwikiServer class
	instanceVariableNames: ''!

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'RAA 10/7/2000 17:47'!
currentSuperSwiki

	"make this return nil to disable SuperSwiki hack"

	^self defaultSuperSwiki

! !

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'KR 2/1/2006 13:18'!
defaultEncodingName
	Locale current isoLanguage = 'ja' ifTrue: [^'shift_jis' copy] ifFalse: [^'latin1' copy].
! !

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 19:11'!
defaultSuperSwiki

	^SuperSwikiServer new 
		type: #http;
		server: self defaultSuperSwikiIPAddress;
		directory: '/super/SuperSwikiProj'
	
! !

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'RAA 10/19/2000 11:05'!
defaultSuperSwikiIPAddress

	^'209.143.91.36'
! !

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 19:11'!
testOnlySuperSwiki

	^SuperSwikiServer new 
		type: #http;
		server: self defaultSuperSwikiIPAddress;
		directory: '/super/SuperSwikiProj'
	
! !
RWBinaryOrTextStream subclass: #SwikiPseudoFileStream
	instanceVariableNames: 'directoryUrl localName directory'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RemoteDirectory'!

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:53'!
directory

	^directory url! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:53'!
directory: x

	directory _ x! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 15:00'!
directoryObject

	^directory! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 15:00'!
directoryUrl

	^directory url! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'!
directoryUrl: x

	directoryUrl _ x! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 13:59'!
fileName

	^localName! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:01'!
isTypeHTTP

	^true! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'!
localName

	^localName! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'!
localName: x

	localName _ x! !
Model subclass: #Switch
	instanceVariableNames: 'on onAction offAction'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Menus'!
!Switch commentStamp: '<historical>' prior: 0!
I represent a selection setting and actions to take depending on a change in the setting. An instance has three attributes: state, which is either on or off; on action; and off action. The on and off actions are blocks of code that execute whenever the instance changes state. I am typically used as a menu item in conjunction with a SwitchView and a SwitchController.
1/24/96 sw: made this a subclass of Model, for faster dependents handling!


!Switch methodsFor: 'action'!
doAction: anAction 
	"Execute anAction if it is non-nil."

	anAction == nil ifFalse: [anAction value]! !

!Switch methodsFor: 'action'!
offAction: anAction 
	"Set the off action of the receiver to anAction."

	offAction _ anAction fixTemps! !

!Switch methodsFor: 'action'!
onAction: anAction 
	"Set the on action of the receiver to anAction."

	onAction _ anAction fixTemps! !


!Switch methodsFor: 'converting' stamp: 'md 9/18/2004 19:51'!
printOn: aStream
	self isOn
		ifTrue: [aStream nextPutAll: 'ON-Switch']
		ifFalse: [aStream nextPutAll: 'OFF-Switch']! !


!Switch methodsFor: 'state'!
clear
	"Set the state of the receiver to 'off'. If the state of the receiver was 
	previously 'on', then 'self change' is sent. The receiver's off action is 
	NOT executed."

	self isOn
		ifTrue: 
			[on _ false.
			self changed]! !

!Switch methodsFor: 'state'!
isOff
	"Answer whether the receiver is set off or not."

	^on not! !

!Switch methodsFor: 'state'!
isOn
	"Answer whether the receiver is set on or not."

	^on! !

!Switch methodsFor: 'state'!
set
	"Set the state of the receiver to 'on'. If the state of the receiver was 
	previously 'off', then 'self change' is sent. The receiver's on action is 
	NOT executed."

	self isOff
		ifTrue: 
			[on _ true.
			self changed]! !

!Switch methodsFor: 'state'!
switch
	"Change the state of the receiver from 'on' to 'off' or from 'off' to 'on' (see 
	Switch|turnOn, Switch|turnOff)."

	self isOn
		ifTrue: [self turnOff]
		ifFalse: [self turnOn]! !

!Switch methodsFor: 'state'!
turnOff
	"Set the state of the receiver to 'off'. If the state of the receiver was 
	previously 'on', then 'self change' is sent and the receiver's off action is 
	executed."

	self isOn
		ifTrue: 
			[on _ false.
			self changed.
			self doAction: offAction]! !

!Switch methodsFor: 'state'!
turnOn
	"Set the state of the receiver to 'on'. If the state of the receiver was 
	previously 'off', then 'self change' is sent and the receiver's on action is 
	executed."

	self isOff
		ifTrue: 
			[on _ true.
			self changed.
			self doAction: onAction]! !


!Switch methodsFor: 'private'!
initializeOff

	on _ false. 
	onAction _ nil.
	offAction _ nil! !

!Switch methodsFor: 'private'!
initializeOn

	on _ true. 
	onAction _ nil.
	offAction _ nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Switch class
	instanceVariableNames: ''!

!Switch class methodsFor: 'instance creation'!
new
	"Answer an instance of me such that the on and off actions are set to nil
	('no action'), and the state is set to 'off'."

	^self newOff! !

!Switch class methodsFor: 'instance creation'!
newOff
	"Answer an instance of me such that the on and off actions are set to nil 
	('no action'), and the state is set to 'off'."

	^super new initializeOff! !

!Switch class methodsFor: 'instance creation'!
newOn
	"Answer an instance of me such that the on and off actions are set to nil 
	('no action'), and the state is set to 'on'."

	^super new initializeOn! !
Object subclass: #Syllable
	instanceVariableNames: 'phonemes accent events'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!
!Syllable commentStamp: '<historical>' prior: 0!
My instances are syllables. They can carry a pitch accent: 'H*', 'L*', etc.!


!Syllable methodsFor: 'accessing' stamp: 'len 12/11/1999 13:03'!
accent
	^ accent! !

!Syllable methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
accent: aString
	accent := aString! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/8/1999 17:47'!
accept: anObject
	anObject syllable: self! !

!Syllable methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
events
	^ events ifNil: [events := CompositeEvent new addAll: (self phonemes collect: [ :each | PhoneticEvent new phoneme: each; duration: 0.080]); yourself]! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/8/1999 02:55'!
phonemes
	^ phonemes! !

!Syllable methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
phonemes: aCollection
	phonemes := aCollection! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/8/1999 02:54'!
stress
	self phonemes do: [ :each | each stress > 0 ifTrue: [^ each stress]].
	^ 0! !


!Syllable methodsFor: 'enumarating' stamp: 'len 12/13/1999 01:20'!
eventsDo: aBlock
	self events do: aBlock! !


!Syllable methodsFor: 'printing' stamp: 'stephaneducasse 2/3/2006 22:23'!
printOn: aStream
	| first |
	aStream nextPut: $[.
	first := true.
	self phonemes do: [ :each |
		first ifFalse: [aStream space].
		aStream print: each.
		first := false].
	aStream nextPut: $]! !


!Syllable methodsFor: 'testing' stamp: 'len 12/8/1999 19:03'!
hasPrimaryStress
	^ self stress = 1! !

!Syllable methodsFor: 'testing' stamp: 'len 12/8/1999 19:03'!
hasSecondaryStress
	^ self stress = 2! !

!Syllable methodsFor: 'testing' stamp: 'len 12/11/1999 13:11'!
isAccented
	^ self accent notNil! !
String subclass: #Symbol
	instanceVariableNames: ''
	classVariableNames: 'NewSymbols OneCharacterSymbols SymbolTable'
	poolDictionaries: ''
	category: 'Collections-Strings'!
!Symbol commentStamp: '<historical>' prior: 0!
I represent Strings that are created uniquely. Thus, someString asSymbol == someString asSymbol.!


!Symbol methodsFor: 'accessing'!
at: anInteger put: anObject 
	"You cannot modify the receiver."

	self errorNoModification! !

!Symbol methodsFor: 'accessing' stamp: 'sma 2/5/2000 12:32'!
precedence
	"Answer the receiver's precedence, assuming it is a valid Smalltalk
	message selector or 0 otherwise.  The numbers are 1 for unary,
	2 for binary and 3 for keyword selectors."

	self size = 0 ifTrue: [^ 0].
	self first isLetter ifFalse: [^ 2].
	self last = $: ifTrue: [^ 3].
	^ 1! !

!Symbol methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement startingAt: repStart

	self errorNoModification! !


!Symbol methodsFor: 'comparing' stamp: 'ar 4/10/2005 23:45'!
= aSymbol
	"Compare the receiver and aSymbol." 
	self == aSymbol ifTrue: [^ true].
	self class == aSymbol class ifTrue: [^ false].
	"Use String comparison otherwise"
	^ super = aSymbol! !


!Symbol methodsFor: 'converting' stamp: 'st 11/22/2004 17:26'!
asMutator
	"Return a setter message from a getter message. For example,
	#name asMutator returns #name:"
	^ (self copyWith: $:) asSymbol! !

!Symbol methodsFor: 'converting' stamp: 'ar 4/10/2005 22:42'!
asString 
	"Refer to the comment in String|asString."
	| newString |
	newString _ self species new: self size.
	newString replaceFrom: 1 to: newString size with: self startingAt: 1.
	^newString! !

!Symbol methodsFor: 'converting'!
asSymbol 
	"Refer to the comment in String|asSymbol."! !

!Symbol methodsFor: 'converting' stamp: 'sw 1/28/98 18:18'!
capitalized
	^ self asString capitalized asSymbol! !

!Symbol methodsFor: 'converting' stamp: 'md 8/10/2004 10:54'!
withFirstCharacterDownshifted
	"Answer an object like the receiver but with first character downshifted if necesary"

	^self asString withFirstCharacterDownshifted asSymbol.! !


!Symbol methodsFor: 'copying' stamp: 'tk 6/26/1998 11:35'!
clone
	"Answer with the receiver, because Symbols are unique."! !

!Symbol methodsFor: 'copying'!
copy
	"Answer with the receiver, because Symbols are unique."! !

!Symbol methodsFor: 'copying'!
shallowCopy
	"Answer with the receiver, because Symbols are unique."! !

!Symbol methodsFor: 'copying' stamp: 'tk 8/19/1998 16:05'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."! !


!Symbol methodsFor: 'filter streaming' stamp: 'mpw 1/1/1901 00:20'!
byteEncode:aStream
	^aStream writeSymbol:self.
! !


!Symbol methodsFor: 'printing' stamp: 'sw 8/19/1999 11:30'!
isOrientedFill
	"Needs to be implemented here because symbols can occupy 'color' slots of morphs."

	^ false! !

!Symbol methodsFor: 'printing' stamp: 'di 4/25/2000 12:32'!
storeOn: aStream 

	aStream nextPut: $#.
	(Scanner isLiteralSymbol: self)
		ifTrue: [aStream nextPutAll: self]
		ifFalse: [super storeOn: aStream]! !


!Symbol methodsFor: 'system primitives' stamp: 'di 1/2/1999 17:00'!
flushCache
	"Tell the interpreter to remove all entries with this symbol as a selector from its method lookup cache, if it has one.  This primitive must be called whenever a method is defined or removed.
	NOTE:  Only one of the two selective flush methods needs to be used.
	Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)."

	<primitive: 119>
! !

!Symbol methodsFor: 'system primitives' stamp: 'md 2/16/2006 17:17'!
numArgs: n
	"Answer a string that can be used as a selector with n arguments.
	 TODO: need to be extended to support shrinking and for selectors like #+ " 

	| selector numArgs aStream offs |
	
	selector := self.
	(numArgs := selector numArgs) >= n ifTrue: [^self].	
	aStream := WriteStream on: (String new: 16).
	aStream nextPutAll: self.
	
	(numArgs = 0) ifTrue: [aStream nextPutAll: ':'. offs := 0] ifFalse: [offs := 1].
	2 to: n - numArgs + offs do: [:i | aStream nextPutAll: 'with:'].	
	^aStream contents asSymbol
	
! !


!Symbol methodsFor: 'testing' stamp: 'md 1/20/2006 16:16'!
includesKey: sym
	^self == sym.! !

!Symbol methodsFor: 'testing' stamp: 'md 8/27/2005 16:33'!
isDoIt

	^ (self == #DoIt) or: [self == #DoItIn:].! !

!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:32'!
isInfix
	"Answer whether the receiver is an infix message selector."

	^ self precedence == 2! !

!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:34'!
isKeyword
	"Answer whether the receiver is a message keyword."

	^ self precedence == 3! !

!Symbol methodsFor: 'testing' stamp: 'di 4/25/2000 12:32'!
isLiteral
	"Answer whether the receiver is a valid Smalltalk literal."

	^ true! !

!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:13'!
isPvtSelector
	"Answer whether the receiver is a private message selector, that is,
	begins with 'pvt' followed by an uppercase letter, e.g. pvtStringhash."

	^ (self beginsWith: 'pvt') and: [self size >= 4 and: [(self at: 4) isUppercase]]! !

!Symbol methodsFor: 'testing' stamp: 'md 4/30/2003 15:31'!
isSymbol
	^ true ! !

!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:34'!
isUnary
	"Answer whether the receiver is an unary message selector."

	^ self precedence == 1! !


!Symbol methodsFor: 'user interface' stamp: 'sma 11/12/2000 11:46'!
asExplorerString
	^ self printString! !


!Symbol methodsFor: 'private'!
errorNoModification

	self error: 'symbols can not be modified.'! !

!Symbol methodsFor: 'private'!
string: aString

	1 to: aString size do: [:j | super at: j put: (aString at: j)].
	^self  ! !


!Symbol methodsFor: 'evaluating' stamp: 'md 3/24/2006 12:09'!
value: anObject 
	^anObject perform: self.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Symbol class
	instanceVariableNames: ''!

!Symbol class methodsFor: 'access' stamp: 'ar 4/10/2005 22:49'!
allSymbols
	"Answer all interned symbols"
	^Array streamContents:[:s|
		s nextPutAll: NewSymbols.
		s nextPutAll: OneCharacterSymbols.
		s nextPutAll: SymbolTable.
	].
! !

!Symbol class methodsFor: 'access' stamp: 'yo 11/3/2004 19:24'!
selectorsContaining: aString
	"Answer a list of selectors that contain aString within them. Case-insensitive.  Does return symbols that begin with a capital letter."

	| size selectorList ascii |

	selectorList _ OrderedCollection new.
	(size _ aString size) = 0 ifTrue: [^selectorList].

	aString size = 1 ifTrue:
		[
			ascii _ aString first asciiValue.
			ascii < 128 ifTrue: [selectorList add: (OneCharacterSymbols at: ascii+1)]
		].

	aString first isLetter ifFalse:
		[
			aString size == 2 ifTrue: 
				[Symbol hasInterned: aString ifTrue:
					[:s | selectorList add: s]].
			^selectorList
		].

	selectorList _ selectorList copyFrom: 2 to: selectorList size.

	self allSymbolTablesDo: [:each |
		each size >= size ifTrue:
			[(each findSubstring: aString in: each startingAt: 1 
				matchTable: CaseInsensitiveOrder) > 0
						ifTrue: [selectorList add: each]]].

	^selectorList reject: [:each | "reject non-selectors, but keep ones that begin with an uppercase"
		each numArgs < 0 and: [each asString withFirstCharacterDownshifted numArgs < 0]].

"Symbol selectorsContaining: 'scon'"! !

!Symbol class methodsFor: 'access' stamp: 'tween 9/13/2004 10:09'!
thatStartsCaseSensitive: leadingCharacters skipping: skipSym
	"Same as thatStarts:skipping: but caseSensitive"
	| size firstMatch key |

	size := leadingCharacters size.
	size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]].
	firstMatch := leadingCharacters at: 1.
	size > 1 ifTrue: [key := leadingCharacters copyFrom: 2 to: size].
	self allSymbolTablesDo: [:each |
			each size >= size ifTrue:
				[
					((each at: 1) == firstMatch and:
						[key == nil or:
							[(each findString: key startingAt: 2 caseSensitive: true) = 2]])
								ifTrue: [^each]
				]
		] after: skipSym.

	^nil
! !

!Symbol class methodsFor: 'access' stamp: 'RAA 5/29/2001 14:35'!
thatStarts: leadingCharacters skipping: skipSym
	"Answer a selector symbol that starts with leadingCharacters.
	Symbols beginning with a lower-case letter handled directly here.
	Ignore case after first char.
	If skipSym is not nil, it is a previous answer; start searching after it.
	If no symbols are found, answer nil.
	Used by Alt-q (Command-q) routines"

	| size firstMatch key |

	size _ leadingCharacters size.
	size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]].

	firstMatch _ leadingCharacters at: 1.
	size > 1 ifTrue: [key _ leadingCharacters copyFrom: 2 to: size].

	self allSymbolTablesDo: [:each |
			each size >= size ifTrue:
				[
					((each at: 1) == firstMatch and:
						[key == nil or:
							[(each findString: key startingAt: 2 caseSensitive: false) = 2]])
								ifTrue: [^each]
				]
		] after: skipSym.

	^nil

"Symbol thatStarts: 'sf' skipping: nil"
"Symbol thatStarts: 'sf' skipping: #sfpGetFile:with:with:with:with:with:with:with:with:"
"Symbol thatStarts: 'candidate' skipping: nil"
! !


!Symbol class methodsFor: 'class initialization' stamp: 'RAA 5/29/2001 08:21'!
allSymbolTablesDo: aBlock

	NewSymbols do: aBlock.
	SymbolTable do: aBlock.! !

!Symbol class methodsFor: 'class initialization' stamp: 'RAA 5/29/2001 14:35'!
allSymbolTablesDo: aBlock after: aSymbol

	NewSymbols do: aBlock after: aSymbol.
	SymbolTable do: aBlock after: aSymbol.! !

!Symbol class methodsFor: 'class initialization' stamp: 'RAA 12/17/2000 18:05'!
compactSymbolTable
	"Reduce the size of the symbol table so that it holds all existing symbols + 25% (changed from 1000 since sets like to have 25% free and the extra space would grow back in a hurry)"

	| oldSize |

	Smalltalk garbageCollect.
	oldSize _ SymbolTable array size.
	SymbolTable growTo: SymbolTable size * 4 // 3 + 100.
	^oldSize printString,'  ',(oldSize - SymbolTable array size) printString, ' slot(s) reclaimed'! !

!Symbol class methodsFor: 'class initialization' stamp: 'RAA 5/29/2001 09:04'!
initialize

	"Symbol initialize"

	Symbol rehash.
	OneCharacterSymbols _ nil.
	OneCharacterSymbols _ (1 to: 256) collect: [ :i | (i - 1) asCharacter asSymbol].
	Smalltalk addToShutDownList: self.
! !


!Symbol class methodsFor: 'instance creation'!
findInterned:aString

	self hasInterned:aString ifTrue:[:symbol| ^symbol].
	^nil.! !

!Symbol class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 23:04'!
internCharacter: aCharacter
	aCharacter asciiValue > 256 ifTrue:[^self intern: aCharacter asString].
	OneCharacterSymbols ifNil: [^self intern: aCharacter asString].
	^OneCharacterSymbols at: aCharacter asciiValue + 1
! !

!Symbol class methodsFor: 'instance creation' stamp: 'ar 4/12/2005 17:37'!
intern: aStringOrSymbol 

	^(self lookup: aStringOrSymbol) ifNil:[
		| aClass aSymbol |
		aStringOrSymbol isSymbol ifTrue:[
			aSymbol _ aStringOrSymbol.
		] ifFalse:[
			aClass := aStringOrSymbol isOctetString ifTrue:[ByteSymbol] ifFalse:[WideSymbol].
			aSymbol := aClass new: aStringOrSymbol size.
			aSymbol string: aStringOrSymbol.
		].
		NewSymbols add: aSymbol.
		aSymbol].! !

!Symbol class methodsFor: 'instance creation' stamp: 'RAA 5/29/2001 08:09'!
lookup: aStringOrSymbol

	^(SymbolTable like: aStringOrSymbol) ifNil: [
		NewSymbols like: aStringOrSymbol
	]! !

!Symbol class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	^ (aCollection as: String) asSymbol

"	Symbol newFrom: {$P. $e. $n}
	{$P. $e. $n} as: Symbol
"! !

!Symbol class methodsFor: 'instance creation' stamp: 'di 10/11/1999 00:02'!
readFrom: strm  "Symbol readFromString: '#abc'"

	strm peek = $# ifFalse: [self error: 'Symbols must be introduced by #'].
	^ (Scanner new scan: strm) advance  "Just do what the code scanner does"! !


!Symbol class methodsFor: 'private' stamp: 'ar 4/10/2005 22:43'!
hasInterned: aString ifTrue: symBlock 
	"Answer with false if aString hasnt been interned (into a Symbol),  
	otherwise supply the symbol to symBlock and return true."

	| symbol |
	^ (symbol _ self lookup: aString)
		ifNil: [false]
		ifNotNil: [symBlock value: symbol.
			true]! !

!Symbol class methodsFor: 'private' stamp: 'RAA 5/29/2001 14:33'!
possibleSelectorsFor: misspelled 
	"Answer an ordered collection of possible corrections
	for the misspelled selector in order of likelyhood"

	| numArgs candidates lookupString best binary short long first ss |
	lookupString _ misspelled asLowercase. "correct uppercase selectors to lowercase"
	numArgs _ lookupString numArgs.
	(numArgs < 0 or: [lookupString size < 2]) ifTrue: [^ OrderedCollection new: 0].
	first _ lookupString first.
	short _ lookupString size - (lookupString size // 4 max: 3) max: 2.
	long _ lookupString size + (lookupString size // 4 max: 3).

	"First assemble candidates for detailed scoring"
	candidates _ OrderedCollection new.
	self allSymbolTablesDo: [:s | (((ss _ s size) >= short	"not too short"
			and: [ss <= long			"not too long"
					or: [(s at: 1) = first]])	"well, any length OK if starts w/same letter"
			and: [s numArgs = numArgs])	"and numArgs is the same"
			ifTrue: [candidates add: s]].

	"Then further prune these by correctAgainst:"
	best _ lookupString correctAgainst: candidates.
	((misspelled last ~~ $:) and: [misspelled size > 1]) ifTrue: [
		binary _ misspelled, ':'.		"try for missing colon"
		Symbol hasInterned: binary ifTrue: [:him | best addFirst: him]].
	^ best! !

!Symbol class methodsFor: 'private' stamp: 'ar 9/27/2005 20:01'!
rehash		"Symbol rehash"
	"Rebuild the hash table, reclaiming unreferenced Symbols."

	SymbolTable := WeakSet withAll: self allSubInstances.
	NewSymbols := WeakSet new.! !

!Symbol class methodsFor: 'private' stamp: 'RAA 5/29/2001 09:04'!
shutDown: aboutToQuit

	SymbolTable addAll: NewSymbols.
	NewSymbols _ WeakSet new.! !
KeyboardInputInterpreter subclass: #SymbolInputInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!SymbolInputInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:10'!
nextCharFrom: sensor firstEvt: evtBuf

	| keyValue |
	keyValue := evtBuf third.
	evtBuf fifth > 1 ifTrue: [^ keyValue asCharacter macToSqueak].
	^ (self symbolKeyValueToUnicode: keyValue) asCharacter.
! !

!SymbolInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 11/8/2004 18:53'!
symbolKeyValueToUnicode: keyValue

	keyValue = 127 ifTrue: [^ 127].
	keyValue < 32 ifTrue: [^ keyValue].
	keyValue > 255 ifTrue: [^ 0].
	^ #(0 0 0 0 0 0 0 0 0 61472 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61472 61473 61474 61475 61476 61477 61478 61479 61480 61481 61482 61483 61484 61485 61486 61487 61488 61489 61490 61491 61492 61493 61494 61495 61496 61497 61498 61499 61500 61501 61502 61503 61504 61505 61506 61507 61508 61509 61510 61511 61512 61513 61514 61515 61516 61517 61518 61519 61520 61521 61522 61523 61524 61525 61526 61527 61528 61529 61530 61531 61532 61533 61534 61535 61536 61537 61538 61539 61540 61541 61542 61543 61544 61545 61546 61547 61548 61549 61550 61551 61552 61553 61554 61555 61556 61557 61558 61559 61560 61561 61562 61563 61564 61565 61566 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61601 61602 61603 61604 61605 61606 61607 61608 61609 61610 61611 61612 61613 61614 61615 61616 61617 61618 61619 61620 61621 61622 61623 61624 61625 61626 61627 61628 61629 61630 61631 61632 61633 61634 61635 61636 61637 61638 61639 61640 61641 61642 61643 61644 61645 61646 61647 61648 61649 61650 61651 61652 61653 61654 61655 61656 61657 61658 61659 61660 61661 61662 61663 61664 61665 61666 61667 61668 61669 61670 61671 61672 61673 61674 61675 61676 61677 61678 61679 0 61681 61682 61683 61684 61685 61686 61687 61688 61689 61690 61691 61692 61693 61694 0) at: keyValue + 1.
! !
TileMorph subclass: #SymbolListTile
	instanceVariableNames: 'choices dataType'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!SymbolListTile commentStamp: '<historical>' prior: 0!
Instances of SymbolListTile are literal tiles whose literals are choosable from a finite list.!


!SymbolListTile methodsFor: 'accessing' stamp: 'yo 7/2/2004 21:27'!
literal: anObject
	"Set the receiver's literal as indicated"
	self flag: #yo.

	literal _ anObject asSymbol.
	self updateLiteralLabel.
"
	key _ Vocabulary eToyVocabulary translationKeyFor: literal.
	key isNil ifFalse: [literal _ key].
"
	self flag: #deferred.  "The below formerly was necessary but now is problematical, leading to low-space condition etc.  May need to revisit, since as I comment this out now I am uncertain what if anything this may break"
	"self labelMorph informTarget"

! !

!SymbolListTile methodsFor: 'accessing' stamp: 'tak 12/6/2004 01:58'!
options
	^ {self choices. self choices
		collect: [:each | ScriptingSystem helpStringForOperator: literal]}! !

!SymbolListTile methodsFor: 'accessing' stamp: 'tak 12/7/2004 14:42'!
value: anObject 
	self acceptNewLiteral: anObject! !


!SymbolListTile methodsFor: 'customevents-accessing' stamp: 'nk 7/21/2003 22:02'!
dataType
	^dataType! !


!SymbolListTile methodsFor: 'customevents-initialization' stamp: 'nk 7/21/2003 22:14'!
updateChoices
	choices _ (Vocabulary vocabularyNamed: dataType) choices.
	(choices includes: literal) ifFalse: [ literal _ choices first. self changed ]! !


!SymbolListTile methodsFor: 'event handling' stamp: 'sw 12/3/2001 21:30'!
handlesMouseDown: evt
	"Answer whether the receiver handles mouse-down"

	^ true! !

!SymbolListTile methodsFor: 'event handling' stamp: 'sw 11/16/2001 07:31'!
wantsKeyboardFocusFor: aSubmorph
	"Answer whether a plain mouse click on aSubmorph, a text-edit-capable thing, should result in a text selection there"

	^ false! !


!SymbolListTile methodsFor: 'events-processing' stamp: 'sw 12/3/2001 20:45'!
mouseDownPriority
	"Higher-priority than parts donor, so that the tile can offer a popup even when it is in a larger structure, such as a PhraseTileMorph, that itself behaves as a parts donor"

	^ 75! !


!SymbolListTile methodsFor: 'initialization' stamp: 'sw 10/30/2000 09:04'!
choices: choiceList dataType: aDataType
	"Initialize the receiver with the given choice-list and data type"

	choices _ choiceList.
	dataType _ aDataType.
	literal _ choiceList first! !

!SymbolListTile methodsFor: 'initialization' stamp: 'tak 12/6/2004 01:38'!
initialize
	super initialize.
	literal _ #nothing! !


!SymbolListTile methodsFor: 'misc' stamp: 'sw 11/6/2001 13:30'!
setLiteralInitially: anObject
	"Establish the initial literal.  Get the label correct, but do *not* send the value back to the target via the setter (unlike #literal:)"

	literal _ anObject ifNotNil: [anObject asSymbol].
	self updateLiteralLabel! !


!SymbolListTile methodsFor: 'player viewer' stamp: 'yo 1/12/2005 14:28'!
updateLiteralLabel
	"Update the wording emblazoned on the tile, if needed.  Copied down, for jimmying, unfortunately"

	| myLabel |
	(myLabel _ self labelMorph) ifNil: [^ self].
	myLabel useSymbolFormat.
	myLabel acceptValue: literal asString.
	self changed.! !


!SymbolListTile methodsFor: 'user interface' stamp: 'yo 1/12/2005 14:38'!
acceptNewLiteral: aLiteral
	"Accept the new literal"

	self labelMorph useSymbolFormat.
	self literal: aLiteral.
	self adjustHelpMessage.
	self acceptNewLiteral.  "so tile scriptor can recompile if necessary"
	self labelMorph informTarget
! !

!SymbolListTile methodsFor: 'user interface' stamp: 'sw 3/10/2004 23:24'!
adjustHelpMessage
	"Adjust the help message to reflect the new literal"

	(ScriptingSystem helpStringOrNilForOperator: literal) ifNotNilDo:
		[:aString |
			self labelMorph setBalloonText: aString]! !

!SymbolListTile methodsFor: 'user interface' stamp: 'sw 12/21/2003 00:07'!
choices
	"Answer the list of current choices for the receiver's symbol"

	dataType == #ScriptName ifTrue: "Backward compatibility with old tiles"
		[^ ActiveWorld presenter allKnownUnaryScriptSelectors].
	^ choices! !

!SymbolListTile methodsFor: 'user interface' stamp: 'sw 1/4/2005 00:16'!
offerAllChoicesInAPopUp
	"Retained in deference to pre-existing content that may have event handlers that send this message."

	! !


!SymbolListTile methodsFor: 'private' stamp: 'yo 1/12/2005 14:28'!
line1: line1
	"Emblazon the receiver with the requested label.  If the receiver already has a label, make the new label be of the same class"

	super line1: line1.
	self labelMorph useSymbolFormat! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SymbolListTile class
	instanceVariableNames: ''!

!SymbolListTile class methodsFor: 'customevents-updating' stamp: 'nk 7/21/2003 22:16'!
updateAllTilesForVocabularyNamed: aVocabularyName
	"The choices in the Vocabulary named aVocabularyName may have changed.
	Update my subinstances if necessary to reflect the changes."

	 (self allSubInstances select: [ :ea | ea dataType = aVocabularyName ])
		do: [ :ea | ea updateChoices ] ! !
DataType subclass: #SymbolListType
	instanceVariableNames: 'symbols'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!
!SymbolListType commentStamp: 'sw 1/6/2005 17:52' prior: 0!
A type whose values range across a finite set of symbols, which are held in the "symbols" instance variable.!


!SymbolListType methodsFor: 'initial value' stamp: 'sw 12/3/2001 19:27'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"

	^ self choices first! !


!SymbolListType methodsFor: 'tiles' stamp: 'sw 12/3/2001 19:14'!
choices
	"answer the list of choices to offer as variant values"

	^ symbols copy! !

!SymbolListType methodsFor: 'tiles' stamp: 'sw 1/6/2005 17:24'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^ #(BorderStyle ButtonPhase TrailStyle) includes: vocabularyName! !

!SymbolListType methodsFor: 'tiles' stamp: 'stephaneducasse 2/4/2006 20:39'!
symbols: symbolList
	"Set the receiver's list of symbols as indicated"

	symbols := symbolList! !


!SymbolListType methodsFor: '*eToys-tiles' stamp: 'sw 1/12/2005 10:13'!
affordsCoercionToBoolean
	"Answer true if a tile of this data type, when dropped into a pane that demands a boolean, could plausibly be expanded into a comparison (of the form  frog < toad   or frog = toad) to provide a boolean expression"

	"Formerly this had been disabled (9/27/01) but from today's perspective I don't see any reason to disable it..."

	^ true! !

!SymbolListType methodsFor: '*eToys-tiles' stamp: 'sw 12/3/2001 19:15'!
defaultArgumentTile
	"Answer a tile to represent the type"

	| aTile choices |
	aTile _ SymbolListTile new choices: (choices _ self choices) dataType: self vocabularyName.
	aTile addArrows.
	aTile setLiteral: choices first.
	^ aTile! !

!SymbolListType methodsFor: '*eToys-tiles' stamp: 'sw 12/3/2001 21:00'!
newReadoutTile
	"Answer a tile that can serve as a readout for data of this type"

	^ SymbolListTile new choices: self choices dataType: self vocabularyName
! !
ClassTestCase subclass: #SymbolTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!
!SymbolTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Symbol. 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!


!SymbolTest methodsFor: 'tests' stamp: 'md 9/6/2005 20:02'!
testAsMutator

	self assert: #x asMutator = #x:.
	self assert: #x asMutator isSymbol! !

!SymbolTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:29'!
testCapitalized

	| uc lc |		
	uc := #MElViN.
	lc := #mElViN.
	self assert:  lc capitalized = uc.
	self assert: uc capitalized = uc.
! !

!SymbolTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:29'!
testWithFirstCharacterDownshifted

	| uc lc empty |		
	uc := #MElViN.
	lc := #mElViN.
	empty := #' '.
	self assert:  uc withFirstCharacterDownshifted = lc.
	self assert: lc withFirstCharacterDownshifted = lc.
	
! !


!SymbolTest methodsFor: 'as yet unclassified' stamp: 'md 2/16/2006 17:17'!
testNumArgs2
    "TODO: need to be extended to support shrinking and for selectors like #+ " 
	
	self assert: (#test numArgs: 0) = #test.
	self assert: (#test numArgs: 1) = #test:.
	self assert: (#test numArgs: 2) = #test:with:.
	self assert: (#test numArgs: 3) = #test:with:with:.
	

	self assert: (#test: numArgs: 0) = #test:.
	self assert: (#test: numArgs: 1) = #test:.
	self assert: (#test: numArgs: 2) = #test:with:.
	self assert: (#test: numArgs: 3) = #test:with:with:.
	
	self assert: (#test:with: numArgs: 0) = #test:with:.
	self assert: (#test:with: numArgs: 1) = #test:with:.
	self assert: (#test:with: numArgs: 2) = #test:with:.
	self assert: (#test:with: numArgs: 3) = #test:with:with:.
	self assert: (#test:with: numArgs: 4) = #test:with:with:with:.
	
	self assert: (#test:with:with: numArgs: 0) = #test:with:with:.
	self assert: (#test:with:with: numArgs: 1) = #test:with:with:.
	self assert: (#test:with:with: numArgs: 2) = #test:with:with:.
	self assert: (#test:with:with: numArgs: 3) = #test:with:with:.
	self assert: (#test:with:with: numArgs: 4) = #test:with:with:with:.! !
Object subclass: #SyntaxAttribute
	instanceVariableNames: 'color emphasis attributeList'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Support'!
!SyntaxAttribute commentStamp: '<historical>' prior: 0!
Represents a color and possibly a style attribute to be applied to a syntactic element for pretty-printing.  The attributeList inst var is a cache.!


!SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/17/1999 15:04'!
attributeList
	"Answer a list of text attributes that characterize the receiver"
	attributeList ifNil:
		[attributeList _ OrderedCollection new: 2.
		color ifNotNil: [attributeList add: (TextColor color: color)].
		emphasis ifNotNil: [attributeList add: (TextEmphasis perform: emphasis)]].
	^ attributeList! !

!SyntaxAttribute methodsFor: 'accessing' stamp: 'djp 11/7/1999 14:52'!
color

	^ color! !

!SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/16/1999 16:21'!
color: aTextColor
	color _ aTextColor.
	attributeList _ nil! !

!SyntaxAttribute methodsFor: 'accessing' stamp: 'djp 11/7/1999 14:52'!
emphasis

	^ emphasis! !

!SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/16/1999 16:22'!
emphasis: aTextEmphasis
	emphasis _ aTextEmphasis.
	attributeList _ nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SyntaxAttribute class
	instanceVariableNames: ''!

!SyntaxAttribute class methodsFor: 'as yet unclassified' stamp: 'sw 11/16/1999 12:01'!
color: aColor emphasis: anEmphasis
	^ self new color: aColor; emphasis: anEmphasis; yourself! !
StringHolder subclass: #SyntaxError
	instanceVariableNames: 'class selector category debugger doitFlag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!SyntaxError commentStamp: '<historical>' prior: 0!
I represent syntax error report for syntax errors encountered when filing in class descriptions from a non-interactive source such as an external file. As a StringHolder, the string to be viewed is the method code or expression containing the error.

The user may fix the error and accept the method to continue the fileIn.
!


!SyntaxError methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'!
category: aSymbol
	"Record the message category of method being compiled. This is used when the user corrects the error and accepts."

	category := aSymbol.
! !

!SyntaxError methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:30'!
setClass: aClass code: aString debugger: aDebugger doitFlag: flag

	| types printables badChar |
	class := aClass.
	debugger := aDebugger.
	selector := aClass parserClass new parseSelector: aString.
	types := Scanner classPool at: #TypeTable.	"dictionary"
	printables := '!!@#$%&*-_=+<>{}?/\,·£¢§¶ªº–—“‘”’…Úæگ׿«»`~`' asSet.
	badChar := aString detect: [:aChar | (types at: aChar asciiValue ifAbsent: [#xLetter]) == #xBinary and: [
			(printables includes: aChar) not]] ifNone: [nil].
	contents := badChar 
		ifNil: [aString]
		ifNotNil: ['<<<This string contains a character (ascii value ', 
			badChar asciiValue printString,
			') that is not normally used in code>>> ', aString].
	category ifNil: [category := aClass organization categoryOfElement: selector].
	category ifNil: [category := ClassOrganizer default].
	doitFlag := flag! !


!SyntaxError methodsFor: 'menu' stamp: 'RAA 12/1/2000 14:24'!
debug
	"Show the stack of the process leading to this syntax editor, typically showing the stack of the compiler as called from fileIn."

	debugger openFullNoSuspendLabel: 'Stack of the Syntax Error'.
	Smalltalk isMorphic ifFalse: [Processor terminateActive].
! !

!SyntaxError methodsFor: 'menu' stamp: 'jm 5/3/1998 14:22'!
listMenu: aMenu

	^ aMenu labels:
'proceed
debug calling process
browse full'
	lines: #()
	selections: #(proceed debug browseMethodFull)
! !

!SyntaxError methodsFor: 'menu' stamp: 'di 5/5/1998 00:06'!
proceed
	"The user has has edited and presumably fixed the syntax error and the filein can now proceed."

	debugger proceed: self topView.
! !


!SyntaxError methodsFor: 'message list' stamp: 'tk 4/19/1999 08:08'!
list
	"Answer an array of one element made up of the class name, message category, and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver."

	selector ifNil: [^ Array with: (class name, '  ', category, '  ', '<none>')].
	^ Array with: (class name, '  ', category, '  ', selector)
! !

!SyntaxError methodsFor: 'message list' stamp: 'jm 5/3/1998 13:48'!
listIndex
	"There is always exactly one element in my list and it is always selected."

	^ 1
! !


!SyntaxError methodsFor: 'other' stamp: 'di 10/9/1998 16:36'!
contents: aString notifying: aController
	"Compile the code in aString and notify aController of any errors. If there are no errors, then automatically proceed."

	doitFlag
	ifTrue: [Compiler new evaluate: aString in: nil to: nil
						notifying: aController ifFail: [^ false]]
	ifFalse: [(class compile: aString classified: category
						notifying: aController) ifNil: [^ false]].

	aController hasUnacceptedEdits: false.
	self proceed! !

!SyntaxError methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'!
notify: error at: location in: source
	"Open a syntax error view, inserting the given error message into the given source at the given location. This message is sent to the 'requestor' when the parser or compiler finds a syntax error."

	| aClass aString |
	aClass := thisContext sender receiver encoder classEncoding.
	aString :=
		source contents
			copyReplaceFrom: location
			to: location - 1
			with: error.
	self setClass: aClass
		code: aString
		debugger: (Debugger context: thisContext)
		doitFlag: false.
	self class open: self.
! !


!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:15'!
selectedClass
	"Answer the class in which the syntax error occurred."

	^ class
! !

!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:33'!
selectedClassOrMetaClass
	"Answer the class of the method being compiled."

	^ class
! !

!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:17'!
selectedMessageName
	"Answer the selector of the method being compiled."

	^ selector
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SyntaxError class
	instanceVariableNames: ''!

!SyntaxError class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
buildMVCViewOn: aSyntaxError
	"Answer an MVC view on the given SyntaxError."

	| topView aListView aCodeView |
	topView := StandardSystemView new
		model: aSyntaxError;
		label: 'Syntax Error';
		minimumSize: 380@220.

	aListView := PluggableListView on: aSyntaxError
		list: #list
		selected: #listIndex
		changeSelected: nil
		menu: #listMenu:.
	aListView window: (0@0 extent: 380@20).
	topView addSubView: aListView.

	aCodeView := PluggableTextView on: aSyntaxError
		text: #contents
		accept: #contents:notifying:
		readSelection: #contentsSelection
		menu: #codePaneMenu:shifted:.
	aCodeView window: (0@0 extent: 380@200).
	topView addSubView: aCodeView below: aListView.

	^ topView
! !

!SyntaxError class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
buildMorphicViewOn: aSyntaxError
	"Answer an Morphic view on the given SyntaxError."
	| window |
	window := (SystemWindow labelled: 'Syntax Error') model: aSyntaxError.

	window addMorph: (PluggableListMorph on: aSyntaxError list: #list
			selected: #listIndex changeSelected: nil menu: #listMenu:)
		frame: (0@0 corner: 1@0.15).

	window addMorph: (PluggableTextMorph on: aSyntaxError text: #contents
			accept: #contents:notifying: readSelection: #contentsSelection
			menu: #codePaneMenu:shifted:)
		frame: (0@0.15 corner: 1@1).

	^ window openInWorldExtent: 380@220! !

!SyntaxError class methodsFor: 'instance creation' stamp: 'di 9/14/2001 07:46'!
errorInClass: aClass withCode: codeString doitFlag: doit
	"Open a view whose model is a syntax error. The error occurred when trying to add the given method code to the given class."

	self open:
		(self new setClass: aClass
			code: codeString
			debugger: (Debugger context: thisContext)
			doitFlag: doit).
! !

!SyntaxError class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
open: aSyntaxError
	"Answer a standard system view whose model is an instance of me."
	| topView |
	<primitive: 19> "Simulation guard"
	Smalltalk isMorphic
		ifTrue:
			[self buildMorphicViewOn: aSyntaxError.
			Project spawnNewProcessIfThisIsUI: Processor activeProcess.
			^ Processor activeProcess suspend].
	topView := self buildMVCViewOn: aSyntaxError.
	topView controller openNoTerminateDisplayAt: Display extent // 2.
	Cursor normal show.
	Processor activeProcess suspend.
! !
Notification subclass: #SyntaxErrorNotification
	instanceVariableNames: 'inClass code category doitFlag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Extensions'!

!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:17'!
category
	^category! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:11'!
doitFlag
	^doitFlag! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:10'!
errorClass
	^inClass! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:10'!
errorCode
	^code! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:14'!
messageText
	^ super messageText
		ifNil: [messageText := code]! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:15'!
setClass: aClass category: aCategory code: codeString doitFlag: aBoolean
	inClass := aClass.
	category := aCategory.
	code := codeString.
	doitFlag := aBoolean ! !


!SyntaxErrorNotification methodsFor: 'exceptionDescription' stamp: 'ar 9/27/2005 19:13'!
defaultAction
	^ToolSet debugSyntaxError: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SyntaxErrorNotification class
	instanceVariableNames: ''!

!SyntaxErrorNotification class methodsFor: 'exceptionInstantiator' stamp: 'ar 9/27/2005 19:15'!
inClass: aClass category: aCategory withCode: codeString doitFlag: doitFlag 
	^ (self new
		setClass: aClass
		category: aCategory 
		code: codeString
		doitFlag: doitFlag) signal! !
AlignmentMorph subclass: #SyntaxMorph
	instanceVariableNames: 'parseNode markerMorph'
	classVariableNames: 'AllSpecs ContrastFactor DownRightArrow SelfTile SizeScaleFactor'
	poolDictionaries: ''
	category: 'EToys-Tile Scriptors'!
!SyntaxMorph commentStamp: '<historical>' prior: 0!
A single class of morph that holds any piece of Smalltalk syntax, and allows it to be a tile.  Tiles can be dragged in or out of a method. 

In the message list pane of a Browser, choose 'tile scriptor'.  Bring up a second one to steal parts from.  If you use a Protocol Browser, and choose tiles, there will be two buttons that bring up menus with many tiles on them.

Clicking multiple times selects enclosing phrases of code.  Dragging lets you take away a copy.  Any tile may be replaced by dropping on it.  Shift-click to edit the text of any tile.  Change variable and message names, but do not change the part-of-speech (objects to selector).

Each SyntaxMorph holds a ParseNode.  After editing, the parseNode is only good as a part-of-speech indicator.  Only the Class of a parseNode is important.  It's state is not kept up to date with the tile edits (but maybe it should be).  (For MessageNodes, whether the receiver slot is nil is significant.)

The correspondence between SyntaxMorphs and parseNodes in the real parse tree is not one-to-one.  Several extra levels of SyntaxMorph were added as aligners to make the horizontal and vertical layout right.  These sometimes have nil for the parseNode.

When accept the method, we pass over the tree of SyntaxMorphs, gathering their printStrings and inserting punctuation.  See (SyntaxMorph>>printOn:indent:).  We send the result to the compiler.  (We do not use the parse tree we already have.)

To turn on type checking: 
Preferences enable: #eToyFriendly
or for testing:     World project projectParameters at: #fullCheck put: true.

Colors of tiles:  Each tile has a current color (inst car color) and a deselectedColor (a property).  The deselectedColor may be governed by the part of speech, or not.  (translateColor: is only used when a tile is created, to set deselectedColor.)  From deselectedColor (set by #setDeselectedColor), the color changes to:
	lightBrown when selected (not the submorphs) in #select
	translucent when held in the hand (allMorphs) in #lookTranslucent
	green when a drop target (allMorphs) (change the owners back) #dropColor, 
		#trackDropZones 
deselectedColor is moderated by the darkness setting, #scaleColorByUserPref:.  (as it is put into color in #color:)

Code to produce an individual tile is: 
	(SyntaxMorph new) attachTileForCode: '''abc''' nodeType: LiteralNode.
see offerTilesMenuFor:in: for many other phrases that produce useful tiles.

AssignmentNode:  If three submorphs, is a statement, and is a noun.  If one submorph, is just the left arrow.  When dropped on a variable, it creates a new assignment statement. !


!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 8/21/2001 09:36'!
actualObject
	| sub |
	"Who is self in these tiles?  Usually a Player."


	(self nodeClassIs: LiteralVariableNode) ifTrue: [
		(sub _ self findA: StringMorph) ifNil: [^ nil].
		"Need to decompile here for odd synonyms of 'self' ?"
		^ Compiler evaluate: sub contents for: Player logged: false].

	(self nodeClassIs: VariableNode) ifTrue: [
		(sub _ self findA: StringMorph) ifNil: [^ nil].
		^ References at: (self cleanUpString: sub) asSymbol ifAbsent: [nil]].

	(self nodeClassIs: LiteralNode) ifTrue: [
		(sub _ self findA: StringMorph) ifNil: [^ nil].
		^ Compiler evaluate: sub contents for: nil logged: false].

	(sub _ self findA: SyntaxMorph) ifNil: [^ nil].
	^ sub actualObject	"receiver"! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 9/20/2001 13:21'!
argumentNodes
	"Return a collection of this message's argument nodes.  "

	| cls coll rec |
	parseNode ifNil: [^ #()].
	cls _ parseNode class.
	cls == SelectorNode ifTrue: [^ #()].
	cls == KeyWordNode ifTrue: [^ #()].

	coll _ OrderedCollection new.
	rec _ self receiverNode.
	submorphs do: [:sub | 
		(sub isSyntaxMorph and: [sub ~~ rec]) ifTrue: [
			sub isNoun ifTrue: [coll addLast: sub]	"complete arg"
				ifFalse: [coll _ coll, sub argumentNodes]]].	"MessagePartNode, MessageNode with no receiver"
	^ coll! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'RAA 8/24/1999 17:57'!
balloonText

	^(('Value: ',(self getCurrentValue ifNil: [^nil])) 
		withNoLineLongerThan: 35) truncateWithElipsisTo: 300! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'di 12/13/2000 15:25'!
borderColor: colorOrSymbolOrNil

	borderColor = colorOrSymbolOrNil ifFalse: [
		borderColor _ colorOrSymbolOrNil.
		self bounds area < 40000
			ifTrue: [self invalidRect: self bounds]
			ifFalse: [(self bounds areasOutside: (self bounds insetBy: self borderWidth))
						do: [:r | self invalidRect: r]]].
! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'RAA 4/4/2001 12:36'!
cleanUpString: stringSubMorph

	| style rawData |
	^ stringSubMorph 
		valueOfProperty: #syntacticallyCorrectContents 
		ifAbsent: [
			style _ stringSubMorph valueOfProperty: #syntacticReformatting.
			rawData _ stringSubMorph contents.
			 (#(unary tempVariableDeclaration blockarg2 methodHeader1 tempVariable variable) includes: style) ifTrue: [
				rawData _ self unSpaceAndUpShift: rawData appending: nil.
			].
			style == #keywordGetz ifTrue: [
				rawData _ self unSpaceAndUpShift: rawData appending: 'Getz:'.
			].
			style == #keywordSetter ifTrue: [
				rawData _ self unSpaceAndUpShift: 'set ',rawData appending: ':'.
			].
			style == #unaryGetter ifTrue: [
				rawData _ self unSpaceAndUpShift: 'get ',rawData appending: nil.
			].
			(#(keyword2 methodHeader2) includes: style)  ifTrue: [
				rawData _ self unSpaceAndUpShift: rawData appending: ':'.
			].
			rawData
		]
! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 7/19/2001 20:04'!
color: aColorOrSymbol

	| deselectedColor cc |
	aColorOrSymbol isColor ifTrue: [
		self valueOfProperty: #deselectedColor ifAbsent: ["record my color the first time"
			self setProperty: #deselectedColor toValue: aColorOrSymbol.
			^ super color: (self scaleColorByUserPref: aColorOrSymbol)].
		^ super color: aColorOrSymbol].

	deselectedColor _ self valueOfProperty: #deselectedColor ifAbsent: [nil].
	deselectedColor ifNotNil: [^ super color: (self scaleColorByUserPref: deselectedColor)].

	aColorOrSymbol == #comment  ifTrue: [^ self color: Color blue lighter].
	SyntaxMorph noTileColor ifTrue: [	"override"
		^ self color: Color transparent].	"Fix this to be real color!!"

	(cc _ self class translateColor: aColorOrSymbol) isColor
		ifTrue: [^ self color: cc]
		ifFalse: [Transcript show: aColorOrSymbol, ' needs to be handled in translateColor:'; cr.
			^ self color: Color transparent].	"help!!"! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 9/20/2001 12:43'!
dissectMessage
	"I am a MessageNode.  Return {receiverNode or nil, selector, (keyword nodes), (argument nodes)}.  Ignore all spacing morphs."

	! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'sw 2/3/2001 01:40'!
editor
	"In parallel with the interface for text morphs, we respond to this, but in our case we are our own editor"

	^ self! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 9/19/2001 15:39'!
enclosingPane
	"The object that owns this script layout"

	| oo higher |
	oo _ self owner.
	[higher _ oo isSyntaxMorph.
	higher _ higher or: [oo class == TransformMorph].
	higher _ higher or: [oo class == TwoWayScrollPane].
	higher ifFalse: [^ oo].
	higher] whileTrue: [oo _ oo owner].
! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 9/7/2001 16:13'!
getCurrentValue

	parseNode ifNil: [^nil].
	parseNode class == Symbol ifTrue: [^nil].	"special"
	^parseNode currentValueIn: self hostContext! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 18:48'!
messageNode
	"Return the enclosing messageNode that is the full message.  It has a receiver."

	^self orOwnerSuchThat: [:oo | oo receiverNode notNil]! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'RAA 8/15/1999 16:23'!
parseNode
	
	^parseNode
		
	! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'RAA 8/15/1999 16:11'!
parseNode: x
	
	parseNode _ x
		
	! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'di 11/17/2000 08:07'!
parsedInClass

	^ self rootTile parseNode encoder classEncoding! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 11/15/2000 14:39'!
parsedInClass: x

	self parsedInClass == x ifFalse: [self error: 'inconsistent value']! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 9/25/2001 11:28'!
readOut
	"Find and return an UpdatingStringMorph, possibly in a NumericReadoutTile"

	^ ((self findA: NumericReadoutTile) ifNil: [^ nil]) findA: UpdatingStringMorph! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 7/23/2001 18:04'!
receiverNode
	"If I am (have) a MessageNode, return the node of the receiver.  Watch out for foolish noise words."

	parseNode class == MessageNode ifFalse: [^ nil].
	parseNode receiver ifNil: [^ nil].
	submorphs do: [:ss | 
		ss isSyntaxMorph ifTrue: [
			ss parseNode ifNotNil: ["not noise word"
				ss isNoun ifTrue: [^ ss] 
					ifFalse: [^ nil "found selector"]]]].
	^ nil! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 9/23/2001 00:27'!
receiverObject
	"Return some object that could be the receiver to me (a selector).  Either the actual object who is the receiver in this message, or a guy of the right class."

	| rec value mm |
	(rec _ owner) isSyntaxMorph ifFalse: [^ nil].
	rec _ rec receiverNode.
	rec ifNil: [(rec _ owner owner) isSyntaxMorph ifFalse: [^ nil].
				rec _ rec receiverNode].	
	rec ifNil: [(rec _ owner owner owner) isSyntaxMorph ifFalse: [^ nil].
				rec _ rec receiverNode].
	rec isSelfTile ifTrue: [
		^ ((mm _ self containingWindow model) respondsTo: #targetObject) 
			ifTrue: [mm targetObject]
			ifFalse: [mm selectedClassOrMetaClass new]].
	value _ rec ifNotNil: [rec try].
	value class == Error ifTrue: [
		value _ Vocabulary instanceWhoRespondsTo: self selector].
	^ value! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 1/13/2001 20:08'!
rename: newSelector
	| keywords mainSel list last |
	"Attempt to change the name as listed in my tiles.  Can change the number of argumtents.  MethodNode (SelectorNode (SelectorNode (string))) or MethodNode (SelectorNode (SelectorNode (string) TempVarNode() SelectorNode (string) TempVarNode()))"

	self isMethodNode ifFalse: [
		self rootTile == self ifTrue: [^ self].  "not in a script"
		^ self rootTile rename: newSelector  "always do at the root"].

	keywords _ newSelector keywords.
	mainSel _ self findA: SelectorNode.
	list _ mainSel submorphs select: [:mm | 
		mm isSyntaxMorph and: [mm parseNode class == SelectorNode]].
	1 to: (list size min: keywords size) do: [:ind |
		((list at: ind) findA: UpdatingStringMorph) contents: (keywords at: ind)].
	keywords size + 1 to: list size do: [:ind | "removing keywords"
		[last _ mainSel submorphs last.
		 (last isSyntaxMorph and: [last parseNode class == TempVariableNode])] whileFalse: [
				last delete].
		[last _ mainSel submorphs last.
		 (last isSyntaxMorph and: [last parseNode class == SelectorNode])] whileFalse: [
				last delete].	"the TempVariableNode and others"
		mainSel submorphs last delete.	"the SelectorNode"
		].
	list size + 1 to: keywords size do: [:ind | "adding keywords"
		"add a SelectorNode, add a spacer, add a TempVarNode"
		mainSel addToken: (keywords at: ind) type: #keyword1 
			on: (SelectorNode new key: (keywords at: ind) code: nil).
		mainSel addMorphBack: (mainSel transparentSpacerOfSize: 4@4).
		(TempVariableNode new name: 'arg', ind printString index: ind type: nil scope: nil)
			 asMorphicSyntaxIn: mainSel].! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 13:41'!
selector
	"Find the selector I represent, or have inside of me.  My parseNode is a SelectorNode or a MessageNode."

	| sel cnt |
	parseNode class == SelectorNode 
		ifTrue: [^self decompile asString asSymbol].
	parseNode class == KeyWordNode ifTrue: [^self decompile asString asSymbol].
	parseNode class == MessageNode | (parseNode class == MessagePartNode) 
		ifFalse: [^nil].
	"Must be one of those to have a selector"
	"Beware of messageParts.  If MessagePartNode, only returns this one keyword."
	sel := ''.
	cnt := 0.
	submorphs do: 
			[:mm | 
			mm isSyntaxMorph 
				ifTrue: 
					[cnt := cnt + 1.
					(mm nodeClassIs: SelectorNode) ifTrue: [^mm selector].
					(mm nodeClassIs: MessagePartNode) ifTrue: [sel := sel , mm selector].
					(mm nodeClassIs: KeyWordNode) ifTrue: [sel := sel , mm decompile asString].
					(mm nodeClassIs: ReturnNode) ifTrue: [cnt := cnt - 1].
					(mm nodeClassIs: MessageNode) 
						ifTrue: 
							[parseNode receiver ifNil: [sel := mm selector].
							cnt = 2 & (sel isEmpty) 
								ifTrue: 
									["not the receiver.  Selector and arg"

									sel := mm selector]]]].
	sel ifNil: [^nil].
	sel notEmpty ifTrue: [^sel asSymbol].
	^nil! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'aoy 2/15/2003 21:31'!
unSpaceAndUpShift: aString appending: extraChars 
	| answer upShiftNext |
	answer := WriteStream on: String new.
	upShiftNext := false.
	aString do: 
			[:ch | 
			upShiftNext :=( ch == Character space) 
				ifTrue: [ true]
				ifFalse: 
					[answer nextPut: (upShiftNext ifTrue: [ch asUppercase] ifFalse: [ch]).
					 false]].
	answer := answer contents.
	extraChars isEmptyOrNil ifTrue: [^answer].
	(answer endsWith: extraChars) ifFalse: [answer := answer , extraChars].
	^answer! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 11/12/2000 14:42'!
userScriptSelector
	"user wrote this script"

	^ self valueOfProperty: #userScriptSelector! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 11/12/2000 14:41'!
userScriptSelector: sel
	"user wrote this script"

	self setProperty: #userScriptSelector toValue: sel.! !


!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 16:03'!
aSimpleStringMorphWith: aString

	self alansTest1 ifTrue: [
		^StringMorph contents: aString font: self alansCurrentFontPreference
	].

	^StringMorph contents: aString! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 23:24'!
alansCurrentFontPreference

	^nil		"StrikeFont familyName: 'ComicBold' size: 16"! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 13:38'!
alansTemplateStyleFor: key

	(#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes: key) ifTrue: [^1].
	(#(do: collect:) includes: key) ifTrue: [^2].
	(#(if:do:) includes: key) ifTrue: [^3].
	^0
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/28/2001 13:46'!
anUpdatingStringMorphWith: aString special: aBoolean

	self alansTest1 ifTrue: [
		^(aBoolean ifTrue: [SyntaxUpdatingStringMorph] ifFalse: [UpdatingStringMorph])
			 contents: aString
			font: self alansCurrentFontPreference
	].
	^UpdatingStringMorph contents: aString! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 13:39'!
constructSelfVariant: receiver and: key

	| wordy |
	(receiver isKindOf: VariableNode) ifFalse: [^nil].
	receiver name = 'self'  ifFalse: [^nil].
	(wordy _ self translateFromWordySelfVariant: key) ifNil: [^nil].
	^wordy

! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 23:20'!
darkerColor

	^(Color r: 1.0 g: 0.839 b: 0.613)	"Color lightBrown lighter lighter."
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 23:23'!
fontToUseForSpecialWord: aString

	^(#('Yes' 'No' 'Test') includes: aString) ifTrue: [
		(StrikeFont familyName: 'Helvetica' size: 14)
	] ifFalse: [
		nil	"(StrikeFont familyName: 'ComicBold' size: 16)"
	]! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/28/2001 09:35'!
lighterColor

	^Color gray: 0.9		
"(Color r: 0.935 g: 0.935 b: 0.935)"
"paleGreen lighter"
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 8/7/2001 23:15'!
noiseBeforeBlockArg

	^ self alansTest1 ifTrue: [' Use'] ifFalse: [' from']! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 3/25/2001 17:16'!
noiseStringMorph: aNoiseString

	| sMorph |

	sMorph _ self aSimpleStringMorphWith: aNoiseString.
	sMorph 
		font: (self fontToUseForSpecialWord: aNoiseString); 
		setProperty: #noiseWord toValue: true.

	^sMorph
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 8/7/2001 23:12'!
noiseWordBeforeVariableNode: aNode string: aString

	(#('self' 'nil') includes: aString) ifFalse: [
		aNode code ifNil: [^'my'].
		aNode type < 4 ifTrue: [^'my']
	].
	^nil! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 22:50'!
setConditionalPartStyle

	self specialColor: self lighterColor andBorder: self darkerColor.
	self useRoundedCorners.
	self borderWidth: 1.
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/27/2001 07:34'!
setSpecialOuterTestFormat

	self 
		specialColor: self darkerColor 
		andBorder: self lighterColor.
	self useRoundedCorners.
	self layoutInset: 1.
	"self setProperty: #variableInsetSize toValue: 6."
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 22:50'!
setSpecialTempDeclarationFormat1

	"the outer template for temp defs"

	self 
		specialColor: self darkerColor 
		andBorder: self lighterColor.
	"self 
		specialColor: (Color lightYellow) 
		andBorder: (Color r: 0.581 g: 0.774 b: 0.903)."
	self useRoundedCorners.
	self layoutInset: 1.
	self cellPositioning: #center.
	"self setProperty: #variableInsetSize toValue: 6."
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 22:50'!
setSpecialTempDeclarationFormat2

	"the inner template for temp defs"

	self 
		specialColor: self lighterColor 
		andBorder:  self darkerColor.
	"self 
		specialColor: (Color r: 1.0 g: 1.0 b: 0.548) 
		andBorder:  (Color r: 0.581 g: 0.774 b: 0.903)."
	self useRoundedCorners.
	self layoutInset: 1.
	"self setProperty: #variableInsetSize toValue: 6."
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 7/27/2001 16:53'!
shouldBeBrokenIntoWords: aSymbol

	^#(methodHeader1 methodHeader2 keyword2 upArrow 
		tempVariable tempVariableDeclaration blockarg2 variable
		keywordGetz keywordSetter unaryGetter
		assignmentArrow) includes: aSymbol! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 13:44'!
specialColor: c1 andBorder: c2

	self color: (self scaleColorByUserPref: c1).
	self setProperty: #deselectedColor toValue: c1.
	self borderColor: (self scaleColorByUserPref: c2).
	self setProperty: #deselectedBorderColor toValue: c2.
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'yo 11/11/2002 10:32'!
splitAtCapsAndDownshifted: aString

	self flag: #yoCharCases.

	^String streamContents: [ :strm |
		aString do: [ :each | 
			each = $: ifFalse: [
				each isUppercase ifTrue: [strm nextPut: (Character value: 0);  
						 	nextPut: (Character value: 0); 
						 	nextPut: (Character value: 0); 
							nextPut: each asLowercase]
					ifFalse: [strm nextPut: each]
			].
		]
	].! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 23:01'!
standardCellPositioning

	^ self alansTest1 ifTrue: [#leftCenter] ifFalse: [#topLeft]! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 7/25/2001 17:33'!
standardInset

	parseNode class == BlockNode ifTrue: [^ 5@1].
		"allow pointing beside a line so can replace it"
	^ self alansTest1 ifTrue: [1] ifFalse: [-1]! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 4/4/2001 13:12'!
substituteKeywordFor: aString

	aString isEmpty ifTrue: [^aString asString].
	aString asString = '^ ' ifTrue: [^'answer'].
	aString asString = 'ifTrue:' ifTrue: [^'Yes'].
	aString asString = 'ifFalse:' ifTrue: [^'No'].
	aString asString = 'self' ifTrue: [^'self'].
	aString first isUppercase ifTrue: [^aString asString].

	^self splitAtCapsAndDownshifted: aString! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/28/2001 15:03'!
tokenVerticalSeparator

	^Morph new 
		color: Color transparent;
		extent: 3@3;
		lock
! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 13:45'!
translateFromWordySelfVariant: key

	#selfWrittenAsMe == key ifTrue: [^'me'].
	#selfWrittenAsMy == key ifTrue: [^'my'].
	#selfWrittenAsIll == key ifTrue: [^'I''ll'].
	#selfWrittenAsIm == key ifTrue: [^'I''m'].
	#selfWrittenAsThis == key ifTrue: [^'this'].
	^nil

! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 7/28/2001 09:05'!
translateToWordyGetter: key
	"  setBlob:  becomes  's blob _  "

	^ '''s ', 
	  (self splitAtCapsAndDownshifted: (key asString allButFirst: 3) 
			withFirstCharacterDownshifted)! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'RAA 2/26/2001 13:45'!
translateToWordySelfVariant: aString

	| lc |
	lc _ aString asLowercase.
	lc = 'me' ifTrue: [^#selfWrittenAsMe].
	lc = 'my' ifTrue: [^#selfWrittenAsMy].
	lc = 'i''ll' ifTrue: [^#selfWrittenAsIll].
	lc = 'i''m' ifTrue: [^#selfWrittenAsIm].
	lc = 'this' ifTrue: [^#selfWrittenAsThis].
	^nil

! !

!SyntaxMorph methodsFor: 'alans styles' stamp: 'tk 7/27/2001 17:26'!
translateToWordySetter: key
	"  setBlob:  becomes  's blob _  "

	^ '''s ', 
	  (self splitAtCapsAndDownshifted: (key asString allButFirst: 3) allButLast 
			withFirstCharacterDownshifted), 
	  ' _'! !


!SyntaxMorph methodsFor: 'card in a stack' stamp: 'tk 9/25/2001 11:46'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')"

	^ true! !


!SyntaxMorph methodsFor: 'card & stack' stamp: 'tk 9/25/2001 11:41'!
setNewContentsFrom: stringOrNumberOrNil
	"Using stringOrNumberOrNil as a guide, set the receiver's contents afresh.  If the input parameter is nil, the a default value stored in a property of the receiver, if any, will supply the new initial content.  This method is only called when a VariableDock is attempting to put a new value."

	(self readOut ifNil: [^ self]) setNewContentsFrom: stringOrNumberOrNil.! !

!SyntaxMorph methodsFor: 'card & stack' stamp: 'tk 11/4/2001 21:47'!
setTarget: aPlayer
	"Find my UpdatingStringMorph and set its getSelector, putSelector, and target"

	| updatingString |
	(updatingString _ self readOut) ifNil: [^ self].
	updatingString putSelector: (Utilities setterSelectorFor: self knownName).
	updatingString getSelector: (Utilities getterSelectorFor: self knownName).
	updatingString target: aPlayer. ! !


!SyntaxMorph methodsFor: 'change reporting' stamp: 'tk 9/28/2001 13:36'!
colorChangedForSubmorph: colorPatch
	| sel newSel cc ms phrase completeMsg |
	"reporting a color change"

	(self nodeClassIs: MessageNode) ifFalse: [^ nil].
	(sel _ self selector) ifNil: [^ nil].
	(Color colorNames includes: sel) | (sel == #r:g:b:) ifFalse: [^ nil].
		"a standard color name"
	"replace self with new tiles from the color"
	(newSel _ (cc _ colorPatch color) name) 
		ifNil: [ms _ MessageSend receiver: Color selector: #r:g:b: arguments: 
				(Array with: cc red with: cc green with: cc blue).
			phrase _ ms asTilesIn: Color globalNames: true]
		ifNotNil: [ms _ MessageSend receiver: Color selector: newSel arguments: #().
			phrase _ ms asTilesIn: Color globalNames: true].
	self deletePopup.
	completeMsg _ self isNoun ifTrue: [self] ifFalse: [owner].
	completeMsg owner replaceSubmorph: completeMsg by: phrase.
	"rec setSelection: {rec. nil. rec}."
	phrase acceptIfInScriptor.! !


!SyntaxMorph methodsFor: 'classification' stamp: 'di 11/2/2000 13:25'!
isSyntaxMorph
	^ true! !


!SyntaxMorph methodsFor: 'debugging' stamp: 'di 11/17/2000 07:59'!
debugger

	^ self rootTile valueOfProperty: #debugger! !

!SyntaxMorph methodsFor: 'debugging' stamp: 'di 11/17/2000 07:59'!
debugger: x

	self rootTile setProperty: #debugger toValue: x! !

!SyntaxMorph methodsFor: 'debugging' stamp: 'RAA 8/24/1999 12:35'!
hostContext

	^nil		"we don't have one"! !


!SyntaxMorph methodsFor: 'drawing' stamp: 'RAA 3/25/2001 16:16'!
drawOn: aCanvas

	super drawOn: aCanvas.
	self isBlockNode ifFalse: [^self].
	self alansTest1 ifTrue: [^self].

	self immediatelyBelowTheMethodNode ifTrue: [
		aCanvas fillRectangle: (self topLeft + (0@-1) extent: self width@1) color: Color gray
	] ifFalse: [
		aCanvas fillRectangle: (self topLeft + (1@1) extent: 2@(self height-2)) color: Color gray.
		aCanvas fillRectangle: (self topLeft + (1@1) extent: 4@1) color: Color gray.
		aCanvas fillRectangle: (self bottomLeft + (1@-1) extent: 4@1) color: Color gray
	].
! !

!SyntaxMorph methodsFor: 'drawing' stamp: 'tk 9/13/2001 15:13'!
lookTranslucent

	self setDeselectedColor.
	super color: (self color alpha: 0.25).
	submorphs do: [:mm | (mm respondsTo: #lookTranslucent) 
		ifTrue: [mm lookTranslucent]
		ifFalse: ["mm color: color"]].
! !


!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'di 1/29/2001 16:23'!
cleanupAfterItDroppedOnMe
	"A tile just dropped into me.  Clean up"

	self layoutChanged.  "** Isn't this already implied by the addMorph: ?"
	"Auto-accept on drop if in a scriptor"
	self acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'di 5/4/2001 13:16'!
highlightForDrop: evt

	(self wantsDroppedMorph: evt hand firstSubmorph event: evt)
		ifTrue: [self color: self dropColor].! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 7/19/2001 19:04'!
justDroppedInto: aMorph event: evt
	aMorph isSyntaxMorph ifFalse:
		[Preferences tileTranslucentDrag
			ifTrue: [self setDeselectedColor]
			ifFalse: [self align: self topLeft with: self topLeft - self cursorBaseOffset]].
	self removeProperty: #beScript.
	^ super justDroppedInto: aMorph event: evt! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 9/30/2001 11:09'!
morphToDropInPasteUp: aPasteUp
	"If property #beScript is true, create a scriptor around me."

	| actualObject itsSelector aScriptor adjustment handy tw blk |
	(self valueOfProperty: #beScript ifAbsent: [false]) ifFalse: [^ self].
	self removeProperty: #beScript.
	actualObject _ self actualObject ifNil: [
					self valueOfProperty: #scriptedPlayer ifAbsent: [nil]].
	actualObject ifNil: [^ self].
	self removeProperty: #scriptedPlayer.
	actualObject assureUniClass.

	itsSelector _ self userScriptSelector.
	aScriptor _ itsSelector isEmptyOrNil
		ifFalse:
			[adjustment _ 0@0.
			actualObject scriptEditorFor: itsSelector]
		ifTrue:
			[adjustment _ 60 @ 20.
			actualObject newScriptorAround: self].
	aScriptor ifNil: [^self].
	handy _ aPasteUp primaryHand.

	aScriptor position: handy position - adjustment.
	aPasteUp addMorphFront: aScriptor.	"do this early so can find World"
	aScriptor showingMethodPane ifFalse: [
		"(tw _ aScriptor findA: TwoWayScrollPane) ifNil:
			[itsSelector ifNil: ['blank script'.
				tw _ aScriptor findA: TwoWayScrollPane.
				blk _ (tw scroller findA:  SyntaxMorph ""MethodNode"") findA: BlockNode.
				blk addMorphFront: self]].
		"
		SyntaxMorph setSize: nil andMakeResizable: aScriptor.
		].
	^ aScriptor
! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 9/24/2001 10:04'!
structureMatchWith: aMorph
	| meNoun itNoun |
	"Return true if the node types would allow aMorph to replace me.  This tests the gross structure of the method only."

	meNoun _ self isNoun.
	itNoun _ aMorph isNoun.

	"Consider these nouns to be equal:  TempVariableNode, LiteralNode, VariableNode, (MessageNode with receiver), CascadeNode, AssignmentNode"
	meNoun & itNoun ifTrue: [^ true].
	meNoun & aMorph isBlockNode ifTrue: [^ true].

	"If I am a BlockNode, and it is a TempVariableNode, add it into list"
	"If I am a BlockNode, and it is a noun, add it as a new line"
	self isBlockNode ifTrue:
		[itNoun ifTrue: [^ true].
		(aMorph nodeClassIs: ReturnNode) ifTrue:
			[^ (self submorphs
				detect: [:mm | ((mm isSyntaxMorph) and: [mm nodeClassIs: ReturnNode])]
				ifNone: [nil]) isNil].	"none already in this block"
				"If I am a BlockNode, and it is a ReturnNode, add to end"
		(aMorph nodeClassIs: CommentNode) ifTrue: [^ true]].

	(self isMethodNode) ifTrue: [^ false].	"Later add args and keywords"
		"Later allow comments to be dropped in"
		"Add MethodTemps by dropping into the main block"

	(self nodeClassIs: ReturnNode) & (aMorph parseNode class == MessageNode) 
		ifTrue: [^ true].		"Command replace Return"
	(self nodeClassIs: MessageNode) & (aMorph parseNode class == ReturnNode) ifTrue: [
		(owner submorphs select: [:ss | ss isSyntaxMorph]) last == self
			ifTrue: [^ true]].	"Return replace last command"

	(aMorph nodeClassIs: AssignmentNode) ifTrue: [
		itNoun ifFalse: ["create a new assignment"
			^ self isAVariable & self isDeclaration not]].	"only assign to a variable"

	"If nodes are of equal class, replace me with new one."
	(self nodeClassIs: aMorph parseNode class) ifTrue: [
		(self nodeClassIs: MessageNode) 
				ifFalse: [^ true]	"normal match"
				ifTrue: [^ self receiverNode == aMorph receiverNode]].	"both nil"

	^ false "otherwise reject"
! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'gm 2/22/2003 12:49'!
wantsDroppedMorph: aMorph event: evt 
	"For the moment, you have to drop it the right place.  We do not look at enclosing morphs"

	"Two ways to do this:  Must always destroy old node, then drag in new one.
		Or, drop replaces what you drop on.  Nasty with blocks."

	(aMorph isSyntaxMorph) ifFalse: [^false].
	(self structureMatchWith: aMorph) ifFalse: [^false].	"gross structure"

	"Only look at types if NoviceMode -- building EToys"
	^self okToBeReplacedBy: aMorph	"test the types"

	"^ true"! !


!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/8/2000 22:05'!
cursorBaseOffset

	^ 7@14
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/6/2000 16:20'!
handlesKeyboard: evt
	^ evt keyCharacter = Character backspace! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 13:39'!
handlesMouseDown: evt 
	evt yellowButtonPressed ifTrue: [^true].
	parseNode isNil ifTrue: [^false].
	owner isSyntaxMorph 
		ifTrue: [(owner isMethodNode and: [self isBlockNode not]) ifTrue: [^false]].	"Can only take block out of a MethodNode"
	^true! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'tk 10/26/2000 16:58'!
handlesMouseOver: evt
	"Am I a tile that could be picked up?"

	^ true! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/6/2000 08:21'!
handlesMouseOverDragging: evt

	^ evt hand hasSubmorphs
		and: [evt hand firstSubmorph isSyntaxMorph]
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/17/2000 08:21'!
keyStroke: evt
	"Handle a keystroke event."
	| spacer |
	evt keyCharacter = Character backspace ifTrue:
		[(owner notNil and: [owner isSyntaxMorph]) ifTrue:
			[owner isBlockNode ifTrue:
				["Delete a statement."
				(spacer _ self submorphAfter) class == AlignmentMorph
						ifTrue: [spacer delete].
				self delete].
			]].
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'tk 9/26/2001 05:56'!
mouseDown: evt 
	| dup rootTile |
	evt yellowButtonPressed ifTrue: [^ self showMenu: evt].
	(rootTile _ self rootTile) isMethodNode ifTrue:
		[self currentSelectionDo:
			[:innerMorph :mouseDownLoc :outerMorph |
			(outerMorph notNil and: [self == innerMorph])
				ifTrue: ["Click on prior selection -- record click point."
						self setSelection: {self. evt cursorPoint. outerMorph}]
				ifFalse: ["A new selection sequence."
						self setSelection: {self. evt cursorPoint. nil}]].
		^ self].

	"Out in the world -- treat as a unit"
	rootTile isSticky ifTrue: [^ self].	"later may allow to be selected"
	rootTile isPartsDonor 
		ifTrue: [dup _ rootTile duplicate.
				dup setProperty: #beScript toValue: true]
		ifFalse: [dup _ rootTile].
	evt hand attachMorph: dup.
	Preferences tileTranslucentDrag
		ifTrue: [^ dup lookTranslucent]
		ifFalse: [^ dup align: dup topLeft with: evt hand position + self cursorBaseOffset]
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'tk 7/19/2001 20:21'!
mouseEnter: evt
	"Highlight this level as a potential grab target"

"Transcript cr; print: self; show: ' enter'."
	self rootTile isMethodNode ifFalse: [^ self]. 	"not in a script"
	self unhighlightOwnerBorder.
	self highlightForGrab: evt.
	evt hand newKeyboardFocus: self.
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'tk 7/25/2001 10:09'!
mouseEnterDragging: evt
	"Highlight this level as a potential drop target"

"self isBlockNode ifTrue: [Transcript cr; print: self; show: ' enterDragging']."
	self rootTile isMethodNode ifFalse: [^ self]. 	"not in a script"

	evt hand hasSubmorphs ifFalse: [^ self].  "Don't react to empty hand"
	self unhighlightOwnerBorder.
	self isBlockNode ifFalse: [self highlightForDrop: evt.
		(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m color = self dropColor]])
			ifNotNilDo: [:m | m unhighlight]].

	self isBlockNode ifTrue:
		[(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]])
			ifNotNilDo: [:m | "Suspend outer block."
						m stopStepping; removeDropZones].
		self startStepping]
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:48'!
mouseLeave: evt 
	"Move grab highlight back out a level"

	"Transcript cr; print: self; show: ' leave'."

	self rootTile isMethodNode ifFalse: [^self].	"not in a script"
	self unhighlightBorder.
	(owner notNil and: [owner isSyntaxMorph]) 
		ifTrue: [owner highlightForGrab: evt]! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:48'!
mouseLeaveDragging: evt 
	"Transcript cr; print: self; show: ' leaveDragging'."

	self rootTile isMethodNode ifFalse: [^self].	"not in a script"
	self isBlockNode 
		ifTrue: 
			[self
				stopStepping;
				removeDropZones.
			(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]]) 
				ifNotNilDo: [:m | m startStepping].	"Activate outer block."
			self submorphs do: 
					[:ss | 
					"cancel drop color in line beside mouse"

					ss color = self dropColor ifTrue: [ss setDeselectedColor]]].

	"Move drop highlight back out a level"
	self unhighlight.
	(owner notNil and: [owner isSyntaxMorph]) 
		ifTrue: [owner isBlockNode ifFalse: [owner highlightForDrop: evt]]! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'tk 10/17/2001 13:41'!
mouseMove: evt
	| dup selection |
	owner isSyntaxMorph ifFalse: [^ self].

false ifTrue: ["for now, do not drag off a tile"
	self currentSelectionDo:
		[:innerMorph :mouseDownLoc :outerMorph |
		mouseDownLoc ifNotNil: [
			(evt cursorPoint dist: mouseDownLoc) > 4 ifTrue:
				["If drag 5 pixels, then tear off a copy of outer selection."
				selection _ outerMorph ifNil: [self].
				selection deletePopup.
				evt hand attachMorph: (dup _ selection duplicate).
				Preferences tileTranslucentDrag
					ifTrue: [dup lookTranslucent]
					ifFalse: [dup align: dup topLeft
								with: evt hand position + self cursorBaseOffset].
				self setSelection: nil.	"Why doesn't this deselect?"
				(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]])
					ifNotNilDo: [:m | "Activate enclosing block."
								m startStepping]]]].
	].! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/17/2000 08:13'!
mouseUp: evt
	| newSel |
	self rootTile isMethodNode ifFalse: [^ self].
	self currentSelectionDo:
		[:innerMorph :mouseDownLoc :outerMorph |
		newSel _ outerMorph
			ifNil: [self "first click"]
			ifNotNil: [(outerMorph firstOwnerSuchThat:
							[:m | m isSyntaxMorph and: [m isSelectable]]) ifNil: [self]].
		newSel isMethodNode ifTrue: [^ self setSelection: nil].
		self setSelection: {self. nil. newSel}]
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'tk 12/1/2000 15:42'!
wantsKeyboardFocusFor: aSubmorph
	| doEdit |
	"only let strings edit on shift-click.  Editing on ordinary click defeats the brown selection and tile dragging."

	doEdit _ self world primaryHand lastEvent shiftPressed.
	doEdit ifTrue: ["remove the arrows during editing"
		self valueOfProperty: #myPopup ifPresentDo: [:panel |
			panel delete. self removeProperty: #myPopup]].
	^ doEdit! !


!SyntaxMorph methodsFor: 'formatting options' stamp: 'di 2/21/2001 11:42'!
alansTest1
	
	| root |

	root _ self rootTile ifNil: [self].
	^root valueOfProperty: #alansNewStyle ifAbsent: [self usingClassicTiles not]! !

!SyntaxMorph methodsFor: 'formatting options' stamp: 'RAA 2/26/2001 09:02'!
controlContrast2: evt

	| origin scale startingContrastX |

	evt isMouseUp ifTrue: [
		^self removeProperty: #startingPointForSomeAdjustment
	].
	evt isMouseDown ifTrue: [
		^self setProperty: #startingPointForSomeAdjustment toValue: evt cursorPoint
	].
	ContrastFactor ifNil: [ContrastFactor _ 0.5].
	scale _ 200.0.
	startingContrastX _ ContrastFactor * scale.
	origin _ self valueOfProperty: #startingPointForSomeAdjustment.
	ContrastFactor _ (evt cursorPoint x - origin x + startingContrastX) / scale min: 1.0 max: 0.0.
	self finalAppearanceTweaks.
! !

!SyntaxMorph methodsFor: 'formatting options' stamp: 'RAA 2/26/2001 09:07'!
controlContrast: evt

	"old version. may be some scripts saved with me, so don't crash"
	^self! !

!SyntaxMorph methodsFor: 'formatting options' stamp: 'RAA 5/11/2001 07:41'!
controlSpacing2: evt

	| origin scale startingContrastX |

	evt isMouseUp ifTrue: [
		^self removeProperty: #startingPointForSomeAdjustment
	].
	evt isMouseDown ifTrue: [
		^self setProperty: #startingPointForSomeAdjustment toValue: evt cursorPoint
	].
	SizeScaleFactor ifNil: [SizeScaleFactor _ 0.15].
	scale _ 200.0.
	startingContrastX _ SizeScaleFactor * scale.
	origin _ self valueOfProperty: #startingPointForSomeAdjustment.
	SizeScaleFactor _ (evt cursorPoint x - origin x + startingContrastX) / scale min: 1.0 max: 0.0.
	self finalAppearanceTweaks.
! !

!SyntaxMorph methodsFor: 'formatting options' stamp: 'RAA 2/26/2001 09:07'!
controlSpacing: evt

	"old version. may be some scripts saved with me, so don't crash"
	^self! !

!SyntaxMorph methodsFor: 'formatting options' stamp: 'di 2/21/2001 12:30'!
lookClassic
	self isLeafTile ifTrue: [self layoutInset: 2@4]! !

!SyntaxMorph methodsFor: 'formatting options' stamp: 'tk 7/18/2001 16:00'!
usingClassicTiles 

	^ Preferences uniTilesClassic! !


!SyntaxMorph methodsFor: 'highlighting' stamp: 'tk 7/30/2001 14:48'!
compoundBorderColor 

	^ self valueOfProperty: #deselectedBorderColor ifAbsent: [Color veryLightGray]
! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/5/2000 07:26'!
dropColor
	^ Color green darker! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'tk 7/23/2001 18:28'!
grabColor

	"Not the select color, but the mouseOver border color.  Means it could be grabbed"
	^ Color paleOrange mixed: 0.5 with: Color brown! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/6/2000 09:22'!
highlightForGrab: evt

	self borderColor: self grabColor.! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'tk 7/19/2001 19:09'!
stdBorderColor 

	"put choices of how to do the border here"
	^ self valueOfProperty: #deselectedBorderColor ifAbsent: [Color transparent]! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'tk 7/19/2001 19:50'!
unhighlight

	self setDeselectedColor.


false ifTrue: [
	self currentSelectionDo: [:innerMorph :mouseDownLoc :outerMorph |
		self color: ( false
			"(self == outerMorph or: [owner notNil and: [owner isSyntaxMorph not]])"
				ifTrue: [self valueOfProperty: #deselectedBorderColor ifAbsent: [#raised]]
				ifFalse: [self color: Color transparent]
		)
	]].
! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 5/4/2001 13:21'!
unhighlightBorder

	self currentSelectionDo: [:innerMorph :mouseDownLoc :outerMorph |
		self borderColor: (
			(self == outerMorph or: [owner notNil and: [owner isSyntaxMorph not]])
				ifTrue: [self valueOfProperty: #deselectedBorderColor ifAbsent: [#raised]]
				ifFalse: [self stdBorderColor]
		)
	]
! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'dgd 2/22/2003 18:48'!
unhighlightOwner
	"Unhighlight my owner"

	(owner notNil and: [owner isSyntaxMorph]) ifTrue: [owner unhighlight]! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'dgd 2/22/2003 18:49'!
unhighlightOwnerBorder
	"Unhighlight my owner's border"

	(owner notNil and: [owner isSyntaxMorph]) 
		ifTrue: [owner unhighlightBorder]! !


!SyntaxMorph methodsFor: 'initialization' stamp: 'sw 3/6/2001 11:26'!
inAPluggableScrollPane
	"Answer a PluggableTileScriptorMorph that holds the receiver"

	| widget |
	widget _ PluggableTileScriptorMorph new.
	widget extent: 10@10; borderWidth: 0.
	widget scroller addMorph: self.
	widget setScrollDeltas.
	widget hResizing: #spaceFill; vResizing: #spaceFill.
	^ widget

! !

!SyntaxMorph methodsFor: 'initialization' stamp: 'sw 6/26/2001 10:58'!
inAScrollPane
	"Answer a scroll pane in which the receiver is scrollable"

	^ self inATwoWayScrollPane! !

!SyntaxMorph methodsFor: 'initialization' stamp: 'di 1/31/2001 10:14'!
openInWindow

	| window widget sel |
	sel _ ''.
	self firstSubmorph allMorphs do: [:rr | 
			(rr isKindOf: StringMorph) ifTrue: [sel _ sel, rr contents]].
	window _ (SystemWindow labelled: 'Tiles for ', self parsedInClass printString, '>>',sel).
	widget _ self inAScrollPane.
	widget color: Color paleOrange.
	window
		addMorph: widget
		frame: (0@0 extent: 1.0@1.0).
	window openInWorldExtent: (
		self extent + (20@40) min: (Display boundingBox extent * 0.8) rounded
	)

! !

!SyntaxMorph methodsFor: 'initialization' stamp: 'FBS 2/24/2004 14:21'!
returnNode: aNode expression: expr

	| row expMorph sMorph aNoiseString |
	row _ self addRow: #return on: aNode.
	self alansTest1 ifTrue: [
		row setSpecialOuterTestFormat.
		aNoiseString _ ' Reply '.
		sMorph _ self aSimpleStringMorphWith: aNoiseString.
		sMorph 
			emphasis: TextEmphasis bold emphasisCode;
			setProperty: #syntacticallyCorrectContents toValue: '^'.

		row addMorphBack: sMorph.
	] ifFalse: [
		row addToken: '^ ' type: #upArrow on: aNode.
	].
	expMorph _ expr asMorphicSyntaxIn: row.
	self alansTest1 ifTrue: [
		(expMorph hasProperty: #deselectedColor) ifFalse: [expMorph setConditionalPartStyle].
	].
	expr addCommentToMorph: row.
	^row
! !

!SyntaxMorph methodsFor: 'initialization' stamp: 'tk 1/19/2001 13:29'!
sample: arg1
"a comment"
| temp1 |
temp1 _ 5.
temp1 yourself.
temp1 min: arg1.! !


!SyntaxMorph methodsFor: 'insertion drop zones' stamp: 'di 1/30/2001 21:00'!
removeDropZones
	"Remove the insertion drop-zone morphs."

	self submorphsDo:
		[:mm | (mm isMemberOf: BorderedMorph) ifTrue: [mm delete]].
! !

!SyntaxMorph methodsFor: 'insertion drop zones' stamp: 'tk 9/13/2001 15:24'!
trackDropZones
	| hand i localPt insertion insHt ii prevBot nxtHt d c1 c2 ht2 spacer1 spacer2 wid ht1 dc each |
	hand _ self primaryHand.
	("hand lastEvent redButtonPressed &" hand hasSubmorphs
		and: [(self hasOwner: hand) not]) ifFalse: [^ self].

	insertion _ hand firstSubmorph renderedMorph.
	insertion isSyntaxMorph ifFalse: [^ self].
	insertion isNoun ifFalse: [(insertion nodeClassIs: CommentNode) ifFalse: [^ self]].
	localPt _ self globalPointToLocal: hand position.
	insHt _ insertion height.  "**just use standard line height here"
	self removeDropZones.  "Maybe first check if in right place, then just tweak heights."
	i _ (ii _ self indexOfMorphAbove: localPt) min: submorphs size-1.
	prevBot _ i <= 0 ifTrue: [(self innerBounds) top]
					ifFalse: [(self submorphs at: i) bottom].
	nxtHt _ (submorphs isEmpty
		ifTrue: [insertion]
		ifFalse: [self submorphs at: i+1]) height.
	d _ ii > i ifTrue: [nxtHt "for consistent behavior at bottom"]
			ifFalse: [0 max: (localPt y - prevBot min: nxtHt)].

	"Top and bottom spacer heights cause continuous motion..."
	c1 _ Color transparent.  c2 _ Color transparent.
	ht2 _ d*insHt//nxtHt.  ht1 _ insHt - ht2.
	wid _ self width - (2*borderWidth) - (2*self layoutInset).
	wid isPoint ifTrue: [wid _ wid x].
	(spacer1 _ BorderedMorph newBounds: (0@0 extent: wid@ht1)
				color: (ht1 > (insHt//2) ifTrue: [c1] ifFalse: [c2]))
					borderWidth: 1; borderColor: spacer1 color.
	self privateAddMorph: spacer1 atIndex: (i+1 max: 1).
	(spacer2 _ BorderedMorph newBounds: (0@0 extent: wid@ht2)
				color: (ht2 > (insHt//2+1) ifTrue: [c1] ifFalse: [c2]))
					borderWidth: 1; borderColor: spacer2 color.
	spacer1 setProperty: #dropZone toValue: true.
	spacer2 setProperty: #dropZone toValue: true.
	self privateAddMorph: spacer2 atIndex: (i+3 min: submorphs size+1).
	self fullBounds.  "Force layout prior to testing for cursor containment"

	"Maintain the drop target highlight -- highlight spacer if hand is in it."
	{spacer1. spacer2} do:
		[:spacer | (spacer containsPoint: localPt) ifTrue:
			[spacer color: self dropColor.
			"Ignore border color.  Maybe do it later.
			self borderColor = self dropColor
				ifTrue: [self borderColor: self stdBorderColor]"]].
	"If no submorph (incl spacers) highlighted, then re-highlight the block."
	"Ignore border color.  Maybe do it later.
	((self wantsDroppedMorph: insertion event: hand lastEvent) and:
		[(self submorphs anySatisfy: [:m | m containsPoint: localPt]) not])
			ifTrue: [self borderColor: self dropColor].
	"

	"Dragging a tile within a Block, if beside a tile, color it a dropzone"
	"Transcript show: localPt y printString; space; show: submorphs first top 
		printString; space; show: submorphs last top printString; cr."
	dc _ self dropColor.
	1 to: ((ii+4 min: submorphs size) max: 1) do: [:ind | 
		each _ submorphs at: ind.
		each isSyntaxMorph ifTrue: [
			localPt y >= each top 
				ifTrue: ["in this one or beyond"
					(localPt y < each bottom) 
						ifTrue: [(each submorphs anySatisfy: [:m | 
								m containsPoint: localPt])
							ifTrue: [each setDeselectedColor]
							ifFalse: [each color: dc]]
						ifFalse: [each color = dc ifTrue: [each setDeselectedColor]]]
				ifFalse: [each color = dc ifTrue: [each setDeselectedColor]]]].
! !


!SyntaxMorph methodsFor: 'layout' stamp: 'tk 9/13/2001 15:28'!
acceptDroppingMorph: aMorph event: evt
	| itNoun old |
	"Two cases: 1) a phrase being dropped into a block.  Add a new line.
		2) aMorph is replacing self by dropping on it.
	For the moment, you have to drop it the right place (the end of a tile if it is complex).  We do not look at enclosing morphs"

	itNoun _ aMorph isNoun.
	self withAllOwnersDo:
		[:m | (m isSyntaxMorph and: [m isBlockNode])
				ifTrue: [m stopStepping; removeDropZones]].
	self isBlockNode & itNoun ifTrue:
		[(aMorph nodeClassIs: TempVariableNode) ifTrue:
				["If I am a BlockNode, and it is a TempVariableNode, add it into list"
				(self addBlockArg: aMorph)].
		"If I am a BlockNode and it is a noun add it as a new line"
		^ self addToBlock: aMorph event: evt].
				
	self isBlockNode ifTrue: [
		 (aMorph nodeClassIs: CommentNode) ifTrue: [^ self addToBlock: aMorph event: evt].
		 (aMorph nodeClassIs: ReturnNode) ifTrue: [^ self addToBlock: aMorph event: evt]].

	"Later add args and keywords.  later allow comments to be dropped"

	"Can't put statement, literal, assignment, or cascade into left side of assignment"
	(owner isSyntaxMorph) ifTrue:
		[(owner nodeClassIs: AssignmentNode) ifTrue:
			[(owner submorphIndexOf: self) = 1 ifTrue:
				[aMorph isAVariable ifFalse: [ ^ self]]]].

	(aMorph nodeClassIs: AssignmentNode) ifTrue: [
		itNoun ifFalse: ["create a new assignment"
			self isAVariable ifTrue: [^ self newAssignment]
					ifFalse: [^ self]]].	"only assign to a variable"

	aMorph deselect.
	(old _ owner) replaceSubmorph: self by: aMorph.	"do the normal replacement"
	(old isSyntaxMorph) ifTrue: [old cleanupAfterItDroppedOnMe].	"now owned by no one"
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'FBS 2/24/2004 14:24'!
addBlockArg: aMorph
	"Add a temporary to a block or the method.  Return true if succeed"
	"(aMorph nodeClassIs: TempVariableNode) is known to be true."
	"***NOTE: This method should be combined with addTempVar:"

	| tempHolder tt var nn |
	owner isMethodNode ifTrue: [
		^ (self addTempVar: aMorph)].	"Node for them is not inside the block"
		"If exists, drop the temp in this block and let user extend it."
	nn _ aMorph decompile string.	"name"
	(self isKnownVarName: nn) ifTrue: [^ false].	"already defined"

	tt _ self firstSubmorph.
	tempHolder _ tt firstSubmorph isSyntaxMorph 
				ifTrue: [(tt nodeClassIs: BlockArgsNode) 
							ifTrue: [tt] ifFalse: [nil]]
				ifFalse: [nil].

	tempHolder ifNil: ["make new row"
		tempHolder _ self addRow: #blockarg1 on: (BlockArgsNode new).
		tempHolder addNoiseString: self noiseBeforeBlockArg.
		tempHolder submorphs last firstSubmorph emphasis: TextEmphasis bold emphasisCode.
		tempHolder useRoundedCorners.

		self addMorphFront: tempHolder.
		aMorph parseNode name: nn key: nn code: nil.
		aMorph parseNode asMorphicSyntaxIn: tempHolder.
		tempHolder cleanupAfterItDroppedOnMe.
		^ true].

	"Know this variable is not present, so add it"

	aMorph parseNode name: nn key: nn code: nil.
	tempHolder addMorphBack: (tempHolder transparentSpacerOfSize: 4@4).
	var _ tempHolder addRow: #tempVariable on: aMorph parseNode.
	var layoutInset: 1.
	var addMorphBack: (self aSimpleStringMorphWith: nn).
	var cleanupAfterItDroppedOnMe.
	^ true
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'RAA 3/25/2001 16:15'!
addColumn: aColorOrSymbol on: aNode
	| col |
	self addMorphBack: (col _ self class column: aColorOrSymbol on: aNode).

"col setProperty: #howCreated toValue: thisContext longStack."

	self alansTest1 ifTrue: [
		(aColorOrSymbol == #block and: [self isMethodNode not]) ifTrue: [
			col setConditionalPartStyle.
		].
	].
	^ col
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'FBS 2/24/2004 14:44'!
addNoiseString: aNoiseString

	^self addNoiseString: aNoiseString emphasis: TextEmphasis normal emphasisCode.
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'RAA 3/25/2001 16:17'!
addNoiseString: aNoiseString emphasis: anInteger

	self alansTest1 ifFalse: [^self].
	^(self addColumn: #keyword1 on: nil)
		layoutInset: 1;
		addMorphBack: ((self noiseStringMorph: aNoiseString)  emphasis: anInteger)
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'RAA 2/15/2001 19:22'!
addRow: aColorOrSymbol on: aNode

	| row |
	self addMorphBack: (row _ self class row: aColorOrSymbol on: aNode).

"row setProperty: #howCreated toValue: thisContext longStack."

	^row
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/24/2001 15:15'!
addSingleKeywordRow: aStringLikeItem

	| row sMorph modifiedString |

	(row _ self class row: #text on: nil) borderWidth: 1.

	modifiedString _ self substituteKeywordFor: aStringLikeItem.
	sMorph _ self addString: modifiedString special: true.
	sMorph font: (self fontToUseForSpecialWord: modifiedString).
	modifiedString = aStringLikeItem ifFalse: [
		sMorph setProperty: #syntacticallyCorrectContents toValue: aStringLikeItem].

	row addMorph: sMorph.
	self addMorphBack: row.
	^row! !

!SyntaxMorph methodsFor: 'layout' stamp: 'RAA 4/4/2001 13:15'!
addString: literalOrVarName special: aBoolean

	| answer |
	"Create and return an UpdatingStringMorph containing the value.  Use an UpdatingStringMorph, so it can inform its owner when it has been edited. Keep the getSelector being nil"

	answer _ (self anUpdatingStringMorphWith: literalOrVarName special: aBoolean)
		target: self;
		putSelector: #acceptIgnoring:;
		useStringFormat.

	^answer
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'FBS 2/24/2004 14:23'!
addTempVar: aMorph 
	"know we are a block inside a MethodNode" 
	"(aMorph nodeClassIs: TempVariableNode) is known to be true."
	| tempHolder ii tt var nn |
	nn _ aMorph decompile string.	"name"
	(self isKnownVarName: nn) ifTrue: [^ false].	"already defined"

	tempHolder _ nil.
	(ii _ owner submorphIndexOf: self) = 1 ifFalse: [
		tt _ owner submorphs at: ii - 1.
		tt isSyntaxMorph ifTrue: [
			(tt nodeClassIs: MethodTempsNode) ifTrue: [tempHolder _ tt].
			(tt nodeClassIs: UndefinedObject) ifTrue: [tempHolder _ tt findA: MethodTempsNode]]].

	tempHolder ifNil: [
		tempHolder _ owner addRow: #tempVariable on: MethodTempsNode new.
		tempHolder addNoiseString: self noiseBeforeBlockArg.
		tempHolder submorphs last firstSubmorph emphasis: TextEmphasis bold emphasisCode.
		tempHolder useRoundedCorners.

		owner addMorph: tempHolder inFrontOf: self.
		aMorph parseNode name: nn key: nn code: nil.
		aMorph parseNode asMorphicSyntaxIn: tempHolder.
		tempHolder cleanupAfterItDroppedOnMe.
		^ true].

	aMorph parseNode name: nn key: nn code: nil.
	tempHolder addMorphBack: (tempHolder transparentSpacerOfSize: 4@4).
	var _ tempHolder addRow: #tempVariable on: aMorph parseNode.
	var layoutInset: 1.
	var addMorphBack: (self addString: nn special: false).
	var cleanupAfterItDroppedOnMe.
	^ true! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/10/2001 09:57'!
addTextRow: aStringLikeItem

	| row tt |
	(row _ self class row: #text on: nil) borderWidth: 1.
	(tt _ TextMorph new) contents: aStringLikeItem.
	row addMorph: tt.
	"row addMorph: (self addString: (aStringLikeItem copyWithout: Character cr) special: false)."
	self addMorphBack: row.
	^row! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 7/25/2001 10:01'!
addToBlock: aMorph event: evt
	"Insert a new line of code.  Figure out who it goes before.  If evt Y is within an existing line (to the right of a tile), then replace that tile."

	| whereDropped dropBefore replace |
	whereDropped _ "self pointFromWorld:" evt cursorPoint.
	dropBefore _ self submorphs 
		detect: [:each | each isSyntaxMorph ifTrue: [
			whereDropped y < each top ifTrue: [true]	"before this one"
				ifFalse: [whereDropped y < each bottom 
							ifTrue: [replace _ true]	"replace this one"
							ifFalse: [false]]]] "try next line"
		ifNone: [nil].
	(aMorph nodeClassIs: ReturnNode) ifTrue: [dropBefore _ nil].
		"Returns are always at the end. (Watch out for comments)"

	dropBefore 
		ifNil: [self addMorphBack: aMorph]
		ifNotNil: [
			replace ifNotNil: [aMorph deselect.
				self replaceSubmorph: dropBefore by: aMorph.	"replace it!!"
				^ dropBefore cleanupAfterItDroppedOnMe].	"now owned by no one"
			self addMorph: aMorph inFrontOf: dropBefore].
	self cleanupAfterItDroppedOnMe.
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'FBS 2/24/2004 14:22'!
addToken: aString type: aColorOrSymbol on: aNode

	| sMorph modifiedString noiseWord row |

	row _ (self addRow: aColorOrSymbol on: aNode) layoutInset: 1.
	self alansTest1 ifFalse: [
		sMorph _ self addString: aString special: false.
		row addMorphBack: sMorph.
		^row
	].

	noiseWord _ [ :w |
		w ifNotNil: [
			row 
				addMorphBack: (self noiseStringMorph: w);
				addMorphBack: (self tokenVerticalSeparator)
		].
	].
	(self shouldBeBrokenIntoWords: aColorOrSymbol) ifTrue: [
		modifiedString _ self substituteKeywordFor: aString.
		sMorph _ self addString: modifiedString special: (aColorOrSymbol ~= #assignmentArrow).
			"(#(unary keywordGetz keywordSetter unaryGetter) includes: aColorOrSymbol)"
		modifiedString = aString ifFalse: [
			sMorph setProperty: #syntacticallyCorrectContents toValue: aString].
		sMorph setProperty: #syntacticReformatting toValue: aColorOrSymbol;
			contents: modifiedString.
	] ifFalse: [
		sMorph _ self addString: (modifiedString _ aString) special: false.
	].
	(#(keyword2 upArrow) includes: aColorOrSymbol) ifTrue: [
		sMorph 
			font: (self fontToUseForSpecialWord: modifiedString).
	].
	(#(keyword2 unary assignmentArrow methodHeader1 methodHeader2) includes: aColorOrSymbol) ifTrue: [
		sMorph emphasis: TextEmphasis bold emphasisCode.
	].
	aColorOrSymbol == #blockarg1 ifTrue: [
	].
	(aColorOrSymbol == #variable or: [aColorOrSymbol == #tempVariable]) ifTrue: [
		aString = 'self' ifTrue: [
			sMorph setProperty: #wordyVariantOfSelf toValue: true.
		].
		noiseWord value: (self noiseWordBeforeVariableNode: aNode string: aString).
	].

	row addMorphBack: sMorph.
	^row! !

!SyntaxMorph methodsFor: 'layout' stamp: 'RAA 3/25/2001 17:22'!
addTokenSpecialCase: aString type: aColorOrSymbol on: aNode

	| sMorph modifiedString noiseWord col |

	noiseWord _ nil.
	sMorph _ self addString: aString special: false.
	(aColorOrSymbol == #keyword2) ifTrue: [
		modifiedString _ aString = 'if:' ifTrue: ['Test'] ifFalse: ['Yes'].
		sMorph 
			font: (self fontToUseForSpecialWord: modifiedString); 
			setProperty: #syntacticallyCorrectContents toValue: aString;
			contents: modifiedString.
	].

	col _ (self addRow: aColorOrSymbol on: aNode) layoutInset: 1.
	noiseWord ifNotNil: [
		col 
			addMorphBack: (self noiseStringMorph: noiseWord);
			addMorphBack: (self transparentSpacerOfSize: 3@1)
	].
	col addMorphBack: sMorph.
	^col! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/24/2001 15:21'!
addUnaryRow: aStringLikeItem style: aSymbol

	| row sMorph modifiedString fontToUse |

	(row _ self class row: #text on: nil) borderWidth: 1.
	modifiedString _ self substituteKeywordFor: aStringLikeItem.
	sMorph _ self addString: modifiedString special: true.
	fontToUse _ self fontToUseForSpecialWord: modifiedString.

	sMorph 
		font: fontToUse emphasis: 1;
		setProperty: #syntacticReformatting toValue: #unary.
	modifiedString = aStringLikeItem ifFalse: [
		sMorph setProperty: #syntacticallyCorrectContents toValue: aStringLikeItem].
	row addMorph: sMorph.
	self addMorphBack: row.
	^row! !

!SyntaxMorph methodsFor: 'layout' stamp: 'RAA 2/15/2001 19:43'!
foldMessage
	"I am a message whose receiver is wide, and whose message part is a column.
	Rearrange me so that the message part appears indented under the receiver part."
	| messageRow node2 |
	node2 _ parseNode copy receiver: nil.
	messageRow _ SyntaxMorph row: #keyword1 on: node2.

	messageRow 
		addMorph: (self transparentSpacerOfSize: 20@10);
		addMorphBack: submorphs last.		"<<handle noise words better"
	self listDirection: #topToBottom;
		wrapCentering: #topLeft;
		addMorphBack: (self transparentSpacerOfSize: 4@4);
		addMorphBack: messageRow.
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 1/15/2001 11:15'!
foldMessageOneArg
	"I am a message that is wide, a row with receiver and a row with selector and arg.
	Rearrange me so that the message part appears indented under the receiver part."
	| messageRow node2 |
	node2 _ parseNode copy receiver: nil.
	messageRow _ SyntaxMorph row: #keyword1 on: node2.
	messageRow addMorph: (self transparentSpacerOfSize: 20@10);
			addMorphBack: submorphs second;
			addMorphBack: submorphs second.  "was the third"
	self listDirection: #topToBottom;
		wrapCentering: #topLeft;
		addMorphBack: messageRow.
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/22/2001 16:30'!
isKnownVarName: newVarName
	"Return true if this variable is already known, as an argument, temp var, block temp, or instance variable."

	| syntLevel |
	(self parsedInClass allInstVarNames includes: newVarName) ifTrue: [^ true].
	syntLevel _ self.
	[syntLevel tempVarNodesDo: [:node | 
		node decompile string = newVarName ifTrue: [^ true]].
	 (syntLevel _ syntLevel owner) isSyntaxMorph] whileTrue.
	^ false! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/1/2001 13:06'!
removeReturnNode
	| blk |
	"If last line is ^ self, remove it.  I am a methodNode.  Keep if no other tiles in the block."

	blk _ self findA: BlockNode.
	blk submorphs last decompile string = '^self ' ifTrue: [
		(blk submorphs count: [:ss | ss isSyntaxMorph]) > 1 ifTrue: [
			blk submorphs last delete]].! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 8/22/2001 16:35'!
tempVarNodesDo: aBlock
	"Execute the block for any block temporary variables, method temps, or method args we have"

	| tempHolder argsHolder |
	((self parseNode class == MethodNode) or: [self parseNode class == BlockNode]) ifTrue: [
		self submorphsDoIfSyntax: [:sub | 
				(sub nodeClassIs: MethodTempsNode) ifTrue: [tempHolder _ sub].
				((sub nodeClassIs: UndefinedObject) and: [tempHolder isNil]) ifTrue: [
					tempHolder _ sub findA: MethodTempsNode].
				(sub nodeClassIs: BlockArgsNode) ifTrue: [tempHolder _ sub].
				(sub nodeClassIs: SelectorNode) ifTrue: [argsHolder _ sub].
				]
			ifString: [:sub | ].
		tempHolder ifNotNil: ["Temp variables"
			tempHolder submorphsDoIfSyntax: [:sm | 
					(sm nodeClassIs: TempVariableNode) ifTrue: [aBlock value: sm]]
				ifString: [:sm | ]].
		argsHolder ifNotNil: ["arguments"
			argsHolder submorphsDoIfSyntax: [:sm | 
					(sm nodeClassIs: TempVariableNode) ifTrue: [aBlock value: sm]]
				ifString: [:sm | ]].
		].
	"otherwise do nothing"! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 2/12/2001 14:39'!
try
	"Evaluate me once"

	(#(MessageNode LiteralNode VariableNode) includes: parseNode class name) 
		ifFalse: [^ Error new].
	^ [Compiler evaluate: self decompile
				for: self actualObject
				logged: false.	"should do something to the player"
		] ifError: [ :a :b | Error new].! !

!SyntaxMorph methodsFor: 'layout' stamp: 'ar 8/10/2003 18:19'!
unfoldMessage
	"I am a message whose message part is a column.
	Rearrange me so that the entire message is one row."
	| messageRow |
	messageRow _ self submorphs last.
	self removeMorph: messageRow.
	messageRow submorphs do: [:m | self addMorphBack: m].

! !


!SyntaxMorph methodsFor: 'macpal' stamp: 'sw 6/4/2001 19:26'!
currentVocabulary
	"Answer the current vocabulary associated with the receiver.  If none is yet set, determine an appropriate vocabulary and cache it within my properties dictionary."

	| aVocab aSym |
	aSym _ self valueOfProperty: #currentVocabularySymbol ifAbsent: [nil].
	aSym ifNil:
		[aVocab _ self valueOfProperty: #currentVocabulary ifAbsent: [nil].
		aVocab ifNotNil:
			[aSym _ aVocab vocabularyName.
			self removeProperty: #currentVocabulary.
			self setProperty: #currentVocabularySymbol toValue: aSym]].

	aSym ifNotNil:
		[^ Vocabulary vocabularyNamed: aSym].
	aVocab _ super currentVocabulary.
	self setProperty: #currentVocabularySymbol toValue: aVocab vocabularyName.
	^ aVocab! !


!SyntaxMorph methodsFor: 'menus' stamp: 'tk 9/27/2001 19:09'!
accept
	"Turn my current state into the text of a method.  Compile it in my class."

	^ self acceptInCategory: ClassOrganizer default! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 11/21/2000 16:35'!
acceptIfInScriptor
	| root |
	"If I am in a ScriptEditorMorph, tell my root to accept the new changes."

	(self ownerThatIsA: ScriptEditorMorph) ifNotNil: [
		root _ self rootTile.
		root ifNotNil: [root accept]]. ! !

!SyntaxMorph methodsFor: 'menus' stamp: 'RAA 2/14/2001 15:40'!
acceptIgnoring: aString
	"If I am inside a ScriptEditorMorph, tell my root to accept the new changes.  Ignore the argument, which is the string whose conents just changed."

	thisContext sender receiver removeProperty: #syntacticallyCorrectContents.
	self acceptIfInScriptor! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 9/27/2001 17:15'!
acceptInCategory: categoryString
	"Turn my current state into the text of a method.  Compile it in my class."
	| cls sc sel |
	self isMethodNode ifFalse: [
		self rootTile == self ifTrue: [^ self].  "not in a script"
		^ self rootTile accept  "always accept at the root"].
	(cls _ self parsedInClass) ifNil: [^ self].
	sel _ cls compile: self decompile classified: categoryString.
	(sc _ self firstOwnerSuchThat: [:mm | mm class == ScriptEditorMorph]) 
		ifNotNil: [sc hibernate; unhibernate].	"rebuild the tiles"
	^ sel! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 9/27/2001 19:12'!
acceptSilently
	"Turn my current state into the text of a method.
	Compile it in my class.  Don't rebuild the tiles."
	| cls |
	self isMethodNode ifFalse: [
		self rootTile == self ifTrue: [^ false].  "not in a script"
		^ self rootTile acceptSilently  "always accept at the root"].
	(self ownerThatIsA: ScriptEditorMorph) ifNil: [^ false].
	(cls _ self parsedInClass) ifNil: [^ false].
	cls compile: self decompile classified: 'scripts'.
	^ true! !

!SyntaxMorph methodsFor: 'menus' stamp: 'di 5/4/2001 12:14'!
acceptUnlogged
	"This is an exact copy of acceptSilently, except it does not log to the source file.
	Used for all but the last of scrolling number changes."
	| cls |
	self isMethodNode ifFalse:
		[self rootTile == self ifTrue: [^ self].  "not in a script"
		^ self rootTile acceptUnlogged  "always accept at the root"].
	(self ownerThatIsA: ScriptEditorMorph) ifNil: [^ self].
	(cls _ self parsedInClass) ifNil: [^ self].
	cls compile: self decompile
		classified: ClassOrganizer default
		withStamp: nil
		notifying: nil
		logSource: false.
! !

!SyntaxMorph methodsFor: 'menus' stamp: 'md 8/15/2005 11:02'!
decompile
	| stream |
	"Produce Smalltalk code.  We have a tree of SyntaxMorphs, but not a tree of ParseNodes.  The user has dragged in many SyntaxMorphs, each with its own parseNode, but those nodes are not sewn together in a tree.  The only data we get from a ParseNode is its class.
	We produce really ugly code.  But we compile it and decompile (prettyPrint) again for user to see."

	stream _ ColoredCodeStream on: (Text new: 400).
	self printOn: stream indent: 1.	"Tree walk and produce text of the code"
	^ stream contents! !

!SyntaxMorph methodsFor: 'menus' stamp: 'di 11/13/2000 20:23'!
getMenuBlock

	^ nil! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 9/23/2001 02:05'!
offerTilesMenuFor: aReceiver in: aLexiconModel
	"Offer a menu of tiles for assignment and constants"

	| menu |
	menu _ MenuMorph new addTitle: 'Hand me a tile for...'.
	menu addLine.
	menu add: '(accept method now)' target: aLexiconModel selector: #acceptTiles.
	menu submorphs last color: Color red darker.
	menu addLine.

	menu add: 'me, by name' target: self  selector: #attachTileForCode:nodeType: 
				argumentList: {'<me by name>'. aReceiver}.
	menu add: 'self' target: self  selector: #attachTileForCode:nodeType: 
				argumentList: {'self'. VariableNode}.
	menu add: '_   (assignment)' target: self  selector: #attachTileForCode:nodeType: 
				argumentList: {'<assignment>'. nil}.
	menu add: '"a Comment"' target: self  selector: #attachTileForCode:nodeType: 
				argumentList: {'"a comment"\' withCRs. CommentNode}.
	menu submorphs last color: Color blue.
	menu add: 'a Number' target: self  selector: #attachTileForCode:nodeType: 
				argumentList: {'5'. LiteralNode}.
	menu add: 'a Character' target: self  selector: #attachTileForCode:nodeType: 
				argumentList: {'$z'. LiteralNode}.
	menu add: '''abc''' target: self selector: #attachTileForCode:nodeType: 
				argumentList: {'''abc'''. LiteralNode}.
	menu add: 'a Symbol constant' target: self selector: #attachTileForCode:nodeType: 
				argumentList: {'#next'. LiteralNode}.
	menu add: 'true' target: self selector: #attachTileForCode:nodeType: 
				argumentList: {'true'. VariableNode}.
	menu add: 'a Test' target: self  selector: #attachTileForCode:nodeType: 
				argumentList: {'true ifTrue: [self] ifFalse: [self]'. MessageNode}.
	menu add: 'a Loop' target: self selector: #attachTileForCode:nodeType: 
				argumentList: {'1 to: 10 do: [:index | self]'. MessageNode}.
	menu add: 'a Block' target: self selector: #attachTileForCode:nodeType: 
				argumentList: {'[self]'. BlockNode}.
	menu add: 'a Class or Global' target: self selector: #attachTileForCode:nodeType: 
				argumentList: {'Character'. LiteralVariableNode}.
	menu add: 'a Reply' target: self selector: #attachTileForCode:nodeType: 
				argumentList: {'| temp | temp'. ReturnNode}.
	menu popUpAt: ActiveHand position forHand: ActiveHand in: World.
! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 9/17/2001 13:38'!
offerVarsMenuFor: aReceiver in: aLexiconModel
	"Offer a menu of tiles for assignment and constants"

	| menu instVarList cls |
	menu _ MenuMorph new addTitle: 'Hand me a tile for...'.
	menu addLine.
	menu add: '(accept method now)' target: aLexiconModel selector: #acceptTiles.
	menu submorphs last color: Color red darker.
	menu addLine.
	menu add: 'new temp variable' target: self selector: #attachTileForCode:nodeType: 
				argumentList: {'| temp | temp'. TempVariableNode}.

	instVarList _ OrderedCollection new.
	cls _ aReceiver class.
	[instVarList addAllFirst: cls instVarNames.
	 cls == aLexiconModel limitClass] whileFalse: [cls _ cls superclass].
	instVarList do: [:nn |
		menu add: nn target: self selector: #instVarTile: argument: nn].
	menu popUpAt: ActiveHand position forHand: ActiveHand in: World.

! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 12/14/2001 11:58'!
putOnBackground
	"Place the receiver, formerly private to its card, onto the shared background.  If the receiver needs data carried on its behalf by the card, such data will be represented on every card."

	| updStr |
	(updStr _ self readOut) ifNotNil: ["If has a place to put per-card data, set that up."
		updStr getSelector ifNotNil: [
			self setProperty: #holdsSeparateDataForEachInstance toValue: true]].
	super putOnBackground.! !

!SyntaxMorph methodsFor: 'menus' stamp: 'di 11/17/2000 09:00'!
showCode
	"Turn my current state into the text of a method.  Put it in a window."

	(Workspace new contents: self rootTile decompile) openLabel: self printString,' code'

	
! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 12/10/2001 17:48'!
showMenu: evt
	| menu |
	menu _ MenuMorph new.
	self rootTile isMethodNode ifTrue:
		[menu add: 'accept method' target: self selector: #accept.
		menu addLine.

		menu add: 'new temp variable' target: self selector: #attachTileForCode:nodeType: 
					argumentList: {'| temp | temp'. TempVariableNode}.
		menu addLine.

		self parsedInClass allInstVarNames do: [:nn |
			menu add: nn,' tile' target: self selector: #instVarTile: argument: nn].
		menu addLine.

		menu add: 'show code' target: self selector: #showCode.
		menu add: 'try out' target: self selector: #try.
		menu popUpAt: evt hand position forHand: evt hand in: World].



! !


!SyntaxMorph methodsFor: 'new tiles' stamp: 'FBS 2/24/2004 14:32'!
attachTileForCode: expression nodeType: nodeClass
	| nn master tile |
	"create a new tile for a part of speech, and put it into the hand"

	"a few special cases"
	expression = 'self' ifTrue: [
		^ (((self string: expression toTilesIn: Object) 
				findA: ReturnNode) findA: nodeClass) attachToHand].

	expression = '<me by name>' ifTrue: ["Tile for the variable in References"
		nn _ nodeClass knownName ifNil: [#+].
		(References at: nn asSymbol ifAbsent: [nil]) == nodeClass ifTrue: [
			^ self attachTileForCode: nn nodeType: LiteralVariableNode].
		"otherwise just give a tile for self"
		^ self attachTileForCode: 'self' nodeType: VariableNode].

	expression = '<assignment>' ifTrue: ["do something really special"
		master _ self class new.
		master addNoiseString: '  _  ' emphasis: TextEmphasis bold emphasisCode.
		tile _ master firstSubmorph.
		^ (tile parseNode: AssignmentNode new) attachToHand].	"special marker"
		"When this is dropped on a variable, enclose it in 
			a new assignment statement"

	"general case -- a tile for a whole line of code is returned"
	^ ((self string: expression toTilesIn: Object) 
				findA: nodeClass) attachToHand.! !

!SyntaxMorph methodsFor: 'new tiles' stamp: 'tk 9/7/2001 11:21'!
attachToHand
	"Adjust my look and attach me to the hand"

	self roundedCorners.
	ActiveHand attachMorph: self.
	Preferences tileTranslucentDrag
		ifTrue: [self lookTranslucent.
			self align: self center with: ActiveHand position "+ self cursorBaseOffset"]
		ifFalse: [self align: self topLeft with: ActiveHand position + self cursorBaseOffset]
! !

!SyntaxMorph methodsFor: 'new tiles' stamp: 'tk 8/30/2001 06:22'!
instVarTile: aName
	"Make and put into hand a tile for an instance variable"

	| sm |
	sm _ ((VariableNode new
					name: aName
					index: 1
					type: 1 "LdInstType") asMorphicSyntaxIn: SyntaxMorph new).
	sm roundedCorners.
	ActiveHand attachMorph: sm.
	Preferences tileTranslucentDrag
		ifTrue: [sm lookTranslucent.
			sm align: sm center with: ActiveHand position "+ self cursorBaseOffset"]
		ifFalse: [sm align: sm topLeft with: ActiveHand position + self cursorBaseOffset]
! !

!SyntaxMorph methodsFor: 'new tiles' stamp: 'tk 9/13/2001 13:44'!
string: anExpression toTilesIn: playerClass
	| code tree methodNode |
	"Construct SyntaxMorph tiles for some code.  Returns the main BlockNode of a doIt."

	"This is really cheating!!  Make a true parse tree later. -tk"
	code _ String streamContents: [:strm | 
		strm nextPutAll: 'doIt'; cr; tab; nextPutAll: anExpression].
	"decompile to tiles"
	tree _ Compiler new 
		parse: code 
		in: playerClass
		notifying: nil.
	methodNode _ tree asMorphicSyntaxUsing: SyntaxMorph.
	anExpression first == $" ifTrue: ["a comment" 
		"(methodNode findA: CommentNode) firstSubmorph color: Color blue."
		^ methodNode].
	^ methodNode submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) 
			ifTrue: [mm parseNode class == BlockNode] 
			ifFalse: [false]].
! !


!SyntaxMorph methodsFor: 'node to morph' stamp: 'FBS 2/24/2004 14:23'!
addTemporaries: temporaries 
	| tempMorph outerMorph w2 |
	temporaries notEmpty ifFalse: [^self].
	self alansTest1 
		ifFalse: 
			[tempMorph := self addRow: #tempVariable on: MethodTempsNode new.
			temporaries do: [:temp | temp asMorphicSyntaxIn: tempMorph]
				separatedBy: 
					[tempMorph addMorphBack: (tempMorph transparentSpacerOfSize: 4 @ 4)].
			^self].
	outerMorph := self addRow: #tempVariable on: nil.
	outerMorph setSpecialTempDeclarationFormat1.
	outerMorph 
		addMorphBack: (w2 := self noiseStringMorph: self noiseBeforeBlockArg).
	w2 emphasis: TextEmphasis bold emphasisCode.
	tempMorph := outerMorph addRow: #tempVariable on: MethodTempsNode new.
	tempMorph setSpecialTempDeclarationFormat2.
	temporaries do: 
			[:temp | 
			tempMorph 
				addToken: temp name
				type: #tempVariableDeclaration
				on: temp]
		separatedBy: [tempMorph addMorphBack: self tokenVerticalSeparator]! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 7/31/2001 17:27'!
addTemporaryControls

	| row stdSize |
	
	stdSize _ 8@8.
	row _ AlignmentMorph newRow
		color: Color transparent;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	self addMorphBack: row.

	{
		Morph new
			extent: stdSize; 
			color: Color paleBlue darker;
			setBalloonText: 'Change the contrast';
			on: #mouseUp send: #controlContrast2: to: self;
			on: #mouseMove send: #controlContrast2: to: self;
			on: #mouseDown send: #controlContrast2: to: self.

	"Removed because it's default is giant tiles, which no one wants. --tk
		Morph new
			extent: stdSize; 
			color: Color green;
			setBalloonText: 'Change basic spacing';
			on: #mouseUp send: #controlSpacing2: to: self;
			on: #mouseMove send: #controlSpacing2: to: self;
			on: #mouseDown send: #controlSpacing2: to: self.
	"

		Morph new
			extent: stdSize; 
			color: Color lightRed;
			setBalloonText: 'Change basic style';
			on: #mouseUp send: #changeBasicStyle to: self.

	} do: [ :each |
		row addMorphBack: each.
		row addMorphBack: (self transparentSpacerOfSize: stdSize).
	].
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'yo 12/3/2004 17:01'!
alanBinaryPostRcvr: aNode key: key args: args

	| nodeWithNilReceiver row |

"==
Repeat for collection [ collect ( from foo. blah blah foo blah) ]
Repeat for 1 to 50 [ do ( from i. blah blab i blah ) ]
=="

	nodeWithNilReceiver _ aNode copy receiver: nil.
	(row _ self addRow: #keyword2 on: nodeWithNilReceiver)
		borderWidth: 1;
		parseNode: (nodeWithNilReceiver as: MessageNode);
		borderColor: row stdBorderColor.
	row addToken: key asString
		type: #binary
		on: (SelectorNode new key: key asString code: nil "fill this in?").
	args first asMorphicSyntaxIn: row.
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 7/30/2001 14:52'!
alanKeywordMessage: aNode isAConditional: template key: key args: args

	| nodeWithNilReceiver column keywords row onlyOne |

	(key == #collect: and: [args first isKindOf: BlockNode]) ifTrue: [
		^self
			alanKwdCollect: aNode 
			isAConditional: template 
			key: key 
			args: args
	].
	key == #repeatFor:doing: ifTrue: [
		^self
			alanKwdRepeatForDoing: aNode 
			isAConditional: template 
			key: key 
			args: args
	].
	key == #if:do: ifTrue: [
		^self
			alanKwdIfDo: aNode 
			isAConditional: template 
			key: key 
			args: args
	].
	(args size = 1 and: [key endsWith: 'Getz:']) ifTrue: [
		^self
			alanKwdSetter: aNode 
			isAConditional: 0 
			key: key 
			args: args
	].
	(args size = 1 and: [self isStandardSetterKeyword: key]) ifTrue: [
		^self
			alanKwdSetter2: aNode 
			isAConditional: 0 
			key: key 
			args: args
	].
	nodeWithNilReceiver _ aNode copy receiver: nil.
	template = 1 ifTrue: [
		self listDirection: #topToBottom.
	].
	column _ self addColumn: #keyword1 on: nodeWithNilReceiver.
	keywords _ key keywords.
	onlyOne _ args size = 1.
	onlyOne ifFalse: ["necessary for three keyword messages!!"
		column setProperty: #deselectedBorderColor toValue: column compoundBorderColor].
	keywords
		with: (args first: keywords size)
		do: [:kwd :arg |
			template = 1 ifTrue: [
				column addMorphBack: (column transparentSpacerOfSize: 3@3).
			].
			(row _ column addRow: #keyword2 on: nodeWithNilReceiver)
				parseNode: (nodeWithNilReceiver as: 
						(onlyOne ifTrue: [MessageNode] ifFalse: [MessagePartNode]));
				borderColor: row stdBorderColor.
			template = 1 ifTrue: [row addMorphBack: (row transparentSpacerOfSize: 20@6)].
			row addToken: kwd
				type: #keyword2
				on: (onlyOne ifTrue: [SelectorNode new key: kwd code: nil "fill this in?"]
								ifFalse: [KeyWordNode new]).
			(arg asMorphicSyntaxIn: row) setConditionalPartStyle.
		].
	onlyOne ifTrue: [
		self replaceSubmorph: column by: row.
		column _ row.
	].
			
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 3/25/2001 16:31'!
alanKwdCollect: aNode isAConditional: template key: key args: args

	| nodeWithNilReceiver row kwdHolder |

	nodeWithNilReceiver _ aNode copy receiver: nil.
	(row _ self addRow: #keyword2 on: nodeWithNilReceiver)
		borderWidth: 1;
		parseNode: (nodeWithNilReceiver as: MessageNode);
		borderColor: row stdBorderColor.
	kwdHolder _ row
		addToken: key
		type: #keyword2
		on: (SelectorNode new key: key code: nil "fill this in?").
	kwdHolder firstSubmorph 
		setProperty: #syntacticallyCorrectContents toValue: key asString;
		contents: ''.

	args first asMorphicCollectSyntaxIn: row.
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 7/30/2001 14:52'!
alanKwdIfDo: aNode isAConditional: template key: key args: args
	"(know it has more than one arg)"
	| nodeWithNilReceiver column keywords row |

	nodeWithNilReceiver _ aNode copy receiver: nil.
	column _ self addColumn: #keyword1 on: nodeWithNilReceiver.
	"column borderColor: column compoundBorderColor."
	keywords _ key keywords.
	keywords
		with: (args first: keywords size)
		do: [:kwd :arg |
			(row _ column addRow: #keyword2 on: nodeWithNilReceiver)
				parseNode: (nodeWithNilReceiver as: MessagePartNode).
			kwd = 'do:' ifTrue: [
				row addMorphBack: (row transparentSpacerOfSize: 26@6).
			] ifFalse: [
				row addMorphBack: (row transparentSpacerOfSize: 10@6).
			].
			row addTokenSpecialCase: kwd
				type: #keyword2
				on: KeyWordNode new.
			(arg asMorphicSyntaxIn: row) setConditionalPartStyle.
		].
			
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 2/28/2001 10:16'!
alanKwdRepeatForDoing: aNode isAConditional: template key: key args: args

	| nodeWithNilReceiver row column keywords |

	nodeWithNilReceiver _ aNode copy receiver: nil.
	column _ self addColumn: #keyword1 on: nodeWithNilReceiver.
	keywords _ key keywords.
	keywords
		with: (args first: keywords size)
		do: [:kwd :arg |
			(row _ column addRow: #keyword2 on: nodeWithNilReceiver)
				parseNode: (nodeWithNilReceiver as: MessagePartNode).
			row addToken: kwd
				type: #keyword2
				on: KeyWordNode new.
			(arg asMorphicSyntaxIn: row) setConditionalPartStyle.
		].
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'FBS 2/24/2004 14:22'!
alanKwdSetter2: aNode isAConditional: template key: key args: args
	"translates
		foo setHeading: 0
	to
		foo's heading _ 0
	"
	| kwdHolder wordy |
	kwdHolder _ self
		addToken: key
		type: #keywordSetter
		on: (SelectorNode new key: key code: nil "fill this in?").
	wordy _ self translateToWordySetter: key.
	kwdHolder firstSubmorph 
		setProperty: #syntacticReformatting toValue: #keywordSetter;
		contents: wordy;
		emphasis: TextEmphasis bold emphasisCode.
	wordy = key asString ifFalse: [
		kwdHolder firstSubmorph 
			setProperty: #syntacticallyCorrectContents toValue: key asString].

	(args first asMorphicSyntaxIn: self) setConditionalPartStyle
			
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'FBS 2/24/2004 14:22'!
alanKwdSetter: aNode isAConditional: template key: key args: args

	| nodeWithNilReceiver row kwdHolder |

	nodeWithNilReceiver _ aNode copy receiver: nil.
	(row _ self addRow: #keyword2 on: nodeWithNilReceiver)
		borderWidth: 1;
		parseNode: (nodeWithNilReceiver as: MessageNode);
		borderColor: row stdBorderColor.
	row addNoiseString: '''s' emphasis: TextEmphasis bold emphasisCode.
	kwdHolder _ row
		addToken: key
		type: #keywordGetz
		on: (SelectorNode new key: key code: nil "fill this in?").
	kwdHolder firstSubmorph 
		setProperty: #syntacticReformatting toValue: #keywordGetz;
		setProperty: #syntacticallyCorrectContents toValue: key asString;
		contents: (self splitAtCapsAndDownshifted: (key asString allButLast: 5));
		emphasis: TextEmphasis bold emphasisCode.
	row addNoiseString: '_' emphasis: TextEmphasis bold emphasisCode.

	(args first asMorphicSyntaxIn: row) setConditionalPartStyle
			
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'FBS 2/24/2004 14:21'!
alanUnaryGetter: aNode key: key
	"I am a MessageNode.  Fill me with a SelectorNode {getX} whose string is {'s x}.  All on one level."

	| selSyn usm wordy |
	selSyn _ self
		addToken: key
		type: #unaryGetter
		on: (SelectorNode new key: key code: nil "fill this in?").
	usm _ selSyn firstSubmorph.
	usm setProperty: #syntacticReformatting toValue: #unaryGetter.
	wordy _ self translateToWordyGetter: key.
	wordy = key asString ifFalse: [
		usm setProperty: #syntacticallyCorrectContents toValue: key asString].
	usm contents: wordy; emphasis: TextEmphasis bold emphasisCode.
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 4/4/2001 12:49'!
alanUnaryPostRcvr: aNode key: key selector: selector

	| row |

	(self isStandardGetterSelector: key) ifTrue: [
		^self alanUnaryGetter: aNode key: key
	].
	row _ (self addUnaryRow: key style: #unary) layoutInset: 1.
	^ row parseNode: selector
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'dgd 2/22/2003 13:38'!
alansMessageNode: aNode receiver: receiver selector: selector keywords: key arguments: args 
	| receiverMorph testAndReceiver anotherSelf wordyMorph template |
	template := self alansTemplateStyleFor: key.
	receiver ifNotNil: 
			["i.e. not a cascade"

			anotherSelf := self constructSelfVariant: receiver and: key.
			anotherSelf ifNotNil: 
					[wordyMorph := self addString: anotherSelf special: false.
					wordyMorph setProperty: #wordyVariantOfSelf toValue: true.
					self addMorph: wordyMorph.
					self layoutInset: 1.
					^self].
			testAndReceiver := self.
			template = 1 
				ifTrue: 
					[testAndReceiver := self addRow: #keyword1 on: nil.
					self setSpecialOuterTestFormat.
					testAndReceiver addNoiseString: 'Test'].
			false 
				ifTrue: 
					["template = 2"

					testAndReceiver := self addRow: #keyword1 on: nil.
					"self setSpecialOuterTestFormat."
					testAndReceiver addNoiseString: 'Repeat for'].
			receiverMorph := receiver asMorphicSyntaxIn: testAndReceiver.
			template = 1 ifTrue: [receiverMorph setConditionalPartStyle]].

	"unary messages"
	args isEmpty 
		ifTrue: 
			[^self 
				alanUnaryPostRcvr: aNode
				key: key
				selector: selector].

	"binary messages"
	key last = $: 
		ifFalse: 
			[^self 
				alanBinaryPostRcvr: aNode
				key: key
				args: args].

	"keyword messages"
	receiverMorph ifNotNil: [receiverMorph setConditionalPartStyle].
	self setSpecialOuterTestFormat.
	self 
		alanKeywordMessage: aNode
		isAConditional: template
		key: key
		args: args! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 2/27/2001 14:19'!
assignmentNode: aNode variable: variable value: value

	| row v expMorph |

	row _ self addRow: #assignment on: aNode.
	v _ variable asMorphicSyntaxIn: row.
	self alansTest1 ifTrue: [v setConditionalPartStyle; layoutInset: 2].
	row addToken: ' _ ' type: #assignmentArrow on: aNode.
	expMorph _ value asMorphicSyntaxIn: row.
	self alansTest1 ifTrue: [
		row setSpecialOuterTestFormat.
		(expMorph hasProperty: #deselectedColor) ifFalse: [expMorph setConditionalPartStyle].
	].
	^row
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'dgd 2/22/2003 13:39'!
blockNode: aNode arguments: arguments statements: statements 
	| row column |
	column := self addColumn: #block on: aNode.
	self alansTest1 ifFalse: [column layoutInset: 5 @ -1].
	self alansTest1 
		ifTrue: 
			[column setProperty: #deselectedBorderColor toValue: self lighterColor].
	aNode addCommentToMorph: column.
	arguments notEmpty 
		ifTrue: 
			[row := column addRow: #blockarg1 on: BlockArgsNode new.
			row addNoiseString: self noiseBeforeBlockArg.
			arguments do: 
					[:arg | 
					row 
						addToken: arg name
						type: #blockarg2
						on: arg]].
	statements do: 
			[:each | 
			(row := each asMorphicSyntaxIn: column) borderWidth: 1.
			self alansTest1 ifTrue: [row setSpecialOuterTestFormat].
			each addCommentToMorph: column].
	^column! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'FBS 2/24/2004 14:32'!
blockNodeCollect: aNode arguments: arguments statements: statements 
	| row column c2 r2 r3 |
	column := self addColumn: #blockCollectOnly on: aNode.
	self alansTest1 ifFalse: [column layoutInset: 5 @ -1].
	aNode addCommentToMorph: column.
	arguments notEmpty 
		ifTrue: 
			[row := column addRow: #blockarg1 on: BlockArgsNode new.
			row addNoiseString: 'collect using' emphasis: TextEmphasis bold emphasisCode.
			r3 := row addRow: #blockarg1b on: nil.	"aNode"
			r3 setConditionalPartStyle.
			arguments do: 
					[:arg | 
					r3 
						addToken: arg name
						type: #blockarg2
						on: arg]].
	r2 := column addRow: #block on: aNode.
	r2 setProperty: #ignoreNodeWhenPrinting toValue: true.
	r2 addNoiseString: self noiseBeforeBlockArg emphasis: TextEmphasis bold emphasisCode.
	c2 := r2 addColumn: #block on: aNode.
	c2 setProperty: #ignoreNodeWhenPrinting toValue: true.
	statements do: 
			[:each | 
			(each asMorphicSyntaxIn: c2) borderWidth: 1.
			each addCommentToMorph: c2].
	^column! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 2/22/2001 17:00'!
cascadeNode: aNode receiver: receiver messages: messages
	| row |

	self alansTest1 ifTrue: [
		row _ self addColumn: #cascade on: aNode.
		row setSpecialOuterTestFormat.
	] ifFalse: [
		row _ self addRow: #cascade on: aNode
	].
	receiver asMorphicSyntaxIn: row.
	messages do: [:m | m asMorphicSyntaxIn: row].
	^ row

"	(node2 _ aNode copy) receiver: nil messages: messages.
	cascadeMorph _ row addColumn: #cascade2 on: node2.
	messages do: [ :m | m asMorphicSyntaxIn: cascadeMorph].
	^row
"
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 2/16/2001 16:34'!
changeBasicStyle

	self removeAllMorphs.
	self setProperty: #alansNewStyle toValue: self alansTest1 not.
	self methodNodeOuter: parseNode
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'gm 2/22/2003 13:42'!
finalAppearanceTweaks
	| deletes lw |
	SizeScaleFactor ifNil: [SizeScaleFactor := 0.15].
	SizeScaleFactor := 0.0.	"disable this feature.  Default was for giant tiles"
	self usingClassicTiles 
		ifTrue: 
			[self 
				allMorphsDo: [:each | (each isSyntaxMorph) ifTrue: [each lookClassic]].
			^self].
	deletes := OrderedCollection new.
	self allMorphsDo: 
			[:each | 
			(each respondsTo: #setDeselectedColor) ifTrue: [each setDeselectedColor].
			"(each hasProperty: #variableInsetSize) ifTrue: [
			each layoutInset: 
				((each valueOfProperty: #variableInsetSize) * SizeScaleFactor) rounded]."
			each isSyntaxMorph 
				ifTrue: 
					[lw := each layoutInset.
					lw isPoint ifTrue: [lw := lw x].
					each layoutInset: lw @ 0	"(6 * SizeScaleFactor) rounded"]].
	deletes do: [:each | each delete]! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'yo 11/11/2002 10:30'!
isStandardGetterSelector: key

	self flag: #yoCharCases.

	key size > 3 ifFalse: [^false].
	(key beginsWith: 'get') ifFalse: [^false].
	key fourth isUppercase ifFalse: [^false].
	^true
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'yo 11/11/2002 10:31'!
isStandardSetterKeyword: key

	self flag: #yoCharCases.

	key size > 4 ifFalse: [^false].
	(key endsWith: ':') ifFalse: [^false].
	(key beginsWith: 'set') ifFalse: [^false].
	key fourth isUppercase ifFalse: [^false].
	^true
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'dgd 2/22/2003 13:39'!
messageNode: aNode receiver: receiver selector: selector keywords: key arguments: args 
	| keywords column row receiverMorph receiverWidth messageWidth onlyOne nodeWithNilReceiver isAConditional |
	self alansTest1 
		ifTrue: 
			[^self 
				alansMessageNode: aNode
				receiver: receiver
				selector: selector
				keywords: key
				arguments: args].
	isAConditional := #(#ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue:) 
				includes: key.
	receiver ifNotNil: 
			["i.e. not a cascade"

			receiverMorph := receiver asMorphicSyntaxIn: self].
	keywords := key keywords.
	args isEmpty 
		ifTrue: 
			[row := (self addSingleKeywordRow: key) layoutInset: 1.
			^row parseNode: selector].
	receiverWidth := receiver ifNil: [0]
				ifNotNil: [receiverMorph fullBounds width].
	onlyOne := args size = 1.
	(receiverWidth <= 80 and: [onlyOne]) 
		ifTrue: 
			[self 
				messageOneArg: key
				receiver: receiver
				selector: selector
				args: args.
			^self].
	nodeWithNilReceiver := aNode copy receiver: nil.
	column := self addColumn: #keyword1 on: nodeWithNilReceiver.
	"onlyOne ifTrue: [column parseNode: nil].	is a spacer"
	messageWidth := 0.
	keywords with: (args copyFrom: 1 to: keywords size)
		do: 
			[:kwd :arg | 
			isAConditional 
				ifTrue: [column addMorphBack: (column transparentSpacerOfSize: 3 @ 3)].
			(row := column addRow: #keyword2 on: nodeWithNilReceiver)
				borderWidth: 1;
				parseNode: (nodeWithNilReceiver 
							as: (onlyOne ifTrue: [MessageNode] ifFalse: [MessagePartNode]));
				borderColor: row stdBorderColor.
			isAConditional 
				ifTrue: [row addMorphBack: (row transparentSpacerOfSize: 20 @ 6)].
			row 
				addToken: kwd
				type: #keyword2
				on: (onlyOne 
						ifTrue: [SelectorNode new key: kwd code: nil	"fill this in?"]
						ifFalse: [KeyWordNode new]).
			arg asMorphicSyntaxIn: row.
			messageWidth := messageWidth + row fullBounds width].
	onlyOne 
		ifTrue: 
			[self replaceSubmorph: column by: row.
			column := row].
	receiverMorph ifNil: [^self].
	receiverWidth + messageWidth < 350 
		ifTrue: 
			[isAConditional ifFalse: [self unfoldMessage].
			^self].
	((receiverWidth > 200 
		or: [receiverWidth > 80 and: [column fullBounds height > 20]]) or: 
				[receiverMorph fullBounds width > 30 
					and: [column fullBounds height > 100 or: [column fullBounds width > 250]]]) 
		ifTrue: [^self foldMessage]! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 2/26/2001 14:04'!
messageOneArg: key receiver: receiver selector: selector args: args

	| row firstArgMorph |

	row _ (self addSingleKeywordRow: key) layoutInset: 1.
	row parseNode: selector.
	firstArgMorph _ args first asMorphicSyntaxIn: self.
	receiver ifNil: [^ self].
	(firstArgMorph fullBounds height > 100
			or: [firstArgMorph fullBounds width > 250])
		ifTrue: [self foldMessageOneArg].
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 2/26/2001 17:12'!
methodNodeInner: aNode selectorOrFalse: selectorOrFalse precedence: precedence arguments: arguments temporaries: temporaries primitive: primitive block: block
	| header selNode |

	selNode _ selectorOrFalse class == SelectorNode 
		ifTrue: [selectorOrFalse] 
		ifFalse: [SelectorNode new key: selectorOrFalse code: nil].
	header _ self addRow: Color white on: selNode.
	precedence = 1
		ifTrue: [header addToken: aNode selector type: #methodHeader1 on: selNode]
		ifFalse: [aNode selector keywords with: arguments do:
					[:kwd :arg | 
					header addToken: kwd type: #methodHeader2 on: selNode.
					(arg asMorphicSyntaxIn: header) color: #blockarg2]].
	aNode addCommentToMorph: self.
	self addTemporaries: temporaries.
	(primitive > 0 and: [(primitive between: 255 and: 519) not]) ifTrue:
		["Dont decompile <prim> for, eg, ^ self "
		self addTextRow: (String streamContents: [ :strm | aNode printPrimitiveOn: strm])].
	block asMorphicSyntaxIn: self.
	^ self
! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'tk 7/31/2001 17:37'!
methodNodeOuter: aNode

	| block |
	
	self borderWidth: 0.
	aNode asMorphicSyntaxIn: self.
	self alansTest1 ifTrue: [self addTemporaryControls].
	self finalAppearanceTweaks.
		"self setProperty: #deselectedColor toValue: Color transparent."
	block _ self findA: BlockNode.
		"block setProperty: #deselectedColor toValue: Color transparent."
	block submorphs size = 1 ifTrue: [^ self].	"keep '^ self' if that is the only thing in method"
	block submorphs last decompile string = '^  self ' ifTrue: [
		block submorphs last delete].
	^ self! !

!SyntaxMorph methodsFor: 'node to morph' stamp: 'RAA 2/15/2001 19:49'!
vanillaMessageNode: aNode receiver: receiver selector: selector arguments: arguments

	| substitute row sel |
	sel _ #message.
	((self nodeClassIs: CascadeNode) and: [self parseNode receiver ~~ aNode]) ifTrue: [
		sel _ #keyword2.
		receiver ifNotNil: [self inform: 'receiver should be nil']].
	row _ self addRow: sel on: aNode.
	substitute _ aNode as: TileMessageNode.
	(aNode macroPrinter == #printCaseOn:indent:) ifTrue: [
		aNode asMorphicCaseOn: row indent: nil.
		^ self].
	aNode macroPrinter
		ifNotNil: 
			[substitute perform: aNode macroPrinter with: row with: nil]
		ifNil: 
			[substitute 
				printKeywords: selector key
				arguments: arguments
				on: row
				indent: nil].
	^ row addTransparentSpacerOfSize: 3@0.	"horizontal spacing only"
! !


!SyntaxMorph methodsFor: 'node types' stamp: 'RAA 2/14/2001 20:34'!
immediatelyBelowTheMethodNode

	^(owner respondsTo: #isMethodNode) and: [owner isMethodNode]! !

!SyntaxMorph methodsFor: 'node types' stamp: 'tk 8/24/2001 15:41'!
isAVariable
	"There are three kinds of variable nodes"

	((parseNode class == TempVariableNode) or: [
		(parseNode class == LiteralVariableNode) or: [
			parseNode class == VariableNode]]) ifFalse: [^ false].
	^ (ClassBuilder new reservedNames includes: 
			self decompile string withoutTrailingBlanks) not! !

!SyntaxMorph methodsFor: 'node types' stamp: 'di 11/17/2000 08:31'!
isBlockNode
	^ parseNode class == BlockNode! !

!SyntaxMorph methodsFor: 'node types' stamp: 'tk 9/26/2001 05:50'!
isDeclaration
	"Return true if I am a TempVarNode inside a declaration of some kind, including a method arg"

	| opc |
	owner isSyntaxMorph ifFalse: [^ false].
	opc _ owner parseNode class.
	opc == BlockArgsNode ifTrue: [^ true].
	opc == MethodTempsNode ifTrue: [^ true].
	opc == SelectorNode ifTrue: [^ true].
	^ false! !

!SyntaxMorph methodsFor: 'node types' stamp: 'gm 2/22/2003 12:30'!
isLeafTile
	self hasSubmorphs ifFalse: [^false].
	(self firstSubmorph isSyntaxMorph) ifTrue: [^false].
	(self firstSubmorph isMemberOf: Morph) ifTrue: [^false].
	^true! !

!SyntaxMorph methodsFor: 'node types' stamp: 'di 11/17/2000 08:31'!
isMethodNode
	^ parseNode class == MethodNode! !

!SyntaxMorph methodsFor: 'node types' stamp: 'tk 9/13/2001 15:28'!
isNoun
	"Consider these to be nouns:  MessageNode with receiver, CascadeNode with receiver, AssignmentNode, TempVariableNode, LiteralNode, VariableNode, LiteralVariableNode."

	(#(TempVariableNode LiteralNode VariableNode LiteralVariableNode) includes:
		(parseNode class name)) ifTrue: [^ true].

	(self nodeClassIs: MessageNode) ifTrue: [^ parseNode receiver notNil].
	(self nodeClassIs: CascadeNode) ifTrue: [^ parseNode receiver notNil].
	(self nodeClassIs: AssignmentNode) ifTrue: [^ submorphs size >= 3].

	^ false! !

!SyntaxMorph methodsFor: 'node types' stamp: 'tk 9/23/2001 00:17'!
isSelfTile

	^ parseNode class == VariableNode and: [self decompile asString = 'self ']
	! !

!SyntaxMorph methodsFor: 'node types' stamp: 'di 11/6/2000 15:26'!
nodeClassIs: aParseNodeClass
	"Test the class of my parseNode"

	^ parseNode class == aParseNodeClass! !

!SyntaxMorph methodsFor: 'node types' stamp: 'dgd 2/22/2003 13:40'!
rootTile
	^self 
		orOwnerSuchThat: [:m | m owner isNil or: [m owner isSyntaxMorph not]]! !


!SyntaxMorph methodsFor: 'player' stamp: 'tk 9/26/2001 06:05'!
currentDataValue
	"Answer the current data value held by the receiver"

	^ self readOut valueFromContents! !

!SyntaxMorph methodsFor: 'player' stamp: 'tk 2/15/2002 13:03'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield.  For a numeric-readout tile."

	"Is CardPlayer class holding my variableDock, or should I be using the caching mechanism in Morph>>variableDocks?"
	| updatingString lab nn aGetter |
	(updatingString _ self readOut) ifNil: [^ #()].
	updatingString getSelector ifNil: [
		lab _ self submorphNamed: 'label' ifNone: [self defaultName].
		nn _ lab contents asString.
		"nn at: 1 put: nn first asUppercase."
		updatingString getSelector: (aGetter _ 'get',nn) asSymbol;
			putSelector: (ScriptingSystem setterSelectorForGetter: aGetter).
		].
	^ Array with: (VariableDock new 
			variableName: (updatingString getSelector allButFirst: 3) withFirstCharacterDownshifted 
			type: #number 
			definingMorph: updatingString 
			morphGetSelector: #valueFromContents 
			morphPutSelector: #acceptValue:)! !


!SyntaxMorph methodsFor: 'pop ups' stamp: 'aoy 2/15/2003 21:30'!
addArg: index 
	"I rep a SelectorNode.  My string has been replaced.  Append an argument to my owner."

	"See if any sample args are recorded"

	| sel rec aVocabulary mi sample descrip mthNode tiles |
	sel := self decompile asString asSymbol.
	rec := self receiverObject.
	sample := rec class == Error 
				ifFalse: 
					[aVocabulary := self vocabularyToUseWith: rec.
					mi := aVocabulary methodInterfaceAt: sel ifAbsent: [nil].
					mi ifNil: [5]
						ifNotNil: 
							[descrip := mi argumentVariables at: index.
							descrip sample]]
				ifTrue: [5]. 
	mthNode := self string: sample storeString toTilesIn: sample class.
	tiles := mthNode submorphs at: mthNode submorphs size - 1.	"before the ^ self"
	self owner addMorphBack: tiles! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:24'!
assignmentArrow
	"Offer to embed this variable in a new assignment statement.  (Don't confuse this with upDownAssignment:, which runs the up and down arrows that rotate among assignment types.)"
	| rr |

	self isAVariable ifFalse: [^ nil].
	self isDeclaration ifTrue: [^ nil].
	^ (rr _ RectangleMorph new)
		extent: 11@13; borderWidth: 1; color: Color lightGreen;
		borderColor: Color gray;
		addMorph: ((self noiseStringMorph: '_') topLeft: rr topLeft + (3@0));
		on: #mouseUp send: #newAssignment to: self
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'gk 2/23/2004 21:08'!
changeSound: upDown
	| ind arg st soundChoices index it current |
	"move in the list of sounds.  Adjust arg tile after me"

	ind _ owner submorphs indexOf: self.
	arg _ owner submorphs atWrap: ind+1.
	arg isSyntaxMorph ifFalse: [^ self].
	st _ arg submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self].
	soundChoices _ SoundService default sampledSoundChoices.
	current _ st contents copyFrom: 2 to: st contents size-1.	"remove string quotes"
	index _ soundChoices indexOf: current.
	index > 0 ifTrue:
		[st contents: (it _ soundChoices atWrap: index + upDown) printString.
		self playSoundNamed: it].
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/26/2001 14:31'!
colorPatch
	"Return a color patch button that lets the user choose a color and modifies the code"
	| cc patch sel completeMsg |
	
	
	((self nodeClassIs: MessageNode) "or: [self nodeClassIs: SelectorNode]") ifFalse: [^ nil].
	(sel _ self selector) ifNil: [^ nil].
	(Color colorNames includes: sel) | (sel == #r:g:b:) ifFalse: [^ nil].
		"a standard color name"
	completeMsg _ self isNoun ifTrue: [self] 
				ifFalse: [owner isNoun ifTrue: [owner] ifFalse: [owner owner]].

	(cc _ completeMsg try) class == Color ifFalse: [^ nil].
	patch _ ColorTileMorph new colorSwatchColor: cc.
		"sends colorChangedForSubmorph: to the messageNode"
	patch color: Color transparent; borderWidth: 0.  patch submorphs last delete.
	^ patch! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 2/21/2001 16:37'!
deleteLine
	| temp |
	temp _ owner.
	self deletePopup.
	self delete.
	temp setSelection: nil.
	temp acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 12/13/2000 13:05'!
deletePopup

	self valueOfProperty: #myPopup ifPresentDo:
		[:panel | panel delete. self removeProperty: #myPopup]! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 2/21/2001 13:09'!
dismisser
	"Return the icon to delete this line of tiles.  I am an entire line in a block."
	| handle handleSpec colorToUse iconName form |

	(owner isSyntaxMorph and: [owner nodeClassIs: BlockNode]) ifFalse: [^ nil].
	handleSpec _ Preferences haloSpecifications fourth.	"dismiss"
	handle _ EllipseMorph
			newBounds: (Rectangle center: 10@10 extent: 16 asPoint)
			color: (colorToUse _ Color colorFrom: handleSpec color).
	iconName _ handleSpec iconSymbol.
	form _ ScriptingSystem formAtKey: iconName.	"#'Halo-Dismiss'"
	handle addMorphCentered: (ImageMorph new
				image: form; 
				color: colorToUse makeForegroundColor;
				lock).
	handle on: #mouseDown send: #deleteLine to: self.
	^ handle! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 10/17/2001 13:38'!
dupTile: evt

	| dup |
	self deletePopup.
	"self deselect."
	dup _ self duplicateMorph: evt.
	Preferences tileTranslucentDrag
		ifTrue: [dup align: dup center with: evt hand position.
				dup lookTranslucent]
		ifFalse: [dup align: dup topLeft
					with: evt hand position + self cursorBaseOffset].
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 10/17/2001 13:29'!
duplicator
	"Return the icon to duplicate this tile."
	| handle handleSpec colorToUse iconName form |

	handleSpec _ Preferences haloSpecifications at: 11.	"duplicate"
	handle _ EllipseMorph
			newBounds: (Rectangle center: 10@10 extent: 16 asPoint)
			color: (colorToUse _ Color colorFrom: handleSpec color).
	iconName _ handleSpec iconSymbol.
	form _ ScriptingSystem formAtKey: iconName.	"#'Halo-Dup'"
	handle addMorphCentered: (ImageMorph new
				image: form; 
				color: colorToUse makeForegroundColor;
				lock).
	handle on: #mouseDown send: #dupTile: to: self.
	^ handle! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'ar 3/18/2001 17:28'!
event: arg1 arrow: arg2 upDown: arg3
	"Reorder the arguments for existing event handlers"
	(arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
	^self upDown: arg1 event: arg2 arrow: arg3! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/28/2001 13:38'!
extend
	| messageNodeMorph first |
	"replace this noun with a new message like (arg + 1).  If type is not known, ask the user to type in a selector.  Use nil as arg.  Let user drag something to it afterwards."

	"Later do evaluation of self to see what type and offer right selector"
	self deselect.
	messageNodeMorph _ (MessageSend receiver: 1 selector: #+ arguments: #(1))
								asTilesIn: Player globalNames: false.
	owner replaceSubmorph: self by: messageNodeMorph.
	first _ messageNodeMorph submorphs detect: [:mm | mm isSyntaxMorph].
	messageNodeMorph replaceSubmorph: first by: self.
	self acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:14'!
extendArrow
	"Return the extend arrow button.  It replaces the argument with a new message.
	I am a number or getter messageNode."
	| patch |
	
	self isNoun ifFalse: [^ nil].
	self isDeclaration ifTrue: [^ nil].
	patch _ (ImageMorph new image: (TileMorph classPool at: #SuffixPicture)).
	patch on: #mouseDown send: #extend to: self.
	^ patch! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/28/2001 11:35'!
newAssignment
	"I am a variableNode.  Place me inside an assignment statement."

	| new old |
	parseNode name: self decompile.	"in case user changed name"
	new _ owner assignmentNode: AssignmentNode new variable: parseNode 
					value: parseNode copy.
	self deselect.
	(old _ owner) replaceSubmorph: self by: new.	"do the normal replacement"
	(old isSyntaxMorph) ifTrue: [old cleanupAfterItDroppedOnMe].	"now owned by no one"
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'dgd 2/22/2003 13:40'!
offerPopUp
	"Put up a halo to allow user to change
		Literals (Integer, true),
		Selector (beep: sound, +,-,*,//,\\, r:g:b:, setX: incX: decX: for any X,),
		Variable (Color),
		not AssignmentNode (_ inc dec),
	Extend arrows on each literal, variable, and message, (block that is by itself).
	Retract arrows on each literal or variable, or message or block that is an argument.
	Any literal can be changed by Shift-clicking and typing."

	| panel any upDown retract extend colorPatch edge dismiss rr duplicate |
	(self hasProperty: #myPopup) ifTrue: [^self].	"already has one"
	any := false.
	(upDown := self upDownArrows) ifNotNil: [any := true].	"includes menu of selectors"
	(retract := self retractArrow) ifNotNil: [any := true].
	(extend := self extendArrow) ifNotNil: [any := true].
	(dismiss := self dismisser) ifNotNil: [any := true].
	(duplicate := self duplicator) ifNotNil: [any := true].
	"(assign _ self assignmentArrow) ifNotNil: [any _ true].
			get from menu or any other assignment"
	submorphs last class == ColorTileMorph 
		ifFalse: [(colorPatch := self colorPatch) ifNotNil: [any := true]].
	any ifFalse: [^self].
	"Transcript cr; print: parseNode class; space; 
		print: (self hasProperty: #myPopup); endEntry."
	panel := (RectangleMorph new)
				color: Color transparent;
				borderWidth: 0.
	upDown ifNotNil: 
			[panel addMorphBack: upDown first.
			upDown first align: upDown first topLeft with: panel topLeft + (0 @ 0).
			panel addMorphBack: upDown second.
			upDown second align: upDown second topLeft
				with: upDown first bottomLeft + (0 @ 1).
			upDown size > 2 
				ifTrue: 
					[panel addMorphBack: upDown third.
					upDown third align: upDown third topLeft
						with: upDown first topRight + (2 @ 3)]].
	rr := self right.
	colorPatch ifNotNil: 
			[rr := rr + colorPatch submorphs first width + 1.
			self addMorphBack: colorPatch	"always in tile"
			"colorPatch align: colorPatch topLeft 
					with: panel topLeft + (1@1)"].
	retract ifNotNil: 
			[edge := panel submorphs isEmpty 
						ifTrue: [panel left]
						ifFalse: [panel submorphs last right].
			panel addMorphBack: retract.
			retract align: retract topLeft with: (edge + 2) @ (panel top + 3)].
	extend ifNotNil: 
			[edge := panel submorphs isEmpty 
						ifTrue: [panel left]
						ifFalse: [panel submorphs last right].
			panel addMorphBack: extend.
			extend align: extend topLeft with: (edge + 2) @ (panel top + 3)].
	duplicate ifNotNil: 
			[edge := panel submorphs isEmpty 
						ifTrue: [panel left]
						ifFalse: [panel submorphs last right].
			panel addMorphBack: duplicate.
			duplicate align: duplicate topLeft with: (edge + 2) @ (panel top + 1)].
	dismiss ifNotNil: 
			[edge := panel submorphs isEmpty 
						ifTrue: [panel left]
						ifFalse: [panel submorphs last right].
			panel addMorphBack: dismiss.
			dismiss align: dismiss topLeft with: (edge + 2) @ (panel top + 1)].
	"	assign ifNotNil: [
		edge _ panel submorphs isEmpty 
			ifTrue: [panel left] 
			ifFalse: [panel submorphs last right].
		panel addMorphBack: assign.
		assign align: assign topLeft with: (edge+2) @ (panel top + 2)].
"
	panel align: panel topLeft with: rr @ (self top - 2).
	panel extent: panel submorphs last bottomRight - panel topLeft.
	self setProperty: #myPopup toValue: panel.
	self addMorphBack: panel	"Any reason ever to have panel below?"
	"(owner listDirection = #topToBottom and: [self listDirection = #leftToRight])
		ifTrue: [self addMorphBack: panel]
		ifFalse: [owner addMorph: panel after: self]."! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/28/2001 13:39'!
replaceKeyWord: evt menuItem: stringMorph
	"Replace my entire message (which may be multi-part) with the one specified.  Preserve all argument tiles, either in the new message or in the world outside the scriptor.  I am a SelectorNode or KeyWordNode."

	| menu new news newSel mm newTree newRec newArgs top oldArgNodes share ctrY |
	(menu _ stringMorph owner owner) class == RectangleMorph ifTrue: [
		menu delete].
	new _ stringMorph contents.
	new first = $( ifTrue: [^ self].	"Cancel"
	new first = $  ifTrue: [^ self].	"nothing"
	news _ String streamContents: [:strm | "remove fake args"
		(new findBetweenSubStrs: #(' 5' $ )) do: [:part | strm nextPutAll: part]].
	newSel _ stringMorph valueOfProperty: #syntacticallyCorrectContents.
	newSel ifNil: [newSel _ news].
	mm _ MessageSend receiver: 5 selector: newSel 
			arguments: ((Array new: newSel numArgs) atAllPut: 5).
	newTree _ mm asTilesIn: Object globalNames: false.
	newRec _ newTree receiverNode.
	newArgs _ newTree argumentNodes.
	ctrY _ self fullBoundsInWorld center y.
	top _ self messageNode.
	newRec owner replaceSubmorph: newRec by: top receiverNode.
	oldArgNodes _ top argumentNodes.
	share _ newArgs size min: oldArgNodes size.
	(newArgs first: share) with: (oldArgNodes first: share) do: [:newNode :oldNode | 
		newNode owner replaceSubmorph: newNode by: oldNode].
	"later get nodes for objects of the right type for new extra args"

	top owner replaceSubmorph: top by: newTree.

	"Deposit extra args in the World"
	(oldArgNodes copyFrom: share+1 to: oldArgNodes size) do: [:leftOver |
		(leftOver parseNode class == LiteralNode and: [leftOver decompile asString = '5']) 
			ifFalse: [newTree pasteUpMorph addMorphFront: leftOver.
				leftOver position: newTree enclosingPane fullBoundsInWorld right - 20 @ ctrY.
				ctrY _ ctrY + 26]
			ifTrue: [leftOver delete]].
	newTree acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/19/2001 21:32'!
replaceSel: evt menuItem: stringMorph
	"I rep a SelectorNode.  Replace my selector with new one that was just chosen from a menu"

	| menu new old newSel ms oa na case news |
	(menu _ stringMorph owner owner) class == RectangleMorph ifTrue: [
		menu delete].
	new _ stringMorph contents.
	new first = $( ifTrue: [^ self].	"Cancel"
	new first = $  ifTrue: [^ self].	"nothing"
	news _ String streamContents: [:strm | "remove fake args"
		(new findBetweenSubStrs: #(' 5' $ )) do: [:part | strm nextPutAll: part]].
	newSel _ stringMorph valueOfProperty: #syntacticallyCorrectContents.
	newSel ifNil: [newSel _ news].
	old _ (ms _ self findA: StringMorph) valueOfProperty: #syntacticallyCorrectContents.
	old ifNil: [old _ (self findA: StringMorph) contents].
	oa _ old numArgs.  na _ newSel numArgs.  case _ 5.
	(oa = 1) & (na = 1) ifTrue: [case _ 1]. 
	(oa = 0) & (na = 0) ifTrue: [case _ 2].
	(oa = 1) & (na  = 0) ifTrue: [case _ 3].
	(oa = 0) & (na  = 1) ifTrue: [case _ 4].
	case <= 4 ifTrue: ["replace the selector"
		ms contents: news.	"not multi-part"
		ms setProperty: #syntacticallyCorrectContents toValue: newSel].
	case = 3 ifTrue: [owner tossOutArg: 1].
	case = 4 ifTrue: [self addArg: 1].
	"more cases here.  Rebuild the entire MessageNode"
	
	self acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/28/2001 10:06'!
retract
	"replace this message with its receiver.  I am the message node."
	| rec cascade msg |
	(self nodeClassIs: CascadeNode) ifTrue:
		["This is a piece of a cascaded message -- just delete it"
		self deletePopup.
		cascade _ owner.
		self delete.
		cascade setSelection: {cascade. nil. cascade}.
		^ cascade acceptIfInScriptor].
	self deletePopup.
	(rec _ self receiverNode)
		ifNil: [msg _ owner.
			rec _ owner receiverNode.
			msg owner replaceSubmorph: msg by: rec]
		ifNotNil: [owner replaceSubmorph: self by: rec].
	rec setSelection: {rec. nil. rec}.
	rec acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 12/13/2000 12:57'!
retractArrow
	"Return the retract arrow button.  It replaces the current message with its receiver.
	I am in a MessageNode whose first subnode is not a MessagePartNode.  I did not encounter a block on the way up to it.  I am the last subnode in every owner up to it."
	| patch |

	(self nodeClassIs: MessageNode) ifFalse: [^ nil].
	(owner isSyntaxMorph and: [owner parseNode == parseNode]) ifTrue: [^ nil].

	patch _ (ImageMorph new image: (TileMorph classPool at: #RetractPicture)).
	patch on: #mouseDown send: #retract to: self.
	^ patch! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/18/2001 16:27'!
selectorMenu
	"Put up a menu of all selectors that my receiver could be sent.  Replace me with the one chosen.  (If fewer args, put the tiles for the extra arg to the side, in script's owner (world?).)
	Go ahead and eval receiver to find out its type.  Later, mark selectors for side effects, and don't eval those.
	Put up a table.  Each column is a viewer category."

	| cats value catNames interfaces list setter wording all words ind aVocabulary limitClass |
	cats _ #().
	all _ Set new.
	value _ self receiverObject.
	value class == Error ifTrue: [^ nil].
	
	aVocabulary _ self vocabularyToUseWith: value.
	limitClass _ self limitClassToUseWith: value vocabulary: aVocabulary.
	catNames _ value categoriesForVocabulary: aVocabulary limitClass: limitClass.
	cats _ catNames collect: [:nn | 
		list _ OrderedCollection new.
		interfaces _ value methodInterfacesForCategory: nn 
						inVocabulary: aVocabulary limitClass: limitClass.
		interfaces do: [:mi | 
			(all includes: mi selector) ifFalse: [
				"list add: (self aSimpleStringMorphWith: mi elementWording).  Expensive"
				words _ mi selector.
				(words beginsWith: 'get ') ifTrue: [words _ words allButFirst: 4].
				mi selector last == $: ifTrue: [
					words _ String streamContents: [:strm | "add fake args"
						(words findTokens: $:) do: [:part | strm nextPutAll: part; nextPutAll: ' 5 ']].
					words _ words allButLast].
				mi selector isInfix ifTrue: [words _ words, ' 5'].
				words _ self splitAtCapsAndDownshifted: words.	
				list add: (self anUpdatingStringMorphWith: words special: true).
				words = mi selector ifFalse: [
					list last setProperty: #syntacticallyCorrectContents toValue: mi selector].
				all add: mi selector].
			setter _ mi companionSetterSelector asString.
			(setter = 'nil') | (all includes: setter) ifFalse: ["need setters also"
				wording _ (self translateToWordySetter: setter).
				list add:  (self aSimpleStringMorphWith: wording, ' 5').
				wording = setter ifFalse: [
					list last setProperty: #syntacticallyCorrectContents 
						toValue: setter].
				all add: setter]].
		list].
	(ind _ catNames indexOf: 'scripts') > 0 ifTrue: [
		(cats at: ind) first contents = 'empty script' ifTrue: [(cats at: ind) removeFirst]].
	cats first addFirst: (self aSimpleStringMorphWith: ' ').	"spacer"
	cats first addFirst: (self aSimpleStringMorphWith: '( from ', value class name, ' )').
	cats first first color: (Color green mixed: 0.25 with: Color black).
	self selectorMenuAsk: cats.	"The method replaceSel:menuItem: does the work.  
		and replaces the selector."
	! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/20/2001 16:04'!
selectorMenuAsk: listOfLists
	"I represent a SelectorNode to be replaced by one of the selectors in one of the category lists.  Each list has pre-built StringMorphs in it."

	| menu col |
	listOfLists isEmpty ifTrue: [^ nil].
	listOfLists first addFirst: (self aSimpleStringMorphWith: '( Cancel )').
	listOfLists first first color: Color red.
	menu _ RectangleMorph new.
	menu listDirection: #leftToRight; layoutInset: 3; cellInset: 1@0.
	menu layoutPolicy: TableLayout new; hResizing: #shrinkWrap; 
		vResizing: #shrinkWrap; color: (Color r: 0.767 g: 1.0 b: 0.767);
		useRoundedCorners; cellPositioning: #topLeft.
	listOfLists do: [:ll |
		col _ Morph new.
	 	col listDirection: #topToBottom; layoutInset: 0; cellInset: 0@0.
		col layoutPolicy: TableLayout new; hResizing: #shrinkWrap.
		col color: Color transparent; vResizing: #shrinkWrap.
		menu addMorphBack: col.
		ll do: [:ss | 
			col addMorphBack: ss.
			ss on: #mouseUp send: #replaceKeyWord:menuItem: to: self]
		].
	self world addMorph: menu.
	menu setConstrainedPosition: (owner localPointToGlobal: self topRight) + (10@-30) 
			hangOut: false.
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'sw 3/18/2004 00:35'!
setSelector: stringLike in: stringMorph
	"Store the new selector and accept method."

	| aSymbol myType str |
	aSymbol _ stringLike asSymbol.
	(ScriptingSystem helpStringOrNilFor: aSymbol) ifNotNilDo:
		[:aString |
			self setBalloonText: aString translated].
	myType _ stringMorph valueOfProperty: #syntacticReformatting ifAbsent: [#none].
	str _ aSymbol.
	(self isStandardSetterKeyword: str) ifTrue: [str _ self translateToWordySetter: str].
	(self isStandardGetterSelector: str) ifTrue: [str _ self translateToWordyGetter: str].
	(self shouldBeBrokenIntoWords: myType) 
		ifTrue: [str _ self substituteKeywordFor: str].
	stringMorph contents: str.
	"parseNode key: aSymbol code: nil."
	str = stringLike ifFalse:
		[stringMorph setProperty: #syntacticallyCorrectContents toValue: aSymbol].
	self acceptSilently! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/19/2001 15:47'!
tossOutArg: extras

	"Remove the tiles for the last N keywords and arguments.  Place the tiles beside the current window.  I am a SyntaxMorph for a MessageNode."

	| cnt ctr |
	cnt _ 0.
	 submorphs copy reverseDo: [:sub |
		ctr _ sub fullBoundsInWorld center.
		sub delete.
		(sub isSyntaxMorph and: [sub parseNode notNil]) ifTrue: [
			sub isNoun ifTrue: [
				self pasteUpMorph addMorphFront: sub.
				sub position: self enclosingPane fullBoundsInWorld right - 20 @ ctr y].
			(cnt _ cnt + 1) >= extras ifTrue: [^ self]]].! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 13:35'!
upDown: delta event: evt arrow: arrowMorph

	| st |
	st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self].
	(self nodeClassIs: LiteralNode) ifTrue:
		[ "+/- 1"
		st contents: (self decompile asNumber + delta) printString.
		^ self acceptUnlogged].
	(self nodeClassIs: VariableNode) ifTrue:
		[ "true/false"
		st contents: (self decompile string = 'true') not printString.
		^ self acceptSilently ifFalse: [self changed].
			"maybe set parseNode's key"].

	(self upDownArithOp: delta) ifTrue: [^ self].	"+ - // *   < > <= =   beep:"

	(self upDownAssignment: delta) ifTrue: [^ self].
		"Handle assignment --  increaseBy:  <-   multiplyBy:"
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 7/24/2001 17:54'!
upDownArithOp: delta
	"Change a + into a -.  Also do sounds (change the arg to the beep:)."

	| aList index st |
	st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self].
	(self nodeClassIs: SelectorNode) ifTrue:
		[aList _ #(+ - * / // \\ min: max:).
		(index _ aList indexOf: self decompile asString) > 0 ifTrue:
			[self setSelector: (aList atWrap: index + delta) in: st.  ^ true].

		aList _ #(= ~= > >= isDivisibleBy: < <=).
		(index _ aList indexOf: self decompile asString) > 0 ifTrue:
			[self setSelector: (aList atWrap: index + delta) in: st.  ^ true].

		aList _ #(== ~~).
		(index _ aList indexOf: self decompile asString) > 0 ifTrue:
			[self setSelector: (aList atWrap: index + delta) in: st.  ^ true].

		'beep:' = self decompile asString ifTrue:
			["replace sound arg"
			self changeSound: delta.
			self acceptSilently.  ^ true].
		].
	^ false! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 9/20/2001 16:33'!
upDownArrows
	"Return an array of two up/down arrow buttons.
	It replaces the selector or arg with a new one.
	I am a number or boolean or a selector (beep:, +,-,*,//,\\, or setX: incX: decX: for any X."
	| patch any noMenu |
	any _ (self nodeClassIs: LiteralNode) and: [parseNode key isNumber].
	any _ any or: [(self nodeClassIs: VariableNode) and:
						[(#('true' 'false') includes: self decompile asString)]].
	noMenu _ any.

	any _ any or: [self nodeClassIs: SelectorNode].	"arrows and menu of selectors"
	any _ any or: [self nodeClassIs: KeyWordNode].
	any ifFalse: [^ nil].

	patch _ {(ImageMorph new image: TileMorph upPicture)
				on: #mouseDown send: #upDown:event:arrow: to: self withValue: 1;
				on: #mouseStillDown send: #upDownMore:event:arrow: 
					to: self withValue: 1;
				on: #mouseUp send: #upDownDone to: self.
			(ImageMorph new image: TileMorph downPicture)
				on: #mouseDown send: #upDown:event:arrow: to: self withValue: -1;
				on: #mouseStillDown send: #upDownMore:event:arrow: 
					to: self withValue: -1;
				on: #mouseUp send: #upDownDone to: self}.
	noMenu ifFalse: [patch _ patch, {(RectangleMorph new)
						extent: 6@10; borderWidth: 1;
						borderColor: Color gray;
						on: #mouseUp send: #selectorMenu to: self}.
					patch last color: ((self nodeClassIs: SelectorNode) 
						ifTrue: [Color lightGreen] ifFalse: [Color red darker])].
	^ patch! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 8/24/2001 12:33'!
upDownAssignment: delta
	"Rotate between increaseBy:  decreaseBy:   _  multiplyBy:"

	| st now want instVar |
	st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self].
	(self nodeClassIs: SelectorNode) ifTrue:
		["kinds of assignment"
		((now _ self decompile asString) beginsWith: 'set') ifTrue:
			["a setX: 3"
			want _ 1+delta.  instVar _ (now allButFirst: 3) allButLast].
		(now endsWith: 'IncreaseBy:') ifTrue:
			["a xIncreaseBy: 3 a setX: (a getX +3)."
			want _ 2+delta.  instVar _ now allButLast: 11].
		(now endsWith: 'DecreaseBy:') ifTrue:
			["a xDecreaseBy: 3 a setX: (a getX -3)."
			want _ 3+delta.  instVar _ now allButLast: 11].
		(now endsWith: 'MultiplyBy:') ifTrue:
			["a xMultiplyBy: 3 a setX: (a getX *3)."
			want _ 4+delta.  instVar _ now allButLast: 11].
		want ifNil: [^ false].
		instVar _ instVar asLowercase.
		want _ #(1 2 3 4) atWrap: want.
		want = 1 ifTrue:
			["setter method is present"
			self setSelector: ('set', instVar capitalized, ':') in: st.  ^ true].
		want = 2 ifTrue:
			["notUnderstood will create the method if needed"
			self setSelector: instVar, 'IncreaseBy:' in: st.  ^ true].
		want = 3 ifTrue:
			["notUnderstood will create the method if needed"
			self setSelector: instVar, 'DecreaseBy:' in: st.  ^ true].
		want = 4 ifTrue:
			["notUnderstood will create the method if needed"
			self setSelector: instVar, 'MultiplyBy:' in: st.  ^ true].
		].
	^ false
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 5/4/2001 11:49'!
upDownDone

	(self nodeClassIs: LiteralNode) ifTrue:
		[self acceptSilently.  "Final compilation logs source"
		self removeProperty: #timeOfLastTick;
			removeProperty: #currentDelay].
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 5/4/2001 12:26'!
upDownMore: delta event: evt arrow: arrowMorph

	| st delay1 delay2 now timeOfLastTick currentDelay |
	(self nodeClassIs: LiteralNode) ifFalse: [^ self].
	st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self].
	delay1 _ 300.  "ms"
	delay2 _ 50.  "ms"
	now _ Time millisecondClockValue.
	timeOfLastTick _ (self valueOfProperty: #timeOfLastTick) ifNil: [now - delay1].
	currentDelay _ (self valueOfProperty: #currentDelay) ifNil: [delay1].
	now >= (timeOfLastTick + currentDelay) ifTrue:
		[self setProperty: #timeOfLastTick toValue: now.
		"decrease the delay"
		self setProperty: #currentDelay toValue: (currentDelay*8//10 max: delay2).
		st contents: (self decompile asNumber + delta) printString.
		^ self acceptUnlogged].
! !


!SyntaxMorph methodsFor: 'printing' stamp: 'tk 9/23/2001 01:33'!
getHeader: strm
	| se |
	"We are in an EToy scriptor and the method header line has been removed.  Try to recover the method name.  Fail if method has args (deal with this later)."

	(se _ self ownerThatIsA: ScriptEditorMorph) ifNotNil: [
		se scriptName numArgs > 0 ifTrue: [^ false].	"abort"
		strm nextPutAll: se scriptName].
	^ true! !

!SyntaxMorph methodsFor: 'printing' stamp: 'dgd 2/22/2003 13:40'!
ownerPrecedence
	"Return the selector precedence of my owner.  1 for unary (asInteger), 2 for binary arithmetic (+), and 3 for keyword selectors (from:to:).  Subtract 0.5 if self is an arg, not the receiver (the case of a + (b + c))"

	| oo below sel pp |
	oo := owner.
	below := self.
	
	[oo isSyntaxMorph ifFalse: [^10].	"I do not need parens"
	oo parseNode isNil] 
			whileTrue: 
				[below := oo.
				oo := oo owner].
	(sel := oo selector) ifNil: [^10].
	(pp := sel precedence) = 3 ifTrue: [^2.5].	"keyword messages need parens"
	^oo receiverNode == below ifTrue: [pp] ifFalse: [pp - 0.5]! !

!SyntaxMorph methodsFor: 'printing' stamp: 'tk 9/23/2001 02:11'!
printAssignmentNodeOn: strm indent: level
	"sometimes an assignment is in parens"
	| parens above |

	parens _ submorphs size >= 3.
	parens ifTrue: [
		above _ self ownerPrecedence.	"high if not in an expression"
		parens _ above <= 3].	"assignment is a noun inside a message"
	parens ifTrue: [strm nextPut: $( ].
	self
		submorphsDoIfSyntax: [ :sub |
			sub printOn: strm indent: level.
			strm ensureASpace.
		]
		ifString: [ :sub |
			strm ensureNoSpace. 	"_ will have a leading space"
			self printSimpleStringMorph: sub on: strm
		].
	parens ifTrue: [strm ensureNoSpace; nextPut: $) ].
! !

!SyntaxMorph methodsFor: 'printing' stamp: 'RAA 3/4/2001 12:19'!
printBlockArgsNodeOn: strm indent: level

	| argString |

	self
		submorphsDoIfSyntax: [ :sub |
			(argString _ sub decompile) isEmpty ifFalse: [
				strm 
					nextPut: $:;
					nextPutAll: argString;
					space
			].
		] 
		ifString: [ :sub |
			"self printSimpleStringMorph: sub on: strm	<<<< do we need this??"
		].
	strm nextPut: $|; crtab: level.

! !

!SyntaxMorph methodsFor: 'printing' stamp: 'tk 9/23/2001 01:17'!
printBlockNodeOn: strm indent: level

	| lev inASyntaxButNotOutermost subNodeClass |

	lev _ level.
	inASyntaxButNotOutermost _ owner isSyntaxMorph and: [ owner isMethodNode not].
	inASyntaxButNotOutermost ifTrue: [strm nextPut: $[.  lev _ lev+1].
	self
		submorphsDoIfSyntax: [ :sub |
			sub printOn: strm indent: lev.
			subNodeClass _ sub parseNode class.
			(#(BlockArgsNode ReturnNode CommentNode) includes: subNodeClass name) ifFalse: [
				strm ensureNoSpace; nextPut: $.].
			subNodeClass == BlockArgsNode
				ifTrue: [strm space]
				ifFalse: [strm crtab: lev].
		] 
		ifString: [ :sub |
			self printSimpleStringMorph: sub on: strm
		].
	inASyntaxButNotOutermost ifTrue: [strm nextPut: $] ].

! !

!SyntaxMorph methodsFor: 'printing' stamp: 'tk 9/23/2001 01:19'!
printCascadeNodeOn: strm indent: level

	| parens cnt me above |

	parens _ parseNode receiver notNil.
	parens ifTrue: [me _ self selector precedence.
		above _ self ownerPrecedence.	"high if not in an expression"
		parens _ me > above].
	parens ifTrue: [strm nextPut: $( ].
	cnt _ 0.
	self
		submorphsDoIfSyntax: [ :sub |
			cnt _ cnt + 1.
			"maybe we want to test sub isCascadePart for the following???"
			cnt > 2 ifTrue: [strm nextPutAll: '; '].
			sub printOn: strm indent: level.
			strm ensureASpace.
		]
		ifString: [ :sub |
			self printSimpleStringMorph: sub on: strm
		].
	parens ifTrue: [strm ensureNoSpace; nextPut: $) ].
! !

!SyntaxMorph methodsFor: 'printing' stamp: 'tk 9/23/2001 01:17'!
printMessageNodeOn: strm indent: level

	| parens me above |

	parens _ parseNode receiver notNil.
	parens ifTrue: [me _ self selector precedence.
		above _ self ownerPrecedence.	"high if not in an expression"
		parens _ me > above].
	parens ifTrue: [strm nextPut: $( ].
	self
		submorphsDoIfSyntax: [ :sub |
			sub printOn: strm indent: level.
			strm ensureASpace.
		]
		ifString: [ :sub |
			self printSimpleStringMorph: sub on: strm
		].
	parens ifTrue: [strm ensureNoSpace; nextPut: $) ].
! !

!SyntaxMorph methodsFor: 'printing' stamp: 'tk 9/23/2001 02:12'!
printMethodNodeOn: strm indent: level

	(self findA: SelectorNode) ifNil: [
		(self getHeader: strm) ifFalse: [^ self].		"might fail"
		strm crtab: level].
	self 
		submorphsDoIfSyntax: [ :sub |
			sub printOn: strm indent: level.
			strm crtab: level.
		]
		ifString: [ :sub |
			self printSimpleStringMorph: sub on: strm
		]. 
	strm last == $. ifTrue: [strm skip: -1].  "ugh!!  erase duplicate final period"! !

!SyntaxMorph methodsFor: 'printing' stamp: 'RAA 3/4/2001 12:08'!
printMethodTempsNodeOn: strm indent: level

	strm nextPut: $|; space.
	self
		submorphsDoIfSyntax: [ :sub |
			sub printOn: strm indent: level.
			strm space.
		]
		ifString: [ :sub |
			self printSimpleStringMorph: sub on: strm
		].
	strm nextPut: $|; crtab: level.
! !

!SyntaxMorph methodsFor: 'printing' stamp: 'tk 10/22/2000 20:43'!
printOn: strm

	super printOn: strm.
	strm space; nextPutAll: parseNode class name.! !

!SyntaxMorph methodsFor: 'printing' stamp: 'tk 9/14/2001 13:52'!
printOn: strm indent: level

	| nodeClass |

	(self hasProperty: #ignoreNodeWhenPrinting) ifFalse: [
		nodeClass _ parseNode class.
		nodeClass == VariableNode ifTrue: [^self printVariableNodeOn: strm indent: level].
		nodeClass == LiteralVariableNode ifTrue: [^self printVariableNodeOn: strm indent: level].
		nodeClass == MessageNode ifTrue: [^self printMessageNodeOn: strm indent: level].
		nodeClass == BlockNode ifTrue: [^self printBlockNodeOn: strm indent: level].
		nodeClass == BlockArgsNode ifTrue: [^self printBlockArgsNodeOn: strm indent: level].
		nodeClass == MethodNode ifTrue: [^self printMethodNodeOn: strm indent: level].
		nodeClass == MethodTempsNode ifTrue: [^self printMethodTempsNodeOn: strm indent: level].
		nodeClass == CascadeNode ifTrue: [^self printCascadeNodeOn: strm indent: level].
		nodeClass == AssignmentNode ifTrue: [^self printAssignmentNodeOn: strm indent: level].
	].
	self
		submorphsDoIfSyntax: [ :sub |
			sub printOn: strm indent: level.
			strm ensureASpace.
		]
		ifString: [ :sub |
			self printSimpleStringMorph: sub on: strm
		].
! !

!SyntaxMorph methodsFor: 'printing' stamp: 'RAA 2/16/2001 18:16'!
printSimpleStringMorph: aMorph on: strm

	| trialContents |

	(aMorph hasProperty: #wordyVariantOfSelf) ifTrue: [
		strm nextPutAll: 'self '.
		strm nextPutAll: ((self translateToWordySelfVariant: aMorph contents) ifNil: [^self]).
		^self
	].
	(aMorph hasProperty: #noiseWord) ifFalse: [
		trialContents _ self cleanUpString: aMorph.
		strm nextPutAll: trialContents
	].
! !

!SyntaxMorph methodsFor: 'printing' stamp: 'RAA 2/13/2001 23:10'!
printStatementsOn: aStream indent: indent

	"seemed to be necessary to see top node in explorer"

	^parseNode printStatementsOn: aStream indent: indent! !

!SyntaxMorph methodsFor: 'printing' stamp: 'ar 8/16/2001 13:29'!
printVariableNodeOn: strm indent: level

	"nil out any old association"
	parseNode key isVariableBinding ifTrue: [
		parseNode 
			name: parseNode name 
			key: nil 
			code: parseNode code
	].
	self
		submorphsDoIfSyntax: [ :sub |
			sub printOn: strm indent: level.
			strm ensureASpace.
		]
		ifString: [ :sub |
			self printSimpleStringMorph: sub on: strm
		].
! !

!SyntaxMorph methodsFor: 'printing' stamp: 'di 11/13/2000 07:43'!
structure
	"Print my structure from inner to outer."
	^ String streamContents: [:s |
		self withAllOwnersDo:
			[:m | m isSyntaxMorph ifTrue:
				[s cr; print: m parseNode class.
				((m nodeClassIs: MessageNode) or: [m nodeClassIs: TileMessageNode]) ifTrue:
					[s space; nextPutAll: m parseNode selector key]]]]! !

!SyntaxMorph methodsFor: 'printing' stamp: 'RAA 3/4/2001 11:55'!
submorphsDoIfSyntax: block1 ifString: block2 

	^self submorphsDoIfSyntax: block1 ifString: block2 otherwise: [ :sub | ]
! !

!SyntaxMorph methodsFor: 'printing' stamp: 'gm 2/22/2003 12:34'!
submorphsDoIfSyntax: block1 ifString: block2 otherwise: block3 
	submorphs do: 
			[:sub | 
			sub isSyntaxMorph 
				ifTrue: [block1 value: sub]
				ifFalse: 
					[(sub isKindOf: StringMorph) 
						ifTrue: [block2 value: sub]
						ifFalse: 
							[(sub isTextMorph) 
								ifTrue: [block2 value: sub]
								ifFalse: [block3 value: sub]]]]! !


!SyntaxMorph methodsFor: 'scripting' stamp: 'tk 9/26/2001 06:01'!
tearOffTile
	"For a SyntaxMorph, this means give a copy of me"

	| dup |
	dup _ self duplicate.
	ActiveHand attachMorph: dup.
	Preferences tileTranslucentDrag
		ifTrue: [^ dup lookTranslucent]
		ifFalse: [^ dup align: dup topLeft with: ActiveHand position + self cursorBaseOffset]
! !


!SyntaxMorph methodsFor: 'selection' stamp: 'di 11/17/2000 08:10'!
currentSelectionDo: blockForSelection
	| rootTile |
	(rootTile _ self rootTile) isMethodNode ifFalse:
		 [^ blockForSelection value: nil value: nil value: nil].
	rootTile valueOfProperty: #selectionSpec ifPresentDo:
		[:selectionSpec | ^ blockForSelection
							value: selectionSpec first
							value: selectionSpec second
							value: selectionSpec third].
	^ blockForSelection value: nil value: nil value: nil! !

!SyntaxMorph methodsFor: 'selection' stamp: 'RAA 2/14/2001 11:33'!
deselect
	self allMorphsDo:
		[:m | m isSyntaxMorph ifTrue: [m setDeselectedColor]].

	"Note following is wasteful because we do a deselect before each select, and it is often the same morph."
	self deletePopup! !

!SyntaxMorph methodsFor: 'selection' stamp: 'tk 1/17/2001 15:07'!
isSelectable
	| ss |
	"Spacer morphs enclose other morphs with the same parseNode"
	self submorphs size > 1 ifTrue: [
		ss _ self submorphs second.
		ss isSyntaxMorph ifTrue: [
			ss parseNode == parseNode ifTrue: [
				^ self submorphs first class ~~ Morph]]].
		
"	(self nodeClassIs: SelectorNode) ifTrue: [^ false].
	(self nodeClassIs: KeyWordNode) ifTrue: [^ false].
"
	self isMethodNode ifTrue: [^ false].
	parseNode ifNil: [^ false].
	^ true! !

!SyntaxMorph methodsFor: 'selection' stamp: 'tk 7/31/2001 17:18'!
scaleColorByUserPref: aColor
	
	| myRoot underLyingColor |

	myRoot _ self rootTile.
	underLyingColor _ myRoot ifNil: [Color transparent] ifNotNil: [myRoot color].
	[underLyingColor isTransparent and: [(myRoot _ myRoot owner) notNil]] whileTrue: [
		underLyingColor _ myRoot color.
	].
	
	"rude hack to get the desired effect before we have an owner"

	underLyingColor isTransparent ifTrue: [underLyingColor _ Color r: 0.903 g: 1.0 b: 0.903].
	^aColor mixed: (ContrastFactor ifNil: [0.3]) with: underLyingColor

"Would like to be able to make MethodNode and outer Block be transparent.  This method does not allow that.  Consider (^ myRoot color) inside the whileTrue.  Consider setting underLyingColor to (myRoot valueOfProperty: #deselectedBorderColor ifAbsent: [myRoot color]) in second line."! !

!SyntaxMorph methodsFor: 'selection' stamp: 'tk 7/23/2001 18:31'!
select
	self deselect.
	"Outer block is not colored and has no popup"
	(owner isSyntaxMorph and: [owner nodeClassIs: MethodNode]) 
		ifTrue: [self setDeselectedColor "normal"]
		ifFalse: [self color: Color lightBrown].
	self borderColor: #raised.
	self offerPopUp.! !

!SyntaxMorph methodsFor: 'selection' stamp: 'tk 7/19/2001 17:52'!
setDeselectedColor
	"The normal color of the tile, stored with the tile"
	| deselectedColor deselectedBorderColor |

	deselectedColor _ self valueOfProperty: #deselectedColor ifAbsent: [nil].
	deselectedBorderColor _ self valueOfProperty: #deselectedBorderColor ifAbsent: [nil].
	deselectedColor ifNotNil: [
		deselectedColor _ self scaleColorByUserPref: deselectedColor].
	deselectedBorderColor ifNotNil: [
		deselectedBorderColor _ self scaleColorByUserPref: deselectedBorderColor].
	self 
		color: (deselectedColor ifNil: [Color transparent]);
		borderColor: (deselectedBorderColor ifNil: [Color transparent])! !

!SyntaxMorph methodsFor: 'selection' stamp: 'dgd 2/22/2003 13:41'!
setSelection: newSpec 
	"A selectionSpec is {Inner morph.  Where clicked.  Outer morph}.
	First mouseDown starts a selection (with outerMorph isNil).
	Dragging more than 4 pixels means to grab a copy of the current outer selection.
		The current selection is the outerMorph, or the inner if it is nil.
	Each mouseUp extends the selection to the next outer morph that is selectable.
		Except if this is the first click."

	| rootTile |
	(rootTile := self rootTile) valueOfProperty: #selectionSpec
		ifPresentDo: [:oldSpec | oldSpec third ifNotNilDo: [:m | m deselect]].
	(newSpec isNil or: [newSpec third isNil and: [self isMethodNode]]) 
		ifTrue: 
			[self deselect.
			^rootTile removeProperty: #selectionSpec].

	"Select outer morph of the new selection"
	newSpec third isNil 
		ifTrue: [self select	"first click down"]
		ifFalse: [newSpec third select	"subsequent clicks"].
	rootTile setProperty: #selectionSpec toValue: newSpec! !


!SyntaxMorph methodsFor: 'stepping and presenter' stamp: 'tk 7/25/2001 11:26'!
step
	super step.
	self isBlockNode ifTrue: [self trackDropZones].
! !


!SyntaxMorph methodsFor: 'submorphs-accessing' stamp: 'tk 1/13/2001 20:41'!
findA: aClass
	| ans |
	"Allow finding on the class of the parseNode"

	(ans _ super findA: aClass) ifNotNil: [^ ans].
	submorphs do: [:ss | 
		ss isSyntaxMorph ifTrue: [
			ss parseNode class == aClass ifTrue: [^ ss]]].
	^ nil! !


!SyntaxMorph methodsFor: 'testing' stamp: 'di 11/3/2000 08:03'!
stepTime

	^ 50! !

!SyntaxMorph methodsFor: 'testing' stamp: 'di 1/30/2001 11:22'!
wantsSteps
	"Only step this morph if we explicitly send startStepping"

	^ false! !


!SyntaxMorph methodsFor: 'tests' stamp: 'di 11/6/2000 10:47'!
test
	3 > 4 ifTrue: [].
	^ self! !

!SyntaxMorph methodsFor: 'tests' stamp: 'gm 2/22/2003 12:35'!
testForNode: targetNode andDo: aBlock 
	targetNode == parseNode ifTrue: [aBlock value: self].
	self submorphsDo: 
			[:each | 
			(each isSyntaxMorph) 
				ifTrue: [each testForNode: targetNode andDo: aBlock]]! !

!SyntaxMorph methodsFor: 'tests' stamp: 'di 11/14/2000 14:54'!
toDo
"
Biggies...
[ ]	Integrate with EToy scriptors
	releaseCachedState can discard all morphic structure.

[ ]	Options:
	Show / hide syntax markers (like [], (), ., :, ;, etc)
	No color / color-in-focus / full color
	Tiles / textiles / text

[ ]	ParsedTextMorph -- looks like text but has all same substructure

[ ]	Introduce notion of an UnParsedNode -- maybe a flag in ParseNode
	Text -> UnParsed -> Parsed -> CodeGen

[ ]	Need DnD evaluator, or some sort of '!!' button on any entity (halo?)
	Also inspector / browser

[ ]	All the type help we can get

Details ...
[ ]	Open up the parse of BraceNodes

[ ]	Verify that all pastes are OK

[ ]	Colors not yet right for colored version.

[ ]	Start work on show / hide of syntax markers -- (), [], etc.

[ ]	Start work on textiles (grabable entites in 'normal' text)

[ ]	Need autoscroll during drag for drop

[ ]	Use, eg, shift-drag to move, del to delete

[ ]	What about invalid drops -- stick on cursor?

System...
[ ]	Only keep history 7 deep; option to clear on quit
	clear command above spaceLeft

[ ]	Compute each page of prefs viewer on demand instead of as now.

[ ]	Offer a search command that will gather up all preferences that match a given string (name or help string)

Preferences enable: #noTileColor.
Preferences disable: #noTileColor.
Smalltalk browseAllSelect: [:cm | cm size > 600]
SyntaxMorph testAll
"! !


!SyntaxMorph methodsFor: 'type checking' stamp: 'sw 2/23/2001 23:40'!
argTypeFor: aSelector
	"Answer the type of the argument of this selector.  Return #unknown if not found."

	| itsInterface |
	aSelector numArgs = 0 
		ifTrue: [self inform: aSelector, ' does not take an argument'. ^ #error "7"].
	itsInterface _ self currentVocabulary methodInterfaceAt: aSelector ifAbsent:
		[^ #unknown].
	^ itsInterface typeForArgumentNumber: 1! !

!SyntaxMorph methodsFor: 'type checking' stamp: 'sw 2/15/2001 14:25'!
okToBeReplacedBy: aSyntaxMorph
	"Return true if it is OK to replace me with aSyntaxMorph.  Enforce the type rules in the old EToy green tiles."

	| itsType myType |
	(Preferences eToyFriendly or: [Preferences typeCheckingInTileScripting])
		ifFalse: [^ true].	"not checking unless one of those prefs is true"
	(parseNode class == BlockNode and: [aSyntaxMorph parseNode class == BlockNode]) 
		ifTrue: [^ true].
	(parseNode class == ReturnNode and: [aSyntaxMorph parseNode class == ReturnNode]) 
		ifTrue: [^ true].
	parseNode class == KeyWordNode ifTrue: [^ false].
	aSyntaxMorph parseNode class == KeyWordNode ifTrue: [^ false].
	parseNode class == SelectorNode ifTrue: [^ false].
	aSyntaxMorph parseNode class == SelectorNode ifTrue: [^ false].
	owner isSyntaxMorph ifFalse: [^ true].	"only within a script"
		"Transcript show: aSyntaxMorph resultType printString, ' dropped on ', 
			self receiverOrArgType printString; cr.
		"
	(itsType _ aSyntaxMorph resultType) == #unknown ifTrue: [^ true].
	(myType _ self receiverOrArgType) == #unknown ifTrue: [^ true].
		"my type in enclosing message"
	^ myType = itsType! !

!SyntaxMorph methodsFor: 'type checking' stamp: 'tk 2/9/2001 15:56'!
receiverOrArgType
	| ty |
	"Return my type in my role as a receiver or as an argument.  Ask my enclosing message first, then ask myself.  (If owner accepts any #object, and I am a #point, do return #object.)"

	^ (ty _ self receiverOrArgTypeAbove) == #unknown
		ifTrue: [self resultType]
		ifFalse: [ty]! !

!SyntaxMorph methodsFor: 'type checking' stamp: 'dgd 2/22/2003 18:48'!
receiverOrArgTypeAbove
	"Return the type for me according to the message that encloses me."

	| enclosing sub list |
	(self nodeClassIs: BlockNode) ifTrue: [^#command].
	enclosing := owner.
	sub := self.
	
	[enclosing isSyntaxMorph ifFalse: [^#unknown].
	(enclosing nodeClassIs: MessageNode) 
		ifTrue: 
			[list := enclosing submorphs 
						select: [:ss | ss isSyntaxMorph and: [ss parseNode notNil]].
			list size = 1 
				ifFalse: 
					[^(list indexOf: sub) = 1 
						ifTrue: [enclosing receiverTypeFor: enclosing selector]
						ifFalse: [enclosing argTypeFor: enclosing selector]]].
	(enclosing nodeClassIs: BlockNode) ifTrue: [^#command].
	sub := enclosing.
	enclosing := enclosing owner.
	true] 
			whileTrue! !

!SyntaxMorph methodsFor: 'type checking' stamp: 'sw 2/27/2001 09:11'!
receiverTypeFor: aSelector
	"Answer the type of the receiver of this selector.  Return #unknown if not found."

	| itsInterface |

	aSelector ifNil: [^ #unknown].
	itsInterface _ self currentVocabulary methodInterfaceAt: aSelector ifAbsent:
		[^ #unknown].
	^ itsInterface receiverType! !

!SyntaxMorph methodsFor: 'type checking' stamp: 'yo 7/22/2005 16:43'!
resultType
	"Look up my result type.  If I am a constant, use that class.  If I am a message, look up the selector."

	| list value soundChoices |
	parseNode class == BlockNode ifTrue: [^#blockContext].
	parseNode class == AssignmentNode ifTrue: [^#command].
	parseNode class == ReturnNode ifTrue: [^#command].	"Need more restriction than this"
	list := submorphs 
				select: [:ss | ss isSyntaxMorph and: [ss parseNode notNil]].
	list size > 1 ifTrue: [^self resultTypeFor: self selector].
	list size = 1 
		ifTrue: 
			["test for levels that are just for spacing in layout"

			(list first isSyntaxMorph and: [list first nodeClassIs: MessageNode]) 
				ifTrue: [^list first resultType]].	"go down one level"
	value := self try.
	value class == Error ifTrue: [^#unknown].
	(value isNumber) ifTrue: [^#Number].
	(value isKindOf: Boolean) ifTrue: [^#Boolean].
	(value isForm) ifTrue: [^#Graphic].
	(value isPlayerLike and: [value costume renderedMorph isMemberOf: KedamaPatchMorph]) ifTrue: [^#Patch].
	value isString
		ifTrue: 
			[soundChoices := #('silence').	"default, if no SampledSound class"
			Smalltalk at: #SampledSound
				ifPresent: [:sampledSound | soundChoices := sampledSound soundNames].
			(soundChoices includes: value) ifTrue: [^#Sound]].
	(value isPlayerLike) ifTrue: [^#Player].
	^value class name asLowercase	"asSymbol (not needed)"! !

!SyntaxMorph methodsFor: 'type checking' stamp: 'sw 2/24/2001 12:13'!
resultTypeFor: aSelector
	"Answer the result type of selector.  Return #unknown if not found."

	| itsInterface |
	aSelector ifNil: [self inform: 'Please tell Ted how you caused this'.
		^ #abs "a bogus type"].
	itsInterface _ self currentVocabulary methodInterfaceAt: aSelector ifAbsent:
		[^ #unknown].
	^ itsInterface resultType! !


!SyntaxMorph methodsFor: 'updating' stamp: 'di 11/13/2000 20:30'!
update: aSymbol

	| bingo saveOwner newMorph db |

	(db _ self debugger) ifNil: [^super update: aSymbol].
	aSymbol == #contents ifTrue: [
		saveOwner _ owner.
		db removeDependent: self.
		markerMorph ifNotNil: [markerMorph delete. markerMorph _ nil].
		newMorph _ db createSyntaxMorph.
		self delete.
		saveOwner addMorph: newMorph.
		saveOwner owner setScrollDeltas.
		newMorph update: #contentsSelection.
	].
	aSymbol == #contentsSelection ifTrue: [
		markerMorph ifNil: [
			markerMorph _ RectangleMorph new.
			markerMorph
				color: Color transparent;
				borderWidth: 2;
				borderColor: Color red;
				lock.
			owner addMorphFront: markerMorph.
		].
		bingo _ parseNode rawSourceRanges keyAtValue: db pcRange ifAbsent: [nil].
		self testForNode: bingo andDo: [ :foundMorph | 
			markerMorph
				position: foundMorph position;
				extent: foundMorph extent.
			owner owner scrollIntoView: foundMorph bounds extra: 0.5.
			^self
		].
	].
	super update: aSymbol! !


!SyntaxMorph methodsFor: 'viewer' stamp: 'tk 11/5/2001 08:32'!
externalName

	^ self knownName ifNil: [
		parseNode ifNil: ['Syntax -- (extra layer)']
				ifNotNil: [self parseNode class printString]]! !


!SyntaxMorph methodsFor: 'visual properties' stamp: 'tk 7/31/2001 16:53'!
fillStyle: aFillStyle

	aFillStyle isColor 
		ifTrue: [self color: aFillStyle]	"so we will process it"
		ifFalse: [super fillStyle: aFillStyle].
! !


!SyntaxMorph methodsFor: 'vocabulary' stamp: 'gm 2/22/2003 12:31'!
limitClassToUseWith: aValue vocabulary: aVocabulary 
	"Answer the most generic whose method should be shown in a selector pop-up in the receiver that is put up on behalf of aValue"

	(aValue isNumber) ifTrue: [^Number].
	"Ted: This hook allows you to intervene as suits your purposes here if you don't like the defaults."
	^aValue defaultLimitClassForVocabulary: aVocabulary! !

!SyntaxMorph methodsFor: 'vocabulary' stamp: 'gm 2/22/2003 12:48'!
vocabularyToUseWith: aValue 
	"Answer a vocabulary to use with the given value"

	(aValue isNumber) ifTrue: [^Vocabulary numberVocabulary].
	(aValue isKindOf: Time) ifTrue: [^Vocabulary vocabularyForClass: Time].
	(aValue isString) ifTrue: [^Vocabulary vocabularyForClass: String].
	aValue class isUniClass ifTrue: [^Vocabulary eToyVocabulary].
	^self currentVocabulary! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SyntaxMorph class
	instanceVariableNames: ''!

!SyntaxMorph class methodsFor: 'accessing' stamp: 'tk 9/18/2001 16:10'!
sourceCodeTemplate
	"Return the default tile method template"

	^ 'anEmpty: input1 method: input2
	"Edit the name above and the code below to make your own method"
	3 + 4.
	"Drag tiles in here.  Use the ''tiles'' and ''vars'' menus to get new tiles"
	^ ''this is a statement'' sort'  
! !


!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 2/26/2001 22:59'!
column: aColor on: aParseNode

	| c color |
	color _ self translateColor: aColor.
	(c _ self newColumn)
		parseNode: aParseNode;
		layoutInset: c standardInset;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		color: color;
		borderWidth: 1;
		borderColor: c stdBorderColor;
		wrapCentering: #topLeft;
		cellPositioning: c standardCellPositioning.
	^c
! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 2/16/2001 15:37'!
methodNodeOuter: aNode

	^(self column: #method on: aNode) methodNodeOuter: aNode
! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'di 11/13/2000 21:12'!
noTileColor

	^ true! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 2/26/2001 23:00'!
row: aColor on: aParseNode

	| r color |
	color _ self translateColor: aColor.
	(r _ self newRow)
		parseNode: aParseNode;
		layoutInset: r standardInset;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		color: color;
		borderWidth: 1;
		borderColor: r stdBorderColor;
		wrapCentering: #topLeft;
		cellPositioning: r standardCellPositioning.
	^r! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/2/2001 09:59'!
setSize: oldExtent andMakeResizable: outerMorph
	| tw |
	(tw _ outerMorph findA: TwoWayScrollPane) ifNil: [^self].
	tw hResizing: #spaceFill;
		vResizing: #spaceFill;
		color: Color transparent;
		setProperty: #hideUnneededScrollbars toValue: true.
	outerMorph 
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		cellPositioning: #topLeft.
	outerMorph fullBounds.
! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 2/26/2001 22:56'!
standardInset

	^ self alansTest1 ifTrue: [1] ifFalse: [-1@-1]! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/24/1999 11:59'!
test

"
SyntaxMorph test
"
	self testClass: MessageNode andMethod: #asMorphicSyntaxIn:.
	"self testClass: MethodNode andMethod: #asMorphicSyntaxIn:."

! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'dvf 8/23/2003 12:20'!
testAll

	| source tree total count systNav|
"
SyntaxMorph testAll
"
	systNav _ self systemNavigation.
	count _ total _ 0.
	systNav allBehaviorsDo: [ :aClass | total _ total + 1].
'Testing all behaviors'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: total
	during: [ :bar |
		systNav allBehaviorsDo: [ :aClass |
			bar value: (count _ count + 1).
			aClass selectors do: [ :aSelector |
				source _ (aClass compiledMethodAt: aSelector) getSourceFromFile.
				tree _ Compiler new 
					parse: source 
					in: aClass 
					notifying: nil.
				tree asMorphicSyntaxUsing: SyntaxMorph.
			].
		].	].


! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'dvf 8/23/2003 12:20'!
testAllMethodsOver: methodSize 
	"MessageTally spyOn: [SyntaxMorph testAllMethodsOver: 600]"
	"Add up the total layout area for syntax morphs representing all  
	methods over the given size. This is a stress-test for SyntaxMorph  
	layout. A small value for the total area is also a figure of merit in the  
	presentation of Squeak source code in general."
	"Results:  
	#(69 600 180820874 103700) 11/4  
	70% build morphs, 12% get source, 9% layout, 8% parse, 1% roundoff  
	Folded wide receivers, don't center keywords any more.  
	#(68 600 160033784 127727) 11/9  
	76% build morphs, 8% get source, 8% layout, 8% parse, 0% roundoff  
	Folded more messages, dropped extra vertical spacing in blocks.  
	#(68 600 109141704 137308) 11/10  
	79% build morphs, 6% get source, 8% layout, 7% parse  
	Folded more messages, dropped extra horizontal spacing.  
	#(68 600 106912968 132171) 11/10  
	80% build morphs, ??% get source, 11% layout, 7% parse  
	Unfolded keyword messages that will fit on one line.  
	#(68 600 96497372 132153) 11/10  
	81% build morphs, ??% get source, 8% layout, 8% parse  
	After alignment rewrite...  
	#(74 600 101082316 244799) 11/12  
	76% build morphs, 4% get source, 15% layout, 5% parse  
	After alignment rewrite...  
	#(74 600 101250620 204972) 11/15  
	74% build morphs, 6% get source, 13% layout, 7% parse  
	"
	| tree source biggies morph stats time area |
	biggies _ self systemNavigation 
				allMethodsSelect: [:cm | cm size > methodSize].
	stats _ OrderedCollection new.
	'Laying out all ' , biggies size printString , ' methods over ' , methodSize printString , ' bytes...'
		displayProgressAt: Sensor cursorPoint
		from: 1
		to: biggies size
		during: [:bar | biggies
				withIndexDo: [:methodRef :i | 
					bar value: i.
					Utilities
						setClassAndSelectorFrom: methodRef
						in: [:aClass :aSelector | 
							source _ (aClass compiledMethodAt: aSelector) getSourceFromFile.
							time _ Time
										millisecondsToRun: [tree _ Compiler new
														parse: source
														in: aClass
														notifying: nil.
											morph _ tree asMorphicSyntaxUsing: SyntaxMorph.
											area _ morph fullBounds area]].
					stats add: {methodRef. area. time}]].
	^ {{biggies size. methodSize. stats
		detectSum: [:a | a second]. stats
		detectSum: [:a | a third]}. (stats
		asSortedCollection: [:x :y | x third >= y third]) asArray}! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'di 7/30/2001 16:29'!
testClass: aClass andMethod: aSelector
	| tree |
	tree _ Compiler new 
		parse: (aClass sourceCodeAt: aSelector) 
		in: aClass 
		notifying: nil.
	(tree asMorphicSyntaxUsing: SyntaxMorph)
		parsedInClass: aClass;
		openInWindow! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 7/19/2001 20:06'!
translateColor: aColorOrSymbol

	aColorOrSymbol isColor  ifTrue: [^ aColorOrSymbol].
	aColorOrSymbol == #comment  ifTrue: [^ Color blue lighter].
	aColorOrSymbol == #block  ifTrue: [^ Color r: 0.903 g: 1.0 b: 0.903].
	aColorOrSymbol == #method  ifTrue: [^ Color r: 0.903 g: 1.0 b: 0.903].
	aColorOrSymbol == #text  ifTrue: [^ Color r: 0.9 g: 0.9 b: 0.9].

	self noTileColor ifTrue: [^ Color r: 1.0 g: 0.839 b: 0.613].	"override"

	aColorOrSymbol == #assignment  ifTrue: [^ Color paleGreen].
	aColorOrSymbol == #keyword1  ifTrue: [^ Color paleBuff].	"binary"
	aColorOrSymbol == #keyword2  ifTrue: [^ Color paleBuff lighter].	"multipart" 
	aColorOrSymbol == #cascade  ifTrue: [^ Color paleYellow darker].	"has receiver"
	aColorOrSymbol == #cascade2  ifTrue: [^ Color paleOrange].	"one send in the cascade"
	aColorOrSymbol == #literal  ifTrue: [^ Color paleMagenta].
	aColorOrSymbol == #message  ifTrue: [^ Color paleYellow].
	aColorOrSymbol == #method  ifTrue: [^ Color white].
	aColorOrSymbol == #error  ifTrue: [^ Color red].
	aColorOrSymbol == #return  ifTrue: [^ Color lightGray].
	aColorOrSymbol == #variable  ifTrue: [^ Color paleTan].
	aColorOrSymbol == #brace  ifTrue: [^ Color paleOrange].
	aColorOrSymbol == #tempVariable  ifTrue: [^ Color paleYellow mixed: 0.75 with: Color paleGreen
		"Color yellow lighter lighter"].
	aColorOrSymbol == #blockarg2  ifTrue: [
			^ Color paleYellow mixed: 0.75 with: Color paleGreen].	"arg itself"
	aColorOrSymbol == #blockarg1  ifTrue: [^ Color paleRed].	"container"
		"yellow mixed: 0.5 with: Color white"

	^ Color tan	"has to be something!!"! !


!SyntaxMorph class methodsFor: '*flexibleVocabularies-flexiblevocabularies-accessing' stamp: 'stephaneducasse 2/4/2006 20:33'!
allSpecs
	"Return all specs that the Viewer knows about. Cache them."
	"SyntaxMorph allSpecs"

	^AllSpecs ifNil: [
		AllSpecs := Dictionary new.
		(EToyVocabulary morphClassesDeclaringViewerAdditions)
			do: [:cls | cls allAdditionsToViewerCategories keysAndValuesDo: [ :k :v | 
				(AllSpecs at: k ifAbsentPut: [ OrderedCollection new ]) addAll: v ] ].
		AllSpecs
	]! !

!SyntaxMorph class methodsFor: '*flexibleVocabularies-flexiblevocabularies-accessing' stamp: 'stephaneducasse 2/4/2006 20:33'!
clearAllSpecs
	"Clear the specs that the Viewer knows about."
	"SyntaxMorph clearAllSpecs"

	AllSpecs := nil.! !
UpdatingStringMorph subclass: #SyntaxUpdatingStringMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Tile Scriptors'!

!SyntaxUpdatingStringMorph methodsFor: 'drawing' stamp: 'tk 1/31/2002 09:53'!
drawOn: aCanvas

	| tempForm strm where chars wid spaceWidth putLigature topOfLigature sizeOfLigature colorOfLigature dots charZero canvas f |

	tempForm _ Form extent: self extent depth: aCanvas depth.
	canvas _ tempForm getCanvas.
	f _ self fontToUse.
	spaceWidth _ f widthOf: Character space.
	strm _ ReadStream on: contents.
	charZero _ Character value: 0.	"a marker for center dot ·"
	where _ 0@0.
	topOfLigature _ self height // 2 - 1.
	sizeOfLigature _ (spaceWidth-2)@(spaceWidth-2).
	colorOfLigature _ Color black alpha: 0.45	"veryLightGray".
	dots _ OrderedCollection new.
	putLigature _ [
		dots add: ((where x + 1) @ topOfLigature extent: sizeOfLigature).
		where _ where + (spaceWidth@0)].
	strm peek = charZero ifTrue: [
		strm next.
		putLigature value].
	[strm peek = charZero] whileTrue: [strm next].
	[strm atEnd] whileFalse: [
		chars _ strm upTo: charZero.
		wid _ f widthOfString: chars.
		canvas drawString: chars at: where.
		where _ where + (wid@0).
		strm atEnd ifFalse: [putLigature value.
			[strm peek = charZero] whileTrue: [strm next]].
	].
	aCanvas paintImage: tempForm at: self topLeft.
	dots do: [ :each |
		aCanvas 
			fillRectangle: (each translateBy: self topLeft) 
			fillStyle: colorOfLigature.
	].
! !
AppRegistry subclass: #SystemBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Base'!
!SystemBrowser commentStamp: '<historical>' prior: 0!
This is the AppRegistry class for class browsing!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemBrowser class
	instanceVariableNames: ''!

!SystemBrowser class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:28'!
initialize
	| pref |
	pref := Preferences preferenceAt: #browserShowsPackagePane.
	Preferences
		addPreference: #browserShowsPackagePane
		categories: pref categoryList
		default: pref defaultValue
		balloonHelp: pref helpString
		projectLocal: pref localToProject
		changeInformee: self
		changeSelector: #packagePanePreferenceChanged
		! !


!SystemBrowser class methodsFor: 'events' stamp: 'sd 11/20/2005 21:28'!
packagePanePreferenceChanged
	| theOtherOne |
	self registeredClasses size = 2
		ifTrue: [theOtherOne := (self registeredClasses copyWithout: PackagePaneBrowser) first]
		ifFalse: [theOtherOne := nil].
	(Preferences valueOfFlag: #browserShowsPackagePane ifAbsent: [false])
		ifTrue: [self default: PackagePaneBrowser]
		ifFalse: [self default: theOtherOne].
	SystemNavigation default browserClass: self default.! !


!SystemBrowser class methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:28'!
unload
	| pref |
	pref := Preferences preferenceAt: #browserShowsPackagePane.
	Preferences
		addPreference: #browserShowsPackagePane
		categories: pref categoryList
		default: pref defaultValue
		balloonHelp: pref helpString
		projectLocal: pref localToProject
		changeInformee: nil
		changeSelector: nil
		! !


!SystemBrowser class methodsFor: 'instance creation' stamp: 'hpt 8/5/2004 20:27'!
defaultOpenBrowser
	^self default openBrowser! !


!SystemBrowser class methodsFor: 'registration' stamp: 'hpt 9/30/2004 20:53'!
addRegistryMenuItemsTo: aMenu inAccountOf: aBrowser 
	"Add some useful options related Browser registry to the
	browsers windows menu"
	aMenu addLine;
		add: 'Register this Browser as default'
		target: [self default: aBrowser class]
		action: #value;
		add: 'Choose new default Browser'
		target: self
		action: #askForDefault! !
SystemChangeTestRoot subclass: #SystemChangeErrorHandling
	instanceVariableNames: 'capturedEvents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SystemChangeNotification-Tests'!
!SystemChangeErrorHandling commentStamp: 'rw 4/3/2006 17:21' prior: 0!
This class tests the error handing of the notification mechanism to ensure that one client that receives a system change cannot lock up the complete system."!


!SystemChangeErrorHandling methodsFor: 'Event Notifications' stamp: 'rw 4/3/2006 17:57'!
handleEventWithError: event

	self error: 'Example of event handling code that throws an error.'! !

!SystemChangeErrorHandling methodsFor: 'Event Notifications' stamp: 'rw 4/3/2006 18:07'!
handleEventWithHalt: event

	self halt: 'Example of event handling code that contains a halt.'! !

!SystemChangeErrorHandling methodsFor: 'Event Notifications' stamp: 'rw 4/3/2006 17:57'!
storeEvent1: anEvent

	capturedEvents add: anEvent! !

!SystemChangeErrorHandling methodsFor: 'Event Notifications' stamp: 'rw 4/3/2006 17:57'!
storeEvent2: anEvent

	capturedEvents add: anEvent! !

!SystemChangeErrorHandling methodsFor: 'Event Notifications' stamp: 'rw 4/3/2006 17:57'!
storeEvent3: anEvent

	capturedEvents add: anEvent! !


!SystemChangeErrorHandling methodsFor: 'Running' stamp: 'rw 4/3/2006 17:51'!
setUp

	super setUp.
	capturedEvents := OrderedCollection new! !

!SystemChangeErrorHandling methodsFor: 'Running' stamp: 'rw 4/3/2006 17:56'!
tearDown

	capturedEvents := nil.
	super tearDown! !


!SystemChangeErrorHandling methodsFor: 'Testing' stamp: 'rw 4/5/2006 17:24'!
testErrorOperation

	| notifier wasCaptured |
	notifier := self systemChangeNotifier.
	wasCaptured := false.
	notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent1:.
	notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent2:.
	notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #handleEventWithError:.
	notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent3:.
	[notifier classAdded: self class inCategory: #FooCat] on: Error do: [:exc |
		wasCaptured := true.
		self assert: (capturedEvents size = 3)].
	self assert: wasCaptured.! !

!SystemChangeErrorHandling methodsFor: 'Testing' stamp: 'rw 4/5/2006 17:24'!
testHaltOperation
	
	| notifier wasCaptured |
	notifier := self systemChangeNotifier.
	wasCaptured := false.
	notifier notify: self ofAllSystemChangesUsing: #storeEvent1:.
	notifier notify: self ofAllSystemChangesUsing: #storeEvent2:.
	notifier notify: self ofAllSystemChangesUsing: #handleEventWithHalt:.
	notifier notify: self ofAllSystemChangesUsing: #storeEvent3:.
	[notifier classAdded: self class inCategory: #FooCat] on: Halt do: [:exc |
		wasCaptured := true.
		self assert: (capturedEvents size = 3)].
	self assert: wasCaptured.! !

!SystemChangeErrorHandling methodsFor: 'Testing' stamp: 'rw 4/5/2006 17:24'!
testUnhandledEventOperation

	| notifier wasCaptured |
	notifier := self systemChangeNotifier.
	wasCaptured := false.
	notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent1:.
	notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent2:.
	notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #zork:.
	notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent3:.
	[notifier classAdded: self class inCategory: #FooCat] on: MessageNotUnderstood do: [:exc |
		wasCaptured := true.
		self assert: (capturedEvents size = 3)].
	self assert: wasCaptured.! !
Object subclass: #SystemChangeNotifier
	instanceVariableNames: 'eventSource silenceLevel'
	classVariableNames: 'UniqueInstance'
	poolDictionaries: ''
	category: 'System-Change Notification'!

!SystemChangeNotifier methodsFor: 'initialize' stamp: 'NS 1/26/2004 20:41'!
initialize

	eventSource := SystemEventManager new.
	silenceLevel _ 0.! !


!SystemChangeNotifier methodsFor: 'public' stamp: 'NS 1/28/2004 11:29'!
doSilently: aBlock
	"Perform the block, and ensure that no system notification are broadcasted while doing so."

	| result |
	silenceLevel := silenceLevel + 1.
	[result := aBlock value] ensure: [silenceLevel > 0 ifTrue: [silenceLevel := silenceLevel - 1]].
	^ result.! !

!SystemChangeNotifier methodsFor: 'public' stamp: 'NS 1/26/2004 20:41'!
isBroadcasting

	^ silenceLevel = 0! !

!SystemChangeNotifier methodsFor: 'public' stamp: 'rw 7/29/2003 17:01'!
noMoreNotificationsFor: anObject
	"Stop sending system notifications to an object."

	eventSource removeActionsWithReceiver: anObject! !

!SystemChangeNotifier methodsFor: 'public' stamp: 'rw 7/10/2003 12:00'!
notify: anObject ofAllSystemChangesUsing: oneArgumentSelector 
	"Notifies an object of any system changes."

	self 
		notify: anObject
		ofEvents: self allSystemEvents
		using: oneArgumentSelector! !

!SystemChangeNotifier methodsFor: 'public' stamp: 'bvs 7/20/2004 12:13'!
notify: anObject ofSystemChangesOfChange: changeKind using: oneArgumentSelector 
	"Notifies an object of system changes of the specified changeKind (#added, #removed, ...). Evaluate 'AbstractEvent allChangeKinds' to get the complete list."

	self 
		notify: anObject
		ofEvents: (self systemEventsForChange: changeKind)
		using: oneArgumentSelector! !

!SystemChangeNotifier methodsFor: 'public' stamp: 'bvs 7/20/2004 12:13'!
notify: anObject ofSystemChangesOfItem: itemKind change: changeKind using: oneArgumentSelector 
	"Notifies an object of system changes of the specified itemKind (#class, #category, ...) and changeKind (#added, #removed, ...). This is the finest granularity possible.
	Evaluate 'AbstractEvent allChangeKinds' to get the complete list of change kinds, and 'AbstractEvent allItemKinds to get all the possible item kinds supported."

	self 
		notify: anObject
		ofEvents: (Bag with: (self systemEventsForItem: itemKind change: changeKind))
		using: oneArgumentSelector! !

!SystemChangeNotifier methodsFor: 'public' stamp: 'bvs 7/20/2004 12:13'!
notify: anObject ofSystemChangesOfItem: itemKind  using: oneArgumentSelector 
	"Notifies an object of system changes of the specified itemKind (#class, #method, #protocol, ...). Evaluate 'AbstractEvent allItemKinds' to get the complete list."

	self 
		notify: anObject
		ofEvents: (self systemEventsForItem: itemKind)
		using: oneArgumentSelector! !


!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'ab 2/10/2005 16:32'!
classCategoryAdded: aClassCategoryName

	self trigger: (AddedEvent
					classCategory: aClassCategoryName)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'ab 2/10/2005 16:35'!
classCategoryRemoved: aClassCategoryName

	self trigger: (RemovedEvent
					classCategory: aClassCategoryName)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'ab 2/10/2005 16:44'!
classCategoryRenamedFrom: anOldClassCategoryName to: aNewClassCategoryName

	self trigger: (RenamedEvent
					classCategoryRenamedFrom: anOldClassCategoryName 
					to: aNewClassCategoryName)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'rw 7/29/2003 15:12'!
class: aClass recategorizedFrom: oldCategory to: newCategory 
	self trigger: (RecategorizedEvent 
				class: aClass
				category: newCategory
				oldCategory: oldCategory)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'rw 7/29/2003 15:11'!
classAdded: aClass inCategory: aCategoryName 
	self trigger: (AddedEvent class: aClass category: aCategoryName)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/26/2004 09:37'!
classCommented: aClass
	"A class with the given name was commented in the system."

	self trigger: (CommentedEvent class: aClass)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'rw 7/29/2003 15:11'!
classCommented: aClass inCategory: aCategoryName 
	"A class with the given name was commented in the system."

	self trigger: (CommentedEvent class: aClass category: aCategoryName)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/20/2004 19:37'!
classDefinitionChangedFrom: oldClass to: newClass
	self trigger: (ModifiedClassDefinitionEvent classDefinitionChangedFrom: oldClass to: newClass)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/16/2004 15:10'!
classRemoved: aClass fromCategory: aCategoryName 
	self trigger: (RemovedEvent class: aClass category: aCategoryName)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 12:19'!
classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName 
	self trigger: (RenamedEvent 
				class: aClass
				category: aCategoryName
				oldName: oldClassName
				newName: newClassName)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 12:48'!
classReorganized: aClass
	self trigger: (ReorganizedEvent class: aClass)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/19/2004 09:48'!
evaluated: textOrStream
	^ self evaluated: textOrStream context: nil.! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/19/2004 09:47'!
evaluated: expression context: aContext
	self trigger: (DoItEvent 
				expression: expression
				context: aContext)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:24'!
methodAdded: aMethod selector: aSymbol inClass: aClass 
	"A method with the given selector was added to aClass, but not put in a protocol."

	self trigger: (AddedEvent
				method: aMethod 
				selector: aSymbol
				class: aClass)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:24'!
methodAdded: aMethod selector: aSymbol inClass: aClass requestor: requestor
	"A method with the given selector was added to aClass, but not put in a protocol."

	self trigger: (AddedEvent
				method: aMethod 
				selector: aSymbol
				class: aClass
				requestor: requestor)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:24'!
methodAdded: aMethod selector: aSymbol inProtocol: aCategoryName class: aClass 
	"A method with the given selector was added to aClass in protocol aCategoryName."

	self trigger: (AddedEvent
				method: aMethod
				selector: aSymbol
				protocol: aCategoryName
				class: aClass)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:24'!
methodAdded: aMethod selector: aSymbol inProtocol: aCategoryName class: aClass requestor: requestor
	"A method with the given selector was added to aClass in protocol aCategoryName."

	self trigger: (AddedEvent
				method: aMethod
				selector: aSymbol
				protocol: aCategoryName
				class: aClass
				requestor: requestor)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:41'!
methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass
	self trigger: (ModifiedEvent
					methodChangedFrom: oldMethod
					to: newMethod
					selector: aSymbol 
					inClass: aClass)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:41'!
methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass requestor: requestor
	self trigger: (ModifiedEvent
					methodChangedFrom: oldMethod
					to: newMethod
					selector: aSymbol 
					inClass: aClass
					requestor: requestor)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/28/2004 11:12'!
methodRemoved: aMethod selector: aSymbol class: aClass 
	"A method with the given selector was removed from the class."

	self trigger: (RemovedEvent
				method: aMethod 
				selector: aSymbol
				class: aClass)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/28/2004 11:11'!
methodRemoved: aMethod selector: aSymbol inProtocol: protocol class: aClass 
	"A method with the given selector was removed from the class."

	self trigger: (RemovedEvent
				method: aMethod 
				selector: aSymbol
				protocol: protocol
				class: aClass)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 4/7/2004 13:35'!
selector: selector recategorizedFrom: oldCategory to: newCategory inClass: aClass

	self trigger: (RecategorizedEvent 
				method: (aClass compiledMethodAt: selector ifAbsent: [nil])
				protocol: newCategory
				class: aClass
				oldProtocol: oldCategory)! !

!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'al 7/18/2004 10:48'!
traitDefinitionChangedFrom: oldTrait to: newTrait
	self trigger: (ModifiedTraitDefinitionEvent traitDefinitionChangedFrom: oldTrait to: newTrait)! !



!SystemChangeNotifier methodsFor: 'private' stamp: 'rw 7/10/2003 15:15'!
notify: anObject ofEvents: eventsCollection using: oneArgumentSelector
	"Notifies an object of any events in the eventsCollection. Send it back a message #oneArgumentSelector, with as argument the particular system event instance."

	eventsCollection do: [:eachEvent |
		eventSource when: eachEvent send: oneArgumentSelector to: anObject]! !

!SystemChangeNotifier methodsFor: 'private' stamp: 'rw 7/29/2003 17:05'!
releaseAll
	"Release all the dependents so that nobody receives notifications anymore."

	"Done for cleaning up the system."
	"self uniqueInstance releaseAll"

	eventSource releaseActionMap! !

!SystemChangeNotifier methodsFor: 'private' stamp: 'NS 1/26/2004 20:43'!
setBroadcasting
	silenceLevel := 0.! !

!SystemChangeNotifier methodsFor: 'private' stamp: 'NS 1/26/2004 20:41'!
trigger: event

	self isBroadcasting ifTrue: [event trigger: eventSource]

"	| caughtExceptions |
	caughtExceptions := OrderedCollection new.
	self isBroadcasting ifTrue: [
		[(eventSource actionForEvent: event eventSelector) valueWithArguments: (Array with: event)] on: Exception do: [:exc | caughtExceptions add: exc]].
	caughtExceptions do: [:exc | exc resignalAs: exc class new]"! !


!SystemChangeNotifier methodsFor: 'private-event lists' stamp: 'rw 7/29/2003 15:14'!
allSystemEvents
	^AbstractEvent systemEvents! !

!SystemChangeNotifier methodsFor: 'private-event lists' stamp: 'rw 7/29/2003 15:14'!
systemEventsForChange: changeKind 
	| selectorBlock |
	selectorBlock := AbstractEvent eventSelectorBlock.
	^AbstractEvent allItemKinds 
		collect: [:itemKind | selectorBlock value: itemKind value: changeKind]! !

!SystemChangeNotifier methodsFor: 'private-event lists' stamp: 'rw 7/29/2003 15:14'!
systemEventsForItem: itemKind 
	| selectorBlock |
	selectorBlock := AbstractEvent eventSelectorBlock.
	^AbstractEvent allChangeKinds 
		collect: [:changeKind | selectorBlock value: itemKind value: changeKind]! !

!SystemChangeNotifier methodsFor: 'private-event lists' stamp: 'rw 7/29/2003 15:14'!
systemEventsForItem: itemKind change: changeKind 
	^AbstractEvent eventSelectorBlock value: itemKind value: changeKind! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemChangeNotifier class
	instanceVariableNames: ''!

!SystemChangeNotifier class methodsFor: 'instance creation' stamp: 'rw 6/28/2003 09:41'!
new

	^self error: self instanceCreationErrorString! !


!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:31'!
categoryKind

	^ AbstractEvent categoryKind! !

!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:31'!
classKind

	^ AbstractEvent classKind! !

!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:32'!
expressionKind
	^ AbstractEvent expressionKind! !

!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:31'!
methodKind

	^ AbstractEvent methodKind! !

!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:32'!
protocolKind
	^ AbstractEvent protocolKind! !


!SystemChangeNotifier class methodsFor: 'public' stamp: 'NS 1/27/2004 16:23'!
uniqueInstance

	UniqueInstance ifNil: [UniqueInstance := self createInstance].
	^UniqueInstance! !


!SystemChangeNotifier class methodsFor: 'private' stamp: 'NS 1/27/2004 16:23'!
createInstance

	^self basicNew initialize! !

!SystemChangeNotifier class methodsFor: 'private' stamp: 'rw 6/28/2003 09:41'!
instanceCreationErrorString

	^'This is a singleton implementation, so you are not allowed to create instances yourself. Use #uniqueInstance to access the instance.'! !

!SystemChangeNotifier class methodsFor: 'private' stamp: 'rw 7/11/2003 14:36'!
resetUniqueInstance
	"self resetUniqueInstance"

	UniqueInstance
		ifNotNilDo: [:u | UniqueInstance releaseAll.
			UniqueInstance _ nil]! !
SystemChangeTestRoot subclass: #SystemChangeNotifierTest
	instanceVariableNames: 'capturedEvent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SystemChangeNotification-Tests'!
!SystemChangeNotifierTest commentStamp: 'rw 4/3/2006 17:19' prior: 0!
A SystemChangeNotifierTest is a test class that tests whether the triggering of changes indeed results in the intended changes to be sent to registered object. The basic mechanism for each test is fairly simple:
	- register the receiver as the one to get the change notifier.
	- manually trigger a change (so the system is not polluted just to see whether we get the needed event).
	- the method #event: is invoked and remembers the change event.
	- the change event is checked to see whether it was the intended one.

Instance Variables
	capturedEvent:		Remembers the captured event!


!SystemChangeNotifierTest methodsFor: 'Private' stamp: 'rw 4/3/2006 16:34'!
capturedEvent: eventOrNil
	"Remember the event being sent."

	capturedEvent := eventOrNil! !

!SystemChangeNotifierTest methodsFor: 'Private' stamp: 'rw 4/3/2006 16:36'!
checkEventForClass: aClass category: cat change: changeKind 

	self assert: (capturedEvent perform: ('is' , changeKind) asSymbol).
	self assert: capturedEvent item = aClass.
	self assert: capturedEvent itemKind = AbstractEvent classKind.
	self assert: capturedEvent itemClass = aClass.
	self assert: capturedEvent itemCategory = cat! !

!SystemChangeNotifierTest methodsFor: 'Private' stamp: 'rw 4/3/2006 16:43'!
checkEventForMethod: aMethod protocol: prot change: changeKind 

	self assert: (capturedEvent perform: ('is' , changeKind) asSymbol).
	self assert: capturedEvent item = aMethod.
	self assert: capturedEvent itemKind = AbstractEvent methodKind.
	self assert: capturedEvent itemClass = self class.
	self assert: capturedEvent itemMethod = aMethod.
	self assert: capturedEvent itemProtocol = prot! !

!SystemChangeNotifierTest methodsFor: 'Private' stamp: 'rw 4/3/2006 16:43'!
checkEventForMethod: aMethod protocol: prot change: changeKind oldMethod: oldMethod

	self checkEventForMethod: aMethod protocol: prot change: changeKind.
	self assert: capturedEvent oldItem == oldMethod
	! !


!SystemChangeNotifierTest methodsFor: 'Event Notifications' stamp: 'rw 4/3/2006 17:50'!
event: event
	"The notification message being sent to me when an event is captured. Remember it."

"	capturedEvent isNil ifTrue: [	self capturedEvent: event] ifFalse: [self assert: false]"

	self capturedEvent: event! !


!SystemChangeNotifierTest methodsFor: 'Running' stamp: 'rw 4/3/2006 17:55'!
tearDown

	self capturedEvent: nil.
	super tearDown! !


!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:24'!
testClassAddedEvent

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier classAdded: self class inCategory: #FooCat.
	self
		checkEventForClass: self class
		category: #FooCat
		change: #Added! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:24'!
testClassAddedEvent2

	self systemChangeNotifier notify: self ofSystemChangesOfItem: #class change: #Added using: #event:.
	self systemChangeNotifier classAdded: self class inCategory: #FooCat.
	self
		checkEventForClass: self class
		category: #FooCat
		change: #Added! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:24'!
testClassCommentedEvent

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier classCommented: self class inCategory: #FooCat.
	self
		checkEventForClass: self class
		category: #FooCat
		change: #Commented! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:24'!
testClassRecategorizedEvent

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier 
		class: self class
		recategorizedFrom: #FooCat
		to: #FooBar.
	self
		checkEventForClass: self class
		category: #FooBar
		change: #Recategorized.
	self assert: capturedEvent oldCategory = #FooCat! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:24'!
testClassRemovedEvent

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier classRemoved: self class fromCategory: #FooCat.
	self
		checkEventForClass: self class
		category: #FooCat
		change: #Removed! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:24'!
testClassRenamedEvent

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier 
		classRenamed: self class
		from: #OldFooClass
		to: #NewFooClass
		inCategory: #FooCat.
	self
		checkEventForClass: self class
		category: #FooCat
		change: #Renamed.
"	self assert: capturedEvent oldName = #OldFooClass.
	self assert: capturedEvent newName = #NewFooClass"! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:25'!
testDoItEvent

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier 
		evaluated: '1 + 2'
		context: self.
	self assert: capturedEvent isDoIt.
	self assert: capturedEvent item = '1 + 2'.
	self assert: capturedEvent itemKind = AbstractEvent expressionKind.
	self assert: capturedEvent itemClass = nil.
	self assert: capturedEvent itemMethod = nil.
	self assert: capturedEvent itemProtocol = nil.
	self assert: capturedEvent itemExpression = '1 + 2'.
	self assert: capturedEvent context = self.! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:25'!
testMethodAddedEvent1

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier 
		methodAdded: self class >> #testMethodAddedEvent1
		selector: #testMethodAddedEvent1
		inProtocol: #FooCat
		class: self class.
	self 
		checkEventForMethod: self class >> #testMethodAddedEvent1
		protocol: #FooCat
		change: #Added! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:25'!
testMethodAddedEvent2

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier 
		methodAdded: self class >> #testMethodAddedEvent1
		selector: #testMethodAddedEvent1
		inClass: self class.
	self 
		checkEventForMethod: self class >> #testMethodAddedEvent1
		protocol: nil
		change: #Added! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:25'!
testMethodAddedEvent3

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier 
		methodChangedFrom: self class >> #testMethodAddedEvent1
		to: self class >> #testMethodAddedEvent2
		selector: #testMethodAddedEvent2
		inClass: self class.
	self 
		checkEventForMethod: self class >> #testMethodAddedEvent2
		protocol: nil
		change: #Modified
		oldMethod: self class >> #testMethodAddedEvent1.! !

!SystemChangeNotifierTest methodsFor: 'Testing-system triggers' stamp: 'rw 4/5/2006 17:25'!
testMethodRemovedEvent

	self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:.
	self systemChangeNotifier 
		methodRemoved: self class>> #testMethodRemovedEvent
		selector: #testMethodRemovedEvent
		inProtocol: #FooCat
		class: self class.
	self
		checkEventForMethod: self class>> #testMethodRemovedEvent
		protocol: #FooCat
		change: #Removed.! !
TestCase subclass: #SystemChangeTestRoot
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SystemChangeNotification-Tests'!
!SystemChangeTestRoot commentStamp: 'rw 4/5/2006 17:28' prior: 0!
The Root test class for the System Change Notification tests.!


!SystemChangeTestRoot methodsFor: 'Private' stamp: 'rw 4/3/2006 17:48'!
systemChangeNotifier
	"The notifier to use. Use the one for the system."

	^SystemChangeNotifier uniqueInstance! !


!SystemChangeTestRoot methodsFor: 'Running' stamp: 'rw 4/3/2006 17:59'!
tearDown

	self unhook.
	super tearDown! !

!SystemChangeTestRoot methodsFor: 'Running' stamp: 'rw 4/3/2006 17:23'!
unhook

	self systemChangeNotifier noMoreNotificationsFor: self! !
IdentityDictionary subclass: #SystemDictionary
	instanceVariableNames: 'cachedClassNames'
	classVariableNames: 'LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore MemoryHogs ShutDownList SpecialSelectors StartUpList StartupStamp SystemChanges'
	poolDictionaries: ''
	category: 'System-Support'!
!SystemDictionary commentStamp: '<historical>' prior: 0!
I represent a special dictionary that supports protocol for asking questions about the structure of the system. Other than class names, I contain (print this)...
	Smalltalk keys select: [:k | ((Smalltalk at: k) isKindOf: Class) not]
			thenCollect: [:k | k -> (Smalltalk at: k) class]
!


!SystemDictionary methodsFor: 'accessing' stamp: 'ar 7/11/1999 21:56'!
organization
	"Return the organizer for the receiver"
	^SystemOrganization! !


!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/12/2006 23:59'!
allClassesAndTraits
	"Return all the classes and traits defined in the Smalltalk SystemDictionary"

	^ self classNames , self traitNames collect: [:each | self at: each]! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/13/2006 00:15'!
allClassesAndTraitsDo: aBlock
	^self allClassesAndTraits do: aBlock! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/12/2006 23:57'!
classNamed: className 
	^self classOrTraitNamed: className.! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/13/2006 00:51'!
classNames
	"Answer a SortedCollection of all class names."
	| names |
	cachedClassNames == nil ifTrue:
		[names _ OrderedCollection new: self size.
		self do: 
			[:cl | (cl isInMemory
				and: [(cl isKindOf: Class)
					and: [(cl name beginsWith: 'AnObsolete') not]])
				ifTrue: [names add: cl name]].
		cachedClassNames _ names asSortedCollection].
	^ cachedClassNames! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/12/2006 23:56'!
classOrTraitNamed: aString 
	"aString is either a class or trait name or a class or trait name followed by ' class' or 'classTrait' respectively.
	Answer the class or metaclass it names."

	| meta baseName baseClass |
	(aString endsWith: ' class')
		ifTrue: [meta _ true.
				baseName _ aString copyFrom: 1 to: aString size - 6]
		ifFalse: [
			(aString endsWith: ' classTrait')
				ifTrue: [
					meta _ true.
					baseName _ aString copyFrom: 1 to: aString size - 11]
				ifFalse: [
					meta _ false.
					baseName _ aString]].
	baseClass _ Smalltalk at: baseName asSymbol ifAbsent: [^ nil].
	meta
		ifTrue: [^ baseClass classSide]
		ifFalse: [^ baseClass]! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'di 2/16/2000 10:28'!
flushClassNameCache
	"Smalltalk flushClassNameCache"
	"Forse recomputation of the cached list of class names."

	cachedClassNames _ nil! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'NS 1/27/2004 12:08'!
forgetClass: aClass logged: aBool 
	"Delete the class, aClass, from the system.
	Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem."

	aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: aClass category].		
	SystemOrganization removeElement: aClass name.
	self removeFromStartUpList: aClass.
	self removeFromShutDownList: aClass.
	self removeKey: aClass name ifAbsent: [].
	self flushClassNameCache! !

!SystemDictionary methodsFor: 'class and trait names'!
hasClassNamed: aString
	"Answer whether there is a class of the given name, but don't intern aString if it's not alrady interned.  4/29/96 sw"

	Symbol hasInterned: aString ifTrue: 
		[:aSymbol | ^ (self at: aSymbol ifAbsent: [nil]) isKindOf: Class].
	^ false! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'sw 9/5/97 18:30'!
removeClassNamed: aName
	"Invoked from fileouts:  if there is currently a class in the system named aName, then remove it.  If anything untoward happens, report it in the Transcript.  "

	| oldClass |
	(oldClass _ self at: aName asSymbol ifAbsent: [nil]) == nil
		ifTrue:
			[Transcript cr; show: 'Removal of class named ', aName, ' ignored because ', aName, ' does not exist.'.
			^ self].

	oldClass removeFromSystem! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'sw 10/28/96'!
renameClassNamed: oldName as: newName
	"Invoked from fileouts:  if there is currently a class in the system named oldName, then rename it to newName.  If anything untoward happens, report it in the Transcript.  "

	| oldClass |
	(oldClass _ self at: oldName asSymbol ifAbsent: [nil]) == nil
		ifTrue:
			[Transcript cr; show: 'Class-rename for ', oldName, ' ignored because ', oldName, ' does not exist.'.
			^ self].

	oldClass rename: newName! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'rr 3/11/2004 15:18'!
renameClass: aClass as: newName 
	"Rename the class, aClass, to have the title newName."
	| oldref i oldName category |
	oldName := aClass name.
	category := aClass category.
	SystemOrganization classify: newName under: aClass category.
	SystemOrganization removeElement: aClass name.
	oldref _ self associationAt: aClass name.
	self removeKey: aClass name.
	oldref key: newName.
	self add: oldref.  "Old association preserves old refs"
	(Array with: StartUpList with: ShutDownList) do:
		[:list |  i _ list indexOf: aClass name ifAbsent: [0].
		i > 0 ifTrue: [list at: i put: newName]].
	self flushClassNameCache.
	SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category! !

!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/12/2006 23:54'!
traitNames
	"Answer a SortedCollection of all traits (not including class-traits) names."
	| names |
	names := OrderedCollection new.
	self do: 
		[:cl | (cl isInMemory
			and: [(cl isKindOf: Trait)
			and: [(cl name beginsWith: 'AnObsolete') not]])
				ifTrue: [names add: cl name]].
	^ names! !


!SystemDictionary methodsFor: 'copying' stamp: 'tk 10/20/2000 11:35'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !


!SystemDictionary methodsFor: 'dictionary access' stamp: 'md 3/2/2006 22:01'!
associationOrUndeclaredAt: key 
	"return an association or install in undeclared.  Used for mating up ImageSegments."

	^ self associationAt: key ifAbsent: [
		Undeclared at: key put: nil.
		Undeclared associationAt: key]! !

!SystemDictionary methodsFor: 'dictionary access'!
at: aKey put: anObject 
	"Override from Dictionary to check Undeclared and fix up
	references to undeclared variables."
	| index element |
	(self includesKey: aKey) ifFalse: 
		[self declare: aKey from: Undeclared.
		self flushClassNameCache].
	super at: aKey put: anObject.
	^ anObject! !


!SystemDictionary methodsFor: 'housekeeping'!
cleanOutUndeclared 
	Undeclared removeUnreferencedKeys! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'md 1/5/2004 18:05'!
compressSources	
	"Copy all the source file to a compressed file. Usually preceded by Smalltalk condenseSources."
	"The new file will be created in the default directory, and the code in openSources
	will try to open it if it is there, otherwise it will look for normal sources."
	"Smalltalk compressSources"

	| f cfName cf |
	f _ SourceFiles first.
	(SmalltalkImage current sourcesName endsWith: 'sources')
		ifTrue: [cfName _ (SmalltalkImage current sourcesName allButLast: 7) , 'stc']
		ifFalse: [self error: 'Hey, I thought the sources name ended with ''.sources''.'].
	cf _ (CompressedSourceStream on: (FileStream newFileNamed: cfName))
				segmentSize: 20000 maxSize: f size.

	"Copy the sources"
'Compressing Sources File...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: f size
	during:
		[:bar | f position: 0.
		[f atEnd] whileFalse:
			[cf nextPutAll: (f next: 20000).
			bar value: f position]].
	cf close.
	self setMacFileInfoOn: cfName.
	self inform: 'You now have a compressed sources file!!
Squeak will use it the next time you start.'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'al 1/13/2006 00:17'!
condenseChanges
	"Move all the changes onto a compacted sources file."
	"Smalltalk condenseChanges"
	| f oldChanges count |
	f := FileStream fileNamed: 'ST80.temp'.
	f header; timeStamp.
	'Condensing Changes File...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: self classNames size + self traitNames size
		during: [:bar | 
			count := 0.
			self
				allClassesAndTraitsDo: [:classOrTrait | 
					bar value: (count := count + 1).
					classOrTrait moveChangesTo: f.
					classOrTrait putClassCommentToCondensedChangesFile: f.
					classOrTrait classSide moveChangesTo: f]].
	SmalltalkImage current lastQuitLogPosition: f position.
	f trailer; close.
	oldChanges := SourceFiles at: 2.
	oldChanges close.
	FileDirectory default deleteFileNamed: oldChanges name , '.old';
		 rename: oldChanges name toBe: oldChanges name , '.old';
		 rename: f name toBe: oldChanges name.
	self setMacFileInfoOn: oldChanges name.
	SourceFiles
		at: 2
		put: (StandardFileStream oldFileNamed: oldChanges name)! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'md 3/1/2006 00:02'!
condenseSources	
	"Move all the changes onto a compacted sources file."
	"Smalltalk condenseSources"

	| f dir newVersionString count |
	Utilities fixUpProblemsWithAllCategory.
	"The above removes any concrete, spurious '-- all --' categories, which mess up the process."
	dir := FileDirectory default.
	newVersionString := UIManager default request: 'Please designate the version
for the new source code file...' initialAnswer: SmalltalkImage current sourceFileVersionString.
	newVersionString ifNil: [^ self].
	newVersionString = SmalltalkImage current sourceFileVersionString ifTrue:
		[^ self error: 'The new source file must not be the same as the old.'].
	SmalltalkImage current sourceFileVersionString: newVersionString.

	"Write all sources with fileIndex 1"
	f := FileStream newFileNamed: SmalltalkImage current sourcesName.
	f header; timeStamp.
'Condensing Sources File...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: self classNames size + self traitNames size
	during:
		[:bar | count := 0.
		Smalltalk allClassesAndTraitsDo:
			[:classOrTrait | bar value: (count := count + 1).
			classOrTrait fileOutOn: f moveSource: true toFile: 1]].
	f trailer; close.

	"Make a new empty changes file"
	SmalltalkImage current closeSourceFiles.
	dir rename: SmalltalkImage current changesName
		toBe: SmalltalkImage current changesName , '.old'.
	(FileStream newFileNamed: SmalltalkImage current changesName)
		header; timeStamp; close.
	SmalltalkImage current lastQuitLogPosition: 0.

	self setMacFileInfoOn: SmalltalkImage current changesName.
	self setMacFileInfoOn: SmalltalkImage current sourcesName.
	SmalltalkImage current openSourceFiles.
	self inform: 'Source files have been rewritten!!
Check that all is well,
and then save/quit.'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 20:59'!
forgetDoIts	
	"Smalltalk forgetDoIts"
	 "get rid of old DoIt methods"

	self systemNavigation allBehaviorsDo:
		[:cl | cl forgetDoIts]

! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'ar 9/27/2005 21:45'!
makeExternalRelease
	"Smalltalk makeExternalRelease"
	(self confirm: SystemVersion current version , '
Is this the correct version designation?
If not, choose no, and fix it.')
		ifFalse: [^ self].
	"Object classPool at: #DependentsFields"
	self reclaimDependents.
	Preferences enable: #mvcProjectsAllowed.
	Preferences enable: #fastDragWindowForMorphic.
	Smalltalk at: #Browser ifPresent:[:br| br initialize].
	Undeclared isEmpty
		ifFalse: [self halt].
	ScriptingSystem deletePrivateGraphics.
	#(#Helvetica #Palatino #Courier )
		do: [:n | TextConstants
				removeKey: n
				ifAbsent: []].
	(Utilities classPool at: #UpdateUrlLists) copy
		do: [:pair | (pair first includesSubstring: 'Disney' caseSensitive: false)
				ifTrue: [(Utilities classPool at: #UpdateUrlLists)
						remove: pair]].
	(ServerDirectory serverNames copyWithoutAll: #('UCSBCreateArchive' 'UIUCArchive' 'UpdatesExtUIUC' 'UpdatesExtWebPage' ))
		do: [:sn | ServerDirectory removeServerNamed: sn].
	self  garbageCollect.
	self obsoleteClasses isEmpty
		ifFalse: [self halt].
	Symbol rehash.
	self halt: 'Ready to condense changes or sources'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'ar 9/27/2005 21:45'!
makeInternalRelease
	"Smalltalk makeInternalRelease"
	(self confirm: SystemVersion current version , '
Is this the correct version designation?
If not, choose no, and fix it.')
		ifFalse: [^ self].
	(Object classPool at: #DependentsFields) size > 1
		ifTrue: [self halt].
	Smalltalk at: #Browser ifPresent:[:br| br initialize].
	Undeclared isEmpty
		ifFalse: [self halt].
	self garbageCollect.
	self obsoleteClasses isEmpty
		ifFalse: [self halt].
	Symbol rehash.
	self halt: 'Ready to condense changes'.
	self condenseChanges! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 9/29/2004 18:15'!
reclaimDependents
	"No-opped due to weak dictionary in use"
	self garbageCollect! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'al 1/13/2006 00:19'!
reconstructChanges	
	"Move all the changes and its histories onto another sources file."
	"Smalltalk reconstructChanges"

	| f oldChanges classCount |
	f _ FileStream fileNamed: 'ST80.temp'.
	f header; timeStamp.
'Condensing Changes File...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: self classNames size + self traitNames size
	during:
		[:bar | classCount _ 0.
		Smalltalk allClassesAndTraitsDo:
			[:classOrTrait | bar value: (classCount _ classCount + 1).
			classOrTrait moveChangesWithVersionsTo: f.
			classOrTrait putClassCommentToCondensedChangesFile: f.
			classOrTrait classSide moveChangesWithVersionsTo: f]].
	SmalltalkImage current lastQuitLogPosition: f position.
	f trailer; close.
	oldChanges _ SourceFiles at: 2.
	oldChanges close.
	FileDirectory default 
		deleteFileNamed: oldChanges name , '.old';
		rename: oldChanges name toBe: oldChanges name , '.old';
		rename: f name toBe: oldChanges name.
	self setMacFileInfoOn: oldChanges name.
	SourceFiles at: 2
			put: (FileStream oldFileNamed: oldChanges name)! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'yo 2/24/2005 18:01'!
reformatChangesToUTF8
	"Smalltalk reformatChangesToUTF8"

	| f oldChanges classCount |
	f _ FileStream fileNamed: 'ST80.temp'.
	f converter: (UTF8TextConverter new).
	f header; timeStamp.
'Condensing Changes File...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: Smalltalk classNames size
	during:
		[:bar | classCount _ 0.
		Smalltalk allClassesDo:
			[:class | bar value: (classCount _ classCount + 1).
			class moveChangesTo: f.
			class putClassCommentToCondensedChangesFile: f.
			class class moveChangesTo: f]].
	SmalltalkImage current lastQuitLogPosition: f position.
	f trailer; close.
	oldChanges _ SourceFiles at: 2.
	oldChanges close.
	FileDirectory default 
		deleteFileNamed: oldChanges name , '.old';
		rename: oldChanges name toBe: oldChanges name , '.old';
		rename: f name toBe: oldChanges name.
	self setMacFileInfoOn: oldChanges name.
	SourceFiles at: 2
			put: (FileStream oldFileNamed: oldChanges name).
	MultiByteFileStream codeConverterClass: UTF8TextConverter.
	(SourceFiles at: 2) converter: (UTF8TextConverter new).
! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'nk 6/2/2006 10:22'!
removeAllLineFeeds
	"Smalltalk removeAllLineFeeds"
	"Scan all methods for source code with lineFeeds.
	Replaces all occurrences of <CR><LF> or <LF> by <CR>.
	When done, offers to display an Inspector containing the message
	names grouped by author initials.
	In this dictionary, the key 'OK' contains the methods that had literals that contained <LF> characters."
	| n authors totalStripped totalOK |
	'Scanning sources for LineFeeds.
This will take a few minutes...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: CompiledMethod instanceCount
		during: [:bar | 
			n _ 0.
			authors _ self
						removeAllLineFeedsQuietlyCalling: [:cls :sel | (n _ n + 1) \\ 100 = 0
								ifTrue: [bar value: n]]].
	totalStripped _ authors
				inject: 1
				into: [:sum :set | sum + set size].
	totalOK _ (authors at: 'OK') size.
	totalStripped _ totalStripped - totalOK.
	Transcript cr; show: totalStripped printString , ' methods stripped of LFs.'.
	Transcript cr; show: totalOK printString , ' methods still correctly contain LFs.'.
	(self confirm: 'Do you want to see the affected methods?')
		ifTrue: [authors inspect]! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'nk 6/2/2006 08:35'!
removeAllLineFeedsQuietly
	"Smalltalk removeAllLineFeedsQuietly"
	"Scan all methods for source code with lineFeeds.
	Replaces all occurrences of <CR><LF> or <LF> by <CR>.
	Answer a Dictionary keyed by author name containing sets of affected method names,
	as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters."
	^self removeAllLineFeedsQuietlyCalling: [ :cls :sel | ].! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'nk 6/2/2006 09:22'!
removeAllLineFeedsQuietlyCalling: aBlock
	"Smalltalk removeAllLineFeedsQuietly"
	"Scan all methods for source code with lineFeeds.
	Replaces all occurrences of <CR><LF> or <LF> by <CR>.
	Answer a Dictionary keyed by author name containing sets of affected method names,
	as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters.
	Evaluate aBlock for each method so that status can be updated."
	| oldCodeString newCodeString oldStamp oldCategory authors nameString |
	self forgetDoIts.
	authors _ Dictionary new.
	authors at: 'OK' put: Set new.
	self systemNavigation
		allBehaviorsDo: [:cls | cls selectors
				do: [:selector | 
					aBlock value: cls value: selector.
					oldCodeString _ cls sourceCodeAt: selector.
					(oldCodeString includes: Character lf)
						ifTrue: [
							newCodeString _ oldCodeString withSqueakLineEndings.
							nameString _ cls name , '>>' , selector.
							((cls compiledMethodAt: selector) hasLiteralSuchThat: [ :lit | lit asString includes: Character lf ])
								ifTrue: [(authors at: 'OK')
										add: nameString]
								ifFalse: [oldStamp _ (Utilities
												timeStampForMethod: (cls compiledMethodAt: selector))
												copy replaceAll: Character cr
												with: Character space.
									(authors
										at: (oldStamp copyFrom: 1 to: (oldStamp findFirst: [ :c | c isAlphaNumeric not ]))
										ifAbsentPut: [Set new])
										add: nameString.
									oldCategory _ cls whichCategoryIncludesSelector: selector.
									cls
										compile: newCodeString
										classified: oldCategory
										withStamp: oldStamp
										notifying: nil ]]]].
	^ authors! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 9/29/2004 18:15'!
removeEmptyMessageCategories
	"Smalltalk removeEmptyMessageCategories"
	self garbageCollect.
	(ClassOrganizer allInstances copyWith: SystemOrganization)
		do: [:org | org removeEmptyCategories]! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'nk 2/23/2005 18:00'!
testFormatter
	"Smalltalk testFormatter"

	"Reformats the source for every method in the system, and
	then compiles that source and verifies that it generates
	identical code. The formatting used will be either classic
	monochrome or fancy polychrome, depending on the setting
	of the preference #colorWhenPrettyPrinting."

	| newCodeString methodNode oldMethod newMethod badOnes n |
	badOnes := OrderedCollection new.
	self forgetDoIts.
	'Formatting all classes...' 
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: CompiledMethod instanceCount
		during: 
			[:bar | 
			n := 0.
			self systemNavigation allBehaviorsDo: 
					[:cls | 
					"Transcript cr; show: cls name."

					cls selectors do: 
							[:selector | 
							(n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
							newCodeString := cls prettyPrinterClass 
										format: (cls sourceCodeAt: selector)
										in: cls
										notifying: nil
										decorated: Preferences colorWhenPrettyPrinting.
							methodNode := cls compilerClass new 
										compile: newCodeString
										in: cls
										notifying: nil
										ifFail: [].
							newMethod := methodNode generate: #(0 0 0 0).
							oldMethod := cls compiledMethodAt: selector.
							oldMethod = newMethod 
								ifFalse: 
									[Transcript
										cr;
										show: '***' , cls name , ' ' , selector.
									badOnes add: cls name , ' ' , selector]]]].
	self systemNavigation browseMessageList: badOnes asSortedCollection
		name: 'Formatter Discrepancies'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'nk 2/23/2005 18:00'!
testFormatter2
	"Smalltalk testFormatter2"

	"Reformats the source for every method in the system, and
	then verifies that the order of source tokens is unchanged.
	The formatting used will be either classic monochrome or
	fancy polychrome, depending on the setting of the preference
	#colorWhenPrettyPrinting. "

	| newCodeString badOnes n oldCodeString oldTokens newTokens |
	badOnes := OrderedCollection new.
	self forgetDoIts.
	'Formatting all classes...' 
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: CompiledMethod instanceCount
		during: 
			[:bar | 
			n := 0.
			self systemNavigation allBehaviorsDo: 
					[:cls | 
					"Transcript cr; show: cls name."

					cls selectors do: 
							[:selector | 
							(n := n + 1) \\ 100 = 0 ifTrue: [bar value: n].
							oldCodeString := (cls sourceCodeAt: selector) asString.
							newCodeString := cls prettyPrinterClass 
										format: oldCodeString
										in: cls
										notifying: nil
										decorated: Preferences colorWhenPrettyPrinting.
							oldTokens := oldCodeString findTokens: Character separators.
							newTokens := newCodeString findTokens: Character separators.
							oldTokens = newTokens 
								ifFalse: 
									[Transcript
										cr;
										show: '***' , cls name , ' ' , selector.
									badOnes add: cls name , ' ' , selector]]]].
	self systemNavigation browseMessageList: badOnes asSortedCollection
		name: 'Formatter Discrepancies'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:01'!
verifyChanges		"Smalltalk verifyChanges"
	"Recompile all methods in the changes file."
	self systemNavigation allBehaviorsDo: [:class | class recompileChanges].
! !


!SystemDictionary methodsFor: 'image, changes name' stamp: 'yo 3/29/2004 09:36'!
primImageName
	"Answer the full path name for the current image."
	"Smalltalk imageName"

	<primitive: 121>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'image, changes name' stamp: 'yo 3/29/2004 09:36'!
primImageName: newName
	"Set the the full path name for the current image.  All further snapshots will use this."

	<primitive: 121>
	^ self primitiveFailed! !

!SystemDictionary methodsFor: 'image, changes name' stamp: 'yo 3/29/2004 09:36'!
primVmPath
	"Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented."
	"Smalltalk vmPath"

	<primitive: 142>
	^ ''! !


!SystemDictionary methodsFor: 'memory space'!
bytesLeft
	"Answer the number of bytes of space available. Does a full garbage collection."

	^ self garbageCollect
! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 2/25/2001 18:00'!
bytesLeftString
	"Return a string describing the amount of memory available"
	| availInternal availPhysical availTotal |
	self garbageCollect.
	availInternal _ self primBytesLeft.
	availPhysical _ self bytesLeft: false.
	availTotal _ self bytesLeft: true.
	(availTotal > (availInternal + 10000)) "compensate for mini allocations inbetween"
		ifFalse:[^availInternal asStringWithCommas, ' bytes available'].
	^String streamContents:[:s|
		s nextPutAll: availInternal asStringWithCommas, 	' bytes (internal) '; cr.
		s nextPutAll: availPhysical asStringWithCommas,	' bytes (physical) '; cr.
		s nextPutAll: availTotal asStringWithCommas, 	' bytes (total)     '].! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 2/25/2001 17:55'!
bytesLeft: aBool
	"Return the amount of available space. If aBool is true, include possibly available swap space. If aBool is false, include possibly available physical memory. For a report on the largest free block currently availabe within Squeak memory but not counting extra memory use #primBytesLeft."
	<primitive: 112>
	^self primBytesLeft! !

!SystemDictionary methodsFor: 'memory space'!
createStackOverflow
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; createStackOverflow"

	self createStackOverflow.  "infinite recursion"! !

!SystemDictionary methodsFor: 'memory space' stamp: 'JMM 1/27/2005 13:23'!
forceTenure
	"Primitive. Tell the GC logic to force a tenure on the next increment GC."
	<primitive: 'primitiveForceTenure'>
	^self primitiveFailed! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 2/11/2001 02:36'!
garbageCollect
	"Primitive. Reclaims all garbage and answers the number of bytes of available space."
	Object flushDependents.
	Object flushEvents.
	^self primitiveGarbageCollect! !

!SystemDictionary methodsFor: 'memory space'!
garbageCollectMost
	"Primitive. Reclaims recently created garbage (which is usually most of it) fairly quickly and answers the number of bytes of available space."

	<primitive: 131>
	^ self primBytesLeft! !

!SystemDictionary methodsFor: 'memory space'!
installLowSpaceWatcher
	"Start a process to watch for low-space conditions."
	"Smalltalk installLowSpaceWatcher"

	self primSignalAtBytesLeft: 0.  "disable low-space interrupts"
	LowSpaceProcess == nil ifFalse: [LowSpaceProcess terminate].
	LowSpaceProcess _ [self lowSpaceWatcher] newProcess.
	LowSpaceProcess priority: Processor lowIOPriority.
	LowSpaceProcess resume.

! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:46'!
isRoot: oop
	"Primitive. Answer whether the object is currently a root for youngSpace."
	<primitive: 'primitiveIsRoot'>
	^self primitiveFailed! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:47'!
isYoung: oop
	"Primitive. Answer whether the object currently resides in youngSpace."
	<primitive: 'primitiveIsYoung'>
	^self primitiveFailed! !

!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'!
lowSpaceThreshold 
	"Return the low space threshold. When the amount of free memory (after garbage collection) falls below this limit, the system is in serious danger of completely exhausting memory and crashing. This limit should be made high enough to allow the user open a debugger to diagnose a problem or to save the image."

	thisContext isPseudoContext
		ifTrue: [^ 400000  "Enough for JIT compiler"]
		ifFalse: [^ 200000  "Enough for interpreter"]! !

!SystemDictionary methodsFor: 'memory space' stamp: 'dtl 10/3/2005 06:12'!
lowSpaceWatcher
	"Wait until the low space semaphore is signalled, then take appropriate actions."

	| free preemptedProcess |
	self garbageCollectMost <= self lowSpaceThreshold
		ifTrue: [self garbageCollect <= self lowSpaceThreshold
				ifTrue: ["free space must be above threshold before
					starting low space watcher"
					^ Beeper beep]].

	Smalltalk specialObjectsArray at: 23 put: nil.  "process causing low space will be saved here"
	LowSpaceSemaphore _ Semaphore new.
	self primLowSpaceSemaphore: LowSpaceSemaphore.
	self primSignalAtBytesLeft: self lowSpaceThreshold.  "enable low space interrupts"

	LowSpaceSemaphore wait.  "wait for a low space condition..."

	self primSignalAtBytesLeft: 0.  "disable low space interrupts"
	self primLowSpaceSemaphore: nil.
	LowSpaceProcess _ nil.

	"The process that was active at the time of the low space interrupt."
	preemptedProcess _ Smalltalk specialObjectsArray at: 23.
	Smalltalk specialObjectsArray at: 23 put: nil.

	"Note: user now unprotected until the low space watcher is re-installed"

	self memoryHogs isEmpty
		ifFalse: [free := self bytesLeft.
			self memoryHogs
				do: [ :hog | hog freeSomeSpace ].
			self bytesLeft > free
				ifTrue: [ ^ self installLowSpaceWatcher ]].
	self isMorphic
		ifTrue: [CurrentProjectRefactoring
				currentInterruptName: 'Space is low'
				preemptedProcess: preemptedProcess]
		ifFalse: [ScheduledControllers
				interruptName: 'Space is low'
				preemptedProcess: preemptedProcess]
! !

!SystemDictionary methodsFor: 'memory space' stamp: 'nk 10/28/2000 20:37'!
lowSpaceWatcherProcess
	^LowSpaceProcess! !

!SystemDictionary methodsFor: 'memory space' stamp: 'sma 4/22/2000 19:03'!
memoryHogs
	"Answer the list of objects to notify with #freeSomeSpace if memory gets full."

	^ MemoryHogs ifNil: [MemoryHogs _ OrderedCollection new]! !

!SystemDictionary methodsFor: 'memory space'!
okayToProceedEvenIfSpaceIsLow
	"Return true if either there is enough memory to do so safely or if the user gives permission after being given fair warning."

	self garbageCollectMost > self lowSpaceThreshold ifTrue: [^ true].  "quick"
	self garbageCollect > self lowSpaceThreshold ifTrue: [^ true].  "work harder"

	^ self confirm:
'WARNING: There is not enough space to start the low space watcher.
If you proceed, you will not be warned again, and the system may
run out of memory and crash. If you do proceed, you can start the
low space notifier when more space becomes available simply by
opening and then closing a debugger (e.g., by hitting Cmd-period.)
Do you want to proceed?'
! !

!SystemDictionary methodsFor: 'memory space'!
primBytesLeft
	"Primitive. Answer the number of bytes available for new object data.
	Not accurate unless preceded by
		Smalltalk garbageCollectMost (for reasonable accuracy), or
		Smalltalk garbageCollect (for real accuracy).
	See Object documentation whatIsAPrimitive."

	<primitive: 112>
	^ 0! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 2/11/2001 02:16'!
primitiveGarbageCollect
	"Primitive. Reclaims all garbage and answers the number of bytes of available space."

	<primitive: 130>
	^ self primBytesLeft! !

!SystemDictionary methodsFor: 'memory space'!
primLowSpaceSemaphore: aSemaphore
	"Primitive. Register the given Semaphore to be signalled when the
	number of free bytes drops below some threshold. Disable low-space
	interrupts if the argument is nil."

	<primitive: 124>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'memory space'!
primSignalAtBytesLeft: numBytes
	"Tell the interpreter the low-space threshold in bytes. When the free
	space falls below this threshold, the interpreter will signal the low-space
	semaphore, if one has been registered.  Disable low-space interrupts if the
	argument is zero.  Fail if numBytes is not an Integer."

	<primitive: 125>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:48'!
rootTable
	"Primitive. Answer a snapshot of the VMs root table. 
	Keep in mind that the primitive may itself cause GC."
	<primitive: 'primitiveRootTable'>
	^self primitiveFailed! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:49'!
rootTableAt: index
	"Primitive. Answer the nth element of the VMs root table"
	<primitive: 'primitiveRootTableAt'>
	^nil! !

!SystemDictionary methodsFor: 'memory space' stamp: 'JMM 1/27/2005 12:27'!
setGCBiasToGrowGCLimit: aNumber
	"Primitive. Indicate that the bias to grow logic should do a GC after aNumber Bytes"
	<primitive: 'primitiveSetGCBiasToGrowGCLimit'>
	^self primitiveFailed
"Example:
	Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024.
"! !

!SystemDictionary methodsFor: 'memory space' stamp: 'JMM 1/27/2005 13:12'!
setGCBiasToGrow: aNumber
	"Primitive. Indicate that the GC logic should be bias to grow"
	<primitive: 'primitiveSetGCBiasToGrow'>
	^self primitiveFailed
"Example:
	Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024.
	Smalltalk setGCBiasToGrow: 1.
"! !

!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:54'!
setGCSemaphore: semaIndex
	"Primitive. Indicate the GC semaphore index to be signaled on GC occurance."
	<primitive: 'primitiveSetGCSemaphore'>
	^self primitiveFailed
"Example:

	| index sema process |
	sema := Semaphore new.
	index := Smalltalk registerExternalObject: sema.
	Smalltalk setGCSemaphore: index.
	process := [
		[[true] whileTrue:[
			sema wait.
			Smalltalk beep.
		]] ensure:[
			Smalltalk setGCSemaphore: 0.
			Smalltalk unregisterExternalObject: sema.
		].
	] fork.
	process inspect.
"! !

!SystemDictionary methodsFor: 'memory space'!
signalLowSpace
	"Signal the low-space semaphore to alert the user that space is running low."

	LowSpaceSemaphore signal.! !

!SystemDictionary methodsFor: 'memory space' stamp: 'apb 10/3/2000 16:40'!
useUpMemory
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; useUpMemory"

	| lst |
	lst _ nil.
	[true] whileTrue: [
		lst _ Link nextLink: lst.
	].! !

!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 21:15'!
useUpMemoryWithArrays 
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; useUpMemoryWithArrays"

	| b |  "First use up most of memory."
	b _ String new: self bytesLeft - self lowSpaceThreshold - 100000.
	b _ b.  "Avoid unused value warning"
	(1 to: 10000) collect: [:i | Array new: 10000]! !

!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'!
useUpMemoryWithContexts 
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; useUpMemoryWithContexts"

	self useUpMemoryWithContexts! !

!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:50'!
useUpMemoryWithTinyObjects 
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; useUpMemoryWithTinyObjects"

	| b |  "First use up most of memory."
	b _ String new: self bytesLeft - self lowSpaceThreshold - 100000.
	b _ b.  "Avoid unused value warning"
	(1 to: 10000) collect: [:i | BitBlt new]! !


!SystemDictionary methodsFor: 'miscellaneous'!
exitToDebugger
	"Primitive. Enter the machine language debugger, if one exists. Essential.
	See Object documentation whatIsAPrimitive."

	<primitive: 114>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'dao 10/1/2004 13:33'!
handleUserInterrupt
	Preferences cmdDotEnabled ifTrue:
		[Smalltalk isMorphic
			ifTrue: [[Project interruptName: 'User Interrupt'] fork]
			ifFalse: [[ScheduledControllers interruptName: 'User Interrupt'] fork]]! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'sd 9/29/2004 18:17'!
hasMorphic
	"Answer whether the Morphic classes are available in the
	system (they may have been stripped, such as by a call to
	Smalltalk removeMorphic"
	^ (self
		at: #Morph
		ifAbsent: [])
		isKindOf: Class! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'tk 10/16/2001 19:24'!
logError: errMsg inContext: aContext to: aFilename
	"Log the error message and a stack trace to the given file."

	| ff |
	FileDirectory default deleteFileNamed: aFilename ifAbsent: [].
	(ff _ FileStream fileNamed: aFilename) ifNil: [^ self "avoid recursive errors"].

  	ff nextPutAll: errMsg; cr.
	aContext errorReportOn: ff.
	ff close.! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'yo 7/2/2004 13:32'!
m17nVersion

	^ 'M17n 5.0' copy
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'yo 7/2/2004 13:32'!
nihongoVersion

	^ 'Nihongo7.0' copy
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'MPH 10/24/2000 14:27'!
setMacFileInfoOn: aString
	"On Mac, set the file type and creator (noop on other platforms)"
	FileDirectory default
		setMacFileNamed: aString
		type: 'STch'
		creator: 'FAST'.! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'nb 6/17/2003 12:25'!
verifyMorphicAvailability
	"If Morphic is available, return true; if not, put up an informer and return false"
	self hasMorphic ifFalse:
		[Beeper beep.
		self inform: 'Sorry, Morphic must
be present to use this feature'.
		^ false].
	^ true! !


!SystemDictionary methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:50'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to Smalltalk instead."

	dp _ DiskProxy global: #Smalltalk selector: #yourself
			args: #().
	refStrm replace: self with: dp.
	^ dp! !

!SystemDictionary methodsFor: 'objects from disk' stamp: 'tk 3/7/2000 18:40'!
storeDataOn: aDataStream
	"I don't get stored.  Use a DiskProxy"

	self error: 'use a DiskProxy to store me'! !


!SystemDictionary methodsFor: 'printing' stamp: 'sma 6/1/2000 09:53'!
printElementsOn: aStream
	aStream nextPutAll:'(lots of globals)'! !


!SystemDictionary methodsFor: 'retrieving' stamp: 'sd 4/17/2003 21:15'!
allClasses  
	"Return all the class defines in the Smalltalk SystemDictionary"
	"Smalltalk allClasses"

	^ self classNames collect: [:name | self at: name]! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'sd 4/17/2003 21:18'!
allClassesDo: aBlock
	"Evaluate the argument, aBlock, for each class in the system."

	(self classNames collect: [:name | self at: name]) do: aBlock! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'al 2/23/2006 21:39'!
allTraits
	"Return all traits defined in the Smalltalk SystemDictionary"

	^ self traitNames collect: [:each | self at: each]! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'sd 9/29/2004 18:17'!
poolUsers
	"Answer a dictionary of pool name -> classes that refer to it.
	Also includes any globally know dictionaries (such as
	Smalltalk, Undeclared etc) which although not strictly
	accurate is potentially useful information"
	"Smalltalk poolUsers"
	| poolUsers pool refs |
	poolUsers := Dictionary new.
	self keys
		do: [:k | "yes, using isKindOf: is tacky but for reflective code like
			this it is very useful. If you really object you can:-
			a) go boil your head.
			b) provide a better answer.
			your choice."
			(((pool := self at: k) isKindOf: Dictionary)
					or: [pool isKindOf: SharedPool class])
				ifTrue: [refs := self systemNavigation allClasses
								select: [:c | c sharedPools identityIncludes: pool]
								thenCollect: [:c | c name].
					refs
						add: (self systemNavigation
								allCallsOn: (self associationAt: k)).
					poolUsers at: k put: refs]].
	^ poolUsers! !


!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:18'!
abandonSources
	"Smalltalk abandonSources"
	"Replaces every method by a copy with the 4-byte source
	pointer 
	replaced by a string of all arg and temp names, followed by its
	length. These names can then be used to inform the
	decompiler. See stats below"
	"wod 11/3/1998: zap the organization before rather than after
	condensing changes."
	| oldCodeString argsAndTemps oldMethods newMethods m bTotal bCount |
	(self confirm: 'This method will preserve most temp names
(up to about 400 characters) while allowing
the sources file to be discarded.
-- CAUTION --
If you have backed up your system and
are prepared to face the consequences of
abandoning source code files, choose Yes.
If you have any doubts, you may choose No
to back out with no harm done.')
			== true
		ifFalse: [^ self inform: 'Okay - no harm done'].
	self forgetDoIts.
	oldMethods := OrderedCollection new: CompiledMethod instanceCount.
	newMethods := OrderedCollection new: CompiledMethod instanceCount.
	bTotal := 0.
	bCount := 0.
	self systemNavigation
		allBehaviorsDo: [:b | bTotal := bTotal + 1].
	'Saving temp names for better decompilation...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: bTotal
		during: [:bar | self systemNavigation
				allBehaviorsDo: [:cl | 
					"for test: (Array with: Arc with: Arc class) do:"
					bar value: (bCount := bCount + 1).
					cl selectors
						do: [:selector | 
							m := cl compiledMethodAt: selector.
							m fileIndex > 0
								ifTrue: [oldCodeString := cl sourceCodeAt: selector.
									argsAndTemps := (cl compilerClass new
												parse: oldCodeString
												in: cl
												notifying: nil) tempNames.
									oldMethods addLast: m.
									newMethods
										addLast: (m copyWithTempNames: argsAndTemps)]]]].
	oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
	self systemNavigation
		allBehaviorsDo: [:b | b zapOrganization].
	self condenseChanges.
	Preferences disable: #warnIfNoSourcesFile! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:18'!
abandonTempNames
	"Replaces every method by a copy with no source pointer or
	encoded temp names."
	"Smalltalk abandonTempNames"
	| continue oldMethods newMethods n m |
	continue := self confirm: '-- CAUTION --
If you have backed up your system and
are prepared to face the consequences of
abandoning all source code, hit Yes.
If you have any doubts, hit No,
to back out with no harm done.'.
	continue
		ifFalse: [^ self inform: 'Okay - no harm done'].
	self forgetDoIts; garbageCollect.
	oldMethods := OrderedCollection new.
	newMethods := OrderedCollection new.
	n := 0.
	'Removing temp names to save space...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: CompiledMethod instanceCount
		during: [:bar | self systemNavigation
				allBehaviorsDo: [:cl | cl selectors
						do: [:sel | 
							bar value: (n := n + 1).
							m := cl compiledMethodAt: sel.
							oldMethods addLast: m.
							newMethods
								addLast: (m copyWithTrailerBytes: #(0 ))]]].
	oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
	SmalltalkImage current closeSourceFiles.
	self flag: #shouldUseAEnsureBlockToBeSureThatTheFileIsClosed.
	"sd: 17 April 2003"
	Preferences disable: #warnIfNoChangesFile.
	Preferences disable: #warnIfNoSourcesFile! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'di 3/3/2001 08:31'!
cleanUpUndoCommands
	"Smalltalk cleanUpUndoCommands"  "<== print this to get classes involved"

	| classes i p |
	classes _ Bag new.
	'Ferreting out obsolete undo commands'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: Morph withAllSubclasses size
		during:
	[:bar | i _ 0.
	Morph withAllSubclassesDo:
		[:c | bar value: (i _ i+1).
		c allInstancesDo:
			[:m | (p _ m otherProperties) ifNotNil:
				[p keys do:
					[:k | (p at: k) class == Command ifTrue:
						[classes add: c name.
						m removeProperty: k]]]]]].
	^ classes! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:40'!
computeImageSegmentation
	"Smalltalk computeImageSegmentation"
	"Here's how the segmentation works:
	For each partition, we collect the classes involved, and also all
	messages no longer used in the absence of this partition. We
	start by computing a 'Miscellaneous' segment of all the
	unused classes in the system as is."
	| partitions unusedCandM newClasses expandedCandM |
	partitions := Dictionary new.
	unusedCandM := self unusedClassesAndMethodsWithout: {{}. {}}.
	partitions at: 'Miscellaneous' put: unusedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'VMConstruction-*')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'VMConstruction' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'ST80-*')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'ST80' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'Morphic-Games')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Games' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'Morphic-Remote')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Nebraska' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | ((SystemOrganization categoriesMatching: 'Network-*')
						copyWithoutAll: #('Network-Kernel' 'Network-Url' 'Network-Protocols' 'Network-ObjectSocket' ))
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := Smalltalk unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Network' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon3D-*')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Balloon3D' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'FFI-*')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'FFI' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'Genie-*')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Genie' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'Speech-*')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Speech' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | #('Morphic-Components' )
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	newClasses := newClasses copyWithoutAll: #(#ComponentLikeModel ).
	expandedCandM := Smalltalk unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Components' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | #('Sound-Scores' 'Sound-Interface' )
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	newClasses := newClasses , #(#WaveletCodec #Sonogram #FWT #AIFFFileReader ).
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Sound' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | ((SystemOrganization categoriesMatching: 'Tools-*')
						copyWithout: 'Tools-Menus')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	newClasses := newClasses copyWithoutAll: #(#Debugger #Inspector #ContextVariablesInspector #SyntaxError #ChangeSet #ChangeRecord #ClassChangeRecord #ChangeList #VersionsBrowser ).
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Tools' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon-MMFlash*')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	newClasses := newClasses , #(#ADPCMCodec ).
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'Flash' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon-TrueType*')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'TrueType' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	newClasses := Array
				streamContents: [:s | (SystemOrganization categoriesMatching: 'Graphics-Files')
						do: [:cat | (SystemOrganization superclassOrder: cat)
								do: [:c | s nextPut: c name]]].
	expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}.
	partitions at: 'GraphicFiles' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses;
			 yourself. expandedCandM second copyWithoutAll: unusedCandM second}.
	unusedCandM := expandedCandM.
	#(#AliceConstants 'Balloon3D' #B3DEngineConstants 'Balloon3D' #WonderlandConstants 'Balloon3D' #FFIConstants 'FFI' #KlattResonatorIndices 'Speech' )
		pairsDo: [:poolName :part | (partitions at: part) first add: poolName].
	partitions
		keysDo: [:k | k = 'Miscellaneous'
				ifFalse: [(partitions at: 'Miscellaneous') first removeAllFoundIn: (partitions at: k) first]].
	^ partitions! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sma 6/18/2000 12:32'!
discardDiscards
	"Discard all discard* methods - including this one."

	(self class selectors select: [:each | each beginsWith: 'discard']) 
		do: [:each | self class removeSelector: each].
	#(lastRemoval majorShrink zapMVCprojects)
		do: [:each | self class removeSelector: each]! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:20'!
discardFFI
	"Discard the complete foreign function interface.
	NOTE: Recreates specialObjectsArray to prevent obsolete
	references. Has to specially remove external structure
	hierarchy before ExternalType"
	self
		at: #ExternalStructure
		ifPresent: [:cls | (ChangeSet superclassOrder: cls withAllSubclasses asArray)
				reverseDo: [:c | c removeFromSystem]].
	SystemOrganization removeCategoriesMatching: 'FFI-*'.
	self recreateSpecialObjectsArray.
	"Remove obsolete refs"
	ByteArray removeSelector: #asExternalPointer.
	ByteArray removeSelector: #pointerAt:! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 01:32'!
discardFlash
	"Discard Flash support."

	SystemOrganization removeCategoriesMatching: 'Balloon-MMFlash*'
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'RAA 12/17/2000 16:50'!
discardMIDI

	"this seems to have gone away"! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:21'!
discardMorphic
	"Discard Morphic.
	Updated for 2.8 TPR"
	"Smalltalk discardMorphic"
	"Check that we are in an MVC Project and that there are no
	Morphic Projects
	or WorldMorphViews."
	| subs |
	Flaps clobberFlapTabList.
	self discardFlash.
	self discardTrueType.
	subs := OrderedCollection new.
	Morph
		allSubclassesWithLevelDo: [:c :i | subs addFirst: c]
		startingLevel: 0.
	subs
		do: [:c | c removeFromSystem].
	self removeClassNamed: #CornerRounder.
	self
		removeKey: #BalloonEngineConstants
		ifAbsent: [].
	SystemOrganization removeCategoriesMatching: 'Balloon-*'.
	SystemOrganization removeCategoriesMatching: 'Morphic-*'.
	SystemOrganization removeSystemCategory: 'Graphics-Transformations'.
	SystemOrganization removeSystemCategory: 'ST80-Morphic'.
	ScriptingSystem := nil! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:21'!
discardMVC
	"After suitable checks, strip out much of MVC from the system"
	"Smalltalk discardMVC"
	| keepers |
	self flag: #bob.
	"zapping projects"
	self isMorphic
		ifFalse: [self inform: 'You must be in a Morphic project to discard MVC.'.
			^ self].
	"Check that there are no MVC Projects"
	(Project allProjects
			allSatisfy: [:proj | proj isMorphic])
		ifFalse: [(self confirm: 'Would you like a chance to remove your
MVC projects in an orderly manner?')
				ifTrue: [^ self].
			(self confirm: 'If you wish, I can remove all MVC projects,
make this project be the top project, and place
all orphaned sub-projects of MVC parents here.
Would you like be to do this
and proceed to discard all MVC classes?')
				ifTrue: [self zapMVCprojects]
				ifFalse: [^ self]].
	self reclaimDependents.
	"Remove old Paragraph classes and View classes."
	self
		at: #Paragraph
		ifPresent: [:paraClass | (ChangeSet superclassOrder: paraClass withAllSubclasses asArray)
				reverseDo: [:c | c removeFromSystem]].
	self
		at: #View
		ifPresent: [:viewClass | (ChangeSet superclassOrder: viewClass withAllSubclasses asArray)
				reverseDo: [:c | c removeFromSystem]].
	"Get rid of ParagraphEditor's ScrollController dependence"
	#(#markerDelta #viewDelta #scrollAmount #scrollBar #computeMarkerRegion )
		do: [:sel | ParagraphEditor removeSelector: sel].
	ParagraphEditor compile: 'updateMarker'.
	"Reshape to MouseMenuController"
	Compiler
		evaluate: (ParagraphEditor definition copyReplaceAll: 'ScrollController' with: 'MouseMenuController').
	"Get rid of all Controller classes not needed by
	ParagraphEditor and ScreenController"
	keepers := TextMorphEditor withAllSuperclasses copyWith: ScreenController.
	(ChangeSet superclassOrder: Controller withAllSubclasses asArray)
		reverseDo: [:c | (keepers includes: c)
				ifFalse: [c removeFromSystem]].
	SystemOrganization removeCategoriesMatching: 'ST80-Paths'.
	SystemOrganization removeCategoriesMatching: 'ST80-Symbols'.
	SystemOrganization removeCategoriesMatching: 'ST80-Pluggable Views'.
	self removeClassNamed: 'FormButtonCache'.
	self removeClassNamed: 'WindowingTransformation'.
	self removeClassNamed: 'ControlManager'.
	self removeClassNamed: 'DisplayTextView'.
	ScheduledControllers := nil.
	Undeclared removeUnreferencedKeys.
	SystemOrganization removeEmptyCategories.
	Symbol rehash! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'cwp 11/8/2002 13:38'!
discardNetworking
	"Discard the support for TCP/IP networking."

	SystemOrganization removeCategoriesMatching: 'Network-*'.

! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'md 7/29/2005 16:00'!
discardOddsAndEnds
	"This method throws out lots of classes that are not frequently
	used."
	"Smalltalk discardOddsAndEnds"
	self organization removeSystemCategory: 'System-Serial Port'.
	self organization removeSystemCategory: 'ST80-Symbols'.
	self organization removeSystemCategory: 'Tools-File Contents Browser'.
	self organization removeSystemCategory: 'System-Compression'.
	self organization removeSystemCategory: 'Tools-Explorer'.
	self organization removeSystemCategory: 'System-Digital Signatures'.
	Form removeSelector: #edit.
	self
		at: #FormView
		ifPresent: [:c | c compile: 'defaultControllerClass  ^ NoController' classified: 'controller access'].
	self removeClassNamed: #FormEditorView.
	self removeClassNamed: #FormEditor.
	self organization removeSystemCategory: 'ST80-Paths'.
	"bit editor (remove Form editor first):"
	Form removeSelector: #bitEdit.
	Form removeSelector: #bitEditAt:scale:.
	StrikeFont removeSelector: #edit:.
	self removeClassNamed: #FormButtonCache.
	self removeClassNamed: #FormMenuController.
	self removeClassNamed: #FormMenuView.
	self removeClassNamed: #BitEditor.
	"inspector for Dictionaries of Forms"
	Dictionary removeSelector: #inspectFormsWithLabel:.
	SystemDictionary removeSelector: #viewImageImports.
	ScreenController removeSelector: #viewImageImports.
	self removeClassNamed: #FormHolderView.
	self removeClassNamed: #FormInspectView.
	"experimental updating object viewer:"
	Object removeSelector: #evaluate:wheneverChangeIn:.
	self removeClassNamed: #ObjectViewer.
	self removeClassNamed: #ObjectTracer.
	"miscellaneous classes:"
	self removeClassNamed: #Array2D.
	self removeClassNamed: #DriveACar.
	self removeClassNamed: #EventRecorder.
	self removeClassNamed: #FindTheLight.
	self removeClassNamed: #PluggableTest.
	self removeClassNamed: #SystemMonitor.
	self removeClassNamed: #ProtocolBrowser.
	self removeClassNamed: #ObjectExplorerWrapper.
	self removeClassNamed: #HierarchyBrowser.
	self removeClassNamed: #LinkedMessageSet.
	self removeClassNamed: #ObjectExplorer.
	self removeClassNamed: #PackageBrowser.
	self removeClassNamed: #AbstractHierarchicalList.
	self removeClassNamed: #ChangeList.
	self removeClassNamed: #VersionsBrowser.
	self removeClassNamed: #ChangeRecord.
	self removeClassNamed: #SelectorBrowser.
	self removeClassNamed: #HtmlFileStream.
	self removeClassNamed: #CrLfFileStream.
	self removeClassNamed: #FXGrafPort.
	self removeClassNamed: #FXBlt.
	self
		at: #SampledSound
		ifPresent: [:c | c initialize].
	#(#Helvetica #Palatino #Courier #ComicBold #ComicPlain )
		do: [:k | TextConstants
				removeKey: k
				ifAbsent: []].
	Preferences
		setButtonFontTo: (StrikeFont familyName: #NewYork size: 12).
	Preferences
		setFlapsFontTo: (StrikeFont familyName: #NewYork size: 12).
	#(#GZipConstants #ZipConstants #KlattResonatorIndices )
		do: [:k | self
				removeKey: k
				ifAbsent: []]! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:23'!
discardSoundSynthesis
	"Discard the sound synthesis facilities, and the methods and
	classes that use it. This also discards MIDI."
	self discardMIDI.
	self discardSpeech.
	SystemOrganization removeCategoriesMatching: 'Sound-Interface'.
	self
		at: #GraphMorph
		ifPresent: [:graphMorph | #(#playOnce #readDataFromFile )
				do: [:sel | graphMorph removeSelector: sel]].
	self
		at: #TrashCanMorph
		ifPresent: [:trashMorph | 
			trashMorph class removeSelector: #samplesForDelete.
			trashMorph class removeSelector: #samplesForMouseEnter.
			trashMorph class removeSelector: #samplesForMouseLeave].
	SystemOrganization removeCategoriesMatching: 'Sound-Synthesis'.
	SystemOrganization removeCategoriesMatching: 'Sound-Scores'! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 19:21'!
discardSpeech
	"Discard support for speech synthesis"

	SystemOrganization removeCategoriesMatching: 'Speech*'.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:23'!
discardSUnit
	"Smalltalk discardSUnit"
	| oc |
	oc := OrderedCollection new.
	(self
		at: #TestCase
		ifAbsent: [^ self])
		allSubclassesWithLevelDo: [:c :i | oc addFirst: c]
		startingLevel: 0.
	oc
		do: [:c | c removeFromSystem].
	SystemOrganization removeCategoriesMatching: 'SUnit-*'! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 01:32'!
discardTrueType
	"Discard TrueType support."

	SystemOrganization removeCategoriesMatching: 'Balloon-TrueType*'.

! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:24'!
lastRemoval
	"Smalltalk lastRemoval"
	"Some explicit removals - add unwanted methods keeping
	other methods."
	| oldDicts newDicts |
	#(#abandonSources )
		do: [:each | self class removeSelector: each].
	"Get rid of all unsent methods."
	[self removeAllUnSentMessages > 0] whileTrue.
	"Shrink method dictionaries."
	self garbageCollect.
	oldDicts := MethodDictionary allInstances.
	newDicts := Array new: oldDicts size.
	oldDicts
		withIndexDo: [:d :index | newDicts at: index put: d rehashWithoutBecome].
	oldDicts elementsExchangeIdentityWith: newDicts.
	oldDicts := newDicts := nil.
	self
		allClassesDo: [:c | c zapOrganization].
	SystemOrganization := nil.
	ChangeSet current initialize! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'md 2/24/2006 15:42'!
majorShrink
	"Undertake a major shrinkage of the image.
	This method throws out lots of the system that is not needed
	for, eg, operation in a hand-held PC. majorShrink produces a
	999k image in Squeak 2.8
	Smalltalk majorShrink; abandonSources; lastRemoval"
	| oldDicts newDicts |
	self isMorphic
		ifTrue: [^ self error: 'You can only run majorShrink in MVC'].
	Project current isTopProject
		ifFalse: [^ self error: 'You can only run majorShrink in the top project'].
	(self confirm: 'All sub-projects will be deleted from this image.
You should already have made a backup copy,
or you must save with a different name after shrinking.
Shall we proceed to discard most of the content in this image?')
		ifFalse: [^ self inform: 'No changes have been made.'].
	"Remove all projects but the current one. - saves 522k"
	ProjectView
		allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate].
	Project current setParent: Project current.
	MorphWorldView
		allInstancesDo: [:pv | pv topView controller closeAndUnscheduleNoTerminate].
	self
		at: #Wonderland
		ifPresent: [:cls | cls removeActorPrototypesFromSystem].
	Player freeUnreferencedSubclasses.
	MorphicModel removeUninstantiatedModels.
	Utilities classPool at: #ScrapsBook put: nil.
	Utilities zapUpdateDownloader.
	ProjectHistory currentHistory initialize.
	Project rebuildAllProjects.
	"Smalltalk discardVMConstruction."
	"755k"
	self discardSoundSynthesis.
	"544k"
	self discardOddsAndEnds.
	"227k"
	self discardNetworking.
	"234k"
	"Smalltalk discard3D."
	"407k"
	self discardFFI.
	"33k"
	self discardMorphic.
	"1372k"
	Symbol rehash.
	"40k"
	"Above by itself saves about 4,238k"
	"Remove references to a few classes to be deleted, so that they
	won't leave obsolete versions around."
	ChangeSet class compile: 'defaultName
		^ ''Changes'' ' classified: 'initialization'.
	ScreenController removeSelector: #openChangeManager.
	ScreenController removeSelector: #exitProject.
	ScreenController removeSelector: #openProject.
	ScreenController removeSelector: #viewImageImports.
	"Now delete various other classes.."
	SystemOrganization removeSystemCategory: 'Graphics-Files'.
	SystemOrganization removeSystemCategory: 'System-Object Storage'.
	self removeClassNamed: #ProjectController.
	self removeClassNamed: #ProjectView.
	"Smalltalk removeClassNamed: #Project."
	self removeClassNamed: #Component1.
	self removeClassNamed: #FormSetFont.
	self removeClassNamed: #FontSet.
	self removeClassNamed: #InstructionPrinter.
	self removeClassNamed: #ChangeSorter.
	self removeClassNamed: #DualChangeSorter.
	self removeClassNamed: #EmphasizedMenu.
	self removeClassNamed: #MessageTally.
	StringHolder class removeSelector: #originalWorkspaceContents.
	CompiledMethod removeSelector: #symbolic.
	RemoteString removeSelector: #makeNewTextAttVersion.
	Utilities class removeSelector: #absorbUpdatesFromServer.
	self removeClassNamed: #PenPointRecorder.
	self removeClassNamed: #Path.
	self removeClassNamed: #Base64MimeConverter.
	"Smalltalk removeClassNamed: #EToySystem. Dont bother - its
	very small and used for timestamps etc"
	self removeClassNamed: #RWBinaryOrTextStream.
	self removeClassNamed: #AttributedTextStream.
	self removeClassNamed: #WordNet.
	self removeClassNamed: #SelectorBrowser.
	TextStyle
		allSubInstancesDo: [:ts | ts
				newFontArray: (ts fontArray
						copyFrom: 1
						to: (2 min: ts fontArray size))].
	ListParagraph initialize.
	PopUpMenu initialize.
	StandardSystemView initialize.
	ChangeSet noChanges.
	ChangeSet classPool
		at: #AllChangeSets
		put: (OrderedCollection with: ChangeSet current).
	SystemDictionary removeSelector: #majorShrink.
	[self removeAllUnSentMessages > 0]
		whileTrue: [Smalltalk unusedClasses
				do: [:c | (Smalltalk at: c) removeFromSystem]].
	SystemOrganization removeEmptyCategories.
	self
		allClassesDo: [:c | c zapOrganization].
	self garbageCollect.
	'Rehashing method dictionaries . . .'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: MethodDictionary instanceCount
		during: [:bar | 
			oldDicts := MethodDictionary allInstances.
			newDicts := Array new: oldDicts size.
			oldDicts
				withIndexDo: [:d :index | 
					bar value: index.
					newDicts at: index put: d rehashWithoutBecome].
			oldDicts elementsExchangeIdentityWith: newDicts].
	oldDicts := newDicts := nil.
	Project rebuildAllProjects.
	ChangeSet current initialize.
	"seems to take more than one try to gc all the weak refs in
	SymbolTable "
	3
		timesRepeat: [self garbageCollect.
			Symbol compactSymbolTable]! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'nk 4/28/2004 10:24'!
presumedSentMessages   | sent |
"Smalltalk presumedSentMessages"

	"The following should be preserved for doIts, etc"
	sent _ IdentitySet new.
	#( rehashWithoutBecome compactSymbolTable rebuildAllProjects
		browseAllSelect:  lastRemoval
		scrollBarValue: vScrollBarValue: scrollBarMenuButtonPressed: 
		withSelectionFrom:  to: removeClassNamed:
		dragon: hilberts: mandala: web test3 factorial tinyBenchmarks benchFib
		newDepth: restoreAfter: forgetDoIts zapAllMethods obsoleteClasses
		removeAllUnSentMessages abandonSources removeUnreferencedKeys
		reclaimDependents zapOrganization condenseChanges browseObsoleteReferences
		subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
		methodsFor:stamp: methodsFor:stamp:prior: instanceVariableNames:
		startTimerInterruptWatcher unusedClasses) do:
		[:sel | sent add: sel].
	"The following may be sent by perform: in dispatchOnChar..."
	(ParagraphEditor classPool at: #CmdActions) asSet do:
		[:sel | sent add: sel].
	(ParagraphEditor classPool at: #ShiftCmdActions) asSet do:
		[:sel | sent add: sel].
	^ sent! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'nk 4/28/2004 10:24'!
removeAllUnSentMessages
	"Smalltalk removeAllUnSentMessages"
	"[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. 
	Smalltalk removeAllUnSentMessages > 0] whileTrue."
	"Remove all implementations of unsent messages."
	| sels n |
	sels _ self systemNavigation allUnSentMessages.
	"The following should be preserved for doIts, etc"
	"needed even after #majorShrink is pulled"
	#(#rehashWithoutBecome #compactSymbolTable #rebuildAllProjects #browseAllSelect:  #lastRemoval #scrollBarValue: vScrollBarValue: #scrollBarMenuButtonPressed: #withSelectionFrom: #to: #removeClassNamed: #dragon: #hilberts: #mandala: #web #test3 #factorial #tinyBenchmarks #benchFib #newDepth: #restoreAfter: #forgetDoIts #zapAllMethods #obsoleteClasses #removeAllUnSentMessages #abandonSources #removeUnreferencedKeys #reclaimDependents #zapOrganization #condenseChanges #browseObsoleteReferences #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: #methodsFor:stamp: #methodsFor:stamp:prior: #instanceVariableNames: #startTimerInterruptWatcher #unusedClasses )
		do: [:sel | sels
				remove: sel
				ifAbsent: []].
	"The following may be sent by perform: in dispatchOnChar..."
	(ParagraphEditor classPool at: #CmdActions) asSet
		do: [:sel | sels
				remove: sel
				ifAbsent: []].
	(ParagraphEditor classPool at: #ShiftCmdActions) asSet
		do: [:sel | sels
				remove: sel
				ifAbsent: []].
	sels size = 0
		ifTrue: [^ 0].
	n _ 0.
	self systemNavigation
		allBehaviorsDo: [:x | n _ n + 1].
	'Removing ' , sels size printString , ' messages . . .'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: n
		during: [:bar | 
			n _ 0.
			self systemNavigation
				allBehaviorsDo: [:class | 
					bar value: (n _ n + 1).
					sels
						do: [:sel | class basicRemoveSelector: sel]]].
	^ sels size! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:26'!
removeNormalCruft
	"Remove various graphics, uniclasses, references. Caution: see
	comment at bottom of method"
	"Smalltalk removeNormalCruft"
	ScriptingSystem stripGraphicsForExternalRelease.
	ScriptingSystem spaceReclaimed.
	References keys
		do: [:k | References removeKey: k].
	self classNames
		do: [:cName | #('Player' 'CardPlayer' 'Component' 'WonderlandActor' 'MorphicModel' 'PlayWithMe' )
				do: [:superName | ((cName ~= superName
								and: [cName beginsWith: superName])
							and: [(cName allButFirst: superName size)
									allSatisfy: [:ch | ch isDigit]])
						ifTrue: [self removeClassNamed: cName]]].
	self
		at: #Wonderland
		ifPresent: [:cls | cls removeActorPrototypesFromSystem].
	ChangeSet current clear
	"Caution: if any worlds in the image happen to have uniclass
	players associated with them, running this method would
	likely compromise their functioning and could cause errors,
	especially if the uniclass player of the current world had any
	scripts set to ticking. If that happens to you somehow, you will
	probably want to find a way to reset the offending world's
	player to be an UnscriptedCardPlayer, or perhaps nil"! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:26'!
removeSelector: descriptor 
	"Safely remove a selector from a class (or metaclass). If the
	class or the method doesn't exist anymore, never mind and
	answer nil.
	This method should be used instead of 'Class removeSelector:
	#method' to omit global class references."
	| class sel |
	class := self
				at: descriptor first
				ifAbsent: [^ nil].
	(descriptor size > 2
			and: [descriptor second == #class])
		ifTrue: [class := class class.
			sel := descriptor third]
		ifFalse: [sel := descriptor second].
	^ class removeSelector: sel! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/25/2001 22:34'!
reportClassAndMethodRemovalsFor: collectionOfClassNames
	| initialClassesAndMethods finalClassesAndMethods |
	"Smalltalk reportClassAndMethodRemovalsFor: #(Celeste Scamper MailMessage)"

	initialClassesAndMethods _ self unusedClassesAndMethodsWithout: {{}. {}}.
	finalClassesAndMethods _ self unusedClassesAndMethodsWithout: {collectionOfClassNames. {}}.
	^ {finalClassesAndMethods first copyWithoutAll: initialClassesAndMethods first.
		finalClassesAndMethods second copyWithoutAll: initialClassesAndMethods second}! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 4/29/2003 19:06'!
unusedClasses
	"Enumerates all classes in the system and returns a list of those that are 
	apparently unused. A class is considered in use if it (a) has subclasses 
	or (b) is referred to by some method or (c) has its name in use as a 
	literal. "
	"Smalltalk unusedClasses asSortedCollection"
	^ self systemNavigation allUnusedClassesWithout: {{}. {}}! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'edc 11/8/2005 10:11'!
unusedClassesAndMethodsWithout: classesAndMessagesPair 
	"Accepts and returns a pair: {set of class names. set of selectors}. 
	It is expected these results will be diff'd with the normally unused 
	results. "
	| classRemovals messageRemovals nClasses nMessages |
	(classRemovals _ IdentitySet new) addAll: classesAndMessagesPair first.
	(messageRemovals _ IdentitySet new) addAll: classesAndMessagesPair second.
	nClasses _ nMessages _ -1.
	["As long as we keep making progress..."
	classRemovals size > nClasses
		or: [messageRemovals size > nMessages]]
		whileTrue: ["...keep trying for bigger sets of unused classes and selectors."
			nClasses _ classRemovals size.
			nMessages _ messageRemovals size.
			Utilities
				informUser: 'Iterating removals '
						, (classesAndMessagesPair first isEmpty
								ifTrue: ['for baseline...']
								ifFalse: ['for ' , classesAndMessagesPair first first , ' etc...']) , Character cr asString , nClasses printString , ' classes, ' , nMessages printString , ' messages.
|
|'
				during: ["spacers move menu off cursor"
					classRemovals
						addAll: (self systemNavigation allUnusedClassesWithout: {classRemovals. messageRemovals}).
					messageRemovals
						addAll: (self systemNavigation allUnSentMessagesWithout: {classRemovals. messageRemovals})]].
	^ {classRemovals. self systemNavigation allUnSentMessagesWithout: {classRemovals. messageRemovals}}! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'dao 10/1/2004 13:51'!
writeImageSegmentsFrom: segmentDictionary withKernel: kernel
	"segmentDictionary is associates segmentName -> {classNames. methodNames},
	and kernel is another set of classNames determined to be essential.
	Add a partition, 'Secondary' with everything not in partitions and not in the kernel.
	Then write segments based on this partitioning of classes."

	| metas secondary dups segDict overlaps classes n symbolHolder |
	"First, put all classes that are in no other partition, and not in kernel into a new partition called 'Secondary'.  Also remove any classes in kernel from putative partitions."
	secondary _ Smalltalk classNames asIdentitySet.
	segmentDictionary keysDo:
		[:segName |
		secondary removeAllFoundIn: (segmentDictionary at: segName) first.
		(segmentDictionary at: segName) first removeAllFoundIn: kernel].
	secondary removeAllFoundIn: kernel.
	secondary removeAllFoundIn: #(PseudoContext TranslatedMethod Utilities Preferences OutOfScopeNotification FakeClassPool  BlockCannotReturn FormSetFont ExternalSemaphoreTable NetNameResolver ScreenController InterpreterPlugin Command WeakSet).
	FileDirectory allSubclassesDo: [:c | secondary remove: c name ifAbsent: []].
	segmentDictionary at: 'Secondary' put: {secondary. {}}.

	"Now build segDict giving className -> segName, and report any duplicates."
	dups _ Dictionary new.
	segDict _ IdentityDictionary new: 3000.
	segmentDictionary keysDo:
		[:segName | (segmentDictionary at: segName) first do:
			[:className |
			(segDict includesKey: className) ifTrue:
				[(dups includesKey: className) ifFalse: [dups at: className put: Array new].
				dups at: className put: (dups at: className) , {segName}].
			segDict at: className put: segName]].
	dups size > 0 ifTrue: [dups inspect.  ^ self error: 'Duplicate entries'].

	"Then for every class in every partition, make sure that neither it
	nor any of its superclasses are in any other partition.  If they are,
	enter them in a dictionary of overlaps.
	If the dictionary is not empty, then stop and report it."
	overlaps _ Dictionary new.
	segmentDictionary keysDo:
		[:segName |  
		classes _ (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
		classes do:
			[:c | (c isKindOf: Class) ifTrue:
				[c withAllSuperclasses do:
					[:sc | n _ segDict at: sc name ifAbsent: [segName].
					n ~= segName ifTrue:
						[n = 'Secondary'
							ifTrue: [(segmentDictionary at: 'Secondary') first
										remove: sc name ifAbsent: []]
							ifFalse: [overlaps at: c name put: 
										(c withAllSuperclasses collect: [:cc | segDict associationAt: cc name ifAbsent: [cc name -> 'Kernel']])]]]]]].
	overlaps size > 0 ifTrue: [overlaps inspect.  ^ self error: 'Superclasses in separate segments'].

	"If there are no overlaps, then proceed to write the partitioned classes."
	symbolHolder _ Symbol allInstances.	"Hold onto Symbols with strong pointers, 
		so they will be in outPointers"
	segmentDictionary keysDo:
		[:segName |  Utilities informUser: segName during:
			[classes _ (segmentDictionary at: segName) first asArray collect: [:k | Smalltalk at: k].
			metas _ classes select: [:c | c isKindOf: Class] thenCollect: [:c | c class].
			(ImageSegment new copyFromRoots: classes , metas sizeHint: 0) extract; 
					writeToFile: segName]].
	symbolHolder.  "Keep compiler for getting uppity."! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'ar 9/27/2005 20:12'!
zapAllOtherProjects 
	"Smalltalk zapAllOtherProjects"
"Note: as of this writing, the only reliable way to get rid of all but the current project is te execute the following, one line at a time...
		Smalltalk zapAllOtherProjects.
		ProjectHistory currentHistory initialize.
		Smalltalk garbageCollect.
		Project rebuildAllProjects.
"

	
	Project allInstancesDo: [:p | p setParent: nil].
	Project current setParent: Project current.
	Project current isMorphic ifTrue: [ScheduledControllers := nil].
	TheWorldMenu allInstancesDo: [:m | 1 to: m class instSize do: [:i | m instVarAt: i put: nil]].
	ChangeSet classPool at: #AllChangeSets put: nil.
	Project classPool at: #AllProjects put: nil.
	ProjectHistory currentHistory initialize.
	ChangeSet initialize.
	Project rebuildAllProjects.  "Does a GC"
	Project allProjects size > 1 ifTrue: [Project allProjects inspect]! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'dao 10/1/2004 13:30'!
zapMVCprojects
	"Smalltalk zapMVCprojects"
	| window |

	self flag: #bob. "zapping projects"

	Smalltalk garbageCollect.
	"So allInstances is precise"
	Project
		allSubInstancesDo: [:proj | proj isTopProject
				ifTrue: [proj isMorphic
						ifFalse: ["Root project is MVC -- we must become the root"
							Project current setParent: Project current.]]
				ifFalse: [proj parent isMorphic
						ifFalse: [proj isMorphic
								ifTrue: ["Remove Morphic projects from MVC 
									views "
									"... and add them back here."
									window _ (SystemWindow labelled: proj name)
												model: proj.
									window
										addMorph: (ProjectViewMorph on: proj)
										frame: (0 @ 0 corner: 1.0 @ 1.0).
									window openInWorld.
									proj setParent: Project current]].
					proj isMorphic
						ifFalse: ["Remove MVC projects from Morphic views"
							Project deletingProject: proj]]]! !


!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:38'!
addToShutDownList: aClass
	"This will add a ref to this class at the BEGINNING of the shutDown list."

	self addToShutDownList: aClass after: nil! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'!
addToShutDownList: aClass after: predecessor

	self add: aClass toList: ShutDownList after: predecessor! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:37'!
addToStartUpList: aClass
	"This will add a ref to this class at the END of the startUp list."

	self addToStartUpList: aClass after: nil! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'!
addToStartUpList: aClass after: predecessor

	self add: aClass toList: StartUpList after: predecessor! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/19/1999 22:36'!
add: aClass toList: startUpOrShutDownList after: predecessor
	"Add the name of aClass to the startUp or shutDown list.
	Add it after the name of predecessor, or at the end if predecessor is nil."

	| name earlierName |
	name _ aClass name.
	(self at: name ifAbsent: [nil]) == aClass ifFalse:
		[self error: name , ' cannot be found in Smalltalk dictionary.'].
	predecessor == nil
		ifTrue: ["No-op if alredy in the list."
				(startUpOrShutDownList includes: name) ifFalse:
					[startUpOrShutDownList == StartUpList
						ifTrue: ["Add to end of startUp list"
								startUpOrShutDownList addLast: name]
						ifFalse: ["Add to front of shutDown list"
								startUpOrShutDownList addFirst: name]]]
		ifFalse: ["Add after predecessor, moving it if already there."
				earlierName _ predecessor name.
				(self at: earlierName) == predecessor ifFalse:
					[self error: earlierName , ' cannot be found in Smalltalk dictionary.'].
				(startUpOrShutDownList includes: earlierName) ifFalse:
					[self error: earlierName , ' cannot be found in the list.'].
				startUpOrShutDownList remove: name ifAbsent:[].
				startUpOrShutDownList add: name after: earlierName]! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'RAA 6/14/2000 17:21'!
isMorphic
        "Answer true if the user interface is running in Morphic rathern than 
        MVC.  By convention the gloabl variable World is set to nil when MVC is 
        running.  ScheduledControllers could be set to nil when Morphic is 
        running, but this symmetry is not yet in effect."

        ^ World ~~ nil "or: [RequestCurrentWorldNotification signal notNil]"! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'!
processShutDownList: quitting
	"Send #shutDown to each class that needs to wrap up before a snapshot."

	self send: #shutDown: toClassesNamedIn: ShutDownList with: quitting.
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'!
processStartUpList: resuming
	"Send #startUp to each class that needs to run initialization after a snapshot."

	self send: #startUp: toClassesNamedIn: StartUpList with: resuming.
! !

!SystemDictionary methodsFor: 'snapshot and quit'!
quitPrimitive
	"Primitive. Exit to another operating system on the host machine, if one
	exists. All state changes in the object space since the last snapshot are lost.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 113>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'!
removeFromShutDownList: aClass

	ShutDownList remove: aClass name ifAbsent: []! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'!
removeFromStartUpList: aClass

	StartUpList remove: aClass name ifAbsent: []! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 3/7/2001 01:26'!
send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument
	"Send the message #startUp: or #shutDown: to each class named in the list.
	The argument indicates if the system is about to quit (for #shutDown:) or if
	the image is resuming (for #startUp:).
	If any name cannot be found, then remove it from the list."

	| removals class |
	removals _ OrderedCollection new.
	startUpOrShutDownList do:
		[:name |
		class _ self at: name ifAbsent: [nil].
		class == nil
			ifTrue: [removals add: name]
			ifFalse: [class isInMemory ifTrue:
						[class perform: startUpOrShutDown with: argument]]].

	"Remove any obsolete entries, but after the iteration"
	startUpOrShutDownList removeAll: removals! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sd 9/30/2003 13:47'!
setGCParameters
	"Adjust the VM's default GC parameters to avoid premature tenuring."

	SmalltalkImage current  vmParameterAt: 5 put: 4000.  "do an incremental GC after this many allocations"
	SmalltalkImage current  vmParameterAt: 6 put: 2000.  "tenure when more than this many objects survive the GC"
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 13:14'!
shutDown
	^ SmalltalkImage current closeSourceFiles! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'gk 2/23/2004 20:51'!
shutDownSound
	"No longer used in the release, but retained for backward compatibility."

	SoundService default shutDown
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'JMM 11/21/2000 21:02'!
snapshotEmbeddedPrimitive
	<primitive: 247>
	^nil "indicates error writing embedded image file"! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 7/22/2000 14:34'!
snapshotPrimitive
	"Primitive. Write the current state of the object memory on a file in the
	same format as the Smalltalk-80 release. The file can later be resumed,
	returning you to this exact state. Return normally after writing the file.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 97>
	^nil "indicates error writing image file"! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'nk 11/12/2003 10:32'!
unbindExternalPrimitives
	"Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found."
	^ self deprecated: 'Use SmalltalkImage unbindExternalPrimitives'
		block: [SmalltalkImage unbindExternalPrimitives].
	"Do nothing if the primitive fails for compatibility with older VMs"! !


!SystemDictionary methodsFor: 'sources, change log'!
copyright
	"The Smalltalk copyright."

	^'Copyright (c) Xerox Corp. 1981, 1982 All rights reserved.
Copyright (c) Apple Computer, Inc. 1985-1996 All rights reserved.'! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'em 3/31/2005 11:48'!
currentChangeSetString
	"Smalltalk currentChangeSetString"
	^ 'Current Change Set: ' translated, ChangeSet current name! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 9/29/2004 18:27'!
currentProjectDo: aBlock 
	"So that code can work after removal of Projects"
	self
		at: #Project
		ifPresent: [:projClass | aBlock value: projClass current]! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 11/16/2003 12:55'!
externalizeSources   
	"Write the sources and changes streams onto external files."
 	"Smalltalk externalizeSources"
	"the logic of this method is complex because it uses changesName and self changesName
	may be this is normal - sd"
	
	| sourcesName changesName aFile |
	sourcesName _ SmalltalkImage current sourcesName.
	(FileDirectory default fileExists: sourcesName)
		ifTrue: [^ self inform:
'Sorry, you must first move or remove the
file named ', sourcesName].
	changesName _ SmalltalkImage current changesName.
	(FileDirectory default fileExists: changesName)
		ifTrue: [^ self inform:
'Sorry, you must first move or remove the
file named ', changesName].

	aFile _  FileStream newFileNamed: sourcesName.
	aFile nextPutAll: SourceFiles first originalContents.
	aFile close.
	self setMacFileInfoOn: sourcesName.
	SourceFiles at: 1 put: (FileStream readOnlyFileNamed: sourcesName).

	aFile _ FileStream newFileNamed: SmalltalkImage current changesName.
	aFile nextPutAll: SourceFiles last contents.
	aFile close.
	"On Mac, set the file type and creator (noop on other platforms)"
	FileDirectory default
		setMacFileNamed: SmalltalkImage current changesName
		type: 'STch'
		creator: 'FAST'.
	SourceFiles at: 2 put: (FileStream oldFileNamed: changesName).

	self inform: 'Sources successfully externalized'.
! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'ar 2/6/2001 18:42'!
forceChangesToDisk
	"Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot."

	| changesFile |
	changesFile _ SourceFiles at: 2.
	(changesFile isKindOf: FileStream) ifTrue: [
		changesFile flush.
		SecurityManager default hasFileAccess ifTrue:[
			changesFile close.
			changesFile open: changesFile name forWrite: true].
		changesFile setToEnd.
	].
! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 11/16/2003 12:55'!
internalizeChangeLog    
		"Smalltalk internalizeChangeLog"
	"Bring the changes file into a memory-resident filestream, for faster access and freedom from external file system.  1/31/96 sw"

	| reply aName aFile |
	reply _ self confirm:  'CAUTION -- do not undertake this lightly!!
If you have backed up your system and
are prepared to face the consequences of
the requested internalization of sources,
hit Yes.  If you have any doubts, hit No
to back out with no harm done.'.

	(reply ==  true) ifFalse:
		[^ self inform: 'Okay - abandoned'].

	aName _ SmalltalkImage current changesName.
	(aFile _ SourceFiles last) == nil ifTrue:
		[(FileDirectory default fileExists: aName)
			ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
		aFile _ FileStream readOnlyFileNamed: aName].
	SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).

	self inform: 'Okay, changes file internalized'! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 11/16/2003 12:55'!
internalizeSources    
		"Smalltalk internalizeSources"
	"Bring the sources and changes files into memory-resident filestreams, for faster access and freedom from file-system interface.  1/29/96 sw"

	| reply aName aFile |
	reply _ self confirm:  'CAUTION -- do not undertake this lightly!!
If you have backed up your system and
are prepared to face the consequences of
the requested internalization of sources,
hit Yes.  If you have any doubts, hit No
to back out with no harm done.'.

	(reply ==  true) ifFalse:
		[^ self inform: 'Okay - abandoned'].

	aName _ SmalltalkImage current sourcesName.
	(aFile _ SourceFiles first) == nil ifTrue:
		[(FileDirectory default fileExists: aName)
			ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
		aFile _ FileStream readOnlyFileNamed: aName].
	SourceFiles at: 1 put: (ReadWriteStream with: aFile contentsOfEntireFile).

	aName _ SmalltalkImage current changesName.
	(aFile _ SourceFiles last) == nil ifTrue:
		[(FileDirectory default fileExists: aName)
			ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
		aFile _ FileStream readOnlyFileNamed: aName].
	SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).

	self inform: 'Okay, sources internalized'! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/3/2000 15:59'!
recover: nCharacters
	"Schedule an editable text view on the last n characters of changes."
	self writeRecentCharacters: nCharacters toFileNamed: 'st80.recent'! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'md 5/16/2006 12:34'!
version
	"Answer the version of this release."

	^SystemVersion current version! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'JMM 4/13/2005 20:35'!
wordSize
	"Answer the size (in bytes) of an object pointer."
	"Smalltalk wordSize"

	^[SmalltalkImage current vmParameterAt: 40] on: Error do: [4]! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'nk 8/21/2004 15:55'!
writeRecentCharacters: nCharacters toFileNamed: aFilename
	"Schedule an editable text view on the last n characters of changes."
	| changes |
	changes _ SourceFiles at: 2.
	changes setToEnd; skip: nCharacters negated.
	(StandardFileStream newFileNamed: aFilename) nextPutAll: (changes next: nCharacters); close; open; edit! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'ar 9/27/2005 22:38'!
writeRecentToFile
	"Smalltalk writeRecentToFile"
	| numChars aDirectory aFileName |
	aDirectory := FileDirectory default.
	aFileName := Utilities
				keyLike: 'squeak-recent.01'
				withTrailing: '.log'
				satisfying: [:aKey | (aDirectory includesKey: aKey) not].
	numChars := ChangeSet getRecentLocatorWithPrompt: 'copy logged source as far back as...'.
	numChars
		ifNotNil: [self writeRecentCharacters: numChars toFileNamed: aFileName]! !


!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:36'!
clearExternalObjects
	"Clear the array of objects that have been registered for use in non-Smalltalk code."
	"Smalltalk clearExternalObjects"

	ExternalSemaphoreTable clearExternalObjects
! !

!SystemDictionary methodsFor: 'special objects' stamp: 'sd 9/29/2004 18:30'!
compactClassesArray
	"Smalltalk compactClassesArray"
	"Return the array of 31 classes whose instances may be
	represented compactly"
	^ self specialObjectsArray at: 29! !

!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 21:01'!
externalObjects
	"Return an array of objects that have been registered for use in non-Smalltalk code. Smalltalk objects should be referrenced by external code only via indirection through this array, thus allowing the objects to move during compaction. This array can be cleared when the VM re-starts, since variables in external code do not survive snapshots. Note that external code should not attempt to access a Smalltalk object, even via this mechanism, while garbage collection is in progress."
	"Smalltalk externalObjects"

	^ ExternalSemaphoreTable externalObjects
! !

!SystemDictionary methodsFor: 'special objects'!
hasSpecialSelector: aLiteral ifTrueSetByte: aBlock

	1 to: self specialSelectorSize do:
		[:index | 
		(self specialSelectorAt: index) == aLiteral
			ifTrue: [aBlock value: index + 16rAF. ^true]].
	^false! !

!SystemDictionary methodsFor: 'special objects' stamp: 'dtl 10/3/2005 05:56'!
recreateSpecialObjectsArray
	"Smalltalk recreateSpecialObjectsArray"
	"The Special Objects Array is an array of object pointers used
	by the
	Squeak virtual machine. Its contents are critical and
	unchecked, so don't even think of playing here unless you
	know what you are doing."
	| newArray |
	newArray := Array new: 50.
	"Nil false and true get used throughout the interpreter"
	newArray at: 1 put: nil.
	newArray at: 2 put: false.
	newArray at: 3 put: true.
	"This association holds the active process (a ProcessScheduler)"
	newArray
		at: 4
		put: (self associationAt: #Processor).
	"Numerous classes below used for type checking and
	instantiation"
	newArray at: 5 put: Bitmap.
	newArray at: 6 put: SmallInteger.
	newArray at: 7 put: ByteString.
	newArray at: 8 put: Array.
	newArray at: 9 put: Smalltalk.
	newArray at: 10 put: Float.
	newArray at: 11 put: MethodContext.
	newArray at: 12 put: BlockContext.
	newArray at: 13 put: Point.
	newArray at: 14 put: LargePositiveInteger.
	newArray at: 15 put: Display.
	newArray at: 16 put: Message.
	newArray at: 17 put: CompiledMethod.
	newArray
		at: 18
		put: (self specialObjectsArray at: 18).
	"(low space Semaphore)"
	newArray at: 19 put: Semaphore.
	newArray at: 20 put: Character.
	newArray at: 21 put: #doesNotUnderstand:.
	newArray at: 22 put: #cannotReturn:.
	"The process that signaled the low space semaphore."
	newArray at: 23 put: nil.
	"An array of the 32 selectors that are compiled as special
	bytecodes, paired alternately with the number of arguments
	each takes."
	newArray at: 24 put: #(#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
	"An array of the 255 Characters in ascii order."
	newArray
		at: 25
		put: ((0 to: 255)
				collect: [:ascii | Character value: ascii]).
	newArray at: 26 put: #mustBeBoolean.
	newArray at: 27 put: ByteArray.
	newArray at: 28 put: Process.
	"An array of up to 31 classes whose instances will have
	compact headers"
	newArray at: 29 put: self compactClassesArray.
	newArray
		at: 30
		put: (self specialObjectsArray at: 30).
	"(delay Semaphore)"
	newArray
		at: 31
		put: (self specialObjectsArray at: 31).
	"(user interrupt Semaphore)"
	"Prototype instances that can be copied for fast initialization"
	newArray
		at: 32
		put: (Float new: 2).
	newArray
		at: 33
		put: (LargePositiveInteger new: 4).
	newArray at: 34 put: Point new.
	newArray at: 35 put: #cannotInterpret:.
	"Note: This must be fixed once we start using context
	prototypes"
	newArray
		at: 36
		put: (self specialObjectsArray at: 36).
	"(MethodContext new: CompiledMethod fullFrameSize)."
	newArray at: 37 put: nil.
	newArray
		at: 38
		put: (self specialObjectsArray at: 38).
	"(BlockContext new: CompiledMethod fullFrameSize)."
	newArray at: 39 put: Array new.
	"array of objects referred to by external code"
	newArray at: 40 put: PseudoContext.
	newArray at: 41 put: TranslatedMethod.
	"finalization Semaphore"
	newArray
		at: 42
		put: ((self specialObjectsArray at: 42)
				ifNil: [Semaphore new]).
	newArray at: 43 put: LargeNegativeInteger.
	"External objects for callout.
	Note: Written so that one can actually completely remove the
	FFI."
	newArray
		at: 44
		put: (self
				at: #ExternalAddress
				ifAbsent: []).
	newArray
		at: 45
		put: (self
				at: #ExternalStructure
				ifAbsent: []).
	newArray
		at: 46
		put: (self
				at: #ExternalData
				ifAbsent: []).
	newArray
		at: 47
		put: (self
				at: #ExternalFunction
				ifAbsent: []).
	newArray
		at: 48
		put: (self
				at: #ExternalLibrary
				ifAbsent: []).
	newArray at: 49 put: #aboutToReturn:through:.
	newArray at: 50 put: #run:with:in:.
	"Now replace the interpreter's reference in one atomic
	operation"
	self specialObjectsArray become: newArray! !

!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:39'!
registerExternalObject: anObject
	"Register the given object in the external objects array and return its index. If it is already there, just return its index."

	^ExternalSemaphoreTable registerExternalObject: anObject! !

!SystemDictionary methodsFor: 'special objects'!
specialNargsAt: anInteger 
	"Answer the number of arguments for the special selector at: anInteger."

	^ (self specialObjectsArray at: 24) at: anInteger * 2! !

!SystemDictionary methodsFor: 'special objects'!
specialObjectsArray  "Smalltalk specialObjectsArray at: 1"
	<primitive: 129>
	^ self primitiveFailed! !

!SystemDictionary methodsFor: 'special objects'!
specialSelectorAt: anInteger 
	"Answer the special message selector from the interleaved specialSelectors array."

	^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1! !

!SystemDictionary methodsFor: 'special objects'!
specialSelectorSize
	"Answer the number of special selectors in the system."

	^ (self specialObjectsArray at: 24) size // 2! !

!SystemDictionary methodsFor: 'special objects'!
specialSelectors
	"Used by SystemTracer only."

	^SpecialSelectors! !

!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:40'!
unregisterExternalObject: anObject
	"Unregister the given object in the external objects array. Do nothing if it isn't registered."

	ExternalSemaphoreTable unregisterExternalObject: anObject! !


!SystemDictionary methodsFor: 'ui' stamp: 'sd 1/16/2004 20:49'!
inspectGlobals
	"Smalltalk  inspectGlobals"
	
	| associations aDict |
	associations _ ((self  keys select: [:aKey | ((self  at: aKey) isKindOf: Class) not]) asSortedArray collect:[:aKey | self associationAt: aKey]).
	aDict _ IdentityDictionary new.
	associations do: [:as | aDict add: as].
	aDict inspectWithLabel: 'The Globals'! !


!SystemDictionary methodsFor: '*39Deprecated' stamp: 'md 3/3/2006 09:28'!
associationAtOrAbove: varName ifAbsent: absentBlock 
	"Compatibility with environment protocol."

	self deprecated: 'use associationAt:ifAbsent:'.
	^ self associationAt: varName ifAbsent: absentBlock! !

!SystemDictionary methodsFor: '*39Deprecated' stamp: 'md 3/3/2006 09:28'!
atOrAbove: key ifAbsent: absentBlock
	"Compatibility with environment protocol."

	self deprecated: 'use at:ifAbsent:'.
	^ self at: key ifAbsent: absentBlock! !

!SystemDictionary methodsFor: '*39Deprecated' stamp: 'md 3/3/2006 09:27'!
atOrBelow: key ifAbsent: absentBlock
	"Compatibility with environment protocol."
	
	self deprecated: 'use at:ifAbsent:'.
	^ self at: key ifAbsent: absentBlock! !

!SystemDictionary methodsFor: '*39Deprecated' stamp: 'md 3/3/2006 11:07'!
environmentForCategory: catName 
	"Default response for non-partitioned systems"
	self deprecated: 'deprecated'.
	^ self! !

!SystemDictionary methodsFor: '*39Deprecated' stamp: 'rbb 3/1/2005 11:16'!
getFileNameFromUser

	| newName |
	self deprecated: 'Use SmalltalkImage current getFileNameFromUser'.
	newName := UIManager default
		request: 'New File Name?' translated
		initialAnswer: (FileDirectory localNameFor: SmalltalkImage current imageName).
	newName = '' ifTrue: [^nil].
	((FileDirectory default fileOrDirectoryExists: (SmalltalkImage current fullNameForImageNamed: newName)) or:
	 [FileDirectory default fileOrDirectoryExists: (SmalltalkImage current fullNameForChangesNamed: newName)]) ifTrue: [
		(self confirm: ('{1} already exists. Overwrite?' translated format: {newName})) ifFalse: [^nil]].
	^newName
! !

!SystemDictionary methodsFor: '*39Deprecated' stamp: 'md 3/3/2006 09:27'!
includesKeyOrAbove: key
	"Compatibility with environment protocol."

	self deprecated: 'use includesKey:'.
	self at: key ifAbsent: [^ false].
	^ true! !

!SystemDictionary methodsFor: '*39Deprecated' stamp: 'md 3/3/2006 11:10'!
scopeFor: varName from: lower envtAndPathIfFound: envtAndPathBlock
	"Null compatibility with partitioning into environments."
	
	self deprecated: 'deprecated'.

	(self includesKey: varName)
		ifTrue: [^ envtAndPathBlock value: self value: String new]
		ifFalse: [^ nil]! !

!SystemDictionary methodsFor: '*39Deprecated' stamp: 'tpr 4/27/2005 11:04'!
vmParameterAt: parameterIndex
	"See comment for SmalltalkImage>vmParameterAt:"

	^ self deprecated: 'Use SmalltalkImage current vmParameterAt:'
		block: [SmalltalkImage current vmParameterAt: parameterIndex]
	! !


!SystemDictionary methodsFor: '*eToys-copying' stamp: 'sw 11/21/2001 15:08'!
assureUniClass
	"Assure that the receiver has a uniclass.  Or rather, in this case, stop short of fulfilling such a request"

	self error: 'We do not want uniclasses descending from here'
! !

!SystemDictionary methodsFor: '*eToys-copying' stamp: 'sw 10/23/2001 10:23'!
vocabularyDemanded
	"Answer the vocabulary that the receiver really would like to use in a Viewer"

	^ Vocabulary vocabularyNamed: #System! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemDictionary class
	instanceVariableNames: ''!

!SystemDictionary class methodsFor: 'initialization' stamp: 'nk 6/21/2004 10:18'!
initialize
	"SystemDictionary initialize"

	| oldList |
	oldList _ StartUpList.
	StartUpList _ OrderedCollection new.
	"These get processed from the top down..."
	#(
		DisplayScreen
		Cursor
		InputSensor
		ProcessorScheduler  "Starts low space watcher and bkground."
		Delay
		FileDirectory  "Enables file stack dump and opens sources."
		ShortIntegerArray
		ShortRunArray
		CrLfFileStream
	) do:[:clsName|
		Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToStartUpList: cls].
	].
	oldList ifNotNil: [oldList do: [:className | Smalltalk at: className
						ifPresent: [:theClass | Smalltalk addToStartUpList: theClass]]].
	#(
		ImageSegment
		PasteUpMorph
		ControlManager
	) do:[:clsName|
		Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToStartUpList: cls].
	].
		

	oldList _ ShutDownList.
	ShutDownList _ OrderedCollection new.
	"These get processed from the bottom up..."
	#(
		DisplayScreen
		InputSensor
		Form
		ControlManager
		PasteUpMorph
		StrikeFont
		Color
		FileDirectory
		Delay
		SoundPlayer
		HttpUrl
		Password
		PWS
		MailDB
		ImageSegment
	) do:[:clsName|
		Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToShutDownList: cls].
	].

	oldList ifNotNil: [oldList reverseDo: [:className | Smalltalk at: className
						ifPresent: [:theClass | Smalltalk addToShutDownList: theClass]]].
! !
EventManager subclass: #SystemEventManager
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!
!SystemEventManager commentStamp: 'tlk 5/7/2006 20:10' prior: 0!
A SystemEventManager is EventManager that overrides Object>>actionSequenceForEvent: anEventSelector to supply WeakActionSequenceTrappingErrors as the default event.

!


!SystemEventManager methodsFor: 'events-accessing' stamp: 'rw 7/20/2003 17:02'!
actionSequenceForEvent: anEventSelector

    ^(self actionMap
        at: anEventSelector asSymbol
        ifAbsent: [^WeakActionSequenceTrappingErrors new])
            asActionSequenceTrappingErrors! !
Object subclass: #SystemNavigation
	instanceVariableNames: 'browserClass hierarchyBrowserClass'
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'System-Support'!
!SystemNavigation commentStamp: 'sd 4/15/2003 22:30' prior: 0!
I support the navigation of the system. I act as a facade but as I could require some state
or different way of navigating the system all my behavior are on the instance side!


!SystemNavigation methodsFor: 'browse' stamp: 'ich. 5/16/2004 01:05'!
allMethodsInCategory: category 
	| aCollection |
	aCollection _ SortedCollection new.
	Cursor wait showWhile:
		[self allBehaviorsDo:
			[:x | (x allMethodsInCategory: category) do:
				[:sel | aCollection add: x name , ' ' , sel]]].
	^aCollection.
	! !

!SystemNavigation methodsFor: 'browse' stamp: 'md 8/27/2005 16:42'!
browseAllAccessesTo: instVarName from: aClass
	"Create and schedule a Message Set browser for all the receiver's methods 
	or any methods of a subclass/superclass that refer to the instance variable name."

	"self new browseAllAccessesTo: 'contents' from: Collection."
	
	| coll |
	coll _ OrderedCollection new.
	Cursor wait showWhile: [
		aClass withAllSubAndSuperclassesDo: [:class | 
			(class whichSelectorsAccess: instVarName) do: [:sel |
				sel isDoIt ifFalse: [
					coll add: (
						MethodReference new
							setStandardClass: class 
							methodSymbol: sel
					)
				]
			]
		].
	].
	^ self 
		browseMessageList: coll 
		name: 'Accesses to ' , instVarName 
		autoSelect: instVarName! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/29/2003 12:23'!
browseAllCallsOn: aLiteral 
	"Create and schedule a message browser on each method that refers to 
	aLiteral. For example, SystemNavigation new browseAllCallsOn: #open:label:."
	(aLiteral isKindOf: LookupKey)
		ifTrue: [^ self
				browseMessageList: (self allCallsOn: aLiteral) asSortedCollection
				name: 'Users of ' , aLiteral key
				autoSelect: aLiteral key].
	self
		browseMessageList: (self allCallsOn: aLiteral) asSortedCollection
		name: 'Senders of ' , aLiteral
		autoSelect: aLiteral keywords first! !

!SystemNavigation methodsFor: 'browse' stamp: 'nk 6/26/2003 22:32'!
browseAllCallsOn: literal1 and: literal2 
	"Create and schedule a message browser on each method that calls on the 
	two Symbols, literal1 and literal2. For example, SystemNavigation new 
	browseAllCallsOn: #at: and: #at:put:."

	^self 
		browseMessageList: (self allCallsOn: literal1 and: literal2)
		name: literal1 printString , ' -and- ' , literal2 printString! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 08:53'!
browseAllCallsOn: aSymbol from: aClass
	"Create and schedule a Message Set browser for all the methods that call 
	on aSymbol."

	"self new browseAllCallsOn: #/. from: Number"

	| key label |
	label _ (aSymbol isKindOf: LookupKey)
			ifTrue: ['Users of ' , (key _ aSymbol key)]
			ifFalse: ['Senders of ' , (key _ aSymbol)].
	^ self 
		browseMessageList: (self  allCallsOn: aSymbol from: aClass)
		name: label
		autoSelect: key

	! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 11:44'!
browseAllCallsOn: aLiteral localTo: aClass
	"Create and schedule a message browser on each method in or below the given class that refers to
	aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:."

	aClass ifNil: [ ^self inform: 'no selected class' ].
	(aLiteral isKindOf: LookupKey)
		ifTrue: [self browseMessageList: (aClass allLocalCallsOn: aLiteral) asSortedCollection
					name: 'Users of ' , aLiteral key, ' local to ', aClass name
					autoSelect: aLiteral key]
		ifFalse: [self browseMessageList: (aClass allLocalCallsOn: aLiteral) asSortedCollection
					name: 'Senders of ' , aLiteral, ' local to ', aClass name
					autoSelect: aLiteral keywords first]! !

!SystemNavigation methodsFor: 'browse' stamp: 'tpr 12/17/2003 16:01'!
browseAllCallsOnClass: aClass
	"Create and schedule a message browser on each method that refers to 
	aClass. For example, SystemNavigation new browseAllCallsOnClass: Object."
	self
		browseMessageList: aClass allCallsOn asSortedCollection
		name: 'Users of class ' , aClass theNonMetaClass name
		autoSelect: aClass theNonMetaClass name! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/19/2003 12:15'!
browseAllImplementorsOf: selector 
	"Create and schedule a message browser on each method that implements 
	the message whose selector is the argument, selector. For example,  
	Smalltalk browseAllImplementorsOf: #at:put:."
	^ self
		browseMessageList: (self allImplementorsOf: selector)
		name: 'Implementors of ' , selector! !

!SystemNavigation methodsFor: 'browse' stamp: 'apl 4/4/2005 18:23'!
browseAllImplementorsOf: selector localTo: aClass 
	"Create and schedule a message browser on each method in or below the  
	given class  
	that implements the message whose selector is the argument, selector.  
	For example,  
	SystemNavigation new browseAllImplementorsOf: #at:put: localTo:  
	Dictionary."
	aClass
		ifNil: [^ self inform: 'no class selected'].
	^ self
		browseMessageList: ((self allImplementorsOf: selector localTo: aClass)
				collect: [:methRef | methRef actualClass name , ' ' , methRef methodSymbol])
		name: 'Implementors of ' , selector , ' local to ' , aClass name! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 21:43'!
browseAllImplementorsOfList: selectorList
	"Create and schedule a message browser on each method that implements 
	the message whose selector is in the argument selectorList. For example, 
	Smalltalk browseAllImplementorsOf: #(at:put: size).
	1/16/96 sw: defer to the titled version"

	self browseAllImplementorsOfList: selectorList title: 'Implementors of all'! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/19/2003 12:15'!
browseAllImplementorsOfList: selectorList title: aTitle 
	"Create and schedule a message browser on each method that implements 
	the message whose selector is in the argument selectorList. For 
	example,  
	self new browseAllImplementorsOf: #(at:put: size).  
	1/16/96 sw: this variant adds the title argument.  
	1/24/96 sw: use a SortedCollection  
	2/1/96 sw: show normal cursor"
	| implementorLists flattenedList |
	implementorLists _ selectorList
				collect: [:each | self allImplementorsOf: each].
	flattenedList _ SortedCollection new.
	implementorLists
		do: [:each | flattenedList addAll: each].
	Cursor normal show.
	^ self browseMessageList: flattenedList name: aTitle! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 09:17'!
browseAllMethodsInCategory: category 
	^self browseMessageList: (self allMethodsInCategory: category)
		name: category! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 22:41'!
browseAllObjectReferencesTo: anObject except: objectsToExclude ifNone: aBlock 
	"Bring up a list inspector on the objects that point to anObject.
	If there are none, then evaluate aBlock on anObject.  "

	| aList shortName |
	aList := Utilities pointersTo: anObject except: objectsToExclude.
	aList size > 0 ifFalse: [^aBlock value: anObject].
	shortName := (anObject name ifNil: [anObject printString]) contractTo: 20.
	aList inspectWithLabel: 'Objects pointing to ' , shortName! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/7/2003 18:05'!
browseAllReferencesToPool: poolOrName from: aClass
	"Open a message list on all messages referencing the given pool"
	| pool list |
	(poolOrName isString)
		ifTrue:[pool := Smalltalk at: poolOrName asSymbol]
		ifFalse:[pool := poolOrName].
	list := self allReferencesToPool: pool from: aClass.
	self
		browseMessageList: list
		name: 'users of ', poolOrName name.
	^list! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/29/2003 20:43'!
browseAllSelect: aBlock 
	"Create and schedule a message browser on each method that, when used 
	as the block argument to aBlock gives a true result. For example,  
	SystemNavigation new browseAllSelect: [:method | method numLiterals >  
	10]."
	^ self
		browseMessageList: (self allMethodsSelect: aBlock)
		name: 'selected messages'! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/29/2003 20:44'!
browseAllSelect: aBlock name: aName autoSelect: autoSelectString 
	"Create and schedule a message browser on each method that, when used 
	as the block argument to aBlock gives a true result. Do not return an  
	#DoIt traces."
	"self new browseAllSelect: [:method | method numLiterals > 10] name:  
	'Methods with more than 10 literals' autoSelect: 'isDigit'"
	^ self
		browseMessageList: (self allMethodsNoDoitsSelect: aBlock)
		name: aName
		autoSelect: autoSelectString! !

!SystemNavigation methodsFor: 'browse' stamp: 'md 8/27/2005 17:17'!
browseAllStoresInto: instVarName from: aClass
	"Create and schedule a Message Set browser for all the receiver's methods 
	or any methods of a subclass/superclass that refer to the instance variable name."
	
	"self new browseAllStoresInto: 'contents' from: Collection."

	| coll |
	coll _ OrderedCollection new.
	Cursor wait showWhile: [
		aClass withAllSubAndSuperclassesDo: [:class | 
			(class whichSelectorsStoreInto: instVarName) do: [:sel |
				sel isDoIt ifFalse: [
					coll add: (
						MethodReference new
							setStandardClass: class 
							methodSymbol: sel
					)
				]
			]
		].
	].
	^ self
		browseMessageList: coll 
		name: 'Stores into ' , instVarName 
		autoSelect: instVarName! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 21:26'!
browseAllUnSentMessages
	"Create and schedule a message browser on each method whose message is  not sent in any method in the system."
	"self new browseAllUnSentMessages"

	self browseAllImplementorsOfList: self allUnSentMessages title: 'Messages implemented but not sent'
! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 09:16'!
browseAllUnimplementedCalls
	"Create and schedule a message browser on each method that includes a 
	message that is not implemented in any object in the system."

	^self   browseMessageList: self allUnimplementedCalls name: 'Unimplemented calls'! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 08:53'!
browseClassCommentsWithString: aString
	"Smalltalk browseClassCommentsWithString: 'my instances' "
	"Launch a message list browser on all class comments containing aString as a substring."

	| caseSensitive suffix list |

	suffix _ (caseSensitive _ Sensor shiftPressed)
		ifTrue: [' (case-sensitive)']
		ifFalse: [' (use shift for case-sensitive)'].
	list _ Set new.
	Cursor wait showWhile: [
		Smalltalk allClassesDo: [:class | 
			(class organization classComment asString findString: aString 
							startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [
								list add: (
									MethodReference new
										setStandardClass: class
										methodSymbol: #Comment
								)
							]
		]
	].
	^ self 
		browseMessageList: list asSortedCollection
		name: 'Class comments containing ' , aString printString , suffix
		autoSelect: aString! !

!SystemNavigation methodsFor: 'browse' stamp: 'rbb 2/18/2005 14:43'!
browseClassVarRefs: aClass
	"Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods 
	that refer to the selected class variable"

	| lines labelStream vars allVars index owningClasses |
	lines _ OrderedCollection new.
	allVars _ OrderedCollection new.
	owningClasses _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	aClass withAllSuperclasses reverseDo:
		[:class |
		vars _ class classVarNames asSortedCollection.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var.
			owningClasses add: class].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better"
	labelStream skip: -1 "cut last CR".
	index _ (UIManager default chooseFrom: (labelStream contents substrings) lines: lines).
	index = 0 ifTrue: [^ self].
	self browseAllCallsOn:
		((owningClasses at: index) classPool associationAt: (allVars at: index))! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 3/28/2003 18:49'!
browseClassVariables: aClass
	aClass classPool inspectWithLabel: 'Class Variables in ' , aClass name! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:33'!
browseClassesWithNamesContaining: aString caseSensitive: caseSensitive 
	"Smalltalk browseClassesWithNamesContaining: 'eMorph' caseSensitive: true "
	"Launch a class-list list browser on all classes whose names containg aString as a substring."

	| suffix aList |
	suffix := caseSensitive
				ifTrue: [' (case-sensitive)']
				ifFalse: [' (use shift for case-sensitive)'].
	aList := OrderedCollection new.
	Cursor wait
		showWhile: [Smalltalk
				allClassesDo: [:class | (class name includesSubstring: aString caseSensitive: caseSensitive)
						ifTrue: [aList add: class name]]].
	aList size > 0
		ifTrue: [ToolSet openClassListBrowser: aList asSet asSortedArray title: 'Classes whose names contain ' , aString , suffix]! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'!
browseClass: aBehavior
	| targetClass |
	targetClass := aBehavior isMeta
				ifTrue: [aBehavior theNonMetaClass]
				ifFalse: [aBehavior ].
	ToolSet browse: targetClass selector: nil! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'!
browseHierarchy: aBehavior
	| targetClass |
	targetClass := aBehavior isMeta
				ifTrue: [aBehavior theNonMetaClass]
				ifFalse: [aBehavior ].
	ToolSet browseHierarchy: targetClass selector: nil.! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 16:08'!
browseInstVarDefs: aClass
	"Copied from browseInstVarRefs.  Should be consolidated some day. 7/29/96 di
	7/30/96 sw: did the consolidation"
	"Change to use SystemNavigation  27 March 2003 sd"

	aClass chooseInstVarThenDo:	
		[:aVar | self browseAllStoresInto: aVar from: aClass]! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 16:08'!
browseInstVarRefs: aClass
	"1/16/96 sw: moved here from Browser so that it could be used from a variety of places.
	 7/30/96 sw: call chooseInstVarThenDo: to get the inst var choice"

	aClass chooseInstVarThenDo: 
		[:aVar | self browseAllAccessesTo: aVar from: aClass]! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 09:18'!
browseMessageList: messageList name: label 
	"Create and schedule a MessageSet browser on messageList."
	^ self   
		browseMessageList: messageList 
		name: label 
		autoSelect: nil! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'!
browseMessageList: messageList name: labelString autoSelect: autoSelectString
	| title aSize |
	"Create and schedule a MessageSet browser on the message list."

	messageList size = 0 ifTrue: 
		[^ self inform: 'There are no
' , labelString].

	title _ (aSize _ messageList size) > 1
		ifFalse:	[labelString]
		ifTrue:	[ labelString, ' [', aSize printString, ']'].

	ToolSet 
		browseMessageSet: messageList 
		name: title 
		autoSelect: autoSelectString! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'!
browseMethodsWhoseNamesContain: aString
	"Launch a tool which shows all methods whose names contain the given string; case-insensitive.
·	1/16/1996 sw, at the dawn of Squeak: this was the classic implementation that provided the underpinning for the 'method names containing it' (cmd-shift-W) feature that has always been in Squeak -- the feature that later inspired the MethodFinder (aka SelectorBrowser).
·	sw 7/27/2001:	Switched to showing a MessageNames tool rather than a message-list browser, if in Morphic."

	| aList |
	Smalltalk isMorphic
		ifFalse:
			[aList _ Symbol selectorsContaining: aString.
			aList size > 0 ifTrue:
				[self browseAllImplementorsOfList: aList asSortedCollection title: 'Methods whose names contain ''', aString, '''']]

		ifTrue:
			[ToolSet browseMessageNames: aString]
	! !

!SystemNavigation methodsFor: 'browse' stamp: 'yo 7/31/2004 18:40'!
browseMethodsWithLiteral: aString
	"Launch a browser on all methods that contain string literals with aString as a substring. Make the search case-sensitive or insensitive as dictated by the caseSensitive boolean parameter"

	self browseAllSelect:
			[:method |
				method hasLiteralSuchThat: [:lit |
					(lit isString and: [lit isSymbol not]) and:
					[lit = aString]]]
		name:  'Methods with string ', aString printString
		autoSelect: aString.
! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/20/2003 14:11'!
browseMethodsWithSourceString: aString 
	"SystemNavigation new browseMethodsWithSourceString: 'SourceString'"
	"Launch a browser on all methods whose source code contains aString as 
	a substring."
	| caseSensitive suffix |
	suffix _ (caseSensitive _ Sensor shiftPressed)
				ifTrue: [' (case-sensitive)']
				ifFalse: [' (use shift for case-sensitive)'].
	^ self
		browseMessageList: (self allMethodsWithSourceString: aString matchCase: caseSensitive)
		name: 'Methods containing ' , aString printString , suffix
		autoSelect: aString! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 22:28'!
browseMethodsWithString: aString
	"Launch a browser on all methods that contain string literals with aString as a substring. The search is case-insensitive, unless the shift key is pressed, in which case the search is case-sensitive."

	'string for testing'.
	^ self browseMethodsWithString: aString matchCase: Sensor shiftPressed

	"SystemNavigation new browseMethodsWithString: 'Testing' matchCase: false"
	"SystemNavigation new browseMethodsWithString: 'Testing' matchCase: true"! !

!SystemNavigation methodsFor: 'browse' stamp: 'bf 4/26/2005 11:44'!
browseMethodsWithString: aString matchCase: caseSensitive
	"Launch a browser on all methods that contain string literals with aString as a substring. Make the search case-sensitive or insensitive as dictated by the caseSensitive boolean parameter"

	self browseAllSelect:
			[:method |
				method  hasLiteralSuchThat: [:lit |
					(lit isString and: [lit isSymbol not]) and:
					[lit includesSubstring: aString caseSensitive: caseSensitive]]]
		name:  'Methods with string ', aString printString, (caseSensitive ifTrue: [' (case-sensitive)'] ifFalse: [' (case-insensitive)'])
		autoSelect: aString.
! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'!
browseObsoleteMethodReferences
	"Open a browser on all referenced behaviors that are obsolete"

	"SystemNavigation default browseObsoleteMethodReferences"

	| list |
	list := self obsoleteMethodReferences.
	self 
		browseMessageList: list
		name: 'Method referencing obsoletes'
		autoSelect: nil! !

!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 20:32'!
browseObsoleteReferences  
	"self new browseObsoleteReferences"

	| references |
	references _ OrderedCollection new.
	(LookupKey allSubInstances select:
		[:x | ((x value isKindOf: Behavior) and: ['AnOb*' match: x value name]) or:
		['AnOb*' match: x value class name]]) 
		do: [:x | references addAll: (self allCallsOn: x)].
	self  
		browseMessageList: references 
		name: 'References to Obsolete Classes'! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'!
browseUncommentedMethodsWithInitials: targetInitials
	"Browse uncommented methods whose initials (in the time-stamp, as logged to disk) match the given initials.  Present them in chronological order.  CAUTION: It will take several minutes for this to complete."
	"Time millisecondsToRun: [SystemNavigation default browseUncommentedMethodsWithInitials: 'jm']"

	| initials timeStamp methodReferences cm |
	methodReferences _ OrderedCollection new.
	self  allBehaviorsDo:
		[:aClass | aClass selectors do: [:sel |
			cm _ aClass compiledMethodAt: sel.
			timeStamp _ Utilities timeStampForMethod: cm.
			timeStamp isEmpty ifFalse:
				[initials _ timeStamp substrings first.
				initials first isDigit ifFalse:
					[((initials = targetInitials) and: [(aClass firstPrecodeCommentFor: sel) isNil])
						ifTrue:
							[methodReferences add: (MethodReference new
								setStandardClass: aClass 
								methodSymbol: sel)]]]]].

	ToolSet
		browseMessageSet: methodReferences 
		name: 'Uncommented methods with initials ', targetInitials
		autoSelect: nil! !

!SystemNavigation methodsFor: 'browse' stamp: 'al 12/7/2005 21:11'!
methodHierarchyBrowserForClass: aClass selector: sel
	"Create and schedule a message set browser on all implementors of the 
	currently selected message selector. Do nothing if no message is selected."
	"SystemNavigation default 
		methodHierarchyBrowserForClass: ParagraphEditor 
		selector: #isControlActive"
	
	| list tab stab aClassNonMeta isMeta theClassOrMeta |
	aClass ifNil: [^ self].
	aClass isTrait ifTrue: [^ self].
	sel ifNil: [^ self].
	aClassNonMeta _ aClass theNonMetaClass.
	isMeta _ aClassNonMeta ~~ aClass.
	list _ OrderedCollection new.
	tab _ ''.
	aClass allSuperclasses reverseDo:
		[:cl |
		(cl includesSelector: sel) ifTrue:
			[list addLast: tab , cl name, ' ', sel].
		tab _ tab , '  '].
	aClassNonMeta allSubclassesWithLevelDo:
		[:cl :level |
		theClassOrMeta _ isMeta ifTrue: [cl class] ifFalse: [cl].
		(theClassOrMeta includesSelector: sel) ifTrue:
			[stab _ ''.  1 to: level do: [:i | stab _ stab , '  '].
			list addLast: tab , stab , theClassOrMeta name, ' ', sel]]
	 	startingLevel: 0.
	self browseMessageList: list name: 'Inheritance of ' , sel

! !

!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'!
spawnHierarchyForClass: aClass selector: aSelector
	"Create and schedule a new class hierarchy browser on the requested class/selector."
	"SystemNavigation default spawnHierarchyForClass: SmallInteger selector: #hash"

	(aClass == nil)  ifTrue: [^ self].
	ToolSet browseHierarchy: aClass selector: aSelector
! !


!SystemNavigation methodsFor: 'query' stamp: 'al 1/9/2006 19:13'!
allBehaviorsDo: aBlock 
	"Evaluate the argument, aBlock, for each kind of Behavior in the system 
	(that is, Object and its subclasses and Traits).
	ar 7/15/1999: The code below will not enumerate any obsolete or anonymous
	behaviors for which the following should be executed:

		Smalltalk allObjectsDo:[:obj| obj isBehavior ifTrue:[aBlock value: obj]].

	but what follows is way faster than enumerating all objects."

	aBlock value: ProtoObject.
	ProtoObject allSubclassesDoGently: aBlock.		"don't bring in ImageSegments"

	"Classes outside the ProtoObject hierarchy"
	Class subclassesDo: [:aClass |
		(aClass == ProtoObject class
			or: [aClass isInMemory not
			or: [aClass isMeta not]]) ifFalse:
			["Enumerate the non-meta class and its subclasses"
			aBlock value: aClass soleInstance.
			aClass soleInstance allSubclassesDoGently: aBlock]].
	
	Trait allInstances , ClassTrait allInstances do: [:trait |
		aBlock value: trait]! !

!SystemNavigation methodsFor: 'query' stamp: 'md 8/27/2005 16:44'!
allCallsOn: aLiteral 
	"Answer a Collection of all the methods that call on aLiteral even deeply embedded in 
	literal array."
	"self new browseAllCallsOn: #open:label:."
	| aCollection special thorough aList byte |
	aCollection _ OrderedCollection new.
	special _ Smalltalk
				hasSpecialSelector: aLiteral
				ifTrueSetByte: [:b | byte _ b].
	thorough _ (aLiteral isSymbol)
				and: ["Possibly search for symbols imbedded in literal arrays"
					Preferences thoroughSenders].
	Cursor wait
		showWhile: [self
				allBehaviorsDo: [:class | 
					aList _ thorough
								ifTrue: [class
										thoroughWhichSelectorsReferTo: aLiteral
										special: special
										byte: byte]
								ifFalse: [class
										whichSelectorsReferTo: aLiteral
										special: special
										byte: byte].
					aList
						do: [:sel | sel isDoIt
								ifFalse: [aCollection
										add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
	^ aCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/18/2003 08:21'!
allCallsOn: firstLiteral and: secondLiteral
	"Answer a SortedCollection of all the methods that call on both aLiteral 
	and secondLiteral."

	| aCollection secondArray firstSpecial secondSpecial firstByte secondByte |
	self flag: #ShouldUseAllCallsOn:. "sd"
	aCollection _ SortedCollection new.
	firstSpecial _ Smalltalk hasSpecialSelector: firstLiteral ifTrueSetByte: [:b | firstByte _ b].
	secondSpecial _ Smalltalk hasSpecialSelector: secondLiteral ifTrueSetByte: [:b | secondByte _ b].
	Cursor wait showWhile: [
		self allBehaviorsDo: [:class |
			secondArray _ class 
				whichSelectorsReferTo: secondLiteral
				special: secondSpecial
				byte: secondByte.
			((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select:
				[:aSel | (secondArray includes: aSel)]) do:
						[:sel | 
							aCollection add: (
								MethodReference new
									setStandardClass: class 
									methodSymbol: sel
							)
						]
		]
	].
	^aCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'md 8/27/2005 17:17'!
allCallsOn: aSymbol from: aClass
	"Answer a SortedCollection of all the methods that call on aSymbol."

	| aSortedCollection special byte |
	aSortedCollection _ SortedCollection new.
	special _ aClass environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ].
	aClass withAllSubclassesDo: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel |
			sel isDoIt ifFalse: [
				aSortedCollection add: (
					MethodReference new
						setStandardClass: class 
						methodSymbol: sel
				)
			]
		]
	].
	^aSortedCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/17/2003 21:31'!
allClasses
	"currently returns all the classes defined in Smalltalk but could be customized 
	for dealing with environments and in such a case would return on really all the classes"

	^ Smalltalk allClasses

	! !

!SystemNavigation methodsFor: 'query' stamp: 'al 2/13/2006 21:52'!
allClassesAndTraits
	
	^ Smalltalk allClassesAndTraits

	! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/17/2003 21:31'!
allClassesDo: aBlock
	"currently returns all the classes defined in Smalltalk but could be customized 
	for dealing with environments and  in such a case would work on really all the classes"

	^ Smalltalk allClassesDo: aBlock

	! !

!SystemNavigation methodsFor: 'query' stamp: 'nb 5/6/2003 16:57'!
allClassesImplementing: aSelector  
	"Answer an Array of all classes that implement the message aSelector."

	| aCollection |
	aCollection _ ReadWriteStream on: Array new.
	self allBehaviorsDo:
		[:class | (class includesSelector: aSelector)
			ifTrue: [aCollection nextPut: class]].
	^ aCollection contents! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/18/2003 10:04'!
allGlobalRefs
	"Answer a set of symbols that may be refs to Global names.  In some sense we should only need the associations, but this will also catch, eg, HTML tag types."

	^ self allGlobalRefsWithout: {{}. {}}! !

!SystemNavigation methodsFor: 'query' stamp: 'yo 7/16/2003 15:18'!
allGlobalRefsWithout: classesAndMessagesPair 
	"Answer a set of symbols that may be refs to Global names. In some  
	sense we should only need the associations, but this will also catch, eg,  
	HTML tag types. This method computes its result in the absence of  
	specified classes and messages."
	"may be a problem if namespaces are introduced as for the moment  
	only Smalltalk is queried. sd 29/4/03"
	| globalRefs absentClasses absentSelectors |
	globalRefs _ IdentitySet new: CompiledMethod instanceCount.
	absentClasses _ classesAndMessagesPair first.
	absentSelectors _ classesAndMessagesPair second.
	self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:.
	"sd 29/04/03"
	Cursor execute
		showWhile: [Smalltalk classNames
				do: [:cName | ((absentClasses includes: cName)
						ifTrue: [{}]
						ifFalse: [{Smalltalk at: cName. (Smalltalk at: cName) class}])
						do: [:cl | (absentSelectors isEmpty
								ifTrue: [cl selectors]
								ifFalse: [cl selectors copyWithoutAll: absentSelectors])
								do: [:sel | "Include all capitalized symbols for good 
									measure"
									(cl compiledMethodAt: sel) literals
										do: [:m | 
											((m isSymbol)
													and: [m size > 0
															and: [m first canBeGlobalVarInitial]])
												ifTrue: [globalRefs add: m].
											(m isMemberOf: Array)
												ifTrue: [m
														do: [:x | ((x isSymbol)
																	and: [x size > 0
																			and: [x first canBeGlobalVarInitial]])
																ifTrue: [globalRefs add: x]]].
											m isVariableBinding
												ifTrue: [m key
														ifNotNil: [globalRefs add: m key]]]]]]].
	^ globalRefs! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 13:30'!
allImplementedMessages
	"Answer a Set of all the messages that are implemented in the system."
	^ self allImplementedMessagesWithout: {{}. {}}! !

!SystemNavigation methodsFor: 'query' stamp: 'al 1/13/2006 00:24'!
allImplementedMessagesWithout: classesAndMessagesPair 
	"Answer a Set of all the messages that are implemented in the system,  
	computed in the absence of the supplied classes and messages. Note this  
	reports messages that are in the absent selectors set."
	| messages absentClasses |
	messages _ IdentitySet new: CompiledMethod instanceCount.
	absentClasses _ classesAndMessagesPair first.
	self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:. "sd 29/04/03" 
	Cursor execute showWhile: [
		Smalltalk classNames , Smalltalk traitNames
			do: [:name | ((absentClasses includes: name)
				ifTrue: [{}]
				ifFalse: [{Smalltalk at: name. (Smalltalk at: name) classSide}])
					do: [:each | messages addAll: each selectors]]].
	^ messages! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/23/2003 22:31'!
allImplementorsOf: aSelector 
	"Answer a SortedCollection of all the methods that implement the message 
	aSelector."
	| aCollection |
	aCollection _ SortedCollection new.
	Cursor wait
		showWhile: [self
				allBehaviorsDo: [:class | (class includesSelector: aSelector)
						ifTrue: [aCollection
								add: (MethodReference new setStandardClass: class methodSymbol: aSelector)]]].
	^ aCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'apl 4/4/2005 17:59'!
allImplementorsOf: aSelector localTo: aClass 
	"Answer a SortedCollection of all the methods that implement the message  
	aSelector in, above, or below the given class."
	| cls aCollection |
	aCollection := SortedCollection new.
	cls := aClass theNonMetaClass.
	Cursor wait
		showWhile: [cls
				withAllSuperAndSubclassesDoGently: [:class | (class includesSelector: aSelector)
						ifTrue: [aCollection
								add: (MethodReference new setStandardClass: class methodSymbol: aSelector)]].
			cls class
				withAllSuperAndSubclassesDoGently: [:class | (class includesSelector: aSelector)
						ifTrue: [aCollection
								add: (MethodReference new setStandardClass: class methodSymbol: aSelector)]]].
	^ aCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'md 8/27/2005 16:42'!
allMethodsNoDoitsSelect: aBlock 
	"Like allSelect:, but strip out Doits"
	| aCollection |
	aCollection _ SortedCollection new.
	Cursor execute
		showWhile: [self
				allBehaviorsDo: [:class | class
						selectorsDo: [:sel | (sel isDoIt not
									and: [aBlock
											value: (class compiledMethodAt: sel)])
								ifTrue: [aCollection
										add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
	^ aCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:41'!
allMethodsSelect: aBlock 
	"Answer a SortedCollection of each method that, when used as the block  
	argument to aBlock, gives a true result."
	| aCollection |
	aCollection _ SortedCollection new.
	Cursor execute
		showWhile: [self
				allBehaviorsDo: [:class | class
						selectorsDo: [:sel | (aBlock
									value: (class compiledMethodAt: sel))
								ifTrue: [aCollection
										add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
	^ aCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'al 1/13/2006 11:59'!
allMethodsWithSourceString: aString matchCase: caseSensitive
	"Answer a SortedCollection of all the methods that contain, in source code, aString as a substring.  Search the class comments also"

	| list count adder |
	list _ Set new.
	adder _ [ :mrClass :mrSel | list add: ( MethodReference new
											setStandardClass: mrClass
											methodSymbol: mrSel)].
	'Searching all source code...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: Smalltalk classNames size
		during: [:bar |
			count _ 0.
			SystemNavigation default allBehaviorsDo: [:each |
				bar value: (count _ count + 1).
					each selectorsDo: [:sel | 
						((each sourceCodeAt: sel) findString: aString 
							startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [
								sel isDoIt ifFalse: [adder value: each value: sel]]].
					(each organization classComment asString findString: aString 
							startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [
								adder value: each value: #Comment]	]].
			^ list asSortedCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:53'!
allObjectsDo: aBlock 
	"Evaluate the argument, aBlock, for each object in the system 
	excluding SmallIntegers."
	| object |
	object _ self someObject.
	[0 == object]
		whileFalse: [aBlock value: object.
			object _ object nextObject]! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:53'!
allObjectsSelect: aBlock 
	"Evaluate the argument, aBlock, for each object in the system excluding 
	SmallIntegers. Return a collection af all objects for whom the value is 
	true. "
	^ Array
		streamContents: [:s | self
				allObjectsDo: [:object | (aBlock value: object)
						ifTrue: [s nextPut: object]]]! !

!SystemNavigation methodsFor: 'query' stamp: 'nk 7/3/2003 19:51'!
allPrimitiveMethods
	"Answer an OrderedCollection of all the methods that are implemented by primitives."
	| aColl method |
	aColl _ OrderedCollection new: 200.
	Cursor execute
		showWhile: [self allBehaviorsDo: [:class | class
						selectorsDo: [:sel | 
							method _ class compiledMethodAt: sel.
							method primitive ~= 0
								ifTrue: [aColl addLast: class name , ' ' , sel , ' ' , method primitive printString]]]].
	^ aColl! !

!SystemNavigation methodsFor: 'query' stamp: 'nk 7/3/2003 19:49'!
allPrimitiveMethodsInCategories: aList 
	"Answer an OrderedCollection of all the methods that are implemented by 
	primitives in the given categories. 1/26/96 sw"
	"SystemNavigation new allPrimitiveMethodsInCategories:  
	#('Collections-Streams' 'Files-Streams' 'Files-Abstract' 'Files-Macintosh')"

	| aColl method |
	aColl _ OrderedCollection new: 200.
	Cursor execute
		showWhile: [self
				allBehaviorsDo: [:aClass | (aList includes: (SystemOrganization categoryOfElement: aClass theNonMetaClass name asString) asString)
						ifTrue: [aClass
								selectorsDo: [:sel | 
									method _ aClass compiledMethodAt: sel.
									method primitive ~= 0
										ifTrue: [aColl addLast: aClass name , ' ' , sel , ' ' , method primitive printString]]]]].
	^ aColl! !

!SystemNavigation methodsFor: 'query' stamp: 'ar 9/7/2003 17:58'!
allReferencesToPool: aPool from: aClass
	"Answer all the references to variables from aPool"
	| ref list |
	list := OrderedCollection new.
	aClass withAllSubclassesDo:[:cls|
		cls selectorsAndMethodsDo:[:sel :meth|
			ref := meth literals detect:[:lit|
				lit isVariableBinding and:[(aPool bindingOf: lit key) notNil]
			] ifNone:[nil].
			ref ifNotNil:[
				list add:(MethodReference new setStandardClass: cls methodSymbol: sel)
			].
		].
	].
	^list! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 5/5/2003 09:18'!
allSelectorsWithAnyImplementorsIn: selectorList 
	"Answer the subset of the given list which represent method selectors 
	which have at least one implementor in the system."
	| good |
	good _ OrderedCollection new.
	self allBehaviorsDo: [:class | selectorList
				do: [:aSelector | (class includesSelector: aSelector)
						ifTrue: [good add: aSelector]]].
	^ good asSet asSortedArray" 
	SystemNavigation new selectorsWithAnyImplementorsIn: #( contents 
	contents: nuts)
	"! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:12'!
allSentMessages
	"Answer the set of selectors which are sent somewhere in the system."
	^ self  allSentMessagesWithout: {{}. {}}! !

!SystemNavigation methodsFor: 'query' stamp: 'al 1/13/2006 00:44'!
allSentMessagesWithout: classesAndMessagesPair 
	"Answer the set of selectors which are sent somewhere in the system,  
	computed in the absence of the supplied classes and messages."
	| sent absentClasses absentSelectors |
	sent _ IdentitySet new: CompiledMethod instanceCount.
	absentClasses _ classesAndMessagesPair first.
	absentSelectors _ classesAndMessagesPair second.
	self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:.
	"sd 29/04/03"
	Cursor execute showWhile: [
		Smalltalk classNames , Smalltalk traitNames do: [:name |
			((absentClasses includes: name)
				ifTrue: [{}]
				ifFalse: [{Smalltalk at: name. (Smalltalk at: name) classSide}])
					do: [:each | (absentSelectors isEmpty
						ifTrue: [each selectors]
						ifFalse: [each selectors copyWithoutAll: absentSelectors])
						do: [:sel | "Include all sels, but not if sent by self"
							(each compiledMethodAt: sel) literals
								do: [:m | 
									(m isSymbol)
										ifTrue: ["might be sent"
											m == sel
												ifFalse: [sent add: m]].
									(m isMemberOf: Array)
										ifTrue: ["might be performed"
											m
												do: [:x | (x isSymbol)
														ifTrue: [x == sel
																ifFalse: [sent add: x]]]]]]]].
			"The following may be sent without being in any literal frame"
			1
				to: Smalltalk specialSelectorSize
				do: [:index | sent
						add: (Smalltalk specialSelectorAt: index)]].
	Smalltalk presumedSentMessages
		do: [:sel | sent add: sel].
	^ sent! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:12'!
allUnSentMessages
	"SystemNavigation new allUnSentMessages"
	"Answer the set of selectors that are implemented by some object in the  
	system but not sent by any."
	^ self allUnSentMessagesWithout: {{}. {}}! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:13'!
allUnSentMessagesIn: selectorSet 
	"Answer the subset of selectorSet which are not sent anywhere in the 
	system. "
	^ selectorSet copyWithoutAll: self allSentMessages! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 19:19'!
allUnSentMessagesWithout: classesAndMessagesPair 
	"Answer the set of selectors that are implemented but not sent, computed  
	in the absence of the supplied classes and messages."
	^ (self  allImplementedMessagesWithout: classesAndMessagesPair)
		copyWithoutAll: (self  allSentMessagesWithout: classesAndMessagesPair)! !

!SystemNavigation methodsFor: 'query' stamp: 'nk 7/3/2003 16:13'!
allUnimplementedCalls
	"Answer an Array of each message that is sent by an expression in a  
	method but is not implemented by any object in the system."
	| aStream secondStream all |
	all _ self allImplementedMessages.
	aStream _ WriteStream
				on: (Array new: 50).
	Cursor execute
		showWhile: [self
				allBehaviorsDo: [:cl | cl
						selectorsDo: [:sel | 
							secondStream _ WriteStream
										on: (String new: 5).
							(cl compiledMethodAt: sel) messages
								do: [:m | (all includes: m)
										ifFalse: [secondStream nextPutAll: m;
												 space]].
							secondStream position = 0
								ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]].
	^ aStream contents! !

!SystemNavigation methodsFor: 'query' stamp: 'yo 7/16/2003 14:19'!
allUnimplementedNonPrimitiveCalls
	"Answer an Array of each message that is sent by an expression in a  
	method but is not implemented by any object in the system."
	| aStream secondStream all meth |
	all _ self systemNavigation allImplementedMessages.
	aStream _ WriteStream
				on: (Array new: 50).
	Cursor execute
		showWhile: [self systemNavigation
				allBehaviorsDo: [:cl | cl
						selectorsDo: [:sel | 
							secondStream _ WriteStream
										on: (String new: 5).
							meth _ cl compiledMethodAt: sel.
							meth primitive = 0 ifTrue: [
								meth messages
									do: [:m | (all includes: m)
											ifFalse: [secondStream nextPutAll: m;
													 space]].
								secondStream position = 0
									ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]]].
	^ aStream contents! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 13:07'!
allUnreferencedClassVariablesOf: aClass
	"Answer a list of the names of all the receiver's unreferenced class  
	vars, including those defined in superclasses"
	| aList |
	aList _ OrderedCollection new.
	aClass withAllSuperclasses
		reverseDo: [:aSuperClass | aSuperClass classVarNames
				do: [:var | (self allCallsOn: (aSuperClass classPool associationAt: var)) isEmpty
						ifTrue: [aList add: var]]].
	^ aList! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 19:06'!
allUnusedClassesWithout: classesAndMessagesPair 
	"Enumerates all classes in the system and returns a list of those that are 
	apparently unused. A class is considered in use if it (a) has subclasses  
	or (b) is referred to by some method or (c) has its name in use as a  
	literal."
	"SystemNavigation new unusedClasses"

	| unused cl |
	unused _ Smalltalk classNames asIdentitySet
				copyWithoutAll: (self allGlobalRefsWithout: classesAndMessagesPair).
	^ unused
		reject: [:cName | 
			cl _ Smalltalk at: cName.
			cl subclasses isEmpty not
				or: [cl inheritsFrom: FileDirectory]]! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 1/16/2004 21:01'!
hierarchyOfClassesSurrounding: aClass
	"Answer a list of classes in the hierarchy both above and below the given class"
	"SystemNavigation default hierarchyOfClassesSurrounding: StringHolder"
	
	| list aClassNonMeta isMeta theClassOrMeta |
	aClass ifNil: [^ OrderedCollection new].
	aClass ifNil: [^ self].
	aClassNonMeta _ aClass theNonMetaClass.
	isMeta _ aClassNonMeta ~~ aClass.
	list _ OrderedCollection new.
	aClass allSuperclasses reverseDo:
		[:cl | list addLast: cl].
	aClassNonMeta allSubclassesWithLevelDo:
		[:cl :level |
		theClassOrMeta _ isMeta ifTrue: [cl class] ifFalse: [cl].
		list addLast: theClassOrMeta]
	 	startingLevel: 0.
	^ list

! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 1/16/2004 21:03'!
hierarchyOfImplementorsOf: aSelector forClass: aClass
	"Answer a list of classes in the hierarchy both above and below the given class which implement the given selector."
	"SystemNavigation default hierarchyOfImplementorsOf: #contents forClass: StringHolder"

	^ (self hierarchyOfClassesSurrounding: aClass) select:
		[:cl | cl includesSelector: aSelector]
! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/18/2003 10:44'!
isThereAnImplementorOf: aSelector 
	"Answer true if there is at least one implementor of the selector found  
	in the system, false if there are no implementors"
	"self new isThereAnImplementorOf: #contents.  
	self new isThereAnImplementorOf: #nobodyImplementsThis."
	self 
		allBehaviorsDo: [:class | (class includesSelector: aSelector)
				ifTrue: [^ true]].
	^ false! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/20/2003 14:27'!
numberOfImplementorsOf: aSelector 
	"Answer a count of the implementors of the given selector found in the  
	system"
	"self new numberOfImplementorsOf: #contents.  
	self new numberOfImplementorsOf: #nobodyImplementsThis.  
	self new numberOfimplementorsOf: #numberOfImplementorsOf:."
	| aCount |
	aCount _ 0.
	self
		allBehaviorsDo: [:class | (class includesSelector: aSelector)
				ifTrue: [aCount _ aCount + 1]].
	^ aCount! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 9/23/2004 22:03'!
obsoleteBehaviors
	"SystemNavigation default obsoleteBehaviors inspect"
	"Find all obsolete behaviors including meta classes"

	| obs |
	obs _ OrderedCollection new.
	Smalltalk garbageCollect.
	self 
		allObjectsDo: [:cl | (cl isBehavior
					and: [cl isObsolete])
				ifTrue: [obs add: cl]].
	^ obs asArray! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 9/23/2004 22:06'!
obsoleteClasses   

	"SystemNavigation default obsoleteClasses inspect"
	"NOTE:  Also try inspecting comments below"
	| obs c |
	obs _ OrderedCollection new.  Smalltalk garbageCollect.
	Metaclass allInstancesDo:
		[:m | c _ m soleInstance.
		(c ~~ nil and: ['AnOb*' match: c name asString])
			ifTrue: [obs add: c]].
	^ obs asArray

"Likely in a ClassDict or Pool...
(Association allInstances select: [:a | (a value isKindOf: Class) and: ['AnOb*' match: a value name]]) asArray
"
"Obsolete class refs or super pointer in last lit of a method...
| n l found |
Smalltalk browseAllSelect:
	[:m | found _ false.
	1 to: m numLiterals do:
		[:i | (((l _ m literalAt: i) isMemberOf: Association)
				and: [(l value isKindOf: Behavior)
				and: ['AnOb*' match: l value name]])
			ifTrue: [found _ true]].
	found]
"! !

!SystemNavigation methodsFor: 'query' stamp: 'ar 9/27/2005 18:03'!
obsoleteMethodReferences
	"SystemNavigation default obsoleteMethodReferences"

	"Open a browser on all referenced behaviors that are obsolete"

	| obsClasses obsRefs references |
	references := WriteStream on: Array new.
	obsClasses := self obsoleteBehaviors.
	'Scanning for methods referencing obsolete classes' 
		displayProgressAt: Sensor cursorPoint
		from: 1
		to: obsClasses size
		during: 
			[:bar | 
			obsClasses keysAndValuesDo: 
					[:index :each | 
					bar value: index.
					obsRefs := Utilities pointersTo: each except: obsClasses.
					obsRefs do: 
							[:ref | 
							"Figure out if it may be a global"

							(ref isVariableBinding and: [ref key isString	"or Symbol"]) 
								ifTrue: 
									[(Utilities pointersTo: ref) do: 
											[:meth | 
											(meth isKindOf: CompiledMethod) 
												ifTrue: [meth methodReference ifNotNilDo: [:mref | references nextPut: mref]]]]]]].
	^references contents! !

!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 15:17'!
selectAllMethods: aBlock 
	"Answer a SortedCollection of each method that, when used as the block  
	argument to aBlock, gives a true result."
	| aCollection |
	aCollection _ SortedCollection new.
	Cursor execute
		showWhile: [self
				allBehaviorsDo: [:class | class
						selectorsDo: [:sel | (aBlock
									value: (class compiledMethodAt: sel))
								ifTrue: [aCollection
										add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
	^ aCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'md 8/27/2005 17:17'!
selectAllMethodsNoDoits: aBlock 
	"Like allSelect:, but strip out Doits"
	| aCollection |
	aCollection _ SortedCollection new.
	Cursor execute
		showWhile: [self
				allBehaviorsDo: [:class | class
						selectorsDo: [:sel | (sel isDoIt not
									and: [aBlock
											value: (class compiledMethodAt: sel)])
								ifTrue: [aCollection
										add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]].
	^ aCollection! !

!SystemNavigation methodsFor: 'query' stamp: 'md 7/19/2004 16:03'!
unimplemented
	"Answer an Array of each message that is sent by an expression in a method but is not implemented by any object in the system."

	| all unimplemented entry |
	all _ IdentitySet new: Symbol instanceCount * 2.
	Cursor wait showWhile: 
		[self allBehaviorsDo: [:cl | cl selectorsDo: [:aSelector | all add: aSelector]]].

	unimplemented _ IdentityDictionary new.
	Cursor execute showWhile: [
		self allBehaviorsDo: [:cl |
			 cl selectorsDo: [:sel |
				(cl compiledMethodAt: sel) messages do: [:m |
					(all includes: m) ifFalse: [
						entry _ unimplemented at: m ifAbsent: [Array new].
						entry _ entry copyWith: (cl name, '>', sel).
						unimplemented at: m put: entry]]]]].
	^ unimplemented
! !


!SystemNavigation methodsFor: 'ui' stamp: 'rbb 2/18/2005 14:48'!
confirmRemovalOf: aSelector on: aClass 
	"Determine if it is okay to remove the given selector. Answer 1 if it  
	should be removed, 2 if it should be removed followed by a senders  
	browse, and 3 if it should not be removed."
	| count answer caption allCalls |
	allCalls _ self allCallsOn: aSelector.
	(count _ allCalls size) == 0
		ifTrue: [^ 1].
	"no senders -- let the removal happen without warning"
	count == 1
		ifTrue: [(allCalls first actualClass == aClass
					and: [allCalls first methodSymbol == aSelector])
				ifTrue: [^ 1]].
	"only sender is itself"
	caption _ 'This message has ' , count printString , ' sender'.
	count > 1
		ifTrue: [caption _ caption copyWith: $s].
	answer _ UIManager default 
		chooseFrom: #('Remove it'
				'Remove, then browse senders'
				'Don''t remove, but show me those senders'
				'Forget it -- do nothing -- sorry I asked') title: caption.
	answer == 3
		ifTrue: [self
				browseMessageList: allCalls
				name: 'Senders of ' , aSelector
				autoSelect: aSelector keywords first].
	answer == 0
		ifTrue: [answer _ 3].
	"If user didn't answer, treat it as cancel"
	^ answer min: 3! !

!SystemNavigation methodsFor: 'ui' stamp: 'sd 4/15/2003 15:34'!
showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock
	"Show a sorted menu of the given selectors, preceded by firstItem, and all
	abbreviated to 40 characters.  Evaluate choiceBlock if a message is chosen."

	^ self showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock withCaption: nil! !

!SystemNavigation methodsFor: 'ui' stamp: 'edc 11/8/2005 10:58'!
showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock withCaption: aCaption
	"Show a sorted menu of the given selectors, preceded by firstItem, and all abbreviated to 40 characters.  Use aCaption as the menu title, if it is not nil.  Evaluate choiceBlock if a message is chosen."

	| index menuLabels sortedList |
	sortedList _ selectorCollection asSortedCollection.
	menuLabels _ String streamContents: 
		[:strm | strm nextPutAll: (firstItem contractTo: 40).
		sortedList do: [:sel | strm cr; nextPutAll: (sel contractTo: 40)]].
	index _ UIManager default chooseFrom: (menuLabels substrings) lines: #(1).
	index = 1 ifTrue: [choiceBlock value: firstItem].
	index > 1 ifTrue: [choiceBlock value: (sortedList at: index - 1)]! !


!SystemNavigation methodsFor: '*Multilingual-Editor' stamp: 'sd 12/18/2004 18:17'!
allSelect: aBlock 
	"Answer a SortedCollection of each method that, when used as 
	the block  
	argument to aBlock, gives a true result."
	| aCollection |
	aCollection := SortedCollection new.
	Cursor execute
		showWhile: [self
				allBehaviorsDo: [:class | class
						selectorsDo: [:sel | (aBlock
									value: (class compiledMethodAt: sel))
								ifTrue: [aCollection add: class name , ' ' , sel]]]].
	^ aCollection! !


!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:46'!
browserClass
	browserClass ifNil: [browserClass := self defaultBrowserClass].
	^browserClass! !

!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:46'!
browserClass: aBrowserClass
	browserClass := aBrowserClass! !

!SystemNavigation methodsFor: '*tools-browser' stamp: 'nk 2/25/2005 09:42'!
defaultBrowserClass
	^SystemBrowser default! !

!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:49'!
defaultHierarchyBrowserClass
	^self class environment at: #HierarchyBrowser ifAbsent:[]! !

!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:50'!
hierarchyBrowserClass
	hierarchyBrowserClass ifNil: [hierarchyBrowserClass := self defaultHierarchyBrowserClass].
	^hierarchyBrowserClass! !

!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:47'!
hierarchyBrowserClass: aBrowserClass
	hierarchyBrowserClass := aBrowserClass! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemNavigation class
	instanceVariableNames: ''!

!SystemNavigation class methodsFor: 'accessing' stamp: 'dvf 8/23/2003 12:25'!
default
	Default isNil ifTrue: [Default _ self new].
	^Default! !
Categorizer subclass: #SystemOrganizer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!SystemOrganizer commentStamp: '<historical>' prior: 0!
My instances provide an organization for the classes in the system, just as a ClassOrganizer organizes the messages within a class. The only difference is the methods for fileIn/Out.!


!SystemOrganizer methodsFor: 'accessing' stamp: 'ab 2/10/2005 16:33'!
addCategory: newCategory
	| r |
	r := super addCategory: newCategory.
	SystemChangeNotifier uniqueInstance classCategoryAdded: newCategory.
	^ r! !

!SystemOrganizer methodsFor: 'accessing' stamp: 'ab 2/10/2005 16:36'!
removeCategory: cat 
	| r |
	r := super removeCategory: cat.
	SystemChangeNotifier uniqueInstance classCategoryRemoved: cat.
	^ r! !

!SystemOrganizer methodsFor: 'accessing' stamp: 'ab 2/10/2005 16:47'!
renameCategory: oldCatString toBe: newCatString
	| r |
	r := super renameCategory: oldCatString toBe: newCatString.
	SystemChangeNotifier uniqueInstance 
		classCategoryRenamedFrom: oldCatString to: newCatString.
	^ r! !


!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 20:22'!
fileOut  "SystemOrganization fileOut"

	| internalStream |
	internalStream _ WriteStream on: (String new: 30000).
	internalStream nextPutAll: 'SystemOrganization changeFromCategorySpecs: #('; cr;
		print: SystemOrganization;  "ends with a cr"
		nextPutAll: ')!!'; cr.

	FileStream writeSourceCodeFrom: internalStream baseName: (FileDirectory default nextNameFor: 'SystemOrganization' extension: 'st') isSt: true useHtml: false
! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 19:01'!
fileOutCategory: category 
	"Store on the file named category (a string) concatenated with '.st' all the 
	classes associated with the category."
	^ self fileOutCategory: category asHtml: false! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 20:22'!
fileOutCategory: category asHtml: useHtml
	"FileOut all the classes in the named system category."
	| internalStream |
	internalStream _ WriteStream on: (String new: 1000).
	self fileOutCategory: category on: internalStream initializing: true.

	FileStream writeSourceCodeFrom: internalStream baseName: category isSt: true useHtml: useHtml.
! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:28'!
fileOutCategory: category on: aFileStream 
	"Store on the file associated with aFileStream, all the classes associated 
	with the category and any requested shared pools."
	^self fileOutCategory: category on: aFileStream initializing: true! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'al 4/25/2004 11:41'!
fileOutCategory: category on: aFileStream initializing: aBool
	"Store on the file associated with aFileStream, all the traits and classes associated 
	with the category and any requested shared pools in the right order."

	| first poolSet tempClass classes traits |
	traits _ self orderedTraitsIn: category.
	classes _ self superclassOrder: category.
	poolSet _ Set new.
	classes do:  [:class | class sharedPools do: [:eachPool | poolSet add: eachPool]].
	poolSet size > 0 ifTrue: [
		tempClass _ Class new.
		tempClass shouldFileOutPools ifTrue: [
			poolSet _ poolSet select: [:aPool |
				tempClass shouldFileOutPool: (Smalltalk keyAtIdentityValue: aPool)].
			poolSet do: [:aPool | tempClass fileOutPool: aPool onFileStream: aFileStream]]].
	first _ true.
	traits, classes do: [:each | 
		first
			ifTrue: [first _ false]
			ifFalse: [aFileStream cr; nextPut: Character newPage; cr].
		each
			fileOutOn: aFileStream
			moveSource: false
			toFile: 0
			initializing: false].
	aBool ifTrue: [classes do: [:cls | cls fileOutInitializerOn: aFileStream]].! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'tk 9/28/2000 15:50'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

self == SystemOrganization ifTrue: [
	dp _ DiskProxy global: #SystemOrganization selector: #yourself args: #().
	refStrm replace: self with: dp.
	^ dp].
^ self
! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 19:06'!
orderedTraitsIn: category 
	"Answer an OrderedCollection containing references to the traits in the 
	category whose name is the argument, category (a string). The traits 
	are ordered so they can be filed in."

	| behaviors traits |
	behaviors _ (self listAtCategoryNamed: category asSymbol) 
			collect: [:title | Smalltalk at: title].
	traits _ behaviors reject: [:each | each isBehavior].
	traits _ traits asSortedCollection: [:t1 :t2 |
		(t2 traitComposition allTraits includes: t1)
			or: [(t1 traitComposition allTraits includes: t2) not]].
	^traits asArray! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 19:06'!
superclassOrder: category 
	"Answer an OrderedCollection containing references to the classes in the 
	category whose name is the argument, category (a string). The classes 
	are ordered with superclasses first so they can be filed in."

	| behaviors classes |
	behaviors _ (self listAtCategoryNamed: category asSymbol) 
			collect: [:title | Smalltalk at: title].
	classes _ behaviors select: [:each | each isBehavior].
	^ChangeSet superclassOrder: classes! !


!SystemOrganizer methodsFor: 'query' stamp: 'dtl 8/26/2004 11:18'!
commentInventory: categoryName

	"SystemOrganization commentInventory: 'Morphic*'"

	| classes commentedClasses |
	classes _ OrderedCollection new.
	self categories withIndexCollect: [:cat :idx |
		(categoryName match: cat)
			ifTrue: [classes addAll: (self listAtCategoryNumber: idx)]
			ifFalse: [nil]].
	commentedClasses _ classes select: [:catCls | (Smalltalk at: catCls) hasComment].
	^ 'There are ' , classes size asString , ' classes in ' , categoryName ,
		' of which ' , commentedClasses size asString , ' have comments and ',
		(classes size - commentedClasses size) asString , ' do not yet have comments.'
! !

!SystemOrganizer methodsFor: 'query' stamp: 'dtl 8/26/2004 11:23'!
uncommentedClassesIn: categoryName

	"SystemOrganization uncommentedClassesIn: 'Morphic*'"

	| classes |
	classes _ OrderedCollection new.
	self categories withIndexCollect: [:cat :idx |
		(categoryName match: cat)
			ifTrue: [classes addAll: (self listAtCategoryNumber: idx)]
			ifFalse: [nil]].
	^ (classes collect: [:clsName | Smalltalk at: clsName]
		thenSelect: [:cls | cls hasComment not]) asArray
! !


!SystemOrganizer methodsFor: 'remove' stamp: 'di 3/3/2001 16:07'!
categoriesMatching: matchString
	"Return all matching categories"
	^ self categories select: [:c | matchString match: c]! !

!SystemOrganizer methodsFor: 'remove' stamp: 'di 3/3/2001 16:08'!
removeCategoriesMatching: matchString
	"Remove all matching categories with their classes"
	(self categoriesMatching: matchString) do:
		[:c | self removeSystemCategory: c]! !

!SystemOrganizer methodsFor: 'remove' stamp: 'jm 5/20/1998 19:38'!
removeMissingClasses
	"Remove any class names that are no longer in the Smalltalk dictionary. Used for cleaning up after garbage collecting user-generated classes."
	"SystemOrganization removeMissingClasses"

	elementArray copy do: [:el |
		(Smalltalk includesKey: el) ifFalse: [self removeElement: el]].
! !

!SystemOrganizer methodsFor: 'remove' stamp: 'al 4/25/2004 11:38'!
removeSystemCategory: category
	"remove all the classes and traits associated with the category"

	 (self orderedTraitsIn: category) , (self superclassOrder: category)
		reverseDo: [:each | each removeFromSystem].

	self removeCategory: category.
! !



!SystemOrganizer methodsFor: 'private' stamp: 'rw 7/31/2003 17:23'!
ifClassOrganizerDo: aBlock
	"Do nothing, since this is not a class organizer"! !


!SystemOrganizer methodsFor: '*ob-standard-testing' stamp: 'cwp 9/18/2004 23:58'!
isClassOrganizer
	^ false! !
RectangleMorph subclass: #SystemProgressBarMorph
	instanceVariableNames: 'barSize'
	classVariableNames: 'BarHeight BarWidth FillColor'
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!SystemProgressBarMorph commentStamp: 'laza 4/9/2004 11:47' prior: 0!
Instances of this morph get used by SystemProgressMoprh to quickly display a progress bar.!


!SystemProgressBarMorph methodsFor: 'accessing' stamp: 'laza 4/9/2004 10:37'!
barSize: anInteger
	barSize _ anInteger.
	self changed.! !


!SystemProgressBarMorph methodsFor: 'drawing' stamp: 'dgd 4/3/2006 12:09'!
drawOn: aCanvas
	| area |
	super drawOn: aCanvas.
	
	barSize > 0 ifTrue: [
		area := self innerBounds.
		area := area origin extent: barSize-2@area extent y.
		aCanvas fillRectangle: area color: Preferences menuTitleColor.
	].
! !


!SystemProgressBarMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 12:10'!
initialize
	super initialize.

	self
		borderWidth: 1;
		borderColor: Preferences menuBorderColor;
		color: Preferences menuColor muchLighter.
		
	barSize := 0.
! !
RectangleMorph subclass: #SystemProgressMorph
	instanceVariableNames: 'activeSlots bars labels font lock'
	classVariableNames: 'BarHeight BarWidth UniqueInstance'
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!SystemProgressMorph commentStamp: '<historical>' prior: 0!
An single instance of this morph class is used to display progress while the system is busy, eg. while it receives code updates or does a fileIn. To give the user progress information you don't deal directly with SystemProgressMorph. You keep on using the well established way of progress notification, that has been a long time in the system, is widely used and does not depend on the existence of SystemProgressMorph. For more information on this look at the example in this class or look at the comment of the method displayProgressAt:from:to:during: in class String.

SystemProgressMorph is not meant to be used as a component inside other morphs.

You can switch back to the old style of progress display by disabling the morphicProgressStyle setting in the morphic section of the preferences.!
]style[(461 8 51 33 233 11 1)f2,f2LSystemProgressMorph class example;,f2,f2LString displayProgressAt:from:to:during:;,f2,f2dPreferences openFactoredPanel;;,f2!


!SystemProgressMorph methodsFor: 'dropping/grabbing' stamp: 'laza 4/20/2004 11:38'!
slideToTrash: evt
	"If the user needs to dismiss a progress morph by hand, start with a 
	fresh instance next time."
	self dismissViaHalo! !


!SystemProgressMorph methodsFor: 'initialization' stamp: 'laza 7/29/2004 10:26'!
close: aBlock
	| slot |
	slot _ aBlock value: SmallInteger maxVal. "This should prevent a redraw"
	self freeSlot: slot
	
! !

!SystemProgressMorph methodsFor: 'initialization' stamp: 'laza 4/20/2004 10:40'!
initialize
	super initialize.
	activeSlots _ 0.
	bars _ Array new: 10.
	labels _ Array new: 10.
	font _ Preferences windowTitleFont.
	lock _ Semaphore forMutualExclusion.
	self setDefaultParameters;
		setProperty: #morphicLayerNumber toValue: self morphicLayerNumber;
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		cellPositioning: #topCenter;
		cellInset: 5;
		listCentering: #center;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		layoutInset:4@4.! !

!SystemProgressMorph methodsFor: 'initialization' stamp: 'laza 4/18/2004 21:31'!
morphicLayerNumber
	"progress morphs are behind menus and balloons, but in front of most other stuff"
	^self valueOfProperty: #morphicLayerNumber ifAbsent: [12].
! !

!SystemProgressMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 11:09'!
setDefaultParameters
	"change the receiver's appareance parameters"

	| colorFromMenu worldColor menuColor |

	colorFromMenu := Preferences menuColorFromWorld
									and: [Display depth > 4]
									and: [(worldColor := self currentWorld color) isColor].

	menuColor := colorFromMenu
						ifTrue: [worldColor luminance > 0.7
										ifTrue: [worldColor mixed: 0.85 with: Color black]
										ifFalse: [worldColor mixed: 0.4 with: Color white]]
						ifFalse: [Preferences menuColor].

	self color: menuColor.
	
	Preferences roundedMenuCorners
		ifTrue: [self useRoundedCorners].
	self borderWidth: Preferences menuBorderWidth.

	Preferences menuAppearance3d ifTrue: [
		self borderStyle: BorderStyle thinGray.
		self
			addDropShadow;
			shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666);
			shadowOffset: 1 @ 1
	]
	ifFalse: [
		| menuBorderColor |
		menuBorderColor := colorFromMenu
										ifTrue: [worldColor muchDarker]
										ifFalse: [Preferences menuBorderColor].
		self borderColor: menuBorderColor.
	].

	self
		updateColor: self
		color: self color
		intensity: 1.! !

!SystemProgressMorph methodsFor: 'initialization' stamp: 'jrp 7/6/2005 21:45'!
updateColor: aMorph color: aColor intensity: anInteger 
	"update the apareance of aMorph"
	| fill |
	Preferences gradientMenu
		ifFalse: [^ self].

	fill _ GradientFillStyle ramp: {0.0 -> Color white. 1 ->aColor}.
	fill radial: false;
		origin: aMorph topLeft;
		direction: 0 @ aMorph height.
	aMorph fillStyle: fill! !


!SystemProgressMorph methodsFor: 'submorphs-add/remove' stamp: 'laza 4/20/2004 12:01'!
dismissViaHalo
	self class reset! !


!SystemProgressMorph methodsFor: 'private' stamp: 'laza 5/28/2004 06:03'!
freeSlot: number
	number > 0 ifTrue: [
		lock critical: [
			(bars at: number) delete.
			(labels at: number) delete.
			activeSlots _ activeSlots - 1.
			activeSlots = 0
				ifTrue: [self delete]
				ifFalse: [self align: self fullBounds center with: Display boundingBox center]]]! !

!SystemProgressMorph methodsFor: 'private' stamp: 'laza 7/29/2004 10:30'!
label: shortDescription min: minValue max: maxValue
	| slot range newBarSize barSize lastRefresh |
	((range _ maxValue - minValue) <= 0 or: [(slot _ self nextSlotFor: shortDescription) = 0])
		ifTrue: [^[:barVal| 0 ]].
	self openInWorld.
	self align: self fullBounds center with: Display boundingBox center.
	barSize _ -1. "Enforces a inital draw of the morph"
	lastRefresh _ 0.
	^[:barVal | 
		(barVal between: minValue and: maxValue) ifTrue: [
			newBarSize _ (barVal - minValue / range * BarWidth) truncated.
			newBarSize = barSize ifFalse: [
				barSize _ newBarSize.
				(bars at: slot) barSize: barSize.
				Time primMillisecondClock - lastRefresh > 25 ifTrue: [
					self currentWorld displayWorld.
					lastRefresh _ Time primMillisecondClock]]].
		slot]
! !

!SystemProgressMorph methodsFor: 'private' stamp: 'laza 4/9/2004 10:23'!
nextSlotFor: shortDescription
	| bar slots label |
	lock critical: [
		slots _ bars size.
		activeSlots = slots ifTrue: [^0].
		activeSlots _ activeSlots + 1.
		1 to: slots do: [:index |
			bar _ (bars at: index).
			bar ifNil: [
				bar _ bars at: index put: (SystemProgressBarMorph new extent: BarWidth@BarHeight).
				label _ labels at: index put: (StringMorph contents: shortDescription font: font).
				self
					addMorphBack: label;
					addMorphBack: bar.
				^index].
			bar owner ifNil: [
				bar _ bars at: index.
				label _ labels at: index.
				self
					addMorphBack: (label contents: shortDescription);
					addMorphBack: (bar barSize: 0).
				^index]]]
		! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemProgressMorph class
	instanceVariableNames: ''!

!SystemProgressMorph class methodsFor: 'class initialization' stamp: 'laza 4/10/2004 20:29'!
initialize
	"SystemProgressMorph initialize"
	BarHeight _ 16.
	BarWidth _ 200.
	self reset! !


!SystemProgressMorph class methodsFor: 'examples' stamp: 'laza 4/9/2004 10:49'!
example
	"SystemProgressMorph example"
	'Progress' 
		displayProgressAt: Display center
		from: 0 to: 1000
		during: [:bar | 0 to: 1000 do: [:i | bar value: i. (Delay forMilliseconds: 2) wait]]
! !


!SystemProgressMorph class methodsFor: 'instance creation' stamp: 'laza 4/9/2004 10:51'!
close: aBlock
	UniqueInstance ifNotNil: [UniqueInstance close: aBlock]! !

!SystemProgressMorph class methodsFor: 'instance creation' stamp: 'laza 4/18/2004 21:16'!
label: shortDescription min: minValue max: maxValue
	UniqueInstance ifNil: [UniqueInstance _ super new].
	^UniqueInstance label: (shortDescription contractTo: 100) min: minValue asFloat max: maxValue asFloat! !

!SystemProgressMorph class methodsFor: 'instance creation' stamp: 'laza 4/6/2004 21:17'!
new
	^self shouldNotImplement! !

!SystemProgressMorph class methodsFor: 'instance creation' stamp: 'laza 4/9/2004 10:35'!
reset
	"SystemProgressMorph reset"
	UniqueInstance ifNotNil: [UniqueInstance delete].
	UniqueInstance _ nil.! !
PhraseTileMorph subclass: #SystemQueryPhrase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!SystemQueryPhrase methodsFor: 'access' stamp: 'sw 8/3/1998 14:50'!
isBoolean
	^ true! !


!SystemQueryPhrase methodsFor: 'code generation' stamp: 'sw 8/3/1998 14:51'!
storeCodeOn: aStream indent: tabCount
	submorphs first storeCodeOn: aStream indent: tabCount! !


!SystemQueryPhrase methodsFor: 'initialization' stamp: 'sw 9/26/2001 03:04'!
initialize
	"Initialize the receiver.  In this case we primarily seek to undo the damage done by inherited implementors of #initialize"

	super initialize.
	self removeAllMorphs.
	resultType _ #Boolean.
	self vResizing: #shrinkWrap! !


!SystemQueryPhrase methodsFor: 'miscellaneous' stamp: 'sw 8/3/1998 14:48'!
actualObject
	^ nil! !

!SystemQueryPhrase methodsFor: 'miscellaneous' stamp: 'sw 8/11/1998 16:42'!
associatedPlayer
	^ nil! !
TraitsTestCase subclass: #SystemTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!SystemTest methodsFor: 'testing' stamp: 'al 4/9/2006 15:22'!
testAllClassesAndTraits
	"self debug: #testAllClassesAndTraits"
	
	| trait |
	trait := self t1.
	self assert: (Smalltalk allClassesAndTraits includes: trait).
	self deny: (Smalltalk allClasses includes: trait).
	! !

!SystemTest methodsFor: 'testing' stamp: 'al 1/13/2006 12:27'!
testAllImplementedMessagesWithout
	"self debug: #testAllImplementedMessagesWithout"

	self t6 compile: 'das2qwdqwd'.
	self assert: (SystemNavigation default allImplementedMessages includes: #das2qwdqwd).
	self deny: (SystemNavigation default allImplementedMessages includes: #qwdqwdqwdc).! !

!SystemTest methodsFor: 'testing' stamp: 'al 1/13/2006 12:19'!
testAllMethodsWithSourceString
	"self debug: #testAllMethodsWithSourceString"

	| result classes |
	self t6 compile: 'foo self das2d3oia'.
	
	result := SystemNavigation default
		allMethodsWithSourceString: '2d3oi' matchCase: false.
	self assert: result size = 2.
	
	classes := result collect: [:each | each actualClass].
	self assert: (classes includesAllOf: {self t6. self class}).
	
	self assert: (SystemNavigation default
		allMethodsWithSourceString: '2d3asdas' , 'ascascoi' matchCase: false) isEmpty.! !

!SystemTest methodsFor: 'testing' stamp: 'al 1/13/2006 11:49'!
testAllSentMessages
	"self debug: #testAllSentMessages"

	self t1 compile: 'foo 1 dasoia'.
	self assert: (SystemNavigation default allSentMessages includes: 'dasoia' asSymbol).
	self deny: (SystemNavigation default allSentMessages includes: 'nioaosi' asSymbol).! !

!SystemTest methodsFor: 'testing' stamp: 'al 1/13/2006 11:09'!
testClassFromPattern
	"self debug: #testClassFromPattern"

	self assert: (Utilities classFromPattern: 'TCompilingB' withCaption: '') = TCompilingBehavior! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemTest class
	instanceVariableNames: ''!
Object subclass: #SystemVersion
	instanceVariableNames: 'version date highestUpdate updates'
	classVariableNames: 'Current'
	poolDictionaries: ''
	category: 'System-Support'!
!SystemVersion commentStamp: 'tlk 11/14/2004 10:44' prior: 0!
I am responsible for maintaining what version of Squeak and the VM is running.  I also track all of the update items that have been included in the image.

I'm invoked at auto start to get the latest plugins, etc.!


!SystemVersion methodsFor: 'accessing'!
date
	^date! !

!SystemVersion methodsFor: 'accessing'!
date: newDate
	date _ newDate! !

!SystemVersion methodsFor: 'accessing' stamp: 'mir 5/1/2001 18:19'!
datedVersion
	"Answer the version of this release."

	^ self version asString , ' of ' , self date printString! !

!SystemVersion methodsFor: 'accessing' stamp: 'mir 3/29/2001 18:03'!
highestUpdate
	| sortedUpdates |
	highestUpdate ifNil: [
		sortedUpdates _ self updates asSortedCollection.
		highestUpdate _ (sortedUpdates isEmpty
			ifTrue: [0]
			ifFalse: [sortedUpdates last])].
	^highestUpdate! !

!SystemVersion methodsFor: 'accessing'!
highestUpdate: anInteger
	highestUpdate _ anInteger! !

!SystemVersion methodsFor: 'accessing'!
includesUpdate: anUpdate
	^self updates includes: anUpdate! !

!SystemVersion methodsFor: 'accessing' stamp: 'mir 3/29/2001 18:01'!
registerUpdate: update
	self updates add: update.
	self resetHighestUpdate! !

!SystemVersion methodsFor: 'accessing' stamp: 'mir 3/29/2001 18:01'!
resetHighestUpdate
	highestUpdate _ nil! !

!SystemVersion methodsFor: 'accessing'!
unregisterUpdate: update
	self updates remove: update ifAbsent: []! !

!SystemVersion methodsFor: 'accessing'!
updates
	^updates! !

!SystemVersion methodsFor: 'accessing'!
version
	^version! !

!SystemVersion methodsFor: 'accessing'!
version: newVersion
	version _ newVersion! !


!SystemVersion methodsFor: 'initialize'!
initialize
	version _ 'No version set'.
	date _ Date today.
	updates _ Set new.
! !


!SystemVersion methodsFor: 'printing' stamp: 'mir 5/1/2001 18:20'!
printOn: stream
	stream
		nextPutAll: self datedVersion;
		nextPutAll: ' update ' , self highestUpdate printString! !


!SystemVersion methodsFor: '*smbase-extension' stamp: 'jcg 11/2/2004 10:03'!
majorMinorVersion
	"Return the major/minor version number of the form X.Y, without any 'alpha' or 'beta' or other suffix."
	"(SystemVersion new version: 'Squeak3.7alpha') majorMinorVersion" "  -->  'Squeak3.7' "
	"SystemVersion current majorMinorVersion"
	
	| char stream |
	stream := ReadStream on: version, 'x'.
	stream upTo: $..
	char := stream next.
	char ifNil: [^ version].	"eg: 'Jasmine-rc1' has no $. in it."
	[char isDigit]
		whileTrue: [char := stream next].
	^ version copyFrom: 1 to: stream position - 1
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemVersion class
	instanceVariableNames: ''!

!SystemVersion class methodsFor: 'accessing'!
current
	Current ifNil: [Current _ SystemVersion new].
	^Current! !

!SystemVersion class methodsFor: 'accessing' stamp: 'mir 8/10/2001 11:52'!
parseVersionString: versionString
	"Answer the version of this release as version, date, update."
	"SystemVersion parseVersionString: 'Squeak3.1alpha of 28 February 2001 [latest update: #3966]' "

	| stream version date update |

	[stream _ ReadStream on: versionString.
	version _ stream upToAll: ' of '.
	date _ Date readFrom: stream.
	stream upToAll: ' #'.
	update _ Number readFrom: stream]
		on: Error
		do: [^nil].
	^{version. date. update.}! !

!SystemVersion class methodsFor: 'accessing' stamp: 'mir 8/10/2001 11:53'!
pluginVersion: availableVersionString newerThan: currentVersionString
	| currentVersion availableVersion |
	(currentVersionString isEmptyOrNil
		or: [availableVersionString isEmptyOrNil])
		ifTrue: [^true].
	currentVersion _ self parseVersionString: currentVersionString.
	availableVersion _ self parseVersionString: availableVersionString.
	(currentVersion isNil
		or: [availableVersion isNil])
		ifTrue: [^false].
	^(currentVersion at: 2) < (availableVersion at: 2)! !


!SystemVersion class methodsFor: 'class initialization' stamp: 'rbb 3/1/2005 11:17'!
setVersion
	"SystemVersion setVersion"

	| newName |
	newName := UIManager default
		request: ('Please name this system version.\The old version is:\',
					self current version, '\set on ', self current date asString) withCRs
 		initialAnswer: self current version.
	newName size > 0 ifTrue:
		[self newVersion: newName]! !


!SystemVersion class methodsFor: 'instance creation' stamp: 'mir 3/29/2001 18:06'!
newVersion: versionName
	| newVersion |
	newVersion _ self new version: versionName.
	newVersion
		highestUpdate: self current highestUpdate.
	Current _ newVersion
! !


!SystemVersion class methodsFor: 'updating' stamp: 'sd 9/30/2003 13:58'!
check: pluginVersion andRequestPluginUpdate: updateURL
	"SystemVersion check: 'zzz' andRequestPluginUpdate: 'http://www.squeakland.org/installers/update.html' "

	"We don't have a decent versioning scheme yet, so we are basically checking for a nil VM version on the mac."
	(self pluginVersion: pluginVersion newerThan: self currentPluginVersion)
		ifFalse: [^true].
	(self confirm: 'There is a newer plugin version available. Do you want to install it now?')
		ifFalse: [^false].
	HTTPClient
		requestURL: updateURL , (SmalltalkImage current platformName copyWithout: Character space) asLowercase , '.html'
		target: '_top'.
	^false! !

!SystemVersion class methodsFor: 'updating' stamp: 'sd 11/16/2003 14:18'!
checkAndApplyUpdates: availableUpdate
	"SystemVersion checkAndApplyUpdates: nil"

	^(availableUpdate isNil
		or: [availableUpdate > SystemVersion current highestUpdate])
		ifTrue: [
			(self confirm: 'There are updates available. Do you want to install them now?')
				ifFalse: [^false].
			Utilities
				readServerUpdatesThrough: availableUpdate
				saveLocally: false
				updateImage: true.
			SmalltalkImage current snapshot: true andQuit: false.
			true]
		ifFalse: [false]! !

!SystemVersion class methodsFor: 'updating' stamp: 'sd 9/30/2003 13:58'!
currentPluginVersion
	^SmalltalkImage current vmVersion! !
TestCase subclass: #SystemVersionTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support-Tests'!
!SystemVersionTest commentStamp: 'tlk 11/14/2004 10:47' prior: 0!
I am an sunit test for SystemVersion.  Originally created to test SqueakMapSystemVersionFix change set.
I have no test fixtures.!


!SystemVersionTest methodsFor: 'as yet unclassified' stamp: 'tlk 11/14/2004 10:55'!
testMajorMinorVersion
	"
	SystemVersionTest run: #testMajorMinorVersion
	"
	self assert: (SystemVersion new version: 'Squeak3.7alpha') majorMinorVersion = 'Squeak3.7'.
	self assert: (SystemVersion new version: 'Squeak3.7') majorMinorVersion = 'Squeak3.7'.
	self assert: (SystemVersion new version: 'Squeak3') majorMinorVersion = 'Squeak3'.
	self assert: (SystemVersion new version: '') majorMinorVersion = ''.
! !
MorphicModel subclass: #SystemWindow
	instanceVariableNames: 'labelString stripes label closeBox collapseBox activeOnlyOnTop paneMorphs paneRects collapsedFrame fullFrame isCollapsed menuBox mustNotClose labelWidgetAllowance updatablePanes allowReframeHandles labelArea expandBox'
	classVariableNames: 'CloseBoxImage CollapseBoxImage TopWindow'
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!SystemWindow commentStamp: '<historical>' prior: 0!
SystemWindow is the Morphic equivalent of StandardSystemView -- a labelled container for rectangular views, with iconic facilities for close, collapse/expand, and resizing.

The attribute onlyActiveOnTop, if set to true (and any call to activate will set this), determines that only the top member of a collection of such windows on the screen shall be active.  To be not active means that a mouse click in any region will only result in bringing the window to the top and then making it active.!


!SystemWindow methodsFor: 'drawing' stamp: 'di 8/16/1998 01:14'!
areasRemainingToFill: aRectangle
	| areas |
	(areas _ super areasRemainingToFill: aRectangle) isEmpty
		ifTrue: [^ areas "good news -- complete occlusion"].
	"Check for special case that this is scrollbar damage"
	((bounds topLeft - (14@0) corner: bounds bottomRight) containsRect: aRectangle) ifTrue:
		[paneMorphs do: [:p | ((p isKindOf: ScrollPane) and: [p scrollBarFills: aRectangle])
							ifTrue: [^ Array new]]].
	^ areas! !

!SystemWindow methodsFor: 'drawing' stamp: 'ar 8/15/2001 21:55'!
colorForInsets
	^self paneColor colorForInsets! !

!SystemWindow methodsFor: 'drawing' stamp: 'RAA 6/12/2000 18:16'!
makeMeVisible 

	self world extent > (0@0) ifFalse: [^ self].

	((self world bounds insetBy: (0@0 corner: self labelHeight asPoint))
		containsPoint: self position) ifTrue: [^ self "OK -- at least my top left is visible"].

	"window not on screen (probably due to reframe) -- move it now"
	self isCollapsed
		ifTrue: [self position: (RealEstateAgent assignCollapsePointFor: self)]
		ifFalse: [self position: (RealEstateAgent initialFrameFor: self initialExtent: self extent world: self world) topLeft].

! !

!SystemWindow methodsFor: 'drawing' stamp: 'ar 8/16/2001 12:47'!
raisedColor
	^self paneColor raisedColor! !

!SystemWindow methodsFor: 'drawing' stamp: 'ar 12/18/2001 02:09'!
scrollBarColor
	^self paneColor! !

!SystemWindow methodsFor: 'drawing' stamp: 'di 3/25/2000 10:55'!
wantsRoundedCorners
	^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! !


!SystemWindow methodsFor: 'events' stamp: 'bmk 3/19/2002 02:09'!
doFastFrameDrag: grabPoint
	"Do fast frame dragging from the given point"

	| offset newBounds outerWorldBounds |
	outerWorldBounds _ self boundsIn: nil.
	offset _ outerWorldBounds origin - grabPoint.
	newBounds _ outerWorldBounds newRectFrom: [:f | 
		Sensor cursorPoint + offset extent: outerWorldBounds extent].
	self position: (self globalPointToLocal: newBounds topLeft); comeToFront! !

!SystemWindow methodsFor: 'events' stamp: 'RAA 2/7/2001 07:11'!
handleListenEvent: evt
	"Make sure we lock our contents after DnD has finished"
	evt isMouse ifFalse:[^self].
	evt hand hasSubmorphs ifTrue:[^self]. "still dragging"
	self == TopWindow ifFalse:[self lockInactivePortions].
	evt hand removeMouseListener: self.! !

!SystemWindow methodsFor: 'events' stamp: 'di 12/1/2001 22:54'!
handlesMouseDown: evt 
	"If I am not the topWindow, then I will only respond to dragging by the title bar.
	Any other click will only bring me to the top"

	(self labelRect containsPoint: evt cursorPoint)
		ifTrue: [^ true].
	^ self activeOnlyOnTop and: [self ~~ TopWindow]! !

!SystemWindow methodsFor: 'events' stamp: 'ar 1/31/2001 21:02'!
handlesMouseOverDragging: evt
	^true! !

!SystemWindow methodsFor: 'events' stamp: 'sw 6/30/1999 20:30'!
isCandidateForAutomaticViewing
	^ false! !

!SystemWindow methodsFor: 'events' stamp: 'di 11/30/2001 15:30'!
mouseDown: evt

	self setProperty: #clickPoint toValue: evt cursorPoint.
	TopWindow == self ifFalse:
		[evt hand releaseKeyboardFocus.
		self activate].
	model windowActiveOnFirstClick ifTrue:
		["Normally window keeps control of first click.
		Need explicit transmission for first-click activity."
		submorphs do: [:m | (m containsPoint: evt cursorPoint) ifTrue: [m mouseDown: evt]]]

! !

!SystemWindow methodsFor: 'events' stamp: 'ar 1/31/2001 21:09'!
mouseEnterDragging: evt
	"unlock children for drop operations"
	(self ~~ TopWindow and:[evt hand hasSubmorphs]) ifTrue:[
		self submorphsDo:[:m| m unlock].
		evt hand addMouseListener: self. "for drop completion on submorph"
	].! !

!SystemWindow methodsFor: 'events' stamp: 'RAA 2/7/2001 07:12'!
mouseLeaveDragging: evt
	"lock children after drop operations"
	(self ~~ TopWindow and:[evt hand hasSubmorphs]) ifTrue:[
		self lockInactivePortions.
		evt hand removeMouseListener: self.
	].! !

!SystemWindow methodsFor: 'events' stamp: 'bmk 3/19/2002 02:11'!
mouseMove: evt
	"Handle a mouse-move event"

	| cp |
	cp _ evt cursorPoint.
	self valueOfProperty: #clickPoint ifPresentDo: 
		[:firstClick |
		((self labelRect containsPoint: firstClick) and: [(cp dist: firstClick) > 3]) ifTrue:
		["If this is a drag that started in the title bar, then pick me up"
		^ self isSticky ifFalse:
			[self fastFramingOn 
				ifTrue: [self doFastFrameDrag: firstClick]
				ifFalse: [evt hand grabMorph: self topRendererOrSelf]]]].
	model windowActiveOnFirstClick ifTrue:
		["Normally window takes control on first click.
		Need explicit transmission for first-click activity."
		submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseMove: evt]]]! !

!SystemWindow methodsFor: 'events' stamp: 'di 6/10/1998 14:41'!
mouseUp: evt
	| cp |
	model windowActiveOnFirstClick ifTrue:
		["Normally window takes control on first click.
		Need explicit transmission for first-click activity."
		cp _ evt cursorPoint.
		submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseUp: evt]]]! !

!SystemWindow methodsFor: 'events' stamp: 'jmv 2/19/2006 14:47'!
paneTransition: event
	"Mouse has entered or left a pane"! !

!SystemWindow methodsFor: 'events' stamp: 'jmv 2/19/2006 14:54'!
secondaryPaneTransition: event divider: aMorph
	"Mouse has entered or left a pane"! !

!SystemWindow methodsFor: 'events' stamp: 'sw 12/22/1999 18:31'!
wantsHalo
	^ false! !

!SystemWindow methodsFor: 'events' stamp: 'ar 9/18/2000 18:34'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph"
	^aMorph isWorldMorph or:[Preferences systemWindowEmbedOK]! !


!SystemWindow methodsFor: 'geometry' stamp: 'bvs 3/16/2004 11:12'!
extent: aPoint 
	"Set the receiver's extent to value provided. Respect my minimumExtent."

	| newExtent |
	newExtent _ self isCollapsed
		ifTrue: [aPoint]
		ifFalse: [aPoint max: self minimumExtent].
	newExtent = self extent ifTrue: [^ self].

	isCollapsed
		ifTrue: [super extent: newExtent x @ (self labelHeight + 2)]
		ifFalse: [super extent: newExtent].
	isCollapsed
		ifTrue: [collapsedFrame _ self bounds]
		ifFalse: [fullFrame _ self bounds]! !

!SystemWindow methodsFor: 'geometry' stamp: 'ar 10/5/2000 20:05'!
justDroppedInto: aMorph event: anEvent
	isCollapsed
		ifTrue: [self position: ((self position max: 0@0) grid: 8@8).
				collapsedFrame _ self bounds]
		ifFalse: [fullFrame _ self bounds.
				TopWindow ~~ self ifTrue: [self activate]].
	^super justDroppedInto: aMorph event: anEvent! !

!SystemWindow methodsFor: 'geometry' stamp: 'di 6/16/1998 07:56'!
labelRect
	^ self innerBounds withHeight: self labelHeight.
! !

!SystemWindow methodsFor: 'geometry' stamp: 'sw 2/16/1999 15:23'!
paneMorphs
	"Nominally private but a need for obtaining this from the outside arose"
	^ paneMorphs copy! !

!SystemWindow methodsFor: 'geometry' stamp: 'sma 2/5/2000 14:09'!
panelRect
	"Answer the area below the title bar which is devoted to panes."

	^ self innerBounds insetBy: (0 @ self labelHeight corner: 0 @ 0)! !

!SystemWindow methodsFor: 'geometry' stamp: 'di 5/22/1998 13:24'!
position: newPos
	super position: newPos.
	isCollapsed
		ifTrue: [collapsedFrame _ self bounds]
		ifFalse: [fullFrame _ self bounds].
! !

!SystemWindow methodsFor: 'geometry' stamp: 'sw 9/28/1999 11:02'!
removeMenuBox
	menuBox ifNotNil:
		[menuBox delete.
		menuBox _ nil].
! !

!SystemWindow methodsFor: 'geometry' stamp: 'JW 2/1/2001 13:15'!
setPaneRectsFromBounds
	"Reset proportional specs from actual bounds, eg, after reframing panes"
	| layoutBounds box frame left right top bottom |
	layoutBounds _ self layoutBounds.
	paneMorphs do:[:m|
		frame _ m layoutFrame.
		box _ m bounds.
		frame ifNotNil:[
			left _ box left - layoutBounds left - (frame leftOffset ifNil:[0]).
			right _ box right - layoutBounds left - (frame rightOffset ifNil:[0]).
			top _ box top - layoutBounds top - (frame topOffset ifNil:[0]).
			bottom _ box bottom - layoutBounds top - (frame bottomOffset ifNil:[0]).
			frame leftFraction: (left / layoutBounds width asFloat).
			frame rightFraction: (right / layoutBounds width asFloat).
			frame topFraction: (top / layoutBounds height asFloat).
			frame bottomFraction: (bottom / layoutBounds height asFloat).
		].
	].! !


!SystemWindow methodsFor: 'initialization' stamp: 'bvs 3/16/2004 11:13'!
addCloseBox
	"If I have a labelArea, add a close box to it"
	| frame |
	labelArea
		ifNil: [^ self].
	closeBox := self createCloseBox.
	frame := LayoutFrame new.
	frame leftFraction: 0;
		 leftOffset: 2;
		 topFraction: 0;
		 topOffset: 0.
	closeBox layoutFrame: frame.
	labelArea addMorphBack: closeBox! !

!SystemWindow methodsFor: 'initialization' stamp: 'bvs 3/16/2004 11:13'!
addExpandBox
	"If I have a labelArea, add a close box to it"
	| frame |
	labelArea
		ifNil: [^ self].
	expandBox := self createExpandBox.
	frame := LayoutFrame new.
	frame leftFraction: 1;
		 leftOffset: (self boxExtent x * 2 + 3) negated;
		 topFraction: 0;
		 topOffset: 0.
	expandBox layoutFrame: frame.
	labelArea addMorphBack: expandBox! !

!SystemWindow methodsFor: 'initialization' stamp: 'nk 6/2/2004 11:27'!
addLabelArea

	labelArea := (AlignmentMorph newSpacer: Color transparent)
			vResizing: #spaceFill;
			layoutPolicy: ProportionalLayout new.
	self addMorph: labelArea.! !

!SystemWindow methodsFor: 'initialization' stamp: 'bvs 3/16/2004 11:13'!
addMenuControl
	"If I have a label area, add a menu control to it."
	| frame |
	labelArea
		ifNil: [^ self].
	"No menu if no label area"
	menuBox
		ifNotNil: [menuBox delete].
	menuBox := self createMenuBox.
	frame := LayoutFrame new.
	frame leftFraction: 0;
		 leftOffset: closeBox right + 3;
		 topFraction: 0;
		 topOffset: 0.
	menuBox layoutFrame: frame.
	labelArea addMorphBack: menuBox! !

!SystemWindow methodsFor: 'initialization' stamp: 'jrp 7/23/2005 21:34'!
addPaneHSplitters

	| remaining targetY sameY |
	remaining _ paneMorphs copy reject: [:each | each layoutFrame bottomFraction = 1].
	[remaining notEmpty] whileTrue:
		[targetY _ remaining first layoutFrame bottomFraction.
		sameY _ paneMorphs select: [:each | each layoutFrame bottomFraction = targetY].
		self addPaneHSplitterBetween: remaining first and: sameY.
		remaining _ remaining copyWithoutAll: sameY]! !

!SystemWindow methodsFor: 'initialization' stamp: 'jmv 1/29/2006 17:41'!
addPaneSplitters

	self removePaneSplitters.
	self removeCornerGrips.
	
	self addCornerGrips.
	self addPaneVSplitters.
	self addPaneHSplitters.	

	self linkSubmorphsToSplitters! !

!SystemWindow methodsFor: 'initialization' stamp: 'jrp 7/23/2005 21:26'!
addPaneVSplitters

	| remaining targetX sameX |
	remaining _ paneMorphs copy reject: [:each | each layoutFrame rightFraction = 1].
	[remaining notEmpty] whileTrue:
		[targetX _ remaining first layoutFrame rightFraction.
		sameX _ paneMorphs select: [:each | each layoutFrame rightFraction = targetX].
		self addPaneVSplitterBetween: remaining first and: sameX.
		remaining _ remaining copyWithoutAll: sameX]! !

!SystemWindow methodsFor: 'initialization' stamp: 'dgd 10/26/2004 19:44'!
applyModelExtent
	| initialExtent |
	initialExtent := Preferences bigDisplay
				ifTrue: [(model initialExtent * 1.5) rounded]
				ifFalse: [model initialExtent].
	self extent: initialExtent ! !

!SystemWindow methodsFor: 'initialization' stamp: 'dgd 3/21/2003 19:41'!
boxExtent
	"answer the extent to use in all the buttons. 
	 
	the label height is used to be proportional to the fonts preferences"
	^ (Preferences alternativeWindowBoxesLook
		ifTrue: [18 @ 18]
		ifFalse: [14 @ 14])
		max: label height @ label height ! !

!SystemWindow methodsFor: 'initialization' stamp: 'jrp 7/23/2005 12:07'!
createBox
	"create a button with default to be used in the label area"
	"Transcript show: self paneColor asString;  
	cr."
	| box |
	box _ IconicButton new.
	box color: Color transparent;
		 target: self;
		 useSquareCorners;
		 borderWidth: 0.

	^ box! !

!SystemWindow methodsFor: 'initialization' stamp: 'dgd 12/15/2003 10:33'!
createCloseBox
	^ self createBox labelGraphic: self class closeBoxImage;
		 extent: self boxExtent;
		 actionSelector: #closeBoxHit;
		 setBalloonText: 'close this window' translated! !

!SystemWindow methodsFor: 'initialization' stamp: 'yo 2/12/2005 19:21'!
createCollapseBox
	^ self createBox labelGraphic: self class collapseBoxImage;
		 extent: self boxExtent;
		 actionSelector: #collapseOrExpand;
		 setBalloonText: 'collapse this window' translated.
! !

!SystemWindow methodsFor: 'initialization' stamp: 'dgd 12/15/2003 10:34'!
createExpandBox
	^ self createBox 
		
		labelGraphic: (ScriptingSystem formAtKey: 'expandBox');
	
		 extent: self boxExtent;
		 actWhen: #buttonUp;
		 actionSelector: #expandBoxHit;

		 setBalloonText: 'expand to full screen' translated! !

!SystemWindow methodsFor: 'initialization' stamp: 'dgd 12/15/2003 10:34'!
createMenuBox
	^ self createBox 
		
		labelGraphic: (ScriptingSystem formAtKey: 'TinyMenu');

		 extent: self boxExtent;
		 actWhen: #buttonDown;
		 actionSelector: #offerWindowMenu;
		 setBalloonText: 'window menu' translated! !

!SystemWindow methodsFor: 'initialization' stamp: 'md 2/24/2006 15:57'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #raised.! !

!SystemWindow methodsFor: 'initialization' stamp: 'md 2/24/2006 15:57'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 2.! !

!SystemWindow methodsFor: 'initialization' stamp: 'md 2/24/2006 15:57'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color white.! !

!SystemWindow methodsFor: 'initialization' stamp: 'bvs 3/16/2004 13:20'!
gradientWithColor: aColor

	| ramp |
	ramp _ {0.0 -> Color white. 1.0 -> aColor}.

	^ (GradientFillStyle ramp: ramp)
		radial: true;
		origin: self bounds origin;
		direction: 0 @ 223;
		normal: 223 @ 0.! !

!SystemWindow methodsFor: 'initialization' stamp: 'dgd 4/3/2006 11:53'!
initialize
	"Initialize a system window. Add label, stripes, etc., if desired"
	super initialize.
	allowReframeHandles _ true.
	labelString ifNil: [labelString _ 'Untitled Window'].
	isCollapsed _ false.
	activeOnlyOnTop _ true.
	paneMorphs _ Array new.
	borderColor _ Color lightGray.
	borderWidth _ 1.
	self color: Color lightGray lighter lighter lighter.
	self layoutPolicy: ProportionalLayout new.
	
	label _ StringMorph new contents: labelString;
						 font: Preferences windowTitleFont emphasis: 1.
			"Add collapse box so #labelHeight will work"
			collapseBox _ self createCollapseBox.
			stripes _ Array
						with: (RectangleMorph newBounds: bounds)
						with: (RectangleMorph newBounds: bounds).
			"see extent:"
			self addLabelArea.
			self setLabelWidgetAllowance.
			self addCloseBox.
			self addMenuControl.
			labelArea addMorphBack: (Morph new extent: self class borderWidth @ 0).
			labelArea addMorphBack: label.
			self wantsExpandBox
				ifTrue: [self addExpandBox].
			labelArea addMorphBack: collapseBox.
			self setFramesForLabelArea.
			Preferences clickOnLabelToEdit
				ifTrue: [label
						on: #mouseDown
						send: #relabel
						to: self].
			Preferences noviceMode
				ifTrue: [closeBox
						ifNotNil: [closeBox setBalloonText: 'close window'].
					menuBox
						ifNotNil: [menuBox setBalloonText: 'window menu'].
					collapseBox
						ifNotNil: [collapseBox setBalloonText: 'collapse/expand window']].
				
	self addCornerGrips.

	self extent: 300 @ 200.
	mustNotClose _ false.
	updatablePanes _ Array new.
		
	Preferences menuAppearance3d
		ifTrue: [
			self
				addDropShadow;
				shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.333);
				shadowOffset: 1@1.
		].
					! !

!SystemWindow methodsFor: 'initialization' stamp: 'fc 12/15/2004 15:30'!
initializeLabelArea
	"Initialize the label area (titlebar) for the window."
	label := LabelStringMorph new
				contents: labelString;
				font: Preferences windowTitleFont
				emphasis: (Preferences windowTitleFont isTTCFont ifTrue: [0] ifFalse: [1]);
				mySystemWindow: self.
	"Add collapse box so #labelHeight will work"
	collapseBox := self createCollapseBox.
	stripes := Array
				with: (RectangleMorph newBounds: bounds)
				with: (RectangleMorph newBounds: bounds).
	"see extent:"
	self addLabelArea.
	labelArea
		addMorph: (stripes first borderWidth: 1).
	labelArea
		addMorph: (stripes second borderWidth: 2).
	self setLabelWidgetAllowance.
	self addCloseBox.
	self addMenuControl.
	labelArea addMorph: label.
	self wantsExpandBox
		ifTrue: [self addExpandBox].
	labelArea addMorph: collapseBox.
	self setFramesForLabelArea.
	Preferences clickOnLabelToEdit
		ifTrue: [label
				on: #mouseDown
				send: #relabel
				to: self].
	Preferences noviceMode
		ifTrue: [closeBox
				ifNotNil: [closeBox setBalloonText: 'close window' translated].
			menuBox
				ifNotNil: [menuBox setBalloonText: 'window menu' translated].
			collapseBox
				ifNotNil: [collapseBox setBalloonText: 'collapse/expand window' translated]].
! !

!SystemWindow methodsFor: 'initialization' stamp: 'jlb 5/29/2001 23:24'!
maximumExtent
	"This returns the maximum extent that the morph may be expanded to.
	Return nil if this property has not been set."

	^ self valueOfProperty: #maximumExtent! !

!SystemWindow methodsFor: 'initialization' stamp: 'jlb 5/29/2001 23:24'!
maximumExtent: aPoint
	"This returns the maximum extent that the morph may be expanded to.
	Return nil if this property has not been set."

	^ self setProperty: #maximumExtent toValue: aPoint! !

!SystemWindow methodsFor: 'initialization' stamp: 'ar 8/15/2001 22:16'!
model: anObject
	super model: anObject.
	self paneColor: nil.! !

!SystemWindow methodsFor: 'initialization' stamp: 'nk 7/11/2004 22:28'!
replaceBoxes
	"Rebuild the various boxes."
	self setLabelWidgetAllowance.
	closeBox ifNotNilDo: [ :m | m delete. self addCloseBox. ].
	expandBox ifNotNilDo: [ :m | m delete. self addExpandBox. ].
	menuBox ifNotNilDo: [ :m | m delete. self addMenuControl. ].
	collapseBox ifNotNilDo: [ :m | m delete. labelArea addMorph: (collapseBox := self createCollapseBox) ].
	self setFramesForLabelArea.
	self setWindowColor: self paneColor ! !

!SystemWindow methodsFor: 'initialization' stamp: 'md 2/24/2006 16:06'!
setFramesForLabelArea
	"an aid to converting old instances, but then I found  
	convertAlignment (jesse welton's note)"
	| frame windowBorderWidth |
	labelArea ifNil: [^ self].	
	labelArea
		layoutPolicy: TableLayout new;
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		layoutInset: 0.
	label hResizing: #spaceFill.
	labelArea
		ifNotNil: [frame _ LayoutFrame new.
			frame leftFraction: 0;
				topFraction: 0;
				rightFraction: 1;
				topOffset: self labelHeight negated.
				windowBorderWidth := self class borderWidth.
			frame leftOffset: windowBorderWidth;
				rightOffset: windowBorderWidth negated;
				topOffset: self labelHeight negated + windowBorderWidth;
				bottomOffset: windowBorderWidth negated.
			labelArea layoutFrame: frame]! !


!SystemWindow methodsFor: 'label' stamp: 'sw 11/7/2000 10:24'!
externalName
	"Answer the name by which the receiver is known in the UI"

	^ labelString! !

!SystemWindow methodsFor: 'label' stamp: 'bvs 4/2/2004 16:55'!
getRawLabel
	| contentsFit |
	contentsFit _ label duplicate fitContents.
	contentsFit extent: (label extent x min: contentsFit extent x) @ contentsFit extent y.
	
	^ contentsFit
! !

!SystemWindow methodsFor: 'label' stamp: 'di 5/4/1998 23:42'!
label
	^ labelString! !

!SystemWindow methodsFor: 'label' stamp: 'jrp 8/6/2005 23:49'!
labelHeight
	"Answer the height for the window label.  The standard behavior is at bottom; a hook is provided so that models can stipulate other heights, in support of various less-window-looking demos."

	| aHeight |
	(model notNil and: [model respondsTo: #desiredWindowLabelHeightIn:]) ifTrue:
		[(aHeight _ model desiredWindowLabelHeightIn: self) ifNotNil: [^ aHeight]].

	^ label ifNil: [0] ifNotNil:
		 [(label height + (self class borderWidth * 2)) max:
			(collapseBox ifNotNil: [collapseBox height] ifNil: [10])]! !

!SystemWindow methodsFor: 'label' stamp: 'sw 9/29/1999 07:22'!
labelWidgetAllowance
	^ labelWidgetAllowance ifNil: [self setLabelWidgetAllowance]! !

!SystemWindow methodsFor: 'label' stamp: 'rbb 3/1/2005 11:17'!
relabel
	| newLabel |
	newLabel := UIManager default 
		request: 'New title for this window' translated
		initialAnswer: labelString.
	newLabel isEmpty ifTrue: [^self].
	(model windowReqNewLabel: newLabel)
		ifTrue: [self setLabel: newLabel]! !

!SystemWindow methodsFor: 'label' stamp: 'di 12/1/2001 23:19'!
relabelEvent: evt
	"No longer used, but may be referred to by old eventHandlers"

	^ Preferences clickOnLabelToEdit
		ifFalse:	[self mouseDown: evt]
		ifTrue:	[self relabel]! !

!SystemWindow methodsFor: 'label' stamp: 'dew 8/3/2004 01:12'!
setLabel: aString
	| frame |
	labelString _ aString.
	label ifNil: [^ self].
	label contents: aString.
	self labelWidgetAllowance.  "Sets it if not already"
	self isCollapsed
		ifTrue: [self extent: (label width + labelWidgetAllowance) @ (self labelHeight + 2)]
		ifFalse: [label fitContents; setWidth: (label width min: bounds width - labelWidgetAllowance).
				label align: label bounds topCenter with: bounds topCenter + (0@borderWidth).
				collapsedFrame ifNotNil:
					[collapsedFrame _ collapsedFrame withWidth: label width + labelWidgetAllowance]].
	frame _ LayoutFrame new.
	frame leftFraction: 0.5;
		 topFraction: 0.5;
		 leftOffset: label width negated // 2;
		 topOffset: label height negated // 2.
	label layoutFrame: frame.
! !

!SystemWindow methodsFor: 'label' stamp: 'yo 6/30/2004 00:21'!
setLabelFont: aFont

	label ifNil: [^ self].
	label font: aFont.
! !

!SystemWindow methodsFor: 'label' stamp: 'dgd 3/21/2003 13:03'!
setLabelWidgetAllowance
	^ labelWidgetAllowance :=  (self boxExtent x * 4) + 19! !

!SystemWindow methodsFor: 'label' stamp: 'md 2/24/2006 15:38'!
setStripeColorsFrom: paneColor 
	"Set the stripe color based on the given paneColor"

	labelArea ifNotNil: [labelArea color: Color transparent].
	self updateBoxesColor: (self isActive 
				ifTrue: [paneColor]
				ifFalse: [paneColor muchDarker]).
	stripes ifNil: [^self].
	self isActive 
		ifTrue: [self fillStyle: (self gradientWithColor: paneColor lighter lighter lighter)] 
		ifFalse: ["This could be much faster"
				self fillStyle: (self gradientWithColor: paneColor duller)].! !

!SystemWindow methodsFor: 'label' stamp: 'fc 12/15/2004 13:33'!
tryToRenameTo: newLabel
	"Triggered eg by typing a new name in the halo"

	newLabel isEmpty ifTrue: [^self].
	(model windowReqNewLabel: newLabel)
		ifTrue: [self setLabel: newLabel]
	! !

!SystemWindow methodsFor: 'label' stamp: 'BG 8/27/2003 19:07'!
update: aSymbol
	aSymbol = #relabel
		ifTrue: [^ model ifNotNil: [ self setLabel: model labelString ] ].
	aSymbol = #close
		ifTrue: [self delete]! !

!SystemWindow methodsFor: 'label' stamp: 'ar 12/30/2001 20:47'!
widthOfFullLabelText
	^(Preferences windowTitleFont emphasized: 1) widthOfString: labelString! !


!SystemWindow methodsFor: 'layout' stamp: 'wiz 1/18/2006 15:44'!
convertAlignment
	"Primarily Jesse Welton's code to convert old system windows to ones with modern layout scheme"

	| frame |
	self layoutPolicy: ProportionalLayout new.
	(paneMorphs isNil 
		or: [paneRects isNil or: [paneMorphs size ~= paneRects size]]) 
			ifFalse: 
				[self addLabelArea.
				self putLabelItemsInLabelArea.
				self setFramesForLabelArea.
				paneMorphs with: paneRects
					do: 
						[:m :r | 
						frame := LayoutFrame new.
						frame
							leftFraction: r left;
							rightFraction: r right;
							topFraction: r top;
							bottomFraction: r bottom.
						m layoutFrame: frame.
						m
							hResizing: #spaceFill;
							vResizing: #spaceFill]].
	labelArea isNil 
		ifTrue: 
			[self addLabelArea.
			self putLabelItemsInLabelArea.
			self setFramesForLabelArea.
			paneMorphs ifNotNil: 
					[paneMorphs do: 
							[:m | 
							frame := m layoutFrame ifNil: [LayoutFrame new].
							frame topOffset: (frame topOffset ifNil: [0]) - self labelHeight.
							frame bottomFraction ~= 1.0 
								ifTrue: 
									[frame bottomOffset: (frame bottomOffset ifNil: [0]) - self labelHeight]]]].
	label ifNotNil: 
			[frame := LayoutFrame new.
			frame
				leftFraction: 0.5;
				topFraction: 0;
				leftOffset: label width negated // 2.
			label layoutFrame: frame].
	collapseBox ifNotNil: 
			[frame := LayoutFrame new.
			frame
				rightFraction: 1;
				topFraction: 0;
				rightOffset: -1;
				topOffset: 1.
			collapseBox layoutFrame: frame].
	stripes ifNotNil: 
			[frame := LayoutFrame new.
			frame
				leftFraction: 0;
				topFraction: 0;
				rightFraction: 1;
				leftOffset: 1;
				topOffset: 1;
				rightOffset: -1.
			stripes first layoutFrame: frame.
			stripes first height: self labelHeight - 2.
			stripes first hResizing: #spaceFill.
			frame := LayoutFrame new.
			frame
				leftFraction: 0;
				topFraction: 0;
				rightFraction: 1;
				leftOffset: 3;
				topOffset: 3;
				rightOffset: -3.
			stripes last layoutFrame: frame.
			stripes last height: self labelHeight - 6.
			stripes last hResizing: #spaceFill].
	menuBox ifNotNil: 
			[frame := LayoutFrame new.
			frame
				leftFraction: 0;
				leftOffset: 19;
				topFraction: 0;
				topOffset: 1.
			menuBox layoutFrame: frame].
	closeBox ifNotNil: 
			[frame := LayoutFrame new.
			frame
				leftFraction: 0;
				leftOffset: 4;
				topFraction: 0;
				topOffset: 1.
			closeBox layoutFrame: frame]! !

!SystemWindow methodsFor: 'layout' stamp: 'JW 1/30/2001 22:45'!
layoutBounds
	"Bounds of pane area only."
	| box |

	box := super layoutBounds.
	^box withTop: box top + self labelHeight! !

!SystemWindow methodsFor: 'layout' stamp: 'sw 5/18/2001 16:09'!
putLabelItemsInLabelArea
	"Put label items into the label area, if there is one"

	labelArea ifNotNil:
		[stripes ifNotNil: [stripes do: [:stripe | labelArea addMorph: stripe]].
		closeBox ifNotNil: [labelArea addMorph: closeBox].
		menuBox ifNotNil: [labelArea addMorph: menuBox].
		collapseBox ifNotNil: [labelArea addMorph: collapseBox].
		label ifNotNil: [labelArea addMorph: label]]

! !


!SystemWindow methodsFor: 'menu' stamp: 'md 11/14/2003 17:30'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
"template..."
	aCustomMenu addLine.
	aCustomMenu add: 'edit label...' translated action: #relabel.
! !

!SystemWindow methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:40'!
buildWindowMenu
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu add: 'change title...' translated action: #relabel.
	aMenu addLine.
	aMenu add: 'send to back' translated action: #sendToBack.
	aMenu add: 'make next-to-topmost' translated action: #makeSecondTopmost.
	aMenu addLine.
	self mustNotClose
		ifFalse:
			[aMenu add: 'make unclosable' translated action: #makeUnclosable]
		ifTrue:
			[aMenu add: 'make closable' translated action: #makeClosable].
	aMenu
		add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) translated 
		action: #toggleStickiness.
	aMenu addLine.
	aMenu add: 'full screen' translated action: #fullScreen.
	self isCollapsed ifFalse: [aMenu add: 'window color...' translated action: #setWindowColor].
	^aMenu! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 10/6/2000 14:01'!
changeColor
	"Change the color of the receiver -- triggered, e.g. from a menu.  This variant allows the recolor triggered from the window's halo recolor handle to have the same result as choosing change-window-color from the window-title menu"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #setWindowColor:;
		originalColor: self color;
		putUpFor: self near: self fullBoundsInWorld! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 8/7/2000 17:35'!
deleteCloseBox
	closeBox ifNotNil:
		[closeBox delete.
		closeBox _ nil]! !

!SystemWindow methodsFor: 'menu' stamp: 'dao 10/1/2004 12:57'!
fullScreen
	"Zoom Window to Full World size with possible DeskMargins"
		"SystemWindow fullScreen"
	
	| left right possibleBounds |
	left _ right _ 0.
	self paneMorphs
		do: [:pane | ((pane isKindOf: ScrollPane)
					and: [pane retractableScrollBar])
				ifTrue: [pane scrollBarOnLeft
						ifTrue: [left _ left max: pane scrollBarThickness]
						ifFalse: [right _ right max: pane scrollBarThickness]]].
	possibleBounds _ (RealEstateAgent maximumUsableAreaInWorld: self world)
				insetBy: (left @ 0 corner: right @ 0).
	((Flaps sharedFlapsAllowed
				and: [Project current flapsSuppressed not])
			or: [Preferences fullScreenLeavesDeskMargins])
		ifTrue: [possibleBounds _ possibleBounds insetBy: 22].
	self bounds: possibleBounds! !

!SystemWindow methodsFor: 'menu' stamp: 'dao 10/1/2004 12:57'!
fullScreenMaximumExtent
	"Zoom Window to Full World size with possible DeskMargins
	obey the maximum extent rules"
	
	| left right possibleBounds |
	left _ right _ 0.
	self paneMorphs
		do: [:pane | ((pane isKindOf: ScrollPane)
					and: [pane retractableScrollBar])
				ifTrue: [pane scrollBarOnLeft
						ifTrue: [left _ left max: pane scrollBarThickness]
						ifFalse: [right _ right max: pane scrollBarThickness]]].
	possibleBounds _ self worldBounds
				insetBy: (left @ 0 corner: right @ 0).

	self maximumExtent ifNotNil:
		[possibleBounds _ possibleBounds origin extent: ( self maximumExtent min: ( possibleBounds extent ))].
	((Flaps sharedFlapsAllowed
				and: [Project current flapsSuppressed not])
			or: [Preferences fullScreenLeavesDeskMargins])
		ifTrue: [possibleBounds _ possibleBounds insetBy: 22].
	self bounds: possibleBounds! !

!SystemWindow methodsFor: 'menu' stamp: 'kfr 8/15/2004 15:27'!
makeClosable
	| opaqueColor |
	mustNotClose := false.
	closeBox
		ifNil: [self addCloseBox.
			self isActive
				ifTrue: [opaqueColor := self paneColor]
				ifFalse: [opaqueColor := self paneColor muchDarker].
			self
				updateBox: closeBox
				color: (opaqueColor alphaMixed: 0.5 with: Color red).
			self extent: self extent]! !

!SystemWindow methodsFor: 'menu' stamp: 'gm 2/16/2003 20:35'!
makeSecondTopmost
	| aWorld nextWindow |
	aWorld := self world.
	nextWindow := aWorld submorphs 
				detect: [:m | (m isSystemWindow) and: [m ~~ self]]
				ifNone: [^self].
	nextWindow activate.
	aWorld addMorph: self behind: nextWindow! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 8/7/2000 17:35'!
makeUnclosable
	mustNotClose _ true.
	self deleteCloseBox! !

!SystemWindow methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:01'!
offerWindowMenu
	| aMenu |
	aMenu _ self buildWindowMenu.
	model ifNotNil:
		[model addModelItemsToWindowMenu: aMenu].
	aMenu popUpEvent: self currentEvent in: self world! !

!SystemWindow methodsFor: 'menu' stamp: 'gm 2/16/2003 20:35'!
sendToBack
	| aWorld nextWindow |
	aWorld := self world.
	nextWindow := aWorld submorphs 
				detect: [:m | (m isSystemWindow) and: [m ~~ self]]
				ifNone: [^self].
	nextWindow activate.
	aWorld addMorphNearBack: self! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 9/6/2000 18:46'!
setWindowColor
	"Allow the user to select a new basic color for the window"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #setWindowColor:;
		originalColor: self paneColorToUse;
		putUpFor: self
			near: self fullBounds! !

!SystemWindow methodsFor: 'menu' stamp: 'md 2/24/2006 15:37'!
setWindowColor: incomingColor
	| existingColor aColor |
	incomingColor ifNil: [^ self].  "it happens"
	aColor _ incomingColor asNontranslucentColor.
	(aColor = ColorPickerMorph perniciousBorderColor 
		or: [aColor = Color black]) ifTrue: [^ self].
	existingColor _ self paneColorToUse.
	existingColor ifNil: [^ Beeper beep].
	self paneColor: aColor.
	self setStripeColorsFrom: aColor.
	self changed.! !

!SystemWindow methodsFor: 'menu' stamp: 'nb 6/17/2003 12:25'!
takeOutOfWindow
	"Take the receiver's pane morph out the window and place it, naked, where once the window was"
	| aMorph |
	paneMorphs size == 1 ifFalse: [^ Beeper beep].
	aMorph _ paneMorphs first.
	owner addMorphFront: aMorph.
	self delete! !

!SystemWindow methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:27'!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	^ false! !


!SystemWindow methodsFor: 'object fileIn' stamp: 'JW 1/31/2001 08:57'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	allowReframeHandles ifNil: [allowReframeHandles := true].
	self layoutPolicy ifNil: [self convertAlignment].
	labelArea ifNil: [self convertAlignment].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!SystemWindow methodsFor: 'open/close' stamp: 'ar 10/5/2000 17:26'!
closeBoxHit
	"The user clicked on the close-box control in the window title.  For Mac users only, the Mac convention of option-click-on-close-box is obeyed if the mac option key is down."

	Preferences dismissAllOnOptionClose ifTrue:
		[Sensor rawMacOptionKeyPressed ifTrue:
			[^ self world closeUnchangedWindows]].
	self delete
! !

!SystemWindow methodsFor: 'open/close' stamp: 'di 10/28/1999 13:15'!
delete
	| thisWorld sketchEditor aPaintBox |
	self mustNotClose ifTrue: [^ self].
	model okToChange ifFalse: [^ self].
	thisWorld _ self world.
	sketchEditor _ self extantSketchEditor.
	self isFlexed
		ifTrue: [owner delete]
		ifFalse: [super delete].
	model windowIsClosing; release.
	model _ nil.
	sketchEditor ifNotNil:
		[sketchEditor deleteSelfAndSubordinates.
		thisWorld notNil ifTrue:
			[(aPaintBox _ thisWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]]].
		
	SystemWindow noteTopWindowIn: thisWorld.
! !

!SystemWindow methodsFor: 'open/close' stamp: 'dgd 10/26/2004 19:45'!
initialExtent
	^ Preferences bigDisplay
		ifTrue: [(model initialExtent * 1.75) rounded]
		ifFalse: [model initialExtent]! !

!SystemWindow methodsFor: 'open/close' stamp: 'sw 9/28/1999 13:32'!
mustNotClose
	^ mustNotClose == true! !

!SystemWindow methodsFor: 'open/close' stamp: 'ar 5/11/2001 23:46'!
openAsIs
	^self openAsIsIn: self currentWorld
! !

!SystemWindow methodsFor: 'open/close' stamp: 'ar 5/11/2001 23:46'!
openAsIsIn: aWorld
	"This msg and its callees result in the window being activeOnlyOnTop"
	aWorld addMorph: self.
	self activate.
	aWorld startSteppingSubmorphsOf: self.
! !

!SystemWindow methodsFor: 'open/close' stamp: 'di 5/20/1998 09:14'!
openInMVC
	^ self openInMVCExtent: self initialExtent! !

!SystemWindow methodsFor: 'open/close' stamp: 'di 5/13/1998 21:28'!
openInMVCExtent: extent
	Smalltalk isMorphic ifTrue: [^ self openInWorldExtent: extent].
	self bounds: (16@0 extent: extent).  "Room on left for scroll bars"
	MorphWorldView openWorldWith: self labelled: labelString! !

!SystemWindow methodsFor: 'open/close' stamp: 'ar 5/11/2001 23:47'!
openInWorld: aWorld
	"This msg and its callees result in the window being activeOnlyOnTop"
	self bounds: (RealEstateAgent initialFrameFor: self world: aWorld).
	^self openAsIsIn: aWorld! !

!SystemWindow methodsFor: 'open/close' stamp: 'ar 5/11/2001 23:47'!
openInWorld: aWorld extent: extent
	"This msg and its callees result in the window being activeOnlyOnTop"
	self position: (RealEstateAgent initialFrameFor: self world: aWorld) topLeft; extent: extent.
	^self openAsIsIn: aWorld! !

!SystemWindow methodsFor: 'open/close' stamp: 'RAA 6/2/2000 10:46'!
openInWorldExtent: extent
	"This msg and its callees result in the window being activeOnlyOnTop"

	Smalltalk isMorphic ifFalse: [^ self openInMVCExtent: extent].
	self openInWorld: self currentWorld extent: extent! !

!SystemWindow methodsFor: 'open/close' stamp: 'sw 10/15/1998 11:13'!
positionSubmorphs
	"Feels like overkill, but effect needed"
	super positionSubmorphs.
	self submorphsDo:
		[:aMorph | aMorph positionSubmorphs]! !


!SystemWindow methodsFor: 'panes' stamp: 'RAA 1/8/2001 20:37'!
addMorph: aMorph frame: relFrame
	| frame |
	frame _ LayoutFrame new.
	frame 
		leftFraction: relFrame left; 
		rightFraction: relFrame right; 
		topFraction: relFrame top; 
		bottomFraction: relFrame bottom.
	self addMorph: aMorph fullFrame: frame.

! !

!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:58'!
addMorph: aMorph fullFrame: aLayoutFrame

	| left right bottom top windowBorderWidth |
	windowBorderWidth _ self class borderWidth.

	left _ aLayoutFrame leftOffset ifNil: [0].
	right _ aLayoutFrame rightOffset ifNil: [0].

	bottom _ aLayoutFrame bottomOffset ifNil: [0].
	top _ aLayoutFrame topOffset ifNil: [0].
	
	aLayoutFrame rightFraction = 1 ifTrue: [aLayoutFrame rightOffset: right - windowBorderWidth].
	aLayoutFrame leftFraction = 0
		ifTrue: [aLayoutFrame leftOffset: left + windowBorderWidth]
		ifFalse: [aLayoutFrame leftOffset: left + ProportionalSplitterMorph splitterWidth].

	aLayoutFrame bottomFraction = 1 ifTrue: [aLayoutFrame bottomOffset: bottom - windowBorderWidth].
	aLayoutFrame topFraction = 0
		ifTrue: [aLayoutFrame topOffset: top]
		ifFalse: [aLayoutFrame topOffset: top + ProportionalSplitterMorph splitterWidth].
	
	(aMorph class name = #BrowserCommentTextMorph) ifTrue:
		[aLayoutFrame rightOffset: windowBorderWidth negated.
		aLayoutFrame leftOffset: windowBorderWidth.
		aLayoutFrame bottomOffset: windowBorderWidth negated.
		aLayoutFrame topOffset: (windowBorderWidth negated) + 4].
	
	super addMorph: aMorph fullFrame: aLayoutFrame.

	paneMorphs _ paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph).
	aMorph adoptPaneColor: self paneColor.
	aMorph borderWidth: 1; borderColor: Color lightGray; color: Color white.
	Preferences scrollBarsOnRight	"reorder panes so flop-out right-side scrollbar is visible"
		ifTrue: [self addMorphBack: aMorph].
		
	self addPaneSplitters! !

!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:47'!
existingPaneColor
	"Answer the existing pane color for the window, obtaining it from the first paneMorph if any, and fall back on using the second stripe color if necessary."

	| aColor |
	aColor := self valueOfProperty: #paneColor.
	aColor ifNil: [self setProperty: #paneColor toValue: (aColor := self paneColor)].
	^aColor.! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 1/14/1999 10:52'!
holdsTranscript
	"ugh"
	| plug |
	^ paneMorphs size == 1 and: [((plug _ paneMorphs first) isKindOf: PluggableTextMorph) and: [plug model isKindOf: TranscriptStream]]! !

!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:56'!
paneColor
	| cc |
	(cc := self valueOfProperty: #paneColor) ifNotNil: [^cc].
	Display depth > 2 
		ifTrue: 
			[model ifNotNil: 
					[model isInMemory 
						ifTrue: 
							[cc := Color colorFrom: model defaultBackgroundColor.
							cc := (cc = Color lightYellow or: [cc = Color white]) 
										ifTrue: [Color gray: 0.67]
										ifFalse: [cc duller]]].
	cc ifNil: [cc := paneMorphs isEmptyOrNil ifFalse: [paneMorphs first color]]].
	cc ifNil: [cc := self defaultBackgroundColor].
	self paneColor: cc.
	^cc! !

!SystemWindow methodsFor: 'panes' stamp: 'bvs 3/17/2004 09:15'!
paneColor: aColor
	self setProperty: #paneColor toValue: aColor.

	self adoptPaneColor: aColor.! !

!SystemWindow methodsFor: 'panes' stamp: 'ar 8/15/2001 22:14'!
paneColorToUse
	^ Display depth <= 2
		ifTrue:
			[Color white]
		ifFalse:
			[self paneColor]! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:44'!
paneMorphSatisfying: aBlock
	^ paneMorphs detect: [:aPane | aBlock value: aPane] ifNone: [nil]! !

!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:46'!
replacePane: oldPane with: newPane
	"Make newPane exactly occupy the position and extent of oldPane"

	| aLayoutFrame hadDep |
	hadDep _ model dependents includes: oldPane.
	oldPane owner replaceSubmorph: oldPane by: newPane.
	newPane
		position: oldPane position;
		extent: oldPane extent.
	aLayoutFrame _ oldPane layoutFrame.
	paneMorphs _ paneMorphs collect:
		[:each |
		each == oldPane ifTrue: [newPane] ifFalse: [each]].
	aLayoutFrame ifNotNil: [newPane layoutFrame: aLayoutFrame].
	newPane color: Color transparent.
	hadDep ifTrue: [model removeDependent: oldPane. model addDependent: newPane].

	self changed

! !

!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:46'!
restoreDefaultPaneColor
	"Useful when changing from monochrome to color display"

	self setStripeColorsFrom: self paneColor.! !

!SystemWindow methodsFor: 'panes' stamp: 'RAA 1/10/2001 19:01'!
setUpdatablePanesFrom: getSelectors
	| aList aPane possibles |
	"Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors.  Order is important here!!  Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case"

	aList _ OrderedCollection new.
	possibles _ OrderedCollection new.
	self allMorphsDo: [ :pane | 
		(pane isKindOf: PluggableListMorph) ifTrue: [
			possibles add: pane.
		].
	].

	getSelectors do: [:sel | 
		aPane _ possibles detect: [ :pane | pane getListSelector == sel] ifNone: [nil].
		aPane
			ifNotNil:
				[aList add: aPane]
			ifNil:
				[Transcript cr; show: 'Warning: pane ', sel, ' not found.']].
	updatablePanes _ aList asArray! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 12/21/1998 23:24'!
titleAndPaneText
	"If the receiver represents a workspace, return an Association between the title and that text, else return nil"
	(paneMorphs size ~~ 1 or: [(paneMorphs first isKindOf: PluggableTextMorph) not])
		ifTrue: [^ nil].
	^ labelString -> paneMorphs first text

! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:53'!
updatablePanes
	"Answer the list of panes, in order, which should be sent the #verifyContents message"
	^ updatablePanes ifNil: [updatablePanes _ #()]! !

!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 16:06'!
updateBox: anIconMorph color: aColor 
	| fill |
	anIconMorph isNil
		ifTrue: [^ self].
	anIconMorph
		extent: self boxExtent;
		useRoundedCorners.
	fill := GradientFillStyle ramp: {0.0 -> aColor muchLighter muchLighter. 1.0 -> aColor twiceDarker}.
	
	fill origin: anIconMorph topLeft + (5 @ 5).
	fill direction: anIconMorph extent.

	anIconMorph fillStyle: fill.
	anIconMorph borderWidth: (Preferences alternativeWindowBoxesLook
				ifTrue: [1]
				ifFalse: [0]);
		borderColor: aColor darker! !

!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:36'!
updateBoxesColor: aColor 
	| opaqueColor |
	aColor isNil
		ifTrue: [^ self].
	Preferences alternativeWindowBoxesLook ifFalse:[^ self].
	
	opaqueColor := aColor asNontranslucentColor.
	
	self
		updateBox: closeBox
		color: (opaqueColor alphaMixed: 0.5 with: Color red).
	self updateBox: menuBox color: opaqueColor.
	self updateBox: expandBox color: opaqueColor.
	self updateBox: collapseBox color: opaqueColor! !

!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:36'!
updatePaneColors
	"Useful when changing from monochrome to color display"

	self setStripeColorsFrom: self paneColorToUse.! !


!SystemWindow methodsFor: 'resize/collapse' stamp: 'dns 2/2/2000 14:20'!
allowReframeHandles

	^ allowReframeHandles! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'dns 2/2/2000 14:20'!
allowReframeHandles: aBoolean

	allowReframeHandles := aBoolean! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'ar 2/10/1999 04:19'!
collapse
	self isCollapsed ifFalse:[self collapseOrExpand]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jrp 7/27/2005 22:44'!
collapseOrExpand
	"Collapse or expand the window, depending on existing state"
	| cf |
	isCollapsed
		ifTrue: 
			["Expand -- restore panes to morphics structure"
			isCollapsed _ false.
			self activate.  "Bring to frint first"
			Preferences collapseWindowsInPlace
				ifTrue: 
					[fullFrame _ fullFrame align: fullFrame topLeft with: self getBoundsWithFlex topLeft]
				ifFalse:
					[collapsedFrame _ self getBoundsWithFlex].
			collapseBox ifNotNil: [collapseBox setBalloonText: 'collapse this window'].
			self setBoundsWithFlex: fullFrame.
			paneMorphs reverseDo: 
					[:m |  self addMorph: m unlock.
					self world startSteppingSubmorphsOf: m].
			self addPaneSplitters]
		ifFalse: 
			["Collapse -- remove panes from morphics structure"
			isCollapsed _ true.
			fullFrame _ self getBoundsWithFlex.
			"First save latest fullFrame"
			paneMorphs do: [:m | m delete; releaseCachedState].
			self removePaneSplitters.
			self removeCornerGrips.
			model modelSleep.
			cf _ self getCollapsedFrame.
			(collapsedFrame isNil and: [Preferences collapseWindowsInPlace not]) ifTrue:
				[collapsedFrame _ cf].
			self setBoundsWithFlex: cf.
			collapseBox ifNotNil: [collapseBox setBalloonText: 'expand this window'].
			expandBox ifNotNil: [expandBox setBalloonText: 'expand to full screen']].
	self layoutChanged! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/20/1998 08:25'!
collapsedFrame
	^ collapsedFrame! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'md 2/24/2006 22:41'!
doFastWindowReframe: ptName

	| newBounds |
	"For fast display, only higlight the rectangle during loop"
	newBounds _ self bounds newRectButtonPressedDo: [:f | 
		f 
			withSideOrCorner: ptName
			setToPoint: (self pointFromWorld: Sensor cursorPoint)
			minExtent: self minimumExtent].
	self bounds: newBounds.
	^newBounds.! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'ar 2/10/1999 04:20'!
expand
	self isCollapsed ifTrue:[self collapseOrExpand]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'dgd 12/15/2003 10:34'!
expandBoxHit
	"The full screen expand box has been hit"

	isCollapsed
		ifTrue: [self hide.
			self collapseOrExpand.
			self unexpandedFrame ifNil: [ self unexpandedFrame: fullFrame. ].
			self fullScreen.
			expandBox setBalloonText: 'contract to original size' translated.
			^ self show].
	self unexpandedFrame
		ifNil: [self unexpandedFrame: fullFrame.
			self fullScreen.
			expandBox setBalloonText: 'contract to original size' translated]
		ifNotNil: [self bounds: self unexpandedFrame.
			self unexpandedFrame: nil.
			expandBox setBalloonText: 'expand to full screen' translated]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 13:21'!
fastFramingOn

	^ Preferences fastDragWindowForMorphic and: [self isFlexed not]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/20/1998 08:25'!
fullFrame
	^ fullFrame! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 14:14'!
getBoundsWithFlex
	"Return the lastest bounds rectangle with origin forced to global coordinates"

	self isFlexed
		ifTrue: [^ ((owner transform localPointToGlobal: bounds topLeft)
										extent: bounds extent)]
		ifFalse: [^ self bounds].
! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'svp 8/21/2001 11:13'!
getCollapsedFrame

	| tmp |
	^Preferences collapseWindowsInPlace 
		ifTrue:
			[tmp := self getBoundsWithFlex.
			tmp origin corner: (tmp corner x @ 18)]
		ifFalse:
			[RealEstateAgent assignCollapseFrameFor: self]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/19/1998 09:34'!
isCollapsed
	^ isCollapsed! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jm 6/17/1998 11:55'!
mouseLeaveEvent: event fromPane: pane
	"For backward compatibility only.  Not used by any newly created window"
	(pane isKindOf: ScrollPane) ifTrue: [pane mouseLeave: event].
! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/21/1998 16:12'!
paneWithLongestSide: sideBlock near: aPoint 
	| thePane theSide theLen box |
	theLen _ 0.
	paneMorphs do:
		[:pane | box _ pane bounds.
		box forPoint: aPoint closestSideDistLen:
			[:side :dist :len |
			(dist <= 5 and: [len > theLen]) ifTrue:
				[thePane _ pane.
				theSide _ side.
				theLen _ len]]].
	sideBlock value: theSide.
	^ thePane! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/22/1998 22:55'!
reframePanesAdjoining: growingPane along: side to: aDisplayBox 
	| delta newRect minDim theMin horiz |
	growingPane ifNil: [^ self].  "As from click outside"
	newRect _ aDisplayBox.
	horiz _ #(left right) includes: side.
	theMin _ horiz ifTrue: [40] ifFalse: [20].

	"First check that this won't make any pane smaller than theMin screen dots"
	minDim _ (((paneMorphs select: [:pane | pane bounds bordersOn: growingPane bounds along: side])
		collect: [:pane | pane bounds adjustTo: newRect along: side]) copyWith: aDisplayBox)
			inject: 999 into:
				[:was :rect | was min: (horiz ifTrue: [rect width] ifFalse: [rect height])].
	"If so, amend newRect as required"
	minDim > theMin ifFalse:
		[delta _ minDim - theMin.
		newRect _ newRect withSide: side setTo: 
				((newRect perform: side) > (growingPane bounds perform: side)
					ifTrue: [(newRect perform: side) + delta]
					ifFalse: [(newRect perform: side) - delta])].

	"Now adjust all adjoining panes for real"
	paneMorphs do:
		[:pane | (pane bounds bordersOn: growingPane bounds along: side) ifTrue:
			[pane bounds: (pane bounds adjustTo: newRect along: side)]].
	"And adjust the growing pane itself"
	growingPane bounds: newRect.

	"Finally force a recomposition of the whole window"
	self setPaneRectsFromBounds.
	self extent: self extent! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 14:15'!
setBoundsWithFlex: newFrame
	"Set bounds from newFrame with origin preserved from global coordinates"

	self isFlexed
		ifTrue: [super bounds: ((owner transform globalPointToLocal: newFrame topLeft)
										extent: newFrame extent)]
		ifFalse: [super bounds: newFrame].! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jlb 5/29/2001 23:06'!
unexpandedFrame
	"Return the frame size of an unexpanded window"

	^ self valueOfProperty: #unexpandedFrame! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jlb 5/29/2001 23:07'!
unexpandedFrame: aRectangle
	"Set the frame size of an unexpanded window"

	^ self setProperty: #unexpandedFrame toValue: aRectangle! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'sw 5/30/2001 10:56'!
wantsExpandBox
	"Answer whether I'd like an expand box"

	^ true! !


!SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 09:30'!
amendSteppingStatus
	"Circumstances having changed, find out whether stepping is wanted and assure that the new policy is carried out"

	self wantsSteps
		ifTrue:
			[self arrangeToStartStepping]
		ifFalse:
			[self stopStepping]! !

!SystemWindow methodsFor: 'stepping' stamp: 'di 4/9/2001 17:04'!
stepAt: millisecondClockValue
	"If the receiver is not collapsed, step it, after first stepping the model."

	(isCollapsed not or: [self wantsStepsWhenCollapsed]) ifTrue:
		[model ifNotNil: [model stepAt: millisecondClockValue in: self].
		super stepAt: millisecondClockValue "let player, if any, step"]

"Since this method ends up calling step, the model-stepping logic should not be duplicated there."! !

!SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:22'!
stepTime
	^ model
		ifNotNil:
			[model stepTimeIn: self]
		ifNil:
			[200] "milliseconds"! !

!SystemWindow methodsFor: 'stepping' stamp: 'jcg 9/6/2000 23:01'!
wantsSteps
	"Return true if the model wants its view to be stepped.  For an open system window, we give the model to offer an opinion"

	self isPartsDonor ifTrue: [^ false].
	self player wantsSteps ifTrue: [^ true].
	^ isCollapsed not and: [model wantsStepsIn: self]! !

!SystemWindow methodsFor: 'stepping' stamp: 'di 4/9/2001 16:45'!
wantsStepsWhenCollapsed
	"Default is not to bother updating collapsed windows"

	^ false! !


!SystemWindow methodsFor: 'testing' stamp: 'jam 3/9/2003 15:13'!
isSystemWindow
"answer whatever the receiver is a SystemWindow"
	^ true! !

!SystemWindow methodsFor: 'testing' stamp: 'ar 12/2/2001 21:43'!
shouldDropOnMouseUp
	"Return true for consistency with fastdrag"
	^true! !

!SystemWindow methodsFor: 'testing' stamp: 'ar 6/23/2001 16:06'!
wantsToBeCachedByHand
	"Return true if the receiver wants to be cached by the hand when it is dragged around."
	self hasTranslucentColor ifTrue:[^false].
	self bounds = self fullBounds ifTrue:[^true].
	self submorphsDo:[:m|
		(self bounds containsRect: m fullBounds) ifFalse:[
			m wantsToBeCachedByHand ifFalse:[^false].
		].
	].
	^true! !


!SystemWindow methodsFor: 'top window' stamp: 'sw 5/18/2001 23:20'!
activate
	"Bring me to the front and make me able to respond to mouse and keyboard"

	| oldTop outerMorph sketchEditor pal |
	outerMorph _ self topRendererOrSelf.
	outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"].
	oldTop _ TopWindow.
	TopWindow _ self.
	oldTop ifNotNil: [oldTop passivate].
	outerMorph owner firstSubmorph == outerMorph
		ifFalse: ["Bring me (with any flex) to the top if not already"
				outerMorph owner addMorphFront: outerMorph].
	self submorphsDo: [:m | m unlock].
	labelArea ifNotNil:
		[labelArea submorphsDo: [:m | m unlock].
		self setStripeColorsFrom: self paneColorToUse].
	self isCollapsed ifFalse:
		[model modelWakeUpIn: self.
		self positionSubmorphs.
		labelArea ifNil: [self adjustBorderUponActivationWhenLabeless]].

	(sketchEditor _ self extantSketchEditor) ifNotNil:
		[sketchEditor comeToFront.
		(pal _ self world findA: PaintBoxMorph) ifNotNil:
			[pal comeToFront]].
! !

!SystemWindow methodsFor: 'top window' stamp: 'sw 5/10/1999 15:42'!
activateAndForceLabelToShow
	self activate.
	bounds top < 0 ifTrue:
		[self position: (self position x @ 0)]! !

!SystemWindow methodsFor: 'top window' stamp: 'di 5/14/1998 11:49'!
activeOnlyOnTop
	^ activeOnlyOnTop ifNil: [false]! !

!SystemWindow methodsFor: 'top window' stamp: 'di 5/14/1998 12:38'!
activeOnlyOnTop: trueOrFalse
	activeOnlyOnTop _ trueOrFalse! !

!SystemWindow methodsFor: 'top window' stamp: 'sw 5/20/2001 22:32'!
adjustBorderUponActivationWhenLabeless
	"Adjust the border upon, um, activation when, um, labelless"

	| aWidth |
	(aWidth _ self valueOfProperty: #borderWidthWhenActive) ifNotNil:
		[self acquireBorderWidth: aWidth]! !

!SystemWindow methodsFor: 'top window' stamp: 'sw 5/20/2001 22:32'!
adjustBorderUponDeactivationWhenLabeless
	"Adjust the border upon deactivation when, labelless"

	| aWidth |
	(aWidth _ self valueOfProperty: #borderWidthWhenInactive) ifNotNil:
		[self acquireBorderWidth: aWidth]! !

!SystemWindow methodsFor: 'top window' stamp: 'LC 9/28/1999 19:04'!
extantSketchEditor
	"If my world has an extant SketchEditorMorph associated with anything  
	in this window, return that SketchEditor, else return nil"
	| w sketchEditor pasteUp |
	(w _ self world) isNil ifTrue: [^ nil].
	(sketchEditor _ w sketchEditorOrNil) isNil ifTrue: [^ nil].
	(pasteUp _ sketchEditor enclosingPasteUpMorph) isNil ifTrue: [^ nil].
	self findDeepSubmorphThat: [:m | m = pasteUp]
		ifAbsent: [^ nil].
	^ sketchEditor! !

!SystemWindow methodsFor: 'top window' stamp: 'di 5/14/1998 11:55'!
isActive
	self activeOnlyOnTop ifTrue: [^ self == TopWindow].
	^ true! !

!SystemWindow methodsFor: 'top window' stamp: 'aoy 2/15/2003 21:03'!
lockInactivePortions
	"Make me unable to respond to mouse and keyboard.  Control boxes remain active, except in novice mode"

	self submorphsDo: [:m | m == labelArea ifFalse: [m lock]].
	labelArea ifNotNil: 
			[labelArea submorphsDo: 
					[:m | 
					(m == closeBox or: [m == collapseBox]) 
						ifTrue: [m lock]]]! !

!SystemWindow methodsFor: 'top window' stamp: 'sw 5/18/2001 23:20'!
passivate
	"Make me unable to respond to mouse and keyboard"

	self setStripeColorsFrom: self paneColorToUse.
	model modelSleep.

	"Control boxes remain active, except in novice mode"
	self submorphsDo: [:m |
		m == labelArea ifFalse:
			[m lock]].
	labelArea ifNotNil:
		[labelArea submorphsDo: [:m |
			(m == closeBox or: [m == collapseBox])
				ifTrue:
					[Preferences noviceMode ifTrue: [m lock]]
				ifFalse:
					[m lock]]]
		ifNil: "i.e. label area is nil, so we're titleless"
			[self adjustBorderUponDeactivationWhenLabeless].
	self world ifNotNil:  "clean damage now, so dont merge this rect with new top window"
		[self world == World ifTrue: [self world displayWorld]].
! !

!SystemWindow methodsFor: 'top window' stamp: 'nk 8/6/2003 10:53'!
updatePanesFromSubmorphs
	"Having removed some submorphs, make sure this is reflected in my paneMorphs."
	paneMorphs _ paneMorphs select: [ :pane | submorphs includes: pane ].! !




!SystemWindow methodsFor: '*services-base' stamp: 'rr 3/24/2004 17:22'!
requestor
	[^model requestor] 
		on: Error 
		do: [Transcript show: 'no requestor for : ', model class name.^ Requestor default] ! !

!SystemWindow methodsFor: '*services-base' stamp: 'rr 3/10/2006 14:15'!
topWindow
	^ TopWindow! !


!SystemWindow methodsFor: 'thumbnail' stamp: 'dgd 9/22/2004 19:29'!
icon
	"Answer a form with an icon to represent the receiver"
	^ MenuIcons windowIcon! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemWindow class
	instanceVariableNames: ''!

!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 8/7/2005 17:09'!
borderWidth

	"Making changes to this for some reason requires repositioning of CornerGripMorphs.
	Edit BorderedMorph#addCornerGrip and play with offsets to get them right if you increase
	border width. For instance, going from 4 to 6 here and you should updated offsets to
	(-23@-23 corner: 0@0) for the right placement of corner grips."

	^ 4! !

!SystemWindow class methodsFor: 'initializing' stamp: 'RAA 12/21/2000 12:01'!
classVersion
	"Changed to 1 for SystemWindow Dec 2000 - see if this helps loading old ones"
	^ 1! !

!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 7/30/2005 22:51'!
closeBoxImage
	"Supplied here because we don't necessarily have ComicBold"

	^ CloseBoxImage ifNil: [CloseBoxImage _ (Form
	extent: 10@10
	depth: 32
	fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 3326099520 3330310272 0 0 0 0 0 0 0 0 4144038145 3326099520 3330310272 0 0 0 4144038145 3326099520 0 0 0 4227924225 3326099520 3330310272 0 4144038145 3326099520 3330310272 0 0 0 0 4144038145 3326099520 4144038145 3326099520 3330310272 3336494814 0 0 0 0 0 4227924225 3326099520 3330310272 3336494814 0 0 0 0 0 4144038145 3326099520 4144038145 3326099520 3330310272 3336494814 0 0 0 4144038145 3326099520 3330310272 3336494814 4144038145 3326099520 3330310272 0 0 4144038145 3326099520 3330310272 3336494814 0 0 4144038145 3326099520 0 0 0 3330310272 3336494814 0 0 0 0 0 0)
	offset: 0@0)]! !

!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 7/31/2005 13:21'!
collapseBoxImage
	"Supplied here because we don't necessarily have ComicBold"

	^ CollapseBoxImage ifNil: [ CollapseBoxImage _ (Form
	extent: 10@10
	depth: 32
	fromArray: #( 0 0 4127260929 4127260929 4127260929 4127260929 4127260929 0 0 0 0 3875602689 3212869760 3212869760 3212869760 3212869760 3212869760 4227924225 0 0 4127260929 3212869760 3212869760 0 0 0 0 3212869760 4127260929 0 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4128708375 3212869760 0 0 0 0 0 0 4127260929 3212869760 0 4127260929 3212869760 0 0 0 0 4127260929 3208659008 3212869760 0 3208659008 4127260929 4127260929 4127260929 4127260929 4127260929 3208659008 3212869760 0 0 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 0 0)
	offset: 0@0)]! !

!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 7/31/2005 12:30'!
expandBoxImage

	^ (Form
	extent: 10@10
	depth: 32
	fromArray: #( 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 0 0 0 0 3875602689 0 0 0 0 4127260929 3877181721 3877181721 3875602689 0 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 4127260929 3875602689 3875602689 3875602689 3875602689 3212869760 0 3875602689 3212869760 0 3877181721 3212869760 3212869760 3212869760 3212869760 3212869760 0 3875602689 3212869760 0 3877181721 0 0 0 0 0 0 3875602689 3212869760 0 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3212869760 0 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760)
	offset: 0@0)! !

!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 8/9/2005 19:22'!
initialize

	CollapseBoxImage _ nil.
	CloseBoxImage _ nil.
	ScriptingSystem saveForm: self expandBoxImage atKey: 'expandBox'.
	ScriptingSystem saveForm: self menuBoxImage atKey: 'TinyMenu'! !

!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 7/31/2005 13:28'!
menuBoxImage

	^ (Form
	extent: 10@10
	depth: 32
	fromArray: #( 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4227858432 0 4127195136 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4227858432 3212869760 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760)
	offset: 0@0)! !


!SystemWindow class methodsFor: 'instance creation' stamp: 'di 6/18/97 05:31'!
labelled: labelString
	^ (self basicNew setLabel: labelString) initialize! !


!SystemWindow class methodsFor: 'new-morph participation' stamp: 'di 2/3/98 11:54'!
includeInNewMorphMenu
	"Include my subclasses but not me"
	^ self ~~ SystemWindow! !


!SystemWindow class methodsFor: 'top window' stamp: 'RAA 7/7/2000 09:34'!
clearTopWindow

	TopWindow _ nil.	"if leaving morphic to export from mvc, this ref could cause problems"! !

!SystemWindow class methodsFor: 'top window' stamp: 'sw 12/6/2000 20:13'!
closeTopWindow
	"Try to close the top window.  It may of course decline"

	TopWindow ifNotNil:
		[TopWindow delete]! !

!SystemWindow class methodsFor: 'top window' stamp: 'gm 2/16/2003 20:55'!
noteTopWindowIn: aWorld
	| newTop |
	"TopWindow must be nil or point to the top window in this project."
	TopWindow _ nil.
	aWorld ifNil: [^ self].
	newTop _ nil.
	aWorld submorphsDo:
		[:m | (m isSystemWindow) ifTrue:
			[(newTop == nil and: [m activeOnlyOnTop])
				ifTrue: [newTop _ m].
			(m model isKindOf: Project)
				ifTrue: ["This really belongs in a special ProjWindow class"
						m label ~= m model name ifTrue: [m setLabel: m model name]]]].
	newTop == nil ifFalse: [newTop activate]! !

!SystemWindow class methodsFor: 'top window' stamp: 'sw 12/6/2000 19:43'!
sendTopWindowToBack
	"Send the top window of the world to the back, activating the one just beneath it"

	TopWindow ifNotNil:
		[TopWindow sendToBack]! !

!SystemWindow class methodsFor: 'top window' stamp: 'sw 1/4/2000 15:22'!
wakeUpTopWindowUponStartup
	TopWindow ifNotNil:
		[TopWindow isCollapsed ifFalse:
			[TopWindow model ifNotNil:
				[TopWindow model modelWakeUpIn: TopWindow]]]! !

!SystemWindow class methodsFor: 'top window' stamp: 'gm 2/16/2003 20:55'!
windowsIn: aWorld satisfying: windowBlock
	| windows s |

	windows _ OrderedCollection new.
	aWorld ifNil: [^windows].	"opening MVC in Morphic - WOW!!"
	aWorld submorphs do:
		[:m |
		((m isSystemWindow) and: [windowBlock value: m])
			ifTrue: [windows addLast: m]
			ifFalse: [((m isKindOf: TransformationMorph) and: [m submorphs size = 1])
					ifTrue: [s _ m firstSubmorph.
							((s isSystemWindow) and: [windowBlock value: s])
								ifTrue: [windows addLast: s]]]].
	^ windows! !


!SystemWindow class methodsFor: '*services-base' stamp: 'rr 3/10/2006 14:19'!
topWindow
	^ TopWindow! !
SystemWindow subclass: #SystemWindowWithButton
	instanceVariableNames: 'buttonInTitle'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!SystemWindowWithButton commentStamp: '<historical>' prior: 0!
A SystemWindow with a single extra button in its title bar.!


!SystemWindowWithButton methodsFor: 'as yet unclassified' stamp: 'wiz 2/14/2006 02:07'!
adjustExtraButton
	buttonInTitle ifNil: [^ self].
	buttonInTitle align: buttonInTitle topLeft with:  self innerBounds topRight - (buttonInTitle width + 20 @ -3)! !

!SystemWindowWithButton methodsFor: 'as yet unclassified' stamp: 'sw 2/15/1999 22:41'!
buttonInTitle: aButton
	buttonInTitle _ aButton.
	self addMorphFront: aButton! !


!SystemWindowWithButton methodsFor: 'geometry' stamp: 'sw 9/29/1999 07:26'!
extent: newExtent
	super extent: (newExtent max: 120 @ 50).
	self adjustExtraButton! !


!SystemWindowWithButton methodsFor: 'label' stamp: 'sw 9/29/1999 07:27'!
setLabelWidgetAllowance
	^ labelWidgetAllowance _ 115! !


!SystemWindowWithButton methodsFor: 'resize/collapse' stamp: 'sw 5/30/2001 11:11'!
wantsExpandBox
	"Answer whether I'd like an expand box"

	^ false! !
Trait named: #TAccessingMethodDictDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TAccessingMethodDictDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 20:36'!
addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor
	| priorMethodOrNil |
	priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil].
	self addSelectorSilently: selector withMethod: compiledMethod.
	SystemChangeNotifier uniqueInstance 
		doSilently: [self organization classify: selector under: category].
	priorMethodOrNil isNil
		ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor]
		ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! !

!TAccessingMethodDictDescription methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 09:51'!
addSelectorSilently: selector withMethod: compiledMethod
	super addSelectorSilently: selector withMethod: compiledMethod.
	self instanceSide noteAddedSelector: selector meta: self isMeta.! !

!TAccessingMethodDictDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 20:33'!
addSelector: selector withMethod: compiledMethod notifying: requestor
	| priorMethodOrNil |
	priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil].
	self addSelectorSilently: selector withMethod: compiledMethod.
	priorMethodOrNil isNil
		ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor]
		ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! !

!TAccessingMethodDictDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/9/2004 16:36'!
noteAddedSelector: aSelector meta: isMeta
	"A hook allowing some classes to react to adding of certain selectors"! !

!TAccessingMethodDictDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 20:49'!
removeSelector: selector 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."
	
	| priorMethod priorProtocol | 
	priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil].
	priorProtocol _ self whichCategoryIncludesSelector: selector.
	super removeSelector: selector.
	SystemChangeNotifier uniqueInstance 
		doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil].
	SystemChangeNotifier uniqueInstance 
			methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TAccessingMethodDictDescription classTrait
	uses: {}!
Trait named: #TAccessingTraitCompositionBehavior
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TAccessingTraitCompositionBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:51'!
addExclusionOf: aSymbol to: aTrait
	self setTraitComposition: (
		self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! !

!TAccessingTraitCompositionBehavior methodsFor: 'traits' stamp: 'al 1/9/2006 17:58'!
addToComposition: aTrait
	self setTraitComposition: (self traitComposition copyTraitExpression
		add: aTrait;
		yourself)! !

!TAccessingTraitCompositionBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:54'!
removeAlias: aSymbol of: aTrait
	self setTraitComposition: (
		self traitComposition copyWithoutAlias: aSymbol of: aTrait)! !

!TAccessingTraitCompositionBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:54'!
removeFromComposition: aTrait
	self setTraitComposition: (self traitComposition copy
		removeFromComposition: aTrait)! !

!TAccessingTraitCompositionBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:55'!
traitOrClassOfSelector: aSymbol
	"Return the trait or the class which originally defines the method aSymbol
	or return self if locally defined or if it is a conflict marker method.
	This is primarly used by Debugger to determin the behavior in which a recompiled
	method should be put. If a conflict method is recompiled it should be put into
	the class, thus return self. Also see TraitComposition>>traitProvidingSelector:"
	
	((self includesLocalSelector: aSymbol) or: [
		self hasTraitComposition not]) ifTrue: [^self].
	^(self traitComposition traitProvidingSelector: aSymbol) ifNil: [self]! !

!TAccessingTraitCompositionBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:55'!
traitsProvidingSelector: aSymbol
	| result |
	result _ OrderedCollection new.
	self hasTraitComposition ifFalse: [^result].
	(self traitComposition methodDescriptionsForSelector: aSymbol)
		do: [:methodDescription | methodDescription selector = aSymbol ifTrue: [
			result addAll: (methodDescription locatedMethods
				collect: [:each | each location])]].
	^result! !


!TAccessingTraitCompositionBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:37'!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my or in another composition somewhere deeper in 
	the tree of traits compositions."

	^(self includesLocalSelector: aSymbol) not
		and: [self hasTraitComposition]
		and: [self traitComposition isAliasSelector: aSymbol]! !

!TAccessingTraitCompositionBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:37'!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in my trait composition."

	^(self includesLocalSelector: aSymbol) not
		and: [self hasTraitComposition]
		and: [self traitComposition isLocalAliasSelector: aSymbol]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TAccessingTraitCompositionBehavior classTrait
	uses: {}!
Trait named: #TApplyingOnClassSide
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TApplyingOnClassSide methodsFor: 'composition' stamp: 'al 7/30/2004 09:07'!
assertConsistantCompositionsForNew: aTraitComposition
	"Applying or modifying a trait composition on the class side
	of a behavior has some restrictions."

	| baseTraits notAddable message |
	baseTraits _ aTraitComposition traits select: [:each | each isBaseTrait].
	baseTraits isEmpty ifFalse: [
		notAddable _ (baseTraits reject: [:each | each classSide methodDict isEmpty]).
		notAddable isEmpty ifFalse: [
			message _ String streamContents: [:stream |
				stream nextPutAll: 'You can not add the base trait(s)'; cr.
				notAddable
					do: [:each | stream nextPutAll: each name]
					separatedBy: [ stream nextPutAll: ', '].
				stream cr; nextPutAll: 'to this composition because it/they define(s) methods on the class side.'].
		^TraitCompositionException signal: message]].
		
	(self instanceSide traitComposition traits asSet =
			(aTraitComposition traits
				select: [:each | each isClassTrait]
				thenCollect: [:each | each baseTrait]) asSet) ifFalse: [
				^TraitCompositionException signal: 'You can not add or remove class side traits on
				the class side of a composition. (But you can specify aliases or exclusions
				for existing traits or add a trait which does not have any methods on the class side.)']! !

!TApplyingOnClassSide methodsFor: 'composition' stamp: 'apb 8/24/2005 14:15'!
noteNewBaseTraitCompositionApplied: aTraitComposition
	"The argument is the new trait composition of my base trait - add
	the new traits or remove non existing traits on my class side composition.
	(Each class trait in my composition has its base trait on the instance side
	of the composition - manually added traits to the class side are always 
	base traits.)"
	
	| newComposition traitsFromInstanceSide |
	traitsFromInstanceSide := self traitComposition traits
		select: [:each | each isClassTrait]
		thenCollect: [:each | each baseTrait].
		
	newComposition := self traitComposition copyTraitExpression.
	(traitsFromInstanceSide copyWithoutAll: aTraitComposition traits) do: [:each |
		newComposition removeFromComposition: each classTrait].
	(aTraitComposition traits copyWithoutAll: traitsFromInstanceSide) do: [:each |
		newComposition add:  (each classTrait)].

	self setTraitComposition: newComposition! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TApplyingOnClassSide classTrait
	uses: {}!
Trait named: #TBasicCategorisingDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TBasicCategorisingDescription methodsFor: 'organization' stamp: 'dvf 8/19/2005 11:31'!
methodReferencesInCategory: aCategoryName
	^(self organization listAtCategoryNamed: aCategoryName)
		collect: [:ea | MethodReference new
						setClassSymbol: self theNonMetaClass name
						classIsMeta: self isMeta
						methodSymbol: ea
						stringVersion: '']
! !

!TBasicCategorisingDescription methodsFor: 'organization' stamp: 'al 5/9/2004 19:19'!
reorganize
	"During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization.  See the transfer of control where ReadWriteStream fileIn calls scanFrom:"

	^self organization! !

!TBasicCategorisingDescription methodsFor: 'organization' stamp: 'al 5/8/2004 19:15'!
whichCategoryIncludesSelector: aSelector 
	"Answer the category of the argument, aSelector, in the organization of 
	the receiver, or answer nil if the receiver does not inlcude this selector."

	(self includesSelector: aSelector)
		ifTrue: [^ self organization categoryOfElement: aSelector]
		ifFalse: [^nil]! !

!TBasicCategorisingDescription methodsFor: 'organization' stamp: 'al 5/8/2004 19:29'!
zapOrganization
	"Remove the organization of this class by message categories.
	This is typically done to save space in small systems.  Classes and methods
	created or filed in subsequently will, nonetheless, be organized"

	self organization: nil.
	self isClassSide ifFalse: [self classSide zapOrganization]! !


!TBasicCategorisingDescription methodsFor: 'private' stamp: 'al 5/8/2004 19:24'!
errorCategoryName
	self error: 'Category name must be a String'! !


!TBasicCategorisingDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 19:50'!
removeCategory: aString 
	"Remove each of the messages categorized under aString in the method 
	dictionary of the receiver. Then remove the category aString."
	| categoryName |
	categoryName _ aString asSymbol.
	(self organization listAtCategoryNamed: categoryName) do:
		[:sel | self removeSelector: sel].
	self organization removeCategory: categoryName! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TBasicCategorisingDescription classTrait
	uses: {}!
Trait named: #TBehaviorCategorization
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TBehaviorCategorization methodsFor: 'organization' stamp: 'al 3/18/2006 13:46'!
category
	"Answer the system organization category for the receiver. First check whether the
	category name stored in the ivar is still correct and only if this fails look it up
	(latter is much more expensive)"

	| result |
	self basicCategory ifNotNilDo: [ :symbol |
		((SystemOrganization listAtCategoryNamed: symbol) includes: self name)
			ifTrue: [ ^symbol ] ].
	self basicCategory: (result := SystemOrganization categoryOfElement: self name).
	^result! !

!TBehaviorCategorization methodsFor: 'organization' stamp: 'al 3/18/2006 13:35'!
category: aString 
	"Categorize the receiver under the system category, aString, removing it from 
	any previous categorization."

	| oldCategory |
	oldCategory := self basicCategory.
	aString isString
		ifTrue: [
			self basicCategory: aString asSymbol.
			SystemOrganization classify: self name under: self basicCategory ]
		ifFalse: [self errorCategoryName].
	SystemChangeNotifier uniqueInstance
		class: self recategorizedFrom: oldCategory to: self basicCategory! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TBehaviorCategorization classTrait
	uses: {}!
Trait named: #TCommentDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TCommentDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 17:13'!
classComment: aString
	"Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing.  Empty string gets stored only if had a non-empty one before."
	^ self classComment: aString stamp: '<historical>'! !

!TCommentDescription methodsFor: 'fileIn/Out' stamp: 'al 12/1/2005 15:43'!
classComment: aString stamp: aStamp
	"Store the comment, aString or Text or RemoteString, associated with the class we are organizing.  Empty string gets stored only if had a non-empty one before."

	| ptr header file oldCommentRemoteStr |
	(aString isKindOf: RemoteString) ifTrue:
		[SystemChangeNotifier uniqueInstance classCommented: self.
		^ self organization classComment: aString stamp: aStamp].

	oldCommentRemoteStr _ self organization commentRemoteStr.
	(aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil].
		"never had a class comment, no need to write empty string out"

	ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer].
	SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil:
		[file setToEnd; cr; nextPut: $!!.	"directly"
		"Should be saying (file command: 'H3') for HTML, but ignoring it here"
		header _ String streamContents: [:strm | strm nextPutAll: self name;
			nextPutAll: ' commentStamp: '.
			aStamp storeOn: strm.
			strm nextPutAll: ' prior: '; nextPutAll: ptr printString].
		file nextChunkPut: header]].
	self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp.
	SystemChangeNotifier uniqueInstance classCommented: self.
! !

!TCommentDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 17:14'!
commentFollows 
	"Answer a ClassCommentReader who will scan in the comment."

	^ ClassCommentReader new setClass: self category: #Comment

	"False commentFollows inspect"! !

!TCommentDescription methodsFor: 'fileIn/Out' stamp: 'al 11/28/2005 22:18'!
commentStamp: changeStamp
	self organization commentStamp: changeStamp.
	^ self commentStamp: changeStamp prior: 0! !

!TCommentDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 17:15'!
commentStamp: changeStamp prior: indexAndOffset
	"Prior source link ignored when filing in."

	^ ClassCommentReader new setClass: self
				category: #Comment
				changeStamp: changeStamp! !


!TCommentDescription methodsFor: 'accessing comment' stamp: 'dvf 9/27/2005 16:55'!
comment
	"Answer the receiver's comment. (If missing, supply a template) "
	| aString |
	aString := self instanceSide organization classComment.
	aString isEmpty ifFalse: [^ aString].
	^self classCommentBlank! !

!TCommentDescription methodsFor: 'accessing comment' stamp: 'al 5/9/2004 17:05'!
comment: aStringOrText
	"Set the receiver's comment to be the argument, aStringOrText."

	self instanceSide classComment: aStringOrText.! !

!TCommentDescription methodsFor: 'accessing comment' stamp: 'al 5/9/2004 17:07'!
comment: aStringOrText stamp: aStamp
	"Set the receiver's comment to be the argument, aStringOrText."

	self instanceSide classComment: aStringOrText stamp: aStamp.! !

!TCommentDescription methodsFor: 'accessing comment' stamp: 'al 5/9/2004 17:09'!
hasComment
	"return whether this class truly has a comment other than the default"
	| org |
	org _ self instanceSide organization.
	^org classComment isEmptyOrNil not! !


!TCommentDescription methodsFor: '*ob-standard-converting' stamp: 'cwp 7/14/2006 16:24'!
asCommentNode
	^ OBClassCommentNode on: self theNonMetaClass 
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TCommentDescription classTrait
	uses: {}!
Trait named: #TCompilingBehavior
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TCompilingBehavior methodsFor: 'adding/removing methods' stamp: 'al 11/28/2005 11:31'!
addSelectorSilently: selector withMethod: compiledMethod
	self basicAddSelector: selector withMethod: compiledMethod! !

!TCompilingBehavior methodsFor: 'adding/removing methods' stamp: 'al 7/30/2004 22:43'!
addSelector: selector withMethod: compiledMethod 
	^ self addSelector: selector withMethod: compiledMethod notifying: nil! !

!TCompilingBehavior methodsFor: 'adding/removing methods' stamp: 'al 7/30/2004 22:43'!
addSelector: selector withMethod: compiledMethod notifying: requestor
	^ self addSelectorSilently: selector withMethod: compiledMethod! !

!TCompilingBehavior methodsFor: 'adding/removing methods' stamp: 'md 2/18/2006 20:07'!
basicAddSelector: selector withMethod: compiledMethod 
	"Add the message selector with the corresponding compiled method to the 
	receiver's method dictionary.
	Do this without sending system change notifications"

	| oldMethodOrNil |
	oldMethodOrNil _ self lookupSelector: selector.
	self methodDict at: selector put: compiledMethod.
	compiledMethod methodClass: self.
	compiledMethod selector: selector.

	"Now flush Squeak's method cache, either by selector or by method"
	oldMethodOrNil == nil ifFalse: [oldMethodOrNil flushCache].
	selector flushCache.! !

!TCompilingBehavior methodsFor: 'adding/removing methods' stamp: 'al 7/30/2004 22:43'!
basicRemoveSelector: selector 
	"Assuming that the argument, selector (a Symbol), is a message selector 
	in my method dictionary, remove it and its method."

	| oldMethod |
	oldMethod _ self methodDict at: selector ifAbsent: [^ self].
	self methodDict removeKey: selector.

	"Now flush Squeak's method cache, either by selector or by method"
	oldMethod flushCache.
	selector flushCache! !

!TCompilingBehavior methodsFor: 'adding/removing methods' stamp: 'al 7/30/2004 22:50'!
removeSelectorSilently: selector 
	"Remove selector without sending system change notifications"

	^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! !

!TCompilingBehavior methodsFor: 'adding/removing methods' stamp: 'al 8/2/2004 16:39'!
removeSelector: selector 
	"Assuming that the argument, selector (a Symbol), is a message selector 
	in my method dictionary, remove it and its method."

	^ self basicRemoveSelector: selector
! !


!TCompilingBehavior methodsFor: 'compiling' stamp: 'md 3/5/2006 23:49'!
binding
	^ nil -> self! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'!
bindingOf: varName
	
	"Answer the binding of some variable resolved in the scope of the receiver"
	| aSymbol binding |
	aSymbol _ varName asSymbol.

	"Look in declared environment."
	binding _ self environment bindingOf: aSymbol.
	^binding! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:02'!
compileAll
	^ self compileAllFrom: self! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:02'!
compileAllFrom: oldClass
	"Compile all the methods in the receiver's method dictionary.
	This validates sourceCode and variable references and forces
	all methods to use the current bytecode set"
	"ar 7/10/1999: Use oldClass selectors not self selectors"
	
	oldClass selectorsDo: [:sel | self recompile: sel from: oldClass].
	self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'!
compilerClass
	"Answer a compiler class appropriate for source methods of this class."

	^Compiler! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 8/2/2004 19:34'!
compile: code 
	"Compile the argument, code, as source code in the context of the 
	receiver. Create an error notification if the code can not be compiled. 
	The argument is either a string or an object that converts to a string or a 
	PositionableStream on an object that converts to a string."

	^self compile: code notifying: nil! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'md 2/28/2006 10:04'!
compile: code classified: category notifying: requestor trailer: bytes ifFail: failBlock
	"Compile code without logging the source in the changes file"

	| methodNode |
	methodNode  := self compilerClass new
				compile: code
				in: self
				classified: category 
				notifying: requestor
				ifFail: failBlock.
	^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 21:52'!
compile: code notifying: requestor 
	"Compile the argument, code, as source code in the context of the 
	receiver and insEtall the result in the receiver's method dictionary. The 
	second argument, requestor, is to be notified if an error occurs. The 
	argument code is either a string or an object that converts to a string or 
	a PositionableStream. This method also saves the source code."
	
	| methodAndNode |
	methodAndNode  := self
		compile: code "a Text"
		classified: nil
		notifying: requestor
		trailer: self defaultMethodTrailer
		ifFail: [^nil].
	methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2
			withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr].
	self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor.
	^ methodAndNode selector! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'md 3/1/2006 20:01'!
decompilerClass
	"Answer a decompiler class appropriate for compiled methods of this class."

	^ self compilerClass decompilerClass! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'!
decompile: selector 
	"Find the compiled code associated with the argument, selector, as a 
	message selector in the receiver's method dictionary and decompile it. 
	Answer the resulting source code as a string. Create an error notification 
	if the selector is not in the receiver's method dictionary."

	^self decompilerClass new decompile: selector in: self! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 8/2/2004 19:57'!
defaultMethodTrailer
	^ #(0 0 0 0)! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'!
evaluatorClass
	"Answer an evaluator class appropriate for evaluating expressions in the 
	context of this class."

	^Compiler! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'!
parserClass
	"Answer a parser class to use for parsing method headers."

	^self compilerClass parserClass! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:17'!
recompileChanges
	"Compile all the methods that are in the changes file.
	This validates sourceCode and variable references and forces
	methods to use the current bytecode set"

	self selectorsDo:
		[:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue:
			[self recompile: sel from: self]]! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:17'!
recompileNonResidentMethod: method atSelector: selector from: oldClass
	"Recompile the method supplied in the context of this class."

	| trailer methodNode |
	trailer _ method trailer.
	methodNode _ self compilerClass new
			compile: (method getSourceFor: selector in: oldClass)
			in: self
			notifying: nil
			ifFail: ["We're in deep doo-doo if this fails (syntax error).
				Presumably the user will correct something and proceed,
				thus installing the result in this methodDict.  We must
				retrieve that new method, and restore the original (or remove)
				and then return the method we retrieved."
				^ self error: 'see comment'].
	selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
	^ methodNode generate: trailer
! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:03'!
recompile: selector
	"Compile the method associated with selector in the receiver's method dictionary."
	^self recompile: selector from: self! !

!TCompilingBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:03'!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."
	"ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:"
	| method trailer methodNode |
	method _ oldClass compiledMethodAt: selector.
	trailer _ method trailer.
	methodNode _ self compilerClass new
				compile: (oldClass sourceCodeAt: selector)
				in: self
				notifying: nil
				ifFail: [^ self].   "Assume OK after proceed from SyntaxError"
	selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
	self basicAddSelector: selector withMethod: (methodNode generate: trailer).
! !


!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 8/2/2004 16:29'!
compiledMethodAt: selector 
	"Answer the compiled method associated with the argument, selector (a 
	Symbol), a message selector in the receiver's method dictionary. If the 
	selector is not in the dictionary, create an error notification."

	^ self methodDict at: selector! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 20:55'!
compiledMethodAt: selector ifAbsent: aBlock
	"Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock"

	^ self methodDict at: selector ifAbsent: [aBlock value]! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 20:55'!
compress
	"Compact the method dictionary of the receiver."

	self methodDict rehash! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:01'!
compressedSourceCodeAt: selector
	"(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921
	Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450"
	| rawText parse |
	rawText _ (self sourceCodeAt: selector) asString.
	parse _ self compilerClass new parse: rawText in: self notifying: nil.
	^ rawText compressWithTable:
		((selector keywords ,
		parse tempNames ,
		self instVarNames ,
		#(self super ifTrue: ifFalse:) ,
		((0 to: 7) collect:
			[:i | String streamContents:
				[:s | s cr. i timesRepeat: [s tab]]]) ,
		(self compiledMethodAt: selector) literalStrings)
			asSortedCollection: [:a :b | a size > b size])! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 12/1/2005 15:40'!
firstCommentAt:  selector
	"Answer a string representing the first comment in the method associated with selector.  Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment.  Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote."

	|someComments|
	someComments := self commentsAt: selector.
	^someComments isEmpty ifTrue: [''] ifFalse: [someComments first]


"Behavior firstCommentAt: #firstCommentAt:"! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 11/28/2005 21:54'!
firstPrecodeCommentFor:  selector
	"If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil"

	| parser source tree |
	"Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:"
	(#(Comment Definition Hierarchy) includes: selector)
		ifTrue:
			["Not really a selector"
			^ nil].
	source _ self sourceCodeAt: selector asSymbol ifAbsent: [^ nil].
	parser _ self parserClass new.
	tree _ 
		parser
			parse: (ReadStream on: source)
			class: self
			noPattern: false
			context: nil
			notifying: nil
			ifFail: [^ nil].
	^ (tree comment ifNil: [^ nil]) first! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:02'!
methodDictionary
	"Convenience"
	^self methodDict! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/30/2005 18:24'!
methodDictionary: aDictionary
	self methodDict: aDictionary! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:02'!
methodsDo: aBlock
	"Evaluate aBlock for all the compiled methods in my method dictionary."

	^ self methodDict valuesDo: aBlock! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:03'!
selectors
	"Answer a Set of all the message selectors specified in the receiver's 
	method dictionary."

	^ self methodDict keys! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:03'!
selectorsAndMethodsDo: aBlock
	"Evaluate selectorBlock for all the message selectors in my method dictionary."

	^ self methodDict keysAndValuesDo: aBlock! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:03'!
selectorsDo: selectorBlock
	"Evaluate selectorBlock for all the message selectors in my method dictionary."

	^ self methodDict keysDo: selectorBlock! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:03'!
selectorsWithArgs: numberOfArgs
	"Return all selectors defined in this class that take this number of arguments.  Could use String.keywords.  Could see how compiler does this."

	| list num |
	list _ OrderedCollection new.
	self selectorsDo: [:aSel | 
		num _ aSel count: [:char | char == $:].
		num = 0 ifTrue: [aSel last isLetter ifFalse: [num _ 1]].
		num = numberOfArgs ifTrue: [list add: aSel]].
	^ list! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:04'!
sourceCodeAt: selector

	^ (self methodDict at: selector) getSourceFor: selector in: self! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:04'!
sourceCodeAt: selector ifAbsent: aBlock

	^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:04'!
sourceMethodAt: selector 
	"Answer the paragraph corresponding to the source code for the 
	argument."

	^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:05'!
sourceMethodAt: selector ifAbsent: aBlock
	"Answer the paragraph corresponding to the source code for the 
	argument."

	^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! !

!TCompilingBehavior methodsFor: 'accessing method dictionary' stamp: 'al 8/2/2004 16:26'!
>> selector 
	"Answer the compiled method associated with the argument, selector (a 
	Symbol), a message selector in the receiver's method dictionary. If the 
	selector is not in the dictionary, create an error notification."

	^self compiledMethodAt: selector
! !


!TCompilingBehavior methodsFor: 'copying' stamp: 'al 7/30/2004 22:51'!
copyOfMethodDictionary
	"Return a copy of the receiver's method dictionary"

	^ self methodDict copy! !


!TCompilingBehavior methodsFor: 'user interface' stamp: 'al 7/30/2004 22:38'!
crossReference
	"Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included."

	^self selectors asSortedCollection asArray collect: [:x | 		Array 
			with: (String with: Character cr), x 
			with: (self whichSelectorsReferTo: x)]

	"Point crossReference."! !


!TCompilingBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:35'!
fullyImplementsVocabulary: aVocabulary
	"Answer whether instances of the receiver respond to all the messages in aVocabulary"

	(aVocabulary encompassesAPriori: self) ifTrue: [^ true].
	aVocabulary allSelectorsInVocabulary do:
		[:aSelector | (self canUnderstand: aSelector) ifFalse: [^ false]].
	^ true! !

!TCompilingBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:28'!
hasMethods
	"Answer whether the receiver has any methods in its method dictionary."

	^ self methodDict size > 0! !

!TCompilingBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:35'!
implementsVocabulary: aVocabulary
	"Answer whether instances of the receiver respond to the messages in aVocabulary."

	(aVocabulary isKindOf: FullVocabulary orOf: ScreenedVocabulary) ifTrue: [^ true].
	^ self fullyImplementsVocabulary: aVocabulary! !

!TCompilingBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:35'!
includesSelector: aSymbol 
	"Answer whether the message whose selector is the argument is in the 
	method dictionary of the receiver's class."

	^ self methodDict includesKey: aSymbol! !

!TCompilingBehavior methodsFor: 'testing method dictionary' stamp: 'md 2/15/2006 11:01'!
thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a 
	literal. Dives into the compact literal notation, making it slow but 
	thorough "

	| who |
	who _ IdentitySet new.
	self selectorsAndMethodsDo:
		[:sel :method |
		((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]])
			ifTrue:
				[((literal isVariableBinding) not
					or: [method literals allButLast includes: literal])
						ifTrue: [who add: sel]]].
	^ who! !

!TCompilingBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:37'!
whichSelectorsReferTo: literal 
	"Answer a Set of selectors whose methods access the argument as a
literal."

	| special byte |
	special _ self environment hasSpecialSelector: literal ifTrueSetByte: [:b |
byte _ b].
	^self whichSelectorsReferTo: literal special: special byte: byte

	"Rectangle whichSelectorsReferTo: #+."! !

!TCompilingBehavior methodsFor: 'testing method dictionary' stamp: 'md 2/15/2006 11:01'!
whichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a literal."

	| who |
	who _ IdentitySet new.
	self selectorsAndMethodsDo: 
		[:sel :method |
		((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]])
			ifTrue:
				[((literal isVariableBinding) not
					or: [method literals allButLast includes: literal])
						ifTrue: [who add: sel]]].
	^ who! !


!TCompilingBehavior methodsFor: 'private' stamp: 'al 12/1/2005 15:20'!
spaceUsed
	"Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables."

	| space method |
	space _ 0.
	self selectorsDo: [:sel |
		space _ space + 16.  "dict and org'n space"
		method _ self compiledMethodAt: sel.
		space _ space + (method size + 6 "hdr + avg pad").
		method literals do: [:lit |
			(lit isMemberOf: Array) ifTrue: [space _ space + ((lit size + 1) * 4)].
			(lit isMemberOf: Float) ifTrue: [space _ space + 12].
			(lit isMemberOf: ByteString) ifTrue: [space _ space + (lit size + 6)].
			(lit isMemberOf: LargeNegativeInteger) ifTrue: [space _ space + ((lit size + 1) * 4)].
			(lit isMemberOf: LargePositiveInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]]].
		^ space! !


!TCompilingBehavior methodsFor: 'newcompiler' stamp: 'md 3/1/2006 21:23'!
parseScope

	^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TCompilingBehavior classTrait
	uses: {}!
Trait named: #TCompilingDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:00'!
acceptsLoggingOfCompilation
	"weird name is so that it will come lexically before #compile, so that a clean build can make it through.  7/7/96 sw"

	^ true! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:12'!
compileSilently: code classified: category
	"Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed."

	^ self compileSilently: code classified: category notifying: nil.! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:13'!
compileSilently: code classified: category notifying: requestor
	"Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed."

	^ SystemChangeNotifier uniqueInstance 
		doSilently: [self compile: code classified: category withStamp: nil notifying: requestor logSource: false].! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 11/28/2005 22:18'!
compile: code classified: heading 
	"Compile the argument, code, as source code in the context of the 
	receiver and install the result in the receiver's method dictionary under 
	the classification indicated by the second argument, heading. nil is to be 
	notified if an error occurs. The argument code is either a string or an 
	object that converts to a string or a PositionableStream on an object that 
	converts to a string."

	^self
		compile: code
		classified: heading
		notifying: nil! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:00'!
compile: text classified: category notifying: requestor
	| stamp |
	stamp _ self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil].
	^ self compile: text classified: category
		withStamp: stamp notifying: requestor! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:00'!
compile: text classified: category withStamp: changeStamp notifying: requestor
	^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 11/28/2005 22:21'!
compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource
	| methodAndNode |
	methodAndNode := self compile: text asString classified: category notifying: requestor
							trailer: self defaultMethodTrailer ifFail: [^nil].
	logSource ifTrue: [
		self logMethodSource: text forMethodWithNode: methodAndNode 
			inCategory: category withStamp: changeStamp notifying: requestor.
	].
	self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode 
		method inProtocol: category notifying: requestor.
	self instanceSide noteCompilationOf: methodAndNode selector meta: self isClassSide.
	^ methodAndNode selector! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:12'!
compile: code notifying: requestor 
	"Refer to the comment in Behavior|compile:notifying:." 

	^self compile: code
		 classified: ClassOrganizer default
		 notifying: requestor! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 6/29/2004 21:37'!
doneCompiling
	"A ClassBuilder has finished the compilation of the receiver.
	This message is a notification for a class that needs to do some
	cleanup / reinitialization after it has been recompiled."! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'dvf 9/27/2005 17:13'!
noteCompilationOf: aSelector meta: isMeta
	"A hook allowing some classes to react to recompilation of certain selectors"! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/9/2004 19:17'!
reformatAll
	"Reformat all methods in this class.
	Leaves old code accessible to version browsing"
	self selectorsDo: [:sel | self reformatMethodAt: sel]! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'dvf 9/27/2005 17:18'!
reformatMethodAt: selector
	| newCodeString method |
	newCodeString := self prettyPrinterClass 
				format: (self sourceCodeAt: selector)
				in: self
				notifying: nil
				decorated: false.
	method := self compiledMethodAt: selector.
	method 
		putSource: newCodeString
		fromParseNode: nil
		class: self
		category: (self organization categoryOfElement: selector)
		inFile: 2
		priorMethod: method
! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:13'!
wantsChangeSetLogging
	"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.  7/12/96 sw"

	^ true! !

!TCompilingDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:13'!
wantsRecompilationProgressReported
	"Answer whether the receiver would like progress of its recompilation reported interactively to the user."

	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TCompilingDescription classTrait
	uses: {}!
Trait named: #TComposingDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TComposingDescription methodsFor: 'private' stamp: 'apb 8/22/2005 17:53'!
addCompositionOnLeft: aTraitComposition
	^ aTraitComposition add: self! !

!TComposingDescription methodsFor: 'private' stamp: 'apb 8/22/2005 17:40'!
addOnTheLeft: aTraitExpression
	^TraitComposition with: aTraitExpression with: self! !


!TComposingDescription methodsFor: 'converting' stamp: 'apb 8/22/2005 15:47'!
asTraitComposition
	^TraitComposition with: self! !


!TComposingDescription methodsFor: 'composition' stamp: 'apb 8/22/2005 17:31'!
+ aTraitOrTraitComposition
	"Use double dispatch to avoid having nested composition in cases where
	parenthesis are used, such as T1 + (T2 + T3)"
	
	^aTraitOrTraitComposition addOnTheLeft: self! !

!TComposingDescription methodsFor: 'composition' stamp: 'apb 8/22/2005 17:12'!
- anArrayOfSelectors
	^TraitExclusion
		with: self
		exclusions: anArrayOfSelectors! !

!TComposingDescription methodsFor: 'composition' stamp: 'apb 8/22/2005 17:02'!
@ anArrayOfAssociations 
	^ TraitAlias with: self aliases: anArrayOfAssociations! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TComposingDescription classTrait
	uses: {}!
Trait named: #TCopyingDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TCopyingDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'!
copyAllCategoriesFrom: aClass 
	"Specify that the categories of messages for the receiver include all of 
	those found in the class, aClass. Install each of the messages found in 
	these categories into the method dictionary of the receiver, classified 
	under the appropriate categories."

	aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! !

!TCopyingDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'!
copyAll: selArray from: class 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	-As yet not classified-."

	self copyAll: selArray
		from: class
		classified: nil! !

!TCopyingDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'!
copyAll: selArray from: class classified: cat 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	the third argument, cat."

	selArray do: 
		[:s | self copy: s
				from: class
				classified: cat]! !

!TCopyingDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'!
copyCategory: cat from: class 
	"Specify that one of the categories of messages for the receiver is cat, as 
	found in the class, class. Copy each message found in this category."

	self copyCategory: cat
		from: class
		classified: cat! !

!TCopyingDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:55'!
copyCategory: cat from: aClass classified: newCat 
	"Specify that one of the categories of messages for the receiver is the 
	third argument, newCat. Copy each message found in the category cat in 
	class aClass into this new category."

	self copyAll: (aClass organization listAtCategoryNamed: cat)
		from: aClass
		classified: newCat! !

!TCopyingDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:55'!
copyMethodDictionaryFrom: donorClass
	"Copy the method dictionary of the donor class over to the receiver"

	self methodDict: donorClass copyOfMethodDictionary.
	self organization: donorClass organization deepCopy.! !

!TCopyingDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:53'!
copy: sel from: class 
	"Install the method associated with the first argument, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under -As yet not 
	classified-."

	self copy: sel
		from: class
		classified: nil! !

!TCopyingDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'!
copy: sel from: class classified: cat 
	"Install the method associated with the first arugment, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under the third 
	argument, cat."

	| code category |
	"Useful when modifying an existing class"
	code _ class sourceMethodAt: sel.
	code == nil
		ifFalse: 
			[cat == nil
				ifTrue: [category _ class organization categoryOfElement: sel]
				ifFalse: [category _ cat].
			(self methodDict includesKey: sel)
				ifTrue: [code asString = (self sourceMethodAt: sel) asString 
							ifFalse: [self error: self name 
										, ' ' 
										, sel 
										, ' will be redefined if you proceed.']].
			self compile: code classified: category]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TCopyingDescription classTrait
	uses: {}!
Trait named: #TFileInOutDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:34'!
definition
	"Answer a String that defines the receiver in good old ST-80."

	^ self definitionST80! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:50'!
fileOutCategory: catName 
	^ self fileOutCategory: catName asHtml: false! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 17:13'!
fileOutCategory: catName asHtml: useHtml
	"FileOut the named category, possibly in Html format."
	| internalStream |
	internalStream _ WriteStream on: (String new: 1000).
	internalStream header; timeStamp.
	self fileOutCategory: catName on: internalStream moveSource: false toFile: 0.
	internalStream trailer.

	FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true useHtml: useHtml.! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:51'!
fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the receiver's category, aString, onto aFileStream. If 
	moveSource, is true, then set the method source pointer to the new file position.
	Note when this method is called with moveSource=true, it is condensing the
	.sources file, and should only write one preamble per method category."

	| selectors |

	aFileStream cr.
	selectors := (aSymbol asString = ClassOrganizer allCategory)
				ifTrue: [ self organization allMethodSelectors ]
				ifFalse: [ self organization listAtCategoryNamed: aSymbol ].

	selectors _ selectors select: [:each | self includesLocalSelector: each].
	
	"Overridden to preserve author stamps in sources file regardless"
	selectors do: [:sel |
		self printMethodChunk: sel 
			withPreamble: true
			on: aFileStream 
			moveSource: moveSource 
			toFile: fileIndex].
	^ self! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:51'!
fileOutChangedMessages: aSet on: aFileStream 
	"File a description of the messages of the receiver that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream."

	self fileOutChangedMessages: aSet
		on: aFileStream
		moveSource: false
		toFile: 0! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:52'!
fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the messages of this class that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream.  If 
	moveSource, is true, then set the method source pointer to the new file position.
	Note when this method is called with moveSource=true, it is condensing the
	.changes file, and should only write a preamble for every method."
	| org sels |
	(org _ self organization) categories do: 
		[:cat | 
		sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
		sels do:
			[:sel |  self printMethodChunk: sel withPreamble: true on: aFileStream
							moveSource: moveSource toFile: fileIndex]]! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:52'!
fileOutMethod: selector
	"Write source code of a single method on a file.  Make up a name for the file."
	self fileOutMethod: selector asHtml: false! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 17:15'!
fileOutMethod: selector asHtml: useHtml
	"Write source code of a single method on a file in .st or .html format"

	| internalStream |
	(selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.'].
	(self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found'].
	internalStream _ WriteStream on: (String new: 1000).
	internalStream header; timeStamp.
	self printMethodChunk: selector withPreamble: true
		on: internalStream moveSource: false toFile: 0.

	FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true useHtml: useHtml.
! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:52'!
fileOutOn: aFileStream 
	"File a description of the receiver on aFileStream."

	self fileOutOn: aFileStream
		moveSource: false
		toFile: 0! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:53'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
	"File a description of the receiver on aFileStream. If the boolean 
	argument, moveSource, is true, then set the trailing bytes to the position 
	of aFileStream and to fileIndex in order to indicate where to find the 
	source code."

	aFileStream command: 'H3'.
		aFileStream nextChunkPut: self definition.
		aFileStream command: '/H3'.

	self organization
		putCommentOnFile: aFileStream
		numbered: fileIndex
		moveSource: moveSource
		forClass: self.
	self organization categories do: 
		[:heading |
		self fileOutCategory: heading
			on: aFileStream
			moveSource: moveSource
			toFile: fileIndex]! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:53'!
fileOutOrganizationOn: aFileStream
	"File a description of the receiver's organization on aFileStream."

	aFileStream cr; nextPut: $!!.
	aFileStream nextChunkPut: self name, ' reorganize'; cr.
	aFileStream nextChunkPut: self organization printString; cr! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:53'!
methods
	"Answer a ClassCategoryReader for compiling messages that are not classified, as in fileouts made with Smalltalk/V"

	^ ClassCategoryReader new setClass: self category: ClassOrganizer default! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:53'!
methodsFor: categoryName 
	"Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver."

	^ ClassCategoryReader new setClass: self category: categoryName asSymbol

	"(False methodsFor: 'logical operations') inspect"! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:54'!
methodsFor: aString priorSource: sourcePosition inFile: fileIndex
	"Prior source pointer ignored when filing in."
	^ self methodsFor: aString! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:54'!
methodsFor: categoryName stamp: changeStamp 
	^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:54'!
methodsFor: categoryName stamp: changeStamp prior: indexAndOffset
	"Prior source link ignored when filing in."
	^ ClassCategoryReader new setClass: self
				category: categoryName asSymbol
				changeStamp: changeStamp

"Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control.  So method will be placed in the proper category.  See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 7/9/2006 18:20'!
moveChangesTo: newFile 
	"Used in the process of condensing changes, this message requests that 
	the source code of all methods of the receiver that have been changed 
	should be moved to newFile."

	| changes |
	changes := self methodDict keys select: [:sel |
		(self compiledMethodAt: sel) fileIndex > 1 and: [
			(self includesLocalSelector: sel) or: [
				(self compiledMethodAt: sel) sendsToSuper]]].
	self
		fileOutChangedMessages: changes
		on: newFile
		moveSource: true
		toFile: 2! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:54'!
printCategoryChunk: categoryName on: aFileStream
	^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:55'!
printCategoryChunk: category on: aFileStream priorMethod: priorMethod
	^ self printCategoryChunk: category on: aFileStream
		withStamp: Utilities changeStamp priorMethod: priorMethod! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:55'!
printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod 
	"Print a method category preamble.  This must have a category name.
	It may have an author/date stamp, and it may have a prior source link.
	If it has a prior source link, it MUST have a stamp, even if it is empty."

"The current design is that changeStamps and prior source links are preserved in the changes file.  All fileOuts include changeStamps.  Condensing sources, however, eliminates all stamps (and links, natch)."

	aFileStream cr; command: 'H3'; nextPut: $!!.
	aFileStream nextChunkPut: (String streamContents:
		[:strm |
		strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString.
		(changeStamp ~~ nil and:
			[changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue:
			[strm nextPutAll: ' stamp: '; print: changeStamp].
		priorMethod ~~ nil ifTrue:
			[strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]).
	aFileStream command: '/H3'.! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:55'!
printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream
	^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp
		priorMethod: nil! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'md 2/22/2006 16:25'!
printMethodChunk: selector withPreamble: doPreamble on: outStream
		moveSource: moveSource toFile: fileIndex
	"Copy the source code for the method associated with selector onto the fileStream.  If moveSource true, then also set the source code pointer of the method."
	| preamble method oldPos newPos sourceFile endPos |
	doPreamble 
		ifTrue: [preamble _ self name , ' methodsFor: ' ,
					(self organization categoryOfElement: selector) asString printString]
		ifFalse: [preamble _ ''].
	method _ self methodDict at: selector ifAbsent:
		[outStream nextPutAll: selector; cr.
		outStream tab; nextPutAll: '** ERROR!!  THIS SCRIPT IS MISSING ** ' translated; cr; cr.
		outStream nextPutAll: '  '.
		^ outStream].

	((method fileIndex = 0
		or: [(SourceFiles at: method fileIndex) == nil])
		or: [(oldPos _ method filePosition) = 0])
		ifTrue:
		["The source code is not accessible.  We must decompile..."
		preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr].
		outStream nextChunkPut: method decompileString]
		ifFalse:
		[sourceFile _ SourceFiles at: method fileIndex.
		preamble size > 0
			ifTrue:    "Copy the preamble"
				[outStream copyPreamble: preamble from: sourceFile at: oldPos]
			ifFalse:
				[sourceFile position: oldPos].
		"Copy the method chunk"
		newPos _ outStream position.
		outStream copyMethodChunkFrom: sourceFile.
		sourceFile skipSeparators.      "The following chunk may have ]style["
		sourceFile peek == $] ifTrue: [
			outStream cr; copyMethodChunkFrom: sourceFile].
		moveSource ifTrue:    "Set the new method source pointer"
			[endPos _ outStream position.
			method checkOKToAdd: endPos - newPos at: newPos.
			method setSourcePosition: newPos inFile: fileIndex]].
	preamble size > 0 ifTrue: [outStream nextChunkPut: ' '].
	^ outStream cr! !

!TFileInOutDescription methodsFor: 'fileIn/Out' stamp: 'al 5/9/2004 18:56'!
putClassCommentToCondensedChangesFile: aFileStream
	"Called when condensing changes.  If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2.  Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday."

	| header aStamp aCommentRemoteStr |
	self isMeta ifTrue: [^ self].  "bulletproofing only"
	((aCommentRemoteStr _ self organization commentRemoteStr) isNil or:
		[aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self].

	aFileStream cr; nextPut: $!!.
	header _ String streamContents: [:strm | strm nextPutAll: self name;
		nextPutAll: ' commentStamp: '.
		(aStamp _ self organization commentStamp ifNil: ['<historical>']) storeOn: strm.
		strm nextPutAll: ' prior: 0'].
	aFileStream nextChunkPut: header.
	aFileStream cr.
	self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TFileInOutDescription classTrait
	uses: {}!
Trait named: #TPrintingDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TPrintingDescription methodsFor: 'printing' stamp: 'al 5/9/2004 16:50'!
printOnStream: aStream 
	aStream print: self name! !

!TPrintingDescription methodsFor: 'printing' stamp: 'al 5/9/2004 16:50'!
printOn: aStream 
	aStream nextPutAll: self name! !

!TPrintingDescription methodsFor: 'printing' stamp: 'al 5/9/2004 16:50'!
storeOn: aStream
	"Classes and Metaclasses have global names."

	aStream nextPutAll: self name! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TPrintingDescription classTrait
	uses: {}!
Trait named: #TPureBehavior
	uses: TCompilingBehavior @ {#methodDictAddSelectorSilently:withMethod:->#addSelectorSilently:withMethod:} + TUpdateTraitsBehavior + TAccessingTraitCompositionBehavior
	category: 'Traits-Kernel-Traits'!

!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 9/16/2005 14:31'!
addSelectorSilently: selector withMethod: compiledMethod
	self methodDictAddSelectorSilently: selector withMethod: compiledMethod.
	self registerLocalSelector: selector! !

!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 11/28/2005 11:47'!
localSelectors
	"Return a set of selectors defined locally.
	The instance variable is lazily initialized. If it is nil then there
	are no non-local selectors"

	^ self basicLocalSelectors isNil
		ifTrue: [self selectors]
		ifFalse: [self basicLocalSelectors].! !

!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 3/26/2006 21:37'!
removeSelector: aSelector 
	"Assuming that the argument, selector (a Symbol), is a message selector 
	in my method dictionary, remove it and its method.
	
	If the method to remove will be replaced by a method from my trait composition,
	the current method does not have to be removed because we mark it as non-local.
	If it is not identical to the actual method from the trait it will be replaced automatically
	by #noteChangedSelectors:.
	
	This is useful to avoid bootstrapping problems when moving methods to a trait
	(e.g., from TPureBehavior to TMethodDictionaryBehavior). Manual moving (implementing
	the method in the trait and then remove it from the class) does not work if the methods
	themselves are used for this process (such as compiledMethodAt:, includesLocalSelector: or
	addTraitSelector:withMethod:)"

	| changeFromLocalToTraitMethod |
	changeFromLocalToTraitMethod _ (self includesLocalSelector: aSelector)
		and: [self hasTraitComposition]
		and: [self traitComposition includesMethod: aSelector].

	changeFromLocalToTraitMethod
		ifFalse: [self basicRemoveSelector: aSelector]
		ifTrue: [self ensureLocalSelectors].
	self deregisterLocalSelector: aSelector.
	self noteChangedSelectors: (Array with: aSelector)
	
! !


!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:12'!
allSelectors
	self explicitRequirement! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:13'!
basicLocalSelectors
	self explicitRequirement! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:13'!
basicLocalSelectors: aSetOrNil
	self explicitRequirement! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 11/28/2005 21:48'!
changeRecordsAt: selector
	"Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one.  Return nil if the method is absent."

	"(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]"
	^ChangeSet 
		scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil])
		class: self meta: self isMeta
		category: (self whichCategoryIncludesSelector: selector)
		selector: selector.! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:14'!
classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock
	"Looks up the selector aSymbol in this class/trait. If it is found, binaryBlock is evaluated
	with this class/trait and the associated method. Otherwise absentBlock is evaluated.
	Note that this implementation is very simple because PureBehavior does not know
	about inheritance (cf. implementation in Behavior)"
	
	^ binaryBlock value: self value: (self compiledMethodAt: aSymbol ifAbsent: [^ absentBlock value]).! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 11/28/2005 11:46'!
deregisterLocalSelector: aSymbol
	self basicLocalSelectors notNil ifTrue: [
		self basicLocalSelectors remove: aSymbol ifAbsent: []]! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:49'!
"popeye" formalHeaderPartsFor: "olive oil" aSelector
	"RELAX!!  The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment.
	This method returns a collection giving the parts in the formal declaration for aSelector.  This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header
	The result will have
     	3 elements for a simple, argumentless selector.
		5 elements for a single-argument selector
		9 elements for a two-argument selector
		13 elements for a three-argument, selector
		etc...

	The syntactic elements are:

		1		comment preceding initial selector fragment

		2		first selector fragment
		3		comment following first selector fragment  (nil if selector has no arguments)

        ----------------------  (ends here for, e.g., #copy)

		4		first formal argument
		5		comment following first formal argument (nil if selector has only one argument)

        ----------------------  (ends here for, e.g., #copyFrom:)

		6		second keyword
		7		comment following second keyword
		8		second formal argument
		9		comment following second formal argument (nil if selector has only two arguments)

         ----------------------  (ends here for, e.g., #copyFrom:to:)

	Any nil element signifies an absent comment.
	NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:).  Thus, the *final* element in the structure returned by this method is always going to be nil."

	^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector)

"
	Behavior class formalHeaderPartsFor: #formalHeaderPartsFor:
"


	! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:49'!
formalParametersAt: aSelector
	"Return the names of the arguments used in this method."

	| source parser message list params |
	source _ self sourceCodeAt: aSelector ifAbsent: [^ #()].	"for now"
	(parser _ self parserClass new) parseSelector: source.
	message _ source copyFrom: 1 to: (parser endOfLastToken min: source size).
	list _ message string findTokens: Character separators.
	params _ OrderedCollection new.
	list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]].
	^ params! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:50'!
lookupSelector: selector
	^ self explicitRequirement! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:50'!
methodDict
	^ self explicitRequirement! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:50'!
methodDict: aDictionary
	^ self explicitRequirement! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:50'!
methodHeaderFor: selector 
	"Answer the string corresponding to the method header for the given selector"

	| sourceString parser |
	sourceString _ self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector].
	(parser _ self parserClass new) parseSelector: sourceString.
	^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size)

	"Behavior methodHeaderFor: #methodHeaderFor: "
! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 11/28/2005 11:47'!
registerLocalSelector: aSymbol
	self basicLocalSelectors notNil ifTrue: [
		self basicLocalSelectors add: aSymbol]! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:51'!
standardMethodHeaderFor: aSelector
	| args |
	args _ (1 to: aSelector numArgs)	collect:[:i| 'arg', i printString].
	args size = 0 ifTrue:[^aSelector asString].
	args size = 1 ifTrue:[^aSelector,' arg1'].
	^String streamContents:[:s|
		(aSelector findTokens:':') with: args do:[:tok :arg|
			s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '.
		].
	].
! !

!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:51'!
ultimateSourceCodeAt: selector ifAbsent: aBlock
	"Return the source code at selector"
	
	^self
		sourceCodeAt: selector
		ifAbsent: aBlock! !


!TPureBehavior methodsFor: 'compiling' stamp: 'al 9/16/2005 14:17'!
sourceCodeTemplate
	"Answer an expression to be edited and evaluated in order to define 
	methods in this class or trait."

	^'message selector and argument names
	"comment stating purpose of message"

	| temporary variable names |
	statements'! !


!TPureBehavior methodsFor: 'copying' stamp: 'al 9/16/2005 14:19'!
copy
	"Answer a copy of the receiver without a list of subclasses."

	| myCopy |
	myCopy _ self shallowCopy.
	^myCopy methodDictionary: self copyOfMethodDictionary! !

!TPureBehavior methodsFor: 'copying' stamp: 'al 9/16/2005 14:20'!
deepCopy
	"Classes should only be shallowCopied or made anew."

	^ self shallowCopy! !


!TPureBehavior methodsFor: 'traits' stamp: 'al 11/28/2005 11:47'!
ensureLocalSelectors
	"Ensures that the instance variable localSelectors is effectively used to maintain
	the set of local selectors.
	This method must be called before any non-local selectors are added to the
	method dictionary!!"

	self basicLocalSelectors isNil 
		ifTrue: [self basicLocalSelectors: self selectors]! !

!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:29'!
hasTraitComposition
	self explicitRequirement! !

!TPureBehavior methodsFor: 'traits' stamp: 'al 11/28/2005 11:47'!
purgeLocalSelectors
	self basicLocalSelectors: nil! !

!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:30'!
selfSentSelectorsFromSelectors: interestingSelectors 
	| m result info |
	result := IdentitySet new.
	interestingSelectors collect: 
			[:sel | 
			m := self compiledMethodAt: sel ifAbsent: [].
			m ifNotNil: 
					[info := (SendInfo on: m) collectSends.
					info selfSentSelectors do: [:sentSelector | result add: sentSelector]]].
	^result! !

!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:30'!
traitComposition
	"Return my trait composition. Manipulating the composition does not
	effect changes automatically. Use #setTraitComposition: to do this but
	note, that you have to make a copy of the old trait composition before
	changing it because only the difference between the new and the old
	composition is updated."
	
	^self explicitRequirement ! !

!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:31'!
traitCompositionIncludes: aTrait
	^self == aTrait or: 
		[self hasTraitComposition and: 
			[self traitComposition allTraits includes: aTrait]]! !

!TPureBehavior methodsFor: 'traits' stamp: 'al 3/26/2006 21:29'!
traitCompositionString
	^self hasTraitComposition
		ifTrue: [self traitComposition asString]
		ifFalse: ['{}']! !

!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:53'!
traitComposition: aTraitComposition
	^self explicitRequirement ! !

!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:53'!
traitTransformations 
	^ self traitComposition transformations ! !


!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 9/16/2005 14:16'!
canUnderstand: selector
	"Answer whether the receiver can respond to the message whose selector 
	is the argument."

	^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! !

!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 9/16/2005 14:16'!
includesLocalSelector: aSymbol
	^self basicLocalSelectors isNil
		ifTrue: [self includesSelector: aSymbol]
		ifFalse: [self localSelectors includes: aSymbol]! !

!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 9/16/2005 14:16'!
isDisabledSelector: selector
	^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! !

!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 9/16/2005 14:16'!
isProvidedSelector: selector
	^ ProvidedSelectors current isSelector: selector providedIn: self
! !




!TPureBehavior methodsFor: 'testing' stamp: 'al 9/16/2005 14:23'!
canZapMethodDictionary
	"Return true if it is safe to zap the method dictionary on #obsolete"
	^true! !

!TPureBehavior methodsFor: 'testing' stamp: 'al 3/1/2006 23:02'!
includesBehavior: aBehavior
	^self == aBehavior! !


!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:41'!
clearSendCaches
	LocalSends current clearOut: self! !

!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:41'!
hasRequiredSelectors
	^ self requiredSelectors notEmpty! !

!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:41'!
requirements
	^ self requiredSelectorsCache 
		ifNil: [#()] 
		ifNotNilDo: [:rsc | rsc requirements]! !

!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:42'!
sendCaches
	^ self explicitRequirement! !

!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:42'!
sendCaches: aSendCaches
	^ self explicitRequirement! !

!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:42'!
setRequiredStatusOf: selector to: aBoolean
	aBoolean 
		ifTrue: [self requiredSelectorsCache addRequirement: selector]
		ifFalse: [self requiredSelectorsCache removeRequirement: selector].! !

!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:42'!
superRequirements
	^ self requiredSelectorsCache superRequirements! !


!TPureBehavior methodsFor: 'printing' stamp: 'al 9/16/2005 14:21'!
defaultNameStemForInstances
	"Answer a basis for external names for default instances of the receiver.
	For classees, the class-name itself is a good one."

	^ self name! !

!TPureBehavior methodsFor: 'printing' stamp: 'al 12/1/2005 15:25'!
literalScannedAs: scannedLiteral notifying: requestor
	"Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote).
	If scannedLiteral is not an association, answer it.
	Else, if it is of the form:
		nil->#NameOfMetaclass
	answer nil->theMetaclass, if any has that name, else report an error.
	Else, if it is of the form:
		#NameOfGlobalVariable->anythiEng
	answer the global, class, or pool association with that nameE, if any, else
	add it to Undeclared a answer the new Association."

	| key value |
	(scannedLiteral isVariableBinding)
		ifFalse: [^ scannedLiteral].
	key _ scannedLiteral key.
	value _ scannedLiteral value.
	key isNil 
		ifTrue: "###<metaclass soleInstance name>"
			[(self bindingOf: value) ifNotNilDo:[:assoc|
				 (assoc value isKindOf: Behavior)
					ifTrue: [^ nil->assoc value class]].
			 requestor notify: 'No such metaclass'.
			 ^false].
	(key isSymbol)
		ifTrue: "##<global var name>"
			[(self bindingOf: key) ifNotNilDo:[:assoc | ^assoc].
			Undeclared at: key put: nil.
			 ^Undeclared bindingOf: key].
	requestor notify: '## must be followed by a non-local variable name'.
	^false

"	Form literalScannedAs: 14 notifying: nil 14
	Form literalScannedAs: #OneBitForm notiEfying: nil  OneBitForm
	Form literalScannedAs: ##OneBitForm notifying: nil  OneBitForm->a Form
	Form literalScannedAs: ##Form notifying: nil   Form->Form
	Form literalScannedAs: ###Form notifying: nil   nilE->Form class
"! !

!TPureBehavior methodsFor: 'printing' stamp: 'al 9/16/2005 14:21'!
longPrintOn: aStream
	"Append to the argument, aStream, the names and values of all of the receiver's instance variables.  But, not useful for a class with a method dictionary."

	aStream nextPutAll: '<<too complex to show>>'; cr.! !

!TPureBehavior methodsFor: 'printing' stamp: 'al 12/7/2005 21:05'!
prettyPrinterClass
	^self compilerClass! !

!TPureBehavior methodsFor: 'printing' stamp: 'al 12/1/2005 15:37'!
storeLiteral: aCodeLiteral on: aStream
	"Store aCodeLiteral on aStream, changing an Association to ##GlobalName
	 or ###MetaclassSoleInstanceName format if appropriate"
	| key value |
	(aCodeLiteral isVariableBinding)
		ifFalse:
			[aCodeLiteral storeOn: aStream.
			 ^self].
	key _ aCodeLiteral key.
	(key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass])
		ifTrue:
			[aStream nextPutAll: '###'; nextPutAll: value soleInstance name.
			 ^self].
	(key isSymbol and: [(self bindingOf: key) notNil])
		ifTrue:
			[aStream nextPutAll: '##'; nextPutAll: key.
			 ^self].
	aCodeLiteral storeOn: aStream! !


!TPureBehavior methodsFor: 'initialization' stamp: 'al 12/1/2005 16:01'!
emptyMethodDictionary

	^ MethodDictionary new! !

!TPureBehavior methodsFor: 'initialization' stamp: 'al 12/1/2005 15:24'!
obsolete
	"Invalidate and recycle local methods,
	e.g., zap the method dictionary if can be done safely."
	self canZapMethodDictionary
		ifTrue: [self methodDict: self emptyMethodDictionary].
	self hasTraitComposition ifTrue: [
		self traitComposition traits do: [:each |
			each removeUser: self]]! !


!TPureBehavior methodsFor: 'naming' stamp: 'al 9/16/2005 14:22'!
environment
	"Return the environment in which the receiver is visible"
	^Smalltalk! !

!TPureBehavior methodsFor: 'naming' stamp: 'al 9/16/2005 14:21'!
name
	^ self explicitRequirement! !


!TPureBehavior methodsFor: '*Traits' stamp: 'al 9/16/2005 14:48'!
providedSelectors
	^ProvidedSelectors current for: self! !


!TPureBehavior methodsFor: 'accessing class hierarchy' stamp: 'al 12/31/2005 13:40'!
withAllSuperclasses
	"Answer an OrderedCollection of the receiver and the receiver's 
	superclasses. The first element is the receiver, 
	followed by its superclass; the last element is Object."

	| temp |
	temp _ self allSuperclasses.
	temp addFirst: self.
	^ temp! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TPureBehavior classTrait
	uses: TCompilingBehavior classTrait + TUpdateTraitsBehavior classTrait + TAccessingTraitCompositionBehavior classTrait!
AbstractFont subclass: #TTCFont
	instanceVariableNames: 'ttcDescription pointSize foregroundColor cache derivatives fallbackFont ascent'
	classVariableNames: 'NamesToIndexes Registry Scale'
	poolDictionaries: ''
	category: 'Multilingual-Display'!
!TTCFont commentStamp: 'efc 9/30/2005 21:25' prior: 0!
I represent a font that uses TrueType derived glyph.  Upon a request for glyph for a character through a call to #formOf: (or #widthOf:), I first search corresponding glyph in the cache.  If there is not, it creates a 32bit depth form with the glyph.

  The cache is weakly held.  The entries are zapped at full GC.

Structure:
 ttcDescription	TTFontDescription -- The Squeak data structure for a TrueType font data file.
 pointSize		Number -- Nominal Em size in points. Conversion to pixel sizes depends on the definition of TextStyle class>>pixelsPerInch.
 foregroundColor	Color -- So far, this font need to know the glyph color in cache.
 cache			WeakArray of <Color -> <Array(256) of glyph>>
 derivatives		Array -- stores the fonts in the same family but different emphasis.
 ascent Number -- The height of the font above the baseline. Cached.!


!TTCFont methodsFor: 'accessing' stamp: 'efc 9/30/2005 21:28'!
ascent
	"Use a cached copy if available"
	ascent ifNil:[
		ascent := ttcDescription ascender * self pixelSize // (ttcDescription ascender - ttcDescription descender) * Scale y.
	(fallbackFont notNil and: [fallbackFont ascent > ascent])
		ifTrue: [ascent := fallbackFont ascent].
	].
	^ascent! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 7/31/2004 19:30'!
ascentOf: aCharacter

"	(self hasGlyphFor: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont ascentOf: aCharacter.
		].
	].
"
	^ self ascent.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 3/11/2004 11:38'!
descent
	"One is added to make sure the gap between lines is filled.  If we don't add, multi line selection in a text pane look ugly."
	^ (ttcDescription descender * self pixelSize // (ttcDescription descender - ttcDescription ascender)) * Scale y + 1.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 11/30/2002 22:39'!
descentKern

	^ 0.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 7/31/2004 19:30'!
descentOf: aCharacter

"	(self hasGlyphFor: aCharacter) ifFalse: [
		fallbackFont ifNotNil: [
			^ fallbackFont descentOf: aCharacter.
		].
	]."
	^ self descent.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 5/6/2004 19:25'!
emphasis
	"Answer the emphasis code (0 to 3) corresponding to my subfamily name"
	^self indexOfSubfamilyName: self subfamilyName

! !

!TTCFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 20:13'!
emphasis: code

	code > 3 ifTrue: [^ self].
	code = 0 ifTrue: [^ self].
	derivatives isNil ifTrue: [^ self].
	^ (derivatives at: code) ifNil: [self].
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 8/1/2005 12:14'!
emphasized: code

	code = 0 ifTrue: [^ self].
	derivatives ifNil: [^ self].
	(((code bitAnd: 20) ~= 0) and: [
		derivatives size < code or: [(derivatives at: code) isNil]]) ifTrue: [
		self addLined.
	].
	^ (derivatives at: code) ifNil: [self].
! !

!TTCFont methodsFor: 'accessing' stamp: 'tak 12/22/2004 01:25'!
fallbackFont
	^ fallbackFont
		ifNil: [fallbackFont _ FixedFaceFont new errorFont fontSize: self height]! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 5/24/2004 20:16'!
fallbackFont: aFontSetOrNil

	fallbackFont _ aFontSetOrNil.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 12/10/2002 17:08'!
familyName

	^ ttcDescription name.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 11/30/2002 22:39'!
familySizeFace

	^ Array
		with: self familyName
		with: self height
		with: 0.
! !

!TTCFont methodsFor: 'accessing' stamp: 'dgd 8/17/2004 22:10'!
fontNameWithPointSize
	^ self name withoutTrailingDigits , ' ' , self pointSize printString! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 3/11/2004 11:38'!
height
	"Answer my height in pixels. This will answer a Float."
	^ self pixelSize * Scale y! !

!TTCFont methodsFor: 'accessing' stamp: 'dgd 12/11/2003 12:47'!
lineGrid
	"Answer the relative space between lines"
	^ self ascent + self descent! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 11/16/2002 01:00'!
maxAscii

	^ ttcDescription size.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 11/16/2002 01:00'!
minAscii

	^ 0.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 11/16/2002 01:00'!
name

	^ ttcDescription name.
! !

!TTCFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:27'!
pixelSize
	"Make sure that we don't return a Fraction"
	^ TextStyle pointsToPixels: pointSize! !

!TTCFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:27'!
pixelSize: aNumber
	"Make sure that we don't return a Fraction"
	self pointSize: (TextStyle pixelsToPoints: aNumber) rounded.
! !

!TTCFont methodsFor: 'accessing' stamp: 'yo 6/23/2003 18:39'!
pointSize

	^ pointSize.
! !

!TTCFont methodsFor: 'accessing' stamp: 'nk 7/18/2004 15:32'!
pointSize: aNumber

	self privatePointSize: aNumber.
	derivatives ifNotNil: [ derivatives do: [ :f | f ifNotNil: [ f privatePointSize: aNumber ]]].
! !

!TTCFont methodsFor: 'accessing' stamp: 'nk 7/18/2004 15:31'!
privatePointSize: aNumber 
	pointSize = aNumber
		ifFalse: [pointSize := aNumber.
			self flushCache]! !

!TTCFont methodsFor: 'accessing' stamp: 'nk 6/17/2003 14:26'!
textStyle
	^ TextStyle actualTextStyles detect:
		[:aStyle | aStyle fontArray includes: self] ifNone: [nil]! !


!TTCFont methodsFor: 'as yet unclassified' stamp: 'tak 11/11/2004 16:42'!
setupDefaultFallbackFont

	| fonts f |
	fonts _ TextStyle default fontArray.
	f _ fonts first.
	1 to: fonts size do: [:i |
		self height > (fonts at: i) height ifTrue: [f _ fonts at: i].
	].
	self fallbackFont: f.
	self reset.

! !


!TTCFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:52'!
releaseCachedState
	self flushCache.! !

!TTCFont methodsFor: 'caching' stamp: 'yo 6/30/2004 14:49'!
reset
! !


!TTCFont methodsFor: 'character shapes' stamp: 'nk 11/3/2004 10:02'!
characterFormAt: character 
	"Answer a Form copied out of the glyphs for the argument,  
	character. Use a cached copy if possible."

	^self formOf: character! !


!TTCFont methodsFor: 'copying' stamp: 'yo 12/10/2002 16:35'!
copy

	^ self.
! !

!TTCFont methodsFor: 'copying' stamp: 'yo 12/10/2002 16:35'!
deepCopy

	^ self.
! !

!TTCFont methodsFor: 'copying' stamp: 'yo 12/10/2002 16:36'!
veryDeepCopyWith: deepCopier

	self flushCache.
	^ self.
! !


!TTCFont methodsFor: 'friend' stamp: 'yo 12/10/2002 17:47'!
cache

	(cache at: 1) ifNil: [self flushCache].
	^ cache at: 1.
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 8/3/2005 07:46'!
derivativeFont: aTTCFont

	| index |
	index _ self indexOfSubfamilyName: (aTTCFont subfamilyName).
	index < 1 ifTrue: [
		^ self "inform: 'unknown sub family name.  This font will be skipped'".
	].

	self derivativeFont: aTTCFont at: index.

	self addLined: aTTCFont.
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 5/7/2004 12:40'!
derivativeFont: aTTCFont at: index

	| newDeriv |
	aTTCFont ifNil: [derivatives _ nil. ^ self].
	derivatives ifNil: [derivatives _ Array new: 32].
	derivatives size < 32 ifTrue: [
		newDeriv _ Array new: 32.
		newDeriv replaceFrom: 1 to: derivatives size with: derivatives.
		derivatives _ newDeriv.
	].
	derivatives at: index put: aTTCFont.
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 5/6/2004 19:54'!
derivativeFontArray

	^ derivatives.
! !

!TTCFont methodsFor: 'friend' stamp: 'nk 9/1/2004 13:01'!
derivativeFonts

	derivatives ifNil: [^ #()].
	^derivatives copyWithout: nil! !

!TTCFont methodsFor: 'friend' stamp: 'yo 1/7/2005 12:04'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 

	^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent.
! !

!TTCFont methodsFor: 'friend' stamp: 'efc 9/30/2005 21:34'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY

	| destPoint form glyphInfo destY |
	destPoint _ aPoint.
	glyphInfo _ Array new: 5.
	startIndex to: stopIndex do: [:charIndex |
		self glyphInfoOf: (aString at: charIndex) into: glyphInfo.
		form _ glyphInfo first.
		((glyphInfo at:5) ~= aBitBlt lastFont) ifTrue: [
			(glyphInfo at:5) installOn: aBitBlt.
		].
		destY _ baselineY - (glyphInfo at:4). 
		aBitBlt sourceForm: form.
		aBitBlt destX: destPoint x.
		aBitBlt destY: destY.
		aBitBlt sourceOrigin: (glyphInfo at:2) @ 0.
		aBitBlt width: glyphInfo third - glyphInfo second.
		aBitBlt height: form height.
		aBitBlt copyBits.
		destPoint _ destPoint + (((glyphInfo at:3) - (glyphInfo at:2)) + kernDelta @ 0).
	].
	^ destPoint.
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 12/10/2002 16:35'!
flushCache

	cache at: 1 put: (Array new: 256).
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 11/16/2002 01:00'!
initialize

	foregroundColor _ Color black.
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 1/6/2005 21:59'!
installOn: aDisplayContext

	^aDisplayContext installTTCFont: self.
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 12/10/2002 18:15'!
installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor

	foregroundColor _ fgColor.

	aDisplayContext installTTCFont: self foregroundColor: foregroundColor backgroundColor: bgColor
! !

!TTCFont methodsFor: 'friend' stamp: 'efc 9/30/2005 22:03'!
recreateCache

	cache _ WeakArray new: 1.
	ascent := nil.
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 8/3/2005 07:44'!
setupDefaultFallbackFontTo: aTextStyleOrNil
"
	TTCFont allInstances do: [:i | i setupDefaultFallbackFontTo: (TextStyle named: 'MultiMSMincho')].
"

	| fonts f |
	aTextStyleOrNil ifNil: [
		self fallbackFont: nil.
		^ self.
	].
	fonts _ aTextStyleOrNil fontArray.
	(aTextStyleOrNil defaultFont familyName endsWith: self familyName) ifTrue: [fallbackFont _ nil. ^ self].

	f _ fonts first.
	1 to: fonts size do: [:i |
		self height >= (fonts at: i) height ifTrue: [f _ fonts at: i].
	].
	self fallbackFont: f.
	self reset.

! !

!TTCFont methodsFor: 'friend' stamp: 'yo 11/16/2002 01:01'!
ttcDescription

	^ ttcDescription.
! !

!TTCFont methodsFor: 'friend' stamp: 'yo 12/10/2002 17:27'!
ttcDescription: aTTCDescription

	ttcDescription _ aTTCDescription.
	self recreateCache.
! !


!TTCFont methodsFor: 'objects from disk' stamp: 'nk 4/2/2004 11:29'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	"If we're reading in an old version with a pixelSize instance variable, convert it to a point size."

	"Deal with the change from pixelSize to pointSize, assuming the current monitor dpi."
	varDict at: 'pixelSize' ifPresent: [ :x | 
		pointSize _ (TextStyle pixelsToPoints: x) rounded.
	].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.! !

!TTCFont methodsFor: 'objects from disk' stamp: 'yo 3/17/2005 11:21'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a
reference to a known FontSet in the other system instead."

	"a path to me"
	dp _ DiskProxy global: #TTCFont selector: #familyName:pointSize:emphasis:
			args: {self familyName. self pointSize. self emphasis}.
	refStrm replace: self with: dp.
	^ dp.
! !


!TTCFont methodsFor: 'printing' stamp: 'yo 5/6/2004 19:25'!
printOn: aStream
	aStream nextPutAll: 'TTCFont(';
		nextPutAll: self familyName; space;
		print: self pointSize; space;
		nextPutAll: self subfamilyName;
		nextPut: $)! !


!TTCFont methodsFor: 'public' stamp: 'yo 12/10/2002 16:35'!
depth

	^ 32.
! !

!TTCFont methodsFor: 'public' stamp: 'yo 11/16/2002 00:59'!
foregroundColor

	^ foregroundColor.
! !

!TTCFont methodsFor: 'public' stamp: 'yo 12/10/2002 16:36'!
size

	^ ttcDescription size.
! !

!TTCFont methodsFor: 'public' stamp: 'yo 1/18/2005 16:10'!
widthOf: aCharacter

	"This method cannot use #formOf: because formOf: discriminates the color and causes unnecessary bitmap creation."

	| f assoc |
	aCharacter charCode > 255 ifTrue: [
		fallbackFont ifNotNil: [^ fallbackFont widthOf: aCharacter].
		^ 1
	].
	assoc _ self cache at: (aCharacter charCode + 1).
	assoc ifNotNil: [
		^ assoc value width
	].

	f _ self computeForm: aCharacter.
	self at: aCharacter charCode put: f.
	^ f width.
! !


!TTCFont methodsFor: 'testing' stamp: 'yo 5/6/2004 19:25'!
isRegular
	"Answer true if I am a Regular/Roman font (i.e. not bold, etc.)"
	^ (self indexOfSubfamilyName: (self subfamilyName)) = 0.
! !

!TTCFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:55'!
isTTCFont
	^true! !


!TTCFont methodsFor: '*nebraska-file in/out' stamp: 'yo 6/23/2003 18:44'!
encodedForRemoteCanvas

	^ self familyName, ' ', self pointSize printString, ' ', self emphasis printString.
! !


!TTCFont methodsFor: 'private' stamp: 'yo 5/7/2004 12:30'!
addLined

	self addLined: self.
	self derivativeFonts do: [:e |
		e ifNotNil: [self addLined: e].
	].
! !

!TTCFont methodsFor: 'private' stamp: 'yo 5/7/2004 12:23'!
addLined: aTTCFont

	| l |
	l _ LinedTTCFont fromTTCFont: aTTCFont emphasis: 4.
	self derivativeFont: l at: l emphasis.

	l _ LinedTTCFont fromTTCFont: aTTCFont emphasis: 16.
	self derivativeFont: l at: l emphasis.

	l _ LinedTTCFont fromTTCFont: aTTCFont emphasis: 20.
	self derivativeFont: l at: l emphasis.
! !

!TTCFont methodsFor: 'private' stamp: 'yo 7/31/2004 19:41'!
at: char put: form

	self cache at: (char asInteger + 1) put: (foregroundColor -> form).
! !

!TTCFont methodsFor: 'private' stamp: 'yo 1/18/2005 16:13'!
computeForm: char

	| ttGlyph scale |
	scale _ self pixelSize asFloat / (ttcDescription ascender - ttcDescription descender).
	Scale ifNotNil: [scale _ Scale * scale].
	ttGlyph _ ttcDescription at: (char isCharacter ifTrue: [char charCode] ifFalse: [char]).
	^ ttGlyph asFormWithScale: scale ascender: ttcDescription ascender descender: ttcDescription descender fgColor: foregroundColor bgColor: Color transparent depth: self depth.
! !

!TTCFont methodsFor: 'private' stamp: 'yo 1/7/2005 13:13'!
formOf: char

	| f assoc code |
	char charCode > 255
		ifTrue: [^ self fallbackFont formOf: char].

	code _ char charCode.
	assoc _ self cache at: (code + 1).
	assoc ifNotNil: [
		(assoc key = foregroundColor) ifTrue: [
			^ assoc value.
		].
	].

	f _ self computeForm: code.
	self at: code put: f.
	^ f.
! !

!TTCFont methodsFor: 'private' stamp: 'yo 1/11/2005 18:48'!
glyphInfoOf: aCharacter into: glyphInfoArray
	"Answer the width of the argument as a character in the receiver."

	| form |
	(self hasGlyphOf: aCharacter) ifFalse: [
		^ self fallbackFont glyphInfoOf: aCharacter into: glyphInfoArray.
	].
	form _ self formOf: aCharacter.
	glyphInfoArray at: 1 put: form;
		at: 2 put: 0;
		at: 3 put: form width;
		at: 4 put: (self ascentOf: aCharacter);
		at: 5 put: self.
	^ glyphInfoArray.
! !

!TTCFont methodsFor: 'private' stamp: 'yo 1/6/2005 04:43'!
hasGlyphOf: aCharacter

	^ aCharacter charCode <= 255
! !

!TTCFont methodsFor: 'private' stamp: 'nk 3/25/2004 17:01'!
indexOfSubfamilyName: aName
	| decoded |

	"decodeStyleName will consume all the modifiers and leave nothing if everything was recognized."
	decoded := TextStyle decodeStyleName: aName.
	decoded second isEmpty ifTrue: [ ^decoded first ].

	"If you get a halt here - please add the missing synonym to the lookup table in TextStyle>>decodeStyleName: ."
	
	self error: 'please add the missing synonym ', aName, ' to the lookup table in TextStyle>>decodeStyleName:'.

	^0.! !

!TTCFont methodsFor: 'private' stamp: 'nk 4/1/2004 09:15'!
scale

	^ self pixelSize / ttcDescription unitsPerEm
! !

!TTCFont methodsFor: 'private' stamp: 'yo 5/6/2004 19:23'!
subfamilyName

	^ ttcDescription subfamilyName.
! !


!TTCFont methodsFor: 'html' stamp: 'dgd 9/2/2005 12:39'!
closeHtmlOn: aStream 
	"put on the given stream the tag to close the html  
	representation of the receiver"
	self htmlSize isZero
		ifFalse: [aStream nextPutAll: '</font>']! !

!TTCFont methodsFor: 'html' stamp: 'dgd 9/2/2005 11:19'!
htmlSize
"private - answer the size in html form, assumes 12 as default size"
	^ (self pointSize - 12 / 3) rounded! !

!TTCFont methodsFor: 'html' stamp: 'dgd 9/2/2005 12:38'!
openHtmlOn: aStream 
	"put on the given stream the tag to open the html  
	representation of the receiver"
	| size |
	size := self htmlSize.
	size isZero
		ifFalse: [aStream nextPutAll: '<font size="' , size asString , '">']! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTCFont class
	instanceVariableNames: ''!

!TTCFont class methodsFor: 'class initialization' stamp: 'yo 3/9/2004 15:56'!
initialize
"
	self initialize
"

	| tt |
	Smalltalk addToShutDownList: TTCFont.
	tt _ TTFontDescription default.
	tt ifNotNil: [self newTextStyleFromTT: tt].

	(FileList respondsTo: #registerFileReader:) ifTrue: [
		FileList registerFileReader: self
	].
! !

!TTCFont class methodsFor: 'class initialization' stamp: 'yo 3/9/2004 15:56'!
shutDown

	self recreateCache.
! !

!TTCFont class methodsFor: 'class initialization' stamp: 'nk 6/25/2003 13:14'!
unload

	(FileList respondsTo: #unregisterFileReader:) ifTrue: [
		FileList unregisterFileReader: self
	]! !


!TTCFont class methodsFor: 'file list services' stamp: 'nk 7/16/2003 15:40'!
fileReaderServicesForFile: fullName suffix: suffix 
	^(suffix = 'ttf')  | (suffix = '*') 
		ifTrue: [ self services ]
		ifFalse: [ #() ]! !

!TTCFont class methodsFor: 'file list services'!
serviceInstallTrueTypeFontStyle
	"Return a service to install a true type font as a text style"

	^ SimpleServiceEntry
		provider: self
		label: 'install ttf style'
		selector: #newTextStyleFromTTFile: 
		description: 'install a true type font as a text style'
		buttonLabel: 'install ttf'! !

!TTCFont class methodsFor: 'file list services'!
services
	"Return a set of services for use in FileList"

	^ Array with: self serviceInstallTrueTypeFontStyle! !


!TTCFont class methodsFor: 'instance creation' stamp: 'yo 8/1/2005 15:06'!
familyName: n pointSize: s emphasis: code

	"(TTCFont familyName: 'BitstreamVeraSans' pointSize: 12 emphasis: 0)"
	| t ret index |
	t _ self registry at: n asSymbol ifAbsent: [#()].
	t isEmpty ifTrue: [
		t _ (TextConstants at: #DefaultTextStyle) fontArray.
		ret _ t first.
		ret pointSize >= s ifTrue: [^ ret emphasis: code].
		index _ 2.
		[index <= t size and: [(t at: index) pointSize <= s]] whileTrue: [
			ret _ t at: index.
			index _ index + 1.
		].
		^ ret emphasis: code.
	].
	^ ((TextStyle named: n) addNewFontSize: s) emphasis: code.
! !

!TTCFont class methodsFor: 'instance creation' stamp: 'yo 6/23/2003 18:44'!
family: f size: s

	^ self allInstances detect: [:a | a familyName = f and: [a pointSize = s]] ifNone: [nil].
! !

!TTCFont class methodsFor: 'instance creation' stamp: 'yo 12/13/2002 12:20'!
getExistings: fontArray

	| result em |
	result _ OrderedCollection new.
	result add: fontArray.
	1 to: 3 do: [:i |
		em _ (fontArray collect: [:f | f emphasized: i]).
		(em at: 1) ~= (fontArray at: 1) ifTrue: [
			result add: em.
		].
	].
	^ result asArray.
! !

!TTCFont class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'!
newTextStyleFromTT: description 
	"Create a new TextStyle from specified TTFontDescription instance."

	| array f |
	array := self pointSizes collect: 
					[:pt | 
					f := self new.
					f ttcDescription: description.
					f pointSize: pt].
	^self reorganizeForNewFontArray: array name: array first name asSymbol! !

!TTCFont class methodsFor: 'instance creation' stamp: 'yo 11/8/2004 19:27'!
newTextStyleFromTTFile: fileName
	"Create a new TextStyle from specified file name.  On certain versions of Windows, you can evaluate following to get Arial font into the image.  On other platforms, wait and see someone implements the support code for FontPlugin then we can start relying on the generic font lookup mechanism.
	TTCFontReader encodingTag: 0.
	self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\symbol.TTF'.
	"

	| description |
	description _ TTFontDescription addFromTTFile: fileName.
	^ self newTextStyleFromTT: description.
! !

!TTCFont class methodsFor: 'instance creation' stamp: 'tb 6/24/2003 17:12'!
newTextStyleFromTTStream: readStream
"
"

	| description |
	description _ TTFontDescription addFromTTStream: readStream.
	^ self newTextStyleFromTT: description.
! !

!TTCFont class methodsFor: 'instance creation' stamp: 'yo 10/9/2005 13:05'!
reorganizeForNewFontArray: array name: styleName

	| style existings regular altName |
	(TextConstants includesKey: styleName) ifFalse: [
		TextConstants at: styleName put: (TextStyle fontArray: array).
		^ TextConstants at: styleName.
	].
 
	"There is a text style with the name I want to use.  See if it is a TTC font..."
	style _ TextConstants at: styleName.
	style isTTCStyle ifFalse: [
		altName _ ((array at: 1) name, 'TT') asSymbol.
		^ self reorganizeForNewFontArray: array name: altName.
	].

	existings _ (self getExistings: style fontArray), (Array with: array).
	regular _ existings detect: [:e | (e at: 1) isRegular] ifNone: [existings at: 1].

	regular do: [:r |
		r addLined: r.
	].

	"The existing array may be different in size than the new one."
	existings do: [:e |
		(e at: 1) isRegular ifFalse: [
			regular do: [ :r | | f |
				f _ e detect: [ :ea | ea pointSize = r pointSize ] ifNone: [ ].
				f ifNotNil: [ r derivativeFont: f ].
			].
		].
	].

	style newFontArray: regular.
	self register: regular at: styleName.
	self recreateCache.	
	^ style.
! !


!TTCFont class methodsFor: 'objects from disk' stamp: 'nk 6/25/2003 13:42'!
classVersion
	"Version 0 had pixelSize; version 1 changed it to pointSize"
	^1! !


!TTCFont class methodsFor: 'other' stamp: 'yo 6/23/2003 19:46'!
isCacheAllNil
"
	self cacheAllNil
"
	self allInstances do: [:inst |
		inst cache do: [:e |
			e ifNotNil: [^ false].
		].
	].

	^ true.
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 6/23/2003 20:18'!
pointSizes

	"The default sizes that are created when a TextStyle is created.  You can add new sizes by the new-size feature."
	^ #(9 12 15 24 36).
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 5/7/2004 08:25'!
recreateCache
"
	self recreateCache.
"
	self allSubInstances do: [:inst | inst recreateCache].
	Smalltalk garbageCollect.
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 3/17/2005 11:11'!
registerAll
"
	TTCFont registerAll
"

	TextStyle allInstancesDo: [:e |
		(e fontArray first isMemberOf: TTCFont) ifTrue: [
			self register: e fontArray at: e fontArray first familyName asSymbol.
		].
	].
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 3/17/2005 10:52'!
register: anObject at: symbolName

	self registry at: symbolName put: anObject.
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 3/17/2005 10:52'!
registry

	^ Registry isNil
		ifTrue: [Registry := IdentityDictionary new]
		ifFalse: [Registry].
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 5/7/2004 08:09'!
removeAllDerivatives
"
	self removeAllDerivatives
"

	self allInstances do: [:s |
		s textStyle ifNotNil: [
			s textStyle fontArray do: [:f |
				f derivativeFont: nil at: 0.
			].
		].
	].
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 11/30/2002 22:37'!
removeStyleName: aString

	TextConstants removeKey: aString asSymbol ifAbsent: [].
	TTFontDescription removeDescriptionNamed: aString asString.
! !

!TTCFont class methodsFor: 'other' stamp: 'nk 4/13/2004 17:56'!
repairBadSizes
	"There was a bug that would cause the TTCFonts to generate incorrectly sized glyphs.
	By looking at the dimensions of cached forms,
	we can tell whether the incorrect height logic was used.
	If it was, change the point size of the font and its derivatives.
	
	Note that this is probably pointless to call after the new code has been loaded; it's here for documentation (it should be called from the CS preamble instead)."

	"TTCFont repairBadSizes"
	| description computedScale cached desiredScale newPointSize repaired |
	repaired _ OrderedCollection new.
	TTCFont allInstancesDo: [ :font |
		cached := (font cache copyFrom: $A asciiValue + 1 to: $z asciiValue + 1)
			detect: [ :f | f notNil ] ifNone: [].
		cached := cached ifNil: [  font formOf: $A ] ifNotNil: [ cached value ].
		description _ font ttcDescription.
		desiredScale _ cached height asFloat / (description ascender - description descender).
		computedScale _ font pixelSize asFloat / font ttcDescription unitsPerEm.
		(((computedScale / desiredScale) - 1.0 * cached height) abs < 1.0) ifFalse: [
			newPointSize _ (font pointSize * desiredScale / computedScale) rounded.
			font pointSize: newPointSize; flushCache.
			repaired add: font.
			font derivativeFonts do: [ :df | df ifNotNil: [
				df pointSize: newPointSize; flushCache.
				repaired add: df. ]].
		].
	].
	repaired isEmpty ifFalse: [ repaired asArray inspect ].
! !

!TTCFont class methodsFor: 'other' stamp: 'nk 7/18/2004 15:35'!
repairDerivativeFonts
	"Fix the cases where the derivatives are a different size than the originals."

	"
	TTCFont repairDerivativeFonts.
	"
	self allInstancesDo: [ :font | font pointSize: font pointSize ].
	Preferences refreshFontSettings.! !

!TTCFont class methodsFor: 'other' stamp: 'yo 2/17/2004 14:40'!
scale: anObject

	Scale _ anObject.
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 3/17/2005 10:53'!
unregister: symbolName

	self registry removeKey: symbolName ifAbsent: [].
! !

!TTCFont class methodsFor: 'other' stamp: 'yo 6/23/2003 19:50'!
version

	^ '6.0'.
! !
TTFontDescription subclass: #TTCFontDescription
	instanceVariableNames: ''
	classVariableNames: 'TTCDefault TTCDescriptions'
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!TTCFontDescription methodsFor: 'as yet unclassified' stamp: 'yo 12/27/2002 04:25'!
at: aCharOrInteger

	| char |
	char _ aCharOrInteger asCharacter.
	^ glyphs at: (char charCode) + 1.
! !

!TTCFontDescription methodsFor: 'as yet unclassified' stamp: 'yo 11/14/2002 22:40'!
deepCopy

	^ self.
! !

!TTCFontDescription methodsFor: 'as yet unclassified' stamp: 'yo 11/14/2002 18:42'!
name

	^ self familyName copyWithout: Character space.
! !

!TTCFontDescription methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 22:50'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to a known Font in the other system instead.  "

	"A path to me"
	(TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self].
		"special case for saving the default fonts on the disk.  See collectionFromFileNamed:"

	dp _ DiskProxy global: #TTCFontDescription selector: #descriptionNamed:at:
			args: {self name. ((TTCFontDescription descriptionNamed: self name) indexOf: self)}.
	refStrm replace: self with: dp.
	^ dp.
! !

!TTCFontDescription methodsFor: 'as yet unclassified' stamp: 'yo 11/14/2002 18:28'!
size

	^ glyphs size.
! !

!TTCFontDescription methodsFor: 'as yet unclassified' stamp: 'yo 11/14/2002 22:41'!
veryDeepCopyWith: deepCopier
	"Return self.  I am shared.  Do not record me."
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTCFontDescription class
	instanceVariableNames: ''!

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 2/15/2004 23:03'!
addFromTTFile: fileName
"
	Execute the following only if you know what you are doing.
	self addFromTTFile: 'C:\WINDOWS\Fonts\msgothic.TTC'
"

	| tt old |
	(fileName asLowercase endsWith: 'ttf') ifTrue: [
		tt _ TTCFontReader readTTFFrom: (FileStream readOnlyFileNamed: fileName).
	] ifFalse: [
		tt _ TTCFontReader readFrom: (FileStream readOnlyFileNamed: fileName).
	].
		
	old _ TTCDescriptions detect: [:f | f first name = tt first name] ifNone: [nil].
	old ifNotNil: [TTCDescriptions remove: old].
	TTCDescriptions add: tt.
	^ tt.
! !

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 02:01'!
clearDefault
"
	self clearDefault
"

	TTCDefault _ nil.
! !

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 23:10'!
clearDescriptions
"
	self clearDescriptions
"

	TTCDescriptions _ Set new.
	TTCDefault ifNotNil: [TTCDescriptions add: TTCDefault].
! !

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 22:44'!
default

	^ TTCDefault.
! !

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 19:29'!
descriptionNamed: descriptionName

	^ TTCDescriptions detect: [:f | f first name = descriptionName] ifNone: [TTCDefault].
! !

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'tk 12/6/2004 09:05'!
descriptionNamed: descriptionName at: index

	| array |
	(array _  self descriptionNamed: descriptionName) ifNil: [^ nil].
	^ array at: index.
! !

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 23:10'!
initialize
"
	self initialize
"

	self clearDescriptions.
! !

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 13:02'!
removeDescriptionNamed: descriptionName

	| tt |
	TTCDescriptions ifNil: [^ self].
	[(tt _ TTCDescriptions detect: [:f | ('Multi', f first name) = descriptionName] ifNone: [nil]) notNil] whileTrue:[
		 TTCDescriptions remove: tt
	].
! !

!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 23:27'!
setDefault
"
	self setDefault
"

	TTCDefault _ TTCFontReader readFrom: (FileStream readOnlyFileNamed: 'C:\WINDOWS\Fonts\msgothic.ttc').
	self clearDescriptions.

! !
TTFontReader subclass: #TTCFontReader
	instanceVariableNames: 'fonts'
	classVariableNames: 'EncodingTag'
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'yo 11/8/2002 23:35'!
decodeCmapFmtTable: entry
	| cmapFmt length cmap firstCode entryCount segCount segments offset code |
	cmapFmt _ entry nextUShort.
	length _ entry nextUShort.
	entry skip: 2. "skip version"

	cmapFmt = 0 ifTrue: "byte encoded table"
		[length _ length - 6. 		"should be always 256"
		length <= 0 ifTrue: [^ nil].	"but sometimes, this table is empty"
		cmap _ Array new: length.
		entry nextBytes: length into: cmap startingAt: entry offset.
		^ cmap].

	cmapFmt = 4 ifTrue: "segment mapping to deltavalues"
		[segCount _ entry nextUShort // 2.
		entry skip: 6. "skip searchRange, entrySelector, rangeShift"
		segments _ Array new: segCount.
		segments _ (1 to: segCount) collect: [:e | Array new: 4].
		1 to: segCount do: [:i | (segments at: i) at: 2 put: entry nextUShort]. "endCount"
		entry skip: 2. "skip reservedPad"
		1 to: segCount do: [:i | (segments at: i) at: 1 put: entry nextUShort]. "startCount"
		1 to: segCount do: [:i | (segments at: i) at: 3 put: entry nextShort]. "idDelta"
		offset _ entry offset.
		1 to: segCount do: [:i | (segments at: i) at: 4 put: entry nextUShort]. "idRangeOffset"
		cmap _ Array new: 65536 withAll: 0.
		segments withIndexDo:
			[:seg :si |
			seg first to: seg second do:
				[:i |
					seg last > 0 ifTrue:
						["offset to glypthIdArray - this is really C-magic!!"
						entry offset: i - seg first - 1 * 2 + seg last + si + si + offset.
						code _ entry nextUShort.
						code > 0 ifTrue: [code _ code + seg third]]
					ifFalse:
						["simple offset"
						code _ i + seg third].
					cmap at: i + 1 put: (code \\ 16r10000)]].
		^ cmap].

	cmapFmt = 6 ifTrue: "trimmed table"
		[firstCode _ entry nextUShort.
		entryCount _ entry nextUShort.
		cmap _ Array new: entryCount + firstCode withAll: 0.
		entryCount timesRepeat:
			[cmap at: (firstCode _ firstCode + 1) put: entry nextUShort].
		^ cmap].
	^ nil! !

!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'yo 11/8/2002 15:12'!
getTableDirEntry: tagString from: fontData offset: offset
	"Find the table named tagString in fontData and return a table directory entry for it."

	| nTables pos currentTag tag |
	nTables _ fontData shortAt: 5 + offset bigEndian: true.
	tag _ ByteArray new: 4.
	1 to: 4 do:[:i| tag byteAt: i put: (tagString at: i) asInteger].
	tag _ tag longAt: 1 bigEndian: true.
	pos _ 13 + offset.
	1 to: nTables do:[:i|
		currentTag _ fontData longAt: pos bigEndian: true.
		currentTag = tag ifTrue:[^TTFontTableDirEntry on: fontData at: pos].
		pos _ pos+16].
	^nil! !

!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'yo 11/8/2002 15:47'!
parseTTCHeaderFrom: fontData

	| pos nTables |
	nTables _ fontData longAt: 9 bigEndian: true.
	fonts _ Array new: nTables.
	pos _ 13.
	1 to: nTables do: [:i |
		fonts at: i put: (fontData longAt: pos bigEndian: true).
		pos _ pos + 4.
	].

	^ fonts
! !

!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'yo 2/17/2004 19:45'!
processCharMap: assoc
	"Process the given character map"

	| glyph cmap encode0 encode1 char value null |
	cmap _ assoc value.
	null _ (glyphs at: (cmap at: Character space asUnicode + 1) + 1) copy.
	null contours: #().

	encode0 _ Array new: 256 withAll: glyphs first.
	encode1 _ Array new: 65536 withAll: glyphs first.

	0 to: 255 do: [:i |
		char _ Character value: i.
		glyph _ glyphs at: (cmap at: char asUnicode + 1) + 1.
		encode0 at: i+1 put: glyph.
	].
	Character separators do: [:c |
		encode0 at: (c asciiValue + 1) put: null.
	].
	0 to: 65536 - 1 do: [:i |
		value _ cmap at: i+1.
		value = 65535 ifFalse: [ "???"
			encode1 at: i+1 put: (glyphs at: value+1).
		]
	].

	^ {encode0. encode1}.
! !

!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'yo 11/8/2002 19:02'!
processCharacterMappingTable: entry
	"Read the font's character to glyph index mapping table.
	If an appropriate mapping can be found then return an association
	with the format identifier and the contents of the table"
	| copy initialOffset nSubTables pID sID offset cmap assoc |
	initialOffset _ entry offset.
	entry skip: 2. "Skip table version"
	nSubTables _ entry nextUShort.
	1 to: nSubTables do:[:i|
		pID _ entry nextUShort.
		sID _ entry nextUShort.
		offset _ entry nextULong.
		"Check if this is either a Macintosh encoded table
		or a Windows encoded table"
		(pID = 1 or:[pID = 3]) ifTrue:[
			"Go to the beginning of the table"
			copy _ entry copy.
			copy offset: initialOffset + offset.
			cmap _ self decodeCmapFmtTable: copy.
			"(pID = 1 and: [cmap notNil])" "Prefer Macintosh encoding over everything else"
				"ifTrue: [pID -> cmap]."
			assoc _ pID -> cmap. "Keep it in case we don't find a Mac encoded table"
		].
	].
	^assoc! !

!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'yo 2/15/2004 18:37'!
readFrom: aStream

	"Read the raw font byte data"
	| fontData |
	(aStream respondsTo: #binary) ifTrue:[aStream binary].
	fontData _ aStream contents asByteArray.

	fonts _ self parseTTCHeaderFrom: fontData.
	^ ((Array with: fonts first) collect: [:offset |
		fontDescription _ TTCFontDescription new.
		self readFrom: fontData fromOffset: offset at: EncodingTag.
	]) at: 1.
! !

!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'yo 11/8/2004 22:22'!
readFrom: fontData fromOffset: offset at: encodingTag

	| headerEntry maxProfileEntry nameEntry indexLocEntry charMapEntry glyphEntry horzHeaderEntry horzMetricsEntry kerningEntry glyphOffset cmap numHMetrics indexToLocFormat fontDescription0 fontDescription1 array result |

	"Search the tables required to build the font"
	(headerEntry _ self getTableDirEntry: 'head' from: fontData offset: offset) == nil ifTrue:[
		^self error:'This font does not have a header table'].
	(maxProfileEntry _ self getTableDirEntry: 'maxp' from: fontData offset: offset) == nil ifTrue:[
		^self error:'This font does not have a maximum profile table'].
	(nameEntry _ self getTableDirEntry: 'name' from: fontData offset: offset) == nil ifTrue:[
		^self error:'This font does not have a name table'].
	(indexLocEntry _ self getTableDirEntry: 'loca' from: fontData offset: offset) == nil ifTrue:[
		^self error:'This font does not have a relocation table'].
	(charMapEntry _ self getTableDirEntry: 'cmap' from: fontData offset: offset) == nil ifTrue:[
		^self error:'This font does not have a character map table'].
	(glyphEntry _ self getTableDirEntry: 'glyf' from: fontData  offset: offset) == nil ifTrue:[
		^self error:'This font does not have a glyph table'].
	(horzHeaderEntry _ self getTableDirEntry: 'hhea' from: fontData offset: offset) == nil ifTrue:[
		^self error:'This font does not have a horizontal header table'].
	(horzMetricsEntry _ self getTableDirEntry: 'hmtx' from: fontData offset: offset) == nil ifTrue:[
		^self error:'This font does not have a horizontal metrics table'].
	(kerningEntry _ self getTableDirEntry: 'kern' from: fontData offset: offset) == nil ifTrue:[
		Transcript cr; show:'This font does not have a kerning table';endEntry].


	"Process the data"
	indexToLocFormat _ self processFontHeaderTable: headerEntry.
	self processMaximumProfileTable: maxProfileEntry.
	self processNamingTable: nameEntry.
	glyphOffset _ self processIndexToLocationTable: indexLocEntry format: indexToLocFormat.
	cmap _ self processCharacterMappingTable: charMapEntry.
	(cmap == nil or:[cmap value == nil])
		ifTrue:[^self error:'This font has no suitable character mappings'].
	self processGlyphDataTable: glyphEntry offsets: glyphOffset.
	numHMetrics _ self processHorizontalHeaderTable: horzHeaderEntry.
	self processHorizontalMetricsTable: horzMetricsEntry length: numHMetrics.
	kerningEntry isNil 
		ifTrue:[kernPairs _ #()]
		ifFalse:[self processKerningTable: kerningEntry].
	array _ self processCharMap: cmap.
	fontDescription0 _ fontDescription clone.
	fontDescription1 _ fontDescription clone.
	fontDescription0 setGlyphs: (array at: 1) mapping: nil.
	fontDescription1 setGlyphs: (array at: 2) mapping: nil.
	"fontDescription setKernPairs: kernPairs."
	result _ OrderedCollection new.
	(encodingTag = nil or: [encodingTag = 0]) ifTrue: [^ Array with: fontDescription1].
	result add: fontDescription0.
	encodingTag -1 timesRepeat: [result add: nil].
	result add: fontDescription1.
	^ result asArray.

! !

!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'yo 2/15/2004 18:43'!
readTTFFrom: aStream

	"Read the raw font byte data"
	| fontData |
	(aStream respondsTo: #binary) ifTrue:[aStream binary].
	fontData _ aStream contents asByteArray.
	fontDescription _ TTCFontDescription new.

	^ self readFrom: fontData fromOffset: 0 at: EncodingTag.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTCFontReader class
	instanceVariableNames: ''!

!TTCFontReader class methodsFor: 'as yet unclassified' stamp: 'yo 2/15/2004 18:45'!
encodingTag: aNumber
"
	TTCFontReader encodingTag: 6
"

	EncodingTag _ aNumber.
! !
AbstractFont subclass: #TTCFontSet
	instanceVariableNames: 'name fontArray foregroundColor'
	classVariableNames: 'Registry'
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:15'!
ascent

	^ (fontArray at: 1) ascent.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/8/2004 21:18'!
ascentOf: aCharacter

	^ fontArray first ascentOf: aCharacter.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'!
baseKern

	^ 0.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:28'!
depth

	^ (fontArray at: 1) depth.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'!
descent

	^ (fontArray at: 1) descent.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'!
descentKern

	^ 0.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/8/2004 21:18'!
descentOf: aChar

	^ fontArray first descentOf: aChar
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/7/2005 12:05'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta

	^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/7/2005 15:17'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY

	| destPoint font form encoding glyphInfo char charCode destY |
	destPoint _ aPoint.
	glyphInfo _ Array new: 5.
	startIndex to: stopIndex do: [:charIndex |
		char _ aString at: charIndex.
		encoding _ char leadingChar + 1.
		charCode _ char charCode.
		font _ fontArray at: encoding.
		((charCode between: font minAscii and: font maxAscii) not) ifTrue: [
			charCode _ font maxAscii].
		self glyphInfoOf: char into: glyphInfo.
		form _ glyphInfo first.
		(glyphInfo fifth ~= aBitBlt lastFont) ifTrue: [
			glyphInfo fifth installOn: aBitBlt.
		].
		destY _ baselineY - glyphInfo fourth. 
		aBitBlt sourceForm: form.
		aBitBlt destX: destPoint x.
		aBitBlt destY: destY.
		aBitBlt sourceOrigin: 0 @ 0.
		aBitBlt width: form width.
		aBitBlt height: form height.
		aBitBlt copyBits.
		destPoint _ destPoint + (form width + kernDelta @ 0).
	].
	^ destPoint.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/7/2005 11:00'!
displayStringR2L: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 

	| destPoint font form encoding char charCode glyphInfo |
	destPoint _ aPoint.
	glyphInfo _ Array new: 5.
	startIndex to: stopIndex do: [:charIndex |
		char _ aString at: charIndex.
		encoding _ char leadingChar + 1.
		charCode _ char charCode.
		font _ fontArray at: encoding.
		((charCode between: font minAscii and: font maxAscii) not) ifTrue: [
			charCode _ font maxAscii].
		self glyphInfoOf: char into: glyphInfo.
		form _ glyphInfo first.
			(glyphInfo size > 4 and: [glyphInfo fifth notNil and: [glyphInfo fifth ~= aBitBlt lastFont]]) ifTrue: [
				glyphInfo fifth installOn: aBitBlt.
			].
		aBitBlt sourceForm: form.
		aBitBlt destX: destPoint x - form width.
		aBitBlt destY: destPoint y.
		aBitBlt sourceOrigin: 0 @ 0.
		aBitBlt width: form width.
		aBitBlt height: form height.
		aBitBlt copyBits.
		destPoint _ destPoint - (form width + kernDelta @ 0).
	].
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'TN 3/14/2005 23:46'!
emphasis
	^ fontArray first emphasis! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'!
emphasized: code

! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:20'!
familyName

	^ 'Multi', (fontArray at: 1) familyName.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'!
familySizeFace

	^ Array
		with: fontArray first name
		with: self height
		with: 0.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'!
fontArray

	^ fontArray
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/7/2005 11:17'!
glyphInfoOf: aCharacter into: glyphInfoArray

	| index f code |
	index _ aCharacter leadingChar + 1.
	fontArray size < index ifTrue: [^ self questionGlyphInfoInto: glyphInfoArray].
	(f _ fontArray at: index) ifNil: [^ self questionGlyphInfoInto: glyphInfoArray].

	code _ aCharacter charCode.
	((code between: f minAscii and: f maxAscii) not) ifTrue: [
		^ self questionGlyphInfoInto: glyphInfoArray.
	].
	f glyphInfoOf: aCharacter into: glyphInfoArray.
	glyphInfoArray at: 5 put: self.
	^ glyphInfoArray.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'nk 8/31/2004 09:27'!
height

	^fontArray first pixelSize.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:20'!
initializeWithFontArray: anArray

	fontArray _ anArray.
	"name _ anArray first name."
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/6/2005 22:00'!
installOn: aDisplayContext

	^aDisplayContext installTTCFont: self.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 8/20/2003 22:51'!
installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor

	foregroundColor _ fgColor.
	fontArray do: [:s | s ifNotNil: [s installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor]].
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 12/29/2003 15:02'!
isTTCFont
	^true! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'nk 8/31/2004 09:27'!
lineGrid

	^ fontArray first lineGrid.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:17'!
maxAsciiFor: encoding

	| f |
	f _ (fontArray at: encoding+1).
	f ifNotNil: [^ f maxAscii].
	^ 0.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:17'!
pointSize

	^ fontArray first pixelSize * 72 // 96.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:27'!
pointSizes

	^ self class pointSizes.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/6/2005 17:16'!
questionGlyphInfoInto: glyphInfoArray

	| f form |
	f _ fontArray at: 1.
	form _ f formOf: $?.
	glyphInfoArray at: 1 put: form;
		at: 2 put: 0;
		at: 3 put: form width;
		at: 4 put: self.
	^ glyphInfoArray.
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 15:31'!
textStyle

	^ TextStyle actualTextStyles
		detect: [:aStyle | (aStyle fontArray collect: [:s | s name]) includes: self name]
		ifNone: [].
! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'TN 3/14/2005 23:53'!
ttcDescription
	^ fontArray first ttcDescription! !

!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:17'!
widthOf: aCharacter

	| encoding |
	encoding _ aCharacter leadingChar.
	^ (fontArray at: encoding + 1) widthOf: aCharacter.
! !


!TTCFontSet methodsFor: 'objects from disk' stamp: 'tk 12/4/2004 14:51'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a
reference to a known FontSet in the other system instead."

	"a path to me"
	dp _ DiskProxy global: #TTCFontSet selector: #familyName:pointSize:
			args: {self familyName. self pointSize}.
	refStrm replace: self with: dp.
	^ dp.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTCFontSet class
	instanceVariableNames: ''!

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 23:47'!
discardDefault
"
	self discardDefault
"
	| ttc |
	ttc _ TTCFontDescription default.
	ttc ifNotNil: [
		TextConstants removeKey: ttc name asSymbol ifAbsent: [].
	].! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 3/16/2005 16:12'!
familyName: n pointSize: s

	"(self familyName: 'MultiMSGothic' pointSize: 14) pointSize"
	| t ret index |
	t _ self registry at: n asSymbol ifAbsent: [#()].
	t isEmpty ifTrue: [
		t _ (TextConstants at: #DefaultTextStyle) fontArray.
		ret _ t first.
		ret pointSize >= s ifTrue: [^ ret].
		index _ 2.
		[index <= t size and: [(t at: index) pointSize <= s]] whileTrue: [
			ret _ t at: index.
			index _ index + 1.
		].
		^ ret.
	].
	^ (TextStyle named: n) addNewFontSize: s.! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 23:15'!
initialize
"
	self initialize
"

	| tt |
	tt _ TTCFontDescription default.
	tt ifNotNil: [self newTextStyleFromTT: tt].
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:18'!
newFontArray: anArray
 
	^super new initializeWithFontArray: anArray
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 13:04'!
newTextStyleFromTT: descriptionArray

	| array f textStyle styleName arrayOfArray |

	arrayOfArray _ self pointSizes collect: [:pt |
		descriptionArray collect: [:ttc |
			ttc ifNil: [nil] ifNotNil: [
				f _ (ttc size > 256)
					ifTrue: [MultiTTCFont new initialize]
					ifFalse: [TTCFont new initialize].
				f ttcDescription: ttc.
				f pointSize: pt.
			].
		].
	].

	array _ arrayOfArray collect: [:fonts |
		self newFontArray: fonts.
	].

	styleName _ (array at: 1) familyName asSymbol.
	textStyle _ TextStyle fontArray: array.
	TextConstants at: styleName put: textStyle.

	self register: array at: styleName.

	^ TextConstants at: styleName.
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 12:58'!
newTextStyleFromTTFile: fileName
"
	TTCFontReader encodingTag: JapaneseEnvironment leadingChar.
	self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\msmincho.TTC'

	TTCFontReader encodingTag: 0.
	self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\symbol.ttf'
"

	| description |
	description _ TTCFontDescription addFromTTFile: fileName.
	^ self newTextStyleFromTT: description.
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 22:21'!
pointSizes

	^ TTCFont pointSizes.
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 12:50'!
register: anObject at: symbolName

	self registry at: symbolName put: anObject.
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 13:07'!
registry

	^ Registry isNil
		ifTrue: [Registry := IdentityDictionary new]
		ifFalse: [Registry].
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 12:49'!
removeStyleName: aString

	| style symName |
	symName _ aString asSymbol.
	style _ TextConstants removeKey: symName ifAbsent: [].
	style ifNotNil: [self unregister: symName].
	TTCFontDescription removeDescriptionNamed: aString asString.
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/1/2002 00:03'!
setDefault
"
	self setDefault
"
	| tt |
	tt _ TTCFontDescription default.
	tt ifNil: [TTCFontDescription setDefault].
	tt _ TTCFontDescription default.
	tt ifNotNil: [self newTextStyleFromTT: tt].
! !

!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 12:49'!
unregister: symbolName

	self registry removeKey: symbolName ifAbsent: [].
! !
TTGlyph subclass: #TTCompositeGlyph
	instanceVariableNames: 'glyphs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'TrueType-Fonts'!
!TTCompositeGlyph commentStamp: '<historical>' prior: 0!
This class represents a composite TrueType glyph, e.g.one which contains many simple TTGlyphs.!


!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:21'!
addGlyph: aGlyph transformation: aMatrix
	glyphs := glyphs copyWith: (aMatrix -> aGlyph)! !

!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:43'!
contours
	^contours ifNil:[contours := self computeContours]! !

!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:20'!
glyphs

	^glyphs collect:[:assoc| assoc value].! !

!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:28'!
glyphsAndTransformationsDo: aBlock
	glyphs do:[:assoc|
		aBlock value: assoc value value: assoc key.
	].! !


!TTCompositeGlyph methodsFor: 'initialize' stamp: 'ar 11/2/1998 01:20'!
initialize
	glyphs := #().! !


!TTCompositeGlyph methodsFor: 'testing'!
isComposite
	^true! !


!TTCompositeGlyph methodsFor: 'private' stamp: 'ar 11/2/1998 01:43'!
computeContours
	| out |
	out := WriteStream on: (Array new: glyphs size * 4).
	self glyphsAndTransformationsDo:[:glyph :transform|
		glyph contours do:[:ptArray|
			out nextPut: (transform localPointsToGlobal: ptArray).
		].
	].
	^out contents! !

!TTCompositeGlyph methodsFor: 'private' stamp: 'ar 11/14/1998 20:27'!
flipAroundY
	bounds := (bounds origin x @ bounds corner y negated) corner:
				(bounds corner x @ bounds origin y negated).
	contours := nil.! !
Object subclass: #TTContourConstruction
	instanceVariableNames: 'points'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'TrueType-Support'!
!TTContourConstruction commentStamp: '<historical>' prior: 0!
This class represents a temporary contour structure during the construction of a TTGlyph from a TrueType file.

Instance variables:
	points	<Array of: TTPoint>	The points defining this contour!


!TTContourConstruction methodsFor: 'accessing'!
points
	^points! !

!TTContourConstruction methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:34'!
points: anArray
	points := anArray asArray.! !

!TTContourConstruction methodsFor: 'accessing'!
segments

	| segments |
	segments := OrderedCollection new.
	self segmentsDo:[:seg| segments add: seg].
	^segments! !


!TTContourConstruction methodsFor: 'converting' stamp: 'di 11/21/1999 20:19'!
asCompressedPoints
	"Return the receiver compressed into a PointArray.
	All lines will be converted into bezier segments with
	the control point set to the start point"
	| out minPt maxPt fullRange |
	minPt := -16r7FFF asPoint.
	maxPt := 16r8000 asPoint.
	"Check if we need full 32bit range"
	fullRange := points anySatisfy: [:any| any asPoint < minPt or:[any asPoint > maxPt]].
	fullRange ifTrue:[
		out := WriteStream on: (PointArray new: points size).
	] ifFalse:[
		out := WriteStream on: (ShortPointArray new: points size).
	].
	self segmentsDo:[:segment|
		out nextPut: segment start.
		segment isBezier2Segment 
			ifTrue:[out nextPut: segment via]
			ifFalse:[out nextPut: segment start].
		out nextPut: segment end.
	].
	^out contents! !


!TTContourConstruction methodsFor: 'enumerating' stamp: 'hmm 10/28/2001 21:55'!
segmentsDo: aBlock
	"Evaluate aBlock with the segments of the receiver. This may either be straight line
	segments or quadratic bezier curves. The decision is made upon the type flags
	in TTPoint as follows:
	a) 	Two subsequent #OnCurve points define a straight segment
	b) 	An #OnCurve point followed by an #OffCurve point followed 
		by an #OnCurve point defines a quadratic bezier segment
	c)	Two subsequent #OffCurve points have an implicitely defined 
		#OnCurve point at half the distance between them"
	| last next mid index i |
	last := points first.
	"Handle case where first point is off-curve"
	(last type == #OnCurve) ifFalse: [
		i := points findFirst: [:pt | pt type == #OnCurve].
		i = 0
			ifTrue: [mid := TTPoint new
							type: #OnCurve;
							x: points first x + points last x // 2;
							y: points first y + points last y // 2.
					points := (Array with: mid), points]
			ifFalse: [points := (points copyFrom: i to: points size), (points copyFrom: 1 to: i)].
		last := points first].
	index := 2.
	[index <= points size] whileTrue:[
		mid := points at: index.
		mid type == #OnCurve ifTrue:[
			"Straight segment"
			aBlock value: (LineSegment from: last asPoint to: mid asPoint).
			last := mid.
		] ifFalse:["Quadratic bezier"
			"Read ahead if the next point is on curve"
			next := (index < points size) ifTrue:[points at: (index+1)] ifFalse:[points first].
			next type == #OnCurve ifTrue:[
				"We'll continue after the end point"
				index := index + 1.
			] ifFalse:[ "Calculate center"
				next := (next asPoint + mid asPoint) // 2].
			aBlock value:(Bezier2Segment from: last asPoint via: mid asPoint to: next asPoint).
			last := next].
		index := index + 1].
	(index = (points size + 1)) ifTrue:[
		aBlock value:(LineSegment from: points last asPoint to: points first asPoint)]! !


!TTContourConstruction methodsFor: 'printing'!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPut:$(;
		print: points size;
		"space;
		print: self type;"
		nextPut:$)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTContourConstruction class
	instanceVariableNames: ''!

!TTContourConstruction class methodsFor: 'instance creation'!
on: points

	^self new points: points! !
Object subclass: #TTFontDescription
	instanceVariableNames: 'glyphTable glyphs kernPairs copyright familyName fullName subfamilyName uniqueName versionName postscriptName trademark bounds unitsPerEm ascender descender lineGap'
	classVariableNames: 'Default Descriptions'
	poolDictionaries: ''
	category: 'TrueType-Fonts'!
!TTFontDescription commentStamp: '<historical>' prior: 0!
Holds a TrueType font in memory.  Is used by TTSampleStringMorph as its font.  

Class owns a default example.  !


!TTFontDescription methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:08'!
at: aCharOrInteger
	^glyphTable at: aCharOrInteger asInteger+1! !

!TTFontDescription methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:08'!
at: index put: value
	^self shouldNotImplement! !

!TTFontDescription methodsFor: 'accessing' stamp: 'yo 11/30/2002 22:38'!
name

	^ self familyName copyWithout: Character space.
! !

!TTFontDescription methodsFor: 'accessing' stamp: 'yo 11/30/2002 22:38'!
size

	^ glyphs size.
! !


!TTFontDescription methodsFor: 'converting' stamp: 'sma 5/5/2000 13:46'!
asStrikeFontScale: scale
	"Generate a StrikeFont (actually a FormSetFont) for this TTF font at a given scale."

	| forms |
	forms := (0 to: 255) collect:
		[:i |
		(self at: i)
			asFormWithScale: scale
			ascender: ascender
			descender: descender].
	^ FormSetFont new
		fromFormArray: forms
		asciiStart: 0
		ascent: (ascender * scale) rounded! !


!TTFontDescription methodsFor: 'copying' stamp: 'yo 6/23/2003 18:23'!
deepCopy

	"Since it shouldn't be copied for transmitting or any reason, it returns self."
	^ self.
! !

!TTFontDescription methodsFor: 'copying' stamp: 'nk 9/3/2004 14:48'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to a known Font in the other system instead.  "

	"A path to me"
	(TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self].
		"special case for saving the default fonts on the disk.  See collectionFromFileNamed:"

	dp := DiskProxy global: #TTFontDescription selector: #descriptionFullNamed:
			args: {self fullName}.
	refStrm replace: self with: dp.
	^ dp.
! !

!TTFontDescription methodsFor: 'copying' stamp: 'yo 11/30/2002 22:38'!
veryDeepCopyWith: deepCopier
	"Return self.  I am shared.  Do not record me."
! !


!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
copyright
	^copyright! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
familyName
	^familyName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
fullName
	^fullName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
postscriptName
	^postscriptName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
subfamilyName
	^subfamilyName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
trademark
	^trademark! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
uniqueName
	^uniqueName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:49'!
versionName
	^versionName! !


!TTFontDescription methodsFor: 'migration' stamp: 'yo 8/16/2004 10:44'!
blankGlyphForSeparators

	| space |
	space := (self at: Character space charCode) copy.
	space contours: #().
	Character separators do: [:s | 
		glyphTable at: s charCode +1 put: space.
	].
! !


!TTFontDescription methodsFor: 'printing' stamp: 'th 6/27/2003 17:08'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	familyName printOn: aStream.
	aStream nextPut:$).! !


!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'!
ascender
	^ascender! !

!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'!
bounds
	^bounds! !

!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'!
descender
	^descender! !

!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'!
lineGap
	^lineGap! !

!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:49'!
unitsPerEm
	^unitsPerEm! !


!TTFontDescription methodsFor: '*Morphic-TrueType' stamp: 'ar 11/14/1998 23:47'!
asMorph
	^TTSampleFontMorph font: self! !


!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/14/1998 20:20'!
flipAroundY
	bounds := (bounds origin x @ bounds corner y negated) corner:
				(bounds corner x @ bounds origin y negated).
	glyphs do:[:glyph| glyph flipAroundY]! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:27'!
setAscender: asc descender: desc lineGap: lgap
	ascender := asc.
	descender := desc.
	lineGap := lgap! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:28'!
setBounds: aRect unitsPerEm: aNumber
	bounds := aRect.
	unitsPerEm := aNumber.! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:27'!
setGlyphs: glyphArray mapping: mappingTable
	glyphs := glyphArray.
	glyphTable := mappingTable.! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:48'!
setKernPairs: array
	kernPairs := array! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:46'!
setStrings: anArray
	copyright := anArray at: 1.
	familyName := anArray at: 2.
	subfamilyName := anArray at: 3.
	uniqueName := anArray at: 4.
	fullName := anArray at: 5.
	versionName := anArray at: 6.
	postscriptName := anArray at: 7.
	trademark := anArray at: 8.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTFontDescription class
	instanceVariableNames: ''!

!TTFontDescription class methodsFor: 'instance creations' stamp: 'tb 6/24/2003 17:10'!
addFromTTFile: fileName
"
	self addFromTTFile: 'C:\WINDOWS\Fonts\ARIALN.TTF'
"
	^self addFromTTStream: (FileStream readOnlyFileNamed: fileName).
! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'tb 6/24/2003 17:08'!
addFromTTStream: readStream
"
	self addFromTTFile: 'C:\WINDOWS\Fonts\ARIALN.TTF'
"

	| tt old |
	tt := TTFontReader readFrom: readStream.
	old := Descriptions detect: [:f | f name = tt name and: [f subfamilyName = tt subfamilyName]] ifNone: [nil].
	old ifNotNil: [Descriptions remove: old].
	Descriptions add: tt.
	^ tt.
! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 11/30/2002 22:22'!
clearDefault
"
	self clearDefault
"

	Default := nil.
! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 11/30/2002 22:22'!
clearDescriptions
"
	self clearDescriptions
"

	Descriptions := Set new.
	Default ifNotNil: [Descriptions add: Default].
! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'tk 12/10/2001 17:12'!
default
	^ Default! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'dgd 11/4/2003 17:54'!
descriptionFullNamed: descriptionFullName 
	^ Descriptions
		detect: [:f | f fullName = descriptionFullName]
		ifNone: [Default]! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 11/30/2002 22:22'!
descriptionNamed: descriptionName

	^ Descriptions detect: [:f | f name = descriptionName] ifNone: [Default].
! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 11/30/2002 22:22'!
initialize
"
	self initialize
"

	self clearDescriptions.
! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 2/21/2004 02:36'!
removeDescriptionNamed: descriptionName

	| tt |
	Descriptions ifNil: [^ self].
	[(tt :=  Descriptions detect: [:f | f name = descriptionName] ifNone: [nil]) notNil] whileTrue:[
		 Descriptions remove: tt
	].
! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 12/13/2002 13:55'!
removeDescriptionNamed: descriptionName subfamilyName: subfamilyName

	| tts |
	Descriptions ifNil: [^ self].
	tts := Descriptions select: [:f | f name = descriptionName and: [f subfamilyName = subfamilyName]].
	tts do: [:f | Descriptions remove: f].
! !

!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 12/13/2002 13:20'!
setDefault
"
	self setDefault
"

	Default := TTFontReader readFrom: (FileStream readOnlyFileNamed: 'C:\WINDOWS\Fonts\comic.ttf').
! !
Object subclass: #TTFontReader
	instanceVariableNames: 'charMap glyphs nGlyphs kernPairs infoBar fontDescription'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'TrueType-Support'!
!TTFontReader commentStamp: '<historical>' prior: 0!
TTFontReader constructs a TTFontDescription from a TrueType font (.ttf).!


!TTFontReader methodsFor: 'processing' stamp: 'th 6/27/2003 16:58'!
processCharMap: assoc
	"Process the given character map"

	| charTable glyph cmap |
	cmap := assoc value.
	charTable := Array new: 256 withAll: glyphs first. "Initialize with default glyph"

	assoc key = 1 ifTrue: "Mac encoded table"
		[1 to: (cmap size min: charTable size) do:
			[:i |
			glyph := glyphs at: (cmap at: i) + 1.
			charTable at: (self macToWin: i) put: glyph]].

	assoc key = 3 ifTrue: "Win encoded table"
		[1 to: (cmap size min: charTable size) do:
			[:i |
			glyph := glyphs at: (cmap at: i) + 1.
			charTable at: i put: glyph]].

	^ charTable! !

!TTFontReader methodsFor: 'processing' stamp: 'yo 6/29/2004 23:33'!
processCharacterMappingTable: entry
	"Read the font's character to glyph index mapping table.
	If an appropriate mapping can be found then return an association
	with the format identifier and the contents of the table"
	| copy initialOffset nSubTables pID sID offset cmap assoc |
	initialOffset := entry offset.
	entry skip: 2. "Skip table version"
	nSubTables := entry nextUShort.
	1 to: nSubTables do:[:i|
		pID := entry nextUShort.
		sID := entry nextUShort.
		offset := entry nextULong.
		"Check if this is either a Macintosh encoded table
		or a Windows encoded table"
		(pID = 1 or:[pID = 3]) ifTrue:[
			"Go to the beginning of the table"
			copy := entry copy.
			copy offset: initialOffset + offset.
			cmap := self decodeCmapFmtTable: copy.
			(pID = 3 and: [cmap notNil]) "Prefer Windows encoding over everything else"
				ifTrue: [^ pID -> cmap].
			assoc := pID -> cmap. "Keep it in case we don't find a Mac encoded table"
		].
	].
	^assoc! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/15/1998 01:00'!
processCompositeGlyph: glyph contours: nContours from: entry
	"Read a composite glyph from the font data. The glyph passed into this method contains some state variables that must be copied into the resulting composite glyph."
	| flags glyphIndex hasInstr cGlyph ofsX ofsY iLen a11 a12 a21 a22 m |
	cGlyph := TTCompositeGlyph new.
	a11 := a22 := 16r4000.	"1.0 in F2Dot14"
	a21 := a12 := 0.		"0.0 in F2Dot14"
	"Copy state"
	cGlyph bounds: glyph bounds; glyphIndex: glyph glyphIndex.
	hasInstr := false.
	[ flags := entry nextUShort.
	glyphIndex := entry nextUShort + 1.
	(flags bitAnd: 1) = 1 ifTrue:[
		ofsX := entry nextShort.
		ofsY := entry nextShort.
	] ifFalse:[
		(ofsX := entry nextByte) > 127 ifTrue:[ofsX := ofsX - 256].
		(ofsY := entry nextByte) > 127 ifTrue:[ofsY := ofsY - 256]].
	((flags bitAnd: 2) = 2) ifFalse:[self halt].
	(flags bitAnd: 8) = 8 ifTrue:[
		a11 := a22 := entry nextShort].
	(flags bitAnd: 64) = 64 ifTrue:[
		a11 := entry nextShort.
		a22 := entry nextShort].
	(flags bitAnd: 128) = 128 ifTrue:[
		"2x2 transformation"
		a11 := entry nextShort.
		a21 := entry nextShort.
		a12 := entry nextShort.
		a22 := entry nextShort].
	m := MatrixTransform2x3 new.
	"Convert entries from F2Dot14 to float"
	m a11: (a11 asFloat / 16r4000).
	m a12: (a12 asFloat / 16r4000).
	m a21: (a21 asFloat / 16r4000).
	m a22: (a22 asFloat / 16r4000).
	m a13: ofsX.
	m a23: ofsY.
	cGlyph addGlyph: (glyphs at: glyphIndex) transformation: m.
	hasInstr := hasInstr or:[ (flags bitAnd: 256) = 256].
	"Continue as long as the MORE:=COMPONENTS bit is set"
	(flags bitAnd: 32) = 32] whileTrue.
	hasInstr ifTrue:[
		iLen := entry nextUShort.
		entry skip: iLen].
	^cGlyph! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:42'!
processFontHeaderTable: entry
"Value				Data Type    Description
unitsPerEm			USHORT      Granularity of the font's em square.
xMax				USHORT      Maximum X-coordinate for the entire font.
xMin				USHORT      Minimum X-coordinate for the entire font.
yMax				USHORT      Maximum Y-coordinate for the entire font.
yMin				USHORT      Minimum Y-coordinate for the entire font.
indexToLocFormat	SHORT       Used when processing the Index To Loc Table."
	| origin corner units indexToLocFormat |
	entry skip: 4. "Skip table version number"
	entry skip: 4. "Skip font revision number"
	entry skip: 4. "Skip check sum adjustment"
	entry skip: 4. "Skip magic number"
	entry skip: 2. "Skip flags"

	units := entry nextUShort.

	entry skip: 8. "Skip creation date"
	entry skip: 8. "Skip modification date"

	"Get min/max values of all glyphs"
	origin := entry nextShort @ entry nextShort.
	corner := entry nextShort @ entry nextShort.

	entry skip: 2. "Skip mac style"
	entry skip: 2. "Skip lowest rec PPEM"
	entry skip: 2. "Skip font direction hint"
	indexToLocFormat := entry nextShort.

	fontDescription setBounds: (origin corner: corner) unitsPerEm: units.
	^indexToLocFormat! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/3/1998 14:43'!
processGlyphDataTable: entry offsets: offsetArray
	"Read the actual glyph data from the font.
	offsetArray contains the start offsets in the data for each glyph."
	| initialOffset glyph nextOffset glyphLength glyphOffset nContours origin corner |
	initialOffset := entry offset.
	glyphs := Array new: nGlyphs.
	1 to: nGlyphs do:[:i | 
		glyphs at: i put: (TTGlyph new glyphIndex: i-1)].
	'Reading glyph data' 
		displayProgressAt: Sensor cursorPoint
		from: 1 to: nGlyphs during:[:bar|

	1 to: nGlyphs do:[:glyphIndex |
		bar value: glyphIndex.
		glyph := glyphs at: glyphIndex.
		glyphOffset := offsetArray at: glyphIndex.
		nextOffset := offsetArray at: glyphIndex+1.
		glyphLength := nextOffset - glyphOffset.
		glyphLength = 0 ifFalse:[
			entry offset: initialOffset + glyphOffset.
			nContours := entry nextShort.
			origin := entry nextShort @ entry nextShort.
			corner := entry nextShort @ entry nextShort.
			glyph bounds: (origin corner: corner).
			nContours >= 0 ifTrue:[
				self processSimpleGlyph: glyph contours: nContours from: entry
			] ifFalse:[
				glyph := self processCompositeGlyph: glyph contours: nContours from: entry.
				glyphs at: glyphIndex put: glyph]]]
	].! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:40'!
processHorizontalHeaderTable: entry
"
ascender           SHORT          Typographic ascent.
descender          SHORT          Typographic descent.
lineGap            SHORT          Typographic lineGap.
numberOfHMetrics   USHORT         Number hMetric entries in the HTMX
                                               Table; may be smaller than the total
                                             number of glyphs.
"
	| asc desc lGap numHMetrics |
	entry skip: 4. "Skip table version"
	asc := entry nextShort.
	desc := entry nextShort.
	lGap := entry nextShort.
	entry skip: 2. "Skip advanceWidthMax"
	entry skip: 2. "Skip minLeftSideBearing"
	entry skip: 2. "Skip minRightSideBearing"
	entry skip: 2. "Skip xMaxExtent"
	entry skip: 2. "Skip caretSlopeRise"
	entry skip: 2. "Skip caretSlopeRun"
	entry skip: 10. "Skip 5 reserved shorts"
	entry skip: 2. "Skip metricDataFormat"

	numHMetrics := entry nextUShort.

	fontDescription setAscender: asc descender: desc lineGap: lGap.
	^numHMetrics! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:40'!
processHorizontalMetricsTable: entry length: numHMetrics
	"Extract the advance width, left side bearing, and right
	side bearing for each glyph from the Horizontal Metrics Table."
	|  index lastAW glyph |
	index := 1.
	[index <= numHMetrics] whileTrue:[
		glyph := glyphs at: index.
		glyph advanceWidth: entry nextUShort.
		glyph leftSideBearing: entry nextShort.
		glyph updateRightSideBearing.
		index := index + 1].
	index = (nGlyphs +1) ifTrue:[^true].
	lastAW := (glyphs at: index-1) advanceWidth.

	[index <= nGlyphs] whileTrue:[
		glyph := glyphs at: index.
		glyph advanceWidth: lastAW.
		glyph leftSideBearing: entry nextShort.
		glyph updateRightSideBearing.
		index := index + 1].! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:43'!
processIndexToLocationTable: entry format: indexToLocFormat
"glyphOffset    ULONG[numGlyphs]   An array that contains each glyph's
                                 offset into the Glyph Data Table.
"	| glyphOffset offset|
	glyphOffset := Array new: nGlyphs+1.
	1 to: nGlyphs+1 do:[:i|
		(indexToLocFormat = 0) ifTrue:[ "Format0: offset/2 is stored"
			offset := entry nextUShort * 2.
		] ifFalse:["Format1: store actual offset"
			offset := entry nextULong].
		glyphOffset at: i put: offset].
	^glyphOffset! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/1/1998 23:21'!
processKerningTable: entry
	"Extract the kerning information for pairs of glyphs."
	| covLow covHigh nKernPairs kp |
	entry skip: 2. "Skip table version"
	entry skip: 2. "Skip number of sub tables -- we're using the first one only"
	entry skip: 2. "Skip current subtable number"
	entry skip: 2. "Skip length of subtable"
	covHigh := entry nextByte.
	covLow := entry nextByte.

	"Make sure the format is right (kerning table and format type 0)"
	((covLow bitAnd: 2) = 2 or:[ covHigh ~= 0]) ifTrue:[^false].
	nKernPairs := entry nextUShort.
	entry skip: 2. "Skip search range"
	entry skip: 2. "Skip entry selector"
	entry skip: 2. "Skip range shift"
	kernPairs := Array new: nKernPairs.
	1 to: nKernPairs do:[:i|
		kp := TTKernPair new.
		kp left: entry nextUShort.
		kp right: entry nextUShort.
		kp value: entry nextShort.
		kernPairs at: i put: kp].
	^true! !

!TTFontReader methodsFor: 'processing'!
processMaximumProfileTable: entry
"
numGlyphs         USHORT      The number of glyphs in the font.
"
	entry skip: 4. "Skip Table version number"
	nGlyphs := entry nextUShort.! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:38'!
processNamingTable: entry
"copyright         CHARPTR     The font's copyright notice.
familyName        CHARPTR     The font's family name.
subfamilyName     CHARPTR     The font's subfamily name.
uniqueName        CHARPTR     A unique identifier for this font.
fullName          CHARPTR     The font's full name (a combination of
                                          familyName and subfamilyName).
versionName       CHARPTR     The font's version string.
"	| nRecords initialOffset storageOffset pID sID lID nID length offset multiBytes string strings |
	strings := Array new: 8.
	strings atAllPut:''.
	initialOffset := entry offset.
	entry skip: 2. "Skip format selector"
	"Get the number of name records"
	nRecords := entry nextUShort.
	"Offset from the beginning of this table"
	storageOffset := entry nextUShort + initialOffset.
	1 to: nRecords do:[:i|
		pID := entry nextUShort.
		sID := entry nextUShort.
		lID := entry nextUShort.
		nID := entry nextUShort.
		length := entry nextUShort.
		offset := entry nextUShort.
		"Read only Macintosh or Microsoft strings"
		(pID = 1 or:[pID = 3 and:[sID = 1]]) ifTrue:[
			"MS uses Unicode all others single byte"
			multiBytes := pID = 3.
			string := entry stringAt: storageOffset + offset length: length multiByte: multiBytes.
			"Put the name at the right location.
			Note: We prefer Macintosh strings about everything else."
			nID < strings size ifTrue:[
				(pID = 1 or:[(strings at: nID+1) = ''])
					ifTrue:[strings at: nID+1 put: string].
			].
		].
	].
	fontDescription setStrings: strings.! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/1/1998 22:18'!
processSimpleGlyph: glyph contours: nContours from: entry

	| endPts  nPts iLength flags |
	endPts := Array new: nContours.
	1 to: nContours do:[:i| endPts at: i put: entry nextUShort].
	glyph initializeContours: nContours with: endPts.
	nPts := endPts last + 1.
	iLength := entry nextUShort. "instruction length"
	entry skip: iLength.
	flags := self getGlyphFlagsFrom: entry size: nPts.
	self readGlyphXCoords: entry glyph: glyph nContours: nContours flags: flags endPoints: endPts.
	self readGlyphYCoords: entry glyph: glyph nContours: nContours flags: flags endPoints: endPts.
	glyph buildContours.! !


!TTFontReader methodsFor: 'public' stamp: 'sd 1/30/2004 15:24'!
readFrom: aStream

	| fontData headerEntry maxProfileEntry nameEntry indexLocEntry charMapEntry glyphEntry horzHeaderEntry horzMetricsEntry kerningEntry glyphOffset cmap numHMetrics indexToLocFormat |

	"Read the raw font byte data"
	aStream binary.
	fontData := aStream contents asByteArray.
	fontDescription := TTFontDescription new.

	"Search the tables required to build the font"
	(headerEntry := self getTableDirEntry: 'head' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a header table'].
	(maxProfileEntry := self getTableDirEntry: 'maxp' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a maximum profile table'].
	(nameEntry := self getTableDirEntry: 'name' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a name table'].
	(indexLocEntry := self getTableDirEntry: 'loca' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a relocation table'].
	(charMapEntry := self getTableDirEntry: 'cmap' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a character map table'].
	(glyphEntry := self getTableDirEntry: 'glyf' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a glyph table'].
	(horzHeaderEntry := self getTableDirEntry: 'hhea' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a horizontal header table'].
	(horzMetricsEntry := self getTableDirEntry: 'hmtx' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a horizontal metrics table'].
	(kerningEntry := self getTableDirEntry: 'kern' from: fontData) == nil ifTrue:[
		Transcript cr; show:'This font does not have a kerning table';endEntry].


	"Process the data"
	indexToLocFormat := self processFontHeaderTable: headerEntry.
	self processMaximumProfileTable: maxProfileEntry.
	self processNamingTable: nameEntry.
	glyphOffset := self processIndexToLocationTable: indexLocEntry format: indexToLocFormat.
	cmap := self processCharacterMappingTable: charMapEntry.
	(cmap == nil or:[cmap value == nil])
		ifTrue:[^self error:'This font has no suitable character mappings'].
	self processGlyphDataTable: glyphEntry offsets: glyphOffset.
	numHMetrics := self processHorizontalHeaderTable: horzHeaderEntry.
	self processHorizontalMetricsTable: horzMetricsEntry length: numHMetrics.
	kerningEntry isNil 
		ifTrue:[kernPairs := #()]
		ifFalse:[self processKerningTable: kerningEntry].
	charMap := self processCharMap: cmap.
	fontDescription setGlyphs: glyphs mapping: charMap.
	fontDescription setKernPairs: kernPairs.
	^fontDescription! !


!TTFontReader methodsFor: 'private' stamp: 'sma 1/1/2000 19:17'!
decodeCmapFmtTable: entry
	| cmapFmt length cmap firstCode entryCount segCount segments offset code |
	cmapFmt := entry nextUShort.
	length := entry nextUShort.
	entry skip: 2. "skip version"

	cmapFmt = 0 ifTrue: "byte encoded table"
		[length := length - 6. 		"should be always 256"
		length <= 0 ifTrue: [^ nil].	"but sometimes, this table is empty"
		cmap := Array new: length.
		entry nextBytes: length into: cmap startingAt: entry offset.
		^ cmap].

	cmapFmt = 4 ifTrue: "segment mapping to deltavalues"
		[segCount := entry nextUShort // 2.
		entry skip: 6. "skip searchRange, entrySelector, rangeShift"
		segments := Array new: segCount.
		segments := (1 to: segCount) collect: [:e | Array new: 4].
		1 to: segCount do: [:i | (segments at: i) at: 2 put: entry nextUShort]. "endCount"
		entry skip: 2. "skip reservedPad"
		1 to: segCount do: [:i | (segments at: i) at: 1 put: entry nextUShort]. "startCount"
		1 to: segCount do: [:i | (segments at: i) at: 3 put: entry nextShort]. "idDelta"
		offset := entry offset.
		1 to: segCount do: [:i | (segments at: i) at: 4 put: entry nextUShort]. "idRangeOffset"
		cmap := Array new: 256 withAll: 0. "could be larger, but Squeak can't handle that"
		segments withIndexDo:
			[:seg :si |
			seg first to: seg second do:
				[:i |
				i < 256 ifTrue:
					[seg last > 0 ifTrue:
						["offset to glypthIdArray - this is really C-magic!!"
						entry offset: i - seg first - 1 * 2 + seg last + si + si + offset. 
						code := entry nextUShort.
						code > 0 ifTrue: [code := code + seg third]]
					ifFalse:
						["simple offset"
						code := i + seg third].
					cmap at: i + 1 put: code]]].
		^ cmap].

	cmapFmt = 6 ifTrue: "trimmed table"
		[firstCode := entry nextUShort.
		entryCount := entry nextUShort.
		cmap := Array new: entryCount + firstCode withAll: 0.
		entryCount timesRepeat:
			[cmap at: (firstCode := firstCode + 1) put: entry nextUShort].
		^ cmap].
	^ nil! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:33'!
getGlyphFlagsFrom: entry size: nPts
	"Read in the flags for this glyph.  The outer loop gathers the flags that
	are actually contained in the table.  If the repeat bit is set in a flag
	then the next byte is read from the table; this is the number of times
	to repeat the last flag.  The inner loop does this, incrementing the
	outer loops index each time."
	| flags index repCount flagBits |
	flags := ByteArray new: nPts.
	index := 1.
	[index <= nPts] whileTrue:[
		flagBits := entry nextByte.
		flags at: index put: flagBits.
		(flagBits bitAnd: 8) = 8 ifTrue:[
			repCount := entry nextByte.
			repCount timesRepeat:[
				index := index + 1.
				flags at: index put: flagBits]].
		index := index + 1].
	^flags! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:33'!
getTableDirEntry: tagString from: fontData
	"Find the table named tagString in fontData and return a table directory entry for it."
	| nTables pos currentTag tag |
	nTables := fontData shortAt: 5 bigEndian: true.
	tag := ByteArray new: 4.
	1 to: 4 do:[:i| tag byteAt: i put: (tagString at: i) asInteger].
	tag := tag longAt: 1 bigEndian: true.
	pos := 13.
	1 to: nTables do:[:i|
		currentTag := fontData longAt: pos bigEndian: true.
		currentTag = tag ifTrue:[^TTFontTableDirEntry on: fontData at: pos].
		pos := pos+16].
	^nil! !

!TTFontReader methodsFor: 'private' stamp: 'ar 4/10/2005 16:10'!
macToWin: index
	^ (index - 1) asCharacter macToSqueak asciiValue + 1! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:36'!
readGlyphXCoords:entry glyph: glyph nContours: nContours flags: flags endPoints: endPts
	"Read the x coordinates for the given glyph from the font file."
	| startPoint endPoint flagBits xValue contour ttPoint |
	startPoint := 1.
	1 to: nContours do:[:i|
		contour := glyph contours at: i.
		"Get the end point"
		endPoint := (endPts at: i) + 1.
		"Store number of points"
		startPoint to: endPoint do:[:j|
			ttPoint := contour points at: (j - startPoint + 1).
			flagBits := flags at: j.
			"If bit zero in the flag is set then this point is an on-curve
			point, if not, then it is an off-curve point."
			(flagBits bitAnd: 1) = 1 
				ifTrue:[ ttPoint type: #OnCurve]
				ifFalse:[ttPoint type: #OffCurve].
			"First we check to see if bit one is set.  This would indicate that
			the corresponding coordinate data in the table is 1 byte long.
			If the bit is not set, then the coordinate data is 2 bytes long."
			(flagBits bitAnd: 2) = 2 ifTrue:[ "one byte"
				xValue := entry nextByte.
				xValue := (flagBits bitAnd: 16)=16 ifTrue:[xValue] ifFalse:[xValue negated].
				ttPoint x: xValue.
			] ifFalse:[ "two byte"
				"If bit four is set, then this coordinate is the same as the
				last one, so the relative offset (of zero) is stored.  If bit
				is not set, then read in two bytes and store it as a signed value."
				(flagBits bitAnd: 16) = 16 ifTrue:[ ttPoint x: 0 ]
				ifFalse:[
					xValue := entry nextShort.
					ttPoint x: xValue]]].
		startPoint := endPoint + 1]! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:37'!
readGlyphYCoords:entry glyph: glyph nContours: nContours flags: flags endPoints: endPts
	"Read the y coordinates for the given glyph from the font file."
	| startPoint endPoint flagBits yValue contour ttPoint |
	startPoint := 1.
	1 to: nContours do:[:i|
		contour := glyph contours at: i.
		"Get the end point"
		endPoint := (endPts at: i) + 1.
		"Store number of points"
		startPoint to: endPoint do:[:j|
			ttPoint := contour points at: (j - startPoint + 1).
			flagBits := flags at: j.
			"Check if this value one or two byte encoded"
			(flagBits bitAnd: 4) = 4 ifTrue:[ "one byte"
				yValue := entry nextByte.
				yValue := (flagBits bitAnd: 32)=32 ifTrue:[yValue] ifFalse:[yValue negated].
				ttPoint y: yValue.
			] ifFalse:[ "two byte"
				(flagBits bitAnd: 32) = 32 ifTrue:[ ttPoint y: 0 ]
				ifFalse:[
					yValue := entry nextShort.
					ttPoint y: yValue]]].
		startPoint := endPoint + 1]! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/1/1998 21:01'!
warn: aString
	Transcript cr; show: aString; endEntry.! !

!TTFontReader methodsFor: 'private' stamp: 'ar 4/10/2005 16:11'!
winToMac: index
	^ (index - 1) asCharacter squeakToMac asciiValue + 1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTFontReader class
	instanceVariableNames: ''!

!TTFontReader class methodsFor: 'class initialization' stamp: 'nk 7/16/2003 15:56'!
fileReaderServicesForFile: fullName suffix: suffix


	^(suffix = 'fnt')  | (suffix = '*') 
		ifTrue: [ self services]
		ifFalse: [#()]
! !

!TTFontReader class methodsFor: 'class initialization' stamp: 'sd 2/1/2002 19:32'!
initialize
	"self initialize"

	FileList registerFileReader: self! !

!TTFontReader class methodsFor: 'class initialization' stamp: 'sd 2/1/2002 19:31'!
openTTFFile: fullName 

	(TTFontReader parseFileNamed: fullName) asMorph open! !

!TTFontReader class methodsFor: 'class initialization' stamp: 'sd 2/1/2002 22:02'!
serviceOpenTrueTypeFont

	^ SimpleServiceEntry 
				provider: self 
				label: 'open true type font'
				selector: #openTTFFile:
				description: 'open true type font'! !

!TTFontReader class methodsFor: 'class initialization' stamp: 'sd 2/1/2002 22:03'!
services

	^ Array with: self serviceOpenTrueTypeFont
! !

!TTFontReader class methodsFor: 'class initialization' stamp: 'sd 2/1/2002 19:29'!
unload

	FileList unregisterFileReader: self ! !


!TTFontReader class methodsFor: 'instance creation' stamp: 'nk 4/1/2004 09:05'!
installTTF: ttfFileName asTextStyle: textStyleName sizes: sizeArray
	"Sizes are in pixels."
	"TTFontReader
		installTTF: 'F:\fonts\amazon:=:=.TTF' 
		asTextStyle: #Amazon
		sizes: #(24 60)"

	| ttf fontArray |
	ttf := self parseFileNamed: ttfFileName.
	fontArray := sizeArray collect:
		[:each |
		(ttf asStrikeFontScale: each / ttf unitsPerEm)
			name: textStyleName;
			pixelSize: each].
	TextConstants at: textStyleName asSymbol put: (TextStyle fontArray: fontArray)! !

!TTFontReader class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 23:43'!
parseFileNamed: aString
	"TTFontReader parseFileNamed:'c:\windows\arial.ttf'"
	"TTFontReader parseFileNamed:'c:\windows\times.ttf'"
	| contents |
	contents := (FileStream readOnlyFileNamed: aString) binary contentsOfEntireFile.
	^self readFrom: (ReadStream on: contents)! !

!TTFontReader class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 00:53'!
readFrom: aStream

	^self new readFrom: aStream! !

!TTFontReader class methodsFor: 'instance creation' stamp: 'yo 2/15/2004 18:40'!
readTTFFrom: aStream

	^self new readTTFFrom: aStream! !
Object subclass: #TTFontTableDirEntry
	instanceVariableNames: 'tag fontData offset length checkSum'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'TrueType-Support'!
!TTFontTableDirEntry commentStamp: '<historical>' prior: 0!
This class represents an entry in a truetype font table directory. Used by TTFontReader only.!


!TTFontTableDirEntry methodsFor: 'accessing'!
nextByte

	| value |
	value := fontData byteAt: offset.
	offset := offset + 1.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextBytes: numBytes into: array startingAt: byteOffset

	1 to: numBytes do:[:i|
		array at: i put: (fontData byteAt: byteOffset + i - 1)].! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextLong

	| value |
	value := fontData longAt: offset bigEndian: true.
	offset := offset + 4.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextShort

	| value |
	value := fontData shortAt: offset bigEndian: true.
	offset := offset + 2.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextULong

	| value |
	value := fontData unsignedLongAt: offset bigEndian: true.
	offset := offset + 4.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextUShort

	| value |
	value := fontData unsignedShortAt: offset bigEndian: true.
	offset := offset + 2.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
offset
	^offset! !

!TTFontTableDirEntry methodsFor: 'accessing'!
offset: newOffset
	offset := newOffset! !

!TTFontTableDirEntry methodsFor: 'accessing'!
skip: n
	"Skip n bytes"
	offset := offset + n.! !

!TTFontTableDirEntry methodsFor: 'accessing' stamp: 'ar 11/1/1998 23:37'!
stringAt: stringOffset length: byteLength multiByte: aBoolean

	| string index stringLength |
	aBoolean ifFalse:[
		stringLength := byteLength.
		string := String new: stringLength.
		index := stringOffset.
		1 to: stringLength do:[:i|
			string at: i put: (Character value: (fontData byteAt: index + i - 1))].
		^string
	] ifTrue:[
		stringLength := byteLength // 2.
		string := String new: stringLength.
		index := stringOffset.
		1 to: stringLength do:[:i|
			string at: i put: (Character value: (fontData byteAt: index + 1)).
			index := index + 2].
		^string]! !


!TTFontTableDirEntry methodsFor: 'initialize-release'!
on: fd at: index

	fontData := fd.
	tag := fontData longAt: index bigEndian: true.
	checkSum := fontData longAt: index+4 bigEndian: true.
	offset := (fontData longAt: index+8 bigEndian: true) + 1.
	length := fontData longAt: index+12 bigEndian: true.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTFontTableDirEntry class
	instanceVariableNames: ''!

!TTFontTableDirEntry class methodsFor: 'instance creation'!
on: fontData at: index

	^self new on: fontData at: index! !
Object subclass: #TTGlyph
	instanceVariableNames: 'bounds contours advanceWidth leftSideBearing rightSideBearing glyphIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'TrueType-Fonts'!
!TTGlyph commentStamp: '<historical>' prior: 0!
This class represents a glyph of a TrueType font.

Instance variables:
	bounds			<Rectangle>	The receiver's bounds
	contours		<Array of: PointArray> The compressed contours in the receiver
	advanceWidth	<Integer>	advance width of the glyph
	leftSideBearing	<Integer>	left side bearing
	rightSideBearing <Integer>	right side bearing
	glyphIndex 		<Integer>	the original index of the glyph (used for kerning)!


!TTGlyph methodsFor: 'accessing'!
advanceWidth
	^advanceWidth! !

!TTGlyph methodsFor: 'accessing'!
advanceWidth: aNumber
	advanceWidth := aNumber.! !

!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:25'!
bounds
	^bounds! !

!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:25'!
bounds: aRectangle
	bounds := aRectangle! !

!TTGlyph methodsFor: 'accessing'!
contours
	^contours! !

!TTGlyph methodsFor: 'accessing'!
contours: aCollection
	contours := aCollection asArray.! !

!TTGlyph methodsFor: 'accessing'!
glyphIndex
	^glyphIndex! !

!TTGlyph methodsFor: 'accessing'!
glyphIndex: anInteger
	glyphIndex := anInteger! !

!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:26'!
glyphsAndTransformationsDo: aBlock
	aBlock value: self value: MatrixTransform2x3 identity! !

!TTGlyph methodsFor: 'accessing'!
leftSideBearing
	^leftSideBearing! !

!TTGlyph methodsFor: 'accessing'!
leftSideBearing: aNumber
	leftSideBearing := aNumber.! !

!TTGlyph methodsFor: 'accessing'!
rightSideBearing
	^rightSideBearing! !

!TTGlyph methodsFor: 'accessing'!
rightSideBearing: aNumber
	rightSideBearing := aNumber.! !


!TTGlyph methodsFor: 'converting' stamp: 'yo 6/23/2003 18:29'!
asFormWithScale: scale ascender: ascender descender: descender
	^ self
		asFormWithScale: scale
		ascender: ascender
		descender: descender
		fgColor: Color black
		bgColor: Color white
		depth: 8
		replaceColor: true.
! !

!TTGlyph methodsFor: 'converting' stamp: 'yo 6/23/2003 18:27'!
asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth

	^ self
		asFormWithScale: scale
		ascender: ascender
		descender: descender
		fgColor: fgColor
		bgColor: bgColor
		depth: depth
		replaceColor: false.
! !

!TTGlyph methodsFor: 'converting' stamp: 'yo 5/7/2004 10:37'!
asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth replaceColor: replaceColorFlag

	^ self
		asFormWithScale: scale
		ascender: ascender
		descender: descender
		fgColor: fgColor
		bgColor: bgColor
		depth: depth
		replaceColor: replaceColorFlag
		lineGlyph: nil
		lingGlyphWidth: 0
		emphasis: 0.! !

!TTGlyph methodsFor: 'converting' stamp: 'yo 5/7/2004 11:22'!
asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth replaceColor: replaceColorFlag lineGlyph: lineGlyph lingGlyphWidth: lWidth emphasis: code

	| form canvas newScale |
	form := Form extent: (advanceWidth @ (ascender - descender) * scale) rounded depth: depth.
	form fillColor: bgColor.
	canvas := BalloonCanvas on: form.
	canvas aaLevel: 4.
	canvas transformBy: (MatrixTransform2x3 withScale: scale asPoint * (1 @ -1)).
	canvas transformBy: (MatrixTransform2x3 withOffset: 0 @ ascender negated).
	canvas
		drawGeneralBezierShape: self contours
		color: fgColor 
		borderWidth: 0 
		borderColor: fgColor.
	((code bitAnd: 4) ~= 0 or: [(code bitAnd: 16) ~= 0]) ifTrue: [
		newScale := (form width + 1) asFloat / lineGlyph calculateWidth asFloat.
		canvas transformBy: (MatrixTransform2x3 withScale: (newScale / scale)@1.0).

		(code bitAnd: 4) ~= 0 ifTrue: [
			canvas
				drawGeneralBezierShape: lineGlyph contours
				color: fgColor 
				borderWidth: 0 
				borderColor: fgColor.
		].

		(code bitAnd: 16) ~= 0 ifTrue: [
			canvas transformBy: (MatrixTransform2x3 withOffset: 0@(ascender // 2)).
			canvas
				drawGeneralBezierShape: lineGlyph contours
				color: fgColor 
				borderWidth: 0 
				borderColor: fgColor.
		].
	].

	replaceColorFlag ifTrue: [
		form replaceColor: bgColor withColor: Color transparent.
	].
	^ form! !


!TTGlyph methodsFor: 'initialize-release' stamp: 'ar 11/1/1998 22:25'!
initialize

	bounds := 0@0 corner: 0@0.
	contours := #().
	advanceWidth := 0.
	leftSideBearing := 0.
	rightSideBearing := 0.! !


!TTGlyph methodsFor: 'printing' stamp: 'tk 9/13/1999 09:54'!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPut:$(;
		print: (contours ifNil: [0] ifNotNil: [contours size]);
		nextPut:$).! !


!TTGlyph methodsFor: 'testing'!
isComposite
	^false! !


!TTGlyph methodsFor: 'private' stamp: 'yo 5/7/2004 10:38'!
calculateWidth

	| min max |
	min := SmallInteger maxVal.
	max := SmallInteger minVal.
	self contours do: [:a | a do: [:p |
		p x > max ifTrue: [max := p x].
		p x < min ifTrue: [min := p x].
	]].
	^ max - min.
! !

!TTGlyph methodsFor: 'private' stamp: 'ar 5/25/2000 18:01'!
display
	| canvas |
	canvas := Display getCanvas.
	self contours do:[:ptArray|
		1 to: ptArray size by: 3 do:[:i|
			canvas line: (ptArray at: i) // 10
					to: (ptArray at: i+2) // 10
					width: 1 color: Color black.
		].
	].! !

!TTGlyph methodsFor: 'private' stamp: 'ar 11/14/1998 20:22'!
flipAroundY
	bounds := (bounds origin x @ bounds corner y negated) corner:
				(bounds corner x @ bounds origin y negated).
	contours := self contours collect:[:contour| contour collect:[:pt| pt x @ pt y negated]].! !


!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:18'!
buildContours
	"Build the contours in the receiver glyph.
	The contour is constructed by converting the points
	form each contour into an absolute value and then
	compressing the contours into PointArrays."
	| tx ty points |
	tx := ty := 0.
	contours := contours collect:[:contour|
		points := contour points.
		points do:[:pt|
			pt x: (tx := tx + pt x).
			pt y: (ty := ty + pt y)].
		contour asCompressedPoints].! !

!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:42'!
initializeContours: numContours with: endPoints
	"Initialize the contours for creation of the glyph."
	| startPt pts endPt |
	contours := Array new: numContours.
	startPt := -1.
	1 to: numContours do:[:i|
		endPt := endPoints at: i.
		pts := Array new: endPt - startPt.
		1 to: pts size do:[:j| pts at: j put: TTPoint new].
		contours at: i put: (TTContourConstruction on: pts).
		startPt := endPt].! !

!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:27'!
updateRightSideBearing
	"Update the right side bearing value"
	"@@: Is the following really correct?!!?!!"
	rightSideBearing := advanceWidth - leftSideBearing - bounds corner x + bounds origin x! !
Object subclass: #TTKernPair
	instanceVariableNames: 'left right value mask'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'TrueType-Fonts'!
!TTKernPair commentStamp: '<historical>' prior: 0!
A TTKernPair represents a TrueType kerning pair.

Instance variables:
	left	<Integer>	The glyph index for the left character.
	right <Integer>	The glyph index for the right character.
	value <Integer>	The amount of kerning.
	mask <Integer>	An efficient representation for the left and the right value.!


!TTKernPair methodsFor: 'accessing'!
left
	^left! !

!TTKernPair methodsFor: 'accessing'!
left: aNumber

	left := aNumber! !

!TTKernPair methodsFor: 'accessing' stamp: 'ar 11/1/1998 20:08'!
mask
	^mask ifNil:[mask := self class maskFor: left with: right]! !

!TTKernPair methodsFor: 'accessing'!
right
	^right! !

!TTKernPair methodsFor: 'accessing'!
right: aNumber

	right := aNumber! !

!TTKernPair methodsFor: 'accessing'!
value
	^value! !

!TTKernPair methodsFor: 'accessing'!
value: aNumber

	value := aNumber! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTKernPair class
	instanceVariableNames: ''!

!TTKernPair class methodsFor: 'accessing'!
maskFor: left with: right
	^(left bitShift: 12) + right! !
Object subclass: #TTPoint
	instanceVariableNames: 'x y type'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'TrueType-Support'!
!TTPoint commentStamp: '<historical>' prior: 0!
A representation of a TrueType point which includes a 'type' flag defining whether this point is an 'on' or an 'off' curve point.!


!TTPoint methodsFor: 'accessing'!
type
	^type! !

!TTPoint methodsFor: 'accessing'!
type: aSymbol

	type := aSymbol! !

!TTPoint methodsFor: 'accessing'!
x
	^x! !

!TTPoint methodsFor: 'accessing'!
x: aNumber

	x := aNumber! !

!TTPoint methodsFor: 'accessing'!
y
	^y! !

!TTPoint methodsFor: 'accessing'!
y: aNumber
	y := aNumber! !


!TTPoint methodsFor: 'converting'!
asPoint
	^x@y! !


!TTPoint methodsFor: 'printing'!
printOn: aStream

	aStream 
		nextPutAll: self class name;
		nextPut:$(;
		print: x;
		nextPut:$@;
		print: y;
		nextPut:$|;
		print: type;
		nextPut:$)! !
BorderedMorph subclass: #TTSampleFontMorph
	instanceVariableNames: 'font transform smoothing'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-TrueType'!
!TTSampleFontMorph commentStamp: '<historical>' prior: 0!
An example for using TrueType fonts.!


!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 22:52'!
doesBevels
	^false! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 18:08'!
font
	^ font! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 00:31'!
font: aTTFontDescription
	| morph |
	font _ aTTFontDescription.
	morph _ (TTSampleStringMorph font: font).
	morph extent: morph extent * 2.
	morph color: Color magenta.
	self addMorphCentered: morph.
	morph position: morph position x @ (self bounds bottom + 10).
	self privateFullMoveBy: self fullBounds origin negated.! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 17:53'!
smoothing
	^ smoothing! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'bf 10/18/1999 16:19'!
smoothing: aNumber
	smoothing _ aNumber.
	self changed! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 22:53'!
transform
	^transform ifNil:[self computeTransform].! !


!TTSampleFontMorph methodsFor: 'copying' stamp: 'sma 2/26/2000 19:20'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here. If they were in the 
	tree being copied, fix them up, otherwise point to the originals!!!!"

	super veryDeepFixupWith: deepCopier.
	font _ deepCopier references at: font ifAbsent: [font]! !

!TTSampleFontMorph methodsFor: 'copying' stamp: 'sma 2/26/2000 19:18'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all,
	but shared. Warning!!!! Every instance variable defined in this class
	must be handled.  We must also implement veryDeepFixupWith:.
	See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	"font _ font"
	transform _ transform veryDeepCopyWith: deepCopier.
	smoothing _ smoothing veryDeepCopyWith: deepCopier! !


!TTSampleFontMorph methodsFor: 'drawing' stamp: 'ar 11/14/1998 23:12'!
areasRemainingToFill: aRectangle
	^ Array with: aRectangle! !

!TTSampleFontMorph methodsFor: 'drawing' stamp: 'sma 1/1/2000 17:56'!
drawCharactersOn: aCanvas
	| glyph origin r offset cy m |
	0 to: 255 do:[:i|
		glyph _ font at: i.
		origin _ font bounds extent * ((i \\ 16) @ (i // 16)).
		r _ origin extent: font bounds extent.
		offset _ r center - glyph bounds center.
		cy _ glyph bounds center y.
		m _ MatrixTransform2x3 withOffset: 0@cy.
		m _ m composedWithLocal: (MatrixTransform2x3 withScale: 1@-1).
		m _ m composedWithLocal: (MatrixTransform2x3 withOffset: 0@cy negated).
		m _ m composedWithGlobal: (MatrixTransform2x3 withOffset: offset).
		aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
			balloonCanvas transformBy: m.
			balloonCanvas drawGeneralBezierShape: glyph contours
					color: color
					borderWidth: 0
					borderColor: Color black.
		].
	].! !

!TTSampleFontMorph methodsFor: 'drawing' stamp: 'ar 12/30/1998 10:49'!
drawOn: aCanvas
	| origin extent offset |
	(font isNil) 
		ifTrue:[^aCanvas frameRectangle: bounds color: Color black].
	origin _ self position asIntegerPoint.
	extent _ self extent asIntegerPoint.
	0 to: 16 do:[:i|
		offset _ (extent x * i // 16) @ (extent y * i // 16).
		aCanvas line: origin x @ (origin y + offset y) 
				to: (origin x + extent x) @ (origin y + offset y)
				width: borderWidth color: borderColor.
		aCanvas line: (origin x + offset x) @ origin y 
				to: (origin x + offset x) @ (origin y + extent y)
				width: borderWidth color: borderColor.
	].
	aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
		balloonCanvas transformBy: self transform.
		balloonCanvas aaLevel: self smoothing.
		self drawCharactersOn: balloonCanvas.
	].! !


!TTSampleFontMorph methodsFor: 'geometry' stamp: 'ar 11/14/1998 22:53'!
extent: extentPoint
	super extent: extentPoint.
	transform _ nil.! !

!TTSampleFontMorph methodsFor: 'geometry' stamp: 'ar 11/14/1998 22:53'!
position: pos
	super position: pos.
	transform _ nil.! !


!TTSampleFontMorph methodsFor: 'halos and balloon help' stamp: 'sw 1/27/2000 15:43'!
addOptionalHandlesTo: aHalo box: box
	aHalo addHandleAt: box center color: Color magenta icon: nil on: #mouseDown send: #createSample to: self.! !

!TTSampleFontMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/14/1998 23:39'!
balloonHelpTextForHandle: aHandle
	aHandle eventHandler firstMouseSelector == #createSample
		ifTrue:[^'Create a sample string'].
	^super balloonHelpTextForHandle: aHandle! !


!TTSampleFontMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!TTSampleFontMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color black! !

!TTSampleFontMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:43'!
initialize
	"initialize the state of the receiver"
	super initialize.
	smoothing _ 4.
	self extent: 300 @ 300! !

!TTSampleFontMorph methodsFor: 'initialization' stamp: 'sma 4/30/2000 10:51'!
openInWorld
	Smalltalk isMorphic ifFalse: [^ self openInMVC].
	HandMorph attach: self! !


!TTSampleFontMorph methodsFor: 'initialize' stamp: 'ar 11/14/1998 23:50'!
open
	Smalltalk isMorphic 
		ifTrue:[self openInWorld]
		ifFalse:[self openInMVC]! !


!TTSampleFontMorph methodsFor: 'menu' stamp: 'ar 11/14/1998 23:46'!
createSample
	self world primaryHand attachMorph: (TTSampleStringMorph font: font)! !

!TTSampleFontMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:42'!
getSmoothingLevel
	"Menu support"
	smoothing = 1
		ifTrue: [^ 'turn on smoothing' translated].
	smoothing = 2
		ifTrue: [^ 'more smoothing' translated].
	smoothing = 4
		ifTrue: [^ 'turn off smoothing' translated]! !

!TTSampleFontMorph methodsFor: 'menu' stamp: 'sma 1/1/2000 17:51'!
nextSmoothingLevel
	smoothing = 1
		ifTrue: [smoothing _ 2]
		ifFalse: [smoothing = 2
			ifTrue: [smoothing _ 4]
			ifFalse: [smoothing = 4
				ifTrue: [smoothing _ 1]]].
	self changed! !


!TTSampleFontMorph methodsFor: 'menus' stamp: 'ar 6/16/1999 07:21'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addUpdating: #getSmoothingLevel action: #nextSmoothingLevel.! !


!TTSampleFontMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 22:42'!
newTransformationMorph
	^MatrixTransformMorph new! !


!TTSampleFontMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:09'!
canDrawBorder: aBorderStyle
	^aBorderStyle style == #simple! !


!TTSampleFontMorph methodsFor: 'updating' stamp: 'sma 1/1/2000 17:59'!
changed
	self invalidRect: (self fullBounds expandBy: 1)! !


!TTSampleFontMorph methodsFor: 'private' stamp: 'ar 11/15/1998 22:48'!
computeTransform
	| fullExtent scale |
	fullExtent _ font bounds extent * 16.
	scale _ self extent asFloatPoint / fullExtent asFloatPoint.
	transform _ MatrixTransform2x3 withScale: scale.
	transform _ transform composedWithGlobal: (MatrixTransform2x3 withOffset: self position).
	^transform! !

!TTSampleFontMorph methodsFor: 'private' stamp: 'ar 11/14/1998 22:55'!
privateMoveBy: delta
	super privateMoveBy: delta.
	transform _ nil.! !


!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:34'!
fontWithoutString: aTTFontDescription
	font _ aTTFontDescription.
! !

!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:43'!
glyphAt: position
	^font at: (self glyphIndexAt: position).! !

!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:54'!
glyphIndexAt: position
	| offset |
	offset _ (position adhereTo: (bounds insetBy: 1)) - bounds origin.
	offset _ (offset asFloatPoint / bounds extent) * 16.
	offset _ offset truncated.
	^offset y * 16 + offset x! !

!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 7/15/2003 15:12'!
printOn: aStream
	aStream nextPutAll: 'TTSampleFont(';
		nextPutAll: font familyName;
		nextPut: $)! !

!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 12:12'!
selectGlyph
	| retval done |
	"Modal glyph selector"
	done _ false.
	self on: #mouseDown send: #selectGlyphBlock:event:from: to: self withValue: [ :glyph | retval _ glyph. done _ true. ].
	self on: #keyStroke send: #value to: [ done _ true ].
	[ done ] whileFalse: [ self world doOneCycle ].
	self on: #mouseDown send: nil to: nil.
	self on: #keyStroke send: nil to: nil.
	^retval! !

!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:58'!
selectGlyphAndSendTo: aBlock
	self on: #mouseDown send: #selectGlyphBlock:event:from: to: self withValue: aBlock.! !

!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 12:17'!
selectGlyphBlock: aBlock event: evt from: me
	aBlock value: (self glyphAt: evt position).
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTSampleFontMorph class
	instanceVariableNames: ''!

!TTSampleFontMorph class methodsFor: 'instance creation' stamp: 'ar 11/14/1998 23:06'!
font: aTTFontDescription
	^self new font: aTTFontDescription! !


!TTSampleFontMorph class methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:34'!
fontWithoutString: aTTFontDescription
	^self new fontWithoutString: aTTFontDescription! !
TTSampleFontMorph subclass: #TTSampleStringMorph
	instanceVariableNames: 'string ttBounds'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-TrueType'!
!TTSampleStringMorph commentStamp: '<historical>' prior: 0!
I allow the display of a string in a TrueType font as a stand-alone morph.

Morph's color changes the inside of the characters.
Morph's borderColor changes the outline.

Many free fonts are stored at www.FontGuy.com.  
Use a normal web browser (not our Scamper) and go there.  
Choose 'categories' and browse to a font you like.  
Hold the mouse down on the example text in that font.  
When the menu comes up, choose "Copy this link location".  
Come back into Squeak, choose "load font from web..."
from my menu, and paste in the url.!


!TTSampleStringMorph methodsFor: 'accessing' stamp: 'tk 12/10/2001 16:21'!
font: aTTFontDescription
	font _ aTTFontDescription.
	string ifNil: [self string: aTTFontDescription fullName]
		ifNotNil: [self initializeString].! !

!TTSampleStringMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 18:08'!
string
	^ string! !

!TTSampleStringMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:53'!
string: aString
	string _ aString.
	self initializeString.! !


!TTSampleStringMorph methodsFor: 'drawing' stamp: 'ar 12/30/1998 10:51'!
drawOn: aCanvas
	| xStart glyph |
	(font isNil or:[string isNil or:[string isEmpty]]) 
		ifTrue:[^aCanvas frameRectangle: bounds color: Color black].
	xStart _ 0.
	aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
		balloonCanvas transformBy: self transform.
		balloonCanvas aaLevel: self smoothing.
		string do:[:char|
			glyph _ font at: char.
			balloonCanvas preserveStateDuring:[:subCanvas|
				subCanvas transformBy: (MatrixTransform2x3 withOffset: xStart@0).
				subCanvas 
					drawGeneralBezierShape: glyph contours
					color: color 
					borderWidth: borderWidth 
					borderColor: borderColor].
			xStart _ xStart + glyph advanceWidth.
		].
	].! !


!TTSampleStringMorph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 14:42'!
containsPoint: aPoint 
	"^ super containsPoint: aPoint"

	"so much faster..."

	| picker |
	(self bounds containsPoint: aPoint) ifFalse: [^false].
	picker := BalloonCanvas on: (Form extent: 1 @ 1 depth: 32).
	picker transformBy: (MatrixTransform2x3 withOffset: aPoint negated).
	self drawOn: picker.
	^(picker form bits first) ~= 0! !


!TTSampleStringMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/14/1998 23:44'!
addOptionalHandlesTo: aHalo box: box! !


!TTSampleStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 0! !

!TTSampleStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ {Color magenta. Color yellow. Color orange. Color lightGray} atRandom! !


!TTSampleStringMorph methodsFor: 'initialize' stamp: 'sma 1/1/2000 18:08'!
initializeString
	| xStart char glyph |
	(font isNil or: [string isNil]) ifTrue: [^ self].
	xStart _ 0.
	ttBounds _ 0@0 corner: 0@0.
	1 to: string size do:
		[:i |
		char _ string at: i.
		glyph _ font at: char.
		ttBounds _ ttBounds quickMerge: (glyph bounds translateBy: xStart@0).
		xStart _ xStart + glyph advanceWidth.
	].
	self extent: ttBounds extent // 40.
	borderWidth _ ttBounds height // 40! !


!TTSampleStringMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 22:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'edit contents...' translated action: #edit.
	aCustomMenu add: 'how to find more fonts...' translated action: #howTo.
	aCustomMenu add: 'load font from web...' translated action: #loadFromURL.! !

!TTSampleStringMorph methodsFor: 'menus' stamp: 'tk 12/7/2001 11:24'!
edit
	"Allow the user to change the text in a crude way"

	| str |
	str _ FillInTheBlankMorph request: 'Type in new text for this TrueType displayer.'
				 initialAnswer: 'some text'.
	str isEmpty ifTrue: [^ self].
	self string: str.
! !

!TTSampleStringMorph methodsFor: 'menus' stamp: 'tk 12/10/2001 16:02'!
howTo

	self inform: 'Many free fonts are stored at www.FontGuy.com.  
Use a normal web browser (not our Scamper) and go there.  
Choose ''categories'' and browse to a font you like.  
Hold the mouse down on the example text in that font.  
When the menu comes up, choose "Copy this link location".  
Come back into Squeak, choose "load font from web..."
from this menu, and paste in the url.'! !

!TTSampleStringMorph methodsFor: 'menus' stamp: 'tk 12/10/2001 16:03'!
loadFromURL
	"Allow the user to change the text in a crude way"

	| url |
	url _ FillInTheBlankMorph request: ' Type in the url for a TrueType font on the web. '
				 initialAnswer: 'http://www.fontguy.com/download.asp?fontid=1494'.
	url isEmpty ifTrue: [^ self].
	self loadFromURL: url.
! !

!TTSampleStringMorph methodsFor: 'menus' stamp: 'tk 12/10/2001 16:03'!
loadFromURL: urlString
	"Fetch the file, unarchive, unzip, and use as my font."

	| rawStrm |
	rawStrm _ HTTPSocket httpGet: urlString. 	"Later use an HttpURL?"
	self font: (TTFontReader readFrom: rawStrm asUnZippedStream).
! !


!TTSampleStringMorph methodsFor: 'parts bin' stamp: 'tk 12/10/2001 17:36'!
initializeToStandAlone
	"Make me into an example"

	| dd |
	dd _ TTFontDescription default.
	dd ifNil: [^ RectangleMorph initializeToStandAlone].	"not available"

	super initializeToStandAlone.
	self font: dd; color: (TranslucentColor r: 1.0 g: 0.097 b: 1.0 alpha: 0.6).
	self string: 'TrueType fonts are beautiful'.
! !


!TTSampleStringMorph methodsFor: 'private' stamp: 'ar 11/14/1998 22:04'!
computeTransform
	| cy |
	cy _ bounds origin y + bounds corner y * 0.5.
	transform _ MatrixTransform2x3 
			transformFromLocal: (ttBounds insetBy: borderWidth negated)
			toGlobal: bounds.
	transform _ transform composedWithGlobal:(MatrixTransform2x3 withOffset: 0@cy negated).
	transform _ transform composedWithGlobal:(MatrixTransform2x3 withScale: 1.0@-1.0).
	transform _ transform composedWithGlobal:(MatrixTransform2x3 withOffset: 0@cy).
	^transform! !


!TTSampleStringMorph methodsFor: 'printing' stamp: 'nk 7/15/2003 15:12'!
printOn: aStream
	aStream nextPutAll: 'TTSampleString(';
		nextPutAll: font familyName;
		nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTSampleStringMorph class
	instanceVariableNames: ''!

!TTSampleStringMorph class methodsFor: 'parts bin' stamp: 'nk 9/2/2004 15:42'!
descriptionForPartsBin
	^ self partName:	'TrueType banner'
		categories:		#('Demo')
		documentation:	'A short text in a beautiful font.  Use the resize handle to change size.'! !
Trait named: #TTestingDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TTestingDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 5/9/2004 20:50'!
isClassSide
	^self == self classSide! !

!TTestingDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 5/9/2004 20:50'!
isInstanceSide
	^self isClassSide not! !

!TTestingDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 5/9/2004 20:55'!
isMeta
	^self isClassSide! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTestingDescription classTrait
	uses: {}!
Trait named: #TTraitsCategorisingDescription
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TTraitsCategorisingDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:08'!
applyChangesOfNewTraitCompositionReplacing: oldComposition
	| changedSelectors |
	changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition.
	self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition.
	^ changedSelectors.! !

!TTraitsCategorisingDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:01'!
noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition
	| oldCategory newCategory |
	aCollection do: [:each | 
		oldCategory _ self organization categoryOfElement: each.
		newCategory _ (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory.
		self noteRecategorizedSelector: each from: oldCategory to: newCategory]! !

!TTraitsCategorisingDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:00'!
noteRecategorizedSelector: aSymbol from: oldCategoryOrNil to: newCategoryOrNil
	| changedCategories |
	changedCategories _ self updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil.
	changedCategories do: [:each |
		(self organization isEmptyCategoryNamed: each) ifTrue: [self organization removeCategory: each]]! !

!TTraitsCategorisingDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:02'!
notifyOfRecategorizedSelector: element from: oldCategory to: newCategory
	SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self! !

!TTraitsCategorisingDescription methodsFor: 'organization updating' stamp: 'al 3/27/2006 10:21'!
updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil
	| currentCategory effectiveCategory sel changedCategories composition |
	changedCategories _ IdentitySet new.
	composition := self hasTraitComposition
		ifTrue: [self traitComposition]
		ifFalse: [TraitComposition new].
	(composition methodDescriptionsForSelector: aSymbol) do: [:each |
		sel _ each selector.
		(self includesLocalSelector: sel) ifFalse: [
			currentCategory _ self organization categoryOfElement: sel.
			effectiveCategory _ each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil.
			effectiveCategory isNil ifTrue: [
				currentCategory ifNotNil: [changedCategories add: currentCategory].
				self organization removeElement: sel.
			] ifFalse: [
				((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [
					currentCategory ifNotNil: [changedCategories add: currentCategory].
					self organization 
						classify: sel 
						under: effectiveCategory
						suppressIfDefault: false]]]].
	^ changedCategories! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTraitsCategorisingDescription classTrait
	uses: {}!
Trait named: #TTransformationCompatibility
	uses: {}
	category: 'Traits-Kernel-Traits'!
!TTransformationCompatibility commentStamp: 'apb 8/22/2005 15:24' prior: 0!
methods that make the user of this trait protocol-compatible with TraitTransformation.
When used in Trait and ClassTrait, this eliminates the need for TraitHolders.
!


!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:35'!
aliasesForSelector: aSelector 
	^ OrderedCollection new
! !

!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:36'!
allAliasesDict
	^IdentityDictionary new
! !

!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:36'!
changedSelectorsComparedTo: aTraitTransformation
	| selectors otherSelectors changedSelectors aliases otherAliases |
	selectors := self allSelectors asIdentitySet.
	otherSelectors := aTraitTransformation allSelectors asIdentitySet.
	changedSelectors := IdentitySet withAll: (
		(selectors difference: otherSelectors) union: (otherSelectors difference: selectors)).
	aliases := self allAliasesDict.
	otherAliases := aTraitTransformation allAliasesDict.
	aliases keysAndValuesDo: [:key :value |
		(value ~~ (otherAliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]].
	otherAliases keysAndValuesDo: [:key :value |
		(value ~~ (aliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]].
	^ changedSelectors.
! !

!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:36'!
collectMethodsFor: aSelector into: methodDescription
	(self includesSelector: aSelector) ifTrue: [ 
		methodDescription addLocatedMethod: (
			LocatedMethod
				location: self
				selector: aSelector)]
! !

!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'dvf 9/22/2005 18:15'!
subject
	"for compatibility with TraitTransformations"
	^ self
! !

!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:36'!
trait
	"for compatibility with TraitTransformations"
	^ self
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTransformationCompatibility classTrait
	uses: {}!
Trait named: #TUpdateTraitsBehavior
	uses: {}
	category: 'Traits-Kernel-Traits'!

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'al 8/16/2004 15:36'!
addTraitSelector: aSymbol withMethod: aCompiledMethod
	"Add aMethod with selector aSymbol to my
	methodDict. aMethod must not be defined locally.
	Note that I am overridden by ClassDescription
	to do a recompilation of the method if it has supersends."

	self assert: [(self includesLocalSelector: aSymbol) not].
	self ensureLocalSelectors.
	self basicAddSelector: aSymbol withMethod: aCompiledMethod.! !

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:39'!
applyChangesOfNewTraitCompositionReplacing: oldComposition
	| changedSelectors |
	changedSelectors _ self traitComposition
		changedSelectorsComparedTo: oldComposition.
	changedSelectors isEmpty ifFalse: [
		self noteChangedSelectors: changedSelectors].
	self traitComposition isEmpty ifTrue: [
		self purgeLocalSelectors].
	^changedSelectors! !

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'al 8/6/2004 13:09'!
noteChangedSelectors: aCollection
	"Start update of my methodDict (after changes to traits in traitComposition
	or after a local method was removed from my methodDict). The argument 
	is a collection of method selectors that may have been changed. Most of the time
	aCollection only holds one selector. But when there are aliases involved 
	there may be several method changes that have to be propagated to users."

	| affectedSelectors |
	affectedSelectors _ IdentitySet new.
	aCollection do: [:selector |
		affectedSelectors addAll: (self updateMethodDictionarySelector: selector)].
	self notifyUsersOfChangedSelectors: affectedSelectors.
	^ affectedSelectors! !

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:40'!
notifyUsersOfChangedSelectors: aCollection! !

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:40'!
notifyUsersOfChangedSelector: aSelector
	self notifyUsersOfChangedSelectors: (Array with: aSelector)! !

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:46'!
removeTraitSelector: aSymbol
	self assert: [(self includesLocalSelector: aSymbol) not].
	self basicRemoveSelector: aSymbol! !

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'apb 8/22/2005 18:28'!
setTraitCompositionFrom: aTraitExpression
	^ self setTraitComposition: aTraitExpression asTraitComposition! !

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:48'!
setTraitComposition: aTraitComposition
	| oldComposition |
	(self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self].
	aTraitComposition assertValidUser: self.

	oldComposition _ self traitComposition.
	self traitComposition: aTraitComposition.
	self applyChangesOfNewTraitCompositionReplacing: oldComposition.
	
	oldComposition traits do: [:each | each removeUser: self].
	aTraitComposition traits do: [:each | each addUser: self]! !

!TUpdateTraitsBehavior methodsFor: 'traits' stamp: 'al 3/26/2006 21:36'!
updateMethodDictionarySelector: aSymbol
	"A method with selector aSymbol in myself or my traitComposition has been changed.
	Do the appropriate update to my methodDict (remove or update method) and
	return all affected selectors of me so that my useres get notified."

	| effectiveMethod modifiedSelectors descriptions selector |
	modifiedSelectors _ IdentitySet new.
	descriptions _ self hasTraitComposition
		ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ]
		ifFalse: [ #() ].
	descriptions do: [:methodDescription |
		selector _ methodDescription selector.
		(self includesLocalSelector: selector) ifFalse: [
			methodDescription isEmpty
				ifTrue: [
					self removeTraitSelector: selector.
					modifiedSelectors add: selector]
				ifFalse: [
					effectiveMethod _ methodDescription effectiveMethod.
					(self compiledMethodAt: selector ifAbsent: [nil]) ~~ effectiveMethod ifTrue: [
						self addTraitSelector: selector withMethod: effectiveMethod.
						modifiedSelectors add: selector]]]].
	^modifiedSelectors! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TUpdateTraitsBehavior classTrait
	uses: {}!
StringButtonMorph subclass: #TabMorph
	instanceVariableNames: 'morphToInstall'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Palettes'!
!TabMorph commentStamp: '<historical>' prior: 0!
A tab in a palette.  The contents is the name to be shown.  If it represents a book, that book is pointed to in my morphToInstall.!


!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/2/1999 15:55'!
convertToReferenceMorph
	| aMorph |
	aMorph _ ReferenceMorph new referent: morphToInstall.
	aMorph position: self position.
	self become: aMorph.! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/9/1999 20:49'!
isHighlighted
	^ false! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/2/1998 15:28'!
morphToInstall
	^ morphToInstall! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/2/1998 15:38'!
morphToInstall: m
	morphToInstall _ m.
	self contents: m externalName.
	self actionSelector: #tabSelected.
	self target: self! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'!
tabSelected
	"Called when the receiver is hit.  First, bulletproof against someone having taken the structure apart.  My own action basically requires that my grand-owner be a TabbedPalette"
	self player ifNotNil: [self player runAllOpeningScripts ifTrue: [^ self]].
	(owner isKindOf: IndexTabs) ifFalse: [^ Beeper beep].
	(owner owner isKindOf: TabbedPalette) ifFalse: [^ Beeper beep].
	owner owner selectTab: self! !


!TabMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 10:39'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
morphToInstall _ deepCopier references at: morphToInstall ifAbsent: [morphToInstall].! !

!TabMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 10:39'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
morphToInstall _ morphToInstall.		"Weakly copied"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TabMorph class
	instanceVariableNames: ''!

!TabMorph class methodsFor: 'printing' stamp: 'sw 7/2/1998 16:48'!
defaultNameStemForInstances
	^ 'tab'! !
BookPageSorterMorph subclass: #TabSorterMorph
	instanceVariableNames: 'originalTabs'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Palettes'!
!TabSorterMorph commentStamp: '<historical>' prior: 0!
A sorter for the tabs of a TabbedPalette!


!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 22:56'!
acceptSort
	"Reconstitute the palette based on what is found in the sorter"

	| rejects toAdd oldOwner tabsToUse appearanceMorph oldTop aMenu |
	tabsToUse := OrderedCollection new.
	rejects := OrderedCollection new.
	pageHolder submorphs doWithIndex: 
			[:m :i | 
			toAdd := nil.
			(m isKindOf: BookMorph) ifTrue: [toAdd := SorterTokenMorph forMorph: m].
			(m isKindOf: SorterTokenMorph) 
				ifTrue: 
					[toAdd := m morphRepresented.
					(toAdd referent isKindOf: MenuMorph) 
						ifTrue: 
							[(aMenu := toAdd referent) setProperty: #paletteMenu toValue: true.
							(aMenu submorphs size > 1 and: 
									[(aMenu submorphs second isKindOf: MenuItemMorph) 
										and: [aMenu submorphs second contents = 'dismiss this menu']]) 
								ifTrue: 
									[aMenu submorphs first delete.	"delete title"
									aMenu submorphs first delete.	"delete stay-up item"
									(aMenu submorphs first isKindOf: MenuLineMorph) 
										ifTrue: [aMenu submorphs first delete]]].
					toAdd removeAllMorphs.
					toAdd addMorph: (appearanceMorph := m submorphs first).
					appearanceMorph position: toAdd position.
					appearanceMorph lock.
					toAdd fitContents].
			toAdd ifNil: [rejects add: m] ifNotNil: [tabsToUse add: toAdd]].
	tabsToUse isEmpty 
		ifTrue: [^self inform: 'Sorry, must have at least one tab'].
	book newTabs: tabsToUse.
	book tabsMorph color: pageHolder color.
	oldTop := self topRendererOrSelf.	"in case some maniac has flexed the sorter"
	oldOwner := oldTop owner.
	oldTop delete.
	oldOwner addMorphFront: book! !

!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2001 18:28'!
addControls

	| b r |
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r wrapCentering: #topLeft.
	r addMorphBack: (b label: 'Okay';	actionSelector: #acceptSort).
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (b label: 'Cancel';	actionSelector: #cancelSort).
	self addMorphFront: r.
! !

!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/3/1998 16:06'!
cancelSort
	| oldOwner |
	oldOwner _ owner.
	self delete.
	oldOwner addMorphFront: book! !

!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/2/1999 16:47'!
sortTabsFor: aTabbedPalette
	| actualTabs |
	actualTabs _ aTabbedPalette tabMorphs.
	self book: aTabbedPalette morphsToSort:
		(actualTabs collect: [:aTab | aTab sorterToken]).
	pageHolder color: aTabbedPalette tabsMorph color.
 
	self position: aTabbedPalette position.
	pageHolder extent: self extent.
	self setNameTo: 'Tab Sorter for ', aTabbedPalette externalName.
	aTabbedPalette owner addMorphFront: self! !


!TabSorterMorph methodsFor: 'initialization' stamp: 'tk 10/30/2001 18:41'!
initialize
	super initialize.
	self removeAllMorphs.

	self extent: 300@100.
	pageHolder _ PasteUpMorph new.
	pageHolder vResizeToFit: true; autoLineLayout: true.
	pageHolder extent: self extent - borderWidth.
	pageHolder padding: 8.
	pageHolder cursor: 0.
	self addControls.
	self addMorphBack: pageHolder! !
BookMorph subclass: #TabbedPalette
	instanceVariableNames: 'tabsMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Palettes'!
!TabbedPalette commentStamp: '<historical>' prior: 0!
A structure of tabs and associated books.  Pressing a tab brings into focus the associated book.  Some tabs can have simple actions rather than books as their focus -- in this case, the palette is cleared and the action taken. !


!TabbedPalette methodsFor: 'dropping/grabbing' stamp: 'dgd 2/21/2003 23:00'!
wantsDroppedMorph: aMorph event: evt 
	(tabsMorph bounds containsPoint: (self pointFromWorld: evt cursorPoint)) 
		ifTrue: [^false	"unless it's a book, perhaps, someday"].
	^currentPage isNil or: [currentPage wantsDroppedMorph: aMorph event: evt]! !


!TabbedPalette methodsFor: 'halos and balloon help' stamp: 'ar 9/14/2000 16:45'!
defersHaloOnClickTo: aSubMorph
	"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"

	^ currentPage notNil and:
		[(aSubMorph hasOwner: currentPage)
			and: [currentPage defersHaloOnClickTo: aSubMorph]]
	! !


!TabbedPalette methodsFor: 'initialization' stamp: 'sw 1/11/2000 11:16'!
addTabFor: aReferent font: aFont
	| aTab |
	aTab _ tabsMorph addTabFor: aReferent font: aFont.
	pages add: aReferent.
	currentPage ifNil: [currentPage _ aReferent].
	^ aTab! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 7/2/1998 17:52'!
addTabForBook: aBook
	| aTab |
	aTab _ tabsMorph addTabForBook: aBook.
	pages add: aBook.
	currentPage ifNil: [currentPage _ aBook].
	^ aTab! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 10/29/1998 17:35'!
addTabForBook: aBook withBalloonText: text
	| aTab |
	aTab _ tabsMorph addTabForBook: aBook.
	pages add: aBook.
	currentPage ifNil: [currentPage _ aBook].
	text ifNotNil: [aTab setBalloonText: text].
	^ aTab! !

!TabbedPalette methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color transparent! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 7/3/1998 18:05'!
defaultPageSize
	^ 156 @ 232! !

!TabbedPalette methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:08'!
initialize
	"Initialize the receiver, which was just created via a call to the  
	class's #basicNew"
	super initialize.
	""
	pageSize _ self defaultPageSize.
	self removeEverything.
	
	tabsMorph _ IndexTabs new.
	self addMorph: tabsMorph! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 12/7/1998 17:26'!
newTabs: tabsList
	"Reconstitute the palette based on info in the tabs list"

	| itsBook color1 color2 color3 |
	pages _ pages species new.
	tabsMorph ifNotNil:
		[color1 _ tabsMorph  highlightColor.
		color2 _ tabsMorph regularColor.
		color3 _ tabsMorph color.
		tabsMorph delete].
	tabsMorph _ IndexTabs new.
	self addMorphFront: tabsMorph.
	color1 ifNotNil:
		[tabsMorph highlightColor: color1 regularColor: color2; color: color3].
	currentPage ifNotNil:
		[currentPage delete.
		currentPage _ nil].
	tabsList do:
		[:aTab |
			tabsMorph addTab: aTab.
			aTab unHighlight.
			(itsBook _ aTab morphToInstall) ifNotNil:
					[pages add: itsBook.
					currentPage ifNil: [currentPage _ itsBook]]].
	tabsMorph position: self position + self borderWidth! !

!TabbedPalette methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:07'!
setInitialState
	super setInitialState.
""
	self layoutInset: 0.
	pageSize _ 156 @ 232! !


!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 6/16/1998 16:17'!
becomeStandardPalette
	self presenter standardPalette: self! !

!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 7/4/1998 14:12'!
recolorTabs
	"Prompt the user for new on and off colors for tabs"

	| onColor offColor |
	self inform: 'Choose the ''on'' color'.
	onColor _ Color fromUser.

	self inform: 
'Okay, now please choose
the ''off'' color'.
	offColor _ Color fromUser.

	tabsMorph highlightColor: onColor regularColor: offColor.
	currentPage ifNotNil:
		[tabsMorph highlightTabFor: currentPage]! !

!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 12/27/1998 23:34'!
showNoPalette
	self showNoPaletteAndHighlightTab: nil! !

!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 3/3/1999 13:06'!
showNoPaletteAndHighlightTab: aTab

	| oldTab morphToInstall aSketchEditor |
	oldTab _ tabsMorph highlightedTab.
	(oldTab notNil and: [(morphToInstall _ oldTab morphToInstall) isKindOf: PaintBoxMorph])
		ifTrue:
			[(aSketchEditor _ self world submorphOfClass: SketchEditorMorph) ifNotNil:
				[aSketchEditor cancelOutOfPainting].
			morphToInstall delete].

	currentPage ifNotNil: [currentPage delete].
	currentPage _ nil.
	submorphs size > 1 ifTrue: "spurious submorphs, yecch"
		[(submorphs copyFrom: 2 to: submorphs size) do: [:m | m delete]].
	tabsMorph highlightTab: aTab! !

!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 7/3/1998 18:17'!
sortTabs: evt
	TabSorterMorph new sortTabsFor: self.  "it directly replaces me"
	self delete
! !


!TabbedPalette methodsFor: 'miscellaneous' stamp: 'sw 6/23/1998 12:31'!
currentPalette
	"A stylistic convenience to reduce confusion caused by the fact that a palette is a book of books"
	^ currentPage! !

!TabbedPalette methodsFor: 'miscellaneous' stamp: 'jm 11/16/97 17:59'!
tabsMorph
	^ tabsMorph! !


!TabbedPalette methodsFor: 'navigation' stamp: 'sw 12/22/1998 16:37'!
transitionSpecFor: aMorph
	^ aMorph valueOfProperty: #transitionSpec  " check for special propety"
		ifAbsent: [Array with: 'silence'  " ... otherwise this is the default"
						with: #none
						with: #none]! !


!TabbedPalette methodsFor: 'other' stamp: 'sw 6/6/2003 17:38'!
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 setExtentFromHalo: ((anExtent x @ (anExtent y - (self innerBounds height - currentPage height))) - (2 * (self borderWidth @ self borderWidth))).
			self maintainsUniformPageSize ifTrue:
				[self setProperty: #uniformPageSize toValue: currentPage extent]]! !


!TabbedPalette methodsFor: 'palette menu' stamp: 'dgd 8/30/2003 21:14'!
addBookMenuItemsTo: aCustomMenu hand: aHandMorph 
	aCustomMenu add: 'add palette menu' translated action: #addMenuTab.
	aCustomMenu add: 'become the Standard palette' translated action: #becomeStandardPalette! !

!TabbedPalette methodsFor: 'palette menu' stamp: 'nk 6/12/2004 10:05'!
addMenuTab
	"Add the menu tab.  This is ancient code, not much in the spirit of anything current"

	| aMenu aTab aGraphic sk |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu stayUp: true.
	"aMenu add:  'clear' translated action: #showNoPalette."
	aMenu add:  'sort tabs' translated action: #sortTabs:.
	aMenu add:  'choose new colors for tabs' translated action: #recolorTabs.
	aMenu setProperty: #paletteMenu toValue: true.
	"aMenu add:  'make me the Standard palette' translated action: #becomeStandardPalette."
	aTab _ self addTabForBook: aMenu  withBalloonText: 'a menu of palette-related controls' translated.
	aTab highlightColor: tabsMorph highlightColor; regularColor: tabsMorph regularColor.
	tabsMorph laySubpartsOutInOneRow; layoutChanged.

	aGraphic _ ScriptingSystem formAtKey: 'TinyMenu'.
	aGraphic ifNotNil:
		[aTab removeAllMorphs.
		aTab addMorph: (sk _ World drawingClass withForm: aGraphic).
		sk position: aTab position.
		sk lock.
		aTab fitContents].
	self layoutChanged! !


!TabbedPalette methodsFor: 'scraps tab' stamp: 'sw 6/24/1998 18:36'!
hasScrapsTab
	pages detect: [:p | (p hasProperty: #scraps)] ifNone: [^ false].
	^ true! !

!TabbedPalette methodsFor: 'scraps tab' stamp: 'sw 6/24/1998 18:42'!
scrapsBook
	^ pages detect: [:p | p hasProperty: #scraps] ifNone: [nil]! !

!TabbedPalette methodsFor: 'scraps tab' stamp: 'sw 3/8/1999 14:56'!
showScrapsTab
	self selectTabOfBook: self scrapsBook! !


!TabbedPalette methodsFor: 'submorphs-add/remove' stamp: 'sw 4/7/1999 12:16'!
replaceSubmorph: oldMorph by: newMorph
	super replaceSubmorph: oldMorph by: newMorph.
	oldMorph == currentPage ifTrue:
		[currentPage _ newMorph]! !


!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 12/27/1998 23:28'!
selectTab: aTab
	| currentPalette morphToInstall oldTab aSketchEditor |
	currentPage ifNotNil:
		[self currentPalette currentPlayerDo:
			[:aPlayer | aPlayer runAllClosingScripts]].
	oldTab _ tabsMorph highlightedTab.
	(oldTab notNil and: [(morphToInstall _ oldTab morphToInstall) isKindOf: PaintBoxMorph])
		ifTrue:
			[(aSketchEditor _ self world submorphOfClass: SketchEditorMorph) ifNotNil:
				[aSketchEditor cancelOutOfPainting].
			morphToInstall delete].

	tabsMorph selectTab: aTab.
	morphToInstall _ aTab morphToInstall.

	(morphToInstall isKindOf: PaintBoxMorph) "special case, maybe generalize this need?"
		ifFalse:
			[self goToPageMorph: morphToInstall]
		ifTrue:
			[self showNoPaletteAndHighlightTab: aTab.
			self world addMorphFront: morphToInstall.
			morphToInstall position: ((self left max: 90) "room for the pop-out-to-left panel"
				@ (tabsMorph bottom))].
	
	(currentPalette _ self currentPalette) ifNotNil:
		[currentPalette layoutChanged.
		currentPalette currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]].
	self snapToEdgeIfAppropriate! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 1/19/2001 12:47'!
selectTabNamed: aName
	"If the receiver has a tab with the given name, select it"

	| aTab |
	aTab _ self tabNamed: aName.
	aTab ifNotNil: [self selectTab: aTab]! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 7/5/1998 15:40'!
selectTabOfBook: aBook
	self tabMorphs do:
		[:aTab | aTab morphToInstall == aBook ifTrue: [^ self selectTab: aTab]]! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 7/5/1998 15:38'!
tabMorphs
	^ tabsMorph tabMorphs! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 1/19/2001 03:23'!
tabNamed: aName
	"Answer the tab of the given name, or nil if none"

	^ self tabMorphs detect: [:m | ((m isKindOf: StringMorph) and: [m contents = aName])
		or: [(m isKindOf: ReferenceMorph) and: [(m firstSubmorph isKindOf: StringMorph) and:
				[m firstSubmorph contents = aName]]]] ifNone: [nil]! !


!TabbedPalette methodsFor: '*eToys-e-toy support' stamp: 'sw 7/5/1998 15:40'!
succeededInRevealing: aPlayer
	| result |
	result _ super succeededInRevealing: aPlayer.
	result ifTrue:
		["BookMorph code will have called goToPageNumber:; here, we just need to get the tab selection right here"
		self selectTabOfBook: self currentPalette].
	^ result! !


!TabbedPalette methodsFor: '*eToys-viewer tab' stamp: 'sw 3/3/1999 13:17'!
viewMorph: aMorph
	"The receiver is expected to have a viewer tab; select it, and target it to aMorph"
	| aPlayer aViewer oldOwner |
	((currentPage isKindOf: Viewer) and: [currentPage scriptedPlayer == aMorph player])
		ifTrue:
			[^ self].
	oldOwner _ owner.
	self delete.
	self visible: false.
	aPlayer _ aMorph assuredPlayer.
	self showNoPalette.
	aViewer _  StandardViewer new initializeFor: aPlayer barHeight: 0.
	aViewer enforceTileColorPolicy.
	self showNoPalette.
	currentPage ifNotNil: [currentPage delete].
	self addMorphBack: (currentPage _ aViewer beSticky).
	self snapToEdgeIfAppropriate.
	tabsMorph highlightTab: nil.
	self visible: true.
	oldOwner addMorphFront: self.
	self world startSteppingSubmorphsOf: aViewer.
	self layoutChanged! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TabbedPalette class
	instanceVariableNames: ''!

!TabbedPalette class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:40'!
initialize

	self registerInFlapsRegistry.	! !

!TabbedPalette class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:41'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(TabbedPalette	authoringPrototype	'TabbedPalette'	'A structure with tabs')
						forFlapNamed: 'Supplies'.]! !

!TabbedPalette class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:41'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!TabbedPalette class methodsFor: 'parts bin' stamp: 'sw 8/12/2001 13:15'!
descriptionForPartsBin
	^ DescriptionForPartsBin
		formalName: 'TabbedPalette'
		categoryList: #('Presentation')
		documentation: 'A tabbed palette of books'
		globalReceiverSymbol: #TabbedPalette
		nativitySelector: #authoringPrototype! !


!TabbedPalette class methodsFor: 'printing' stamp: 'sw 6/3/1998 21:27'!
defaultNameStemForInstances
	^ 'tabbedPalette'! !


!TabbedPalette class methodsFor: 'scripting' stamp: 'nk 6/12/2004 10:05'!
authoringPrototype
	| aTabbedPalette aBook aTab |
	aTabbedPalette _ self new markAsPartsDonor.
	aTabbedPalette pageSize: 200 @ 300.
	aTabbedPalette tabsMorph highlightColor: Color red regularColor: Color blue.
	aTabbedPalette addMenuTab.

	aBook _ BookMorph new setNameTo: 'one'; pageSize: aTabbedPalette pageSize.
	aBook color: Color blue muchLighter.
	aBook removeEverything; insertPage; showPageControls.
	aBook currentPage addMorphBack: (World drawingClass withForm: ScriptingSystem squeakyMouseForm).
	aTab _ aTabbedPalette addTabForBook: aBook.

	aBook _ BookMorph new setNameTo: 'two'; pageSize: aTabbedPalette pageSize.
	aBook color: Color red muchLighter.
	aBook removeEverything; insertPage; showPageControls.
	aBook currentPage addMorphBack: CurveMorph authoringPrototype.
	aTabbedPalette addTabForBook: aBook.

	aTabbedPalette selectTab: aTab.

	aTabbedPalette beSticky.
	aTabbedPalette tabsMorph hResizing: #spaceFill.
	^ aTabbedPalette! !
LayoutPolicy subclass: #TableLayout
	instanceVariableNames: 'properties minExtentCache'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!TableLayout commentStamp: '<historical>' prior: 0!
The layout process:
For computing the new layout for the children of any morph, we start with an initial rectangle which is provided as a reference.

Step 1: The first step of layout computation is to compute the minimum extent each of our children can have. The minimum extent is mapped through both the local layout frame of the morph (for relative positioning) and the global layout frame (for insets, such as cursor indication) to obtain the minimal size required for each cell.

Step 2: Based on the cell sizes, the number of cells we can put into each row and column is computed. For equal spacing, the maximum size of the cells is taken into account here.

Step 3: Based on the row/column sizes, we compute the extra space which should be added to each row/column. For 
	#leftFlush/#topFlush - we add all extra space add the end
	#rightFlush/#bottomFlush - we add all extra space at the start
	#centering - we add 1/2 of the extra space at start and end
	#justified - we distribute the space evenly between the morphs
[NOTE: If any #spaceFill morphs are encountered during this step, #justified is implied and the space is exclusively and equally distributed between those #spaceFill morphs. This is for backward compatibility and should *never* be necessary in the new regime].

Step 4: The morphs are placed in the computed cells and the extra space is distributed as necessary. Placing the submorphs is done by mapping through the global and the local layout frame as requested.

Start point:
=> bounds: new rectangle for the morph.

Compute basic arrangement of morphs:
=> For each submorph compute minExtent
	- if global layout frame inset in global layout frame
	- if local layout frame inset in local layout frame
=> Compute number of morphs per, width and height of row/column
	- if equal spacing based on max size
=> Compute extra space per row/column
	- if centering = #justified; distribute space equally
	- if centering #leftFlush/#topFlush (-1) add start extra
	- if centering #rightFlush/#bottomFlush (1) add end extra
	- if centering #centered add 1/2 extra to start/end
	<extra space must be float and rounded accordingly!!>
=> Place morphs in appropriate cells
	- if global layout frame inset in global layout frame
	- if local layout frame inset in local layout frame
	<will likely cause #layoutChanged by submorphs>

Distribute morphs in row/column:

=> Compute the max length of each row/column
!


!TableLayout methodsFor: 'layout' stamp: 'jdl 3/28/2003 08:18'!
computeCellArrangement: cellHolder in: newBounds horizontal: aBool target: aMorph 
	"Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level.
	Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row."

	| cells wrap spacing output maxExtent n sum index max cell first last w cellMax maxCell hFill vFill inset |
	maxCell := cellHolder key.
	cells := cellHolder value.
	properties wrapDirection == #none 
		ifTrue: [wrap := SmallInteger maxVal]
		ifFalse: 
			[wrap := aBool ifTrue: [newBounds width] ifFalse: [newBounds height].
			wrap := wrap max: (maxCell x)].
	spacing := properties cellSpacing.
	(spacing == #globalRect or: [spacing = #globalSquare]) 
		ifTrue: 
			["Globally equal spacing is a very special case here, so get out fast and easy"

			^self 
				computeGlobalCellArrangement: cells
				in: newBounds
				horizontal: aBool
				wrap: wrap
				spacing: spacing].
	output := WriteStream on: Array new.
	inset := properties cellInset asPoint.
	aBool ifFalse: [inset := inset transposed].
	first := last := nil.
	maxExtent := 0 @ 0.
	sum := 0.
	index := 1.
	n := 0.
	hFill := vFill := false.
	[index <= cells size] whileTrue: 
			[w := sum.
			cell := cells at: index.
			cellMax := maxExtent max: cell cellSize.	"e.g., minSize"
			sum := (spacing == #localRect or: [spacing == #localSquare]) 
						ifTrue: 
							["Recompute entire size of current row"

							max := spacing == #localSquare 
										ifTrue: [cellMax x max: cellMax y]
										ifFalse: [cellMax x].
							(n + 1) * max]
						ifFalse: [sum + cell cellSize x].
			(sum + (n * inset x) > wrap and: [first notNil]) 
				ifTrue: 
					["It doesn't fit and we're not starting a new line"

					(spacing == #localSquare or: [spacing == #localRect]) 
						ifTrue: 
							[spacing == #localSquare 
								ifTrue: [maxExtent := (maxExtent x max: maxExtent y) asPoint].
							first do: [:c | c cellSize: maxExtent]].
					w := w + ((n - 1) * inset x).
					"redistribute extra space"
					first nextCell 
						ifNotNil: [first nextCell do: [:c | c addExtraSpace: inset x @ 0]].
					last := LayoutCell new.
					last cellSize: w @ maxExtent y.
					last hSpaceFill: hFill.
					last vSpaceFill: vFill.
					last nextCell: first.
					output position = 0 ifFalse: [last addExtraSpace: 0 @ inset y].
					output nextPut: last.
					first := nil.
					maxExtent := 0 @ 0.
					sum := 0.
					n := 0.
					hFill := vFill := false]
				ifFalse: 
					["It did fit; use next item from input"

					first ifNil: [first := last := cell]
						ifNotNil: 
							[last nextCell: cell.
							last := cell].
					index := index + 1.
					n := n + 1.
					maxExtent := cellMax.
					hFill := hFill or: [cell hSpaceFill].
					vFill := vFill or: [cell vSpaceFill]]].
	first ifNotNil: 
			[last := LayoutCell new.
			sum := sum + ((n - 1) * inset x).
			first nextCell 
				ifNotNil: [first nextCell do: [:c | c addExtraSpace: inset x @ 0]].
			last cellSize: sum @ maxExtent y.
			last hSpaceFill: hFill.
			last vSpaceFill: vFill.
			last nextCell: first.
			output position = 0 ifFalse: [last addExtraSpace: 0 @ inset y].
			output nextPut: last].
	output := output contents.
	properties listSpacing == #equal 
		ifTrue: 
			["Make all the heights equal"

			max := output inject: 0 into: [:size :c | size max: c cellSize y].
			output do: [:c | c cellSize: c cellSize x @ max]].
	^output! !

!TableLayout methodsFor: 'layout' stamp: 'ar 12/18/2000 13:45'!
computeCellSizes: aMorph in: newBounds horizontal: aBool
	"Step 1: Compute the minimum extent for all the children of aMorph"
	| cells cell size block maxCell minSize maxSize |
	cells _ WriteStream on: (Array new: aMorph submorphCount).
	minSize _ properties minCellSize asPoint.
	maxSize _ properties maxCellSize asPoint.
	aBool ifTrue:[
		minSize _ minSize transposed.
		maxSize _ maxSize transposed].
	maxCell _ 0@0.
	block _ [:m|
		m disableTableLayout ifFalse:[
			size _ m minExtent asIntegerPoint.
			cell _ LayoutCell new target: m.
			aBool ifTrue:[
				cell hSpaceFill: m hResizing == #spaceFill.
				cell vSpaceFill: m vResizing == #spaceFill.
			] ifFalse:[
				cell hSpaceFill: m vResizing == #spaceFill.
				cell vSpaceFill: m hResizing == #spaceFill.
				size _ size transposed.
			].
			size _ (size min: maxSize) max: minSize.
			cell cellSize: size.
			maxCell _ maxCell max: size.
			cells nextPut: cell]].
	properties reverseTableCells
		ifTrue:[aMorph submorphsReverseDo: block]
		ifFalse:[aMorph submorphsDo: block].
	^maxCell -> cells contents! !

!TableLayout methodsFor: 'layout' stamp: 'aoy 2/15/2003 20:49'!
computeExtraSpacing: arrangement in: newBounds horizontal: aBool target: aMorph 
	"Compute the required extra spacing for laying out the cells"

	"match newBounds extent with arrangement's orientation"

	| extent extra centering n extraPerCell cell last hFill vFill max amount allow |
	extent := newBounds extent.
	aBool ifFalse: [extent := extent transposed].

	"figure out if we have any horizontal or vertical space fillers"
	hFill := vFill := false.
	max := 0 @ 0.
	arrangement do: 
			[:c | 
			max := (max x max: c cellSize x) @ (max y + c cellSize y).
			max := max max: c cellSize.
			hFill := hFill or: [c hSpaceFill].
			vFill := vFill or: [c vSpaceFill]].

	"Take client's shrink wrap constraints into account.
	Note: these are only honored when there are no #spaceFill children,
	or when #rubberBandCells is set."
	allow := properties rubberBandCells not.
	aMorph hResizing == #shrinkWrap 
		ifTrue: 
			[aBool 
				ifTrue: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]]
				ifFalse: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]].
	aMorph vResizing == #shrinkWrap 
		ifTrue: 
			[aBool 
				ifFalse: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]]
				ifTrue: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]].

	"Now compute the extra v space"
	extra := extent y 
				- (arrangement inject: 0 into: [:sum :c | sum + c cellSize y]).
	extra > 0 
		ifTrue: 
			["Check if we have any #spaceFillers"

			vFill 
				ifTrue: 
					["use only #spaceFillers"

					n := arrangement inject: 0
								into: [:sum :c | c vSpaceFill ifTrue: [sum + 1] ifFalse: [sum]].
					n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat].
					extra := last := 0.
					arrangement do: 
							[:c | 
							c vSpaceFill 
								ifTrue: 
									[extra := (last := extra) + extraPerCell.
									amount := 0 @ (extra truncated - last truncated).
									c do: [:cc | cc cellSize: cc cellSize + amount]]]]
				ifFalse: 
					["no #spaceFillers; distribute regularly"

					centering := properties wrapCentering.
					"centering == #topLeft ifTrue:[]."	"add all extra space to the last cell; e.g., do nothing"
					centering == #bottomRight 
						ifTrue: 
							["add all extra space to the first cell"

							arrangement first addExtraSpace: 0 @ extra].
					centering == #center 
						ifTrue: 
							["add 1/2 extra space to the first and last cell"

							arrangement first addExtraSpace: 0 @ (extra // 2)].
					centering == #justified 
						ifTrue: 
							["add extra space equally distributed to each cell"

							n := arrangement size - 1 max: 1.
							extraPerCell := extra asFloat / n asFloat.
							extra := last := 0.
							arrangement do: 
									[:c | 
									c addExtraSpace: 0 @ (extra truncated - last truncated).
									extra := (last := extra) + extraPerCell]]]].

	"Now compute the extra space for the primary direction"
	centering := properties listCentering.
	1 to: arrangement size
		do: 
			[:i | 
			cell := arrangement at: i.
			extra := extent x - cell cellSize x.
			extra > 0 
				ifTrue: 
					["Check if we have any #spaceFillers"
					cell := cell nextCell.
					cell hSpaceFill 
						ifTrue: 
							["use only #spaceFillers"

							
							n := cell inject: 0
										into: [:sum :c | c hSpaceFill ifTrue: [sum + c target spaceFillWeight] ifFalse: [sum]].
							n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat].
							extra := last := 0.
							cell do: 
									[:c | 
									c hSpaceFill 
										ifTrue: 
											[extra := (last := extra) + (extraPerCell * c target spaceFillWeight).
											amount := extra truncated - last truncated.
											c cellSize: c cellSize + (amount @ 0)]]]
						ifFalse: 
							["no #spaceFiller; distribute regularly"

						
							"centering == #topLeft ifTrue:[]"	"add all extra space to the last cell; e.g., do nothing"
							centering == #bottomRight 
								ifTrue: 
									["add all extra space to the first cell"

									cell addExtraSpace: extra @ 0].
							centering == #center 
								ifTrue: 
									["add 1/2 extra space to the first and last cell"

									cell addExtraSpace: (extra // 2) @ 0].
							centering == #justified 
								ifTrue: 
									["add extra space equally distributed to each cell"

									n := cell size - 1 max: 1.
									extraPerCell := extra asFloat / n asFloat.
									extra := last := 0.
									cell do: 
											[:c | 
											c addExtraSpace: (extra truncated - last truncated) @ 0.
											extra := (last := extra) + extraPerCell]]]]]! !

!TableLayout methodsFor: 'layout' stamp: 'ar 10/31/2000 22:50'!
computeGlobalCellArrangement: cells in: newBounds horizontal: aBool wrap: wrap spacing: spacing
	"Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level.
	Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row."
	| output maxExtent n cell first last hFill vFill |
	output _ (WriteStream on: Array new).
	first _ last _ nil.
	maxExtent _ cells inject: 0@0 into:[:size :c| size max: c cellSize "e.g., minSize"].
	spacing == #globalSquare ifTrue:[maxExtent _ (maxExtent x max: maxExtent y) asPoint].
	n _ (wrap // maxExtent x) max: 1.
	hFill _ vFill _ false.
	1 to: cells size do:[:i|
		cell _ cells at: i.
		hFill _ hFill or:[cell hSpaceFill].
		vFill _ vFill or:[cell vSpaceFill].
		cell cellSize: maxExtent.
		first ifNil:[first _ last _ cell] ifNotNil:[last nextCell: cell. last _ cell].
		(i \\ n) = 0 ifTrue:[
			last _ LayoutCell new.
			last cellSize: (maxExtent x * n) @ (maxExtent y).
			last hSpaceFill: hFill.
			last vSpaceFill: vFill.
			hFill _ vFill _ false.
			last nextCell: first.
			output nextPut: last.
			first _ nil]].
	first ifNotNil:[
		last _ LayoutCell new.
		last cellSize: (maxExtent x * n) @ (maxExtent y). self flag: #arNote."@@@: n is not correct!!"
		last nextCell: first.
		output nextPut: last].
	^output contents
! !

!TableLayout methodsFor: 'layout' stamp: 'ar 1/27/2001 14:40'!
flushLayoutCache
	"Flush any cached information associated with the receiver"
	minExtentCache _ nil.! !

!TableLayout methodsFor: 'layout' stamp: 'aoy 2/17/2003 01:23'!
layout: aMorph in: box 
	"Compute the layout for the given morph based on the new bounds"

	| cells arrangement horizontal newBounds |
	aMorph hasSubmorphs ifFalse: [^self].
	properties := aMorph assureTableProperties.
	newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint.
	(properties wrapDirection == #none and: [properties cellSpacing == #none]) 
		ifTrue: 
			["get into the fast lane"

			properties listCentering == #justified 
				ifFalse: 
					["can't deal with that"

					properties listDirection == #leftToRight 
						ifTrue: [^self layoutLeftToRight: aMorph in: newBounds].
					properties listDirection == #topToBottom 
						ifTrue: [^self layoutTopToBottom: aMorph in: newBounds]]].
	horizontal := (properties listDirection == #topToBottom 
				or: [properties listDirection == #bottomToTop]) not. 
	"Step 1: Compute the minimum extent for all the children of aMorph"
	cells := self 
				computeCellSizes: aMorph
				in: (0 @ 0 corner: newBounds extent)
				horizontal: horizontal.
	"Step 2: Compute the arrangement of the cells for each row and column"
	arrangement := self 
				computeCellArrangement: cells
				in: newBounds
				horizontal: horizontal
				target: aMorph.
	"Step 3: Compute the extra spacing for each cell"
	self 
		computeExtraSpacing: arrangement
		in: newBounds
		horizontal: horizontal
		target: aMorph.
	"Step 4: Place the children within the cells accordingly"
	self 
		placeCells: arrangement
		in: newBounds
		horizontal: horizontal
		target: aMorph! !

!TableLayout methodsFor: 'layout' stamp: 'gm 2/28/2003 01:43'!
minExtentOf: aMorph in: box 
	"Return the minimal size aMorph's children would require given the new bounds"

	| cells arrangement horizontal newBounds minX minY dir |
	minExtentCache isNil ifFalse: [^minExtentCache].
	aMorph hasSubmorphs ifFalse: [^0 @ 0].
	properties := aMorph assureTableProperties.
	(properties wrapDirection == #none and: [properties cellSpacing == #none]) 
		ifTrue: 
			["Get into the fast lane"

			dir := properties listDirection.
			(dir == #leftToRight or: [dir == #rightToLeft]) 
				ifTrue: [^self minExtentHorizontal: aMorph].
			(dir == #topToBottom or: [dir == #bottomToTop]) 
				ifTrue: [^self minExtentVertical: aMorph]].
	newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint.
	horizontal := (properties listDirection == #topToBottom 
				or: [properties listDirection == #bottomToTop]) not.
	"Step 1: Compute the minimum extent for all the children of aMorph"
	cells := self 
				computeCellSizes: aMorph
				in: (0 @ 0 corner: newBounds extent)
				horizontal: horizontal.
	"Step 2: Compute the arrangement of the cells for each row and column"
	arrangement := self 
				computeCellArrangement: cells
				in: newBounds
				horizontal: horizontal
				target: aMorph.
	"Step 3: Extract the minimum size out of the arrangement"
	minX := minY := 0.
	arrangement do: 
			[:cell | 
			minX := minX max: cell cellSize x + cell extraSpace x.
			minY := minY + cell cellSize y + cell extraSpace y].
	minExtentCache := horizontal ifTrue: [minX @ minY] ifFalse: [minY @ minX].
	^minExtentCache! !

!TableLayout methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:42'!
placeCells: arrangement in: newBounds horizontal: aBool target: aMorph 
	"Place the morphs within the cells accordingly"

	| xDir yDir anchor yDist place cell xDist cellRect corner inset |
	inset := properties cellInset.
	(inset isNumber and: [inset isZero]) ifTrue: [inset := nil].
	aBool 
		ifTrue: 
			["horizontal layout"

			properties listDirection == #rightToLeft 
				ifTrue: 
					[xDir := -1 @ 0.
					properties wrapDirection == #bottomToTop 
						ifTrue: 
							[yDir := 0 @ -1.
							anchor := newBounds bottomRight]
						ifFalse: 
							[yDir := 0 @ 1.
							anchor := newBounds topRight]]
				ifFalse: 
					[xDir := 1 @ 0.
					properties wrapDirection == #bottomToTop 
						ifTrue: 
							[yDir := 0 @ -1.
							anchor := newBounds bottomLeft]
						ifFalse: 
							[yDir := 0 @ 1.
							anchor := newBounds topLeft]]]
		ifFalse: 
			["vertical layout"

			properties listDirection == #bottomToTop 
				ifTrue: 
					[xDir := 0 @ -1.
					properties wrapDirection == #rightToLeft 
						ifTrue: 
							[yDir := -1 @ 0.
							anchor := newBounds bottomRight]
						ifFalse: 
							[yDir := 1 @ 0.
							anchor := newBounds bottomLeft]]
				ifFalse: 
					[xDir := 0 @ 1.
					anchor := properties wrapDirection == #rightToLeft 
								ifTrue: 
									[yDir := -1 @ 0.
									newBounds topRight]
								ifFalse: 
									[yDir := 1 @ 0.
									newBounds topLeft]]].
	1 to: arrangement size
		do: 
			[:i | 
			cell := arrangement at: i.
			cell extraSpace ifNotNil: [anchor := anchor + (cell extraSpace y * yDir)].
			yDist := cell cellSize y * yDir.	"secondary advance direction"
			place := anchor.
			cell := cell nextCell.
			[cell isNil] whileFalse: 
					[cell extraSpace ifNotNil: [place := place + (cell extraSpace x * xDir)].
					xDist := cell cellSize x * xDir.	"primary advance direction"
					corner := place + xDist + yDist.
					cellRect := Rectangle origin: (place min: corner)
								corner: (place max: corner).
					inset ifNotNil: [cellRect := cellRect insetBy: inset].
					cell target layoutInBounds: cellRect.
					place := place + xDist.
					cell := cell nextCell].
			anchor := anchor + yDist]! !


!TableLayout methodsFor: 'optimized' stamp: 'jdl 3/28/2003 08:48'!
layoutLeftToRight: aMorph in: newBounds 
	"An optimized left-to-right list layout"

	| inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props |
	size := properties minCellSize asPoint.
	minX := size x.
	minY := size y.
	size := properties maxCellSize asPoint.
	maxX := size x.
	maxY := size y.
	inset := properties cellInset asPoint x.
	extent := newBounds extent.
	n := 0.
	vFill := false.
	sum := 0.
	width := height := 0.
	first := last := nil.
	block := 
			[:m | 
			props := m layoutProperties ifNil: [m].
			props disableTableLayout 
				ifFalse: 
					[n := n + 1.
					cell := LayoutCell new target: m.
					props hResizing == #spaceFill 
						ifTrue: 
							[cell hSpaceFill: true.
							extra := m spaceFillWeight.
							cell extraSpace: extra.
							sum := sum + extra]
						ifFalse: [cell hSpaceFill: false].
					props vResizing == #spaceFill ifTrue: [vFill := true].
					size := m minExtent.
					size := m minExtent.
					sizeX := size x.
					sizeY := size y.
					sizeX < minX ifTrue: [sizeX := minX] ifFalse: [sizeX := sizeX min: maxX].
					sizeY < minY ifTrue: [sizeY := minY] ifFalse: [sizeY := sizeY min: maxY].
					cell cellSize: sizeX.
					last ifNil: [first := cell] ifNotNil: [last nextCell: cell].
					last := cell.
					width := width + sizeX.
					sizeY > height ifTrue: [height := sizeY]]].
	properties reverseTableCells 
		ifTrue: [aMorph submorphsReverseDo: block]
		ifFalse: [aMorph submorphsDo: block].
	n > 1 ifTrue: [width := width + ((n - 1) * inset)].
	(properties hResizing == #shrinkWrap 
		and: [properties rubberBandCells or: [sum isZero]]) 
			ifTrue: [extent := width @ (extent y max: height)].
	(properties vResizing == #shrinkWrap 
		and: [properties rubberBandCells or: [vFill not]]) 
			ifTrue: [extent := (extent x max: width) @ height].
	posX := newBounds left.
	posY := newBounds top.

	"Compute extra vertical space"
	extra := extent y - height.
	extra := extra max: 0.
	extra > 0 
		ifTrue: 
			[vFill 
				ifTrue: [height := extent y]
				ifFalse: 
					[centering := properties wrapCentering.
					centering == #bottomRight ifTrue: [posY := posY + extra].
					centering == #center ifTrue: [posY := posY + (extra // 2)]]].


	"Compute extra horizontal space"
	extra := extent x - width.
	extra := extra max: 0.
	extraPerCell := 0.
	extra > 0 
		ifTrue: 
			[sum isZero 
				ifTrue: 
					["extra space but no #spaceFillers"

					centering := properties listCentering.
					centering == #bottomRight ifTrue: [posX := posX + extra].
					centering == #center ifTrue: [posX := posX + (extra // 2)]]
				ifFalse: [extraPerCell := extra asFloat / sum asFloat]].
	n := 0.
	extra := last := 0.
	cell := first.
	[cell isNil] whileFalse: 
			[n := n + 1.
			width := cell cellSize.
			(extraPerCell > 0 and: [cell hSpaceFill]) 
				ifTrue: 
					[extra := (last := extra) + (extraPerCell * cell extraSpace).
					amount := extra truncated - last truncated.
					width := width + amount].
			cell target layoutInBounds: (posX @ posY extent: width @ height).
			posX := posX + width + inset.
			cell := cell nextCell]! !

!TableLayout methodsFor: 'optimized' stamp: 'jdl 3/28/2003 08:50'!
layoutTopToBottom: aMorph in: newBounds 
	"An optimized top-to-bottom list layout"

	| inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props |
	size := properties minCellSize asPoint.
	minX := size x.
	minY := size y.
	size := properties maxCellSize asPoint.
	maxX := size x.
	maxY := size y.
	inset := properties cellInset asPoint y.
	extent := newBounds extent.
	n := 0.
	vFill := false.
	sum := 0.
	width := height := 0.
	first := last := nil.
	block := 
			[:m | 
			props := m layoutProperties ifNil: [m].
			props disableTableLayout 
				ifFalse: 
					[n := n + 1.
					cell := LayoutCell new target: m.
					props vResizing == #spaceFill 
						ifTrue: 
							[cell vSpaceFill: true.
							extra := m spaceFillWeight.
							cell extraSpace: extra.
							sum := sum + extra]
						ifFalse: [cell vSpaceFill: false].
					props hResizing == #spaceFill ifTrue: [vFill := true].
					size := m minExtent.
					sizeX := size x.
					sizeY := size y.
					sizeX < minX ifTrue: [sizeX := minX] ifFalse: [sizeX := sizeX min: maxX].
					sizeY < minY ifTrue: [sizeY := minY] ifFalse: [sizeY := sizeY min: maxY].
					cell cellSize: sizeY.
					first ifNil: [first := cell] ifNotNil: [last nextCell: cell].
					last := cell.
					height := height + sizeY.
					sizeX > width ifTrue: [width := sizeX]]].
	properties reverseTableCells 
		ifTrue: [aMorph submorphsReverseDo: block]
		ifFalse: [aMorph submorphsDo: block].
	n > 1 ifTrue: [height := height + ((n - 1) * inset)].
	(properties vResizing == #shrinkWrap 
		and: [properties rubberBandCells or: [sum isZero]]) 
			ifTrue: [extent := (extent x max: width) @ height].
	(properties hResizing == #shrinkWrap 
		and: [properties rubberBandCells or: [vFill not]]) 
			ifTrue: [extent := width @ (extent y max: height)].
	posX := newBounds left.
	posY := newBounds top.

	"Compute extra horizontal space"
	extra := extent x - width.
	extra := extra max: 0.
	extra > 0 
		ifTrue: 
			[vFill 
				ifTrue: [width := extent x]
				ifFalse: 
					[centering := properties wrapCentering.
					centering == #bottomRight ifTrue: [posX := posX + extra].
					centering == #center ifTrue: [posX := posX + (extra // 2)]]].


	"Compute extra vertical space"
	extra := extent y - height.
	extra := extra max: 0.
	extraPerCell := 0.
	extra > 0 
		ifTrue: 
			[sum isZero 
				ifTrue: 
					["extra space but no #spaceFillers"

					centering := properties listCentering.
					centering == #bottomRight ifTrue: [posY := posY + extra].
					centering == #center ifTrue: [posY := posY + (extra // 2)]]
				ifFalse: [extraPerCell := extra asFloat / sum asFloat]].
	n := 0.
	extra := last := 0.
	cell := first.
	[cell isNil] whileFalse: 
			[n := n + 1.
			height := cell cellSize.
			(extraPerCell > 0 and: [cell vSpaceFill]) 
				ifTrue: 
					[extra := (last := extra) + (extraPerCell * cell extraSpace).
					amount := extra truncated - last truncated.
					height := height + amount].
			cell target layoutInBounds: (posX @ posY extent: width @ height).
			posY := posY + height + inset.
			cell := cell nextCell]! !

!TableLayout methodsFor: 'optimized' stamp: 'jdl 3/28/2003 08:37'!
minExtentHorizontal: aMorph 
	"Return the minimal size aMorph's children would require given the new bounds"

	| inset n size width height minX minY maxX maxY sizeX sizeY |
	size := properties minCellSize asPoint.
	minX := size x.
	minY := size y.
	size := properties maxCellSize asPoint.
	maxX := size x.
	maxY := size y.
	inset := properties cellInset asPoint.
	n := 0.
	width := height := 0.
	aMorph submorphsDo: 
			[:m | 
			m disableTableLayout 
				ifFalse: 
					[n := n + 1.
					size := m minExtent.
					sizeX := size x.
					sizeY := size y.
					sizeX < minX 
						ifTrue: [sizeX := minX]
						ifFalse: [sizeX := sizeX min: maxX].
					sizeY < minY 
						ifTrue: [sizeY := minY]
						ifFalse: [sizeY := sizeY min: maxY].
					width := width + sizeX.
					sizeY > height ifTrue: [height := sizeY]]].
	n > 1 ifTrue: [width := width + ((n - 1) * inset x)].
	^minExtentCache := width @ height! !

!TableLayout methodsFor: 'optimized' stamp: 'jdl 3/28/2003 08:39'!
minExtentVertical: aMorph 
	"Return the minimal size aMorph's children would require given the new bounds"

	| inset n size width height minX minY maxX maxY sizeX sizeY |
	size := properties minCellSize asPoint.
	minX := size x.
	minY := size y.
	size := properties maxCellSize asPoint.
	maxX := size x.
	maxY := size y.
	inset := properties cellInset asPoint.
	n := 0.
	width := height := 0.
	aMorph submorphsDo: 
			[:m | 
			m disableTableLayout 
				ifFalse: 
					[n := n + 1.
					size := m minExtent.
					sizeX := size x.
					sizeY := size y.
					sizeX < minX 
						ifTrue: [sizeX := minX]
						ifFalse: [sizeX := sizeX min: maxX].
					sizeY < minY 
						ifTrue: [sizeY := minY]
						ifFalse: [sizeY := sizeY min: maxY].
					height := height + sizeY.
					sizeX > width ifTrue: [width := sizeX]]].
	n > 1 ifTrue: [height := height + ((n - 1) * inset y)].
	^minExtentCache := width @ height! !


!TableLayout methodsFor: 'testing' stamp: 'ar 10/29/2000 01:29'!
isTableLayout
	^true! !


!TableLayout methodsFor: 'utilities' stamp: 'aoy 2/17/2003 01:22'!
indexForInserting: aMorph at: aPoint in: owner 
	"Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion."

	| horizontal morphList index |
	owner hasSubmorphs ifFalse: [^1].
	aMorph disableTableLayout ifTrue: [^1].
	horizontal := (owner listDirection == #topToBottom 
				or: [owner listDirection == #bottomToTop]) not .
	morphList := owner submorphs.
	owner reverseTableCells ifTrue: [morphList := morphList reversed].
	index := self 
				indexForInserting: aPoint
				inList: morphList
				horizontal: horizontal
				target: owner.
	owner reverseTableCells ifTrue: [index := morphList size - index + 2].
	^index ifNil: [1]! !

!TableLayout methodsFor: 'utilities' stamp: 'aoy 2/17/2003 01:22'!
indexForInserting: aPoint inList: morphList horizontal: aBool target: aMorph 
	| box cmp1 cmp2 cmp3 noWrap |
	properties := aMorph layoutProperties.
	noWrap := properties wrapDirection == #none.
	aBool 
		ifTrue: 
			["horizontal"

			properties listDirection == #rightToLeft 
				ifTrue: [cmp1 := [:rect | aPoint x > rect left]]
				ifFalse: [cmp1 := [:rect | aPoint x < rect right]].
			properties wrapDirection == #bottomToTop 
				ifTrue: 
					[cmp2 := [:rect | aPoint y > rect top].
					cmp3 := [:rect | aPoint y > rect bottom]]
				ifFalse: 
					[cmp2 := [:rect | aPoint y < rect bottom].
					cmp3 := [:rect | aPoint y < rect top]]]
		ifFalse: 
			["vertical"

			properties listDirection == #bottomToTop 
				ifTrue: [cmp1 := [:rect | aPoint y > rect top]]
				ifFalse: [cmp1 := [:rect | aPoint y < rect bottom]].
			properties wrapDirection == #rightToLeft 
				ifTrue: 
					[cmp2 := [:rect | aPoint x > rect left].
					cmp3 := [:rect | aPoint x > rect right]]
				ifFalse: 
					[cmp2 := [:rect | aPoint x < rect right].
					cmp3 := [:rect | aPoint x < rect left]]]. 
	morphList keysAndValuesDo: 
			[:index :m | 
			self flag: #arNote.	"it is not quite clear if we can really use #fullBounds here..."
			box := m fullBounds.
			noWrap 
				ifTrue: 
					["Only in one direction"

					(cmp1 value: box) ifTrue: [^index]]
				ifFalse: 
					["Check for inserting before current row"

					(cmp3 value: box) ifTrue: [^index].
					"Check for inserting before current cell"
					((cmp1 value: box) and: [cmp2 value: box]) ifTrue: [^index]]].
	^morphList size + 1! !
LayoutProperties subclass: #TableLayoutProperties
	instanceVariableNames: 'cellInset cellPositioning cellSpacing layoutInset listCentering listDirection listSpacing reverseTableCells rubberBandCells wrapCentering wrapDirection minCellSize maxCellSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:57'!
cellInset: aNumber
	cellInset _ aNumber! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:49'!
cellPositioning: aSymbol
	cellPositioning _ aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
cellSpacing: aSymbol
	cellSpacing _ aSymbol.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 16:37'!
layoutInset: aNumber
	layoutInset _ aNumber! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
listCentering: aSymbol
	listCentering _ aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
listDirection: aSymbol
	listDirection _ aSymbol.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
listSpacing: aSymbol
	listSpacing _ aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:58'!
maxCellSize: aNumber
	maxCellSize _ aNumber.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:57'!
minCellSize: aNumber
	minCellSize _ aNumber.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
reverseTableCells: aBool
	reverseTableCells _ aBool! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'!
rubberBandCells: aBool
	rubberBandCells _ aBool.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'!
wrapCentering: aSymbol
	wrapCentering _ aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'!
wrapDirection: aSymbol
	wrapDirection _ aSymbol! !


!TableLayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:45'!
initialize
	super initialize.
	cellSpacing _ listSpacing _ wrapDirection _ #none.
	cellPositioning _ #center.
	listCentering _ wrapCentering _ #topLeft.
	listDirection _ #topToBottom.
	reverseTableCells _ rubberBandCells _ false.
	layoutInset _ cellInset _ minCellSize _ 0.
	maxCellSize _ 1073741823. "SmallInteger maxVal"
! !


!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:45'!
cellInset
	^cellInset! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:49'!
cellPositioning
	^cellPositioning! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:46'!
cellSpacing
	^cellSpacing! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 16:37'!
layoutInset
	^layoutInset! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:46'!
listCentering
	^listCentering! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:46'!
listDirection
	^listDirection! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'!
listSpacing
	^listSpacing! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'!
maxCellSize
	^maxCellSize! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'!
minCellSize
	^minCellSize! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'!
reverseTableCells
	^reverseTableCells! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'!
rubberBandCells
	^rubberBandCells! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:48'!
wrapCentering
	^wrapCentering! !

!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:48'!
wrapDirection
	^wrapDirection! !


!TableLayoutProperties methodsFor: 'testing' stamp: 'ar 11/13/2000 18:34'!
includesTableProperties
	^true! !
GesturalEvent subclass: #TalkGesturalEvent
	instanceVariableNames: 'phoneme'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!TalkGesturalEvent methodsFor: 'accessing' stamp: 'len 9/6/1999 00:41'!
phoneme
	^ phoneme! !

!TalkGesturalEvent methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
phoneme: aPhoneme
	phoneme := aPhoneme! !


!TalkGesturalEvent methodsFor: 'playing' stamp: 'len 9/6/1999 00:44'!
actOn: aHeadMorph
	aHeadMorph face lips articulate: self phoneme! !


!TalkGesturalEvent methodsFor: 'printing' stamp: 'len 9/7/1999 02:27'!
printOn: aStream
	aStream nextPutAll: 'articulate '; print: self phoneme! !
Archive subclass: #TarArchive
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Archives'!
!TarArchive commentStamp: '<historical>' prior: 0!
This is a kind of archive that uses the TAR format (popular in Unix). It is here as a placeholder.!


!TarArchive methodsFor: 'private' stamp: 'nk 2/21/2001 18:27'!
memberClass
	^TarArchiveMember! !
ArchiveMember subclass: #TarArchiveMember
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Archives'!
ProtocolClient subclass: #TelnetProtocolClient
	instanceVariableNames: 'responseCode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!TelnetProtocolClient commentStamp: 'mir 5/12/2003 18:06' prior: 0!
Abstract super class for protocol clients based on the generic telnet protocol "<response code> <response>"

Structure:
	responseCode	the numerical (integer) value of the last response code
!


!TelnetProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'!
responseCode
	^responseCode! !


!TelnetProtocolClient methodsFor: 'private' stamp: 'mir 2/22/2002 17:34'!
determineResponseCode
	self lastResponse size >= 3
		ifFalse: [^0].
	^[SmallInteger readFromString: (self lastResponse copyFrom: 1 to: 3)]
		on: Error
		do: [:ex | ex return: 0]! !

!TelnetProtocolClient methodsFor: 'private' stamp: 'mir 11/14/2002 18:27'!
lastResponse: aString
	super lastResponse: aString.
	responseCode _ self determineResponseCode! !


!TelnetProtocolClient methodsFor: 'private protocol' stamp: 'nk 2/24/2005 18:21'!
fetchNextResponse
	"The FTP and similar protocols allow multi-line responses.
	If the response is multi-line, the fourth character of the first line is a  
	$- and the last line repeats the numeric code but the code is followed by 
	a space."

	| response result firstLine |
	result := '' writeStream.
	firstLine := self stream nextLine.
	result nextPutAll: firstLine.
	(self responseIsContinuation: firstLine) 
		ifTrue: 
			["continued over multiple lines. Discard continuation lines."

			
			[response := self stream nextLine.
			response ifNil: [^nil].
			response size > 3 and: 
					[(response copyFrom: 1 to: 3) = (firstLine copyFrom: 1 to: 3) 
						and: [(response at: 4) = Character space]]] 
					whileFalse: 
						[result
							cr;
							nextPutAll: response]].
	self lastResponse: result contents! !

!TelnetProtocolClient methodsFor: 'private protocol' stamp: 'mir 4/7/2003 15:46'!
lookForCode: code
	"We are expecting a certain code next."

	self
		lookForCode: code
		ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: response]
! !

!TelnetProtocolClient methodsFor: 'private protocol' stamp: 'mir 11/14/2002 16:21'!
lookForCode: code ifDifferent: handleBlock
	"We are expecting a certain code next."

	self fetchNextResponse.

	self responseCode == code
		ifFalse: [handleBlock value: self lastResponse]
! !


!TelnetProtocolClient methodsFor: 'private testing' stamp: 'mir 2/22/2002 17:35'!
responseIsContinuation
	^(self lastResponse size > 3
		and: [(self lastResponse at: 4) == $-])! !

!TelnetProtocolClient methodsFor: 'private testing' stamp: 'mir 11/14/2002 16:18'!
responseIsContinuation: response
	^(response size > 3
		and: [(response at: 4) == $-])! !

!TelnetProtocolClient methodsFor: 'private testing' stamp: 'mir 2/22/2002 17:35'!
responseIsError
	^self responseCode between: 500 and: 599! !

!TelnetProtocolClient methodsFor: 'private testing' stamp: 'mir 2/22/2002 17:35'!
responseIsWarning
	^self responseCode between: 400 and: 499! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TelnetProtocolClient class
	instanceVariableNames: ''!

!TelnetProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/21/2002 17:21'!
rawResponseCodes
	self subclassResponsibility! !
ProtocolClientError subclass: #TelnetProtocolError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!TelnetProtocolError commentStamp: 'mir 5/12/2003 18:07' prior: 0!
Abstract super class for exceptions signalled by clients based on the telnet protocol.
!


!TelnetProtocolError methodsFor: 'accessing' stamp: 'mir 4/7/2003 16:47'!
code
	^self protocolInstance responseCode! !


!TelnetProtocolError methodsFor: 'private' stamp: 'len 12/14/2002 14:15'!
isCommandUnrecognized
	^ self code = 500! !
VariableNode subclass: #TempVariableNode
	instanceVariableNames: 'isAnArg hasRefs hasDefs scope'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!TempVariableNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a temporary variable!


!TempVariableNode methodsFor: 'initialize-release'!
isArg: aBoolean

	isAnArg _ aBoolean.
	isAnArg ifTrue: [hasDefs _ true]! !

!TempVariableNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:57'!
name: varName index: i type: type scope: level
	"Only used for initting temporary variables"
	self name: varName.
	self key: varName
		index: i
		type: type.
	self isArg: (hasDefs _ hasRefs _ false).
	self scope: level! !

!TempVariableNode methodsFor: 'initialize-release'!
nowHasDef
	hasDefs _ true! !

!TempVariableNode methodsFor: 'initialize-release'!
nowHasRef
	hasRefs _ true! !

!TempVariableNode methodsFor: 'initialize-release'!
scope: level
	"Note scope of temporary variables.
	Currently only the following distinctions are made:
		0	outer level: args and user-declared temps
		1	block args and doLimiT temps
		-1	a block temp that is no longer active
		-2	a block temp that held limit of to:do:"
	scope _ level! !


!TempVariableNode methodsFor: 'printing' stamp: 'ab 7/13/2004 13:54'!
printOn: aStream indent: level 
	aStream withStyleFor: #temporaryVariable
			do: [aStream nextPutAll: self name]! !


!TempVariableNode methodsFor: 'testing' stamp: 'ab 7/13/2004 13:56'!
assignmentCheck: encoder at: location

	self isArg ifTrue: [^ location]
			ifFalse: [^ -1]! !

!TempVariableNode methodsFor: 'testing'!
isArg
	^ isAnArg! !

!TempVariableNode methodsFor: 'testing'!
isTemp
	^ true! !

!TempVariableNode methodsFor: 'testing'!
isUndefTemp
	^ hasDefs not! !

!TempVariableNode methodsFor: 'testing'!
isUnusedTemp
	^ hasRefs not! !

!TempVariableNode methodsFor: 'testing'!
scope
	^ scope! !


!TempVariableNode methodsFor: '*eToys-tiles' stamp: 'ab 7/13/2004 13:54'!
asMorphicSyntaxIn: parent

	^ parent addToken: self name type: #tempVariable on: self! !

!TempVariableNode methodsFor: '*eToys-tiles' stamp: 'ab 7/13/2004 13:54'!
explanation

	^(self isArg ifTrue: ['Method argument'] ifFalse: ['Temporary variable']),' <',self name,'>'
! !
AbstractScoreEvent subclass: #TempoEvent
	instanceVariableNames: 'tempo'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!TempoEvent commentStamp: '<historical>' prior: 0!
Represents a tempo change in a MIDI score.
!


!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 12/30/97 10:10'!
isTempoEvent

	^ true
! !

!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 9/10/1998 08:37'!
printOn: aStream

	aStream nextPut: $(.
	time printOn: aStream.
	aStream nextPutAll: ': tempo '.
	((120.0 * (500000.0 / tempo)) roundTo: 0.01) printOn: aStream.
	aStream nextPut: $).
! !

!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 12/30/97 10:09'!
tempo

	^ tempo
! !

!TempoEvent methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
tempo: anInteger

	tempo := anInteger.
! !
StarSqueakTurtle subclass: #TermiteTurtle
	instanceVariableNames: 'isCarryingChip'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!TermiteTurtle methodsFor: 'demons' stamp: 'jm 1/24/2001 08:20'!
lookForChip
	"If this terminte is not carrying a chip and there is a chip at the current location, pick up the chip. To minimize the chance of immediately enountering the same chip pile, turn around and take one step in the the opposite direction."

	(isCarryingChip not and:
	 [(self get: 'woodChips') > 0]) ifTrue: [
		self pickUpChip.
		self turnRight: 180.
		self forward: 1].
! !

!TermiteTurtle methodsFor: 'demons' stamp: 'jm 1/24/2001 08:23'!
lookForPile
	"If I am carrying a chip and there is a chip at the current location, drop the chip I'm carrying. To minimize the chance of immediately enountering the same chip pile, turn around and take one step in the the opposite direction."

	(isCarryingChip and:
	 [(self get: 'woodChips') > 0]) ifTrue: [
		self putDownChip.
		self turnRight: 180.
		self forward: 1].
! !

!TermiteTurtle methodsFor: 'demons' stamp: 'sd 11/20/2005 21:26'!
pickUpChip
	"Pick up a wood chip from the current patch."

	self increment: 'woodChips' by: -1.
	isCarryingChip := true.
	self color: Color red.

! !

!TermiteTurtle methodsFor: 'demons' stamp: 'sd 11/20/2005 21:26'!
putDownChip
	"Drop the wood chip I'm carrying on the current patch."

	self increment: 'woodChips' by: 1.
	isCarryingChip := false.
	self color: Color blue.

! !

!TermiteTurtle methodsFor: 'demons' stamp: 'jm 1/24/2001 08:11'!
walk

	self forward: 1.
! !

!TermiteTurtle methodsFor: 'demons' stamp: 'jm 1/24/2001 08:12'!
wiggle

	self turnRight: (self random: 50).
	self turnLeft: (self random: 50).
! !


!TermiteTurtle methodsFor: 'variables' stamp: 'jm 1/24/2001 08:28'!
isCarryingChip

	^ isCarryingChip

! !

!TermiteTurtle methodsFor: 'variables' stamp: 'sd 11/20/2005 21:26'!
isCarryingChip: aBoolean

	isCarryingChip := aBoolean.
! !
Object subclass: #TestCase
	instanceVariableNames: 'testSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Kernel'!
!TestCase commentStamp: '<historical>' prior: 0!
A TestCase is a Command representing the future running of a test case. Create one with the class method #selector: aSymbol, passing the name of the method to be run when the test case runs.

When you discover a new fixture, subclass TestCase, declare instance variables for the objects in the fixture, override #setUp to initialize the variables, and possibly override# tearDown to deallocate any external resources allocated in #setUp.

When you are writing a test case method, send #assert: aBoolean when you want to check for an expected value. For example, you might say "self assert: socket isOpen" to test whether or not a socket is open at a point in a test.!


!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 10:59'!
assert: aBooleanOrBlock

	aBooleanOrBlock value ifFalse: [self signalFailure: 'Assertion failed']
			! !

!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'!
assert: aBooleanOrBlock description: aString
	aBooleanOrBlock value ifFalse: [
		self logFailure: aString.
		TestResult failure signal: aString]
			! !

!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'!
assert: aBooleanOrBlock description: aString resumable: resumableBoolean 
	| exception |
	aBooleanOrBlock value
		ifFalse: 
			[self logFailure: aString.
			exception := resumableBoolean
						ifTrue: [TestResult resumableFailure]
						ifFalse: [TestResult failure].
			exception signal: aString]
			! !

!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'!
deny: aBooleanOrBlock

	self assert: aBooleanOrBlock value not
			! !

!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'!
deny: aBooleanOrBlock description: aString
	self assert: aBooleanOrBlock value not description: aString
			! !

!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'!
deny: aBooleanOrBlock description: aString resumable: resumableBoolean 
	self
		assert: aBooleanOrBlock value not
		description: aString
		resumable: resumableBoolean
			! !

!TestCase methodsFor: 'accessing'!
resources
	| allResources resourceQueue |
	allResources := Set new.
	resourceQueue := OrderedCollection new.
	resourceQueue addAll: self class resources.
	[resourceQueue isEmpty] whileFalse: [
		| next |
		next := resourceQueue removeFirst.
		allResources add: next.
		resourceQueue addAll: next resources].
	^allResources
			! !

!TestCase methodsFor: 'accessing'!
selector
	^testSelector
			! !

!TestCase methodsFor: 'accessing'!
should: aBlock
	self assert: aBlock value
			! !

!TestCase methodsFor: 'accessing'!
should: aBlock description: aString
	self assert: aBlock value description: aString
			! !

!TestCase methodsFor: 'accessing'!
should: aBlock raise: anExceptionalEvent 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
			! !

!TestCase methodsFor: 'accessing'!
should: aBlock raise: anExceptionalEvent description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
		description: aString
			! !

!TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:32'!
should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString)
		description: aString
! !

!TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:24'!
should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString)
		description: aString
! !

!TestCase methodsFor: 'accessing'!
shouldnt: aBlock
	self deny: aBlock value
			! !

!TestCase methodsFor: 'accessing'!
shouldnt: aBlock description: aString
	self deny: aBlock value description: aString
			! !

!TestCase methodsFor: 'accessing'!
shouldnt: aBlock raise: anExceptionalEvent 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not
			! !

!TestCase methodsFor: 'accessing'!
shouldnt: aBlock raise: anExceptionalEvent description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not 		description: aString
			! !

!TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:34'!
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) not
		description: aString
! !

!TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:34'!
shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) not
		description: aString
! !

!TestCase methodsFor: 'accessing' stamp: 'md 2/22/2006 14:26'!
signalFailure: aString
	TestResult failure signal: aString! !


!TestCase methodsFor: 'dependencies'!
addDependentToHierachy: anObject 
	"an empty method. for Composite compability with TestSuite"


			! !

!TestCase methodsFor: 'dependencies'!
removeDependentFromHierachy: anObject 
	"an empty method. for Composite compability with TestSuite"


			! !


!TestCase methodsFor: 'printing'!
printOn: aStream

	aStream
		nextPutAll: self class printString;
		nextPutAll: '>>#';
		nextPutAll: testSelector
			! !


!TestCase methodsFor: 'running' stamp: 'md 2/22/2006 14:27'!
debug
	self resources do: [:res | 
		res isAvailable ifFalse: [^res signalInitializationError]].
	[(self class selector: testSelector) runCase] 
		ensure: [self resources do: [:each | each reset]]
			! !

!TestCase methodsFor: 'running' stamp: 'bp 11/15/2004 18:13'!
debugAsFailure
	| semaphore |
	semaphore := Semaphore new.
	self resources do: [:res | 
		res isAvailable ifFalse: [^res signalInitializationError]].
	[semaphore wait. self resources do: [:each | each reset]] fork.
	(self class selector: testSelector) runCaseAsFailure: semaphore.! !

!TestCase methodsFor: 'running' stamp: 'md 2/22/2006 14:17'!
failureLog	
	^Transcript

			! !

!TestCase methodsFor: 'running'!
isLogging
	"By default, we're not logging failures. If you override this in 
	a subclass, make sure that you override #failureLog"
	^false
			! !

!TestCase methodsFor: 'running'!
logFailure: aString
	self isLogging ifTrue: [
		self failureLog 
			cr; 
			nextPutAll: aString; 
			flush]
			! !

!TestCase methodsFor: 'running' stamp: 'bp 11/15/2004 18:17'!
openDebuggerOnFailingTestMethod
	"SUnit has halted one step in front of the failing test method. Step over the 'self halt' and 
	 send into 'self perform: testSelector' to see the failure from the beginning"

	self
		halt;
		performTest! !

!TestCase methodsFor: 'running'!
run
	| result |
	result := TestResult new.
	self run: result.
	^result
			! !

!TestCase methodsFor: 'running'!
run: aResult
	aResult runCase: self
			! !

!TestCase methodsFor: 'running' stamp: 'md 2/22/2006 14:27'!
runCase

	[self setUp.
	self performTest] ensure: [self tearDown]
			! !

!TestCase methodsFor: 'running' stamp: 'md 2/22/2006 14:27'!
runCaseAsFailure: aSemaphore
	[self setUp.
	self openDebuggerOnFailingTestMethod] ensure: [
		self tearDown.
		aSemaphore signal]! !

!TestCase methodsFor: 'running'!
setUp
			! !

!TestCase methodsFor: 'running'!
tearDown
			! !


!TestCase methodsFor: 'testing' stamp: 'JF 7/30/2003 13:40'!
expectedFailures
	^ Array new! !

!TestCase methodsFor: 'testing' stamp: 'JF 7/30/2003 13:39'!
shouldPass
	"Unless the selector is in the list we get from #expectedFailures, we expect it to pass"
	^ (self expectedFailures includes: testSelector) not! !


!TestCase methodsFor: 'private' stamp: 'md 2/22/2006 14:27'!
executeShould: aBlock inScopeOf: anExceptionalEvent 
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: true]
			! !

!TestCase methodsFor: 'private' stamp: 'md 2/22/2006 14:27'!
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: (ex description includesSubString: aString) ]
			! !

!TestCase methodsFor: 'private' stamp: 'md 2/22/2006 14:27'!
executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString
	^[aBlock value.
 	false] on: anExceptionalEvent
		do: [:ex | ex return: (ex description includesSubString: aString) not ]
			! !

!TestCase methodsFor: 'private' stamp: 'md 2/22/2006 14:22'!
performTest

	self perform: testSelector asSymbol
			! !

!TestCase methodsFor: 'private'!
setTestSelector: aSymbol
	testSelector := aSymbol
			! !


!TestCase methodsFor: 'extensions' stamp: 'mx 3/20/2006 23:32'!
executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock

	^[aBlock value.
 	false] 
		on: anException
		do: [:exception | 
			anotherBlock value: exception.
			exception return: true]! !

!TestCase methodsFor: 'extensions' stamp: 'mx 3/13/2006 23:21'!
fail

	^self assert: false! !

!TestCase methodsFor: 'extensions' stamp: 'md 8/2/2006 11:09'!
should: aBlock notTakeMoreThan: aDuration
    "Evaluate aBlock in a forked process and if it takes more than anInteger milliseconds
    to run we terminate the process and report a test failure.  It'' important to
    use the active process for the test failure so that the failure reporting works correctly
    in the context of the exception handlers."

    | evaluated evaluationProcess result delay testProcess |

    evaluated := false.
    delay := Delay forDuration: aDuration.
    testProcess := Processor activeProcess.
    "Create a new process to evaluate aBlock"
    evaluationProcess := [
        result := aBlock value.
        evaluated := true.
        delay unschedule.
        testProcess resume ] forkNamed: 'Process to evaluate should: notTakeMoreThanMilliseconds:'.

    "Wait the milliseconds they asked me to"
    delay wait.
    "After this point either aBlock was evaluated or not..."
    evaluated ifFalse: [
        evaluationProcess terminate.
        self assert: false description: ('Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration)].
   
    ^result! !

!TestCase methodsFor: 'extensions' stamp: 'mx 3/20/2006 21:29'!
shouldFix: aBlock 

	^self should: aBlock raise: Exception! !

!TestCase methodsFor: 'extensions' stamp: 'md 8/2/2006 11:08'!
should: aBlock notTakeMoreThanMilliseconds: anInteger
    "For compatibility with other Smalltalks"

   self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! !

!TestCase methodsFor: 'extensions' stamp: 'mx 3/20/2006 23:52'!
should: aBlock raise: anException withExceptionDo: anotherBlock 

	^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestCase class
	instanceVariableNames: ''!

!TestCase class methodsFor: 'accessing' stamp: 'md 2/22/2006 14:28'!
allTestSelectors

	^self allSelectors asSortedCollection asOrderedCollection select: [:each | 
		('test*' match: each) and: [each numArgs isZero]]
			! !

!TestCase class methodsFor: 'accessing'!
resources

	^#()
			! !

!TestCase class methodsFor: 'accessing'!
sunitVersion
	^'3.1'
			! !

!TestCase class methodsFor: 'accessing' stamp: 'md 2/22/2006 14:29'!
testSelectors 

	^self selectors asSortedCollection asOrderedCollection select: [:each | 
		('test*' match: each) and: [each numArgs isZero]]
			! !


!TestCase class methodsFor: 'building suites' stamp: 'stephaneducasse 2/3/2006 22:41'!
addTestsFor: classNameString toSuite: suite

	| cls  |
	cls := Smalltalk at: classNameString ifAbsent: [ ^suite ].
	^cls isAbstract 
		ifTrue:  [
			cls allSubclasses do: [ :each |
				each isAbstract ifFalse: [
					each addToSuiteFromSelectors: suite ] ].
			suite]
		ifFalse: [ cls addToSuiteFromSelectors: suite ]
! !

!TestCase class methodsFor: 'building suites' stamp: 'nk 4/21/2002 16:37'!
addToSuiteFromSelectors: suite
	^self addToSuite: suite fromMethods: (self shouldInheritSelectors
		ifTrue: [ self allTestSelectors ]
		ifFalse: [self testSelectors ])! !

!TestCase class methodsFor: 'building suites' stamp: 'nk 4/21/2002 10:51'!
addToSuite: suite fromMethods: testMethods 
	testMethods do:  [ :selector | 
			suite addTest: (self selector: selector) ].
	^suite! !

!TestCase class methodsFor: 'building suites' stamp: 'stephaneducasse 2/3/2006 22:41'!
buildSuite
	| suite |
	suite := TestSuite new.
	^ self isAbstract
		ifTrue: [
			suite name: self name asString.
			self allSubclasses
				do: [:each | each isAbstract
						ifFalse: [each addToSuiteFromSelectors: suite]].
			suite]
		ifFalse: [self addToSuiteFromSelectors: suite]! !

!TestCase class methodsFor: 'building suites'!
buildSuiteFromAllSelectors

	^self buildSuiteFromMethods: self allTestSelectors
			! !

!TestCase class methodsFor: 'building suites'!
buildSuiteFromLocalSelectors

	^self buildSuiteFromMethods: self testSelectors
			! !

!TestCase class methodsFor: 'building suites' stamp: 'stephaneducasse 2/3/2006 22:41'!
buildSuiteFromMethods: testMethods 
	| suite |
	suite := (TestSuite new)
				name: self name asString;
				yourself.
	^self addToSuite: suite fromMethods: testMethods! !

!TestCase class methodsFor: 'building suites'!
buildSuiteFromSelectors

	^self shouldInheritSelectors
		ifTrue: [self buildSuiteFromAllSelectors]
		ifFalse: [self buildSuiteFromLocalSelectors]
			! !

!TestCase class methodsFor: 'building suites'!
suiteClass
	^TestSuite
			! !


!TestCase class methodsFor: 'instance creation'!
debug: aSymbol

	^(self selector: aSymbol) debug
			! !

!TestCase class methodsFor: 'instance creation'!
run: aSymbol

	^(self selector: aSymbol) run
			! !

!TestCase class methodsFor: 'instance creation'!
selector: aSymbol

	^self new setTestSelector: aSymbol
			! !

!TestCase class methodsFor: 'instance creation'!
suite

	^self buildSuite
			! !


!TestCase class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'!
isAbstract
	"Override to true if a TestCase subclass is Abstract and should not have
	TestCase instances built from it"

	^self name = #TestCase
			! !

!TestCase class methodsFor: 'testing'!
shouldInheritSelectors
	"I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass.  If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass."

	^self superclass isAbstract
		or: [self testSelectors isEmpty]

"$QA Ignore:Sends system method(superclass)$"
			! !
ClickExerciser subclass: #TestClickExerciser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!TestClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/26/2005 00:48'!
alternateColor
"answer the alternate color/fill style for the receiver"
	^ Color magenta! !

!TestClickExerciser methodsFor: 'accessing' stamp: 'wiz 8/26/2005 00:49'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color orange! !


!TestClickExerciser methodsFor: 'event handling' stamp: 'wiz 8/23/2005 13:21'!
mouseDown: evt
	"Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched"
	
	Preferences enable: #NewClickTest .
	evt hand
		waitForClicksOrDrag: self
		event: evt
		selectors: self selectors
		threshold: 10! !
Exception subclass: #TestFailure
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Kernel'!
!TestFailure commentStamp: '<historical>' prior: 0!
Signaled in case of a failed test (failure). The test framework distinguishes between failures and errors. A failure is anticipated and checked for with assertions. Errors are unanticipated problems like a division by 0 or an index out of bounds ...!


!TestFailure methodsFor: 'camp smalltalk' stamp: 'ajh 1/24/2003 19:23'!
defaultAction

	Processor activeProcess
		debug: self signalerContext
		title: self description! !

!TestFailure methodsFor: 'camp smalltalk' stamp: 'ajh 2/1/2003 00:58'!
isResumable
	
	^ false! !
Morph subclass: #TestInWorldMorph
	instanceVariableNames: 'intoWorldCount outOfWorldCount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Kernel'!
!TestInWorldMorph commentStamp: 'sd 6/5/2005 10:25' prior: 0!
Helper class for MorphTest!


!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:06'!
initialize
	super initialize.
	outOfWorldCount := intoWorldCount := 0.! !

!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:03'!
intoWorld: aWorld
	aWorld ifNil:[^self].
	super intoWorld: aWorld.
	intoWorldCount := intoWorldCount + 1.
! !

!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:06'!
intoWorldCount
	^intoWorldCount! !

!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:03'!
outOfWorld: aWorld
	aWorld ifNil:[^self].
	super outOfWorld: aWorld.
	outOfWorldCount := outOfWorldCount + 1.
! !

!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:06'!
outOfWorldCount
	^outOfWorldCount! !
TestCase subclass: #TestIndenting
	instanceVariableNames: 'para'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support-Tests'!

!TestIndenting methodsFor: 'running' stamp: 'hmm 2/2/2001 14:29'!
setUp
	| text |
	text _ 'p	' asText, (Text string: 'word word' attribute: (TextIndent tabs: 1)).
	para _ text asParagraph! !


!TestIndenting methodsFor: 'testing' stamp: 'hmm 2/2/2001 14:42'!
testBreak1
	"Checks whether the beginning of a new line starts at the indented position"
	| cb |
	para compositionRectangle: (0@0 extent: para width - 1@100); updateCompositionHeight.
	para clippingRectangle: (0@0 extent: 200@200).
	cb := para characterBlockForIndex: 8.
	self assert: cb top > 0.
	self assert: cb left = 24! !

!TestIndenting methodsFor: 'testing' stamp: 'hmm 2/2/2001 14:45'!
testBreak2
	"When an indented line is broken at a space, the character block must still lie in the line crossing the right margin."
	| cb |
	para compositionRectangle: (0@0 extent: para width - 24 // 2 + 24@100); updateCompositionHeight.
	para clippingRectangle: (0@0 extent: 200@200).
	cb := para characterBlockForIndex: 7.
	self assert: cb top = 0.
	self assert: cb left >= 24! !

!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 17:14'!
testBreakAtSpaceLeavesSpaceOnOriginalLine
	"When an indented line is broken at a space, the character block must still lie in the line crossing the right margin."
	| cb |
	para compositionRectangle: (0@0 extent: para width - 24 @100); updateCompositionHeight.
	para clippingRectangle: (0@0 extent: 200@200).
	cb := para characterBlockForIndex: 7.
	self assert: cb top = 0.
	self assert: cb left >= 24! !

!TestIndenting methodsFor: 'testing' stamp: 'hmm 2/2/2001 14:41'!
testCR
	"Checks whether the beginning of a new line starts at the indented position"
	| cb |
	para replaceFrom: 7 to: 7 with: (String with: Character cr) displaying: false.
	para clippingRectangle: (0@0 extent: 200@200).
	cb := para characterBlockForIndex: 8.
	self assert: cb top > 0.
	self assert: cb left = 24! !

!TestIndenting methodsFor: 'testing' stamp: 'hmm 2/2/2001 14:41'!
testCR2
	"Checks whether the drawing of indented text is really indented..."
	| cb |
	para replaceFrom: 7 to: 7 with: (String with: Character cr) displaying: false.
	para clippingRectangle: (0@0 extent: 200@200).
	cb := para characterBlockForIndex: 8.
	self assert: (para asForm copy: (0@cb top extent: 24@cb height)) isAllWhite! !

!TestIndenting methodsFor: 'testing' stamp: 'hmm 2/2/2001 15:17'!
testCR3
	"Checks whether the beginning of a new line starts at the indented position"
	| cb |
	para replaceFrom: 11 to: 11 with: (Text string: (String with: Character cr) attribute: (TextIndent tabs: 1)) displaying: false.
	para clippingRectangle: (0@0 extent: 200@200).
	cb := para characterBlockForIndex: 12.
	self assert: cb top > 0.
	self assert: cb left = 24! !

!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 16:52'!
testNewLineAndTabProvidesDoubleIndent
	"Checks whether the beginning of a new line starts at the indented position"
	| cb |
	para replaceFrom: 11 to: 11 with: (Text string: (String with: Character cr) attribute: (TextIndent tabs: 1)) displaying: false.
 
	cb := para characterBlockForIndex: 12.
	self assert: cb top > 0.
	self assert: cb left = 24! !

!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 16:52'!
testNewLineLeaveSpacesOnOldLine
	"Checks whether the drawing of indented text is really indented..."
	| cb |
	para replaceFrom: 7 to: 7 with: (String with: Character cr) displaying: false.

	cb := para characterBlockForIndex: 8.
	self assert: (para asForm copy: (0@cb top extent: 24@cb height)) isAllWhite! !

!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 16:53'!
testNewLineStartsIndented
	"Checks whether the beginning of a new line starts at the indented position"
	| cb |
	para replaceFrom: 7 to: 7 with: (String with: Character cr) displaying: false.
 
	cb := para characterBlockForIndex: 8.
	self assert: cb top > 0.
	self assert: cb left = 24! !

!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 17:11'!
testNewLineStartsIndentedWhenWrapped
	"Checks whether the beginning of a new line starts at the indented position"
	| cb |
	para compositionRectangle: (0@0 extent: para width - 20@100); updateCompositionHeight.
	para clippingRectangle: (0@0 extent: 200@200).
	cb := para characterBlockForIndex: 8.
	self assert: cb top > 0.
	self assert: cb left = 24! !

!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 16:36'!
testSetUp
	"just reminding us all what the paragraph looks like to begin with. assuming Accuny12 font "
	| cb |

	
	cb := para characterBlockForIndex: 1.  "p"
	self assert: cb top = 0.
	self assert: cb left = 0.
	self assert: cb right = 7.
	
	
	cb := para characterBlockForIndex: 2.  "the tab"
	self assert: cb top = 0.
	self assert: cb left = 7.
	self assert: cb right = 24.

	
	cb := para characterBlockForIndex: 3.  "w" 
	self assert: cb top = 0.
	self assert: cb left = 24.
	self assert: cb right = 34.
	
	cb := para characterBlockForIndex: 7.  " " "between word and word"
	self assert: cb top = 0.
	self assert: cb left = 52.
	self assert: cb right = 57.
	
	cb := para characterBlockForIndex: 11.  "d" "last char"
	self assert: cb top = 0.
	self assert: cb left = 79.
	self assert: cb right = 85.
	
		
! !
TestParagraphFix subclass: #TestNewParagraphFix
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support-Tests'!
!TestNewParagraphFix commentStamp: '<historical>' prior: 0!
This class tests the same things as its superclass, but for NewParagraph which is used in the Morphic environment.!


!TestNewParagraphFix methodsFor: 'running' stamp: 'hmm 10/1/2000 17:41'!
setUp
	| morph |
	morph _ TextMorph new contents: 'i i'.
	morph fit.
	para _ morph paragraph! !


!TestNewParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 17:42'!
testCharacterBlockAfterReplacingAll
	^super testCharacterBlockAfterReplacingAll! !

!TestNewParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 17:42'!
testCharacterBlockAfterReplacingOther
	^super testCharacterBlockAfterReplacingOther! !

!TestNewParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 17:42'!
testCharacterBlockAfterReplacingSpace
	^super testCharacterBlockAfterReplacingSpace! !

!TestNewParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 17:43'!
testCharacterBlockNormal
	^super testCharacterBlockNormal! !
TestCase subclass: #TestObjectsAsMethods
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-ObjectsAsMethods'!

!TestObjectsAsMethods methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 19:35'!
testAddNumbers 
"self debug: #testAddNumbers"
	"md: I had to comment out the error... did strange things"
	self class addSelector: #add:with: withMethod: ObjectsAsMethodsExample new.
	self assert: (self add: 3 with: 4) = 7.
	"self assert: (self perform: #add:with: withArguments: #(3 4)) = 7. "
	self class basicRemoveSelector: #add:with:.! !

!TestObjectsAsMethods methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 19:35'!
testAnswer42 
	self class addSelector: #answer42 withMethod: ObjectsAsMethodsExample new.
	self assert: self answer42 = 42.
	self class basicRemoveSelector: #answer42.! !

!TestObjectsAsMethods methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 19:35'!
testDNU 
	self class addSelector: #answer42 withMethod: AbstractObjectsAsMethod new.
	self should: [self answer42] raise: MessageNotUnderstood.
	self class basicRemoveSelector: #answer42.! !
TestCase subclass: #TestParagraphFix
	instanceVariableNames: 'para'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support-Tests'!
!TestParagraphFix commentStamp: '<historical>' prior: 0!
This class tests whether locating characters past the end of a text is possible in all cases.!


!TestParagraphFix methodsFor: 'running' stamp: 'hmm 10/1/2000 15:05'!
setUp
	para _ 'i i' asParagraph! !


!TestParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 15:52'!
testCharacterBlockAfterReplacingAll
	para replaceFrom: 1 to: 3 with: 'mmm' displaying: false.
	self assert: (para characterBlockForIndex: 4) stringIndex = 4! !

!TestParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 15:05'!
testCharacterBlockAfterReplacingOther
	para replaceFrom: 3 to: 3 with: 'm' displaying: false.
	self assert: (para characterBlockForIndex: 4) stringIndex = 4! !

!TestParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 15:05'!
testCharacterBlockAfterReplacingSpace
	para replaceFrom: 3 to: 3 with: ' ' displaying: false.
	self assert: (para characterBlockForIndex: 4) stringIndex = 4! !

!TestParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 15:05'!
testCharacterBlockNormal
	self assert: (para characterBlockForIndex: 4) stringIndex = 4! !
Object subclass: #TestResource
	instanceVariableNames: 'name description'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Kernel'!

!TestResource methodsFor: 'accessing'!
description

	description isNil
		ifTrue: [^''].

	^description
			! !

!TestResource methodsFor: 'accessing'!
description: aString

	description := aString
			! !

!TestResource methodsFor: 'accessing'!
name

	name isNil
		ifTrue: [^self printString].

	^name
			! !

!TestResource methodsFor: 'accessing'!
name: aString

	name := aString
			! !

!TestResource methodsFor: 'accessing'!
resources
	^self class resources
			! !


!TestResource methodsFor: 'initializing'!
initialize
	self setUp

			! !


!TestResource methodsFor: 'printing'!
printOn: aStream

	aStream nextPutAll: self class printString
			! !


!TestResource methodsFor: 'running'!
setUp
	"Does nothing. Subclasses should override this
	to initialize their resource"
			! !

!TestResource methodsFor: 'running'!
signalInitializationError
	^self class signalInitializationError
			! !

!TestResource methodsFor: 'running'!
tearDown
	"Does nothing. Subclasses should override this
	to tear down their resource"
			! !


!TestResource methodsFor: 'testing'!
isAvailable
	"override to provide information on the
	readiness of the resource"
	
	^true
			! !

!TestResource methodsFor: 'testing'!
isUnavailable
	"override to provide information on the
	readiness of the resource"
	
	^self isAvailable not
			! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestResource class
	instanceVariableNames: 'current'!

!TestResource class methodsFor: 'accessing'!
current

	current isNil
		ifTrue: [current := self new].

	^current
			! !

!TestResource class methodsFor: 'accessing'!
current: aTestResource

	current := aTestResource
			! !

!TestResource class methodsFor: 'accessing'!
resources
	^#()
			! !


!TestResource class methodsFor: 'creation'!
reset

	current notNil ifTrue: [
		[current tearDown] ensure: [
			current := nil]]
			! !

!TestResource class methodsFor: 'creation'!
signalInitializationError
	^TestResult signalErrorWith: 'Resource ' , self name , ' could not be initialized'
			! !


!TestResource class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'!
isAbstract
	"Override to true if a TestResource subclass is Abstract and should not have
	TestCase instances built from it"

	^self name = #TestResource
			! !

!TestResource class methodsFor: 'testing'!
isAvailable
	^self current notNil and: [self current isAvailable]
			! !

!TestResource class methodsFor: 'testing'!
isUnavailable

	^self isAvailable not
			! !
Object subclass: #TestResult
	instanceVariableNames: 'failures errors passed'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Kernel'!
!TestResult commentStamp: '<historical>' prior: 0!
This is a Collecting Parameter for the running of a bunch of tests. TestResult is an interesting object to subclass or substitute. #runCase: is the external protocol you need to reproduce. Kent has seen TestResults that recorded coverage information and that sent email when they were done.!


!TestResult methodsFor: 'accessing'!
correctCount
	"depreciated - use #passedCount"

	^self passedCount
			! !

!TestResult methodsFor: 'accessing'!
defects
	^OrderedCollection new
		addAll: self errors;
		addAll: self failures; yourself
			! !

!TestResult methodsFor: 'accessing'!
errorCount

	^self errors size
			! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'!
expectedDefectCount
	^ self expectedDefects size! !

!TestResult methodsFor: 'accessing' stamp: 'md 11/25/2004 16:36'!
expectedDefects
	^ (errors, failures asOrderedCollection) select: [:each | each shouldPass not] ! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'!
expectedPassCount
	^ self expectedPasses size! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'!
expectedPasses
	^ passed select: [:each | each shouldPass] ! !

!TestResult methodsFor: 'accessing'!
failureCount

	^self failures size
			! !

!TestResult methodsFor: 'accessing'!
passedCount

	^self passed size
			! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:07'!
runCount
	^ passed size + failures size + errors size! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:06'!
tests
	^(OrderedCollection new: self runCount)
		addAll: passed;
		addAll: failures;
		addAll: errors;
		yourself! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'!
unexpectedErrorCount
	^ self unexpectedErrors size! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'!
unexpectedErrors
	^ errors select: [:each | each shouldPass] ! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'!
unexpectedFailureCount
	^ self unexpectedFailures size! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'!
unexpectedFailures
	^ failures select: [:each | each shouldPass] ! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'!
unexpectedPassCount
	^ self unexpectedPasses size! !

!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'!
unexpectedPasses
	^ passed select: [:each | each shouldPass not] ! !


!TestResult methodsFor: 'compatibility' stamp: 'JF 7/30/2003 16:09'!
errors
	^ self unexpectedErrors! !

!TestResult methodsFor: 'compatibility' stamp: 'md 11/25/2004 16:23'!
failures
	^ self unexpectedFailures, self unexpectedPasses ! !

!TestResult methodsFor: 'compatibility' stamp: 'JF 7/30/2003 16:08'!
passed
	^ self expectedPasses, self expectedDefects! !


!TestResult methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/3/2006 22:41'!
initialize
	passed := OrderedCollection new.
	failures := Set new.
	errors := OrderedCollection new.! !


!TestResult methodsFor: 'printing' stamp: 'JF 7/30/2003 16:15'!
printOn: aStream
	aStream
		nextPutAll: self runCount printString;
		nextPutAll: ' run, ';
		nextPutAll: self expectedPassCount printString;
		nextPutAll: ' passes, ';
		nextPutAll: self expectedDefectCount printString;
		nextPutAll:' expected failures, ';
		nextPutAll: self unexpectedFailureCount printString;
		nextPutAll: ' failures, ';
		nextPutAll: self unexpectedErrorCount printString;
		nextPutAll:' errors, ';
		nextPutAll: self unexpectedPassCount printString;
		nextPutAll:' unexpected passes'.! !


!TestResult methodsFor: 'running' stamp: 'md 2/22/2006 14:27'!
runCase: aTestCase
	| testCasePassed |
	testCasePassed := true.
	[[aTestCase runCase] 
			on: self class failure
			do: 
				[:signal | 
				failures add: aTestCase.
				testCasePassed := false.
				signal return: false]]
					on: self class error
					do:
						[:signal |
						errors add: aTestCase.
						testCasePassed := false.
						signal return: false].
	testCasePassed ifTrue: [passed add: aTestCase]! !


!TestResult methodsFor: 'testing'!
hasErrors

	^self errors size > 0
			! !

!TestResult methodsFor: 'testing'!
hasFailures

	^self failures size > 0
			! !

!TestResult methodsFor: 'testing' stamp: 'JF 7/30/2003 14:04'!
hasPassed
	^self runCount = (self passedCount + self expectedDefectCount)! !

!TestResult methodsFor: 'testing'!
isError: aTestCase

	^self errors includes: aTestCase
			! !

!TestResult methodsFor: 'testing'!
isFailure: aTestCase
	^self failures includes: aTestCase
			! !

!TestResult methodsFor: 'testing'!
isPassed: aTestCase

	^self passed includes: aTestCase
			! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestResult class
	instanceVariableNames: ''!

!TestResult class methodsFor: 'exceptions'!
error
	^self exError
			! !

!TestResult class methodsFor: 'exceptions' stamp: 'md 2/22/2006 14:17'!
exError
	^Error
			! !

!TestResult class methodsFor: 'exceptions'!
failure
	^TestFailure
			! !

!TestResult class methodsFor: 'exceptions'!
resumableFailure
	^ResumableTestFailure
			! !

!TestResult class methodsFor: 'exceptions' stamp: 'md 2/22/2006 14:26'!
signalErrorWith: aString 
	self error signal: aString
			! !

!TestResult class methodsFor: 'exceptions' stamp: 'md 2/22/2006 14:26'!
signalFailureWith: aString 
	self failure signal: aString
			! !
Object subclass: #TestRunner
	instanceVariableNames: 'categories categoriesSelected classes classesSelected failedList failedSelected errorList errorSelected lastUpdate result'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnitGUI'!
!TestRunner commentStamp: '<historical>' prior: 0!
<lint: #ignore rule: #classNotReferenced rational: 'this view is only accessed from menus'>

!


!TestRunner methodsFor: 'accessing' stamp: 'lr 10/31/2005 15:31'!
baseClass
	^ TestCase! !

!TestRunner methodsFor: 'accessing' stamp: 'lr 11/3/2005 09:37'!
suiteAll
	^ TestSuite new in: [ :suite |
		classesSelected do: [ :each | 
			each isAbstract 
				ifFalse: [ each addToSuiteFromSelectors: suite ] ].
		suite name: (self label: 'Test' forSuite: suite) ].! !

!TestRunner methodsFor: 'accessing' stamp: 'lr 10/27/2005 10:29'!
suiteErrors
	^ TestSuite new in: [ :suite |
		suite 
			addTests: errorList; 
			name: (self label: 'Error' forSuite: suite) ].! !

!TestRunner methodsFor: 'accessing' stamp: 'lr 10/27/2005 10:42'!
suiteFailures
	^ TestSuite new in: [ :suite |
		suite 
			addTests: failedList; 
			name: (self label: 'Failure' forSuite: suite) ].! !


!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:09'!
categoryAt: anIndex
	^ categoriesSelected includes: (categories at: anIndex ifAbsent: [ ^ false ]).! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:51'!
categoryAt: anInteger put: aBoolean
	categoriesSelected := categoriesSelected
		perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ])
		with: (categories at: anInteger ifAbsent: [ ^ self ]).
	self changed: #categorySelected; updateClasses.! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:10'!
categoryList
	^ categories! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 11/1/2005 19:25'!
categoryMenu: aMenu
	^ aMenu
		title: 'Categories';
		add: 'Select all' action: #selectAllCategories;
		add: 'Select inversion' action: #selectInverseCategories;
		add: 'Select none' action: #selectNoCategories;
		addLine;
		add: 'Filter...' action: #filterCategories;
		addLine;
		add: 'Refresh' action: #updateCategories;
		yourself.! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:11'!
categorySelected
	^ 0! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:12'!
categorySelected: anInteger
	self changed: #categorySelected.! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 11/1/2005 19:27'!
filterCategories
	| pattern |
	pattern := UIManager default 
		request: 'Pattern to select categories:' 
		initialAnswer: '*'.
	pattern isNil ifTrue: [ ^ self ].
	categoriesSelected := (categories 
		select: [ :each | pattern match: each ]) asSet.
	self changed: #categorySelected; updateClasses.! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 11/1/2005 19:27'!
selectAllCategories
	categoriesSelected := categories asSet.
	self changed: #categorySelected; updateClasses.! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 11/1/2005 19:27'!
selectInverseCategories
	categoriesSelected := categories asSet 
		removeAll: categoriesSelected;
		yourself.
	self changed: #categorySelected; updateClasses.! !

!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 11/1/2005 19:27'!
selectNoCategories
	categoriesSelected := Set new.
	self changed: #categorySelected; updateClasses.! !


!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:36'!
browseReferencedClasses
	| references |
	references := classesSelected gather: [ :class |
		class methodDict values , class class methodDict values gather: [ :method |
			method literals
				select: [ :each | each isVariableBinding and: [ each value isBehavior ] ]
				thenCollect: [ :each | each value ] ] ].
	(self browserEnvironment new forClasses: references asSet)
		label: 'Referenced Classes';
		openEditor.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/10/2005 21:26'!
browseSentMessages
	| references |
	references := classesSelected gather: [ :class |
		class methodDict values , class class methodDict values gather: [ :method |
			(method literals copyWithoutAll: class allSelectors , class class allSelectors)
				select: [ :each | each isSymbol ] ] ].
	self systemNavigation
		browseAllImplementorsOfList: references asSet
		title: 'Sent Messages'.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:36'!
browseTestClasses
	(self browserEnvironment new forClasses: classesSelected asSet)
		label: 'Test Classes';
		openEditor.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 10/8/2005 19:58'!
classAt: anInteger
	^ classesSelected includes: (classes at: anInteger ifAbsent: [ ^ false ]).! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:19'!
classAt: anInteger put: aBoolean
	classesSelected := classesSelected
		perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ])
		with: (classes at: anInteger ifAbsent: [ ^ self ]).
	self changed: #classSelected; changed: #hasRunnable.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 10/10/2005 11:24'!
classList
	| offset ident |
	classes isEmpty ifTrue: [ ^ classes ].
	offset := classes first allSuperclasses size.
	^ classes collect: [ :each |
		ident := String 
			new: 2 * (0 max: each allSuperclasses size - offset) 
			withAll: $ .
		each isAbstract
			ifFalse: [ ident , each name ]
			ifTrue: [ 
				ident asText , each name asText 
					addAttribute: TextEmphasis italic;
					yourself ] ].! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:37'!
classMenu: aMenu
	| menu |
	menu := aMenu
		title: 'Classes';
		yourself.
	self browserEnvironment notNil ifTrue: [ 
		menu
			add: 'Browse classes' action: #browseTestClasses;
			add: 'Browse referenced classes' action: #browseReferencedClasses ].
	^ menu
		add: 'Browse sent messages' action: #browseSentMessages;
		addLine;
		add: 'Select all' action: #selectAllClasses;
		add: 'Select subclasses' action: #selectSubclasses;
		add: 'Select inversion' action: #selectInverseClasses;
		add: 'Select none' action: #selectNoClasses;
		addLine;
		add: 'Filter...' action: #filterClasses;
		addLine;
		add: 'Refresh' action: #updateClasses;
		yourself.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 10/8/2005 22:30'!
classSelected
	^ 0! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 10/8/2005 22:30'!
classSelected: anInteger
	self changed: #classSelected.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:20'!
filterClasses
	| pattern |
	pattern := UIManager default 
		request: 'Pattern to select tests:' 
		initialAnswer: '*'.
	pattern isNil ifTrue: [ ^ self ].
	classesSelected := (classes select: [ :each | 
		pattern match: each name ]) asSet.
	self changed: #classSelected; changed: #hasRunnable.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:20'!
selectAllClasses
	classesSelected := classes asSet.
	self changed: #classSelected; changed: #hasRunnable.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:20'!
selectInverseClasses
	classesSelected := classes asSet 
		removeAll: classesSelected;
		yourself.
	self changed: #classSelected; changed: #hasRunnable.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:20'!
selectNoClasses
	classesSelected := Set new.
	self changed: #classSelected; changed: #hasRunnable.! !

!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:26'!
selectSubclasses
	| classesForPackages |
	classesForPackages := self findClassesForCategories: categoriesSelected.	
	classesSelected := (classesSelected gather: [ :class |
		class withAllSubclasses select: [ :each |
			classesForPackages includes: each ] ])
		asSet.
	self changed: #classSelected; changed: #hasRunnable.! !


!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/8/2005 22:37'!
errorList
	^ errorList collect: [ :each | each printString ].! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/6/2005 19:46'!
errorSelected
	^ errorList indexOf: errorSelected.! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/27/2005 10:37'!
errorSelected: anInteger
	errorSelected := errorList at: anInteger ifAbsent: nil.
	self changed: #errorSelected.
	errorSelected ifNotNil: [ self debug: errorSelected ].! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/8/2005 22:37'!
failedList
	^ failedList collect: [ :each | each printString ].! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/6/2005 19:47'!
failedSelected
	^ failedList indexOf: failedSelected.! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/6/2005 20:14'!
failedSelected: anInteger
	failedSelected := failedList at: anInteger ifAbsent: nil.
	self changed: #failedSelected.
	failedSelected ifNotNil: [ self debug: failedSelected ].! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/6/2005 15:47'!
result
	^ result! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/8/2005 22:47'!
result: aResult
	result := aResult! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 11/1/2005 19:37'!
statusColor
	result hasPassed 
		ifTrue:[ ^ Color green ].
	result hasErrors 
		ifTrue: [ ^ Color red ].
	^ Color yellow.! !

!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/8/2005 22:45'!
statusText
	^ result printString.! !


!TestRunner methodsFor: 'accessing-ui' stamp: 'lr 1/20/2006 13:25'!
buttons
	^ #(( 'Run Selected' #runAll #hasRunnable )
		( 'Run Profiled' #runProfiled #hasRunnable )
		( 'Run Failures' #runFailures #hasFailures )
		( 'Run Errors' #runErrors #hasErrors )).! !

!TestRunner methodsFor: 'accessing-ui' stamp: 'lr 10/8/2005 18:39'!
extent
	^ 640 @ 480! !

!TestRunner methodsFor: 'accessing-ui' stamp: 'lr 1/20/2006 13:36'!
label
	^ 'Test Runner' ! !


!TestRunner methodsFor: 'actions' stamp: 'lr 10/31/2005 17:01'!
debugSuite: aTestSuite
	self basicRunSuite: aTestSuite do: [ :each | each debug ].! !

!TestRunner methodsFor: 'actions' stamp: 'lr 10/31/2005 17:42'!
debug: aTestCase
	self debugSuite: (TestSuite new
		addTest: aTestCase; 
		yourself).! !

!TestRunner methodsFor: 'actions' stamp: 'lr 10/8/2005 22:52'!
reset
	self result: TestResult new; updateResults.! !

!TestRunner methodsFor: 'actions' stamp: 'lr 10/20/2005 16:28'!
runAll
	self reset; runSuite: self suiteAll.! !

!TestRunner methodsFor: 'actions' stamp: 'lr 10/8/2005 23:02'!
runErrors
	self result instVarNamed: 'errors' put: OrderedCollection new.
	self runSuite: self suiteErrors.! !

!TestRunner methodsFor: 'actions' stamp: 'lr 10/27/2005 10:42'!
runFailures
	self result instVarNamed: 'failures' put: Set new.
	self runSuite: self suiteFailures.! !

!TestRunner methodsFor: 'actions' stamp: 'lr 10/31/2005 17:13'!
runProfiled
	MessageTally spyOn: [ self runAll ].! !

!TestRunner methodsFor: 'actions' stamp: 'lr 10/31/2005 17:00'!
runSuite: aTestSuite
	self basicRunSuite: aTestSuite do: [ :each | self runTest: each ].
	self updateResults.! !

!TestRunner methodsFor: 'actions' stamp: 'lr 11/3/2005 09:15'!
runTest: aTestCase
	aTestCase run: result.
	self updateStatus: true.! !


!TestRunner methodsFor: 'building' stamp: 'lr 11/21/2005 13:22'!
buildButtonsWith: aBuilder
	^ aBuilder pluggablePanelSpec new
		model: self;
		layout: #horizontal;
		children: (self buttons collect: [ :each |
			aBuilder pluggableButtonSpec new
				model: self; 
				label: each first;
				action: each second;
				enabled: each third;
				yourself ]);
		yourself.! !

!TestRunner methodsFor: 'building' stamp: 'lr 10/31/2005 15:12'!
buildCategoriesWith: aBuilder
	^ aBuilder pluggableMultiSelectionListSpec new
		model: self;
		list: #categoryList;
		menu: #categoryMenu:;
		getIndex: #categorySelected;
		setIndex: #categorySelected:;
		getSelectionList: #categoryAt:;
		setSelectionList: #categoryAt:put:;
		yourself.! !

!TestRunner methodsFor: 'building' stamp: 'lr 10/17/2005 09:13'!
buildClassesWith: aBuilder
	^ aBuilder pluggableMultiSelectionListSpec new
		model: self;
		list: #classList;
		menu: #classMenu:;
		getIndex: #classSelected;
		setIndex: #classSelected:;
		getSelectionList: #classAt:;
		setSelectionList: #classAt:put:;
		yourself.! !

!TestRunner methodsFor: 'building' stamp: 'lr 10/6/2005 19:39'!
buildErrorListWith: aBuilder
	^ aBuilder pluggableListSpec new
		model: self;
		name: 'Error List';
		list: #errorList; 
		getIndex: #errorSelected; 
		setIndex: #errorSelected:;
		yourself.! !

!TestRunner methodsFor: 'building' stamp: 'lr 10/6/2005 19:47'!
buildFailureListWith: aBuilder
	^ aBuilder pluggableListSpec new
		model: self;
		name: 'Failure List';
		list: #failedList; 
		getIndex: #failedSelected; 
		setIndex: #failedSelected:;
		yourself.! !

!TestRunner methodsFor: 'building' stamp: 'lr 10/8/2005 23:06'!
buildStatusWith: aBuilder
	^ aBuilder pluggableInputFieldSpec new
		model: self;
		color: #statusColor;
		getText: #statusText;
		yourself.! !

!TestRunner methodsFor: 'building' stamp: 'lr 10/31/2005 15:12'!
buildWith: aBuilder
	| window |
	window := aBuilder pluggableWindowSpec new
		model: self; label: self label; extent: self extent;
		children: (OrderedCollection new 
			add: ((self buildCategoriesWith: aBuilder)
				frame: (0.00 @ 0.00 corner: 0.25 @ 0.92 );
				yourself);
			add: ((self buildClassesWith: aBuilder)
				frame: (0.25 @ 0.00 corner: 0.50 @ 0.92 );
				yourself);
			add: ((self buildStatusWith: aBuilder)
				frame: (0.50 @ 0.00 corner: 1.00 @ 0.08);
				yourself);
			add: ((self buildFailureListWith: aBuilder)
				frame: (0.50 @ 0.08 corner: 1.00 @ 0.50);
				yourself);
			add: ((self buildErrorListWith: aBuilder)
				frame: (0.50 @ 0.50 corner: 1.00 @ 0.92);
				yourself);
			add: ((self buildButtonsWith: aBuilder)
				frame: (0.00 @ 0.92 corner: 1.00 @ 1.00);
				yourself);
			yourself);
		yourself.
	^ aBuilder build: window.! !


!TestRunner methodsFor: 'initialization' stamp: 'lr 3/22/2006 19:36'!
initialize
	super initialize.
	failedList := errorList := Array new.
	SystemChangeNotifier uniqueInstance 
		notify: self ofSystemChangesOfItem: #class change: #Added using: #update;
		notify: self ofSystemChangesOfItem: #category change: #Added using: #update;
		notify: self ofSystemChangesOfItem: #class change: #Removed using: #update;
		notify: self ofSystemChangesOfItem: #category change: #Removed using: #update;
		notify: self ofSystemChangesOfItem: #class change: #Renamed using: #update;
		notify: self ofSystemChangesOfItem: #category change: #Renamed using: #update;
		notify: self ofSystemChangesOfItem: #class change: #Recategorized using: #update;
		notify: self ofSystemChangesOfItem: #category change: #Recategorized using: #update.
	self update; reset! !


!TestRunner methodsFor: 'processing' stamp: 'lr 10/31/2005 17:43'!
basicRunSuite: aTestSuite do: aBlock
	self basicSetUpSuite: aTestSuite.
	[ aTestSuite name isEmptyOrNil
		ifTrue: [ aTestSuite tests do: aBlock ]
		ifFalse: [ aTestSuite tests do: aBlock displayingProgress: aTestSuite name ] ]
			ensure: [ self basicTearDownSuite: aTestSuite ].
	! !

!TestRunner methodsFor: 'processing' stamp: 'lr 10/27/2005 10:04'!
basicSetUpSuite: aTestSuite
	aTestSuite resources do: [ :each |
		each isAvailable
			ifFalse: [ each signalInitializationError ] ].! !

!TestRunner methodsFor: 'processing' stamp: 'lr 10/27/2005 10:04'!
basicTearDownSuite: aTestSuite
	aTestSuite resources do: [ :each | each reset ].! !


!TestRunner methodsFor: 'testing' stamp: 'lr 11/21/2005 13:19'!
hasErrors
	^ result hasErrors.! !

!TestRunner methodsFor: 'testing' stamp: 'lr 11/21/2005 13:19'!
hasFailures
	^ result hasFailures.! !

!TestRunner methodsFor: 'testing' stamp: 'lr 11/21/2005 13:19'!
hasRunnable
	^ classesSelected notEmpty.! !


!TestRunner methodsFor: 'updating' stamp: 'lr 3/22/2006 19:35'!
update
	self updateCategories; updateClasses! !

!TestRunner methodsFor: 'updating' stamp: 'lr 10/31/2005 15:45'!
updateCategories
	categories := self findCategories.
	categoriesSelected := categoriesSelected isNil
		ifTrue: [ Set new ]
		ifFalse: [
			categoriesSelected
				select: [ :each | categories includes: each ] ].
	self changed: #categoryList; changed: #categorySelected.! !

!TestRunner methodsFor: 'updating' stamp: 'lr 11/21/2005 13:20'!
updateClasses
	| classesForCategories |
	classesForCategories := self findClassesForCategories: categoriesSelected.
	classes := classesForCategories asArray
		sort: [ :a :b | self sortClass: a before: b ].
	classesSelected := classesSelected isNil
		ifTrue: [ classesForCategories ]
		ifFalse: [ 
			classesSelected
				select: [ :each | classesForCategories includes: each ] ].
	self changed: #classList; changed: #classSelected; changed: #hasRunnable.! !

!TestRunner methodsFor: 'updating' stamp: 'lr 12/21/2005 14:17'!
updateResults
	"<lint: #expect rule: #guardingClause>"
	"<lint: #expect rule: #longMethods>"

	self updateStatus: false.
	failedList size = result failures size ifFalse: [
		failedList := result failures asArray
			sort: [ :a :b | a printString <= b printString ].
		failedSelected := nil.
		self 
			changed: #failedList; 
			changed: #failedSelected;
			changed: #hasFailures ].
	errorList size = result errors size ifFalse: [
		errorList := result errors asArray
			sort: [ :a :b | a printString <= b printString ].
		errorSelected := nil.
		self 
			changed: #errorList; 
			changed: #errorSelected;
			changed: #hasErrors ].! !

!TestRunner methodsFor: 'updating' stamp: 'lr 11/3/2005 09:28'!
updateStatus: aBoolean
	"Update the status display, at most once a second if aBoolean is true."

	(aBoolean and: [ lastUpdate = Time totalSeconds ])
		ifTrue: [ ^ self ].
	self changed: #statusText; changed: #statusColor.
	lastUpdate := Time totalSeconds.! !


!TestRunner methodsFor: 'utilities' stamp: 'lr 3/22/2006 19:29'!
findCategories
	| visible |
	visible := Set new.
	self baseClass withAllSubclassesDo: [ :each |
		each category ifNotNilDo: [ :category |
			visible add: category ] ].
	^ Array streamContents: [ :stream |
		Smalltalk organization categories do: [ :each |
			(visible includes: each)
				ifTrue: [ stream nextPut: each ] ] ].! !

!TestRunner methodsFor: 'utilities' stamp: 'lr 10/31/2005 16:05'!
findClassesForCategories: aCollection
	| items |
	aCollection isEmpty 
		ifTrue: [ ^ self baseClass withAllSubclasses ].
	items := aCollection gather: [ :category |
		((Smalltalk organization listAtCategoryNamed: category)
			collect: [ :each | Smalltalk at: each ])
			select: [ :each | each includesBehavior: self baseClass ] ].
	^ items asSet.! !

!TestRunner methodsFor: 'utilities' stamp: 'lr 10/10/2005 08:43'!
sortClass: aFirstClass before: aSecondClass
	| first second |
	first := aFirstClass withAllSuperclasses reversed.
	second := aSecondClass withAllSuperclasses reversed.
	1 to: (first size min: second size) do: [ :index | 
		(first at: index) == (second at: index)
			ifFalse: [ ^ (first at: index) name <= (second at: index) name ] ].
	^ second includes: aFirstClass.! !


!TestRunner methodsFor: 'private' stamp: 'lr 11/21/2005 13:36'!
browserEnvironment
	^ Smalltalk classNamed: #BrowserEnvironment.! !

!TestRunner methodsFor: 'private' stamp: 'lr 10/28/2005 13:28'!
defaultBackgroundColor
	"<lint: #expect rule: #overridesSuper rational: 'we want a different color than the parent'>"

	^ Color orange.! !

!TestRunner methodsFor: 'private' stamp: 'lr 10/27/2005 10:32'!
label: aString forSuite: aTestSuite
	^ String streamContents: [ :stream |
		stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString.
		aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ]. ! !

!TestRunner methodsFor: 'private' stamp: 'lr 12/21/2005 10:39'!
perform: selector orSendTo: otherTarget
	"<lint: #expect rule: #badMessage rational: 'this is a common morphic pattern'>"
	
	^ (self respondsTo: selector)
		ifTrue: [ self perform: selector ]
		ifFalse: [ super perform: selector orSendTo: otherTarget ].! !

!TestRunner methodsFor: 'private' stamp: 'lr 3/22/2006 19:26'!
windowIsClosing
	SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestRunner class
	instanceVariableNames: ''!

!TestRunner class methodsFor: 'initialization' stamp: 'lr 12/7/2005 13:56'!
initialize
	self registerInWorldMenu; registerInToolsFlap.! !

!TestRunner class methodsFor: 'initialization' stamp: 'KR 4/28/2006 21:06'!
registerInToolsFlap
	self environment at: #Flaps ifPresent: [ :class |
		class
			registerQuad: #( TestRunner build 'SUnit Runner' 'A production scale test-runner.' ) forFlapNamed: 'Tools';
			replaceToolsFlap ].! !

!TestRunner class methodsFor: 'initialization' stamp: 'md 1/13/2006 18:14'!
registerInWorldMenu
	self environment at: #TheWorldMenu ifPresent: [ :class |
		class registerOpenCommand: (Array 
			with: 'Test Runner' 
			with: (Array
				with: self
				with: #open)) ].! !


!TestRunner class methodsFor: 'instance-creation' stamp: 'KR 4/28/2006 21:07'!
build
	^ ToolBuilder build: self new.! !

!TestRunner class methodsFor: 'instance-creation' stamp: 'lr 10/8/2005 18:35'!
open
	^ ToolBuilder open: self new.! !
Object subclass: #TestSuite
	instanceVariableNames: 'tests resources name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Kernel'!
!TestSuite commentStamp: '<historical>' prior: 0!
This is a Composite of Tests, either TestCases or other TestSuites. The common protocol is #run: aTestResult and the dependencies protocol!


!TestSuite methodsFor: 'accessing'!
addTest: aTest
	self tests add: aTest
			! !

!TestSuite methodsFor: 'accessing'!
addTests: aCollection 
	aCollection do: [:eachTest | self addTest: eachTest]
			! !

!TestSuite methodsFor: 'accessing'!
defaultResources
	^self tests 
		inject: Set new
		into: [:coll :testCase | 
			coll
				addAll: testCase resources;
				yourself]
			! !

!TestSuite methodsFor: 'accessing'!
name

	^name
			! !

!TestSuite methodsFor: 'accessing'!
name: aString

	name := aString
			! !

!TestSuite methodsFor: 'accessing'!
resources
	resources isNil ifTrue: [resources := self defaultResources].
	^resources
			! !

!TestSuite methodsFor: 'accessing'!
resources: anObject
	resources := anObject
			! !

!TestSuite methodsFor: 'accessing'!
tests
	tests isNil ifTrue: [tests := OrderedCollection new].
	^tests
			! !


!TestSuite methodsFor: 'dependencies' stamp: 'md 2/22/2006 14:24'!
addDependentToHierachy: anObject
	self addDependent: anObject.
	self tests do: [ :each | each addDependentToHierachy: anObject]
			! !

!TestSuite methodsFor: 'dependencies' stamp: 'md 2/22/2006 14:24'!
removeDependentFromHierachy: anObject
	self removeDependent: anObject.
	self tests do: [ :each | each removeDependentFromHierachy: anObject]
			! !


!TestSuite methodsFor: 'running' stamp: 'md 2/22/2006 14:27'!
run
	| result |
 	result := TestResult new.
	self resources do: [ :res |
		res isAvailable ifFalse: [^res signalInitializationError]].
	[self run: result] ensure: [self resources do: [:each | each reset]].
	^result
			! !

!TestSuite methodsFor: 'running' stamp: 'md 2/22/2006 14:24'!
run: aResult 
	self tests do: [:each | 
		self changed: each.
		each run: aResult]
			! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestSuite class
	instanceVariableNames: ''!

!TestSuite class methodsFor: 'instance creation'!
named: aString

	^self new
		name: aString;
		yourself
			! !
TestCase subclass: #TestURI
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NetworkTests-URI'!
!TestURI commentStamp: 'mir 2/27/2002 14:42' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.


   Some parsers allow the scheme name to be present in a relative URI if
   it is the same as the base URI scheme.  This is considered to be a
   loophole in prior specifications of partial URI [RFC1630]. Its use
   should be avoided.

      http:g        =  http:g           ; for validating parsers
                    |  http://a/b/c/g   ; for backwards compatibility
!


!TestURI methodsFor: 'running file' stamp: 'mir 6/20/2005 17:17'!
testDefaultDirRoundtrip
	| defaultDir defaultURI uriDir |
	defaultDir := FileDirectory default.
	defaultURI := defaultDir uri.
	uriDir := FileDirectory uri: defaultURI.
	self should: [defaultDir fullName = uriDir fullName]! !

!TestURI methodsFor: 'running file' stamp: 'mir 6/20/2005 17:19'!
testDirectoryRoot

	| rootDir uriRoot uriDir |
	rootDir := FileDirectory root.
	uriRoot := 'file:///' asURI.
	uriDir := FileDirectory uri: uriRoot.
	self should: [rootDir fullName = uriDir fullName]! !


!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:21'!
testSchemeAbsoluteFail1
	self should: [URI fromString: 'http:'] raise: IllegalURIException! !

!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:24'!
testSchemeAbsolutePass1
	| uri |
	uri _ URI fromString: 'http://www.squeakland.org'.
	self should: [uri scheme = 'http'].
	self should: [uri isAbsolute].
	self shouldnt: [uri isOpaque].
	self shouldnt: [uri isRelative]! !

!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:25'!
testSchemeAbsolutePass2
	| uri |
	uri _ URI fromString: 'mailto:somebody@somewhere.nowhere'.
	self should: [uri scheme = 'mailto'].
	self should: [uri isAbsolute].
	self should: [uri isOpaque].
	self shouldnt: [uri isRelative]! !

!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:32'!
testSchemeAbsolutePass3
	| uri |
	uri _ URI fromString: 'ftp://ftp@squeak.org'.
	self should: [uri scheme = 'ftp'].
	self should: [uri isAbsolute].
	self shouldnt: [uri isOpaque].
	self shouldnt: [uri isRelative].
	self should: [uri userInfo = 'ftp'].
	self should: [uri host = 'squeak.org'].
	self should: [uri port isNil].
! !

!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:38'!
testSchemeAbsolutePass4
	| uri |
	uri _ URI fromString: 'mailto:somebody@somewhere.nowhere#fragment'.
	self should: [uri scheme = 'mailto'].
	self should: [uri isAbsolute].
	self should: [uri isOpaque].
	self shouldnt: [uri isRelative].
	self should: [uri fragment = 'fragment'].
! !

!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:39'!
testSchemeAbsolutePass5
	| uri |
	uri _ URI fromString: 'http://www.squeakland.org#fragment'.
	self should: [uri scheme = 'http'].
	self should: [uri isAbsolute].
	self shouldnt: [uri isOpaque].
	self shouldnt: [uri isRelative].
	self should: [uri fragment = 'fragment'].
! !


!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal1
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '../../../g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/../g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal10
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ './g/.'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g/'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal11
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g/./h'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g/h'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal12
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g/../h'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/h'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal13
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g;x=1/./y'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g;x=1/y'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal14
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g;x=1/../y'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/y'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal15
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g?y/./x'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g?y/./x'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 16:12'!
testResolveAbnormal16
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g?y/../x'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g?y/../x'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal17
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g#s/./x'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g#s/./x'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal18
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g#s/../x'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g#s/../x'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal2
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '../../../../g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/../../g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal3
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '/./g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/./g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal4
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '/../g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/../g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal5
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g.'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g.'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal6
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '.g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/.g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal7
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g..'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g..'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal8
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '..g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/..g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveAbnormal9
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ './../g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal1
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g:h'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'g:h'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal10
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g?y#s'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g?y#s'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal11
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ ';x'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/;x'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal12
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g;x'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g;x'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal13
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g;x?y#s'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g;x?y#s'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal14
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '.'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal15
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ './'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal16
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '..'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal17
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '../'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal18
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '../g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal19
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '../..'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal2
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal20
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '../../'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal21
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '../../g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal3
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ './g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal4
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g/'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g/'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal5
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '/g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal6
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '//g'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://g'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal7
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ '?y'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/?y'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal8
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g?y'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g?y'].
! !

!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'!
testResolveNormal9
	| baseURI relURI resolvedURI |
	baseURI _ 'http://a/b/c/d;p?q' asURI.
	relURI _ 'g#s'.
	resolvedURI _ baseURI resolveRelativeURI: relURI.
	self should: [resolvedURI asString = 'http://a/b/c/g#s'].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestURI class
	instanceVariableNames: ''!

!TestURI class methodsFor: 'test generation' stamp: 'mir 2/27/2002 16:13'!
generateAbnormalResolverTests
	"TestURI generateAbnormalResolverTests"

	| relURIString result method testPairs pair |

	testPairs _ #(
		#('../../../g' 'http://a/../g' )
		#('../../../../g' 'http://a/../../g' )
		#('/./g' 'http://a/./g' )
		#('/../g' 'http://a/../g' )
		#('g.' 'http://a/b/c/g.' )
		#('.g' 'http://a/b/c/.g' )
		#('g..' 'http://a/b/c/g..' )
		#('..g' 'http://a/b/c/..g' )
		#('./../g' 'http://a/b/g' )
		#('./g/.' 'http://a/b/c/g/' )
		#('g/./h' 'http://a/b/c/g/h' )
		#('g/../h' 'http://a/b/c/h' )
		#('g;x=1/./y' 'http://a/b/c/g;x=1/y' )
		#('g;x=1/../y' 'http://a/b/c/y' )
		#('g?y/./x' 'http://a/b/c/g?y/./x' )
		#('g?y/../x' 'http://a/b/c/g?y/../x' )
		#('g#s/./x' 'http://a/b/c/g#s/./x' )
		#('g#s/../x' 'http://a/b/c/g#s/../x' )
	).
	1 to: testPairs size do: [:index |
		pair _ testPairs at: index.
		relURIString _ pair first.
		result _ pair last.
		method _ String streamContents: [:stream |
			stream nextPutAll: 'testResolveAbnormal' , index printString; cr.
			stream
				nextPutAll: '	| baseURI relURI resolvedURI |' ; cr;
				nextPutAll: '	baseURI _ ''http://a/b/c/d;p?q'' asURI.' ; cr;
				nextPutAll: '	relURI _ '; nextPut: $'; nextPutAll: relURIString; nextPutAll: '''.' ; cr;
				nextPutAll: '	resolvedURI _ baseURI resolveRelativeURI: relURI.' ; cr;
				nextPutAll: '	self should: [resolvedURI asString = '''; nextPutAll: result; nextPutAll: '''].' ; cr].
		self compile: method classified: 'running resolving'].
! !

!TestURI class methodsFor: 'test generation' stamp: 'mir 2/27/2002 14:42'!
generateNormalResolverTests
	"TestURI generateNormalResolverTests"

	| relURIString result method testPairs pair |

	testPairs _ #(
		#('g:h' 'g:h' )
		#('g' 'http://a/b/c/g' )
		#('./g' 'http://a/b/c/g' )
		#('g/' 'http://a/b/c/g/' )
		#('/g' 'http://a/g' )
		#('//g' 'http://g' )
		#('?y' 'http://a/b/c/?y' )
		#('g?y' 'http://a/b/c/g?y' )
		#('g#s' 'http://a/b/c/g#s' )
		#('g?y#s' 'http://a/b/c/g?y#s' )
		#(';x' 'http://a/b/c/;x' )
		#('g;x' 'http://a/b/c/g;x' )
		#('g;x?y#s' 'http://a/b/c/g;x?y#s' )
		#('.' 'http://a/b/c/' )
		#('./' 'http://a/b/c/' )
		#('..' 'http://a/b/' )
		#('../' 'http://a/b/' )
		#('../g' 'http://a/b/g' )
		#('../..' 'http://a/' )
		#('../../' 'http://a/' )
		#('../../g' 'http://a/g' )
	).
	1 to: testPairs size do: [:index |
		pair _ testPairs at: index.
		relURIString _ pair first.
		result _ pair last.
		method _ String streamContents: [:stream |
			stream nextPutAll: 'testResolveNormal' , index printString; cr.
			stream
				nextPutAll: '	| baseURI relURI resolvedURI |' ; cr;
				nextPutAll: '	baseURI _ ''http://a/b/c/d;p?q'' asURI.' ; cr;
				nextPutAll: '	relURI _ '; nextPut: $'; nextPutAll: relURIString; nextPutAll: '''.' ; cr;
				nextPutAll: '	resolvedURI _ baseURI resolveRelativeURI: relURI.' ; cr;
				nextPutAll: '	self should: [resolvedURI asString = '''; nextPutAll: result; nextPutAll: '''].' ; cr].
		self compile: method classified: 'running resolving'].
! !
ArrayedCollection subclass: #Text
	instanceVariableNames: 'string runs'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Collections-Text'!
!Text commentStamp: '<historical>' prior: 0!
I represent a character string that has been marked with abstract changes in character appearance. Actual display is performed in the presence of a TextStyle which indicates, for each abstract code, an actual font to be used.  A Text associates a set of TextAttributes with each character in its character string.  These attributes may be font numbers, emphases such as bold or italic, or hyperling actions.  Font numbers are interpreted relative to whatever textStyle appears, along with the text, in a Paragraph.  Since most characters have the same attributes as their neighbors, the attributes are stored in a RunArray for efficiency.  Each of my instances has
	string		a String
	runs		a RunArray!
]style[(148 9 97 13 237 9 163 6 10 8)f1,f1LTextStyle Comment;,f1,f1LTextAttribute Hierarchy;,f1,f1LParagraph Comment;,f1,f1LString Comment;,f1,f1LRunArray Comment;!


!Text methodsFor: 'accessing' stamp: 'tk 9/4/2000 16:04'!
append: stringOrText

	self replaceFrom: string size + 1
				to: string size with: stringOrText! !

!Text methodsFor: 'accessing'!
at: index

	^string at: index! !

!Text methodsFor: 'accessing'!
at: index put: character

	^string at: index put: character! !

!Text methodsFor: 'accessing' stamp: 'gm 2/15/2003 14:59'!
embeddedMorphs
	"return the list of morphs embedded in me"

	| morphs |
	morphs := IdentitySet new.
	runs withStartStopAndValueDo: 
			[:start :stop :attribs | 
			attribs 
				do: [:attrib | attrib anchoredMorph ifNotNil: [morphs add: attrib anchoredMorph]]].
	^morphs select: [:m | m isMorph]! !

!Text methodsFor: 'accessing' stamp: 'gm 2/15/2003 14:59'!
embeddedMorphsFrom: start to: stop 
	"return the list of morphs embedded in me"

	| morphs |
	morphs := IdentitySet new.
	runs 
		runsFrom: start
		to: stop
		do: 
			[:attribs | 
			attribs 
				do: [:attr | attr anchoredMorph ifNotNil: [morphs add: attr anchoredMorph]]].
	^morphs select: [:m | m isMorph]! !

!Text methodsFor: 'accessing'!
findString: aString startingAt: start 
	"Answer the index of subString within the receiver, starting at index 
	start. If the receiver does not contain subString, answer 0."

	^string findString: aString asString startingAt: start! !

!Text methodsFor: 'accessing' stamp: 'di 11/23/1998 11:53'!
findString: aString startingAt: start caseSensitive: caseSensitive
	"Answer the index of subString within the receiver, starting at index 
	start. If the receiver does not contain subString, answer 0."

	^string findString: aString asString startingAt: start caseSensitive: caseSensitive! !

!Text methodsFor: 'accessing' stamp: 'tk 9/6/2000 12:33'!
lineCount

	^ string lineCount! !

!Text methodsFor: 'accessing' stamp: 'ar 12/27/2001 00:03'!
prepend: stringOrText

	self replaceFrom: 1 to: 0 with: stringOrText! !

!Text methodsFor: 'accessing' stamp: 'BG 6/8/2003 16:18'!
rangeOf: attribute startingAt: index
"Answer an interval that gives the range of attribute at index position  index. An empty interval with start value index is returned when the attribute is not present at position index.  "
   ^string size = 0
      ifTrue: [index to: index - 1]
	 ifFalse: [runs rangeOf: attribute startingAt: index]! !

!Text methodsFor: 'accessing' stamp: 'tk 12/30/97 07:17'!
replaceFrom: start to: stop with: aText

	| txt |
	txt _ aText asText.	"might be a string"
	string _ string copyReplaceFrom: start to: stop with: txt string.
	runs _ runs copyReplaceFrom: start to: stop with: txt runs! !

!Text methodsFor: 'accessing' stamp: 'tween 9/13/2004 10:07'!
runs: anArray

	runs := anArray! !

!Text methodsFor: 'accessing'!
size

	^string size! !

!Text methodsFor: 'accessing'!
string
	"Answer the string representation of the receiver."

	^string! !


!Text methodsFor: 'attributes' stamp: 'rbb 2/18/2005 09:14'!
askIfAddStyle: priorMethod req: requestor
	"Ask the user if we have a complex style (i.e. bold) for the first time"
	| tell answ old |
	(Preferences browseWithPrettyPrint and: [Preferences colorWhenPrettyPrinting])
		ifTrue: [self couldDeriveFromPrettyPrinting ifTrue: [^ self asString]].
	self runs coalesce.
	self unembellished ifTrue: [^ self asString].
	priorMethod ifNotNil: [old _ priorMethod getSourceFromFile].
	(old == nil or: [old unembellished])
		ifTrue:
			[tell _ 'This method contains style for the first time (e.g. bold or colored text).
Do you really want to save the style info?'.
			answ _ (UIManager default 
						chooseFrom: #('Save method with style' 'Save method simply')
						title: tell).
			answ = 2 ifTrue: [^ self asString]]! !

!Text methodsFor: 'attributes' stamp: 'tk 11/1/2001 14:37'!
basicType
	"Answer a symbol representing the inherent type I hold"

	"Number String Boolean player collection sound color etc"
	^ #Text! !

!Text methodsFor: 'attributes' stamp: 'sw 11/16/1999 22:33'!
couldDeriveFromPrettyPrinting
	"Return true if the receiver has any TextAttributes that are functional rather than simply appearance-related"
	runs values do:
		[:emphArray | emphArray do:
			[:emph | emph couldDeriveFromPrettyPrinting ifFalse: [^ false]]].
	^ true! !

!Text methodsFor: 'attributes' stamp: 'sw 12/7/1999 12:31'!
unembellished 
	"Return true if the only emphases are the default font and bold"
	| font1 bold |
	font1 _ TextFontChange defaultFontChange.
	bold _ TextEmphasis bold.
	Preferences ignoreStyleIfOnlyBold ifFalse:
		["Ignore font1 only or font1-bold followed by font1-plain"
		^ (runs values = (Array with: (Array with: font1)))
		or: [runs values = (Array with: (Array with: font1 with: bold)
 								with: (Array with: font1))]].

	"If preference is set, then ignore any combo of font1 and bold"
	runs withStartStopAndValueDo:
		[:start :stop :emphArray |
		emphArray do:
			[:emph | (font1 = emph or: [bold = emph]) ifFalse: [^ false]]].
	^ true! !


!Text methodsFor: 'comparing' stamp: 'tk 10/17/2001 14:12'!
hash
	"#hash is implemented, because #= is implemented.  We are now equal to a string with the same characters.  Hash must reflect that."

	^ string hash! !

!Text methodsFor: 'comparing' stamp: 'tk 9/6/2000 11:59'!
howManyMatch: aString

	^ self string howManyMatch: aString! !

!Text methodsFor: 'comparing'!
isText
	^ true! !

!Text methodsFor: 'comparing' stamp: 'tk 10/19/2001 17:48'!
= other
	"Am I equal to the other Text or String?  
	***** Warning ***** Two Texts are considered equal if they have the same characters in them.  They might have completely different emphasis, fonts, sizes, text actions, or embedded morphs.  If you need to find out if one is a true copy of the other, you must do (text1 = text2 and: [text1 runs = text2 runs])."

	other isText ifTrue:	["This is designed to run fast even for megabytes"
				^ string == other string or: [string = other string]].
	other isString ifTrue: [^ string == other or: [string = other]].
	^ false! !


!Text methodsFor: 'converting'!
asDisplayText
	"Answer a DisplayText whose text is the receiver."

	^DisplayText text: self! !

!Text methodsFor: 'converting'!
asNumber
	"Answer the number created by interpreting the receiver as the textual 
	representation of a number."

	^string asNumber! !

!Text methodsFor: 'converting' stamp: 'ar 4/12/2005 17:32'!
asOctetStringText

	string class == WideString ifTrue: [
		^ self class string: string asOctetString runs: self runs copy.
	].
	^self.
! !

!Text methodsFor: 'converting'!
asParagraph
	"Answer a Paragraph whose text is the receiver."

	^Paragraph withText: self! !

!Text methodsFor: 'converting'!
asString
	"Answer a String representation of the textual receiver."

	^string! !

!Text methodsFor: 'converting' stamp: 'RAA 5/28/2001 06:19'!
asStringOrText	
	"Answer the receiver itself."

	^self! !

!Text methodsFor: 'converting'!
asText	
	"Answer the receiver itself."

	^self! !

!Text methodsFor: 'converting' stamp: 'ls 7/14/1998 03:17'!
asUrl
	^self asString asUrl! !

!Text methodsFor: 'converting' stamp: 'ls 7/14/1998 03:20'!
asUrlRelativeTo: aUrl
	^self asString asUrlRelativeTo: aUrl! !

!Text methodsFor: 'converting' stamp: 'ar 4/9/2005 22:16'!
isoToSqueak
	^self "no longer needed"! !

!Text methodsFor: 'converting' stamp: 'ar 4/10/2005 15:58'!
macToSqueak
	"Convert the receiver from MacRoman to Squeak encoding"
	^ self class new setString: string macToSqueak setRuns: runs copy! !

!Text methodsFor: 'converting' stamp: 'ar 12/17/2001 00:38'!
removeAttributesThat: removalBlock replaceAttributesThat: replaceBlock by: convertBlock
	"Enumerate all attributes in the receiver. Remove those passing removalBlock and replace those passing replaceBlock after converting it through convertBlock"
	| added removed new |
	"Deliberately optimized for the no-op default."
	added _ removed _ nil.
	runs withStartStopAndValueDo: [ :start :stop :attribs | 
		attribs do: [ :attrib |
			(removalBlock value: attrib) ifTrue:[
				removed ifNil:[removed _ WriteStream on: #()].
				removed nextPut: {start. stop. attrib}.
			] ifFalse:[
				(replaceBlock value: attrib) ifTrue:[
					removed ifNil:[removed _ WriteStream on: #()].
					removed nextPut: {start. stop. attrib}.
					new _ convertBlock value: attrib.
					added ifNil:[added _ WriteStream on: #()].
					added nextPut: {start. stop. new}.
				].
			].
		].
	].
	(added == nil and:[removed == nil]) ifTrue:[^self].
	"otherwise do the real work"
	removed ifNotNil:[removed contents do:[:spec|
		self removeAttribute: spec last from: spec first to: spec second]].
	added ifNotNil:[added contents do:[:spec|
		self addAttribute: spec last from: spec first to: spec second]].! !

!Text methodsFor: 'converting' stamp: 'dvf 10/1/2003 02:58'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"This destructively replaces elements from start to stop in the receiver starting at index, repStart, in replacementCollection. Do it to both the string and the runs."

	| rep newRepRuns |
	rep _ replacement asText.	"might be a string"
	string replaceFrom: start to: stop with: rep string startingAt: repStart.
	newRepRuns _ rep runs copyFrom: repStart to: repStart + stop - start.
	runs _ runs copyReplaceFrom: start to: stop with: newRepRuns! !

!Text methodsFor: 'converting' stamp: 'BG 6/8/2003 16:38'!
reversed

	"Answer a copy of the receiver with element order reversed."

	^ self class string: string reversed runs: runs reversed.

  "  It is assumed that  self size = runs size  holds. "! !

!Text methodsFor: 'converting' stamp: 'ar 4/9/2005 22:16'!
squeakToIso
	^self "no longer needed"! !

!Text methodsFor: 'converting' stamp: 'ar 4/10/2005 15:56'!
squeakToMac
	"Convert the receiver from Squeak to MacRoman encoding"
	^ self class new setString: string squeakToMac setRuns: runs copy! !

!Text methodsFor: 'converting' stamp: 'nk 9/16/2003 16:46'!
withSqueakLineEndings
	"Answer a copy of myself in which all sequences of <CR><LF> or <LF> have been changed to <CR>"
	| newText |
	(string includes: Character lf) ifFalse: [ ^self copy ].
	newText _ self copyReplaceAll: String crlf with: String cr asTokens: false.
	(newText asString includes: Character lf) ifFalse: [ ^newText ].
	^newText copyReplaceAll: String lf with: String cr asTokens: false.! !


!Text methodsFor: 'copying'!
copy

	^ self class new setString: string copy setRuns: runs copy
! !

!Text methodsFor: 'copying'!
copyFrom: start to: stop 
	"Answer a copied subrange of the receiver."

	| realStart realStop |
	stop > self size
		ifTrue: [realStop _ self size]		"handle selection at end of string"
		ifFalse: [realStop _ stop].
	start < 1
		ifTrue: [realStart _ 1]			"handle selection before start of string"
		ifFalse: [realStart _ start].
	^Text 
		string: (string copyFrom: realStart to: realStop)
		runs: (runs copyFrom: realStart to: realStop)! !

!Text methodsFor: 'copying' stamp: 'BG 6/12/2003 13:11'!
copyReplaceFrom: start to: stop with: aTextOrString

	| txt |
	txt _ aTextOrString asText.	"might be a string"
	^self class 
             string: (string copyReplaceFrom: start to: stop with: txt string)
             runs: (runs copyReplaceFrom: start to: stop with: txt runs)
! !

!Text methodsFor: 'copying' stamp: 'tk 1/7/98 10:58'!
copyReplaceTokens: oldSubstring with: newSubstring 
	"Replace all occurrences of oldSubstring that are surrounded
	by non-alphanumeric characters"
	^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true
	"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! !

!Text methodsFor: 'copying' stamp: 'di 11/9/97 17:13'!
deepCopy

	^ self copy "Both string and runs are assumed to be read-only"! !


!Text methodsFor: 'emphasis'!
addAttribute: att 
	^ self addAttribute: att from: 1 to: self size! !

!Text methodsFor: 'emphasis'!
addAttribute: att from: start to: stop 
	"Set the attribute for characters in the interval start to stop."
	runs _  runs copyReplaceFrom: start to: stop
			with: ((runs copyFrom: start to: stop)
				mapValues:
				[:attributes | Text addAttribute: att toArray: attributes])
! !

!Text methodsFor: 'emphasis' stamp: 'ar 12/17/2001 23:48'!
alignmentAt: characterIndex ifAbsent: aBlock
	| attributes emph |
	self size = 0 ifTrue: [^aBlock value].
	emph _ nil.
	attributes _ runs at: characterIndex.
	attributes do:[:att | (att isKindOf: TextAlignment) ifTrue:[emph _ att]].
	^ emph ifNil: aBlock ifNotNil:[emph alignment]! !

!Text methodsFor: 'emphasis'!
allBold 
	"Force this whole text to be bold."
	string size = 0 ifTrue: [^self].
	self makeBoldFrom: 1 to: string size! !

!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 12:30'!
attributesAt: characterIndex 
	"Answer the code for characters in the run beginning at characterIndex."
	"NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this"
	| attributes |
	self size = 0
		ifTrue: [^ Array with: (TextFontChange new fontNumber: 1)].  "null text tolerates access"
	attributes _ runs at: characterIndex.
	^ attributes! !

!Text methodsFor: 'emphasis' stamp: 'ar 12/17/2001 01:17'!
attributesAt: characterIndex do: aBlock
	"Answer the code for characters in the run beginning at characterIndex."
	"NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this"
	self size = 0 ifTrue:[^self].
	(runs at: characterIndex) do: aBlock! !

!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 11:32'!
attributesAt: characterIndex forStyle: aTextStyle
	"Answer the code for characters in the run beginning at characterIndex."
	| attributes |
	self size = 0
		ifTrue: [^ Array with: (TextFontChange new fontNumber: aTextStyle defaultFontIndex)].  "null text tolerates access"
	attributes _ runs at: characterIndex.
	^ attributes! !

!Text methodsFor: 'emphasis' stamp: 'di 4/1/1999 15:17'!
emphasisAt: characterIndex
	"Answer the fontfor characters in the run beginning at characterIndex."
	| attributes emph |
	self size = 0 ifTrue: [^ 0].	"null text tolerates access"
	emph _ 0.
	attributes _ runs at: characterIndex.
	attributes do: 
		[:att | emph _ emph bitOr: att emphasisCode].
	^ emph
	! !

!Text methodsFor: 'emphasis' stamp: 'di 11/10/97 13:36'!
find: attribute
	"Return the first interval over which this attribute applies"
	| begin end |
	begin _ 0.
	runs withStartStopAndValueDo:
		[:start :stop :attributes |
		(attributes includes: attribute)
			ifTrue: [begin = 0 ifTrue: [begin _ start].
					end _ stop]
			ifFalse: [begin > 0 ifTrue: [^ begin to: end]]].
	begin > 0 ifTrue: [^ begin to: end].
	^ nil! !

!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 10:58'!
fontAt: characterIndex withStyle: aTextStyle
	"Answer the fontfor characters in the run beginning at characterIndex."
	| attributes font |
	self size = 0 ifTrue: [^ aTextStyle defaultFont].	"null text tolerates access"
	attributes _ runs at: characterIndex.
	font _ aTextStyle defaultFont.  "default"
	attributes do: 
		[:att | att forFontInStyle: aTextStyle do: [:f | font _ f]].
	^ font! !

!Text methodsFor: 'emphasis'!
fontNumberAt: characterIndex 
	"Answer the fontNumber for characters in the run beginning at characterIndex."
	| attributes fontNumber |
	self size = 0 ifTrue: [^1].	"null text tolerates access"
	attributes _ runs at: characterIndex.
	fontNumber _ 1.
	attributes do: [:att | (att isMemberOf: TextFontChange) ifTrue: [fontNumber _ att fontNumber]].
	^ fontNumber
	! !

!Text methodsFor: 'emphasis'!
makeBoldFrom: start to: stop

	^ self addAttribute: TextEmphasis bold from: start to: stop! !

!Text methodsFor: 'emphasis' stamp: 'md 1/20/2006 17:11'!
makeSelectorBold
	"For formatting Smalltalk source code, set the emphasis of that portion of 
	the receiver's string that parses as a message selector to be bold."

	| parser i |
	string size = 0 ifTrue: [^ self].
	i _ 0.
	[(string at: (i _ i + 1)) isSeparator] whileTrue.
	(string at: i) = $[ ifTrue: [^ self].  "block, no selector"
	[(parser _ Compiler parserClass new) parseSelector: string] on: Error do: [^ self].
	self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)! !

!Text methodsFor: 'emphasis' stamp: 'sma 2/5/2000 12:03'!
makeSelectorBoldIn: aClass
	"For formatting Smalltalk source code, set the emphasis of that portion of 
	the receiver's string that parses as a message selector to be bold."

	| parser |
	string size = 0 ifTrue: [^self].
	(parser _ aClass parserClass new) parseSelector: string.
	self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)! !

!Text methodsFor: 'emphasis'!
removeAttribute: att from: start to: stop 
	"Remove the attribute over the interval start to stop."
	runs _  runs copyReplaceFrom: start to: stop
			with: ((runs copyFrom: start to: stop)
				mapValues:
				[:attributes | attributes copyWithout: att])
! !

!Text methodsFor: 'emphasis'!
runLengthFor: characterIndex 
	"Answer the count of characters remaining in run beginning with 
	characterIndex."

	^runs runLengthAt: characterIndex! !


!Text methodsFor: 'printing' stamp: 'sma 6/1/2000 09:49'!
printOn: aStream
	self printNameOn: aStream.
	aStream nextPutAll: ' for '; print: string! !

!Text methodsFor: 'printing'!
storeOn: aStream

	aStream nextPutAll: '(Text string: ';
		store: string;
		nextPutAll: ' runs: ';
		store: runs;
		nextPut: $)! !


!Text methodsFor: '*Morphic-converting' stamp: 'nk 2/26/2004 13:32'!
asMorph
	^ self asTextMorph! !

!Text methodsFor: '*Morphic-converting' stamp: 'nk 2/26/2004 13:31'!
asStringMorph
	^ StringMorph
		contents: self string
		font: (self fontAt: 1 withStyle: TextStyle default)
		emphasis: (self emphasisAt: 1)! !

!Text methodsFor: '*Morphic-converting' stamp: 'nk 2/26/2004 13:32'!
asTextMorph
	^ TextMorph new contentsAsIs: self! !


!Text methodsFor: 'private'!
runs

	^runs! !

!Text methodsFor: 'private' stamp: 'tk 12/16/97 14:14'!
setString: aString setRunsChecking: aRunArray
	"Check runs and do the best you can to make them fit..."

	string _ aString.
	"check the runs"
	aRunArray ifNil: [^ aString asText].
	(aRunArray isKindOf: RunArray) ifFalse: [^ aString asText].
	aRunArray runs size = aRunArray values size ifFalse: [^ aString asText].
	(aRunArray values includes: #()) ifTrue: [^ aString asText].	"not allowed?"
	aRunArray size = aString size ifFalse: [^ aString asText].
	
	runs _ aRunArray.! !

!Text methodsFor: 'private'!
setString: aString setRuns: anArray

	string _ aString.
	runs _ anArray! !


!Text methodsFor: 'html' stamp: 'dgd 9/1/2005 13:05'!
closeHtmlAttributes: anArray on: aStream 
	anArray
		do: [:each | each closeHtmlOn: aStream].! !

!Text methodsFor: 'html' stamp: 'dgd 9/1/2005 13:05'!
openHtmlAttributes: anArray on: aStream 
	anArray
		do: [:each | each openHtmlOn: aStream ]! !

!Text methodsFor: 'html' stamp: 'dgd 9/2/2005 12:20'!
printHtmlOn: aStream 
	self runs
		withStartStopAndValueDo: [:start :stop :attributes | 
			| att str | 
			att := self attributesAt: start.
			str := self string copyFrom: start to: stop.
			""
			self openHtmlAttributes: att on: aStream.
			self printStringHtml: str on: aStream.

			self closeHtmlAttributes: att on: aStream]! !

!Text methodsFor: 'html' stamp: 'dgd 9/2/2005 12:40'!
printHtmlString
	"answer a string whose characters are the html representation 
	of the receiver"
	| html |
	html := String new writeStream.
	self printHtmlOn: html.
	^ html contents! !

!Text methodsFor: 'html' stamp: 'dgd 9/2/2005 12:30'!
printStringHtml: aString on: aStream 
	| html |
	html := aString.
	""
	html := html copyReplaceAll: '&' with: '&amp;'.
	html := html copyReplaceAll: '>' with: '&gt;'.
	html := html copyReplaceAll: '<' with: '&lt;'.
	""
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬®¬¨¦Ö' with: '&aacute;'.
	html := html copyReplaceAll: '¬¨¬Ž¬¨¬©' with: '&eacute;'.
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬®¬¶¦ë' with: '&iacute;'.
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬®¬¶¦ü' with: '&oacute;'.
	html := html copyReplaceAll: '¬¨¬Ž¬¨¦š' with: '&uacute;'.
	html := html copyReplaceAll: '¬¨¬Ž¬¨¬±' with: '&ntilde;'.
	""
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬Ž¬¶¦±' with: '&Aacute;'.
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬Ž¬¨¬¢' with: '&Eacute;'.
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬Ž¬¶¦º' with: '&Iacute;'.
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬Ž¬¨¬Æ' with: '&Oacute;'.
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬Ž¬¨¦©' with: '&Uacute;'.
	html := html copyReplaceAll: '¬¨¬®¬¨¬é¬¨¬Ž¬¨¬·' with: '&Ntilde;'.
	""
	html := html copyReplaceAll: '
' with: '<br>
'.
	html := html copyReplaceAll: '	' with: '&nbsp;&nbsp;&nbsp;&nbsp;'.
	""
	aStream nextPutAll: html! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Text class
	instanceVariableNames: ''!

!Text class methodsFor: 'class initialization' stamp: 'mir 8/3/2004 13:30'!
initTextConstants 
	"Initialize constants shared by classes associated with text display, e.g., 
	Space, Tab, Cr, Bs, ESC."
		"1/24/96 sw: in exasperation and confusion, changed cmd-g mapping from 231 to 232 to see if I could gain any relief?!!"


	| letter varAndValue tempArray width |
	"CtrlA..CtrlZ, Ctrla..Ctrlz"
	letter _ $A.
 	#(		212 230 228 196 194 226 241 243 214 229 200 217 246 
			245 216 202 210 239 211 240 197 198 209 215 242 231
	 		1 166 228 132 130 12 232 179 150 165 136 153 182 
			14 15 138 17 18 19 11 21 134 145 151 178 167 ) do:
		[:kbd |
		TextConstants at: ('Ctrl', letter asSymbol) asSymbol put: kbd asCharacter.
		letter _ letter == $Z ifTrue: [$a] ifFalse: [(letter asciiValue + 1) asCharacter]].

	varAndValue _ #(
		Space	32
		Tab		9
		CR		13
		Enter	3
		BS		8
		BS2		158
		ESC		160
		Clear 	173
	).

	varAndValue size odd ifTrue: [self error: 'unpaired text constant'].
	(2 to: varAndValue size by: 2) do:
		[:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i) asCharacter].

	varAndValue _ #(
		CtrlDigits 			(159 144 143 128 127 129 131 180 149 135)
		CtrlOpenBrackets	(201 7 218 249 219 15)
			"lparen gottn by ctrl-_ = 201; should be 213 but can't type that on Mac"

			"location of non-character stop conditions"
		EndOfRun	257
		CrossedX	258

			"values for alignment"
		LeftFlush	0
		RightFlush	1
		Centered	2
		Justified	3

			"subscripts for a marginTabsArray tuple"
		LeftMarginTab	1
		RightMarginTab	2

			"font faces"
		Basal	0
		Bold	1
		Italic	2

			"in case font doesn't have a width for space character"
			"some plausible numbers-- are they the right ones?"
		DefaultSpace			4
		DefaultTab				24
		DefaultLineGrid			16
		DefaultBaseline			12
		DefaultFontFamilySize	3	"basal, bold, italic"
	).

	varAndValue size odd ifTrue: [self error: 'unpaired text constant'].
	(2 to: varAndValue size by: 2) do:
		[:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i)].

	TextConstants at: #DefaultRule	put: Form over.
	TextConstants at: #DefaultMask	put: Color black.

	width _ Display width max: 720.
	tempArray _ Array new: width // DefaultTab.
	1 to: tempArray size do:
		[:i | tempArray at: i put: DefaultTab * i].
	TextConstants at: #DefaultTabsArray put: tempArray.
	tempArray _ Array new: (width // DefaultTab) // 2.
	1 to: tempArray size do:
		[:i | tempArray at: i put: (Array with: (DefaultTab*i) with: (DefaultTab*i))].
	TextConstants at: #DefaultMarginTabsArray put: tempArray.

"Text initTextConstants "! !

!Text class methodsFor: 'class initialization'!
initialize	"Text initialize"
	"Initialize constants shared by classes associated with text display."

	TextConstants at: #CaretForm put:
				(Form extent: 16@5
					fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)
					offset: -3@0).
	self initTextConstants! !


!Text class methodsFor: 'instance creation' stamp: 'sw 12/6/1999 14:14'!
fromString: aString 
	"Answer an instance of me whose characters are those of the argument, aString."

	^ self string: aString attribute: (TextFontChange fontNumber: TextStyle default defaultFontIndex)! !

!Text class methodsFor: 'instance creation' stamp: 'rbb 3/1/2005 11:18'!
fromUser
	"Answer an instance of me obtained by requesting the user to type a string."
	"Text fromUser"

	^ self fromString:
		(UIManager default request: 'Enter text followed by carriage return')
! !

!Text class methodsFor: 'instance creation'!
new: stringSize

	^self fromString: (String new: stringSize)! !

!Text class methodsFor: 'instance creation'!
streamContents: blockWithArg 
	| stream |
	stream _ TextStream on: (self new: 400).
	blockWithArg value: stream.
	^ stream contents! !

!Text class methodsFor: 'instance creation'!
string: aString attribute: att
	"Answer an instance of me whose characters are aString.
	att is a TextAttribute."

	^self string: aString attributes: (Array with: att)! !

!Text class methodsFor: 'instance creation'!
string: aString attributes: atts
	"Answer an instance of me whose characters are those of aString.
	atts is an array of TextAttributes."

	^self string: aString runs: (RunArray new: aString size withAll: atts)! !

!Text class methodsFor: 'instance creation'!
string: aString emphasis: emphasis
	"This is an old method that is mainly used by old applications"

	emphasis isNumber ifTrue:
		[self halt: 'Numeric emphasis is not supported in Squeak'.
		"But if you proceed, we will do our best to give you what you want..."
		^ self string: aString runs: (RunArray new: aString size withAll: 
			(Array with: (TextFontChange new fontNumber: emphasis)))].
	^ self string: aString attributes: emphasis! !


!Text class methodsFor: 'private' stamp: 'di 10/31/97 11:22'!
addAttribute: att toArray: others 
	"Add a new text attribute to an existing set"
	"NOTE: The use of reset and set in this code is a specific
	hack for merging TextKerns."
	att reset.
	^ Array streamContents:
		[:strm | others do:
			[:other | (att dominates: other) ifFalse: [strm nextPut: other]].
		att set ifTrue: [strm nextPut: att]]! !

!Text class methodsFor: 'private'!
string: aString runs: anArray
 
	^self basicNew setString: aString setRuns: anArray! !
TextAttribute subclass: #TextAction
	instanceVariableNames: ''
	classVariableNames: 'Purple'
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextAction methodsFor: 'as yet unclassified' stamp: 'nk 2/26/2005 09:49'!
analyze: aString
	"Analyze the selected text to find both the parameter to store and the text to emphesize (may be different from original selection).  Does not return self!!.  May be of the form:
3+4
<3+4>
Click Here<3+4>
<3+4>Click Here
"
	"Obtain the showing text and the instructions"
	| b1 b2 trim param show |
	b1 _ aString indexOf: $<.
	b2 _ aString indexOf: $>.
	(b1 < b2) & (b1 > 0) ifFalse: ["only one part"
		param _ self validate: aString.
		param ifNil: [ ^{ nil. nil } ].
		^ Array with: param with: (param size = 0 ifTrue: [nil] ifFalse: [param])].
	"Two parts"
	trim _ aString withBlanksTrimmed.
	(trim at: 1) == $< 
		ifTrue: [(trim last) == $>
			ifTrue: ["only instructions" 
				param _ self validate: (aString copyFrom: b1+1 to: b2-1).
				show _ param size = 0 ifTrue: [nil] ifFalse: [param]]
			ifFalse: ["at the front"
				param _ self validate: (aString copyFrom: b1+1 to: b2-1).
				show _ param size = 0 ifTrue: [nil] 
						ifFalse: [aString copyFrom: b2+1 to: aString size]]]
		ifFalse: [(trim last) == $>
			ifTrue: ["at the end"
				param _ self validate: (aString copyFrom: b1+1 to: b2-1).
				show _ param size = 0 ifTrue: [nil] 
						ifFalse: [aString copyFrom: 1 to: b1-1]]
			ifFalse: ["Illegal -- <> has text on both sides"
				show _ nil]].
	^ Array with: param with: show
! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:21'!
couldDeriveFromPrettyPrinting
	^ false! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:11'!
dominatedByCmd0
	"Cmd-0 should turn off active text"
	^ true! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'di 1/14/98 09:30'!
emphasizeScanner: scanner
	"Set the emphasis for text display"
	scanner textColor: Purple! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'DSM 3/30/1999 13:15'!
info
	^ 'no hidden info'! !

!TextAction methodsFor: 'as yet unclassified'!
mayActOnClick

	^ true! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:48'!
validate: aString
	"any format is OK with me"
	^ aString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextAction class
	instanceVariableNames: ''!

!TextAction class methodsFor: 'as yet unclassified' stamp: 'di 1/14/98 09:30'!
initialize   "TextAction initialize"
	Purple _ Color r: 0.4 g: 0 b: 1.0! !
TextAttribute subclass: #TextAlignment
	instanceVariableNames: 'alignment'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/15/2001 23:33'!
= other 
	^ (other class == self class) 
		and: [other alignment = alignment]! !

!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/15/2001 23:33'!
alignment
	^alignment! !

!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/15/2001 23:33'!
alignment: aNumber
	alignment _ aNumber.! !

!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/16/2001 00:20'!
dominates: other
	"There can be only one..."
	^self class == other class! !

!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/15/2001 23:34'!
emphasizeScanner: scanner
	"Set the emphasist for text scanning"
	scanner setAlignment: alignment.! !

!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 9/9/2003 22:03'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^ alignment hash! !

!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/16/2001 01:55'!
writeScanOn: strm

	strm nextPut: $a.
	alignment printOn: strm.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextAlignment class
	instanceVariableNames: ''!

!TextAlignment class methodsFor: 'instance creation' stamp: 'ar 12/15/2001 23:36'!
centered
	^self new alignment: 2! !

!TextAlignment class methodsFor: 'instance creation' stamp: 'ar 12/15/2001 23:36'!
justified
	^self new alignment: 3! !

!TextAlignment class methodsFor: 'instance creation' stamp: 'ar 12/15/2001 23:35'!
leftFlush
	^self new alignment: 0! !

!TextAlignment class methodsFor: 'instance creation' stamp: 'ar 12/15/2001 23:35'!
rightFlush
	^self new alignment: 1! !


!TextAlignment class methodsFor: 'as yet unclassified' stamp: 'KR 12/5/2005 00:53'!
alignmentSymbol: alignmentCode
	^#(leftFlush rightFlush centered justified) at: (alignmentCode + 1)! !
HashAndEqualsTestCase subclass: #TextAlignmentTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!

!TextAlignmentTest methodsFor: 'initialize-release' stamp: 'mjr 8/20/2003 18:55'!
setUp
	super setUp.
	prototypes add: TextAlignment centered;
		 add: TextAlignment justified;
		 add: TextAlignment leftFlush;
		 add: TextAlignment rightFlush ! !
TextAttribute subclass: #TextAnchor
	instanceVariableNames: 'anchoredMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextAnchor commentStamp: 'md 8/10/2006 11:52' prior: 0!
TextAnchors support anchoring of images in text.  A TextAnchor exists as an attribute of text emphasis, and it gets control like a FontReference, through the emphasizeScanner: message.  Depending on whether its anchoredMorph is a Morph or a Form, it repositions the morph, or displays the form respectively.  The coordination between composition, display and selection can best be understood by browsing the various implementations of placeEmbeddedObject:.

In the morphic world, simply embed any form or morph in text.

	Workspace new
		contents: (Text withAll: 'foo') , (Text string: '*' attribute: (TextAnchor new anchoredMorph: MenuIcons confirmIcon)) , (Text withAll: 'bar');
		openLabel: 'Text with Form'.

	Workspace new
		contents: (Text withAll: 'foo') , (Text string: '*' attribute: (TextAnchor new anchoredMorph: EllipseMorph new)) , (Text withAll: 'bar');
		openLabel: 'Text with Morph'.

In this case you select a piece of the screen, and it gets anchored to a one-character text in the editor's past buffer.  If you then paste into some other text, you will see the image as an embedded image.!


!TextAnchor methodsFor: 'accessing' stamp: 'di 11/10/97 13:21'!
anchoredMorph
	^ anchoredMorph! !

!TextAnchor methodsFor: 'accessing' stamp: 'di 11/10/97 10:47'!
anchoredMorph: aMorph 
	anchoredMorph _ aMorph! !

!TextAnchor methodsFor: 'accessing' stamp: 'sw 11/9/1999 17:21'!
couldDeriveFromPrettyPrinting
	^ false! !

!TextAnchor methodsFor: 'accessing' stamp: 'di 11/10/97 14:08'!
mayBeExtended
	"A textAnchor is designed to modify only a single character, and therefore must not be extended by the ParagraphEditor's emphasisHere facility"
	^ false! !


!TextAnchor methodsFor: 'comparing' stamp: 'di 7/1/1998 14:35'!
= other 
	^ (other class == self class) 
		and: [other anchoredMorph == anchoredMorph]! !

!TextAnchor methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:03'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^anchoredMorph identityHash! !


!TextAnchor methodsFor: 'visiting' stamp: 'lr 2/3/2006 16:13'!
emphasizeScanner: aScanner
	self anchoredMorph ifNil: [ ^ self ].
	aScanner placeEmbeddedObject: self anchoredMorph.! !
HashAndEqualsTestCase subclass: #TextAnchorTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Text Support'!

!TextAnchorTest methodsFor: 'initialize-release' stamp: 'mjr 8/20/2003 18:55'!
setUp
	super setUp.
	prototypes
		add: (TextAnchor new anchoredMorph: RectangleMorph new initialize);
		
		add: (TextAnchor new anchoredMorph: EllipseMorph new initialize) ! !
TestCase subclass: #TextAndTextStreamTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!
!TextAndTextStreamTest commentStamp: '<historical>' prior: 0!
At May 09, 2003 Tim Olson sent a bug report to the Squeak developers list that inspired me to examine the protocol of TextStream in greater detail.  (The bug that Tim reported was present in Squeak 3.4, it is shown in testExample1.) In a discussion that followed,  Daniel Vainsencher proposed that we should have tests for Text and TextStreams. This class is an attempt to implement that proposal. For Squeak 3.4, some of the test examples fail.!


!TextAndTextStreamTest methodsFor: 'examples' stamp: 'BG 6/10/2003 20:17'!
example1: size

   | ts text |

  ts := TextStream on: (Text new: size).
  ts  nextPutAll: 'xxxxx' asText.
  ts nextPutAll: ('yyyyy' asText allBold, 'zzzzzzz' asText).
  text := ts contents.
  ^text
  ! !

!TextAndTextStreamTest methodsFor: 'examples' stamp: 'BG 6/10/2003 20:26'!
example2

      | ts text |

  ts := TextStream on: (Text new: 50).
  ts  nextPutAll: 'abc' asText.
  ts nextPutAll: 'def' asText allBold.
  ts nextPutAll: 'ghijk' asText.
  text := ts contents.
  ^text
  ! !

!TextAndTextStreamTest methodsFor: 'examples' stamp: 'BG 6/11/2003 13:09'!
replacementAtStartExample3

   | text1  replacement  length  |

   text1 := 'This is a simple text' copy asText.
    " without the copy, we would modify a constant that the compiler attached at the compiled method. "
   length  := 'This' size.
   replacement := 'Tht' asText.
   text1 replaceFrom: 1 
        to:   length
        with: replacement
        startingAt: 1.
! !

!TextAndTextStreamTest methodsFor: 'examples' stamp: 'BG 6/11/2003 13:05'!
replacementExample3

  " for a Text  t,
     the following assertion should always hold:
     t string size = t run size 
    This test examines the preservation of this assertion for in-place replacement 
 Here, the replacement text is shorteer than the text that is shall replace. "


   | text1 string replacement startPos length startPosInRep string2 |

   text1 := (string := 'This is again simple text' copy) asText.
     " without the copy, we would modify a constant that the compiler attached at the compiled method. "
   startPos := string findString: 'simple'. 
   length  := 'simple' size.
   replacement := (string2 := 'both simple and short') asText.
   startPosInRep :=  string2 findString: 'short'.
   text1 replaceFrom: startPos 
        to: startPos + length - 1
        with: replacement
        startingAt: startPosInRep.
   
! !


!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:45'!
testAddStringToTextStream

	"It is possible to add a string into a TextStream.
	This test verifies that the created text has text attributes for all its characters. "

	| ts text |
	ts := TextStream on: (Text new: 50).
	ts nextPutAll: 'abc' asText.
	ts nextPutAll: 'def' asText allBold.
	ts nextPutAll: 'ghijk'.
	text := ts contents.
     " now, check the fundamental invariant of a text: "
	self assert: text string size = text runs size.
! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:40'!
testExampleText1
	"self run: #testExampleText1"
	"inspired by a bug report from Tim Olson.
	Text attributes are lost when the stream collection is expanded.
	Documented BUG!!!!!!"

    | text1 text2 atts1 atts2 |
	text1 := self example1: 10. " here we will loose the attribute bold "
	text2 := self example1: 50. " here we have a larger buffer and will not loose text attributes "
	atts1 := text1 runs copyFrom: 6 to: 10. 
	atts2 := text2 runs copyFrom: 6 to: 10. 

	self assert: atts1 = atts2.
      ! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:40'!
testExampleText2
	"a Text looses its attributes when it is reversed "
	
	| text1 text2 |
	text1 := self example2.
	text2 := text1 reversed reversed.
	self assert: text1 runs = text2 runs.
 
! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:35'!
testRunArrayAdjacentMerge

	"this demonstrates that adjancent runs with equal attributes are merged. "
	| runArray |
	runArray := RunArray new.
	runArray 
		addLast: TextEmphasis normal times: 5;
		addLast: TextEmphasis bold times: 5;
		addLast: TextEmphasis bold times: 5.
	self assert: (runArray runs size = 2). ! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:37'!
testRunArrayInvariant

	"this verifies that the fundamental invariant of a RunArray is always satisfied. "
	"see comment below"
	| runArray |
	runArray := RunArray new.
	runArray 
		addLast: TextEmphasis normal times: 5;
		addLast: TextEmphasis bold times: 5;
		addLast: TextEmphasis normal times: 5.
	self assert:
       ((1 to: runArray size) allSatisfy:
           [:idx |  | lastIndex lastOffset lastRun lengthOfPreviousRuns |
               runArray at: idx.  " updates the cached values "
               lastIndex := runArray instVarNamed: 'lastIndex'.
               lastRun := runArray instVarNamed: 'lastRun'.
               lastOffset := runArray instVarNamed: 'lastOffset'.
               lengthOfPreviousRuns 
                   := (1 to: lastRun - 1)
                      inject: 0
                       into: [:sum :idx2 | sum + (runArray runs at: idx2)].
               lastIndex = (lastOffset + lengthOfPreviousRuns + 1) 
           ]
       ). 

" This method is a bit tricky. First, it uses Object>>instVarNamed: to access instance variables for which no accessors are defined. The same method is used by the debuggers and by various inspectors.
The assertion itself explains the meaning of the cached values."! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:36'!
testRunArrayReversal

  	"this tests the reversal of a  RunArray "
	| runArray |
	runArray := RunArray new.
	runArray 
		addLast: TextEmphasis normal times: 5;
		addLast: TextEmphasis bold times: 5;
		addLast: TextEmphasis normal times: 5.
	self assert: (runArray reversed runs size = 3). ! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:32'!
testRunArrayRunsAreNotMerged

	" this demonstrates that different runs are not merged "
	| runArray |
	runArray := RunArray new.
	runArray 
		addLast: TextEmphasis normal times: 5;
		addLast: TextEmphasis bold times: 5;
		addLast: TextEmphasis normal times: 5.
	self assert: (runArray runs size = 3). ! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:33'!
testRunArrayRunsSize

 	"this demonstrates that the size of a run array is the sum of the sizes of its runs. "
	| runArray |
	runArray := RunArray new.
  	runArray 
		addLast: TextEmphasis normal times: 5;
		addLast: TextEmphasis bold times: 5;
		addLast: TextEmphasis normal times: 5.
	self assert: (runArray size = 15). ! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:49'!
testTextEmphasisRangeDetection1

	"this tests the detection of the range of a text attribute. "
	| text startPos boldStyle |
	text := 'This is a text with attriute bold for some characters' asText.
	startPos := text findString: 'bold' startingAt: 1.
	text addAttribute: TextEmphasis bold from: startPos to: startPos + 3.
	boldStyle := TextEmphasis bold.

  " uncomment the following statement for examine failures: "
  " -----------------
       (1 to: text size) do:
           [:idx | | range |
              range := text rangeOf: boldStyle startingAt: idx.
             Transcript show: startPos; show: ' -- '; show: idx printString; show: '  '; show: range printString; show: range size printString; show: ((idx between: startPos and: startPos + 3)
                  ifTrue:
                    [range first = startPos & (range size = 4)]
                  ifFalse:
                    [range first = idx & (range size = 0)]) printString; cr.
           ].
    ------------- "

	self assert: 
		((1 to: text size) allSatisfy:
			[:idx | | range |
				range := text rangeOf: boldStyle startingAt: idx.
				(idx between: startPos and: startPos + 3)
					ifTrue: [range first = startPos & (range size = 4)]
					ifFalse: [range first = idx & (range size = 0)]])! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:51'!
testTextEmphasisRangeDetection2

	"this tests the detection of the range of a text attribute.
	Here the searched attribute spans three runs. The objective of the test is whether the entire range is always found."
	| text startPos searchedStyle |
	text := 'This is a text with attriute bold for some characters' asText.
	startPos := text findString: 'bold' startingAt: 1.
	text addAttribute: TextEmphasis bold from: startPos to: startPos + 3.
	text addAttribute: TextEmphasis italic from: startPos - 2 to: startPos + 5.
	searchedStyle := TextEmphasis italic.

  " uncomment the following statement for examine failures: " 
  " -----------------------
       (1 to: text size) do:
           [:idx | | range | 
              range := text rangeOf: searchedStyle startingAt: idx.
             Transcript show: startPos; show: ' -- '; show: idx printString; show: '  '; show: range printString; show: range size printString; show: ((idx between: startPos - 2 and: startPos -2 + 7)
                  ifTrue:
                    [range first = (startPos - 2) & (range size = 8)]
                  ifFalse:
                    [range first = idx & (range size = 0)]) printString; cr.
           ].
   ----------------------- "
	self assert: 
			((1 to: text size) allSatisfy:
				[:idx | | range |
					range := text rangeOf: searchedStyle startingAt: idx.
					(idx between: startPos - 2 and: startPos -2 + 7)
						ifTrue: [range first = (startPos - 2) & (range size = 8)]
						ifFalse: [range first = idx & (range size = 0)]])! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:53'!
testTextEmphasisRangeDetection3

	"this tests the detection of the range of a text attribute.
    Here the searched attribute spans three runs. The the range to be detected begins at text position 1. The objective of the test is whether the entire range is always found."

	| text startPos searchedStyle |
	text := 'This is a text with attriute bold for some characters' asText.
	startPos := text findString: 'bold' startingAt: 1.
	text addAttribute: TextEmphasis bold from: startPos to: startPos + 3.
	text addAttribute: TextEmphasis italic from: 1 to: startPos + 5.
	searchedStyle := TextEmphasis italic.

	" uncomment the following statement to examine failures: "
 	" -----------------------
       (1 to: text size) do:
           [:idx | | range | 
              range := text rangeOf: searchedStyle startingAt: idx.
             Transcript show: startPos;
					show: ' -- ';
					show: idx printString;
					show: '  ';
					show: range printString;
					show: range size printString;
                        show: ' ';
					 show: ((idx between: 1 and: startPos + 5)
                  					ifTrue:
                  					  [range first = 1 & (range size = (startPos + 5))]
                					ifFalse:
                   					 [range first = idx & (range size = 0)]) printString; cr.
           ].
   ----------------------- "
	self assert: 
       ((1 to: text size) allSatisfy:
           [:idx | | range |
              range := text rangeOf: searchedStyle startingAt: idx.
              (idx between: 1 and: startPos + 5)
                  ifTrue:
                    [range first = 1 & (range size = (startPos + 5))]
                  ifFalse:
                    [range first = idx & (range size = 0)]])! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:55'!
testTextEmphasisRangeDetection4

	"this tests the detection of the range of a text attribute.
	Here the searched attribute spans three runs. The the range to be detected extends to the end of the text . The objective of the test is whether the 
	entire range is always found."

	| text startPos searchedStyle |
	text := 'This is a text with attriute bold for some characters' asText.
	startPos := text findString: 'bold' startingAt: 1.
	text addAttribute: TextEmphasis bold from: startPos to: startPos + 3.	
	text addAttribute: TextEmphasis italic from: startPos - 2 to: text size.
	searchedStyle := TextEmphasis italic.

	" uncomment the following statement to examine failures: "
 
 	" -----------------------------------------
       (1 to: text size) do:
           [:idx | | range | 
              range := text rangeOf: searchedStyle startingAt: idx.
             Transcript show: startPos;
					show: ' -- ';
					show: idx printString;
					show: '  ';
					show: range printString;
					show: range size printString;
                        show: ' ';
					 show: ((idx between: startPos - 2 and: text size)
                  			ifTrue:
   			                 [range first = (startPos - 2) & (range size = (text size - (startPos - 2) + 1))]
                  			ifFalse:
 			                 [range first = idx & (range size = 0)]) printString;
					cr.
           ].
   -------------------------------"

	self assert: 
       ((1 to: text size) allSatisfy:
           [:idx | | range |
              range := text rangeOf: searchedStyle startingAt: idx.
              (idx between: startPos - 2 and: text size)
                  ifTrue: [range first = (startPos - 2) & (range size = (text size - (startPos - 2) + 1))]
                  ifFalse: [range first = idx & (range size = 0)]])! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:56'!
testTextReplacement1

	"for a Text  t,
     the following assertion should always hold:
     t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement "

   | text1 string replacement startPos length startPosInRep string2 |
   text1 := (string := 'This is a simple text' copy) asText.
   "without the copy, we would modify a constant that the compiler attached at the compiled method. "
   startPos := string findString: 'simple'. 
   length  := 'simple' size.
   replacement := (string2 := 'both simple and short*') asText.
   startPosInRep :=  string2 findString: 'short'.
   text1 replaceFrom: startPos 
        to: startPos + length - 1
        with: replacement
        startingAt: startPosInRep.
   self assert: text1 string size = text1 runs size.
! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:57'!
testTextReplacement2


  	"for a Text  t,
     the following assertion should always hold:
     t string size = t run size 
    	This test examines the preservation of this assertion for in-place replacement.
    	Here, the replacement text has trailing characters. "

	| text1 string replacement startPos length startPosInRep string2 |
	text1 := (string := 'This is simple text' copy) asText.
	"without the copy, we would modify a constant that the compiler attached at the compiled method. "
	startPos := string findString: 'simple'. 
	length := 'simple' size.
	replacement := (string2 := 'both simple and short*************') asText.
	startPosInRep :=  string2 findString: 'short'.
	text1 replaceFrom: startPos 
        to: startPos + length - 1
        with: replacement
        startingAt: startPosInRep.
	self assert: text1 string size = text1 runs size.
! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:58'!
testTextReplacement3

	"for a Text  t,
	the following assertion should always hold:
	t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement 
	Here, the replacement text is shorteer than the text that is shall replace. "

	self should: [self replacementExample3]  raise: Error! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:59'!
testTextReplacementAtStartPos1

	"for a Text  t,
     the following assertion should always hold:
     t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement "

	| text1  replacement  length  |
	text1 := 'This is a simple text' copy asText.
	"without the copy, we would modify a constant that the compiler attached at the compiled method. "
	length  := 'This' size.
	replacement := 'That' asText.
	text1 replaceFrom: 1 
        to:   length
        with: replacement
        startingAt: 1.
	self assert: text1 string size = text1 runs size.
! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:00'!
testTextReplacementAtStartPos2

  	"for a Text  t,
     the following assertion should always hold:
     t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement "

	| text1  replacement  length  |
	text1 := 'This is a simple text' copy asText.
	"without the copy, we would modify a constant that the compiler attached at the compiled method. "
	length  := 'This' size.
	replacement := 'That********' asText.
	text1 replaceFrom: 1 
        to:   length
        with: replacement
        startingAt: 1.
	self assert: text1 string size = text1 runs size.
! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:00'!
testTextReplacementAtStartPos3

	"for a Text  t,
	the following assertion should always hold:
	t string size = t run size 
	This test examines the preservation of this assertion for in-place replacement 
	Here, the replacement text is shorteer than the text that is shall replace. "

	self should: [self replacementAtStartExample3] raise: Error! !

!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:44'!
testTextStreamAdjacentRunsWithIdentitcalAttributes

	"This test verifies that adjacent runs with identical attributes are coalesced."

	| ts text rangeOfBold |
	ts := TextStream on: (Text new: 50).
	ts nextPutAll: 'abc' asText.
	ts nextPutAll: 'def' asText allBold.
	ts nextPutAll: 'ghijk'.
	text := ts contents.
	rangeOfBold := text find:  TextEmphasis bold.
	text removeAttribute: TextEmphasis bold from: rangeOfBold first to: rangeOfBold last. 
     "now, check that only one run is left and that it has the correct size "
	self assert: text runs runs size = 1 & (text runs size = text string size).
! !
Object subclass: #TextAttribute
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextAttribute commentStamp: 'tk 7/22/2002 18:33' prior: 0!
Tells a piece of text to be a certain way.

Select text, press Command-6, choose a attribute.  If selected text is of the form 
	Hi There<Smalltalk beep>
the part in angle brackets is saved for action, and the Hi There appears in the paragraph.  If selection has no angle brackets, use the whole thing as both the text and the action.

TextDoIt  --  eval as a Smalltalk expression (the part in angle brackets)

TextLink -- Show a method, class comment, class hierarchy, or class defintion.
	<Point extent:>, <Point Comment>, <Point Hierarchy>, or <Point Defintion> are what you type.

TextURL -- Show the web page. <www.disney.com>

These attributes of text need to be stored on the disk in a regular file-out.  It is done in this form: 	Hi There   
	in the text, and a Run containing   dSmalltalk beep;;
	Click here to see the extent:   
	in the text, and a Run containing   method LPoint extent:;
See RunArray class scanFrom: where decoding is done.
!
]style[(903 24 25)f1,f1LRunArray class scanFrom:;,f1!


!TextAttribute methodsFor: 'as yet unclassified'!
actOnClickFor: model
	"Subclasses may override to provide, eg, hot-spot actions"
	^ false! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'ar 9/22/2001 16:00'!
actOnClickFor: model in: aParagraph
	^self actOnClickFor: model! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'ar 9/22/2001 16:08'!
actOnClickFor: model in: aParagraph at: clickPoint
	^self actOnClickFor: model in: aParagraph! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'ar 9/22/2001 16:22'!
actOnClickFor: model in: aParagraph at: clickPoint editor: editor
	^self actOnClickFor: model in: aParagraph at: clickPoint! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'ar 12/16/2001 23:18'!
anchoredMorph
	"If one hides here, return it"
	^nil! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:25'!
couldDeriveFromPrettyPrinting
	"Answer whether the receiver is a kind of attribute that could have been generated by doing polychrome pretty-printing of a method without functional text attributes."

	^ true! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:09'!
dominatedByCmd0
	"Subclasses may override if cmd-0 should turn them off"
	^ false! !

!TextAttribute methodsFor: 'as yet unclassified'!
dominates: another
	"Subclasses may override condense multiple attributes"
	^ false! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 4/1/1999 15:16'!
emphasisCode
	"Subclasses may override to add bold, italic, etc"
	^ 0! !

!TextAttribute methodsFor: 'as yet unclassified'!
emphasizeScanner: scanner
	"Subclasses may override to set, eg, font, color, etc"! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:46'!
forFontInStyle: aTextStyle do: aBlock
	"No action is the default.  Overridden by font specs"! !

!TextAttribute methodsFor: 'as yet unclassified'!
mayActOnClick
	"Subclasses may override to provide, eg, hot-spot actions"
	^ false! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 11/10/97 14:05'!
mayBeExtended
	"A quality that may be overridden by subclasses, such as TextAnchors, that really only apply to a single character"
	^ true! !

!TextAttribute methodsFor: 'as yet unclassified'!
oldEmphasisCode: default
	"Allows running thorugh possibly multiple attributes
	and getting the emphasis out of any that has an emphasis (font number)"
	^ default! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:03'!
reset
	"Allow subclasses to prepare themselves for merging attributes"! !

!TextAttribute methodsFor: 'as yet unclassified'!
set
	"Respond true to include this attribute (as opposed to, eg, a bold
	emphasizer that is clearing the property"
	^ true! !


!TextAttribute methodsFor: 'testing' stamp: 'ar 9/21/2000 14:16'!
isKern
	^false! !


!TextAttribute methodsFor: 'html' stamp: 'dgd 9/2/2005 12:39'!
closeHtmlOn: aStream 
	"put on the given stream the tag to close the html  
	representation of the receiver"
	self subclassResponsibility! !

!TextAttribute methodsFor: 'html' stamp: 'dgd 9/2/2005 12:38'!
openHtmlOn: aStream 
	"put on the given stream the tag to open the html  
	representation of the receiver"
	self subclassResponsibility! !
TextAttribute subclass: #TextColor
	instanceVariableNames: 'color'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextColor commentStamp: '<historical>' prior: 0!
A TextColor encodes a text color change applicable over a given range of text.!


!TextColor methodsFor: 'accessing'!
color
	^ color! !

!TextColor methodsFor: 'accessing'!
color: aColor
	color _ aColor! !


!TextColor methodsFor: 'comparing' stamp: 'di 10/31/97 11:19'!
= other 
	^ (other class == self class) 
		and: [other color = color]! !

!TextColor methodsFor: 'comparing' stamp: 'sma 3/24/2000 10:51'!
hash
	^ color hash! !


!TextColor methodsFor: 'printing' stamp: 'sma 3/24/2000 10:51'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' code: '; print: color! !


!TextColor methodsFor: 'scanning' stamp: 'di 10/31/97 11:20'!
dominates: other
	^ other class == self class! !

!TextColor methodsFor: 'scanning'!
emphasizeScanner: scanner
	"Set the emphasis for text display"
	scanner textColor: color! !

!TextColor methodsFor: 'scanning' stamp: 'tk 12/16/97 09:47'!
writeScanOn: strm
	"Two formats.  c125000255 or cblue;"

	| nn str |
	strm nextPut: $c.
	(nn _ color name) ifNotNil: [
		(self class respondsTo: nn) ifTrue: [
			^ strm nextPutAll: nn; nextPut: $;]].
	(Array with: color red with: color green with: color blue) do: [:float |
		str _ '000', (float * 255) asInteger printString.
		strm nextPutAll: (str copyFrom: str size-2 to: str size)]! !


!TextColor methodsFor: 'html' stamp: 'dgd 9/2/2005 12:39'!
closeHtmlOn: aStream 
	"put on the given stream the tag to close the html  
	representation of the receiver"
	aStream nextPutAll: '</font>'! !

!TextColor methodsFor: 'html' stamp: 'dgd 9/2/2005 12:38'!
openHtmlOn: aStream 
	"put on the given stream the tag to open the html  
	representation of the receiver"
	aStream nextPutAll: '<font color="#' , color printHtmlString , '">'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextColor class
	instanceVariableNames: ''!

!TextColor class methodsFor: 'constants'!
black
	^ self new color: Color black! !

!TextColor class methodsFor: 'constants'!
blue
	^ self new color: Color blue! !

!TextColor class methodsFor: 'constants'!
cyan
	^ self new color: Color cyan! !

!TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26'!
gray
	^ self new color: Color gray! !

!TextColor class methodsFor: 'constants'!
green
	^ self new color: Color green! !

!TextColor class methodsFor: 'constants'!
magenta
	^ self new color: Color magenta! !

!TextColor class methodsFor: 'constants'!
red
	^ self new color: Color red! !

!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50'!
white 
	^ self new color: Color white! !

!TextColor class methodsFor: 'constants'!
yellow
	^ self new color: Color yellow! !


!TextColor class methodsFor: 'instance creation'!
color: aColor
	^ self new color: aColor! !

!TextColor class methodsFor: 'instance creation' stamp: 'sma 3/24/2000 10:49'!
scanFrom: strm
	"read a color in the funny format used by Text styles on files. c125000255 or cblue;"

	| r g b |
	strm peek isDigit
		ifTrue:
			[r _ (strm next: 3) asNumber.
			g _ (strm next: 3) asNumber.
			b _ (strm next: 3) asNumber.
			^ self color: (Color r: r g: g b: b range: 255)].
	"A name of a color"
	^ self color: (Color perform: (strm upTo: $;) asSymbol)! !
PluggableTextMorph subclass: #TextComponent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!TextComponent methodsFor: 'components' stamp: 'di 5/3/1998 20:24'!
initComponentIn: aLayout
	super initComponentIn: aLayout.
	self setText: self getText! !

!TextComponent methodsFor: 'components' stamp: 'gm 2/28/2003 00:35'!
initFromPinSpecs
	| ioPin |
	ioPin := pinSpecs first.
	getTextSelector := ioPin isInput 
		ifTrue: [ioPin modelReadSelector]
		ifFalse: [nil].
	setTextSelector := ioPin isOutput 
				ifTrue: [ioPin modelWriteSelector]
				ifFalse: [nil]! !

!TextComponent methodsFor: 'components' stamp: 'di 5/1/1998 13:39'!
initPinSpecs 
	pinSpecs _ Array
		with: (PinSpec new pinName: 'text' direction: #inputOutput
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: getTextSelector modelWriteSelector: setTextSelector
				defaultValue: 'some text' pinLoc: 1.5)! !


!TextComponent methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:25'!
initialize
	"initialize the state of the receiver"
	super initialize.
	self extent: 144 @ 42! !
Object subclass: #TextComposer
	instanceVariableNames: 'lines maxRightX currentY scanner possibleSlide nowSliding prevIndex prevLines currCharIndex startCharIndex stopCharIndex deltaCharIndex theText theContainer isFirstLine theTextStyle defaultLineHeight actualHeight wantsColumnBreaks'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!

!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 18:09'!
addNullLineForIndex: index
"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic."

	| oldLastLine r |

	oldLastLine _ lines last.
	oldLastLine last - oldLastLine first >= 0 ifFalse: [^self].
	oldLastLine last = (index - 1) ifFalse: [^self].

	r _ oldLastLine left @ oldLastLine bottom 
				extent: 0@(oldLastLine bottom - oldLastLine top).
	"Even though we may be below the bottom of the container,
	it is still necessary to compose the last line for consistency..."

	self addNullLineWithIndex: index andRectangle: r.
! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/5/2001 11:05'!
addNullLineWithIndex: index andRectangle: r

	lines addLast: (
		(
			TextLine 
				start: index 
				stop: index - 1
				internalSpaces: 0 
				paddingWidth: 0
		)
			rectangle: r;
			lineHeight: defaultLineHeight baseline: theTextStyle baseline
	)
! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 11:33'!
checkIfReadyToSlide

	"Check whether we are now in sync with previously composed lines"

	(possibleSlide and: [currCharIndex > stopCharIndex]) ifFalse: [^self].

	[prevIndex < prevLines size
		and: [(prevLines at: prevIndex) first < (currCharIndex - deltaCharIndex)]]
			whileTrue: [prevIndex _ prevIndex + 1].

	(prevLines at: prevIndex) first = (currCharIndex - deltaCharIndex) ifTrue: [
		"Yes -- next line will have same start as prior line."
		prevIndex _ prevIndex - 1.
		possibleSlide _ false.
		nowSliding _ true
	] ifFalse: [
		prevIndex = prevLines size ifTrue: [
			"Weve reached the end of prevLines, so no use to keep looking for lines to slide."
			possibleSlide _ false
		]
	]! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 14:48'!
composeAllLines

	[currCharIndex <= theText size and: 
			[(currentY + defaultLineHeight) <= theContainer bottom]] whileTrue: [

		nowSliding ifTrue: [
			self slideOneLineDown ifNil: [^nil].
		] ifFalse: [
			self composeOneLine ifNil: [^nil].
		]
	].
! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'th 11/18/2002 19:13'!
composeAllRectangles: rectangles

	| charIndexBeforeLine numberOfLinesBefore reasonForStopping |

	actualHeight _ defaultLineHeight.
	charIndexBeforeLine _ currCharIndex.
	numberOfLinesBefore _ lines size.
	reasonForStopping _ self composeEachRectangleIn: rectangles.

	currentY _ currentY + actualHeight.
	currentY > theContainer bottom ifTrue: [
		"Oops -- the line is really too high to fit -- back out"
		currCharIndex _ charIndexBeforeLine.
		lines size - numberOfLinesBefore timesRepeat: [lines removeLast].
		^self
	].
	
	"It's OK -- the line still fits."
	maxRightX _ maxRightX max: scanner rightX.
	1 to: rectangles size - 1 do: [ :i |
		"Adjust heights across rectangles if necessary"
		(lines at: lines size - rectangles size + i)
			lineHeight: lines last lineHeight
			baseline: lines last baseline
	].
	isFirstLine _ false.
	reasonForStopping == #columnBreak ifTrue: [^nil].
	currCharIndex > theText size ifTrue: [
		^nil		"we are finished composing"
	].
	! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'ar 12/17/2001 01:59'!
composeEachRectangleIn: rectangles

	| myLine lastChar |

	1 to: rectangles size do: [:i | 
		currCharIndex <= theText size ifFalse: [^false].
		myLine _ scanner 
			composeFrom: currCharIndex 
			inRectangle: (rectangles at: i)				
			firstLine: isFirstLine 
			leftSide: i=1 
			rightSide: i=rectangles size.
		lines addLast: myLine.
		actualHeight _ actualHeight max: myLine lineHeight.  "includes font changes"
		currCharIndex _ myLine last + 1.
		lastChar _ theText at: myLine last.
		lastChar = Character cr ifTrue: [^#cr].
		wantsColumnBreaks ifTrue: [
			lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak].
		].
	].
	^false! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 10:11'!
composeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks

	wantsColumnBreaks _ argWantsColumnBreaks.
	lines _ argLinesCollection.
	theTextStyle _ argTextStyle.
	theText _ argText.
	theContainer _ argContainer.
	deltaCharIndex _ argDelta.
	currCharIndex _ startCharIndex _ argStart.
	stopCharIndex _ argStop.
	prevLines _ argPriorLines.
	currentY _ argStartY.
	defaultLineHeight _ theTextStyle lineGrid.
	maxRightX _ theContainer left.
	possibleSlide _ stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle].
	nowSliding _ false.
	prevIndex _ 1.
	scanner _ CompositionScanner new text: theText textStyle: theTextStyle.
	scanner wantsColumnBreaks: wantsColumnBreaks.
	isFirstLine _ true.
	self composeAllLines.
	isFirstLine ifTrue: ["No space in container or empty text"
		self 
			addNullLineWithIndex: startCharIndex
			andRectangle: (theContainer topLeft extent: 0@defaultLineHeight)
	] ifFalse: [
		self fixupLastLineIfCR
	].
	^{lines asArray. maxRightX}

! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 13:31'!
composeOneLine
	| rectangles |
	rectangles := theContainer rectanglesAt: currentY height: defaultLineHeight.
	rectangles notEmpty 
		ifTrue: [(self composeAllRectangles: rectangles) ifNil: [^nil]]
		ifFalse: [currentY := currentY + defaultLineHeight].
	self checkIfReadyToSlide! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 18:09'!
fixupLastLineIfCR
"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic."

	(theText size > 1 and: [theText last = Character cr]) ifFalse: [^self].
	self addNullLineForIndex: theText size + 1.
! !

!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 15:15'!
slideOneLineDown

	| priorLine |

	"Having detected the end of rippling recoposition, we are only sliding old lines"
	prevIndex < prevLines size ifFalse: [
		"There are no more prevLines to slide."
		^nowSliding _ possibleSlide _ false
	].

	"Adjust and re-use previously composed line"
	prevIndex _ prevIndex + 1.
	priorLine _ (prevLines at: prevIndex)
				slideIndexBy: deltaCharIndex andMoveTopTo: currentY.
	lines addLast: priorLine.
	currentY _ priorLine bottom.
	currCharIndex _ priorLine last + 1.
	wantsColumnBreaks ifTrue: [
		priorLine first to: priorLine last do: [ :i |
			(theText at: i) = TextComposer characterForColumnBreak ifTrue: [
				nowSliding _ possibleSlide _ false.
				^nil
			].
		].
	].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextComposer class
	instanceVariableNames: ''!

!TextComposer class methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 09:31'!
characterForColumnBreak

	^Character value: 12! !
Object subclass: #TextContainer
	instanceVariableNames: 'textMorph shadowForm vertProfile minWidth rectangleCache fillsOwner avoidsOcclusions'
	classVariableNames: 'OuterMargin'
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextContainer commentStamp: '<historical>' prior: 0!
A TextContainer models the shape of an ownerMorph, possibly occluded by one or more occludingMorphs, and scans this shape to provide a list of rectangles suitable for layout of text.  It does this by displaying the shadow of the ownerMorph in black, and any occludingMorphs in white, on its shadowForm.  It then scans horizontal strips of appropriate height to find unbroken intervals of black, greater than minWidth in extent.  Conputation of the rectangles is done on demand, and results are cached so that text can be redisplayed without having to recompute the rectangles.!


!TextContainer methodsFor: 'access' stamp: 'di 11/4/97 14:05'!
avoidsOcclusions
	^ avoidsOcclusions ifNil: [false]! !

!TextContainer methodsFor: 'access' stamp: 'di 11/13/97 14:45'!
avoidsOcclusions: aBoolean
	avoidsOcclusions _ aBoolean.
	self releaseCachedState! !

!TextContainer methodsFor: 'access' stamp: 'di 11/4/97 14:05'!
fillsOwner
	^ fillsOwner ifNil: [true]! !

!TextContainer methodsFor: 'access' stamp: 'di 11/13/97 14:45'!
fillsOwner: aBoolean
	fillsOwner _ aBoolean.
	self releaseCachedState! !

!TextContainer methodsFor: 'access' stamp: 'yo 1/3/2003 12:21'!
paragraphClass
	^ MultiNewParagraph! !

!TextContainer methodsFor: 'access' stamp: 'di 11/16/97 09:39'!
releaseCachedState

	shadowForm _ nil.
	vertProfile _ nil.
	rectangleCache _ Dictionary new.
! !

!TextContainer methodsFor: 'access' stamp: 'tk 8/31/2000 14:50'!
textMorph
	^ textMorph! !


!TextContainer methodsFor: 'container protocol' stamp: 'di 10/27/97 23:09'!
bottom
	"Note we should really check for contiguous pixels here"
	^ (self vertProfile findLast: [:count | count >= minWidth])
		+ shadowForm offset y! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:33'!
left 
	^ textMorph owner left! !

!TextContainer methodsFor: 'container protocol' stamp: 'dgd 2/22/2003 19:06'!
rectanglesAt: lineY height: lineHeight 
	"Return a list of rectangles that are at least minWidth wide
	in the specified horizontal strip of the shadowForm.
	Cache the results for later retrieval if the owner does not change."

	| hProfile rects thisWidth thisX count pair outerWidth lineRect lineForm |
	pair := Array with: lineY with: lineHeight.
	rects := rectangleCache at: pair ifAbsent: [nil].
	rects ifNotNil: [^rects].
	outerWidth := minWidth + (2 * OuterMargin).
	self shadowForm.	"Compute the shape"
	lineRect := 0 @ (lineY - shadowForm offset y) 
				extent: shadowForm width @ lineHeight.
	lineForm := shadowForm copy: lineRect.

	"Check for a full line -- frequent case"
	(lineForm tallyPixelValues second) = lineRect area 
		ifTrue: 
			[rects := Array with: (shadowForm offset x @ lineY extent: lineRect extent)]
		ifFalse: 
			["No such luck -- scan the horizontal profile for segments of minWidth"

			hProfile := lineForm xTallyPixelValue: 1 orNot: false.
			rects := OrderedCollection new.
			thisWidth := 0.
			thisX := 0.
			1 to: hProfile size
				do: 
					[:i | 
					count := hProfile at: i.
					count >= lineHeight 
						ifTrue: [thisWidth := thisWidth + 1]
						ifFalse: 
							[thisWidth >= outerWidth 
								ifTrue: 
									[rects addLast: ((thisX + shadowForm offset x) @ lineY 
												extent: thisWidth @ lineHeight)].
							thisWidth := 0.
							thisX := i]].
			thisWidth >= outerWidth 
				ifTrue: 
					[rects addLast: ((thisX + shadowForm offset x) @ lineY 
								extent: thisWidth @ lineHeight)]].
	rects := rects collect: [:r | r insetBy: OuterMargin @ 0].
	rectangleCache at: pair put: rects.
	^rects! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 11/16/97 09:33'!
top
	"Note we should really check for contiguous pixels here"
	| outerWidth |
	outerWidth _ minWidth + (2*OuterMargin).
	^ (self vertProfile findFirst: [:count | count >= outerWidth]) - 1
		+ shadowForm offset y! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:33'!
topLeft  "for compatibility"
	^ textMorph owner topLeft! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 11/7/97 12:01'!
translateBy: delta
	self releaseCachedState! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:32'!
width  "for compatibility"
	^ textMorph owner width! !


!TextContainer methodsFor: 'private' stamp: 'ar 10/26/2000 20:04'!
bounds
	| bounds theText |
	self fillsOwner ifFalse: [^ textMorph textBounds].
	theText _ textMorph.
	bounds _ theText owner innerBounds.
	bounds _ bounds insetBy: (textMorph valueOfProperty: #margins ifAbsent: [1@1]).
	theText owner submorphsBehind: theText do:
		[:m | bounds _ bounds merge: m fullBounds].
	^ bounds! !

!TextContainer methodsFor: 'private' stamp: 'ar 10/26/2000 20:05'!
computeShadow
	| canvas back bounds theText |
	bounds _ self bounds.
	theText _ textMorph.
	canvas _ (Display defaultCanvasClass extent: bounds extent depth: 1)
			shadowColor: Color black.
	canvas translateBy: bounds topLeft negated during:[:tempCanvas|
		self fillsOwner
			ifTrue: [tempCanvas fullDrawMorph: (theText owner copyWithoutSubmorph: theText)]
			ifFalse: [tempCanvas fillRectangle: textMorph bounds color: Color black].
		self avoidsOcclusions ifTrue:
			[back _ tempCanvas form deepCopy.
			tempCanvas form fillWhite.
			theText owner submorphsInFrontOf: theText do:
				[:m | (textMorph isLinkedTo: m)
					ifTrue: []
					ifFalse: [tempCanvas fullDrawMorph: m]].
			back displayOn: tempCanvas form at: 0@0 rule: Form reverse].
	].
	shadowForm _ canvas form offset: bounds topLeft.
	vertProfile _ shadowForm  yTallyPixelValue: 1 orNot: false.
	rectangleCache _ Dictionary new.
	^ shadowForm! !

!TextContainer methodsFor: 'private' stamp: 'di 11/4/97 14:06'!
for: aTextMorph minWidth: wid
	textMorph _ aTextMorph.
	minWidth _ wid.
	fillsOwner _ true.
	avoidsOcclusions _ false.! !

!TextContainer methodsFor: 'private' stamp: 'di 10/27/97 23:09'!
shadowForm
	shadowForm ifNil: [self computeShadow].
	^ shadowForm! !

!TextContainer methodsFor: 'private' stamp: 'di 10/27/97 23:08'!
vertProfile
	vertProfile ifNil: [self computeShadow].
	^ vertProfile! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextContainer class
	instanceVariableNames: ''!

!TextContainer class methodsFor: 'class initialization' stamp: 'di 11/16/97 09:25'!
initialize    "TextContainer initialize"
	OuterMargin _ 2! !
Object subclass: #TextConverter
	instanceVariableNames: 'acceptingEncodings'
	classVariableNames: ''
	poolDictionaries: 'EventSensorConstants'
	category: 'Multilingual-TextConversion'!
!TextConverter commentStamp: '<historical>' prior: 0!
The abstract class for all different type of text converters.  nextFromStream: and nextPut:toStream: are the public accessible methods.  If you are going to make a subclass for a stateful text conversion, you should override restoreStateOf:with: and saveStateOf: along the line of CompoundTextConverter.
!


!TextConverter methodsFor: 'conversion' stamp: 'yo 8/19/2002 15:27'!
nextFromStream: aStream

	self subclassResponsibility.
! !

!TextConverter methodsFor: 'conversion' stamp: 'yo 8/19/2002 15:27'!
nextPut: aCharacter toStream: aStream

	self subclassResponsibility.
! !


!TextConverter methodsFor: 'friend' stamp: 'yo 8/19/2002 15:27'!
currentCharSize

	self subclassResponsibility.
! !

!TextConverter methodsFor: 'friend' stamp: 'yo 7/29/2003 15:51'!
emitSequenceToResetStateIfNeededOn: aStream
! !

!TextConverter methodsFor: 'friend' stamp: 'yo 2/21/2004 03:26'!
restoreStateOf: aStream with: aConverterState

	aStream position: aConverterState.
! !

!TextConverter methodsFor: 'friend' stamp: 'yo 2/21/2004 03:59'!
saveStateOf: aStream

	^ aStream position.
! !


!TextConverter methodsFor: 'query' stamp: 'yo 8/19/2002 15:27'!
accepts: aSymbol

	self subclassResponsibility.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextConverter class
	instanceVariableNames: ''!

!TextConverter class methodsFor: 'instance creation' stamp: 'yo 12/28/2003 00:54'!
default

	^ UTF8TextConverter new.
! !

!TextConverter class methodsFor: 'instance creation' stamp: 'yo 7/25/2003 14:08'!
defaultConverterClassForEncoding: encodingName
	"TextConverter defaultConverterClassForEncoding: 'shift-jis'"

	^ self allSubclasses
		detect: [:class | class encodingNames includes: encodingName]
		ifNone: []
! !

!TextConverter class methodsFor: 'instance creation' stamp: 'mir 7/20/2004 15:51'!
defaultSystemConverter

	^LanguageEnvironment defaultSystemConverter! !

!TextConverter class methodsFor: 'instance creation' stamp: 'yo 2/21/2004 04:56'!
newForEncoding: aString 
	| class encoding |
	aString ifNil: [^ Latin1TextConverter new].
	encoding _ aString asLowercase.
	class _ self allSubclasses
				detect: [:each | each encodingNames includes: encoding]
				ifNone: [].
	class isNil
		ifTrue: [^ nil].
	^ class new! !


!TextConverter class methodsFor: 'utilities' stamp: 'yo 7/5/2004 19:41'!
allEncodingNames
	"TextConverter allEncodingNames"
	| encodingNames |
	encodingNames _ Set new.
	self allSubclasses
		do: [:each | 
			| names | 
			names _ each encodingNames.
			names notEmpty
				ifTrue: [encodingNames add: names first asSymbol]].
	^encodingNames! !

!TextConverter class methodsFor: 'utilities' stamp: 'yo 8/19/2002 15:28'!
encodingNames 

	^ #() copy.
! !
Object subclass: #TextDiffBuilder
	instanceVariableNames: 'realSrc realDst srcMap dstMap srcLines dstLines srcPos dstPos added removed shifted runs matches multipleMatches patchSequence'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FilePackage'!

!TextDiffBuilder methodsFor: 'creating patches'!
buildDisplayPatch
	^Text streamContents:[:stream|
		self printPatchSequence: self buildPatchSequence on: stream.
	]! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'RAA 5/2/2001 23:35'!
buildPatchSequence
	"@@ TODO: Das funktioniert noch nicht für n-m matches"
	matches := TwoLevelDictionary new.
	self buildReferenceMap.
	runs := self processDiagonals.
	self validateRuns: runs.
	"There may be things which have just been moved around. Find those."
	shifted := self detectShiftedRuns.
	self processShiftedRuns.
	"Now generate a patch sequence"
	patchSequence := self generatePatchSequence.
	^patchSequence! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 16:57'!
buildReferenceMap
	dstLines doWithIndex:[:line :index|
		(srcPos at: line ifAbsent:[#()]) 
			do:[:index2| matches at: index@index2 put: line]
	].
	srcLines doWithIndex:[:line :index|
		(dstPos at: line ifAbsent:[#()]) 
			do:[:index2| matches at: index2@index put: line]
	].
! !

!TextDiffBuilder methodsFor: 'creating patches'!
collectRunFrom: todo startingWith: startIndex into: run
	| next start |
	start := startIndex.
	self remove: start from: todo.
	run add: (matches at: start).
	"Search downwards"
	next := start.
	[next := next + (1@1).
	todo includes: next] whileTrue:[
		run addLast: (matches at: next).
		self remove: next from: todo].
	"Search upwards"
	next := start.
	[next := next - (1@1).
	todo includes: next] whileTrue:[
		run addFirst: (matches at: next).
		self remove: next from: todo.
		start := next. "To use the first index"
	].
	^start! !

!TextDiffBuilder methodsFor: 'creating patches'!
detectShiftedRuns
	| sortedRuns lastY run shiftedRuns |
	runs size < 2 ifTrue: [^ nil].
	shiftedRuns _ OrderedCollection new.
	sortedRuns _ SortedCollection sortBlock: [:a1 :a2 | a1 key x < a2 key x].
	runs associationsDo: [:assoc | sortedRuns add: assoc].
	lastY _ sortedRuns first key y.
	2 to: sortedRuns size do:[:i | 
		run _ sortedRuns at: i.
		run key y > lastY
			ifTrue: [lastY _ run key y]
			ifFalse: [shiftedRuns add: run]].
	^ shiftedRuns! !

!TextDiffBuilder methodsFor: 'creating patches'!
generatePatchSequence
	| ps |
	ps := OrderedCollection new: srcLines size.
	srcLines size timesRepeat:[ps add: nil].
	self incorporateMatchesInto: ps.
	self incorporateRemovalsInto: ps.
	self incorporateAddsInto: ps.
	^ps! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'di 3/15/1999 14:01'!
incorporateAddsInto: aPatchSequence
	"Incorporate adds"
	| lastMatch lastIndex index |
	added ifNil:[^self].
	added := added sortBy:[:a1 :a2| a1 key < a2 key].
	lastMatch := 1.
	lastIndex := 0.
	1 to: added size do:[:i|
		index := (added at: i) key.
		[index > lastMatch] whileTrue:[
			[lastIndex := lastIndex + 1.
			(aPatchSequence at: lastIndex) key == #match] whileFalse.
			lastMatch := lastMatch + 1.
		].
		aPatchSequence add: #insert->(added at: i) value afterIndex: lastIndex.
		lastIndex := lastIndex + 1.
		lastMatch := lastMatch + 1.
	].! !

!TextDiffBuilder methodsFor: 'creating patches'!
incorporateMatchesInto: aPatchSequence
	"Incorporate matches"
	| index |
	runs associationsDo:[:assoc|
		index := assoc key y.
		assoc value do:[:line|
			self assert:[(aPatchSequence at: index) isNil].
			aPatchSequence at: index put: (#match -> line).
			index := index + 1.
		].
	].
! !

!TextDiffBuilder methodsFor: 'creating patches'!
incorporateRemovalsInto: aPatchSequence
	"Incorporate removals"
	| index |
	removed ifNil:[^self].
	removed do:[:assoc|
		index := assoc key.
		self assert:[(aPatchSequence at: index) isNil].
		aPatchSequence at: index put: #remove -> assoc value.
	].
! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'RAA 5/2/2001 23:41'!
processDiagonals

	^self processDiagonalsFrom: matches twoLevelKeys
! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'RAA 5/2/2001 23:17'!
processDiagonalsFrom: todoList
	| runList start run todo |
	todo := todoList copy.
	runList := PluggableDictionary new.
	runList hashBlock: self pointHashBlock.
	runList equalBlock: self pointEqualBlock.
	[todo isEmpty] whileFalse:[
		start := todo detect:[:any| true].
		run := OrderedCollection new.
		start := self 
					collectRunFrom: todo 
					startingWith: start 
					into: run.
		runList at: start put: run.
	].
	"If we have multiple matches we might have chosen a bad sequence.
	There we redo the whole thing recursively"
	self hasMultipleMatches  ifFalse:[^runList].
	runList size < 2 ifTrue:[^runList].

	run := nil.
	start := 0.
	runList associationsDo:[:assoc|
		(run isNil or:[assoc value size > run size]) ifTrue:[
			run := assoc value.
			start := assoc key]].
	"Now found the longest run"
	run := OrderedCollection new.
	start := self
				collectRunFrom: todoList
				startingWith: start
				into: run.
	"Find the diagonals in the remaining set"
	runList := self processDiagonalsFrom: todoList.
	runList at: start put: run.
	^runList! !

!TextDiffBuilder methodsFor: 'creating patches'!
processShiftedRuns
	| key |
	shifted isNil ifTrue:[^self].
	shifted do:[:assoc|
		key := assoc key.
		assoc value doWithIndex:[:line :idx|
			removed add: (key y + idx - 1) -> line.
			added add: (key x + idx - 1) -> line].
		runs removeKey: assoc key.
	].
! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 17:26'!
validateRuns: runList
	| srcPosCopy dstPosCopy lines srcIndex dstIndex |
	srcPosCopy _ srcPos copy.
	srcPosCopy associationsDo:[:assoc| assoc value: assoc value asSet].
	dstPosCopy _ dstPos copy.
	dstPosCopy associationsDo:[:assoc| assoc value: assoc value asSet].
	runList associationsDo:[:assoc|
		srcIndex := assoc key y.
		dstIndex := assoc key x.
		lines := assoc value.
		lines do:[:string|
			(srcPosCopy at: string) remove: srcIndex.
			(dstPosCopy at: string) remove: dstIndex.
			srcIndex := srcIndex + 1.
			dstIndex := dstIndex + 1.
		].
	].
	removed := OrderedCollection new.
	srcPosCopy associationsDo:[:assoc|
		assoc value do:[:index| removed add: (index -> assoc key)].
	].
	removed := removed sortBy:[:a1 :a2| a1 key < a2 key].
	added := OrderedCollection new.
	dstPosCopy associationsDo:[:assoc|
		assoc value do:[:index| added add: (index -> assoc key)].
	].
	added := added sortBy:[:a1 :a2| a1 key < a2 key].
! !


!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:15'!
destString: aString 
	realDst _ self split: aString asString.
	dstLines _ OrderedCollection new.
	dstMap _ OrderedCollection new.
	realDst
		doWithIndex: [:line :realIndex | 
			dstLines
				add: (self formatLine: line).
			dstMap add: realIndex].
	dstPos _ PluggableDictionary new: dstLines size.
	dstPos hashBlock: self stringHashBlock.
	dstLines
		doWithIndex: [:line :index | (dstPos includesKey: line)
				ifTrue: [(dstPos at: line)
						add: index.
					multipleMatches _ true]
				ifFalse: [dstPos
						at: line
						put: (OrderedCollection with: index)]]! !

!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 1/7/2004 09:24'!
formatLine: aString
	^aString copyWithout: Character lf! !

!TextDiffBuilder methodsFor: 'initialize'!
from: sourceString to: destString
	self sourceString: sourceString.
	self destString: destString.! !

!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:15'!
sourceString: aString 
	realSrc _ self split: aString asString.
	srcLines _ OrderedCollection new.
	srcMap _ OrderedCollection new.
	realSrc
		doWithIndex: [:line :realIndex | 
			srcLines
				add: (self formatLine: line).
			srcMap add: realIndex].
	srcPos _ PluggableDictionary new: srcLines size.
	srcPos hashBlock: self stringHashBlock.
	srcLines
		doWithIndex: [:line :index | (srcPos includesKey: line)
				ifTrue: [(srcPos at: line)
						add: index.
					multipleMatches _ true]
				ifFalse: [srcPos
						at: line
						put: (OrderedCollection with: index)]]! !

!TextDiffBuilder methodsFor: 'initialize'!
split: aString
	^self split: aString by: self splitCharacter! !


!TextDiffBuilder methodsFor: 'printing' stamp: 'nk 4/24/2004 08:48'!
printPatchSequence: seq on: aStream 
	seq do: 
		[:assoc | 
		aStream
			withAttributes: (self attributesOf: assoc key)
			do: [aStream nextPutAll: assoc value; cr]]! !


!TextDiffBuilder methodsFor: 'testing'!
hasMultipleMatches
	^multipleMatches == true! !


!TextDiffBuilder methodsFor: 'private' stamp: 'nk 4/24/2004 08:48'!
attributesOf: type
	"Private.
	Answer the TextAttributes that are used to display text of the given type."

	^type caseOf: {
		[#insert] -> [ {TextColor red} ].
		[#remove] -> [ {TextEmphasis struckOut. TextColor blue}].
	} otherwise: [ {TextEmphasis normal} ].
! !

!TextDiffBuilder methodsFor: 'private' stamp: 'RAA 5/2/2001 22:56'!
pointEqualBlock
	^[ :a :b | a x = b x and: [a y = b y]] fixTemps! !

!TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 16:35'!
pointHashBlock
	^[:pt| (pt x bitShift: 12) + pt y] fixTemps! !

!TextDiffBuilder methodsFor: 'private' stamp: 'RAA 5/2/2001 23:28'!
remove: pointKey from: aSet

	self hasMultipleMatches ifFalse:[^aSet remove: pointKey].
	aSet removeAllXAndY: pointKey.
! !

!TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 17:26'!
split: aString by: splitChar
	| lines index nextIndex |
	lines := OrderedCollection new.
	index _ 1.
	[index <= aString size] whileTrue:[
		nextIndex _ aString 
						indexOf: splitChar 
						startingAt: index 
						ifAbsent:[aString size+1].
		lines add: (aString copyFrom: index to: nextIndex-1).
		index _ nextIndex+1].
	^lines! !

!TextDiffBuilder methodsFor: 'private'!
splitCharacter
	^Character cr! !

!TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/24/1998 13:41'!
stringHashBlock
	"Return a block for use in string hashing"
	| stringSize |
	^[:string| 
		stringSize _ string size.
		stringSize = 0 
			ifTrue:[0]
			ifFalse:[ stringSize < 3 
				ifTrue:[(string at: 1) asInteger +
						((string at: string size) asInteger bitShift: 8)]
				ifFalse:[	(string at: 1) asInteger +
						((string at: stringSize // 3 + 1) asInteger bitShift: 4) +
						((string at: stringSize // 2 + 1) asInteger bitShift: 8) +
						((string at: stringSize * 2 // 3 + 1) asInteger bitShift: 12) +
						((string at: stringSize) asInteger bitShift: 16)]]] fixTemps! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextDiffBuilder class
	instanceVariableNames: ''!

!TextDiffBuilder class methodsFor: 'instance creation'!
buildDisplayPatchFrom: srcString to: dstString
	^(self from: srcString to: dstString) buildDisplayPatch! !

!TextDiffBuilder class methodsFor: 'instance creation' stamp: 'nk 10/29/2000 12:38'!
buildDisplayPatchFrom: srcString to: dstString inClass: srcClass 
	^ ((srcClass notNil and: [ (Preferences valueOfFlag: #diffsWithPrettyPrint) ])
		ifTrue: [PrettyTextDiffBuilder
				from: srcString
				to: dstString
				inClass: srcClass]
		ifFalse: [self from: srcString to: dstString]) buildDisplayPatch! !

!TextDiffBuilder class methodsFor: 'instance creation' stamp: 'sw 5/19/2001 10:52'!
buildDisplayPatchFrom: srcString to: dstString inClass: srcClass prettyDiffs: prettyBoolean
	"Build a display patch for mapping via diffs from srcString to dstString in the given class.  If prettyBoolean is true, do the diffing for pretty-printed forms"

	^ ((srcClass notNil and: [prettyBoolean])
		ifTrue: [PrettyTextDiffBuilder
				from: srcString
				to: dstString
				inClass: srcClass]
		ifFalse: [self from: srcString to: dstString]) buildDisplayPatch! !

!TextDiffBuilder class methodsFor: 'instance creation'!
from: srcString to: dstString
	^self new from: srcString to: dstString! !
TextAction subclass: #TextDoIt
	instanceVariableNames: 'evalString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:01'!
actOnClickFor: anObject
	"Note: evalString gets evaluated IN THE CONTEXT OF anObject
	 -- meaning that self and all instVars are accessible"
	Compiler evaluate: evalString for: anObject logged: false.
	^ true ! !

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:46'!
analyze: aString

	| list |
	list _ super analyze: aString.
	evalString _ list at: 1.
	^ list at: 2! !

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:01'!
evalString: str
	evalString _ str ! !

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'!
info
	^ evalString! !

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:46'!
writeScanOn: strm

	strm nextPut: $d; nextPutAll: evalString; nextPutAll: ';;'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextDoIt class
	instanceVariableNames: ''!

!TextDoIt class methodsFor: 'as yet unclassified' stamp: 'tk 12/6/97 20:28'!
evalString: str
	^ self new evalString: str! !

!TextDoIt class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:06'!
scanFrom: strm
	"read a doit in the funny format used by Text styles on files. d10 factorial;;  end with two semicolons"

	| pos end doit |
	pos _ strm position.
	[strm skipTo: $;. strm peek == $;] whileFalse.
	end _ strm position - 1.
	strm position: pos.
	doit _ strm next: end-pos.
	strm skip: 2.  ";;"
	^ self evalString: doit! !
TextAttribute subclass: #TextEmphasis
	instanceVariableNames: 'emphasisCode setMode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextEmphasis commentStamp: '<historical>' prior: 0!
A TextEmphasis, encodes a characteristic applicable to all fonts.  The encoding is as follows:
	1	bold
	2	itallic
	4	underlined
	8	narrow
	16	struck out!


!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'!
= other 
	^ (other class == self class) 
		and: [other emphasisCode = emphasisCode]! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:11'!
dominatedByCmd0
	"Cmd-0 should turn off emphasis"
	^ true! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:13'!
dominates: other
	(emphasisCode = 0 and: [other dominatedByCmd0]) ifTrue: [^ true].
	^ (other class == self class)
		and: [emphasisCode = other emphasisCode]! !

!TextEmphasis methodsFor: 'as yet unclassified'!
emphasisCode
	^ emphasisCode! !

!TextEmphasis methodsFor: 'as yet unclassified'!
emphasisCode: int
	emphasisCode _ int.
	setMode _ true! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:57'!
emphasizeScanner: scanner
	"Set the emphasist for text scanning"
	scanner addEmphasis: emphasisCode! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'ar 9/9/2003 22:03'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^emphasisCode hash
! !

!TextEmphasis methodsFor: 'as yet unclassified'!
printOn: strm
	super printOn: strm.
	strm nextPutAll: ' code: '; print: emphasisCode! !

!TextEmphasis methodsFor: 'as yet unclassified'!
set
	^ setMode and: [emphasisCode ~= 0]! !

!TextEmphasis methodsFor: 'as yet unclassified'!
turnOff
	setMode _ false! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:28'!
writeScanOn: strm

	emphasisCode = 1 ifTrue: [strm nextPut: $b].
	emphasisCode = 2 ifTrue: [strm nextPut: $i].
	emphasisCode = 0 ifTrue: [strm nextPut: $n].
	emphasisCode = 16 ifTrue: [strm nextPut: $=].
	emphasisCode = 4 ifTrue: [strm nextPut: $u].! !


!TextEmphasis methodsFor: 'html' stamp: 'dgd 9/2/2005 12:39'!
closeHtmlOn: aStream 
	"put on the given stream the tag to close the html  
	representation of the receiver"
	emphasisCode = 1
		ifTrue: [aStream nextPutAll: '</b>'].
	emphasisCode = 2
		ifTrue: [aStream nextPutAll: '</i>'].
	emphasisCode = 4
		ifTrue: [aStream nextPutAll: '</u>']! !

!TextEmphasis methodsFor: 'html' stamp: 'dgd 9/2/2005 12:38'!
openHtmlOn: aStream 
	"put on the given stream the tag to open the html  
	representation of the receiver"
	emphasisCode = 1
		ifTrue: [aStream nextPutAll: '<b>'].
	emphasisCode = 2
		ifTrue: [aStream nextPutAll: '<i>'].
	emphasisCode = 4
		ifTrue: [aStream nextPutAll: '<u>']! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextEmphasis class
	instanceVariableNames: ''!

!TextEmphasis class methodsFor: 'as yet unclassified'!
bold
	^ self new emphasisCode: 1! !

!TextEmphasis class methodsFor: 'as yet unclassified'!
italic
	^ self new emphasisCode: 2! !

!TextEmphasis class methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:05'!
narrow
	^ TextKern kern: -1! !

!TextEmphasis class methodsFor: 'as yet unclassified'!
normal
	^ self new emphasisCode: 0! !

!TextEmphasis class methodsFor: 'as yet unclassified'!
struckOut
	^ self new emphasisCode: 16! !

!TextEmphasis class methodsFor: 'as yet unclassified'!
underlined
	^ self new emphasisCode: 4! !
HashAndEqualsTestCase subclass: #TextEmphasisTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!

!TextEmphasisTest methodsFor: 'initialize-release' stamp: 'mjr 8/20/2003 18:55'!
setUp
	super setUp.
	prototypes add: TextEmphasis bold;
		 add: TextEmphasis italic;
		 add: TextEmphasis narrow;
		 add: TextEmphasis normal;
		 add: TextEmphasis struckOut;
		 add: TextEmphasis underlined ! !


!TextEmphasisTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:03'!
testAppendString
	"tests the Text>>prepend: method when appending a String " 
	"self run: # testAppendString"

	| receiver argument result expectedResult |

	receiver := 'xxx' asText  
		addAttribute: TextEmphasis bold from: 1 to: 3.
	argument := 'yyy'.
	expectedResult := 'xxxyyy' asText 
		addAttribute: TextEmphasis bold from: 1 to: 3.
	result := receiver append: argument.
	self assert: (result == receiver). 
	self assert: (result string = expectedResult string).
	self assert: (result runs = expectedResult runs)! !

!TextEmphasisTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:04'!
testAppendText
	"tests the Text>>prepend: method when appending a Text " 
	| receiver argument result expectedResult |

	receiver := 'xxx' asText  
		addAttribute: TextEmphasis bold from: 1 to: 3.
	argument := 'yyy' asText
		addAttribute: TextEmphasis italic from: 1 to: 3.		.
	expectedResult := 'xxxyyy' asText 
		addAttribute: TextEmphasis bold from: 1 to: 3;
		addAttribute: TextEmphasis italic from: 4 to: 6.
	result := receiver append: argument.
	self assert: (result == receiver). 
	self assert: (result string = expectedResult string).
	self assert: (result runs = expectedResult runs)

	
	! !

!TextEmphasisTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:04'!
testPrependString
	"tests the Text>>prepend: method when prepending a String " 
	| receiver argument result expectedResult |

	receiver := 'xxx' asText  
		addAttribute: TextEmphasis bold from: 1 to: 3.
	argument := 'yyy'.
	expectedResult := 'yyyxxx' asText 
		addAttribute: TextEmphasis bold from: 4 to: 6.
	result := receiver prepend: argument.
	self assert: (result == receiver). 
	self assert: (result string = expectedResult string).
	self assert: (result runs = expectedResult runs)

	! !

!TextEmphasisTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:04'!
testPrependText
	"tests the Text>>prepend: method when prepending Text " 
	| receiver argument result expectedResult |

	receiver := 'xxx' asText  
		addAttribute: TextEmphasis bold from: 1 to: 3.
	argument := 'yyy' asText 
		addAttribute: TextEmphasis italic from: 1 to: 3.
	expectedResult := 'yyyxxx' asText 
		addAttribute: TextEmphasis italic from: 1 to: 3;
		addAttribute: TextEmphasis bold from: 4 to: 6.
	result := receiver prepend: argument.
	self assert: (result == receiver). 
	self assert: (result string = expectedResult string).
	self assert: (result runs = expectedResult runs)! !
RectangleMorph subclass: #TextFieldMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextFieldMorph commentStamp: '<historical>' prior: 0!
Act as a field in a HyperCard-like setting.  Has both properties of a Rectangle, and exposes some proteries of the TextMorph it owns.

!


!TextFieldMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:54'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color veryLightGray lighter! !

!TextFieldMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:54'!
initialize
	"initialize the state of the receiver"
	| tm |
	super initialize.
	""
	
	self addMorph: (tm _ TextMorph new).
	tm fillingOnOff! !


!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 9/6/2000 11:03'!
append: stringOrText
	"add to my text"
	| tm |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	tm contents append: stringOrText.
	tm releaseParagraph; paragraph.


	! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 8/30/2000 14:22'!
contents
	| tm |
	"talk to my text"

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	^ tm contents! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'ar 4/10/2005 18:54'!
contents: textOrString
	"talk to my text"
	| tm newText atts |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	textOrString isString ifTrue: [
		tm contents ifNotNil: ["Keep previous properties of the field"
			newText _ textOrString asText.
			atts _ tm contents attributesAt: 1.
			atts do: [:each | newText addAttribute: each].
			^ tm contents: newText]].

	^ tm contents: textOrString! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 9/4/2000 16:28'!
fit
	"tell my text to recompute its looks"
	| tm |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	tm releaseParagraph; paragraph.! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 8/30/2000 14:24'!
fontName: fontName size: fontSize
	| tm |
	"talk to my text"

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	^ tm fontName: fontName size: fontSize
! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 9/6/2000 12:33'!
lineCount
	| tm |
	"how many lines in my text"

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	^ tm contents string lineCount! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'ar 12/27/2001 00:03'!
prepend: stringOrText
	"add to my text"
	| tm |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	tm contents prepend: stringOrText.
	tm releaseParagraph; paragraph.


	! !


!TextFieldMorph methodsFor: '*eToys-card in a stack' stamp: 'tk 1/6/2001 14:20'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')"

	^ true! !


!TextFieldMorph methodsFor: '*eToys-card & stack' stamp: 'tk 1/6/2001 14:15'!
setNewContentsFrom: textOrString
	"talk to my text"
	| tm |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	tm valueOfProperty: #cardInstance ifAbsent: ["move it down"
		tm setProperty: #cardInstance toValue: (self valueOfProperty: #cardInstance)].
	tm valueOfProperty: #holdsSeparateDataForEachInstance ifAbsent: ["move it down"
		tm setProperty: #holdsSeparateDataForEachInstance toValue: 
			(self valueOfProperty: #holdsSeparateDataForEachInstance)].
	^ tm setNewContentsFrom: textOrString! !


!TextFieldMorph methodsFor: '*eToys-player' stamp: 'sw 10/30/2000 09:03'!
currentDataValue
	"Answer the current data value held by the receiver"

	^ self contents! !

!TextFieldMorph methodsFor: '*eToys-player' stamp: 'tk 1/6/2001 13:58'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield"

	^ Array with: (VariableDock new variableName: self defaultVariableName type: #text definingMorph: self morphGetSelector: #contents morphPutSelector: #setNewContentsFrom:)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextFieldMorph class
	instanceVariableNames: ''!

!TextFieldMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:56'!
initialize

	self registerInFlapsRegistry.	! !

!TextFieldMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 11:58'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(TextFieldMorph  exampleBackgroundField	'Scrolling Field'	'A scrolling data field which will have a different value on every card of the background')
						forFlapNamed: 'Scripting'.]! !

!TextFieldMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:41'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!TextFieldMorph class methodsFor: 'scripting' stamp: 'md 11/14/2003 17:32'!
authoringPrototype 
	"Answer an instance of the receiver that can serve as a prototype for authoring"

	| proto |
	proto _ super authoringPrototype.
	proto setProperty: #shared toValue: true.
	proto extent: 170 @ 30.
	proto color: Color veryLightGray lighter.
	proto contents: 'on a clear day you can...'.
	^ proto
! !


!TextFieldMorph class methodsFor: '*eToys-instance creation' stamp: 'sw 6/13/2001 22:48'!
exampleBackgroundField
	"Answer a scrollable background field for a parts bin"

	| aMorph |
	aMorph _ self authoringPrototype.
	aMorph contents: 'background field' asText allBold.
	aMorph setProperty: #shared toValue: true.
	aMorph setNameTo: 'scrollingField1'.
	aMorph setProperty: #holdsSeparateDataForEachInstance toValue: true.
	^ aMorph! !
TextAttribute subclass: #TextFontChange
	instanceVariableNames: 'fontNumber'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextFontChange commentStamp: '<historical>' prior: 0!
A TextFontChange encodes a font change applicable over a given range of text.  The font number is interpreted relative to the textStyle governing display of this text.!


!TextFontChange methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'!
= other 
	^ (other class == self class) 
		and: [other fontNumber = fontNumber]! !

!TextFontChange methodsFor: 'as yet unclassified' stamp: 'nk 9/3/2004 15:48'!
dominates: other
	^ other isKindOf: TextFontChange! !

!TextFontChange methodsFor: 'as yet unclassified'!
emphasizeScanner: scanner
	"Set the font for text display"
	scanner setFont: fontNumber! !

!TextFontChange methodsFor: 'as yet unclassified'!
fontNumber
	^ fontNumber! !

!TextFontChange methodsFor: 'as yet unclassified'!
fontNumber: int
	fontNumber _ int! !

!TextFontChange methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:46'!
forFontInStyle: aTextStyle do: aBlock
	aBlock value: (aTextStyle fontAt: fontNumber)! !

!TextFontChange methodsFor: 'as yet unclassified' stamp: 'ar 9/9/2003 22:03'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^fontNumber hash! !

!TextFontChange methodsFor: 'as yet unclassified'!
printOn: strm
	super printOn: strm.
	strm nextPutAll: ' font: '; print: fontNumber! !

!TextFontChange methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:22'!
writeScanOn: strm

	strm nextPut: $f.
	fontNumber printOn: strm.! !


!TextFontChange methodsFor: 'html' stamp: 'dgd 9/2/2005 12:39'!
closeHtmlOn: aStream 
	"put on the given stream the tag to close the html  
	representation of the receiver"
	| font |
	font := TextStyle default fontAt: fontNumber.
	font closeHtmlOn: aStream! !

!TextFontChange methodsFor: 'html' stamp: 'dgd 9/2/2005 12:38'!
openHtmlOn: aStream 
	"put on the given stream the tag to open the html  
	representation of the receiver"
	| font |
	font := TextStyle default fontAt: fontNumber.
	font openHtmlOn: aStream! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextFontChange class
	instanceVariableNames: ''!

!TextFontChange class methodsFor: 'as yet unclassified' stamp: 'sw 12/6/1999 17:52'!
defaultFontChange
	"Answer a TextFontChange that represents the default font"

	^ self new fontNumber: TextStyle default defaultFontIndex! !

!TextFontChange class methodsFor: 'as yet unclassified'!
font1
	^ self new fontNumber: 1! !

!TextFontChange class methodsFor: 'as yet unclassified'!
font2
	^ self new fontNumber: 2! !

!TextFontChange class methodsFor: 'as yet unclassified'!
font3
	^ self new fontNumber: 3! !

!TextFontChange class methodsFor: 'as yet unclassified'!
font4
	^ self new fontNumber: 4! !

!TextFontChange class methodsFor: 'as yet unclassified'!
fontNumber: n
	^ self new fontNumber: n! !
HashAndEqualsTestCase subclass: #TextFontChangeTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!

!TextFontChangeTest methodsFor: 'initialize-release' stamp: 'mjr 8/20/2003 18:55'!
setUp
	"create the prototypes for testing"
	super setUp.
	prototypes add: TextFontChange defaultFontChange.
	prototypes add: TextFontChange font1.
	prototypes add: TextFontChange font2.
	prototypes add: TextFontChange font3.
	prototypes add: TextFontChange font4.
	prototypes
		add: (TextFontChange fontNumber: 6) ! !


!TextFontChangeTest methodsFor: 'tests' stamp: 'mjr 8/17/2003 20:29'!
testEquality
	"Check that different instances of the same TextFontChange are equal"
	self assert: TextFontChange defaultFontChange = TextFontChange defaultFontChange.
	self assert: TextFontChange font1 = TextFontChange font1.
	self assert: TextFontChange font2 = TextFontChange font2.
	self assert: TextFontChange font3 = TextFontChange font3.
	self assert: TextFontChange font4 = TextFontChange font4.
	self assert: (TextFontChange fontNumber: 6)
			= (TextFontChange fontNumber: 6)! !

!TextFontChangeTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:10'!
testHash
	"test that different instances of the same TextFontChange hash to the 
	same value"
	| hashes hash |
	hashes := OrderedCollection new.
	1
		to: 100
		do: [:i | hashes add: TextFontChange defaultFontChange hash].
	hash := hashes at: 1.
	2
		to: 100
		do: [:i | self assert: (hashes at: i)
					= hash]! !
TextFontChange subclass: #TextFontReference
	instanceVariableNames: 'font'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextFontReference commentStamp: '<historical>' prior: 0!
A TextFontReference encodes a font change applicable over a given range of text.  The font reference is absolute:  unlike a TextFontChange, it is independent of the textStyle governing display of this text.!


!TextFontReference methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:22'!
couldDeriveFromPrettyPrinting
	^ false! !

!TextFontReference methodsFor: 'as yet unclassified'!
emphasizeScanner: scanner
	"Set the actual font for text display"
	scanner setActualFont: font! !

!TextFontReference methodsFor: 'as yet unclassified' stamp: 'di 5/10/1999 23:47'!
font

	^ font! !

!TextFontReference methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:47'!
forFontInStyle: aTextStyle do: aBlock
	aBlock value: font! !

!TextFontReference methodsFor: 'as yet unclassified'!
toFont: aFont

	font _ aFont! !

!TextFontReference methodsFor: 'as yet unclassified' stamp: 'tk 7/22/2002 18:39'!
writeScanOn: strm

	strm nextPut: $F.
	strm nextPutAll: font familyName; nextPut: $#.
	font height printOn: strm.! !


!TextFontReference methodsFor: 'comparing' stamp: 'nk 9/3/2004 15:43'!
= other 
	^ (other class == self class) 
		and: [other font = font]! !

!TextFontReference methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:03'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^font hash! !

!TextFontReference methodsFor: 'comparing' stamp: 'nk 9/3/2004 15:24'!
printOn: aStream
	aStream nextPutAll: 'a TextFontReference(';
		print: font;
		nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextFontReference class
	instanceVariableNames: ''!

!TextFontReference class methodsFor: 'as yet unclassified'!
toFont: aFont
	^ self new toFont: aFont! !
HashAndEqualsTestCase subclass: #TextFontReferenceTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!

!TextFontReferenceTest methodsFor: 'tests' stamp: 'mjr 8/20/2003 18:55'!
setUp
	super setUp.
	prototypes
		add: (TextFontReference
				toFont: (StrikeFont familyName: 'NewYork' size: 15)) ! !
TextAttribute subclass: #TextIndent
	instanceVariableNames: 'amount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextIndent commentStamp: '<historical>' prior: 0!
create a hanging indent. !


!TextIndent methodsFor: 'access' stamp: 'ls 6/22/1998 17:51'!
amount
	"number of tab spaces to indent by"
	^amount! !

!TextIndent methodsFor: 'access' stamp: 'ls 6/22/1998 17:51'!
amount: anInteger
	"change the number of tabs to indent by"
	amount _ anInteger! !


!TextIndent methodsFor: 'condensing' stamp: 'ls 6/22/1998 19:27'!
dominates: anAttribute
	^(self class == anAttribute class)! !


!TextIndent methodsFor: 'printing' stamp: 'ls 6/22/1998 18:03'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' amount: '.
	amount printOn: aStream! !


!TextIndent methodsFor: 'setting indentation' stamp: 'ls 6/22/1998 18:56'!
emphasizeScanner: scanner
	scanner indentationLevel: amount! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextIndent class
	instanceVariableNames: ''!

!TextIndent class methodsFor: 'example' stamp: 'ls 6/24/1998 18:06'!
example
	"TextIndent example"
	| text pg |

	"create an example text with some indentation"
	text _ 'abcdao euoaeuo aeuo aeuoaeu o aeuoeauefgh bcd efghi'  asText.
	text addAttribute: (TextColor red)  from: 3 to: 8.
	text addAttribute: (TextIndent amount: 1) from: 1 to: 2.
	text addAttribute: (TextIndent amount: 2) from: 20 to: 35.

	"stick it in a paragraph and display it"
	pg _ text asParagraph.
	pg compositionRectangle: (0@0 extent: 100@200).
	pg textStyle alignment: 2.
	pg displayAt: 0@0.
! !


!TextIndent class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:55'!
amount: amount
	"create a TextIndent which will indent by the given amount.  Currently this is a number of tabs, but may change in the futur"
	^super new amount: amount! !

!TextIndent class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:54'!
tabs: numTabs
	"create an indentation by the given number of tabs"
	^self amount: numTabs! !
TextAttribute subclass: #TextKern
	instanceVariableNames: 'kern active'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextKern commentStamp: '<historical>' prior: 0!
A TextKern encodes a kerning change applicable over a given range of text.  Positive values of kern spread letters out, negative kern will cause them to overlap more.  Note that kerns other than 0 will display somewhat slower, as kerning is not yet supported in the text scanning primitive. !


!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'!
= other 
	^ (other class == self class) 
		and: [other kern = kern]! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:21'!
couldDeriveFromPrettyPrinting
	^ false! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:10'!
dominatedByCmd0
	"Cmd-0 should turn off kerning"
	^ true! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:10'!
dominates: other
	"NOTE: The use of active in this code is specific to its use in the method
		Text class addAttribute: att toArray: others"
	(active and: [other class == self class and: [other kern + kern = 0]])
		ifTrue: [active _ false.  ^ true].  "can only dominate once"
	^ false! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:50'!
emphasizeScanner: scanner
	"Augment (or diminish) the kerning offset for text display"
	scanner addKern: kern! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'ar 9/9/2003 22:03'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^kern hash! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:12'!
kern
	^ kern! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 09:59'!
kern: kernValue
	kern _ kernValue.
	self reset.! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:04'!
reset
	active _ true! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:11'!
set
	^ active! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'tk 9/21/1999 15:57'!
writeScanOn: strm

	kern > 0 ifTrue: [
		1 to: kern do: [:kk | strm nextPut: $+]].
	kern < 0 ifTrue: [
		1 to: 0-kern do: [:kk | strm nextPut: $-]].! !


!TextKern methodsFor: 'testing' stamp: 'ar 9/21/2000 14:16'!
isKern
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextKern class
	instanceVariableNames: ''!

!TextKern class methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:49'!
kern: kernValue
	^ self new kern: kernValue! !
HashAndEqualsTestCase subclass: #TextKernTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!

!TextKernTest methodsFor: 'tests' stamp: 'mjr 8/20/2003 18:55'!
setUp
	super setUp.
	prototypes
		add: (TextKern kern: 1) ! !
Object subclass: #TextLine
	instanceVariableNames: 'left right top bottom firstIndex lastIndex internalSpaces paddingWidth baseline leftMargin'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextLine commentStamp: '<historical>' prior: 0!
A TextLine embodies the layout of a line of composed text.
	left right top bottom		The full line rectangle
	firstIndex lastIndex		Starting and stopping indices in the full text
	internalSpaces		Number of spaces to share paddingWidth
	paddingWidth		Number of pixels of extra space in full line
	baseline				Distance of baseline below the top of the line
	leftMargin			Left margin due to paragraph indentation
TextLine's rather verbose message protocol is required for compatibility with the old CharacterScanners.!


!TextLine methodsFor: 'accessing'!
baseline
	^ baseline! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
bottom
	^ bottom! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
bottomRight
	^ right@bottom! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:12'!
first
	^ firstIndex! !

!TextLine methodsFor: 'accessing'!
internalSpaces
	"Answer the number of spaces in the line."

	^internalSpaces! !

!TextLine methodsFor: 'accessing'!
internalSpaces: spacesInteger 
	"Set the number of spaces in the line to be spacesInteger."

	internalSpaces _ spacesInteger! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:14'!
last
	^ lastIndex! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
left
	^ left! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:42'!
leftMargin
	"This has to get fixed -- store during composition"
	^ self left! !

!TextLine methodsFor: 'accessing' stamp: 'hmm 2/9/2001 11:58'!
leftMargin: lm
	left _ lm! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/26/97 16:03'!
leftMarginForAlignment: alignmentCode
	alignmentCode = 1 ifTrue: [^ self left + paddingWidth].  "right flush"
	alignmentCode = 2 ifTrue: [^ self left + (paddingWidth//2)].  "centered"
	^ self left  "leftFlush and justified"! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
lineHeight
	^ bottom - top! !

!TextLine methodsFor: 'accessing'!
paddingWidth
	"Answer the amount of space to be added to the font."

	^paddingWidth! !

!TextLine methodsFor: 'accessing'!
paddingWidth: padWidthInteger 
	"Set the amount of space to be added to the font to be padWidthInteger."

	paddingWidth _ padWidthInteger! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 20:00'!
rectangle
	^ self topLeft corner: self bottomRight! !

!TextLine methodsFor: 'accessing' stamp: 'hmm 2/9/2001 11:58'!
rectangle: lineRectangle
	left _ lineRectangle left.
	right _ lineRectangle right.
	top _ lineRectangle top.
	bottom _ lineRectangle bottom! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
right
	^ right! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:42'!
rightMargin
	"This has to get fixed -- store during composition"
	^ self right! !

!TextLine methodsFor: 'accessing' stamp: 'di 11/26/97 16:18'!
setRight: x
	right _ x! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/20/97 23:27'!
stop: stopInteger 
	"Set the stopping point in the string of the line to be stopInteger."

	lastIndex _ stopInteger! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
top
	^ top! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
topLeft
	^ left @ top! !

!TextLine methodsFor: 'accessing' stamp: 'di 11/26/97 16:58'!
width
	^ right - left! !


!TextLine methodsFor: 'comparing' stamp: 'di 10/20/97 23:24'!
= line

	self species = line species
		ifTrue: [^((firstIndex = line first and: [lastIndex = line last])
				and: [internalSpaces = line internalSpaces])
				and: [paddingWidth = line paddingWidth]]
		ifFalse: [^false]! !

!TextLine methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:03'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^firstIndex hash bitXor: lastIndex hash! !


!TextLine methodsFor: 'printing' stamp: 'di 10/23/97 23:19'!
printOn: aStream
	super printOn: aStream.
	aStream space; print: firstIndex; nextPutAll: ' to: '; print: lastIndex! !


!TextLine methodsFor: 'scanning'!
justifiedPadFor: spaceIndex 
	"Compute the width of pad for a given space in a line of justified text."

	| pad |
	internalSpaces = 0 ifTrue: [^0].
	pad _ paddingWidth // internalSpaces.
	spaceIndex <= (paddingWidth \\ internalSpaces)
		ifTrue: [^pad + 1]
		ifFalse: [^pad]! !

!TextLine methodsFor: 'scanning'!
justifiedTabDeltaFor: spaceIndex 
	"Compute the delta for a tab in a line of justified text, so tab falls 
	somewhere plausible when line is justified."

	| pad extraPad |
	internalSpaces = 0 ifTrue: [^0].
	pad _ paddingWidth // internalSpaces.
	extraPad _ paddingWidth \\ internalSpaces.
	spaceIndex <= extraPad
		ifTrue: [^spaceIndex * (pad + 1)]
		ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! !


!TextLine methodsFor: 'updating' stamp: 'di 11/7/97 08:32'!
moveBy: delta 
	"Move my rectangle by the given delta"
	left _ left + delta x.
	right _ right + delta x.
	top _ top + delta y.
	bottom _ bottom + delta y.
! !

!TextLine methodsFor: 'updating' stamp: 'di 10/20/97 23:25'!
slide: delta 
	"Change the starting and stopping points of the line by delta."

	firstIndex _ firstIndex + delta.
	lastIndex _ lastIndex + delta! !

!TextLine methodsFor: 'updating' stamp: 'di 4/28/1999 11:12'!
slideIndexBy: delta andMoveTopTo: newTop
	"Relocate my character indices and y-values.
	Used to slide constant text up or down in the wake of a text replacement."

	firstIndex _ firstIndex + delta.
	lastIndex _ lastIndex + delta.
	bottom _ bottom + (newTop - top).
	top _ newTop.
! !


!TextLine methodsFor: 'private' stamp: 'di 10/20/97 23:08'!
firstIndex: firstInteger lastIndex: lastInteger
	firstIndex _ firstInteger.
	lastIndex _ lastInteger! !

!TextLine methodsFor: 'private'!
internalSpaces: spacesInteger paddingWidth: padWidthInteger

	internalSpaces _ spacesInteger.
	paddingWidth _ padWidthInteger! !

!TextLine methodsFor: 'private' stamp: 'di 10/23/97 19:57'!
lineHeight: height baseline: ascent
	bottom _ top + height.
	baseline _ ascent! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextLine class
	instanceVariableNames: ''!

!TextLine class methodsFor: 'instance creation' stamp: 'di 10/20/97 23:08'!
start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger
	"Answer an instance of me with the arguments as the start, stop points, 
	number of spaces in the line, and width of the padding."
	| line |
	line _ self new firstIndex: startInteger lastIndex: stopInteger.
	^ line internalSpaces: spacesInteger paddingWidth: padWidthInteger! !
TestCase subclass: #TextLineEndingsTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!
!TextLineEndingsTest commentStamp: 'nk 11/1/2003 07:55' prior: 0!
This is a test case for Text>>withSqueakLineEndings and String>>withSqueakLineEndings.

The main problem we've seen with the Text version is that it doesn't preserve formatting correctly.!


!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:06'!
testDecoratedTextConversionCrLF

	| text newText |
	text := ('123456', String crlf, '901234') asText.
	text addAttribute: TextColor blue from: 4 to: 10.
	text addAttribute: TextColor red from: 6 to: 9.
	text addAttribute: TextEmphasis bold.
	newText := text withSqueakLineEndings.
	self assert: ((text size - 1) = newText size).
	self assert: (newText size = newText runs size).
	self assert: (newText attributesAt: 6) = (text attributesAt: 6).
	self assert: (newText attributesAt: 8) = (text attributesAt: 9).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:06'!
testDecoratedTextConversionJustLF

	| text newText |
	text := ('123456', String lf, '901234') asText.
	text addAttribute: TextColor blue from: 4 to: 10.
	text addAttribute: TextColor red from: 6 to: 9.
	text addAttribute: TextEmphasis bold.
	newText := text withSqueakLineEndings.
	self assert: ((text size) = newText size).
	self assert: (newText size = newText runs size).
	self assert: (newText attributesAt: 6) = (text attributesAt: 6).
	self assert: (newText attributesAt: 8) = (text attributesAt: 8).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'!
testDecoratedTextConversionNoLF

	| text newText |
	text := ('123456', String cr, '901234') asText.
	text addAttribute: TextColor blue from: 4 to: 10.
	text addAttribute: TextColor red from: 6 to: 9.
	text addAttribute: TextEmphasis bold.
	newText := text withSqueakLineEndings.
	self assert: ((text size) = newText size).
	self assert: (newText size = newText runs size).
	self assert: (newText attributesAt: 6) = (text attributesAt: 6).
	self assert: (newText attributesAt: 8) = (text attributesAt: 8).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'!
testSimpleTextConversionCrLF

	| string newText |
	string := 'This is a test', String crlf, 'of the conversion'.
	newText := string asText withSqueakLineEndings.
	self assert: ((string size - 1) = newText size).
	self assert: (newText size = newText runs size).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'!
testSimpleTextConversionJustCR

	| string newText |
	string := 'This is a test', String cr, 'of the conversion'.
	newText := string asText withSqueakLineEndings.
	self assert: ((string size) = newText size).
	self assert: (newText size = newText runs size).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'!
testSimpleTextConversionJustLF

	| string newText |
	string := 'This is a test', String lf, 'of the conversion'.
	newText := string asText withSqueakLineEndings.
	self assert: ((string size) = newText size).
	self assert: (newText size = newText runs size).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'!
testStringConversionCrLF

	| string newString |
	string := 'This is a test', String crlf, 'of the conversion'.
	newString := string withSqueakLineEndings.
	self assert: ((string size - 1) = newString size).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'!
testStringConversionJustLF

	| string newString |
	string := 'This is a test', String lf, 'of the conversion'.
	newString := string withSqueakLineEndings.
	self assert: (string size = newString size).! !

!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'!
testStringConversionNoLF

	| string newString |
	string := 'This is a test', String cr, 'of the conversion'.
	newString := string withSqueakLineEndings.
	self assert: (string = newString).! !
Interval subclass: #TextLineInterval
	instanceVariableNames: 'internalSpaces paddingWidth lineHeight baseline'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Text'!
!TextLineInterval commentStamp: '<historical>' prior: 0!
My instances specify the starting and stopping points in a String of a composed line. The step is always 1.!


!TextLineInterval methodsFor: 'accessing'!
baseline
	^ baseline! !

!TextLineInterval methodsFor: 'accessing'!
internalSpaces
	"Answer the number of spaces in the line."

	^internalSpaces! !

!TextLineInterval methodsFor: 'accessing'!
internalSpaces: spacesInteger 
	"Set the number of spaces in the line to be spacesInteger."

	internalSpaces _ spacesInteger! !

!TextLineInterval methodsFor: 'accessing'!
lineHeight
	^ lineHeight! !

!TextLineInterval methodsFor: 'accessing'!
paddingWidth
	"Answer the amount of space to be added to the font."

	^paddingWidth! !

!TextLineInterval methodsFor: 'accessing'!
paddingWidth: padWidthInteger 
	"Set the amount of space to be added to the font to be padWidthInteger."

	paddingWidth _ padWidthInteger! !

!TextLineInterval methodsFor: 'accessing'!
stop: stopInteger 
	"Set the stopping point in the string of the line to be stopInteger."

	stop _ stopInteger! !


!TextLineInterval methodsFor: 'comparing'!
= line

	self species = line species
		ifTrue: [^((start = line first and: [stop = line last])
				and: [internalSpaces = line internalSpaces])
				and: [paddingWidth = line paddingWidth]]
		ifFalse: [^false]! !


!TextLineInterval methodsFor: 'scanning'!
justifiedPadFor: spaceIndex 
	"Compute the width of pad for a given space in a line of justified text."

	| pad |
	internalSpaces = 0 ifTrue: [^0].
	pad _ paddingWidth // internalSpaces.
	spaceIndex <= (paddingWidth \\ internalSpaces)
		ifTrue: [^pad + 1]
		ifFalse: [^pad]! !

!TextLineInterval methodsFor: 'scanning'!
justifiedTabDeltaFor: spaceIndex 
	"Compute the delta for a tab in a line of justified text, so tab falls 
	somewhere plausible when line is justified."

	| pad extraPad |
	internalSpaces = 0 ifTrue: [^0].
	pad _ paddingWidth // internalSpaces.
	extraPad _ paddingWidth \\ internalSpaces.
	spaceIndex <= extraPad
		ifTrue: [^spaceIndex * (pad + 1)]
		ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! !


!TextLineInterval methodsFor: 'updating'!
slide: delta 
	"Change the starting and stopping points of the line by delta."

	start _ start + delta.
	stop _ stop + delta! !


!TextLineInterval methodsFor: 'private'!
internalSpaces: spacesInteger paddingWidth: padWidthInteger

	internalSpaces _ spacesInteger.
	paddingWidth _ padWidthInteger! !

!TextLineInterval methodsFor: 'private'!
lineHeight: height baseline: ascent

	lineHeight _ height.
	baseline _ ascent! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextLineInterval class
	instanceVariableNames: ''!

!TextLineInterval class methodsFor: 'instance creation'!
start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger
	"Answer an instance of me with the arguments as the start, stop points, 
	number of spaces in the line, and width of the padding."
	| newSelf |
	newSelf _ super from: startInteger to: stopInteger by: 1.
	^newSelf internalSpaces: spacesInteger paddingWidth: padWidthInteger! !
HashAndEqualsTestCase subclass: #TextLineTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Text Support'!

!TextLineTest methodsFor: 'initialize-release' stamp: 'mjr 8/20/2003 18:56'!
setUp
	super setUp.
	prototypes
		add: (TextLine
				start: 1
				stop: 50
				internalSpaces: 2
				paddingWidth: 1) ! !
TextAction subclass: #TextLink
	instanceVariableNames: 'classAndMethod'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 5/1/2001 18:17'!
actOnClickFor: aMessageSet
	"Add to the end of the list.  'aClass selector', 'aClass Comment', 'aClass Definition', 'aClass Hierarchy' are the formats allowed."

	aMessageSet addItem: classAndMethod.
	^ true! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:49'!
analyze: aString

	| list |
	list _ super analyze: aString.
	classAndMethod _ list at: 1.
	^ list at: 2! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'LC 10/8/2001 10:53'!
analyze: aString with: nonMethod
	"Initalize this attribute holder with a piece text the user typed into a paragraph.  Returns the text to emphesize (may be different from selection)  Does not return self!!.  nonMethod is what to show when clicked, i.e. the last part of specifier (Comment, Definition, or Hierarchy).  May be of the form:
Point
<Point>
Click Here<Point>
<Point>Click Here
"
	"Obtain the showing text and the instructions"
	| b1 b2 trim |
	b1 _ aString indexOf: $<.
	b2 _ aString indexOf: $>.
	(b1 < b2) & (b1 > 0) ifFalse: ["only one part"
		classAndMethod _ self validate: aString, ' ', nonMethod.
		^ classAndMethod ifNotNil: [aString]].
	"Two parts"
	trim _ aString withBlanksTrimmed.
	(trim at: 1) == $< 
		ifTrue: [(trim last) == $>
			ifTrue: ["only instructions" 
				classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
				^ classAndMethod ifNotNil: [classAndMethod]]
			ifFalse: ["at the front"
				classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
				^ classAndMethod ifNotNil: [aString copyFrom: b2+1 to: aString size]]]
		ifFalse: [(trim last) == $>
			ifTrue: ["at the end"
				classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
				^ classAndMethod ifNotNil: [aString copyFrom: 1 to: b1-1]]
			ifFalse: ["Illegal -- <> has text on both sides"
				^ nil]]
! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:09'!
classAndMethod: aString
	classAndMethod _ aString! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'!
info
	^ classAndMethod! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'nk 2/26/2005 09:50'!
validate: specString
	"Can this string be decoded to be Class space Method (or Comment, Definition, Hierarchy)? If so, return it in valid format, else nil" 

	| list first mid last |
	list _ specString findTokens: ' 	.|'.
	list isEmpty ifTrue: [ ^nil ].
	last _ list last.
	last first isUppercase ifTrue: [
		(#('Comment' 'Definition' 'Hierarchy') includes: last) ifFalse: [^ nil].
		"Check for 'Rectangle Comment Comment' and remove last one"
		(list at: list size - 1 ifAbsent: [^nil]) = last ifTrue: [list _ list allButLast]].
	list size > 3 ifTrue: [^ nil].
	list size < 2 ifTrue: [^ nil].
	Symbol hasInterned: list first ifTrue: [:sym | first _ sym].
	first ifNil: [^ nil].
	Smalltalk at: first ifAbsent: [^ nil].
	mid _ list size = 3 
		ifTrue: [(list at: 2) = 'class' ifTrue: ['class '] ifFalse: [^ nil]]
		ifFalse: [''].
	"OK if method name is not interned -- may not be defined yet"
	^ first, ' ', mid, last! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:44'!
writeScanOn: strm

	strm nextPut: $L; nextPutAll: classAndMethod; nextPut: $;! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextLink class
	instanceVariableNames: ''!

!TextLink class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 08:53'!
scanFrom: strm
	"read a link in the funny format used by Text styles on files. LPoint +;LPoint Comment;"

	^ self new classAndMethod: (strm upTo: $;)! !
TextAttribute subclass: #TextMessageLink
	instanceVariableNames: 'message'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!TextMessageLink commentStamp: '<historical>' prior: 0!
A link to a hidden mail message.  Clicking on it allows the message to be viewed or saved to disk.!


!TextMessageLink methodsFor: 'acting' stamp: 'rbb 2/18/2005 09:33'!
actOnClickFor: evt 
	| choice viewMsg |
	viewMsg _ message containsViewableImage
		ifTrue: ['view this image attachment']
		ifFalse: ['view this attachment'].
	choice _ UIManager default chooseFrom: (Array with: viewMsg 
													with: 'save this attachment' ).
	choice = 1
		ifTrue: ["open a new viewer"
			message viewBody].
	choice = 2
		ifTrue: ["save the mesasge"
			message save].
	^ true! !

!TextMessageLink methodsFor: 'acting' stamp: 'ls 4/30/2000 19:03'!
mayActOnClick
	^true! !


!TextMessageLink methodsFor: 'appearance' stamp: 'ls 4/30/2000 20:34'!
emphasizeScanner: scanner
	scanner textColor: Color brown! !


!TextMessageLink methodsFor: 'initialization' stamp: 'ls 4/30/2000 18:54'!
initialize: message0
	message := message0! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextMessageLink class
	instanceVariableNames: ''!

!TextMessageLink class methodsFor: 'instance creation' stamp: 'ls 4/30/2000 19:00'!
message: aMessage
	^super new initialize: aMessage! !
RectangleMorph subclass: #TextMorph
	instanceVariableNames: 'textStyle text wrapFlag paragraph editor container predecessor successor backgroundColor margins editHistory'
	classVariableNames: 'CaretForm'
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!TextMorph commentStamp: 'sd 2/20/2004 23:25' prior: 0!
TextMorphs support display of text with emphasis.  They also support reasonable text-editing capabilities, as well as embedded hot links, and the ability to embed submorphs in the text.

Late in life, TextMorph was made a subclass of BorderedMorph to provide border and background color if desired.  In order to keep things compatible, protocols have been redirected so that color (preferably textColor) relates to the text, and backgroundColor relates to the inner fill color.

Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter.

If text has been embedded in another object, one can elect to fill the owner's shape, in which case the text will be laid out in the shape of the owner's shadow image (including any submorphs other than the text).  One can also elect to have the text avoid occlusions, in which case it will avoid the bounds of any sibling morphs that appear in front of it.  It may be necessary to update bounds in order for the text runaround to notice the presence of a new occluding shape.

The optional autoFitContents property enables the following feature:  if the text contents changes, then the bounds of the morph will be adjusted to fit the minimum rectangle that encloses the text (plus any margins specified).  Similarly, any attempt to change the size of the morph will be resisted if this parameter is set.  Except...

If the wrapFlag parameter is true, then text will be wrapped at word boundaries based on the composition width (innerBounds insetBy: margins) width.  Thus an attempt to resize the morph in autofit mode, if it changes the width, will cause the text to be recomposed with the new width, and then the bounds will be reset to the minimum enclosing rectangle.  Similarly, if the text contents are changed with the wrapFlag set to true, word wrap will be performed based on the current compostion width, after which the bounds will be set (or not), based on the autoFitcontents property.

Note that fonts can only be applied to the TextMorph as a whole.  While you can change the size, color, and emphasis of a subsection of the text and have it apply to only that subsection, changing the font changes the font for the entire contents of the TextMorph. 

Still a TextMorph can be composed of several texts of different fonts
| font1 font2 t1 t2 tMorph|
tMorph _ TextMorph new.
font1 _ (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 22)).
font2 _ (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 11)).
t1 _ 'this is font1' asText addAttribute: font1.
t2 _ ' and this is font2' asText addAttribute: font2.
tMorph contents: (t1,t2).
tMorph openInHand.


Yet to do:
Make a comprehensive control for the eyedropper, with border width and color, inner color and text color, and margin widths.!


!TextMorph methodsFor: 'accessing' stamp: 'sw 1/12/98 23:40'!
asText
	^ text! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/12/2001 22:25'!
autoFit: trueOrFalse
	self isAutoFit = trueOrFalse ifTrue: [^ self].
	self autoFitOnOff! !

!TextMorph methodsFor: 'accessing' stamp: 'di 6/22/2001 09:33'!
backgroundColor
	^ backgroundColor! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/23/2001 15:30'!
backgroundColor: newColor
	backgroundColor _ newColor.
	self changed! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/19/2001 11:08'!
borderWidth: newWidth
	super borderWidth: newWidth.
	paragraph ifNotNil: [self composeToBounds].! !

!TextMorph methodsFor: 'accessing'!
contents

	^ text! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 8/31/2000 14:59'!
contentsAsIs: stringOrText
	"Accept new text contents with line breaks only as in the text.
	Fit my width and height to the result."
	wrapFlag _ false.
	container ifNotNil: [container fillsOwner ifTrue: [wrapFlag _ true]].
	self newContents: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 09:51'!
contentsWrapped: stringOrText
	"Accept new text contents.  Lay it out, wrapping within my current width.
	Then fit my height to the result."
	wrapFlag _ true.
	self newContents: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 15:48'!
contents: stringOrText
	^ self contentsAsIs: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: 'di 4/14/98 08:33'!
contents: stringOrText wrappedTo: width
	"Accept new text contents.  Lay it out, wrapping to width.
	Then fit my height to the result."
	self newContents: ''.
	wrapFlag _ true.
	super extent: width truncated@self height.
	self newContents: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: 'ar 8/23/2001 21:23'!
crAction
	"Return the action to perform when encountering a CR in the input"
	^self valueOfProperty: #crAction! !

!TextMorph methodsFor: 'accessing' stamp: 'ar 8/23/2001 21:23'!
crAction: aMessageSend
	"Return the action to perform when encountering a CR in the input"
	^self setProperty: #crAction toValue: aMessageSend! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 5/22/2003 02:39'!
cursor
	"Answer the receiver's logical cursor position"

	| loc |
	loc _ self valueOfProperty: #textCursorLocation  ifAbsentPut: [1].
	loc _ loc min: text string size.
	^ loc rounded
	! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 2/17/2003 18:20'!
cursorWrapped: aNumber
	"Set the cursor as indicated"

	self setProperty: #textCursorLocation toValue: (((aNumber rounded - 1) \\  text string size) + 1)

	! !

!TextMorph methodsFor: 'accessing' stamp: 'di 10/5/1998 13:56'!
editor
	"Return my current editor, or install a new one."
	editor ifNotNil: [^ editor].
	^ self installEditorToReplace: nil! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 2/18/2003 02:58'!
elementCount
	"Answer how many sub-objects are within me"

	^ self text string size ! !

!TextMorph methodsFor: 'accessing' stamp: 'nk 8/30/2004 05:43'!
fontName: fontName pointSize: fontSize
	| newTextStyle |
	newTextStyle _ ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy.
	newTextStyle ifNil: [self error: 'font ', fontName, ' not found.'].

	textStyle _ newTextStyle.
	text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfPointSize: fontSize)).
	paragraph ifNotNil: [paragraph textStyle: newTextStyle]! !

!TextMorph methodsFor: 'accessing' stamp: 'nk 7/12/2003 08:39'!
fontName: fontName size: fontSize
	| newTextStyle |
	newTextStyle _ ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy.
	textStyle _ newTextStyle.
	text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: fontSize)).
	paragraph ifNotNil: [paragraph textStyle: newTextStyle]! !

!TextMorph methodsFor: 'accessing' stamp: 'nk 10/16/2003 16:42'!
font: aFont
	| newTextStyle |
	newTextStyle _ aFont textStyle copy ifNil: [ TextStyle fontArray: { aFont } ].
	textStyle _ newTextStyle.
	text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOf: aFont)).
	paragraph ifNotNil: [paragraph textStyle: newTextStyle]! !

!TextMorph methodsFor: 'accessing' stamp: 'kfr 9/21/2003 21:47'!
getFirstCharacter
	"obtain the first character from the receiver if it is empty, return a  
	black dot"
	| aString |
	^ (aString _ text string) isEmpty
		ifTrue: ['·']
		ifFalse: [aString first asString] ! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 8/10/2004 00:53'!
getLastCharacter
	"obtain the last character from the receiver if it is empty, return a black dot"

	| aString |
	^ (aString _ text string) size > 0 ifTrue: [aString last asString] ifFalse: ['·']! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/24/2001 11:20'!
hasTranslucentColor
	"Overridden from BorderedMorph to test backgroundColor instead of (text) color."

	backgroundColor ifNil: [^ true].
	(backgroundColor isColor and: [backgroundColor isTranslucentColor]) ifTrue: [^ true].
	(borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true].
	^ false
! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/12/2001 14:01'!
isAutoFit
	^ self valueOfProperty: #autoFitContents ifAbsent: [true]
! !

!TextMorph methodsFor: 'accessing' stamp: 'RAA 8/21/2001 11:18'!
isWrapped
	
	^wrapFlag! !

!TextMorph methodsFor: 'accessing' stamp: 'RAA 8/21/2001 11:41'!
margins

	^margins! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/20/2001 22:44'!
margins: newMargins
	"newMargins can be a number, point or rectangle, as allowed by, eg, insetBy:."

	margins _ newMargins.
	self composeToBounds! !

!TextMorph methodsFor: 'accessing' stamp: 'BJP 12/1/2003 00:19'!
newContents: stringOrText 
	"Accept new text contents."
	| newText embeddedMorphs |
	"If my text is all the same font, use the font for my new contents"
	newText _ stringOrText isString ifTrue: [ | textSize |
		(text notNil
		  and: [ (textSize _ text size) > 0
		    and: [ (text runLengthFor: 1) = textSize ]]) ifTrue: [ | attribs |
			attribs _ text attributesAt: 1 forStyle: textStyle.
			Text string: stringOrText copy attributes: attribs.
		]
		ifFalse: [ Text fromString: stringOrText copy ]
	]
	ifFalse: [ stringOrText copy asText.	"should be veryDeepCopy?" ].

	(text = newText and: [text runs = newText runs]) ifTrue: [^ self].	"No substantive change"
	text ifNotNil: [(embeddedMorphs _ text embeddedMorphs)
			ifNotNil: 
				[self removeAllMorphsIn: embeddedMorphs.
				embeddedMorphs do: [:m | m delete]]].

	text _ newText.

	"add all morphs off the visible region; they'll be moved into the right 
	place when they become visible. (this can make the scrollable area too 
	large, though)"
	newText embeddedMorphs do: 
		[:m | 
		self addMorph: m.
		m position: -1000 @ 0].
	self releaseParagraph.
	"update the paragraph cache"
	self paragraph.
	"re-instantiate to set bounds"
	self world ifNotNil: [self world startSteppingSubmorphsOf: self]! !

!TextMorph methodsFor: 'accessing' stamp: 'nk 2/26/2001 12:45'!
selectAll
	self editor selectFrom: 1 to: text size! !

!TextMorph methodsFor: 'accessing' stamp: 'nk 2/26/2001 12:45'!
selectFrom: a to: b
	self editor selectFrom: a to: b! !

!TextMorph methodsFor: 'accessing' stamp: 'nk 2/26/2001 12:42'!
selection
	^editor ifNotNil: [ editor selection ]! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 9/1/2000 10:43'!
setCharacters: chars
	"obtain a string value from the receiver"

	(self getCharacters = chars) ifFalse:
		[self newContents: chars]! !

!TextMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:32'!
setFirstCharacter: source 
	"Set the first character of the receiver as indicated"
	| aChar chars |
	aChar _ source asCharacter.
	(chars _ self getCharacters) isEmpty
		ifTrue: [self
				newContents: (String with: aChar)]
		ifFalse: [chars first = aChar
				ifFalse: [self
						newContents: (String
								streamContents: [:aStream | 
									aStream nextPut: aChar.
									aStream
										nextPutAll: (chars copyFrom: 2 to: chars size)])]] ! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 8/10/2004 00:56'!
setLastCharacter: source
	"Set the last character of the receiver as indicated"

	| aChar chars |
	aChar _ source asCharacter.
	(chars _ self getCharacters) size > 0 
		ifFalse:
			[self newContents: (String with: aChar)]
		ifTrue:
			[(chars last = aChar) ifFalse:
				[self newContents: (String streamContents:
					[:aStream |
						aStream nextPutAll: (chars copyFrom: 1 to: (chars size - 1)).
						aStream nextPut: aChar])]]! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 1/10/2001 13:52'!
text
	^ text! !

!TextMorph methodsFor: 'accessing' stamp: 'nk 7/3/2003 18:33'!
textAlignment
	"Answer 1..4, representing #leftFlush, #rightFlush, #centered, or #justified"
	^self editor textAlignment! !

!TextMorph methodsFor: 'accessing' stamp: 'nk 6/18/2003 14:28'!
textAlignmentSymbol
	"Answer one of #leftFlush, #rightFlush, #centered, or #justified"
	^self editor textAlignmentSymbol! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/21/2001 10:37'!
textColor

	^ color! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/21/2001 10:35'!
textColor: aColor

	color = aColor ifTrue: [^ self].
	color _ aColor.
	self changed.
! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 9/1/2000 13:50'!
textStyle
	^textStyle! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:58'!
userString
	"Do I have a text string to be searched on?"

	^ text string! !

!TextMorph methodsFor: 'accessing' stamp: 'di 7/27/2001 13:10'!
wrapFlag: aBoolean
	"Change whether contents are wrapped to the container."

	aBoolean == wrapFlag ifTrue: [^ self].
	wrapFlag _ aBoolean.
	self composeToBounds! !


!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:19'!
centered 
	self paragraph centered.
	self updateFromParagraph ! !

!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'!
justified 
	self paragraph justified.
	self updateFromParagraph! !

!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'!
leftFlush 
	self paragraph leftFlush.
	self updateFromParagraph! !

!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'!
rightFlush 
	self paragraph rightFlush.
	self updateFromParagraph! !


!TextMorph methodsFor: 'anchors' stamp: 'ar 12/17/2001 13:38'!
adjustTextAnchor: aMorph
	"Later compute the new relative position of aMorph if it is #paragraph anchored."! !

!TextMorph methodsFor: 'anchors' stamp: 'ar 8/10/2003 18:19'!
anchorMorph: aMorph at: aPoint type: anchorType
	| relPt index newText block |
	aMorph owner == self ifTrue:[self removeMorph: aMorph].
	aMorph textAnchorType: nil.
	aMorph relativeTextAnchorPosition: nil.
	self addMorphFront: aMorph.
	aMorph textAnchorType: anchorType.
	aMorph relativeTextAnchorPosition: nil.
	anchorType == #document ifTrue:[^self].
	relPt _ self transformFromWorld globalPointToLocal: aPoint.
	index _ (self paragraph characterBlockAtPoint: relPt) stringIndex.
	newText _ Text string: (String value: 1) attribute: (TextAnchor new anchoredMorph: aMorph).
	anchorType == #inline ifTrue:[
		self paragraph replaceFrom: index to: index-1 with: newText displaying: false.
	] ifFalse:[
		index _ index min: paragraph text size.
		index _ paragraph text string lastIndexOf: Character cr startingAt: index ifAbsent:[0].
		block _ paragraph characterBlockForIndex: index+1.
		aMorph relativeTextAnchorPosition: (relPt x - bounds left) @ (relPt y - block top ).
		self paragraph replaceFrom: index+1 to: index with: newText displaying: false.
	].
	self fit.! !


!TextMorph methodsFor: 'caching' stamp: 'di 11/13/97 15:17'!
loadCachedState
	"Prepare for fast response -- next page of a book?"
	self paragraph! !

!TextMorph methodsFor: 'caching' stamp: 'BG 11/20/2004 12:36'!
releaseCachedState

	super releaseCachedState.
	self releaseParagraph; paragraph.
! !


!TextMorph methodsFor: 'change reporting' stamp: 'di 10/18/2004 13:50'!
ownerChanged
	| priorEditor |
	super ownerChanged.
	container ifNotNil: 
			[editor isNil 
				ifTrue:
					[self releaseParagraph.
					(container isKindOf: TextContainer) ifTrue:
						["May need to recompose due to changes in owner"
						self installEditorToReplace: nil.
						self releaseParagraph]]
				ifFalse: 
					[priorEditor := editor.
					self releaseParagraph.
					self installEditorToReplace: priorEditor]]! !


!TextMorph methodsFor: 'classification' stamp: 'ar 12/17/2001 12:46'!
isTextMorph
	^true! !


!TextMorph methodsFor: 'containment' stamp: 'nk 8/18/2004 11:23'!
avoidsOcclusions
	^container notNil and: [ container avoidsOcclusions ]
! !

!TextMorph methodsFor: 'containment' stamp: 'nk 8/18/2004 11:37'!
fillingOnOff
	"Establish a container for this text, with opposite filling status"
	self fillsOwner: (self fillsOwner not)! !

!TextMorph methodsFor: 'containment' stamp: 'nk 8/18/2004 11:21'!
fillsOwner
	"Answer true if I fill my owner's shape."
	^container notNil and: [container fillsOwner]! !

!TextMorph methodsFor: 'containment' stamp: 'nk 8/18/2004 11:38'!
fillsOwner: aBoolean 
	self fillsOwner == aBoolean
		ifTrue: [^ self].
	self
		setContainer: (aBoolean
				ifTrue: [wrapFlag := true.
					container
						ifNil: [TextContainer new for: self minWidth: textStyle lineGrid * 2]
						ifNotNil: [container fillsOwner: true]]
				ifFalse: [self avoidsOcclusions
						ifFalse: [ nil ]
						ifTrue: [container fillsOwner: false]])! !

!TextMorph methodsFor: 'containment' stamp: 'di 11/4/97 15:37'!
occlusionsOnOff
	"Establish a container for this text, with opposite occlusion avoidance status"
	self setContainer:
	(container
	ifNil: [(TextContainer new for: self minWidth: textStyle lineGrid*2)
							fillsOwner: false; avoidsOcclusions: true]
	ifNotNil: [(container avoidsOcclusions and: [container fillsOwner not])
			ifTrue: [nil  "Return to simple rectangular bounds"]
			ifFalse: [container avoidsOcclusions: container avoidsOcclusions not]])! !

!TextMorph methodsFor: 'containment' stamp: 'sw 12/16/1998 09:09'!
recognizerArena
	"Answer the rectangular area, in world coordinates, that the character recognizer should regard as its tablet"

	| outer |
	^ (outer _ self ownerThatIsA: PluggableTextMorph)
		ifNotNil:
			[outer boundsInWorld]
		ifNil:
			[self boundsInWorld]! !

!TextMorph methodsFor: 'containment' stamp: 'di 11/12/97 09:06'!
setContainer: newContainer
	"Adopt (or abandon) container shape"
	self changed.
	container _ newContainer.
	self releaseParagraph! !


!TextMorph methodsFor: 'copying' stamp: 'di 11/12/97 09:31'!
copy
	^ super copy text: text copy textStyle: textStyle copy 
		wrap: wrapFlag color: color
		predecessor: nil successor: nil! !

!TextMorph methodsFor: 'copying' stamp: 'tk 2/20/2001 18:55'!
veryDeepFixupWith: deepCopier 
	"If target and arguments fields were weakly copied, fix them here.  If 
	they were in the tree being copied, fix them up, otherwise point to the 
	originals!!"

	super veryDeepFixupWith: deepCopier.
	"It makes no sense to share pointers to an existing predecessor and successor"
	predecessor _ deepCopier references at: predecessor ifAbsent: [nil].
	successor _ deepCopier references at: successor ifAbsent: [nil]! !

!TextMorph methodsFor: 'copying' stamp: 'md 8/15/2005 11:17'!
veryDeepInner: deepCopier 
	"Copy all of my instance variables. Some need to be not copied at all, but shared.
	Warning!!!! Every instance variable defined in this class must be handled.
	We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	textStyle _ textStyle veryDeepCopyWith: deepCopier.
	text _ text veryDeepCopyWith: deepCopier.
	wrapFlag _ wrapFlag veryDeepCopyWith: deepCopier.
	paragraph _ paragraph veryDeepCopyWith: deepCopier.
	editor _ editor veryDeepCopyWith: deepCopier.
	container _ container veryDeepCopyWith: deepCopier.
	predecessor _ predecessor.
	successor _ successor.
	backgroundColor _ backgroundColor veryDeepCopyWith: deepCopier.
	margins _ margins veryDeepCopyWith: deepCopier.
	editHistory _ editHistory veryDeepCopyWith: deepCopier.
! !


!TextMorph methodsFor: 'drawing' stamp: 'di 7/24/2001 11:18'!
areasRemainingToFill: aRectangle
	"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
	(backgroundColor isNil or: [backgroundColor isTranslucent])
		ifTrue: [^ Array with: aRectangle].
	self wantsRoundedCorners
	ifTrue: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]])
				ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)]
				ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]]
	ifFalse: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]])
				ifTrue: [^ aRectangle areasOutside: self innerBounds]
				ifFalse: [^ aRectangle areasOutside: self bounds]]! !

!TextMorph methodsFor: 'drawing' stamp: 'di 7/12/2001 10:45'!
debugDrawLineRectsOn: aCanvas
	"Shows where text line rectangles are"
	self paragraph lines do:
		[:line | aCanvas frameRectangle: line rectangle color: Color brown]
! !

!TextMorph methodsFor: 'drawing' stamp: 'nk 1/1/2004 21:10'!
drawNullTextOn: aCanvas
	"make null text frame visible"

	aCanvas isPostscriptCanvas ifFalse: [
	aCanvas fillRectangle: bounds color: 
		((Color black) alpha: 0.1).
		]! !

!TextMorph methodsFor: 'drawing' stamp: 'yo 1/23/2003 18:04'!
drawOnTest: aCanvas
	"Draw the receiver on a canvas"

	| fauxBounds |
	self setDefaultContentsIfNil.
	super drawOn: aCanvas.  "Border and background if any"
	false ifTrue: [self debugDrawLineRectsOn: aCanvas].  "show line rects for debugging"
	(self startingIndex > text size)
		ifTrue: [self drawNullTextOn: aCanvas].
	"Hack here:  The canvas expects bounds to carry the location of the text, but we also need to communicate clipping."
	fauxBounds _ self bounds topLeft corner: self innerBounds bottomRight.
	aCanvas paragraph3: self paragraph bounds: fauxBounds color: color! !

!TextMorph methodsFor: 'drawing' stamp: 'sw 4/25/2002 00:52'!
drawOn: aCanvas
	"Draw the receiver on a canvas"

	| fauxBounds |
	self setDefaultContentsIfNil.
	super drawOn: aCanvas.  "Border and background if any"
	false ifTrue: [self debugDrawLineRectsOn: aCanvas].  "show line rects for debugging"
	(self startingIndex > text size)
		ifTrue: [self drawNullTextOn: aCanvas].
	"Hack here:  The canvas expects bounds to carry the location of the text, but we also need to communicate clipping."
	fauxBounds _ self bounds topLeft corner: self innerBounds bottomRight.
	aCanvas paragraph: self paragraph bounds: fauxBounds color: color! !


!TextMorph methodsFor: 'editing' stamp: 'di 4/22/1998 10:57'!
acceptContents
	"The message is sent when the user hits enter or Cmd-S.
	Accept the current contents and end editing.
	This default implementation does nothing."
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'sw 8/12/2002 01:10'!
acceptOnCR
	"Answer whether the receiver wants to accept when the Return key is hit.  Generic TextMorph has no such feature, but subclasses may."

	^ false! !

!TextMorph methodsFor: 'editing' stamp: 'di 4/22/1998 11:00'!
cancelEdits
	"The message is sent when the user hits enter or Cmd-L.
	Cancel the current contents and end editing.
	This default implementation does nothing."
	self releaseParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'!
chooseAlignment
	self editor changeAlignment.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'!
chooseEmphasis
	self editor changeEmphasis.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'sw 9/27/1999 12:13'!
chooseEmphasisOrAlignment
	self editor changeEmphasisOrAlignment.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'ar 12/17/2001 13:09'!
chooseFont
	self editor changeTextFont.
	self updateFromParagraph.! !

!TextMorph methodsFor: 'editing' stamp: 'vj 9/14/2003 20:53'!
chooseStyle
	self editor changeStyle.
	self updateFromParagraph.! !

!TextMorph methodsFor: 'editing' stamp: 'ar 9/26/2001 22:45'!
enterClickableRegion: evt
	| index isLink |
	evt hand hasSubmorphs ifTrue:[^self].
	evt hand temporaryCursor ifNotNil:[^self].
	paragraph ifNotNil:[
		index _ (paragraph characterBlockAtPoint: evt position) stringIndex.
		isLink _ (paragraph text attributesAt: index forStyle: paragraph textStyle) 
					anySatisfy:[:attr| attr mayActOnClick].
		isLink ifTrue:[Cursor webLink show] ifFalse:[Cursor normal show].
	].
! !

!TextMorph methodsFor: 'editing' stamp: 'di 4/12/98 11:36'!
handleEdit: editBlock
	"Ensure that changed areas get suitably redrawn"
	self selectionChanged.  "Note old selection"
		editBlock value.
	self selectionChanged.  "Note new selection"
	self updateFromParagraph  "Propagate changes as necessary"! !

!TextMorph methodsFor: 'editing' stamp: 'nk 8/31/2004 15:31'!
handleInteraction: interactionBlock fromEvent: evt
	"Perform the changes in interactionBlock, noting any change in selection
	and possibly a change in the size of the paragraph (ar 9/22/2001 - added for TextPrintIts)"
	"Also couple ParagraphEditor to Morphic keyboard events"
	| oldEditor oldParagraph oldText |
	self editor sensor: (KeyboardBuffer new startingEvent: evt).
	oldEditor _ editor.
	oldParagraph _ paragraph.
	oldText _ oldParagraph text copy.

	self selectionChanged.  "Note old selection"

		interactionBlock value.

	(oldParagraph == paragraph) ifTrue:[
		"this will not work if the paragraph changed"
		editor _ oldEditor.     "since it may have been changed while in block"
	].
	self selectionChanged.  "Note new selection"
	(oldText = paragraph text and: [ oldText runs = paragraph text runs ])
		ifFalse:[ self updateFromParagraph ].
	self setCompositionWindow.! !

!TextMorph methodsFor: 'editing' stamp: 'di 4/21/1998 13:22'!
hasUnacceptedEdits: aBoolean
	"Ignored here, but noted in TextMorphForEditView"
! !

!TextMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:29'!
passKeyboardFocusTo: otherMorph 
	| w |
	self flag: #arNote.	"Do we need this?!!"
	(w := self world) isNil 
		ifFalse: 
			[w 
				handsDo: [:h | h keyboardFocus == self ifTrue: [h newKeyboardFocus: otherMorph]]]! !

!TextMorph methodsFor: 'editing' stamp: 'fbs 1/7/2005 15:42'!
preferredKeyboardPosition

	| default rects |
	default  _ (self bounds: self bounds in: World) topLeft.
	paragraph ifNil: [^ default].
	rects _ paragraph selectionRects.
	rects size = 0 ifTrue: [^ default].
	^ rects first topLeft.

	"^ (self bounds: self bounds in: World) topLeft."
! !

!TextMorph methodsFor: 'editing' stamp: 'yo 11/7/2002 19:11'!
setCompositionWindow

	| hand |
	hand _ self primaryHand.
	hand ifNotNil: [hand compositionWindowManager keyboardFocusForAMorph: self].
! !

!TextMorph methodsFor: 'editing'!
xeqLinkText: sourceString withParameter: param
	self confirm: 'xeqLinkText:
' asText allBold , sourceString asText! !


!TextMorph methodsFor: 'event handling' stamp: 'dgd 10/1/2004 12:40'!
getMenu: shiftKeyState 
	^ (shiftKeyState not
			or: [Preferences noviceMode])
		ifTrue: [ParagraphEditor yellowButtonMenu]
		ifFalse: [ParagraphEditor shiftedYellowButtonMenu]! !

!TextMorph methodsFor: 'event handling' stamp: 'ar 10/4/2000 19:09'!
handlesKeyboard: evt
	^true! !

!TextMorph methodsFor: 'event handling' stamp: 'di 7/21/2001 09:44'!
handlesMouseDown: evt
	self isPartsDonor ifTrue: [^ false].
	^ self innerBounds containsPoint: evt cursorPoint! !

!TextMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 19:04'!
hasFocus
	^editor notNil! !

!TextMorph methodsFor: 'event handling' stamp: 'nk 8/29/2004 21:29'!
keyboardFocusChange: aBoolean 
	| w |
	paragraph isNil ifFalse:[paragraph focused: aBoolean].
	aBoolean 
		ifTrue: 
			["A hand is wanting to send us characters..."

			self hasFocus ifFalse: [self editor	"Forces install"]]
		ifFalse: 
			["A hand has clicked elsewhere..."

			(w := self world) isNil 
				ifFalse: 
					[w handsDo: [:h | h keyboardFocus == self ifTrue: [^self]].
					"Release control unless some hand is still holding on"
					self releaseEditor]]! !

!TextMorph methodsFor: 'event handling' stamp: 'Tsutomu Hiroshima 11/17/2003 08:49'!
keyStroke: evt
	"Handle a keystroke event."
	| action |
	evt keyValue = 13 ifTrue:["CR - check for special action"
		action _ self crAction.
		action ifNotNil:[
			"Note: Code below assumes that this was some
			input field reacting on CR. Break the keyboard
			focus so that the receiver can be safely deleted."
			evt hand newKeyboardFocus: nil.
			^action value]].
	self handleInteraction: [editor readKeyboard] fromEvent: evt.
	"self updateFromParagraph."
	super keyStroke: evt  "sends to keyStroke event handler, if any"! !

!TextMorph methodsFor: 'event handling' stamp: 'dgd 9/18/2004 20:06'!
mouseDown: evt 
	"Make this TextMorph be the keyboard input focus, if it isn't  
	already, and repond to the text selection gesture."
	evt yellowButtonPressed
		ifTrue: ["First check for option (menu) click"
			^ self yellowButtonActivity: evt shiftPressed].
	evt hand newKeyboardFocus: self.
	self
		handleInteraction: [editor mouseDown: evt]
		fromEvent: evt.
! !

!TextMorph methodsFor: 'event handling' stamp: 'ar 9/26/2001 22:22'!
mouseMove: evt
	evt redButtonPressed ifFalse: [^ self enterClickableRegion: evt].
	self handleInteraction: [editor mouseMove: evt] fromEvent: evt! !

!TextMorph methodsFor: 'event handling' stamp: 'di 12/3/97 20:04'!
mouseUp: evt
	self handleInteraction: [editor mouseUp: evt] fromEvent: evt! !

!TextMorph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 13:54'!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver might accept keyboard focus if 
	tab were hit in some container playfield"
	^ self inPartsBin not! !

!TextMorph methodsFor: 'event handling' stamp: 'dgd 10/1/2004 13:24'!
yellowButtonActivity
	"Supply the normal 'code pane' menu to use its text editing 
	commands from a menu."
	self yellowButtonActivity:false! !

!TextMorph methodsFor: 'event handling' stamp: 'dgd 10/1/2004 13:15'!
yellowButtonActivity: shiftKeyState 
	"Invoke the text-editing menu"
	| menu |
	(menu := self getMenu: shiftKeyState)
		ifNotNil: [""
			menu setInvokingView: self editor.
			menu invokeModal. self changed]! !


!TextMorph methodsFor: 'events-processing' stamp: 'sw 3/1/2001 17:16'!
handleKeystroke: anEvent
	"System level event handling."

	| pasteUp |
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:	[^ self].
	anEvent wasHandled: true.
	anEvent keyCharacter = Character tab ifTrue:
		["Allow passing through text morph inside pasteups"
		(self wouldAcceptKeyboardFocusUponTab and:
				[(pasteUp _ self pasteUpMorphHandlingTabAmongFields) notNil])
			ifTrue:[^ pasteUp tabHitWithEvent: anEvent]].
	self keyStroke: anEvent! !

!TextMorph methodsFor: 'events-processing' stamp: 'ar 9/26/2001 22:21'!
handleMouseMove: anEvent
	"Re-implemented to allow for mouse-up move events"
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(anEvent hand hasSubmorphs) ifTrue:[^self].
	anEvent wasHandled: true.
	self mouseMove: anEvent.
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
	(self handlesMouseStillDown: anEvent) ifTrue:[
		"Step at the new location"
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].
! !


!TextMorph methodsFor: 'geometry' stamp: 'di 10/8/1998 23:46'!
bounds
	container ifNil: [^ bounds].
	^ container bounds ifNil: [bounds]! !

!TextMorph methodsFor: 'geometry' stamp: 'di 7/19/2001 10:57'!
container
	"Return the container for composing this text.  There are four cases:
	1.  container is specified as, eg, an arbitrary shape,
	2.  container is specified as the bound rectangle, because
		this morph is linked to others,
	3.  container is nil, and wrap is true -- grow downward as necessary,
	4.  container is nil, and wrap is false -- grow in 2D as nexessary."

	container ifNil:
		[successor ifNotNil: [^ self compositionRectangle].
		wrapFlag ifTrue: [^ self compositionRectangle withHeight: 9999999].
		^ self compositionRectangle topLeft extent: 9999999@9999999].
	^ container! !

!TextMorph methodsFor: 'geometry' stamp: 'di 8/14/1998 15:50'!
defaultLineHeight
	^ textStyle lineGrid! !

!TextMorph methodsFor: 'geometry' stamp: 'nk 7/11/2004 20:07'!
extent: aPoint 
	| newExtent priorEditor |
	bounds extent = aPoint ifTrue: [^ self].
	priorEditor _ editor.
	self isAutoFit
		ifTrue: [wrapFlag ifFalse: [^ self].  "full autofit can't change"
				newExtent _ aPoint truncated max: self minimumExtent.
				newExtent x = self extent x ifTrue: [^ self].  "No change of wrap width"
				self releaseParagraphReally.  "invalidate the paragraph cache"
				super extent: newExtent.
				priorEditor
					ifNil: [self fit]  "since the width has changed..."
					ifNotNil: [self installEditorToReplace: priorEditor]]
		ifFalse: [super extent: (aPoint truncated max: self minimumExtent).
				wrapFlag ifFalse: [^ self].  "no effect on composition"
				self composeToBounds]
! !

!TextMorph methodsFor: 'geometry' stamp: 'di 7/20/2001 22:51'!
minimumExtent
	| minExt |
	textStyle ifNil: [^ 9@16].
	borderWidth ifNil: [^ 9@16].
	minExt _ (9@(textStyle lineGrid+2)) + (borderWidth*2).
	margins ifNil: [^ minExt].
	^ ((0@0 extent: minExt) expandBy: margins) extent! !

!TextMorph methodsFor: 'geometry' stamp: 'dgd 2/21/2003 22:29'!
privateMoveBy: delta 
	super privateMoveBy: delta.
	editor isNil 
		ifTrue: [paragraph ifNotNil: [paragraph moveBy: delta]]
		ifFalse: 
			["When moving text with an active editor, save and restore all state."

			paragraph moveBy: delta.
			self installEditorToReplace: editor]! !

!TextMorph methodsFor: 'geometry' stamp: 'di 3/1/98 11:40'!
textBounds
	^ bounds! !


!TextMorph methodsFor: 'geometry testing' stamp: 'di 7/12/2001 22:15'!
containsPoint: aPoint
	(super containsPoint: aPoint) ifFalse: [^ false].  "Not in my bounds"
	container ifNil: [^ true].  "In bounds of simple text"
	self startingIndex > text size ifTrue:
		["make null text frame visible"
		^ super containsPoint: aPoint].
	"In complex text (non-rect container), test by line bounds"
	^ self paragraph containsPoint: aPoint
! !


!TextMorph methodsFor: 'initialization' stamp: 'di 12/29/97 14:42'!
beAllFont: aFont

	textStyle _ TextStyle fontArray: (Array with: aFont).
	self releaseCachedState; changed! !

!TextMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color black! !

!TextMorph methodsFor: 'initialization' stamp: 'di 7/27/2001 11:56'!
initialize
	super initialize.
	borderWidth _ 0.
	textStyle _ TextStyle default copy.
	wrapFlag _ true.
! !

!TextMorph methodsFor: 'initialization' stamp: 'di 11/17/2001 15:34'!
setTextStyle: aTextStyle

	textStyle _ aTextStyle.
	self releaseCachedState; changed! !

!TextMorph methodsFor: 'initialization' stamp: 'mir 8/2/1999 10:34'!
string: aString fontName: aName size: aSize

	self string: aString fontName: aName size: aSize wrap: true! !

!TextMorph methodsFor: 'initialization' stamp: 'mir 8/2/1999 10:35'!
string: aString fontName: aName size: aSize wrap: shouldWrap

	shouldWrap
		ifTrue: [self contentsWrapped: aString]
		ifFalse: [self contents: aString].
	self fontName: aName size: aSize! !


!TextMorph methodsFor: 'layout' stamp: 'tk 6/30/1998 17:06'!
acceptDroppingMorph: aMorph event: evt
	"This message is sent when a morph is dropped onto me."

	self addMorphFront: aMorph fromWorldPosition: aMorph position.
		"Make a TextAnchor and install it in a run."! !


!TextMorph methodsFor: 'linked frames' stamp: 'di 7/28/2001 10:34'!
addPredecessor: evt
	| newMorph |
	newMorph _ self copy predecessor: predecessor successor: self.
	newMorph extent: self width @ 100.
	predecessor ifNotNil: [predecessor setSuccessor: newMorph].
	self setPredecessor: newMorph.
	predecessor recomposeChain.
	evt hand attachMorph: newMorph! !

!TextMorph methodsFor: 'linked frames' stamp: 'di 7/28/2001 10:35'!
addSuccessor: evt
	| newMorph |
	newMorph _ self copy predecessor: self successor: successor.
	newMorph extent: self width @ 100.
	successor ifNotNil: [successor setPredecessor: newMorph].
	self setSuccessor: newMorph.
	successor recomposeChain.
	evt hand attachMorph: newMorph! !

!TextMorph methodsFor: 'linked frames' stamp: 'di 11/8/97 15:51'!
firstCharacterIndex
	^ self paragraph firstCharacterIndex! !

!TextMorph methodsFor: 'linked frames' stamp: 'dgd 2/21/2003 22:26'!
firstInChain
	"Return the first morph in a chain of textMorphs"

	| first |
	first := self.
	[first predecessor isNil] whileFalse: [first := first predecessor].
	^first! !

!TextMorph methodsFor: 'linked frames' stamp: 'di 11/16/97 15:15'!
isLinkedTo: aMorph
	self firstInChain withSuccessorsDo:
		[:m | m == aMorph ifTrue: [^ true]].
	^ false! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
lastCharacterIndex
	^ self paragraph lastCharacterIndex! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
predecessor
	^ predecessor! !

!TextMorph methodsFor: 'linked frames' stamp: 'di 11/12/97 09:10'!
recomposeChain
	"Recompose this textMorph and all that follow it."
	self withSuccessorsDo:
		[:m |  m text: text textStyle: textStyle;  "Propagate new style if any"
				releaseParagraph;  "Force recomposition"
				fit  "and propagate the change"]! !

!TextMorph methodsFor: 'linked frames' stamp: 'dgd 2/21/2003 22:32'!
startingIndex
	predecessor isNil
		ifTrue: [^ 1].
	^ predecessor lastCharacterIndex + 1 ! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
successor
	^ successor! !

!TextMorph methodsFor: 'linked frames' stamp: 'dgd 2/21/2003 22:32'!
withSuccessorsDo: aBlock 
	"Evaluate aBlock for each morph in my successor chain"

	| each |
	each := self.
	[each isNil] whileFalse: 
			[aBlock value: each.
			each := each successor]! !


!TextMorph methodsFor: 'menu' stamp: 'nk 9/1/2004 20:26'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	| outer |
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'text properties...' translated action: #changeTextColor.
	aCustomMenu addUpdating: #autoFitString target: self action: #autoFitOnOff.
	aCustomMenu addUpdating: #wrapString target: self action: #wrapOnOff.
	aCustomMenu add: 'text margins...' translated action: #changeMargins:.
	aCustomMenu add: 'add predecessor' translated action: #addPredecessor:.
	aCustomMenu add: 'add successor' translated action: #addSuccessor:.
	(Preferences noviceMode
			or: [Preferences simpleMenus])
		ifFalse: [aCustomMenu add: 'code pane menu...' translated action: #yellowButtonActivity.
			aCustomMenu add: 'code pane shift menu...' translated action: #shiftedYellowButtonActivity].

	outer _ self owner.
	outer ifNotNil: [
	outer isLineMorph ifTrue:
		[container isNil
			ifTrue: [aCustomMenu add: 'follow owner''s curve' translated action: #followCurve]
			ifFalse: [aCustomMenu add: 'reverse direction' translated action: #reverseCurveDirection.
					aCustomMenu add: 'set baseline' translated action: #setCurveBaseline:]]
		ifFalse:
		[self fillsOwner
			ifFalse: [aCustomMenu add: 'fill owner''s shape' translated action: #fillingOnOff]
			ifTrue: [aCustomMenu add: 'rectangular bounds' translated action: #fillingOnOff].
		self avoidsOcclusions
			ifFalse: [aCustomMenu add: 'avoid occlusions' translated action: #occlusionsOnOff]
			ifTrue: [aCustomMenu add: 'ignore occlusions' translated action: #occlusionsOnOff]]].
	aCustomMenu addLine.
	aCustomMenu add: 'holder for characters' translated action: #holderForCharacters
! !

!TextMorph methodsFor: 'menu' stamp: 'di 7/27/2001 13:19'!
autoFitOnOff
	self setProperty: #autoFitContents toValue: self isAutoFit not.
	self isAutoFit ifTrue: [self fit]! !

!TextMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:06'!
autoFitString
	"Answer the string to put in a menu that will invite the user to 
	switch autoFit mode"
	^ (self isAutoFit
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'text auto fit' translated! !

!TextMorph methodsFor: 'menu' stamp: 'sw 1/31/2006 05:33'!
changeMargins: evt
	| handle origin aHand oldMargin newMargin |
	aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin _ aHand position.
	oldMargin _ margins.
	handle _ HandleMorph new
		forEachPointDo:
			[:newPoint | handle removeAllMorphs.
			handle addMorph:
				(LineMorph from: origin to: newPoint color: Color black width: 1).
			newMargin _ (newPoint - origin max: 0@0) // 5.
			self margins: newMargin]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo ifNotNilDo: [:halo | halo addHandles].
			self rememberCommand:
				(Command new cmdWording: ('margin change for ' translated,self nameForUndoWording);
					undoTarget: self selector: #margins: argument: oldMargin;
					redoTarget: self selector: #margins: argument: newMargin;
					yourself)].
	aHand attachMorph: handle.
	handle setProperty: #helpAtCenter toValue: true.
	handle showBalloon:
'Move cursor down and to the right
to increase margin inset.
Click when done.' hand: evt hand.
	handle startStepping! !

!TextMorph methodsFor: 'menu' stamp: 'RAA 8/21/2001 11:08'!
changeTextColor
	"Change the color of the receiver -- triggered, e.g. from a menu"

	self openATextPropertySheet.
">>>>>
	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #textColor:;
		originalColor: self textColor;
		putUpFor: self near: self fullBoundsInWorld
<<<<"! !

!TextMorph methodsFor: 'menu' stamp: 'di 10/8/1998 23:40'!
followCurve
	self setContainer: (TextOnCurveContainer new baseline: 0; textDirection: 1).
	self changed! !

!TextMorph methodsFor: 'menu' stamp: 'sw 2/18/2003 03:20'!
holderForCharacters
	"Hand the user a Holder that is populated with individual text morphs representing my characters"

	| aHolder |
	aHolder _ ScriptingSystem prototypicalHolder.
	aHolder setNameTo: 'H', self externalName.
	text string do:
		[:aChar |
			aHolder addMorphBack: (TextMorph new contents: aChar asText)].
	aHolder setProperty: #donorTextMorph toValue: self.
	aHolder fullBounds.
	aHolder openInHand! !

!TextMorph methodsFor: 'menu' stamp: 'di 12/3/97 09:40'!
reverseCurveDirection
	container textDirection: container textDirection negated.
	self paragraph composeAll! !

!TextMorph methodsFor: 'menu' stamp: 'di 12/3/97 10:25'!
setCurveBaseline: evt
	| handle origin |
	origin _ evt cursorPoint.
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | handle removeAllMorphs.
		handle addMorph:
			(PolygonMorph vertices: (Array with: origin with: newPoint)
				color: Color black borderWidth: 1 borderColor: Color black).
		container baseline: (newPoint - origin) y negated asInteger // 5.
		self paragraph composeAll].
	evt hand attachMorph: handle.
	handle startStepping	! !

!TextMorph methodsFor: 'menu' stamp: 'tk 7/14/2000 12:20'!
shiftedYellowButtonActivity
	"Supply the normal 'code pane' menu to use its text editing commands from a menu."

	self editor pluggableYellowButtonActivity: true.
	self changed.
! !

!TextMorph methodsFor: 'menu' stamp: 'di 7/27/2001 13:20'!
wrapOnOff
	self wrapFlag: wrapFlag not! !

!TextMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:18'!
wrapString
	"Answer the string to put in a menu that will invite the user to 
	switch autoFit mode"
	^ (wrapFlag
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		, 'text wrap to bounds' translated! !


!TextMorph methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 22:57'!
editHistory
	editHistory ifNil: [ editHistory _ TextMorphCommandHistory new].
	^editHistory
! !

!TextMorph methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 16:49'!
editHistory: aTextMorphCommandHistory
	^editHistory _ aTextMorphCommandHistory 
! !


!TextMorph methodsFor: 'objects from disk' stamp: 'di 7/30/2001 14:19'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	borderWidth ifNil:
		[borderWidth _ 0.
		self removeProperty: #fillStyle].
	^ super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !

!TextMorph methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 16:54'!
fixUponLoad: aProject seg: anImageSegment
	"We are in an old project that is being loaded from disk.
Fix up conventions that have changed."

	| substituteFont |
	substituteFont _ aProject projectParameters at:
#substitutedFont ifAbsent: [#none].
	(substituteFont ~~ #none and: [self textStyle fontArray
includes: substituteFont])
			ifTrue: [ self fit ].

	^ super fixUponLoad: aProject seg: anImageSegment! !


!TextMorph methodsFor: 'scripting access' stamp: 'sw 9/15/2000 06:14'!
getAllButFirstCharacter
	"Obtain all but the first character from the receiver; if that would be empty, return a black dot"

	| aString |
	^ (aString _ text string) size > 1 ifTrue: [aString copyFrom: 2 to: aString size] ifFalse: ['·']! !

!TextMorph methodsFor: 'scripting access' stamp: 'sw 10/13/2004 19:57'!
insertCharacters: aSource
	"Insert the characters from the given source at my current cursor position"

	| aLoc |
	aLoc _ self cursor max: 1.
	paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
	self updateFromParagraph  ! !

!TextMorph methodsFor: 'scripting access' stamp: 'sw 2/18/2003 02:46'!
insertContentsOf: aPlayer
	"Insert the characters from the given player at my current cursor position"

	| aLoc |
	aLoc _ self cursor.
	paragraph replaceFrom: aLoc to: (aLoc - 1) with: aPlayer getStringContents displaying: true.
	self updateFromParagraph  ! !

!TextMorph methodsFor: 'scripting access' stamp: 'dgd 2/21/2003 22:31'!
setAllButFirstCharacter: source 
	"Set all but the first char of the receiver to the source"
	| aChar chars |
	aChar _ source asCharacter.
	(chars _ self getCharacters) isEmpty
		ifTrue: [self newContents: '·' , source asString]
		ifFalse: [chars first = aChar
				ifFalse: [""
					self
						newContents: (String
								streamContents: [:aStream | 
									aStream nextPut: chars first.
									aStream nextPutAll: source])]] ! !


!TextMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 12/17/2001 13:21'!
addMorphFront: aMorph fromWorldPosition: wp 
	"Overridden for more specific re-layout and positioning"
	aMorph textAnchorType == #document 
		ifFalse:[^self anchorMorph: aMorph at: wp type: aMorph textAnchorType].
	self addMorphFront: aMorph.
! !

!TextMorph methodsFor: 'submorphs-add/remove' stamp: 'di 11/7/97 10:00'!
delete
	predecessor ifNotNil: [predecessor setSuccessor: successor].
	successor ifNotNil: [successor setPredecessor: predecessor.
						successor recomposeChain].
	super delete! !

!TextMorph methodsFor: 'submorphs-add/remove' stamp: 'di 11/16/97 16:52'!
goBehind
	"We need to save the container, as it knows about fill and run-around"
	| cont |
	container ifNil: [^ super goBehind].
	self releaseParagraph.  "Cause recomposition"
	cont _ container.  "Save the container"
	super goBehind.  "This will change owner, nilling the container"
	container _ cont.  "Restore the container"
	self changed! !


!TextMorph methodsFor: 'testing' stamp: 'tk 11/1/2001 14:37'!
basicType
	"Answer a symbol representing the inherent type I hold"

	"Number String Boolean player collection sound color etc"
	^ #Text! !


!TextMorph methodsFor: 'visual properties' stamp: 'dgd 2/16/2003 20:03'!
fillStyle
	"Return the current fillStyle of the receiver."
	^ self
		valueOfProperty: #fillStyle
		ifAbsent: [backgroundColor
				ifNil: [Color transparent]]! !

!TextMorph methodsFor: 'visual properties' stamp: 'di 6/22/2001 09:52'!
fillStyle: aFillStyle
	"Set the current fillStyle of the receiver."
	self setProperty: #fillStyle toValue: aFillStyle.
	"Workaround for Morphs not yet converted"
	backgroundColor _ aFillStyle asColor.
	self changed.! !


!TextMorph methodsFor: '*eToys-card in a stack' stamp: 'sw 10/30/2000 09:02'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')"

	^ true! !


!TextMorph methodsFor: '*eToys-card & stack' stamp: 'sw 5/31/2000 01:18'!
newContents: stringOrText fromCard: aCard
	"Accept new text contents."
	| newText setter |

	newText _ stringOrText asText.
	text = newText ifTrue: [^ self].  "No substantive change"

	text ifNotNil: [
		text embeddedMorphs do: [ :m | m delete ] ].

	text _ newText.

	"add all morphs off the visible region; they'll be moved into the right place when they become visible.  (this can make the scrollable area too large, though)"
	stringOrText asText embeddedMorphs do: [ :m | 
		self addMorph: m. 
		m position: (-1000@0)].

	self releaseParagraph.  "update the paragraph cache"
	self paragraph.  "re-instantiate to set bounds"

	self holdsSeparateDataForEachInstance
		ifTrue:
			[setter _ self valueOfProperty: #setterSelector.
			setter ifNotNil:
				[aCard perform: setter with: newText]].

	self world ifNotNil:
		[self world startSteppingSubmorphsOf: self ].
! !

!TextMorph methodsFor: '*eToys-card & stack' stamp: 'tk 1/8/2001 13:14'!
setNewContentsFrom: stringOrTextOrNil
	"Using stringOrTextOrNil as a guide, set the receiver's contents afresh.  If the input parameter is nil, the a default value stored in a property of the receiver, if any, will supply the new initial content.  This method is only called when a VariableDock is attempting to put a new value.  This is still messy and ill-understood and not ready for prime time."

	| defaultValue tt atts |
	stringOrTextOrNil ifNotNil: [^ self newContents: stringOrTextOrNil 
		fromCard: (self valueOfProperty: #cardInstance)].
		   "Well, totally yuk -- emergency measure late on eve of demo"
	defaultValue _ self valueOfProperty: #defaultValue 
					ifAbsent: [atts _ text attributesAt: 1.	"Preserve size, emphasis"
						tt _ text copyReplaceFrom: 1 to: text size
								with: 'blankText'.
						atts do: [:anAtt | tt addAttribute: anAtt].
						tt].
	self contents: defaultValue deepCopy wrappedTo: self width.
! !


!TextMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 10/2/97 15:16'!
configureForKids
	super configureForKids.
	self lock! !

!TextMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 9/15/2000 06:14'!
getNumericValue
	"Obtain a numeric value from the receiver; if no digits, return zero"

	| aString |
	^ [(aString _ text string) asNumber] ifError: [:a :b | ^ aString asInteger ifNil: [0]]! !

!TextMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 9/1/2000 10:44'!
setNumericValue: aValue
	"Set the contents of the receiver to be a string obtained from aValue"

	self newContents: aValue asString! !


!TextMorph methodsFor: '*eToys-player' stamp: 'sw 10/30/2000 09:01'!
currentDataValue
	"Answer the current data value held by the receiver"

	^ text! !

!TextMorph methodsFor: '*eToys-player' stamp: 'sw 10/25/2000 07:02'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield"

	^ Array with: (VariableDock new variableName: self defaultVariableName type: #text definingMorph: self morphGetSelector: #contents morphPutSelector: #setNewContentsFrom:)! !


!TextMorph methodsFor: '*MorphicExtras-accessing' stamp: 'sw 6/27/2001 13:45'!
getCharacters
	"obtain a string value from the receiver"

	^ self text string copy! !


!TextMorph methodsFor: '*MorphicExtras-copying' stamp: 'di 11/11/97 20:45'!
updateReferencesUsing: refDict
	| anchors range new |
	super updateReferencesUsing: refDict.
	"Update any anchors in the text of a newly copied morph"
	anchors _ IdentityDictionary new.
	text runs withStartStopAndValueDo:
		[:start :stop :attributes |
		attributes do: [:att | (att isMemberOf: TextAnchor)
							ifTrue: [anchors at: att put: (start to: stop)]]].
	anchors isEmpty ifTrue: [^ self].
	anchors keysDo:
		[:old |  range _ anchors at: old.
		text removeAttribute: old from: range first to: range last.
		new _ TextAnchor new anchoredMorph:
					(refDict at: old anchoredMorph).
		text addAttribute: new from: range first to: range last].
	self layoutChanged "for good measure"! !


!TextMorph methodsFor: '*MorphicExtras-printing'!
fullPrintOn: aStream

	aStream nextPutAll: '('.
	super fullPrintOn: aStream.
	aStream nextPutAll: ') contents: '; print: text! !


!TextMorph methodsFor: 'private' stamp: 'di 11/8/97 16:02'!
adjustLineIndicesBy: delta
	paragraph ifNotNil: [paragraph adjustLineIndicesBy: delta]! !

!TextMorph methodsFor: 'private' stamp: 'di 6/22/2001 09:10'!
clippingRectangle
	^ self innerBounds! !

!TextMorph methodsFor: 'private' stamp: 'di 8/4/2000 16:06'!
composeToBounds
	"Compose my text to fit my bounds.
	If any text lies outside my bounds, it will be clipped, or
	if I have successors, it will be shown in the successors."
	| |
	self releaseParagraph; paragraph.
	container ifNotNil:
		[self privateBounds: container bounds truncated].
	self paragraph positionWhenComposed: self position.
	successor ifNotNil:
		[successor predecessorChanged].

! !

!TextMorph methodsFor: 'private' stamp: 'di 7/20/2001 22:18'!
compositionRectangle
	| compRect |
	compRect _ self innerBounds.
	margins ifNotNil: [compRect _ compRect insetBy: margins].
	compRect width < 9 ifTrue: [compRect _ compRect withWidth: 9].
	compRect height < 16 ifTrue: [compRect _ compRect withHeight: 16].
	^ compRect! !

!TextMorph methodsFor: 'private' stamp: 'tween 8/29/2004 20:33'!
editorClass
	"Answer the class used to create the receiver's editor"
	
	^TextMorphEditor! !

!TextMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 14:57'!
fit
	"Adjust my bounds to fit the text.  Should be a no-op if autoFit is not specified.
	Required after the text changes,
	or if wrapFlag is true and the user attempts to change the extent."

	| newExtent para cBounds lastOfLines heightOfLast |
	self isAutoFit 
		ifTrue: 
			[newExtent := (self paragraph extent max: 9 @ textStyle lineGrid) + (0 @ 2).
			newExtent := newExtent + (2 * borderWidth).
			margins 
				ifNotNil: [newExtent := ((0 @ 0 extent: newExtent) expandBy: margins) extent].
			newExtent ~= bounds extent 
				ifTrue: 
					[(container isNil and: [successor isNil]) 
						ifTrue: 
							[para := paragraph.	"Save para (layoutChanged smashes it)"
							super extent: newExtent.
							paragraph := para]].
			container notNil & successor isNil 
				ifTrue: 
					[cBounds := container bounds truncated.
					"23 sept 2000 - try to allow vertical growth"
					lastOfLines := self paragraph lines last.
					heightOfLast := lastOfLines bottom - lastOfLines top.
					(lastOfLines last < text size 
						and: [lastOfLines bottom + heightOfLast >= self bottom]) 
							ifTrue: 
								[container releaseCachedState.
								cBounds := cBounds origin corner: cBounds corner + (0 @ heightOfLast)].
					self privateBounds: cBounds]].

	"These statements should be pushed back into senders"
	self paragraph positionWhenComposed: self position.
	successor ifNotNil: [successor predecessorChanged].
	self changed	"Too conservative: only paragraph composition
					should cause invalidation."! !

!TextMorph methodsFor: 'private' stamp: 'RAA 2/16/2001 08:15'!
installEditor


	self flag: #bob.		"I don't see any senders (16 Feb 2001)"


	"Install an editor for my paragraph.  This constitutes 'hasFocus'."
	editor ifNotNil: [^ editor].
	^ self installEditorToReplace: nil! !

!TextMorph methodsFor: 'private' stamp: 'tween 8/29/2004 20:34'!
installEditorToReplace: priorEditor
	"Install an editor for my paragraph.  This constitutes 'hasFocus'.
	If priorEditor is not nil, then initialize the new editor from its state.
	We may want to rework this so it actually uses the prior editor."

	| stateArray |
	priorEditor ifNotNil: [stateArray _ priorEditor stateArray].
	editor _ self editorClass new morph: self.
	editor changeParagraph: self paragraph.
	priorEditor ifNotNil: [editor stateArrayPut: stateArray].
	self selectionChanged.
	^ editor! !

!TextMorph methodsFor: 'private' stamp: 'hpt 4/11/2004 20:35'!
paragraph
	"Paragraph instantiation is lazy -- create it only when needed"
	paragraph ifNotNil: [^ paragraph].

self setProperty: #CreatingParagraph toValue: true.

	self setDefaultContentsIfNil.

	"...Code here to recreate the paragraph..."
	paragraph _ (self paragraphClass new textOwner: self owner).
	paragraph wantsColumnBreaks: successor notNil.
	paragraph
		compose: text
		style: textStyle copy
		from: self startingIndex
		in: self container.
	wrapFlag ifFalse:
		["Was given huge container at first... now adjust"
		paragraph adjustRightX].
	paragraph focused: (self currentHand keyboardFocus == self).
	self fit.
self removeProperty: #CreatingParagraph.


	^ paragraph! !

!TextMorph methodsFor: 'private' stamp: 'yo 1/3/2003 12:21'!
paragraphClass
	container ifNil: [^ MultiNewParagraph].
	^ container paragraphClass! !

!TextMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:29'!
predecessorChanged
	| newStart oldStart |
	(self hasProperty: #CreatingParagraph) ifTrue: [^self].
	newStart := predecessor isNil 
				ifTrue: [1]
				ifFalse: [predecessor lastCharacterIndex + 1].
	(self paragraph adjustedFirstCharacterIndex ~= newStart 
		or: [newStart >= text size]) 
			ifTrue: 
				[paragraph composeAllStartingAt: newStart.
				self fit]
			ifFalse: 
				["If the offset to end of text has not changed, just slide"

				oldStart := self firstCharacterIndex.
				self withSuccessorsDo: [:m | m adjustLineIndicesBy: newStart - oldStart]]! !

!TextMorph methodsFor: 'private' stamp: 'di 7/28/2001 10:33'!
predecessor: pred successor: succ
	"Private -- for use only in morphic duplication"
	predecessor _ pred.
	successor _ succ.
! !

!TextMorph methodsFor: 'private' stamp: 'tk 9/28/1999 16:50'!
privateOwner: newOwner
	"Nil the container when text gets extracted"
	super privateOwner: newOwner.
	container ifNotNil: [
		newOwner ifNotNil: [
			newOwner isWorldOrHandMorph ifTrue: [self setContainer: nil]]]! !

!TextMorph methodsFor: 'private' stamp: 'di 10/5/1998 16:39'!
releaseEditor 
	"Release the editor for my paragraph.  This morph no longer 'hasFocus'."
	editor ifNotNil:
		[self selectionChanged.
		self paragraph selectionStart: nil selectionStop: nil.
		editor _ nil].! !

!TextMorph methodsFor: 'private' stamp: 'RAA 12/5/2001 11:20'!
releaseParagraph

	"a slight kludge so subclasses can have a bit more control over whether the paragraph really 
	gets released. important for GeeMail since the selection needs to be accessible even if the 
	hand is outside me"

	self releaseParagraphReally.
! !

!TextMorph methodsFor: 'private' stamp: 'RAA 12/5/2001 11:20'!
releaseParagraphReally

	"a slight kludge so subclasses can have a bit more control over whether the paragraph really 
	gets released. important for GeeMail since the selection needs to be accessible even if the 
	hand is outside me"

	"Paragraph instantiation is lazy -- it will be created only when needed"
	self releaseEditor.
	paragraph ifNotNil:
		[paragraph _ nil].
	container ifNotNil:
		[container releaseCachedState]! !

!TextMorph methodsFor: 'private' stamp: 'ar 8/10/2003 18:12'!
removedMorph: aMorph
	| range |
	range _ text find: (TextAnchor new anchoredMorph: aMorph).
	range ifNotNil:
		[self paragraph replaceFrom: range first to: range last
				with: Text new displaying: false.
		self fit].
	aMorph textAnchorType: nil.
	aMorph relativeTextAnchorPosition: nil.
	super removedMorph: aMorph.! !

!TextMorph methodsFor: 'private' stamp: 'nk 8/29/2004 21:40'!
selectionChanged
	"Invalidate all the selection rectangles. 
	Make sure that any drop shadow is accounted for too."
	self paragraph selectionRects
		do: [:r | self
				invalidRect: (self expandFullBoundsForDropShadow: (r intersect: self fullBounds))]! !

!TextMorph methodsFor: 'private' stamp: 'tk 11/13/2001 01:57'!
setDefaultContentsIfNil
	"Set the default contents"

	| toUse |
	text ifNil:
		[toUse _ self valueOfProperty: #defaultContents.
		toUse ifNil: [toUse _'abc' asText "allBold"].	"try it plain for a while"
		text _ toUse]! !

!TextMorph methodsFor: 'private' stamp: 'di 10/25/97 17:11'!
setPredecessor: newPredecessor
	predecessor _ newPredecessor! !

!TextMorph methodsFor: 'private' stamp: 'RAA 5/6/2001 15:12'!
setSuccessor: newSuccessor

	successor _ newSuccessor.
	paragraph ifNotNil: [paragraph wantsColumnBreaks: successor notNil].
! !

!TextMorph methodsFor: 'private' stamp: 'di 10/24/97 11:35'!
text: t textStyle: s
	"Private -- for use only in morphic duplication"
	text _ t.
	textStyle _ s.
	paragraph ifNotNil: [paragraph textStyle: s]! !

!TextMorph methodsFor: 'private' stamp: 'di 7/28/2001 10:34'!
text: t textStyle: s wrap: wrap color: c
	predecessor: pred successor: succ
	"Private -- for use only in morphic duplication"
	text _ t.
	textStyle _ s.
	wrapFlag _ wrap.
	color _ c.
	paragraph _ editor _ container _ nil.
	self predecessor: pred successor: succ! !

!TextMorph methodsFor: 'private' stamp: 'Tsutomu Hiroshima 11/17/2003 08:50'!
updateFromParagraph
	"A change has taken place in my paragraph, as a result of editing and I must be updated.  If a line break causes recomposition of the current paragraph, or it the selection has entered a different paragraph, then the current editor will be released, and must be reinstalled with the resulting new paragraph, while retaining any editor state, such as selection, undo state, and current typing emphasis."

	| newStyle sel oldLast oldEditor back |
	paragraph ifNil: [^self].
	wrapFlag ifNil: [wrapFlag := true].
	editor ifNotNil: 
			[oldEditor := editor.
			sel := editor selectionInterval.
			editor storeSelectionInParagraph].
	text := paragraph text.
	paragraph textStyle = textStyle 
		ifTrue: [self fit]
		ifFalse: 
			["Broadcast style changes to all morphs"

			newStyle := paragraph textStyle.
			(self firstInChain text: text textStyle: newStyle) recomposeChain.
			editor ifNotNil: [self installEditorToReplace: editor]].
	super layoutChanged.
	sel ifNil: [^self].

	"If selection is in top line, then recompose predecessor for possible ripple-back"
	predecessor ifNotNil: 
			[sel first <= (self paragraph lines first last + 1) 
				ifTrue: 
					[oldLast := predecessor lastCharacterIndex.
					predecessor paragraph 
						recomposeFrom: oldLast
						to: text size
						delta: 0.
					oldLast = predecessor lastCharacterIndex 
						ifFalse: 
							[predecessor changed.	"really only last line"
							self predecessorChanged]]].
	((back := predecessor notNil 
				and: [sel first <= self paragraph firstCharacterIndex]) or: 
				[successor notNil 
					and: [sel first > (self paragraph lastCharacterIndex + 1)]]) 
		ifTrue: 
			["The selection is no longer inside this paragraph.
		Pass focus to the paragraph that should be in control."

			back ifTrue: [predecessor recomposeChain] ifFalse: [self recomposeChain].
			self firstInChain withSuccessorsDo: 
					[:m | 
					(sel first between: m firstCharacterIndex and: m lastCharacterIndex + 1) 
						ifTrue: 
							[m installEditorToReplace: oldEditor.
							^self passKeyboardFocusTo: m]].
			self error: 'Inconsistency in text editor'	"Must be somewhere in the successor chain"].
	editor ifNil: 
			["Reinstate selection after, eg, style change"

			self installEditorToReplace: oldEditor].
	"self setCompositionWindow."
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextMorph class
	instanceVariableNames: ''!

!TextMorph class methodsFor: 'class initialization' stamp: 'nk 11/9/2003 09:58'!
initialize	"TextMorph initialize"
	
	"Initialize constants shared by classes associated with text display."

	CaretForm _ (ColorForm extent: 16@5
					fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)
					offset: -2@0)
					colors: (Array with: Color transparent with: Preferences textHighlightColor).

	self registerInFlapsRegistry.
! !

!TextMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:04'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(TextMorph		authoringPrototype			'Text'				'Text that you can edit into anything you desire.')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(TextMorph		exampleBackgroundLabel	'Background Label' 'A piece of text that will occur on every card of the background')
						forFlapNamed: 'Scripting'.
						cl registerQuad: #(TextMorph		exampleBackgroundField		'Background Field'	'A  data field which will have a different value on every card of the background')
						forFlapNamed: 'Scripting'.
						cl registerQuad: #(TextMorph		authoringPrototype		'Simple Text'		'Text that you can edit into anything you wish')
						forFlapNamed: 'Stack Tools'.
						cl registerQuad: #(TextMorph		fancyPrototype			'Fancy Text' 		'A text field with a rounded shadowed border, with a fancy font.')
						forFlapNamed: 'Stack Tools'.
						cl registerQuad: #(TextMorph		authoringPrototype		'Text'			'Text that you can edit into anything you desire.')
						forFlapNamed: 'Supplies'.]! !

!TextMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:41'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!TextMorph class methodsFor: 'connectorstext-parts bin' stamp: 'yo 1/20/2005 12:44'!
boldAuthoringPrototype
	"TextMorph boldAuthoringPrototype openInHand"
	| text |
	text := Text string: 'Text' translated attributes: { TextEmphasis bold. }.
	^self new
		contentsWrapped: text;
		fontName: 'BitstreamVeraSans' pointSize: 24;
		paragraph;
		extent: 79@36;
		margins: 4@0;
		fit;
		yourself
! !


!TextMorph class methodsFor: 'new-morph participation' stamp: 'kfr 5/1/2000 13:42'!
includeInNewMorphMenu
	^ true! !


!TextMorph class methodsFor: 'parts bin' stamp: 'nk 9/2/2004 16:03'!
borderedPrototype

	| t |
	t _ self authoringPrototype.
	t fontName: 'BitstreamVeraSans' pointSize: 24.
	t autoFit: false; extent: 250@100.
	t borderWidth: 1; margins: 4@0.

"Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window"
	t paragraph.
	^ t! !

!TextMorph class methodsFor: 'parts bin' stamp: 'sw 6/13/2001 21:58'!
exampleBackgroundLabel
	"Answer a background label for a parts bin"

	| aTextMorph |
	aTextMorph _ self authoringPrototype.
	aTextMorph contents: 'background
label' asText.  
	aTextMorph beAllFont: (StrikeFont familyName: #NewYork size: 18).
	aTextMorph color: Color brown.
	aTextMorph setProperty: #shared toValue: true.
	^ aTextMorph
! !

!TextMorph class methodsFor: 'parts bin' stamp: 'nk 7/12/2003 08:59'!
fancyPrototype

	| t |
	t _ self authoringPrototype.
	t autoFit: false; extent: 150@75.
	t borderWidth: 2; margins: 4@0; useRoundedCorners.	"Why not rounded?"
	"fancy font, shadow, rounded"
	t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; backgroundColor: Color lightBrown.
	t addDropShadow.

"Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window"
	t paragraph.
	^ t! !


!TextMorph class methodsFor: 'scripting' stamp: 'yo 7/2/2004 21:27'!
authoringPrototype
	| t |
	t _ super authoringPrototype.
	t contents: 'abc' translated asText.
	t wrapFlag: true. 

"Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window"
	t paragraph.
	^ t! !

!TextMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:12'!
defaultNameStemForInstances
	^ 'Text'! !


!TextMorph class methodsFor: '*eToys-parts bin' stamp: 'sw 6/13/2001 22:46'!
exampleBackgroundField
	"Answer a background field for a parts bin"

	| aMorph |
	aMorph _ TextMorph authoringPrototype.
	aMorph contents: 'background field' asText allBold.
	aMorph setProperty: #shared toValue: true.
	aMorph setNameTo: 'field1'.
	aMorph setProperty: #holdsSeparateDataForEachInstance toValue: true.	
	^ aMorph
! !


!TextMorph class methodsFor: '*eToys-scripting' stamp: 'sw 10/3/2004 01:34'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(
(#'color & border' (
(slot backgroundColor 'The color of the background behind the text' Color readWrite Player getBackgroundColor Player setBackgroundColor:)))

(text (
(slot backgroundColor 'The color of the background behind the text' Color readWrite Player getBackgroundColor Player setBackgroundColor:)
(slot characters	'The characters in my contents' String	readWrite Player getCharacters Player setCharacters:)

(slot cursor 'The position among my characters that replacement text would go' Number readWrite Player getCursor Player setCursor:)
(slot characterAtCursor 'The character at the my cursor position' String readWrite Player getCharacterAtCursor Player setCharacterAtCursor:)
(slot count 'How many characters I have' Number readOnly Player getCount unused unused)

(slot firstCharacter  'The first character in my contents' String  readWrite Player getFirstCharacter  Player  setFirstCharacter:)

(slot lastCharacter  'The last character in my contents' String  readWrite Player getLastCharacter  Player  setLastCharacter:)
(slot allButFirst 'All my characters except the first one' String readWrite Player getAllButFirstCharacter Player  setAllButFirstCharacter:)
(command insertCharacters: 'insert the given string at my cursor position' String)
(command insertContentsOf: 'insert the characters from another object at my cursor position' Player)
(slot numericValue 'The number represented by my contents' Number readWrite Player getNumericValue Player  setNumericValue:)))

(basic (
(slot characters	'The characters in my contents' String	readWrite Player getCharacters Player setCharacters:))))


! !


!TextMorph class methodsFor: '*MorphicExtras-parts bin' stamp: 'nk 9/2/2004 15:38'!
supplementaryPartsDescriptions
	^ {
	DescriptionForPartsBin
		formalName: 'Text (border)'
		categoryList: #('Text')
		documentation: 'A text field with border'
		globalReceiverSymbol: #TextMorph
		nativitySelector: #borderedPrototype.

"	DescriptionForPartsBin
		formalName: 'Text (fancy)'
		categoryList: #('Text')
		documentation: 'A text field with a rounded shadowed border, with a fancy font.'
		globalReceiverSymbol: #TextMorph
		nativitySelector: #fancyPrototype."

	DescriptionForPartsBin
		formalName: 'Text'
		categoryList: #('Basic' 'Text')
		documentation: 'A raw piece of text which you can edit into anything you want'
		globalReceiverSymbol: #TextMorph
		nativitySelector: #boldAuthoringPrototype.
}
! !
CommandHistory subclass: #TextMorphCommandHistory
	instanceVariableNames: 'textMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!

!TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:57'!
redo
	^super redoNextCommand
! !

!TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:58'!
rememberCommand: aCommand
	"Make the supplied command be the 'LastCommand', and mark it 'done'"

	"Before adding the new command, remove any commands after the last #done 
	command, and make that last #done command be lastCommand."
	self removeUndoneCommands.
	aCommand phase: #done.
		
	"If we are building a compound command, just add the new command to that"
	history addLast: aCommand.
	lastCommand _ aCommand.
"Debug dShow: ('Remember: ', commandToUse asString)."

! !

!TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/24/2003 16:42'!
removeUndoneCommands
"Remove all of the commands at the end of history until the first one that is not marked #undone"

	history reversed do: [ :command |
		(command phase == #done) ifTrue:[
			lastCommand _ command.
			^self
		]ifFalse:[
			history remove: command.
		].
	].
	
	"If there were no #done commands on the stack, then get rid of lastCommand"
	lastCommand _ nil.
! !

!TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:57'!
undo
	^super undoLastCommand

! !
ParagraphEditor subclass: #TextMorphEditor
	instanceVariableNames: 'morph oldInterval pivotBlock editHistory'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextMorphEditor commentStamp: '<historical>' prior: 0!
This is the ParagraphEditor for TextMorphs.



-----
In the past, BookMorphs had the ability to have each page be on the server as a .sp SqueakPage file.  The index of the book was a .bo file.  In text, Cmd-6 had a LinkTo option that linked to a page by its name, or created a new page of that name.  It assumed the book was on a server with a file per page.  Ted removed that code, and kept a copy on his disk in 'TME-ChngEmphasis.st for .bo .sp'!


!TextMorphEditor methodsFor: 'accessing' stamp: 'tk 1/13/1999 07:53'!
morph
	^ morph! !

!TextMorphEditor methodsFor: 'accessing' stamp: 'tk 1/13/1999 07:53'!
morph: aMorph
	"Install a link back to the morph being edited (esp for text links)"
	morph _ aMorph ! !

!TextMorphEditor methodsFor: 'accessing' stamp: 'tk 12/18/2001 10:25'!
setSearch: aString
	| bk |
	"Set the FindText and ChangeText to seek aString; except if already seeking aString, leave ChangeText alone so again will repeat last replacement."

	(bk _ morph ownerThatIsA: BookMorph) ifNotNil: [
		bk setProperty: #tempSearchKey 
			toValue: (aString findTokens: Character separators)].


	FindText string = aString
		ifFalse: [FindText _ ChangeText _ aString asText]! !

!TextMorphEditor methodsFor: 'accessing' stamp: 'ar 9/22/2001 16:16'!
transformFrom: owner
	^morph transformFrom: owner! !

!TextMorphEditor methodsFor: 'accessing' stamp: 'di 4/21/1998 14:11'!
userHasEdited
	"Note that my text is free of user edits."

	morph hasUnacceptedEdits: true! !


!TextMorphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:41'!
totalTextHeight

	^paragraph lines last bottom! !

!TextMorphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:43'!
visibleHeight

	^morph owner bounds height! !


!TextMorphEditor methodsFor: 'attributes' stamp: 'KR 12/5/2005 00:57'!
changeEmphasisOrAlignment
	| aList reply  code align menuList startIndex alignSymbol |
	self flag: #arNote. "Move this up once we get rid of MVC"
	startIndex _ self startIndex.
	aList _ #(normal bold italic narrow underlined struckOut leftFlush centered rightFlush justified).	
	align _ paragraph text alignmentAt: startIndex 
		ifAbsent:[paragraph textStyle alignment].
	alignSymbol _ TextAlignment alignmentSymbol: align.
	code _ paragraph text emphasisAt: startIndex.
	menuList _ WriteStream on: Array new.
	menuList nextPut: (code isZero ifTrue:['<on>'] ifFalse:['<off>']), 'normal' translated.
	menuList nextPutAll: (#(bold italic underlined struckOut) collect:[:emph|
		(code anyMask: (TextEmphasis perform: emph) emphasisCode)
			ifTrue:['<on>', emph asString translated]
			ifFalse:['<off>',emph asString translated]]).
	((paragraph text attributesAt: startIndex forStyle: paragraph textStyle)
		anySatisfy:[:attr| attr isKern and:[attr kern < 0]]) 
			ifTrue:[menuList nextPut:'<on>', 'narrow' translated]
			ifFalse:[menuList nextPut:'<off>', 'narrow' translated].
	menuList nextPutAll: (#(leftFlush centered rightFlush justified) collect:[:type|
		type == alignSymbol
			ifTrue:['<on>',type asString translated]
			ifFalse:['<off>',type asString translated]]).
	aList _ #(normal bold italic underlined struckOut narrow leftFlush centered rightFlush justified).
	reply _ (SelectionMenu labelList: menuList contents lines: #(1 6) selections: aList) startUpWithoutKeyboard.
	reply notNil ifTrue:
		[(#(leftFlush centered rightFlush justified) includes: reply)
			ifTrue:
				[self setAlignment: reply.
				paragraph composeAll.
				self recomputeInterval]
			ifFalse:
				[self setEmphasis: reply.
				paragraph composeAll.
				self recomputeSelection.
				self mvcRedisplay]].
	^ true! !

!TextMorphEditor methodsFor: 'attributes' stamp: 'cds 7/27/2005 22:35'!
changeStyle
	"Let user change styles for the current text pane."
	| aList reply style theStyle menuList |
	self flag: #arNote. "Move this up once we get rid of MVC"
	aList := StrikeFont actualFamilyNames.
	theStyle := paragraph textStyle.
	menuList := aList collect:[:styleName|
		"Hack!! use defaultFont for comparison - we have no name that we could use for compare and the style changes with alignment so they're no longer equal."
		(TextConstants at: styleName) defaultFont == theStyle defaultFont
			ifTrue:['<on>', styleName]
			ifFalse:['<off>',styleName]].
	theStyle = TextStyle default
		ifTrue:[menuList addFirst: '<on>DefaultTextStyle']
		ifFalse:[menuList addFirst: '<off>DefaultTextStyle'].
	aList addFirst: 'DefaultTextStyle'.
	reply := (SelectionMenu labelList: menuList lines: #(1) selections: aList) startUpWithCaption: nil at: ActiveHand position allowKeyboard: false.
	reply ifNotNil:
		[(style := TextStyle named: reply) ifNil: [Beeper beep. ^ true].
		paragraph textStyle: style copy.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!TextMorphEditor methodsFor: 'attributes' stamp: 'nk 9/1/2004 14:55'!
changeTextFont
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.
	If there is no selection, or the selection is empty, apply it to the whole morph."
	| curFont newFont attr startIndex stopIndex |
	startIndex _ self startIndex.
	stopIndex := self stopIndex-1 min: paragraph text size.
	curFont _ (paragraph text fontAt: startIndex withStyle: paragraph textStyle).
	newFont _ StrikeFont fromUser: curFont allowKeyboard: false.
	newFont ifNil:[^self].
	attr _ TextFontReference toFont: newFont.
	stopIndex >= startIndex
		ifTrue: [ paragraph text addAttribute: attr from: startIndex to: stopIndex ]
		ifFalse: [ paragraph text addAttribute: attr from: 1 to: paragraph text size. ].

	paragraph composeAll.
	self recomputeInterval.
! !

!TextMorphEditor methodsFor: 'attributes' stamp: 'th 9/19/2002 18:30'!
offerFontMenu
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.  
	Use only names of Fonts of this paragraph  "
	| aList reply curFont menuList |
true ifTrue:[^self changeTextFont].
	self flag: #arNote. "Move this up once we get rid of MVC"
	curFont _ (paragraph text fontAt: self startIndex withStyle: paragraph textStyle) fontNameWithPointSize.
	aList _ paragraph textStyle fontNamesWithPointSizes.
	menuList _ aList collect:[:fntName|
		fntName = curFont ifTrue:['<on>',fntName] ifFalse:['<off>',fntName]].
	reply _ (SelectionMenu labelList: menuList selections: aList) startUp.
	reply ~~ nil ifTrue:
		[self replaceSelectionWith:
			(Text string: self selection asString 
				attribute: (TextFontChange fontNumber: (aList indexOf: reply)))] ! !

!TextMorphEditor methodsFor: 'attributes' stamp: 'nk 7/3/2003 18:33'!
textAlignment
	"Answer 1..4, representing #leftFlush, #rightFlush, #centered, or #justified"
	^paragraph text alignmentAt: startBlock stringIndex
		ifAbsent: [paragraph textStyle alignment]! !

!TextMorphEditor methodsFor: 'attributes' stamp: 'nk 7/3/2003 18:33'!
textAlignmentSymbol
	^#(leftFlush rightFlush centered justified) at: self textAlignment
	! !


!TextMorphEditor methodsFor: 'binding' stamp: 'ls 7/24/1998 21:06'!
bindingOf: aString
	^model bindingOf: aString! !


!TextMorphEditor methodsFor: 'controlling' stamp: 'di 4/16/1998 11:33'!
controlInitialize
	"No-op for MVC ParagraphEditor compatibility"! !

!TextMorphEditor methodsFor: 'controlling' stamp: 'di 4/16/1998 11:33'!
controlTerminate
	"No-op for MVC ParagraphEditor compatibility"! !


!TextMorphEditor methodsFor: 'current selection'!
select
	"Ignore selection redraw requests."! !

!TextMorphEditor methodsFor: 'current selection' stamp: 'jm 10/28/97 18:31'!
selectAndScroll
	"Ignore scroll requests."! !


!TextMorphEditor methodsFor: 'displaying' stamp: 'di 4/22/1998 10:21'!
flash
	^ morph flash! !


!TextMorphEditor methodsFor: 'editing keys' stamp: 'nk 8/23/2004 17:08'!
changeEmphasis: aStream
	"Change the emphasis of the current selection."
	| retval |
	retval := super changeEmphasis: aStream.
	paragraph composeAll.
	self recomputeInterval.
	morph updateFromParagraph.
	^retval! !

!TextMorphEditor methodsFor: 'editing keys' stamp: 'tk 5/7/2001 09:10'!
chooseColor
	| attribute |
	"Make a new Text Color Attribute, let the user pick a color, and return the attribute"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: morph activeHand;
		target: (attribute _ TextColor color: Color black "default");
		selector: #color:;
		originalColor: Color black;
		putUpFor: morph near: morph fullBoundsInWorld.
	^ attribute
! !

!TextMorphEditor methodsFor: 'editing keys' stamp: 'tk 5/8/1998 11:08'!
inspectIt: characterStream 
	"Inspect the selection -- invoked via cmd-i.  If there is no current selection, use the current line."

	sensor keyboard.		"flush character"
	self inspectIt.
	^ true! !

!TextMorphEditor methodsFor: 'editing keys' stamp: 'sw 10/18/1998 10:17'!
tempCommand: characterStream 
	"Experimental.  Triggered by Cmd-t; put trial cmd-key commands here to see how they work, before hanging them on their own cmd accelerators."
	Sensor keyboard.
	morph tempCommand.
	^ true! !


!TextMorphEditor methodsFor: 'events' stamp: 'th 9/18/2002 11:15'!
mouseDown: evt 
	"An attempt to break up the old processRedButton code into threee phases"
	| clickPoint |

	oldInterval _ self selectionInterval.
	clickPoint _ evt cursorPoint.
	(paragraph clickAt: clickPoint for: model controller: self) ifTrue: [
		pivotBlock _ paragraph characterBlockAtPoint: clickPoint.
		self markBlock: pivotBlock.
		self pointBlock: pivotBlock.
		evt hand releaseKeyboardFocus: self.
		^ self].
	evt shiftPressed
		ifFalse:
			[self closeTypeIn.
			pivotBlock _ paragraph characterBlockAtPoint: clickPoint.
			self markBlock: pivotBlock.
			self pointBlock: pivotBlock.]
		ifTrue:
			[self closeTypeIn.
			self mouseMove: evt].
	self storeSelectionInParagraph! !

!TextMorphEditor methodsFor: 'events' stamp: 'th 9/17/2002 16:45'!
mouseMove: evt 
	"Change the selection in response to moue-down drag"

	pivotBlock ifNil: [^ self].  "Patched during clickAt: repair"
	self pointBlock: (paragraph characterBlockAtPoint: (evt cursorPoint)).
	self storeSelectionInParagraph! !

!TextMorphEditor methodsFor: 'events' stamp: 'th 9/19/2002 18:29'!
mouseUp: evt
	"An attempt to break up the old processRedButton code into threee phases"
	oldInterval ifNil: [^ self].  "Patched during clickAt: repair"
	(self hasCaret 
		and: [oldInterval = self selectionInterval])
		ifTrue: [self selectWord].
	self setEmphasisHere.
	(self isDisjointFrom: oldInterval) ifTrue:
		[otherInterval _ oldInterval].
	self storeSelectionInParagraph! !


!TextMorphEditor methodsFor: 'menu commands' stamp: 'sw 12/9/2001 18:55'!
offerMenuFromEsc: characterStream 
	"The escape key was hit while the receiver has the keyboard focus; take action"

	^ ActiveEvent shiftPressed 
		ifTrue:
			[self escapeToDesktop: characterStream]
		ifFalse:
			[self raiseContextMenu: characterStream]! !


!TextMorphEditor methodsFor: 'menu messages' stamp: 'di 4/21/1998 20:30'!
accept
	"Save the current text of the text being edited as the current acceptable version for purposes of canceling.  Allow my morph to take appropriate action"
	morph acceptContents! !

!TextMorphEditor methodsFor: 'menu messages' stamp: 'ar 12/17/2001 12:55'!
align
	"Align text according to the next greater alignment value,
	cycling among leftFlush, rightFlush, center, and justified."
	self changeAlignment.
	self recomputeInterval! !

!TextMorphEditor methodsFor: 'menu messages' stamp: 'di 10/9/1998 16:55'!
cancel
	"Cancel the changes made so far to this text"
	morph cancelEdits! !

!TextMorphEditor methodsFor: 'menu messages' stamp: 'di 10/5/1998 21:48'!
find
	super find.
	morph installEditorToReplace: self! !

!TextMorphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:38'!
mvcRedisplay
	"Ignore mvcRedisplay requests."! !

!TextMorphEditor methodsFor: 'menu messages' stamp: 'sps 2/5/2004 13:16'!
zapSelectionWith: aText
	"**overridden to inhibit old-style display"
	| start stop rText rInterval isInTypeRun |
	self deselect.
	start _ self startIndex.
	stop _ self stopIndex.
	(aText isEmpty and: [stop > start]) ifTrue:
		["If deleting, then set emphasisHere from 1st character of the deletion"
		emphasisHere _ (paragraph text attributesAt: start forStyle: paragraph textStyle)
					select: [:att | att mayBeExtended]].
	(start = stop and: [aText size = 0]) ifFalse:
		[
		"===Support for multilevel undo start ==="
		rText _ (paragraph text copyFrom: start to: (stop - 1)).
		rInterval _ start to: (stop - 1).
		isInTypeRun _ self isInTypeRun.
		"===Support for multilevel undo end ==="
		
		paragraph replaceFrom: start to: stop - 1
			with: aText displaying: false.  "** was true in super"
		self computeIntervalFrom: start to: start + aText size - 1.
		UndoInterval _ otherInterval _ self selectionInterval.

		"===Support for multilevel undo start ==="
		 (Preferences multipleTextUndo and: [isInTypeRun not])ifTrue:
				[ self addEditCommand: 
							(EditCommand
									textMorph: morph
									replacedText: rText
									replacedTextInterval: rInterval
									newText: aText 
									newTextInterval: super selectionInterval)].
		"===Support for multilevel undo end ==="].

	self userHasEdited  " -- note text now dirty"! !


!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 18:56'!
addEditCommand: anEditCommand

	self editHistory rememberCommand: anEditCommand.
"
	Debug dShow: anEditCommand newText.
	Debug dShow: anEditCommand replacedText.
"


! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 2/5/2004 13:26'!
closeTypeIn

	| begin stop rInterval nInterval newText |

	(UndoMessage sends: #noUndoer) ifFalse:[^super closeTypeIn].
	Preferences multipleTextUndo ifTrue: 
		[
		beginTypeInBlock == nil ifFalse:
			[
				begin _ self startOfTyping.
				stop _ self stopIndex.
				rInterval _ (begin "+ UndoMessage argument" 
																to: begin + UndoSelection size - 1).
				nInterval _ begin to: stop - 1.
				(nInterval = rInterval) ifTrue:[ ^super closeTypeIn ].
				newText _ nInterval size > 0
										ifTrue: [ paragraph text 
																copyFrom: nInterval first 
																to: nInterval last ]
										ifFalse: [ self nullText ].
				self addEditCommand: 
				 	(EditCommand
							textMorph: morph
							replacedText: UndoSelection copy
							replacedTextInterval: rInterval
							newText: newText 
							newTextInterval: nInterval)
			].
		].
	
	"Call the super regardless, just to keep the standard undo machine happy"
	^super closeTypeIn
! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 16:49'!
editHistory
	^morph editHistory
! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 12:37'!
isInTypeRun
	^beginTypeInBlock ~~ nil
! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 17:24'!
multiRedo
	^self multiRedoWithCount: 1
! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 18:52'!
multiRedoWithCount: count

	| command i lastCommand newSelection saveSelection history |

	count > 0 ifFalse:[ ^self ].

	history _ self editHistory.
	(command _ history nextCommand) isNil
			ifTrue:[ ^self multiUndoError: 'Nothing to redo'].

	saveSelection _ self selectionInterval.
	self deselect.
	i _ 0.
	[i < count] whileTrue: 
		[
		history redo.
		lastCommand _ command.
		((i _ i + 1) < count) ifTrue:
			[
			(command _ history nextCommand) ifNil:[
				self multiUndoError: ('Only ', (i - 1) asString, ' commands to redo.').
				i _ count.]]].

	(newSelection _ lastCommand redoSelectionInterval) isNil
			ifTrue:[ self selectInterval: saveSelection]
			ifFalse:[ self selectInterval: newSelection].

! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 17:28'!
multiRedo: readAheadStream
	sensor keyboard. 	"flush character"
	self closeTypeIn.
	self multiRedoWithCount: 1.
	^true
! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 17:24'!
multiUndo
	^self multiUndoWithCount: 1
! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'md 8/15/2005 11:18'!
multiUndoError: eString

	Beeper beep
! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 18:53'!
multiUndoWithCount: count

	| command i lastCommand saveSelection newSelection history |

	count > 0 ifFalse:[ ^self ].
	history _ self editHistory.
	(command _ history commandToUndo) 
		ifNil:[ ^self multiUndoError: 'Nothing to undo'].
		
	saveSelection _ self selectionInterval.
	self deselect.
	i _ 0.
	[i < count] whileTrue: 
		[history undo.
		lastCommand _ command.
		((i _ i + 1) < count) ifTrue:
			[(command _ history commandToUndo) ifNil:[
				self multiUndoError: ('Only ', (i - 1) asString, ' commands to undo.').
				i _ count. ]]].

	(newSelection _ lastCommand undoSelectionInterval) isNil
			ifTrue:[ self selectInterval: saveSelection]
			ifFalse:[ self selectInterval: newSelection].

! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 13:45'!
noUndoReplace: anInterval with: aText
"This is the zap that multilevel undo uses to do edits. This method bypasses any undo/redo plumbing (in contrast to zapSelection:).  This method is called by an EditCommand (which wants to carry out its paragraph surgery without adding another command to the editHistory)"

	| start stop |
	self deselect.
	start _ (anInterval first max: 1).
	stop _ (anInterval last min: paragraph text size).
	(aText isEmpty and: [stop > start]) ifTrue:
		["If deleting, then set emphasisHere from 1st character of the deletion"
		emphasisHere _ (paragraph text attributesAt: start forStyle: paragraph textStyle)
					select: [:att | att mayBeExtended]].
"Debug dShow: ('zap start->stop: ', (start to: stop) asString)."
	paragraph 
		replaceFrom: start 
		to: stop 
		with: aText 
		displaying: false.  

	UndoMessage sends: #noUndoer . "Keep the normal undo machine happy"
	self userHasEdited  " -- note text now dirty"
! !

!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 13:34'!
undo
	"Reset the state of the paragraph prior to the previous edit.
	 If another ParagraphEditor instance did that edit, UndoInterval is invalid;
	 just recover the contents of the undo-buffer at the start of the paragraph."

	Preferences multipleTextUndo 
		ifTrue: [ ^self multiUndo ]
		ifFalse:[ ^super undo ].
! !


!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'th 9/20/2002 11:26'!
selectAndScrollToTop
	"Scroll until the selection is in the view and then highlight it."

	| lineHeight deltaY rect deltaX |
	lineHeight _ paragraph textStyle lineGrid.
	rect _ morph owner bounds.
	deltaY _ self stopBlock top - rect top.
	deltaY ~= 0 ifTrue: [
		deltaX _ 0.
		deltaY _ (deltaY abs + lineHeight - 1 truncateTo: lineHeight) negated.
		morph editView scrollBy: deltaX@deltaY]! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'sbw 10/14/1999 16:51'!
selectForTopFrom: start to: stop

	self selectFrom: start to: stop.
	morph editView ifNotNil: [self selectAndScrollToTop]! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'th 9/19/2002 18:17'!
storeSelectionInParagraph
	paragraph selectionStart: self startBlock selectionStop: self stopBlock! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 4/21/1998 13:26'!
userHasNotEdited
	"Note that my text is free of user edits."

	morph hasUnacceptedEdits: false! !


!TextMorphEditor methodsFor: 'new selection' stamp: 'ls 11/10/2002 12:26'!
selectFrom: start to: stop
	"Select the specified characters inclusive."
	self selectInvisiblyFrom: start to: stop.
	self closeTypeIn.
	self storeSelectionInParagraph.
	self setEmphasisHere.
! !


!TextMorphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'dgd 10/1/2004 13:23'!
raiseContextMenu: characterStream 
	(morph respondsTo: #editView)
		ifTrue: [morph editView yellowButtonActivity: ActiveEvent shiftPressed]
		ifFalse: [sensor keyboard.
			"consume the character"
			morph yellowButtonActivity: false].
	^ true! !


!TextMorphEditor methodsFor: 'scrolling' stamp: 'di 10/2/97 09:08'!
scrollBy: ignore 
	"Ignore scroll requests."! !

!TextMorphEditor methodsFor: 'scrolling'!
updateMarker
	"Ignore scrollbar redraw requests."
! !


!TextMorphEditor methodsFor: 'typing support' stamp: 'sw 8/12/2002 01:12'!
dispatchOnCharacter: char with: typeAheadStream
	"Carry out the action associated with this character, if any.
	Type-ahead is passed so some routines can flush or use it."

	((char == Character cr) and: [morph acceptOnCR])
		ifTrue:
			[sensor keyboard.  "Gobble cr -- probably unnecessary."
			self closeTypeIn.
			^ true].

	^ super dispatchOnCharacter: char with: typeAheadStream! !

!TextMorphEditor methodsFor: 'typing support' stamp: 'di 6/14/1998 13:11'!
readKeyboard
	super readKeyboard.
	self storeSelectionInParagraph! !


!TextMorphEditor methodsFor: 'private' stamp: 'dgd 2/21/2003 22:50'!
againOrSame: bool 
	| bk keys |
	(bk := morph ownerThatIsA: BookMorph) ifNotNil: 
			[(keys := bk valueOfProperty: #tempSearchKey ifAbsent: [nil]) ifNil: 
					["Cmd-f"

					keys := bk valueOfProperty: #searchKey ifAbsent: [nil]	"Cmd-g"]
				ifNotNil: [bk removeProperty: #tempSearchKey].
			keys ifNotNil: 
					[keys notEmpty
						ifTrue: 
							[bk findText: keys.
							^(morph respondsTo: #editView) 
								ifTrue: [morph editView selectionInterval: self selectionInterval]]]].
	super againOrSame: bool.
	(morph respondsTo: #editView) 
		ifTrue: [morph editView selectionInterval: self selectionInterval]! !
TextMorph subclass: #TextMorphForEditView
	instanceVariableNames: 'editView acceptOnCR'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!

!TextMorphForEditView methodsFor: 'accept/cancel' stamp: 'di 9/11/1998 15:42'!
acceptOnCR: trueOrFalse
	acceptOnCR _ trueOrFalse! !


!TextMorphForEditView methodsFor: 'debug and other' stamp: 'sw 11/2/1998 15:51'!
tempCommand
	"Smalltalk browseAllImplementorsOf: #tempCommand"
	"Place your definition for tempCommand for this class here"! !


!TextMorphForEditView methodsFor: 'drawing' stamp: 'di 6/22/1998 10:44'!
drawNullTextOn: aCanvas
	"Just run the normal code to show selection in a window"
	aCanvas paragraph: self paragraph bounds: bounds color: color
! !


!TextMorphForEditView methodsFor: 'edit view' stamp: 'di 6/22/1998 01:31'!
editView
	^ editView! !

!TextMorphForEditView methodsFor: 'edit view' stamp: 'di 4/21/1998 13:09'!
setEditView: editPane
	editView _ editPane! !


!TextMorphForEditView methodsFor: 'editing' stamp: 'di 4/22/1998 10:57'!
acceptContents
	"The message is sent when the user hits enter or Cmd-S.
	Accept the current contents and end editing."
	self updateFromParagraph.
	editView accept.! !

!TextMorphForEditView methodsFor: 'editing' stamp: 'sw 8/12/2002 00:02'!
acceptOnCR
	"Answer whether the receiver wants to accept when the Return key is hit"

	^ acceptOnCR == true! !

!TextMorphForEditView methodsFor: 'editing' stamp: 'di 4/22/1998 11:03'!
cancelEdits
	"The message is sent when the user hits enter or Cmd-L.
	Cancel the current contents and end editing."
	self releaseParagraph.
	editView cancel! !

!TextMorphForEditView methodsFor: 'editing' stamp: 'di 10/5/1998 14:03'!
handleInteraction: interActionBlock fromEvent: evt
	"Overridden to pass along a model to the editor for, eg, link resolution, doits, etc"

	self editor model: editView model.  "For evaluateSelection, etc"
	^ super handleInteraction: interActionBlock fromEvent: evt! !

!TextMorphForEditView methodsFor: 'editing' stamp: 'di 4/21/1998 13:23'!
hasUnacceptedEdits: aBoolean
	"Set the hasUnacceptedEdits flag in my view."

	editView hasUnacceptedEdits: aBoolean! !


!TextMorphForEditView methodsFor: 'event handling' stamp: 'ar 11/8/2000 15:50'!
autoScrollView: evt
	"This is kind of a hack because the PluggableTextMorph expects me to first expand the selection before auto scrolling will work."
	| localEvt |
	localEvt _ evt transformedBy: (self transformedFrom: editView).
	super mouseMove: localEvt.
	editView scrollSelectionIntoView: localEvt.! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'bf 4/14/1999 12:39'!
keyStroke: evt
	| view |
	(editView scrollByKeyboard: evt) ifTrue: [^self].
	self editor model: editView model.  "For evaluateSelection"
	view _ editView.  "Copy into temp for case of a self-mutating doit"
	(acceptOnCR and: [evt keyCharacter = Character cr])
		ifTrue: [^ self editor accept].
	super keyStroke: evt.
	view scrollSelectionIntoView! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'sw 8/29/2004 23:09'!
keyboardFocusChange: aBoolean 
	"rr 3/21/2004 22:55 : removed the #ifFalse: branch, 
	which was responsible of the deselection of text when the 
	paragraph lost focus. This way selection works in a more standard 
	way, and this permits the menu keyboard control to be really effective"
	paragraph isNil ifFalse:[paragraph focused: aBoolean].
	aBoolean 
		ifTrue: 
			["A hand is wanting to send us characters..."

			self hasFocus ifFalse: [self editor	"Forces install"]].
	self changed.
! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'di 6/30/1998 08:50'!
mouseDown: event

	event yellowButtonPressed ifTrue: [^ editView yellowButtonActivity: event shiftPressed].
	^ super mouseDown: event
! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'ar 9/26/2001 22:28'!
mouseMove: evt
	| editEvt |
	super mouseMove: evt.
	evt redButtonPressed ifFalse: [^ self].
	editEvt _ evt transformedBy: (self transformedFrom: editView) inverseTransformation.
	(editEvt position y between: editView top and: editView bottom) ifFalse:[
		"Start auto-scrolling"
		self startStepping: #autoScrollView:
			at: Time millisecondClockValue
			arguments: (Array with: editEvt)
			stepTime: 100. "fast enough"
	] ifTrue:[
		self stopSteppingSelector: #autoScrollView:.
	].! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'yo 11/7/2002 18:44'!
mouseUp: evt
	super mouseUp: evt.
	self stopSteppingSelector: #autoScrollView:.
	editView scrollSelectionIntoView: evt.

	self setCompositionWindow.
! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:43'!
preferredKeyboardPosition

	| pos |
	pos _ super preferredKeyboardPosition.
	^ pos + (self bounds: self bounds in: World) topLeft.
! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'sw 8/29/2000 15:06'!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver would be a happy inheritor of keyboard focus if tab were hit in an enclosing playfield under propitious circumstances.  Does not make sense for this kind of morph, which is encased in a window"

	^ false! !


!TextMorphForEditView methodsFor: 'initialization' stamp: 'di 9/11/1998 15:43'!
initialize
	super initialize.
	acceptOnCR _ false! !


!TextMorphForEditView methodsFor: 'macpal' stamp: 'di 11/10/1998 10:13'!
flash
	^ editView flash! !


!TextMorphForEditView methodsFor: 'miscellaneous' stamp: 'sw 7/27/2001 13:35'!
selectAll
	"Tell my editor to select all the text"

	self editor selectAll! !


!TextMorphForEditView methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 17:50'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	acceptOnCR ifNil: [acceptOnCR _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!TextMorphForEditView methodsFor: 'private' stamp: 'dew 2/21/1999 03:09'!
updateFromParagraph  
	super updateFromParagraph.
	editView setScrollDeltas.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextMorphForEditView class
	instanceVariableNames: ''!

!TextMorphForEditView class methodsFor: 'new-morph participation' stamp: 'kfr 5/1/2000 13:41'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
ClassTestCase subclass: #TextMorphTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!

!TextMorphTest methodsFor: 'testing' stamp: 'md 11/13/2003 10:01'!
testInitialize
	"For now, just make sure initialization doesn't throw exception"

	self shouldnt: [TextMorph initialize] raise: Error.! !
NewParagraph subclass: #TextOnCurve
	instanceVariableNames: 'lastCharacterIndex curve'
	classVariableNames: 'CachedWarpColor CachedWarpDepth CachedWarpMap'
	poolDictionaries: ''
	category: 'MorphicExtras-Text Support'!
!TextOnCurve commentStamp: '<historical>' prior: 0!
This subclass of Paragraph composes and displays text along a segmented line or curve.  It does this by using all the normal text composition machinery, but just to lay text out for each segment of the curve in question.  The display process is somewhat complicated, as it involves rotating the text for each segment, and then merging it into the destination Form with background, selection highlight, and transparency all handled correctly.

Because TextMorph flushes its paragraph to save space, the enduring specification of curve layout (direction, baseline, and margin) must be stored in the container.!


!TextOnCurve methodsFor: 'access' stamp: 'jm 11/19/97 22:38'!
extent
	^ curve bounds extent! !

!TextOnCurve methodsFor: 'access' stamp: 'jm 11/19/97 20:29'!
textOwner: theCurve
	curve _ theCurve! !


!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 22:54'!
composeLinesFrom: startingIndex withLines: startingLines atY: startingY 
	"Here we determine the 'lines' of text that will fit along each segment of the curve. For each line, we determine its rectangle, then the dest wuadrilateral that it willbe rotated to.  Then, we take the outer hull to determine a dest rectangle for WarpBlt.  In addition we need the segment pivot point and angle, from which the source quadrilateral may be computed."

	| charIndex scanner line firstLine curveSegments segIndex pa pb segLen lineRect textSegments segDelta segAngle destRect destQuad i oldBounds |
	(oldBounds := container bounds) ifNotNil: [curve invalidRect: oldBounds].
	charIndex := startingIndex.
	lines := startingLines.
	curveSegments := curve lineSegments.
	container textDirection < 0 
		ifTrue: 
			[curveSegments := curveSegments reversed 
						collect: [:seg | Array with: (seg second) with: seg first]].
	textSegments := OrderedCollection new.
	scanner := SegmentScanner new text: text textStyle: textStyle.
	segIndex := 1.	"For curves, segIndex is just an index."
	firstLine := true.
	pa := curveSegments first first.
	[charIndex <= text size and: [segIndex <= curveSegments size]] whileTrue: 
			[curve isCurve ifFalse: [pa := (curveSegments at: segIndex) first].
			pb := (curveSegments at: segIndex) last.
			segDelta := pb - pa.	"Direction of this segment"
			segLen := segDelta r.
			lineRect := 0 @ 0 extent: segLen asInteger @ textStyle lineGrid.
			line := scanner 
						composeFrom: charIndex
						inRectangle: lineRect
						firstLine: firstLine
						leftSide: true
						rightSide: true.
			line setRight: scanner rightX.
			line width > 0 
				ifTrue: 
					[lines addLast: line.
					segAngle := segDelta theta.
					destQuad := line rectangle corners collect: 
									[:p | 
									(p translateBy: pa - (0 @ (line baseline + container baseline))) 
										rotateBy: segAngle negated
										about: pa].
					destRect := Rectangle encompassing: destQuad.
					textSegments addLast: (Array 
								with: destRect truncated
								with: pa
								with: segAngle).
					pa := pa + ((pb - pa) * line width / segLen).
					charIndex := line last + 1].
			segIndex := segIndex + 1.
			firstLine := false].
	lines isEmpty 
		ifTrue: 
			["No space in container or empty text"

			line := (TextLine 
						start: startingIndex
						stop: startingIndex - 1
						internalSpaces: 0
						paddingWidth: 0)
						rectangle: (0 @ 0 extent: 10 @ textStyle lineGrid);
						lineHeight: textStyle lineGrid baseline: textStyle baseline.
			lines := Array with: line.
			textSegments addLast: (Array 
						with: (curve vertices first extent: line rectangle extent)
						with: curve vertices first
						with: 0.0)].
	"end of segments, now attempt word break."
	lines last last < text size 
		ifTrue: 
			[
			[lines size > 1 
				and: [(text at: (i := lines last last) + 1) ~= Character space]] 
					whileTrue: 
						[i = lines last first 
							ifTrue: 
								[lines removeLast.
								textSegments removeLast]
							ifFalse: [lines last stop: i - 1]]].
	lines := lines asArray.
	container textSegments: textSegments asArray.
	curve invalidRect: container bounds.
	^maxRightX! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 10:24'!
pointInLine: line forDestPoint: p segStart: segStart segAngle: segAngle
	^ (p rotateBy: segAngle about: segStart)
			translateBy: (0@(line baseline + container baseline)) - segStart! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 11/29/97 20:15'!
releaseCachedState
	super releaseCachedState.
	CachedWarpMap _ CachedWarpDepth _ CachedWarpColor _ nil! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 22:54'!
textSegmentsDo: blockForLineDestPivotAngle 
	| segments segSpec |
	(segments := container textSegments) ifNil: [^self].
	1 to: lines size
		do: 
			[:i | 
			segSpec := segments at: i.
			blockForLineDestPivotAngle 
				value: (lines at: i)
				value: (segSpec first)
				value: (segSpec second)
				value: (segSpec third)]! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 22:54'!
warpMapForDepth: destDepth withTransparentFor: bkgndColor 
	(CachedWarpDepth = destDepth and: [CachedWarpColor = bkgndColor]) 
		ifTrue: 
			["Map is OK as is -- return it"

			^CachedWarpMap].
	(CachedWarpMap isNil or: [CachedWarpDepth ~= destDepth]) 
		ifTrue: 
			["Have to recreate the map"

			CachedWarpMap := Color computeColormapFrom: 32 to: destDepth.
			CachedWarpDepth := destDepth]
		ifFalse: 
			["Map is OK, if we restore prior color substiution"

			CachedWarpMap at: (CachedWarpColor indexInMap: CachedWarpMap)
				put: (CachedWarpColor pixelValueForDepth: destDepth)].
	"Now map the background color into transparent, and return the new map"
	CachedWarpColor := bkgndColor.
	CachedWarpMap at: (CachedWarpColor indexInMap: CachedWarpMap) put: 0.
	^CachedWarpMap! !


!TextOnCurve methodsFor: 'composition' stamp: 'di 4/30/1999 08:06'!
composeAll
	self composeLinesFrom: firstCharacterIndex
		withLines: OrderedCollection new
		atY: container top.! !

!TextOnCurve methodsFor: 'composition' stamp: 'di 6/23/1999 10:17'!
composeLinesFrom: start to: stop delta: delta into: newLines priorLines: priorLines
	atY: startingY

	^ self composeLinesFrom: start withLines: newLines atY: startingY! !


!TextOnCurve methodsFor: 'display' stamp: 'di 8/13/2000 12:27'!
asParagraphForPostscript

	^ self as: TextOnCurvePS! !

!TextOnCurve methodsFor: 'display' stamp: 'ar 5/25/2000 18:01'!
displayOn: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"
	| maxExtent lineForm leftInRun lineRect warp sourceQuad backgroundColor lineCanvas |
	warp _ nil.
	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		false ifTrue:
			["Show the dest rects for debugging..."
			aCanvas frameRectangle: destRect width: 1 color: Color black].
		(aCanvas isVisible: destRect) ifTrue:
			[warp ifNil:
				["Lazy initialization because may hot have to display at all."
				maxExtent _ lines inject: lines first rectangle extent 
					into: [:maxWid :lin | maxWid max: lin rectangle extent].
				lineForm _ Form extent: maxExtent depth: aCanvas depth.
				displayScanner setDestForm: lineForm.
				lineRect _ lineForm boundingBox.
				leftInRun _ 0.
				backgroundColor _ (curve borderWidth > 10
							ifTrue: [curve color]
							ifFalse: [curve owner isHandMorph
									ifTrue: [curve owner owner color]
									ifFalse: [curve owner color]]) dominantColor.
				warp _ (aCanvas warpFrom: lineRect corners toRect: lineRect)
						cellSize: 2;  "installs a colormap if smoothing > 1"
						sourceForm: lineForm.
				warp colorMap: (self warpMapForDepth: aCanvas depth
									withTransparentFor: backgroundColor).
				lineCanvas _ lineForm getCanvas].
			sourceQuad _ destRect innerCorners collect:
				[:p | self pointInLine: line forDestPoint: p
						segStart: segStart segAngle: segAngle].
			lineForm fill: lineForm boundingBox fillColor: backgroundColor.
			self displaySelectionInLine: line on: lineCanvas.
			leftInRun _ displayScanner displayLine: line offset: 0@0 leftInRun: leftInRun.
			warp sourceQuad: sourceQuad destRect: (destRect translateBy: aCanvas origin).
			warp warpBits]].
! !


!TextOnCurve methodsFor: 'selection' stamp: 'ar 5/18/2000 18:33'!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for the character in the text at aPoint."
	| sourcePoint cb curvePoint |
	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		(destRect containsPoint: aPoint) ifTrue:
			["It's in the destRect; now convert to source coords"
			sourcePoint _ self pointInLine: line forDestPoint: aPoint
							segStart: segStart segAngle: segAngle.
			cb _ (CharacterBlockScanner new text: text textStyle: textStyle)
				characterBlockAtPoint: (sourcePoint adhereTo: line rectangle)
				index: nil in: line.
			(sourcePoint x between: line left and: line right) ifTrue:
				["Definitely in this segment"
				^ cb]]].
	"Point is off curve -- try again with closest point on curve"
	curvePoint _ curve closestPointTo: aPoint.
	curvePoint = aPoint ifFalse:
		[^ self characterBlockAtPoint: curvePoint].
	"If all else fails, at least return something acceptable."
	^ cb ifNil: [self defaultCharacterBlock]! !

!TextOnCurve methodsFor: 'selection' stamp: 'di 12/3/97 09:06'!
containsPoint: aPoint
	"Return true if aPoint is in the actual text areas."
	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		(destRect containsPoint: aPoint) ifTrue:
			["It's in the destRect; now check if really in text area"
			(line rectangle containsPoint:
				(self pointInLine: line forDestPoint: aPoint
					segStart: segStart segAngle: segAngle))
				ifTrue: [^ true]]].
	^ false! !

!TextOnCurve methodsFor: 'selection' stamp: 'di 12/3/97 09:06'!
selectionRectsFrom: characterBlock1 to: characterBlock2
	"Return an array of rectangles encompassing the area
	between the two character blocks, presumably a selection."
	| rects |
	rects _ OrderedCollection new.
	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		(characterBlock1 stringIndex <= line last
			and: [characterBlock2 stringIndex >= line first]) ifTrue:
			[rects addLast: destRect].
		line first > characterBlock2 stringIndex ifTrue:
			[^ rects]].
	^ rects! !


!TextOnCurve methodsFor: 'private' stamp: 'nk 6/23/2004 15:06'!
moveBy: delta
	positionWhenComposed _ (positionWhenComposed ifNil: [ container origin ]) + delta.
	container _ container translateBy: delta
! !
Object subclass: #TextOnCurveContainer
	instanceVariableNames: 'baseline inset textDirection textSegments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Text Support'!
!TextOnCurveContainer commentStamp: '<historical>' prior: 0!
I am not really a container in the sense of TextContainer.  However, I get stored in the same field of a textMorph.  My baseline specifies the vertical displacement of the character baselines from the curve center (0 means on center, 5 would mean, eg, the character baselines are 5 pixels above the curve center).  This is ssential enduring information.  I also cache temporary layout information, including the locations, angles and bounding boxes of each of the characters as displayed.!


!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 10:22'!
baseline
	baseline ifNil: [^ 0].
	^ baseline! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'jm 11/19/97 19:30'!
baseline: newBaseline
	baseline _ newBaseline! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 13:36'!
bounds
	textSegments ifNil: [^nil].
	^textSegments inject: (textSegments first first)
		into: [:bnd :each | bnd merge: (each first)]! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'jm 11/19/97 19:28'!
paragraphClass
	^ TextOnCurve! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/4/97 08:28'!
releaseCachedState
	textSegments _ nil.! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:16'!
textDirection
	^ textDirection! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/4/97 09:23'!
textDirection: plusOrMinusOne
	textDirection _ plusOrMinusOne! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:29'!
textSegments
	^ textSegments! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:29'!
textSegments: segments
	textSegments _ segments! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 11/21/97 21:48'!
top
	^ 1  "for compatibility"! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 13:37'!
translateBy: delta 
	textSegments isNil ifTrue: [^self].
	textSegments := textSegments collect: 
					[:ls | 
					Array 
						with: (ls first translateBy: delta)
						with: (ls second translateBy: delta)
						with: ls third]! !
TextOnCurve subclass: #TextOnCurvePS
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Text Support'!

!TextOnCurvePS methodsFor: 'display' stamp: 'di 8/13/2000 12:39'!
displayOn: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"

	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		self displaySelectionInLine: line on: aCanvas.
		line first <= line last ifTrue:
			[displayScanner displayLine: line offset: destRect topLeft leftInRun: 999]]

! !
TextAction subclass: #TextPlusJumpEnd
	instanceVariableNames: 'jumpLabel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!TextPlusJumpEnd methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:33'!
emphasizeScanner: scanner

	"none for me, thanks"! !

!TextPlusJumpEnd methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:08'!
jumpLabel

	^jumpLabel! !

!TextPlusJumpEnd methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:08'!
jumpLabel: aString

	jumpLabel _ aString! !
TextAction subclass: #TextPlusJumpStart
	instanceVariableNames: 'jumpLabel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!TextPlusJumpStart methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 13:06'!
actOnClickFor: model
	"Subclasses may override to provide, eg, hot-spot actions"

	model doJumpTo: jumpLabel.
	^ true! !

!TextPlusJumpStart methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:34'!
emphasizeScanner: scanner
	"Set the emphasist for text scanning"
	scanner addEmphasis: 4! !

!TextPlusJumpStart methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:21'!
jumpLabel

	^jumpLabel! !

!TextPlusJumpStart methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:21'!
jumpLabel: aString

	jumpLabel _ aString! !
TextMorph subclass: #TextPlusMorph
	instanceVariableNames: 'scrollerOwner ignoreNextUp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'md 2/15/2006 18:38'!
addAlansAnchorFor: aMorph

	| ed attribute selRects |

	self removeAlansAnchorFor: aMorph.
	ed _ self editor.
	attribute _ TextAnchor new anchoredMorph: aMorph.
	aMorph setProperty: #geeMailLeftOffset toValue: aMorph left - self left.
	ed replaceSelectionWith: (ed selection addAttribute: attribute).
	selRects _ self paragraph selectionRects.
	selRects isEmpty ifFalse: [
		aMorph top: selRects first top
	].
	self releaseParagraphReally.
	self layoutChanged.

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 15:15'!
addColumnBreak

	| ed old new break |

	ed _ self editor.
	old _ ed selection.
	break _ TextComposer characterForColumnBreak asString.
	break _ Text string: break attributes: {}.
	new _ old ,break.
	ed replaceSelectionWith: new.
	self releaseParagraphReally.
	self layoutChanged.

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'tk 7/26/2001 08:44'!
addItem: classAndMethod
	"Make a linked message list and put this method in it"

	Model new addItem: classAndMethod	"let him do all the work"! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:01'!
addJumpBeginning

	| ed attribute jumpEnd mySelection a1 ax |

	ed _ self editor.
	(mySelection _ ed selection) isEmpty ifTrue: [^self inform: 'Please select something first'].
	jumpEnd _ self chooseOneJumpEnd.
	jumpEnd isEmptyOrNil ifTrue: [^self].

	attribute _ TextPlusJumpStart new jumpLabel: jumpEnd.
	a1 _ (mySelection attributesAt: 1) reject: [ :each | each isKindOf: TextPlusJumpStart].
	ax _ (mySelection attributesAt: mySelection size) reject: [ :each | each isKindOf: TextPlusJumpStart].
	ed replaceSelectionWith: 
		(Text string: '*' attributes: a1),
		(mySelection addAttribute: attribute),
		(Text string: '*' attributes: ax).
	self releaseParagraphReally.
	self layoutChanged.

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:18'!
addJumpEnd

	| ed attribute jumpLabel selectedString |

	ed _ self editor.
	selectedString _ ed selection asString.
	selectedString isEmpty ifTrue: [^self inform: 'Please select something first'].
	jumpLabel _ FillInTheBlank request: 'Name this place' initialAnswer: selectedString.
	jumpLabel isEmpty ifTrue: [^self].
	self removeJumpEndFor: jumpLabel.
	attribute _ TextPlusJumpEnd new jumpLabel: jumpLabel.
	ed replaceSelectionWith: (ed selection addAttribute: attribute).

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 14:41'!
allJumpEndStrings

	| answer |

	answer _ OrderedCollection new.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextPlusJumpEnd) ifTrue: [
				(answer includes: att jumpLabel) ifFalse: [answer add: att jumpLabel].
			]
		]
	].
	^answer

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:28'!
chooseOneJumpEnd

	| menu |

	menu _ CustomMenu new.
	self allJumpEndStrings do: [ :each |
		menu 
			add: each 
			action: each
	].
	^menu build startUpCenteredWithCaption: 'Possible jump ends'.
	
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 14:13'!
doJumpTo: aString

	| myStart myStop |
	myStart _ myStop _ nil.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			((att isMemberOf: TextPlusJumpEnd) and: [att jumpLabel = aString]) ifTrue: [
				myStart 
					ifNil: [myStart _ start. myStop _ stop] 
					ifNotNil: [myStart _ myStart min: start. myStop _ myStop max: stop].
			]
		]
	].
	myStart ifNil: [^self].

	self editor selectFrom: myStart to: myStop.
	ignoreNextUp _ true.
	self changed.
	self scrollSelectionToTop.
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 09:18'!
doYellowButtonPress: evt

	| menu |

	menu _ CustomMenu new.
	menu 
		add: 'Go to top of document'				action: [self jumpToDocumentTop];
		add: 'Move selection to top of page'		action: [self scrollSelectionToTop];
		add: 'Add column break'					action: [self addColumnBreak];
		add: 'Define as jump start'				action: [self addJumpBeginning];
		add: 'Define as jump end'				action: [self addJumpEnd].

	((menu build startUpCenteredWithCaption: 'Text navigation options') ifNil: [^self]) value.
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'md 2/15/2006 18:44'!
fixAllLeftOffsets

	| am |

	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextAnchor) ifTrue: [
				am _ att anchoredMorph.
				(am isNil or: [am world isNil]) ifFalse: [
					am 
						valueOfProperty: #geeMailLeftOffset 
						ifAbsent: [
							am setProperty: #geeMailLeftOffset toValue: am left - self left
						]
				]
			]
		]
	].

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 14:13'!
jumpToDocumentTop

	self editor selectFrom: 1 to: 0.
	self changed.
	self scrollSelectionToTop.
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:46'!
keyboardFocusLostForSure

	editor ifNotNil: [
		self selectionChanged.
		self paragraph selectionStart: nil selectionStop: nil.
		editor _ nil
	].


! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 16:27'!
linkNewlyDroppedMorph: aMorph

	| ed para lineToUse |

	ed _ self editor.
	para _ self paragraph.
	lineToUse _ para lines detect: [ :each | each bottom > aMorph top] ifNone: [para lines last].
	ed selectFrom: lineToUse first to: lineToUse last.
	self addAlansAnchorFor: aMorph.

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'di 7/28/2001 10:35'!
makeSuccessorMorph

	| newMorph |
	self fixAllLeftOffsets.
	newMorph _ self copy predecessor: self successor: successor.
	newMorph extent: self width @ 100.
	successor ifNotNil: [successor setPredecessor: newMorph].
	self setSuccessor: newMorph.
	successor recomposeChain.
	^newMorph! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'sd 7/9/2004 18:02'!
parentGeeMail
	
	^self ownerThatIsA: GeeMailMorph
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'md 2/15/2006 18:44'!
removeAlansAnchorFor: aMorph

	| anchors |

	anchors _ OrderedCollection new.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextAnchor) ifTrue: [
				(att anchoredMorph isNil or: [
					att anchoredMorph == aMorph or: [att anchoredMorph world isNil]]) ifTrue: [
					anchors add: {att. start. stop}
				]
			]
		]
	].
	anchors do: [ :old |
		text removeAttribute: old first from: old second to: old third.
	].

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:08'!
removeJumpEndFor: aString

	| anchors |

	anchors _ OrderedCollection new.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextPlusJumpEnd) ifTrue: [
				att jumpLabel == aString ifTrue: [
					anchors add: {att. start. stop}
				]
			]
		]
	].
	anchors do: [ :old |
		text removeAttribute: old first from: old second to: old third.
	].

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'md 2/15/2006 18:44'!
repositionAnchoredMorphs

	| am cBlock leftShift firstCharacterIndex lastCharacterIndex |

	firstCharacterIndex _ self paragraph firstCharacterIndex.
	lastCharacterIndex _ paragraph lastCharacterIndex.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextAnchor) ifTrue: [
				am _ att anchoredMorph.
				(am isNil or: [am world isNil]) ifFalse: [
					(stop between: firstCharacterIndex and: lastCharacterIndex) ifTrue: [
						cBlock _ self paragraph characterBlockForIndex: stop.
						leftShift _ am valueOfProperty: #geeMailLeftOffset ifAbsent: [0].
						am position: (self left + leftShift) @ cBlock origin y.
					].
				]
			]
		]
	].
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:35'!
scrollSelectionToTop

	(self parentGeeMail ifNil: [^self])
		scrollSelectionIntoView: nil 
		alignTop: true 
		inTextMorph: self.
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 16:23'!
textPlusMenuFor: aMorph

	| menu |
	menu _ MenuMorph new.
	menu 
		add: 'Link to text selection' 
		target: [self addAlansAnchorFor: aMorph] fixTemps
		selector: #value;

		add: 'Unlink from text selection' 
		target: [self removeAlansAnchorFor: aMorph] fixTemps
		selector: #value;

		add: 'Delete' 
		target: [
			self removeAlansAnchorFor: aMorph.
			aMorph delete.
		] fixTemps
		selector: #value.
	^menu
! !


!TextPlusMorph methodsFor: 'editing' stamp: 'RAA 5/3/2001 17:35'!
handleInteraction: interactionBlock fromEvent: evt
	
	super handleInteraction: interactionBlock fromEvent: evt.
	(self parentGeeMail ifNil: [^self])
		scrollSelectionIntoView: evt 
		alignTop: false 
		inTextMorph: self.
! !


!TextPlusMorph methodsFor: 'event handling' stamp: 'ag 8/19/2004 04:53'!
keyboardFocusChange: aBoolean

	| parent |

	"we basically ignore loss of focus unless it is going to one of our siblings"
	aBoolean ifFalse: [^self].

	paragraph isNil ifFalse:[paragraph focused: aBoolean].

	"A hand is wanting to send us characters..."
	self hasFocus ifFalse: [self editor "Forces install"].

	"Inform our siblings we have taken the focus"
	parent _ self parentGeeMail ifNil: [^self].
	parent allTextPlusMorphs do: [ :each |
		each == self ifFalse: [each keyboardFocusLostForSure]
	].

! !

!TextPlusMorph methodsFor: 'event handling' stamp: 'RAA 9/13/2000 15:53'!
mouseDown: evt

	ignoreNextUp _ false.
	evt yellowButtonPressed ifTrue: [
		^self doYellowButtonPress: evt
	].
	^super mouseDown: evt
! !

!TextPlusMorph methodsFor: 'event handling' stamp: 'RAA 9/13/2000 15:53'!
mouseMove: evt

	ignoreNextUp == true ifTrue: [^self].
	^super mouseMove: evt
! !

!TextPlusMorph methodsFor: 'event handling' stamp: 'RAA 9/13/2000 15:53'!
mouseUp: evt

	ignoreNextUp == true ifTrue: [ignoreNextUp _ false. ^self].
	^super mouseUp: evt
! !


!TextPlusMorph methodsFor: 'linked frames' stamp: 'RAA 5/2/2001 14:05'!
addSuccessor: evt

	evt hand attachMorph: self makeSuccessorMorph! !

!TextPlusMorph methodsFor: 'linked frames' stamp: 'RAA 11/30/2001 11:13'!
recomposeChain
	"Recompose this textMorph and all that follow it."
	self withSuccessorsDo:
		[:m |  m text: text textStyle: textStyle;  "Propagate new style if any"
				releaseParagraphReally;  "Force recomposition"
				fit  "and propagate the change"]
! !


!TextPlusMorph methodsFor: 'private' stamp: 'RAA 5/7/2001 10:25'!
predecessorChanged

	super predecessorChanged.
	self repositionAnchoredMorphs.
! !

!TextPlusMorph methodsFor: 'private' stamp: 'RAA 9/6/2000 15:50'!
releaseEditor! !

!TextPlusMorph methodsFor: 'private' stamp: 'RAA 9/6/2000 15:49'!
releaseParagraph! !

!TextPlusMorph methodsFor: 'private' stamp: 'RAA 9/6/2000 15:52'!
releaseParagraphReally
	"Paragraph instantiation is lazy -- it will be created only when needed"

	editor ifNotNil: [
		self selectionChanged.
		self paragraph selectionStart: nil selectionStop: nil.
		editor _ nil].
	paragraph ifNotNil: [paragraph _ nil].
	container ifNotNil: [container releaseCachedState]! !

!TextPlusMorph methodsFor: 'private' stamp: 'RAA 5/5/2001 15:48'!
updateFromParagraph

	super updateFromParagraph.
	self repositionAnchoredMorphs.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextPlusMorph class
	instanceVariableNames: ''!

!TextPlusMorph class methodsFor: 'new-morph participation' stamp: 'RAA 9/6/2000 16:26'!
includeInNewMorphMenu

	^ false! !
PasteUpMorph subclass: #TextPlusPasteUpMorph
	instanceVariableNames: 'theTextMorph showPageBreaks'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-GeeMail'!

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/29/2001 18:06'!
allTextPlusMorphs

	^submorphs select: [ :each | each isKindOf: TextPlusMorph]

! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:18'!
disablePageBreaksWhile: aBlock

	| save result |

	save _ showPageBreaks.
	showPageBreaks _ false.
	result _ aBlock value.
	showPageBreaks _ save.
	^result
! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:19'!
fullDrawForPrintingOn: aCanvas

	self disablePageBreaksWhile: [self fullDrawOn: aCanvas].
! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 09:31'!
nearestTextPlusMorphTo: aMorph

	^self allTextPlusMorphs inject: nil into: [ :best :each |
		self select: best or: each asClosestTo: aMorph
	]! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:25'!
printer

	^GeePrinter new 
		pasteUp: self;
		printSpecs: self printSpecs! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 09:30'!
select: bestPrevious or: current asClosestTo: aMorph

	bestPrevious ifNil: [^current].
	(bestPrevious bounds intersects: aMorph bounds) ifTrue: [^bestPrevious].
	(current bounds intersects: aMorph bounds) ifTrue: [^current].
	bestPrevious left < current left ifTrue: [
		^aMorph left < current left ifTrue: [bestPrevious] ifFalse: [current]
	].
	^aMorph left < bestPrevious left ifTrue: [current] ifFalse: [bestPrevious]
! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/30/2003 22:19'!
showPageBreaksString
	^ (showPageBreaks
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'show page breaks' translated! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 09:31'!
textPlusMenuFor: aMorph

	^(self nearestTextPlusMorphTo: aMorph) textPlusMenuFor: aMorph
! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:12'!
togglePageBreaks

	showPageBreaks _ showPageBreaks not.
	self changed! !


!TextPlusPasteUpMorph methodsFor: 'drawing' stamp: 'RAA 9/18/2000 15:55'!
drawOn: aCanvas

	| clip rects |
	super drawOn: aCanvas.
	showPageBreaks == false ifTrue: [^self].

	clip _ aCanvas clipRect.
	rects _ self printer pageRectangles.
	rects do: [ :each |
		each bottom > clip bottom ifTrue: [^self].
		aCanvas 
			fillRectangle: (self left @ each bottom corner: self right @ each bottom + 1) 
			color: Color red
	].! !


!TextPlusPasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 10/3/2000 12:56'!
wantsDroppedMorph: aMorph event: evt
	"Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. The default implementation returns false.
NOTE: the event is assumed to be in global (world) coordinates."

	(aMorph isKindOf: NewHandleMorph) ifTrue: [^false].
	(aMorph isKindOf: GeeBookMorph) ifTrue: [^false].	"avoid looping"
	^super wantsDroppedMorph: aMorph event: evt! !


!TextPlusPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 5/3/2001 17:22'!
initialize

	super initialize.
	showPageBreaks _ true.
	self addMorphBack: (TextPlusMorph new position: 4@4).
! !


!TextPlusPasteUpMorph methodsFor: 'layout' stamp: 'RAA 4/30/2001 10:13'!
acceptDroppingMorph: aMorph event: evt

	| allTextPlus |

	(aMorph isKindOf: NewHandleMorph) ifTrue: [^self].
	(aMorph isKindOf: GeeBookMorph) ifTrue: [^self].	"avoid looping"
	(aMorph isKindOf: TextPlusMorph) ifTrue: [
		^self addMorphBack: aMorph.
	].
	self addMorph: aMorph.

	allTextPlus _ self allTextPlusMorphs.
	aMorph allMorphsDo: [ :each | 
		allTextPlus do: [ :e2 | e2 removeAlansAnchorFor: each].
	].
	(self nearestTextPlusMorphTo: aMorph) linkNewlyDroppedMorph: aMorph! !


!TextPlusPasteUpMorph methodsFor: 'menus' stamp: 'RAA 5/2/2001 16:59'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addUpdating: #showPageBreaksString action: #togglePageBreaks.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextPlusPasteUpMorph class
	instanceVariableNames: ''!

!TextPlusPasteUpMorph class methodsFor: 'new-morph participation' stamp: 'RAA 9/7/2000 12:02'!
includeInNewMorphMenu

	^ false! !
TextDoIt subclass: #TextPrintIt
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextPrintIt methodsFor: 'as yet unclassified' stamp: 'dvf 10/1/2003 13:27'!
actOnClickFor: anObject in: aParagraph at: clickPoint editor: editor
	"Note: evalString gets evaluated IN THE CONTEXT OF anObject
	 -- meaning that self and all instVars are accessible"
	| result range index |
	result _ Compiler evaluate: evalString for: anObject logged: false.
	result _ ' ', result printString,' '.
	"figure out where the attribute ends in aParagraph"
	index _ (aParagraph characterBlockAtPoint: clickPoint) stringIndex.
	range _ aParagraph text rangeOf: self startingAt: index.
	editor selectFrom: range last+1 to: range last.
	editor zapSelectionWith: result.
	editor selectFrom: range last to: range last + result size.
	^ true ! !

!TextPrintIt methodsFor: 'as yet unclassified' stamp: 'ar 9/22/2001 16:28'!
writeScanOn: strm

	strm nextPut: $P; nextPutAll: evalString; nextPutAll: ';;'! !
Object subclass: #TextPrinter
	instanceVariableNames: 'form para paperSize landscape resolution depth offset columns docTitle noHeader noFooter'
	classVariableNames: 'DefaultPaperSize DefaultTextPrinter'
	poolDictionaries: ''
	category: 'Graphics-Text'!

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
bestColor
	"Set the reproduction quality to true color"
	depth := 32.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
blackAndWhite
	"Set the reproduction quality to black and white"
	depth := 1.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:50'!
columns
	^columns! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:50'!
columns: aNumber
	columns := aNumber asInteger max: 1.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 20:14'!
documentTitle
	^docTitle! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 20:14'!
documentTitle: aString
	docTitle := aString! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
goodColor
	"Set the reproduction quality to 8 bit color depth"
	depth := 8.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
landscape
	^landscape! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
landscape: aBoolean
	landscape := aBoolean! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:23'!
noFooter
	^noFooter! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'!
noFooter: aBoolean
	"Turn off footer printing"
	noFooter := aBoolean.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'!
noHeader
	^noHeader! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'!
noHeader: aBoolean
	"Turn off header printing"
	noHeader := aBoolean.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:27'!
offsetRect
	^offset! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:27'!
offsetRect: aRectangle
	"Set the offset rectangle"
	offset := aRectangle! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
paperSize
	^paperSize! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
paperSize: aPoint
	paperSize := aPoint! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:43'!
resolution
	^resolution! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:43'!
resolution: aPoint
	resolution := aPoint! !


!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 19:23'!
footerHeight
	"Return the (additional) height of the footer in inches."
	self noFooter ifTrue:[^0.0].
	^(self pix2in: 0@TextStyle default lineGrid) y * 2! !

!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 20:11'!
footerParagraph
	"Return a paragraph for the footer"
	| fPara rect |
	fPara := Paragraph new.
	fPara destinationForm: form.
	rect := (self in2pix: self textArea bottomLeft) corner: 
				(self in2pix: self textArea bottomRight + (0.0@self footerHeight)).
	fPara clippingRectangle: rect.
	fPara compositionRectangle: rect.
	^fPara! !

!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 19:24'!
printFooter: pageNumber
	"Print the footer for the given page number"
	| fPara |
	self noFooter ifTrue:[^self].
	fPara := self footerParagraph.
	fPara centered.
	fPara text: ('Page ', pageNumber printString) asText.
	fPara displayOn: form.! !


!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:25'!
columnRect: n
	"Return a rectangle describing the n-th column"
	| area left right |
	area := self textArea.
	left := area left + ((n-1) * self columnWidth).
	left := left + ((n-1) * self columnSkip).
	right := left + self columnWidth.
	^(self in2pix: left @ area top) corner: 
		(self in2pix: right @ area bottom)! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:20'!
columnSkip
	"Return the separating space between two columns in inches"
	^0.2! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:21'!
columnWidth
	^(self textWidth - ((self columns-1) * self columnSkip)) / self columns! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:29'!
formatColumn: columnNum startingWith: anIndex
	"Format a new column starting at the given string index. Return the string index indicating the start of the next column or nil if no more columns need printing."
	| colRect blk |
	colRect := self columnRect: columnNum.
	anIndex > 1 ifTrue:[para text: (para text copyFrom: anIndex to: para text size)].
	para compositionRectangle: colRect.
	para clippingRectangle: colRect.
	para composeAll.
	para displayOn: form.
	para visibleRectangle corner y <= colRect extent y ifTrue:[^nil].
	"More columns -- find the character block of the last line and adjust clip rect"
	blk := para characterBlockAtPoint: para visibleRectangle bottomLeft.
	para clearVisibleRectangle. "Make sure that the background is clean"
	para clippingRectangle: (colRect topLeft corner: colRect right@blk top).
	para displayOn: form.
	^blk stringIndex.! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:29'!
formatPage: pageNum startingWith: anIndex
	"Format a new page starting at the given string index. Return the string index indicating the start of the next page or nil if no more pages need printing."
	| nextIndex |
	nextIndex := anIndex.
	1 to: self columns do:[:i|
		nextIndex := self formatColumn: i startingWith: nextIndex.
		nextIndex isNil ifTrue:[^nil].
	].
	^nextIndex! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:58'!
textArea
	^(self offsetRect origin + (0.0@self headerHeight)) corner:
		(self realPaperSize - self offsetRect corner - (0.0@self footerHeight))! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:23'!
textWidth
	^self textArea extent x! !


!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 19:23'!
headerHeight
	"Return the (additional) height of the header in inches."
	self noHeader ifTrue:[^0.0].
	^(self pix2in: 0@TextStyle default lineGrid) y * 2! !

!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 20:11'!
headerParagraph
	"Return a paragraph for the footer"
	| hPara rect |
	hPara := Paragraph new.
	hPara destinationForm: form.
	rect := (self in2pix: self textArea topLeft - (0.0@self headerHeight)) corner: 
				(self in2pix: self textArea topRight).
	hPara clippingRectangle: rect.
	hPara compositionRectangle: rect.
	^hPara! !

!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 19:23'!
printHeader: pageNumber
	"Print the header for the given page number"
	| fPara |
	self noHeader ifTrue:[^self].
	fPara := self headerParagraph.
	fPara centered.
	fPara text: self documentTitle asText.
	fPara displayOn: form.! !


!TextPrinter methodsFor: 'initialize' stamp: 'ar 4/30/98 19:26'!
defaultPaperSize
	"Return the default paper size (inches) for printing"
	^self class defaultPaperSize! !

!TextPrinter methodsFor: 'initialize' stamp: 'nk 4/2/2004 11:32'!
defaultResolution
	"Return the default resolution (DPI) for printing"
	^TextStyle pixelsPerInch asPoint! !

!TextPrinter methodsFor: 'initialize' stamp: 'ar 4/30/98 19:39'!
initialize
	self paperSize: self defaultPaperSize.
	self resolution: self defaultResolution.
	self blackAndWhite.
	self landscape: false.
	self offsetRect: (1.0@1.0 corner: 1.0@1.0).
	self columns: 1.
	self noHeader: false.
	self noFooter: false.
	self documentTitle: 'Squeak Document (from ', Date today printString,')'.! !


!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:39'!
in2mm: aPoint
	"Convert aPoint from millimeters to inches"
	^aPoint * 25.4! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:38'!
in2pix: aPoint
	"Convert aPoint from inches to actual pixels"
	^(aPoint * self resolution) rounded! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:38'!
mm2in: aPoint
	"Convert aPoint from millimeters to inches"
	^aPoint / 25.4! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:40'!
mm2pix: aPoint
	"Convert aPoint from millimeters to actual pixels"
	^self in2pix: (self mm2in: aPoint)! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:39'!
pix2in: aPoint
	"Convert aPoint from a pixel value to inches"
	^aPoint / self resolution! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:40'!
pix2mm: aPoint
	"Convert aPoint from a pixel value to millimeters"
	^self in2mm: (self pix2in: aPoint)! !


!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 20:41'!
flushPage
	"The current page has been set up. Send it to the printer."
	form primPrintHScale: self resolution x vScale: self resolution y landscape: self landscape.
	"Uncomment the following for testing"
	"form displayOn: Display. (Delay forSeconds: 5) wait."
! !

!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 19:19'!
printParagraph
	| pageNum nextIndex |
	para destinationForm: form.
	pageNum := 1.
	nextIndex := 1.
	[form fillColor: Color white.
	self printHeader: pageNum.
	self printFooter: pageNum.
	nextIndex := self formatPage: pageNum startingWith: nextIndex.
	self flushPage.
	nextIndex isNil] whileFalse:[pageNum := pageNum + 1].! !

!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 18:55'!
printText: aText
	"Print aText"
	form isNil ifTrue:[
		form := Form extent: self pixelSize depth: depth.
	].
	para := Paragraph withText: aText asText.
	Cursor wait showWhile:[
		self printParagraph.
	].! !


!TextPrinter methodsFor: 'private' stamp: 'ar 4/30/98 19:40'!
pixelSize
	"Return the size of the page in pixels"
	^self in2pix: (self realPaperSize)! !

!TextPrinter methodsFor: 'private' stamp: 'ar 4/30/98 19:39'!
realPaperSize
	^self landscape
		ifTrue:[self paperSize y @ self paperSize x]
		ifFalse:[self paperSize]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextPrinter class
	instanceVariableNames: ''!

!TextPrinter class methodsFor: 'accessing' stamp: 'ar 4/30/98 18:31'!
defaultPaperSize
	^DefaultPaperSize! !

!TextPrinter class methodsFor: 'accessing' stamp: 'ar 4/30/98 18:31'!
defaultPaperSize: aPoint
	DefaultPaperSize := aPoint! !

!TextPrinter class methodsFor: 'accessing' stamp: 'dew 3/7/2000 20:39'!
defaultTextPrinter
	"This is the global default TextPrinter instance."
	DefaultTextPrinter isNil ifTrue: [DefaultTextPrinter _ self new].
	^DefaultTextPrinter! !


!TextPrinter class methodsFor: 'class initialization' stamp: 'ar 4/30/98 18:30'!
initialize
	"TextPrinter initialize"
	self defaultPaperSize: self paperSizeA4.! !


!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:30'!
mm2in: aPoint
	"Convert aPoint from millimeters to inches"
	^aPoint / 25.4! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSize10x14
	^10.0@14.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSize11x17
	^11.0@17.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeA3
	^self mm2in: 297@420! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeA4
	^self mm2in: 210@297! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeA5
	^self mm2in: 148@210! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeB4
	^self mm2in: 250@354! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeB5
	^self mm2in: 182@257! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeCSheet
	^17.0@22.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeDSheet
	^22.0@34.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeESheet
	^34.0@44.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope10
	^4.125@9.5
! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope11
	^4.5@10.375! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope12
	^4.75@11! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope14
	^5.0@11.5! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope9
	^3.875@8.875! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelopeB4
	^self mm2in: 250@353! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelopeB5
	^self mm2in: 176@250! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelopeB6
	^self mm2in: 176@125! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelopeC3
	^self mm2in: 324@458! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeEnvelopeC4
	^self mm2in: 229@324! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeEnvelopeC5
	^self mm2in: 162@229! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeEnvelopeC6
	^self mm2in: 114@162! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeEnvelopeC65
	^self mm2in: 114@229! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeFanfoldGerman
	"German standard fanfold"
	^8.5@12.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeFanfoldLegalGerman
	"German legal fanfold"
	^8.5@13.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeFanfoldUS
	"US standard fanfold"
	^14.875@11.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeFolio
	^8.5@13.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeLegal
	^8.5@14.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeLetter
	^8.5@11.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeNote
	^8.5@11.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:30'!
paperSizeTabloid
	^11.0@17.0! !
GenericPropertiesMorph subclass: #TextPropertiesMorph
	instanceVariableNames: 'activeTextMorph applyToWholeText lastGlobalColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Experimental'!

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 11:41'!
activeEditor

	^self activeTextMorph editor! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 11:41'!
activeTextMorph

	^activeTextMorph! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/21/2001 11:26'!
adjustTargetMargin: aFractionalPoint

	| n |

	n _ (aFractionalPoint * 4) rounded.
	myTarget margins: n.
	self showSliderFeedback: n.
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 11:57'!
applyToWholeText

	^applyToWholeText! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:06'!
changeKernBy: delta

	self changeSelectionAttributeTo: (TextKern kern: delta)! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:05'!
changeSelectionAttributeTo: newAttribute

	self applyToWholeText ifTrue: [self activeEditor selectAll].
	self activeEditor replaceSelectionWith: (
		self activeEditor selection asText addAttribute: newAttribute
	).
	self activeTextMorph updateFromParagraph.! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'md 10/22/2003 15:22'!
changeStyle

	| aList reply style |

	aList _ StrikeFont actualFamilyNames.
	aList addFirst: 'DefaultTextStyle'.
	reply _ (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp.
	reply ifNil: [^self].

	(style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true].
	self applyToWholeText ifTrue: [self activeEditor selectAll].
	self activeEditor changeStyleTo: style copy.
	self activeTextMorph updateFromParagraph.! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/21/2001 11:07'!
changeTargetColorTo: aColor

	self applyToWholeText ifTrue: [
		lastGlobalColor _ aColor
	].
	self changeSelectionAttributeTo: (TextColor color: aColor)! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:07'!
changeToNormalText

	self changeSelectionAttributeTo: (TextEmphasis normal)! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/21/2001 11:06'!
doAccept

	myTarget 
		text: self activeTextMorph contents textStyle: self activeTextMorph textStyle;
		releaseCachedState;
		changed.
	lastGlobalColor ifNotNil: [myTarget textColor: lastGlobalColor].
	super doAccept.! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:00'!
kernMinus

	self changeKernBy: -1! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:01'!
kernPlus

	self changeKernBy: 1! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 12:01'!
offerFontMenu
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.  
	Use only names of Fonts of this paragraph  "

	| aList reply |

	aList _ self activeTextMorph textStyle fontNamesWithPointSizes.
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ifNil: [^self].
	self applyToWholeText ifTrue: [self activeEditor selectAll].
	self activeEditor replaceSelectionWith:
		(Text string: self activeEditor selection asString 
			attribute: (TextFontChange fontNumber: (aList indexOf: reply))).
	self activeTextMorph updateFromParagraph.! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 21:54'!
paneForApplyToWholeText

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #applyToWholeText
			setter: #toggleApplyToWholeText
			help: 'Whether to apply style changes to entire text or just selection' translated.
		self lockedString: ' Apply changes to entire text ' translated.
	}
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 21:54'!
paneForAutoFitToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetHasAutoFit
			setter: #toggleTargetAutoFit
			help: 'Turn auto-fit on or off' translated.
		self lockedString: ' Auto-Fit' translated.
	}
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 21:54'!
paneForMargins

	^(self inARow: {
		self
			buildFakeSlider: 'Margins' translated 
			selector: #adjustTargetMargin:
			help: 'Drag in here to change the margins of the text' translated
	}) hResizing: #shrinkWrap

! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 21:54'!
paneForTextColorPicker

	^self 
		inAColumn: {
			self 
				colorPickerFor: self
				getter: #targetTextColor
				setter: #changeTargetColorTo:.
			self lockedString: 'Text Color' translated.
		} 
		named: #pickerForTextColor.

! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 21:54'!
paneForWrappingToggle

	^self inARow: {
		self
			directToggleButtonFor: self 
			getter: #targetHasWrapping
			setter: #toggleTargetWrapping
			help: 'Turn line wrapping on or off' translated.
		self lockedString: ' Wrapping' translated.
	}
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 21:56'!
rebuild

	| buttonColor c |

	self removeAllMorphs.
	self addAColumn: {
		self lockedString: ('Text Properties for {1}' translated format:{myTarget name}).
	}.
	self addAColumn: {
		self paneForApplyToWholeText.
	}.


	c _ self addAColumn: {
		self activeTextMorph.
	}.
	c 
		wrapCentering: #topLeft;
		color: Color white;
		borderWidth: 2;
		borderColor: color darker.
	self addAColumn: {
		self paneForTextColorPicker.
	}.

	self addARow: {
		self paneForAutoFitToggle.
	}.
	self addARow: {
		self paneForWrappingToggle.
	}.
	self addARow: {
		self paneForMargins.
	}.

	buttonColor _ color lighter.
	self addARow: {
		self inAColumn: {
			self addARow: {
				self 
					buttonNamed: 'Size' translated action: #offerFontMenu color: buttonColor
					help: 'font changing' translated.
				self 
					buttonNamed: 'Style' translated action: #changeStyle color: buttonColor
					help: 'font changing' translated.
				self 
					buttonNamed: 'N' translated action: #changeToNormalText color: buttonColor
					help: 'normal text' translated.
				self 
					buttonNamed: 'B' translated action: #toggleBold color: buttonColor
					help: 'bold text' translated.
				self 
					buttonNamed: 'I' translated action: #toggleItalic color: buttonColor
					help: 'italic text' translated.
				self 
					buttonNamed: 'n' translated action: #toggleNarrow color: buttonColor
					help: 'narrow text' translated.
				self 
					buttonNamed: 'U' translated action: #toggleUnderlined color: buttonColor
					help: 'underlined text' translated.
				self 
					buttonNamed: 'S' translated action: #toggleStruckOut color: buttonColor
					help: 'struck out text' translated.
				self 
					buttonNamed: 'Kern-' translated action: #kernMinus color: buttonColor
					help: 'decrease kern' translated.
				self 
					buttonNamed: 'Kern+' translated action: #kernPlus color: buttonColor
					help: 'increase kern' translated.
			}.
		}.
	}.
	self addARow: {
		self inAColumn: {
			self addARow: {
				self 
					buttonNamed: 'Accept' translated action: #doAccept color: buttonColor
					help: 'keep changes made and close panel' translated.
				self 
					buttonNamed: 'Cancel' translated action: #doCancel color: buttonColor
					help: 'cancel changes made and close panel' translated.
			}.
		}.
	}.
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/21/2001 11:14'!
targetHasAutoFit

	^myTarget isAutoFit
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/21/2001 11:19'!
targetHasWrapping

	^myTarget isWrapped
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:56'!
targetTextColor

	^Color black! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 11:50'!
toggleApplyToWholeText

	applyToWholeText _ applyToWholeText not.
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:16'!
toggleBold

	self toggleSelectionAttribute: TextEmphasis bold! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:16'!
toggleItalic

	self toggleSelectionAttribute: TextEmphasis italic! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:16'!
toggleNarrow

	self toggleSelectionAttribute: TextEmphasis narrow! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:15'!
toggleSelectionAttribute: newAttribute

	| selText oldAttributes |

	self applyToWholeText ifTrue: [self activeEditor selectAll].
	selText _ self activeEditor selection asText.
	oldAttributes _ selText attributesAt: 1 forStyle: self activeTextMorph textStyle.
	oldAttributes do: [:att |
		(att dominates: newAttribute) ifTrue: [newAttribute turnOff]
	].
	self activeEditor replaceSelectionWith: (selText addAttribute: newAttribute).
	self activeTextMorph updateFromParagraph.! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:17'!
toggleStruckOut

	self toggleSelectionAttribute: TextEmphasis struckOut! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/21/2001 11:14'!
toggleTargetAutoFit

	^myTarget autoFitOnOff
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/21/2001 11:16'!
toggleTargetWrapping

	^myTarget wrapOnOff
! !

!TextPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 09:17'!
toggleUnderlined

	self toggleSelectionAttribute: TextEmphasis underlined! !


!TextPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:55'!
defaultBorderColor
"answer the default border color/fill style for the receiver"
	^ self defaultColor darker! !

!TextPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:55'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.355
		g: 0.742
		b: 0.839! !

!TextPropertiesMorph methodsFor: 'initialization' stamp: 'nk 2/12/2004 13:06'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	applyToWholeText _ true.
	myTarget
		ifNil: [""
			myTarget _ TextMorph new openInWorld.
			myTarget contents: ''].

	activeTextMorph _ myTarget copy.
	activeTextMorph extent: 300 @ 100;	 
			 releaseCachedState.
	thingsToRevert
		at: #wrapFlag: put: myTarget isWrapped;
		 at: #autoFit: put: myTarget isAutoFit;
		 at: #margins: put: myTarget margins;
		at: #extent: put: myTarget extent.
	self rebuild! !
Requestor subclass: #TextRequestor
	instanceVariableNames: 'model'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base-Requestors'!
!TextRequestor commentStamp: 'rr 7/10/2006 15:20' prior: 0!
A requestor for text areas, able for example to fetch the current selected text.!


!TextRequestor methodsFor: 'accessing' stamp: 'rr 8/27/2005 15:42'!
model: aModel
	model := WeakArray with: aModel! !


!TextRequestor methodsFor: 'request' stamp: 'rr 8/27/2005 15:42'!
getCurrentText
	"returns the unnacepted text in the text morph" 
	^ self getModel codeTextMorph text! !

!TextRequestor methodsFor: 'request' stamp: 'rr 8/27/2005 15:42'!
getModel
	^ model first! !
TextURL subclass: #TextSqkPageLink
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextSqkPageLink commentStamp: '<historical>' prior: 0!
I represent a link to either a SqueakPage in a BookMorph, or a regular url.  See TextMorphEditor changeEmphasis:.  
!
]style[(81 31 4)f1,f1LTextMorphEditor changeEmphasis:;,f1!


!TextSqkPageLink methodsFor: 'as yet unclassified' stamp: 'tk 1/12/1999 12:56'!
actOnClickFor: textMorph
	"I represent a link to either a SqueakPage in a BookMorph, or a regular url"

	| book |
	((url endsWith: '.bo') or: [url endsWith: '.sp']) ifFalse: [
		^ super actOnClickFor: textMorph].
	book _ textMorph ownerThatIsA: BookMorph.
	book ifNotNil: [book goToPageUrl: url].
	"later handle case of page being in another book, not this one"
	^ true! !

!TextSqkPageLink methodsFor: 'as yet unclassified' stamp: 'tk 1/13/1999 08:14'!
writeScanOn: strm

	strm nextPut: $q; nextPutAll: url; nextPut: $;! !
TextURL subclass: #TextSqkProjectLink
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextSqkProjectLink methodsFor: 'as yet unclassified' stamp: 'RAA 10/19/2000 16:27'!
actOnClickFor: textMorph

	Project enterIfThereOrFind: url.
	^ true! !

!TextSqkProjectLink methodsFor: 'as yet unclassified' stamp: 'RAA 10/19/2000 16:24'!
analyze: aString

	^url _ aString! !

!TextSqkProjectLink methodsFor: 'as yet unclassified' stamp: 'RAA 10/19/2000 16:29'!
writeScanOn: strm

	strm nextPut: $p; nextPutAll: url; nextPut: $;! !
WriteStream subclass: #TextStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

!TextStream methodsFor: 'as yet unclassified'!
applyAttribute: att beginningAt: startPos
	collection addAttribute: att from: startPos to: self position! !

!TextStream methodsFor: 'as yet unclassified' stamp: 'dvf 10/1/2003 02:51'!
nextPutAll: aCollection 
	"Optimized access to get around Text at:Put: overhead"
	| n |
	n _ aCollection size.
     position + n > writeLimit
       ifTrue:
        [self growTo: position + n + 10].
	collection 
		replaceFrom: position+1
		to: position + n
		with: aCollection
		startingAt: 1.
	position _ position + n! !

!TextStream methodsFor: 'as yet unclassified'!
withAttribute: att do: strmBlock
	| pos1 val |
	pos1 _ self position.
	val _ strmBlock value.
	collection addAttribute: att from: pos1+1 to: self position.
	^ val! !

!TextStream methodsFor: 'as yet unclassified' stamp: 'djp 11/6/1999 20:30'!
withAttributes: attributes do: streamBlock 
	| pos1 val |
	pos1 _ self position.
	val _ streamBlock value.
	attributes do: [:attribute |
		collection
			addAttribute: attribute
			from: pos1 + 1
			to: self position].
	^ val! !
WidgetStub subclass: #TextStub
	instanceVariableNames: 'text'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!TextStub methodsFor: 'events' stamp: 'cwp 5/30/2005 23:11'!
eventAccessors
	^ #(setText selection menu color)! !

!TextStub methodsFor: 'events' stamp: 'cwp 5/30/2005 23:10'!
refresh
	self refreshText! !

!TextStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'!
refreshText
	text := self model perform: spec getText! !

!TextStub methodsFor: 'events' stamp: 'cwp 5/30/2005 23:11'!
update: aSymbol
	aSymbol = spec getText ifTrue: [^ self refreshText].
	super update: aSymbol! !


!TextStub methodsFor: 'simulating' stamp: 'cwp 4/22/2005 22:49'!
accept: aString
	^ self model perform: spec setText with: aString asText! !

!TextStub methodsFor: 'simulating' stamp: 'cwp 4/22/2005 22:43'!
color
	^ self model perform: spec color! !

!TextStub methodsFor: 'simulating' stamp: 'cwp 5/30/2005 23:11'!
text
	^ text! !
Object subclass: #TextStyle
	instanceVariableNames: 'fontArray fontFamilySize lineGrid baseline alignment firstIndent restIndent rightIndent tabsArray marginTabsArray leading defaultFontIndex'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Text'!
!TextStyle commentStamp: '<historical>' prior: 0!
A textStyle comprises the formatting information for composing and displaying a unit (usually a paragraph) of text.  Typically one makes a copy of a master textStyle (such as TextStyle default), and then that copy may get altered in the process of editing.  Bad things can happen if you do not copy first.

Each of my instances consists of...
	fontArray		An array of StrikeFonts
	fontFamilySize	unused
	lineGrid			An integer; default line spacing for paragraphs
	baseline			An integer; default baseline (dist from line top to bottom of an 'a')
	alignment		An integer; text alignment, see TextStyle alignment:
	firstIndent		An integer; indent of first line in pixels
	restIndent		An integer; indent of remaining lines in pixels
	rightIndent		An integer; indent of right margin rel to section
	tabsArray		An array of integers giving tab offsets in pixels
	marginTabsArray	An array of margin tabs
	leading			An integer giving default vertical line separation

For a concrete example, look at TextStyle default copy inspect!


!TextStyle methodsFor: 'accessing'!
alignment
	"Answer the code for the current setting of the alignment."

	^alignment! !

!TextStyle methodsFor: 'accessing' stamp: 'ar 9/21/2000 15:17'!
alignment: anInteger 
	"Set the current setting of the alignment to be anInteger:
	0=left flush, 1=right flush, 2=centered, 3=justified."

	alignment _ anInteger \\ (Justified + 1)! !

!TextStyle methodsFor: 'accessing' stamp: 'ar 9/21/2000 15:16'!
alignmentSymbol
	"Answer the symbol for the current setting of the alignment."
	alignment = LeftFlush ifTrue:[^#leftFlush].
	alignment = Centered ifTrue:[^#centered].
	alignment = RightFlush ifTrue:[^#rightFlush].
	alignment = Justified ifTrue:[^#justified].
	^#leftFlush! !

!TextStyle methodsFor: 'accessing'!
baseline
	"Answer the distance from the top of the line to the bottom of most of the 
	characters (by convention, bottom of the letter 'A')."

	^baseline! !

!TextStyle methodsFor: 'accessing'!
baseline: anInteger 
	"Set the distance from the top of the line to the bottom of most of the 
	characters."

	baseline _ anInteger! !

!TextStyle methodsFor: 'accessing'!
centered
	alignment _ 2! !

!TextStyle methodsFor: 'accessing' stamp: 'sw 12/6/1999 12:31'!
defaultFont
	^ fontArray at: self defaultFontIndex! !

!TextStyle methodsFor: 'accessing'!
firstIndent
	"Answer the horizontal indenting of the first line of a paragraph in the 
	style of the receiver."

	^firstIndent! !

!TextStyle methodsFor: 'accessing'!
firstIndent: anInteger 
	"Set the horizontal indenting of the first line of a paragraph in the style 
	of the receiver to be the argument, anInteger."

	firstIndent _ anInteger! !

!TextStyle methodsFor: 'accessing'!
fontNamed: fontName  "TextStyle default fontNamed: 'TimesRoman10'"
	^ fontArray detect: [:x | x name sameAs: fontName]! !

!TextStyle methodsFor: 'accessing'!
fontNames  "TextStyle default fontNames"
	^ fontArray collect: [:x | x name]! !

!TextStyle methodsFor: 'accessing' stamp: 'tk 6/26/1998 15:03'!
fontNamesAndSizes  "TextStyle default fontNames"
	^ fontArray collect: [:x | x name, ' ', x height printString]! !

!TextStyle methodsFor: 'accessing' stamp: 'ar 9/21/2000 11:53'!
fontNamesWithPointSizes
	^ fontArray collect:
		[:x | x fontNameWithPointSize]

  "TextStyle default fontNamesWithPointSizes"! !

!TextStyle methodsFor: 'accessing' stamp: 'ar 12/16/2001 16:58'!
fonts
	"Return a collection of fonts contained in this text style"
	^fontArray! !

!TextStyle methodsFor: 'accessing' stamp: 'nk 6/25/2003 12:54'!
isTTCStyle

	^ fontArray first isTTCFont.
! !

!TextStyle methodsFor: 'accessing'!
justified
	alignment _ 3! !

!TextStyle methodsFor: 'accessing'!
leading
	"Leading (from typographers historical use of extra lead (type metal))
	is the extra spacing above and beyond that needed just to accomodate
	the various font heights in the set."
	^ leading! !

!TextStyle methodsFor: 'accessing'!
leading: yDelta

	leading _ yDelta! !

!TextStyle methodsFor: 'accessing'!
leftFlush
	alignment _ 0! !

!TextStyle methodsFor: 'accessing'!
lineGrid
	"Answer the relative space between lines of a paragraph in the style of 
	the receiver."

	^lineGrid! !

!TextStyle methodsFor: 'accessing'!
lineGrid: anInteger 
	"Set the relative space between lines of a paragraph in the style of the 
	receiver to be the argument, anInteger."

	lineGrid _ anInteger! !

!TextStyle methodsFor: 'accessing' stamp: 'ar 12/16/2001 16:43'!
pointSizes
	^ fontArray collect:
		[:x | x pointSize]

  "TextStyle default fontNamesWithPointSizes"! !

!TextStyle methodsFor: 'accessing' stamp: 'yo 5/24/2004 22:52'!
printOn: aStream

	super printOn: aStream.
	(fontArray first isMemberOf: StrikeFontSet) ifTrue: [
		aStream space; nextPutAll: self defaultFont familySizeFace first; nextPutAll: '(FontSet)'
	] ifFalse: [
		aStream space; nextPutAll: self defaultFont familySizeFace first
	]
! !

!TextStyle methodsFor: 'accessing'!
restIndent
	"Answer the indent for all but the first line of a paragraph in the style 
	of the receiver."

	^restIndent! !

!TextStyle methodsFor: 'accessing'!
restIndent: anInteger 
	"Set the indent for all but the first line of a paragraph in the style of the 
	receiver to be the argument, anInteger."

	restIndent _ anInteger! !

!TextStyle methodsFor: 'accessing'!
rightFlush
	alignment _ 1! !

!TextStyle methodsFor: 'accessing'!
rightIndent
	"Answer the right margin indent for the lines of a paragraph in the style 
	of the receiver."

	^rightIndent! !

!TextStyle methodsFor: 'accessing'!
rightIndent: anInteger 
	"Answer the right margin indent for the lines of a paragraph in the style 
	of the receiver to be the argument, anInteger."

	rightIndent _ anInteger! !


!TextStyle methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:18'!
= other

	self species == other species ifFalse: [^ false].
	1 to: self class instSize do:
		[:i | (self instVarAt: i) == (other instVarAt: i) ifFalse: [^ false]].
	^ true! !

!TextStyle methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:04'!
hash
	"#hash is re-implemented because #= is re-implemented"
	^fontArray hash
! !

!TextStyle methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:18'!
species

	^TextStyle! !


!TextStyle methodsFor: 'Disk I/O' stamp: 'tk 9/25/2000 10:10'!
storeDataOn: aDataStream
	"The shared arrays in tabsArray and marginTabsArray are the globals DefaultTabsArray and DefaultMarginTabsArray.  DiskProxies will be substituted for these in (Array objectForDataStream:)."

	^ super storeDataOn: aDataStream! !

!TextStyle methodsFor: 'Disk I/O' stamp: 'di 11/19/1999 20:12'!
veryDeepCopyWith: deepCopier
	"All inst vars are meant to be shared"

	self == #veryDeepCopyWith:.	"to satisfy checkVariables"
	^ deepCopier references at: self ifAbsent: [
		deepCopier references at: self put: self clone].	"remember"! !


!TextStyle methodsFor: 'default font' stamp: 'sw 12/6/1999 12:30'!
defaultFontIndex
	^ defaultFontIndex ifNil: [defaultFontIndex _ 1]! !

!TextStyle methodsFor: 'default font' stamp: 'sw 12/6/1999 13:50'!
defaultFontIndex: anIndex
	defaultFontIndex _ anIndex! !


!TextStyle methodsFor: 'fonts and font indexes' stamp: 'yo 5/7/2004 11:18'!
addLinedIfTT

	(fontArray first isKindOf: TTCFont) ifFalse: [^ self].

	fontArray do: [:f |
		f addLined.
	].
! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'yo 3/17/2005 11:10'!
addNewFontSize: pointSize
	"Add a font in specified size to the array of fonts."
	| f d newArray t isSet fallbackStyle |
	fontArray first emphasis ~= 0 ifTrue: [
		t _ TextConstants at: self fontArray first familyName asSymbol.
		t fonts first emphasis = 0 ifTrue: [
			^ t addNewFontSize: pointSize.
		].
	].

	pointSize <= 0 ifTrue: [^ nil].
	fontArray do: [:s |
		s pointSize = pointSize ifTrue: [^ s].
	].

	(isSet _ fontArray first isKindOf: TTCFontSet) 
	ifTrue:[
		| fonts |
		fonts _ fontArray first fontArray collect: [ :font |
			| newFont |
			(font isNil)
			ifTrue: [newFont _ nil]
			ifFalse: [
				newFont _ (font ttcDescription size > 256)
					ifTrue: [MultiTTCFont new initialize]
					ifFalse: [TTCFont new initialize].
				newFont ttcDescription: font ttcDescription.
				newFont pixelSize: pointSize * 96 // 72.
				font derivativeFonts notEmpty ifTrue: [font derivativeFonts do: [ :proto |
					proto ifNotNil: [
						d _ proto class new initialize.
						d ttcDescription: proto ttcDescription.
						d pixelSize: newFont pixelSize.
						newFont derivativeFont: d]]].
				].
			newFont].
		f _ TTCFontSet newFontArray: fonts]
	ifFalse: [
		f _ TTCFont new initialize.
		f ttcDescription: fontArray first ttcDescription.
		f pointSize: pointSize.
		fontArray first derivativeFonts do: [:proto |
			proto ifNotNil: [
				d _ TTCFont new initialize.
				d ttcDescription: proto ttcDescription.
				d pointSize: f pointSize.
				f derivativeFont: d.
			].
		].
	].
	isSet ifFalse: [
		fallbackStyle _ TextStyle named: (fontArray first fallbackFont textStyleName).
	].
	newArray _ ((fontArray copyWith: f) asSortedCollection: [:a :b | a pointSize <= b pointSize]) asArray.
	self newFontArray: newArray.
	isSet ifTrue: [
		TTCFontSet register: newArray at: newArray first familyName asSymbol.
	].
	isSet ifFalse: [
		f setupDefaultFallbackFontTo: fallbackStyle.
		f derivativeFonts do: [:g | g setupDefaultFallbackFontTo: fallbackStyle].
	].
	^ self fontOfPointSize: pointSize
! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'rbb 3/1/2005 11:18'!
addNewFontSizeDialog: args
	"This is called from a modal menu and call back the menu with entered argument."
	| f n r |
	f := UIManager default request: 'Enter the point size' initialAnswer: '12'.
	n := f asNumber.
	r := self addNewFontSize: n.
	r ifNotNil: [
		args second ifNotNil: [args second modalSelection: {args first. n}].
	].
! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'tk 3/5/2002 09:57'!
collectionFromFileNamed: fileName
	"Read the file.  It is an TextStyle whose StrikeFonts are to be added to the system.  (Written by fooling SmartRefStream, so it won't write a DiskProxy!!)  These fonts will be added to the master TextSytle for this font family.  
	To write out fonts: 
		| ff | ff _ ReferenceStream fileNamed: 'new fonts'.
		TextConstants at: #forceFontWriting put: true.
		ff nextPut: (TextConstants at: #AFontName).
			'do not mix font families in the TextStyle written out'.
		TextConstants at: #forceFontWriting put: false.
		ff close.

	To read: (TextStyle default collectionFromFileNamed: 'new fonts')
*** Do not remove this method *** "

	| ff this newName style heights |
	ff _ ReferenceStream fileNamed: fileName.
	this _ ff nextAndClose.	"Only works if file created by special code above"
	newName _ this fontArray first familyName.
	this fontArray do: [:aFont | aFont familyName = newName ifFalse: [
		self error: 'All must be same family']].
	style _ TextConstants at: newName asSymbol ifAbsent: [
		^ TextConstants at: newName asSymbol put: this].		"new family"
	this fontArray do: [:aFont | "add new fonts"
		heights _ style fontArray collect: [:bFont | bFont height].
		(heights includes: aFont height) ifFalse: [
			style fontAt: style fontArray size + 1 put: aFont]].
! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 12/8/1999 18:02'!
consistOnlyOf: aFont
	fontArray _ Array with: aFont.
	defaultFontIndex _ 1! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'yo 6/23/2003 19:58'!
discardOtherSizes
	"This method trys to discard the fonts in non-standard size.  If the size is still in use, there will be a problem."
	| newArray |
	self isTTCStyle ifFalse: [^ self].
	newArray _ fontArray select: [:s | TTCFont pointSizes includes: s pointSize].
	self newFontArray: newArray.

"(TextConstants at: #ComicSansMS) discardOtherSizes"! !

!TextStyle methodsFor: 'fonts and font indexes'!
flushFonts
	"Clean out the fonts, an aid when snapshotting claims too many are 
	holding onto Display."

	(self confirm: 
'flushFonts is very dangerous.
Are you foolish or clever enough to proceed?')
		ifTrue: [1 to: fontArray size do: [:index | fontArray at: index put: nil]]
		ifFalse: [Transcript cr; show: 'flushFonts cancelled']

	"TextStyle default flushFonts"! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 12/6/1999 13:54'!
fontIndexOf: aFont
	^ fontArray indexOf: aFont ifAbsent: [nil]! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'nk 6/12/2004 16:31'!
fontIndexOfPointSize: desiredPointSize
	"Returns an index in fontArray of the font with pointSize <= desiredPointSize"
	"Leading is not inluded in the comparison"
	| bestMatch bestIndex d |
	bestMatch _ 9999.  bestIndex _ 1.
	1 to: fontArray size do:
		[:i | d _ desiredPointSize - (fontArray at: i) pointSize.
		d = 0 ifTrue: [^ i].
		(d > 0 and: [d < bestMatch]) ifTrue: [bestIndex _ i. bestMatch _ d]].
	^ bestIndex! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'di 10/11/97 09:23'!
fontIndexOfSize: desiredHeight
	"Returns an index in fontArray of the font with height <= desiredHeight"
	"Leading is not inluded in the comparison"
	| bestMatch bestIndex d |
	bestMatch _ 9999.  bestIndex _ 1.
	1 to: fontArray size do:
		[:i | d _ desiredHeight - (fontArray at: i) height.
		d = 0 ifTrue: [^ i].
		(d > 0 and: [d < bestMatch]) ifTrue: [bestIndex _ i. bestMatch _ d]].
	^ bestIndex! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'nk 6/12/2004 16:33'!
fontOfPointSize: aPointSize
	^ fontArray at: (self fontIndexOfPointSize: aPointSize)! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'di 10/11/97 09:33'!
fontOfSize: aHeight
	"See fontIndexOfSize.
	Returns the actual font.  Leading not considered."

	^ fontArray at: (self fontIndexOfSize: aHeight)! !


!TextStyle methodsFor: 'make arrows' stamp: 'sps 10/15/2003 17:09'!
makeArrows
"
TextStyle default makeArrows.
"
	fontArray do: [ :font |
		(font isKindOf: StrikeFont) ifTrue:[ 
			font 
				makeAssignArrow; 
				makeReturnArrow.
		]
	].
! !


!TextStyle methodsFor: 'mime file in/out' stamp: 'nk 8/31/2004 09:23'!
compressedMIMEEncodedStream
	"Answer a ReadWriteStream with my compressed, stored representation as Base64"

	| s ff ffcontents s2 gzs |
	self fontArray do: [:f | f releaseCachedState].
	s := RWBinaryOrTextStream on: ''.
	ff := SmartRefStream on: s reset.
	TextConstants at: #forceFontWriting put: true.
	[ff nextPut: self] 
		ensure: [TextConstants at: #forceFontWriting put: false].
	ffcontents := s contents.
	ff close.
	s2 := RWBinaryOrTextStream on: ''.
	gzs := GZipWriteStream on: s2.
	gzs nextPutAll: ffcontents.
	gzs close.
	s2 reset.
	s := RWBinaryOrTextStream on: (ByteArray new: 10000).
	Base64MimeConverter mimeEncode: s2 to: s.
	^s
		ascii;
		reset;
		yourself! !


!TextStyle methodsFor: 'tabs and margins'!
clearIndents
	"Reset all the margin (index) settings to be 0."

	self firstIndent: 0.
	self restIndent: 0.
	self rightIndent: 0! !

!TextStyle methodsFor: 'tabs and margins'!
leftMarginTabAt: marginIndex 
	"Set the 'nesting' level of left margin indents of the paragraph in the 
	style of the receiver to be the argument, marginIndex."

	(marginIndex > 0 and: [marginIndex < marginTabsArray size])
		ifTrue: [^(marginTabsArray at: marginIndex) at: 1]
		ifFalse: [^0]	
	"The marginTabsArray is an Array of tuples.  The Array is indexed according 
	to the marginIndex, the 'nesting' level of the requestor."
! !

!TextStyle methodsFor: 'tabs and margins'!
nextTabXFrom: anX leftMargin: leftMargin rightMargin: rightMargin 
	"Tab stops are distances from the left margin. Set the distance into the 
	argument, anX, normalized for the paragraph's left margin."

	| normalizedX tabX |
	normalizedX _ anX - leftMargin.
	1 to: tabsArray size do: 
		[:i | (tabX _ tabsArray at: i) > normalizedX 
				ifTrue: [^leftMargin + tabX min: rightMargin]].
	^rightMargin! !

!TextStyle methodsFor: 'tabs and margins'!
rightMarginTabAt: marginIndex 
	"Set the 'nesting' level of right margin indents of the paragraph in the 
	style of the receiver to be marginIndex."

	(marginIndex > 0 and: [marginIndex < marginTabsArray size])
		ifTrue: [^(marginTabsArray at: marginIndex) at: 2]
		ifFalse: [^0]
	"The marginTabsArray is an Array of tuples.  The Array is indexed according 
	to the marginIndex, the 'nesting' level of the requestor."
! !

!TextStyle methodsFor: 'tabs and margins'!
tabWidth
	"Answer the width of a tab."

	^DefaultTab! !


!TextStyle methodsFor: 'private'!
consolidate
	"If this style includes any fonts that are also in the default style,
	then replace them with references to the default ones."
"
	TextStyle allInstancesDo: [:s | s == TextStyle default ifFalse: [s consolidate]]
"
	| defFonts font |
	defFonts _ TextStyle default fontArray.
	1 to: fontArray size do:
		[:i | font _ fontArray at: i.
		1 to: defFonts size do:
			[:j | (font name asUppercase copyWithout: $ )
			= ((defFonts at: j) name asUppercase copyWithout: $ )
			ifTrue: [fontArray at: i put: (defFonts at: j)]]]! !

!TextStyle methodsFor: 'private'!
fontArray
	"Only for writing out fonts, etc.  8/16/96 tk"
	^ fontArray! !

!TextStyle methodsFor: 'private' stamp: 'di 3/20/1999 22:31'!
fontAt: index 
	"This is private because no object outside TextStyle should depend on the 
	representation of the font family in fontArray."

	^ fontArray atPin: index! !

!TextStyle methodsFor: 'private'!
fontAt: index put: font
	"Automatically grow the array.  8/20/96 tk"
	index > fontArray size ifTrue: [
		fontArray _ fontArray, (Array new: index - fontArray size)].
	fontArray at: index put: font! !

!TextStyle methodsFor: 'private'!
gridForFont: fontIndex withLead: leadInteger 
	"Force whole style to suit one of its fonts. Assumes only one font referred
	to by runs."
	| font |
	font _ self fontAt: fontIndex.
	self lineGrid: font height + leadInteger.
	self baseline: font ascent.
	self leading: leadInteger! !

!TextStyle methodsFor: 'private'!
marginTabAt: marginIndex side: sideIndex 
	"The marginTabsArray is an Array of tuples.  The Array is indexed
	according to the marginIndex, the 'nesting' level of the requestor.
	sideIndex is 1 for left, 2 for right."

	(marginIndex > 0 and: [marginIndex < marginTabsArray size])
		ifTrue: [^(marginTabsArray at: marginIndex) at: sideIndex]
		ifFalse: [^0]! !

!TextStyle methodsFor: 'private' stamp: 'tk 8/20/96'!
newFontArray: anArray
	"Currently there is no supporting protocol for changing these arrays. If an editor wishes to implement margin setting, then a copy of the default should be stored with these instance variables.  
	, Make size depend on first font."

	fontArray _ anArray.
	lineGrid _ (fontArray at: 1) height + leading.	"For whole family"
	baseline _ (fontArray at: 1) ascent + leading.
	alignment _ 0.
	firstIndent _ 0.
	restIndent _ 0.
	rightIndent _ 0.
	tabsArray _ DefaultTabsArray.
	marginTabsArray _ DefaultMarginTabsArray
"
TextStyle allInstancesDo: [:ts | ts newFontArray: TextStyle default fontArray].
"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextStyle class
	instanceVariableNames: ''!

!TextStyle class methodsFor: 'class initialization' stamp: 'nk 3/25/2004 17:51'!
initialize
	self initializeStyleDecoder.! !

!TextStyle class methodsFor: 'class initialization' stamp: 'nk 3/25/2004 17:53'!
initializeStyleDecoder
	TextConstants at: #StyleDecoder put: nil.
	self styleDecoder.! !

!TextStyle class methodsFor: 'class initialization' stamp: 'nk 3/25/2004 17:57'!
styleDecoder
	TextConstants at: #StyleDecoder ifPresent: [ :dict | dict ifNotNil: [ ^dict ]].
	^TextConstants at: #StyleDecoder put: (
		Dictionary new at: 'Regular' put: 0;
				 at: 'Roman' put: 0;
				 at: 'Medium' put: 0;
				 at: 'Light' put: 0;
				 at: 'Normal' put: 0;
				 at: 'Plain' put: 0;
				 at: 'Book' put: 0;
				 at: 'Demi' put: 0;
				 at: 'Demibold' put: 0;
				 at: 'Semibold' put: 0;
				 at: 'SemiBold' put: 0;
				 at: 'ExtraBold' put: 1;
				 at: 'SuperBold' put: 1;
				 at: 'B' put: 1;
				 at: 'I' put: 2;
				 at: 'U' put: 4;
				 at: 'X' put: 16;
				 at: 'N' put: 8;
				 at: 'Bold' put: 1;
				 at: 'Italic' put: 2;
				 at: 'Oblique' put: 2;
				 at: 'Narrow' put: 8;
				 at: 'Condensed' put: 8;
				 at: 'Underlined' put: 4;
				 yourself )! !


!TextStyle class methodsFor: 'constants'!
default
	"Answer the system default text style."

	^DefaultTextStyle! !

!TextStyle class methodsFor: 'constants' stamp: 'sw 12/6/1999 12:32'!
defaultFont
	"Answer the default system font"

	^ DefaultTextStyle defaultFont! !

!TextStyle class methodsFor: 'constants' stamp: 'nk 7/3/2003 19:11'!
named: familyName
	"Answer the TextStyle with the given name, or nil."
	"TextStyle named: 'NewYork'"
	| textStyle |
	textStyle _ TextConstants at: familyName ifAbsent: [ ^nil ].
	(textStyle isKindOf: self) ifFalse: [ ^nil ].
	^textStyle! !

!TextStyle class methodsFor: 'constants' stamp: 'ar 1/27/2002 20:36'!
setDefault: aTextStyle
	"Answer the system default text style."

	DefaultTextStyle := aTextStyle.! !


!TextStyle class methodsFor: 'instance creation' stamp: 'rbb 2/18/2005 13:18'!
changeDefaultFontSizeBy: delta      "TextStyle changeDefaultFontSizeBy: 1"
	"This sample method recreates the default textStyle, with font 1 being a size
	larger than the smallest.  It then initializes most references in the system
	as well, although most windows will have to beclosed and reopened to get the effect."
	| allFonts |
	allFonts _ TextStyle default fontArray asSortedCollection: [:a :b | a height < b height].
	TextConstants at: #DefaultTextStyle put:
		(TextStyle fontArray: ((1 to: allFonts size) collect: [:i | allFonts atWrap: i+delta])).
	"rbb 2/18/2005 13:18 - How should this work for UIManager?"
	PopUpMenu initialize.  "Change this method for difft menu font"
	ListParagraph initialize.  "Change this method for difft ListPane font"
	StandardSystemView initialize.  "Change this method for difft Window label font"
! !

!TextStyle class methodsFor: 'instance creation'!
fontArray: anArray 
	"Answer an instance of me with fonts those in the argument, anArray."

	^self new newFontArray: anArray! !

!TextStyle class methodsFor: 'instance creation'!
initDefaultFontsAndStyle
	"This provides the system with 10 and 12-pt basal fonts.
	Bold and italic versions will be automatically generated as needed"
	| fontArray |	
	fontArray _ Array new: 2.
	fontArray at: 1 put: (StrikeFont new readFromStrike2: 'NewYork10.sf2').
	fontArray at: 2 put: (StrikeFont new readFromStrike2: 'NewYork12.sf2').
	TextConstants at: #DefaultTextStyle put:
		(TextStyle fontArray: fontArray).

	"TextStyle initDefaultFontsAndStyle."! !

!TextStyle class methodsFor: 'instance creation'!
new
	^ super new leading: 2! !


!TextStyle class methodsFor: 'mime file in/out' stamp: 'nk 1/19/2004 20:36'!
collectionFromCompressedMIMEString: aString
	"aString holds a compressed, Base64 representation of a SmartRefStream storage of a TextStyle.
	Install the TextStyle."

	| this newName style heights data |
	data := (Base64MimeConverter mimeDecode: aString as: String) unzipped.
	(RWBinaryOrTextStream with: data) reset; fileIn.
	this := SmartRefStream scannedObject.

	"now install it"

	newName _ this fontArray first familyName.
	this fontArray do: [:aFont | aFont familyName = newName ifFalse: [
		self error: 'All must be same family']].
	style _ TextConstants at: newName asSymbol ifAbsent: [
		^ TextConstants at: newName asSymbol put: this].		"new family"
	this fontArray do: [:aFont | "add new fonts"
		heights _ style fontArray collect: [:bFont | bFont height].
		(heights includes: aFont height) ifFalse: [
			style fontAt: style fontArray size + 1 put: aFont]].
! !

!TextStyle class methodsFor: 'mime file in/out' stamp: 'nk 3/15/2004 19:37'!
looseFontsFromFamily: familyName
	"
	TextStyle looseFontsFromFamily: 'Accuny'
	TextStyle looseFontsFromFamily: 'Accujen'
	TextStyle actualTextStyles keys collect: [ :k | TextStyle looseFontsFromFamily: k ]
	"

	| looseFonts realStyle classes |
	realStyle _ TextStyle named: familyName.
	classes _ ((realStyle fontArray copyWithout: nil) collect: [ :f | f class ]) asSet.
	classes do: [ :cls | cls allSubInstancesDo: [ :f | f releaseCachedState ]].
	Smalltalk garbageCollect.
	looseFonts _ IdentitySet new.
	classes do: [ :cls |
		looseFonts addAll: ((cls allSubInstances select: [ :ea | ea familyName = familyName ])
			reject: [ :f | realStyle fontArray anySatisfy: [ :fn | fn == f or: [ fn derivativeFonts includes: f ] ]]) ].
	^looseFonts! !

!TextStyle class methodsFor: 'mime file in/out' stamp: 'nk 3/15/2004 19:25'!
replaceFontsIn: oldFontArray with: newStyle
	"
	TextStyle replaceFontsIn: (TextStyle looseFontsFromFamily: #Accuny) with: (TextStyle named: #Accuny)
	"
	"Try to find corresponding fonts in newStyle and substitute them for the fonts in oldFontArray"

	newStyle fontArray do: [ :newFont | newFont releaseCachedState ].

	oldFontArray do: [ :oldFont | | newFont |
		oldFont reset.
		newFont _ (newStyle fontOfPointSize: oldFont pointSize) emphasis: oldFont emphasis.
		oldFont becomeForward: newFont ].

	StringMorph allSubInstancesDo: [ :s | s layoutChanged ].
	TextMorph allSubInstancesDo: [ :s | s layoutChanged ].
	SystemWindow allInstancesDo: [ :w | [ w update: #relabel ] on: Error do: [ :ex | ] ].
	World ifNotNilDo: [ :w | w changed ].! !

!TextStyle class methodsFor: 'mime file in/out' stamp: 'nk 9/1/2004 11:03'!
replaceStyle: oldStyle with: newStyle
	"
	TextStyle replaceStyle: (TextStyle named: #AccunyOLD) with: (TextStyle named: #Accuny)
	"
	"Try to find corresponding fonts in newStyle and substitute the fonts in oldStyle for them."
	| oldKeys |
	oldKeys _ Set new.
	TextConstants keysAndValuesDo: [ :k :v | v = oldStyle ifTrue: [ oldKeys add: k ]].
	oldKeys removeAllFoundIn: self defaultFamilyNames.

	self replaceFontsIn: oldStyle fontArray with: newStyle.

	oldStyle becomeForward: newStyle.
	oldKeys do: [ :k | TextConstants removeKey: k ].
! !

!TextStyle class methodsFor: 'mime file in/out' stamp: 'tpr 6/10/2005 18:29'!
writeSF2FamilyNamed: familyName inDirectory: directoryName toChangeSet: csName 
	"
	TextStyle writeSF2FamilyNamed: 'Accuny' inDirectory: 'AccunyCorrectedFeb252004Beta Folder' toChangeSet: 'AccunyInstall'.
	"

	|  family |
	family := OrderedCollection new.
	family addAll: (StrikeFont readStrikeFont2Family: familyName fromDirectory: (FileDirectory default fullNameFor: directoryName)) .
	family do: [:f | f reset].
	self 
		writeStyle: (TextStyle fontArray: family asArray)
		named: familyName
		toChangeSet: csName! !

!TextStyle class methodsFor: 'mime file in/out' stamp: 'nk 3/15/2004 19:46'!
writeStyle: aTextStyle named: familyName toChangeSet: csName
	"Write the text style to a change set, with a postscript that will re-load it.
	NOTE: to do TTCFonts, you have to have a working ShortPointArray endianness conversion."
	"
	TTCFont recreateCache.
	TextStyle writeStyle: (TextStyle named: #Arial) named: 'Arial' toChangeSet: 'ArialInstall'.
	
	TextStyle writeStyle: (TextStyle named: #Accuny) named: 'Accuny' toChangeSet: 'AccunyInstall2'.
	"

	| cs mimeStream |

	cs _ ChangeSet basicNewNamed: csName.
	cs adoptSelector: #collectionFromCompressedMIMEString: forClass: self class.
	cs adoptSelector: #replaceStyle:with: forClass: self class.
	cs adoptSelector: #replaceFontsIn:with: forClass: self class.
	cs adoptSelector: #looseFontsFromFamily: forClass: self class.
	((aTextStyle fontArray copyWithout: nil) collect: [ :f | f class ]) asSet do: [ :cls  | 
		cs adoptSelector: #derivativeFonts forClass: cls.
		cs adoptSelector: #releaseCachedState forClass: cls ].

	cs preambleString: (String streamContents: [ :s |
		s nextPutAll: '"Change Set:		'; nextPutAll: csName; cr;
		nextPutAll: 'Date:		'; print: Date today; cr;
		nextPutAll: 'Author:		'; nextPutAll: Utilities authorName; cr; cr;
		nextPutAll: 'Installs the text style '''; nextPutAll: familyName; nextPutAll: ''''; cr;
		nextPutAll: 'from a compressed MIME encoding in the postscript."'; cr. ]).

	mimeStream _ aTextStyle compressedMIMEEncodedStream.

	cs postscriptString: (String streamContents: [ :s | s
		nextPutAll: '"Postscript:'; cr;
		nextPutAll: 'Install the text style from the compressed MIME encoding, and replace the old one.';
		nextPut: $"; cr;
		nextPutAll: 'TextConstants at: #';
		nextPutAll: familyName;
		nextPutAll: ' ifPresent: [ :oldStyle | TextConstants at: #';
		nextPutAll: familyName;
		nextPutAll: 'OLD put: oldStyle. TextConstants removeKey: #';
		nextPutAll: familyName;
		nextPutAll: ' ].';
		cr;
		nextPutAll: 'TextStyle collectionFromCompressedMIMEString: ';
		cr;
		print: mimeStream contents;
		nextPut: $.; cr; cr;
		nextPutAll: 'TextConstants at: #';
		nextPutAll: familyName;
		nextPutAll: 'OLD ifPresent: [ :oldStyle | TextStyle replaceStyle: oldStyle with: (TextStyle named: ''';
		nextPutAll: familyName;
		nextPutAll: ''') ].';
		cr;
		nextPutAll: 'TextStyle replaceFontsIn: (TextStyle looseFontsFromFamily: ''';
		nextPutAll: familyName;
		nextPutAll: ''') with: (TextStyle named: ''';
		nextPutAll: familyName;
		nextPutAll: ''').';		
		cr ]).

	cs fileOut.

! !


!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 9/1/2004 11:00'!
actualTextStyles
	| aDict |
	"TextStyle actualTextStyles"

	"Answer dictionary whose keys are the names of styles in the system and whose values are the actual styles"

	aDict _ TextConstants select: [:thang | thang isKindOf: self ].
	self defaultFamilyNames do: [ :sym | aDict removeKey: sym ].
	^ aDict! !

!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 9/1/2004 10:59'!
defaultFamilyNames
	^#(DefaultTextStyle DefaultFixedTextStyle DefaultMultiStyle)! !

!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 7/3/2003 19:06'!
fontArrayForStyle: aName
	"Answer the fonts in the style named aName,
	or an empty Array if no such named style."

	"TextStyle fontArrayForStyle: #Atlanta"
	"TextStyle fontPointSizesFor: 'NewYork'"

	^ ((self named: aName) ifNil: [ ^#() ]) fontArray
! !

!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 7/3/2003 18:56'!
fontPointSizesFor: aName
	"Answer the point sizes for all the fonts in the given text style"

	"TextStyle fontPointSizesFor: 'Arial'"
	"TextStyle fontPointSizesFor: 'NewYork'"

	^ (self fontArrayForStyle: aName) collect: [:f | f pointSize]
! !

!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 7/3/2003 18:58'!
fontSizesFor: aName
	"Answer the pixel sizes for all the fonts in the given text style"

	"TextStyle fontSizesFor: 'Arial'"
	"TextStyle fontSizesFor: 'NewYork'"

	^ (self fontArrayForStyle: aName) collect: [:f | f height ]
! !

!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 7/3/2003 18:58'!
fontWidthsFor: aName
	"Answer the widths for all the fonts in the given text style"

	"TextStyle fontWidthsFor: 'ComicPlain'"
	^ (self fontArrayForStyle: aName) collect: [:f | f maxWidth]
! !

!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 7/3/2003 19:00'!
knownTextStyles
	"Answer the names of the known text styles, sorted in alphabetical order"

	"TextStyle knownTextStyles"
	^ (TextConstants select: [:thang | thang isKindOf: TextStyle]) keys asSortedArray

! !

!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 9/1/2004 11:08'!
knownTextStylesWithoutDefault
	"Answer the names of the known text styles, sorted in alphabetical order without default"

	"TextStyle knownTextStylesWithoutDefault"
	| result |
	result := self knownTextStyles asOrderedCollection.
	^ result copyWithoutAll: self defaultFamilyNames

! !

!TextStyle class methodsFor: 'TextConstants access' stamp: 'nk 7/3/2003 19:11'!
pointSizesFor: aName
	"Answer all the point sizes for the given text style name"

	"TextStyle pointSizesFor: 'NewYork'"
	^ (self fontArrayForStyle: aName) collect: [:f | f pointSize]
! !


!TextStyle class methodsFor: 'user interface' stamp: 'rbb 3/1/2005 11:18'!
chooseTTCFontSize: args
	"Prompt for a point size and, if one is given, add a new font size to the font named by the first member of args. If args' length is three, send a message with the selector equal to the third of args, and the receiver equal to the second of args, passing the selected style as an argument."

	| f n style |
	f := UIManager default request: 'New Point Size' initialAnswer: '0'.
	n := f asNumber.
	style := (TextConstants at: args first) addNewFontSize: n.
	style ifNotNil: [
		args second ifNotNil: [args second perform: args third with: style].
	].
! !

!TextStyle class methodsFor: 'user interface' stamp: 'nk 9/1/2004 13:18'!
emphasisMenuForFont: font target: target selector: selector highlight: currentEmphasis
	"Offer a font emphasis menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font.
	Answer nil if no derivatives exist.
	"

 	| aMenu derivs |
	derivs := font derivativeFonts.
	derivs isEmpty ifTrue: [ ^nil ].
	aMenu _ MenuMorph entitled: 'emphasis' translated.
	derivs := derivs asOrderedCollection.
	derivs addFirst: font.
	derivs do: [ :df | 
			aMenu 
				add: (AbstractFont emphasisStringFor: df emphasis)
				target: target 
				selector: selector
				argument: df.
                aMenu lastItem font: df.
                df emphasis == currentEmphasis ifTrue: [aMenu lastItem color: Color blue darker]].
        ^ aMenu! !

!TextStyle class methodsFor: 'user interface' stamp: 'laza 3/25/2004 23:12'!
fontMenuForStyle: styleName target: target selector: selector
	^self fontMenuForStyle: styleName target: target selector: selector highlight: nil! !

!TextStyle class methodsFor: 'user interface' stamp: 'nk 9/1/2004 13:31'!
fontMenuForStyle: styleName target: target selector: selector highlight: currentFont 
	"Offer a font menu for the given style. If one is selected, pass 
	that font to target with a  
	call to selector. The fonts will be displayed in that font."
	| aMenu |
	aMenu := MenuMorph entitled: styleName.
	(TextStyle named: styleName)
		ifNotNilDo: [:s | s isTTCStyle
				ifTrue: [aMenu
						add: 'New Size'
						target: self
						selector: #chooseTTCFontSize:
						argument: {styleName. target. selector}]].
	(self pointSizesFor: styleName)
		do: [:pointSize | 
			| font subMenu | 
			font := (self named: styleName)
						fontOfPointSize: pointSize.
			subMenu := self
						emphasisMenuForFont: font
						target: target
						selector: selector
						highlight: (currentFont
								ifNotNilDo: [:cf | (cf familyName = styleName
											and: [cf pointSize = font pointSize])
										ifTrue: [currentFont emphasis]]).
			subMenu
				ifNil: [aMenu
						add: pointSize asString , ' Point'
						target: target
						selector: selector
						argument: font]
				ifNotNil: [aMenu add: pointSize asString , ' Point' subMenu: subMenu].
			aMenu lastItem font: font.
			currentFont
				ifNotNilDo: [:cf | (cf familyName = styleName
							and: [cf pointSize = font pointSize])
						ifTrue: [aMenu lastItem color: Color blue darker]]].
	^ aMenu! !

!TextStyle class methodsFor: 'user interface' stamp: 'dgd 10/8/2003 18:38'!
fontSizeSummary
	"Open a text window with a simple summary of the available sizes in each of the fonts in the system."

	"TextStyle fontSizeSummary"
	| aString aList |
	aList _ self knownTextStyles.
	aString _ String streamContents:
		[:aStream |
			aList do: [:aStyleName |
				aStream nextPutAll:
					aStyleName, '  ',
					(self fontPointSizesFor: aStyleName) asArray storeString.
				aStream cr]].
	(StringHolder new contents: aString)
		openLabel: 'Font styles and sizes' translated! !

!TextStyle class methodsFor: 'user interface' stamp: 'sw 8/12/2004 19:08'!
importFontsFromStyleFiles
	"Import any and all of the fonts found in the default directory in files named ComicBold.style, ComicPlain.style, NewYork.style, Palatino.style, Courier.style"

	| aName |
	#('ComicBold' 'ComicPlain' 'NewYork' 'Palatino' 'Courier') do:
		[:frag |
			(TextStyle knownTextStyles includes: frag) ifFalse:
				[(FileDirectory default fileExists: (aName _ frag, '.style'))
						ifTrue:
							[TextStyle default collectionFromFileNamed: aName]]].! !

!TextStyle class methodsFor: 'user interface' stamp: 'nk 9/1/2004 10:38'!
modalMVCStyleSelectorWithTitle: title
	"MVC Only!! Presents a modal font-style choice menu, answers a TextStyle or nil."
	"TextStyle modalMVCStyleSelectorWithTitle: 'testing'"
	
	| aMenu actualStyles |
	aMenu _ CustomMenu new.
	actualStyles := self actualTextStyles.
	actualStyles keysSortedSafely do: [ :styleName | | style |
		style := actualStyles at: styleName.
		aMenu add: styleName action: style
	].
	^aMenu startUpWithCaption: title.
! !

!TextStyle class methodsFor: 'user interface' stamp: 'nk 9/1/2004 10:34'!
modalStyleSelectorWithTitle: title
	"Presents a modal font-style choice menu, answers a TextStyle or nil."
	"TextStyle modalStyleSelectorWithTitle: 'testing'"
	
	| menu actualStyles |
	Smalltalk isMorphic ifFalse: [ ^self modalMVCStyleSelectorWithTitle: title ].

	menu _ MenuMorph entitled: title.
	actualStyles := self actualTextStyles.
	actualStyles keysSortedSafely do: [ :styleName | | style |
		style := actualStyles at: styleName.
		menu add: styleName target: menu selector: #modalSelection: argument: style.
		menu lastItem font: (style fontOfSize: 18)
	].
	^menu invokeModal.
! !

!TextStyle class methodsFor: 'user interface' stamp: 'nk 9/1/2004 10:37'!
mvcPromptForFont: aPrompt andSendTo: aTarget withSelector: aSelector
	"MVC Only!! prompt for a font and if one is provided, send it to aTarget using a message with selector aSelector."
	| aMenu aChoice aStyle namesAndSizes aFont |
	"TextStyle mvcPromptForFont: 'Choose system font style' andSendTo: TextStyle withSelector: #setSystemFontTo:"
	aMenu _ CustomMenu new.
	self actualTextStyles keysSortedSafely do:
		[:styleName |
			aMenu add: styleName action: styleName].
	aChoice _ aMenu startUpWithCaption: aPrompt.
	aChoice ifNil: [^ self].
	aMenu _ CustomMenu new.
	aStyle _ self named: aChoice.
	(namesAndSizes _ aStyle fontNamesWithPointSizes) do:
		[:aString | aMenu add: aString action: aString].
	aChoice _ aMenu startUpWithCaption: nil.
	aChoice ifNil: [^ self].
	aFont _ aStyle fontAt: (namesAndSizes indexOf: aChoice).
	aTarget perform: aSelector with: aFont! !

!TextStyle class methodsFor: 'user interface' stamp: 'laza 3/25/2004 23:12'!
promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector
	self promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: nil! !

!TextStyle class methodsFor: 'user interface' stamp: 'nk 9/1/2004 13:19'!
promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: currentFont 
	"Morphic Only!! prompt for a font and if one is provided, send it to aTarget using a 
	message with selector aSelector."
	"TextStyle promptForFont: 'Choose system font:' andSendTo: Preferences withSelector: 
	#setSystemFontTo: "
	"Derived from a method written by Robin Gibson"
	| menu subMenu currentTextStyle |
	currentTextStyle := currentFont
				ifNotNil: [currentFont textStyleName].
	menu := MenuMorph entitled: aPrompt.
	self actualTextStyles keysSortedSafely
		do: [:styleName | 
			subMenu := self
						fontMenuForStyle: styleName
						target: aTarget
						selector: aSelector
						highlight: currentFont.
			menu add: styleName subMenu: subMenu.
			menu lastItem
				font: ((self named: styleName)
						fontOfSize: 18).
			styleName = currentTextStyle
				ifTrue: [menu lastItem color: Color blue darker]].
	menu popUpInWorld: self currentWorld! !


!TextStyle class methodsFor: 'utilities' stamp: 'nk 3/25/2004 17:55'!
decodeStyleName: styleName 
	"Given a string styleName, return a collection with: 
	 
	* [1] the probable Squeak emphasis code, which is a bit combination of: 
	1	bold 
	2	italic 
	4	underlined 
	8	narrow 
	16	strikeout 
	 
	* [2] the base style name without the modifiers (can be empty)
	* [3] the modifiers in the order they were found 
	* [4] the codes for those modifiers, in the same order
	"
	| decoder keys modifiers modifierCodes baseName styleCode matchedKey |

	decoder := self styleDecoder.

	modifiers := OrderedCollection new.
	modifierCodes := OrderedCollection new.
	keys := decoder keys asArray
				sort: [:a :b | a size > b size].
	styleCode := 0.
	baseName := styleName asString.
	[matchedKey := keys
				detect: [:k | baseName endsWith: k]
				ifNone: [].
	matchedKey notNil]
		whileTrue: [| last code | 
			last := baseName size - matchedKey size.
			last > 0
				ifTrue: [('- ' includes: (baseName at: last))
						ifTrue: [last := last - 1]].
			baseName := baseName copyFrom: 1 to: last.
			code := decoder at: matchedKey.
			styleCode := styleCode + code.
			modifiers addFirst: matchedKey.
			modifierCodes addFirst: code.
	].
	^ {styleCode. baseName. modifiers. modifierCodes }! !

!TextStyle class methodsFor: 'utilities' stamp: 'nk 4/2/2004 11:26'!
pixelsPerInch
	"Answer the nominal resolution of the screen."

	^TextConstants at: #pixelsPerInch ifAbsentPut: [ 96.0 ].! !

!TextStyle class methodsFor: 'utilities' stamp: 'nk 4/2/2004 11:24'!
pixelsPerInch: aNumber
	"Set the nominal number of pixels per inch to aNumber."
	TextConstants at: #pixelsPerInch put: aNumber asFloat.
	AbstractFont allSubInstancesDo: [ :font | font pixelsPerInchChanged ].! !

!TextStyle class methodsFor: 'utilities' stamp: 'nk 4/2/2004 11:23'!
pixelsToPoints: pixels
	^pixels * 72.0 / self pixelsPerInch! !

!TextStyle class methodsFor: 'utilities' stamp: 'nk 4/2/2004 11:22'!
pointsToPixels: points
	^points * self pixelsPerInch / 72.0! !
HashAndEqualsTestCase subclass: #TextStyleTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'GraphicsTests-Text'!

!TextStyleTest methodsFor: 'initialize-release' stamp: 'mjr 8/20/2003 18:55'!
setUp
	super setUp.
	prototypes add: TextStyle default ! !
ClassTestCase subclass: #TextTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!
!TextTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Text. 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!

TextAction subclass: #TextURL
	instanceVariableNames: 'url'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextURL methodsFor: 'as yet unclassified' stamp: 'rbb 2/18/2005 09:24'!
actOnClickFor: anObject
	"Do what you can with this URL.  Later a web browser."

	| response m |

	(url beginsWith: 'sqPr://') ifTrue: [
		ProjectLoading thumbnailFromUrl: (url copyFrom: 8 to: url size).
		^self		"should not get here, but what the heck"
	].
	"if it's a web browser, tell it to jump"
	anObject isWebBrowser
		ifTrue: [anObject jumpToUrl: url. ^ true]
		ifFalse: [((anObject respondsTo: #model) and: [anObject model isWebBrowser])
				ifTrue: [anObject model jumpToUrl: url. ^ true]].

		"if it's a morph, see if it is contained in a web browser"
		(anObject isKindOf: Morph) ifTrue: [
			m _ anObject.
			[ m ~= nil ] whileTrue: [
				(m isWebBrowser) ifTrue: [
					m  jumpToUrl: url.
					^true ].
				(m hasProperty: #webBrowserView) ifTrue: [
					m model jumpToUrl: url.
					^true ].
				m _ m owner. ]
		].

	"no browser in sight.  ask if we should start a new browser"
	((self confirm: 'open a browser to view this URL?' translated) and: [WebBrowser default notNil]) ifTrue: [
		WebBrowser default openOnUrl: url.
		^ true ].

	"couldn't display in a browser.  Offer to put up just the source"

	response _ (UIManager default 
				chooseFrom: (Array with: 'View web page as source' translated
									with: 'Cancel' translated)
				title:  'Couldn''t find a web browser. View\page as source?' withCRs translated).
	response = 1 ifTrue: [HTTPSocket httpShowPage: url].
	^ true! !

!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:47'!
analyze: aString

	| list |
	list _ super analyze: aString.
	url _ list at: 1.
	^ list at: 2! !

!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'!
info
	^ url! !

!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 08:55'!
url: aString
	url _ aString! !

!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:45'!
writeScanOn: strm

	strm nextPut: $R; nextPutAll: url; nextPut: $;! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextURL class
	instanceVariableNames: ''!

!TextURL class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:24'!
scanFrom: strm
	"read a link in the funny format used by Text styles on files. Rhttp://www.disney.com;"

	^ self new url: (strm upTo: $;)! !
Object subclass: #TheWorldMainDockingBar
	instanceVariableNames: 'icons'
	classVariableNames: 'Instance TS'
	poolDictionaries: ''
	category: 'Morphic-Kernel'!

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:12'!
activateObjectsTool
	self world activateObjectsTool! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/7/2004 17:13'!
appearance
	self worldMenu appearanceMenu popUpInWorld ! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/4/2004 19:37'!
changeSoundVolume
	self notYetImplemented! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:12'!
clearTurtleTrails
	self world clearTurtleTrails! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:12'!
doNewPainting
	| w |
	w := self world.
	w
		assureNotPaintingElse: [^ self].
	w
		makeNewDrawing: (World primaryHand lastEvent copy setPosition: w center)! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:12'!
eToyVocabularySummary
	Cursor wait
		showWhile: [self world printVocabularySummary]! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:35'!
exitFromFullScreen
	self toggleFullScreen! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:13'!
findAnyFile
	FileList2 morphicViewGeneralLoaderInWorld: self world! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:13'!
findAProject
	FileList2
		morphicViewProjectLoader2InWorld: self world
		reallyLoad: true
		dirFilterType: #limitedSuperSwikiDirectoryList! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:13'!
hideAllViewers
	self hideAllViewersIn: self world! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 17:46'!
hideAllViewersIn: aMorph 
	aMorph isFlapTab
		ifTrue: [self hideAllViewersIn: aMorph referent].
	aMorph
		submorphsDo: [:each | ""
			({ScriptEditorMorph. StandardViewer} includes: each class)
				ifTrue: [each dismiss]
				ifFalse: [self hideAllViewersIn: each]]! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 20:52'!
importFile
	self findAnyFile! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/4/2004 18:43'!
jumpToProject
	Project jumpToProject! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 20:30'!
makeNewDrawing
	self doNewPainting! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:13'!
moveObjectsOnscreen
	self world roundUpStrays! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/4/2004 18:41'!
newProject
	Project newMorphicOn: nil! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/4/2004 18:56'!
nextProject
	Project advanceToNextProject.
	Beeper beep! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 20:30'!
objectCatalog
	self activateObjectsTool! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/19/2004 13:48'!
objectFromPasteBuffer
	ActiveHand 	pasteMorph! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/7/2004 14:55'!
open
	self worldMenu openMenu popUpInWorld! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 21:50'!
preferences
	Preferences openFactoredPanel! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/4/2004 18:42'!
previousProject

	Project returnToPreviousProject.
	CurrentProjectRefactoring exitCurrentProject.	"go to parent if no previous"
	Beeper beep.! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:16'!
publishProject
	self
		publishStyle: #limitedSuperSwikiPublishDirectoryList
		forgetURL: false
		withRename: false! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:15'!
publishStyle: aSymbol forgetURL: aBoolean withRename: renameBoolean

	| w primaryServer rename |

	w _ self world ifNil: [^Beeper beep].
	w setProperty: #SuperSwikiPublishOptions toValue: aSymbol.

	primaryServer _ w project primaryServerIfNil: [nil].
	rename _ ((primaryServer notNil
		and: [primaryServer acceptsUploads]) not)
		or: [renameBoolean].
	w setProperty: #SuperSwikiRename toValue: rename.

	w project 
		storeOnServerShowProgressOn: self 
		forgetURL: aBoolean | rename.
! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/15/2004 11:49'!
purgeUndoRecords
	 CommandHistory resetAllHistory! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 11/5/2004 15:30'!
quit
	Preferences readOnlyMode
		ifTrue: [""(self confirm: 'REALLY quit Squeak?' translated)
				ifTrue: [SmalltalkImage current snapshot: false andQuit: true]]
		ifFalse: [| saveBeforeQuitting | 
			saveBeforeQuitting := self
						confirm: 'Save changes before quitting?' translated
						orCancel: [^ self].
			SmalltalkImage current snapshot: saveBeforeQuitting andQuit: true]! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 11:20'!
save
	SmalltalkImage current snapshot: true andQuit: false! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 11:25'!
saveAndQuit
	SmalltalkImage current snapshot: true andQuit: true! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 11:21'!
saveAs
	SmalltalkImage current saveAs! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/22/2004 17:48'!
saveAsNewVersion
	SmalltalkImage current saveAsNewVersion! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 3/12/2006 13:11'!
setColorTheme
		SmallLandColorTheme chooseTheme.  ! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 16:23'!
setLanguage
	Project current chooseNaturalLanguage ! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/7/2004 14:51'!
setWorldColor
| world |
world _ self world.
	world
		changeColorTarget: world
		selector: #color:
		originalColor: world color
		hand: world activeHand! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:13'!
showAllViewers
	self world showAllPlayers! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/20/2004 20:03'!
showWorldMainDockingBarString
	^ self world showWorldMainDockingBarString! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/20/2004 20:04'!
suppressFlapsString
	"Answer the wording of the suppress-flaps item"
	^ CurrentProjectRefactoring suppressFlapsString! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 4/13/2005 09:41'!
switchToExpertMode
	| ok |
	ok := self confirm: 'CAUTION!!
The expert mode is powerful as well as dangerous and you can break your Squeak in several ways.
Are you sure to switch to expert mode?' translated.
	ok
		ifFalse: [^ self].
	""
	Preferences enable: #cmdGesturesEnabled.
	Preferences enable: #debugHaloHandle.
	Preferences disable: #noviceMode.
! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:36'!
switchToFullScreen
	self toggleFullScreen! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 4/13/2005 09:41'!
switchToNoviceMode
	Preferences disable: #cmdGesturesEnabled.
	Preferences disable: #debugHaloHandle.
	Preferences enable: #noviceMode.
! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:28'!
toggleFullScreen
	ScreenController lastScreenModeSelected
		ifTrue: [ScreenController new fullScreenOff]
		ifFalse: [ScreenController new fullScreenOn].
	self world positionSubmorphs.
self class updateInstances! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/20/2004 20:05'!
toggleShowWorldMainDockingBar
	self world toggleShowWorldMainDockingBar! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:13'!
unhideHiddenObjects
	self world showHiders! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 3/29/2006 11:48'!
updateFromServer
	Smalltalk
		at: #SmallLandTools
		ifPresent: [:smallLandTools | smallLandTools instance updateFromSmallLandSwikiPage: #quick]! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/25/2004 21:50'!
viewObjectsHierarchy
	"self world findWindow: nil"
	MorphHierarchy openOrDelete! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 7/28/2005 13:04'!
viewSelectedObject
	| selected menu |
	selected := self world selectedObject.
	selected isNil
		ifTrue: [^ self viewObjectsHierarchy].
	""
	menu := selected buildYellowButtonMenu: ActiveHand.
	menu
		addTitle: selected externalName
		icon: (selected iconOrThumbnailOfSize: (Preferences tinyDisplay ifTrue: [16] ifFalse: [28])).
	menu popUpInWorld: selected currentWorld! !

!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/7/2004 14:55'!
windows
	self worldMenu windowsMenu popUpInWorld! !


!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:17'!
backIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallBackIcon]
		ifFalse: [MenuIcons backIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:19'!
forwardIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallForwardIcon]
		ifFalse: [MenuIcons forwardIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:26'!
fullScreenIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallFullScreenIcon]
		ifFalse: [MenuIcons fullScreenIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:18'!
jumpIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallJumpIcon]
		ifFalse: [MenuIcons jumpIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:20'!
loadProjectIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallLoadProjectIcon]
		ifFalse: [MenuIcons loadProjectIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:20'!
objectCatalogIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallObjectCatalogIcon]
		ifFalse: [MenuIcons objectCatalogIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:27'!
objectsIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallObjectsIcon]
		ifFalse: [MenuIcons objectsIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:19'!
openIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallOpenIcon]
		ifFalse: [MenuIcons openIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:20'!
paintIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallPaintIcon]
		ifFalse: [MenuIcons paintIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:20'!
projectIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallProjectIcon]
		ifFalse: [MenuIcons projectIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:21'!
publishIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallPublishIcon]
		ifFalse: [MenuIcons publishIcon]! !

!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:26'!
volumeIcon
	^ Preferences tinyDisplay
		ifTrue: [MenuIcons smallVolumeIcon]
		ifFalse: [MenuIcons volumeIcon]! !


!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:37'!
colorOffEvent: anEvent for: aMorph 
	"Private - gives an off-color to the given morph"
	aMorph color: self offColor! !

!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:38'!
colorOnEvent: anEvent for: aMorph 
	"Private - gives an on-color to the given morph"
	aMorph color: self onColor! !

!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/10/2004 19:24'!
createButtonIcon: aFormOrMorph help: helpStringOrNil selector: selector 
	"Private - Creates a button to fire an action from a docking bar"
	| button icon |
	button := RectangleMorph new.
	button extent: aFormOrMorph extent + 2.
	button borderWidth: 0.
	button color: self offColor.
	helpStringOrNil isNil

		ifFalse: [button setBalloonText: helpStringOrNil translated].
	""
	icon := aFormOrMorph isMorph
				ifTrue: [aFormOrMorph]
				ifFalse: [SketchMorph withForm: aFormOrMorph].
	button addMorphCentered: icon.
	""
	button
		on: #mouseDown
		send: #perform:event:for:
		to: self
		withValue: selector.
	button
		on: #mouseEnter
		send: #colorOnEvent:for:
		to: self.
	button
		on: #mouseLeave
		send: #colorOffEvent:for:
		to: self.
	""
	^ button! !

!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/10/2004 19:33'!
createButtonIcon: aFormOrMorph selector: selector 
	"Private - Creates a button to fire an action from a docking bar"
	^ self
		createButtonIcon: aFormOrMorph
		help: nil
		selector: selector! !

!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:38'!
offColor
	"Private - answer the off color"
	^ Color black alpha: 0.01! !

!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:38'!
onColor
"Private - answer the on color"
	^ (Preferences menuSelectionColor
		ifNil: [Color blue])
		alpha: 0.4! !

!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:39'!
perform: selectorSymbol event: anEvent for: aMorph 
	"Private - perform the given selector"
	aMorph color: self offColor.
	self perform: selectorSymbol! !


!TheWorldMainDockingBar methodsFor: 'construction - submenus' stamp: 'dgd 3/12/2006 13:14'!
configurationMenu
	| menu |
	menu := MenuMorph new defaultTarget: self.
	""
	self createMenuItem: {'set language...'. 'Choose the language in which Squeak should be displayed'. MenuIcons smallLanguageIcon} on: menu.
	menu addLine.
	self createMenuItem: {'update from server'. 'Update from server (Internet access is required)'. MenuIcons smallUpdateIcon} on: menu.
	""
	menu addLine.
	menu addUpdating: #showWorldMainDockingBarString action: #toggleShowWorldMainDockingBar.
	Flaps sharedFlapsAllowed
		ifTrue: [menu
				addUpdating: #suppressFlapsString
				target: CurrentProjectRefactoring
				action: #currentToggleFlapsSuppressed].
	menu addLine.
	self createMenuItem: {'set world color...'. 'Choose a color to use as world background.'} on: menu.
	ScreenController lastScreenModeSelected
		ifTrue: [self createMenuItem: {'exit from full screen'. 'Exit from full screen and enclose Squeak in a window'. MenuIcons smallFullScreenIcon} on: menu]
		ifFalse: [self createMenuItem: {'switch to full screen'. 'Switch to full screen giving the maximun display space to Squeak'. MenuIcons smallFullScreenIcon} on: menu].
	""
	self createMenuItem: {'change sound volume'. 'Change sound volume'. MenuIcons smallVolumeIcon} on: menu.
	menu addLine.
	Preferences noviceMode
		ifFalse: [""
			Preferences useUndo
				ifTrue: [""
					self createMenuItem: {'purge undo records'. 'Save space by removing all the undo information.'} on: menu.
					menu addLine].
			self createMenuItem: {'preferences..'. 'Opens a "Preferences Panel" which allows you to alter many settings'. MenuIcons smallConfigurationIcon} on: menu.
			self createMenuItem: {'appearance...'. nil. MenuIcons smallConfigurationIcon} on: menu].
	self createMenuItem: {'set color theme...'. 'Choose the color theme in which Squeak should be displayed'} on: menu.
	menu addLine.
	Preferences noviceMode
		ifTrue: [self createMenuItem: {'switch to expert mode'. 'Switch to expert mode. CAUTION: The expert mode is powerful as well as dangerous'. MenuIcons smallExpertIcon} on: menu]
		ifFalse: [self createMenuItem: {'switch to novice mode'. 'Come back to novice mode'. MenuIcons smallExpertIcon} on: menu].
	""
	^ menu! !

!TheWorldMainDockingBar methodsFor: 'construction - submenus' stamp: 'dgd 2/15/2005 18:48'!
helpMenu
	| menu |
	menu := MenuMorph new defaultTarget: self.
	""
	self createMenuItem: {'move objects onscreen'. 'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen'} on: menu.
	self createMenuItem: {'unhide hidden objects'. 'If any items on the world are currently hidden, make them visible'} on: menu.
	menu addLine.
	self createMenuItem: {'show all viewers'. 'Make visible the viewers for all objects which have user-written scripts in this playfield'} on: menu.
	self createMenuItem: {'hide all viewers'. 'Make invisible the viewers for all objects in the world'} on: menu.
	menu addLine.
	self createMenuItem: {'clear turtle trails'. 'Remove any pigment laid down on the desktop by objects moving with their pens down'} on: menu.
"
	menu addLine.
	self createMenuItem: {'eToy vocabulary summary'. 'Displays a summary of all the pre-defined commands and properties in the pre-defined eToy vocabulary'} on: menu.
"
	""
	^ menu! !

!TheWorldMainDockingBar methodsFor: 'construction - submenus' stamp: 'dgd 11/6/2004 17:16'!
projectMenu
	| menu |
	menu := MenuMorph new defaultTarget: self.
	""
	Preferences noviceMode
		ifFalse: [""
			self createMenuItem: {'open...'. nil. MenuIcons smallOpenIcon} on: menu.
			self createMenuItem: {'windows...'. nil. MenuIcons smallWindowIcon} on: menu.
			menu addLine].
	""
	self createMenuItem: {'previous project'. 'Return to the most recently visited project'. MenuIcons smallBackIcon} on: menu.
	self createMenuItem: {'jump to project...'. 'Put up a list of all projects, letting me choose one to go to'. MenuIcons smallJumpIcon} on: menu.
	self createMenuItem: {'next project'. 'Go to next project'. MenuIcons smallForwardIcon} on: menu.
	menu addLine.
	self createMenuItem: {'find any file'. 'Import a file into Squeak'. MenuIcons smallOpenIcon} on: menu.
	self createMenuItem: {'find a project'. 'Open a project into Squeak'. MenuIcons smallLoadProjectIcon} on: menu.
	menu addLine.
	self createMenuItem: {'new project'. 'Start a new project'. MenuIcons smallProjectIcon} on: menu.
	self createMenuItem: {'make new drawing'. 'Make a painting'. MenuIcons smallPaintIcon} on: menu.
	self createMenuItem: {'object catalog (o)'. 'A tool for finding and obtaining many kinds of objects'. MenuIcons smallObjectCatalogIcon} on: menu.
	menu addLine.
	self createMenuItem: {'object from paste buffer'. 'Create a new object from paste buffer'. MenuIcons smallPasteIcon} on: menu.
	Preferences useUndo
		ifTrue: [""
			Preferences infiniteUndo
				ifTrue: [""
					menu
						addUpdating: #undoMenuWording
						target: self commandHistory
						action: #undoLastCommand.
					menu
						addUpdating: #redoMenuWording
						target: self commandHistory
						action: #redoNextCommand]
				ifFalse: [""
					menu
						addUpdating: #undoOrRedoMenuWording
						target: self commandHistory
						action: #undoOrRedoCommand]].
	menu addLine.
	self createMenuItem: {'view objects hierarchy'. 'A tool for discovering the objects and the relations between them'. MenuIcons smallObjectsIcon} on: menu.
	menu addLine.
	self createMenuItem: {'publish project'. 'Publish the current project'. MenuIcons smallPublishIcon} on: menu.
	""
	^ menu! !

!TheWorldMainDockingBar methodsFor: 'construction - submenus' stamp: 'dgd 11/5/2004 15:25'!
squeakMenu
	| menu |
	menu := MenuMorph new defaultTarget: self.
	""
	" 
	menu add: 'configuration...' translated subMenu: self  
	configurationMenu. menu lastItem icon: MenuIcons  
	smallConfigurationIcon. menu addLine.  
	"
	Preferences readOnlyMode ifFalse:[""
	self createMenuItem: {'save'. 'Save the current state of Squeak on disk'. MenuIcons smallSaveIcon} on: menu.
	self createMenuItem: {'save as...'. 'Save the current state of Squeak on disk under a new name'. MenuIcons smallSaveAsIcon} on: menu.
	Preferences noviceMode
		ifFalse: [""
			self createMenuItem: {'save as new version'. 'Save the current state of Squeak on disk under a version-stamped name'. MenuIcons smallSaveAsIcon} on: menu].
	menu addLine.
	self createMenuItem: {'save and quit'. 'Save the current state of Squeak on disk, and quit out of Squeak'. MenuIcons smallQuitIcon} on: menu].
	self createMenuItem: {'quit'. 'Quit out of Squeak'. MenuIcons smallQuitIcon} on: menu.
	""
	^ menu! !


!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'dgd 11/2/2004 17:55'!
createDockingBar
	"Create a docking bar from the receiver's representation"
	| dockingBar |
	dockingBar := DockingBarMorph new.
	dockingBar adhereToTop.
	dockingBar color: ColorTheme current dockingBarColor.
	dockingBar gradientRamp: ColorTheme current  dockingBarGradientRamp.
	dockingBar autoGradient: ColorTheme current dockingBarAutoGradient.
	""
	self fillDockingBar: dockingBar.
	""
	^ dockingBar! !

!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'dgd 7/28/2005 12:11'!
fillDockingBar: aDockingBar 
	"Private - fill the given docking bar"
	self fillMenuItemsBar: aDockingBar.
	""
	aDockingBar addSpacer.
	self fillNavigatorOn: aDockingBar.
	""
	aDockingBar addSpacer.
	Preferences tinyDisplay
		ifFalse: [| clock | 
			clock := ClockMorph new.
			clock show24hr: true.
			clock showSeconds: false.
			clock font: Preferences standardMenuFont emphasis: 0.
			aDockingBar addMorphBack: clock.
			aDockingBar addSpace: 5.
	""
	aDockingBar
		addMorphBack: (self
				createButtonIcon: self volumeIcon
				help: 'Change sound volume' translated
				selector: #changeSoundVolume)].
	aDockingBar
		addMorphBack: (self
				createButtonIcon: self fullScreenIcon
				help: (ScreenController lastScreenModeSelected
						ifTrue: ['Exit from full screen']
						ifFalse: ['Switch to full screen'])
				selector: #toggleFullScreen).
	aDockingBar
		addMorphBack: (self
				createButtonIcon: (SelectedObjectThumbnail
						extent: 37 @ 28
								- (Preferences tinyDisplay
										ifTrue: [12]
										ifFalse: [0])
						noSelectedThumbnail: self objectsIcon
						noSelectedBalloonText: 'View objects hierarchy' translated)
				selector: #viewSelectedObject).
	""
	aDockingBar setProperty: #mainDockingBarTimeStamp toValue: self class timeStamp! !

!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'dgd 7/28/2005 11:42'!
fillMenuItemsBar: aDockingBar 
	"Private - fill the given docking bar"
	| squeakIcon homeIcon configurationIcon helpIcon squeakLabel projectLabel configurationLabel helpLabel |
	(aDockingBar isDockingBar not
			or: [Preferences tinyDisplay])
		ifTrue: [""
			squeakIcon := MenuIcons smallSqueakIcon.
			homeIcon := MenuIcons smallHomeIcon.
			configurationIcon := MenuIcons smallConfigurationIcon.
			helpIcon := MenuIcons smallHelpIcon]
		ifFalse: [""
			squeakIcon := MenuIcons squeakIcon.
			homeIcon := MenuIcons homeIcon.
			configurationIcon := MenuIcons configurationIcon.
			helpIcon := MenuIcons helpIcon].
	""
	Preferences tinyDisplay
		ifTrue: [""
			squeakLabel := '' .
			projectLabel := '' .
			configurationLabel := '' .
			helpLabel := '' ]
		ifFalse: [""
			squeakLabel := 'Squeak' translated.
			projectLabel := 'Project' translated.
			configurationLabel := 'Configuration' translated.
			helpLabel := 'Help' translated].
	""
	aDockingBar
		add: squeakLabel
		icon: squeakIcon
		help: 'Options related to Squeak as a whole' translated
		subMenu: self squeakMenu.
	aDockingBar
		add: projectLabel
		icon: homeIcon
		help: 'Options to open things in the current project or to navigate between projects' translated
		subMenu: self projectMenu.
	aDockingBar
		add: configurationLabel
		icon: configurationIcon
		help: 'Options to configure Squeak' translated
		subMenu: self configurationMenu.
	aDockingBar
		add: helpLabel
		icon: helpIcon
		help: 'Helpful options or options to get help' translated
		subMenu: self helpMenu! !

!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'dgd 7/28/2005 12:10'!
fillNavigatorOn: main 
	"main addLine."
	main addDefaultSpace.
	""
	main
		addMorphBack: (self
				createButtonIcon: self backIcon
				help: 'Previous project'
				selector: #previousProject).
	main
		addMorphBack: (self
				createButtonIcon: self jumpIcon
				help: 'Put up a list of all projects, letting me choose one to go to'
				selector: #jumpToProject).
	main
		addMorphBack: (self
				createButtonIcon: self forwardIcon
				help: 'Next project'
				selector: #nextProject).
	main
		addMorphBack: (self
				createButtonIcon: self openIcon
				help: 'Find any file'
				selector: #findAnyFile).
Preferences tinyDisplay ifFalse:[""
	main
		addMorphBack: (self
				createButtonIcon: self loadProjectIcon
				help: 'Find a project'
				selector: #findAProject)].
	main addDefaultSpace.
	main addSpacer.
	main
		addMorphBack: (self
				createButtonIcon: self projectIcon
				help: 'Start a new project'
				selector: #newProject).
	main
		addMorphBack: (self
				createButtonIcon: self paintIcon
				help: 'Make a painting'
				selector: #doNewPainting).
	main
		addMorphBack: (self
				createButtonIcon: self objectCatalogIcon
				help: 'Open the objects catalog'
				selector: #activateObjectsTool).
Preferences tinyDisplay ifFalse:[""
	main
		addMorphBack: (self
				createButtonIcon: self publishIcon
				help: 'Publish the current project'
				selector: #publishProject)].
	""
	main addDefaultSpace! !

!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'dgd 9/6/2004 14:05'!
openDockingBar
	^ self createDockingBar openInWorld ! !


!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 7/28/2005 12:52'!
createMenuItem: triplet on: menu 
	| wording help selectorOrMenu |
	wording := triplet first.
	help := triplet second.
	selectorOrMenu := triplet size > 3
				ifTrue: [triplet fourth]
				ifFalse: [self selectorForWording: wording].
	""
	selectorOrMenu isSymbol
		ifTrue: [""
			menu
				add: wording translated
				target: self
				selector: selectorOrMenu]
		ifFalse: [menu add: wording translated subMenu: selectorOrMenu].
	""
	help isNil
		ifFalse: [menu lastItem setBalloonText: help translated].""
	Preferences tinyDisplay
		ifFalse: [triplet size > 2
				ifTrue: [menu lastItem icon: triplet third]]! !

!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 10/7/2004 12:12'!
selectorForWording: aString 
	"Private - Create a valid smalltalk selector from an english  
	wording.  
	'foo' -> #foo  
	'foo....' -> #foo  
	'foo bar' -> #fooBar  
	'foo bar (f)' - #fooBar  
	"
	| words selector temp |
	temp := aString.
	('*(*)*' match: temp)
		ifTrue: [| pre post | 
			pre := temp copyUpTo: $(.
			post := temp copyAfterLast: $).
			temp := pre , post].
	""
	temp := temp
				collect: [:each | ""
					each isLetter
						ifTrue: [each]
						ifFalse: [Character space]].
	words := temp subStrings: Character separators.
	selector := String
				streamContents: [:stream | ""
					words
						do: [:word | stream nextPutAll: word capitalized]].
	selector at: 1 put: selector first asLowercase.
	""
	^ selector asSymbol! !

!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 9/6/2004 18:48'!
updateIfNeeded: aDockingBar 
"Update the given docking bar if needed"
	| timeStamp |
	timeStamp := aDockingBar
				valueOfProperty: #mainDockingBarTimeStamp
				ifAbsent: [^ self].
	timeStamp = self class timeStamp
		ifTrue: [^ self].
	""
	aDockingBar removeAllMorphs.
	self fillDockingBar: aDockingBar! !

!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 9/9/2004 18:12'!
world
^ World! !

!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 10/7/2004 14:55'!
worldMenu
	^ TheWorldMenu new
		world: self world
		project: Project current
		hand: self world activeHand; yourself! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TheWorldMainDockingBar class
	instanceVariableNames: ''!

!TheWorldMainDockingBar class methodsFor: 'class initialization' stamp: 'dgd 9/22/2004 20:42'!
initialize
	"Initialize the receiver"
	Preferences
		addPreference: #showWorldMainDockingBar
		categories: #(#'docking bars' )
		default: true
		balloonHelp: 'Whether world''s main docking bar should be shown or not.'
		projectLocal: true
		changeInformee: TheWorldMainDockingBar
		changeSelector: #showWorldMainDockingBarPreferenceChanged.
	""
	SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self.
	SystemChangeNotifier uniqueInstance
		notify: self
		ofSystemChangesOfItem: #method
		using: #updateInstances:.
	""
	Locale addLocalChangedListener: self.
	self setTimeStamp! !


!TheWorldMainDockingBar class methodsFor: 'instance creation' stamp: 'dgd 9/6/2004 14:35'!
instance
	"Answer the receiver's instance"
	^ Instance
		ifNil: [Instance := super new]! !

!TheWorldMainDockingBar class methodsFor: 'instance creation' stamp: 'dgd 9/6/2004 14:35'!
new
	"Singleton, use #instance"
	^ self error: 'Use #instance'! !


!TheWorldMainDockingBar class methodsFor: 'as yet unclassified' stamp: 'dgd 9/9/2004 16:27'!
localeChanged
	self updateInstances! !


!TheWorldMainDockingBar class methodsFor: 'timestamping' stamp: 'dgd 9/6/2004 14:21'!
setTimeStamp
	"Change the receiver's timeStamp"
	TS := UUID new! !

!TheWorldMainDockingBar class methodsFor: 'timestamping' stamp: 'dgd 9/6/2004 14:19'!
timeStamp
	"Answer the receiver's timeStamp"
	^ TS! !


!TheWorldMainDockingBar class methodsFor: 'preferences' stamp: 'dgd 9/6/2004 18:48'!
showWorldMainDockingBarPreferenceChanged
	"The preference #showWorldMainDockingBar has just  
	changed"
	Project current showWorldMainDockingBar:  Preferences showWorldMainDockingBar! !


!TheWorldMainDockingBar class methodsFor: 'events' stamp: 'dgd 9/7/2004 21:33'!
updateInstances
	"The class has changed, time to update the instances"

	self setTimeStamp.
	Project current assureMainDockingBarPresenceMatchesPreference! !

!TheWorldMainDockingBar class methodsFor: 'events' stamp: 'dgd 9/7/2004 21:33'!
updateInstances: anEvent 
	"The class has changed, time to update the instances"
	(anEvent itemClass == self
			or: [anEvent itemClass == self class])
		ifFalse: [^ self].
	""
	self updateInstances! !
Object subclass: #TheWorldMenu
	instanceVariableNames: 'myProject myWorld myHand'
	classVariableNames: 'OpenMenuRegistry'
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!TheWorldMenu commentStamp: 'sw 10/5/2002 00:44' prior: 0!
Instances of TheWorldMenu serve to present the primary Squeak menu obtained by clicking on open desktop, which is variously spoken of as the "screen menu", the "desktop menu", or the "world menu".

myProject is the Project I pertain to.
myWorld is the world, a PasteUpMorph, that I pertain to.
myHand is the hand that invoked the menu.!


!TheWorldMenu methodsFor: 'action' stamp: 'sw 12/4/2001 21:02'!
commandKeyTypedIntoMenu: evt
	"The user typed a command-key into the given menu; dispatch it"

	myWorld keystrokeInWorld: evt ! !

!TheWorldMenu methodsFor: 'action' stamp: 'ar 3/17/2001 23:46'!
doMenuItem: aCollection with: event
	| realTarget selector nArgs |
	selector _ aCollection second.
	nArgs _ selector numArgs.
	realTarget _ aCollection first.
	realTarget == #myWorld ifTrue: [realTarget _ myWorld].
	realTarget == #myHand ifTrue: [realTarget _ myHand].
	realTarget == #myProject ifTrue: [realTarget _ self projectForMyWorld].
	^nArgs = 0 
		ifTrue:[realTarget perform: selector]
		ifFalse:[realTarget perform: selector with: event].
! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 10:18'!
menuColorString

	^ Preferences menuColorString! !

!TheWorldMenu methodsFor: 'action' stamp: 'dao 10/1/2004 13:37'!
projectThumbnail
	"Offer the user a menu of project names. Attach to the hand a thumbnail of the project the user selects."

	| menu projName pr |
	menu _ CustomMenu new.
	menu 
		add: (Project current name, ' (current)') 
		action: Project current name.
	menu addLine.
	Project allNames do: [:n | menu add: n action: n].
	projName _ menu startUpWithCaption: 'Select a project'.
	projName ifNotNil:
		[(pr _ Project named: projName) 
			ifNotNil: [myHand attachMorph: (ProjectViewMorph on: pr)]
			ifNil: [self inform: 'can''t seem to find that project']].! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 10:18'!
roundedCornersString

	^ Preferences roundedCornersString! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 6/27/2000 09:04'!
setGradientColor

	myWorld setGradientColor: myHand lastEvent! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 08:35'!
soundEnablingString

	^ Preferences soundEnablingString! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 11:31'!
staggerPolicyString

	^ Preferences staggerPolicyString! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 11:32'!
toggleWindowPolicy

	Preferences toggleWindowPolicy! !


!TheWorldMenu methodsFor: 'commands' stamp: 'RAA 6/15/2000 10:18'!
beIsolated
        "Establish this project as an isolation layer.
        Further method changes made here will be revoked when you leave the project."

        self projectForMyWorld beIsolated.! !

!TheWorldMenu methodsFor: 'commands' stamp: 'ar 10/5/2000 18:54'!
changeBackgroundColor
	"Let the user select a new background color for the world"

	myWorld changeColorTarget: myWorld selector: #color: originalColor: myWorld color hand: myWorld activeHand.
! !

!TheWorldMenu methodsFor: 'commands' stamp: 'dgd 9/21/2003 17:43'!
cleanUpWorld
	(SelectionMenu confirm:
'This will remove all windows except those
containing unsubmitted text edits, and will
also remove all non-window morphs (other
than flaps) found on the desktop.  Are you
sure you want to do this?' translated)
		ifFalse: [^ self].

	myWorld allNonFlapRelatedSubmorphs do:
		[:m | m delete].
	(SystemWindow windowsIn: myWorld satisfying: [:w | w model canDiscardEdits])
		do: [:w | w delete]! !

!TheWorldMenu methodsFor: 'commands' stamp: 'nk 2/15/2004 09:37'!
garbageCollect
	"Do a garbage collection, and report results to the user."

	Utilities garbageCollectAndReport! !

!TheWorldMenu methodsFor: 'commands' stamp: 'dgd 9/21/2003 13:17'!
loadProject

	| stdFileMenuResult |
	"Put up a Menu and let the user choose a '.project' file to load.  Create a thumbnail and jump into the project."

	Project canWeLoadAProjectNow ifFalse: [^ self].
	stdFileMenuResult _ ((StandardFileMenu new) pattern: '*.pr'; 
		oldFileFrom: FileDirectory default ) 
			startUpWithCaption: 'Select a File:' translated.
	stdFileMenuResult ifNil: [^ nil].
	ProjectLoading 
		openFromDirectory: stdFileMenuResult directory 
		andFileName: stdFileMenuResult name
! !

!TheWorldMenu methodsFor: 'commands' stamp: 'sd 5/23/2003 14:49'!
lookForSlips

	ChangeSet current lookForSlips! !

!TheWorldMenu methodsFor: 'commands' stamp: 'RAA 5/24/2000 17:31'!
mvcProjectsAllowed

	^Preferences mvcProjectsAllowed and: [Smalltalk includesKey: #StandardSystemView]! !

!TheWorldMenu methodsFor: 'commands' stamp: 'RAA 5/25/2000 07:42'!
newMorphOfClass: morphClass event: evt
	"Attach a new morph of the given class to the invoking hand."

	| m |
	m _ morphClass new.
	m installModelIn: myWorld.  "a chance to install model pointers"
	m wantsToBeOpenedInWorld
		ifTrue:[myWorld addMorph: m]
		ifFalse:[evt hand attachMorph: m].
	myWorld startSteppingSubmorphsOf: m.
! !

!TheWorldMenu methodsFor: 'commands' stamp: 'ar 9/27/2005 20:33'!
openBrowser 
	"Create and schedule a Browser view for browsing code."
	ToolSet browse: nil selector: nil! !

!TheWorldMenu methodsFor: 'commands' stamp: 'asm 1/17/2006 19:17'!
openFileDirectly

	FileList openFileDirectly! !

!TheWorldMenu methodsFor: 'commands' stamp: 'md 2/24/2006 15:21'!
openFileList
	FileList2 prototypicalToolWindow openInWorld: myWorld! !

!TheWorldMenu methodsFor: 'commands' stamp: 'md 8/28/2005 00:20'!
openMorphicProject
	"Open a morphic project from within a morphic project"
	Project newMorphicOn: nil
! !

!TheWorldMenu methodsFor: 'commands' stamp: 'RAA 5/24/2000 17:32'!
openMVCProject

	ProjectViewMorph newMVCProject openInWorld.
! !

!TheWorldMenu methodsFor: 'commands' stamp: 'RAA 5/24/2000 18:53'!
openTranscript

	(Transcript openAsMorphLabel: 'Transcript') openInWorld: myWorld! !

!TheWorldMenu methodsFor: 'commands' stamp: 'ar 9/27/2005 20:49'!
openWorkspace

	UIManager default edit: '' label: 'Workspace'! !

!TheWorldMenu methodsFor: 'commands' stamp: 'RAA 6/15/2000 10:17'!
projectForMyWorld

        ^myProject ifNil: [myProject _ myWorld project]! !

!TheWorldMenu methodsFor: 'commands' stamp: 'md 11/14/2003 17:33'!
propagateChanges
        "The changes made in this isolated project will be propagated to projects above."

        self projectForMyWorld propagateChanges.! !

!TheWorldMenu methodsFor: 'commands' stamp: 'sd 11/16/2003 14:18'!
quitSession

	SmalltalkImage current
		snapshot: (self confirm: 'Save changes before quitting?' translated orCancel: [^ self])
		andQuit: true! !

!TheWorldMenu methodsFor: 'commands' stamp: 'dgd 9/21/2003 13:20'!
readMorphFromAFile
	"Produce a morph from a file -- either a saved .morph file or a graphics file"

	| morphOrList ff aName f m |
	aName _ Utilities chooseFileWithSuffixFromList:
(#('.morph'), Utilities graphicsFileSuffixes) withCaption: 'Choose a file
to load' translated.
	aName ifNil: [^ self].  "User made no choice"
	aName == #none ifTrue: [^ self inform: 
'Sorry, no suitable files found
(names should end with .morph, .gif,
.bmp, .jpeg, .jpe, .jp, or .form)' translated].

	(aName asLowercase endsWith: '.morph')
		ifTrue:
			[ff _ FileStream readOnlyFileNamed: aName.
			morphOrList _ ff fileInObjectAndCode.		"code filed in is the Model class"
			"the file may contain either a single morph or an array of morphs"
			myWorld addMorphsAndModel: morphOrList]
		ifFalse:
			[f _ Form fromFileNamed: aName.
			f ifNil: [^ self error: 'unrecognized image file format' translated].
			m _ myWorld drawingClass new form: f.
			myHand attachMorph: m]
! !

!TheWorldMenu methodsFor: 'commands' stamp: 'sd 11/16/2003 14:18'!
saveAndQuit

	SmalltalkImage current snapshot: true andQuit: true! !

!TheWorldMenu methodsFor: 'commands' stamp: 'RAA 5/24/2000 18:13'!
saveWorldInFile
	"Save the world's submorphs, model, and stepList in a file.  "

	| fileName fileStream aClass |
	fileName _ FillInTheBlank request: 'File name for this morph?'.
	fileName isEmpty ifTrue: [^ self].  "abort"

	"Save only model, stepList, submorphs in this world"
	myWorld submorphsDo: [:m |
		m allMorphsDo: [:subM | subM prepareToBeSaved]].	"Amen"

	fileStream _ FileStream newFileNamed: fileName, '.morph'.
	aClass _ myWorld model ifNil: [nil] ifNotNil: [myWorld model class].
	fileStream fileOutClass: aClass andObject: myWorld.
! !

!TheWorldMenu methodsFor: 'commands' stamp: 'dgd 9/6/2003 18:17'!
setDisplayDepth
	"Let the user choose a new depth for the display. "

	| result oldDepth allDepths allLabels menu hasBoth |
	oldDepth _ Display nativeDepth.
	allDepths _ #(1 -1 2 -2 4 -4 8 -8 16 -16 32 -32) select: [:d | Display supportsDisplayDepth: d].
	hasBoth _ (allDepths anySatisfy:[:d| d > 0]) and:[allDepths anySatisfy:[:d| d < 0]].
	allLabels _ allDepths collect:[:d|
		String streamContents:[:s|
			s nextPutAll: (d = oldDepth ifTrue:['<on>'] ifFalse:['<off>']).
			s print: d abs.
			hasBoth ifTrue:[s nextPutAll: (d > 0 ifTrue:['  (big endian)'] ifFalse:['  (little endian)'])].
		]].
	menu _ SelectionMenu labels: allLabels selections: allDepths.
	result _ menu startUpWithCaption: 'Choose a display depth' translated.
	result ifNotNil: [Display newDepth: result].
	oldDepth _ oldDepth abs.
	(Smalltalk isMorphic and: [(Display depth < 4) ~= (oldDepth < 4)])
		ifTrue:
			["Repaint windows since they look better all white in depth < 4"
			(SystemWindow windowsIn: myWorld satisfying: [:w | true]) do:
				[:w |
				oldDepth < 4
					ifTrue: [w restoreDefaultPaneColor]
					ifFalse: [w updatePaneColors]]]! !

!TheWorldMenu methodsFor: 'commands' stamp: 'aoy 2/15/2003 21:19'!
splitNewMorphList: list depth: d 
	| middle c prev next out |
	d <= 0 ifTrue: [^Array with: list].
	middle := list size // 2 + 1.
	c := (list at: middle) name first.
	prev := middle - 1.
	[prev > 0 and: [(list at: prev) name first = c]] 
		whileTrue: [prev := prev - 1].
	next := middle + 1.
	[next <= list size and: [(list at: next) name first = c]] 
		whileTrue: [next := next + 1].
	"Choose the better cluster"
	middle := middle - prev < (next - middle) 
				ifTrue: [prev + 1]
				ifFalse: [next]. 
	middle = 1 ifTrue: [middle := next].
	middle >= list size ifTrue: [middle := prev + 1].
	(middle = 1 or: [middle >= list size]) ifTrue: [^Array with: list].
	out := WriteStream on: Array new.
	out nextPutAll: (self splitNewMorphList: (list copyFrom: 1 to: middle - 1)
				depth: d - 1).
	out 
		nextPutAll: (self splitNewMorphList: (list copyFrom: middle to: list size)
				depth: d - 1).
	^out contents! !

!TheWorldMenu methodsFor: 'commands' stamp: 'ar 3/17/2001 23:40'!
startMessageTally

	(self confirm: 'MessageTally will start now,
and stop when the cursor goes
to the top of the screen') ifTrue:
		[MessageTally spyOn:
			[[Sensor peekMousePt y > 0] whileTrue: [World doOneCycle]]]! !

!TheWorldMenu methodsFor: 'commands' stamp: 'nk 2/15/2004 09:31'!
vmStatistics
	"Open a string view on a report of vm statistics"

	(StringHolder new contents: SmalltalkImage current  vmStatisticsReportString)
		openLabel: 'VM Statistics'! !

!TheWorldMenu methodsFor: 'commands' stamp: 'dgd 10/8/2003 20:11'!
worldMenuHelp
	| aList aMenu cnts explanation |
	"self currentWorld primaryHand worldMenuHelp"

	aList _ OrderedCollection new.
	#(helpMenu changesMenu openMenu debugMenu projectMenu scriptingMenu windowsMenu playfieldMenu appearanceMenu flapsMenu) 
		with:
	#('help' 'changes' 'open' 'debug' 'projects' 'authoring tools' 'windows' 'playfield options' 'appearance' 'flaps') do:
		[:sel :title | aMenu _ self perform: sel.
			aMenu items do:
				[:it | (((cnts _ it contents) = 'keep this menu up') or: [cnts isEmpty])
					ifFalse: [aList add: (cnts, ' - ', title translated)]]].
	aList _ aList asSortedCollection: [:a :b | a asLowercase < b asLowercase].

	explanation _ String streamContents: [:aStream | aList do:
		[:anItem | aStream nextPutAll: anItem; cr]].

	(StringHolder new contents: explanation)
		openLabel: 'Where in the world menu is...' translated! !


!TheWorldMenu methodsFor: 'construction' stamp: 'gm 2/28/2003 01:42'!
alphabeticalMorphMenu
	| list splitLists menu firstChar lastChar subMenu |
	list := Morph withAllSubclasses select: [:m | m includeInNewMorphMenu].
	list := list asArray sortBy: [:c1 :c2 | c1 name < c2 name].
	splitLists := self splitNewMorphList: list depth: 3.
	menu := MenuMorph new defaultTarget: self.
	1 to: splitLists size
		do: 
			[:i | 
			firstChar := i = 1 
				ifTrue: [$A]
				ifFalse: 
					[((splitLists at: i - 1) last name first asInteger + 1) 
								asCharacter].
			lastChar := i = splitLists size 
						ifTrue: [$Z]
						ifFalse: [(splitLists at: i) last name first].
			subMenu := MenuMorph new.
			(splitLists at: i) do: 
					[:cl | 
					subMenu 
						add: cl name
						target: self
						selector: #newMorphOfClass:event:
						argument: cl].
			menu add: firstChar asString , ' - ' , lastChar asString subMenu: subMenu].
	^menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'sw 10/5/2002 00:45'!
appearanceMenu
	"Build the appearance menu for the world."
	| screenCtrl |

	screenCtrl _ ScreenController new.
	^self fillIn: (self menu: 'appearance...') from: {

		{'preferences...' . { Preferences . #openFactoredPanel} . 'Opens a "Preferences Panel" which allows you to alter many settings' } .
		{'choose theme...' . { Preferences . #offerThemesMenu} . 'Presents you with a menu of themes; each item''s balloon-help will tell you about the theme.  If you choose a theme, many different preferences that come along with that theme are set at the same time; you can subsequently change any settings by using a Preferences Panel'} .
		nil .
		{'window colors...' . { Preferences . #windowSpecificationPanel} . 'Lets you specify colors for standard system windows.'}.
		{'system fonts...' . { self . #standardFontDo} . 'Choose the standard fonts to use for code, lists, menus, window titles, etc.'}.
		{'text highlight color...' . { Preferences . #chooseTextHighlightColor} . 'Choose which color should be used for text highlighting in Morphic.'}.
		{'insertion point color...' . { Preferences . #chooseInsertionPointColor} . 'Choose which color to use for the text insertion point in Morphic.'}.
		{'keyboard focus color' . { Preferences . #chooseKeyboardFocusColor} . 'Choose which color to use for highlighting which pane has the keyboard focus'}.
		nil.
		{#menuColorString . { Preferences . #toggleMenuColorPolicy} . 'Governs whether menu colors should be derived from the desktop color.'}.
		{#roundedCornersString . { Preferences . #toggleRoundedCorners} . 'Governs whether morphic windows and menus should have rounded corners.'}.
		nil.
		{'full screen on' . { screenCtrl . #fullScreenOn} . 'puts you in full-screen mode, if not already there.'}.
		{'full screen off' . { screenCtrl . #fullScreenOff} . 'if in full-screen mode, takes you out of it.'}.
		nil.
		{'set display depth...' . {self. #setDisplayDepth} . 'choose how many bits per pixel.'}.
		{'set desktop color...' . {self. #changeBackgroundColor} . 'choose a uniform color to use as desktop background.'}.
		{'set gradient color...' . {self. #setGradientColor} . 'choose second color to use as gradient for desktop background.'}.
		{'use texture background' . { #myWorld . #setStandardTexture} . 'apply a graph-paper-like texture background to the desktop.'}.
		nil.
		{'clear turtle trails from desktop' . { #myWorld . #clearTurtleTrails} . 'remove any pigment laid down on the desktop by objects moving with their pens down.'}.
		{'pen-trail arrowhead size...' . { Preferences. #setArrowheads} . 'choose the shape to be used in arrowheads on pen trails.'}.

	}! !

!TheWorldMenu methodsFor: 'construction' stamp: 'rr 3/10/2006 16:41'!
buildWorldMenu
	"Build the menu that is put up when the screen-desktop is clicked on"
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu commandKeyHandler: self.
	self colorForDebugging: menu.
	menu addStayUpItem.
	ServiceGui worldMenu: menu.
	ServiceGui onlyServices
		ifTrue: [^ menu].
	self fillIn: menu from: {{'previous project'. {#myWorld. #goBack}. 'return to the most-recently-visited project'}. {'jump to project...'. {#myWorld. #jumpToProject}. 'put up a list of all projects, letting me choose one to go to'}. {'save project on file...'. {#myWorld. #saveOnFile}. 'save this project on a file'}. {'load project from file...'. {self. #loadProject}. 'load a project from a file'}. nil}.
	myWorld addUndoItemsTo: menu.
	self fillIn: menu from: {{'restore display (r)'. {World. #restoreMorphicDisplay}. 'repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'}. nil}.
	Preferences simpleMenus
		ifFalse: [self fillIn: menu from: {{'open...'. {self. #openWindow}}. {'windows...'. {self. #windowsDo}}. {'changes...'. {self. #changesDo}}}].
	self fillIn: menu from: {{'help...'. {self. #helpDo}. 'puts up a menu of useful items for updating the system, determining what version you are running, and much else'}. {'appearance...'. {self. #appearanceDo}. 'put up a menu offering many controls over appearance.'}}.
	Preferences simpleMenus
		ifFalse: [self fillIn: menu from: {{'do...'. {Utilities. #offerCommonRequests}. 'put up an editible list of convenient expressions, and evaluate the one selected.'}}].
	self fillIn: menu from: {nil. {'objects (o)'. {#myWorld. #activateObjectsTool}. 'A tool for finding and obtaining many kinds of objects'}. {'new morph...'. {self. #newMorph}. 'Offers a variety of ways to create new objects'}. nil. {'authoring tools...'. {self. #scriptingDo}. 'A menu of choices useful for authoring'}. {'playfield options...'. {self. #playfieldDo}. 'A menu of options pertaining to this object as viewed as a playfield'}. {'flaps...'. {self. #flapsDo}. 'A menu relating to use of flaps.  For best results, use "keep this menu up"'}. {'projects...'. {self. #projectDo}. 'A menu of commands relating to use of projects'}}.
	Preferences simpleMenus
		ifFalse: [self fillIn: menu from: {{'print PS to file...'. {self. #printWorldOnFile}. 'write the world into a postscript file'}. {'debug...'. {self. #debugDo}. 'a menu of debugging items'}}].
	self fillIn: menu from: {nil. {'save'. {SmalltalkImage current. #saveSession}. 'save the current version of the image on disk'}. {'save as...'. {SmalltalkImage current. #saveAs}. 'save the current version of the image on disk under a new name.'}. {'save as new version'. {SmalltalkImage current. #saveAsNewVersion}. 'give the current image a new version-stamped name and save it under that name on disk.'}. {'save and quit'. {self. #saveAndQuit}. 'save the current image on disk, and quit out of Squeak.'}. {'quit'. {self. #quitSession}. 'quit out of Squeak.'}}.
	^ menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'ar 9/27/2005 20:13'!
changesMenu
        "Build the changes menu for the world."

        | menu |
        menu _ self menu: 'changes...'.
        self fillIn: menu from: {
                { 'file out current change set' . { ChangeSet current . #verboseFileOut}.
                                'Write the current change set out to a file whose name reflects the change set name and the current date & time.'}.
                { 'create new change set...' . { ChangeSet . #newChangeSet}. 'Create a new change set and make it the current one.'}.
                { 'browse changed methods' . { ChangeSet  . #browseChangedMessages}.  'Open a message-list browser showing all methods in the current change set'}.
                { 'check change set for slips' . { self  . #lookForSlips}.
                                'Check the current change set for halts, references to the Transcript, etc., and if any such thing is found, open up a message-list browser detailing all possible slips.'}.

                nil.
                { 'simple change sorter' . {self. #openChangeSorter1}.  'Open a 3-paned changed-set viewing tool'}.
                { 'dual change sorter' . {self. #openChangeSorter2}.
                                'Open a change sorter that shows you two change sets at a time, making it easy to copy and move methods and classes between them.'}.
               { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}.
                nil.
                { 'browse recent submissions' . { Utilities . #browseRecentSubmissions}.
                                'Open a new recent-submissions browser.  A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted.  If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions.'}.

                { 'find recent submissions (R)' . { #myWorld . #openRecentSubmissionsBrowser:}.
                                'Make an open recent-submissions browser be the front-window, expanding a collapsed one or creating a new one if necessary.  A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted, latest first.  If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions at the top of the browser.'}.

			nil.
                { 'recently logged changes...' . { self . #browseRecentLog}.'Open a change-list browser on the latter part of the changes log.  You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'}.

                { 'recent log file...' . { Smalltalk . #writeRecentToFile}.
                                'Create a file holding the logged changes (going as far back as you wish), and open a window on that file.'}.

                nil.
                { 'save world as morph file' . {self. #saveWorldInFile}. 'Save a file that, when reloaded, reconstitutes the current World.'}.
                nil.
        }.
        self projectForMyWorld isIsolated ifTrue: [
                self fillIn: menu from: { 
                        { 'propagate changes upward' . {self. #propagateChanges}.
                                'The changes made in this isolated project will propagate to projects up to the next isolation layer.'}.
                }.
        ] ifFalse: [
                self fillIn: menu from: { 
                        { 'isolate changes of this project' . {self. #beIsolated}.
                                'Isolate this project and its subprojects from the rest of the system.  Changes to methods here will be revoked when you leave this project.'}.
                }.
        ].

        ^ menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'RAA 6/16/2000 09:50'!
colorForDebugging: aMenu

        "aMenu color: self myMenuColor"

        "aMenu color: Color lightRed"

! !

!TheWorldMenu methodsFor: 'construction' stamp: 'md 1/21/2006 10:51'!
debugMenu

        | menu |

        menu _ self menu: 'debug...'.
        self fillIn: menu from: { 
                { 'inspect world' . { #myWorld . #inspect } }.
                { 'explore world' . { #myWorld . #explore } }.
                { 'inspect model' . { self . #inspectWorldModel } }.
                        " { 'talk to world...' . { self . #typeInMessageToWorld } }."
                { 'start MessageTally' . { self . #startMessageTally } }.
                { 'start/browse MessageTally' . { self . #startThenBrowseMessageTally } }.
                { 'open process browser' . { self . #openProcessBrowser } }.
                nil.
                        "(self hasProperty: #errorOnDraw) ifTrue:  Later make this come up only when needed."
                { 'start drawing again' . { #myWorld . #resumeAfterDrawError } }.
                { 'start stepping again' . { #myWorld . #resumeAfterStepError } }.
                nil.
                { 'call #tempCommand' . { #myWorld . #tempCommand } }.
                { 'define #tempCommand' . { #myWorld . #defineTempCommand } }.
        }.
	self haltOnceEnabled
		ifTrue: [menu
				add: 'disable halt/inspect once' translated
				target: menu
				action: #clearHaltOnce]
		ifFalse: [menu
				add: 'enable halt/inspect once' translated
				target: menu
				action: #setHaltOnce].
	^menu
	! !

!TheWorldMenu methodsFor: 'construction' stamp: 'dgd 8/26/2003 21:23'!
fillIn: aMenu from: dataForMenu
	"A menu constructor utility by RAA.  dataForMenu is a list of items which mean:
			nil							Indicates to add a line

			first element is symbol		Add updating item with the symbol as the wording selector
			second element is a list		second element has the receiver and selector

			first element is a string		Add menu item with the string as its wording
			second element is a list		second element has the receiver and selector

			a third element exists		Use it as the balloon text
			a fourth element exists		Use it as the enablement selector (updating case only)"
	| item |

	dataForMenu do: [ :itemData |
		itemData ifNil: [aMenu addLine] ifNotNil:
			[item _ (itemData first isKindOf: Symbol)
				ifTrue: 
					[aMenu 
						addUpdating: itemData first 
						target: self 
						selector: #doMenuItem:with: 
						argumentList: {itemData second}]
				 ifFalse:
					[aMenu 
						add: itemData first translated
						target: self 
						selector: #doMenuItem:with: 
						argumentList: {itemData second}].
			itemData size >= 3 ifTrue:
				[aMenu balloonTextForLastItem: itemData third translated.
			itemData size >= 4 ifTrue:
				[item enablementSelector: itemData fourth]]]].

	^ aMenu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'md 7/22/2005 21:29'!
helpMenu
        "Build the help menu for the world."
        |  menu |

  	menu := self menu: 'help...'.

        self fillIn: menu from:
        {
                {'about this system...'. {SmalltalkImage current. #aboutThisSystem}. 'current version information.'}.
                {'update code from server'. {Utilities. #updateFromServer}. 'load latest code updates via the internet'}.
                {'preferences...'. {Preferences. #openPreferencesInspector}. 'view and change various options.'}.
			 {'set language...' . {Project. #chooseNaturalLanguage}. 'choose the language in which tiles should be displayed.'} .
                nil.
               {'command-key help'. { Utilities . #openCommandKeyHelp}. 'summary of keyboard shortcuts.'}
	}.

	self addGestureHelpItemsTo: menu.

	self fillIn: menu from:
	{
                {'world menu help'. { self . #worldMenuHelp}. 'helps find menu items buried in submenus.'}.
                        "{'info about flaps' . { Utilities . #explainFlaps}. 'describes how to enable and use flaps.'}."
                {'font size summary' . { TextStyle . #fontSizeSummary}.  'summary of names and sizes of available fonts.'}.
                {'useful expressions' . { Utilities . #openStandardWorkspace}. 'a window full of useful expressions.'}.
			 {'annotation setup...' . { Preferences . #editAnnotations}. 'Click here to get a little window that will allow you to specify which types of annotations, in which order, you wish to see in the annotation panes of browsers and other tools'}.
			nil.
                {'graphical imports' . { Imports default . #viewImages}.  'view the global repository called ImageImports; you can easily import external graphics into ImageImports via the FileList'}.
                {'standard graphics library' . { ScriptingSystem . #inspectFormDictionary}.  'lets you view and change the system''s standard library of graphics.'}.
                nil.
                {'telemorphic...' . {self. #remoteDo}.  'commands for doing multi-machine "telemorphic" experiments'}.
                {#soundEnablingString . { Preferences . #toggleSoundEnabling}. 'turning sound off will completely disable Squeak''s use of sound.'}.
                nil.

                {'set author initials...' . { Utilities . #setAuthorInitials }. 'supply initials to be used to identify the author of code and other content.'}.
                {'vm statistics' . { self . #vmStatistics}.  'obtain some intriguing data about the vm.'}.
			  nil.
			  {'purge undo records' . { CommandHistory . #resetAllHistory }. 'save space by removing all the undo information remembered in all projects.'}.
                {'space left' . { self . #garbageCollect}. 'perform a full garbage-collection and report how many bytes of space remain in the image.'}.
        }.

	^menu

! !

!TheWorldMenu methodsFor: 'construction' stamp: 'md 2/22/2006 21:24'!
newMorph
	"The user requested 'new morph' from the world menu.  Put up a menu that allows many ways of obtaining new morphs."

	| menu |

	menu _ self menu: 'Add a new morph'.
	menu 
		add: 'from paste buffer' translated target: myHand action: #pasteMorph;
		add: 'from alphabetical list' translated subMenu: self alphabeticalMorphMenu;
		add: 'from a file...' translated target: self action: #readMorphFromAFile.
	menu addLine.
	menu add: 'grab rectangle from screen' translated target: myWorld action: #grabDrawingFromScreen:;
		add: 'grab with lasso from screen' translated target: myWorld action: #grabLassoFromScreen:;
		add: 'grab rubber band from screen' translated target: myWorld action: #grabRubberBandFromScreen:;
		add: 'grab flood area from screen' translated target: myWorld action: #grabFloodFromScreen:.
	menu addLine.
	menu add: 'make new drawing' translated target: myWorld action: #newDrawingFromMenu:;
		add: 'make link to project...' translated target: self action: #projectThumbnail.

	self doPopUp: menu.
! !

!TheWorldMenu methodsFor: 'construction' stamp: 'ar 9/27/2005 20:36'!
openMenu
	"Build the open window menu for the world."

	| menu |
	menu _ self menu: 'open...'.
	menu defaultTarget: ToolSet default.
	menu addList: ToolSet menuItems.
	menu defaultTarget: self.
	self fillIn: menu from: {
		nil.
		{'file...' . { self . #openFileDirectly} . 'Lets you open a window on a single file'}.
		{'transcript (t)' . {self . #openTranscript}. 'A window used to report messages sent to Transcript' }.
		"{'inner world' . { WorldWindow . #test1} }."
		nil.
	}.
	self fillIn: menu from: self class registeredOpenCommands.
	menu addLine.

	self mvcProjectsAllowed ifTrue:
		[self fillIn: menu from: { {'mvc project' . {self. #openMVCProject} . 'Creates a new project of the classic "mvc" style'} }].

	^ self fillIn: menu from: { 
		{'morphic project' . {self. #openMorphicProject} . 'Creates a new morphic project'}.
	}.! !

!TheWorldMenu methodsFor: 'construction' stamp: 'sw 2/14/2001 17:55'!
projectMenu
	"Build the project menu for the world."
	| menu |

	self flag: #bob0302.

	menu _ self menu: 'projects...'.
	self fillIn: menu from: { 
		{ 'save on server (also makes a local copy)' . { #myProject . #storeOnServer } }.
		{ 'save to a different server' . { #myProject . #saveAs } }.
		{ 'save project on local file only' . { #myWorld . #saveOnFile } }.
		{ 'see if server version is more recent...' . { #myProject . #loadFromServer } }.
		{ 'load project from file...' . { self . #loadProject } }.
		nil.
	}.

	self fillIn: menu from:
		{{'show project hierarchy'. {Project. #showProjectHierarchyInWindow}. 'Opens a window that shows names and relationships of all the projects in your system.'}.
		nil}.

	self mvcProjectsAllowed ifTrue: [
		self fillIn: menu from: {
			{ 'create new mvc project'. { self . #openMVCProject } }.
		}
	].
	self fillIn: menu from: { 
		{ 'create new morphic project' . { self . #openMorphicProject } }.
		nil.
		{ 'go to previous project' . { Project . #returnToPreviousProject } }.
		{ 'go to next project' . { Project . #advanceToNextProject } }.
		{ 'jump to project...' . { #myWorld . #jumpToProject } }.
	}.
	Preferences simpleMenus ifFalse: [
		self fillIn: menu from: { 
			nil.
			{ 'save for future revert' . { #myProject . #saveForRevert } }.
			{ 'revert to saved copy' . { #myProject . #revert } }.
		}.
	].

	^ menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'ar 10/24/2000 14:08'!
remoteMenu
        "Build the Telemorphic menu for the world."

        ^self fillIn: (self menu: 'Telemorphic') from: {
                { 'local host address' . { #myWorld . #reportLocalAddress } }.
                { 'connect remote user' . { #myWorld . #connectRemoteUser } }.
                { 'disconnect remote user' . { #myWorld . #disconnectRemoteUser } }.
                { 'disconnect all remote users' . { #myWorld . #disconnectAllRemoteUsers } }.
        }! !


!TheWorldMenu methodsFor: 'mechanics' stamp: 'dgd 8/26/2003 21:05'!
menu: titleString
	"Create a menu with the given title, ready for filling"

	| menu |
	(menu _ MenuMorph entitled: titleString translated) 
		defaultTarget: self; 
		addStayUpItem;
		commandKeyHandler: self.
	self colorForDebugging: menu.
	^ menu
! !

!TheWorldMenu methodsFor: 'mechanics' stamp: 'RAA 5/24/2000 19:02'!
world: aWorld project: aProject hand: aHand

	myWorld _ aWorld.
	myProject _ aProject.
	myHand _ aHand.! !


!TheWorldMenu methodsFor: 'menu' stamp: 'nk 2/15/2004 09:38'!
addGestureHelpItemsTo: aMenuMorph 
! !


!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:25'!
appearanceDo
	"Build and show the appearance menu for the world."

	self doPopUp: self appearanceMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
changesDo
	"Build the changes menu for the world."

	self doPopUp: self changesMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
debugDo

	self doPopUp: self debugMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 6/12/2000 09:13'!
doPopUp: aMenu

	aMenu popUpForHand: myHand in: myWorld.
! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
helpDo
	"Build and show the help menu for the world."

	self doPopUp: self helpMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
openWindow

	self doPopUp: self openMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
projectDo
	"Build and show the project menu for the world."

	self doPopUp: self projectMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
remoteDo

	self doPopUp: self remoteMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:27'!
standardFontDo
	"Build and show the standard font menu"

	self doPopUp: Preferences fontConfigurationMenu! !


!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'dao 10/1/2004 13:12'!
suppressFlapsString
	"Answer the wording of the suppress-flaps item"

	^ Project current suppressFlapsString! !

!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'RAA 5/26/2000 10:27'!
windowsDo
	"Build the windows menu for the world."

	self doPopUp: self windowsMenu! !

!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'sw 7/22/2002 08:59'!
windowsMenu
        "Build the windows menu for the world."

        ^ self fillIn: (self menu: 'windows') from: {  
                { 'find window' . { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.'}.

                { 'find changed browsers...' . { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}.

                { 'find changed windows...' . { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}.
			nil.

                { 'find a transcript (t)' . { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window'}.

               { 'find a fileList (L)' . { #myWorld . #findAFileList: }. 'Brings an open fileList  to the front, creating one if necessary, and makes it the active window'}.

               { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}.

			{ 'find message names (W)' . { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window'}.

			 nil.
                { #staggerPolicyString . { self . #toggleWindowPolicy }. 'stagger: new windows positioned so you can see a portion of each one.
                tile: new windows positioned so that they do not overlap others, if possible.'}.

                nil.
                { 'collapse all windows' . { #myWorld . #collapseAll }. 'Reduce all open windows to collapsed forms that only show titles.'}.
                { 'expand all windows' . { #myWorld . #expandAll }. 'Expand all collapsed windows back to their expanded forms.'}.
                { 'close top window (w)' . { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.'}.
                { 'send top window to back (\)' . { SystemWindow . #sendTopWindowToBack  }. 'Make the topmost window become the backmost one, and activate the window just beneath it.'}.
			 { 'move windows onscreen' . { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen'}.

                nil.
                { 'delete unchanged windows' . { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.'}.
                { 'delete non-windows' . { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.'}.
                { 'delete both of the above' . { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.'}.

        }! !


!TheWorldMenu methodsFor: '*eToys-action' stamp: 'dgd 9/1/2003 15:05'!
uniTilesClassicString
	^ ((myProject
			parameterAt: #uniTilesClassic
			ifAbsent: [false])
		ifTrue: ['<yes>']
		ifFalse: ['<no>']), 'classic tiles' translated! !


!TheWorldMenu methodsFor: '*eToys-construction' stamp: 'RAA 5/24/2000 22:34'!
playfieldMenu

	^ myWorld playfieldOptionsMenu! !


!TheWorldMenu methodsFor: '*eToys-popups' stamp: 'RAA 5/26/2000 10:26'!
playfieldDo
	"Build the playfield menu for the world."

	self doPopUp: myWorld playfieldOptionsMenu! !

!TheWorldMenu methodsFor: '*eToys-popups' stamp: 'RAA 5/26/2000 10:27'!
scriptingDo

	self doPopUp: self scriptingMenu! !


!TheWorldMenu methodsFor: '*eToys-scripting' stamp: 'ar 3/17/2001 20:16'!
adaptedToWorld: aWorld
	"Can use me but need to adapt myself"
	self adaptToWorld: aWorld.! !


!TheWorldMenu methodsFor: '*flexibleVocabularies-flexibleVocabularies-construction' stamp: 'nk 10/14/2004 07:08'!
scriptingMenu
	"Build the authoring-tools menu for the world."

	^ self fillIn: (self menu: 'authoring tools...') from: { 
		{ 'objects (o)' . { #myWorld . #activateObjectsTool }. 'A searchable source of new objects.'}.
		nil.  "----------"
 		{ 'view trash contents' . { #myWorld . #openScrapsBook:}. 'The place where all your trashed morphs go.'}.
 		{ 'empty trash can' . { Utilities . #emptyScrapsBook}. 'Empty out all the morphs that have accumulated in the trash can.'}.
		nil.  "----------"		

	{ 'new scripting area' . { #myWorld . #detachableScriptingSpace}. 'A window set up for simple scripting.'}.

		nil.  "----------"		
	
		{ 'status of scripts' . {#myWorld . #showStatusOfAllScripts}. 'Lets you view the status of all the scripts belonging to all the scripted objects of the project.'}.
		{ 'summary of scripts' . {#myWorld . #printScriptSummary}. 'Produces a summary of scripted objects in the project, and all of their scripts.'}.
		{ 'browser for scripts' . {#myWorld . #browseAllScriptsTextually}. 'Allows you to view all the scripts in the project in a traditional programmers'' "browser" format'}.


		nil.

		{ 'gallery of players' . {#myWorld . #galleryOfPlayers}. 'A tool that lets you find out about all the players used in this project'}.

"		{ 'gallery of scripts' . {#myWorld . #galleryOfScripts}. 'Allows you to view all the scripts in the project'}."

		{ 'etoy vocabulary summary' . {#myWorld . #printVocabularySummary }. 'Displays a summary of all the pre-defined commands and properties in the pre-defined EToy vocabulary.'}.

		{ 'attempt misc repairs' . {#myWorld . #attemptCleanup}. 'Take measures that may help fix up some things about a faulty or problematical project.'}.

		{ 'remove all viewers' . {#myWorld . #removeAllViewers}. 'Remove all the Viewers from this project.'}.

		{ 'refer to masters' . {#myWorld . #makeAllScriptEditorsReferToMasters }. 'Ensure that all script editors are referring to the first (alphabetically by external name) Player of their type' }.

		nil.  "----------" 

		{ 'unlock locked objects' . { #myWorld . #unlockContents}. 'If any items on the world desktop are currently locked, unlock them.'}.
		{ 'unhide hidden objects' . { #myWorld . #showHiders}. 'If any items on the world desktop are currently hidden, make them visible.'}.
        }! !


!TheWorldMenu methodsFor: '*MorphicExtras-action' stamp: 'sw 8/12/2001 16:36'!
createStandardPartsBin
	"A dead branch -- only reachable now from pre-existing menus that the user may have kept up"

	ObjectsTool newStandAlone openInHand! !

!TheWorldMenu methodsFor: '*MorphicExtras-action' stamp: 'sw 8/12/2001 17:13'!
launchCustomPartsBin
	"A dead branch -- only reachable now from pre-existing menus that the user may have kept up"

	ObjectsTool newStandAlone openInHand! !

!TheWorldMenu methodsFor: '*MorphicExtras-action' stamp: 'sw 4/30/2001 20:47'!
toggleFlapSuppressionInProject
	"Toggle whether global flaps are suppressed in this project.  Obsolete, retained for bkwrd compatibility with preexisting persistent menus."

	self flag: #toRemove.
	self inform: 'This is an obsolete menu -- please delete it'! !


!TheWorldMenu methodsFor: '*MorphicExtras-construction' stamp: 'RAA 6/2/2000 08:48'!
myMenuColor

	| c |
	c _ myWorld color.
	c isColor ifTrue: [^c atLeastAsLuminentAs: 0.2].
	^Color white! !


!TheWorldMenu methodsFor: '*MorphicExtras-mechanics' stamp: 'RAA 6/15/2000 10:16'!
adaptToWorld: aWorld

        myWorld _ aWorld.
        myProject _ nil.                "figure it out if and when needed. maybe make it easier to find"
        myHand _ aWorld primaryHand.! !


!TheWorldMenu methodsFor: '*MorphicExtras-windows & flaps menu' stamp: 'sw 4/24/2001 10:29'!
flapsDo
	"Put up the flaps menu for the world."

	self doPopUp: self flapsMenu! !

!TheWorldMenu methodsFor: '*MorphicExtras-windows & flaps menu' stamp: 'sw 4/23/2001 11:24'!
flapsMenu
	"Build the flaps menu for the world."

	| aMenu |
	aMenu _ UpdatingMenuMorph new updater: self updateSelector: #formulateFlapsMenu:.
	self formulateFlapsMenu: aMenu.
	^ aMenu! !

!TheWorldMenu methodsFor: '*MorphicExtras-windows & flaps menu' stamp: 'dao 10/1/2004 13:45'!
formulateFlapsMenu: aMenu
	"Fill aMenu with appropriate content"

	aMenu addTitle: 'flaps' translated.
	aMenu addStayUpItem.
	Preferences classicNavigatorEnabled ifTrue:
		[aMenu
			addUpdating: #navigatorShowingString
			enablementSelector: #enableProjectNavigator
			target: Preferences
			selector: #togglePreference: 
			argumentList: #(showProjectNavigator).
		aMenu balloonTextForLastItem: (Preferences preferenceAt: #showProjectNavigator) helpString translated].

	Flaps sharedFlapsAllowed
		ifTrue:
			[self fillIn: aMenu from:
				{{#suppressFlapsString.
					{Project current. #toggleFlapsSuppressed}.
				'Whether prevailing flaps should be shown in the project right now or not.'}}.

			aMenu addUpdating: #automaticFlapLayoutString  target: Preferences selector: #togglePreference: argumentList: #(automaticFlapLayout).
			aMenu balloonTextForLastItem: (Preferences preferenceAt: #automaticFlapLayout) helpString translated.

			aMenu addLine.
			Flaps addIndividualGlobalFlapItemsTo: aMenu].

     self fillIn: aMenu from: {
			nil.

               {'make a new flap'.
			{Flaps. #addLocalFlap}.
			'Create a new flap.  You can later make it into a shared flap is you wish.'}.

			nil.}.
	Flaps sharedFlapsAllowed
		ifTrue:
			[aMenu addWithLabel: 'put shared flaps on bottom' translated enablementSelector: #showSharedFlaps
				target: Flaps selector: #sharedFlapsAlongBottom argumentList: #().
			aMenu balloonTextForLastItem: 'Group all the standard shared flaps along the bottom edge of the screen' translated.

			self fillIn: aMenu from: {
				{'destroy all shared flaps'.
				{Flaps. #disableGlobalFlaps}.
				'Destroy all the shared flaps and disable their use in all projects.'}}]
		ifFalse:
			[aMenu add: 'install default shared flaps' translated target: Flaps action: #enableGlobalFlaps.
			aMenu balloonTextForLastItem: 'Create the default set of shared flaps' translated.
			aMenu add: 'install etoy flaps' translated target: Flaps action: #enableEToyFlaps.
			aMenu balloonTextForLastItem: 'Put up the default etoy flaps: a custom Suplies flap and the Navigator flap' translated.
			aMenu addLine].

	self fillIn: aMenu from: {
			nil.
			{'about flaps...'.
			{Flaps . #explainFlaps}.
			'Gives a window full of details about how to use flaps.'}}! !

!TheWorldMenu methodsFor: '*MorphicExtras-windows & flaps menu' stamp: 'sw 4/24/2001 10:42'!
globalFlapsEnabled
	"Answer whether global flaps are enabled.  Retained for the benefit of preexisting menus/butons that may call this"

	^ Flaps sharedFlapsAllowed! !

!TheWorldMenu methodsFor: '*MorphicExtras-windows & flaps menu' stamp: 'sw 4/30/2001 10:31'!
newGlobalFlapString
	"Answer a string for the new-global-flap item in the flap menu.  Obsolete; retained momentarily for the benefit of preexisting persistent menus."

	self flag: #toRemove.
	^ 'make a new shared flap'! !


!TheWorldMenu methodsFor: '*MorphicExtras-*morphic-Postscript Canvases' stamp: 'RAA 2/1/2001 15:55'!
printWorldOnFile
	"Ask the user for a filename and print the world as postscript."

	myWorld printPSToFileNamed: 'SqueakScreen'
! !


!TheWorldMenu methodsFor: '*Tools' stamp: 'ar 7/16/2005 19:47'!
browseRecentLog
	ChangeList browseRecentLog! !

!TheWorldMenu methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
inspectWorldModel
	| insp |

	insp := InspectorBrowser openAsMorphOn: myWorld model.
	myWorld addMorph: insp; startStepping: insp! !

!TheWorldMenu methodsFor: '*Tools' stamp: 'RAA 5/26/2000 08:43'!
openChangeSorter1

	ChangeSorter new morphicWindow openInWorld: myWorld! !

!TheWorldMenu methodsFor: '*Tools' stamp: 'RAA 5/26/2000 08:43'!
openChangeSorter2

	DualChangeSorter new morphicWindow openInWorld: myWorld! !

!TheWorldMenu methodsFor: '*Tools' stamp: 'sw 7/28/2001 02:11'!
openMessageNames
	"Bring a MessageNames tool to the front"

	MessageNames openMessageNames! !

!TheWorldMenu methodsFor: '*Tools' stamp: 'ar 7/16/2005 20:02'!
openProcessBrowser
	ProcessBrowser open! !

!TheWorldMenu methodsFor: '*Tools' stamp: 'RAA 5/24/2000 18:50'!
openSelectorBrowser

	SelectorBrowser new morphicWindow openInWorld! !

!TheWorldMenu methodsFor: '*Tools' stamp: 'ar 3/17/2001 23:40'!
startThenBrowseMessageTally
	(self confirm: 'MessageTally will start now,
and stop when the cursor goes
to the top of the screen')
		ifTrue: [TimeProfileBrowser
				onBlock: [[Sensor peekMousePt y > 10]
						whileTrue: [World doOneCycle]]]! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TheWorldMenu class
	instanceVariableNames: ''!

!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'ar 9/27/2005 20:13'!
loadSqueakMap
	"Load the externally-maintained SqueakMap package if it is not already loaded.  Based on code by Göran Hultgren"

	| server addr answer |
	Socket initializeNetwork.
	server := #('map1.squeakfoundation.org' 'map2.squeakfoundation.org' 'map.squeak.org' 'map.bluefish.se' 'marvin.bluefish.se:8000')
		detect: [:srv |
			addr := NetNameResolver addressForName: (srv upTo: $:) timeout: 5.
			addr notNil and: [
				answer := HTTPSocket httpGet: ('http://', srv, '/sm/ping').
				answer isString not and: [answer contents = 'pong']]]
		ifNone: [^ self inform: 'Sorry, no SqueakMap master server responding.'].
	server ifNotNil: ["Ok, found an SqueakMap server"
		ChangeSet newChangesFromStream:
			((('http://', server, '/sm/packagebyname/squeakmap/downloadurl')
			asUrl retrieveContents content) asUrl retrieveContents content unzipped
			readStream)
		named: 'SqueakMap']! !

!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'sw 11/11/2002 00:27'!
openPackageLoader
	"If this method is reached, it means that SMLoader has not yet been loaded; after SqueakMap has come into the image, a different receiver/selector will have been installed under 'Package Loader'; if this method is reached when theoretically SqueakMap is already loaded, presumably this is a grandfathered menu item in a still-up menu, so get the message on to its appropriate recipient."

	| loaderClass |
	((loaderClass _ Smalltalk at: #SMLoader ifAbsent: [nil]) isKindOf: Class)
		ifTrue:
			[^ loaderClass open].

	(self confirm: 
'This requires that you first install "SqueakMap" into your image.
SqueakMap is a new architecture for finding, installing, and
publishing packages in Squeak.
Would you like to install SqueakMap now?' )
		ifTrue:
			[self loadSqueakMap]! !

!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'sw 11/10/2002 22:56'!
registerOpenCommand: anArray
	"The array received should be of form {'A Label String'. {TargetObject. #command}  'A Help String'} ; the final element is optional but if present will be used to supply balloon help for the menu item in the Open menu.
	If any previous registration of the same label string is already known, delete the old one."

	self unregisterOpenCommand: anArray first.
	OpenMenuRegistry addLast: anArray! !

!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'nk 6/29/2003 13:56'!
registeredOpenCommands
	"Answer the list of dynamic open commands, sorted by description"
	
	^self registry asArray sort: [ :a :b | a first asLowercase < b first asLowercase ]! !

!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'nk 6/29/2003 13:55'!
registry
	"Answer the registry of dynamic open commands"
	
	^OpenMenuRegistry ifNil: [OpenMenuRegistry _ OrderedCollection new].
! !

!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'ar 9/27/2005 21:49'!
removeObsolete
	"Remove all obsolete commands"	
	self registry removeAllSuchThat: [:e | e second first class isObsolete].! !

!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'nk 6/29/2003 13:55'!
unregisterOpenCommand: label
	"Remove the open command with the given label from the registry"
	
	self registry removeAllSuchThat: [:e | e first = label]! !

!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'nk 6/29/2003 13:55'!
unregisterOpenCommandWithReceiver: aReceiver
	"Remove the open command with the given object as receiver from the registry"
	
	self registry removeAllSuchThat: [:e | e second first == aReceiver]! !
Object subclass: #ThirtyTwoBitRegister
	instanceVariableNames: 'hi low'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Digital Signatures'!
!ThirtyTwoBitRegister commentStamp: '<historical>' prior: 0!
I represent a 32-bit register. An instance of me can hold any non-negative integer in the range [0..(2^32 - 1)]. Operations are performed on my contents in place, like a hardware register, and results are always modulo 2^32.

This class is primarily meant for use by the SecureHashAlgorithm class.
!


!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:03'!
asInteger
	"Answer the integer value of my current contents."

	^ (hi bitShift: 16) + low
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/7/1999 15:26'!
hi

	^ hi
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:07'!
load: anInteger
	"Set my contents to the value of given integer."

	low _ anInteger bitAnd: 16rFFFF.
	hi _ (anInteger bitShift: -16) bitAnd: 16rFFFF.
	self asInteger = anInteger
		ifFalse: [self error: 'out of range: ', anInteger printString].
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:07'!
loadFrom: aByteArray at: index
	"Load my 32-bit value from the four bytes of the given ByteArray starting at the given index. Consider the first byte to contain the most significant bits of the word (i.e., use big-endian byte ordering)."

	hi _ ((aByteArray at: index) bitShift: 8) + ( aByteArray at: index + 1).
	low _ ((aByteArray at: index + 2) bitShift: 8) + ( aByteArray at: index + 3).
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/7/1999 15:26'!
low

	^ low! !


!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:36'!
+= aThirtTwoBitRegister
	"Replace my contents with the sum of the given register and my current contents."

	| lowSum |
	lowSum _ low + aThirtTwoBitRegister low.
	hi _ (hi + aThirtTwoBitRegister hi + (lowSum bitShift: -16)) bitAnd: 16rFFFF.
	low _ lowSum bitAnd: 16rFFFF.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:41'!
bitAnd: aThirtTwoBitRegister
	"Replace my contents with the bitwise AND of the given register and my current contents."

	hi _ hi bitAnd: aThirtTwoBitRegister hi.
	low _ low bitAnd: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:40'!
bitInvert
	"Replace my contents with the bitwise inverse my current contents."

	hi _ hi bitXor: 16rFFFF.
	low _ low bitXor: 16rFFFF.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:40'!
bitOr: aThirtTwoBitRegister
	"Replace my contents with the bitwise OR of the given register and my current contents."

	hi _ hi bitOr: aThirtTwoBitRegister hi.
	low _ low bitOr: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:38'!
bitXor: aThirtTwoBitRegister
	"Replace my contents with the bitwise exclusive OR of the given register and my current contents."

	hi _ hi bitXor: aThirtTwoBitRegister hi.
	low _ low bitXor: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 23:09'!
leftRotateBy: bits
	"Rotate my contents left by the given number of bits, retaining exactly 32 bits."
	"Details: Perform this operation with as little LargeInteger arithmetic as possible."

	| bitCount s1 s2 newHi |
	"ensure bitCount is in range [0..32]"
	bitCount _ bits \\ 32.
	bitCount < 0 ifTrue: [bitCount _ bitCount + 32].

	bitCount > 16
		ifTrue: [
			s1 _ bitCount - 16.
			s2 _ s1 - 16.
			newHi _ ((low bitShift: s1) bitAnd: 16rFFFF) bitOr: (hi bitShift: s2).
			low _ ((hi bitShift: s1) bitAnd: 16rFFFF) bitOr: (low bitShift: s2).
			hi _ newHi]
		ifFalse: [
			s1 _ bitCount.
			s2 _ s1 - 16.
			newHi _ ((hi bitShift: s1) bitAnd: 16rFFFF) bitOr: (low bitShift: s2).
			low _ ((low bitShift: s1) bitAnd: 16rFFFF) bitOr: (hi bitShift: s2).
			hi _ newHi]
! !


!ThirtyTwoBitRegister methodsFor: 'copying' stamp: 'jm 12/7/1999 15:26'!
copy
	"Use the clone primitive for speed."

	<primitive: 148>
	^ super copy
! !


!ThirtyTwoBitRegister methodsFor: 'printing' stamp: 'laza 3/29/2004 12:22'!
printOn: aStream
	"Print my contents in hex with a leading 'R' to show that it is a register object being printed."

	aStream nextPutAll: 'R:'.
	self asInteger storeOn: aStream base: 16.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThirtyTwoBitRegister class
	instanceVariableNames: ''!

!ThirtyTwoBitRegister class methodsFor: 'instance creation' stamp: 'jm 12/14/1999 16:05'!
new
	"Answer a new instance whose initial contents is zero."

	^ super new load: 0
! !
AlignmentMorphBob1 subclass: #ThreadNavigationMorph
	instanceVariableNames: 'listOfPages currentIndex loadedProject'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Navigators'!

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:28'!
buttonExit

	^self makeButton: 'Exit' balloonText: 'Exit the sequence' for: #exitTheSequence.


! !

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:26'!
buttonFirst

	^self makeButton: 'First' balloonText: 'First page in sequence' for: #firstPage
! !

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:27'!
buttonForward

	^self makeButton: 'Forward >' balloonText: 'Next page in sequence' for: #nextPage

! !

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:27'!
buttonLast

	^self makeButton: 'Last' balloonText: 'Last page in sequence' for: #lastPage

! !

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:27'!
buttonPrevious

	^self makeButton: '< Back' balloonText: 'Previous page in sequence' for: #previousPage
! !


!ThreadNavigationMorph methodsFor: 'initialization' stamp: 'RAA 11/9/2000 16:29'!
addButtons

	self addARow: {
		self inAColumn: {self buttonFirst}.
		self inAColumn: {self buttonPrevious}.
		self inAColumn: {self buttonForward}.
		self inAColumn: {self buttonLast}.
		self inAColumn: {self buttonExit}.
	}.
! !

!ThreadNavigationMorph methodsFor: 'initialization' stamp: 'RAA 11/9/2000 16:31'!
colorForButtons

	^color darker! !

!ThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color red lighter! !

!ThreadNavigationMorph methodsFor: 'initialization' stamp: 'RAA 11/9/2000 16:31'!
fontForButtons

	^TextStyle defaultFont! !

!ThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:28'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self layoutInset: 6;
	  hResizing: #shrinkWrap;
	  vResizing: #shrinkWrap;
	  useRoundedCorners;
	  ensureSuitableDefaults;
	  addButtons! !

!ThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 9/19/2003 15:23'!
makeButton: aString balloonText: anotherString for: aSymbol 
	^ SimpleButtonDelayedMenuMorph new target: self;
		 borderColor: #raised;
		 color: self colorForButtons;
		 label: aString translated font: self fontForButtons;
		 setBalloonText: anotherString translated;
		 actionSelector: aSymbol! !


!ThreadNavigationMorph methodsFor: 'menu' stamp: 'RAA 11/9/2000 17:50'!
showMenuFor: actionSelector event: evt

	"no-op here"! !


!ThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 6/28/2000 08:29'!
deleteCurrentPage

	| outerWrapper |

	loadedProject ifNil: [^self].
	outerWrapper _ loadedProject world ownerThatIsA: EmbeddedWorldBorderMorph.
	outerWrapper ifNil: [^self].
	outerWrapper delete.
	loadedProject _ nil.

! !

!ThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 11/10/2000 11:37'!
ensureSuitableDefaults

	listOfPages ifNil: [listOfPages _ OrderedCollection new].
	currentIndex ifNil: [currentIndex _ 0].

! !

!ThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 6/28/2000 08:32'!
exitTheSequence

	self deleteCurrentPage.
	self delete.! !

!ThreadNavigationMorph methodsFor: 'navigation' stamp: 'nb 6/17/2003 12:25'!
firstPage

	listOfPages isEmpty ifTrue: [^Beeper beep].
	currentIndex _ 1.
	self loadPageWithProgress.! !

!ThreadNavigationMorph methodsFor: 'navigation' stamp: 'nb 6/17/2003 12:25'!
lastPage

	listOfPages isEmpty ifTrue: [^Beeper beep].
	currentIndex _ listOfPages size.
	self loadPageWithProgress.! !

!ThreadNavigationMorph methodsFor: 'navigation' stamp: 'nk 7/30/2004 21:47'!
navigateFromKeystroke: aChar 
	"A character was typed in an effort to do interproject navigation along the receiver's thread"

	| ascii |
	ascii := aChar asciiValue.
	(#(29 31 32) includes: ascii) ifTrue: [^self nextPage].	"right arrow, down arrow, space"
	(#(8 28 30) includes: ascii) ifTrue: [^self previousPage].	"left arrow, up arrow, backspace"
	(#(1) includes: ascii) ifTrue: [^self firstPage].
	(#(4) includes: ascii) ifTrue: [^self lastPage].
	Beeper beep! !

!ThreadNavigationMorph methodsFor: 'navigation' stamp: 'nb 6/17/2003 12:25'!
nextPage

	self currentIndex >= listOfPages size ifTrue: [^Beeper beep].
	currentIndex _ self currentIndex + 1.
	self loadPageWithProgress.! !

!ThreadNavigationMorph methodsFor: 'navigation' stamp: 'nb 6/17/2003 12:25'!
previousPage

	self currentIndex <= 1 ifTrue: [^Beeper beep].
	currentIndex _ self currentIndex - 1.
	self loadPageWithProgress.! !


!ThreadNavigationMorph methodsFor: 'stepping' stamp: 'RAA 11/9/2000 16:33'!
step

	| delta |

	owner == self world ifFalse: [^ self].
	owner addMorphInLayer: self.
	delta _ self bounds amountToTranslateWithin: self worldBounds.
	delta = (0 @ 0) ifFalse: [self position: self position + delta].
! !

!ThreadNavigationMorph methodsFor: 'stepping' stamp: 'RAA 6/28/2000 08:22'!
stepTime

	^250! !

!ThreadNavigationMorph methodsFor: 'stepping' stamp: 'RAA 6/27/2000 17:59'!
wantsSteps

	^true! !


!ThreadNavigationMorph methodsFor: 'private' stamp: 'RAA 11/9/2000 16:52'!
currentIndex

	^currentIndex! !

!ThreadNavigationMorph methodsFor: 'private' stamp: 'RAA 6/27/2000 18:49'!
listOfPages: aCollection

	listOfPages _ aCollection! !

!ThreadNavigationMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 13:24'!
loadPage
	| theProject projectInfo url gotoPage theBook |
	projectInfo := listOfPages at: currentIndex.
	url := projectInfo first.
	gotoPage := projectInfo at: 2 ifAbsent: [nil].
	[Project fromUrl: url] on: ProjectEntryNotification
		do: 
			[:ex | 
			self deleteCurrentPage.
			theProject := ex projectToEnter enterAsActiveSubprojectWithin: self world.
			theProject world showExpandedView.
			loadedProject := theProject.
			gotoPage ifNotNil: 
					[theBook := loadedProject world findA: BookMorph.
					theBook ifNotNil: [theBook goToPage: gotoPage]].
			^loadedProject]! !

!ThreadNavigationMorph methodsFor: 'private' stamp: 'RAA 6/28/2000 08:26'!
loadPageWithProgress

	ComplexProgressIndicator new 
		targetMorph: self;
		historyCategory: 'project loading';
		withProgressDo: [self loadPage]
! !

!ThreadNavigationMorph methodsFor: 'private' stamp: 'RAA 6/27/2000 18:09'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^15		"Navigators are behind menus and balloons, but in front of most other stuff"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThreadNavigationMorph class
	instanceVariableNames: ''!

!ThreadNavigationMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:20'!
example1
"
ThreadNavigationMorph example1
"
	self new
		listOfPages: #(
			('ftp://209.143.91.36/Drive A Car')
			('ftp://209.143.91.36/Teachers & NewTech' 1)
			('ftp://209.143.91.36/Teachers & NewTech' 2)
			('ftp://209.143.91.36/Lander')
		);
		openInWorld! !
ImageMorph subclass: #ThreePhaseButtonMorph
	instanceVariableNames: 'offImage pressedImage state target actionSelector arguments actWhen'
	classVariableNames: 'AuthorModeOwner'
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!ThreePhaseButtonMorph commentStamp: '<historical>' prior: 0!
A button morph with separate images for on, off, and pressed with the mouse. 

When the event actWhen occurs, send actionSelector with 'arguments' to target.  For other events, default to my eventHandler.  The current event is not supplied in the arguments to the actionSelector.  

image (a.k.a. onImage) may not be nil.  offImage and pressedImage may be nil.  nil there means be transparent and show the underlying object.  

Tools for debugging:
Display the images momentarily under program control (for positioning) (self is an instance).
	self state: #on.  self state: #off.
	self state: #pressed.  self state: #off.
Display a rectangle where the button is.
	Display fillWithColor: bounds + (self world viewBox origin).
	self invalidRect: bounds.!


!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:49'!
actionSelector

	^ actionSelector
! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:49'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 7/1/97 12:39'!
arguments
	^ arguments! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 7/1/97 08:39'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'!
offImage
	^ offImage! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:08'!
offImage: aForm
	offImage _ aForm.
	self invalidRect: self bounds.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'!
onImage
	^ image! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:08'!
onImage: aForm
	image _ aForm.
	self invalidRect: self bounds.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'!
pressedImage
	^ pressedImage! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:09'!
pressedImage: aForm
	pressedImage _ aForm.
	self invalidRect: self bounds.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 11:01'!
state: newState
	"Change the image and invalidate the rect."

	newState == state ifTrue: [^ self].
	state _ newState.
	self invalidRect: bounds.	"All three images must be the same size"! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:50'!
target

	^ target
! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:50'!
target: anObject

	target _ anObject
! !


!ThreePhaseButtonMorph methodsFor: 'button' stamp: 'dgd 2/22/2003 18:45'!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target notNil and: [actionSelector notNil]) 
		ifTrue: 
			[Cursor normal 
				showWhile: [target perform: actionSelector withArguments: arguments].
			target isMorph ifTrue: [target changed]]! !


!ThreePhaseButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:02'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!ThreePhaseButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:01'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
offImage _ offImage veryDeepCopyWith: deepCopier.
pressedImage _ pressedImage veryDeepCopyWith: deepCopier.
state _ state veryDeepCopyWith: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		Symbol"
"arguments _ arguments.		Weakly copied"
actWhen _ actWhen.		"Symbol"! !


!ThreePhaseButtonMorph methodsFor: 'drawing' stamp: 'tk 10/9/2002 10:20'!
drawOn: aCanvas

	state == #off ifTrue: [
		offImage ifNotNil: [aCanvas translucentImage: offImage at: bounds origin]].
	state == #pressed ifTrue: [
		pressedImage ifNotNil: [aCanvas translucentImage: pressedImage at: bounds origin]].
	state == #on ifTrue: [
		image ifNotNil: [aCanvas translucentImage: image at: bounds origin]].! !


!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'RAA 8/15/2000 16:27'!
doButtonAction: evt
	| moreArgs |
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	target ifNil: [^self].
	actionSelector ifNil: [^self].
	Cursor normal showWhile: [
		moreArgs _ actionSelector numArgs > arguments size ifTrue: [
			arguments copyWith: evt
		] ifFalse: [
			arguments
		].
		target perform: actionSelector withArguments: moreArgs
	]! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'tk 6/30/97 10:52'!
handlesMouseDown: evt

	^ true
! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:18'!
handlesMouseStillDown: evt
	^actWhen == #whilePressed! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:16'!
mouseDown: evt
	| now dt |
	self state: #pressed.
	actWhen == #buttonDown
		ifTrue:
			[self doButtonAction]
		ifFalse:
			[now _ Time millisecondClockValue.
			super mouseDown: evt.
			"Allow on:send:to: to set the response to events other than actWhen"
			dt _ Time millisecondClockValue - now max: 0.  "Time it took to do"
			dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
	self mouseStillDown: evt.! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:18'!
mouseMove: evt
	(self containsPoint: evt cursorPoint)
		ifTrue: [self state: #pressed.
				super mouseMove: evt]
				"Allow on:send:to: to set the response to events other than actWhen"
		ifFalse: [self state: #off].
! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:17'!
mouseStillDown: evt
	actWhen == #whilePressed ifFalse:[^self].
	(self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:17'!
mouseUp: evt
	"Allow on:send:to: to set the response to events other than actWhen"
	actWhen == #buttonUp ifFalse: [^super mouseUp: evt].

	(self containsPoint: evt cursorPoint) ifTrue: [
		self state: #on.
		self doButtonAction: evt
	] ifFalse: [
		self state: #off.
		target ifNotNil: [target mouseUpBalk: evt]
	].
	"Allow owner to keep it selected for radio buttons"
! !


!ThreePhaseButtonMorph methodsFor: 'geometry' stamp: 'tk 7/1/97 09:14'!
extent: aPoint
	"Do it normally"
	
	self changed.
	bounds _ bounds topLeft extent: aPoint.
	self layoutChanged.
	self changed.
! !


!ThreePhaseButtonMorph methodsFor: 'initialization' stamp: 'tk 7/1/97 08:34'!
initialize

	super initialize.
	state _ #off.
	target _ nil.
	actionSelector _ #flash.
	arguments _ EmptyArray.
	actWhen _ #buttonUp.

	"self on: #mouseStillDown send: #dragIfAuthoring: to: self."
		"real move should include a call on dragIfAuthoring: "! !


!ThreePhaseButtonMorph methodsFor: 'printing' stamp: 'dgd 2/22/2003 18:45'!
printOn: aStream 
	| string |
	aStream nextPutAll: '3PButton'.
	arguments notEmpty 
		ifTrue: [string := arguments at: (2 min: arguments size)].
	aStream nextPutAll: '('.
	(string notNil and: [string ~~ self]) 
		ifTrue: 
			[aStream
				print: string;
				space]
		ifFalse: 
			[aStream
				print: actionSelector;
				space].
	aStream
		print: self identityHash;
		nextPutAll: ')'! !


!ThreePhaseButtonMorph methodsFor: 'stepping and presenter' stamp: 'ar 10/11/2000 14:05'!
step
	(self hasProperty: #doesButtonAction) ifTrue:[
		self doButtonAction.
		self setProperty: #didButtonAction toValue: true.
	].! !


!ThreePhaseButtonMorph methodsFor: 'submorphs-add/remove' stamp: 'tk 6/30/97 10:49'!
actWhen: condition
	"Accepts symbols:  #buttonDown, #buttonUp, and #whilePressed"
	actWhen _ condition! !


!ThreePhaseButtonMorph methodsFor: 'testing' stamp: 'sw 3/8/1999 13:56'!
isOn
	^ state == #on! !

!ThreePhaseButtonMorph methodsFor: 'testing' stamp: 'ar 10/11/2000 14:05'!
stepTime
	(self hasProperty: #doesButtonAction) ifTrue:[^1].
	^super stepTime! !

!ThreePhaseButtonMorph methodsFor: 'testing' stamp: 'ar 10/11/2000 14:06'!
wantsSteps
	^(self hasProperty: #doesButtonAction) or:[super wantsSteps]! !


!ThreePhaseButtonMorph methodsFor: '*MorphicExtras-accessing' stamp: 'tk 6/29/97 21:04'!
authorModeOwner: aMorph
	AuthorModeOwner _ aMorph! !

!ThreePhaseButtonMorph methodsFor: '*MorphicExtras-accessing' stamp: 'tk 6/29/97 21:02'!
dragIfAuthoring: evt
	"Allow simple dragging if the class var is set to my owner."
	owner == AuthorModeOwner ifTrue: [
		self center: evt cursorPoint].
	^ owner == AuthorModeOwner! !


!ThreePhaseButtonMorph methodsFor: '*MorphicExtras-copying' stamp: 'jm 7/28/97 11:56'!
updateReferencesUsing: aDictionary
	"If the arguments array points at a morph we are copying, then update it to point to the new copy. This method also copies the arguments array itself, which is important!!"

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !


!ThreePhaseButtonMorph methodsFor: '*MorphicExtras-e-toy support' stamp: 'ar 3/17/2001 20:18'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	self target: (target adaptedToWorld: aWorld).! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThreePhaseButtonMorph class
	instanceVariableNames: ''!

!ThreePhaseButtonMorph class methodsFor: 'class initialization' stamp: 'ar 5/25/2000 18:01'!
initialize
	"ThreePhaseButtonMorph initialize"
	| extent inset |
	extent _ 12@12.
	inset _ 3.

	#('CheckBoxOff' 'CheckBoxOn' 'CheckBoxPressed') do: [:button |
		| f r |
		f _ ColorForm extent: extent depth: 1.
		f colors: {Color transparent. Color black}.
		f borderWidth: 1.
		r _ f boundingBox insetBy: inset.
		button = 'CheckBoxPressed' ifTrue: [f border: r width: 1].
		button = 'CheckBoxOn' ifTrue: [f fillBlack: r].
		ScriptingSystem saveForm: f atKey: button].

	#('RadioButtonOff' 'RadioButtonOn' 'RadioButtonPressed') do: [:button |
		| f r c |
		f _ ColorForm extent: extent depth: 1.
		f colors: {Color transparent. Color black}.
		r _ f boundingBox.
		c _ f getCanvas.
		c frameOval: r color: Color black.
		r _ r insetBy: inset.
		button = 'RadioButtonPressed' ifTrue:
			[c frameOval: r color: Color black].
		button = 'RadioButtonOn' ifTrue:
			[c fillOval: r color: Color black].
		ScriptingSystem saveForm: f atKey: button]! !


!ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'bf 10/8/1999 15:23'!
checkBox
	"Answer a button pre-initialized with checkbox images."
	| f |
	^self new
		onImage: (f _ ScriptingSystem formAtKey: 'CheckBoxOn');
		pressedImage: (ScriptingSystem formAtKey: 'CheckBoxPressed');
		offImage: (ScriptingSystem formAtKey: 'CheckBoxOff');
		extent: f extent + (2@0);
		yourself
! !

!ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'bf 10/8/1999 15:14'!
radioButton
	"Answer a button pre-initialized with radiobutton images."
	| f |
	^self new
		onImage: (f _ ScriptingSystem formAtKey: 'RadioButtonOn');
		pressedImage: (ScriptingSystem formAtKey: 'RadioButtonPressed');
		offImage: (ScriptingSystem formAtKey: 'RadioButtonOff');
		extent: f extent + (2@0);
		yourself
! !
SketchMorph subclass: #Thumbnail
	instanceVariableNames: 'maximumWidth minimumHeight'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-PartsBin'!
!Thumbnail commentStamp: '<historical>' prior: 0!
A morph that serves as a thumbnail of a given form.!


!Thumbnail methodsFor: 'initialization' stamp: 'sw 6/13/2001 17:49'!
initialize
	"Initialize the receiver"

	super initialize.
	self setStandardDefaultMetrics! !

!Thumbnail methodsFor: 'initialization' stamp: 'sw 6/13/2001 18:17'!
maxWidth: maxWidth minHeight: minHeight
	"Set the min and max heights and widths as indicated"

	maximumWidth _ maxWidth.
	minimumHeight _ minHeight! !

!Thumbnail methodsFor: 'initialization' stamp: 'sw 6/13/2001 19:38'!
setStandardDefaultMetrics
	"Provide the current choices for min.max width/height for thumbnails"

	self maxWidth: 60 minHeight: 24! !


!Thumbnail methodsFor: 'thumnail creation' stamp: 'nk 9/1/2004 18:10'!
makeThumbnailFromForm: aForm
	"Make a thumbnail from the form provided, obeying my min and max width and height preferences"

	|  scaleX scaleY margin opaque |
	scaleY _ minimumHeight / aForm height.  "keep height invariant"
	scaleX _ ((aForm width * scaleY) <= maximumWidth)
		ifTrue: [scaleY]  "the usual case; same scale factor, to preserve aspect ratio"
		ifFalse: [scaleY _ maximumWidth / aForm width].

	"self form: (aForm magnify: aForm boundingBox by: (scaleX @ scaleY) smoothing: 2)."
	"Note: A problem with magnify:by: fails to reproduce borders properly.
		The following code does a better job..."
	margin _ 1.0 / (scaleX@scaleY) // 2 max: 0@0.  "Extra margin around border"
	opaque _ (Form extent: aForm extent + margin depth: 32) "fillWhite".
	aForm fixAlpha displayOn: opaque at: aForm offset negated rule: Form blendAlpha.  "Opaque form shrinks better"
	opaque fixAlpha.
	self form: (opaque magnify: opaque boundingBox by: (scaleX @ scaleY) smoothing: 2).

	self extent: originalForm extent! !
ThumbnailMorph subclass: #ThumbnailForAllPlayersTool
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!ThumbnailForAllPlayersTool commentStamp: '<historical>' prior: 0!
A thumbnail for use in an All-Players tool!


!ThumbnailForAllPlayersTool methodsFor: 'stepping' stamp: 'sw 7/28/2004 22:23'!
step
	"periodic action"

	| aMorph |
	((aMorph _ objectToView costume) notNil and: [aMorph isInWorld]) ifTrue:
		[super step]  "don't bother changing my readout to blank when/if object disappears"! !

!ThumbnailForAllPlayersTool methodsFor: 'stepping' stamp: 'sw 7/28/2004 22:19'!
stepTime
	"Don't update too aggressively"

	^ 2500! !
ImageMorph subclass: #ThumbnailImageMorph
	instanceVariableNames: 'imagePopupMorph desiredExtent isPopup'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!ThumbnailImageMorph commentStamp: 'wiz 2/19/2006 18:10' prior: 0!
A ThumbnailImageMorph is variant of Lex Spoon's CDScreenShotMorph. It displays a thumbnail of the image stored in imagePopupMorph. As a super class of PopupThumbnail morph it is meant to be a thumbnail w/o the popup action. Basicly it provides a scalable thumbnail with the usual morph event behaviors.

A menu item allows for "photographing" any morph on the screen to become the subject of our images.

Instance Variables
	imagePopupMorph:		<anImageMorph>
	image: 					<aForm>
	desiredExtent			<aPoint>
	isPopup					<aBool>
imagePopupMorph
	- an ImageMorph containing the full sized image.
	- it can be set from a morph image via the sight target menu item.
image
	- holds the scaled thumbnail form of our imagePopupMorph image.
desiredExtent
	- holds the desired extent that the thumbnail is expected to fit within.
	- it is guarded to be positive and non-zero.
	- it can be set by extent: so that the yellow halo handle works.
isPopup
	- true when popup feature is on.
	- toggled from red halo menu
		
Setting the size of the thumbnail works somewhat excentrically because the extent of the thumbnail depends both on the desiredExtent and the aspect ratio of the current popup image.
 
With the popup feature off this morph can be picked up and dropped with the mouse.
When the feature is on, a full sized snapshot will be seen when the mouse is pressed.
Since the mouse can't be used for two things at once, moving the morph must be done with the grab halo or brown move halo.!


!ThumbnailImageMorph methodsFor: 'menu commands' stamp: 'wiz 2/19/2006 14:38'!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addWorldTargetSightingItems: aCustomMenu hand: aHandMorph .
	self addPopupMenuItems: aCustomMenu hand: aHandMorph! !

!ThumbnailImageMorph methodsFor: 'menu commands' stamp: 'wiz 2/19/2006 14:41'!
addPopupMenuItems: aCustomMenu hand: aHandMorph
" Show and toggle the popUp boolean menu item."

	aCustomMenu addLine. 
	
	aCustomMenu addUpdating: #popupFeatureString  target: self 
	selector: #togglePopupFeature argumentList: #() .

	! !


!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 9/14/2005 23:53'!
extent: anExtentPoint
"Set the desired extetnt for the thumbnail. It is guarenteed to fit within the desired extent.
The desitedExtent is guarded to prevent deviant forms from being attempted."

self changed . "We might be bigger before we change."
desiredExtent := anExtentPoint guarded.
self newThumbnail: imagePopupMorph image .
! !

!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 9/14/2005 23:55'!
newImage: aForm
	"Use aForm as the new popupImage and update the thumbnail image."
	
	imagePopupMorph 
		ifNil: [ imagePopupMorph :=   aForm asMorph]
		ifNotNil: [ imagePopupMorph image: aForm ] .
		
		self newThumbnail: aForm
		
		! !

!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 2/19/2006 14:12'!
newThumbnail: aForm
	"Use aForm as the new popupImage and update the thumbnail image."
	| scale  thumbForm border smoothing |

		scale := aForm extent scaleTo: desiredExtent .
		smoothing := (scale x < 1.0 or: [ scale y < 1.0 ]) ifTrue: [ 2 ] ifFalse: [ 1 ] .
		
		thumbForm := aForm magnify: aForm boundingBox by: scale smoothing: smoothing .
		
		self image: thumbForm . "heres where we put in a thumbnail"
		"We need the following to keep the border the right size. Otherwise it will shrink."
		(border := self borderStyle) == BorderStyle default ifFalse: [ self borderStyle: border ] .
		
		"We have changed clear the old and show the new"
		self invalidRect: self bounds . ! !

!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 2/19/2006 14:48'!
popupFeatureString
	"Answer the string to be shown in a menu to represent the  
	stickiness status"
	^ (self yesNoStringFor: (isPopup == true ) )
		, 'Popup feature' translated! !

!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 11/3/2005 01:17'!
target: aMorph
	"Snap aMorphs current image and show its thumbnail"
	
	self newImage: aMorph imageForm fixAlpha .
		! !

!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 2/19/2006 14:49'!
togglePopupFeature
	"Change the popup behaviour. Return the new boolean value."
	
	^isPopup := isPopup ~~ true .
		! !

!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 2/19/2006 14:21'!
yesNoStringFor: aBool
	"Answer the string to be shown in a menu to represent the  
	yes/no status"
	^ (aBool
		ifTrue: ['<yes>']
		ifFalse: ['<no>'])
		! !


!ThumbnailImageMorph methodsFor: 'event handling' stamp: 'wiz 2/19/2006 12:51'!
handlesMouseDown: evt
	^isPopup == true! !

!ThumbnailImageMorph methodsFor: 'event handling' stamp: 'wiz 2/19/2006 12:51'!
mouseDown: evt
	
	
	imagePopupMorph center: (self localPointToGlobal: evt position).
	imagePopupMorph bounds: (imagePopupMorph bounds translatedAndSquishedToBeWithin: World bounds).
	imagePopupMorph openInWorld
! !

!ThumbnailImageMorph methodsFor: 'event handling' stamp: 'wiz 2/19/2006 12:50'!
mouseUp: evt
	imagePopupMorph ifNotNil: [
		imagePopupMorph delete	.
		 ]! !


!ThumbnailImageMorph methodsFor: 'initialization' stamp: 'wiz 9/15/2005 17:38'!
initialize
super initialize .
desiredExtent := 90 asPoint.
self newImage: DefaultForm! !

!ThumbnailImageMorph methodsFor: 'initialization' stamp: 'wiz 9/21/2005 22:26'!
initializeWithDisplay
super initialize .
desiredExtent := 90 asPoint.
self newImage: Display! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThumbnailImageMorph class
	instanceVariableNames: ''!

!ThumbnailImageMorph class methodsFor: 'examples' stamp: 'wiz 9/21/2005 22:31'!
ofDisplay
"ThumbnailImageMorph ofDisplay openInHand"
^self new initializeWithDisplay .! !
RectangleMorph subclass: #ThumbnailMorph
	instanceVariableNames: 'objectToView viewSelector lastSketchForm lastFormShown drawTime'
	classVariableNames: 'EccentricityThreshhold RecursionDepth RecursionMax'
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!ThumbnailMorph commentStamp: 'sw 1/6/2005 03:47' prior: 0!
A Morph that views another morph, its objectToView.!


!ThumbnailMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:46'!
getSelector
	"Answer the selector I send to my target to retrieve my value"

	^ viewSelector! !

!ThumbnailMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 17:03'!
getSelector: aSelector
	"Set the selector used to obtain my value"

	self objectToView: objectToView viewSelector: aSelector! !

!ThumbnailMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 17:06'!
putSelector
	"Answer the selector used  for the receiver to send a fresh value back to its target"

	^ nil! !

!ThumbnailMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:39'!
target
	"Answer the object on which I act"

	^ objectToView! !


!ThumbnailMorph methodsFor: 'caching' stamp: 'ar 3/3/2001 19:37'!
releaseCachedState
	super releaseCachedState.
	lastSketchForm _ lastFormShown _ nil.! !


!ThumbnailMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:57'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
objectToView _ deepCopier references at: objectToView ifAbsent: [objectToView].! !

!ThumbnailMorph methodsFor: 'copying' stamp: 'ar 10/26/2000 23:55'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"objectToView _ objectToView.		Weakly copied"
viewSelector _ viewSelector veryDeepCopyWith: deepCopier.
lastSketchForm _ lastSketchForm veryDeepCopyWith: deepCopier.
lastFormShown _ lastFormShown veryDeepCopyWith: deepCopier.
drawTime _ drawTime veryDeepCopyWith: deepCopier.
! !


!ThumbnailMorph methodsFor: 'display' stamp: 'wiz 8/6/2005 22:01'!
drawForForm: aForm on: aCanvas
	"Draw a small view of the given form on the canvas"

	| scale shrunkForm viewedObjectBox interimCanvas |
	viewedObjectBox := aForm boundingBox.
	scale :=  self scaleFor: viewedObjectBox in: self innerBounds.
	interimCanvas := Display defaultCanvasClass extent: viewedObjectBox extent depth: aCanvas depth.
	interimCanvas translateBy: viewedObjectBox topLeft negated 
				during: [:tempCanvas | tempCanvas drawImage: aForm at: 0@0].
	shrunkForm := interimCanvas form magnify: interimCanvas form boundingBox by: scale smoothing: 1.
	lastFormShown := shrunkForm.

	aCanvas paintImage: shrunkForm at: self center - shrunkForm boundingBox center! !

!ThumbnailMorph methodsFor: 'display' stamp: 'wiz 8/6/2005 22:11'!
drawMeOn: aCanvas 
	"Draw a small view of a morph in another place.  Guard against infinite recursion if that morph has a thumbnail of itself inside.  Now also works if the thing to draw is a plain Form rather than a morph."

	| viewedMorphBox scale c shrunkForm aWorld aFormOrMorph  |
	super drawOn: aCanvas.
	((aFormOrMorph := self formOrMorphToView) isForm) 
		ifTrue: [^self drawForForm: aFormOrMorph on: aCanvas].
	(((aFormOrMorph notNil and: [(aWorld := aFormOrMorph world) notNil]) 
		and: [aWorld ~~ aFormOrMorph or: [lastFormShown isNil]]) 
			and: [RecursionDepth + 1 < RecursionMax]) 
			ifTrue: 
				[RecursionDepth := RecursionDepth + 1.
				viewedMorphBox := aFormOrMorph fullBounds.
			scale :=  self scaleFor: viewedMorphBox in: self innerBounds.
				c := Display defaultCanvasClass extent: viewedMorphBox extent
							depth: aCanvas depth.
				c translateBy: viewedMorphBox topLeft negated
					during: 
						[:tempCanvas | 
						"recursion happens here"
						tempCanvas fullDrawMorph: aFormOrMorph].
				shrunkForm := c form 
							magnify: c form boundingBox
							by: scale
							smoothing: 1.
				lastFormShown := shrunkForm.
				RecursionDepth := RecursionDepth - 1]
			ifFalse: 
				["This branch used if we've recurred, or if the thumbnail views a World that's already been rendered once, or if the referent is not in a world at the moment"
				lastFormShown ifNotNil: [shrunkForm := lastFormShown]].
	shrunkForm ifNotNil: 
			[aCanvas paintImage: shrunkForm
				at: self center - shrunkForm boundingBox center]! !

!ThumbnailMorph methodsFor: 'display' stamp: 'wiz 8/6/2005 21:58'!
scaleFor:  viewedMorphBox in: myBox
	"Compute the proper scale for the thumbnail."

	|   scale  scaleX scaleY ratio factor  |
scaleX := myBox width asFloat / viewedMorphBox width.
				scaleY := myBox height asFloat / viewedMorphBox height.
				ratio := scaleX / scaleY.
				factor := 1.0 / EccentricityThreshhold.
				ratio < factor
					ifTrue:
						[scale := (scaleX) @ (factor * scaleY)]
					ifFalse:
						[ratio > EccentricityThreshhold
							ifTrue:
								[scale := (factor * scaleX) @ scaleY]
							ifFalse:
								[scale := scaleX min: scaleY]].
^ scale
! !


!ThumbnailMorph methodsFor: 'drawing' stamp: 'ar 10/26/2000 23:45'!
drawOn: aCanvas
	"Draw a small view of a morph in another place. Guard against infinite recursion if that morph has a thumbnail of itself inside."
	| time |
	time _ Time millisecondClockValue.
	self drawMeOn: aCanvas.
	drawTime _ Time millisecondClockValue - time.
	drawTime < 0 ifTrue:[drawTime _ nil].
! !


!ThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:57'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 1! !

!ThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:56'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.781
		g: 0.781
		b: 0.781! !

!ThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:57'!
initialize
	"Initialize the receiver, obeying a #nominalExtent property if I  
	have one"
	| anExtent |
	super initialize.
	""
	anExtent _ self
				valueOfProperty: #nominalExtent
				ifAbsent: [25 @ 25].
	self
		extent: (anExtent
				)! !

!ThumbnailMorph methodsFor: 'initialization' stamp: 'sw 6/9/2000 18:35'!
objectToView: objectOrNil
	(objectOrNil isMorph and: [objectOrNil allMorphs includes: self]) ifTrue:
		["cannot view a morph containing myself or drawOn: goes into infinite recursion"
		objectToView _ nil.
		^ self].
	objectToView _ objectOrNil! !

!ThumbnailMorph methodsFor: 'initialization' stamp: 'sw 6/9/2000 18:35'!
objectToView: objectOrNil viewSelector: aSelector
	self objectToView: objectOrNil.
	viewSelector _ aSelector! !


!ThumbnailMorph methodsFor: 'scripting' stamp: 'sw 1/6/2005 01:29'!
isEtoyReadout
	"Answer whether the receiver can serve as an etoy readout"

	^ true! !


!ThumbnailMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/14/2004 16:47'!
step
	"Optimization: Don't redraw if we're viewing some kind of SketchMorph and its rotated Form hasn't changed."

	| viewee f |
	viewee _ self actualViewee.
	viewee ifNil: [ self stopStepping. ^self ].
	(viewee isSketchMorph) ifTrue: [
		f _ viewee rotatedForm.
		f == lastSketchForm ifTrue: [^ self].
		lastSketchForm _ f].
	self changed.
! !


!ThumbnailMorph methodsFor: 'testing' stamp: 'ar 5/16/2001 01:41'!
stepTime 
	"Adjust my step time to the time it takes drawing my referent"
	drawTime ifNil:[^ 250].
	^(objectToView updateThresholdForGraphicInViewerTab * drawTime) max: 250.! !


!ThumbnailMorph methodsFor: 'texture support' stamp: 'ar 11/7/1999 22:55'!
installAsWonderlandTextureOn: anActor
	"Make the receiver a texture for the given actor"
	self morphRepresented installAsWonderlandTextureOn: anActor! !


!ThumbnailMorph methodsFor: 'what to view' stamp: 'nk 8/29/2004 17:18'!
actualViewee
	"Return the actual morph to be viewed, or nil if there isn't an appropriate morph to view."

	| aMorph actualViewee |
	aMorph _ self morphToView ifNil: [^ nil]. 
	aMorph isInWorld ifFalse: [^ nil].
	actualViewee _ viewSelector ifNil: [aMorph] ifNotNil: [objectToView perform: viewSelector].
	actualViewee == 0 ifTrue: [^ nil].  "valueAtCursor result for an empty HolderMorph"
	actualViewee ifNil: [actualViewee _ objectToView].
	(actualViewee isPlayerLike) ifTrue: [actualViewee _ actualViewee costume].
	(actualViewee isMorph and: 
		[actualViewee isFlexMorph and: [actualViewee submorphs size = 1]])
			ifTrue: [actualViewee _ actualViewee firstSubmorph].
	^ actualViewee! !

!ThumbnailMorph methodsFor: 'what to view' stamp: 'nk 8/29/2004 17:18'!
formOrMorphToView
	"Answer the form to be viewed, or the morph to be viewed, or nil"

	| actualViewee |
	(objectToView isForm) ifTrue: [^objectToView].
	actualViewee := viewSelector ifNil: [objectToView]
				ifNotNil: [objectToView perform: viewSelector].
	^actualViewee == 0 
		ifTrue: [nil	"valueAtCursor result for an empty HolderMorph"]
		ifFalse: 
			[(actualViewee isPlayerLike) 
				ifTrue: [actualViewee costume]
				ifFalse: [actualViewee]]! !

!ThumbnailMorph methodsFor: 'what to view' stamp: 'nk 8/29/2004 17:18'!
morphToView
	"If the receiver is viewing some object, answer a morph can be thought of as being viewed;  A gesture is made toward generalizing this beyond the morph/player regime, in that a plain blue rectangle is returned rather than simply failing if the referent is not itself displayable."

	objectToView ifNil: [^ nil].
	^ objectToView isMorph
		ifTrue:
			[objectToView]
		ifFalse:
			[(objectToView isPlayerLike)
				ifTrue:
					[objectToView costume]
				ifFalse:
					[RectangleMorph new color: Color blue]]
! !


!ThumbnailMorph methodsFor: '*eToys-scripting' stamp: 'nk 8/29/2004 17:18'!
tearOffTile
	(objectToView isPlayerLike) ifTrue: [^ objectToView tearOffTileForSelf].

	objectToView ifNil: [^ nil].
	^ objectToView isMorph
		ifTrue:
			[objectToView]
		ifFalse:
			[objectToView costume]
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThumbnailMorph class
	instanceVariableNames: ''!

!ThumbnailMorph class methodsFor: 'as yet unclassified' stamp: 'sw 5/3/1998 19:12'!
recursionReset
	"ThumbnailMorph recursionReset"
	"Reset the RecursionDepth counter in case the user interrupted
during a thumbnail being drawn.  Do this just once in a while when no
drawOn: is being called.  tk 9/8/97"

	RecursionDepth _ 0.! !


!ThumbnailMorph class methodsFor: 'class initialization' stamp: 'sw 12/30/2004 00:47'!
initialize
	"Initialize the class variables of ThumbnailMorph"

	RecursionMax _ 2.
	RecursionDepth _ 0.
	EccentricityThreshhold _  Float pi

"ThumbnailMorph initialize"! !
EllipseMorph subclass: #TickIndicatorMorph
	instanceVariableNames: 'stepTime corners index range isTicking lastTick'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!TickIndicatorMorph methodsFor: 'accessing' stamp: 'ar 2/11/2001 19:48'!
color: aColor
	super color: aColor.
	self borderColor: aColor darker.! !

!TickIndicatorMorph methodsFor: 'accessing' stamp: 'ar 2/11/2001 20:31'!
isTicking
	^isTicking ifNil:[false].! !

!TickIndicatorMorph methodsFor: 'accessing' stamp: 'ar 2/11/2001 20:32'!
isTicking: aBool
	isTicking _ aBool.! !

!TickIndicatorMorph methodsFor: 'accessing' stamp: 'ar 2/12/2001 17:40'!
stepTime: aNumber
	stepTime _ aNumber max: 1.! !


!TickIndicatorMorph methodsFor: 'drawing' stamp: 'ar 2/12/2001 17:50'!
drawOn: aCanvas
	| r center cc deg |
	super drawOn: aCanvas.
	corners ifNil:[
		r _ (bounds topCenter - bounds center) r - 2.
		corners _ Array new: 32.
		1 to: corners size do:[:i|
			deg _ 360.0 / corners size * (i-1).
			corners at: i put: (Point r: r degrees: deg-90) asIntegerPoint]].
	index _ index \\ corners size.
	cc _ color darker.
	center _ bounds center.
	1 to: corners size by: 4 do:[:i|
		aCanvas fillRectangle: (center + (corners at: i)-2  extent: 4@4) color: cc.
	].
	cc _ cc darker.
	aCanvas line: center to: center + (corners at: index + 1) width: 2 color: cc.! !


!TickIndicatorMorph methodsFor: 'geometry' stamp: 'ar 2/11/2001 20:12'!
extent: aPoint
	super extent: ((aPoint x max: aPoint y)  asInteger bitClear: 3) asPoint.
	corners _ nil.! !


!TickIndicatorMorph methodsFor: 'initialization' stamp: 'gm 3/10/2003 22:10'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ self defaultColor darker
! !

!TickIndicatorMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:59'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.767
		g: 0.767
		b: 1.0! !

!TickIndicatorMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:59'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""

	self extent: 20 @ 20.
	index _ 0! !


!TickIndicatorMorph methodsFor: 'stepping and presenter' stamp: 'md 8/20/2005 19:03'!
stepAt: nowTick 
	| delta |
	self isTicking 
		ifTrue: 
			[(lastTick isNil or: [nowTick < lastTick]) ifTrue: [lastTick := nowTick].
			delta := (nowTick - lastTick) // self stepTime.
			delta > 0 
				ifTrue: 
					[index := index + delta.
					lastTick := nowTick.
					self changed]]! !


!TickIndicatorMorph methodsFor: 'testing' stamp: 'ar 2/12/2001 17:53'!
stepTime
	^(stepTime ifNil:[125]) max: 50! !

!TickIndicatorMorph methodsFor: 'testing' stamp: 'ar 2/11/2001 19:14'!
wantsSteps
	^true! !


!TickIndicatorMorph methodsFor: 'private' stamp: 'ar 2/11/2001 19:22'!
privateMoveBy: delta
	corners _ nil.
	super privateMoveBy: delta! !
AlignmentMorph subclass: #TileLikeMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!TileLikeMorph methodsFor: 'dropping/grabbing' stamp: 'ar 2/9/2001 23:57'!
justGrabbedFrom: formerOwner
	| editor |
	formerOwner ifNil:[^self].
	editor _ formerOwner topEditor.
	editor ifNotNil:[editor scriptEdited].! !


!TileLikeMorph methodsFor: 'initialization' stamp: 'mir 7/15/2004 15:20'!
localeChanged
	"Update myself to reflect the change in locale"

	self updateWordingToMatchVocabulary! !


!TileLikeMorph methodsFor: 'scripting' stamp: 'ar 10/7/2000 16:50'!
isTileLike
	^true! !


!TileLikeMorph methodsFor: 'user interface'!
fixLayoutOfSubmorphsNotIn: aCollection 
	self minCellSize: 0 @ (Preferences standardEToysFont height rounded + 10).
	self
		allMorphsDo: [:m | (aCollection includes: m)
				ifFalse: [(m respondsTo: #fixLayoutOfSubmorphsNotIn:)
						ifTrue: [m ~~ self
								ifTrue: [m fixLayoutOfSubmorphsNotIn: aCollection]]
						ifFalse: [m layoutChanged].
					aCollection add: m]].
	self layoutChanged; fullBounds! !

!TileLikeMorph methodsFor: 'user interface' stamp: 'sw 3/10/2004 19:55'!
updateWordingToMatchVocabulary
	"If appropriate, change the wording on the receiver to match up with a changed vocabulary."! !
MessageNode subclass: #TileMessageNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Tile Scriptors'!

!TileMessageNode methodsFor: 'printing' stamp: 'RAA 6/9/2000 18:25'!
printIfNilNotNil: aMorph indent: level

	| newNode |
	newNode _ aMorph parseNode clone.
	newNode receiver ifNotNil:
		[newNode receiver: newNode receiver ifNilReceiver].	"fudge so it prints right"

	(arguments first isJust: NodeNil) ifTrue:
		[^ newNode morphFromKeywords: #ifNotNil:
				arguments: { arguments second }
				on: aMorph indent: level].
	(arguments second isJust: NodeNil) ifTrue:
		[^ newNode morphFromKeywords: #ifNil:
				arguments: { arguments first }
				on: aMorph indent: level].
	^ newNode morphFromKeywords: #ifNil:ifNotNil:
			arguments: arguments
			on: aMorph indent: level! !

!TileMessageNode methodsFor: 'printing' stamp: 'BJP 6/9/2000 12:37'!
printIfOn: aStream indent: level 
"Just copied the old MessageNode one down here."
	(arguments last isJust: NodeNil)
		ifTrue: [^ self
				printKeywords: #ifTrue:
				arguments: (Array with: arguments first)
				on: aStream
				indent: level].
	(arguments last isJust: NodeFalse)
		ifTrue: [^ self
				printKeywords: #and:
				arguments: (Array with: arguments first)
				on: aStream
				indent: level].
	(arguments first isJust: NodeNil)
		ifTrue: [^ self
				printKeywords: #ifFalse:
				arguments: (Array with: arguments last)
				on: aStream
				indent: level].
	(arguments first isJust: NodeTrue)
		ifTrue: [^ self
				printKeywords: #or:
				arguments: (Array with: arguments last)
				on: aStream
				indent: level].
	self
		printKeywords: #ifTrue:ifFalse:
		arguments: arguments
		on: aStream
		indent: level! !

!TileMessageNode methodsFor: 'printing' stamp: 'RAA 8/15/1999 16:23'!
printKeywords: key arguments: args on: morph indent: level

	^morph parseNode
		morphFromKeywords: key 
		arguments: args 
		on: morph 
		indent: level
! !

!TileMessageNode methodsFor: 'printing' stamp: 'RAA 6/9/2000 15:32'!
printReceiver: rcvr on: aMorph indent: level
					
	"I don't think we need this to do anything since we already printed the receiver ourself"
! !

!TileMessageNode methodsFor: 'printing' stamp: 'dgd 2/21/2003 22:52'!
printToDoOn: aMorph indent: level 
	| limitNode |
	limitNode := (arguments last isNil 
				or: [(arguments last isMemberOf: AssignmentNode) not]) 
					ifTrue: [arguments first]
					ifFalse: [arguments last value].
	(selector key = #to:by:do: 
		and: [arguments second isConstantNumber and: [arguments second key = 1]]) 
			ifTrue: 
				[self 
					printKeywords: #to:do:
					arguments: (Array with: limitNode with: (arguments third))
					on: aMorph
					indent: level]
			ifFalse: 
				[self 
					printKeywords: selector key
					arguments: (Array with: limitNode) , arguments allButFirst
					on: aMorph
					indent: level]! !

!TileMessageNode methodsFor: 'printing' stamp: 'RAA 6/9/2000 17:15'!
printWhileOn: aMorph indent: level

	(arguments first isJust: NodeNil) ifTrue: [
		selector _ SelectorNode new
			key: (selector key == #whileTrue:
				ifTrue: [#whileTrue] ifFalse: [#whileFalse])
			code: #macro.
		arguments _ Array new
	].
	self printKeywords: selector key arguments: arguments
		on: aMorph indent: level! !
RectangleMorph subclass: #TileMorph
	instanceVariableNames: 'type slotName literal operatorOrExpression actualObject downArrow upArrow suffixArrow typeColor lastArrowTick nArrowTicks operatorReadoutString possessive retractArrow vocabulary vocabularySymbol'
	classVariableNames: 'DownPicture RetractPicture SuffixArrowAllowance SuffixPicture UpArrowAllowance UpPicture UpdatingOperators'
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!TileMorph commentStamp: '<historical>' prior: 0!
A tile with up, down and suffix arrows.

To install new Forms for the arrows, just nil out UpPicture, DownPicture,
or SuffixPicture.
Create actors with the picture you want and write it out with these file names:
'tile inc arrow.morph' 'tile dec arrow.morph' 'tile suffix
arrow.morph'.  Make sure that file is in the same directory as the image.
Open an EToy.!


!TileMorph methodsFor: 'accessing' stamp: 'ar 9/15/2000 23:31'!
abandonLabelFocus
	"If the receiver's label has editing focus, abandon it"
	self flag: #arNote. "Probably unnecessary"
	self currentHand releaseKeyboardFocus: self labelMorph.! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 11/6/1998 11:02'!
associatedPlayer
	^ actualObject! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 4/27/1998 16:10'!
labelMorph
	^ submorphs detect: [:m | m isKindOf: StringMorph] ifNone: [nil].! !

!TileMorph methodsFor: 'accessing' stamp: 'tk 8/16/2000 10:01'!
lastTile
	"The tile that might get an extension arrow"

	^ self! !

!TileMorph methodsFor: 'accessing'!
literal

	^ literal
! !

!TileMorph methodsFor: 'accessing' stamp: 'di 9/18/97 12:02'!
literal: anObject

	literal _ anObject.
	self updateLiteralLabel.
	self acceptNewLiteral.		"Show that we are out of date, install is needed"
! !

!TileMorph methodsFor: 'accessing' stamp: 'tak 12/6/2004 01:55'!
literalFromContents
	"Get value from StringMorph if it is needed. (See subclass)"
	^ literal! !

!TileMorph methodsFor: 'accessing'!
operatorOrExpression

	^ operatorOrExpression
! !

!TileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 01:07'!
options
	"Answer the options of the tile for an arrow"
	(type == #literal
			and: [literal isKindOf: Boolean])
		ifTrue: [^ {{true. false}. #('true' 'false' )}].
	operatorOrExpression
		ifNil: [^ nil].
	(ScriptingSystem arithmeticalOperatorsAndHelpStrings first includes: operatorOrExpression)
		ifTrue: [^ ScriptingSystem arithmeticalOperatorsAndHelpStrings].
	(ScriptingSystem numericComparitorsAndHelpStrings first includes: operatorOrExpression)
		ifTrue: [self receiverType = #Number
				ifTrue: [^ ScriptingSystem numericComparitorsAndHelpStrings]
				ifFalse: [^ #(#(#= #~=) #('equal' 'not equal') )]].
	^ nil! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 2/15/2002 01:47'!
playerBearingCode
	"Answer the actual Player object who will be the 'self' when the receiver is being asked to generate code"

	self topEditor ifNotNilDo:
		[:anEditor | ^ anEditor playerScripted].
	(self nearestOwnerThat: [:m | m isAViewer]) 
		ifNotNilDo:
			[:aViewer | ^ aViewer scriptedPlayer].
	^ actualObject! !

!TileMorph methodsFor: 'accessing' stamp: 'tak 1/4/2005 08:53'!
receiverType
	owner
		ifNil: [^ nil].
	owner submorphs size > 0
		ifFalse: [^ nil].
	^ (owner submorphs first respondsTo: #type)
		ifTrue: [owner submorphs first type]! !

!TileMorph methodsFor: 'accessing' stamp: 'yo 6/18/2004 14:54'!
resultType
	"Answer the result type of the receiver"

	type == #literal 
		ifTrue: 
			[(literal isNumber) ifTrue: [^#Number].
			(literal isString) ifTrue: [^#String].
			(literal isKindOf: Boolean) ifTrue: [^#Boolean]].
	type == #expression ifTrue: [^#Number].
	type == #objRef ifTrue: [(actualObject costume renderedMorph isMemberOf: KedamaPatchMorph) ifTrue: [^ #Patch] ifFalse: [^#Player]].
	^#unknown! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 11/9/1998 14:18'!
slotName
	"Caution: the slotName is not in use!!"
	^ slotName
! !

!TileMorph methodsFor: 'accessing'!
type

	^ type
! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 7/4/2004 01:09'!
updatingStringMorph
	"If the receiver has an updatingStringMorph as a submorph, answer it, else answer nil"
	
	^ submorphs detect: [:m | m isKindOf: UpdatingStringMorph] ifNone: [nil]! !

!TileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 00:30'!
value
	^ type == #literal
		ifTrue: [literal]
		ifFalse: [type == #objRef
				ifTrue: [actualObject]
				ifFalse: [operatorOrExpression]]! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 1/12/2005 12:35'!
value: anObject
	"Set the receiver's 'value'.  For a literal tile, this is the literal itself; for operator tiles it is the operator.  Recompile any enclosing script."

	type == #literal
		ifTrue: [self literal: anObject]
		ifFalse: [self setOperatorAndUseArrows: anObject asString].
	self scriptEdited.
	self layoutChanged! !


!TileMorph methodsFor: 'arrows' stamp: 'ar 11/2/2000 22:29'!
addArrows
	| frame |
	downArrow _ ImageMorph new image: DownPicture.
	upArrow _ ImageMorph new image: UpPicture.
	frame _ Morph new color: Color transparent.
	frame 
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		hResizing: #shrinkWrap; 
		vResizing: #shrinkWrap;
		cellInset: 0@1;
		layoutInset: 0@1.
	frame addMorphBack: upArrow; addMorphBack: downArrow.
	self addMorphFront: frame.
! !

!TileMorph methodsFor: 'arrows' stamp: 'tk 8/16/2000 09:48'!
addRetractArrow
	"Must be situated in a script"

	self couldRetract ifNil: [^ self].
	retractArrow _ ImageMorph new image: RetractPicture.
	suffixArrow ifNotNil: [
		self addMorph: retractArrow inFrontOf: suffixArrow].
	fullBounds _ nil.
	self extent: self fullBounds extent! !

!TileMorph methodsFor: 'arrows' stamp: 'ar 11/2/2000 22:30'!
addSuffixArrow

	suffixArrow _ ImageMorph new image: SuffixPicture.
	self addMorphBack: suffixArrow.! !

!TileMorph methodsFor: 'arrows' stamp: 'tk 10/12/97 15:05'!
addSuffixIfCan
	"Should this tile have a suffix arrow?"

	self addSuffixArrow.! !

!TileMorph methodsFor: 'arrows' stamp: 'tak 12/5/2004 14:36'!
arrowAction: delta 
	"Do what is appropriate when an arrow on the tile is pressed; delta will  
	be +1 or -1"
	| index options |
	(type == #literal
			and: [literal isNumber])
		ifTrue: [self value: literal + delta]
		ifFalse: [options _ self options
						ifNil: [^ self].
			index _ (options first indexOf: self value)
						+ delta.
			self
				value: (options first atWrap: index).
			submorphs last
				setBalloonText: (options second atWrap: index)]! !

!TileMorph methodsFor: 'arrows' stamp: 'tk 8/16/2000 08:59'!
couldRetract
	"See if it makes sense to retract this tile and the op before it.  Return the phrase that gets retracted, or nil if not allowed."
	| phrase pad |
	(phrase _ self ownerThatIsA: PhraseTileMorph) ifNil: [^ nil].
	(pad _ phrase ownerThatIsA: TilePadMorph) ifNil: [^ nil].
	(phrase firstSubmorph "goodPad") type == pad type ifFalse: [
		phrase submorphs size < 3 ifFalse: [^ nil].	"types should have matched"
		"Go up a level"
		(phrase _ pad ownerThatIsA: PhraseTileMorph) ifNil: [^ nil].
		(pad _ phrase ownerThatIsA: TilePadMorph) ifNil: [^ nil].
		(phrase firstSubmorph "goodPad") type == pad type ifFalse: [^ nil].
		].
	^ phrase
! !

!TileMorph methodsFor: 'arrows' stamp: 'ar 9/24/2000 19:11'!
deleteLastTwoTiles
	"Remove the current suffix (last two tiles) in this line of tiles"
	| phrase pad goodPad |
	(phrase _ self couldRetract) ifNil: [^ self].
	pad _ phrase ownerThatIsA: TilePadMorph.
	goodPad _ phrase firstSubmorph.
	pad owner addMorphBack: goodPad.
	pad delete.
	(goodPad lastSubmorph respondsTo: #addSuffixArrow) 
		ifTrue: [goodPad lastSubmorph addSuffixArrow; addRetractArrow]
		ifFalse: [goodPad lastSubmorph lastSubmorph addSuffixArrow; addRetractArrow].
	goodPad topEditor install. "recompile"! !

!TileMorph methodsFor: 'arrows' stamp: 'tk 8/10/2000 14:34'!
deleteSuffixArrow

	suffixArrow delete.
	suffixArrow _ nil.
	retractArrow ifNotNil: ["backward compat"
		retractArrow delete.
		retractArrow _ nil].
	self updateLiteralLabel! !

!TileMorph methodsFor: 'arrows' stamp: 'sw 1/4/2005 02:09'!
phraseForOp: op arg: arg resultType: resultType
	"Answer a numeric-valued phrase derived from the receiver, whose extension arrow has just been hit.  Pass along my float-precision."

	| phrase srcLabel distLabel |
	phrase _ self presenter
				phraseForReceiver: literal
				op: op
				arg: 1
				resultType: #Number.
	srcLabel _ self findA: UpdatingStringMorph.
	distLabel _ phrase submorphs first submorphs first findA: UpdatingStringMorph.
	distLabel floatPrecision: srcLabel floatPrecision.
	^ phrase! !

!TileMorph methodsFor: 'arrows' stamp: 'tak 12/5/2004 15:33'!
showSuffixChoices
	"The suffix arrow has been hit, so respond appropriately"

	| plusPhrase phrase pad outer num |
	(phrase _ self ownerThatIsA: PhraseTileMorph) ifNil: [^ self].

	(type == #literal) & (literal isNumber) ifTrue: ["Tile is a constant number"
		phrase lastSubmorph == owner "pad"
			ifTrue: ["we are adding the first time (at end of our phrase)"
				plusPhrase _ self phraseForOp: #+ arg: 1 resultType: #Number.
				plusPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: #+).
				owner acceptDroppingMorph: plusPhrase event: self primaryHand lastEvent.
				num _ plusPhrase firstSubmorph firstSubmorph.
				num deleteSuffixArrow]].

	type == #operator ifTrue: ["Tile is accessor of an expression"
		phrase resultType == #Number ifTrue:
			[outer _ phrase ownerThatIsA: PhraseTileMorph.
			pad _ self ownerThatIsA: TilePadMorph.
			outer ifNotNil:
				[outer lastSubmorph == pad ifTrue: [ "first time"
					plusPhrase _ self presenter phraseForReceiver: 1 
							op: #+ arg: 1 resultType: #Number.
					plusPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: #+).
					pad acceptDroppingMorph: plusPhrase event: self primaryHand lastEvent.
					plusPhrase firstSubmorph removeAllMorphs; addMorph: phrase.	"car's heading"
					self deleteSuffixArrow.
					pad topEditor install "recompile"]]]].

	(phrase topEditor ifNil: [phrase]) enforceTileColorPolicy! !

!TileMorph methodsFor: 'arrows' stamp: 'ar 2/12/2001 13:55'!
variableDelay: aBlock

	| now delay dt |
	(self hasProperty: #inVariableDelay) ifTrue:[^self].
	nArrowTicks ifNil: [nArrowTicks _ 1].
	now _ Time millisecondClockValue.
	aBlock value.
	delay _ nArrowTicks > 5 ifTrue: [100] ifFalse: [300].
	nArrowTicks _ nArrowTicks + 1.
	dt _ Time millisecondClockValue - now max: 0.  "Time it took to do."
	dt < delay ifTrue: [
		self setProperty: #inVariableDelay toValue: true.
		self addAlarm: #removeProperty: withArguments: #(inVariableDelay) after: (delay - dt)].
! !


!TileMorph methodsFor: 'as yet unclassified'!
fixLayoutOfSubmorphsNotIn: aCollection 
	self
		allMorphsDo: [:m | (aCollection includes: m)
				ifFalse: [(m respondsTo: #fixLayoutOfSubmorphsNotIn:)
						ifTrue: [m ~~ self
								ifTrue: [m fixLayoutOfSubmorphsNotIn: aCollection]]
						ifFalse: [m layoutChanged].
					aCollection add: m]].
	self layoutChanged; fullBounds! !


!TileMorph methodsFor: 'change reporting' stamp: 'tk 2/21/2001 20:07'!
colorChangedForSubmorph: aSubmorph
	"Invoked when the user selects a new color on a colorTile or a color-seer-tile; need to recompile the script."
	self acceptNewLiteral
	owner ifNil: [^ self].
	owner isTileLike ifFalse: [owner colorChangedForSubmorph: aSubmorph].! !

!TileMorph methodsFor: 'change reporting' stamp: 'ar 11/8/2000 23:46'!
ownerChanged
	super ownerChanged.
	(owner class == TilePadMorph and:[owner layoutPolicy isNil]) ifTrue:[
		owner layoutPolicy: TableLayout new.
		owner hResizing: #shrinkWrap.
		owner vResizing: #spaceFill.
	].! !


!TileMorph methodsFor: 'code generation' stamp: 'sw 8/30/2004 16:34'!
acceptNewLiteral
	"Tell the scriptEditor who I belong to that I have a new literal value."

	| topScript |
	topScript _ self outermostMorphThat:
		[:m | m isKindOf: ScriptEditorMorph].
	topScript ifNotNil: [topScript installWithNewLiteral].
	(self ownerThatIsA: ViewerLine) ifNotNilDo:
		[:aLine |
			(self ownerThatIsA: PhraseTileMorph) ifNotNil:
				[aLine removeHighlightFeedback.
				self layoutChanged.
				ActiveWorld doOneSubCycle.
				aLine addCommandFeedback]]! !

!TileMorph methodsFor: 'code generation' stamp: 'sw 9/2/1999 15:01'!
codeString
	^ String streamContents: [:aStream | self storeCodeOn: aStream indent: 1]
! !

!TileMorph methodsFor: 'code generation'!
precedingTileType
	"Return the slot reference type of the preceding TileMorph in my owner."

	| row i tile |
	row _ owner submorphs.
	i _ row indexOf: self.
	((i > 1) and: [(tile _ row at: i - 1) isKindOf: TileMorph])
		ifTrue: [^ tile type]
		ifFalse: [^ #unknown].
! !

!TileMorph methodsFor: 'code generation' stamp: 'sw 9/26/97 10:51'!
scriptEdited
	"Tell the scriptEditor who I belong to that I have changed.  "
	| him |
	(him _ self outermostMorphThat: [:m| m isKindOf: ScriptEditorMorph])
		ifNotNil: [him scriptEdited]! !

!TileMorph methodsFor: 'code generation' stamp: 'yo 4/4/2005 16:14'!
storeCodeOn: aStream indent: tabCount 
	"Store code representing the receiver onto the stream, with the given amount of indentation"

	| op playerBearingCode |
	playerBearingCode := self playerBearingCode.	"Must determine whom is scripted for what follows to work; if it's ever nil, we've got trouble"
	type = #expression 
		ifTrue: 
			[^aStream
				nextPut: $(;
				nextPutAll: operatorOrExpression;
				nextPut: $)].
	type = #literal 
		ifTrue: 
			[^aStream
				nextPut: $(;
				nextPutAll: literal printString;
				nextPut: $)].
	type == #objRef 
		ifTrue: 
			[^playerBearingCode == actualObject 
				ifTrue: 
					["If the object is the method's own 'self' then we MUST, rather than just MAY, put out 'self' rather than the referencer call, though the latter will temporarily work if only one instance of the uniclass exists."

					aStream nextPutAll: 'self']
				ifFalse: 
					[(actualObject isPlayerLike and: [actualObject isSequentialStub]) ifTrue: [
						actualObject storeCodeOn: aStream indent: tabCount.
					] ifFalse: [
						 Preferences capitalizedReferences 
						ifTrue: 
							["Global dictionary References"

							self flag: #deferred.	"Start deploying the meesage-receiver hints soon"
							aStream nextPutAll: actualObject uniqueNameForReference]
						ifFalse: 
							["old class-inst-var-based scheme used  Feb 1998 to Oct 2000, and indeed
						ongoing in school year 2000-01 at the open school"

							aStream nextPutAll: 'self class '.
							aStream 
								nextPutAll: (playerBearingCode class referenceSelectorFor: actualObject)]]]].
	type = #operator 
		ifTrue: 
			[op := ((UpdatingOperators includesKey: operatorOrExpression) 
				and: [self precedingTileType = #slotRef]) 
					ifTrue: [UpdatingOperators at: operatorOrExpression]
					ifFalse: [operatorOrExpression].
			^op isEmpty 
				ifTrue: [aStream position: aStream position - 1]
				ifFalse: [aStream nextPutAll: op]]

	"The following branch has long been disused
	type = #slotRef ifTrue:
		[self isThisEverCalled.
		refType _ self slotRefType.
		refType = #get ifTrue:
			[^ aStream
				nextPutAll: targetName;
				space;
				nextPutAll: (Utilities getterSelectorFor: slotName)].
		refType = #set ifTrue:
			[^ aStream
				nextPutAll: targetName;
				space;
				nextPutAll: (Utilities setterSelectorFor: slotName);
				nextPut: $:].
		refType = #update ifTrue:
			[^ aStream
				nextPutAll: targetName;
				space;
				nextPutAll: slotName;
				nextPutAll: ': ';
				nextPutAll: targetName;
				space;
				nextPutAll: slotName]]"! !


!TileMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:15'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
actualObject _ deepCopier references at: actualObject ifAbsent: [actualObject].! !

!TileMorph methodsFor: 'copying' stamp: 'sw 6/4/2001 16:45'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
type _ type veryDeepCopyWith: deepCopier.
slotName _ slotName veryDeepCopyWith: deepCopier.
literal _ literal veryDeepCopyWith: deepCopier.
operatorOrExpression _ operatorOrExpression veryDeepCopyWith: deepCopier.
"actualObject _ actualObject.		Weakly copied"
downArrow _ downArrow veryDeepCopyWith: deepCopier.
upArrow _ upArrow veryDeepCopyWith: deepCopier.
suffixArrow _ suffixArrow veryDeepCopyWith: deepCopier.
typeColor _ typeColor veryDeepCopyWith: deepCopier.
lastArrowTick _ lastArrowTick veryDeepCopyWith: deepCopier.
nArrowTicks _ nArrowTicks veryDeepCopyWith: deepCopier.
operatorReadoutString _ operatorReadoutString veryDeepCopyWith: deepCopier.
possessive _ possessive veryDeepCopyWith: deepCopier.
retractArrow _ retractArrow veryDeepCopyWith: deepCopier.
vocabularySymbol _ vocabularySymbol.  "Weakly copied"
vocabulary _ nil.   "obsolete - clobbered"! !


!TileMorph methodsFor: 'dropping/grabbing' stamp: 'sw 1/7/2004 02:45'!
justDroppedInto: aMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"

	super justDroppedInto: aMorph event: anEvent.
	aMorph isPlayfieldLike
		ifTrue:
			[self vResizing: #shrinkWrap]
		ifFalse:
			[aMorph isTileScriptingElement ifTrue:
				[self vResizing: #spaceFill]]
! !

!TileMorph methodsFor: 'dropping/grabbing' stamp: 'ar 2/9/2001 23:57'!
justGrabbedFrom: formerOwner
	| editor |
	formerOwner ifNil:[^self].
	editor _ formerOwner topEditor.
	editor ifNotNil:[editor scriptEdited].! !


!TileMorph methodsFor: 'event handling' stamp: 'ar 2/8/2001 20:07'!
handlesMouseDown: evt
	"Answer whether the receiver would handle the mouseDown represented by evt"

	| aPoint |
	aPoint _ evt cursorPoint.
	(operatorOrExpression notNil and: [upArrow notNil]) ifTrue: [^ true].
		"Click on the operator presents list of alternatives"

	upArrow ifNotNil: [^true].
	suffixArrow ifNotNil: [^true].
	retractArrow ifNotNil: [^true].
	^ super handlesMouseDown: evt! !

!TileMorph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:42'!
handlesMouseStillDown: evt
	^true! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 8/2/2005 18:28'!
mouseDown: evt 
	self setProperty: #previousLiteral toValue: self literalFromContents.
	(upArrow notNil
			and: [(upArrow containsPoint: evt position)
					or: [downArrow containsPoint: evt position]])
		ifTrue: [self setProperty: #previousPoint toValue: evt position].
	self currentHand releaseKeyboardFocus.
	evt hand
		waitForClicksOrDrag: self
		event: evt
		selectors: {#mouseStillDown:. nil. nil. #startDrag:}
		threshold: 5.
	^ super mouseDown: evt! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 8/2/2005 18:11'!
mouseMove: evt 
	self options
		ifNotNil: [^ self showOptions].
	(self hasProperty: #previousLiteral)
		ifFalse: [^ self].
	(self hasProperty: #previousPoint)
		ifFalse: [^ evt hand grabMorph: self rootInPasteUp].
	self currentHand releaseKeyboardFocus.
	"Once reviving the value at drag start"
	literal := self valueOfProperty: #previousLiteral.
	"Then applying delta"
	self arrowAction: (self valueOfProperty: #previousPoint) y - evt position y * self arrowDelta abs.
	^ super mouseMove: evt! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 12/6/2004 01:00'!
mouseStillDown: evt 
	"See if arrows are being pressed and call arrowAction:..."
	| aPoint |
	upArrow
		ifNil: [^ super mouseStillDown: evt].
	aPoint _ evt cursorPoint.
	(upArrow containsPoint: aPoint)
		ifTrue: [^ self
				variableDelay: [self arrowAction: self arrowDelta]].
	(downArrow containsPoint: aPoint)
		ifTrue: [^ self
				variableDelay: [self arrowAction: self arrowDelta negated]].
	self options
		ifNotNil: [^ self showOptions]! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 12/5/2004 13:54'!
mouseUp: evt 
	self removeProperty: #previousLiteral.
	self removeProperty: #previousPoint.
	suffixArrow
		ifNotNil: [(suffixArrow bounds containsPoint: evt cursorPoint)
				ifTrue: [self showSuffixChoices.
					^ self]].
	retractArrow
		ifNotNil: [(retractArrow bounds containsPoint: evt cursorPoint)
				ifTrue: [self deleteLastTwoTiles.
					^ self]].
	^ super mouseUp: evt! !

!TileMorph methodsFor: 'event handling' stamp: 'tak 12/5/2004 01:30'!
wantsKeyboardFocusFor: aSubmorph 
	^ type == #literal
		and: [(literal isKindOf: Boolean) not]! !


!TileMorph methodsFor: 'events-processing' stamp: 'ar 9/18/2000 18:03'!
handlerForMouseDown: anEvent
	"Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event"
	| aPoint |
	upArrow ifNotNil:
		[(upArrow bounds containsPoint: (aPoint _ anEvent cursorPoint))
			ifTrue: [^self].
		(downArrow bounds containsPoint: aPoint)
			ifTrue: [^self]].

	^super handlerForMouseDown: anEvent! !


!TileMorph methodsFor: 'e-toy support' stamp: 'sw 6/4/2001 16:48'!
adoptVocabulary: aVocabulary
	"Set the receiver's vocabulary"

	vocabularySymbol _ aVocabulary vocabularyName.
	self updateWordingToMatchVocabulary.
	super adoptVocabulary: aVocabulary! !

!TileMorph methodsFor: 'e-toy support' stamp: 'sw 7/30/1999 13:08'!
isCandidateForAutomaticViewing
	^ false! !

!TileMorph methodsFor: 'e-toy support' stamp: 'mir 7/15/2004 15:20'!
localeChanged
	"Update myself to reflect the change in locale"

	self updateWordingToMatchVocabulary! !


!TileMorph methodsFor: 'initialization' stamp: 'sw 10/3/97 18:00'!
actualObject
	^ actualObject! !

!TileMorph methodsFor: 'initialization' stamp: 'dgd 9/1/2003 13:34'!
bePossessive
	possessive := true.
	self line1: actualObject externalName , '''s' translated! !

!TileMorph methodsFor: 'initialization' stamp: 'dgd 9/1/2003 13:35'!
bringUpToDate
	"Make certain, if the receiver is an object-reference tile, that it shows the current external name of the object, which may just have changed.  This only applies to the Player regime." 

	| newLabel |
		(type == #objRef and: [actualObject isPlayerLike]) ifTrue:
		[newLabel _ actualObject externalName.
		self isPossessive ifTrue:
			[newLabel _ newLabel, '''s' translated].
		self line1: newLabel]! !

!TileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 1! !

!TileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: 1 @ 1.
	self
		typeColor: (Color
				r: 0.8
				g: 1.0
				b: 0.6).

	type _ #literal.
	"#literal, #slotRef, #objRef, #operator, #expression"
	slotName _ ''.
	literal _ 1.
	self layoutPolicy: TableLayout new.
	self cellInset: 2 @ 0.
	self layoutInset: 1 @ 0.
	self listDirection: #leftToRight.
	self wrapCentering: #center.
	self hResizing: #shrinkWrap.
	self vResizing: #spaceFill! !

!TileMorph methodsFor: 'initialization' stamp: 'dgd 2/21/2003 22:56'!
isPossessive
	possessive isNil ifTrue: [^false].
	^possessive! !

!TileMorph methodsFor: 'initialization' stamp: 'gm 2/24/2003 18:08'!
rawVocabulary: aVocabulary 
	"Set the receiver's vocabulary, without side effects."

	vocabularySymbol := (aVocabulary isKindOf: Symbol) 
				ifTrue: [aVocabulary]
				ifFalse: [aVocabulary vocabularyName]! !

!TileMorph methodsFor: 'initialization' stamp: 'yo 4/4/2005 14:31'!
referToSimilarObject: anObject
	"Make the receiver be an object-reference tile whose referent is anObject"
	actualObject _ anObject.
! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 9/28/2000 12:27'!
referTo: anObject
	"Make the receiver be an object-reference tile whose referent is anObject"

	type _ #objRef.
	typeColor _ ScriptingSystem colorForType: anObject basicType.
	actualObject _ anObject.
	self line1: anObject uniqueNameForReference! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 3/3/2004 16:28'!
retargetFrom: oldPlayer to: newPlayer
	"Change the receiver so that if formerly it referred to oldPlayer, it refers to newPlayer instead"

	| newLabel |
	(type == #objRef  and: [actualObject == oldPlayer]) ifTrue:
		[actualObject _ newPlayer.
		newLabel _ actualObject externalName.
		self isPossessive ifTrue:
			[newLabel _ newLabel, '''s' translated].
		self line1: newLabel]! !

!TileMorph methodsFor: 'initialization'!
setExpression: exprString label: labelString

	type _ #expression.
	operatorOrExpression _ exprString.
	self line1: labelString.
! !

!TileMorph methodsFor: 'initialization' stamp: 'nk 8/30/2004 08:02'!
setLiteral: anObject
	"Set the receiver's literal to be anObject.  Create a readout morph and add it to the receiver, deleting any existing one that may be there."

	| m already |
	already _ submorphs detect: [:aSubMorph  | aSubMorph isKindOf: UpdatingStringMorph] ifNone: [nil].
	already ifNotNil: [already delete].
	type _ #literal.
	m _ UpdatingStringMorph contents: ' ' font: ScriptingSystem fontForTiles.
	m target: self; getSelector: #literal; putSelector: #literal:.
	(anObject isString or: [ anObject isText]) ifTrue: [m useStringFormat].
	self addMorphBack: m.
	self setLiteralInitially: anObject.
! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 9/27/2001 04:16'!
setOperator: aString
	"Set the operator symbol from the string provided"

	self setOperator: aString andUseWording:  (self currentVocabulary tileWordingForSelector: aString)! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 9/27/2001 04:09'!
setOperator: aString andUseWording: wording
	"Set the operator symbol from the string provided"

	type _ #operator.
	operatorOrExpression _ aString asSymbol.
 	self line1: wording.
	(ScriptingSystem doesOperatorWantArrows: operatorOrExpression)
		ifTrue: [self addArrows].
	self updateLiteralLabel

	"operatorOrExpression == #heading ifTrue: [self halt]."! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 5/17/2001 12:17'!
setOperatorAndUseArrows: aString
	"Set the operator as per aString, and add up/down arrows"

	type _ #operator.
	operatorOrExpression _ aString asSymbol.
 	self line1: (self currentVocabulary tileWordingForSelector: operatorOrExpression).
	self addArrows; updateLiteralLabel.
	submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: operatorOrExpression)! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 9/13/2001 21:58'!
setSlotRefOperator: getter
	"getter represents the name of a slot that the receiver is to represent; configure the receiver to serve thi duty, and set upthe wording on the tile appropriately"

	type _ #operator.
	operatorOrExpression _ getter asSymbol.
	self line1:  (self currentEToyVocabulary tileWordingForSelector: operatorOrExpression).
	self updateLiteralLabel! !

!TileMorph methodsFor: 'initialization' stamp: 'dgd 8/26/2004 12:04'!
setToReferTo: anObject
	"Set the receiver to bear an object reference to the given object."
	self flag: #yo.
	type _ #objRef.
	actualObject _ anObject.
	self line1: anObject nameForViewer.
	self typeColor: (ScriptingSystem colorForType: #Player).
	self enforceTileColorPolicy
! !

!TileMorph methodsFor: 'initialization' stamp: 'yo 7/2/2004 21:44'!
updateWordingToMatchVocabulary
	"The current vocabulary has changed; change the wording on my face, if appropriate"

	| aMethodInterface |
	type == #operator ifTrue:
		[self line1: (self currentVocabulary tileWordingForSelector: operatorOrExpression).
		(ScriptingSystem doesOperatorWantArrows: operatorOrExpression)
			ifTrue: [self addArrows].
		self updateLiteralLabel.

		aMethodInterface _ self currentVocabulary methodInterfaceAt: operatorOrExpression
			ifAbsent: [
				Vocabulary eToyVocabulary
					methodInterfaceAt: operatorOrExpression ifAbsent: [^ self]].
		self setBalloonText: aMethodInterface documentation.
	].

	type == #objRef ifTrue: [
		self isPossessive
			ifTrue: [self bePossessive]
			ifFalse: [self labelMorph contents: self actualObject nameForViewer asSymbol translated]].

		"submorphs last setBalloonText: aMethodInterface documentation"! !


!TileMorph methodsFor: 'macpal' stamp: 'sw 6/4/2001 19:33'!
currentVocabulary
	"Answer the receiver's current vocabulary"

	| outer aVocab |
	vocabulary ifNotNil:  "old structures -- bring up to date"
		[vocabularySymbol _ vocabulary vocabularyName.
		vocabulary _ nil].
	^ vocabularySymbol
		ifNotNil:
			[Vocabulary vocabularyNamed: vocabularySymbol]
		ifNil:
			[(outer _ self ownerThatIsA: StandardViewer orA: ScriptEditorMorph) 
				ifNotNil:
					[aVocab _ outer currentVocabulary.
					vocabularySymbol _ aVocab vocabularyName.
					aVocab]
				ifNil:
					[super currentVocabulary]]! !

!TileMorph methodsFor: 'macpal' stamp: 'sw 5/25/2000 15:52'!
scriptPerformer
	"Guard against obscure circumstance in which the tile itself has an associated Player, which then might be asked to interact in inappropriate ways with, for example, an UpdatingStringMorph to provide the literal for a RandomNumberTile.  This is at best a finger in the dike.  Still very unsatisfactory!!"
	^ self! !


!TileMorph methodsFor: 'misc' stamp: 'dgd 8/30/2003 22:19'!
addCustomMenuItems:  aMenu hand: aHandMorph
	"Add custom halo menu items to a menu"

	| aPlayer |
	super addCustomMenuItems: aMenu hand: aHandMorph.
	((aPlayer _ self associatedPlayer) notNil and:
		[aPlayer costume isMorph]) ifTrue:
			[aMenu addLine.
			aMenu add: 'hand me this object' translated target: self action: #handReferentMorph.
			aMenu balloonTextForLastItem: 'This tile refers to an actual graphical object; use this menu item to grab that object.  Caution!!  This may remove the object from a place it really ought to stay.' translated.
			aMenu addLine ]! !

!TileMorph methodsFor: 'misc' stamp: 'sw 9/17/1999 08:00'!
basicWidth
	"Provide a nominal minimum, exclusive of arrows and independent of label width"

	^ operatorOrExpression
		ifNotNil:
			[3]
		ifNil:
			[18]! !

!TileMorph methodsFor: 'misc' stamp: 'nk 8/29/2004 17:22'!
currentEToyVocabulary
	"Answer the etoy vocabulary that pertains"
	| aVocab |
	^ (aVocab := self currentVocabulary) isEToyVocabulary
		ifTrue: [aVocab]
		ifFalse: [Vocabulary eToyVocabulary]! !

!TileMorph methodsFor: 'misc' stamp: 'sw 4/9/2001 12:55'!
handReferentMorph
	"Hand the user the actual morph referred to"

	| aMorph surrogate |
	((aMorph _ actualObject costume) isMorph and:
		[aMorph isWorldMorph not])
			ifTrue:
				[surrogate _ CollapsedMorph collapsedMorphOrNilFor: aMorph.
				surrogate
					ifNotNil:
						[surrogate uncollapseToHand]
					ifNil:
						[ActiveHand attachMorph: aMorph]]! !

!TileMorph methodsFor: 'misc' stamp: 'sw 9/17/1999 08:02'!
minimumWidth
	| aWidth |
	aWidth _ self basicWidth.
	upArrow ifNotNil: [aWidth _ aWidth + UpArrowAllowance].
	suffixArrow ifNotNil: [aWidth _ aWidth + SuffixArrowAllowance].
	^ aWidth
	! !

!TileMorph methodsFor: 'misc' stamp: 'sw 1/29/98 00:45'!
numericValue
	literal isNumber ifFalse: [^ 0].
	^ literal! !

!TileMorph methodsFor: 'misc' stamp: 'sw 9/15/2000 06:00'!
setLiteralInitially: anObject
	"Establish the initial literal.  Get the label correct, but do *not* send the value back to the target via the setter (unlike #literal:)"

	literal _ anObject.
	self updateLiteralLabel! !

!TileMorph methodsFor: 'misc' stamp: 'sw 1/28/2005 00:54'!
soundChoices
	"Answer a list of sound choices.  This applies only to tiles that have sound-names as their literals, viz. SoundTiles and SoundReadoutTiles."

	| aList |
	aList _ SoundService default sampledSoundChoices asOrderedCollection.
	aList removeAllFoundIn: (ScriptingSystem soundNamesToSuppress copyWithout: literal).
	^ aList asSortedArray! !

!TileMorph methodsFor: 'misc' stamp: 'sw 8/28/2004 15:20'!
typeColor: aColor
	"Set the receiver's typeColor"

	borderColor _ ScriptingSystem standardTileBorderColor.
	typeColor _ aColor.
	color _ ScriptingSystem uniformTileInteriorColor ! !


!TileMorph methodsFor: 'mouse handling' stamp: 'sw 11/29/2001 13:14'!
arrowDelta
	"Answer the amount by which a number I display should increase at a time"

	^  self valueOfProperty: #arrowDelta ifAbsent: [1]! !

!TileMorph methodsFor: 'mouse handling' stamp: 'sw 11/22/2000 10:50'!
presentOperatorAlternatives: evt
	"The receiver is a tile that represents an operator; a click on the receiver's label will pop up a menu of alternative operator choices"

	| result ops |

	((ops _ ScriptingSystem arithmeticalOperatorsAndHelpStrings first) includes: operatorOrExpression) ifFalse:
		[((ops _ ScriptingSystem numericComparitorsAndHelpStrings first) includes: operatorOrExpression)
			ifFalse: [^ self]].
		
	(result _ (SelectionMenu selections: ops) startUp) ifNotNil:
		[self setOperatorAndUseArrows: result asString.
		self scriptEdited]! !

!TileMorph methodsFor: 'mouse handling' stamp: 'yo 3/14/2005 10:27'!
showOptions
	"The receiver is a tile that represents an operator; a click on the 
	receiver's label will pop up a menu of alternative operator choices"
	| result menuChoices word |
	menuChoices _ (self options first collect: [:each | each asString translated]) collect: [:each | 
							word := self currentVocabulary translatedWordingFor: each asSymbol.
							word isEmpty
								ifTrue: ['<-']
								ifFalse: [word]].
	result _ (SelectionMenu labelList: menuChoices lines: nil selections: self options first) startUp.
	result 
		ifNotNil: [self value: result.
			self scriptEdited]! !


!TileMorph methodsFor: 'player viewer' stamp: 'sw 9/13/2001 21:58'!
updateLiteralLabel
	"Update the wording emblazoned on the tile, if needed"

	| myLabel |
	(myLabel _ self labelMorph) ifNil: [^ self].

	myLabel acceptValue:
		(type == #literal
			ifTrue:
				[literal] 
			ifFalse: [operatorReadoutString 
				ifNil:		[self currentEToyVocabulary tileWordingForSelector: operatorOrExpression]
				ifNotNil:  	[operatorReadoutString]]).
	self changed.! !


!TileMorph methodsFor: 'printing' stamp: 'sw 4/28/1998 00:14'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' - ', type printString.
	operatorOrExpression ifNotNil: [aStream nextPutAll: ' op= ', operatorOrExpression printString].
	slotName ifNotNil: [aStream nextPutAll: ' op= ', slotName printString].! !


!TileMorph methodsFor: 'scripting' stamp: 'tk 10/1/97 18:24'!
isTileLike
	"Can be dropped into a script"
	^ true! !

!TileMorph methodsFor: 'scripting' stamp: 'sw 4/21/1998 21:34'!
isTileScriptingElement
	^ true! !

!TileMorph methodsFor: 'scripting' stamp: 'sw 1/21/98 17:44'!
restoreTypeColor
	self borderColor: Color black.
	typeColor ifNotNil: [self color: typeColor]! !

!TileMorph methodsFor: 'scripting' stamp: 'sw 5/2/1998 15:01'!
useUniformTileColor
	self color: ScriptingSystem uniformTileInteriorColor! !


!TileMorph methodsFor: 'tiles from method' stamp: 'tk 8/6/1999 16:00'!
selectorTile: msgNode in: aScriptor
	| sel selTile |
	"Make a selector (operator) tile"

	sel _ msgNode selector key.
	sel == #color:sees: ifTrue: [
		selTile _ (Viewer new) colorSeesPhrase submorphs second.	"ColorSeer tile"
		selTile colorSwatchColor: msgNode arguments first eval.
		^ selTile].
	^ self setOperator: sel! !


!TileMorph methodsFor: 'private' stamp: 'ar 11/2/2000 19:21'!
convertAlignment
	"Convert the receiver's alignment rules"
	| where frame |
	owner ifNotNil:[
		owner class == TilePadMorph ifTrue:[
			owner layoutPolicy: TableLayout new.
			owner hResizing: #shrinkWrap.
			owner vResizing: #spaceFill.
		].
	].
	self layoutPolicy: TableLayout new.
	self cellInset: 2@0.
	self layoutInset: 1@0.
	self listDirection: #leftToRight.
	self wrapCentering: #center.
	self hResizing: #shrinkWrap.
	self vResizing: #spaceFill.
	"Now convert up and down arrow"
	(upArrow notNil and:[upArrow owner == self "e.g., not converted"
		and:[downArrow notNil and:[downArrow owner == self]]]) ifTrue:[
			"where to insert the frame"
			where _ (submorphs indexOf: upArrow) min: (submorphs indexOf: downArrow).
			frame _ Morph new color: Color transparent.
			frame 
				layoutPolicy: TableLayout new;
				listDirection: #topToBottom;
				hResizing: #shrinkWrap; 
				vResizing: #shrinkWrap;
				cellInset: 0@1;
				layoutInset: 0@1.
			self privateAddMorph: frame atIndex: where.
			frame addMorphBack: upArrow; addMorphBack: downArrow.
		].
! !

!TileMorph methodsFor: 'private' stamp: 'sw 10/30/2000 09:00'!
line1: line1
	"Emblazon the receiver with the requested label.  If the receiver already has a label, make the new label be of the same class"

	| m desiredW classToUse lab |
	classToUse _ (lab _ self labelMorph) ifNotNil: [lab class] ifNil: [StringMorph].
	self removeAllMorphs.
	m _ classToUse contents: line1 font: ScriptingSystem fontForTiles.
	desiredW _ m width + 6.
	self extent: (desiredW max: self minimumWidth) @ self class defaultH.
	m position: self center - (m extent // 2).
	self addMorph: m.
! !

!TileMorph methodsFor: 'private' stamp: 'tk 8/14/2000 13:32'!
test
	| pos hh |
	"Set the position of all my submorphs.  Compute my bounds.  Caller must call layoutChanged or set fullBounds to nil."

	fullBounds ifNil: [
		pos _ self topLeft.
		self submorphsDo: [:sub | 
			hh _ (self class defaultH - sub height) // 2.	"center in Y"
			sub privateBounds: (pos + (2@hh) extent: sub extent).
			pos x: (sub right min: 1200)].	"2 pixels spacing on left"
		bounds _ bounds topLeft corner: pos + (2 @ self class defaultH).
		fullBounds _ bounds.
		].
	owner class == TilePadMorph ifTrue: [owner bounds: bounds].
	^ fullBounds! !


!TileMorph methodsFor: 'commands' stamp: 'nk 9/9/2004 13:17'!
playerRepresented
	"Answer the player represented by the receiver. Morphs that serve as 
	references to other morphs reimplement this; by default a morph 
	represents its own player."
	^ type == #objRef
		ifTrue: [actualObject]
		ifFalse: [super playerRepresented]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TileMorph class
	instanceVariableNames: ''!

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 16:40'!
downPicture
	^ DownPicture! !

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 17:30'!
fixCaretForms
	"TileMorph fixCaretForms"
	"UpPicture storeString"
	"DownPicture storeString"

	UpPicture _  Form
	extent: 9@8
	depth: 16
	fromArray: #( 0 0 60817408 0 0 0 0 60818336 0 0 0 928 60818336 60817408 0 0 928 60818336 60817408 0 0 60818336 60818336 60818336 0 928 60818336 60818336 60818336 0 928 60818336 60818336 60818336 60817408 60818336 60818336 60818336 60818336 60817408)
	offset: 0@0.

	DownPicture _ Form
	extent: 9@8
	depth: 16
	fromArray: #( 60818336 60818336 60818336 60818336 60817408 928 60818336 60818336 60818336 60817408 928 60818336 60818336 60818336 0 0 60818336 60818336 60818336 0 0 928 60818336 60817408 0 0 928 60818336 60817408 0 0 0 60818336 0 0 0 0 60817408 0 0)
	offset: 0@8.

	SuffixPicture _  Form
	extent: 10@8
	depth: 16
	fromArray: #( 928 0 0 0 0 60818336 60818336 0 0 0 60818336 60818336 60818336 60817408 0 60818336 60818336 60818336 60818336 0 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 0 60818336 60818336 60818336 0 0)
	offset: 0@0! !

!TileMorph class methodsFor: 'class initialization' stamp: 'tk 8/15/2000 11:00'!
initialize
	"TileMorph readInArrowGraphics    -- call manually if necessary to bring graphics forward"
	"TileMorph initialize"

	UpdatingOperators _ Dictionary new.
	UpdatingOperators at: #incr: put: #+.
	UpdatingOperators at: #decr: put: #-.
	UpdatingOperators at: #set: put: ''.

	RetractPicture ifNil: [
		RetractPicture _ (SuffixPicture flipBy: #horizontal centerAt: (SuffixPicture center))].
	SuffixArrowAllowance _ 5 + SuffixPicture width + RetractPicture width.
	UpArrowAllowance _ 10.
! !

!TileMorph class methodsFor: 'class initialization' stamp: 'mdr 9/4/2000 11:06'!
readInArrowGraphics
	"TileMorph readInArrowGraphics"

	| obj |
	obj _ (FileStream readOnlyFileNamed: 'tile inc arrow.morph') fileInObjectAndCode.
	UpPicture _ obj form.

	obj _ (FileStream readOnlyFileNamed: 'tile dec arrow.morph') fileInObjectAndCode.
	DownPicture _ obj form.

	obj _ (FileStream readOnlyFileNamed: 'tile suffix arrow.morph')fileInObjectAndCode.
	SuffixPicture _ obj form.! !

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 16:29'!
upPicture
	^ UpPicture! !


!TileMorph class methodsFor: 'constants' stamp: 'tk 9/17/97 17:24'!
defaultH

	^ 22! !


!TileMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:12'!
defaultNameStemForInstances
	^ 'Tile'! !
TestCase subclass: #TileMorphTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!

!TileMorphTest methodsFor: 'testing' stamp: 'tak 12/5/2004 18:58'!
testArrowAction
	"self debug: #testArrowAction"
	| dummy tile |
	dummy _ Morph new.
	tile _ TileMorph new setOperator: '+'.
	dummy addMorph: tile.
	tile arrowAction: 1.
	self assert: tile codeString = '-'.

	tile _ TileMorph new setOperator: '<'.
	dummy addMorph: tile.
	tile arrowAction: 1.
	"Because receiver is not tile"
	self assert: tile codeString = '='.

	tile _ true newTileMorphRepresentative.
	dummy addMorph: tile.
	tile arrowAction: 1.
	self assert: tile codeString = '(false)'.
! !

!TileMorphTest methodsFor: 'testing' stamp: 'tak 12/5/2004 18:58'!
testAssignmentTile
	"self debug: #testAssignmentTile"

	| player viewer tile phrase |
	player _ Morph new assuredPlayer.
	viewer _ CategoryViewer new invisiblySetPlayer: player.
	viewer  makeSetter: #(#getX #Number) event: nil from: player costume.
	phrase _ ActiveHand firstSubmorph.
	ActiveHand removeAllMorphs.
	tile _ phrase submorphs second.

	self assert: tile codeString = 'setX: '.
	tile arrowAction: 1.
	self assert: tile codeString = 'setX: self getX + '.

! !

!TileMorphTest methodsFor: 'testing' stamp: 'tlk 5/6/2006 16:35'!
testSoundTile
	"self debug: #testSoundTile"
	| tile dummy |
	dummy _ Morph new.
	tile _ SoundTile new literal: 'croak'.
	dummy addMorph: tile.
	tile arrowAction: 1.
	self assert: tile codeString = '(''horn'')'.

	! !
Morph subclass: #TilePadMorph
	instanceVariableNames: 'type'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!TilePadMorph commentStamp: '<historical>' prior: 0!
The drop target for colored tiles.  Landing pad.  In the hierarchy, but not a tile itself.  Would like to eliminate this, but an attempt at it failed. !


!TilePadMorph methodsFor: 'code generation' stamp: 'jm 5/28/1998 19:10'!
storeCodeOn: aStream indent: tabCount

	submorphs do: [:m | m storeCodeOn: aStream indent: tabCount].
! !


!TilePadMorph methodsFor: 'dropping/grabbing' stamp: 'jm 6/26/97 08:30'!
wantsDroppedMorph: aMorph event: evt

	^ self canAccept: aMorph
! !


!TilePadMorph methodsFor: 'event handling' stamp: 'ar 2/8/2001 19:54'!
handlesMouseOverDragging: evt
	^true! !

!TilePadMorph methodsFor: 'event handling' stamp: 'ar 2/8/2001 19:56'!
mouseEnterDragging: evt
	evt hand hasSubmorphs ifFalse:[^self].
	(self wantsDroppedMorph: evt hand firstSubmorph event: evt) ifTrue:[
		self firstSubmorph color: Color green.
	].
! !

!TilePadMorph methodsFor: 'event handling' stamp: 'ar 2/8/2001 19:59'!
mouseLeaveDragging: evt
	evt hand hasSubmorphs ifFalse:[^self].
	(self wantsDroppedMorph: evt hand firstSubmorph event: evt) ifTrue:[
		self firstSubmorph useUniformTileColor.
	].! !


!TilePadMorph methodsFor: 'layout' stamp: 'sw 1/6/2005 03:25'!
acceptDroppingMorph: aMorph event: evt 
	"Accept the given morph within my bowels"

	| editor wasPossessive morphToUse |
	wasPossessive := submorphs notEmpty and: [submorphs first isPossessive].
	morphToUse _ self morphToDropFrom: aMorph.
	self prepareToUndoDropOf: morphToUse.
	self removeAllMorphs.
	morphToUse position: self position.
	self addMorph: morphToUse.
	wasPossessive ifTrue: [morphToUse bePossessive].
	morphToUse lastTile addRetractArrow.	"if can"
	(editor := self topEditor) ifNotNil: [editor install]! !


!TilePadMorph methodsFor: 'miscellaneous' stamp: 'dgd 8/30/2003 22:19'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add custom menu items to the menu"

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'restore default tile' translated action: #restoreDefaultTile.! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 9/17/1999 08:04'!
basicWidth
	^ 18
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'ar 8/16/2001 13:30'!
isColorConstant: aParseNode
	"Is this a Color constant, of the form (MessageNode (VariableNode Color->Color) (SelectorNode #r:g:b:) (LiteralNode LiteralNode LiteralNode))"

	| rec |
	((rec _ aParseNode receiver) isKindOf: VariableNode) ifFalse: [^ false].
	rec key isVariableBinding ifFalse: [^ false].
	rec key value == Color ifFalse: [^ false].
	aParseNode selector key == #r:g:b: ifFalse: [^ false].
	aParseNode arguments  size = 3 ifFalse: [^ false].
	^ true
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'tk 8/3/1999 13:25'!
isOutsideRef: aParseNode
	"Is this a reference to an outside Player, of the form (self class refUnscriptedPlayer1)?
(MessageNode (VariableNode 'self') (SelectorNode 'class')) (SelectorNode 'refUnscriptedPlayer1')"

	| rec |
	((rec _ aParseNode receiver) isKindOf: MessageNode) ifFalse: [^ false].
	rec receiver isSelfPseudoVariable ifFalse: [^ false].
	rec selector key == #class ifFalse: [^ false].
	aParseNode selector key numArgs = 0 ifFalse: [^ false].
	(aParseNode selector key beginsWith: 'ref') ifFalse: [^ false].
	^ true
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'tk 8/16/2000 10:01'!
lastTile
	"The tile that might get an extension arrow"

	^ self lastSubmorph lastTile! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 5/1/2005 03:42'!
morphToDropFrom: aMorph 
	"Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited.  Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service."

	| vwr |
	(aMorph isKindOf: WatcherWrapper)
		ifTrue: [^ aMorph getterTilesForDrop].
	^ ((self type capitalized = #Graphic)  "Special-case requested by Alan 4/30/05"
		and: [aMorph isKindOf: TileMorph] and: [aMorph resultType = #Player])
			ifFalse:
				[aMorph]
			ifTrue:
				[vwr _ CategoryViewer new initializeFor: aMorph associatedPlayer categoryChoice: #basic.
				vwr getterTilesFor: (Utilities getterSelectorFor: #graphic)  type: #Graphic]! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 7/22/2002 18:32'!
restoreDefaultTile
	"Restore the receiver to showing only its default literal tile"

	self setToBearDefaultLiteral.
	(self ownerThatIsA: ScriptEditorMorph) ifNotNilDo:
		[:aScriptEditor | aScriptEditor install]! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 7/22/2002 17:50'!
setToBearDefaultLiteral
	"Set the receiver so that it contains only a tile reflecting the default literal value for a pad of this type"

	self removeAllMorphs.
	self addMorphBack: (Vocabulary vocabularyForType: type) defaultArgumentTile! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 9/17/1999 08:03'!
setType: aSymbol

	type _ aSymbol.
	self color: (ScriptingSystem colorForType: type).
	self extent: (self basicWidth @ TileMorph defaultH)
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 10/3/97 18:00'!
type
	^ type! !


!TilePadMorph methodsFor: 'mouse' stamp: 'sw 5/1/2005 03:17'!
canAccept: aMorph
	"Answer whether this pad can accept the given morph"

	| itsType myType |
	((aMorph isKindOf: PhraseTileMorph) or: [aMorph isKindOf: TileMorph orOf: WatcherWrapper]) 		ifTrue:
			[^ ((itsType _ aMorph resultType capitalized) = (myType _ self type capitalized)) or:
				[(myType = #Graphic) and: [itsType = #Player]]].
	^ false! !

!TilePadMorph methodsFor: 'mouse' stamp: 'dgd 2/22/2003 14:43'!
prepareToUndoDropOf: aMorph 
	| m |
	m := self owner.
	[m isNil] whileFalse: 
			[(m isKindOf: ScriptEditorMorph) ifTrue: [^m prepareToUndoDropOf: aMorph].
			m := m owner]! !


!TilePadMorph methodsFor: 'printing' stamp: 'sma 6/1/2000 09:19'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' type='; print: type! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TilePadMorph class
	instanceVariableNames: ''!

!TilePadMorph class methodsFor: 'color' stamp: 'sw 5/8/1998 13:40'!
colorFudge
	^ 0.4! !
Magnitude subclass: #Time
	instanceVariableNames: 'seconds nanos'
	classVariableNames: ''
	poolDictionaries: 'ChronologyConstants'
	category: 'Kernel-Chronology'!
!Time commentStamp: 'dew 10/23/2004 17:58' prior: 0!
This represents a particular point in time during any given day.  For example, '5:19:45 pm'.

If you need a point in time on a particular day, use DateAndTime.  If you need a duration of time, use Duration.
!


!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 15:54'!
< aTime

	^ self asDuration < aTime asDuration! !

!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:11'!
= aTime

	^ [ self ticks = aTime ticks ]
		on: MessageNotUnderstood do: [false]! !

!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:32'!
duration

	^ Duration zero
! !

!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:11'!
hash

	^ self ticks hash
! !

!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:10'!
hour

	^ self hour24
! !

!Time methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 18:45'!
hour12
	"Answer an <integer> between 1 and 12, inclusive, representing the hour 
	of the day in the 12-hour clock of the local time of the receiver."
	^ self hour24 - 1 \\ 12 + 1! !

!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:17'!
hour24


	^ self asDuration hours
! !

!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:41'!
meridianAbbreviation

	^ self hour < 12 ifTrue: ['AM'] ifFalse: ['PM'].
! !

!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 22:08'!
minute

	^ self asDuration minutes! !

!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:19'!
second


	^ self asDuration seconds! !


!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'!
hhmm24
	"Return a string of the form 1123 (for 11:23 am), 2154 (for 9:54 pm), of exactly 4 digits"

	^(String streamContents: 
		[ :aStream | self print24: true showSeconds: false on: aStream ])
			copyWithout: $:! !

!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'!
print24
	"Return as 8-digit string 'hh:mm:ss', with leading zeros if needed"

	^String streamContents:
		[ :aStream | self print24: true on: aStream ]

! !

!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'!
print24: hr24 on: aStream 
	"Format is 'hh:mm:ss' or 'h:mm:ss am' "

	self print24: hr24 showSeconds: true on: aStream 
! !

!Time methodsFor: 'printing' stamp: 'brp 2/16/2004 09:10'!
print24: hr24 showSeconds: showSeconds on: aStream 
	"Format is 'hh:mm:ss' or 'h:mm:ss am'  or, if showSeconds is false, 'hh:mm' or 'h:mm am'"

	| h m s |
	h _ self hour. m _ self minute. s _ self second.
	hr24
	
	ifTrue: 
			[ h < 10 ifTrue: [ aStream nextPutAll: '0' ].
	
		h printOn: aStream ]
	
	ifFalse:
			[ h > 12
		
		ifTrue: [h - 12 printOn: aStream]
		
		ifFalse: 
			
		[h < 1
		
				ifTrue: [ 12 printOn: aStream ]
						ifFalse: [ h printOn: aStream ]]].

	aStream nextPutAll: (m < 10 ifTrue: [':0'] ifFalse: [':']).
	m printOn: aStream.

	showSeconds ifTrue:
	
	[ aStream nextPutAll: (s < 10 ifTrue: [':0'] ifFalse: [':']).
		s asInteger printOn: aStream ].

	hr24 ifFalse:
	
	[ aStream nextPutAll: (h < 12 ifTrue: [' am'] ifFalse: [' pm']) ].
! !

!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'!
printMinutes
	"Return as string 'hh:mm pm'  "

	^String streamContents:
		[ :aStream | self print24: false showSeconds: false on: aStream ]
! !

!Time methodsFor: 'printing' stamp: 'brp 8/23/2003 19:14'!
printOn: aStream 

	self print24: false showSeconds: (self seconds ~= 0) on: aStream! !

!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'!
storeOn: aStream

	aStream print: self printString; nextPutAll: ' asTime'! !


!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:02'!
addSeconds: nSeconds 
	"Answer a Time that is nSeconds after the receiver."

	^ self class seconds: self asSeconds + nSeconds! !

!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:02'!
addTime: timeAmount
	"Answer a Time that is timeInterval after the receiver. timeInterval is an 
	instance of Date or Time."

	^ self class seconds: self asSeconds + timeAmount asSeconds! !

!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 15:55'!
asSeconds
	"Answer the number of seconds since midnight of the receiver."

	^ seconds! !

!Time methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:29'!
hours

	^ self hour! !

!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:24'!
intervalString
	"Treat the time as a difference.  Give it in hours and minutes with two digits of accuracy."

	| d |
	d _ self asDuration.
	^ String streamContents: [ :s |
		d hours > 0 ifTrue: [s print: d hours; nextPutAll: ' hours'].
		d minutes > 0 ifTrue: [s space; print: d minutes; nextPutAll: ' minutes'].
		d seconds > 0 ifTrue: [s space; print: d seconds; nextPutAll: ' seconds'] ].

! !

!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:07'!
minutes

	^ self asDuration minutes! !

!Time methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 18:18'!
seconds

	^ self second! !

!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:03'!
subtractTime: timeAmount 
	"Answer a Time that is timeInterval before the receiver. timeInterval is  
	an instance of Date or Time."

	^ self class seconds: self asSeconds - timeAmount asSeconds! !


!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 23:58'!
asDate

	^ Date today! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:26'!
asDateAndTime

	^ DateAndTime today + self! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:01'!
asDuration

	"Answer the duration since midnight"

	^ Duration seconds: seconds nanoSeconds: nanos
! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:29'!
asMonth

	^ self asDateAndTime asMonth! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:29'!
asNanoSeconds
	"Answer the number of nanoseconds since midnight"

	^ self asDuration asNanoSeconds
! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:08'!
asTime

	^ self! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:27'!
asTimeStamp

	^ self asDateAndTime asTimeStamp! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:28'!
asWeek

	^ self asDateAndTime asWeek! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:43'!
asYear

	^ self asDateAndTime asYear! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:33'!
nanoSecond


	^ nanos
! !

!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:35'!
to: anEnd
	"Answer a Timespan. anEnd must respond to #asDateAndTime"

	^ self asDateAndTime to: anEnd! !


!Time methodsFor: 'private' stamp: 'brp 8/23/2003 22:38'!
ticks
	"Answer an Array: { seconds. nanoSeconds }"

	^ Array with: 0 with: seconds with: nanos.! !

!Time methodsFor: 'private' stamp: 'brp 8/23/2003 20:44'!
ticks: anArray
	"ticks is an Array: { days. seconds. nanoSeconds }"

	seconds _ anArray second.
	nanos _ anArray third.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Time class
	instanceVariableNames: ''!

!Time class methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 18:56'!
now
	"Answer a Time representing the time right now - this is a 24 hour clock."

	^ self seconds: self totalSeconds \\ 86400.
! !


!Time class methodsFor: 'benchmarks' stamp: 'brp 8/24/2003 00:06'!
benchmarkMillisecondClock		"Time benchmarkMillisecondClock"
	"Benchmark the time spent in a call to Time>>millisecondClockValue.
	On the VM level this tests the efficiency of calls to ioMSecs()."
	"PII/400 Windows 98: 0.725 microseconds per call"
	| temp1 temp2 temp3 delayTime nLoops time |
	delayTime _ 5000. "Time to run benchmark is approx. 2*delayTime"

	"Don't run the benchmark if we have an active delay since
	we will measure the additional penalty in the primitive dispatch
	mechanism (see #benchmarkPrimitiveResponseDelay)."
	Delay anyActive ifTrue:[
		^self notify:'Some delay is currently active.
Running this benchmark will not give any useful result.'].

	"Flush the cache for this benchmark so we will have
	a clear cache hit for each send to #millisecondClockValue below"
	Object flushCache.
	temp1 _ 0.
	temp2 _ self. "e.g., temp1 == Time"
	temp3 _ self millisecondClockValue + delayTime.

	"Now check how often we can run the following loop in the given time"
	[temp2 millisecondClockValue < temp3]
		whileTrue:[temp1 _ temp1 + 1].

	nLoops _ temp1. "Remember the loops we have run during delayTime"

	"Setup the second loop"
	temp1 _ 0.
	temp3 _ nLoops.

	"Now measure how much time we spend without sending #millisecondClockValue"
	time _ Time millisecondClockValue.
	[temp1 < temp3]
		whileTrue:[temp1 _ temp1 + 1].
	time _ Time millisecondClockValue - time.

	"And compute the number of microseconds spent per call to #millisecondClockValue"
	^((delayTime - time * 1000.0 / nLoops) truncateTo: 0.001) printString,
		' microseconds per call to Time>>millisecondClockValue'! !

!Time class methodsFor: 'benchmarks' stamp: 'BP 3/30/2001 15:25'!
benchmarkPrimitiveResponseDelay	"Time benchmarkPrimitiveResponseDelay"
	"Benchmark the overhead for primitive dispatches with an active Delay.
	On the VM level, this tests the efficiency of ioLowResMSecs."

	"PII/400 Windows98: 0.128 microseconds per prim"

	"ar 9/6/1999: This value is *extremely* important for stuff like sockets etc.
	I had a bad surprise when Michael pointed this particular problem out:
	Using the hardcoded clock() call for ioLowResMSecs on Win32 resulted in an overhead
	of 157.4 microseconds per primitive call - meaning you can't get no more than
	approx. 6000 primitives per second on my 400Mhz PII system with an active delay!!
	BTW, it finally explains why Squeak seemed soooo slow when running PWS or 
	other socket stuff. The new version (not using clock() but some Windows function) 
	looks a lot better (see above; approx. 8,000,000 prims per sec with an active delay)."

	| nLoops bb index baseTime actualTime delayTime |
	delayTime _ 5000. "Time to run this test is approx. 3*delayTime"

	Delay anyActive ifTrue:[
		^self notify:'Some delay is currently active.
Running this benchmark will not give any useful result.'].

	bb _ Array new: 1. "The object we send the prim message to"

	"Compute the # of loops we'll run in a decent amount of time"
	[(Delay forMilliseconds: delayTime) wait] 
		forkAt: Processor userInterruptPriority.

	nLoops _ 0.
	[Delay anyActive] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		nLoops _ nLoops + 1.
	].

	"Flush the cache and make sure #basicSize is in there"
	Object flushCache.
	bb basicSize.

	"Now run the loop without any active delay
	for getting an idea about its actual speed."
	baseTime _ self millisecondClockValue.
	index _ nLoops.
	[index > 0] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		index _ index - 1.
	].
	baseTime _ self millisecondClockValue - baseTime.

	"Setup the active delay but try to never make it active"
	[(Delay forMilliseconds: delayTime + delayTime) wait] 
		forkAt: Processor userInterruptPriority.

	"And run the loop"
	actualTime _ self millisecondClockValue.
	index _ nLoops.
	[index > 0] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		index _ index - 1.
	].
	actualTime _ self millisecondClockValue - actualTime.

	"And get us some result"
	^((actualTime - baseTime) * 1000 asFloat / (nLoops * 10) truncateTo: 0.001) printString,
		' microseconds overhead per primitive call'! !


!Time class methodsFor: 'general inquiries' stamp: 'BP 3/30/2001 15:25'!
condenseBunches: aCollectionOfSeconds
	| secArray pause now out prev bunchEnd ago |
	"Identify the major intervals in a bunch of numbers.  
	Each number is a seconds since 1901 that represents a date and time.
	We want the last event in a bunch.  Return array of seconds for:
	
	Every event in the last half hour.
		Every bunch separated by 30 min in the last 24 hours.
	
	Every bunch separated by two hours before that."

	"Time condenseBunches: 
		(#(20 400 401  20000 20200 20300 40000 45000  200000 201000 202000) 
			collect: [ :tt | self totalSeconds - tt])
"

	secArray _ aCollectionOfSeconds asSortedCollection.
	pause _ 1.
	now _ self totalSeconds.
	out _ OrderedCollection new.
	prev _ 0.
	bunchEnd _ nil.
	secArray reverseDo: [:secs | "descending"
		ago _ now - secs.
		ago > (60*30) ifTrue: [pause _ "60*30" 1800].
		ago > (60*60*24) ifTrue: [pause _ "60*120" 7200].
		ago - prev >= pause ifTrue: [out add: bunchEnd.  bunchEnd _ secs].
		prev _ ago].
	out add: bunchEnd.
	out removeFirst.
	^ out! !

!Time class methodsFor: 'general inquiries' stamp: 'brp 8/23/2003 23:59'!
humanWordsForSecondsAgo: secs
	| date today |
	"Return natural language for this date and time in the past."

	secs <= 1 ifTrue: [^ 'a second ago'].
	secs < 45 ifTrue: [^ secs printString, ' seconds ago'].
	secs < 90 ifTrue: [^ 'a minute ago'].
	secs < "45*60" 2700 ifTrue: [^ (secs//60) printString, ' minutes ago'].
	secs < "90*60" 5400 ifTrue: [^ 'an hour ago'].
	secs < "18*60*60" 64800 ifTrue: [^ (secs//3600) printString, ' hours ago'].
	date _ Date fromSeconds: self totalSeconds - secs.		"now work with dates"
	today _ Date today.
	date > (today subtractDays: 2) ifTrue: [^ 'yesterday'].
	date > (today subtractDays: 8) ifTrue: [^ 'last ', date dayOfWeekName].
	date > (today subtractDays: 13) ifTrue: [^ 'a week ago'].
	date > (today subtractDays: 28) ifTrue: [
		^ ((today subtractDate: date)//7) printString, ' weeks ago'].
	date > (today subtractDays: 45) ifTrue: [^ 'a month ago'].
	date > (today subtractDays: 300) ifTrue: [^ 'last ', date monthName].
	^ date monthName, ', ', date year printString

"Example
#(0.5 30 62 130 4000 10000 60000 90000 345600 864000 1728000 3456000 17280000 34560000 345600000) 
		collect: [:ss | Time humanWordsForSecondsAgo: ss].
"! !

!Time class methodsFor: 'general inquiries' stamp: 'nk 3/8/2004 12:05'!
millisecondClockValue
	"Answer the number of milliseconds since the millisecond clock was last reset or rolled over.
	Answer 0 if the primitive fails."

	<primitive: 135>
	^ 0! !

!Time class methodsFor: 'general inquiries' stamp: 'ar 11/25/2004 11:26'!
millisecondsToRun: timedBlock 
	"Answer the number of milliseconds timedBlock takes to return its value."

	| initialMilliseconds |
	initialMilliseconds _ self millisecondClockValue.
	timedBlock value.
	^self millisecondsSince: initialMilliseconds! !

!Time class methodsFor: 'general inquiries' stamp: 'BP 3/30/2001 15:25'!
namesForTimes: arrayOfSeconds
	| simpleEnglish prev final prevPair myPair |
	"Return English descriptions of the times in the array.  They are each seconds since 1901.  If two names are the same, append the date and time to distinguish them."

	simpleEnglish _ arrayOfSeconds collect: [:secsAgo |
		self humanWordsForSecondsAgo: self totalSeconds - secsAgo].
	prev _ ''.
	final _ simpleEnglish copy.
	simpleEnglish withIndexDo: [:eng :ind | 
		eng = prev ifFalse: [eng]
			ifTrue: ["both say 'a month ago'"
				prevPair _ self dateAndTimeFromSeconds: 
						(arrayOfSeconds at: ind-1).
				myPair _ self dateAndTimeFromSeconds: 
						(arrayOfSeconds at: ind).
				(final at: ind-1) = prev ifTrue: ["only has 'a month ago'"
					final at: ind-1 put: 
							(final at: ind-1), ', ', prevPair first mmddyyyy].
				final at: ind put: 
							(final at: ind), ', ', myPair first mmddyyyy.
				prevPair first = myPair first 
					ifTrue: [
						(final at: ind-1) last == $m ifFalse: ["date but no time"
							final at: ind-1 put: 
								(final at: ind-1), ', ', prevPair second printMinutes].
						final at: ind put: 
							(final at: ind), ', ', myPair second printMinutes]].
		prev _ eng].
	^ final! !


!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 23:59'!
dateAndTimeFromSeconds: secondCount

	^ Array
		with: (Date fromSeconds: secondCount)
		with: (Time fromSeconds: secondCount \\ 86400)
! !

!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:50'!
dateAndTimeNow
	"Answer a two-element Array of (Date today, Time now)."

	^ self dateAndTimeFromSeconds: self totalSeconds! !

!Time class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:11'!
fromSeconds: secondCount 
	"Answer an instance of me that is secondCount number of seconds since midnight."

	^ self seconds: secondCount
! !

!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 20:01'!
new
	"Answer a Time representing midnight"

	^ self midnight! !

!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:01'!
primMillisecondClock
	"Primitive. Answer the number of milliseconds since the millisecond clock
	 was last reset or rolled over. Answer zero if the primitive fails.
	 Optional. See Object documentation whatIsAPrimitive."

	<primitive: 135>
	^ 0! !

!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:01'!
primSecondsClock
	"Answer the number of seconds since 00:00 on the morning of
	 January 1, 1901 (a 32-bit unsigned number).
	 Essential. See Object documentation whatIsAPrimitive. "

	<primitive: 137>
	self primitiveFailed! !

!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 20:07'!
readFrom: aStream
	"Read a Time from the stream in the form:
		<hour>:<minute>:<second> <am/pm>

	<minute>, <second> or <am/pm> may be omitted.  e.g. 1:59:30 pm; 8AM; 15:30"

	| hour minute second ampm |
	hour _ Integer readFrom: aStream.
	minute _ 0.
	second _ 0.
	(aStream peekFor: $:) ifTrue:
	
	[ minute _ Integer readFrom: aStream.
		(aStream peekFor: $:) ifTrue: [ second _ Integer readFrom: aStream ]].
	aStream skipSeparators.
	(aStream atEnd not and: [aStream peek isLetter]) ifTrue: 
		[ampm _ aStream next asLowercase.
	
	(ampm = $p and: [hour < 12]) ifTrue: [hour _ hour + 12].
		(ampm = $a and: [hour = 12]) ifTrue: [hour _ 0].
	
	(aStream peekFor: $m) ifFalse: [aStream peekFor: $M ]].

	^ self hour: hour minute: minute second: second

	"Time readFrom: (ReadStream on: '2:23:09 pm')"
! !

!Time class methodsFor: 'smalltalk-80' stamp: 'dtl 10/11/2004 22:15'!
totalSeconds
	"Answer the total seconds since the Squeak epoch: 1 January 1901."

	^ self primSecondsClock! !


!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:46'!
current 

	^ self now! !

!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:05'!
hour: hour minute: minute second: second
	"Answer a Time"

	^ self hour: hour minute: minute second: second nanoSecond: 0! !

!Time class methodsFor: 'squeak protocol' stamp: 'brp` 8/24/2003 19:26'!
hour: hour minute: minute second: second  nanoSecond: nanoCount
	"Answer a Time - only second precision for now"

	^ self 
		seconds: (hour * SecondsInHour) + (minute * SecondsInMinute) + second 
		nanoSeconds: nanoCount! !

!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:01'!
midnight

	^ self seconds: 0
! !

!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 18:58'!
milliseconds: currentTime since: lastTime
	"Answer the elapsed time since last recorded in milliseconds.
	Compensate for rollover."

	| delta |
	delta _ currentTime - lastTime.
	^ delta < 0
		ifTrue: [SmallInteger maxVal + delta]
		ifFalse: [delta]
! !

!Time class methodsFor: 'squeak protocol' stamp: 'BP 3/30/2001 15:25'!
millisecondsSince: lastTime
	"Answer the elapsed time since last recorded in milliseconds.
	Compensate for rollover."

	^self milliseconds: self millisecondClockValue since: lastTime! !

!Time class methodsFor: 'squeak protocol' stamp: 'brp` 8/24/2003 19:26'!
noon

	^ self seconds: (SecondsInDay / 2)
! !

!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:47'!
seconds: seconds
	"Answer a Time from midnight"

	^ self seconds: seconds nanoSeconds: 0! !

!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:46'!
seconds: seconds nanoSeconds: nanoCount
	"Answer a Time from midnight"

	^ self basicNew
		ticks: (Duration seconds: seconds nanoSeconds: nanoCount) ticks;
		yourself
! !


!Time class methodsFor: '*monticello' stamp: 'nk 11/2/2003 10:51'!
fromString: aString
	^ self readFrom: (ReadStream on: aString).
! !
TestCase subclass: #TimeMeasuringTest
	instanceVariableNames: 'realTime shouldProfile'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Requires'!

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'md 2/22/2006 14:27'!
debug
	self resources do: [:res | 
		res isAvailable ifFalse: [^res signalInitializationError]].
	[(self class selector: testSelector) setToDebug; runCase] 
		ensure: [self resources do: [:each | each reset]]
			! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 15:09'!
initialize
	shouldProfile _ false.! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 16:07'!
measure: measuredBlock 
	shouldProfile 
		ifTrue: [TimeProfileBrowser onBlock: [10 timesRepeat: measuredBlock]].
	realTime := measuredBlock timeToRun! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 15:09'!
openDebuggerOnFailingTestMethod
	shouldProfile _ true! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:53'!
reportPerformance
	| str |
	str := CrLfFileStream fileNamed: 'performanceReports.txt'.
	str setToEnd;
		nextPutAll: ' test: ', testSelector;
		nextPutAll: ' time: ', realTime asString; 
		nextPutAll: ' version: ', self versionInformation;
		cr; 
		close! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:58'!
runCase
	[super runCase] ensure: [self reportPerformance]! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 15:13'!
setToDebug
	shouldProfile _ true
! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:59'!
versionInfoForWorkingCopiesThat: wcPredicate 
	^(MCWorkingCopy allManagers select: wcPredicate) inject: ''
		into: [:s :e | s , e description]! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:48'!
versionInformation
	| wcPredicate |
	wcPredicate := self workingCopyPredicate.
	^self versionInfoForWorkingCopiesThat: wcPredicate! !

!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:48'!
workingCopyPredicate
	^[:e | '*Traits*' match: e package name]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TimeMeasuringTest class
	instanceVariableNames: ''!
MessageSet subclass: #TimeProfileBrowser
	instanceVariableNames: 'selectedClass selectedSelector block tally'
	classVariableNames: 'TextMenu'
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!TimeProfileBrowser commentStamp: '<historical>' prior: 0!
A TimeProfileBrowser is a browser visualizing the runtime profile of an executed Smalltalk block.  It is useful for finding performance bottlenecks in code. When optimizing code it can
be hard to know what methods actually constitute the bulk of the execution time. Is it a few
methods that take very long time to execute or is it perhaps a single method that gets executed a thousand times?

The block is first spied on using a MessageTally instance (which has even more funtionality than used by the TimeProfileBrowser) which samples the block during it's execution and collects the amount of time approximately spent in the methods executed. Then the methods are shown in the browser with their relative execution time in percent.

Example:
TimeProfileBrowser onBlock: [20 timesRepeat:  [Transcript show: 100 factorial printString]]
!


!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
selectedClass
	"Answer the receiver's 'selectedClass'."

	^selectedClass! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
selectedClass: anObject
	"Set the receiver's instance variable 'selectedClass' to be anObject."

	selectedClass := anObject! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
selectedSelector
	"Answer the receiver's 'selectedSelector'."

	^selectedSelector! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
selectedSelector: anObject
	"Set the receiver's instance variable 'selectedSelector' to be anObject."

	selectedSelector := anObject! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
tally
	"Answer the receiver's 'tally'."

	^tally! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
tally: anObject
	"Set the receiver's instance variable 'tally' to be anObject."

	tally := anObject! !


!TimeProfileBrowser methodsFor: 'message list' stamp: 'nk 2/23/2005 18:00'!
selectedMessage
	"Answer the source method for the currently selected message."

	| source |
	self setClassAndSelectorIn: 
			[:class :selector | 
			source := class sourceMethodAt: selector ifAbsent: [^'Missing'].
			Preferences browseWithPrettyPrint 
				ifTrue: 
					[source := class prettyPrinterClass 
								format: source
								in: class
								notifying: nil
								decorated: false].
			self selectedClass: class.
			self selectedSelector: selector.
			^source asText makeSelectorBoldIn: class].
	^''! !


!TimeProfileBrowser methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
initializeMessageList: anArray
	messageList := anArray.
	messageListIndex := 0.
	contents := ''! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'nk 3/8/2004 13:22'!
messageListKey: aChar from: view 
	"Respond to a Command key. Cmd-D means re-run block."

	aChar == $d ifTrue: [^Cursor execute showWhile: [ block value ]].
	^super messageListKey: aChar from: view! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'stp 05/08/1999 15:27'!
messageListMenu: aMenu shifted: shifted
	"Add a menu to the inherited one."

	| menu |
	menu := super messageListMenu: aMenu shifted: shifted.
"	menu addItem: (0)."
	^menu! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'nk 3/8/2004 12:51'!
runBlock: aBlock
	^self runBlock: aBlock pollingEvery: MessageTally defaultPollPeriod! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'nk 3/8/2004 13:23'!
runBlock: aBlock pollingEvery: pollPeriod 
	| stream list result |
	block := MessageSend 
				receiver: self
				selector: #runBlock:pollingEvery:
				arguments: { 
						aBlock.
						pollPeriod}.	"so we can re-run it"
	tally := MessageTally new.
	tally
		maxClassNameSize: 1000;
		maxClassPlusSelectorSize: 1000;
		maxTabs: 100.
	result := tally spyEvery: pollPeriod on: aBlock.
	stream := ReadWriteStream 
				with: (String streamContents: 
							[:s | 
							tally
								report: s;
								close]).
	stream reset.
	list := OrderedCollection new.
	[stream atEnd] whileFalse: [list add: stream nextLine].
	self initializeMessageList: list.
	self changed: #messageList.
	self changed: #messageListIndex.
	^result! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'nk 3/8/2004 13:24'!
runProcess: aProcess forMilliseconds: msecDuration pollingEvery: pollPeriod 
	| stream list result |
	block := MessageSend 
				receiver: self
				selector: #runProcess:forMilliseconds:pollingEvery: 
				arguments: { 
						aProcess.
						msecDuration.
						pollPeriod}.	"so we can re-run it"
	tally := MessageTally new.
	tally
		maxClassNameSize: 1000;
		maxClassPlusSelectorSize: 1000;
		maxTabs: 100.
	result := tally 
				spyEvery: pollPeriod
				onProcess: aProcess
				forMilliseconds: msecDuration.
	stream := ReadWriteStream 
				with: (String streamContents: 
							[:s | 
							tally
								report: s;
								close]).
	stream reset.
	list := OrderedCollection new.
	[stream atEnd] whileFalse: [list add: stream nextLine].
	self initializeMessageList: list.
	self changed: #messageList.
	self changed: #messageListIndex.
	^result! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
setClassAndSelectorIn: csBlock
	"Decode strings of the form    <selectorName> (<className> [class])  "

	| string strm class sel parens |

	self flag: #mref.	"fix for faster references to methods"

	[string := self selection asString.
	string first == $* ifTrue: [^contents := nil].		"Ignore lines starting with *"
	parens := string includes: $(.					"Does it have open-paren?"
	strm := ReadStream on: string.
	parens
		ifTrue: [strm skipTo: $(.		"easy case"
			class := strm upTo: $).
			strm next: 2.
			sel := strm upToEnd]
		ifFalse: [strm position: (string findString: ' class>>').
			strm position > 0
				ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])]
				ifTrue:
					[ | subString |  "find the next to last space character"
					subString := strm contents copyFrom: 1 to: (string findLast: [ :ch | ch == $ ]) - 1.
					strm position: (subString findLast: [ :ch | ch == $ ])].
		"ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])."
			class := strm upTo: $>.
			strm next.
			sel := strm upToEnd].
	^ MessageSet parse: (class, ' ', sel) toClassAndSelector: csBlock]
		on: Error do: [:ex | ^ contents := nil]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TimeProfileBrowser class
	instanceVariableNames: ''!

!TimeProfileBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
onBlock: block
	"Open a profile browser on the given block, thereby running the block and 
	 collecting the message tally."
	"TimeProfileBrowser onBlock: [20 timesRepeat: 
			[Transcript show: 100 factorial printString]]"

	| inst result |
	inst := self new.
	result := inst runBlock: block.
	self open: inst name: 'Time Profile'.
	^ result! !

!TimeProfileBrowser class methodsFor: 'instance creation' stamp: 'nk 3/8/2004 12:46'!
spyOn: block
	"Open a profile browser on the given block, thereby running the block and 
	 collecting the message tally."
	"TimeProfileBrowser spyOn:  [20 timesRepeat: 
			[Transcript show: 100 factorial printString]]"

	^self onBlock: block! !

!TimeProfileBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
spyOnProcess: aProcess forMilliseconds: msecDuration 
	"Run aProcess for msecDuration milliseconds, then open a TimeProfileBrowser on the results."

	"| p |  
	p := [100000 timesRepeat: [3.14159 printString]] fork.  
	(Delay forMilliseconds: 100) wait.  
	TimeProfileBrowser spyOnProcess: p forMilliseconds: 1000"

	| inst |
	inst := self new.
	inst runProcess: aProcess forMilliseconds: msecDuration pollingEvery: MessageTally defaultPollPeriod.
	self open: inst name: (String streamContents: [ :s | s nextPutAll: 'Time Profile for '; print: msecDuration; nextPutAll: ' msec' ]).
	^ inst! !
DateAndTime subclass: #TimeStamp
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Chronology'!
!TimeStamp commentStamp: '<historical>' prior: 0!
This represents a duration of 0 length that marks a particular point in time.!


!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:13'!
asTimeStamp
	"Answer the receiver as an instance of TimeStamp."

	^ self! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:14'!
date
	"Answer the date of the receiver."

	^ self asDate! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:17'!
dateAndTime
	"Answer a two element Array containing the receiver's date and time."

	^ Array with: self date with: self time! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:19'!
minusDays: anInteger
	"Answer a TimeStamp which is anInteger days before the receiver."

	^ self - (anInteger days)! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:19'!
minusSeconds: anInteger
	"Answer a TimeStamp which is anInteger number of seconds before the receiver."

	^ self - (anInteger seconds)! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:18'!
plusDays: anInteger
	"Answer a TimeStamp which is anInteger days after the receiver."

	^ self + (anInteger days)! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:19'!
plusSeconds: anInteger
	"Answer a TimeStamp which is anInteger number of seconds after the receiver."

	^ self + (anInteger seconds)! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:17'!
printOn: aStream 
	"Print receiver's date and time on aStream."

	aStream 
		nextPutAll: self date printString;
		space;
		nextPutAll: self time printString.! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:17'!
storeOn: aStream 

	aStream 
		print: self printString;
		nextPutAll: ' asTimeStamp'! !

!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:15'!
time
	"Answer the time of the receiver."

	^ self asTime! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TimeStamp class
	instanceVariableNames: ''!

!TimeStamp class methodsFor: 'ansi protocol' stamp: 'fbs 4/20/2004 14:22'!
now
	"Answer the current date and time as a TimeStamp."

	^self current! !


!TimeStamp class methodsFor: 'squeak protocol' stamp: 'fbs 4/20/2004 14:21'!
current

	| ts ticks |
	ts _ super now.
	
	ticks _ ts ticks.
	ticks at: 3 put: 0.
	ts ticks: ticks offset: ts offset.
	
	^ ts
		
! !


!TimeStamp class methodsFor: '*monticello-instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'!
fromMethodTimeStamp: aString
	| stream |
	stream := ReadStream on: aString.
	stream skipSeparators.
	stream skipTo: Character space.
	^self readFrom: stream.! !

!TimeStamp class methodsFor: '*monticello-instance creation' stamp: 'nk 10/21/2003 23:05'!
fromString: aString
	"Answer a new instance for the value given by aString.

	 TimeStamp fromString: '1-10-2000 11:55:00 am'. 
	"

	^self readFrom: (ReadStream on: aString).! !

!TimeStamp class methodsFor: '*monticello-instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'!
readFrom: stream
	| date time |
	stream skipSeparators.
	date := Date readFrom: stream.
	stream skipSeparators.
	time := Time readFrom: stream.
	^self 
		date: date
		time: time! !
ClassTestCase subclass: #TimeStampTest
	instanceVariableNames: 'timestamp aTimeStamp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!TimeStampTest commentStamp: 'brp 7/26/2003 22:44' prior: 0!
This is the unit test for the class TimeStamp.!


!TimeStampTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:50'!
classToBeTested

	^ self timestampClass! !

!TimeStampTest methodsFor: 'Coverage' stamp: 'brp 1/30/2005 09:13'!
selectorsToBeIgnored

	| deprecated private special |

	deprecated := #().
	private := #( #printOn: ).
	special := #().

	^ super selectorsToBeIgnored, deprecated, private, special.! !


!TimeStampTest methodsFor: 'Running' stamp: 'brp 1/21/2004 18:41'!
setUp

	timestamp := self timestampClass date: ('1-10-2000' asDate) time: ('11:55:00 am' asTime).

	aTimeStamp := TimeStamp readFrom: '1-02-2004 12:34:56 am' readStream! !

!TimeStampTest methodsFor: 'Running' stamp: 'brp 7/26/2003 21:53'!
tearDown

	timestamp := nil.! !


!TimeStampTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 21:56'!
testAccessing

	| d t |
	d := '1-10-2000' asDate.
	t := '11:55:00 am' asTime.

	self
		assert: timestamp date = d;
		assert: timestamp time = t.
! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:05'!
testArithmetic

	| ts |
	ts := timestamp minusDays: 123.  	"9 September 1999, 11:55 am"
	ts := ts minusSeconds: 1056.			"9 September 1999, 11:37:24 am"
	ts := ts plusDays: 123.				"10 January 2000, 11:37:24 am"
	ts := ts plusSeconds: 1056.			"10 January 2000, 11:55 am"
	self
		assert: ts  = timestamp.

	! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:34'!
testArithmeticAcrossDateBoundary

	| ts |
	ts := timestamp minusSeconds: ((11*3600) + (55*60) + 1).
	self
		assert: ts = ('1-9-2000 11:59:59 pm' asTimeStamp).

	! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 3/12/2004 15:54'!
testComparing

	| ts1 ts2 ts3 c1 c2 le |
	ts1 := self timestampClass date: ('01-10-2000' asDate) time: ('11:55:00 am' asTime).
	ts2 := self timestampClass date: ('07-26-2003' asDate) time: ('22:09:45 am' asTime).
	ts3 := self timestampClass date: ('05-28-1972' asDate) time: ('04:31:14 pm' asTime).

	self
		assert: ts1 = timestamp;
		assert: ts1 hash = timestamp hash;
		assert: timestamp = timestamp copy;
		assert: ts1 < ts2;
		deny: ts1 < ts3.

	c1 := self timestampClass current.
	c2 := self timestampClass current.
	le _ (c1 <= c2).
	self assert: le.

! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:19'!
testConverting

	| d t |
	d := '1-10-2000' asDate.
	t := '11:55:00 am' asTime.

	self
		assert: timestamp asSeconds = (d asSeconds + t asSeconds);
		assert: timestamp asDate = d;
		assert: timestamp asTime = t;
		assert: timestamp asTimeStamp == timestamp;
		assert: timestamp dateAndTime = {d. t}.
! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:55'!
testFromSeconds

	self
		assert: (self timestampClass fromSeconds: 3124958100) = timestamp.! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 15:02'!
testFromString
	"This should signal an exception in 3.6beta as Time>>fromString: does not exist."

	self should: [ timestamp = (self timestampClass fromString: '1-10-2000 11:55:00 am') ] 

! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 1/30/2005 09:12'!
testInstanceCreation

	self 
		should: [ self timestampClass midnight asDuration = (0 hours) ];
		should: [ self timestampClass noon asDuration = (12 hours) ].
! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 15:02'!
testPrinting

	self	
		assert: timestamp printString = '10 January 2000 11:55 am'.
! !

!TimeStampTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 17:47'!
testSorting

	| c1 c2 |
	c1 _ self timestampClass current.
	c2 _ self timestampClass current.

	self
		assert: (self timestampClass current) <= (self timestampClass current);
		assert: (c1 <= c2).


! !


!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testDate
	self assert: aTimeStamp date = '01-02-2004' asDate! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testDateAndTime
	self assert: aTimeStamp dateAndTime
			= (Array with: '01-02-2004' asDate with: '00:34:56' asTime)! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testMinusDays
	self assert: (aTimeStamp minusDays: 5) dateAndTime
			= (Array with: '12-28-2003' asDate with: '00:34:56' asTime)! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testMinusSeconds
	self assert: (aTimeStamp minusSeconds: 34 * 60 + 56) dateAndTime
			= (Array with: '01-02-2004' asDate with: '00:00:00' asTime)! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testMinusSecondsOverMidnight
	self assert: (aTimeStamp minusSeconds: 34 * 60 + 57) dateAndTime
			= (Array with: '01-01-2004' asDate with: '23:59:59' asTime)
	"Bug The results are actual results are: #(1 January 2005 11:25:03 pm)"! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testPlusDays
	self assert: (aTimeStamp plusDays: 366) dateAndTime
			= (Array with: '01-02-2005' asDate with: '00:34:56' asTime)! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testPlusSeconds
	self assert: (aTimeStamp plusSeconds: 60 * 60 ) dateAndTime
			= (Array with: '01-02-2004' asDate with: '01:34:56' asTime)! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testPlusSecondsOverMidnight
	self assert: (aTimeStamp plusSeconds: 24 * 60 * 60 + 1) dateAndTime
			= (Array with: '01-03-2004' asDate with: '00:34:57' asTime)! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testPrintOn
	| cs rw |
	cs := ReadStream on: '2 January 2004 12:34:56 am'.
	rw := ReadWriteStream on: ''.
	aTimeStamp printOn: rw.
	self assert: rw contents = cs contents! !

!TimeStampTest methodsFor: 'testing' stamp: 'cbc 2/4/2004 21:18'!
testReadFromA1
	|ts|
	ts _ TimeStamp current.
	self assert: (ts = (TimeStamp fromString: ts asString)).! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testStoreOn
	| cs rw |
	cs := ReadStream on: '''2 January 2004 12:34:56 am'' asTimeStamp'.
	rw := ReadWriteStream on: ''.
	aTimeStamp storeOn: rw.
	self assert: rw contents = cs contents! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testTime
	self assert: aTimeStamp time =  '00:34:56' asTime! !

!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'!
testTimeStamp
	self assert: aTimeStamp = aTimeStamp asTimeStamp
! !


!TimeStampTest methodsFor: 'Private' stamp: 'brp 7/27/2003 13:50'!
timestampClass

	^ TimeStamp! !
ClassTestCase subclass: #TimeTest
	instanceVariableNames: 'time aTime localTimeZoneToRestore'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!TimeTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Time.

!


!TimeTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:31'!
classToBeTested

	^ self timeClass! !

!TimeTest methodsFor: 'Coverage' stamp: 'brp 1/30/2005 09:09'!
selectorsToBeIgnored

	 | deprecated private special primitives timing benchmarks |

	deprecated := #().
	private := #( #print24:on: #print24:showSeconds:on: ).
	special := #( #< #= #new #printOn: #storeOn: ).
	primitives := #( #primMillisecondClock #primSecondsClock ).
	timing := #( #millisecondClockValue #milliseconds:since: #millisecondsSince: ).
	benchmarks := #( #benchmarkMillisecondClock #benchmarkPrimitiveResponseDelay ). 

	^ super selectorsToBeIgnored, deprecated, private, special, primitives, timing, benchmarks.! !


!TimeTest methodsFor: 'Running' stamp: 'nk 3/30/2004 09:40'!
setUp

	localTimeZoneToRestore := DateAndTime localTimeZone.
	DateAndTime localTimeZone: TimeZone default.
	time := self timeClass fromSeconds: 14567.		"4:02:47 am"
	aTime := Time readFrom: '12:34:56 pm' readStream
! !

!TimeTest methodsFor: 'Running' stamp: 'nk 3/30/2004 09:40'!
tearDown
	DateAndTime localTimeZone: localTimeZoneToRestore.
! !


!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:33'!
testAccessing

	self
		assert: time hours = 4;
		assert: time minutes = 2;
		assert: time seconds = 47;
		assert: time asSeconds = 14567.
! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:35'!
testArithmetic
	| t1 t2 t3 |
	t1 := time addSeconds: 70.		"4:03:57 am"
	self
		assert: t1 hours = 4;
		assert: t1 minutes = 3;
		assert: t1 seconds = 57.

	t2 := t1 addTime: (self timeClass fromSeconds: (60*60*5)).
	self
		assert: t2 hours = 9;
		assert: t2 minutes = 3;
		assert: t2 seconds = 57.

	t3 := t2 subtractTime: (self timeClass fromSeconds: (60*60*5) + 70).
	self
		assert: t3 = time.
! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:36'!
testComparing
	| t1 t2 t3 |
	t1 := self timeClass fromSeconds: 14567.		"4:02:47 am"
	t2 := self timeClass fromSeconds: 5000.		"1:23:20 am"
	t3 := self timeClass fromSeconds: 80000.		"10:13:20 pm"

	self
		assert: time = t1;
		assert: time hash = t1 hash;
		assert: time = time copy.
	self
		deny: t1 < t2;
		assert: t1 < t3.! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:37'!
testConverting

	self
		assert: time asSeconds = 14567.! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:38'!
testFromSeconds
	| t |
	t := self timeClass fromSeconds: 14567.
	self
		assert: t = time
! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:52'!
testGeneralInquiries
	| now d t dt |

	now  := self timeClass dateAndTimeNow.
	self 
		assert: now size = 2;
		assert: now last <= self timeClass now.

	self should: [ self timeClass timeWords ] raise: MessageNotUnderstood.

	d := '2 June 1973' asDate.
	t := '4:02:47 am' asTime.
	dt := self timeClass dateAndTimeFromSeconds: (2285280000 + 14567).
	self
		assert: dt = {d. t.}.
! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:44'!
testNew
	
	self assert: self timeClass new asSeconds = 0! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 22:27'!
testPrinting

	self	
		assert: time printString = '4:02:47 am';
		assert: time intervalString =  '4 hours 2 minutes 47 seconds';
		assert: time print24 = '04:02:47';
		assert: time printMinutes = '4:02 am';
		assert: time hhmm24 = '0402'.
! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:46'!
testReadFrom

	| string t |
	string := '4:02:47 am'.
	t := self timeClass readFrom: string readStream.

	self
		assert: time = t.
! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:49'!
testSqueakInquiries
	| timewords totalseconds condensed corrected |
	self assert: 
		(self timeClass namesForTimes: #(2 10000023 10000026))
			= #('January, 1901' 'April, 1901, 4/26/1901, 5:47 pm' 'April, 1901, 4/26/1901, 5:47 pm').

	timewords := #(0.5 30 62 130 4000 10000 60000 90000) 
		collect: [ :ss | self timeClass humanWordsForSecondsAgo: ss ].
	self assert: 
		timewords = #('a second ago' '30 seconds ago' 'a minute ago' '2 minutes ago' 
			'an hour ago' '2 hours ago' '16 hours ago' 'yesterday').

	totalseconds :=  self timeClass totalSeconds.
	condensed := self timeClass condenseBunches: 
		(#(20 400 401  20000 20200 20300 40000 45000  200000 201000 202000) 
			collect: [:tt | totalseconds - tt]).
	corrected := condensed collect: [ :e | totalseconds - e ].
	self
		assert: (corrected includesAllOf: #(20 400 401 20000 40000 45000 200000)).
! !

!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:47'!
testStoring

	self	
		assert: time storeString = '''4:02:47 am'' asTime';
		assert: time = ('4:02:47 am' asTime).
! !


!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAddSeconds
	self assert: (aTime addSeconds: 1) = (Time readFrom: (ReadStream on: '12:34:57')).
	self assert: (aTime addSeconds: 60) = (Time readFrom: (ReadStream on: '12:35:56')).	
	self assert: (aTime addSeconds: 3600) = (Time readFrom: (ReadStream on: '13:34:56')).
	self assert: (aTime addSeconds: 24*60*60) = (Time readFrom: (ReadStream on: '12:34:56')).! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAddTime
	self assert: (aTime addTime: aTime) = (Time readFrom: (ReadStream on: '01:09:52')).
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsDate
	self assert: (aTime asDate) = (Date current)
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsDateAndTime
	self assert: (aTime asDateAndTime) = (DateAndTime current midnight + aTime)
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsDuration
	self assert: (aTime asDuration) = (Duration days: 0 hours: 12 minutes: 34 seconds: 56)
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsNanoSeconds
	self assert: (aTime asNanoSeconds) = 45296000000000

! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsSeconds
	self assert: (aTime asSeconds) = 45296
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsTime
	self assert: (aTime asTime) = aTime

! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsTimeStamp
	self assert: (aTime asTimeStamp) = (DateAndTime current midnight + aTime) asTimeStamp
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsWeek
	self assert: aTime asWeek = (DateAndTime current midnight + aTime) asWeek
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testAsYear
	self assert: aTime asYear = (DateAndTime current midnight + aTime) asYear
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testDuration
	self assert: aTime duration = 0 seconds! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testEqual
	self assert: aTime = (Time readFrom: (ReadStream on: '12:34:56')).! !

!TimeTest methodsFor: 'testing' stamp: 'tlk 4/30/2006 22:14'!
testHash
	self assert: aTime hash =  607004.! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testHhmm24
	self assert: aTime hhmm24 = '1234'! !

!TimeTest methodsFor: 'testing' stamp: 'nk 3/30/2004 09:42'!
testHour
	self assert: aTime hour =  12.
	self assert: aTime hour12 =  12.
	self assert: aTime hour24 =  12.
	self assert: aTime hours =  12.! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testHumanWordsForSecondsAgo
	self assert: (Time humanWordsForSecondsAgo: 0.999999999)
			= 'a second ago'.
	self assert: (Time humanWordsForSecondsAgo: 44.99999999)
			= '44.99999999 seconds ago'.
	self assert: (Time humanWordsForSecondsAgo: 89.999999999)
			= 'a minute ago'.
	self assert: (Time humanWordsForSecondsAgo: 2699.999999999)
			= '44 minutes ago'.
	self assert: (Time humanWordsForSecondsAgo: 5399.999999999)
			= 'an hour ago'.
	self assert: (Time humanWordsForSecondsAgo: 64799.999999999)
			= '17 hours ago'.
	! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testHumanWordsForSecondsAgoWithDays

	self assert: (Time humanWordsForSecondsAgo: 18 * 60 * 60)
					= 'yesterday'.
	self assert: (Time humanWordsForSecondsAgo: 24 * 60 * 60)
					= 'yesterday'.
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testLessThan
	self assert: aTime < (Time readFrom: (ReadStream on: '12:34:57')).! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testMeridianAbbreviation
	self assert: aTime meridianAbbreviation =  'PM'.
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testMinute
	self assert: aTime minute =  34.
	self assert: aTime minutes =  34
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testNanoSecond
	self assert: aTime nanoSecond = 0
	"Right now all times all seconds"
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testPrint24
	self assert: aTime print24 = '12:34:56'! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testPrint24On
	| cs rw |
	cs := ReadStream on: '12:34:56'.
	rw := ReadWriteStream on: ''.
	aTime print24: true on: rw.
	self assert: rw contents = cs contents! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testPrint24OnWithPM
	| cs rw |
	cs := ReadStream on: '12:34:56 pm'.
	rw := ReadWriteStream on: ''.
	aTime print24: false on: rw.
	^ self assert: rw contents = cs contents! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testPrint24OnWithoutSeconds
	| cs rw |
	cs := ReadStream on: '12:34:56'.
	rw := ReadWriteStream on: ''.
	aTime print24: true showSeconds: true on: rw.
	self assert: rw contents = cs contents! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testPrintMinutes
	self assert: aTime printMinutes = '12:34 pm'! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testPrintOn
	| cs rw |
	cs := ReadStream on: '12:34:56 pm'.
	rw := ReadWriteStream on: ''.
	aTime printOn: rw.
	self assert: rw contents = cs contents! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testSecond
	self assert: aTime second =  56.
	self assert: aTime seconds =  56
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testStoreOn
	| cs rw |
	cs := ReadStream on: '''12:34:56 pm'' asTime'.
	rw := ReadWriteStream on: ''.
	aTime storeOn: rw.
	self assert: rw contents = cs contents! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testSubtractTime
	self assert: (aTime subtractTime: aTime) = (Time readFrom: (ReadStream on: '00:00:00'))
! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testTicks
	self assert: aTime ticks = #(0 45296 0).
	self assert: aTime  = (Time new ticks: #(0 45296 0))! !

!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'!
testTimeStamp
	self assert: aTime = aTime asTimeStamp asTime! !


!TimeTest methodsFor: 'Private' stamp: 'brp 7/27/2003 13:32'!
timeClass

	^ Time! !
Object subclass: #TimeZone
	instanceVariableNames: 'offset abbreviation name'
	classVariableNames: ''
	poolDictionaries: 'ChronologyConstants'
	category: 'Kernel-Chronology'!
!TimeZone commentStamp: 'brp 9/4/2003 06:32' prior: 0!
TimeZone is a simple class to colect the information identifying a UTC time zone.

offset			-	Duration	- the time zone's offset from UTC
abbreviation	-	String		- the abbreviated name for the time zone.
name			-	String		- the name of the time zone.

TimeZone class >> #timeZones returns an array of the known time zones
TimeZone class >> #default returns the default time zone (Grenwich Mean Time)!


!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'!
abbreviation

	^ abbreviation
! !

!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'!
abbreviation: aString

	abbreviation _ aString
! !

!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:29'!
name

	^ name
! !

!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'!
name: aString

	name _ aString
! !

!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'!
offset

	^ offset! !

!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'!
offset: aDuration

	offset _ aDuration! !


!TimeZone methodsFor: 'private' stamp: 'brp 9/4/2003 06:37'!
printOn: aStream

	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self abbreviation;
		nextPut: $).! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TimeZone class
	instanceVariableNames: ''!

!TimeZone class methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:38'!
default
	"Answer the default time zone - GMT"

	^ self timeZones detect: [ :tz | tz offset = Duration zero ]
! !

!TimeZone class methodsFor: 'accessing' stamp: 'brp 1/30/2005 09:35'!
timeZones

	^ {
		self offset:  0 hours name: 'Universal Time' abbreviation: 'UTC'.
		self offset:  0 hours name: 'Greenwich Mean Time' abbreviation: 'GMT'.
		self offset:  1 hours name: 'British Summer Time' abbreviation: 'BST'.
		self offset:  2 hours name: 'South African Standard Time' abbreviation: 'SAST'.
		self offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'.
		self offset: -7 hours name: 'Pacific Daylight Time' abbreviation: 'PDT'.
	}

! !


!TimeZone class methodsFor: 'instance creation' stamp: 'brp 9/4/2003 06:33'!
offset: aDuration name: aName abbreviation: anAbbreviation

	^ self new
		offset: aDuration;
		name: aName;
		abbreviation: anAbbreviation;
		yourself! !
Notification subclass: #TimedOut
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!TimedOut commentStamp: 'brp 10/21/2004 17:47' prior: 0!
I am signalled by #duration:timeoutDo: if the receiving block takes too long to execute.

I am signalled by a watchdog process spawned by #duration:timeoutDo: and caught in the same method. 

I am not intended to be used elsewhere.!

Magnitude subclass: #Timespan
	instanceVariableNames: 'start duration'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Chronology'!
!Timespan commentStamp: 'brp 5/13/2003 08:07' prior: 0!
I represent a duration starting on a specific DateAndTime.
!


!Timespan methodsFor: 'ansi protocol' stamp: 'brp 9/15/2003 14:05'!
+ operand
	"operand conforms to protocol Duration"
	

	^ self class starting: (self start + operand) duration: self duration
! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 9/15/2003 14:07'!
- operand
	"operand conforms to protocol DateAndTime or protocol Duration"

	^ (operand respondsTo: #asDateAndTime)

	 	ifTrue: [ self start - operand ]
	
	ifFalse: [ self + (operand negated) ].
! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:43'!
< comparand

	^ self start < comparand	
! !

!Timespan methodsFor: 'ansi protocol' stamp: 'lr 4/18/2005 16:39'!
= comparand
	^ self class = comparand class 
		and: [ self start = comparand start ]
		and: [ self duration = comparand duration ]
.! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 17:49'!
dayOfMonth
	"Answer the day of the month represented by the receiver."

	^ start dayOfMonth! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 8/6/2003 18:42'!
dayOfWeek
	"Answer the day of the week represented by the receiver."

	^ start dayOfWeek! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 8/6/2003 18:42'!
dayOfWeekName
	"Answer the day of the week represented by the receiver."

	^ start dayOfWeekName! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 8/24/2003 11:50'!
dayOfYear
	"Answer the day of the year represented by the receiver."

	^ start dayOfYear! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'!
hash

	^ start hash + duration hash
! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'!
isLeapYear

	^ start isLeapYear
! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'!
month

	^ start month
! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 1/7/2004 16:25'!
monthAbbreviation


	^ start monthAbbreviation
! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'!
monthName


	^ start monthName
! !

!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'!
year


	^ start year
! !


!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:49'!
dates


	| dates |

	dates _ OrderedCollection new.
	self datesDo: [ :m | dates add: m ].
	^ dates asArray.! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:49'!
datesDo: aBlock


	self do: aBlock with: start asDate.
! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:50'!
every: aDuration do: aBlock

	| element end |
	element _ self start.
	end _ self end.
	[ element <= end ] whileTrue:
	
	[ aBlock value: element.
		element _ element + aDuration. ]
! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:50'!
months

	| months |
	months _ OrderedCollection new: 12.
	self monthsDo: [ :m | months add: m ].
	^ months asArray.! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:50'!
monthsDo: aBlock

	self do: aBlock with: start asMonth.! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:51'!
weeks


	| weeks |
	weeks _ OrderedCollection new.
	self weeksDo: [ :m | weeks add: m ].
	^ weeks asArray.! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:51'!
weeksDo: aBlock

	self do: aBlock with: self asWeek.! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:51'!
workDatesDo: aBlock
	"Exclude Saturday and Sunday"

	self do: aBlock with: start asDate when: [ :d | d dayOfWeek < 6 ].
! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:51'!
years


	| years |
	years _ OrderedCollection new.
	self yearsDo: [ :m | years add: m ].
	^ years asArray.! !

!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:58'!
yearsDo: aBlock

	self do: aBlock with: start asYear.! !


!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 14:09'!
day
	"Answer the day of the year represented by the receiver."
	^ self dayOfYear! !

!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:45'!
daysInMonth


	^ start daysInMonth
! !

!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:45'!
daysInYear
	"Answer the number of days in the month represented by the receiver."

	^ start daysInYear
! !

!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 17:50'!
daysLeftInYear
	^ start daysLeftInYear! !

!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 17:55'!
firstDayOfMonth

	^ start firstDayOfMonth! !

!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:47'!
monthIndex

	^ self month
! !

!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:47'!
next

	^ self class starting: (start + duration) duration: duration
! !

!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:48'!
previous


	^ self class starting: (start - duration) duration: duration
! !


!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:44'!
asDate


	^ start asDate
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:44'!
asDateAndTime

	^ start
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/30/2003 00:10'!
asDuration

	^ self duration! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:45'!
asMonth


	^ start asMonth
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:45'!
asTime

	^ start asTime! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:25'!
asTimeStamp

	^ start asTimeStamp! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:45'!
asWeek

	^ start asWeek
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:45'!
asYear


	^ start asYear! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:45'!
duration
	"Answer the Duration of this timespan"

	^ duration
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 9/23/2004 09:53'!
end


	^ self duration asNanoSeconds = 0
		ifTrue: [ self start ]
		ifFalse: [ self next start - DateAndTime clockPrecision ]! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 1/7/2004 16:05'!
includes: aDateAndTime


	^ (aDateAndTime isKindOf: Timespan)
			ifTrue: [ (self includes: aDateAndTime start)
						and: [ self includes: aDateAndTime end ] ]
			ifFalse: [ aDateAndTime asDateAndTime between: start and: self end ]
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:54'!
includesAllOf: aCollection 
	"Answer whether all the elements of aCollection are in the receiver."

	aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]].
	^ true
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 1/7/2004 15:59'!
includesAnyOf: aCollection 
	"Answer whether any element of aCollection is included in the receiver"

	aCollection do: [ :elem | (self includes: elem) ifTrue: [^ true]].
	^false
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:47'!
intersection: aTimespan

	 "Return the Timespan both have in common, or nil"

	 | aBegin anEnd |
	 aBegin _ self start max: aTimespan start.
	 anEnd _ self end min: aTimespan end.
	 anEnd < aBegin ifTrue: [^nil].

	 ^ self class starting: aBegin ending: anEnd.
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:47'!
julianDayNumber


	^ start julianDayNumber
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 09:17'!
printOn: aStream


	super printOn: aStream.
	aStream 
		nextPut: $(;
		print: start;
		nextPut: $D;
		print: duration;
		nextPut: $).
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:48'!
start
	"Answer the start DateAndTime of this timespan"

	^ start
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:48'!
start: aDateAndTime
	"Store the start DateAndTime of this timespan"

	start _ aDateAndTime asDateAndTime
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:49'!
to: anEnd
	"Answer an Timespan. anEnd must be aDateAndTime or a Timespan"


	^ Timespan starting: (self start) ending: (anEnd asDateAndTime).
! !

!Timespan methodsFor: 'squeak protocol' stamp: 'brp 1/9/2004 16:46'!
union: aTimespan
	 "Return the Timespan spanned by both"

	| aBegin anEnd |

	aBegin _ self start min: aTimespan start.
	anEnd _ self end max: aTimespan end.
	^ Timespan starting: aBegin ending: (anEnd + DateAndTime clockPrecision).
! !


!Timespan methodsFor: 'private' stamp: 'brp 5/13/2003 08:58'!
do: aBlock with: aFirstElement

	self do: aBlock with: aFirstElement when: [ :t | true ].
! !

!Timespan methodsFor: 'private' stamp: 'brp 5/13/2003 08:59'!
do: aBlock with: aFirstElement when: aConditionBlock

	| element end |
	element _ aFirstElement.
	end _ self end.
	[ element start <= end ] whileTrue:
	
	[(aConditionBlock value: element)
			ifTrue: [ aBlock value: element ].
		element _ element next. ]! !

!Timespan methodsFor: 'private' stamp: 'brp 5/13/2003 08:59'!
duration: aDuration
	"Set the Duration of this timespan"

	duration _ aDuration
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Timespan class
	instanceVariableNames: ''!

!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 5/21/2003 08:35'!
current


	^ self starting: DateAndTime now
! !

!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 18:49'!
new
	"Answer a Timespan starting on the Squeak epoch: 1 January 1901"

	^ self starting: DateAndTime new
! !

!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:42'!
starting: aDateAndTime


	^ self starting: aDateAndTime duration: Duration zero
! !

!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 18:48'!
starting: aDateAndTime duration: aDuration

	^ self basicNew
 		start: aDateAndTime asDateAndTime;
		duration: aDuration;
		yourself.! !

!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:16'!
starting: startDateAndTime ending: endDateAndTime

	^ self 
		starting: startDateAndTime 
		duration: (endDateAndTime asDateAndTime - startDateAndTime).
! !
TestCase subclass: #TimespanDoSpanAYearTest
	instanceVariableNames: 'aTimespan aDuration aDate'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!TimespanDoSpanAYearTest commentStamp: 'tlk 1/6/2004 17:55' prior: 0!
I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndTimeEpochTestCase for a complete list. tlk.
My fixtures include a Timespan that crosses over a year boundary:
aDate = December 25, 2004, midnight
aDuration = 91 days
aTimeSpan= 91 days, starting December 25, 2004, midnight!


!TimespanDoSpanAYearTest methodsFor: 'running' stamp: 'brp 9/26/2004 18:59'!
setUp
	aDate := DateAndTime year: 2004 month: 12 day: 25 hour: 0 minute: 0 second: 0.
	aDuration := Duration days: 91 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0.

	aTimespan := Timespan starting: aDate duration: aDuration! !


!TimespanDoSpanAYearTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:55'!
testMonthsDo

	| monthArray |

	monthArray := Array
				with: (Month starting: (DateAndTime year: 2004 day: 355) duration: 31 days)
				with: (Month starting: (DateAndTime year: 2005 day: 1) duration: 31 days)
				with: (Month starting: (DateAndTime year: 2005 day: 32) duration: 29 days)
				with: (Month starting: (DateAndTime year: 2005 day: 61) duration: 31 days).
				
	self assert: aTimespan months = monthArray! !

!TimespanDoSpanAYearTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:55'!
testNext

	self assert: aTimespan next
			= (Timespan
					starting: (DateAndTime
							year: 2005
							month: 3
							day: 26
							hour: 0
							minute: 0
							second: 0)
					duration: aDuration)! !

!TimespanDoSpanAYearTest methodsFor: 'testing' stamp: 'brp 9/26/2004 19:06'!
testWeeksDo
	| weeks weekArray |
	weeks := aTimespan weeks.
	self assert: weeks size = ((aDuration days / 7.0) ceiling + 1).

	weekArray := OrderedCollection new.
	weekArray
		addLast: (Week starting: (DateAndTime year: 2004 month: 12 day: 19) duration: 7 days);
		addLast: (Week starting: (DateAndTime year: 2004 month: 12 day: 26) duration: 7 days).

	2 to: 79 by: 7 do:
		[ :i | weekArray
				addLast: (Week starting: (DateAndTime year: 2005 day: i) duration: 7 days) ].

	weekArray := weekArray asArray.
	self assert: aTimespan weeks = weekArray
! !

!TimespanDoSpanAYearTest methodsFor: 'testing' stamp: 'nk 3/30/2004 11:08'!
testYearsDo
	| yearArray |
	yearArray := Array
				with: (Year
						starting: (DateAndTime
								year: 2004
								month: 12
								day: 25)
						duration: 366 days).
	self assert: aTimespan years = yearArray
! !
TestCase subclass: #TimespanDoTest
	instanceVariableNames: 'aTimespan aDuration aDate'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!TimespanDoTest commentStamp: 'tlk 1/6/2004 17:55' prior: 0!
I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndTimeEpochTestCase for a complete list.  tlk.
My fixtures are:
aDate = January 8, 2003, midnight
aDuration = 91 days
aTimeSpan= 91 days, starting January 8, 2003, midnight
!


!TimespanDoTest methodsFor: 'running' stamp: 'tlk 1/5/2004 13:01'!
setUp
	aDate := DateAndTime
				year: 2003
				month: 01
				day: 07
				hour: 0
				minute: 0
				second: 0.
	aDuration := Duration
				days: 91
				hours: 0
				minutes: 0
				seconds: 0
				nanoSeconds: 0.
	aTimespan := Timespan starting: aDate duration: aDuration! !


!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 18:00'!
testDatesDo
	| dateArray |
	dateArray := OrderedCollection new.
	7
		to: 97
		do: [:each | dateArray
				addLast: (Date year: 2003 day: each)].
	dateArray := dateArray asArray.
	self assert: aTimespan dates = dateArray! !

!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 16:36'!
testDoWith
	| count |
	count := 0.
	aTimespan
		do: [:each | count := count + 1]
		with: (Timespan
				starting: aDate
				duration: 7 days).
	self assert: count = 13! !

!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 16:39'!
testDoWithWhen
	| count |
	count := 0.
	aTimespan
		do: [:each | count := count + 1]
		with: (Timespan starting: aDate duration: 7 days)
		when: [:each | count < 5].
	self assert: count = 5	
! !

!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 15:39'!
testEveryDo
	|count  duration |
	count := 0.
	duration := 7 days.
	(aTimespan
			every: duration
			do: [:each | count := count + 1]).
	self assert: count = 13
			! !

!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 13:05'!
testMonthsDo
	| monthArray |
	monthArray := Array
				with: (Month
						starting: (DateAndTime year: 2003 day: 1)
						duration: 31 days)
				with: (Month
						starting: (DateAndTime year: 2003 day: 32)
						duration: 28 days)
				with: (Month
						starting: (DateAndTime year: 2003 day: 60)
						duration: 31 days)		
				with: (Month
						starting: (DateAndTime year: 2003 day: 91)
						duration: 30 days).
	self assert: aTimespan months = monthArray! !

!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 16:09'!
testNext
	self assert: aTimespan next 
			= (Timespan
					starting: (DateAndTime
							year: 2003
							month: 4
							day: 8
							hour: 0
							minute: 0
							second: 0)
					duration: aDuration)! !

!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 13:07'!
testWeeksDo
	| weekArray |
	weekArray := OrderedCollection new.
	7
		to: 98
		by: 7
		do: [:each | weekArray
				addLast: (Week
						starting: (DateAndTime year: 2003 day: each)
						duration: 7 days)].
	weekArray := weekArray asArray.
	self assert: aTimespan weeks = weekArray
! !

!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 13:09'!
testYearsDo
	| yearArray |
	yearArray := Array
				with: (Year
						starting: (DateAndTime year: 2003 day: 7)
						duration: 365 days).
	self assert: aTimespan years contents = yearArray contents! !
ClassTestCase subclass: #TimespanTest
	instanceVariableNames: 'timespan aTimespan anOverlappingTimespan anIncludedTimespan aDisjointTimespan aDay aWeek dec31 jan01 jan08 localTimeZoneToRestore'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!

!TimespanTest methodsFor: 'Coverage' stamp: 'brp 9/15/2003 14:15'!
classToBeTested

	^ Timespan
! !


!TimespanTest methodsFor: 'Running' stamp: 'nk 3/30/2004 09:21'!
setUp

	localTimeZoneToRestore := DateAndTime localTimeZone.
	DateAndTime localTimeZone: TimeZone default.

	"100 hours starting noon 22 March 2003"
	timespan := Timespan starting:
					(DateAndTime year: 2003 month: 03 day: 22 hour: 12 minute: 0 second: 0)
						duration: (Duration hours: 100).

	dec31 := (DateAndTime year: 2004 month: 12 day: 31 hour: 0 minute: 0 second: 0).
	jan01 := (DateAndTime year: 2005 month: 1 day: 1 hour: 0 minute: 0 second: 0).
	jan08 := (DateAndTime year: 2005 month: 1 day: 8 hour: 0 minute: 0 second:0).
	aDay := Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0.
	aWeek := Duration days: 7 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0.
	aTimespan := Timespan starting: jan01 duration: aWeek.
	anOverlappingTimespan := Timespan starting: dec31 duration: aWeek.
	anIncludedTimespan := Timespan starting: jan01 duration: aDay.
	aDisjointTimespan := Timespan starting: jan08 duration: aWeek.



! !

!TimespanTest methodsFor: 'Running' stamp: 'nk 3/30/2004 09:22'!
tearDown
	DateAndTime localTimeZone: localTimeZoneToRestore.
	timespan := nil
! !


!TimespanTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 16:25'!
testAccessing

	self 
		assert: (timespan start =
				 (DateAndTime year: 2003 month: 03 day: 22 hour: 12 minute: 0 second: 0));
		assert: timespan duration = (Duration hours: 100);
		assert: timespan month = 3;
		assert: timespan monthName = 'March';
		assert: timespan monthAbbreviation = 'Mar'
		

! !

!TimespanTest methodsFor: 'Tests' stamp: 'brp 9/15/2003 14:29'!
testArithmetic

	| ts1 ts2 d |
	ts1 _ timespan + 2 days.
	ts2 _ ts1 - 2 days.
	d _ ts1 - (DateAndTime year: 2003 month: 03 day: 20).

	self 
		assert: (ts1 start = 
				 (DateAndTime year: 2003 month: 03 day: 24 hour: 12 minute: 0 second: 0));
		assert: (ts1 duration = timespan duration);
		assert: (ts2 start = timespan start);
		assert: (ts2 duration = timespan duration).

	self
		assert: d = (Duration days: 4 hours: 12 minutes: 0 seconds: 0)

! !

!TimespanTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:43'!
testInclusion

	| t1 t2 t3 t4 |
	t1 _ timespan start.
	t2 _ timespan start + (timespan duration / 2).
	t3 _ timespan end.
	t4 _ timespan start + (timespan duration).

	self 
		assert: (timespan includes: t1);
		assert: (timespan includes: t2);
		assert: (timespan includes: t3)";
		deny: (timespan includes: t4).
	self
		assert: (timespan includes: (t1 to: t2));
		assert: (timespan includes: (t1 to: t4));
		deny: (timespan includes: (Timespan starting: t2 duration: (timespan duration * 2))).
	self 
		assert: (timespan includesAllOf: { t1. t2. t3 } );
		deny: (timespan includesAllOf: { t1. t2. t3. t4} ).
	self 
		assert: (timespan includesAnyOf: { t1. t2. t3 } );
		deny: (timespan includesAnyOf: { t4 } ).
"! !

!TimespanTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 16:49'!
testUnion

	| union |
	union _ timespan union: timespan.
	
	self 
		assert: (union start = timespan start);
		assert: (union duration = timespan duration)
! !


!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testAsDate
	self assert: aTimespan asDate =   jan01 asDate.
	"MessageNotUnderstood: Date class>>starting:"
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testAsDateAndTime
	self assert: aTimespan asDateAndTime =   jan01.
	"MessageNotUnderstood: Date class>>starting:"
	
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testAsDuration
	self assert: aTimespan asDuration =  aWeek.

	
	
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testAsMonth
	self assert: aTimespan asMonth =   jan01 asMonth.
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testAsTime
	self assert: aTimespan asTime =  jan01 asTime
	"MessageNotUnderstood: Time class>>seconds:nanoSeconds:"
 ! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testAsTimeStamp
	self assert: aTimespan asTimeStamp =  ((TimeStamp readFrom: '1-01-2005 0:00 am' readStream) offset: 0 hours).
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testAsWeek
	self assert: aTimespan asWeek =   jan01 asWeek.
	"DateAndTime new asWeek
	 MessageNotUnderstood: Week class>>starting:"
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testAsYear
	self assert: aTimespan asYear =   jan01 asYear.

! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 9/23/2004 09:58'!
testClockPrecisionDuration
	| ts |
	ts := Timespan starting: Date today duration: DateAndTime clockPrecision.
	self
		assert: ts start = ts end! !

!TimespanTest methodsFor: 'testing' stamp: 'nk 3/30/2004 09:26'!
testCurrent
	self assert: (Timespan starting: DateAndTime current)
			<= Timespan current.
	self assert:  Timespan current
			<= (Timespan starting: DateAndTime current)! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDay
	self assert: aTimespan day =   jan01 day
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDayOfMonth
	self assert: aTimespan dayOfMonth  = 1.
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDayOfWeek
	self assert: aTimespan  dayOfWeek  = 7.
	self assert: aTimespan  dayOfWeekName = 'Saturday'.
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDayOfYear
	self assert: aTimespan  dayOfYear  = 1.
	"MessageNotUnderstood: UndefinedObject>>year:, Undefined object is Year class"
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDaysInMonth
	self assert: aTimespan  daysInMonth  = 31.
	"MessageNotUnderstood: Month class>>starting:"
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDaysInYear
	self assert: aTimespan  daysInYear  = 365.
	"MessageNotUnderstood: UndefinedObject>>starting:  UndefinedObject is Year class"
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDaysLeftInYear
	self assert: aTimespan  daysLeftInYear  = 364.
	"MessageNotUnderstood: UndefinedObject>>starting:  UndefinedObject is Year class"
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDoWith
	| count |
	count := 0.
	aTimespan
		do: [:each | count := count + 1]
		with: (Timespan starting: jan01 duration: aDay).
	self assert: count = 7! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDoWithWhen
	| count |
	count := 0.
	aTimespan
		do: [:each | count := count + 1]
		with: (Timespan starting: jan01 duration: aDay)
		when: [:each | count < 5].
	self assert: count = 5! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testDuration
	self assert: aTimespan duration  = aWeek.
	aTimespan duration: aDay.
	self assert: aTimespan duration =  aDay.

! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testEnd
	self assert: aTimespan end 	+ (Duration  nanoSeconds:1)  =  aDisjointTimespan
	"self assert: aTimespan end 	(DateAndTime year: 2005 month: 1 day: 7 hour: 23 minute: 59 second: 59 nanoSecond: 999999999 offset: 0 hours). "
	"This should work once DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset: is fixed"

! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testEveryDo
	| count duration |
	count := 0.
	duration := 7 days.
	aTimespan
		every: duration
		do: [:each | count := count + 1].
	self assert: count = 1! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testFirstDayOfMonth
	self assert: aTimespan firstDayOfMonth =   1. 
	self assert: aDisjointTimespan firstDayOfMonth =   1
! !

!TimespanTest methodsFor: 'testing' stamp: 'tlk 4/30/2006 22:15'!
testHash
	self assert: aTimespan hash =     101198424
	"must be a more meaningful test?"! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIncludes
	self assert: (aTimespan includes: jan01).
	self deny: (aTimespan includes: jan08)
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIncludesAllOf
	self assert: (aTimespan includesAllOf: (Bag with: jan01)).
	self deny: (aTimespan includesAllOf: (Bag with: jan01 with: jan08))
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIncludesAnyOf
	self deny: (aTimespan includesAnyOf: (Bag with: dec31)).
	self assert: (aTimespan includesAnyOf: (Bag with: jan01 with: jan08))
	"Error is due to bug in Timespan 
includesAnyOf: aCollection "
	"Answer whether any element of aCollection is included in the receiver"
	"aCollection do: [ :elem | (self includes: elem) ifTrue: [^ true]].
Shouldn't this return false if none are included?
"
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIntersectionWithDisjoint
	self assert: (aTimespan intersection: aDisjointTimespan) isNil.
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIntersectionWithIncluded
	self assert: (aTimespan intersection: anIncludedTimespan)  = 
	(Timespan starting: jan01 duration: (Duration days: 0 hours: 23 minutes: 59 seconds: 59 nanoSeconds: 999999999)).		
	self deny: (aTimespan intersection: anIncludedTimespan)	= anIncludedTimespan
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIntersectionWithOverlapping
	self assert: (aTimespan intersection: anOverlappingTimespan)  = 
	(Timespan starting: jan01 duration: (Duration days: 5 hours: 23 minutes: 59 seconds: 59 nanoSeconds: 999999999)).		

! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIntersectionWithSelf
	self assert: (aTimespan intersection: aTimespan)  = 
	(Timespan starting: jan01 duration: (Duration days: 6 hours: 23 minutes: 59 seconds: 59 nanoSeconds: 999999999)).		
	self deny: (aTimespan intersection: anIncludedTimespan)	= aTimespan
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIntersectionWithSeparate
	self assert: (aTimespan intersection: aDisjointTimespan) isNil.
	self deny: (aTimespan intersection: anOverlappingTimespan) isNil.
	self assert: (aTimespan intersection: anIncludedTimespan)  = 
	(Timespan starting: jan01 duration: (Duration days: 0 hours: 23 minutes: 59 seconds: 59 nanoSeconds: 999999999)).		
	self deny: (aTimespan intersection: anIncludedTimespan)	= anIncludedTimespan
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testIsLeapYear
	"self assert: anOverlappingTimespan isLeapYear."
	"not sure why this fails"
	self deny: aTimespan isLeapYear
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testJulianDayNumber
	self assert: aTimespan julianDayNumber =  (jan01 julianDayNumber).
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testLessThan
	self assert: aTimespan  < aDisjointTimespan.
	self deny: anIncludedTimespan < aTimespan
	! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testMinusADateAndTime
	"It appears that subtracting a date from a Timespan gives you a duration = to the difference between the start of the timespan and the date "
	self assert: aTimespan - dec31 =  aDay.
	self assert: aDisjointTimespan - jan01 =  aWeek.


! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testMinusADuration
	"It appears that subtracting a duration from a Timespan gives you a Timespan shifted by the duration"
	self assert: aTimespan - aDay =  anOverlappingTimespan.
	self assert: aDisjointTimespan - aWeek =  aTimespan.	


! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testMonth
	self assert: aTimespan month  = 1.
	self assert: aTimespan monthName = 'January'.
	self assert: aTimespan monthIndex = 1.! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testNew
	self assert: Timespan new = (Timespan starting: '01-01-1901' asDate)! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testNext
	self assert: aTimespan next = aDisjointTimespan
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testPlus
	self assert: aTimespan + aWeek = aDisjointTimespan.
	self assert: anOverlappingTimespan + aDay = aTimespan.
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testPrevious
	self assert: aTimespan  = aDisjointTimespan previous.
	self assert: aTimespan next previous = aTimespan 
! !

!TimespanTest methodsFor: 'testing' stamp: 'nk 3/30/2004 09:23'!
testPrintOn
	| cs rw |
	cs := ReadStream on: 'a Timespan(2005-01-01T00:00:00+00:00D7:00:00:00)'.
	rw := ReadWriteStream on: ''.
	aTimespan  printOn: rw.
	self assert: rw contents = cs contents
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testStart
	self assert: aTimespan start =   jan01.
	aTimespan start: jan08.
	self assert: aTimespan start =   jan08.! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testStartingEnding
	self assert: aTimespan  = (Timespan starting: jan01 ending: jan08)
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testTo
	self assert: (anIncludedTimespan to: jan08) = aTimespan 
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testUnionWithDisjoint

	self assert: (aTimespan union: aDisjointTimespan)  = 
		(Timespan starting: jan01 duration: (14 days)).	
			
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testUnionWithIncluded

	self 
		assert: (aTimespan union: anIncludedTimespan) = aTimespan 	! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testUnionWithOverlapping

	self 
		assert: (aTimespan union: anOverlappingTimespan)  = 
				(Timespan starting: dec31 duration: (8 days))! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testUnionWithSelf
	self assert: (aTimespan union: aTimespan) = aTimespan
	! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testUnionWithSeparate

	self 
		assert: (anOverlappingTimespan union: aDisjointTimespan) = 
			(Timespan 
				starting: anOverlappingTimespan start
				ending:  (aDisjointTimespan end + DateAndTime clockPrecision))
			
! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testWorkDatesDo
	| count |
	count := 0.
	aTimespan
		workDatesDo: [:each | count := count + 1].
	self assert: count = 5! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'!
testYear
	self assert: aTimespan year = 2005.

	! !

!TimespanTest methodsFor: 'testing' stamp: 'brp 9/23/2004 09:57'!
testZeroDuration
	| ts |
	ts := Timespan starting: Date today duration: Duration zero.
	self
		assert: ts start = ts end! !
SketchMorph subclass: #TinyPaint
	instanceVariableNames: 'brush brushSize brushColor lastMouse'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!TinyPaint methodsFor: 'event handling' stamp: 'sw 5/11/1998 14:02'!
handlesMouseDown: evt

	^ self inPartsBin not
! !

!TinyPaint methodsFor: 'event handling' stamp: 'jm 5/6/1998 16:28'!
mouseDown: evt

	lastMouse _ evt cursorPoint.
	brush drawFrom: lastMouse - bounds origin to: lastMouse - bounds origin.
	self invalidRect:
		((lastMouse - brush sourceForm extent) corner:
		 (lastMouse + brush sourceForm extent)).
! !

!TinyPaint methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
mouseMove: evt

	| p |
	p _ evt cursorPoint.
	p = lastMouse ifTrue: [^ self].
	brush drawFrom: lastMouse - bounds origin to: p - bounds origin.
	self invalidRect: (
		((lastMouse min: p) - brush sourceForm extent) corner:
		((lastMouse max: p) + brush sourceForm extent)).
	lastMouse _ p.
! !


!TinyPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color veryVeryLightGray! !

!TinyPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:53'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	brushColor _ Color red.
	brushSize _ 3.
	self clear! !


!TinyPaint methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:20'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'clear' translated action: #clear.
	aCustomMenu add: 'pen color' translated action: #setPenColor:.
	aCustomMenu add: 'pen size' translated action: #setPenSize.
	aCustomMenu add: 'fill' translated action: #fill.
! !

!TinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
brushColor: aColor

	brushColor _ aColor.
	brush color: aColor.
! !

!TinyPaint methodsFor: 'menu' stamp: 'jm 5/6/1998 16:23'!
clear

	self form: ((Form extent: 125@100 depth: 8) fillColor: color).
	brush _ Pen newOnForm: originalForm.
	brush roundNib: brushSize.
	brush color: brushColor.
! !

!TinyPaint methodsFor: 'menu' stamp: 'bf 1/5/2000 19:39'!
fill

	| fillPt |
	Cursor blank show.
	Cursor crossHair showWhile:
		[fillPt _ Sensor waitButton - self position].
	originalForm shapeFill: brushColor interiorPoint: fillPt.
	self changed.
! !

!TinyPaint methodsFor: 'menu' stamp: 'ar 10/5/2000 18:54'!
setPenColor: evt

	self changeColorTarget: self selector: #brushColor: originalColor: brushColor hand: evt hand.! !

!TinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:16'!
setPenSize

	| menu sizes nibSize |
	menu _ CustomMenu new.
	sizes _ (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
	sizes do: [:w | menu add: w printString action: w].
	nibSize _ menu startUp.
	nibSize ifNotNil: [
		brushSize _ nibSize.
		brush roundNib: nibSize].
! !
Object subclass: #ToolBuilder
	instanceVariableNames: 'parent'
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!ToolBuilder commentStamp: '<historical>' prior: 0!
I am a tool builder, that is an object which knows how to create concrete widgets from abstract specifications. Those specifications are used by tools which want to be able to function in diverse user interface paradigms, such as MVC, Morphic, Tweak, wxWidgets etc.

The following five specs must be supported by all implementations:
	* PluggableButton
	* PluggableList
	* PluggableText
	* PluggablePanel
	* PluggableWindow

The following specs are optional:
	* PluggableTree: If not supported, the tool builder must answer nil when asked for a pluggableTreeSpec. Substitution will require client support so clients must be aware that some tool builders may not support trees (MVC for example, or Seaside). See examples in FileListPlus or TestRunnerPlus.
	* PluggableMultiSelectionList: If multi-selection lists are not supported, tool builder will silently support regular single selection lists.
	* PluggableInputField: Intended as a HINT for the builder that this widget will be used as a single line input field. Unless explicitly supported it will be automatically substituted by PluggableText.
	* PluggableActionButton: Intended as a HINT for the builder that this widget will be used as push (action) button. Unless explicitly supported it will be automatically substituted by PluggableButton.
	* PluggableRadioButton: Intended as a HINT for the builder that this widget will be used as radio button. Unless explicitly supported it will be automatically substituted by PluggableButton.
	* PluggableCheckBox: Intended as a HINT for the builder that this widget will be used as check box. Unless explicitly supported it will be automatically substituted by PluggableButton.
!


!ToolBuilder methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:54'!
parent
	^parent! !

!ToolBuilder methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:54'!
parent: aWidget
	parent := aWidget! !

!ToolBuilder methodsFor: 'accessing' stamp: 'ar 7/14/2005 22:23'!
widgetAt: widgetID
	"Answer the widget with the given ID"
	^self widgetAt: widgetID ifAbsent:[nil]! !

!ToolBuilder methodsFor: 'accessing' stamp: 'ar 7/14/2005 22:23'!
widgetAt: widgetID ifAbsent: aBlock
	"Answer the widget with the given ID"
	^aBlock value! !


!ToolBuilder methodsFor: 'building' stamp: 'ar 6/5/2005 12:35'!
buildAll: aList in: newParent
	"Build the given set of widgets in the new parent"
	| prior |
	aList ifNil:[^self].
	prior := parent.
	parent := newParent.
	aList do:[:each| each buildWith: self].
	parent := prior.
! !

!ToolBuilder methodsFor: 'building' stamp: 'ar 6/5/2005 12:35'!
build: anObject
	"Build the given object using this tool builder"
	^anObject buildWith: self! !


!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 14:18'!
pluggableActionButtonSpec
	^PluggableActionButtonSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:31'!
pluggableButtonSpec
	^PluggableButtonSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 14:18'!
pluggableCheckBoxSpec
	^PluggableCheckBoxSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/11/2005 16:41'!
pluggableInputFieldSpec
	^PluggableInputFieldSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:30'!
pluggableListSpec
	^PluggableListSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'cwp 6/8/2005 23:24'!
pluggableMenuSpec
	^ PluggableMenuSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 13:43'!
pluggableMultiSelectionListSpec
	^PluggableMultiSelectionListSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:30'!
pluggablePanelSpec
	^PluggablePanelSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 14:18'!
pluggableRadioButtonSpec
	^PluggableRadioButtonSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:31'!
pluggableTextSpec
	^PluggableTextSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 16:53'!
pluggableTreeSpec
	^PluggableTreeSpec! !

!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:30'!
pluggableWindowSpec
	^PluggableWindowSpec! !


!ToolBuilder methodsFor: 'initialize' stamp: 'ar 2/9/2005 19:49'!
initialize
! !


!ToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:37'!
close: aWidget
	"Close a previously opened widget"
	^self subclassResponsibility! !

!ToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:38'!
open: anObject
	"Build and open the object. Answer the widget opened."
	^self subclassResponsibility! !

!ToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:38'!
open: anObject label: aString
	"Build an open the object, labeling it appropriately.  Answer the widget opened."
	^self subclassResponsibility! !

!ToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:39'!
runModal: aWidget
	"Run the (previously opened) widget modally, e.g., 
	do not return control to the sender before the user has responded."
	^self subclassResponsibility! !


!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 14:05'!
buildPluggableActionButton: spec
	^self buildPluggableButton: spec! !

!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 14:05'!
buildPluggableCheckBox: spec
	^self buildPluggableButton: spec! !

!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 18:39'!
buildPluggableInputField: aSpec
	^self buildPluggableText: aSpec! !

!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 14:06'!
buildPluggableMultiSelectionList: aSpec
	^self buildPluggableList: aSpec! !

!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 14:05'!
buildPluggableRadioButton: spec
	^self buildPluggableButton: spec! !


!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/9/2005 18:46'!
buildPluggableButton: aSpec
	^self subclassResponsibility! !

!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/9/2005 18:47'!
buildPluggableList: aSpec
	^self subclassResponsibility! !

!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 6/5/2005 12:30'!
buildPluggablePanel: aSpec
	^self subclassResponsibility! !

!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/9/2005 18:47'!
buildPluggableText: aSpec
	^self subclassResponsibility! !

!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/12/2005 00:36'!
buildPluggableTree: aSpec
	^self subclassResponsibility! !

!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/9/2005 18:47'!
buildPluggableWindow: aSpec
	^self subclassResponsibility! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ToolBuilder class
	instanceVariableNames: ''!

!ToolBuilder class methodsFor: 'accessing' stamp: 'ar 2/11/2005 15:55'!
default
	"Answer the default tool builder"
	| builderClass |
	^Default ifNil:[
		"Note: The way the following is phrased ensures that you can always make 'more specific' builders merely by subclassing a tool builder and implementing a more specific way of reacting to #isActiveBuilder. For example, a BobsUIToolBuilder can subclass MorphicToolBuilder and (if enabled, say Preferences useBobsUITools) will be considered before the parent (generic MorphicToolBuilder)."
		builderClass := self allSubclasses 
			detect:[:any| any isActiveBuilder and:[
				any subclasses noneSatisfy:[:sub| sub isActiveBuilder]]] ifNone:[nil].
		builderClass ifNotNil:[builderClass new]]! !

!ToolBuilder class methodsFor: 'accessing' stamp: 'ar 2/11/2005 15:21'!
default: aToolBuilder
	"Set a new default tool builder"
	Default := aToolBuilder.! !

!ToolBuilder class methodsFor: 'accessing' stamp: 'ar 2/11/2005 15:23'!
isActiveBuilder
	"Answer whether I am the currently active builder"
	^false! !


!ToolBuilder class methodsFor: 'instance creation' stamp: 'KR 4/28/2006 21:05'!
build: aClass
	^self default build: aClass! !

!ToolBuilder class methodsFor: 'instance creation' stamp: 'ar 2/11/2005 18:15'!
open: aClass
	^self default open: aClass! !

!ToolBuilder class methodsFor: 'instance creation' stamp: 'ar 2/11/2005 18:15'!
open: aClass label: aString
	^self default open: aClass label: aString! !
Object subclass: #ToolBuilderSpec
	instanceVariableNames: 'name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!ToolBuilderSpec commentStamp: 'ar 2/11/2005 14:59' prior: 0!
I am an abstract widget specification. I can be rendered using many different UI frameworks.!


!ToolBuilderSpec methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:42'!
name
	^ name! !

!ToolBuilderSpec methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:40'!
name: anObject
	name := anObject! !


!ToolBuilderSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:17'!
buildWith: aBuilder
	^self subclassResponsibility! !
TestCase subclass: #ToolBuilderTests
	instanceVariableNames: 'builder widget queries'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!ToolBuilderTests commentStamp: 'ar 2/11/2005 15:01' prior: 0!
Some tests to make sure ToolBuilder does what it says.!


!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 10:59'!
acceptWidgetText
	"accept text in widget"
	^ self subclassResponsibility! !

!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:27'!
buttonWidgetEnabled
	"Answer whether the current widget (a button) is currently enabled"
	
	^ widget getModelState! !

!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:00'!
changeListWidget
	"Change the list widget's selection index"
	self subclassResponsibility! !

!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:00'!
fireButtonWidget
	"Fire the widget, e.g., perform what is needed for the guy to trigger its action"
	self subclassResponsibility! !

!ToolBuilderTests methodsFor: 'support' stamp: 'ar 6/21/2005 11:00'!
returnFalse
	^false! !

!ToolBuilderTests methodsFor: 'support' stamp: 'ar 6/21/2005 10:57'!
returnTrue
	^true! !

!ToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 14:46'!
setUp
	queries := IdentitySet new.! !

!ToolBuilderTests methodsFor: 'support' stamp: 'ar 2/10/2005 21:04'!
shutDown
	self myDependents: nil! !

!ToolBuilderTests methodsFor: 'support' stamp: 'ar 2/12/2005 02:54'!
waitTick
	^nil! !

!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:00'!
widgetColor
	"Answer color from widget"
	self subclassResponsibility

	"NOTE: You can bail out if you don't know how to get the color from the widget:
		^self getColor
	will work."! !


!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 16:56'!
fireButton
	queries add: #fireButton.! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:53'!
getEnabled
	queries add: #getEnabled.
	^true! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:54'!
getLabel
	queries add: #getLabel.
	^'TestLabel'! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:53'!
getState
	queries add: #getState.
	^true! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/10/2005 21:02'!
makeButton
	| spec |
	spec := self makeButtonSpec.
	widget := builder build: spec.
	^widget! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 7/14/2005 22:14'!
makeButtonSpec
	| spec |
	spec := builder pluggableButtonSpec new.
	spec name: #button.
	spec model: self.
	spec label: #getLabel.
	spec color: #getColor.
	spec state: #getState.
	spec enabled: #getEnabled.
	^spec! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 16:54'!
testButtonFiresBlock
	| spec |
	spec := builder pluggableButtonSpec new.
	spec model: self.
	spec action: [self fireButton].
	widget := builder build: spec.
	queries := IdentitySet new.
	self fireButtonWidget.
	self assert: (queries includes: #fireButton).! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 16:53'!
testButtonFiresMessage
	| spec |
	spec := builder pluggableButtonSpec new.
	spec model: self.
	spec action: (MessageSend receiver: self selector: #fireButton arguments: #()).
	widget := builder build: spec.
	queries := IdentitySet new.
	self fireButtonWidget.
	self assert: (queries includes: #fireButton).! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 16:53'!
testButtonFiresSymbol
	| spec |
	spec := builder pluggableButtonSpec new.
	spec model: self.
	spec action: #fireButton.
	widget := builder build: spec.
	queries := IdentitySet new.
	self fireButtonWidget.
	self assert: (queries includes: #fireButton).! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'cwp 7/14/2006 11:15'!
testButtonInitiallyDisabled
	| spec |
	spec := builder pluggableButtonSpec new.
	spec model: self.
	spec label: #getLabel.
	spec color: #getColor.
	spec state: #getState.
	spec enabled: #returnFalse.
	widget := builder build: spec.
	self deny: (self buttonWidgetEnabled)! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 6/21/2005 10:57'!
testButtonInitiallyDisabledSelector
	| spec |
	spec := builder pluggableButtonSpec new.
	spec model: self.
	spec label: #getLabel.
	spec color: #getColor.
	spec state: #getState.
	spec enabled: #returnFalse.
	widget := builder build: spec.
	self deny: (self buttonWidgetEnabled)! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'cwp 7/14/2006 11:18'!
testButtonInitiallyEnabled
	| spec |
	spec := builder pluggableButtonSpec new.
	spec model: self.
	spec label: #getLabel.
	spec color: #getColor.
	spec state: #getState.
	spec enabled: #returnTrue.
	widget := builder build: spec.
	self assert: (self buttonWidgetEnabled)! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 6/21/2005 10:57'!
testButtonInitiallyEnabledSelector
	| spec |
	spec := builder pluggableButtonSpec new.
	spec model: self.
	spec label: #getLabel.
	spec color: #getColor.
	spec state: #getState.
	spec enabled: #returnTrue.
	widget := builder build: spec.
	self assert: (self buttonWidgetEnabled)! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 7/14/2005 22:22'!
testButtonWidgetID
	self makeButton.
	self assert: (builder widgetAt: #button) == widget.! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 21:42'!
testGetButtonColor
	self makeButton.
	queries := IdentitySet new.
	self changed: #getColor.
	self assert: (queries includes: #getColor).
	self assert: self widgetColor = self getColor.! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:57'!
testGetButtonEnabled
	self makeButton.
	queries := IdentitySet new.
	self changed: #getEnabled.
	self assert: (queries includes: #getEnabled).! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:57'!
testGetButtonLabel
	self makeButton.
	queries := IdentitySet new.
	self changed: #getLabel.
	self assert: (queries includes: #getLabel).! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:57'!
testGetButtonSideEffectFree
	self makeButton.
	queries := IdentitySet new.
	self changed: #testSignalWithNoDiscernableEffect.
	self assert: queries isEmpty.! !

!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:57'!
testGetButtonState
	self makeButton.
	queries := IdentitySet new.
	self changed: #getState.
	self assert: (queries includes: #getState).! !


!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'!
makeInputField
	| spec |
	spec := self makeInputFieldSpec.
	widget := builder build: spec.! !

!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 7/14/2005 22:19'!
makeInputFieldSpec
	| spec |
	spec := builder pluggableInputFieldSpec new.
	spec name: #input.
	spec model: self.
	spec getText: #getText.
	spec selection: #getTextSelection.
	spec color: #getColor.
	"<-- the following cannot be tested very well -->"
	spec setText: #setText:.
	spec menu: #getMenu:.
	^spec! !

!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'!
testGetInputFieldColor
	self makeInputField.
	queries := IdentitySet new.
	self changed: #getColor.
	self assert: (queries includes: #getColor).
	self assert: self widgetColor = self getColor.! !

!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'!
testGetInputFieldSelection
	self makeInputField.
	queries := IdentitySet new.
	self changed: #getTextSelection.
	self assert: (queries includes: #getTextSelection).! !

!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'!
testGetInputFieldSideEffectFree
	self makeInputField.
	queries := IdentitySet new.
	self changed: #testSignalWithNoDiscernableEffect.
	self assert: queries isEmpty.! !

!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'!
testGetInputFieldText
	self makeInputField.
	queries := IdentitySet new.
	self changed: #getText.
	self assert: (queries includes: #getText).! !

!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 7/14/2005 22:19'!
testInputWidgetID
	self makeInputField.
	self assert: (builder widgetAt: #input) == widget.! !

!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'!
testSetInputField
	self makeInputField.
	queries := IdentitySet new.
	self acceptWidgetText.
	self assert: (queries includes: #setText).! !


!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:54'!
getList
	queries add: #getList.
	^(1 to: 100) collect:[:i| i printString].! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:54'!
getListIndex
	queries add: #getListIndex.
	^13! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:54'!
getListSelection
	queries add: #getListSelection.
	^'55'! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/12/2005 02:44'!
getMenu: aMenu
	queries add: #getMenu.
	^aMenu! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/12/2005 02:45'!
keyPress: key
	queries add: #keyPress.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/10/2005 22:35'!
makeItemList
	| spec |
	spec := self makeItemListSpec.
	widget := builder build: spec.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 7/14/2005 22:17'!
makeItemListSpec
	| spec |
	spec := builder pluggableListSpec new.
	spec name: #list.
	spec model: self.
	spec list: #getList.
	spec getSelected: #getListSelection.
	"<-- the following cannot be tested very well -->"
	spec setSelected: #setListSelection:.
	spec menu: #getMenu:.
	spec keyPress: #keyPress:.
	^spec! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/10/2005 21:03'!
makeList
	| spec |
	spec := self makeListSpec.
	widget := builder build: spec.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 7/14/2005 22:18'!
makeListSpec
	| spec |
	spec := builder pluggableListSpec new.
	spec name: #list.
	spec model: self.
	spec list: #getList.
	spec getIndex: #getListIndex.
	"<-- the following cannot be tested very well -->"
	spec setIndex: #setListIndex:.
	spec menu: #getMenu:.
	spec keyPress: #keyPress:.
	^spec! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 19:18'!
setListIndex: index
	queries add: #setListIndex.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:54'!
setListSelection: newIndex
	queries add: #setListSelection.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:56'!
testGetItemListSideEffectFree
	self makeItemList.
	queries := IdentitySet new.
	self changed: #testSignalWithNoDiscernableEffect.
	self assert: queries isEmpty.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:56'!
testGetList
	self makeList.
	queries := IdentitySet new.
	self changed: #getList.
	self assert: (queries includes: #getList).! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:57'!
testGetListIndex
	self makeList.
	queries := IdentitySet new.
	self changed: #getListIndex.
	self assert: (queries includes: #getListIndex).! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:57'!
testGetListSelection
	self makeItemList.
	queries := IdentitySet new.
	self changed: #getListSelection.
	self assert: (queries includes: #getListSelection).! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:57'!
testGetListSideEffectFree
	self makeList.
	queries := IdentitySet new.
	self changed: #testSignalWithNoDiscernableEffect.
	self assert: queries isEmpty.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 7/14/2005 22:18'!
testItemListWidgetID
	self makeItemList.
	self assert: (builder widgetAt: #list) == widget.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 7/14/2005 22:18'!
testListWidgetID
	self makeList.
	self assert: (builder widgetAt: #list) == widget.! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 19:19'!
testSetListIndex
	self makeList.
	queries := IdentitySet new.
	self changeListWidget.
	self assert: (queries includes: #setListIndex).! !

!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 19:19'!
testSetListSelection
	self makeItemList.
	queries := IdentitySet new.
	self changeListWidget.
	self assert: (queries includes: #setListSelection).! !


!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/9/2005 08:25'!
assertItemFiresWith: aBlock
	| spec |
	spec := builder pluggableMenuSpec new.
	spec model: self.
	aBlock value: spec.
	widget := builder build: spec.
	queries := IdentitySet new.
	self fireMenuItemWidget.
	self assert: (queries includes: #fireMenuAction)! !

!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/8/2005 23:25'!
fireMenuAction
	queries add: #fireMenuAction! !

!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/9/2005 00:08'!
fireMenuItemWidget
	self subclassResponsibility! !

!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/9/2005 08:27'!
testAddAction
	self assertItemFiresWith: [:spec | spec add: 'Menu Item' action: #fireMenuAction]! !

!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/9/2005 08:28'!
testAddTargetSelectorArgumentList
	self assertItemFiresWith: 
		[:spec | spec
				add: 'Menu Item' 
				target: self
				selector: #fireMenuAction
				argumentList: #()]! !


!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 2/11/2005 14:54'!
getChildren
	queries add: #getChildren.
	^#()! !

!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 2/10/2005 21:03'!
makePanel
	| spec |
	spec := self makePanelSpec.
	widget := builder build: spec.! !

!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 7/14/2005 22:15'!
makePanelSpec
	| spec |
	spec := builder pluggablePanelSpec new.
	spec name: #panel.
	spec model: self.
	spec children: #getChildren.
	^spec! !

!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 2/11/2005 14:56'!
testGetPanelChildren
	self makePanel.
	queries := IdentitySet new.
	self changed: #getChildren.
	self assert: (queries includes: #getChildren).! !

!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 2/11/2005 14:56'!
testGetPanelSideEffectFree
	self makePanel.
	queries := IdentitySet new.
	self changed: #testSignalWithNoDiscernableEffect.
	self assert: queries isEmpty.! !

!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 7/14/2005 22:22'!
testPanelWidgetID
	self makePanel.
	self assert: (builder widgetAt: #panel) == widget.! !


!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 21:41'!
getColor
	queries add: #getColor.
	^Color tan! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 14:53'!
getText
	queries add: #getText.
	^Text new! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 14:54'!
getTextSelection
	queries add: #getTextSelection.
	^(1 to: 0)! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/10/2005 21:03'!
makeText
	| spec |
	spec := self makeTextSpec.
	widget := builder build: spec.! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 7/14/2005 22:17'!
makeTextSpec
	| spec |
	spec := builder pluggableTextSpec new.
	spec name: #text.
	spec model: self.
	spec getText: #getText.
	spec selection: #getTextSelection.
	spec color: #getColor.
	"<-- the following cannot be tested very well -->"
	spec setText: #setText:.
	spec menu: #getMenu:.
	^spec! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 19:29'!
setText: newText
	queries add: #setText.
	^false! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 21:41'!
testGetText
	self makeText.
	queries := IdentitySet new.
	self changed: #getText.
	self assert: (queries includes: #getText).! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 21:41'!
testGetTextColor
	self makeText.
	queries := IdentitySet new.
	self changed: #getColor.
	self assert: (queries includes: #getColor).
	self assert: self widgetColor = self getColor.! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 14:56'!
testGetTextSelection
	self makeText.
	queries := IdentitySet new.
	self changed: #getTextSelection.
	self assert: (queries includes: #getTextSelection).! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 14:57'!
testGetTextSideEffectFree
	self makeText.
	queries := IdentitySet new.
	self changed: #testSignalWithNoDiscernableEffect.
	self assert: queries isEmpty.! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 19:23'!
testSetText
	self makeText.
	queries := IdentitySet new.
	self acceptWidgetText.
	self assert: (queries includes: #setText).! !

!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 7/14/2005 22:17'!
testTextWidgetID
	self makeText.
	self assert: (builder widgetAt: #text) == widget! !


!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:43'!
getChildrenOf: item
	queries add: #getChildrenOf.
	^(1 to: 9) asArray! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:44'!
getHelpOf: item
	^'help'! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:43'!
getIconOf: item
	queries add: #getIconOf.
	^nil! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:47'!
getLabelOf: item
	queries add: #getLabelOf.
	^item asString! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:41'!
getRoots
	queries add: #getRoots.
	^(1 to: 9) asArray! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 03:38'!
getTreeSelectionPath
	queries add: #getTreeSelectionPath.
	^{2. 4. 3}! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:43'!
hasChildren: item
	queries add: #hasChildren.
	^true! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 7/14/2005 22:15'!
makeTree
	| spec |
	spec := self makeTreeSpec.
	widget := builder build: spec.! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 7/14/2005 22:15'!
makeTreeSpec
	| spec |
	spec := builder pluggableTreeSpec new.
	spec name: #tree.
	spec model: self.
	spec roots: #getRoots.
	"<-- the following cannot be tested very well -->"
	spec getSelectedPath: #getTreeSelectionPath.
	spec getChildren: #getChildrenOf:.
	spec hasChildren: #hasChildren:.
	spec label: #getLabelOf:.
	spec icon: #getIconOf:.
	spec help: #getHelpOf:.
	spec setSelected: #setTreeSelection:.
	spec menu: #getMenu:.
	spec keyPress: #keyPress:.
	^spec! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:44'!
setTreeSelection: node
	queries add: #setTreeSelection.! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 03:51'!
testTreeExpandPath
	"@@@@: REMOVE THIS - it's a hack (changed: #openPath)"
	self makeTree.
	queries := IdentitySet new.
	self changed: {#openPath. '4'. '2'. '3'}.
	self waitTick.
	self assert: (queries includes: #getChildrenOf).
	self assert: (queries includes: #setTreeSelection).
	self assert: (queries includes: #getLabelOf).
! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 03:51'!
testTreeExpandPathFirst
	"@@@@: REMOVE THIS - it's a hack (changed: #openPath)"
	self makeTree.
	queries := IdentitySet new.
	self changed: {#openPath. '1'. '2'. '2'}.
	self waitTick.
	self assert: (queries includes: #getChildrenOf).
	self assert: (queries includes: #setTreeSelection).
	self assert: (queries includes: #getLabelOf).
! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 03:49'!
testTreeGetSelectionPath
	self makeTree.
	queries := IdentitySet new.
	self changed: #getTreeSelectionPath.
	self waitTick.
	self assert: (queries includes: #getTreeSelectionPath).
	self assert: (queries includes: #getChildrenOf).
	self assert: (queries includes: #setTreeSelection).
! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:48'!
testTreeRoots
	self makeTree.
	queries := IdentitySet new.
	self changed: #getRoots.
	self assert: (queries includes: #getRoots).! !

!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 7/14/2005 22:22'!
testTreeWidgetID
	self makeTree.
	self assert: (builder widgetAt: #tree) == widget.! !


!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/10/2005 21:04'!
makeWindow
	| spec |
	spec := self makeWindowSpec.
	widget := builder build: spec.! !

!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 9/17/2005 21:02'!
makeWindowSpec
	| spec |
	spec := builder pluggableWindowSpec new.
	spec name: #window.
	spec model: self.
	spec children: #getChildren.
	spec label: #getLabel.
	spec closeAction: #noteWindowClosed.
	^spec! !

!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 9/17/2005 21:02'!
noteWindowClosed
	queries add: #noteWindowClosed.! !

!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 9/17/2005 21:04'!
openWindow
	| spec |
	spec := self makeWindowSpec.
	widget := builder open: spec.! !

!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/11/2005 14:56'!
testGetWindowChildren
	self makeWindow.
	queries := IdentitySet new.
	self changed: #getChildren.
	self assert: (queries includes: #getChildren).! !

!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/11/2005 14:56'!
testGetWindowLabel
	self makeWindow.
	queries := IdentitySet new.
	self changed: #getLabel.
	self assert: (queries includes: #getLabel).! !

!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/11/2005 14:57'!
testGetWindowSideEffectFree
	self makeWindow.
	queries := IdentitySet new.
	self changed: #testSignalWithNoDiscernableEffect.
	self assert: queries isEmpty.! !

!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 9/17/2005 21:05'!
testWindowCloseAction
	self openWindow.
	builder close: widget.
	self assert: (queries includes: #noteWindowClosed).! !

!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 7/14/2005 22:20'!
testWindowID
	self makeWindow.
	self assert: (builder widgetAt: #window) == widget.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ToolBuilderTests class
	instanceVariableNames: ''!

!ToolBuilderTests class methodsFor: 'testing' stamp: 'ar 2/11/2005 14:36'!
isAbstract
	^self == ToolBuilderTests! !
AppRegistry subclass: #ToolSet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Applications'!
!ToolSet commentStamp: 'ar 7/15/2005 17:58' prior: 0!
ToolSet defines an interface that clients can use to request programmer facilities such as browsers, inspectors, debuggers, message sets etc.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ToolSet class
	instanceVariableNames: ''!

!ToolSet class methodsFor: 'accessing' stamp: 'ar 7/17/2005 10:47'!
askForDefault
	"Ask for the default implementor"
	self registeredClasses isEmpty 
		ifTrue:[^ default _ nil].
	self registeredClasses size = 1 
		ifTrue:[^ default _ self registeredClasses anyOne].
	default := UIManager default 
		chooseFrom: (self registeredClasses collect:[:each| each name printString])
		values: self registeredClasses
		title: 'Which ', self appName, ' would you prefer?'.
	^default.! !


!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:54'!
browseChangeSetsWithClass: aClass selector: aSelector
	"Browse all the change sets with the given class/selector"
	self default ifNil:[^self inform: 'No ChangeSorter present'].
	^self default browseChangeSetsWithClass: aClass selector: aSelector! !

!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:14'!
browseHierarchy: aClass selector: aSelector
	"Open a browser"
	self default ifNil:[^self inform: 'No browser present'].
	^self default browseHierarchy: aClass selector: aSelector! !

!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:12'!
browseMessageNames: aString
	"Open a MessageNames browser"
	self default ifNil:[^self inform: 'No MessageNames present'].
	^self default browseMessageNames: aString! !

!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:13'!
browseMessageSet: messageList name: title autoSelect: autoSelectString
	"Open a message set browser"
	self default ifNil:[^self inform: 'Cannot open MessageSet'].
	^self default browseMessageSet: messageList name: title autoSelect: autoSelectString! !

!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:54'!
browseVersionsOf: aClass selector: aSelector
	"Open a browser"
	self default ifNil:[^self inform: 'Cannot open Browser'].
	^self default browseVersionsOf: aClass selector: aSelector! !

!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:54'!
browse: aClass selector: aSelector
	"Open a browser"
	self default ifNil:[^self inform: 'Cannot open Browser'].
	^self default browse: aClass selector: aSelector! !

!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:44'!
openChangedMessageSet: aChangeSet
	"Open a ChangedMessageSet for aChangeSet"
	self default ifNil:[^self inform: 'Cannot open MessageSet'].
	^self default openChangedMessageSet: aChangeSet! !

!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:44'!
openClassListBrowser: anArray title: aString
	"Open a class list browser"
	self default ifNil:[^self inform: 'Cannot open ClassListBrowser'].
	^self default openClassListBrowser: anArray title: aString! !


!ToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 10:37'!
debugContext: aContext label: aString contents: contents
	"Open a debugger on the given context."
	self default ifNil:[
		(self confirm: 'Debugger request -- proceed?')
			ifFalse:[Processor terminateActive].
		^self].
	^self default debugContext: aContext label: aString contents: contents! !

!ToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 11:00'!
debugError: anError
	"Handle an otherwise unhandled error"
	self default ifNil:[ | ctx |
		Smalltalk 
			logError: anError description 
			inContext: (ctx := anError signalerContext)
			to: 'SqueakDebug.log'.
		self inform: (anError description, String cr, ctx shortStack).
		^anError return].
	^self default debugError: anError! !

!ToolSet class methodsFor: 'debugging' stamp: 'ar 9/27/2005 19:12'!
debugSyntaxError: anError
	"Handle a syntax error"
	self default ifNil:[^self debugError: anError]. "handle as usual error"
	^self default debugSyntaxError: anError! !

!ToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 10:37'!
debug: aProcess context: aContext label: aString contents: contents fullView: aBool
	"Open a debugger on the given process and context."
	self default ifNil:[
		(self confirm: 'Debugger request -- proceed?')
			ifFalse:[Processor terminateActive].
		^self].
	^self default debug: aProcess context: aContext label: aString contents: contents fullView: aBool! !

!ToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 10:37'!
interrupt: aProcess label: aString
	"Open a debugger on the given process and context."
	self default ifNil:[
		(self confirm: 'Debugger request -- proceed?')
			ifFalse:[aProcess terminate].
		^self].
	^self default interrupt: aProcess label: aString! !


!ToolSet class methodsFor: 'inspecting' stamp: 'ar 7/17/2005 10:54'!
basicInspect: anObject
	"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
	self default ifNil:[^self inform: 'Cannot inspect -- no Inspector present'].
	^self default basicInspect: anObject! !

!ToolSet class methodsFor: 'inspecting' stamp: 'al 11/28/2005 20:32'!
explore: anObject
	"Open an explorer on the given object."
	self default ifNil:[^self inform: 'Cannot explore - no ToolSet present'].
	^self default explore: anObject! !

!ToolSet class methodsFor: 'inspecting' stamp: 'ar 7/17/2005 10:43'!
inspectorClassOf: anObject
	"Answer the inspector class for the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
	self default ifNil:[^nil].
	^self default inspectorClassOf: anObject! !

!ToolSet class methodsFor: 'inspecting' stamp: 'ar 7/17/2005 10:55'!
inspect: anObject
	"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
	self default ifNil:[^self inform: 'Cannot inspect - no ToolSet present'].
	^self default inspect: anObject! !

!ToolSet class methodsFor: 'inspecting' stamp: 'ar 7/17/2005 10:55'!
inspect: anObject label: aString
	"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
	self default ifNil:[^self inform: 'Cannot inspect - no ToolSet present'].
	^self default inspect: anObject label: aString! !


!ToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:19'!
menuItems
	"Answer the menu items available for this tool set"
	self default ifNil:[^#()].
	^self default menuItems! !
CornerGripMorph subclass: #TopLeftGripMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!TopLeftGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0!
I am the handle in the left top of windows used for resizing them.!


!TopLeftGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 18:02'!
apply: delta 
	| oldBounds |
	oldBounds := target bounds.
	target
		bounds: (oldBounds origin + delta corner: oldBounds corner)! !

!TopLeftGripMorph methodsFor: 'target resize' stamp: 'md 2/24/2006 22:44'!
ptName
	^#topLeft! !


!TopLeftGripMorph methodsFor: 'drawing' stamp: 'jmv 2/19/2006 14:24'!
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 bottom: (dotBounds2 top + windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.
	
	dotBounds2 _ dotBounds left: (dotBounds left + windowBorderWidth).
	dotBounds2 _ dotBounds2 bottom: (dotBounds2 top + 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 top: (dotBounds2 top + 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! !


!TopLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:47'!
gripLayoutFrame
	^ LayoutFrame
		fractions: (0 @ 0 corner: 0 @ 0)
		offsets: (0 @ -27 corner: self defaultWidth @ 0)! !

!TopLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'!
resizeCursor

	^ Cursor resizeForEdge: #topLeft! !
CornerGripMorph subclass: #TopRightGripMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!TopRightGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0!
I am the handle in the right top of windows used for resizing them.!


!TopRightGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 18:05'!
apply: delta 
	| oldBounds |
	oldBounds := target bounds.
	target
		bounds: (oldBounds origin + (0@delta y) corner: oldBounds corner + (delta x @ 0))! !


!TopRightGripMorph methodsFor: 'drawing' stamp: 'jmv 2/19/2006 14:24'!
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 bottom: (dotBounds2 top + windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.
	
	dotBounds2 _ dotBounds right: (dotBounds right - windowBorderWidth).
	dotBounds2 _ dotBounds2 bottom: (dotBounds2 top + 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 top: (dotBounds2 top + 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! !


!TopRightGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:47'!
gripLayoutFrame
	^ LayoutFrame
		fractions: (1 @ 0 corner: 1 @ 0)
		offsets: (0 - self defaultWidth @ -27 corner: 0 @ 0)! !

!TopRightGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:44'!
ptName
	^#topRight! !

!TopRightGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'!
resizeCursor

	^ Cursor resizeForEdge: #topRight! !
TraitDescription subclass: #Trait
	uses: TBehaviorCategorization
	instanceVariableNames: 'name environment classTrait category'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Kernel'!
!Trait commentStamp: '<historical>' prior: 0!
Each trait in the system is represented as an instance of me. Like Class, I concretize my superclass by providing instance variables for the name and the environment. Since traits do not define variables, I not provide facilities for pool variables. However, I declare an instance variable to hold the associated classtrait, which is an instance of the class ClassTrait. !


!Trait methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'!
basicCategory
	^category! !

!Trait methodsFor: 'accessing' stamp: 'al 3/18/2006 13:22'!
basicCategory: aSymbol
	category := aSymbol! !

!Trait methodsFor: 'accessing' stamp: 'al 7/17/2004 14:16'!
environment
	^environment! !

!Trait methodsFor: 'accessing' stamp: 'al 7/17/2004 14:16'!
environment: anObject
	environment _ anObject! !

!Trait methodsFor: 'accessing' stamp: 'al 7/17/2004 14:16'!
name
	^name! !

!Trait methodsFor: 'accessing' stamp: 'al 7/17/2004 14:16'!
name: aSymbol
	name _ aSymbol! !

!Trait methodsFor: 'accessing' stamp: 'dvf 9/6/2005 13:11'!
requirements
	^self requiredSelectors! !


!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'!
baseTrait
	^self! !

!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'!
classTrait
	^classTrait! !

!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'!
classTrait: aTrait
	"Assigns the class trait associated with the receiver."
	
	self assert: aTrait isClassTrait.
	classTrait _ aTrait! !

!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'!
hasClassTrait
	^classTrait notNil! !

!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'!
isBaseTrait
	^true! !

!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'!
isClassTrait
	^false! !


!Trait methodsFor: 'copying' stamp: 'dvf 8/30/2005 16:49'!
copy 
	| newTrait |
	newTrait := self class basicNew initialize
		name: self name
		traitComposition: self traitComposition copyTraitExpression 
		methodDict: self methodDict copy
		localSelectors: self localSelectors copy
		organization: self organization copy.
		
	newTrait classTrait initializeFrom: self classTrait.
	^newTrait! !


!Trait methodsFor: 'fileIn/Out' stamp: 'al 12/1/2005 16:06'!
fileOutAsHtml: useHtml
	"File a description of the receiver onto a new file whose base name is the name of the receiver."

	| internalStream |
	internalStream _ WriteStream on: (String new: 100).
	internalStream header; timeStamp.

	self fileOutOn: internalStream moveSource: false toFile: 0.
	internalStream trailer.

	FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: useHtml.
! !

!Trait methodsFor: 'fileIn/Out' stamp: 'al 12/1/2005 16:29'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 
	"This is just copied from Class.. the whole fileout is a mess."
	^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! !

!Trait methodsFor: 'fileIn/Out' stamp: 'al 12/1/2005 16:28'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
	"File a description of the receiver on aFileStream. If the boolean argument,
	moveSource, is true, then set the trailing bytes to the position of aFileStream and
	to fileIndex in order to indicate where to find the source code."

	Transcript cr; show: name.
	super
		fileOutOn: aFileStream
		moveSource: moveSource
		toFile: fileIndex.
	self hasClassTrait ifTrue: [
		aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr.
		self classTrait
			fileOutOn: aFileStream
			moveSource: moveSource
			toFile: fileIndex]! !


!Trait methodsFor: 'initialize-release' stamp: 'al 7/17/2004 14:16'!
initialize
	super initialize.
	classTrait _ ClassTrait for: self! !

!Trait methodsFor: 'initialize-release' stamp: 'al 7/17/2004 23:00'!
name: aString traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization

	"Used by copy"
	
	self name: aString.
	localSelectors _ aSet.
	methodDict _ aMethodDict.
	traitComposition _ aComposition.
	self organization: aClassOrganization
	
	! !

!Trait methodsFor: 'initialize-release' stamp: 'al 7/29/2004 16:48'!
obsolete
	self name: ('AnObsolete' , self name) asSymbol.
	self hasClassTrait ifTrue: [
		self classTrait obsolete].
	super obsolete! !

!Trait methodsFor: 'initialize-release' stamp: 'al 7/17/2004 14:16'!
removeFromSystem
	self removeFromSystem: true! !

!Trait methodsFor: 'initialize-release' stamp: 'al 7/17/2004 14:16'!
removeFromSystem: logged
	self environment forgetClass: self logged: logged.
	self obsolete! !


!Trait methodsFor: 'testing' stamp: 'al 7/17/2004 14:16'!
isObsolete
	"Return true if the receiver is obsolete."
	^(self environment at: name ifAbsent: [nil]) ~~ self! !


!Trait methodsFor: '*monticello' stamp: 'al 3/26/2006 21:44'!
asClassDefinition
	^ MCTraitDefinition
		name: self name
		traitComposition: self traitCompositionString
		category: self category 
		comment: self organization classComment asString
		commentStamp: self organization commentStamp.! !

!Trait methodsFor: '*monticello' stamp: 'al 3/26/2006 21:45'!
classDefinitions
	| definitions |
	definitions := OrderedCollection with: self asClassDefinition.
	(self hasClassTrait
		and: [self classTrait hasTraitComposition]
		and: [self classTrait traitComposition isEmpty not])
			ifTrue: [definitions add: self classTrait asMCDefinition].
	^definitions asArray! !


!Trait methodsFor: 'private' stamp: 'al 7/17/2004 14:16'!
applyChangesOfNewTraitCompositionReplacing: oldComposition
	"Duplicated on Class"
	
	| changedSelectors |
	changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition.
	self classSide
		noteNewBaseTraitCompositionApplied: self traitComposition.
	^ changedSelectors! !

!Trait methodsFor: 'private' stamp: 'al 7/17/2004 14:16'!
isValidTraitName: aSymbol
	^(aSymbol isEmptyOrNil
		or: [aSymbol first isLetter not]
		or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]) not! !

!Trait methodsFor: 'private' stamp: 'al 7/17/2004 14:16'!
rename: aString 
	"The new name of the receiver is the argument, aString."

	| newName |
	(newName _ aString asSymbol) ~= self name
		ifFalse: [^ self].
	(self environment includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	(Undeclared includesKey: newName)
		ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
	self environment renameClass: self as: newName.
	name _ newName! !

!Trait methodsFor: 'private' stamp: 'al 7/17/2004 14:16'!
setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary
	(self isValidTraitName: aSymbol) ifFalse: [TraitException signal: 'Invalid trait name'].
	
	(self environment == aSystemDictionary
		and: [self name = aSymbol
			and: [self category = categorySymbol]]) ifTrue: [^self].
		
	((aSystemDictionary includes: aSymbol) and: [(aSystemDictionary at: aSymbol) ~~ self])
		ifTrue: [TraitException signal: 'The name ''' , aSymbol , ''' is already used'].

	(self environment notNil and: [self name notNil and: [self name ~= aSymbol]]) ifTrue: [
		self environment renameClass: self as: aSymbol].
	
	self name: aSymbol.
	self environment: aSystemDictionary.	
	self environment at: self name put: self.
	self environment organization classify: self name under: categorySymbol.
	^ true! !


!Trait methodsFor: 'compiling' stamp: 'md 3/5/2006 23:47'!
binding

	^ Smalltalk associationAt: name ifAbsent: [nil -> self]
! !



!Trait methodsFor: '*ob-standard-converting' stamp: 'lr 3/9/2006 21:01'!
asClassSideNode
	^ OBMetaclassNode on: self! !

!Trait methodsFor: '*ob-standard-converting' stamp: 'lr 3/6/2006 22:35'!
asNode
	^ OBClassNode on: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Trait class
	uses: TBehaviorCategorization classTrait
	instanceVariableNames: ''!

!Trait class methodsFor: 'instance creation' stamp: 'al 12/7/2003 16:00'!
defaultEnvironment
	^Smalltalk! !

!Trait class methodsFor: 'instance creation' stamp: 'md 3/3/2006 11:05'!
named: aSymbol uses: aTraitCompositionOrCollection category: aString
	| env |
	env _ self environment.
	^self
		named: aSymbol
		uses: aTraitCompositionOrCollection
		category: aString
		env: env! !

!Trait class methodsFor: 'instance creation' stamp: 'al 3/18/2006 13:48'!
named: aSymbol uses: aTraitCompositionOrCollection category: aString env: anEnvironment
	| trait oldTrait systemCategory |
	systemCategory _ aString asSymbol.
	trait _ anEnvironment
		at: aSymbol
		ifAbsent: [nil].
	oldTrait _ trait copy.
	trait _ trait ifNil: [super new].
	
	(trait isKindOf: Trait) ifFalse: [
		^self error: trait name , ' is not a Trait'].
	trait
		setName: aSymbol
		andRegisterInCategory: systemCategory
		environment: anEnvironment.
		
	trait setTraitComposition: aTraitCompositionOrCollection asTraitComposition.
	
	"... notify interested clients ..."
	oldTrait isNil ifTrue: [
		SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory.
		^ trait].
	SystemChangeNotifier uniqueInstance traitDefinitionChangedFrom: oldTrait to: trait.
	systemCategory ~= oldTrait category 
		ifTrue: [SystemChangeNotifier uniqueInstance class: trait recategorizedFrom: oldTrait category to: systemCategory].
		
	^ trait! !

!Trait class methodsFor: 'instance creation' stamp: 'al 12/19/2003 15:03'!
new
	self shouldNotImplement! !


!Trait class methodsFor: 'printing' stamp: 'al 2/9/2004 22:23'!
newTemplateIn: categoryString
	^String streamContents: [:stream |
		stream
			nextPutAll: self name;
			nextPutAll: ' named: #NameOfTrait';
			cr; tab;
			nextPutAll: 'uses: {}';
			cr; tab;
			nextPutAll: 'category: ';
			nextPut: $';
			nextPutAll: categoryString;
			nextPut: $' ]! !
TraitTransformation subclass: #TraitAlias
	instanceVariableNames: 'aliases'
	classVariableNames: 'AliasMethodCache'
	poolDictionaries: ''
	category: 'Traits-Composition'!
!TraitAlias commentStamp: '<historical>' prior: 0!
See comment of my superclass TraitTransformation.!


!TraitAlias methodsFor: 'accessing' stamp: 'al 3/12/2004 16:43'!
aliases
	"Collection of associations where key is the
	alias and value the original selector."
	
	^aliases! !

!TraitAlias methodsFor: 'accessing' stamp: 'al 3/17/2004 15:22'!
aliases: anArrayOfAssociations
	| newNames |
	newNames _ (anArrayOfAssociations collect: [:each | each key]) asIdentitySet.
	newNames size < anArrayOfAssociations size ifTrue: [
		TraitCompositionException signal: 'Cannot use the same alias name twice'].
	anArrayOfAssociations do: [:each |
		(newNames includes: each value) ifTrue: [
			TraitCompositionException signal: 'Cannot define an alias for an alias']].
	aliases _ anArrayOfAssociations! !


!TraitAlias methodsFor: 'composition' stamp: 'al 4/10/2004 23:51'!
removeAlias: aSymbol
	self aliases: (self aliases
		reject: [:each | each key = aSymbol])! !

!TraitAlias methodsFor: 'composition' stamp: 'al 3/3/2004 19:49'!
- anArrayOfSelectors
	^TraitExclusion
		with: self
		exclusions: anArrayOfSelectors! !


!TraitAlias methodsFor: 'copying' stamp: 'al 4/9/2004 21:27'!
copy
	^super copy
		aliases: self aliases copy;
		yourself! !

!TraitAlias methodsFor: 'copying' stamp: 'dvf 8/25/2005 16:07'!
copyTraitExpression
	^super copyTraitExpression
		aliases: self aliases deepCopy;
		yourself! !


!TraitAlias methodsFor: 'enquiries' stamp: 'al 3/12/2004 17:10'!
aliasesForSelector: aSymbol
	| selectors |
	selectors _ self aliases
		select: [:association | association value = aSymbol]
		thenCollect: [:association | association key].
	^(super aliasesForSelector: aSymbol)
		addAll: selectors;
		yourself
		 ! !

!TraitAlias methodsFor: 'enquiries' stamp: 'al 7/13/2004 16:53'!
allAliasesDict
	| dict |
	dict _ super allAliasesDict.
	self aliases do: [:assoc |
		dict at: assoc key put: assoc value].
	^dict! !

!TraitAlias methodsFor: 'enquiries' stamp: 'al 3/7/2004 23:26'!
allSelectors
	^self subject allSelectors
		addAll: (self aliases collect: [:each | each key]) asSet;
		yourself! !

!TraitAlias methodsFor: 'enquiries' stamp: 'al 4/7/2004 21:16'!
collectMethodsFor: aSelector into: methodDescription
	| originalSelector association |
	self subject
		collectMethodsFor: aSelector
		into: methodDescription.			
	association _ self aliasNamed: aSelector ifAbsent: [nil].
	association notNil ifTrue: [
		originalSelector _ association value.
		self subject
			collectMethodsFor: originalSelector
			into: methodDescription]! !


!TraitAlias methodsFor: 'enumeration' stamp: 'al 4/7/2004 21:14'!
aliasNamed: aSymbol ifAbsent: aBlock
	^self aliases
		detect: [:association |  association key = aSymbol]
		ifNone: aBlock! !


!TraitAlias methodsFor: 'printing' stamp: 'al 2/22/2004 21:45'!
printOn: aStream
	super printOn: aStream.
	aStream
		space;
		nextPut: $@;
		space;
		nextPut: ${.
	self aliases do: [:each | aStream print: each]
		separatedBy: [aStream nextPutAll: '. '].
	aStream nextPut: $}! !


!TraitAlias methodsFor: 'testing' stamp: 'al 4/10/2004 23:57'!
isEmpty
	^self aliases isEmpty! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitAlias class
	instanceVariableNames: ''!

!TraitAlias class methodsFor: 'instance creation' stamp: 'al 3/17/2004 15:22'!
assertValidAliasDefinition: anArrayOfAssociations
	"Throw an exceptions if the alias definition is not valid.
	It is expected to be a collection of associations and
	the number of arguments of the alias selector has to
	be the same as the original selector."

	((anArrayOfAssociations isKindOf: Collection) and: [
		anArrayOfAssociations allSatisfy: [:each |
			each isKindOf: Association]]) ifFalse: [
		TraitCompositionException signal: 'Invalid alias definition: Not a collection of associations.'].
	
	(anArrayOfAssociations allSatisfy: [:association |
		(association key numArgs = association value numArgs and: [
			(association key numArgs = -1) not])]) ifFalse: [
		TraitCompositionException signal: 'Invalid alias definition: Alias and original selector have to have the same number of arguments.']! !

!TraitAlias class methodsFor: 'instance creation' stamp: 'al 3/12/2004 16:24'!
with: aTraitComposition aliases: anArrayOfAssociations
	self assertValidAliasDefinition: anArrayOfAssociations.
	^self new
		subject: aTraitComposition;
		aliases: anArrayOfAssociations;
		yourself! !
Object subclass: #TraitBehavior
	uses: TPureBehavior @ {#pureRemoveSelector:->#removeSelector:. #pureAddSelectorSilently:withMethod:->#addSelectorSilently:withMethod:}
	instanceVariableNames: 'methodDict traitComposition localSelectors users'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Kernel'!
!TraitBehavior commentStamp: 'apb 3/2/2006 17:49' prior: 0!
I declare the instance variables methodDict, traitComposition and localSelectors that normally would be defined on PureBehavior (see class comment of PureBehavior). Furthermore I keep track of where I am used and I provide compatibility methods to make me useable in tools where originally a class was expected.!



!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/20/2005 21:24'!
addSelectorSilently: selector withMethod: compiledMethod
	self pureAddSelectorSilently: selector withMethod: compiledMethod.
	self notifyUsersOfChangedSelector: selector.! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/6/2004 12:24'!
allSelectors
	^ self selectors! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/6/2004 09:02'!
basicLocalSelectors
	"Direct accessor for the instance variable localSelectors.
	Since localSelectors is lazily initialized, this may 
	return nil, which means that all selectors are local."

	^ localSelectors! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 3/30/2004 13:26'!
basicLocalSelectors: aSetOrNil
	localSelectors _ aSetOrNil! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 12/10/2003 10:02'!
lookupSelector: selector
	^(self includesSelector: selector)
		ifTrue: [self compiledMethodAt: selector]
		ifFalse: [nil]! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 12/9/2003 10:51'!
methodDict
	^ methodDict! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 12/9/2003 10:50'!
methodDict: aDictionary
	methodDict _ aDictionary! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/17/2004 14:31'!
precodeCommentOrInheritedCommentFor: aSelector
	^self firstPrecodeCommentFor: aSelector
	! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/20/2005 21:24'!
removeSelector: selector
	self pureRemoveSelector: selector.
	self notifyUsersOfChangedSelector: selector.! !

!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 2/8/2004 19:08'!
zapAllMethods
	"Remove all methods in this trait which is assumed to be obsolete"

	methodDict _ MethodDictionary new.
	self hasClassTrait ifTrue: [self classTrait zapAllMethods]! !



!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:36'!
allInstVarNames
	^ #()! !

!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:34'!
allSubclassesDo: aBlock! !

!TraitBehavior methodsFor: 'class compatibility' stamp: 'al 12/31/2005 13:41'!
allSuperclasses
	^ OrderedCollection new! !

!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:34'!
allSuperclassesDo: aBlock! !

!TraitBehavior methodsFor: 'class compatibility' stamp: 'al 7/29/2004 15:03'!
inheritsFrom: aClass
	"Used by RB"
	
	^false! !

!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:33'!
instSize
	^0! !

!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:36'!
instVarNames
	^#()! !

!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:34'!
subclassDefinerClass
	^nil subclassDefinerClass ! !

!TraitBehavior methodsFor: 'class compatibility' stamp: 'al 7/17/2004 14:35'!
whichClassIncludesSelector: aSymbol 
	"Traits compatibile implementation for:
	
	Answer the class on the receiver's superclass chain where the 
	argument, aSymbol (a message selector), will be found. Answer nil if none found."
	
	^(self includesSelector: aSymbol)
		ifTrue: [self]
		ifFalse: [nil]! !





!TraitBehavior methodsFor: 'initialize-release' stamp: 'al 4/21/2004 21:56'!
forgetDoIts
	"get rid of old DoIt methods"
	self 
		basicRemoveSelector: #DoIt;
		basicRemoveSelector: #DoItIn:! !

!TraitBehavior methodsFor: 'initialize-release' stamp: 'NS 4/12/2004 14:28'!
initialize
	self methodDict: MethodDictionary new.
	self traitComposition: nil.
	users _ IdentitySet new.! !




!TraitBehavior methodsFor: 'remove me later' stamp: 'apb 8/22/2005 15:28'!
classPool
	^ Dictionary new! !

!TraitBehavior methodsFor: 'remove me later' stamp: 'apb 8/22/2005 15:29'!
sharedPools
	^ Dictionary new! !


!TraitBehavior methodsFor: 'send caches' stamp: 'dvf 9/6/2005 14:12'!
requiredSelectors
	| sss selfSentNotProvided otherRequired |
	sss := self selfSentSelectorsFromSelectors: self allSelectors.
	selfSentNotProvided _ sss copyWithoutAll: (self allSelectors select: [:e | (self >> e) isProvided]).
	otherRequired _ self allSelectors select: [:e | (self >> e) isRequired].
	^(selfSentNotProvided, otherRequired) asSet
! !

!TraitBehavior methodsFor: 'send caches' stamp: 'dvf 9/1/2005 16:40'!
sendCaches
	^LocalSends current for: self! !

!TraitBehavior methodsFor: 'send caches' stamp: 'dvf 8/9/2005 17:22'!
updateRequires
	| sss aTrait |
	sss := self selfSentSelectorsInTrait: aTrait.
	^sss copyWithoutAll: aTrait allSelectors.! !


!TraitBehavior methodsFor: 'testing' stamp: 'al 2/9/2004 22:29'!
isTrait
	^true! !



!TraitBehavior methodsFor: 'traits' stamp: 'NS 4/12/2004 14:16'!
addUser: aClassOrTrait
	users add: aClassOrTrait! !

!TraitBehavior methodsFor: 'traits' stamp: 'dvf 9/9/2005 19:39'!
classesComposedWithMe
	^users gather: [:u | u classesComposedWithMe]
! !

!TraitBehavior methodsFor: 'traits' stamp: 'al 7/21/2004 20:57'!
hasTraitComposition
	^traitComposition notNil! !

!TraitBehavior methodsFor: 'traits' stamp: 'al 4/20/2004 09:33'!
removeFromTraitCompositionOfUsers
	self users do: [:each |
		each removeFromComposition: self ]! !

!TraitBehavior methodsFor: 'traits' stamp: 'NS 4/12/2004 14:17'!
removeUser: aClassOrTrait
	users remove: aClassOrTrait ifAbsent: []! !

!TraitBehavior methodsFor: 'traits' stamp: 'al 12/12/2003 21:42'!
traitComposition
	traitComposition ifNil: [traitComposition _ TraitComposition new].
	^traitComposition! !

!TraitBehavior methodsFor: 'traits' stamp: 'NS 12/11/2003 16:35'!
traitComposition: aTraitComposition
	traitComposition _ aTraitComposition! !

!TraitBehavior methodsFor: 'traits' stamp: 'NS 4/12/2004 14:17'!
users
	^users! !




!TraitBehavior methodsFor: '*tools-browser' stamp: 'al 2/4/2006 11:43'!
browse
	self systemNavigation browseClass: self! !



"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitBehavior class
	uses: TPureBehavior classTrait
	instanceVariableNames: ''!
Object subclass: #TraitComposition
	instanceVariableNames: 'transformations'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Composition'!
!TraitComposition commentStamp: '<historical>' prior: 0!
I hold a collection of trait transformations and provide important facilities to query the trait composition. For each trait in the composition clause there exists exactly one transformation in the collection.

Note, that directly manipulating the composition of a class or trait does not effect changes automatically. Use PureBehavior>>setTraitComposition: to do this. You have to make a copy of the old trait composition before changing it because only the difference between the new and the old composition is updated!!!


!TraitComposition methodsFor: 'accessing' stamp: 'al 3/18/2004 14:10'!
add: aTraitTransformation
	self errorIfNotAddable: aTraitTransformation.
	self transformations addLast: aTraitTransformation! !

!TraitComposition methodsFor: 'accessing' stamp: 'al 3/26/2006 22:03'!
allTraits
	^self traits gather: [:trait |
		trait hasTraitComposition
			ifTrue: [trait traitComposition allTraits copyWith: trait]
			ifFalse: [Array with: trait]]! !

!TraitComposition methodsFor: 'accessing' stamp: 'al 4/9/2004 17:12'!
removeFromComposition: aTrait
	self remove:
		(self transformationOfTrait: aTrait)! !

!TraitComposition methodsFor: 'accessing' stamp: 'al 4/9/2004 17:12'!
remove: aTransformation
	self transformations
		remove: aTransformation! !

!TraitComposition methodsFor: 'accessing' stamp: 'al 1/18/2004 19:29'!
size
	^transformations size! !

!TraitComposition methodsFor: 'accessing' stamp: 'al 4/13/2004 15:30'!
traits
	^self transformations collect: [:each |
		each trait]! !

!TraitComposition methodsFor: 'accessing' stamp: 'al 3/7/2004 22:31'!
transformationOfTrait: aTrait
	"Return the transformation which holds aTrait
	or nil if this composition doesn't include aTrait."
	
	^self transformations
		detect: [:each | each trait = aTrait]
		ifNone: [nil]! !

!TraitComposition methodsFor: 'accessing' stamp: 'al 3/17/2004 19:34'!
transformations
	^transformations! !


!TraitComposition methodsFor: 'composition' stamp: 'apb 8/22/2005 17:28'!
addOnTheLeft: aTrait 
	self errorIfNotAddable: aTrait.
	self transformations addFirst: aTrait! !

!TraitComposition methodsFor: 'composition' stamp: 'al 4/10/2004 00:08'!
normalizeTransformations
	self transformations: (
		self transformations collect: [:each |
			each normalized])! !

!TraitComposition methodsFor: 'composition' stamp: 'apb 8/22/2005 17:52'!
+ aTraitExpression
	^ aTraitExpression addCompositionOnLeft: self.
! !

!TraitComposition methodsFor: 'composition' stamp: 'al 12/15/2003 20:56'!
- anArray
	"the modifier operators #@ and #- bind stronger than +.
	Thus, #@ or #- sent to a sum will only affect the most right summand"
	
	self transformations
		addLast: (self transformations removeLast - anArray)! !

!TraitComposition methodsFor: 'composition' stamp: 'al 12/15/2003 20:56'!
@ anArrayOfAssociations
	"the modifier operators #@ and #- bind stronger than +.
	Thus, #@ or #- sent to a sum will only affect the most right summand"

	self transformations
		addLast: (self transformations removeLast @ anArrayOfAssociations)! !


!TraitComposition methodsFor: 'converting' stamp: 'al 1/18/2004 19:35'!
asTraitComposition
	^self! !


!TraitComposition methodsFor: 'copying' stamp: 'apb 8/24/2005 17:13'!
copy
	self error: 'should not be called'.
	^super copy
		transformations: (self transformations collect: [:each | each copy]);
		yourself! !

!TraitComposition methodsFor: 'copying' stamp: 'apb 8/24/2005 13:49'!
copyTraitExpression
	| newCopy |
	newCopy _ self shallowCopy.
	newCopy transformations: (self transformations collect: [ : each | each copyTraitExpression ]).
	^ newCopy
! !

!TraitComposition methodsFor: 'copying' stamp: 'al 12/7/2005 20:49'!
copyWithExclusionOf: aSymbol to: aTrait
	| composition transformation |
	composition _ self copyTraitExpression.
	transformation _ (composition transformationOfTrait: aTrait).
	^composition
		remove: transformation;
		add: (transformation addExclusionOf: aSymbol);
		yourself! !

!TraitComposition methodsFor: 'copying' stamp: 'al 12/7/2005 20:50'!
copyWithoutAlias: aSymbol of: aTrait
	| composition transformation |
	composition _ self copyTraitExpression.
	transformation _ (composition transformationOfTrait: aTrait).
	^composition
		remove: transformation;
		add: (transformation removeAlias: aSymbol);
		normalizeTransformations;
		yourself! !


!TraitComposition methodsFor: 'enquiries' stamp: 'apb 8/22/2005 14:48'!
changedSelectorsComparedTo: oldComposition
	| changedSelectors oldTransformation traits newTransformation |
	changedSelectors := IdentitySet new.
	traits := self traits asIdentitySet addAll: oldComposition traits asIdentitySet; yourself.
	traits do: [:each |
		newTransformation := self transformationOfTrait: each.
		oldTransformation := oldComposition transformationOfTrait: each.
		(newTransformation isNil or: [oldTransformation isNil])
			ifTrue: [
				changedSelectors addAll: each selectors]
			ifFalse: [
				changedSelectors addAll: 
					(newTransformation changedSelectorsComparedTo: oldTransformation)]].
	^changedSelectors! !

!TraitComposition methodsFor: 'enquiries' stamp: 'al 7/21/2004 21:03'!
methodDescriptionForSelector: aSymbol
	"Return a TraitMethodDescription for the selector aSymbol."

	| description |
	description _ TraitMethodDescription selector: aSymbol.
	self transformations do: [:each |
		each collectMethodsFor: aSymbol into: description].
	^description! !

!TraitComposition methodsFor: 'enquiries' stamp: 'al 7/21/2004 21:03'!
methodDescriptionsForSelector: aSymbol
	"Return a collection of TraitMethodDescriptions for aSymbol and all the 
	aliases of aSymbol."

	| selectors collection |
	selectors _ IdentitySet with: aSymbol.
	self transformations do: [:each |
		selectors addAll: (each aliasesForSelector: aSymbol)].
	collection _ OrderedCollection new: selectors size.
	selectors do: [:each |
		collection add: (self methodDescriptionForSelector: each)].
	^collection! !

!TraitComposition methodsFor: 'enquiries' stamp: 'al 7/22/2004 15:35'!
traitProvidingSelector: aSymbol
	"Return the trait which originally provides the method aSymbol or return nil
	if trait composition does not provide this selector or there is a conflict.
	Take aliases into account. Return the trait which the aliased method is defined in."

	| methodDescription locatedMethod |
	methodDescription _ self methodDescriptionForSelector: aSymbol.
	(methodDescription isProvided not or: [methodDescription isConflict])	
		ifTrue: [^nil].
	locatedMethod _ methodDescription providedLocatedMethod.
	^locatedMethod location traitOrClassOfSelector: locatedMethod selector! !


!TraitComposition methodsFor: 'error-handling' stamp: 'al 3/18/2004 14:19'!
assertValidUser: aBehavior
	"Assert that this trait composition set for aBehavior
	does not introduce a cycle."
	
	(self allTraits includes: aBehavior) ifTrue: [
		TraitCompositionException signal: 'Cycle in compositions:  The composition (in)directly includes this trait!!']! !

!TraitComposition methodsFor: 'error-handling' stamp: 'al 3/17/2004 15:22'!
errorIfNotAddable: aTraitTransformation
	(self includesTrait: aTraitTransformation trait) ifTrue: [
		^TraitCompositionException
			signal: 'Trait ' , aTraitTransformation trait asString, ' already in composition']! !


!TraitComposition methodsFor: 'initialize-release' stamp: 'al 3/12/2004 17:06'!
initialize
	super initialize.
	transformations _ OrderedCollection new! !


!TraitComposition methodsFor: 'printing' stamp: 'al 12/16/2003 22:06'!
printOn: aStream
	self transformations isEmptyOrNil
		ifFalse: [
			self transformations
				do: [:each | aStream print: each]
				separatedBy: [aStream nextPutAll: ' + '] ]
		ifTrue: [aStream nextPutAll: '{}']
		! !

!TraitComposition methodsFor: 'printing' stamp: 'al 12/16/2003 22:16'!
printString
	^String streamContents: [:stream |
		self printOn: stream]! !


!TraitComposition methodsFor: 'testing' stamp: 'al 7/30/2004 15:50'!
includesMethod: aSelector
	^(self methodDescriptionForSelector: aSelector) isEmpty not! !

!TraitComposition methodsFor: 'testing' stamp: 'al 1/18/2004 19:32'!
includesTrait: aTrait
	^self traits includes: aTrait! !

!TraitComposition methodsFor: 'testing' stamp: 'al 4/10/2004 23:25'!
isAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in this or in another composition somewhere deeper in 
	the tree of traits compositions."

	| methodDescription |
	methodDescription _ (self methodDescriptionsForSelector: aSymbol)
		detect: [:each | each selector = aSymbol].
	^methodDescription isAliasSelector! !

!TraitComposition methodsFor: 'testing' stamp: 'al 3/6/2004 19:05'!
isEmpty
	^self transformations isEmpty! !

!TraitComposition methodsFor: 'testing' stamp: 'al 4/10/2004 23:34'!
isLocalAliasSelector: aSymbol
	"Return true if the selector aSymbol is an alias defined
	in this composition."

	| methodDescription |
	methodDescription _ (self methodDescriptionsForSelector: aSymbol)
		detect: [:each | each selector = aSymbol].
	^methodDescription isLocalAliasSelector! !

!TraitComposition methodsFor: 'testing' stamp: 'al 3/6/2004 19:05'!
notEmpty
	^self isEmpty not! !


!TraitComposition methodsFor: 'private' stamp: 'apb 8/22/2005 17:44'!
addCompositionOnLeft: aTraitComposition
	self transformations do: [ : each | aTraitComposition add: each ].
	^ aTraitComposition! !

!TraitComposition methodsFor: 'private' stamp: 'al 3/19/2004 10:30'!
transformations: aCollection
	transformations _ aCollection! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitComposition class
	instanceVariableNames: ''!

!TraitComposition class methodsFor: 'instance creation' stamp: 'al 12/12/2003 18:24'!
with: aTraitTransformation
	^self new
		add: aTraitTransformation;
		yourself! !

!TraitComposition class methodsFor: 'instance creation' stamp: 'al 12/12/2003 18:24'!
with: aTraitTransformation with: anotherTraitTransformation
	^self new
		add: aTraitTransformation;
		add: anotherTraitTransformation;
		yourself! !
TraitException subclass: #TraitCompositionException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Composition'!
!TraitCompositionException commentStamp: '<historical>' prior: 0!
Signal invalid trait compositions.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitCompositionException class
	instanceVariableNames: ''!
TraitsTestCase subclass: #TraitCompositionTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'!
testAliasCompositions
	"unary"

	self 
		shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#aliasM11 -> #m11) }]
		raise: TraitCompositionException.
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#alias: -> #m11) }]
		raise: TraitCompositionException.
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#alias:x:y: -> #m11) }]
		raise: TraitCompositionException.

	"binary"
	self t1 compile: '= anObject'.
	self 
		shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#equals: -> #=) }]
		raise: TraitCompositionException.
	self shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#% -> #=) }]
		raise: TraitCompositionException.
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#equals -> #=) }]
		raise: TraitCompositionException.
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#equals:x: -> #=) }]
		raise: TraitCompositionException.

	"keyword"
	self t1 compile: 'x: a y: b z: c'.
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#'==' -> #x:y:z:) }]
		raise: TraitCompositionException.
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#x -> #x:y:z:) }]
		raise: TraitCompositionException.
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#x: -> #x:y:z:) }]
		raise: TraitCompositionException.
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#x:y: -> #x:y:z:) }]
		raise: TraitCompositionException.
	self shouldnt: 
			[self t2 setTraitCompositionFrom: self t1 @ { (#myX:y:z: -> #x:y:z:) }]
		raise: TraitCompositionException.

	"alias same as selector"
	self 
		should: [self t2 setTraitCompositionFrom: self t1 @ { (#m11 -> #m11) }]
		raise: TraitCompositionException.

	"same alias name used twice"
	self should: 
			[self t2 
				setTraitCompositionFrom: self t1 @ { (#alias -> #m11). (#alias -> #m12) }]
		raise: TraitCompositionException.

	"aliasing an alias"
	self should: 
			[self t2 
				setTraitCompositionFrom: self t1 @ { (#alias -> #m11). (#alias2 -> #alias) }]
		raise: TraitCompositionException! !

!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/30/2005 14:07'!
testCompositionFromArray
	| composition |
	composition := { (self t1) } asTraitComposition.
	self assert: (composition isKindOf: TraitComposition).
	self assert: (composition traits includes: self t1).
	self assert: composition traits size = 1.
	composition := { (self t1). self t2 } asTraitComposition.
	self assert: (composition isKindOf: TraitComposition).
	self assert: (composition traits includes: self t1).
	self assert: (composition traits includes: self t2).
	self assert: composition traits size = 2! !

!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'al 12/15/2003 20:51'!
testEmptyTrait
	| composition |
	composition _ {} asTraitComposition.
	
	self assert: (composition isKindOf: TraitComposition).
	self assert: composition transformations isEmpty.
	self assert: composition traits isEmpty! !

!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'!
testInvalidComposition
	self should: [self t1 @ { (#a -> #b) } @ { (#x -> #y) }]
		raise: TraitCompositionException.
	self should: [(self t1 + self t2) @ { (#a -> #b) } @ { (#x -> #y) }]
		raise: TraitCompositionException.
	self should: [self t1 - { #a } - { #b }] raise: TraitCompositionException.
	self should: [self t1 + self t2 - { #a } - { #b }]
		raise: TraitCompositionException.
	self should: [(self t1 - { #x }) @ { (#a -> #b) }]
		raise: TraitCompositionException.
	self should: [(self t1 + self t2 - { #x }) @ { (#a -> #b) }]
		raise: TraitCompositionException.
	self should: [self t1 + self t1] raise: TraitCompositionException.
	self should: [(self t1 + self t2) @ { (#a -> #b) } + self t1]
		raise: TraitCompositionException.
	self should: [self t1 @ { (#a -> #m11). (#a -> #m12) }]
		raise: TraitCompositionException.
	self should: [self t1 @ { (#a -> #m11). (#b -> #a) }]
		raise: TraitCompositionException! !

!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'!
testPrinting
	| composition1 composition2 |
	composition1 := ((self t1 - { #a } + self t2) @ { (#z -> #c) } - { #b. #c } 
				+ self t3 - { #d. #e } 
				+ self t4) @ { (#x -> #a). (#y -> #b) }.
	composition2 := self t4 @ { (#x -> #a). (#y -> #b) } + self t1 - { #a } 
				+ self t3 - { #d. #e } 
				+ self t2 - { #b. #c }.
	self assertPrints: composition1 printString
		like: 'T1 - {#a} + T2 @ {#z->#c} - {#b. #c} + T3 - {#d. #e} + T4 @ {#x->#a. #y->#b}'.
	self assertPrints: composition2 printString
		like: 'T4 @ {#x->#a. #y->#b} + T1 - {#a} + T3 - {#d. #e} + T2 - {#b. #c}'! !

!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'!
testSum
	| composition |
	composition := self t1 + self t2 + self t3.
	self assert: (composition isKindOf: TraitComposition).
	self assert: (composition traits includes: self t1).
	self assert: (composition traits includes: self t2).
	self assert: (composition traits includes: self t3).
	self assert: composition traits size = 3! !

!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'!
testSumWithParenthesis
	| composition |
	composition := self t1 + (self t2 + self t3).
	self assert: (composition isKindOf: TraitComposition).
	self assert: (composition traits includes: self t1).
	self assert: (composition traits includes: self t2).
	self assert: (composition traits includes: self t3).
	self assert: composition traits size = 3.
	self assert: composition size = 3! !


!TraitCompositionTest methodsFor: 'testing-enquiries' stamp: 'dvf 8/26/2005 14:31'!
testClassMethodsTakePrecedenceOverTraitsMethods
	| keys |
	keys := Set new.
	self t4 methodDict bindingsDo: [:each | keys add: each key].
	self assert: keys size = 6.
	self 
		assert: (keys includesAllOf: #(
						#m12
						#m13
						#m13
						#m21
						#m22
						#m11
						#m42
					)).
	self assert: (self t4 methodDict at: #m11) decompileString = 'm11
	^ 41'! !

!TraitCompositionTest methodsFor: 'testing-enquiries' stamp: 'dvf 8/26/2005 14:31'!
testProvidedMethodBindingsWithConflicts
	| traitWithConflict methodDict |
	traitWithConflict := self createTraitNamed: #TraitWithConflict
				uses: self t1 + self t4.
	methodDict := traitWithConflict methodDict.
	self assert: methodDict size = 6.
	self 
		assert: (methodDict keys includesAllOf: #(
						#m11
						#m12
						#m13
						#m21
						#m22
						#m42
					)).
	self 
		assert: (methodDict at: #m11) decompileString = 'm11
	self traitConflict'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitCompositionTest class
	instanceVariableNames: ''!
TraitBehavior subclass: #TraitDescription
	uses: TCopyingDescription + TBasicCategorisingDescription + TCompilingDescription + TAccessingMethodDictDescription + TTraitsCategorisingDescription + TPrintingDescription + TCommentDescription + TFileInOutDescription + TTestingDescription + TComposingDescription + TTransformationCompatibility
	instanceVariableNames: 'organization'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Kernel'!
!TraitDescription commentStamp: '<historical>' prior: 0!
I add a number of facilities (most defined by traits which are also used in ClassDescription):
	Category organization for methods
	The maintenance of a ChangeSet, and logging changes on a file
	Most of the mechanism for fileOut.
	Copying of methods to other traits/classes
	Operators to create trait compositions!


!TraitDescription methodsFor: 'accessing' stamp: 'NS 12/9/2003 11:00'!
traitVersion
	"Default.  Any class may return a later version to inform readers that use ReferenceStream.  8/17/96 tk"
	"This method allows you to distinguish between class versions when the shape of the class 
	hasn't changed (when there's no change in the instVar names).
	In the conversion methods you usually can tell by the inst var names 
	what old version you have. In a few cases, though, the same inst var 
	names were kept but their interpretation changed (like in the layoutFrame).
	By changing the class version when you keep the same instVars you can 
	warn older and newer images that they have to convert."
	^ 0! !

!TraitDescription methodsFor: 'accessing' stamp: 'NS 12/9/2003 15:12'!
version
		"Allows polymoprhism with ClassDescription>>version"
		
	^ self traitVersion! !


!TraitDescription methodsFor: 'accessing class hierarchy' stamp: 'NS 4/12/2004 14:38'!
subclasses
	^ Array new! !


!TraitDescription methodsFor: 'accessing comment' stamp: 'al 10/17/2005 10:45'!
classCommentBlank

	| existingComment stream |
	existingComment := self instanceSide organization classComment.
	existingComment isEmpty
		ifFalse: [^existingComment].

	stream := WriteStream on: (String new: 100).
	stream
		nextPutAll: 'A';
		nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']);
		nextPutAll: self name;
		nextPutAll: ' is xxxxxxxxx.'.
	stream cr.
	^stream contents! !


!TraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 09:51'!
addSelectorSilently: selector withMethod: compiledMethod
	super addSelectorSilently: selector withMethod: compiledMethod.
	self instanceSide noteAddedSelector: selector meta: self isMeta.! !

!TraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 6/29/2004 21:42'!
allMethodsInCategory: aName 
	"Answer a list of all the method categories of the receiver"
	
	| aColl |
	aColl _ aName = ClassOrganizer allCategory
		ifTrue: [self organization allMethodSelectors]
		ifFalse: [self organization listAtCategoryNamed: aName].
	^aColl asSet asSortedArray

	"TileMorph allMethodsInCategory: #initialization"! !

!TraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 20:49'!
removeSelector: selector 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."
	
	| priorMethod priorProtocol | 
	priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil].
	priorProtocol _ self whichCategoryIncludesSelector: selector.
	super removeSelector: selector.
	SystemChangeNotifier uniqueInstance 
		doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil].
	SystemChangeNotifier uniqueInstance 
			methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! !


!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/21/2004 10:01'!
baseTrait
	self subclassResponsibility! !

!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:05'!
classSide
	^self classTrait! !

!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/21/2004 10:01'!
classTrait
	self subclassResponsibility! !

!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/21/2004 10:02'!
hasClassTrait
	self subclassResponsibility! !

!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:05'!
instanceSide
	^self baseTrait! !

!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:47'!
isBaseTrait
	self subclassResponsibility! !

!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:47'!
isClassTrait
	self subclassResponsibility! !


!TraitDescription methodsFor: 'class compatibility' stamp: 'NS 12/9/2003 11:18'!
theMetaClass
	^ self classTrait! !

!TraitDescription methodsFor: 'class compatibility' stamp: 'al 12/10/2003 00:07'!
theNonMetaClass
	^ self baseTrait! !



!TraitDescription methodsFor: 'composition' stamp: 'al 12/7/2005 21:00'!
addExclusionOf: aSymbol
	^self - {aSymbol}! !



!TraitDescription methodsFor: 'copying' stamp: 'dvf 9/22/2005 17:54'!
copyTraitExpression
	"When recursively copying a trait expression, the primitive traits should NOT be copied
because they are globally named 'well-known' objects"
	^ self ! !



!TraitDescription methodsFor: 'fileIn/Out' stamp: 'al 3/26/2006 21:50'!
definitionST80
	^String streamContents: [:stream |
		stream nextPutAll: self class name.
		stream nextPutAll: ' named: ';
				store: self name.
		stream cr; tab; nextPutAll: 'uses: ';
				nextPutAll: self traitCompositionString.
		stream cr; tab; nextPutAll: 'category: ';
				store: self category asString].! !

!TraitDescription methodsFor: 'fileIn/Out' stamp: 'sd 12/28/2003 22:04'!
fileOut
	"Create a file whose name is the name of the receiver with '.st' as the 
	extension, and file a description of the receiver onto it."
	^ self fileOutAsHtml: false! !


!TraitDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 10:59'!
forgetDoIts
	"get rid of old DoIt methods and bogus entries in the ClassOrganizer."
	SystemChangeNotifier uniqueInstance doSilently: [
		self organization
			removeElement: #DoIt;
			removeElement: #DoItIn:.
	].
	super forgetDoIts.! !

!TraitDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 11:01'!
obsolete
	"Make the receiver obsolete."
	self organization: nil.
	super obsolete! !


!TraitDescription methodsFor: 'organization' stamp: 'al 3/18/2006 14:10'!
category
	self subclassResponsibility! !

!TraitDescription methodsFor: 'organization' stamp: 'al 3/18/2006 14:10'!
category: aString
	self subclassResponsibility! !

!TraitDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:03'!
organization
	"Answer the instance of ClassOrganizer that represents the organization 
	of the messages of the receiver."

	organization ifNil:
		[self organization: (ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray)].
	(organization isMemberOf: Array) ifTrue:
		[self recoverFromMDFaultWithTrace].
	
	"Making sure that subject is set correctly. It should not be necessary."
	organization ifNotNil: [organization setSubject: self].
	^ organization! !

!TraitDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:04'!
organization: aClassOrg
	"Install an instance of ClassOrganizer that represents the organization of the messages of the receiver."

	aClassOrg ifNotNil: [aClassOrg setSubject: self].
	organization _ aClassOrg! !


!TraitDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:08'!
applyChangesOfNewTraitCompositionReplacing: oldComposition
	| changedSelectors |
	changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition.
	self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition.
	^ changedSelectors.! !

!TraitDescription methodsFor: 'organization updating' stamp: 'al 12/1/2005 15:50'!
notifyOfRecategorizedSelector: element from: oldCategory to: newCategory
	SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self.
	SystemChangeNotifier uniqueInstance 
		doSilently: [self notifyUsersOfRecategorizedSelector: element from: oldCategory to: newCategory].! !



!TraitDescription methodsFor: 'testing' stamp: 'al 4/9/2004 15:28'!
isTestCase
	^false! !

!TraitDescription methodsFor: 'testing' stamp: 'dvf 8/9/2005 14:18'!
isUniClass
	^false! !


!TraitDescription methodsFor: 'users notification' stamp: 'NS 4/12/2004 15:45'!
notifyUsersOfChangedSelectors: aCollection
	self users do: [:each |
		each noteChangedSelectors: aCollection]! !

!TraitDescription methodsFor: 'users notification' stamp: 'NS 4/12/2004 21:46'!
notifyUsersOfRecategorizedSelector: element from: oldCategory to: newCategory
	self users do: [:each |
		each noteRecategorizedSelector: element from: oldCategory to: newCategory]! !


!TraitDescription methodsFor: 'private' stamp: 'md 6/2/2006 10:32'!
linesOfCode
	"An approximate measure of lines of code.
	Includes comments, but excludes blank lines."
	| lines |
	lines _ self methodDict values inject: 0 into: [:sum :each | sum + each linesOfCode]. 
	self isMeta 
		ifTrue: [^ lines]
		ifFalse: [^ lines + self class linesOfCode]! !

!TraitDescription methodsFor: 'private' stamp: 'al 2/4/2004 14:22'!
logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor
	| priorMethodOrNil newText |
	priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: [].
	newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not
						and: [Preferences confirmFirstUseOfStyle])
			ifTrue: [aText askIfAddStyle: priorMethodOrNil req: requestor]
			ifFalse: [aText].
	aCompiledMethodWithNode method putSource: newText
		fromParseNode: aCompiledMethodWithNode node
		class: self category: category withStamp: changeStamp 
		inFile: 2 priorMethod: priorMethodOrNil.! !

!TraitDescription methodsFor: 'private' stamp: 'al 7/30/2004 11:49'!
spaceUsed
	^super spaceUsed + (self hasClassTrait
		ifTrue: [self classTrait spaceUsed] 
		ifFalse: [0])! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitDescription class
	uses: TCopyingDescription classTrait + TBasicCategorisingDescription classTrait + TCompilingDescription classTrait + TAccessingMethodDictDescription classTrait + TTraitsCategorisingDescription classTrait + TPrintingDescription classTrait + TCommentDescription classTrait + TFileInOutDescription classTrait + TTestingDescription classTrait + TComposingDescription classTrait + TTransformationCompatibility classTrait
	instanceVariableNames: ''!
Error subclass: #TraitException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Kernel'!
!TraitException commentStamp: '<historical>' prior: 0!
General exception used for example to signal invalid trait compositions!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitException class
	instanceVariableNames: ''!
TraitTransformation subclass: #TraitExclusion
	instanceVariableNames: 'exclusions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Composition'!
!TraitExclusion commentStamp: '<historical>' prior: 0!
See comment of my superclass TraitTransformation.!


!TraitExclusion methodsFor: 'accessing' stamp: 'al 12/7/2003 11:58'!
exclusions
	^exclusions! !

!TraitExclusion methodsFor: 'accessing' stamp: 'al 12/7/2003 11:58'!
exclusions: aCollection
	exclusions _ aCollection! !

!TraitExclusion methodsFor: 'accessing' stamp: 'dvf 8/19/2005 12:25'!
methodReferencesInCategory: aCategoryName
	^(self organization listAtCategoryNamed: aCategoryName)
		collect: [:ea | MethodReference new
						setClassSymbol: self theNonMetaClass name
						classIsMeta: self isMeta
						methodSymbol: ea
						stringVersion: '']
! !


!TraitExclusion methodsFor: 'composition' stamp: 'al 4/9/2004 16:55'!
addExclusionOf: aSymbol
	self exclusions: (self exclusions copyWith: aSymbol)! !


!TraitExclusion methodsFor: 'copying' stamp: 'al 4/9/2004 19:12'!
copy
	^super copy
		exclusions: self exclusions copy;
		yourself! !

!TraitExclusion methodsFor: 'copying' stamp: 'dvf 8/25/2005 16:07'!
copyTraitExpression
	^super copyTraitExpression 
		exclusions: self exclusions deepCopy;
		yourself! !


!TraitExclusion methodsFor: 'enquiries' stamp: 'al 3/7/2004 22:48'!
allSelectors
	| selectors |
	selectors _ self subject allSelectors.
	self exclusions do: [:each |
		selectors remove: each ifAbsent: []].
	^selectors! !

!TraitExclusion methodsFor: 'enquiries' stamp: 'al 3/4/2004 16:35'!
collectMethodsFor: aSelector into: methodDescription
	(self exclusions includes: aSelector) ifFalse: [
		self subject
			collectMethodsFor: aSelector
			into: methodDescription]! !


!TraitExclusion methodsFor: 'printing' stamp: 'al 2/22/2004 21:45'!
printOn: aStream
	super printOn: aStream. 
	aStream
		space;
		nextPut: $-;
		space;
		nextPut: ${.
	self exclusions do: [:each | aStream print: each]
		separatedBy: [aStream nextPutAll: '. '].
	aStream nextPut: $}! !


!TraitExclusion methodsFor: 'testing' stamp: 'al 4/10/2004 23:56'!
isEmpty
	^self exclusions isEmpty! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitExclusion class
	instanceVariableNames: ''!

!TraitExclusion class methodsFor: 'instance creation' stamp: 'dvf 8/18/2005 17:36'!
with: aTraitComposition exclusions: anArrayOfSelectors
	^self new
		subject: aTraitComposition;
		exclusions: anArrayOfSelectors;
		yourself
! !
TraitsTestCase subclass: #TraitFileOutTest
	instanceVariableNames: 'ca cb ta tb tc td'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!TraitFileOutTest methodsFor: 'running' stamp: 'al 4/25/2004 16:29'!
categoryName
	^'Traits-Tests-FileOut'! !

!TraitFileOutTest methodsFor: 'running' stamp: 'al 4/25/2004 13:26'!
setUp
	super setUp.
	SystemOrganization addCategory: self categoryName.
	
	td _ self createTraitNamed: #TD uses: {}.		
	td compile: 'd' classified: #cat1.
	tc _ self createTraitNamed: #TC uses: td.		
	tc compile: 'c' classified: #cat1.
	tb _ self createTraitNamed: #TB uses: td.		
	tb compile: 'b' classified: #cat1.
	ta _ self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}.
	ta compile: 'a' classified: #cat1.
	
	ca _ self createClassNamed: #CA superclass: Object uses: {}.
	ca compile: 'ca' classified: #cat1.
	cb _ self createClassNamed: #CB superclass: ca uses: ta.
	cb compile: 'cb' classified: #cat1.
	
	"make the class of cb also use tc:"
	cb class uses: ta classTrait + tc instanceVariableNames: ''.! !

!TraitFileOutTest methodsFor: 'running' stamp: 'dvf 8/30/2005 15:07'!
tearDown
	| dir |
	dir := FileDirectory default.
	self createdClassesAndTraits, self resourceClassesAndTraits  do: [:each |
		dir deleteFileNamed: each asString , '.st' ifAbsent: []].
	dir deleteFileNamed: self categoryName , '.st' ifAbsent: [].
	SystemOrganization removeSystemCategory: self categoryName.
	super tearDown! !


!TraitFileOutTest methodsFor: 'testing' stamp: 'al 7/19/2004 20:50'!
testFileOutCategory
	"File out whole system category, delete all classes and traits and then
	file them in again."

	"self run: #testFileOutCategory"

	| file |
	SystemOrganization fileOutCategory: self categoryName.
	SystemOrganization removeSystemCategory: self categoryName.
	self deny: (Smalltalk keys includesAnyOf: #(CA CB TA TB TC TD)).
	[	file _ FileStream readOnlyFileNamed: self categoryName , '.st'.
		file fileIn]
		ensure: [file close].

	self assert: (Smalltalk keys includesAllOf: #(CA CB TA TB TC TD)).

	ta _ Smalltalk at: #TA.
	self assert: ta traitComposition asString = 'TB + TC @ {#cc->#c} - {#c}'.
	self assert: (ta methodDict keys includesAllOf: #(a b cc)).

	cb _ Smalltalk at: #CB.
	self assert: cb traitComposition asString = 'TA'.
	self assert: (cb methodDict keys includesAllOf: #(cb a b cc)).

	"test classSide traitComposition of CB"

	self assert: cb classSide traitComposition asString =  'TA classTrait + TC'.
	self assert: (cb classSide methodDict keys includesAllOf: #(d c))
	! !

!TraitFileOutTest methodsFor: 'testing' stamp: 'al 12/1/2005 16:30'!
testFileOutTrait
	"fileOut trait T6, remove it from system and then file it in again"

	"self run: #testFileOutTrait"

	| fileName file |
	self t6 compile: 'localMethod: argument ^argument'.
	self t6 classSide compile: 'localClassSideMethod: argument ^argument'.
	self t6 fileOut.
	fileName := self t6 asString , '.st'.
	self resourceClassesAndTraits remove: self t6.
	self t6 removeFromSystem.
	
	[file := FileStream readOnlyFileNamed: fileName.
	file fileIn] 
			ensure: [file close].
	self assert: (Smalltalk includesKey: #T6).
	TraitsResource current t6: (Smalltalk at: #T6).
	self resourceClassesAndTraits add: self t6.
	self 
		assert: self t6 traitComposition asString = 'T1 + T2 @ {#m22Alias->#m22}'.
	self 
		assert: (self t6 methodDict keys includesAllOf: #(
						#localMethod:
						#m11
						#m12
						#m13
						#m21
						#m22
						#m22Alias
					)).
	self assert: self t6 classSide methodDict size = 2.
	self 
		assert: (self t6 classSide methodDict keys includesAllOf: #(#localClassSideMethod: #m2ClassSide: ))! !

!TraitFileOutTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testRemovingMethods
	"When removing a local method, assure that the method
	from the trait is installed instead and that the users are 
	updated."

	"self run: #testRemovingMethods"

	"Classes"

	self c2 compile: 'm12 ^0' classified: #xxx.
	self assert: (self c2 includesLocalSelector: #m12).
	self c2 removeSelector: #m12.
	self deny: (self c2 includesLocalSelector: #m12).
	self assert: (self c2 selectors includes: #m12).

	"Traits"
	self t5 compile: 'm12 ^0' classified: #xxx.
	self assert: self c2 new m12 = 0.
	self t5 removeSelector: #m12.
	self deny: (self t5 includesLocalSelector: #m12).
	self assert: (self t5 selectors includes: #m12).
	self assert: self c2 new m12 = 12! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitFileOutTest class
	instanceVariableNames: ''!
Object subclass: #TraitMethodDescription
	instanceVariableNames: 'selector locatedMethods'
	classVariableNames: 'ConflictMethods RequiredMethods'
	poolDictionaries: ''
	category: 'Traits-Composition'!
!TraitMethodDescription commentStamp: '<historical>' prior: 0!
Used by TraitComposition to encapsulates a collection of methods for one particular selector when querying for changes. According to the number and kind of those methods a provided method exists, there is a conflict or there are no provided nor conflicting methods at all. I provide the interface to query for those situations, e.g., effectiveMethod returns the provided method or the conflict marker method.
!


!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 10:20'!
addLocatedMethod: aLocatedMethod
	locatedMethods add: aLocatedMethod! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 7/25/2004 21:21'!
conflictMethod
	| templateMethod argumentNames binary numberOfArguments |
	self isConflict ifFalse: [^nil].
	argumentNames _ self getArgumentNames.
	binary _ self isBinarySelector.
	numberOfArguments _ binary
		ifTrue: [1]
		ifFalse: [argumentNames size + 2].
	templateMethod _ self conflictMethodForArguments: numberOfArguments ifAbsentPut: [
		self
			generateTemplateMethodWithMarker: CompiledMethod conflictMarker
			forArgs: argumentNames size
			binary: binary].
	^templateMethod copyWithTempNames: argumentNames
	
	
 ! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'NS 4/19/2004 16:13'!
effectiveMethod
	"Return the effective compiled method of this method description." 

	| locatedMethod method |
	method _ self providedMethod.
	method isNil ifFalse: [^ method].
	method _ self conflictMethod.
	method isNil ifFalse: [^ method].
	^ self requiredMethod.! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'NS 4/16/2004 15:06'!
effectiveMethodCategory
	^ self effectiveMethodCategoryCurrent: nil new: nil! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 7/22/2004 14:50'!
effectiveMethodCategoryCurrent: currentCategoryOrNil new: newCategoryOrNil
	| isCurrent result cat size isConflict |
	size _ self size.
	size = 0 ifTrue: [^ nil].
	result _ self locatedMethods anyOne category.
	size = 1 ifTrue: [^ result].
	
	isCurrent _ currentCategoryOrNil isNil.
	isConflict _ false.
	self locatedMethods do: [:each |
		cat _ each category.
		isCurrent _ isCurrent or: [cat == currentCategoryOrNil].
		isConflict _ isConflict or: [cat ~~ result]].
	isConflict ifFalse: [^ result].
	(isCurrent not and: [newCategoryOrNil notNil]) ifTrue: [^ newCategoryOrNil].
	^ ClassOrganizer ambiguous.! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 10:20'!
locatedMethods
	^locatedMethods! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 7/21/2004 21:17'!
providedLocatedMethod
	| locatedMethod |
	locatedMethod _ nil.
	self locatedMethods do: [:each |
		each method isProvided ifTrue: [
			locatedMethod isNil ifFalse: [^nil].
			locatedMethod _ each]].
	^locatedMethod! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 7/21/2004 21:26'!
providedMethod
	^self providedLocatedMethod ifNotNilDo: [:locatedMethod | locatedMethod method]! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 7/25/2004 21:39'!
requiredMethod
	| templateMethod argumentNames numberOfArguments binary |
	self isRequired ifFalse: [^nil].
	self size = 1 ifTrue: [^self locatedMethods anyOne method].
	
	argumentNames _ self getArgumentNames.
	binary _ self isBinarySelector.
	numberOfArguments _ binary
		ifTrue: [1]
		ifFalse: [argumentNames size + 2].
	templateMethod _ self requiredMethodForArguments: numberOfArguments ifAbsentPut: [
		self
			generateTemplateMethodWithMarker: CompiledMethod implicitRequirementMarker
			forArgs: argumentNames size
			binary: binary].
	^templateMethod copyWithTempNames: argumentNames
	
	
 ! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 10:19'!
selector
	^selector! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 10:19'!
selector: aSymbol 
	selector _ aSymbol! !

!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 12:54'!
size
	^self locatedMethods size! !


!TraitMethodDescription methodsFor: 'enumeration' stamp: 'al 7/22/2004 14:50'!
methodsDo: aBlock
	self locatedMethods do: [:each |
		aBlock value: each method]! !


!TraitMethodDescription methodsFor: 'initialize-release' stamp: 'NS 3/30/2004 16:12'!
initialize
	super initialize.
	locatedMethods _ Set new! !


!TraitMethodDescription methodsFor: 'testing' stamp: 'al 4/10/2004 23:29'!
isAliasSelector
	"Return true if the selector is an alias (if it is different
	from the original selector) or already an aliased method
	in the original location (recursively search the compositions).
	Return false, if not or if we have a conflict."
	
	| locatedMethod |
	^self size = 1 and: [
		locatedMethod _ self locatedMethods anyOne.
		(locatedMethod selector ~= self selector) or: [
			locatedMethod location isAliasSelector: self selector]]! !

!TraitMethodDescription methodsFor: 'testing' stamp: 'al 2/20/2004 22:18'!
isBinarySelector
	^self locatedMethods anyOne
		isBinarySelector! !

!TraitMethodDescription methodsFor: 'testing' stamp: 'al 1/23/2004 10:30'!
isConflict
	| count |
	count _ 0.
	self methodsDo: [:each |
		each isProvided ifTrue: [
			count _ count + 1.
			count > 1 ifTrue: [^true]]].
	^false! !

!TraitMethodDescription methodsFor: 'testing' stamp: 'al 1/23/2004 10:31'!
isEmpty
	^self size = 0! !

!TraitMethodDescription methodsFor: 'testing' stamp: 'al 4/10/2004 23:34'!
isLocalAliasSelector
	"Return true if the selector is an alias (if it is different
	from the original selector). Return false, if not or if we
	have a conflict."
	
	^self size = 1 and: [
		(self locatedMethods anyOne selector ~= self selector)]! !

!TraitMethodDescription methodsFor: 'testing' stamp: 'NS 4/19/2004 16:10'!
isProvided
	^ self providedMethod notNil! !

!TraitMethodDescription methodsFor: 'testing' stamp: 'NS 4/21/2004 12:29'!
isRequired
	self isEmpty ifTrue: [^ false].
	^ self locatedMethods allSatisfy: [:each | each method isRequired]! !


!TraitMethodDescription methodsFor: 'private' stamp: 'al 7/25/2004 21:20'!
conflictMethodForArguments: aNumber ifAbsentPut: aBlock
	"ConflictMethods is an array that caches the generated conflict
	methods. At position 1: binary method; 2: unary method;
	n+2: keywordmethod with n arguments." 

	^(ConflictMethods at: aNumber)
		ifNil: [ConflictMethods at: aNumber put: aBlock value]! !

!TraitMethodDescription methodsFor: 'private' stamp: 'md 2/13/2006 14:36'!
generateTemplateMethodWithMarker: aSymbol forArgs: aNumber binary: aBoolean
	| source node |
	source _ String streamContents: [:stream |
		aNumber < 1
			ifTrue: [stream nextPutAll: 'selector']
			ifFalse: [aBoolean
				ifTrue: [
					stream nextPutAll: '* anObject']
				ifFalse: [
					1 to: aNumber do: [:argumentNumber |
						stream
							nextPutAll: 'with:'; space;
							nextPutAll: 'arg'; nextPutAll: argumentNumber asString; space]]].
		stream cr; tab; nextPutAll: 'self '; nextPutAll: aSymbol].
	node _ self class compilerClass new
		compile: source
		in: self class
		notifying: nil
		ifFail: [].
	^node generate.! !

!TraitMethodDescription methodsFor: 'private' stamp: 'al 3/12/2004 17:04'!
getArgumentNames
	| argumentNamesCollection names defaultName |
	defaultName _ 'arg'.
	argumentNamesCollection _ self locatedMethods
		collect: [:each | each argumentNames ].
	names _ Array new: argumentNamesCollection anyOne size.
	argumentNamesCollection do: [:collection |
		1 to: names size do: [:index |
			(names at: index) isNil
				ifTrue: [names at: index put: (collection at: index)]
				ifFalse: [(names at: index) ~= (collection at: index)
					ifTrue: [names at: index put: defaultName, index asString]]]].
	^names
		! !

!TraitMethodDescription methodsFor: 'private' stamp: 'al 7/25/2004 21:37'!
requiredMethodForArguments: aNumber ifAbsentPut: aBlock
	"ConflictMethods is an array that caches the generated conflict
	methods. At position 1: binary method; 2: unary method;
	n+2: keywordmethod with n arguments." 

	^(RequiredMethods at: aNumber)
		ifNil: [ConflictMethods at: aNumber put: aBlock value]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitMethodDescription class
	instanceVariableNames: ''!

!TraitMethodDescription class methodsFor: 'class initialization' stamp: 'NS 4/19/2004 16:26'!
initialize
	"	self initialize	"
	ConflictMethods _ Array new: self maxArguments + 2.
	RequiredMethods _ Array new: self maxArguments + 2.! !


!TraitMethodDescription class methodsFor: 'instance creation' stamp: 'al 1/23/2004 12:52'!
new
	^super new
		initialize;
		yourself! !

!TraitMethodDescription class methodsFor: 'instance creation' stamp: 'al 1/23/2004 13:04'!
selector: aSymbol
	^self new
		selector: aSymbol
		yourself! !


!TraitMethodDescription class methodsFor: 'private' stamp: 'NS 4/19/2004 16:26'!
maxArguments
	^30! !
TraitsTestCase subclass: #TraitMethodDescriptionTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:31'!
testArgumentNames
	self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'.
	self t2 compile: 'zork1: myArgument zork2: somethingElse ^false'.
	self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 
				beginsWith: 'zork1: myArgument zork2: arg2').
	self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'.
	self t2 compile: 'zork1: somethingElse zork2: myArgument ^false'.
	self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 
				beginsWith: 'zork1: arg1 zork2: arg2')! !

!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:33'!
testCategories
	self assert: (self t4 organization categoryOfElement: #m21) = #cat1.
	self assert: (self t4 organization categoryOfElement: #m22) = #cat2.
	self assert: (self t4 organization categoryOfElement: #m11) = #catX.
	self assert: (self t4 organization categoryOfElement: #m12) = #cat2.
	self assert: (self t4 organization categoryOfElement: #m13) = #cat3.
	self assert: (self t6 organization categoryOfElement: #m22Alias) = #cat2.
	self t2 organization classify: #m22 under: #catX.
	self assert: (self t4 organization categoryOfElement: #m22) = #catX.
	self assert: (self t6 organization categoryOfElement: #m22Alias) = #catX.
	self t6 organization classify: #m22 under: #catY.
	self t6 organization classify: #m22Alias under: #catY.
	self t2 organization classify: #m22 under: #catZ.
	self assert: (self t6 organization categoryOfElement: #m22) = #catY.
	self assert: (self t6 organization categoryOfElement: #m22Alias) = #catY.
	self t1 compile: 'mA' classified: #catA.
	self assert: (self t4 organization categoryOfElement: #mA) = #catA.
	self t1 organization classify: #mA under: #cat1.
	self assert: (self t4 organization categories includes: #catA) not! !

!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:31'!
testConflictingCategories
	| t7 t8 |
	self t2 compile: 'm11' classified: #catY.
	self assert: (self t4 organization categoryOfElement: #m11) = #catX.
	self assert: (self t5 organization categoryOfElement: #m11) = #cat1.
	t7 := self createTraitNamed: #T7 uses: self t1 + self t2.
	self assert: (t7 organization categoryOfElement: #m11) 
				= ClassOrganizer ambiguous.
	self t1 removeSelector: #m11.
	self assert: (self t4 organization categoryOfElement: #m11) = #catX.
	self assert: (self t5 organization categoryOfElement: #m11) = #catY.
	self assert: (t7 organization categoryOfElement: #m11) = #catY.
	self 
		assert: (t7 organization categories includes: ClassOrganizer ambiguous) not.
	self t1 compile: 'm11' classified: #cat1.
	t8 := self createTraitNamed: #T8 uses: self t1 + self t2.
	t8 organization classify: #m11 under: #cat1.
	self t1 organization classify: #m11 under: #catZ.
	self assert: (self t4 organization categoryOfElement: #m11) = #catX.
	self assert: (self t5 organization categoryOfElement: #m11) = #catY.
	self assert: (t8 organization categoryOfElement: #m11) = #catZ! !

!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:32'!
testConflictMethodCreation
	"Generate conflicting methods between t1 and t2
	and check the resulting method in Trait t5 (or c2).
	Also test selectors like foo:x (without space) or selectors with CRs."

	"unary"

	self t2 compile: 'm12 ^false'.
	self assert: ((self t5 sourceCodeAt: #m12) asString beginsWith: 'm12').
	self should: [self c2 new m12] raise: Error.

	"binary"
	self t1 compile: '@ myArgument ^true'.
	self t2 compile: '@myArgument ^false'.
	self 
		assert: ((self t5 sourceCodeAt: #@) asString beginsWith: '@ myArgument').
	self should: [self c2 new @ 17] raise: Error.

	"keyword"
	self t1 compile: 'zork: myArgument
		^true'.
	self t2 compile: 'zork: myArgument ^false'.
	self assert: ((self t5 sourceCodeAt: #zork:) asString 
				beginsWith: 'zork: myArgument').
	self should: [self c2 new zork: 17] raise: Error.
	self t1 compile: 'zork:myArgument ^true'.
	self t2 compile: 'zork:myArgument ^false'.
	self assert: ((self t5 sourceCodeAt: #zork:) asString 
				beginsWith: 'zork: myArgument').
	self should: [self c2 new zork: 17] raise: Error.
	self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'.
	self t2 compile: 'zork1: anObject zork2: anotherObject ^false'.
	self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 
				beginsWith: 'zork1: arg1 zork2: arg2').
	self should: [self c2 new zork1: 1 zork2: 2] raise: Error! !

!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'al 1/23/2004 12:57'!
testInitialize
	| empty |
	empty _ TraitMethodDescription new.
	self assert: empty isEmpty.
	self deny: empty isConflict.
	self deny: empty isProvided.
	self deny: empty isRequired! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitMethodDescriptionTest class
	instanceVariableNames: ''!
TraitsTestCase subclass: #TraitTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testAddAndRemoveMethodsFromSubtraits
	| aC2 |
	aC2 := self c2 new.
	self assert: aC2 m51.
	self t5 removeSelector: #m51.
	self should: [aC2 m51] raise: MessageNotUnderstood.
	self t1 compile: 'foo ^true'.
	self deny: aC2 foo.
	self t1 compile: 'm51 ^self'.
	self shouldnt: [aC2 m51] raise: MessageNotUnderstood.
	self assert: aC2 m51 == aC2! !

!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testAddAndRemoveMethodsInClassOrTrait
	| aC2 |
	aC2 := self c2 new.
	self assert: aC2 m51.
	self c2 compile: 'm51 ^123'.
	self assert: aC2 m51 = 123.
	self c2 removeSelector: #m51.
	self shouldnt: [aC2 m51] raise: MessageNotUnderstood.
	self assert: aC2 m51.
	self t4 removeSelector: #m11.
	self assert: (self t4 methodDict includesKey: #m11)! !

!TraitTest methodsFor: 'testing' stamp: 'dvf 8/30/2005 14:10'!
testCompositionCopy
	| t6compositionCopyFirst c2compositionCopy |
	self assert: (self t1 + self t2) allTraits 
				= (self t1 + self t2) copyTraitExpression allTraits.
	self assert: (self t1 classTrait + self t2 classTrait) allTraits 
				= (self t1 classTrait + self t2 classTrait) copyTraitExpression allTraits.
	self assert: self t6 traitComposition allTraits 
				= self t6 traitComposition copyTraitExpression allTraits.
	self 
		assert: self t6 asTraitComposition copyTraitExpression allTraits = { (self t1). (self t2). (self t6) }.
	"make no undue sharing happens of exclusions and aliases after an expression copy"
	t6compositionCopyFirst := self t6 traitComposition copyTraitExpression.
	t6compositionCopyFirst transformations at: 1 put: #m22Alias -> #m33.
	self 
		assert: self t6 traitComposition transformations second aliases first value 
				= #m22.
	c2compositionCopy := self c2 traitComposition copyTraitExpression.
	c2compositionCopy transformations first exclusions at: 1 put: #m4.
	self c2 traitComposition transformations first exclusions = #(#m11 )! !

!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testExplicitRequirement
	"self run: #testExplicitRequirement"

	self t1 compile: 'm self explicitRequirement'.
	self t2 compile: 'm ^true'.
	self assert: self t4 >> #m == (self t2 >> #m).
	self assert: self c2 new m.
	self t2 removeSelector: #m.
	self assert: self t5 >> #m == (self t1 >> #m).
	self should: [self c2 new m] raise: Error! !

!TraitTest methodsFor: 'testing' stamp: 'al 10/16/2005 14:55'!
testLocalMethodWithSameCodeInTrait
	"Note, takes all behaviors (classes and traits) into account"

	SystemNavigation default allBehaviorsDo: [ :each |
		each hasTraitComposition ifTrue: [
			each methodDict keys do: [ :selector |
				(each includesLocalSelector: selector) ifTrue: [
					(each traitComposition traitProvidingSelector: selector) ifNotNilDo: [ :trait |
						self deny: (trait >> selector = (each >> selector)) ] ] ] ] ].! !

!TraitTest methodsFor: 'testing' stamp: 'al 2/13/2006 17:41'!
testMarkerMethods
	"self debug: #testMarkerMethods"

	self t1 compile: 'm1 self foo bar'.
	self assert: (self t1 >> #m1) markerOrNil isNil.


	self t1 compile: 'm2 self requirement'.
	self assert: (self t1 >> #m2) markerOrNil == #requirement.
	
	self t1 compile: 'm3 ^self requirement'.
	self assert: (self t1 >> #m3) markerOrNil == #requirement.! !

!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:33'!
testPrinting
	self assertPrints: self t6 definitionST80
		like: 'Trait named: #T6
	uses: T1 + T2 @ {#m22Alias->#m22}
	category: ''Traits-Tests'''! !

!TraitTest methodsFor: 'testing' stamp: 'al 10/16/2005 15:07'!
testPrintingClassSide
	"self run: #testPrintingClassSide"
	
	self assertPrints: self t6 classSide definitionST80
		like: 'T6 classTrait
	uses: T1 classTrait + T2 classTrait'! !

!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:31'!
testRemoveFromSystem
	self t4 removeFromSystem.
	self deny: (Smalltalk includesKey: #T4).
	self assert: self t4 name = 'AnObsoleteT4'.
	self assert: self t4 methodDict isEmpty.
	self deny: (self t1 users includes: self t4)! !

!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'!
testRequirement
	"self run: #testRequirement"

	self t1 compile: 'm self requirement'.
	self t2 compile: 'm ^true'.
	self assert: self t4 >> #m == (self t2 >> #m).
	self assert: self c2 new m.
	self t2 removeSelector: #m.
	self assert: self t5 >> #m == (self t1 >> #m).
	self should: [self c2 new m] raise: Error! !

!TraitTest methodsFor: 'testing' stamp: 'dvf 8/30/2005 14:55'!
testUsers
	self assert: self t1 users size = 3.
	self assert: (self t1 users includesAllOf: {self t4. self t5. self t6 }).
	self assert: self t3 users isEmpty.
	self assert: self t5 users size = 1.
	self assert: self t5 users anyOne = self c2.
	self c2 setTraitCompositionFrom: self t1 + self t5.
	self assert: self t5 users size = 1.
	self assert: self t5 users anyOne = self c2.
	self c2 setTraitComposition: self t2 asTraitComposition.
	self assert: self t5 users isEmpty! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitTest class
	instanceVariableNames: ''!
Object subclass: #TraitTransformation
	uses: TComposingDescription
	instanceVariableNames: 'subject'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Composition'!
!TraitTransformation commentStamp: 'apb 8/25/2005 11:54' prior: 0!
A trait transformation is an instance of one of my concrete subclasses, TraitAlias or TraitExclusion. These represent a transformation of a trait, specified by the alias and exclusion operators. 

I define an instance variable named subject which holds the object that is transformed.  Thus, an alias transformation has as its subject a trait, and a trait exclusion has as its subject either a trait alias or a trait. Each of the concrete transformation classes implement the method allSelectors according to the transformation it represents. 

(There was formerly a subclass called TraitHolder, which was the identity transformation and which did not modify the trait.  This was clearly redundant, and was removed.)!


!TraitTransformation methodsFor: 'accessing' stamp: 'al 4/10/2004 00:06'!
normalized
	^self isEmpty
		ifFalse: [
			self subject: self subject normalized.
			self]
		ifTrue: [self subject normalized]
		
		! !

!TraitTransformation methodsFor: 'accessing' stamp: 'NS 12/11/2003 15:13'!
subject
	^subject! !

!TraitTransformation methodsFor: 'accessing' stamp: 'al 4/9/2004 18:23'!
subject: aTraitTransformation
	subject _ aTraitTransformation! !


!TraitTransformation methodsFor: 'accessing parallel hierarchy' stamp: 'dvf 8/18/2005 18:29'!
isMeta
	^self subject isMeta! !

!TraitTransformation methodsFor: 'accessing parallel hierarchy' stamp: 'dvf 8/18/2005 18:28'!
theNonMetaClass 
	^ self subject theNonMetaClass  ! !


!TraitTransformation methodsFor: 'browser support' stamp: 'dvf 8/18/2005 18:31'!
sourceCodeTemplate
	^ self subject sourceCodeTemplate! !


!TraitTransformation methodsFor: 'composition' stamp: 'al 4/9/2004 17:01'!
addExclusionOf: aSymbol
	^self - {aSymbol}! !

!TraitTransformation methodsFor: 'composition' stamp: 'al 4/10/2004 23:48'!
removeAlias: aSymbol
	self subject removeAlias: aSymbol! !

!TraitTransformation methodsFor: 'composition' stamp: 'al 12/7/2005 21:19'!
- anArray
	TraitCompositionException signal: 'Invalid trait exclusion. Exclusions have to be specified after aliases.'! !

!TraitTransformation methodsFor: 'composition' stamp: 'al 12/7/2005 21:20'!
@ anArrayOfAssociations
	TraitCompositionException signal: 'Invalid trait exclusion. Aliases have to be specified before exclusions.'! !



!TraitTransformation methodsFor: 'copying' stamp: 'apb 8/24/2005 17:13'!
copy
	self error: 'should not be called'.
	^super copy
		subject: self subject copy;
		yourself! !

!TraitTransformation methodsFor: 'copying' stamp: 'dvf 8/25/2005 16:06'!
copyTraitExpression
	^self shallowCopy 
		subject: self subject copyTraitExpression;
		yourself! !


!TraitTransformation methodsFor: 'enquiries' stamp: 'al 3/11/2004 21:49'!
aliasesForSelector: aSymbol
	"Return a collection of alias selectors that are defined in this transformation."
	
	^self subject aliasesForSelector: aSymbol! !

!TraitTransformation methodsFor: 'enquiries' stamp: 'NS 4/16/2004 13:40'!
allAliasesDict
	"Return a dictionary with all alias associations that are defined in this transformation."
	
	^self subject allAliasesDict! !

!TraitTransformation methodsFor: 'enquiries' stamp: 'al 3/7/2004 22:36'!
allSelectors
	^self subclassResponsibility! !

!TraitTransformation methodsFor: 'enquiries' stamp: 'NS 4/16/2004 14:20'!
changedSelectorsComparedTo: aTraitTransformation
	| selectors otherSelectors changedSelectors aliases otherAliases |
	selectors _ self allSelectors asIdentitySet.
	otherSelectors _ aTraitTransformation allSelectors asIdentitySet.
	changedSelectors _ IdentitySet withAll: (
		(selectors difference: otherSelectors) union: (otherSelectors difference: selectors)).
	aliases _ self allAliasesDict.
	otherAliases _ aTraitTransformation allAliasesDict.
	aliases keysAndValuesDo: [:key :value |
		(value ~~ (otherAliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]].
	otherAliases keysAndValuesDo: [:key :value |
		(value ~~ (aliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]].
	^ changedSelectors.! !

!TraitTransformation methodsFor: 'enquiries' stamp: 'al 3/6/2004 18:51'!
collectMethodsFor: aSelector into: methodDescription
	"Collect instances of LocatedMethod into methodDescription
	for each method that has the selector aSelector and is not excluded
	or for which aSelector is an alias."

	self subclassResponsibility! !

!TraitTransformation methodsFor: 'enquiries' stamp: 'dvf 8/18/2005 18:39'!
selectors
	^self allSelectors! !

!TraitTransformation methodsFor: 'enquiries' stamp: 'al 12/12/2003 18:00'!
trait
	^self subject trait! !

!TraitTransformation methodsFor: 'enquiries' stamp: 'dvf 8/16/2005 17:35'!
traitTransformations 
	^ { subject }! !


!TraitTransformation methodsFor: 'printing' stamp: 'al 12/12/2003 18:29'!
printOn: aStream
	aStream print: self subject! !


!TraitTransformation methodsFor: 'testing' stamp: 'al 4/10/2004 23:56'!
isEmpty
	self subclassResponsibility! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitTransformation class
	uses: TComposingDescription classTrait
	instanceVariableNames: ''!
TestResource subclass: #TraitsResource
	instanceVariableNames: 'createdClassesAndTraits t1 t2 t3 t4 t5 t6 c1 c2 c3 c4 c5 c6 c7 c8 dirty'
	classVariableNames: 'SetUpCount'
	poolDictionaries: ''
	category: 'Traits-Tests'!

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c1
	^c1! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c1: anObject
	^c1 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c2
	^c2! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c2: anObject
	^c2 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c3
	^c3! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c3: anObject
	^c3 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c4
	^c4! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c4: anObject
	^c4 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c5
	^c5! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c5: anObject
	^c5 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c6
	^c6! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c6: anObject
	^c6 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c7
	^c7! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'!
c7: anObject
	^c7 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:01'!
c8
	^c8! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:01'!
c8: anObject
	^c8 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 15:19'!
isDirty
	^dirty! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 15:19'!
setDirty
	dirty := true! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:58'!
t1
	^t1! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:58'!
t1: anObject
	^t1 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t2
	^t2! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t2: anObject
	^t2 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t3
	^t3! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t3: anObject
	^t3 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t4
	^t4! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t4: anObject
	^t4 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t5
	^t5! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t5: anObject
	^t5 := anObject! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t6
	^t6! !

!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'!
t6: anObject
	^t6 := anObject! !


!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:47'!
categoryName
	^self class category! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'al 10/10/2005 10:37'!
codeChangedEvent: anEvent

	(anEvent isDoIt not
		and: [anEvent itemClass notNil]
		and: [self createdClassesAndTraits includes: anEvent itemClass instanceSide]) ifTrue: [self setDirty] ! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:47'!
createClassNamed: aSymbol superclass: aClass uses: aTraitComposition
	| class |
	class := aClass
		subclass: aSymbol
		uses: aTraitComposition
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''		
		category: self categoryName.
	self createdClassesAndTraits add: class.
	^class! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:47'!
createdClassesAndTraits
	createdClassesAndTraits ifNil: [
		createdClassesAndTraits := OrderedCollection new].
	^createdClassesAndTraits! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:47'!
createTraitNamed: aSymbol uses: aTraitComposition
	| trait |
	trait := Trait
		named: aSymbol
		uses: aTraitComposition
		category: self categoryName.
	self createdClassesAndTraits add: trait.
	^trait! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'al 9/16/2005 11:52'!
setUp
	"Please note, that most tests rely on this setup of traits and
	classes - and that especially the order of the definitions matters."
	"SetUpCount := SetUpCount + 1."

	dirty := false.
	SystemChangeNotifier uniqueInstance doSilently: 
			[self t1: (self createTraitNamed: #T1
						uses: { }).
			self t1 comment: 'I am the trait T1'.
			self t2: (self createTraitNamed: #T2
						uses: { }).
			self t2 compile: 'm21 ^21' classified: #cat1.
			self t2 compile: 'm22 ^22' classified: #cat2.
			self t2 classSide compile: 'm2ClassSide: a ^a'.
			self t3: (self createTraitNamed: #T3
						uses: { }).
			self t3 compile: 'm31 ^31' classified: #cat1.
			self t3 compile: 'm32 ^32' classified: #cat2.
			self t3 compile: 'm33 ^33' classified: #cat3.
			self t4: (self createTraitNamed: #T4
						uses: { (self t1). (self t2) }).
			self t4 compile: 'm11 ^41' classified: #catX.	"overrides T1>>m11"
			self t4 compile: 'm42 ^42' classified: #cat2.
			self t5: (self createTraitNamed: #T5 uses: self t1 + self t2).
			self t5 compile: 'm51 ^super foo' classified: #cat1.
			self t5 compile: 'm52 ^ self class bar' classified: #cat1.
			self t5 compile: 'm53 ^ self class bar' classified: #cat1.
			self t6: (self createTraitNamed: #T6
						uses: (self t1 + self t2) @ { (#m22Alias -> #m22) }).
			self c1: (self 
						createClassNamed: #C1
						superclass: Object
						uses: { }).
			self c1 compile: 'foo ^true' classified: #accessing.
			self t1 compile: 'm11 ^11' classified: #cat1.
			self t1 compile: 'm12 ^12' classified: #cat2.
			self t1 compile: 'm13 ^self m12' classified: #cat3.
			self c2: (self 
						createClassNamed: #C2
						superclass: self c1
						uses: self t5 - { #m11 }).
			self c2 compile: 'foo ^false' classified: #private.
			self c2 compile: 'bar ^self foo' classified: #private.
			self setUpTrivialRequiresFixture.
			self setUpTwoLevelRequiresFixture.
			self setUpTranslatingRequiresFixture].
	SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #codeChangedEvent:! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 14:01'!
setUpTranslatingRequiresFixture
	self c6: (self 
				createClassNamed: #C6
				superclass: ProtoObject
				uses: { }).
	self c6 superclass: nil.
	self c7: (self 
				createClassNamed: #C7
				superclass: self c6
				uses: { }).
	self c8: (self 
				createClassNamed: #C8
				superclass: self c7
				uses: { }).
	self c6 compile: 'foo ^self x' classified: #accessing.
	self c7 compile: 'foo ^3' classified: #accessing.
	self c7 compile: 'bar ^super foo' classified: #accessing.
	self c8 compile: 'bar ^self blah' classified: #accessing! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 14:00'!
setUpTrivialRequiresFixture
	self c3: (self 
				createClassNamed: #C3
				superclass: ProtoObject
				uses: { }).
	self c3 superclass: nil.
	self c3 compile: 'foo ^self bla' classified: #accessing! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 14:00'!
setUpTwoLevelRequiresFixture
	self c4: (self 
				createClassNamed: #C4
				superclass: ProtoObject
				uses: { }).
	self c4 superclass: nil.
	self c5: (self 
				createClassNamed: #C5
				superclass: self c4
				uses: { }).
	self c4 compile: 'foo ^self blew' classified: #accessing.
	self c5 compile: 'foo ^self blah' classified: #accessing! !

!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 16:01'!
tearDown
	| behaviorName |
	SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self.
	self createdClassesAndTraits do: 
			[:aClassOrTrait | 
			behaviorName := aClassOrTrait name.
			Smalltalk at: behaviorName
				ifPresent: [:classOrTrait | classOrTrait removeFromSystem].
			ChangeSet current removeClassChanges: behaviorName].
	createdClassesAndTraits := self t1: (self 
						t2: (self t3: (self 
										t4: (self t5: (self 
														t6: (self c1: (self 
																		c2: (self c3: (self c4: (self c5: (self c6: (self c7: (self c8: nil)))))))))))))! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitsResource class
	instanceVariableNames: ''!

!TraitsResource class methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 16:57'!
resetIfDirty
	self current isDirty ifTrue: [self reset]! !
TestCase subclass: #TraitsTestCase
	instanceVariableNames: 'createdClassesAndTraits'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Traits-Tests'!

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
c1
	^TraitsResource current c1! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
c2
	^TraitsResource current c2! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
c3
	^TraitsResource current c3! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
c4
	^TraitsResource current c4! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
c5
	^TraitsResource current c5! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
c6
	^TraitsResource current c6! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
c7
	^TraitsResource current c7! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
c8
	^TraitsResource current c8! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
t1
	^TraitsResource current t1! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'!
t2
	^TraitsResource current t2! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:45'!
t3
	^TraitsResource current t3! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:45'!
t4
	^TraitsResource current t4! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:45'!
t5
	^TraitsResource current t5! !

!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:45'!
t6
	^TraitsResource current t6! !


!TraitsTestCase methodsFor: 'running' stamp: 'al 4/25/2004 16:31'!
categoryName
	^self class category! !

!TraitsTestCase methodsFor: 'running' stamp: 'dvf 8/30/2005 16:58'!
tearDown
	| behaviorName |
	TraitsResource resetIfDirty.
	self createdClassesAndTraits do: 
			[:aClassOrTrait | 
			behaviorName := aClassOrTrait name.
			Smalltalk at: behaviorName
				ifPresent: [:classOrTrait | classOrTrait removeFromSystem].
			ChangeSet current removeClassChanges: behaviorName].
	createdClassesAndTraits := nil! !


!TraitsTestCase methodsFor: 'testing-applying trait composition' stamp: 'al 9/19/2005 12:19'!
testChangeSuperclass
	"self run: #testChangeSuperclass"

	"Test that when the superclass of a class is changed the non-local methods
	of the class sending super are recompiled to correctly store the new superclass."

	| aC2 newSuperclass |
	aC2 := self c2 new.

	"C1 is current superclass of C2"
	self assert: aC2 m51.
	self assert: self c2 superclass == self c1.
	self deny: (self c2 localSelectors includes: #m51).

	"change superclass of C2 from C1 to X"
	newSuperclass := self createClassNamed: #X superclass: Object uses: {}.
	newSuperclass
		subclass: self c2 name
		uses: self c2 traitComposition
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: self c2 category.

	self assert: self c2 superclass == newSuperclass.

	newSuperclass compile: 'foo ^17'.
	self assert: aC2 m51 = 17.
	self deny: (self c2 localSelectors includes: #m51).

	self c2 compile: 'm51 ^19'.
	self assert: aC2 m51 = 19.

	self assert: self c2 >> #m52 == (self t5 >> #m52).

	
	! !


!TraitsTestCase methodsFor: 'utility' stamp: 'al 12/16/2003 22:16'!
assertPrints: aString like: anotherString 
	self assert: (aString copyWithout: $ )
		= (anotherString copyWithout: $ )! !

!TraitsTestCase methodsFor: 'utility' stamp: 'dvf 8/30/2005 14:44'!
createClassNamed: aSymbol superclass: aClass uses: aTraitComposition
	| class |
	class := aClass
		subclass: aSymbol
		uses: aTraitComposition
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''		
		category: self categoryName.
	self createdClassesAndTraits add: class.
	^class! !

!TraitsTestCase methodsFor: 'utility' stamp: 'dvf 8/30/2005 14:44'!
createdClassesAndTraits
	createdClassesAndTraits ifNil: [
		createdClassesAndTraits := OrderedCollection new].
	^createdClassesAndTraits! !

!TraitsTestCase methodsFor: 'utility' stamp: 'dvf 8/30/2005 14:44'!
createTraitNamed: aSymbol uses: aTraitComposition
	| trait |
	trait := Trait
		named: aSymbol
		uses: aTraitComposition
		category: self categoryName.
	self createdClassesAndTraits add: trait.
	^trait! !

!TraitsTestCase methodsFor: 'utility' stamp: 'dvf 8/30/2005 14:49'!
resourceClassesAndTraits
	^TraitsResource current createdClassesAndTraits! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TraitsTestCase class
	instanceVariableNames: ''!

!TraitsTestCase class methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:41'!
resources
	^{TraitsResource}! !
WriteStream subclass: #TranscriptStream
	instanceVariableNames: ''
	classVariableNames: 'AccessSema'
	poolDictionaries: ''
	category: 'Collections-Streams'!
!TranscriptStream commentStamp: '<historical>' prior: 0!
This class is a much simpler implementation of Transcript protocol that supports multiple views and very simple conversion to morphic.  Because it inherits from Stream, it is automatically compatible with code that is designe to write to streams.!


!TranscriptStream methodsFor: 'access' stamp: 'di 3/16/1999 21:38'!
characterLimit
	"Tell the views how much to retain on screen"
	^ 20000! !


!TranscriptStream methodsFor: 'initialization' stamp: 'gm 2/16/2003 20:39'!
closeAllViews
	"Transcript closeAllViews"

	self dependents do: 
			[:d | 
			(d isKindOf: PluggableTextView) 
				ifTrue: [d topView controller closeAndUnscheduleNoTerminate].
			(d isSystemWindow) ifTrue: [d delete]]! !

!TranscriptStream methodsFor: 'initialization' stamp: 'di 5/8/1998 13:12'!
open
	| openCount |
	openCount _ 0.
	self dependents do:
		[:d | ((d isKindOf: PluggableTextView) or:
			[d isKindOf: PluggableTextMorph]) ifTrue: [openCount _ openCount + 1]].
	openCount = 0
		ifTrue: [self openLabel: 'Transcript']
		ifFalse: [self openLabel: 'Transcript #' , (openCount+1) printString]! !

!TranscriptStream methodsFor: 'initialization' stamp: 'sw 6/12/2001 13:06'!
openAsMorph
	"Answer a morph viewing this transcriptStream"

	^ (self openAsMorphLabel: 'Transcript') applyModelExtent! !

!TranscriptStream methodsFor: 'initialization' stamp: 'di 5/27/1998 16:36'!
openAsMorphLabel: labelString 
	"Build a morph viewing this transcriptStream"
	| window |
	window _ (SystemWindow labelled: labelString) model: self.
	window addMorph: (PluggableTextMorph on: self text: nil accept: nil
			readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0@0 corner: 1@1).
	^ window! !

!TranscriptStream methodsFor: 'initialization' stamp: 'sma 4/30/2000 10:16'!
openLabel: aString 
	"Open a window on this transcriptStream"

	| topView codeView |
	Smalltalk isMorphic ifTrue: [^ (self openAsMorphLabel: aString) openInWorld].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
	topView label: aString.
	topView minimumSize: 100 @ 50.

	codeView _ PluggableTextView on: self text: nil accept: nil
					readSelection: nil menu: #codePaneMenu:shifted:.
	codeView window: (0@0 extent: 200@200).
	topView addSubView: codeView.
	topView controller open! !


!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/27/1998 16:44'!
codePaneMenu: aMenu shifted: shifted
	"Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items"
	^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted
! !

!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/29/1998 17:13'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !

!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/3/1999 22:49'!
release

	self dependents do:
		[:view | (view isMorph and: [view isInWorld not])
					ifTrue: [self removeDependent: view]]! !

!TranscriptStream methodsFor: 'model protocol' stamp: 'sw 3/2/2001 10:18'!
step
	"Objects that may be models of SystemWindows need to respond to this, albeit vacuously"! !


!TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 3/15/2000 21:28'!
bs
	self position > 0 ifTrue: [^ self skip: -1].
	self changed: #bs! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'di 5/8/1998 12:35'!
clear
	"Clear all characters and redisplay the view"
	self changed: #clearText.
	self reset! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'mir 1/11/2000 11:41'!
endEntry
	"Display all the characters since the last endEntry, and reset the stream"
	self semaphore critical:[
		self changed: #appendEntry.
		self reset.
	].! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'md 8/2/2005 23:09'!
flush
	self endEntry
! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'di 5/8/1998 12:35'!
pastEndPut: anObject
	"If the stream reaches its limit, just output the contents and reset."
	self endEntry.
	^ self nextPut: anObject! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 2/26/2000 19:31'!
show: anObject  "TextCollector compatibility"
	self nextPutAll: anObject asString; endEntry! !


!TranscriptStream methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 20:36'!
buildWith: builder
	| windowSpec textSpec |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'Transcript'.
	windowSpec children: OrderedCollection new.

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self;
		menu: #codePaneMenu:shifted:;
		frame: (0@0corner: 1@1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !


!TranscriptStream methodsFor: 'private' stamp: 'mir 1/11/2000 11:41'!
semaphore
	^AccessSema ifNil:[AccessSema _ Semaphore forMutualExclusion]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TranscriptStream class
	instanceVariableNames: ''!

!TranscriptStream class methodsFor: 'as yet unclassified' stamp: 'di 5/8/1998 13:51'!
new
	^ self on: (String new: 1000)
"
INSTALLING:
TextCollector allInstances do:
	[:t | t breakDependents.
	t become: TranscriptStream new].

TESTING: (Execute this text in a workspace)
Do this first...
	tt _ TranscriptStream new.
	tt openLabel: 'Transcript test 1'.
Then this will open a second view -- ooooh...
	tt openLabel: 'Transcript test 2'.
And finally make them do something...
	tt clear.
	[Sensor anyButtonPressed] whileFalse:
		[1 to: 20 do: [:i | tt print: (2 raisedTo: i-1); cr; endEntry]].
"! !

!TranscriptStream class methodsFor: 'as yet unclassified' stamp: 'di 5/8/1998 12:44'!
newTranscript: aTextCollector 
	"Store aTextCollector as the value of the system global Transcript."
	Smalltalk at: #Transcript put: aTextCollector! !

!TranscriptStream class methodsFor: 'as yet unclassified' stamp: 'sw 1/29/2002 19:56'!
openMorphicTranscript
	"Have the current project's transcript open up as a morph"

	^ Transcript openAsMorph! !


!TranscriptStream class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:05'!
initialize

	self registerInFlapsRegistry.	! !

!TranscriptStream class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:06'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(TranscriptStream		openMorphicTranscript	'Transcript'			'A Transcript is a window usable for logging and debugging; browse references to #Transcript for examples of how to write to it.')
						forFlapNamed: 'Tools']
! !

!TranscriptStream class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:41'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!TranscriptStream class methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 18:10'!
buildWith: aBuilder
	^self new buildWith: aBuilder! !


!TranscriptStream class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:46'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Transcript' brightColor: #lightOrange pastelColor: #paleOrange helpMessage: 'The system transcript'! !
ReadWriteStream subclass: #Transcripter
	instanceVariableNames: 'frame para'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!Transcripter commentStamp: '<historical>' prior: 0!
Transcripter is a dog-simple scrolling stream with display.  It is intended to operate with no support from MVC or color in a minimal, or headless version of Squeak.  No attention has been paid to appearance or performance.!


!Transcripter methodsFor: 'accessing' stamp: 'di 8/14/97 12:41'!
clear
	Display fill: (frame insetBy: -2) fillColor: self black;
			fill: frame fillColor: self white.
	self on: (String new: 100); endEntry! !

!Transcripter methodsFor: 'accessing' stamp: 'di 8/14/97 12:44'!
endEntry
	| c d cb |
	c _ self contents.
	Display extent ~= DisplayScreen actualScreenSize ifTrue:
		["Handle case of user resizing physical window"
		DisplayScreen startUp.
		frame _ frame intersect: Display boundingBox.
		^ self clear; show: c].
	para setWithText: c asText
		style: TextStyle default
		compositionRectangle: ((frame insetBy: 4) withHeight: 9999)
		clippingRectangle: frame
		foreColor: self black backColor: self white.
	d _ para compositionRectangle bottom - frame bottom.
	d > 0 ifTrue:
		["Scroll up to keep all contents visible"
		cb _ para characterBlockAtPoint: para compositionRectangle topLeft
											+ (0@(d+para lineGrid)).
		self on: (c copyFrom: cb stringIndex to: c size).
		readLimit_ position_ collection size.
		^ self endEntry].
	para display! !

!Transcripter methodsFor: 'accessing' stamp: 'sma 2/26/2000 19:35'!
show: anObject
	self nextPutAll: anObject asString; endEntry! !


!Transcripter methodsFor: 'command line' stamp: 'di 8/12/97 22:11'!
confirm: queryString 
	| choice |
	[true]
		whileTrue: 
			[choice _ self request: queryString , '
Please type yes or no followed by return'.
			choice first asUppercase = $Y ifTrue: [^ true].
			choice first asUppercase = $N ifTrue: [^ false]]! !

!Transcripter methodsFor: 'command line' stamp: 'di 11/3/2000 18:52'!
readEvalPrint
	| line okToRevert |
	okToRevert _ true.
	[#('quit' 'exit' 'done' ) includes: (line _ self request: '>')]
		whileFalse:
		[line = 'revert'
		ifTrue: [okToRevert
			ifTrue: [Utilities revertLastMethodSubmission.
					self cr; show: 'reverted: ' , Utilities mostRecentlySubmittedMessage.
					okToRevert _ false]
			ifFalse: [self cr; show: 'Only one level of revert currently supported']]
		ifFalse: [self cr; show: ([Compiler evaluate: line] ifError: [:err :ex | err])]]! !

!Transcripter methodsFor: 'command line' stamp: 'sma 2/26/2000 19:39'!
request: prompt
	| startPos char contents | 
	self cr; show: prompt.
	startPos _ position.
	[[Sensor keyboardPressed] whileFalse.
	(char _ Sensor keyboard) = Character cr]
		whileFalse:
		[char = Character backspace
			ifTrue: [readLimit _ position _ (position - 1 max: startPos)]
			ifFalse: [self nextPut: char].
		self endEntry].
	contents _ self contents.
	^ contents copyFrom: startPos + 1 to: contents size! !


!Transcripter methodsFor: 'initialization' stamp: 'di 8/14/97 12:44'!
initInFrame: rect
	frame _ rect insetBy: 2.  "Leave room for border"
	para _ Paragraph withText: self contents asText
				style: TextStyle default
				compositionRectangle: ((frame insetBy: 4) withHeight: 9999)
				clippingRectangle: frame
				foreColor: self black backColor: self white! !


!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12'!
black
	Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"].
	^ Color black! !

!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12'!
white
	Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"].
	^ Color white! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Transcripter class
	instanceVariableNames: ''!

!Transcripter class methodsFor: 'instance creation' stamp: 'di 8/14/97 12:09'!
newInFrame: frame
"
(Transcripter newInFrame: (0@0 extent: 100@200))
	nextPutAll: 'Hello there'; endEntry;
	cr; print: 355.0/113; endEntry;
	readEvalPrint.
"
	| transcript |
	transcript _ self on: (String new: 100).
	transcript initInFrame: frame.
	^ transcript clear! !

!Transcripter class methodsFor: 'instance creation' stamp: 'ar 11/16/1999 20:16'!
startTranscriptProcess   "Transcripter startTranscriptProcess"
	| activeProcess |
	Transcript _ self newInFrame: Display boundingBox.
	activeProcess _ [Transcript readEvalPrint.
					Smalltalk processShutDownList: true; quitPrimitive]
						newProcess
					priority: Processor userSchedulingPriority.
	activeProcess resume.
	Processor terminateActive
! !


!Transcripter class methodsFor: 'utilities' stamp: 'di 11/3/2000 18:47'!
emergencyEvaluator
	(Transcripter newInFrame: (0@0 corner: 320@200))
		show: 'Type ''revert'' to revert your last method change.
Type ''exit'' to exit the emergency evaluator.';
		readEvalPrint! !
Morph subclass: #TransferMorph
	instanceVariableNames: 'transferType passenger draggedMorph source dropNotifyRecipient accepted resultRecipient copy'
	classVariableNames: 'CopyPlusIcon'
	poolDictionaries: ''
	category: 'Morphic-Support'!
!TransferMorph commentStamp: 'nk 6/16/2003 16:52' prior: 0!
This is a Morph that is used to visually indicate the progress of a drag operation, and also as a container for various bits of drag state information.

It polls the shift state in its step method to update its copy state (shift pressed = should copy).

And if you hit the Escape key while dragging, it aborts the drag operation.!


!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 16:11'!
dragTransferType: aSymbol
	transferType _ aSymbol! !

!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 17:34'!
draggedMorph
	draggedMorph ifNil: [self initDraggedMorph].
	^draggedMorph! !

!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/25/2000 16:31'!
draggedMorph: aMorph
	draggedMorph _ aMorph! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:52'!
dropNotifyRecipient
	^dropNotifyRecipient! !

!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/25/2000 16:14'!
dropNotifyRecipient: anObject
	dropNotifyRecipient _ anObject! !

!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 14:39'!
move
	copy _ false! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:52'!
passenger
	^passenger! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:53'!
passenger: anObject
	passenger _ anObject! !

!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 14:39'!
shouldCopy
	^copy! !

!TransferMorph methodsFor: 'accessing' stamp: 'nk 6/16/2003 16:29'!
shouldCopy: aBoolean
	copy := aBoolean.! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 11:55'!
source
	^source! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:53'!
source: anObject
	source _ anObject! !


!TransferMorph methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:11'!
dragTransferType
	^transferType! !


!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'nk 6/16/2003 16:51'!
aboutToBeGrabbedBy: aHand 
	"The receiver is being grabbed by a hand.                           
	Perform necessary adjustments (if any) and return the actual morph    
	     that should be added to the hand."
	"Since this morph has been initialized automatically with bounds origin   
	     0@0, we have to move it to aHand position."
	super aboutToBeGrabbedBy: aHand.
	self draggedMorph.
	self align: self bottomLeft with: aHand position.
	aHand newKeyboardFocus: self.! !

!TransferMorph methodsFor: 'dropping/grabbing'!
justDroppedInto: targetMorph event: anEvent 
	"If only world wants this TransferMorph, treat it as unaccepted (see also >>delete)."

	super justDroppedInto: targetMorph event: anEvent.
	accepted _ targetMorph ~= self world.
	self animationForMoveSuccess: accepted.
	accepted ifTrue: [self dropNotifyRecipient ifNotNil: [self dropNotifyRecipient dropAcceptedMorph: self from: targetMorph]].
	self delete! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'sr 4/16/2000 18:53'!
result: result 
	^ self result: result from: nil! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'nk 6/12/2004 17:02'!
result: aResult from: aResultGenerator 
	"Send aResult of the drop operation computed by aResultGenerator to a   
	resultRecipient, if it exists."
	resultRecipient ifNotNil: [resultRecipient dropResult: aResult from: aResultGenerator]! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/6/2000 17:30'!
undoGrabCommand
	^nil! !


!TransferMorph methodsFor: 'event handling' stamp: 'nk 6/16/2003 16:51'!
keyStroke: evt
	"Abort the drag on an escape"
	evt keyCharacter ~= Character escape ifTrue: [ ^self ].
	self delete.! !


!TransferMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:00'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color blue alpha: 0.4! !

!TransferMorph methodsFor: 'initialization' stamp: 'nk 6/16/2003 16:50'!
initialize
	"initialize the state of the receiver"
	super initialize.
	self layoutPolicy: TableLayout new.
	self listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		layoutInset: 3;
		wrapCentering: #center;
		cellPositioning: #leftCenter.
	accepted _ false.
	copy _ false.
	self on: #keyStroke send: #keyStroke: to: self! !


!TransferMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/16/2003 16:41'!
step
	self shouldCopy: Sensor shiftPressed.
	self updateCopyIcon! !

!TransferMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/16/2003 16:42'!
stepTime
	^100! !


!TransferMorph methodsFor: 'submorphs-add/remove' stamp: 'mir 5/15/2000 18:05'!
delete
	"See also >>justDroppedInto:event:."
	accepted ifFalse: [self dropNotifyRecipient ifNotNil: [self dropNotifyRecipient dropRejectedMorph: self]].
	self changed: #deleted.
	self breakDependents.
	super delete! !


!TransferMorph methodsFor: 'private' stamp: 'sr 6/6/2000 07:19'!
animationForMoveSuccess: success 
	| start stop slideForm |
	success
		ifTrue: [^ self]
		ifFalse: 
			[start _ self fullBounds origin.
			stop _ self source bounds origin].
	start = stop ifTrue: [^ self].
	slideForm _ self imageFormForRectangle: ((self fullBounds origin corner: self fullBounds corner + self activeHand shadowOffset)
					merge: self activeHand bounds).
	slideForm offset: 0 @ 0.
	slideForm
		slideWithFirstFrom: start
		to: stop
		nSteps: 12
		delay: 20! !

!TransferMorph methodsFor: 'private' stamp: 'nk 6/16/2003 16:49'!
initDraggedMorph
	draggedMorph ifNotNil: [^self].
	draggedMorph := self passenger asDraggableMorph.
	self addMorphBack: draggedMorph.
	self updateCopyIcon.
	self changed; fullBounds! !

!TransferMorph methodsFor: 'private' stamp: 'mir 5/14/2000 00:11'!
privateFullMoveBy: delta 
	super privateFullMoveBy: delta.
	self changed: #position! !

!TransferMorph methodsFor: 'private' stamp: 'nk 6/16/2003 16:34'!
updateCopyIcon
	| copyIcon |
	copyIcon _ self submorphWithProperty: #tmCopyIcon.
	(self shouldCopy and: [ copyIcon isNil ]) ifTrue: [
		^self addMorphFront: ((ImageMorph new image: CopyPlusIcon) setProperty: #tmCopyIcon toValue: true)
	].
	(self shouldCopy not and: [ copyIcon notNil ]) ifTrue: [
		copyIcon delete
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TransferMorph class
	instanceVariableNames: ''!

!TransferMorph class methodsFor: 'class initialization' stamp: 'mir 5/5/2000 14:49'!
initIcons
	"TransferMorph initIcons"

	CopyPlusIcon _ Form
		extent: 16@16
		depth: 8
		fromArray: #( 0 0 65535 0 0 0 16768220 4278190080 0 0 16768220 4278190080 0 255 4294958300 4294967040 0 65500 3705461980 3705462015 0 65500 3705461980 3705462015 0 255 4294958300 4294967295 0 0 16768220 4278190080 0 0 16768220 4278190080 0 0 65535 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
		offset: 0@0! !

!TransferMorph class methodsFor: 'class initialization' stamp: 'mir 5/5/2000 14:48'!
initialize
	"TransferMorph initialize"

	self initIcons! !


!TransferMorph class methodsFor: 'instance creation' stamp: 'sr 4/13/2000 21:52'!
withPassenger: anObject 
	^ self withPassenger: anObject from: nil! !

!TransferMorph class methodsFor: 'instance creation' stamp: 'nk 6/16/2003 16:29'!
withPassenger: anObject from: source 
	| ddm |
	ddm _ self new.
	ddm passenger: anObject.
	ddm source: source.
	Sensor shiftPressed ifTrue: [ddm shouldCopy: true].
	^ ddm! !
Morph subclass: #TransferMorphAnimation
	instanceVariableNames: 'transferMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!TransferMorphAnimation methodsFor: 'accessing' stamp: 'mir 5/14/2000 00:10'!
transferMorph
	^transferMorph! !


!TransferMorphAnimation methodsFor: 'initialization' stamp: 'ar 3/17/2001 23:43'!
on: aTransferMorph

	self flag: #bob.		"there was a reference to World, but the class seems to be unused"

	self color: Color transparent.
	transferMorph _ aTransferMorph.
	transferMorph addDependent: self.
	ActiveWorld addMorph: self	"or perhaps aTransferMorph world"! !


!TransferMorphAnimation methodsFor: 'update' stamp: 'mir 5/15/2000 18:02'!
updateAnimation! !


!TransferMorphAnimation methodsFor: 'updating' stamp: 'mir 5/15/2000 18:05'!
update: aSymbol	
	aSymbol == #deleted
		ifTrue: [self delete].
	aSymbol == #position
		ifTrue: [self updateAnimation].
	self changed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TransferMorphAnimation class
	instanceVariableNames: ''!

!TransferMorphAnimation class methodsFor: 'instance creation' stamp: 'mir 5/14/2000 00:07'!
on: aTransferMorph
	^self new on: aTransferMorph! !
TransferMorphAnimation subclass: #TransferMorphLineAnimation
	instanceVariableNames: 'polygon'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!TransferMorphLineAnimation methodsFor: 'initialization' stamp: 'di 9/9/2000 09:59'!
initPolygon
	polygon _ (LineMorph from: self transferMorph source bounds center
				to: self transferMorph bounds center
				color: Color black width: 2)
			dashedBorder: {10. 10. Color white}.
	self addMorph: polygon
! !

!TransferMorphLineAnimation methodsFor: 'initialization' stamp: 'mir 5/14/2000 00:12'!
on: aTransferMorph
	super on: aTransferMorph.
	self initPolygon! !


!TransferMorphLineAnimation methodsFor: 'update' stamp: 'di 9/9/2000 09:46'!
updateAnimation
	polygon verticesAt: 2 put: self transferMorph center! !
Morph subclass: #TransformMorph
	instanceVariableNames: 'transform smoothing localBounds'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!TransformMorph commentStamp: 'wiz 11/6/2005 15:59' prior: 0!
A TransformMorph introduces a 2-D transformation between its (global) coordinates and the (local) coordinates of its submorphs, while also clipping all display to its bounds.  Specifically, with no offset, angle or scaling, a submorph with coordinates (0@0) will appear exactly at the topLeft of the windowMorph (its position).  Rotation and scaling are relative to the local origin, (0@0).

instance var	type				description
 transform		MorphicTransform	The coordinate transform between my coordinates and the
									local coordinates of my submorphs.
 smoothing		anInteger in 1..3	Perform smoothing of my contents during drawing
										1 No smoothing (#smoothingOff)
										2 Smoothing w/ edge adjacent pixels (#smoothingOn)
										3 Smoothing w/ edge and corner adj pixels
			
 localBounds	Rectangle or nil		caches the value of #localSubmorphBounds for performance

TransformMorphs operate with two different display strategies, depending on whether the transformation is a pure translation or not.  If so, then they simply use a clipping canvas and display their submorphs with the appropriate offset.  If the transformation includes scaling or rotation, then a caching canvas is used, whose active area covers the fullBounds of the submorphs intersected with the source quadrilateral corresponding to the window bounds.!


!TransformMorph methodsFor: 'accessing'!
angle
	^ transform angle! !

!TransformMorph methodsFor: 'accessing' stamp: 'ar 1/30/2001 23:20'!
angle: newAngle

	self changed.
	transform _ transform withAngle: newAngle.
	self layoutChanged.
	self changed! !

!TransformMorph methodsFor: 'accessing' stamp: 'di 2/23/98 14:44'!
colorForInsets
	^ owner ifNil: [color] ifNotNil: [owner color]! !

!TransformMorph methodsFor: 'accessing'!
offset
	^ transform offset + self innerBounds topLeft! !

!TransformMorph methodsFor: 'accessing'!
offset: newOffset

	transform _ transform withOffset: newOffset - self innerBounds topLeft.
	self changed! !

!TransformMorph methodsFor: 'accessing'!
scale
	^ transform scale! !

!TransformMorph methodsFor: 'accessing' stamp: 'jm 4/17/1998 05:23'!
scale: newScale

	self changed.
	transform _ transform withScale: newScale.
	self layoutChanged.
	self changed.
! !

!TransformMorph methodsFor: 'accessing'!
setOffset: newOffset angle: newAngle scale: newScale

	transform _ MorphicTransform offset: newOffset angle: newAngle scale: newScale.
	self changed! !

!TransformMorph methodsFor: 'accessing' stamp: 'sps 11/29/2002 17:03'!
smoothing
	^smoothing
! !

!TransformMorph methodsFor: 'accessing'!
smoothing: cellSize
	smoothing _ cellSize.
	self changed! !

!TransformMorph methodsFor: 'accessing'!
smoothingOff
	smoothing _ 1.
	self changed! !

!TransformMorph methodsFor: 'accessing'!
smoothingOn
	smoothing _ 2.
	self changed! !

!TransformMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 18:04'!
transform
	^transform! !

!TransformMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 18:04'!
transform: aTransform
	transform _ aTransform.! !


!TransformMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:49'!
invalidRect: damageRect from: aMorph
	"Translate damage reports from submorphs by the scrollOffset."
	aMorph == self
		ifTrue:[super invalidRect: damageRect from: self]
		ifFalse:[super invalidRect: (((transform localBoundsToGlobal: damageRect) intersect: bounds) expandBy: 1) from: self].! !


!TransformMorph methodsFor: 'drawing' stamp: 'di 10/16/1999 16:03'!
drawSubmorphsOn: aCanvas

	aCanvas transformBy: transform
		clippingTo: self innerBounds
		during: [:myCanvas |
				submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ]
		smoothing: smoothing! !


!TransformMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/22/2000 18:00'!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]! !


!TransformMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:52'!
transformFrom: uberMorph 
	"Return a transform to map coorinates of uberMorph, a morph above me in my owner chain, into the coordinates of my submorphs."

	(self == uberMorph or: [owner isNil]) ifTrue: [^transform].
	^(owner transformFrom: uberMorph) composedWithLocal: transform! !


!TransformMorph methodsFor: 'geometry' stamp: 'efc 7/24/2003 16:43'!
layoutChanged

	"A submorph could have moved, thus changing my localBounds. Invalidate the cache."
	localBounds _ nil.

	^super layoutChanged! !

!TransformMorph methodsFor: 'geometry' stamp: 'efc 7/24/2003 16:41'!
localSubmorphBounds
	"Answer, in my coordinate system, the bounds of all my submorphs (or nil if no submorphs). We will cache this value for performance. The value is invalidated upon recieving #layoutChanged."

	localBounds ifNil:[
		self submorphsDo:[:m |
			localBounds ifNil: [localBounds _ m fullBounds]
						ifNotNil: [localBounds _ localBounds quickMerge: m fullBounds]].
	].	

	^ localBounds! !

!TransformMorph methodsFor: 'geometry' stamp: 'nk 4/12/2002 14:02'!
localVisibleSubmorphBounds
	"Answer, in my coordinate system, the bounds of all my visible submorphs (or nil if no visible submorphs)"
	| subBounds |
	subBounds _ nil.
	self submorphsDo: [:m |
		(m visible) ifTrue: [
			subBounds
				ifNil: [subBounds _ m fullBounds copy]
				ifNotNil: [subBounds _ subBounds quickMerge: m fullBounds]]
			].
	^subBounds! !

!TransformMorph methodsFor: 'geometry' stamp: 'nk 3/8/2004 11:05'!
numberOfItemsInView
	"Answer the number of my submorphs whose (transformed) bounds intersect mine.
	This includes items that are only partially visible.
	Ignore visibility of submorphs."

	^(submorphs select: [ :ea | self innerBounds intersects: (transform localBoundsToGlobal: ea bounds) ]) size! !

!TransformMorph methodsFor: 'geometry' stamp: 'nk 3/8/2004 11:06'!
numberOfItemsPotentiallyInView
	"Answer the number of items that could potentially be viewed in full,
	computed as my visible height divided by the average height of my submorphs.
	Ignore visibility of submorphs."

	^self innerBounds height // (self localSubmorphBounds height / submorphs size)! !


!TransformMorph methodsFor: 'geometry testing' stamp: 'wiz 11/6/2005 15:53'!
containsPoint: aPoint
	(bounds containsPoint: aPoint) ifFalse: [^ false].
	self hasSubmorphs
		ifTrue: [ | localPoint |  localPoint := (transform globalPointToLocal: aPoint) .
				self submorphsDo: 
					[:m | (m containsPoint: localPoint)
							ifTrue: [^ true]].
				^ false]
		ifFalse: [^ true]! !


!TransformMorph methodsFor: 'halos and balloon help' stamp: 'sw 12/29/1999 15:51'!
wantsHaloFromClick
	^ false! !


!TransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGreen! !

!TransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:39'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	smoothing _ 1.
	transform _ MorphicTransform identity! !


!TransformMorph methodsFor: 'layout' stamp: 'di 11/20/2000 11:54'!
fullBounds
	"Overridden to clip submorph hit detection to my bounds."
	"It might be better to override doLayoutIn:, and remove this method"

	fullBounds ifNotNil:[^ fullBounds].
	fullBounds _ bounds.
	submorphs do: [:m| m ownerChanged].
	^ fullBounds! !

!TransformMorph methodsFor: 'layout' stamp: 'nk 4/12/2002 14:03'!
submorphBounds
	"Answer, in owner coordinates, the bounds of my visible submorphs, or my bounds"
	| box |
	box _ self localVisibleSubmorphBounds.
	^(box ifNotNil: [ transform localBoundsToGlobal: box ] ifNil: [ self bounds ]) truncated.
! !


!TransformMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:20'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	smoothing = 1
		ifTrue: [aCustomMenu add: 'turn on smoothing' translated action: #smoothingOn]
		ifFalse: [aCustomMenu add: 'turn off smoothing' translated action: #smoothingOff]! !


!TransformMorph methodsFor: '*MorphicExtras-accessing' stamp: 'sps 12/28/2002 02:09'!
quickAddAllMorphs: aCollection
"A fast add of all the morphs for the PluggableListMorph>>list: method to use -- assumes that fullBounds will get called later by the sender, so it avoids doing any updating on the morphs in aCol or updating layout of this scroller. So the sender should handle those tasks as appropriate"

	| myWorld itsWorld |
	myWorld _ self world.
	aCollection do: [:m |
		m owner ifNotNil: [
			itsWorld _ m world.
			itsWorld == myWorld ifFalse: [m outOfWorld: itsWorld].
			m owner privateRemoveMorph: m].
		m privateOwner: self.
		"inWorld ifTrue: [self addedOrRemovedSubmorph: m]."
		itsWorld == myWorld ifFalse: [m intoWorld: myWorld].
		].
	submorphs _ aCollection.
	"self layoutChanged."

! !


!TransformMorph methodsFor: 'private' stamp: 'kfr 8/7/2004 18:48'!
privateFullMoveBy: delta
	"Private!! Relocate me, but not my subMorphs."

	self privateMoveBy: delta.
	transform _  (transform asMorphicTransform) withOffset: (transform offset - delta).
! !
TransformationMorph subclass: #TransformationB2Morph
	instanceVariableNames: 'worldBoundsToShow useRegularWarpBlt'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!TransformationB2Morph commentStamp: '<historical>' prior: 0!
A transformation which:

- is content to let someone else decide my bounds (I do not try to minimally enclose my submorphs)
- can use bi-linear interpolation!


!TransformationB2Morph methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/2000 12:44'!
useRegularWarpBlt: aBoolean

	useRegularWarpBlt _ aBoolean! !


!TransformationB2Morph methodsFor: 'drawing' stamp: 'RAA 12/17/2000 13:25'!
drawSubmorphsOn: aCanvas

	| r1 fullG r2 actualCanvas newClip where deferredMorphs case |
	(self innerBounds intersects: aCanvas clipRect) ifFalse: [^self].
	useRegularWarpBlt == true ifTrue: [
		^aCanvas 
			transformBy: transform
			clippingTo: ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) rounded
			during: [:myCanvas |
				submorphs reverseDo:[:m | myCanvas fullDrawMorph: m]
			]
			smoothing: smoothing
	].
	r1 _ self innerBounds intersect: aCanvas clipRect.
	r1 area = 0 ifTrue: [^self].
	fullG _ (transform localBoundsToGlobal: self firstSubmorph fullBounds) rounded.
	r2 _ r1 intersect: fullG.
	r2 area = 0 ifTrue: [^self].
	newClip _ (r2 expandBy: 1) rounded intersect: self innerBounds rounded.
	deferredMorphs _ #().
	aCanvas 
		transform2By: transform		"#transformBy: for pure WarpBlt"
		clippingTo: newClip
		during: [:myCanvas |
			self scale > 1.0 ifTrue: [
				actualCanvas _ MultiResolutionCanvas new initializeFrom: myCanvas.
				actualCanvas deferredMorphs: (deferredMorphs _ OrderedCollection new).
			] ifFalse: [
				actualCanvas _ myCanvas.
			].
			submorphs reverseDo:[:m | actualCanvas fullDrawMorph: m].
		]
		smoothing: smoothing.

	deferredMorphs do: [ :each |
		where _ each bounds: each fullBounds in: self.
		case _ 2.
		case = 1 ifTrue: [where _ where origin rounded extent: where extent rounded].
		case = 2 ifTrue: [where _ where rounded].
		each drawHighResolutionOn: aCanvas in: where.
	].

! !


!TransformationB2Morph methodsFor: 'geometry' stamp: 'RAA 11/21/2000 13:32'!
computeBounds

	"the transform bounds must remain under the control of the owner in this case"! !

!TransformationB2Morph methodsFor: 'geometry' stamp: 'RAA 11/20/2000 18:17'!
extent: aPoint

	| newExtent |

	newExtent _ aPoint truncated.
	bounds extent = newExtent ifTrue: [^self].
	bounds _ bounds topLeft extent: newExtent.
	"self recomputeExtent."

! !


!TransformationB2Morph methodsFor: 'private' stamp: 'RAA 11/22/2000 08:12'!
adjustAfter: changeBlock 

	"same as super, but without reference position stuff"

	changeBlock value.
	self chooseSmoothing.
	self layoutChanged.
	owner ifNotNil: [owner invalidRect: bounds]
! !
TransformMorph subclass: #TransformationMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!TransformationMorph commentStamp: 'mk 8/16/2005 11:58' prior: 0!
A TransformationMorph is like a transformMorph, except that it does not clip, and its bounds include its entire submorph.  TransformationMorphs are assumed to have only one submorph -- the idea is that it is a wrapper that enables its submorph to scale and rotate.  A TMorph may come to have more than one submorph if, eg, a menu sprouts a sub menu, using the transformationMorph temporarily as its world, but this ability is only sparsely supported (as in layoutChanged).

See TransformationMorph class example1 method.!


!TransformationMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 20:44'!
forwardDirection
	^self renderedMorph forwardDirection! !

!TransformationMorph methodsFor: 'accessing' stamp: 'jm 4/25/1998 05:55'!
hasNoScaleOrRotation

	^ transform isPureTranslation
! !

!TransformationMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 14:17'!
rotationDegrees: degrees
	self adjustAfter:[self angle: degrees degreesToRadians negated]! !

!TransformationMorph methodsFor: 'accessing' stamp: 'sw 2/15/2002 02:27'!
scaleFactor
	"Answer the scaleFactor"

	^ transform scale! !

!TransformationMorph methodsFor: 'accessing' stamp: 'jdl 3/28/2003 08:13'!
scaleToMatch: aPoint 
	| scaleFactor tfm originalScale |
	tfm := transform withScale: 1.0.
	originalScale := ((tfm localBoundsToGlobal: self renderedMorph fullBounds) 
				corner - (tfm localPointToGlobal: self renderedMorph referencePosition)) 
				r.
	"Catch cases where the reference point is on fullBounds corner"
	originalScale := originalScale max: 1.0.
	scaleFactor := (aPoint - self referencePosition) r / originalScale.
	scaleFactor := scaleFactor < 1.0 
				ifTrue: 
					[scaleFactor 
						detentBy: 0.05
						atMultiplesOf: 0.25
						snap: false]
				ifFalse: 
					[scaleFactor 
						detentBy: 0.1
						atMultiplesOf: 0.5
						snap: false].
	self adjustAfter: [self scale: ((scaleFactor min: 8.0) max: 0.1)]! !


!TransformationMorph methodsFor: 'classification' stamp: 'jm 4/17/1998 00:44'!
isFlexMorph

	^ true
! !

!TransformationMorph methodsFor: 'classification' stamp: 'jm 5/7/1998 13:46'!
isRenderer

	^ true
! !


!TransformationMorph methodsFor: 'drawing' stamp: 'di 2/23/98 19:59'!
drawOn: aCanvas
	submorphs isEmpty ifTrue: [super drawOn: aCanvas]! !


!TransformationMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/22/2000 18:26'!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	self renderedMorph isWorldMorph 
		ifTrue:[^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]].
	^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]! !


!TransformationMorph methodsFor: 'geometry' stamp: 'ar 11/21/2000 17:00'!
computeBounds
	self hasSubmorphs ifTrue:
		[bounds _ (transform localBoundsToGlobal:
					(Rectangle merging:
						(self submorphs collect: [:m | m fullBounds]))) truncated
				expandBy: 1].
	fullBounds _ bounds.! !

!TransformationMorph methodsFor: 'geometry' stamp: 'ar 4/18/2000 16:21'!
extent: newExtent
	| scaleFactor |
	self adjustAfter:
		[scaleFactor _ (self scale * newExtent r / self fullBounds extent r) max: 0.1.
		self scale: (scaleFactor detentBy: 0.1 atMultiplesOf: 1.0 snap: false)]! !

!TransformationMorph methodsFor: 'geometry' stamp: 'ar 10/25/2000 16:24'!
transformedBy: aTransform
	self changed.
	self transform: (self transform composedWithGlobal: aTransform).
	self computeBounds.
	self changed.! !


!TransformationMorph methodsFor: 'geometry eToy' stamp: 'di 10/1/2000 11:48'!
degreesOfFlex
	"Return any rotation due to flexing"
	^ self rotationDegrees! !

!TransformationMorph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 20:44'!
forwardDirection: degrees
	^self renderedMorph forwardDirection: degrees! !

!TransformationMorph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 13:38'!
heading
	^self renderedMorph heading! !

!TransformationMorph methodsFor: 'geometry eToy' stamp: 'sw 3/28/2001 14:24'!
referencePosition
	"Answer the  receiver's reference position, bullet-proofed against infinite recursion in the unlikely but occasionally-seen case that I am my own renderee"

	| rendered |
	^ (rendered _ self renderedMorph) == self
		ifTrue:
			[super referencePosition]
		ifFalse:
			[transform localPointToGlobal: rendered referencePosition]! !

!TransformationMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:23'!
setDirectionFrom: aPoint
	| delta degrees inner |
	inner _ self renderedMorph.
	inner == self ifTrue:[^self].
	delta _ (inner transformFromWorld globalPointToLocal: aPoint) - inner referencePosition.
	degrees _ delta degrees + 90.0.
	self forwardDirection: (degrees \\ 360) rounded.
! !

!TransformationMorph methodsFor: 'geometry eToy' stamp: 'sw 10/6/2004 12:15'!
simplySetVisible: aBoolean
	"Set the receiver's visibility property.  This mild circumlocution is because my own #visible: method would also set the visibility flag of my flexee, which in this case is pointless because it's the flexee that calls this."

	super visible: aBoolean! !

!TransformationMorph methodsFor: 'geometry eToy' stamp: 'sw 10/6/2004 11:33'!
visible: aBoolean
	"Set the receiver's visibility property"

	super visible: aBoolean.
	submorphs isEmptyOrNil ifFalse: [submorphs first visible: aBoolean]! !


!TransformationMorph methodsFor: 'initialization' stamp: 'di 2/21/98 14:35'!
asFlexOf: aMorph
	"Initialize me with position and bounds of aMorph,
	and with an offset that provides centered rotation."
	| pos |
	pos _ aMorph position.
	self addMorph: aMorph.
	aMorph position: (aMorph extent // 2) negated.
	self position: pos.
	transform _ transform withOffset: aMorph position - pos
! !

!TransformationMorph methodsFor: 'initialization' stamp: 'di 9/30/1998 23:12'!
flexing: aMorph byTransformation: tfm
	"Initialize me with position and bounds of aMorph,
	and with an offset that provides centered rotation."

	(aMorph isKindOf: TransformationMorph)
		ifTrue: [aMorph submorphsDo: [:m | self addMorph: m clone]]
		ifFalse: [self addMorph: aMorph].
	transform _ tfm.
	self chooseSmoothing.
	self layoutChanged.! !


!TransformationMorph methodsFor: 'layout' stamp: 'ar 10/25/2000 16:21'!
layoutChanged
	"Recompute bounds as a result of change"
	self computeBounds.
	super layoutChanged! !


!TransformationMorph methodsFor: 'menu' stamp: 'RJT 5/31/2006 13:05'!
removeFlexShell
	"Remove the shell used to make a morph rotatable and scalable."

	| oldHalo unflexed pensDown player myWorld refPos aPosition |
	refPos _ self referencePosition.
	myWorld _ self world.
	oldHalo _ self halo.
	submorphs isEmpty ifTrue: [^ self delete].
	aPosition _ (owner submorphIndexOf: self) ifNil: [1].
	unflexed _ self firstSubmorph.
	pensDown _ OrderedCollection new.
	self allMorphsDo:  "Note any pens down -- must not be down during the move"
		[:m | ((player _ m player) notNil and: [player getPenDown]) ifTrue:
			[m == player costume ifTrue:
				[pensDown add: player.
				player setPenDown: false]]].
	self submorphs do: [:m |
		m position: self center - (m extent // 2).
		owner addMorph: m asElementNumber: aPosition].
	unflexed absorbStateFromRenderer: self.
	pensDown do: [:p | p setPenDown: true].
	oldHalo ifNotNil: [oldHalo setTarget: unflexed].
	myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: unflexed].
	self delete.
	unflexed referencePosition: refPos.
	^ unflexed! !


!TransformationMorph methodsFor: 'naming' stamp: 'sw 5/13/1998 10:32'!
innocuousName
	| r |
	^ (r _ self renderedMorph) == self
		ifTrue: [super innocuousName] ifFalse: [r innocuousName]! !


!TransformationMorph methodsFor: 'printing' stamp: 'dgd 2/21/2003 22:42'!
printOn: aStream 
	super printOn: aStream.
	submorphs isEmpty 
		ifTrue: [aStream nextPutAll: ' with no transformee!!']
		ifFalse: [aStream nextPutAll: ' on ' , submorphs first printString]! !


!TransformationMorph methodsFor: 'rotate scale and flex' stamp: 'di 2/20/98 14:53'!
rotationDegrees
	^ self angle radiansToDegrees negated! !


!TransformationMorph methodsFor: 'submorphs-add/remove' stamp: 'di 11/18/1999 15:44'!
replaceSubmorph: oldMorph by: newMorph
	| t b |
	t _ transform.
	b _ bounds.
	super replaceSubmorph: oldMorph by: newMorph.
	transform _ t.
	bounds _ b.
	self layoutChanged! !


!TransformationMorph methodsFor: 'testing' stamp: 'mdr 10/3/2000 11:28'!
stepTime
	"Answer the stepTime of my rendered morph if posible"

	| rendered |
	rendered _ self renderedMorph.
	rendered = self ifTrue: [^super stepTime].	"Hack to avoid infinite recursion"
	^rendered stepTime.
	! !


!TransformationMorph methodsFor: '*eToys-geometry eToy' stamp: 'ar 9/22/2000 13:38'!
heading: newHeading
	self renderedMorph heading: newHeading! !


!TransformationMorph methodsFor: 'private' stamp: 'di 9/30/1998 22:49'!
adjustAfter: changeBlock 
	"Cause this morph to remain cetered where it was before, and
	choose appropriate smoothing, after a change of scale or rotation."
	| oldRefPos |
	oldRefPos _ self referencePosition.
	changeBlock value.
	self chooseSmoothing.
	self penUpWhile: [self position: self position + (oldRefPos - self referencePosition)].
	self layoutChanged.
	owner ifNotNil: [owner invalidRect: bounds]
! !

!TransformationMorph methodsFor: 'private' stamp: 'aoy 2/17/2003 01:02'!
chooseSmoothing
	"Choose appropriate smoothing, after a change of scale or rotation."

	smoothing := (self scale < 1.0 or: [self angle ~= (self angle roundTo: Float pi / 2.0)]) 
		ifTrue: [ 2]
		ifFalse: [1]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TransformationMorph class
	instanceVariableNames: ''!

!TransformationMorph class methodsFor: 'example' stamp: 'mk 8/14/2005 16:07'!
example1
	| stringMorph transformationMorph |
	stringMorph _ 'vertical text' asMorph.
	transformationMorph _ TransformationMorph new asFlexOf: stringMorph.
	transformationMorph angle: Float pi / 2.
	transformationMorph position: 5@5.
	transformationMorph openInWorld.! !
Morph subclass: #TransitionMorph
	instanceVariableNames: 'startMorph endMorph startBlock completionBlock stepNumber nSteps stepTime startForm endForm effect direction'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!TransitionMorph commentStamp: '<historical>' prior: 0!
A transitionMorph inserts itself in the morphic object structure during a visual transition.  It has a stepNumber that runs from 1 to nSteps.  This class handles a large family of wipe-like transitions by itself.  Subclasses may implement other transitions such as dissolves and zooms.!


!TransitionMorph methodsFor: 'change reporting' stamp: 'di 12/22/1998 20:10'!
invalidate: box1 areasOutside: box2

	((box1 intersect: bounds) areasOutside: (box2 intersect: bounds))
		do: [:r | self invalidRect: r]! !


!TransitionMorph methodsFor: 'drawing' stamp: 'di 1/5/1999 08:37'!
areasRemainingToFill: aRectangle
	"May be overridden by any subclasses with opaque regions"

	^ aRectangle areasOutside: self bounds! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'!
drawDissolveOn: aCanvas
	"startForm and endFrom are both fixed, but the dissolve ration changes."

	startForm copyBits: endForm at: 0@0 translucent: stepNumber asFloat / (nSteps*2).

	aCanvas drawImage: startForm at: self position.
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'!
drawFrenchDoorOn: aCanvas
	"startForm and endFrom are both fixed, but a border expands out from a vertical (or H) slit, revealing endForm.
	It's like opening a pair of doors."
	| box innerForm outerForm boxExtent h w |
	h _ self height. w _ self width.
	direction = #in ifTrue: [innerForm _ endForm.  outerForm _ startForm.
							boxExtent _ self stepFrom: 0@h to: self extent].
	direction = #out ifTrue: [innerForm _ startForm.  outerForm _ endForm.
							boxExtent _ self stepFrom: self extent to: 0@h].
	direction = #inH ifTrue: [innerForm _ endForm.  outerForm _ startForm.
							boxExtent _ self stepFrom: w@0 to: self extent].
	direction = #outH ifTrue: [innerForm _ startForm.  outerForm _ endForm.
							boxExtent _ self stepFrom: self extent to: w@0].
		
	aCanvas drawImage: outerForm at: self position.

	box _ Rectangle center: self center extent: boxExtent.
	aCanvas drawImage: innerForm at: box topLeft sourceRect: (box translateBy: self position negated).

	((box expandBy: 1) areasOutside: box) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'di 12/22/1998 20:58'!
drawOn: aCanvas
	"During the transition process, the reveal and obscure areas will be invalidated,
	so we should be drawing on a canvas that clips to only the changing region."

	(stepNumber between: 1 and: nSteps) ifFalse: [^ self].
	effect = #slideOver ifTrue: [^ self drawSlideOverOn: aCanvas].
	effect = #slideBoth ifTrue: [^ self drawSlideBothOn: aCanvas].
	effect = #slideAway ifTrue: [^ self drawSlideAwayOn: aCanvas].
	effect = #slideBorder ifTrue: [^ self drawSlideBorderOn: aCanvas].
	effect = #pageForward ifTrue: [^ self drawPageForwardOn: aCanvas].
	effect = #pageBack ifTrue: [^ self drawPageBackOn: aCanvas].
	effect = #frenchDoor ifTrue: [^ self drawFrenchDoorOn: aCanvas].
	effect = #zoomFrame ifTrue: [^ self drawZoomFrameOn: aCanvas].
	effect = #zoom ifTrue: [^ self drawZoomOn: aCanvas].
	effect = #dissolve ifTrue: [^ self drawDissolveOn: aCanvas].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'!
drawPageBackOn: aCanvas
	"endForm grows in the given direction, overlaying endForm."
	| offset growRect scale |
	aCanvas drawImage: startForm at: self position.

	offset _ self stepFrom: self extent * direction negated to: 0@0.
	growRect _ (bounds translateBy: offset) intersect: bounds.
	scale _ growRect extent asFloatPoint / bounds extent.
	aCanvas drawImage: (endForm magnify: endForm boundingBox by: scale smoothing: 1)
		at: growRect topLeft.

	((growRect translateBy: direction) areasOutside: growRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'!
drawPageForwardOn: aCanvas
	"startForm shrinks in the given direction, revealing endForm."
	| offset shrinkRect scale |
	aCanvas drawImage: endForm at: self position.

	offset _ self stepFrom: 0@0 to: self extent * direction.
	shrinkRect _ (bounds translateBy: offset) intersect: bounds.
	scale _ shrinkRect extent asFloatPoint / bounds extent.
	aCanvas drawImage: (startForm magnify: startForm boundingBox by: scale smoothing: 1)
		at: shrinkRect topLeft.

	((shrinkRect translateBy: direction negated) areasOutside: shrinkRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'!
drawSlideAwayOn: aCanvas
	"startMorph slides away in the given direction, revealing up the endMorph."
	| startLoc moveRect |
	startLoc _ self stepFrom: self position to: self position + (self extent * direction).
	moveRect _ startForm boundingBox translateBy: startLoc.

	aCanvas drawImage: endForm at: self position.
	aCanvas drawImage: startForm at: startLoc.

	((moveRect translateBy: direction negated) areasOutside: moveRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'!
drawSlideBorderOn: aCanvas
	"startForm and endFrom are both fixed, but a border slides in the given direction, revealing endForm.  (It's like opening a can of sardines ;-)."
	| endRect box sourceRect boxLoc |
	box _ endForm boundingBox.
	boxLoc _ self stepFrom: box topLeft - (box extent * direction) to: box topLeft.
	sourceRect _ box translateBy: boxLoc.
	endRect _ sourceRect translateBy: self position.

	((endRect expandBy: 1) containsRect: aCanvas clipRect) ifFalse:
		[aCanvas drawImage: startForm at: self position].
	aCanvas drawImage: endForm at: self position + boxLoc sourceRect: sourceRect.

	((endRect translateBy: direction) areasOutside: endRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'!
drawSlideBothOn: aCanvas
	"endMorph slides in the given direction, as startMorph slides out of its way."
	| endLoc endRect startLoc |
	startLoc _ self stepFrom: self position to: self position + (self extent * direction).
	aCanvas drawImage: startForm at: startLoc.

	endLoc _ self stepFrom: self position - (self extent * direction) to: self position.
	aCanvas drawImage: endForm at: endLoc.

	endRect _ endForm boundingBox translateBy: endLoc.
	((endRect translateBy: direction) areasOutside: endRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'!
drawSlideOverOn: aCanvas
	"endMorph slides in the given direction, covering up the startMorph."
	| endLoc endRect |
	endLoc _ self stepFrom: self position - (self extent * direction) to: self position.
	endRect _ endForm boundingBox translateBy: endLoc.

	((endRect expandBy: 1) containsRect: aCanvas clipRect) ifFalse:
		[aCanvas drawImage: startForm at: self position].
	aCanvas drawImage: endForm at: endLoc.

	((endRect translateBy: direction) areasOutside: endRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'!
drawZoomFrameOn: aCanvas
	"startForm and endFrom are both fixed, but a square border expands out from the center (or back), revealing endForm.
	It's like passing through a portal."
	| box innerForm outerForm boxExtent |
	direction = #in
		ifTrue: [innerForm _ endForm.  outerForm _ startForm.
				boxExtent _ self stepFrom: 0@0 to: self extent]
		ifFalse: [innerForm _ startForm.  outerForm _ endForm.
				boxExtent _ self stepFrom: self extent to: 0@0].
		
	aCanvas drawImage: outerForm at: self position.

	box _ Rectangle center: self center extent: boxExtent.
	aCanvas drawImage: innerForm at: box topLeft sourceRect: (box translateBy: self position negated).

	((box expandBy: 1) areasOutside: box) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'!
drawZoomOn: aCanvas
	"Zoom in: endForm expands overlaying startForm.
	Zoom out: startForm contracts revealing endForm."
	| box innerForm outerForm boxExtent scale |
	direction = #in
		ifTrue: [innerForm _ endForm.  outerForm _ startForm.
				boxExtent _ self stepFrom: 0@0 to: self extent]
		ifFalse: [innerForm _ startForm.  outerForm _ endForm.
				boxExtent _ self stepFrom: self extent to: 0@0].

	aCanvas drawImage: outerForm at: self position.

	box _ Rectangle center: self center extent: boxExtent.
	scale _ box extent asFloatPoint / bounds extent.
	aCanvas drawImage: (innerForm magnify: innerForm boundingBox by: scale smoothing: 1)
		at: box topLeft.

	((box expandBy: 1) areasOutside: box) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !


!TransitionMorph methodsFor: 'initialization' stamp: 'di 12/22/1998 12:52'!
completeReplacement

	self delete.
	completionBlock value! !

!TransitionMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 14:22'!
initiateReplacement
	| n |
	startForm := effect = #dissolve 
				ifTrue: [(startMorph imageForm: 16 forRectangle: bounds) offset: 0 @ 0]
				ifFalse: [(startMorph imageFormForRectangle: bounds) offset: 0 @ 0].
	endForm := (endMorph imageFormForRectangle: bounds) offset: 0 @ 0.
	nSteps isNil 
		ifTrue: 
			[self nSteps: 30 stepTime: 10.
			(#(#zoom #pageForward #pageBack) includes: effect) 
				ifTrue: 
					[n := 20 * 100000 // self bounds area min: 20 max: 4.
					self nSteps: n stepTime: 10].
			#dissolve = effect 
				ifTrue: 
					[n := 20 * 50000 // self bounds area min: 20 max: 4.
					self nSteps: n stepTime: 10]].
	startBlock value.	"with forms in place there should b no further delay."
	self arrangeToStartStepping! !

!TransitionMorph methodsFor: 'initialization' stamp: 'di 12/14/1998 12:25'!
nSteps: n stepTime: msPerStep
	nSteps _ n.
	stepTime _ msPerStep! !

!TransitionMorph methodsFor: 'initialization' stamp: 'di 12/22/1998 13:32'!
showTransitionFrom: startingMorph to: endingMorph in: containingMorph
	whenStart: firstBlock whenDone: doneBlock

	effect == #none ifTrue: [firstBlock value.  ^ doneBlock value].

	self startMorph: startingMorph endMorph: endingMorph
		startBlock: firstBlock completionBlock: doneBlock.
	stepNumber _ 0.

	self bounds: startingMorph bounds.
	endingMorph privateOwner: self.  "Allows test of transition in progress"
	containingMorph owner privateAddMorph: self atIndex: 
		(containingMorph owner submorphs indexOf: containingMorph).

	self initiateReplacement! !

!TransitionMorph methodsFor: 'initialization' stamp: 'di 12/20/1998 10:46'!
startMorph: start endMorph: end startBlock: firstBlock completionBlock: aBlock
	startMorph _ start.
	endMorph _ end.
	startBlock _ firstBlock.
	completionBlock _ aBlock! !


!TransitionMorph methodsFor: 'stepping and presenter' stamp: 'di 12/14/1998 12:30'!
step
	(stepNumber _ stepNumber + 1) <= nSteps
		ifTrue: [self changed]
		ifFalse: [self completeReplacement]! !


!TransitionMorph methodsFor: 'testing' stamp: 'di 12/15/1998 13:52'!
stepTime
	^ stepTime! !


!TransitionMorph methodsFor: 'updating' stamp: 'di 12/22/1998 20:59'!
changed
	"The default (super) method is, generally much slower than need be, since many transitions only change part of the screen on any given step of the animation.  The purpose of this method is to effect some of those savings."
	| loc box boxPrev h w |
	(stepNumber between: 1 and: nSteps) ifFalse: [^ super changed].
	effect = #slideBoth ifTrue: [^ super changed].
	effect = #slideOver ifTrue:
		[loc _ self stepFrom: self position - (self extent * direction) to: self position.
		^ self invalidRect: (((loc extent: self extent) expandBy: 1) intersect: bounds)].
	effect = #slideAway ifTrue:
		[loc _ self prevStepFrom: self position to: self position + (self extent * direction).
		^ self invalidRect: (((loc extent: self extent) expandBy: 1) intersect: bounds)].
	effect = #slideBorder ifTrue:
		[box _ endForm boundingBox translateBy:
				(self stepFrom: self topLeft - (self extent * direction) to: self topLeft).
		boxPrev _ endForm boundingBox translateBy:
				(self prevStepFrom: self topLeft - (self extent * direction) to: self topLeft).
		^ self invalidate: (box expandBy: 1) areasOutside: boxPrev].
	effect = #pageForward ifTrue:
		[loc _ self prevStepFrom: 0@0 to: self extent * direction.
		^ self invalidRect: (((bounds translateBy: loc) expandBy: 1) intersect: bounds)].
	effect = #pageBack ifTrue:
		[loc _ self stepFrom: self extent * direction negated to: 0@0.
		^ self invalidRect: (((bounds translateBy: loc) expandBy: 1) intersect: bounds)].
	effect = #frenchDoor ifTrue:
		[h _ self height. w _ self width.
		direction = #in ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: 0@h to: self extent).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: 0@h to: self extent).
			^ self invalidate: (box expandBy: 1) areasOutside: boxPrev].
		direction = #out ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: self extent to: 0@h).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: self extent to: 0@h).
			^ self invalidate: (boxPrev expandBy: 1) areasOutside: box].
		direction = #inH ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: w@0 to: self extent).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: w@0 to: self extent).
			^ self invalidate: (box expandBy: 1) areasOutside: boxPrev].
		direction = #outH ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: self extent to: w@0).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: self extent to: w@0).
			^ self invalidate: (boxPrev expandBy: 1) areasOutside: box]].
	effect = #zoomFrame ifTrue:
		[direction = #in ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: 0@0 to: self extent).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: 0@0 to: self extent).
			^ self invalidate: (box expandBy: 1) areasOutside: boxPrev].
		direction = #out ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: self extent to: 0@0).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: self extent to: 0@0).
			^ self invalidate: (boxPrev expandBy: 1) areasOutside: box]].
	effect = #zoom ifTrue:
		[box _ Rectangle center: self center extent:
			(direction = #in
				ifTrue: [self stepFrom: 0@0 to: self extent]
				ifFalse: [self prevStepFrom: self extent to: 0@0]).
		^ self invalidRect: ((box expandBy: 1) intersect: bounds)].
	^ super changed
! !


!TransitionMorph methodsFor: 'private' stamp: 'aoy 2/17/2003 01:09'!
effect: effectSymbol direction: dirSymbol 
	| i |
	effect := effectSymbol.

	"Default directions"
	(#(#zoom #zoomFrame #frenchDoor) includes: effectSymbol) 
		ifTrue: 
			[direction := (#(#in #out #inH #outH) includes: dirSymbol) 
				ifTrue: [dirSymbol]
				ifFalse: [#in]]
		ifFalse: 
			[i := #(#right #downRight #down #downLeft #left #upLeft #up #upRight) 
						indexOf: dirSymbol
						ifAbsent: [5].
			direction := (0 @ 0) eightNeighbors at: i]! !

!TransitionMorph methodsFor: 'private' stamp: 'di 12/15/1998 11:42'!
prevStepFrom: p1 to: p2
	"Used for recalling dimensions from previous step."

	^ (p2-p1) * (stepNumber-1) // nSteps + p1! !

!TransitionMorph methodsFor: 'private' stamp: 'di 12/14/1998 12:43'!
stepFrom: p1 to: p2
	"This gives p1 for stepCount = 0, moving to p2 for stepCount = nSteps"

	^ (p2-p1) * stepNumber // nSteps + p1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TransitionMorph class
	instanceVariableNames: ''!

!TransitionMorph class methodsFor: 'available effects' stamp: 'di 12/22/1998 20:58'!
allEffects
	^ #(none
		slideOver slideBoth slideAway slideBorder
		pageForward pageBack 
		frenchDoor
		zoomFrame zoom
		dissolve)! !

!TransitionMorph class methodsFor: 'available effects' stamp: 'di 12/22/1998 20:59'!
directionsForEffect: eff
	 "All these arrays are ordered so inverse is atWrap: size//2."
	(#(slideOver slideBoth slideAway slideBorder) includes: eff)
		ifTrue: [^ #(right downRight down downLeft left upLeft up upRight)].
	(#(pageForward pageBack) includes: eff)
		ifTrue: [^ #(right down left up)].
	(#(frenchDoor) includes: eff)
		ifTrue: [^ #(in inH out outH)].
	(#(zoomFrame zoom) includes: eff)
		ifTrue: [^ #(in out)].
	^ Array new! !


!TransitionMorph class methodsFor: 'initialization' stamp: 'di 12/20/1998 22:01'!
effect: effectSymbol direction: dirSymbol
	^ self new effect: effectSymbol direction: dirSymbol! !

!TransitionMorph class methodsFor: 'initialization' stamp: 'di 12/20/1998 21:37'!
effect: effectSymbol direction: dirSymbol inverse: inverse
	| invEffect invDir i dirSet |
	inverse ifFalse: [^ self effect: effectSymbol direction: dirSymbol].

	invEffect _ effectSymbol.
	effectSymbol = #pageForward ifTrue: [invEffect _ #pageBack].
	effectSymbol = #pageBack ifTrue: [invEffect _ #pageForward].
	effectSymbol = #slideOver ifTrue: [invEffect _ #slideAway].
	effectSymbol = #slideAway ifTrue: [invEffect _ #slideOver].

	invDir _ dirSymbol.
	dirSet _ self directionsForEffect: effectSymbol.
	(i _ dirSet indexOf: dirSymbol) > 0
		ifTrue: [invDir _ dirSet atWrap: i + (dirSet size // 2)].

	^ self effect: invEffect direction: invDir! !


!TransitionMorph class methodsFor: 'new-morph participation' stamp: 'di 11/16/1998 15:37'!
includeInNewMorphMenu
	"Transitions aren't meaningful without initializations"
	^ false! !
ArrayedCollection variableSubclass: #TranslatedMethod
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TranslatedMethod class
	instanceVariableNames: ''!

!TranslatedMethod class methodsFor: 'class initialization' stamp: 'ikp 1/10/98 02:34'!
initialize
	self becomeCompact.
	Smalltalk recreateSpecialObjectsArray.
	Smalltalk specialObjectsArray size = 41
		ifFalse: [self error: 'Please check size of special objects array!!']! !
Object subclass: #TranslatedReceiverFinder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Editor'!

!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 8/2/2004 17:22'!
searchBlockNode: aBlockNode addTo: aCollection

	aBlockNode statements do: [:e |
		(e isMemberOf: MessageNode) ifTrue: [self searchMessageNode: e addTo: aCollection].
		(e isMemberOf: ReturnNode) ifTrue: [self searchReturnNode: e addTo: aCollection].
	].
! !

!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 8/2/2004 17:23'!
searchMessageNode: aMessageNode addTo: aCollection

	((aMessageNode receiver isMemberOf: LiteralNode) and: [(aMessageNode selector isMemberOf: SelectorNode) and: [aMessageNode selector key = #translated]]) ifTrue: [
		aCollection add: aMessageNode receiver key.
	].

	(aMessageNode receiver isMemberOf: BlockNode) ifTrue: [self searchBlockNode: aMessageNode receiver addTo: aCollection].
	(aMessageNode receiver isMemberOf: MessageNode) ifTrue: [self searchMessageNode: aMessageNode receiver addTo: aCollection].
	(aMessageNode receiver isMemberOf: ReturnNode) ifTrue: [self searchReturnNode: aMessageNode receiver addTo: aCollection].

	aMessageNode arguments do: [:a |
		(a isMemberOf: BlockNode) ifTrue: [self searchBlockNode: a addTo: aCollection].
		(a isMemberOf: MessageNode) ifTrue: [self searchMessageNode: a addTo: aCollection].
		(a isMemberOf: ReturnNode) ifTrue: [self searchReturnNode: a addTo: aCollection].
	].
! !

!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 8/2/2004 17:22'!
searchMethodNode: aMethodNode addTo: aCollection

	(aMethodNode block isMemberOf: BlockNode) ifTrue: [self searchBlockNode: aMethodNode block addTo: aCollection].
	(aMethodNode block isMemberOf: MessageNode) ifTrue: [self searchMessageNode: aMethodNode block addTo: aCollection].
	(aMethodNode block isMemberOf: ReturnNode) ifTrue: [self searchReturnNode: aMethodNode block addTo: aCollection].
! !

!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 8/2/2004 17:21'!
searchReturnNode: aReturnNode addTo: aCollection

	(aReturnNode expr isMemberOf: BlockNode) ifTrue: [self searchBlockNode: aReturnNode expr addTo: aCollection].
	(aReturnNode expr isMemberOf: MessageNode) ifTrue: [self searchMessageNode: aReturnNode expr addTo: aCollection].
! !

!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 7/29/2004 18:22'!
senders

	| m o |
	m _ SystemNavigation default allCallsOn: #translated.
	m _ m collect: [:e |
		e classIsMeta ifTrue: [
			(Smalltalk at: e classSymbol) class decompile: e methodSymbol.
		] ifFalse: [
			(Smalltalk at: e classSymbol) decompile: e methodSymbol.
		]
	].

	o _ SortedCollection new.
	m do: [:e | self searchMethodNode: e addTo: o].
	^ o.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TranslatedReceiverFinder class
	instanceVariableNames: ''!

!TranslatedReceiverFinder class methodsFor: 'as yet unclassified' stamp: 'dgd 4/3/2006 13:24'!
makeJapaneseTranslationFile
	| t n |
	NaturalLanguageTranslator initializeKnownPhrases.
	t := TranslatedReceiverFinder new senders.
	n := NaturalLanguageTranslator
				localeID: (LocaleID isoLanguage: 'ja').
	t
		do: [:w | 
			NaturalLanguageTranslator registerPhrase: w.
			self
				at: w
				ifPresent: [:k | n phrase: w translation: k]].
	n saveToFileNamed: 'ja.translation'! !
Color subclass: #TranslucentColor
	instanceVariableNames: 'alpha'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!TranslucentColor commentStamp: '<historical>' prior: 0!
A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the high byte of a 32-bit pixelValue.  This allows creating forms with translucency for use with the alpha blend function of BitBlt.  An alpha of zero is transparent, and 1.0 is opaque.!


!TranslucentColor methodsFor: 'accessing'!
alpha
	"Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque."

	^ alpha asFloat / 255.0
! !


!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/15/1999 11:44'!
alpha: alphaValue
	alphaValue = 1.0 ifTrue:
		[^ Color basicNew
			setPrivateRed: self privateRed
			green: self privateGreen
			blue: self privateBlue].
	^ super alpha: alphaValue! !

!TranslucentColor methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'!
asNontranslucentColor
	^ self alpha: 1.0! !

!TranslucentColor methodsFor: 'conversions' stamp: 'di 3/25/2000 17:56'!
balancedPatternForDepth: depth
	"Return an appropriate bit pattern or stipple.  This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency."

	alpha = 0 ifTrue: [^ Bitmap with: 0].
	^ super balancedPatternForDepth: depth! !

!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/14/1999 20:05'!
bitPatternForDepth: depth
	"Return an appropriate bit pattern or stipple.  This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency."

	alpha = 0 ifTrue: [^ Bitmap with: 0].
	^ super bitPatternForDepth: depth! !

!TranslucentColor methodsFor: 'conversions' stamp: 'ar 5/27/2001 16:30'!
pixelValueForDepth: d
	"Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths."
	| basicPixelWord |
	alpha = 0 ifTrue: [^ 0].
	basicPixelWord _ super pixelValueForDepth: d.
	d < 32
		ifTrue: [^ basicPixelWord]
		ifFalse: [^ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: (alpha bitShift: 24)].
! !

!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/6/1999 16:14'!
pixelWordForDepth: depth
	"Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths."

	| basicPixelWord |
	alpha = 0 ifTrue: [^ 0].
	basicPixelWord _ super pixelWordForDepth: depth.
	depth < 32
		ifTrue: [^ basicPixelWord]
		ifFalse: [^ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: (alpha bitShift: 24)].
! !

!TranslucentColor methodsFor: 'conversions' stamp: 'ar 1/14/1999 15:30'!
scaledPixelValue32
	"Return the alpha scaled pixel value for depth 32"
	| pv32 a b g r |
	pv32 _ super scaledPixelValue32.
	a _ (self alpha * 255.0) rounded.
	b _ (pv32 bitAnd: 255) * a // 256.
	g _ ((pv32 bitShift: -8) bitAnd: 255) * a // 256.
	r _ ((pv32 bitShift: -16) bitAnd: 255) * a // 256.
	^b + (g bitShift: 8) + (r bitShift: 16) + (a bitShift: 24)! !


!TranslucentColor methodsFor: 'equality'!
hash

	^ rgb bitXor: alpha
! !


!TranslucentColor methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:50'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"1/13/1999 -- old versions did not have alpha??"
	varDict at: 'alpha' ifAbsent: [^ Color transparent].

	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
	! !


!TranslucentColor methodsFor: 'printing' stamp: 'mir 7/21/1999 11:43'!
storeArrayValuesOn: aStream

	self isTransparent ifTrue: [
		^ aStream space].
	super storeArrayValuesOn: aStream.

	aStream space.
	(self alpha roundTo: 0.001) storeOn: aStream.

! !

!TranslucentColor methodsFor: 'printing' stamp: 'di 9/27/2000 13:33'!
storeOn: aStream

	self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)'].
	super storeOn: aStream.
	aStream
		skip: -1;	  "get rid of trailing )"
		nextPutAll: ' alpha: ';
		print: (self alpha roundTo: 0.001);
		nextPutAll: ')'.
! !


!TranslucentColor methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'!
isOpaque
	^alpha = 255! !

!TranslucentColor methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'!
isTranslucent
	^ alpha < 255! !

!TranslucentColor methodsFor: 'queries' stamp: 'di 1/3/1999 12:22'!
isTranslucentColor
	"This means: self isTranslucent, but isTransparent not"
	^ alpha > 0! !

!TranslucentColor methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'!
isTransparent
	^ alpha = 0! !


!TranslucentColor methodsFor: 'private'!
privateAlpha
	"Return my raw alpha value, an integer in the range 0..255. Used for fast equality testing."

	^ alpha
! !

!TranslucentColor methodsFor: 'private'!
setRgb: rgbValue alpha: alphaValue
	"Set the state of this translucent color. Alpha is represented internally by an integer in the range 0..255."

	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _ rgbValue.
	alpha _ (255.0 * alphaValue) asInteger min: 255 max: 0.
! !
Morph subclass: #TranslucentProgessMorph
	instanceVariableNames: 'opaqueBackgroundColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!TranslucentProgessMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/29/2000 11:35'!
opaqueBackgroundColor: aColor

	opaqueBackgroundColor _ aColor! !

!TranslucentProgessMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 11:19'!
revealingStyle

">>>>
	1 = original, no change after 100%
	2 = hold at last 25% and blink until done
	3 = wrap around from 100% back to 0 and go again. change color after first
<<<<"
	^3
! !


!TranslucentProgessMorph methodsFor: 'drawing' stamp: 'nk 7/12/2003 08:59'!
drawOn: aCanvas

	| revealPercentage revealingStyle revealingColor revealingBounds revealToggle x baseColor revealTimes secondsRemaining stringToDraw where fontToUse innerBounds |
	
	innerBounds _ bounds.
	opaqueBackgroundColor ifNotNil: [
		aCanvas 
			frameAndFillRectangle: bounds
			fillColor: opaqueBackgroundColor
			borderWidth: 8
			borderColor: Color blue.
		innerBounds _ innerBounds insetBy: 8.
	].
	revealTimes _ (self valueOfProperty: #revealTimes) ifNil: [^self].
	revealPercentage _ (revealTimes first / revealTimes second) asFloat.
	revealingStyle _ self revealingStyle.
	x _ self valueOfProperty: #progressStageNumber ifAbsent: [1].
	baseColor _ Color perform: (#(red blue green magenta cyan yellow) atPin: x).
	revealingColor _ baseColor alpha: 0.2.
	revealingStyle = 3 ifTrue: [	"wrap and change color"
		revealPercentage > 1.0 ifTrue: [
			revealingColor _ baseColor alpha: (0.2 + (revealingStyle / 10) min: 0.5).
		].
		revealPercentage _ revealPercentage fractionPart.
	].
	revealingStyle = 2 ifTrue: [	"peg at 75 and blink"
		revealPercentage > 0.75 ifTrue: [
			revealToggle _ self valueOfProperty: #revealToggle ifAbsent: [true].
			self setProperty: #revealToggle toValue: revealToggle not.
			revealToggle ifTrue: [revealingColor _ baseColor alpha: 0.8.].
		].
		revealPercentage _ revealPercentage min: 0.75.
	].
	revealingBounds _ innerBounds withLeft: innerBounds left + (innerBounds width * revealPercentage) truncated.
	aCanvas 
		fillRectangle: revealingBounds
		color: revealingColor.
	secondsRemaining _ (revealTimes second - revealTimes first / 1000) rounded.
	secondsRemaining > 0 ifTrue: [
		fontToUse _ StrikeFont familyName: Preferences standardEToysFont familyName size: 24.
		stringToDraw _ secondsRemaining printString.
		where _ innerBounds corner - ((fontToUse widthOfString: stringToDraw) @ fontToUse height).
		aCanvas 
			drawString: stringToDraw 
			in: (where corner: innerBounds corner)
			font: fontToUse
			color: Color black.
		aCanvas
			drawString: stringToDraw 
			in: (where - (1@1) corner: innerBounds corner)
			font: fontToUse
			color: Color white.
	]. 


! !


!TranslucentProgessMorph methodsFor: 'WiW support' stamp: 'RAA 7/19/2000 18:52'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^self valueOfProperty: #morphicLayerNumber ifAbsent: [12].

	"progress morphs are behind menus and balloons, but in front of most other stuff"! !
ThreePhaseButtonMorph subclass: #TrashCanMorph
	instanceVariableNames: ''
	classVariableNames: 'TrashPic TrashPicOn'
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWidgets'!

!TrashCanMorph methodsFor: 'dropping/grabbing' stamp: 'sw 8/15/2000 17:03'!
wantsDroppedMorph: aMorph event: evt

	^ ((aMorph ~~ self) and: [aMorph ~~ Utilities scrapsBook]) and:
		[aMorph willingToBeDiscarded]! !


!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:14'!
doubleClick: evt
	| palette |
	palette _ self standardPalette.
	((palette notNil and: [palette isInWorld]) and: [palette hasScrapsTab])
		ifTrue:
			[palette showScrapsTab]
		ifFalse:
			[self world openScrapsBook: evt].! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 00:17'!
handlesMouseDown: evt

	^ self inPartsBin not! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 7/3/1998 13:33'!
handlesMouseOver: evt

	^ self inPartsBin not
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:51'!
handlesMouseOverDragging: evt

	^ self inPartsBin not
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:02'!
mouseDown: evt
	| paintBox |
	evt hand visible: true.
	"See if a stamp is being dropped into the trash. It is not held by the hand."
	(paintBox _ self findActivePaintBox) ifNotNil: [
		paintBox getSpecial == #stamp: ifTrue: [
			paintBox deleteCurrentStamp: evt.  "throw away stamp..."
			self primaryHand showTemporaryCursor: nil.
			^ self]].	  "... and don't open trash"
	evt hand waitForClicksOrDrag: self event: evt.
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'wiz 8/2/2005 22:53'!
mouseEnter: event 
	"Present feedback for potential deletion."
	| hand firstSub |
	hand := event hand.
	((hand submorphCount > 0
				and: [(firstSub := hand submorphs first) ~~ self])
			and: [self wantsDroppedMorph: firstSub event: event])
		ifTrue: [Preferences soundsEnabled
				ifTrue: [self class playMouseEnterSound].
			"hand visible: false." "This leads to confusion. Let morph and hand appear til dropped."
			"self world abandonAllHalos."
			"hand halo: nil."
			self state: #pressed]
		ifFalse: [self showStampIn: hand]! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:08'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 16:18'!
mouseLeave: event
	"Present feedback for aborted deletion."
	| hand |
	hand _ event hand.
	((hand submorphCount > 0) and:
	 [hand submorphs first ~~ self])
		ifTrue:
			[Preferences soundsEnabled ifTrue: [self class playMouseLeaveSound].
			hand visible: true.
			self state: #off]
		ifFalse:
			[self stopShowingStampIn: hand].
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:13'!
mouseMove: evt
	| hand firstSub |
	hand _ evt hand.
	(((hand submorphCount > 0) and: [(firstSub _ hand submorphs first) ~~ self]) and:
			[self wantsDroppedMorph: firstSub event: evt])
		ifTrue: 
			[super mouseMove: evt]
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'jm 5/22/1998 10:35'!
mouseUp: evt
	"Close the lid when you're through!!"

	self state: #off.
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:08'!
startDrag: evt
	evt hand grabMorph: self.! !


!TrashCanMorph methodsFor: 'initialization' stamp: 'dgd 9/19/2003 10:51'!
initialize
	"Initialize the receiver's graphics, name, and balloon-help"

	super initialize.
	self image: TrashPicOn;
		offImage: TrashPic;
		pressedImage: TrashPicOn.
	self setNameTo: 'Trash' translated.
	self setBalloonText:
'To remove an object, drop it on any trash can. To view, and maybe retrieve, items that have been thrown away, double-click on any trash-can.  Things are retained in the trash-can if the "preserveTrash" preference is set, otherwise they are purged immediately' translated.
! !


!TrashCanMorph methodsFor: 'layout' stamp: 'wiz 8/2/2005 22:46'!
acceptDroppingMorph: aMorph event: evt 
	Preferences soundsEnabled
		ifTrue: [Preferences preserveTrash
				ifTrue: [self class playDeleteSound]
				ifFalse: [self playSoundNamed: 'scratch']].
	evt hand visible: true.
	self state: #off.
	aMorph delete.
	aMorph == Utilities scrapsBook
		ifFalse: [Utilities addToTrash: aMorph removeHalo]! !


!TrashCanMorph methodsFor: 'parts bin' stamp: 'sw 8/12/2001 18:09'!
initializeToStandAlone
	"Bypass ImageMorph's intervention"

	self initialize! !


!TrashCanMorph methodsFor: 'printing' stamp: 'sw 9/14/1998 12:02'!
printOn: aStream
	aStream nextPutAll: 'a TrashCanMorph'! !


!TrashCanMorph methodsFor: 'private' stamp: 'sw 8/22/1998 22:44'!
findActivePaintBox
	"If painting, return the active PaintBoxMorph. If not painting, or if the paint box cannot be found, return nil."

	| w m |
	w _ self world.
	w ifNil: [^ nil].
	(w findA: SketchEditorMorph) ifNil: [^ nil].  "not painting"
	(m _ w findA: PaintBoxMorph) ifNotNil: [^ m].
	^ nil
! !

!TrashCanMorph methodsFor: 'private' stamp: 'jm 5/22/1998 10:13'!
showStampIn: aHand
	"If painting and in stamp mode, show the stamp that is about to be thrown away."

	| paintBox curs |
	paintBox _ self findActivePaintBox.
	paintBox ifNotNil: [
		"See if a stamp is being dropped into the trash. It is not actually held by the hand."
		paintBox getSpecial == #stamp: ifTrue: [
			curs _ paintBox actionCursor.
			aHand showTemporaryCursor: curs hotSpotOffset: curs center]].
! !

!TrashCanMorph methodsFor: 'private' stamp: 'jm 5/22/1998 10:16'!
stopShowingStampIn: aHand
	"Revert to the normal cursor."

	aHand showTemporaryCursor: nil.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TrashCanMorph class
	instanceVariableNames: ''!

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'gk 2/23/2004 20:51'!
playDeleteSound
	"TrashCanMorph playDeleteSound"

	SoundService default playSampledSound: self samplesForDelete rate: 22050! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'gk 2/23/2004 20:51'!
playMouseEnterSound
	"TrashCanMorph playMouseEnterSound"

	SoundService default playSampledSound: self samplesForMouseEnter rate: 22050! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'gk 2/23/2004 20:51'!
playMouseLeaveSound
	"TrashCanMorph playMouseLeaveSound"

	SoundService default playSampledSound: self samplesForMouseLeave rate: 22050! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 11:00'!
samplesForDelete

	^ #(0 11 5 18 42 35 28 54 42 59 52 44 16 18 33 6 -39 -30 -39 -37 -61 -61 -55 -83 -71 -42 -66 -45 -61 -40 -22 1 -3 33 61 69 44 59 59 64 44 81 62 79 91 62 45 55 1 -8 -10 -1 -16 -33 -20 -57 -54 -18 10 5 -1 -6 25 62 47 49 79 52 20 50 76 94 74 91 100 94 69 67 76 76 44 71 62 64 91 93 96 113 93 125 120 108 76 67 79 54 79 69 64 83 37 39 35 6 -13 -57 -62 -52 -79 -94 -100 -78 -105 -101 -59 -69 -64 -25 -55 -33 -57 -33 -39 -33 -16 -16 -16 -30 -25 -1 -27 -32 -39 -44 -1 -18 -23 -61 -55 -45 -67 -74 -47 -23 -22 -55 -50 -18 -47 -39 -22 -32 -28 -45 -28 -50 -69 -83 -83 -66 -93 -84 -74 -74 -84 -76 -94 -52 -69 -62 -35 -3 11 -16 28 5 -10 0 3 25 -1 20 32 25 44 59 18 11 -32 0 -11 -28 -55 -67 -62 -64 -57 -49 -76 -239 -980 -1731 -1565 -478 1153 2646 2919 1799 -1385 -5482 -8325 -8427 -4347 2556 9606 13864 12797 7894 731 -6395 -9218 -6222 1491 9207 12724 10783 3258 -6050 -12631 -14020 -9175 -454 8771 14419 13457 7050 -1679 -8875 -11346 -7670 960 10478 16383 15908 10112 2191 -5150 -8398 -6123 644 8334 12364 11062 5163 -2966 -9760 -12327 -9012 -1947 4977 8880 8495 4412 -1704 -6697 -7935 -5491 -186 5557 9289 9235 4955 -819 -4990 -5843 -3005 2128 7204 9606 7728 2439 -3872 -8469 -9930 -7226 -1385 4532 7567 6452 2154 -3136 -7248 -8045 -4493 1794 7582 10089 8636 3994 -1994 -6473 -7257 -3774 1894 6760 9011 7177 1979 -4364 -8760 -9067 -5465 332 5596 7764 5742 284 -5345 -8517 -7840 -3480 2838 8592 10639 7918 2485 -3435 -7177 -7341 -3630 2542 7333 8449 5514 15 -5645 -9192 -8368 -3540 3111 8083 9218 6558 941 -5119 -8500 -7748 -2905 3329 8259 9891 6975 1192 -4921 -8285 -7411 -3123 3090 7961 9206 5967 -130 -5728 -8793 -7886 -3061 3637 8965 9864 6471 683 -5121 -8324 -7547 -2720 3679 8050 8714 5236 -373 -6032 -9138 -7679 -2653 3679 8166 8982 5906 -111 -5825 -8561 -7094 -2091 3874 8412 9128 5533 -361 -5918 -8320 -6939 -2222 4016 8376 8831 4987 -943 -6130 -8678 -7102 -2117 4149 8322 8296 4768 -744 -5827 -8144 -6444 -1172 4732 8463 8412 4659 -1111 -6519 -8782 -6838 -1876 3818 7423 7601 3966 -1852 -6722 -8505 -6354 -1297 4366 8266 8217 4386 -1206 -5891 -7589 -5647 -595 5092 8402 7645 3372 -2274 -7031 -8958 -6814 -1560 4329 7654 7123 3477 -1869 -6393 -7899 -5367 88 5572 8632 8001 3994 -1711 -6441 -7793 -5287 -393 4497 7216 6430 2176 -3494 -7572 -8412 -5660 -476 4873 7782 6690 2393 -2805 -6588 -7323 -4649 614 5879 8327 6904 2609 -2773 -6848 -7927 -5150 117 5087 7272 5923 1730 -3616 -7575 -8117 -4951 332 5082 7314 6100 1716 -3587 -7162 -7338 -4064 1063 5860 7922 6178 1477 -3845 -7267 -7575 -4571 537 5260 7199 5292 826 -4115 -7486 -7689 -4446 938 5637 7201 5421 1063 -3815 -7109 -7141 -3667 1448 5660 6990 4983 519 -4622 -7833 -7543 -3996 1080 5323 6922 5028 385 -4480 -7416 -7070 -3789 1145 5533 6878 4693 40 -4734 -7506 -7268 -3827 1353 5650 6756 4347 -161 -4821 -7581 -7051 -3301 1993 5847 6707 4347 -198 -4888 -7582 -6814 -2926 2076 5860 6719 4339 -313 -5104 -7557 -6685 -2960 1915 5679 6573 3945 -814 -5333 -7572 -6588 -2787 2269 6052 6597 3789 -877 -5189 -7406 -6525 -2636 2447 5996 6307 3497 -1070 -5450 -7609 -6463 -2340 2658 5945 6230 3482 -1158 -5519 -7458 -5949 -1767 3039 6341 6612 3603 -1267 -5625 -7343 -5857 -1774 3033 6279 6346 3156 -1653 -5721 -7357 -5877 -1742 3158 6256 6039 2848 -1752 -5721 -7285 -5643 -1223 3635 6464 6159 2960 -1731 -5771 -7229 -5280 -936 3662 6266 5823 2488 -2386 -6329 -7457 -5362 -1044 3521 6339 5962 2564 -2183 -5850 -6875 -4841 -536 4120 6763 6062 2488 -2111 -5681 -6838 -4873 -605 3845 6190 5268 1777 -2759 -6413 -7419 -5162 -680 3692 5964 5234 1888 -2556 -5979 -6624 -4157 242 4497 6702 5860 2200 -2597 -6054 -6732 -4381 -111 4183 6330 5153 1346 -3170 -6430 -7031 -4688 -198 4213 6335 5180 1519 -2753 -5777 -6198 -3531 958 5024 6619 5234 1523 -3048 -6295 -6753 -4157 137 3986 5665 4412 788 -3545 -6449 -6469 -3735 539 4539 6246 4921 1172 -3100 -5918 -6010 -3352 905 4800 6313 4702 865 -3363 -6118 -6254 -3609 753 4529 5842 4178 466 -3628 -6305 -6174 -3231 1195 4854 6112 4497 715 -3550 -6183 -5972 -3043 1265 4843 6030 4203 264 -3915 -6352 -5945 -2961 1328 4907 6001 4025 50 -3949 -6240 -5808 -2731 1620 5085 5932 3872 5 -3961 -6174 -5640 -2408 1971 5204 5806 3587 -347 -4320 -6493 -5674 -2252 2103 5245 5818 3709 -300 -4249 -6215 -5309 -2066 2078 5077 5591 3262 -809 -4558 -6335 -5384 -2111 2062 5097 5460 3022 -951 -4570 -6283 -5192 -1733 2491 5348 5475 3024 -912 -4546 -6217 -5077 -1557 2597 5245 5301 2785 -1263 -4934 -6522 -5226 -1716 2385 5104 5206 2680 -1328 -4860 -6276 -4933 -1472 2549 5211 5238 2602 -1389 -4778 -6118 -4834 -1379 2664 5109 4880 2156 -1731 -5007 -6259 -4754 -1121 2883 5297 4973 2318 -1620 -4939 -6086 -4395 -697 3187 5426 5082 2242 -1738 -5026 -6037 -4332 -754 3012 5156 4665 1777 -2237 -5294 -6125 -4310 -676 3177 5313 4707 1704 -2171 -5167 -5962 -4134 -434 3307 5221 4456 1421 -2371 -5287 -5974 -3954 -188 3542 5297 4424 1389 -2456 -5362 -5854 -3667 161 3709 5435 4476 1255 -2671 -5472 -5828 -3589 215 3804 5409 4402 1138 -2724 -5324 -5599 -3384 378 3901 5396 4091 868 -2871 -5385 -5572 -3270 525 3884 5155 3828 575 -3119 -5518 -5503 -2994 826 4095 5277 3886 615 -3100 -5348 -5202 -2603 1202 4405 5579 4064 602 -3109 -5419 -5272 -2790 899 4067 5100 3521 122 -3477 -5592 -5270 -2585 1314 4537 5531 3905 485 -3089 -5226 -4956 -2347 1443 4476 5236 3463 11 -3604 -5711 -5257 -2473 1341 4363 5141 3385 -28 -3584 -5504 -4973 -2164 1586 4456 5218 3413 -64 -3496 -5321 -4707 -1969 1721 4571 5109 3195 -329 -3723 -5474 -4821 -1969 1776 4503 4921 2919 -522 -3845 -5506 -4654 -1676 2057 4687 5036 3068 -415 -3721 -5323 -4408 -1430 2169 4614 4882 2788 -695 -3915 -5313 -4337 -1396 2132 4519 4702 2544 -905 -3866 -5124 -3993 -988 2586 4865 4841 2573 -877 -3859 -5050 -3949 -902 2556 4668 4510 2223 -1141 -4108 -5170 -3808 -703 2720 4719 4553 2271 -1131 -3972 -4907 -3489 -390 2919 4890 4537 2088 -1385 -4154 -4934 -3447 -337 2949 4792 4325 1743 -1562 -4181 -4856 -3273 -33 3316 5041 4439 1923 -1424 -3959 -4570 -2910 317 3423 4907 4088 1355 -2054 -4624 -5056 -3187 140 3307 4809 4030 1323 -2069 -4432 -4695 -2724 597 3694 5114 4179 1360 -1966 -4229 -4478 -2602 675 3715 5019 3932 1027 -2281 -4537 -4753 -2714 656 3687 4919 3859 1085 -2127 -4312 -4403 -2332 965 3786 4910 3750 882 -2391 -4437 -4402 -2254 933 3703 4646 3397 396 -2761 -4724 -4539 -2305 980 3754 4756 3469 590 -2468 -4317 -4120 -1871 1389 4050 4788 3321 318 -2715 -4503 -4201 -1837 1438 4025 4685 3201 220 -2892 -4629 -4167 -1665 1653 4171 4763 3180 93 -2975 -4602 -4015 -1499 1777 4212 4668 2927 -195 -3214 -4712 -4027 -1443 1877 4278 4609 2759 -451 -3440 -4853 -4093 -1385 1983 4334 4570 2726 -405 -3326 -4680 -3794 -1068 2210 4410 4547 2595 -554 -3460 -4715 -3725 -987 2203 4300 4352 2317 -875 -3669 -4760 -3687 -941 2237 4312 4330 2291 -778 -3453 -4486 -3475 -775 2271 4218 4105 1969 -1070 -3682 -4656 -3518 -661 2424 4262 4018 1854 -1197 -3718 -4505 -3141 -252 2809 4564 4264 2067 -1039 -3611 -4369 -3028 -201 2761 4427 4040 1772 -1318 -3740 -4352 -2907 -52 2939 4553 4008 1657 -1414 -3784 -4364 -2858 71 3089 4629 4098 1794 -1219 -3535 -4025 -2500 373 3224 4571 3896 1487 -1553 -3828 -4269 -2661 281 3126 4547 3891 1552 -1413 -3640 -3989 -2363 529 3341 4719 4010 1545 -1452 -3640 -3988 -2305 653 3467 4729 3866 1292 -1740 -3849 -4091 -2325 671 3436 4602 3716 1219 -1733 -3760 -3867 -1994 1031 3708 4758 3730 1100 -1925 -3891 -3898 -1938 1044 3640 4625 3557 921 -2020 -3859 -3776 -1813 1116 3687 4617 3465 815 -2079 -3828 -3713 -1708 1263 3759 4544 3307 641 -2169 -3855 -3674 -1608 1362 3750 4410 3090 425 -2383 -4022 -3725 -1533 1491 3835 4488 3167 390 -2378 -3928 -3509 -1257 1728 4013 4573 3123 286 -2473 -3894 -3404 -1080 1884 4078 4466 2853 -5 -2678 -4035 -3440 -1097 1857 3996 4295 2678 -137 -2821 -4118 -3421 -983 1959 4054 4283 2648 -196 -2873 -4054 -3273 -751 2161 4159 4334 2556 -320 -2965 -4064 -3201 -743 2176 4144 4225 2424 -491 -2999 -4011 -3065 -524 2366 4218 4166 2266 -527 -3007 -3950 -2995 -441 2446 4186 4011 2055 -793 -3221 -4122 -3048 -497 2269 3910 3759 1847 -951 -3318 -4032 -2861 -261 2461 4044 3777 1764 -1048 -3282 -3888 -2595 8 2720 4200 3747 1609 -1195 -3413 -4006 -2727 -94 2586 4001 3501 1396 -1321 -3396 -3835 -2456 164 2756 3984 3385 1253 -1458 -3540 -3889 -2427 161 2654 3835 3194 978 -1743 -3638 -3838 -2295 322 2819 3964 3211 939 -1698 -3550 -3689 -2147 446 2883 3884 3016 726 -1901 -3667 -3765 -2123 530 2870 3745 2848 568 -2028 -3721 -3652 -1884 743 3014 3804 2827 478 -2144 -3779 -3686 -1910 685 2910 3669 2636 249 -2295 -3828 -3676 -1867 787 3011 3681 2564 169 -2269 -3684 -3424 -1508 1109 3282 3789 2575 134 -2334 -3779 -3482 -1543 1073 3099 3608 2339 -127 -2620 -3944 -3519 -1525 1092 3151 3535 2273 -193 -2580 -3787 -3318 -1296 1326 3309 3652 2234 -256 -2634 -3888 -3409 -1348 1282 3204 3491 2125 -346 -2666 -3811 -3204 -1114 1441 3253 3462 2008 -432 -2714 -3692 -3007 -861 1662 3399 3499 1940 -547 -2821 -3765 -2983 -854 1648 3346 3394 1743 -761 -2958 -3849 -3087 -822 1676 3304 3282 1636 -822 -2963 -3772 -2878 -644 1835 3375 3296 1599 -831 -2924 -3667 -2702 -446 1998 3489 3307 1604 -885 -2949 -3667 -2658 -408 1984 3421 3207 1407 -1005 -3028 -3592 -2493 -223 2183 3519 3168 1323 -1124 -3078 -3621 -2468 -157 2191 3465 3090 1216 -1211 -3123 -3584 -2390 -106 2201 3424 2983 1031 -1414 -3236 -3594 -2278 52 2393 3518 2982 1026 -1372 -3185 -3492 -2174 217 2481 3558 2990 999 -1399 -3104 -3323 -1944 391 2603 3528 2824 765 -1645 -3338 -3516 -2118 259 2439 3404 2700 654 -1716 -3375 -3479 -1952 439 2602 3455 2704 617 -1772 -3360 -3404 -1901 493 2585 3413 2571 442 -1901 -3413 -3358 -1742 676 2719 3458 2583 442 -1862 -3275 -3184 -1514 848 2836 3482 2495 313 -1981 -3404 -3224 -1543 771 2719 3268 2198 22 -2217 -3523 -3218 -1457 934 2870 3380 2242 59 -2137 -3336 -3000 -1255 1077 2880 3290 2110 -83 -2249 -3472 -3087 -1267 1111 2885 3257 2040 -176 -2349 -3455 -3004 -1129 1255 3036 3316 2039 -227 -2339 -3367 -2824 -929 1423 3077 3287 1959 -317 -2425 -3404 -2826 -843 1430 3068 3162 1762 -476 -2500 -3382 -2659 -727 1562 3083 3145 1742 -512 -2522 -3314 -2559 -602 1664 3136 3073 1555 -715 -2690 -3413 -2556 -503 1757 3190 3055 1450 -804 -2731 -3387 -2464 -390 1826 3150 2944 1301 -988 -2887 -3487 -2491 -402 1808 3073 2807 1145 -1095 -2921 -3406 -2352 -208 1950 3141 2802 1072 -1204 -2977 -3394 -2252 -139 2044 3163 2751 988 -1284 -2999 -3350 -2217 -88 2015 3102 2629 783 -1424 -3044 -3346 -2157 -30 2050 2988 2449 636 -1582 -3178 -3411 -2135 33 2055 3016 2424 588 -1604 -3153 -3331 -2032 105 2123 3004 2344 451 -1704 -3204 -3309 -1933 240 2208 3055 2334 446 -1723 -3175 -3231 -1818 359 2308 3090 2346 386 -1787 -3260 -3265 -1820 356 2266 2999 2193 254 -1933 -3348 -3302 -1774 369 2222 2917 2042 49 -2030 -3348 -3221 -1676 551 2424 2995 2054 59 -2069 -3306 -3095 -1494 698 2522 3017 1974 -76 -2184 -3380 -3114 -1440 812 2568 3072 2033 -28 -2128 -3285 -2956 -1228 978 2724 3102 2010 -72 -2132 -3243 -2871 -1197 1016 2712 3029 1879 -193 -2206 -3229 -2775 -1056 1151 2797 3009 1818 -259 -2251 -3228 -2729 -924 1199 2758 2960 1718 -366 -2324 -3206 -2607 -812 1346 2836 2951 1687 -417 -2296 -3068 -2403 -625 1489 2924 2973 1616 -495 -2352 -3067 -2391 -554 1545 2861 2807 1397 -666 -2452 -3170 -2430 -598 1455 2785 2736 1312 -666 -2441 -3082 -2300 -371 1625 2866 2787 1319 -715 -2419 -3014 -2215 -357 1630 2768 2593 1134 -895 -2544 -3051 -2178 -300 1721 2892 2634 1145 -873 -2515 -2951 -2057 -198 1786 2807 2505 988 -1041 -2620 -2987 -2040 -173 1787 2775 2424 878 -1146 -2653 -2960 -1923 -22 1884 2870 2447 839 -1131 -2622 -2897 -1799 150 2027 2955 2466 880 -1138 -2624 -2885 -1730 215 2008 2792 2244 532 -1406 -2788 -2907 -1703 271 2074 2865 2293 571 -1377 -2724 -2844 -1597 359 2159 2905 2247 524 -1426 -2756 -2770 -1526 385 2118 2799 2111 366 -1521 -2792 -2805 -1494 476 2227 2856 2176 419 -1497 -2702 -2664 -1365 576 2242 2846 2050 288 -1597 -2805 -2685 -1346 610 2278 2780 1937 101 -1784 -2922 -2737 -1321 656 2274 2778 1906 101 -1762 -2860 -2610 -1156 798 2368 2831 1903 113 -1745 -2832 -2569 -1114 817 2385 2771 1847 64 -1781 -2734 -2446 -980 972 2488 2827 1830 -37 -1804 -2773 -2381 -854 1075 2529 2805 1762 -115 -1871 -2814 -2424 -863 995 2388 2588 1572 -262 -1977 -2756 -2281 -768 1187 2551 2702 1616 -217 -1921 -2693 -2156 -525 1368 2688 2802 1681 -176 -1843 -2583 -2054 -486 1362 2622 2668 1482 -310 -1964 -2658 -2030 -407 1440 2632 2615 1414 -419 -1998 -2603 -1949 -308 1501 2646 2553 1251 -544 -2111 -2641 -1891 -203 1606 2693 2558 1221 -636 -2152 -2639 -1867 -169 1662 2737 2547 1212 -588 -2088 -2498 -1655 66 1843 2843 2575 1178 -659 -2118 -2500 -1614 84 1874 2810 2476 1056 -807 -2218 -2522 -1633 91 1833 2736 2359 912 -917 -2295 -2539 -1521 210 1962 2793 2374 877 -956 -2273 -2486 -1486 273 1960 2763 2318 846 -924 -2200 -2364 -1294 463 2123 2812 2301 746 -1033 -2281 -2395 -1277 478 2088 2770 2203 668 -1089 -2273 -2325 -1138 593 2156 2782 2140 586 -1177 -2335 -2295 -1131 673 2266 2788 2115 527 -1240 -2337 -2291 -1065 714 2232 2751 2049 415 -1301 -2344 -2203 -912 893 2398 2875 2103 441 -1287 -2285 -2145 -860 919 2373 2787 1955 291 -1384 -2390 -2218 -926 895 2315 2670 1786 118 -1521 -2456 -2156 -763 1043 2485 2775 1905 215 -1428 -2301 -1988 -605 1143 2486 2773 1811 106 -1504 -2330 -1949 -517 1224 2539 2766 1765 -1 -1609 -2354 -1901 -485 1265 2576 2702 1630 -103 -1664 -2429 -1998 -532 1202 2383 2439 1382 -313 -1859 -2522 -1972 -449 1268 2454 2522 1407 -266 -1801 -2391 -1793 -269 1458 2597 2563 1399 -335 -1806 -2393 -1781 -264 1457 2571 2525 1296 -424 -1881 -2419 -1738 -169 1570 2620 2485 1246 -483 -1893 -2373 -1645 -76 1594 2564 2400 1128 -595 -2039 -2476 -1670 -79 1582 2556 2366 1092 -661 -2010 -2352 -1514 42 1745 2668 2398 1085 -602 -1954 -2271 -1428 161 1794 2649 2296 1000 -680 -1991 -2286 -1416 208 1781 2580 2232 882 -783 -2025 -2223 -1270 357 1925 2659 2237 856 -861 -2084 -2254 -1331 264 1833 2527 2105 724 -924 -2098 -2169 -1211 463 2013 2658 2137 717 -951 -2037 -2125 -1067 580 2088 2704 2156 712 -922 -1998 -2030 -975 687 2101 2625 2033 553 -1068 -2105 -2113 -992 614 2054 2544 1925 393 -1209 -2193 -2120 -978 659 2095 2553 1852 371 -1175 -2167 -2055 -907 712 2117 2532 1833 351 -1221 -2191 -2064 -904 722 2089 2497 1755 251 -1306 -2191 -1996 -809 793 2079 2441 1687 159 -1350 -2232 -1959 -717 875 2159 2439 1591 74 -1423 -2210 -1928 -710 904 2117 2327 1511 0 -1455 -2184 -1832 -544 1070 2242 2419 1545 6 -1440 -2161 -1769 -468 1124 2271 2393 1463 -93 -1541 -2206 -1748 -459 1145 2278 2366 1367 -193 -1575 -2225 -1774 -398 1206 2305 2327 1348 -193 -1597 -2240 -1767 -379 1195 2225 2232 1192 -351 -1692 -2218 -1655 -300 1255 2262 2245 1173 -381 -1740 -2223 -1589 -193 1358 2339 2254 1162 -359 -1698 -2137 -1513 -130 1419 2361 2208 1099 -480 -1771 -2242 -1558 -110 1399 2259 2096 965 -566 -1838 -2200 -1501 -69 1440 2279 2064 956 -566 -1796 -2127 -1367 47 1509 2339 2071 854 -666 -1862 -2105 -1321 125 1599 2378 2079 834 -676 -1816 -2062 -1279 167 1625 2349 1998 792 -726 -1860 -2055 -1178 296 1692 2369 1979 714 -802 -1893 -2084 -1211 261 1664 2237 1779 464 -1005 -2033 -2147 -1245 259 1594 2166 1720 434 -1065 -2061 -2095 -1133 371 1750 2251 1742 417 -1055 -2010 -2003 -1033 476 1747 2210 1621 274 -1178 -2098 -2074 -1051 405 1660 2091 1502 145 -1277 -2162 -2062 -1043 446 1704 2091 1430 117 -1302 -2130 -2008 -924 534 1752 2081 1391 6 -1401 -2186 -2016 -924 551 1669 1938 1233 -144 -1443 -2208 -1949 -810 656 1764 2040 1273 -74 -1399 -2100 -1818 -690 741 1816 2006 1199 -137 -1418 -2110 -1808 -673 737 1740 1866 1055 -293 -1597 -2213 -1793 -644 736 1752 1869 1050 -301 -1584 -2159 -1776 -568 810 1796 1871 1005 -364 -1608 -2164 -1706 -534 843 1798 1833 919 -422 -1660 -2137 -1655 -454 917 1830 1784 866 -449 -1647 -2147 -1604 -424 965 1801 1743 821 -566 -1743 -2128 -1562 -305 1000 1820 1704 753 -619 -1781 -2127 -1565 -334 1000 1874 1733 710 -631 -1726 -2074 -1487 -225 1072 1849 1676 690 -670 -1771 -2072 -1409 -150 1134 1842 1630 622 -744 -1801 -2088 -1375 -118 1112 1793 1572 517 -861 -1860 -2061 -1360 -125 1153 1801 1499 435 -863 -1843 -2011 -1287 -15 1250 1871 1496 419 -888 -1866 -2020 -1263 25 1240 1801 1457 354 -941 -1864 -1971 -1153 123 1290 1808 1416 300 -992 -1882 -1974 -1136 101 1265 1735 1287 169 -1145 -2027 -2006 -1172 88 1243 1709 1223 74 -1185 -2022 -1994 -1090 201 1290 1665 1151 -5 -1270 -2037 -1964 -1029 254 1341 1723 1148 -30 -1243 -1998 -1893 -990 313 1404 1692 1116 -88 -1318 -2061 -1901 -966 335 1372 1657 1007 -184 -1409 -2127 -1972 -1012 273 1297 1553 922 -283 -1502 -2195 -1944 -924 359 1353 1581 934 -257 -1472 -2069 -1782 -743 544 1508 1721 1005 -239 -1430 -2013 -1728 -726 568 1513 1687 946 -274 -1453 -2000 -1706 -615 656 1560 1662 916 -303 -1462 -2018 -1660 -619 641 1506 1558 765 -459 -1584 -2078 -1667 -602 614 1463 1504 707 -507 -1609 -2050 -1591 -502 732 1547 1574 746 -434 -1467 -1896 -1414 -320 873 1638 1558 717 -546 -1572 -1920 -1423 -303 914 1626 1499 622 -576 -1601 -1947 -1440 -315 878 1564 1413 497 -700 -1630 -1901 -1340 -235 943 1635 1450 505 -673 -1626 -1838 -1268 -117 1063 1699 1487 566 -598 -1531 -1754 -1133 6 1155 1725 1477 520 -692 -1577 -1721 -1087 50 1187 1782 1497 541 -634 -1526 -1698 -1005 122 1201 1737 1426 424 -741 -1599 -1704 -1051 98 1219 1728 1363 347 -795 -1614 -1650 -910 278 1353 1830 1470 405 -761 -1553 -1575 -782 407 1414 1867 1394 356 -827 -1587 -1589 -810 320 1326 1735 1304 232 -916 -1650 -1601 -790 378 1401 1748 1262 196 -924 -1606 -1538 -720 463 1453 1774 1262 215 -880 -1591 -1465 -619 542 1487 1760 1224 169 -924 -1567 -1379 -486 658 1604 1874 1328 256 -834 -1433 -1297 -476 680 1601 1816 1236 149 -922 -1492 -1307 -434 705 1579 1733 1136 59 -1005 -1540 -1331 -395 756 1616 1789 1146 67 -944 -1440 -1162 -234 897 1698 1796 1162 54 -965 -1433 -1126 -196 909 1742 1826 1116 39 -951 -1385 -1117 -179 985 1740 1777 1100 -3 -973 -1397 -1065 -139 965 1709 1708 1009 -83 -1061 -1492 -1114 -176 914 1630 1640 902 -188 -1100 -1497 -1082 -135 948 1676 1636 887 -137 -1063 -1382 -966 10 1061 1728 1681 890 -196 -1095 -1360 -888 52 1082 1706 1594 775 -300 -1194 -1472 -994 -25 1014 1628 1484 690 -420 -1262 -1480 -1007 -10 1063 1653 1467 631 -413 -1268 -1460 -951 27 1033 1557 1336 508 -544 -1350 -1552 -999 1 1027 1506 1307 486 -568 -1367 -1492 -904 123 1082 1574 1307 437 -602 -1372 -1474 -880 135 1083 1518 1204 320 -717 -1489 -1574 -980 22 965 1401 1092 188 -858 -1536 -1564 -893 120 1029 1372 1038 173 -824 -1484 -1470 -809 225 1095 1435 1063 156 -851 -1492 -1482 -804 189 1075 1357 992 79 -941 -1541 -1513 -817 186 1038 1329 909 -1 -951 -1550 -1487 -776 242 1068 1319 907 -37 -970 -1562 -1433 -703 281 1111 1338 877 -22 -994 -1547 -1382 -646 359 1158 1375 877 -39 -917 -1424 -1279 -513 488 1246 1396 895 -42 -944 -1430 -1251 -444 493 1180 1296 748 -193 -1056 -1523 -1294 -507 471 1189 1294 754 -176 -1068 -1426 -1178 -354 617 1314 1423 832 -137 -1029 -1413 -1138 -379 566 1257 1306 693 -251 -1112 -1494 -1204 -366 595 1224 1217 608 -351 -1167 -1513 -1184 -340 595 1201 1206 551 -368 -1260 -1558 -1240 -403 519 1117 1089 435 -536 -1324 -1623 -1250 -366 575 1173 1122 468 -466 -1309 -1516 -1111 -244 680 1257 1162 486 -441 -1211 -1443 -1011 -161 763 1258 1160 463 -481 -1258 -1414 -955 -105 773 1243 1104 435 -491 -1216 -1382 -949 -118 800 1263 1089 332 -585 -1250 -1363 -926 -47 832 1262 1027 296 -598 -1258 -1368 -829 54 919 1299 1085 378 -515 -1153 -1219 -703 189 997 1391 1145 393 -517 -1141 -1201 -678 213 1036 1363 1104 303 -605 -1216 -1279 -683 193 983 1304 1011 249 -641 -1223 -1251 -646 245 1046 1299 1002 205 -671 -1216 -1173 -554 354 1136 1397 1043 225 -659 -1189 -1133 -498 368 1139 1391 1004 178 -646 -1160 -1056 -478 432 1160 1401 978 161 -653 -1138 -1089 -420 459 1139 1341 927 115 -695 -1170 -1038 -381 468 1148 1316 893 61 -744 -1201 -1061 -376 503 1173 1341 899 49 -731 -1155 -1000 -312 536 1168 1335 853 27 -754 -1167 -983 -279 575 1219 1297 797 -8 -790 -1145 -931 -234 617 1223 1245 737 -89 -863 -1195 -949 -218 617 1167 1202 693 -183 -895 -1216 -951 -220 629 1172 1199 664 -128 -836 -1134 -844 -108 731 1265 1229 659 -157 -860 -1119 -809 -91 734 1240 1178 595 -229 -975 -1194 -870 -111 678 1150 1136 537 -283 -943 -1165 -800 -71 766 1226 1106 520 -271 -924 -1129 -800 -49 785 1221 1072 476 -361 -980 -1162 -753 1 768 1204 1063 415 -364 -994 -1122 -678 83 868 1268 1109 498 -329 -938 -1039 -631 137 880 1234 1009 354 -422 -1041 -1109 -663 72 832 1182 994 335 -478 -1029 -1136 -649 152 885 1234 1004 320 -471 -999 -1044 -539 247 926 1272 1070 373 -381 -939 -987 -490 256 966 1294 1007 305 -461 -972 -963 -469 278 966 1228 927 218 -529 -1044 -1041 -517 264 924 1143 853 105 -632 -1104 -1048 -507 313 943 1143 788 98 -670 -1100 -1019 -429 339 968 1141 822 117 -603 -1002 -907 -334 454 1050 1195 795 96 -612 -1014 -934 -369 412 983 1073 680 -47 -759 -1153 -1021 -419 335 919 1053 697 -15 -724 -1067 -916 -332 420 966 1055 659 -67 -734 -1106 -917 -349 385 929 1034 600 -96 -734 -1029 -885 -217 513 1060 1082 676 -40 -698 -1005 -785 -193 580 1063 1097 670 -45 -707 -1005 -787 -178 512 1029 1016 505 -217 -829 -1094 -827 -196 517 949 944 480 -229 -836 -1041 -753 -135 602 1100 1068 615 -83 -695 -948 -644 27 710 1133 1073 549 -179 -793 -1005 -736 -71 617 1044 990 463 -266 -831 -1017 -680 -45 658 1063 978 430 -245 -815 -944 -624 42 707 1034 910 376 -327 -880 -1014 -653 -55 636 966 812 290 -393 -917 -1022 -612 61 698 1034 902 327 -386 -912 -1005 -598 44 673 1002 838 261 -464 -944 -1053 -661 27 676 949 739 130 -537 -1031 -1097 -687 -18 653 922 690 113 -547 -1036 -1033 -597 105 719 983 751 149 -536 -978 -983 -546 125 737 949 681 79 -573 -1005 -1002 -559 108 720 895 648 28 -653 -1050 -1011 -524 137 681 834 536 -93 -754 -1160 -1085 -624 79 603 758 463 -184 -829 -1189 -1080 -563 79 631 788 434 -178 -809 -1129 -965 -454 201 724 861 497 -139 -724 -1082 -980 -405 227 729 804 430 -206 -814 -1158 -992 -439 218 683 751 351 -264 -890 -1177 -988 -449 159 661 726 356 -295 -904 -1131 -936 -415 242 697 707 301 -307 -870 -1106 -926 -337 296 739 739 356 -300 -829 -1053 -814 -212 407 821 839 378 -268 -829 -1026 -814 -232 361 749 744 274 -366 -910 -1090 -814 -254 347 751 676 184 -402 -924 -1077 -785 -189 419 763 683 240 -354 -885 -1017 -707 -117 481 812 722 290 -296 -793 -919 -590 -15 576 897 805 322 -312 -809 -890 -598 -64 544 839 715 242 -385 -836 -895 -592 10 602 878 765 291 -315 -731 -815 -454 123 707 955 826 300 -291 -717 -775 -434 139 710 973 788 254 -347 -732 -765 -391 189 714 961 776 249 -330 -707 -709 -332 230 736 941 736 196 -398 -783 -805 -408 195 663 838 632 94 -490 -849 -815 -435 162 648 822 607 83 -481 -826 -768 -320 259 731 873 649 135 -429 -734 -664 -247 335 802 921 629 89 -463 -753 -681 -300 247 693 792 513 -27 -566 -838 -714 -315 271 697 798 493 -22 -564 -860 -707 -245 281 722 819 541 -13 -505 -734 -617 -195 390 814 858 539 11 -520 -739 -607 -149 449 815 848 497 -45 -510 -790 -605 -171 369 775 780 461 -103 -603 -809 -639 -189 329 693 687 354 -183 -671 -843 -654 -193 368 739 770 376 -149 -575 -761 -578 -93 452 839 804 403 -134 -568 -726 -508 -45 498 778 773 371 -161 -625 -766 -530 -57 485 824 731 378 -179 -598 -727 -532 -25 502 773 698 291 -212 -670 -790 -546 -83 420 712 608 218 -293 -703 -787 -524 -49 471 739 649 274 -249 -661 -739 -452 57 532 810 710 274 -234 -619 -698 -413 61 558 758 602 169 -351 -732 -798 -517 -28 435 653 493 52 -408 -810 -817 -490 20 525 719 532 89 -407 -780 -804 -474 1 463 656 466 40 -463 -785 -809 -459 22 452 642 493 13 -435 -754 -717 -366 113 541 714 471 33 -456 -773 -748 -429 61 495 625 420 -15 -502 -838 -751 -402 106 500 610 395 -37 -510 -787 -739 -342 157 549 646 427 -20 -463 -734 -670 -290 208 608 709 452 -20 -469 -724 -666 -273 218 622 648 390 -44 -495).
! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 11:01'!
samplesForMouseEnter

	^ #(-37 -24 -30 -30 -25 -23 -11 -8 -38 -40 -34 -21 -18 -27 -34 -20 2 11 8 10 5 7 10 14 34 28 34 54 59 47 54 25 27 43 33 48 23 40 59 63 47 46 27 47 43 41 46 50 64 57 46 57 44 48 12 17 24 28 18 23 27 -7 -17 2 4 1 -4 18 12 11 34 25 43 18 11 20 43 43 11 12 31 -5 -11 -43 -41 -17 -23 -28 -38 -33 -48 -64 -61 -53 -61 -54 -56 -73 -73 -48 -48 -63 -92 -102 -90 -92 -115 -93 -90 -109 -120 -112 -119 -141 -136 -128 -146 -143 -141 -129 -118 -139 -132 -120 -103 -100 -96 -79 -71 -83 -79 -77 -87 -73 -73 -43 -24 -5 -10 20 23 -5 -4 0 28 20 -11 20 4 -11 -23 20 27 7 8 -2 -7 -15 -27 4 0 -8 -34 -31 -38 -34 -50 -40 -64 -46 -59 -51 -82 -80 -82 -80 -89 -95 -122 -89 -97 -67 -64 -31 -21 -34 -56 -25 -35 -48 -63 -37 -54 -34 8 40 82 161 306 503 921 1638 2549 3458 4074 4290 3947 2988 1528 -293 -2417 -4592 -6693 -8734 -10727 -12641 -14255 -15466 -16249 -16383 -15965 -15159 -14019 -12574 -10934 -9124 -7214 -5191 -3092 -856 1418 3639 5667 7543 9156 10532 11608 12361 12795 12922 12755 12307 11574 10473 8964 7129 5084 2911 596 -1773 -4103 -6374 -8593 -10593 -12355 -13748 -14599 -14866 -14527 -13593 -12109 -10146 -7697 -4933 -2022 881 3689 6302 8638 10580 12067 13052 13602 13774 13543 13046 12276 11271 9965 8426 6677 4771 2731 607 -1469 -3420 -5217 -6790 -8196 -9401 -10377 -11001 -11242 -11095 -10600 -9729 -8581 -7114 -5423 -3563 -1566 488 2577 4556 6448 8234 9786 11143 12136 12756 13034 12936 12489 11744 10678 9320 7673 5775 3813 1813 -182 -2113 -3924 -5606 -7123 -8439 -9477 -10213 -10688 -10855 -10663 -10109 -9278 -8125 -6682 -5004 -3147 -1171 791 2762 4655 6386 7944 9222 10201 10800 11120 11163 10885 10313 9434 8363 7050 5604 4048 2395 711 -872 -2376 -3707 -4894 -5875 -6667 -7214 -7489 -7480 -7251 -6739 -6039 -5102 -3987 -2754 -1475 -207 1094 2392 3590 4686 5639 6469 7178 7758 8142 8273 8187 7883 7398 6803 6056 5188 4152 3075 1968 866 -184 -1197 -2143 -2964 -3615 -4163 -4572 -4907 -5100 -5141 -5018 -4723 -4288 -3725 -3031 -2198 -1246 -276 704 1661 2529 3377 4140 4835 5333 5721 5941 6098 6048 5846 5498 5047 4467 3816 3131 2444 1659 856 57 -636 -1301 -1946 -2549 -3099 -3548 -3871 -4057 -4143 -4153 -3999 -3753 -3380 -2893 -2338 -1742 -1098 -391 380 1111 1822 2543 3206 3784 4283 4638 4868 4955 4894 4713 4385 3938 3365 2679 1910 1089 272 -564 -1379 -2145 -2902 -3583 -4127 -4562 -4866 -5010 -4949 -4785 -4468 -4026 -3463 -2817 -2070 -1256 -398 462 1297 2147 2922 3613 4211 4732 5178 5449 5617 5608 5456 5168 4727 4120 3404 2561 1646 706 -218 -1212 -2160 -3018 -3688 -4293 -4726 -5015 -5195 -5231 -5096 -4788 -4321 -3754 -3057 -2240 -1363 -433 515 1446 2340 3118 3820 4401 4851 5133 5256 5195 5011 4696 4209 3627 2934 2168 1334 434 -475 -1357 -2211 -2981 -3669 -4285 -4771 -5116 -5322 -5382 -5315 -5067 -4701 -4169 -3518 -2775 -1937 -1036 -165 735 1626 2440 3115 3681 4154 4467 4625 4681 4589 4344 4008 3583 3008 2353 1615 777 -57 -872 -1713 -2486 -3206 -3843 -4391 -4840 -5116 -5273 -5277 -5128 -4831 -4418 -3868 -3252 -2533 -1744 -898 -67 780 1570 2300 2913 3463 3874 4159 4331 4353 4248 4028 3668 3184 2633 1949 1216 426 -341 -1109 -1852 -2512 -3102 -3597 -3983 -4224 -4349 -4339 -4183 -3910 -3520 -3065 -2510 -1885 -1242 -588 54 685 1249 1839 2352 2777 3106 3327 3466 3488 3417 3234 2948 2617 2185 1671 1117 564 -15 -608 -1174 -1700 -2196 -2650 -3039 -3296 -3481 -3587 -3568 -3460 -3273 -2983 -2614 -2156 -1658 -1154 -626 -89 421 921 1413 1865 2266 2602 2818 3004 3090 3036 2944 2824 2565 2214 1837 1422 954 469 -15 -490 -960 -1413 -1806 -2139 -2421 -2703 -2877 -2949 -2974 -2964 -2820 -2608 -2340 -1972 -1592 -1154 -680 -190 267 745 1183 1592 1947 2225 2473 2624 2696 2723 2692 2565 2408 2219 1916 1579 1200 797 368 -115 -549 -994 -1408 -1767 -2037 -2241 -2394 -2469 -2497 -2427 -2317 -2150 -1887 -1551 -1197 -778 -346 103 544 942 1390 1766 2077 2353 2535 2657 2697 2700 2615 2473 2257 1980 1677 1287 871 466 21 -377 -757 -1134 -1464 -1713 -1932 -2096 -2208 -2243 -2235 -2168 -2051 -1854 -1566 -1229 -888 -499 -100 319 719 1124 1481 1801 2084 2306 2434 2469 2476 2431 2287 2101 1825 1527 1194 836 483 123 -231 -593 -931 -1251 -1541 -1796 -1978 -2122 -2188 -2162 -2106 -1903 -1717 -1467 -1140 -814 -463 -115 254 617 950 1284 1550 1753 1880 1992 1988 1930 1829 1695 1475 1226 924 603 293 -27 -345 -640 -954 -1217 -1471 -1687 -1832 -1917 -1985 -1960 -1900 -1750 -1546 -1356 -1092 -771 -469 -135 200 555 895 1176 1429 1628 1786 1920 1968 1966 1924 1842 1704 1464 1200 922 600 285 -21 -348 -614 -840 -1073 -1266 -1397 -1501 -1595 -1635 -1638 -1585 -1464 -1311 -1151 -971 -735 -501 -267 -43 210 398 643 865 1050 1206 1333 1419 1418 1410 1383 1281 1147 996 803 621 437 226 23 -148 -309 -466 -611 -748 -849 -912 -964 -1016 -1039 -1032 -990 -868 -757 -621 -440 -256 -118 43 194 354 470 564 653 718 780 809 793 748 672 587 453 321 151 8 -142 -308 -499 -647 -819 -950 -1073 -1169 -1243 -1276 -1282 -1262 -1219 -1140 -1016 -921 -809 -624 -475 -335 -142 25 182 339 483 613 702 796 856 899 898 902 858 826 735 656 529 395 263 146 -14 -167 -346 -480 -633 -715 -806 -878 -955 -958 -978 -930 -891 -794 -705 -616 -477 -336 -243 -112 4 109 205 276 332 430 480 519 508 521 513 518 463 384 319 227 112 -8 -100 -202 -348 -505 -596 -725 -833 -906 -951 -940 -927 -883 -806 -692 -542 -365 -207 -60 80 249 400 483 584 626 650 657 634 585 493 443 351 238 158 63 -30 -123 -185 -279 -359 -400 -470 -529 -570 -561 -594 -601 -588 -570 -524 -477 -414 -328 -236 -141 -37 48 99 204 287 391 441 472 495 516 476 418 371 292 204 99 -10 -43 -118 -207 -253 -303 -341 -349 -359 -342 -338 -305 -264 -227 -164 -119 -46 38 99 138 174 227 234 215 231 262 234 227 237 273 218 198 192 192 135 119 90 44 -27 -40 -73 -99 -132 -149 -154 -128 -92 -46 -23 38 59 59 51 57 50 28 17 37 -10 2 -4 -40 -71 -96 -126 -142 -194 -227 -274 -300 -345 -362 -369 -357 -345 -335 -303 -256 -223 -191 -141 -116 -71 -80 -96 -74 -86 -120 -141 -181 -249 -315 -372 -388 -397 -430 -449 -460 -462 -417 -391 -357 -299 -253 -175 -119 -34 43 128 198 241 282 357 410 436 444 472 473 441 413 358 260 191 96 -12 -74 -164 -270 -346 -437 -513 -594 -652 -704 -728 -750 -735 -668 -626 -544 -456 -341 -244 -138 -34 89 195 293 381 459 476 549 597 600 620 601 572 532 475 417 351 233 135 63 -44 -142 -230 -295 -385 -405 -450 -472 -492 -463 -482 -477 -460 -440 -393 -339 -326 -257 -190 -126 -35 63 146 201 283 355 393 401 427 441 411 382 335 282 241 200 133 90 30 -8 -64 -116 -142 -175 -213 -223 -244 -274 -280 -272 -280 -264 -241 -262 -249 -228 -211 -156 -128 -64 -21 43 80 129 142 187 215 227 230 237 243 254 266 267 273 256 254 251 253 236 208 164 128 69 54 30 -18 -69 -86 -106 -143 -167 -188 -218 -246 -247 -233 -220 -169 -138 -95 -44 -23 18 69 116 188 236 298 380 440 503 516 538 544 516 485 475 427 374 310 292 220 109 57 5 -100 -184 -276 -362 -436 -480 -512 -539 -531 -524 -511 -452 -371 -302 -260 -169 -95 -46 59 156 208 262 336 397 421 436 441 427 427 414 368 332 298 237 197 145 93 46 0 -48 -89 -112 -138 -132 -118 -73 -23 0).
! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 10:58'!
samplesForMouseLeave

	^ #(230 254 256 242 234 246 206 211 179 175 133 111 106 91 46 53 35 54 17 40 67 98 79 114 127 167 162 133 130 119 91 82 98 90 75 87 45 19 -17 1 -16 -1 8 12 -1 53 71 85 109 117 106 159 138 154 133 161 122 138 85 72 67 51 46 20 6 3 -8 8 -8 -4 -1 22 38 53 43 85 71 103 88 87 45 51 43 59 16 -9 -17 1 -45 -20 -32 -8 -38 3 -20 20 43 53 43 37 24 54 30 58 59 32 20 33 17 8 -30 -56 -72 -111 -133 -127 -122 -111 -129 -111 -108 -112 -108 -111 -135 -100 -130 -111 -158 -125 -121 -104 -96 -111 -135 -106 -111 -104 -133 -111 -143 -137 -140 -130 -109 -103 -119 -62 -59 -67 -62 -33 -41 -12 -43 -46 -43 -38 -71 -87 -100 -80 -125 -124 -145 -132 -145 -111 -148 -106 -95 -79 -51 -14 -17 8 22 85 93 111 116 127 138 133 96 67 53 72 45 -22 -30 -20 -33 16 27 121 177 335 500 756 1023 1362 1738 2131 2465 2769 2932 3032 2951 2609 1980 1102 -43 -1326 -2769 -4181 -5598 -6852 -7906 -8630 -9014 -8982 -8390 -7257 -5645 -3637 -1415 1029 3476 5953 8267 10196 11595 12386 12531 12089 10938 9187 6826 4120 1124 -1933 -4946 -7699 -10138 -12005 -13244 -13719 -13418 -12384 -10706 -8485 -5808 -2796 421 3640 6629 9344 11524 13121 14054 14261 13735 12528 10643 8209 5307 2125 -1265 -4592 -7693 -10426 -12683 -14290 -15200 -15273 -14514 -12881 -10583 -7628 -4171 -448 3303 6911 10154 12921 14914 16133 16383 15750 14259 12040 9164 5772 2083 -1721 -5395 -8751 -11629 -13799 -15261 -15758 -15399 -14104 -11989 -9176 -5801 -2022 1844 5593 9006 11905 14064 15405 15842 15387 13957 11834 9005 5754 2215 -1402 -4888 -8044 -10744 -12739 -14054 -14519 -14216 -13070 -11186 -8680 -5729 -2501 789 4023 6924 9450 11320 12489 12920 12629 11614 9949 7764 5214 2411 -495 -3327 -5845 -8006 -9690 -10820 -11288 -11133 -10271 -8914 -6992 -4820 -2357 174 2643 4910 6853 8361 9360 9729 9537 8811 7573 5908 3939 1799 -448 -2695 -4641 -6343 -7628 -8525 -8926 -8785 -8177 -7118 -5640 -3861 -1943 43 2047 3813 5332 6502 7292 7601 7455 6837 5872 4578 3054 1305 -482 -2228 -3781 -5133 -6187 -6850 -7136 -7039 -6529 -5688 -4489 -3071 -1489 109 1726 3166 4447 5398 6034 6235 6151 5651 4847 3747 2483 997 -464 -1915 -3221 -4323 -5159 -5708 -5929 -5812 -5328 -4601 -3635 -2478 -1165 75 1324 2432 3366 4011 4423 4557 4439 3961 3326 2470 1494 422 -616 -1596 -2506 -3267 -3797 -4124 -4258 -4142 -3740 -3235 -2527 -1702 -832 43 919 1718 2391 2820 3151 3276 3206 2988 2569 1983 1321 587 -125 -837 -1516 -2112 -2554 -2854 -2951 -2883 -2669 -2285 -1771 -1186 -539 119 779 1363 1889 2223 2457 2528 2451 2177 1776 1271 681 88 -500 -1079 -1592 -2009 -2283 -2420 -2354 -2230 -1904 -1460 -942 -385 198 766 1263 1660 1967 2138 2185 2094 1889 1518 1102 577 56 -463 -971 -1423 -1799 -2070 -2222 -2244 -2112 -1910 -1554 -1166 -679 -162 353 797 1195 1505 1733 1844 1863 1696 1489 1144 731 267 -201 -706 -1157 -1525 -1834 -2036 -2089 -2033 -1893 -1644 -1281 -865 -367 85 572 968 1342 1591 1783 1812 1699 1481 1186 811 413 -66 -534 -965 -1333 -1699 -1920 -2046 -2022 -1964 -1721 -1410 -989 -505 -14 471 929 1337 1673 1863 1989 1993 1854 1634 1318 898 477 -50 -484 -940 -1320 -1657 -1852 -1978 -1928 -1778 -1531 -1199 -785 -316 174 634 1092 1470 1789 2022 2107 2081 1999 1715 1374 939 488 -27 -493 -953 -1326 -1644 -1880 -1997 -1960 -1875 -1639 -1345 -927 -511 -85 342 834 1202 1570 1801 1938 1989 1893 1721 1436 1068 663 216 -185 -632 -1040 -1384 -1625 -1783 -1857 -1836 -1659 -1466 -1131 -748 -359 46 476 852 1200 1445 1600 1678 1710 1544 1297 1003 676 246 -175 -621 -990 -1353 -1628 -1855 -1947 -1965 -1851 -1639 -1341 -973 -524 -106 376 776 1160 1492 1715 1815 1838 1738 1589 1279 979 559 106 -285 -731 -1128 -1450 -1731 -1922 -2001 -2005 -1863 -1636 -1316 -948 -545 -137 306 755 1126 1466 1717 1893 1955 1915 1760 1531 1190 844 384 -61 -511 -921 -1299 -1584 -1773 -1889 -1880 -1730 -1520 -1152 -716 -256 156 622 1057 1437 1709 1873 1925 1902 1718 1431 1103 706 272 -164 -563 -915 -1224 -1450 -1592 -1642 -1596 -1441 -1194 -879 -527 -133 274 705 1015 1294 1515 1610 1671 1592 1412 1195 876 556 214 -153 -495 -800 -1037 -1189 -1307 -1308 -1260 -1087 -879 -626 -335 8 321 651 900 1137 1299 1402 1387 1341 1165 950 689 388 50 -266 -572 -823 -1028 -1203 -1287 -1265 -1197 -1052 -847 -539 -253 72 411 708 976 1236 1404 1470 1433 1350 1181 965 679 366 71 -217 -547 -789 -971 -1039 -1082 -1008 -884 -726 -476 -185 104 403 697 939 1097 1232 1247 1257 1124 955 756 534 224 -38 -332 -537 -731 -889 -981 -992 -937 -839 -747 -547 -324 -111 116 343 547 724 847 924 910 902 777 676 482 301 85 -104 -272 -445 -597 -702 -779 -782 -800 -766 -653 -500 -390 -187 -59 114 259 417 508 603 643 676 626 572 463 366 200 54 -119 -237 -398 -501 -637 -698 -731 -722 -714 -624 -519 -369 -246 -82 54 248 372 492 540 592 589 526 426 358 211 56 -90 -206 -372 -476 -592 -640 -666 -661 -598 -487 -367 -211 -66 151 290 430 526 663 695 753 719 724 629 563 430 300 153 20 -85 -158 -251 -296 -309 -301 -269 -217 -153 -51 33 151 230 345 429 495 527 558 568 572 508 421 321 240 111 43 -114 -175 -232 -267 -288 -305 -300 -214 -180 -79 4 104 206 324 403 511 555 580 585 618 563 498 458 382 308 279 198 148 108 95 51 51 50 66 91 104 116 162 183 214 195 253 261 274 279 267 266 285 266 285 254 258 254 243 269 235 180 175 154 179 159 119 164 216 227 274 314 371 398 461 495 532 509 485 498 401 325 271 164 100 -27 -116 -166 -204 -230 -227 -222 -166 -106 -4 127 258 364 485 577 663 708 753 743 718 608 547 440 298 188 75 -71 -153 -204 -227 -246 -208 -198 -140 -85 43 137 254 343 438 524 593 610 631 605 572 511 456 338 250 154 62 -17 -33 -103 -77 -114 -69 -38 59 117 193 288 369 390 429 438 456 408 353 303 235 140 80 -29 -95 -164 -192 -208 -185 -166 -119 -58 95 198 288 371 488 519 563 598 582 547 482 387 277 112 4 -132 -179 -319 -376 -447 -416 -416 -382 -298 -169 -80 69 211 364 490 624 718 774 789 811 768 721 601 509 384 271 154 33 -95 -138 -216 -259 -253 -237 -198 -171 -109 -22 56 167 264 374 450 530 551 584 595 553 500 458 348 275 146 51 -62 -166 -201 -254 -295 -266 -253 -164 -137 -59 11 98 214 343 403 514 550 603 632 593 543 509 405 337 196 111 17 -61 -146 -188 -242 -229 -224 -201 -187 -129 -104 -37 77 112 166 237 275 311 292 292 290 235 162 111 43 4 -59 -72 -124 -140 -140 -117 -108 -61 -24 56 109 158 169 240 264 284 292 275 266 256 185 124 109 64 1 -41 -72 -87 -80 -77 -46 -35 -11 41 43 56 69 101 116 119 133 108 51 56 53 59 9 43 32 67 95 104 109 150 167 171 183 204 213 190 171 172 122 130 98 95 30 16 -20 -46 -88 -83 -74 -56 -19 33 85 119 201 272 279 319 342 364 369 376 335 325 282 213 158 108 8 -30 -116 -130 -169 -182 -164 -140 -137 -82 -54 32 116 175 225 284 317 379 369 377 342 314).
! !


!TrashCanMorph class methodsFor: 'class initialization' stamp: 'dgd 4/4/2006 14:49'!
initialize
	"initialize the receiver"

	self registerInFlapsRegistry.

	self initializePictures.
! !

!TrashCanMorph class methodsFor: 'class initialization' stamp: 'dgd 9/2/2004 13:25'!
initializePictures
	" 
	TrashCanMorph initializePictures. 
	"
	TrashPicOn := self initializeTrashPicOn.
	TrashPic := self initializeTrashPic! !

!TrashCanMorph class methodsFor: 'class initialization' stamp: 'dgd 9/2/2004 13:13'!
initializeTrashPic
	^(Form
	extent: 72@72
	depth: 32
	fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 35593500 438246684 773791004 1109335324 706682140 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 52370716 857677084 1914641692 2971606300 3995016476 4280229148 4280229148 4280229148 4280229148 3089046812 1159666972 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 35593500 1059003676 2535398684 3944684828 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3508477212 1595874588 102702364 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 924785948 2401180956 3844021532 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4282136620 4281149988 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3844021532 2015304988 287251740 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 790568220 2266963228 3726581020 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4282333741 4287266903 4292200065 4294962328 4294699158 4291279224 4286937941 4282597168 4280229148 4280229148 4280229148 4280229148 4280229148 4095679772 2451512604 572464412 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 673127708 2132745500 3609140508 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4282333741 4287266903 4292200065 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292331393 4286346064 4281084195 4280229148 4280229148 4280229148 4280229148 4229897500 2870943004 941563164 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 52370716 1495211292 3424591132 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4282333741 4287266903 4292200065 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294370451 4289240168 4283320374 4280229148 4280229148 4280229148 4280229148 4280229148 3307150620 1226775836 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 169811228 1813978396 3726581020 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4281544487 4287069525 4292134272 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962071 4294103679 4290947944 4288252760 4293316998 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292068480 4286148685 4280952610 4280229148 4280229148 4280229148 4280229148 3407813916 1310661916 18816284 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 320806172 2115968284 3944684828 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4283912250 4289897581 4294633365 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294895763 4293379184 4291467593 4292713278 4293501761 4281935888 4282330129 4292581949 4289495097 4291473254 4294962327 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294238866 4288648034 4282005034 4280229148 4280229148 4280229148 4280229148 3491699996 1394547996 18816284 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 438246684 2434735388 4095679772 4280229148 4280229148 4280229148 4280229148 4280229148 4281149988 4286609233 4292594564 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294961814 4293774199 4291796299 4293041983 4293501761 4293501761 4293501761 4293501761 4279898631 4284104473 4293370432 4293370432 4293370432 4291596347 4291207769 4294830228 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294699158 4289503082 4282597168 4280229148 4280229148 4280229148 4280229148 3558808860 1478434076 35593500 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1646206236 4028570908 4280229148 4280229148 4280229148 4280229148 4280229148 4283189045 4289305960 4294436243 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294564997 4292191827 4292779071 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4293173055 4278321409 4285813024 4293370432 4293370432 4293370432 4293370432 4293370432 4292319293 4290943568 4294500750 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294896535 4290358129 4283451958 4280229148 4280229148 4280229148 4280229148 3625917724 1562320156 52370716 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 203365660 3089046812 4280229148 4280229148 4280229148 4280229148 4280229148 4283189045 4290621556 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294896278 4293378926 4292123203 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4290281523 4284498715 4278190080 4287521831 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4292910142 4290942281 4294105222 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291213433 4284307006 4280229148 4280229148 4280229148 4280229148 3676249372 1646206236 69147932 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2803834140 4280229148 4280229148 4280229148 4280229148 4282333741 4290423922 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294829713 4292456284 4292647743 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4290741813 4285484319 4280161544 4278190080 4278190080 4278190080 4281081612 4288376107 4293239103 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293107519 4290678852 4293579136 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292002431 4283715129 4280229148 4280229148 4280229148 4280229148 3743358236 1713315100 18816284 0 0 0 0 0 0 0 0 0 0 0 0 0 1243553052 4280229148 4280229148 4280229148 4280294940 4286871892 4294436243 4294962328 4294962328 4294962328 4294962328 4294962328 4294962327 4292785762 4293107520 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4292516157 4286667300 4280621578 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4280358665 4287193126 4292910398 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293173311 4290481215 4292986745 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4289766508 4281741865 4280229148 4280229148 4280229148 4280229148 2199854364 0 0 0 0 0 0 0 0 0 0 0 0 0 1310661916 4280229148 4280229148 4280360476 4288776274 4293515148 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293248629 4290414395 4293304640 4293501761 4293501761 4293501761 4290873142 4284367386 4278781443 4278321666 4278716424 4279111182 4279242768 4279242768 4279242768 4279242768 4279242768 4279242768 4279308561 4278979596 4278584838 4279438597 4285944609 4292319035 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293304640 4290942021 4294895507 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294304658 4287266903 4280623647 4280229148 4280229148 4280229148 1511988508 0 0 0 0 0 0 0 0 0 0 0 0 1025449244 4280229148 4280229148 4281740320 4293370432 4286735669 4285686849 4292594564 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4290619751 4287720239 4288376107 4282067473 4278190080 4278453252 4279505940 4280295456 4280361249 4280361249 4280427042 4280427042 4280427042 4280427042 4280427042 4280427042 4280427042 4280427042 4280427042 4280229663 4279242768 4278913028 4284761628 4291530296 4293370432 4293370432 4292779069 4289427761 4288904509 4291736169 4294962070 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294830742 4290687091 4282333742 4280229148 4280229148 4129234204 455023900 0 0 0 0 0 0 0 0 0 0 0 773725211 4280229148 4280229148 4281871648 4293370432 4293370432 4288442418 4281280544 4284568890 4291410554 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291147381 4283978293 4280163612 4281479730 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281348144 4279966491 4278518786 4282987284 4284896044 4288910687 4294304402 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291805053 4288516449 4290160751 4294370195 4290161008 4280229148 4280229148 4280229148 2082413852 0 0 0 0 0 0 0 0 0 0 0 1074596876 4280229148 4280229148 4281477407 4293370432 4293370432 4293370432 4292253244 4284960041 4280229148 4283254065 4290423922 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292923271 4285228105 4281940279 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282071864 4285557065 4292791684 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292857478 4287266647 4285556808 4290029422 4294764950 4294962328 4294962328 4291805309 4280229148 4280229148 4280229148 1847335449 0 0 0 0 0 0 0 0 0 0 0 1040581893 4280229148 4280229148 4280294684 4293305153 4293370432 4293370432 4293370432 4293370432 4291004729 4284631336 4280294940 4283122480 4290752628 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294764950 4289042791 4283715910 4283453520 4283782485 4283782485 4283782485 4283782485 4283782485 4283782485 4283782485 4283782485 4283782485 4283650899 4283847497 4289043049 4294830742 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294633365 4289963629 4284438591 4285622345 4291936639 4294962328 4294962328 4294962328 4294962328 4294962328 4290687092 4280229148 4280229148 4280229148 1896877839 167772160 0 0 0 0 0 0 0 0 0 0 788529152 4229831707 4280229148 4280229148 4292977735 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4291333434 4285091113 4280426269 4283385907 4291016054 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293318026 4286610012 4284308569 4284900966 4284900966 4284900966 4284900966 4284900966 4284374619 4286412639 4292923529 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292857478 4287069525 4282794033 4287464024 4293580940 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4289174118 4280229148 4280229148 4280229148 1527186950 1056964608 16777216 0 0 0 0 0 0 0 0 0 687865856 4045282331 4280229148 4280229148 4290219337 4293370689 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4291662139 4285485354 4280492061 4283648821 4291410298 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4290490234 4285821028 4285098086 4285755229 4290950523 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294699157 4290095214 4284109628 4283122996 4289437289 4294567572 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4285162309 4280229148 4280229148 4062059547 1275068416 1275068416 419430400 0 0 0 0 0 0 0 0 0 587202560 3843889946 4280229148 4280229148 4280229148 4282990123 4290943054 4293371203 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4291924796 4285945387 4280886559 4284043321 4291739260 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293318026 4287464024 4282465583 4286148686 4291936639 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292528515 4280558111 4280229148 4280229148 3592165913 1275068416 1275068416 352321536 0 0 0 0 0 0 0 0 0 503316480 3659274777 4280229148 4280229148 4280229148 4280229148 4280229148 4281543715 4289628488 4293240390 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4292713021 4287850801 4282463782 4286016071 4294238353 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294896535 4290950006 4284833346 4283780921 4289371497 4294304402 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291476090 4281347365 4280229148 4280229148 4280229148 3105495063 1275068416 1275068416 150994944 0 0 0 0 0 0 0 0 0 402653184 2014318350 3676051994 4280229148 4280229148 4280229148 4280229148 4280627012 4280099376 4280426270 4288050752 4293043528 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4289953846 4286276665 4291080047 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293909903 4288319072 4283451959 4286740563 4292528771 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293909902 4289963374 4285885515 4281741865 4280229148 4280229148 4280229148 4280229148 4280229148 2249396497 1275068416 1207959552 0 0 0 0 0 0 0 0 0 0 301989888 1275068416 1291845632 3155826711 4280229148 4280229148 4280229148 4281352290 4280166989 4280167246 4280561742 4280098343 4286407480 4292649802 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4291924796 4292586841 4294565770 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291805053 4286148686 4285293638 4289963629 4294633365 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294764950 4291607675 4287464281 4283386166 4280294940 4280558630 4281679176 4281151542 4280229148 4280229148 4280229148 4280229148 3877444378 1375928834 1275068416 1006632960 0 0 0 0 0 0 0 0 0 0 218103808 1275068416 1275068416 2685867284 4280229148 4280229148 4280229148 4281286239 4280166989 4280166989 4280166989 4280167246 4280364881 4280297276 4284567602 4292190283 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4292844863 4291666774 4293579395 4294962328 4294962328 4294962328 4292923271 4288845156 4289765996 4294238353 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293186441 4289108583 4284964931 4281149988 4281152831 4282472305 4283658645 4284647089 4285109445 4285109703 4281482312 4280229148 4280229148 3424327961 2920814358 1661602057 1275068416 1275068416 788529152 0 0 0 0 0 0 0 0 0 0 117440512 1275068416 1275068416 2434077459 4280229148 4280229148 4280229148 4281220444 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166990 4280363589 4282661678 4291467850 4293304897 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293504076 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294764950 4291410554 4286937941 4282596911 4280427301 4281879135 4283395214 4284713140 4285240001 4285174722 4285174980 4285175238 4285109703 4284978631 4280427301 4280229148 3860667162 1275068416 1275068416 1275068416 1275068416 1275068416 570425344 0 0 0 0 0 0 0 0 0 0 0 285212672 922746880 2198999312 4280229148 4280229148 4280229148 4281088342 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280232521 4281675823 4290547784 4293370947 4293370432 4293370432 4293370432 4293370432 4293370432 4293502790 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293975439 4289766508 4285424968 4281215781 4280229664 4281877848 4283461009 4284778934 4285107900 4285108414 4285174464 4285240002 4285174979 4285175237 4285175238 4285044167 4284319411 4280229148 4280229148 3172603927 1275068416 1275068416 1275068416 1275068416 1275068416 167772160 0 0 0 0 0 0 0 0 0 0 0 0 0 1745948687 4280229148 4280229148 4280229148 4280890702 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280232779 4281018928 4289496903 4293305926 4293370432 4293370432 4293370432 4293370432 4294962327 4294962328 4294962328 4294962328 4294962328 4294962328 4292923270 4288253535 4283846459 4280426525 4280229149 4281548879 4283262598 4284515245 4284844725 4284976056 4285042362 4285173949 4285174463 4285174465 4285240259 4285175237 4285175238 4285109703 4285109704 4283330711 4280229148 4280229148 2685867284 1275068416 1275068416 1275068416 1275068416 738197504 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1393429773 4280229148 4280229148 4280229148 4280758084 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280232779 4280427050 4288576322 4293174856 4293370432 4293370432 4294829969 4294962328 4294962328 4293975439 4288976998 4283518008 4280229148 4280229148 4281218368 4282932603 4284185249 4284580781 4284712625 4284844212 4284910519 4285042106 4285108156 4285173951 4285174464 4285240258 4285240516 4285174981 4285109702 4285109704 4285044168 4282341750 4280229148 4280229148 2333348370 1275068416 1090519040 452984832 318767104 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1024002056 4280229148 4280229148 4280229148 4280625722 4281285730 4281746538 4282272628 4282601850 4282535800 4282404471 4282272885 4281746282 4280758871 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280495950 4280295203 4287393598 4292912715 4294434184 4290358129 4284964931 4280623647 4280229148 4280756268 4282207587 4283525774 4284185252 4284317353 4284514989 4284646831 4284778418 4284910262 4285041848 4285042619 4285108414 4285174208 4284977859 4284846533 4284715461 4284584390 4284518599 4284387271 4284256199 4281418325 4280229148 4280229148 2014318350 1275068416 654311424 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 687865856 4246608923 4280229148 4280229148 4280624683 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282667644 4281614697 4280627541 4280166989 4280166989 4280232525 4280627283 4281022041 4281285462 4280229406 4280820768 4280229148 4280558374 4281482059 4282669173 4283592342 4283921822 4284119459 4284251559 4284448938 4284646574 4284712626 4284844469 4284844985 4284714175 4284452289 4284255685 4283993286 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280823351 4280229148 4280229148 1678379273 1275068416 335544320 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 553648128 4028505115 4280229148 4280229148 4280360736 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282272628 4280693078 4280495441 4280824662 4281219163 4281548384 4281943399 4281747555 4282076265 4282802308 4283329428 4283527065 4283790237 4283987874 4284251046 4284383145 4284580781 4284516278 4284320447 4283993028 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283795650 4280229406 4280229148 4263386139 1359086082 1275068416 134217728 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 452984832 3793558298 4280229148 4280229148 4280229148 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283128452 4282206834 4281285214 4281416798 4281745763 4282009191 4282538367 4282934412 4283197841 4283526806 4283789723 4283922080 4284119975 4284122035 4284057790 4283927494 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283201446 4280229148 4280229148 4028505115 1275068416 1241513984 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 335544320 3541834265 4280229148 4280229148 4280229148 4283194760 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283062660 4282404212 4282008679 4282206570 4282669438 4283132048 4283394965 4283658908 4283923885 4283991741 4283861958 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282540935 4280229148 4280229148 3692829466 1275068416 1107296256 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 234881024 3306887448 4280229148 4280229148 4280229148 4283129481 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283062659 4282732919 4282404716 4283463075 4283794104 4283861957 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281946477 4280229148 4280229148 3357219096 1275068416 956301312 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 117440512 3071875095 4280229148 4280229148 4280229148 4283063688 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281153350 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281550170 4280229148 4280229148 3021543191 1275068416 788529152 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 2836928021 4280229148 4280229148 4280229148 4282932357 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280624684 4283597496 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281153864 4280229148 4280229148 2685867284 1275068416 637534208 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2551649556 4280229148 4280229148 4280229148 4282800512 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280756528 4283465394 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280757557 4280229148 4280229148 2350125586 1275068416 486539264 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2232751123 4280229148 4280229148 4280229148 4282603130 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280888373 4283465394 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280361251 4280229148 4280229148 2014318350 1275068416 335544320 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1913852433 4280229148 4280229148 4280229148 4282405233 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281350216 4283861958 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283663804 4280229148 4280229148 4280229148 1695156745 1275068416 167772160 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1561399311 4280229148 4280229148 4280229148 4282141543 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282536308 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283267498 4280229148 4280229148 4280229148 1359086082 1275068416 33554432 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1175325964 4280229148 4280229148 4280229148 4281812060 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194761 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282871191 4280229148 4280229148 4028505115 1275068416 1157627904 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 788989446 4280229148 4280229148 4280229148 4281416526 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194504 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282474885 4280229148 4280229148 3709606682 1275068416 989855744 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 536870912 4179500059 4280229148 4280229148 4281086270 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194503 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282078579 4280229148 4280229148 3357219096 1275068416 838860800 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 419430400 3944553243 4280229148 4280229148 4280624941 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281748580 4280229148 4280229148 3038320407 1275068416 687865856 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 301989888 3709606682 4280229148 4280229148 4280360994 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281483862 4280229148 4280229148 2702644501 1275068416 536870912 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 201326592 3474659865 4280229148 4280229148 4280229148 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283861958 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281153864 4280229148 4280229148 2366903058 1275068416 369098752 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 100663296 3239713048 4280229148 4280229148 4280229148 4283194760 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283795906 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280823866 4280229148 4280229148 2031095566 1275068416 218103808 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2987988758 4280229148 4280229148 4280229148 4283129224 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283333548 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280559404 4280229148 4280229148 1695222281 1275068416 67108864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2702710293 4280229148 4280229148 4280229148 4283063687 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283128453 4282870677 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283861958 4280229406 4280229148 4280229148 1375928834 1191182336 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2400654612 4280229148 4280229148 4280229148 4282866049 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282930813 4282606987 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283663547 4280229148 4280229148 4045282331 1275068416 1040187392 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2048201747 4280229148 4280229148 4280229148 4282536565 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282667124 4282409091 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283333549 4280229148 4280229148 3709606682 1275068416 889192448 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1712525841 4280229148 4280229148 4280229148 4282140774 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282403434 4282276732 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283069087 4280229148 4280229148 3390773528 1275068416 738197504 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1292898062 4280229148 4280229148 4280229148 4281679187 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282140258 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282607244 4280229148 4280229148 3038320407 1275068416 570425344 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 688063235 4095613979 4280229148 4280229148 4280756528 4282800511 4283194247 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281876825 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281550427 4280229148 4280229148 2719421717 1275068416 419430400 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 503316480 2736199189 4280229148 4280229148 4280229148 4280229148 4280822579 4282799998 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281613392 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283795907 4280427560 4280229148 4280229148 2383680274 1275068416 268435456 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 318767104 1291845632 2987988758 4280229148 4280229148 4280229148 4280229148 4280229148 4281547599 4283128710 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281349959 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281946476 4280229148 4280229148 4280229148 1997475342 1275068416 117440512 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 1040187392 1275068416 2232553745 4062059547 4280229148 4280229148 4280229148 4280229148 4280756271 4282865276 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281086270 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283795648 4281880425 4280229148 4280229148 4280229148 4162722843 1359086082 1241513984 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 150994944 1073741824 1275068416 1594361863 3491502617 4280229148 4280229148 4280229148 4280229148 4280295200 4282206309 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280822580 4282276732 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283201446 4281946733 4280625712 4280229148 4280229148 4280229148 4280229148 3390773528 1275068416 1073741824 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 704643072 1258291200 1291845632 2635470100 4213054491 4280229148 4280229148 4280229148 4280229148 4281283909 4283128709 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280558889 4282408833 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283267755 4281946733 4280757556 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4229831707 1846348812 1275068416 771751936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 285212672 1073741824 1275068416 1846348812 3810335514 4280229148 4280229148 4280229148 4280229148 4280624683 4282931071 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280295199 4282540935 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283795649 4282540937 4281087812 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4213054491 2400457490 1275068416 1275068416 402653184 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33554432 687865856 1258291200 1392706307 3055097879 4280229148 4280229148 4280229148 4280229148 4280295200 4282404205 4283194246 4283194246 4283194246 4283194246 4283194246 4282996607 4280229148 4282673038 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283267498 4281814375 4280427560 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4246608923 3273267480 1812728843 1275068416 1275068416 1006632960 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 268435456 1056964608 1275068416 2198999312 4045282331 4280229148 4280229148 4280229148 4280229148 4281745238 4283194247 4283194246 4283194246 4283194246 4282732917 4280229148 4282804884 4283927751 4283927751 4283927751 4283927751 4283861957 4282739090 4281153606 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4028505115 2836928021 1627981832 1275068416 1275068416 1275068416 1056964608 167772160 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33554432 654311424 1258291200 1560807175 3407550744 4280229148 4280229148 4280229148 4280229148 4281020475 4283129225 4283194246 4283194246 4282469228 4280229148 4282937242 4283927751 4283927751 4283663805 4282276475 4280691506 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3575388697 2316505617 1342308866 1275068416 1275068416 1275068416 1073741824 553648128 33554432 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 251658240 1040187392 1275068416 2484409363 4145945627 4280229148 4280229148 4280229148 4280427303 4282998664 4283194246 4282205794 4280229148 4283069344 4283399342 4281748581 4280361508 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4145945627 3038320407 1812728843 1275068416 1275068416 1275068416 1207959552 788529152 301989888 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 603979776 1241513984 1695222281 3608943129 4280229148 4280229148 4280229148 4280229148 4282538365 4281942619 4280559146 4281154120 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3776781082 2517963795 1426326532 1275068416 1275068416 1275068416 973078528 486539264 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 184549376 956301312 1308688641 2719421717 4213054491 4280229148 4280229148 4280229148 4280691506 4280426788 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4213054491 3256490264 2014318350 1275068416 1275068416 1275068416 1140850688 671088640 184549376 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 503316480 1191182336 1846348812 3793558298 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3944553242 2736199189 1560807175 1275068416 1275068416 1241513984 855638016 369098752 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 117440512 855638016 1375928834 2954434326 4263386139 4280229148 4280229148 4280229148 4280229148 4263386139 3457882649 2215776528 1308688641 1275068416 1275068416 1040187392 553648128 100663296 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 385875968 1140850688 1863126284 2685867284 3306887448 3038320407 2316505617 1577584647 1275068416 1275068416 1191182336 738197504 251658240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 67108864 738197504 1258291200 1275068416 1275068416 1275068416 1224736768 905969664 436207616 33554432 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
	offset: 0@0)! !

!TrashCanMorph class methodsFor: 'class initialization' stamp: 'dgd 9/2/2004 13:15'!
initializeTrashPicOn
	^ Form
		extent: 72 @ 72
		depth: 32
		fromArray: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 35593500 438246684 773791004 1109335324 706682140 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 52370716 857677084 1914641692 2971606300 3995016476 4280229148 4280229148 4280229148 4280229148 3089046812 1159666972 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 35593500 1059003676 2535398684 3944684828 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3508477212 1595874588 102702364 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 924785948 2401180956 3844021532 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4282136620 4281149988 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3844021532 2015304988 287251740 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 790568220 2266963228 3726581020 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4282333741 4287266903 4292200065 4294962328 4294699158 4291279224 4286937941 4282597168 4280229148 4280229148 4280229148 4280229148 4280229148 4095679772 2451512604 572464412 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 673127708 2132745500 3609140508 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4282333741 4287266903 4292200065 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292331393 4286346064 4281084195 4280229148 4280229148 4280229148 4280229148 4229897500 2870943004 941563164 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 52370716 1495211292 3424591132 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4282333741 4287266903 4292200065 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294370451 4289240168 4283320374 4280229148 4280229148 4280229148 4280229148 4280229148 3307150620 1226775836 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 169811228 1813978396 3726581020 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4281544487 4287069525 4292134272 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962071 4294103679 4290947944 4288252760 4293316998 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292068480 4286148685 4280952610 4280229148 4280229148 4280229148 4280229148 3407813916 1310661916 18816284 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 320806172 2115968284 3944684828 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4283912250 4289897581 4294633365 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294895763 4293379184 4291467593 4292713278 4293501761 4281935888 4282330129 4292581949 4289495097 4291473254 4294962327 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294238866 4288648034 4282005034 4280229148 4280229148 4280229148 4280229148 3491699996 1394547996 18816284 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 438246684 2434735388 4095679772 4280229148 4280229148 4280229148 4280229148 4280229148 4281149988 4286609233 4292594564 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294961814 4293774199 4291796299 4293041983 4293501761 4293501761 4293501761 4293501761 4279898631 4284104473 4293370432 4293370432 4293370432 4291596347 4291207769 4294830228 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294699158 4289503082 4282597168 4280229148 4280229148 4280229148 4280229148 3558808860 1478434076 35593500 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1646206236 4028570908 4280229148 4280229148 4280229148 4280229148 4280229148 4283189045 4289305960 4294436243 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294564997 4292191827 4292779071 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4293173055 4278321409 4285813024 4293370432 4293370432 4293370432 4293370432 4293370432 4292319293 4290943568 4294500750 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294896535 4290358129 4283451958 4280229148 4280229148 4280229148 4280229148 3625917724 1562320156 52370716 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 203365660 3089046812 4280229148 4280229148 4280229148 4280229148 4280229148 4283189045 4290621556 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294896278 4293378926 4292123203 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4290281523 4284498715 4278190080 4287521831 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4292910142 4290942281 4294105222 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291213433 4284307006 4280229148 4280229148 4280229148 4280229148 3676249372 1646206236 69147932 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2803834140 4280229148 4280229148 4280229148 4280229148 4282333741 4290423922 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294829713 4292456284 4292647743 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4290741813 4285484319 4280161544 4278190080 4278190080 4278190080 4281081612 4288376107 4293239103 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293107519 4290678852 4293579136 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292002431 4283715129 4280229148 4280229148 4280229148 4280229148 3743358236 1713315100 18816284 0 0 0 0 0 0 0 0 0 0 0 0 0 1243553052 4280229148 4280229148 4280229148 4280294940 4286871892 4294436243 4294962328 4294962328 4294962328 4294962328 4294962328 4294962327 4292785762 4293107520 4293501761 4293501761 4293501761 4293501761 4293501761 4293501761 4292516157 4286667300 4280621578 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4280358665 4287193126 4292910398 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293173311 4290481215 4292986745 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4289766508 4281741865 4280229148 4280229148 4280229148 4280229148 2199854364 0 0 0 0 0 0 0 0 0 0 0 0 0 1310661916 4280229148 4280229148 4280360476 4288776274 4293515148 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293248629 4290414395 4293304640 4293501761 4293501761 4293501761 4290873142 4284367386 4278781443 4278321666 4278716424 4279111182 4279242768 4279242768 4279242768 4279242768 4279242768 4279242768 4279308561 4278979596 4278584838 4279438597 4285944609 4292319035 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293304640 4290942021 4294895507 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294304658 4287266903 4280623647 4280229148 4280229148 4280229148 1511988508 0 0 0 0 0 0 0 0 0 0 0 0 1025449244 4280229148 4280229148 4281740320 4293370432 4286735669 4285686849 4292594564 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4290619751 4287720239 4288376107 4282067473 4278190080 4278453252 4279505940 4280295456 4280361249 4280361249 4280427042 4280427042 4280427042 4280427042 4280427042 4280427042 4280427042 4280427042 4280427042 4280229663 4279242768 4278913028 4284761628 4291530296 4293370432 4293370432 4292779069 4289427761 4288904509 4291736169 4294962070 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294830742 4290687091 4282333742 4280229148 4280229148 4129234204 455023900 0 0 0 0 0 0 0 0 0 0 0 773725211 4280229148 4280229148 4281871648 4293370432 4293370432 4288442418 4281280544 4284568890 4291410554 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291147381 4283978293 4280163612 4281479730 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281545523 4281348144 4279966491 4278518786 4286213469 4284702037 4288253794 4294304402 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291805053 4288516449 4290160751 4294370195 4290161008 4280229148 4280229148 4280229148 2082413852 0 0 0 0 0 0 0 0 0 0 0 1074596876 4280229148 4280229148 4281477407 4293370432 4293370432 4293370432 4292253244 4284960041 4280229148 4283254065 4290423922 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292923271 4285228105 4281940279 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4282664004 4283585107 4288256927 4293454315 4294967295 4291612632 4284442748 4292924050 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292857478 4287266647 4285556808 4290029422 4294764950 4294962328 4294962328 4291805309 4280229148 4280229148 4280229148 1847335449 0 0 0 0 0 0 0 0 0 0 0 1040581893 4280229148 4280229148 4280294684 4293305153 4293370432 4293370432 4293370432 4293370432 4291004729 4284631336 4280294940 4283122480 4290752628 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294764950 4289042791 4283715910 4283453520 4283782485 4283782485 4283782485 4283782485 4283782485 4283782485 4283782485 4283782485 4283782485 4286217343 4290888647 4294638331 4294967295 4294967295 4294967295 4294967295 4290692045 4284508540 4293384340 4294962328 4294962328 4294633365 4289963629 4284438591 4285622345 4291936639 4294962328 4294962328 4294962328 4294962328 4294962328 4290687092 4280229148 4280229148 4280229148 1896877839 167772160 0 0 0 0 0 0 0 0 0 0 788529152 4229831707 4280229148 4280229148 4292977735 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4291333434 4285091113 4280426269 4283385907 4291016054 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293318026 4286610012 4284308569 4284900966 4284900966 4284900966 4284900966 4284835430 4287533462 4293059558 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288126895 4288650374 4292857478 4287069525 4282794033 4287464024 4293580940 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4289174118 4280229148 4280229148 4280229148 1527186950 1056964608 16777216 0 0 0 0 0 0 0 0 0 687865856 4045282331 4280229148 4280229148 4290219337 4293370689 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4291662139 4285485354 4280492061 4283648821 4291410298 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4290490234 4285821028 4285098086 4285755229 4285625721 4286548124 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4292336352 4283587440 4283122996 4289437289 4294567572 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4285162309 4280229148 4280229148 4062059547 1275068416 1275068416 419430400 0 0 0 0 0 0 0 0 0 587202560 3843889946 4280229148 4280229148 4280229148 4282990123 4290943054 4293371203 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4291924796 4285945387 4280886559 4284043321 4291739260 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4293384340 4284179578 4291218131 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294901502 4284771975 4292792722 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4292528515 4280558111 4280229148 4280229148 3592165913 1275068416 1275068416 352321536 0 0 0 0 0 0 0 0 0 503316480 3659274777 4280229148 4280229148 4280229148 4280229148 4280229148 4281543715 4289628488 4293240390 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4292713021 4287850801 4282463782 4286016071 4294238353 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4290491531 4285166988 4294835709 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4287863724 4290097034 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291476090 4281347365 4280229148 4280229148 4280229148 3105495063 1275068416 1275068416 150994944 0 0 0 0 0 0 0 0 0 402653184 2014318350 3676051994 4280229148 4280229148 4280229148 4280229148 4280627012 4280099376 4280426270 4288050752 4293043528 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4289953846 4286276665 4291080047 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294830743 4285297533 4291283667 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4290165703 4288058757 4294962328 4294962328 4294962328 4294962328 4294962328 4293909902 4289963374 4285885515 4281741865 4280229148 4280229148 4280229148 4280229148 4280229148 2249396497 1275068416 1207959552 0 0 0 0 0 0 0 0 0 0 301989888 1275068416 1291845632 3155826711 4280229148 4280229148 4280229148 4281352290 4280166989 4280167246 4280561742 4280098343 4286407480 4292649802 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4291924796 4292586841 4294565770 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4291805053 4285163869 4285890453 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4292402145 4286020735 4294962328 4294764950 4291607675 4287464281 4283386166 4280294940 4280558630 4281679176 4281151542 4280229148 4280229148 4280229148 4280229148 3877444378 1375928834 1275068416 1006632960 0 0 0 0 0 0 0 0 0 0 218103808 1275068416 1275068416 2685867284 4280229148 4280229148 4280229148 4281286239 4280166989 4280166989 4280166989 4280167246 4280364881 4280297276 4284567602 4292190283 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4292844863 4291666774 4293579395 4294962328 4294962328 4294962328 4292923271 4288845156 4289765996 4293778320 4283916922 4292336352 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294507002 4283851128 4284899138 4281149988 4281152831 4282472305 4283658645 4284647089 4285109445 4285109703 4281482312 4280229148 4280229148 3424327961 2920814358 1661602057 1275068416 1275068416 788529152 0 0 0 0 0 0 0 0 0 0 117440512 1275068416 1275068416 2434077459 4280229148 4280229148 4280229148 4281220444 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166990 4280363589 4282661678 4291467850 4293304897 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293370432 4293504076 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4287006849 4290363081 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4285495440 4283394699 4284713140 4285240001 4285174722 4285174980 4285175238 4285109703 4284978631 4280427301 4280229148 3860667162 1275068416 1275068416 1275068416 1275068416 1275068416 570425344 0 0 0 0 0 0 0 0 0 0 0 285212672 922746880 2198999312 4280229148 4280229148 4280229148 4281088342 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280232521 4281675823 4290547784 4293370947 4293370432 4293370432 4293370432 4293370432 4293370432 4293502790 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4294962328 4290228362 4289179067 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4287468711 4284579752 4285174464 4285240002 4285174979 4285175237 4285175238 4285044167 4284319411 4280229148 4280229148 3172603927 1275068416 1275068416 1275068416 1275068416 1275068416 167772160 0 0 0 0 0 0 0 0 0 0 0 0 0 1745948687 4280229148 4280229148 4280229148 4280890702 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280232779 4281018928 4289496903 4293305926 4293370432 4293370432 4293370432 4293370432 4294962327 4294962328 4294962328 4294962328 4294962328 4294962328 4292923270 4286807910 4287995053 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4289244860 4284381599 4285174465 4285240259 4285175237 4285175238 4285109703 4285109704 4283330711 4280229148 4280229148 2685867284 1275068416 1275068416 1275068416 1275068416 738197504 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1393429773 4280229148 4280229148 4280229148 4280758084 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280232779 4280427050 4288576322 4293174856 4293370432 4293370432 4294829969 4294962328 4294962328 4293975439 4288976998 4283518008 4280229148 4280887856 4286811295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4290955216 4284183189 4285240258 4285240516 4285174981 4285109702 4285109704 4285044168 4282341750 4280229148 4280229148 2333348370 1275068416 1090519040 452984832 318767104 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1024002056 4280229148 4280229148 4280229148 4280625722 4281285730 4281746538 4282272628 4282601850 4282535800 4282404471 4282272885 4281746282 4280758871 4280166989 4280166989 4280166989 4280166989 4280166989 4280166989 4280495950 4280295203 4287393598 4292912715 4294434184 4290358129 4284964931 4280623647 4280229148 4280756268 4282207587 4283459723 4285627282 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4292730853 4283853451 4284846533 4284715461 4284584390 4284518599 4284387271 4284256199 4281418325 4280229148 4280229148 2014318350 1275068416 654311424 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 687865856 4246608923 4280229148 4280229148 4280624683 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282667644 4281614697 4280627541 4280166989 4280166989 4280232525 4280627283 4281022041 4281285462 4280229406 4280820768 4280229148 4280558374 4281482059 4282669173 4283592342 4283921822 4283987101 4284508804 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294441209 4283523713 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280823351 4280229148 4280229148 1678379273 1275068416 335544320 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 553648128 4028505115 4280229148 4280229148 4280360736 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282272628 4280693078 4280495441 4280824662 4281219163 4281548384 4281943399 4281747555 4282076265 4282802308 4283329428 4283527065 4283790237 4283987874 4284052894 4283522425 4294638587 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4284772232 4283861443 4283927751 4283927751 4283927751 4283927751 4283795650 4280229406 4280229148 4263386139 1359086082 1275068416 134217728 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 452984832 3793558298 4280229148 4280229148 4280229148 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283128452 4282206834 4281285214 4281416798 4281745763 4282009191 4282538367 4282934412 4283197841 4283526806 4283789723 4283922080 4284119975 4283988904 4283522425 4293454573 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4291678681 4284574853 4283859895 4283927751 4283927751 4283927751 4283927751 4283201446 4280229148 4280229148 4028505115 1275068416 1241513984 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 335544320 3541834265 4280229148 4280229148 4280229148 4283194760 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283062660 4282404212 4282008679 4282206570 4282669438 4283132048 4283394965 4283658908 4283923885 4283991741 4283861958 4283794360 4283522425 4292138974 4294967295 4294967295 4294967295 4294967295 4294704124 4290757582 4285495696 4283522425 4283591569 4283860670 4283927751 4283927751 4283927751 4283927751 4282540935 4280229148 4280229148 3692829466 1275068416 1107296256 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 234881024 3306887448 4280229148 4280229148 4280229148 4283129481 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283062659 4282732919 4282404716 4283463075 4283794104 4283861957 4283927751 4283927751 4283927751 4283794360 4283522425 4289442238 4294967295 4294967295 4292665060 4288521395 4284574853 4283522682 4283658134 4283860154 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281946477 4280229148 4280229148 3357219096 1275068416 956301312 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 117440512 3071875095 4280229148 4280229148 4280229148 4283063688 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281153350 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283861184 4283522425 4284640646 4289310653 4285232525 4283522425 4283523198 4283658908 4283860926 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281550170 4280229148 4280229148 3021543191 1275068416 788529152 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 2836928021 4280229148 4280229148 4280229148 4282932357 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280624684 4283597496 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283589764 4283522425 4283522940 4283592084 4283793071 4283927493 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281153864 4280229148 4280229148 2685867284 1275068416 637534208 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2551649556 4280229148 4280229148 4280229148 4282800512 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280756528 4283465394 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283861443 4283860412 4283861956 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280757557 4280229148 4280229148 2350125586 1275068416 486539264 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2232751123 4280229148 4280229148 4280229148 4282603130 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280888373 4283465394 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280361251 4280229148 4280229148 2014318350 1275068416 335544320 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1913852433 4280229148 4280229148 4280229148 4282405233 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281350216 4283861958 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283663804 4280229148 4280229148 4280229148 1695156745 1275068416 167772160 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1561399311 4280229148 4280229148 4280229148 4282141543 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282536308 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283267498 4280229148 4280229148 4280229148 1359086082 1275068416 33554432 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1175325964 4280229148 4280229148 4280229148 4281812060 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194761 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282871191 4280229148 4280229148 4028505115 1275068416 1157627904 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 788989446 4280229148 4280229148 4280229148 4281416526 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194504 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282474885 4280229148 4280229148 3709606682 1275068416 989855744 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 536870912 4179500059 4280229148 4280229148 4281086270 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194503 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282078579 4280229148 4280229148 3357219096 1275068416 838860800 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 419430400 3944553243 4280229148 4280229148 4280624941 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281748580 4280229148 4280229148 3038320407 1275068416 687865856 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 301989888 3709606682 4280229148 4280229148 4280360994 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281483862 4280229148 4280229148 2702644501 1275068416 536870912 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 201326592 3474659865 4280229148 4280229148 4280229148 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283861958 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281153864 4280229148 4280229148 2366903058 1275068416 369098752 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 100663296 3239713048 4280229148 4280229148 4280229148 4283194760 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283795906 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280823866 4280229148 4280229148 2031095566 1275068416 218103808 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2987988758 4280229148 4280229148 4280229148 4283129224 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283333548 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4280559404 4280229148 4280229148 1695222281 1275068416 67108864 0 0 0 0 72441209 3075562873 2790350201 1330732409 72441209 0 0 0 0 0 0 0 0 0 0 0 0 2702710293 4280229148 4280229148 4280229148 4283063687 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283128453 4282870677 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283861958 4280229406 4280229148 4280229148 1375928834 1191182336 0 0 0 0 0 1716608377 4283522425 4283522425 4286811296 3949622412 2287033721 558980473 0 0 0 0 0 0 0 0 0 0 2400654612 4280229148 4280229148 4280229148 4282866049 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282930813 4282606987 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283663547 4280229148 4280229148 4045282331 1275068416 1040187392 0 0 0 0 72441209 3729874297 4283522425 4287534760 4294901502 4294704123 4289902532 4250362750 3008454009 1230069113 22109561 0 0 0 0 0 0 0 2048201747 4280229148 4280229148 4280229148 4282536565 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282667124 4282409091 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283333549 4280229148 4280229148 3709606682 1275068416 889192448 0 0 0 0 1666276729 4283522425 4284772232 4294177781 4294901502 4294901502 4294901502 4292796645 4284903561 4283522425 3696319865 424762745 0 0 0 0 0 0 1712525841 4280229148 4280229148 4280229148 4282140774 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282403434 4282276732 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283069087 4280229148 4280229148 3390773528 1275068416 738197504 0 0 0 189881721 3864092025 4283522425 4291875803 4294901502 4294901502 4294901502 4294901502 4294901502 4293914867 4286153368 4283522425 960119383 0 0 0 0 0 0 1292898062 4280229148 4280229148 4280229148 4281679187 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4282140258 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4282607244 4280229148 4280229148 3038320407 1275068416 570425344 0 0 0 2169593209 4283522425 4288455602 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4290823631 3998112117 1359020289 922746880 0 0 0 0 0 688063235 4095613979 4280229148 4280229148 4280756528 4282800511 4283194247 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281876825 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281550427 4280229148 4280229148 2719421717 1275068416 419430400 0 0 475094393 4115750265 4284903561 4294506745 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4287666346 2721793113 1342177280 889192448 0 0 0 0 0 503316480 2736199189 4280229148 4280229148 4280229148 4280229148 4280822579 4282799998 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281613392 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283795907 4280427560 4280229148 4280229148 2383680274 1275068416 268435456 0 0 2706464121 4283522425 4290165701 4294572537 4294769916 4294901502 4294901502 4294901502 4294901502 4294901502 4293914866 4116013178 1510739474 1342177280 436207616 0 0 0 0 0 318767104 1291845632 2987988758 4280229148 4280229148 4280229148 4280229148 4280229148 4281547599 4283128710 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281349959 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4281946476 4280229148 4280229148 4280229148 1997475342 1275068416 117440512 0 860970361 4266679416 4284969353 4293585642 4293914607 4294111986 4294309365 4294440951 4294638330 4294835709 4294901502 4288915896 2889828446 1342177280 1124073472 16777216 0 0 0 0 0 16777216 1040187392 1275068416 2232553745 4062059547 4280229148 4280229148 4280229148 4280229148 4280756271 4282865276 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4281086270 4282276731 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283795648 4281880425 4280229148 4280229148 4280229148 4162722843 1359086082 1241513984 0 0 3193003385 4283522425 4289573563 4293059298 4293256677 4293454056 4293585642 4293783021 4293980400 4294177779 4293717486 4200228222 1595020571 1342177280 452984832 0 0 0 0 0 0 0 150994944 1073741824 1275068416 1594361863 3491502617 4280229148 4280229148 4280229148 4280229148 4280295200 4282206309 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280822580 4282276732 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283201446 4281946733 4280625712 4280229148 4280229148 4280229148 4280229148 3390773528 1275068416 1073741824 0 1246846329 4283522425 4284969352 4292138196 4292401368 4292532954 4292730333 4292927712 4293125091 4293322470 4293519849 4288784308 3057798242 1342177280 1107296256 0 0 0 0 0 0 0 0 0 50331648 704643072 1258291200 1291845632 2635470100 4213054491 4280229148 4280229148 4280229148 4280229148 4281283909 4283128709 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280558889 4282408833 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283267755 4281946733 4280757556 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4229831707 1846348812 1275068416 890048276 34080776 2907724920 4283522425 4285824144 4290756802 4291677645 4291875024 4292072403 4292269782 4292467161 4292664540 4292006870 4233651070 1729764646 1342177280 436207616 0 0 0 0 0 0 0 0 0 0 0 285212672 1073741824 1275068416 1846348812 3810335514 4280229148 4280229148 4280229148 4280229148 4280624683 4282931071 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4283194246 4280295199 4282540935 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283795649 4282540937 4281087812 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4213054491 2400457490 1275068416 2167354950 3914292086 1982871110 1242698777 2620998230 4115618678 4283719803 4286810521 4290756801 4291414473 4291611852 4291809231 4291940817 4287073951 3040955234 1342177280 1090519040 0 0 0 0 0 0 0 0 0 0 0 0 0 33554432 687865856 1258291200 1392706307 3055097879 4280229148 4280229148 4280229148 4280229148 4280295200 4282404205 4283194246 4283194246 4283194246 4283194246 4283194246 4282996607 4280229148 4282673038 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283927751 4283267498 4281814375 4280427560 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4246608923 3273267480 1812728843 1426853394 3158921833 4289113274 4290428874 3880605811 2030569739 1526726656 1611863581 3192147558 4266679416 4284377473 4289112495 4290953922 4291085508 4290033338 4065418103 1544491286 1342177280 419430400 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 268435456 1056964608 1275068416 2198999312 4045282331 4280229148 4280229148 4280229148 4280229148 4281745238 4283194247 4283194246 4283194246 4283194246 4282732917 4280229148 4282804884 4283927751 4283927751 4283927751 4283927751 4283861957 4282739090 4281153606 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4028505115 2836928021 1627981832 1275068416 2049651008 3982781829 4292796645 4294835709 4289968581 3914489207 1797005353 1023739141 1023410176 1342177280 2015833403 3796653937 4283588217 4287796896 4290427578 4285626765 2553757779 1342177280 989855744 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33554432 654311424 1258291200 1560807175 3407550744 4280229148 4280229148 4280229148 4280229148 4281020475 4283129225 4283194246 4283194246 4282469228 4280229148 4282937242 4283927751 4283927751 4283663805 4282276475 4280691506 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3575388697 2316505617 1342308866 1275068416 1544820510 3024178018 4268915858 4293783537 4293388781 4286022038 3410449002 1612126495 1244937036 1582390649 458317177 503382273 1090519040 1544491543 3712702064 4283588217 4286613141 3746256497 1375863556 1308622848 201326592 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 251658240 1040187392 1275068416 2484409363 4145945627 4280229148 4280229148 4280229148 4280427303 4282998664 4283194246 4282205794 4280229148 4283069344 4283399342 4281748581 4280361508 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4145945627 3038320407 1812728843 1275068416 1275068416 2083008060 3982650755 4283916925 4286087575 4294375416 4291415253 4284180353 4166015863 3695924848 4183779971 4286613917 4285693074 2318744653 1376258056 17303560 452984832 1460671257 3729479280 4283522425 2083074110 1342177280 704643072 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 603979776 1241513984 1695222281 3608943129 4280229148 4280229148 4280229148 4280229148 4282538365 4281942619 4280559146 4281154120 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3776781082 2517963795 1426326532 1275068416 1275068416 1275068416 973078528 2285717084 4292467938 4287600553 4291810266 4292270559 4285955989 4288586932 4291218131 4293783281 4294967295 4294967295 4290954960 2789033562 1426589704 185075720 0 234881024 1494488862 2688172887 1342177280 1174405120 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 184549376 956301312 1308688641 2719421717 4213054491 4280229148 4280229148 4280229148 4280691506 4280426788 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4213054491 3256490264 2014318350 1275068416 1275068416 1275068416 1140850688 671088640 184549376 0 2118405733 4252598936 4284443268 4292533474 4294967295 4294967295 4294967295 4293322988 4290823374 4288455346 4286087575 4283917182 3192147557 1426589704 403179528 0 0 218103808 1191182336 1308622848 285212672 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 503316480 1191182336 1846348812 3793558298 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 4280229148 3944553242 2736199189 1560807175 1275068416 1275068416 1241513984 855638016 369098752 16777216 0 0 0 336070664 974263063 3511441264 4294441209 4291415253 4286942625 4284443268 4233124984 3729479280 3124972900 2536980306 1948592436 1376389900 1057490952 336070664 0 0 0 117440512 369098752 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 117440512 855638016 1375928834 2954434326 4263386139 4280229148 4280229148 4280229148 4280229148 4263386139 3457882649 2215776528 1308688641 1275068416 1275068416 1040187392 553648128 100663296 0 0 0 0 0 0 0 0 3882513291 4292138974 4283719803 2906605662 2049519163 1410207762 1040713736 755501064 470288392 201852936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 385875968 1140850688 1863126284 2685867284 3306887448 3038320407 2316505617 1577584647 1275068416 1275068416 1191182336 738197504 251658240 0 0 0 0 0 0 0 0 0 0 38886777 3192476781 3930937715 2990623328 1158154248 168298504 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 67108864 738197504 1258291200 1275068416 1275068416 1275068416 1224736768 905969664 436207616 33554432 0 0 0 0 0 0 0 0 0 0 0 0 0 621283336 1023936520 1158154248 151521288 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 )
		offset: 0 @ 0! !

!TrashCanMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:08'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(TrashCanMorph	new	'Trash'		'A tool for discarding objects')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(TrashCanMorph	new	'Trash'		'A tool for discarding objects')
						forFlapNamed: 'Widgets'.
						cl registerQuad: #(TrashCanMorph	new	'Trash'		'A tool for discarding objects')
						forFlapNamed: 'Scripting']! !

!TrashCanMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:41'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!TrashCanMorph class methodsFor: 'miscellaneous' stamp: 'nk 8/23/2004 18:12'!
descriptionForPartsBin
	^ self partName:	'Trash'
		categories:		#('Useful' 'Basic')
		documentation:	'a tool for discarding objects'! !

!TrashCanMorph class methodsFor: 'miscellaneous' stamp: 'sw 8/18/1999 19:55'!
moveToTrash: aMorph
	Preferences soundsEnabled ifTrue:
		[Preferences preserveTrash 
			ifFalse:
				[self playSoundNamed: 'scratch']
			ifTrue:
				[self playDeleteSound]].

	aMorph delete.
	aMorph == Utilities scrapsBook ifFalse:
		[Utilities addToTrash: aMorph]! !
WidgetStub subclass: #TreeNodeStub
	instanceVariableNames: 'item'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!TreeNodeStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'!
openPath: anArray
	| child |
	anArray isEmpty 
		ifTrue: [self select]
		ifFalse: [child := self children 
								detect: [:ea | ea matches: anArray first] 
								ifNone: [^ self select].
				child openPath: anArray allButFirst]
	! !


!TreeNodeStub methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/3/2006 22:32'!
setSpec: aSpec item: anObject
	super setSpec: aSpec.
	item := anObject! !


!TreeNodeStub methodsFor: 'printing' stamp: 'cwp 4/23/2005 00:54'!
printOn: aStream
	aStream
		print: self class;
		nextPut: $<;
		print: item;
		nextPut: $>! !


!TreeNodeStub methodsFor: 'simulating' stamp: 'cwp 4/23/2005 00:50'!
children
	^ (self model perform: spec getChildren with: item)
		collect: [:ea | TreeNodeStub fromSpec: spec item: ea]! !

!TreeNodeStub methodsFor: 'simulating' stamp: 'cwp 4/23/2005 00:49'!
item
	^ item! !

!TreeNodeStub methodsFor: 'simulating' stamp: 'cwp 4/23/2005 00:57'!
label
	^ self model perform: spec label with: item! !

!TreeNodeStub methodsFor: 'simulating' stamp: 'cwp 4/23/2005 00:23'!
select
	self model perform: spec setSelected with: item! !


!TreeNodeStub methodsFor: 'private' stamp: 'cwp 4/23/2005 00:56'!
matches: aString
	^ self label = aString! !

!TreeNodeStub methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:32'!
selectPath: anArray
	| child |
	anArray isEmpty ifTrue: [^ self select].
	child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select].
	child selectPath: anArray allButFirst.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TreeNodeStub class
	instanceVariableNames: ''!

!TreeNodeStub class methodsFor: 'instance creation' stamp: 'cwp 4/23/2005 00:15'!
fromSpec: aSpec item: anObject
	^ self new setSpec: aSpec item: anObject! !
WidgetStub subclass: #TreeStub
	instanceVariableNames: 'roots'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!TreeStub methodsFor: 'events' stamp: 'cwp 4/22/2005 22:40'!
eventAccessors
	^ #(roots getSelectedPath setSelected getChildren hasChildren label icon help menu keyPress)! !

!TreeStub methodsFor: 'events' stamp: 'cwp 4/23/2005 01:00'!
updateRoots
	^ self roots: (self model perform: spec roots)
! !

!TreeStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'!
updateSelectedPath
	| path first |
	path := self model perform: spec getSelectedPath.
	first := roots detect: [:ea | ea item = path first] ifNone: [^ self].
	first selectPath: path allButFirst.! !

!TreeStub methodsFor: 'events' stamp: 'cwp 4/23/2005 01:00'!
update: anObject
	anObject == spec roots ifTrue: [^ self updateRoots].
	anObject == spec getSelectedPath ifTrue: [^ self updateSelectedPath].
	(anObject isKindOf: Array) ifTrue: [^ self openPath: anObject allButFirst].
	super update: anObject
	! !


!TreeStub methodsFor: 'initialize-release' stamp: 'cwp 4/23/2005 00:28'!
setSpec: aSpec
	super setSpec: aSpec.
	self update: spec roots! !


!TreeStub methodsFor: 'simulating' stamp: 'cwp 6/7/2005 00:31'!
select: anArray
	self openPath: anArray! !


!TreeStub methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:32'!
openPath: anArray
	| first |
	first := roots detect: [:ea | ea matches: anArray first] ifNone: [^ self].
	first openPath: anArray allButFirst! !

!TreeStub methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:32'!
roots: anArray
	roots := anArray collect: [:ea | TreeNodeStub fromSpec: spec item: ea].
! !
StarSqueakTurtle subclass: #TreeTurtle
	instanceVariableNames: 'depth length'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!TreeTurtle methodsFor: 'commands' stamp: 'sd 11/20/2005 21:26'!
tree1
	"Draw a recursive tree whose trunk length is determined by my depth instance variable. Stop when depth is < 1."

	depth < 1 ifTrue: [^ self stop].
	depth := depth - 1.
	self forward: 2 * depth.
	self turnRight: 20.
	self replicate.				"create child 1"
	self turnLeft: 40.
	self replicate.				"create child 2"
	self die.						"this turtle dies"
! !

!TreeTurtle methodsFor: 'commands' stamp: 'sd 11/20/2005 21:26'!
tree2
	"Draw a recursive tree whose trunk length determined by my length instance variable. Stop when depth is < 1. This version uses randomness to create a more natural looking, asymmetric tree. It also changes the turtle's hue a little each generation."

	depth < 1 ifTrue: [^ self stop].
	depth := depth - 1.
	self color: (Color h: self color hue + 10 s: 0.7 v: 0.7).
	self forward: length.
	length := (0.5 + ((self random: 450) / 1000.0)) * length.
	self turnRight: 10 + (self random: 20).
	self replicate.
	self turnLeft: 30 + (self random: 20).
	self replicate.
	self die.
! !


!TreeTurtle methodsFor: 'variables' stamp: 'jm 1/29/2001 09:42'!
depth

	^ depth
! !

!TreeTurtle methodsFor: 'variables' stamp: 'sd 11/20/2005 21:26'!
depth: aNumber

	depth := aNumber.
! !

!TreeTurtle methodsFor: 'variables' stamp: 'jm 1/28/2001 10:39'!
length

	^ length
! !

!TreeTurtle methodsFor: 'variables' stamp: 'sd 11/20/2005 21:26'!
length: aNumber

	length := aNumber.
! !
Boolean subclass: #True
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!True commentStamp: '<historical>' prior: 0!
True defines the behavior of its single instance, true -- logical assertion. Notice how the truth-value checks become direct message sends, without the need for explicit testing.

Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.!


!True methodsFor: 'controlling'!
and: alternativeBlock 
	"Nonevaluating conjunction -- answer the value of alternativeBlock since
	the receiver is true."

	^alternativeBlock value! !

!True methodsFor: 'controlling'!
ifFalse: alternativeBlock 
	"Since the condition is true, the value is the true alternative, which is nil. 
	Execution does not actually reach here because the expression is compiled 
	in-line."

	^nil! !

!True methodsFor: 'controlling'!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Answer the value of trueAlternativeBlock. Execution does not 
	actually reach here because the expression is compiled in-line."

	^trueAlternativeBlock value! !

!True methodsFor: 'controlling'!
ifTrue: alternativeBlock 
	"Answer the value of alternativeBlock. Execution does not actually 
	reach here because the expression is compiled in-line."

	^alternativeBlock value! !

!True methodsFor: 'controlling'!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 
	"Answer with the value of trueAlternativeBlock. Execution does not 
	actually reach here because the expression is compiled in-line."

	^trueAlternativeBlock value! !

!True methodsFor: 'controlling'!
or: alternativeBlock 
	"Nonevaluating disjunction -- answer true since the receiver is true."

	^self! !


!True methodsFor: 'logical operations' stamp: 'md 7/30/2005 18:04'!
& aBoolean 
	"Evaluating conjunction -- answer aBoolean since receiver is true."

	^aBoolean! !

!True methodsFor: 'logical operations'!
not
	"Negation--answer false since the receiver is true."

	^false! !

!True methodsFor: 'logical operations'!
| aBoolean 
	"Evaluating disjunction (OR) -- answer true since the receiver is true."

	^self! !


!True methodsFor: 'printing' stamp: 'ajh 7/1/2004 10:36'!
asBit

	^ 1! !

!True methodsFor: 'printing'!
printOn: aStream 

	aStream nextPutAll: 'true'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

True class
	instanceVariableNames: ''!

!True class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 11:09'!
initializedInstance
	^ true! !
ClassTestCase subclass: #TrueTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Objects'!

!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'!
testAND

	self assert: (true & true) = true.
	self assert: (true & false) = false.! !

!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'!
testInMemory

	self assert: (false isInMemory = true).! !

!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'!
testNew

	self should: [True new] raise: Error. ! !

!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'!
testNot

	self assert: (false not = true).! !

!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'!
testPrintOn

	self assert: (String streamContents: [:stream | true printOn: stream]) = 'true'. ! !
Object subclass: #TwoLevelDictionary
	instanceVariableNames: 'firstLevel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FilePackage'!
!TwoLevelDictionary commentStamp: '<historical>' prior: 0!
A simple dictionary for the use of the TextDiffBuilder. Keys are presumed to be Points and a significant speed advantage is gained by using a dictionary of dictionaries. The first is keyed by the x-values and the second by the y-values. Only the minimum necessary protocol is implemented.!


!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:42'!
at: aPoint

	^(firstLevel at: aPoint x ifAbsent: [^nil]) at: aPoint y ifAbsent: [^nil]
! !

!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:37'!
at: aPoint put: anObject

	(firstLevel at: aPoint x ifAbsentPut: [Dictionary new]) at: aPoint y put: anObject
! !

!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:38'!
initialize

	firstLevel _ Dictionary new.! !

!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:40'!
keysDo: aBlock

	firstLevel keysAndValuesDo: [ :x :v |
		v keysDo: [ :y | aBlock value: x@y]
	].! !

!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:40'!
twoLevelKeys

	| twoLevelSet |

	twoLevelSet _ TwoLevelSet new.
	self keysDo: [ :each | twoLevelSet add: each].
	^twoLevelSet
! !
Object subclass: #TwoLevelSet
	instanceVariableNames: 'firstLevel'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-FilePackage'!
!TwoLevelSet commentStamp: '<historical>' prior: 0!
A simple set for the use of the TextDiffBuilder. Elements are presumed to be Points and a significant speed advantage is gained by using a dictionary of sets. The first is keyed by the x-values and the second contains the y-values. Only the minimum necessary protocol is implemented.!


!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:18'!
add: aPoint

	(firstLevel at: aPoint x ifAbsentPut: [Set new]) add: aPoint y
! !

!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:18'!
copy

	| answer |

	answer _ self class new initialize.
	self do: [ :each |
		answer add: each
	].
	^answer! !

!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 09:26'!
detect: aBlock

	firstLevel keysAndValuesDo: [ :x :v |
		v do: [ :y | (aBlock value: x@y) ifTrue: [^x@y]]
	].
	^nil! !

!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:15'!
do: aBlock

	firstLevel keysAndValuesDo: [ :x :v |
		v do: [ :y | aBlock value: x@y]
	].! !

!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:19'!
includes: aPoint

	^(firstLevel at: aPoint x ifAbsent: [^false]) includes: aPoint y! !

!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:11'!
initialize

	firstLevel _ Dictionary new.! !

!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:13'!
isEmpty

	^firstLevel isEmpty! !

!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:22'!
remove: aPoint

	| lev2 |

	lev2 _ firstLevel at: aPoint x ifAbsent: [^self].
	lev2 remove: aPoint y ifAbsent: [].
	lev2 isEmpty ifTrue: [firstLevel removeKey: aPoint x].

! !

!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:28'!
removeAllXAndY: aPoint

	| deletes |

	deletes _ OrderedCollection new.
	firstLevel removeKey: aPoint x ifAbsent: [].
	firstLevel keysAndValuesDo: [ :x :lev2 |
		lev2 remove: aPoint y ifAbsent: [].
		lev2 isEmpty ifTrue: [deletes add: x].
	].
	deletes do: [ :each | firstLevel removeKey: each ifAbsent: []].! !
ComponentLikeModel subclass: #TwoWayScrollPane
	instanceVariableNames: 'getMenuSelector getMenuTitleSelector xScrollBar yScrollBar scroller'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Obsolete'!
!TwoWayScrollPane commentStamp: '<historical>' prior: 0!
TwoWayScrollPane is now obsolete.  You should be able to use ScrollPane to do both vertical and horizontal scrolling.

As an example, see Morph>>inATwoWayScrollPane and change the first line to create a ScrollPane instead of a TwoWayScrollPane.  It will still work.

(EllipseMorph new extent: 200@150) inATwoWayScrollPane openInWorld

Note that user preferences for ScrollPane may be geared toward text scrolling, so that the horizontal scrollbar may be hidden when not needed, while the vertical scrollbar is always shown.  Use ScrollPane>>alwaysShowHScrollbar: or its variants to adjust this if you want the vertical & horizontal scrollbars to be shown consistently.
!


!TwoWayScrollPane methodsFor: 'access' stamp: 'RAA 10/6/1998 19:45'!
scroller
	^ scroller! !

!TwoWayScrollPane methodsFor: 'access' stamp: 'di 6/7/97 10:42'!
wantsSlot
	"For now do it the old way, until we sort this out"
	^ true! !


!TwoWayScrollPane methodsFor: 'accessing' stamp: 'md 7/29/2005 19:47'!
colorForInsets
	"My submorphs use the surrounding color"

	owner color isColor ifTrue:[^ owner color].
	^ Color white! !


!TwoWayScrollPane methodsFor: 'event handling' stamp: 'di 5/7/1998 09:52'!
handlesMouseDown: evt
	^ true! !

!TwoWayScrollPane methodsFor: 'event handling' stamp: 'di 7/3/1998 12:07'!
handlesMouseOver: evt
	^ true! !

!TwoWayScrollPane methodsFor: 'event handling' stamp: 'RAA 10/6/1998 19:45'!
keyStroke: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"

	scroller submorphs last keyStroke: evt! !

!TwoWayScrollPane methodsFor: 'event handling' stamp: 'RAA 10/6/1998 19:45'!
mouseDown: evt
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseDown: (evt transformedBy: (scroller transformFrom: self))]! !

!TwoWayScrollPane methodsFor: 'event handling' stamp: 'RAA 10/6/1998 18:38'!
mouseEnter: event

	"used to handle retractable scrolbar"! !

!TwoWayScrollPane methodsFor: 'event handling' stamp: 'RAA 10/6/1998 18:38'!
mouseLeave: event

	"used to handle retractable scrolbar"! !

!TwoWayScrollPane methodsFor: 'event handling' stamp: 'RAA 10/6/1998 19:45'!
mouseMove: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseMove: (evt transformedBy: (scroller transformFrom: self))]! !

!TwoWayScrollPane methodsFor: 'event handling' stamp: 'RAA 10/6/1998 19:45'!
mouseUp: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseUp: (evt transformedBy: (scroller transformFrom: self))]! !


!TwoWayScrollPane methodsFor: 'events-processing' stamp: 'RAA 11/23/2000 10:16'!
rejectsEvent: anEvent

	scroller submorphs isEmpty ifTrue: [^true].	"something messed up here"
	scroller firstSubmorph isSyntaxMorph ifTrue: [^ super rejectsEvent: anEvent].
	^self visible not		"ignore locked status"! !


!TwoWayScrollPane methodsFor: 'geometry' stamp: 'nk 7/11/2004 20:08'!
extent: newExtent
	bounds extent = newExtent ifTrue: [^ self].
	super extent: (newExtent max: 36@32).
	self resizeScrollBar; resizeScroller; setScrollDeltas.
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'nk 4/12/2002 14:00'!
fitContents
	"Adjust my size to fit my contents reasonably snugly"

	self extent: scroller submorphBounds extent
				+ (yScrollBar width @ xScrollBar height)
				+ (borderWidth*2)
				 ! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 8/13/1999 15:56'!
leftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	^ self totalScrollRange - (self innerBounds extent * 3 // 4) max: 0@0
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 10/6/1998 19:00'!
resizeScrollBar
	"used to handle left vs right scrollbar"
	yScrollBar bounds: (bounds topLeft extent: 16 @ (bounds height - 16)).
	xScrollBar bounds: ((bounds left + 16) @ (bounds bottom - 16)  extent: (bounds width - 16) @ 16).
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'di 1/29/2001 14:18'!
resizeScroller
	| inner |
	"used to handle left vs right scrollbar"
	inner _ self innerBounds.
	scroller bounds: (inner topLeft + (yScrollBar width@0) corner: (inner bottomRight - (0@xScrollBar height)))! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 10/6/1998 18:40'!
scrollBarFills: aRectangle
	"Return true if a flop-out scrollbar fills the rectangle"
	"used to handle retractable scrolbar"
	^ false! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 8/24/1999 18:13'!
scrollBy: delta
	"Move the contents in the direction delta."
	"For now, delta is assumed to have a zero x-component. Used by scrollIntoView:"
	| r newOffset |

	newOffset _ (scroller offset - delta max: 0@0) min: self leftoverScrollRange.
	scroller offset: newOffset.

	r _ self leftoverScrollRange.
	r y = 0
		ifTrue: [yScrollBar value: 0.0]
		ifFalse: [yScrollBar value: newOffset y asFloat / r y].
	r x = 0
		ifTrue: [xScrollBar value: 0.0]
		ifFalse: [xScrollBar value: newOffset x asFloat / r x].
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 8/21/1999 10:17'!
scrollIntoView: desiredRectangle extra: anumber
	| shift |

	shift _ desiredRectangle deltaToEnsureInOrCentered: (
		scroller offset extent: scroller bounds extent
	)  extra: anumber.
	shift = (0 @ 0) ifFalse: [self scrollBy: (0@0) - shift].
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'di 5/2/2001 10:03'!
setScrollDeltas
	| range scrollDelta totalRange innerBounds |
	totalRange _ self totalScrollRange ifNil: [^ self].
	range _ self leftoverScrollRange.
	innerBounds _ self innerBounds.
	scrollDelta _ 10 @ 10.

	self hideOrShowScrollBar: xScrollBar
		forRange: totalRange x - (innerBounds width - yScrollBar width).
	range x <= 0
		ifTrue: [xScrollBar scrollDelta: 0.02 pageDelta: 0.2.
				xScrollBar interval: 1.0]
		ifFalse: [xScrollBar scrollDelta: (scrollDelta x / range x) asFloat
						pageDelta: (innerBounds width - scrollDelta x / range x) asFloat.
				xScrollBar interval: (innerBounds width - scrollDelta x / totalRange x) asFloat].

	self hideOrShowScrollBar: yScrollBar
		forRange: totalRange y - (innerBounds height - xScrollBar height).
	range y <= 0
		ifTrue: [yScrollBar scrollDelta: 0.02 pageDelta: 0.2.
				yScrollBar interval: 1.0]
		ifFalse: [yScrollBar scrollDelta: (scrollDelta y / range y) asFloat
						pageDelta: (innerBounds height - scrollDelta y / range y) asFloat.
				yScrollBar interval: (innerBounds height - scrollDelta y / totalRange y) asFloat]! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'nk 4/12/2002 14:06'!
totalScrollRange

	"Return the entire scrolling range."
	^ ((scroller localVisibleSubmorphBounds ifNil: [^nil]) encompass: 0@0) extent

! !


!TwoWayScrollPane methodsFor: 'geometry testing' stamp: 'RAA 10/6/1998 18:40'!
containsPoint: aPoint
	(super containsPoint: aPoint) ifTrue: [^ true].
	"Also include scrollbar when it is extended..."
	"used to handle retractable scrolbar"
	^ false! !


!TwoWayScrollPane methodsFor: 'initialization' stamp: 'jam 3/9/2003 17:52'!
createScrollBarNamed: aString 
"creates a scroll bar named as aString"
	| result |
	result _ ScrollBar new model: self slotName: aString.
	result borderWidth: 2;
		 borderColor: #inset.
	^ result! !

!TwoWayScrollPane methodsFor: 'initialization' stamp: 'jam 3/9/2003 17:53'!
createScroller
"create a scroller"
	| result |
	result _ TransformMorph new color: Color transparent.
	result offset: 0 @ 0.
	^ result! !

!TwoWayScrollPane methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ #inset! !

!TwoWayScrollPane methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:03'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self addMorph: (yScrollBar _ self createScrollBarNamed: 'yScrollBar');
		 addMorph: (xScrollBar _ self createScrollBarNamed: 'xScrollBar');
		 addMorph: (scroller _ self createScroller).
	""
	self extent: 150 @ 120! !


!TwoWayScrollPane methodsFor: 'layout' stamp: 'di 5/2/2001 10:01'!
doLayoutIn: layoutBounds
	"layout has changed. update scroll deltas or whatever else"

	(owner notNil and: [owner hasProperty: #autoFitContents])
		ifTrue: [self fitContents].
	super doLayoutIn: layoutBounds.! !


!TwoWayScrollPane methodsFor: 'menu' stamp: 'dgd 2/21/2003 22:33'!
getMenu: shiftKeyState 
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| menu aMenu aTitle |
	getMenuSelector isNil ifTrue: [^nil].
	menu := MenuMorph new defaultTarget: model.
	aTitle := getMenuTitleSelector 
				ifNotNil: [model perform: getMenuTitleSelector].
	getMenuSelector numArgs = 1 
		ifTrue: 
			[aMenu := model perform: getMenuSelector with: menu.
			aTitle ifNotNil: [aMenu addTitle: aTitle].
			^aMenu].
	getMenuSelector numArgs = 2 
		ifTrue: 
			[aMenu := model 
						perform: getMenuSelector
						with: menu
						with: shiftKeyState.
			aTitle ifNotNil: [aMenu addTitle: aTitle].
			^aMenu].
	^self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'RAA 10/6/1998 18:41'!
leftOrRight  "Change scroll bar location"

	"used to handle left vs right scrollbar"! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'nk 4/19/2002 12:58'!
menuSelector: aSelector
	getMenuSelector _ aSelector! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'sw 8/18/1998 12:38'!
menuTitleSelector: aSelector
	getMenuTitleSelector _ aSelector! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'RAA 10/6/1998 18:38'!
retractableOrNot  "Change scroll bar operation"

	"used to handle retractable scrolbar"! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'RAA 10/6/1998 18:41'!
scrollBarOnLeft: aBoolean

	"used to handle left vs right scrollbar"! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:30'!
wantsYellowButtonMenu
	"Answer true if the receiver wants a yellow button menu"
	^ getMenuSelector notNil! !


!TwoWayScrollPane methodsFor: 'retractable scroll bar' stamp: 'RAA 6/9/2000 15:05'!
hideOrShowScrollBar

	^self		"we don't support retractable at the moment"! !

!TwoWayScrollPane methodsFor: 'retractable scroll bar' stamp: 'di 5/2/2001 08:23'!
hideOrShowScrollBar: scrollBar forRange: range

	(self hasProperty: #hideUnneededScrollbars) ifFalse: [^ self].
	(submorphs includes: scrollBar)
		ifTrue: [range <= 0 ifTrue: [scrollBar model: nil; delete]]
		ifFalse: [range > 0 ifTrue: [scrollBar model: self.  self resizeScrollBar; addMorph: scrollBar]]
! !

!TwoWayScrollPane methodsFor: 'retractable scroll bar' stamp: 'tk 8/21/2001 18:11'!
xScrollerHeight

	(submorphs includes: xScrollBar)  "Sorry the logic is reversed :( "
		ifFalse: [^ 0 @ 0]					"already included"
		ifTrue: [^ 0 @ xScrollBar height]	"leave space for it"
! !


!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'!
scrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'!
shiftedYellowButtonActivity
	^ self yellowButtonActivity: true! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:32'!
unshiftedYellowButtonActivity
	^ self yellowButtonActivity: false! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 10/6/1998 22:38'!
xScrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 8/24/1999 16:01'!
xScrollBarValue: scrollValue 

	"although there appear to be no senders, see Slider>>setValue:"

	scroller hasSubmorphs ifFalse: [^ self].
	scroller offset: self leftoverScrollRange x * scrollValue @ scroller offset y! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 6/12/2000 09:01'!
yellowButtonActivity: shiftKeyState
	| menu |
	(menu _ self getMenu: shiftKeyState) ifNotNil:
		[menu setInvokingView: self.
		menu popUpEvent: self activeHand lastEvent in: self world]! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 10/6/1998 22:37'!
yScrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 8/13/1999 15:55'!
yScrollBarValue: scrollValue

	"although there appear to be no senders, see Slider>>setValue:"

	scroller hasSubmorphs ifFalse: [^ self].
	scroller offset: scroller offset x @ (self leftoverScrollRange y * scrollValue)! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TwoWayScrollPane class
	instanceVariableNames: ''!

!TwoWayScrollPane class methodsFor: 'new-morph participation' stamp: 'di 2/21/98 11:02'!
includeInNewMorphMenu
	"OK to instantiate"
	^ true! !
SymbolListTile subclass: #TypeListTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!TypeListTile commentStamp: '<historical>' prior: 0!
A tile that offers a list of supported data types.!


!TypeListTile methodsFor: 'accessing' stamp: 'tak 12/6/2004 02:50'!
value: anObject 
	| scriptEditor |
	super value: anObject.
	(scriptEditor _ self ownerThatIsA: ScriptEditorMorph)
		ifNotNil: [scriptEditor setParameterType: anObject]! !


!TypeListTile methodsFor: 'arrows' stamp: 'em 3/29/2005 15:01'!
addMenuIcon
	"Add a little menu icon; store it in my suffixArrow slot"

	suffixArrow _ ImageMorph new image: (ScriptingSystem formAtKey: #MenuTriangle).
	suffixArrow setBalloonText: 'click here to choose a new type for this parameter' translated.
	self addMorphBack: suffixArrow! !

!TypeListTile methodsFor: 'arrows' stamp: 'tak 12/7/2004 14:28'!
showSuffixChoices
	"When the user clicks on the suffix arrow, put up the type-choices menu"
	"A bit dirty hack, avoided testing whether the down arrow includes mouse point"
	 super showOptions! !


!TypeListTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45'!
initialize
	"Initialize the receiver. Cheesily, we use the extension arrow 
	graphic for a menu icon temporarily"
	super initialize
"".
	self addMenuIcon! !


!TypeListTile methodsFor: 'menus' stamp: 'yo 3/14/2005 12:08'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add morph-specific items to the given menu"

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'choose type...' translated action: #showSuffixChoices! !


!TypeListTile methodsFor: 'mouse handling' stamp: 'tak 12/6/2004 02:43'!
showOptions
	| topScript |
	suffixArrow
		ifNotNil: [(suffixArrow bounds containsPoint: ActiveHand cursorPoint)
				ifTrue: [^ super showOptions]].
	topScript _ self
				outermostMorphThat: [:m | m isKindOf: ScriptEditorMorph].
	topScript
		ifNotNil: [topScript handUserParameterTile]! !


!TypeListTile methodsFor: 'user interface' stamp: 'sw 7/19/2002 14:48'!
acceptNewLiteral: aLiteral
	"Accept the new literal"

	| scriptEditor |
	super acceptNewLiteral: aLiteral.
	(scriptEditor _ self ownerThatIsA: ScriptEditorMorph) ifNotNil:
			[scriptEditor setParameterType: aLiteral asSymbol]! !

!TypeListTile methodsFor: 'user interface' stamp: 'sw 7/19/2002 14:58'!
adjustHelpMessage
	"In this case, don't"! !
Object subclass: #UCSTable
	instanceVariableNames: ''
	classVariableNames: 'GB2312Table JISX0208Table KSX1001Table Latin1Table'
	poolDictionaries: ''
	category: 'Multilingual-Encodings'!
!UCSTable commentStamp: 'yo 10/19/2004 19:54' prior: 0!
This class represents the Unicode conversion table from/to the domestic encodings and Unicode.
!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UCSTable class
	instanceVariableNames: ''!

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:36'!
gb2312Table

	^ GB2312Table.
! !

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:41'!
initialize
"
	self initialize
"

	self initializeGB2312Table.
	self initializeJISX0208Table.
	self initializeKSX1001Table.
	self initializeLatin1Table.
! !

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:33'!
initializeGB2312Table
	"UCSTable initializeGB2312Table"

	| table size gb2312 unicode gb23122 code uIndex u |
	table _ #(16r2121 16r3000 16r2122 16r3001 16r2123 16r3002 16r2124 16r30FB 16r2125 16r02C9 16r2126 16r02C7 16r2127 16r00A8 16r2128 16r3003 16r2129 16r3005 16r212A 16r2015 16r212B 16rFF5E 16r212C 16r2016 16r212D 16r2026 16r212E 16r2018 16r212F 16r2019 16r2130 16r201C 16r2131 16r201D 16r2132 16r3014 16r2133 16r3015 16r2134 16r3008 16r2135 16r3009 16r2136 16r300A 16r2137 16r300B 16r2138 16r300C 16r2139 16r300D 16r213A 16r300E 16r213B 16r300F 16r213C 16r3016 16r213D 16r3017 16r213E 16r3010 16r213F 16r3011 16r2140 16r00B1 16r2141 16r00D7 16r2142 16r00F7 16r2143 16r2236 16r2144 16r2227 16r2145 16r2228 16r2146 16r2211 16r2147 16r220F 16r2148 16r222A 16r2149 16r2229 16r214A 16r2208 16r214B 16r2237 16r214C 16r221A 16r214D 16r22A5 16r214E 16r2225 16r214F 16r2220 16r2150 16r2312 16r2151 16r2299 16r2152 16r222B 16r2153 16r222E 16r2154 16r2261 16r2155 16r224C 16r2156 16r2248 16r2157 16r223D 16r2158 16r221D 16r2159 16r2260 16r215A 16r226E 16r215B 16r226F 16r215C 16r2264 16r215D 16r2265 16r215E 16r221E 16r215F 16r2235 16r2160 16r2234 16r2161 16r2642 16r2162 16r2640 16r2163 16r00B0 16r2164 16r2032 16r2165 16r2033 16r2166 16r2103 16r2167 16rFF04 16r2168 16r00A4 16r2169 16rFFE0 16r216A 16rFFE1 16r216B 16r2030 16r216C 16r00A7 16r216D 16r2116 16r216E 16r2606 16r216F 16r2605 16r2170 16r25CB 16r2171 16r25CF 16r2172 16r25CE 16r2173 16r25C7 16r2174 16r25C6 16r2175 16r25A1 16r2176 16r25A0 16r2177 16r25B3 16r2178 16r25B2 16r2179 16r203B 16r217A 16r2192 16r217B 16r2190 16r217C 16r2191 16r217D 16r2193 16r217E 16r3013 16r2231 16r2488 16r2232 16r2489 16r2233 16r248A 16r2234 16r248B 16r2235 16r248C 16r2236 16r248D 16r2237 16r248E 16r2238 16r248F 16r2239 16r2490 16r223A 16r2491 16r223B 16r2492 16r223C 16r2493 16r223D 16r2494 16r223E 16r2495 16r223F 16r2496 16r2240 16r2497 16r2241 16r2498 16r2242 16r2499 16r2243 16r249A 16r2244 16r249B 16r2245 16r2474 16r2246 16r2475 16r2247 16r2476 16r2248 16r2477 16r2249 16r2478 16r224A 16r2479 16r224B 16r247A 16r224C 16r247B 16r224D 16r247C 16r224E 16r247D 16r224F 16r247E 16r2250 16r247F 16r2251 16r2480 16r2252 16r2481 16r2253 16r2482 16r2254 16r2483 16r2255 16r2484 16r2256 16r2485 16r2257 16r2486 16r2258 16r2487 16r2259 16r2460 16r225A 16r2461 16r225B 16r2462 16r225C 16r2463 16r225D 16r2464 16r225E 16r2465 16r225F 16r2466 16r2260 16r2467 16r2261 16r2468 16r2262 16r2469 16r2265 16r3220 16r2266 16r3221 16r2267 16r3222 16r2268 16r3223 16r2269 16r3224 16r226A 16r3225 16r226B 16r3226 16r226C 16r3227 16r226D 16r3228 16r226E 16r3229 16r2271 16r2160 16r2272 16r2161 16r2273 16r2162 16r2274 16r2163 16r2275 16r2164 16r2276 16r2165 16r2277 16r2166 16r2278 16r2167 16r2279 16r2168 16r227A 16r2169 16r227B 16r216A 16r227C 16r216B 16r2321 16rFF01 16r2322 16rFF02 16r2323 16rFF03 16r2324 16rFFE5 16r2325 16rFF05 16r2326 16rFF06 16r2327 16rFF07 16r2328 16rFF08 16r2329 16rFF09 16r232A 16rFF0A 16r232B 16rFF0B 16r232C 16rFF0C 16r232D 16rFF0D 16r232E 16rFF0E 16r232F 16rFF0F 16r2330 16rFF10 16r2331 16rFF11 16r2332 16rFF12 16r2333 16rFF13 16r2334 16rFF14 16r2335 16rFF15 16r2336 16rFF16 16r2337 16rFF17 16r2338 16rFF18 16r2339 16rFF19 16r233A 16rFF1A 16r233B 16rFF1B 16r233C 16rFF1C 16r233D 16rFF1D 16r233E 16rFF1E 16r233F 16rFF1F 16r2340 16rFF20 16r2341 16rFF21 16r2342 16rFF22 16r2343 16rFF23 16r2344 16rFF24 16r2345 16rFF25 16r2346 16rFF26 16r2347 16rFF27 16r2348 16rFF28 16r2349 16rFF29 16r234A 16rFF2A 16r234B 16rFF2B 16r234C 16rFF2C 16r234D 16rFF2D 16r234E 16rFF2E 16r234F 16rFF2F 16r2350 16rFF30 16r2351 16rFF31 16r2352 16rFF32 16r2353 16rFF33 16r2354 16rFF34 16r2355 16rFF35 16r2356 16rFF36 16r2357 16rFF37 16r2358 16rFF38 16r2359 16rFF39 16r235A 16rFF3A 16r235B 16rFF3B 16r235C 16rFF3C 16r235D 16rFF3D 16r235E 16rFF3E 16r235F 16rFF3F 16r2360 16rFF40 16r2361 16rFF41 16r2362 16rFF42 16r2363 16rFF43 16r2364 16rFF44 16r2365 16rFF45 16r2366 16rFF46 16r2367 16rFF47 16r2368 16rFF48 16r2369 16rFF49 16r236A 16rFF4A 16r236B 16rFF4B 16r236C 16rFF4C 16r236D 16rFF4D 16r236E 16rFF4E 16r236F 16rFF4F 16r2370 16rFF50 16r2371 16rFF51 16r2372 16rFF52 16r2373 16rFF53 16r2374 16rFF54 16r2375 16rFF55 16r2376 16rFF56 16r2377 16rFF57 16r2378 16rFF58 16r2379 16rFF59 16r237A 16rFF5A 16r237B 16rFF5B 16r237C 16rFF5C 16r237D 16rFF5D 16r237E 16rFFE3 16r2421 16r3041 16r2422 16r3042 16r2423 16r3043 16r2424 16r3044 16r2425 16r3045 16r2426 16r3046 16r2427 16r3047 16r2428 16r3048 16r2429 16r3049 16r242A 16r304A 16r242B 16r304B 16r242C 16r304C 16r242D 16r304D 16r242E 16r304E 16r242F 16r304F 16r2430 16r3050 16r2431 16r3051 16r2432 16r3052 16r2433 16r3053 16r2434 16r3054 16r2435 16r3055 16r2436 16r3056 16r2437 16r3057 16r2438 16r3058 16r2439 16r3059 16r243A 16r305A 16r243B 16r305B 16r243C 16r305C 16r243D 16r305D 16r243E 16r305E 16r243F 16r305F 16r2440 16r3060 16r2441 16r3061 16r2442 16r3062 16r2443 16r3063 16r2444 16r3064 16r2445 16r3065 16r2446 16r3066 16r2447 16r3067 16r2448 16r3068 16r2449 16r3069 16r244A 16r306A 16r244B 16r306B 16r244C 16r306C 16r244D 16r306D 16r244E 16r306E 16r244F 16r306F 16r2450 16r3070 16r2451 16r3071 16r2452 16r3072 16r2453 16r3073 16r2454 16r3074 16r2455 16r3075 16r2456 16r3076 16r2457 16r3077 16r2458 16r3078 16r2459 16r3079 16r245A 16r307A 16r245B 16r307B 16r245C 16r307C 16r245D 16r307D 16r245E 16r307E 16r245F 16r307F 16r2460 16r3080 16r2461 16r3081 16r2462 16r3082 16r2463 16r3083 16r2464 16r3084 16r2465 16r3085 16r2466 16r3086 16r2467 16r3087 16r2468 16r3088 16r2469 16r3089 16r246A 16r308A 16r246B 16r308B 16r246C 16r308C 16r246D 16r308D 16r246E 16r308E 16r246F 16r308F 16r2470 16r3090 16r2471 16r3091 16r2472 16r3092 16r2473 16r3093 16r2521 16r30A1 16r2522 16r30A2 16r2523 16r30A3 16r2524 16r30A4 16r2525 16r30A5 16r2526 16r30A6 16r2527 16r30A7 16r2528 16r30A8 16r2529 16r30A9 16r252A 16r30AA 16r252B 16r30AB 16r252C 16r30AC 16r252D 16r30AD 16r252E 16r30AE 16r252F 16r30AF 16r2530 16r30B0 16r2531 16r30B1 16r2532 16r30B2 16r2533 16r30B3 16r2534 16r30B4 16r2535 16r30B5 16r2536 16r30B6 16r2537 16r30B7 16r2538 16r30B8 16r2539 16r30B9 16r253A 16r30BA 16r253B 16r30BB 16r253C 16r30BC 16r253D 16r30BD 16r253E 16r30BE 16r253F 16r30BF 16r2540 16r30C0 16r2541 16r30C1 16r2542 16r30C2 16r2543 16r30C3 16r2544 16r30C4 16r2545 16r30C5 16r2546 16r30C6 16r2547 16r30C7 16r2548 16r30C8 16r2549 16r30C9 16r254A 16r30CA 16r254B 16r30CB 16r254C 16r30CC 16r254D 16r30CD 16r254E 16r30CE 16r254F 16r30CF 16r2550 16r30D0 16r2551 16r30D1 16r2552 16r30D2 16r2553 16r30D3 16r2554 16r30D4 16r2555 16r30D5 16r2556 16r30D6 16r2557 16r30D7 16r2558 16r30D8 16r2559 16r30D9 16r255A 16r30DA 16r255B 16r30DB 16r255C 16r30DC 16r255D 16r30DD 16r255E 16r30DE 16r255F 16r30DF 16r2560 16r30E0 16r2561 16r30E1 16r2562 16r30E2 16r2563 16r30E3 16r2564 16r30E4 16r2565 16r30E5 16r2566 16r30E6 16r2567 16r30E7 16r2568 16r30E8 16r2569 16r30E9 16r256A 16r30EA 16r256B 16r30EB 16r256C 16r30EC 16r256D 16r30ED 16r256E 16r30EE 16r256F 16r30EF 16r2570 16r30F0 16r2571 16r30F1 16r2572 16r30F2 16r2573 16r30F3 16r2574 16r30F4 16r2575 16r30F5 16r2576 16r30F6 16r2621 16r0391 16r2622 16r0392 16r2623 16r0393 16r2624 16r0394 16r2625 16r0395 16r2626 16r0396 16r2627 16r0397 16r2628 16r0398 16r2629 16r0399 16r262A 16r039A 16r262B 16r039B 16r262C 16r039C 16r262D 16r039D 16r262E 16r039E 16r262F 16r039F 16r2630 16r03A0 16r2631 16r03A1 16r2632 16r03A3 16r2633 16r03A4 16r2634 16r03A5 16r2635 16r03A6 16r2636 16r03A7 16r2637 16r03A8 16r2638 16r03A9 16r2641 16r03B1 16r2642 16r03B2 16r2643 16r03B3 16r2644 16r03B4 16r2645 16r03B5 16r2646 16r03B6 16r2647 16r03B7 16r2648 16r03B8 16r2649 16r03B9 16r264A 16r03BA 16r264B 16r03BB 16r264C 16r03BC 16r264D 16r03BD 16r264E 16r03BE 16r264F 16r03BF 16r2650 16r03C0 16r2651 16r03C1 16r2652 16r03C3 16r2653 16r03C4 16r2654 16r03C5 16r2655 16r03C6 16r2656 16r03C7 16r2657 16r03C8 16r2658 16r03C9 16r2721 16r0410 16r2722 16r0411 16r2723 16r0412 16r2724 16r0413 16r2725 16r0414 16r2726 16r0415 16r2727 16r0401 16r2728 16r0416 16r2729 16r0417 16r272A 16r0418 16r272B 16r0419 16r272C 16r041A 16r272D 16r041B 16r272E 16r041C 16r272F 16r041D 16r2730 16r041E 16r2731 16r041F 16r2732 16r0420 16r2733 16r0421 16r2734 16r0422 16r2735 16r0423 16r2736 16r0424 16r2737 16r0425 16r2738 16r0426 16r2739 16r0427 16r273A 16r0428 16r273B 16r0429 16r273C 16r042A 16r273D 16r042B 16r273E 16r042C 16r273F 16r042D 16r2740 16r042E 16r2741 16r042F 16r2751 16r0430 16r2752 16r0431 16r2753 16r0432 16r2754 16r0433 16r2755 16r0434 16r2756 16r0435 16r2757 16r0451 16r2758 16r0436 16r2759 16r0437 16r275A 16r0438 16r275B 16r0439 16r275C 16r043A 16r275D 16r043B 16r275E 16r043C 16r275F 16r043D 16r2760 16r043E 16r2761 16r043F 16r2762 16r0440 16r2763 16r0441 16r2764 16r0442 16r2765 16r0443 16r2766 16r0444 16r2767 16r0445 16r2768 16r0446 16r2769 16r0447 16r276A 16r0448 16r276B 16r0449 16r276C 16r044A 16r276D 16r044B 16r276E 16r044C 16r276F 16r044D 16r2770 16r044E 16r2771 16r044F 16r2821 16r0101 16r2822 16r00E1 16r2823 16r01CE 16r2824 16r00E0 16r2825 16r0113 16r2826 16r00E9 16r2827 16r011B 16r2828 16r00E8 16r2829 16r012B 16r282A 16r00ED 16r282B 16r01D0 16r282C 16r00EC 16r282D 16r014D 16r282E 16r00F3 16r282F 16r01D2 16r2830 16r00F2 16r2831 16r016B 16r2832 16r00FA 16r2833 16r01D4 16r2834 16r00F9 16r2835 16r01D6 16r2836 16r01D8 16r2837 16r01DA 16r2838 16r01DC 16r2839 16r00FC 16r283A 16r00EA 16r2845 16r3105 16r2846 16r3106 16r2847 16r3107 16r2848 16r3108 16r2849 16r3109 16r284A 16r310A 16r284B 16r310B 16r284C 16r310C 16r284D 16r310D 16r284E 16r310E 16r284F 16r310F 16r2850 16r3110 16r2851 16r3111 16r2852 16r3112 16r2853 16r3113 16r2854 16r3114 16r2855 16r3115 16r2856 16r3116 16r2857 16r3117 16r2858 16r3118 16r2859 16r3119 16r285A 16r311A 16r285B 16r311B 16r285C 16r311C 16r285D 16r311D 16r285E 16r311E 16r285F 16r311F 16r2860 16r3120 16r2861 16r3121 16r2862 16r3122 16r2863 16r3123 16r2864 16r3124 16r2865 16r3125 16r2866 16r3126 16r2867 16r3127 16r2868 16r3128 16r2869 16r3129 16r2924 16r2500 16r2925 16r2501 16r2926 16r2502 16r2927 16r2503 16r2928 16r2504 16r2929 16r2505 16r292A 16r2506 16r292B 16r2507 16r292C 16r2508 16r292D 16r2509 16r292E 16r250A 16r292F 16r250B 16r2930 16r250C 16r2931 16r250D 16r2932 16r250E 16r2933 16r250F 16r2934 16r2510 16r2935 16r2511 16r2936 16r2512 16r2937 16r2513 16r2938 16r2514 16r2939 16r2515 16r293A 16r2516 16r293B 16r2517 16r293C 16r2518 16r293D 16r2519 16r293E 16r251A 16r293F 16r251B 16r2940 16r251C 16r2941 16r251D 16r2942 16r251E 16r2943 16r251F 16r2944 16r2520 16r2945 16r2521 16r2946 16r2522 16r2947 16r2523 16r2948 16r2524 16r2949 16r2525 16r294A 16r2526 16r294B 16r2527 16r294C 16r2528 16r294D 16r2529 16r294E 16r252A 16r294F 16r252B 16r2950 16r252C 16r2951 16r252D 16r2952 16r252E 16r2953 16r252F 16r2954 16r2530 16r2955 16r2531 16r2956 16r2532 16r2957 16r2533 16r2958 16r2534 16r2959 16r2535 16r295A 16r2536 16r295B 16r2537 16r295C 16r2538 16r295D 16r2539 16r295E 16r253A 16r295F 16r253B 16r2960 16r253C 16r2961 16r253D 16r2962 16r253E 16r2963 16r253F 16r2964 16r2540 16r2965 16r2541 16r2966 16r2542 16r2967 16r2543 16r2968 16r2544 16r2969 16r2545 16r296A 16r2546 16r296B 16r2547 16r296C 16r2548 16r296D 16r2549 16r296E 16r254A 16r296F 16r254B 16r3021 16r554A 16r3022 16r963F 16r3023 16r57C3 16r3024 16r6328 16r3025 16r54CE 16r3026 16r5509 16r3027 16r54C0 16r3028 16r7691 16r3029 16r764C 16r302A 16r853C 16r302B 16r77EE 16r302C 16r827E 16r302D 16r788D 16r302E 16r7231 16r302F 16r9698 16r3030 16r978D 16r3031 16r6C28 16r3032 16r5B89 16r3033 16r4FFA 16r3034 16r6309 16r3035 16r6697 16r3036 16r5CB8 16r3037 16r80FA 16r3038 16r6848 16r3039 16r80AE 16r303A 16r6602 16r303B 16r76CE 16r303C 16r51F9 16r303D 16r6556 16r303E 16r71AC 16r303F 16r7FF1 16r3040 16r8884 16r3041 16r50B2 16r3042 16r5965 16r3043 16r61CA 16r3044 16r6FB3 16r3045 16r82AD 16r3046 16r634C 16r3047 16r6252 16r3048 16r53ED 16r3049 16r5427 16r304A 16r7B06 16r304B 16r516B 16r304C 16r75A4 16r304D 16r5DF4 16r304E 16r62D4 16r304F 16r8DCB 16r3050 16r9776 16r3051 16r628A 16r3052 16r8019 16r3053 16r575D 16r3054 16r9738 16r3055 16r7F62 16r3056 16r7238 16r3057 16r767D 16r3058 16r67CF 16r3059 16r767E 16r305A 16r6446 16r305B 16r4F70 16r305C 16r8D25 16r305D 16r62DC 16r305E 16r7A17 16r305F 16r6591 16r3060 16r73ED 16r3061 16r642C 16r3062 16r6273 16r3063 16r822C 16r3064 16r9881 16r3065 16r677F 16r3066 16r7248 16r3067 16r626E 16r3068 16r62CC 16r3069 16r4F34 16r306A 16r74E3 16r306B 16r534A 16r306C 16r529E 16r306D 16r7ECA 16r306E 16r90A6 16r306F 16r5E2E 16r3070 16r6886 16r3071 16r699C 16r3072 16r8180 16r3073 16r7ED1 16r3074 16r68D2 16r3075 16r78C5 16r3076 16r868C 16r3077 16r9551 16r3078 16r508D 16r3079 16r8C24 16r307A 16r82DE 16r307B 16r80DE 16r307C 16r5305 16r307D 16r8912 16r307E 16r5265 16r3121 16r8584 16r3122 16r96F9 16r3123 16r4FDD 16r3124 16r5821 16r3125 16r9971 16r3126 16r5B9D 16r3127 16r62B1 16r3128 16r62A5 16r3129 16r66B4 16r312A 16r8C79 16r312B 16r9C8D 16r312C 16r7206 16r312D 16r676F 16r312E 16r7891 16r312F 16r60B2 16r3130 16r5351 16r3131 16r5317 16r3132 16r8F88 16r3133 16r80CC 16r3134 16r8D1D 16r3135 16r94A1 16r3136 16r500D 16r3137 16r72C8 16r3138 16r5907 16r3139 16r60EB 16r313A 16r7119 16r313B 16r88AB 16r313C 16r5954 16r313D 16r82EF 16r313E 16r672C 16r313F 16r7B28 16r3140 16r5D29 16r3141 16r7EF7 16r3142 16r752D 16r3143 16r6CF5 16r3144 16r8E66 16r3145 16r8FF8 16r3146 16r903C 16r3147 16r9F3B 16r3148 16r6BD4 16r3149 16r9119 16r314A 16r7B14 16r314B 16r5F7C 16r314C 16r78A7 16r314D 16r84D6 16r314E 16r853D 16r314F 16r6BD5 16r3150 16r6BD9 16r3151 16r6BD6 16r3152 16r5E01 16r3153 16r5E87 16r3154 16r75F9 16r3155 16r95ED 16r3156 16r655D 16r3157 16r5F0A 16r3158 16r5FC5 16r3159 16r8F9F 16r315A 16r58C1 16r315B 16r81C2 16r315C 16r907F 16r315D 16r965B 16r315E 16r97AD 16r315F 16r8FB9 16r3160 16r7F16 16r3161 16r8D2C 16r3162 16r6241 16r3163 16r4FBF 16r3164 16r53D8 16r3165 16r535E 16r3166 16r8FA8 16r3167 16r8FA9 16r3168 16r8FAB 16r3169 16r904D 16r316A 16r6807 16r316B 16r5F6A 16r316C 16r8198 16r316D 16r8868 16r316E 16r9CD6 16r316F 16r618B 16r3170 16r522B 16r3171 16r762A 16r3172 16r5F6C 16r3173 16r658C 16r3174 16r6FD2 16r3175 16r6EE8 16r3176 16r5BBE 16r3177 16r6448 16r3178 16r5175 16r3179 16r51B0 16r317A 16r67C4 16r317B 16r4E19 16r317C 16r79C9 16r317D 16r997C 16r317E 16r70B3 16r3221 16r75C5 16r3222 16r5E76 16r3223 16r73BB 16r3224 16r83E0 16r3225 16r64AD 16r3226 16r62E8 16r3227 16r94B5 16r3228 16r6CE2 16r3229 16r535A 16r322A 16r52C3 16r322B 16r640F 16r322C 16r94C2 16r322D 16r7B94 16r322E 16r4F2F 16r322F 16r5E1B 16r3230 16r8236 16r3231 16r8116 16r3232 16r818A 16r3233 16r6E24 16r3234 16r6CCA 16r3235 16r9A73 16r3236 16r6355 16r3237 16r535C 16r3238 16r54FA 16r3239 16r8865 16r323A 16r57E0 16r323B 16r4E0D 16r323C 16r5E03 16r323D 16r6B65 16r323E 16r7C3F 16r323F 16r90E8 16r3240 16r6016 16r3241 16r64E6 16r3242 16r731C 16r3243 16r88C1 16r3244 16r6750 16r3245 16r624D 16r3246 16r8D22 16r3247 16r776C 16r3248 16r8E29 16r3249 16r91C7 16r324A 16r5F69 16r324B 16r83DC 16r324C 16r8521 16r324D 16r9910 16r324E 16r53C2 16r324F 16r8695 16r3250 16r6B8B 16r3251 16r60ED 16r3252 16r60E8 16r3253 16r707F 16r3254 16r82CD 16r3255 16r8231 16r3256 16r4ED3 16r3257 16r6CA7 16r3258 16r85CF 16r3259 16r64CD 16r325A 16r7CD9 16r325B 16r69FD 16r325C 16r66F9 16r325D 16r8349 16r325E 16r5395 16r325F 16r7B56 16r3260 16r4FA7 16r3261 16r518C 16r3262 16r6D4B 16r3263 16r5C42 16r3264 16r8E6D 16r3265 16r63D2 16r3266 16r53C9 16r3267 16r832C 16r3268 16r8336 16r3269 16r67E5 16r326A 16r78B4 16r326B 16r643D 16r326C 16r5BDF 16r326D 16r5C94 16r326E 16r5DEE 16r326F 16r8BE7 16r3270 16r62C6 16r3271 16r67F4 16r3272 16r8C7A 16r3273 16r6400 16r3274 16r63BA 16r3275 16r8749 16r3276 16r998B 16r3277 16r8C17 16r3278 16r7F20 16r3279 16r94F2 16r327A 16r4EA7 16r327B 16r9610 16r327C 16r98A4 16r327D 16r660C 16r327E 16r7316 16r3321 16r573A 16r3322 16r5C1D 16r3323 16r5E38 16r3324 16r957F 16r3325 16r507F 16r3326 16r80A0 16r3327 16r5382 16r3328 16r655E 16r3329 16r7545 16r332A 16r5531 16r332B 16r5021 16r332C 16r8D85 16r332D 16r6284 16r332E 16r949E 16r332F 16r671D 16r3330 16r5632 16r3331 16r6F6E 16r3332 16r5DE2 16r3333 16r5435 16r3334 16r7092 16r3335 16r8F66 16r3336 16r626F 16r3337 16r64A4 16r3338 16r63A3 16r3339 16r5F7B 16r333A 16r6F88 16r333B 16r90F4 16r333C 16r81E3 16r333D 16r8FB0 16r333E 16r5C18 16r333F 16r6668 16r3340 16r5FF1 16r3341 16r6C89 16r3342 16r9648 16r3343 16r8D81 16r3344 16r886C 16r3345 16r6491 16r3346 16r79F0 16r3347 16r57CE 16r3348 16r6A59 16r3349 16r6210 16r334A 16r5448 16r334B 16r4E58 16r334C 16r7A0B 16r334D 16r60E9 16r334E 16r6F84 16r334F 16r8BDA 16r3350 16r627F 16r3351 16r901E 16r3352 16r9A8B 16r3353 16r79E4 16r3354 16r5403 16r3355 16r75F4 16r3356 16r6301 16r3357 16r5319 16r3358 16r6C60 16r3359 16r8FDF 16r335A 16r5F1B 16r335B 16r9A70 16r335C 16r803B 16r335D 16r9F7F 16r335E 16r4F88 16r335F 16r5C3A 16r3360 16r8D64 16r3361 16r7FC5 16r3362 16r65A5 16r3363 16r70BD 16r3364 16r5145 16r3365 16r51B2 16r3366 16r866B 16r3367 16r5D07 16r3368 16r5BA0 16r3369 16r62BD 16r336A 16r916C 16r336B 16r7574 16r336C 16r8E0C 16r336D 16r7A20 16r336E 16r6101 16r336F 16r7B79 16r3370 16r4EC7 16r3371 16r7EF8 16r3372 16r7785 16r3373 16r4E11 16r3374 16r81ED 16r3375 16r521D 16r3376 16r51FA 16r3377 16r6A71 16r3378 16r53A8 16r3379 16r8E87 16r337A 16r9504 16r337B 16r96CF 16r337C 16r6EC1 16r337D 16r9664 16r337E 16r695A 16r3421 16r7840 16r3422 16r50A8 16r3423 16r77D7 16r3424 16r6410 16r3425 16r89E6 16r3426 16r5904 16r3427 16r63E3 16r3428 16r5DDD 16r3429 16r7A7F 16r342A 16r693D 16r342B 16r4F20 16r342C 16r8239 16r342D 16r5598 16r342E 16r4E32 16r342F 16r75AE 16r3430 16r7A97 16r3431 16r5E62 16r3432 16r5E8A 16r3433 16r95EF 16r3434 16r521B 16r3435 16r5439 16r3436 16r708A 16r3437 16r6376 16r3438 16r9524 16r3439 16r5782 16r343A 16r6625 16r343B 16r693F 16r343C 16r9187 16r343D 16r5507 16r343E 16r6DF3 16r343F 16r7EAF 16r3440 16r8822 16r3441 16r6233 16r3442 16r7EF0 16r3443 16r75B5 16r3444 16r8328 16r3445 16r78C1 16r3446 16r96CC 16r3447 16r8F9E 16r3448 16r6148 16r3449 16r74F7 16r344A 16r8BCD 16r344B 16r6B64 16r344C 16r523A 16r344D 16r8D50 16r344E 16r6B21 16r344F 16r806A 16r3450 16r8471 16r3451 16r56F1 16r3452 16r5306 16r3453 16r4ECE 16r3454 16r4E1B 16r3455 16r51D1 16r3456 16r7C97 16r3457 16r918B 16r3458 16r7C07 16r3459 16r4FC3 16r345A 16r8E7F 16r345B 16r7BE1 16r345C 16r7A9C 16r345D 16r6467 16r345E 16r5D14 16r345F 16r50AC 16r3460 16r8106 16r3461 16r7601 16r3462 16r7CB9 16r3463 16r6DEC 16r3464 16r7FE0 16r3465 16r6751 16r3466 16r5B58 16r3467 16r5BF8 16r3468 16r78CB 16r3469 16r64AE 16r346A 16r6413 16r346B 16r63AA 16r346C 16r632B 16r346D 16r9519 16r346E 16r642D 16r346F 16r8FBE 16r3470 16r7B54 16r3471 16r7629 16r3472 16r6253 16r3473 16r5927 16r3474 16r5446 16r3475 16r6B79 16r3476 16r50A3 16r3477 16r6234 16r3478 16r5E26 16r3479 16r6B86 16r347A 16r4EE3 16r347B 16r8D37 16r347C 16r888B 16r347D 16r5F85 16r347E 16r902E 16r3521 16r6020 16r3522 16r803D 16r3523 16r62C5 16r3524 16r4E39 16r3525 16r5355 16r3526 16r90F8 16r3527 16r63B8 16r3528 16r80C6 16r3529 16r65E6 16r352A 16r6C2E 16r352B 16r4F46 16r352C 16r60EE 16r352D 16r6DE1 16r352E 16r8BDE 16r352F 16r5F39 16r3530 16r86CB 16r3531 16r5F53 16r3532 16r6321 16r3533 16r515A 16r3534 16r8361 16r3535 16r6863 16r3536 16r5200 16r3537 16r6363 16r3538 16r8E48 16r3539 16r5012 16r353A 16r5C9B 16r353B 16r7977 16r353C 16r5BFC 16r353D 16r5230 16r353E 16r7A3B 16r353F 16r60BC 16r3540 16r9053 16r3541 16r76D7 16r3542 16r5FB7 16r3543 16r5F97 16r3544 16r7684 16r3545 16r8E6C 16r3546 16r706F 16r3547 16r767B 16r3548 16r7B49 16r3549 16r77AA 16r354A 16r51F3 16r354B 16r9093 16r354C 16r5824 16r354D 16r4F4E 16r354E 16r6EF4 16r354F 16r8FEA 16r3550 16r654C 16r3551 16r7B1B 16r3552 16r72C4 16r3553 16r6DA4 16r3554 16r7FDF 16r3555 16r5AE1 16r3556 16r62B5 16r3557 16r5E95 16r3558 16r5730 16r3559 16r8482 16r355A 16r7B2C 16r355B 16r5E1D 16r355C 16r5F1F 16r355D 16r9012 16r355E 16r7F14 16r355F 16r98A0 16r3560 16r6382 16r3561 16r6EC7 16r3562 16r7898 16r3563 16r70B9 16r3564 16r5178 16r3565 16r975B 16r3566 16r57AB 16r3567 16r7535 16r3568 16r4F43 16r3569 16r7538 16r356A 16r5E97 16r356B 16r60E6 16r356C 16r5960 16r356D 16r6DC0 16r356E 16r6BBF 16r356F 16r7889 16r3570 16r53FC 16r3571 16r96D5 16r3572 16r51CB 16r3573 16r5201 16r3574 16r6389 16r3575 16r540A 16r3576 16r9493 16r3577 16r8C03 16r3578 16r8DCC 16r3579 16r7239 16r357A 16r789F 16r357B 16r8776 16r357C 16r8FED 16r357D 16r8C0D 16r357E 16r53E0 16r3621 16r4E01 16r3622 16r76EF 16r3623 16r53EE 16r3624 16r9489 16r3625 16r9876 16r3626 16r9F0E 16r3627 16r952D 16r3628 16r5B9A 16r3629 16r8BA2 16r362A 16r4E22 16r362B 16r4E1C 16r362C 16r51AC 16r362D 16r8463 16r362E 16r61C2 16r362F 16r52A8 16r3630 16r680B 16r3631 16r4F97 16r3632 16r606B 16r3633 16r51BB 16r3634 16r6D1E 16r3635 16r515C 16r3636 16r6296 16r3637 16r6597 16r3638 16r9661 16r3639 16r8C46 16r363A 16r9017 16r363B 16r75D8 16r363C 16r90FD 16r363D 16r7763 16r363E 16r6BD2 16r363F 16r728A 16r3640 16r72EC 16r3641 16r8BFB 16r3642 16r5835 16r3643 16r7779 16r3644 16r8D4C 16r3645 16r675C 16r3646 16r9540 16r3647 16r809A 16r3648 16r5EA6 16r3649 16r6E21 16r364A 16r5992 16r364B 16r7AEF 16r364C 16r77ED 16r364D 16r953B 16r364E 16r6BB5 16r364F 16r65AD 16r3650 16r7F0E 16r3651 16r5806 16r3652 16r5151 16r3653 16r961F 16r3654 16r5BF9 16r3655 16r58A9 16r3656 16r5428 16r3657 16r8E72 16r3658 16r6566 16r3659 16r987F 16r365A 16r56E4 16r365B 16r949D 16r365C 16r76FE 16r365D 16r9041 16r365E 16r6387 16r365F 16r54C6 16r3660 16r591A 16r3661 16r593A 16r3662 16r579B 16r3663 16r8EB2 16r3664 16r6735 16r3665 16r8DFA 16r3666 16r8235 16r3667 16r5241 16r3668 16r60F0 16r3669 16r5815 16r366A 16r86FE 16r366B 16r5CE8 16r366C 16r9E45 16r366D 16r4FC4 16r366E 16r989D 16r366F 16r8BB9 16r3670 16r5A25 16r3671 16r6076 16r3672 16r5384 16r3673 16r627C 16r3674 16r904F 16r3675 16r9102 16r3676 16r997F 16r3677 16r6069 16r3678 16r800C 16r3679 16r513F 16r367A 16r8033 16r367B 16r5C14 16r367C 16r9975 16r367D 16r6D31 16r367E 16r4E8C 16r3721 16r8D30 16r3722 16r53D1 16r3723 16r7F5A 16r3724 16r7B4F 16r3725 16r4F10 16r3726 16r4E4F 16r3727 16r9600 16r3728 16r6CD5 16r3729 16r73D0 16r372A 16r85E9 16r372B 16r5E06 16r372C 16r756A 16r372D 16r7FFB 16r372E 16r6A0A 16r372F 16r77FE 16r3730 16r9492 16r3731 16r7E41 16r3732 16r51E1 16r3733 16r70E6 16r3734 16r53CD 16r3735 16r8FD4 16r3736 16r8303 16r3737 16r8D29 16r3738 16r72AF 16r3739 16r996D 16r373A 16r6CDB 16r373B 16r574A 16r373C 16r82B3 16r373D 16r65B9 16r373E 16r80AA 16r373F 16r623F 16r3740 16r9632 16r3741 16r59A8 16r3742 16r4EFF 16r3743 16r8BBF 16r3744 16r7EBA 16r3745 16r653E 16r3746 16r83F2 16r3747 16r975E 16r3748 16r5561 16r3749 16r98DE 16r374A 16r80A5 16r374B 16r532A 16r374C 16r8BFD 16r374D 16r5420 16r374E 16r80BA 16r374F 16r5E9F 16r3750 16r6CB8 16r3751 16r8D39 16r3752 16r82AC 16r3753 16r915A 16r3754 16r5429 16r3755 16r6C1B 16r3756 16r5206 16r3757 16r7EB7 16r3758 16r575F 16r3759 16r711A 16r375A 16r6C7E 16r375B 16r7C89 16r375C 16r594B 16r375D 16r4EFD 16r375E 16r5FFF 16r375F 16r6124 16r3760 16r7CAA 16r3761 16r4E30 16r3762 16r5C01 16r3763 16r67AB 16r3764 16r8702 16r3765 16r5CF0 16r3766 16r950B 16r3767 16r98CE 16r3768 16r75AF 16r3769 16r70FD 16r376A 16r9022 16r376B 16r51AF 16r376C 16r7F1D 16r376D 16r8BBD 16r376E 16r5949 16r376F 16r51E4 16r3770 16r4F5B 16r3771 16r5426 16r3772 16r592B 16r3773 16r6577 16r3774 16r80A4 16r3775 16r5B75 16r3776 16r6276 16r3777 16r62C2 16r3778 16r8F90 16r3779 16r5E45 16r377A 16r6C1F 16r377B 16r7B26 16r377C 16r4F0F 16r377D 16r4FD8 16r377E 16r670D 16r3821 16r6D6E 16r3822 16r6DAA 16r3823 16r798F 16r3824 16r88B1 16r3825 16r5F17 16r3826 16r752B 16r3827 16r629A 16r3828 16r8F85 16r3829 16r4FEF 16r382A 16r91DC 16r382B 16r65A7 16r382C 16r812F 16r382D 16r8151 16r382E 16r5E9C 16r382F 16r8150 16r3830 16r8D74 16r3831 16r526F 16r3832 16r8986 16r3833 16r8D4B 16r3834 16r590D 16r3835 16r5085 16r3836 16r4ED8 16r3837 16r961C 16r3838 16r7236 16r3839 16r8179 16r383A 16r8D1F 16r383B 16r5BCC 16r383C 16r8BA3 16r383D 16r9644 16r383E 16r5987 16r383F 16r7F1A 16r3840 16r5490 16r3841 16r5676 16r3842 16r560E 16r3843 16r8BE5 16r3844 16r6539 16r3845 16r6982 16r3846 16r9499 16r3847 16r76D6 16r3848 16r6E89 16r3849 16r5E72 16r384A 16r7518 16r384B 16r6746 16r384C 16r67D1 16r384D 16r7AFF 16r384E 16r809D 16r384F 16r8D76 16r3850 16r611F 16r3851 16r79C6 16r3852 16r6562 16r3853 16r8D63 16r3854 16r5188 16r3855 16r521A 16r3856 16r94A2 16r3857 16r7F38 16r3858 16r809B 16r3859 16r7EB2 16r385A 16r5C97 16r385B 16r6E2F 16r385C 16r6760 16r385D 16r7BD9 16r385E 16r768B 16r385F 16r9AD8 16r3860 16r818F 16r3861 16r7F94 16r3862 16r7CD5 16r3863 16r641E 16r3864 16r9550 16r3865 16r7A3F 16r3866 16r544A 16r3867 16r54E5 16r3868 16r6B4C 16r3869 16r6401 16r386A 16r6208 16r386B 16r9E3D 16r386C 16r80F3 16r386D 16r7599 16r386E 16r5272 16r386F 16r9769 16r3870 16r845B 16r3871 16r683C 16r3872 16r86E4 16r3873 16r9601 16r3874 16r9694 16r3875 16r94EC 16r3876 16r4E2A 16r3877 16r5404 16r3878 16r7ED9 16r3879 16r6839 16r387A 16r8DDF 16r387B 16r8015 16r387C 16r66F4 16r387D 16r5E9A 16r387E 16r7FB9 16r3921 16r57C2 16r3922 16r803F 16r3923 16r6897 16r3924 16r5DE5 16r3925 16r653B 16r3926 16r529F 16r3927 16r606D 16r3928 16r9F9A 16r3929 16r4F9B 16r392A 16r8EAC 16r392B 16r516C 16r392C 16r5BAB 16r392D 16r5F13 16r392E 16r5DE9 16r392F 16r6C5E 16r3930 16r62F1 16r3931 16r8D21 16r3932 16r5171 16r3933 16r94A9 16r3934 16r52FE 16r3935 16r6C9F 16r3936 16r82DF 16r3937 16r72D7 16r3938 16r57A2 16r3939 16r6784 16r393A 16r8D2D 16r393B 16r591F 16r393C 16r8F9C 16r393D 16r83C7 16r393E 16r5495 16r393F 16r7B8D 16r3940 16r4F30 16r3941 16r6CBD 16r3942 16r5B64 16r3943 16r59D1 16r3944 16r9F13 16r3945 16r53E4 16r3946 16r86CA 16r3947 16r9AA8 16r3948 16r8C37 16r3949 16r80A1 16r394A 16r6545 16r394B 16r987E 16r394C 16r56FA 16r394D 16r96C7 16r394E 16r522E 16r394F 16r74DC 16r3950 16r5250 16r3951 16r5BE1 16r3952 16r6302 16r3953 16r8902 16r3954 16r4E56 16r3955 16r62D0 16r3956 16r602A 16r3957 16r68FA 16r3958 16r5173 16r3959 16r5B98 16r395A 16r51A0 16r395B 16r89C2 16r395C 16r7BA1 16r395D 16r9986 16r395E 16r7F50 16r395F 16r60EF 16r3960 16r704C 16r3961 16r8D2F 16r3962 16r5149 16r3963 16r5E7F 16r3964 16r901B 16r3965 16r7470 16r3966 16r89C4 16r3967 16r572D 16r3968 16r7845 16r3969 16r5F52 16r396A 16r9F9F 16r396B 16r95FA 16r396C 16r8F68 16r396D 16r9B3C 16r396E 16r8BE1 16r396F 16r7678 16r3970 16r6842 16r3971 16r67DC 16r3972 16r8DEA 16r3973 16r8D35 16r3974 16r523D 16r3975 16r8F8A 16r3976 16r6EDA 16r3977 16r68CD 16r3978 16r9505 16r3979 16r90ED 16r397A 16r56FD 16r397B 16r679C 16r397C 16r88F9 16r397D 16r8FC7 16r397E 16r54C8 16r3A21 16r9AB8 16r3A22 16r5B69 16r3A23 16r6D77 16r3A24 16r6C26 16r3A25 16r4EA5 16r3A26 16r5BB3 16r3A27 16r9A87 16r3A28 16r9163 16r3A29 16r61A8 16r3A2A 16r90AF 16r3A2B 16r97E9 16r3A2C 16r542B 16r3A2D 16r6DB5 16r3A2E 16r5BD2 16r3A2F 16r51FD 16r3A30 16r558A 16r3A31 16r7F55 16r3A32 16r7FF0 16r3A33 16r64BC 16r3A34 16r634D 16r3A35 16r65F1 16r3A36 16r61BE 16r3A37 16r608D 16r3A38 16r710A 16r3A39 16r6C57 16r3A3A 16r6C49 16r3A3B 16r592F 16r3A3C 16r676D 16r3A3D 16r822A 16r3A3E 16r58D5 16r3A3F 16r568E 16r3A40 16r8C6A 16r3A41 16r6BEB 16r3A42 16r90DD 16r3A43 16r597D 16r3A44 16r8017 16r3A45 16r53F7 16r3A46 16r6D69 16r3A47 16r5475 16r3A48 16r559D 16r3A49 16r8377 16r3A4A 16r83CF 16r3A4B 16r6838 16r3A4C 16r79BE 16r3A4D 16r548C 16r3A4E 16r4F55 16r3A4F 16r5408 16r3A50 16r76D2 16r3A51 16r8C89 16r3A52 16r9602 16r3A53 16r6CB3 16r3A54 16r6DB8 16r3A55 16r8D6B 16r3A56 16r8910 16r3A57 16r9E64 16r3A58 16r8D3A 16r3A59 16r563F 16r3A5A 16r9ED1 16r3A5B 16r75D5 16r3A5C 16r5F88 16r3A5D 16r72E0 16r3A5E 16r6068 16r3A5F 16r54FC 16r3A60 16r4EA8 16r3A61 16r6A2A 16r3A62 16r8861 16r3A63 16r6052 16r3A64 16r8F70 16r3A65 16r54C4 16r3A66 16r70D8 16r3A67 16r8679 16r3A68 16r9E3F 16r3A69 16r6D2A 16r3A6A 16r5B8F 16r3A6B 16r5F18 16r3A6C 16r7EA2 16r3A6D 16r5589 16r3A6E 16r4FAF 16r3A6F 16r7334 16r3A70 16r543C 16r3A71 16r539A 16r3A72 16r5019 16r3A73 16r540E 16r3A74 16r547C 16r3A75 16r4E4E 16r3A76 16r5FFD 16r3A77 16r745A 16r3A78 16r58F6 16r3A79 16r846B 16r3A7A 16r80E1 16r3A7B 16r8774 16r3A7C 16r72D0 16r3A7D 16r7CCA 16r3A7E 16r6E56 16r3B21 16r5F27 16r3B22 16r864E 16r3B23 16r552C 16r3B24 16r62A4 16r3B25 16r4E92 16r3B26 16r6CAA 16r3B27 16r6237 16r3B28 16r82B1 16r3B29 16r54D7 16r3B2A 16r534E 16r3B2B 16r733E 16r3B2C 16r6ED1 16r3B2D 16r753B 16r3B2E 16r5212 16r3B2F 16r5316 16r3B30 16r8BDD 16r3B31 16r69D0 16r3B32 16r5F8A 16r3B33 16r6000 16r3B34 16r6DEE 16r3B35 16r574F 16r3B36 16r6B22 16r3B37 16r73AF 16r3B38 16r6853 16r3B39 16r8FD8 16r3B3A 16r7F13 16r3B3B 16r6362 16r3B3C 16r60A3 16r3B3D 16r5524 16r3B3E 16r75EA 16r3B3F 16r8C62 16r3B40 16r7115 16r3B41 16r6DA3 16r3B42 16r5BA6 16r3B43 16r5E7B 16r3B44 16r8352 16r3B45 16r614C 16r3B46 16r9EC4 16r3B47 16r78FA 16r3B48 16r8757 16r3B49 16r7C27 16r3B4A 16r7687 16r3B4B 16r51F0 16r3B4C 16r60F6 16r3B4D 16r714C 16r3B4E 16r6643 16r3B4F 16r5E4C 16r3B50 16r604D 16r3B51 16r8C0E 16r3B52 16r7070 16r3B53 16r6325 16r3B54 16r8F89 16r3B55 16r5FBD 16r3B56 16r6062 16r3B57 16r86D4 16r3B58 16r56DE 16r3B59 16r6BC1 16r3B5A 16r6094 16r3B5B 16r6167 16r3B5C 16r5349 16r3B5D 16r60E0 16r3B5E 16r6666 16r3B5F 16r8D3F 16r3B60 16r79FD 16r3B61 16r4F1A 16r3B62 16r70E9 16r3B63 16r6C47 16r3B64 16r8BB3 16r3B65 16r8BF2 16r3B66 16r7ED8 16r3B67 16r8364 16r3B68 16r660F 16r3B69 16r5A5A 16r3B6A 16r9B42 16r3B6B 16r6D51 16r3B6C 16r6DF7 16r3B6D 16r8C41 16r3B6E 16r6D3B 16r3B6F 16r4F19 16r3B70 16r706B 16r3B71 16r83B7 16r3B72 16r6216 16r3B73 16r60D1 16r3B74 16r970D 16r3B75 16r8D27 16r3B76 16r7978 16r3B77 16r51FB 16r3B78 16r573E 16r3B79 16r57FA 16r3B7A 16r673A 16r3B7B 16r7578 16r3B7C 16r7A3D 16r3B7D 16r79EF 16r3B7E 16r7B95 16r3C21 16r808C 16r3C22 16r9965 16r3C23 16r8FF9 16r3C24 16r6FC0 16r3C25 16r8BA5 16r3C26 16r9E21 16r3C27 16r59EC 16r3C28 16r7EE9 16r3C29 16r7F09 16r3C2A 16r5409 16r3C2B 16r6781 16r3C2C 16r68D8 16r3C2D 16r8F91 16r3C2E 16r7C4D 16r3C2F 16r96C6 16r3C30 16r53CA 16r3C31 16r6025 16r3C32 16r75BE 16r3C33 16r6C72 16r3C34 16r5373 16r3C35 16r5AC9 16r3C36 16r7EA7 16r3C37 16r6324 16r3C38 16r51E0 16r3C39 16r810A 16r3C3A 16r5DF1 16r3C3B 16r84DF 16r3C3C 16r6280 16r3C3D 16r5180 16r3C3E 16r5B63 16r3C3F 16r4F0E 16r3C40 16r796D 16r3C41 16r5242 16r3C42 16r60B8 16r3C43 16r6D4E 16r3C44 16r5BC4 16r3C45 16r5BC2 16r3C46 16r8BA1 16r3C47 16r8BB0 16r3C48 16r65E2 16r3C49 16r5FCC 16r3C4A 16r9645 16r3C4B 16r5993 16r3C4C 16r7EE7 16r3C4D 16r7EAA 16r3C4E 16r5609 16r3C4F 16r67B7 16r3C50 16r5939 16r3C51 16r4F73 16r3C52 16r5BB6 16r3C53 16r52A0 16r3C54 16r835A 16r3C55 16r988A 16r3C56 16r8D3E 16r3C57 16r7532 16r3C58 16r94BE 16r3C59 16r5047 16r3C5A 16r7A3C 16r3C5B 16r4EF7 16r3C5C 16r67B6 16r3C5D 16r9A7E 16r3C5E 16r5AC1 16r3C5F 16r6B7C 16r3C60 16r76D1 16r3C61 16r575A 16r3C62 16r5C16 16r3C63 16r7B3A 16r3C64 16r95F4 16r3C65 16r714E 16r3C66 16r517C 16r3C67 16r80A9 16r3C68 16r8270 16r3C69 16r5978 16r3C6A 16r7F04 16r3C6B 16r8327 16r3C6C 16r68C0 16r3C6D 16r67EC 16r3C6E 16r78B1 16r3C6F 16r7877 16r3C70 16r62E3 16r3C71 16r6361 16r3C72 16r7B80 16r3C73 16r4FED 16r3C74 16r526A 16r3C75 16r51CF 16r3C76 16r8350 16r3C77 16r69DB 16r3C78 16r9274 16r3C79 16r8DF5 16r3C7A 16r8D31 16r3C7B 16r89C1 16r3C7C 16r952E 16r3C7D 16r7BAD 16r3C7E 16r4EF6 16r3D21 16r5065 16r3D22 16r8230 16r3D23 16r5251 16r3D24 16r996F 16r3D25 16r6E10 16r3D26 16r6E85 16r3D27 16r6DA7 16r3D28 16r5EFA 16r3D29 16r50F5 16r3D2A 16r59DC 16r3D2B 16r5C06 16r3D2C 16r6D46 16r3D2D 16r6C5F 16r3D2E 16r7586 16r3D2F 16r848B 16r3D30 16r6868 16r3D31 16r5956 16r3D32 16r8BB2 16r3D33 16r5320 16r3D34 16r9171 16r3D35 16r964D 16r3D36 16r8549 16r3D37 16r6912 16r3D38 16r7901 16r3D39 16r7126 16r3D3A 16r80F6 16r3D3B 16r4EA4 16r3D3C 16r90CA 16r3D3D 16r6D47 16r3D3E 16r9A84 16r3D3F 16r5A07 16r3D40 16r56BC 16r3D41 16r6405 16r3D42 16r94F0 16r3D43 16r77EB 16r3D44 16r4FA5 16r3D45 16r811A 16r3D46 16r72E1 16r3D47 16r89D2 16r3D48 16r997A 16r3D49 16r7F34 16r3D4A 16r7EDE 16r3D4B 16r527F 16r3D4C 16r6559 16r3D4D 16r9175 16r3D4E 16r8F7F 16r3D4F 16r8F83 16r3D50 16r53EB 16r3D51 16r7A96 16r3D52 16r63ED 16r3D53 16r63A5 16r3D54 16r7686 16r3D55 16r79F8 16r3D56 16r8857 16r3D57 16r9636 16r3D58 16r622A 16r3D59 16r52AB 16r3D5A 16r8282 16r3D5B 16r6854 16r3D5C 16r6770 16r3D5D 16r6377 16r3D5E 16r776B 16r3D5F 16r7AED 16r3D60 16r6D01 16r3D61 16r7ED3 16r3D62 16r89E3 16r3D63 16r59D0 16r3D64 16r6212 16r3D65 16r85C9 16r3D66 16r82A5 16r3D67 16r754C 16r3D68 16r501F 16r3D69 16r4ECB 16r3D6A 16r75A5 16r3D6B 16r8BEB 16r3D6C 16r5C4A 16r3D6D 16r5DFE 16r3D6E 16r7B4B 16r3D6F 16r65A4 16r3D70 16r91D1 16r3D71 16r4ECA 16r3D72 16r6D25 16r3D73 16r895F 16r3D74 16r7D27 16r3D75 16r9526 16r3D76 16r4EC5 16r3D77 16r8C28 16r3D78 16r8FDB 16r3D79 16r9773 16r3D7A 16r664B 16r3D7B 16r7981 16r3D7C 16r8FD1 16r3D7D 16r70EC 16r3D7E 16r6D78 16r3E21 16r5C3D 16r3E22 16r52B2 16r3E23 16r8346 16r3E24 16r5162 16r3E25 16r830E 16r3E26 16r775B 16r3E27 16r6676 16r3E28 16r9CB8 16r3E29 16r4EAC 16r3E2A 16r60CA 16r3E2B 16r7CBE 16r3E2C 16r7CB3 16r3E2D 16r7ECF 16r3E2E 16r4E95 16r3E2F 16r8B66 16r3E30 16r666F 16r3E31 16r9888 16r3E32 16r9759 16r3E33 16r5883 16r3E34 16r656C 16r3E35 16r955C 16r3E36 16r5F84 16r3E37 16r75C9 16r3E38 16r9756 16r3E39 16r7ADF 16r3E3A 16r7ADE 16r3E3B 16r51C0 16r3E3C 16r70AF 16r3E3D 16r7A98 16r3E3E 16r63EA 16r3E3F 16r7A76 16r3E40 16r7EA0 16r3E41 16r7396 16r3E42 16r97ED 16r3E43 16r4E45 16r3E44 16r7078 16r3E45 16r4E5D 16r3E46 16r9152 16r3E47 16r53A9 16r3E48 16r6551 16r3E49 16r65E7 16r3E4A 16r81FC 16r3E4B 16r8205 16r3E4C 16r548E 16r3E4D 16r5C31 16r3E4E 16r759A 16r3E4F 16r97A0 16r3E50 16r62D8 16r3E51 16r72D9 16r3E52 16r75BD 16r3E53 16r5C45 16r3E54 16r9A79 16r3E55 16r83CA 16r3E56 16r5C40 16r3E57 16r5480 16r3E58 16r77E9 16r3E59 16r4E3E 16r3E5A 16r6CAE 16r3E5B 16r805A 16r3E5C 16r62D2 16r3E5D 16r636E 16r3E5E 16r5DE8 16r3E5F 16r5177 16r3E60 16r8DDD 16r3E61 16r8E1E 16r3E62 16r952F 16r3E63 16r4FF1 16r3E64 16r53E5 16r3E65 16r60E7 16r3E66 16r70AC 16r3E67 16r5267 16r3E68 16r6350 16r3E69 16r9E43 16r3E6A 16r5A1F 16r3E6B 16r5026 16r3E6C 16r7737 16r3E6D 16r5377 16r3E6E 16r7EE2 16r3E6F 16r6485 16r3E70 16r652B 16r3E71 16r6289 16r3E72 16r6398 16r3E73 16r5014 16r3E74 16r7235 16r3E75 16r89C9 16r3E76 16r51B3 16r3E77 16r8BC0 16r3E78 16r7EDD 16r3E79 16r5747 16r3E7A 16r83CC 16r3E7B 16r94A7 16r3E7C 16r519B 16r3E7D 16r541B 16r3E7E 16r5CFB 16r3F21 16r4FCA 16r3F22 16r7AE3 16r3F23 16r6D5A 16r3F24 16r90E1 16r3F25 16r9A8F 16r3F26 16r5580 16r3F27 16r5496 16r3F28 16r5361 16r3F29 16r54AF 16r3F2A 16r5F00 16r3F2B 16r63E9 16r3F2C 16r6977 16r3F2D 16r51EF 16r3F2E 16r6168 16r3F2F 16r520A 16r3F30 16r582A 16r3F31 16r52D8 16r3F32 16r574E 16r3F33 16r780D 16r3F34 16r770B 16r3F35 16r5EB7 16r3F36 16r6177 16r3F37 16r7CE0 16r3F38 16r625B 16r3F39 16r6297 16r3F3A 16r4EA2 16r3F3B 16r7095 16r3F3C 16r8003 16r3F3D 16r62F7 16r3F3E 16r70E4 16r3F3F 16r9760 16r3F40 16r5777 16r3F41 16r82DB 16r3F42 16r67EF 16r3F43 16r68F5 16r3F44 16r78D5 16r3F45 16r9897 16r3F46 16r79D1 16r3F47 16r58F3 16r3F48 16r54B3 16r3F49 16r53EF 16r3F4A 16r6E34 16r3F4B 16r514B 16r3F4C 16r523B 16r3F4D 16r5BA2 16r3F4E 16r8BFE 16r3F4F 16r80AF 16r3F50 16r5543 16r3F51 16r57A6 16r3F52 16r6073 16r3F53 16r5751 16r3F54 16r542D 16r3F55 16r7A7A 16r3F56 16r6050 16r3F57 16r5B54 16r3F58 16r63A7 16r3F59 16r62A0 16r3F5A 16r53E3 16r3F5B 16r6263 16r3F5C 16r5BC7 16r3F5D 16r67AF 16r3F5E 16r54ED 16r3F5F 16r7A9F 16r3F60 16r82E6 16r3F61 16r9177 16r3F62 16r5E93 16r3F63 16r88E4 16r3F64 16r5938 16r3F65 16r57AE 16r3F66 16r630E 16r3F67 16r8DE8 16r3F68 16r80EF 16r3F69 16r5757 16r3F6A 16r7B77 16r3F6B 16r4FA9 16r3F6C 16r5FEB 16r3F6D 16r5BBD 16r3F6E 16r6B3E 16r3F6F 16r5321 16r3F70 16r7B50 16r3F71 16r72C2 16r3F72 16r6846 16r3F73 16r77FF 16r3F74 16r7736 16r3F75 16r65F7 16r3F76 16r51B5 16r3F77 16r4E8F 16r3F78 16r76D4 16r3F79 16r5CBF 16r3F7A 16r7AA5 16r3F7B 16r8475 16r3F7C 16r594E 16r3F7D 16r9B41 16r3F7E 16r5080 16r4021 16r9988 16r4022 16r6127 16r4023 16r6E83 16r4024 16r5764 16r4025 16r6606 16r4026 16r6346 16r4027 16r56F0 16r4028 16r62EC 16r4029 16r6269 16r402A 16r5ED3 16r402B 16r9614 16r402C 16r5783 16r402D 16r62C9 16r402E 16r5587 16r402F 16r8721 16r4030 16r814A 16r4031 16r8FA3 16r4032 16r5566 16r4033 16r83B1 16r4034 16r6765 16r4035 16r8D56 16r4036 16r84DD 16r4037 16r5A6A 16r4038 16r680F 16r4039 16r62E6 16r403A 16r7BEE 16r403B 16r9611 16r403C 16r5170 16r403D 16r6F9C 16r403E 16r8C30 16r403F 16r63FD 16r4040 16r89C8 16r4041 16r61D2 16r4042 16r7F06 16r4043 16r70C2 16r4044 16r6EE5 16r4045 16r7405 16r4046 16r6994 16r4047 16r72FC 16r4048 16r5ECA 16r4049 16r90CE 16r404A 16r6717 16r404B 16r6D6A 16r404C 16r635E 16r404D 16r52B3 16r404E 16r7262 16r404F 16r8001 16r4050 16r4F6C 16r4051 16r59E5 16r4052 16r916A 16r4053 16r70D9 16r4054 16r6D9D 16r4055 16r52D2 16r4056 16r4E50 16r4057 16r96F7 16r4058 16r956D 16r4059 16r857E 16r405A 16r78CA 16r405B 16r7D2F 16r405C 16r5121 16r405D 16r5792 16r405E 16r64C2 16r405F 16r808B 16r4060 16r7C7B 16r4061 16r6CEA 16r4062 16r68F1 16r4063 16r695E 16r4064 16r51B7 16r4065 16r5398 16r4066 16r68A8 16r4067 16r7281 16r4068 16r9ECE 16r4069 16r7BF1 16r406A 16r72F8 16r406B 16r79BB 16r406C 16r6F13 16r406D 16r7406 16r406E 16r674E 16r406F 16r91CC 16r4070 16r9CA4 16r4071 16r793C 16r4072 16r8389 16r4073 16r8354 16r4074 16r540F 16r4075 16r6817 16r4076 16r4E3D 16r4077 16r5389 16r4078 16r52B1 16r4079 16r783E 16r407A 16r5386 16r407B 16r5229 16r407C 16r5088 16r407D 16r4F8B 16r407E 16r4FD0 16r4121 16r75E2 16r4122 16r7ACB 16r4123 16r7C92 16r4124 16r6CA5 16r4125 16r96B6 16r4126 16r529B 16r4127 16r7483 16r4128 16r54E9 16r4129 16r4FE9 16r412A 16r8054 16r412B 16r83B2 16r412C 16r8FDE 16r412D 16r9570 16r412E 16r5EC9 16r412F 16r601C 16r4130 16r6D9F 16r4131 16r5E18 16r4132 16r655B 16r4133 16r8138 16r4134 16r94FE 16r4135 16r604B 16r4136 16r70BC 16r4137 16r7EC3 16r4138 16r7CAE 16r4139 16r51C9 16r413A 16r6881 16r413B 16r7CB1 16r413C 16r826F 16r413D 16r4E24 16r413E 16r8F86 16r413F 16r91CF 16r4140 16r667E 16r4141 16r4EAE 16r4142 16r8C05 16r4143 16r64A9 16r4144 16r804A 16r4145 16r50DA 16r4146 16r7597 16r4147 16r71CE 16r4148 16r5BE5 16r4149 16r8FBD 16r414A 16r6F66 16r414B 16r4E86 16r414C 16r6482 16r414D 16r9563 16r414E 16r5ED6 16r414F 16r6599 16r4150 16r5217 16r4151 16r88C2 16r4152 16r70C8 16r4153 16r52A3 16r4154 16r730E 16r4155 16r7433 16r4156 16r6797 16r4157 16r78F7 16r4158 16r9716 16r4159 16r4E34 16r415A 16r90BB 16r415B 16r9CDE 16r415C 16r6DCB 16r415D 16r51DB 16r415E 16r8D41 16r415F 16r541D 16r4160 16r62CE 16r4161 16r73B2 16r4162 16r83F1 16r4163 16r96F6 16r4164 16r9F84 16r4165 16r94C3 16r4166 16r4F36 16r4167 16r7F9A 16r4168 16r51CC 16r4169 16r7075 16r416A 16r9675 16r416B 16r5CAD 16r416C 16r9886 16r416D 16r53E6 16r416E 16r4EE4 16r416F 16r6E9C 16r4170 16r7409 16r4171 16r69B4 16r4172 16r786B 16r4173 16r998F 16r4174 16r7559 16r4175 16r5218 16r4176 16r7624 16r4177 16r6D41 16r4178 16r67F3 16r4179 16r516D 16r417A 16r9F99 16r417B 16r804B 16r417C 16r5499 16r417D 16r7B3C 16r417E 16r7ABF 16r4221 16r9686 16r4222 16r5784 16r4223 16r62E2 16r4224 16r9647 16r4225 16r697C 16r4226 16r5A04 16r4227 16r6402 16r4228 16r7BD3 16r4229 16r6F0F 16r422A 16r964B 16r422B 16r82A6 16r422C 16r5362 16r422D 16r9885 16r422E 16r5E90 16r422F 16r7089 16r4230 16r63B3 16r4231 16r5364 16r4232 16r864F 16r4233 16r9C81 16r4234 16r9E93 16r4235 16r788C 16r4236 16r9732 16r4237 16r8DEF 16r4238 16r8D42 16r4239 16r9E7F 16r423A 16r6F5E 16r423B 16r7984 16r423C 16r5F55 16r423D 16r9646 16r423E 16r622E 16r423F 16r9A74 16r4240 16r5415 16r4241 16r94DD 16r4242 16r4FA3 16r4243 16r65C5 16r4244 16r5C65 16r4245 16r5C61 16r4246 16r7F15 16r4247 16r8651 16r4248 16r6C2F 16r4249 16r5F8B 16r424A 16r7387 16r424B 16r6EE4 16r424C 16r7EFF 16r424D 16r5CE6 16r424E 16r631B 16r424F 16r5B6A 16r4250 16r6EE6 16r4251 16r5375 16r4252 16r4E71 16r4253 16r63A0 16r4254 16r7565 16r4255 16r62A1 16r4256 16r8F6E 16r4257 16r4F26 16r4258 16r4ED1 16r4259 16r6CA6 16r425A 16r7EB6 16r425B 16r8BBA 16r425C 16r841D 16r425D 16r87BA 16r425E 16r7F57 16r425F 16r903B 16r4260 16r9523 16r4261 16r7BA9 16r4262 16r9AA1 16r4263 16r88F8 16r4264 16r843D 16r4265 16r6D1B 16r4266 16r9A86 16r4267 16r7EDC 16r4268 16r5988 16r4269 16r9EBB 16r426A 16r739B 16r426B 16r7801 16r426C 16r8682 16r426D 16r9A6C 16r426E 16r9A82 16r426F 16r561B 16r4270 16r5417 16r4271 16r57CB 16r4272 16r4E70 16r4273 16r9EA6 16r4274 16r5356 16r4275 16r8FC8 16r4276 16r8109 16r4277 16r7792 16r4278 16r9992 16r4279 16r86EE 16r427A 16r6EE1 16r427B 16r8513 16r427C 16r66FC 16r427D 16r6162 16r427E 16r6F2B 16r4321 16r8C29 16r4322 16r8292 16r4323 16r832B 16r4324 16r76F2 16r4325 16r6C13 16r4326 16r5FD9 16r4327 16r83BD 16r4328 16r732B 16r4329 16r8305 16r432A 16r951A 16r432B 16r6BDB 16r432C 16r77DB 16r432D 16r94C6 16r432E 16r536F 16r432F 16r8302 16r4330 16r5192 16r4331 16r5E3D 16r4332 16r8C8C 16r4333 16r8D38 16r4334 16r4E48 16r4335 16r73AB 16r4336 16r679A 16r4337 16r6885 16r4338 16r9176 16r4339 16r9709 16r433A 16r7164 16r433B 16r6CA1 16r433C 16r7709 16r433D 16r5A92 16r433E 16r9541 16r433F 16r6BCF 16r4340 16r7F8E 16r4341 16r6627 16r4342 16r5BD0 16r4343 16r59B9 16r4344 16r5A9A 16r4345 16r95E8 16r4346 16r95F7 16r4347 16r4EEC 16r4348 16r840C 16r4349 16r8499 16r434A 16r6AAC 16r434B 16r76DF 16r434C 16r9530 16r434D 16r731B 16r434E 16r68A6 16r434F 16r5B5F 16r4350 16r772F 16r4351 16r919A 16r4352 16r9761 16r4353 16r7CDC 16r4354 16r8FF7 16r4355 16r8C1C 16r4356 16r5F25 16r4357 16r7C73 16r4358 16r79D8 16r4359 16r89C5 16r435A 16r6CCC 16r435B 16r871C 16r435C 16r5BC6 16r435D 16r5E42 16r435E 16r68C9 16r435F 16r7720 16r4360 16r7EF5 16r4361 16r5195 16r4362 16r514D 16r4363 16r52C9 16r4364 16r5A29 16r4365 16r7F05 16r4366 16r9762 16r4367 16r82D7 16r4368 16r63CF 16r4369 16r7784 16r436A 16r85D0 16r436B 16r79D2 16r436C 16r6E3A 16r436D 16r5E99 16r436E 16r5999 16r436F 16r8511 16r4370 16r706D 16r4371 16r6C11 16r4372 16r62BF 16r4373 16r76BF 16r4374 16r654F 16r4375 16r60AF 16r4376 16r95FD 16r4377 16r660E 16r4378 16r879F 16r4379 16r9E23 16r437A 16r94ED 16r437B 16r540D 16r437C 16r547D 16r437D 16r8C2C 16r437E 16r6478 16r4421 16r6479 16r4422 16r8611 16r4423 16r6A21 16r4424 16r819C 16r4425 16r78E8 16r4426 16r6469 16r4427 16r9B54 16r4428 16r62B9 16r4429 16r672B 16r442A 16r83AB 16r442B 16r58A8 16r442C 16r9ED8 16r442D 16r6CAB 16r442E 16r6F20 16r442F 16r5BDE 16r4430 16r964C 16r4431 16r8C0B 16r4432 16r725F 16r4433 16r67D0 16r4434 16r62C7 16r4435 16r7261 16r4436 16r4EA9 16r4437 16r59C6 16r4438 16r6BCD 16r4439 16r5893 16r443A 16r66AE 16r443B 16r5E55 16r443C 16r52DF 16r443D 16r6155 16r443E 16r6728 16r443F 16r76EE 16r4440 16r7766 16r4441 16r7267 16r4442 16r7A46 16r4443 16r62FF 16r4444 16r54EA 16r4445 16r5450 16r4446 16r94A0 16r4447 16r90A3 16r4448 16r5A1C 16r4449 16r7EB3 16r444A 16r6C16 16r444B 16r4E43 16r444C 16r5976 16r444D 16r8010 16r444E 16r5948 16r444F 16r5357 16r4450 16r7537 16r4451 16r96BE 16r4452 16r56CA 16r4453 16r6320 16r4454 16r8111 16r4455 16r607C 16r4456 16r95F9 16r4457 16r6DD6 16r4458 16r5462 16r4459 16r9981 16r445A 16r5185 16r445B 16r5AE9 16r445C 16r80FD 16r445D 16r59AE 16r445E 16r9713 16r445F 16r502A 16r4460 16r6CE5 16r4461 16r5C3C 16r4462 16r62DF 16r4463 16r4F60 16r4464 16r533F 16r4465 16r817B 16r4466 16r9006 16r4467 16r6EBA 16r4468 16r852B 16r4469 16r62C8 16r446A 16r5E74 16r446B 16r78BE 16r446C 16r64B5 16r446D 16r637B 16r446E 16r5FF5 16r446F 16r5A18 16r4470 16r917F 16r4471 16r9E1F 16r4472 16r5C3F 16r4473 16r634F 16r4474 16r8042 16r4475 16r5B7D 16r4476 16r556E 16r4477 16r954A 16r4478 16r954D 16r4479 16r6D85 16r447A 16r60A8 16r447B 16r67E0 16r447C 16r72DE 16r447D 16r51DD 16r447E 16r5B81 16r4521 16r62E7 16r4522 16r6CDE 16r4523 16r725B 16r4524 16r626D 16r4525 16r94AE 16r4526 16r7EBD 16r4527 16r8113 16r4528 16r6D53 16r4529 16r519C 16r452A 16r5F04 16r452B 16r5974 16r452C 16r52AA 16r452D 16r6012 16r452E 16r5973 16r452F 16r6696 16r4530 16r8650 16r4531 16r759F 16r4532 16r632A 16r4533 16r61E6 16r4534 16r7CEF 16r4535 16r8BFA 16r4536 16r54E6 16r4537 16r6B27 16r4538 16r9E25 16r4539 16r6BB4 16r453A 16r85D5 16r453B 16r5455 16r453C 16r5076 16r453D 16r6CA4 16r453E 16r556A 16r453F 16r8DB4 16r4540 16r722C 16r4541 16r5E15 16r4542 16r6015 16r4543 16r7436 16r4544 16r62CD 16r4545 16r6392 16r4546 16r724C 16r4547 16r5F98 16r4548 16r6E43 16r4549 16r6D3E 16r454A 16r6500 16r454B 16r6F58 16r454C 16r76D8 16r454D 16r78D0 16r454E 16r76FC 16r454F 16r7554 16r4550 16r5224 16r4551 16r53DB 16r4552 16r4E53 16r4553 16r5E9E 16r4554 16r65C1 16r4555 16r802A 16r4556 16r80D6 16r4557 16r629B 16r4558 16r5486 16r4559 16r5228 16r455A 16r70AE 16r455B 16r888D 16r455C 16r8DD1 16r455D 16r6CE1 16r455E 16r5478 16r455F 16r80DA 16r4560 16r57F9 16r4561 16r88F4 16r4562 16r8D54 16r4563 16r966A 16r4564 16r914D 16r4565 16r4F69 16r4566 16r6C9B 16r4567 16r55B7 16r4568 16r76C6 16r4569 16r7830 16r456A 16r62A8 16r456B 16r70F9 16r456C 16r6F8E 16r456D 16r5F6D 16r456E 16r84EC 16r456F 16r68DA 16r4570 16r787C 16r4571 16r7BF7 16r4572 16r81A8 16r4573 16r670B 16r4574 16r9E4F 16r4575 16r6367 16r4576 16r78B0 16r4577 16r576F 16r4578 16r7812 16r4579 16r9739 16r457A 16r6279 16r457B 16r62AB 16r457C 16r5288 16r457D 16r7435 16r457E 16r6BD7 16r4621 16r5564 16r4622 16r813E 16r4623 16r75B2 16r4624 16r76AE 16r4625 16r5339 16r4626 16r75DE 16r4627 16r50FB 16r4628 16r5C41 16r4629 16r8B6C 16r462A 16r7BC7 16r462B 16r504F 16r462C 16r7247 16r462D 16r9A97 16r462E 16r98D8 16r462F 16r6F02 16r4630 16r74E2 16r4631 16r7968 16r4632 16r6487 16r4633 16r77A5 16r4634 16r62FC 16r4635 16r9891 16r4636 16r8D2B 16r4637 16r54C1 16r4638 16r8058 16r4639 16r4E52 16r463A 16r576A 16r463B 16r82F9 16r463C 16r840D 16r463D 16r5E73 16r463E 16r51ED 16r463F 16r74F6 16r4640 16r8BC4 16r4641 16r5C4F 16r4642 16r5761 16r4643 16r6CFC 16r4644 16r9887 16r4645 16r5A46 16r4646 16r7834 16r4647 16r9B44 16r4648 16r8FEB 16r4649 16r7C95 16r464A 16r5256 16r464B 16r6251 16r464C 16r94FA 16r464D 16r4EC6 16r464E 16r8386 16r464F 16r8461 16r4650 16r83E9 16r4651 16r84B2 16r4652 16r57D4 16r4653 16r6734 16r4654 16r5703 16r4655 16r666E 16r4656 16r6D66 16r4657 16r8C31 16r4658 16r66DD 16r4659 16r7011 16r465A 16r671F 16r465B 16r6B3A 16r465C 16r6816 16r465D 16r621A 16r465E 16r59BB 16r465F 16r4E03 16r4660 16r51C4 16r4661 16r6F06 16r4662 16r67D2 16r4663 16r6C8F 16r4664 16r5176 16r4665 16r68CB 16r4666 16r5947 16r4667 16r6B67 16r4668 16r7566 16r4669 16r5D0E 16r466A 16r8110 16r466B 16r9F50 16r466C 16r65D7 16r466D 16r7948 16r466E 16r7941 16r466F 16r9A91 16r4670 16r8D77 16r4671 16r5C82 16r4672 16r4E5E 16r4673 16r4F01 16r4674 16r542F 16r4675 16r5951 16r4676 16r780C 16r4677 16r5668 16r4678 16r6C14 16r4679 16r8FC4 16r467A 16r5F03 16r467B 16r6C7D 16r467C 16r6CE3 16r467D 16r8BAB 16r467E 16r6390 16r4721 16r6070 16r4722 16r6D3D 16r4723 16r7275 16r4724 16r6266 16r4725 16r948E 16r4726 16r94C5 16r4727 16r5343 16r4728 16r8FC1 16r4729 16r7B7E 16r472A 16r4EDF 16r472B 16r8C26 16r472C 16r4E7E 16r472D 16r9ED4 16r472E 16r94B1 16r472F 16r94B3 16r4730 16r524D 16r4731 16r6F5C 16r4732 16r9063 16r4733 16r6D45 16r4734 16r8C34 16r4735 16r5811 16r4736 16r5D4C 16r4737 16r6B20 16r4738 16r6B49 16r4739 16r67AA 16r473A 16r545B 16r473B 16r8154 16r473C 16r7F8C 16r473D 16r5899 16r473E 16r8537 16r473F 16r5F3A 16r4740 16r62A2 16r4741 16r6A47 16r4742 16r9539 16r4743 16r6572 16r4744 16r6084 16r4745 16r6865 16r4746 16r77A7 16r4747 16r4E54 16r4748 16r4FA8 16r4749 16r5DE7 16r474A 16r9798 16r474B 16r64AC 16r474C 16r7FD8 16r474D 16r5CED 16r474E 16r4FCF 16r474F 16r7A8D 16r4750 16r5207 16r4751 16r8304 16r4752 16r4E14 16r4753 16r602F 16r4754 16r7A83 16r4755 16r94A6 16r4756 16r4FB5 16r4757 16r4EB2 16r4758 16r79E6 16r4759 16r7434 16r475A 16r52E4 16r475B 16r82B9 16r475C 16r64D2 16r475D 16r79BD 16r475E 16r5BDD 16r475F 16r6C81 16r4760 16r9752 16r4761 16r8F7B 16r4762 16r6C22 16r4763 16r503E 16r4764 16r537F 16r4765 16r6E05 16r4766 16r64CE 16r4767 16r6674 16r4768 16r6C30 16r4769 16r60C5 16r476A 16r9877 16r476B 16r8BF7 16r476C 16r5E86 16r476D 16r743C 16r476E 16r7A77 16r476F 16r79CB 16r4770 16r4E18 16r4771 16r90B1 16r4772 16r7403 16r4773 16r6C42 16r4774 16r56DA 16r4775 16r914B 16r4776 16r6CC5 16r4777 16r8D8B 16r4778 16r533A 16r4779 16r86C6 16r477A 16r66F2 16r477B 16r8EAF 16r477C 16r5C48 16r477D 16r9A71 16r477E 16r6E20 16r4821 16r53D6 16r4822 16r5A36 16r4823 16r9F8B 16r4824 16r8DA3 16r4825 16r53BB 16r4826 16r5708 16r4827 16r98A7 16r4828 16r6743 16r4829 16r919B 16r482A 16r6CC9 16r482B 16r5168 16r482C 16r75CA 16r482D 16r62F3 16r482E 16r72AC 16r482F 16r5238 16r4830 16r529D 16r4831 16r7F3A 16r4832 16r7094 16r4833 16r7638 16r4834 16r5374 16r4835 16r9E4A 16r4836 16r69B7 16r4837 16r786E 16r4838 16r96C0 16r4839 16r88D9 16r483A 16r7FA4 16r483B 16r7136 16r483C 16r71C3 16r483D 16r5189 16r483E 16r67D3 16r483F 16r74E4 16r4840 16r58E4 16r4841 16r6518 16r4842 16r56B7 16r4843 16r8BA9 16r4844 16r9976 16r4845 16r6270 16r4846 16r7ED5 16r4847 16r60F9 16r4848 16r70ED 16r4849 16r58EC 16r484A 16r4EC1 16r484B 16r4EBA 16r484C 16r5FCD 16r484D 16r97E7 16r484E 16r4EFB 16r484F 16r8BA4 16r4850 16r5203 16r4851 16r598A 16r4852 16r7EAB 16r4853 16r6254 16r4854 16r4ECD 16r4855 16r65E5 16r4856 16r620E 16r4857 16r8338 16r4858 16r84C9 16r4859 16r8363 16r485A 16r878D 16r485B 16r7194 16r485C 16r6EB6 16r485D 16r5BB9 16r485E 16r7ED2 16r485F 16r5197 16r4860 16r63C9 16r4861 16r67D4 16r4862 16r8089 16r4863 16r8339 16r4864 16r8815 16r4865 16r5112 16r4866 16r5B7A 16r4867 16r5982 16r4868 16r8FB1 16r4869 16r4E73 16r486A 16r6C5D 16r486B 16r5165 16r486C 16r8925 16r486D 16r8F6F 16r486E 16r962E 16r486F 16r854A 16r4870 16r745E 16r4871 16r9510 16r4872 16r95F0 16r4873 16r6DA6 16r4874 16r82E5 16r4875 16r5F31 16r4876 16r6492 16r4877 16r6D12 16r4878 16r8428 16r4879 16r816E 16r487A 16r9CC3 16r487B 16r585E 16r487C 16r8D5B 16r487D 16r4E09 16r487E 16r53C1 16r4921 16r4F1E 16r4922 16r6563 16r4923 16r6851 16r4924 16r55D3 16r4925 16r4E27 16r4926 16r6414 16r4927 16r9A9A 16r4928 16r626B 16r4929 16r5AC2 16r492A 16r745F 16r492B 16r8272 16r492C 16r6DA9 16r492D 16r68EE 16r492E 16r50E7 16r492F 16r838E 16r4930 16r7802 16r4931 16r6740 16r4932 16r5239 16r4933 16r6C99 16r4934 16r7EB1 16r4935 16r50BB 16r4936 16r5565 16r4937 16r715E 16r4938 16r7B5B 16r4939 16r6652 16r493A 16r73CA 16r493B 16r82EB 16r493C 16r6749 16r493D 16r5C71 16r493E 16r5220 16r493F 16r717D 16r4940 16r886B 16r4941 16r95EA 16r4942 16r9655 16r4943 16r64C5 16r4944 16r8D61 16r4945 16r81B3 16r4946 16r5584 16r4947 16r6C55 16r4948 16r6247 16r4949 16r7F2E 16r494A 16r5892 16r494B 16r4F24 16r494C 16r5546 16r494D 16r8D4F 16r494E 16r664C 16r494F 16r4E0A 16r4950 16r5C1A 16r4951 16r88F3 16r4952 16r68A2 16r4953 16r634E 16r4954 16r7A0D 16r4955 16r70E7 16r4956 16r828D 16r4957 16r52FA 16r4958 16r97F6 16r4959 16r5C11 16r495A 16r54E8 16r495B 16r90B5 16r495C 16r7ECD 16r495D 16r5962 16r495E 16r8D4A 16r495F 16r86C7 16r4960 16r820C 16r4961 16r820D 16r4962 16r8D66 16r4963 16r6444 16r4964 16r5C04 16r4965 16r6151 16r4966 16r6D89 16r4967 16r793E 16r4968 16r8BBE 16r4969 16r7837 16r496A 16r7533 16r496B 16r547B 16r496C 16r4F38 16r496D 16r8EAB 16r496E 16r6DF1 16r496F 16r5A20 16r4970 16r7EC5 16r4971 16r795E 16r4972 16r6C88 16r4973 16r5BA1 16r4974 16r5A76 16r4975 16r751A 16r4976 16r80BE 16r4977 16r614E 16r4978 16r6E17 16r4979 16r58F0 16r497A 16r751F 16r497B 16r7525 16r497C 16r7272 16r497D 16r5347 16r497E 16r7EF3 16r4A21 16r7701 16r4A22 16r76DB 16r4A23 16r5269 16r4A24 16r80DC 16r4A25 16r5723 16r4A26 16r5E08 16r4A27 16r5931 16r4A28 16r72EE 16r4A29 16r65BD 16r4A2A 16r6E7F 16r4A2B 16r8BD7 16r4A2C 16r5C38 16r4A2D 16r8671 16r4A2E 16r5341 16r4A2F 16r77F3 16r4A30 16r62FE 16r4A31 16r65F6 16r4A32 16r4EC0 16r4A33 16r98DF 16r4A34 16r8680 16r4A35 16r5B9E 16r4A36 16r8BC6 16r4A37 16r53F2 16r4A38 16r77E2 16r4A39 16r4F7F 16r4A3A 16r5C4E 16r4A3B 16r9A76 16r4A3C 16r59CB 16r4A3D 16r5F0F 16r4A3E 16r793A 16r4A3F 16r58EB 16r4A40 16r4E16 16r4A41 16r67FF 16r4A42 16r4E8B 16r4A43 16r62ED 16r4A44 16r8A93 16r4A45 16r901D 16r4A46 16r52BF 16r4A47 16r662F 16r4A48 16r55DC 16r4A49 16r566C 16r4A4A 16r9002 16r4A4B 16r4ED5 16r4A4C 16r4F8D 16r4A4D 16r91CA 16r4A4E 16r9970 16r4A4F 16r6C0F 16r4A50 16r5E02 16r4A51 16r6043 16r4A52 16r5BA4 16r4A53 16r89C6 16r4A54 16r8BD5 16r4A55 16r6536 16r4A56 16r624B 16r4A57 16r9996 16r4A58 16r5B88 16r4A59 16r5BFF 16r4A5A 16r6388 16r4A5B 16r552E 16r4A5C 16r53D7 16r4A5D 16r7626 16r4A5E 16r517D 16r4A5F 16r852C 16r4A60 16r67A2 16r4A61 16r68B3 16r4A62 16r6B8A 16r4A63 16r6292 16r4A64 16r8F93 16r4A65 16r53D4 16r4A66 16r8212 16r4A67 16r6DD1 16r4A68 16r758F 16r4A69 16r4E66 16r4A6A 16r8D4E 16r4A6B 16r5B70 16r4A6C 16r719F 16r4A6D 16r85AF 16r4A6E 16r6691 16r4A6F 16r66D9 16r4A70 16r7F72 16r4A71 16r8700 16r4A72 16r9ECD 16r4A73 16r9F20 16r4A74 16r5C5E 16r4A75 16r672F 16r4A76 16r8FF0 16r4A77 16r6811 16r4A78 16r675F 16r4A79 16r620D 16r4A7A 16r7AD6 16r4A7B 16r5885 16r4A7C 16r5EB6 16r4A7D 16r6570 16r4A7E 16r6F31 16r4B21 16r6055 16r4B22 16r5237 16r4B23 16r800D 16r4B24 16r6454 16r4B25 16r8870 16r4B26 16r7529 16r4B27 16r5E05 16r4B28 16r6813 16r4B29 16r62F4 16r4B2A 16r971C 16r4B2B 16r53CC 16r4B2C 16r723D 16r4B2D 16r8C01 16r4B2E 16r6C34 16r4B2F 16r7761 16r4B30 16r7A0E 16r4B31 16r542E 16r4B32 16r77AC 16r4B33 16r987A 16r4B34 16r821C 16r4B35 16r8BF4 16r4B36 16r7855 16r4B37 16r6714 16r4B38 16r70C1 16r4B39 16r65AF 16r4B3A 16r6495 16r4B3B 16r5636 16r4B3C 16r601D 16r4B3D 16r79C1 16r4B3E 16r53F8 16r4B3F 16r4E1D 16r4B40 16r6B7B 16r4B41 16r8086 16r4B42 16r5BFA 16r4B43 16r55E3 16r4B44 16r56DB 16r4B45 16r4F3A 16r4B46 16r4F3C 16r4B47 16r9972 16r4B48 16r5DF3 16r4B49 16r677E 16r4B4A 16r8038 16r4B4B 16r6002 16r4B4C 16r9882 16r4B4D 16r9001 16r4B4E 16r5B8B 16r4B4F 16r8BBC 16r4B50 16r8BF5 16r4B51 16r641C 16r4B52 16r8258 16r4B53 16r64DE 16r4B54 16r55FD 16r4B55 16r82CF 16r4B56 16r9165 16r4B57 16r4FD7 16r4B58 16r7D20 16r4B59 16r901F 16r4B5A 16r7C9F 16r4B5B 16r50F3 16r4B5C 16r5851 16r4B5D 16r6EAF 16r4B5E 16r5BBF 16r4B5F 16r8BC9 16r4B60 16r8083 16r4B61 16r9178 16r4B62 16r849C 16r4B63 16r7B97 16r4B64 16r867D 16r4B65 16r968B 16r4B66 16r968F 16r4B67 16r7EE5 16r4B68 16r9AD3 16r4B69 16r788E 16r4B6A 16r5C81 16r4B6B 16r7A57 16r4B6C 16r9042 16r4B6D 16r96A7 16r4B6E 16r795F 16r4B6F 16r5B59 16r4B70 16r635F 16r4B71 16r7B0B 16r4B72 16r84D1 16r4B73 16r68AD 16r4B74 16r5506 16r4B75 16r7F29 16r4B76 16r7410 16r4B77 16r7D22 16r4B78 16r9501 16r4B79 16r6240 16r4B7A 16r584C 16r4B7B 16r4ED6 16r4B7C 16r5B83 16r4B7D 16r5979 16r4B7E 16r5854 16r4C21 16r736D 16r4C22 16r631E 16r4C23 16r8E4B 16r4C24 16r8E0F 16r4C25 16r80CE 16r4C26 16r82D4 16r4C27 16r62AC 16r4C28 16r53F0 16r4C29 16r6CF0 16r4C2A 16r915E 16r4C2B 16r592A 16r4C2C 16r6001 16r4C2D 16r6C70 16r4C2E 16r574D 16r4C2F 16r644A 16r4C30 16r8D2A 16r4C31 16r762B 16r4C32 16r6EE9 16r4C33 16r575B 16r4C34 16r6A80 16r4C35 16r75F0 16r4C36 16r6F6D 16r4C37 16r8C2D 16r4C38 16r8C08 16r4C39 16r5766 16r4C3A 16r6BEF 16r4C3B 16r8892 16r4C3C 16r78B3 16r4C3D 16r63A2 16r4C3E 16r53F9 16r4C3F 16r70AD 16r4C40 16r6C64 16r4C41 16r5858 16r4C42 16r642A 16r4C43 16r5802 16r4C44 16r68E0 16r4C45 16r819B 16r4C46 16r5510 16r4C47 16r7CD6 16r4C48 16r5018 16r4C49 16r8EBA 16r4C4A 16r6DCC 16r4C4B 16r8D9F 16r4C4C 16r70EB 16r4C4D 16r638F 16r4C4E 16r6D9B 16r4C4F 16r6ED4 16r4C50 16r7EE6 16r4C51 16r8404 16r4C52 16r6843 16r4C53 16r9003 16r4C54 16r6DD8 16r4C55 16r9676 16r4C56 16r8BA8 16r4C57 16r5957 16r4C58 16r7279 16r4C59 16r85E4 16r4C5A 16r817E 16r4C5B 16r75BC 16r4C5C 16r8A8A 16r4C5D 16r68AF 16r4C5E 16r5254 16r4C5F 16r8E22 16r4C60 16r9511 16r4C61 16r63D0 16r4C62 16r9898 16r4C63 16r8E44 16r4C64 16r557C 16r4C65 16r4F53 16r4C66 16r66FF 16r4C67 16r568F 16r4C68 16r60D5 16r4C69 16r6D95 16r4C6A 16r5243 16r4C6B 16r5C49 16r4C6C 16r5929 16r4C6D 16r6DFB 16r4C6E 16r586B 16r4C6F 16r7530 16r4C70 16r751C 16r4C71 16r606C 16r4C72 16r8214 16r4C73 16r8146 16r4C74 16r6311 16r4C75 16r6761 16r4C76 16r8FE2 16r4C77 16r773A 16r4C78 16r8DF3 16r4C79 16r8D34 16r4C7A 16r94C1 16r4C7B 16r5E16 16r4C7C 16r5385 16r4C7D 16r542C 16r4C7E 16r70C3 16r4D21 16r6C40 16r4D22 16r5EF7 16r4D23 16r505C 16r4D24 16r4EAD 16r4D25 16r5EAD 16r4D26 16r633A 16r4D27 16r8247 16r4D28 16r901A 16r4D29 16r6850 16r4D2A 16r916E 16r4D2B 16r77B3 16r4D2C 16r540C 16r4D2D 16r94DC 16r4D2E 16r5F64 16r4D2F 16r7AE5 16r4D30 16r6876 16r4D31 16r6345 16r4D32 16r7B52 16r4D33 16r7EDF 16r4D34 16r75DB 16r4D35 16r5077 16r4D36 16r6295 16r4D37 16r5934 16r4D38 16r900F 16r4D39 16r51F8 16r4D3A 16r79C3 16r4D3B 16r7A81 16r4D3C 16r56FE 16r4D3D 16r5F92 16r4D3E 16r9014 16r4D3F 16r6D82 16r4D40 16r5C60 16r4D41 16r571F 16r4D42 16r5410 16r4D43 16r5154 16r4D44 16r6E4D 16r4D45 16r56E2 16r4D46 16r63A8 16r4D47 16r9893 16r4D48 16r817F 16r4D49 16r8715 16r4D4A 16r892A 16r4D4B 16r9000 16r4D4C 16r541E 16r4D4D 16r5C6F 16r4D4E 16r81C0 16r4D4F 16r62D6 16r4D50 16r6258 16r4D51 16r8131 16r4D52 16r9E35 16r4D53 16r9640 16r4D54 16r9A6E 16r4D55 16r9A7C 16r4D56 16r692D 16r4D57 16r59A5 16r4D58 16r62D3 16r4D59 16r553E 16r4D5A 16r6316 16r4D5B 16r54C7 16r4D5C 16r86D9 16r4D5D 16r6D3C 16r4D5E 16r5A03 16r4D5F 16r74E6 16r4D60 16r889C 16r4D61 16r6B6A 16r4D62 16r5916 16r4D63 16r8C4C 16r4D64 16r5F2F 16r4D65 16r6E7E 16r4D66 16r73A9 16r4D67 16r987D 16r4D68 16r4E38 16r4D69 16r70F7 16r4D6A 16r5B8C 16r4D6B 16r7897 16r4D6C 16r633D 16r4D6D 16r665A 16r4D6E 16r7696 16r4D6F 16r60CB 16r4D70 16r5B9B 16r4D71 16r5A49 16r4D72 16r4E07 16r4D73 16r8155 16r4D74 16r6C6A 16r4D75 16r738B 16r4D76 16r4EA1 16r4D77 16r6789 16r4D78 16r7F51 16r4D79 16r5F80 16r4D7A 16r65FA 16r4D7B 16r671B 16r4D7C 16r5FD8 16r4D7D 16r5984 16r4D7E 16r5A01 16r4E21 16r5DCD 16r4E22 16r5FAE 16r4E23 16r5371 16r4E24 16r97E6 16r4E25 16r8FDD 16r4E26 16r6845 16r4E27 16r56F4 16r4E28 16r552F 16r4E29 16r60DF 16r4E2A 16r4E3A 16r4E2B 16r6F4D 16r4E2C 16r7EF4 16r4E2D 16r82C7 16r4E2E 16r840E 16r4E2F 16r59D4 16r4E30 16r4F1F 16r4E31 16r4F2A 16r4E32 16r5C3E 16r4E33 16r7EAC 16r4E34 16r672A 16r4E35 16r851A 16r4E36 16r5473 16r4E37 16r754F 16r4E38 16r80C3 16r4E39 16r5582 16r4E3A 16r9B4F 16r4E3B 16r4F4D 16r4E3C 16r6E2D 16r4E3D 16r8C13 16r4E3E 16r5C09 16r4E3F 16r6170 16r4E40 16r536B 16r4E41 16r761F 16r4E42 16r6E29 16r4E43 16r868A 16r4E44 16r6587 16r4E45 16r95FB 16r4E46 16r7EB9 16r4E47 16r543B 16r4E48 16r7A33 16r4E49 16r7D0A 16r4E4A 16r95EE 16r4E4B 16r55E1 16r4E4C 16r7FC1 16r4E4D 16r74EE 16r4E4E 16r631D 16r4E4F 16r8717 16r4E50 16r6DA1 16r4E51 16r7A9D 16r4E52 16r6211 16r4E53 16r65A1 16r4E54 16r5367 16r4E55 16r63E1 16r4E56 16r6C83 16r4E57 16r5DEB 16r4E58 16r545C 16r4E59 16r94A8 16r4E5A 16r4E4C 16r4E5B 16r6C61 16r4E5C 16r8BEC 16r4E5D 16r5C4B 16r4E5E 16r65E0 16r4E5F 16r829C 16r4E60 16r68A7 16r4E61 16r543E 16r4E62 16r5434 16r4E63 16r6BCB 16r4E64 16r6B66 16r4E65 16r4E94 16r4E66 16r6342 16r4E67 16r5348 16r4E68 16r821E 16r4E69 16r4F0D 16r4E6A 16r4FAE 16r4E6B 16r575E 16r4E6C 16r620A 16r4E6D 16r96FE 16r4E6E 16r6664 16r4E6F 16r7269 16r4E70 16r52FF 16r4E71 16r52A1 16r4E72 16r609F 16r4E73 16r8BEF 16r4E74 16r6614 16r4E75 16r7199 16r4E76 16r6790 16r4E77 16r897F 16r4E78 16r7852 16r4E79 16r77FD 16r4E7A 16r6670 16r4E7B 16r563B 16r4E7C 16r5438 16r4E7D 16r9521 16r4E7E 16r727A 16r4F21 16r7A00 16r4F22 16r606F 16r4F23 16r5E0C 16r4F24 16r6089 16r4F25 16r819D 16r4F26 16r5915 16r4F27 16r60DC 16r4F28 16r7184 16r4F29 16r70EF 16r4F2A 16r6EAA 16r4F2B 16r6C50 16r4F2C 16r7280 16r4F2D 16r6A84 16r4F2E 16r88AD 16r4F2F 16r5E2D 16r4F30 16r4E60 16r4F31 16r5AB3 16r4F32 16r559C 16r4F33 16r94E3 16r4F34 16r6D17 16r4F35 16r7CFB 16r4F36 16r9699 16r4F37 16r620F 16r4F38 16r7EC6 16r4F39 16r778E 16r4F3A 16r867E 16r4F3B 16r5323 16r4F3C 16r971E 16r4F3D 16r8F96 16r4F3E 16r6687 16r4F3F 16r5CE1 16r4F40 16r4FA0 16r4F41 16r72ED 16r4F42 16r4E0B 16r4F43 16r53A6 16r4F44 16r590F 16r4F45 16r5413 16r4F46 16r6380 16r4F47 16r9528 16r4F48 16r5148 16r4F49 16r4ED9 16r4F4A 16r9C9C 16r4F4B 16r7EA4 16r4F4C 16r54B8 16r4F4D 16r8D24 16r4F4E 16r8854 16r4F4F 16r8237 16r4F50 16r95F2 16r4F51 16r6D8E 16r4F52 16r5F26 16r4F53 16r5ACC 16r4F54 16r663E 16r4F55 16r9669 16r4F56 16r73B0 16r4F57 16r732E 16r4F58 16r53BF 16r4F59 16r817A 16r4F5A 16r9985 16r4F5B 16r7FA1 16r4F5C 16r5BAA 16r4F5D 16r9677 16r4F5E 16r9650 16r4F5F 16r7EBF 16r4F60 16r76F8 16r4F61 16r53A2 16r4F62 16r9576 16r4F63 16r9999 16r4F64 16r7BB1 16r4F65 16r8944 16r4F66 16r6E58 16r4F67 16r4E61 16r4F68 16r7FD4 16r4F69 16r7965 16r4F6A 16r8BE6 16r4F6B 16r60F3 16r4F6C 16r54CD 16r4F6D 16r4EAB 16r4F6E 16r9879 16r4F6F 16r5DF7 16r4F70 16r6A61 16r4F71 16r50CF 16r4F72 16r5411 16r4F73 16r8C61 16r4F74 16r8427 16r4F75 16r785D 16r4F76 16r9704 16r4F77 16r524A 16r4F78 16r54EE 16r4F79 16r56A3 16r4F7A 16r9500 16r4F7B 16r6D88 16r4F7C 16r5BB5 16r4F7D 16r6DC6 16r4F7E 16r6653 16r5021 16r5C0F 16r5022 16r5B5D 16r5023 16r6821 16r5024 16r8096 16r5025 16r5578 16r5026 16r7B11 16r5027 16r6548 16r5028 16r6954 16r5029 16r4E9B 16r502A 16r6B47 16r502B 16r874E 16r502C 16r978B 16r502D 16r534F 16r502E 16r631F 16r502F 16r643A 16r5030 16r90AA 16r5031 16r659C 16r5032 16r80C1 16r5033 16r8C10 16r5034 16r5199 16r5035 16r68B0 16r5036 16r5378 16r5037 16r87F9 16r5038 16r61C8 16r5039 16r6CC4 16r503A 16r6CFB 16r503B 16r8C22 16r503C 16r5C51 16r503D 16r85AA 16r503E 16r82AF 16r503F 16r950C 16r5040 16r6B23 16r5041 16r8F9B 16r5042 16r65B0 16r5043 16r5FFB 16r5044 16r5FC3 16r5045 16r4FE1 16r5046 16r8845 16r5047 16r661F 16r5048 16r8165 16r5049 16r7329 16r504A 16r60FA 16r504B 16r5174 16r504C 16r5211 16r504D 16r578B 16r504E 16r5F62 16r504F 16r90A2 16r5050 16r884C 16r5051 16r9192 16r5052 16r5E78 16r5053 16r674F 16r5054 16r6027 16r5055 16r59D3 16r5056 16r5144 16r5057 16r51F6 16r5058 16r80F8 16r5059 16r5308 16r505A 16r6C79 16r505B 16r96C4 16r505C 16r718A 16r505D 16r4F11 16r505E 16r4FEE 16r505F 16r7F9E 16r5060 16r673D 16r5061 16r55C5 16r5062 16r9508 16r5063 16r79C0 16r5064 16r8896 16r5065 16r7EE3 16r5066 16r589F 16r5067 16r620C 16r5068 16r9700 16r5069 16r865A 16r506A 16r5618 16r506B 16r987B 16r506C 16r5F90 16r506D 16r8BB8 16r506E 16r84C4 16r506F 16r9157 16r5070 16r53D9 16r5071 16r65ED 16r5072 16r5E8F 16r5073 16r755C 16r5074 16r6064 16r5075 16r7D6E 16r5076 16r5A7F 16r5077 16r7EEA 16r5078 16r7EED 16r5079 16r8F69 16r507A 16r55A7 16r507B 16r5BA3 16r507C 16r60AC 16r507D 16r65CB 16r507E 16r7384 16r5121 16r9009 16r5122 16r7663 16r5123 16r7729 16r5124 16r7EDA 16r5125 16r9774 16r5126 16r859B 16r5127 16r5B66 16r5128 16r7A74 16r5129 16r96EA 16r512A 16r8840 16r512B 16r52CB 16r512C 16r718F 16r512D 16r5FAA 16r512E 16r65EC 16r512F 16r8BE2 16r5130 16r5BFB 16r5131 16r9A6F 16r5132 16r5DE1 16r5133 16r6B89 16r5134 16r6C5B 16r5135 16r8BAD 16r5136 16r8BAF 16r5137 16r900A 16r5138 16r8FC5 16r5139 16r538B 16r513A 16r62BC 16r513B 16r9E26 16r513C 16r9E2D 16r513D 16r5440 16r513E 16r4E2B 16r513F 16r82BD 16r5140 16r7259 16r5141 16r869C 16r5142 16r5D16 16r5143 16r8859 16r5144 16r6DAF 16r5145 16r96C5 16r5146 16r54D1 16r5147 16r4E9A 16r5148 16r8BB6 16r5149 16r7109 16r514A 16r54BD 16r514B 16r9609 16r514C 16r70DF 16r514D 16r6DF9 16r514E 16r76D0 16r514F 16r4E25 16r5150 16r7814 16r5151 16r8712 16r5152 16r5CA9 16r5153 16r5EF6 16r5154 16r8A00 16r5155 16r989C 16r5156 16r960E 16r5157 16r708E 16r5158 16r6CBF 16r5159 16r5944 16r515A 16r63A9 16r515B 16r773C 16r515C 16r884D 16r515D 16r6F14 16r515E 16r8273 16r515F 16r5830 16r5160 16r71D5 16r5161 16r538C 16r5162 16r781A 16r5163 16r96C1 16r5164 16r5501 16r5165 16r5F66 16r5166 16r7130 16r5167 16r5BB4 16r5168 16r8C1A 16r5169 16r9A8C 16r516A 16r6B83 16r516B 16r592E 16r516C 16r9E2F 16r516D 16r79E7 16r516E 16r6768 16r516F 16r626C 16r5170 16r4F6F 16r5171 16r75A1 16r5172 16r7F8A 16r5173 16r6D0B 16r5174 16r9633 16r5175 16r6C27 16r5176 16r4EF0 16r5177 16r75D2 16r5178 16r517B 16r5179 16r6837 16r517A 16r6F3E 16r517B 16r9080 16r517C 16r8170 16r517D 16r5996 16r517E 16r7476 16r5221 16r6447 16r5222 16r5C27 16r5223 16r9065 16r5224 16r7A91 16r5225 16r8C23 16r5226 16r59DA 16r5227 16r54AC 16r5228 16r8200 16r5229 16r836F 16r522A 16r8981 16r522B 16r8000 16r522C 16r6930 16r522D 16r564E 16r522E 16r8036 16r522F 16r7237 16r5230 16r91CE 16r5231 16r51B6 16r5232 16r4E5F 16r5233 16r9875 16r5234 16r6396 16r5235 16r4E1A 16r5236 16r53F6 16r5237 16r66F3 16r5238 16r814B 16r5239 16r591C 16r523A 16r6DB2 16r523B 16r4E00 16r523C 16r58F9 16r523D 16r533B 16r523E 16r63D6 16r523F 16r94F1 16r5240 16r4F9D 16r5241 16r4F0A 16r5242 16r8863 16r5243 16r9890 16r5244 16r5937 16r5245 16r9057 16r5246 16r79FB 16r5247 16r4EEA 16r5248 16r80F0 16r5249 16r7591 16r524A 16r6C82 16r524B 16r5B9C 16r524C 16r59E8 16r524D 16r5F5D 16r524E 16r6905 16r524F 16r8681 16r5250 16r501A 16r5251 16r5DF2 16r5252 16r4E59 16r5253 16r77E3 16r5254 16r4EE5 16r5255 16r827A 16r5256 16r6291 16r5257 16r6613 16r5258 16r9091 16r5259 16r5C79 16r525A 16r4EBF 16r525B 16r5F79 16r525C 16r81C6 16r525D 16r9038 16r525E 16r8084 16r525F 16r75AB 16r5260 16r4EA6 16r5261 16r88D4 16r5262 16r610F 16r5263 16r6BC5 16r5264 16r5FC6 16r5265 16r4E49 16r5266 16r76CA 16r5267 16r6EA2 16r5268 16r8BE3 16r5269 16r8BAE 16r526A 16r8C0A 16r526B 16r8BD1 16r526C 16r5F02 16r526D 16r7FFC 16r526E 16r7FCC 16r526F 16r7ECE 16r5270 16r8335 16r5271 16r836B 16r5272 16r56E0 16r5273 16r6BB7 16r5274 16r97F3 16r5275 16r9634 16r5276 16r59FB 16r5277 16r541F 16r5278 16r94F6 16r5279 16r6DEB 16r527A 16r5BC5 16r527B 16r996E 16r527C 16r5C39 16r527D 16r5F15 16r527E 16r9690 16r5321 16r5370 16r5322 16r82F1 16r5323 16r6A31 16r5324 16r5A74 16r5325 16r9E70 16r5326 16r5E94 16r5327 16r7F28 16r5328 16r83B9 16r5329 16r8424 16r532A 16r8425 16r532B 16r8367 16r532C 16r8747 16r532D 16r8FCE 16r532E 16r8D62 16r532F 16r76C8 16r5330 16r5F71 16r5331 16r9896 16r5332 16r786C 16r5333 16r6620 16r5334 16r54DF 16r5335 16r62E5 16r5336 16r4F63 16r5337 16r81C3 16r5338 16r75C8 16r5339 16r5EB8 16r533A 16r96CD 16r533B 16r8E0A 16r533C 16r86F9 16r533D 16r548F 16r533E 16r6CF3 16r533F 16r6D8C 16r5340 16r6C38 16r5341 16r607F 16r5342 16r52C7 16r5343 16r7528 16r5344 16r5E7D 16r5345 16r4F18 16r5346 16r60A0 16r5347 16r5FE7 16r5348 16r5C24 16r5349 16r7531 16r534A 16r90AE 16r534B 16r94C0 16r534C 16r72B9 16r534D 16r6CB9 16r534E 16r6E38 16r534F 16r9149 16r5350 16r6709 16r5351 16r53CB 16r5352 16r53F3 16r5353 16r4F51 16r5354 16r91C9 16r5355 16r8BF1 16r5356 16r53C8 16r5357 16r5E7C 16r5358 16r8FC2 16r5359 16r6DE4 16r535A 16r4E8E 16r535B 16r76C2 16r535C 16r6986 16r535D 16r865E 16r535E 16r611A 16r535F 16r8206 16r5360 16r4F59 16r5361 16r4FDE 16r5362 16r903E 16r5363 16r9C7C 16r5364 16r6109 16r5365 16r6E1D 16r5366 16r6E14 16r5367 16r9685 16r5368 16r4E88 16r5369 16r5A31 16r536A 16r96E8 16r536B 16r4E0E 16r536C 16r5C7F 16r536D 16r79B9 16r536E 16r5B87 16r536F 16r8BED 16r5370 16r7FBD 16r5371 16r7389 16r5372 16r57DF 16r5373 16r828B 16r5374 16r90C1 16r5375 16r5401 16r5376 16r9047 16r5377 16r55BB 16r5378 16r5CEA 16r5379 16r5FA1 16r537A 16r6108 16r537B 16r6B32 16r537C 16r72F1 16r537D 16r80B2 16r537E 16r8A89 16r5421 16r6D74 16r5422 16r5BD3 16r5423 16r88D5 16r5424 16r9884 16r5425 16r8C6B 16r5426 16r9A6D 16r5427 16r9E33 16r5428 16r6E0A 16r5429 16r51A4 16r542A 16r5143 16r542B 16r57A3 16r542C 16r8881 16r542D 16r539F 16r542E 16r63F4 16r542F 16r8F95 16r5430 16r56ED 16r5431 16r5458 16r5432 16r5706 16r5433 16r733F 16r5434 16r6E90 16r5435 16r7F18 16r5436 16r8FDC 16r5437 16r82D1 16r5438 16r613F 16r5439 16r6028 16r543A 16r9662 16r543B 16r66F0 16r543C 16r7EA6 16r543D 16r8D8A 16r543E 16r8DC3 16r543F 16r94A5 16r5440 16r5CB3 16r5441 16r7CA4 16r5442 16r6708 16r5443 16r60A6 16r5444 16r9605 16r5445 16r8018 16r5446 16r4E91 16r5447 16r90E7 16r5448 16r5300 16r5449 16r9668 16r544A 16r5141 16r544B 16r8FD0 16r544C 16r8574 16r544D 16r915D 16r544E 16r6655 16r544F 16r97F5 16r5450 16r5B55 16r5451 16r531D 16r5452 16r7838 16r5453 16r6742 16r5454 16r683D 16r5455 16r54C9 16r5456 16r707E 16r5457 16r5BB0 16r5458 16r8F7D 16r5459 16r518D 16r545A 16r5728 16r545B 16r54B1 16r545C 16r6512 16r545D 16r6682 16r545E 16r8D5E 16r545F 16r8D43 16r5460 16r810F 16r5461 16r846C 16r5462 16r906D 16r5463 16r7CDF 16r5464 16r51FF 16r5465 16r85FB 16r5466 16r67A3 16r5467 16r65E9 16r5468 16r6FA1 16r5469 16r86A4 16r546A 16r8E81 16r546B 16r566A 16r546C 16r9020 16r546D 16r7682 16r546E 16r7076 16r546F 16r71E5 16r5470 16r8D23 16r5471 16r62E9 16r5472 16r5219 16r5473 16r6CFD 16r5474 16r8D3C 16r5475 16r600E 16r5476 16r589E 16r5477 16r618E 16r5478 16r66FE 16r5479 16r8D60 16r547A 16r624E 16r547B 16r55B3 16r547C 16r6E23 16r547D 16r672D 16r547E 16r8F67 16r5521 16r94E1 16r5522 16r95F8 16r5523 16r7728 16r5524 16r6805 16r5525 16r69A8 16r5526 16r548B 16r5527 16r4E4D 16r5528 16r70B8 16r5529 16r8BC8 16r552A 16r6458 16r552B 16r658B 16r552C 16r5B85 16r552D 16r7A84 16r552E 16r503A 16r552F 16r5BE8 16r5530 16r77BB 16r5531 16r6BE1 16r5532 16r8A79 16r5533 16r7C98 16r5534 16r6CBE 16r5535 16r76CF 16r5536 16r65A9 16r5537 16r8F97 16r5538 16r5D2D 16r5539 16r5C55 16r553A 16r8638 16r553B 16r6808 16r553C 16r5360 16r553D 16r6218 16r553E 16r7AD9 16r553F 16r6E5B 16r5540 16r7EFD 16r5541 16r6A1F 16r5542 16r7AE0 16r5543 16r5F70 16r5544 16r6F33 16r5545 16r5F20 16r5546 16r638C 16r5547 16r6DA8 16r5548 16r6756 16r5549 16r4E08 16r554A 16r5E10 16r554B 16r8D26 16r554C 16r4ED7 16r554D 16r80C0 16r554E 16r7634 16r554F 16r969C 16r5550 16r62DB 16r5551 16r662D 16r5552 16r627E 16r5553 16r6CBC 16r5554 16r8D75 16r5555 16r7167 16r5556 16r7F69 16r5557 16r5146 16r5558 16r8087 16r5559 16r53EC 16r555A 16r906E 16r555B 16r6298 16r555C 16r54F2 16r555D 16r86F0 16r555E 16r8F99 16r555F 16r8005 16r5560 16r9517 16r5561 16r8517 16r5562 16r8FD9 16r5563 16r6D59 16r5564 16r73CD 16r5565 16r659F 16r5566 16r771F 16r5567 16r7504 16r5568 16r7827 16r5569 16r81FB 16r556A 16r8D1E 16r556B 16r9488 16r556C 16r4FA6 16r556D 16r6795 16r556E 16r75B9 16r556F 16r8BCA 16r5570 16r9707 16r5571 16r632F 16r5572 16r9547 16r5573 16r9635 16r5574 16r84B8 16r5575 16r6323 16r5576 16r7741 16r5577 16r5F81 16r5578 16r72F0 16r5579 16r4E89 16r557A 16r6014 16r557B 16r6574 16r557C 16r62EF 16r557D 16r6B63 16r557E 16r653F 16r5621 16r5E27 16r5622 16r75C7 16r5623 16r90D1 16r5624 16r8BC1 16r5625 16r829D 16r5626 16r679D 16r5627 16r652F 16r5628 16r5431 16r5629 16r8718 16r562A 16r77E5 16r562B 16r80A2 16r562C 16r8102 16r562D 16r6C41 16r562E 16r4E4B 16r562F 16r7EC7 16r5630 16r804C 16r5631 16r76F4 16r5632 16r690D 16r5633 16r6B96 16r5634 16r6267 16r5635 16r503C 16r5636 16r4F84 16r5637 16r5740 16r5638 16r6307 16r5639 16r6B62 16r563A 16r8DBE 16r563B 16r53EA 16r563C 16r65E8 16r563D 16r7EB8 16r563E 16r5FD7 16r563F 16r631A 16r5640 16r63B7 16r5641 16r81F3 16r5642 16r81F4 16r5643 16r7F6E 16r5644 16r5E1C 16r5645 16r5CD9 16r5646 16r5236 16r5647 16r667A 16r5648 16r79E9 16r5649 16r7A1A 16r564A 16r8D28 16r564B 16r7099 16r564C 16r75D4 16r564D 16r6EDE 16r564E 16r6CBB 16r564F 16r7A92 16r5650 16r4E2D 16r5651 16r76C5 16r5652 16r5FE0 16r5653 16r949F 16r5654 16r8877 16r5655 16r7EC8 16r5656 16r79CD 16r5657 16r80BF 16r5658 16r91CD 16r5659 16r4EF2 16r565A 16r4F17 16r565B 16r821F 16r565C 16r5468 16r565D 16r5DDE 16r565E 16r6D32 16r565F 16r8BCC 16r5660 16r7CA5 16r5661 16r8F74 16r5662 16r8098 16r5663 16r5E1A 16r5664 16r5492 16r5665 16r76B1 16r5666 16r5B99 16r5667 16r663C 16r5668 16r9AA4 16r5669 16r73E0 16r566A 16r682A 16r566B 16r86DB 16r566C 16r6731 16r566D 16r732A 16r566E 16r8BF8 16r566F 16r8BDB 16r5670 16r9010 16r5671 16r7AF9 16r5672 16r70DB 16r5673 16r716E 16r5674 16r62C4 16r5675 16r77A9 16r5676 16r5631 16r5677 16r4E3B 16r5678 16r8457 16r5679 16r67F1 16r567A 16r52A9 16r567B 16r86C0 16r567C 16r8D2E 16r567D 16r94F8 16r567E 16r7B51 16r5721 16r4F4F 16r5722 16r6CE8 16r5723 16r795D 16r5724 16r9A7B 16r5725 16r6293 16r5726 16r722A 16r5727 16r62FD 16r5728 16r4E13 16r5729 16r7816 16r572A 16r8F6C 16r572B 16r64B0 16r572C 16r8D5A 16r572D 16r7BC6 16r572E 16r6869 16r572F 16r5E84 16r5730 16r88C5 16r5731 16r5986 16r5732 16r649E 16r5733 16r58EE 16r5734 16r72B6 16r5735 16r690E 16r5736 16r9525 16r5737 16r8FFD 16r5738 16r8D58 16r5739 16r5760 16r573A 16r7F00 16r573B 16r8C06 16r573C 16r51C6 16r573D 16r6349 16r573E 16r62D9 16r573F 16r5353 16r5740 16r684C 16r5741 16r7422 16r5742 16r8301 16r5743 16r914C 16r5744 16r5544 16r5745 16r7740 16r5746 16r707C 16r5747 16r6D4A 16r5748 16r5179 16r5749 16r54A8 16r574A 16r8D44 16r574B 16r59FF 16r574C 16r6ECB 16r574D 16r6DC4 16r574E 16r5B5C 16r574F 16r7D2B 16r5750 16r4ED4 16r5751 16r7C7D 16r5752 16r6ED3 16r5753 16r5B50 16r5754 16r81EA 16r5755 16r6E0D 16r5756 16r5B57 16r5757 16r9B03 16r5758 16r68D5 16r5759 16r8E2A 16r575A 16r5B97 16r575B 16r7EFC 16r575C 16r603B 16r575D 16r7EB5 16r575E 16r90B9 16r575F 16r8D70 16r5760 16r594F 16r5761 16r63CD 16r5762 16r79DF 16r5763 16r8DB3 16r5764 16r5352 16r5765 16r65CF 16r5766 16r7956 16r5767 16r8BC5 16r5768 16r963B 16r5769 16r7EC4 16r576A 16r94BB 16r576B 16r7E82 16r576C 16r5634 16r576D 16r9189 16r576E 16r6700 16r576F 16r7F6A 16r5770 16r5C0A 16r5771 16r9075 16r5772 16r6628 16r5773 16r5DE6 16r5774 16r4F50 16r5775 16r67DE 16r5776 16r505A 16r5777 16r4F5C 16r5778 16r5750 16r5779 16r5EA7 16r5821 16r4E8D 16r5822 16r4E0C 16r5823 16r5140 16r5824 16r4E10 16r5825 16r5EFF 16r5826 16r5345 16r5827 16r4E15 16r5828 16r4E98 16r5829 16r4E1E 16r582A 16r9B32 16r582B 16r5B6C 16r582C 16r5669 16r582D 16r4E28 16r582E 16r79BA 16r582F 16r4E3F 16r5830 16r5315 16r5831 16r4E47 16r5832 16r592D 16r5833 16r723B 16r5834 16r536E 16r5835 16r6C10 16r5836 16r56DF 16r5837 16r80E4 16r5838 16r9997 16r5839 16r6BD3 16r583A 16r777E 16r583B 16r9F17 16r583C 16r4E36 16r583D 16r4E9F 16r583E 16r9F10 16r583F 16r4E5C 16r5840 16r4E69 16r5841 16r4E93 16r5842 16r8288 16r5843 16r5B5B 16r5844 16r556C 16r5845 16r560F 16r5846 16r4EC4 16r5847 16r538D 16r5848 16r539D 16r5849 16r53A3 16r584A 16r53A5 16r584B 16r53AE 16r584C 16r9765 16r584D 16r8D5D 16r584E 16r531A 16r584F 16r53F5 16r5850 16r5326 16r5851 16r532E 16r5852 16r533E 16r5853 16r8D5C 16r5854 16r5366 16r5855 16r5363 16r5856 16r5202 16r5857 16r5208 16r5858 16r520E 16r5859 16r522D 16r585A 16r5233 16r585B 16r523F 16r585C 16r5240 16r585D 16r524C 16r585E 16r525E 16r585F 16r5261 16r5860 16r525C 16r5861 16r84AF 16r5862 16r527D 16r5863 16r5282 16r5864 16r5281 16r5865 16r5290 16r5866 16r5293 16r5867 16r5182 16r5868 16r7F54 16r5869 16r4EBB 16r586A 16r4EC3 16r586B 16r4EC9 16r586C 16r4EC2 16r586D 16r4EE8 16r586E 16r4EE1 16r586F 16r4EEB 16r5870 16r4EDE 16r5871 16r4F1B 16r5872 16r4EF3 16r5873 16r4F22 16r5874 16r4F64 16r5875 16r4EF5 16r5876 16r4F25 16r5877 16r4F27 16r5878 16r4F09 16r5879 16r4F2B 16r587A 16r4F5E 16r587B 16r4F67 16r587C 16r6538 16r587D 16r4F5A 16r587E 16r4F5D 16r5921 16r4F5F 16r5922 16r4F57 16r5923 16r4F32 16r5924 16r4F3D 16r5925 16r4F76 16r5926 16r4F74 16r5927 16r4F91 16r5928 16r4F89 16r5929 16r4F83 16r592A 16r4F8F 16r592B 16r4F7E 16r592C 16r4F7B 16r592D 16r4FAA 16r592E 16r4F7C 16r592F 16r4FAC 16r5930 16r4F94 16r5931 16r4FE6 16r5932 16r4FE8 16r5933 16r4FEA 16r5934 16r4FC5 16r5935 16r4FDA 16r5936 16r4FE3 16r5937 16r4FDC 16r5938 16r4FD1 16r5939 16r4FDF 16r593A 16r4FF8 16r593B 16r5029 16r593C 16r504C 16r593D 16r4FF3 16r593E 16r502C 16r593F 16r500F 16r5940 16r502E 16r5941 16r502D 16r5942 16r4FFE 16r5943 16r501C 16r5944 16r500C 16r5945 16r5025 16r5946 16r5028 16r5947 16r507E 16r5948 16r5043 16r5949 16r5055 16r594A 16r5048 16r594B 16r504E 16r594C 16r506C 16r594D 16r507B 16r594E 16r50A5 16r594F 16r50A7 16r5950 16r50A9 16r5951 16r50BA 16r5952 16r50D6 16r5953 16r5106 16r5954 16r50ED 16r5955 16r50EC 16r5956 16r50E6 16r5957 16r50EE 16r5958 16r5107 16r5959 16r510B 16r595A 16r4EDD 16r595B 16r6C3D 16r595C 16r4F58 16r595D 16r4F65 16r595E 16r4FCE 16r595F 16r9FA0 16r5960 16r6C46 16r5961 16r7C74 16r5962 16r516E 16r5963 16r5DFD 16r5964 16r9EC9 16r5965 16r9998 16r5966 16r5181 16r5967 16r5914 16r5968 16r52F9 16r5969 16r530D 16r596A 16r8A07 16r596B 16r5310 16r596C 16r51EB 16r596D 16r5919 16r596E 16r5155 16r596F 16r4EA0 16r5970 16r5156 16r5971 16r4EB3 16r5972 16r886E 16r5973 16r88A4 16r5974 16r4EB5 16r5975 16r8114 16r5976 16r88D2 16r5977 16r7980 16r5978 16r5B34 16r5979 16r8803 16r597A 16r7FB8 16r597B 16r51AB 16r597C 16r51B1 16r597D 16r51BD 16r597E 16r51BC 16r5A21 16r51C7 16r5A22 16r5196 16r5A23 16r51A2 16r5A24 16r51A5 16r5A25 16r8BA0 16r5A26 16r8BA6 16r5A27 16r8BA7 16r5A28 16r8BAA 16r5A29 16r8BB4 16r5A2A 16r8BB5 16r5A2B 16r8BB7 16r5A2C 16r8BC2 16r5A2D 16r8BC3 16r5A2E 16r8BCB 16r5A2F 16r8BCF 16r5A30 16r8BCE 16r5A31 16r8BD2 16r5A32 16r8BD3 16r5A33 16r8BD4 16r5A34 16r8BD6 16r5A35 16r8BD8 16r5A36 16r8BD9 16r5A37 16r8BDC 16r5A38 16r8BDF 16r5A39 16r8BE0 16r5A3A 16r8BE4 16r5A3B 16r8BE8 16r5A3C 16r8BE9 16r5A3D 16r8BEE 16r5A3E 16r8BF0 16r5A3F 16r8BF3 16r5A40 16r8BF6 16r5A41 16r8BF9 16r5A42 16r8BFC 16r5A43 16r8BFF 16r5A44 16r8C00 16r5A45 16r8C02 16r5A46 16r8C04 16r5A47 16r8C07 16r5A48 16r8C0C 16r5A49 16r8C0F 16r5A4A 16r8C11 16r5A4B 16r8C12 16r5A4C 16r8C14 16r5A4D 16r8C15 16r5A4E 16r8C16 16r5A4F 16r8C19 16r5A50 16r8C1B 16r5A51 16r8C18 16r5A52 16r8C1D 16r5A53 16r8C1F 16r5A54 16r8C20 16r5A55 16r8C21 16r5A56 16r8C25 16r5A57 16r8C27 16r5A58 16r8C2A 16r5A59 16r8C2B 16r5A5A 16r8C2E 16r5A5B 16r8C2F 16r5A5C 16r8C32 16r5A5D 16r8C33 16r5A5E 16r8C35 16r5A5F 16r8C36 16r5A60 16r5369 16r5A61 16r537A 16r5A62 16r961D 16r5A63 16r9622 16r5A64 16r9621 16r5A65 16r9631 16r5A66 16r962A 16r5A67 16r963D 16r5A68 16r963C 16r5A69 16r9642 16r5A6A 16r9649 16r5A6B 16r9654 16r5A6C 16r965F 16r5A6D 16r9667 16r5A6E 16r966C 16r5A6F 16r9672 16r5A70 16r9674 16r5A71 16r9688 16r5A72 16r968D 16r5A73 16r9697 16r5A74 16r96B0 16r5A75 16r9097 16r5A76 16r909B 16r5A77 16r909D 16r5A78 16r9099 16r5A79 16r90AC 16r5A7A 16r90A1 16r5A7B 16r90B4 16r5A7C 16r90B3 16r5A7D 16r90B6 16r5A7E 16r90BA 16r5B21 16r90B8 16r5B22 16r90B0 16r5B23 16r90CF 16r5B24 16r90C5 16r5B25 16r90BE 16r5B26 16r90D0 16r5B27 16r90C4 16r5B28 16r90C7 16r5B29 16r90D3 16r5B2A 16r90E6 16r5B2B 16r90E2 16r5B2C 16r90DC 16r5B2D 16r90D7 16r5B2E 16r90DB 16r5B2F 16r90EB 16r5B30 16r90EF 16r5B31 16r90FE 16r5B32 16r9104 16r5B33 16r9122 16r5B34 16r911E 16r5B35 16r9123 16r5B36 16r9131 16r5B37 16r912F 16r5B38 16r9139 16r5B39 16r9143 16r5B3A 16r9146 16r5B3B 16r520D 16r5B3C 16r5942 16r5B3D 16r52A2 16r5B3E 16r52AC 16r5B3F 16r52AD 16r5B40 16r52BE 16r5B41 16r54FF 16r5B42 16r52D0 16r5B43 16r52D6 16r5B44 16r52F0 16r5B45 16r53DF 16r5B46 16r71EE 16r5B47 16r77CD 16r5B48 16r5EF4 16r5B49 16r51F5 16r5B4A 16r51FC 16r5B4B 16r9B2F 16r5B4C 16r53B6 16r5B4D 16r5F01 16r5B4E 16r755A 16r5B4F 16r5DEF 16r5B50 16r574C 16r5B51 16r57A9 16r5B52 16r57A1 16r5B53 16r587E 16r5B54 16r58BC 16r5B55 16r58C5 16r5B56 16r58D1 16r5B57 16r5729 16r5B58 16r572C 16r5B59 16r572A 16r5B5A 16r5733 16r5B5B 16r5739 16r5B5C 16r572E 16r5B5D 16r572F 16r5B5E 16r575C 16r5B5F 16r573B 16r5B60 16r5742 16r5B61 16r5769 16r5B62 16r5785 16r5B63 16r576B 16r5B64 16r5786 16r5B65 16r577C 16r5B66 16r577B 16r5B67 16r5768 16r5B68 16r576D 16r5B69 16r5776 16r5B6A 16r5773 16r5B6B 16r57AD 16r5B6C 16r57A4 16r5B6D 16r578C 16r5B6E 16r57B2 16r5B6F 16r57CF 16r5B70 16r57A7 16r5B71 16r57B4 16r5B72 16r5793 16r5B73 16r57A0 16r5B74 16r57D5 16r5B75 16r57D8 16r5B76 16r57DA 16r5B77 16r57D9 16r5B78 16r57D2 16r5B79 16r57B8 16r5B7A 16r57F4 16r5B7B 16r57EF 16r5B7C 16r57F8 16r5B7D 16r57E4 16r5B7E 16r57DD 16r5C21 16r580B 16r5C22 16r580D 16r5C23 16r57FD 16r5C24 16r57ED 16r5C25 16r5800 16r5C26 16r581E 16r5C27 16r5819 16r5C28 16r5844 16r5C29 16r5820 16r5C2A 16r5865 16r5C2B 16r586C 16r5C2C 16r5881 16r5C2D 16r5889 16r5C2E 16r589A 16r5C2F 16r5880 16r5C30 16r99A8 16r5C31 16r9F19 16r5C32 16r61FF 16r5C33 16r8279 16r5C34 16r827D 16r5C35 16r827F 16r5C36 16r828F 16r5C37 16r828A 16r5C38 16r82A8 16r5C39 16r8284 16r5C3A 16r828E 16r5C3B 16r8291 16r5C3C 16r8297 16r5C3D 16r8299 16r5C3E 16r82AB 16r5C3F 16r82B8 16r5C40 16r82BE 16r5C41 16r82B0 16r5C42 16r82C8 16r5C43 16r82CA 16r5C44 16r82E3 16r5C45 16r8298 16r5C46 16r82B7 16r5C47 16r82AE 16r5C48 16r82CB 16r5C49 16r82CC 16r5C4A 16r82C1 16r5C4B 16r82A9 16r5C4C 16r82B4 16r5C4D 16r82A1 16r5C4E 16r82AA 16r5C4F 16r829F 16r5C50 16r82C4 16r5C51 16r82CE 16r5C52 16r82A4 16r5C53 16r82E1 16r5C54 16r8309 16r5C55 16r82F7 16r5C56 16r82E4 16r5C57 16r830F 16r5C58 16r8307 16r5C59 16r82DC 16r5C5A 16r82F4 16r5C5B 16r82D2 16r5C5C 16r82D8 16r5C5D 16r830C 16r5C5E 16r82FB 16r5C5F 16r82D3 16r5C60 16r8311 16r5C61 16r831A 16r5C62 16r8306 16r5C63 16r8314 16r5C64 16r8315 16r5C65 16r82E0 16r5C66 16r82D5 16r5C67 16r831C 16r5C68 16r8351 16r5C69 16r835B 16r5C6A 16r835C 16r5C6B 16r8308 16r5C6C 16r8392 16r5C6D 16r833C 16r5C6E 16r8334 16r5C6F 16r8331 16r5C70 16r839B 16r5C71 16r835E 16r5C72 16r832F 16r5C73 16r834F 16r5C74 16r8347 16r5C75 16r8343 16r5C76 16r835F 16r5C77 16r8340 16r5C78 16r8317 16r5C79 16r8360 16r5C7A 16r832D 16r5C7B 16r833A 16r5C7C 16r8333 16r5C7D 16r8366 16r5C7E 16r8365 16r5D21 16r8368 16r5D22 16r831B 16r5D23 16r8369 16r5D24 16r836C 16r5D25 16r836A 16r5D26 16r836D 16r5D27 16r836E 16r5D28 16r83B0 16r5D29 16r8378 16r5D2A 16r83B3 16r5D2B 16r83B4 16r5D2C 16r83A0 16r5D2D 16r83AA 16r5D2E 16r8393 16r5D2F 16r839C 16r5D30 16r8385 16r5D31 16r837C 16r5D32 16r83B6 16r5D33 16r83A9 16r5D34 16r837D 16r5D35 16r83B8 16r5D36 16r837B 16r5D37 16r8398 16r5D38 16r839E 16r5D39 16r83A8 16r5D3A 16r83BA 16r5D3B 16r83BC 16r5D3C 16r83C1 16r5D3D 16r8401 16r5D3E 16r83E5 16r5D3F 16r83D8 16r5D40 16r5807 16r5D41 16r8418 16r5D42 16r840B 16r5D43 16r83DD 16r5D44 16r83FD 16r5D45 16r83D6 16r5D46 16r841C 16r5D47 16r8438 16r5D48 16r8411 16r5D49 16r8406 16r5D4A 16r83D4 16r5D4B 16r83DF 16r5D4C 16r840F 16r5D4D 16r8403 16r5D4E 16r83F8 16r5D4F 16r83F9 16r5D50 16r83EA 16r5D51 16r83C5 16r5D52 16r83C0 16r5D53 16r8426 16r5D54 16r83F0 16r5D55 16r83E1 16r5D56 16r845C 16r5D57 16r8451 16r5D58 16r845A 16r5D59 16r8459 16r5D5A 16r8473 16r5D5B 16r8487 16r5D5C 16r8488 16r5D5D 16r847A 16r5D5E 16r8489 16r5D5F 16r8478 16r5D60 16r843C 16r5D61 16r8446 16r5D62 16r8469 16r5D63 16r8476 16r5D64 16r848C 16r5D65 16r848E 16r5D66 16r8431 16r5D67 16r846D 16r5D68 16r84C1 16r5D69 16r84CD 16r5D6A 16r84D0 16r5D6B 16r84E6 16r5D6C 16r84BD 16r5D6D 16r84D3 16r5D6E 16r84CA 16r5D6F 16r84BF 16r5D70 16r84BA 16r5D71 16r84E0 16r5D72 16r84A1 16r5D73 16r84B9 16r5D74 16r84B4 16r5D75 16r8497 16r5D76 16r84E5 16r5D77 16r84E3 16r5D78 16r850C 16r5D79 16r750D 16r5D7A 16r8538 16r5D7B 16r84F0 16r5D7C 16r8539 16r5D7D 16r851F 16r5D7E 16r853A 16r5E21 16r8556 16r5E22 16r853B 16r5E23 16r84FF 16r5E24 16r84FC 16r5E25 16r8559 16r5E26 16r8548 16r5E27 16r8568 16r5E28 16r8564 16r5E29 16r855E 16r5E2A 16r857A 16r5E2B 16r77A2 16r5E2C 16r8543 16r5E2D 16r8572 16r5E2E 16r857B 16r5E2F 16r85A4 16r5E30 16r85A8 16r5E31 16r8587 16r5E32 16r858F 16r5E33 16r8579 16r5E34 16r85AE 16r5E35 16r859C 16r5E36 16r8585 16r5E37 16r85B9 16r5E38 16r85B7 16r5E39 16r85B0 16r5E3A 16r85D3 16r5E3B 16r85C1 16r5E3C 16r85DC 16r5E3D 16r85FF 16r5E3E 16r8627 16r5E3F 16r8605 16r5E40 16r8629 16r5E41 16r8616 16r5E42 16r863C 16r5E43 16r5EFE 16r5E44 16r5F08 16r5E45 16r593C 16r5E46 16r5941 16r5E47 16r8037 16r5E48 16r5955 16r5E49 16r595A 16r5E4A 16r5958 16r5E4B 16r530F 16r5E4C 16r5C22 16r5E4D 16r5C25 16r5E4E 16r5C2C 16r5E4F 16r5C34 16r5E50 16r624C 16r5E51 16r626A 16r5E52 16r629F 16r5E53 16r62BB 16r5E54 16r62CA 16r5E55 16r62DA 16r5E56 16r62D7 16r5E57 16r62EE 16r5E58 16r6322 16r5E59 16r62F6 16r5E5A 16r6339 16r5E5B 16r634B 16r5E5C 16r6343 16r5E5D 16r63AD 16r5E5E 16r63F6 16r5E5F 16r6371 16r5E60 16r637A 16r5E61 16r638E 16r5E62 16r63B4 16r5E63 16r636D 16r5E64 16r63AC 16r5E65 16r638A 16r5E66 16r6369 16r5E67 16r63AE 16r5E68 16r63BC 16r5E69 16r63F2 16r5E6A 16r63F8 16r5E6B 16r63E0 16r5E6C 16r63FF 16r5E6D 16r63C4 16r5E6E 16r63DE 16r5E6F 16r63CE 16r5E70 16r6452 16r5E71 16r63C6 16r5E72 16r63BE 16r5E73 16r6445 16r5E74 16r6441 16r5E75 16r640B 16r5E76 16r641B 16r5E77 16r6420 16r5E78 16r640C 16r5E79 16r6426 16r5E7A 16r6421 16r5E7B 16r645E 16r5E7C 16r6484 16r5E7D 16r646D 16r5E7E 16r6496 16r5F21 16r647A 16r5F22 16r64B7 16r5F23 16r64B8 16r5F24 16r6499 16r5F25 16r64BA 16r5F26 16r64C0 16r5F27 16r64D0 16r5F28 16r64D7 16r5F29 16r64E4 16r5F2A 16r64E2 16r5F2B 16r6509 16r5F2C 16r6525 16r5F2D 16r652E 16r5F2E 16r5F0B 16r5F2F 16r5FD2 16r5F30 16r7519 16r5F31 16r5F11 16r5F32 16r535F 16r5F33 16r53F1 16r5F34 16r53FD 16r5F35 16r53E9 16r5F36 16r53E8 16r5F37 16r53FB 16r5F38 16r5412 16r5F39 16r5416 16r5F3A 16r5406 16r5F3B 16r544B 16r5F3C 16r5452 16r5F3D 16r5453 16r5F3E 16r5454 16r5F3F 16r5456 16r5F40 16r5443 16r5F41 16r5421 16r5F42 16r5457 16r5F43 16r5459 16r5F44 16r5423 16r5F45 16r5432 16r5F46 16r5482 16r5F47 16r5494 16r5F48 16r5477 16r5F49 16r5471 16r5F4A 16r5464 16r5F4B 16r549A 16r5F4C 16r549B 16r5F4D 16r5484 16r5F4E 16r5476 16r5F4F 16r5466 16r5F50 16r549D 16r5F51 16r54D0 16r5F52 16r54AD 16r5F53 16r54C2 16r5F54 16r54B4 16r5F55 16r54D2 16r5F56 16r54A7 16r5F57 16r54A6 16r5F58 16r54D3 16r5F59 16r54D4 16r5F5A 16r5472 16r5F5B 16r54A3 16r5F5C 16r54D5 16r5F5D 16r54BB 16r5F5E 16r54BF 16r5F5F 16r54CC 16r5F60 16r54D9 16r5F61 16r54DA 16r5F62 16r54DC 16r5F63 16r54A9 16r5F64 16r54AA 16r5F65 16r54A4 16r5F66 16r54DD 16r5F67 16r54CF 16r5F68 16r54DE 16r5F69 16r551B 16r5F6A 16r54E7 16r5F6B 16r5520 16r5F6C 16r54FD 16r5F6D 16r5514 16r5F6E 16r54F3 16r5F6F 16r5522 16r5F70 16r5523 16r5F71 16r550F 16r5F72 16r5511 16r5F73 16r5527 16r5F74 16r552A 16r5F75 16r5567 16r5F76 16r558F 16r5F77 16r55B5 16r5F78 16r5549 16r5F79 16r556D 16r5F7A 16r5541 16r5F7B 16r5555 16r5F7C 16r553F 16r5F7D 16r5550 16r5F7E 16r553C 16r6021 16r5537 16r6022 16r5556 16r6023 16r5575 16r6024 16r5576 16r6025 16r5577 16r6026 16r5533 16r6027 16r5530 16r6028 16r555C 16r6029 16r558B 16r602A 16r55D2 16r602B 16r5583 16r602C 16r55B1 16r602D 16r55B9 16r602E 16r5588 16r602F 16r5581 16r6030 16r559F 16r6031 16r557E 16r6032 16r55D6 16r6033 16r5591 16r6034 16r557B 16r6035 16r55DF 16r6036 16r55BD 16r6037 16r55BE 16r6038 16r5594 16r6039 16r5599 16r603A 16r55EA 16r603B 16r55F7 16r603C 16r55C9 16r603D 16r561F 16r603E 16r55D1 16r603F 16r55EB 16r6040 16r55EC 16r6041 16r55D4 16r6042 16r55E6 16r6043 16r55DD 16r6044 16r55C4 16r6045 16r55EF 16r6046 16r55E5 16r6047 16r55F2 16r6048 16r55F3 16r6049 16r55CC 16r604A 16r55CD 16r604B 16r55E8 16r604C 16r55F5 16r604D 16r55E4 16r604E 16r8F94 16r604F 16r561E 16r6050 16r5608 16r6051 16r560C 16r6052 16r5601 16r6053 16r5624 16r6054 16r5623 16r6055 16r55FE 16r6056 16r5600 16r6057 16r5627 16r6058 16r562D 16r6059 16r5658 16r605A 16r5639 16r605B 16r5657 16r605C 16r562C 16r605D 16r564D 16r605E 16r5662 16r605F 16r5659 16r6060 16r565C 16r6061 16r564C 16r6062 16r5654 16r6063 16r5686 16r6064 16r5664 16r6065 16r5671 16r6066 16r566B 16r6067 16r567B 16r6068 16r567C 16r6069 16r5685 16r606A 16r5693 16r606B 16r56AF 16r606C 16r56D4 16r606D 16r56D7 16r606E 16r56DD 16r606F 16r56E1 16r6070 16r56F5 16r6071 16r56EB 16r6072 16r56F9 16r6073 16r56FF 16r6074 16r5704 16r6075 16r570A 16r6076 16r5709 16r6077 16r571C 16r6078 16r5E0F 16r6079 16r5E19 16r607A 16r5E14 16r607B 16r5E11 16r607C 16r5E31 16r607D 16r5E3B 16r607E 16r5E3C 16r6121 16r5E37 16r6122 16r5E44 16r6123 16r5E54 16r6124 16r5E5B 16r6125 16r5E5E 16r6126 16r5E61 16r6127 16r5C8C 16r6128 16r5C7A 16r6129 16r5C8D 16r612A 16r5C90 16r612B 16r5C96 16r612C 16r5C88 16r612D 16r5C98 16r612E 16r5C99 16r612F 16r5C91 16r6130 16r5C9A 16r6131 16r5C9C 16r6132 16r5CB5 16r6133 16r5CA2 16r6134 16r5CBD 16r6135 16r5CAC 16r6136 16r5CAB 16r6137 16r5CB1 16r6138 16r5CA3 16r6139 16r5CC1 16r613A 16r5CB7 16r613B 16r5CC4 16r613C 16r5CD2 16r613D 16r5CE4 16r613E 16r5CCB 16r613F 16r5CE5 16r6140 16r5D02 16r6141 16r5D03 16r6142 16r5D27 16r6143 16r5D26 16r6144 16r5D2E 16r6145 16r5D24 16r6146 16r5D1E 16r6147 16r5D06 16r6148 16r5D1B 16r6149 16r5D58 16r614A 16r5D3E 16r614B 16r5D34 16r614C 16r5D3D 16r614D 16r5D6C 16r614E 16r5D5B 16r614F 16r5D6F 16r6150 16r5D5D 16r6151 16r5D6B 16r6152 16r5D4B 16r6153 16r5D4A 16r6154 16r5D69 16r6155 16r5D74 16r6156 16r5D82 16r6157 16r5D99 16r6158 16r5D9D 16r6159 16r8C73 16r615A 16r5DB7 16r615B 16r5DC5 16r615C 16r5F73 16r615D 16r5F77 16r615E 16r5F82 16r615F 16r5F87 16r6160 16r5F89 16r6161 16r5F8C 16r6162 16r5F95 16r6163 16r5F99 16r6164 16r5F9C 16r6165 16r5FA8 16r6166 16r5FAD 16r6167 16r5FB5 16r6168 16r5FBC 16r6169 16r8862 16r616A 16r5F61 16r616B 16r72AD 16r616C 16r72B0 16r616D 16r72B4 16r616E 16r72B7 16r616F 16r72B8 16r6170 16r72C3 16r6171 16r72C1 16r6172 16r72CE 16r6173 16r72CD 16r6174 16r72D2 16r6175 16r72E8 16r6176 16r72EF 16r6177 16r72E9 16r6178 16r72F2 16r6179 16r72F4 16r617A 16r72F7 16r617B 16r7301 16r617C 16r72F3 16r617D 16r7303 16r617E 16r72FA 16r6221 16r72FB 16r6222 16r7317 16r6223 16r7313 16r6224 16r7321 16r6225 16r730A 16r6226 16r731E 16r6227 16r731D 16r6228 16r7315 16r6229 16r7322 16r622A 16r7339 16r622B 16r7325 16r622C 16r732C 16r622D 16r7338 16r622E 16r7331 16r622F 16r7350 16r6230 16r734D 16r6231 16r7357 16r6232 16r7360 16r6233 16r736C 16r6234 16r736F 16r6235 16r737E 16r6236 16r821B 16r6237 16r5925 16r6238 16r98E7 16r6239 16r5924 16r623A 16r5902 16r623B 16r9963 16r623C 16r9967 16r623D 16r9968 16r623E 16r9969 16r623F 16r996A 16r6240 16r996B 16r6241 16r996C 16r6242 16r9974 16r6243 16r9977 16r6244 16r997D 16r6245 16r9980 16r6246 16r9984 16r6247 16r9987 16r6248 16r998A 16r6249 16r998D 16r624A 16r9990 16r624B 16r9991 16r624C 16r9993 16r624D 16r9994 16r624E 16r9995 16r624F 16r5E80 16r6250 16r5E91 16r6251 16r5E8B 16r6252 16r5E96 16r6253 16r5EA5 16r6254 16r5EA0 16r6255 16r5EB9 16r6256 16r5EB5 16r6257 16r5EBE 16r6258 16r5EB3 16r6259 16r8D53 16r625A 16r5ED2 16r625B 16r5ED1 16r625C 16r5EDB 16r625D 16r5EE8 16r625E 16r5EEA 16r625F 16r81BA 16r6260 16r5FC4 16r6261 16r5FC9 16r6262 16r5FD6 16r6263 16r5FCF 16r6264 16r6003 16r6265 16r5FEE 16r6266 16r6004 16r6267 16r5FE1 16r6268 16r5FE4 16r6269 16r5FFE 16r626A 16r6005 16r626B 16r6006 16r626C 16r5FEA 16r626D 16r5FED 16r626E 16r5FF8 16r626F 16r6019 16r6270 16r6035 16r6271 16r6026 16r6272 16r601B 16r6273 16r600F 16r6274 16r600D 16r6275 16r6029 16r6276 16r602B 16r6277 16r600A 16r6278 16r603F 16r6279 16r6021 16r627A 16r6078 16r627B 16r6079 16r627C 16r607B 16r627D 16r607A 16r627E 16r6042 16r6321 16r606A 16r6322 16r607D 16r6323 16r6096 16r6324 16r609A 16r6325 16r60AD 16r6326 16r609D 16r6327 16r6083 16r6328 16r6092 16r6329 16r608C 16r632A 16r609B 16r632B 16r60EC 16r632C 16r60BB 16r632D 16r60B1 16r632E 16r60DD 16r632F 16r60D8 16r6330 16r60C6 16r6331 16r60DA 16r6332 16r60B4 16r6333 16r6120 16r6334 16r6126 16r6335 16r6115 16r6336 16r6123 16r6337 16r60F4 16r6338 16r6100 16r6339 16r610E 16r633A 16r612B 16r633B 16r614A 16r633C 16r6175 16r633D 16r61AC 16r633E 16r6194 16r633F 16r61A7 16r6340 16r61B7 16r6341 16r61D4 16r6342 16r61F5 16r6343 16r5FDD 16r6344 16r96B3 16r6345 16r95E9 16r6346 16r95EB 16r6347 16r95F1 16r6348 16r95F3 16r6349 16r95F5 16r634A 16r95F6 16r634B 16r95FC 16r634C 16r95FE 16r634D 16r9603 16r634E 16r9604 16r634F 16r9606 16r6350 16r9608 16r6351 16r960A 16r6352 16r960B 16r6353 16r960C 16r6354 16r960D 16r6355 16r960F 16r6356 16r9612 16r6357 16r9615 16r6358 16r9616 16r6359 16r9617 16r635A 16r9619 16r635B 16r961A 16r635C 16r4E2C 16r635D 16r723F 16r635E 16r6215 16r635F 16r6C35 16r6360 16r6C54 16r6361 16r6C5C 16r6362 16r6C4A 16r6363 16r6CA3 16r6364 16r6C85 16r6365 16r6C90 16r6366 16r6C94 16r6367 16r6C8C 16r6368 16r6C68 16r6369 16r6C69 16r636A 16r6C74 16r636B 16r6C76 16r636C 16r6C86 16r636D 16r6CA9 16r636E 16r6CD0 16r636F 16r6CD4 16r6370 16r6CAD 16r6371 16r6CF7 16r6372 16r6CF8 16r6373 16r6CF1 16r6374 16r6CD7 16r6375 16r6CB2 16r6376 16r6CE0 16r6377 16r6CD6 16r6378 16r6CFA 16r6379 16r6CEB 16r637A 16r6CEE 16r637B 16r6CB1 16r637C 16r6CD3 16r637D 16r6CEF 16r637E 16r6CFE 16r6421 16r6D39 16r6422 16r6D27 16r6423 16r6D0C 16r6424 16r6D43 16r6425 16r6D48 16r6426 16r6D07 16r6427 16r6D04 16r6428 16r6D19 16r6429 16r6D0E 16r642A 16r6D2B 16r642B 16r6D4D 16r642C 16r6D2E 16r642D 16r6D35 16r642E 16r6D1A 16r642F 16r6D4F 16r6430 16r6D52 16r6431 16r6D54 16r6432 16r6D33 16r6433 16r6D91 16r6434 16r6D6F 16r6435 16r6D9E 16r6436 16r6DA0 16r6437 16r6D5E 16r6438 16r6D93 16r6439 16r6D94 16r643A 16r6D5C 16r643B 16r6D60 16r643C 16r6D7C 16r643D 16r6D63 16r643E 16r6E1A 16r643F 16r6DC7 16r6440 16r6DC5 16r6441 16r6DDE 16r6442 16r6E0E 16r6443 16r6DBF 16r6444 16r6DE0 16r6445 16r6E11 16r6446 16r6DE6 16r6447 16r6DDD 16r6448 16r6DD9 16r6449 16r6E16 16r644A 16r6DAB 16r644B 16r6E0C 16r644C 16r6DAE 16r644D 16r6E2B 16r644E 16r6E6E 16r644F 16r6E4E 16r6450 16r6E6B 16r6451 16r6EB2 16r6452 16r6E5F 16r6453 16r6E86 16r6454 16r6E53 16r6455 16r6E54 16r6456 16r6E32 16r6457 16r6E25 16r6458 16r6E44 16r6459 16r6EDF 16r645A 16r6EB1 16r645B 16r6E98 16r645C 16r6EE0 16r645D 16r6F2D 16r645E 16r6EE2 16r645F 16r6EA5 16r6460 16r6EA7 16r6461 16r6EBD 16r6462 16r6EBB 16r6463 16r6EB7 16r6464 16r6ED7 16r6465 16r6EB4 16r6466 16r6ECF 16r6467 16r6E8F 16r6468 16r6EC2 16r6469 16r6E9F 16r646A 16r6F62 16r646B 16r6F46 16r646C 16r6F47 16r646D 16r6F24 16r646E 16r6F15 16r646F 16r6EF9 16r6470 16r6F2F 16r6471 16r6F36 16r6472 16r6F4B 16r6473 16r6F74 16r6474 16r6F2A 16r6475 16r6F09 16r6476 16r6F29 16r6477 16r6F89 16r6478 16r6F8D 16r6479 16r6F8C 16r647A 16r6F78 16r647B 16r6F72 16r647C 16r6F7C 16r647D 16r6F7A 16r647E 16r6FD1 16r6521 16r6FC9 16r6522 16r6FA7 16r6523 16r6FB9 16r6524 16r6FB6 16r6525 16r6FC2 16r6526 16r6FE1 16r6527 16r6FEE 16r6528 16r6FDE 16r6529 16r6FE0 16r652A 16r6FEF 16r652B 16r701A 16r652C 16r7023 16r652D 16r701B 16r652E 16r7039 16r652F 16r7035 16r6530 16r704F 16r6531 16r705E 16r6532 16r5B80 16r6533 16r5B84 16r6534 16r5B95 16r6535 16r5B93 16r6536 16r5BA5 16r6537 16r5BB8 16r6538 16r752F 16r6539 16r9A9E 16r653A 16r6434 16r653B 16r5BE4 16r653C 16r5BEE 16r653D 16r8930 16r653E 16r5BF0 16r653F 16r8E47 16r6540 16r8B07 16r6541 16r8FB6 16r6542 16r8FD3 16r6543 16r8FD5 16r6544 16r8FE5 16r6545 16r8FEE 16r6546 16r8FE4 16r6547 16r8FE9 16r6548 16r8FE6 16r6549 16r8FF3 16r654A 16r8FE8 16r654B 16r9005 16r654C 16r9004 16r654D 16r900B 16r654E 16r9026 16r654F 16r9011 16r6550 16r900D 16r6551 16r9016 16r6552 16r9021 16r6553 16r9035 16r6554 16r9036 16r6555 16r902D 16r6556 16r902F 16r6557 16r9044 16r6558 16r9051 16r6559 16r9052 16r655A 16r9050 16r655B 16r9068 16r655C 16r9058 16r655D 16r9062 16r655E 16r905B 16r655F 16r66B9 16r6560 16r9074 16r6561 16r907D 16r6562 16r9082 16r6563 16r9088 16r6564 16r9083 16r6565 16r908B 16r6566 16r5F50 16r6567 16r5F57 16r6568 16r5F56 16r6569 16r5F58 16r656A 16r5C3B 16r656B 16r54AB 16r656C 16r5C50 16r656D 16r5C59 16r656E 16r5B71 16r656F 16r5C63 16r6570 16r5C66 16r6571 16r7FBC 16r6572 16r5F2A 16r6573 16r5F29 16r6574 16r5F2D 16r6575 16r8274 16r6576 16r5F3C 16r6577 16r9B3B 16r6578 16r5C6E 16r6579 16r5981 16r657A 16r5983 16r657B 16r598D 16r657C 16r59A9 16r657D 16r59AA 16r657E 16r59A3 16r6621 16r5997 16r6622 16r59CA 16r6623 16r59AB 16r6624 16r599E 16r6625 16r59A4 16r6626 16r59D2 16r6627 16r59B2 16r6628 16r59AF 16r6629 16r59D7 16r662A 16r59BE 16r662B 16r5A05 16r662C 16r5A06 16r662D 16r59DD 16r662E 16r5A08 16r662F 16r59E3 16r6630 16r59D8 16r6631 16r59F9 16r6632 16r5A0C 16r6633 16r5A09 16r6634 16r5A32 16r6635 16r5A34 16r6636 16r5A11 16r6637 16r5A23 16r6638 16r5A13 16r6639 16r5A40 16r663A 16r5A67 16r663B 16r5A4A 16r663C 16r5A55 16r663D 16r5A3C 16r663E 16r5A62 16r663F 16r5A75 16r6640 16r80EC 16r6641 16r5AAA 16r6642 16r5A9B 16r6643 16r5A77 16r6644 16r5A7A 16r6645 16r5ABE 16r6646 16r5AEB 16r6647 16r5AB2 16r6648 16r5AD2 16r6649 16r5AD4 16r664A 16r5AB8 16r664B 16r5AE0 16r664C 16r5AE3 16r664D 16r5AF1 16r664E 16r5AD6 16r664F 16r5AE6 16r6650 16r5AD8 16r6651 16r5ADC 16r6652 16r5B09 16r6653 16r5B17 16r6654 16r5B16 16r6655 16r5B32 16r6656 16r5B37 16r6657 16r5B40 16r6658 16r5C15 16r6659 16r5C1C 16r665A 16r5B5A 16r665B 16r5B65 16r665C 16r5B73 16r665D 16r5B51 16r665E 16r5B53 16r665F 16r5B62 16r6660 16r9A75 16r6661 16r9A77 16r6662 16r9A78 16r6663 16r9A7A 16r6664 16r9A7F 16r6665 16r9A7D 16r6666 16r9A80 16r6667 16r9A81 16r6668 16r9A85 16r6669 16r9A88 16r666A 16r9A8A 16r666B 16r9A90 16r666C 16r9A92 16r666D 16r9A93 16r666E 16r9A96 16r666F 16r9A98 16r6670 16r9A9B 16r6671 16r9A9C 16r6672 16r9A9D 16r6673 16r9A9F 16r6674 16r9AA0 16r6675 16r9AA2 16r6676 16r9AA3 16r6677 16r9AA5 16r6678 16r9AA7 16r6679 16r7E9F 16r667A 16r7EA1 16r667B 16r7EA3 16r667C 16r7EA5 16r667D 16r7EA8 16r667E 16r7EA9 16r6721 16r7EAD 16r6722 16r7EB0 16r6723 16r7EBE 16r6724 16r7EC0 16r6725 16r7EC1 16r6726 16r7EC2 16r6727 16r7EC9 16r6728 16r7ECB 16r6729 16r7ECC 16r672A 16r7ED0 16r672B 16r7ED4 16r672C 16r7ED7 16r672D 16r7EDB 16r672E 16r7EE0 16r672F 16r7EE1 16r6730 16r7EE8 16r6731 16r7EEB 16r6732 16r7EEE 16r6733 16r7EEF 16r6734 16r7EF1 16r6735 16r7EF2 16r6736 16r7F0D 16r6737 16r7EF6 16r6738 16r7EFA 16r6739 16r7EFB 16r673A 16r7EFE 16r673B 16r7F01 16r673C 16r7F02 16r673D 16r7F03 16r673E 16r7F07 16r673F 16r7F08 16r6740 16r7F0B 16r6741 16r7F0C 16r6742 16r7F0F 16r6743 16r7F11 16r6744 16r7F12 16r6745 16r7F17 16r6746 16r7F19 16r6747 16r7F1C 16r6748 16r7F1B 16r6749 16r7F1F 16r674A 16r7F21 16r674B 16r7F22 16r674C 16r7F23 16r674D 16r7F24 16r674E 16r7F25 16r674F 16r7F26 16r6750 16r7F27 16r6751 16r7F2A 16r6752 16r7F2B 16r6753 16r7F2C 16r6754 16r7F2D 16r6755 16r7F2F 16r6756 16r7F30 16r6757 16r7F31 16r6758 16r7F32 16r6759 16r7F33 16r675A 16r7F35 16r675B 16r5E7A 16r675C 16r757F 16r675D 16r5DDB 16r675E 16r753E 16r675F 16r9095 16r6760 16r738E 16r6761 16r7391 16r6762 16r73AE 16r6763 16r73A2 16r6764 16r739F 16r6765 16r73CF 16r6766 16r73C2 16r6767 16r73D1 16r6768 16r73B7 16r6769 16r73B3 16r676A 16r73C0 16r676B 16r73C9 16r676C 16r73C8 16r676D 16r73E5 16r676E 16r73D9 16r676F 16r987C 16r6770 16r740A 16r6771 16r73E9 16r6772 16r73E7 16r6773 16r73DE 16r6774 16r73BA 16r6775 16r73F2 16r6776 16r740F 16r6777 16r742A 16r6778 16r745B 16r6779 16r7426 16r677A 16r7425 16r677B 16r7428 16r677C 16r7430 16r677D 16r742E 16r677E 16r742C 16r6821 16r741B 16r6822 16r741A 16r6823 16r7441 16r6824 16r745C 16r6825 16r7457 16r6826 16r7455 16r6827 16r7459 16r6828 16r7477 16r6829 16r746D 16r682A 16r747E 16r682B 16r749C 16r682C 16r748E 16r682D 16r7480 16r682E 16r7481 16r682F 16r7487 16r6830 16r748B 16r6831 16r749E 16r6832 16r74A8 16r6833 16r74A9 16r6834 16r7490 16r6835 16r74A7 16r6836 16r74D2 16r6837 16r74BA 16r6838 16r97EA 16r6839 16r97EB 16r683A 16r97EC 16r683B 16r674C 16r683C 16r6753 16r683D 16r675E 16r683E 16r6748 16r683F 16r6769 16r6840 16r67A5 16r6841 16r6787 16r6842 16r676A 16r6843 16r6773 16r6844 16r6798 16r6845 16r67A7 16r6846 16r6775 16r6847 16r67A8 16r6848 16r679E 16r6849 16r67AD 16r684A 16r678B 16r684B 16r6777 16r684C 16r677C 16r684D 16r67F0 16r684E 16r6809 16r684F 16r67D8 16r6850 16r680A 16r6851 16r67E9 16r6852 16r67B0 16r6853 16r680C 16r6854 16r67D9 16r6855 16r67B5 16r6856 16r67DA 16r6857 16r67B3 16r6858 16r67DD 16r6859 16r6800 16r685A 16r67C3 16r685B 16r67B8 16r685C 16r67E2 16r685D 16r680E 16r685E 16r67C1 16r685F 16r67FD 16r6860 16r6832 16r6861 16r6833 16r6862 16r6860 16r6863 16r6861 16r6864 16r684E 16r6865 16r6862 16r6866 16r6844 16r6867 16r6864 16r6868 16r6883 16r6869 16r681D 16r686A 16r6855 16r686B 16r6866 16r686C 16r6841 16r686D 16r6867 16r686E 16r6840 16r686F 16r683E 16r6870 16r684A 16r6871 16r6849 16r6872 16r6829 16r6873 16r68B5 16r6874 16r688F 16r6875 16r6874 16r6876 16r6877 16r6877 16r6893 16r6878 16r686B 16r6879 16r68C2 16r687A 16r696E 16r687B 16r68FC 16r687C 16r691F 16r687D 16r6920 16r687E 16r68F9 16r6921 16r6924 16r6922 16r68F0 16r6923 16r690B 16r6924 16r6901 16r6925 16r6957 16r6926 16r68E3 16r6927 16r6910 16r6928 16r6971 16r6929 16r6939 16r692A 16r6960 16r692B 16r6942 16r692C 16r695D 16r692D 16r6984 16r692E 16r696B 16r692F 16r6980 16r6930 16r6998 16r6931 16r6978 16r6932 16r6934 16r6933 16r69CC 16r6934 16r6987 16r6935 16r6988 16r6936 16r69CE 16r6937 16r6989 16r6938 16r6966 16r6939 16r6963 16r693A 16r6979 16r693B 16r699B 16r693C 16r69A7 16r693D 16r69BB 16r693E 16r69AB 16r693F 16r69AD 16r6940 16r69D4 16r6941 16r69B1 16r6942 16r69C1 16r6943 16r69CA 16r6944 16r69DF 16r6945 16r6995 16r6946 16r69E0 16r6947 16r698D 16r6948 16r69FF 16r6949 16r6A2F 16r694A 16r69ED 16r694B 16r6A17 16r694C 16r6A18 16r694D 16r6A65 16r694E 16r69F2 16r694F 16r6A44 16r6950 16r6A3E 16r6951 16r6AA0 16r6952 16r6A50 16r6953 16r6A5B 16r6954 16r6A35 16r6955 16r6A8E 16r6956 16r6A79 16r6957 16r6A3D 16r6958 16r6A28 16r6959 16r6A58 16r695A 16r6A7C 16r695B 16r6A91 16r695C 16r6A90 16r695D 16r6AA9 16r695E 16r6A97 16r695F 16r6AAB 16r6960 16r7337 16r6961 16r7352 16r6962 16r6B81 16r6963 16r6B82 16r6964 16r6B87 16r6965 16r6B84 16r6966 16r6B92 16r6967 16r6B93 16r6968 16r6B8D 16r6969 16r6B9A 16r696A 16r6B9B 16r696B 16r6BA1 16r696C 16r6BAA 16r696D 16r8F6B 16r696E 16r8F6D 16r696F 16r8F71 16r6970 16r8F72 16r6971 16r8F73 16r6972 16r8F75 16r6973 16r8F76 16r6974 16r8F78 16r6975 16r8F77 16r6976 16r8F79 16r6977 16r8F7A 16r6978 16r8F7C 16r6979 16r8F7E 16r697A 16r8F81 16r697B 16r8F82 16r697C 16r8F84 16r697D 16r8F87 16r697E 16r8F8B 16r6A21 16r8F8D 16r6A22 16r8F8E 16r6A23 16r8F8F 16r6A24 16r8F98 16r6A25 16r8F9A 16r6A26 16r8ECE 16r6A27 16r620B 16r6A28 16r6217 16r6A29 16r621B 16r6A2A 16r621F 16r6A2B 16r6222 16r6A2C 16r6221 16r6A2D 16r6225 16r6A2E 16r6224 16r6A2F 16r622C 16r6A30 16r81E7 16r6A31 16r74EF 16r6A32 16r74F4 16r6A33 16r74FF 16r6A34 16r750F 16r6A35 16r7511 16r6A36 16r7513 16r6A37 16r6534 16r6A38 16r65EE 16r6A39 16r65EF 16r6A3A 16r65F0 16r6A3B 16r660A 16r6A3C 16r6619 16r6A3D 16r6772 16r6A3E 16r6603 16r6A3F 16r6615 16r6A40 16r6600 16r6A41 16r7085 16r6A42 16r66F7 16r6A43 16r661D 16r6A44 16r6634 16r6A45 16r6631 16r6A46 16r6636 16r6A47 16r6635 16r6A48 16r8006 16r6A49 16r665F 16r6A4A 16r6654 16r6A4B 16r6641 16r6A4C 16r664F 16r6A4D 16r6656 16r6A4E 16r6661 16r6A4F 16r6657 16r6A50 16r6677 16r6A51 16r6684 16r6A52 16r668C 16r6A53 16r66A7 16r6A54 16r669D 16r6A55 16r66BE 16r6A56 16r66DB 16r6A57 16r66DC 16r6A58 16r66E6 16r6A59 16r66E9 16r6A5A 16r8D32 16r6A5B 16r8D33 16r6A5C 16r8D36 16r6A5D 16r8D3B 16r6A5E 16r8D3D 16r6A5F 16r8D40 16r6A60 16r8D45 16r6A61 16r8D46 16r6A62 16r8D48 16r6A63 16r8D49 16r6A64 16r8D47 16r6A65 16r8D4D 16r6A66 16r8D55 16r6A67 16r8D59 16r6A68 16r89C7 16r6A69 16r89CA 16r6A6A 16r89CB 16r6A6B 16r89CC 16r6A6C 16r89CE 16r6A6D 16r89CF 16r6A6E 16r89D0 16r6A6F 16r89D1 16r6A70 16r726E 16r6A71 16r729F 16r6A72 16r725D 16r6A73 16r7266 16r6A74 16r726F 16r6A75 16r727E 16r6A76 16r727F 16r6A77 16r7284 16r6A78 16r728B 16r6A79 16r728D 16r6A7A 16r728F 16r6A7B 16r7292 16r6A7C 16r6308 16r6A7D 16r6332 16r6A7E 16r63B0 16r6B21 16r643F 16r6B22 16r64D8 16r6B23 16r8004 16r6B24 16r6BEA 16r6B25 16r6BF3 16r6B26 16r6BFD 16r6B27 16r6BF5 16r6B28 16r6BF9 16r6B29 16r6C05 16r6B2A 16r6C07 16r6B2B 16r6C06 16r6B2C 16r6C0D 16r6B2D 16r6C15 16r6B2E 16r6C18 16r6B2F 16r6C19 16r6B30 16r6C1A 16r6B31 16r6C21 16r6B32 16r6C29 16r6B33 16r6C24 16r6B34 16r6C2A 16r6B35 16r6C32 16r6B36 16r6535 16r6B37 16r6555 16r6B38 16r656B 16r6B39 16r724D 16r6B3A 16r7252 16r6B3B 16r7256 16r6B3C 16r7230 16r6B3D 16r8662 16r6B3E 16r5216 16r6B3F 16r809F 16r6B40 16r809C 16r6B41 16r8093 16r6B42 16r80BC 16r6B43 16r670A 16r6B44 16r80BD 16r6B45 16r80B1 16r6B46 16r80AB 16r6B47 16r80AD 16r6B48 16r80B4 16r6B49 16r80B7 16r6B4A 16r80E7 16r6B4B 16r80E8 16r6B4C 16r80E9 16r6B4D 16r80EA 16r6B4E 16r80DB 16r6B4F 16r80C2 16r6B50 16r80C4 16r6B51 16r80D9 16r6B52 16r80CD 16r6B53 16r80D7 16r6B54 16r6710 16r6B55 16r80DD 16r6B56 16r80EB 16r6B57 16r80F1 16r6B58 16r80F4 16r6B59 16r80ED 16r6B5A 16r810D 16r6B5B 16r810E 16r6B5C 16r80F2 16r6B5D 16r80FC 16r6B5E 16r6715 16r6B5F 16r8112 16r6B60 16r8C5A 16r6B61 16r8136 16r6B62 16r811E 16r6B63 16r812C 16r6B64 16r8118 16r6B65 16r8132 16r6B66 16r8148 16r6B67 16r814C 16r6B68 16r8153 16r6B69 16r8174 16r6B6A 16r8159 16r6B6B 16r815A 16r6B6C 16r8171 16r6B6D 16r8160 16r6B6E 16r8169 16r6B6F 16r817C 16r6B70 16r817D 16r6B71 16r816D 16r6B72 16r8167 16r6B73 16r584D 16r6B74 16r5AB5 16r6B75 16r8188 16r6B76 16r8182 16r6B77 16r8191 16r6B78 16r6ED5 16r6B79 16r81A3 16r6B7A 16r81AA 16r6B7B 16r81CC 16r6B7C 16r6726 16r6B7D 16r81CA 16r6B7E 16r81BB 16r6C21 16r81C1 16r6C22 16r81A6 16r6C23 16r6B24 16r6C24 16r6B37 16r6C25 16r6B39 16r6C26 16r6B43 16r6C27 16r6B46 16r6C28 16r6B59 16r6C29 16r98D1 16r6C2A 16r98D2 16r6C2B 16r98D3 16r6C2C 16r98D5 16r6C2D 16r98D9 16r6C2E 16r98DA 16r6C2F 16r6BB3 16r6C30 16r5F40 16r6C31 16r6BC2 16r6C32 16r89F3 16r6C33 16r6590 16r6C34 16r9F51 16r6C35 16r6593 16r6C36 16r65BC 16r6C37 16r65C6 16r6C38 16r65C4 16r6C39 16r65C3 16r6C3A 16r65CC 16r6C3B 16r65CE 16r6C3C 16r65D2 16r6C3D 16r65D6 16r6C3E 16r7080 16r6C3F 16r709C 16r6C40 16r7096 16r6C41 16r709D 16r6C42 16r70BB 16r6C43 16r70C0 16r6C44 16r70B7 16r6C45 16r70AB 16r6C46 16r70B1 16r6C47 16r70E8 16r6C48 16r70CA 16r6C49 16r7110 16r6C4A 16r7113 16r6C4B 16r7116 16r6C4C 16r712F 16r6C4D 16r7131 16r6C4E 16r7173 16r6C4F 16r715C 16r6C50 16r7168 16r6C51 16r7145 16r6C52 16r7172 16r6C53 16r714A 16r6C54 16r7178 16r6C55 16r717A 16r6C56 16r7198 16r6C57 16r71B3 16r6C58 16r71B5 16r6C59 16r71A8 16r6C5A 16r71A0 16r6C5B 16r71E0 16r6C5C 16r71D4 16r6C5D 16r71E7 16r6C5E 16r71F9 16r6C5F 16r721D 16r6C60 16r7228 16r6C61 16r706C 16r6C62 16r7118 16r6C63 16r7166 16r6C64 16r71B9 16r6C65 16r623E 16r6C66 16r623D 16r6C67 16r6243 16r6C68 16r6248 16r6C69 16r6249 16r6C6A 16r793B 16r6C6B 16r7940 16r6C6C 16r7946 16r6C6D 16r7949 16r6C6E 16r795B 16r6C6F 16r795C 16r6C70 16r7953 16r6C71 16r795A 16r6C72 16r7962 16r6C73 16r7957 16r6C74 16r7960 16r6C75 16r796F 16r6C76 16r7967 16r6C77 16r797A 16r6C78 16r7985 16r6C79 16r798A 16r6C7A 16r799A 16r6C7B 16r79A7 16r6C7C 16r79B3 16r6C7D 16r5FD1 16r6C7E 16r5FD0 16r6D21 16r603C 16r6D22 16r605D 16r6D23 16r605A 16r6D24 16r6067 16r6D25 16r6041 16r6D26 16r6059 16r6D27 16r6063 16r6D28 16r60AB 16r6D29 16r6106 16r6D2A 16r610D 16r6D2B 16r615D 16r6D2C 16r61A9 16r6D2D 16r619D 16r6D2E 16r61CB 16r6D2F 16r61D1 16r6D30 16r6206 16r6D31 16r8080 16r6D32 16r807F 16r6D33 16r6C93 16r6D34 16r6CF6 16r6D35 16r6DFC 16r6D36 16r77F6 16r6D37 16r77F8 16r6D38 16r7800 16r6D39 16r7809 16r6D3A 16r7817 16r6D3B 16r7818 16r6D3C 16r7811 16r6D3D 16r65AB 16r6D3E 16r782D 16r6D3F 16r781C 16r6D40 16r781D 16r6D41 16r7839 16r6D42 16r783A 16r6D43 16r783B 16r6D44 16r781F 16r6D45 16r783C 16r6D46 16r7825 16r6D47 16r782C 16r6D48 16r7823 16r6D49 16r7829 16r6D4A 16r784E 16r6D4B 16r786D 16r6D4C 16r7856 16r6D4D 16r7857 16r6D4E 16r7826 16r6D4F 16r7850 16r6D50 16r7847 16r6D51 16r784C 16r6D52 16r786A 16r6D53 16r789B 16r6D54 16r7893 16r6D55 16r789A 16r6D56 16r7887 16r6D57 16r789C 16r6D58 16r78A1 16r6D59 16r78A3 16r6D5A 16r78B2 16r6D5B 16r78B9 16r6D5C 16r78A5 16r6D5D 16r78D4 16r6D5E 16r78D9 16r6D5F 16r78C9 16r6D60 16r78EC 16r6D61 16r78F2 16r6D62 16r7905 16r6D63 16r78F4 16r6D64 16r7913 16r6D65 16r7924 16r6D66 16r791E 16r6D67 16r7934 16r6D68 16r9F9B 16r6D69 16r9EF9 16r6D6A 16r9EFB 16r6D6B 16r9EFC 16r6D6C 16r76F1 16r6D6D 16r7704 16r6D6E 16r770D 16r6D6F 16r76F9 16r6D70 16r7707 16r6D71 16r7708 16r6D72 16r771A 16r6D73 16r7722 16r6D74 16r7719 16r6D75 16r772D 16r6D76 16r7726 16r6D77 16r7735 16r6D78 16r7738 16r6D79 16r7750 16r6D7A 16r7751 16r6D7B 16r7747 16r6D7C 16r7743 16r6D7D 16r775A 16r6D7E 16r7768 16r6E21 16r7762 16r6E22 16r7765 16r6E23 16r777F 16r6E24 16r778D 16r6E25 16r777D 16r6E26 16r7780 16r6E27 16r778C 16r6E28 16r7791 16r6E29 16r779F 16r6E2A 16r77A0 16r6E2B 16r77B0 16r6E2C 16r77B5 16r6E2D 16r77BD 16r6E2E 16r753A 16r6E2F 16r7540 16r6E30 16r754E 16r6E31 16r754B 16r6E32 16r7548 16r6E33 16r755B 16r6E34 16r7572 16r6E35 16r7579 16r6E36 16r7583 16r6E37 16r7F58 16r6E38 16r7F61 16r6E39 16r7F5F 16r6E3A 16r8A48 16r6E3B 16r7F68 16r6E3C 16r7F74 16r6E3D 16r7F71 16r6E3E 16r7F79 16r6E3F 16r7F81 16r6E40 16r7F7E 16r6E41 16r76CD 16r6E42 16r76E5 16r6E43 16r8832 16r6E44 16r9485 16r6E45 16r9486 16r6E46 16r9487 16r6E47 16r948B 16r6E48 16r948A 16r6E49 16r948C 16r6E4A 16r948D 16r6E4B 16r948F 16r6E4C 16r9490 16r6E4D 16r9494 16r6E4E 16r9497 16r6E4F 16r9495 16r6E50 16r949A 16r6E51 16r949B 16r6E52 16r949C 16r6E53 16r94A3 16r6E54 16r94A4 16r6E55 16r94AB 16r6E56 16r94AA 16r6E57 16r94AD 16r6E58 16r94AC 16r6E59 16r94AF 16r6E5A 16r94B0 16r6E5B 16r94B2 16r6E5C 16r94B4 16r6E5D 16r94B6 16r6E5E 16r94B7 16r6E5F 16r94B8 16r6E60 16r94B9 16r6E61 16r94BA 16r6E62 16r94BC 16r6E63 16r94BD 16r6E64 16r94BF 16r6E65 16r94C4 16r6E66 16r94C8 16r6E67 16r94C9 16r6E68 16r94CA 16r6E69 16r94CB 16r6E6A 16r94CC 16r6E6B 16r94CD 16r6E6C 16r94CE 16r6E6D 16r94D0 16r6E6E 16r94D1 16r6E6F 16r94D2 16r6E70 16r94D5 16r6E71 16r94D6 16r6E72 16r94D7 16r6E73 16r94D9 16r6E74 16r94D8 16r6E75 16r94DB 16r6E76 16r94DE 16r6E77 16r94DF 16r6E78 16r94E0 16r6E79 16r94E2 16r6E7A 16r94E4 16r6E7B 16r94E5 16r6E7C 16r94E7 16r6E7D 16r94E8 16r6E7E 16r94EA 16r6F21 16r94E9 16r6F22 16r94EB 16r6F23 16r94EE 16r6F24 16r94EF 16r6F25 16r94F3 16r6F26 16r94F4 16r6F27 16r94F5 16r6F28 16r94F7 16r6F29 16r94F9 16r6F2A 16r94FC 16r6F2B 16r94FD 16r6F2C 16r94FF 16r6F2D 16r9503 16r6F2E 16r9502 16r6F2F 16r9506 16r6F30 16r9507 16r6F31 16r9509 16r6F32 16r950A 16r6F33 16r950D 16r6F34 16r950E 16r6F35 16r950F 16r6F36 16r9512 16r6F37 16r9513 16r6F38 16r9514 16r6F39 16r9515 16r6F3A 16r9516 16r6F3B 16r9518 16r6F3C 16r951B 16r6F3D 16r951D 16r6F3E 16r951E 16r6F3F 16r951F 16r6F40 16r9522 16r6F41 16r952A 16r6F42 16r952B 16r6F43 16r9529 16r6F44 16r952C 16r6F45 16r9531 16r6F46 16r9532 16r6F47 16r9534 16r6F48 16r9536 16r6F49 16r9537 16r6F4A 16r9538 16r6F4B 16r953C 16r6F4C 16r953E 16r6F4D 16r953F 16r6F4E 16r9542 16r6F4F 16r9535 16r6F50 16r9544 16r6F51 16r9545 16r6F52 16r9546 16r6F53 16r9549 16r6F54 16r954C 16r6F55 16r954E 16r6F56 16r954F 16r6F57 16r9552 16r6F58 16r9553 16r6F59 16r9554 16r6F5A 16r9556 16r6F5B 16r9557 16r6F5C 16r9558 16r6F5D 16r9559 16r6F5E 16r955B 16r6F5F 16r955E 16r6F60 16r955F 16r6F61 16r955D 16r6F62 16r9561 16r6F63 16r9562 16r6F64 16r9564 16r6F65 16r9565 16r6F66 16r9566 16r6F67 16r9567 16r6F68 16r9568 16r6F69 16r9569 16r6F6A 16r956A 16r6F6B 16r956B 16r6F6C 16r956C 16r6F6D 16r956F 16r6F6E 16r9571 16r6F6F 16r9572 16r6F70 16r9573 16r6F71 16r953A 16r6F72 16r77E7 16r6F73 16r77EC 16r6F74 16r96C9 16r6F75 16r79D5 16r6F76 16r79ED 16r6F77 16r79E3 16r6F78 16r79EB 16r6F79 16r7A06 16r6F7A 16r5D47 16r6F7B 16r7A03 16r6F7C 16r7A02 16r6F7D 16r7A1E 16r6F7E 16r7A14 16r7021 16r7A39 16r7022 16r7A37 16r7023 16r7A51 16r7024 16r9ECF 16r7025 16r99A5 16r7026 16r7A70 16r7027 16r7688 16r7028 16r768E 16r7029 16r7693 16r702A 16r7699 16r702B 16r76A4 16r702C 16r74DE 16r702D 16r74E0 16r702E 16r752C 16r702F 16r9E20 16r7030 16r9E22 16r7031 16r9E28 16r7032 16r9E29 16r7033 16r9E2A 16r7034 16r9E2B 16r7035 16r9E2C 16r7036 16r9E32 16r7037 16r9E31 16r7038 16r9E36 16r7039 16r9E38 16r703A 16r9E37 16r703B 16r9E39 16r703C 16r9E3A 16r703D 16r9E3E 16r703E 16r9E41 16r703F 16r9E42 16r7040 16r9E44 16r7041 16r9E46 16r7042 16r9E47 16r7043 16r9E48 16r7044 16r9E49 16r7045 16r9E4B 16r7046 16r9E4C 16r7047 16r9E4E 16r7048 16r9E51 16r7049 16r9E55 16r704A 16r9E57 16r704B 16r9E5A 16r704C 16r9E5B 16r704D 16r9E5C 16r704E 16r9E5E 16r704F 16r9E63 16r7050 16r9E66 16r7051 16r9E67 16r7052 16r9E68 16r7053 16r9E69 16r7054 16r9E6A 16r7055 16r9E6B 16r7056 16r9E6C 16r7057 16r9E71 16r7058 16r9E6D 16r7059 16r9E73 16r705A 16r7592 16r705B 16r7594 16r705C 16r7596 16r705D 16r75A0 16r705E 16r759D 16r705F 16r75AC 16r7060 16r75A3 16r7061 16r75B3 16r7062 16r75B4 16r7063 16r75B8 16r7064 16r75C4 16r7065 16r75B1 16r7066 16r75B0 16r7067 16r75C3 16r7068 16r75C2 16r7069 16r75D6 16r706A 16r75CD 16r706B 16r75E3 16r706C 16r75E8 16r706D 16r75E6 16r706E 16r75E4 16r706F 16r75EB 16r7070 16r75E7 16r7071 16r7603 16r7072 16r75F1 16r7073 16r75FC 16r7074 16r75FF 16r7075 16r7610 16r7076 16r7600 16r7077 16r7605 16r7078 16r760C 16r7079 16r7617 16r707A 16r760A 16r707B 16r7625 16r707C 16r7618 16r707D 16r7615 16r707E 16r7619 16r7121 16r761B 16r7122 16r763C 16r7123 16r7622 16r7124 16r7620 16r7125 16r7640 16r7126 16r762D 16r7127 16r7630 16r7128 16r763F 16r7129 16r7635 16r712A 16r7643 16r712B 16r763E 16r712C 16r7633 16r712D 16r764D 16r712E 16r765E 16r712F 16r7654 16r7130 16r765C 16r7131 16r7656 16r7132 16r766B 16r7133 16r766F 16r7134 16r7FCA 16r7135 16r7AE6 16r7136 16r7A78 16r7137 16r7A79 16r7138 16r7A80 16r7139 16r7A86 16r713A 16r7A88 16r713B 16r7A95 16r713C 16r7AA6 16r713D 16r7AA0 16r713E 16r7AAC 16r713F 16r7AA8 16r7140 16r7AAD 16r7141 16r7AB3 16r7142 16r8864 16r7143 16r8869 16r7144 16r8872 16r7145 16r887D 16r7146 16r887F 16r7147 16r8882 16r7148 16r88A2 16r7149 16r88C6 16r714A 16r88B7 16r714B 16r88BC 16r714C 16r88C9 16r714D 16r88E2 16r714E 16r88CE 16r714F 16r88E3 16r7150 16r88E5 16r7151 16r88F1 16r7152 16r891A 16r7153 16r88FC 16r7154 16r88E8 16r7155 16r88FE 16r7156 16r88F0 16r7157 16r8921 16r7158 16r8919 16r7159 16r8913 16r715A 16r891B 16r715B 16r890A 16r715C 16r8934 16r715D 16r892B 16r715E 16r8936 16r715F 16r8941 16r7160 16r8966 16r7161 16r897B 16r7162 16r758B 16r7163 16r80E5 16r7164 16r76B2 16r7165 16r76B4 16r7166 16r77DC 16r7167 16r8012 16r7168 16r8014 16r7169 16r8016 16r716A 16r801C 16r716B 16r8020 16r716C 16r8022 16r716D 16r8025 16r716E 16r8026 16r716F 16r8027 16r7170 16r8029 16r7171 16r8028 16r7172 16r8031 16r7173 16r800B 16r7174 16r8035 16r7175 16r8043 16r7176 16r8046 16r7177 16r804D 16r7178 16r8052 16r7179 16r8069 16r717A 16r8071 16r717B 16r8983 16r717C 16r9878 16r717D 16r9880 16r717E 16r9883 16r7221 16r9889 16r7222 16r988C 16r7223 16r988D 16r7224 16r988F 16r7225 16r9894 16r7226 16r989A 16r7227 16r989B 16r7228 16r989E 16r7229 16r989F 16r722A 16r98A1 16r722B 16r98A2 16r722C 16r98A5 16r722D 16r98A6 16r722E 16r864D 16r722F 16r8654 16r7230 16r866C 16r7231 16r866E 16r7232 16r867F 16r7233 16r867A 16r7234 16r867C 16r7235 16r867B 16r7236 16r86A8 16r7237 16r868D 16r7238 16r868B 16r7239 16r86AC 16r723A 16r869D 16r723B 16r86A7 16r723C 16r86A3 16r723D 16r86AA 16r723E 16r8693 16r723F 16r86A9 16r7240 16r86B6 16r7241 16r86C4 16r7242 16r86B5 16r7243 16r86CE 16r7244 16r86B0 16r7245 16r86BA 16r7246 16r86B1 16r7247 16r86AF 16r7248 16r86C9 16r7249 16r86CF 16r724A 16r86B4 16r724B 16r86E9 16r724C 16r86F1 16r724D 16r86F2 16r724E 16r86ED 16r724F 16r86F3 16r7250 16r86D0 16r7251 16r8713 16r7252 16r86DE 16r7253 16r86F4 16r7254 16r86DF 16r7255 16r86D8 16r7256 16r86D1 16r7257 16r8703 16r7258 16r8707 16r7259 16r86F8 16r725A 16r8708 16r725B 16r870A 16r725C 16r870D 16r725D 16r8709 16r725E 16r8723 16r725F 16r873B 16r7260 16r871E 16r7261 16r8725 16r7262 16r872E 16r7263 16r871A 16r7264 16r873E 16r7265 16r8748 16r7266 16r8734 16r7267 16r8731 16r7268 16r8729 16r7269 16r8737 16r726A 16r873F 16r726B 16r8782 16r726C 16r8722 16r726D 16r877D 16r726E 16r877E 16r726F 16r877B 16r7270 16r8760 16r7271 16r8770 16r7272 16r874C 16r7273 16r876E 16r7274 16r878B 16r7275 16r8753 16r7276 16r8763 16r7277 16r877C 16r7278 16r8764 16r7279 16r8759 16r727A 16r8765 16r727B 16r8793 16r727C 16r87AF 16r727D 16r87A8 16r727E 16r87D2 16r7321 16r87C6 16r7322 16r8788 16r7323 16r8785 16r7324 16r87AD 16r7325 16r8797 16r7326 16r8783 16r7327 16r87AB 16r7328 16r87E5 16r7329 16r87AC 16r732A 16r87B5 16r732B 16r87B3 16r732C 16r87CB 16r732D 16r87D3 16r732E 16r87BD 16r732F 16r87D1 16r7330 16r87C0 16r7331 16r87CA 16r7332 16r87DB 16r7333 16r87EA 16r7334 16r87E0 16r7335 16r87EE 16r7336 16r8816 16r7337 16r8813 16r7338 16r87FE 16r7339 16r880A 16r733A 16r881B 16r733B 16r8821 16r733C 16r8839 16r733D 16r883C 16r733E 16r7F36 16r733F 16r7F42 16r7340 16r7F44 16r7341 16r7F45 16r7342 16r8210 16r7343 16r7AFA 16r7344 16r7AFD 16r7345 16r7B08 16r7346 16r7B03 16r7347 16r7B04 16r7348 16r7B15 16r7349 16r7B0A 16r734A 16r7B2B 16r734B 16r7B0F 16r734C 16r7B47 16r734D 16r7B38 16r734E 16r7B2A 16r734F 16r7B19 16r7350 16r7B2E 16r7351 16r7B31 16r7352 16r7B20 16r7353 16r7B25 16r7354 16r7B24 16r7355 16r7B33 16r7356 16r7B3E 16r7357 16r7B1E 16r7358 16r7B58 16r7359 16r7B5A 16r735A 16r7B45 16r735B 16r7B75 16r735C 16r7B4C 16r735D 16r7B5D 16r735E 16r7B60 16r735F 16r7B6E 16r7360 16r7B7B 16r7361 16r7B62 16r7362 16r7B72 16r7363 16r7B71 16r7364 16r7B90 16r7365 16r7BA6 16r7366 16r7BA7 16r7367 16r7BB8 16r7368 16r7BAC 16r7369 16r7B9D 16r736A 16r7BA8 16r736B 16r7B85 16r736C 16r7BAA 16r736D 16r7B9C 16r736E 16r7BA2 16r736F 16r7BAB 16r7370 16r7BB4 16r7371 16r7BD1 16r7372 16r7BC1 16r7373 16r7BCC 16r7374 16r7BDD 16r7375 16r7BDA 16r7376 16r7BE5 16r7377 16r7BE6 16r7378 16r7BEA 16r7379 16r7C0C 16r737A 16r7BFE 16r737B 16r7BFC 16r737C 16r7C0F 16r737D 16r7C16 16r737E 16r7C0B 16r7421 16r7C1F 16r7422 16r7C2A 16r7423 16r7C26 16r7424 16r7C38 16r7425 16r7C41 16r7426 16r7C40 16r7427 16r81FE 16r7428 16r8201 16r7429 16r8202 16r742A 16r8204 16r742B 16r81EC 16r742C 16r8844 16r742D 16r8221 16r742E 16r8222 16r742F 16r8223 16r7430 16r822D 16r7431 16r822F 16r7432 16r8228 16r7433 16r822B 16r7434 16r8238 16r7435 16r823B 16r7436 16r8233 16r7437 16r8234 16r7438 16r823E 16r7439 16r8244 16r743A 16r8249 16r743B 16r824B 16r743C 16r824F 16r743D 16r825A 16r743E 16r825F 16r743F 16r8268 16r7440 16r887E 16r7441 16r8885 16r7442 16r8888 16r7443 16r88D8 16r7444 16r88DF 16r7445 16r895E 16r7446 16r7F9D 16r7447 16r7F9F 16r7448 16r7FA7 16r7449 16r7FAF 16r744A 16r7FB0 16r744B 16r7FB2 16r744C 16r7C7C 16r744D 16r6549 16r744E 16r7C91 16r744F 16r7C9D 16r7450 16r7C9C 16r7451 16r7C9E 16r7452 16r7CA2 16r7453 16r7CB2 16r7454 16r7CBC 16r7455 16r7CBD 16r7456 16r7CC1 16r7457 16r7CC7 16r7458 16r7CCC 16r7459 16r7CCD 16r745A 16r7CC8 16r745B 16r7CC5 16r745C 16r7CD7 16r745D 16r7CE8 16r745E 16r826E 16r745F 16r66A8 16r7460 16r7FBF 16r7461 16r7FCE 16r7462 16r7FD5 16r7463 16r7FE5 16r7464 16r7FE1 16r7465 16r7FE6 16r7466 16r7FE9 16r7467 16r7FEE 16r7468 16r7FF3 16r7469 16r7CF8 16r746A 16r7D77 16r746B 16r7DA6 16r746C 16r7DAE 16r746D 16r7E47 16r746E 16r7E9B 16r746F 16r9EB8 16r7470 16r9EB4 16r7471 16r8D73 16r7472 16r8D84 16r7473 16r8D94 16r7474 16r8D91 16r7475 16r8DB1 16r7476 16r8D67 16r7477 16r8D6D 16r7478 16r8C47 16r7479 16r8C49 16r747A 16r914A 16r747B 16r9150 16r747C 16r914E 16r747D 16r914F 16r747E 16r9164 16r7521 16r9162 16r7522 16r9161 16r7523 16r9170 16r7524 16r9169 16r7525 16r916F 16r7526 16r917D 16r7527 16r917E 16r7528 16r9172 16r7529 16r9174 16r752A 16r9179 16r752B 16r918C 16r752C 16r9185 16r752D 16r9190 16r752E 16r918D 16r752F 16r9191 16r7530 16r91A2 16r7531 16r91A3 16r7532 16r91AA 16r7533 16r91AD 16r7534 16r91AE 16r7535 16r91AF 16r7536 16r91B5 16r7537 16r91B4 16r7538 16r91BA 16r7539 16r8C55 16r753A 16r9E7E 16r753B 16r8DB8 16r753C 16r8DEB 16r753D 16r8E05 16r753E 16r8E59 16r753F 16r8E69 16r7540 16r8DB5 16r7541 16r8DBF 16r7542 16r8DBC 16r7543 16r8DBA 16r7544 16r8DC4 16r7545 16r8DD6 16r7546 16r8DD7 16r7547 16r8DDA 16r7548 16r8DDE 16r7549 16r8DCE 16r754A 16r8DCF 16r754B 16r8DDB 16r754C 16r8DC6 16r754D 16r8DEC 16r754E 16r8DF7 16r754F 16r8DF8 16r7550 16r8DE3 16r7551 16r8DF9 16r7552 16r8DFB 16r7553 16r8DE4 16r7554 16r8E09 16r7555 16r8DFD 16r7556 16r8E14 16r7557 16r8E1D 16r7558 16r8E1F 16r7559 16r8E2C 16r755A 16r8E2E 16r755B 16r8E23 16r755C 16r8E2F 16r755D 16r8E3A 16r755E 16r8E40 16r755F 16r8E39 16r7560 16r8E35 16r7561 16r8E3D 16r7562 16r8E31 16r7563 16r8E49 16r7564 16r8E41 16r7565 16r8E42 16r7566 16r8E51 16r7567 16r8E52 16r7568 16r8E4A 16r7569 16r8E70 16r756A 16r8E76 16r756B 16r8E7C 16r756C 16r8E6F 16r756D 16r8E74 16r756E 16r8E85 16r756F 16r8E8F 16r7570 16r8E94 16r7571 16r8E90 16r7572 16r8E9C 16r7573 16r8E9E 16r7574 16r8C78 16r7575 16r8C82 16r7576 16r8C8A 16r7577 16r8C85 16r7578 16r8C98 16r7579 16r8C94 16r757A 16r659B 16r757B 16r89D6 16r757C 16r89DE 16r757D 16r89DA 16r757E 16r89DC 16r7621 16r89E5 16r7622 16r89EB 16r7623 16r89EF 16r7624 16r8A3E 16r7625 16r8B26 16r7626 16r9753 16r7627 16r96E9 16r7628 16r96F3 16r7629 16r96EF 16r762A 16r9706 16r762B 16r9701 16r762C 16r9708 16r762D 16r970F 16r762E 16r970E 16r762F 16r972A 16r7630 16r972D 16r7631 16r9730 16r7632 16r973E 16r7633 16r9F80 16r7634 16r9F83 16r7635 16r9F85 16r7636 16r9F86 16r7637 16r9F87 16r7638 16r9F88 16r7639 16r9F89 16r763A 16r9F8A 16r763B 16r9F8C 16r763C 16r9EFE 16r763D 16r9F0B 16r763E 16r9F0D 16r763F 16r96B9 16r7640 16r96BC 16r7641 16r96BD 16r7642 16r96CE 16r7643 16r96D2 16r7644 16r77BF 16r7645 16r96E0 16r7646 16r928E 16r7647 16r92AE 16r7648 16r92C8 16r7649 16r933E 16r764A 16r936A 16r764B 16r93CA 16r764C 16r938F 16r764D 16r943E 16r764E 16r946B 16r764F 16r9C7F 16r7650 16r9C82 16r7651 16r9C85 16r7652 16r9C86 16r7653 16r9C87 16r7654 16r9C88 16r7655 16r7A23 16r7656 16r9C8B 16r7657 16r9C8E 16r7658 16r9C90 16r7659 16r9C91 16r765A 16r9C92 16r765B 16r9C94 16r765C 16r9C95 16r765D 16r9C9A 16r765E 16r9C9B 16r765F 16r9C9E 16r7660 16r9C9F 16r7661 16r9CA0 16r7662 16r9CA1 16r7663 16r9CA2 16r7664 16r9CA3 16r7665 16r9CA5 16r7666 16r9CA6 16r7667 16r9CA7 16r7668 16r9CA8 16r7669 16r9CA9 16r766A 16r9CAB 16r766B 16r9CAD 16r766C 16r9CAE 16r766D 16r9CB0 16r766E 16r9CB1 16r766F 16r9CB2 16r7670 16r9CB3 16r7671 16r9CB4 16r7672 16r9CB5 16r7673 16r9CB6 16r7674 16r9CB7 16r7675 16r9CBA 16r7676 16r9CBB 16r7677 16r9CBC 16r7678 16r9CBD 16r7679 16r9CC4 16r767A 16r9CC5 16r767B 16r9CC6 16r767C 16r9CC7 16r767D 16r9CCA 16r767E 16r9CCB 16r7721 16r9CCC 16r7722 16r9CCD 16r7723 16r9CCE 16r7724 16r9CCF 16r7725 16r9CD0 16r7726 16r9CD3 16r7727 16r9CD4 16r7728 16r9CD5 16r7729 16r9CD7 16r772A 16r9CD8 16r772B 16r9CD9 16r772C 16r9CDC 16r772D 16r9CDD 16r772E 16r9CDF 16r772F 16r9CE2 16r7730 16r977C 16r7731 16r9785 16r7732 16r9791 16r7733 16r9792 16r7734 16r9794 16r7735 16r97AF 16r7736 16r97AB 16r7737 16r97A3 16r7738 16r97B2 16r7739 16r97B4 16r773A 16r9AB1 16r773B 16r9AB0 16r773C 16r9AB7 16r773D 16r9E58 16r773E 16r9AB6 16r773F 16r9ABA 16r7740 16r9ABC 16r7741 16r9AC1 16r7742 16r9AC0 16r7743 16r9AC5 16r7744 16r9AC2 16r7745 16r9ACB 16r7746 16r9ACC 16r7747 16r9AD1 16r7748 16r9B45 16r7749 16r9B43 16r774A 16r9B47 16r774B 16r9B49 16r774C 16r9B48 16r774D 16r9B4D 16r774E 16r9B51 16r774F 16r98E8 16r7750 16r990D 16r7751 16r992E 16r7752 16r9955 16r7753 16r9954 16r7754 16r9ADF 16r7755 16r9AE1 16r7756 16r9AE6 16r7757 16r9AEF 16r7758 16r9AEB 16r7759 16r9AFB 16r775A 16r9AED 16r775B 16r9AF9 16r775C 16r9B08 16r775D 16r9B0F 16r775E 16r9B13 16r775F 16r9B1F 16r7760 16r9B23 16r7761 16r9EBD 16r7762 16r9EBE 16r7763 16r7E3B 16r7764 16r9E82 16r7765 16r9E87 16r7766 16r9E88 16r7767 16r9E8B 16r7768 16r9E92 16r7769 16r93D6 16r776A 16r9E9D 16r776B 16r9E9F 16r776C 16r9EDB 16r776D 16r9EDC 16r776E 16r9EDD 16r776F 16r9EE0 16r7770 16r9EDF 16r7771 16r9EE2 16r7772 16r9EE9 16r7773 16r9EE7 16r7774 16r9EE5 16r7775 16r9EEA 16r7776 16r9EEF 16r7777 16r9F22 16r7778 16r9F2C 16r7779 16r9F2F 16r777A 16r9F39 16r777B 16r9F37 16r777C 16r9F3D 16r777D 16r9F3E 16r777E 16r9F44).
	table size even ifFalse: [^ self error: 'given table size must be even'].
	size _ table size / 2.
	gb2312 _ Array new: size.
	unicode _ Array new: size.
	1 to: table size by: 2 do: [:index |
		| tableIndex |
		tableIndex _ index + 1 / 2.
		gb2312 at: tableIndex put: (table at: index).
		unicode at: tableIndex put: (table at: index + 1)].
	gb23122 _ Array new: 94*94 withAll: -1.
	gb2312 withIndexDo: [:elem :index |
		code _ (elem // 256 - 33) * 94 + (elem \\ 256 - 33) + 1.
		(gb23122 at: code) ~= -1 ifTrue: [self halt].
		uIndex _ gb2312 indexOf: elem.
		uIndex = 0 ifFalse: [
			u _ unicode at: uIndex.
			gb23122 at: code put: u.
		].
	].
	GB2312Table _ gb23122.
! !

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 1/17/2004 00:33'!
initializeJISX0208Table
	"self halt. UCSTable initializeJISX0208Table"

	| table size jisX0208 unicode jisX02082 code uIndex u |
	table _ #(16r2121 16r3000 16r2122 16r3001 16r2123 16r3002 16r2124 16rFF0C 16r2125 16rFF0E 16r2126 16r30FB 16r2127 16rFF1A 16r2128 16rFF1B 16r2129 16rFF1F 16r212A 16rFF01 16r212B 16r309B 16r212C 16r309C 16r212D 16rB4 16r212E 16rFF40 16r212F 16rA8 16r2130 16rFF3E 16r2131 16rFFE3 16r2132 16rFF3F 16r2133 16r30FD 16r2134 16r30FE 16r2135 16r309D 16r2136 16r309E 16r2137 16r3003 16r2138 16r4EDD 16r2139 16r3005 16r213A 16r3006 16r213B 16r3007 16r213C 16r30FC 16r213D 16r2015 16r213E 16r2010 16r213F 16rFF0F 16r2140 16r5C 16r2141 16r301C 16r2142 16r2016 16r2143 16rFF5C 16r2144 16r2026 16r2145 16r2025 16r2146 16r2018 16r2147 16r2019 16r2148 16r201C 16r2149 16r201D 16r214A 16rFF08 16r214B 16rFF09 16r214C 16r3014 16r214D 16r3015 16r214E 16rFF3B 16r214F 16rFF3D 16r2150 16rFF5B 16r2151 16rFF5D 16r2152 16r3008 16r2153 16r3009 16r2154 16r300A 16r2155 16r300B 16r2156 16r300C 16r2157 16r300D 16r2158 16r300E 16r2159 16r300F 16r215A 16r3010 16r215B 16r3011 16r215C 16rFF0B 16r215D 16r2212 16r215E 16rB1 16r215F 16rD7 16r2160 16rF7 16r2161 16rFF1D 16r2162 16r2260 16r2163 16rFF1C 16r2164 16rFF1E 16r2165 16r2266 16r2166 16r2267 16r2167 16r221E 16r2168 16r2234 16r2169 16r2642 16r216A 16r2640 16r216B 16rB0 16r216C 16r2032 16r216D 16r2033 16r216E 16r2103 16r216F 16rFFE5 16r2170 16rFF04 16r2171 16rA2 16r2172 16rA3 16r2173 16rFF05 16r2174 16rFF03 16r2175 16rFF06 16r2176 16rFF0A 16r2177 16rFF20 16r2178 16rA7 16r2179 16r2606 16r217A 16r2605 16r217B 16r25CB 16r217C 16r25CF 16r217D 16r25CE 16r217E 16r25C7 16r2221 16r25C6 16r2222 16r25A1 16r2223 16r25A0 16r2224 16r25B3 16r2225 16r25B2 16r2226 16r25BD 16r2227 16r25BC 16r2228 16r203B 16r2229 16r3012 16r222A 16r2192 16r222B 16r2190 16r222C 16r2191 16r222D 16r2193 16r222E 16r3013 16r223A 16r2208 16r223B 16r220B 16r223C 16r2286 16r223D 16r2287 16r223E 16r2282 16r223F 16r2283 16r2240 16r222A 16r2241 16r2229 16r224A 16r2227 16r224B 16r2228 16r224C 16rAC 16r224D 16r21D2 16r224E 16r21D4 16r224F 16r2200 16r2250 16r2203 16r225C 16r2220 16r225D 16r22A5 16r225E 16r2312 16r225F 16r2202 16r2260 16r2207 16r2261 16r2261 16r2262 16r2252 16r2263 16r226A 16r2264 16r226B 16r2265 16r221A 16r2266 16r223D 16r2267 16r221D 16r2268 16r2235 16r2269 16r222B 16r226A 16r222C 16r2272 16r212B 16r2273 16r2030 16r2274 16r266F 16r2275 16r266D 16r2276 16r266A 16r2277 16r2020 16r2278 16r2021 16r2279 16rB6 16r227E 16r25EF 16r2330 16rFF10 16r2331 16rFF11 16r2332 16rFF12 16r2333 16rFF13 16r2334 16rFF14 16r2335 16rFF15 16r2336 16rFF16 16r2337 16rFF17 16r2338 16rFF18 16r2339 16rFF19 16r2341 16rFF21 16r2342 16rFF22 16r2343 16rFF23 16r2344 16rFF24 16r2345 16rFF25 16r2346 16rFF26 16r2347 16rFF27 16r2348 16rFF28 16r2349 16rFF29 16r234A 16rFF2A 16r234B 16rFF2B 16r234C 16rFF2C 16r234D 16rFF2D 16r234E 16rFF2E 16r234F 16rFF2F 16r2350 16rFF30 16r2351 16rFF31 16r2352 16rFF32 16r2353 16rFF33 16r2354 16rFF34 16r2355 16rFF35 16r2356 16rFF36 16r2357 16rFF37 16r2358 16rFF38 16r2359 16rFF39 16r235A 16rFF3A 16r2361 16rFF41 16r2362 16rFF42 16r2363 16rFF43 16r2364 16rFF44 16r2365 16rFF45 16r2366 16rFF46 16r2367 16rFF47 16r2368 16rFF48 16r2369 16rFF49 16r236A 16rFF4A 16r236B 16rFF4B 16r236C 16rFF4C 16r236D 16rFF4D 16r236E 16rFF4E 16r236F 16rFF4F 16r2370 16rFF50 16r2371 16rFF51 16r2372 16rFF52 16r2373 16rFF53 16r2374 16rFF54 16r2375 16rFF55 16r2376 16rFF56 16r2377 16rFF57 16r2378 16rFF58 16r2379 16rFF59 16r237A 16rFF5A 16r2421 16r3041 16r2422 16r3042 16r2423 16r3043 16r2424 16r3044 16r2425 16r3045 16r2426 16r3046 16r2427 16r3047 16r2428 16r3048 16r2429 16r3049 16r242A 16r304A 16r242B 16r304B 16r242C 16r304C 16r242D 16r304D 16r242E 16r304E 16r242F 16r304F 16r2430 16r3050 16r2431 16r3051 16r2432 16r3052 16r2433 16r3053 16r2434 16r3054 16r2435 16r3055 16r2436 16r3056 16r2437 16r3057 16r2438 16r3058 16r2439 16r3059 16r243A 16r305A 16r243B 16r305B 16r243C 16r305C 16r243D 16r305D 16r243E 16r305E 16r243F 16r305F 16r2440 16r3060 16r2441 16r3061 16r2442 16r3062 16r2443 16r3063 16r2444 16r3064 16r2445 16r3065 16r2446 16r3066 16r2447 16r3067 16r2448 16r3068 16r2449 16r3069 16r244A 16r306A 16r244B 16r306B 16r244C 16r306C 16r244D 16r306D 16r244E 16r306E 16r244F 16r306F 16r2450 16r3070 16r2451 16r3071 16r2452 16r3072 16r2453 16r3073 16r2454 16r3074 16r2455 16r3075 16r2456 16r3076 16r2457 16r3077 16r2458 16r3078 16r2459 16r3079 16r245A 16r307A 16r245B 16r307B 16r245C 16r307C 16r245D 16r307D 16r245E 16r307E 16r245F 16r307F 16r2460 16r3080 16r2461 16r3081 16r2462 16r3082 16r2463 16r3083 16r2464 16r3084 16r2465 16r3085 16r2466 16r3086 16r2467 16r3087 16r2468 16r3088 16r2469 16r3089 16r246A 16r308A 16r246B 16r308B 16r246C 16r308C 16r246D 16r308D 16r246E 16r308E 16r246F 16r308F 16r2470 16r3090 16r2471 16r3091 16r2472 16r3092 16r2473 16r3093 16r2521 16r30A1 16r2522 16r30A2 16r2523 16r30A3 16r2524 16r30A4 16r2525 16r30A5 16r2526 16r30A6 16r2527 16r30A7 16r2528 16r30A8 16r2529 16r30A9 16r252A 16r30AA 16r252B 16r30AB 16r252C 16r30AC 16r252D 16r30AD 16r252E 16r30AE 16r252F 16r30AF 16r2530 16r30B0 16r2531 16r30B1 16r2532 16r30B2 16r2533 16r30B3 16r2534 16r30B4 16r2535 16r30B5 16r2536 16r30B6 16r2537 16r30B7 16r2538 16r30B8 16r2539 16r30B9 16r253A 16r30BA 16r253B 16r30BB 16r253C 16r30BC 16r253D 16r30BD 16r253E 16r30BE 16r253F 16r30BF 16r2540 16r30C0 16r2541 16r30C1 16r2542 16r30C2 16r2543 16r30C3 16r2544 16r30C4 16r2545 16r30C5 16r2546 16r30C6 16r2547 16r30C7 16r2548 16r30C8 16r2549 16r30C9 16r254A 16r30CA 16r254B 16r30CB 16r254C 16r30CC 16r254D 16r30CD 16r254E 16r30CE 16r254F 16r30CF 16r2550 16r30D0 16r2551 16r30D1 16r2552 16r30D2 16r2553 16r30D3 16r2554 16r30D4 16r2555 16r30D5 16r2556 16r30D6 16r2557 16r30D7 16r2558 16r30D8 16r2559 16r30D9 16r255A 16r30DA 16r255B 16r30DB 16r255C 16r30DC 16r255D 16r30DD 16r255E 16r30DE 16r255F 16r30DF 16r2560 16r30E0 16r2561 16r30E1 16r2562 16r30E2 16r2563 16r30E3 16r2564 16r30E4 16r2565 16r30E5 16r2566 16r30E6 16r2567 16r30E7 16r2568 16r30E8 16r2569 16r30E9 16r256A 16r30EA 16r256B 16r30EB 16r256C 16r30EC 16r256D 16r30ED 16r256E 16r30EE 16r256F 16r30EF 16r2570 16r30F0 16r2571 16r30F1 16r2572 16r30F2 16r2573 16r30F3 16r2574 16r30F4 16r2575 16r30F5 16r2576 16r30F6 16r2621 16r391 16r2622 16r392 16r2623 16r393 16r2624 16r394 16r2625 16r395 16r2626 16r396 16r2627 16r397 16r2628 16r398 16r2629 16r399 16r262A 16r39A 16r262B 16r39B 16r262C 16r39C 16r262D 16r39D 16r262E 16r39E 16r262F 16r39F 16r2630 16r3A0 16r2631 16r3A1 16r2632 16r3A3 16r2633 16r3A4 16r2634 16r3A5 16r2635 16r3A6 16r2636 16r3A7 16r2637 16r3A8 16r2638 16r3A9 16r2641 16r3B1 16r2642 16r3B2 16r2643 16r3B3 16r2644 16r3B4 16r2645 16r3B5 16r2646 16r3B6 16r2647 16r3B7 16r2648 16r3B8 16r2649 16r3B9 16r264A 16r3BA 16r264B 16r3BB 16r264C 16r3BC 16r264D 16r3BD 16r264E 16r3BE 16r264F 16r3BF 16r2650 16r3C0 16r2651 16r3C1 16r2652 16r3C3 16r2653 16r3C4 16r2654 16r3C5 16r2655 16r3C6 16r2656 16r3C7 16r2657 16r3C8 16r2658 16r3C9 16r2721 16r410 16r2722 16r411 16r2723 16r412 16r2724 16r413 16r2725 16r414 16r2726 16r415 16r2727 16r401 16r2728 16r416 16r2729 16r417 16r272A 16r418 16r272B 16r419 16r272C 16r41A 16r272D 16r41B 16r272E 16r41C 16r272F 16r41D 16r2730 16r41E 16r2731 16r41F 16r2732 16r420 16r2733 16r421 16r2734 16r422 16r2735 16r423 16r2736 16r424 16r2737 16r425 16r2738 16r426 16r2739 16r427 16r273A 16r428 16r273B 16r429 16r273C 16r42A 16r273D 16r42B 16r273E 16r42C 16r273F 16r42D 16r2740 16r42E 16r2741 16r42F 16r2751 16r430 16r2752 16r431 16r2753 16r432 16r2754 16r433 16r2755 16r434 16r2756 16r435 16r2757 16r451 16r2758 16r436 16r2759 16r437 16r275A 16r438 16r275B 16r439 16r275C 16r43A 16r275D 16r43B 16r275E 16r43C 16r275F 16r43D 16r2760 16r43E 16r2761 16r43F 16r2762 16r440 16r2763 16r441 16r2764 16r442 16r2765 16r443 16r2766 16r444 16r2767 16r445 16r2768 16r446 16r2769 16r447 16r276A 16r448 16r276B 16r449 16r276C 16r44A 16r276D 16r44B 16r276E 16r44C 16r276F 16r44D 16r2770 16r44E 16r2771 16r44F 16r2821 16r2500 16r2822 16r2502 16r2823 16r250C 16r2824 16r2510 16r2825 16r2518 16r2826 16r2514 16r2827 16r251C 16r2828 16r252C 16r2829 16r2524 16r282A 16r2534 16r282B 16r253C 16r282C 16r2501 16r282D 16r2503 16r282E 16r250F 16r282F 16r2513 16r2830 16r251B 16r2831 16r2517 16r2832 16r2523 16r2833 16r2533 16r2834 16r252B 16r2835 16r253B 16r2836 16r254B 16r2837 16r2520 16r2838 16r252F 16r2839 16r2528 16r283A 16r2537 16r283B 16r253F 16r283C 16r251D 16r283D 16r2530 16r283E 16r2525 16r283F 16r2538 16r2840 16r2542 16r3021 16r4E9C 16r3022 16r5516 16r3023 16r5A03 16r3024 16r963F 16r3025 16r54C0 16r3026 16r611B 16r3027 16r6328 16r3028 16r59F6 16r3029 16r9022 16r302A 16r8475 16r302B 16r831C 16r302C 16r7A50 16r302D 16r60AA 16r302E 16r63E1 16r302F 16r6E25 16r3030 16r65ED 16r3031 16r8466 16r3032 16r82A6 16r3033 16r9BF5 16r3034 16r6893 16r3035 16r5727 16r3036 16r65A1 16r3037 16r6271 16r3038 16r5B9B 16r3039 16r59D0 16r303A 16r867B 16r303B 16r98F4 16r303C 16r7D62 16r303D 16r7DBE 16r303E 16r9B8E 16r303F 16r6216 16r3040 16r7C9F 16r3041 16r88B7 16r3042 16r5B89 16r3043 16r5EB5 16r3044 16r6309 16r3045 16r6697 16r3046 16r6848 16r3047 16r95C7 16r3048 16r978D 16r3049 16r674F 16r304A 16r4EE5 16r304B 16r4F0A 16r304C 16r4F4D 16r304D 16r4F9D 16r304E 16r5049 16r304F 16r56F2 16r3050 16r5937 16r3051 16r59D4 16r3052 16r5A01 16r3053 16r5C09 16r3054 16r60DF 16r3055 16r610F 16r3056 16r6170 16r3057 16r6613 16r3058 16r6905 16r3059 16r70BA 16r305A 16r754F 16r305B 16r7570 16r305C 16r79FB 16r305D 16r7DAD 16r305E 16r7DEF 16r305F 16r80C3 16r3060 16r840E 16r3061 16r8863 16r3062 16r8B02 16r3063 16r9055 16r3064 16r907A 16r3065 16r533B 16r3066 16r4E95 16r3067 16r4EA5 16r3068 16r57DF 16r3069 16r80B2 16r306A 16r90C1 16r306B 16r78EF 16r306C 16r4E00 16r306D 16r58F1 16r306E 16r6EA2 16r306F 16r9038 16r3070 16r7A32 16r3071 16r8328 16r3072 16r828B 16r3073 16r9C2F 16r3074 16r5141 16r3075 16r5370 16r3076 16r54BD 16r3077 16r54E1 16r3078 16r56E0 16r3079 16r59FB 16r307A 16r5F15 16r307B 16r98F2 16r307C 16r6DEB 16r307D 16r80E4 16r307E 16r852D 16r3121 16r9662 16r3122 16r9670 16r3123 16r96A0 16r3124 16r97FB 16r3125 16r540B 16r3126 16r53F3 16r3127 16r5B87 16r3128 16r70CF 16r3129 16r7FBD 16r312A 16r8FC2 16r312B 16r96E8 16r312C 16r536F 16r312D 16r9D5C 16r312E 16r7ABA 16r312F 16r4E11 16r3130 16r7893 16r3131 16r81FC 16r3132 16r6E26 16r3133 16r5618 16r3134 16r5504 16r3135 16r6B1D 16r3136 16r851A 16r3137 16r9C3B 16r3138 16r59E5 16r3139 16r53A9 16r313A 16r6D66 16r313B 16r74DC 16r313C 16r958F 16r313D 16r5642 16r313E 16r4E91 16r313F 16r904B 16r3140 16r96F2 16r3141 16r834F 16r3142 16r990C 16r3143 16r53E1 16r3144 16r55B6 16r3145 16r5B30 16r3146 16r5F71 16r3147 16r6620 16r3148 16r66F3 16r3149 16r6804 16r314A 16r6C38 16r314B 16r6CF3 16r314C 16r6D29 16r314D 16r745B 16r314E 16r76C8 16r314F 16r7A4E 16r3150 16r9834 16r3151 16r82F1 16r3152 16r885B 16r3153 16r8A60 16r3154 16r92ED 16r3155 16r6DB2 16r3156 16r75AB 16r3157 16r76CA 16r3158 16r99C5 16r3159 16r60A6 16r315A 16r8B01 16r315B 16r8D8A 16r315C 16r95B2 16r315D 16r698E 16r315E 16r53AD 16r315F 16r5186 16r3160 16r5712 16r3161 16r5830 16r3162 16r5944 16r3163 16r5BB4 16r3164 16r5EF6 16r3165 16r6028 16r3166 16r63A9 16r3167 16r63F4 16r3168 16r6CBF 16r3169 16r6F14 16r316A 16r708E 16r316B 16r7114 16r316C 16r7159 16r316D 16r71D5 16r316E 16r733F 16r316F 16r7E01 16r3170 16r8276 16r3171 16r82D1 16r3172 16r8597 16r3173 16r9060 16r3174 16r925B 16r3175 16r9D1B 16r3176 16r5869 16r3177 16r65BC 16r3178 16r6C5A 16r3179 16r7525 16r317A 16r51F9 16r317B 16r592E 16r317C 16r5965 16r317D 16r5F80 16r317E 16r5FDC 16r3221 16r62BC 16r3222 16r65FA 16r3223 16r6A2A 16r3224 16r6B27 16r3225 16r6BB4 16r3226 16r738B 16r3227 16r7FC1 16r3228 16r8956 16r3229 16r9D2C 16r322A 16r9D0E 16r322B 16r9EC4 16r322C 16r5CA1 16r322D 16r6C96 16r322E 16r837B 16r322F 16r5104 16r3230 16r5C4B 16r3231 16r61B6 16r3232 16r81C6 16r3233 16r6876 16r3234 16r7261 16r3235 16r4E59 16r3236 16r4FFA 16r3237 16r5378 16r3238 16r6069 16r3239 16r6E29 16r323A 16r7A4F 16r323B 16r97F3 16r323C 16r4E0B 16r323D 16r5316 16r323E 16r4EEE 16r323F 16r4F55 16r3240 16r4F3D 16r3241 16r4FA1 16r3242 16r4F73 16r3243 16r52A0 16r3244 16r53EF 16r3245 16r5609 16r3246 16r590F 16r3247 16r5AC1 16r3248 16r5BB6 16r3249 16r5BE1 16r324A 16r79D1 16r324B 16r6687 16r324C 16r679C 16r324D 16r67B6 16r324E 16r6B4C 16r324F 16r6CB3 16r3250 16r706B 16r3251 16r73C2 16r3252 16r798D 16r3253 16r79BE 16r3254 16r7A3C 16r3255 16r7B87 16r3256 16r82B1 16r3257 16r82DB 16r3258 16r8304 16r3259 16r8377 16r325A 16r83EF 16r325B 16r83D3 16r325C 16r8766 16r325D 16r8AB2 16r325E 16r5629 16r325F 16r8CA8 16r3260 16r8FE6 16r3261 16r904E 16r3262 16r971E 16r3263 16r868A 16r3264 16r4FC4 16r3265 16r5CE8 16r3266 16r6211 16r3267 16r7259 16r3268 16r753B 16r3269 16r81E5 16r326A 16r82BD 16r326B 16r86FE 16r326C 16r8CC0 16r326D 16r96C5 16r326E 16r9913 16r326F 16r99D5 16r3270 16r4ECB 16r3271 16r4F1A 16r3272 16r89E3 16r3273 16r56DE 16r3274 16r584A 16r3275 16r58CA 16r3276 16r5EFB 16r3277 16r5FEB 16r3278 16r602A 16r3279 16r6094 16r327A 16r6062 16r327B 16r61D0 16r327C 16r6212 16r327D 16r62D0 16r327E 16r6539 16r3321 16r9B41 16r3322 16r6666 16r3323 16r68B0 16r3324 16r6D77 16r3325 16r7070 16r3326 16r754C 16r3327 16r7686 16r3328 16r7D75 16r3329 16r82A5 16r332A 16r87F9 16r332B 16r958B 16r332C 16r968E 16r332D 16r8C9D 16r332E 16r51F1 16r332F 16r52BE 16r3330 16r5916 16r3331 16r54B3 16r3332 16r5BB3 16r3333 16r5D16 16r3334 16r6168 16r3335 16r6982 16r3336 16r6DAF 16r3337 16r788D 16r3338 16r84CB 16r3339 16r8857 16r333A 16r8A72 16r333B 16r93A7 16r333C 16r9AB8 16r333D 16r6D6C 16r333E 16r99A8 16r333F 16r86D9 16r3340 16r57A3 16r3341 16r67FF 16r3342 16r86CE 16r3343 16r920E 16r3344 16r5283 16r3345 16r5687 16r3346 16r5404 16r3347 16r5ED3 16r3348 16r62E1 16r3349 16r64B9 16r334A 16r683C 16r334B 16r6838 16r334C 16r6BBB 16r334D 16r7372 16r334E 16r78BA 16r334F 16r7A6B 16r3350 16r899A 16r3351 16r89D2 16r3352 16r8D6B 16r3353 16r8F03 16r3354 16r90ED 16r3355 16r95A3 16r3356 16r9694 16r3357 16r9769 16r3358 16r5B66 16r3359 16r5CB3 16r335A 16r697D 16r335B 16r984D 16r335C 16r984E 16r335D 16r639B 16r335E 16r7B20 16r335F 16r6A2B 16r3360 16r6A7F 16r3361 16r68B6 16r3362 16r9C0D 16r3363 16r6F5F 16r3364 16r5272 16r3365 16r559D 16r3366 16r6070 16r3367 16r62EC 16r3368 16r6D3B 16r3369 16r6E07 16r336A 16r6ED1 16r336B 16r845B 16r336C 16r8910 16r336D 16r8F44 16r336E 16r4E14 16r336F 16r9C39 16r3370 16r53F6 16r3371 16r691B 16r3372 16r6A3A 16r3373 16r9784 16r3374 16r682A 16r3375 16r515C 16r3376 16r7AC3 16r3377 16r84B2 16r3378 16r91DC 16r3379 16r938C 16r337A 16r565B 16r337B 16r9D28 16r337C 16r6822 16r337D 16r8305 16r337E 16r8431 16r3421 16r7CA5 16r3422 16r5208 16r3423 16r82C5 16r3424 16r74E6 16r3425 16r4E7E 16r3426 16r4F83 16r3427 16r51A0 16r3428 16r5BD2 16r3429 16r520A 16r342A 16r52D8 16r342B 16r52E7 16r342C 16r5DFB 16r342D 16r559A 16r342E 16r582A 16r342F 16r59E6 16r3430 16r5B8C 16r3431 16r5B98 16r3432 16r5BDB 16r3433 16r5E72 16r3434 16r5E79 16r3435 16r60A3 16r3436 16r611F 16r3437 16r6163 16r3438 16r61BE 16r3439 16r63DB 16r343A 16r6562 16r343B 16r67D1 16r343C 16r6853 16r343D 16r68FA 16r343E 16r6B3E 16r343F 16r6B53 16r3440 16r6C57 16r3441 16r6F22 16r3442 16r6F97 16r3443 16r6F45 16r3444 16r74B0 16r3445 16r7518 16r3446 16r76E3 16r3447 16r770B 16r3448 16r7AFF 16r3449 16r7BA1 16r344A 16r7C21 16r344B 16r7DE9 16r344C 16r7F36 16r344D 16r7FF0 16r344E 16r809D 16r344F 16r8266 16r3450 16r839E 16r3451 16r89B3 16r3452 16r8ACC 16r3453 16r8CAB 16r3454 16r9084 16r3455 16r9451 16r3456 16r9593 16r3457 16r9591 16r3458 16r95A2 16r3459 16r9665 16r345A 16r97D3 16r345B 16r9928 16r345C 16r8218 16r345D 16r4E38 16r345E 16r542B 16r345F 16r5CB8 16r3460 16r5DCC 16r3461 16r73A9 16r3462 16r764C 16r3463 16r773C 16r3464 16r5CA9 16r3465 16r7FEB 16r3466 16r8D0B 16r3467 16r96C1 16r3468 16r9811 16r3469 16r9854 16r346A 16r9858 16r346B 16r4F01 16r346C 16r4F0E 16r346D 16r5371 16r346E 16r559C 16r346F 16r5668 16r3470 16r57FA 16r3471 16r5947 16r3472 16r5B09 16r3473 16r5BC4 16r3474 16r5C90 16r3475 16r5E0C 16r3476 16r5E7E 16r3477 16r5FCC 16r3478 16r63EE 16r3479 16r673A 16r347A 16r65D7 16r347B 16r65E2 16r347C 16r671F 16r347D 16r68CB 16r347E 16r68C4 16r3521 16r6A5F 16r3522 16r5E30 16r3523 16r6BC5 16r3524 16r6C17 16r3525 16r6C7D 16r3526 16r757F 16r3527 16r7948 16r3528 16r5B63 16r3529 16r7A00 16r352A 16r7D00 16r352B 16r5FBD 16r352C 16r898F 16r352D 16r8A18 16r352E 16r8CB4 16r352F 16r8D77 16r3530 16r8ECC 16r3531 16r8F1D 16r3532 16r98E2 16r3533 16r9A0E 16r3534 16r9B3C 16r3535 16r4E80 16r3536 16r507D 16r3537 16r5100 16r3538 16r5993 16r3539 16r5B9C 16r353A 16r622F 16r353B 16r6280 16r353C 16r64EC 16r353D 16r6B3A 16r353E 16r72A0 16r353F 16r7591 16r3540 16r7947 16r3541 16r7FA9 16r3542 16r87FB 16r3543 16r8ABC 16r3544 16r8B70 16r3545 16r63AC 16r3546 16r83CA 16r3547 16r97A0 16r3548 16r5409 16r3549 16r5403 16r354A 16r55AB 16r354B 16r6854 16r354C 16r6A58 16r354D 16r8A70 16r354E 16r7827 16r354F 16r6775 16r3550 16r9ECD 16r3551 16r5374 16r3552 16r5BA2 16r3553 16r811A 16r3554 16r8650 16r3555 16r9006 16r3556 16r4E18 16r3557 16r4E45 16r3558 16r4EC7 16r3559 16r4F11 16r355A 16r53CA 16r355B 16r5438 16r355C 16r5BAE 16r355D 16r5F13 16r355E 16r6025 16r355F 16r6551 16r3560 16r673D 16r3561 16r6C42 16r3562 16r6C72 16r3563 16r6CE3 16r3564 16r7078 16r3565 16r7403 16r3566 16r7A76 16r3567 16r7AAE 16r3568 16r7B08 16r3569 16r7D1A 16r356A 16r7CFE 16r356B 16r7D66 16r356C 16r65E7 16r356D 16r725B 16r356E 16r53BB 16r356F 16r5C45 16r3570 16r5DE8 16r3571 16r62D2 16r3572 16r62E0 16r3573 16r6319 16r3574 16r6E20 16r3575 16r865A 16r3576 16r8A31 16r3577 16r8DDD 16r3578 16r92F8 16r3579 16r6F01 16r357A 16r79A6 16r357B 16r9B5A 16r357C 16r4EA8 16r357D 16r4EAB 16r357E 16r4EAC 16r3621 16r4F9B 16r3622 16r4FA0 16r3623 16r50D1 16r3624 16r5147 16r3625 16r7AF6 16r3626 16r5171 16r3627 16r51F6 16r3628 16r5354 16r3629 16r5321 16r362A 16r537F 16r362B 16r53EB 16r362C 16r55AC 16r362D 16r5883 16r362E 16r5CE1 16r362F 16r5F37 16r3630 16r5F4A 16r3631 16r602F 16r3632 16r6050 16r3633 16r606D 16r3634 16r631F 16r3635 16r6559 16r3636 16r6A4B 16r3637 16r6CC1 16r3638 16r72C2 16r3639 16r72ED 16r363A 16r77EF 16r363B 16r80F8 16r363C 16r8105 16r363D 16r8208 16r363E 16r854E 16r363F 16r90F7 16r3640 16r93E1 16r3641 16r97FF 16r3642 16r9957 16r3643 16r9A5A 16r3644 16r4EF0 16r3645 16r51DD 16r3646 16r5C2D 16r3647 16r6681 16r3648 16r696D 16r3649 16r5C40 16r364A 16r66F2 16r364B 16r6975 16r364C 16r7389 16r364D 16r6850 16r364E 16r7C81 16r364F 16r50C5 16r3650 16r52E4 16r3651 16r5747 16r3652 16r5DFE 16r3653 16r9326 16r3654 16r65A4 16r3655 16r6B23 16r3656 16r6B3D 16r3657 16r7434 16r3658 16r7981 16r3659 16r79BD 16r365A 16r7B4B 16r365B 16r7DCA 16r365C 16r82B9 16r365D 16r83CC 16r365E 16r887F 16r365F 16r895F 16r3660 16r8B39 16r3661 16r8FD1 16r3662 16r91D1 16r3663 16r541F 16r3664 16r9280 16r3665 16r4E5D 16r3666 16r5036 16r3667 16r53E5 16r3668 16r533A 16r3669 16r72D7 16r366A 16r7396 16r366B 16r77E9 16r366C 16r82E6 16r366D 16r8EAF 16r366E 16r99C6 16r366F 16r99C8 16r3670 16r99D2 16r3671 16r5177 16r3672 16r611A 16r3673 16r865E 16r3674 16r55B0 16r3675 16r7A7A 16r3676 16r5076 16r3677 16r5BD3 16r3678 16r9047 16r3679 16r9685 16r367A 16r4E32 16r367B 16r6ADB 16r367C 16r91E7 16r367D 16r5C51 16r367E 16r5C48 16r3721 16r6398 16r3722 16r7A9F 16r3723 16r6C93 16r3724 16r9774 16r3725 16r8F61 16r3726 16r7AAA 16r3727 16r718A 16r3728 16r9688 16r3729 16r7C82 16r372A 16r6817 16r372B 16r7E70 16r372C 16r6851 16r372D 16r936C 16r372E 16r52F2 16r372F 16r541B 16r3730 16r85AB 16r3731 16r8A13 16r3732 16r7FA4 16r3733 16r8ECD 16r3734 16r90E1 16r3735 16r5366 16r3736 16r8888 16r3737 16r7941 16r3738 16r4FC2 16r3739 16r50BE 16r373A 16r5211 16r373B 16r5144 16r373C 16r5553 16r373D 16r572D 16r373E 16r73EA 16r373F 16r578B 16r3740 16r5951 16r3741 16r5F62 16r3742 16r5F84 16r3743 16r6075 16r3744 16r6176 16r3745 16r6167 16r3746 16r61A9 16r3747 16r63B2 16r3748 16r643A 16r3749 16r656C 16r374A 16r666F 16r374B 16r6842 16r374C 16r6E13 16r374D 16r7566 16r374E 16r7A3D 16r374F 16r7CFB 16r3750 16r7D4C 16r3751 16r7D99 16r3752 16r7E4B 16r3753 16r7F6B 16r3754 16r830E 16r3755 16r834A 16r3756 16r86CD 16r3757 16r8A08 16r3758 16r8A63 16r3759 16r8B66 16r375A 16r8EFD 16r375B 16r981A 16r375C 16r9D8F 16r375D 16r82B8 16r375E 16r8FCE 16r375F 16r9BE8 16r3760 16r5287 16r3761 16r621F 16r3762 16r6483 16r3763 16r6FC0 16r3764 16r9699 16r3765 16r6841 16r3766 16r5091 16r3767 16r6B20 16r3768 16r6C7A 16r3769 16r6F54 16r376A 16r7A74 16r376B 16r7D50 16r376C 16r8840 16r376D 16r8A23 16r376E 16r6708 16r376F 16r4EF6 16r3770 16r5039 16r3771 16r5026 16r3772 16r5065 16r3773 16r517C 16r3774 16r5238 16r3775 16r5263 16r3776 16r55A7 16r3777 16r570F 16r3778 16r5805 16r3779 16r5ACC 16r377A 16r5EFA 16r377B 16r61B2 16r377C 16r61F8 16r377D 16r62F3 16r377E 16r6372 16r3821 16r691C 16r3822 16r6A29 16r3823 16r727D 16r3824 16r72AC 16r3825 16r732E 16r3826 16r7814 16r3827 16r786F 16r3828 16r7D79 16r3829 16r770C 16r382A 16r80A9 16r382B 16r898B 16r382C 16r8B19 16r382D 16r8CE2 16r382E 16r8ED2 16r382F 16r9063 16r3830 16r9375 16r3831 16r967A 16r3832 16r9855 16r3833 16r9A13 16r3834 16r9E78 16r3835 16r5143 16r3836 16r539F 16r3837 16r53B3 16r3838 16r5E7B 16r3839 16r5F26 16r383A 16r6E1B 16r383B 16r6E90 16r383C 16r7384 16r383D 16r73FE 16r383E 16r7D43 16r383F 16r8237 16r3840 16r8A00 16r3841 16r8AFA 16r3842 16r9650 16r3843 16r4E4E 16r3844 16r500B 16r3845 16r53E4 16r3846 16r547C 16r3847 16r56FA 16r3848 16r59D1 16r3849 16r5B64 16r384A 16r5DF1 16r384B 16r5EAB 16r384C 16r5F27 16r384D 16r6238 16r384E 16r6545 16r384F 16r67AF 16r3850 16r6E56 16r3851 16r72D0 16r3852 16r7CCA 16r3853 16r88B4 16r3854 16r80A1 16r3855 16r80E1 16r3856 16r83F0 16r3857 16r864E 16r3858 16r8A87 16r3859 16r8DE8 16r385A 16r9237 16r385B 16r96C7 16r385C 16r9867 16r385D 16r9F13 16r385E 16r4E94 16r385F 16r4E92 16r3860 16r4F0D 16r3861 16r5348 16r3862 16r5449 16r3863 16r543E 16r3864 16r5A2F 16r3865 16r5F8C 16r3866 16r5FA1 16r3867 16r609F 16r3868 16r68A7 16r3869 16r6A8E 16r386A 16r745A 16r386B 16r7881 16r386C 16r8A9E 16r386D 16r8AA4 16r386E 16r8B77 16r386F 16r9190 16r3870 16r4E5E 16r3871 16r9BC9 16r3872 16r4EA4 16r3873 16r4F7C 16r3874 16r4FAF 16r3875 16r5019 16r3876 16r5016 16r3877 16r5149 16r3878 16r516C 16r3879 16r529F 16r387A 16r52B9 16r387B 16r52FE 16r387C 16r539A 16r387D 16r53E3 16r387E 16r5411 16r3921 16r540E 16r3922 16r5589 16r3923 16r5751 16r3924 16r57A2 16r3925 16r597D 16r3926 16r5B54 16r3927 16r5B5D 16r3928 16r5B8F 16r3929 16r5DE5 16r392A 16r5DE7 16r392B 16r5DF7 16r392C 16r5E78 16r392D 16r5E83 16r392E 16r5E9A 16r392F 16r5EB7 16r3930 16r5F18 16r3931 16r6052 16r3932 16r614C 16r3933 16r6297 16r3934 16r62D8 16r3935 16r63A7 16r3936 16r653B 16r3937 16r6602 16r3938 16r6643 16r3939 16r66F4 16r393A 16r676D 16r393B 16r6821 16r393C 16r6897 16r393D 16r69CB 16r393E 16r6C5F 16r393F 16r6D2A 16r3940 16r6D69 16r3941 16r6E2F 16r3942 16r6E9D 16r3943 16r7532 16r3944 16r7687 16r3945 16r786C 16r3946 16r7A3F 16r3947 16r7CE0 16r3948 16r7D05 16r3949 16r7D18 16r394A 16r7D5E 16r394B 16r7DB1 16r394C 16r8015 16r394D 16r8003 16r394E 16r80AF 16r394F 16r80B1 16r3950 16r8154 16r3951 16r818F 16r3952 16r822A 16r3953 16r8352 16r3954 16r884C 16r3955 16r8861 16r3956 16r8B1B 16r3957 16r8CA2 16r3958 16r8CFC 16r3959 16r90CA 16r395A 16r9175 16r395B 16r9271 16r395C 16r783F 16r395D 16r92FC 16r395E 16r95A4 16r395F 16r964D 16r3960 16r9805 16r3961 16r9999 16r3962 16r9AD8 16r3963 16r9D3B 16r3964 16r525B 16r3965 16r52AB 16r3966 16r53F7 16r3967 16r5408 16r3968 16r58D5 16r3969 16r62F7 16r396A 16r6FE0 16r396B 16r8C6A 16r396C 16r8F5F 16r396D 16r9EB9 16r396E 16r514B 16r396F 16r523B 16r3970 16r544A 16r3971 16r56FD 16r3972 16r7A40 16r3973 16r9177 16r3974 16r9D60 16r3975 16r9ED2 16r3976 16r7344 16r3977 16r6F09 16r3978 16r8170 16r3979 16r7511 16r397A 16r5FFD 16r397B 16r60DA 16r397C 16r9AA8 16r397D 16r72DB 16r397E 16r8FBC 16r3A21 16r6B64 16r3A22 16r9803 16r3A23 16r4ECA 16r3A24 16r56F0 16r3A25 16r5764 16r3A26 16r58BE 16r3A27 16r5A5A 16r3A28 16r6068 16r3A29 16r61C7 16r3A2A 16r660F 16r3A2B 16r6606 16r3A2C 16r6839 16r3A2D 16r68B1 16r3A2E 16r6DF7 16r3A2F 16r75D5 16r3A30 16r7D3A 16r3A31 16r826E 16r3A32 16r9B42 16r3A33 16r4E9B 16r3A34 16r4F50 16r3A35 16r53C9 16r3A36 16r5506 16r3A37 16r5D6F 16r3A38 16r5DE6 16r3A39 16r5DEE 16r3A3A 16r67FB 16r3A3B 16r6C99 16r3A3C 16r7473 16r3A3D 16r7802 16r3A3E 16r8A50 16r3A3F 16r9396 16r3A40 16r88DF 16r3A41 16r5750 16r3A42 16r5EA7 16r3A43 16r632B 16r3A44 16r50B5 16r3A45 16r50AC 16r3A46 16r518D 16r3A47 16r6700 16r3A48 16r54C9 16r3A49 16r585E 16r3A4A 16r59BB 16r3A4B 16r5BB0 16r3A4C 16r5F69 16r3A4D 16r624D 16r3A4E 16r63A1 16r3A4F 16r683D 16r3A50 16r6B73 16r3A51 16r6E08 16r3A52 16r707D 16r3A53 16r91C7 16r3A54 16r7280 16r3A55 16r7815 16r3A56 16r7826 16r3A57 16r796D 16r3A58 16r658E 16r3A59 16r7D30 16r3A5A 16r83DC 16r3A5B 16r88C1 16r3A5C 16r8F09 16r3A5D 16r969B 16r3A5E 16r5264 16r3A5F 16r5728 16r3A60 16r6750 16r3A61 16r7F6A 16r3A62 16r8CA1 16r3A63 16r51B4 16r3A64 16r5742 16r3A65 16r962A 16r3A66 16r583A 16r3A67 16r698A 16r3A68 16r80B4 16r3A69 16r54B2 16r3A6A 16r5D0E 16r3A6B 16r57FC 16r3A6C 16r7895 16r3A6D 16r9DFA 16r3A6E 16r4F5C 16r3A6F 16r524A 16r3A70 16r548B 16r3A71 16r643E 16r3A72 16r6628 16r3A73 16r6714 16r3A74 16r67F5 16r3A75 16r7A84 16r3A76 16r7B56 16r3A77 16r7D22 16r3A78 16r932F 16r3A79 16r685C 16r3A7A 16r9BAD 16r3A7B 16r7B39 16r3A7C 16r5319 16r3A7D 16r518A 16r3A7E 16r5237 16r3B21 16r5BDF 16r3B22 16r62F6 16r3B23 16r64AE 16r3B24 16r64E6 16r3B25 16r672D 16r3B26 16r6BBA 16r3B27 16r85A9 16r3B28 16r96D1 16r3B29 16r7690 16r3B2A 16r9BD6 16r3B2B 16r634C 16r3B2C 16r9306 16r3B2D 16r9BAB 16r3B2E 16r76BF 16r3B2F 16r6652 16r3B30 16r4E09 16r3B31 16r5098 16r3B32 16r53C2 16r3B33 16r5C71 16r3B34 16r60E8 16r3B35 16r6492 16r3B36 16r6563 16r3B37 16r685F 16r3B38 16r71E6 16r3B39 16r73CA 16r3B3A 16r7523 16r3B3B 16r7B97 16r3B3C 16r7E82 16r3B3D 16r8695 16r3B3E 16r8B83 16r3B3F 16r8CDB 16r3B40 16r9178 16r3B41 16r9910 16r3B42 16r65AC 16r3B43 16r66AB 16r3B44 16r6B8B 16r3B45 16r4ED5 16r3B46 16r4ED4 16r3B47 16r4F3A 16r3B48 16r4F7F 16r3B49 16r523A 16r3B4A 16r53F8 16r3B4B 16r53F2 16r3B4C 16r55E3 16r3B4D 16r56DB 16r3B4E 16r58EB 16r3B4F 16r59CB 16r3B50 16r59C9 16r3B51 16r59FF 16r3B52 16r5B50 16r3B53 16r5C4D 16r3B54 16r5E02 16r3B55 16r5E2B 16r3B56 16r5FD7 16r3B57 16r601D 16r3B58 16r6307 16r3B59 16r652F 16r3B5A 16r5B5C 16r3B5B 16r65AF 16r3B5C 16r65BD 16r3B5D 16r65E8 16r3B5E 16r679D 16r3B5F 16r6B62 16r3B60 16r6B7B 16r3B61 16r6C0F 16r3B62 16r7345 16r3B63 16r7949 16r3B64 16r79C1 16r3B65 16r7CF8 16r3B66 16r7D19 16r3B67 16r7D2B 16r3B68 16r80A2 16r3B69 16r8102 16r3B6A 16r81F3 16r3B6B 16r8996 16r3B6C 16r8A5E 16r3B6D 16r8A69 16r3B6E 16r8A66 16r3B6F 16r8A8C 16r3B70 16r8AEE 16r3B71 16r8CC7 16r3B72 16r8CDC 16r3B73 16r96CC 16r3B74 16r98FC 16r3B75 16r6B6F 16r3B76 16r4E8B 16r3B77 16r4F3C 16r3B78 16r4F8D 16r3B79 16r5150 16r3B7A 16r5B57 16r3B7B 16r5BFA 16r3B7C 16r6148 16r3B7D 16r6301 16r3B7E 16r6642 16r3C21 16r6B21 16r3C22 16r6ECB 16r3C23 16r6CBB 16r3C24 16r723E 16r3C25 16r74BD 16r3C26 16r75D4 16r3C27 16r78C1 16r3C28 16r793A 16r3C29 16r800C 16r3C2A 16r8033 16r3C2B 16r81EA 16r3C2C 16r8494 16r3C2D 16r8F9E 16r3C2E 16r6C50 16r3C2F 16r9E7F 16r3C30 16r5F0F 16r3C31 16r8B58 16r3C32 16r9D2B 16r3C33 16r7AFA 16r3C34 16r8EF8 16r3C35 16r5B8D 16r3C36 16r96EB 16r3C37 16r4E03 16r3C38 16r53F1 16r3C39 16r57F7 16r3C3A 16r5931 16r3C3B 16r5AC9 16r3C3C 16r5BA4 16r3C3D 16r6089 16r3C3E 16r6E7F 16r3C3F 16r6F06 16r3C40 16r75BE 16r3C41 16r8CEA 16r3C42 16r5B9F 16r3C43 16r8500 16r3C44 16r7BE0 16r3C45 16r5072 16r3C46 16r67F4 16r3C47 16r829D 16r3C48 16r5C61 16r3C49 16r854A 16r3C4A 16r7E1E 16r3C4B 16r820E 16r3C4C 16r5199 16r3C4D 16r5C04 16r3C4E 16r6368 16r3C4F 16r8D66 16r3C50 16r659C 16r3C51 16r716E 16r3C52 16r793E 16r3C53 16r7D17 16r3C54 16r8005 16r3C55 16r8B1D 16r3C56 16r8ECA 16r3C57 16r906E 16r3C58 16r86C7 16r3C59 16r90AA 16r3C5A 16r501F 16r3C5B 16r52FA 16r3C5C 16r5C3A 16r3C5D 16r6753 16r3C5E 16r707C 16r3C5F 16r7235 16r3C60 16r914C 16r3C61 16r91C8 16r3C62 16r932B 16r3C63 16r82E5 16r3C64 16r5BC2 16r3C65 16r5F31 16r3C66 16r60F9 16r3C67 16r4E3B 16r3C68 16r53D6 16r3C69 16r5B88 16r3C6A 16r624B 16r3C6B 16r6731 16r3C6C 16r6B8A 16r3C6D 16r72E9 16r3C6E 16r73E0 16r3C6F 16r7A2E 16r3C70 16r816B 16r3C71 16r8DA3 16r3C72 16r9152 16r3C73 16r9996 16r3C74 16r5112 16r3C75 16r53D7 16r3C76 16r546A 16r3C77 16r5BFF 16r3C78 16r6388 16r3C79 16r6A39 16r3C7A 16r7DAC 16r3C7B 16r9700 16r3C7C 16r56DA 16r3C7D 16r53CE 16r3C7E 16r5468 16r3D21 16r5B97 16r3D22 16r5C31 16r3D23 16r5DDE 16r3D24 16r4FEE 16r3D25 16r6101 16r3D26 16r62FE 16r3D27 16r6D32 16r3D28 16r79C0 16r3D29 16r79CB 16r3D2A 16r7D42 16r3D2B 16r7E4D 16r3D2C 16r7FD2 16r3D2D 16r81ED 16r3D2E 16r821F 16r3D2F 16r8490 16r3D30 16r8846 16r3D31 16r8972 16r3D32 16r8B90 16r3D33 16r8E74 16r3D34 16r8F2F 16r3D35 16r9031 16r3D36 16r914B 16r3D37 16r916C 16r3D38 16r96C6 16r3D39 16r919C 16r3D3A 16r4EC0 16r3D3B 16r4F4F 16r3D3C 16r5145 16r3D3D 16r5341 16r3D3E 16r5F93 16r3D3F 16r620E 16r3D40 16r67D4 16r3D41 16r6C41 16r3D42 16r6E0B 16r3D43 16r7363 16r3D44 16r7E26 16r3D45 16r91CD 16r3D46 16r9283 16r3D47 16r53D4 16r3D48 16r5919 16r3D49 16r5BBF 16r3D4A 16r6DD1 16r3D4B 16r795D 16r3D4C 16r7E2E 16r3D4D 16r7C9B 16r3D4E 16r587E 16r3D4F 16r719F 16r3D50 16r51FA 16r3D51 16r8853 16r3D52 16r8FF0 16r3D53 16r4FCA 16r3D54 16r5CFB 16r3D55 16r6625 16r3D56 16r77AC 16r3D57 16r7AE3 16r3D58 16r821C 16r3D59 16r99FF 16r3D5A 16r51C6 16r3D5B 16r5FAA 16r3D5C 16r65EC 16r3D5D 16r696F 16r3D5E 16r6B89 16r3D5F 16r6DF3 16r3D60 16r6E96 16r3D61 16r6F64 16r3D62 16r76FE 16r3D63 16r7D14 16r3D64 16r5DE1 16r3D65 16r9075 16r3D66 16r9187 16r3D67 16r9806 16r3D68 16r51E6 16r3D69 16r521D 16r3D6A 16r6240 16r3D6B 16r6691 16r3D6C 16r66D9 16r3D6D 16r6E1A 16r3D6E 16r5EB6 16r3D6F 16r7DD2 16r3D70 16r7F72 16r3D71 16r66F8 16r3D72 16r85AF 16r3D73 16r85F7 16r3D74 16r8AF8 16r3D75 16r52A9 16r3D76 16r53D9 16r3D77 16r5973 16r3D78 16r5E8F 16r3D79 16r5F90 16r3D7A 16r6055 16r3D7B 16r92E4 16r3D7C 16r9664 16r3D7D 16r50B7 16r3D7E 16r511F 16r3E21 16r52DD 16r3E22 16r5320 16r3E23 16r5347 16r3E24 16r53EC 16r3E25 16r54E8 16r3E26 16r5546 16r3E27 16r5531 16r3E28 16r5617 16r3E29 16r5968 16r3E2A 16r59BE 16r3E2B 16r5A3C 16r3E2C 16r5BB5 16r3E2D 16r5C06 16r3E2E 16r5C0F 16r3E2F 16r5C11 16r3E30 16r5C1A 16r3E31 16r5E84 16r3E32 16r5E8A 16r3E33 16r5EE0 16r3E34 16r5F70 16r3E35 16r627F 16r3E36 16r6284 16r3E37 16r62DB 16r3E38 16r638C 16r3E39 16r6377 16r3E3A 16r6607 16r3E3B 16r660C 16r3E3C 16r662D 16r3E3D 16r6676 16r3E3E 16r677E 16r3E3F 16r68A2 16r3E40 16r6A1F 16r3E41 16r6A35 16r3E42 16r6CBC 16r3E43 16r6D88 16r3E44 16r6E09 16r3E45 16r6E58 16r3E46 16r713C 16r3E47 16r7126 16r3E48 16r7167 16r3E49 16r75C7 16r3E4A 16r7701 16r3E4B 16r785D 16r3E4C 16r7901 16r3E4D 16r7965 16r3E4E 16r79F0 16r3E4F 16r7AE0 16r3E50 16r7B11 16r3E51 16r7CA7 16r3E52 16r7D39 16r3E53 16r8096 16r3E54 16r83D6 16r3E55 16r848B 16r3E56 16r8549 16r3E57 16r885D 16r3E58 16r88F3 16r3E59 16r8A1F 16r3E5A 16r8A3C 16r3E5B 16r8A54 16r3E5C 16r8A73 16r3E5D 16r8C61 16r3E5E 16r8CDE 16r3E5F 16r91A4 16r3E60 16r9266 16r3E61 16r937E 16r3E62 16r9418 16r3E63 16r969C 16r3E64 16r9798 16r3E65 16r4E0A 16r3E66 16r4E08 16r3E67 16r4E1E 16r3E68 16r4E57 16r3E69 16r5197 16r3E6A 16r5270 16r3E6B 16r57CE 16r3E6C 16r5834 16r3E6D 16r58CC 16r3E6E 16r5B22 16r3E6F 16r5E38 16r3E70 16r60C5 16r3E71 16r64FE 16r3E72 16r6761 16r3E73 16r6756 16r3E74 16r6D44 16r3E75 16r72B6 16r3E76 16r7573 16r3E77 16r7A63 16r3E78 16r84B8 16r3E79 16r8B72 16r3E7A 16r91B8 16r3E7B 16r9320 16r3E7C 16r5631 16r3E7D 16r57F4 16r3E7E 16r98FE 16r3F21 16r62ED 16r3F22 16r690D 16r3F23 16r6B96 16r3F24 16r71ED 16r3F25 16r7E54 16r3F26 16r8077 16r3F27 16r8272 16r3F28 16r89E6 16r3F29 16r98DF 16r3F2A 16r8755 16r3F2B 16r8FB1 16r3F2C 16r5C3B 16r3F2D 16r4F38 16r3F2E 16r4FE1 16r3F2F 16r4FB5 16r3F30 16r5507 16r3F31 16r5A20 16r3F32 16r5BDD 16r3F33 16r5BE9 16r3F34 16r5FC3 16r3F35 16r614E 16r3F36 16r632F 16r3F37 16r65B0 16r3F38 16r664B 16r3F39 16r68EE 16r3F3A 16r699B 16r3F3B 16r6D78 16r3F3C 16r6DF1 16r3F3D 16r7533 16r3F3E 16r75B9 16r3F3F 16r771F 16r3F40 16r795E 16r3F41 16r79E6 16r3F42 16r7D33 16r3F43 16r81E3 16r3F44 16r82AF 16r3F45 16r85AA 16r3F46 16r89AA 16r3F47 16r8A3A 16r3F48 16r8EAB 16r3F49 16r8F9B 16r3F4A 16r9032 16r3F4B 16r91DD 16r3F4C 16r9707 16r3F4D 16r4EBA 16r3F4E 16r4EC1 16r3F4F 16r5203 16r3F50 16r5875 16r3F51 16r58EC 16r3F52 16r5C0B 16r3F53 16r751A 16r3F54 16r5C3D 16r3F55 16r814E 16r3F56 16r8A0A 16r3F57 16r8FC5 16r3F58 16r9663 16r3F59 16r976D 16r3F5A 16r7B25 16r3F5B 16r8ACF 16r3F5C 16r9808 16r3F5D 16r9162 16r3F5E 16r56F3 16r3F5F 16r53A8 16r3F60 16r9017 16r3F61 16r5439 16r3F62 16r5782 16r3F63 16r5E25 16r3F64 16r63A8 16r3F65 16r6C34 16r3F66 16r708A 16r3F67 16r7761 16r3F68 16r7C8B 16r3F69 16r7FE0 16r3F6A 16r8870 16r3F6B 16r9042 16r3F6C 16r9154 16r3F6D 16r9310 16r3F6E 16r9318 16r3F6F 16r968F 16r3F70 16r745E 16r3F71 16r9AC4 16r3F72 16r5D07 16r3F73 16r5D69 16r3F74 16r6570 16r3F75 16r67A2 16r3F76 16r8DA8 16r3F77 16r96DB 16r3F78 16r636E 16r3F79 16r6749 16r3F7A 16r6919 16r3F7B 16r83C5 16r3F7C 16r9817 16r3F7D 16r96C0 16r3F7E 16r88FE 16r4021 16r6F84 16r4022 16r647A 16r4023 16r5BF8 16r4024 16r4E16 16r4025 16r702C 16r4026 16r755D 16r4027 16r662F 16r4028 16r51C4 16r4029 16r5236 16r402A 16r52E2 16r402B 16r59D3 16r402C 16r5F81 16r402D 16r6027 16r402E 16r6210 16r402F 16r653F 16r4030 16r6574 16r4031 16r661F 16r4032 16r6674 16r4033 16r68F2 16r4034 16r6816 16r4035 16r6B63 16r4036 16r6E05 16r4037 16r7272 16r4038 16r751F 16r4039 16r76DB 16r403A 16r7CBE 16r403B 16r8056 16r403C 16r58F0 16r403D 16r88FD 16r403E 16r897F 16r403F 16r8AA0 16r4040 16r8A93 16r4041 16r8ACB 16r4042 16r901D 16r4043 16r9192 16r4044 16r9752 16r4045 16r9759 16r4046 16r6589 16r4047 16r7A0E 16r4048 16r8106 16r4049 16r96BB 16r404A 16r5E2D 16r404B 16r60DC 16r404C 16r621A 16r404D 16r65A5 16r404E 16r6614 16r404F 16r6790 16r4050 16r77F3 16r4051 16r7A4D 16r4052 16r7C4D 16r4053 16r7E3E 16r4054 16r810A 16r4055 16r8CAC 16r4056 16r8D64 16r4057 16r8DE1 16r4058 16r8E5F 16r4059 16r78A9 16r405A 16r5207 16r405B 16r62D9 16r405C 16r63A5 16r405D 16r6442 16r405E 16r6298 16r405F 16r8A2D 16r4060 16r7A83 16r4061 16r7BC0 16r4062 16r8AAC 16r4063 16r96EA 16r4064 16r7D76 16r4065 16r820C 16r4066 16r8749 16r4067 16r4ED9 16r4068 16r5148 16r4069 16r5343 16r406A 16r5360 16r406B 16r5BA3 16r406C 16r5C02 16r406D 16r5C16 16r406E 16r5DDD 16r406F 16r6226 16r4070 16r6247 16r4071 16r64B0 16r4072 16r6813 16r4073 16r6834 16r4074 16r6CC9 16r4075 16r6D45 16r4076 16r6D17 16r4077 16r67D3 16r4078 16r6F5C 16r4079 16r714E 16r407A 16r717D 16r407B 16r65CB 16r407C 16r7A7F 16r407D 16r7BAD 16r407E 16r7DDA 16r4121 16r7E4A 16r4122 16r7FA8 16r4123 16r817A 16r4124 16r821B 16r4125 16r8239 16r4126 16r85A6 16r4127 16r8A6E 16r4128 16r8CCE 16r4129 16r8DF5 16r412A 16r9078 16r412B 16r9077 16r412C 16r92AD 16r412D 16r9291 16r412E 16r9583 16r412F 16r9BAE 16r4130 16r524D 16r4131 16r5584 16r4132 16r6F38 16r4133 16r7136 16r4134 16r5168 16r4135 16r7985 16r4136 16r7E55 16r4137 16r81B3 16r4138 16r7CCE 16r4139 16r564C 16r413A 16r5851 16r413B 16r5CA8 16r413C 16r63AA 16r413D 16r66FE 16r413E 16r66FD 16r413F 16r695A 16r4140 16r72D9 16r4141 16r758F 16r4142 16r758E 16r4143 16r790E 16r4144 16r7956 16r4145 16r79DF 16r4146 16r7C97 16r4147 16r7D20 16r4148 16r7D44 16r4149 16r8607 16r414A 16r8A34 16r414B 16r963B 16r414C 16r9061 16r414D 16r9F20 16r414E 16r50E7 16r414F 16r5275 16r4150 16r53CC 16r4151 16r53E2 16r4152 16r5009 16r4153 16r55AA 16r4154 16r58EE 16r4155 16r594F 16r4156 16r723D 16r4157 16r5B8B 16r4158 16r5C64 16r4159 16r531D 16r415A 16r60E3 16r415B 16r60F3 16r415C 16r635C 16r415D 16r6383 16r415E 16r633F 16r415F 16r63BB 16r4160 16r64CD 16r4161 16r65E9 16r4162 16r66F9 16r4163 16r5DE3 16r4164 16r69CD 16r4165 16r69FD 16r4166 16r6F15 16r4167 16r71E5 16r4168 16r4E89 16r4169 16r75E9 16r416A 16r76F8 16r416B 16r7A93 16r416C 16r7CDF 16r416D 16r7DCF 16r416E 16r7D9C 16r416F 16r8061 16r4170 16r8349 16r4171 16r8358 16r4172 16r846C 16r4173 16r84BC 16r4174 16r85FB 16r4175 16r88C5 16r4176 16r8D70 16r4177 16r9001 16r4178 16r906D 16r4179 16r9397 16r417A 16r971C 16r417B 16r9A12 16r417C 16r50CF 16r417D 16r5897 16r417E 16r618E 16r4221 16r81D3 16r4222 16r8535 16r4223 16r8D08 16r4224 16r9020 16r4225 16r4FC3 16r4226 16r5074 16r4227 16r5247 16r4228 16r5373 16r4229 16r606F 16r422A 16r6349 16r422B 16r675F 16r422C 16r6E2C 16r422D 16r8DB3 16r422E 16r901F 16r422F 16r4FD7 16r4230 16r5C5E 16r4231 16r8CCA 16r4232 16r65CF 16r4233 16r7D9A 16r4234 16r5352 16r4235 16r8896 16r4236 16r5176 16r4237 16r63C3 16r4238 16r5B58 16r4239 16r5B6B 16r423A 16r5C0A 16r423B 16r640D 16r423C 16r6751 16r423D 16r905C 16r423E 16r4ED6 16r423F 16r591A 16r4240 16r592A 16r4241 16r6C70 16r4242 16r8A51 16r4243 16r553E 16r4244 16r5815 16r4245 16r59A5 16r4246 16r60F0 16r4247 16r6253 16r4248 16r67C1 16r4249 16r8235 16r424A 16r6955 16r424B 16r9640 16r424C 16r99C4 16r424D 16r9A28 16r424E 16r4F53 16r424F 16r5806 16r4250 16r5BFE 16r4251 16r8010 16r4252 16r5CB1 16r4253 16r5E2F 16r4254 16r5F85 16r4255 16r6020 16r4256 16r614B 16r4257 16r6234 16r4258 16r66FF 16r4259 16r6CF0 16r425A 16r6EDE 16r425B 16r80CE 16r425C 16r817F 16r425D 16r82D4 16r425E 16r888B 16r425F 16r8CB8 16r4260 16r9000 16r4261 16r902E 16r4262 16r968A 16r4263 16r9EDB 16r4264 16r9BDB 16r4265 16r4EE3 16r4266 16r53F0 16r4267 16r5927 16r4268 16r7B2C 16r4269 16r918D 16r426A 16r984C 16r426B 16r9DF9 16r426C 16r6EDD 16r426D 16r7027 16r426E 16r5353 16r426F 16r5544 16r4270 16r5B85 16r4271 16r6258 16r4272 16r629E 16r4273 16r62D3 16r4274 16r6CA2 16r4275 16r6FEF 16r4276 16r7422 16r4277 16r8A17 16r4278 16r9438 16r4279 16r6FC1 16r427A 16r8AFE 16r427B 16r8338 16r427C 16r51E7 16r427D 16r86F8 16r427E 16r53EA 16r4321 16r53E9 16r4322 16r4F46 16r4323 16r9054 16r4324 16r8FB0 16r4325 16r596A 16r4326 16r8131 16r4327 16r5DFD 16r4328 16r7AEA 16r4329 16r8FBF 16r432A 16r68DA 16r432B 16r8C37 16r432C 16r72F8 16r432D 16r9C48 16r432E 16r6A3D 16r432F 16r8AB0 16r4330 16r4E39 16r4331 16r5358 16r4332 16r5606 16r4333 16r5766 16r4334 16r62C5 16r4335 16r63A2 16r4336 16r65E6 16r4337 16r6B4E 16r4338 16r6DE1 16r4339 16r6E5B 16r433A 16r70AD 16r433B 16r77ED 16r433C 16r7AEF 16r433D 16r7BAA 16r433E 16r7DBB 16r433F 16r803D 16r4340 16r80C6 16r4341 16r86CB 16r4342 16r8A95 16r4343 16r935B 16r4344 16r56E3 16r4345 16r58C7 16r4346 16r5F3E 16r4347 16r65AD 16r4348 16r6696 16r4349 16r6A80 16r434A 16r6BB5 16r434B 16r7537 16r434C 16r8AC7 16r434D 16r5024 16r434E 16r77E5 16r434F 16r5730 16r4350 16r5F1B 16r4351 16r6065 16r4352 16r667A 16r4353 16r6C60 16r4354 16r75F4 16r4355 16r7A1A 16r4356 16r7F6E 16r4357 16r81F4 16r4358 16r8718 16r4359 16r9045 16r435A 16r99B3 16r435B 16r7BC9 16r435C 16r755C 16r435D 16r7AF9 16r435E 16r7B51 16r435F 16r84C4 16r4360 16r9010 16r4361 16r79E9 16r4362 16r7A92 16r4363 16r8336 16r4364 16r5AE1 16r4365 16r7740 16r4366 16r4E2D 16r4367 16r4EF2 16r4368 16r5B99 16r4369 16r5FE0 16r436A 16r62BD 16r436B 16r663C 16r436C 16r67F1 16r436D 16r6CE8 16r436E 16r866B 16r436F 16r8877 16r4370 16r8A3B 16r4371 16r914E 16r4372 16r92F3 16r4373 16r99D0 16r4374 16r6A17 16r4375 16r7026 16r4376 16r732A 16r4377 16r82E7 16r4378 16r8457 16r4379 16r8CAF 16r437A 16r4E01 16r437B 16r5146 16r437C 16r51CB 16r437D 16r558B 16r437E 16r5BF5 16r4421 16r5E16 16r4422 16r5E33 16r4423 16r5E81 16r4424 16r5F14 16r4425 16r5F35 16r4426 16r5F6B 16r4427 16r5FB4 16r4428 16r61F2 16r4429 16r6311 16r442A 16r66A2 16r442B 16r671D 16r442C 16r6F6E 16r442D 16r7252 16r442E 16r753A 16r442F 16r773A 16r4430 16r8074 16r4431 16r8139 16r4432 16r8178 16r4433 16r8776 16r4434 16r8ABF 16r4435 16r8ADC 16r4436 16r8D85 16r4437 16r8DF3 16r4438 16r929A 16r4439 16r9577 16r443A 16r9802 16r443B 16r9CE5 16r443C 16r52C5 16r443D 16r6357 16r443E 16r76F4 16r443F 16r6715 16r4440 16r6C88 16r4441 16r73CD 16r4442 16r8CC3 16r4443 16r93AE 16r4444 16r9673 16r4445 16r6D25 16r4446 16r589C 16r4447 16r690E 16r4448 16r69CC 16r4449 16r8FFD 16r444A 16r939A 16r444B 16r75DB 16r444C 16r901A 16r444D 16r585A 16r444E 16r6802 16r444F 16r63B4 16r4450 16r69FB 16r4451 16r4F43 16r4452 16r6F2C 16r4453 16r67D8 16r4454 16r8FBB 16r4455 16r8526 16r4456 16r7DB4 16r4457 16r9354 16r4458 16r693F 16r4459 16r6F70 16r445A 16r576A 16r445B 16r58F7 16r445C 16r5B2C 16r445D 16r7D2C 16r445E 16r722A 16r445F 16r540A 16r4460 16r91E3 16r4461 16r9DB4 16r4462 16r4EAD 16r4463 16r4F4E 16r4464 16r505C 16r4465 16r5075 16r4466 16r5243 16r4467 16r8C9E 16r4468 16r5448 16r4469 16r5824 16r446A 16r5B9A 16r446B 16r5E1D 16r446C 16r5E95 16r446D 16r5EAD 16r446E 16r5EF7 16r446F 16r5F1F 16r4470 16r608C 16r4471 16r62B5 16r4472 16r633A 16r4473 16r63D0 16r4474 16r68AF 16r4475 16r6C40 16r4476 16r7887 16r4477 16r798E 16r4478 16r7A0B 16r4479 16r7DE0 16r447A 16r8247 16r447B 16r8A02 16r447C 16r8AE6 16r447D 16r8E44 16r447E 16r9013 16r4521 16r90B8 16r4522 16r912D 16r4523 16r91D8 16r4524 16r9F0E 16r4525 16r6CE5 16r4526 16r6458 16r4527 16r64E2 16r4528 16r6575 16r4529 16r6EF4 16r452A 16r7684 16r452B 16r7B1B 16r452C 16r9069 16r452D 16r93D1 16r452E 16r6EBA 16r452F 16r54F2 16r4530 16r5FB9 16r4531 16r64A4 16r4532 16r8F4D 16r4533 16r8FED 16r4534 16r9244 16r4535 16r5178 16r4536 16r586B 16r4537 16r5929 16r4538 16r5C55 16r4539 16r5E97 16r453A 16r6DFB 16r453B 16r7E8F 16r453C 16r751C 16r453D 16r8CBC 16r453E 16r8EE2 16r453F 16r985B 16r4540 16r70B9 16r4541 16r4F1D 16r4542 16r6BBF 16r4543 16r6FB1 16r4544 16r7530 16r4545 16r96FB 16r4546 16r514E 16r4547 16r5410 16r4548 16r5835 16r4549 16r5857 16r454A 16r59AC 16r454B 16r5C60 16r454C 16r5F92 16r454D 16r6597 16r454E 16r675C 16r454F 16r6E21 16r4550 16r767B 16r4551 16r83DF 16r4552 16r8CED 16r4553 16r9014 16r4554 16r90FD 16r4555 16r934D 16r4556 16r7825 16r4557 16r783A 16r4558 16r52AA 16r4559 16r5EA6 16r455A 16r571F 16r455B 16r5974 16r455C 16r6012 16r455D 16r5012 16r455E 16r515A 16r455F 16r51AC 16r4560 16r51CD 16r4561 16r5200 16r4562 16r5510 16r4563 16r5854 16r4564 16r5858 16r4565 16r5957 16r4566 16r5B95 16r4567 16r5CF6 16r4568 16r5D8B 16r4569 16r60BC 16r456A 16r6295 16r456B 16r642D 16r456C 16r6771 16r456D 16r6843 16r456E 16r68BC 16r456F 16r68DF 16r4570 16r76D7 16r4571 16r6DD8 16r4572 16r6E6F 16r4573 16r6D9B 16r4574 16r706F 16r4575 16r71C8 16r4576 16r5F53 16r4577 16r75D8 16r4578 16r7977 16r4579 16r7B49 16r457A 16r7B54 16r457B 16r7B52 16r457C 16r7CD6 16r457D 16r7D71 16r457E 16r5230 16r4621 16r8463 16r4622 16r8569 16r4623 16r85E4 16r4624 16r8A0E 16r4625 16r8B04 16r4626 16r8C46 16r4627 16r8E0F 16r4628 16r9003 16r4629 16r900F 16r462A 16r9419 16r462B 16r9676 16r462C 16r982D 16r462D 16r9A30 16r462E 16r95D8 16r462F 16r50CD 16r4630 16r52D5 16r4631 16r540C 16r4632 16r5802 16r4633 16r5C0E 16r4634 16r61A7 16r4635 16r649E 16r4636 16r6D1E 16r4637 16r77B3 16r4638 16r7AE5 16r4639 16r80F4 16r463A 16r8404 16r463B 16r9053 16r463C 16r9285 16r463D 16r5CE0 16r463E 16r9D07 16r463F 16r533F 16r4640 16r5F97 16r4641 16r5FB3 16r4642 16r6D9C 16r4643 16r7279 16r4644 16r7763 16r4645 16r79BF 16r4646 16r7BE4 16r4647 16r6BD2 16r4648 16r72EC 16r4649 16r8AAD 16r464A 16r6803 16r464B 16r6A61 16r464C 16r51F8 16r464D 16r7A81 16r464E 16r6934 16r464F 16r5C4A 16r4650 16r9CF6 16r4651 16r82EB 16r4652 16r5BC5 16r4653 16r9149 16r4654 16r701E 16r4655 16r5678 16r4656 16r5C6F 16r4657 16r60C7 16r4658 16r6566 16r4659 16r6C8C 16r465A 16r8C5A 16r465B 16r9041 16r465C 16r9813 16r465D 16r5451 16r465E 16r66C7 16r465F 16r920D 16r4660 16r5948 16r4661 16r90A3 16r4662 16r5185 16r4663 16r4E4D 16r4664 16r51EA 16r4665 16r8599 16r4666 16r8B0E 16r4667 16r7058 16r4668 16r637A 16r4669 16r934B 16r466A 16r6962 16r466B 16r99B4 16r466C 16r7E04 16r466D 16r7577 16r466E 16r5357 16r466F 16r6960 16r4670 16r8EDF 16r4671 16r96E3 16r4672 16r6C5D 16r4673 16r4E8C 16r4674 16r5C3C 16r4675 16r5F10 16r4676 16r8FE9 16r4677 16r5302 16r4678 16r8CD1 16r4679 16r8089 16r467A 16r8679 16r467B 16r5EFF 16r467C 16r65E5 16r467D 16r4E73 16r467E 16r5165 16r4721 16r5982 16r4722 16r5C3F 16r4723 16r97EE 16r4724 16r4EFB 16r4725 16r598A 16r4726 16r5FCD 16r4727 16r8A8D 16r4728 16r6FE1 16r4729 16r79B0 16r472A 16r7962 16r472B 16r5BE7 16r472C 16r8471 16r472D 16r732B 16r472E 16r71B1 16r472F 16r5E74 16r4730 16r5FF5 16r4731 16r637B 16r4732 16r649A 16r4733 16r71C3 16r4734 16r7C98 16r4735 16r4E43 16r4736 16r5EFC 16r4737 16r4E4B 16r4738 16r57DC 16r4739 16r56A2 16r473A 16r60A9 16r473B 16r6FC3 16r473C 16r7D0D 16r473D 16r80FD 16r473E 16r8133 16r473F 16r81BF 16r4740 16r8FB2 16r4741 16r8997 16r4742 16r86A4 16r4743 16r5DF4 16r4744 16r628A 16r4745 16r64AD 16r4746 16r8987 16r4747 16r6777 16r4748 16r6CE2 16r4749 16r6D3E 16r474A 16r7436 16r474B 16r7834 16r474C 16r5A46 16r474D 16r7F75 16r474E 16r82AD 16r474F 16r99AC 16r4750 16r4FF3 16r4751 16r5EC3 16r4752 16r62DD 16r4753 16r6392 16r4754 16r6557 16r4755 16r676F 16r4756 16r76C3 16r4757 16r724C 16r4758 16r80CC 16r4759 16r80BA 16r475A 16r8F29 16r475B 16r914D 16r475C 16r500D 16r475D 16r57F9 16r475E 16r5A92 16r475F 16r6885 16r4760 16r6973 16r4761 16r7164 16r4762 16r72FD 16r4763 16r8CB7 16r4764 16r58F2 16r4765 16r8CE0 16r4766 16r966A 16r4767 16r9019 16r4768 16r877F 16r4769 16r79E4 16r476A 16r77E7 16r476B 16r8429 16r476C 16r4F2F 16r476D 16r5265 16r476E 16r535A 16r476F 16r62CD 16r4770 16r67CF 16r4771 16r6CCA 16r4772 16r767D 16r4773 16r7B94 16r4774 16r7C95 16r4775 16r8236 16r4776 16r8584 16r4777 16r8FEB 16r4778 16r66DD 16r4779 16r6F20 16r477A 16r7206 16r477B 16r7E1B 16r477C 16r83AB 16r477D 16r99C1 16r477E 16r9EA6 16r4821 16r51FD 16r4822 16r7BB1 16r4823 16r7872 16r4824 16r7BB8 16r4825 16r8087 16r4826 16r7B48 16r4827 16r6AE8 16r4828 16r5E61 16r4829 16r808C 16r482A 16r7551 16r482B 16r7560 16r482C 16r516B 16r482D 16r9262 16r482E 16r6E8C 16r482F 16r767A 16r4830 16r9197 16r4831 16r9AEA 16r4832 16r4F10 16r4833 16r7F70 16r4834 16r629C 16r4835 16r7B4F 16r4836 16r95A5 16r4837 16r9CE9 16r4838 16r567A 16r4839 16r5859 16r483A 16r86E4 16r483B 16r96BC 16r483C 16r4F34 16r483D 16r5224 16r483E 16r534A 16r483F 16r53CD 16r4840 16r53DB 16r4841 16r5E06 16r4842 16r642C 16r4843 16r6591 16r4844 16r677F 16r4845 16r6C3E 16r4846 16r6C4E 16r4847 16r7248 16r4848 16r72AF 16r4849 16r73ED 16r484A 16r7554 16r484B 16r7E41 16r484C 16r822C 16r484D 16r85E9 16r484E 16r8CA9 16r484F 16r7BC4 16r4850 16r91C6 16r4851 16r7169 16r4852 16r9812 16r4853 16r98EF 16r4854 16r633D 16r4855 16r6669 16r4856 16r756A 16r4857 16r76E4 16r4858 16r78D0 16r4859 16r8543 16r485A 16r86EE 16r485B 16r532A 16r485C 16r5351 16r485D 16r5426 16r485E 16r5983 16r485F 16r5E87 16r4860 16r5F7C 16r4861 16r60B2 16r4862 16r6249 16r4863 16r6279 16r4864 16r62AB 16r4865 16r6590 16r4866 16r6BD4 16r4867 16r6CCC 16r4868 16r75B2 16r4869 16r76AE 16r486A 16r7891 16r486B 16r79D8 16r486C 16r7DCB 16r486D 16r7F77 16r486E 16r80A5 16r486F 16r88AB 16r4870 16r8AB9 16r4871 16r8CBB 16r4872 16r907F 16r4873 16r975E 16r4874 16r98DB 16r4875 16r6A0B 16r4876 16r7C38 16r4877 16r5099 16r4878 16r5C3E 16r4879 16r5FAE 16r487A 16r6787 16r487B 16r6BD8 16r487C 16r7435 16r487D 16r7709 16r487E 16r7F8E 16r4921 16r9F3B 16r4922 16r67CA 16r4923 16r7A17 16r4924 16r5339 16r4925 16r758B 16r4926 16r9AED 16r4927 16r5F66 16r4928 16r819D 16r4929 16r83F1 16r492A 16r8098 16r492B 16r5F3C 16r492C 16r5FC5 16r492D 16r7562 16r492E 16r7B46 16r492F 16r903C 16r4930 16r6867 16r4931 16r59EB 16r4932 16r5A9B 16r4933 16r7D10 16r4934 16r767E 16r4935 16r8B2C 16r4936 16r4FF5 16r4937 16r5F6A 16r4938 16r6A19 16r4939 16r6C37 16r493A 16r6F02 16r493B 16r74E2 16r493C 16r7968 16r493D 16r8868 16r493E 16r8A55 16r493F 16r8C79 16r4940 16r5EDF 16r4941 16r63CF 16r4942 16r75C5 16r4943 16r79D2 16r4944 16r82D7 16r4945 16r9328 16r4946 16r92F2 16r4947 16r849C 16r4948 16r86ED 16r4949 16r9C2D 16r494A 16r54C1 16r494B 16r5F6C 16r494C 16r658C 16r494D 16r6D5C 16r494E 16r7015 16r494F 16r8CA7 16r4950 16r8CD3 16r4951 16r983B 16r4952 16r654F 16r4953 16r74F6 16r4954 16r4E0D 16r4955 16r4ED8 16r4956 16r57E0 16r4957 16r592B 16r4958 16r5A66 16r4959 16r5BCC 16r495A 16r51A8 16r495B 16r5E03 16r495C 16r5E9C 16r495D 16r6016 16r495E 16r6276 16r495F 16r6577 16r4960 16r65A7 16r4961 16r666E 16r4962 16r6D6E 16r4963 16r7236 16r4964 16r7B26 16r4965 16r8150 16r4966 16r819A 16r4967 16r8299 16r4968 16r8B5C 16r4969 16r8CA0 16r496A 16r8CE6 16r496B 16r8D74 16r496C 16r961C 16r496D 16r9644 16r496E 16r4FAE 16r496F 16r64AB 16r4970 16r6B66 16r4971 16r821E 16r4972 16r8461 16r4973 16r856A 16r4974 16r90E8 16r4975 16r5C01 16r4976 16r6953 16r4977 16r98A8 16r4978 16r847A 16r4979 16r8557 16r497A 16r4F0F 16r497B 16r526F 16r497C 16r5FA9 16r497D 16r5E45 16r497E 16r670D 16r4A21 16r798F 16r4A22 16r8179 16r4A23 16r8907 16r4A24 16r8986 16r4A25 16r6DF5 16r4A26 16r5F17 16r4A27 16r6255 16r4A28 16r6CB8 16r4A29 16r4ECF 16r4A2A 16r7269 16r4A2B 16r9B92 16r4A2C 16r5206 16r4A2D 16r543B 16r4A2E 16r5674 16r4A2F 16r58B3 16r4A30 16r61A4 16r4A31 16r626E 16r4A32 16r711A 16r4A33 16r596E 16r4A34 16r7C89 16r4A35 16r7CDE 16r4A36 16r7D1B 16r4A37 16r96F0 16r4A38 16r6587 16r4A39 16r805E 16r4A3A 16r4E19 16r4A3B 16r4F75 16r4A3C 16r5175 16r4A3D 16r5840 16r4A3E 16r5E63 16r4A3F 16r5E73 16r4A40 16r5F0A 16r4A41 16r67C4 16r4A42 16r4E26 16r4A43 16r853D 16r4A44 16r9589 16r4A45 16r965B 16r4A46 16r7C73 16r4A47 16r9801 16r4A48 16r50FB 16r4A49 16r58C1 16r4A4A 16r7656 16r4A4B 16r78A7 16r4A4C 16r5225 16r4A4D 16r77A5 16r4A4E 16r8511 16r4A4F 16r7B86 16r4A50 16r504F 16r4A51 16r5909 16r4A52 16r7247 16r4A53 16r7BC7 16r4A54 16r7DE8 16r4A55 16r8FBA 16r4A56 16r8FD4 16r4A57 16r904D 16r4A58 16r4FBF 16r4A59 16r52C9 16r4A5A 16r5A29 16r4A5B 16r5F01 16r4A5C 16r97AD 16r4A5D 16r4FDD 16r4A5E 16r8217 16r4A5F 16r92EA 16r4A60 16r5703 16r4A61 16r6355 16r4A62 16r6B69 16r4A63 16r752B 16r4A64 16r88DC 16r4A65 16r8F14 16r4A66 16r7A42 16r4A67 16r52DF 16r4A68 16r5893 16r4A69 16r6155 16r4A6A 16r620A 16r4A6B 16r66AE 16r4A6C 16r6BCD 16r4A6D 16r7C3F 16r4A6E 16r83E9 16r4A6F 16r5023 16r4A70 16r4FF8 16r4A71 16r5305 16r4A72 16r5446 16r4A73 16r5831 16r4A74 16r5949 16r4A75 16r5B9D 16r4A76 16r5CF0 16r4A77 16r5CEF 16r4A78 16r5D29 16r4A79 16r5E96 16r4A7A 16r62B1 16r4A7B 16r6367 16r4A7C 16r653E 16r4A7D 16r65B9 16r4A7E 16r670B 16r4B21 16r6CD5 16r4B22 16r6CE1 16r4B23 16r70F9 16r4B24 16r7832 16r4B25 16r7E2B 16r4B26 16r80DE 16r4B27 16r82B3 16r4B28 16r840C 16r4B29 16r84EC 16r4B2A 16r8702 16r4B2B 16r8912 16r4B2C 16r8A2A 16r4B2D 16r8C4A 16r4B2E 16r90A6 16r4B2F 16r92D2 16r4B30 16r98FD 16r4B31 16r9CF3 16r4B32 16r9D6C 16r4B33 16r4E4F 16r4B34 16r4EA1 16r4B35 16r508D 16r4B36 16r5256 16r4B37 16r574A 16r4B38 16r59A8 16r4B39 16r5E3D 16r4B3A 16r5FD8 16r4B3B 16r5FD9 16r4B3C 16r623F 16r4B3D 16r66B4 16r4B3E 16r671B 16r4B3F 16r67D0 16r4B40 16r68D2 16r4B41 16r5192 16r4B42 16r7D21 16r4B43 16r80AA 16r4B44 16r81A8 16r4B45 16r8B00 16r4B46 16r8C8C 16r4B47 16r8CBF 16r4B48 16r927E 16r4B49 16r9632 16r4B4A 16r5420 16r4B4B 16r982C 16r4B4C 16r5317 16r4B4D 16r50D5 16r4B4E 16r535C 16r4B4F 16r58A8 16r4B50 16r64B2 16r4B51 16r6734 16r4B52 16r7267 16r4B53 16r7766 16r4B54 16r7A46 16r4B55 16r91E6 16r4B56 16r52C3 16r4B57 16r6CA1 16r4B58 16r6B86 16r4B59 16r5800 16r4B5A 16r5E4C 16r4B5B 16r5954 16r4B5C 16r672C 16r4B5D 16r7FFB 16r4B5E 16r51E1 16r4B5F 16r76C6 16r4B60 16r6469 16r4B61 16r78E8 16r4B62 16r9B54 16r4B63 16r9EBB 16r4B64 16r57CB 16r4B65 16r59B9 16r4B66 16r6627 16r4B67 16r679A 16r4B68 16r6BCE 16r4B69 16r54E9 16r4B6A 16r69D9 16r4B6B 16r5E55 16r4B6C 16r819C 16r4B6D 16r6795 16r4B6E 16r9BAA 16r4B6F 16r67FE 16r4B70 16r9C52 16r4B71 16r685D 16r4B72 16r4EA6 16r4B73 16r4FE3 16r4B74 16r53C8 16r4B75 16r62B9 16r4B76 16r672B 16r4B77 16r6CAB 16r4B78 16r8FC4 16r4B79 16r4FAD 16r4B7A 16r7E6D 16r4B7B 16r9EBF 16r4B7C 16r4E07 16r4B7D 16r6162 16r4B7E 16r6E80 16r4C21 16r6F2B 16r4C22 16r8513 16r4C23 16r5473 16r4C24 16r672A 16r4C25 16r9B45 16r4C26 16r5DF3 16r4C27 16r7B95 16r4C28 16r5CAC 16r4C29 16r5BC6 16r4C2A 16r871C 16r4C2B 16r6E4A 16r4C2C 16r84D1 16r4C2D 16r7A14 16r4C2E 16r8108 16r4C2F 16r5999 16r4C30 16r7C8D 16r4C31 16r6C11 16r4C32 16r7720 16r4C33 16r52D9 16r4C34 16r5922 16r4C35 16r7121 16r4C36 16r725F 16r4C37 16r77DB 16r4C38 16r9727 16r4C39 16r9D61 16r4C3A 16r690B 16r4C3B 16r5A7F 16r4C3C 16r5A18 16r4C3D 16r51A5 16r4C3E 16r540D 16r4C3F 16r547D 16r4C40 16r660E 16r4C41 16r76DF 16r4C42 16r8FF7 16r4C43 16r9298 16r4C44 16r9CF4 16r4C45 16r59EA 16r4C46 16r725D 16r4C47 16r6EC5 16r4C48 16r514D 16r4C49 16r68C9 16r4C4A 16r7DBF 16r4C4B 16r7DEC 16r4C4C 16r9762 16r4C4D 16r9EBA 16r4C4E 16r6478 16r4C4F 16r6A21 16r4C50 16r8302 16r4C51 16r5984 16r4C52 16r5B5F 16r4C53 16r6BDB 16r4C54 16r731B 16r4C55 16r76F2 16r4C56 16r7DB2 16r4C57 16r8017 16r4C58 16r8499 16r4C59 16r5132 16r4C5A 16r6728 16r4C5B 16r9ED9 16r4C5C 16r76EE 16r4C5D 16r6762 16r4C5E 16r52FF 16r4C5F 16r9905 16r4C60 16r5C24 16r4C61 16r623B 16r4C62 16r7C7E 16r4C63 16r8CB0 16r4C64 16r554F 16r4C65 16r60B6 16r4C66 16r7D0B 16r4C67 16r9580 16r4C68 16r5301 16r4C69 16r4E5F 16r4C6A 16r51B6 16r4C6B 16r591C 16r4C6C 16r723A 16r4C6D 16r8036 16r4C6E 16r91CE 16r4C6F 16r5F25 16r4C70 16r77E2 16r4C71 16r5384 16r4C72 16r5F79 16r4C73 16r7D04 16r4C74 16r85AC 16r4C75 16r8A33 16r4C76 16r8E8D 16r4C77 16r9756 16r4C78 16r67F3 16r4C79 16r85AE 16r4C7A 16r9453 16r4C7B 16r6109 16r4C7C 16r6108 16r4C7D 16r6CB9 16r4C7E 16r7652 16r4D21 16r8AED 16r4D22 16r8F38 16r4D23 16r552F 16r4D24 16r4F51 16r4D25 16r512A 16r4D26 16r52C7 16r4D27 16r53CB 16r4D28 16r5BA5 16r4D29 16r5E7D 16r4D2A 16r60A0 16r4D2B 16r6182 16r4D2C 16r63D6 16r4D2D 16r6709 16r4D2E 16r67DA 16r4D2F 16r6E67 16r4D30 16r6D8C 16r4D31 16r7336 16r4D32 16r7337 16r4D33 16r7531 16r4D34 16r7950 16r4D35 16r88D5 16r4D36 16r8A98 16r4D37 16r904A 16r4D38 16r9091 16r4D39 16r90F5 16r4D3A 16r96C4 16r4D3B 16r878D 16r4D3C 16r5915 16r4D3D 16r4E88 16r4D3E 16r4F59 16r4D3F 16r4E0E 16r4D40 16r8A89 16r4D41 16r8F3F 16r4D42 16r9810 16r4D43 16r50AD 16r4D44 16r5E7C 16r4D45 16r5996 16r4D46 16r5BB9 16r4D47 16r5EB8 16r4D48 16r63DA 16r4D49 16r63FA 16r4D4A 16r64C1 16r4D4B 16r66DC 16r4D4C 16r694A 16r4D4D 16r69D8 16r4D4E 16r6D0B 16r4D4F 16r6EB6 16r4D50 16r7194 16r4D51 16r7528 16r4D52 16r7AAF 16r4D53 16r7F8A 16r4D54 16r8000 16r4D55 16r8449 16r4D56 16r84C9 16r4D57 16r8981 16r4D58 16r8B21 16r4D59 16r8E0A 16r4D5A 16r9065 16r4D5B 16r967D 16r4D5C 16r990A 16r4D5D 16r617E 16r4D5E 16r6291 16r4D5F 16r6B32 16r4D60 16r6C83 16r4D61 16r6D74 16r4D62 16r7FCC 16r4D63 16r7FFC 16r4D64 16r6DC0 16r4D65 16r7F85 16r4D66 16r87BA 16r4D67 16r88F8 16r4D68 16r6765 16r4D69 16r83B1 16r4D6A 16r983C 16r4D6B 16r96F7 16r4D6C 16r6D1B 16r4D6D 16r7D61 16r4D6E 16r843D 16r4D6F 16r916A 16r4D70 16r4E71 16r4D71 16r5375 16r4D72 16r5D50 16r4D73 16r6B04 16r4D74 16r6FEB 16r4D75 16r85CD 16r4D76 16r862D 16r4D77 16r89A7 16r4D78 16r5229 16r4D79 16r540F 16r4D7A 16r5C65 16r4D7B 16r674E 16r4D7C 16r68A8 16r4D7D 16r7406 16r4D7E 16r7483 16r4E21 16r75E2 16r4E22 16r88CF 16r4E23 16r88E1 16r4E24 16r91CC 16r4E25 16r96E2 16r4E26 16r9678 16r4E27 16r5F8B 16r4E28 16r7387 16r4E29 16r7ACB 16r4E2A 16r844E 16r4E2B 16r63A0 16r4E2C 16r7565 16r4E2D 16r5289 16r4E2E 16r6D41 16r4E2F 16r6E9C 16r4E30 16r7409 16r4E31 16r7559 16r4E32 16r786B 16r4E33 16r7C92 16r4E34 16r9686 16r4E35 16r7ADC 16r4E36 16r9F8D 16r4E37 16r4FB6 16r4E38 16r616E 16r4E39 16r65C5 16r4E3A 16r865C 16r4E3B 16r4E86 16r4E3C 16r4EAE 16r4E3D 16r50DA 16r4E3E 16r4E21 16r4E3F 16r51CC 16r4E40 16r5BEE 16r4E41 16r6599 16r4E42 16r6881 16r4E43 16r6DBC 16r4E44 16r731F 16r4E45 16r7642 16r4E46 16r77AD 16r4E47 16r7A1C 16r4E48 16r7CE7 16r4E49 16r826F 16r4E4A 16r8AD2 16r4E4B 16r907C 16r4E4C 16r91CF 16r4E4D 16r9675 16r4E4E 16r9818 16r4E4F 16r529B 16r4E50 16r7DD1 16r4E51 16r502B 16r4E52 16r5398 16r4E53 16r6797 16r4E54 16r6DCB 16r4E55 16r71D0 16r4E56 16r7433 16r4E57 16r81E8 16r4E58 16r8F2A 16r4E59 16r96A3 16r4E5A 16r9C57 16r4E5B 16r9E9F 16r4E5C 16r7460 16r4E5D 16r5841 16r4E5E 16r6D99 16r4E5F 16r7D2F 16r4E60 16r985E 16r4E61 16r4EE4 16r4E62 16r4F36 16r4E63 16r4F8B 16r4E64 16r51B7 16r4E65 16r52B1 16r4E66 16r5DBA 16r4E67 16r601C 16r4E68 16r73B2 16r4E69 16r793C 16r4E6A 16r82D3 16r4E6B 16r9234 16r4E6C 16r96B7 16r4E6D 16r96F6 16r4E6E 16r970A 16r4E6F 16r9E97 16r4E70 16r9F62 16r4E71 16r66A6 16r4E72 16r6B74 16r4E73 16r5217 16r4E74 16r52A3 16r4E75 16r70C8 16r4E76 16r88C2 16r4E77 16r5EC9 16r4E78 16r604B 16r4E79 16r6190 16r4E7A 16r6F23 16r4E7B 16r7149 16r4E7C 16r7C3E 16r4E7D 16r7DF4 16r4E7E 16r806F 16r4F21 16r84EE 16r4F22 16r9023 16r4F23 16r932C 16r4F24 16r5442 16r4F25 16r9B6F 16r4F26 16r6AD3 16r4F27 16r7089 16r4F28 16r8CC2 16r4F29 16r8DEF 16r4F2A 16r9732 16r4F2B 16r52B4 16r4F2C 16r5A41 16r4F2D 16r5ECA 16r4F2E 16r5F04 16r4F2F 16r6717 16r4F30 16r697C 16r4F31 16r6994 16r4F32 16r6D6A 16r4F33 16r6F0F 16r4F34 16r7262 16r4F35 16r72FC 16r4F36 16r7BED 16r4F37 16r8001 16r4F38 16r807E 16r4F39 16r874B 16r4F3A 16r90CE 16r4F3B 16r516D 16r4F3C 16r9E93 16r4F3D 16r7984 16r4F3E 16r808B 16r4F3F 16r9332 16r4F40 16r8AD6 16r4F41 16r502D 16r4F42 16r548C 16r4F43 16r8A71 16r4F44 16r6B6A 16r4F45 16r8CC4 16r4F46 16r8107 16r4F47 16r60D1 16r4F48 16r67A0 16r4F49 16r9DF2 16r4F4A 16r4E99 16r4F4B 16r4E98 16r4F4C 16r9C10 16r4F4D 16r8A6B 16r4F4E 16r85C1 16r4F4F 16r8568 16r4F50 16r6900 16r4F51 16r6E7E 16r4F52 16r7897 16r4F53 16r8155 16r5021 16r5F0C 16r5022 16r4E10 16r5023 16r4E15 16r5024 16r4E2A 16r5025 16r4E31 16r5026 16r4E36 16r5027 16r4E3C 16r5028 16r4E3F 16r5029 16r4E42 16r502A 16r4E56 16r502B 16r4E58 16r502C 16r4E82 16r502D 16r4E85 16r502E 16r8C6B 16r502F 16r4E8A 16r5030 16r8212 16r5031 16r5F0D 16r5032 16r4E8E 16r5033 16r4E9E 16r5034 16r4E9F 16r5035 16r4EA0 16r5036 16r4EA2 16r5037 16r4EB0 16r5038 16r4EB3 16r5039 16r4EB6 16r503A 16r4ECE 16r503B 16r4ECD 16r503C 16r4EC4 16r503D 16r4EC6 16r503E 16r4EC2 16r503F 16r4ED7 16r5040 16r4EDE 16r5041 16r4EED 16r5042 16r4EDF 16r5043 16r4EF7 16r5044 16r4F09 16r5045 16r4F5A 16r5046 16r4F30 16r5047 16r4F5B 16r5048 16r4F5D 16r5049 16r4F57 16r504A 16r4F47 16r504B 16r4F76 16r504C 16r4F88 16r504D 16r4F8F 16r504E 16r4F98 16r504F 16r4F7B 16r5050 16r4F69 16r5051 16r4F70 16r5052 16r4F91 16r5053 16r4F6F 16r5054 16r4F86 16r5055 16r4F96 16r5056 16r5118 16r5057 16r4FD4 16r5058 16r4FDF 16r5059 16r4FCE 16r505A 16r4FD8 16r505B 16r4FDB 16r505C 16r4FD1 16r505D 16r4FDA 16r505E 16r4FD0 16r505F 16r4FE4 16r5060 16r4FE5 16r5061 16r501A 16r5062 16r5028 16r5063 16r5014 16r5064 16r502A 16r5065 16r5025 16r5066 16r5005 16r5067 16r4F1C 16r5068 16r4FF6 16r5069 16r5021 16r506A 16r5029 16r506B 16r502C 16r506C 16r4FFE 16r506D 16r4FEF 16r506E 16r5011 16r506F 16r5006 16r5070 16r5043 16r5071 16r5047 16r5072 16r6703 16r5073 16r5055 16r5074 16r5050 16r5075 16r5048 16r5076 16r505A 16r5077 16r5056 16r5078 16r506C 16r5079 16r5078 16r507A 16r5080 16r507B 16r509A 16r507C 16r5085 16r507D 16r50B4 16r507E 16r50B2 16r5121 16r50C9 16r5122 16r50CA 16r5123 16r50B3 16r5124 16r50C2 16r5125 16r50D6 16r5126 16r50DE 16r5127 16r50E5 16r5128 16r50ED 16r5129 16r50E3 16r512A 16r50EE 16r512B 16r50F9 16r512C 16r50F5 16r512D 16r5109 16r512E 16r5101 16r512F 16r5102 16r5130 16r5116 16r5131 16r5115 16r5132 16r5114 16r5133 16r511A 16r5134 16r5121 16r5135 16r513A 16r5136 16r5137 16r5137 16r513C 16r5138 16r513B 16r5139 16r513F 16r513A 16r5140 16r513B 16r5152 16r513C 16r514C 16r513D 16r5154 16r513E 16r5162 16r513F 16r7AF8 16r5140 16r5169 16r5141 16r516A 16r5142 16r516E 16r5143 16r5180 16r5144 16r5182 16r5145 16r56D8 16r5146 16r518C 16r5147 16r5189 16r5148 16r518F 16r5149 16r5191 16r514A 16r5193 16r514B 16r5195 16r514C 16r5196 16r514D 16r51A4 16r514E 16r51A6 16r514F 16r51A2 16r5150 16r51A9 16r5151 16r51AA 16r5152 16r51AB 16r5153 16r51B3 16r5154 16r51B1 16r5155 16r51B2 16r5156 16r51B0 16r5157 16r51B5 16r5158 16r51BD 16r5159 16r51C5 16r515A 16r51C9 16r515B 16r51DB 16r515C 16r51E0 16r515D 16r8655 16r515E 16r51E9 16r515F 16r51ED 16r5160 16r51F0 16r5161 16r51F5 16r5162 16r51FE 16r5163 16r5204 16r5164 16r520B 16r5165 16r5214 16r5166 16r520E 16r5167 16r5227 16r5168 16r522A 16r5169 16r522E 16r516A 16r5233 16r516B 16r5239 16r516C 16r524F 16r516D 16r5244 16r516E 16r524B 16r516F 16r524C 16r5170 16r525E 16r5171 16r5254 16r5172 16r526A 16r5173 16r5274 16r5174 16r5269 16r5175 16r5273 16r5176 16r527F 16r5177 16r527D 16r5178 16r528D 16r5179 16r5294 16r517A 16r5292 16r517B 16r5271 16r517C 16r5288 16r517D 16r5291 16r517E 16r8FA8 16r5221 16r8FA7 16r5222 16r52AC 16r5223 16r52AD 16r5224 16r52BC 16r5225 16r52B5 16r5226 16r52C1 16r5227 16r52CD 16r5228 16r52D7 16r5229 16r52DE 16r522A 16r52E3 16r522B 16r52E6 16r522C 16r98ED 16r522D 16r52E0 16r522E 16r52F3 16r522F 16r52F5 16r5230 16r52F8 16r5231 16r52F9 16r5232 16r5306 16r5233 16r5308 16r5234 16r7538 16r5235 16r530D 16r5236 16r5310 16r5237 16r530F 16r5238 16r5315 16r5239 16r531A 16r523A 16r5323 16r523B 16r532F 16r523C 16r5331 16r523D 16r5333 16r523E 16r5338 16r523F 16r5340 16r5240 16r5346 16r5241 16r5345 16r5242 16r4E17 16r5243 16r5349 16r5244 16r534D 16r5245 16r51D6 16r5246 16r535E 16r5247 16r5369 16r5248 16r536E 16r5249 16r5918 16r524A 16r537B 16r524B 16r5377 16r524C 16r5382 16r524D 16r5396 16r524E 16r53A0 16r524F 16r53A6 16r5250 16r53A5 16r5251 16r53AE 16r5252 16r53B0 16r5253 16r53B6 16r5254 16r53C3 16r5255 16r7C12 16r5256 16r96D9 16r5257 16r53DF 16r5258 16r66FC 16r5259 16r71EE 16r525A 16r53EE 16r525B 16r53E8 16r525C 16r53ED 16r525D 16r53FA 16r525E 16r5401 16r525F 16r543D 16r5260 16r5440 16r5261 16r542C 16r5262 16r542D 16r5263 16r543C 16r5264 16r542E 16r5265 16r5436 16r5266 16r5429 16r5267 16r541D 16r5268 16r544E 16r5269 16r548F 16r526A 16r5475 16r526B 16r548E 16r526C 16r545F 16r526D 16r5471 16r526E 16r5477 16r526F 16r5470 16r5270 16r5492 16r5271 16r547B 16r5272 16r5480 16r5273 16r5476 16r5274 16r5484 16r5275 16r5490 16r5276 16r5486 16r5277 16r54C7 16r5278 16r54A2 16r5279 16r54B8 16r527A 16r54A5 16r527B 16r54AC 16r527C 16r54C4 16r527D 16r54C8 16r527E 16r54A8 16r5321 16r54AB 16r5322 16r54C2 16r5323 16r54A4 16r5324 16r54BE 16r5325 16r54BC 16r5326 16r54D8 16r5327 16r54E5 16r5328 16r54E6 16r5329 16r550F 16r532A 16r5514 16r532B 16r54FD 16r532C 16r54EE 16r532D 16r54ED 16r532E 16r54FA 16r532F 16r54E2 16r5330 16r5539 16r5331 16r5540 16r5332 16r5563 16r5333 16r554C 16r5334 16r552E 16r5335 16r555C 16r5336 16r5545 16r5337 16r5556 16r5338 16r5557 16r5339 16r5538 16r533A 16r5533 16r533B 16r555D 16r533C 16r5599 16r533D 16r5580 16r533E 16r54AF 16r533F 16r558A 16r5340 16r559F 16r5341 16r557B 16r5342 16r557E 16r5343 16r5598 16r5344 16r559E 16r5345 16r55AE 16r5346 16r557C 16r5347 16r5583 16r5348 16r55A9 16r5349 16r5587 16r534A 16r55A8 16r534B 16r55DA 16r534C 16r55C5 16r534D 16r55DF 16r534E 16r55C4 16r534F 16r55DC 16r5350 16r55E4 16r5351 16r55D4 16r5352 16r5614 16r5353 16r55F7 16r5354 16r5616 16r5355 16r55FE 16r5356 16r55FD 16r5357 16r561B 16r5358 16r55F9 16r5359 16r564E 16r535A 16r5650 16r535B 16r71DF 16r535C 16r5634 16r535D 16r5636 16r535E 16r5632 16r535F 16r5638 16r5360 16r566B 16r5361 16r5664 16r5362 16r562F 16r5363 16r566C 16r5364 16r566A 16r5365 16r5686 16r5366 16r5680 16r5367 16r568A 16r5368 16r56A0 16r5369 16r5694 16r536A 16r568F 16r536B 16r56A5 16r536C 16r56AE 16r536D 16r56B6 16r536E 16r56B4 16r536F 16r56C2 16r5370 16r56BC 16r5371 16r56C1 16r5372 16r56C3 16r5373 16r56C0 16r5374 16r56C8 16r5375 16r56CE 16r5376 16r56D1 16r5377 16r56D3 16r5378 16r56D7 16r5379 16r56EE 16r537A 16r56F9 16r537B 16r5700 16r537C 16r56FF 16r537D 16r5704 16r537E 16r5709 16r5421 16r5708 16r5422 16r570B 16r5423 16r570D 16r5424 16r5713 16r5425 16r5718 16r5426 16r5716 16r5427 16r55C7 16r5428 16r571C 16r5429 16r5726 16r542A 16r5737 16r542B 16r5738 16r542C 16r574E 16r542D 16r573B 16r542E 16r5740 16r542F 16r574F 16r5430 16r5769 16r5431 16r57C0 16r5432 16r5788 16r5433 16r5761 16r5434 16r577F 16r5435 16r5789 16r5436 16r5793 16r5437 16r57A0 16r5438 16r57B3 16r5439 16r57A4 16r543A 16r57AA 16r543B 16r57B0 16r543C 16r57C3 16r543D 16r57C6 16r543E 16r57D4 16r543F 16r57D2 16r5440 16r57D3 16r5441 16r580A 16r5442 16r57D6 16r5443 16r57E3 16r5444 16r580B 16r5445 16r5819 16r5446 16r581D 16r5447 16r5872 16r5448 16r5821 16r5449 16r5862 16r544A 16r584B 16r544B 16r5870 16r544C 16r6BC0 16r544D 16r5852 16r544E 16r583D 16r544F 16r5879 16r5450 16r5885 16r5451 16r58B9 16r5452 16r589F 16r5453 16r58AB 16r5454 16r58BA 16r5455 16r58DE 16r5456 16r58BB 16r5457 16r58B8 16r5458 16r58AE 16r5459 16r58C5 16r545A 16r58D3 16r545B 16r58D1 16r545C 16r58D7 16r545D 16r58D9 16r545E 16r58D8 16r545F 16r58E5 16r5460 16r58DC 16r5461 16r58E4 16r5462 16r58DF 16r5463 16r58EF 16r5464 16r58FA 16r5465 16r58F9 16r5466 16r58FB 16r5467 16r58FC 16r5468 16r58FD 16r5469 16r5902 16r546A 16r590A 16r546B 16r5910 16r546C 16r591B 16r546D 16r68A6 16r546E 16r5925 16r546F 16r592C 16r5470 16r592D 16r5471 16r5932 16r5472 16r5938 16r5473 16r593E 16r5474 16r7AD2 16r5475 16r5955 16r5476 16r5950 16r5477 16r594E 16r5478 16r595A 16r5479 16r5958 16r547A 16r5962 16r547B 16r5960 16r547C 16r5967 16r547D 16r596C 16r547E 16r5969 16r5521 16r5978 16r5522 16r5981 16r5523 16r599D 16r5524 16r4F5E 16r5525 16r4FAB 16r5526 16r59A3 16r5527 16r59B2 16r5528 16r59C6 16r5529 16r59E8 16r552A 16r59DC 16r552B 16r598D 16r552C 16r59D9 16r552D 16r59DA 16r552E 16r5A25 16r552F 16r5A1F 16r5530 16r5A11 16r5531 16r5A1C 16r5532 16r5A09 16r5533 16r5A1A 16r5534 16r5A40 16r5535 16r5A6C 16r5536 16r5A49 16r5537 16r5A35 16r5538 16r5A36 16r5539 16r5A62 16r553A 16r5A6A 16r553B 16r5A9A 16r553C 16r5ABC 16r553D 16r5ABE 16r553E 16r5ACB 16r553F 16r5AC2 16r5540 16r5ABD 16r5541 16r5AE3 16r5542 16r5AD7 16r5543 16r5AE6 16r5544 16r5AE9 16r5545 16r5AD6 16r5546 16r5AFA 16r5547 16r5AFB 16r5548 16r5B0C 16r5549 16r5B0B 16r554A 16r5B16 16r554B 16r5B32 16r554C 16r5AD0 16r554D 16r5B2A 16r554E 16r5B36 16r554F 16r5B3E 16r5550 16r5B43 16r5551 16r5B45 16r5552 16r5B40 16r5553 16r5B51 16r5554 16r5B55 16r5555 16r5B5A 16r5556 16r5B5B 16r5557 16r5B65 16r5558 16r5B69 16r5559 16r5B70 16r555A 16r5B73 16r555B 16r5B75 16r555C 16r5B78 16r555D 16r6588 16r555E 16r5B7A 16r555F 16r5B80 16r5560 16r5B83 16r5561 16r5BA6 16r5562 16r5BB8 16r5563 16r5BC3 16r5564 16r5BC7 16r5565 16r5BC9 16r5566 16r5BD4 16r5567 16r5BD0 16r5568 16r5BE4 16r5569 16r5BE6 16r556A 16r5BE2 16r556B 16r5BDE 16r556C 16r5BE5 16r556D 16r5BEB 16r556E 16r5BF0 16r556F 16r5BF6 16r5570 16r5BF3 16r5571 16r5C05 16r5572 16r5C07 16r5573 16r5C08 16r5574 16r5C0D 16r5575 16r5C13 16r5576 16r5C20 16r5577 16r5C22 16r5578 16r5C28 16r5579 16r5C38 16r557A 16r5C39 16r557B 16r5C41 16r557C 16r5C46 16r557D 16r5C4E 16r557E 16r5C53 16r5621 16r5C50 16r5622 16r5C4F 16r5623 16r5B71 16r5624 16r5C6C 16r5625 16r5C6E 16r5626 16r4E62 16r5627 16r5C76 16r5628 16r5C79 16r5629 16r5C8C 16r562A 16r5C91 16r562B 16r5C94 16r562C 16r599B 16r562D 16r5CAB 16r562E 16r5CBB 16r562F 16r5CB6 16r5630 16r5CBC 16r5631 16r5CB7 16r5632 16r5CC5 16r5633 16r5CBE 16r5634 16r5CC7 16r5635 16r5CD9 16r5636 16r5CE9 16r5637 16r5CFD 16r5638 16r5CFA 16r5639 16r5CED 16r563A 16r5D8C 16r563B 16r5CEA 16r563C 16r5D0B 16r563D 16r5D15 16r563E 16r5D17 16r563F 16r5D5C 16r5640 16r5D1F 16r5641 16r5D1B 16r5642 16r5D11 16r5643 16r5D14 16r5644 16r5D22 16r5645 16r5D1A 16r5646 16r5D19 16r5647 16r5D18 16r5648 16r5D4C 16r5649 16r5D52 16r564A 16r5D4E 16r564B 16r5D4B 16r564C 16r5D6C 16r564D 16r5D73 16r564E 16r5D76 16r564F 16r5D87 16r5650 16r5D84 16r5651 16r5D82 16r5652 16r5DA2 16r5653 16r5D9D 16r5654 16r5DAC 16r5655 16r5DAE 16r5656 16r5DBD 16r5657 16r5D90 16r5658 16r5DB7 16r5659 16r5DBC 16r565A 16r5DC9 16r565B 16r5DCD 16r565C 16r5DD3 16r565D 16r5DD2 16r565E 16r5DD6 16r565F 16r5DDB 16r5660 16r5DEB 16r5661 16r5DF2 16r5662 16r5DF5 16r5663 16r5E0B 16r5664 16r5E1A 16r5665 16r5E19 16r5666 16r5E11 16r5667 16r5E1B 16r5668 16r5E36 16r5669 16r5E37 16r566A 16r5E44 16r566B 16r5E43 16r566C 16r5E40 16r566D 16r5E4E 16r566E 16r5E57 16r566F 16r5E54 16r5670 16r5E5F 16r5671 16r5E62 16r5672 16r5E64 16r5673 16r5E47 16r5674 16r5E75 16r5675 16r5E76 16r5676 16r5E7A 16r5677 16r9EBC 16r5678 16r5E7F 16r5679 16r5EA0 16r567A 16r5EC1 16r567B 16r5EC2 16r567C 16r5EC8 16r567D 16r5ED0 16r567E 16r5ECF 16r5721 16r5ED6 16r5722 16r5EE3 16r5723 16r5EDD 16r5724 16r5EDA 16r5725 16r5EDB 16r5726 16r5EE2 16r5727 16r5EE1 16r5728 16r5EE8 16r5729 16r5EE9 16r572A 16r5EEC 16r572B 16r5EF1 16r572C 16r5EF3 16r572D 16r5EF0 16r572E 16r5EF4 16r572F 16r5EF8 16r5730 16r5EFE 16r5731 16r5F03 16r5732 16r5F09 16r5733 16r5F5D 16r5734 16r5F5C 16r5735 16r5F0B 16r5736 16r5F11 16r5737 16r5F16 16r5738 16r5F29 16r5739 16r5F2D 16r573A 16r5F38 16r573B 16r5F41 16r573C 16r5F48 16r573D 16r5F4C 16r573E 16r5F4E 16r573F 16r5F2F 16r5740 16r5F51 16r5741 16r5F56 16r5742 16r5F57 16r5743 16r5F59 16r5744 16r5F61 16r5745 16r5F6D 16r5746 16r5F73 16r5747 16r5F77 16r5748 16r5F83 16r5749 16r5F82 16r574A 16r5F7F 16r574B 16r5F8A 16r574C 16r5F88 16r574D 16r5F91 16r574E 16r5F87 16r574F 16r5F9E 16r5750 16r5F99 16r5751 16r5F98 16r5752 16r5FA0 16r5753 16r5FA8 16r5754 16r5FAD 16r5755 16r5FBC 16r5756 16r5FD6 16r5757 16r5FFB 16r5758 16r5FE4 16r5759 16r5FF8 16r575A 16r5FF1 16r575B 16r5FDD 16r575C 16r60B3 16r575D 16r5FFF 16r575E 16r6021 16r575F 16r6060 16r5760 16r6019 16r5761 16r6010 16r5762 16r6029 16r5763 16r600E 16r5764 16r6031 16r5765 16r601B 16r5766 16r6015 16r5767 16r602B 16r5768 16r6026 16r5769 16r600F 16r576A 16r603A 16r576B 16r605A 16r576C 16r6041 16r576D 16r606A 16r576E 16r6077 16r576F 16r605F 16r5770 16r604A 16r5771 16r6046 16r5772 16r604D 16r5773 16r6063 16r5774 16r6043 16r5775 16r6064 16r5776 16r6042 16r5777 16r606C 16r5778 16r606B 16r5779 16r6059 16r577A 16r6081 16r577B 16r608D 16r577C 16r60E7 16r577D 16r6083 16r577E 16r609A 16r5821 16r6084 16r5822 16r609B 16r5823 16r6096 16r5824 16r6097 16r5825 16r6092 16r5826 16r60A7 16r5827 16r608B 16r5828 16r60E1 16r5829 16r60B8 16r582A 16r60E0 16r582B 16r60D3 16r582C 16r60B4 16r582D 16r5FF0 16r582E 16r60BD 16r582F 16r60C6 16r5830 16r60B5 16r5831 16r60D8 16r5832 16r614D 16r5833 16r6115 16r5834 16r6106 16r5835 16r60F6 16r5836 16r60F7 16r5837 16r6100 16r5838 16r60F4 16r5839 16r60FA 16r583A 16r6103 16r583B 16r6121 16r583C 16r60FB 16r583D 16r60F1 16r583E 16r610D 16r583F 16r610E 16r5840 16r6147 16r5841 16r613E 16r5842 16r6128 16r5843 16r6127 16r5844 16r614A 16r5845 16r613F 16r5846 16r613C 16r5847 16r612C 16r5848 16r6134 16r5849 16r613D 16r584A 16r6142 16r584B 16r6144 16r584C 16r6173 16r584D 16r6177 16r584E 16r6158 16r584F 16r6159 16r5850 16r615A 16r5851 16r616B 16r5852 16r6174 16r5853 16r616F 16r5854 16r6165 16r5855 16r6171 16r5856 16r615F 16r5857 16r615D 16r5858 16r6153 16r5859 16r6175 16r585A 16r6199 16r585B 16r6196 16r585C 16r6187 16r585D 16r61AC 16r585E 16r6194 16r585F 16r619A 16r5860 16r618A 16r5861 16r6191 16r5862 16r61AB 16r5863 16r61AE 16r5864 16r61CC 16r5865 16r61CA 16r5866 16r61C9 16r5867 16r61F7 16r5868 16r61C8 16r5869 16r61C3 16r586A 16r61C6 16r586B 16r61BA 16r586C 16r61CB 16r586D 16r7F79 16r586E 16r61CD 16r586F 16r61E6 16r5870 16r61E3 16r5871 16r61F6 16r5872 16r61FA 16r5873 16r61F4 16r5874 16r61FF 16r5875 16r61FD 16r5876 16r61FC 16r5877 16r61FE 16r5878 16r6200 16r5879 16r6208 16r587A 16r6209 16r587B 16r620D 16r587C 16r620C 16r587D 16r6214 16r587E 16r621B 16r5921 16r621E 16r5922 16r6221 16r5923 16r622A 16r5924 16r622E 16r5925 16r6230 16r5926 16r6232 16r5927 16r6233 16r5928 16r6241 16r5929 16r624E 16r592A 16r625E 16r592B 16r6263 16r592C 16r625B 16r592D 16r6260 16r592E 16r6268 16r592F 16r627C 16r5930 16r6282 16r5931 16r6289 16r5932 16r627E 16r5933 16r6292 16r5934 16r6293 16r5935 16r6296 16r5936 16r62D4 16r5937 16r6283 16r5938 16r6294 16r5939 16r62D7 16r593A 16r62D1 16r593B 16r62BB 16r593C 16r62CF 16r593D 16r62FF 16r593E 16r62C6 16r593F 16r64D4 16r5940 16r62C8 16r5941 16r62DC 16r5942 16r62CC 16r5943 16r62CA 16r5944 16r62C2 16r5945 16r62C7 16r5946 16r629B 16r5947 16r62C9 16r5948 16r630C 16r5949 16r62EE 16r594A 16r62F1 16r594B 16r6327 16r594C 16r6302 16r594D 16r6308 16r594E 16r62EF 16r594F 16r62F5 16r5950 16r6350 16r5951 16r633E 16r5952 16r634D 16r5953 16r641C 16r5954 16r634F 16r5955 16r6396 16r5956 16r638E 16r5957 16r6380 16r5958 16r63AB 16r5959 16r6376 16r595A 16r63A3 16r595B 16r638F 16r595C 16r6389 16r595D 16r639F 16r595E 16r63B5 16r595F 16r636B 16r5960 16r6369 16r5961 16r63BE 16r5962 16r63E9 16r5963 16r63C0 16r5964 16r63C6 16r5965 16r63E3 16r5966 16r63C9 16r5967 16r63D2 16r5968 16r63F6 16r5969 16r63C4 16r596A 16r6416 16r596B 16r6434 16r596C 16r6406 16r596D 16r6413 16r596E 16r6426 16r596F 16r6436 16r5970 16r651D 16r5971 16r6417 16r5972 16r6428 16r5973 16r640F 16r5974 16r6467 16r5975 16r646F 16r5976 16r6476 16r5977 16r644E 16r5978 16r652A 16r5979 16r6495 16r597A 16r6493 16r597B 16r64A5 16r597C 16r64A9 16r597D 16r6488 16r597E 16r64BC 16r5A21 16r64DA 16r5A22 16r64D2 16r5A23 16r64C5 16r5A24 16r64C7 16r5A25 16r64BB 16r5A26 16r64D8 16r5A27 16r64C2 16r5A28 16r64F1 16r5A29 16r64E7 16r5A2A 16r8209 16r5A2B 16r64E0 16r5A2C 16r64E1 16r5A2D 16r62AC 16r5A2E 16r64E3 16r5A2F 16r64EF 16r5A30 16r652C 16r5A31 16r64F6 16r5A32 16r64F4 16r5A33 16r64F2 16r5A34 16r64FA 16r5A35 16r6500 16r5A36 16r64FD 16r5A37 16r6518 16r5A38 16r651C 16r5A39 16r6505 16r5A3A 16r6524 16r5A3B 16r6523 16r5A3C 16r652B 16r5A3D 16r6534 16r5A3E 16r6535 16r5A3F 16r6537 16r5A40 16r6536 16r5A41 16r6538 16r5A42 16r754B 16r5A43 16r6548 16r5A44 16r6556 16r5A45 16r6555 16r5A46 16r654D 16r5A47 16r6558 16r5A48 16r655E 16r5A49 16r655D 16r5A4A 16r6572 16r5A4B 16r6578 16r5A4C 16r6582 16r5A4D 16r6583 16r5A4E 16r8B8A 16r5A4F 16r659B 16r5A50 16r659F 16r5A51 16r65AB 16r5A52 16r65B7 16r5A53 16r65C3 16r5A54 16r65C6 16r5A55 16r65C1 16r5A56 16r65C4 16r5A57 16r65CC 16r5A58 16r65D2 16r5A59 16r65DB 16r5A5A 16r65D9 16r5A5B 16r65E0 16r5A5C 16r65E1 16r5A5D 16r65F1 16r5A5E 16r6772 16r5A5F 16r660A 16r5A60 16r6603 16r5A61 16r65FB 16r5A62 16r6773 16r5A63 16r6635 16r5A64 16r6636 16r5A65 16r6634 16r5A66 16r661C 16r5A67 16r664F 16r5A68 16r6644 16r5A69 16r6649 16r5A6A 16r6641 16r5A6B 16r665E 16r5A6C 16r665D 16r5A6D 16r6664 16r5A6E 16r6667 16r5A6F 16r6668 16r5A70 16r665F 16r5A71 16r6662 16r5A72 16r6670 16r5A73 16r6683 16r5A74 16r6688 16r5A75 16r668E 16r5A76 16r6689 16r5A77 16r6684 16r5A78 16r6698 16r5A79 16r669D 16r5A7A 16r66C1 16r5A7B 16r66B9 16r5A7C 16r66C9 16r5A7D 16r66BE 16r5A7E 16r66BC 16r5B21 16r66C4 16r5B22 16r66B8 16r5B23 16r66D6 16r5B24 16r66DA 16r5B25 16r66E0 16r5B26 16r663F 16r5B27 16r66E6 16r5B28 16r66E9 16r5B29 16r66F0 16r5B2A 16r66F5 16r5B2B 16r66F7 16r5B2C 16r670F 16r5B2D 16r6716 16r5B2E 16r671E 16r5B2F 16r6726 16r5B30 16r6727 16r5B31 16r9738 16r5B32 16r672E 16r5B33 16r673F 16r5B34 16r6736 16r5B35 16r6741 16r5B36 16r6738 16r5B37 16r6737 16r5B38 16r6746 16r5B39 16r675E 16r5B3A 16r6760 16r5B3B 16r6759 16r5B3C 16r6763 16r5B3D 16r6764 16r5B3E 16r6789 16r5B3F 16r6770 16r5B40 16r67A9 16r5B41 16r677C 16r5B42 16r676A 16r5B43 16r678C 16r5B44 16r678B 16r5B45 16r67A6 16r5B46 16r67A1 16r5B47 16r6785 16r5B48 16r67B7 16r5B49 16r67EF 16r5B4A 16r67B4 16r5B4B 16r67EC 16r5B4C 16r67B3 16r5B4D 16r67E9 16r5B4E 16r67B8 16r5B4F 16r67E4 16r5B50 16r67DE 16r5B51 16r67DD 16r5B52 16r67E2 16r5B53 16r67EE 16r5B54 16r67B9 16r5B55 16r67CE 16r5B56 16r67C6 16r5B57 16r67E7 16r5B58 16r6A9C 16r5B59 16r681E 16r5B5A 16r6846 16r5B5B 16r6829 16r5B5C 16r6840 16r5B5D 16r684D 16r5B5E 16r6832 16r5B5F 16r684E 16r5B60 16r68B3 16r5B61 16r682B 16r5B62 16r6859 16r5B63 16r6863 16r5B64 16r6877 16r5B65 16r687F 16r5B66 16r689F 16r5B67 16r688F 16r5B68 16r68AD 16r5B69 16r6894 16r5B6A 16r689D 16r5B6B 16r689B 16r5B6C 16r6883 16r5B6D 16r6AAE 16r5B6E 16r68B9 16r5B6F 16r6874 16r5B70 16r68B5 16r5B71 16r68A0 16r5B72 16r68BA 16r5B73 16r690F 16r5B74 16r688D 16r5B75 16r687E 16r5B76 16r6901 16r5B77 16r68CA 16r5B78 16r6908 16r5B79 16r68D8 16r5B7A 16r6922 16r5B7B 16r6926 16r5B7C 16r68E1 16r5B7D 16r690C 16r5B7E 16r68CD 16r5C21 16r68D4 16r5C22 16r68E7 16r5C23 16r68D5 16r5C24 16r6936 16r5C25 16r6912 16r5C26 16r6904 16r5C27 16r68D7 16r5C28 16r68E3 16r5C29 16r6925 16r5C2A 16r68F9 16r5C2B 16r68E0 16r5C2C 16r68EF 16r5C2D 16r6928 16r5C2E 16r692A 16r5C2F 16r691A 16r5C30 16r6923 16r5C31 16r6921 16r5C32 16r68C6 16r5C33 16r6979 16r5C34 16r6977 16r5C35 16r695C 16r5C36 16r6978 16r5C37 16r696B 16r5C38 16r6954 16r5C39 16r697E 16r5C3A 16r696E 16r5C3B 16r6939 16r5C3C 16r6974 16r5C3D 16r693D 16r5C3E 16r6959 16r5C3F 16r6930 16r5C40 16r6961 16r5C41 16r695E 16r5C42 16r695D 16r5C43 16r6981 16r5C44 16r696A 16r5C45 16r69B2 16r5C46 16r69AE 16r5C47 16r69D0 16r5C48 16r69BF 16r5C49 16r69C1 16r5C4A 16r69D3 16r5C4B 16r69BE 16r5C4C 16r69CE 16r5C4D 16r5BE8 16r5C4E 16r69CA 16r5C4F 16r69DD 16r5C50 16r69BB 16r5C51 16r69C3 16r5C52 16r69A7 16r5C53 16r6A2E 16r5C54 16r6991 16r5C55 16r69A0 16r5C56 16r699C 16r5C57 16r6995 16r5C58 16r69B4 16r5C59 16r69DE 16r5C5A 16r69E8 16r5C5B 16r6A02 16r5C5C 16r6A1B 16r5C5D 16r69FF 16r5C5E 16r6B0A 16r5C5F 16r69F9 16r5C60 16r69F2 16r5C61 16r69E7 16r5C62 16r6A05 16r5C63 16r69B1 16r5C64 16r6A1E 16r5C65 16r69ED 16r5C66 16r6A14 16r5C67 16r69EB 16r5C68 16r6A0A 16r5C69 16r6A12 16r5C6A 16r6AC1 16r5C6B 16r6A23 16r5C6C 16r6A13 16r5C6D 16r6A44 16r5C6E 16r6A0C 16r5C6F 16r6A72 16r5C70 16r6A36 16r5C71 16r6A78 16r5C72 16r6A47 16r5C73 16r6A62 16r5C74 16r6A59 16r5C75 16r6A66 16r5C76 16r6A48 16r5C77 16r6A38 16r5C78 16r6A22 16r5C79 16r6A90 16r5C7A 16r6A8D 16r5C7B 16r6AA0 16r5C7C 16r6A84 16r5C7D 16r6AA2 16r5C7E 16r6AA3 16r5D21 16r6A97 16r5D22 16r8617 16r5D23 16r6ABB 16r5D24 16r6AC3 16r5D25 16r6AC2 16r5D26 16r6AB8 16r5D27 16r6AB3 16r5D28 16r6AAC 16r5D29 16r6ADE 16r5D2A 16r6AD1 16r5D2B 16r6ADF 16r5D2C 16r6AAA 16r5D2D 16r6ADA 16r5D2E 16r6AEA 16r5D2F 16r6AFB 16r5D30 16r6B05 16r5D31 16r8616 16r5D32 16r6AFA 16r5D33 16r6B12 16r5D34 16r6B16 16r5D35 16r9B31 16r5D36 16r6B1F 16r5D37 16r6B38 16r5D38 16r6B37 16r5D39 16r76DC 16r5D3A 16r6B39 16r5D3B 16r98EE 16r5D3C 16r6B47 16r5D3D 16r6B43 16r5D3E 16r6B49 16r5D3F 16r6B50 16r5D40 16r6B59 16r5D41 16r6B54 16r5D42 16r6B5B 16r5D43 16r6B5F 16r5D44 16r6B61 16r5D45 16r6B78 16r5D46 16r6B79 16r5D47 16r6B7F 16r5D48 16r6B80 16r5D49 16r6B84 16r5D4A 16r6B83 16r5D4B 16r6B8D 16r5D4C 16r6B98 16r5D4D 16r6B95 16r5D4E 16r6B9E 16r5D4F 16r6BA4 16r5D50 16r6BAA 16r5D51 16r6BAB 16r5D52 16r6BAF 16r5D53 16r6BB2 16r5D54 16r6BB1 16r5D55 16r6BB3 16r5D56 16r6BB7 16r5D57 16r6BBC 16r5D58 16r6BC6 16r5D59 16r6BCB 16r5D5A 16r6BD3 16r5D5B 16r6BDF 16r5D5C 16r6BEC 16r5D5D 16r6BEB 16r5D5E 16r6BF3 16r5D5F 16r6BEF 16r5D60 16r9EBE 16r5D61 16r6C08 16r5D62 16r6C13 16r5D63 16r6C14 16r5D64 16r6C1B 16r5D65 16r6C24 16r5D66 16r6C23 16r5D67 16r6C5E 16r5D68 16r6C55 16r5D69 16r6C62 16r5D6A 16r6C6A 16r5D6B 16r6C82 16r5D6C 16r6C8D 16r5D6D 16r6C9A 16r5D6E 16r6C81 16r5D6F 16r6C9B 16r5D70 16r6C7E 16r5D71 16r6C68 16r5D72 16r6C73 16r5D73 16r6C92 16r5D74 16r6C90 16r5D75 16r6CC4 16r5D76 16r6CF1 16r5D77 16r6CD3 16r5D78 16r6CBD 16r5D79 16r6CD7 16r5D7A 16r6CC5 16r5D7B 16r6CDD 16r5D7C 16r6CAE 16r5D7D 16r6CB1 16r5D7E 16r6CBE 16r5E21 16r6CBA 16r5E22 16r6CDB 16r5E23 16r6CEF 16r5E24 16r6CD9 16r5E25 16r6CEA 16r5E26 16r6D1F 16r5E27 16r884D 16r5E28 16r6D36 16r5E29 16r6D2B 16r5E2A 16r6D3D 16r5E2B 16r6D38 16r5E2C 16r6D19 16r5E2D 16r6D35 16r5E2E 16r6D33 16r5E2F 16r6D12 16r5E30 16r6D0C 16r5E31 16r6D63 16r5E32 16r6D93 16r5E33 16r6D64 16r5E34 16r6D5A 16r5E35 16r6D79 16r5E36 16r6D59 16r5E37 16r6D8E 16r5E38 16r6D95 16r5E39 16r6FE4 16r5E3A 16r6D85 16r5E3B 16r6DF9 16r5E3C 16r6E15 16r5E3D 16r6E0A 16r5E3E 16r6DB5 16r5E3F 16r6DC7 16r5E40 16r6DE6 16r5E41 16r6DB8 16r5E42 16r6DC6 16r5E43 16r6DEC 16r5E44 16r6DDE 16r5E45 16r6DCC 16r5E46 16r6DE8 16r5E47 16r6DD2 16r5E48 16r6DC5 16r5E49 16r6DFA 16r5E4A 16r6DD9 16r5E4B 16r6DE4 16r5E4C 16r6DD5 16r5E4D 16r6DEA 16r5E4E 16r6DEE 16r5E4F 16r6E2D 16r5E50 16r6E6E 16r5E51 16r6E2E 16r5E52 16r6E19 16r5E53 16r6E72 16r5E54 16r6E5F 16r5E55 16r6E3E 16r5E56 16r6E23 16r5E57 16r6E6B 16r5E58 16r6E2B 16r5E59 16r6E76 16r5E5A 16r6E4D 16r5E5B 16r6E1F 16r5E5C 16r6E43 16r5E5D 16r6E3A 16r5E5E 16r6E4E 16r5E5F 16r6E24 16r5E60 16r6EFF 16r5E61 16r6E1D 16r5E62 16r6E38 16r5E63 16r6E82 16r5E64 16r6EAA 16r5E65 16r6E98 16r5E66 16r6EC9 16r5E67 16r6EB7 16r5E68 16r6ED3 16r5E69 16r6EBD 16r5E6A 16r6EAF 16r5E6B 16r6EC4 16r5E6C 16r6EB2 16r5E6D 16r6ED4 16r5E6E 16r6ED5 16r5E6F 16r6E8F 16r5E70 16r6EA5 16r5E71 16r6EC2 16r5E72 16r6E9F 16r5E73 16r6F41 16r5E74 16r6F11 16r5E75 16r704C 16r5E76 16r6EEC 16r5E77 16r6EF8 16r5E78 16r6EFE 16r5E79 16r6F3F 16r5E7A 16r6EF2 16r5E7B 16r6F31 16r5E7C 16r6EEF 16r5E7D 16r6F32 16r5E7E 16r6ECC 16r5F21 16r6F3E 16r5F22 16r6F13 16r5F23 16r6EF7 16r5F24 16r6F86 16r5F25 16r6F7A 16r5F26 16r6F78 16r5F27 16r6F81 16r5F28 16r6F80 16r5F29 16r6F6F 16r5F2A 16r6F5B 16r5F2B 16r6FF3 16r5F2C 16r6F6D 16r5F2D 16r6F82 16r5F2E 16r6F7C 16r5F2F 16r6F58 16r5F30 16r6F8E 16r5F31 16r6F91 16r5F32 16r6FC2 16r5F33 16r6F66 16r5F34 16r6FB3 16r5F35 16r6FA3 16r5F36 16r6FA1 16r5F37 16r6FA4 16r5F38 16r6FB9 16r5F39 16r6FC6 16r5F3A 16r6FAA 16r5F3B 16r6FDF 16r5F3C 16r6FD5 16r5F3D 16r6FEC 16r5F3E 16r6FD4 16r5F3F 16r6FD8 16r5F40 16r6FF1 16r5F41 16r6FEE 16r5F42 16r6FDB 16r5F43 16r7009 16r5F44 16r700B 16r5F45 16r6FFA 16r5F46 16r7011 16r5F47 16r7001 16r5F48 16r700F 16r5F49 16r6FFE 16r5F4A 16r701B 16r5F4B 16r701A 16r5F4C 16r6F74 16r5F4D 16r701D 16r5F4E 16r7018 16r5F4F 16r701F 16r5F50 16r7030 16r5F51 16r703E 16r5F52 16r7032 16r5F53 16r7051 16r5F54 16r7063 16r5F55 16r7099 16r5F56 16r7092 16r5F57 16r70AF 16r5F58 16r70F1 16r5F59 16r70AC 16r5F5A 16r70B8 16r5F5B 16r70B3 16r5F5C 16r70AE 16r5F5D 16r70DF 16r5F5E 16r70CB 16r5F5F 16r70DD 16r5F60 16r70D9 16r5F61 16r7109 16r5F62 16r70FD 16r5F63 16r711C 16r5F64 16r7119 16r5F65 16r7165 16r5F66 16r7155 16r5F67 16r7188 16r5F68 16r7166 16r5F69 16r7162 16r5F6A 16r714C 16r5F6B 16r7156 16r5F6C 16r716C 16r5F6D 16r718F 16r5F6E 16r71FB 16r5F6F 16r7184 16r5F70 16r7195 16r5F71 16r71A8 16r5F72 16r71AC 16r5F73 16r71D7 16r5F74 16r71B9 16r5F75 16r71BE 16r5F76 16r71D2 16r5F77 16r71C9 16r5F78 16r71D4 16r5F79 16r71CE 16r5F7A 16r71E0 16r5F7B 16r71EC 16r5F7C 16r71E7 16r5F7D 16r71F5 16r5F7E 16r71FC 16r6021 16r71F9 16r6022 16r71FF 16r6023 16r720D 16r6024 16r7210 16r6025 16r721B 16r6026 16r7228 16r6027 16r722D 16r6028 16r722C 16r6029 16r7230 16r602A 16r7232 16r602B 16r723B 16r602C 16r723C 16r602D 16r723F 16r602E 16r7240 16r602F 16r7246 16r6030 16r724B 16r6031 16r7258 16r6032 16r7274 16r6033 16r727E 16r6034 16r7282 16r6035 16r7281 16r6036 16r7287 16r6037 16r7292 16r6038 16r7296 16r6039 16r72A2 16r603A 16r72A7 16r603B 16r72B9 16r603C 16r72B2 16r603D 16r72C3 16r603E 16r72C6 16r603F 16r72C4 16r6040 16r72CE 16r6041 16r72D2 16r6042 16r72E2 16r6043 16r72E0 16r6044 16r72E1 16r6045 16r72F9 16r6046 16r72F7 16r6047 16r500F 16r6048 16r7317 16r6049 16r730A 16r604A 16r731C 16r604B 16r7316 16r604C 16r731D 16r604D 16r7334 16r604E 16r732F 16r604F 16r7329 16r6050 16r7325 16r6051 16r733E 16r6052 16r734E 16r6053 16r734F 16r6054 16r9ED8 16r6055 16r7357 16r6056 16r736A 16r6057 16r7368 16r6058 16r7370 16r6059 16r7378 16r605A 16r7375 16r605B 16r737B 16r605C 16r737A 16r605D 16r73C8 16r605E 16r73B3 16r605F 16r73CE 16r6060 16r73BB 16r6061 16r73C0 16r6062 16r73E5 16r6063 16r73EE 16r6064 16r73DE 16r6065 16r74A2 16r6066 16r7405 16r6067 16r746F 16r6068 16r7425 16r6069 16r73F8 16r606A 16r7432 16r606B 16r743A 16r606C 16r7455 16r606D 16r743F 16r606E 16r745F 16r606F 16r7459 16r6070 16r7441 16r6071 16r745C 16r6072 16r7469 16r6073 16r7470 16r6074 16r7463 16r6075 16r746A 16r6076 16r7476 16r6077 16r747E 16r6078 16r748B 16r6079 16r749E 16r607A 16r74A7 16r607B 16r74CA 16r607C 16r74CF 16r607D 16r74D4 16r607E 16r73F1 16r6121 16r74E0 16r6122 16r74E3 16r6123 16r74E7 16r6124 16r74E9 16r6125 16r74EE 16r6126 16r74F2 16r6127 16r74F0 16r6128 16r74F1 16r6129 16r74F8 16r612A 16r74F7 16r612B 16r7504 16r612C 16r7503 16r612D 16r7505 16r612E 16r750C 16r612F 16r750E 16r6130 16r750D 16r6131 16r7515 16r6132 16r7513 16r6133 16r751E 16r6134 16r7526 16r6135 16r752C 16r6136 16r753C 16r6137 16r7544 16r6138 16r754D 16r6139 16r754A 16r613A 16r7549 16r613B 16r755B 16r613C 16r7546 16r613D 16r755A 16r613E 16r7569 16r613F 16r7564 16r6140 16r7567 16r6141 16r756B 16r6142 16r756D 16r6143 16r7578 16r6144 16r7576 16r6145 16r7586 16r6146 16r7587 16r6147 16r7574 16r6148 16r758A 16r6149 16r7589 16r614A 16r7582 16r614B 16r7594 16r614C 16r759A 16r614D 16r759D 16r614E 16r75A5 16r614F 16r75A3 16r6150 16r75C2 16r6151 16r75B3 16r6152 16r75C3 16r6153 16r75B5 16r6154 16r75BD 16r6155 16r75B8 16r6156 16r75BC 16r6157 16r75B1 16r6158 16r75CD 16r6159 16r75CA 16r615A 16r75D2 16r615B 16r75D9 16r615C 16r75E3 16r615D 16r75DE 16r615E 16r75FE 16r615F 16r75FF 16r6160 16r75FC 16r6161 16r7601 16r6162 16r75F0 16r6163 16r75FA 16r6164 16r75F2 16r6165 16r75F3 16r6166 16r760B 16r6167 16r760D 16r6168 16r7609 16r6169 16r761F 16r616A 16r7627 16r616B 16r7620 16r616C 16r7621 16r616D 16r7622 16r616E 16r7624 16r616F 16r7634 16r6170 16r7630 16r6171 16r763B 16r6172 16r7647 16r6173 16r7648 16r6174 16r7646 16r6175 16r765C 16r6176 16r7658 16r6177 16r7661 16r6178 16r7662 16r6179 16r7668 16r617A 16r7669 16r617B 16r766A 16r617C 16r7667 16r617D 16r766C 16r617E 16r7670 16r6221 16r7672 16r6222 16r7676 16r6223 16r7678 16r6224 16r767C 16r6225 16r7680 16r6226 16r7683 16r6227 16r7688 16r6228 16r768B 16r6229 16r768E 16r622A 16r7696 16r622B 16r7693 16r622C 16r7699 16r622D 16r769A 16r622E 16r76B0 16r622F 16r76B4 16r6230 16r76B8 16r6231 16r76B9 16r6232 16r76BA 16r6233 16r76C2 16r6234 16r76CD 16r6235 16r76D6 16r6236 16r76D2 16r6237 16r76DE 16r6238 16r76E1 16r6239 16r76E5 16r623A 16r76E7 16r623B 16r76EA 16r623C 16r862F 16r623D 16r76FB 16r623E 16r7708 16r623F 16r7707 16r6240 16r7704 16r6241 16r7729 16r6242 16r7724 16r6243 16r771E 16r6244 16r7725 16r6245 16r7726 16r6246 16r771B 16r6247 16r7737 16r6248 16r7738 16r6249 16r7747 16r624A 16r775A 16r624B 16r7768 16r624C 16r776B 16r624D 16r775B 16r624E 16r7765 16r624F 16r777F 16r6250 16r777E 16r6251 16r7779 16r6252 16r778E 16r6253 16r778B 16r6254 16r7791 16r6255 16r77A0 16r6256 16r779E 16r6257 16r77B0 16r6258 16r77B6 16r6259 16r77B9 16r625A 16r77BF 16r625B 16r77BC 16r625C 16r77BD 16r625D 16r77BB 16r625E 16r77C7 16r625F 16r77CD 16r6260 16r77D7 16r6261 16r77DA 16r6262 16r77DC 16r6263 16r77E3 16r6264 16r77EE 16r6265 16r77FC 16r6266 16r780C 16r6267 16r7812 16r6268 16r7926 16r6269 16r7820 16r626A 16r792A 16r626B 16r7845 16r626C 16r788E 16r626D 16r7874 16r626E 16r7886 16r626F 16r787C 16r6270 16r789A 16r6271 16r788C 16r6272 16r78A3 16r6273 16r78B5 16r6274 16r78AA 16r6275 16r78AF 16r6276 16r78D1 16r6277 16r78C6 16r6278 16r78CB 16r6279 16r78D4 16r627A 16r78BE 16r627B 16r78BC 16r627C 16r78C5 16r627D 16r78CA 16r627E 16r78EC 16r6321 16r78E7 16r6322 16r78DA 16r6323 16r78FD 16r6324 16r78F4 16r6325 16r7907 16r6326 16r7912 16r6327 16r7911 16r6328 16r7919 16r6329 16r792C 16r632A 16r792B 16r632B 16r7940 16r632C 16r7960 16r632D 16r7957 16r632E 16r795F 16r632F 16r795A 16r6330 16r7955 16r6331 16r7953 16r6332 16r797A 16r6333 16r797F 16r6334 16r798A 16r6335 16r799D 16r6336 16r79A7 16r6337 16r9F4B 16r6338 16r79AA 16r6339 16r79AE 16r633A 16r79B3 16r633B 16r79B9 16r633C 16r79BA 16r633D 16r79C9 16r633E 16r79D5 16r633F 16r79E7 16r6340 16r79EC 16r6341 16r79E1 16r6342 16r79E3 16r6343 16r7A08 16r6344 16r7A0D 16r6345 16r7A18 16r6346 16r7A19 16r6347 16r7A20 16r6348 16r7A1F 16r6349 16r7980 16r634A 16r7A31 16r634B 16r7A3B 16r634C 16r7A3E 16r634D 16r7A37 16r634E 16r7A43 16r634F 16r7A57 16r6350 16r7A49 16r6351 16r7A61 16r6352 16r7A62 16r6353 16r7A69 16r6354 16r9F9D 16r6355 16r7A70 16r6356 16r7A79 16r6357 16r7A7D 16r6358 16r7A88 16r6359 16r7A97 16r635A 16r7A95 16r635B 16r7A98 16r635C 16r7A96 16r635D 16r7AA9 16r635E 16r7AC8 16r635F 16r7AB0 16r6360 16r7AB6 16r6361 16r7AC5 16r6362 16r7AC4 16r6363 16r7ABF 16r6364 16r9083 16r6365 16r7AC7 16r6366 16r7ACA 16r6367 16r7ACD 16r6368 16r7ACF 16r6369 16r7AD5 16r636A 16r7AD3 16r636B 16r7AD9 16r636C 16r7ADA 16r636D 16r7ADD 16r636E 16r7AE1 16r636F 16r7AE2 16r6370 16r7AE6 16r6371 16r7AED 16r6372 16r7AF0 16r6373 16r7B02 16r6374 16r7B0F 16r6375 16r7B0A 16r6376 16r7B06 16r6377 16r7B33 16r6378 16r7B18 16r6379 16r7B19 16r637A 16r7B1E 16r637B 16r7B35 16r637C 16r7B28 16r637D 16r7B36 16r637E 16r7B50 16r6421 16r7B7A 16r6422 16r7B04 16r6423 16r7B4D 16r6424 16r7B0B 16r6425 16r7B4C 16r6426 16r7B45 16r6427 16r7B75 16r6428 16r7B65 16r6429 16r7B74 16r642A 16r7B67 16r642B 16r7B70 16r642C 16r7B71 16r642D 16r7B6C 16r642E 16r7B6E 16r642F 16r7B9D 16r6430 16r7B98 16r6431 16r7B9F 16r6432 16r7B8D 16r6433 16r7B9C 16r6434 16r7B9A 16r6435 16r7B8B 16r6436 16r7B92 16r6437 16r7B8F 16r6438 16r7B5D 16r6439 16r7B99 16r643A 16r7BCB 16r643B 16r7BC1 16r643C 16r7BCC 16r643D 16r7BCF 16r643E 16r7BB4 16r643F 16r7BC6 16r6440 16r7BDD 16r6441 16r7BE9 16r6442 16r7C11 16r6443 16r7C14 16r6444 16r7BE6 16r6445 16r7BE5 16r6446 16r7C60 16r6447 16r7C00 16r6448 16r7C07 16r6449 16r7C13 16r644A 16r7BF3 16r644B 16r7BF7 16r644C 16r7C17 16r644D 16r7C0D 16r644E 16r7BF6 16r644F 16r7C23 16r6450 16r7C27 16r6451 16r7C2A 16r6452 16r7C1F 16r6453 16r7C37 16r6454 16r7C2B 16r6455 16r7C3D 16r6456 16r7C4C 16r6457 16r7C43 16r6458 16r7C54 16r6459 16r7C4F 16r645A 16r7C40 16r645B 16r7C50 16r645C 16r7C58 16r645D 16r7C5F 16r645E 16r7C64 16r645F 16r7C56 16r6460 16r7C65 16r6461 16r7C6C 16r6462 16r7C75 16r6463 16r7C83 16r6464 16r7C90 16r6465 16r7CA4 16r6466 16r7CAD 16r6467 16r7CA2 16r6468 16r7CAB 16r6469 16r7CA1 16r646A 16r7CA8 16r646B 16r7CB3 16r646C 16r7CB2 16r646D 16r7CB1 16r646E 16r7CAE 16r646F 16r7CB9 16r6470 16r7CBD 16r6471 16r7CC0 16r6472 16r7CC5 16r6473 16r7CC2 16r6474 16r7CD8 16r6475 16r7CD2 16r6476 16r7CDC 16r6477 16r7CE2 16r6478 16r9B3B 16r6479 16r7CEF 16r647A 16r7CF2 16r647B 16r7CF4 16r647C 16r7CF6 16r647D 16r7CFA 16r647E 16r7D06 16r6521 16r7D02 16r6522 16r7D1C 16r6523 16r7D15 16r6524 16r7D0A 16r6525 16r7D45 16r6526 16r7D4B 16r6527 16r7D2E 16r6528 16r7D32 16r6529 16r7D3F 16r652A 16r7D35 16r652B 16r7D46 16r652C 16r7D73 16r652D 16r7D56 16r652E 16r7D4E 16r652F 16r7D72 16r6530 16r7D68 16r6531 16r7D6E 16r6532 16r7D4F 16r6533 16r7D63 16r6534 16r7D93 16r6535 16r7D89 16r6536 16r7D5B 16r6537 16r7D8F 16r6538 16r7D7D 16r6539 16r7D9B 16r653A 16r7DBA 16r653B 16r7DAE 16r653C 16r7DA3 16r653D 16r7DB5 16r653E 16r7DC7 16r653F 16r7DBD 16r6540 16r7DAB 16r6541 16r7E3D 16r6542 16r7DA2 16r6543 16r7DAF 16r6544 16r7DDC 16r6545 16r7DB8 16r6546 16r7D9F 16r6547 16r7DB0 16r6548 16r7DD8 16r6549 16r7DDD 16r654A 16r7DE4 16r654B 16r7DDE 16r654C 16r7DFB 16r654D 16r7DF2 16r654E 16r7DE1 16r654F 16r7E05 16r6550 16r7E0A 16r6551 16r7E23 16r6552 16r7E21 16r6553 16r7E12 16r6554 16r7E31 16r6555 16r7E1F 16r6556 16r7E09 16r6557 16r7E0B 16r6558 16r7E22 16r6559 16r7E46 16r655A 16r7E66 16r655B 16r7E3B 16r655C 16r7E35 16r655D 16r7E39 16r655E 16r7E43 16r655F 16r7E37 16r6560 16r7E32 16r6561 16r7E3A 16r6562 16r7E67 16r6563 16r7E5D 16r6564 16r7E56 16r6565 16r7E5E 16r6566 16r7E59 16r6567 16r7E5A 16r6568 16r7E79 16r6569 16r7E6A 16r656A 16r7E69 16r656B 16r7E7C 16r656C 16r7E7B 16r656D 16r7E83 16r656E 16r7DD5 16r656F 16r7E7D 16r6570 16r8FAE 16r6571 16r7E7F 16r6572 16r7E88 16r6573 16r7E89 16r6574 16r7E8C 16r6575 16r7E92 16r6576 16r7E90 16r6577 16r7E93 16r6578 16r7E94 16r6579 16r7E96 16r657A 16r7E8E 16r657B 16r7E9B 16r657C 16r7E9C 16r657D 16r7F38 16r657E 16r7F3A 16r6621 16r7F45 16r6622 16r7F4C 16r6623 16r7F4D 16r6624 16r7F4E 16r6625 16r7F50 16r6626 16r7F51 16r6627 16r7F55 16r6628 16r7F54 16r6629 16r7F58 16r662A 16r7F5F 16r662B 16r7F60 16r662C 16r7F68 16r662D 16r7F69 16r662E 16r7F67 16r662F 16r7F78 16r6630 16r7F82 16r6631 16r7F86 16r6632 16r7F83 16r6633 16r7F88 16r6634 16r7F87 16r6635 16r7F8C 16r6636 16r7F94 16r6637 16r7F9E 16r6638 16r7F9D 16r6639 16r7F9A 16r663A 16r7FA3 16r663B 16r7FAF 16r663C 16r7FB2 16r663D 16r7FB9 16r663E 16r7FAE 16r663F 16r7FB6 16r6640 16r7FB8 16r6641 16r8B71 16r6642 16r7FC5 16r6643 16r7FC6 16r6644 16r7FCA 16r6645 16r7FD5 16r6646 16r7FD4 16r6647 16r7FE1 16r6648 16r7FE6 16r6649 16r7FE9 16r664A 16r7FF3 16r664B 16r7FF9 16r664C 16r98DC 16r664D 16r8006 16r664E 16r8004 16r664F 16r800B 16r6650 16r8012 16r6651 16r8018 16r6652 16r8019 16r6653 16r801C 16r6654 16r8021 16r6655 16r8028 16r6656 16r803F 16r6657 16r803B 16r6658 16r804A 16r6659 16r8046 16r665A 16r8052 16r665B 16r8058 16r665C 16r805A 16r665D 16r805F 16r665E 16r8062 16r665F 16r8068 16r6660 16r8073 16r6661 16r8072 16r6662 16r8070 16r6663 16r8076 16r6664 16r8079 16r6665 16r807D 16r6666 16r807F 16r6667 16r8084 16r6668 16r8086 16r6669 16r8085 16r666A 16r809B 16r666B 16r8093 16r666C 16r809A 16r666D 16r80AD 16r666E 16r5190 16r666F 16r80AC 16r6670 16r80DB 16r6671 16r80E5 16r6672 16r80D9 16r6673 16r80DD 16r6674 16r80C4 16r6675 16r80DA 16r6676 16r80D6 16r6677 16r8109 16r6678 16r80EF 16r6679 16r80F1 16r667A 16r811B 16r667B 16r8129 16r667C 16r8123 16r667D 16r812F 16r667E 16r814B 16r6721 16r968B 16r6722 16r8146 16r6723 16r813E 16r6724 16r8153 16r6725 16r8151 16r6726 16r80FC 16r6727 16r8171 16r6728 16r816E 16r6729 16r8165 16r672A 16r8166 16r672B 16r8174 16r672C 16r8183 16r672D 16r8188 16r672E 16r818A 16r672F 16r8180 16r6730 16r8182 16r6731 16r81A0 16r6732 16r8195 16r6733 16r81A4 16r6734 16r81A3 16r6735 16r815F 16r6736 16r8193 16r6737 16r81A9 16r6738 16r81B0 16r6739 16r81B5 16r673A 16r81BE 16r673B 16r81B8 16r673C 16r81BD 16r673D 16r81C0 16r673E 16r81C2 16r673F 16r81BA 16r6740 16r81C9 16r6741 16r81CD 16r6742 16r81D1 16r6743 16r81D9 16r6744 16r81D8 16r6745 16r81C8 16r6746 16r81DA 16r6747 16r81DF 16r6748 16r81E0 16r6749 16r81E7 16r674A 16r81FA 16r674B 16r81FB 16r674C 16r81FE 16r674D 16r8201 16r674E 16r8202 16r674F 16r8205 16r6750 16r8207 16r6751 16r820A 16r6752 16r820D 16r6753 16r8210 16r6754 16r8216 16r6755 16r8229 16r6756 16r822B 16r6757 16r8238 16r6758 16r8233 16r6759 16r8240 16r675A 16r8259 16r675B 16r8258 16r675C 16r825D 16r675D 16r825A 16r675E 16r825F 16r675F 16r8264 16r6760 16r8262 16r6761 16r8268 16r6762 16r826A 16r6763 16r826B 16r6764 16r822E 16r6765 16r8271 16r6766 16r8277 16r6767 16r8278 16r6768 16r827E 16r6769 16r828D 16r676A 16r8292 16r676B 16r82AB 16r676C 16r829F 16r676D 16r82BB 16r676E 16r82AC 16r676F 16r82E1 16r6770 16r82E3 16r6771 16r82DF 16r6772 16r82D2 16r6773 16r82F4 16r6774 16r82F3 16r6775 16r82FA 16r6776 16r8393 16r6777 16r8303 16r6778 16r82FB 16r6779 16r82F9 16r677A 16r82DE 16r677B 16r8306 16r677C 16r82DC 16r677D 16r8309 16r677E 16r82D9 16r6821 16r8335 16r6822 16r8334 16r6823 16r8316 16r6824 16r8332 16r6825 16r8331 16r6826 16r8340 16r6827 16r8339 16r6828 16r8350 16r6829 16r8345 16r682A 16r832F 16r682B 16r832B 16r682C 16r8317 16r682D 16r8318 16r682E 16r8385 16r682F 16r839A 16r6830 16r83AA 16r6831 16r839F 16r6832 16r83A2 16r6833 16r8396 16r6834 16r8323 16r6835 16r838E 16r6836 16r8387 16r6837 16r838A 16r6838 16r837C 16r6839 16r83B5 16r683A 16r8373 16r683B 16r8375 16r683C 16r83A0 16r683D 16r8389 16r683E 16r83A8 16r683F 16r83F4 16r6840 16r8413 16r6841 16r83EB 16r6842 16r83CE 16r6843 16r83FD 16r6844 16r8403 16r6845 16r83D8 16r6846 16r840B 16r6847 16r83C1 16r6848 16r83F7 16r6849 16r8407 16r684A 16r83E0 16r684B 16r83F2 16r684C 16r840D 16r684D 16r8422 16r684E 16r8420 16r684F 16r83BD 16r6850 16r8438 16r6851 16r8506 16r6852 16r83FB 16r6853 16r846D 16r6854 16r842A 16r6855 16r843C 16r6856 16r855A 16r6857 16r8484 16r6858 16r8477 16r6859 16r846B 16r685A 16r84AD 16r685B 16r846E 16r685C 16r8482 16r685D 16r8469 16r685E 16r8446 16r685F 16r842C 16r6860 16r846F 16r6861 16r8479 16r6862 16r8435 16r6863 16r84CA 16r6864 16r8462 16r6865 16r84B9 16r6866 16r84BF 16r6867 16r849F 16r6868 16r84D9 16r6869 16r84CD 16r686A 16r84BB 16r686B 16r84DA 16r686C 16r84D0 16r686D 16r84C1 16r686E 16r84C6 16r686F 16r84D6 16r6870 16r84A1 16r6871 16r8521 16r6872 16r84FF 16r6873 16r84F4 16r6874 16r8517 16r6875 16r8518 16r6876 16r852C 16r6877 16r851F 16r6878 16r8515 16r6879 16r8514 16r687A 16r84FC 16r687B 16r8540 16r687C 16r8563 16r687D 16r8558 16r687E 16r8548 16r6921 16r8541 16r6922 16r8602 16r6923 16r854B 16r6924 16r8555 16r6925 16r8580 16r6926 16r85A4 16r6927 16r8588 16r6928 16r8591 16r6929 16r858A 16r692A 16r85A8 16r692B 16r856D 16r692C 16r8594 16r692D 16r859B 16r692E 16r85EA 16r692F 16r8587 16r6930 16r859C 16r6931 16r8577 16r6932 16r857E 16r6933 16r8590 16r6934 16r85C9 16r6935 16r85BA 16r6936 16r85CF 16r6937 16r85B9 16r6938 16r85D0 16r6939 16r85D5 16r693A 16r85DD 16r693B 16r85E5 16r693C 16r85DC 16r693D 16r85F9 16r693E 16r860A 16r693F 16r8613 16r6940 16r860B 16r6941 16r85FE 16r6942 16r85FA 16r6943 16r8606 16r6944 16r8622 16r6945 16r861A 16r6946 16r8630 16r6947 16r863F 16r6948 16r864D 16r6949 16r4E55 16r694A 16r8654 16r694B 16r865F 16r694C 16r8667 16r694D 16r8671 16r694E 16r8693 16r694F 16r86A3 16r6950 16r86A9 16r6951 16r86AA 16r6952 16r868B 16r6953 16r868C 16r6954 16r86B6 16r6955 16r86AF 16r6956 16r86C4 16r6957 16r86C6 16r6958 16r86B0 16r6959 16r86C9 16r695A 16r8823 16r695B 16r86AB 16r695C 16r86D4 16r695D 16r86DE 16r695E 16r86E9 16r695F 16r86EC 16r6960 16r86DF 16r6961 16r86DB 16r6962 16r86EF 16r6963 16r8712 16r6964 16r8706 16r6965 16r8708 16r6966 16r8700 16r6967 16r8703 16r6968 16r86FB 16r6969 16r8711 16r696A 16r8709 16r696B 16r870D 16r696C 16r86F9 16r696D 16r870A 16r696E 16r8734 16r696F 16r873F 16r6970 16r8737 16r6971 16r873B 16r6972 16r8725 16r6973 16r8729 16r6974 16r871A 16r6975 16r8760 16r6976 16r875F 16r6977 16r8778 16r6978 16r874C 16r6979 16r874E 16r697A 16r8774 16r697B 16r8757 16r697C 16r8768 16r697D 16r876E 16r697E 16r8759 16r6A21 16r8753 16r6A22 16r8763 16r6A23 16r876A 16r6A24 16r8805 16r6A25 16r87A2 16r6A26 16r879F 16r6A27 16r8782 16r6A28 16r87AF 16r6A29 16r87CB 16r6A2A 16r87BD 16r6A2B 16r87C0 16r6A2C 16r87D0 16r6A2D 16r96D6 16r6A2E 16r87AB 16r6A2F 16r87C4 16r6A30 16r87B3 16r6A31 16r87C7 16r6A32 16r87C6 16r6A33 16r87BB 16r6A34 16r87EF 16r6A35 16r87F2 16r6A36 16r87E0 16r6A37 16r880F 16r6A38 16r880D 16r6A39 16r87FE 16r6A3A 16r87F6 16r6A3B 16r87F7 16r6A3C 16r880E 16r6A3D 16r87D2 16r6A3E 16r8811 16r6A3F 16r8816 16r6A40 16r8815 16r6A41 16r8822 16r6A42 16r8821 16r6A43 16r8831 16r6A44 16r8836 16r6A45 16r8839 16r6A46 16r8827 16r6A47 16r883B 16r6A48 16r8844 16r6A49 16r8842 16r6A4A 16r8852 16r6A4B 16r8859 16r6A4C 16r885E 16r6A4D 16r8862 16r6A4E 16r886B 16r6A4F 16r8881 16r6A50 16r887E 16r6A51 16r889E 16r6A52 16r8875 16r6A53 16r887D 16r6A54 16r88B5 16r6A55 16r8872 16r6A56 16r8882 16r6A57 16r8897 16r6A58 16r8892 16r6A59 16r88AE 16r6A5A 16r8899 16r6A5B 16r88A2 16r6A5C 16r888D 16r6A5D 16r88A4 16r6A5E 16r88B0 16r6A5F 16r88BF 16r6A60 16r88B1 16r6A61 16r88C3 16r6A62 16r88C4 16r6A63 16r88D4 16r6A64 16r88D8 16r6A65 16r88D9 16r6A66 16r88DD 16r6A67 16r88F9 16r6A68 16r8902 16r6A69 16r88FC 16r6A6A 16r88F4 16r6A6B 16r88E8 16r6A6C 16r88F2 16r6A6D 16r8904 16r6A6E 16r890C 16r6A6F 16r890A 16r6A70 16r8913 16r6A71 16r8943 16r6A72 16r891E 16r6A73 16r8925 16r6A74 16r892A 16r6A75 16r892B 16r6A76 16r8941 16r6A77 16r8944 16r6A78 16r893B 16r6A79 16r8936 16r6A7A 16r8938 16r6A7B 16r894C 16r6A7C 16r891D 16r6A7D 16r8960 16r6A7E 16r895E 16r6B21 16r8966 16r6B22 16r8964 16r6B23 16r896D 16r6B24 16r896A 16r6B25 16r896F 16r6B26 16r8974 16r6B27 16r8977 16r6B28 16r897E 16r6B29 16r8983 16r6B2A 16r8988 16r6B2B 16r898A 16r6B2C 16r8993 16r6B2D 16r8998 16r6B2E 16r89A1 16r6B2F 16r89A9 16r6B30 16r89A6 16r6B31 16r89AC 16r6B32 16r89AF 16r6B33 16r89B2 16r6B34 16r89BA 16r6B35 16r89BD 16r6B36 16r89BF 16r6B37 16r89C0 16r6B38 16r89DA 16r6B39 16r89DC 16r6B3A 16r89DD 16r6B3B 16r89E7 16r6B3C 16r89F4 16r6B3D 16r89F8 16r6B3E 16r8A03 16r6B3F 16r8A16 16r6B40 16r8A10 16r6B41 16r8A0C 16r6B42 16r8A1B 16r6B43 16r8A1D 16r6B44 16r8A25 16r6B45 16r8A36 16r6B46 16r8A41 16r6B47 16r8A5B 16r6B48 16r8A52 16r6B49 16r8A46 16r6B4A 16r8A48 16r6B4B 16r8A7C 16r6B4C 16r8A6D 16r6B4D 16r8A6C 16r6B4E 16r8A62 16r6B4F 16r8A85 16r6B50 16r8A82 16r6B51 16r8A84 16r6B52 16r8AA8 16r6B53 16r8AA1 16r6B54 16r8A91 16r6B55 16r8AA5 16r6B56 16r8AA6 16r6B57 16r8A9A 16r6B58 16r8AA3 16r6B59 16r8AC4 16r6B5A 16r8ACD 16r6B5B 16r8AC2 16r6B5C 16r8ADA 16r6B5D 16r8AEB 16r6B5E 16r8AF3 16r6B5F 16r8AE7 16r6B60 16r8AE4 16r6B61 16r8AF1 16r6B62 16r8B14 16r6B63 16r8AE0 16r6B64 16r8AE2 16r6B65 16r8AF7 16r6B66 16r8ADE 16r6B67 16r8ADB 16r6B68 16r8B0C 16r6B69 16r8B07 16r6B6A 16r8B1A 16r6B6B 16r8AE1 16r6B6C 16r8B16 16r6B6D 16r8B10 16r6B6E 16r8B17 16r6B6F 16r8B20 16r6B70 16r8B33 16r6B71 16r97AB 16r6B72 16r8B26 16r6B73 16r8B2B 16r6B74 16r8B3E 16r6B75 16r8B28 16r6B76 16r8B41 16r6B77 16r8B4C 16r6B78 16r8B4F 16r6B79 16r8B4E 16r6B7A 16r8B49 16r6B7B 16r8B56 16r6B7C 16r8B5B 16r6B7D 16r8B5A 16r6B7E 16r8B6B 16r6C21 16r8B5F 16r6C22 16r8B6C 16r6C23 16r8B6F 16r6C24 16r8B74 16r6C25 16r8B7D 16r6C26 16r8B80 16r6C27 16r8B8C 16r6C28 16r8B8E 16r6C29 16r8B92 16r6C2A 16r8B93 16r6C2B 16r8B96 16r6C2C 16r8B99 16r6C2D 16r8B9A 16r6C2E 16r8C3A 16r6C2F 16r8C41 16r6C30 16r8C3F 16r6C31 16r8C48 16r6C32 16r8C4C 16r6C33 16r8C4E 16r6C34 16r8C50 16r6C35 16r8C55 16r6C36 16r8C62 16r6C37 16r8C6C 16r6C38 16r8C78 16r6C39 16r8C7A 16r6C3A 16r8C82 16r6C3B 16r8C89 16r6C3C 16r8C85 16r6C3D 16r8C8A 16r6C3E 16r8C8D 16r6C3F 16r8C8E 16r6C40 16r8C94 16r6C41 16r8C7C 16r6C42 16r8C98 16r6C43 16r621D 16r6C44 16r8CAD 16r6C45 16r8CAA 16r6C46 16r8CBD 16r6C47 16r8CB2 16r6C48 16r8CB3 16r6C49 16r8CAE 16r6C4A 16r8CB6 16r6C4B 16r8CC8 16r6C4C 16r8CC1 16r6C4D 16r8CE4 16r6C4E 16r8CE3 16r6C4F 16r8CDA 16r6C50 16r8CFD 16r6C51 16r8CFA 16r6C52 16r8CFB 16r6C53 16r8D04 16r6C54 16r8D05 16r6C55 16r8D0A 16r6C56 16r8D07 16r6C57 16r8D0F 16r6C58 16r8D0D 16r6C59 16r8D10 16r6C5A 16r9F4E 16r6C5B 16r8D13 16r6C5C 16r8CCD 16r6C5D 16r8D14 16r6C5E 16r8D16 16r6C5F 16r8D67 16r6C60 16r8D6D 16r6C61 16r8D71 16r6C62 16r8D73 16r6C63 16r8D81 16r6C64 16r8D99 16r6C65 16r8DC2 16r6C66 16r8DBE 16r6C67 16r8DBA 16r6C68 16r8DCF 16r6C69 16r8DDA 16r6C6A 16r8DD6 16r6C6B 16r8DCC 16r6C6C 16r8DDB 16r6C6D 16r8DCB 16r6C6E 16r8DEA 16r6C6F 16r8DEB 16r6C70 16r8DDF 16r6C71 16r8DE3 16r6C72 16r8DFC 16r6C73 16r8E08 16r6C74 16r8E09 16r6C75 16r8DFF 16r6C76 16r8E1D 16r6C77 16r8E1E 16r6C78 16r8E10 16r6C79 16r8E1F 16r6C7A 16r8E42 16r6C7B 16r8E35 16r6C7C 16r8E30 16r6C7D 16r8E34 16r6C7E 16r8E4A 16r6D21 16r8E47 16r6D22 16r8E49 16r6D23 16r8E4C 16r6D24 16r8E50 16r6D25 16r8E48 16r6D26 16r8E59 16r6D27 16r8E64 16r6D28 16r8E60 16r6D29 16r8E2A 16r6D2A 16r8E63 16r6D2B 16r8E55 16r6D2C 16r8E76 16r6D2D 16r8E72 16r6D2E 16r8E7C 16r6D2F 16r8E81 16r6D30 16r8E87 16r6D31 16r8E85 16r6D32 16r8E84 16r6D33 16r8E8B 16r6D34 16r8E8A 16r6D35 16r8E93 16r6D36 16r8E91 16r6D37 16r8E94 16r6D38 16r8E99 16r6D39 16r8EAA 16r6D3A 16r8EA1 16r6D3B 16r8EAC 16r6D3C 16r8EB0 16r6D3D 16r8EC6 16r6D3E 16r8EB1 16r6D3F 16r8EBE 16r6D40 16r8EC5 16r6D41 16r8EC8 16r6D42 16r8ECB 16r6D43 16r8EDB 16r6D44 16r8EE3 16r6D45 16r8EFC 16r6D46 16r8EFB 16r6D47 16r8EEB 16r6D48 16r8EFE 16r6D49 16r8F0A 16r6D4A 16r8F05 16r6D4B 16r8F15 16r6D4C 16r8F12 16r6D4D 16r8F19 16r6D4E 16r8F13 16r6D4F 16r8F1C 16r6D50 16r8F1F 16r6D51 16r8F1B 16r6D52 16r8F0C 16r6D53 16r8F26 16r6D54 16r8F33 16r6D55 16r8F3B 16r6D56 16r8F39 16r6D57 16r8F45 16r6D58 16r8F42 16r6D59 16r8F3E 16r6D5A 16r8F4C 16r6D5B 16r8F49 16r6D5C 16r8F46 16r6D5D 16r8F4E 16r6D5E 16r8F57 16r6D5F 16r8F5C 16r6D60 16r8F62 16r6D61 16r8F63 16r6D62 16r8F64 16r6D63 16r8F9C 16r6D64 16r8F9F 16r6D65 16r8FA3 16r6D66 16r8FAD 16r6D67 16r8FAF 16r6D68 16r8FB7 16r6D69 16r8FDA 16r6D6A 16r8FE5 16r6D6B 16r8FE2 16r6D6C 16r8FEA 16r6D6D 16r8FEF 16r6D6E 16r9087 16r6D6F 16r8FF4 16r6D70 16r9005 16r6D71 16r8FF9 16r6D72 16r8FFA 16r6D73 16r9011 16r6D74 16r9015 16r6D75 16r9021 16r6D76 16r900D 16r6D77 16r901E 16r6D78 16r9016 16r6D79 16r900B 16r6D7A 16r9027 16r6D7B 16r9036 16r6D7C 16r9035 16r6D7D 16r9039 16r6D7E 16r8FF8 16r6E21 16r904F 16r6E22 16r9050 16r6E23 16r9051 16r6E24 16r9052 16r6E25 16r900E 16r6E26 16r9049 16r6E27 16r903E 16r6E28 16r9056 16r6E29 16r9058 16r6E2A 16r905E 16r6E2B 16r9068 16r6E2C 16r906F 16r6E2D 16r9076 16r6E2E 16r96A8 16r6E2F 16r9072 16r6E30 16r9082 16r6E31 16r907D 16r6E32 16r9081 16r6E33 16r9080 16r6E34 16r908A 16r6E35 16r9089 16r6E36 16r908F 16r6E37 16r90A8 16r6E38 16r90AF 16r6E39 16r90B1 16r6E3A 16r90B5 16r6E3B 16r90E2 16r6E3C 16r90E4 16r6E3D 16r6248 16r6E3E 16r90DB 16r6E3F 16r9102 16r6E40 16r9112 16r6E41 16r9119 16r6E42 16r9132 16r6E43 16r9130 16r6E44 16r914A 16r6E45 16r9156 16r6E46 16r9158 16r6E47 16r9163 16r6E48 16r9165 16r6E49 16r9169 16r6E4A 16r9173 16r6E4B 16r9172 16r6E4C 16r918B 16r6E4D 16r9189 16r6E4E 16r9182 16r6E4F 16r91A2 16r6E50 16r91AB 16r6E51 16r91AF 16r6E52 16r91AA 16r6E53 16r91B5 16r6E54 16r91B4 16r6E55 16r91BA 16r6E56 16r91C0 16r6E57 16r91C1 16r6E58 16r91C9 16r6E59 16r91CB 16r6E5A 16r91D0 16r6E5B 16r91D6 16r6E5C 16r91DF 16r6E5D 16r91E1 16r6E5E 16r91DB 16r6E5F 16r91FC 16r6E60 16r91F5 16r6E61 16r91F6 16r6E62 16r921E 16r6E63 16r91FF 16r6E64 16r9214 16r6E65 16r922C 16r6E66 16r9215 16r6E67 16r9211 16r6E68 16r925E 16r6E69 16r9257 16r6E6A 16r9245 16r6E6B 16r9249 16r6E6C 16r9264 16r6E6D 16r9248 16r6E6E 16r9295 16r6E6F 16r923F 16r6E70 16r924B 16r6E71 16r9250 16r6E72 16r929C 16r6E73 16r9296 16r6E74 16r9293 16r6E75 16r929B 16r6E76 16r925A 16r6E77 16r92CF 16r6E78 16r92B9 16r6E79 16r92B7 16r6E7A 16r92E9 16r6E7B 16r930F 16r6E7C 16r92FA 16r6E7D 16r9344 16r6E7E 16r932E 16r6F21 16r9319 16r6F22 16r9322 16r6F23 16r931A 16r6F24 16r9323 16r6F25 16r933A 16r6F26 16r9335 16r6F27 16r933B 16r6F28 16r935C 16r6F29 16r9360 16r6F2A 16r937C 16r6F2B 16r936E 16r6F2C 16r9356 16r6F2D 16r93B0 16r6F2E 16r93AC 16r6F2F 16r93AD 16r6F30 16r9394 16r6F31 16r93B9 16r6F32 16r93D6 16r6F33 16r93D7 16r6F34 16r93E8 16r6F35 16r93E5 16r6F36 16r93D8 16r6F37 16r93C3 16r6F38 16r93DD 16r6F39 16r93D0 16r6F3A 16r93C8 16r6F3B 16r93E4 16r6F3C 16r941A 16r6F3D 16r9414 16r6F3E 16r9413 16r6F3F 16r9403 16r6F40 16r9407 16r6F41 16r9410 16r6F42 16r9436 16r6F43 16r942B 16r6F44 16r9435 16r6F45 16r9421 16r6F46 16r943A 16r6F47 16r9441 16r6F48 16r9452 16r6F49 16r9444 16r6F4A 16r945B 16r6F4B 16r9460 16r6F4C 16r9462 16r6F4D 16r945E 16r6F4E 16r946A 16r6F4F 16r9229 16r6F50 16r9470 16r6F51 16r9475 16r6F52 16r9477 16r6F53 16r947D 16r6F54 16r945A 16r6F55 16r947C 16r6F56 16r947E 16r6F57 16r9481 16r6F58 16r947F 16r6F59 16r9582 16r6F5A 16r9587 16r6F5B 16r958A 16r6F5C 16r9594 16r6F5D 16r9596 16r6F5E 16r9598 16r6F5F 16r9599 16r6F60 16r95A0 16r6F61 16r95A8 16r6F62 16r95A7 16r6F63 16r95AD 16r6F64 16r95BC 16r6F65 16r95BB 16r6F66 16r95B9 16r6F67 16r95BE 16r6F68 16r95CA 16r6F69 16r6FF6 16r6F6A 16r95C3 16r6F6B 16r95CD 16r6F6C 16r95CC 16r6F6D 16r95D5 16r6F6E 16r95D4 16r6F6F 16r95D6 16r6F70 16r95DC 16r6F71 16r95E1 16r6F72 16r95E5 16r6F73 16r95E2 16r6F74 16r9621 16r6F75 16r9628 16r6F76 16r962E 16r6F77 16r962F 16r6F78 16r9642 16r6F79 16r964C 16r6F7A 16r964F 16r6F7B 16r964B 16r6F7C 16r9677 16r6F7D 16r965C 16r6F7E 16r965E 16r7021 16r965D 16r7022 16r965F 16r7023 16r9666 16r7024 16r9672 16r7025 16r966C 16r7026 16r968D 16r7027 16r9698 16r7028 16r9695 16r7029 16r9697 16r702A 16r96AA 16r702B 16r96A7 16r702C 16r96B1 16r702D 16r96B2 16r702E 16r96B0 16r702F 16r96B4 16r7030 16r96B6 16r7031 16r96B8 16r7032 16r96B9 16r7033 16r96CE 16r7034 16r96CB 16r7035 16r96C9 16r7036 16r96CD 16r7037 16r894D 16r7038 16r96DC 16r7039 16r970D 16r703A 16r96D5 16r703B 16r96F9 16r703C 16r9704 16r703D 16r9706 16r703E 16r9708 16r703F 16r9713 16r7040 16r970E 16r7041 16r9711 16r7042 16r970F 16r7043 16r9716 16r7044 16r9719 16r7045 16r9724 16r7046 16r972A 16r7047 16r9730 16r7048 16r9739 16r7049 16r973D 16r704A 16r973E 16r704B 16r9744 16r704C 16r9746 16r704D 16r9748 16r704E 16r9742 16r704F 16r9749 16r7050 16r975C 16r7051 16r9760 16r7052 16r9764 16r7053 16r9766 16r7054 16r9768 16r7055 16r52D2 16r7056 16r976B 16r7057 16r9771 16r7058 16r9779 16r7059 16r9785 16r705A 16r977C 16r705B 16r9781 16r705C 16r977A 16r705D 16r9786 16r705E 16r978B 16r705F 16r978F 16r7060 16r9790 16r7061 16r979C 16r7062 16r97A8 16r7063 16r97A6 16r7064 16r97A3 16r7065 16r97B3 16r7066 16r97B4 16r7067 16r97C3 16r7068 16r97C6 16r7069 16r97C8 16r706A 16r97CB 16r706B 16r97DC 16r706C 16r97ED 16r706D 16r9F4F 16r706E 16r97F2 16r706F 16r7ADF 16r7070 16r97F6 16r7071 16r97F5 16r7072 16r980F 16r7073 16r980C 16r7074 16r9838 16r7075 16r9824 16r7076 16r9821 16r7077 16r9837 16r7078 16r983D 16r7079 16r9846 16r707A 16r984F 16r707B 16r984B 16r707C 16r986B 16r707D 16r986F 16r707E 16r9870 16r7121 16r9871 16r7122 16r9874 16r7123 16r9873 16r7124 16r98AA 16r7125 16r98AF 16r7126 16r98B1 16r7127 16r98B6 16r7128 16r98C4 16r7129 16r98C3 16r712A 16r98C6 16r712B 16r98E9 16r712C 16r98EB 16r712D 16r9903 16r712E 16r9909 16r712F 16r9912 16r7130 16r9914 16r7131 16r9918 16r7132 16r9921 16r7133 16r991D 16r7134 16r991E 16r7135 16r9924 16r7136 16r9920 16r7137 16r992C 16r7138 16r992E 16r7139 16r993D 16r713A 16r993E 16r713B 16r9942 16r713C 16r9949 16r713D 16r9945 16r713E 16r9950 16r713F 16r994B 16r7140 16r9951 16r7141 16r9952 16r7142 16r994C 16r7143 16r9955 16r7144 16r9997 16r7145 16r9998 16r7146 16r99A5 16r7147 16r99AD 16r7148 16r99AE 16r7149 16r99BC 16r714A 16r99DF 16r714B 16r99DB 16r714C 16r99DD 16r714D 16r99D8 16r714E 16r99D1 16r714F 16r99ED 16r7150 16r99EE 16r7151 16r99F1 16r7152 16r99F2 16r7153 16r99FB 16r7154 16r99F8 16r7155 16r9A01 16r7156 16r9A0F 16r7157 16r9A05 16r7158 16r99E2 16r7159 16r9A19 16r715A 16r9A2B 16r715B 16r9A37 16r715C 16r9A45 16r715D 16r9A42 16r715E 16r9A40 16r715F 16r9A43 16r7160 16r9A3E 16r7161 16r9A55 16r7162 16r9A4D 16r7163 16r9A5B 16r7164 16r9A57 16r7165 16r9A5F 16r7166 16r9A62 16r7167 16r9A65 16r7168 16r9A64 16r7169 16r9A69 16r716A 16r9A6B 16r716B 16r9A6A 16r716C 16r9AAD 16r716D 16r9AB0 16r716E 16r9ABC 16r716F 16r9AC0 16r7170 16r9ACF 16r7171 16r9AD1 16r7172 16r9AD3 16r7173 16r9AD4 16r7174 16r9ADE 16r7175 16r9ADF 16r7176 16r9AE2 16r7177 16r9AE3 16r7178 16r9AE6 16r7179 16r9AEF 16r717A 16r9AEB 16r717B 16r9AEE 16r717C 16r9AF4 16r717D 16r9AF1 16r717E 16r9AF7 16r7221 16r9AFB 16r7222 16r9B06 16r7223 16r9B18 16r7224 16r9B1A 16r7225 16r9B1F 16r7226 16r9B22 16r7227 16r9B23 16r7228 16r9B25 16r7229 16r9B27 16r722A 16r9B28 16r722B 16r9B29 16r722C 16r9B2A 16r722D 16r9B2E 16r722E 16r9B2F 16r722F 16r9B32 16r7230 16r9B44 16r7231 16r9B43 16r7232 16r9B4F 16r7233 16r9B4D 16r7234 16r9B4E 16r7235 16r9B51 16r7236 16r9B58 16r7237 16r9B74 16r7238 16r9B93 16r7239 16r9B83 16r723A 16r9B91 16r723B 16r9B96 16r723C 16r9B97 16r723D 16r9B9F 16r723E 16r9BA0 16r723F 16r9BA8 16r7240 16r9BB4 16r7241 16r9BC0 16r7242 16r9BCA 16r7243 16r9BB9 16r7244 16r9BC6 16r7245 16r9BCF 16r7246 16r9BD1 16r7247 16r9BD2 16r7248 16r9BE3 16r7249 16r9BE2 16r724A 16r9BE4 16r724B 16r9BD4 16r724C 16r9BE1 16r724D 16r9C3A 16r724E 16r9BF2 16r724F 16r9BF1 16r7250 16r9BF0 16r7251 16r9C15 16r7252 16r9C14 16r7253 16r9C09 16r7254 16r9C13 16r7255 16r9C0C 16r7256 16r9C06 16r7257 16r9C08 16r7258 16r9C12 16r7259 16r9C0A 16r725A 16r9C04 16r725B 16r9C2E 16r725C 16r9C1B 16r725D 16r9C25 16r725E 16r9C24 16r725F 16r9C21 16r7260 16r9C30 16r7261 16r9C47 16r7262 16r9C32 16r7263 16r9C46 16r7264 16r9C3E 16r7265 16r9C5A 16r7266 16r9C60 16r7267 16r9C67 16r7268 16r9C76 16r7269 16r9C78 16r726A 16r9CE7 16r726B 16r9CEC 16r726C 16r9CF0 16r726D 16r9D09 16r726E 16r9D08 16r726F 16r9CEB 16r7270 16r9D03 16r7271 16r9D06 16r7272 16r9D2A 16r7273 16r9D26 16r7274 16r9DAF 16r7275 16r9D23 16r7276 16r9D1F 16r7277 16r9D44 16r7278 16r9D15 16r7279 16r9D12 16r727A 16r9D41 16r727B 16r9D3F 16r727C 16r9D3E 16r727D 16r9D46 16r727E 16r9D48 16r7321 16r9D5D 16r7322 16r9D5E 16r7323 16r9D64 16r7324 16r9D51 16r7325 16r9D50 16r7326 16r9D59 16r7327 16r9D72 16r7328 16r9D89 16r7329 16r9D87 16r732A 16r9DAB 16r732B 16r9D6F 16r732C 16r9D7A 16r732D 16r9D9A 16r732E 16r9DA4 16r732F 16r9DA9 16r7330 16r9DB2 16r7331 16r9DC4 16r7332 16r9DC1 16r7333 16r9DBB 16r7334 16r9DB8 16r7335 16r9DBA 16r7336 16r9DC6 16r7337 16r9DCF 16r7338 16r9DC2 16r7339 16r9DD9 16r733A 16r9DD3 16r733B 16r9DF8 16r733C 16r9DE6 16r733D 16r9DED 16r733E 16r9DEF 16r733F 16r9DFD 16r7340 16r9E1A 16r7341 16r9E1B 16r7342 16r9E1E 16r7343 16r9E75 16r7344 16r9E79 16r7345 16r9E7D 16r7346 16r9E81 16r7347 16r9E88 16r7348 16r9E8B 16r7349 16r9E8C 16r734A 16r9E92 16r734B 16r9E95 16r734C 16r9E91 16r734D 16r9E9D 16r734E 16r9EA5 16r734F 16r9EA9 16r7350 16r9EB8 16r7351 16r9EAA 16r7352 16r9EAD 16r7353 16r9761 16r7354 16r9ECC 16r7355 16r9ECE 16r7356 16r9ECF 16r7357 16r9ED0 16r7358 16r9ED4 16r7359 16r9EDC 16r735A 16r9EDE 16r735B 16r9EDD 16r735C 16r9EE0 16r735D 16r9EE5 16r735E 16r9EE8 16r735F 16r9EEF 16r7360 16r9EF4 16r7361 16r9EF6 16r7362 16r9EF7 16r7363 16r9EF9 16r7364 16r9EFB 16r7365 16r9EFC 16r7366 16r9EFD 16r7367 16r9F07 16r7368 16r9F08 16r7369 16r76B7 16r736A 16r9F15 16r736B 16r9F21 16r736C 16r9F2C 16r736D 16r9F3E 16r736E 16r9F4A 16r736F 16r9F52 16r7370 16r9F54 16r7371 16r9F63 16r7372 16r9F5F 16r7373 16r9F60 16r7374 16r9F61 16r7375 16r9F66 16r7376 16r9F67 16r7377 16r9F6C 16r7378 16r9F6A 16r7379 16r9F77 16r737A 16r9F72 16r737B 16r9F76 16r737C 16r9F95 16r737D 16r9F9C 16r737E 16r9FA0 16r7421 16r582F 16r7422 16r69C7 16r7423 16r9059 16r7424 16r7464 16r7425 16r51DC 16r7426 16r7199).
	table size even ifFalse: [^ self error: 'given table size must be even'].
	size _ table size / 2.
	jisX0208 _ Array new: size.
	unicode _ Array new: size.
	1 to: table size by: 2 do: [:index |
		| tableIndex |
		tableIndex _ index + 1 / 2.
		jisX0208 at: tableIndex put: (table at: index).
		unicode at: tableIndex put: (table at: index + 1)].
	jisX02082 _ Array new: 94*94 withAll: -1.
	jisX0208 withIndexDo: [:elem :index |
		code _ (elem // 256 - 33) * 94 + (elem \\ 256 - 33) + 1.
		(jisX02082 at: code) ~= -1 ifTrue: [self halt].
		uIndex _ jisX0208 indexOf: elem.
		uIndex = 0 ifFalse: [
			u _ unicode at: uIndex.
			jisX02082 at: code put: u.
		].
	].
	JISX0208Table _ jisX02082.
! !

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:35'!
initializeKSX1001Table
	"UCSTable initializeKSX1001Table"

	| table size ksX1001 unicode ksX10012 code uIndex u |
	table _ #(16r2121 16r3000 16r2122 16r3001 16r2123 16r3002 16r2124 16r00B7 16r2125 16r2025 16r2126 16r2026 16r2127 16r00A8 16r2128 16r3003 16r2129 16r00AD 16r212A 16r2015 16r212B 16r2225 16r212C 16rFF3C 16r212D 16r223C 16r212E 16r2018 16r212F 16r2019 16r2130 16r201C 16r2131 16r201D 16r2132 16r3014 16r2133 16r3015 16r2134 16r3008 16r2135 16r3009 16r2136 16r300A 16r2137 16r300B 16r2138 16r300C 16r2139 16r300D 16r213A 16r300E 16r213B 16r300F 16r213C 16r3010 16r213D 16r3011 16r213E 16r00B1 16r213F 16r00D7 16r2140 16r00F7 16r2141 16r2260 16r2142 16r2264 16r2143 16r2265 16r2144 16r221E 16r2145 16r2234 16r2146 16r00B0 16r2147 16r2032 16r2148 16r2033 16r2149 16r2103 16r214A 16r212B 16r214B 16rFFE0 16r214C 16rFFE1 16r214D 16rFFE5 16r214E 16r2642 16r214F 16r2640 16r2150 16r2220 16r2151 16r22A5 16r2152 16r2312 16r2153 16r2202 16r2154 16r2207 16r2155 16r2261 16r2156 16r2252 16r2157 16r00A7 16r2158 16r203B 16r2159 16r2606 16r215A 16r2605 16r215B 16r25CB 16r215C 16r25CF 16r215D 16r25CE 16r215E 16r25C7 16r215F 16r25C6 16r2160 16r25A1 16r2161 16r25A0 16r2162 16r25B3 16r2163 16r25B2 16r2164 16r25BD 16r2165 16r25BC 16r2166 16r2192 16r2167 16r2190 16r2168 16r2191 16r2169 16r2193 16r216A 16r2194 16r216B 16r3013 16r216C 16r226A 16r216D 16r226B 16r216E 16r221A 16r216F 16r223D 16r2170 16r221D 16r2171 16r2235 16r2172 16r222B 16r2173 16r222C 16r2174 16r2208 16r2175 16r220B 16r2176 16r2286 16r2177 16r2287 16r2178 16r2282 16r2179 16r2283 16r217A 16r222A 16r217B 16r2229 16r217C 16r2227 16r217D 16r2228 16r217E 16rFFE2 16r2221 16r21D2 16r2222 16r21D4 16r2223 16r2200 16r2224 16r2203 16r2225 16r00B4 16r2226 16rFF5E 16r2227 16r02C7 16r2228 16r02D8 16r2229 16r02DD 16r222A 16r02DA 16r222B 16r02D9 16r222C 16r00B8 16r222D 16r02DB 16r222E 16r00A1 16r222F 16r00BF 16r2230 16r02D0 16r2231 16r222E 16r2232 16r2211 16r2233 16r220F 16r2234 16r00A4 16r2235 16r2109 16r2236 16r2030 16r2237 16r25C1 16r2238 16r25C0 16r2239 16r25B7 16r223A 16r25B6 16r223B 16r2664 16r223C 16r2660 16r223D 16r2661 16r223E 16r2665 16r223F 16r2667 16r2240 16r2663 16r2241 16r2299 16r2242 16r25C8 16r2243 16r25A3 16r2244 16r25D0 16r2245 16r25D1 16r2246 16r2592 16r2247 16r25A4 16r2248 16r25A5 16r2249 16r25A8 16r224A 16r25A7 16r224B 16r25A6 16r224C 16r25A9 16r224D 16r2668 16r224E 16r260F 16r224F 16r260E 16r2250 16r261C 16r2251 16r261E 16r2252 16r00B6 16r2253 16r2020 16r2254 16r2021 16r2255 16r2195 16r2256 16r2197 16r2257 16r2199 16r2258 16r2196 16r2259 16r2198 16r225A 16r266D 16r225B 16r2669 16r225C 16r266A 16r225D 16r266C 16r225E 16r327F 16r225F 16r321C 16r2260 16r2116 16r2261 16r33C7 16r2262 16r2122 16r2263 16r33C2 16r2264 16r33D8 16r2265 16r2121 16r2321 16rFF01 16r2322 16rFF02 16r2323 16rFF03 16r2324 16rFF04 16r2325 16rFF05 16r2326 16rFF06 16r2327 16rFF07 16r2328 16rFF08 16r2329 16rFF09 16r232A 16rFF0A 16r232B 16rFF0B 16r232C 16rFF0C 16r232D 16rFF0D 16r232E 16rFF0E 16r232F 16rFF0F 16r2330 16rFF10 16r2331 16rFF11 16r2332 16rFF12 16r2333 16rFF13 16r2334 16rFF14 16r2335 16rFF15 16r2336 16rFF16 16r2337 16rFF17 16r2338 16rFF18 16r2339 16rFF19 16r233A 16rFF1A 16r233B 16rFF1B 16r233C 16rFF1C 16r233D 16rFF1D 16r233E 16rFF1E 16r233F 16rFF1F 16r2340 16rFF20 16r2341 16rFF21 16r2342 16rFF22 16r2343 16rFF23 16r2344 16rFF24 16r2345 16rFF25 16r2346 16rFF26 16r2347 16rFF27 16r2348 16rFF28 16r2349 16rFF29 16r234A 16rFF2A 16r234B 16rFF2B 16r234C 16rFF2C 16r234D 16rFF2D 16r234E 16rFF2E 16r234F 16rFF2F 16r2350 16rFF30 16r2351 16rFF31 16r2352 16rFF32 16r2353 16rFF33 16r2354 16rFF34 16r2355 16rFF35 16r2356 16rFF36 16r2357 16rFF37 16r2358 16rFF38 16r2359 16rFF39 16r235A 16rFF3A 16r235B 16rFF3B 16r235C 16rFFE6 16r235D 16rFF3D 16r235E 16rFF3E 16r235F 16rFF3F 16r2360 16rFF40 16r2361 16rFF41 16r2362 16rFF42 16r2363 16rFF43 16r2364 16rFF44 16r2365 16rFF45 16r2366 16rFF46 16r2367 16rFF47 16r2368 16rFF48 16r2369 16rFF49 16r236A 16rFF4A 16r236B 16rFF4B 16r236C 16rFF4C 16r236D 16rFF4D 16r236E 16rFF4E 16r236F 16rFF4F 16r2370 16rFF50 16r2371 16rFF51 16r2372 16rFF52 16r2373 16rFF53 16r2374 16rFF54 16r2375 16rFF55 16r2376 16rFF56 16r2377 16rFF57 16r2378 16rFF58 16r2379 16rFF59 16r237A 16rFF5A 16r237B 16rFF5B 16r237C 16rFF5C 16r237D 16rFF5D 16r237E 16rFFE3 16r2421 16r3131 16r2422 16r3132 16r2423 16r3133 16r2424 16r3134 16r2425 16r3135 16r2426 16r3136 16r2427 16r3137 16r2428 16r3138 16r2429 16r3139 16r242A 16r313A 16r242B 16r313B 16r242C 16r313C 16r242D 16r313D 16r242E 16r313E 16r242F 16r313F 16r2430 16r3140 16r2431 16r3141 16r2432 16r3142 16r2433 16r3143 16r2434 16r3144 16r2435 16r3145 16r2436 16r3146 16r2437 16r3147 16r2438 16r3148 16r2439 16r3149 16r243A 16r314A 16r243B 16r314B 16r243C 16r314C 16r243D 16r314D 16r243E 16r314E 16r243F 16r314F 16r2440 16r3150 16r2441 16r3151 16r2442 16r3152 16r2443 16r3153 16r2444 16r3154 16r2445 16r3155 16r2446 16r3156 16r2447 16r3157 16r2448 16r3158 16r2449 16r3159 16r244A 16r315A 16r244B 16r315B 16r244C 16r315C 16r244D 16r315D 16r244E 16r315E 16r244F 16r315F 16r2450 16r3160 16r2451 16r3161 16r2452 16r3162 16r2453 16r3163 16r2454 16r3164 16r2455 16r3165 16r2456 16r3166 16r2457 16r3167 16r2458 16r3168 16r2459 16r3169 16r245A 16r316A 16r245B 16r316B 16r245C 16r316C 16r245D 16r316D 16r245E 16r316E 16r245F 16r316F 16r2460 16r3170 16r2461 16r3171 16r2462 16r3172 16r2463 16r3173 16r2464 16r3174 16r2465 16r3175 16r2466 16r3176 16r2467 16r3177 16r2468 16r3178 16r2469 16r3179 16r246A 16r317A 16r246B 16r317B 16r246C 16r317C 16r246D 16r317D 16r246E 16r317E 16r246F 16r317F 16r2470 16r3180 16r2471 16r3181 16r2472 16r3182 16r2473 16r3183 16r2474 16r3184 16r2475 16r3185 16r2476 16r3186 16r2477 16r3187 16r2478 16r3188 16r2479 16r3189 16r247A 16r318A 16r247B 16r318B 16r247C 16r318C 16r247D 16r318D 16r247E 16r318E 16r2521 16r2170 16r2522 16r2171 16r2523 16r2172 16r2524 16r2173 16r2525 16r2174 16r2526 16r2175 16r2527 16r2176 16r2528 16r2177 16r2529 16r2178 16r252A 16r2179 16r2530 16r2160 16r2531 16r2161 16r2532 16r2162 16r2533 16r2163 16r2534 16r2164 16r2535 16r2165 16r2536 16r2166 16r2537 16r2167 16r2538 16r2168 16r2539 16r2169 16r2541 16r0391 16r2542 16r0392 16r2543 16r0393 16r2544 16r0394 16r2545 16r0395 16r2546 16r0396 16r2547 16r0397 16r2548 16r0398 16r2549 16r0399 16r254A 16r039A 16r254B 16r039B 16r254C 16r039C 16r254D 16r039D 16r254E 16r039E 16r254F 16r039F 16r2550 16r03A0 16r2551 16r03A1 16r2552 16r03A3 16r2553 16r03A4 16r2554 16r03A5 16r2555 16r03A6 16r2556 16r03A7 16r2557 16r03A8 16r2558 16r03A9 16r2561 16r03B1 16r2562 16r03B2 16r2563 16r03B3 16r2564 16r03B4 16r2565 16r03B5 16r2566 16r03B6 16r2567 16r03B7 16r2568 16r03B8 16r2569 16r03B9 16r256A 16r03BA 16r256B 16r03BB 16r256C 16r03BC 16r256D 16r03BD 16r256E 16r03BE 16r256F 16r03BF 16r2570 16r03C0 16r2571 16r03C1 16r2572 16r03C3 16r2573 16r03C4 16r2574 16r03C5 16r2575 16r03C6 16r2576 16r03C7 16r2577 16r03C8 16r2578 16r03C9 16r2621 16r2500 16r2622 16r2502 16r2623 16r250C 16r2624 16r2510 16r2625 16r2518 16r2626 16r2514 16r2627 16r251C 16r2628 16r252C 16r2629 16r2524 16r262A 16r2534 16r262B 16r253C 16r262C 16r2501 16r262D 16r2503 16r262E 16r250F 16r262F 16r2513 16r2630 16r251B 16r2631 16r2517 16r2632 16r2523 16r2633 16r2533 16r2634 16r252B 16r2635 16r253B 16r2636 16r254B 16r2637 16r2520 16r2638 16r252F 16r2639 16r2528 16r263A 16r2537 16r263B 16r253F 16r263C 16r251D 16r263D 16r2530 16r263E 16r2525 16r263F 16r2538 16r2640 16r2542 16r2641 16r2512 16r2642 16r2511 16r2643 16r251A 16r2644 16r2519 16r2645 16r2516 16r2646 16r2515 16r2647 16r250E 16r2648 16r250D 16r2649 16r251E 16r264A 16r251F 16r264B 16r2521 16r264C 16r2522 16r264D 16r2526 16r264E 16r2527 16r264F 16r2529 16r2650 16r252A 16r2651 16r252D 16r2652 16r252E 16r2653 16r2531 16r2654 16r2532 16r2655 16r2535 16r2656 16r2536 16r2657 16r2539 16r2658 16r253A 16r2659 16r253D 16r265A 16r253E 16r265B 16r2540 16r265C 16r2541 16r265D 16r2543 16r265E 16r2544 16r265F 16r2545 16r2660 16r2546 16r2661 16r2547 16r2662 16r2548 16r2663 16r2549 16r2664 16r254A 16r2721 16r3395 16r2722 16r3396 16r2723 16r3397 16r2724 16r2113 16r2725 16r3398 16r2726 16r33C4 16r2727 16r33A3 16r2728 16r33A4 16r2729 16r33A5 16r272A 16r33A6 16r272B 16r3399 16r272C 16r339A 16r272D 16r339B 16r272E 16r339C 16r272F 16r339D 16r2730 16r339E 16r2731 16r339F 16r2732 16r33A0 16r2733 16r33A1 16r2734 16r33A2 16r2735 16r33CA 16r2736 16r338D 16r2737 16r338E 16r2738 16r338F 16r2739 16r33CF 16r273A 16r3388 16r273B 16r3389 16r273C 16r33C8 16r273D 16r33A7 16r273E 16r33A8 16r273F 16r33B0 16r2740 16r33B1 16r2741 16r33B2 16r2742 16r33B3 16r2743 16r33B4 16r2744 16r33B5 16r2745 16r33B6 16r2746 16r33B7 16r2747 16r33B8 16r2748 16r33B9 16r2749 16r3380 16r274A 16r3381 16r274B 16r3382 16r274C 16r3383 16r274D 16r3384 16r274E 16r33BA 16r274F 16r33BB 16r2750 16r33BC 16r2751 16r33BD 16r2752 16r33BE 16r2753 16r33BF 16r2754 16r3390 16r2755 16r3391 16r2756 16r3392 16r2757 16r3393 16r2758 16r3394 16r2759 16r2126 16r275A 16r33C0 16r275B 16r33C1 16r275C 16r338A 16r275D 16r338B 16r275E 16r338C 16r275F 16r33D6 16r2760 16r33C5 16r2761 16r33AD 16r2762 16r33AE 16r2763 16r33AF 16r2764 16r33DB 16r2765 16r33A9 16r2766 16r33AA 16r2767 16r33AB 16r2768 16r33AC 16r2769 16r33DD 16r276A 16r33D0 16r276B 16r33D3 16r276C 16r33C3 16r276D 16r33C9 16r276E 16r33DC 16r276F 16r33C6 16r2821 16r00C6 16r2822 16r00D0 16r2823 16r00AA 16r2824 16r0126 16r2826 16r0132 16r2828 16r013F 16r2829 16r0141 16r282A 16r00D8 16r282B 16r0152 16r282C 16r00BA 16r282D 16r00DE 16r282E 16r0166 16r282F 16r014A 16r2831 16r3260 16r2832 16r3261 16r2833 16r3262 16r2834 16r3263 16r2835 16r3264 16r2836 16r3265 16r2837 16r3266 16r2838 16r3267 16r2839 16r3268 16r283A 16r3269 16r283B 16r326A 16r283C 16r326B 16r283D 16r326C 16r283E 16r326D 16r283F 16r326E 16r2840 16r326F 16r2841 16r3270 16r2842 16r3271 16r2843 16r3272 16r2844 16r3273 16r2845 16r3274 16r2846 16r3275 16r2847 16r3276 16r2848 16r3277 16r2849 16r3278 16r284A 16r3279 16r284B 16r327A 16r284C 16r327B 16r284D 16r24D0 16r284E 16r24D1 16r284F 16r24D2 16r2850 16r24D3 16r2851 16r24D4 16r2852 16r24D5 16r2853 16r24D6 16r2854 16r24D7 16r2855 16r24D8 16r2856 16r24D9 16r2857 16r24DA 16r2858 16r24DB 16r2859 16r24DC 16r285A 16r24DD 16r285B 16r24DE 16r285C 16r24DF 16r285D 16r24E0 16r285E 16r24E1 16r285F 16r24E2 16r2860 16r24E3 16r2861 16r24E4 16r2862 16r24E5 16r2863 16r24E6 16r2864 16r24E7 16r2865 16r24E8 16r2866 16r24E9 16r2867 16r2460 16r2868 16r2461 16r2869 16r2462 16r286A 16r2463 16r286B 16r2464 16r286C 16r2465 16r286D 16r2466 16r286E 16r2467 16r286F 16r2468 16r2870 16r2469 16r2871 16r246A 16r2872 16r246B 16r2873 16r246C 16r2874 16r246D 16r2875 16r246E 16r2876 16r00BD 16r2877 16r2153 16r2878 16r2154 16r2879 16r00BC 16r287A 16r00BE 16r287B 16r215B 16r287C 16r215C 16r287D 16r215D 16r287E 16r215E 16r2921 16r00E6 16r2922 16r0111 16r2923 16r00F0 16r2924 16r0127 16r2925 16r0131 16r2926 16r0133 16r2927 16r0138 16r2928 16r0140 16r2929 16r0142 16r292A 16r00F8 16r292B 16r0153 16r292C 16r00DF 16r292D 16r00FE 16r292E 16r0167 16r292F 16r014B 16r2930 16r0149 16r2931 16r3200 16r2932 16r3201 16r2933 16r3202 16r2934 16r3203 16r2935 16r3204 16r2936 16r3205 16r2937 16r3206 16r2938 16r3207 16r2939 16r3208 16r293A 16r3209 16r293B 16r320A 16r293C 16r320B 16r293D 16r320C 16r293E 16r320D 16r293F 16r320E 16r2940 16r320F 16r2941 16r3210 16r2942 16r3211 16r2943 16r3212 16r2944 16r3213 16r2945 16r3214 16r2946 16r3215 16r2947 16r3216 16r2948 16r3217 16r2949 16r3218 16r294A 16r3219 16r294B 16r321A 16r294C 16r321B 16r294D 16r249C 16r294E 16r249D 16r294F 16r249E 16r2950 16r249F 16r2951 16r24A0 16r2952 16r24A1 16r2953 16r24A2 16r2954 16r24A3 16r2955 16r24A4 16r2956 16r24A5 16r2957 16r24A6 16r2958 16r24A7 16r2959 16r24A8 16r295A 16r24A9 16r295B 16r24AA 16r295C 16r24AB 16r295D 16r24AC 16r295E 16r24AD 16r295F 16r24AE 16r2960 16r24AF 16r2961 16r24B0 16r2962 16r24B1 16r2963 16r24B2 16r2964 16r24B3 16r2965 16r24B4 16r2966 16r24B5 16r2967 16r2474 16r2968 16r2475 16r2969 16r2476 16r296A 16r2477 16r296B 16r2478 16r296C 16r2479 16r296D 16r247A 16r296E 16r247B 16r296F 16r247C 16r2970 16r247D 16r2971 16r247E 16r2972 16r247F 16r2973 16r2480 16r2974 16r2481 16r2975 16r2482 16r2976 16r00B9 16r2977 16r00B2 16r2978 16r00B3 16r2979 16r2074 16r297A 16r207F 16r297B 16r2081 16r297C 16r2082 16r297D 16r2083 16r297E 16r2084 16r2A21 16r3041 16r2A22 16r3042 16r2A23 16r3043 16r2A24 16r3044 16r2A25 16r3045 16r2A26 16r3046 16r2A27 16r3047 16r2A28 16r3048 16r2A29 16r3049 16r2A2A 16r304A 16r2A2B 16r304B 16r2A2C 16r304C 16r2A2D 16r304D 16r2A2E 16r304E 16r2A2F 16r304F 16r2A30 16r3050 16r2A31 16r3051 16r2A32 16r3052 16r2A33 16r3053 16r2A34 16r3054 16r2A35 16r3055 16r2A36 16r3056 16r2A37 16r3057 16r2A38 16r3058 16r2A39 16r3059 16r2A3A 16r305A 16r2A3B 16r305B 16r2A3C 16r305C 16r2A3D 16r305D 16r2A3E 16r305E 16r2A3F 16r305F 16r2A40 16r3060 16r2A41 16r3061 16r2A42 16r3062 16r2A43 16r3063 16r2A44 16r3064 16r2A45 16r3065 16r2A46 16r3066 16r2A47 16r3067 16r2A48 16r3068 16r2A49 16r3069 16r2A4A 16r306A 16r2A4B 16r306B 16r2A4C 16r306C 16r2A4D 16r306D 16r2A4E 16r306E 16r2A4F 16r306F 16r2A50 16r3070 16r2A51 16r3071 16r2A52 16r3072 16r2A53 16r3073 16r2A54 16r3074 16r2A55 16r3075 16r2A56 16r3076 16r2A57 16r3077 16r2A58 16r3078 16r2A59 16r3079 16r2A5A 16r307A 16r2A5B 16r307B 16r2A5C 16r307C 16r2A5D 16r307D 16r2A5E 16r307E 16r2A5F 16r307F 16r2A60 16r3080 16r2A61 16r3081 16r2A62 16r3082 16r2A63 16r3083 16r2A64 16r3084 16r2A65 16r3085 16r2A66 16r3086 16r2A67 16r3087 16r2A68 16r3088 16r2A69 16r3089 16r2A6A 16r308A 16r2A6B 16r308B 16r2A6C 16r308C 16r2A6D 16r308D 16r2A6E 16r308E 16r2A6F 16r308F 16r2A70 16r3090 16r2A71 16r3091 16r2A72 16r3092 16r2A73 16r3093 16r2B21 16r30A1 16r2B22 16r30A2 16r2B23 16r30A3 16r2B24 16r30A4 16r2B25 16r30A5 16r2B26 16r30A6 16r2B27 16r30A7 16r2B28 16r30A8 16r2B29 16r30A9 16r2B2A 16r30AA 16r2B2B 16r30AB 16r2B2C 16r30AC 16r2B2D 16r30AD 16r2B2E 16r30AE 16r2B2F 16r30AF 16r2B30 16r30B0 16r2B31 16r30B1 16r2B32 16r30B2 16r2B33 16r30B3 16r2B34 16r30B4 16r2B35 16r30B5 16r2B36 16r30B6 16r2B37 16r30B7 16r2B38 16r30B8 16r2B39 16r30B9 16r2B3A 16r30BA 16r2B3B 16r30BB 16r2B3C 16r30BC 16r2B3D 16r30BD 16r2B3E 16r30BE 16r2B3F 16r30BF 16r2B40 16r30C0 16r2B41 16r30C1 16r2B42 16r30C2 16r2B43 16r30C3 16r2B44 16r30C4 16r2B45 16r30C5 16r2B46 16r30C6 16r2B47 16r30C7 16r2B48 16r30C8 16r2B49 16r30C9 16r2B4A 16r30CA 16r2B4B 16r30CB 16r2B4C 16r30CC 16r2B4D 16r30CD 16r2B4E 16r30CE 16r2B4F 16r30CF 16r2B50 16r30D0 16r2B51 16r30D1 16r2B52 16r30D2 16r2B53 16r30D3 16r2B54 16r30D4 16r2B55 16r30D5 16r2B56 16r30D6 16r2B57 16r30D7 16r2B58 16r30D8 16r2B59 16r30D9 16r2B5A 16r30DA 16r2B5B 16r30DB 16r2B5C 16r30DC 16r2B5D 16r30DD 16r2B5E 16r30DE 16r2B5F 16r30DF 16r2B60 16r30E0 16r2B61 16r30E1 16r2B62 16r30E2 16r2B63 16r30E3 16r2B64 16r30E4 16r2B65 16r30E5 16r2B66 16r30E6 16r2B67 16r30E7 16r2B68 16r30E8 16r2B69 16r30E9 16r2B6A 16r30EA 16r2B6B 16r30EB 16r2B6C 16r30EC 16r2B6D 16r30ED 16r2B6E 16r30EE 16r2B6F 16r30EF 16r2B70 16r30F0 16r2B71 16r30F1 16r2B72 16r30F2 16r2B73 16r30F3 16r2B74 16r30F4 16r2B75 16r30F5 16r2B76 16r30F6 16r2C21 16r0410 16r2C22 16r0411 16r2C23 16r0412 16r2C24 16r0413 16r2C25 16r0414 16r2C26 16r0415 16r2C27 16r0401 16r2C28 16r0416 16r2C29 16r0417 16r2C2A 16r0418 16r2C2B 16r0419 16r2C2C 16r041A 16r2C2D 16r041B 16r2C2E 16r041C 16r2C2F 16r041D 16r2C30 16r041E 16r2C31 16r041F 16r2C32 16r0420 16r2C33 16r0421 16r2C34 16r0422 16r2C35 16r0423 16r2C36 16r0424 16r2C37 16r0425 16r2C38 16r0426 16r2C39 16r0427 16r2C3A 16r0428 16r2C3B 16r0429 16r2C3C 16r042A 16r2C3D 16r042B 16r2C3E 16r042C 16r2C3F 16r042D 16r2C40 16r042E 16r2C41 16r042F 16r2C51 16r0430 16r2C52 16r0431 16r2C53 16r0432 16r2C54 16r0433 16r2C55 16r0434 16r2C56 16r0435 16r2C57 16r0451 16r2C58 16r0436 16r2C59 16r0437 16r2C5A 16r0438 16r2C5B 16r0439 16r2C5C 16r043A 16r2C5D 16r043B 16r2C5E 16r043C 16r2C5F 16r043D 16r2C60 16r043E 16r2C61 16r043F 16r2C62 16r0440 16r2C63 16r0441 16r2C64 16r0442 16r2C65 16r0443 16r2C66 16r0444 16r2C67 16r0445 16r2C68 16r0446 16r2C69 16r0447 16r2C6A 16r0448 16r2C6B 16r0449 16r2C6C 16r044A 16r2C6D 16r044B 16r2C6E 16r044C 16r2C6F 16r044D 16r2C70 16r044E 16r2C71 16r044F 16r3021 16rAC00 16r3022 16rAC01 16r3023 16rAC04 16r3024 16rAC07 16r3025 16rAC08 16r3026 16rAC09 16r3027 16rAC0A 16r3028 16rAC10 16r3029 16rAC11 16r302A 16rAC12 16r302B 16rAC13 16r302C 16rAC14 16r302D 16rAC15 16r302E 16rAC16 16r302F 16rAC17 16r3030 16rAC19 16r3031 16rAC1A 16r3032 16rAC1B 16r3033 16rAC1C 16r3034 16rAC1D 16r3035 16rAC20 16r3036 16rAC24 16r3037 16rAC2C 16r3038 16rAC2D 16r3039 16rAC2F 16r303A 16rAC30 16r303B 16rAC31 16r303C 16rAC38 16r303D 16rAC39 16r303E 16rAC3C 16r303F 16rAC40 16r3040 16rAC4B 16r3041 16rAC4D 16r3042 16rAC54 16r3043 16rAC58 16r3044 16rAC5C 16r3045 16rAC70 16r3046 16rAC71 16r3047 16rAC74 16r3048 16rAC77 16r3049 16rAC78 16r304A 16rAC7A 16r304B 16rAC80 16r304C 16rAC81 16r304D 16rAC83 16r304E 16rAC84 16r304F 16rAC85 16r3050 16rAC86 16r3051 16rAC89 16r3052 16rAC8A 16r3053 16rAC8B 16r3054 16rAC8C 16r3055 16rAC90 16r3056 16rAC94 16r3057 16rAC9C 16r3058 16rAC9D 16r3059 16rAC9F 16r305A 16rACA0 16r305B 16rACA1 16r305C 16rACA8 16r305D 16rACA9 16r305E 16rACAA 16r305F 16rACAC 16r3060 16rACAF 16r3061 16rACB0 16r3062 16rACB8 16r3063 16rACB9 16r3064 16rACBB 16r3065 16rACBC 16r3066 16rACBD 16r3067 16rACC1 16r3068 16rACC4 16r3069 16rACC8 16r306A 16rACCC 16r306B 16rACD5 16r306C 16rACD7 16r306D 16rACE0 16r306E 16rACE1 16r306F 16rACE4 16r3070 16rACE7 16r3071 16rACE8 16r3072 16rACEA 16r3073 16rACEC 16r3074 16rACEF 16r3075 16rACF0 16r3076 16rACF1 16r3077 16rACF3 16r3078 16rACF5 16r3079 16rACF6 16r307A 16rACFC 16r307B 16rACFD 16r307C 16rAD00 16r307D 16rAD04 16r307E 16rAD06 16r3121 16rAD0C 16r3122 16rAD0D 16r3123 16rAD0F 16r3124 16rAD11 16r3125 16rAD18 16r3126 16rAD1C 16r3127 16rAD20 16r3128 16rAD29 16r3129 16rAD2C 16r312A 16rAD2D 16r312B 16rAD34 16r312C 16rAD35 16r312D 16rAD38 16r312E 16rAD3C 16r312F 16rAD44 16r3130 16rAD45 16r3131 16rAD47 16r3132 16rAD49 16r3133 16rAD50 16r3134 16rAD54 16r3135 16rAD58 16r3136 16rAD61 16r3137 16rAD63 16r3138 16rAD6C 16r3139 16rAD6D 16r313A 16rAD70 16r313B 16rAD73 16r313C 16rAD74 16r313D 16rAD75 16r313E 16rAD76 16r313F 16rAD7B 16r3140 16rAD7C 16r3141 16rAD7D 16r3142 16rAD7F 16r3143 16rAD81 16r3144 16rAD82 16r3145 16rAD88 16r3146 16rAD89 16r3147 16rAD8C 16r3148 16rAD90 16r3149 16rAD9C 16r314A 16rAD9D 16r314B 16rADA4 16r314C 16rADB7 16r314D 16rADC0 16r314E 16rADC1 16r314F 16rADC4 16r3150 16rADC8 16r3151 16rADD0 16r3152 16rADD1 16r3153 16rADD3 16r3154 16rADDC 16r3155 16rADE0 16r3156 16rADE4 16r3157 16rADF8 16r3158 16rADF9 16r3159 16rADFC 16r315A 16rADFF 16r315B 16rAE00 16r315C 16rAE01 16r315D 16rAE08 16r315E 16rAE09 16r315F 16rAE0B 16r3160 16rAE0D 16r3161 16rAE14 16r3162 16rAE30 16r3163 16rAE31 16r3164 16rAE34 16r3165 16rAE37 16r3166 16rAE38 16r3167 16rAE3A 16r3168 16rAE40 16r3169 16rAE41 16r316A 16rAE43 16r316B 16rAE45 16r316C 16rAE46 16r316D 16rAE4A 16r316E 16rAE4C 16r316F 16rAE4D 16r3170 16rAE4E 16r3171 16rAE50 16r3172 16rAE54 16r3173 16rAE56 16r3174 16rAE5C 16r3175 16rAE5D 16r3176 16rAE5F 16r3177 16rAE60 16r3178 16rAE61 16r3179 16rAE65 16r317A 16rAE68 16r317B 16rAE69 16r317C 16rAE6C 16r317D 16rAE70 16r317E 16rAE78 16r3221 16rAE79 16r3222 16rAE7B 16r3223 16rAE7C 16r3224 16rAE7D 16r3225 16rAE84 16r3226 16rAE85 16r3227 16rAE8C 16r3228 16rAEBC 16r3229 16rAEBD 16r322A 16rAEBE 16r322B 16rAEC0 16r322C 16rAEC4 16r322D 16rAECC 16r322E 16rAECD 16r322F 16rAECF 16r3230 16rAED0 16r3231 16rAED1 16r3232 16rAED8 16r3233 16rAED9 16r3234 16rAEDC 16r3235 16rAEE8 16r3236 16rAEEB 16r3237 16rAEED 16r3238 16rAEF4 16r3239 16rAEF8 16r323A 16rAEFC 16r323B 16rAF07 16r323C 16rAF08 16r323D 16rAF0D 16r323E 16rAF10 16r323F 16rAF2C 16r3240 16rAF2D 16r3241 16rAF30 16r3242 16rAF32 16r3243 16rAF34 16r3244 16rAF3C 16r3245 16rAF3D 16r3246 16rAF3F 16r3247 16rAF41 16r3248 16rAF42 16r3249 16rAF43 16r324A 16rAF48 16r324B 16rAF49 16r324C 16rAF50 16r324D 16rAF5C 16r324E 16rAF5D 16r324F 16rAF64 16r3250 16rAF65 16r3251 16rAF79 16r3252 16rAF80 16r3253 16rAF84 16r3254 16rAF88 16r3255 16rAF90 16r3256 16rAF91 16r3257 16rAF95 16r3258 16rAF9C 16r3259 16rAFB8 16r325A 16rAFB9 16r325B 16rAFBC 16r325C 16rAFC0 16r325D 16rAFC7 16r325E 16rAFC8 16r325F 16rAFC9 16r3260 16rAFCB 16r3261 16rAFCD 16r3262 16rAFCE 16r3263 16rAFD4 16r3264 16rAFDC 16r3265 16rAFE8 16r3266 16rAFE9 16r3267 16rAFF0 16r3268 16rAFF1 16r3269 16rAFF4 16r326A 16rAFF8 16r326B 16rB000 16r326C 16rB001 16r326D 16rB004 16r326E 16rB00C 16r326F 16rB010 16r3270 16rB014 16r3271 16rB01C 16r3272 16rB01D 16r3273 16rB028 16r3274 16rB044 16r3275 16rB045 16r3276 16rB048 16r3277 16rB04A 16r3278 16rB04C 16r3279 16rB04E 16r327A 16rB053 16r327B 16rB054 16r327C 16rB055 16r327D 16rB057 16r327E 16rB059 16r3321 16rB05D 16r3322 16rB07C 16r3323 16rB07D 16r3324 16rB080 16r3325 16rB084 16r3326 16rB08C 16r3327 16rB08D 16r3328 16rB08F 16r3329 16rB091 16r332A 16rB098 16r332B 16rB099 16r332C 16rB09A 16r332D 16rB09C 16r332E 16rB09F 16r332F 16rB0A0 16r3330 16rB0A1 16r3331 16rB0A2 16r3332 16rB0A8 16r3333 16rB0A9 16r3334 16rB0AB 16r3335 16rB0AC 16r3336 16rB0AD 16r3337 16rB0AE 16r3338 16rB0AF 16r3339 16rB0B1 16r333A 16rB0B3 16r333B 16rB0B4 16r333C 16rB0B5 16r333D 16rB0B8 16r333E 16rB0BC 16r333F 16rB0C4 16r3340 16rB0C5 16r3341 16rB0C7 16r3342 16rB0C8 16r3343 16rB0C9 16r3344 16rB0D0 16r3345 16rB0D1 16r3346 16rB0D4 16r3347 16rB0D8 16r3348 16rB0E0 16r3349 16rB0E5 16r334A 16rB108 16r334B 16rB109 16r334C 16rB10B 16r334D 16rB10C 16r334E 16rB110 16r334F 16rB112 16r3350 16rB113 16r3351 16rB118 16r3352 16rB119 16r3353 16rB11B 16r3354 16rB11C 16r3355 16rB11D 16r3356 16rB123 16r3357 16rB124 16r3358 16rB125 16r3359 16rB128 16r335A 16rB12C 16r335B 16rB134 16r335C 16rB135 16r335D 16rB137 16r335E 16rB138 16r335F 16rB139 16r3360 16rB140 16r3361 16rB141 16r3362 16rB144 16r3363 16rB148 16r3364 16rB150 16r3365 16rB151 16r3366 16rB154 16r3367 16rB155 16r3368 16rB158 16r3369 16rB15C 16r336A 16rB160 16r336B 16rB178 16r336C 16rB179 16r336D 16rB17C 16r336E 16rB180 16r336F 16rB182 16r3370 16rB188 16r3371 16rB189 16r3372 16rB18B 16r3373 16rB18D 16r3374 16rB192 16r3375 16rB193 16r3376 16rB194 16r3377 16rB198 16r3378 16rB19C 16r3379 16rB1A8 16r337A 16rB1CC 16r337B 16rB1D0 16r337C 16rB1D4 16r337D 16rB1DC 16r337E 16rB1DD 16r3421 16rB1DF 16r3422 16rB1E8 16r3423 16rB1E9 16r3424 16rB1EC 16r3425 16rB1F0 16r3426 16rB1F9 16r3427 16rB1FB 16r3428 16rB1FD 16r3429 16rB204 16r342A 16rB205 16r342B 16rB208 16r342C 16rB20B 16r342D 16rB20C 16r342E 16rB214 16r342F 16rB215 16r3430 16rB217 16r3431 16rB219 16r3432 16rB220 16r3433 16rB234 16r3434 16rB23C 16r3435 16rB258 16r3436 16rB25C 16r3437 16rB260 16r3438 16rB268 16r3439 16rB269 16r343A 16rB274 16r343B 16rB275 16r343C 16rB27C 16r343D 16rB284 16r343E 16rB285 16r343F 16rB289 16r3440 16rB290 16r3441 16rB291 16r3442 16rB294 16r3443 16rB298 16r3444 16rB299 16r3445 16rB29A 16r3446 16rB2A0 16r3447 16rB2A1 16r3448 16rB2A3 16r3449 16rB2A5 16r344A 16rB2A6 16r344B 16rB2AA 16r344C 16rB2AC 16r344D 16rB2B0 16r344E 16rB2B4 16r344F 16rB2C8 16r3450 16rB2C9 16r3451 16rB2CC 16r3452 16rB2D0 16r3453 16rB2D2 16r3454 16rB2D8 16r3455 16rB2D9 16r3456 16rB2DB 16r3457 16rB2DD 16r3458 16rB2E2 16r3459 16rB2E4 16r345A 16rB2E5 16r345B 16rB2E6 16r345C 16rB2E8 16r345D 16rB2EB 16r345E 16rB2EC 16r345F 16rB2ED 16r3460 16rB2EE 16r3461 16rB2EF 16r3462 16rB2F3 16r3463 16rB2F4 16r3464 16rB2F5 16r3465 16rB2F7 16r3466 16rB2F8 16r3467 16rB2F9 16r3468 16rB2FA 16r3469 16rB2FB 16r346A 16rB2FF 16r346B 16rB300 16r346C 16rB301 16r346D 16rB304 16r346E 16rB308 16r346F 16rB310 16r3470 16rB311 16r3471 16rB313 16r3472 16rB314 16r3473 16rB315 16r3474 16rB31C 16r3475 16rB354 16r3476 16rB355 16r3477 16rB356 16r3478 16rB358 16r3479 16rB35B 16r347A 16rB35C 16r347B 16rB35E 16r347C 16rB35F 16r347D 16rB364 16r347E 16rB365 16r3521 16rB367 16r3522 16rB369 16r3523 16rB36B 16r3524 16rB36E 16r3525 16rB370 16r3526 16rB371 16r3527 16rB374 16r3528 16rB378 16r3529 16rB380 16r352A 16rB381 16r352B 16rB383 16r352C 16rB384 16r352D 16rB385 16r352E 16rB38C 16r352F 16rB390 16r3530 16rB394 16r3531 16rB3A0 16r3532 16rB3A1 16r3533 16rB3A8 16r3534 16rB3AC 16r3535 16rB3C4 16r3536 16rB3C5 16r3537 16rB3C8 16r3538 16rB3CB 16r3539 16rB3CC 16r353A 16rB3CE 16r353B 16rB3D0 16r353C 16rB3D4 16r353D 16rB3D5 16r353E 16rB3D7 16r353F 16rB3D9 16r3540 16rB3DB 16r3541 16rB3DD 16r3542 16rB3E0 16r3543 16rB3E4 16r3544 16rB3E8 16r3545 16rB3FC 16r3546 16rB410 16r3547 16rB418 16r3548 16rB41C 16r3549 16rB420 16r354A 16rB428 16r354B 16rB429 16r354C 16rB42B 16r354D 16rB434 16r354E 16rB450 16r354F 16rB451 16r3550 16rB454 16r3551 16rB458 16r3552 16rB460 16r3553 16rB461 16r3554 16rB463 16r3555 16rB465 16r3556 16rB46C 16r3557 16rB480 16r3558 16rB488 16r3559 16rB49D 16r355A 16rB4A4 16r355B 16rB4A8 16r355C 16rB4AC 16r355D 16rB4B5 16r355E 16rB4B7 16r355F 16rB4B9 16r3560 16rB4C0 16r3561 16rB4C4 16r3562 16rB4C8 16r3563 16rB4D0 16r3564 16rB4D5 16r3565 16rB4DC 16r3566 16rB4DD 16r3567 16rB4E0 16r3568 16rB4E3 16r3569 16rB4E4 16r356A 16rB4E6 16r356B 16rB4EC 16r356C 16rB4ED 16r356D 16rB4EF 16r356E 16rB4F1 16r356F 16rB4F8 16r3570 16rB514 16r3571 16rB515 16r3572 16rB518 16r3573 16rB51B 16r3574 16rB51C 16r3575 16rB524 16r3576 16rB525 16r3577 16rB527 16r3578 16rB528 16r3579 16rB529 16r357A 16rB52A 16r357B 16rB530 16r357C 16rB531 16r357D 16rB534 16r357E 16rB538 16r3621 16rB540 16r3622 16rB541 16r3623 16rB543 16r3624 16rB544 16r3625 16rB545 16r3626 16rB54B 16r3627 16rB54C 16r3628 16rB54D 16r3629 16rB550 16r362A 16rB554 16r362B 16rB55C 16r362C 16rB55D 16r362D 16rB55F 16r362E 16rB560 16r362F 16rB561 16r3630 16rB5A0 16r3631 16rB5A1 16r3632 16rB5A4 16r3633 16rB5A8 16r3634 16rB5AA 16r3635 16rB5AB 16r3636 16rB5B0 16r3637 16rB5B1 16r3638 16rB5B3 16r3639 16rB5B4 16r363A 16rB5B5 16r363B 16rB5BB 16r363C 16rB5BC 16r363D 16rB5BD 16r363E 16rB5C0 16r363F 16rB5C4 16r3640 16rB5CC 16r3641 16rB5CD 16r3642 16rB5CF 16r3643 16rB5D0 16r3644 16rB5D1 16r3645 16rB5D8 16r3646 16rB5EC 16r3647 16rB610 16r3648 16rB611 16r3649 16rB614 16r364A 16rB618 16r364B 16rB625 16r364C 16rB62C 16r364D 16rB634 16r364E 16rB648 16r364F 16rB664 16r3650 16rB668 16r3651 16rB69C 16r3652 16rB69D 16r3653 16rB6A0 16r3654 16rB6A4 16r3655 16rB6AB 16r3656 16rB6AC 16r3657 16rB6B1 16r3658 16rB6D4 16r3659 16rB6F0 16r365A 16rB6F4 16r365B 16rB6F8 16r365C 16rB700 16r365D 16rB701 16r365E 16rB705 16r365F 16rB728 16r3660 16rB729 16r3661 16rB72C 16r3662 16rB72F 16r3663 16rB730 16r3664 16rB738 16r3665 16rB739 16r3666 16rB73B 16r3667 16rB744 16r3668 16rB748 16r3669 16rB74C 16r366A 16rB754 16r366B 16rB755 16r366C 16rB760 16r366D 16rB764 16r366E 16rB768 16r366F 16rB770 16r3670 16rB771 16r3671 16rB773 16r3672 16rB775 16r3673 16rB77C 16r3674 16rB77D 16r3675 16rB780 16r3676 16rB784 16r3677 16rB78C 16r3678 16rB78D 16r3679 16rB78F 16r367A 16rB790 16r367B 16rB791 16r367C 16rB792 16r367D 16rB796 16r367E 16rB797 16r3721 16rB798 16r3722 16rB799 16r3723 16rB79C 16r3724 16rB7A0 16r3725 16rB7A8 16r3726 16rB7A9 16r3727 16rB7AB 16r3728 16rB7AC 16r3729 16rB7AD 16r372A 16rB7B4 16r372B 16rB7B5 16r372C 16rB7B8 16r372D 16rB7C7 16r372E 16rB7C9 16r372F 16rB7EC 16r3730 16rB7ED 16r3731 16rB7F0 16r3732 16rB7F4 16r3733 16rB7FC 16r3734 16rB7FD 16r3735 16rB7FF 16r3736 16rB800 16r3737 16rB801 16r3738 16rB807 16r3739 16rB808 16r373A 16rB809 16r373B 16rB80C 16r373C 16rB810 16r373D 16rB818 16r373E 16rB819 16r373F 16rB81B 16r3740 16rB81D 16r3741 16rB824 16r3742 16rB825 16r3743 16rB828 16r3744 16rB82C 16r3745 16rB834 16r3746 16rB835 16r3747 16rB837 16r3748 16rB838 16r3749 16rB839 16r374A 16rB840 16r374B 16rB844 16r374C 16rB851 16r374D 16rB853 16r374E 16rB85C 16r374F 16rB85D 16r3750 16rB860 16r3751 16rB864 16r3752 16rB86C 16r3753 16rB86D 16r3754 16rB86F 16r3755 16rB871 16r3756 16rB878 16r3757 16rB87C 16r3758 16rB88D 16r3759 16rB8A8 16r375A 16rB8B0 16r375B 16rB8B4 16r375C 16rB8B8 16r375D 16rB8C0 16r375E 16rB8C1 16r375F 16rB8C3 16r3760 16rB8C5 16r3761 16rB8CC 16r3762 16rB8D0 16r3763 16rB8D4 16r3764 16rB8DD 16r3765 16rB8DF 16r3766 16rB8E1 16r3767 16rB8E8 16r3768 16rB8E9 16r3769 16rB8EC 16r376A 16rB8F0 16r376B 16rB8F8 16r376C 16rB8F9 16r376D 16rB8FB 16r376E 16rB8FD 16r376F 16rB904 16r3770 16rB918 16r3771 16rB920 16r3772 16rB93C 16r3773 16rB93D 16r3774 16rB940 16r3775 16rB944 16r3776 16rB94C 16r3777 16rB94F 16r3778 16rB951 16r3779 16rB958 16r377A 16rB959 16r377B 16rB95C 16r377C 16rB960 16r377D 16rB968 16r377E 16rB969 16r3821 16rB96B 16r3822 16rB96D 16r3823 16rB974 16r3824 16rB975 16r3825 16rB978 16r3826 16rB97C 16r3827 16rB984 16r3828 16rB985 16r3829 16rB987 16r382A 16rB989 16r382B 16rB98A 16r382C 16rB98D 16r382D 16rB98E 16r382E 16rB9AC 16r382F 16rB9AD 16r3830 16rB9B0 16r3831 16rB9B4 16r3832 16rB9BC 16r3833 16rB9BD 16r3834 16rB9BF 16r3835 16rB9C1 16r3836 16rB9C8 16r3837 16rB9C9 16r3838 16rB9CC 16r3839 16rB9CE 16r383A 16rB9CF 16r383B 16rB9D0 16r383C 16rB9D1 16r383D 16rB9D2 16r383E 16rB9D8 16r383F 16rB9D9 16r3840 16rB9DB 16r3841 16rB9DD 16r3842 16rB9DE 16r3843 16rB9E1 16r3844 16rB9E3 16r3845 16rB9E4 16r3846 16rB9E5 16r3847 16rB9E8 16r3848 16rB9EC 16r3849 16rB9F4 16r384A 16rB9F5 16r384B 16rB9F7 16r384C 16rB9F8 16r384D 16rB9F9 16r384E 16rB9FA 16r384F 16rBA00 16r3850 16rBA01 16r3851 16rBA08 16r3852 16rBA15 16r3853 16rBA38 16r3854 16rBA39 16r3855 16rBA3C 16r3856 16rBA40 16r3857 16rBA42 16r3858 16rBA48 16r3859 16rBA49 16r385A 16rBA4B 16r385B 16rBA4D 16r385C 16rBA4E 16r385D 16rBA53 16r385E 16rBA54 16r385F 16rBA55 16r3860 16rBA58 16r3861 16rBA5C 16r3862 16rBA64 16r3863 16rBA65 16r3864 16rBA67 16r3865 16rBA68 16r3866 16rBA69 16r3867 16rBA70 16r3868 16rBA71 16r3869 16rBA74 16r386A 16rBA78 16r386B 16rBA83 16r386C 16rBA84 16r386D 16rBA85 16r386E 16rBA87 16r386F 16rBA8C 16r3870 16rBAA8 16r3871 16rBAA9 16r3872 16rBAAB 16r3873 16rBAAC 16r3874 16rBAB0 16r3875 16rBAB2 16r3876 16rBAB8 16r3877 16rBAB9 16r3878 16rBABB 16r3879 16rBABD 16r387A 16rBAC4 16r387B 16rBAC8 16r387C 16rBAD8 16r387D 16rBAD9 16r387E 16rBAFC 16r3921 16rBB00 16r3922 16rBB04 16r3923 16rBB0D 16r3924 16rBB0F 16r3925 16rBB11 16r3926 16rBB18 16r3927 16rBB1C 16r3928 16rBB20 16r3929 16rBB29 16r392A 16rBB2B 16r392B 16rBB34 16r392C 16rBB35 16r392D 16rBB36 16r392E 16rBB38 16r392F 16rBB3B 16r3930 16rBB3C 16r3931 16rBB3D 16r3932 16rBB3E 16r3933 16rBB44 16r3934 16rBB45 16r3935 16rBB47 16r3936 16rBB49 16r3937 16rBB4D 16r3938 16rBB4F 16r3939 16rBB50 16r393A 16rBB54 16r393B 16rBB58 16r393C 16rBB61 16r393D 16rBB63 16r393E 16rBB6C 16r393F 16rBB88 16r3940 16rBB8C 16r3941 16rBB90 16r3942 16rBBA4 16r3943 16rBBA8 16r3944 16rBBAC 16r3945 16rBBB4 16r3946 16rBBB7 16r3947 16rBBC0 16r3948 16rBBC4 16r3949 16rBBC8 16r394A 16rBBD0 16r394B 16rBBD3 16r394C 16rBBF8 16r394D 16rBBF9 16r394E 16rBBFC 16r394F 16rBBFF 16r3950 16rBC00 16r3951 16rBC02 16r3952 16rBC08 16r3953 16rBC09 16r3954 16rBC0B 16r3955 16rBC0C 16r3956 16rBC0D 16r3957 16rBC0F 16r3958 16rBC11 16r3959 16rBC14 16r395A 16rBC15 16r395B 16rBC16 16r395C 16rBC17 16r395D 16rBC18 16r395E 16rBC1B 16r395F 16rBC1C 16r3960 16rBC1D 16r3961 16rBC1E 16r3962 16rBC1F 16r3963 16rBC24 16r3964 16rBC25 16r3965 16rBC27 16r3966 16rBC29 16r3967 16rBC2D 16r3968 16rBC30 16r3969 16rBC31 16r396A 16rBC34 16r396B 16rBC38 16r396C 16rBC40 16r396D 16rBC41 16r396E 16rBC43 16r396F 16rBC44 16r3970 16rBC45 16r3971 16rBC49 16r3972 16rBC4C 16r3973 16rBC4D 16r3974 16rBC50 16r3975 16rBC5D 16r3976 16rBC84 16r3977 16rBC85 16r3978 16rBC88 16r3979 16rBC8B 16r397A 16rBC8C 16r397B 16rBC8E 16r397C 16rBC94 16r397D 16rBC95 16r397E 16rBC97 16r3A21 16rBC99 16r3A22 16rBC9A 16r3A23 16rBCA0 16r3A24 16rBCA1 16r3A25 16rBCA4 16r3A26 16rBCA7 16r3A27 16rBCA8 16r3A28 16rBCB0 16r3A29 16rBCB1 16r3A2A 16rBCB3 16r3A2B 16rBCB4 16r3A2C 16rBCB5 16r3A2D 16rBCBC 16r3A2E 16rBCBD 16r3A2F 16rBCC0 16r3A30 16rBCC4 16r3A31 16rBCCD 16r3A32 16rBCCF 16r3A33 16rBCD0 16r3A34 16rBCD1 16r3A35 16rBCD5 16r3A36 16rBCD8 16r3A37 16rBCDC 16r3A38 16rBCF4 16r3A39 16rBCF5 16r3A3A 16rBCF6 16r3A3B 16rBCF8 16r3A3C 16rBCFC 16r3A3D 16rBD04 16r3A3E 16rBD05 16r3A3F 16rBD07 16r3A40 16rBD09 16r3A41 16rBD10 16r3A42 16rBD14 16r3A43 16rBD24 16r3A44 16rBD2C 16r3A45 16rBD40 16r3A46 16rBD48 16r3A47 16rBD49 16r3A48 16rBD4C 16r3A49 16rBD50 16r3A4A 16rBD58 16r3A4B 16rBD59 16r3A4C 16rBD64 16r3A4D 16rBD68 16r3A4E 16rBD80 16r3A4F 16rBD81 16r3A50 16rBD84 16r3A51 16rBD87 16r3A52 16rBD88 16r3A53 16rBD89 16r3A54 16rBD8A 16r3A55 16rBD90 16r3A56 16rBD91 16r3A57 16rBD93 16r3A58 16rBD95 16r3A59 16rBD99 16r3A5A 16rBD9A 16r3A5B 16rBD9C 16r3A5C 16rBDA4 16r3A5D 16rBDB0 16r3A5E 16rBDB8 16r3A5F 16rBDD4 16r3A60 16rBDD5 16r3A61 16rBDD8 16r3A62 16rBDDC 16r3A63 16rBDE9 16r3A64 16rBDF0 16r3A65 16rBDF4 16r3A66 16rBDF8 16r3A67 16rBE00 16r3A68 16rBE03 16r3A69 16rBE05 16r3A6A 16rBE0C 16r3A6B 16rBE0D 16r3A6C 16rBE10 16r3A6D 16rBE14 16r3A6E 16rBE1C 16r3A6F 16rBE1D 16r3A70 16rBE1F 16r3A71 16rBE44 16r3A72 16rBE45 16r3A73 16rBE48 16r3A74 16rBE4C 16r3A75 16rBE4E 16r3A76 16rBE54 16r3A77 16rBE55 16r3A78 16rBE57 16r3A79 16rBE59 16r3A7A 16rBE5A 16r3A7B 16rBE5B 16r3A7C 16rBE60 16r3A7D 16rBE61 16r3A7E 16rBE64 16r3B21 16rBE68 16r3B22 16rBE6A 16r3B23 16rBE70 16r3B24 16rBE71 16r3B25 16rBE73 16r3B26 16rBE74 16r3B27 16rBE75 16r3B28 16rBE7B 16r3B29 16rBE7C 16r3B2A 16rBE7D 16r3B2B 16rBE80 16r3B2C 16rBE84 16r3B2D 16rBE8C 16r3B2E 16rBE8D 16r3B2F 16rBE8F 16r3B30 16rBE90 16r3B31 16rBE91 16r3B32 16rBE98 16r3B33 16rBE99 16r3B34 16rBEA8 16r3B35 16rBED0 16r3B36 16rBED1 16r3B37 16rBED4 16r3B38 16rBED7 16r3B39 16rBED8 16r3B3A 16rBEE0 16r3B3B 16rBEE3 16r3B3C 16rBEE4 16r3B3D 16rBEE5 16r3B3E 16rBEEC 16r3B3F 16rBF01 16r3B40 16rBF08 16r3B41 16rBF09 16r3B42 16rBF18 16r3B43 16rBF19 16r3B44 16rBF1B 16r3B45 16rBF1C 16r3B46 16rBF1D 16r3B47 16rBF40 16r3B48 16rBF41 16r3B49 16rBF44 16r3B4A 16rBF48 16r3B4B 16rBF50 16r3B4C 16rBF51 16r3B4D 16rBF55 16r3B4E 16rBF94 16r3B4F 16rBFB0 16r3B50 16rBFC5 16r3B51 16rBFCC 16r3B52 16rBFCD 16r3B53 16rBFD0 16r3B54 16rBFD4 16r3B55 16rBFDC 16r3B56 16rBFDF 16r3B57 16rBFE1 16r3B58 16rC03C 16r3B59 16rC051 16r3B5A 16rC058 16r3B5B 16rC05C 16r3B5C 16rC060 16r3B5D 16rC068 16r3B5E 16rC069 16r3B5F 16rC090 16r3B60 16rC091 16r3B61 16rC094 16r3B62 16rC098 16r3B63 16rC0A0 16r3B64 16rC0A1 16r3B65 16rC0A3 16r3B66 16rC0A5 16r3B67 16rC0AC 16r3B68 16rC0AD 16r3B69 16rC0AF 16r3B6A 16rC0B0 16r3B6B 16rC0B3 16r3B6C 16rC0B4 16r3B6D 16rC0B5 16r3B6E 16rC0B6 16r3B6F 16rC0BC 16r3B70 16rC0BD 16r3B71 16rC0BF 16r3B72 16rC0C0 16r3B73 16rC0C1 16r3B74 16rC0C5 16r3B75 16rC0C8 16r3B76 16rC0C9 16r3B77 16rC0CC 16r3B78 16rC0D0 16r3B79 16rC0D8 16r3B7A 16rC0D9 16r3B7B 16rC0DB 16r3B7C 16rC0DC 16r3B7D 16rC0DD 16r3B7E 16rC0E4 16r3C21 16rC0E5 16r3C22 16rC0E8 16r3C23 16rC0EC 16r3C24 16rC0F4 16r3C25 16rC0F5 16r3C26 16rC0F7 16r3C27 16rC0F9 16r3C28 16rC100 16r3C29 16rC104 16r3C2A 16rC108 16r3C2B 16rC110 16r3C2C 16rC115 16r3C2D 16rC11C 16r3C2E 16rC11D 16r3C2F 16rC11E 16r3C30 16rC11F 16r3C31 16rC120 16r3C32 16rC123 16r3C33 16rC124 16r3C34 16rC126 16r3C35 16rC127 16r3C36 16rC12C 16r3C37 16rC12D 16r3C38 16rC12F 16r3C39 16rC130 16r3C3A 16rC131 16r3C3B 16rC136 16r3C3C 16rC138 16r3C3D 16rC139 16r3C3E 16rC13C 16r3C3F 16rC140 16r3C40 16rC148 16r3C41 16rC149 16r3C42 16rC14B 16r3C43 16rC14C 16r3C44 16rC14D 16r3C45 16rC154 16r3C46 16rC155 16r3C47 16rC158 16r3C48 16rC15C 16r3C49 16rC164 16r3C4A 16rC165 16r3C4B 16rC167 16r3C4C 16rC168 16r3C4D 16rC169 16r3C4E 16rC170 16r3C4F 16rC174 16r3C50 16rC178 16r3C51 16rC185 16r3C52 16rC18C 16r3C53 16rC18D 16r3C54 16rC18E 16r3C55 16rC190 16r3C56 16rC194 16r3C57 16rC196 16r3C58 16rC19C 16r3C59 16rC19D 16r3C5A 16rC19F 16r3C5B 16rC1A1 16r3C5C 16rC1A5 16r3C5D 16rC1A8 16r3C5E 16rC1A9 16r3C5F 16rC1AC 16r3C60 16rC1B0 16r3C61 16rC1BD 16r3C62 16rC1C4 16r3C63 16rC1C8 16r3C64 16rC1CC 16r3C65 16rC1D4 16r3C66 16rC1D7 16r3C67 16rC1D8 16r3C68 16rC1E0 16r3C69 16rC1E4 16r3C6A 16rC1E8 16r3C6B 16rC1F0 16r3C6C 16rC1F1 16r3C6D 16rC1F3 16r3C6E 16rC1FC 16r3C6F 16rC1FD 16r3C70 16rC200 16r3C71 16rC204 16r3C72 16rC20C 16r3C73 16rC20D 16r3C74 16rC20F 16r3C75 16rC211 16r3C76 16rC218 16r3C77 16rC219 16r3C78 16rC21C 16r3C79 16rC21F 16r3C7A 16rC220 16r3C7B 16rC228 16r3C7C 16rC229 16r3C7D 16rC22B 16r3C7E 16rC22D 16r3D21 16rC22F 16r3D22 16rC231 16r3D23 16rC232 16r3D24 16rC234 16r3D25 16rC248 16r3D26 16rC250 16r3D27 16rC251 16r3D28 16rC254 16r3D29 16rC258 16r3D2A 16rC260 16r3D2B 16rC265 16r3D2C 16rC26C 16r3D2D 16rC26D 16r3D2E 16rC270 16r3D2F 16rC274 16r3D30 16rC27C 16r3D31 16rC27D 16r3D32 16rC27F 16r3D33 16rC281 16r3D34 16rC288 16r3D35 16rC289 16r3D36 16rC290 16r3D37 16rC298 16r3D38 16rC29B 16r3D39 16rC29D 16r3D3A 16rC2A4 16r3D3B 16rC2A5 16r3D3C 16rC2A8 16r3D3D 16rC2AC 16r3D3E 16rC2AD 16r3D3F 16rC2B4 16r3D40 16rC2B5 16r3D41 16rC2B7 16r3D42 16rC2B9 16r3D43 16rC2DC 16r3D44 16rC2DD 16r3D45 16rC2E0 16r3D46 16rC2E3 16r3D47 16rC2E4 16r3D48 16rC2EB 16r3D49 16rC2EC 16r3D4A 16rC2ED 16r3D4B 16rC2EF 16r3D4C 16rC2F1 16r3D4D 16rC2F6 16r3D4E 16rC2F8 16r3D4F 16rC2F9 16r3D50 16rC2FB 16r3D51 16rC2FC 16r3D52 16rC300 16r3D53 16rC308 16r3D54 16rC309 16r3D55 16rC30C 16r3D56 16rC30D 16r3D57 16rC313 16r3D58 16rC314 16r3D59 16rC315 16r3D5A 16rC318 16r3D5B 16rC31C 16r3D5C 16rC324 16r3D5D 16rC325 16r3D5E 16rC328 16r3D5F 16rC329 16r3D60 16rC345 16r3D61 16rC368 16r3D62 16rC369 16r3D63 16rC36C 16r3D64 16rC370 16r3D65 16rC372 16r3D66 16rC378 16r3D67 16rC379 16r3D68 16rC37C 16r3D69 16rC37D 16r3D6A 16rC384 16r3D6B 16rC388 16r3D6C 16rC38C 16r3D6D 16rC3C0 16r3D6E 16rC3D8 16r3D6F 16rC3D9 16r3D70 16rC3DC 16r3D71 16rC3DF 16r3D72 16rC3E0 16r3D73 16rC3E2 16r3D74 16rC3E8 16r3D75 16rC3E9 16r3D76 16rC3ED 16r3D77 16rC3F4 16r3D78 16rC3F5 16r3D79 16rC3F8 16r3D7A 16rC408 16r3D7B 16rC410 16r3D7C 16rC424 16r3D7D 16rC42C 16r3D7E 16rC430 16r3E21 16rC434 16r3E22 16rC43C 16r3E23 16rC43D 16r3E24 16rC448 16r3E25 16rC464 16r3E26 16rC465 16r3E27 16rC468 16r3E28 16rC46C 16r3E29 16rC474 16r3E2A 16rC475 16r3E2B 16rC479 16r3E2C 16rC480 16r3E2D 16rC494 16r3E2E 16rC49C 16r3E2F 16rC4B8 16r3E30 16rC4BC 16r3E31 16rC4E9 16r3E32 16rC4F0 16r3E33 16rC4F1 16r3E34 16rC4F4 16r3E35 16rC4F8 16r3E36 16rC4FA 16r3E37 16rC4FF 16r3E38 16rC500 16r3E39 16rC501 16r3E3A 16rC50C 16r3E3B 16rC510 16r3E3C 16rC514 16r3E3D 16rC51C 16r3E3E 16rC528 16r3E3F 16rC529 16r3E40 16rC52C 16r3E41 16rC530 16r3E42 16rC538 16r3E43 16rC539 16r3E44 16rC53B 16r3E45 16rC53D 16r3E46 16rC544 16r3E47 16rC545 16r3E48 16rC548 16r3E49 16rC549 16r3E4A 16rC54A 16r3E4B 16rC54C 16r3E4C 16rC54D 16r3E4D 16rC54E 16r3E4E 16rC553 16r3E4F 16rC554 16r3E50 16rC555 16r3E51 16rC557 16r3E52 16rC558 16r3E53 16rC559 16r3E54 16rC55D 16r3E55 16rC55E 16r3E56 16rC560 16r3E57 16rC561 16r3E58 16rC564 16r3E59 16rC568 16r3E5A 16rC570 16r3E5B 16rC571 16r3E5C 16rC573 16r3E5D 16rC574 16r3E5E 16rC575 16r3E5F 16rC57C 16r3E60 16rC57D 16r3E61 16rC580 16r3E62 16rC584 16r3E63 16rC587 16r3E64 16rC58C 16r3E65 16rC58D 16r3E66 16rC58F 16r3E67 16rC591 16r3E68 16rC595 16r3E69 16rC597 16r3E6A 16rC598 16r3E6B 16rC59C 16r3E6C 16rC5A0 16r3E6D 16rC5A9 16r3E6E 16rC5B4 16r3E6F 16rC5B5 16r3E70 16rC5B8 16r3E71 16rC5B9 16r3E72 16rC5BB 16r3E73 16rC5BC 16r3E74 16rC5BD 16r3E75 16rC5BE 16r3E76 16rC5C4 16r3E77 16rC5C5 16r3E78 16rC5C6 16r3E79 16rC5C7 16r3E7A 16rC5C8 16r3E7B 16rC5C9 16r3E7C 16rC5CA 16r3E7D 16rC5CC 16r3E7E 16rC5CE 16r3F21 16rC5D0 16r3F22 16rC5D1 16r3F23 16rC5D4 16r3F24 16rC5D8 16r3F25 16rC5E0 16r3F26 16rC5E1 16r3F27 16rC5E3 16r3F28 16rC5E5 16r3F29 16rC5EC 16r3F2A 16rC5ED 16r3F2B 16rC5EE 16r3F2C 16rC5F0 16r3F2D 16rC5F4 16r3F2E 16rC5F6 16r3F2F 16rC5F7 16r3F30 16rC5FC 16r3F31 16rC5FD 16r3F32 16rC5FE 16r3F33 16rC5FF 16r3F34 16rC600 16r3F35 16rC601 16r3F36 16rC605 16r3F37 16rC606 16r3F38 16rC607 16r3F39 16rC608 16r3F3A 16rC60C 16r3F3B 16rC610 16r3F3C 16rC618 16r3F3D 16rC619 16r3F3E 16rC61B 16r3F3F 16rC61C 16r3F40 16rC624 16r3F41 16rC625 16r3F42 16rC628 16r3F43 16rC62C 16r3F44 16rC62D 16r3F45 16rC62E 16r3F46 16rC630 16r3F47 16rC633 16r3F48 16rC634 16r3F49 16rC635 16r3F4A 16rC637 16r3F4B 16rC639 16r3F4C 16rC63B 16r3F4D 16rC640 16r3F4E 16rC641 16r3F4F 16rC644 16r3F50 16rC648 16r3F51 16rC650 16r3F52 16rC651 16r3F53 16rC653 16r3F54 16rC654 16r3F55 16rC655 16r3F56 16rC65C 16r3F57 16rC65D 16r3F58 16rC660 16r3F59 16rC66C 16r3F5A 16rC66F 16r3F5B 16rC671 16r3F5C 16rC678 16r3F5D 16rC679 16r3F5E 16rC67C 16r3F5F 16rC680 16r3F60 16rC688 16r3F61 16rC689 16r3F62 16rC68B 16r3F63 16rC68D 16r3F64 16rC694 16r3F65 16rC695 16r3F66 16rC698 16r3F67 16rC69C 16r3F68 16rC6A4 16r3F69 16rC6A5 16r3F6A 16rC6A7 16r3F6B 16rC6A9 16r3F6C 16rC6B0 16r3F6D 16rC6B1 16r3F6E 16rC6B4 16r3F6F 16rC6B8 16r3F70 16rC6B9 16r3F71 16rC6BA 16r3F72 16rC6C0 16r3F73 16rC6C1 16r3F74 16rC6C3 16r3F75 16rC6C5 16r3F76 16rC6CC 16r3F77 16rC6CD 16r3F78 16rC6D0 16r3F79 16rC6D4 16r3F7A 16rC6DC 16r3F7B 16rC6DD 16r3F7C 16rC6E0 16r3F7D 16rC6E1 16r3F7E 16rC6E8 16r4021 16rC6E9 16r4022 16rC6EC 16r4023 16rC6F0 16r4024 16rC6F8 16r4025 16rC6F9 16r4026 16rC6FD 16r4027 16rC704 16r4028 16rC705 16r4029 16rC708 16r402A 16rC70C 16r402B 16rC714 16r402C 16rC715 16r402D 16rC717 16r402E 16rC719 16r402F 16rC720 16r4030 16rC721 16r4031 16rC724 16r4032 16rC728 16r4033 16rC730 16r4034 16rC731 16r4035 16rC733 16r4036 16rC735 16r4037 16rC737 16r4038 16rC73C 16r4039 16rC73D 16r403A 16rC740 16r403B 16rC744 16r403C 16rC74A 16r403D 16rC74C 16r403E 16rC74D 16r403F 16rC74F 16r4040 16rC751 16r4041 16rC752 16r4042 16rC753 16r4043 16rC754 16r4044 16rC755 16r4045 16rC756 16r4046 16rC757 16r4047 16rC758 16r4048 16rC75C 16r4049 16rC760 16r404A 16rC768 16r404B 16rC76B 16r404C 16rC774 16r404D 16rC775 16r404E 16rC778 16r404F 16rC77C 16r4050 16rC77D 16r4051 16rC77E 16r4052 16rC783 16r4053 16rC784 16r4054 16rC785 16r4055 16rC787 16r4056 16rC788 16r4057 16rC789 16r4058 16rC78A 16r4059 16rC78E 16r405A 16rC790 16r405B 16rC791 16r405C 16rC794 16r405D 16rC796 16r405E 16rC797 16r405F 16rC798 16r4060 16rC79A 16r4061 16rC7A0 16r4062 16rC7A1 16r4063 16rC7A3 16r4064 16rC7A4 16r4065 16rC7A5 16r4066 16rC7A6 16r4067 16rC7AC 16r4068 16rC7AD 16r4069 16rC7B0 16r406A 16rC7B4 16r406B 16rC7BC 16r406C 16rC7BD 16r406D 16rC7BF 16r406E 16rC7C0 16r406F 16rC7C1 16r4070 16rC7C8 16r4071 16rC7C9 16r4072 16rC7CC 16r4073 16rC7CE 16r4074 16rC7D0 16r4075 16rC7D8 16r4076 16rC7DD 16r4077 16rC7E4 16r4078 16rC7E8 16r4079 16rC7EC 16r407A 16rC800 16r407B 16rC801 16r407C 16rC804 16r407D 16rC808 16r407E 16rC80A 16r4121 16rC810 16r4122 16rC811 16r4123 16rC813 16r4124 16rC815 16r4125 16rC816 16r4126 16rC81C 16r4127 16rC81D 16r4128 16rC820 16r4129 16rC824 16r412A 16rC82C 16r412B 16rC82D 16r412C 16rC82F 16r412D 16rC831 16r412E 16rC838 16r412F 16rC83C 16r4130 16rC840 16r4131 16rC848 16r4132 16rC849 16r4133 16rC84C 16r4134 16rC84D 16r4135 16rC854 16r4136 16rC870 16r4137 16rC871 16r4138 16rC874 16r4139 16rC878 16r413A 16rC87A 16r413B 16rC880 16r413C 16rC881 16r413D 16rC883 16r413E 16rC885 16r413F 16rC886 16r4140 16rC887 16r4141 16rC88B 16r4142 16rC88C 16r4143 16rC88D 16r4144 16rC894 16r4145 16rC89D 16r4146 16rC89F 16r4147 16rC8A1 16r4148 16rC8A8 16r4149 16rC8BC 16r414A 16rC8BD 16r414B 16rC8C4 16r414C 16rC8C8 16r414D 16rC8CC 16r414E 16rC8D4 16r414F 16rC8D5 16r4150 16rC8D7 16r4151 16rC8D9 16r4152 16rC8E0 16r4153 16rC8E1 16r4154 16rC8E4 16r4155 16rC8F5 16r4156 16rC8FC 16r4157 16rC8FD 16r4158 16rC900 16r4159 16rC904 16r415A 16rC905 16r415B 16rC906 16r415C 16rC90C 16r415D 16rC90D 16r415E 16rC90F 16r415F 16rC911 16r4160 16rC918 16r4161 16rC92C 16r4162 16rC934 16r4163 16rC950 16r4164 16rC951 16r4165 16rC954 16r4166 16rC958 16r4167 16rC960 16r4168 16rC961 16r4169 16rC963 16r416A 16rC96C 16r416B 16rC970 16r416C 16rC974 16r416D 16rC97C 16r416E 16rC988 16r416F 16rC989 16r4170 16rC98C 16r4171 16rC990 16r4172 16rC998 16r4173 16rC999 16r4174 16rC99B 16r4175 16rC99D 16r4176 16rC9C0 16r4177 16rC9C1 16r4178 16rC9C4 16r4179 16rC9C7 16r417A 16rC9C8 16r417B 16rC9CA 16r417C 16rC9D0 16r417D 16rC9D1 16r417E 16rC9D3 16r4221 16rC9D5 16r4222 16rC9D6 16r4223 16rC9D9 16r4224 16rC9DA 16r4225 16rC9DC 16r4226 16rC9DD 16r4227 16rC9E0 16r4228 16rC9E2 16r4229 16rC9E4 16r422A 16rC9E7 16r422B 16rC9EC 16r422C 16rC9ED 16r422D 16rC9EF 16r422E 16rC9F0 16r422F 16rC9F1 16r4230 16rC9F8 16r4231 16rC9F9 16r4232 16rC9FC 16r4233 16rCA00 16r4234 16rCA08 16r4235 16rCA09 16r4236 16rCA0B 16r4237 16rCA0C 16r4238 16rCA0D 16r4239 16rCA14 16r423A 16rCA18 16r423B 16rCA29 16r423C 16rCA4C 16r423D 16rCA4D 16r423E 16rCA50 16r423F 16rCA54 16r4240 16rCA5C 16r4241 16rCA5D 16r4242 16rCA5F 16r4243 16rCA60 16r4244 16rCA61 16r4245 16rCA68 16r4246 16rCA7D 16r4247 16rCA84 16r4248 16rCA98 16r4249 16rCABC 16r424A 16rCABD 16r424B 16rCAC0 16r424C 16rCAC4 16r424D 16rCACC 16r424E 16rCACD 16r424F 16rCACF 16r4250 16rCAD1 16r4251 16rCAD3 16r4252 16rCAD8 16r4253 16rCAD9 16r4254 16rCAE0 16r4255 16rCAEC 16r4256 16rCAF4 16r4257 16rCB08 16r4258 16rCB10 16r4259 16rCB14 16r425A 16rCB18 16r425B 16rCB20 16r425C 16rCB21 16r425D 16rCB41 16r425E 16rCB48 16r425F 16rCB49 16r4260 16rCB4C 16r4261 16rCB50 16r4262 16rCB58 16r4263 16rCB59 16r4264 16rCB5D 16r4265 16rCB64 16r4266 16rCB78 16r4267 16rCB79 16r4268 16rCB9C 16r4269 16rCBB8 16r426A 16rCBD4 16r426B 16rCBE4 16r426C 16rCBE7 16r426D 16rCBE9 16r426E 16rCC0C 16r426F 16rCC0D 16r4270 16rCC10 16r4271 16rCC14 16r4272 16rCC1C 16r4273 16rCC1D 16r4274 16rCC21 16r4275 16rCC22 16r4276 16rCC27 16r4277 16rCC28 16r4278 16rCC29 16r4279 16rCC2C 16r427A 16rCC2E 16r427B 16rCC30 16r427C 16rCC38 16r427D 16rCC39 16r427E 16rCC3B 16r4321 16rCC3C 16r4322 16rCC3D 16r4323 16rCC3E 16r4324 16rCC44 16r4325 16rCC45 16r4326 16rCC48 16r4327 16rCC4C 16r4328 16rCC54 16r4329 16rCC55 16r432A 16rCC57 16r432B 16rCC58 16r432C 16rCC59 16r432D 16rCC60 16r432E 16rCC64 16r432F 16rCC66 16r4330 16rCC68 16r4331 16rCC70 16r4332 16rCC75 16r4333 16rCC98 16r4334 16rCC99 16r4335 16rCC9C 16r4336 16rCCA0 16r4337 16rCCA8 16r4338 16rCCA9 16r4339 16rCCAB 16r433A 16rCCAC 16r433B 16rCCAD 16r433C 16rCCB4 16r433D 16rCCB5 16r433E 16rCCB8 16r433F 16rCCBC 16r4340 16rCCC4 16r4341 16rCCC5 16r4342 16rCCC7 16r4343 16rCCC9 16r4344 16rCCD0 16r4345 16rCCD4 16r4346 16rCCE4 16r4347 16rCCEC 16r4348 16rCCF0 16r4349 16rCD01 16r434A 16rCD08 16r434B 16rCD09 16r434C 16rCD0C 16r434D 16rCD10 16r434E 16rCD18 16r434F 16rCD19 16r4350 16rCD1B 16r4351 16rCD1D 16r4352 16rCD24 16r4353 16rCD28 16r4354 16rCD2C 16r4355 16rCD39 16r4356 16rCD5C 16r4357 16rCD60 16r4358 16rCD64 16r4359 16rCD6C 16r435A 16rCD6D 16r435B 16rCD6F 16r435C 16rCD71 16r435D 16rCD78 16r435E 16rCD88 16r435F 16rCD94 16r4360 16rCD95 16r4361 16rCD98 16r4362 16rCD9C 16r4363 16rCDA4 16r4364 16rCDA5 16r4365 16rCDA7 16r4366 16rCDA9 16r4367 16rCDB0 16r4368 16rCDC4 16r4369 16rCDCC 16r436A 16rCDD0 16r436B 16rCDE8 16r436C 16rCDEC 16r436D 16rCDF0 16r436E 16rCDF8 16r436F 16rCDF9 16r4370 16rCDFB 16r4371 16rCDFD 16r4372 16rCE04 16r4373 16rCE08 16r4374 16rCE0C 16r4375 16rCE14 16r4376 16rCE19 16r4377 16rCE20 16r4378 16rCE21 16r4379 16rCE24 16r437A 16rCE28 16r437B 16rCE30 16r437C 16rCE31 16r437D 16rCE33 16r437E 16rCE35 16r4421 16rCE58 16r4422 16rCE59 16r4423 16rCE5C 16r4424 16rCE5F 16r4425 16rCE60 16r4426 16rCE61 16r4427 16rCE68 16r4428 16rCE69 16r4429 16rCE6B 16r442A 16rCE6D 16r442B 16rCE74 16r442C 16rCE75 16r442D 16rCE78 16r442E 16rCE7C 16r442F 16rCE84 16r4430 16rCE85 16r4431 16rCE87 16r4432 16rCE89 16r4433 16rCE90 16r4434 16rCE91 16r4435 16rCE94 16r4436 16rCE98 16r4437 16rCEA0 16r4438 16rCEA1 16r4439 16rCEA3 16r443A 16rCEA4 16r443B 16rCEA5 16r443C 16rCEAC 16r443D 16rCEAD 16r443E 16rCEC1 16r443F 16rCEE4 16r4440 16rCEE5 16r4441 16rCEE8 16r4442 16rCEEB 16r4443 16rCEEC 16r4444 16rCEF4 16r4445 16rCEF5 16r4446 16rCEF7 16r4447 16rCEF8 16r4448 16rCEF9 16r4449 16rCF00 16r444A 16rCF01 16r444B 16rCF04 16r444C 16rCF08 16r444D 16rCF10 16r444E 16rCF11 16r444F 16rCF13 16r4450 16rCF15 16r4451 16rCF1C 16r4452 16rCF20 16r4453 16rCF24 16r4454 16rCF2C 16r4455 16rCF2D 16r4456 16rCF2F 16r4457 16rCF30 16r4458 16rCF31 16r4459 16rCF38 16r445A 16rCF54 16r445B 16rCF55 16r445C 16rCF58 16r445D 16rCF5C 16r445E 16rCF64 16r445F 16rCF65 16r4460 16rCF67 16r4461 16rCF69 16r4462 16rCF70 16r4463 16rCF71 16r4464 16rCF74 16r4465 16rCF78 16r4466 16rCF80 16r4467 16rCF85 16r4468 16rCF8C 16r4469 16rCFA1 16r446A 16rCFA8 16r446B 16rCFB0 16r446C 16rCFC4 16r446D 16rCFE0 16r446E 16rCFE1 16r446F 16rCFE4 16r4470 16rCFE8 16r4471 16rCFF0 16r4472 16rCFF1 16r4473 16rCFF3 16r4474 16rCFF5 16r4475 16rCFFC 16r4476 16rD000 16r4477 16rD004 16r4478 16rD011 16r4479 16rD018 16r447A 16rD02D 16r447B 16rD034 16r447C 16rD035 16r447D 16rD038 16r447E 16rD03C 16r4521 16rD044 16r4522 16rD045 16r4523 16rD047 16r4524 16rD049 16r4525 16rD050 16r4526 16rD054 16r4527 16rD058 16r4528 16rD060 16r4529 16rD06C 16r452A 16rD06D 16r452B 16rD070 16r452C 16rD074 16r452D 16rD07C 16r452E 16rD07D 16r452F 16rD081 16r4530 16rD0A4 16r4531 16rD0A5 16r4532 16rD0A8 16r4533 16rD0AC 16r4534 16rD0B4 16r4535 16rD0B5 16r4536 16rD0B7 16r4537 16rD0B9 16r4538 16rD0C0 16r4539 16rD0C1 16r453A 16rD0C4 16r453B 16rD0C8 16r453C 16rD0C9 16r453D 16rD0D0 16r453E 16rD0D1 16r453F 16rD0D3 16r4540 16rD0D4 16r4541 16rD0D5 16r4542 16rD0DC 16r4543 16rD0DD 16r4544 16rD0E0 16r4545 16rD0E4 16r4546 16rD0EC 16r4547 16rD0ED 16r4548 16rD0EF 16r4549 16rD0F0 16r454A 16rD0F1 16r454B 16rD0F8 16r454C 16rD10D 16r454D 16rD130 16r454E 16rD131 16r454F 16rD134 16r4550 16rD138 16r4551 16rD13A 16r4552 16rD140 16r4553 16rD141 16r4554 16rD143 16r4555 16rD144 16r4556 16rD145 16r4557 16rD14C 16r4558 16rD14D 16r4559 16rD150 16r455A 16rD154 16r455B 16rD15C 16r455C 16rD15D 16r455D 16rD15F 16r455E 16rD161 16r455F 16rD168 16r4560 16rD16C 16r4561 16rD17C 16r4562 16rD184 16r4563 16rD188 16r4564 16rD1A0 16r4565 16rD1A1 16r4566 16rD1A4 16r4567 16rD1A8 16r4568 16rD1B0 16r4569 16rD1B1 16r456A 16rD1B3 16r456B 16rD1B5 16r456C 16rD1BA 16r456D 16rD1BC 16r456E 16rD1C0 16r456F 16rD1D8 16r4570 16rD1F4 16r4571 16rD1F8 16r4572 16rD207 16r4573 16rD209 16r4574 16rD210 16r4575 16rD22C 16r4576 16rD22D 16r4577 16rD230 16r4578 16rD234 16r4579 16rD23C 16r457A 16rD23D 16r457B 16rD23F 16r457C 16rD241 16r457D 16rD248 16r457E 16rD25C 16r4621 16rD264 16r4622 16rD280 16r4623 16rD281 16r4624 16rD284 16r4625 16rD288 16r4626 16rD290 16r4627 16rD291 16r4628 16rD295 16r4629 16rD29C 16r462A 16rD2A0 16r462B 16rD2A4 16r462C 16rD2AC 16r462D 16rD2B1 16r462E 16rD2B8 16r462F 16rD2B9 16r4630 16rD2BC 16r4631 16rD2BF 16r4632 16rD2C0 16r4633 16rD2C2 16r4634 16rD2C8 16r4635 16rD2C9 16r4636 16rD2CB 16r4637 16rD2D4 16r4638 16rD2D8 16r4639 16rD2DC 16r463A 16rD2E4 16r463B 16rD2E5 16r463C 16rD2F0 16r463D 16rD2F1 16r463E 16rD2F4 16r463F 16rD2F8 16r4640 16rD300 16r4641 16rD301 16r4642 16rD303 16r4643 16rD305 16r4644 16rD30C 16r4645 16rD30D 16r4646 16rD30E 16r4647 16rD310 16r4648 16rD314 16r4649 16rD316 16r464A 16rD31C 16r464B 16rD31D 16r464C 16rD31F 16r464D 16rD320 16r464E 16rD321 16r464F 16rD325 16r4650 16rD328 16r4651 16rD329 16r4652 16rD32C 16r4653 16rD330 16r4654 16rD338 16r4655 16rD339 16r4656 16rD33B 16r4657 16rD33C 16r4658 16rD33D 16r4659 16rD344 16r465A 16rD345 16r465B 16rD37C 16r465C 16rD37D 16r465D 16rD380 16r465E 16rD384 16r465F 16rD38C 16r4660 16rD38D 16r4661 16rD38F 16r4662 16rD390 16r4663 16rD391 16r4664 16rD398 16r4665 16rD399 16r4666 16rD39C 16r4667 16rD3A0 16r4668 16rD3A8 16r4669 16rD3A9 16r466A 16rD3AB 16r466B 16rD3AD 16r466C 16rD3B4 16r466D 16rD3B8 16r466E 16rD3BC 16r466F 16rD3C4 16r4670 16rD3C5 16r4671 16rD3C8 16r4672 16rD3C9 16r4673 16rD3D0 16r4674 16rD3D8 16r4675 16rD3E1 16r4676 16rD3E3 16r4677 16rD3EC 16r4678 16rD3ED 16r4679 16rD3F0 16r467A 16rD3F4 16r467B 16rD3FC 16r467C 16rD3FD 16r467D 16rD3FF 16r467E 16rD401 16r4721 16rD408 16r4722 16rD41D 16r4723 16rD440 16r4724 16rD444 16r4725 16rD45C 16r4726 16rD460 16r4727 16rD464 16r4728 16rD46D 16r4729 16rD46F 16r472A 16rD478 16r472B 16rD479 16r472C 16rD47C 16r472D 16rD47F 16r472E 16rD480 16r472F 16rD482 16r4730 16rD488 16r4731 16rD489 16r4732 16rD48B 16r4733 16rD48D 16r4734 16rD494 16r4735 16rD4A9 16r4736 16rD4CC 16r4737 16rD4D0 16r4738 16rD4D4 16r4739 16rD4DC 16r473A 16rD4DF 16r473B 16rD4E8 16r473C 16rD4EC 16r473D 16rD4F0 16r473E 16rD4F8 16r473F 16rD4FB 16r4740 16rD4FD 16r4741 16rD504 16r4742 16rD508 16r4743 16rD50C 16r4744 16rD514 16r4745 16rD515 16r4746 16rD517 16r4747 16rD53C 16r4748 16rD53D 16r4749 16rD540 16r474A 16rD544 16r474B 16rD54C 16r474C 16rD54D 16r474D 16rD54F 16r474E 16rD551 16r474F 16rD558 16r4750 16rD559 16r4751 16rD55C 16r4752 16rD560 16r4753 16rD565 16r4754 16rD568 16r4755 16rD569 16r4756 16rD56B 16r4757 16rD56D 16r4758 16rD574 16r4759 16rD575 16r475A 16rD578 16r475B 16rD57C 16r475C 16rD584 16r475D 16rD585 16r475E 16rD587 16r475F 16rD588 16r4760 16rD589 16r4761 16rD590 16r4762 16rD5A5 16r4763 16rD5C8 16r4764 16rD5C9 16r4765 16rD5CC 16r4766 16rD5D0 16r4767 16rD5D2 16r4768 16rD5D8 16r4769 16rD5D9 16r476A 16rD5DB 16r476B 16rD5DD 16r476C 16rD5E4 16r476D 16rD5E5 16r476E 16rD5E8 16r476F 16rD5EC 16r4770 16rD5F4 16r4771 16rD5F5 16r4772 16rD5F7 16r4773 16rD5F9 16r4774 16rD600 16r4775 16rD601 16r4776 16rD604 16r4777 16rD608 16r4778 16rD610 16r4779 16rD611 16r477A 16rD613 16r477B 16rD614 16r477C 16rD615 16r477D 16rD61C 16r477E 16rD620 16r4821 16rD624 16r4822 16rD62D 16r4823 16rD638 16r4824 16rD639 16r4825 16rD63C 16r4826 16rD640 16r4827 16rD645 16r4828 16rD648 16r4829 16rD649 16r482A 16rD64B 16r482B 16rD64D 16r482C 16rD651 16r482D 16rD654 16r482E 16rD655 16r482F 16rD658 16r4830 16rD65C 16r4831 16rD667 16r4832 16rD669 16r4833 16rD670 16r4834 16rD671 16r4835 16rD674 16r4836 16rD683 16r4837 16rD685 16r4838 16rD68C 16r4839 16rD68D 16r483A 16rD690 16r483B 16rD694 16r483C 16rD69D 16r483D 16rD69F 16r483E 16rD6A1 16r483F 16rD6A8 16r4840 16rD6AC 16r4841 16rD6B0 16r4842 16rD6B9 16r4843 16rD6BB 16r4844 16rD6C4 16r4845 16rD6C5 16r4846 16rD6C8 16r4847 16rD6CC 16r4848 16rD6D1 16r4849 16rD6D4 16r484A 16rD6D7 16r484B 16rD6D9 16r484C 16rD6E0 16r484D 16rD6E4 16r484E 16rD6E8 16r484F 16rD6F0 16r4850 16rD6F5 16r4851 16rD6FC 16r4852 16rD6FD 16r4853 16rD700 16r4854 16rD704 16r4855 16rD711 16r4856 16rD718 16r4857 16rD719 16r4858 16rD71C 16r4859 16rD720 16r485A 16rD728 16r485B 16rD729 16r485C 16rD72B 16r485D 16rD72D 16r485E 16rD734 16r485F 16rD735 16r4860 16rD738 16r4861 16rD73C 16r4862 16rD744 16r4863 16rD747 16r4864 16rD749 16r4865 16rD750 16r4866 16rD751 16r4867 16rD754 16r4868 16rD756 16r4869 16rD757 16r486A 16rD758 16r486B 16rD759 16r486C 16rD760 16r486D 16rD761 16r486E 16rD763 16r486F 16rD765 16r4870 16rD769 16r4871 16rD76C 16r4872 16rD770 16r4873 16rD774 16r4874 16rD77C 16r4875 16rD77D 16r4876 16rD781 16r4877 16rD788 16r4878 16rD789 16r4879 16rD78C 16r487A 16rD790 16r487B 16rD798 16r487C 16rD799 16r487D 16rD79B 16r487E 16rD79D 16r4A21 16r4F3D 16r4A22 16r4F73 16r4A23 16r5047 16r4A24 16r50F9 16r4A25 16r52A0 16r4A26 16r53EF 16r4A27 16r5475 16r4A28 16r54E5 16r4A29 16r5609 16r4A2A 16r5AC1 16r4A2B 16r5BB6 16r4A2C 16r6687 16r4A2D 16r67B6 16r4A2E 16r67B7 16r4A2F 16r67EF 16r4A30 16r6B4C 16r4A31 16r73C2 16r4A32 16r75C2 16r4A33 16r7A3C 16r4A34 16r82DB 16r4A35 16r8304 16r4A36 16r8857 16r4A37 16r8888 16r4A38 16r8A36 16r4A39 16r8CC8 16r4A3A 16r8DCF 16r4A3B 16r8EFB 16r4A3C 16r8FE6 16r4A3D 16r99D5 16r4A3E 16r523B 16r4A3F 16r5374 16r4A40 16r5404 16r4A41 16r606A 16r4A42 16r6164 16r4A43 16r6BBC 16r4A44 16r73CF 16r4A45 16r811A 16r4A46 16r89BA 16r4A47 16r89D2 16r4A48 16r95A3 16r4A49 16r4F83 16r4A4A 16r520A 16r4A4B 16r58BE 16r4A4C 16r5978 16r4A4D 16r59E6 16r4A4E 16r5E72 16r4A4F 16r5E79 16r4A50 16r61C7 16r4A51 16r63C0 16r4A52 16r6746 16r4A53 16r67EC 16r4A54 16r687F 16r4A55 16r6F97 16r4A56 16r764E 16r4A57 16r770B 16r4A58 16r78F5 16r4A59 16r7A08 16r4A5A 16r7AFF 16r4A5B 16r7C21 16r4A5C 16r809D 16r4A5D 16r826E 16r4A5E 16r8271 16r4A5F 16r8AEB 16r4A60 16r9593 16r4A61 16r4E6B 16r4A62 16r559D 16r4A63 16r66F7 16r4A64 16r6E34 16r4A65 16r78A3 16r4A66 16r7AED 16r4A67 16r845B 16r4A68 16r8910 16r4A69 16r874E 16r4A6A 16r97A8 16r4A6B 16r52D8 16r4A6C 16r574E 16r4A6D 16r582A 16r4A6E 16r5D4C 16r4A6F 16r611F 16r4A70 16r61BE 16r4A71 16r6221 16r4A72 16r6562 16r4A73 16r67D1 16r4A74 16r6A44 16r4A75 16r6E1B 16r4A76 16r7518 16r4A77 16r75B3 16r4A78 16r76E3 16r4A79 16r77B0 16r4A7A 16r7D3A 16r4A7B 16r90AF 16r4A7C 16r9451 16r4A7D 16r9452 16r4A7E 16r9F95 16r4B21 16r5323 16r4B22 16r5CAC 16r4B23 16r7532 16r4B24 16r80DB 16r4B25 16r9240 16r4B26 16r9598 16r4B27 16r525B 16r4B28 16r5808 16r4B29 16r59DC 16r4B2A 16r5CA1 16r4B2B 16r5D17 16r4B2C 16r5EB7 16r4B2D 16r5F3A 16r4B2E 16r5F4A 16r4B2F 16r6177 16r4B30 16r6C5F 16r4B31 16r757A 16r4B32 16r7586 16r4B33 16r7CE0 16r4B34 16r7D73 16r4B35 16r7DB1 16r4B36 16r7F8C 16r4B37 16r8154 16r4B38 16r8221 16r4B39 16r8591 16r4B3A 16r8941 16r4B3B 16r8B1B 16r4B3C 16r92FC 16r4B3D 16r964D 16r4B3E 16r9C47 16r4B3F 16r4ECB 16r4B40 16r4EF7 16r4B41 16r500B 16r4B42 16r51F1 16r4B43 16r584F 16r4B44 16r6137 16r4B45 16r613E 16r4B46 16r6168 16r4B47 16r6539 16r4B48 16r69EA 16r4B49 16r6F11 16r4B4A 16r75A5 16r4B4B 16r7686 16r4B4C 16r76D6 16r4B4D 16r7B87 16r4B4E 16r82A5 16r4B4F 16r84CB 16r4B50 16rF900 16r4B51 16r93A7 16r4B52 16r958B 16r4B53 16r5580 16r4B54 16r5BA2 16r4B55 16r5751 16r4B56 16rF901 16r4B57 16r7CB3 16r4B58 16r7FB9 16r4B59 16r91B5 16r4B5A 16r5028 16r4B5B 16r53BB 16r4B5C 16r5C45 16r4B5D 16r5DE8 16r4B5E 16r62D2 16r4B5F 16r636E 16r4B60 16r64DA 16r4B61 16r64E7 16r4B62 16r6E20 16r4B63 16r70AC 16r4B64 16r795B 16r4B65 16r8DDD 16r4B66 16r8E1E 16r4B67 16rF902 16r4B68 16r907D 16r4B69 16r9245 16r4B6A 16r92F8 16r4B6B 16r4E7E 16r4B6C 16r4EF6 16r4B6D 16r5065 16r4B6E 16r5DFE 16r4B6F 16r5EFA 16r4B70 16r6106 16r4B71 16r6957 16r4B72 16r8171 16r4B73 16r8654 16r4B74 16r8E47 16r4B75 16r9375 16r4B76 16r9A2B 16r4B77 16r4E5E 16r4B78 16r5091 16r4B79 16r6770 16r4B7A 16r6840 16r4B7B 16r5109 16r4B7C 16r528D 16r4B7D 16r5292 16r4B7E 16r6AA2 16r4C21 16r77BC 16r4C22 16r9210 16r4C23 16r9ED4 16r4C24 16r52AB 16r4C25 16r602F 16r4C26 16r8FF2 16r4C27 16r5048 16r4C28 16r61A9 16r4C29 16r63ED 16r4C2A 16r64CA 16r4C2B 16r683C 16r4C2C 16r6A84 16r4C2D 16r6FC0 16r4C2E 16r8188 16r4C2F 16r89A1 16r4C30 16r9694 16r4C31 16r5805 16r4C32 16r727D 16r4C33 16r72AC 16r4C34 16r7504 16r4C35 16r7D79 16r4C36 16r7E6D 16r4C37 16r80A9 16r4C38 16r898B 16r4C39 16r8B74 16r4C3A 16r9063 16r4C3B 16r9D51 16r4C3C 16r6289 16r4C3D 16r6C7A 16r4C3E 16r6F54 16r4C3F 16r7D50 16r4C40 16r7F3A 16r4C41 16r8A23 16r4C42 16r517C 16r4C43 16r614A 16r4C44 16r7B9D 16r4C45 16r8B19 16r4C46 16r9257 16r4C47 16r938C 16r4C48 16r4EAC 16r4C49 16r4FD3 16r4C4A 16r501E 16r4C4B 16r50BE 16r4C4C 16r5106 16r4C4D 16r52C1 16r4C4E 16r52CD 16r4C4F 16r537F 16r4C50 16r5770 16r4C51 16r5883 16r4C52 16r5E9A 16r4C53 16r5F91 16r4C54 16r6176 16r4C55 16r61AC 16r4C56 16r64CE 16r4C57 16r656C 16r4C58 16r666F 16r4C59 16r66BB 16r4C5A 16r66F4 16r4C5B 16r6897 16r4C5C 16r6D87 16r4C5D 16r7085 16r4C5E 16r70F1 16r4C5F 16r749F 16r4C60 16r74A5 16r4C61 16r74CA 16r4C62 16r75D9 16r4C63 16r786C 16r4C64 16r78EC 16r4C65 16r7ADF 16r4C66 16r7AF6 16r4C67 16r7D45 16r4C68 16r7D93 16r4C69 16r8015 16r4C6A 16r803F 16r4C6B 16r811B 16r4C6C 16r8396 16r4C6D 16r8B66 16r4C6E 16r8F15 16r4C6F 16r9015 16r4C70 16r93E1 16r4C71 16r9803 16r4C72 16r9838 16r4C73 16r9A5A 16r4C74 16r9BE8 16r4C75 16r4FC2 16r4C76 16r5553 16r4C77 16r583A 16r4C78 16r5951 16r4C79 16r5B63 16r4C7A 16r5C46 16r4C7B 16r60B8 16r4C7C 16r6212 16r4C7D 16r6842 16r4C7E 16r68B0 16r4D21 16r68E8 16r4D22 16r6EAA 16r4D23 16r754C 16r4D24 16r7678 16r4D25 16r78CE 16r4D26 16r7A3D 16r4D27 16r7CFB 16r4D28 16r7E6B 16r4D29 16r7E7C 16r4D2A 16r8A08 16r4D2B 16r8AA1 16r4D2C 16r8C3F 16r4D2D 16r968E 16r4D2E 16r9DC4 16r4D2F 16r53E4 16r4D30 16r53E9 16r4D31 16r544A 16r4D32 16r5471 16r4D33 16r56FA 16r4D34 16r59D1 16r4D35 16r5B64 16r4D36 16r5C3B 16r4D37 16r5EAB 16r4D38 16r62F7 16r4D39 16r6537 16r4D3A 16r6545 16r4D3B 16r6572 16r4D3C 16r66A0 16r4D3D 16r67AF 16r4D3E 16r69C1 16r4D3F 16r6CBD 16r4D40 16r75FC 16r4D41 16r7690 16r4D42 16r777E 16r4D43 16r7A3F 16r4D44 16r7F94 16r4D45 16r8003 16r4D46 16r80A1 16r4D47 16r818F 16r4D48 16r82E6 16r4D49 16r82FD 16r4D4A 16r83F0 16r4D4B 16r85C1 16r4D4C 16r8831 16r4D4D 16r88B4 16r4D4E 16r8AA5 16r4D4F 16rF903 16r4D50 16r8F9C 16r4D51 16r932E 16r4D52 16r96C7 16r4D53 16r9867 16r4D54 16r9AD8 16r4D55 16r9F13 16r4D56 16r54ED 16r4D57 16r659B 16r4D58 16r66F2 16r4D59 16r688F 16r4D5A 16r7A40 16r4D5B 16r8C37 16r4D5C 16r9D60 16r4D5D 16r56F0 16r4D5E 16r5764 16r4D5F 16r5D11 16r4D60 16r6606 16r4D61 16r68B1 16r4D62 16r68CD 16r4D63 16r6EFE 16r4D64 16r7428 16r4D65 16r889E 16r4D66 16r9BE4 16r4D67 16r6C68 16r4D68 16rF904 16r4D69 16r9AA8 16r4D6A 16r4F9B 16r4D6B 16r516C 16r4D6C 16r5171 16r4D6D 16r529F 16r4D6E 16r5B54 16r4D6F 16r5DE5 16r4D70 16r6050 16r4D71 16r606D 16r4D72 16r62F1 16r4D73 16r63A7 16r4D74 16r653B 16r4D75 16r73D9 16r4D76 16r7A7A 16r4D77 16r86A3 16r4D78 16r8CA2 16r4D79 16r978F 16r4D7A 16r4E32 16r4D7B 16r5BE1 16r4D7C 16r6208 16r4D7D 16r679C 16r4D7E 16r74DC 16r4E21 16r79D1 16r4E22 16r83D3 16r4E23 16r8A87 16r4E24 16r8AB2 16r4E25 16r8DE8 16r4E26 16r904E 16r4E27 16r934B 16r4E28 16r9846 16r4E29 16r5ED3 16r4E2A 16r69E8 16r4E2B 16r85FF 16r4E2C 16r90ED 16r4E2D 16rF905 16r4E2E 16r51A0 16r4E2F 16r5B98 16r4E30 16r5BEC 16r4E31 16r6163 16r4E32 16r68FA 16r4E33 16r6B3E 16r4E34 16r704C 16r4E35 16r742F 16r4E36 16r74D8 16r4E37 16r7BA1 16r4E38 16r7F50 16r4E39 16r83C5 16r4E3A 16r89C0 16r4E3B 16r8CAB 16r4E3C 16r95DC 16r4E3D 16r9928 16r4E3E 16r522E 16r4E3F 16r605D 16r4E40 16r62EC 16r4E41 16r9002 16r4E42 16r4F8A 16r4E43 16r5149 16r4E44 16r5321 16r4E45 16r58D9 16r4E46 16r5EE3 16r4E47 16r66E0 16r4E48 16r6D38 16r4E49 16r709A 16r4E4A 16r72C2 16r4E4B 16r73D6 16r4E4C 16r7B50 16r4E4D 16r80F1 16r4E4E 16r945B 16r4E4F 16r5366 16r4E50 16r639B 16r4E51 16r7F6B 16r4E52 16r4E56 16r4E53 16r5080 16r4E54 16r584A 16r4E55 16r58DE 16r4E56 16r602A 16r4E57 16r6127 16r4E58 16r62D0 16r4E59 16r69D0 16r4E5A 16r9B41 16r4E5B 16r5B8F 16r4E5C 16r7D18 16r4E5D 16r80B1 16r4E5E 16r8F5F 16r4E5F 16r4EA4 16r4E60 16r50D1 16r4E61 16r54AC 16r4E62 16r55AC 16r4E63 16r5B0C 16r4E64 16r5DA0 16r4E65 16r5DE7 16r4E66 16r652A 16r4E67 16r654E 16r4E68 16r6821 16r4E69 16r6A4B 16r4E6A 16r72E1 16r4E6B 16r768E 16r4E6C 16r77EF 16r4E6D 16r7D5E 16r4E6E 16r7FF9 16r4E6F 16r81A0 16r4E70 16r854E 16r4E71 16r86DF 16r4E72 16r8F03 16r4E73 16r8F4E 16r4E74 16r90CA 16r4E75 16r9903 16r4E76 16r9A55 16r4E77 16r9BAB 16r4E78 16r4E18 16r4E79 16r4E45 16r4E7A 16r4E5D 16r4E7B 16r4EC7 16r4E7C 16r4FF1 16r4E7D 16r5177 16r4E7E 16r52FE 16r4F21 16r5340 16r4F22 16r53E3 16r4F23 16r53E5 16r4F24 16r548E 16r4F25 16r5614 16r4F26 16r5775 16r4F27 16r57A2 16r4F28 16r5BC7 16r4F29 16r5D87 16r4F2A 16r5ED0 16r4F2B 16r61FC 16r4F2C 16r62D8 16r4F2D 16r6551 16r4F2E 16r67B8 16r4F2F 16r67E9 16r4F30 16r69CB 16r4F31 16r6B50 16r4F32 16r6BC6 16r4F33 16r6BEC 16r4F34 16r6C42 16r4F35 16r6E9D 16r4F36 16r7078 16r4F37 16r72D7 16r4F38 16r7396 16r4F39 16r7403 16r4F3A 16r77BF 16r4F3B 16r77E9 16r4F3C 16r7A76 16r4F3D 16r7D7F 16r4F3E 16r8009 16r4F3F 16r81FC 16r4F40 16r8205 16r4F41 16r820A 16r4F42 16r82DF 16r4F43 16r8862 16r4F44 16r8B33 16r4F45 16r8CFC 16r4F46 16r8EC0 16r4F47 16r9011 16r4F48 16r90B1 16r4F49 16r9264 16r4F4A 16r92B6 16r4F4B 16r99D2 16r4F4C 16r9A45 16r4F4D 16r9CE9 16r4F4E 16r9DD7 16r4F4F 16r9F9C 16r4F50 16r570B 16r4F51 16r5C40 16r4F52 16r83CA 16r4F53 16r97A0 16r4F54 16r97AB 16r4F55 16r9EB4 16r4F56 16r541B 16r4F57 16r7A98 16r4F58 16r7FA4 16r4F59 16r88D9 16r4F5A 16r8ECD 16r4F5B 16r90E1 16r4F5C 16r5800 16r4F5D 16r5C48 16r4F5E 16r6398 16r4F5F 16r7A9F 16r4F60 16r5BAE 16r4F61 16r5F13 16r4F62 16r7A79 16r4F63 16r7AAE 16r4F64 16r828E 16r4F65 16r8EAC 16r4F66 16r5026 16r4F67 16r5238 16r4F68 16r52F8 16r4F69 16r5377 16r4F6A 16r5708 16r4F6B 16r62F3 16r4F6C 16r6372 16r4F6D 16r6B0A 16r4F6E 16r6DC3 16r4F6F 16r7737 16r4F70 16r53A5 16r4F71 16r7357 16r4F72 16r8568 16r4F73 16r8E76 16r4F74 16r95D5 16r4F75 16r673A 16r4F76 16r6AC3 16r4F77 16r6F70 16r4F78 16r8A6D 16r4F79 16r8ECC 16r4F7A 16r994B 16r4F7B 16rF906 16r4F7C 16r6677 16r4F7D 16r6B78 16r4F7E 16r8CB4 16r5021 16r9B3C 16r5022 16rF907 16r5023 16r53EB 16r5024 16r572D 16r5025 16r594E 16r5026 16r63C6 16r5027 16r69FB 16r5028 16r73EA 16r5029 16r7845 16r502A 16r7ABA 16r502B 16r7AC5 16r502C 16r7CFE 16r502D 16r8475 16r502E 16r898F 16r502F 16r8D73 16r5030 16r9035 16r5031 16r95A8 16r5032 16r52FB 16r5033 16r5747 16r5034 16r7547 16r5035 16r7B60 16r5036 16r83CC 16r5037 16r921E 16r5038 16rF908 16r5039 16r6A58 16r503A 16r514B 16r503B 16r524B 16r503C 16r5287 16r503D 16r621F 16r503E 16r68D8 16r503F 16r6975 16r5040 16r9699 16r5041 16r50C5 16r5042 16r52A4 16r5043 16r52E4 16r5044 16r61C3 16r5045 16r65A4 16r5046 16r6839 16r5047 16r69FF 16r5048 16r747E 16r5049 16r7B4B 16r504A 16r82B9 16r504B 16r83EB 16r504C 16r89B2 16r504D 16r8B39 16r504E 16r8FD1 16r504F 16r9949 16r5050 16rF909 16r5051 16r4ECA 16r5052 16r5997 16r5053 16r64D2 16r5054 16r6611 16r5055 16r6A8E 16r5056 16r7434 16r5057 16r7981 16r5058 16r79BD 16r5059 16r82A9 16r505A 16r887E 16r505B 16r887F 16r505C 16r895F 16r505D 16rF90A 16r505E 16r9326 16r505F 16r4F0B 16r5060 16r53CA 16r5061 16r6025 16r5062 16r6271 16r5063 16r6C72 16r5064 16r7D1A 16r5065 16r7D66 16r5066 16r4E98 16r5067 16r5162 16r5068 16r77DC 16r5069 16r80AF 16r506A 16r4F01 16r506B 16r4F0E 16r506C 16r5176 16r506D 16r5180 16r506E 16r55DC 16r506F 16r5668 16r5070 16r573B 16r5071 16r57FA 16r5072 16r57FC 16r5073 16r5914 16r5074 16r5947 16r5075 16r5993 16r5076 16r5BC4 16r5077 16r5C90 16r5078 16r5D0E 16r5079 16r5DF1 16r507A 16r5E7E 16r507B 16r5FCC 16r507C 16r6280 16r507D 16r65D7 16r507E 16r65E3 16r5121 16r671E 16r5122 16r671F 16r5123 16r675E 16r5124 16r68CB 16r5125 16r68C4 16r5126 16r6A5F 16r5127 16r6B3A 16r5128 16r6C23 16r5129 16r6C7D 16r512A 16r6C82 16r512B 16r6DC7 16r512C 16r7398 16r512D 16r7426 16r512E 16r742A 16r512F 16r7482 16r5130 16r74A3 16r5131 16r7578 16r5132 16r757F 16r5133 16r7881 16r5134 16r78EF 16r5135 16r7941 16r5136 16r7947 16r5137 16r7948 16r5138 16r797A 16r5139 16r7B95 16r513A 16r7D00 16r513B 16r7DBA 16r513C 16r7F88 16r513D 16r8006 16r513E 16r802D 16r513F 16r808C 16r5140 16r8A18 16r5141 16r8B4F 16r5142 16r8C48 16r5143 16r8D77 16r5144 16r9321 16r5145 16r9324 16r5146 16r98E2 16r5147 16r9951 16r5148 16r9A0E 16r5149 16r9A0F 16r514A 16r9A65 16r514B 16r9E92 16r514C 16r7DCA 16r514D 16r4F76 16r514E 16r5409 16r514F 16r62EE 16r5150 16r6854 16r5151 16r91D1 16r5152 16r55AB 16r5153 16r513A 16r5154 16rF90B 16r5155 16rF90C 16r5156 16r5A1C 16r5157 16r61E6 16r5158 16rF90D 16r5159 16r62CF 16r515A 16r62FF 16r515B 16rF90E 16r515C 16rF90F 16r515D 16rF910 16r515E 16rF911 16r515F 16rF912 16r5160 16rF913 16r5161 16r90A3 16r5162 16rF914 16r5163 16rF915 16r5164 16rF916 16r5165 16rF917 16r5166 16rF918 16r5167 16r8AFE 16r5168 16rF919 16r5169 16rF91A 16r516A 16rF91B 16r516B 16rF91C 16r516C 16r6696 16r516D 16rF91D 16r516E 16r7156 16r516F 16rF91E 16r5170 16rF91F 16r5171 16r96E3 16r5172 16rF920 16r5173 16r634F 16r5174 16r637A 16r5175 16r5357 16r5176 16rF921 16r5177 16r678F 16r5178 16r6960 16r5179 16r6E73 16r517A 16rF922 16r517B 16r7537 16r517C 16rF923 16r517D 16rF924 16r517E 16rF925 16r5221 16r7D0D 16r5222 16rF926 16r5223 16rF927 16r5224 16r8872 16r5225 16r56CA 16r5226 16r5A18 16r5227 16rF928 16r5228 16rF929 16r5229 16rF92A 16r522A 16rF92B 16r522B 16rF92C 16r522C 16r4E43 16r522D 16rF92D 16r522E 16r5167 16r522F 16r5948 16r5230 16r67F0 16r5231 16r8010 16r5232 16rF92E 16r5233 16r5973 16r5234 16r5E74 16r5235 16r649A 16r5236 16r79CA 16r5237 16r5FF5 16r5238 16r606C 16r5239 16r62C8 16r523A 16r637B 16r523B 16r5BE7 16r523C 16r5BD7 16r523D 16r52AA 16r523E 16rF92F 16r523F 16r5974 16r5240 16r5F29 16r5241 16r6012 16r5242 16rF930 16r5243 16rF931 16r5244 16rF932 16r5245 16r7459 16r5246 16rF933 16r5247 16rF934 16r5248 16rF935 16r5249 16rF936 16r524A 16rF937 16r524B 16rF938 16r524C 16r99D1 16r524D 16rF939 16r524E 16rF93A 16r524F 16rF93B 16r5250 16rF93C 16r5251 16rF93D 16r5252 16rF93E 16r5253 16rF93F 16r5254 16rF940 16r5255 16rF941 16r5256 16rF942 16r5257 16rF943 16r5258 16r6FC3 16r5259 16rF944 16r525A 16rF945 16r525B 16r81BF 16r525C 16r8FB2 16r525D 16r60F1 16r525E 16rF946 16r525F 16rF947 16r5260 16r8166 16r5261 16rF948 16r5262 16rF949 16r5263 16r5C3F 16r5264 16rF94A 16r5265 16rF94B 16r5266 16rF94C 16r5267 16rF94D 16r5268 16rF94E 16r5269 16rF94F 16r526A 16rF950 16r526B 16rF951 16r526C 16r5AE9 16r526D 16r8A25 16r526E 16r677B 16r526F 16r7D10 16r5270 16rF952 16r5271 16rF953 16r5272 16rF954 16r5273 16rF955 16r5274 16rF956 16r5275 16rF957 16r5276 16r80FD 16r5277 16rF958 16r5278 16rF959 16r5279 16r5C3C 16r527A 16r6CE5 16r527B 16r533F 16r527C 16r6EBA 16r527D 16r591A 16r527E 16r8336 16r5321 16r4E39 16r5322 16r4EB6 16r5323 16r4F46 16r5324 16r55AE 16r5325 16r5718 16r5326 16r58C7 16r5327 16r5F56 16r5328 16r65B7 16r5329 16r65E6 16r532A 16r6A80 16r532B 16r6BB5 16r532C 16r6E4D 16r532D 16r77ED 16r532E 16r7AEF 16r532F 16r7C1E 16r5330 16r7DDE 16r5331 16r86CB 16r5332 16r8892 16r5333 16r9132 16r5334 16r935B 16r5335 16r64BB 16r5336 16r6FBE 16r5337 16r737A 16r5338 16r75B8 16r5339 16r9054 16r533A 16r5556 16r533B 16r574D 16r533C 16r61BA 16r533D 16r64D4 16r533E 16r66C7 16r533F 16r6DE1 16r5340 16r6E5B 16r5341 16r6F6D 16r5342 16r6FB9 16r5343 16r75F0 16r5344 16r8043 16r5345 16r81BD 16r5346 16r8541 16r5347 16r8983 16r5348 16r8AC7 16r5349 16r8B5A 16r534A 16r931F 16r534B 16r6C93 16r534C 16r7553 16r534D 16r7B54 16r534E 16r8E0F 16r534F 16r905D 16r5350 16r5510 16r5351 16r5802 16r5352 16r5858 16r5353 16r5E62 16r5354 16r6207 16r5355 16r649E 16r5356 16r68E0 16r5357 16r7576 16r5358 16r7CD6 16r5359 16r87B3 16r535A 16r9EE8 16r535B 16r4EE3 16r535C 16r5788 16r535D 16r576E 16r535E 16r5927 16r535F 16r5C0D 16r5360 16r5CB1 16r5361 16r5E36 16r5362 16r5F85 16r5363 16r6234 16r5364 16r64E1 16r5365 16r73B3 16r5366 16r81FA 16r5367 16r888B 16r5368 16r8CB8 16r5369 16r968A 16r536A 16r9EDB 16r536B 16r5B85 16r536C 16r5FB7 16r536D 16r60B3 16r536E 16r5012 16r536F 16r5200 16r5370 16r5230 16r5371 16r5716 16r5372 16r5835 16r5373 16r5857 16r5374 16r5C0E 16r5375 16r5C60 16r5376 16r5CF6 16r5377 16r5D8B 16r5378 16r5EA6 16r5379 16r5F92 16r537A 16r60BC 16r537B 16r6311 16r537C 16r6389 16r537D 16r6417 16r537E 16r6843 16r5421 16r68F9 16r5422 16r6AC2 16r5423 16r6DD8 16r5424 16r6E21 16r5425 16r6ED4 16r5426 16r6FE4 16r5427 16r71FE 16r5428 16r76DC 16r5429 16r7779 16r542A 16r79B1 16r542B 16r7A3B 16r542C 16r8404 16r542D 16r89A9 16r542E 16r8CED 16r542F 16r8DF3 16r5430 16r8E48 16r5431 16r9003 16r5432 16r9014 16r5433 16r9053 16r5434 16r90FD 16r5435 16r934D 16r5436 16r9676 16r5437 16r97DC 16r5438 16r6BD2 16r5439 16r7006 16r543A 16r7258 16r543B 16r72A2 16r543C 16r7368 16r543D 16r7763 16r543E 16r79BF 16r543F 16r7BE4 16r5440 16r7E9B 16r5441 16r8B80 16r5442 16r58A9 16r5443 16r60C7 16r5444 16r6566 16r5445 16r65FD 16r5446 16r66BE 16r5447 16r6C8C 16r5448 16r711E 16r5449 16r71C9 16r544A 16r8C5A 16r544B 16r9813 16r544C 16r4E6D 16r544D 16r7A81 16r544E 16r4EDD 16r544F 16r51AC 16r5450 16r51CD 16r5451 16r52D5 16r5452 16r540C 16r5453 16r61A7 16r5454 16r6771 16r5455 16r6850 16r5456 16r68DF 16r5457 16r6D1E 16r5458 16r6F7C 16r5459 16r75BC 16r545A 16r77B3 16r545B 16r7AE5 16r545C 16r80F4 16r545D 16r8463 16r545E 16r9285 16r545F 16r515C 16r5460 16r6597 16r5461 16r675C 16r5462 16r6793 16r5463 16r75D8 16r5464 16r7AC7 16r5465 16r8373 16r5466 16rF95A 16r5467 16r8C46 16r5468 16r9017 16r5469 16r982D 16r546A 16r5C6F 16r546B 16r81C0 16r546C 16r829A 16r546D 16r9041 16r546E 16r906F 16r546F 16r920D 16r5470 16r5F97 16r5471 16r5D9D 16r5472 16r6A59 16r5473 16r71C8 16r5474 16r767B 16r5475 16r7B49 16r5476 16r85E4 16r5477 16r8B04 16r5478 16r9127 16r5479 16r9A30 16r547A 16r5587 16r547B 16r61F6 16r547C 16rF95B 16r547D 16r7669 16r547E 16r7F85 16r5521 16r863F 16r5522 16r87BA 16r5523 16r88F8 16r5524 16r908F 16r5525 16rF95C 16r5526 16r6D1B 16r5527 16r70D9 16r5528 16r73DE 16r5529 16r7D61 16r552A 16r843D 16r552B 16rF95D 16r552C 16r916A 16r552D 16r99F1 16r552E 16rF95E 16r552F 16r4E82 16r5530 16r5375 16r5531 16r6B04 16r5532 16r6B12 16r5533 16r703E 16r5534 16r721B 16r5535 16r862D 16r5536 16r9E1E 16r5537 16r524C 16r5538 16r8FA3 16r5539 16r5D50 16r553A 16r64E5 16r553B 16r652C 16r553C 16r6B16 16r553D 16r6FEB 16r553E 16r7C43 16r553F 16r7E9C 16r5540 16r85CD 16r5541 16r8964 16r5542 16r89BD 16r5543 16r62C9 16r5544 16r81D8 16r5545 16r881F 16r5546 16r5ECA 16r5547 16r6717 16r5548 16r6D6A 16r5549 16r72FC 16r554A 16r7405 16r554B 16r746F 16r554C 16r8782 16r554D 16r90DE 16r554E 16r4F86 16r554F 16r5D0D 16r5550 16r5FA0 16r5551 16r840A 16r5552 16r51B7 16r5553 16r63A0 16r5554 16r7565 16r5555 16r4EAE 16r5556 16r5006 16r5557 16r5169 16r5558 16r51C9 16r5559 16r6881 16r555A 16r6A11 16r555B 16r7CAE 16r555C 16r7CB1 16r555D 16r7CE7 16r555E 16r826F 16r555F 16r8AD2 16r5560 16r8F1B 16r5561 16r91CF 16r5562 16r4FB6 16r5563 16r5137 16r5564 16r52F5 16r5565 16r5442 16r5566 16r5EEC 16r5567 16r616E 16r5568 16r623E 16r5569 16r65C5 16r556A 16r6ADA 16r556B 16r6FFE 16r556C 16r792A 16r556D 16r85DC 16r556E 16r8823 16r556F 16r95AD 16r5570 16r9A62 16r5571 16r9A6A 16r5572 16r9E97 16r5573 16r9ECE 16r5574 16r529B 16r5575 16r66C6 16r5576 16r6B77 16r5577 16r701D 16r5578 16r792B 16r5579 16r8F62 16r557A 16r9742 16r557B 16r6190 16r557C 16r6200 16r557D 16r6523 16r557E 16r6F23 16r5621 16r7149 16r5622 16r7489 16r5623 16r7DF4 16r5624 16r806F 16r5625 16r84EE 16r5626 16r8F26 16r5627 16r9023 16r5628 16r934A 16r5629 16r51BD 16r562A 16r5217 16r562B 16r52A3 16r562C 16r6D0C 16r562D 16r70C8 16r562E 16r88C2 16r562F 16r5EC9 16r5630 16r6582 16r5631 16r6BAE 16r5632 16r6FC2 16r5633 16r7C3E 16r5634 16r7375 16r5635 16r4EE4 16r5636 16r4F36 16r5637 16r56F9 16r5638 16rF95F 16r5639 16r5CBA 16r563A 16r5DBA 16r563B 16r601C 16r563C 16r73B2 16r563D 16r7B2D 16r563E 16r7F9A 16r563F 16r7FCE 16r5640 16r8046 16r5641 16r901E 16r5642 16r9234 16r5643 16r96F6 16r5644 16r9748 16r5645 16r9818 16r5646 16r9F61 16r5647 16r4F8B 16r5648 16r6FA7 16r5649 16r79AE 16r564A 16r91B4 16r564B 16r96B7 16r564C 16r52DE 16r564D 16rF960 16r564E 16r6488 16r564F 16r64C4 16r5650 16r6AD3 16r5651 16r6F5E 16r5652 16r7018 16r5653 16r7210 16r5654 16r76E7 16r5655 16r8001 16r5656 16r8606 16r5657 16r865C 16r5658 16r8DEF 16r5659 16r8F05 16r565A 16r9732 16r565B 16r9B6F 16r565C 16r9DFA 16r565D 16r9E75 16r565E 16r788C 16r565F 16r797F 16r5660 16r7DA0 16r5661 16r83C9 16r5662 16r9304 16r5663 16r9E7F 16r5664 16r9E93 16r5665 16r8AD6 16r5666 16r58DF 16r5667 16r5F04 16r5668 16r6727 16r5669 16r7027 16r566A 16r74CF 16r566B 16r7C60 16r566C 16r807E 16r566D 16r5121 16r566E 16r7028 16r566F 16r7262 16r5670 16r78CA 16r5671 16r8CC2 16r5672 16r8CDA 16r5673 16r8CF4 16r5674 16r96F7 16r5675 16r4E86 16r5676 16r50DA 16r5677 16r5BEE 16r5678 16r5ED6 16r5679 16r6599 16r567A 16r71CE 16r567B 16r7642 16r567C 16r77AD 16r567D 16r804A 16r567E 16r84FC 16r5721 16r907C 16r5722 16r9B27 16r5723 16r9F8D 16r5724 16r58D8 16r5725 16r5A41 16r5726 16r5C62 16r5727 16r6A13 16r5728 16r6DDA 16r5729 16r6F0F 16r572A 16r763B 16r572B 16r7D2F 16r572C 16r7E37 16r572D 16r851E 16r572E 16r8938 16r572F 16r93E4 16r5730 16r964B 16r5731 16r5289 16r5732 16r65D2 16r5733 16r67F3 16r5734 16r69B4 16r5735 16r6D41 16r5736 16r6E9C 16r5737 16r700F 16r5738 16r7409 16r5739 16r7460 16r573A 16r7559 16r573B 16r7624 16r573C 16r786B 16r573D 16r8B2C 16r573E 16r985E 16r573F 16r516D 16r5740 16r622E 16r5741 16r9678 16r5742 16r4F96 16r5743 16r502B 16r5744 16r5D19 16r5745 16r6DEA 16r5746 16r7DB8 16r5747 16r8F2A 16r5748 16r5F8B 16r5749 16r6144 16r574A 16r6817 16r574B 16rF961 16r574C 16r9686 16r574D 16r52D2 16r574E 16r808B 16r574F 16r51DC 16r5750 16r51CC 16r5751 16r695E 16r5752 16r7A1C 16r5753 16r7DBE 16r5754 16r83F1 16r5755 16r9675 16r5756 16r4FDA 16r5757 16r5229 16r5758 16r5398 16r5759 16r540F 16r575A 16r550E 16r575B 16r5C65 16r575C 16r60A7 16r575D 16r674E 16r575E 16r68A8 16r575F 16r6D6C 16r5760 16r7281 16r5761 16r72F8 16r5762 16r7406 16r5763 16r7483 16r5764 16rF962 16r5765 16r75E2 16r5766 16r7C6C 16r5767 16r7F79 16r5768 16r7FB8 16r5769 16r8389 16r576A 16r88CF 16r576B 16r88E1 16r576C 16r91CC 16r576D 16r91D0 16r576E 16r96E2 16r576F 16r9BC9 16r5770 16r541D 16r5771 16r6F7E 16r5772 16r71D0 16r5773 16r7498 16r5774 16r85FA 16r5775 16r8EAA 16r5776 16r96A3 16r5777 16r9C57 16r5778 16r9E9F 16r5779 16r6797 16r577A 16r6DCB 16r577B 16r7433 16r577C 16r81E8 16r577D 16r9716 16r577E 16r782C 16r5821 16r7ACB 16r5822 16r7B20 16r5823 16r7C92 16r5824 16r6469 16r5825 16r746A 16r5826 16r75F2 16r5827 16r78BC 16r5828 16r78E8 16r5829 16r99AC 16r582A 16r9B54 16r582B 16r9EBB 16r582C 16r5BDE 16r582D 16r5E55 16r582E 16r6F20 16r582F 16r819C 16r5830 16r83AB 16r5831 16r9088 16r5832 16r4E07 16r5833 16r534D 16r5834 16r5A29 16r5835 16r5DD2 16r5836 16r5F4E 16r5837 16r6162 16r5838 16r633D 16r5839 16r6669 16r583A 16r66FC 16r583B 16r6EFF 16r583C 16r6F2B 16r583D 16r7063 16r583E 16r779E 16r583F 16r842C 16r5840 16r8513 16r5841 16r883B 16r5842 16r8F13 16r5843 16r9945 16r5844 16r9C3B 16r5845 16r551C 16r5846 16r62B9 16r5847 16r672B 16r5848 16r6CAB 16r5849 16r8309 16r584A 16r896A 16r584B 16r977A 16r584C 16r4EA1 16r584D 16r5984 16r584E 16r5FD8 16r584F 16r5FD9 16r5850 16r671B 16r5851 16r7DB2 16r5852 16r7F54 16r5853 16r8292 16r5854 16r832B 16r5855 16r83BD 16r5856 16r8F1E 16r5857 16r9099 16r5858 16r57CB 16r5859 16r59B9 16r585A 16r5A92 16r585B 16r5BD0 16r585C 16r6627 16r585D 16r679A 16r585E 16r6885 16r585F 16r6BCF 16r5860 16r7164 16r5861 16r7F75 16r5862 16r8CB7 16r5863 16r8CE3 16r5864 16r9081 16r5865 16r9B45 16r5866 16r8108 16r5867 16r8C8A 16r5868 16r964C 16r5869 16r9A40 16r586A 16r9EA5 16r586B 16r5B5F 16r586C 16r6C13 16r586D 16r731B 16r586E 16r76F2 16r586F 16r76DF 16r5870 16r840C 16r5871 16r51AA 16r5872 16r8993 16r5873 16r514D 16r5874 16r5195 16r5875 16r52C9 16r5876 16r68C9 16r5877 16r6C94 16r5878 16r7704 16r5879 16r7720 16r587A 16r7DBF 16r587B 16r7DEC 16r587C 16r9762 16r587D 16r9EB5 16r587E 16r6EC5 16r5921 16r8511 16r5922 16r51A5 16r5923 16r540D 16r5924 16r547D 16r5925 16r660E 16r5926 16r669D 16r5927 16r6927 16r5928 16r6E9F 16r5929 16r76BF 16r592A 16r7791 16r592B 16r8317 16r592C 16r84C2 16r592D 16r879F 16r592E 16r9169 16r592F 16r9298 16r5930 16r9CF4 16r5931 16r8882 16r5932 16r4FAE 16r5933 16r5192 16r5934 16r52DF 16r5935 16r59C6 16r5936 16r5E3D 16r5937 16r6155 16r5938 16r6478 16r5939 16r6479 16r593A 16r66AE 16r593B 16r67D0 16r593C 16r6A21 16r593D 16r6BCD 16r593E 16r6BDB 16r593F 16r725F 16r5940 16r7261 16r5941 16r7441 16r5942 16r7738 16r5943 16r77DB 16r5944 16r8017 16r5945 16r82BC 16r5946 16r8305 16r5947 16r8B00 16r5948 16r8B28 16r5949 16r8C8C 16r594A 16r6728 16r594B 16r6C90 16r594C 16r7267 16r594D 16r76EE 16r594E 16r7766 16r594F 16r7A46 16r5950 16r9DA9 16r5951 16r6B7F 16r5952 16r6C92 16r5953 16r5922 16r5954 16r6726 16r5955 16r8499 16r5956 16r536F 16r5957 16r5893 16r5958 16r5999 16r5959 16r5EDF 16r595A 16r63CF 16r595B 16r6634 16r595C 16r6773 16r595D 16r6E3A 16r595E 16r732B 16r595F 16r7AD7 16r5960 16r82D7 16r5961 16r9328 16r5962 16r52D9 16r5963 16r5DEB 16r5964 16r61AE 16r5965 16r61CB 16r5966 16r620A 16r5967 16r62C7 16r5968 16r64AB 16r5969 16r65E0 16r596A 16r6959 16r596B 16r6B66 16r596C 16r6BCB 16r596D 16r7121 16r596E 16r73F7 16r596F 16r755D 16r5970 16r7E46 16r5971 16r821E 16r5972 16r8302 16r5973 16r856A 16r5974 16r8AA3 16r5975 16r8CBF 16r5976 16r9727 16r5977 16r9D61 16r5978 16r58A8 16r5979 16r9ED8 16r597A 16r5011 16r597B 16r520E 16r597C 16r543B 16r597D 16r554F 16r597E 16r6587 16r5A21 16r6C76 16r5A22 16r7D0A 16r5A23 16r7D0B 16r5A24 16r805E 16r5A25 16r868A 16r5A26 16r9580 16r5A27 16r96EF 16r5A28 16r52FF 16r5A29 16r6C95 16r5A2A 16r7269 16r5A2B 16r5473 16r5A2C 16r5A9A 16r5A2D 16r5C3E 16r5A2E 16r5D4B 16r5A2F 16r5F4C 16r5A30 16r5FAE 16r5A31 16r672A 16r5A32 16r68B6 16r5A33 16r6963 16r5A34 16r6E3C 16r5A35 16r6E44 16r5A36 16r7709 16r5A37 16r7C73 16r5A38 16r7F8E 16r5A39 16r8587 16r5A3A 16r8B0E 16r5A3B 16r8FF7 16r5A3C 16r9761 16r5A3D 16r9EF4 16r5A3E 16r5CB7 16r5A3F 16r60B6 16r5A40 16r610D 16r5A41 16r61AB 16r5A42 16r654F 16r5A43 16r65FB 16r5A44 16r65FC 16r5A45 16r6C11 16r5A46 16r6CEF 16r5A47 16r739F 16r5A48 16r73C9 16r5A49 16r7DE1 16r5A4A 16r9594 16r5A4B 16r5BC6 16r5A4C 16r871C 16r5A4D 16r8B10 16r5A4E 16r525D 16r5A4F 16r535A 16r5A50 16r62CD 16r5A51 16r640F 16r5A52 16r64B2 16r5A53 16r6734 16r5A54 16r6A38 16r5A55 16r6CCA 16r5A56 16r73C0 16r5A57 16r749E 16r5A58 16r7B94 16r5A59 16r7C95 16r5A5A 16r7E1B 16r5A5B 16r818A 16r5A5C 16r8236 16r5A5D 16r8584 16r5A5E 16r8FEB 16r5A5F 16r96F9 16r5A60 16r99C1 16r5A61 16r4F34 16r5A62 16r534A 16r5A63 16r53CD 16r5A64 16r53DB 16r5A65 16r62CC 16r5A66 16r642C 16r5A67 16r6500 16r5A68 16r6591 16r5A69 16r69C3 16r5A6A 16r6CEE 16r5A6B 16r6F58 16r5A6C 16r73ED 16r5A6D 16r7554 16r5A6E 16r7622 16r5A6F 16r76E4 16r5A70 16r76FC 16r5A71 16r78D0 16r5A72 16r78FB 16r5A73 16r792C 16r5A74 16r7D46 16r5A75 16r822C 16r5A76 16r87E0 16r5A77 16r8FD4 16r5A78 16r9812 16r5A79 16r98EF 16r5A7A 16r52C3 16r5A7B 16r62D4 16r5A7C 16r64A5 16r5A7D 16r6E24 16r5A7E 16r6F51 16r5B21 16r767C 16r5B22 16r8DCB 16r5B23 16r91B1 16r5B24 16r9262 16r5B25 16r9AEE 16r5B26 16r9B43 16r5B27 16r5023 16r5B28 16r508D 16r5B29 16r574A 16r5B2A 16r59A8 16r5B2B 16r5C28 16r5B2C 16r5E47 16r5B2D 16r5F77 16r5B2E 16r623F 16r5B2F 16r653E 16r5B30 16r65B9 16r5B31 16r65C1 16r5B32 16r6609 16r5B33 16r678B 16r5B34 16r699C 16r5B35 16r6EC2 16r5B36 16r78C5 16r5B37 16r7D21 16r5B38 16r80AA 16r5B39 16r8180 16r5B3A 16r822B 16r5B3B 16r82B3 16r5B3C 16r84A1 16r5B3D 16r868C 16r5B3E 16r8A2A 16r5B3F 16r8B17 16r5B40 16r90A6 16r5B41 16r9632 16r5B42 16r9F90 16r5B43 16r500D 16r5B44 16r4FF3 16r5B45 16rF963 16r5B46 16r57F9 16r5B47 16r5F98 16r5B48 16r62DC 16r5B49 16r6392 16r5B4A 16r676F 16r5B4B 16r6E43 16r5B4C 16r7119 16r5B4D 16r76C3 16r5B4E 16r80CC 16r5B4F 16r80DA 16r5B50 16r88F4 16r5B51 16r88F5 16r5B52 16r8919 16r5B53 16r8CE0 16r5B54 16r8F29 16r5B55 16r914D 16r5B56 16r966A 16r5B57 16r4F2F 16r5B58 16r4F70 16r5B59 16r5E1B 16r5B5A 16r67CF 16r5B5B 16r6822 16r5B5C 16r767D 16r5B5D 16r767E 16r5B5E 16r9B44 16r5B5F 16r5E61 16r5B60 16r6A0A 16r5B61 16r7169 16r5B62 16r71D4 16r5B63 16r756A 16r5B64 16rF964 16r5B65 16r7E41 16r5B66 16r8543 16r5B67 16r85E9 16r5B68 16r98DC 16r5B69 16r4F10 16r5B6A 16r7B4F 16r5B6B 16r7F70 16r5B6C 16r95A5 16r5B6D 16r51E1 16r5B6E 16r5E06 16r5B6F 16r68B5 16r5B70 16r6C3E 16r5B71 16r6C4E 16r5B72 16r6CDB 16r5B73 16r72AF 16r5B74 16r7BC4 16r5B75 16r8303 16r5B76 16r6CD5 16r5B77 16r743A 16r5B78 16r50FB 16r5B79 16r5288 16r5B7A 16r58C1 16r5B7B 16r64D8 16r5B7C 16r6A97 16r5B7D 16r74A7 16r5B7E 16r7656 16r5C21 16r78A7 16r5C22 16r8617 16r5C23 16r95E2 16r5C24 16r9739 16r5C25 16rF965 16r5C26 16r535E 16r5C27 16r5F01 16r5C28 16r8B8A 16r5C29 16r8FA8 16r5C2A 16r8FAF 16r5C2B 16r908A 16r5C2C 16r5225 16r5C2D 16r77A5 16r5C2E 16r9C49 16r5C2F 16r9F08 16r5C30 16r4E19 16r5C31 16r5002 16r5C32 16r5175 16r5C33 16r5C5B 16r5C34 16r5E77 16r5C35 16r661E 16r5C36 16r663A 16r5C37 16r67C4 16r5C38 16r68C5 16r5C39 16r70B3 16r5C3A 16r7501 16r5C3B 16r75C5 16r5C3C 16r79C9 16r5C3D 16r7ADD 16r5C3E 16r8F27 16r5C3F 16r9920 16r5C40 16r9A08 16r5C41 16r4FDD 16r5C42 16r5821 16r5C43 16r5831 16r5C44 16r5BF6 16r5C45 16r666E 16r5C46 16r6B65 16r5C47 16r6D11 16r5C48 16r6E7A 16r5C49 16r6F7D 16r5C4A 16r73E4 16r5C4B 16r752B 16r5C4C 16r83E9 16r5C4D 16r88DC 16r5C4E 16r8913 16r5C4F 16r8B5C 16r5C50 16r8F14 16r5C51 16r4F0F 16r5C52 16r50D5 16r5C53 16r5310 16r5C54 16r535C 16r5C55 16r5B93 16r5C56 16r5FA9 16r5C57 16r670D 16r5C58 16r798F 16r5C59 16r8179 16r5C5A 16r832F 16r5C5B 16r8514 16r5C5C 16r8907 16r5C5D 16r8986 16r5C5E 16r8F39 16r5C5F 16r8F3B 16r5C60 16r99A5 16r5C61 16r9C12 16r5C62 16r672C 16r5C63 16r4E76 16r5C64 16r4FF8 16r5C65 16r5949 16r5C66 16r5C01 16r5C67 16r5CEF 16r5C68 16r5CF0 16r5C69 16r6367 16r5C6A 16r68D2 16r5C6B 16r70FD 16r5C6C 16r71A2 16r5C6D 16r742B 16r5C6E 16r7E2B 16r5C6F 16r84EC 16r5C70 16r8702 16r5C71 16r9022 16r5C72 16r92D2 16r5C73 16r9CF3 16r5C74 16r4E0D 16r5C75 16r4ED8 16r5C76 16r4FEF 16r5C77 16r5085 16r5C78 16r5256 16r5C79 16r526F 16r5C7A 16r5426 16r5C7B 16r5490 16r5C7C 16r57E0 16r5C7D 16r592B 16r5C7E 16r5A66 16r5D21 16r5B5A 16r5D22 16r5B75 16r5D23 16r5BCC 16r5D24 16r5E9C 16r5D25 16rF966 16r5D26 16r6276 16r5D27 16r6577 16r5D28 16r65A7 16r5D29 16r6D6E 16r5D2A 16r6EA5 16r5D2B 16r7236 16r5D2C 16r7B26 16r5D2D 16r7C3F 16r5D2E 16r7F36 16r5D2F 16r8150 16r5D30 16r8151 16r5D31 16r819A 16r5D32 16r8240 16r5D33 16r8299 16r5D34 16r83A9 16r5D35 16r8A03 16r5D36 16r8CA0 16r5D37 16r8CE6 16r5D38 16r8CFB 16r5D39 16r8D74 16r5D3A 16r8DBA 16r5D3B 16r90E8 16r5D3C 16r91DC 16r5D3D 16r961C 16r5D3E 16r9644 16r5D3F 16r99D9 16r5D40 16r9CE7 16r5D41 16r5317 16r5D42 16r5206 16r5D43 16r5429 16r5D44 16r5674 16r5D45 16r58B3 16r5D46 16r5954 16r5D47 16r596E 16r5D48 16r5FFF 16r5D49 16r61A4 16r5D4A 16r626E 16r5D4B 16r6610 16r5D4C 16r6C7E 16r5D4D 16r711A 16r5D4E 16r76C6 16r5D4F 16r7C89 16r5D50 16r7CDE 16r5D51 16r7D1B 16r5D52 16r82AC 16r5D53 16r8CC1 16r5D54 16r96F0 16r5D55 16rF967 16r5D56 16r4F5B 16r5D57 16r5F17 16r5D58 16r5F7F 16r5D59 16r62C2 16r5D5A 16r5D29 16r5D5B 16r670B 16r5D5C 16r68DA 16r5D5D 16r787C 16r5D5E 16r7E43 16r5D5F 16r9D6C 16r5D60 16r4E15 16r5D61 16r5099 16r5D62 16r5315 16r5D63 16r532A 16r5D64 16r5351 16r5D65 16r5983 16r5D66 16r5A62 16r5D67 16r5E87 16r5D68 16r60B2 16r5D69 16r618A 16r5D6A 16r6249 16r5D6B 16r6279 16r5D6C 16r6590 16r5D6D 16r6787 16r5D6E 16r69A7 16r5D6F 16r6BD4 16r5D70 16r6BD6 16r5D71 16r6BD7 16r5D72 16r6BD8 16r5D73 16r6CB8 16r5D74 16rF968 16r5D75 16r7435 16r5D76 16r75FA 16r5D77 16r7812 16r5D78 16r7891 16r5D79 16r79D5 16r5D7A 16r79D8 16r5D7B 16r7C83 16r5D7C 16r7DCB 16r5D7D 16r7FE1 16r5D7E 16r80A5 16r5E21 16r813E 16r5E22 16r81C2 16r5E23 16r83F2 16r5E24 16r871A 16r5E25 16r88E8 16r5E26 16r8AB9 16r5E27 16r8B6C 16r5E28 16r8CBB 16r5E29 16r9119 16r5E2A 16r975E 16r5E2B 16r98DB 16r5E2C 16r9F3B 16r5E2D 16r56AC 16r5E2E 16r5B2A 16r5E2F 16r5F6C 16r5E30 16r658C 16r5E31 16r6AB3 16r5E32 16r6BAF 16r5E33 16r6D5C 16r5E34 16r6FF1 16r5E35 16r7015 16r5E36 16r725D 16r5E37 16r73AD 16r5E38 16r8CA7 16r5E39 16r8CD3 16r5E3A 16r983B 16r5E3B 16r6191 16r5E3C 16r6C37 16r5E3D 16r8058 16r5E3E 16r9A01 16r5E3F 16r4E4D 16r5E40 16r4E8B 16r5E41 16r4E9B 16r5E42 16r4ED5 16r5E43 16r4F3A 16r5E44 16r4F3C 16r5E45 16r4F7F 16r5E46 16r4FDF 16r5E47 16r50FF 16r5E48 16r53F2 16r5E49 16r53F8 16r5E4A 16r5506 16r5E4B 16r55E3 16r5E4C 16r56DB 16r5E4D 16r58EB 16r5E4E 16r5962 16r5E4F 16r5A11 16r5E50 16r5BEB 16r5E51 16r5BFA 16r5E52 16r5C04 16r5E53 16r5DF3 16r5E54 16r5E2B 16r5E55 16r5F99 16r5E56 16r601D 16r5E57 16r6368 16r5E58 16r659C 16r5E59 16r65AF 16r5E5A 16r67F6 16r5E5B 16r67FB 16r5E5C 16r68AD 16r5E5D 16r6B7B 16r5E5E 16r6C99 16r5E5F 16r6CD7 16r5E60 16r6E23 16r5E61 16r7009 16r5E62 16r7345 16r5E63 16r7802 16r5E64 16r793E 16r5E65 16r7940 16r5E66 16r7960 16r5E67 16r79C1 16r5E68 16r7BE9 16r5E69 16r7D17 16r5E6A 16r7D72 16r5E6B 16r8086 16r5E6C 16r820D 16r5E6D 16r838E 16r5E6E 16r84D1 16r5E6F 16r86C7 16r5E70 16r88DF 16r5E71 16r8A50 16r5E72 16r8A5E 16r5E73 16r8B1D 16r5E74 16r8CDC 16r5E75 16r8D66 16r5E76 16r8FAD 16r5E77 16r90AA 16r5E78 16r98FC 16r5E79 16r99DF 16r5E7A 16r9E9D 16r5E7B 16r524A 16r5E7C 16rF969 16r5E7D 16r6714 16r5E7E 16rF96A 16r5F21 16r5098 16r5F22 16r522A 16r5F23 16r5C71 16r5F24 16r6563 16r5F25 16r6C55 16r5F26 16r73CA 16r5F27 16r7523 16r5F28 16r759D 16r5F29 16r7B97 16r5F2A 16r849C 16r5F2B 16r9178 16r5F2C 16r9730 16r5F2D 16r4E77 16r5F2E 16r6492 16r5F2F 16r6BBA 16r5F30 16r715E 16r5F31 16r85A9 16r5F32 16r4E09 16r5F33 16rF96B 16r5F34 16r6749 16r5F35 16r68EE 16r5F36 16r6E17 16r5F37 16r829F 16r5F38 16r8518 16r5F39 16r886B 16r5F3A 16r63F7 16r5F3B 16r6F81 16r5F3C 16r9212 16r5F3D 16r98AF 16r5F3E 16r4E0A 16r5F3F 16r50B7 16r5F40 16r50CF 16r5F41 16r511F 16r5F42 16r5546 16r5F43 16r55AA 16r5F44 16r5617 16r5F45 16r5B40 16r5F46 16r5C19 16r5F47 16r5CE0 16r5F48 16r5E38 16r5F49 16r5E8A 16r5F4A 16r5EA0 16r5F4B 16r5EC2 16r5F4C 16r60F3 16r5F4D 16r6851 16r5F4E 16r6A61 16r5F4F 16r6E58 16r5F50 16r723D 16r5F51 16r7240 16r5F52 16r72C0 16r5F53 16r76F8 16r5F54 16r7965 16r5F55 16r7BB1 16r5F56 16r7FD4 16r5F57 16r88F3 16r5F58 16r89F4 16r5F59 16r8A73 16r5F5A 16r8C61 16r5F5B 16r8CDE 16r5F5C 16r971C 16r5F5D 16r585E 16r5F5E 16r74BD 16r5F5F 16r8CFD 16r5F60 16r55C7 16r5F61 16rF96C 16r5F62 16r7A61 16r5F63 16r7D22 16r5F64 16r8272 16r5F65 16r7272 16r5F66 16r751F 16r5F67 16r7525 16r5F68 16rF96D 16r5F69 16r7B19 16r5F6A 16r5885 16r5F6B 16r58FB 16r5F6C 16r5DBC 16r5F6D 16r5E8F 16r5F6E 16r5EB6 16r5F6F 16r5F90 16r5F70 16r6055 16r5F71 16r6292 16r5F72 16r637F 16r5F73 16r654D 16r5F74 16r6691 16r5F75 16r66D9 16r5F76 16r66F8 16r5F77 16r6816 16r5F78 16r68F2 16r5F79 16r7280 16r5F7A 16r745E 16r5F7B 16r7B6E 16r5F7C 16r7D6E 16r5F7D 16r7DD6 16r5F7E 16r7F72 16r6021 16r80E5 16r6022 16r8212 16r6023 16r85AF 16r6024 16r897F 16r6025 16r8A93 16r6026 16r901D 16r6027 16r92E4 16r6028 16r9ECD 16r6029 16r9F20 16r602A 16r5915 16r602B 16r596D 16r602C 16r5E2D 16r602D 16r60DC 16r602E 16r6614 16r602F 16r6673 16r6030 16r6790 16r6031 16r6C50 16r6032 16r6DC5 16r6033 16r6F5F 16r6034 16r77F3 16r6035 16r78A9 16r6036 16r84C6 16r6037 16r91CB 16r6038 16r932B 16r6039 16r4ED9 16r603A 16r50CA 16r603B 16r5148 16r603C 16r5584 16r603D 16r5B0B 16r603E 16r5BA3 16r603F 16r6247 16r6040 16r657E 16r6041 16r65CB 16r6042 16r6E32 16r6043 16r717D 16r6044 16r7401 16r6045 16r7444 16r6046 16r7487 16r6047 16r74BF 16r6048 16r766C 16r6049 16r79AA 16r604A 16r7DDA 16r604B 16r7E55 16r604C 16r7FA8 16r604D 16r817A 16r604E 16r81B3 16r604F 16r8239 16r6050 16r861A 16r6051 16r87EC 16r6052 16r8A75 16r6053 16r8DE3 16r6054 16r9078 16r6055 16r9291 16r6056 16r9425 16r6057 16r994D 16r6058 16r9BAE 16r6059 16r5368 16r605A 16r5C51 16r605B 16r6954 16r605C 16r6CC4 16r605D 16r6D29 16r605E 16r6E2B 16r605F 16r820C 16r6060 16r859B 16r6061 16r893B 16r6062 16r8A2D 16r6063 16r8AAA 16r6064 16r96EA 16r6065 16r9F67 16r6066 16r5261 16r6067 16r66B9 16r6068 16r6BB2 16r6069 16r7E96 16r606A 16r87FE 16r606B 16r8D0D 16r606C 16r9583 16r606D 16r965D 16r606E 16r651D 16r606F 16r6D89 16r6070 16r71EE 16r6071 16rF96E 16r6072 16r57CE 16r6073 16r59D3 16r6074 16r5BAC 16r6075 16r6027 16r6076 16r60FA 16r6077 16r6210 16r6078 16r661F 16r6079 16r665F 16r607A 16r7329 16r607B 16r73F9 16r607C 16r76DB 16r607D 16r7701 16r607E 16r7B6C 16r6121 16r8056 16r6122 16r8072 16r6123 16r8165 16r6124 16r8AA0 16r6125 16r9192 16r6126 16r4E16 16r6127 16r52E2 16r6128 16r6B72 16r6129 16r6D17 16r612A 16r7A05 16r612B 16r7B39 16r612C 16r7D30 16r612D 16rF96F 16r612E 16r8CB0 16r612F 16r53EC 16r6130 16r562F 16r6131 16r5851 16r6132 16r5BB5 16r6133 16r5C0F 16r6134 16r5C11 16r6135 16r5DE2 16r6136 16r6240 16r6137 16r6383 16r6138 16r6414 16r6139 16r662D 16r613A 16r68B3 16r613B 16r6CBC 16r613C 16r6D88 16r613D 16r6EAF 16r613E 16r701F 16r613F 16r70A4 16r6140 16r71D2 16r6141 16r7526 16r6142 16r758F 16r6143 16r758E 16r6144 16r7619 16r6145 16r7B11 16r6146 16r7BE0 16r6147 16r7C2B 16r6148 16r7D20 16r6149 16r7D39 16r614A 16r852C 16r614B 16r856D 16r614C 16r8607 16r614D 16r8A34 16r614E 16r900D 16r614F 16r9061 16r6150 16r90B5 16r6151 16r92B7 16r6152 16r97F6 16r6153 16r9A37 16r6154 16r4FD7 16r6155 16r5C6C 16r6156 16r675F 16r6157 16r6D91 16r6158 16r7C9F 16r6159 16r7E8C 16r615A 16r8B16 16r615B 16r8D16 16r615C 16r901F 16r615D 16r5B6B 16r615E 16r5DFD 16r615F 16r640D 16r6160 16r84C0 16r6161 16r905C 16r6162 16r98E1 16r6163 16r7387 16r6164 16r5B8B 16r6165 16r609A 16r6166 16r677E 16r6167 16r6DDE 16r6168 16r8A1F 16r6169 16r8AA6 16r616A 16r9001 16r616B 16r980C 16r616C 16r5237 16r616D 16rF970 16r616E 16r7051 16r616F 16r788E 16r6170 16r9396 16r6171 16r8870 16r6172 16r91D7 16r6173 16r4FEE 16r6174 16r53D7 16r6175 16r55FD 16r6176 16r56DA 16r6177 16r5782 16r6178 16r58FD 16r6179 16r5AC2 16r617A 16r5B88 16r617B 16r5CAB 16r617C 16r5CC0 16r617D 16r5E25 16r617E 16r6101 16r6221 16r620D 16r6222 16r624B 16r6223 16r6388 16r6224 16r641C 16r6225 16r6536 16r6226 16r6578 16r6227 16r6A39 16r6228 16r6B8A 16r6229 16r6C34 16r622A 16r6D19 16r622B 16r6F31 16r622C 16r71E7 16r622D 16r72E9 16r622E 16r7378 16r622F 16r7407 16r6230 16r74B2 16r6231 16r7626 16r6232 16r7761 16r6233 16r79C0 16r6234 16r7A57 16r6235 16r7AEA 16r6236 16r7CB9 16r6237 16r7D8F 16r6238 16r7DAC 16r6239 16r7E61 16r623A 16r7F9E 16r623B 16r8129 16r623C 16r8331 16r623D 16r8490 16r623E 16r84DA 16r623F 16r85EA 16r6240 16r8896 16r6241 16r8AB0 16r6242 16r8B90 16r6243 16r8F38 16r6244 16r9042 16r6245 16r9083 16r6246 16r916C 16r6247 16r9296 16r6248 16r92B9 16r6249 16r968B 16r624A 16r96A7 16r624B 16r96A8 16r624C 16r96D6 16r624D 16r9700 16r624E 16r9808 16r624F 16r9996 16r6250 16r9AD3 16r6251 16r9B1A 16r6252 16r53D4 16r6253 16r587E 16r6254 16r5919 16r6255 16r5B70 16r6256 16r5BBF 16r6257 16r6DD1 16r6258 16r6F5A 16r6259 16r719F 16r625A 16r7421 16r625B 16r74B9 16r625C 16r8085 16r625D 16r83FD 16r625E 16r5DE1 16r625F 16r5F87 16r6260 16r5FAA 16r6261 16r6042 16r6262 16r65EC 16r6263 16r6812 16r6264 16r696F 16r6265 16r6A53 16r6266 16r6B89 16r6267 16r6D35 16r6268 16r6DF3 16r6269 16r73E3 16r626A 16r76FE 16r626B 16r77AC 16r626C 16r7B4D 16r626D 16r7D14 16r626E 16r8123 16r626F 16r821C 16r6270 16r8340 16r6271 16r84F4 16r6272 16r8563 16r6273 16r8A62 16r6274 16r8AC4 16r6275 16r9187 16r6276 16r931E 16r6277 16r9806 16r6278 16r99B4 16r6279 16r620C 16r627A 16r8853 16r627B 16r8FF0 16r627C 16r9265 16r627D 16r5D07 16r627E 16r5D27 16r6321 16r5D69 16r6322 16r745F 16r6323 16r819D 16r6324 16r8768 16r6325 16r6FD5 16r6326 16r62FE 16r6327 16r7FD2 16r6328 16r8936 16r6329 16r8972 16r632A 16r4E1E 16r632B 16r4E58 16r632C 16r50E7 16r632D 16r52DD 16r632E 16r5347 16r632F 16r627F 16r6330 16r6607 16r6331 16r7E69 16r6332 16r8805 16r6333 16r965E 16r6334 16r4F8D 16r6335 16r5319 16r6336 16r5636 16r6337 16r59CB 16r6338 16r5AA4 16r6339 16r5C38 16r633A 16r5C4E 16r633B 16r5C4D 16r633C 16r5E02 16r633D 16r5F11 16r633E 16r6043 16r633F 16r65BD 16r6340 16r662F 16r6341 16r6642 16r6342 16r67BE 16r6343 16r67F4 16r6344 16r731C 16r6345 16r77E2 16r6346 16r793A 16r6347 16r7FC5 16r6348 16r8494 16r6349 16r84CD 16r634A 16r8996 16r634B 16r8A66 16r634C 16r8A69 16r634D 16r8AE1 16r634E 16r8C55 16r634F 16r8C7A 16r6350 16r57F4 16r6351 16r5BD4 16r6352 16r5F0F 16r6353 16r606F 16r6354 16r62ED 16r6355 16r690D 16r6356 16r6B96 16r6357 16r6E5C 16r6358 16r7184 16r6359 16r7BD2 16r635A 16r8755 16r635B 16r8B58 16r635C 16r8EFE 16r635D 16r98DF 16r635E 16r98FE 16r635F 16r4F38 16r6360 16r4F81 16r6361 16r4FE1 16r6362 16r547B 16r6363 16r5A20 16r6364 16r5BB8 16r6365 16r613C 16r6366 16r65B0 16r6367 16r6668 16r6368 16r71FC 16r6369 16r7533 16r636A 16r795E 16r636B 16r7D33 16r636C 16r814E 16r636D 16r81E3 16r636E 16r8398 16r636F 16r85AA 16r6370 16r85CE 16r6371 16r8703 16r6372 16r8A0A 16r6373 16r8EAB 16r6374 16r8F9B 16r6375 16rF971 16r6376 16r8FC5 16r6377 16r5931 16r6378 16r5BA4 16r6379 16r5BE6 16r637A 16r6089 16r637B 16r5BE9 16r637C 16r5C0B 16r637D 16r5FC3 16r637E 16r6C81 16r6421 16rF972 16r6422 16r6DF1 16r6423 16r700B 16r6424 16r751A 16r6425 16r82AF 16r6426 16r8AF6 16r6427 16r4EC0 16r6428 16r5341 16r6429 16rF973 16r642A 16r96D9 16r642B 16r6C0F 16r642C 16r4E9E 16r642D 16r4FC4 16r642E 16r5152 16r642F 16r555E 16r6430 16r5A25 16r6431 16r5CE8 16r6432 16r6211 16r6433 16r7259 16r6434 16r82BD 16r6435 16r83AA 16r6436 16r86FE 16r6437 16r8859 16r6438 16r8A1D 16r6439 16r963F 16r643A 16r96C5 16r643B 16r9913 16r643C 16r9D09 16r643D 16r9D5D 16r643E 16r580A 16r643F 16r5CB3 16r6440 16r5DBD 16r6441 16r5E44 16r6442 16r60E1 16r6443 16r6115 16r6444 16r63E1 16r6445 16r6A02 16r6446 16r6E25 16r6447 16r9102 16r6448 16r9354 16r6449 16r984E 16r644A 16r9C10 16r644B 16r9F77 16r644C 16r5B89 16r644D 16r5CB8 16r644E 16r6309 16r644F 16r664F 16r6450 16r6848 16r6451 16r773C 16r6452 16r96C1 16r6453 16r978D 16r6454 16r9854 16r6455 16r9B9F 16r6456 16r65A1 16r6457 16r8B01 16r6458 16r8ECB 16r6459 16r95BC 16r645A 16r5535 16r645B 16r5CA9 16r645C 16r5DD6 16r645D 16r5EB5 16r645E 16r6697 16r645F 16r764C 16r6460 16r83F4 16r6461 16r95C7 16r6462 16r58D3 16r6463 16r62BC 16r6464 16r72CE 16r6465 16r9D28 16r6466 16r4EF0 16r6467 16r592E 16r6468 16r600F 16r6469 16r663B 16r646A 16r6B83 16r646B 16r79E7 16r646C 16r9D26 16r646D 16r5393 16r646E 16r54C0 16r646F 16r57C3 16r6470 16r5D16 16r6471 16r611B 16r6472 16r66D6 16r6473 16r6DAF 16r6474 16r788D 16r6475 16r827E 16r6476 16r9698 16r6477 16r9744 16r6478 16r5384 16r6479 16r627C 16r647A 16r6396 16r647B 16r6DB2 16r647C 16r7E0A 16r647D 16r814B 16r647E 16r984D 16r6521 16r6AFB 16r6522 16r7F4C 16r6523 16r9DAF 16r6524 16r9E1A 16r6525 16r4E5F 16r6526 16r503B 16r6527 16r51B6 16r6528 16r591C 16r6529 16r60F9 16r652A 16r63F6 16r652B 16r6930 16r652C 16r723A 16r652D 16r8036 16r652E 16rF974 16r652F 16r91CE 16r6530 16r5F31 16r6531 16rF975 16r6532 16rF976 16r6533 16r7D04 16r6534 16r82E5 16r6535 16r846F 16r6536 16r84BB 16r6537 16r85E5 16r6538 16r8E8D 16r6539 16rF977 16r653A 16r4F6F 16r653B 16rF978 16r653C 16rF979 16r653D 16r58E4 16r653E 16r5B43 16r653F 16r6059 16r6540 16r63DA 16r6541 16r6518 16r6542 16r656D 16r6543 16r6698 16r6544 16rF97A 16r6545 16r694A 16r6546 16r6A23 16r6547 16r6D0B 16r6548 16r7001 16r6549 16r716C 16r654A 16r75D2 16r654B 16r760D 16r654C 16r79B3 16r654D 16r7A70 16r654E 16rF97B 16r654F 16r7F8A 16r6550 16rF97C 16r6551 16r8944 16r6552 16rF97D 16r6553 16r8B93 16r6554 16r91C0 16r6555 16r967D 16r6556 16rF97E 16r6557 16r990A 16r6558 16r5704 16r6559 16r5FA1 16r655A 16r65BC 16r655B 16r6F01 16r655C 16r7600 16r655D 16r79A6 16r655E 16r8A9E 16r655F 16r99AD 16r6560 16r9B5A 16r6561 16r9F6C 16r6562 16r5104 16r6563 16r61B6 16r6564 16r6291 16r6565 16r6A8D 16r6566 16r81C6 16r6567 16r5043 16r6568 16r5830 16r6569 16r5F66 16r656A 16r7109 16r656B 16r8A00 16r656C 16r8AFA 16r656D 16r5B7C 16r656E 16r8616 16r656F 16r4FFA 16r6570 16r513C 16r6571 16r56B4 16r6572 16r5944 16r6573 16r63A9 16r6574 16r6DF9 16r6575 16r5DAA 16r6576 16r696D 16r6577 16r5186 16r6578 16r4E88 16r6579 16r4F59 16r657A 16rF97F 16r657B 16rF980 16r657C 16rF981 16r657D 16r5982 16r657E 16rF982 16r6621 16rF983 16r6622 16r6B5F 16r6623 16r6C5D 16r6624 16rF984 16r6625 16r74B5 16r6626 16r7916 16r6627 16rF985 16r6628 16r8207 16r6629 16r8245 16r662A 16r8339 16r662B 16r8F3F 16r662C 16r8F5D 16r662D 16rF986 16r662E 16r9918 16r662F 16rF987 16r6630 16rF988 16r6631 16rF989 16r6632 16r4EA6 16r6633 16rF98A 16r6634 16r57DF 16r6635 16r5F79 16r6636 16r6613 16r6637 16rF98B 16r6638 16rF98C 16r6639 16r75AB 16r663A 16r7E79 16r663B 16r8B6F 16r663C 16rF98D 16r663D 16r9006 16r663E 16r9A5B 16r663F 16r56A5 16r6640 16r5827 16r6641 16r59F8 16r6642 16r5A1F 16r6643 16r5BB4 16r6644 16rF98E 16r6645 16r5EF6 16r6646 16rF98F 16r6647 16rF990 16r6648 16r6350 16r6649 16r633B 16r664A 16rF991 16r664B 16r693D 16r664C 16r6C87 16r664D 16r6CBF 16r664E 16r6D8E 16r664F 16r6D93 16r6650 16r6DF5 16r6651 16r6F14 16r6652 16rF992 16r6653 16r70DF 16r6654 16r7136 16r6655 16r7159 16r6656 16rF993 16r6657 16r71C3 16r6658 16r71D5 16r6659 16rF994 16r665A 16r784F 16r665B 16r786F 16r665C 16rF995 16r665D 16r7B75 16r665E 16r7DE3 16r665F 16rF996 16r6660 16r7E2F 16r6661 16rF997 16r6662 16r884D 16r6663 16r8EDF 16r6664 16rF998 16r6665 16rF999 16r6666 16rF99A 16r6667 16r925B 16r6668 16rF99B 16r6669 16r9CF6 16r666A 16rF99C 16r666B 16rF99D 16r666C 16rF99E 16r666D 16r6085 16r666E 16r6D85 16r666F 16rF99F 16r6670 16r71B1 16r6671 16rF9A0 16r6672 16rF9A1 16r6673 16r95B1 16r6674 16r53AD 16r6675 16rF9A2 16r6676 16rF9A3 16r6677 16rF9A4 16r6678 16r67D3 16r6679 16rF9A5 16r667A 16r708E 16r667B 16r7130 16r667C 16r7430 16r667D 16r8276 16r667E 16r82D2 16r6721 16rF9A6 16r6722 16r95BB 16r6723 16r9AE5 16r6724 16r9E7D 16r6725 16r66C4 16r6726 16rF9A7 16r6727 16r71C1 16r6728 16r8449 16r6729 16rF9A8 16r672A 16rF9A9 16r672B 16r584B 16r672C 16rF9AA 16r672D 16rF9AB 16r672E 16r5DB8 16r672F 16r5F71 16r6730 16rF9AC 16r6731 16r6620 16r6732 16r668E 16r6733 16r6979 16r6734 16r69AE 16r6735 16r6C38 16r6736 16r6CF3 16r6737 16r6E36 16r6738 16r6F41 16r6739 16r6FDA 16r673A 16r701B 16r673B 16r702F 16r673C 16r7150 16r673D 16r71DF 16r673E 16r7370 16r673F 16rF9AD 16r6740 16r745B 16r6741 16rF9AE 16r6742 16r74D4 16r6743 16r76C8 16r6744 16r7A4E 16r6745 16r7E93 16r6746 16rF9AF 16r6747 16rF9B0 16r6748 16r82F1 16r6749 16r8A60 16r674A 16r8FCE 16r674B 16rF9B1 16r674C 16r9348 16r674D 16rF9B2 16r674E 16r9719 16r674F 16rF9B3 16r6750 16rF9B4 16r6751 16r4E42 16r6752 16r502A 16r6753 16rF9B5 16r6754 16r5208 16r6755 16r53E1 16r6756 16r66F3 16r6757 16r6C6D 16r6758 16r6FCA 16r6759 16r730A 16r675A 16r777F 16r675B 16r7A62 16r675C 16r82AE 16r675D 16r85DD 16r675E 16r8602 16r675F 16rF9B6 16r6760 16r88D4 16r6761 16r8A63 16r6762 16r8B7D 16r6763 16r8C6B 16r6764 16rF9B7 16r6765 16r92B3 16r6766 16rF9B8 16r6767 16r9713 16r6768 16r9810 16r6769 16r4E94 16r676A 16r4F0D 16r676B 16r4FC9 16r676C 16r50B2 16r676D 16r5348 16r676E 16r543E 16r676F 16r5433 16r6770 16r55DA 16r6771 16r5862 16r6772 16r58BA 16r6773 16r5967 16r6774 16r5A1B 16r6775 16r5BE4 16r6776 16r609F 16r6777 16rF9B9 16r6778 16r61CA 16r6779 16r6556 16r677A 16r65FF 16r677B 16r6664 16r677C 16r68A7 16r677D 16r6C5A 16r677E 16r6FB3 16r6821 16r70CF 16r6822 16r71AC 16r6823 16r7352 16r6824 16r7B7D 16r6825 16r8708 16r6826 16r8AA4 16r6827 16r9C32 16r6828 16r9F07 16r6829 16r5C4B 16r682A 16r6C83 16r682B 16r7344 16r682C 16r7389 16r682D 16r923A 16r682E 16r6EAB 16r682F 16r7465 16r6830 16r761F 16r6831 16r7A69 16r6832 16r7E15 16r6833 16r860A 16r6834 16r5140 16r6835 16r58C5 16r6836 16r64C1 16r6837 16r74EE 16r6838 16r7515 16r6839 16r7670 16r683A 16r7FC1 16r683B 16r9095 16r683C 16r96CD 16r683D 16r9954 16r683E 16r6E26 16r683F 16r74E6 16r6840 16r7AA9 16r6841 16r7AAA 16r6842 16r81E5 16r6843 16r86D9 16r6844 16r8778 16r6845 16r8A1B 16r6846 16r5A49 16r6847 16r5B8C 16r6848 16r5B9B 16r6849 16r68A1 16r684A 16r6900 16r684B 16r6D63 16r684C 16r73A9 16r684D 16r7413 16r684E 16r742C 16r684F 16r7897 16r6850 16r7DE9 16r6851 16r7FEB 16r6852 16r8118 16r6853 16r8155 16r6854 16r839E 16r6855 16r8C4C 16r6856 16r962E 16r6857 16r9811 16r6858 16r66F0 16r6859 16r5F80 16r685A 16r65FA 16r685B 16r6789 16r685C 16r6C6A 16r685D 16r738B 16r685E 16r502D 16r685F 16r5A03 16r6860 16r6B6A 16r6861 16r77EE 16r6862 16r5916 16r6863 16r5D6C 16r6864 16r5DCD 16r6865 16r7325 16r6866 16r754F 16r6867 16rF9BA 16r6868 16rF9BB 16r6869 16r50E5 16r686A 16r51F9 16r686B 16r582F 16r686C 16r592D 16r686D 16r5996 16r686E 16r59DA 16r686F 16r5BE5 16r6870 16rF9BC 16r6871 16rF9BD 16r6872 16r5DA2 16r6873 16r62D7 16r6874 16r6416 16r6875 16r6493 16r6876 16r64FE 16r6877 16rF9BE 16r6878 16r66DC 16r6879 16rF9BF 16r687A 16r6A48 16r687B 16rF9C0 16r687C 16r71FF 16r687D 16r7464 16r687E 16rF9C1 16r6921 16r7A88 16r6922 16r7AAF 16r6923 16r7E47 16r6924 16r7E5E 16r6925 16r8000 16r6926 16r8170 16r6927 16rF9C2 16r6928 16r87EF 16r6929 16r8981 16r692A 16r8B20 16r692B 16r9059 16r692C 16rF9C3 16r692D 16r9080 16r692E 16r9952 16r692F 16r617E 16r6930 16r6B32 16r6931 16r6D74 16r6932 16r7E1F 16r6933 16r8925 16r6934 16r8FB1 16r6935 16r4FD1 16r6936 16r50AD 16r6937 16r5197 16r6938 16r52C7 16r6939 16r57C7 16r693A 16r5889 16r693B 16r5BB9 16r693C 16r5EB8 16r693D 16r6142 16r693E 16r6995 16r693F 16r6D8C 16r6940 16r6E67 16r6941 16r6EB6 16r6942 16r7194 16r6943 16r7462 16r6944 16r7528 16r6945 16r752C 16r6946 16r8073 16r6947 16r8338 16r6948 16r84C9 16r6949 16r8E0A 16r694A 16r9394 16r694B 16r93DE 16r694C 16rF9C4 16r694D 16r4E8E 16r694E 16r4F51 16r694F 16r5076 16r6950 16r512A 16r6951 16r53C8 16r6952 16r53CB 16r6953 16r53F3 16r6954 16r5B87 16r6955 16r5BD3 16r6956 16r5C24 16r6957 16r611A 16r6958 16r6182 16r6959 16r65F4 16r695A 16r725B 16r695B 16r7397 16r695C 16r7440 16r695D 16r76C2 16r695E 16r7950 16r695F 16r7991 16r6960 16r79B9 16r6961 16r7D06 16r6962 16r7FBD 16r6963 16r828B 16r6964 16r85D5 16r6965 16r865E 16r6966 16r8FC2 16r6967 16r9047 16r6968 16r90F5 16r6969 16r91EA 16r696A 16r9685 16r696B 16r96E8 16r696C 16r96E9 16r696D 16r52D6 16r696E 16r5F67 16r696F 16r65ED 16r6970 16r6631 16r6971 16r682F 16r6972 16r715C 16r6973 16r7A36 16r6974 16r90C1 16r6975 16r980A 16r6976 16r4E91 16r6977 16rF9C5 16r6978 16r6A52 16r6979 16r6B9E 16r697A 16r6F90 16r697B 16r7189 16r697C 16r8018 16r697D 16r82B8 16r697E 16r8553 16r6A21 16r904B 16r6A22 16r9695 16r6A23 16r96F2 16r6A24 16r97FB 16r6A25 16r851A 16r6A26 16r9B31 16r6A27 16r4E90 16r6A28 16r718A 16r6A29 16r96C4 16r6A2A 16r5143 16r6A2B 16r539F 16r6A2C 16r54E1 16r6A2D 16r5713 16r6A2E 16r5712 16r6A2F 16r57A3 16r6A30 16r5A9B 16r6A31 16r5AC4 16r6A32 16r5BC3 16r6A33 16r6028 16r6A34 16r613F 16r6A35 16r63F4 16r6A36 16r6C85 16r6A37 16r6D39 16r6A38 16r6E72 16r6A39 16r6E90 16r6A3A 16r7230 16r6A3B 16r733F 16r6A3C 16r7457 16r6A3D 16r82D1 16r6A3E 16r8881 16r6A3F 16r8F45 16r6A40 16r9060 16r6A41 16rF9C6 16r6A42 16r9662 16r6A43 16r9858 16r6A44 16r9D1B 16r6A45 16r6708 16r6A46 16r8D8A 16r6A47 16r925E 16r6A48 16r4F4D 16r6A49 16r5049 16r6A4A 16r50DE 16r6A4B 16r5371 16r6A4C 16r570D 16r6A4D 16r59D4 16r6A4E 16r5A01 16r6A4F 16r5C09 16r6A50 16r6170 16r6A51 16r6690 16r6A52 16r6E2D 16r6A53 16r7232 16r6A54 16r744B 16r6A55 16r7DEF 16r6A56 16r80C3 16r6A57 16r840E 16r6A58 16r8466 16r6A59 16r853F 16r6A5A 16r875F 16r6A5B 16r885B 16r6A5C 16r8918 16r6A5D 16r8B02 16r6A5E 16r9055 16r6A5F 16r97CB 16r6A60 16r9B4F 16r6A61 16r4E73 16r6A62 16r4F91 16r6A63 16r5112 16r6A64 16r516A 16r6A65 16rF9C7 16r6A66 16r552F 16r6A67 16r55A9 16r6A68 16r5B7A 16r6A69 16r5BA5 16r6A6A 16r5E7C 16r6A6B 16r5E7D 16r6A6C 16r5EBE 16r6A6D 16r60A0 16r6A6E 16r60DF 16r6A6F 16r6108 16r6A70 16r6109 16r6A71 16r63C4 16r6A72 16r6538 16r6A73 16r6709 16r6A74 16rF9C8 16r6A75 16r67D4 16r6A76 16r67DA 16r6A77 16rF9C9 16r6A78 16r6961 16r6A79 16r6962 16r6A7A 16r6CB9 16r6A7B 16r6D27 16r6A7C 16rF9CA 16r6A7D 16r6E38 16r6A7E 16rF9CB 16r6B21 16r6FE1 16r6B22 16r7336 16r6B23 16r7337 16r6B24 16rF9CC 16r6B25 16r745C 16r6B26 16r7531 16r6B27 16rF9CD 16r6B28 16r7652 16r6B29 16rF9CE 16r6B2A 16rF9CF 16r6B2B 16r7DAD 16r6B2C 16r81FE 16r6B2D 16r8438 16r6B2E 16r88D5 16r6B2F 16r8A98 16r6B30 16r8ADB 16r6B31 16r8AED 16r6B32 16r8E30 16r6B33 16r8E42 16r6B34 16r904A 16r6B35 16r903E 16r6B36 16r907A 16r6B37 16r9149 16r6B38 16r91C9 16r6B39 16r936E 16r6B3A 16rF9D0 16r6B3B 16rF9D1 16r6B3C 16r5809 16r6B3D 16rF9D2 16r6B3E 16r6BD3 16r6B3F 16r8089 16r6B40 16r80B2 16r6B41 16rF9D3 16r6B42 16rF9D4 16r6B43 16r5141 16r6B44 16r596B 16r6B45 16r5C39 16r6B46 16rF9D5 16r6B47 16rF9D6 16r6B48 16r6F64 16r6B49 16r73A7 16r6B4A 16r80E4 16r6B4B 16r8D07 16r6B4C 16rF9D7 16r6B4D 16r9217 16r6B4E 16r958F 16r6B4F 16rF9D8 16r6B50 16rF9D9 16r6B51 16rF9DA 16r6B52 16rF9DB 16r6B53 16r807F 16r6B54 16r620E 16r6B55 16r701C 16r6B56 16r7D68 16r6B57 16r878D 16r6B58 16rF9DC 16r6B59 16r57A0 16r6B5A 16r6069 16r6B5B 16r6147 16r6B5C 16r6BB7 16r6B5D 16r8ABE 16r6B5E 16r9280 16r6B5F 16r96B1 16r6B60 16r4E59 16r6B61 16r541F 16r6B62 16r6DEB 16r6B63 16r852D 16r6B64 16r9670 16r6B65 16r97F3 16r6B66 16r98EE 16r6B67 16r63D6 16r6B68 16r6CE3 16r6B69 16r9091 16r6B6A 16r51DD 16r6B6B 16r61C9 16r6B6C 16r81BA 16r6B6D 16r9DF9 16r6B6E 16r4F9D 16r6B6F 16r501A 16r6B70 16r5100 16r6B71 16r5B9C 16r6B72 16r610F 16r6B73 16r61FF 16r6B74 16r64EC 16r6B75 16r6905 16r6B76 16r6BC5 16r6B77 16r7591 16r6B78 16r77E3 16r6B79 16r7FA9 16r6B7A 16r8264 16r6B7B 16r858F 16r6B7C 16r87FB 16r6B7D 16r8863 16r6B7E 16r8ABC 16r6C21 16r8B70 16r6C22 16r91AB 16r6C23 16r4E8C 16r6C24 16r4EE5 16r6C25 16r4F0A 16r6C26 16rF9DD 16r6C27 16rF9DE 16r6C28 16r5937 16r6C29 16r59E8 16r6C2A 16rF9DF 16r6C2B 16r5DF2 16r6C2C 16r5F1B 16r6C2D 16r5F5B 16r6C2E 16r6021 16r6C2F 16rF9E0 16r6C30 16rF9E1 16r6C31 16rF9E2 16r6C32 16rF9E3 16r6C33 16r723E 16r6C34 16r73E5 16r6C35 16rF9E4 16r6C36 16r7570 16r6C37 16r75CD 16r6C38 16rF9E5 16r6C39 16r79FB 16r6C3A 16rF9E6 16r6C3B 16r800C 16r6C3C 16r8033 16r6C3D 16r8084 16r6C3E 16r82E1 16r6C3F 16r8351 16r6C40 16rF9E7 16r6C41 16rF9E8 16r6C42 16r8CBD 16r6C43 16r8CB3 16r6C44 16r9087 16r6C45 16rF9E9 16r6C46 16rF9EA 16r6C47 16r98F4 16r6C48 16r990C 16r6C49 16rF9EB 16r6C4A 16rF9EC 16r6C4B 16r7037 16r6C4C 16r76CA 16r6C4D 16r7FCA 16r6C4E 16r7FCC 16r6C4F 16r7FFC 16r6C50 16r8B1A 16r6C51 16r4EBA 16r6C52 16r4EC1 16r6C53 16r5203 16r6C54 16r5370 16r6C55 16rF9ED 16r6C56 16r54BD 16r6C57 16r56E0 16r6C58 16r59FB 16r6C59 16r5BC5 16r6C5A 16r5F15 16r6C5B 16r5FCD 16r6C5C 16r6E6E 16r6C5D 16rF9EE 16r6C5E 16rF9EF 16r6C5F 16r7D6A 16r6C60 16r8335 16r6C61 16rF9F0 16r6C62 16r8693 16r6C63 16r8A8D 16r6C64 16rF9F1 16r6C65 16r976D 16r6C66 16r9777 16r6C67 16rF9F2 16r6C68 16rF9F3 16r6C69 16r4E00 16r6C6A 16r4F5A 16r6C6B 16r4F7E 16r6C6C 16r58F9 16r6C6D 16r65E5 16r6C6E 16r6EA2 16r6C6F 16r9038 16r6C70 16r93B0 16r6C71 16r99B9 16r6C72 16r4EFB 16r6C73 16r58EC 16r6C74 16r598A 16r6C75 16r59D9 16r6C76 16r6041 16r6C77 16rF9F4 16r6C78 16rF9F5 16r6C79 16r7A14 16r6C7A 16rF9F6 16r6C7B 16r834F 16r6C7C 16r8CC3 16r6C7D 16r5165 16r6C7E 16r5344 16r6D21 16rF9F7 16r6D22 16rF9F8 16r6D23 16rF9F9 16r6D24 16r4ECD 16r6D25 16r5269 16r6D26 16r5B55 16r6D27 16r82BF 16r6D28 16r4ED4 16r6D29 16r523A 16r6D2A 16r54A8 16r6D2B 16r59C9 16r6D2C 16r59FF 16r6D2D 16r5B50 16r6D2E 16r5B57 16r6D2F 16r5B5C 16r6D30 16r6063 16r6D31 16r6148 16r6D32 16r6ECB 16r6D33 16r7099 16r6D34 16r716E 16r6D35 16r7386 16r6D36 16r74F7 16r6D37 16r75B5 16r6D38 16r78C1 16r6D39 16r7D2B 16r6D3A 16r8005 16r6D3B 16r81EA 16r6D3C 16r8328 16r6D3D 16r8517 16r6D3E 16r85C9 16r6D3F 16r8AEE 16r6D40 16r8CC7 16r6D41 16r96CC 16r6D42 16r4F5C 16r6D43 16r52FA 16r6D44 16r56BC 16r6D45 16r65AB 16r6D46 16r6628 16r6D47 16r707C 16r6D48 16r70B8 16r6D49 16r7235 16r6D4A 16r7DBD 16r6D4B 16r828D 16r6D4C 16r914C 16r6D4D 16r96C0 16r6D4E 16r9D72 16r6D4F 16r5B71 16r6D50 16r68E7 16r6D51 16r6B98 16r6D52 16r6F7A 16r6D53 16r76DE 16r6D54 16r5C91 16r6D55 16r66AB 16r6D56 16r6F5B 16r6D57 16r7BB4 16r6D58 16r7C2A 16r6D59 16r8836 16r6D5A 16r96DC 16r6D5B 16r4E08 16r6D5C 16r4ED7 16r6D5D 16r5320 16r6D5E 16r5834 16r6D5F 16r58BB 16r6D60 16r58EF 16r6D61 16r596C 16r6D62 16r5C07 16r6D63 16r5E33 16r6D64 16r5E84 16r6D65 16r5F35 16r6D66 16r638C 16r6D67 16r66B2 16r6D68 16r6756 16r6D69 16r6A1F 16r6D6A 16r6AA3 16r6D6B 16r6B0C 16r6D6C 16r6F3F 16r6D6D 16r7246 16r6D6E 16rF9FA 16r6D6F 16r7350 16r6D70 16r748B 16r6D71 16r7AE0 16r6D72 16r7CA7 16r6D73 16r8178 16r6D74 16r81DF 16r6D75 16r81E7 16r6D76 16r838A 16r6D77 16r846C 16r6D78 16r8523 16r6D79 16r8594 16r6D7A 16r85CF 16r6D7B 16r88DD 16r6D7C 16r8D13 16r6D7D 16r91AC 16r6D7E 16r9577 16r6E21 16r969C 16r6E22 16r518D 16r6E23 16r54C9 16r6E24 16r5728 16r6E25 16r5BB0 16r6E26 16r624D 16r6E27 16r6750 16r6E28 16r683D 16r6E29 16r6893 16r6E2A 16r6E3D 16r6E2B 16r6ED3 16r6E2C 16r707D 16r6E2D 16r7E21 16r6E2E 16r88C1 16r6E2F 16r8CA1 16r6E30 16r8F09 16r6E31 16r9F4B 16r6E32 16r9F4E 16r6E33 16r722D 16r6E34 16r7B8F 16r6E35 16r8ACD 16r6E36 16r931A 16r6E37 16r4F47 16r6E38 16r4F4E 16r6E39 16r5132 16r6E3A 16r5480 16r6E3B 16r59D0 16r6E3C 16r5E95 16r6E3D 16r62B5 16r6E3E 16r6775 16r6E3F 16r696E 16r6E40 16r6A17 16r6E41 16r6CAE 16r6E42 16r6E1A 16r6E43 16r72D9 16r6E44 16r732A 16r6E45 16r75BD 16r6E46 16r7BB8 16r6E47 16r7D35 16r6E48 16r82E7 16r6E49 16r83F9 16r6E4A 16r8457 16r6E4B 16r85F7 16r6E4C 16r8A5B 16r6E4D 16r8CAF 16r6E4E 16r8E87 16r6E4F 16r9019 16r6E50 16r90B8 16r6E51 16r96CE 16r6E52 16r9F5F 16r6E53 16r52E3 16r6E54 16r540A 16r6E55 16r5AE1 16r6E56 16r5BC2 16r6E57 16r6458 16r6E58 16r6575 16r6E59 16r6EF4 16r6E5A 16r72C4 16r6E5B 16rF9FB 16r6E5C 16r7684 16r6E5D 16r7A4D 16r6E5E 16r7B1B 16r6E5F 16r7C4D 16r6E60 16r7E3E 16r6E61 16r7FDF 16r6E62 16r837B 16r6E63 16r8B2B 16r6E64 16r8CCA 16r6E65 16r8D64 16r6E66 16r8DE1 16r6E67 16r8E5F 16r6E68 16r8FEA 16r6E69 16r8FF9 16r6E6A 16r9069 16r6E6B 16r93D1 16r6E6C 16r4F43 16r6E6D 16r4F7A 16r6E6E 16r50B3 16r6E6F 16r5168 16r6E70 16r5178 16r6E71 16r524D 16r6E72 16r526A 16r6E73 16r5861 16r6E74 16r587C 16r6E75 16r5960 16r6E76 16r5C08 16r6E77 16r5C55 16r6E78 16r5EDB 16r6E79 16r609B 16r6E7A 16r6230 16r6E7B 16r6813 16r6E7C 16r6BBF 16r6E7D 16r6C08 16r6E7E 16r6FB1 16r6F21 16r714E 16r6F22 16r7420 16r6F23 16r7530 16r6F24 16r7538 16r6F25 16r7551 16r6F26 16r7672 16r6F27 16r7B4C 16r6F28 16r7B8B 16r6F29 16r7BAD 16r6F2A 16r7BC6 16r6F2B 16r7E8F 16r6F2C 16r8A6E 16r6F2D 16r8F3E 16r6F2E 16r8F49 16r6F2F 16r923F 16r6F30 16r9293 16r6F31 16r9322 16r6F32 16r942B 16r6F33 16r96FB 16r6F34 16r985A 16r6F35 16r986B 16r6F36 16r991E 16r6F37 16r5207 16r6F38 16r622A 16r6F39 16r6298 16r6F3A 16r6D59 16r6F3B 16r7664 16r6F3C 16r7ACA 16r6F3D 16r7BC0 16r6F3E 16r7D76 16r6F3F 16r5360 16r6F40 16r5CBE 16r6F41 16r5E97 16r6F42 16r6F38 16r6F43 16r70B9 16r6F44 16r7C98 16r6F45 16r9711 16r6F46 16r9B8E 16r6F47 16r9EDE 16r6F48 16r63A5 16r6F49 16r647A 16r6F4A 16r8776 16r6F4B 16r4E01 16r6F4C 16r4E95 16r6F4D 16r4EAD 16r6F4E 16r505C 16r6F4F 16r5075 16r6F50 16r5448 16r6F51 16r59C3 16r6F52 16r5B9A 16r6F53 16r5E40 16r6F54 16r5EAD 16r6F55 16r5EF7 16r6F56 16r5F81 16r6F57 16r60C5 16r6F58 16r633A 16r6F59 16r653F 16r6F5A 16r6574 16r6F5B 16r65CC 16r6F5C 16r6676 16r6F5D 16r6678 16r6F5E 16r67FE 16r6F5F 16r6968 16r6F60 16r6A89 16r6F61 16r6B63 16r6F62 16r6C40 16r6F63 16r6DC0 16r6F64 16r6DE8 16r6F65 16r6E1F 16r6F66 16r6E5E 16r6F67 16r701E 16r6F68 16r70A1 16r6F69 16r738E 16r6F6A 16r73FD 16r6F6B 16r753A 16r6F6C 16r775B 16r6F6D 16r7887 16r6F6E 16r798E 16r6F6F 16r7A0B 16r6F70 16r7A7D 16r6F71 16r7CBE 16r6F72 16r7D8E 16r6F73 16r8247 16r6F74 16r8A02 16r6F75 16r8AEA 16r6F76 16r8C9E 16r6F77 16r912D 16r6F78 16r914A 16r6F79 16r91D8 16r6F7A 16r9266 16r6F7B 16r92CC 16r6F7C 16r9320 16r6F7D 16r9706 16r6F7E 16r9756 16r7021 16r975C 16r7022 16r9802 16r7023 16r9F0E 16r7024 16r5236 16r7025 16r5291 16r7026 16r557C 16r7027 16r5824 16r7028 16r5E1D 16r7029 16r5F1F 16r702A 16r608C 16r702B 16r63D0 16r702C 16r68AF 16r702D 16r6FDF 16r702E 16r796D 16r702F 16r7B2C 16r7030 16r81CD 16r7031 16r85BA 16r7032 16r88FD 16r7033 16r8AF8 16r7034 16r8E44 16r7035 16r918D 16r7036 16r9664 16r7037 16r969B 16r7038 16r973D 16r7039 16r984C 16r703A 16r9F4A 16r703B 16r4FCE 16r703C 16r5146 16r703D 16r51CB 16r703E 16r52A9 16r703F 16r5632 16r7040 16r5F14 16r7041 16r5F6B 16r7042 16r63AA 16r7043 16r64CD 16r7044 16r65E9 16r7045 16r6641 16r7046 16r66FA 16r7047 16r66F9 16r7048 16r671D 16r7049 16r689D 16r704A 16r68D7 16r704B 16r69FD 16r704C 16r6F15 16r704D 16r6F6E 16r704E 16r7167 16r704F 16r71E5 16r7050 16r722A 16r7051 16r74AA 16r7052 16r773A 16r7053 16r7956 16r7054 16r795A 16r7055 16r79DF 16r7056 16r7A20 16r7057 16r7A95 16r7058 16r7C97 16r7059 16r7CDF 16r705A 16r7D44 16r705B 16r7E70 16r705C 16r8087 16r705D 16r85FB 16r705E 16r86A4 16r705F 16r8A54 16r7060 16r8ABF 16r7061 16r8D99 16r7062 16r8E81 16r7063 16r9020 16r7064 16r906D 16r7065 16r91E3 16r7066 16r963B 16r7067 16r96D5 16r7068 16r9CE5 16r7069 16r65CF 16r706A 16r7C07 16r706B 16r8DB3 16r706C 16r93C3 16r706D 16r5B58 16r706E 16r5C0A 16r706F 16r5352 16r7070 16r62D9 16r7071 16r731D 16r7072 16r5027 16r7073 16r5B97 16r7074 16r5F9E 16r7075 16r60B0 16r7076 16r616B 16r7077 16r68D5 16r7078 16r6DD9 16r7079 16r742E 16r707A 16r7A2E 16r707B 16r7D42 16r707C 16r7D9C 16r707D 16r7E31 16r707E 16r816B 16r7121 16r8E2A 16r7122 16r8E35 16r7123 16r937E 16r7124 16r9418 16r7125 16r4F50 16r7126 16r5750 16r7127 16r5DE6 16r7128 16r5EA7 16r7129 16r632B 16r712A 16r7F6A 16r712B 16r4E3B 16r712C 16r4F4F 16r712D 16r4F8F 16r712E 16r505A 16r712F 16r59DD 16r7130 16r80C4 16r7131 16r546A 16r7132 16r5468 16r7133 16r55FE 16r7134 16r594F 16r7135 16r5B99 16r7136 16r5DDE 16r7137 16r5EDA 16r7138 16r665D 16r7139 16r6731 16r713A 16r67F1 16r713B 16r682A 16r713C 16r6CE8 16r713D 16r6D32 16r713E 16r6E4A 16r713F 16r6F8D 16r7140 16r70B7 16r7141 16r73E0 16r7142 16r7587 16r7143 16r7C4C 16r7144 16r7D02 16r7145 16r7D2C 16r7146 16r7DA2 16r7147 16r821F 16r7148 16r86DB 16r7149 16r8A3B 16r714A 16r8A85 16r714B 16r8D70 16r714C 16r8E8A 16r714D 16r8F33 16r714E 16r9031 16r714F 16r914E 16r7150 16r9152 16r7151 16r9444 16r7152 16r99D0 16r7153 16r7AF9 16r7154 16r7CA5 16r7155 16r4FCA 16r7156 16r5101 16r7157 16r51C6 16r7158 16r57C8 16r7159 16r5BEF 16r715A 16r5CFB 16r715B 16r6659 16r715C 16r6A3D 16r715D 16r6D5A 16r715E 16r6E96 16r715F 16r6FEC 16r7160 16r710C 16r7161 16r756F 16r7162 16r7AE3 16r7163 16r8822 16r7164 16r9021 16r7165 16r9075 16r7166 16r96CB 16r7167 16r99FF 16r7168 16r8301 16r7169 16r4E2D 16r716A 16r4EF2 16r716B 16r8846 16r716C 16r91CD 16r716D 16r537D 16r716E 16r6ADB 16r716F 16r696B 16r7170 16r6C41 16r7171 16r847A 16r7172 16r589E 16r7173 16r618E 16r7174 16r66FE 16r7175 16r62EF 16r7176 16r70DD 16r7177 16r7511 16r7178 16r75C7 16r7179 16r7E52 16r717A 16r84B8 16r717B 16r8B49 16r717C 16r8D08 16r717D 16r4E4B 16r717E 16r53EA 16r7221 16r54AB 16r7222 16r5730 16r7223 16r5740 16r7224 16r5FD7 16r7225 16r6301 16r7226 16r6307 16r7227 16r646F 16r7228 16r652F 16r7229 16r65E8 16r722A 16r667A 16r722B 16r679D 16r722C 16r67B3 16r722D 16r6B62 16r722E 16r6C60 16r722F 16r6C9A 16r7230 16r6F2C 16r7231 16r77E5 16r7232 16r7825 16r7233 16r7949 16r7234 16r7957 16r7235 16r7D19 16r7236 16r80A2 16r7237 16r8102 16r7238 16r81F3 16r7239 16r829D 16r723A 16r82B7 16r723B 16r8718 16r723C 16r8A8C 16r723D 16rF9FC 16r723E 16r8D04 16r723F 16r8DBE 16r7240 16r9072 16r7241 16r76F4 16r7242 16r7A19 16r7243 16r7A37 16r7244 16r7E54 16r7245 16r8077 16r7246 16r5507 16r7247 16r55D4 16r7248 16r5875 16r7249 16r632F 16r724A 16r6422 16r724B 16r6649 16r724C 16r664B 16r724D 16r686D 16r724E 16r699B 16r724F 16r6B84 16r7250 16r6D25 16r7251 16r6EB1 16r7252 16r73CD 16r7253 16r7468 16r7254 16r74A1 16r7255 16r755B 16r7256 16r75B9 16r7257 16r76E1 16r7258 16r771E 16r7259 16r778B 16r725A 16r79E6 16r725B 16r7E09 16r725C 16r7E1D 16r725D 16r81FB 16r725E 16r852F 16r725F 16r8897 16r7260 16r8A3A 16r7261 16r8CD1 16r7262 16r8EEB 16r7263 16r8FB0 16r7264 16r9032 16r7265 16r93AD 16r7266 16r9663 16r7267 16r9673 16r7268 16r9707 16r7269 16r4F84 16r726A 16r53F1 16r726B 16r59EA 16r726C 16r5AC9 16r726D 16r5E19 16r726E 16r684E 16r726F 16r74C6 16r7270 16r75BE 16r7271 16r79E9 16r7272 16r7A92 16r7273 16r81A3 16r7274 16r86ED 16r7275 16r8CEA 16r7276 16r8DCC 16r7277 16r8FED 16r7278 16r659F 16r7279 16r6715 16r727A 16rF9FD 16r727B 16r57F7 16r727C 16r6F57 16r727D 16r7DDD 16r727E 16r8F2F 16r7321 16r93F6 16r7322 16r96C6 16r7323 16r5FB5 16r7324 16r61F2 16r7325 16r6F84 16r7326 16r4E14 16r7327 16r4F98 16r7328 16r501F 16r7329 16r53C9 16r732A 16r55DF 16r732B 16r5D6F 16r732C 16r5DEE 16r732D 16r6B21 16r732E 16r6B64 16r732F 16r78CB 16r7330 16r7B9A 16r7331 16rF9FE 16r7332 16r8E49 16r7333 16r8ECA 16r7334 16r906E 16r7335 16r6349 16r7336 16r643E 16r7337 16r7740 16r7338 16r7A84 16r7339 16r932F 16r733A 16r947F 16r733B 16r9F6A 16r733C 16r64B0 16r733D 16r6FAF 16r733E 16r71E6 16r733F 16r74A8 16r7340 16r74DA 16r7341 16r7AC4 16r7342 16r7C12 16r7343 16r7E82 16r7344 16r7CB2 16r7345 16r7E98 16r7346 16r8B9A 16r7347 16r8D0A 16r7348 16r947D 16r7349 16r9910 16r734A 16r994C 16r734B 16r5239 16r734C 16r5BDF 16r734D 16r64E6 16r734E 16r672D 16r734F 16r7D2E 16r7350 16r50ED 16r7351 16r53C3 16r7352 16r5879 16r7353 16r6158 16r7354 16r6159 16r7355 16r61FA 16r7356 16r65AC 16r7357 16r7AD9 16r7358 16r8B92 16r7359 16r8B96 16r735A 16r5009 16r735B 16r5021 16r735C 16r5275 16r735D 16r5531 16r735E 16r5A3C 16r735F 16r5EE0 16r7360 16r5F70 16r7361 16r6134 16r7362 16r655E 16r7363 16r660C 16r7364 16r6636 16r7365 16r66A2 16r7366 16r69CD 16r7367 16r6EC4 16r7368 16r6F32 16r7369 16r7316 16r736A 16r7621 16r736B 16r7A93 16r736C 16r8139 16r736D 16r8259 16r736E 16r83D6 16r736F 16r84BC 16r7370 16r50B5 16r7371 16r57F0 16r7372 16r5BC0 16r7373 16r5BE8 16r7374 16r5F69 16r7375 16r63A1 16r7376 16r7826 16r7377 16r7DB5 16r7378 16r83DC 16r7379 16r8521 16r737A 16r91C7 16r737B 16r91F5 16r737C 16r518A 16r737D 16r67F5 16r737E 16r7B56 16r7421 16r8CAC 16r7422 16r51C4 16r7423 16r59BB 16r7424 16r60BD 16r7425 16r8655 16r7426 16r501C 16r7427 16rF9FF 16r7428 16r5254 16r7429 16r5C3A 16r742A 16r617D 16r742B 16r621A 16r742C 16r62D3 16r742D 16r64F2 16r742E 16r65A5 16r742F 16r6ECC 16r7430 16r7620 16r7431 16r810A 16r7432 16r8E60 16r7433 16r965F 16r7434 16r96BB 16r7435 16r4EDF 16r7436 16r5343 16r7437 16r5598 16r7438 16r5929 16r7439 16r5DDD 16r743A 16r64C5 16r743B 16r6CC9 16r743C 16r6DFA 16r743D 16r7394 16r743E 16r7A7F 16r743F 16r821B 16r7440 16r85A6 16r7441 16r8CE4 16r7442 16r8E10 16r7443 16r9077 16r7444 16r91E7 16r7445 16r95E1 16r7446 16r9621 16r7447 16r97C6 16r7448 16r51F8 16r7449 16r54F2 16r744A 16r5586 16r744B 16r5FB9 16r744C 16r64A4 16r744D 16r6F88 16r744E 16r7DB4 16r744F 16r8F1F 16r7450 16r8F4D 16r7451 16r9435 16r7452 16r50C9 16r7453 16r5C16 16r7454 16r6CBE 16r7455 16r6DFB 16r7456 16r751B 16r7457 16r77BB 16r7458 16r7C3D 16r7459 16r7C64 16r745A 16r8A79 16r745B 16r8AC2 16r745C 16r581E 16r745D 16r59BE 16r745E 16r5E16 16r745F 16r6377 16r7460 16r7252 16r7461 16r758A 16r7462 16r776B 16r7463 16r8ADC 16r7464 16r8CBC 16r7465 16r8F12 16r7466 16r5EF3 16r7467 16r6674 16r7468 16r6DF8 16r7469 16r807D 16r746A 16r83C1 16r746B 16r8ACB 16r746C 16r9751 16r746D 16r9BD6 16r746E 16rFA00 16r746F 16r5243 16r7470 16r66FF 16r7471 16r6D95 16r7472 16r6EEF 16r7473 16r7DE0 16r7474 16r8AE6 16r7475 16r902E 16r7476 16r905E 16r7477 16r9AD4 16r7478 16r521D 16r7479 16r527F 16r747A 16r54E8 16r747B 16r6194 16r747C 16r6284 16r747D 16r62DB 16r747E 16r68A2 16r7521 16r6912 16r7522 16r695A 16r7523 16r6A35 16r7524 16r7092 16r7525 16r7126 16r7526 16r785D 16r7527 16r7901 16r7528 16r790E 16r7529 16r79D2 16r752A 16r7A0D 16r752B 16r8096 16r752C 16r8278 16r752D 16r82D5 16r752E 16r8349 16r752F 16r8549 16r7530 16r8C82 16r7531 16r8D85 16r7532 16r9162 16r7533 16r918B 16r7534 16r91AE 16r7535 16r4FC3 16r7536 16r56D1 16r7537 16r71ED 16r7538 16r77D7 16r7539 16r8700 16r753A 16r89F8 16r753B 16r5BF8 16r753C 16r5FD6 16r753D 16r6751 16r753E 16r90A8 16r753F 16r53E2 16r7540 16r585A 16r7541 16r5BF5 16r7542 16r60A4 16r7543 16r6181 16r7544 16r6460 16r7545 16r7E3D 16r7546 16r8070 16r7547 16r8525 16r7548 16r9283 16r7549 16r64AE 16r754A 16r50AC 16r754B 16r5D14 16r754C 16r6700 16r754D 16r589C 16r754E 16r62BD 16r754F 16r63A8 16r7550 16r690E 16r7551 16r6978 16r7552 16r6A1E 16r7553 16r6E6B 16r7554 16r76BA 16r7555 16r79CB 16r7556 16r82BB 16r7557 16r8429 16r7558 16r8ACF 16r7559 16r8DA8 16r755A 16r8FFD 16r755B 16r9112 16r755C 16r914B 16r755D 16r919C 16r755E 16r9310 16r755F 16r9318 16r7560 16r939A 16r7561 16r96DB 16r7562 16r9A36 16r7563 16r9C0D 16r7564 16r4E11 16r7565 16r755C 16r7566 16r795D 16r7567 16r7AFA 16r7568 16r7B51 16r7569 16r7BC9 16r756A 16r7E2E 16r756B 16r84C4 16r756C 16r8E59 16r756D 16r8E74 16r756E 16r8EF8 16r756F 16r9010 16r7570 16r6625 16r7571 16r693F 16r7572 16r7443 16r7573 16r51FA 16r7574 16r672E 16r7575 16r9EDC 16r7576 16r5145 16r7577 16r5FE0 16r7578 16r6C96 16r7579 16r87F2 16r757A 16r885D 16r757B 16r8877 16r757C 16r60B4 16r757D 16r81B5 16r757E 16r8403 16r7621 16r8D05 16r7622 16r53D6 16r7623 16r5439 16r7624 16r5634 16r7625 16r5A36 16r7626 16r5C31 16r7627 16r708A 16r7628 16r7FE0 16r7629 16r805A 16r762A 16r8106 16r762B 16r81ED 16r762C 16r8DA3 16r762D 16r9189 16r762E 16r9A5F 16r762F 16r9DF2 16r7630 16r5074 16r7631 16r4EC4 16r7632 16r53A0 16r7633 16r60FB 16r7634 16r6E2C 16r7635 16r5C64 16r7636 16r4F88 16r7637 16r5024 16r7638 16r55E4 16r7639 16r5CD9 16r763A 16r5E5F 16r763B 16r6065 16r763C 16r6894 16r763D 16r6CBB 16r763E 16r6DC4 16r763F 16r71BE 16r7640 16r75D4 16r7641 16r75F4 16r7642 16r7661 16r7643 16r7A1A 16r7644 16r7A49 16r7645 16r7DC7 16r7646 16r7DFB 16r7647 16r7F6E 16r7648 16r81F4 16r7649 16r86A9 16r764A 16r8F1C 16r764B 16r96C9 16r764C 16r99B3 16r764D 16r9F52 16r764E 16r5247 16r764F 16r52C5 16r7650 16r98ED 16r7651 16r89AA 16r7652 16r4E03 16r7653 16r67D2 16r7654 16r6F06 16r7655 16r4FB5 16r7656 16r5BE2 16r7657 16r6795 16r7658 16r6C88 16r7659 16r6D78 16r765A 16r741B 16r765B 16r7827 16r765C 16r91DD 16r765D 16r937C 16r765E 16r87C4 16r765F 16r79E4 16r7660 16r7A31 16r7661 16r5FEB 16r7662 16r4ED6 16r7663 16r54A4 16r7664 16r553E 16r7665 16r58AE 16r7666 16r59A5 16r7667 16r60F0 16r7668 16r6253 16r7669 16r62D6 16r766A 16r6736 16r766B 16r6955 16r766C 16r8235 16r766D 16r9640 16r766E 16r99B1 16r766F 16r99DD 16r7670 16r502C 16r7671 16r5353 16r7672 16r5544 16r7673 16r577C 16r7674 16rFA01 16r7675 16r6258 16r7676 16rFA02 16r7677 16r64E2 16r7678 16r666B 16r7679 16r67DD 16r767A 16r6FC1 16r767B 16r6FEF 16r767C 16r7422 16r767D 16r7438 16r767E 16r8A17 16r7721 16r9438 16r7722 16r5451 16r7723 16r5606 16r7724 16r5766 16r7725 16r5F48 16r7726 16r619A 16r7727 16r6B4E 16r7728 16r7058 16r7729 16r70AD 16r772A 16r7DBB 16r772B 16r8A95 16r772C 16r596A 16r772D 16r812B 16r772E 16r63A2 16r772F 16r7708 16r7730 16r803D 16r7731 16r8CAA 16r7732 16r5854 16r7733 16r642D 16r7734 16r69BB 16r7735 16r5B95 16r7736 16r5E11 16r7737 16r6E6F 16r7738 16rFA03 16r7739 16r8569 16r773A 16r514C 16r773B 16r53F0 16r773C 16r592A 16r773D 16r6020 16r773E 16r614B 16r773F 16r6B86 16r7740 16r6C70 16r7741 16r6CF0 16r7742 16r7B1E 16r7743 16r80CE 16r7744 16r82D4 16r7745 16r8DC6 16r7746 16r90B0 16r7747 16r98B1 16r7748 16rFA04 16r7749 16r64C7 16r774A 16r6FA4 16r774B 16r6491 16r774C 16r6504 16r774D 16r514E 16r774E 16r5410 16r774F 16r571F 16r7750 16r8A0E 16r7751 16r615F 16r7752 16r6876 16r7753 16rFA05 16r7754 16r75DB 16r7755 16r7B52 16r7756 16r7D71 16r7757 16r901A 16r7758 16r5806 16r7759 16r69CC 16r775A 16r817F 16r775B 16r892A 16r775C 16r9000 16r775D 16r9839 16r775E 16r5078 16r775F 16r5957 16r7760 16r59AC 16r7761 16r6295 16r7762 16r900F 16r7763 16r9B2A 16r7764 16r615D 16r7765 16r7279 16r7766 16r95D6 16r7767 16r5761 16r7768 16r5A46 16r7769 16r5DF4 16r776A 16r628A 16r776B 16r64AD 16r776C 16r64FA 16r776D 16r6777 16r776E 16r6CE2 16r776F 16r6D3E 16r7770 16r722C 16r7771 16r7436 16r7772 16r7834 16r7773 16r7F77 16r7774 16r82AD 16r7775 16r8DDB 16r7776 16r9817 16r7777 16r5224 16r7778 16r5742 16r7779 16r677F 16r777A 16r7248 16r777B 16r74E3 16r777C 16r8CA9 16r777D 16r8FA6 16r777E 16r9211 16r7821 16r962A 16r7822 16r516B 16r7823 16r53ED 16r7824 16r634C 16r7825 16r4F69 16r7826 16r5504 16r7827 16r6096 16r7828 16r6557 16r7829 16r6C9B 16r782A 16r6D7F 16r782B 16r724C 16r782C 16r72FD 16r782D 16r7A17 16r782E 16r8987 16r782F 16r8C9D 16r7830 16r5F6D 16r7831 16r6F8E 16r7832 16r70F9 16r7833 16r81A8 16r7834 16r610E 16r7835 16r4FBF 16r7836 16r504F 16r7837 16r6241 16r7838 16r7247 16r7839 16r7BC7 16r783A 16r7DE8 16r783B 16r7FE9 16r783C 16r904D 16r783D 16r97AD 16r783E 16r9A19 16r783F 16r8CB6 16r7840 16r576A 16r7841 16r5E73 16r7842 16r67B0 16r7843 16r840D 16r7844 16r8A55 16r7845 16r5420 16r7846 16r5B16 16r7847 16r5E63 16r7848 16r5EE2 16r7849 16r5F0A 16r784A 16r6583 16r784B 16r80BA 16r784C 16r853D 16r784D 16r9589 16r784E 16r965B 16r784F 16r4F48 16r7850 16r5305 16r7851 16r530D 16r7852 16r530F 16r7853 16r5486 16r7854 16r54FA 16r7855 16r5703 16r7856 16r5E03 16r7857 16r6016 16r7858 16r629B 16r7859 16r62B1 16r785A 16r6355 16r785B 16rFA06 16r785C 16r6CE1 16r785D 16r6D66 16r785E 16r75B1 16r785F 16r7832 16r7860 16r80DE 16r7861 16r812F 16r7862 16r82DE 16r7863 16r8461 16r7864 16r84B2 16r7865 16r888D 16r7866 16r8912 16r7867 16r900B 16r7868 16r92EA 16r7869 16r98FD 16r786A 16r9B91 16r786B 16r5E45 16r786C 16r66B4 16r786D 16r66DD 16r786E 16r7011 16r786F 16r7206 16r7870 16rFA07 16r7871 16r4FF5 16r7872 16r527D 16r7873 16r5F6A 16r7874 16r6153 16r7875 16r6753 16r7876 16r6A19 16r7877 16r6F02 16r7878 16r74E2 16r7879 16r7968 16r787A 16r8868 16r787B 16r8C79 16r787C 16r98C7 16r787D 16r98C4 16r787E 16r9A43 16r7921 16r54C1 16r7922 16r7A1F 16r7923 16r6953 16r7924 16r8AF7 16r7925 16r8C4A 16r7926 16r98A8 16r7927 16r99AE 16r7928 16r5F7C 16r7929 16r62AB 16r792A 16r75B2 16r792B 16r76AE 16r792C 16r88AB 16r792D 16r907F 16r792E 16r9642 16r792F 16r5339 16r7930 16r5F3C 16r7931 16r5FC5 16r7932 16r6CCC 16r7933 16r73CC 16r7934 16r7562 16r7935 16r758B 16r7936 16r7B46 16r7937 16r82FE 16r7938 16r999D 16r7939 16r4E4F 16r793A 16r903C 16r793B 16r4E0B 16r793C 16r4F55 16r793D 16r53A6 16r793E 16r590F 16r793F 16r5EC8 16r7940 16r6630 16r7941 16r6CB3 16r7942 16r7455 16r7943 16r8377 16r7944 16r8766 16r7945 16r8CC0 16r7946 16r9050 16r7947 16r971E 16r7948 16r9C15 16r7949 16r58D1 16r794A 16r5B78 16r794B 16r8650 16r794C 16r8B14 16r794D 16r9DB4 16r794E 16r5BD2 16r794F 16r6068 16r7950 16r608D 16r7951 16r65F1 16r7952 16r6C57 16r7953 16r6F22 16r7954 16r6FA3 16r7955 16r701A 16r7956 16r7F55 16r7957 16r7FF0 16r7958 16r9591 16r7959 16r9592 16r795A 16r9650 16r795B 16r97D3 16r795C 16r5272 16r795D 16r8F44 16r795E 16r51FD 16r795F 16r542B 16r7960 16r54B8 16r7961 16r5563 16r7962 16r558A 16r7963 16r6ABB 16r7964 16r6DB5 16r7965 16r7DD8 16r7966 16r8266 16r7967 16r929C 16r7968 16r9677 16r7969 16r9E79 16r796A 16r5408 16r796B 16r54C8 16r796C 16r76D2 16r796D 16r86E4 16r796E 16r95A4 16r796F 16r95D4 16r7970 16r965C 16r7971 16r4EA2 16r7972 16r4F09 16r7973 16r59EE 16r7974 16r5AE6 16r7975 16r5DF7 16r7976 16r6052 16r7977 16r6297 16r7978 16r676D 16r7979 16r6841 16r797A 16r6C86 16r797B 16r6E2F 16r797C 16r7F38 16r797D 16r809B 16r797E 16r822A 16r7A21 16rFA08 16r7A22 16rFA09 16r7A23 16r9805 16r7A24 16r4EA5 16r7A25 16r5055 16r7A26 16r54B3 16r7A27 16r5793 16r7A28 16r595A 16r7A29 16r5B69 16r7A2A 16r5BB3 16r7A2B 16r61C8 16r7A2C 16r6977 16r7A2D 16r6D77 16r7A2E 16r7023 16r7A2F 16r87F9 16r7A30 16r89E3 16r7A31 16r8A72 16r7A32 16r8AE7 16r7A33 16r9082 16r7A34 16r99ED 16r7A35 16r9AB8 16r7A36 16r52BE 16r7A37 16r6838 16r7A38 16r5016 16r7A39 16r5E78 16r7A3A 16r674F 16r7A3B 16r8347 16r7A3C 16r884C 16r7A3D 16r4EAB 16r7A3E 16r5411 16r7A3F 16r56AE 16r7A40 16r73E6 16r7A41 16r9115 16r7A42 16r97FF 16r7A43 16r9909 16r7A44 16r9957 16r7A45 16r9999 16r7A46 16r5653 16r7A47 16r589F 16r7A48 16r865B 16r7A49 16r8A31 16r7A4A 16r61B2 16r7A4B 16r6AF6 16r7A4C 16r737B 16r7A4D 16r8ED2 16r7A4E 16r6B47 16r7A4F 16r96AA 16r7A50 16r9A57 16r7A51 16r5955 16r7A52 16r7200 16r7A53 16r8D6B 16r7A54 16r9769 16r7A55 16r4FD4 16r7A56 16r5CF4 16r7A57 16r5F26 16r7A58 16r61F8 16r7A59 16r665B 16r7A5A 16r6CEB 16r7A5B 16r70AB 16r7A5C 16r7384 16r7A5D 16r73B9 16r7A5E 16r73FE 16r7A5F 16r7729 16r7A60 16r774D 16r7A61 16r7D43 16r7A62 16r7D62 16r7A63 16r7E23 16r7A64 16r8237 16r7A65 16r8852 16r7A66 16rFA0A 16r7A67 16r8CE2 16r7A68 16r9249 16r7A69 16r986F 16r7A6A 16r5B51 16r7A6B 16r7A74 16r7A6C 16r8840 16r7A6D 16r9801 16r7A6E 16r5ACC 16r7A6F 16r4FE0 16r7A70 16r5354 16r7A71 16r593E 16r7A72 16r5CFD 16r7A73 16r633E 16r7A74 16r6D79 16r7A75 16r72F9 16r7A76 16r8105 16r7A77 16r8107 16r7A78 16r83A2 16r7A79 16r92CF 16r7A7A 16r9830 16r7A7B 16r4EA8 16r7A7C 16r5144 16r7A7D 16r5211 16r7A7E 16r578B 16r7B21 16r5F62 16r7B22 16r6CC2 16r7B23 16r6ECE 16r7B24 16r7005 16r7B25 16r7050 16r7B26 16r70AF 16r7B27 16r7192 16r7B28 16r73E9 16r7B29 16r7469 16r7B2A 16r834A 16r7B2B 16r87A2 16r7B2C 16r8861 16r7B2D 16r9008 16r7B2E 16r90A2 16r7B2F 16r93A3 16r7B30 16r99A8 16r7B31 16r516E 16r7B32 16r5F57 16r7B33 16r60E0 16r7B34 16r6167 16r7B35 16r66B3 16r7B36 16r8559 16r7B37 16r8E4A 16r7B38 16r91AF 16r7B39 16r978B 16r7B3A 16r4E4E 16r7B3B 16r4E92 16r7B3C 16r547C 16r7B3D 16r58D5 16r7B3E 16r58FA 16r7B3F 16r597D 16r7B40 16r5CB5 16r7B41 16r5F27 16r7B42 16r6236 16r7B43 16r6248 16r7B44 16r660A 16r7B45 16r6667 16r7B46 16r6BEB 16r7B47 16r6D69 16r7B48 16r6DCF 16r7B49 16r6E56 16r7B4A 16r6EF8 16r7B4B 16r6F94 16r7B4C 16r6FE0 16r7B4D 16r6FE9 16r7B4E 16r705D 16r7B4F 16r72D0 16r7B50 16r7425 16r7B51 16r745A 16r7B52 16r74E0 16r7B53 16r7693 16r7B54 16r795C 16r7B55 16r7CCA 16r7B56 16r7E1E 16r7B57 16r80E1 16r7B58 16r82A6 16r7B59 16r846B 16r7B5A 16r84BF 16r7B5B 16r864E 16r7B5C 16r865F 16r7B5D 16r8774 16r7B5E 16r8B77 16r7B5F 16r8C6A 16r7B60 16r93AC 16r7B61 16r9800 16r7B62 16r9865 16r7B63 16r60D1 16r7B64 16r6216 16r7B65 16r9177 16r7B66 16r5A5A 16r7B67 16r660F 16r7B68 16r6DF7 16r7B69 16r6E3E 16r7B6A 16r743F 16r7B6B 16r9B42 16r7B6C 16r5FFD 16r7B6D 16r60DA 16r7B6E 16r7B0F 16r7B6F 16r54C4 16r7B70 16r5F18 16r7B71 16r6C5E 16r7B72 16r6CD3 16r7B73 16r6D2A 16r7B74 16r70D8 16r7B75 16r7D05 16r7B76 16r8679 16r7B77 16r8A0C 16r7B78 16r9D3B 16r7B79 16r5316 16r7B7A 16r548C 16r7B7B 16r5B05 16r7B7C 16r6A3A 16r7B7D 16r706B 16r7B7E 16r7575 16r7C21 16r798D 16r7C22 16r79BE 16r7C23 16r82B1 16r7C24 16r83EF 16r7C25 16r8A71 16r7C26 16r8B41 16r7C27 16r8CA8 16r7C28 16r9774 16r7C29 16rFA0B 16r7C2A 16r64F4 16r7C2B 16r652B 16r7C2C 16r78BA 16r7C2D 16r78BB 16r7C2E 16r7A6B 16r7C2F 16r4E38 16r7C30 16r559A 16r7C31 16r5950 16r7C32 16r5BA6 16r7C33 16r5E7B 16r7C34 16r60A3 16r7C35 16r63DB 16r7C36 16r6B61 16r7C37 16r6665 16r7C38 16r6853 16r7C39 16r6E19 16r7C3A 16r7165 16r7C3B 16r74B0 16r7C3C 16r7D08 16r7C3D 16r9084 16r7C3E 16r9A69 16r7C3F 16r9C25 16r7C40 16r6D3B 16r7C41 16r6ED1 16r7C42 16r733E 16r7C43 16r8C41 16r7C44 16r95CA 16r7C45 16r51F0 16r7C46 16r5E4C 16r7C47 16r5FA8 16r7C48 16r604D 16r7C49 16r60F6 16r7C4A 16r6130 16r7C4B 16r614C 16r7C4C 16r6643 16r7C4D 16r6644 16r7C4E 16r69A5 16r7C4F 16r6CC1 16r7C50 16r6E5F 16r7C51 16r6EC9 16r7C52 16r6F62 16r7C53 16r714C 16r7C54 16r749C 16r7C55 16r7687 16r7C56 16r7BC1 16r7C57 16r7C27 16r7C58 16r8352 16r7C59 16r8757 16r7C5A 16r9051 16r7C5B 16r968D 16r7C5C 16r9EC3 16r7C5D 16r532F 16r7C5E 16r56DE 16r7C5F 16r5EFB 16r7C60 16r5F8A 16r7C61 16r6062 16r7C62 16r6094 16r7C63 16r61F7 16r7C64 16r6666 16r7C65 16r6703 16r7C66 16r6A9C 16r7C67 16r6DEE 16r7C68 16r6FAE 16r7C69 16r7070 16r7C6A 16r736A 16r7C6B 16r7E6A 16r7C6C 16r81BE 16r7C6D 16r8334 16r7C6E 16r86D4 16r7C6F 16r8AA8 16r7C70 16r8CC4 16r7C71 16r5283 16r7C72 16r7372 16r7C73 16r5B96 16r7C74 16r6A6B 16r7C75 16r9404 16r7C76 16r54EE 16r7C77 16r5686 16r7C78 16r5B5D 16r7C79 16r6548 16r7C7A 16r6585 16r7C7B 16r66C9 16r7C7C 16r689F 16r7C7D 16r6D8D 16r7C7E 16r6DC6 16r7D21 16r723B 16r7D22 16r80B4 16r7D23 16r9175 16r7D24 16r9A4D 16r7D25 16r4FAF 16r7D26 16r5019 16r7D27 16r539A 16r7D28 16r540E 16r7D29 16r543C 16r7D2A 16r5589 16r7D2B 16r55C5 16r7D2C 16r5E3F 16r7D2D 16r5F8C 16r7D2E 16r673D 16r7D2F 16r7166 16r7D30 16r73DD 16r7D31 16r9005 16r7D32 16r52DB 16r7D33 16r52F3 16r7D34 16r5864 16r7D35 16r58CE 16r7D36 16r7104 16r7D37 16r718F 16r7D38 16r71FB 16r7D39 16r85B0 16r7D3A 16r8A13 16r7D3B 16r6688 16r7D3C 16r85A8 16r7D3D 16r55A7 16r7D3E 16r6684 16r7D3F 16r714A 16r7D40 16r8431 16r7D41 16r5349 16r7D42 16r5599 16r7D43 16r6BC1 16r7D44 16r5F59 16r7D45 16r5FBD 16r7D46 16r63EE 16r7D47 16r6689 16r7D48 16r7147 16r7D49 16r8AF1 16r7D4A 16r8F1D 16r7D4B 16r9EBE 16r7D4C 16r4F11 16r7D4D 16r643A 16r7D4E 16r70CB 16r7D4F 16r7566 16r7D50 16r8667 16r7D51 16r6064 16r7D52 16r8B4E 16r7D53 16r9DF8 16r7D54 16r5147 16r7D55 16r51F6 16r7D56 16r5308 16r7D57 16r6D36 16r7D58 16r80F8 16r7D59 16r9ED1 16r7D5A 16r6615 16r7D5B 16r6B23 16r7D5C 16r7098 16r7D5D 16r75D5 16r7D5E 16r5403 16r7D5F 16r5C79 16r7D60 16r7D07 16r7D61 16r8A16 16r7D62 16r6B20 16r7D63 16r6B3D 16r7D64 16r6B46 16r7D65 16r5438 16r7D66 16r6070 16r7D67 16r6D3D 16r7D68 16r7FD5 16r7D69 16r8208 16r7D6A 16r50D6 16r7D6B 16r51DE 16r7D6C 16r559C 16r7D6D 16r566B 16r7D6E 16r56CD 16r7D6F 16r59EC 16r7D70 16r5B09 16r7D71 16r5E0C 16r7D72 16r6199 16r7D73 16r6198 16r7D74 16r6231 16r7D75 16r665E 16r7D76 16r66E6 16r7D77 16r7199 16r7D78 16r71B9 16r7D79 16r71BA 16r7D7A 16r72A7 16r7D7B 16r79A7 16r7D7C 16r7A00 16r7D7D 16r7FB2 16r7D7E 16r8A70).
	table size even ifFalse: [^ self error: 'given table size must be even'].
	size _ table size / 2.
	ksX1001 _ Array new: size.
	unicode _ Array new: size.
	1 to: table size by: 2 do: [:index |
		| tableIndex |
		tableIndex _ index + 1 / 2.
		ksX1001 at: tableIndex put: (table at: index).
		unicode at: tableIndex put: (table at: index + 1)].
	ksX10012 _ Array new: 94*94 withAll: -1.
	ksX1001 withIndexDo: [:elem :index |
		code _ (elem // 256 - 33) * 94 + (elem \\ 256 - 33) + 1.
		(ksX10012 at: code) ~= -1 ifTrue: [self halt].
		uIndex _ ksX1001 indexOf: elem.
		uIndex = 0 ifFalse: [
			u _ unicode at: uIndex.
			ksX10012 at: code put: u.
		].
	].
	KSX1001Table _ ksX10012
! !

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:41'!
initializeLatin1Table
	"UCSTable initializeLatin1Table"

	Latin1Table _ (0 to: 255) asArray.
! !

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 09:38'!
jisx0208Table

	^ JISX0208Table.
! !

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:36'!
ksx1001Table

	^ KSX1001Table.
! !

!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:36'!
latin1Table

	^ Latin1Table.
! !
Object subclass: #UIManager
	instanceVariableNames: ''
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'ToolBuilder-Kernel'!
!UIManager commentStamp: 'ar 12/27/2004 08:39' prior: 0!
UIManager is a dispatcher for various UI requests.!


!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:35'!
chooseDirectory
	"Let the user choose a directory"
	^self chooseDirectoryFrom: FileDirectory default! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:36'!
chooseDirectoryFrom: dir
	"Let the user choose a directory"
	^self chooseDirectory: nil from: dir! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:36'!
chooseDirectory: label
	"Let the user choose a directory"
	^self chooseDirectory: label from: FileDirectory default! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:36'!
chooseDirectory: label from: dir
	"Let the user choose a directory"
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/17/2005 00:26'!
chooseFileMatching: patterns
	"Let the user choose a file matching the given patterns"
	^self chooseFileMatching: patterns label: nil! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/17/2005 00:26'!
chooseFileMatching: patterns label: labelString
	"Let the user choose a file matching the given patterns"
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 10:44'!
chooseFrom: aList
	"Choose an item from the given list. Answer the index of the selected item."
	^self chooseFrom: aList lines: #()! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 10:45'!
chooseFrom: aList lines: linesArray
	"Choose an item from the given list. Answer the index of the selected item."
	^self chooseFrom: aList lines: linesArray title: ''! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 09:37'!
chooseFrom: aList lines: linesArray title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 10:44'!
chooseFrom: aList title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	^self chooseFrom: aList lines: #() title: aString! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:42'!
chooseFrom: labelList values: valueList
	"Choose an item from the given list. Answer the selected item."
	^self chooseFrom: labelList values: valueList lines: #()! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:43'!
chooseFrom: labelList values: valueList lines: linesArray
	"Choose an item from the given list. Answer the selected item."
	^self chooseFrom: labelList values: valueList lines: linesArray title: ''! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:43'!
chooseFrom: labelList values: valueList lines: linesArray title: aString
	"Choose an item from the given list. Answer the selected item."
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:43'!
chooseFrom: labelList values: valueList title: aString
	"Choose an item from the given list. Answer the selected item."
	^self chooseFrom: labelList values: valueList lines: #() title: aString! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:39'!
confirm: queryString
	"Put up a yes/no menu with caption queryString. Answer true if the 
	response is yes, false if no. This is a modal question--the user must 
	respond yes or no."
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 09:49'!
confirm: aString orCancel: cancelBlock
	"Put up a yes/no/cancel menu with caption aString. Answer true if  
	the response is yes, false if no. If cancel is chosen, evaluate  
	cancelBlock. This is a modal question--the user must respond yes or no."
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:10'!
displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock
	"Display titleString as a caption over a progress bar while workBlock is evaluated."
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 18:56'!
edit: aText
	"Open an editor on the given string/text"
	^self edit: aText label: nil! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 18:56'!
edit: aText label: labelString
	"Open an editor on the given string/text"
	^self edit: aText label: labelString accept: nil! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 18:56'!
edit: aText label: labelString accept: anAction
	"Open an editor on the given string/text"
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:06'!
informUserDuring: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUserDuring:[:bar|
			#(one two three) do:[:info|
				bar value: info.
				(Delay forSeconds: 1) wait]]"
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 20:40'!
informUser: aString during: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait].
	"
	^self informUserDuring:[:bar| bar value: aString. aBlock value].! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:46'!
inform: aString
	"Display a message for the user to read and then dismiss"
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:05'!
multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight
	"Create a multi-line instance of me whose question is queryString with
	the given initial answer. Invoke it centered at the given point, and
	answer the string the user accepts.  Answer nil if the user cancels.  An
	empty string returned means that the ussr cleared the editing area and
	then hit 'accept'.  Because multiple lines are invited, we ask that the user
	use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 
	submit; that way, the return key can be typed to move to the next line."
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:47'!
requestPassword: queryString
	"Create an instance of me whose question is queryString. Invoke it centered
	at the cursor, and answer the string the user accepts. Answer the empty 
	string if the user cancels."
	^self subclassResponsibility! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:41'!
request: queryString 
	"Create an instance of me whose question is queryString. Invoke it 
	centered at the cursor, and answer the string the user accepts. Answer 
	the empty string if the user cancels."
	^self request: queryString initialAnswer: ''! !

!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:41'!
request: queryString initialAnswer: defaultAnswer 
	"Create an instance of me whose question is queryString with the given 
	initial answer. Invoke it centered at the given point, and answer the 
	string the user accepts. Answer the empty string if the user cancels."
	^self subclassResponsibility! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UIManager class
	instanceVariableNames: ''!

!UIManager class methodsFor: 'class initialization' stamp: 'ar 2/11/2005 15:55'!
default
	| mgrClass |
	^Default ifNil:[
		"Note: The way the following is phrased ensures that you can always make 'more specific' managers merely by subclassing a tool builder and implementing a more specific way of reacting to #isActiveManager. For example, a BobsUIManager can subclass MorphicUIManager and (if enabled, say Preferences useBobsUI) will be considered before the parent (generic MorphicUIManager)."
		mgrClass := self allSubclasses 
			detect:[:any| any isActiveManager and:[
				any subclasses noneSatisfy:[:sub| sub isActiveManager]]] ifNone:[nil].
		mgrClass ifNotNil:[mgrClass new]
	].! !

!UIManager class methodsFor: 'class initialization' stamp: 'ar 12/27/2004 09:34'!
default: aUIManager
	Default := aUIManager! !

!UIManager class methodsFor: 'class initialization' stamp: 'ar 2/11/2005 15:41'!
isActiveManager
	"Answer whether I should act as the active ui manager"
	^false! !
Object subclass: #URI
	instanceVariableNames: 'fragment scheme schemeSpecificPart'
	classVariableNames: 'ClientClasses'
	poolDictionaries: ''
	category: 'Network-URI'!
!URI commentStamp: 'mir 2/20/2002 15:17' prior: 0!
A Uniform Resource Identifier (URI) is a compact string of characters for identifying an abstract or physical resource.
This implementation is based on http://www.ietf.org/rfc/rfc2396.txt.

!


!URI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:26'!
fragment
	^fragment! !

!URI methodsFor: 'accessing' stamp: 'mir 2/26/2002 19:17'!
resolveRelativeURI: relativeURI
	self shouldNotImplement! !

!URI methodsFor: 'accessing' stamp: 'mir 2/20/2002 16:53'!
scheme
	^scheme! !


!URI methodsFor: 'converting' stamp: 'mir 3/6/2002 14:54'!
asText
	^self asString asText! !

!URI methodsFor: 'converting' stamp: 'mir 2/26/2002 15:15'!
asURI
	^self! !

!URI methodsFor: 'converting' stamp: 'tb 5/24/2006 22:04'!
asUrl

	^self asString asUrl! !

!URI methodsFor: 'converting' stamp: 'mir 3/6/2002 16:59'!
downloadUrl
	self halt! !


!URI methodsFor: 'printing' stamp: 'mir 2/26/2002 14:56'!
printOn: stream
	self isAbsolute
		ifTrue: [
			stream nextPutAll: self scheme.
			stream nextPut: $: ].
	self printSchemeSpecificPartOn: stream.
	fragment
		ifNotNil: [
			stream nextPut: $# .
			stream nextPutAll: self fragment]
! !

!URI methodsFor: 'printing' stamp: 'mir 2/26/2002 14:55'!
printSchemeSpecificPartOn: stream
	stream nextPutAll: self schemeSpecificPart! !


!URI methodsFor: 'retrieval' stamp: 'mir 10/20/2003 16:31'!
contentStream
	^self clientClass contentStreamForURI: self! !

!URI methodsFor: 'retrieval' stamp: 'mir 3/5/2002 16:20'!
retrieveContentStream
	^self retrieveMIMEDocument contentStream! !

!URI methodsFor: 'retrieval' stamp: 'mir 3/5/2002 18:05'!
retrieveContents
	^self retrieveMIMEDocument contents! !

!URI methodsFor: 'retrieval' stamp: 'mir 3/22/2005 22:44'!
retrieveMIMEDocument
	^self clientClass retrieveMIMEDocument: self! !


!URI methodsFor: 'testing' stamp: 'bf 1/26/2004 14:40'!
hash
	^ self asString hash! !

!URI methodsFor: 'testing' stamp: 'mir 3/6/2002 17:00'!
hasRemoteContents
	self halt! !

!URI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'!
isAbsolute
	^self scheme notNil! !

!URI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'!
isOpaque
	^false! !

!URI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'!
isRelative
	^self isAbsolute not! !

!URI methodsFor: 'testing' stamp: 'bf 1/26/2004 14:40'!
= otherURI
	^ self class = otherURI class
		and: [self asString = otherURI asString]! !


!URI methodsFor: 'private' stamp: 'mir 2/20/2002 17:18'!
absoluteFromString: remainder scheme: schemeName
	scheme _ schemeName.
	self extractSchemeSpecificPartAndFragment: remainder! !

!URI methodsFor: 'private' stamp: 'mir 3/22/2005 23:02'!
clientClass
	^Smalltalk at: (ClientClasses at: self scheme ifAbsent: [ClientClasses at: 'file'])! !

!URI methodsFor: 'private' stamp: 'mir 2/27/2002 14:18'!
extractSchemeSpecificPartAndFragment: remainder
	| fragmentIndex |
	fragmentIndex _ remainder indexOf: $# .
	fragmentIndex > 0
		ifTrue: [
			schemeSpecificPart _ remainder copyFrom: 1 to: fragmentIndex-1.
			fragment _ remainder copyFrom: fragmentIndex+1 to: remainder size]
		ifFalse: [schemeSpecificPart _ remainder]! !

!URI methodsFor: 'private' stamp: 'mir 2/25/2002 16:10'!
schemeSpecificPart
	^schemeSpecificPart! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

URI class
	instanceVariableNames: ''!

!URI class methodsFor: 'class initialization' stamp: 'mir 3/1/2002 15:18'!
initialize
	"URI initialize"

	ClientClasses _ Dictionary new.
	ClientClasses
		at: 'http' put: #HTTPClient;
		at: 'ftp' put: #FTPClient;
		at: 'file' put: #FileDirectory
! !


!URI class methodsFor: 'instance creation' stamp: 'mir 2/20/2002 17:21'!
absoluteFromString: aString scheme: scheme
	| remainder |
	remainder _ aString copyFrom: scheme size+2 to: aString size.
	remainder isEmpty
		ifTrue: [(IllegalURIException new uriString: aString) signal: 'Invalid absolute URI'].
	^(remainder first = $/
		ifTrue: [HierarchicalURI]
		ifFalse: [OpaqueURI]) new absoluteFromString: remainder scheme: scheme! !

!URI class methodsFor: 'instance creation' stamp: 'mir 2/20/2002 17:23'!
extractSchemeFrom: aString
	| colonIndex slashIndex |
	colonIndex _ aString indexOf: $: .
	^colonIndex > 0
		ifTrue: [
			slashIndex _ aString indexOf: $/ .
			(slashIndex == 0
				or: [colonIndex < slashIndex])
				ifTrue: [aString copyFrom: 1 to: colonIndex-1]
				ifFalse: [nil]]
		ifFalse: [nil]! !

!URI class methodsFor: 'instance creation' stamp: 'mir 2/20/2002 17:07'!
fromString: aString
	| parseString scheme |
	parseString _ aString withBlanksTrimmed.
	scheme _ self extractSchemeFrom: parseString.
	^scheme
		ifNil: [HierarchicalURI new relativeFromString: aString]
		ifNotNil: [self absoluteFromString: aString scheme: scheme]
! !
Object subclass: #URIAuthority
	instanceVariableNames: 'host port userInfo'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-URI'!

!URIAuthority methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'!
host
	^host! !

!URIAuthority methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'!
port
	^port! !

!URIAuthority methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:28'!
userInfo
	^userInfo! !


!URIAuthority methodsFor: 'printing' stamp: 'mir 2/26/2002 14:52'!
printOn: stream
	userInfo
		ifNotNil: [
			stream nextPut: $@ .
			stream nextPutAll: userInfo].
	stream nextPutAll: host.
	port
		ifNotNil: [
			stream nextPut: $: .
			port printOn: stream] ! !


!URIAuthority methodsFor: 'private' stamp: 'mir 2/25/2002 19:04'!
fromString: authorityString
	| userInfoEnd remainder hostEnd |
	userInfoEnd _ authorityString indexOf: $@.
	remainder _ userInfoEnd > 0
		ifTrue: [
			userInfo _ authorityString copyFrom: 1 to: userInfoEnd-1.
			authorityString copyFrom: userInfoEnd+1 to: authorityString size]
		ifFalse: [authorityString].
	hostEnd _ remainder indexOf: $: .
	hostEnd > 0
		ifTrue: [
			host _ remainder copyFrom: 1 to: hostEnd-1.
			port _ (remainder copyFrom: hostEnd+1 to: remainder size) asNumber]
		ifFalse: [host _ remainder]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

URIAuthority class
	instanceVariableNames: ''!

!URIAuthority class methodsFor: 'instance creation'!
fromString: authorityString
	^self new fromString: authorityString! !
BasicButton subclass: #URLMorph
	instanceVariableNames: 'url page isBookmark book'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SqueakPage'!
!URLMorph commentStamp: '<historical>' prior: 0!
This morph represents a URL for a SqueakPage. It displays the thumbnail for the associated page, if available. Used in page sorters and for bookmarks.

This morph has several options:
  a. It can act like a thumbnail for sorting (in which case it can be picked up and dragged) or it acts as a bookmark (in which case shift clicking on it activates it).
  b. If it has book set to true, it is a page in a book.  Clicking fetches the index of the book, opens it to the first page, and puts it in the hand.

A thumbnail on a known book:
	(URLMorph grabURL: 'ftp://doltest1.disney.com/squeak/test/p1.sp')
		book: true.

A thumbnail on a single PasteUpMorph:
Make a PasteUpMorph with any morphs in it.
Decide where it should live, make a url string, and copy it.
	'file://HardDisk/books/book1/myPage.sp'
	'ftp://doltest1.disney.com/squeak/test/p1.sp'
Choose 'Save as Web Morph'
Paste in the url.
Drop the resulting thumbnail into some morph.

See SqueakPage's comment for the stages of in/out.

url 
page 		A SqueakPage
isBookmark 		Boolean
book 	A Boolean -- whether I represent a whole book or a page.
!


!URLMorph methodsFor: 'accessing' stamp: 'jm 6/17/1998 21:49'!
book

	^ book
! !

!URLMorph methodsFor: 'accessing' stamp: 'tk 2/17/1999 12:38'!
book: aUrl
	"A notation about what book this page is in.  true means page is in same book as url strm says.  Set to the url of the Book if the book has a different stem url.  nil or false if not for a book page at all."

	book _ aUrl! !

!URLMorph methodsFor: 'accessing' stamp: 'jm 6/17/1998 07:16'!
isBookmark

	^ isBookmark
! !

!URLMorph methodsFor: 'accessing' stamp: 'jm 6/17/1998 07:17'!
isBookmark: aBoolean
	"Make this morph behave as a clickable bookmark if the argument is true."

	isBookmark _ aBoolean.
! !

!URLMorph methodsFor: 'accessing' stamp: 'jm 6/16/1998 18:07'!
page
	"Answer the cached page that this morph represents."

	^ page
! !

!URLMorph methodsFor: 'accessing' stamp: 'jm 6/17/1998 07:05'!
url
	"Answer the URL for the page that this morph represents."

	^ url
! !


!URLMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:07'!
drawOn: aCanvas
	"Draw thumbnail for my page, if it is available. Otherwise, just draw a rectangle." 

| thumbnail oldExt |
color == Color transparent 
	ifTrue: ["show thumbnail"
		thumbnail _ self thumbnailOrNil.
		thumbnail
			ifNil: [aCanvas frameRectangle: bounds width: borderWidth 
						color: borderColor.
				aCanvas fillRectangle: (bounds insetBy: borderWidth) color: color]
			ifNotNil: [oldExt _ bounds extent.
				bounds _ bounds origin extent: thumbnail extent + (2@2).
				aCanvas frameRectangle: bounds width: borderWidth color: borderColor.
				aCanvas paintImage: thumbnail at: bounds origin + borderWidth.
				oldExt = thumbnail extent ifFalse: [self layoutChanged]]]
	ifFalse: ["show labeled button"
		^ super drawOn: aCanvas]
! !


!URLMorph methodsFor: 'event handling' stamp: 'tk 1/13/1999 08:04'!
handlesMouseDown: event

	^ isBookmark & event shiftPressed
! !

!URLMorph methodsFor: 'event handling' stamp: 'tk 10/2/1998 08:55'!
handlesMouseUp: evt

	^ isBookmark
! !

!URLMorph methodsFor: 'event handling' stamp: 'tk 10/2/1998 08:58'!
mouseDown: evt
	"do nothing"
! !

!URLMorph methodsFor: 'event handling' stamp: 'ar 4/10/2005 18:54'!
mouseUp: evt
	| pg ow newPage mm bookUrl bk |
	"If url of a book, open it to that page, or bring it in and open to that page."
	book ifNotNil: [book == false ifFalse: [
		(bookUrl _ book) isString ifFalse: [
			bookUrl _ (SqueakPage stemUrl: url), '.bo'].
		(bk _ BookMorph isInWorld: self world withUrl: bookUrl) class ~~ Symbol 
			ifTrue: [^ bk goToPageUrl: url].
		bk == #conflict ifTrue: [
			^ self inform: 'This book is already open in some other project'].
		(bk _ BookMorph new fromURL: bookUrl) ifNil: [^ self].
		bk goToPageUrl: url.	"turn to the page"
		^ HandMorph attach: bk]].

	"If inside a SqueakPage, replace it!!"
	pg _ self enclosingPage.
	pg ifNotNil: [
		(ow _ pg contentsMorph owner) ifNotNil: [
			pg contentsMorph delete.	"from its owner"
			newPage _ SqueakPageCache atURL: url.
			mm _ newPage fetchContents.
			mm ifNotNil: [ow addMorph: mm.
				page _ newPage].
			^ self]].
	"If I am a project, jump  -- not done yet"

	"For now, just put new page on the hand"
	newPage _ SqueakPageCache atURL: url.
	mm _ newPage fetchInformIfError.
	mm ifNotNil: [self primaryHand attachMorph: mm.
		page _ newPage].

! !


!URLMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!URLMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:53'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	
	isBookmark _ false! !


!URLMorph methodsFor: 'updating' stamp: 'jm 6/17/1998 14:15'!
pageHasChanged: aSqueakPage
	"The given page has changed. Update this morph if it refers to the given page."

	| thumbnail |
	page == aSqueakPage ifFalse: [^ self].  "this change does not affect me"
	thumbnail _ self thumbnailOrNil.
	thumbnail ifNotNil: [
		self extent: (thumbnail extent + 2).
		self changed].
! !


!URLMorph methodsFor: 'private' stamp: 'tk 11/23/1998 17:37'!
enclosingBook
	"rethink this since class WebBookMorph is gone"! !

!URLMorph methodsFor: 'private' stamp: 'di 11/13/2000 00:55'!
enclosingPage
	"Answer the inner-most SqueakPage contents that contains this morph, or nil if there isn't one."

	self allOwnersDo:
		[:m | (m isKindOf: PasteUpMorph)
			ifTrue: [(SqueakPageCache pageForMorph: m) ifNotNilDo: [:pg | ^ pg]]].
	^ nil
! !

!URLMorph methodsFor: 'private' stamp: 'RAA 8/30/2000 11:56'!
label: aString font: aFontOrNil

	| oldLabel m aFont |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	(oldLabel _ self findA: TextMorph)
		ifNotNil: [oldLabel delete].
	aFont _ aFontOrNil ifNil: [Preferences standardButtonFont].
	m _ TextMorph new contents: aString; beAllFont: aFont.
	self extent: (m width + 6) @ (m height + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock
! !

!URLMorph methodsFor: 'private' stamp: 'tk 10/2/1998 08:20'!
setURL: aURLString page: aSqueakPage
	"Initialize the receiver for the given URL and page."

	url _ aURLString.
	page _ aSqueakPage.
	page ifNotNil: [self pageHasChanged: page].
! !

!URLMorph methodsFor: 'private' stamp: 'gm 2/22/2003 13:16'!
thumbnailOrNil
	"Answer the thumbnail Form for the page this morph represents. Answer nil if no thumbnail is available."

	| thum |
	page ifNil: [page := SqueakPageCache atURL: url].
	(thum := page thumbnail) ifNil: [^nil].
	^(thum isForm) 
		ifTrue: [thum]
		ifFalse: [thum form	"a BookPageThumbnailMorph"]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

URLMorph class
	instanceVariableNames: ''!

!URLMorph class methodsFor: 'instance creation' stamp: 'tk 2/27/1999 14:18'!
grabForBook: bookMorph
	"Create a URLMorph for this book.  Put it into the hand."

	| um bookUrl pageUrl pg |
	bookUrl _ bookMorph valueOfProperty: #url.
	pageUrl _ bookMorph currentPage url.	"should have one!!"
	pg _ SqueakPageCache atURL: pageUrl.
	(SqueakPage stemUrl: bookUrl) = (SqueakPage stemUrl: pageUrl) 
		ifTrue: [bookUrl _ true].		"not a shared book"
	um _ URLMorph newForURL: pageUrl.
	um setURL: pageUrl page: pg.
	pg isContentsInMemory ifTrue: [pg computeThumbnail].
	um isBookmark: true.
	um book: bookUrl.
	um removeAllMorphs.
	um color: Color transparent.
	Smalltalk currentHand attachMorph: um.
	^ um! !

!URLMorph class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:52'!
grabURL: aURLString
	"Create a URLMorph for this url.  Drop it and click it to get the SqueakPage."

	| um |
	(um _ self new) isBookmark: true; setURL: aURLString page: nil.
	HandMorph attach: um.
	^ um! !

!URLMorph class methodsFor: 'instance creation' stamp: 'jm 6/17/1998 07:35'!
newBookmarkForURL: aURLString

	^ (self newForURL: aURLString) isBookmark: true
! !

!URLMorph class methodsFor: 'instance creation' stamp: 'tk 10/2/1998 12:08'!
newForURL: aURLString

	| pg |
	pg _ SqueakPageCache atURL: aURLString.
	^ self new setURL: aURLString page: pg
! !
TextConverter subclass: #UTF16TextConverter
	instanceVariableNames: 'useLittleEndian useByteOrderMark byteOrderMarkDone'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!UTF16TextConverter commentStamp: '<historical>' prior: 0!
Text converter for UTF-16.  It supports the endianness and byte order mark.!


!UTF16TextConverter methodsFor: 'accessing' stamp: 'yo 1/12/2004 17:00'!
useByteOrderMark

	^ useByteOrderMark ifNil: [^ false].
! !

!UTF16TextConverter methodsFor: 'accessing' stamp: 'yo 1/12/2004 13:54'!
useByteOrderMark: aBoolean

	useByteOrderMark _ aBoolean.
! !

!UTF16TextConverter methodsFor: 'accessing' stamp: 'yo 1/12/2004 17:00'!
useLittleEndian

	^ useLittleEndian ifNil: [false].
! !

!UTF16TextConverter methodsFor: 'accessing' stamp: 'yo 1/12/2004 14:02'!
useLittleEndian: aBoolean

	useLittleEndian _ aBoolean.
! !


!UTF16TextConverter methodsFor: 'conversion' stamp: 'yo 1/12/2004 17:06'!
nextFromStream: aStream

	| character1 character2 readBOM charValue |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 _ aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	character2 _ aStream basicNext.
	character2 isNil ifTrue: [^ nil].

	readBOM _ false.
	(character1 asciiValue = 16rFF and: [character2 asciiValue = 16rFE]) ifTrue: [
		self useByteOrderMark: true.
		self useLittleEndian: true.
		readBOM _ true.
	].
	(character1 asciiValue = 16rFE and: [character2 asciiValue = 16rFF]) ifTrue: [
		self useByteOrderMark: true.
		self useLittleEndian: false.
		readBOM _ true.
	].

	readBOM ifTrue: [
		character1 _ aStream basicNext.
		character1 isNil ifTrue: [^ nil].
		character2 _ aStream basicNext.
		character2 isNil ifTrue: [^ nil].
	].

	self useLittleEndian ifTrue: [
		charValue _ character2 charCode << 8 + character1 charCode.
	] ifFalse: [
		charValue _ character1 charCode << 8 + character2 charCode.
	].

	^ self charFromStream: aStream withFirst: charValue.
! !

!UTF16TextConverter methodsFor: 'conversion' stamp: 'yo 1/13/2004 12:56'!
nextPut: aCharacter toStream: aStream

	| v low high |
	(self useByteOrderMark and: [byteOrderMarkDone isNil]) ifTrue: [
		self next16BitValue: (16rFEFF) toStream: aStream.
		byteOrderMarkDone _ true.
	].

	v _ aCharacter charCode.
	v > 16rFFFF ifFalse: [
		self next16BitValue: v toStream: aStream.
		^ self.
	] ifTrue: [
		v _ v - 16r10000.
		low _ (v \\ 16r400) + 16rDC00.
		high _ (v // 16r400) + 16rD800.
		self next16BitValue: high toStream: aStream.
		self next16BitValue: low toStream: aStream.
	]! !


!UTF16TextConverter methodsFor: 'private' stamp: 'yo 1/12/2004 17:07'!
charFromStream: aStream withFirst: firstValue

	| character1 character2 tmp n secondValue |
	(16rD800 <= firstValue and: [firstValue <= 16rDBFF]) ifTrue: [
		character1 _ aStream basicNext.
		character1 isNil ifTrue: [^ nil].
		character2 _ aStream basicNext.
		character2 isNil ifTrue: [^ nil].
		self useLittleEndian ifTrue: [
			tmp _ character1.
			character1 _ character2.
			character2 _ tmp
		].
		secondValue _ (character1 charCode << 8) + (character2 charCode).
		n _ (firstValue - 16rD800) * 16r400 + (secondValue - 16rDC00) + 16r10000.
		^ Unicode value: n
	].

	^ Unicode value: firstValue
! !

!UTF16TextConverter methodsFor: 'private' stamp: 'yo 1/13/2004 12:59'!
next16BitValue: value toStream: aStream

	| v1 v2 |
	v1 _ (value >> 8) bitAnd: 16rFF.
	v2 _ value bitAnd: 16rFF.

	self useLittleEndian ifTrue: [
		aStream basicNextPut: (Character value: v2).
		aStream basicNextPut: (Character value: v1).
	] ifFalse: [
		aStream basicNextPut: (Character value: v1).
		aStream basicNextPut: (Character value: v2).
	].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UTF16TextConverter class
	instanceVariableNames: ''!

!UTF16TextConverter class methodsFor: 'utilities' stamp: 'yo 2/10/2004 05:23'!
encodingNames

	^ #('utf-16' 'utf16' 'utf-16-le' 'utf-16-be') copy.
! !
TextConverter subclass: #UTF8TextConverter
	instanceVariableNames: 'currentCharSize forceToEncodingTag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!
!UTF8TextConverter commentStamp: '<historical>' prior: 0!
Text converter for UTF-8.  Since the BOM is used to distinguish the MacRoman code and UTF-8 code, BOM is written for UTF-8 by #writeBOMOn: which is called by client.!


!UTF8TextConverter methodsFor: 'accessing' stamp: 'yo 8/4/2003 15:34'!
forceToEncodingTag

	^ forceToEncodingTag.
! !

!UTF8TextConverter methodsFor: 'accessing' stamp: 'yo 8/4/2003 15:31'!
forceToEncodingTag: encodingTagOrNil

	forceToEncodingTag _ encodingTagOrNil.
! !


!UTF8TextConverter methodsFor: 'conversion' stamp: 'ar 4/6/2006 10:15'!
errorMalformedInput
	^self error: 'Invalid utf8 input detected'! !

!UTF8TextConverter methodsFor: 'conversion' stamp: 'ar 4/6/2006 10:26'!
nextFromStream: aStream

	| character1 value1 character2 value2 unicode character3 value3 character4 value4 |
	aStream isBinary ifTrue: [^ aStream basicNext].
	character1 := aStream basicNext.
	character1 isNil ifTrue: [^ nil].
	value1 := character1 asciiValue.
	value1 <= 127 ifTrue: [
		"1-byte character"
		currentCharSize := 1.
		^ character1
	].

	"at least 2-byte character"
	character2 := aStream basicNext.
	character2 = nil ifTrue: [^self errorMalformedInput].
	value2 := character2 asciiValue.

	(value1 bitAnd: 16rE0) = 192 ifTrue: [
		currentCharSize := 2.
		^ Unicode value: ((value1 bitAnd: 31) bitShift: 6) + (value2 bitAnd: 63).
	].

	"at least 3-byte character"
	character3 := aStream basicNext.
	character3 = nil ifTrue: [^self errorMalformedInput].
	value3 := character3 asciiValue.
	(value1 bitAnd: 16rF0) = 224 ifTrue: [
		unicode := ((value1 bitAnd: 15) bitShift: 12) + ((value2 bitAnd: 63) bitShift: 6)
				+ (value3 bitAnd: 63).
		currentCharSize := 3.
	].

	(value1 bitAnd: 16rF8) = 240 ifTrue: [
		"4-byte character"
		character4 := aStream basicNext.
		character4 = nil ifTrue: [^self errorMalformedInput].
		value4 := character4 asciiValue.
		currentCharSize := 4.
		unicode := ((value1 bitAnd: 16r7) bitShift: 18) +
					((value2 bitAnd: 63) bitShift: 12) + 
					((value3 bitAnd: 63) bitShift: 6) +
					(value4 bitAnd: 63).
	].

	unicode isNil ifTrue: [^self errorMalformedInput].
	unicode > 16r10FFFD ifTrue: [^self errorMalformedInput].
	
	unicode = 16rFEFF ifTrue: [^ self nextFromStream: aStream].
	^ Unicode value: unicode.
! !

!UTF8TextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:29'!
nextPut: aCharacter toStream: aStream 
	| leadingChar nBytes mask shift ucs2code |
	aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream].
	leadingChar _ aCharacter leadingChar.
	(leadingChar = 0 and: [aCharacter asciiValue < 128]) ifTrue: [
		aStream basicNextPut: aCharacter.
		^ aStream.
	].

	"leadingChar > 3 ifTrue: [^ aStream]."

	ucs2code _ aCharacter asUnicode.
	ucs2code ifNil: [^ aStream].

	nBytes _ ucs2code highBit + 3 // 5.
	mask _ #(128 192 224 240 248 252 254 255) at: nBytes.
	shift _ nBytes - 1 * -6.
	aStream basicNextPut: (Character value: (ucs2code bitShift: shift) + mask).
	2 to: nBytes do: [:i | 
		shift _ shift + 6.
		aStream basicNextPut: (Character value: ((ucs2code bitShift: shift) bitAnd: 63) + 128).
	].

	^ aStream.
! !


!UTF8TextConverter methodsFor: 'friend' stamp: 'yo 12/30/2002 14:00'!
currentCharSize

	^ currentCharSize.
! !

!UTF8TextConverter methodsFor: 'friend' stamp: 'yo 11/8/2002 16:17'!
leadingChar

	^ self shouldNotImplement
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UTF8TextConverter class
	instanceVariableNames: ''!

!UTF8TextConverter class methodsFor: 'accessing' stamp: 'tak 1/12/2005 13:22'!
writeBOMOn: aStream
	"Write Byte Order Mark"
	aStream nextPut: 16rEF.
	aStream nextPut: 16rBB.
	aStream nextPut: 16rBF.
! !


!UTF8TextConverter class methodsFor: 'utilities' stamp: 'yo 12/19/2003 22:01'!
encodingNames

	^ #('utf-8' 'utf8') copy.
! !
ByteArray variableByteSubclass: #UUID
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-UUID'!
!UUID commentStamp: '<historical>' prior: 0!
A class to generate UUID
by John M McIntosh johnmci@smalltalkconsulting.com

See http://www.webdav.org/specs/draft-leach-uuids-guids-01.txt

If a plugin does not exist then we generate a UUID version 4 type GUUID!


!UUID methodsFor: 'comparing' stamp: 'JMM 11/22/2001 17:36'!
< aMagnitude 
	"Answer whether the receiver is less than the argument."

	1 to: self size do: [:i |
		(self at: i) < (aMagnitude at: i) ifTrue: [^true]].
	^false.! !

!UUID methodsFor: 'comparing' stamp: 'JMM 11/22/2001 17:30'!
<= aMagnitude 
	"Answer whether the receiver is less than or equal to the argument."

	^(self > aMagnitude) not! !

!UUID methodsFor: 'comparing' stamp: 'JMM 11/22/2001 17:30'!
> aMagnitude 
	"Answer whether the receiver is greater than the argument."

	^aMagnitude < self! !

!UUID methodsFor: 'comparing' stamp: 'JMM 11/22/2001 17:30'!
>= aMagnitude 
	"Answer whether the receiver is greater than or equal to the argument."

	^(self < aMagnitude) not! !


!UUID methodsFor: 'converting' stamp: 'ar 2/8/2004 12:16'!
asString
	| result data |
	data _ String new: 36.
	result _ WriteStream on: data.
	1 to: 4 do:[:i| self printHexAt: i to: result].
	result nextPut: $-.
	5 to: 6 do:[:i| self printHexAt: i to: result].
	result nextPut: $-.
	7 to: 8 do:[:i| self printHexAt: i to: result].
	result nextPut: $-.
	9 to: 10 do:[:i| self printHexAt: i to: result].
	result nextPut: $-.
	11 to: 16 do:[:i| self printHexAt: i to: result].
	^data.
	! !

!UUID methodsFor: 'converting' stamp: 'JMM 11/22/2001 13:09'!
asUUID: aString
	| stream token byte |
	stream _ ReadStream on: (aString copyReplaceAll: '-' with: '') asUppercase.
	1 to: stream size/2 do: [:i | 
		token _ stream next: 2.
		byte _ Integer readFrom: (ReadStream on: token ) base: 16.
		self at: i put: byte].
	^self
! !

!UUID methodsFor: 'converting' stamp: 'JMM 11/22/2001 13:13'!
createStringStartingAt: index for: bytes

	| results candidate data |
	data _ String new: bytes*2.
	results _ WriteStream on: data.
	index to: index+bytes -1 do: 
		[:i |
		candidate _ ((self at: i) printStringBase: 16) last: 2.
		candidate first = $r ifTrue: [candidate _ String with: $0 with: candidate last].
		results nextPutAll: candidate].
	^data asLowercase! !

!UUID methodsFor: 'converting' stamp: 'ar 2/8/2004 12:16'!
printHexAt: index to: aStream
	| map v |
	map := '0123456789abcdef'.
	v := self at: index.
	aStream nextPut: (map at: (v bitShift: -4) + 1). 
	aStream nextPut: (map at: (v bitAnd: 15) + 1).
! !


!UUID methodsFor: 'initalize-release' stamp: 'ar 2/3/2002 19:42'!
initialize
	self primMakeUUID.! !


!UUID methodsFor: 'printing' stamp: 'JMM 10/9/2001 14:46'!
printOn: aStream
	aStream nextPutAll: 'an UUID('.
	self asString printOn: aStream.
	aStream nextPutAll: ')'! !

!UUID methodsFor: 'printing' stamp: 'ar 2/8/2004 12:16'!
printString
	^self asString! !


!UUID methodsFor: 'system primitives' stamp: 'ar 2/3/2002 19:42'!
primMakeUUID
	<primitive: 'primitiveMakeUUID' module: 'UUIDPlugin'>
	UUIDGenerator default generateBytes: self forVersion: 4.! !


!UUID methodsFor: 'testing' stamp: 'JMM 10/9/2001 14:17'!
isNilUUID
	1 to: self size do: [:i | (self at: i) ~= 0 ifTrue: [^false]].
	^true.! !


!UUID methodsFor: '*smbase-macsafe' stamp: 'gk 4/18/2006 22:15'!
asString36
	"Encode the UUID as a base 36 string using 0-9 and lowercase a-z.
	This is the shortest representation still being able to work as
	filenames etc since it does not depend on case nor characters
	that might cause problems, and it fits into short filenames like on
	the old MacOS HFS filesystem. The check for 36r is to make this code
	work in versions before Squeak 3.8."

	| num candidate |
	num := 0.
	1 to: self size do: [:i | num := num + ((256 raisedTo: i - 1) * (self at: i))].
	candidate := num printStringBase: 36.
	^((candidate beginsWith: '36r')
			ifTrue: [candidate copyFrom: 4 to: candidate size]
			ifFalse: [candidate]) asLowercase! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UUID class
	instanceVariableNames: ''!

!UUID class methodsFor: 'instance creation' stamp: 'dvf 9/10/2004 23:10'!
fromString: aString
	| object |
	aString size ~= 36 ifTrue: [Error signal].
	object := self nilUUID. 
	object asUUID: aString.
	^object! !

!UUID class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:49'!
new
	^(self new: 16)! !

!UUID class methodsFor: 'instance creation' stamp: 'nk 6/28/2004 16:10'!
nilUUID
	"Must call basicNew: here because I have a non-trivial initialize method."

	^self basicNew: 16! !


!UUID class methodsFor: '*smbase-macsafe' stamp: 'dvf 9/10/2004 23:11'!
fromString36: aString
	"Decode the UUID from a base 36 string using 0-9 and lowercase a-z.
	This is the shortest representation still being able to work as
	filenames etc since it does not depend on case nor characters
	that might cause problems."

	| object num |
	object := self nilUUID.
	num := Integer readFrom: aString asUppercase readStream base: 36.
	16 to: 1 by: -1 do: [:i |
		num size < i
			ifTrue: [object at: i put: 0]
			ifFalse: [object at: i put: (num digitAt: i)]].
	^object! !
Object subclass: #UUIDGenerator
	instanceVariableNames: 'timeLow timeMid timeHiAndVersion clockSeqHiAndReserved clockSeqLow node randomCounter randomGenerator semaphoreForGenerator'
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'Network-UUID'!
!UUIDGenerator commentStamp: '<historical>' prior: 0!
This class generates a pseudo-random UUID
by John M McIntosh johnmci@smalltalkconsulting.com

See http://www.webdav.org/specs/draft-leach-uuids-guids-01.txt!


!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:28'!
randomCounter
	^randomCounter! !

!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:29'!
randomCounter: aNumber
	randomCounter _ aNumber
! !

!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:27'!
randomGenerator
	^randomGenerator
! !

!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:27'!
randomGenerator: aGenerator
	randomGenerator _ aGenerator
! !

!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:29'!
semaphoreForGenerator
	^semaphoreForGenerator! !

!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:29'!
semaphoreForGenerator: aSema
	semaphoreForGenerator _ aSema
! !


!UUIDGenerator methodsFor: 'generator' stamp: 'JMM 11/22/2001 13:51'!
generateOneOrZero
	| result |
	self semaphoreForGenerator
		critical: [| value | 
			value _ self randomGenerator next.
			self randomCounter: self randomCounter + 1.
			self randomCounter > 100000
				ifTrue: [self setupRandom].
			result _ value < 0.5
						ifTrue: [0]
						ifFalse: [1]].
	^ result! !

!UUIDGenerator methodsFor: 'generator' stamp: 'JMM 11/21/2001 15:12'!
generateRandomBitsOfLength: aNumberOfBits
| target |
	target _ 0.
	aNumberOfBits isZero ifTrue: [^target].
	target _ self generateOneOrZero.
	(aNumberOfBits - 1)  timesRepeat:
		[target _ (target bitShift: 1)  bitOr: self generateOneOrZero].
	^target! !


!UUIDGenerator methodsFor: 'instance creation' stamp: 'JMM 11/22/2001 13:45'!
generateBytes: aPlaceHolder forVersion: aVersion
	aVersion = 4 ifTrue: [self generateFieldsVersion4]
		ifFalse: [self error: 'Unsupported version'].
	self placeFields: aPlaceHolder.! !

!UUIDGenerator methodsFor: 'instance creation' stamp: 'JMM 11/22/2001 23:13'!
generateFieldsVersion4

	timeLow _ self generateRandomBitsOfLength: 32.
	timeMid _ self generateRandomBitsOfLength: 16.
	timeHiAndVersion _ 16r4000 bitOr: (self generateRandomBitsOfLength: 12).
	clockSeqHiAndReserved _ 16r80 bitOr: (self generateRandomBitsOfLength: 6).
	clockSeqLow _ self generateRandomBitsOfLength: 8.
	node _ self generateRandomBitsOfLength: 48.
	! !

!UUIDGenerator methodsFor: 'instance creation' stamp: 'JMM 11/21/2001 14:30'!
initialize
	self setupRandom.
	semaphoreForGenerator _ Semaphore forMutualExclusion.
	! !

!UUIDGenerator methodsFor: 'instance creation' stamp: 'JMM 11/22/2001 23:12'!
placeFields: aByteArray

	aByteArray at: 1 put: ((timeLow bitShift: -24) bitAnd: 16rFF).
	aByteArray at: 2 put: ((timeLow bitShift: -16) bitAnd: 16rFF).
	aByteArray at: 3 put: ((timeLow bitShift: -8) bitAnd: 16rFF).
	aByteArray at: 4 put: (timeLow bitAnd: 16rFF).
	aByteArray at: 5 put: ((timeMid bitShift: -8) bitAnd: 16rFF).
	aByteArray at: 6 put: (timeMid bitAnd: 16rFF).
	aByteArray at: 7 put: ((timeHiAndVersion bitShift: -8) bitAnd: 16rFF).
	aByteArray at: 8 put: (timeHiAndVersion bitAnd: 16rFF).
	aByteArray at: 9 put: clockSeqHiAndReserved.
	aByteArray at: 10 put: clockSeqLow.
	0 to: 5 do: [:i |
		aByteArray at: 11 + i put: ((node bitShift: (-8*i)) bitAnd: 16rFF)]
! !

!UUIDGenerator methodsFor: 'instance creation' stamp: 'CdG 11/19/2002 21:30'!
setupRandom
	randomCounter _ 0.
	randomGenerator _ Random seed: self makeSeed.! !


!UUIDGenerator methodsFor: 'random seed' stamp: 'dew 2/8/2003 00:28'!
makeSeed
	"Try various methods of getting good seeds"
	| seed |
	seed := self makeUnixSeed.
	seed ifNotNil: [^seed].

	"not sure if this is reliably random... commented out for now. -dew"
	"seed := self makeSeedFromSound.
	seed ifNotNil: [^seed]."
	
	"default"
	[seed := (Time millisecondClockValue bitAnd: 16r3FFFFFFF) bitXor: self hash.
	seed := seed bitXor: (Time totalSeconds bitAnd: 16r3FFFFFFF).
	seed = 0] whileTrue: ["Try again if ever get a seed = 0"].

	^seed
! !

!UUIDGenerator methodsFor: 'random seed' stamp: 'gk 2/23/2004 21:09'!
makeSeedFromSound
	| answer |
	[answer := SoundService default randomBitsFromSoundInput: 32
	] ifError: [answer := nil].
	^answer! !

!UUIDGenerator methodsFor: 'random seed' stamp: 'nk 2/22/2005 13:54'!
makeUnixSeed
	| strm answer |
	[strm := (FileStream readOnlyFileNamed: '/dev/urandom') binary.
	strm converter: Latin1TextConverter new.
	answer := Integer
		byte1: strm next
		byte2: strm next
		byte3: strm next
		byte4: strm next.
	strm close.
	] on: FileStreamException do: [answer := nil].
	^answer! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UUIDGenerator class
	instanceVariableNames: ''!

!UUIDGenerator class methodsFor: 'class initialization' stamp: 'CdG 11/19/2002 21:06'!
initialize
	Smalltalk addToStartUpList: self after: nil.! !

!UUIDGenerator class methodsFor: 'class initialization' stamp: 'CdG 11/19/2002 21:07'!
startUp
	Default := nil! !


!UUIDGenerator class methodsFor: 'instance creation' stamp: 'JMM 11/22/2001 13:41'!
default
	Default ifNil: [self generateDefault].
	^Default! !

!UUIDGenerator class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'!
generateDefault
	Default := self new! !
TestCase subclass: #UUIDPrimitivesTest
	instanceVariableNames: ''
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'NetworkTests-UUID'!

!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:14'!
testCreation
	| uuid |
	uuid _ UUID new.
	self should: [uuid size = 16].
	self shouldnt: [uuid isNilUUID].
	self should: [uuid asString size = 36].
! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:27'!
testCreationEquality
	| uuid1 uuid2 |
	uuid1 _ UUID new.
	uuid2 _ UUID new.
	self should: [uuid1 = uuid1].
	self should: [uuid2 = uuid2].
	self shouldnt: [uuid1 = uuid2].
	self shouldnt: [uuid1 hash = uuid2 hash].
! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:17'!
testCreationFromString
	| uuid string |
	string _ UUID nilUUID asString.
	uuid _ UUID fromString: string.
	self should: [uuid size = 16].
	self should: [uuid = UUID nilUUID].
	self should: [uuid isNilUUID].
	self should: [uuid asString size = 36].
	self should: [uuid asArray asSet size = 1].
	self should: [(uuid asArray asSet asArray at: 1) = 0].
! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:18'!
testCreationFromStringNotNil
	| uuid string |
	string _ UUID new asString.
	uuid _ UUID fromString: string.
	self should: [uuid size = 16].
	self should: [uuid asString size = 36].

! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:16'!
testCreationNil
	| uuid |
	uuid _ UUID nilUUID.
	self should: [uuid size = 16].
	self should: [uuid isNilUUID].
	self should: [uuid asString size = 36].
	self should: [uuid asArray asSet size = 1].
	self should: [(uuid asArray asSet asArray at: 1) = 0].
! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 23:24'!
testCreationNodeBased
	| uuid |

	(UUID new asString last: 12) = (UUID new asString last: 12) ifFalse: [^self].
	1000 timesRepeat:
		[uuid _ UUID new.
		self should: [((uuid at: 7) bitAnd: 16rF0) = 16r10].
		self should: [((uuid at: 9) bitAnd: 16rC0) = 16r80]]
! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 22:38'!
testDuplicationsKinda
	|check uuid size |

	size _ 5000.
	check _ Set new: size.
	size timesRepeat: 
		[uuid _ UUID new.
		self shouldnt: [check includes: uuid].
		check add: uuid].
		! !

!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:37'!
testOrder
	| uuid1 uuid2 |
	100 timesRepeat:
		[uuid1 _ UUID new.
		uuid2 _ UUID new.
		(uuid1 asString last: 12) = (uuid2 asString last: 12) ifTrue:
			[self should: [uuid1 < uuid2].
			self should: [uuid2 > uuid1].
			self shouldnt: [uuid1 = uuid2]]]
! !
Object subclass: #UndefinedObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!UndefinedObject commentStamp: '<historical>' prior: 0!
I describe the behavior of my sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.!


!UndefinedObject methodsFor: '3ds parser support' stamp: 'ar 2/6/1999 20:18'!
from3DS: aDictionary
	^aDictionary! !


!UndefinedObject methodsFor: 'bottom context' stamp: 'ajh 2/1/2003 01:31'!
canHandleSignal: exception
	"When no more handler (on:do:) context left in sender chain this gets called"

	^ false! !

!UndefinedObject methodsFor: 'bottom context' stamp: 'ajh 2/1/2003 01:31'!
handleSignal: exception
	"When no more handler (on:do:) context left in sender chain this gets called.  Return from signal with default action."

	^ exception resumeUnchecked: exception defaultAction! !


!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:49'!
addSubclass: aClass
	"Ignored -- necessary to support disjoint class hierarchies"! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'dvf 8/9/2005 16:49'!
allSuperclassesDo: aBlockContext 
	self shouldBeImplemented! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'sd 3/28/2003 15:16'!
environment
	"Necessary to support disjoint class hierarchies."

	^self class environment! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ajh 1/27/2003 17:48'!
literalScannedAs: scannedLiteral notifying: requestor 
	^ scannedLiteral! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'dvf 9/22/2005 20:10'!
removeObsoleteSubclass: aClass
	"Ignored -- necessary to support disjoint class hierarchies"! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ikp 9/26/97 14:45'!
removeSubclass: aClass
	"Ignored -- necessary to support disjoint class hierarchies"! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 8/29/1999 12:49'!
subclassDefinerClass
	"For disjunct class hierarchies -- how should subclasses of nil be evaluated"
	^Compiler! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:55'!
subclasses
	"Return all the subclasses of nil"
	| classList |
	classList _ WriteStream on: Array new.
	self subclassesDo:[:class| classList nextPut: class].
	^classList contents! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'tk 8/18/1999 17:46'!
subclassesDoGently: aBlock
	"Evaluate aBlock with all subclasses of nil.  Others are not direct subclasses of Class."

	^ Class subclassesDoGently: [:cl | 
			cl isMeta ifTrue: [aBlock value: cl soleInstance]].! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 15:44'!
subclassesDo: aBlock
	"Evaluate aBlock with all subclasses of nil."
	^Class subclassesDo:[:cl| 
		cl isMeta ifTrue:[aBlock value: cl soleInstance]].! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ls 10/9/2001 00:11'!
subclass: nameOfClass  
	instanceVariableNames: instVarNames
	classVariableNames: classVarNames
	poolDictionaries: poolDictnames
	category: category
	"Calling this method is now considered an accident.  If you really want to create a class with a nil superclass, then create the class and then set the superclass using #superclass:"
	Transcript show: ('Attempt to create ', nameOfClass, ' as a subclass of nil.  Possibly a class is being loaded before its superclass.'); cr.
	^ProtoObject
		subclass: nameOfClass
		instanceVariableNames: instVarNames
		classVariableNames: classVarNames
		poolDictionaries: poolDictnames
		category: category
! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/13/1999 06:08'!
typeOfClass
	"Necessary to support disjoint class hierarchies."
	^#normal! !


!UndefinedObject methodsFor: 'copying' stamp: 'tk 6/26/1998 11:35'!
clone
	"Only one instance of UndefinedObject should ever be made, so answer 
	with self."! !

!UndefinedObject methodsFor: 'copying'!
deepCopy
	"Only one instance of UndefinedObject should ever be made, so answer 
	with self."! !

!UndefinedObject methodsFor: 'copying'!
shallowCopy
	"Only one instance of UndefinedObject should ever be made, so answer 
	with self."! !

!UndefinedObject methodsFor: 'copying' stamp: 'tk 8/20/1998 16:07'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !


!UndefinedObject methodsFor: 'dependents access'!
addDependent: ignored 
	"Refer to the comment in Object|dependents."

	self error: 'Nil should not have dependents'! !

!UndefinedObject methodsFor: 'dependents access'!
release
	"Nil release is a no-op"! !

!UndefinedObject methodsFor: 'dependents access'!
suspend
	"Kills off processes that didn't terminate properly"
	"Display reverse; reverse."  "<-- So we can catch the suspend bug"
	Processor terminateActive! !


!UndefinedObject methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:." 

	aStream nextPutAll: 'nil'! !

!UndefinedObject methodsFor: 'printing'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:." 

	aStream nextPutAll: 'nil'! !


!UndefinedObject methodsFor: 'testing' stamp: 'sw 1/12/98 18:09'!
haltIfNil
	self halt! !

!UndefinedObject methodsFor: 'testing'!
ifNil: aBlock
	"A convenient test, in conjunction with Object ifNil:"

	^ aBlock value! !

!UndefinedObject methodsFor: 'testing' stamp: 'md 10/7/2004 15:41'!
ifNil: nilBlock ifNotNilDo: ifNotNilBlock
	"Evaluate the block for nil because I'm == nil"

	^ nilBlock value! !

!UndefinedObject methodsFor: 'testing'!
ifNil: nilBlock ifNotNil: ifNotNilBlock
	"Evaluate the block for nil because I'm == nil"

	^ nilBlock value! !

!UndefinedObject methodsFor: 'testing' stamp: 'di 11/8/2000 21:22'!
ifNotNilDo: aBlock
	"Override to do nothing."

	^ self
! !

!UndefinedObject methodsFor: 'testing' stamp: 'md 10/7/2004 15:39'!
ifNotNilDo: ifNotNilBlock ifNil: nilBlock 
	"If I got here, I am nil, so evaluate the block nilBlock"

	^ nilBlock value! !

!UndefinedObject methodsFor: 'testing'!
ifNotNil: aBlock
	"A convenient test, in conjunction with Object ifNotNil:"

	^ self! !

!UndefinedObject methodsFor: 'testing'!
ifNotNil: ifNotNilBlock ifNil: nilBlock 
	"If I got here, I am nil, so evaluate the block nilBlock"

	^ nilBlock value! !

!UndefinedObject methodsFor: 'testing' stamp: 'sw 4/7/1999 17:44'!
isEmptyOrNil
	"Answer whether the receiver contains any elements, or is nil.  Useful in numerous situations where one wishes the same reaction to an empty collection or to nil"
	^ true! !

!UndefinedObject methodsFor: 'testing' stamp: 'sma 6/6/2000 22:53'!
isLiteral
	^ true! !

!UndefinedObject methodsFor: 'testing'!
isNil 
	"Refer to the comment in Object|isNil."

	^true! !

!UndefinedObject methodsFor: 'testing'!
notNil 
	"Refer to the comment in Object|notNil."

	^false! !


!UndefinedObject methodsFor: '*eToys-printing' stamp: 'sw 10/29/1998 16:34'!
newTileMorphRepresentative
	^ UndescribedTile new! !


!UndefinedObject methodsFor: '*eToys-*Morphic-customevents-class initialization' stamp: 'nk 11/1/2004 07:48'!
initialize
	"AlansTextPlusMorph initialize"
	ScriptingSystem addCustomEventFor: self named: #scrolledIntoView help: 'when I am scrolled into view in a GeeMailMorph' targetMorphClass: Morph.
	ScriptingSystem addCustomEventFor: self named: #scrolledOutOfView help: 'when I am scrolled out of view in a GeeMailMorph'  targetMorphClass: Morph.
! !



!UndefinedObject methodsFor: 'compiling' stamp: 'md 2/20/2006 18:47'!
parserClass

	^ Compiler parserClass! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndefinedObject class
	instanceVariableNames: ''!

!UndefinedObject class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 09:32'!
initializedInstance
	^ nil! !

!UndefinedObject class methodsFor: 'instance creation'!
new
	self error: 'You may not create any more undefined objects--use nil'! !
ClassTestCase subclass: #UndefinedObjectTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Objects'!
!UndefinedObjectTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class UndefinedObject. 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!


!UndefinedObjectTest methodsFor: 'tests - Class Methods' stamp: 'sd 6/5/2005 09:08'!
testInitializedInstance

	self assert: ( UndefinedObject initializedInstance class == UndefinedObject).! !

!UndefinedObjectTest methodsFor: 'tests - Class Methods' stamp: 'sd 6/5/2005 09:09'!
testNew

	self should: [ UndefinedObject new] raise: Error.! !


!UndefinedObjectTest methodsFor: 'tests - copying' stamp: 'sd 6/5/2005 09:07'!
testClone

	self assert: ( nil clone = nil).! !

!UndefinedObjectTest methodsFor: 'tests - copying' stamp: 'sd 6/5/2005 09:07'!
testDeepCopy

	self assert:  (nil deepCopy = nil).! !

!UndefinedObjectTest methodsFor: 'tests - copying' stamp: 'sd 6/5/2005 09:07'!
testShallowCopy

	self assert: (nil shallowCopy = nil).! !

!UndefinedObjectTest methodsFor: 'tests - copying' stamp: 'sd 6/5/2005 09:07'!
testVeryDeepCopyWith

	self assert: ((nil veryDeepCopyWith: nil) = nil).! !


!UndefinedObjectTest methodsFor: 'tests - printing' stamp: 'sd 6/5/2005 09:09'!
testNewTileMorphRepresentative
	
	self assert: (nil newTileMorphRepresentative class =  UndescribedTile).! !

!UndefinedObjectTest methodsFor: 'tests - printing' stamp: 'sd 6/5/2005 09:09'!
testPrintOn

	| string |
	string := String streamContents: [:stream | nil printOn: stream].
	self assert: (string = 'nil').! !

!UndefinedObjectTest methodsFor: 'tests - printing' stamp: 'sd 6/5/2005 09:09'!
testStoreOn

	| string |
	string := String streamContents: [:stream | nil storeOn: stream].
	self assert: ((Compiler evaluate: string) = nil).! !


!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:07'!
testHaltIfNil

	self should: [ nil haltIfNil] raise: Halt.! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:07'!
testIfNil

	self should: [ nil ifNil: [self halt]] raise: Halt.


! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'!
testIfNilIfNotNil

	self should: [ nil ifNil: [self halt] ifNotNil: [self error] ] raise: Halt.


! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'!
testIfNotNil

	self shouldnt: [ nil ifNotNil: [self halt]] raise: Halt.


! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'!
testIfNotNilDo

	self shouldnt: [ nil ifNotNilDo: [self halt]] raise: Halt.
! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'!
testIfNotNilIfNil

	self should: [ nil ifNotNil: [self error] ifNil: [self halt] ] raise: Halt.


! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'!
testIsEmptyOrNil

	self assert: (nil isEmptyOrNil).! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'!
testIsLiteral

	self assert: (nil isLiteral).! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'!
testIsNil

	self assert: (nil isNil).! !

!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'!
testNotNil

	self deny: (nil notNil).! !
TileMorph subclass: #UndescribedTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!UndescribedTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45'!
initialize
	"Initialize the receiver. This is in its infancy -- just a place-holder 
	at present"
	super initialize.
""
	self extent: 20 @ 22.
	self setLiteral: 'arg'! !
Exception subclass: #UnhandledError
	instanceVariableNames: 'exception'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!UnhandledError methodsFor: 'as yet unclassified' stamp: 'ajh 9/4/2002 19:15'!
exception

	^ exception! !

!UnhandledError methodsFor: 'as yet unclassified' stamp: 'ajh 9/4/2002 19:15'!
exception: anError

	exception _ anError! !


!UnhandledError methodsFor: 'priv handling' stamp: 'ar 9/27/2005 19:53'!
defaultAction
	"The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated."
	^ToolSet debugError: exception.! !

!UnhandledError methodsFor: 'priv handling' stamp: 'ajh 2/1/2003 00:56'!
isResumable
	
	^ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UnhandledError class
	instanceVariableNames: ''!

!UnhandledError class methodsFor: 'as yet unclassified' stamp: 'ajh 9/4/2002 19:17'!
signalForException: anError

	^ self new
		exception: anError;
		signal! !
MethodWithInterface subclass: #UniclassScript
	instanceVariableNames: 'currentScriptEditor formerScriptingTiles isTextuallyCoded lastSourceString'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!UniclassScript commentStamp: '<historical>' prior: 0!
Represents a tile script of uniclass.  Holds the ScriptEditorMorph structures for the current version of a user-defined tile script, as well as previous versions thereof.

In addition to the instance variables of my superclass, my instance variables are:

currentScriptEditor		The current version of the ScriptEditorMorph for the script
formerScriptingTiles		A collection of pairs, (<timeStamp>  (list of morphs)) 
							each pair characterizing a prior tile version
isTextuallyCoded			A boolean.  If true, then a hand-crafted user coding supersedes
							the tale of the tiles.  This architecture is in transition, perhaps.!


!UniclassScript methodsFor: 'access' stamp: 'sw 12/15/2004 20:46'!
playerClass
	"Answer the playerClass associated with the receiver"

	^ playerClass ifNil:
		[playerClass _ currentScriptEditor playerScripted ifNotNil: [currentScriptEditor playerScripted class]]! !

!UniclassScript methodsFor: 'access' stamp: 'sw 12/15/2004 16:42'!
playerClassPerSe
	"Answer the current value of the playerClass inst var."

	^ playerClass! !


!UniclassScript methodsFor: 'initialization' stamp: 'sw 1/30/2001 11:37'!
convertFromUserScript: aUserScript
	"The argument represents an old UserScript object.  convert it over"

	defaultStatus _ aUserScript status.
	isTextuallyCoded _ aUserScript isTextuallyCoded.
	currentScriptEditor _ aUserScript currentScriptEditor.
	formerScriptingTiles _  aUserScript formerScriptEditors ifNotNil:
		[aUserScript formerScriptEditors collect:
			[:aScriptEditor |
				Array with: aScriptEditor timeStamp with: aScriptEditor submorphs allButFirst]]! !

!UniclassScript methodsFor: 'initialization' stamp: 'sw 1/26/2001 16:44'!
initialize
	"Initialize the receiver by setting its inst vars to default values"

	super initialize.
	isTextuallyCoded _ false

! !

!UniclassScript methodsFor: 'initialization' stamp: 'sw 1/23/2001 17:14'!
isTextuallyCoded
	"Answer whether the receiver is textually coded"

	^ isTextuallyCoded! !

!UniclassScript methodsFor: 'initialization' stamp: 'sw 7/2/2002 14:13'!
playerClass: aPlayerClass selector: aSelector
	"Set the playerClass and selector of the receiver"

	super playerClass: aPlayerClass selector: aSelector.
	aSelector numArgs = 1 ifTrue:
		[argumentVariables _ {Variable new name: 'parameter' type: #Number}]! !

!UniclassScript methodsFor: 'initialization' stamp: 'sw 12/15/2004 15:15'!
printOn: aStream
	aStream nextPutAll: 'A UniclassScript - selector: ', selector printString, ' scriptEditor: ', currentScriptEditor printString! !


!UniclassScript methodsFor: 'initialize-release' stamp: 'RAA 5/18/2001 13:25'!
releaseCachedState
	"release all non-showing scriptors.  What do we do about versions????"
	"18 May 2001 - get more aggressive in dropping stuff"

	formerScriptingTiles _ OrderedCollection new.

	currentScriptEditor ifNil: [^ self].

	true ifTrue: [^ self].	"<<< to test the reconstruction of scripts, change to false"
	currentScriptEditor world ifNil: ["not showing"
		currentScriptEditor _ nil]! !


!UniclassScript methodsFor: 'script editor' stamp: 'sw 7/28/2004 18:32'!
currentScriptEditor
	"Answer the currentScriptEditor"

	^ currentScriptEditor! !

!UniclassScript methodsFor: 'script editor' stamp: 'sw 1/23/2001 17:12'!
currentScriptEditor: anEditor
	"Set the receiver's currentScriptEditor as indicated"

	currentScriptEditor _ anEditor! !

!UniclassScript methodsFor: 'script editor' stamp: 'sw 7/22/2002 17:44'!
currentScriptEditorDo: aBlock
	"Evaluate a block on behalf of my current script editor, if any"

	currentScriptEditor ifNotNil:
		[aBlock value: currentScriptEditor]! !

!UniclassScript methodsFor: 'script editor' stamp: 'sw 7/20/2002 14:27'!
instantiatedScriptEditorForPlayer: aPlayer
	"Return the current script editor, creating it if necessary"

	currentScriptEditor ifNil:
		[currentScriptEditor _ (self playerClass includesSelector: selector) 
			ifTrue:
				[Preferences universalTiles
					ifFalse:
						[self error: 'duplicate selector'].
				ScriptEditorMorph new fromExistingMethod: selector forPlayer: aPlayer]
			ifFalse:
				[ScriptEditorMorph new setMorph: aPlayer costume scriptName: selector].

		(defaultStatus == #ticking and: [selector numArgs == 0]) ifTrue:
			[aPlayer costume arrangeToStartStepping]].
	
	^ currentScriptEditor! !

!UniclassScript methodsFor: 'script editor' stamp: 'sw 7/28/2001 01:11'!
recompileScriptFromTilesUnlessTextuallyCoded
	"recompile Script From Tiles Unless Textually Coded"

	self isTextuallyCoded ifFalse:
		[currentScriptEditor ifNotNil: [currentScriptEditor recompileScript]]! !


!UniclassScript methodsFor: 'textually coded' stamp: 'sw 3/28/2002 00:39'!
becomeTextuallyCoded
	"Transform the receiver into one which is textually coded"

	isTextuallyCoded _ true.
	lastSourceString _ (playerClass compiledMethodAt: selector) decompileString 		"Save this to compare when going back to tiles"! !

!UniclassScript methodsFor: 'textually coded' stamp: 'sw 3/27/2002 22:43'!
lastSourceString
	"Answer the most recent source string"

	^ lastSourceString! !


!UniclassScript methodsFor: 'updating' stamp: 'sw 10/17/2001 09:46'!
bringUpToDate
	"Bring all versions of the receiver's tile-script source up to date"

	currentScriptEditor ifNotNil:
		[currentScriptEditor bringTileScriptingElementsUpToDate].
	formerScriptingTiles isEmptyOrNil ifFalse:
		[formerScriptingTiles do:
			[:aPair | aPair second do:
				[:aMorph | aMorph bringTileScriptingElementsUpToDate]]]! !

!UniclassScript methodsFor: 'updating' stamp: 'sw 2/16/2001 00:46'!
revertToLastSavedTileVersionFor: anEditor
	"revert to the last saved tile version"

	Preferences universalTiles
		ifFalse:
			[formerScriptingTiles isEmptyOrNil ifFalse:
				[anEditor reinsertSavedTiles: formerScriptingTiles last second]]
		ifTrue:
			[anEditor removeAllButFirstSubmorph.
			anEditor insertUniversalTiles].
	anEditor showingMethodPane: false.
	isTextuallyCoded _ false! !

!UniclassScript methodsFor: 'updating' stamp: 'sw 2/18/2001 18:27'!
saveScriptVersion: timeStamp
	"Save the tile script version by appending a pair of the form

		<time stamp>     <morph list>

to my list of former scripting tiles.  The morph-list will get copied back into the Scriptor following restoration.  Only applies to classic tiles."

	Preferences universalTiles ifFalse:  "the following only applies to Classic tiles"
		[(currentScriptEditor notNil and: [currentScriptEditor showingMethodPane not]) ifTrue:
				[formerScriptingTiles ifNil: [formerScriptingTiles _ OrderedCollection new].
				formerScriptingTiles add:
					(Array with: timeStamp
						with: (currentScriptEditor submorphs allButFirst collect: [:m | m veryDeepCopy])).
				formerScriptingTiles size > 100 ifTrue: [^ self halt: 'apparent runaway versions, proceed at your own risk.']]]! !


!UniclassScript methodsFor: 'versions' stamp: 'di 2/19/2001 10:09'!
recreateScriptFrom: anEditor
	"Used to revert to old tiles"

	formerScriptingTiles isEmptyOrNil ifTrue: [^ self].
	anEditor reinsertSavedTiles: formerScriptingTiles last second.
	isTextuallyCoded _ false! !

!UniclassScript methodsFor: 'versions' stamp: 'md 10/22/2003 16:16'!
revertScriptVersionFrom: anEditor 
	"Let user choose which prior tile version to revert to, and revert to it"

	| aMenu chosenStampAndTileList |
	formerScriptingTiles isEmptyOrNil ifTrue: [^Beeper beep].
	chosenStampAndTileList := formerScriptingTiles size == 1 
		ifTrue: [ formerScriptingTiles first]
		ifFalse: 
			[aMenu := SelectionMenu 
						labelList: (formerScriptingTiles collect: [:e | e first])
						selections: formerScriptingTiles.
			aMenu startUp].
	chosenStampAndTileList ifNotNil: 
			[anEditor reinsertSavedTiles: chosenStampAndTileList second.
			isTextuallyCoded := false]! !

!UniclassScript methodsFor: 'versions' stamp: 'sw 1/30/2001 11:31'!
savedTileVersionsCount
	"Answer the number of saved tile versions of the script"

	^ formerScriptingTiles ifNil: [0] ifNotNil: [formerScriptingTiles size]! !
EncodedCharSet subclass: #Unicode
	instanceVariableNames: ''
	classVariableNames: 'DecimalProperty GeneralCategory'
	poolDictionaries: ''
	category: 'Multilingual-Encodings'!
!Unicode commentStamp: 'yo 10/19/2004 20:44' prior: 0!
This class holds the entry points for the utility functions around characters.
!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Unicode class
	instanceVariableNames: ''!

!Unicode class methodsFor: 'accessing - displaying' stamp: 'yo 12/24/2002 08:05'!
isBreakableAt: index in: text

	self subclassResponsibility.
! !

!Unicode class methodsFor: 'accessing - displaying' stamp: 'yo 12/24/2002 08:05'!
printingDirection

	self subclassResponsibility.
! !

!Unicode class methodsFor: 'accessing - displaying' stamp: 'yo 1/2/2003 14:25'!
scanSelector

	^ #scanMultiCharactersCombiningFrom:to:in:rightX:stopConditions:kern:.
	"^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:."
! !


!Unicode class methodsFor: 'character classification' stamp: 'yo 12/1/2003 18:24'!
isDigit: char

	| value |
	value _ char charCode.

	value > (GeneralCategory size - 1) ifTrue: [^ false].
	^ (GeneralCategory at: value+1) = 'Nd'.
! !

!Unicode class methodsFor: 'character classification' stamp: 'yo 12/1/2003 18:25'!
isLetter: char

	| value result |
	value _ char charCode.

	value > (GeneralCategory size - 1) ifTrue: [^ false].
	result _ GeneralCategory at: value+1.
	^ result first = $L.
! !

!Unicode class methodsFor: 'character classification' stamp: 'yo 12/1/2003 18:25'!
isLowercase: char

	| value |
	value _ char charCode.

	value > (GeneralCategory size - 1) ifTrue: [^ false].
	^ (GeneralCategory at: value+1) = 'Ll'.
! !

!Unicode class methodsFor: 'character classification' stamp: 'yo 12/1/2003 18:25'!
isUppercase: char

	| value |
	value _ char charCode.

	value > (GeneralCategory size - 1) ifTrue: [^ false].
	^ (GeneralCategory at: value+1) = 'Lu'.
! !


!Unicode class methodsFor: 'class methods' stamp: 'yo 12/24/2002 07:49'!
compoundTextFinalChar

	self shouldNotImplement.
! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 12/24/2002 08:03'!
compoundTextSequence

	self subclassResponsibility.
! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 1/19/2005 10:58'!
digitValue: char

	| value |
	value _ char charCode.
	value <= $9 asciiValue 
		ifTrue: [^value - $0 asciiValue].
	value >= $A asciiValue 
		ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]].

	value > (DecimalProperty size - 1) ifTrue: [^ -1].
	^ (DecimalProperty at: value+1)
! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 2/20/2004 14:12'!
generalCategory

	^ GeneralCategory.

! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 8/5/2003 16:12'!
generalCategoryComment
"
Lu Letter, Uppercase 
Ll Letter, Lowercase 
Lt Letter, Titlecase 
Lm Letter, Modifier 
Lo Letter, Other 
Mn Mark, Non-Spacing 
Mc Mark, Spacing Combining 
Me Mark, Enclosing 
Nd Number, Decimal 
Nl Number, Letter 
No Number, Other 
Pc Punctuation, Connector 
Pd Punctuation, Dash 
Ps Punctuation, Open 
Pe Punctuation, Close 
Pi Punctuation, Initial quote (may behave like Ps or Pe depending on usage) 
Pf Punctuation, Final quote (may behave like Ps or Pe depending on usage) 
Po Punctuation, Other 
Sm Symbol, Math 
Sc Symbol, Currency 
Sk Symbol, Modifier 
So Symbol, Other 
Zs Separator, Space 
Zl Separator, Line 
Zp Separator, Paragraph 
Cc Other, Control 
Cf Other, Format 
Cs Other, Surrogate 
Co Other, Private Use 
Cn Other, Not Assigned (no characters in the file have this property) 
"! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 12/4/2004 22:47'!
isCharset

	^ false.
! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 8/4/2003 11:50'!
leadingChar

	^ 255.
! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 12/24/2002 08:03'!
nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state

	self subclassResponsibility.
! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 1/15/2004 17:23'!
parseUnicodeDataFrom: stream
"
	self halt.
	self parseUnicodeDataFile
"

	| line fieldEnd point fieldStart toNumber generalCategory decimalProperty |

	toNumber _ [:quad | ('16r', quad) asNumber].

	GeneralCategory _ SparseLargeTable new: 16rE0080 chunkSize: 1024 arrayClass: Array base: 1 defaultValue:  'Cn'.
	DecimalProperty _ SparseLargeTable new: 16rE0080 chunkSize: 32 arrayClass: Array base: 1 defaultValue: -1.

	16r3400 to: 16r4DB5 do: [:i | GeneralCategory at: i+1 put: 'Lo'].
	16r4E00 to: 16r9FA5 do: [:i | GeneralCategory at: i+1 put: 'Lo'].
	16rAC00 to: 16rD7FF do: [:i | GeneralCategory at: i+1 put: 'Lo'].

	[(line _ stream upTo: Character cr) size > 0] whileTrue: [
		fieldEnd _ line indexOf: $; startingAt: 1.
		point _ toNumber value: (line copyFrom: 1 to: fieldEnd - 1).
		point > 16rE007F ifTrue: [
			GeneralCategory zapDefaultOnlyEntries.
			DecimalProperty zapDefaultOnlyEntries.
			^ self].
		2 to: 3 do: [:i |
			fieldStart _ fieldEnd + 1.
			fieldEnd _ line indexOf: $; startingAt: fieldStart.
		].
		generalCategory _ line copyFrom: fieldStart to: fieldEnd - 1.
		GeneralCategory at: point+1 put: generalCategory.
		generalCategory = 'Nd' ifTrue: [
			4 to: 7 do: [:i |
				fieldStart _ fieldEnd + 1.
				fieldEnd _ line indexOf: $; startingAt: fieldStart.
			].
			decimalProperty _  line copyFrom: fieldStart to: fieldEnd - 1.
			DecimalProperty at: point+1 put: decimalProperty asNumber.
		].
	].
	GeneralCategory zapDefaultOnlyEntries.
	DecimalProperty zapDefaultOnlyEntries.
! !

!Unicode class methodsFor: 'class methods' stamp: 'yo 12/24/2002 08:04'!
ucsTable

	^ UCSTable latin1Table.
! !


!Unicode class methodsFor: 'comments' stamp: 'yo 12/23/2002 13:04'!
blocks320Comment

"# Blocks-3.2.0.txt
# Correlated with Unicode 3.2
# Start Code..End Code; Block Name
0000..007F; Basic Latin
0080..00FF; Latin-1 Supplement
0100..017F; Latin Extended-A
0180..024F; Latin Extended-B
0250..02AF; IPA Extensions
02B0..02FF; Spacing Modifier Letters
0300..036F; Combining Diacritical Marks
0370..03FF; Greek and Coptic
0400..04FF; Cyrillic
0500..052F; Cyrillic Supplementary
0530..058F; Armenian
0590..05FF; Hebrew
0600..06FF; Arabic
0700..074F; Syriac
0780..07BF; Thaana
0900..097F; Devanagari
0980..09FF; Bengali
0A00..0A7F; Gurmukhi
0A80..0AFF; Gujarati
0B00..0B7F; Oriya
0B80..0BFF; Tamil
0C00..0C7F; Telugu
0C80..0CFF; Kannada
0D00..0D7F; Malayalam
0D80..0DFF; Sinhala
0E00..0E7F; Thai
0E80..0EFF; Lao
0F00..0FFF; Tibetan
1000..109F; Myanmar
10A0..10FF; Georgian
1100..11FF; Hangul Jamo
1200..137F; Ethiopic
13A0..13FF; Cherokee
1400..167F; Unified Canadian Aboriginal Syllabics
1680..169F; Ogham
16A0..16FF; Runic
1700..171F; Tagalog
1720..173F; Hanunoo
1740..175F; Buhid
1760..177F; Tagbanwa
1780..17FF; Khmer
1800..18AF; Mongolian
1E00..1EFF; Latin Extended Additional
1F00..1FFF; Greek Extended
2000..206F; General Punctuation
2070..209F; Superscripts and Subscripts
20A0..20CF; Currency Symbols
20D0..20FF; Combining Diacritical Marks for Symbols
2100..214F; Letterlike Symbols
2150..218F; Number Forms
2190..21FF; Arrows
2200..22FF; Mathematical Operators
2300..23FF; Miscellaneous Technical
2400..243F; Control Pictures
2440..245F; Optical Character Recognition
2460..24FF; Enclosed Alphanumerics
2500..257F; Box Drawing
2580..259F; Block Elements
25A0..25FF; Geometric Shapes
2600..26FF; Miscellaneous Symbols
2700..27BF; Dingbats
27C0..27EF; Miscellaneous Mathematical Symbols-A
27F0..27FF; Supplemental Arrows-A
2800..28FF; Braille Patterns
2900..297F; Supplemental Arrows-B
2980..29FF; Miscellaneous Mathematical Symbols-B
2A00..2AFF; Supplemental Mathematical Operators
2E80..2EFF; CJK Radicals Supplement
2F00..2FDF; Kangxi Radicals
2FF0..2FFF; Ideographic Description Characters
3000..303F; CJK Symbols and Punctuation
3040..309F; Hiragana
30A0..30FF; Katakana
3100..312F; Bopomofo
3130..318F; Hangul Compatibility Jamo
3190..319F; Kanbun
31A0..31BF; Bopomofo Extended
31F0..31FF; Katakana Phonetic Extensions
3200..32FF; Enclosed CJK Letters and Months
3300..33FF; CJK Compatibility
3400..4DBF; CJK Unified Ideographs Extension A
4E00..9FFF; CJK Unified Ideographs
A000..A48F; Yi Syllables
A490..A4CF; Yi Radicals
AC00..D7AF; Hangul Syllables
D800..DB7F; High Surrogates
DB80..DBFF; High Private Use Surrogates
DC00..DFFF; Low Surrogates
E000..F8FF; Private Use Area
F900..FAFF; CJK Compatibility Ideographs
FB00..FB4F; Alphabetic Presentation Forms
FB50..FDFF; Arabic Presentation Forms-A
FE00..FE0F; Variation Selectors
FE20..FE2F; Combining Half Marks
FE30..FE4F; CJK Compatibility Forms
FE50..FE6F; Small Form Variants
FE70..FEFF; Arabic Presentation Forms-B
FF00..FFEF; Halfwidth and Fullwidth Forms
FFF0..FFFF; Specials
10300..1032F; Old Italic
10330..1034F; Gothic
10400..1044F; Deseret
1D000..1D0FF; Byzantine Musical Symbols
1D100..1D1FF; Musical Symbols
1D400..1D7FF; Mathematical Alphanumeric Symbols
20000..2A6DF; CJK Unified Ideographs Extension B
2F800..2FA1F; CJK Compatibility Ideographs Supplement
E0000..E007F; Tags
F0000..FFFFF; Supplementary Private Use Area-A
100000..10FFFF; Supplementary Private Use Area-B


"! !

!Unicode class methodsFor: 'comments' stamp: 'yo 3/17/2004 23:38'!
blocks320Comment2

"# Blocks-3.2.0.txt
# Correlated with Unicode 3.2
# Start Code..End Code; Block Name
0000..007F; Basic Latin
0080..00FF; Latin-1 Supplement

 => Latin 1

0100..017F; Latin Extended-A
0180..024F; Latin Extended-B
0250..02AF; IPA Extensions

  => LatinExtended1

02B0..02FF; Spacing Modifier Letters
0300..036F; Combining Diacritical Marks

  => Modifiers

0370..03FF; Greek and Coptic
0400..04FF; Cyrillic
0500..052F; Cyrillic Supplementary
0530..058F; Armenian

   => EuropeanAlphabetic1

0590..05FF; Hebrew
0600..06FF; Arabic
0700..074F; Syriac
0780..07BF; Thaana

   => MiddleEastern

0900..097F; Devanagari
0980..09FF; Bengali
0A00..0A7F; Gurmukhi
0A80..0AFF; Gujarati
0B00..0B7F; Oriya
0B80..0BFF; Tamil
0C00..0C7F; Telugu
0C80..0CFF; Kannada
0D00..0D7F; Malayalam
0D80..0DFF; Sinhala

  => South Asian1


0E00..0E7F; Thai
0E80..0EFF; Lao

 => Southeastern 1

0F00..0FFF; Tibetan

  => South Asian1

1000..109F; Myanmar

 => Southeastern 1


10A0..10FF; Georgian

   => European Alphabetic 2

1100..11FF; Hangul Jamo

   => Korean

1200..137F; Ethiopic
13A0..13FF; Cherokee
1400..167F; Unified Canadian Aboriginal Syllabics

  => Additional1

1680..169F; Ogham
16A0..16FF; Runic

  => European Alphabetic 3

1700..171F; Tagalog
1720..173F; Hanunoo
1740..175F; Buhid
1760..177F; Tagbanwa
1780..17FF; Khmer

  => Southeastern2

1800..18AF; Mongolian

  => Additional2

1E00..1EFF; Latin Extended Additional
1F00..1FFF; Greek Extended

  => EuropeanAlphabetic4

2000..206F; General Punctuation
2070..209F; Superscripts and Subscripts
20A0..20CF; Currency Symbols
20D0..20FF; Combining Diacritical Marks for Symbols
2100..214F; Letterlike Symbols
2150..218F; Number Forms
2190..21FF; Arrows
2200..22FF; Mathematical Operators
2300..23FF; Miscellaneous Technical
2400..243F; Control Pictures
2440..245F; Optical Character Recognition
2460..24FF; Enclosed Alphanumerics
2500..257F; Box Drawing
2580..259F; Block Elements
25A0..25FF; Geometric Shapes
2600..26FF; Miscellaneous Symbols
2700..27BF; Dingbats
27C0..27EF; Miscellaneous Mathematical Symbols-A
27F0..27FF; Supplemental Arrows-A
2800..28FF; Braille Patterns
2900..297F; Supplemental Arrows-B
2980..29FF; Miscellaneous Mathematical Symbols-B
2A00..2AFF; Supplemental Mathematical Operators

  => Symbols2

2E80..2EFF; CJK Radicals Supplement
2F00..2FDF; Kangxi Radicals
2FF0..2FFF; Ideographic Description Characters
3000..303F; CJK Symbols and Punctuation
3040..309F; Hiragana
30A0..30FF; Katakana
3100..312F; Bopomofo
3130..318F; Hangul Compatibility Jamo
3190..319F; Kanbun
31A0..31BF; Bopomofo Extended
31F0..31FF; Katakana Phonetic Extensions
3200..32FF; Enclosed CJK Letters and Months
3300..33FF; CJK Compatibility
3400..4DBF; CJK Unified Ideographs Extension A
4E00..9FFF; CJK Unified Ideographs
A000..A48F; Yi Syllables
A490..A4CF; Yi Radicals

  => CJK

AC00..D7AF; Hangul Syllables

  => Korean

D800..DB7F; High Surrogates
DB80..DBFF; High Private Use Surrogates
DC00..DFFF; Low Surrogates
E000..F8FF; Private Use Area

F900..FAFF; CJK Compatibility Ideographs

  => CJK

FB00..FB4F; Alphabetic Presentation Forms
FB50..FDFF; Arabic Presentation Forms-A

  => Middle Eastern 2

FE00..FE0F; Variation Selectors
FE20..FE2F; Combining Half Marks

FE30..FE4F; CJK Compatibility Forms

  => CJK

FE50..FE6F; Small Form Variants

 => Symbol3

FE70..FEFF; Arabic Presentation Forms-B

  => Middle Eastern 3

FF00..FFEF; Halfwidth and Fullwidth Forms
FFF0..FFFF; Specials

  => Specials

10300..1032F; Old Italic
10330..1034F; Gothic
10400..1044F; Deseret

   => European

1D000..1D0FF; Byzantine Musical Symbols
1D100..1D1FF; Musical Symbols
1D400..1D7FF; Mathematical Alphanumeric Symbols

  => Symbols

20000..2A6DF; CJK Unified Ideographs Extension B
2F800..2FA1F; CJK Compatibility Ideographs Supplement

  => CJK

E0000..E007F; Tags
F0000..FFFFF; Supplementary Private Use Area-A
100000..10FFFF; Supplementary Private Use Area-B

  => Special

"! !


!Unicode class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:33'!
charFromUnicode: uniCode

	^ Character leadingChar: self leadingChar code: uniCode
! !

!Unicode class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:33'!
value: code

	| l |
	code < 256 ifTrue: [^ Character value: code].
	l _ Locale currentPlatform languageEnvironment leadingChar.
	l = 0 ifTrue: [l _ 255].
	^ Character leadingChar: l code: code.
! !


!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 18:11'!
isJapanese: code

	^ code > 255 and: [(JISX0208 charFromUnicode: code) notNil].
! !

!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 18:11'!
isKorean: code

	^ code > 255 and: [(KSX1001 charFromUnicode: code) notNil]

! !

!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 18:11'!
isSimplifiedChinese: code

	^ code > 255 and: [(GB2312 charFromUnicode: code) notNil]


! !

!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 18:00'!
isTraditionalChinese: code

	^ false.
! !

!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 17:55'!
isUnifiedKanji: code

	^ ((((16r2E80 <= code and: [code <= 16rA4CF])
		or: [16rF900 <= code and: [code <= 16rFAFF]])
			or: [16rFE30 <= code and: [code <= 16rFE4F]])
				or: [16rFF00 <= code and: [code <= 16rFFEF]])
					or: [16r20000 <= code and: [code <= 16r2FA1F]].
! !
KeyboardInputInterpreter subclass: #UnixEUCJPInputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!UnixEUCJPInputInterpreter methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/7/2003 15:11'!
initialize

	converter _ EUCJPTextConverter new.
! !

!UnixEUCJPInputInterpreter methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/7/2003 20:25'!
nextCharFrom: sensor firstEvt: evtBuf

	| firstChar secondChar peekEvent keyValue type stream multiChar |
	keyValue _ evtBuf third.
	evtBuf fourth = EventKeyChar ifTrue: [type _ #keystroke].
	peekEvent _ sensor peekEvent.
	(peekEvent notNil and: [peekEvent fourth = EventKeyDown]) ifTrue: [
		sensor nextEvent.
		peekEvent _ sensor peekEvent].

	(type == #keystroke
	and: [peekEvent notNil 
	and: [peekEvent first = EventTypeKeyboard
	and: [peekEvent fourth = EventKeyChar]]]) ifTrue: [
		firstChar _ keyValue asCharacter.
		secondChar _ (peekEvent third) asCharacter.
		stream _ ReadStream on: (String with: firstChar with: secondChar).
		multiChar _ converter nextFromStream: stream.
		multiChar isOctetCharacter ifFalse: [sensor nextEvent].
		^ multiChar].

	^ keyValue asCharacter! !
FileDirectory subclass: #UnixFileDirectory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Files-Directories'!
!UnixFileDirectory commentStamp: '<historical>' prior: 0!
I represent a Unix FileDirectory.
!


!UnixFileDirectory methodsFor: 'file names' stamp: 'yo 12/19/2003 21:15'!
fullPathFor: path
	"Return the fully-qualified path name for the given file."
	path isEmpty ifTrue: [^ pathName asSqueakPathName].
	path first = $/ ifTrue: [^ path].
	^ pathName asSqueakPathName = '/'			"Only root dir ends with a slash"
		ifTrue: ['/' , path]
		ifFalse: [pathName asSqueakPathName , '/' , path]! !

!UnixFileDirectory methodsFor: 'file names' stamp: 'ar 10/18/2004 10:58'!
pathFromUrl: aFileUrl
	^'/', (super pathFromUrl: aFileUrl)! !


!UnixFileDirectory methodsFor: 'testing' stamp: 'sr 5/8/2000 12:58'!
directoryExists: filenameOrPath
	"Handles the special case of testing for the root dir: there isn't a
	possibility to express the root dir as full pathname like '/foo'."

	^ filenameOrPath = '/' or: [super directoryExists: filenameOrPath]! !

!UnixFileDirectory methodsFor: 'testing' stamp: 'sr 5/8/2000 13:03'!
fileOrDirectoryExists: filenameOrPath 
	"Handles the special case of testing for the root dir: there isn't a 
	possibility to express the root dir as full pathname like '/foo'."

	^ filenameOrPath = '/' or: [super fileOrDirectoryExists: filenameOrPath]! !


!UnixFileDirectory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:32'!
setPathName: pathString
	"Unix path names start with a leading delimiter character."

	(pathString isEmpty or: [pathString first ~= self pathNameDelimiter])
		ifTrue: [pathName := FilePath pathName: (self pathNameDelimiter asString, pathString)]
		ifFalse: [pathName := FilePath pathName: pathString].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UnixFileDirectory class
	instanceVariableNames: ''!

!UnixFileDirectory class methodsFor: 'platform specific' stamp: 'yo 2/4/1999 06:40'!
maxFileNameLength

	^ 255! !

!UnixFileDirectory class methodsFor: 'platform specific' stamp: 'jm 9/17/97 15:48'!
pathNameDelimiter

	^ $/
! !
ClipboardInterpreter subclass: #UnixJPClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!UnixJPClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/25/2003 17:54'!
fromSystemClipboard: aString
	^ aString convertFromSystemString! !

!UnixJPClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/25/2003 17:54'!
toSystemClipboard: text

	| string |
	"self halt."
	string _ text asString.
	string isAsciiString ifTrue: [^ string asOctetString].
	string isOctetString ifTrue: [^ string "hmm"].
	^ string convertToSystemString .
! !
KeyboardInputInterpreter subclass: #UnixUTF8JPInputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!UnixUTF8JPInputInterpreter methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/25/2003 18:36'!
initialize

	converter _ UTF8TextConverter new.! !

!UnixUTF8JPInputInterpreter methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/25/2003 19:40'!
nextCharFrom: sensor firstEvt: evtBuf

	| firstChar aCollection bytes peekEvent keyValue type stream multiChar |
	keyValue _ evtBuf third.
	evtBuf fourth = EventKeyChar ifTrue: [type _ #keystroke].
	peekEvent _ sensor peekEvent.
	(peekEvent notNil and: [peekEvent fourth = EventKeyDown]) ifTrue: [
		sensor nextEvent.
		peekEvent _ sensor peekEvent].

	(type == #keystroke
	and: [peekEvent notNil 
	and: [peekEvent first = EventTypeKeyboard
	and: [peekEvent fourth = EventKeyChar]]]) ifTrue: [
		firstChar _ keyValue asCharacter.
		aCollection _ OrderedCollection new.
		aCollection add: firstChar.
		bytes _ (keyValue <= 127)
			ifTrue: [ 0 ]
			ifFalse: [ (keyValue bitAnd: 16rE0) = 192
				ifTrue: [ 1 ]
				ifFalse: [ (keyValue bitAnd: 16rF0) = 224
					ifTrue: [ 2 ]
					ifFalse: [ 3 ]
				]
			].
		bytes timesRepeat: [ aCollection add: sensor nextEvent third asCharacter ].
		"aCollection do: [ :each | Transcript show: (each asciiValue hex , ' ')].
		Transcript show: Character cr."
		stream _ ReadStream on: (String withAll: aCollection).
		multiChar _ converter nextFromStream: stream.
		multiChar isOctetCharacter ifFalse: [ sensor nextEvent ].
		^ multiChar].

	^ keyValue asCharacter! !
DataType subclass: #UnknownType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!

!UnknownType methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	vocabularyName := #unknown! !


!UnknownType methodsFor: 'queries' stamp: 'sw 9/27/2001 13:37'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^ false! !


!UnknownType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 13:33'!
affordsCoercionToBoolean
	"Answer true if a tile of this data type, when dropped into a pane that demands a boolean, could plausibly be expanded into a comparison (of the form  frog < toad   or frog = toad) to provide a boolean expression"

	^ false! !

!UnknownType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:33'!
wantsArrowsOnTiles
	"Answer whether this data type wants up/down arrows on tiles representing its values"

	^ false! !
FMSound subclass: #UnloadedSound
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!UnloadedSound commentStamp: '<historical>' prior: 0!
Instances of me, which are really just FMSounds, are used placeholders for sounds that have been unloaded from this image but which may be re-loaded later.
!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UnloadedSound class
	instanceVariableNames: ''!

!UnloadedSound class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
default
	"UnloadedSound default play"

	| snd p |
	snd := super new modulation: 1 ratio: 1.
	p := OrderedCollection new.
	p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !
UnscriptedPlayer subclass: #UnscriptedCardPlayer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!

!UnscriptedCardPlayer methodsFor: 'uniclass' stamp: 'sw 1/30/2001 22:42'!
rootClassForUniclasses
	"Answer the class that should be subclassed when the receiver is made into a uniclass"

	^ CardPlayer! !
Player subclass: #UnscriptedPlayer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!UnscriptedPlayer commentStamp: '<historical>' prior: 0!
My instances are Player objects that have not been scripted, and which hence do not require a unique scripts dictionary, etc.  As soon as the needed, I am transformed automatically into a unique subclass of Player.!


!UnscriptedPlayer methodsFor: 'copying' stamp: 'tk 10/4/2001 13:43'!
copyUniClassWith: deepCopier
	
	self error: 'oops, copyUniClass sent to an UnscriptedPlayer'! !


!UnscriptedPlayer methodsFor: 'error handling' stamp: 'nk 8/21/2004 11:44'!
doesNotUnderstand: aMessage
	"I do not attempt the special setters that Player does.
	I merely ignore not-understood messages."
	^nil! !


!UnscriptedPlayer methodsFor: 'slots-user' stamp: 'sw 12/28/1998 10:27'!
hasUserDefinedScripts
	^ false! !


!UnscriptedPlayer methodsFor: 'testing' stamp: 'sw 10/19/1999 08:30'!
wantsSteps
	"Has no scripts"
	^ false! !


!UnscriptedPlayer methodsFor: 'uniclass' stamp: 'sw 1/30/2001 22:42'!
rootClassForUniclasses
	"Answer the class that should be subclassed when the receiver is made into a uniclass"

	^ Player! !


!UnscriptedPlayer methodsFor: 'viewer' stamp: 'sw 1/30/2001 22:43'!
assureUniClass
	"Create a uniclass and become the receiver into it"

	| anInstance |
	anInstance _ self rootClassForUniclasses instanceOfUniqueClass.
	anInstance initializeCostumesFrom: self.
	self become: anInstance.
	^ anInstance! !

!UnscriptedPlayer methodsFor: 'viewer' stamp: 'sw 8/10/1998 16:23'!
belongsToUniClass
	^ false! !

!UnscriptedPlayer methodsFor: 'viewer' stamp: 'sw 12/28/1998 10:27'!
hasUserDefinedSlots
	^ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UnscriptedPlayer class
	instanceVariableNames: 'ephemeralPlayerRef'!

!UnscriptedPlayer class methodsFor: 'compiling' stamp: 'sw 8/10/1998 16:23'!
acceptsLoggingOfCompilation
	^ true! !

!UnscriptedPlayer class methodsFor: 'compiling' stamp: 'sw 9/15/1998 13:49'!
wantsChangeSetLogging
	^ true! !


!UnscriptedPlayer class methodsFor: 'instance creation' stamp: 'sw 10/23/1999 22:51'!
isUniClass
	^ false! !

!UnscriptedPlayer class methodsFor: 'instance creation' stamp: 'sw 9/15/1998 13:33'!
newUserInstance
	"Answer an instance of an appropriate class to serve as a user object in the containment hierarchy"

	^ self new! !


!UnscriptedPlayer class methodsFor: 'namespace' stamp: 'sw 9/30/1998 09:05'!
referenceSelectorFor: anObject
	"The use of this is for immediate evaluation of lines of script in a Viewer.  The class inst var 'ephemeralPlayerRef' is constantly reused for this purpose."

	ephemeralPlayerRef _ anObject.
	^ 'ephemeralPlayerRef'! !


!UnscriptedPlayer class methodsFor: 'reference' stamp: 'sw 9/30/1998 09:14'!
ephemeralPlayerRef
	"UnscriptedPlayer ephemeralPlayerRef"
	^ ephemeralPlayerRef! !


!UnscriptedPlayer class methodsFor: 'testing' stamp: 'sw 8/17/1998 07:33'!
isSystemDefined
	^ true! !

!UnscriptedPlayer class methodsFor: 'testing' stamp: 'sw 8/17/1998 07:34'!
officialClass
	^ self! !
UpdatingStringMorph subclass: #UpdatingBooleanStringMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!UpdatingBooleanStringMorph commentStamp: '<historical>' prior: 0!
A customized updating-string-morph used for displaying and editing boolean values; mouse-down on one of these is inerpreted as a request to toggle.!


!UpdatingBooleanStringMorph methodsFor: 'event handling' stamp: 'sw 10/1/1998 16:59'!
handlesMouseDown: evt
	^ true! !

!UpdatingBooleanStringMorph methodsFor: 'event handling' stamp: 'sw 6/16/1999 13:30'!
mouseDown: evt
	self color: Color red! !

!UpdatingBooleanStringMorph methodsFor: 'event handling' stamp: 'nb 6/17/2003 12:25'!
mouseUp: evt
	(bounds containsPoint: evt cursorPoint)
		ifTrue:
			[self contentsClipped: (target perform: getSelector) not asString.
			self informTarget]
		ifFalse:
			[Beeper beep].
	self color: Color black! !


!UpdatingBooleanStringMorph methodsFor: 'target access' stamp: 'dgd 2/22/2003 18:59'!
informTarget
	"Determine a value by evaluating my readout, and send that value to my target"

	| newValue |
	(target notNil and: [putSelector notNil]) 
		ifTrue: 
			[newValue := self valueFromContents.
			newValue ifNotNil: 
					[target 
						perform: putSelector
						with: getSelector
						with: newValue.
					target isMorph ifTrue: [target changed]].
			self growable 
				ifTrue: 
					[self
						readFromTarget;
						fitContents.
					owner updateLiteralLabel]]! !
MenuItemMorph subclass: #UpdatingMenuItemMorph
	instanceVariableNames: 'wordingProvider wordingSelector enablementSelector wordingArgument'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!UpdatingMenuItemMorph commentStamp: '<historical>' prior: 0!
A menu item whose textual label and whose enablement are updatable.  The wordingProvider provides the current wording, upon being being sent the wordingSelector.

The item can also dynamically update whether or not it should be enabled; to do this, give it an enablementSelector, which is also sent to the wordingProvider..!


!UpdatingMenuItemMorph methodsFor: 'enablement' stamp: 'ajh 1/21/2003 13:17'!
enablement 

	enablementSelector isBlock
		ifTrue: [^ enablementSelector value]
		ifFalse: [enablementSelector numArgs = 0
				ifTrue: [^ wordingProvider perform: enablementSelector]
				ifFalse: [^ wordingProvider perform: enablementSelector
										withArguments: arguments]]! !

!UpdatingMenuItemMorph methodsFor: 'enablement' stamp: 'aoy 2/17/2003 01:18'!
enablementSelector: aSelector 
	enablementSelector := (aSelector isKindOf: BlockContext) 
				ifTrue: [aSelector copyForSaving]
				ifFalse: [aSelector] ! !


!UpdatingMenuItemMorph methodsFor: 'stepping and presenter' stamp: 'ar 10/7/2000 15:35'!
arrangeToStartSteppingIn: aWorld
	super arrangeToStartSteppingIn: aWorld.
	self updateContents.! !

!UpdatingMenuItemMorph methodsFor: 'stepping and presenter' stamp: 'ar 10/7/2000 15:34'!
step
	super step.
	self updateContents.! !


!UpdatingMenuItemMorph methodsFor: 'testing' stamp: 'sw 6/11/1999 18:31'!
stepTime
	^ 1200! !


!UpdatingMenuItemMorph methodsFor: 'wording' stamp: 'sw 11/6/2000 09:55'!
wordingArgument: anArgument
	"Set the receiver's wordingArgument as indicated"

	wordingArgument _ anArgument! !

!UpdatingMenuItemMorph methodsFor: 'wording' stamp: 'sw 6/11/1999 15:12'!
wordingProvider: aProvider wordingSelector: aSelector
	wordingProvider _ aProvider.
	wordingSelector _ aSelector! !


!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'nk 4/13/2004 15:38'!
updateContents
	"Update the receiver's contents"

	| newString enablement nArgs |
	((wordingProvider isNil) or: [wordingSelector isNil]) ifTrue: [^ self].
	nArgs _ wordingSelector numArgs.
	newString _ nArgs == 0
		ifTrue:
			[wordingProvider perform: wordingSelector]
		ifFalse:
			[(nArgs == 1 and: [wordingArgument notNil])
				ifTrue:
					[wordingProvider perform: wordingSelector with: wordingArgument]
				ifFalse:
					[nArgs == arguments size ifTrue:
						[wordingProvider perform: wordingSelector withArguments: arguments]]].
	newString = (self contentString ifNil: [ contents ])
		ifFalse: [self contents: newString.
			MenuIcons decorateMenu: owner ].
	enablementSelector ifNotNil:
		[(enablement _ self enablement) == isEnabled 
			ifFalse:	[self isEnabled: enablement]]! !


!UpdatingMenuItemMorph methodsFor: '*MorphicExtras-e-toy support' stamp: 'ar 3/17/2001 20:18'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	wordingProvider _ wordingProvider adaptedToWorld: aWorld.! !
MenuMorph subclass: #UpdatingMenuMorph
	instanceVariableNames: 'updater updateSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!

!UpdatingMenuMorph methodsFor: 'initialization' stamp: 'sw 4/23/2001 11:02'!
updater: anObject updateSelector: aSelector
	"Set the receiver's updater and updateSelector"

	updater _ anObject.
	updateSelector _ aSelector! !


!UpdatingMenuMorph methodsFor: 'update' stamp: 'sw 4/23/2001 11:13'!
updateMenu
	"Reconstitute the menu by first removing the contents and then building it afresh"

	self removeAllMorphs.
	updater perform: updateSelector with: self

! !
RectangleMorph subclass: #UpdatingRectangleMorph
	instanceVariableNames: 'target lastValue getSelector putSelector contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Support'!
!UpdatingRectangleMorph commentStamp: '<historical>' prior: 0!
Intended for use as a color swatch coupled to a color obtained from the target, but made just slightly more general than that.!


!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 9/4/97 21:43'!
contents
	^ contents! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 9/4/97 21:43'!
contents: c
	contents _ c! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 16:31'!
getSelector
	"Answer the getSelector"

	^ getSelector! !

!UpdatingRectangleMorph methodsFor: 'accessing'!
getSelector: aSymbol

	getSelector _ aSymbol.
! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:28'!
isEtoyReadout
	"Answer whether the receiver can serve as an etoy readout"

	^ true! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 10/30/97 00:55'!
putSelector
	^ putSelector! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 10/30/97 00:55'!
putSelector: aSymbol
	putSelector _ aSymbol! !

!UpdatingRectangleMorph methodsFor: 'accessing'!
target

	^ target
! !

!UpdatingRectangleMorph methodsFor: 'accessing'!
target: anObject

	target _ anObject.
! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:22'!
userEditsAllowed
	"Answer whether it is suitable for a user to change the value represented by this readout"

	^ putSelector notNil! !


!UpdatingRectangleMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:17'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].! !

!UpdatingRectangleMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:17'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
lastValue _ lastValue veryDeepCopyWith: deepCopier.
"getSelector _ getSelector.		a Symbol"
"putSelector _ putSelector.		a Symbol"
contents _ contents veryDeepCopyWith: deepCopier.! !


!UpdatingRectangleMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:45'!
handlesMouseDown: evt 
	^putSelector notNil! !

!UpdatingRectangleMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 18:54'!
mouseUp: evt

	self changeColorTarget: self selector: #setTargetColor: originalColor: color hand: evt hand.! !


!UpdatingRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color lightGray lighter! !


!UpdatingRectangleMorph methodsFor: 'setting' stamp: 'sw 3/23/2001 23:26'!
setTargetColor: aColor
	"Set my target's color as indicated"

	putSelector ifNotNil:
		[self color: aColor.
		contents _ aColor.
		self valueProvider perform: self putSelector withArguments: (Array with: aColor)]
! !

!UpdatingRectangleMorph methodsFor: 'setting' stamp: 'sw 3/23/2001 13:24'!
valueProvider
	"Answer the object to which my get/set messages should be sent.  This is inefficient and contorted in order to support grandfathered content for an earlier design"

	^ target isMorph
		ifTrue:
			[target topRendererOrSelf player ifNil: [target]]
		ifFalse:
			[target]! !


!UpdatingRectangleMorph methodsFor: 'stepping and presenter' stamp: 'sw 7/15/1999 07:27'!
step
	| s |
	super step.
	s _ self readFromTarget.
	s = contents ifFalse:
		[self contents: s.
		self color: s]
! !


!UpdatingRectangleMorph methodsFor: 'target access' stamp: 'dgd 2/22/2003 14:40'!
readFromTarget
	"Read the color value from my target"

	| v |
	(target isNil or: [getSelector isNil]) ifTrue: [^contents].
	target isMorph ifTrue: [target isInWorld ifFalse: [^contents]].
	v := self valueProvider perform: getSelector.
	lastValue := v.
	^v! !


!UpdatingRectangleMorph methodsFor: 'testing'!
stepTime

	^ 50! !
SimpleButtonMorph subclass: #UpdatingSimpleButtonMorph
	instanceVariableNames: 'wordingProvider wordingSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!UpdatingSimpleButtonMorph commentStamp: '<historical>' prior: 0!
Adds to SimpleButtonMorph the ability to keep its own wording up to date by send a given message (indicated by its wordingSelector) to a given object (indicated by its wordingTarget, and normally the same as its target.)!


!UpdatingSimpleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/11/1999 18:30'!
wordingSelector: aSelector
	wordingSelector _ aSelector.
	wordingProvider ifNil: [wordingProvider _ target]! !


!UpdatingSimpleButtonMorph methodsFor: 'stepping and presenter' stamp: 'sw 10/30/2000 08:56'!
step
	"If appropriate update the receiver's label"

	| newString |
	super step.
	wordingProvider ifNotNil:
		[newString _ wordingProvider perform: wordingSelector.
		newString = self label ifFalse: [self labelString: newString; changed]]! !


!UpdatingSimpleButtonMorph methodsFor: 'testing' stamp: 'sw 10/30/2000 08:57'!
stepTime
	"Answer the desired time between steps in milliseconds.  If the receiver has a wordingProvider that may dynamically provide changed wording for the label, step once every 1.5 seconds"

	^ wordingProvider ifNotNil: [1500] ifNil: [super stepTime]! !

!UpdatingSimpleButtonMorph methodsFor: 'testing' stamp: 'sw 10/30/2000 08:55'!
wantsSteps
	"Answer whether the receiver wishes to be sent the #step message.  In the current case, this decision depends on whether there is a wordingProvider which can dynamically provide fresh wording for the button's label"

	^ wordingProvider notNil! !
StringMorph subclass: #UpdatingStringMorph
	instanceVariableNames: 'format target lastValue getSelector putSelector floatPrecision growable stepTime autoAcceptOnFocusLoss minimumWidth maximumWidth'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!UpdatingStringMorph commentStamp: '<historical>' prior: 0!
A StringMorph that constantly tries to show the current data from the target object.  When sent #step, it shows what the target objects has (target perform: getSelector).  When edited (with shift-click), it writes back to the target.

floatPrecision = 1. to round to integer.
floatPrecision = .1 to round to 1 decimal place, etc.

Even when ((target == nil) or: [getSelector == nil]), the user would still like to edit the string with shift-click.!


!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/9/1999 16:47'!
autoAcceptOnFocusLoss
	^ autoAcceptOnFocusLoss ~~ false! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 10:45'!
autoAcceptOnFocusLoss: aBoolean
	autoAcceptOnFocusLoss _ aBoolean! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:15'!
contents: newContents 
	"This is the original StringMorph implementation of #contents:, restored down in UpdatingStringMorph because a recent 'optimization' of the StringMorph version of this method broke UpdatingStringMorphs."

	contents := newContents isText 
				ifTrue:  
					[emphasis := newContents emphasisAt: 1.
					newContents string]
				ifFalse: 
					[contents = newContents ifTrue: [^self].	"no substantive change"
					newContents].
	self fitContents.
	self changed! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/13/2002 17:55'!
decimalPlaces
	"Answer the number of decimal places to show."

	| places |
	(places _ self valueOfProperty: #decimalPlaces) ifNotNil: [^ places].
	self setProperty: #decimalPlaces toValue: (places _ Utilities decimalPlacesForFloatPrecision: self floatPrecision).
	^ places! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 5/26/2004 00:01'!
decimalPlaces: aNumber
	"Set the receiver's number of decimal places to be shown.  If my target is a morph or a player, tell it about the change, in case it wants to remember it."

	| constrained |
	self setProperty: #decimalPlaces toValue: (constrained _ aNumber min: 11).
	self pvtFloatPrecision: (Utilities floatPrecisionForDecimalPlaces: constrained).
	(target isKindOf: Morph orOf: Player) ifTrue:
		[target noteDecimalPlaces: constrained forGetter: getSelector]! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'ar 12/30/2001 20:48'!
fitContents

	| newExtent f |
	f _ self fontToUse.
	newExtent _ (((f widthOfString: contents) max: self minimumWidth) min: self maximumWidth)  @ f height.
	(self extent = newExtent) ifFalse:
		[self extent: newExtent.
		self changed]
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 7/27/2001 18:20'!
floatPrecision
	"Answer the floatPrecision to use:
		1.0 ->	show whole number
		0.1	->	show one digit of precision
		.01 ->	show two digits of precision
		etc.
	Initialize the floatPrecision to 1 if it is not already defined"

	floatPrecision isNumber ifFalse:
		[self target: target].  "Fixes up errant cases from earlier bug"
	^ floatPrecision
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/11/2002 14:44'!
format
	"Answer the receiver's format: #default or #string"

	^ format ifNil: [format _ #default]! !

!UpdatingStringMorph methodsFor: 'accessing'!
getSelector

	^ getSelector
! !

!UpdatingStringMorph methodsFor: 'accessing'!
getSelector: aSymbol

	getSelector _ aSymbol.
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:21'!
growable

	^ growable ~~ false
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:22'!
growable: aBoolean

	growable _ aBoolean.
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/10/1999 10:07'!
maximumWidth
	"Answer the maximum width that the receiver can have.   A nil value means no maximum, and for practical purposes results in a value of 99999 here temporarily, for help in future debugging"

	^ maximumWidth ifNil: [99999]! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/10/1999 09:59'!
minimumWidth
	"Answer the minimum width that the receiver can have.  A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!!  Obeyed by fitContents."

	^ minimumWidth ifNil: [minimumWidth _ 8]! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'tk 12/1/2000 15:08'!
minimumWidth: aWidth
	"Set the minimum width that the receiver can have.  A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!!  Obeyed by fitContents."

	minimumWidth _ aWidth! !

!UpdatingStringMorph methodsFor: 'accessing'!
putSelector

	^ putSelector
! !

!UpdatingStringMorph methodsFor: 'accessing'!
putSelector: aSymbol

	putSelector _ aSymbol.
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/13/2002 17:58'!
pvtFloatPrecision: aNumber
	"Private - Set the floatPrecision instance variable to the given number"

	floatPrecision _ aNumber! !

!UpdatingStringMorph methodsFor: 'accessing'!
target

	^ target
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 3/11/2000 20:05'!
target: anObject

	target _ anObject.
	getSelector ifNotNil: [floatPrecision _ anObject defaultFloatPrecisionFor: getSelector]
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'yo 3/16/2005 18:26'!
valueFromContents
	"Return a new value from the current contents string."

"
	| expression tilePadMorphOrNil asNumberBlock |
	asNumberBlock _ [:string | [string asNumber]
				on: Error
				do: []].
	format = #string
		ifTrue: [^ contents].
	(format = #default
			and: [self owner isKindOf: NumericReadoutTile])
		ifTrue: [^ asNumberBlock value: contents].
	tilePadMorphOrNil _ self ownerThatIsA: TilePadMorph.
	(tilePadMorphOrNil notNil
			and: [tilePadMorphOrNil type = #Number])
		ifTrue: [^ asNumberBlock value: contents].
	expression _ Vocabulary eToyVocabulary translationKeyFor: contents.
	expression isNil
		ifTrue: [expression _ contents].
	^ Compiler evaluate: expression
"

	format = #symbol ifTrue: [^ lastValue].
	format = #string ifTrue: [^ contents].
	(owner notNil and: [owner isMemberOf: NumericReadoutTile]) ifTrue: [
		^ Number readFrom: contents
	].
	target ifNotNil: [target owner ifNotNil: [
		((target owner isMemberOf: TilePadMorph) and: [target owner type = #Number])
			ifTrue: [^ Number readFrom: contents]]].
	^ Compiler evaluate: contents
! !


!UpdatingStringMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 15:37'!
veryDeepFixupWith: deepCopier
	"If target field is weakly copied, fix it here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
! !

!UpdatingStringMorph methodsFor: 'copying' stamp: 'tk 9/26/2001 05:09'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared."

	super veryDeepInner: deepCopier.
	format _ format veryDeepCopyWith: deepCopier.
	target _ target.					"Weakly copied"
	lastValue _ lastValue veryDeepCopyWith: deepCopier.
	getSelector _ getSelector.			"Symbol"
	putSelector _ putSelector.		"Symbol"
	floatPrecision _ floatPrecision veryDeepCopyWith: deepCopier.
	growable _ growable veryDeepCopyWith: deepCopier.
	stepTime _ stepTime veryDeepCopyWith: deepCopier.
	autoAcceptOnFocusLoss _ autoAcceptOnFocusLoss veryDeepCopyWith: deepCopier.
	minimumWidth _ minimumWidth veryDeepCopyWith: deepCopier.
	maximumWidth _ maximumWidth veryDeepCopyWith: deepCopier.
! !


!UpdatingStringMorph methodsFor: 'editing'!
acceptContents

	self informTarget.
! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'tk 9/26/2001 05:32'!
acceptValue: aValue

	"If target is a CardPlayer, and its costume is one of my owners, change target to its current CardPlayer"
	target class superclass == CardPlayer ifTrue: [
		(self hasOwner: target costume) ifTrue: [	
			self target: target costume player]].

	self updateContentsFrom: (self acceptValueFromTarget: aValue).
! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'dgd 8/30/2003 22:21'!
addCustomMenuItems: menu hand: aHandMorph 
	| prefix |
	super addCustomMenuItems: menu hand: aHandMorph.
	prefix := (self growable
				ifTrue: ['stop being growable']
				ifFalse: ['start being growable']) translated.
	menu add: prefix action: #toggleGrowability.
	menu add: 'decimal places...' translated action: #setPrecision.
	menu add: 'font size...' translated action: #setFontSize.
	menu add: 'font style...' translated action: #setFontStyle! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'nk 1/11/2004 15:29'!
doneWithEdits
	"If in a SyntaxMorph, shrink min width after editing"

	| editor |
	super doneWithEdits.
	(owner respondsTo: #parseNode) ifTrue: [minimumWidth _ 8].
	editor _ (submorphs detect: [ :sm | sm isKindOf: StringMorphEditor ] ifNone: [ ^self ]).
	editor delete.! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'tk 11/29/2000 13:54'!
lostFocusWithoutAccepting
	"The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits."

	self autoAcceptOnFocusLoss ifTrue: [self doneWithEdits; acceptContents]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 9/11/2002 09:57'!
setDecimalPlaces: places
	"Set the number of decimal places, and update the display."

	self decimalPlaces: places.
	self acceptValueFromTarget: lastValue! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 1/19/2000 11:48'!
setFontSize
	| sizes reply family |
	family _ font ifNil: [TextStyle default] ifNotNil: [font textStyle].
	family ifNil: [family _ TextStyle default].  "safety net -- this line SHOULD be unnecessary now"
	sizes _ 	family fontNamesWithPointSizes.
	reply _ (SelectionMenu labelList: sizes selections: sizes) startUp.
	reply ifNotNil:
		[self font: (family fontAt: (sizes indexOf: reply))]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'md 10/22/2003 16:18'!
setFontStyle
	| aList reply style |
	aList := (TextConstants select: [:anItem | anItem isKindOf: TextStyle]) 
				keys asOrderedCollection.
	reply := (SelectionMenu labelList: aList selections: aList) startUp.
	reply notNil 
		ifTrue: 
			[(style := TextStyle named: reply) ifNil: 
					[Beeper beep.
					^true].
			self font: style defaultFont]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'dgd 10/17/2003 22:50'!
setPrecision
	"Allow the user to specify a number of decimal places.  This UI is invoked from a menu.  Nowadays the precision can be set by simple type-in, making this menu approach mostly obsolete.  However, it's still useful for read-only readouts, where type-in is not allowed."

	| aMenu |
	aMenu _ MenuMorph new.
	aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
	0 to: 5 do:
		[:places |
			aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
	aMenu popUpInWorld! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 11/15/2001 20:20'!
setToAllowTextEdit
	"Set up the receiver so that it will be receptive to text editing, even if there is no putSelector provided"

	self setProperty: #okToTextEdit toValue: true! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 6/26/1998 07:47'!
toggleGrowability
	growable _ self growable not.
	self updateContentsFrom: self readFromTarget.
	growable ifTrue: [self fitContents]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 11/15/2001 09:43'!
userEditsAllowed
	"Answer whether user-edits are allowed to this field"

	^ putSelector notNil or: [self hasProperty: #okToTextEdit]! !


!UpdatingStringMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 00:17'!
handlesMouseDown: evt
	(owner wantsKeyboardFocusFor: self)
		ifTrue:[^true].
	^ super handlesMouseDown: evt! !

!UpdatingStringMorph methodsFor: 'event handling' stamp: 'sw 11/15/2001 10:15'!
mouseDown: evt
	"The mouse went down over the receiver.  If appropriate, launch a mini-editor so that the user can commence text-editing here"

	(owner wantsKeyboardFocusFor: self) ifTrue:
		[self userEditsAllowed ifTrue:
			[(owner respondsTo: #parseNode)
					ifTrue: 	"leave space for editing"
						[minimumWidth _ (49 max: minimumWidth)].
			self launchMiniEditor: evt]]! !

!UpdatingStringMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 12:59'!
wouldAcceptKeyboardFocus
	^ (self hasProperty: #okToTextEdit) or: [super wouldAcceptKeyboardFocus]! !


!UpdatingStringMorph methodsFor: 'events-processing' stamp: 'sw 11/15/2001 18:17'!
handlerForMouseDown: evt
	"Answer an object to field the mouseDown event provided, or nil if none"

	| aHandler |
	aHandler _ super handlerForMouseDown: evt.
	aHandler == self ifTrue:	[^ self]. "I would get it anyways"
	"Note: This is a hack to allow value editing in viewers"
	((owner wantsKeyboardFocusFor: self) and:
		[self userEditsAllowed]) ifTrue: [^ self].
	^ aHandler! !


!UpdatingStringMorph methodsFor: 'formats'!
useDefaultFormat
	"Use the object's own printString format."

	format _ #default.
! !

!UpdatingStringMorph methodsFor: 'formats'!
useStringFormat

	format _ #string.! !

!UpdatingStringMorph methodsFor: 'formats' stamp: 'yo 1/12/2005 14:28'!
useSymbolFormat

	format _ #symbol.! !


!UpdatingStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:44'!
initialize
	"Initialie the receiver to have default values in its instance 
	variables "
	super initialize.
""
	format _ #default.
	"formats: #string, #default"
	target _ getSelector _ putSelector _ nil.
	floatPrecision _ 1.
	growable _ true.
	stepTime _ 50.
	autoAcceptOnFocusLoss _ true.
	minimumWidth _ 8.
	maximumWidth _ 300! !


!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jm 5/26/1999 16:23'!
stepTime: mSecsPerStep

	stepTime _ mSecsPerStep truncated.
! !

!UpdatingStringMorph methodsFor: 'stepping' stamp: 'sw 6/26/1998 07:31'!
updateContentsFrom: aValue
	self growable
		ifTrue:
			[self contents: aValue]
		ifFalse:
			[self contentsClipped: aValue]! !


!UpdatingStringMorph methodsFor: 'stepping and presenter' stamp: 'sw 7/15/1999 07:28'!
step
	| s |
	super step.
	hasFocus ifFalse:
		["update contents, but only if user isn't editing this string"
		s _ self readFromTarget.
		s = contents ifFalse:
			[self updateContentsFrom: s]]
! !


!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 3/10/2005 01:53'!
acceptValueFromTarget: v
	"Accept a value from the target"

	lastValue _ v.
	self format == #string ifTrue: [^ v asString].
	self format == #symbol ifTrue: [^ v asString translated].
	(format == #default and: [v isNumber]) ifTrue:
		[^ self stringForNumericValue: v].
	^ v printString translated! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'yo 6/7/2004 21:35'!
checkTarget
	""
	getSelector ifNil: [^ true].
	^ getSelector numArgs = 0.
! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'dgd 2/22/2003 19:01'!
informTarget
	"Obtain a value from my contents, and tell my target about it.  The putSelector can take one argument (traditional) or two (as used by Croquet)"

	| newValue typeIn |
	(target notNil and: [putSelector notNil]) 
		ifTrue: 
			[typeIn := contents.
			(newValue := self valueFromContents) ifNotNil: 
					[self checkTarget.
					putSelector numArgs = 1 
						ifTrue: [target perform: putSelector with: newValue].
					putSelector numArgs = 2 
						ifTrue: 
							[target 
								perform: putSelector
								with: newValue
								with: self].
					target isMorph ifTrue: [target changed]].
			self fitContents.
			(format == #default and: [newValue isNumber]) 
				ifTrue: [self setDecimalPlacesFromTypeIn: typeIn]]! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 1/6/2005 01:27'!
isEtoyReadout
	"Answer whether the receiver can serve as an etoy readout"

	^ true! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'yo 6/9/2004 07:09'!
readFromTarget
	"Update my readout from my target"

	| v ret |
	(target isNil or: [getSelector isNil]) ifTrue: [^contents].
	ret _ self checkTarget.
	ret ifFalse: [^ '0'].
	v := target perform: getSelector.	"scriptPerformer"
	(v isKindOf: Text) ifTrue: [v := v asString].
	^self acceptValueFromTarget: v! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 3/3/2005 02:55'!
setDecimalPlacesFromTypeIn: typeIn
	"The user has typed in a number as the new value of the receiver.  Glean off decimal-places-preference from the type-in"

	| decimalPointPosition tail places |
	(typeIn includes: $e) ifTrue: [^ self].
	decimalPointPosition _ typeIn indexOf: $. ifAbsent: [nil].
	places _ 0.
	decimalPointPosition
		ifNotNil:
			[tail _ typeIn copyFrom: decimalPointPosition + 1 to: typeIn size.
			[places < tail size and: [(tail at: (places + 1)) isDigit]]
				whileTrue:
					[places _ places + 1]].
		
	self decimalPlaces: places! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 3/3/2005 02:53'!
stringForNumericValue: aValue
	"Answer a suitably-formatted string representing the value."

	| barePrintString |
	((barePrintString _ aValue printString) includes: $e)  ifTrue: [^ barePrintString].
	^ aValue printShowingDecimalPlaces: self decimalPlaces! !


!UpdatingStringMorph methodsFor: 'testing' stamp: 'jm 5/26/1999 16:17'!
stepTime

	^ stepTime ifNil: [50]
! !


!UpdatingStringMorph methodsFor: '*eToys-card in a stack' stamp: 'tk 9/26/2001 06:04'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')"

	^ true! !


!UpdatingStringMorph methodsFor: '*eToys-card & stack' stamp: 'tk 9/25/2001 11:43'!
setNewContentsFrom: stringOrNumberOrNil

	self acceptValue: stringOrNumberOrNil! !


!UpdatingStringMorph methodsFor: '*eToys-menus' stamp: 'tk 9/26/2001 06:08'!
putOnBackground
	"Place the receiver, formerly private to its card, onto the shared background.  If the receiver needs data carried on its behalf by the card, such data will be represented on every card."

	"If I seem to have per-card data, then set that up."
	target class superclass == CardPlayer ifTrue: [
		(self hasOwner: target costume) ifTrue: [	
			self setProperty: #holdsSeparateDataForEachInstance toValue: true]].
	super putOnBackground.! !


!UpdatingStringMorph methodsFor: '*eToys-player' stamp: 'tk 9/26/2001 06:06'!
currentDataValue
	"Answer the current data value held by the receiver"

	^ self valueFromContents! !

!UpdatingStringMorph methodsFor: '*eToys-player' stamp: 'tk 9/26/2001 06:10'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield.  For a numeric-readout tile."

	"Is CardPlayer class holding my variableDock, or should I be using the caching mechanism in Morph>>variableDocks?"
	^ Array with: (VariableDock new 
			variableName: (getSelector allButFirst: 3) withFirstCharacterDownshifted 
			type: #number 
			definingMorph: self 
			morphGetSelector: #valueFromContents 
			morphPutSelector: #acceptValue:)! !


!UpdatingStringMorph methodsFor: '*eToys-target access' stamp: 'sw 3/7/2004 15:49'!
hasStructureOfComplexWatcher
	"Answer whether the receiver has precisely the structure of a so-called complex watcher, as used in the etoy system."

	| top |
	top _ (self owner ifNil: [^ false]) owner.
	^ ((((top isMemberOf: AlignmentMorph)
		and: [top submorphs size = 4])
			and: [top submorphs first isMemberOf: TileMorph])
				and: [top submorphs third isMemberOf: AlignmentMorph])! !


!UpdatingStringMorph methodsFor: '*MorphicExtras-accessing' stamp: 'sw 9/13/2002 17:57'!
floatPrecision: aPrecision
	"Set the receiver's number of decimal places to correspond with the given precision.  The preferred protocol here is #decimalPlaces:, which conforms to the UI for this, but #floatPrecision: is retained for backward compatibility."

	self decimalPlaces: (Utilities decimalPlacesForFloatPrecision: aPrecision)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UpdatingStringMorph class
	instanceVariableNames: ''!

!UpdatingStringMorph class methodsFor: 'instance creation' stamp: 'sw 3/10/2000 17:27'!
on: targetObject selector: aSymbol

	^ self new
		getSelector: aSymbol;
		target: targetObject

! !
UpdatingStringMorph subclass: #UpdatingStringMorphWithArgument
	instanceVariableNames: 'argumentTarget argumentGetSelector'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!UpdatingStringMorphWithArgument methodsFor: 'as yet unclassified' stamp: 'sw 10/25/1998 00:20'!
argumentTarget: t argumentGetSelector: s
	argumentTarget _ t.
	argumentGetSelector _ s! !


!UpdatingStringMorphWithArgument methodsFor: 'copying' stamp: 'tk 1/7/1999 15:40'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
argumentTarget _ deepCopier references at: argumentTarget 
			ifAbsent: [argumentTarget].
! !

!UpdatingStringMorphWithArgument methodsFor: 'copying' stamp: 'tk 1/7/1999 15:39'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"argumentTarget _ argumentTarget.		Weakly copied"
argumentGetSelector _ argumentGetSelector veryDeepCopyWith: deepCopier.! !


!UpdatingStringMorphWithArgument methodsFor: 'target access' stamp: 'sw 10/25/1998 00:57'!
readFromTarget
	| v |
	argumentTarget ifNil: [^ super readFromTarget].
	v _ target perform: getSelector with: (argumentTarget perform: argumentGetSelector).
	^ self acceptValueFromTarget: v! !
TextMorph subclass: #UpdatingTextMorph
	instanceVariableNames: 'target getSelector growable stepTime'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!UpdatingTextMorph commentStamp: 'asm 7/31/2003 21:27' prior: 0!
A TextMorph that constantly tries to show the current data from the target object.  When sent #step, it shows what the target objects has (target perform: getSelector).!


!UpdatingTextMorph methodsFor: 'accessing' stamp: 'dgd 3/7/2004 20:16'!
getSelector
	"answer the receiver's getSelector"
	^ getSelector! !

!UpdatingTextMorph methodsFor: 'accessing' stamp: 'dgd 3/7/2004 20:16'!
getSelector: aSymbol 
	"change the receiver's getSelector"
	getSelector := aSymbol! !

!UpdatingTextMorph methodsFor: 'accessing' stamp: 'dgd 3/7/2004 20:17'!
target
	"answer the receiver's target"
	^ target! !

!UpdatingTextMorph methodsFor: 'accessing' stamp: 'dgd 3/7/2004 20:17'!
target: anObject 
	"change the receiver's target"
	target := anObject! !


!UpdatingTextMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2004 20:17'!
initialize
	"Initialie the receiver to have default values in its instance  
	variables"
	super initialize.""
	stepTime := 50! !


!UpdatingTextMorph methodsFor: 'stepping and presenter' stamp: 'dgd 3/8/2004 20:34'!
step
	"update my contents"
	| newContents |
	super step.
	""
	newContents := self contentsFromTarget.
	self visible: newContents isEmpty not.
	self contents: newContents! !

!UpdatingTextMorph methodsFor: 'stepping and presenter' stamp: 'dgd 3/7/2004 20:19'!
stepTime
	"answer the desired time between steps in milliseconds."
	^ stepTime
		ifNil: [50]! !

!UpdatingTextMorph methodsFor: 'stepping and presenter' stamp: 'dgd 3/7/2004 20:19'!
stepTime: mSecsPerStep 
	"change the receiver's stepTime"
	stepTime := mSecsPerStep rounded! !


!UpdatingTextMorph methodsFor: 'target access' stamp: 'nk 8/30/2004 16:18'!
contentsFromTarget
	"private - answer the contents from the receiver's target"
	(target isNil
			or: [getSelector isNil])
		ifTrue: [^ self contents].
	""
	^ (target perform: getSelector) asString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UpdatingTextMorph class
	instanceVariableNames: ''!

!UpdatingTextMorph class methodsFor: 'instance creation' stamp: 'dgd 3/8/2004 20:31'!
on: targetObject selector: aSymbol 
	"answer a new instance of the receiver on a given target and selector"
	^ self new getSelector: aSymbol;
		 target: targetObject! !
ThreePhaseButtonMorph subclass: #UpdatingThreePhaseButtonMorph
	instanceVariableNames: 'getSelector getArgument'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!UpdatingThreePhaseButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/8/1999 13:50'!
getSelector: sel
	getSelector _ sel! !


!UpdatingThreePhaseButtonMorph methodsFor: 'button' stamp: 'bf 10/8/1999 15:08'!
doButtonAction
	"Since the action likely changes our state, do a step so we're updated immediately"
	super doButtonAction.
	self step
! !


!UpdatingThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'bf 10/14/1999 21:11'!
mouseUp: evt
	"Since mouseUp likely changes our state, do a step so we're updated immediately"
	super mouseUp: evt.
	self step! !


!UpdatingThreePhaseButtonMorph methodsFor: 'stepping and presenter' stamp: 'tk 7/14/2000 15:27'!
step
	| newBoolean |
	super step.
	state == #pressed ifTrue: [^ self].
	newBoolean _ target perform: getSelector.
	newBoolean == self isOn
		ifFalse:
			[self state: (newBoolean == true ifTrue: [#on] ifFalse: [#off])]! !


!UpdatingThreePhaseButtonMorph methodsFor: 'testing' stamp: 'sw 3/8/1999 13:50'!
wantsSteps
	^ true! !
Object subclass: #Url
	instanceVariableNames: 'fragment'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!Url commentStamp: '<historical>' prior: 0!
A Uniform Resource Locator.  It specifies the location of a document on the Internet.  The base class is abstract; child classes break different types of URLs down in ways appropriate for that type.!


!Url methodsFor: 'accessing' stamp: 'mir 2/22/2000 18:05'!
authority
	^''! !


!Url methodsFor: 'classification' stamp: 'ar 2/27/2001 22:07'!
hasRemoteContents
	"Return true if the receiver describes some remotely accessible content.
	Typically, this should only return if we could retrieve the contents
	on an arbitrary place in the outside world using a standard browser.
	In other words: If you can get to it from the next Internet Cafe, 
	return true, else return false."
	^false! !

!Url methodsFor: 'classification' stamp: 'ls 6/16/1998 16:22'!
scheme
	"return a string with the scheme of this URL.  For instance, HTTP"
	^self subclassResponsibility! !

!Url methodsFor: 'classification' stamp: 'ls 7/3/1998 21:11'!
schemeName
	"return a lowercase string with the scheme of this URL.  For instance, 'http'"
	^self subclassResponsibility! !


!Url methodsFor: 'converting' stamp: 'ls 7/14/1998 03:17'!
asText
	^self asString asText! !

!Url methodsFor: 'converting' stamp: 'tb 5/24/2006 22:05'!
asURI
	^self asString asURI! !

!Url methodsFor: 'converting' stamp: 'ls 6/29/1998 00:36'!
asUrl
	^self! !

!Url methodsFor: 'converting' stamp: 'ls 7/3/1998 21:11'!
asUrlRelativeTo: aUrl
	^self! !

!Url methodsFor: 'converting' stamp: 'fbs 2/2/2005 13:24'!
downloadUrl
	^self asString! !


!Url methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:41'!
activate
	"spawn an external handler for this URL"
	! !

!Url methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:40'!
hasContents
	"whether this URL can download contents to be displayed; if not, it fundamentally requires an outside application to deal with it.  For example, mailto: and telnet: urls"
	^false! !

!Url methodsFor: 'downloading' stamp: 'ls 7/23/1998 20:14'!
retrieveContents
	"return a MIMEObject with the object's contents, or nil if the object could not be retrieved"
	^nil! !

!Url methodsFor: 'downloading' stamp: 'ls 7/23/1998 20:14'!
retrieveContentsForBrowser: aBrowser
	"return a MIMEObject with the object's contents, or nil if the object could not be retrieved.  Since aBrowser is specified, this could do browser specific things"
	^self retrieveContents! !


!Url methodsFor: 'fragment' stamp: 'ls 8/4/1998 01:41'!
fragment
	^fragment! !

!Url methodsFor: 'fragment' stamp: 'ls 8/4/1998 01:02'!
privateFragment: aString
	fragment _ aString! !

!Url methodsFor: 'fragment' stamp: 'ls 6/1/2000 16:19'!
withFragment: newFragment
	"return a URL which is the same except that it has a different fragment"
	^self copy privateFragment: newFragment; yourself! !

!Url methodsFor: 'fragment' stamp: 'ls 6/1/2000 16:26'!
withoutFragment
	"return a URL which is identical to the receiver except that it has no fragment associated with it"
	^self withFragment: nil! !


!Url methodsFor: 'parsing' stamp: 'ls 8/5/1998 00:57'!
newFromRelativeText: aString
	"return a URL relative to the current one, given by aString.  For instance, if self is 'http://host/dir/file', and aString is '/dir2/file2', then the return will be a Url for 'http://host/dir2/file2'"

	"if the scheme is the same, or not specified, then use the same class"

	| newSchemeName remainder fragmentStart newFragment newUrl bare |

	bare _ aString withBlanksTrimmed.
	newSchemeName _ Url schemeNameForString: bare.
	(newSchemeName isNil not and: [ newSchemeName ~= self schemeName ]) ifTrue: [
		"different scheme -- start from scratch"
		^Url absoluteFromText: aString ].

	remainder _ bare.

	"remove the fragment, if any"
	fragmentStart _ remainder indexOf: $#.
	fragmentStart > 0 ifTrue: [
		newFragment _ remainder copyFrom: fragmentStart+1 to: remainder size. 
		remainder _ remainder copyFrom: 1 to: fragmentStart-1].

	"remove the scheme name"
	newSchemeName ifNotNil: [
		remainder _ remainder copyFrom: (newSchemeName size + 2) to: remainder size ].

	"create and initialize the new url"
	newUrl _ self class new privateInitializeFromText: remainder  relativeTo: self.


	"set the fragment"
	newUrl privateFragment: newFragment.


	^newUrl! !

!Url methodsFor: 'parsing' stamp: 'ls 8/4/1998 00:50'!
privateInitializeFromText: aString
	^self subclassResponsibility! !

!Url methodsFor: 'parsing' stamp: 'ls 8/4/1998 00:55'!
privateInitializeFromText: aString relativeTo: aUrl
	"initialize from the given string, as a relative URL.  aString will have had the scheme name removed, if it was present to begin with.  If it was, then the scheme name was the same as the receiver's scheme name"

	"by default, just do regular initialization"
	^self privateInitializeFromText: aString! !


!Url methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:26'!
printOn: aStream
	^self subclassResponsibility! !

!Url methodsFor: 'printing' stamp: 'KLC 10/20/2005 15:37'!
toText
	self deprecated: 'Use Url>>asText instead'.
	^ self asString.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Url class
	instanceVariableNames: ''!

!Url class methodsFor: 'parsing' stamp: 'gk 10/21/2005 10:45'!
absoluteFromFileNameOrUrlString: aString
	"Return a URL from and handle Strings without schemes
	as local relative FileUrls instead of defaulting to a HttpUrl
	as absoluteFromText: does."

	^(Url schemeNameForString: aString)
		ifNil: [aString asUrlRelativeTo: FileDirectory default asUrl]
		ifNotNil: [Url absoluteFromText: aString]! !

!Url class methodsFor: 'parsing' stamp: 'gk 10/21/2005 10:47'!
absoluteFromText: aString
	"Return a URL from a string and handle
	a String without a scheme as a HttpUrl."

	"Url absoluteFromText: 'http://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part'" 
	"Url absoluteFromText: 'msw://chaos.resnet.gatech.edu:9000/testbook?top'"
	"Url absoluteFromText: 'telnet:chaos.resnet.gatech.edu'"
	"Url absoluteFromText: 'file:/etc/passwd'"

	| remainder index scheme fragment newUrl |
	"trim surrounding whitespace"
	remainder _ aString withBlanksTrimmed.	

	"extract the fragment, if any"
	index _ remainder indexOf: $#.
	index > 0 ifTrue: [
		fragment _ remainder copyFrom: index + 1 to: remainder size.
		remainder _ remainder copyFrom: 1 to: index - 1].

	"choose class based on the scheme name, and let that class do the bulk of the parsing"
	scheme _ self schemeNameForString: remainder.
	newUrl _ (self urlClassForScheme: scheme) new privateInitializeFromText: remainder.
	newUrl privateFragment: fragment.
	^newUrl! !

!Url class methodsFor: 'parsing' stamp: 'st 9/27/2004 15:47'!
combine: baseURL withRelative: relURL 
	"Take two URL as string form, combine them and return the corresponding URL in string form"

	^((self absoluteFromText: baseURL) newFromRelativeText: relURL) asString! !

!Url class methodsFor: 'parsing' stamp: 'gk 10/21/2005 10:41'!
schemeNameForString: aString
	"Get the scheme name from a string, or return nil if it's not specified. 
	Used in internal parsing routines - an outsider may as well use asUrl. 
	Return scheme in lowercases."
	
	"Url schemeNameForString: 'http://www.yahoo.com'"
	"Url schemeNameForString: '/etc/passwed'"
	"Url schemeNameForString: '/etc/testing:1.2.3'"

	| index schemeName |
	index _ aString indexOf: $: ifAbsent: [^ nil].
	schemeName _ aString first: index - 1.
	(schemeName allSatisfy: [:each | each isLetter]) ifFalse: [^ nil].
	^ schemeName asLowercase! !

!Url class methodsFor: 'parsing' stamp: 'gk 10/21/2005 09:28'!
urlClassForScheme: scheme
	(scheme isNil or: [scheme = 'http']) ifTrue: [^HttpUrl].
	scheme = 'ftp' ifTrue: [^FtpUrl].
	scheme = 'file' ifTrue: [^FileUrl].
	scheme = 'mailto' ifTrue: [^MailtoUrl].
	scheme = 'browser' ifTrue: [^BrowserUrl].
	^GenericUrl! !
OrderedCollection subclass: #UrlArgumentList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!

!UrlArgumentList methodsFor: 'adding' stamp: 'mir 7/27/1999 16:19'!
add: argName value: argValue
	| argAssociation |
	argAssociation _ self argumentNamed: argName.
	argAssociation isNil
		ifTrue: [self add: (argName -> (OrderedCollection with: argValue))]
		ifFalse: [argAssociation value add: argValue]! !


!UrlArgumentList methodsFor: 'enumerating' stamp: 'mir 7/27/1999 16:01'!
associationsDo: aBlock
	self do: [:each | 
		aBlock value: each]! !


!UrlArgumentList methodsFor: 'private' stamp: 'mir 7/27/1999 16:20'!
argumentNamed: argName
	^self
		detect: [:each | each key = argName]
		ifNone: [nil]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UrlArgumentList class
	instanceVariableNames: ''!

!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:25'!
with: argAssoc
	| argList |
	argList _ self new.
	argList add: argAssoc key value: argAssoc value.
	^argList! !

!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:26'!
with: firstArgAssoc with: secondArgAssoc
	| argList |
	argList _ self with: firstArgAssoc.
	argList add: secondArgAssoc key value: secondArgAssoc value.
	^argList! !

!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:26'!
with: firstArgAssoc with: secondArgAssoc with: thirdArgAssoc
	| argList |
	argList _ self with: firstArgAssoc with: secondArgAssoc.
	argList add: thirdArgAssoc key value: thirdArgAssoc value.
	^argList! !
ClassTestCase subclass: #UrlTest
	instanceVariableNames: 'url baseUrl expected string'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NetworkTests-Url'!
!UrlTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Url. 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!


!UrlTest methodsFor: 'testing' stamp: 'bp 2/12/2005 20:21'!
testFromFileNameOrUrlString

	url _ Url absoluteFromFileNameOrUrlString: 'asdf'.
	self assert: url schemeName = 'file'.
	self assert: url fragment isNil.
	self assert: url class = FileUrl.

	url _ Url absoluteFromFileNameOrUrlString: 'http://209.143.91.36/super/SuperSwikiProj/AAEmptyTest.001.pr'.
	self assert: url schemeName = 'http'.
	self assert: url fragment isNil.
	self assert: url class = HttpUrl.! !


!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:58'!
testAbsoluteBrowser

	url _ Url absoluteFromText: 'browser:bookmarks#mainPart'.

	self assert: url schemeName = 'browser'.
	self assert: url locator = 'bookmarks'.
	self assert:url fragment = 'mainPart'.
	self assert: url class = BrowserUrl.
	! !

!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:29'!
testAbsoluteFILE
	
	url _ Url absoluteFromText: 'file:/etc/passwd#foo'.

	self assert: url schemeName = 'file'.
	self assert: url path first = 'etc'.
	self assert: url path size = 2.	
	self assert: url fragment = 'foo'.! !

!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:32'!
testAbsoluteFILE2
	
	url _ 'fILE:/foo/bar//zookie/?fakequery/#fragger' asUrl.

	self assert: url schemeName = 'file'.
	self assert: url class = FileUrl.
	self assert: url path first ='foo'.
	self assert: url path size = 5.
	self assert: url fragment = 'fragger'.! !

!UrlTest methodsFor: 'tests' stamp: 'gk 2/12/2004 21:30'!
testAbsoluteFILE3
	"Just a few selected tests for FileUrl, not complete by any means."


	{'file:'. 'file:/'. 'file://'} do: [:s |
	 	url _ FileUrl absoluteFromText: s.
		self assert: (url asString = 'file:///').
		self assert: (url host = '').
		self assert: url isAbsolute].
	
	url _ FileUrl absoluteFromText: 'file://localhost/dir/file.txt'.
	self assert: (url asString = 'file://localhost/dir/file.txt').
	self assert: (url host = 'localhost').
	
	url _ FileUrl absoluteFromText: 'file://localhost/dir/file.txt'.
	self assert: (url asString = 'file://localhost/dir/file.txt').
	self assert: (url host = 'localhost').
	self assert: url isAbsolute.
	
	url _ FileUrl absoluteFromText: 'file:///dir/file.txt'.
	self assert: (url asString = 'file:///dir/file.txt').
	self assert: (url host = '').
	self assert: url isAbsolute.
	
	url _ FileUrl absoluteFromText: '/dir/file.txt'.
	self assert: (url asString = 'file:///dir/file.txt').
	self assert: url isAbsolute.
	
	url _ FileUrl absoluteFromText: 'dir/file.txt'.
	self assert: (url asString = 'file:///dir/file.txt').
	self deny: url isAbsolute.
	
	url _ FileUrl absoluteFromText: 'c:/dir/file.txt'.
	self assert: (url asString = 'file:///c%3A/dir/file.txt').
	self assert: url isAbsolute.
	
	"Only a drive letter doesn't refer to a directory."
	url _ FileUrl absoluteFromText: 'c:'.
	self assert: (url asString = 'file:///c%3A/').
	self assert: url isAbsolute.
	
	url _ FileUrl absoluteFromText: 'c:/'.
	self assert: (url asString = 'file:///c%3A/').
	self assert: url isAbsolute! !

!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:05'!
testAbsoluteFTP
	
	url _ 'ftP://some.server/some/directory/' asUrl.

	self assert: url schemeName = 'ftp'.
	self assert: url class = FtpUrl.
	self assert: url authority = 'some.server'.	
	self assert: url path first = 'some'.
	self assert: url path size  = 3.
	! !

!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:05'!
testAbsoluteHTTP
	
	url _ 'hTTp://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part' asUrl.

	self assert: url schemeName = 'http'.
	self assert: url authority = 'chaos.resnet.gatech.edu'.
	self assert: url path first = 'docs'.
	self assert: url path size = 3.
	self assert: url query = 'A%20query%20'.
	self assert: url fragment = 'part'.! !

!UrlTest methodsFor: 'tests' stamp: 'md 1/5/2004 14:51'!
testAbsolutePortErrorFix
	
	self shouldnt: [Url absoluteFromText: 'http://swikis.ddo.jp:8823/'] raise: Error.

	self should: [Url absoluteFromText: 'http://swikis.ddo.jp:-1/'] raise: Error.
	self should: [Url absoluteFromText: 'http://swikis.ddo.jp:65536/'] raise: Error.
	self should: [Url absoluteFromText: 'http://swikis.ddo.jp:auau/'] raise: Error.! !

!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:08'!
testAbsoluteTELNET
	
	url _ 'telNet:chaos.resnet.gatech.edu#goo' asUrl.

	self assert: url schemeName = 'telnet'.
	self assert: url locator = 'chaos.resnet.gatech.edu'.
	self assert: url fragment = 'goo'.	
! !

!UrlTest methodsFor: 'tests' stamp: 'st 9/27/2004 15:48'!
testCombineWithRelative
	#(#('http://www.rfc1149.net/' 'foo.html' 'http://www.rfc1149.net/foo.html') #('http://www.rfc1149.net/index.html' 'foo.html' 'http://www.rfc1149.net/foo.html') #('http://www.rfc1149.net/devel/' '../sam/' 'http://www.rfc1149.net/sam/') #('http://www.rfc1149.net/devel/index.html' '../sam/' 'http://www.rfc1149.net/sam/')) 
		do: [:a | self assert: (Url combine: a first withRelative: a second) = a third]! !

!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'!
testRelativeFILE
	
	| url2 |
	baseUrl _ 'file:/some/dir#fragment1' asUrl.
	url _ baseUrl newFromRelativeText: 'file:../another/dir/#fragment2'.
	self assert: url asText =  'file:///another/dir/#fragment2'.
	
	url _ FileUrl absoluteFromText: 'file://localhost/dir/dir2/file.txt'.
	url2 _ FileUrl absoluteFromText: 'file://hostname/flip/file.txt'.
	url2 privateInitializeFromText: '../file2.txt' relativeTo: url.
	self assert: (url2 asString = 'file://localhost/dir/file2.txt').
	self assert: (url2 host = 'localhost').
	self assert: url2 isAbsolute.
	
	url _ FileUrl absoluteFromText: 'file://localhost/dir/dir2/file.txt'.
	url2 _ FileUrl absoluteFromText: 'flip/file.txt'.
	self deny: url2 isAbsolute.
	url2 privateInitializeFromText: '.././flip/file.txt' relativeTo: url.
	self assert: (url2 asString = 'file://localhost/dir/flip/file.txt').
	self assert: (url2 host = 'localhost').
	self assert: url2 isAbsolute.
	
! !

!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'!
testRelativeFTP
	
	baseUrl _ 'ftp://somewhere/some/dir/?query#fragment' asUrl.
	url _ baseUrl newFromRelativeText: 'ftp://a.b'.

	self assert: url asString =  'ftp://a.b/'.! !

!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'!
testRelativeFTP2
	
	baseUrl _ 'ftp://somewhere/some/dir/?query#fragment' asUrl.
	url _ baseUrl newFromRelativeText: 'ftp:xyz'.


	self assert: url asString =  'ftp://somewhere/some/dir/xyz'.! !

!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'!
testRelativeFTP3
	
	baseUrl _ 'ftp://somewhere/some/dir/?query#fragment' asUrl.
	url _ baseUrl newFromRelativeText: 'http:xyz'.

	self assert: url asString = 'http://xyz/'.! !

!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'!
testRelativeHTTP
	
	baseUrl _ 'http://some.where/some/dir?query1#fragment1' asUrl.
	url _ baseUrl newFromRelativeText: '../another/dir/?query2#fragment2'.

	self assert: url asString =  'http://some.where/another/dir/?query2#fragment2'.! !

!UrlTest methodsFor: 'tests' stamp: 'gk 2/12/2004 21:31'!
testRoundTripFILE
	"File URLs should round-trip OK. This test should ultimately be
	tested on all platforms."

	| fileName |
	fileName _ FileDirectory default fullNameFor: 'xxx.st'.
	url _ FileDirectory urlForFileNamed: fileName.
	self assert: (url pathForFile = fileName) description: 'fileName didn''t round-trip'.! !

!UrlTest methodsFor: 'tests' stamp: 'md 7/21/2003 10:48'!
testUsernamePassword

	"basic case with a username+password specified"
	url := 'http://user:pword@someserver.blah:8000/root/index.html' asUrl.
	self should: [ url schemeName = 'http' ].
	self should: [ url authority = 'someserver.blah' ].
	self should: [ url port = 8000 ].
	self should: [ url path first = 'root' ].
	self should: [ url username = 'user' ].
	self should: [ url password = 'pword' ].

	"basic case for a relative url"
	baseUrl := 'http://anotherserver.blah:9999/somedir/someotherdir/stuff/' asUrl.
	url := 'http://user:pword@someserver.blah:8000/root/index.html' asUrlRelativeTo: baseUrl.
	self should: [ url schemeName = 'http' ].
	self should: [ url authority = 'someserver.blah' ].
	self should: [ url port = 8000 ].
	self should: [ url path first = 'root' ].
	self should: [ url username = 'user' ].
	self should: [ url password = 'pword' ].

	"a true relative test that should keep the username and password from the base URL"
	baseUrl := 'http://user:pword@someserver.blah:8000/root/index.html' asUrl.
	url := '/anotherdir/stuff/' asUrlRelativeTo: baseUrl.
	self should: [ url schemeName = 'http' ].
	self should: [ url authority = 'someserver.blah' ].
	self should: [ url port = 8000 ].
	self should: [ url path first = 'anotherdir' ].
	self should: [ url username = 'user' ].
	self should: [ url password = 'pword' ].
	


	"just a username specified"
	url := 'http://user@someserver.blah:8000/root/index.html' asUrl.
	self should: [ url schemeName = 'http' ].
	self should: [ url authority = 'someserver.blah' ].
	self should: [ url port = 8000 ].
	self should: [ url path first = 'root' ].
	self should: [ url username = 'user' ].
	self should: [ url password = nil ].


	"the port is not specified"
	url := 'http://user:pword@someserver.blah/root/index.html' asUrl.
	self should: [ url schemeName = 'http' ].
	self should: [ url authority = 'someserver.blah' ].
	self should: [ url port = nil ].
	self should: [ url path first = 'root' ].
	self should: [ url username = 'user' ].
	self should: [ url password = 'pword' ].


	"neither a path nor a port is specified"
	url := 'http://user:pword@someserver.blah' asUrl.
	self should: [ url schemeName = 'http' ].
	self should: [ url authority = 'someserver.blah' ].
	self should: [ url port = nil ].
	self should: [ url username = 'user' ].
	self should: [ url password = 'pword' ].


	"relative URL where the username+password should be forgotten"
	baseUrl := 'http://user:pword@someserver.blah' asUrl.
	url := 'http://anotherserver.blah' asUrlRelativeTo: baseUrl.
	self should: [ url username = nil ].
	self should: [ url password = nil ].

! !

!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:22'!
testUsernamePasswordPrinting

	#(	'http://user:pword@someserver.blah:8000/root/index.html'
		'http://user@someserver.blah:8000/root/index.html' 
		'http://user:pword@someserver.blah/root/index.html'
	) do: [ :urlText |
		self should: [ urlText = urlText asUrl asString ] ].

! !
SymbolListType subclass: #UserCustomEventNameType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-CustomEvents'!
!UserCustomEventNameType commentStamp: 'nk 6/12/2004 14:09' prior: 0!
This is a data type that enumerates user-defined custom event names.

You can turn off the display of such events in the script status popups by turning off the

	allowEtoyUserCustomEvents
	
Preference.!


!UserCustomEventNameType methodsFor: 'initialization' stamp: 'nk 7/21/2003 20:42'!
initialize
	"Initialize the CustomEvents vocabulary"

	super initialize.
	self vocabularyName: #CustomEvents! !


!UserCustomEventNameType methodsFor: 'queries' stamp: 'nk 9/26/2003 23:36'!
choices
	"Answer an alphabetized list of known user custom event selectors"

	| choices |
	choices _ ScriptingSystem userCustomEventNames.
	^choices isEmpty ifTrue: [ #('no event') ] ifFalse: [ choices ]! !


!UserCustomEventNameType methodsFor: 'tiles' stamp: 'nk 8/18/2004 17:48'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UserCustomEventNameType class
	instanceVariableNames: ''!

!UserCustomEventNameType class methodsFor: 'class initialization' stamp: 'nk 6/12/2004 14:18'!
allowEtoyUserCustomEventsPreferenceChanged
	Cursor wait showWhile: [ Vocabulary changeMadeToViewerAdditions ]! !

!UserCustomEventNameType class methodsFor: 'class initialization' stamp: 'nk 8/18/2004 18:02'!
initialize
	Vocabulary embraceAddedTypeVocabularies.
	Preferences
		addPreference: #allowEtoyUserCustomEvents
		categories:  #('scripting')
		default: false
		balloonHelp: 'If true, you can define your own events that can trigger scripts within a World.'
		projectLocal:  false
		changeInformee:  self
		changeSelector: #allowEtoyUserCustomEventsPreferenceChanged! !
MorphicEvent subclass: #UserInputEvent
	instanceVariableNames: 'type buttons position handler wasHandled'
	classVariableNames: ''
	poolDictionaries: 'EventSensorConstants'
	category: 'Morphic-Events'!

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:45'!
buttons
	"Return the a word encoding the mouse and modifier buttons for this event."

	^ buttons! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'!
handler
	^handler! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'!
handler: anObject
	handler _ anObject! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:45'!
position
	^position! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:45'!
type
	"Return a symbol indicating the type this event."

	^ type! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'!
wasHandled
	^wasHandled! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'!
wasHandled: aBool
	wasHandled _ aBool.! !


!UserInputEvent methodsFor: 'initialize' stamp: 'ar 9/13/2000 15:54'!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
	handler _ anEvent handler.
	wasHandled _ anEvent wasHandled.! !

!UserInputEvent methodsFor: 'initialize' stamp: 'ar 9/13/2000 15:54'!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"
	handler _ nil.
	wasHandled _ false.! !


!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:43'!
anyModifierKeyPressed
	"ignore, however, the shift keys 'cause that's not REALLY a command key "

	^ self buttons anyMask: 16r70	"cmd | opt | ctrl"! !

!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:43'!
commandKeyPressed
	"Answer true if the command key on the keyboard was being held down when this event occurred."

	^ buttons anyMask: 64! !

!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:44'!
controlKeyPressed
	"Answer true if the control key on the keyboard was being held down when this event occurred."

	^ buttons anyMask: 16! !

!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:44'!
shiftPressed
	"Answer true if the shift key on the keyboard was being held down when this event occurred."

	^ buttons anyMask: 8
! !


!UserInputEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 21:57'!
buttonString
	"Return a string identifying the currently pressed buttons"
	| string |
	string _ ''.
	self redButtonPressed ifTrue:[string _ string,'red '].
	self yellowButtonPressed ifTrue:[string _ string,'yellow '].
	self blueButtonPressed ifTrue:[string _ string,'blue '].
	^string! !

!UserInputEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 21:56'!
modifierString
	"Return a string identifying the currently pressed modifiers"
	| string |
	string _ ''.
	self commandKeyPressed ifTrue:[string _ string,'CMD '].
	self shiftPressed ifTrue:[string _ string,'SHIFT '].
	self controlKeyPressed ifTrue:[string _ string,'CTRL '].
	^string! !


!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position _  aMorphicTransform globalPointToLocal: position.! !

!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."
	^self shallowCopy transformBy: aMorphicTransform! !

!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:37'!
translateBy: delta
	"add delta to cursorPoint, and return the new event"
	position _ position + delta.! !

!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'!
translatedBy: delta
	"add delta to cursorPoint, and return the new event"
	^self shallowCopy translateBy: delta! !


!UserInputEvent methodsFor: '*nebraska-*nebraska-Morphic-Remote' stamp: 'ar 10/25/2000 23:23'!
encodedAsStringArray
	"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
	^{
		type.
		CanvasEncoder encodePoint: position.
		CanvasEncoder encodeInteger: buttons.
	}! !


!UserInputEvent methodsFor: 'private' stamp: 'ar 10/24/2000 16:33'!
setPosition: aPoint
	position _ aPoint! !
ScriptInstantiation subclass: #UserScript
	instanceVariableNames: 'currentScriptEditor formerScriptEditors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!UserScript commentStamp: '<historical>' prior: 0!
Holds the ScriptEditorMorph structures for the current version of a user-defined tile script, as well as previous versions thereof.
	currentScriptEditor	The current version of the ScriptEditorMorph for the script
	formerScriptEditors 	Earlier versions of the script, for recapturing via the Versions feature
							(a dictionary, <timeStamp> -> ScriptEditorMorph!


!UserScript methodsFor: 'script editor' stamp: 'sw 5/19/1998 12:18'!
allScriptVersionsDo: aBlock
	self isTextuallyCoded ifFalse: [aBlock value: currentScriptEditor].
	formerScriptEditors ifNotNil: [formerScriptEditors do:
		[:ed | aBlock value: ed]]! !

!UserScript methodsFor: 'script editor' stamp: 'sw 5/13/1998 15:38'!
bringUpToDate
	self allScriptVersionsDo: [:v | v bringUpToDate]! !

!UserScript methodsFor: 'script editor' stamp: 'sw 1/25/2001 10:32'!
currentScriptEditor
	"Answer the currentScriptEditor value"

	^ currentScriptEditor! !

!UserScript methodsFor: 'script editor' stamp: 'sw 1/29/98 22:55'!
currentScriptEditor: anEditor
	currentScriptEditor _ anEditor! !

!UserScript methodsFor: 'script editor' stamp: 'sw 1/25/2001 10:32'!
formerScriptEditors
	"Answer the formerScriptEditors value"

	^ formerScriptEditors! !

!UserScript methodsFor: 'script editor' stamp: 'sw 1/23/2001 11:28'!
instantiatedScriptEditor
	"Return the current script editor, creating it if necessary"

	self isTextuallyCoded ifTrue:
			[^ (player costume pasteUpMorph ifNil: [player costume "the world, backstop"]) scriptorForTextualScript: selector ofPlayer: player].

	currentScriptEditor ifNil:
		[currentScriptEditor _ (player class includesSelector: selector) 
			ifTrue: [ScriptEditorMorph new 
				fromExistingMethod: selector 
				forPlayer: player]
			ifFalse: [ScriptEditorMorph new
				setMorph: player costume
				scriptName: selector].
		status == #ticking ifTrue: [player costume arrangeToStartStepping]].
	
	^ currentScriptEditor! !

!UserScript methodsFor: 'script editor' stamp: 'tk 11/30/2000 16:32'!
releaseCachedState
	"release all non-showing scriptors.  What do we do about versions????"

	self isTextuallyCoded ifTrue: [formerScriptEditors _ OrderedCollection new].
		"to test new tiles.  We 'commit' to current script."
	currentScriptEditor ifNil: [^ self].
	true ifTrue: [^ self].	"<<< to test the reconstruction of scripts, change to false"
	currentScriptEditor world ifNil: ["not showing"
		currentScriptEditor _ nil].

! !


!UserScript methodsFor: 'textually coded' stamp: 'sw 5/19/1998 14:13'!
becomeTextuallyCoded
	currentScriptEditor _ #textuallyCoded! !

!UserScript methodsFor: 'textually coded' stamp: 'sw 5/19/1998 09:55'!
isTextuallyCoded
	^ currentScriptEditor == #textuallyCoded! !


!UserScript methodsFor: 'updating' stamp: 'sw 1/22/2001 16:45'!
updateToPlayer: aPlayer
	"Set aPlayer as the current player referenced by the receiver and its script editor"

	(currentScriptEditor notNil and: [currentScriptEditor ~~ #textuallyCoded]) ifTrue:
		[currentScriptEditor updateToPlayer: aPlayer].
	player _ aPlayer! !


!UserScript methodsFor: 'versions' stamp: 'di 2/19/2001 10:05'!
recreateScriptFrom: anEditor
	"Used to revert to old tiles"

	formerScriptEditors isEmptyOrNil ifTrue: [^ self].
	self revertScriptVersionFrom: anEditor installing: formerScriptEditors last! !

!UserScript methodsFor: 'versions' stamp: 'md 10/22/2003 16:07'!
revertScriptVersionFrom: anEditor 
	"Let user choose which prior tile version to revert to, and revert to it"

	| aMenu result |
	formerScriptEditors isEmptyOrNil ifTrue: [^Beeper beep].
	result := formerScriptEditors size == 1 
		ifTrue: [formerScriptEditors first]
		ifFalse: 
			[aMenu := SelectionMenu 
						labelList: (formerScriptEditors collect: [:e | e timeStamp])
						selections: formerScriptEditors.
			aMenu startUp].
	result 
		ifNotNil: [self revertScriptVersionFrom: anEditor installing: result]! !

!UserScript methodsFor: 'versions' stamp: 'sw 10/30/2000 08:54'!
revertScriptVersionFrom: anEditor installing: aSavedEditor
	"Replace anEditor with a brought-up-to-date version of aSavedEditor"

	| aPosition oldOwner |
	aPosition _ anEditor position.
	oldOwner _ anEditor topRendererOrSelf owner.
	anEditor delete.
	currentScriptEditor _ aSavedEditor bringUpToDate install.
	player costume viewAfreshIn: oldOwner showingScript: selector at: aPosition! !

!UserScript methodsFor: 'versions' stamp: 'sw 10/10/2000 11:07'!
revertToLastSavedTileVersionFor: anEditor
	"revert to the last saved tile version"

	formerScriptEditors isEmptyOrNil ifFalse:
		[self revertScriptVersionFrom: anEditor installing: formerScriptEditors last]! !

!UserScript methodsFor: 'versions' stamp: 'dgd 2/21/2003 22:39'!
saveScriptVersion: timeStampCurrentlyIgnored 
	self isTextuallyCoded 
		ifFalse: 
			[formerScriptEditors isNil 
				ifTrue: [formerScriptEditors := OrderedCollection new].
			currentScriptEditor 
				ifNotNil: [formerScriptEditors add: currentScriptEditor veryDeepCopy].
			formerScriptEditors size > 100 
				ifTrue: [^self error: 'apparent runaway versions']]! !

!UserScript methodsFor: 'versions' stamp: 'sw 10/30/2000 08:54'!
savedTileVersionsCount
	"Answer the number of saved tile versions of the script"

	^ formerScriptEditors ifNil: [0] ifNotNil: [formerScriptEditors size]! !
Object subclass: #Utilities
	instanceVariableNames: ''
	classVariableNames: 'AuthorInitials AuthorName CommonRequestStrings LastStats RecentSubmissions ScrapsBook UpdateDownloader UpdateUrlLists'
	poolDictionaries: ''
	category: 'System-Support'!
!Utilities commentStamp: '<historical>' prior: 0!
A repository for general and miscellaneous utilities; much of what is here are in effect global methods that don't naturally attach to anything else.  1/96 sw!


!Utilities methodsFor: 'look in class' stamp: 'sw 10/13/1998 13:14'!
seeClassSide
	"All the code for Utilitites is on the class side"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Utilities class
	instanceVariableNames: ''!

!Utilities class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:11'!
initialize
	"Initialize the class variables.  5/16/96 sw"
	self initializeCommonRequestStrings.
	RecentSubmissions _ OrderedCollection new.

	self registerInFlapsRegistry.	! !

!Utilities class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:12'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(Utilities	recentSubmissionsWindow	'Recent'		'A message browser that tracks the most recently-submitted methods')
						forFlapNamed: 'Tools'.]! !

!Utilities class methodsFor: 'class initialization' stamp: 'NS 1/26/2004 09:52'!
startUp
	SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #event:.! !

!Utilities class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:42'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!Utilities class methodsFor: 'common requests' stamp: 'sw 12/1/1999 16:09'!
appendToCommonRequests: aString
	self commonRequestStrings: (CommonRequestStrings contents, String cr, aString)

"Utilities appendToCommonRequests: 'self beep'"
! !

!Utilities class methodsFor: 'common requests' stamp: 'sw 12/12/96'!
commonRequestStrings: aString
	"Initialize the common request strings from aString.  "

	CommonRequestStrings _ StringHolder new contents: aString! !

!Utilities class methodsFor: 'common requests' stamp: 'tk 5/4/1998 17:35'!
editCommonRequestStrings
	"Let the user edit the common request strings.  2/1/96 sw"

	CommonRequestStrings openLabel: 'Common Request Strings'! !

!Utilities class methodsFor: 'common requests' stamp: 'nk 8/30/2004 08:02'!
eval: aString
	"Evaluate the string in a neutral context, and under certain circumstances print the 
	result in the transcript"

	| result |
	result _ Compiler new evaluate: aString in: nil to: nil.
	(result isNumber) | (result isString)
		ifTrue:
			[Transcript cr; nextPutAll: result printString]! !

!Utilities class methodsFor: 'common requests' stamp: 'sw 2/5/2002 13:17'!
initializeCommonRequestStrings
	"Initialize the common request strings, a directly-editable list of expressions that can be evaluated from the 'do...' menu."

	CommonRequestStrings _ StringHolder new contents: 
'Utilities emergencyCollapse.
Utilities closeAllDebuggers.
-
Sensor keyboard.
ParagraphEditor abandonChangeText.
Cursor normal show.
-
CommandHistory resetAllHistory.
Project allInstancesDo: [:p | p displayDepth: 16].
ScriptingSystem inspectFormDictionary.
Form fromUser bitEdit.
Display border: (0@0 extent: 640@480) width: 2.
-
Undeclared inspect.
Undeclared removeUnreferencedKeys; inspect.
Transcript clear.
Utilities grabScreenAndSaveOnDisk.
FrameRateMorph new openInHand.
-
Utilities reconstructTextWindowsFromFileNamed: ''TW''.
Utilities storeTextWindowContentsToFileNamed: ''TW''.
ChangeSorter removeEmptyUnnamedChangeSets.
ChangeSorter reorderChangeSets.
-
ActiveWorld installVectorVocabulary.
ActiveWorld abandonVocabularyPreference.
Smalltalk saveAsNewVersion'

"Utilities initializeCommonRequestStrings"! !

!Utilities class methodsFor: 'common requests' stamp: 'rbb 2/18/2005 13:11'!
offerCommonRequests
	"Offer up the common-requests menu.  If the user chooses one, then evaluate it, and -- provided the value is a number or string -- show it in the Transcript."

	"Utilities offerCommonRequests"

	| reply result aMenu index normalItemCount strings |

	Smalltalk isMorphic ifTrue: [^ self offerCommonRequestsInMorphic].

	(CommonRequestStrings == nil or: [CommonRequestStrings isKindOf: Array])
		ifTrue:
			[self initializeCommonRequestStrings].
	
	strings _ CommonRequestStrings contents.
	normalItemCount _ strings asString lineCount.
	aMenu _ UIManager default 
		chooseFrom: (((strings asString, '\edit this menu' withCRs) 
						findTokens: Character cr) asArray)
		lines: (Array with: normalItemCount).

	index _ aMenu startUp.
	index == 0 ifTrue: [^ self].
	reply _ aMenu labelString lineNumber: index.
	reply size == 0 ifTrue: [^ self].
	index > normalItemCount ifTrue:
		[^ self editCommonRequestStrings].

	result _ self evaluate: reply in: nil to: nil.
	(result isNumber) | (result isString)
		ifTrue:
			[Transcript cr; nextPutAll: result printString]! !

!Utilities class methodsFor: 'common requests' stamp: 'dgd 9/21/2003 13:52'!
offerCommonRequestsInMorphic
	"Offer up the common-requests menu.  If the user chooses one, then evaluate it, and -- provided the value is a number or string -- show it in the Transcript."

	"Utilities offerCommonRequests"

	| aMenu  strings |

	(CommonRequestStrings == nil or: [CommonRequestStrings isKindOf: Array])
		ifTrue:
			[self initializeCommonRequestStrings].
	strings _ CommonRequestStrings contents.
	aMenu _ MenuMorph new.
	aMenu title: 'Common Requests' translated.
	aMenu addStayUpItem.
	strings asString linesDo:
		[:aString |
			aString = '-'
				ifTrue:
					[aMenu addLine]
				ifFalse:
					[aString size == 0 ifTrue: [aString _ ' '].
					aMenu add: aString target: self selector: #eval: argument: aString]].

	aMenu addLine.
	aMenu add: 'edit this list' translated target: self action: #editCommonRequestStrings.
	aMenu popUpInWorld: self currentWorld! !


!Utilities class methodsFor: 'debugging' stamp: 'sw 4/29/2001 23:42'!
doesNotUnderstand: aMessage
	"A temporary expedient for revectoring various messages formerly sent to Utilities that now are instead implemented by Flaps; this is only for the benefit of pre-existing buttons and menu items that were set up to call the old interface"

	| aSelector |
	aSelector _ aMessage selector.
	(#(addLocalFlap explainFlaps addMenuFlap addPaintingFlap addStackToolsFlap addGlobalFlap offerGlobalFlapsMenu toggleWhetherToUseGlobalFlaps ) includes: aSelector)
		ifTrue:
			[^ self inform: 
'Sorry, this is an obsolete menu.  Please
dismiss it and get a fresh one.  Thank you'].

	^ super doesNotUnderstand: aMessage! !

!Utilities class methodsFor: 'debugging'!
inspectCollection: aCollection notifying: aView
	aCollection size = 0 
		ifTrue: [aView notNil 
			ifTrue: [^ aView flash]
			ifFalse: [^ self]].
	aCollection size = 1
		ifTrue: [aCollection first inspect]
		ifFalse: [aCollection asArray inspect]! !


!Utilities class methodsFor: 'durable menus' stamp: 'di 9/22/1998 14:49'!
windowFromMenu: aMenu target: aTarget title: aTitle
	"Supply a default list of colors"
	^ self windowFromMenu: aMenu target: aTarget title: aTitle
		colorPattern: #(lightRed lightGreen lightBlue lightYellow lightGray lightCyan lightMagenta lightOrange)! !

!Utilities class methodsFor: 'durable menus' stamp: 'di 9/22/1998 14:48'!
windowFromMenu: aMenu target: aTarget title: aTitle colorPattern: aColorPattern
	| labelList targetList selectionList i |
	selectionList _ aMenu selections.
	labelList _ (1 to: selectionList size) collect:
		[:ind | aMenu labelString lineNumber: ind].
	targetList _  (1 to: selectionList size) collect: [:ind | aTarget].

	(i _ labelList indexOf: 'keep this menu up') > 0 ifTrue:
		[selectionList _ selectionList copyReplaceFrom: i to: i with: Array new.
		labelList _ labelList copyReplaceFrom: i to: i with: Array new.
		targetList _ targetList copyReplaceFrom: i to: i with: Array new].

	self windowMenuWithLabels:  labelList colorPattern: aColorPattern targets: targetList selections: selectionList title: aTitle! !

!Utilities class methodsFor: 'durable menus' stamp: 'di 11/27/1999 08:23'!
windowMenuWithLabels: labelList colorPattern: colorPattern  targets: targetList selections: selectionList title: aTitle
	| aWorld colorList  pos delta aButton  rightmost widthToUse |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].
	aWorld _ MVCWiWPasteUpMorph newWorldForProject: nil.
	colorList _  (1 to: labelList size) collect:
		[:ind | Color colorFrom: (colorPattern at: (ind \\ colorPattern size + 1))].
			
	pos _ 4 @ 6.
	delta _ 0 @ 30.
	rightmost _ 0.

	1 to: labelList size do:
		[:index |
			aButton _ SimpleButtonMorph new.
			aButton label: (labelList at: index); 
				color: (colorList at: index); 
				target: (targetList at: index);
				actionSelector: (selectionList at: index);
				position: pos.
			rightmost _ rightmost max: aButton right.
			pos _ pos + delta.
			aWorld addMorphBack: aButton].
	widthToUse _ rightmost + 10.
	aWorld submorphs do:
		[:m | m position: (((widthToUse - m width) // 2) @ m position y)].
	aWorld setProperty: #initialExtent toValue: (widthToUse @ (aButton bottom + 10)).
	aWorld openWithTitle: aTitle cautionOnClose: false! !

!Utilities class methodsFor: 'durable menus' stamp: 'di 11/27/1999 08:24'!
windowMenuWithLabels: labelList colorPattern: colorPattern  targets: targetList selections: selectionList wordingSelectors: wordingList title: aTitle
	| aWorld colorList  pos delta aButton  rightmost widthToUse wordingSelector |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].
	aWorld _ MVCWiWPasteUpMorph newWorldForProject: nil.
	colorList _  (1 to: labelList size) collect:
		[:ind | Color colorFrom: (colorPattern at: (ind \\ colorPattern size + 1))].
			
	pos _ 4 @ 6.
	delta _ 0 @ 30.
	rightmost _ 0.

	1 to: labelList size do:
		[:index |
			wordingSelector _ wordingList at: index.
			aButton _ wordingSelector
				ifNil:
					[SimpleButtonMorph new]
				ifNotNil:
					[UpdatingSimpleButtonMorph new].
			aButton label: (labelList at: index); 
				color: (colorList at: index); 
				target: (targetList at: index);
				actionSelector: (selectionList at: index);
				position: pos.
			wordingSelector ifNotNil: [aButton wordingSelector: wordingSelector].
			rightmost _ rightmost max: aButton right.
			pos _ pos + delta.
			aWorld addMorphBack: aButton].
	widthToUse _ rightmost + 10.
	aWorld startSteppingSubmorphsOf: aWorld.
	aWorld submorphs do:
		[:m | m position: (((widthToUse - m width) // 2) @ m position y)].
	aWorld setProperty: #initialExtent toValue: (widthToUse @ (aButton bottom + 10)).
	aWorld openWithTitle: aTitle cautionOnClose: false! !


!Utilities class methodsFor: 'fetching updates' stamp: 'sr 2/12/2001 03:38'!
applyUpdatesFromDisk
	"Utilities applyUpdatesFromDisk"
	"compute highest update number"
	| updateDirectory updateNumbers |
	updateDirectory _ self getUpdateDirectoryOrNil.
	updateDirectory
		ifNil: [^ self].
	updateNumbers _ updateDirectory fileNames
				collect: [:fn | fn initialIntegerOrNil]
				thenSelect: [:fn | fn notNil].
	self
		applyUpdatesFromDiskToUpdateNumber: (updateNumbers
				inject: 0
				into: [:max :num | max max: num])
		stopIfGap: false! !

!Utilities class methodsFor: 'fetching updates' stamp: 'ar 9/27/2005 20:15'!
applyUpdatesFromDiskToUpdateNumber: lastUpdateNumber stopIfGap: stopIfGapFlag 
	"To use this mechanism, be sure all updates you want to have considered 
	are in a folder named 'updates' which resides in the same directory as  
	your image. Having done that, simply evaluate:  
	 
	Utilities applyUpdatesFromDiskToUpdateNumber: 1234 stopIfGap: false  
	 
	and all numbered updates <= lastUpdateNumber not yet in the image will 
	be loaded in numerical order."
	| previousHighest currentUpdateNumber done fileNames aMessage updateDirectory loaded |
	updateDirectory := self getUpdateDirectoryOrNil.
	updateDirectory ifNil: [^ self].
	previousHighest := SystemVersion current highestUpdate.
	currentUpdateNumber := previousHighest.
	done := false.
	loaded := 0.
	[done]
		whileFalse: [currentUpdateNumber := currentUpdateNumber + 1.
			currentUpdateNumber > lastUpdateNumber
				ifTrue: [done := true]
				ifFalse: [fileNames := updateDirectory fileNamesMatching: currentUpdateNumber printString , '*'.
					fileNames size > 1
						ifTrue: [^ self inform: 'ambiguity -- two files both start with ' , currentUpdateNumber printString , '
(at this point it is probably best to remedy
the situation on disk, then try again.)'].
					fileNames size == 0
						ifTrue: [Transcript cr; show: 'gap in updates from disk for update number '; print: currentUpdateNumber; show: ' found...'.
							done := stopIfGapFlag]
						ifFalse: [ChangeSet
								newChangesFromStream: (updateDirectory readOnlyFileNamed: fileNames first)
								named: fileNames first.
							SystemVersion current registerUpdate: currentUpdateNumber.
							loaded := loaded + 1]]].
	aMessage := loaded = 0
				ifTrue: ['No new updates found.']
				ifFalse: [loaded printString , ' update(s) loaded.'].
	self inform: aMessage , '
Highest numbered update is now ' , (currentUpdateNumber - 1) printString , '.'! !

!Utilities class methodsFor: 'fetching updates' stamp: 'md 9/11/2004 12:06'!
assureAbsenceOfUnstableUpdateStream
	"Check to see if the unstable Updates stream is in the list; if it is, *remove* it.  This is the *opposite* of #assureAvailabilityOfUnstableUpdateStream"

	UpdateUrlLists ifNil: [UpdateUrlLists _ OrderedCollection new].
	UpdateUrlLists _ UpdateUrlLists select:
		[:pair | pair first ~= 'Unstable Updates*']


"Utilities assureAbsenceOfUnstableUpdateStream"! !

!Utilities class methodsFor: 'fetching updates' stamp: 'md 9/11/2004 12:07'!
assureAvailabilityOfUnstableUpdateStream
	"Check to see if the unstable Updates stream is in the list; if not, add it"

	UpdateUrlLists ifNil: [UpdateUrlLists _ OrderedCollection new].
	UpdateUrlLists do:
		[:pair | (pair first =  'Unstable Updates*') ifTrue: [^ self]].

	UpdateUrlLists addFirst: #('Unstable Updates*' #('squeak.cs.uiuc.edu/Squeak2.0/' 'update.squeakfoundation.org/external/'))

"Utilities assureAvailabilityOfUnstableUpdateStream"! !

!Utilities class methodsFor: 'fetching updates' stamp: 'mir 6/26/2001 12:08'!
broadcastUpdatesFrom: n1 to: n2 except: skipList
"
	Note:  This method takes its list of files from the directory named 'updates',
	which will have been created and filled by, eg,
		Utilities readServerUpdatesSaveLocally: true updateImage: true.
	These can then be rebroadcast to any server using, eg,
		Utilities broadcastUpdatesFrom: 1 to: 9999 except: #(223 224).
	If the files are already on the server, and it is only a matter
	of copying them to the index for a different version, then use...
		(ServerDirectory serverInGroupNamed: 'SqC Internal Updates*')
			exportUpdatesExcept: #().
"
	| fileNames fileNamesInOrder names choice file updateDirectory |
	updateDirectory _ FileDirectory default directoryNamed: 'updates'.
	fileNames _ updateDirectory fileNames select:
		[:n | n first isDigit
			and: [(n initialIntegerOrNil between: n1 and: n2)
			and: [(skipList includes: n initialIntegerOrNil) not]]].
	(file _ fileNames select: [:n | (n occurrencesOf: $.) > 1]) size > 0
		ifTrue: [self halt: file first , ' has multiple periods'].
	fileNamesInOrder _ fileNames asSortedCollection:
		[:a :b | a initialIntegerOrNil < b initialIntegerOrNil].

	names _ ServerDirectory groupNames asSortedArray.
	choice _ (SelectionMenu labelList: names selections: names) startUp.
	choice == nil ifTrue: [^ self].
	(ServerDirectory serverInGroupNamed: choice)
		putUpdateMulti: fileNamesInOrder fromDirectory: updateDirectory
! !

!Utilities class methodsFor: 'fetching updates' stamp: 'CdG 10/17/2005 19:36'!
chooseUpdateList
	"When there is more than one set of update servers, let the user choose which we will update from.  Put it at the front of the list. Return false if the user aborted.  If the preference #promptForUpdateServer is false, then suppress that prompt, in effect using the same server choice that was used the previous time (a convenience for those of us who always answer the same thing to the prompt.)"

	| index him |
	((UpdateUrlLists size > 1) and: [Preferences promptForUpdateServer])
		ifTrue:
			[index _ UIManager default 
				chooseFrom: (UpdateUrlLists collect: [:each | each first]) 
				lines: #()
				title: 'Choose a group of servers\from which to fetch updates.' translated withCRs.
			index > 0 ifTrue:
				[him _ UpdateUrlLists at: index.
				UpdateUrlLists removeAt: index.
				UpdateUrlLists addFirst: him].
			^ index > 0].
	^ true! !

!Utilities class methodsFor: 'fetching updates' stamp: 'di 4/29/2001 22:26'!
extractThisVersion: list
	"Pull out the part of the list that applies to this version."

	| listContents version versIndex |
	listContents _ self parseListContents: list.
	version _ SystemVersion current version.
	versIndex _ (listContents collect: [:pair | pair first]) indexOf: version.
	versIndex = 0 ifTrue: [^ Array new].		"abort"
	^ (listContents at: versIndex) last! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 2/26/2002 23:19'!
fileInFromUpdatesFolder: numberList
	"File in a series of updates with the given updates numbers, from the updates folder in the default directory.  The file-ins are done in numeric order, even if numberList was not sorted upon entry.
	This is useful for test-driving the retrofitting of a possibly discontinguous list of updates from an alpha version back to a stable release.

	Utilities fileInFromUpdatesFolder: #(4745 4746 4747 4748 4749 4750 4751 4752 4754 4755 4761 4762 4767 4769).
"
	| fileNames fileNamesInOrder file updateDirectory |
	updateDirectory _ FileDirectory default directoryNamed: 'updates'.
	fileNames _ updateDirectory fileNames select:
		[:n | n first isDigit
			and: [numberList includes: n initialIntegerOrNil]].
	(file _ fileNames select: [:n | (n occurrencesOf: $.) > 1]) size > 0
		ifTrue: [self error: file first , ' has multiple periods'].
	fileNamesInOrder _ fileNames asSortedCollection:
		[:a :b | a initialIntegerOrNil < b initialIntegerOrNil].

	fileNamesInOrder do:
		[:aFileName | (updateDirectory readOnlyFileNamed: aFileName) fileIntoNewChangeSet]! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sr 2/12/2001 03:36'!
getUpdateDirectoryOrNil
	^ (FileDirectory default directoryNames includes: 'updates')
		ifTrue: [FileDirectory default directoryNamed: 'updates']
		ifFalse: [self inform: 'Error: cannot find "updates" folder'.
			nil]! !

!Utilities class methodsFor: 'fetching updates' stamp: 'tk 2/16/98 16:16'!
lastUpdateNum: updatesFileStrm
	"Look in the Updates file and see what the last sequence number is.  Warn the user if the version it is under is not this image's version."

	| verIndex seqIndex char ver seqNum |
	verIndex _ seqIndex _ 0.	 "last # starting a line and last digit starting a line"
	seqNum _ 0.
	updatesFileStrm reset; ascii.
	[char _ updatesFileStrm next.
	 updatesFileStrm atEnd] whileFalse: [
		char == Character cr ifTrue: [
			updatesFileStrm peek == $# ifTrue: [verIndex _ updatesFileStrm position +1.
				seqIndex = 0 ifFalse: ["See if last num of old version if biggest so far"
					updatesFileStrm position: seqIndex.
					ver _ SmallInteger readFrom: updatesFileStrm.
					seqNum _ seqNum max: ver.
					updatesFileStrm position: verIndex-1]].
			updatesFileStrm peek isDigit ifTrue: [seqIndex _ updatesFileStrm position]]].

	seqIndex = 0 ifFalse: ["See if last num of old version if biggest so far"
		updatesFileStrm position: seqIndex.
		ver _ SmallInteger readFrom: updatesFileStrm.
		seqNum _ seqNum max: ver.
		updatesFileStrm setToEnd].
	^ seqNum! !

!Utilities class methodsFor: 'fetching updates' stamp: 'mir 9/7/2001 16:46'!
newUpdatesOn: serverList special: indexPrefix throughNumber: aNumber
	"Return a list of fully formed URLs of update files we do not yet have.  Go to the listed servers and look at the file 'updates.list' for the names of the last N update files.  We look backwards for the first one we have, and make the list from there.  tk 9/10/97
	No updates numbered higher than aNumber (if it is not nil) are returned " 

	| existing doc list out ff raw char maxNumber itsNumber |
	maxNumber _ aNumber ifNil: [99999].
	out _ OrderedCollection new.
	existing _ SystemVersion current updates.
	serverList do: [:server |
		doc _ HTTPClient httpGet: 'http://' , server,indexPrefix,'updates.list'.
		"test here for server being up"
		doc class == RWBinaryOrTextStream ifTrue:
			[raw _ doc reset; contents.	"one file name per line"
			list _ self extractThisVersion: raw.
			list reverseDo: [:fileName |
				ff _ (fileName findTokens: '/') last.	"allow subdirectories"
				itsNumber _ ff initialIntegerOrNil. 
				(existing includes: itsNumber)
					ifFalse:
						[
						(itsNumber == nil or: [itsNumber <= maxNumber])
							ifTrue:
								[out addFirst: 'http://' , server, fileName]]
					ifTrue: [^ out]].
			((out size > 0) or: [char _ doc reset; skipSeparators; next.
				(char == $*) | (char == $#)]) ifTrue:
					[^ out "we have our list"]].	"else got error msg instead of file"
		"Server was down, try next one"].
	self inform: 'All code update servers seem to be unavailable'.
	^ out! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 5/23/2001 14:22'!
objectStrmFromUpdates: fileName
	"Go to the known servers and look for this file in the updates folder.  It is an auxillery file, like .morph or a .gif.  Return a RWBinaryOrTextStream on it.    Meant to be called from during the getting of updates from the server.  That assures that (Utilities serverUrls) returns the right group of servers."

	| urls doc |
	Cursor wait showWhile:
		[urls _ Utilities serverUrls collect: [:url | url, 'updates/', fileName].
		urls do: [:aUrl |
			doc _ HTTPSocket httpGet: aUrl accept: 'application/octet-stream'.
			"test here for server being up"
			doc class == RWBinaryOrTextStream ifTrue: [^ doc reset]]].

	self inform: 'All update servers are unavailable, or bad file name'.
	^ nil! !

!Utilities class methodsFor: 'fetching updates' stamp: 'di 4/29/2001 14:27'!
parseListContents: listContents
	| sections vers strm line fileNames |
	"Parse the contents of updates.list into {{vers. {fileNames*}}*}, and return it."

	sections _ OrderedCollection new.
	fileNames _ OrderedCollection new: 1000.
	vers _ nil.
	strm _ ReadStream on: listContents.
	[strm atEnd] whileFalse:
		[line _ strm upTo: Character cr.
		line size > 0 ifTrue:
			[line first = $#
				ifTrue: [vers ifNotNil: [sections addLast: {vers. fileNames asArray}].
						"Start a new section"
						vers _ line allButFirst.
						fileNames resetTo: 1]
				ifFalse: [line first = $* ifFalse: [fileNames addLast: line]]]].
	vers ifNotNil: [sections addLast: {vers. fileNames asArray}].
	^ sections asArray
" TEST:
 | list |
list _ Utilities parseListContents: (FileStream oldFileNamed: 'updates.list') contentsOfEntireFile.
list = (Utilities parseListContents: (String streamContents: [:s | Utilities writeList: list toStream: s]))
	ifFalse: [self error: 'test failed']
	ifTrue: [self inform: 'test OK']
"! !

!Utilities class methodsFor: 'fetching updates' stamp: 'mir 4/2/2001 16:34'!
position: updateStrm atVersion: version
	"Set the stream to the end of the last line of updates names for this version.  Usually the end of the file.  We will add a new update name.   Return the contents of the rest of the file."

	| char foundIt where data |
	updateStrm reset; ascii.
	foundIt _ false.
	[char _ updateStrm next.
	 updateStrm atEnd] whileFalse: [
		(char == Character cr or: [char == Character lf]) ifTrue: [
			updateStrm peek == $# ifTrue: [
				foundIt ifTrue: ["Next section"
					where _ updateStrm position.
					data _ updateStrm upTo: (255 asCharacter).
					updateStrm position: where.
					^ data].	"won't be found -- copy all the way to the end"
				updateStrm next.
				(updateStrm nextMatchAll: version) ifTrue: [
					(updateStrm atEnd or: [(updateStrm peek = Character cr) | 
						(updateStrm peek = Character lf)]) ifTrue: [
							foundIt _ true
					]]]]].
	foundIt ifTrue: [
		updateStrm setToEnd.
		^ ''].
	self error: 'The current version does not have a section in the Updates file'.
! !

!Utilities class methodsFor: 'fetching updates' stamp: 'ar 9/27/2005 20:15'!
readNextUpdateFromServer
	"Utilities readNextUpdateFromServer"
	self updateFromServerThroughUpdateNumber: (ChangeSet highestNumberedChangeSet + 1)! !

!Utilities class methodsFor: 'fetching updates' stamp: 'ar 9/27/2005 20:15'!
readNextUpdatesFromDisk: n
	"Read the updates up through the current highest-update-number plus n.  Thus, 
	Utilities readNextUpdatesFromDisk: 7
will read the next seven updates from disk"

	self applyUpdatesFromDiskToUpdateNumber: ChangeSet highestNumberedChangeSet + n
		stopIfGap: false! !

!Utilities class methodsFor: 'fetching updates' stamp: 'CdG 10/17/2005 22:51'!
readServer: serverList special: indexPrefix updatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage
	"Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load.  This makes it possible to update only up to a particular point.   If saveLocally is true, then save local copies of the update files on disc.  If updateImage is true, then absorb the updates into the current image."

"Utilities readServer: Utilities serverUrls updatesThrough: 828 saveLocally: true updateImage: true"

	| urls failed loaded docQueue this nextDoc docQueueSema str updateName |
	Cursor wait showWhile: [

	urls := self newUpdatesOn: (serverList collect: [:url | url, 'updates/']) 
				special: indexPrefix
				throughNumber: maxNumber.
	loaded := 0.
	failed := nil.

	"send downloaded documents throuh this queue"
	docQueue := SharedQueue new.

	"this semaphore keeps too many documents from beeing queueed up at a time"
	docQueueSema := Semaphore new.
	5 timesRepeat: [ docQueueSema signal ].

	"fork a process to download the updates"
	self retrieveUrls: urls ontoQueue: docQueue withWaitSema: docQueueSema.

	"process downloaded updates in the foreground"
	'Processing updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar |
	[ this := docQueue next.
	  nextDoc := docQueue next.  
	  nextDoc = #failed ifTrue: [ failed := this ].
	  (failed isNil and: [ nextDoc ~= #finished ])
	] whileTrue: [
		failed ifNil: [
			nextDoc reset; text.
			nextDoc size = 0 ifTrue: [ failed := this ]. ].
		failed ifNil: [
			nextDoc peek asciiValue = 4	"pure object file"
				ifTrue: [failed := this]].	"Must be fileIn, not pure object file"
		failed ifNil: [
			"(this endsWith: '.html') ifTrue: [doc _ doc asHtml]."
				"HTML source code not supported here yet"
			updateImage
				ifTrue: [
					updateName := (this findTokens: '/') last.
					ChangeSet newChangesFromStream: nextDoc named: updateName.
					SystemVersion current registerUpdate: updateName initialIntegerOrNil].
			saveLocally ifTrue:
				[self saveUpdate: nextDoc onFile: (this findTokens: '/') last].	"if wanted"
			loaded := loaded + 1.
			bar value: loaded].

		docQueueSema signal].
	]].

	failed ~~ nil & (urls size - loaded > 0) ifTrue: [
		str := loaded printString ,' new update file(s) processed.'.
		str := str, '\Could not load ' withCRs, 
			(urls size - loaded) printString ,' update file(s).',
			'\Starting with "' withCRs, failed, '".'.
		self inform: str].
	^ Array with: failed with: loaded
! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 1/10/1999 02:02'!
readServerUpdatesSaveLocally: saveLocally updateImage: updateImage
	^ self readServerUpdatesThrough: nil saveLocally: saveLocally updateImage: updateImage! !

!Utilities class methodsFor: 'fetching updates' stamp: 'rbb 2/18/2005 13:16'!
readServerUpdatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage
	"Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load.  This makes it possible to update only up to a particular point.   If saveLocally is true, then save local copies of the update files on disc.  If updateImage is true, then absorb the updates into the current image.

A file on the server called updates.list has the names of the last N update files.  We look backwards for the first one we do not have, and start there"
"* To add a new update:  Name it starting with a new two-digit code.  
* Do not use %, /, *, space, or more than one period in the name of an update file.
* The update name does not need to have any relation to the version name.
* Figure out which versions of the system the update makes sense for.
* Add the name of the file to each version's category below.
* Put this file and the update file on all of the servers.
*
* To make a new version of the system:  Pick a name for it (no restrictions)
* Put # and exactly that name on a new line at the end of this file.
* During the release process, fill in exactly that name in the dialog box.
* Put this file on the server."
"When two sets of updates need to use the same directory, one of them has a * in its 
serverUrls description.  When that is true, the first word of the description is put on
the front of 'updates.list', and that is the index file used."

"Utilities readServerUpdatesThrough: 3922 saveLocally: true updateImage: true"

	| failed loaded str res servers triple tryAgain indexPrefix |
	Utilities chooseUpdateList ifFalse: [^ self].	"ask the user which kind of updates"

	servers _ Utilities serverUrls copy.
	indexPrefix _ (Utilities updateUrlLists first first includes: $*) 
		ifTrue: [(Utilities updateUrlLists first first findTokens: ' ') first]
						"special for internal updates"
		ifFalse: ['']. 	"normal"
	[servers isEmpty] whileFalse: [
		triple _ self readServer: servers special: indexPrefix 
					updatesThrough: maxNumber 
					saveLocally: saveLocally updateImage: updateImage.

		"report to user"
		failed _ triple first.
		loaded _ triple second.
		tryAgain _ false.
		failed ifNil: ["is OK"
			loaded = 0 ifTrue: ["found no updates"
				servers size > 1 ifTrue: ["not the last server"
					res _ UIManager default 
							chooseFrom: #('Stop looking' 'Try next server')
							title: 
'No new updates on the server
', servers first, '
Would you like to try the next server?
(Normally, all servers are identical, but sometimes a
server won''t let us store new files, and gets out of date.)' 
						.
					res = 2 ifFalse: [^ self]
						 ifTrue: [servers _ servers allButFirst.	"try the next server"
							tryAgain _ true]]]].
		tryAgain ifFalse: [
			str _ loaded printString ,' new update file(s) processed.'.
			^ self inform: str].
	].! !

!Utilities class methodsFor: 'fetching updates' stamp: 'laza 8/28/2005 04:55'!
retrieveUrls: urls ontoQueue: queue withWaitSema: waitSema 
	"download the given list of URLs. The queue will be loaded alternately  
	with url's and with the retrieved contents. If a download fails, the  
	contents will be #failed. If all goes well, a special pair with an empty  
	URL and the contents #finished will be put on the queue. waitSema is  
	waited on every time before a new document is downloaded; this keeps 
	the downloader from getting too far  ahead of the main process"
	"kill the existing downloader if there is one"
	| doc canPeek front updateCounter |
	UpdateDownloader
		ifNotNil: [UpdateDownloader terminate].
	updateCounter _ 0.
	"fork a new downloading process"
	UpdateDownloader _ [
		'Downloading updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar |
			urls
				do: [:url | 
					waitSema wait.
					queue nextPut: url.
					doc _ HTTPClient httpGet: url.
					doc isString
						ifTrue: [queue nextPut: #failed.
							UpdateDownloader _ nil.
							Processor activeProcess terminate]
						ifFalse: [canPeek _ 120 min: doc size.
							front _ doc next: canPeek.  doc skip: -1 * canPeek.
							(front beginsWith: '<!!DOCTYPE') ifTrue: [
								(front includesSubString: 'Not Found') ifTrue: [
									queue nextPut: #failed.
									UpdateDownloader _ nil.
									Processor activeProcess terminate]]].
						UpdateDownloader ifNotNil: [queue nextPut: doc. updateCounter _ updateCounter + 1. bar value: updateCounter]]].
			queue nextPut: ''.
			queue nextPut: #finished.
			UpdateDownloader _ nil] newProcess.
	UpdateDownloader priority: Processor userInterruptPriority.
	"start the process running"
	UpdateDownloader resume! !

!Utilities class methodsFor: 'fetching updates' stamp: 'th 4/25/2000 12:59'!
saveUpdate: doc onFile: fileName
	"Save the update on a local file.  With or without the update number on the front, depending on the preference #updateRemoveSequenceNum"

	| file fName pos updateDirectory |

	(FileDirectory default directoryNames includes: 'updates') ifFalse:
		[FileDirectory default createDirectory: 'updates'].
	updateDirectory _ FileDirectory default directoryNamed: 'updates'.

	fName _ fileName.
	(Preferences valueOfFlag: #updateRemoveSequenceNum) ifTrue:
		[pos _ fName findFirst: [:c | c isDigit not].
		fName _ fName copyFrom: pos to: fName size].
	doc reset; ascii.
	(updateDirectory fileExists: fName) ifFalse:
		[file _ updateDirectory newFileNamed: fName.
		file nextPutAll: doc contents.
		file close].
! !

!Utilities class methodsFor: 'fetching updates' stamp: 'nk 6/26/2003 21:12'!
serverUrls 
	"Return the current list of server URLs.  For code updates.  Format of UpdateUrlLists is 
#( ('squeak updates' ('url1' 'url2'))
    ('some other updates' ('url3' 'url4')))"

	| list |
	list _ UpdateUrlLists first last.

	"If there is a dead server, return a copy with that server last" 
	Socket deadServer ifNotNil: [
		list clone withIndexDo: [:aName :ind |
		(aName beginsWith: Socket deadServer) ifTrue: [
			list _ list asOrderedCollection.	"and it's a copy"
			list removeAt: ind.
			list addLast: aName]]
	].

	^ list asArray! !

!Utilities class methodsFor: 'fetching updates' stamp: 'mir 8/10/2001 12:30'!
setUpdateServer: groupName
	"Utilities setUpdateServer: 'Squeakland' "
	| entry index |


	entry _ UpdateUrlLists detect: [:each | each first = groupName] ifNone: [^self].
	index _ UpdateUrlLists indexOf: entry.
	UpdateUrlLists removeAt: index.
	UpdateUrlLists addFirst: entry! !

!Utilities class methodsFor: 'fetching updates' stamp: 'ar 9/27/2005 20:15'!
summariesForUpdates: startNumber through: stopNumber
	"Answer the concatenation of summary strings for updates numbered in the given range"

	^ String streamContents: [:aStream |
		((ChangeSet changeSetsNamedSuchThat:
			[:aName | aName first isDigit and:
						[aName initialIntegerOrNil >= startNumber] and:
						[aName initialIntegerOrNil <= stopNumber]]) asSortedCollection:
				[:a :b | a name < b name]) do:
					[:aChangeSet | aStream cr; nextPutAll: aChangeSet summaryString]]

"Utilities summariesForUpdates: 4899 through: 4903"

! !

!Utilities class methodsFor: 'fetching updates' stamp: 'di 4/30/2001 11:28'!
updateComment
"The following used to be at the beginning of the update file.
	Now it is here to simplify parsing the file...

* To add a new update:  Name it starting with a new four-digit code.  
* Do not use %, /, *, space, or more than one period in the name of an update file.
* The update name does not need to have any relation to the version name.
* Figure out which versions of the system the update makes sense for.
* Add the name of the file to each version's category below.
* Put this file and the update file on all of the servers.
*
* To make a new version of the system:  Pick a name for it (no restrictions)
* Put # and exactly that name on a new line at the end of this file.
* During the release process, fill in exactly that name in the dialog box.
* Put a copy of updates.list on the server.
*
* Special file with a different name for Disney Internal Updates.  
* No need to move or rename files to release them to external updates.
"! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 10/13/1998 16:03'!
updateFromServer
	"Update the image by loading all pending updates from the server.  Also save local copies of the update files if the #updateSavesFile preference is set to true"

	self readServerUpdatesSaveLocally: Preferences updateSavesFile updateImage: true! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 1/10/1999 01:59'!
updateFromServerThroughUpdateNumber: aNumber
	"Update the image by loading all pending updates from the server.  Also save local copies of the update files if the #updateSavesFile preference is set to true"

	self readServerUpdatesThrough: aNumber saveLocally: Preferences updateSavesFile updateImage: true! !

!Utilities class methodsFor: 'fetching updates' stamp: 'tk 5/7/1998 17:03'!
updateUrlLists

	UpdateUrlLists ifNil: [UpdateUrlLists _ OrderedCollection new].
	^ UpdateUrlLists! !

!Utilities class methodsFor: 'fetching updates' stamp: 'di 4/29/2001 14:04'!
writeList: listContents toStream: strm
	"Write a parsed updates.list out as text.
	This is the inverse of parseListContents:"

	| fileNames version |
	strm reset.
	listContents do:
		[:pair | version _ pair first.  fileNames _ pair last.
		strm nextPut: $#; nextPutAll: version; cr.
		fileNames do: [:fileName | strm nextPutAll: fileName; cr]].
	strm close! !

!Utilities class methodsFor: 'fetching updates' stamp: 'RAA 12/17/2000 16:19'!
zapUpdateDownloader

	UpdateDownloader ifNotNil: [UpdateDownloader terminate].
	UpdateDownloader _ nil.! !


!Utilities class methodsFor: 'finding pointers' stamp: 'ar 7/16/2005 19:56'!
pointersToItem: index of: anArray
	"Find all occurrences in the system of pointers to the given element of the given array. This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate:

	Utilities pointersToItem: 2 of: self

in the inspector."
	^ self pointersTo: (anArray at: index) except: (Array with: anArray)! !

!Utilities class methodsFor: 'finding pointers' stamp: 'ar 7/16/2005 19:56'!
pointersTo: anObject
	"Find all occurrences in the system of pointers to the argument anObject."
	"(Utilities pointersTo: Browser) inspect."
	^ self pointersTo: anObject except: #()
! !

!Utilities class methodsFor: 'finding pointers' stamp: 'ar 7/16/2005 19:57'!
pointersTo: anObject except: objectsToExclude 
	"Find all occurrences in the system of pointers to the argument
	anObject. Remove objects in the exclusion list from the
	results. "
	| results anObj |
	Smalltalk garbageCollect.
	"big collection shouldn't grow, so it's contents array is always the same"
	results := OrderedCollection new: 1000.
	"allObjectsDo: is expanded inline to keep spurious
	method and block contexts out of the results"
	anObj := self someObject.
	[0 == anObj] whileFalse: [
		anObj isInMemory ifTrue: [
			(anObj pointsTo: anObject) ifTrue: [
				"exclude the results collector and contexts in call chain"
				(anObj ~~ results collector 
					and: [anObj ~~ objectsToExclude
					and: [anObj ~~ thisContext
					and: [anObj ~~ thisContext sender
					and: [anObj ~~ thisContext sender sender]]]])
						ifTrue: [results add: anObj]]].
		anObj := anObj nextObject].
	objectsToExclude do: [:obj | results removeAllSuchThat: [:el | el == obj]].
	^ results asArray! !


!Utilities class methodsFor: 'graphical support'!
showFormsAcrossTopOfScreen: aFormList
	"Display the given array of forms across the top of the screen, wrapping to subsequent lines if needed.    Useful for example for looking at sets of rotations and animations.  6/10/96 sw"

	| position maxHeight screenBox ceiling |

	position _ 20.
	maxHeight _ 0.
	ceiling _ 0.
	screenBox _ Display boundingBox.
	aFormList do:
		[:elem | elem displayAt: (position @ ceiling).
			maxHeight _ maxHeight max: elem boundingBox height.
			position _ position + elem boundingBox width + 5.
			position > (screenBox right - 100) ifTrue:
				[position _ 20.
				ceiling _ ceiling + maxHeight + 10.
				maxHeight _ 0]]! !

!Utilities class methodsFor: 'graphical support' stamp: 'nk 8/30/2004 08:02'!
showFormsDictAcrossTopOfScreen: formDict
	"Display the given Dictionary of forms across the top of the screen, wrapping to subsequent lines if needed.  Beneath each, put the name of the associated key."

	"Utilities showFormsDictAcrossTopOfScreen: HaloIcons"

	| position maxHeight screenBox ceiling elem box h labelWidth keyString |

	position _ 20.
	maxHeight _ 0.
	ceiling _ 0.
	screenBox _ Display boundingBox.
	formDict associationsDo:
		[:assoc | (elem _ assoc value) displayAt: (position @ ceiling).
			box _ elem boundingBox.
			h _ box height.
			keyString _ (assoc key isString) ifTrue: [assoc key] ifFalse: [assoc key printString].
			keyString displayAt: (position @ (ceiling + h)).
			labelWidth _ TextStyle default defaultFont widthOfString: keyString.
			maxHeight _ maxHeight max: h.
			position _ position + (box width max: labelWidth) + 5.
			position > (screenBox right - 100) ifTrue:
				[position _ 20.
				ceiling _ ceiling + maxHeight + 15.
				maxHeight _ 0]]! !


!Utilities class methodsFor: 'identification' stamp: 'dhhi 11/6/97 16:48'!
authorInitials
	"Answer the initials to be used to identify the current code author.  "

	[AuthorInitials isEmpty] whileTrue: [self setAuthorInitials].
	^ AuthorInitials! !

!Utilities class methodsFor: 'identification' stamp: 'sw 7/6/1998 11:49'!
authorInitialsPerSe
	"Answer the currently-prevailing author initials, such as they, empty or not"

	^ AuthorInitials! !

!Utilities class methodsFor: 'identification' stamp: 'fc 3/11/2004 12:22'!
authorName
	AuthorName ifEmpty: [self setAuthorName].
	^ AuthorName! !

!Utilities class methodsFor: 'identification' stamp: 'ar 8/23/2001 22:44'!
authorName: aString
	AuthorName _ aString! !

!Utilities class methodsFor: 'identification' stamp: 'RAA 12/28/2000 16:32'!
authorNamePerSe

	^ AuthorName! !

!Utilities class methodsFor: 'identification' stamp: 'tk 4/10/98 06:25'!
changeStamp 
	"Answer a string to be pasted into source code to mark who changed it and when."
	^ self authorInitials , ' ' , Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !

!Utilities class methodsFor: 'identification' stamp: 'sw 1/29/2001 09:28'!
changeStampPerSe
	"Answer a string to be pasted into source code to mark who changed it and when."

	^ (self authorInitialsPerSe ifNil: ['·']) , ' ' , Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !

!Utilities class methodsFor: 'identification'!
copyrightNotice
	^ 'Copyright 1985-96, Apple Computer, Inc.'! !

!Utilities class methodsFor: 'identification' stamp: 'tk 4/10/1998 07:16'!
dateStamp
	"Utilities dateStamp"
	^ Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !

!Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 22:45'!
dateTimeSuffix
	"Answer a string which indicates the date and time, intended for use in building fileout filenames, etc."

	"Utilities dateTimeSuffix"
	^ Preferences twentyFourHourFileStamps
		ifFalse:
			[self monthDayTimeStringFrom: Time primSecondsClock]
		ifTrue:
			[self monthDayTime24StringFrom: Time primSecondsClock]! !

!Utilities class methodsFor: 'identification' stamp: 'di 6/13/97 13:52'!
fixStamp: changeStamp 
	| parts |
	parts _ changeStamp findTokens: ' '.
	(parts size > 0 and: [parts last first isLetter]) ifTrue:
		["Put initials first in all time stamps..."
		^ String streamContents:
				[:s | s nextPutAll: parts last.
				parts allButLast do: [:p | s space; nextPutAll: p]]].
	^ changeStamp! !

!Utilities class methodsFor: 'identification' stamp: 'yo 12/3/2004 17:04'!
methodsWithInitials: targetInitials
	"Based on a do-it contributed to the Squeak mailing list by Göran Hultgen:
 Browse methods whose initials (in the time-stamp, as logged to disk) match the given initials.
 Print out the complete time-stamp table to the Transcript.
 Answer a list of (initials -> count) associations.

CAUTION: It may take several minutes for this to complete."

	"Time millisecondsToRun: [Utilities methodsWithInitials: 'bf']"

	| initials timeStamp  allSubmitters |
	initials _ ''.
	timeStamp _ ''.
	allSubmitters _ Bag new.
	self systemNavigation
		browseAllSelect:
			[:cm |
				timeStamp _ Utilities timeStampForMethod: cm.
				initials _ timeStamp isEmpty
					ifTrue:
						['']
					ifFalse:
						[timeStamp substrings first].
				initials _ initials isEmpty
					ifTrue:
						['<no time stamp>']
					ifFalse:
						[initials first isDigit
							ifTrue:
								['<date>']
							ifFalse:
								[initials]].
				allSubmitters add: initials.
				(initials = targetInitials)]
		name: ('Methods with initials ', targetInitials)
		autoSelect: nil.

	allSubmitters sortedCounts do: [:elem | Transcript cr; show: elem asString].
	^ allSubmitters
! !

!Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 23:03'!
monthDayTime24StringFrom: aSecondCount
	| aDate aTime |
	"From the date/time represented by aSecondCount, produce a string which indicates the date and time in the compact form
             ddMMMhhmm		where dd is a two-digit day-of-month, MMM is the alpha month abbreviation and hhmm is the time on a 24-hr clock.

          Utilities monthDayTime24StringFrom: Time primSecondsClock
"

	aDate _ Date fromSeconds: aSecondCount.
	aTime _ Time fromSeconds: aSecondCount \\ 86400.

	^ (aDate dayOfMonth asTwoCharacterString), 
		(aDate monthName copyFrom: 1 to: 3), 
		(aTime hhmm24)! !

!Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 23:03'!
monthDayTimeStringFrom: aSecondCount
	| aDate aTime |
	"From the date/time represented by aSecondCount, produce a string which indicates the date and time in the form:
		ddMMMhhmmPP	  where:
							dd is a two-digit day-of-month,
							MMM is the alpha month abbreviation,
							hhmm is the time,
							PP is either am or pm

          Utilities monthDayTimeStringFrom: Time primSecondsClock
"

	aDate _ Date fromSeconds: aSecondCount.
	aTime _ Time fromSeconds: aSecondCount \\ 86400.

	^ (aDate dayOfMonth asTwoCharacterString), 
		(aDate monthName copyFrom: 1 to: 3), 
		((aTime hours \\ 12) asTwoCharacterString), 
		(aTime minutes asTwoCharacterString),
		(aTime hours > 12 ifTrue: ['pm'] ifFalse: ['am'])! !

!Utilities class methodsFor: 'identification' stamp: 'CdG 10/17/2005 20:56'!
setAuthorInitials
	"Put up a dialog allowing the user to specify the author's initials.  "

	self setAuthorInitials:
		(UIManager default request: 'Please type your initials: ' translated
					initialAnswer: AuthorInitials)! !

!Utilities class methodsFor: 'identification' stamp: 'fc 3/11/2004 12:13'!
setAuthorInitials: aString

	AuthorInitials _ aString.

	"Case of being reset due to, eg, copy of image."
	aString isEmpty ifTrue: [AuthorName _ '']! !

!Utilities class methodsFor: 'identification' stamp: 'CdG 10/17/2005 20:57'!
setAuthorName
	AuthorName := UIManager default 
			request: 'Please type your name:' translated
			initialAnswer: 'Your Name' translated! !


!Utilities class methodsFor: 'investigations' stamp: 'sd 4/29/2003 11:59'!
reportSenderCountsFor: selectorList 
	"Produce a report on the number of senders of each of the selectors in 
	the list. 1/27/96 sw"
	| total report thisSize |
	total _ 0.
	report _ '
'.
	selectorList
		do: [:selector | 
			thisSize _ (self systemNavigation allCallsOn: selector) size.
			report _ report , thisSize printString , String tab , selector printString , String cr.
			total _ total + thisSize].
	report _ report , '--- ------------------
'.
	report _ report , total printString , String tab , 'TOTAL
'.
	^ report! !


!Utilities class methodsFor: 'miscellaneous'!
awaitMouseUpIn: box repeating: doBlock ifSucceed: succBlock
	"The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock.  While waiting for the mouse to come up, repeatedly execute doBlock. 5/11/96 sw
	6/10/96 sw: call new method that adds extra feature"

	^ self awaitMouseUpIn: box whileMouseDownDo: doBlock whileMouseDownInsideDo: [] ifSucceed: succBlock! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'JMM 3/31/2000 20:41'!
awaitMouseUpIn: box whileMouseDownDo: doBlock1 whileMouseDownInsideDo: doBlock2 ifSucceed: succBlock
	"The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock.  While waiting for the mouse to come up, repeatedly execute doBlock1, and also, if the cursor is within the box, execute doBlock2.  6/10/96 sw
3/31/00 JMM added logic to stop multiple redraws"

	| p inside lightForm darkForm isLight |

	p _ Sensor cursorPoint.
	inside _ box insetBy: 1.
	isLight _ true.
	lightForm _ Form fromDisplay: inside.
	darkForm _ lightForm deepCopy reverse.
	[Sensor anyButtonPressed] whileTrue:
		[doBlock1 value.
		(box containsPoint: (p _ Sensor cursorPoint))
			ifTrue: [doBlock2 value.
					isLight ifTrue: 
						[isLight _ false.
						darkForm displayAt: inside origin]]
			ifFalse: [isLight ifFalse:
						[isLight _ true.
						lightForm displayAt: inside origin]]].
	(box containsPoint: p)
		ifTrue: [lightForm displayAt: inside origin.
				^ succBlock value]
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 9/6/2000 09:06'!
cleanseOtherworldlySteppers
	"If the current project is a morphic one, then remove from its steplist those morphs that are not really in the world"

	| old delta |
	Smalltalk isMorphic ifTrue:
		[old _ self currentWorld stepListSize.
		self currentWorld steppingMorphsNotInWorld do: [:m | m delete].
		self currentWorld cleanseStepList.
		(delta _ (old - self currentWorld stepListSize)) > 0 ifTrue:
			[Transcript cr; show: (delta asString, ' morphs removed from steplist')]]

	"Utilities cleanseOtherworldlySteppers"! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'mdr 8/31/2000 18:54'!
convertCRtoLF: fileName
	"Convert the given file to LF line endings. Put the result in a file with the extention '.lf'"

	| in out c justPutCR |
	in _ (FileStream readOnlyFileNamed: fileName) binary.
	out _  (FileStream newFileNamed: fileName, '.lf') binary.
	justPutCR _ false.
	[in atEnd] whileFalse: [
		c _ in next.
		c = 10
			ifTrue: [
				out nextPut: 13.
				justPutCR _ true]
			ifFalse: [
				(justPutCR and: [c = 10]) ifFalse: [out nextPut: c].
				justPutCR _ false]].
	in close.
	out close.
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'ar 9/27/2005 20:50'!
createPageTestWorkspace
	"Used to generate a workspace window for testing page up and page down stuff."
	"Utilities createPageTestWorkspace"

	| numberOfLines maxStringLength minLineCounterSize lineCounterSize offsetSize stream headerConstant prevStart prevStrLen prevLineNumber stringLen lineNumber start log pad charIndex char |
	numberOfLines := 400.
	maxStringLength := 22.
	minLineCounterSize := 3.
	lineCounterSize := (numberOfLines log asInteger + 1) max: minLineCounterSize.
	offsetSize := 5.
	stream := ReadWriteStream on: ''.
	headerConstant := lineCounterSize + 1 + offsetSize + 1.
	prevStart := headerConstant negated.
	prevStrLen := 0.
	prevLineNumber := 0.
	numberOfLines timesRepeat: [
		stringLen := maxStringLength atRandom max: 1.
		lineNumber := prevLineNumber + 1.
		start := prevStart + prevStrLen + headerConstant + 1.
		prevStart := start.
		prevStrLen := stringLen.
		prevLineNumber := lineNumber.
		log := lineNumber log asInteger.
		pad := lineCounterSize - log - 1.
		pad timesRepeat: [stream nextPutAll: '0'].
		stream nextPutAll: lineNumber printString.
		stream space.
		log := start log asInteger.
		pad := offsetSize - log - 1.
		pad timesRepeat: [stream nextPutAll: '0'].
		stream nextPutAll: start printString.
		stream space.
		charIndex := 'a' first asInteger.
		stringLen timesRepeat: [
			char := Character value: charIndex.
			charIndex := charIndex + 1.
			stream nextPut: char].
		lineNumber = numberOfLines ifFalse: [stream cr]
		].
	UIManager default edit: stream contents label: 'Test Data'.
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'nk 5/18/2003 13:03'!
decimalPlacesForFloatPrecision: precision
	"Answer the number of decimal places that correspond to the given floatPrecision"

	^ (#(1 0.1 0.01 0.001 0.0001 0.00001 0.000001 0.0000001 0.00000001 0.000000001) indexOf: precision ifAbsent: [ ^precision log negated floor ]) - 1

"
#(1 0.1 0.01 0.001 0.0001 0.00001 0.000001 0.0000001 0.00000001 0.000000001) collect: [:prec | Utilities decimalPlacesForFloatPrecision: prec]
"! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sd 4/17/2003 21:04'!
decommissionTheAllCategory
	"Utilities decommissionTheAllCategory"
	"Moves all methods that are in a category named 'all' into the default 'as yet unclassified' category"

	| org aCategory methodCount classCount any |
	self flag: #ShouldBeMovedIntoClassOrganization. "sd"
	methodCount _ 0.
	classCount _ 0.
	self systemNavigation allBehaviorsDo:
		[:aClass | org _ aClass organization.
			any _ false.
			aClass selectorsDo:
				[:aSelector |
					aCategory _ org categoryOfElement: aSelector.
					aCategory = #all ifTrue:
						[org classify: aSelector under: ClassOrganizer default suppressIfDefault: false.
						methodCount _ methodCount + 1.
						any _ true]].
			any ifTrue: [classCount _ classCount + 1].
			org removeEmptyCategories].
	Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved
from "all" to "as yet unclassified"'
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 11/21/2001 10:58'!
doesMethod: aSelector forClass: aClass bearInitials: initials
	"Answer whether a method bears the given initials at the head of its time stamp"

	| aTimeStamp implementingClass aMethod |
	implementingClass _ aClass whichClassIncludesSelector: aSelector.
	implementingClass ifNil: [^ false].
	(aMethod _ implementingClass compiledMethodAt: aSelector)
		ifNil: [^ false].
	^ (aTimeStamp _ self timeStampForMethod: aMethod) notNil and:
		[aTimeStamp beginsWith: initials]! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sma 4/30/2000 10:17'!
emergencyCollapse
	Smalltalk isMorphic ifTrue: [^ self].
	ScheduledControllers screenController emergencyCollapse! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sd 4/17/2003 21:04'!
fixUpProblemsWithAllCategory
	"Moves all methods that are in formally classified a category named '-- all --' into the default 'as yet unclassified' category"

	"Utilities fixUpProblemsWithAllCategory"

	| org aCategory methodCount classCount any |
	self flag: #ShouldBeMovedInClassOrganization.
	methodCount _ 0.
	classCount _ 0.
	self systemNavigation allBehaviorsDo:
		[:aClass | org _ aClass organization.
			(org categories includes: #'-- all --') ifTrue:
				[any _ false.
				aClass selectorsDo:
					[:aSelector |
						aCategory _ org categoryOfElement: aSelector.
						aCategory = #'-- all --' ifTrue:
							[org classify: aSelector under: ClassOrganizer default suppressIfDefault: false.
							Transcript cr; show: aClass name, ' >> ', aSelector.
							methodCount _ methodCount + 1.
							any _ true]].
			any ifTrue: [classCount _ classCount + 1].
			org removeEmptyCategories]].
	Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved from "-- all --" to "as yet unclassified"'
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'dtl 11/25/2004 22:10'!
floatPrecisionForDecimalPlaces: places
	"Answer the floatPrecision that corresponds to the given number of decimal places"

	^ places caseOf:
			{[0]->[1] .
			[1]->[0.1] . 
			[2]->[0.01] .
			[3]->[0.001] .
			[4]->[0.0001] .
			[5]->[0.00001] .
			[6]->[0.000001] .
			[7]->[0.0000001] .
			[8]->[0.00000001] .
			[9]->[0.000000001]}
		otherwise:
			[(10.0 raisedTo: places negated) asFloat]

"
(0 to: 6) collect: [:i | Utilities floatPrecisionForDecimalPlaces: i]
(-10 to: 20) collect: [:i | Utilities floatPrecisionForDecimalPlaces: i]
"! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'nk 2/15/2004 09:36'!
garbageCollectAndReport
	"Do a garbage collection, and report results to the user."

	| cc reportString |
	reportString _ String streamContents:
		[:aStream | 
			aStream nextPutAll: Smalltalk bytesLeftString.
			Smalltalk at: #Command ifPresent:
				[:cmdClass |
				(cc _ cmdClass instanceCount) > 0 ifTrue:
					[aStream cr; nextPutAll:
		('(note: there are ', cc printString,
		                         ' undo record(s) present in your
system; purging them may free up more space.)')]]].
			
	self inform: reportString
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 11/16/2001 14:43'!
getterSelectorFor: identifier
	"Answer the corresponding getter.  Two idiosyncratic vectorings herein... " 

	"Utilities getterSelectorFor: #elvis"

	| aSymbol |
	(aSymbol _ identifier asSymbol) == #isOverColor: ifTrue: [^ #seesColor:].
	aSymbol == #copy ifTrue: [^ #getNewClone].

	^ ('get', (identifier asString capitalized)) asSymbol! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 5/19/2000 16:04'!
inherentSelectorForGetter: aGetterSelector
	"Given a selector of the form #getAbc, return the inherent slotname selector that corresponds, which is to say, getterSelector with the leading 'get' removed and with the next character forced to lower case; this is the inverse of #getterSelectorFor:"

	"Utilities inherentSelectorForGetter: #getWidth"
	((aGetterSelector size < 4) or: [(aGetterSelector beginsWith: 'get') not])
			ifTrue: [ ^ aGetterSelector].
	^ ((aGetterSelector at: 4) asLowercase asString, (aGetterSelector copyFrom: 5 to: aGetterSelector size)) asSymbol! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'mdr 9/4/2000 11:07'!
instanceComparisonsBetween: fileName1 and: fileName2
	"For differential results, run printSpaceAnalysis twice with different fileNames,
	then run this method...
		Smalltalk printSpaceAnalysis: 0 on: 'STspace.text1'.
			--- do something that uses space here ---
		Smalltalk printSpaceAnalysis: 0 on: 'STspace.text2'.
		Smalltalk instanceComparisonsBetween: 'STspace.text1' and 'STspace.text2'"

	| instCountDict report f aString items className newInstCount oldInstCount newSpace oldPair oldSpace |
	instCountDict _ Dictionary new.
	report _ ReadWriteStream on: ''.
	f _ FileStream readOnlyFileNamed: fileName1.
	[f atEnd] whileFalse:
		[aString _ f upTo: Character cr.
		items _ aString findTokens: ' '.
		(items size == 4 or: [items size == 5]) ifTrue:
			[instCountDict at: items first put: (Array with: items third asNumber with: items fourth asNumber)]].
	f close.

	f _ FileStream readOnlyFileNamed: fileName2.
	[f atEnd] whileFalse:
		[aString _ f upTo: Character cr.
		items _ aString findTokens: ' '.
		(items size == 4 or: [items size == 5]) ifTrue:
			[className _ items first.
			newInstCount _ items third asNumber.
			newSpace _ items fourth asNumber.
			oldPair _ instCountDict at: className ifAbsent: [nil].
			oldInstCount _ oldPair ifNil: [0] ifNotNil: [oldPair first].
			oldSpace _ oldPair ifNil: [0] ifNotNil: [oldPair second].
			oldInstCount ~= newInstCount ifTrue:
				[report nextPutAll: (newInstCount - oldInstCount) printString; tab; nextPutAll: (newSpace - oldSpace) printString; tab; nextPutAll: className asString; cr]]].
	f close.

	(StringHolder new contents: report contents)
		openLabel: 'Instance count differentials between ', fileName1, ' and ', fileName2! !

!Utilities class methodsFor: 'miscellaneous'!
keyLike: aString satisfying: aBlock
	"Return a key like aString that satisfies aBlock.  The block should provide a test for acceptability -- typically the test is about whether the key is already in use.  aBlock should return a boolean.  8/11/96 sw"

	| stemAndSuffix suffix stem newKey |
	(aBlock value: aString) ifTrue: [^ aString].
	stemAndSuffix _ aString stemAndNumericSuffix.
	suffix _ stemAndSuffix last + 1.
	stem _ stemAndSuffix first.
	[aBlock value: (newKey _ stem, suffix printString)]
		whileFalse:
			[suffix _ suffix + 1].
	^ newKey
! !

!Utilities class methodsFor: 'miscellaneous'!
keyLike: aString withTrailing: trailerString satisfying: aBlock
	"Return a key like (aString, trailerString) that satisfies aBlock.  The block should provide a test for acceptability -- typically the test is about whether the key is already in use.  aBlock should return a boolean.  8/11/96 sw"

	| stemAndSuffix suffix stem composite |
	composite _ aString, trailerString.
	(aBlock value: composite) ifTrue: [^ composite].
	stemAndSuffix _ aString stemAndNumericSuffix.
	suffix _ stemAndSuffix last + 1.
	stem _ stemAndSuffix first.
	[aBlock value: (composite _ stem, suffix printString, trailerString)]
		whileFalse:
			[suffix _ suffix + 1].
	^ composite
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'md 11/14/2003 18:02'!
methodDiffFor: aString class: aClass selector: aSelector prettyDiffs: prettyDiffBoolean
	"Return a string comprising a source-code diff between an existing method and the source-code in aString.  DO prettyDiff if prettyDiffBoolean is true."

	^ (aClass notNil and: [aClass includesSelector: aSelector])
		ifTrue:
			[TextDiffBuilder
				buildDisplayPatchFrom: (aClass sourceCodeAt: aSelector)
				to: aString
				inClass: aClass
				prettyDiffs: prettyDiffBoolean]
		ifFalse:
			[aString copy]! !

!Utilities class methodsFor: 'miscellaneous'!
nextClockwiseSideAfter: aSide
 	aSide == #left ifTrue:
		[^ #top].
	aSide == #right ifTrue:
		[^ #bottom].
	aSide == #top ifTrue:
		[^ #right].
	^ #left! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'jm 5/3/1998 20:12'!
openScratchWorkspaceLabeled: labelString contents: initialContents
	"Open a scratch text view with the given label on the given string. A scratch text view won't warn you about unsaved changes when you close it."
	"Utilities openScratchWorkspaceLabeled: 'Scratch' contents: 'Hello. world!!'"

	| model topView stringView |
	model _ StringHolder new contents: initialContents.
	topView _ StandardSystemView new.
	topView
		model: model;
		label: labelString;
		minimumSize: 180@120.
	topView borderWidth: 1.
	stringView _ PluggableTextView on: model 
		text: #contents
		accept: nil
		readSelection: #contentsSelection
		menu: #codePaneMenu:shifted:.
	stringView
		askBeforeDiscardingEdits: false;
		window: (0@0 extent: 180@120).
	topView addSubView: stringView.
	topView controller open.
! !

!Utilities class methodsFor: 'miscellaneous'!
oppositeCornerFrom: aCorner
	"Answer the corner diagonally opposite to aCorner.  6/27/96 sw"

	aCorner == #topLeft
		ifTrue:
			[^ #bottomRight].
	aCorner == #topRight
		ifTrue:
			[^ #bottomLeft].
	aCorner == #bottomLeft
		ifTrue:
			[^ #topRight].
	^ #topLeft! !

!Utilities class methodsFor: 'miscellaneous'!
oppositeModeTo: aMode
 	aMode == #readOnly ifTrue: [^ #writeOnly].
	aMode == #writeOnly ifTrue: [^ #readOnly].
	^ aMode! !

!Utilities class methodsFor: 'miscellaneous'!
oppositeSideTo: aSide
 	aSide == #left ifTrue:
		[^ #right].
	aSide == #right ifTrue:
		[^ #left].
	aSide == #top ifTrue:
		[^ #bottom].
	^ #top! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 1/5/1999 01:30'!
reconstructTextWindowsFromFileNamed: aName
	"Utilities reconstructTextWindowsFromFileNamed: 'TextWindows'"
	| aReferenceStream aDict |
	aReferenceStream _ ReferenceStream fileNamed: aName.
	aDict _ aReferenceStream next.
	aReferenceStream close.
	aDict associationsDo:
		[:assoc |
			(StringHolder new contents: assoc value) openLabel: assoc key andTerminate: false].
	Smalltalk isMorphic ifFalse:
		[ScheduledControllers restore.
		Processor terminateActive]! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'RAA 5/28/2001 10:02'!
setClassAndSelectorFrom: messageIDString in: csBlock
	"Decode strings of the form <className> [class] <selectorName>.   If <className> does not exist as a class, use nil for the class in the block"

	| aStream aClass maybeClass sel |

	(messageIDString isKindOf: MethodReference) ifTrue: [
		^messageIDString setClassAndSelectorIn: csBlock
	].

	aStream _ ReadStream on: messageIDString.
	aClass _ Smalltalk at: (aStream upTo: $ ) asSymbol ifAbsent: [nil].
	maybeClass _ aStream upTo: $ .
	sel _ aStream upTo: $ .
	((maybeClass = 'class') & (sel size ~= 0))
		ifTrue:
			[aClass
				ifNil:
					[csBlock value: nil value: sel asSymbol]
				ifNotNil:
					[csBlock value: aClass class value: sel asSymbol]]
		ifFalse:
			[csBlock value: aClass value: maybeClass asSymbol]


"
Utilities setClassAndSelectorFrom: 'Utilities class oppositeModeTo:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString].

Utilities setClassAndSelectorFrom: 'MessageSet setClassAndSelectorIn:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString].
"
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 1/30/98 15:12'!
setterSelectorFor: aName
	"Utilities setterSelectorFor: #elvis"
	^ (('set', (aName asString capitalized)), ':') asSymbol! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 2/16/1999 18:07'!
simpleSetterFor: aSymbol
	"Utilities simpleSetterFor: #right"
	^ (aSymbol, ':') asSymbol! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 9/8/2000 10:02'!
steplistToolsWorkspace
	^ ((StringHolder new contents:  'self currentWorld listOfSteppingMorphs asArray inspectWithLabel: ''stepping morphs''.
Utilities cleanseOtherworldlySteppers.
self currentWorld steppingMorphsNotInWorld do: [:m | m delete].
self currentWorld stepListSummary.
self currentWorld stepListSize.
self currentHand attachMorph: FrameRateMorph new') embeddedInMorphicWindowLabeled: 'Steplist workspace')

setWindowColor: (Color r: 0.9 g: 0.7 b: 0.5);
			openInWorld: self currentWorld extent: (550 @ 140)

"Utilities steplistToolsWorkspace"! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'ar 9/27/2005 20:50'!
storeTextWindowContentsToFileNamed: aName
	"Utilities storeTextWindowContentsToFileNamed: 'TextWindows'"
	| windows aDict assoc aRefStream textToUse aTextView |

	"there is a reference to World, but this method seems to be unused"


	aDict := Dictionary new.
	Smalltalk isMorphic
		ifTrue:
			[windows := World submorphs select: [:m | m isSystemWindow].
			windows do:
				[:w | assoc := w titleAndPaneText.
				assoc ifNotNil:
					[w holdsTranscript ifFalse:
						[aDict add: assoc]]]]
		ifFalse:
			[windows := ScheduledControllers controllersSatisfying:
				[:c | (c model isKindOf: StringHolder)].
			windows do:
				[:aController | 
					aTextView := aController view subViews detect: [:m | m isKindOf: PluggableTextView] ifNone: [nil].
					textToUse := aTextView
						ifNil:		[aController model contents]
						ifNotNil:	[aTextView controller text].  "The latest edits, whether accepted or not"
					aDict at: aController view label put: textToUse]].

	aDict size = 0 ifTrue: [^ self inform: 'no windows found to export.'].

	aRefStream := ReferenceStream fileNamed: aName.
	aRefStream nextPut: aDict.
	aRefStream close.
	self inform: 'Done!!  ', aDict size printString, ' window(s) exported.'! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 7/29/2002 02:23'!
timeStampForMethod: method
	"Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available."
	"Utilities timeStampForMethod: (Utilities class compiledMethodAt: #timeStampForMethod:)"

	^ method timeStamp! !


!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 7/29/2002 02:18'!
assureMostRecentSubmissionExists
	"Make certain that the most recent submission exists"

	[RecentSubmissions size > 0 and:
		[RecentSubmissions last isValid not]] whileTrue:
			[RecentSubmissions removeLast].! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'nk 8/30/2004 08:02'!
dumpAnyOldStyleRecentSubmissions

	"simplify conversion by purging those recent submissions which are still Strings"

	RecentSubmissions _ self recentMethodSubmissions reject: [ :each |
		each isString
	].! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'NS 4/12/2004 22:47'!
event: anEvent
	"Hook for SystemChangeNotifier"

	(anEvent isCommented and: [anEvent itemKind = SystemChangeNotifier classKind])
		ifTrue: [self noteMethodSubmission: #Comment forClass: anEvent item].
	((anEvent isAdded or: [anEvent isModified]) and: [anEvent itemKind = SystemChangeNotifier methodKind])
		ifTrue: [anEvent itemRequestor ifNotNil: [self noteMethodSubmission: anEvent itemSelector forClass: anEvent itemClass]].
	((anEvent isAdded or: [anEvent isModified]) and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue:[
		InMidstOfFileinNotification signal
			ifFalse: [Utilities changed: #recentMethodSubmissions].
	].! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 7/29/2002 02:12'!
mostRecentlySubmittedMessage
	"Answer a string indicating the most recently submitted method that is still extant"

	self flag: #mref.	"fix for faster references to methods"

	self assureMostRecentSubmissionExists.
	^ RecentSubmissions last asStringOrText asString! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/28/2001 10:53'!
noteMethodSubmission: selectorName forClass: class

	| submission |

	self flag: #mref.	"fix for faster references to methods"

	self recentMethodSubmissions.	"ensure it is valid"
	class wantsChangeSetLogging ifFalse: [^ self].
	self purgeRecentSubmissionsOfMissingMethods.
	submission _ class name asString, ' ', selectorName.
	RecentSubmissions removeAllSuchThat: [ :each |
		each asStringOrText = submission
	].
	RecentSubmissions size >= self numberOfRecentSubmissionsToStore ifTrue: [
		RecentSubmissions removeFirst
	].
	RecentSubmissions addLast: (
		MethodReference new
			setClass: class 
			methodSymbol: selectorName 
			stringVersion: submission
	) 
! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 7/28/2002 23:20'!
numberOfRecentSubmissionsToStore
	"Answer how many methods back the 'recent method submissions' history should store"

	^ Preferences parameterAt: #numberOfRecentSubmissionsToStore ifAbsentPut: [30]! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 7/28/2002 23:52'!
numberOfRecentSubmissionsToStore: aNumber
	"Set the number of Recent Submissions to store"

	Preferences setParameter: #numberOfRecentSubmissionsToStore to: aNumber! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 9/26/2002 19:16'!
purgeFromRecentSubmissions: aMethodReference
	"Purge any reference found in RecentSubmissions to the method supplied"

	RecentSubmissions _ RecentSubmissions select:
		[:aSubmission |
			Utilities setClassAndSelectorFrom: aSubmission in:
				[:aClass :aSelector | (aClass ~~ aMethodReference actualClass) or: [aSelector ~~ aMethodReference methodSymbol]]]! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 11/5/2001 12:04'!
purgeRecentSubmissionsOfMissingMethods
	"Utilities purgeRecentSubmissionsOfMissingMethods"

	| keep |
	self flag: #mref.	"fix for faster references to methods"
	RecentSubmissions _ RecentSubmissions select:
		[:aSubmission | 
			Utilities setClassAndSelectorFrom: aSubmission in:
				[:aClass :aSelector |
					keep _ (aClass == nil) not
						and: [aClass isInMemory
						and: [aSelector == #Comment or: [(aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil]]]].
			keep]! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/28/2001 07:39'!
recentMethodSubmissions
	"Answer the list of recent method submissions, in order.  5/16/96 sw"


	self flag: #mref.	"fix for faster references to methods"

	RecentSubmissions == nil ifTrue: [RecentSubmissions _ OrderedCollection new].
	^ RecentSubmissions! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'nb 6/17/2003 12:25'!
revertLastMethodSubmission
	| changeRecords lastSubmission theClass theSelector |
	"If the most recent method submission was a method change, revert
	that change, and if it was a submission of a brand-new method, 
	remove that method."

	RecentSubmissions isEmptyOrNil ifTrue: [^ Beeper beep].
	lastSubmission _ RecentSubmissions last.
	theClass _ lastSubmission actualClass ifNil: [^ Beeper beep].
	theSelector _ lastSubmission methodSymbol.
	changeRecords _ theClass changeRecordsAt: theSelector.
	changeRecords isEmptyOrNil ifTrue: [^ Beeper beep].
	changeRecords size == 1
		ifTrue:
			["method has no prior version, so reverting in this case means removing"
			theClass removeSelector: theSelector]
		ifFalse:
			[changeRecords second fileIn].

"Utilities revertLastMethodSubmission"! !


!Utilities class methodsFor: 'scraps' stamp: 'sw 8/18/1999 19:56'!
addToTrash: aMorph
	"Paste the object onto a page of the system Trash book, unless the preference is set to empty the trash immediately."

	| aBook aPage |
	Preferences preserveTrash ifFalse: [^ self].

	aBook _ self scrapsBook.
	aMorph position: aBook pages first position + (0@40).
	aBook pages do: [:pp | 
		(pp submorphs size = 1 and: [pp hasProperty: #trash]) ifTrue:  "perhaps remove that property here"
			["page is blank"
			^ pp addMorph: aMorph]].
	aPage _ aBook insertPageLabel: Time dateAndTimeNow printString
		morphs: (Array with: aMorph).
	aPage setProperty: #trash toValue: true! !

!Utilities class methodsFor: 'scraps' stamp: 'sw 10/21/1999 17:42'!
emptyScrapsBook
	"Utilities emptyScrapsBook"
	| oldScraps |
	oldScraps _ ScrapsBook.
	ScrapsBook _ nil.
	self scrapsBook.  "Creates it afresh"
	(oldScraps notNil and: [oldScraps owner notNil])
		ifTrue:
			[ScrapsBook position: oldScraps position.
			oldScraps owner replaceSubmorph: oldScraps by: ScrapsBook.
			ScrapsBook changed; layoutChanged]! !

!Utilities class methodsFor: 'scraps' stamp: 'dgd 9/19/2003 11:29'!
maybeEmptyTrash
	(self confirm: 'Do you really want to empty the trash?' translated)
		ifTrue: [self emptyScrapsBook]! !

!Utilities class methodsFor: 'scraps' stamp: 'yo 7/2/2004 21:49'!
scrapsBook
	| header aButton label |
	ScrapsBook ifNil:
		[ScrapsBook _ BookMorph new pageSize: 200@300; setNameTo: 'scraps' translated.
		ScrapsBook color: Color yellow muchLighter.
		ScrapsBook borderColor: Color darkGray; borderWidth: 2.
		ScrapsBook removeEverything; showPageControls; insertPage.
		header _ AlignmentMorph newRow wrapCentering: #center; cellPositioning: #leftCenter.
		header setProperty: #header toValue: true.
		header addMorph: (aButton _ SimpleButtonMorph new label: 'O' font: Preferences standardButtonFont).
		aButton target: ScrapsBook; color:  Color tan; actionSelector: #delete;
				setBalloonText: 'Close the trashcan.
(to view again later, click on any trashcan).' translated.

		header addMorphBack: AlignmentMorph newVariableTransparentSpacer beSticky.
		header addMorphBack: 	(label _ UpdatingStringMorph new target: self) beSticky.
		label getSelector: #trashTitle; useStringFormat; step.
		header addMorphBack: AlignmentMorph newVariableTransparentSpacer beSticky.
		header addMorphBack: (aButton _ SimpleButtonMorph new label: 'E' translated font: Preferences standardButtonFont).
		aButton target: Utilities; color:  Color veryLightGray; actionSelector: #maybeEmptyTrash;
				setBalloonText: 'Click here to empty the trash.' translated.
		ScrapsBook currentPage addMorph: (TextMorph new contents: 'Objects you drag into the trash will automatically be saved here, one object per page, in case you need them later.  To disable this feature set the "preserveTrash" Preference to false.

You can individually expunge objects by hitting the - control, and you can empty out all the objects in the trash can by hitting the "E" button at top right.' translated
			wrappedTo: 190).

		ScrapsBook addMorphFront: header.
		ScrapsBook setProperty: #scraps toValue: true].
	^ ScrapsBook

	"Utilities emptyScrapsBook"
! !

!Utilities class methodsFor: 'scraps' stamp: 'dgd 9/19/2003 10:49'!
trashTitle
	| label pgs |
	label _ 'T R A S H' translated.
	^ (pgs _ ScrapsBook pages size) < 2
		ifTrue:
			[label]
		ifFalse:
			[label, ('  ({1} pages)' translated format:{pgs})]
! !


!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 8/16/97 13:13'!
chooseFileWithSuffix: aSuffix
	"Utilities chooseFileWithSuffix: '.gif'"
	| aList aName |
	aList _ FileDirectory default fileNamesMatching: '*', aSuffix.
	aList size > 0
		ifTrue:
			[aName _ (SelectionMenu selections: aList) startUpWithCaption: 'Choose a file'.
			^ aName]
		ifFalse:
			[self inform: 'Sorry, there are no files
whose names end with "', aSuffix, '".'.
			^ nil]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 10/5/1998 17:58'!
chooseFileWithSuffixFromList: aSuffixList withCaption: aCaption
	"Pop up a list of all files in the default directory which have a suffix in the list.  Return #none if there are none; return nil if the user backs out of the menu without making a choice."
	"Utilities chooseFileWithSuffixFromList: #('.gif' '.jpg')"
	| aList aName |
	aList _ OrderedCollection new.
	aSuffixList do:
		[:aSuffix | aList addAll: (FileDirectory default fileNamesMatching: '*', aSuffix)].
	^ aList size > 0
		ifTrue:
			[aName _ (SelectionMenu selections: aList) startUpWithCaption: aCaption.
			aName]
		ifFalse:
			[#none]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 9/13/97 20:44'!
classCategoriesStartingWith: aPrefix
	"Answer a list of system class categories beginning with the given prefix"

	"Utilities classCategoriesStartingWith: 'Files'"

	^ SystemOrganization categories select:
		[:aCat | (aCat asString findString:  aPrefix startingAt: 1) = 1]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'al 1/13/2006 00:50'!
classFromPattern: pattern withCaption: aCaption
	"If there is a class whose name exactly given by pattern, return it.
	If there is only one class in the system whose name matches pattern, return it.
	Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen.
	This method ignores tab, space, & cr characters in the pattern"

	| toMatch potentialClassNames classNames exactMatch index |
	(toMatch _  pattern copyWithoutAll:
			{Character space.  Character cr.  Character tab})
		isEmpty ifTrue: [^ nil].
	Symbol hasInterned: toMatch ifTrue:
		[:patternSymbol | Smalltalk at: patternSymbol ifPresent:
			[:maybeClass | (maybeClass isKindOf: Class) ifTrue: [^ maybeClass]]].

	toMatch _ (toMatch copyWithout: $.) asLowercase.
	potentialClassNames _ (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection.
	classNames _ pattern last = $. 
		ifTrue: [potentialClassNames select:
					[:nm |  nm asLowercase = toMatch]]
		ifFalse: [potentialClassNames select: 
					[:n | n includesSubstring: toMatch caseSensitive: false]].
	classNames isEmpty ifTrue: [^ nil].
	exactMatch _ classNames detect: [:each | each asLowercase = toMatch] ifNone: [nil].

	index _ classNames size = 1
		ifTrue:	[1]
		ifFalse:	[exactMatch
			ifNil: [UIManager default chooseFrom: classNames lines: #() title: aCaption]
			ifNotNil: [classNames addFirst: exactMatch.
				UIManager default chooseFrom: classNames lines: #(1) title: aCaption]].
	index = 0 ifTrue: [^ nil].
	^ Smalltalk at: (classNames at: index) asSymbol

"
	self classFromPattern: 'CharRecog' withCaption: ''
	self classFromPattern: 'rRecog' withCaption: ''
	self classFromPattern: 'znak' withCaption: ''
	self classFromPattern: 'orph' withCaption: ''
	self classFromPattern: 'TCompil' withCaption: ''
"
! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 10/6/1998 14:09'!
graphicsFileSuffixes
	"Answer a list of filename suffixes which signal file content which we are able to internalize"

	^#('.gif' '.bmp' '.jpg' '.jpeg' '.jpe', '.form')! !


!Utilities class methodsFor: 'support windows' stamp: 'dgd 9/21/2003 15:12'!
commandKeyMappings
	^ (self class firstCommentAt: #commandKeyMappings) translated

"Lower-case command keys
(use with Cmd key on Mac and Alt key on other platforms)
a	Select all
b	Browse it (selection is a class name or cursor is over a class-list or message-list)
c	Copy selection
d	Do it (selection is a valid expression)
e	Exchange selection with prior selection
f	Find
g	Find again
h	Set selection as search string for find again
i	Inspect it (selection is a valid expression, or selection is over an inspect-ilst)
j	Again once (do the last text-related operation again)
k	Set font
l	Cancel
m	Implementors of it (selection is a message selector or cursor is over a class-list or message-list)
n	Senders of it (selection is a message selector or cursor is over a class-list or message-list)
o	Spawn current method
p	Print it (selection is a valid expression)
q	Query symbol (toggle all possible completion for a given prefix)
r	Recognizer
s	Save (i.e. accept)
t	Finds a Transcript (when cursor is over the desktop)
u	Toggle alignment
v	Paste
w	Delete preceding word (over text);  Close-window (over morphic desktop)
x	Cut selection
y	Swap characters
z	Undo

Note: for Do it, Senders of it, etc., a null selection will be expanded to a word or to the current line in an attempt to do what you want.  Also note that Senders/Implementors of it will find the outermost keyword selector in a large selection, as when you have selected a bracketed expression or an entire line.  Finally note that the same cmd-m and cmd-n (and cmd-v for versions) work in the message pane of most browsers.

Upper-case command keys
	(use with Shift-Cmd, or Ctrl on Mac
	or Shift-Alt on other platforms; sometimes Ctrl works too)
A	Advance argument
B	Browse it in this same browser (in System browsers only)
C	Compare argument to clipboard
D	Duplicate
E	Method strings containing it
F	Insert 'ifFalse:'
G	fileIn from it (a file name)
H	cursor TopHome:
I	Inspect via Object Explorer
J	Again many (apply the previous text command repeatedly until the end of the text)
K	Set style
L	Outdent (move selection one tab-stop left)
M	Select current type-in
N	References to it (selection is a class name, or cursor is over a class-list or message-list)
O	Open single-message browser (in message lists)
P	Make project link
R	Indent (move selection one tab-stap right)
S	Search
T	Insert 'ifTrue:'
U	Convert linefeeds to carriage returns in selection
V	Paste author's initials
W	Selectors containing it (in text); show-world-menu (when issued with cursor over desktop)
X	Force selection to lowercase
Y	Force selection to uppercase
Z	Capitalize all words in selection

Other special keys
Backspace	Backward delete character
Del			Forward delete character
Shift-Bksp	Backward delete word
Shift-Del	Forward delete word
Esc			Pop up the Desktop Menu
\			Send top window to back

Cursor keys
left, right,
up, down	Move cursor left, right, up or down
Ctrl-left		Move cursor left one word
Ctrl-right	Move cursor right one word
Home		Move cursor to begin of line or begin of text
End			Move cursor to end of line or end of text
PgUp, Ctrl-up	Move cursor up one page
PgDown, Ctrl-Dn	Move cursor down one page

Note all these keys can be used together with Shift to define or enlarge the selection. You cannot however shrink that selection again, as in some other systems.

Other Cmd-key combinations (not available on all platforms)
Return		Insert return followed by as many tabs as the previous line
			(with a further adjustment for additional brackets in that line)
Space		Select the current word as with double clicking

Enclose the selection in a kind of bracket.  Each is a toggle.
	(not available on all platforms)
Ctrl-(	Enclose within ( and ), or remove enclosing ( and )
Ctrl-[	Enclose within [ and ], or remove enclosing [ and ]
Crtl-{	Enclose within { and }, or remove enclosing { and }
Ctrl-<	Enclose within < and >, or remove enclosing < and >
Ctrl-'	Enclose within ' and ', or remove enclosing ' and '
Ctrl-""	Enclose within "" and "", or remove enclosing "" and ""
Note also that you can double-click just inside any of the above delimiters,
or at the beginning or end of a line, to select the text enclosed.

Text Emphasis
	(not available on all platforms)
Cmd-1	10 point font
Cmd-2	12 point font
Cmd-3	18 point font
Cmd-4	24 point font
Cmd-5	36 point font
Cmd-6	color, action-on-click, link to class comment, link to method, url
		Brings up a menu.  To remove these properties, select
		more than the active part and then use command-0.
Cmd-7	bold
Cmd-8	italic
Cmd-9	narrow (same as negative kern)
Cmd-0	plain text (resets all emphasis)
Cmd--	underlined (toggles it)
Cmd-=	struck out (toggles it)

Shift-Cmd--	(aka _) negative kern (letters 1 pixel closer)
Shift-Cmd-+	positive kern (letters 1 pixel larger spread)
"! !

!Utilities class methodsFor: 'support windows' stamp: 'dgd 9/21/2003 15:12'!
openCommandKeyHelp
	"Open a window giving command key help."
	"Utilities openCommandKeyHelp"

	(StringHolder new contents: self commandKeyMappings)
		openLabel: 'Command Key Actions' translated
! !

!Utilities class methodsFor: 'support windows' stamp: 'di 9/23/1998 02:02'!
openStandardWorkspace 
	"Open up a throwaway workspace with useful expressions in it.  1/22/96 sw"
	"Utilities openStandardWorkspace"

	(StringHolder new contents: self standardWorkspaceContents)
		openLabel: 'Useful Expressions ', Date today printString! !

!Utilities class methodsFor: 'support windows' stamp: 'st 11/16/2004 22:10'!
standardWorkspaceContents
	^ self class firstCommentAt: #standardWorkspaceContents

	"Smalltalk recover: 10000.
ChangeList browseRecentLog.
ChangeList browseRecent: 2000.

Preferences editAnnotations.
Flaps reinstateDefaultFlaps. 
Preferences resetCategoryInfo

(FileStream oldFileNamed: 'Lives of the Wolves') edit.
(FileStream oldFileNamed: 'tuesdayFixes.cs') fileIn
ChangeList browseFile: 'myChanges.st'

TextStyle default fontAt: 7 put: (StrikeFont new readMacFontHex: 'Cairo 18')

StandardSystemView browseAllAccessesTo: 'maximumSize'.
StandardSystemView doCacheBits  ""restore fast windows mode in mvc""

Symbol selectorsContaining: 'rsCon'.
Smalltalk browseMethodsWhoseNamesContain: 'screen'.

Browser newOnClass: Utilities.
Browser fullOnClass: SystemDictionary.

FormView allInstances inspect.
StandardSystemView someInstance inspect.

Utilities storeTextWindowContentsToFileNamed: 'TextWindows'
Utilities reconstructTextWindowsFromFileNamed: 'TextWindows'

ScriptingSystem resetStandardPartsBin.
ScheduledControllers screenController openMorphicConstructionWorld.
ScheduledControllers screenController openMorphicWorld.

SystemOrganization categoryOfElement: #Controller. 
ParagraphEditor organization categoryOfElement: #changeEmphasis.

Cursor wait showWhile: [Sensor waitButton].

Smalltalk bytesLeft asStringWithCommas.
Symbol instanceCount. 
Time millisecondsToRun:
	[Smalltalk allCallsOn: #asOop]
MessageTally spyOn: [Smalltalk allCallsOn: #asOop].

"

"Utilities openStandardWorkspace"! !


!Utilities class methodsFor: 'user interface' stamp: 'sma 4/30/2000 10:17'!
informUser: aString during: aBlock
	"Display a message above (or below if insufficient room) the cursor during execution of the given block."
	"Utilities informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait]"

	Smalltalk isMorphic
		ifTrue:
			[(MVCMenuMorph from: (SelectionMenu labels: '') title: aString)
				displayAt: Sensor cursorPoint during: [aBlock value].
			^ self].

	(SelectionMenu labels: '')
		displayAt: Sensor cursorPoint
		withCaption: aString
		during: [aBlock value]! !

!Utilities class methodsFor: 'user interface' stamp: 'sma 4/30/2000 10:18'!
informUserDuring: aBlock
	"Display a message above (or below if insufficient room) the cursor during execution of the given block."
	"Utilities informUserDuring:[:bar|
		#(one two three) do:[:info|
			bar value: info.
			(Delay forSeconds: 1) wait]]"
	Smalltalk isMorphic
		ifTrue:
			[(MVCMenuMorph from: (SelectionMenu labels: '') title: '						')
				informUserAt: Sensor cursorPoint during: aBlock.
			^ self].
	aBlock value:[:string| Transcript cr; show: string]! !


!Utilities class methodsFor: '*39Deprecated' stamp: 'sd 3/30/2005 21:53'!
browseVersionsForClass: aClass selector: aSelector
	self deprecated: 'Use VersionsBrowser browseVersionsForClass: aClass selector: aSelector instead'.
	VersionsBrowser browseVersionsForClass: aClass selector: aSelector! !

!Utilities class methodsFor: '*39Deprecated' stamp: 'ar 9/27/2005 20:15'!
fileOutChangeSetsNamed: nameList
	"File out the list of change sets whose names are provided"
     self deprecated: 'Use ChangeSet fileOutChangeSetsNamed: nameList'.
	ChangeSet fileOutChangeSetsNamed: nameList! !


!Utilities class methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
addSampleWindowsTo: aPage
	"Add windows representing a browser, a workspace, etc., to aPage"
	|  aWindow pu |
	aWindow := Browser new openAsMorphEditing: nil.
	aWindow setLabel: 'System Browser'.
	aPage addMorphBack: aWindow applyModelExtent.
	aWindow := PackagePaneBrowser new openAsMorphEditing: nil.
	aWindow setLabel: 'Package Browser'.
	aPage addMorphBack: aWindow applyModelExtent.
	aWindow := Workspace new embeddedInMorphicWindowLabeled: 'Workspace'.
	aPage addMorphBack: aWindow applyModelExtent.
	aPage addMorphBack: FileList openAsMorph applyModelExtent.

	aPage addMorphBack: DualChangeSorter new morphicWindow applyModelExtent.
	aPage addMorphBack: ChangeSorter new morphicWindow applyModelExtent.

	aWindow := SelectorBrowser new morphicWindow.
	aWindow setLabel: 'Selector Browser'.
	aPage addMorphBack: aWindow.
	aPage addMorphBack: ((pu := PasteUpMorph newSticky borderInset) embeddedInMorphicWindowLabeled: 'assembly').
	pu color: (Color r: 0.839 g: 1.0 b: 0.935)! !

!Utilities class methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
browseRecentSubmissions
	"Open up a browser on the most recent methods submitted in the image.  5/96 sw."

	"Utilities browseRecentSubmissions"

	| recentMessages |

	self recentMethodSubmissions size == 0 ifTrue:
		[^ self inform: 'There are no recent submissions'].
	
	recentMessages := RecentSubmissions copy reversed.
	RecentMessageSet 
		openMessageList: recentMessages 
		name: 'Recent submissions -- youngest first ' 
		autoSelect: nil! !

!Utilities class methodsFor: '*Tools' stamp: 'sw 10/15/1998 15:14'!
closeAllDebuggers
	"Utilities closeAllDebuggers"
	Smalltalk isMorphic
	ifTrue:
		[(SystemWindow allSubInstances select: [:w | w model isKindOf: Debugger])
			do: [:w | w delete]]
	ifFalse:
		[(StandardSystemController allInstances select: [:w | w model isKindOf: Debugger])
			do: [:w | w closeAndUnscheduleNoTerminate]]! !

!Utilities class methodsFor: '*Tools' stamp: 'sw 7/4/2001 12:07'!
openRecentSubmissionsBrowser
	"Open up a browser on the most recent methods submitted in the image; reuse any existing one found in the world."

	self currentWorld openRecentSubmissionsBrowser: nil! !

!Utilities class methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'!
recentSubmissionsWindow
	"Answer a SystemWindow holding recent submissions"

	| recentMessages messageSet |
	recentMessages := RecentSubmissions copy reversed.
	messageSet := RecentMessageSet messageList: recentMessages.
	messageSet autoSelectString: nil.
	^ (messageSet inMorphicWindowLabeled: 'Recent submissions -- youngest first') applyModelExtent

	"Utilities recentSubmissionsWindow openInHand"

! !
Object subclass: #UtteranceVisitor
	instanceVariableNames: 'clause phrase word syllable'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!UtteranceVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:23'!
clause: aClause
	clause := aClause.
	clause phrases do: [ :each | each accept: self].
	phrase := word := syllable := nil! !

!UtteranceVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:23'!
phrase: aPhrase
	phrase := aPhrase.
	phrase words do: [ :each | each accept: self].
	word := syllable := nil! !

!UtteranceVisitor methodsFor: 'visiting' stamp: 'len 12/10/1999 02:46'!
speaker: aSpeaker
	^ self! !

!UtteranceVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:23'!
syllable: aSyllable
	syllable := aSyllable! !

!UtteranceVisitor methodsFor: 'visiting' stamp: 'stephaneducasse 2/3/2006 22:23'!
word: aWord
	word := aWord.
	word syllables do: [ :each | each accept: self].
	syllable := nil! !
Model subclass: #ValueHolder
	instanceVariableNames: 'contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Kernel-Remnants'!

!ValueHolder methodsFor: 'as yet unclassified' stamp: 'ls 8/5/1998 07:49'!
contents
	^contents! !

!ValueHolder methodsFor: 'as yet unclassified' stamp: 'sw 1/28/1999 12:35'!
contents: newContents
	contents _ newContents.
	self contentsChanged! !
ObjectWithDocumentation subclass: #Variable
	instanceVariableNames: 'defaultValue floatPrecision variableName variableType'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Kernel'!

!Variable methodsFor: 'name' stamp: 'stephaneducasse 2/4/2006 20:39'!
name: aName type: aType
	"Set the variable's name and type as indicated"

	variableName := aName.
	variableType := aType! !

!Variable methodsFor: 'name' stamp: 'sw 9/30/2004 05:02'!
printOn: aStream
	"Print the receiver on the stream"

	super printOn: aStream.
	aStream nextPutAll: ' named ', (self variableName ifNil: ['<unnamed>']), ' type = ', variableType printString, ' default val = ', defaultValue printString! !

!Variable methodsFor: 'name' stamp: 'sw 12/11/2000 14:07'!
variableName
	"Answer the variable name of the receiver"

	^ variableName! !


!Variable methodsFor: 'type' stamp: 'sw 12/11/2000 14:06'!
variableType
	"Anser the variable type of the receiver"

	^ variableType! !

!Variable methodsFor: 'type' stamp: 'stephaneducasse 2/4/2006 20:39'!
variableType: aType
	"Set the receiver's variable type as requested"

	variableType := aType! !


!Variable methodsFor: 'value' stamp: 'sw 12/11/2000 14:06'!
defaultValue
	"Answer the default value to be supplied to the receiver"

	^ defaultValue! !

!Variable methodsFor: 'value' stamp: 'stephaneducasse 2/4/2006 20:39'!
sample
	"The closest we can come to an object for our type"

	| ty clsName |
	self defaultValue ifNotNil: [^ self defaultValue].
	ty := self variableType.
	"How translate a type like #player into a class?"
	clsName := ty asString.
	clsName at: 1 put: (clsName first asUppercase).
	clsName := clsName asSymbol.
	(Smalltalk includesKey: clsName) ifFalse: [self error: 'What type is this?'. ^ 5].
	^ (Smalltalk at: clsName) initializedInstance! !
Object subclass: #VariableDock
	instanceVariableNames: 'variableName type definingMorph morphGetSelector morphPutSelector playerGetSelector playerPutSelector defaultValue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Stacks'!
!VariableDock commentStamp: '<historical>' prior: 0!
Represents a variable held in a Player on behalf of a Morph.  When a new Player gets installed in the Morph, variables representing the old player need to be committed to the old player's storage, if not already done, and then new values for the variables need to be obtained from the new Player.  The VariableDock does the actual data transfer.

variableName 		A Symbol.  The name by which this variable known in the bearer,  a Card
type 				An object representing the variable's type.  Initially, we, like the rest
						use a Symbol to represent this.
						Presently #string #number #boolean #object #reference #sound etc.
definingMorph		The morph that requested storage of this variable
morphGetSelector	The message to be sent to the morph to obtain the variable's value
morphPutSelector	The message to be sent to the morph to put a new var value into it
owningClass			The Uniclass of which this is an instance variable
playerGetSelector 	The message to be sent to the Player to obtain its current stored value
playerPutSelector 	The message to be sent to the Player to set a new stored value
defaultValue		The value to set for the variable by default
floatPrecision		e.g. 0, 0.1, 0.001.  Only relevant for numeric-type variables
!


!VariableDock methodsFor: 'accessing' stamp: 'sw 11/2/2002 18:09'!
definingMorph
	"Answer the defining morph"

	^ definingMorph! !

!VariableDock methodsFor: 'accessing' stamp: 'tk 5/25/2001 17:43'!
playerGetSelector
	^playerGetSelector! !

!VariableDock methodsFor: 'accessing' stamp: 'tk 5/25/2001 17:43'!
type
	^type! !


!VariableDock methodsFor: 'getters and setters' stamp: 'sw 10/30/2000 10:55'!
computePlayerGetterAndSetterSelectors
	"Compute and remember the getter and setter selectors for obtaining and setting values from the player instance"

	playerGetSelector _ Utilities getterSelectorFor: variableName.
	playerPutSelector _ Utilities setterSelectorFor: variableName! !


!VariableDock methodsFor: 'initialization' stamp: 'sw 10/26/2000 13:33'!
dockMorphUpToInstance: anInstance
	"Dock my defining morph up to the given player instance.  NB: The odious #cardInstance mechanism used here was a last-minute stopgap for some demo, which surely should not be allowed to survive."

	definingMorph setProperty: #cardInstance toValue: anInstance.
	definingMorph perform: morphPutSelector with: (anInstance perform: playerGetSelector)! !

!VariableDock methodsFor: 'initialization' stamp: 'tk 5/30/2001 12:10'!
storeMorphDataInInstance: anInstance
	"Store the morph instance data represented by the receiver into the card instance provided.  This is done by retrieving the datum value from the morph that holds it on the card, and putting it into the card instance"

	anInstance perform: playerPutSelector with: (definingMorph perform: morphGetSelector) copy! !

!VariableDock methodsFor: 'initialization' stamp: 'sw 10/30/2000 08:52'!
variableName: aSymbol type: aType definingMorph: aMorph morphGetSelector: getterSymbol morphPutSelector: putterSymbol
	"Initialize the receiver as indicated"

	variableName _ aSymbol asSymbol.
	type _ aType.
	definingMorph _ aMorph.
	morphGetSelector _ getterSymbol.
	morphPutSelector _ putterSymbol.
	self computePlayerGetterAndSetterSelectors! !


!VariableDock methodsFor: 'name' stamp: 'sw 10/30/2000 08:52'!
variableName
	"Answer the variable name represented by the receiver"

	^ variableName! !

!VariableDock methodsFor: 'name' stamp: 'sw 10/30/2000 08:51'!
variableName: aSymbol
	"Set the receiver's variableName as indicated, and recompute corresponding getters and setters"

	variableName _ aSymbol asSymbol.
	self computePlayerGetterAndSetterSelectors! !


!VariableDock methodsFor: 'printing' stamp: 'sw 10/30/2000 08:50'!
printOn: aStream
	"Print a description of the receiver onto the given stream"

	super printOn: aStream.
	variableName ifNotNil: [aStream nextPutAll: (' (var name = ', variableName, ')')].
	type ifNotNil: [aStream nextPutAll: (' (type = ', type, ')')]! !


!VariableDock methodsFor: 'type and default value' stamp: 'sw 10/29/2000 17:40'!
variableType
	"Answer the data type of the receiver"

	^ type! !
LeafNode subclass: #VariableNode
	instanceVariableNames: 'name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!VariableNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a variable. Note that my name and key are different for pool variables: the key is the Object Reference.!


!VariableNode methodsFor: 'accessing' stamp: 'tk 1/30/2001 13:45'!
name
	^ name! !


!VariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:37'!
emitForReturn: stack on: strm

	(self code >= LdSelf and: [self code <= LdNil])
		ifTrue: 
			["short returns"
			strm nextPut: EndMethod - 4 + (self code - LdSelf).
			stack push: 1 "doesnt seem right"]
		ifFalse: 
			[super emitForReturn: stack on: strm]! !

!VariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:37'!
emitForValue: stack on: strm

	self code < 256
		ifTrue: 
			[strm nextPut: (self code = LdSuper ifTrue: [LdSelf] ifFalse: [self code]).
			stack push: 1]
		ifFalse: 
			[self emitLong: LoadLong on: strm.
			stack push: 1]! !

!VariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2001 23:14'!
emitLoad: stack on: strm
	"Do nothing"! !

!VariableNode methodsFor: 'code generation'!
emitStore: stack on: strm

	self emitLong: Store on: strm! !

!VariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:37'!
emitStorePop: stack on: strm
	(self code between: 0 and: 7)
		ifTrue: 
			[strm nextPut: ShortStoP + self code "short stopop inst"]
		ifFalse:
			[(self code between: 16 and: 23)
				ifTrue: [strm nextPut: ShortStoP + 8 + self code - 16 "short stopop temp"]
				ifFalse: [(self code >= 256 and: [self code \\ 256 > 63 and: [self code // 256 = 4]])
						ifTrue: [self emitLong: Store on: strm. strm nextPut: Pop]
						ifFalse: [self emitLong: StorePop on: strm]]].
	stack pop: 1! !

!VariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:36'!
fieldOffset  "Return temp or instVar offset for this variable"

	self code < 256
		ifTrue: 
			[^ self code \\ 16]
		ifFalse: 
			[^ self code \\ 256]! !

!VariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:36'!
sizeForReturn: encoder

	(self code >= LdSelf and: [self code <= LdNil])
		ifTrue: ["short returns" ^1].
	^super sizeForReturn: encoder! !

!VariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:38'!
sizeForStore: encoder
	self reserve: encoder.
	self code < 256 ifTrue: [^ 2].
	(self code \\ 256) <= 63 ifTrue: [^ 2].
	^ 3! !

!VariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:43'!
sizeForStorePop: encoder
	self reserve: encoder.
	(self code < 24 and: [self code noMask: 8]) ifTrue: [^ 1].
	self code < 256 ifTrue: [^ 2].
	self code \\ 256 <= 63 ifTrue: [^ 2].  "extended StorePop"
	self code // 256 = 1 ifTrue: [^ 3].  "dbl extended StorePopInst"
	self code // 256 = 4 ifTrue: [^ 4].  "dbl extended StoreLitVar , Pop"
	self halt.  "Shouldn't get here"! !


!VariableNode methodsFor: 'initialize-release'!
asStorableNode: encoder
	^ self! !

!VariableNode methodsFor: 'initialize-release' stamp: 'tk 9/28/2001 11:33'!
name: string
	"Change name"

	name _ string.
! !

!VariableNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:54'!
name: varName index: i type: type
	"Only used for initting instVar refs"
	self name: varName.
	self key: varName
		index: i
		type: type! !

!VariableNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:53'!
name: string key: object code: byte
	"Only used for initting std variables, nil, true, false, self, etc."
	self name: string.
	self key: object.
	self code: byte! !

!VariableNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:53'!
name: varName key: objRef index: i type: type
	"Only used for initting global (litInd) variables"
	self name: varName.
	self key: objRef
		index: i
		type: type! !


!VariableNode methodsFor: 'printing' stamp: 'ab 7/13/2004 13:54'!
printOn: aStream indent: level 
	aStream withStyleFor: #variable
		do: [aStream nextPutAll: self name].
! !


!VariableNode methodsFor: 'testing' stamp: 'ab 7/13/2004 13:53'!
assignmentCheck: encoder at: location

	(encoder cantStoreInto: self name)
		ifTrue: [^ location]
		ifFalse: [^ -1]
! !

!VariableNode methodsFor: 'testing' stamp: 'ab 7/6/2004 17:37'!
canBeSpecialArgument
	"Can I be an argument of (e.g.) ifTrue:?"

	^ self code < LdNil! !

!VariableNode methodsFor: 'testing' stamp: 'ab 7/6/2004 17:36'!
index
	"This code attempts to reconstruct the index from its encoding in code."
	self code < 0 ifTrue:[^ nil].
	self code > 256 ifTrue:[^ self code \\ 256].
	^self code - self type! !

!VariableNode methodsFor: 'testing' stamp: 'ab 7/13/2004 13:53'!
isSelfPseudoVariable
	"Answer if this ParseNode represents the 'self' pseudo-variable."

	^ (self key = 'self') | (self name = '{{self}}')! !

!VariableNode methodsFor: 'testing'!
isVariableReference

	^true! !

!VariableNode methodsFor: 'testing' stamp: 'ab 7/6/2004 17:37'!
type
	"This code attempts to reconstruct the type from its encoding in code.
		This allows one to test, for instance, (aNode type = LdInstType)."
	| type |
	self code < 0 ifTrue: [^ self code negated].
	self code < 256 ifFalse: [^ self code // 256].
	type _ CodeBases findFirst: [:one | self code < one].
	type = 0
		ifTrue: [^ 5]
		ifFalse: [^ type - 1]! !


!VariableNode methodsFor: '*eToys-tiles' stamp: 'ab 7/13/2004 13:54'!
asMorphicSyntaxIn: parent

	^ parent addToken: self name
			type: #variable 
			on: self clone	"don't hand out the prototype!! See VariableNode>>initialize"
! !

!VariableNode methodsFor: '*eToys-tiles' stamp: 'RAA 8/24/1999 16:34'!
currentValueIn: aContext

	aContext ifNil: [^nil].
	^((self variableGetterBlockIn: aContext) ifNil: [^nil]) value printString
	

! !

!VariableNode methodsFor: '*eToys-tiles' stamp: 'ab 7/13/2004 13:53'!
explanation

	self isSelfPseudoVariable ifTrue: [^'the pseudo variable <self> (refers to the receiver)'].
	^(#('instance' 'temporary' 'LIT3' 'global') 
			at: self type 
			ifAbsent: ['UNK',self type printString]),' variable <',self name,'>'
		

	"LdInstType _ 1.
	LdTempType _ 2.
	LdLitType _ 3.
	LdLitIndType _ 4.
"

! !

!VariableNode methodsFor: '*eToys-tiles' stamp: 'ab 7/13/2004 13:54'!
variableGetterBlockIn: aContext

	| temps index ivars |

	(self type = 4 and: [self key isVariableBinding]) ifTrue: [
		^[self key value]
	].
	aContext ifNil: [^nil].
	self isSelfPseudoVariable ifTrue: [^[aContext receiver]].
	self type = 1 ifTrue: [
		ivars _ aContext receiver class allInstVarNames.
		index _ ivars indexOf: self name ifAbsent: [^nil].
		^[aContext receiver instVarAt: index]
	].
	self type = 2 ifTrue: [
		temps _ aContext tempNames.
		index _ temps indexOf: self name ifAbsent: [^nil].
		^[aContext tempAt: index]
	].
	^nil
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VariableNode class
	instanceVariableNames: ''!

!VariableNode class methodsFor: 'class initialization'!
initialize    "VariableNode initialize.  Decompiler initialize"
	| encoder |
	encoder _ Encoder new.
	StdVariables _ Dictionary new: 16.
	encoder
		fillDict: StdVariables
		with: VariableNode
		mapping: #('self' 'thisContext' 'super' 'nil' 'false' 'true' )
		to: (Array with: LdSelf with: LdThisContext with: LdSuper)
				, (Array with: LdNil with: LdFalse with: LdTrue).
	StdSelectors _ Dictionary new: 64.
	encoder
		fillDict: StdSelectors
		with: SelectorNode
		mapping: ((1 to: Smalltalk specialSelectorSize) collect: 
							[:i | Smalltalk specialSelectorAt: i])
		to: (SendPlus to: SendPlus + 31).
	StdLiterals _ LiteralDictionary new: 16.
	encoder
		fillDict: StdLiterals
		with: LiteralNode
		mapping: #(-1 0 1 2 )
		to: (LdMinus1 to: LdMinus1 + 3).
	encoder initScopeAndLiteralTables.

	NodeNil _ encoder encodeVariable: 'nil'.
	NodeTrue _ encoder encodeVariable: 'true'.
	NodeFalse _ encoder encodeVariable: 'false'.
	NodeSelf _ encoder encodeVariable: 'self'.
	NodeThisContext _ encoder encodeVariable: 'thisContext'.
	NodeSuper _ encoder encodeVariable: 'super'! !
Object subclass: #VersionHistory
	instanceVariableNames: 'versions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VersionNumber'!
!VersionHistory commentStamp: '<historical>' prior: 0!
I am a version history.  A version history is a collection of VersionNumbers that together form a tree of versions.  I enforce rules about how versions are added and removed from the history.

To add a new version to a VersionHistory based on an existing version:

  VersionHistory startingAt1 addNewVersionBasedOn: '1' asVersion; yourself

If you add 2 new versions based on the same version, a branch will be started:

  VersionHistory startingAt1 
		addNewVersionBasedOn: '1' asVersion;
		addNewVersionBasedOn: '1' asVersion; 
		yourself

To remove a single version (note: only versions at the tip of a branch, or at the base of the trunk (if it has only one successor) can be individually removed):

  VersionHistory startingAt1 
		addNewVersionBasedOn: '1' asVersion;
		addNewVersionBasedOn: '1' asVersion; 
		remove: '1.1' asVersion;
		yourself

To remove an entire branch:

  VersionHistory startingAt1 
		addNewVersionBasedOn: '1' asVersion;
		addNewVersionBasedOn: '1' asVersion; 
		addNewVersionBasedOn: '1.1' asVersion; 
		addNewVersionBasedOn: '1.2' asVersion; 
		removeBranch: '1.1' asVersion;
		yourself

To remove a portion of the trunk:

  VersionHistory startingAt1 
		addNewVersionBasedOn: '1' asVersion;
		addNewVersionBasedOn: '2' asVersion; 
		addNewVersionBasedOn: '3' asVersion; 
		addNewVersionBasedOn: '3' asVersion; 
		removeTrunk: '2' asVersion;
		yourself

To get a string description of a version history:

  VersionHistory startingAt1 
		addNewVersionBasedOn: '1' asVersion;
		addNewVersionBasedOn: '2' asVersion; 
		addNewVersionBasedOn: '3' asVersion; 
		addNewVersionBasedOn: '3' asVersion; 
		treeString

Also, the following methods are useful for accessing the versions:

	#firstVersion
	#versionBefore:
	#versionsAfter:
	#mainLineStartingAt:
	#allVersionsAfter:
	#allVersionsBefore:
!


!VersionHistory methodsFor: 'accessing' stamp: 'svp 6/26/2002 16:32'!
allVersionsAfter: aVersion
	"Answer all the versions based on aVersion."

	| answer |
	answer := Set new.
	versions do: [ :ea |
		((ea inSameBranchAs: aVersion) and: 
			[ea > aVersion]) ifTrue: [answer add: ea]].
	^answer! !

!VersionHistory methodsFor: 'accessing' stamp: 'svp 6/26/2002 16:32'!
allVersionsBefore: aVersion
	"Answer all versions that came before aVersion"

	| answer |
	answer := Set new.
	versions do: [ :ea |
		((ea inSameBranchAs: aVersion) and: 
			[ea < aVersion]) ifTrue: [answer add: ea]].
	^answer! !

!VersionHistory methodsFor: 'accessing' stamp: 'svp 6/26/2002 16:32'!
firstVersion
	"Answer the first version in the entire version history"

	^versions inject: versions anyOne into: [ :x :ea |
		(x inSameBranchAs: ea)
			ifTrue: [(x < ea) ifTrue: [x] ifFalse: [ea]]
			ifFalse: [ea]]! !

!VersionHistory methodsFor: 'accessing' stamp: 'svp 6/26/2002 16:35'!
mainLineStartingAt: aVersion
	"Answer all versions based on aVersion that are not branches (they have 
	the same number of digits with the same values, except the last value is
	greater than the last value of aVersion)."

	| answer tmp |
	answer := OrderedCollection new.
	tmp := aVersion.
	[versions includes: tmp] 
		whileTrue: 
			[answer add: tmp.
			tmp := tmp next].
	^answer
! !

!VersionHistory methodsFor: 'accessing' stamp: 'svp 6/26/2002 16:37'!
versionBefore: aVersion

	"Answer the version immediately preceeding aVersion."

	| tmp |
	(aVersion > '1' asVersion) ifFalse: [^nil].
	(versions includes: (tmp := aVersion previous)) ifFalse: [^nil].
	^tmp! !

!VersionHistory methodsFor: 'accessing' stamp: 'svp 6/26/2002 16:37'!
versionsAfter: aVersion
	"Answer all the versions immediately following aVersion."

	| answer tmp |
	answer := Set new.
	tmp := aVersion next.
	(versions includes: aVersion next) ifTrue: [answer add: tmp].

	tmp := aVersion.
	[versions includes: (tmp := tmp branchNext)] whileTrue:
		[answer add: tmp].
	^answer! !


!VersionHistory methodsFor: 'adding' stamp: 'svp 6/18/2002 17:17'!
addNewVersionBasedOn: aVersion

	| tmp |
	(versions includes: aVersion) ifFalse: [^self error: 'Version is not in this history'].

	tmp := aVersion next.
	(versions includes: tmp) ifFalse: 
		[versions add: tmp.
		^tmp].

	tmp := aVersion.
	[versions includes: (tmp := tmp branchNext)] whileTrue.
	versions add: tmp.
	^tmp
	! !


!VersionHistory methodsFor: 'initialization' stamp: 'svp 6/18/2002 17:15'!
initializeVersionsAt: aVersion

	versions := Set new.
	versions add: aVersion.! !


!VersionHistory methodsFor: 'printing' stamp: 'svp 6/26/2002 16:30'!
treeString
	"Answer a string that show the entire version history with
	each branch starting on a new line"

	^self treeStringStartingAt: self firstVersion! !

!VersionHistory methodsFor: 'printing' stamp: 'svp 6/26/2002 16:26'!
treeStringOn: strm startingAt: aVersion

	| tmp |
	tmp := self mainLineStartingAt: aVersion.
	tmp do: [ :ea | ea versionStringOn: strm. strm space; space ].
	strm cr.
	tmp do: 
		[ :ea | 
		(versions includes: ea branchNext)
			ifTrue: [self treeStringOn: strm startingAt: ea branchNext]].! !

!VersionHistory methodsFor: 'printing' stamp: 'svp 6/26/2002 11:34'!
treeStringStartingAt: aVersion

	| strm |
	strm := WriteStream on: ''.
	self treeStringOn: strm startingAt: aVersion.
	^strm contents! !


!VersionHistory methodsFor: 'removing' stamp: 'svp 6/26/2002 16:30'!
remove: aVersion
	"Remove aVersion from this version history."

	^self remove: aVersion ifAbsent: [self error: 'version not found'].! !

!VersionHistory methodsFor: 'removing' stamp: 'svp 6/27/2002 14:08'!
remove: aVersion ifAbsent: aBlock
	"Remove aVersion from this version history."

	(versions includes: aVersion) ifFalse: [^aBlock value].

	(self canRemove: aVersion) ifFalse:
		[^self error: 'Only versions at the beginning or end with no more than one follower may be removed'].

	versions remove: aVersion.! !

!VersionHistory methodsFor: 'removing' stamp: 'svp 6/18/2002 17:48'!
removeBranch: aVersion
	"Remove aVersion and all of it's successors, providing that
	aVersion is not the first version."

	(self versionBefore: aVersion)
		ifNil: [^self error: 'version is the first version in the history'].

	versions removeAll: (self allVersionsAfter: aVersion).
	versions remove: aVersion.! !

!VersionHistory methodsFor: 'removing' stamp: 'svp 6/18/2002 17:47'!
removeTrunk: aVersion
	"Remove aVersion and all of it's predecessors, providing there
	are no other branches stemming from the trunk.  Note, a trunk is defined
	as all versions, starting with the first version, that have only one successor."

	| tmp |
	(self versionsAfter: aVersion) size > 1 
		ifTrue: [^self error: 'version is at a fork'].

	tmp := self allVersionsBefore: aVersion.
	(tmp detect: [ :ea | (self versionsAfter: ea) size > 1 ] ifNone: [nil])
		ifNotNil: [^self error: 'not a trunk, other branches detected'].

	versions removeAll: tmp.
	versions remove: aVersion.! !


!VersionHistory methodsFor: 'testing' stamp: 'svp 6/27/2002 14:09'!
canRemove: aVersion

	| hasPriors followers |
	(versions includes: aVersion) ifFalse: [^false].
	hasPriors := (self versionBefore: aVersion) notNil.
	followers := self versionsAfter: aVersion.		

	"Don't allow versions in the middle to be extracted"
	(hasPriors and: [followers size > 0]) ifTrue: [^false].
	
	"Don't allow versions with more than one follower to be extracted"
	(hasPriors not and: [followers size > 1]) ifTrue: [^false].
	^true

! !

!VersionHistory methodsFor: 'testing' stamp: 'svp 6/18/2002 16:43'!
includesVersion: aVersion

	^versions includes: aVersion! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VersionHistory class
	instanceVariableNames: ''!

!VersionHistory class methodsFor: 'as yet unclassified' stamp: 'svp 6/26/2002 16:20'!
startingAt1

	^self startingAt: '1' asVersion! !

!VersionHistory class methodsFor: 'as yet unclassified' stamp: 'svp 6/18/2002 17:14'!
startingAt: aVersion

	^self new
		initializeVersionsAt: aVersion;
		yourself! !
Magnitude subclass: #VersionNumber
	instanceVariableNames: 'numbers'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VersionNumber'!
!VersionNumber commentStamp: '<historical>' prior: 0!
I am a version number.  My representation allows me to handle an entire tree of versions.  Once created, an instance should not change (note: VersionNumbers could be canonicalized like Symbols, but are not currently).  

I am a magnitude so that you can see if one version preceeds another (only if the two versions are in the same branch).  

	'2.1' asVersion < '2.2.1' asVersion	"true"
	'2.3' asVersion < '2.2.1' asVersion	"error different branches"
	'2.3' asVersion inSameBranchAs: '2.2.1' asVersion	"false, why the previous one failed."	
	'2.1' asVersion = '2.1' asVersion		"true, obviously"

To get the next version number in the same branch:

	'2.3.4' asVersion next	"2.3.5"

To get the next version number, starting a new branch:

	'2.3.4' asVersion branchNext		"2.3.4.1"

To get the common base version of any two version numbers (useful for merging):

	'2.3.8' asVersion commonBase: '2.3.4.1' asVersion		"2.3.4"!


!VersionNumber methodsFor: 'accessing' stamp: 'svp 6/18/2002 12:22'!
branchNext

	^self class fromCollection: (numbers, (Array with: 1))! !

!VersionNumber methodsFor: 'accessing' stamp: 'svp 6/18/2002 14:50'!
commonBase: aVersion

	| smallNums largeNums cutoff |
	(aVersion numbers size <= numbers size) 
		ifTrue: [smallNums := aVersion numbers. largeNums := numbers] 
		ifFalse: [smallNums := numbers. largeNums := aVersion numbers].

	cutoff := (1 to: smallNums size) 
		detect: [ :in | ((smallNums at: in) ~= (largeNums at: in))] 
		ifNone: [^self class fromCollection: smallNums].

	^self class fromCollection: 
		((numbers copyFrom: 1 to: (cutoff - 1)), 
		(Array with: ((smallNums at: cutoff) min: (largeNums at: cutoff))))
! !

!VersionNumber methodsFor: 'accessing' stamp: 'svp 6/18/2002 12:14'!
next

	| tmp |
	tmp := numbers copy.
	tmp at: numbers size put: (numbers last + 1).
	^self class fromCollection: tmp! !

!VersionNumber methodsFor: 'accessing' stamp: 'svp 6/18/2002 14:51'!
numbers
	"Answer a copy (to discourage people from directly changing a version number).
	VersionNumbers should never change, instead, instantiate a new instance."

	^numbers copy! !

!VersionNumber methodsFor: 'accessing' stamp: 'svp 6/18/2002 16:51'!
previous

	| tmp |
	numbers last = 1 ifTrue: 
		[^self class fromCollection: (numbers allButLast)].
	tmp := numbers copy.
	tmp at: numbers size put: (numbers last - 1).
	^self class fromCollection: tmp
! !


!VersionNumber methodsFor: 'comparing' stamp: 'svp 6/18/2002 15:05'!
< another 
	"Answer whether the receiver is less than the argument."

	| tmp |
	(self inSameBranchAs: another) ifFalse: 
		[^self error: 'Receiver and argument in different branches'].

	tmp := another numbers.
	(tmp size = numbers size) ifTrue:
		[1 to: numbers size do: 
			[ :in | (numbers at: in) < (tmp at: in) ifTrue: [^true]].
		^false].

	^numbers size < tmp size
! !

!VersionNumber methodsFor: 'comparing' stamp: 'svp 6/18/2002 15:10'!
= aVersion

	^numbers = aVersion numbers! !

!VersionNumber methodsFor: 'comparing' stamp: 'svp 6/18/2002 12:23'!
hash

	^numbers hash! !


!VersionNumber methodsFor: 'initialization' stamp: 'svp 6/18/2002 15:08'!
initializeNumbers: aCollection

	aCollection do: [ :ea | 
		ea <= 0 ifTrue: 
			[^self error: 'VersionNumbers cannot contain zero or negative numbers']].

	numbers := aCollection asArray! !


!VersionNumber methodsFor: 'printing' stamp: 'svp 6/18/2002 12:27'!
printOn: strm

	self storeOn: strm! !

!VersionNumber methodsFor: 'printing' stamp: 'svp 6/18/2002 17:24'!
storeOn: strm

	strm nextPut: $'.
	self versionStringOn: strm.
	strm nextPutAll: ''' asVersion'.! !


!VersionNumber methodsFor: 'testing' stamp: 'svp 6/18/2002 14:57'!
inSameBranchAs: aVersion

	| less more |
	(aVersion numbers size <= numbers size) 
		ifTrue: [less := aVersion numbers. more := numbers] 
		ifFalse: [less := numbers. more := aVersion numbers].

	1 to: (less size - 1) do: [ :in | ((less at: in) = (more at: in)) ifFalse: [^false]].
	^less size = more size or:
		[(less at: less size) <= (more at: less size)]
! !


!VersionNumber methodsFor: '*smbase-override' stamp: 'svp 6/18/2002 17:23'!
versionStringOn: strm

	| first |
	first := true.
	numbers do: [ :ea |
		first ifFalse: [strm nextPut: $.].
		first := false.
		ea printOn: strm]
	! !


!VersionNumber methodsFor: '*smbase-printing' stamp: 'gk 1/23/2004 10:13'!
versionString

	^String streamContents: [ :strm | self versionStringOn: strm ]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VersionNumber class
	instanceVariableNames: ''!

!VersionNumber class methodsFor: 'as yet unclassified' stamp: 'svp 6/18/2002 16:34'!
first

	^self fromCollection: #(1)! !

!VersionNumber class methodsFor: 'as yet unclassified' stamp: 'svp 6/18/2002 12:21'!
fromCollection: aCollection

	^self new
		initializeNumbers: aCollection;
		yourself! !

!VersionNumber class methodsFor: 'as yet unclassified' stamp: 'svp 6/18/2002 12:20'!
fromString: aString

	^self fromCollection: 
		((aString findTokens: '.') collect: [:ea | ea asNumber ])
	! !
ChangeList subclass: #VersionsBrowser
	instanceVariableNames: 'classOfMethod selectorOfMethod addedChangeRecord'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!VersionsBrowser commentStamp: 'nk 11/25/2003 10:04' prior: 0!
VersionsBrowser shows all the versions of a particular method, and lets you compare them, revert to selected versions, and so on.!


!VersionsBrowser methodsFor: 'init & update' stamp: 'nk 1/7/2004 10:10'!
addedChangeRecord
	^addedChangeRecord! !

!VersionsBrowser methodsFor: 'init & update' stamp: 'sd 11/20/2005 21:27'!
addedChangeRecord: aChangeRecord
	addedChangeRecord := aChangeRecord.
	self reformulateList.! !

!VersionsBrowser methodsFor: 'init & update' stamp: 'sw 5/6/2000 01:16'!
changeListButtonSpecs

	^#(
		('compare to current'
		compareToCurrentVersion
		'opens a separate window which shows the text differences between the selected version and the current version')

		('revert'
		fileInSelections
		'reverts the method to the version selected')

		('remove from changes'
		removeMethodFromChanges
		'remove this method from the current change set')

		('help'
		offerVersionsHelp
		'further explanation about use of Versions browsers')
		)! !

!VersionsBrowser methodsFor: 'init & update' stamp: 'sd 11/20/2005 21:27'!
reformulateList
	| aMethod |
	"Some uncertainty about how to deal with lost methods here"
	aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ self].
	
	self scanVersionsOf: aMethod class: classOfMethod theNonMetaClass meta: classOfMethod isMeta category: (classOfMethod whichCategoryIncludesSelector: selectorOfMethod) selector: selectorOfMethod.
	self changed: #list. "for benefit of mvc"
	listIndex := 1.
	self changed: #listIndex.
	self contentsChanged
! !

!VersionsBrowser methodsFor: 'init & update' stamp: 'bf 2/13/2006 00:14'!
scanVersionsOf: method class: class meta: meta category: category selector: selector
	| position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp cat |
	selectorOfMethod _ selector.
	currentCompiledMethod _ method.
	classOfMethod _ meta ifTrue: [class class] ifFalse: [class].
	cat _ category ifNil: [''].
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	self addedChangeRecord ifNotNilDo: [ :change |
		self addItem: change text: ('{1} (in {2})' translated format: { change stamp. change fileName }) ].
	listIndex _ 0.
	position _ method filePosition.
	sourceFilesCopy _ SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	method fileIndex == 0 ifTrue: [^ nil].
	file _ sourceFilesCopy at: method fileIndex.

	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  "Skip back to before the preamble"
		preamble _ method getPreambleFrom: file at: (0 max: position - 3).

		"Preamble is likely a linked method preamble, if we're in
			a changes file (not the sources file).  Try to parse it
			for prior source position and file index"
		prevPos _ nil.
		stamp _ ''.
		(preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [tokens _ Scanner new scanTokens: preamble]
			ifFalse: [tokens _ Array new  "ie cant be back ref"].
		((tokens size between: 7 and: 8)
			and: [(tokens at: tokens size-5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-3) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size-2.
						prevPos _ tokens last.
						prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos]
				ifFalse: ["Old format gives no stamp; prior pointer in two parts"
						prevPos _ tokens at: tokens size-2.
						prevFileIndex _ tokens last].
				cat _ tokens at: tokens size-4.
				(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]].
		((tokens size between: 5 and: 6)
			and: [(tokens at: tokens size-3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-1) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size].
				cat _ tokens at: tokens size-2].
 		self addItem:
				(ChangeRecord new file: file position: position type: #method
						class: class name category: category meta: meta stamp: stamp)
			text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector, ' {', cat, '}'.
		position _ prevPos.
		prevPos notNil ifTrue:
			[file _ sourceFilesCopy at: prevFileIndex]].
	sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
	listSelections _ Array new: list size withAll: false! !

!VersionsBrowser methodsFor: 'init & update' stamp: 'sd 11/20/2005 21:27'!
updateListsAndCodeIn: aWindow
	| aMethod |
	aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ false].
	aMethod == currentCompiledMethod
		ifFalse:
			["Do not attempt to formulate if there is no source pointer.
			It probably means it has been recompiled, but the source hasn't been written
			(as during a display of the 'save text simply?' confirmation)."
			aMethod last ~= 0 ifTrue: [self reformulateList]].
	^ true
! !


!VersionsBrowser methodsFor: 'menu' stamp: 'sw 2/27/2001 08:46'!
changeListKey: aChar from: view
	"Respond to a Command key in the list pane. of the versions browser"

	^ self messageListKey: aChar from: view! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'!
compareToOtherVersion
	"Prompt the user for a reference version, then spawn a window 
	showing the diffs between the older and the newer of the current 
	version and the reference version as text."

	| change1 change2 s1 s2 |
	change1 := changeList at: listIndex ifAbsent: [ ^self ].

	change2 := ((SelectionMenu
				labels: (list copyWithoutIndex: listIndex)
				selections: (changeList copyWithoutIndex: listIndex)) startUp) ifNil: [ ^self ].
	
	"compare earlier -> later"
	"change1 timeStamp < change2 timeStamp
		ifFalse: [ | temp | temp := change1. change1 := change2. change2 := temp ]."

	s1 := change1 string.
	s2 := change2 string.
	s1 = s2
		ifTrue: [^ self inform: 'Exact Match' translated].

	(StringHolder new
		textContents: (TextDiffBuilder
				buildDisplayPatchFrom: s1
				to: s2
				inClass: classOfMethod
				prettyDiffs: self showingPrettyDiffs))
		openLabel: (('Comparison from {1} to {2}' translated) format: { change1 stamp. change2 stamp })! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 17:51'!
fileInSelections 
	super fileInSelections.
	self reformulateList! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'!
findOriginalChangeSet
	| changeSet |
	self currentChange ifNil: [^ self].
	changeSet := self currentChange originalChangeSetForSelector: self selectedMessageName.
	changeSet = #sources ifTrue:
		[^ self inform: 'This version is in the .sources file.'].
	changeSet ifNil:
		[^ self inform: 'This version was not found in any changeset nor in the .sources file.'].
	(ChangeSorter new myChangeSet: changeSet) open! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 22:49'!
offerVersionsHelp
	(StringHolder new contents: self versionsHelpString)
		openLabel: 'Versions Browsers'! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sd 5/23/2003 14:50'!
removeMethodFromChanges
	"Remove my method from the current change set"

	ChangeSet current removeSelectorChanges: selectorOfMethod class: classOfMethod.
	self changed: #annotation
! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'!
versionFrom: secsSince1901
	| strings vTime |
	"Return changeRecord of the version in effect at that time.  Accept in the VersionsBrowser does not use this code."

	changeList do: [:cngRec |
		(strings := cngRec stamp findTokens: ' ') size > 2 ifTrue: [
				vTime := strings second asDate asSeconds + 
							strings third asTime asSeconds.
				vTime <= secsSince1901 ifTrue: ["this one"
					^ cngRec == changeList first ifTrue: [nil] ifFalse: [cngRec]]]].
	"was not defined that early.  Don't delete the method."
	^ changeList last	"earliest one may be OK"	! !

!VersionsBrowser methodsFor: 'menu' stamp: 'nk 11/25/2003 10:19'!
versionsHelpString
	^ 'Each entry in the list pane represents a version of the source code for the same method; the topmost entry is the current version, the next entry is the next most recent, etc.

To revert to an earlier version, select it (in the list pane) and then do any of the following:
  *  Choose "revert to this version" from the list pane menu.
  *  Hit the "revert" button,
  *  Type ENTER in the code pane
  *  Type cmd-s (alt-s) in the code pane.

The code pane shows the source for the selected version.  If "diffing" is in effect, then differences betwen the selected version and the version before it are pointed out in the pane.  Turn diffing on and off by choosing "toggle diffing" from the list pane menu, or hitting the "diffs" button, or hitting cmd-D when the cursor is over the list pane.

To get a comparison between the selected version and the current version, choose "compare to current" from the list pane menu or hit the "compare to current" button.  (This is meaningless if the current version is selected, and is unnecessary if you''re interested in diffs from between the current version and the next-most-recent version, since the standard in-pane "diff" feature will give you that.)

You can also compare the selected version with any other version using the "compare to version..." menu choice.

If further versions of the method in question have been submitted elsewhere since you launched a particular Versions Browser, it will still stay nicely up-to-date if you''re in Morphic and have asked that smart updating be maintained; if you''re in mvc or in morphic but with smart-updating turned off, a versions browser is only brought up to date when you activate its window (and when you issue "revert" from within it, of course,) and you can also use the "update list" command to make certain the versions list is up to date.

Hit the "remove from changes" button, or choose the corresponding command in the list pane menu, to have the method in question deleted from the current change set.  This is useful if you''ve put debugging code into a method, and now want to strip it out and cleanse your current change set of all memory of the excursion.

Note:  the annotation pane in versions browsers shows information about the *current* version of the method in the image, not about the selected version.'! !

!VersionsBrowser methodsFor: 'menu' stamp: 'ar 3/3/2004 00:10'!
versionsMenu: aMenu
	"Fill aMenu with menu items appropriate to the receiver"

	Smalltalk isMorphic ifTrue:
		[aMenu title: 'Versions' translated.
		aMenu addStayUpItemSpecial].

	listIndex > 0 ifTrue:[
		(list size > 1 ) ifTrue: [ aMenu addTranslatedList: #(
			('compare to current'		compareToCurrentVersion		'compare selected version to the current version')
			('compare to version...'	compareToOtherVersion		'compare selected version to another selected version'))].
		"Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method"
		 aMenu addTranslatedList: #(
			('revert to selected version'	fileInSelections					'resubmit the selected version, so that it becomes the current version') )].

	aMenu addTranslatedList: #(
		('remove from changes'		removeMethodFromChanges	'remove this method from the current change set, if present')
		('edit current method (O)'	openSingleMessageBrowser		'open a single-message browser on the current version of this method')		
		('find original change set'	findOriginalChangeSet			'locate the changeset which originally contained this version')
		-
		('toggle diffing (D)'			toggleDiffing					'toggle whether or not diffs should be shown here')
		('update list'				reformulateList					'reformulate the list of versions, in case it somehow got out of synch with reality')
		-
		('senders (n)'				browseSenders					'browse all senders of this selector')
		('implementors (m)'			browseImplementors			'browse all implementors of this selector')
		-
		('help...'					offerVersionsHelp				'provide an explanation of the use of this tool')).
											
	^aMenu! !


!VersionsBrowser methodsFor: 'misc' stamp: 'sw 2/27/2001 08:17'!
addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream
	"Add an annotation detailing the prior versions count.  Specially handled here for the case of a selector no longer in the system, whose prior versions are seen in a versions browser -- in this case, the inherited version of this method will not work."

	(aClass includesSelector: aSelector) ifTrue:
		[^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream].

	aStream nextPutAll: 
		((changeList size > 0
			ifTrue:
				[changeList size == 1
					ifTrue:
						['Deleted - one prior version']
					ifFalse:
						['Deleted - ', changeList size printString, ' prior versions']]
			ifFalse:
				['surprisingly, no prior versions']), self annotationSeparator)! !

!VersionsBrowser methodsFor: 'misc' stamp: 'sw 8/17/2002 21:57'!
classCommentIndicated
	"Answer whether the receiver is pointed at a class comment"

	^ false! !

!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 07:03'!
selectedClass
	"Answer the class currently selected in the browser.  In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"

	^ classOfMethod theNonMetaClass! !

!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 06:26'!
selectedClassOrMetaClass
	"Answer the class or metaclass currently selected in the browser.  In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"

	^ classOfMethod! !

!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 06:10'!
selectedMessageName
	"Answer the message name currently selected in the browser.  In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"

	^ selectorOfMethod! !

!VersionsBrowser methodsFor: 'misc' stamp: 'sw 10/19/1999 15:04'!
showsVersions
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VersionsBrowser class
	instanceVariableNames: ''!

!VersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 3/30/2005 21:53'!
browseVersionsForClass: aClass selector: aSelector
	self
		browseVersionsOf: (aClass compiledMethodAt: aSelector)
		class: aClass
		meta: aClass isMeta
		category: (aClass organization categoryOfElement: aSelector)
		selector: aSelector! !

!VersionsBrowser class methodsFor: 'instance creation' stamp: 'di 1/11/2000 12:45'!
browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector 
	^ self browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: nil! !

!VersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: sourcePointer 
	| changeList browser |
	Cursor read showWhile:
		[changeList := (browser := self new)
			scanVersionsOf: method class: class meta: meta
			category: msgCategory selector: selector].
	changeList ifNil: [ self inform: 'No versions available'. ^nil ].

	sourcePointer ifNotNil:
		[changeList setLostMethodPointer: sourcePointer].

	self open: changeList name: 'Recent versions of ' ,
selector multiSelect: false.

	^browser! !

!VersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
timeStampFor: aSelector class: aClass reverseOrdinal: anInteger
	"Answer the time stamp corresponding to some version of the given method, nil if none.  The reverseOrdinal parameter is interpreted as:  1 = current version; 2 = last-but-one version, etc."
	
	| method aChangeList |
	method := aClass compiledMethodAt: aSelector ifAbsent: [^ nil].
	aChangeList := self new
			scanVersionsOf: method class: aClass meta: aClass isMeta
			category: nil selector: aSelector.
	^ aChangeList ifNil: [nil] ifNotNil:
		[aChangeList list size >= anInteger
			ifTrue:
				[(aChangeList changeList at: anInteger) stamp]
			ifFalse:
				[nil]]! !

!VersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
versionCountForSelector: aSelector class: aClass
	"Answer the number of versions known to the system for the given class and method, including the current version.  A result of greater than one means that there is at least one superseded version.  Answer zero if no logged version can be obtained."
	
	| method aChangeList |
	method := aClass compiledMethodAt: aSelector ifAbsent: [^ 0].
	aChangeList := self new
			scanVersionsOf: method class: aClass meta: aClass isMeta
			category: nil selector: aSelector.
	^ aChangeList ifNil: [0] ifNotNil: [aChangeList list size]! !


!VersionsBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:48'!
windowColorSpecification
	"Answer a WindowColorSpec object that declares my preference"

	^ WindowColorSpec classSymbol: self name wording: 'Versions Browser' brightColor: #(0.869 0.753 1.0)	pastelColor: #(0.919 0.853 1.0) helpMessage: 'A tool for viewing prior versions of a method.'! !
Morph subclass: #VeryPickyMorph
	instanceVariableNames: 'passengerMorph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Explorer'!
!VeryPickyMorph commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!VeryPickyMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/1998 21:53'!
passengerMorph: anotherMorph

	passengerMorph _ anotherMorph! !


!VeryPickyMorph methodsFor: 'converting' stamp: 'RAA 7/15/1998 21:55'!
complexContents

	^passengerMorph complexContents! !


!VeryPickyMorph methodsFor: 'drawing' stamp: 'RAA 3/31/1999 14:58'!
drawOn: aCanvas

	aCanvas frameRectangle: bounds width: 1 color: Color red! !


!VeryPickyMorph methodsFor: 'dropping/grabbing' stamp: 'ar 8/10/2003 18:20'!
justDroppedInto: targetMorph event: evt

	passengerMorph ifNil: [^self "delete"].
	passengerMorph noLongerBeingDragged.
	(targetMorph isKindOf: IndentingListItemMorph) ifFalse: [
		passengerMorph changed.
		passengerMorph _ nil.
		owner removeMorph: self.
		self privateOwner: nil.
	].! !


!VeryPickyMorph methodsFor: 'initialization' stamp: 'RAA 3/31/1999 14:58'!
initialize

	super initialize.
	bounds _ 0@0 extent: 8@10
	"bounds _ 0@0 extent: 17@22"
! !


!VeryPickyMorph methodsFor: 'submorphs-add/remove' stamp: 'RAA 7/15/1998 22:02'!
delete

	passengerMorph ifNotNil: [passengerMorph delete].
	super delete! !
Object subclass: #View
	instanceVariableNames: 'model controller superView subViews transformation viewport window displayTransformation insetDisplayBox borderWidth borderColor insideColor boundingBox'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Framework'!
!View commentStamp: '<historical>' prior: 0!
My instances are intended to be components in a structured picture. Each View in the structured picture can contain other Views as sub-components. These sub-components are called subViews. A View can be a subView of only one View. This View is called its superView. The set of Views in a structured picture forms a hierarchy. The one View in the hierarchy that has no superView is called the topView of the structured picture. A View in a structured picture with no subViews is called a bottom View. A View and all of its subViews, and all of their subViews and so on, are treated as a unit in many operations on the View. For example, if a View is displayed, all of its subViews are displayed as well. There are several categories of operations that can be performed on a View. Among these are the following:
	
	1.	Adding subViews to a View.
	2.	Positioning subViews within a View.
	3.	Deleting subViews from a View.
	4.	Transforming a View.
	5.	Displaying a View.
	
Each View has its own coordinate system. In order to change from one coordinate system to another, each View has two transformations associated with it. The local transformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the coordinate system of the superView of the View. The displayTransformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the display screen coordinate system.
	
The part of the space that is to be made visible is represented by the window of the View. The window of a View is a Rectangle expressed in the coordinate system of the View. The area occupied by a View in the coordinate system of its superView is called its viewport. The viewport of a View is its window transformed by its local transformation. The region of the display screen occupied by a View is called its displayBox. The display box of a View can include a border. The width of the border expressed in display screen coordinates is called the border width of the View. The color of the border is called the border color. The region of the display box of a View excluding the border is called the inset display box. The color of the inset display box is called the inside color of the View.!


!View methodsFor: 'basic control sequence'!
subViewWantingControl
	"Answer the first subView that has a controller that now wants control."

	subViews reverseDo: 
		[:aSubView | aSubView controller isControlWanted ifTrue: [^aSubView]].
	^nil! !


!View methodsFor: 'bordering' stamp: 'sw 11/2/1998 15:34'!
backgroundColor
	Display depth <= 2 ifTrue: [^ Color white].
	insideColor ifNotNil: [^ Color colorFrom: insideColor].
	^ superView == nil
		ifFalse: [superView backgroundColor]
		ifTrue:	[Color white]! !

!View methodsFor: 'bordering' stamp: 'tk 10/21/97 12:31'!
backgroundColor: aColor
	Display depth = 1 ifTrue:
		[(aColor ~= nil and: [aColor isTransparent not]) ifTrue:
			["Avoid stipple due to attempts to match non-whites"
			^ insideColor _ Color white]].
	insideColor _ aColor! !

!View methodsFor: 'bordering'!
borderWidth
	"Answer either 0, indicating no border, or a Rectangle whose left value is 
	the width in display coordinates of the receiver's left border. Right, top, 
	and bottom widths are analogous. The border width is initially 0. A 
	View with a border width of 0 will not have any border displayed."

	^borderWidth! !

!View methodsFor: 'bordering'!
borderWidth: anInteger
	"Set the four border widths of the receiver to anInteger."

	self
		borderWidthLeft: anInteger
		right: anInteger
		top: anInteger
		bottom: anInteger! !

!View methodsFor: 'bordering'!
borderWidthLeft: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4
	"Set the border widths of the receiver. These arguments represent the left, 
	right, top, and bottom border widths."

	borderWidth _
			Rectangle
				left: anInteger1
				right: anInteger2
				top: anInteger3
				bottom: anInteger4.
	self unlock! !

!View methodsFor: 'bordering' stamp: 'sw 11/2/1998 15:35'!
foregroundColor
	borderColor ifNotNil: [^ Color colorFrom: borderColor].
	^ superView == nil
		ifFalse: [superView foregroundColor]
		ifTrue:	[Color black]! !

!View methodsFor: 'bordering'!
foregroundColor: aColor
	borderColor _ aColor! !

!View methodsFor: 'bordering'!
insideColor: aColor 
	^ self backgroundColor: aColor! !


!View methodsFor: 'clearing'!
clear
	"Use the border color to paint the display box (including the border, see 
	View|displayBox) of the receiver."

	borderColor ~= nil ifTrue: [self clear: Color black]! !

!View methodsFor: 'clearing'!
clear: aColor 
	"Use aColor to paint the display box (including the border, see 
	View|displayBox) of the receiver."

	aColor ~= nil ifTrue: [Display fill: self displayBox fillColor: aColor]! !

!View methodsFor: 'clearing'!
clearInside
	"Use the inside color to paint the inset display box (excluding the border, 
	see View|insetDisplayBox) of the receiver."

	self clearInside: self backgroundColor! !

!View methodsFor: 'clearing'!
clearInside: aColor 
	"Use aColor to paint the inset display box (excluding the border, see 
	View|insetDisplayBox) of the receiver."

	aColor ~~ nil ifTrue: [Display fill: self insetDisplayBox fillColor: aColor]! !


!View methodsFor: 'controller access'!
controller
	"If the receiver's controller is nil (the default case), answer an initialized 
	instance of the receiver's default controller. If the receiver does not 
	allow a controller, answer the symbol #NoControllerAllowed."

	controller == nil ifTrue: [self controller: self defaultController].
	^controller! !

!View methodsFor: 'controller access'!
controller: aController 
	"Set the receiver's controller to aController. #NoControllerAllowed can be 
	specified to indicate that the receiver will not have a controller. The 
	model of aController is set to the receiver's model."

	self model: model controller: aController! !

!View methodsFor: 'controller access'!
defaultController
	"Answer an initialized instance of the receiver's default controller. 
	Subclasses should redefine this message only if the default controller 
	instances need to be initialized in a nonstandard way."

	^self defaultControllerClass new! !

!View methodsFor: 'controller access'!
defaultControllerClass
	"Answer the class of the default controller for the receiver. Subclasses 
	should redefine View|defaultControllerClass if the class of the default 
	controller is not Controller."

	^Controller! !

!View methodsFor: 'controller access'!
model: aModel controller: aController 
	"Set the receiver's model to aModel, add the receiver to aModel's list of 
	dependents, and set the receiver's controller to aController. Subsequent 
	changes to aModel (see Model|change) will result in View|update: 
	messages being sent to the receiver. #NoControllerAllowed for the value 
	of aController indicates that no default controller is available; nil for the 
	value of aController indicates that the default controller is to be used 
	when needed. If aController is neither #NoControllerAllowed nor nil, its 
	view is set to the receiver and its model is set to aModel."

	model ~~ nil & (model ~~ aModel)
		ifTrue: [model removeDependent: self].
	aModel ~~ nil & (aModel ~~ model)
		ifTrue: [aModel addDependent: self].
	model _ aModel.
	aController ~~ nil
		ifTrue: 
			[aController view: self.
			aController model: aModel].
	controller _ aController! !


!View methodsFor: 'deEmphasizing'!
deEmphasize
	"Modify the emphasis (highlighting, special tabs) of the receiver. This 
	includes objects such as labels, lines, and boxes. Typically used so that 
	the receiver is not presented as active. Do this for the receiver and then 
	for each of the receiver's subViews."

	self deEmphasizeView.
	self deEmphasizeSubViews! !

!View methodsFor: 'deEmphasizing'!
deEmphasizeForDebugger
	"Overridden by StandardSystemView. This default behavior does nothing."
! !

!View methodsFor: 'deEmphasizing'!
deEmphasizeSubViews
	"Send the deEmphasize message to each of the receiver's subviews."

	subViews do: [:aSubView | aSubView deEmphasize]! !

!View methodsFor: 'deEmphasizing'!
deEmphasizeView
	"Subclasses should redefine View|deEmphasizeView in order to modify 
	the emphasis (highlighting, special tabs) of particular objects associated 
	with the View such as labels, lines, and boxes."

	^self! !

!View methodsFor: 'deEmphasizing'!
emphasize
	"Modify the emphasis (highlighting, special tabs) of the receiver. This 
	includes objects such as labels, lines, and boxes. Typically used so that 
	the receiver is presented as active. Do this for the receiver and then 
	for each of the receiver's subViews."

	self emphasizeView.
	self emphasizeSubViews! !

!View methodsFor: 'deEmphasizing'!
emphasizeSubViews
	"Send the emphasize message to each of the receiver's subviews."

	subViews do: [:aSubView | aSubView emphasize]! !

!View methodsFor: 'deEmphasizing'!
emphasizeView
	"Subclasses should redefine View|emphasizeView in order to modify 
	the emphasis (highlighting, special tabs) of particular objects associated 
	with the View such as labels, lines, and boxes."

	^self! !


!View methodsFor: 'display box access'!
apparentDisplayBox
	^self insetDisplayBox expandBy: 2 @ 2! !

!View methodsFor: 'display box access'!
boundingBox
	"Answer the bounding box which for the default case is the rectangular 
	area surrounding the bounding boxes of all the subViews."

	boundingBox ~~ nil
		ifTrue: [^boundingBox]
		ifFalse: [^self computeBoundingBox]! !

!View methodsFor: 'display box access'!
computeBoundingBox
	"Answer the minimum Rectangle that encloses the bounding boxes of the 
	receiver's subViews. If the receiver has no subViews, then the bounding 
	box is the receiver's window. Subclasses should redefine 
	View|boundingBox if a more suitable default for the case of no subViews 
	is available."

	| aRectangle |
	subViews isEmpty ifTrue: [^self getWindow].
	aRectangle _ self firstSubView transform: self firstSubView boundingBox.
	subViews do: 
		[:aView | 
		aRectangle _ aRectangle merge: (aView transform: aView boundingBox).].
	^aRectangle expandBy: borderWidth! !

!View methodsFor: 'display box access'!
displayBox
	"Answer the receiver's inset display box (see View|insetDisplayBox) 
	expanded by the borderWidth. The display box represents the region of 
	the display screen in which the receiver (including the border) is 
	displayed. If the receiver is totally clipped by the display screen and its 
	superView, the resulting Rectangle will be invalid."

	^self insetDisplayBox expandBy: borderWidth! !

!View methodsFor: 'display box access' stamp: 'acg 2/23/2000 00:08'!
insetDisplayBox
	"Answer the receiver's inset display box. The inset display box is the 
	intersection of the receiver's window, tranformed to display coordinates, 
	and the inset display box of the superView, inset by the border width. 
	The inset display box represents the region of the display screen in 
	which the inside of the receiver (all except the border) is displayed. If 
	the receiver is totally clipped by the display screen and its superView, 
	the resulting Rectangle will be invalid."

	insetDisplayBox ifNil: [insetDisplayBox _ self computeInsetDisplayBox].
	^insetDisplayBox! !


!View methodsFor: 'display transformation'!
displayTransform: anObject 
	"Apply the display transformation of the receiver to anObject (see 
	View|displayTransformation) and answer the resulting scaled, translated 
	object. It is normally applied to Rectangles, Points, and other objects with 
	coordinates defined in the View's local coordinate system in order to get 
	a corresponding object in display coordinates."

	^(self displayTransformation applyTo: anObject) rounded! !

!View methodsFor: 'display transformation'!
displayTransformation
	"Answer a WindowingTransformation that is the result of composing all 
	local transformations in the receiver's superView chain with the 
	receiver's own local transformation. The resulting transformation 
	transforms objects in the receiver's coordinate system into objects in the 
	display screen coordinate system."

	displayTransformation == nil
		ifTrue: [displayTransformation _ self computeDisplayTransformation].
	^displayTransformation! !

!View methodsFor: 'display transformation'!
inverseDisplayTransform: aPoint 
	"Answer a Point that is obtained from the argument, aPoint, by applying 
	to it the inverse of the receiver's display transformation. It is typically 
	used by the Controller of the receiver in order to convert a point in 
	display coordinates, such as the cursor point, to the local coordinate 
	system of the receiver."

	^self displayTransformation applyInverseTo: aPoint! !


!View methodsFor: 'displaying'!
clippingTo: rect do: aBlock

	superView clippingTo: rect do: aBlock! !

!View methodsFor: 'displaying' stamp: 'hmm 6/27/2000 07:07'!
display
	"Display the receiver's border, display the receiver, then display the 
	subViews of the receiver. Can be sent to the top View of a structured 
	picture in order to display the entire structure, or to any particular View 
	in the structure in order to display that View and its subViews. It is 
	typically sent in response to an update request to a View."

	Display deferUpdatesIn: self displayBox while: [
		self displayBorder.
		self displayView.
		self displaySubViews]! !

!View methodsFor: 'displaying'!
displayBorder
	"Display the receiver's border (using the receiver's borderColor)."

	borderWidth = 0
		ifTrue:
			[insideColor == nil
				ifFalse: 
					[Display fill: self displayBox fillColor: self backgroundColor]]
		ifFalse:
			[Display
				border: self displayBox
				widthRectangle: borderWidth
				rule: Form over
				fillColor: self foregroundColor.
			insideColor == nil ifFalse:
				[Display fill: self insetDisplayBox fillColor: self backgroundColor]]! !

!View methodsFor: 'displaying'!
displayClippingTo: rect

	| bigRect |
	bigRect _ rect insetBy: -1.
	self clippingTo: bigRect do: [Display clippingTo: bigRect do: [self display]]
! !

!View methodsFor: 'displaying'!
displayDeEmphasized
	self display; deEmphasize! !

!View methodsFor: 'displaying'!
displaySubViews
	"Display all the subViews of the receiver."

	subViews do: [:aSubView | aSubView display]! !

!View methodsFor: 'displaying'!
displayView
	"Subclasses should redefine View|displayView in order to display 
	particular objects associated with the View such as labels, lines, and 
	boxes."

	^self! !

!View methodsFor: 'displaying'!
displayViewDeEmphasized
	self displayView; deEmphasizeView! !

!View methodsFor: 'displaying'!
inspectFirstSubView
	subViews notNil ifTrue:
		[subViews size > 0 ifTrue:
			[(subViews at: 1) inspect]]! !

!View methodsFor: 'displaying'!
inspectModel
	model notNil
		ifTrue: [^ model inspect]
		ifFalse: [self flash]! !

!View methodsFor: 'displaying'!
inspectView
	^self inspect! !

!View methodsFor: 'displaying'!
maximumSize
	"Answer the maximum size of the receiver."

	^ 10000 @ 10000
	! !

!View methodsFor: 'displaying'!
minimumSize
	"Answer the minimum size of the receiver."
	^ 10 @ 10
	! !


!View methodsFor: 'indicating'!
flash
	"Cause the inset display box (the display box excluding the border, see 
	View|insetDisplayBox) of the receiver to complement twice in succession."

	Display flash: self insetDisplayBox! !

!View methodsFor: 'indicating'!
highlight
	"Cause the inset display box (the display box excluding the border, see 
	View|insetDisplayBox) of the receiver to complement."

	Display reverse: self insetDisplayBox! !


!View methodsFor: 'initialize-release'!
initialize
	"Initialize the state of the receiver. Subclasses should include 'super 
	initialize' when redefining this message to insure proper initialization."

	self resetSubViews.
	transformation _ WindowingTransformation identity.
	self borderWidth: 0! !

!View methodsFor: 'initialize-release'!
release
	"Remove the receiver from its model's list of dependents (if the model
	exists), and release all of its subViews. It is used to break possible cycles
	in the receiver and should be sent when the receiver is no longer needed.
	Subclasses should include 'super release.' when redefining release."

	model removeDependent: self.
	model _ nil.
	controller release.
	controller _ nil.
	subViews ~~ nil ifTrue: [subViews do: [:aView | aView release]].
	subViews _ nil.
	superView _ nil! !

!View methodsFor: 'initialize-release'!
setDefaultBackgroundColor
	"Obtain the background color from the receiver's model, unless the #uniformWindowColors preference is set to true, in which case obtain it from generic Object; and install it as the receiver's background color.  5/1/96 sw"

	| colorToUse |
	colorToUse _ Preferences uniformWindowColors
		ifTrue:
			[Object new defaultBackgroundColor]
		ifFalse:
			[model defaultBackgroundColor].
	self backgroundColor: colorToUse! !


!View methodsFor: 'lock access'!
isLocked
	"Answer whether the receiver is locked. A View is 'locked' if its display 
	transformation and inset display box are defined. If these are undefined, 
	the View is 'unlocked'. The display transformation and inset display box 
	become undefined when the transformation of the View (or the 
	transformation of a View in its superView chain) is changed, or when 
	the superView of the View is changed, or any other change to the View 
	that affects the display screen coordinates of the View. The locking and 
	unlocking of a View is handled automatically by the internal methods of 
	the View, but can also be done explicitly if desired (see View|lock, and 
	View|unlock)."

	displayTransformation == nil | (insetDisplayBox == nil)
		ifTrue: [^false]
		ifFalse: [^true]! !

!View methodsFor: 'lock access'!
isUnlocked
	"Answer whether the receiver is unlocked. See comment in 
	View|isLocked."

	^displayTransformation == nil & (insetDisplayBox == nil)! !

!View methodsFor: 'lock access'!
lock
	"'Lock' the receiver and all of its subViews (see View|isLocked). This has 
	the effect of computing and storing the display transformation (see 
	View|displayTransformation) and inset display box (see 
	View|insetDisplayBox) of the receiver and all its subViews. The locking 
	and unlocking of a View is handled automatically by the internal 
	methods of the View, but can also be done explicitly if desired."

	self isLocked ifTrue: [^self].
	displayTransformation _ self computeDisplayTransformation.
	insetDisplayBox _ self computeInsetDisplayBox.
	subViews do: [:aSubView | aSubView lock]! !

!View methodsFor: 'lock access'!
unlock
	"Unlock the receiver and all of its subViews (see View|isUnlocked). This 
	has the effect of forcing the display transformation (see 
	View|displayTransformation) and inset display box (see 
	View|insetDisplayBox) of the receiver and all its subViews to be 
	recomputed the next time they are referenced. The locking and 
	unlocking of a View is handled automatically by the internal methods of 
	the View, but can also be done explicitly if desired."

	self isUnlocked ifTrue: [^self].
	displayTransformation _ nil.
	insetDisplayBox _ nil.
	subViews do: [:aSubView | aSubView unlock]! !


!View methodsFor: 'miscellaneous'!
clipRect
	^ superView clipRect! !

!View methodsFor: 'miscellaneous'!
clipRect: r
	superView clipRect: r! !

!View methodsFor: 'miscellaneous'!
gridSpacing
	^ superView gridSpacing! !

!View methodsFor: 'miscellaneous'!
nestedViewport

	"The viewport size used to control scaling of nested user views."

	^ (0@0 extent: self viewport extent)
			insetBy: 16 @ 16! !

!View methodsFor: 'miscellaneous'!
printViewSpecOn: strm nested: level
	"Print window and viewport specs
	of this and all nested views."
	strm crtab: level; nextPutAll: self class name.
	strm crtab: level; nextPutAll: 'window: '; print: self window.
	strm crtab: level; nextPutAll: 'viewport: '; print: self viewport.
	strm crtab: level; nextPutAll: 'displayBox: '; print: self displayBox.
	strm crtab: level; nextPutAll: 'border: '; print: self borderWidth.
	subViews do: [:v | v printViewSpecOn: strm nested: level+1]! !

!View methodsFor: 'miscellaneous' stamp: 'JMM 10/21/2003 18:12'!
stretchFrame: newFrameBlock startingWith: startFrame 
	"Track the outline of a newFrame as long as mouse drags it.
	Maintain max and min constraints throughout the drag"
	| frame newFrame click delay |
	delay _ Delay forMilliseconds: 10.
	frame _ startFrame origin extent: ((startFrame extent min: self maximumSize)
											max: self minimumSize).
	Display border: frame width: 2 rule: Form reverse fillColor: Color gray.
	click _ false.
	[click and: [Sensor noButtonPressed]] whileFalse: 
		[delay wait.
		click _ click | Sensor anyButtonPressed.
		newFrame _ newFrameBlock value: frame.
		newFrame _ newFrame topLeft extent: ((newFrame extent min: self maximumSize)
											max: self minimumSize).
		newFrame = frame ifFalse:
			[Display border: frame width: 2 rule: Form reverse fillColor: Color gray.
			Display border: newFrame width: 2 rule: Form reverse fillColor: Color gray.
			frame _ newFrame]].
	Display border: frame width: 2 rule: Form reverse fillColor: Color gray.
	^ frame! !


!View methodsFor: 'model access'!
model
	"Answer the receiver's model."

	^model! !

!View methodsFor: 'model access'!
model: aModel 
	"Set the receiver's model to aModel. The model of the receiver's controller 
	is also set to aModel."

	self model: aModel controller: controller! !


!View methodsFor: 'morphic compatibility' stamp: 'mdr 1/24/2000 17:27'!
setBalloonText: aString
	"Unfortunately we just ignore this help text because we are not morphic"
! !


!View methodsFor: 'scrolling'!
scrollBy: aPoint 
	"The x component of aPoint specifies the amount of scrolling in the x 
	direction; the y component specifies the amount of scrolling in the y 
	direction. The amounts are specified in the receiver's local coordinate 
	system. Scroll the receiver up or down, left or right. The window of the 
	receiver is kept stationary and the subViews and other objects in the 
	receiver are translated relative to it. Scrolling doesn't change the 
	insetDisplayBox or the viewport since the change in the transformation 
	is canceled by the change in the window. In other words, all display 
	objects in the view, except the window, are translated by the scrolling 
	operation.
	Note: subclasses may override to return false if no scrolling takes place."

	| aRectangle |
	aRectangle _ insetDisplayBox.
	transformation _ transformation scrollBy: aPoint.
	window _ self getWindow translateBy: aPoint x negated @ aPoint y negated.
	self unlock.
	insetDisplayBox _ aRectangle.
	^ true! !


!View methodsFor: 'subView access'!
firstSubView
	"Answer the first subView in the receiver's list of subViews if it is not 
	empty, else nil."

	subViews isEmpty
		ifTrue: [^nil]
		ifFalse: [^subViews first]! !

!View methodsFor: 'subView access'!
lastSubView
	"Answer the last subView in the receiver's list of subViews if it is not 
	empty, else nil."

	subViews isEmpty
		ifTrue: [^nil]
		ifFalse: [^subViews last]! !

!View methodsFor: 'subView access'!
resetSubViews
	"Set the list of subviews to an empty collection."
	
	subViews _ OrderedCollection new! !

!View methodsFor: 'subView access'!
subViewContaining: aPoint 
	"Answer the first subView that contains aPoint within its window and 
	answer nil, otherwise. It is typically sent from a Controller in order to 
	determine where to pass control (usually to the Controller of the View 
	returned by View|subViewContaining:)."

	subViews reverseDo: 
		[:aSubView | 
		(aSubView displayBox containsPoint: aPoint) ifTrue: [^aSubView]].
	^nil! !

!View methodsFor: 'subView access'!
subViewSatisfying: aBlock
	"Return the first subview that satisfies aBlock, or nil if none does.  1/31/96 sw"

	^ subViews detect: [:aView | aBlock value: aView] ifNone: [nil]! !

!View methodsFor: 'subView access'!
subViews
	"Answer the receiver's collection of subViews."

	^subViews! !

!View methodsFor: 'subView access'!
textEditorView
	"Return the first view in the receiver whose controller is a ParagraphEdior, or nil if none.  1/31/96 sw"

	(controller isKindOf: ParagraphEditor) ifTrue: [^ self].
	^ self subViewSatisfying:
		[:v | v textEditorView ~~ nil]! !


!View methodsFor: 'subView inserting'!
addSubView: aView 
	"Remove aView from the tree of Views it is in (if any) and adds it to the 
	rear of the list of subViews of the receiver. Set the superView of aView 
	to be the receiver. It is typically used to build up a hierarchy of Views 
	(a structured picture). An error notification is generated if aView is the 
	same as the receiver or its superView, and so on."

	self addSubView: aView ifCyclic: [self error: 'cycle in subView structure.']! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView above: lowerView
	"Adds aView (see View|addSubView:) so that it lies above topView."

	self addSubView: aSubView
		align: aSubView viewport bottomLeft
		with: lowerView viewport topLeft! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView align: aPoint1 with: aPoint2 
	"Add aView to the receiver's list of subViews (see View|addSubView:) 
	and translate aView so that aPoint1 coincides with aPoint2. It is typically 
	used to build up a hierarchy of Views (a structured picture). Normally, 
	aPoint1 is a point on aView's viewport (e.g. aView viewport topLeft), 
	and aPoint2 is either an arbitrary point in the receiver's coordinate 
	system or a point on the receiver's window (e.g., self window topRight)."

	self addSubView: aSubView.
	aSubView align: aPoint1 with: aPoint2! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView below: lowerView
	"Add the argument, aSubView, (see View|addSubView:) so that it lies 
	below the view, topView."

	self addSubView: aSubView
		align: aSubView viewport topLeft
		with: lowerView viewport bottomLeft! !

!View methodsFor: 'subView inserting'!
addSubView: aView ifCyclic: exceptionBlock 
	"Remove aView from the tree of Views it is in (if any) and add it to the 
	rear of the list of subViews of the receiver. Set the superView of aView 
	to be the receiver. It is typically used to build up a hierarchy of Views 
	(a structured picture). An error notification is generated if aView is the 
	same as the receiver or its superView, and so on."

	(self isCyclic: aView)
		ifTrue: [exceptionBlock value]
		ifFalse: 
			[aView removeFromSuperView.
			subViews addLast: aView.
			aView superView: self]! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView toLeftOf: rightView
	"Adds aView (see addSubView:) so that it lies to the right of rightView."

	self addSubView: aSubView
		align: aSubView viewport topRight
		with:  rightView viewport topLeft! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView toRightOf: leftView
	"Add the argument, aSubView, (see View|addSubView:) so that it lies to 
	the right of the view, leftView."

	self addSubView: aSubView
		align: aSubView viewport topLeft
		with: leftView viewport topRight! !

!View methodsFor: 'subView inserting'!
addSubView: aView viewport: aViewport 
	"Add aView to the receiver's list of subViews (see View|addSubView:) and 
	applies to aView a scale and translation computed from its window and 
	aViewport (such that its window fills aViewport)."

	self addSubView: aView.
	aView window: aView window viewport: aViewport! !

!View methodsFor: 'subView inserting'!
addSubView: aView window: aWindow viewport: aViewport 
	"Add aView to the receiver's list of subViews (see View|addSubView:) 
	and applies to aView a scale and translation computed from aWindow 
	and aViewport (such that aWindow fills aViewport)."

	self addSubView: aView.
	aView window: aWindow viewport: aViewport! !


!View methodsFor: 'subView removing'!
releaseSubView: aView 
	"Delete aView from the receiver's list of subViews and send it the 
	message 'release' (so that it can break up cycles with subViews, etc.)."

	self removeSubView: aView.
	aView release! !

!View methodsFor: 'subView removing'!
releaseSubViews
	"Release (see View|releaseSubView:) all subViews in the receiver's list of 
	subViews."

	subViews do: [:aView | aView release].
	self resetSubViews! !

!View methodsFor: 'subView removing'!
removeFromSuperView
	"Delete the receiver from its superView's collection of subViews."

	superView ~= nil ifTrue: [superView removeSubView: self]! !

!View methodsFor: 'subView removing'!
removeSubView: aView 
	"Delete aView from the receiver's list of subViews. If the list of subViews 
	does not contain aView, create an error notification."

	subViews remove: aView.
	aView superView: nil.
	aView unlock! !

!View methodsFor: 'subView removing'!
removeSubViews
	"Delete all the receiver's subViews."

	subViews do: 
		[:aView | 
		aView superView: nil.
		aView unlock].
	self resetSubViews! !


!View methodsFor: 'superView access'!
isTopView
	"Answer whether the receiver is a top view, that is, if it has no 
	superView."

	^superView == nil! !

!View methodsFor: 'superView access'!
superView
	"Answer the superView of the receiver."

	^superView! !

!View methodsFor: 'superView access'!
topView
	"Answer the root of the tree of Views in which the receiver is a node. 
	The root of the tree is found by going up the superView path until 
	reaching a View whose superView is nil."

	superView == nil
		ifTrue: [^self]
		ifFalse: [^superView topView]! !


!View methodsFor: 'testing' stamp: 'tk 4/13/1998 22:58'!
canDiscardEdits
	"Return true if this pane is not dirty."

	^ true
! !

!View methodsFor: 'testing'!
containsPoint: aPoint
	"Answer whether aPoint is within the receiver's display box. It is sent to 
	a View's subViews by View|subViewAt: in order to determine which 
	subView contains the cursor point (so that, for example, control can be 
	pass down to that subView's controller)."

	^ self insetDisplayBox containsPoint: aPoint! !

!View methodsFor: 'testing' stamp: 'jm 3/17/98 13:35'!
hasUnacceptedEdits
	"Return true if this view has unaccepted edits."

	^ false
! !

!View methodsFor: 'testing'!
isObscured

	| topController displayRect |
	(topController _ self topView controller)
		== ScheduledControllers activeController
			ifTrue: [^false].
	displayRect _ self insetDisplayBox.
	ScheduledControllers scheduledControllers do: [:ctrlr |
		ctrlr == topController ifTrue: [^false].
		(displayRect intersects: ctrlr view insetDisplayBox)
			ifTrue: [^true]].
	self error: 'not in ScheduledControllers'.
	^false! !


!View methodsFor: 'transforming'!
align: aPoint1 with: aPoint2 
	"Add a translation of (aPoint2 - aPoint1) to the receiver's local 
	transformation. The point in the receiver's coordinate system that 
	previously was transformed to aPoint1 in the superView's coordinate 
	system will now be transformed to aPoint2 in the superView's coordinate 
	system. Other points will be translated by the same amount. It is 
	normally used when adding subViews to their superView in order to 
	line up the Viewport of one subView with that of another subView (see 
	View|addSubView:align:with:). aPoint1 and aPoint2 are usually points on 
	the viewports that are to be aligned. For example, 'subView2 align: 
	subView2 viewport topLeft with: subView1 viewport topRight' would be 
	used to place the viewport of subView2 next to the viewport of 
	subView1 with the topLeft and topRight corners, respectively, 
	coinciding. It is also possible to align the viewport of a subView with 
	the window of the superView, e.g., 'subView align: subView viewport 
	center with: superView window center'. View|align:with: assumes that 
	the view has been properly scaled, if necessary, to match its superView 
	(see View|scaleBy:). Typically, the coordinate systems of the receiver 
	and its superView will differ only by a translation offset so that no 
	scaling is necessary."

	self setTransformation: (transformation align: aPoint1 with: aPoint2)! !

!View methodsFor: 'transforming'!
scale: aScale translation: aTranslation 
	"The x component of aScale (a Point) specifies the scale (translation) in 
	the x direction; the y component specifies the scale (translation) in the y 
	direction. aScale can optionally be an instance of Integer or Float in 
	order to specify uniform scaling in both directions. Create a new local 
	transformation for the receiver with a scale factor of aScale and a 
	translation offset of aTranslation. When the transformation is applied (see 
	View|transform:), the scale is applied first, followed by the translation. It 
	is typically used when building a superView from its subViews in order 
	to line up the viewports of the subViews in the desired way. If no 
	scaling is required between subView and superView, then 
	View|align:with: is often more convenient to use."

	self setTransformation:
		(WindowingTransformation scale: aScale translation: aTranslation)! !

!View methodsFor: 'transforming'!
scaleBy: aScale 
	"The x component of aScale (a Point) specifies the scale in the x 
	direction; the y component specifies the scale in the y direction. aScale 
	can, optionally, be an instance of Integer or Float in order to specify 
	uniform scaling in both directions. Scales the View by aScale. The scale 
	is concatenated with the current transformation of the receiver and is 
	applied when View|transform is sent. This happens automatically in the 
	process of displaying the receiver, for example."

	self setTransformation: (transformation scaleBy: aScale)! !

!View methodsFor: 'transforming'!
transform: anObject 
	"Apply the local transformation of the receiver to anObject and answer 
	the resulting transformation. It is used to get the superView coordinates 
	of an object. For example, the viewport is equal to the window 
	transformed."

	^transformation applyTo: anObject! !

!View methodsFor: 'transforming'!
transformation
	"Answer a copy of the receiver's local transformation."

	^transformation copy! !

!View methodsFor: 'transforming'!
transformation: aTransformation 
	"Set the receiver's local transformation to a copy of aTransformation, 
	unlock the receiver (see View|unlock) and set the viewport to undefined 
	(this forces it to be recomputed when needed)."

	self setTransformation: aTransformation copy! !

!View methodsFor: 'transforming'!
translateBy: aPoint 
	"Translate the receiver by aPoint. The translation is concatenated with 
	the current transformation of the receiver and is applied when 
	View|transform is sent. This happens automatically in the process of 
	displaying the receiver."

	self setTransformation: (transformation translateBy: aPoint)! !

!View methodsFor: 'transforming'!
window: aWindow viewport: aViewport 
	"Set the receiver's window to aWindow, set its viewport to aViewport, and 
	create a new local transformation for the receiver based on aWindow and 
	aViewport. The receiver is scaled and translated so that aWindow, when 
	transformed, coincides with aViewport. It is used to position a subView's 
	window within some specific region of its superView's area. For example, 
	'subView window: aRectangle1 viewport: aRectangle2' sets subView's 
	window to aRectangle1, its viewport to aRectangle2, and its local 
	transformation to one that transforms aRectangle1 to aRectange2."

	self window: aWindow.
	self setTransformation:
		(WindowingTransformation window: aWindow viewport: aViewport).
	self getViewport! !


!View methodsFor: 'updating'!
update
	"Normally sent by the receiver's model in order to notify the receiver of 
	a change in the model's state. Subclasses implement this message to do 
	particular update actions. A typical action that might be required is to 
	redisplay the receiver."

	self update: self! !

!View methodsFor: 'updating'!
update: aParameter 
	"Normally sent by the receiver's model in order to notify the receiver of 
	a change in the model's state. Subclasses implement this message to do 
	particular update actions. A typical action that might be required is to 
	redisplay the receiver."

	^self! !


!View methodsFor: 'viewport access'!
viewport
	"Answer a copy of the receiver's viewport."

	^self getViewport copy! !


!View methodsFor: 'window access'!
defaultWindow
	"Build the minimum Rectangle that encloses all the windows of the 
	receiver's subViews. The answer is a Rectangle obtained by expanding 
	this minimal Rectangle by the borderWidth of the receiver. If the 
	receiver has no subViews, then a Rectangle enclosing the entire display 
	screen is answered. It is used internally by View methods if no window 
	has been specified for the View. Specialized subclasses of View should 
	redefine View|defaultWindow to handle the default case for instances 
	that have no subViews."

	| aRectangle |
	subViews isEmpty ifTrue: [^DisplayScreen boundingBox].
	aRectangle _ self firstSubView viewport.
	subViews do: [:aView | aRectangle _ aRectangle merge: aView viewport].
	^aRectangle expandBy: borderWidth! !

!View methodsFor: 'window access'!
insetWindow
	"Answer a Rectangle that is obtained by insetting the receiver's window 
	rectangle by the border width."

	^self getWindow insetBy: borderWidth! !

!View methodsFor: 'window access'!
window
	"Answer a copy of the receiver's window."

	^self getWindow copy! !

!View methodsFor: 'window access'!
window: aWindow 
	"Set the receiver's window to a copy of aWindow."

	self setWindow: aWindow copy! !


!View methodsFor: 'private'!
computeDisplayTransformation
	"Answer a WindowingTransformation that transforms the coordinate 
	system of the View into that of the display screen. The transformation is 
	computed by composing the View's transformation with all transformations 
	along its superView chain. It is sent by View|displayTransformation when
	the View is unlocked (see View|unlock)."

	self isTopView
		ifTrue: [^transformation]
		ifFalse: [^superView displayTransformation compose: transformation]! !

!View methodsFor: 'private'!
computeInsetDisplayBox
	"Compute the View's inset display box by intersecting the superView's
	inset display box with the View's window transformed to display
	coordinates and then inseting the result by the border width. It is sent by 
	View|insetDisplayBox if the inset display box is nil.

	The insetDisplayBox points are truncated to prevent sending floating point numbers to QuickDraw which will die."

	self isTopView
		ifTrue:
			[^((self displayTransform: self getWindow) insetBy: borderWidth) truncated]
		ifFalse:
			[^(superView insetDisplayBox
				intersect: (self displayTransform: self getWindow)) truncated
						insetBy: borderWidth]! !

!View methodsFor: 'private'!
getController
	"Answer the View's controller if one exists. nil indicates that the default
	controller is to be used."

	^controller! !

!View methodsFor: 'private'!
getViewport
	"Answer the Rectangle representing the View's viewport (in the
	coordinate system of the superclass). If no viewport has been specified,
	the View's window transformed into the superView's coordinate system is
	saved and returned. It should be used by methods of View and subclasses
	(instead of directly referring to the viewport) unless it is known that a
	viewport actually exists. It should not be used outside of View or
	subclasses because the viewport is not sharable."

	viewport == nil ifTrue: [viewport _ (self transform: self getWindow) truncated].
	^viewport! !

!View methodsFor: 'private'!
getWindow
	"Answer the Rectangle that represents the window of this View. If no
	window has been specified, a default window (see View|defaultWindow)
	is created, saved, and returned. Should be used by methods of View and
	subclasses to access the View window instead of directly accessing the
	field unless it is known that a window actually exists. It is not to be used
	outside of View (or subclasses) because the window is not sharable.
	View|window should be used for outside access to the window."

	window == nil ifTrue: [self setWindow: self defaultWindow].
	^window! !

!View methodsFor: 'private'!
isCyclic: aView 
	"Answer true if aView is the same as this View or its superView, false 
	otherwise."

	self == aView ifTrue: [^true].
	self isTopView ifTrue: [^false].
	^superView isCyclic: aView! !

!View methodsFor: 'private'!
setTransformation: aTransformation 
	"Set the View's local transformation to aTransformation, unlock the View 
	(see View|unlock), and set the viewport to undefined (this forces it to be 
	recomputed when needed). Should be used instead of setting the 
	transformation directly."

	transformation _ aTransformation.
	self unlock.
	viewport _ nil! !

!View methodsFor: 'private'!
setWindow: aWindow 
	"Set the View's window to aWindow and unlock the View (see
	View|unlock). View|setWindow should be used by methods of View and
	subclasses to set the View window (rather than directly setting the
	instance variable) to insure that the View is unlocked."

	window _ aWindow.
	viewport _ nil.
	self unlock! !

!View methodsFor: 'private'!
superView: aView 
	"Set the View's superView to aView and unlock the View (see
	View|unlock). It is sent by View|addSubView: in order to properly set all
	the links."

	superView _ aView.
	self unlock! !
AlignmentMorph subclass: #Viewer
	instanceVariableNames: 'scriptedPlayer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!Viewer commentStamp: 'sw 9/6/2002 13:14' prior: 0!
An abstract superclass for both CategoryViewer and StandardViewer.  A viewer is always associated with a particular 'scriptedPlayer' -- the object whose protocol it shows in tile form.!


!Viewer methodsFor: 'access' stamp: 'sw 10/21/1998 15:56'!
scriptedPlayer
	^ scriptedPlayer! !

!Viewer methodsFor: 'access' stamp: 'sw 10/20/1998 13:20'!
scriptedPlayer: aPlayer
	scriptedPlayer _ aPlayer! !


!Viewer methodsFor: 'commands' stamp: 'yo 1/14/2005 19:57'!
chooseVocabulary
	"Put up a menu allowing the user to specify which protocol to use in this viewer"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Choose a vocabulary' translated.
	"aMenu addStayUpItem."  "For debugging only"
	Vocabulary allStandardVocabularies do:
		[:aVocabulary |
			(scriptedPlayer class implementsVocabulary: aVocabulary)
				ifTrue:
					[aMenu add: aVocabulary vocabularyName selector: #switchToVocabulary: argument: aVocabulary.
					aVocabulary == self currentVocabulary ifTrue:
						[aMenu lastItem color: Color blue]. 
					aMenu balloonTextForLastItem: aVocabulary documentation]].
	aMenu popUpInWorld: self currentWorld! !

!Viewer methodsFor: 'commands' stamp: 'sw 1/26/2001 15:26'!
newPermanentScript
	"Create a new, empty script and attach it to the hand"

	| aMorph |
	self scriptedPlayer assureUniClass.
	aMorph _ ImageMorph new image: (ScriptingSystem formAtKey: 'newScript').
	aMorph setProperty: #newPermanentScript toValue: true.
	aMorph setProperty: #newPermanentPlayer toValue: self scriptedPlayer.
	self primaryHand attachMorph: aMorph! !

!Viewer methodsFor: 'commands' stamp: 'nb 6/17/2003 12:25'!
nextCostume
	| aList aPlayer itsCurrent anIndex newIndex |
	aList _ (aPlayer _ scriptedPlayer) availableCostumesForArrows.
	aList isEmptyOrNil ifTrue: [^ Beeper beep].
	itsCurrent _ aPlayer costume renderedMorph.
	anIndex _ aList indexOf: itsCurrent ifAbsent: [nil].
	newIndex _ anIndex
		ifNil:		[1]
		ifNotNil:	[anIndex + 1].
	newIndex > aList size ifTrue: [newIndex _ 1].
	aPlayer renderedCostume: (aList at: newIndex).
	self presenter ifNotNil: [self presenter updateViewer: self]! !

!Viewer methodsFor: 'commands' stamp: 'nb 6/17/2003 12:25'!
previousCostume
	| aList aPlayer itsCurrent anIndex newIndex |
	aList _ (aPlayer _ scriptedPlayer) availableCostumesForArrows.
	aList isEmptyOrNil ifTrue: [^ Beeper beep].
	itsCurrent _ aPlayer costume renderedMorph.
	anIndex _ aList indexOf: itsCurrent ifAbsent: [nil].
	newIndex _ anIndex
		ifNil:		[aList size]
		ifNotNil:	[anIndex - 1].
	newIndex < 1 ifTrue: [newIndex _ aList size].
	aPlayer renderedCostume: (aList at: newIndex).
	self presenter ifNotNil: [self presenter updateViewer: self]! !


!Viewer methodsFor: 'copying' stamp: 'tk 1/7/1999 17:01'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
scriptedPlayer _ deepCopier references at: scriptedPlayer ifAbsent: [scriptedPlayer].! !

!Viewer methodsFor: 'copying' stamp: 'tk 1/8/1999 07:42'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
scriptedPlayer _ scriptedPlayer.		"Weakly copied"
	"Store into it to satisfy checkVariables"! !


!Viewer methodsFor: 'dropping/grabbing' stamp: 'ar 2/13/2001 19:58'!
repelsMorph: aMorph event: ev
	"viewers in flaps are resistant to drop gestures"
	owner isFlap ifTrue:[^true].
	^false! !

!Viewer 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"! !


!Viewer methodsFor: 'e-toy support' stamp: 'sw 10/21/1998 15:55'!
isAViewer
	^ true! !

!Viewer methodsFor: 'e-toy support' stamp: 'sw 7/6/1999 08:43'!
isCandidateForAutomaticViewing
	^ false! !

!Viewer methodsFor: 'e-toy support' stamp: 'nk 8/29/2004 17:18'!
objectViewed
	"Answer the graphical object to which the receiver's phrases apply"

	^ (scriptedPlayer isPlayerLike)
		ifTrue:
			[scriptedPlayer costume]
		ifFalse:
			[scriptedPlayer]! !


!Viewer methodsFor: 'initialization' stamp: 'ar 11/9/2000 22:00'!
initialize
	super initialize.
	self useRoundedCorners.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.! !


!Viewer methodsFor: 'queries'!
aboutMethod: aSelector 
	"Give the user documentation for the selector"
	| aClass help |
	aClass _ scriptedPlayer class whichClassIncludesSelector: aSelector.
	help _ aClass firstCommentAt: aSelector.
	help
		ifNotNil: [self
				inform: (help string withNoLineLongerThan: 25)]! !

!Viewer methodsFor: 'queries' stamp: 'sd 4/16/2003 08:44'!
browseImplementorsOf: aSelector
	"Open a browser on implementors of aSelector"

	self systemNavigation browseAllImplementorsOf: aSelector

! !

!Viewer methodsFor: 'queries'!
browseMethodFull: aSelector 
	"Open a traditional browser on aSelector, in whatever class implements 
	aSelector "
	| aClass |
	aClass _ scriptedPlayer class whichClassIncludesSelector: aSelector.
	Browser fullOnClass: aClass selector: aSelector! !

!Viewer methodsFor: 'queries' stamp: 'sd 1/16/2004 21:10'!
browseMethodInheritance: aSelector 
	"Open an inheritance browser on aSelector"
	| aClass |
	aClass _ scriptedPlayer class whichClassIncludesSelector: aSelector.
	self systemNavigation methodHierarchyBrowserForClass: aClass selector: aSelector! !

!Viewer methodsFor: 'queries' stamp: 'dvf 8/23/2003 11:51'!
browseSendersOf: aSelector 
	"Open a browser on senders of aSelector"

	self systemNavigation browseAllCallsOn: aSelector! !

!Viewer methodsFor: 'queries'!
browseVersionsOf: aSelector 
	"Open a browser on versions of aSelector"
	| aClass |
	aClass _ scriptedPlayer class whichClassIncludesSelector: aSelector.
	Utilities browseVersionsForClass: aClass selector: aSelector! !


!Viewer methodsFor: 'special phrases' stamp: 'yo 6/18/2004 16:01'!
angleToPhrase

	| outerPhrase getTile |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Number
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	(outerPhrase submorphs second) delete.	"color"
	getTile _ KedamaAngleToTile new.
	outerPhrase addMorphBack: getTile.
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'yo 9/28/2004 18:24'!
bounceOnColorPhrase

	| outerPhrase bounceOn |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Boolean
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	(outerPhrase submorphs second) delete.	"color"
	bounceOn _ KedamaBounceOnColorTile new.
	"upHill setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer)."
	outerPhrase addMorphBack: bounceOn.
	^outerPhrase.
! !

!Viewer methodsFor: 'special phrases' stamp: 'yo 9/27/2004 15:07'!
bounceOnPhrase

	| outerPhrase upHill |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Boolean
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	(outerPhrase submorphs second) delete.	"color"
	upHill _ KedamaBounceOnTile new.
	"upHill setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer)."
	outerPhrase addMorphBack: upHill.
	^outerPhrase.
! !

!Viewer methodsFor: 'special phrases' stamp: 'yo 10/12/2004 22:56'!
colorComponentPhraseFor: componentName

	| outerPhrase getTile |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Number
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	(outerPhrase submorphs second) delete.	"color"
	getTile _ KedamaGetColorComponentTile new.
	getTile componentName: componentName.
	getTile setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer).
	outerPhrase addMorphBack: getTile.
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'dgd 2/22/2003 19:02'!
colorSeesPhrase
	"In classic tiles, answer a complete phrase that represents the colorSees test"

	| outerPhrase |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Boolean
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	"Install (ColorSeerTile new) in middle position"
	(outerPhrase submorphs second) delete.	"operator"
	outerPhrase addMorphBack: ColorSeerTile new.
	(outerPhrase submorphs second) goBehind.	"Make it third"
	outerPhrase submorphs last addMorph: (ColorTileMorph new 
				typeColor: (ScriptingSystem colorForType: #Color)).
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'yo 6/18/2004 16:01'!
distanceToPhrase

	| outerPhrase getTile |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Number
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	(outerPhrase submorphs second) delete.	"color"
	getTile _ KedamaDistanceToTile new.
	outerPhrase addMorphBack: getTile.
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'nk 10/14/2004 10:59'!
overlapsAnyPhrase
	"Answer a conjured-up overlaps phrase in classic tile"

	| outerPhrase |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Boolean
				rcvrType: #Player
				argType: #Player.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	outerPhrase addMorphBack: (TileMorph new setOperator: #overlapsAny:).
	(outerPhrase submorphs second) goBehind.	"Make it third"
	outerPhrase submorphs last addMorph: scriptedPlayer tileToRefer.
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'dgd 2/22/2003 19:02'!
overlapsPhrase
	"Answer a conjured-up overlaps phrase in classic tile"

	| outerPhrase |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Boolean
				rcvrType: #Player
				argType: #Player.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	outerPhrase addMorphBack: (TileMorph new setOperator: #overlaps:).
	(outerPhrase submorphs second) goBehind.	"Make it third"
	outerPhrase submorphs last addMorph: scriptedPlayer tileToRefer.
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'yo 6/18/2004 16:02'!
patchUphillPhrase

	| outerPhrase upHill |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Number
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	(outerPhrase submorphs second) delete.	"color"
	upHill _ KedamaUpHillTile new.
	upHill setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer).
	outerPhrase addMorphBack: upHill.
	^outerPhrase.
! !

!Viewer methodsFor: 'special phrases' stamp: 'yo 6/18/2004 16:50'!
patchValuePhrase

	| outerPhrase getTile |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Number
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	(outerPhrase submorphs second) delete.	"color"
	getTile _ KedamaGetPixelValueTile new.
	getTile setPatchDefaultTo: (scriptedPlayer defaultPatchPlayer).
	outerPhrase addMorphBack: getTile.
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'dgd 2/22/2003 19:02'!
seesColorPhrase
	"In classic tiles, answer a complete phrase that represents the seesColor test"

	| outerPhrase seesColorTile |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Boolean
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	"Install (ColorSeerTile new) in middle position"
	(outerPhrase submorphs second) delete.	"operator"
	seesColorTile := TileMorph new setOperator: #seesColor:.
	outerPhrase addMorphBack: seesColorTile.
	(outerPhrase submorphs second) goBehind.	"Make it third"
	"	selfTile _ self tileForSelf bePossessive.	Done by caller.
	selfTile position: 1.
	outerPhrase firstSubmorph addMorph: selfTile.
"
	outerPhrase submorphs last addMorph: (ColorTileMorph new 
				typeColor: (ScriptingSystem colorForType: #Color)).
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'dgd 2/22/2003 19:02'!
touchesAPhrase
	"Answer a conjured-up touchesA phrase in classic tile"

	| outerPhrase |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Boolean
				rcvrType: #Player
				argType: #Player.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	outerPhrase addMorphBack: (TileMorph new setOperator: #touchesA:).
	(outerPhrase submorphs second) goBehind.	"Make it third"
	outerPhrase submorphs last addMorph: scriptedPlayer tileToRefer.
	^outerPhrase! !

!Viewer methodsFor: 'special phrases' stamp: 'yo 3/7/2005 08:39'!
turtleOfPhrase

	| outerPhrase getTile |
	outerPhrase := PhraseTileMorph new 
				setOperator: #+
				type: #Player
				rcvrType: #Player
				argType: #Color.	"temp dummy"
	(outerPhrase submorphs second) delete.	"operator"
	(outerPhrase submorphs second) delete.	"color"
	getTile _ KedamaTurtleOfTile new.
	outerPhrase addMorphBack: getTile.
	^outerPhrase! !


!Viewer methodsFor: 'transition' stamp: 'sw 11/5/1998 15:48'!
noteDeletionOf: aMorph
	| pal |
	aMorph player == scriptedPlayer ifTrue:
		[(pal _ self standardPalette)
			ifNotNil: [pal showNoPalette]
			ifNil:	[self delete]]   "Viewer on a discarded player"! !

!Viewer methodsFor: 'transition' stamp: 'sw 10/6/2000 22:41'!
retargetFrom: oldPlayer to: newPlayer
	"Retarget the receiver so that instead of viewing oldPlayer, it now views newPlayer, which are expected to be different instances of the same uniclass"

	scriptedPlayer == oldPlayer
		ifTrue:
			[self allMorphs do:  "nightmarishly special-cased, sorry"
				[:aMorph | 
					(aMorph isKindOf: Viewer) ifTrue:  "includes self"
						[aMorph scriptedPlayer: newPlayer].
					((aMorph isKindOf: UpdatingStringMorph) and: [aMorph target == oldPlayer]) ifTrue:
						[aMorph target: newPlayer].
					(aMorph isKindOf: TileMorph) ifTrue:
						[aMorph retargetFrom: oldPlayer to: newPlayer]]]! !
AlignmentMorph subclass: #ViewerEntry
	instanceVariableNames: 'helpPane'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!ViewerEntry methodsFor: 'access' stamp: 'sw 11/5/1998 10:09'!
entryType
	^ self viewerRow entryType! !

!ViewerEntry methodsFor: 'access' stamp: 'sw 12/28/1998 13:01'!
playerBearingCode
	^ owner owner scriptedPlayer! !

!ViewerEntry methodsFor: 'access' stamp: 'sw 11/5/1998 10:09'!
viewerRow
	"Answer the ViewerRow object, that contains the controls and the phraseTile"
	^ submorphs first! !


!ViewerEntry methodsFor: 'contents' stamp: 'nb 6/17/2003 12:25'!
contents: c notifying: k
	"later, spruce this up so that it can accept input such as new method source"
	| info |
	(info _ self userSlotInformation)
		ifNotNil:
			[info documentation: c.
			^ true].
	Beeper beep.
	^ false! !

!ViewerEntry methodsFor: 'contents' stamp: 'sw 11/5/1998 09:31'!
contentsSelection
	"Not well understood why this needs to be here!!"
	^ 1 to: 0! !


!ViewerEntry methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:32'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 1.0
		g: 0.985
		b: 0.985! !

!ViewerEntry methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:07'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self layoutInset: 0! !


!ViewerEntry methodsFor: 'menu' stamp: 'sw 11/9/1998 13:57'!
codePaneMenu: aMenu shifted: shifted
	^ aMenu 
		labels: 'menu
eventually
will
be
useful'
		lines: #(1)
		selections: #(beep flash beep flash beep)! !


!ViewerEntry methodsFor: 'slot' stamp: 'sw 1/13/1999 12:57'!
slotName
	"Assuming the receiver represents a slot, return its name"

	^  self viewerRow elementSymbol! !

!ViewerEntry methodsFor: 'slot' stamp: 'sw 12/28/1998 12:50'!
userSlotInformation
	"If the receiver represents a user-defined slot, then return its info; if not, retun nil"
	| aSlotName info |
	((self entryType == #systemSlot) or: [self entryType == #userSlot])
		ifFalse:
			[^ nil].
	aSlotName _ self slotName.
	^ ((info _ self playerBearingCode slotInfo) includesKey: aSlotName)
		ifTrue:
			[info at: aSlotName]
		ifFalse:
			[nil]! !
FlapTab subclass: #ViewerFlapTab
	instanceVariableNames: 'scriptedPlayer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Flaps'!
!ViewerFlapTab commentStamp: 'kfr 10/28/2003 06:31' prior: 0!
ViewerFlapTab are flap tabs for etoy scripting viewers.!


!ViewerFlapTab methodsFor: 'access' stamp: 'sw 6/25/1999 22:07'!
scriptedPlayer
	^ scriptedPlayer! !


!ViewerFlapTab methodsFor: 'accessing' stamp: 'sw 7/7/1999 13:28'!
isCurrentlyGraphical
	^ true! !


!ViewerFlapTab methodsFor: 'compact' stamp: 'ar 12/19/2000 18:58'!
changeCompactFlap
	self makeFlapCompact: self isFlapCompact not.! !

!ViewerFlapTab methodsFor: 'compact' stamp: 'dgd 8/30/2003 22:23'!
compactFlapString
	^ (self isFlapCompact
		ifTrue: ['<on>compact flap']
		ifFalse: ['<off>']), 'compact flap' translated! !

!ViewerFlapTab methodsFor: 'compact' stamp: 'ar 12/19/2000 18:54'!
isFlapCompact
	"Return true if the referent of the receiver represents a 'compact' flap"
	referent layoutPolicy ifNil:[^false].
	referent layoutPolicy isTableLayout ifFalse:[^false].
	referent vResizing == #shrinkWrap ifFalse:[^false].
	^true! !

!ViewerFlapTab methodsFor: 'compact' stamp: 'ar 12/19/2000 18:55'!
makeFlapCompact: aBool
	"Return true if the referent of the receiver represents a 'compact' flap"
	aBool ifTrue:[
		referent
			layoutPolicy: TableLayout new;
			vResizing: #shrinkWrap;
			useRoundedCorners.
	] ifFalse:[
		referent
			layoutPolicy: nil;
			vResizing: #rigid;
			useSquareCorners.
	].! !


!ViewerFlapTab methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:21'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add further items to the menu as appropriate.  NB: Cannot call super here."

	aMenu add: 'flap color...' translated target: self action: #changeFlapColor.
	aMenu addLine.
	aMenu addUpdating: #edgeString action: #setEdgeToAdhereTo.
	aMenu addUpdating: #dragoverString action: #toggleDragOverBehavior.
	aMenu addUpdating: #mouseoverString action: #toggleMouseOverBehavior.
	aMenu addLine.
	aMenu addUpdating: #compactFlapString target: self action: #changeCompactFlap.

	aMenu add: 'destroy this flap' translated action: #destroyFlap! !

!ViewerFlapTab methodsFor: 'menu' stamp: 'sw 5/4/2001 07:45'!
graphicalMorphForTab
	"Answer a graphical morph to serve as my tab's display"

	^ ThumbnailMorph new objectToView: scriptedPlayer viewSelector: #graphicForViewerTab! !


!ViewerFlapTab methodsFor: 'submorphs-accessing' stamp: 'tk 1/31/2001 16:03'!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy.  Especially the non-showing pages in BookMorphs."

	^ flapShowing 
		ifTrue: [#()]
		ifFalse: [Array with: referent]! !


!ViewerFlapTab methodsFor: 'transition' stamp: 'ar 3/3/2001 20:24'!
hibernate
	"drop my viewer to save space when writing to the disk."

	referent submorphs do: 
		[:m | (m isKindOf: Viewer) ifTrue: [m delete]]! !

!ViewerFlapTab methodsFor: 'transition' stamp: 'sw 7/7/1999 13:14'!
initializeFor: aPlayer topAt: aTop

	scriptedPlayer _ aPlayer.
	self useGraphicalTab.
	self top: aTop! !

!ViewerFlapTab methodsFor: 'transition' stamp: 'aoy 2/15/2003 21:19'!
unhibernate
	"recreate my viewer"

	| wasShowing viewer |
	referent ifNotNil: [(referent findA: Viewer) ifNotNil: [^self]].
	wasShowing := flapShowing.
	"guard against not-quite-player-players"
	viewer := ((scriptedPlayer respondsTo: #costume) 
				and: [scriptedPlayer costume isMorph]) 
					ifTrue: [self presenter viewMorph: scriptedPlayer costume]
					ifFalse: [self presenter viewObjectDirectly: scriptedPlayer]. 
	wasShowing ifFalse: [self hideFlap].
	^viewer! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ViewerFlapTab class
	instanceVariableNames: ''!

!ViewerFlapTab class methodsFor: 'new-morph participation' stamp: 'kfr 5/3/2000 12:52'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !


!ViewerFlapTab class methodsFor: 'printing' stamp: 'dgd 8/26/2004 12:12'!
defaultNameStemForInstances
	^ 'viewerFlapTab'! !
AlignmentMorph subclass: #ViewerLine
	instanceVariableNames: 'elementSymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!ViewerLine commentStamp: 'sw 8/28/2004 20:32' prior: 0!
Serves as a wrapper around a line in a Viewer, enforcing the desired layout properties.!


!ViewerLine methodsFor: 'access' stamp: 'sw 10/30/2001 12:43'!
elementSymbol
	"Answer the element symbol"

	^ elementSymbol! !

!ViewerLine methodsFor: 'access' stamp: 'sw 10/30/2001 12:43'!
elementSymbol: aSymbol
	"Set the element symbol"

	elementSymbol _ aSymbol! !

!ViewerLine methodsFor: 'access' stamp: 'sw 5/25/2001 10:36'!
entryType
	"Answer one of: #systemSlot #userSlot #systemScript #userScript"

	^ self playerBearingCode elementTypeFor: elementSymbol vocabulary: self currentVocabulary! !

!ViewerLine methodsFor: 'access' stamp: 'yo 4/6/2005 14:59'!
firstMorphBearingKedamaPlayer

	self allMorphsWithPlayersDo: [:e :p | (p isKindOf: KedamaExamplerPlayer) ifTrue: [^ e]].
	^ nil.
! !

!ViewerLine methodsFor: 'access' stamp: 'yo 4/1/2005 09:39'!
morphBearingPlayer

	self allMorphsWithPlayersDo:[:e :p | ^ e].
	^ nil.
! !

!ViewerLine methodsFor: 'access' stamp: 'yo 4/1/2005 10:55'!
morphsBearingPlayers

	| c |
	c _ OrderedCollection new.
	self allMorphsWithPlayersDo: [:e :p | c add: e].
	^ c asArray.
! !

!ViewerLine methodsFor: 'access' stamp: 'yo 4/1/2005 09:57'!
playerBearingCode

	self allMorphsWithPlayersDo: [:e :p | ^ e playerBearingCode].
	^ nil.
! !

!ViewerLine methodsFor: 'access' stamp: 'yo 4/6/2005 14:59'!
replacePlayerInReadoutWith: aPlayer 

	| tile |
	tile _ self firstMorphBearingKedamaPlayer.
	tile ifNil: [^ self].
	(tile isMemberOf: TileMorph) ifFalse: [^ self].
	tile type = #objRef ifFalse: [^ self].
	tile referToSimilarObject: aPlayer.

	self allMorphsDo: [:e |
		((e isMemberOf: UpdatingStringMorph) or: [e isMemberOf: UpdatingRectangleMorph]) ifTrue: [
			e target isPlayerLike ifTrue: [
				e target: aPlayer
			].
		].
	].! !

!ViewerLine methodsFor: 'access' stamp: 'yo 4/6/2005 14:59'!
replacePlayerWith: aPlayer

	| tile |
	tile _ self firstMorphBearingKedamaPlayer.
	tile ifNil: [^ self].
	(tile isMemberOf: TileMorph) ifFalse: [^ self].
	tile type = #objRef ifFalse: [^ self].
	tile referToSimilarObject: aPlayer.
! !


!ViewerLine methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:32'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 1.0
		g: 0.985
		b: 0.985! !

!ViewerLine methodsFor: 'initialization' stamp: 'sw 8/28/2004 20:30'!
initialize
	"Initialize the receiver"

	super initialize.
	self layoutInset: 0.
	self minCellSize: (0 @ (Preferences standardEToysFont height rounded + 10))! !


!ViewerLine methodsFor: 'slot' stamp: 'sw 6/6/2003 21:47'!
addCommandFeedback
	"Add screen feedback showing what would be torn off in a drag"

	| aMorph |
	aMorph _ RectangleMorph new bounds: ((submorphs fourth topLeft - (2@1)) corner: (submorphs last bottomRight) + (2@0)).
	aMorph useRoundedCorners; beTransparent; borderWidth: 2; borderColor: (Color r: 1.0 g: 0.548 b: 0.452); lock.
	aMorph setProperty: #highlight toValue: true.
	ActiveWorld addMorphFront: aMorph! !

!ViewerLine methodsFor: 'slot' stamp: 'sw 8/31/2004 23:50'!
addGetterFeedback
	"Add feedback during mouseover of a getter"

	| aMorph endMorph |
	endMorph _
		(#(touchesA: #seesColor: #overlaps:) includes: self elementSymbol)
			ifTrue:
				[submorphs eighth]
			ifFalse:
				[submorphs sixth].
	aMorph _ RectangleMorph new useRoundedCorners bounds: ((submorphs fourth topLeft - (2@-1)) corner: (endMorph bottomRight + (2@-1))).
	aMorph beTransparent; borderWidth: 2; borderColor: (Color r: 1.0 g: 0.355 b: 0.839); lock.
	aMorph setProperty: #highlight toValue: true.
	ActiveWorld addMorphFront: aMorph

"
Color fromUser (Color r: 1.0 g: 0.355 b: 0.839)
"! !

!ViewerLine methodsFor: 'slot' stamp: 'sw 5/22/2003 04:30'!
addSetterFeedback
	"Add screen feedback showing what would be torn off to make a setter"

	| aMorph |
	aMorph _ RectangleMorph new bounds: ((submorphs fourth topLeft - (2@1)) corner: (submorphs last bottomRight) + (2@0)).
	aMorph useRoundedCorners; beTransparent; borderWidth: 2; borderColor: (Color r: 1.0 g: 0.548 b: 0.452); lock.
	aMorph setProperty: #highlight toValue: true.
	ActiveWorld addMorphFront: aMorph! !

!ViewerLine methodsFor: 'slot' stamp: 'sw 6/4/2003 02:36'!
removeGetterFeedback
	"Remove any existing getter feedback.  Backward-compatibility only"

	self removeHighlightFeedback! !

!ViewerLine methodsFor: 'slot' stamp: 'sw 6/4/2003 02:30'!
removeHighlightFeedback
	"Remove any existing highlight feedback"

	(ActiveWorld submorphs select: [:m | m hasProperty: #highlight]) do:
		[:m | m delete]! !

!ViewerLine methodsFor: 'slot' stamp: 'sw 6/4/2003 02:37'!
removeSetterFeedback
	"Remove any existing setter feedback"

	self removeHighlightFeedback  "backward compatibility with previously-launched viewer panes only"! !

!ViewerLine methodsFor: 'slot' stamp: 'sw 10/30/2001 11:46'!
slotName
	"Assuming the receiver represents a slot, return its name"

	^  self elementSymbol! !
AlignmentMorph subclass: #ViewerRow
	instanceVariableNames: 'elementSymbol'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!

!ViewerRow methodsFor: 'access' stamp: 'sw 2/1/1999 13:00'!
elementSymbol
	^ elementSymbol! !

!ViewerRow methodsFor: 'access' stamp: 'sw 1/13/1999 12:47'!
elementSymbol: aSymbol
	elementSymbol _ aSymbol! !

!ViewerRow methodsFor: 'access' stamp: 'sw 5/25/2001 10:36'!
entryType
	"Answer one of: #systemSlot #userSlot #systemScript #userScript"

	^ self playerBearingCode elementTypeFor: elementSymbol vocabulary: self currentVocabulary! !

!ViewerRow methodsFor: 'access' stamp: 'sw 12/28/1998 13:10'!
playerBearingCode
	^ owner playerBearingCode! !


!ViewerRow methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:44'!
initialize
	super initialize.
	self layoutInset: 1! !
SmallLandColorTheme subclass: #VioletSmallLandColorTheme
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!VioletSmallLandColorTheme methodsFor: 'as yet unclassified' stamp: 'dgd 3/12/2006 13:56'!
baseColors
	" 
	VioletSmallLandColorTheme apply.
	"
	^ Array
		with: (Color fromArray: #(0.6 0.0 1.0 ))
		with: (Color fromArray: #(0.8 0.4 1.0 ))
		with: (Color fromArray: #(0.95 0.95 1.0 ))! !
ObjectWithDocumentation subclass: #Vocabulary
	instanceVariableNames: 'vocabularyName categories methodInterfaces object limitClass translationTable'
	classVariableNames: 'AllStandardVocabularies LanguageSymbols LanguageTable'
	poolDictionaries: ''
	category: 'Protocols-Kernel'!
!Vocabulary commentStamp: '<historical>' prior: 0!
Vocabulary

vocabularyName	a Symbol -- the formal name by which this vocabulary is known.
categories			a list of ElementCategory objects: the categories that comprise the vocabulary
methodInterfaces 	an IdentityDictionary; keys are method selectors, values are MethodInterfaces

A Vocabulary can be either be *abstract*, i.e. associated with a *class*, or it can be *bound to an instance*.  The form that is bound to an instance is still in its infancy however.

object				in the *bound* form, an actual object is associated with the vocabulary
limitClass			in the *bound* form, an actual limit class is assocaited with the vocabulary

AllMethodInterfaces	This class variable is available to hold on to all method interfaces
						defined in the system, regardless of class.  Not deployed in 
						the first version of this code to be circulated externally.

AllVocabularies		A dictionary associating symbols with actual abstract vocabulary instances

------
Hints on making a vocabulary for a new foreign language.  You need build a method like #addGermanVocabulary.  Execute

	Transcript show: Vocabulary eToyVocabulary strings.

and copy the text from the transcript to the method you are building.
	A cheap trick to get started is to use a web site that translates.  Here is how.  For an entry like:  

(clearTurtleTrails			'clear pen trails'			'Clear all the pen trails in the interior.')

	substitute exclamation points for single quotes by using Alt-shift-j.  Most of the statements are imperatives.

(clearOwnersPenTrails !!clear all pen trails!! !!clear all pen trails in my containing play field!!) 

	This translates to

(ClearOwnersPenTrails!! reinigt allen Kugelschreiber verfolgt!! !! Reinigt allen Kugelschreiber Pfade in meinem enthaltenden Spiel Feld sind!!) 

	Which is laughable, and will certainly stimulate the author to improve it.
------!


!Vocabulary methodsFor: 'initialization' stamp: 'sw 1/26/2001 23:03'!
addCategoryNamed: aCategoryName
	"Add a category of the given name to my categories list,"

	categories add: (ElementCategory new categoryName: aCategoryName asSymbol)! !

!Vocabulary methodsFor: 'initialization' stamp: 'sw 12/11/2000 15:31'!
addCategory: aCategory
	"Add the given category to my categories list"

	categories add: aCategory! !

!Vocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
addFromTable: aTable
	"Add each method-specification tuples, each of the form:
		(1)	selector
		(2)	companion setter selector (#none or nil indicate none)
		(3)  argument specification array, each element being an array of the form
				<arg name>  <arg type>
		(4)  result type, (#none or nil indicate none)
		(5)  array of category symbols, i.e. the categories in which this element should appear.
		(6)  help message. (optional)
		(7)  wording (optional)
		(8)  auto update flag (optional) - if #updating, set readout to refetch automatically

	Make new categories as needed.
	Consult Vocabulary class.initializeTestVocabulary for an example of use"
				
	| aMethodCategory aMethodInterface aSelector doc wording |
	aTable do:
		[:tuple |   tuple fifth do: [:aCategorySymbol |
			(aMethodCategory := self categoryAt: aCategorySymbol) ifNil: [ 
					aMethodCategory := ElementCategory new categoryName: aCategorySymbol.
					self addCategory: aMethodCategory].		
		
			aMethodInterface := MethodInterface new.
			aSelector := tuple first.
			aMethodInterface selector: aSelector type: tuple fourth setter: tuple second.
			aMethodCategory elementAt: aSelector put: aMethodInterface.
			self atKey: aSelector putMethodInterface: aMethodInterface.
			((tuple third ~~ #none) and: [tuple third isEmptyOrNil not])
				ifTrue:
					[aMethodInterface argumentVariables: (tuple third collect:
						[:pair | Variable new name: pair first type: pair second])].

		
			doc := (tuple size >= 6 and: [(#(nil none unused) includes: tuple sixth) not])
				ifTrue:
					[tuple sixth]
				ifFalse:
					[nil].
			wording := (tuple size >= 7 and: [(#(nil none unused) includes: tuple seventh) not])
				ifTrue:
					[tuple seventh]
				ifFalse:
					[aSelector].
			aMethodInterface
				wording: wording;
				helpMessage: doc.
			tuple size >= 8 ifTrue:
				[aMethodInterface setToRefetch]]].
! !

!Vocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	vocabularyName := #unnamed.
	categories := OrderedCollection new.
	methodInterfaces := IdentityDictionary new! !

!Vocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initializeFor: anObject
	"Initialize the receiver to bear a vocabulary suitable for anObject"

	object := anObject.
	vocabularyName := #unnamed.
	categories := OrderedCollection new.
	methodInterfaces := IdentityDictionary new.
	self documentation: 'A vocabulary that has not yet been documented'.
! !

!Vocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
initializeFromTable: aTable
	"Initialize the receiver from a list of method-specification tuples, each of the form:
		(1)	selector
		(2)	companion setter selector (#none or nil indicate none)
		(3)  argument specification array, each element being an array of the form
				<arg name>  <arg type>
		(4)  result type, (#none or nil indicate none)
		(5)  array of category symbols, i.e. the categories in which this element should appear.
		(6)  help message. (optional)
		(7)  wording (optional)
		(8)  auto update flag (optional) - if #updating, set readout to refetch automatically

	Consult Vocabulary class.initializeTestVocabulary for an example of use"
				
	|  aMethodCategory categoryList aMethodInterface aSelector doc wording |
	categoryList := Set new.
	aTable do:
		[:tuple | categoryList addAll: tuple fifth].
	categoryList := categoryList asSortedArray.
	categoryList do:
		[:aCategorySymbol |
			aMethodCategory := ElementCategory new categoryName: aCategorySymbol.
			aTable do:
				[:tuple | (tuple fifth includes: aCategorySymbol) ifTrue:
					[aMethodInterface := MethodInterface new.
					aSelector := tuple first.
					aMethodInterface selector: aSelector type: tuple fourth setter: tuple second.
					aMethodCategory elementAt: aSelector put: aMethodInterface.
					self atKey: aSelector putMethodInterface: aMethodInterface.
					((tuple third ~~ #none) and: [tuple third isEmptyOrNil not])
						ifTrue:
							[aMethodInterface argumentVariables: (tuple third collect:
								[:pair | Variable new name: pair first type: pair second])].
					doc := (tuple size >= 6 and: [(#(nil none unused) includes: tuple sixth) not])
						ifTrue:
							[tuple sixth]
						ifFalse:
							[nil].
 					wording := (tuple size >= 7 and: [(#(nil none unused) includes: tuple seventh) not])
						ifTrue:
							[tuple seventh]
						ifFalse:
							[aSelector asString].
					aMethodInterface
						wording: wording;
						helpMessage: doc.
					tuple size >= 8 ifTrue:
						[aMethodInterface setToRefetch]]].
			self addCategory: aMethodCategory]! !

!Vocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
renameCategoryFrom: oldName to: newName
	"Rename the category currently known by oldName to be newName.  No senders at present but once a UI is establshed for renaming categories, this will be useful."

	| aCategory |
	(aCategory := self categoryAt: oldName) ifNil: [^ self].
	aCategory categoryName: newName! !

!Vocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
strings
	| strm |
	"Get started making a vocabulary for a foreign language.  That is, build a method like #addGermanVocabulary, but for another language.  
	Returns this vocabulary in the same form used as the input used for foreign languages.  To avoid string quote problems, execute
	Transcript show: Vocabulary eToyVocabulary strings.
and copy the text from the transcript to the method you are building."

	"selector		wording			documentation"

strm := WriteStream on: (String new: 400).
methodInterfaces keys asSortedCollection do: [:sel |
	strm cr; nextPut: $(;
		nextPutAll: sel; tab; tab; tab; nextPut: $';
		nextPutAll: (methodInterfaces at: sel) wording;
		nextPut: $'; tab; tab; tab; nextPut: $';
		nextPutAll: (methodInterfaces at: sel) documentation;
		nextPut: $'; nextPut: $)].
^ strm contents! !

!Vocabulary methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
vocabularyName: aName
	"Set the name of the vocabulary as indicated"

	vocabularyName := aName! !


!Vocabulary methodsFor: 'method list' stamp: 'sw 11/13/2001 09:34'!
phraseSymbolsToSuppress
	"Answer a dictatorially-imposed list of phrase-symbols that are to be suppressed from viewers, even if they otherwise show up.  Note that EToyVocabulary reimplements"

	^ #()! !


!Vocabulary methodsFor: 'printing' stamp: 'sw 12/1/2000 22:05'!
printOn: aStream
	"Append to the argument, aStream, a sequence of characters that   identifies the receiver."

	super printOn: aStream.
	vocabularyName ifNotNil: [aStream nextPutAll: ' named "', vocabularyName, '"']! !


!Vocabulary methodsFor: 'queries' stamp: 'sw 1/30/2001 16:31'!
allCategoryName
	"Answer the name by which the 'all' category is known.  This is redundant with two other things, including ClassOrganizer allCategory, at the moment -- should be cleaned up someday."

	^ '-- all --' asSymbol! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 2/24/2001 01:02'!
allMethodsInCategory: categoryName 
	"Answer a list of methods in the category of the given name"

	^ self allMethodsInCategory: categoryName forInstance: object ofClass: object class! !

!Vocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
	"Answer a list of all methods in the etoy interface which are in the given category, on behalf of aClass and possibly anObject.  Note that there is no limitClass at play here."

	| aCategory |
	categoryName ifNil: [^ OrderedCollection new].
	categoryName = self allCategoryName ifTrue:
		[^ methodInterfaces collect: [:anInterface | anInterface selector]].

	aCategory := categories detect: [:cat | cat categoryName == categoryName asSymbol] ifNone: [^ OrderedCollection new].
	^ aCategory elementsInOrder collect: [:anElement | anElement selector] thenSelect:
			[:aSelector | aClass canUnderstand: aSelector]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/26/2001 16:22'!
allSelectorsInVocabulary
	"Answer a list of all selectors in the vocabulary"

	^ methodInterfaces collect: [:m | m selector]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 9/27/2001 17:47'!
asSymbol
	"Answer a symbol representing the receiver"

	^ self vocabularyName! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 9/13/2001 14:29'!
atKey: aKey putMethodInterface: anInterface
	"Place the given interface at the given key."

	methodInterfaces at: aKey put: anInterface! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/13/2000 20:02'!
categories
	"Answer a list of the categories in the receiver"

	^ categories! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/12/2000 06:13'!
categoriesContaining: aSelector forClass: aClass
	"Answer a list of categories that include aSelector"

	^ self categories select:
		[:aCategory | aCategory includesKey: aSelector]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/11/2000 15:31'!
categoryAt: aSymbol
	"Answer the category which has the given symbol as its categoryName, else nil if none found"

	^ categories detect: [:aCategory | aCategory categoryName == aSymbol] ifNone: [nil]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/30/2001 16:31'!
categoryCommentFor: aCategoryName
	"Answer diocumentation for the given category name, a symbol"

	categories do:
		[:cat | cat categoryName == aCategoryName ifTrue: [^ cat documentation]].

	aCategoryName = self allCategoryName ifTrue:
		[^ 'Shows all methods, whatever other categories they may belong to'].
	#(
	(all					'Danger!! An old designation that usually does NOT include all of anything!!')
	('as yet unclassified'	'Methods not yet given a specific classification in some class in which they are implemented')
	(private				'Methods that should only be called by self'))

		do:
			[:pair | pair first = aCategoryName ifTrue: [^ pair second]].

	^ aCategoryName, ' is a category that currently has no documentation'
! !

!Vocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoryList
	"Answer the category list considering only code implemented in my 
	limitClass and lower. This variant is used when the limitClass and 
	targetObjct are known"
	| classToUse foundAMethod classThatImplements |
	classToUse := object class.
	^ categories
		select: [:aCategory | 
			foundAMethod := false.
			aCategory elementsInOrder
				do: [:aSpec | 
					classThatImplements := classToUse whichClassIncludesSelector: aSpec selector.
					(classThatImplements notNil
							and: [classThatImplements includesBehavior: limitClass])
						ifTrue: [foundAMethod := true]].
			foundAMethod]
		thenCollect: [:aCategory | aCategory categoryName]! !

!Vocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoryListForInstance: targetObject ofClass: aClass limitClass: mostGenericClass 
	"Answer the category list for the given instance (may be nil) of the 
	given class, considering only code implemented in mostGenericClass and 
	lower "
	| classToUse foundAMethod classThatImplements |
	classToUse := targetObject
				ifNil: [aClass]
				ifNotNil: [targetObject class].
	^ categories
		select: [:aCategory | 
			foundAMethod := false.
			aCategory elementsInOrder
				do: [:aSpec | 
					classThatImplements := classToUse whichClassIncludesSelector: aSpec selector.
					(classThatImplements notNil
							and: [classThatImplements includesBehavior: mostGenericClass])
						ifTrue: [foundAMethod := true]].
			foundAMethod]
		thenCollect: [:aCategory | aCategory categoryName]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 9/12/2001 22:43'!
categoryWhoseTranslatedWordingIs: aWording
	"Answer the category whose translated is the one provided, or nil if none"

	^ self categories detect: [:aCategory | aCategory wording = aWording] ifNone: [nil]
! !

!Vocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: targetInstance ofClass: targetClass
	"Answer the name of a category, from among the provided categoryNames, which defines the selector for the given class.  Note reimplementor"

	| itsName |
	self categories do:
		[:aCategory | ((categoryNames includes: (itsName := aCategory categoryName)) and:  [aCategory includesKey: aSelector])
			ifTrue:
				[^ itsName]].
	^ nil! !

!Vocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
categoryWordingAt: aSymbol
	"Answer the wording for the category at the given symbol"

	| result |
	result := self categoryAt: aSymbol.
	^result
		ifNotNil: [result wording]
		ifNil: [aSymbol]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/14/2000 05:55'!
classToUseFromInstance: anInstance ofClass: aClass
	"A small convenience to assist in complications arising because an instance is sometimes provided and sometimes not"

	^ anInstance ifNotNil: [anInstance class] ifNil: [aClass]
! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/12/2000 06:06'!
encompassesAPriori: aClass
	"Answer whether the receiver  a priori encompasses aClass -- see implementors"

	^ false! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 3/20/2001 15:42'!
includesDefinitionForSelector: aSelector
	"Answer whether the given selector is known to the vocabulary.  This is independent of whether its definition lies within the range specified by my limitClass.  Answer whether the given selector is known to the vocabulary.  Unsent at the moment, may disappear."

	^ methodInterfaces includesKey: aSelector! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/1/2000 21:57'!
includesSelector: aSelector
	"Answer whether the given selector is known to the vocabulary"

	^ methodInterfaces includesKey: aSelector! !

!Vocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
	"Answer whether the vocabulary includes the given selector for the given class (and instance, if provided), only considering method implementations in mostGenericClass and lower"

	| classToUse aClass |

	(methodInterfaces includesKey: aSelector) ifFalse: [^ false].
	classToUse := self classToUseFromInstance: anInstance ofClass: aTargetClass.
	^ (aClass := classToUse whichClassIncludesSelector: aSelector)
		ifNil:
			[false]
		ifNotNil:
			[(aClass includesBehavior: mostGenericClass) and:
				[(self someCategoryThatIncludes: aSelector) notNil]]
! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 2/23/2001 23:30'!
methodInterfaceAt: aSelector ifAbsent: aBlock
	"Answer the vocabulary's method interface for the given selector; if absent, return the result of evaluating aBlock"

	^ methodInterfaces at: aSelector ifAbsent: [aBlock value]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 8/11/2002 02:25'!
methodInterfaceForSelector: aSelector class: aClass
	"Answer a method interface for the selector"

	^ self methodInterfaceAt: aSelector ifAbsent:
		[MethodInterface new conjuredUpFor: aSelector class: aClass]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 5/25/2001 10:42'!
methodInterfacesDo: aBlock
	"Evaluate aBlock on behalf, in turn, of each of my methodInterfaces"

	methodInterfaces do: aBlock

	! !

!Vocabulary methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
methodInterfacesInCategory: categoryName forInstance: anObject ofClass: aClass limitClass: aLimitClass
	"Answer a list of method interfaces of all methods in the given category, provided they are implemented no further away than aLimitClass."

	| defClass |
	^ ((self allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass) collect:
		[:sel | methodInterfaces at: sel ifAbsent:
			[MethodInterface new conjuredUpFor: sel class: aClass]]) select:
				[:aMethodInterface |
					defClass := aClass whichClassIncludesSelector: aMethodInterface selector.
					(defClass notNil and: [defClass includesBehavior: aLimitClass])]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 9/27/2001 03:24'!
representsAType
	"Answer whether this vocabulary represents an end-user-sensible data type"

	^ false! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 3/19/2001 23:55'!
someCategoryThatIncludes: aSelector
	"Answer the name of a category that includes the selector, nil if none"

	^ categories detect: [:c | c includesKey: aSelector] ifNone: [nil]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/1/2000 22:05'!
vocabularyName
	"Answer the name of the vocabulary"

	^ vocabularyName! !


!Vocabulary methodsFor: 'translation' stamp: 'tak 8/8/2005 12:52'!
translatedWordingFor: aSymbol
	"If I have a translated wording for aSymbol, return it, else return aSymbol.  Caveat: at present, this mechanism is only germane for *assignment-operator wordings*"

	#(: Incr: Decr: Mult:) with: #('' 'increase by' 'decrease by' 'multiply by') do:
		[:a :b | aSymbol = a ifTrue: [^ b translated]].

	^ aSymbol translated! !

!Vocabulary methodsFor: 'translation' stamp: 'sw 5/25/2001 10:45'!
translatedWordingsFor: symbolList
	"Answer a list giving the translated wordings for the input list. Caveat: at present, this mechanism is only germane for *categories*"

	^ symbolList collect: [:sym | self translatedWordingFor: sym]
! !

!Vocabulary methodsFor: 'translation' stamp: 'yo 7/2/2004 21:51'!
translationKeyFor: translatedWording

	self flag: #yo.
	^ translatedWording.
! !

!Vocabulary methodsFor: 'translation' stamp: 'mir 7/13/2004 00:42'!
translationTable
	^translationTable ifNil: [ElementCategory new]! !


!Vocabulary methodsFor: '*eToys-color' stamp: 'sw 9/27/2001 17:47'!
subduedColorFrom: aColor
	"Answer a subdued color derived from the given color"

	^ aColor mixed: ScriptingSystem colorFudge with: ScriptingSystem uniformTileInteriorColor! !


!Vocabulary methodsFor: '*eToys-queries' stamp: 'yo 2/19/2005 23:41'!
tileWordingForSelector: aSelector
	"Answer the wording to emblazon on tiles representing aSelector"

	| anInterface inherent |
	anInterface _ self methodInterfaceAt: aSelector asSymbol ifAbsent:
		[inherent _ Utilities inherentSelectorForGetter: aSelector.
		^ inherent
			ifNil:
				[self translatedWordingFor: aSelector]
			ifNotNil:
				[inherent translated]].
	^ anInterface wording! !

!Vocabulary methodsFor: '*eToys-queries' stamp: 'sw 9/26/2001 12:01'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFrom: Color green! !


!Vocabulary methodsFor: '*flexibleVocabularies-flexibleVocabularies-testing' stamp: 'nk 9/1/2004 08:42'!
isEToyVocabulary
	^false! !


!Vocabulary methodsFor: 'private' stamp: 'mir 7/15/2004 19:27'!
setCategoryStrings: categoryTriplets
	"Establish the category strings as per (internalCategorySymbol newCategoryWording balloon-help)"

	| category |
	categoryTriplets do:
		[:triplet |
			(category := self categoryAt: triplet first) ifNotNil: [
				category wording: triplet second.
				category helpMessage: triplet third]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Vocabulary class
	instanceVariableNames: ''!

!Vocabulary class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:39'!
embraceAddedTypeVocabularies
	"If there are any type-vocabulary subclases not otherwise accounted for, acknowledge them at this time"

	| vocabulary |
	DataType allSubclasses do:
		[:dataType |
			vocabulary := dataType new.
			vocabulary representsAType
				ifTrue: [(self allStandardVocabularies includesKey: vocabulary vocabularyName)
					ifFalse: 	[self addStandardVocabulary: vocabulary]]]! !

!Vocabulary class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 19:10'!
initialize
	"Initialize a few standard vocabularies and place them in the AllVocabularies list.  Call this to update all vocabularies."

	self initializeStandardVocabularies.
	self embraceAddedTypeVocabularies.

	"Vocabulary initialize"

! !

!Vocabulary class methodsFor: 'class initialization' stamp: 'sw 3/11/2003 12:36'!
initializeSilently
	"Initialize a few standard vocabularies and place them in the AllVocabularies list."

	self initializeStandardVocabularies.
	self embraceAddedTypeVocabularies.

	"Vocabulary initializeSilently"

! !

!Vocabulary class methodsFor: 'class initialization' stamp: 'yo 3/24/2005 13:21'!
initializeStandardVocabularies
	"Initialize a few standard vocabularies and place them in the AllStandardVocabularies list."

	AllStandardVocabularies _ nil.

	self addStandardVocabulary: EToyVocabulary new.
	self addStandardVocabulary: EToyVectorVocabulary new.

	self addStandardVocabulary: self newPublicVocabulary.
	self addStandardVocabulary: FullVocabulary new.

	self addStandardVocabulary: self newQuadVocabulary.

	self addStandardVocabulary: ColorType new.
	self addStandardVocabulary: BooleanType new.
	self addStandardVocabulary: GraphicType new.
	self addStandardVocabulary: PlayerType new.
	self addStandardVocabulary: SoundType new.
	self addStandardVocabulary: StringType new.
	self addStandardVocabulary: MenuType new.
	self addStandardVocabulary: UnknownType new.
	self addStandardVocabulary: ScriptNameType new.

	self addStandardVocabulary: (SymbolListType new symbols: #(simple raised inset complexFramed complexRaised complexInset complexAltFramed complexAltRaised complexAltInset); vocabularyName: #BorderStyle; yourself).
	self addStandardVocabulary: (SymbolListType new symbols: #(lines arrows arrowheads dots); vocabularyName: #TrailStyle; yourself).
	self addStandardVocabulary: (SymbolListType new symbols: #(leftToRight rightToLeft topToBottom bottomToTop); vocabularyName: #ListDirection; yourself).

	self addStandardVocabulary: (SymbolListType new symbols: #(topLeft bottomRight center justified); vocabularyName: #ListCentering; yourself).

	self addStandardVocabulary: (SymbolListType new symbols: #(buttonDown whilePressed buttonUp); vocabularyName: #ButtonPhase; yourself).

	self addStandardVocabulary: (SymbolListType new symbols: #(rotate #'do not rotate' #'flip left right' #'flip up down'); vocabularyName: #RotationStyle; yourself).

	self addStandardVocabulary: (SymbolListType new symbols: #(rigid spaceFill shrinkWrap); vocabularyName: #Resizing; yourself).

	self addStandardVocabulary: self newSystemVocabulary.  "A custom vocabulary for Smalltalk -- still under development)"

	self numberVocabulary.  		"creates and adds it"
	self wonderlandVocabulary.  	"creates and adds it"
	self vocabularyForClass: Time.   "creates and adds it"

	self addStandardVocabulary: (KedamaPatchType new vocabularyName: #Patch; yourself).
	self addStandardVocabulary: (SymbolListType new symbols: #(wrap stick bouncing); vocabularyName: #EdgeMode; yourself).
	self addStandardVocabulary: (SymbolListType new symbols: #(logScale linear color); vocabularyName: #PatchDisplayMode; yourself).

	"Vocabulary initialize"! !


!Vocabulary class methodsFor: 'eToy vocabularies' stamp: 'sw 1/6/2005 04:28'!
gettersForbiddenFromWatchers
	"Answer getters that should not have watchers launched to them"

	^ #(colorSees copy isOverColor: seesColor: newClone getNewClone color:sees: touchesA: overlaps: overlapsAny:)! !

!Vocabulary class methodsFor: 'eToy vocabularies' stamp: 'stephaneducasse 2/4/2006 20:39'!
newSystemVocabulary
	"Answer a Vocabulary object representing significant requests one can make to the Smalltalk object"

	| aVocabulary |
	aVocabulary := self new.

	aVocabulary vocabularyName: #System.
	aVocabulary documentation: 'Useful messages you might want to send to the current Smalltalk image'.
	aVocabulary initializeFromTable:  #(
(aboutThisSystem none () none (basic queries) 'put up a message describing the system' unused)
(saveAsNewVersion none () none (services) 'advance to the next available image-version number and save the image under that new name' unused znak)
(datedVersion none () String (queries) 'the version of the Squeak system')
(endianness none () String (queries) 'big or little - the byte-ordering of the hardware Squeak is currently running on')
(exitToDebugger none () none (dangerous) 'exits to the host debugger.  Do not use this -- I guarantee you will be sorry.')
(bytesLeft none () Number (basic services) 'perform a garbage collection and answer the number of bytes of free space remaining in the system')
"(browseAllCallsOn: none ((aSelector String)) none (#'queries') 'browse all calls on a selector')
(browseAllImplementorsOf: none ((aSelector String)) none (#'queries') 'browse all implementors of a selector')"

"(allMethodsWithSourceString:matchCase: none ((aString String) (caseSensitive Boolean)) none (queries) 'browse all methods that have the given source string, making the search case-sensitive or not depending on the argument provided.')

(browseMethodsWithString:matchCase: none ((aString String) (caseSensitive Boolean)) none (queries) 'browse all methods that contain the given string in any string literal, making the search case-sensitive or not depending on the argument provided.')

(browseAllImplementorsOf:localTo: none ((aSelector String) (aClass Class)) none (#'queries') 'browse all implementors of a selector that are local to a class')"

).
"(isKindOf: none 	((aClass Class)) Boolean (#'class membership') 'answer whether the receiver''s superclass chain includes aClass')"
	^ aVocabulary

"Vocabulary initialize"
"Vocabulary addStandardVocabulary: Vocabulary newSystemVocabulary"

"SmalltalkImage current basicInspect"
"SmalltalkImage current beViewed"
! !


!Vocabulary class methodsFor: 'queries' stamp: 'stephaneducasse 2/4/2006 20:39'!
instanceWhoRespondsTo: aSelector 
	"Find the most likely class that responds to aSelector. Return an instance 
	of it. Look in vocabularies to match the selector."
	"Most eToy selectors are for Players"
	| mthRefs |
	((self vocabularyNamed: #eToy)
			includesSelector: aSelector)
		ifTrue: [aSelector == #+
				ifFalse: [^ Player new costume: Morph new]].
	"Numbers are a problem"
	((self vocabularyNamed: #Number)
			includesSelector: aSelector)
		ifTrue: [^ 1].
	"Is a Float any different?"
	"String Point Time Date"
	#()
		do: [:nn | ((self vocabularyNamed: nn)
					includesSelector: aSelector)
				ifTrue: ["Ask Scott how to get a prototypical instance"
					^ (Smalltalk at: nn) new]].
	mthRefs := self systemNavigation allImplementorsOf: aSelector.
	"every one who implements the selector"
	mthRefs
		sortBlock: [:a :b | (Smalltalk at: a classSymbol) allSuperclasses size < (Smalltalk at: b classSymbol) allSuperclasses size].
	mthRefs size > 0
		ifTrue: [^ (Smalltalk at: mthRefs first classSymbol) new].
	^ Error new! !


!Vocabulary class methodsFor: 'standard vocabulary access' stamp: 'mir 7/15/2004 10:55'!
addStandardVocabulary: aVocabulary
	"Add a vocabulary to the list of standard vocabularies"

	self allStandardVocabularies at: aVocabulary vocabularyName put: aVocabulary! !

!Vocabulary class methodsFor: 'standard vocabulary access' stamp: 'stephaneducasse 2/4/2006 20:39'!
allStandardVocabularies
	"Answer a list of the currently-defined vocabularies in my AllStandardVocabularies list"
	"Vocabulary allStandardVocabularies"

	^AllStandardVocabularies ifNil: [AllStandardVocabularies := IdentityDictionary new].

! !

!Vocabulary class methodsFor: 'standard vocabulary access' stamp: 'stephaneducasse 2/4/2006 20:39'!
newTimeVocabulary
	"Answer a Vocabulary object representing me" 
	| aVocabulary aMethodCategory aMethodInterface |
	"Vocabulary newTimeVocabulary"
	"Vocabulary addStandardVocabulary: Vocabulary newTimeVocabulary"

	aVocabulary := self new vocabularyName: #Time.
	aVocabulary documentation: 'Time knows about hours, minutes, and seconds.  For long time periods, use Date'.

#((accessing 			'The basic info'
		(hours minutes seconds))
(arithmetic 				'Basic numeric operations'
		(addTime: subtractTime: max: min: min:max:))
(comparing				'Determining which is larger'
		(= < > <= >= ~= between:and:))
(testing 				'Testing'
		(ifNil: ifNotNil:))
(printing 				'Return a string for this Time'
		(hhmm24 print24 intervalString printMinutes printOn:))
(converting 			'Converting it to another form'
		(asSeconds asString))
(copying 				'Make another one like me'
		(copy))
) do: [:item | 
			aMethodCategory := ElementCategory new categoryName: item first.
			aMethodCategory documentation: item second.
			item third do:
				[:aSelector | 
					aMethodInterface := MethodInterface new initializeFor: aSelector.
					aVocabulary atKey: aSelector putMethodInterface: aMethodInterface.
					aMethodCategory elementAt: aSelector put: aMethodInterface].
			aVocabulary addCategory: aMethodCategory].
	#(#addTime: subtractTime: max: min: = < > <= >= ~= ) do: [:sel |
		(aVocabulary methodInterfaceAt: sel ifAbsent: [self error: 'fix this method']) 
			argumentVariables: (OrderedCollection with:
				(Variable new name: nil type: aVocabulary vocabularyName))].
	^ aVocabulary! !

!Vocabulary class methodsFor: 'standard vocabulary access' stamp: 'sw 6/4/2001 16:33'!
vocabularyFrom: aNameOrVocabulary
	"Answer the standard vocabulary of the given name, or nil if none found,  For backward compatibilitythe parameter might be an actual vocabulary, in which case return it"

	(aNameOrVocabulary isKindOf: Vocabulary) ifTrue: [^ aNameOrVocabulary].
	^ self vocabularyNamed: aNameOrVocabulary! !

!Vocabulary class methodsFor: 'standard vocabulary access' stamp: 'nk 8/22/2004 09:24'!
vocabularyNamed: aName
	"Answer the standard vocabulary of the given name, or nil if none found"

	^ self allStandardVocabularies at: aName asSymbol ifAbsent: []! !


!Vocabulary class methodsFor: 'testing and demo' stamp: 'stephaneducasse 2/4/2006 20:39'!
newQuadVocabulary
	"Answer a Quad vocabulary -- something to mess with, to illustrate and explore ideas.  Applies to Quadrangles only."

	| aVocabulary  |
	aVocabulary := Vocabulary new vocabularyName: #Quad.
	aVocabulary documentation: 'A highly restricted test vocabulary that can be used with Quadrangle objects'.
	aVocabulary initializeFromTable:  #(
(borderColor borderColor: () Color (basic color) 'The color of the border' unused updating)
(borderWidth borderWidth: () Number (basic geometry) 'The width of the border' unused updating)
(insideColor insideColor: () Color (basic color) 'The color of the quadrangle' unused updating)
(display none () none (basic display) 'Display the quadrangle directly on the screen')
(width none () Number (geometry) 'The width of the object' unused updating)
(left setLeft: () Number (geometry) 'The left edge' unused updating)
(right setRight: () Number (geometry) 'The right edge' unused updating)
(width setWidth: () Number (geometry) 'The width of the object' unused updating)
(height setHeight: () Number (geometry) 'The height of the object' unused updating)
(hasPositiveExtent none () Boolean (tests) 'Whether the corner is to the lower-right of the origin' unused updating)
(isTall none () Boolean (tests) 'Whether the height is greater than the width' unused updating)).

	^ aVocabulary

"Vocabulary initialize"
"Quadrangle exampleInViewer"! !

!Vocabulary class methodsFor: 'testing and demo' stamp: 'stephaneducasse 2/4/2006 20:39'!
newTestVocabulary
	"Answer a Test vocabulary -- something to mess with, to illustrate and explore ideas."

	| aVocabulary  |
	aVocabulary := Vocabulary new vocabularyName: #Test.
	aVocabulary documentation: 'An illustrative vocabulary for testing'.
	aVocabulary initializeFromTable:  #(
(isKindOf: none 	((aClass Class)) Boolean (#'class membership') 'answer whether the receiver''s superclass chain includes aClass')
(class none none Class (#'class membership' wimpy) 'answer the the class to which the receiver belongs')
(respondsTo: none ((aSelector Symbol))	Boolean (#'class membership') 'answer whether the receiver responds to the given selector')
(as:	none ((aClass Class)) Object (conversion) 'answer the receiver converted to be a member of aClass')).

	^ aVocabulary
"
	#((#'class membership' 	'Whether an object can respond to a given message, etc.' 	(isKindOf: class respondsTo:))
	(conversion 			'Messages to convert from one kind of object to another' 		(as:  asString))
	(copying				'Messages for making copies of objects'						(copy copyFrom:))
	(equality 				'Testing whether two objects are equal' 						( = ~= == ~~))
	(dependents				'Support for dependency notification'						(addDependent: removeDependent: release))) do:

		[:item | 
			aMethodCategory := ElementCategory new categoryName: item first.
			aMethodCategory documentation: item second.
			item third do:
				[:aSelector | 
					aMethodInterface := MethodInterface new initializeFor: aSelector.
					aVocabulary atKey: aSelector putMethodInterface: aMethodInterface.
					aMethodCategory elementAt: aSelector put: aMethodInterface].
			aVocabulary addCategory: aMethodCategory]."
! !

!Vocabulary class methodsFor: 'testing and demo' stamp: 'mir 7/15/2004 10:53'!
quadVocabulary
	"Answer the Quad vocabulary lurking in my AllStandardVocabularies list, creating it if necessary"
	"Vocabulary quadVocabulary"

	^ self allStandardVocabularies at: #Quad ifAbsentPut: [self newQuadVocabulary]! !

!Vocabulary class methodsFor: 'testing and demo' stamp: 'mir 7/15/2004 10:54'!
testVocabulary
	"Answer the Test vocabulary lurking in my AllStandardVocabularies list, creating it if necessary"
	"Vocabulary testVocabulary"

	^ self allStandardVocabularies at: #Test ifAbsentPut: [self newTestVocabulary]! !


!Vocabulary class methodsFor: 'type vocabularies' stamp: 'sw 9/25/2001 20:13'!
newNumberVocabulary
	"Answer a Vocabulary object representing the Number vocabulary to the list of AllVocabularies"

	^ NumberType new! !

!Vocabulary class methodsFor: 'type vocabularies' stamp: 'mir 7/15/2004 10:31'!
numberVocabulary
	"Answer the standard vocabulary representing numbers, creating it if necessary"

	^self allStandardVocabularies at: #Number ifAbsentPut: [self newNumberVocabulary]! !

!Vocabulary class methodsFor: 'type vocabularies' stamp: 'sw 6/14/2005 11:49'!
typeChoices
	"Answer a list of all user-choosable data types"

	| aList |
	(aList _ self allStandardVocabularies
		select:
			[:aVocab | aVocab representsAType]
		thenCollect:
			[:aVocab | aVocab vocabularyName]).
	Preferences allowEtoyUserCustomEvents ifFalse: [aList remove: #CustomEvents ifAbsent: []].
	^ aList asSortedArray! !

!Vocabulary class methodsFor: 'type vocabularies' stamp: 'stephaneducasse 2/4/2006 20:39'!
vocabularyForClass: aClass
	"Answer the standard vocabulary for that class.  Create it if not present and init message exists.  Answer nil if none exists and no init message present."

	| initMsgName newTypeVocab |
	(self allStandardVocabularies includesKey: aClass name)
		ifTrue: [^self allStandardVocabularies at: aClass name].

	initMsgName := ('new', aClass name, 'Vocabulary') asSymbol.
	^(self respondsTo: initMsgName)
		 ifTrue:	[
			newTypeVocab := self perform: initMsgName.
			self addStandardVocabulary: newTypeVocab.
			newTypeVocab]
		ifFalse: [nil]! !

!Vocabulary class methodsFor: 'type vocabularies' stamp: 'stephaneducasse 2/4/2006 20:39'!
vocabularyForType: aType
	"Answer a vocabulary appropriate to the given type, which is normally going to be a symbol such as #Number or #Color.  Answer the Unknown vocabulary as a fall-back"

	| ucSym |
	(aType isKindOf: Vocabulary) ifTrue: [^ aType].
	ucSym := aType capitalized asSymbol.
	^self allStandardVocabularies at: ucSym ifAbsent: [self vocabularyNamed: #unknown]! !


!Vocabulary class methodsFor: 'universal vocabularies' stamp: 'mir 7/15/2004 10:52'!
fullVocabulary
	"Answer the full vocabulary in my AllStandardVocabularies list, creating it if necessary"

	^ self allStandardVocabularies at: #Full ifAbsentPut: [FullVocabulary new]! !

!Vocabulary class methodsFor: 'universal vocabularies' stamp: 'stephaneducasse 2/4/2006 20:39'!
newPublicVocabulary
	| aVocabulary |
	"Answer a public vocabulary"

	aVocabulary := ScreenedVocabulary new.
	aVocabulary vocabularyName: #Public.
	aVocabulary documentation: '"Public" is vocabulary that excludes categories that start with "private" and methods that start with "private" or "pvt"'.

	aVocabulary categoryScreeningBlock: [:aCategoryName | (aCategoryName beginsWith: 'private') not].
	aVocabulary methodScreeningBlock: [:aSelector | 
		((aSelector beginsWith: 'private') or: [aSelector beginsWith: 'pvt']) not].
	^ aVocabulary
! !


!Vocabulary class methodsFor: '*eToys-customevents-custom events' stamp: 'nk 8/18/2004 17:57'!
addCustomEventsVocabulary
	| vocab |
	self addStandardVocabulary: (vocab := self newCustomEventsVocabulary).
	SymbolListTile updateAllTilesForVocabularyNamed: #CustomEvents.
	^vocab! !

!Vocabulary class methodsFor: '*eToys-customevents-custom events' stamp: 'nk 8/21/2004 19:58'!
customEventsVocabulary
	"Vocabulary customEventsVocabulary"
	^(self vocabularyNamed: #CustomEvents)
		ifNil: [ self addCustomEventsVocabulary ]
! !

!Vocabulary class methodsFor: '*eToys-customevents-custom events' stamp: 'nk 8/18/2004 17:56'!
newCustomEventsVocabulary
	^UserCustomEventNameType new.
! !


!Vocabulary class methodsFor: '*eToys-eToy vocabularies' stamp: 'sw 9/13/2001 17:29'!
addEToyVectorVocabulary
	"Add the etoy Vector vocabulary to the standard list"

	AllStandardVocabularies at: #Vector put:  EToyVectorVocabulary new

		 ! !

!Vocabulary class methodsFor: '*eToys-eToy vocabularies' stamp: 'mir 7/15/2004 10:49'!
changeMadeToViewerAdditions
	"A change to some morph-subclass class-side #additionsToViewer... was made, which means that the existing etoy vocabularies need updating."
	"Vocabulary changeMadeToViewerAdditions"

	AllStandardVocabularies
		ifNotNil: [
			self addStandardVocabulary: EToyVocabulary new.
			self addStandardVocabulary: EToyVectorVocabulary new]

	
		 ! !

!Vocabulary class methodsFor: '*eToys-eToy vocabularies' stamp: 'mir 7/15/2004 10:50'!
eToyVocabulary
	"Answer the etoy vocabulary in the AllStandardVocabularies list, creating it if necessary."

	^ self allStandardVocabularies at: #eToy ifAbsentPut: [EToyVocabulary new]! !


!Vocabulary class methodsFor: '*eToys-type vocabularies' stamp: 'mir 7/15/2004 10:54'!
newWonderlandVocabulary
	"Answer a Wonderland vocabulary -- highly experimental"

	| aVocabulary  |
	"Vocabulary newWonderlandVocabulary"
	aVocabulary _ Vocabulary new vocabularyName: #Wonderland.
	aVocabulary documentation: 'A simple vocabulary for scripting Alice objects'.
	aVocabulary initializeFromTable:  #(
		(color color: () Color (basic color) 'The color of the object' unused updating)
		"--"
		(getX setX: () Number (basic geometry) 'The x position' unused updating)
		(getY setY: () Number (basic geometry) 'The y position' unused updating)
		(getZ setZ: () Number (basic geometry) 'The z position' unused updating)
		"--"
		(width setWidth: () Number (geometry) 'The width of the object' unused updating)
		(height setHeight: () Number (geometry) 'The height of the object' unused updating)
		(depth setDepth: () Number (geometry) 'The depth of the object' unused updating)
		"--"
		(heading setHeading: () Number (basic geometry) 'The heading of the object' unused updating)
		(forwardBy: unused ((distance Number)) none (basic motion) 'Moves the object by the specified distance' 'forward by')
		(turnBy: unused ((angle Number)) none (basic motion) 'Turns the object by the specified number of degrees' 'turn by')
		(graphic setGraphic: () Graphic (basic graphics) 'The picture currently being worn' unused updating)
		(animationIndex setAnimationIndex: () Number (graphics) 'The index in the object''s animation chain' unused updating)
		(emptyScript unused () none (scripts) 'The empty script')
		(distanceToCamera setDistanceToCamera: () Number (geometry) 'The distance of the object from the camera' unused updating)
		(distanceTo: unused ((target Player)) Number (geometry) 'The distance of the object to the given target')
	).
	^ aVocabulary! !

!Vocabulary class methodsFor: '*eToys-type vocabularies' stamp: 'mir 7/15/2004 10:55'!
wonderlandVocabulary
	"Answer the Quad vocabulary lurking in my AllStandardVocabularies list, creating it if necessary"
	"Vocabulary newWonderlandVocabulary"

	^ self allStandardVocabularies at: #Wonderland ifAbsentPut: [self newWonderlandVocabulary]! !
Object subclass: #Voice
	instanceVariableNames: 'name sound'
	classVariableNames: 'Voices'
	poolDictionaries: ''
	category: 'Speech-Events'!
!Voice commentStamp: '<historical>' prior: 0!
I am an abstract class for speaking voices that know how to play VoiceEvents.!


!Voice methodsFor: 'accessing' stamp: 'len 6/21/1998 20:07'!
name
	^ name! !

!Voice methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
name: aString
	name := aString! !

!Voice methodsFor: 'accessing' stamp: 'len 9/15/1999 23:54'!
sound
	^ sound! !


!Voice methodsFor: 'converting' stamp: 'len 9/7/1999 01:26'!
+ aVoice
	"Answer the composition of the receiver with the argument."
	^ CompositeVoice new add: self; add: aVoice; yourself! !


!Voice methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:23'!
initialize
	name := 'anonymous'! !


!Voice methodsFor: 'playing' stamp: 'stephaneducasse 2/3/2006 22:23'!
flush
	"Play all the events in the queue."
	sound notNil ifTrue: [sound done: true; play. sound := nil]! !

!Voice methodsFor: 'playing' stamp: 'stephaneducasse 2/3/2006 22:23'!
playBuffer: buffer at: time
	| tail |
	tail := SampledSound samples: buffer samplingRate: self samplingRate.
	sound isNil
		ifTrue: [sound := QueueSound new startTime: time - SoundPlayer bufferMSecs.
				sound add: tail; play]
		ifFalse: [sound add: tail]! !

!Voice methodsFor: 'playing' stamp: 'len 8/28/1999 23:04'!
playGesturalEvent: event at: time
	^ self! !

!Voice methodsFor: 'playing' stamp: 'len 8/28/1999 23:05'!
playPhoneticEvent: event at: time
	^ self! !

!Voice methodsFor: 'playing' stamp: 'len 9/14/1999 00:19'!
playSilenceMSecs: msecs
	Transcript cr; show: 'silence ', msecs printString, 'msecs'.
	sound isNil ifTrue: [^ self].
	sound add: (RestSound dur: msecs / 1000.0)! !

!Voice methodsFor: 'playing' stamp: 'stephaneducasse 2/3/2006 22:23'!
reset
	"Reset the state of the receiver."
	sound notNil ifTrue: [sound done: true. sound := nil]! !


!Voice methodsFor: 'printing' stamp: 'len 8/28/1999 03:04'!
printOn: aStream
	aStream nextPutAll: self class name; nextPutAll: ' ('; nextPutAll: self name; nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Voice class
	instanceVariableNames: ''!

!Voice class methodsFor: 'accessing' stamp: 'len 6/7/1999 01:33'!
addVoice: aVoice
	^ self voices add: aVoice! !

!Voice class methodsFor: 'accessing' stamp: 'len 6/21/1999 00:51'!
doesNotUnderstand: aMessage
	self voices do: [ :each | each name asLowercase = aMessage selector asString ifTrue: [^ each]].
	^ super doesNotUnderstand: aMessage! !

!Voice class methodsFor: 'accessing' stamp: 'len 9/14/1999 00:16'!
named: aString
	^ self voices detect: [ :one | one name = aString]! !

!Voice class methodsFor: 'accessing' stamp: 'len 6/7/1999 01:33'!
voices
	^ Voices! !


!Voice class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/3/2006 22:23'!
initialize
	"
	Voice initialize
	"

	Voices := Set new! !


!Voice class methodsFor: 'instance creation' stamp: 'len 9/13/1999 00:58'!
default
	self voices isEmpty ifTrue: [^ KlattVoice new].
	^ self voices detect: [ :one | one name = 'Kurt']
		ifNone: [self voices detect: [ :one | one samplingRate >= 16000]
					ifNone: [self voices anyOne]]! !
Object subclass: #VoiceEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!
!VoiceEvent commentStamp: '<historical>' prior: 0!
I am an abstract class for all events to be played on speaking Voices, such as PhoneticEvents or GesturalEvents.!


!VoiceEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 03:06'!
duration
	"Answer the duration (in seconds) of the receiver."
	^ 0! !

!VoiceEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 02:18'!
voice
	"Answer the default voice for the receiver."
	^ Voice default! !


!VoiceEvent methodsFor: 'playing' stamp: 'len 8/28/1999 23:11'!
play
	^ self playOn: self voice! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 8/28/1999 23:11'!
playAt: time
	^ self playOn: self voice at: time! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 12/24/1999 02:23'!
playDelayed: delay
	self playAt: Time millisecondClockValue + delay! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 8/28/1999 23:11'!
playOn: aVoice
	self playOn: aVoice at: Time millisecondClockValue! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 8/28/1999 03:54'!
playOn: aVoice at: time
	self subclassResponsibility! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 9/13/1999 00:46'!
playOn: aVoice delayed: delay
	self playOn: aVoice at: Time millisecondClockValue + delay! !


!VoiceEvent methodsFor: 'testing' stamp: 'len 8/29/1999 21:17'!
isGestural
	^ false! !

!VoiceEvent methodsFor: 'testing' stamp: 'len 8/29/1999 21:17'!
isPhonetic
	^ false! !


!VoiceEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:13'!
compress: aNumber
	self stretch: 1.0 / aNumber! !

!VoiceEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:13'!
stretch: aNumber
	^ self! !
Envelope subclass: #VolumeEnvelope
	instanceVariableNames: 'currentVol targetVol mSecsForChange'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
computeSlopeAtMSecs: mSecs
	"Private!! Find the next inflection point of this envelope and compute its target volume and the number of milliseconds until the inflection point is reached."

	| t i |
	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t := (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i := self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i == nil ifTrue: [  "past end"
			targetVol := points last y * decayScale.
			mSecsForChange := 0.
			nextRecomputeTime := mSecs + 1000000.
			^ self].
		targetVol := (points at: i) y * decayScale.
		mSecsForChange := (((points at: i) x - t) min: (endMSecs - mSecs)) max: 4.
		nextRecomputeTime := mSecs + mSecsForChange.
		^ self].

	mSecs < loopStartMSecs ifTrue: [  "attack phase"
		i := self indexOfPointAfterMSecs: mSecs startingAt: 1.
		targetVol := (points at: i) y.
		mSecsForChange := ((points at: i) x - mSecs) max: 4.
		nextRecomputeTime := mSecs + mSecsForChange.
		((loopEndMSecs ~~ nil) and: [nextRecomputeTime > loopEndMSecs])
			ifTrue: [nextRecomputeTime := loopEndMSecs].
		^ self].

	"sustain and loop phase"
	noChangesDuringLoop ifTrue: [
		targetVol := (points at: loopEndIndex) y.
		mSecsForChange := 10.
		loopEndMSecs == nil
			ifTrue: [nextRecomputeTime := mSecs + 10]  "unknown end time"
			ifFalse: [nextRecomputeTime := loopEndMSecs].
		^ self].

	loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y].  "looping on a single point"
	t := loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
	i := self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
	targetVol := (points at: i) y.
	mSecsForChange := ((points at: i) x - t) max: 4.
	nextRecomputeTime := (mSecs + mSecsForChange) min: loopEndMSecs.
! !

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
reset
	"Reset the state for this envelope."

	super reset.
	target initialVolume: points first y * scale.
	nextRecomputeTime := 0.
! !

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 07:27'!
updateSelector
	"Needed by the envelope editor."

	^ #volume:
! !

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
updateTargetAt: mSecs
	"Update the volume envelope slope and limit for my target. Answer false."

	mSecs < nextRecomputeTime ifTrue: [^ false].
	self computeSlopeAtMSecs: mSecs.
	mSecsForChange < 5 ifTrue: [mSecsForChange := 5].  "don't change instantly to avoid clicks"
	target adjustVolumeTo: targetVol * scale overMSecs: mSecsForChange.
	^ false
! !

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:41'!
volume: aNumber
	"Set the maximum volume of a volume-controlling envelope."

	scale := aNumber asFloat.
! !
Notification subclass: #Warning
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!Warning commentStamp: '<historical>' prior: 0!
A Warning is a Notification which by default should be brought to the attention of the user.!


!Warning methodsFor: 'exceptionDescription' stamp: 'ar 9/27/2005 19:54'!
defaultAction
	"The user should be notified of the occurrence of an exceptional occurrence and given an option of continuing or aborting the computation. The description of the occurrence should include any text specified as the argument of the #signal: message."
	ToolSet
		debugContext: thisContext
		label: 'Warning'
		contents: self messageText, '\\Select Proceed to continue, or close this window to cancel the operation.' withCRs.
	self resume.
! !
BitBlt subclass: #WarpBlt
	instanceVariableNames: 'p1x p1y p1z p2x p2y p2z p3x p3y p3z p4x p4y p4z cellSize sourceRGBmap'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!WarpBlt commentStamp: '<historical>' prior: 0!
WarpBlt is a little warp-drive added on to BitBlt.  It takes a quadrilateral as its source specification, while its destination is traversed and combined just like any other call to copyBits.

The source quadrilateral is specified as an array of points starting with the corner that wants to end up in the topLeft, and proceding to the successive points that want to follow CCW around the destination rectangle.  Note that in specifying a plain old rectangle source, its non topLeft points must be actual pixels, not outside by 1, as with rectangle bottmRight, eg.  See the method Rectangle asQuad.

WarpBlt does a fast job of rotation, reflection and scaling, and it can even produce a semblance of perspective.  Depth parameters are included for future improvements in this direction. but the primitve does not support this yet.!


!WarpBlt methodsFor: 'primitives'!
copyQuad: pts toRect: destRect
	self sourceQuad: pts destRect: destRect.
	self warpBits! !

!WarpBlt methodsFor: 'primitives'!
deltaFrom: x1 to: x2 nSteps: n
	"Utility routine for computing Warp increments.
	x1 is starting pixel, x2 is ending pixel;  assumes n >= 1"
	| fixedPtOne |
	fixedPtOne _ 16384.  "1.0 in fixed-pt representation"
	x2 > x1
		ifTrue: [^ x2 - x1 + fixedPtOne // (n+1) + 1]
		ifFalse: [x2 = x1 ifTrue: [^ 0].
				^ 0 - (x1 - x2 + fixedPtOne // (n+1) + 1)]! !

!WarpBlt methodsFor: 'primitives' stamp: 'jm 5/2/1999 07:09'!
sourceForm: srcForm destRect: dstRectangle
	"Set up a WarpBlt from the entire source Form to the given destination rectangle."

	| w h |
	sourceForm _ srcForm.
	sourceX _ sourceY _ 0.
	destX _ dstRectangle left.
	destY _ dstRectangle top.
	width _ dstRectangle width.
	height _ dstRectangle height.
	w _ 16384 * (srcForm width - 1).
	h _ 16384 * (srcForm height - 1).
	p1x _ 0.
	p2x _ 0.
	p3x _ w.
	p4x _ w.
	p1y _ 0.
	p2y _ h.
	p3y _ h.
	p4y _ 0.
	p1z _ p2z _ p3z _ p4z _ 16384.  "z-warp ignored for now"
! !

!WarpBlt methodsFor: 'primitives'!
sourceQuad: pts destRect: aRectangle
	| fixedPt1 |
	sourceX _ sourceY _ 0.
	self destRect: aRectangle.
	fixedPt1 _ (pts at: 1) x isInteger ifTrue: [16384] ifFalse: [16384.0].
	p1x _ (pts at: 1) x * fixedPt1.
	p2x _ (pts at: 2) x * fixedPt1.
	p3x _ (pts at: 3) x * fixedPt1.
	p4x _ (pts at: 4) x * fixedPt1.
	p1y _ (pts at: 1) y * fixedPt1.
	p2y _ (pts at: 2) y * fixedPt1.
	p3y _ (pts at: 3) y * fixedPt1.
	p4y _ (pts at: 4) y * fixedPt1.
	p1z _ p2z _ p3z _ p4z _ 16384.  "z-warp ignored for now"
! !

!WarpBlt methodsFor: 'primitives'!
startFrom: x1 to: x2 offset: sumOfDeltas
	"Utility routine for computing Warp increments."
	x2 >= x1
		ifTrue: [^ x1]
		ifFalse: [^ x2 - sumOfDeltas]! !

!WarpBlt methodsFor: 'primitives' stamp: 'nk 11/3/2004 09:26'!
warpBits
	"Move those pixels!!"

	cellSize < 1 ifTrue: [ ^self error: 'cellSize must be >= 1' ].

	self warpBitsSmoothing: cellSize
		sourceMap: (sourceForm colormapIfNeededForDepth: 32).
! !

!WarpBlt methodsFor: 'primitives' stamp: 'nk 4/17/2004 19:50'!
warpBitsSmoothing: n sourceMap: sourceMap
	| deltaP12 deltaP43 pA pB deltaPAB sp fixedPtOne picker poker pix nSteps |
	<primitive: 'primitiveWarpBits' module: 'BitBltPlugin'>

	"Check for compressed source, destination or halftone forms"
	((sourceForm isForm) and: [sourceForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].
	((destForm isForm) and: [destForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].
	((halftoneForm isForm) and: [halftoneForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].

	(width < 1) | (height < 1) ifTrue: [^ self].
	fixedPtOne _ 16384.  "1.0 in fixed-pt representation"
	n > 1 ifTrue:
		[(destForm depth < 16 and: [colorMap == nil])
			ifTrue: ["color map is required to smooth non-RGB dest"
					^ self primitiveFail].
		pix _ Array new: n*n].

	nSteps _ height-1 max: 1.
	deltaP12 _ (self deltaFrom: p1x to: p2x nSteps: nSteps)
			@ (self deltaFrom: p1y to: p2y nSteps: nSteps).
	pA _ (self startFrom: p1x to: p2x offset: nSteps*deltaP12 x)
		@ (self startFrom: p1y to: p2y offset: nSteps*deltaP12 y).
	deltaP43 _ (self deltaFrom: p4x to: p3x nSteps: nSteps)
			@ (self deltaFrom: p4y to: p3y nSteps: nSteps).
	pB _ (self startFrom: p4x to: p3x offset: nSteps*deltaP43 x)
		@ (self startFrom: p4y to: p3y offset: nSteps*deltaP43 y).

	picker _ BitBlt current bitPeekerFromForm: sourceForm.
	poker _ BitBlt current bitPokerToForm: destForm.
	poker clipRect: self clipRect.
	nSteps _ width-1 max: 1.
	destY to: destY+height-1 do:
		[:y |
		deltaPAB _ (self deltaFrom: pA x to: pB x nSteps: nSteps)
				@ (self deltaFrom: pA y to: pB y nSteps: nSteps).
		sp _ (self startFrom: pA x to: pB x offset: nSteps*deltaPAB x)
			@ (self startFrom: pA y to: pB y offset: nSteps*deltaPAB x).
		destX to: destX+width-1 do:
			[:x | 
			n = 1
			ifTrue:
				[poker pixelAt: x@y
						put: (picker pixelAt: sp // fixedPtOne asPoint)]
			ifFalse:
				[0 to: n-1 do:
					[:dx | 0 to: n-1 do:
						[:dy |
						pix at: dx*n+dy+1 put:
								(picker pixelAt: sp
									+ (deltaPAB*dx//n)
									+ (deltaP12*dy//n)
										// fixedPtOne asPoint)]].
				poker pixelAt: x@y put: (self mixPix: pix
										sourceMap: sourceMap
										destMap: colorMap)].
			sp _ sp + deltaPAB].
		pA _ pA + deltaP12.
		pB _ pB + deltaP43]! !


!WarpBlt methodsFor: 'setup'!
cellSize
	^ cellSize! !

!WarpBlt methodsFor: 'setup' stamp: 'jm 4/11/1999 12:00'!
cellSize: s
	cellSize _ s.
	cellSize = 1 ifTrue: [^ self].
	colorMap _ Color colorMapIfNeededFrom: 32 to: destForm depth.
! !


!WarpBlt methodsFor: 'smoothing' stamp: 'di 6/24/97 00:09'!
mixPix: pix sourceMap: sourceMap destMap: destMap
	"Average the pixels in array pix to produce a destination pixel.
	First average the RGB values either from the pixels directly,
	or as supplied in the sourceMap.  Then return either the resulting
	RGB value directly, or use it to index the destination color map." 
	| r g b rgb nPix bitsPerColor d |
	nPix _ pix size.
	r _ 0. g _ 0. b _ 0.
	1 to: nPix do:
		[:i |   "Sum R, G, B values for each pixel"
		rgb _ sourceForm depth <= 8
				ifTrue: [sourceMap at: (pix at: i) + 1]
				ifFalse: [sourceForm depth = 32
						ifTrue: [pix at: i]
						ifFalse: [self rgbMap: (pix at: i) from: 5 to: 8]].
		r _ r + ((rgb bitShift: -16) bitAnd: 16rFF).
		g _ g + ((rgb bitShift: -8) bitAnd: 16rFF).
		b _ b + ((rgb bitShift: 0) bitAnd: 16rFF)].
	destMap == nil
		ifTrue: [bitsPerColor _ 3.  "just in case eg depth <= 8 and no map"
				destForm depth = 16 ifTrue: [bitsPerColor _ 5].
				destForm depth = 32 ifTrue: [bitsPerColor _ 8]]
		ifFalse: [destMap size = 512 ifTrue: [bitsPerColor _ 3].
				destMap size = 4096 ifTrue: [bitsPerColor _ 4].
				destMap size = 32768 ifTrue: [bitsPerColor _ 5]].
	d _ bitsPerColor - 8.
	rgb _ ((r // nPix bitShift: d) bitShift: bitsPerColor*2)
		+ ((g // nPix bitShift: d) bitShift: bitsPerColor)
		+ ((b // nPix bitShift: d) bitShift: 0).
	destMap == nil
		ifTrue: [^ rgb]
		ifFalse: [^ destMap at: rgb+1]! !

!WarpBlt methodsFor: 'smoothing' stamp: 'di 6/24/97 00:08'!
rgbMap: sourcePixel from: nBitsIn to: nBitsOut
	"NOTE: This code is copied verbatim from BitBltSimulation so that it
	may be removed from the system"
	"Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."
	| mask d srcPix destPix |
	self inline: true.
	(d _ nBitsOut - nBitsIn) > 0
		ifTrue:
			["Expand to more bits by zero-fill"
			mask _ (1 << nBitsIn) - 1.  "Transfer mask"
			srcPix _ sourcePixel << d.
			mask _ mask << d.
			destPix _ srcPix bitAnd: mask.
			mask _ mask << nBitsOut.
			srcPix _ srcPix << d.
			^ destPix + (srcPix bitAnd: mask)
				 	+ (srcPix << d bitAnd: mask << nBitsOut)]
		ifFalse:
			["Compress to fewer bits by truncation"
			d = 0 ifTrue: [^ sourcePixel].  "no compression"
			sourcePixel = 0 ifTrue: [^ sourcePixel].  "always map 0 (transparent) to 0"
			d _ nBitsIn - nBitsOut.
			mask _ (1 << nBitsOut) - 1.  "Transfer mask"
			srcPix _ sourcePixel >> d.
			destPix _ srcPix bitAnd: mask.
			mask _ mask << nBitsOut.
			srcPix _ srcPix >> d.
			destPix _ destPix + (srcPix bitAnd: mask)
					+ (srcPix >> d bitAnd: mask << nBitsOut).
			destPix = 0 ifTrue: [^ 1].  "Dont fall into transparent by truncation"
			^ destPix]! !


!WarpBlt methodsFor: 'system simulation' stamp: 'nk 11/3/2004 09:26'!
warpBitsSimulated
	"Simulate WarpBlt"

	cellSize < 1 ifTrue: [ ^self error: 'cellSize must be >= 1' ].

	self warpBitsSimulated: cellSize
		sourceMap: (sourceForm colormapIfNeededForDepth: 32).
! !

!WarpBlt methodsFor: 'system simulation' stamp: 'ar 2/13/2001 21:12'!
warpBitsSimulated: n sourceMap: sourceMap
	"Simulate WarpBlt"
	Smalltalk at: #BitBltSimulation ifPresent:[:bb| bb warpBitsFrom: self].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WarpBlt class
	instanceVariableNames: ''!

!WarpBlt class methodsFor: 'examples'!
test1   "Display restoreAfter: [WarpBlt test1]"
	"Demonstrates variable scale and rotate"
	| warp pts r1 p0 p ext |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle originFromUser: 50@50.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		clipRect: (0@0 extent: r1 extent*5);
		sourceForm: Display;
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) asIntegerPoint.
		warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext)]! !

!WarpBlt class methodsFor: 'examples' stamp: 'sma 4/22/2000 20:23'!
test12   "Display restoreAfter: [WarpBlt test12]"
	"Just like test1, but comparing smooth to non-smooth warps"
	| warp pts r1 p0 p ext warp2 |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle originFromUser: 50@50.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		cellSize: 2;  "installs a colormap"
		clipRect: (0@0 extent: r1 extent*5);
		sourceForm: Display;
		combinationRule: Form over.
	warp2 _ (self toForm: Display)
		clipRect: ((0@0 extent: r1 extent*5) translateBy: 250@0);
		sourceForm: Display;
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) asIntegerPoint.
		warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext).
		warp2 copyQuad: pts toRect: ((r1 extent*5-ext//2 extent: ext) translateBy: 250@0).
		]! !

!WarpBlt class methodsFor: 'examples'!
test3   "Display restoreAfter: [WarpBlt test3]"

	"The Squeak Release Mandala - 9/23/96 di"

	"Move the mouse near the center of the square.
	Up and down affects shrink/grow
	Left and right affect rotation angle"
	| warp pts p0 p box map d t |
	box _ 100@100 extent: 300@300.
	Display border: (box expandBy: 2) width: 2.

	"Make a color map that steps through the color space"
	map _ (Display depth > 8
		ifTrue: ["RGB is a bit messy..."
				d _ Display depth = 16 ifTrue: [5] ifFalse: [8].
				(1 to: 512) collect: [:i | t _ i bitAnd: 511.
					((t bitAnd: 16r7) bitShift: d-3)
					+ ((t bitAnd: 16r38) bitShift: d-3*2)
					+ ((t bitAnd: 16r1C0) bitShift: d-3*3)]]
		ifFalse: ["otherwise simple"
				1 to: (1 bitShift: Display depth)])
			as: Bitmap.
	warp _ (WarpBlt toForm: Display)
		clipRect: box;
		sourceForm: Display;
		colorMap: map;
		combinationRule: Form over.
	p0 _ box center.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ (box insetBy: p y - p0 y) innerCorners
			collect: [:pt | pt rotateBy: p x - p0 x / 50.0 about: p0].
		warp copyQuad: pts toRect: box]! !

!WarpBlt class methodsFor: 'examples'!
test4   "Display restoreAfter: [WarpBlt test4]"

	"The Squeak Release Mandala - 9/23/96 di
	This version does smoothing"

	"Move the mouse near the center ofhe square.
	Up and dn affects shrink/grow
	Left and right affect rotation angle"
	| warp pts p0 p box |
	box _ 100@100 extent: 300@300.
	Display border: (box expandBy: 2) width: 2.

	warp _ (WarpBlt toForm: Display)
		clipRect: box;
		sourceForm: Display;
		cellSize: 2;  "installs a colormap"
		combinationRule: Form over.
	p0 _ box center.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ (box insetBy: p y - p0 y) innerCorners
			collect: [:pt | pt rotateBy: p x - p0 x / 50.0 about: p0].
		warp copyQuad: pts toRect: box]! !

!WarpBlt class methodsFor: 'examples'!
test5   "Display restoreAfter: [WarpBlt test5]"
	"Demonstrates variable scale and rotate"
	| warp pts r1 p0 p |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle fromUser.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		cellSize: 1;
		sourceForm: Display;
		cellSize: 2;  "installs a colormap"
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		warp copyQuad: pts toRect: (r1 translateBy: r1 width@0)]! !


!WarpBlt class methodsFor: 'form rotation' stamp: 'nk 4/17/2004 19:45'!
rotate: srcForm degrees: angleInDegrees center: aPoint scaleBy: scalePoint smoothing: cellSize
	"Rotate the given Form the given number of degrees about the given center and scale its width and height by x and y of the given scale point. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated Form and the second is the position offset required to align the center of the rotated Form with that of the original. Note that the dimensions of the resulting Form generally differ from those of the original."

	| srcRect center radians dstOrigin dstCorner p dstRect inverseScale quad dstForm newCenter warpSrc |
	srcRect _ srcForm boundingBox.
	center _ srcRect center.
	radians _ angleInDegrees degreesToRadians.
	dstOrigin _ dstCorner _ center.
	srcRect corners do: [:corner |
		"find the limits of a rectangle that just encloses the rotated
		 original; in general, this rectangle will be larger than the
		 original (e.g., consider a square rotated by 45 degrees)"
		p _ ((corner - center) scaleBy: scalePoint) + center.
		p _ (p rotateBy: radians about: center) rounded.
		dstOrigin _ dstOrigin min: p.
		dstCorner _ dstCorner max: p].

	"rotate the enclosing rectangle back to get the source quadrilateral"
	dstRect _ dstOrigin corner: dstCorner.
	inverseScale _ (1.0 / scalePoint x)@(1.0 / scalePoint y).
	quad _ dstRect innerCorners collect: [:corner |
		p _ corner rotateBy: radians negated about: center.
		((p - center) scaleBy: inverseScale) + center].

	"make a Form to hold the result and do the rotation"
	warpSrc _ srcForm.
	(srcForm isColorForm)
		ifTrue: [
			cellSize > 1 | true "ar 12/27/2001: Always enable - else sketches won't work"
				ifTrue: [
					warpSrc _ Form extent: srcForm extent depth: 16.
					srcForm displayOn: warpSrc.
					dstForm _ Form extent: dstRect extent depth: 16]  "use 16-bit depth to allow smoothing"
				ifFalse: [
					dstForm _ srcForm class extent: dstRect extent depth: srcForm depth]]
		ifFalse: [
			dstForm _ srcForm class extent: dstRect extent depth: srcForm depth].

	(WarpBlt toForm: dstForm)
		sourceForm: warpSrc;
		colorMap: (warpSrc colormapIfNeededFor: dstForm);
		cellSize: cellSize;  "installs a new colormap if cellSize > 1"
		combinationRule: Form paint;
		copyQuad: quad toRect: dstForm boundingBox.

	(dstForm isColorForm) ifTrue: [dstForm colors: srcForm colors copy].
	newCenter _ (center rotateBy: radians about: aPoint) truncated.
	^ Array with: dstForm with: dstRect origin + (newCenter - center)
! !


!WarpBlt class methodsFor: 'initialization'!
toForm: destinationForm
	"Default cell size is 1 (no pixel smoothing)"
	^ (super toForm: destinationForm) cellSize: 1! !


!WarpBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:00'!
current
	"Return the class currently to be used for WarpBlt"
	^Display defaultWarpBltClass! !
EllipseMorph subclass: #WatchMorph
	instanceVariableNames: 'fontName cColor handsColor romanNumerals antialias'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!WatchMorph commentStamp: '<historical>' prior: 0!
This class is a representation of a watch.
The labels' font is changeble. Labels' font size increase or decrease when resizing me.

WatchMorph new openInWorld
(WatchMorph fontName: 'ComicPlain' bgColor: Color transparent centerColor: Color transparent) openInWorld		" transparent "
(WatchMorph fontName: 'ComicBold' bgColor: Color white centerColor: Color black) openInWorld

Structure:
	fontName		String -- the labels' font name
	cColor			Color -- center color
	handsColor		Color
	romanNumerals	Boolean
	antialias		Boolean!


!WatchMorph methodsFor: 'accessing' stamp: 'bf 5/18/2000 11:06'!
antialias: aBoolean
	antialias _ aBoolean! !

!WatchMorph methodsFor: 'accessing' stamp: 'sw 7/4/2002 00:19'!
centerColor: aColor
	"Set the center color as indicated; map nil into transparent"

	cColor _ aColor ifNil: [Color transparent]! !

!WatchMorph methodsFor: 'accessing' stamp: 'di 5/16/2000 21:45'!
fontName: aString

	fontName _ aString.
	self createLabels! !

!WatchMorph methodsFor: 'accessing' stamp: 'rjf 5/11/2000 00:03'!
handsColor: aColor

	handsColor _ aColor! !


!WatchMorph methodsFor: 'drawing' stamp: 'sw 7/4/2002 00:22'!
drawOn: aCanvas
	"Draw the watch on the given canvas"

	| pHour pMin pSec time centerColor |
	time _ Time now.
	pHour _ self radius: 0.6 hourAngle: time hours + (time minutes/60.0).
	pMin _ self radius: 0.72 hourAngle: (time minutes / 5.0).
	pSec _ self radius: 0.8 hourAngle: (time seconds / 5.0).
	centerColor _ cColor
		ifNil:
			[Color transparent]
		ifNotNil:
			[time hours < 12
				ifTrue: [cColor muchLighter]
				ifFalse: [cColor]].

	antialias ifTrue:
		[aCanvas asBalloonCanvas
			aaLevel: 4;
			drawOval: (bounds insetBy: borderWidth // 2 + 1) color: self fillStyle
				borderWidth: borderWidth borderColor: borderColor;
			drawOval: (bounds insetBy: self extent*0.35) color: centerColor
				borderWidth: 0 borderColor: Color black;
			drawPolygon: {self center. pHour}
				color: Color transparent borderWidth: 3 borderColor: handsColor;
			drawPolygon: {self center. pMin}
				color: Color transparent borderWidth: 2 borderColor: handsColor;
			drawPolygon: {self center. pSec}
				color: Color transparent borderWidth: 1 borderColor: handsColor]
		ifFalse:
			[super drawOn: aCanvas.
			aCanvas
				fillOval: (bounds insetBy: self extent*0.35) color: centerColor;
				line: self center to: pHour width: 3 color: handsColor;
				line: self center to: pMin width: 2 color: handsColor;
				line: self center to: pSec width: 1 color: handsColor]
! !


!WatchMorph methodsFor: 'geometry' stamp: 'di 5/16/2000 21:18'!
extent: newExtent

	super extent: newExtent.
	self createLabels! !


!WatchMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:01'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color green! !

!WatchMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:01'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""

	self handsColor: Color red.
	self centerColor: Color gray.
	romanNumerals _ false.
	antialias _ false.
	fontName _ 'NewYork'.
	self extent: 130 @ 130.
	self start! !


!WatchMorph methodsFor: 'labels' stamp: 'tlk 5/21/2006 14:53'!
createLabels
	| numeral font h r |
	self removeAllMorphs.
	font _ StrikeFont familyName: fontName size: (h _ self height min: self width)//8.
	r _ 1.0 - (1.4 * font height / h).
	1 to: 12 do:
		[:hour |
		numeral _ romanNumerals
			ifTrue: [hour printStringRoman]
			ifFalse: [hour asString].
		self addMorphBack: ((StringMorph contents: numeral font: font emphasis: 1)
			center: (self radius: r hourAngle: hour)) lock]! !


!WatchMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 22:24'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add morph-specific items to the given menu which was invoked by the given hand."

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu addLine.
	aMenu addUpdating: #romanNumeralString action: #toggleRoman.
	aMenu addUpdating: #antiAliasString action: #toggleAntialias.
	aMenu addLine.
	aMenu add: 'change font...' translated action: #changeFont.
	aMenu balloonTextForLastItem: 'Allows you to change the font used to display the numbers.' translated.
	aMenu add: 'change hands color...' translated action: #changeHandsColor.
	aMenu balloonTextForLastItem: 'Allows you to specify a new color for the hands of the watch.  Note that actual *watch* color can be changed simply by using the halo''s recoloring handle.' translated.
	aMenu add: 'change center color...' translated action: #changeCenterColor.
	aMenu balloonTextForLastItem: 'Allows you to specify a new color to be used during PM hours for the center portion of the watch; during AM hours, a lighter shade of the same color will be used.' translated.! !

!WatchMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 22:25'!
antiAliasString
	^ (antialias
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'anti-aliasing' translated! !

!WatchMorph methodsFor: 'menus' stamp: 'sw 9/6/2000 18:46'!
changeCenterColor
	"Let the user change the color of the center of the watch"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #centerColor:;
		originalColor: self color;
		putUpFor: self near: self fullBounds! !

!WatchMorph methodsFor: 'menus' stamp: 'di 5/16/2000 21:48'!
changeFont

	self fontName: ((SelectionMenu labelList: StrikeFont familyNames
							selections: StrikeFont familyNames) startUp
					ifNil: [^ self])! !

!WatchMorph methodsFor: 'menus' stamp: 'sw 9/6/2000 18:46'!
changeHandsColor
	"Let the user change the color of the hands of the watch."

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #handsColor:;
		originalColor: self color;
		putUpFor: self near: self fullBounds! !

!WatchMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 22:24'!
romanNumeralString
	"Answer a string governing the roman-numerals checkbox"
	^ (romanNumerals
		ifTrue: ['<on>']
		ifFalse: ['<off>'])
		, 'roman numerals' translated! !

!WatchMorph methodsFor: 'menus' stamp: 'bf 5/17/2000 18:46'!
toggleAntialias
	antialias _ antialias not! !

!WatchMorph methodsFor: 'menus' stamp: 'di 5/16/2000 21:19'!
toggleRoman

	romanNumerals _ romanNumerals not.
	self createLabels! !


!WatchMorph methodsFor: 'stepping and presenter' stamp: 'rlf 3/17/2000 12:59'!
step
	self changed.! !


!WatchMorph methodsFor: 'private' stamp: 'di 5/16/2000 22:22'!
radius: unitRadius hourAngle: hourAngle
	"unitRadius goes from 0.0 at the center to 1.0 on the circumference.
	hourAngle runs from 0.0 clockwise around to 12.0 with wrapping."

	^ self center + (self extent * (Point r: 0.5 * unitRadius
									degrees: hourAngle * 30.0 - 90.0)).! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WatchMorph class
	instanceVariableNames: ''!

!WatchMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/16/2000 21:43'!
fontName: aString bgColor: aColor centerColor: otherColor
	^ self new
		fontName: aString;
		color: aColor;
		centerColor: otherColor! !


!WatchMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:53'!
descriptionForPartsBin
	^ self partName:	'Watch'
		categories:		#('Useful')
		documentation:	'An analog clock face'! !
TestCase subclass: #WatchMorphTest
	instanceVariableNames: 'morph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!
!WatchMorphTest commentStamp: 'tlk 5/21/2006 14:50' prior: 0!
A WatchMorphTest is a a sunit test of WatchMorpht.  It was first implemented when fixing some broken functionality.

My fixtures are morph, a WatchMorph.  !


!WatchMorphTest methodsFor: 'initialize-release' stamp: 'tlk 5/21/2006 14:42'!
setUp
	morph := WatchMorph new openInWorld.! !

!WatchMorphTest methodsFor: 'initialize-release' stamp: 'tlk 5/21/2006 14:41'!
tearDown
	morph delete.! !


!WatchMorphTest methodsFor: 'testing' stamp: 'tlk 5/21/2006 14:49'!
testToggleRoman
	self shouldnt: [morph toggleRoman]  raise: Error! !
AlignmentMorph subclass: #WatcherWrapper
	instanceVariableNames: 'player variableName'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Support'!
!WatcherWrapper commentStamp: 'sw 1/6/2005 00:06' prior: 0!
A wrapper around either kind of watcher.  My primary raison d'etre is so that I can automatically change names when my player changes names.!


!WatcherWrapper methodsFor: 'accessing' stamp: 'sw 1/12/2005 09:33'!
associatedPlayer
	"Answer the player with which I'm associated"

	^ player! !

!WatcherWrapper methodsFor: 'accessing' stamp: 'sw 1/6/2005 04:18'!
getterTilesForDrop
	"Answer getter tiles to use if there is an attempt to drop me onto a tile pad"

	| aCategoryViewer |
	aCategoryViewer _ CategoryViewer new initializeFor: player categoryChoice: #basic.
	^ aCategoryViewer getterTilesFor: (Utilities getterSelectorFor: variableName)  type: self resultType! !

!WatcherWrapper methodsFor: 'accessing' stamp: 'sw 1/6/2005 03:49'!
isTileLike
	"Answer whether the receiver can participate tile-like"

	^ true! !

!WatcherWrapper methodsFor: 'accessing' stamp: 'sw 1/6/2005 04:00'!
justGrabbedFrom: formerOwner
	"An attempt to make these guys easier to involve in tile scripting.  But in the end too strange, so for the moment the active ingredients commented out"

"	self center: ActiveHand position.
	self left: ActiveHand position x."

	super justGrabbedFrom: formerOwner! !

!WatcherWrapper methodsFor: 'accessing' stamp: 'sw 1/6/2005 02:47'!
readoutMorph
	"Answer the submorph of mine that serves as my readout"

	^ self allMorphs detect:
		[:m | m isEtoyReadout] ifNone: [nil]! !

!WatcherWrapper methodsFor: 'accessing' stamp: 'sw 1/6/2005 03:13'!
resultType
	"Answer the result type the receiver would produce."

	^ player typeForSlotWithGetter: (Utilities getterSelectorFor: variableName)! !

!WatcherWrapper methodsFor: 'accessing' stamp: 'sw 1/12/2005 09:32'!
tileRows
	"Answer, for the benefit of d&d scripting, a structure appropriate for dropping nto a script"

	^ Array with: (Array with: self getterTilesForDrop)! !


!WatcherWrapper methodsFor: 'identification' stamp: 'sw 1/6/2005 03:44'!
isTileScriptingElement
	"Answer whether the receiver is a tile-scripting element"

	^ true! !


!WatcherWrapper methodsFor: 'initialization' stamp: 'tak 4/6/2005 13:06'!
buildForPlayer: aPlayer getter: aGetter 
	"Build up basic structure"
	| aColor |
	self
		player: aPlayer
		variableName: (Utilities inherentSelectorForGetter: aGetter).
	aColor := Color
				r: 0.387
				g: 0.581
				b: 1.0.
	self listDirection: #leftToRight;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 color: aColor;
		 layoutInset: -1;
		 borderWidth: 1;
		 borderColor: aColor darker;
		 listCentering: #center.
	self
		addMorphBack: (self buildReadout: aGetter)! !

!WatcherWrapper methodsFor: 'initialization' stamp: 'tak 4/6/2005 12:14'!
buildReadout: aGetter 
	| triplet type wording setter vocab readout |
	triplet := self readoutInformation: aGetter.
	type := triplet first.
	wording := triplet second.
	setter := triplet third.
	vocab := Vocabulary vocabularyForType: type.
	readout := vocab
				updatingTileForTarget: player
				partName: wording
				getter: aGetter
				setter: setter.
	readout
		setNameTo: ('{1}''s {2}' translated format: {player externalName. wording}).
	readout
		minHeight: (vocab wantsArrowsOnTiles
				ifTrue: [22]
				ifFalse: [14]).
	^ readout! !

!WatcherWrapper methodsFor: 'initialization' stamp: 'tak 4/6/2005 13:25'!
fancyForPlayer: aPlayer getter: aGetter 
	"build a labeled readout"
	| aColor aLabel |
	self buildForPlayer: aPlayer getter: aGetter.
	aColor := Color
				r: 0.387
				g: 0.581
				b: 1.0.
	aLabel := StringMorph contents: variableName translated , ' = ' font: ScriptingSystem fontForTiles.
	aLabel setProperty: #watcherLabel toValue: true.
	self addMorphFront: aLabel.
	self addMorphFront: (aPlayer tileReferringToSelf borderWidth: 0;
			 layoutInset: 4 @ 0;
			 typeColor: aColor;
			 color: aColor;
			 bePossessive)! !

!WatcherWrapper methodsFor: 'initialization' stamp: 'tak 4/6/2005 13:07'!
player: aPlayer variableName: aVariableName
	"Set up my initial state"
	player _ aPlayer.
	variableName _ aVariableName.
	self reconstituteName
! !

!WatcherWrapper methodsFor: 'initialization' stamp: 'tak 4/6/2005 13:14'!
readoutInformation: aGetter 
	"Answer a triplet of {type. wording. setter}"
	| info anInterface |
	info := player slotInfoForGetter: aGetter.
	"In case of a variable"
	info
		ifNotNil: [^ {info type. Utilities inherentSelectorForGetter: aGetter. Utilities setterSelectorFor: variableName}].
	"In case of a slot"
	anInterface := Vocabulary eToyVocabulary
				methodInterfaceAt: aGetter
				ifAbsent: [^ {#Unknown. '*'. nil}].
	^ {anInterface resultType. anInterface wording. anInterface companionSetterSelector}! !

!WatcherWrapper methodsFor: 'initialization' stamp: 'tak 4/6/2005 13:47'!
unlabeledForPlayer: aPlayer getter: aGetter 
	"build a simple watcher"
	| readout |
	self buildForPlayer: aPlayer getter: aGetter.
	readout := self submorphs last.
	(readout isKindOf: TileMorph)
		ifTrue: [readout labelMorph lock: true.
			readout labelMorph beSticky]! !


!WatcherWrapper methodsFor: 'updating' stamp: 'sw 1/6/2005 00:11'!
bringUpToDate
	"Given that my player may have been renamed, reformulate my external name"

	self reconstituteName
	! !

!WatcherWrapper methodsFor: 'updating' stamp: 'tak 8/5/2005 01:14'!
localeChanged! !

!WatcherWrapper methodsFor: 'updating' stamp: 'yo 3/17/2005 08:47'!
reconstituteName
	"Reconstitute the external name of the receiver"

	variableName ifNotNil:
		[self setNameTo: ('{1}''s {2}' translated format: {player externalName. variableName translated}).
		(self submorphWithProperty: #watcherLabel) ifNotNilDo:
			[:aLabel | aLabel contents: variableName asString, ' = ']]! !
AlignmentMorph subclass: #WaveEditor
	instanceVariableNames: 'graph samplingRate perceivedFrequency loopEnd loopLength loopCycles possibleLoopStarts keyboard'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-SoundInterface'!
!WaveEditor commentStamp: '<historical>' prior: 0!
This tool was created to aid in the preparation of LoopedSampledSound objects. It includes support for finding good loop points with a little help from the user.  Namely, the user must identify a good ending point for the loop (typically just before the decay phase begins) and identify one cycle of the waveform. After that, the  "choose loop point" menu command can be invoked to search backwards to find and rank all possible loop starting points. Some experimentation is usually required to find a loop that "breaths" in a natural way.

This tool can also be used as a general viewer of numerical sequences of any kind, such as time-varying functions, FFT data, etc.!


!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/5/1998 12:43'!
data: newData

	graph data: newData.
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/3/2004 18:16'!
graph

	^ graph
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/7/1998 09:48'!
loopCycles

	^ loopCycles
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:21'!
loopCycles: aNumber

	loopCycles _ aNumber.
	self loopLength: loopLength.  "updates frequency"
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 6/30/1998 17:20'!
loopEnd

	^ loopEnd
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/31/1998 14:01'!
loopEnd: aNumber

	loopEnd _ (aNumber asInteger max: 1) min: graph data size.
	possibleLoopStarts _ nil.
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/7/1998 08:38'!
loopLength

	^ loopLength
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/8/1998 21:03'!
loopLength: aNumber

	loopLength _ aNumber.
	((loopCycles > 0) and: [loopLength > 0]) ifTrue: [
		perceivedFrequency _ samplingRate asFloat * loopCycles / loopLength].

! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 10:08'!
loopStart

	^ (loopEnd - loopLength) truncated + 1
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:46'!
loopStart: index

	| start len |
	start _ self fractionalLoopStartAt: index.
	len _ (loopEnd asFloat - start) + 1.0.
	loopCycles _ (len / (samplingRate / perceivedFrequency)) rounded.
	self loopLength: len.
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:31'!
perceivedFrequency

	^ perceivedFrequency

! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:32'!
perceivedFrequency: aNumber

	perceivedFrequency _ aNumber.
	(loopCycles > 0) ifTrue: [
		loopLength _ samplingRate asFloat * loopCycles / perceivedFrequency].
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/4/1998 10:44'!
samplingRate

	^ samplingRate

! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/4/1998 10:44'!
samplingRate: samplesPerSecond

	samplingRate _ samplesPerSecond.
! !

!WaveEditor methodsFor: 'accessing' stamp: 'nk 6/22/2004 16:17'!
sound: aSound
	| buffer |
	buffer _ aSound samples mergeStereo.
	graph data: buffer.
	loopLength := loopEnd := buffer size.
	self samplingRate: aSound originalSamplingRate.
	loopCycles :=  buffer size / aSound originalSamplingRate * 400.
	perceivedFrequency := 400.
! !


!WaveEditor methodsFor: 'initialization' stamp: 'dgd 9/19/2003 12:23'!
addControls

	| slider bb r m |
	r _ AlignmentMorph newRow.
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r color: bb color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r wrapCentering: #topLeft.
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'X';					actionSelector: #delete).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: '<>'; actWhen: #buttonDown;
															actionSelector: #invokeMenu).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'Play' translated;				actionSelector: #play).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'Play Before' translated;		actionSelector: #playBeforeCursor).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'Play After' translated;			actionSelector: #playAfterCursor).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'Play Loop' translated;			actionSelector: #playLoop).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'Test' translated;				actionSelector: #playTestNote).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'Save' translated;				actionSelector: #saveInstrument).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'Set Loop End' translated;		actionSelector: #setLoopEnd).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'One Cycle' translated;			actionSelector: #setOneCycle).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (bb label: 'Set Loop Start' translated;		actionSelector: #setLoopStart).
	self addMorphBack: r.

	r _ AlignmentMorph newRow.
	r color: self color; borderWidth: 0; layoutInset: 0.
	r hResizing: #spaceFill; vResizing: #rigid; extent: 5@20; wrapCentering: #center; cellPositioning: #leftCenter.

	m _ StringMorph new contents: 'Index: ' translated.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: graph; getSelector: #cursor; putSelector: #cursor:;
		growable: false; width: 71; step.
	r addMorphBack: m.

	m _ StringMorph new contents: 'Value: ' translated.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: graph; getSelector: #valueAtCursor; putSelector: #valueAtCursor:;
		growable: false; width: 50; step.
	r addMorphBack: m.

	slider _ SimpleSliderMorph new
		color: color;
		extent: 200@2;
		target: self;
		actionSelector: #scrollTime:.
	r addMorphBack: slider.

	m _ Morph new color: r color; extent: 10@5.  "spacer"
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: graph; getSelector: #startIndex; putSelector: #startIndex:;
		width: 40; step.
	r addMorphBack: m.

	self addMorphBack: r.

! !

!WaveEditor methodsFor: 'initialization' stamp: 'dgd 9/19/2003 12:23'!
addLoopPointControls

	| r m |
	r _ AlignmentMorph newRow.
	r color: self color; borderWidth: 0; layoutInset: 0.
	r hResizing: #spaceFill; vResizing: #rigid; extent: 5@20; wrapCentering: #center; cellPositioning: #leftCenter.

	m _ StringMorph new contents: 'Loop end: ' translated.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: self; getSelector: #loopEnd; putSelector: #loopEnd:;
		growable: false; width: 50; step.
	r addMorphBack: m.

	m _ StringMorph new contents: 'Loop length: ' translated.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: self; getSelector: #loopLength; putSelector: #loopLength:;
		floatPrecision: 0.001;
		growable: false; width: 50; step.
	r addMorphBack: m.

	m _ StringMorph new contents: 'Loop cycles: ' translated.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: self; getSelector: #loopCycles; putSelector: #loopCycles:;
		floatPrecision: 0.001;
		growable: false; width: 50; step.
	r addMorphBack: m.

	m _ StringMorph new contents: 'Frequency: ' translated.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: self; getSelector: #perceivedFrequency; putSelector: #perceivedFrequency:;
		floatPrecision: 0.001;
		growable: false; width: 50; step.
	r addMorphBack: m.

	self addMorphBack: r.
! !

!WaveEditor methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:02'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 2! !

!WaveEditor methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:02'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!WaveEditor methodsFor: 'initialization' stamp: 'nk 6/22/2004 16:22'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	samplingRate _ SoundPlayer samplingRate.
	loopEnd _ loopLength _ 0.
	loopCycles _ 1.
	perceivedFrequency _ 0.
	"zero means unknown"
	self extent: 5 @ 5;
		 listDirection: #topToBottom;
		 wrapCentering: #topLeft;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 layoutInset: 3.
	graph _ GraphMorph new extent: 450 @ 100.

	graph cursor: 0.
	graph cursorColorAtZeroCrossings: Color blue.
	self addControls.
	self addLoopPointControls.
	self addMorphBack: graph.
	self
		addMorphBack: (Morph
				newBounds: (0 @ 0 extent: 0 @ 3)
				color: Color transparent).
	self addMorphBack: (keyboard _ PianoKeyboardMorph new).
	self sound: (SampledSound soundNamed: 'croak').
! !


!WaveEditor methodsFor: 'menu' stamp: 'dgd 10/8/2003 20:12'!
chooseLoopStart 

	| bestLoops menu secs choice start |
	possibleLoopStarts ifNil: [
		Utilities
			informUser: 'Finding possible loop points...' translated
			during: [possibleLoopStarts _ self findPossibleLoopStartsFrom: graph cursor]].
	bestLoops _ possibleLoopStarts copyFrom: 1 to: (100 min: possibleLoopStarts size).
	menu _ CustomMenu new.
	bestLoops do: [:entry |
		secs _ ((loopEnd - entry first) asFloat / self samplingRate) roundTo: 0.01.
		menu add: ('{1} cycles; {2} secs' translated format:{entry third. secs}) action: entry].
	choice _ menu startUp.
	choice ifNil: [^ self].
	loopCycles _ choice third.
	start _ self fractionalLoopStartAt: choice first.
	self loopLength: (loopEnd asFloat - start) + 1.0.
! !

!WaveEditor methodsFor: 'menu' stamp: 'dgd 9/19/2003 12:47'!
invokeMenu
	"Invoke a menu of additonal functions for this WaveEditor."

	| aMenu |
	aMenu _ CustomMenu new.
	aMenu addList:	{
		{'play straight through' translated.	#play}.
		{'play before cursor' translated.	#playBeforeCursor}.
		{'play after cursor' translated.		#playAfterCursor}.
		{'play test note' translated.			#playTestNote}.
		{'play loop' translated.				#playLoop}.
		{'trim before cursor' translated.	#trimBeforeCursor}.
		{'trim after cursor' translated.		#trimAfterCursor}.
		{'choose loop start' translated.		#chooseLoopStart}.
		{'jump to loop start' translated.		#jumpToLoopStart}.
		{'jump to loop end' translated.		#jumpToLoopEnd}.
		{'make unlooped' translated.		#setUnlooped}.
		{'make unpitched' translated.		#setUnpitched}.
		{'show envelope' translated.		#showEnvelope}.
		{'show FFT' translated.				#showFFTAtCursor}}.
	aMenu invokeOn: self defaultSelection: nil.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/3/1998 12:42'!
jumpToLoopEnd

	graph cursor: loopEnd; centerCursor.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 10:09'!
jumpToLoopStart

	graph cursor: (loopEnd - loopLength) truncated; centerCursor.
! !

!WaveEditor methodsFor: 'menu' stamp: 'nk 6/22/2004 18:34'!
makeLoopedSampledSound
	| data end snd basePitch |
	data := graph data.
	snd := (loopEnd = 0 or: [loopLength = 0]) 
				ifTrue: 
					["save as unlooped"

					basePitch := perceivedFrequency = 0 
						ifTrue: [100.0]
						ifFalse: [perceivedFrequency].
					LoopedSampledSound new 
						unloopedSamples: data
						pitch: basePitch
						samplingRate: samplingRate]
				ifFalse: 
					[end := (loopEnd min: data size) max: 1.
					basePitch := samplingRate * loopCycles / loopLength.
					LoopedSampledSound new 
						samples: data
						loopEnd: end
						loopLength: end
						pitch: basePitch
						samplingRate: samplingRate].
	snd addReleaseEnvelope.
	^snd! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 7/9/1998 09:23'!
play

	graph data size < 2 ifTrue: [^ self].
	(SampledSound samples: graph data samplingRate: samplingRate) play.

! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:40'!
playAfterCursor

	self playFrom: graph cursor to: graph data size.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:39'!
playBeforeCursor

	self playFrom: 1 to: graph cursor.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:02'!
playFrom: start to: end

	| sz i1 i2 snd |
	sz _ graph data size.
	i1 _ ((start + 1) min: sz) max: 1.
	i2 _ ((end + 1) min: sz) max: i1.
	(i1 + 2) >= i2 ifTrue: [^ self].
	snd _ SampledSound
		samples: (graph data copyFrom: i1 to: i2)
		samplingRate: samplingRate.
	snd play.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 11:39'!
playLoop

	| sz i1 i2 snd len |
	sz _ graph data size.
	i1 _ ((loopEnd - loopLength) truncated min: sz) max: 1.
	i2 _ (loopEnd min: sz) max: i1.
	len _ (i2 - i1) + 1.
	len < 2 ifTrue: [^ self].

	snd _ LoopedSampledSound new
		samples: (graph data copyFrom: i1 to: i2)
		loopEnd: len
		loopLength: loopLength
		pitch: 100.0
		samplingRate: samplingRate.

	"sustain for the longer of four loops or two seconds"
	snd setPitch: 100.0
		dur: (((4.0 * loopLength) / samplingRate) max: 2.0)
		loudness: 0.5.
	snd play.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 11:38'!
playTestNote

	| data end snd loopDur dur |
	(loopEnd = 0 or: [loopLength = 0]) ifTrue: [^ self].
	data _ graph data.
	end _ (loopEnd min: data size) max: 1.
	snd _ LoopedSampledSound new
		samples: data loopEnd: end loopLength: loopLength
		pitch: 100.0 samplingRate: samplingRate.

	loopDur _ (4.0 * loopLength / samplingRate) max: 2.0.  "longer of 4 loops or 2 seconds"
	dur _ (data size / samplingRate) + loopDur.
	(snd
		addReleaseEnvelope;
		setPitch: 100.0 dur: dur loudness: 0.5) play.
! !

!WaveEditor methodsFor: 'menu' stamp: 'rbb 3/1/2005 11:20'!
saveInstrument

	| name |
	name := UIManager default request: 'Instrument name?' translated.
	name isEmpty ifTrue: [^ self].
	AbstractSound soundNamed: name put: self makeLoopedSampledSound.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 7/31/1998 11:06'!
setLoopEnd

	graph cursor: (self zeroCrossingAfter: graph cursor) - 1.
	self loopEnd: graph cursor.

! !

!WaveEditor methodsFor: 'menu' stamp: 'dgd 9/19/2003 12:48'!
setLoopStart
	"Assuming that the loop end and approximate frequency have been set, this method uses the current cursor position to determine the loop length and the number of cycles."

	| start len |
	start _ graph cursor.
	((start >= loopEnd) or: [perceivedFrequency = 0]) ifTrue: [
		^ self inform:
'Please set the loop end and the approximate frequency
first, then position the cursor one or more cycles
before the loop end and try this again.' translated].
	len _ (loopEnd - start) + 1.
	loopCycles _ (len / (samplingRate / perceivedFrequency)) rounded.
	self loopLength: len.

! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'!
setOneCycle
	"Set the approximate frequency based on a single cycle specified by the user. To use this, first set the loop end, then place the cursor one full cycle before the loop end and invoke this method."

	| len |
	len _ loopEnd - graph cursor.
	len > 0 ifTrue: [
		loopCycles _ 1.
		self loopLength: len].
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'!
setUnlooped
	"Make this sound play straight through without looping."

	loopLength _ 0.
	loopCycles _ 1.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'!
setUnpitched
	"Make this instrument be unpitched and unlooped. Suitable for percussive sounds that should not be pitch-shifted when played. By convention, such sounds are played at a pitch of 100.0 to obtain their original pitch."

	loopLength _ 0.
	loopCycles _ 0.
	perceivedFrequency _ 100.0.
! !

!WaveEditor methodsFor: 'menu' stamp: 'di 7/16/1999 08:30'!
showEnvelope
	"Show an envelope wave constructed by collecting the maximum absolute value of the samples in fixed-size time windows of mSecsPerQuantum."

	| data mSecsPerQuantum samplesPerQuantum result endOfQuantum maxThisQuantum s nSamples |
	data _ graph data.
	mSecsPerQuantum _ 10.
	samplesPerQuantum _ (mSecsPerQuantum / 1000.0) * self samplingRate.
	result _ WriteStream on: (Array new: data size // samplesPerQuantum).
	endOfQuantum _ samplesPerQuantum.
	maxThisQuantum _ 0.
	nSamples _ (data isKindOf: SoundBuffer)
		ifTrue: [data monoSampleCount]
		ifFalse: [data size].
	1 to: nSamples do: [:i |
		i asFloat > endOfQuantum ifTrue: [
			result nextPut: maxThisQuantum.
			maxThisQuantum _ 0.
			endOfQuantum _ endOfQuantum + samplesPerQuantum].
		s _ data at: i.
		s < 0 ifTrue: [s _ 0 - s].
		s > maxThisQuantum ifTrue: [maxThisQuantum _ s]].
	WaveEditor openOn: result contents.
! !

!WaveEditor methodsFor: 'menu' stamp: 'dgd 9/19/2003 12:48'!
showFFTAtCursor

	| data start availableSamples nu n fft r |
	data _ graph data.
	start _ graph cursor max: 1.
	availableSamples _ (data size - start) + 1.
	nu _ 12.
	nu > (availableSamples highBit - 1) ifTrue:
		[^ self inform: 'Too few samples after the cursor to take an FFT.' translated].
	n _ 2 raisedTo: nu.
	fft _ FFT new nu: nu.
	fft realData: ((start to: start + n - 1) collect: [:i | data at: i]).
	fft transformForward: true.
	r _ (1 to: n // 2) collect:
		[:i | ((fft realData at: i) squared + (fft imagData at: i) squared) sqrt].
	WaveEditor openOn: r.

! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:48'!
trimAfterCursor

	graph data: (graph data copyFrom: 1 to: graph cursor).
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:52'!
trimBeforeCursor

	graph data: (graph data copyFrom: graph cursor to: graph data size).
	graph cursor: 1.

! !


!WaveEditor methodsFor: 'other' stamp: 'jm 7/30/1998 18:51'!
autoCorrolationBetween: index1 and: index2 length: length
	"Answer the cummulative error between the portions of my waveform starting at the given two indices and extending for the given length. The larger this error, the greater the difference between the two waveforms."

	| data error i1 e |
	data _ graph data.
	error _ 0.
	i1 _ index1.
	index2 to: (index2 + length - 1) do: [:i2 |
		e _ (data at: i1) - (data at: i2).
		e < 0 ifTrue: [e _ 0 - e].
		error _ error + e.
		i1 _ i1 + 1].
	^ error
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 7/28/1998 02:29'!
errorBetween: sampleArray1 and: sampleArray2
	"Answer the cummulative error between the two sample arrays, which are assumed to be the same size."

	| error e |
	error _ 0.
	1 to: sampleArray1 size do: [:i |
		e _ (sampleArray1 at: i) - (sampleArray2 at: i).
		e < 0 ifTrue: [e _ 0 - e].
		error _ error + e].
	^ error
! !

!WaveEditor methodsFor: 'other' stamp: 'dgd 2/22/2003 18:59'!
findPossibleLoopStartsFrom: index 
	"Assume loopEnd is one sample before a zero-crossing."

	| r postLoopCycleStart i postLoopCycleLength cycleLength cycleCount err oldI |
	r := OrderedCollection new.

	"Record the start and length of the first cycle after the loop endpoint."
	postLoopCycleStart := loopEnd + 1.	"Assumed to be a zero-crossing."
	i := self zeroCrossingAfter: postLoopCycleStart 
						+ (0.9 * samplingRate / perceivedFrequency) asInteger.
	postLoopCycleLength := i - loopEnd - 1.

	"Step backwards one cycle at a time, using zero-crossings to find the
	 beginning of each cycle, and record the auto-corrolation error between
	 each cycle and the cycle following the loop endpoint. Assume pitch may shift gradually."
	i := self zeroCrossingAfter: postLoopCycleStart 
						- (1.1 * postLoopCycleLength) asInteger.
	cycleLength := postLoopCycleStart - i.
	cycleCount := 1.
	[cycleLength > 0] whileTrue: 
			[err := self 
						autoCorrolationBetween: i
						and: postLoopCycleStart
						length: postLoopCycleLength.
			r add: (Array 
						with: i
						with: err
						with: cycleCount
						with: ((loopEnd - i) asFloat / self samplingRate roundTo: 0.01)).
			oldI := i.
			i := self zeroCrossingAfter: oldI - (1.1 * cycleLength) asInteger.
			cycleLength := oldI - i.	"will be zero when start of data is encountered"
			cycleCount := cycleCount + 1].
	r := r asSortedCollection: [:e1 :e2 | (e1 second) < (e2 second)].
	^r asArray! !

!WaveEditor methodsFor: 'other' stamp: 'jm 8/17/1998 11:27'!
fractionalLoopStartAt: index
	"Answer the fractional index starting point near the given integral index that results in the closest match with the cycle following the loop end."
	"Note: could do this more efficiently by sliding downhill on the error curve to find lowest error."

	| oneCycle w1 minErr w2 err bestIndex |
	oneCycle _ (samplingRate / perceivedFrequency) rounded.
	w1 _ self interpolatedWindowAt: loopEnd + 1 width: oneCycle.
	minErr _ SmallInteger maxVal.
	((index - 2) max: 1) to: ((index + 2) min: graph data size) by: 0.01 do: [:i |
		w2 _ self interpolatedWindowAt: i width: oneCycle.
		err _ self errorBetween: w1 and: w2.
		err < minErr ifTrue: [
			bestIndex _ i.
			minErr _ err]].
	^ bestIndex
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 7/31/1998 11:54'!
interpolatedWindowAt: index width: nSamples
	"Return an array of N samples starting at the given index in my data."

	| scale data baseIndex scaledFrac scaledOneMinusFrac prevSample nextSample v |
	scale _ 10000.
	data _ graph data.
	index isInteger
		ifTrue: [^ (index to: index + nSamples - 1) collect: [:i | data at: i]].
	baseIndex _ index truncated.
	scaledFrac _ ((index asFloat - baseIndex) * scale) truncated.
	scaledOneMinusFrac _ scale - scaledFrac.
	prevSample _ data at: baseIndex.
	^ (baseIndex + 1 to: baseIndex + nSamples) collect: [:i |
		nextSample _ data at: i.
		v _ ((nextSample * scaledFrac) + (prevSample * scaledOneMinusFrac)) // scale.
		prevSample _ nextSample.
		v].
! !

!WaveEditor methodsFor: 'other' stamp: 'gm 2/27/2003 23:31'!
normalize: sampleArray 
	"Return a copy of the given sample array scaled to use the maximum 16-bit sample range. Remove any D.C. offset."

	| max scale out |
	max := 0.
	sampleArray do: 
			[:s | 
			max _ max max: s abs].
	scale := ((1 << 15) - 1) asFloat / max.
	out := sampleArray species new: sampleArray size.
	1 to: sampleArray size
		do: [:i | out at: i put: (scale * (sampleArray at: i)) truncated].
	^out! !

!WaveEditor methodsFor: 'other' stamp: 'jm 6/30/1998 16:11'!
scrollTime: relativeValue

	graph startIndex: relativeValue * (graph data size - (graph width // 2)).
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 9/20/1998 09:13'!
stretch: sampleArray by: stretchFactor
	"Return an array consisting of the given samples \stretched in time by the given factor."

	| out end incr i frac index |
	out _ OrderedCollection new: (stretchFactor * sampleArray size) asInteger + 1.
	end _ (sampleArray size - 1) asFloat.
	incr _ 1.0 / stretchFactor.
	i _ 1.0.
	[i < end] whileTrue: [
		frac _ i fractionPart.
		index _ i truncated.
		i _ i + incr.
		out addLast:
			(((1.0 - frac) * (sampleArray at: index)) + (frac * (sampleArray at: index + 1))) rounded].
	^ out asArray
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 8/10/1998 15:08'!
zeroCrossingAfter: index
	"Find the index of the next negative-to-non-negative transition at or after the current index. The result is the index, i, of a zero crossing such that the sample at i-1 is negative and the sample at i is zero or positive. Answer the index of the last sample if the end of the array is encountered before finding a zero crossing."

	| data end i |
	data _ graph data.
	end _ data size.
	index <= 1 ifTrue: [^ 1].
	i _ index - 1.
	[(i <= end) and: [(data at: i) >= 0]] whileTrue: [i _ i + 1].  "find next negative sample"
	i >= end ifTrue: [^ end].

	i _ i + 1.
	[(i <= end) and: [(data at: i) < 0]] whileTrue: [i _ i + 1].  "find next non-negative sample"
	^ i
! !


!WaveEditor methodsFor: 'stepping and presenter' stamp: 'di 6/21/1999 17:59'!
step

	keyboard soundPrototype: self makeLoopedSampledSound! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WaveEditor class
	instanceVariableNames: ''!

!WaveEditor class methodsFor: 'instance creation' stamp: 'jm 9/6/1999 11:21'!
openOn: dataCollection
	"Open a new WaveEditor on the given sequencable collection of data."

	^ (self new data: dataCollection) openInWorld
! !


!WaveEditor class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 14:52'!
descriptionForPartsBin
	^ self partName:	'WaveEditor'
		categories:		#('Multimedia')
		documentation:	'A workbench for seing and editing wave forms'! !
SoundCodec subclass: #WaveletCodec
	instanceVariableNames: 'fwt samplesPerFrame nLevels alpha beta'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!WaveletCodec commentStamp: '<historical>' prior: 0!
The Wavelet codec performs a wavelet transform on the original data.  It then achieves its compression by thresholding the transformed data, converting all values below a given magnitude to zero, and then run-coding the resulting data.  The run-coding provides automatic variable compression depending on the parameters chosen.

As is, this codec achieves reasonable reproduction at 10:1 compression, although the quality from the GSMCodec is definitely better.  I feel that the quality would be comparable if uLaw scaling were introduced prior to thresholding.

The nice thing about using wavelets is there are numerous factors to play with for better performance:
	nLevels - the "order" of the transform performed
	alpha and beta - these specify the wavelet shape (some are better for speech)
	the actual threshold used
By simply changing these parameters, one can easily vary the compression achieved from 5:1 to 50:1, and listen to the quality at each step.

The specific format for an encoded buffer is as follows:
	4 bytes: frameCount.
	4 bytes: samplesPerFrame.
	4 bytes: nLevels.
	4 bytes: alpha asIEEE32BitWord.
	4 bytes: beta asIEEE32BitWord.
	frameCount occurrences of...
		2 bytes: frameSize in bytes, not including these 2
			may be = 0 for complete silence, meaning no scale even.
		4 bytes: scale asIEEE32BitWord.
		A series of 1- or 2-byte values encoded as follows:
			0-111: 	a run of N+1 consecutive 0's;
			112-127:	a run of (N-112)*256 + nextByte + 1 consecutive 0's;
			128-255:	a 15-bit signed value = (N*256 + nextByte) - 32768 - 16384.!


!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 14:22'!
bytesPerEncodedFrame
	"Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."

	^ 0
! !

!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
	"Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	| frameBase coeffArray scale i c nullCount samples sourceFrameEnd frameSize inStream val |
	inStream := ReadStream on: srcByteArray from: srcIndex to: srcByteArray size.
	"frameCount := " inStream nextNumber: 4.
	samplesPerFrame := inStream nextNumber: 4.
	nLevels := inStream nextNumber: 4.
	alpha := Float fromIEEE32Bit: (inStream nextNumber: 4).
	beta := Float fromIEEE32Bit: (inStream nextNumber: 4).
	fwt ifNil:
		["NOTE: This should read parameters from the encoded data"
		fwt := FWT new.
		fwt nSamples: samplesPerFrame nLevels: nLevels.
		fwt setAlpha: alpha beta: beta].
	frameBase := dstIndex.
	coeffArray := fwt coeffs.  "A copy that we can modify"

	1 to: frameCount do:
		[:frame | 

		"Decode the scale for this frame"
		frameSize := inStream nextNumber: 2.
		sourceFrameEnd := frameSize + inStream position.
		scale := Float fromIEEE32Bit: (inStream nextNumber: 4).

		"Expand run-coded samples to scaled float values."
		i := 5.
		[i <= coeffArray size]
			whileTrue:
			[c := inStream next.
			c < 128
				ifTrue: [nullCount := c < 112
							ifTrue: [c + 1]
							ifFalse: [(c-112)*256 + inStream next + 1].
						i to: i + nullCount - 1 do: [:j | coeffArray at: j put: 0.0].
						i := i + nullCount]
				ifFalse: [val := (c*256 + inStream next) - 32768 - 16384.
						coeffArray at: i put: val * scale.
						i := i + 1]].

		"Copy float values into the wavelet sample array"		
			fwt coeffs: coeffArray.

		"Compute the transform"
		fwt transformForward: false.

		"Determine the scale for this frame"
		samples := fwt samples.
		samples size = samplesPerFrame ifFalse: [self error: 'frame size error'].
		1 to: samples size do:
			[:j | dstSoundBuffer at: frameBase + j - 1 put: (samples at: j) asInteger].

		inStream position = sourceFrameEnd ifFalse: [self error: 'frame size error'].
		frameBase := frameBase + samplesPerFrame].

	^ Array with: inStream position + 1 - srcIndex
			with: frameBase - dstIndex! !

!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
	"Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	| frameBase coeffs maxVal minVal c scale nullCount frameI outFrameSize threshold sm outStream cMin val |
	threshold := 2000.
	fwt ifNil:
		[samplesPerFrame := self samplesPerFrame.
		nLevels := 8.
		"Here are some sample mother wavelets, with the compression achieved on a
		sample of my voice at a threshold of 2000:
									compression achieved "
		alpha := 0.0.  beta := 0.0.		"12.1"
		alpha := 1.72.  beta := 1.51.	"14.0"
		alpha := -1.86.  beta := -1.53.	"14.4"
		alpha := 1.28.  beta := -0.86.	"15.9"
		alpha := -1.15.  beta := 0.69.	"16.0"
		fwt := FWT new.
		fwt nSamples: samplesPerFrame nLevels: nLevels.
		fwt setAlpha: alpha beta: beta].

	(outStream := WriteStream on: dstByteArray from: dstIndex to: dstByteArray size)
		nextNumber: 4 put: frameCount;
		nextNumber: 4 put: samplesPerFrame;
		nextNumber: 4 put: nLevels;
		nextNumber: 4 put: alpha asIEEE32BitWord;
		nextNumber: 4 put: beta asIEEE32BitWord.
	frameBase := srcIndex.
	1 to: frameCount do:
		[:frame | 

		"Copy float values into the wavelet sample array"		
		fwt samples: ((frameBase to: frameBase + samplesPerFrame-1) 
				collect: [:i | (srcSoundBuffer at: i) asFloat]).

		"Compute the transform"
		fwt transformForward: true.

		frameI := outStream position+1.  "Reserve space for frame size"
		outStream nextNumber: 2 put: 0.

		"Determine and output the scale for this frame"
		coeffs := fwt coeffs.
		maxVal := 0.0.  minVal := 0.0.
		5 to: coeffs size do:
			[:i | c := coeffs at: i.
			c > maxVal ifTrue: [maxVal := c].
			c < minVal ifTrue: [minVal := c]].
		scale := (maxVal max: minVal negated) / 16000.0.  "Will scale all to -16k..16k: 15 bits"
		outStream nextNumber: 4 put: scale asIEEE32BitWord.

		"Copy scaled values, with run-coded sequences of 0's, to destByteArray"
		nullCount := 0.
		cMin := threshold / scale.
		5 to: coeffs size do:
			[:i | c := (coeffs at: i) / scale.
			c abs < cMin
			ifTrue: ["Below threshold -- count nulls."
					nullCount := nullCount + 1]
			ifFalse: ["Above threshold -- emit prior null count and this sample."
					nullCount > 0 ifTrue:
						[nullCount <= 112
						ifTrue: [outStream nextNumber: 1 put: nullCount-1]
						ifFalse: [outStream nextNumber: 2 put: (112*256) + nullCount-1].
						nullCount := 0].
						val := c asInteger + 16384 + 32768.  "Map -16k..16k into 32k..64k"
						outStream nextNumber: 2 put: val]].

					nullCount > 0 ifTrue:
						[nullCount <= 112
						ifTrue: [outStream nextNumber: 1 put: nullCount-1]
						ifFalse: [outStream nextNumber: 2 put: (112*256) + nullCount-1]].
		outFrameSize := outStream position+1 - frameI - 2.  "Write frame size back at the beginning"
		(WriteStream on: dstByteArray from: frameI to: dstByteArray size)
			nextNumber: 2 put: outFrameSize.
		frameBase := frameBase + samplesPerFrame].

"This displays a temporary indication of compression achieved"
sm := TextMorph new contents: (((frameBase - srcIndex) *2.0 / (outStream position+1 - dstIndex) truncateTo: 0.1) printString , ' : 1') asText allBold.
sm position: Sensor cursorPoint + (-20@30).
ActiveWorld addMorph: sm.
World doOneCycleNow.
sm delete.

	outStream position > dstByteArray size ifTrue:
		["The calling routine only provides buffer space for compression of 2:1 or better.  If you are just testing things, you can increase it to, eg, codeFrameSize := frameSize*3, which would be sufficient for a threshold of 0 (lossless conversion)."
		self error: 'Buffer overrun'].

	^ Array with: frameBase - srcIndex
			with: outStream position+1 - dstIndex! !

!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 16:49'!
frameCount: aByteArray
	"Compute the frame count for this byteArray.  This default computation will have to be overridden by codecs with variable frame sizes."

	^ (ReadStream on: aByteArray) nextNumber: 4.
! !

!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 14:17'!
samplesPerFrame
	"Answer the number of sound samples per compression frame."

	^ 4096
! !
Array variableSubclass: #WeakActionSequence
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!

!WeakActionSequence methodsFor: 'converting' stamp: 'rw 4/27/2002 07:44'!
asActionSequence

	^self! !

!WeakActionSequence methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'!
asActionSequenceTrappingErrors

	^WeakActionSequenceTrappingErrors withAll: self! !

!WeakActionSequence methodsFor: 'converting' stamp: 'nk 7/21/2003 15:16'!
asMinimalRepresentation

	| valid |
	valid := self select: [:e | e isValid ].
	valid size = 0
		ifTrue: [^nil].
	valid size = 1
		ifTrue: [^valid first].
	^valid! !


!WeakActionSequence methodsFor: 'evaluating' stamp: 'nk 7/21/2003 15:17'!
value
    "Answer the result of evaluating the elements of the receiver.
	Actually, return just the last result."

    | answer |
    self do:
        [:each | each isValid ifTrue: [answer := each value]].
    ^answer! !

!WeakActionSequence methodsFor: 'evaluating' stamp: 'nk 7/21/2003 15:17'!
valueWithArguments: anArray

	"Return the last result"

    | answer |
    self do:
        [:each |
        	each isValid ifTrue: [answer := each valueWithArguments: anArray]].
    ^answer! !


!WeakActionSequence methodsFor: 'printing' stamp: 'rw 4/27/2002 07:46'!
printOn: aStream

	self size < 2 ifTrue: [^super printOn: aStream].
	aStream nextPutAll: '#('.
	self
		do: [:each | each printOn: aStream]
		separatedBy: [aStream cr].
	aStream nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeakActionSequence class
	instanceVariableNames: ''!
WeakActionSequence variableSubclass: #WeakActionSequenceTrappingErrors
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!WeakActionSequenceTrappingErrors methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'!
asActionSequenceTrappingErrors

	^self! !


!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'rw 8/6/2003 12:09'!
value
	"Do the same as my parent, but make sure that all actions that do not  
	give errors are evaluated before resignaling the ones that gave errors  
	(giving the chance to clients to handle them)."

	^self valueStartingFrom: 1! !

!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'nk 9/6/2004 08:22'!
valueStartingFrom: startIndex
	"Do the same as my parent, but make sure that all actions that do not 
	give errors are evaluated before resignaling the ones that gave errors 
	(giving the chance to clients to handle them)."

	"Note: I currently trap Halt,Error so that I am sure to get a Halt event in case of a Halt. This is being fixed in the exception system - when the fix is done it will be enough to capture only Error."

	| each answer |
	startIndex to: self size do: [:index |
		each := self at: index.
		each isReceiverOrAnyArgumentGarbage ifFalse: [
			[answer _ each value]
				on: Halt, Error
				do: [:exc | 
						self valueStartingFrom: index + 1.
						exc pass]]].
	^ answer! !

!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'rw 8/6/2003 12:07'!
valueWithArguments: anArray 
	"Do the same as my parent, but make sure that all actions that do not 
	give errors are evaluated before resignaling the ones that gave errors 
	(giving the chance to clients to handle them)."

	^self valueWithArguments: anArray startingFrom: 1! !

!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'nk 9/6/2004 08:22'!
valueWithArguments: anArray startingFrom: startIndex
	"Do the same as my parent, but make sure that all actions that do not 
	give errors are evaluated before resignaling the ones that gave errors 
	(giving the chance to clients to handle them)."

	"Note: I currently trap Halt,Error so that I am sure to get a Halt event in case of a Halt. This is being fixed in the exception system - when the fix is done it will be enough to capture only Error."

	| each answer |
	startIndex to: self size do: [:index |
		each := self at: index.
		each isReceiverOrAnyArgumentGarbage ifFalse: [
			[answer _ each valueWithArguments: anArray]
				on: Halt, Error
				do: [:exc | 
						self valueWithArguments: anArray startingFrom: index + 1.
						exc pass]]].
	^ answer! !
Array weakSubclass: #WeakArray
	instanceVariableNames: ''
	classVariableNames: 'FinalizationDependents FinalizationLock FinalizationProcess FinalizationSemaphore IsFinalizationSupported'
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakArray commentStamp: '<historical>' prior: 0!
WeakArray is an array which holds only weakly on its elements. This means whenever an object is only referenced by instances of WeakArray it will be garbage collected.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeakArray class
	instanceVariableNames: ''!

!WeakArray class methodsFor: 'accessing' stamp: 'ar 10/8/1998 11:17'!
addWeakDependent: anObject
	| finished index weakDependent |
	self isFinalizationSupported ifFalse:[^self].
	FinalizationLock critical:[
		finished := false.
		index := 0.
		[index := index + 1.
		finished not and:[index <= FinalizationDependents size]] whileTrue:[
			weakDependent := FinalizationDependents at: index.
			weakDependent isNil ifTrue:[
				FinalizationDependents at: index put: anObject.
				finished := true.
			].
		].
		finished ifFalse:[
			"Grow linearly"
			FinalizationDependents := FinalizationDependents, (WeakArray new: 10).
			FinalizationDependents at: index put: anObject.
		].
	] ifError:[:msg :rcvr| rcvr error: msg].! !

!WeakArray class methodsFor: 'accessing' stamp: 'ar 10/7/1998 15:30'!
isFinalizationSupported
	"Check if this VM supports the finalization mechanism"
	| tempObject |
	IsFinalizationSupported ifNotNil:[^IsFinalizationSupported].
	tempObject _ WeakArray new: 1.
	"Check if the class format 4 is correctly understood by the VM.
	If the weak class support is not installed then the VM will report
	any weak class as containing 32bit words - not pointers"
	(tempObject at: 1) = nil 
		ifFalse:[^IsFinalizationSupported _false].
	"Check if objects are correctly freed"
	self pvtCreateTemporaryObjectIn: tempObject.
	Smalltalk garbageCollect.
	^IsFinalizationSupported _ (tempObject at: 1) == nil! !

!WeakArray class methodsFor: 'accessing' stamp: 'ar 10/8/1998 11:17'!
removeWeakDependent: anObject
	self isFinalizationSupported ifFalse:[^self].
	FinalizationLock critical:[
		1 to: FinalizationDependents size do:[:i|
			((FinalizationDependents at: i) == anObject) ifTrue:[
				FinalizationDependents at: i put: nil.
			].
		].
	] ifError:[:msg :rcvr| rcvr error: msg].! !

!WeakArray class methodsFor: 'accessing' stamp: 'nk 10/28/2000 20:26'!
runningFinalizationProcess
	"Answer the FinalizationProcess I am running, if any"
	^FinalizationProcess! !


!WeakArray class methodsFor: 'class initialization' stamp: 'nk 6/21/2004 10:22'!
initialize
	"WeakArray initialize"

	"Do we need to initialize specialObjectsArray?"
	Smalltalk specialObjectsArray size < 42 
		ifTrue:[Smalltalk recreateSpecialObjectsArray].

	Smalltalk addToStartUpList: self.
	self restartFinalizationProcess.! !


!WeakArray class methodsFor: 'system startup' stamp: 'nk 6/21/2004 09:22'!
startUp: resuming
	resuming ifFalse: [ ^self ].
	self restartFinalizationProcess.! !


!WeakArray class methodsFor: 'private' stamp: 'di 5/21/2001 21:49'!
finalizationProcess

	[true] whileTrue:
		[FinalizationSemaphore wait.
		FinalizationLock critical:
			[FinalizationDependents do:
				[:weakDependent |
				weakDependent ifNotNil:
					[weakDependent finalizeValues.
					"***Following statement is required to keep weakDependent
					from holding onto its value as garbage.***"
					weakDependent _ nil]]]
			ifError:
			[:msg :rcvr | rcvr error: msg].
		].
! !

!WeakArray class methodsFor: 'private' stamp: 'ar 10/7/1998 15:24'!
pvtCreateTemporaryObjectIn: tempObject
	"We have to create the temporary object in a separate stack frame"
	tempObject at: 1 put: Object new! !

!WeakArray class methodsFor: 'private' stamp: 'nk 6/21/2004 10:22'!
restartFinalizationProcess
	"kill any old process, just in case"
	FinalizationProcess
		ifNotNil: [FinalizationProcess terminate.
			FinalizationProcess := nil].

	"Check if Finalization is supported by this VM"
	IsFinalizationSupported := nil.
	self isFinalizationSupported
		ifFalse: [^ self].

	FinalizationSemaphore := Smalltalk specialObjectsArray at: 42.
	FinalizationDependents ifNil: [FinalizationDependents := WeakArray new: 10].
	FinalizationLock := Semaphore forMutualExclusion.
	FinalizationProcess := [self finalizationProcess]
		forkAt: Processor userInterruptPriority! !
WeakKeyDictionary subclass: #WeakIdentityKeyDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakIdentityKeyDictionary commentStamp: '<historical>' prior: 0!
This class represents an identity dictionary with weak keys.!


!WeakIdentityKeyDictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:44'!
scanFor: anObject
	"ar 10/21/2000: The method has been copied to this location to indicate that whenever #scanFor: changes #scanForNil: must be changed in the receiver as well."
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish hash |
	finish _ array size.
	finish > 4096
		ifTrue: [hash _ anObject identityHash * (finish // 4096)]
		ifFalse: [hash _ anObject identityHash].
	start _ (hash \\ finish) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element key == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element key == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!WeakIdentityKeyDictionary methodsFor: 'private' stamp: 'ar 7/1/2003 15:15'!
scanForNil: anObject
	"Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot."
	| start finish hash |
	finish _ array size.
	finish > 4096
		ifTrue: [hash _ anObject identityHash * (finish // 4096)]
		ifFalse: [hash _ anObject identityHash].
	start _ (hash \\ array size) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | (array at: index) == nil ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | (array at: index) == nil ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
ClassTestCase subclass: #WeakIdentityKeyDictionaryTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Weak'!

!WeakIdentityKeyDictionaryTest methodsFor: 'tests' stamp: 'md 7/15/2006 18:02'!
testNoNils
	| d |
	d := WeakIdentityKeyDictionary new
	at: 'hello' copy put: 'world';
		yourself.
	Smalltalk garbageCollect.
	self deny: (d keys includes: nil)! !
Association subclass: #WeakKeyAssociation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!WeakKeyAssociation commentStamp: '<historical>' prior: 0!
I am an association holding only weakly on my key.!


!WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:54'!
key
	^key isNil
		ifTrue:[nil]
		ifFalse:[key at: 1]! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:45'!
key: aKey
	key := WeakArray with: aKey! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: 'raok 11/29/2002 14:49'!
key: aKey value: anObject
	key := WeakArray with: aKey.
	value := anObject.! !


!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:45'!
< aLookupKey 
	"Refer to the comment in Magnitude|<."

	^self key < aLookupKey key! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'!
= aLookupKey

	self species = aLookupKey species
		ifTrue: [^self key = aLookupKey key]
		ifFalse: [^false]! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'!
hash
	"Hash is reimplemented because = is implemented."

	^self key hash! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^self key hashMappedBy: map! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:47'!
identityHashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^ self key identityHashMappedBy: map! !


!WeakKeyAssociation methodsFor: 'printing' stamp: 'ar 3/21/98 15:53'!
printOn: aStream
	self key printOn: aStream.
	aStream nextPutAll: '->'.
	self value printOn: aStream! !

!WeakKeyAssociation methodsFor: 'printing' stamp: 'ar 3/21/98 15:53'!
storeOn: aStream
	aStream 
		nextPut: $(;
		nextPutAll: self class name;
		nextPutAll:' key: '.
	self key storeOn: aStream.
	aStream nextPutAll: ' value: '.
	self value storeOn: aStream.
	aStream nextPut: $)! !
Dictionary subclass: #WeakKeyDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakKeyDictionary commentStamp: '<historical>' prior: 0!
I am a dictionary holding only weakly on my keys. This is a bit dangerous since at any time my keys can go away. Clients are responsible to register my instances by WeakArray such that the appropriate actions can be taken upon loss of any keys.

See WeakRegistry for an example of use.
!


!WeakKeyDictionary methodsFor: 'accessing' stamp: 'ar 3/21/98 16:02'!
at: key put: anObject 
	"Set the value at key to be anObject.  If key is not found, create a new
	entry for key and set is value to anObject. Answer anObject."
	| index element |
	key isNil ifTrue:[^anObject].
	index _ self findElementOrNil: key.
	element _ array at: index.
	element == nil
		ifTrue: [self atNewIndex: index put: (WeakKeyAssociation key: key value: anObject)]
		ifFalse: [element value: anObject].
	^ anObject! !

!WeakKeyDictionary methodsFor: 'accessing' stamp: 'ar 2/11/2001 02:21'!
keysDo: aBlock 
	"Evaluate aBlock for each of the receiver's keys."
	self associationsDo: [:association | 
		association key ifNotNil:[aBlock value: association key]].! !


!WeakKeyDictionary methodsFor: 'adding' stamp: 'ar 3/21/98 16:00'!
add: anAssociation
	self at: anAssociation key put: anAssociation value.
	^ anAssociation! !


!WeakKeyDictionary methodsFor: 'finalization' stamp: 'ar 10/21/2000 20:00'!
finalizeValues
	"remove all nil keys and rehash the receiver afterwards"
	| assoc |
	1 to: array size do:[:i|
		assoc _ array at: i.
		(assoc notNil and:[assoc key == nil]) ifTrue:[array at: i put: nil].
	].
	self rehash.! !

!WeakKeyDictionary methodsFor: 'finalization' stamp: 'ar 10/21/2000 20:01'!
finalizeValues: finiObjects
	"Remove all associations with key == nil and value is in finiObjects.
	This method is folded with #rehash for efficiency."
	| oldArray assoc newIndex |
	oldArray _ array.
	array _ Array new: oldArray size.
	tally _ 0.
	1 to: array size do:[:i|
		assoc _ oldArray at: i.
		assoc ifNotNil:[
			(assoc key == nil and:[finiObjects includes: assoc value]) ifFalse:[
				newIndex _ self scanForNil: assoc key.
				self atNewIndex: newIndex put: assoc].
		].
	].! !


!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:58'!
fixCollisionsFrom: oldIndex
	"The element at index has been removed and replaced by nil."
	self rehash. "Do it the hard way - we may have any number of nil keys and #rehash deals with them"! !

!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:56'!
rehash
	"Rehash the receiver. Reimplemented to allow for multiple nil keys"
	| oldArray assoc newIndex |
	oldArray _ array.
	array _ Array new: oldArray size.
	tally _ 0.
	1 to: array size do:[:i|
		assoc _ oldArray at: i.
		assoc ifNotNil:[
			newIndex _ self scanForNil: assoc key.
			self atNewIndex: newIndex put: assoc.
		].
	].! !

!WeakKeyDictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:44'!
scanFor: anObject
	"ar 10/21/2000: The method has been copied to this location to indicate that whenever #scanFor: changes #scanForNil: must be changed in the receiver as well."
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	finish _ array size.
	start _ (anObject hash \\ finish) + 1.
	
	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element key = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element key = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:46'!
scanForNil: anObject
	"Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot."
	| start finish |
	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | (array at: index) == nil ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | (array at: index) == nil ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
WeakIdentityKeyDictionary subclass: #WeakKeyToCollectionDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakKeyToCollectionDictionary commentStamp: '<historical>' prior: 0!
This class represents an identity dictionary with weak keys, whose values are collections. 
Keys not in the dictionary are mapped to the empty collection.  Conversely, if a collection becomes empty, the mapping can be removed to save time and space.  However, because this requires re-hashing, it does not pay to do this to eagerly.!


!WeakKeyToCollectionDictionary methodsFor: 'as yet unclassified' stamp: 'apb 7/12/2004 23:47'!
finalizeValues 
	self rehash! !

!WeakKeyToCollectionDictionary methodsFor: 'as yet unclassified' stamp: 'apb 7/13/2004 00:17'!
rehash
	"Rehash the receiver. Reimplemented to remove nils from the collections
	that appear as values, and to entirely remove associations with empty collections 
	as values."
	| oldArray assoc cleanedValue newIndex |
	oldArray := array.
	array := Array new: oldArray size.
	tally := 0.
	1 to: array size do: [:i | 
			assoc := oldArray at: i.
			(assoc notNil
					and: [(cleanedValue := assoc value copyWithout: nil) notEmpty])
				ifTrue: [newIndex := self scanForNil: assoc key.
					assoc value: cleanedValue.
					self atNewIndex: newIndex put: assoc]]! !
Object weakSubclass: #WeakMessageSend
	instanceVariableNames: 'selector shouldBeNil arguments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!WeakMessageSend commentStamp: 'tlk 5/5/2006 12:39' prior: 0!
Instances of WeakMessageSend encapsulate message sends to objects, like MessageSend. Unlike MessageSend it is not necessarily a valid mesage.  A request to value only results in a send if infact it is valid. 

See MessageSendComments also. WeakMessageSend is used primarily for event regristration. 

Unlike MessageSend WeakMessageSend stoes receiver (object receiving the message send) as a the first and only element of its array as opposed to a named ivar.
But like MessageSend, it does have
 selector		Symbol -- message selector
 arguments		Array -- bound arguments
and it also has
 shouldBeNil		Boolean --  used to ensure array of arguments is not all nils!


!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 09:54'!
arguments
	^arguments ifNil: [ Array new ]
! !

!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 09:38'!
arguments: anArray
	arguments _ WeakArray withAll: anArray.
	"no reason this should be a WeakArray"
	shouldBeNil _ Array withAll: (anArray collect: [ :ea | ea isNil ]).
! !

!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 07:54'!
receiver
	^self at: 1
! !

!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 07:54'!
receiver: anObject
	self at: 1 put: anObject
! !

!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 07:54'!
selector
	^selector
! !

!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 07:55'!
selector: aSymbol
	selector _ aSymbol
! !


!WeakMessageSend methodsFor: 'comparing' stamp: 'nk 4/25/2002 08:05'!
= anObject
	"Compare equal to equivalent MessageSend"
	^ anObject isMessageSend
		and: [self receiver == anObject receiver
		and: [selector == anObject selector
		and: [(Array withAll: arguments) = (Array withAll: anObject arguments)]]]
! !

!WeakMessageSend methodsFor: 'comparing' stamp: 'nk 4/25/2002 09:31'!
hash
	"work like MessageSend>>hash"
	^self receiver hash bitXor: selector hash
! !


!WeakMessageSend methodsFor: 'converting' stamp: 'nk 4/25/2002 09:33'!
asMessageSend
	^MessageSend receiver: self receiver selector: selector arguments: (Array withAll: self arguments) 
! !

!WeakMessageSend methodsFor: 'converting' stamp: 'rww 10/20/2002 19:56'!
asMinimalRepresentation

	self isReceiverOrAnyArgumentGarbage
		ifTrue: [^nil]
		ifFalse:[^self].! !


!WeakMessageSend methodsFor: 'evaluating' stamp: 'nk 12/8/2002 12:15'!
value
	^ arguments isNil
		ifTrue: [self ensureReceiver
				ifTrue: [self receiver perform: selector] ifFalse: []]
		ifFalse: [self ensureReceiverAndArguments
				ifTrue: [self receiver
						perform: selector
						withArguments: (Array withAll: arguments)] ifFalse: []]! !

!WeakMessageSend methodsFor: 'evaluating' stamp: 'nk 12/8/2002 12:15'!
valueWithArguments: anArray
	self ensureReceiverAndArguments ifFalse: [ ^nil ].
	^ self receiver 
		perform: selector 
		withArguments: (self collectArguments: anArray)! !

!WeakMessageSend methodsFor: 'evaluating' stamp: 'nk 12/8/2002 12:15'!
valueWithEnoughArguments: anArray
	"call the selector with enough arguments from arguments and anArray"
	| args |
	self ensureReceiverAndArguments ifFalse: [ ^nil ].
	args _ Array new: selector numArgs.
	args replaceFrom: 1
		to: ( arguments size min: args size)
		with: arguments
		startingAt: 1.
	args size > arguments size ifTrue: [
		args replaceFrom: arguments size + 1
			to: (arguments size + anArray size min: args size)
			with: anArray
			startingAt: 1.
	].
	^ self receiver perform: selector withArguments: args
! !


!WeakMessageSend methodsFor: 'printing' stamp: 'nk 4/25/2002 09:36'!
printOn: aStream

        aStream
                nextPutAll: self class name;
                nextPut: $(.
        selector printOn: aStream.
        aStream nextPutAll: ' -> '.
        self receiver printOn: aStream.
        aStream nextPut: $)
! !


!WeakMessageSend methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'!
isMessageSend
	^true
! !

!WeakMessageSend methodsFor: 'testing' stamp: 'nk 8/24/2003 01:12'!
isValid
	^self isReceiverOrAnyArgumentGarbage not
! !


!WeakMessageSend methodsFor: '*eToys-tiles' stamp: 'nk 4/25/2002 09:34'!
asTilesIn: playerClass
	^self asMessageSend asTilesIn: playerClass
! !

!WeakMessageSend methodsFor: '*eToys-tiles' stamp: 'nk 4/25/2002 09:34'!
asTilesIn: playerClass globalNames: makeSelfGlobal
	^self asMessageSend asTilesIn: playerClass globalNames: makeSelfGlobal
! !

!WeakMessageSend methodsFor: '*eToys-tiles' stamp: 'nk 4/25/2002 09:35'!
stringFor: anObject
	^self asMessageSend stringFor: anObject
! !


!WeakMessageSend methodsFor: 'private' stamp: 'nk 4/25/2002 09:49'!
collectArguments: anArgArray
	"Private"
    | staticArgs |
    staticArgs := self arguments.
    ^(anArgArray size = staticArgs size)
        ifTrue: [anArgArray]
        ifFalse:
            [(staticArgs isEmpty
                ifTrue: [ staticArgs := Array new: selector numArgs]
                ifFalse: [staticArgs copy] )
                    replaceFrom: 1
                    to: (anArgArray size min: staticArgs size)
                    with: anArgArray
                    startingAt: 1]
! !

!WeakMessageSend methodsFor: 'private' stamp: 'nk 12/8/2002 12:13'!
ensureArguments
	"Return true if my arguments haven't gone away"
	arguments ifNotNil: [
		arguments with: shouldBeNil do: [ :arg :flag |
			arg ifNil: [ flag ifFalse: [ ^false ]]
		]
	].
	^true
! !

!WeakMessageSend methodsFor: 'private' stamp: 'nk 12/8/2002 12:13'!
ensureReceiver
	"Return true if my receiver hasn't gone away"
	^self receiver notNil
! !

!WeakMessageSend methodsFor: 'private' stamp: 'nk 12/8/2002 12:13'!
ensureReceiverAndArguments

	"Return true if my receiver hasn't gone away"
	self receiver ifNil: [ ^false ].

	"Make sure that my arguments haven't gone away"
	arguments ifNotNil: [
		arguments with: shouldBeNil do: [ :arg :flag |
			arg ifNil: [ flag ifFalse: [ ^false ]]
		]
	].

	^true
! !

!WeakMessageSend methodsFor: 'private' stamp: 'rw 4/27/2002 07:33'!
isAnyArgumentGarbage
	"Make sure that my arguments haven't gone away"
	arguments ifNotNil: [
		arguments with: shouldBeNil do: [ :arg :flag |
			(flag not and: [arg isNil])
				ifTrue: [^true]
		]
	].
	^false
! !

!WeakMessageSend methodsFor: 'private' stamp: 'rw 4/27/2002 07:31'!
isReceiverGarbage
	"Make sure that my receiver hasn't gone away"
	^self receiver isNil
! !

!WeakMessageSend methodsFor: 'private' stamp: 'rw 4/27/2002 07:34'!
isReceiverOrAnyArgumentGarbage
	"Make sure that my receiver hasn't gone away"
	^self isReceiverGarbage 
		or: [self isAnyArgumentGarbage]
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeakMessageSend class
	instanceVariableNames: ''!

!WeakMessageSend class methodsFor: 'instance creation' stamp: 'nk 4/25/2002 10:00'!
new
	^self new: 1
! !

!WeakMessageSend class methodsFor: 'instance creation' stamp: 'nk 4/25/2002 09:37'!
receiver: anObject selector: aSymbol
	^ self receiver: anObject selector: aSymbol arguments: #()
! !

!WeakMessageSend class methodsFor: 'instance creation' stamp: 'nk 4/25/2002 09:37'!
receiver: anObject selector: aSymbol argument: aParameter
	^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)
! !

!WeakMessageSend class methodsFor: 'instance creation' stamp: 'nk 4/25/2002 09:37'!
receiver: anObject selector: aSymbol arguments: anArray
	^ self new
		receiver: anObject;
		selector: aSymbol;
		arguments: anArray
! !
ClassTestCase subclass: #WeakMessageSendTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Objects'!

!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:10'!
testNoArguments
	"self run: #testNoArguments"

	| m |
	m := WeakMessageSend
			receiver: true
			selector: #yourself.
	self assert: (m value).
! !

!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:11'!
testOneArgument
	"self run: #testOneArgument"	

	| m |
	m := WeakMessageSend
		receiver: Array
		selector: #with:
		argument: 1.
	Smalltalk garbageCollectMost.
	self assert: (m value  = { 1 })
! !

!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:11'!
testOneArgumentWithGC

	| m |
	m := WeakMessageSend
		receiver: Array
		selector: #with:
		arguments: { Object new }.
	Smalltalk garbageCollectMost.
	self assert: (m value isNil)! !

!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:11'!
testReceiverWithGC

	| m |
	m := WeakMessageSend
		receiver: Object new
		selector: #isNil.
	Smalltalk garbageCollectMost.
	self assert: (m value isNil).! !

!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:11'!
testTwoArguments

	| m |
	m := WeakMessageSend
		receiver: Array
		selector: #with:with:
		arguments: { 1 . 2 }.
	Smalltalk garbageCollectMost.
	self assert: (m value = { 1 . 2 }).
! !
Collection subclass: #WeakRegistry
	instanceVariableNames: 'valueDictionary accessLock'
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakRegistry commentStamp: '<historical>' prior: 0!
I am a registry for objects needing finalization. When an object is added the object as well as its executor is stored. When the object is garbage collected, the executor can take the appropriate action for any resources associated with the object.

See also:
	Object executor
	Object actAsExecutor
	Object finalize
!


!WeakRegistry methodsFor: 'accessing' stamp: 'ar 12/12/2001 16:00'!
keys
	^self protected:[
		Array streamContents:[:s| valueDictionary keysDo:[:key| s nextPut: key]]].! !

!WeakRegistry methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:40'!
size
	^ self protected: [valueDictionary size]! !

!WeakRegistry methodsFor: 'accessing' stamp: 'ar 3/20/98 19:31'!
species
	^Set! !


!WeakRegistry methodsFor: 'adding' stamp: 'ar 3/21/98 16:33'!
add: anObject
	"Add anObject to the receiver. Store the object as well as the associated executor."
	| executor |
	executor := anObject executor.
	self protected:[
		valueDictionary at: anObject put: executor.
	].
	^anObject! !

!WeakRegistry methodsFor: 'adding' stamp: 'ar 5/19/2003 20:08'!
add: anObject executor: anExecutor
	"Add anObject to the receiver. Store the object as well as the associated executor."
	self protected:[
		valueDictionary at: anObject put: anExecutor.
	].
	^anObject! !


!WeakRegistry methodsFor: 'enumerating' stamp: 'ar 3/21/98 18:36'!
do: aBlock
	^self protected:[
		valueDictionary keysDo: aBlock.
	].
! !


!WeakRegistry methodsFor: 'finalization' stamp: 'ar 10/22/2000 20:24'!
finalizeValues
	"Some of our elements may have gone away. Look for those and activate the associated executors."
	| finiObjects |
	finiObjects := nil.
	"First collect the objects."
	self protected:[
		valueDictionary associationsDo:[:assoc|
			assoc key isNil ifTrue:[
				finiObjects isNil 
					ifTrue:[finiObjects := OrderedCollection with: assoc value]
					ifFalse:[finiObjects add: assoc value]]
		].
		finiObjects isNil ifFalse:[valueDictionary finalizeValues: finiObjects asArray].
	].
	"Then do the finalization"
	finiObjects isNil ifTrue:[^self].
	finiObjects do:[:each| each finalize].
! !


!WeakRegistry methodsFor: 'initialize' stamp: 'ar 3/21/98 16:08'!
initialize: n
	valueDictionary := WeakKeyDictionary new: n.
	accessLock := Semaphore forMutualExclusion.! !


!WeakRegistry methodsFor: 'printing' stamp: 'tk 12/5/2001 09:42'!
printElementsOn: aStream
	aStream nextPut: $(.
	accessLock 
		ifNil: [self do: [:element | aStream print: element; space]]
		ifNotNil: [aStream nextPutAll: '<this WeakRegistry is locked>; space'].
	self isEmpty ifFalse: [aStream skip: -1].
	aStream nextPut: $)! !


!WeakRegistry methodsFor: 'removing' stamp: 'ar 3/21/98 21:12'!
remove: oldObject ifAbsent: exceptionBlock
	"Remove oldObject as one of the receiver's elements."
	| removedObject |
	oldObject isNil ifTrue:[^oldObject].
	self protected:[
		removedObject := valueDictionary removeKey: oldObject ifAbsent:[nil].
	].
	^removedObject isNil
		ifTrue:[exceptionBlock value]
		ifFalse:[removedObject].
! !


!WeakRegistry methodsFor: 'private' stamp: 'ar 10/8/1998 11:18'!
protected: aBlock
	"Execute aBlock protected by the accessLock"
	^accessLock isNil
		ifTrue:[aBlock value]
		ifFalse:[accessLock critical: aBlock ifError:[:msg :rcvr| rcvr error: msg]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeakRegistry class
	instanceVariableNames: ''!

!WeakRegistry class methodsFor: 'accessing' stamp: 'ar 5/19/2003 20:10'!
default
	^Default ifNil:[Default := self new]! !


!WeakRegistry class methodsFor: 'instance creation' stamp: 'ar 3/21/98 15:32'!
new
	^self new: 5! !

!WeakRegistry class methodsFor: 'instance creation' stamp: 'ar 3/21/98 15:33'!
new: n
	| registry |
	registry := super new initialize: n.
	WeakArray addWeakDependent: registry.
	^registry! !
Set subclass: #WeakSet
	instanceVariableNames: 'flag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!

!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:15'!
add: newObject
	"Include newObject as one of the receiver's elements, but only if
	not already present. Answer newObject"

	| index |
	newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
	index _ self findElementOrNil: newObject.
	((array at: index) == flag or: [(array at: index) isNil])
		ifTrue: [self atNewIndex: index put: newObject].
	^newObject! !

!WeakSet methodsFor: 'public' stamp: 'nk 3/11/2002 20:35'!
collect: aBlock
	| each newSet |
	newSet _ self species new: self size.
	tally = 0 ifTrue: [^newSet ].
	1 to: array size do:
		[:index |
			((each _ array at: index) == nil or: [each == flag])
				ifFalse: [newSet add: (aBlock value: each)]
		].
	^newSet! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:46'!
do: aBlock
	| each |

	tally = 0 ifTrue: [^self].
	1 to: array size do:
		[:index |
			((each _ array at: index) == nil or: [each == flag])
				ifFalse: [aBlock value: each]
		]! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:13'!
do: aBlock after: anElement
	| each startIndex |

	tally = 0 ifTrue: [^self].
	startIndex _ anElement ifNil: [1] ifNotNil:
		[self findElementOrNil: anElement].
	startIndex + 1 to: array size do:
		[:index |
			((each _ array at: index) == nil or: [each == flag])
				ifFalse: [aBlock value: each]
		]! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:15'!
includes: anObject 
	^(array at: (self findElementOrNil: anObject)) ~~ flag! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 16:02'!
like: anObject
	"Answer an object in the receiver that is equal to anObject,
	nil if no such object is found. Relies heavily on hash properties"

	| index element |

	^(index _ self scanFor: anObject) = 0
		ifFalse: [(element _ array at: index) == flag ifFalse: [element]]! !

!WeakSet methodsFor: 'public' stamp: 'di 2/3/2001 16:46'!
printElementsOn: aStream
	| oldPos |
	aStream nextPut: $(.
	oldPos _ aStream position.
	self do: [:element | aStream print: element; space].
	aStream position > oldPos ifTrue: [aStream skip: -1 "remove the extra space"].
	aStream nextPut: $)! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:08'!
remove: oldObject ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: oldObject.
	(array at: index) == flag ifTrue: [ ^ aBlock value ].
	array at: index put: flag.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^oldObject! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:12'!
size
	"Careful!! Answer the maximum amount
	of elements in the receiver, not the
	exact amount"

	^tally! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:17'!
slowSize
	"Careful!! Answer the maximum amount
	of elements in the receiver, not the
	exact amount"

	tally _ array inject: 0 into:
		[:total :each | (each == nil or: [each == flag])
			ifTrue: [total] ifFalse: [total + 1]].
	^tally! !


!WeakSet methodsFor: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:33'!
inspectorClass 
	^ WeakSetInspector! !


!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 14:30'!
fixCollisionsFrom: index
	"The element at index has been removed and replaced by nil.
	This method moves forward from there, relocating any entries
	that had been placed below due to collisions with this one"

	| length oldIndex newIndex element |

	oldIndex _ index.
	length _ array size.
	[oldIndex = length
			ifTrue: [oldIndex _ 1]
			ifFalse: [oldIndex _ oldIndex + 1].
	(element _ self keyAt: oldIndex) == flag]
		whileFalse: 
			[newIndex _ self findElementOrNil: element.
			oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! !

!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 15:43'!
grow
	"Grow the elements array and reinsert the old elements"

	self growTo: array size + self growSize! !

!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 15:43'!
growTo: anInteger
	"Grow the elements array and reinsert the old elements"

	| oldElements |

	oldElements _ array.
	array _ WeakArray new: anInteger.
	array atAllPut: flag.
	tally _ 0.
	oldElements do:
		[:each | (each == flag or: [each == nil]) ifFalse: [self noCheckAdd: each]]! !

!WeakSet methodsFor: 'private' stamp: 'nice 4/4/2006 22:09'!
initialize: n
	"Initialize array to an array size of n"

	flag _ Object new.
	array _ WeakArray new: n.
	array atAllPut: flag.
	tally _ 0! !

!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 15:43'!
rehash
	self growTo: array size! !

!WeakSet methodsFor: 'private' stamp: 'md 10/5/2005 15:44'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements"

	| element start finish |

	finish _ array size.
	start _ (anObject hash \\ finish) + 1.
	
	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == flag or: [element = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == flag or: [element = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!WeakSet methodsFor: 'private' stamp: 'yo 11/11/2002 23:10'!
scanForLoadedSymbol: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements"

	| element start finish |

	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == flag or: [element asString = anObject asString])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == flag or: [element asString = anObject asString])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
SetInspector subclass: #WeakSetInspector
	instanceVariableNames: 'flagObject'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!
!WeakSetInspector commentStamp: '<historical>' prior: 0!
A verison of the SetInspector specialized for inspecting WeakSets.  It knows about the flag object used to indicate empty locations in the hash table.!


!WeakSetInspector methodsFor: 'accessing' stamp: 'apb 8/21/2004 02:46'!
fieldList
	object ifNil: [^ Set new].
	^ self baseFieldList
		, (object array
				withIndexCollect: [:each :i | (each notNil and: [each ~= flagObject]) ifTrue: [i printString]])
		  select: [:each | each notNil]! !


!WeakSetInspector methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:27'!
initialize
	super initialize.
	flagObject := object instVarNamed: 'flag'. ! !
LookupKey weakSubclass: #WeakValueAssociation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!WeakValueAssociation commentStamp: '<historical>' prior: 0!
I am a lookup key (acting like an association but) holding only weakly on my value.!


!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:11'!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	key _ aKey.
	self value: anObject! !

!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:08'!
value
	^self at: 1! !

!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:08'!
value: anObject 
	"Store the argument, anObject, as the value of the receiver."

	self at: 1 put: anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeakValueAssociation class
	instanceVariableNames: ''!

!WeakValueAssociation class methodsFor: 'as yet unclassified' stamp: 'r++ 5/27/2000 18:12'!
new
	^ self new: 1! !


!WeakValueAssociation class methodsFor: 'instance creation' stamp: 'r++ 5/27/2000 18:07'!
key: anObject value: bObject
	^ self new key: anObject value: bObject! !
Dictionary subclass: #WeakValueDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakValueDictionary commentStamp: '<historical>' prior: 0!
I am a dictionary holding only weakly on my values. Clients may expect to get a nil value for any object they request.!


!WeakValueDictionary methodsFor: 'accessing' stamp: 'ar 3/21/98 16:01'!
at: key put: anObject 
	"Set the value at key to be anObject.  If key is not found, create a new
	entry for key and set is value to anObject. Answer anObject."
	| index element |
	index _ self findElementOrNil: key.
	element _ array at: index.
	element == nil
		ifTrue: [self atNewIndex: index put: (WeakValueAssociation key: key value: anObject)]
		ifFalse: [element value: anObject].
	^ anObject! !


!WeakValueDictionary methodsFor: 'adding' stamp: 'ar 3/21/98 16:02'!
add: anAssociation
	self at: anAssociation key put: anAssociation value.
	^ anAssociation! !
AppRegistry subclass: #WebBrowser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Applications'!
Timespan subclass: #Week
	instanceVariableNames: ''
	classVariableNames: 'StartDay'
	poolDictionaries: 'ChronologyConstants'
	category: 'Kernel-Chronology'!
!Week commentStamp: 'brp 5/13/2003 09:48' prior: 0!
I represent a week.!


!Week methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:36'!
asWeek

	^ self
! !

!Week methodsFor: 'squeak protocol' stamp: 'brp 1/30/2005 09:31'!
index

	^ self asMonth dayOfWeek + self dayOfMonth - 2  // 7 + 1
! !

!Week methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:37'!
printOn: aStream

	aStream nextPutAll: 'a Week starting: '.
	self start printOn: aStream.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Week class
	instanceVariableNames: ''!

!Week class methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 09:34'!
nameOfDay: anIndex

	^ DayNames at: anIndex
! !


!Week class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:34'!
dayNames

	^ DayNames
! !

!Week class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:34'!
indexOfDay: aSymbol

	^ DayNames indexOf: aSymbol
! !

!Week class methodsFor: 'squeak protocol' stamp: 'brp 1/30/2005 09:17'!
startDay

	^ StartDay ifNil: [ StartDay
 _ DayNames first ]! !

!Week class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 09:30'!
startDay: aSymbol

	(DayNames includes: aSymbol)
		ifTrue: [ StartDay _ aSymbol ]
		ifFalse: [ self error: aSymbol, ' is not a recognised day name' ]
! !

!Week class methodsFor: 'squeak protocol' stamp: 'jf 4/23/2004 14:51'!
starting: aDateAndTime duration: aDuration
	"Override - the duration is always one week.
	 Week will start from the Week class>>startDay"

	| midnight delta adjusted |
	midnight _ aDateAndTime asDateAndTime midnight.
	delta _ ((midnight dayOfWeek + 7 - (DayNames indexOf: self startDay)) rem: 7) abs.
	adjusted _ midnight - (Duration days: delta hours: 0 minutes: 0 seconds: 0).

	^ super starting: adjusted duration: (Duration weeks: 1).! !
ClassTestCase subclass: #WeekTest
	instanceVariableNames: 'week restoredStartDay'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!

!WeekTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:42'!
classToBeTested

	^ Week! !

!WeekTest methodsFor: 'Coverage' stamp: 'brp 1/30/2005 09:21'!
selectorsToBeIgnored

	| deprecated private special |

	deprecated := #().
	private := #( #printOn: ).
	special := #( #next #do: ).

	^ super selectorsToBeIgnored, deprecated, private, special.! !


!WeekTest methodsFor: 'Running' stamp: 'brp 9/26/2004 18:52'!
setUp
	"June 1998, 5th week"

	super setUp.
	restoredStartDay := Week startDay.
	Week startDay: #Sunday.
	week := Week starting: '4 July 1998' asDate! !

!WeekTest methodsFor: 'Running' stamp: 'brp 9/26/2004 18:53'!
tearDown

	super tearDown.
	Week startDay: restoredStartDay.
	week _ nil.

! !


!WeekTest methodsFor: 'Tests' stamp: 'brp 1/30/2005 09:32'!
testEnumerating

	| days |
	days := OrderedCollection new.
	0 to: 6 do: [ :i | days add: ('28 June 1998' asDate addDays: i) ].

	week datesDo: [ :d | days remove: d ].
	
	self assert: days isEmpty.
! !

!WeekTest methodsFor: 'Tests' stamp: 'brp 1/30/2005 09:30'!
testInquiries

	self
		assert: week start asDate = '28 June 1998' asDate;
		assert: week end asDate = '4 July 1998' asDate;
		assert: week index = 5;
		assert: week duration = (7 days).
! !

!WeekTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'!
testPreviousNext
	self
		assert: week next = (Week starting: '6 July 1998' asDate);
		assert: week previous = (Week starting:  '22 June 1998' asDate)! !
PasteUpMorph subclass: #WiWPasteUpMorph
	instanceVariableNames: 'parentWorld hostWindow pendingEvent displayChangeSignatureOnEntry'
	classVariableNames: 'Debug'
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWorlds'!
!WiWPasteUpMorph commentStamp: '<historical>' prior: 0!
This subclass of PasteUpMorph provides special support for viewing of a world in an inner window (WorldWindow).!


!WiWPasteUpMorph methodsFor: 'activation' stamp: 'sw 4/25/2001 01:55'!
becomeTheActiveWorldWith: evt
	"Make the receiver become the active world, and give its hand the event provided, if not nil"

	| outerWorld |
	World == self ifTrue: [^ self].
	worldState resetDamageRecorder.	"since we may have moved, old data no longer valid"
	hostWindow setStripeColorsFrom: Color green.
	worldState canvas: nil.	"safer to start from scratch"
	displayChangeSignatureOnEntry _ Display displayChangeSignature.

	"Messy stuff to clear flaps from outer world"
	Flaps globalFlapTabsIfAny do: [:f | f changed].
	outerWorld _ World.
	World _ self.
	self installFlaps.
	World _ outerWorld.
	outerWorld displayWorld.
	World _ self.

	self viewBox: hostWindow panelRect.
	self startSteppingSubmorphsOf: self.
	self changed.
	pendingEvent _ nil.
	evt ifNotNil: [self primaryHand handleEvent: (evt setHand: self primaryHand)].

! !

!WiWPasteUpMorph methodsFor: 'activation' stamp: 'RAA 5/25/2000 15:11'!
revertToParentWorldWithEvent: evt

	"RAA 27 Nov 99 - if the display changed while we were in charge, parent may need to redraw"

	worldState resetDamageRecorder.	"Terminate local display"
	World _ parentWorld.
	World assuredCanvas.
	World installFlaps.
	hostWindow setStripeColorsFrom: Color red.
	(displayChangeSignatureOnEntry = Display displayChangeSignature) ifFalse: [
		World fullRepaintNeeded; displayWorld
	].
	evt ifNotNil: [World restartWorldCycleWithEvent: evt].

! !


!WiWPasteUpMorph methodsFor: 'event handling' stamp: 'di 11/26/1999 08:14'!
mouseDown: evt

	(World == self or: [World isNil]) ifTrue: [^ super mouseDown: evt].
	(self bounds containsPoint: evt cursorPoint) ifFalse: [^ self].

	self becomeTheActiveWorldWith: evt.
! !


!WiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 11/14/1999 12:05'!
extent: x

	super extent: x.
	self resetViewBox.! !

!WiWPasteUpMorph methodsFor: 'geometry' stamp: 'dgd 2/21/2003 23:18'!
resetViewBox
	| c |
	(c := worldState canvas) isNil ifTrue: [^self resetViewBoxForReal].
	c form == Display ifFalse: [^self resetViewBoxForReal].
	c origin = (0 @ 0) ifFalse: [^self resetViewBoxForReal].
	c clipRect extent = (self viewBox intersect: parentWorld viewBox) extent 
		ifFalse: [^self resetViewBoxForReal]! !

!WiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/6/2000 17:42'!
resetViewBoxForReal

	| newClip |
	self viewBox ifNil: [^self].
	newClip _ self viewBox intersect: parentWorld viewBox.
	worldState canvas: (
		Display getCanvas
			copyOffset:  0@0
			clipRect: newClip
	)! !


!WiWPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 5/24/2000 10:31'!
hostWindow: x

	hostWindow _ x.
	worldState canvas: nil.	"safer to start from scratch"
	self viewBox: hostWindow panelRect.
! !

!WiWPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 11/20/1999 15:11'!
initialize

	super initialize.
	parentWorld _ World.
! !


!WiWPasteUpMorph methodsFor: 'project state' stamp: 'dgd 2/21/2003 23:18'!
viewBox: newViewBox 
	| vb |
	worldState resetDamageRecorder.	"since we may have moved, old data no longer valid"
	((vb := self viewBox) isNil or: [vb ~= newViewBox]) 
		ifTrue: [worldState canvas: nil].
	worldState viewBox: newViewBox.
	bounds := newViewBox.
	worldState assuredCanvas.
	"Paragraph problem workaround; clear selections to avoid screen droppings:"
	self flag: #arNote.	"Probably unnecessary"
	worldState handsDo: [:h | h releaseKeyboardFocus].
	self fullRepaintNeeded! !


!WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 5/25/2000 15:27'!
doDeferredUpdating
	"If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature."

	PasteUpMorph disableDeferredUpdates ifTrue: [^ false].
	(Display deferUpdates: true) ifNil: [^ false].  "deferred updates not supported"

	self resetViewBox.
	^ true
! !


!WiWPasteUpMorph methodsFor: 'WiW support' stamp: 'dao 10/1/2004 13:39'!
restartWorldCycleWithEvent: evt

	"redispatch that click in outer world"

	pendingEvent _ evt.
	Project spawnNewProcessAndTerminateOld: true
! !

!WiWPasteUpMorph methodsFor: 'WiW support' stamp: 'di 11/26/1999 14:09'!
validateMouseEvent: evt

	evt isMouseDown ifFalse: [^ self].

	"any click outside returns us to our home world"
	(self bounds containsPoint: evt cursorPoint) ifFalse: [
		self revertToParentWorldWithEvent: evt.
	].! !


!WiWPasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:45'!
displayWorld

	"RAA 27 Nov 99 - if we are not active, then the parent should do the drawing"

	self flag: #bob.			"probably not needed"

	World == self ifTrue: [^super displayWorld].
	parentWorld ifNotNil: [^parentWorld displayWorld].
	^super displayWorld		"in case MVC needs it"! !

!WiWPasteUpMorph methodsFor: 'world state' stamp: 'RAA 11/23/1999 09:01'!
doOneCycle

	pendingEvent ifNotNil: [
		self primaryHand handleEvent: (pendingEvent setHand: self primaryHand).
		pendingEvent _ nil.
	].
	^super doOneCycle.! !

!WiWPasteUpMorph methodsFor: 'world state' stamp: 'sw 5/23/2001 14:23'!
goBack
	"Return to the previous project.  For the moment, this is not allowed from inner worlds"

	self inform: 'Project changes are not yet allowed
from inner worlds.'! !

!WiWPasteUpMorph methodsFor: 'world state' stamp: 'sw 5/23/2001 14:24'!
jumpToProject
	"Jump directly to another project.  However, this is not currently allowed for inner worlds"

	self inform: 'Project changes are not yet allowed
from inner worlds.'! !

!WiWPasteUpMorph methodsFor: 'world state' stamp: 'ar 3/18/2001 00:01'!
restoreDisplay

	World ifNotNil:[World restoreMorphicDisplay].	"I don't actually expect this to be called"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WiWPasteUpMorph class
	instanceVariableNames: ''!

!WiWPasteUpMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/20/1999 08:05'!
say: x

	(Debug ifNil: [Debug _ OrderedCollection new])
		add: x asString,'
'.
	Debug size > 500 ifTrue: [Debug _ Debug copyFrom: 200 to: Debug size]! !

!WiWPasteUpMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/14/1999 11:04'!
show

	Debug inspect.
	Debug _ OrderedCollection new.! !
String variableWordSubclass: #WideString
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Strings'!
!WideString commentStamp: 'yo 10/19/2004 22:34' prior: 0!
This class represents the array of 32 bit wide characters.
!


!WideString methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:14'!
at: index 
	"Answer the Character stored in the field of the receiver indexed by the argument."
	^ Character value: (self wordAt: index).
! !

!WideString methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:14'!
at: index put: aCharacter 
	"Store the Character in the field of the receiver indicated by the index."
	aCharacter isCharacter ifFalse:[self errorImproperStore].
	self wordAt: index put: aCharacter asInteger.
! !

!WideString methodsFor: 'accessing' stamp: 'yo 10/31/2002 22:29'!
byteAt: index

	| d r |
	d _ (index + 3) // 4.
	r _ (index - 1) \\ 4 + 1.
	^ (self wordAt: d) digitAt: ((4 - r) + 1).
! !

!WideString methodsFor: 'accessing' stamp: 'yo 11/3/2002 13:19'!
byteAt: index put: aByte

	| d r w |
	d _ (index + 3) // 4.
	r _ (index - 1) \\ 4 + 1.
	w _ (self wordAt: d) bitAnd: ((16rFF<<((4 - r)*8)) bitInvert32).
	w _ w + (aByte<<((4 - r)*8)).
	self basicAt: d put: w.
	^ aByte.
! !

!WideString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:22'!
byteSize

	^ self size * 4.
! !

!WideString methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:36'!
replaceFrom: start to: stop with: replacement startingAt: repStart 

	<primitive: 105>
	replacement class == String ifTrue: [
		^ self replaceFrom: start to: stop with: (replacement asWideString) startingAt: repStart.
	]. 

	^ super replaceFrom: start to: stop with: replacement startingAt: repStart.
! !

!WideString methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:14'!
wordAt: index
	<primitive: 60>
	^ (self basicAt: index).
! !

!WideString methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:14'!
wordAt: index put: anInteger
	<primitive: 61>
	self basicAt: index put: anInteger.
! !


!WideString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:46'!
asFourCode

	| result |
	self size = 1 ifFalse: [^self error: 'must be exactly four octets'].
	result _ self basicAt: 1.
	(result bitAnd: 16r80000000) = 0 
		ifFalse: [self error: 'cannot resolve fourcode'].
	(result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000].
	^ result
! !

!WideString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:47'!
asPacked

	self inject: 0 into: [:pack :next | pack _ pack * 16r100000000 + next asInteger].
! !

!WideString methodsFor: 'converting' stamp: 'yo 3/14/2005 11:41'!
copyFrom: start to: stop

	| n |
	n _ super copyFrom: start to: stop.
	n isOctetString ifTrue: [^ n asOctetString].
	^ n.
! !


!WideString methodsFor: 'testing' stamp: 'yo 7/29/2003 14:10'!
includesUnifiedCharacter

	^ self isUnicodeStringWithCJK
! !

!WideString methodsFor: 'testing' stamp: 'ar 4/12/2005 14:10'!
isUnicodeStringWithCJK

	self do: [:c |
		(c isTraditionalDomestic not and: [Unicode isUnifiedKanji: c charCode]) ifTrue: [
			^ true
		].
	].

	^ false.
! !

!WideString methodsFor: 'testing' stamp: 'ar 4/12/2005 19:52'!
isWideString
	"Answer whether the receiver is a WideString"
	^true! !


!WideString methodsFor: 'private' stamp: 'ar 4/9/2005 22:31'!
mutateJISX0208StringToUnicode

	| c |
	1 to: self size do: [:i |
		c _ self at: i.
		(c leadingChar = JISX0208 leadingChar or: [
			c leadingChar = (JISX0208 leadingChar bitShift: 2)]) ifTrue: [
			self basicAt: i put: (Character leadingChar: JapaneseEnvironment leadingChar code: (c asUnicode)) asciiValue.
		]
	].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WideString class
	instanceVariableNames: ''!

!WideString class methodsFor: 'enumeration' stamp: 'yo 8/27/2003 07:01'!
allMethodsWithEncodingTag: encodingTag
	"Answer a SortedCollection of all the methods that implement the message 
	aSelector."

	| list adder num i |
	list _ Set new.
	adder _ [ :mrClass :mrSel |
		list add: (
			MethodReference new
				setStandardClass: mrClass
				methodSymbol: mrSel
		)
	].

	num _ CompiledMethod allInstances size.
	i _ 0.
	'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar |
		SystemNavigation new allBehaviorsDo: [ :class |
			class selectors do: [:s |
				bar value: (i _ i + 1).				
				(self string: (class sourceCodeAt: s) asString hasEncoding: encodingTag) ifTrue: [
					adder value: class value: s.
				]
			]
		]
	].

	^ list.
! !

!WideString class methodsFor: 'enumeration' stamp: 'yo 8/12/2003 17:14'!
allMultiStringMethods  
	"Answer a SortedCollection of all the methods that implement the message 
	aSelector."

	| list adder num i |
	list _ Set new.
	adder _ [ :mrClass :mrSel |
		list add: (
			MethodReference new
				setStandardClass: mrClass
				methodSymbol: mrSel
		)
	].

	num _ CompiledMethod allInstances size.
	i _ 0.
	'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar |
		SystemNavigation new allBehaviorsDo: [ :class |
			class selectors do: [:s |
				bar value: (i _ i + 1).				
				((class sourceCodeAt: s) asString isOctetString) ifFalse: [
					adder value: class value: s.
				]
			]
		]
	].

	^ list.
! !

!WideString class methodsFor: 'enumeration' stamp: 'yo 8/27/2003 07:00'!
allNonAsciiMethods  
	"Answer a SortedCollection of all the methods that implement the message 
	aSelector."

	| list adder num i |
	list _ Set new.
	adder _ [ :mrClass :mrSel |
		list add: (
			MethodReference new
				setStandardClass: mrClass
				methodSymbol: mrSel
		)
	].

	num _ CompiledMethod allInstances size.
	i _ 0.
	'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar |
		SystemNavigation new allBehaviorsDo: [ :class |
			class selectors do: [:s |
				bar value: (i _ i + 1).				
				((class sourceCodeAt: s) asString isAsciiString) ifFalse: [
					adder value: class value: s.
				]
			]
		]
	].

	^ list.
! !


!WideString class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 19:38'!
fromByteArray: aByteArray 

	| inst |
	aByteArray size \\ 4 = 0 ifFalse: [^ ByteString fromByteArray: aByteArray ].
	inst _ self new: aByteArray size // 4.
	4 to: aByteArray size by: 4 do: [:i |
		inst basicAt: i // 4
			put: ((aByteArray at: i - 3) << 24) + 
				((aByteArray at: i - 2) << 16) +
				 ((aByteArray at: i - 1) << 8) +
				(aByteArray at: i)
	].

	^ inst
! !

!WideString class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 17:00'!
fromISO2022JPString: string 

	| tempFileName stream contents |
	tempFileName _ Time millisecondClockValue printString , '.txt'.
	FileDirectory default deleteFileNamed: tempFileName ifAbsent: [].
	stream _ StandardFileStream fileNamed: tempFileName.
	[stream nextPutAll: string]
		ensure: [stream close].
	stream _ FileStream fileNamed: tempFileName.
	contents _ stream contentsOfEntireFile.
	FileDirectory default deleteFileNamed: tempFileName ifAbsent: [].
	^ contents
! !

!WideString class methodsFor: 'instance creation' stamp: 'ar 4/12/2005 19:58'!
fromPacked: aLong
	"Convert from a longinteger to a String of length 4."

	| s val |
	s _ self new: 1.
	val _ (((aLong digitAt: 4) << 24) bitOr:((aLong digitAt: 3) << 16))
				bitOr: (((aLong digitAt: 2) << 8) bitOr: (aLong digitAt: 1)).
	s basicAt: 1 put: val.
	^ s.

"WideString fromPacked: 'TEXT' asPacked"
! !

!WideString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:39'!
fromString: aString 
	"Answer an instance of me that is a copy of the argument, aString."

	| inst |
	(aString isMemberOf: self) ifTrue: [
		^ aString copy.
	].
	inst _ self new: aString size.
	1 to: aString size do: [:pos |
		inst basicAt: pos put: (aString basicAt: pos).
	].
	^ inst.
! !

!WideString class methodsFor: 'instance creation' stamp: 'ar 4/12/2005 20:00'!
from: aString 

	| newString |
	(aString isMemberOf: self)
		ifTrue: [^ aString copy].
	newString _ self new: aString size.
	1 to: aString size do: [:index | newString basicAt: index put: (aString basicAt: index)].
	^ newString
! !
ClassTestCase subclass: #WideStringTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Text'!
!WideStringTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class String. 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!


!WideStringTest methodsFor: 'tests - converting' stamp: 'ar 4/12/2005 17:36'!
testAsInteger
	self assert: '1796exportFixes-tkMX' asWideString asInteger = 1796.
	self assert: 'donald' asWideString asInteger isNil.
	self assert: 'abc234def567' asWideString asInteger = 234.
	self assert: '-94' asWideString asInteger = -94.
	self assert: 'foo-bar-92' asWideString asInteger = -92.

	self assert: '1796exportFixes-tkMX' asWideString asSignedInteger = 1796.
	self assert: 'donald' asWideString asSignedInteger isNil.
	self assert: 'abc234def567' asWideString asSignedInteger = 234.
	self assert: '-94' asWideString asSignedInteger = -94.
	self assert: 'foo-bar-92' asWideString asSignedInteger = -92.

	self assert: '1796exportFixes-tkMX' asWideString asUnsignedInteger = 1796.
	self assert: 'donald' asWideString asUnsignedInteger isNil.
	self assert: 'abc234def567' asWideString asUnsignedInteger = 234.
	self assert: '-94' asWideString asUnsignedInteger = 94.
	self assert: 'foo-bar-92' asWideString asUnsignedInteger = 92! !
Symbol variableWordSubclass: #WideSymbol
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Strings'!
!WideSymbol commentStamp: '<historical>' prior: 0!
This class represents the symbols containing 32bit characters.!


!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'!
at: index 
	"Answer the Character stored in the field of the receiver indexed by the argument."
	^ Character value: (self wordAt: index).
! !

!WideSymbol methodsFor: 'accessing' stamp: 'yo 8/30/2002 14:15'!
at: anInteger put: anObject 
	"You cannot modify the receiver."

	self errorNoModification
! !

!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'!
byteAt: index

	| d r |
	d _ (index + 3) // 4.
	r _ (index - 1) \\ 4 + 1.
	^ (self wordAt: d) digitAt: ((4 - r) + 1).
! !

!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'!
byteAt: index put: aByte
	self errorNoModification.! !

!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'!
byteSize

	^ self size * 4.
! !

!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:34'!
species
	"Answer the preferred class for reconstructing the receiver."
	^WideString
! !

!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'!
wordAt: index
	<primitive: 60>
	^ (self basicAt: index).
! !

!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:39'!
wordAt: index put: anInteger
	self errorNoModification.! !


!WideSymbol methodsFor: 'testing' stamp: 'ar 4/12/2005 19:52'!
isWideString
	"Answer whether the receiver is a WideString"
	^true! !


!WideSymbol methodsFor: 'private' stamp: 'ar 4/12/2005 14:12'!
fixUponLoad: aProject seg: anImageSegment
	"We are in an old project that is being loaded from disk. 
	Fix up conventions that have changed."
	| ms |
	"Yoshiki did not put MultiSymbols into outPointers in older 
images!!
	When all old images are gone, remove this method."
	ms _ Symbol intern: self asString.
	self == ms ifFalse: [
		"For a project from older m17n image, this is necessary."
		self becomeForward: ms.
		aProject projectParameters at: #MultiSymbolInWrongPlace put: true
	].

	"MultiString>>capitalized was not implemented 
correctly. 
	Fix eventual accessors and mutators here."
	((self beginsWith: 'get')
		and:[(self at: 4) asInteger < 256
		and:[(self at: 4) isLowercase]]) ifTrue:[
			ms _ self asString.
			ms at: 4 put: (ms at: 4) asUppercase.
			ms _ ms asSymbol.
			self becomeForward: ms.
			aProject projectParameters at: #MultiSymbolInWrongPlace put: true.
		].
	((self beginsWith: 'set')
		and:[(self at: 4) asInteger < 256
		and:[(self at: 4) isLowercase
		and:[self last = $:
		and:[(self occurrencesOf: $:) = 1]]]]) ifTrue:[
			ms _ self asString.
			ms at: 4 put: (ms at: 4) asUppercase.
			ms _ ms asSymbol.
			self becomeForward: ms.
			aProject projectParameters at: #MultiSymbolInWrongPlace put: true.
		].
	^ super fixUponLoad: aProject seg: anImageSegment	"me, 
not the label"
! !

!WideSymbol methodsFor: 'private' stamp: 'yo 7/29/2005 21:53'!
mutateJISX0208StringToUnicode

	| c |
	1 to: self size do: [:i |
		c _ self at: i.
		(c leadingChar = JISX0208 leadingChar or: [
			c leadingChar = (JISX0208 leadingChar bitShift: 2)]) ifTrue: [
			self basicAt: i put: (Character leadingChar: JapaneseEnvironment leadingChar code: (c asUnicode)) asciiValue.
		]
	].
! !

!WideSymbol methodsFor: 'private' stamp: 'ar 4/11/2005 00:09'!
pvtAt: index put: aCharacter
	"Primitive. Store the Character in the field of the receiver indicated by
	the index. Fail if the index is not an Integer or is out of bounds, or if
	the argument is not a Character. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 61>
	index isInteger
		ifTrue: [self errorSubscriptBounds: index]
		ifFalse: [self errorNonIntegerIndex]! !

!WideSymbol methodsFor: 'private' stamp: 'ar 4/10/2005 23:58'!
string: aString
	1 to: aString size do: [:j | self pvtAt: j put: (aString at: j) asInteger].
	^self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WideSymbol class
	instanceVariableNames: ''!

!WideSymbol class methodsFor: 'class initialization' stamp: 'ar 4/10/2005 23:55'!
initialize
	Smalltalk removeFromShutDownList: self. "@@@ Remove this later @@@"! !
Object subclass: #WidgetStub
	instanceVariableNames: 'spec'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!WidgetStub methodsFor: 'accessing' stamp: 'cwp 5/26/2005 08:48'!
name
	^ spec name ifNil: [' ']! !

!WidgetStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 04:41'!
spec
	^ spec! !

!WidgetStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:57'!
widgetNamed: aString
	^ self name = aString 
		ifTrue: [self]
		ifFalse: [nil]! !


!WidgetStub methodsFor: 'events' stamp: 'cwp 4/22/2005 22:01'!
eventAccessors
	^ #()! !

!WidgetStub methodsFor: 'events' stamp: 'cwp 5/26/2005 08:39'!
refresh! !

!WidgetStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'!
update: aSelector
	| recognized |
	recognized := self eventAccessors collect: [:ea | spec perform: ea].
	(recognized includes: aSelector)
		ifTrue: [spec model perform: aSelector]! !


!WidgetStub methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/3/2006 22:32'!
setSpec: aSpec
	spec := aSpec.
	spec model addDependent: self.
	self refresh.! !


!WidgetStub methodsFor: 'printing' stamp: 'cwp 4/25/2005 03:56'!
printOn: aStream
	aStream
		print: self class;
		nextPut: $<;
		nextPutAll: self name;
		nextPut: $>! !


!WidgetStub methodsFor: 'simulating' stamp: 'cwp 4/22/2005 22:30'!
model
	^ spec model! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WidgetStub class
	instanceVariableNames: ''!

!WidgetStub class methodsFor: 'instance creation' stamp: 'cwp 4/22/2005 21:41'!
fromSpec: aSpec
	^ self new setSpec: aSpec! !
ClipboardInterpreter subclass: #WinGB2312ClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!WinGB2312ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:09'!
fromSystemClipboard: aString

	^ aString squeakToMac convertFromSystemString.
! !

!WinGB2312ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:09'!
toSystemClipboard: text

	| string |
	"self halt."
	string _ text asString.
	string isAsciiString ifTrue: [^ string asOctetString].
	string isOctetString ifTrue: [^ string "hmm"].
	^ string convertToSystemString squeakToMac.
! !
KeyboardInputInterpreter subclass: #WinGB2312InputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!WinGB2312InputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2003 18:53'!
initialize

	converter _ CNGBTextConverter new.
! !

!WinGB2312InputInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:10'!
nextCharFrom: sensor firstEvt: evtBuf

	| firstCharacter secondCharacter peekEvent char1Value keyValue pressType type stream multiCharacter |
	keyValue := evtBuf third.
	pressType := evtBuf fourth.
	pressType = EventKeyDown ifTrue: [type := #keyDown].
	pressType = EventKeyUp ifTrue: [type := #keyUp].
	pressType = EventKeyChar ifTrue: [type := #keystroke].

	char1Value _ (Character value: keyValue) macToSqueak asciiValue.
	((char1Value > 127 and: [char1Value < 160])
		or: [char1Value > 223 and: [char1Value < 253]]) ifFalse: [
			^ keyValue asCharacter.
		].

	peekEvent _ sensor peekEvent.
	"peekEvent printString displayAt: 0@0."
	(peekEvent notNil and: [(peekEvent at: 4) = EventKeyDown])
		ifTrue: [sensor nextEvent.
			peekEvent _ sensor peekEvent].
	(type = #keystroke
			and: [peekEvent notNil
					and: [(peekEvent at: 1)
								= EventTypeKeyboard
							and: [(peekEvent at: 4)
									= EventKeyChar]]])
		ifTrue: [
			firstCharacter _ char1Value asCharacter.
			secondCharacter _ (peekEvent at: 3) asCharacter macToSqueak.
			stream _ ReadStream on: (String with: firstCharacter with: secondCharacter).
			multiCharacter _ converter nextFromStream: stream.
			multiCharacter isOctetCharacter ifFalse: [
				sensor nextEvent.
			].
			^ multiCharacter.
		].
	^ keyValue asCharacter.
! !
ClipboardInterpreter subclass: #WinKSX1001ClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!WinKSX1001ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:09'!
fromSystemClipboard: aString

	^ aString squeakToMac convertFromSystemString.
! !

!WinKSX1001ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:09'!
toSystemClipboard: text

	| string |
	"self halt."
	string _ text asString.
	string isAsciiString ifTrue: [^ string asOctetString].
	string isOctetString ifTrue: [^ string "hmm"].
	^ string convertToSystemString squeakToMac.
! !
KeyboardInputInterpreter subclass: #WinKSX1001InputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!WinKSX1001InputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 1/15/2004 15:47'!
initialize

	converter _ EUCKRTextConverter new.
! !

!WinKSX1001InputInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:10'!
nextCharFrom: sensor firstEvt: evtBuf

	| firstCharacter secondCharacter peekEvent char1Value keyValue pressType type stream multiCharacter |
	keyValue := evtBuf third.
	pressType := evtBuf fourth.
	pressType = EventKeyDown ifTrue: [type := #keyDown].
	pressType = EventKeyUp ifTrue: [type := #keyUp].
	pressType = EventKeyChar ifTrue: [type := #keystroke].

	char1Value _ (Character value: keyValue) macToSqueak asciiValue.
	((char1Value > 127 and: [char1Value < 160])
		or: [char1Value > 223 and: [char1Value < 253]]) ifFalse: [
			^ keyValue asCharacter.
		].

	peekEvent _ sensor peekEvent.
	"peekEvent printString displayAt: 0@0."
	(peekEvent notNil and: [(peekEvent at: 4) = EventKeyDown])
		ifTrue: [sensor nextEvent.
			peekEvent _ sensor peekEvent].
	(type = #keystroke
			and: [peekEvent notNil
					and: [(peekEvent at: 1)
								= EventTypeKeyboard
							and: [(peekEvent at: 4)
									= EventKeyChar]]])
		ifTrue: [
			firstCharacter _ char1Value asCharacter.
			secondCharacter _ (peekEvent at: 3) asCharacter macToSqueak.
			stream _ ReadStream on: (String with: firstCharacter with: secondCharacter).
			multiCharacter _ converter nextFromStream: stream.
			multiCharacter isOctetCharacter ifFalse: [
				sensor nextEvent.
			].
			^ multiCharacter.
		].
	^ keyValue asCharacter.
! !
ClipboardInterpreter subclass: #WinShiftJISClipboardInterpreter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!WinShiftJISClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:10'!
fromSystemClipboard: aString

	^ aString macToSqueak convertFromSystemString
! !

!WinShiftJISClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:09'!
toSystemClipboard: text

	| string |
	"self halt."
	string _ text asString.
	string isAsciiString ifTrue: [^ string asOctetString].
	string isOctetString ifTrue: [^ string "hmm"].
	^ string convertToSystemString squeakToMac.
! !
KeyboardInputInterpreter subclass: #WinShiftJISInputInterpreter
	instanceVariableNames: 'converter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-TextConversion'!

!WinShiftJISInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/13/2003 13:45'!
initialize

	converter _ ShiftJISTextConverter new.
! !

!WinShiftJISInputInterpreter methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 16:10'!
nextCharFrom: sensor firstEvt: evtBuf

	| firstCharacter secondCharacter peekEvent char1Value keyValue pressType type stream multiCharacter |
	keyValue := evtBuf third.
	pressType := evtBuf fourth.
	pressType = EventKeyDown ifTrue: [type := #keyDown].
	pressType = EventKeyUp ifTrue: [type := #keyUp].
	pressType = EventKeyChar ifTrue: [type := #keystroke].

	char1Value _ (Character value: keyValue) macToSqueak asciiValue.

	(char1Value < 16r81) ifTrue: [^ keyValue asCharacter].
	(char1Value > 16rA0 and: [char1Value < 16rE0]) ifTrue: [^ ShiftJISTextConverter basicNew katakanaValue: char1Value].

	peekEvent _ sensor peekEvent.
	"peekEvent printString displayAt: 0@0."
	(peekEvent notNil and: [(peekEvent at: 4) = EventKeyDown])
		ifTrue: [sensor nextEvent.
			peekEvent _ sensor peekEvent].
	(type = #keystroke
			and: [peekEvent notNil
					and: [(peekEvent at: 1)
								= EventTypeKeyboard
							and: [(peekEvent at: 4)
									= EventKeyChar]]])
		ifTrue: [
			firstCharacter _ char1Value asCharacter.
			secondCharacter _ (peekEvent at: 3) asCharacter macToSqueak.
			stream _ ReadStream on: (String with: firstCharacter with: secondCharacter).
			multiCharacter _ converter nextFromStream: stream.
			multiCharacter isOctetCharacter ifFalse: [
				sensor nextEvent.
			].
			^ multiCharacter.
		].
	^ keyValue asCharacter.
! !
Object subclass: #WindowColorRegistry
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!WindowColorRegistry commentStamp: 'hpt 10/9/2005 22:54' prior: 0!
I provide to the applications developer a place where they can register their WindowColorSpecification for their application's windows.
!


!WindowColorRegistry methodsFor: 'notes' stamp: 'hpt 10/9/2005 22:54'!
seeClassSide
	"All the code for WindowColorRegistry is on the class side."! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WindowColorRegistry class
	instanceVariableNames: 'registry'!

!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:11'!
initialize
	self refresh.! !

!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:10'!
refresh
	"This is a one-time only method for bootstraping the new registry. Here we will scan all classes for #windowColorSpecification methods and register those to the registry"

	((self systemNavigation allClassesImplementing: #windowColorSpecification)
		collect: [:aClass | aClass theNonMetaClass windowColorSpecification])
		do: [:spec | self registerColorSpecification: spec toClassNamed: spec classSymbol ].! !

!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:08'!
registerColorSpecification: aColorSpec toClassNamed: aClassName
	self registry at: aClassName asSymbol put: aColorSpec.! !

!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:23'!
registeredWindowColorSpecFor: aClassName
	"Return the Window Color Spec for the given class. "
	^self registry at: aClassName asSymbol ifAbsent: [].
! !

!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:17'!
registeredWindowColorSpecs
	^self registry values! !

!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:10'!
registry
	^registry ifNil: [registry _ Dictionary new].! !
Object subclass: #WindowColorSpec
	instanceVariableNames: 'classSymbol wording brightColor pastelColor helpMessage'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 15:00'!
brightColor
	"Answer the brightColor"

	^ brightColor! !

!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 14:59'!
classSymbol
	"Answer the classSymbol"

	^ classSymbol! !

!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 15:00'!
helpMessage
	"Answer the helpMessage"

	^ helpMessage! !

!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 15:00'!
pastelColor
	"Answer the pastelColor"

	^ pastelColor! !

!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 14:59'!
wording
	"Answer the wording"

	^ wording! !


!WindowColorSpec methodsFor: 'initialization' stamp: 'sw 2/26/2002 13:39'!
classSymbol: sym wording: wrd brightColor: brCol pastelColor: paCol helpMessage: hlpMsg
	"Initialize the receiver's instance variables"

	classSymbol _ sym.
	wording _ wrd.
	brightColor _ brCol.
	pastelColor _ paCol.
	helpMessage _ hlpMsg! !


!WindowColorSpec methodsFor: 'printing' stamp: 'sw 4/21/2002 07:42'!
printOn: aStream
	"Print the receiver on a stream"

	super printOn: aStream.
	classSymbol printOn: aStream. 
	aStream nextPutAll: ' bright: ', brightColor printString, ' pastel: ', pastelColor printString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WindowColorSpec class
	instanceVariableNames: ''!

!WindowColorSpec class methodsFor: 'instance creation' stamp: 'sw 2/26/2002 13:40'!
classSymbol: sym wording: wrd brightColor: brCol pastelColor: paCol helpMessage: hlpMsg
	"Answer a new instance of the receiver with the given slots filled in"

	^ self new classSymbol: sym wording: wrd brightColor: brCol pastelColor: paCol helpMessage: hlpMsg! !
CompositeStub subclass: #WindowStub
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

!WindowStub methodsFor: 'events' stamp: 'cwp 4/25/2005 03:50'!
eventAccessors
	^ super eventAccessors, #(label)! !


!WindowStub methodsFor: 'simulating' stamp: 'cwp 7/14/2006 10:58'!
close
	spec model perform: spec closeAction! !
Object subclass: #WindowingTransformation
	instanceVariableNames: 'scale translation'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Framework'!
!WindowingTransformation commentStamp: '<historical>' prior: 0!
My instances are used to transform objects from a source coordinate system to a destination coordinate system. Each instance contains a scale and a translation which can be applied to objects that respond to scaleBy: and translateBy:. It can be created with a default identity scale and translation, or with a specified scale and translation, or with a scale and translation computed from a window (a Rectangle in the source coordinate system) and a viewport (a Rectangle in the destination coordinate system). In applying a WindowingTransformation to an object, the object is first scaled (around the origin of the source coordinate system) and then translated. WindowingTransformations can be composed to form a single compound transformation.!


!WindowingTransformation methodsFor: 'applying transform'!
applyInverseTo: anObject 
	"Apply the inverse of the receiver to anObject and answer the result. 
	Used to map some object in destination coordinates to one in source 
	coordinates."

	| transformedObject |
	transformedObject _ anObject translateBy: translation x negated @ translation y negated.
	scale == nil
		ifFalse: [transformedObject _ transformedObject scaleBy: 1.0 / scale x @ (1.0 / scale y)].
	^transformedObject! !

!WindowingTransformation methodsFor: 'applying transform'!
applyTo: anObject 
	"Apply the receiver to anObject and answer the result. Used to map some 
	object in source coordinates to one in destination coordinates."

	| transformedObject |
	scale == nil
		ifTrue: [transformedObject _ anObject]
		ifFalse: [transformedObject _ anObject scaleBy: scale].
	transformedObject _ transformedObject translateBy: translation.
	^transformedObject! !

!WindowingTransformation methodsFor: 'applying transform'!
compose: aTransformation 
	"Answer a WindowingTransformation that is the composition of the 
	receiver and aTransformation. The effect of applying the resulting 
	WindowingTransformation to an object is the same as that of first 
	applying aTransformation to the object and then applying the receiver to 
	its result."

	| aTransformationScale newScale newTranslation |
	aTransformationScale _ aTransformation scale.
	scale == nil
		ifTrue: 
			[aTransformation noScale
				ifTrue: [newScale _ nil]
				ifFalse: [newScale _ aTransformationScale].
			newTranslation _ translation + aTransformation translation]
		ifFalse: 
			[aTransformation noScale
				ifTrue: [newScale _ scale]
				ifFalse: [newScale _ scale * aTransformationScale].
			newTranslation _ translation + (scale * aTransformation translation)].
	^WindowingTransformation scale: newScale translation: newTranslation! !


!WindowingTransformation methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	aStream nextPutAll: self class name, ' scale: ';
		print: scale; nextPutAll: ' translation: ';
		print: translation! !


!WindowingTransformation methodsFor: 'scrolling'!
scrollBy: aPoint 
	"Answer a WindowingTransformation with the same scale as the receiver 
	and with a translation of the current translation plus aPoint scaled by 
	the current scale. It is used when the translation is known in source 
	coordinates, rather than scaled source coordinates (see 
	WindowingTransformation|translateBy:). An example is that of scrolling 
	objects with respect to a stationary window in the source coordinate 
	system. If no scaling is in effect (scale = nil), then 
	WindowingTransformation|translateBy: and 
	WindowingTransformation|scrollBy: are equivalent."

	| newTranslation |
	scale == nil
		ifTrue: [newTranslation _ aPoint]
		ifFalse: [newTranslation _ scale * aPoint].
	^self translateBy: newTranslation! !


!WindowingTransformation methodsFor: 'transforming'!
align: point1 with: point2 
	"Answer a WindowingTransformation with the same scale as the receiver 
	and with a translation of (aPoint2 - aPoint1). It is normally used when 
	the source and destination coordinate systems are scaled the same (that 
	is, there is no scaling between them), and is then a convenient way of 
	specifying a translation, given two points that are intended to coincide."

	^self translateBy: point2 - point1! !

!WindowingTransformation methodsFor: 'transforming'!
noScale
	"Answer true if the identity scale is in effect; answer false, otherwise."

	^scale == nil! !

!WindowingTransformation methodsFor: 'transforming'!
scale
	"Answer a copy of the point that represents the current scale of the 
	receiver."

	scale == nil
		ifTrue: [^1.0 @ 1.0]
		ifFalse: [^scale copy]! !

!WindowingTransformation methodsFor: 'transforming'!
scaleBy: aScale 
	"Answer a WindowingTransformation with the scale and translation of 
	the receiver both scaled by aScale."

	| checkedScale newScale newTranslation |
	aScale == nil
		ifTrue: 
			[newScale _ scale.
			newTranslation _ translation]
		ifFalse: 
			[checkedScale _ self checkScale: aScale.
			scale == nil
				ifTrue: [newScale _ checkedScale]
				ifFalse: [newScale _ scale * checkedScale].
			newTranslation _ checkedScale * translation].
	^WindowingTransformation scale: newScale translation: newTranslation! !

!WindowingTransformation methodsFor: 'transforming'!
translateBy: aPoint 
	"Answer a WindowingTransformation with the same scale as the receiver 
	and with a translation of the current translation plus aPoint. It is used 
	when the translation is known in scaled source coordinates, rather than 
	source coordinates (see WindowingTransformation|scrollBy:). If no scaling 
	is in effect (scale = nil), then WindowingTransformation|translateBy: and 
	WindowingTransformation|scrollBy: are equivalent."

	^WindowingTransformation scale: scale translation: translation + aPoint! !

!WindowingTransformation methodsFor: 'transforming'!
translation
	"Answer a copy of the receiver's translation."

	^translation copy! !


!WindowingTransformation methodsFor: 'private'!
checkScale: aScale
	"Convert aScale to the internal format of a floating-point Point."

 	| checkedScale |
	checkedScale _ aScale asPoint.
	^checkedScale x asFloat @ checkedScale y asFloat! !

!WindowingTransformation methodsFor: 'private'!
setScale: aScale translation: aTranslation 
	"Sets the scale to aScale and the translation to aTranslation."

	scale _ aScale.
	translation _ aTranslation! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WindowingTransformation class
	instanceVariableNames: ''!

!WindowingTransformation class methodsFor: 'instance creation'!
identity
	"Answer an instance of me with no scaling (nil) and no translation 
	(0@0)."

	^self new setScale: nil translation: 0 @ 0! !

!WindowingTransformation class methodsFor: 'instance creation'!
scale: aScale translation: aTranslation 
	"Answer an instance of me with a scale factor of aScale and a translation 
	offset of aTranslation. When the transformation is applied (see 
	WindowingTransformation|apply:), the scale is applied first, followed by 
	the translation."

	^self new setScale: aScale translation: aTranslation! !

!WindowingTransformation class methodsFor: 'instance creation'!
window: aWindow viewport: aViewport 
	"Answer an instance of me with a scale and translation based on 
	aWindow and aViewport. The scale and translation are computed such 
	that aWindow, when transformed, coincides with aViewport."

	| scale translation |
	aViewport width = aWindow width & (aViewport height = aWindow height)
		ifTrue:
			[scale _ nil]
		ifFalse:
			[scale _ aViewport width asFloat / aWindow width asFloat
						@ (aViewport height asFloat / aWindow height asFloat)].
	scale == nil
		ifTrue: [translation _ aViewport left - aWindow left
								@ (aViewport top - aWindow top)]
		ifFalse: [translation _ aViewport left - (scale x * aWindow left)
								@ (aViewport top - (scale y * aWindow top))].
	^self new setScale: scale translation: translation! !
PolygonMorph subclass: #WireMorph
	instanceVariableNames: 'pins'
	classVariableNames: 'InputPinForm IoPinForm OutputPinForm'
	poolDictionaries: ''
	category: 'MorphicExtras-Components'!

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/2/1998 16:05'!
fromPin: pin1 toPin: pin2
	pins _ Array with: pin1 with: pin2! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 22:51'!
otherPinFrom: aPin 
	^ pins first = aPin ifTrue: [pins second] ifFalse: [pins first]! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 14:22'!
pinMoved
	| newVerts |
	newVerts _ vertices copy.
	newVerts at: 1 put: pins first wiringEndPoint.
	newVerts at: newVerts size put: pins last wiringEndPoint.
	self setVertices: newVerts! !


!WireMorph methodsFor: 'editing' stamp: 'di 5/3/1998 22:49'!
addHandles
	super addHandles.
	"Don't show endpoint handles"
	handles first delete.
	handles last delete! !


!WireMorph methodsFor: 'event handling' stamp: 'di 5/3/1998 22:35'!
handlesMouseDown: evt
	^ evt buttons noMask: 16r78  "ie no modifier keys pressed"! !

!WireMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:50'!
mouseUp: evt 
	handles isNil ifTrue: [self addHandles] ifFalse: [self removeHandles]! !


!WireMorph methodsFor: 'submorphs-add/remove' stamp: 'di 5/4/1998 00:12'!
delete
	pins do: [:p | p removeWire: self].
	pins first isIsolated 
		ifTrue: [pins first removeVariableAccess.
				pins second isIsolated
					ifTrue: [pins second removeModelVariable]]
		ifFalse: [pins second isIsolated
					ifTrue: [pins second removeVariableAccess]
					ifFalse: [pins second addModelVariable]].
	super delete! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WireMorph class
	instanceVariableNames: ''!

!WireMorph class methodsFor: 'new-morph participation' stamp: 'di 5/3/1998 10:09'!
includeInNewMorphMenu
	^ false! !
Object subclass: #Word
	instanceVariableNames: 'string syllables'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:47'!
accept: anObject
	anObject word: self! !

!Word methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
events
	| answer |
	answer := CompositeEvent new.
	self syllables do: [ :each | answer addAll: each events].
	^ answer! !

!Word methodsFor: 'accessing' stamp: 'len 12/13/1999 02:33'!
lastSyllable
	^ self syllables last! !

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:49'!
string
	^ string! !

!Word methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
string: aString
	string := aString! !

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:48'!
syllables
	^ syllables! !

!Word methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:23'!
syllables: aCollection
	syllables := aCollection! !


!Word methodsFor: 'enumerating' stamp: 'len 12/13/1999 01:20'!
eventsDo: aBlock
	self syllables do: [ :syllable | syllable eventsDo: aBlock]! !


!Word methodsFor: 'printing' stamp: 'len 12/13/1999 03:18'!
printOn: aStream
	aStream nextPutAll: (self isAccented ifTrue: [self string asUppercase] ifFalse: [self string])! !


!Word methodsFor: 'testing' stamp: 'len 12/11/1999 13:11'!
isAccented
	^ (self syllables detect: [ :one | one isAccented] ifNone: []) notNil! !

!Word methodsFor: 'testing' stamp: 'len 12/8/1999 18:47'!
isPolysyllabic
	^ self syllables size > 1! !
ArrayedCollection variableWordSubclass: #WordArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!WordArray commentStamp: '<historical>' prior: 0!
WordArrays store 32-bit unsigned Integer values.
!


!WordArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'!
atAllPut: value
	"Fill the receiver with the given value"

	<primitive: 145>
	super atAllPut: value! !

!WordArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:18'!
byteSize
	^self size * 4! !

!WordArray methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'!
bytesPerElement
	"Number of bytes in each item.  This multiplied by (self size)*8 gives the number of bits stored."
	^ 4! !

!WordArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0! !


!WordArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'!
asWordArray
	^self! !


!WordArray methodsFor: 'private' stamp: 'ar 2/15/1999 00:51'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	<primitive: 105>
	^super replaceFrom: start to: stop with: replacement startingAt: repStart ! !


!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:50'!
primAddArray: rcvr and: other into: result

	<primitive: 'primitiveAddArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveAddArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) + (other at: i)
	].
	^ result.
! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:10'!
primAddScalar: rcvr and: other into: result

	<primitive: 'primitiveAddScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveAddScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) + other.
	].
	^ result.
! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:51'!
primDivArray: rcvr and: other into: result

	<primitive: 'primitiveDivArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveDivArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) / (other at: i)
	].
	^ result.
! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:49'!
primDivScalar: rcvr and: other into: result

	<primitive: 'primitiveDivScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveDivScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) / other.
	].
	^ result.
! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:51'!
primMulArray: rcvr and: other into: result

	<primitive: 'primitiveMulArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveMulArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) * (other at: i)
	].
	^ result.
! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:49'!
primMulScalar: rcvr and: other into: result

	<primitive: 'primitiveMulScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveMulScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) * other.
	].
	^ result.
! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:50'!
primSubArray: rcvr and: other into: result

	<primitive: 'primitiveSubArrays' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveSubArrays."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) - (other at: i)
	].
	^ result.
! !

!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:49'!
primSubScalar: rcvr and: other into: result

	<primitive: 'primitiveSubScalar' module:'KedamaPlugin'>
	"^ KedamaPlugin doPrimitive: #primitiveSubScalar."

	1 to: rcvr size do: [:i |
		result at: i put: (rcvr at: i) - other.
	].
	^ result.
! !


!WordArray methodsFor: 'array arithmetic' stamp: 'yo 10/25/2004 15:52'!
* other

	| result |
	other isNumber ifTrue: [
		other isFloat ifTrue: [
			result _ KedamaFloatArray new: self size.
			^ self primMulScalar: self and: other into: result.
		] ifFalse: [
			result _ WordArray new: self size.
			^ self primMulScalar: self and: other into: result.
		].
	].
	(other isMemberOf: WordArray) ifTrue: [	
		result _ WordArray new: self size.
		^ self primMulArray: self and: other into: result.
	].
	(other isMemberOf: KedamaFloatArray) ifTrue: [	
		result _ KedamaFloatArray new: self size.
		^ self primMulArray: self and: other into: result.
	].
	^ super * other.
! !

!WordArray methodsFor: 'array arithmetic' stamp: 'yo 10/25/2004 14:58'!
+ other

	| result |
	other isNumber ifTrue: [
		other isFloat ifTrue: [
			result _ KedamaFloatArray new: self size.
			^ self primAddScalar: self and: other into: result.
		] ifFalse: [
			result _ WordArray new: self size.
			^ self primAddScalar: self and: other into: result.
		].
	].
	(other isMemberOf: WordArray) ifTrue: [	
		result _ WordArray new: self size.
		^ self primAddArray: self and: other into: result.
	].
	(other isMemberOf: KedamaFloatArray) ifTrue: [	
		result _ KedamaFloatArray new: self size.
		^ self primAddArray: self and: other into: result.
	].
	^ super + other.
! !

!WordArray methodsFor: 'array arithmetic' stamp: 'yo 10/25/2004 15:52'!
- other

	| result |
	other isNumber ifTrue: [
		other isFloat ifTrue: [
			result _ KedamaFloatArray new: self size.
			^ self primSubScalar: self and: other into: result.
		] ifFalse: [
			result _ WordArray new: self size.
			^ self primSubScalar: self and: other into: result.
		].
	].
	(other isMemberOf: WordArray) ifTrue: [	
		result _ WordArray new: self size.
		^ self primSubArray: self and: other into: result.
	].
	(other isMemberOf: KedamaFloatArray) ifTrue: [	
		result _ KedamaFloatArray new: self size.
		^ self primSubArray: self and: other into: result.
	].
	^ super - other.
! !

!WordArray methodsFor: 'array arithmetic' stamp: 'yo 10/25/2004 15:53'!
/ other

	| result |
	other isNumber ifTrue: [
		other isFloat ifTrue: [
			result _ KedamaFloatArray new: self size.
			^ self primDivScalar: self and: other into: result.
		] ifFalse: [
			result _ WordArray new: self size.
			^ self primDivScalar: self and: other into: result.
		].
	].
	(other isMemberOf: WordArray) ifTrue: [	
		result _ WordArray new: self size.
		^ self primDivArray: self and: other into: result.
	].
	(other isMemberOf: KedamaFloatArray) ifTrue: [	
		result _ KedamaFloatArray new: self size.
		^ self primDivArray: self and: other into: result.
	].
	^ super / other.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WordArray class
	instanceVariableNames: ''!

!WordArray class methodsFor: 'as yet unclassified' stamp: 'RAA 5/17/2001 16:07'!
bobsTest
	| wa s1 s2 wa2 answer rawData |
"
WordArray bobsTest
"
	answer _ OrderedCollection new.
	wa _ WordArray with: 16r01020304 with: 16r05060708.
	{false. true} do: [ :pad |
		0 to: 3 do: [ :skip |
			s1 _ RWBinaryOrTextStream on: ByteArray new.

			s1 next: skip put: 0.		"start at varying positions"
			wa writeOn: s1.
			pad ifTrue: [s1 next: 4-skip put: 0].	"force length to be multiple of 4"

			rawData _ s1 contents.
			s2 _ RWBinaryOrTextStream with: rawData.
			s2 reset.
			s2 skip: skip.			"get to beginning of object"
			wa2 _ WordArray newFromStream: s2.
			answer add: {
				rawData size. 
				skip. 
				wa2 = wa. 
				wa2 asArray collect: [ :each | each radix: 16]
			}
		].
	].
	^answer explore! !
WordArray variableWordSubclass: #WordArrayForSegment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!

!WordArrayForSegment methodsFor: 'as yet unclassified' stamp: 'tk 1/24/2000 23:22'!
restoreEndianness
	"This word object was just read in from a stream.  Do not correct the Endianness because the load primitive will reverse bytes as needed."

	"^ self"
! !

!WordArrayForSegment methodsFor: 'as yet unclassified' stamp: 'tk 1/24/2000 23:22'!
writeOn: aByteStream
	"Write quickly and disregard the endianness of the words.  Store the array of bits onto the argument, aStream.  (leading byte ~= 16r80) identifies this as raw bits (uncompressed)."

	aByteStream nextInt32Put: self size.	"4 bytes"
	aByteStream nextPutAll: self
! !
StringHolder subclass: #Workspace
	instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Base'!
!Workspace commentStamp: 'ls 10/14/2003 12:13' prior: 0!
A Workspace is a text area plus a lot of support for executable code.  It is a great place to execute top-level commands to compute something useful, and it is a great place to develop bits of a program before those bits get put into class methods.

To open a new workspace, execute:

	Workspace open


A workspace can have its own variables, called "workspace variables", to hold intermediate results.  For example, if you type into a workspace "x := 5" and do-it, then later you could type in "y := x * 2" and y would become 10.

Additionally, in Morphic, a workspace can gain access to morphs that are on the screen.  If acceptDroppedMorphss is turned on, then whenever a morph is dropped on the workspace, a variable will be created which references that morph.  This functionality is toggled with the window-wide menu of a workspace.


The instance variables of this class are:

	bindings  -  holds the workspace variables for this workspace

	acceptDroppedMorphss - whether dropped morphs should create new variables!


!Workspace methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:56'!
acceptAction
	^acceptAction! !

!Workspace methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:56'!
acceptAction: anAction
	acceptAction := anAction.! !

!Workspace methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:58'!
acceptContents: aString
	acceptAction ifNotNil:[acceptAction value: aString].
	^super acceptContents: aString.! !

!Workspace methodsFor: 'accessing' stamp: 'sd 3/20/2004 15:17'!
mustDeclareVariables: aBoolean

	mustDeclareVariables := aBoolean! !

!Workspace methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'!
setBindings: aDictionary
	"Sets the Workspace to use the specified dictionary as its namespace"

	bindings := aDictionary.
! !


!Workspace methodsFor: 'as yet unclassified' stamp: 'em 3/24/2005 11:21'!
acceptDroppedMorphsWording

	^ self acceptsDroppingMorphForReference
		ifTrue: ['<yes> create textual references to dropped morphs' translated]
		ifFalse: ['<no> create textual references to dropped morphs' translated]
! !

!Workspace methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'!
saveContentsInFile
	"A bit of a hack to pass along this message to the controller or morph.  (Possibly this Workspace menu item could be deleted, since it's now in the text menu.)"
	| textMorph textView |

	textMorph := self dependents detect: [:dep | dep isKindOf: PluggableTextMorph] ifNone: [nil].
	textMorph notNil ifTrue: [^ textMorph saveContentsInFile].

	textView := self dependents detect: [:dep | dep isKindOf: PluggableTextView] ifNone: [nil].
	textView notNil ifTrue: [^ textView controller saveContentsInFile].
! !


!Workspace methodsFor: 'binding' stamp: 'sd 3/20/2004 15:20'!
bindingOf: aString 
	
	mustDeclareVariables ifTrue: [^ nil].
	"I want to have workspace that force the user to declare  
	variables. Still subclasses may want to do something else"
	bindings isNil
		ifTrue: [self initializeBindings].
	(bindings includesKey: aString)
		ifFalse: [bindings at: aString put: nil].
	^ bindings associationAt: aString! !

!Workspace methodsFor: 'binding' stamp: 'sd 3/20/2004 14:31'!
initializeBindings
	
	bindings := Dictionary new! !


!Workspace methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:27'!
acceptDroppingMorph: dropee event: evt inMorph: targetMorph 
	"Return the dropee to its old position, and add a reference to it at the cursor point."

	| bindingName externalName |
	externalName := dropee externalName.
	externalName := externalName isOctetString
		ifTrue: [externalName] ifFalse: ['a' , externalName].
	bindingName := externalName translateToLowercase, dropee identityHash printString.
	targetMorph correctSelectionWithString: bindingName, ' '.
	(self bindingOf: bindingName) value: dropee.
	dropee rejectDropMorphEvent: evt.
	^ true "success"
! !

!Workspace methodsFor: 'drag and drop' stamp: 'jcg 7/8/2000 00:10'!
acceptsDroppingMorphForReference

	^ acceptDroppedMorphs
		
! !

!Workspace methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:27'!
acceptsDroppingMorphForReference: trueFalse

	acceptDroppedMorphs := trueFalse
		
! !

!Workspace methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:27'!
toggleDroppingMorphForReference

	acceptDroppedMorphs := acceptDroppedMorphs not.
		
! !

!Workspace methodsFor: 'drag and drop' stamp: 'jcg 7/7/2000 11:16'!
wantsDroppedMorph: dropee event: evt inMorph: target

	^ acceptDroppedMorphs
		
! !


!Workspace methodsFor: 'initialize-release' stamp: 'md 3/7/2006 10:25'!
embeddedInMorphicWindowLabeled: labelString
	| window pane |
	window _ (SystemWindow labelled: labelString) model: self.
	pane := PluggableTextMorph on: self text: #contents accept: #acceptContents:
			readSelection: nil menu: #codePaneMenu:shifted:.
	pane  font: Preferences standardCodeFont.
	window addMorph: pane frame: (0@0 corner: 1@1).
	^ window! !

!Workspace methodsFor: 'initialize-release' stamp: 'wiz 2/13/2006 21:18'!
initialExtent
 "Start small.  Window aspect ratio is 5 sqrt::1 . Good asthetics. -wiz"
	
	^ 447@200! !

!Workspace methodsFor: 'initialize-release' stamp: 'sd 3/20/2004 14:36'!
initialize
	
	super initialize.
	acceptDroppedMorphs := false.
	mustDeclareVariables := false! !


!Workspace methodsFor: 'menu commands' stamp: 'sd 3/20/2004 15:15'!
addModelItemsToWindowMenu: aMenu 
	
	aMenu addLine.
	aMenu
		add: 'save contents to file...'
		target: self
		action: #saveContentsInFile.
	aMenu
		add: 'reset variables'
		target: self
		action: #initializeBindings.
	aMenu
		addUpdating: #mustDeclareVariableWording
		target: self
		action: #toggleVariableDeclarationMode.
	aMenu
		addUpdating: #acceptDroppedMorphsWording
		target: self
		action: #toggleDroppingMorphForReference! !

!Workspace methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'!
appendContentsOfFile
	"Prompt for a file, and if one is obtained, append its contents to the contents of the receiver.   Caution: as currently implemented this abandons any custom style information previously in the workspace.  Someone should fix this.  Also, for best results you should accept the contents of the workspace before requesting this."

	| aFileStream |
	(aFileStream := FileList2 modalFileSelector) ifNil: [^ self].
	contents := (contents ifNil: ['']) asString, aFileStream contentsOfEntireFile.
	aFileStream close.
	self changed: #contents! !


!Workspace methodsFor: 'object fileIn' stamp: 'sd 11/20/2005 21:27'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	acceptDroppedMorphs ifNil: [acceptDroppedMorphs := false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!Workspace methodsFor: 'variable declarations' stamp: 'sd 3/20/2004 15:24'!
mustDeclareVariableWording
	
	^ '<yes> automatically create variable declaration'! !

!Workspace methodsFor: 'variable declarations' stamp: 'sd 3/20/2004 14:39'!
toggleVariableDeclarationMode

	mustDeclareVariables := mustDeclareVariables not! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Workspace class
	instanceVariableNames: ''!

!Workspace class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'!
prototypicalToolWindow
	"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"

	| aWorkspace |
	aWorkspace := self new embeddedInMorphicWindowLabeled: 'Workspace'.
	aWorkspace applyModelExtent.
	^ aWorkspace! !


!Workspace class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:13'!
initialize

	self registerInFlapsRegistry.	! !

!Workspace class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:14'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(Workspace	prototypicalToolWindow	'Workspace'		'A Workspace is a simple window for editing text.  You can later save the contents to a file if you desire.')
						forFlapNamed: 'Tools'.]! !

!Workspace class methodsFor: '*MorphicExtras-class initialization' stamp: 'asm 4/11/2003 12:42'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !
ServiceProvider subclass: #WorldMenuProvider
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base-Providers'!
!WorldMenuProvider commentStamp: 'rr 7/10/2006 15:19' prior: 0!
I define services and categories:
- The world menu category (identifier:  world), where services and categories can be put to be displayed in the world menu.
- The preferencesMenu category, where services about services and preferences can be put
- th open menu!


!WorldMenuProvider methodsFor: 'saved preferences'!
browserMethodMenucreateNewService
	^ #(#'Items in browserMethodMenu:' #createNewService 1 )! !

!WorldMenuProvider methodsFor: 'saved preferences'!
preferencesMenuhelpOnServices
	^ #(#'Items in preferencesMenu:' #helpOnServices 3 )! !

!WorldMenuProvider methodsFor: 'saved preferences'!
preferencesMenupreferencesBrowser
	^ #(#'Items in preferencesMenu:' #preferencesBrowser 1 )! !

!WorldMenuProvider methodsFor: 'saved preferences'!
preferencesMenurebuildRegistry
	^ #(#'Items in preferencesMenu:' #rebuildRegistry 4 )! !

!WorldMenuProvider methodsFor: 'saved preferences'!
preferencesMenuservicesBrowser
	^ #(#'Items in preferencesMenu:' #servicesBrowser 2 )! !

!WorldMenuProvider methodsFor: 'saved preferences'!
preferencesMenushortcut
	^ #(#'Shortcut for preferencesMenu:' '' 1000 )! !

!WorldMenuProvider methodsFor: 'saved preferences'!
worldpreferencesMenu
	^ #(#'Items in world:' #preferencesMenu 1 )! !

!WorldMenuProvider methodsFor: 'saved preferences'!
worldshortcut
	^ #(#'Shortcut for world:' '' 1000 )! !


!WorldMenuProvider methodsFor: 'service registering' stamp: 'rr 3/25/2005 14:23'!
convertOpenCommand: array 
	| description |
	description := array size > 2 
				ifTrue: [array third]
				ifFalse: ['none available'].
	^ServiceAction 
		id: array first asSymbol
		text: array first
		button: array first
		description: description
		action: [array second first perform: array second second]! !


!WorldMenuProvider methodsFor: 'services' stamp: 'rr 3/11/2006 19:11'!
closeTopWindow
	^ ServiceAction
		text: 'Close top window'
		button: 'close window'
		description: 'Closes the focused window'
		action: [:r | SystemWindow topWindow delete]! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/10/2006 10:41'!
createNewService
	^ ServiceAction 
		text: 'Create new service' 
		button: 'new service' 
		description: 'Define a new service provided by this package' 
		action: [:r | | s p |
			s := r caption: 'enter service identifier'; getSymbol.
			p := r getPackageProvider.
			p compile: s, ' 
	^ ServiceAction 
		"Open the service browser to set the menu position and the keyboard shortcut"
		text: ''fill menu label''
		button: ''short button text''
		description: ''longer text for balloon help''
		action: [:r | "action block"]
		condition: [:r | "optional condition block"]' classified: 'services'.
			r getBrowser browseReference: (MethodReference class: p selector: s)]! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 7/10/2006 15:43'!
helpOnServices
	^ ServiceAction
		text: 'Help on Services'
		button: 'services help'
		description: 'Introductory text about services'
		action: [StringHolder new contents: self servicesHelpText; openLabel: 'Introduction to Services'].! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 3/11/2006 19:10'!
nextWindow
	^ ServiceAction text: 'Switch to next window' button: 'next window' description: 'Switches to the next window' action: [:r | SystemWindow sendTopWindowToBack]! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 10/20/2005 22:50'!
openMenu
	^ ServiceCategory text: 'Open' button: 'open' description: 'The open menu'! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:15'!
preferencesBrowser
	^ ServiceAction text: 'Preference Browser' button: 'pref. browser' description: 'Open the preference browser to edit various Squeak settings' action: [PreferenceBrowser open].! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:14'!
preferencesMenu
	^ ServiceCategory text: 'Preferences & Services' button: 'preferences' description: 'Menu related to editing preferences'! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:18'!
rebuildRegistry
	^ ServiceAction text: 'Rebuild service registry' button: 'rebuild registry' description: 'Rebuilds the service registry to scan for newly defined services' action: [ServiceRegistry rebuild].! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:16'!
servicesBrowser
	^ ServiceAction text: 'Services Browser' button: 'services' description: 'Open a preference browser to edit several Squeak menus' action: [PreferenceBrowser openForServices].! !

!WorldMenuProvider methodsFor: 'services' stamp: 'rr 10/20/2005 22:49'!
world
	^ ServiceCategory text: 'World' button: 'world' description: 'The world menu'! !


!WorldMenuProvider methodsFor: 'accessing' stamp: 'rr 7/10/2006 16:00'!
servicesHelpText
	^ '
	This is an overview of the main concepts of the services framework. More details are available in class comments. The aim is to help you defining services step by step. The three main classes are: 

-ServiceAction
-ServiceCategory
-ServiceProvider

Alongside them, a tool to use is the Services Browser. It can be found in the world menu, under the ''Preferences & Services'' menu heading (in which you found this text).
	
	ServiceAction are executable objects in various contexts.
They can be displayed as buttons or menu items or bounded to keyboard shortcuts.

	ServiceCategory are categories of services. They are also services, so a ServiceCategory can be included in another, forming a tree of Services. ServiceCategories can be displayed with menus, or button bars.
	
	A ServiceProvider references services that are relevant to a given application.
Each application that wishes to use the Services framework must subclass a ServiceProvider.
This class must define a ''services'' method category.
Each method implemented in this category will be automatically called by the framework.
Each of these method should be a unary message (taking no argument), and return a fully initialised instance of ServiceAction or ServiceCategory. There are three possible patterns:

1)
serviceIdentifierAndMethodName
	^ ServiceAction
		text: ''Menu item text''
		button:''Button text''
		description: ''Longer text that appears in help balloons''
		action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"]
		
2)
serviceIdentifierAndMethodName
	^ ServiceAction
		text: ''Menu item text''
		button: ''Button text''
		description: ''Longer text that appears in help balloons''
		action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"]
		condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"]
		
3)
methodNameAndServiceCategoryId
	^ ServiceCategory 
		text: ''Menu text''
		button: ''Button  text'' 
		description: ''Longer descriptive text appearing in help balloons''

The block given to the ServiceActions can take an instance of the Requestor class as parameter. You can fetch data from these. The generic format is to call methods starting with ''get'' on the requestor, like getClass, getMessageName for services related to the browser.	

The organisation of services into categories, and the services bound to keyboard shortcuts are
specified using the Services Browser, based on the Preference Browser by Hernan Tylim. When editing preferences, they are saved as methods on the ServiceProvider, all defined in the ''saved preferences'' method category. 

When opening the Services Browser you see a list of preference categories on the left, and the preferences inside this category on the right. The main preference categories for services are: 

-- keyboard shortcuts -- : several text preferences, one per keyboard shortcuts. To edit them,  enter a service identifier (equal to the method name under which it is defined in its ServiceProvider), and accept with alt-s or enter

-- menu contents -- : All the service categories in the image have a text preference under here. To edit it, enter the services identifiers you wish to put in this category, separating them with a single space character. The order is important: it defines the order of the items in menus.

-- settings -- : general boolean preferences.

Then there is a preference category for each provider in the image. Under each, you will find:
A boolean preference for each service in the image. If it is false, the service will not appear in menus. 
The text preference for each service category defined by the service provider. This is the same as the one appearing in the menu contents preference category.

Some identifiers of categories already appearing in the UI are:
- world : the world menu
- preferencesMenu
- browserClasssCategoryMenu
- browserClassMenu
- browserMethodCategoryMenu
- browserMethodMenu
- browserCodePaneMenu
- browserButtonBar

After editing these preferences to match the services and categories you defined for your application, you should be done.

	Romain Robbes'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WorldMenuProvider class
	instanceVariableNames: ''!

!WorldMenuProvider class methodsFor: 'initialize-release' stamp: 'rr 1/10/2006 12:53'!
initialize
	ServiceRegistry current buildProvider: self new! !
Object subclass: #WorldState
	instanceVariableNames: 'hands activeHand viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime commandHistory alarms lastAlarmTime remoteServer multiCanvas'
	classVariableNames: 'CanSurrenderToOS DeferredUIMessages DisableDeferredUpdates LastCycleTime MinCycleLapse'
	poolDictionaries: ''
	category: 'Morphic-Worlds'!
!WorldState commentStamp: 'ls 7/10/2003 19:30' prior: 0!
The state of a Morphic world.  (This needs some serious commenting!!!!)


The MinCycleLapse variable holds the minimum amount of time that a morphic cycle is allowed to take.  If a cycle takes less than this, then interCyclePause: will wait until the full time has been used up.!


!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 16:43'!
addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime
	"Add a new alarm with the given set of parameters"
	self alarms add: 
		(MorphicAlarm 
			scheduledAt: scheduledTime
			receiver: aTarget
			selector: aSelector
			arguments: argArray).! !

!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 17:11'!
adjustAlarmTimes: nowTime
	"Adjust the alarm times after some clock weirdness (such as roll-over, image-startup etc)"
	| deltaTime |
	deltaTime _ nowTime - lastAlarmTime.
	self alarms do:[:alarm| alarm scheduledTime: alarm scheduledTime + deltaTime].! !

!WorldState methodsFor: 'alarms' stamp: 'RAA 1/7/2001 12:33'!
alarmSortBlock

	| answer |

	"Please pardon the hackery below. Since the block provided by this method is retained elsewhere, it is possible that the block argument variables would retain references to objects that were no longer really needed. In one case, this feature resulted in doubling the size of a published project."

	^[ :alarm1 :alarm2 | 
		answer _ alarm1 scheduledTime < alarm2 scheduledTime.
		alarm1 _ alarm2 _ nil.
		answer
	]! !

!WorldState methodsFor: 'alarms' stamp: 'RAA 1/5/2001 10:46'!
alarms

	^alarms ifNil: [alarms _ Heap sortBlock: self alarmSortBlock]! !

!WorldState methodsFor: 'alarms' stamp: 'dgd 2/22/2003 13:31'!
removeAlarm: aSelector for: aTarget 
	"Remove the alarm with the given selector"

	| alarm |
	alarm := self alarms 
				detect: [:any | any receiver == aTarget and: [any selector == aSelector]]
				ifNone: [nil].
	alarm isNil ifFalse: [self alarms remove: alarm]! !

!WorldState methodsFor: 'alarms' stamp: 'ar 10/22/2000 16:55'!
triggerAlarmsBefore: nowTime
	"Trigger all pending alarms that are to be executed before nowTime."
	| pending |
	lastAlarmTime ifNil:[lastAlarmTime _ nowTime].
	(nowTime < lastAlarmTime or:[nowTime - lastAlarmTime > 10000])
		ifTrue:[self adjustAlarmTimes: nowTime].
	pending _ self alarms.
	[pending isEmpty not and:[pending first scheduledTime < nowTime]]
		whileTrue:[pending removeFirst value: nowTime].
	lastAlarmTime _ nowTime.! !


!WorldState methodsFor: 'canvas' stamp: 'ar 10/26/2000 14:10'!
assuredCanvas
	remoteServer ifNotNil:[^self assuredRemoteCanvas].
	(canvas isNil or: [(canvas extent ~= viewBox extent) or: [canvas form depth ~= Display depth]])
		ifTrue:
			["allocate a new offscreen canvas the size of the window"
			self canvas: (Display defaultCanvasClass extent: viewBox extent)].
	^ self canvas! !

!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'!
canvas

	^ canvas! !

!WorldState methodsFor: 'canvas' stamp: 'dgd 2/22/2003 13:29'!
canvas: x 
	canvas := x.
	damageRecorder isNil 
		ifTrue: [damageRecorder := DamageRecorder new]
		ifFalse: [damageRecorder doFullRepaint]! !

!WorldState methodsFor: 'canvas' stamp: 'RAA 5/25/2000 15:12'!
doFullRepaint

	damageRecorder doFullRepaint
! !

!WorldState methodsFor: 'canvas' stamp: 'ar 1/30/2001 23:25'!
recordDamagedRect: damageRect

	damageRecorder ifNotNil: [damageRecorder recordInvalidRect: damageRect truncated]
! !

!WorldState methodsFor: 'canvas' stamp: 'RAA 5/25/2000 15:10'!
resetDamageRecorder

	damageRecorder reset
! !

!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'!
viewBox

	^ viewBox! !

!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:58'!
viewBox: x

	viewBox _ x! !


!WorldState methodsFor: 'hands' stamp: 'ar 1/22/2001 14:26'!
activeHand

	^ ActiveHand! !

!WorldState methodsFor: 'hands' stamp: 'ar 10/26/2000 14:51'!
addHand: aHandMorph
	"Add the given hand to the list of hands for this world."

	hands _ (hands copyWithout: aHandMorph) copyWith: aHandMorph.
! !

!WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:40'!
hands

	^ hands! !

!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13'!
handsDo: aBlock

	^ hands do: aBlock! !

!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09'!
handsReverseDo: aBlock

	^ hands reverseDo: aBlock! !

!WorldState methodsFor: 'hands' stamp: 'ar 1/22/2001 14:26'!
removeHand: aHandMorph
	"Remove the given hand from the list of hands for this world."

	(hands includes: aHandMorph) ifFalse: [^self].
	hands _ hands copyWithout: aHandMorph.
	ActiveHand == aHandMorph ifTrue: [ActiveHand _ nil].
! !

!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:56'!
selectHandsToDrawForDamage: damageList
	"Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle."

	| result hBnds |
	result _ OrderedCollection new.
	hands do: [:h |
		h needsToBeDrawn ifTrue: [
			h hasChanged
				ifTrue: [result add: h]
				ifFalse: [
					hBnds _ h fullBounds.
					(damageList detect: [:r | r intersects: hBnds] ifNone: [nil])
						ifNotNil: [result add: h]]]].
	^ result
! !


!WorldState methodsFor: 'initialization' stamp: 'RAA 1/5/2001 10:47'!
initialize

	hands _ Array new.
	damageRecorder_ DamageRecorder new.
	stepList _ Heap sortBlock: self stepListSortBlock.
	lastStepTime _ 0.
	lastAlarmTime _ 0.! !

!WorldState methodsFor: 'initialization' stamp: 'sw 9/5/2000 06:39'!
stepListSize
	^ stepList size! !

!WorldState methodsFor: 'initialization' stamp: 'RAA 1/7/2001 12:33'!
stepListSortBlock

	| answer |

	"Please pardon the hackery below. Since the block provided by this method is retained elsewhere, it is possible that the block argument variables would retain references to objects that were no longer really needed. In one case, this feature resulted in doubling the size of a published project."

	^[ :stepMsg1 :stepMsg2 | 
		answer _ stepMsg1 scheduledTime <= stepMsg2 scheduledTime.
		stepMsg1 _ stepMsg2 _ nil.
		answer
	]! !


!WorldState methodsFor: 'object fileIn' stamp: 'RAA 1/5/2001 10:51'!
convertAlarms
	
	alarms ifNotNil: [alarms sortBlock: self alarmSortBlock].	"ensure cleaner block"

! !

!WorldState methodsFor: 'object fileIn' stamp: 'dgd 2/22/2003 13:30'!
convertStepList
	"Convert the old-style step list (an Array of Arrays) into the new-style StepMessage heap"

	| newList wakeupTime morphToStep |
	(stepList isKindOf: Heap) 
		ifTrue: 
			[^stepList sortBlock: self stepListSortBlock	"ensure that we have a cleaner block"].
	newList := Heap sortBlock: self stepListSortBlock.
	stepList do: 
			[:entry | 
			wakeupTime := entry second.
			morphToStep := entry first.
			newList add: (StepMessage 
						scheduledAt: wakeupTime
						stepTime: nil
						receiver: morphToStep
						selector: #stepAt:
						arguments: nil)].
	stepList := newList! !


!WorldState methodsFor: 'objects from disk' stamp: 'RAA 1/5/2001 10:51'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"Convert the old to new step lists"
	self convertStepList.
	self convertAlarms.
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:23'!
adjustWakeupTimes: now
	"Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurence with a 32-bit clock!!)"
	| deltaTime |
	deltaTime _ now - lastStepTime.
	stepList do:[:entry| entry scheduledTime: entry scheduledTime + deltaTime].
	lastStepTime _ now.
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 15:22'!
adjustWakeupTimesIfNecessary
	"Fix the wakeup times in my step list if necessary. This is needed after a snapshot, after a long pause (say because some other view had control or because the user was selecting from an MVC-style menu) or when the millisecond clock wraps around (a very rare occurence with a 32-bit clock!!)."

	| now |
	now _ Time millisecondClockValue.
	((now < lastStepTime) or: [(now - lastStepTime) > 5000])
		 ifTrue: [self adjustWakeupTimes: now].  "clock slipped"
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 2/23/2001 21:14'!
cleanseStepListForWorld: aWorld
	"Remove morphs from the step list that are not in this World.  Often were in a flap that has moved on to another world."

	| deletions morphToStep |
	deletions _ nil.
	stepList do: [:entry |
		morphToStep _ entry receiver.
		morphToStep world == aWorld ifFalse:[
			deletions ifNil: [deletions _ OrderedCollection new].
			deletions addLast: entry]].

	deletions ifNotNil:[
		deletions do: [:entry|
			self stopStepping: entry receiver]].

	self alarms copy do:[:entry|
		morphToStep _ entry receiver.
		(morphToStep isMorph and:[morphToStep world == aWorld]) 
			ifFalse:[self removeAlarm: entry selector for: entry receiver]].! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:09'!
isStepping: aMorph
	"Return true if the given morph is in the step list."
	lastStepMessage ifNotNil:[(lastStepMessage receiver == aMorph) ifTrue:[^true]].
	stepList do:[:entry| entry receiver == aMorph ifTrue:[^true]].
	^ false! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:09'!
isStepping: aMorph selector: aSelector
	"Return true if the given morph is in the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
			ifTrue:[^true]].
	stepList do:[:entry| (entry receiver == aMorph and:[entry selector == aSelector]) ifTrue:[^true]].
	^ false! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:05'!
listOfSteppingMorphs
	^stepList collect:[:entry| entry receiver].
! !

!WorldState methodsFor: 'stepping' stamp: 'dgd 2/22/2003 13:31'!
runLocalStepMethodsIn: aWorld 
	"Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world.
	ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors."

	| now morphToStep stepTime priorWorld |
	now := Time millisecondClockValue.
	priorWorld := ActiveWorld.
	ActiveWorld := aWorld.
	self triggerAlarmsBefore: now.
	stepList isEmpty 
		ifTrue: 
			[ActiveWorld := priorWorld.
			^self].
	(now < lastStepTime or: [now - lastStepTime > 5000]) 
		ifTrue: [self adjustWakeupTimes: now].	"clock slipped"
	[stepList isEmpty not and: [stepList first scheduledTime < now]] 
		whileTrue: 
			[lastStepMessage := stepList removeFirst.
			morphToStep := lastStepMessage receiver.
			(morphToStep shouldGetStepsFrom: aWorld) 
				ifTrue: 
					[lastStepMessage value: now.
					lastStepMessage ifNotNil: 
							[stepTime := lastStepMessage stepTime ifNil: [morphToStep stepTime].
							lastStepMessage scheduledTime: now + (stepTime max: 1).
							stepList add: lastStepMessage]].
			lastStepMessage := nil].
	lastStepTime := now.
	ActiveWorld := priorWorld! !

!WorldState methodsFor: 'stepping' stamp: 'sk 1/26/2003 18:31'!
runStepMethodsIn: aWorld
	"Perform periodic activity inbetween event cycles"
	| queue numItems i limit stamp |

	queue _ self class deferredUIMessages.
	numItems _ queue size.
	i _ 0.
	limit _ self class deferredExecutionTimeLimit.
	stamp _ Time millisecondClockValue.

	"Dispatch deferred messages while maintaing rudimentary UI responsiveness."
	[i < numItems and: [(Time millisecondsSince: stamp) < limit]]
		whileTrue: [queue next value. i _ i + 1].

	self runLocalStepMethodsIn: aWorld.

	"we are using a normal #step for these now"
	"aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]."
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:36'!
startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
	"Add the given morph to the step list. Do nothing if it is already being stepped."

	self stopStepping: aMorph selector: aSelector.
	self adjustWakeupTimesIfNecessary.
	stepList add:(
		StepMessage 
			scheduledAt: scheduledTime
			stepTime: stepTime
			receiver: aMorph
			selector: aSelector
			arguments: args)! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:10'!
stopStepping: aMorph
	"Remove the given morph from the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph) ifTrue:[lastStepMessage _ nil]].
	stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph]).
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:10'!
stopStepping: aMorph selector: aSelector
	"Remove the given morph from the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
			ifTrue:[lastStepMessage _ nil]].
	stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and:[stepMsg selector == aSelector]]).! !


!WorldState methodsFor: 'undo' stamp: 'ar 8/31/2000 22:57'!
commandHistory
	^commandHistory ifNil:[commandHistory _ CommandHistory new]! !


!WorldState methodsFor: 'undo support' stamp: 'RAA 9/21/2000 20:05'!
clearCommandHistory

	"useful prior to project saves"
	commandHistory _ nil! !


!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13'!
checkIfUpdateNeeded

	damageRecorder updateIsNeeded ifTrue: [^true].
	hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]].
	^false  "display is already up-to-date"
! !

!WorldState methodsFor: 'update cycle' stamp: 'ar 4/25/2001 17:01'!
displayWorld: aWorld submorphs: submorphs
	"Update this world's display."

	| deferredUpdateMode worldDamageRects handsToDraw handDamageRects allDamage |

	submorphs do: [:m | m fullBounds].  "force re-layout if needed"
	self checkIfUpdateNeeded ifFalse: [^ self].  "display is already up-to-date"

	deferredUpdateMode _ self doDeferredUpdatingFor: aWorld.
	deferredUpdateMode ifFalse: [self assuredCanvas].
	canvas roundCornersOf: aWorld during:[
		worldDamageRects _ self drawWorld: aWorld submorphs: submorphs invalidAreasOn: canvas.  "repair world's damage on canvas"
		"self handsDo:[:h| h noticeDamageRects: worldDamageRects]."
		handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects.
		handDamageRects _ handsToDraw collect: [:h | h savePatchFrom: canvas].
		allDamage _ worldDamageRects, handDamageRects.

		handsToDraw reverseDo: [:h | canvas fullDrawMorph: h].  "draw hands onto world canvas"
	].
	"*make this true to flash damaged areas for testing*"
	Preferences debugShowDamage ifTrue: [aWorld flashRects: allDamage color: Color black].

	canvas finish.
	"quickly copy altered rects of canvas to Display:"
	deferredUpdateMode
		ifTrue: [self forceDamageToScreen: allDamage]
		ifFalse: [canvas showAt: aWorld viewBox origin invalidRects: allDamage].
	handsToDraw do: [:h | h restoreSavedPatchOn: canvas].  "restore world canvas under hands"
	Display deferUpdates: false; forceDisplayUpdate.
! !

!WorldState methodsFor: 'update cycle' stamp: 'ar 6/28/2003 01:07'!
displayWorldSafely: aWorld
	"Update this world's display and keep track of errors during draw methods."

	[aWorld displayWorld] ifError: [:err :rcvr |
		"Handle a drawing error"
		| errCtx errMorph |
		errCtx _ thisContext.
		[
			errCtx _ errCtx sender.
			"Search the sender chain to find the morph causing the problem"
			[errCtx notNil and:[(errCtx receiver isMorph) not]] 
				whileTrue:[errCtx _ errCtx sender].
			"If we're at the root of the context chain then we have a fatal drawing problem"
			errCtx ifNil:[^self handleFatalDrawingError: err].
			errMorph _ errCtx receiver.
			"If the morph causing the problem has already the #drawError flag set,
			then search for the next morph above in the caller chain."
			errMorph hasProperty: #errorOnDraw
		] whileTrue.
		errMorph setProperty: #errorOnDraw toValue: true.
		"Install the old error handler, so we can re-raise the error"
		rcvr error: err.
	].! !

!WorldState methodsFor: 'update cycle' stamp: 'ar 10/26/2000 14:12'!
doDeferredUpdatingFor: aWorld
        "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature."
	| properDisplay |
	PasteUpMorph disableDeferredUpdates ifTrue: [^ false].
	(Display deferUpdates: true) ifNil: [^ false].  "deferred updates not supported"
	remoteServer ifNotNil:[
		self assuredCanvas.
		^true].
	properDisplay _ canvas notNil and: [canvas form == Display].
	aWorld == World ifTrue: [  "this world fills the entire Display"
		properDisplay ifFalse: [
			aWorld viewBox: Display boundingBox.    "do first since it may clear canvas"
			self canvas: (Display getCanvas copyClipRect: Display boundingBox).
		]
	] ifFalse: [  "this world is inside an MVC window"
		(properDisplay and: [canvas clipRect = aWorld viewBox]) ifFalse: [
			self canvas:
				(Display getCanvas copyOffset: 0@0 clipRect: aWorld viewBox)
		]
	].
	^ true
! !

!WorldState methodsFor: 'update cycle' stamp: 'ls 5/6/2003 16:51'!
doOneCycleFor: aWorld
	"Do one cycle of the interaction loop. This method is called repeatedly when the world is running.

This is a moderately private method; a better alternative is usually either to wait for events or to check the state of things from #step methods."

	self interCyclePause: (Preferences higherPerformance ifTrue: [1] ifFalse: [MinCycleLapse]).
	self doOneCycleNowFor: aWorld.! !

!WorldState methodsFor: 'update cycle' stamp: 'md 3/19/2006 22:16'!
doOneCycleNowFor: aWorld
	"Immediately do one cycle of the interaction loop.
	This should not be called directly, but only via doOneCycleFor:"

	| capturingGesture |
	DisplayScreen checkForNewScreenSize.
	capturingGesture _ false.
	"self flag: #bob.	"	"need to consider remote hands in lower worlds"

	"process user input events"
	LastCycleTime _ Time millisecondClockValue.
	self handsDo: [:h |
		ActiveHand _ h.
		h processEvents.
		capturingGesture _ capturingGesture or: [ h isCapturingGesturePoints ].
		ActiveHand _ nil
	].

	"the default is the primary hand"
	ActiveHand _ self hands first.

	"The gesture recognizer needs enough points to be accurate.
	Therefore morph stepping is disabled while capturing points for the recognizer"
	capturingGesture ifFalse: 
		[aWorld runStepMethods.		"there are currently some variations here"
		self displayWorldSafely: aWorld].
! !

!WorldState methodsFor: 'update cycle' stamp: 'ar 1/22/2001 14:26'!
doOneSubCycleFor: aWorld
	"Like doOneCycle, but preserves activeHand."

	| currentHand |
	currentHand _ ActiveHand.
	self doOneCycleFor: aWorld.
	ActiveHand _ currentHand! !

!WorldState methodsFor: 'update cycle' stamp: 'dgd 2/22/2003 13:31'!
drawWorld: aWorld submorphs: submorphs invalidAreasOn: aCanvas 
	"Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that
were redrawn."

	| rectList c i n mm morphs rects rectToFill remnants rect validList |
	rectList := damageRecorder invalidRectsFullBounds: aWorld viewBox.
	"sort by areas to draw largest portions first"
	rectList := rectList asArray sort: [:r1 :r2 | r1 area > r2 area].
	damageRecorder reset.
	n := submorphs size.
	morphs := OrderedCollection new: n * 2.
	rects := OrderedCollection new: n * 2.
	validList := OrderedCollection new: n * 2.
	rectList do: 
			[:dirtyRect | 
			dirtyRect allAreasOutsideList: validList
				do: 
					[:r | 
					"Experimental top-down drawing --
			Traverses top to bottom, stopping if the entire area is filled.
			If only a single rectangle remains, then continue with the reduced rectangle."

					rectToFill := r.
					i := 1.
					[rectToFill isNil or: [i > n]] whileFalse: 
							[mm := submorphs at: i.
							((mm fullBounds intersects: r) and: [mm visible]) 
								ifTrue: 
									[morphs addLast: mm.
									rects addLast: rectToFill.
									remnants := mm areasRemainingToFill: rectToFill.
									remnants size = 1 ifTrue: [rectToFill := remnants first].
									remnants isEmpty ifTrue: [rectToFill := nil]].
							i := i + 1].

					"Now paint from bottom to top, but using the reduced rectangles."
					rectToFill 
						ifNotNil: [aWorld drawOn: (c := aCanvas copyClipRect: rectToFill)].
					[morphs isEmpty] whileFalse: 
							[(rect := rects removeLast) == rectToFill 
								ifFalse: [c := aCanvas copyClipRect: (rectToFill := rect)].
							c fullDrawMorph: morphs removeLast].
					morphs reset.
					rects reset.
					validList add: r]].
	^validList! !

!WorldState methodsFor: 'update cycle' stamp: 'ar 4/19/2001 05:45'!
forceDamageToScreen: allDamage

	"here for the convenience of NebraskaWorldState"
	Display forceDamageToScreen: allDamage.
	self remoteCanvasesDo: [ :each | 
		allDamage do: [:r | each forceToScreen: r].
		each displayIsFullyUpdated.
	].! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 10:16'!
handleFatalDrawingError: errMsg
	"Handle a fatal drawing error."
	Smalltalk isMorphic ifFalse:[^self error: errMsg]. "Can still handle it from MVC"
	Display deferUpdates: false. "Just in case"
	self primitiveError: errMsg.

	"Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! !

!WorldState methodsFor: 'update cycle' stamp: 'ls 7/10/2003 21:32'!
interCyclePause: milliSecs
	"delay enough that the previous cycle plus the amount of delay will equal milliSecs.  If the cycle is already expensive, then no delay occurs.  However, if the system is idly waiting for interaction from the user, the method will delay for a proportionally long time and cause the overall CPU usage of Squeak to be low."

	| currentTime wait |

	(lastCycleTime notNil and: [CanSurrenderToOS ~~ false]) ifTrue: [ 
		 currentTime _ Time millisecondClockValue.
		  wait _ lastCycleTime + milliSecs - currentTime.
		  (wait > 0 and: [ wait <= milliSecs ] )
		ifTrue: [
			(Delay forMilliseconds: wait) wait ]. 
	].

	lastCycleTime _  Time millisecondClockValue.
	CanSurrenderToOS _ true.! !


!WorldState methodsFor: '*MorphicExtras-hands' stamp: 'ar 1/22/2001 14:26'!
activeHand: aHandMorph
	"still needed until event loop with old code goes away"
	ActiveHand _ aHandMorph.! !


!WorldState methodsFor: '*MorphicExtras-initialization' stamp: 'ar 10/22/2000 16:04'!
stepListSummary
	^ String streamContents:
		[:aStream |
			aStream nextPutAll: stepList size printString, ' items in steplist:'.
			stepList do:
				[:anElement | aStream nextPutAll: anElement receiver printString]]

"Transcript cr show: self currentWorld stepListSummary"! !


!WorldState methodsFor: '*MorphicExtras-update cycle' stamp: 'RAA 6/6/2000 17:30'!
displayWorldAsTwoTone: aWorld submorphs: submorphs color: color
	"Display the world in living black-and-white. (This is typically done to save space.)"

	| f |
	f _ ColorForm extent: aWorld viewBox extent depth: 1.
	f colors: (Array with: color dominantColor with: Color black).
	self canvas: f getCanvas.

	"force the entire canvas to be redrawn"
	aWorld fullRepaintNeeded.
	self drawWorld: aWorld submorphs: submorphs invalidAreasOn: canvas.  "redraw on offscreen canvas"
	canvas showAt: aWorld viewBox origin.  "copy redrawn areas to Display"
	Display forceDisplayUpdate.
	self canvas: nil.  "forget my canvas to save space"
! !

!WorldState methodsFor: '*MorphicExtras-update cycle' stamp: 'ar 1/22/2001 14:26'!
doOneCycleInBackground
	"Do one cycle of the interactive loop. This method is called repeatedly when this world is not the active window but is running in the background."

self halt.		"not ready for prime time"

	"process user input events, but only for remote hands"
	self handsDo: [:h |
		(h isKindOf: RemoteHandMorph) ifTrue: [
			ActiveHand _ h.
			h processEvents.
			ActiveHand _ nil]].

	self runStepMethods.
	self displayWorldSafely.
! !

!WorldState methodsFor: '*MorphicExtras-update cycle' stamp: 'di 6/10/1999 22:40'!
startBackgroundProcess
	"Start a process to update this world in the background. Return the process created."

	| p |
	p _ [[true] whileTrue: [
		self doOneCycleInBackground.
		(Delay forMilliseconds: 20) wait]] newProcess.
	p resume.
	^ p
! !


!WorldState methodsFor: '*nebraska-Nebraska support' stamp: 'ar 10/26/2000 14:11'!
addRemoteCanvas: c
	self canvas: nil. "force recomputation"! !

!WorldState methodsFor: '*nebraska-Nebraska support' stamp: 'ar 10/26/2000 14:17'!
assuredRemoteCanvas
	| newCanvas |
	(self canvas notNil) ifTrue: [ ^self canvas ].
	newCanvas := MultiCanvas new.
	newCanvas depth: 32.
	newCanvas extent: viewBox extent.
	self remoteCanvasesDo: [ :c | newCanvas addCanvas: c ].
	newCanvas addCanvas: Display getCanvas.

	"newCanvas := CachingCanvas on: newCanvas."
	self canvas: newCanvas.
	^newCanvas! !

!WorldState methodsFor: '*nebraska-Nebraska support' stamp: 'sd 11/20/2005 21:25'!
releaseRemoteServer
	"My server has been transferred to some other world. Release pending references"
	remoteServer := nil.
	self canvas: nil.! !

!WorldState methodsFor: '*nebraska-Nebraska support' stamp: 'ar 10/26/2000 14:15'!
remoteCanvasesDo: aBlock
	remoteServer ifNil:[^self].
	^remoteServer clients do:[:client| aBlock value: client canvas]! !

!WorldState methodsFor: '*nebraska-Nebraska support' stamp: 'ar 10/26/2000 14:08'!
remoteServer
	^remoteServer! !

!WorldState methodsFor: '*nebraska-Nebraska support' stamp: 'sd 11/20/2005 21:25'!
remoteServer: aNebraskaServer
	remoteServer ifNotNil:[remoteServer destroy].
	remoteServer := aNebraskaServer.
	self canvas: nil.! !

!WorldState methodsFor: '*nebraska-Nebraska support' stamp: 'ar 10/26/2000 14:17'!
removeRemoteCanvas: c
	self canvas: nil.	"force withdrawal of remote from MultiCanvas"
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WorldState class
	instanceVariableNames: ''!

!WorldState class methodsFor: 'accessing' stamp: 'RAA 1/7/2001 16:32'!
classVersion

	^1		"force cleanup of alarms and stepList"! !

!WorldState class methodsFor: 'accessing' stamp: 'sk 1/26/2003 18:29'!
deferredExecutionTimeLimit
	"Answer the maximum time in milliseconds that should be spent dispatching deferred UI messages in WorldState>>runStepMethodsIn:."

	^ 200! !


!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 16:40'!
canSurrenderToOS: aBoolean

	CanSurrenderToOS _ aBoolean! !

!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 17:28'!
lastCycleTime

	^LastCycleTime! !


!WorldState class methodsFor: 'class initialization' stamp: 'RAA 7/15/2000 12:58'!
addDeferredUIMessage: valuableObject

	self deferredUIMessages nextPut: valuableObject.

! !

!WorldState class methodsFor: 'class initialization' stamp: 'RAA 7/15/2000 12:58'!
deferredUIMessages

	^DeferredUIMessages ifNil: [DeferredUIMessages _ SharedQueue new].
! !

!WorldState class methodsFor: 'class initialization' stamp: 'RAA 7/15/2000 12:56'!
initialize
	"WorldState initialize"

	MinCycleLapse _ 20.		"allows 50 frames per second..."
	DisableDeferredUpdates _ false.
	DeferredUIMessages _ SharedQueue new.! !
Object subclass: #WorldViewModel
	instanceVariableNames: 'initialExtent'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-ST80'!
!WorldViewModel commentStamp: '<historical>' prior: 0!
Serves as a model for a WorldView -- a morphic world viewed within an mvc project.!


!WorldViewModel methodsFor: 'as yet unclassified' stamp: 'sw 9/21/1998 17:51'!
initialExtent: anExtent
	initialExtent _ anExtent! !


!WorldViewModel methodsFor: 'user interface' stamp: 'sw 9/21/1998 17:50'!
fullScreenSize
	"Answer the size to which a window displaying the receiver should be set"

	^ (0@0 extent: DisplayScreen actualScreenSize) copy! !

!WorldViewModel methodsFor: 'user interface' stamp: 'sw 9/21/1998 17:51'!
initialExtent
	initialExtent ifNotNil: [^ initialExtent].
	^ super initialExtent! !
SystemWindow subclass: #WorldWindow
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalWorlds'!
!WorldWindow commentStamp: '<historical>' prior: 0!
A WorldWindow is a SystemWindow whose central area presents an inner Morphic world.

WorldWindows have a red title bar when the world inside is inactive. This changes to green when the world becomes the active world. The world inside becomes activated by clicking in it. When you click outside this world, the parent world resumes control. While its world is inactive, the WorldWindow may be moved and resized like any other.

It would be nice to make the world inside active whenever the WorldWindow was active, but this presents difficulties in moving and resizing, probably related to use of the global World instead of self world in many methods.

This facility is mainly the work of Bob Arning, with a number of tweaks by DI.
!


!WorldWindow methodsFor: 'event handling' stamp: 'RAA 11/23/1999 09:27'!
mouseUp: evt

	(self panelRect containsPoint: evt cursorPoint)
		ifTrue: [model becomeTheActiveWorldWith: evt]! !


!WorldWindow methodsFor: 'geometry' stamp: 'RAA 11/14/1999 12:11'!
extent: x

	super extent: x.
	model ifNil: [^self].
	model extent: self panelRect extent.! !


!WorldWindow methodsFor: 'initialization' stamp: 'ar 5/11/2001 23:48'!
openInWorld: aWorld
	"This msg and its callees result in the window being activeOnlyOnTop"
	self bounds: (RealEstateAgent initialFrameFor: self world: aWorld).
	self firstSubmorph position: (self left + 1) @ (self top + self labelHeight).
	^self openAsIsIn: aWorld! !


!WorldWindow methodsFor: 'layout' stamp: 'RAA 11/13/1999 23:24'!
fullBounds

	^self bounds! !


!WorldWindow methodsFor: 'menu' stamp: 'RAA 11/21/1999 23:05'!
buildWindowMenu

	| aMenu |
	aMenu _ super buildWindowMenu.
	{640@480. 800@600. 832@624. 1024@768} do: [ :each |
		aMenu 
			add: each x printString,' x ',each y printString 
			target: self 
			selector: #extent: 
			argument: each + (0@self labelHeight).
	].
	^aMenu! !


!WorldWindow methodsFor: 'resize/collapse' stamp: 'di 11/25/1999 23:14'!
collapseOrExpand

	super collapseOrExpand.
	isCollapsed ifFalse: [model becomeTheActiveWorldWith: nil]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WorldWindow class
	instanceVariableNames: ''!

!WorldWindow class methodsFor: 'as yet unclassified' stamp: 'di 11/17/1999 11:12'!
test1
	"WorldWindow test1."

	| window world |
	world _ WiWPasteUpMorph newWorldForProject: nil.
	window _ (WorldWindow labelled: 'Inner World') model: world.
	window addMorph: world.
	world hostWindow: window.
	window openInWorld
! !

!WorldWindow class methodsFor: 'as yet unclassified' stamp: 'di 11/17/1999 11:39'!
test2
	"WorldWindow test2."

	| window world scrollPane |
	world _ WiWPasteUpMorph newWorldForProject: nil.
	window _ (WorldWindow labelled: 'Scrollable World') model: world.
	window addMorph: (scrollPane _ TwoWayScrollPane new model: world)
		frame: (0@0 extent: 1.0@1.0).
	scrollPane scroller addMorph: world.
	world hostWindow: window.
	window openInWorld
! !
PositionableStream subclass: #WriteStream
	instanceVariableNames: 'writeLimit'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!WriteStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects that can only store objects in the sequence.!


!WriteStream methodsFor: 'accessing'!
contents

	readLimit _ readLimit max: position.
	^collection copyFrom: 1 to: position! !

!WriteStream methodsFor: 'accessing'!
next

	self shouldNotImplement! !

!WriteStream methodsFor: 'accessing' stamp: 'yo 2/18/2004 14:41'!
next: anInteger putAll: aCollection startingAt: startIndex
	"Store the next anInteger elements from the given collection."

	| newEnd numPut |
	collection class == aCollection class ifFalse:
		[^ super next: anInteger putAll: aCollection startingAt: startIndex ].

	numPut _ anInteger min: (aCollection size - startIndex + 1).
	newEnd _ position + numPut.
	newEnd > writeLimit ifTrue:
		[^ super next: anInteger putAll: aCollection startingAt: startIndex "Trigger normal pastEndPut: logic"].

	collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: startIndex.
	position _ newEnd.
! !

!WriteStream methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:34'!
nextPut: anObject 
	"Primitive. Insert the argument at the next position in the Stream
	represented by the receiver. Fail if the collection of this stream is not an
	Array or a String. Fail if the stream is positioned at its end, or if the
	position is out of bounds in the collection. Fail if the argument is not
	of the right type for the collection. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 66>
	((collection class == ByteString) and: [
		anObject isCharacter and:[anObject isOctetCharacter not]]) ifTrue: [
			collection _ (WideString from: collection).
			^self nextPut: anObject.
	].
	position >= writeLimit
		ifTrue: [^ self pastEndPut: anObject]
		ifFalse: 
			[position _ position + 1.
			^collection at: position put: anObject]! !

!WriteStream methodsFor: 'accessing' stamp: 'BG 5/24/2003 20:41'!
nextPutAll: aCollection

	| newEnd |
	collection class == aCollection class ifFalse:
		[^ super nextPutAll: aCollection ].

	newEnd _ position + aCollection size.
	newEnd > writeLimit ifTrue:
		[self growTo: newEnd + 10].

	collection replaceFrom: position+1 to: newEnd  with: aCollection startingAt: 1.
	position _ newEnd.! !

!WriteStream methodsFor: 'accessing'!
size

	^readLimit _ readLimit max: position! !


!WriteStream methodsFor: 'character writing'!
cr
	"Append a return character to the receiver."

	self nextPut: Character cr! !

!WriteStream methodsFor: 'character writing'!
crtab
	"Append a return character, followed by a single tab character, to the 
	receiver."

	self nextPut: Character cr.
	self nextPut: Character tab! !

!WriteStream methodsFor: 'character writing'!
crtab: anInteger 
	"Append a return character, followed by anInteger tab characters, to the 
	receiver."

	self nextPut: Character cr.
	anInteger timesRepeat: [self nextPut: Character tab]! !

!WriteStream methodsFor: 'character writing' stamp: 'RAA 3/5/2001 10:26'!
ensureASpace
	"Append a space character to the receiver IFF there is not one on the end."

	(position > 0 and: [(collection at: position) = Character space]) ifTrue: [^self].
	self nextPut: Character space! !

!WriteStream methodsFor: 'character writing' stamp: 'tk 9/23/2001 01:16'!
ensureNoSpace
	"If there is not one on the end, remove it."

	(position > 0 and: [(collection at: position) = Character space]) 
		ifTrue: [self skip: -1].! !

!WriteStream methodsFor: 'character writing' stamp: 'di 6/7/2000 22:43'!
nextPutKeyword: keyword withArg: argValue
	"Emit a keyword/value pair in the alternate syntax"

	self nextPutAll: (keyword copyWithout: $:);
		nextPut: $(;
		store: argValue;
		nextPut: $)! !

!WriteStream methodsFor: 'character writing' stamp: 'tk 10/19/2001 11:12'!
peekLast
	"Return that item just put at the end of the stream"

	^ position > 0 
		ifTrue: [collection at: position]
		ifFalse: [nil]! !

!WriteStream methodsFor: 'character writing'!
space
	"Append a space character to the receiver."

	self nextPut: Character space! !

!WriteStream methodsFor: 'character writing' stamp: 'JF 7/31/2003 13:01'!
space: anInteger 
	"Append anInteger space characters to the receiver."

	anInteger timesRepeat: [self space]! !

!WriteStream methodsFor: 'character writing'!
tab
	"Append a tab character to the receiver."

	self nextPut: Character tab! !

!WriteStream methodsFor: 'character writing' stamp: 'JF 7/31/2003 13:00'!
tab: anInteger 
	"Append anInteger tab characters to the receiver."

	anInteger timesRepeat: [self tab]! !


!WriteStream methodsFor: 'file open/close' stamp: 'mir 8/10/1999 11:56'!
flush! !


!WriteStream methodsFor: 'fileIn/Out' stamp: 'yo 8/13/2003 12:18'!
nextChunkPut: aString
	"Append the argument, aString, to the receiver, doubling embedded terminators."

	| i remainder terminator |
	terminator _ $!!.
	remainder _ aString.
	[(i _ remainder indexOf: terminator) = 0] whileFalse:
		[self nextPutAll: (remainder copyFrom: 1 to: i).
		self nextPut: terminator.  "double imbedded terminators"
		remainder _ remainder copyFrom: i+1 to: remainder size].
	self nextPutAll: remainder.
	aString includesUnifiedCharacter ifTrue: [
		self nextPut: terminator.
		self nextPutAll: ']lang['.
		aString writeLeadingCharRunsOn: self.
	].
	self nextPut: terminator.
! !

!WriteStream methodsFor: 'fileIn/Out' stamp: 'yo 8/28/2002 16:13'!
nextChunkPutWithStyle: aStringOrText
	"Append the argument, aText, to the receiver, doubling embedded terminators.  Put out one chunk for the string and one for the style runs.  Mark the style with ]style[."

	aStringOrText isString ifTrue: [^ self nextChunkPut: aStringOrText].
	aStringOrText runs coalesce.
	aStringOrText unembellished ifTrue: [^ self nextChunkPut: aStringOrText asString].

	self nextChunkPut: aStringOrText asString.
	self cr; nextPutAll: ']style['.
	self nextChunkPut: 
		(String streamContents: [:strm | 
			aStringOrText runs writeScanOn: strm]).
! !

!WriteStream methodsFor: 'fileIn/Out' stamp: 'nk 7/29/2004 10:11'!
timeStamp
	"Append the current time to the receiver as a String."
	self nextChunkPut:	"double string quotes and !!s"
		(String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString.
	self cr! !


!WriteStream methodsFor: 'positioning'!
position: anInteger 
	"Refer to the comment in PositionableStream|position:."

	readLimit _ readLimit max: position.
	super position: anInteger! !

!WriteStream methodsFor: 'positioning'!
reset 
	"Refer to the comment in PositionableStream|reset."

	readLimit _ readLimit max: position.
	position _ 0! !

!WriteStream methodsFor: 'positioning' stamp: 'ar 11/12/1998 21:27'!
resetToStart
	readLimit _ position _ 0.! !

!WriteStream methodsFor: 'positioning' stamp: 'ajh 5/25/2001 20:19'!
setToEnd 
	"Refer to the comment in PositionableStream|setToEnd."

	readLimit _ readLimit max: position.
	super setToEnd.! !


!WriteStream methodsFor: 'printing'!
store: anObject 
	"Have anObject print on the receiver for purposes of rereading."

	anObject storeOn: self! !


!WriteStream methodsFor: 'private' stamp: 'di 11/18/1999 22:55'!
braceArray
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	^ collection! !

!WriteStream methodsFor: 'private' stamp: 'di 11/18/1999 22:50'!
braceArray: anArray
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	collection _ anArray.
	position _ 0.
	readLimit _ 0.
	writeLimit _ anArray size.! !

!WriteStream methodsFor: 'private' stamp: 'BG 5/24/2003 22:49'!
growTo: anInteger

   " anInteger is the required minimal new size of the collection "
	| oldSize grownCollection newSize |
	oldSize _ collection size.
     newSize := anInteger + (oldSize // 4 max: 20).
	grownCollection _ collection class new: newSize.
	collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1.
	writeLimit _ collection size.
! !

!WriteStream methodsFor: 'private'!
on: aCollection

	super on: aCollection.
	readLimit _ 0.
	writeLimit _ aCollection size! !

!WriteStream methodsFor: 'private'!
on: aCollection from: firstIndex to: lastIndex

	| len |
	collection _ aCollection.
	readLimit _ 
		writeLimit _ lastIndex > (len _ collection size)
						ifTrue: [len]
						ifFalse: [lastIndex].
	position _ firstIndex <= 1
				ifTrue: [0]
				ifFalse: [firstIndex - 1]! !

!WriteStream methodsFor: 'private' stamp: 'md 2/24/2006 19:50'!
pastEndPut: anObject
	"Grow the collection by creating a new bigger collection and then
	copy over the contents from the old one. We grow by doubling the size
	but the growth is kept between 20 and 1000000.
	Finally we put <anObject> at the current write position."

	| oldSize grownCollection |
	oldSize _ collection size.
	grownCollection _ collection class new: oldSize + ((oldSize max: 20) min: 1000000).
	collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1.
	writeLimit _ collection size.
	collection at: (position _ position + 1) put: anObject.
	"return the argument - added by kwl"
	^ anObject! !

!WriteStream methodsFor: 'private'!
with: aCollection

	super on: aCollection.
	position _ readLimit _ writeLimit _ aCollection size! !

!WriteStream methodsFor: 'private'!
withAttribute: att do: strmBlock 
	"No-op here is overriden in TextStream for font emphasis"
	^ strmBlock value! !

!WriteStream methodsFor: 'private' stamp: 'djp 11/6/1999 23:15'!
withAttributes: attributes do: strmBlock 
	"No-op here is overriden in TextStream for font emphasis"
	^ strmBlock value! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WriteStream class
	instanceVariableNames: ''!

!WriteStream class methodsFor: 'instance creation'!
on: aCollection from: firstIndex to: lastIndex 
	"Answer an instance of me on a copy of the argument, aCollection, 
	determined by the indices firstIndex and lastIndex. Position the instance 
	at the beginning of the collection."

	^self basicNew
		on: aCollection
		from: firstIndex
		to: lastIndex! !

!WriteStream class methodsFor: 'instance creation'!
with: aCollection 
	"Answer an instance of me on the argument, aCollection, positioned to 
	store objects at the end of aCollection."

	^self basicNew with: aCollection! !

!WriteStream class methodsFor: 'instance creation'!
with: aCollection from: firstIndex to: lastIndex 
	"Answer an instance of me on the subcollection of the argument, 
	aCollection, determined by the indices firstIndex and lastIndex. Position 
	the instance to store at the end of the subcollection."

	^self basicNew with: (aCollection copyFrom: firstIndex to: lastIndex)! !
ClassTestCase subclass: #WriteStreamTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Streams'!

!WriteStreamTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:24'!
testNew

	self should: [WriteStream new] raise: Error. ! !

!WriteStreamTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:24'!
testSetToEnd

	| string stream |
	string := 'hello'.
	stream := WriteStream with: ''.
	stream nextPutAll: string.
	self assert: stream position = string size.
	stream setToEnd.
	self assert: stream position = string size.
	self assert: stream contents = string! !
Object subclass: #X11Encoding
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-ImmPlugin'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

X11Encoding class
	instanceVariableNames: ''!

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:09'!
encoding

	| enc |
	enc _ self getEncoding.
	enc ifNil: [ ^ nil ].
	^ enc asLowercase.! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:09'!
getEncoding
	<primitive: 'primGetEncoding' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
getLocaleEncoding
	<primitive: 'primGetLocaleEncoding' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
getPathEnc
	<primitive: 'primGetPathEnc' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
getTextEnc
	<primitive: 'primGetTextEnc' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
getXWinEnc
	<primitive: 'primGetXWinEnc' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
requestUTF8
	<primitive: 'primIsTextEncUTF8' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
requestUTF8: bool
	<primitive: 'primSetTextEncUTF8' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
setEncoding: encoding
	<primitive: 'primSetEncoding' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
setEncodingToLocale
	<primitive: 'primSetEncodingToLocale' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
setPathEnc: encoding
	<primitive: 'primSetPathEnc' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
setPathEncToLocale
	<primitive: 'primSetPathEncToLocale' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
setTextEnc: encoding
	<primitive: 'primSetTextEnc' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
setTextEncToLocale
	<primitive: 'primSetTextEncToLocale' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
setXWinEnc: encoding
	<primitive: 'primSetXWinEnc' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'!
setXWinEncToLocale
	<primitive: 'primSetXWinEncToLocale' module: 'ImmX11Plugin'>
	^ nil
! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'mir 7/15/2004 18:57'!
useEncoding: encoding

	self setEncoding: encoding.
	LanguageEnvironment startUp.
	^ self encoding.! !

!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'mir 7/15/2004 18:57'!
useLocaleEncoding

	self setEncodingToLocale.
	LanguageEnvironment startUp.
	^ self encoding.! !
ImageReadWriter subclass: #XBMReadWriter
	instanceVariableNames: 'width height'
	classVariableNames: 'Flipbits'
	poolDictionaries: ''
	category: 'Graphics-Files'!

!XBMReadWriter methodsFor: 'accessing' stamp: 'wdc 2/1/1999 07:15'!
nextImage
	"Read in the next xbm image from the stream."
	| form long incount chunks byteWidth pad fourway outcount total |
	stream reset.
	stream ascii.
	self readHeader.
	form _ ColorForm extent: width@height depth: 1.
	incount _ 0.	outcount _1.
	chunks _ Array new: 4.	byteWidth _ width + 7 // 8.
	total _ byteWidth * height.
	byteWidth > 4
		ifTrue: [ pad _ byteWidth \\ 4]
		ifFalse: [ pad _ 4 - byteWidth ].
	fourway _ 0.
	[(incount = total)] whileFalse: [
		incount _ incount + 1.
		fourway _ fourway + 1.
		chunks at: fourway put: (Flipbits at: ((self parseByteValue) +1)).
		(pad > 0 and: [(incount \\ byteWidth) = 0]) ifTrue: [
			1 to: pad do:
				[:q |	
  			fourway _ fourway + 1.	
			chunks at: fourway put: 0]
		].
		fourway = 4 ifTrue: [
			long _ Integer
				byte1: (chunks at: 4)
				byte2: (chunks at: 3)
				byte3: (chunks at: 2)
				byte4: (chunks at: 1).
			(form bits) at: outcount put: long.
			fourway _ 0.
			outcount _ outcount + 1].
		].
	 ^ form ! !

!XBMReadWriter methodsFor: 'accessing' stamp: 'nk 7/16/2003 18:18'!
understandsImageFormat
	"Test to see if the image stream format is understood by this decoder.	This should be implemented in each subclass of ImageReadWriter so that	a proper decoder can be selected without ImageReadWriter having to know about all possible image file types."
	| first |
	stream ascii.
	self skipCComments.
	first _ (stream next: 7) asString.
	stream binary.
	^ (first = '#define')! !


!XBMReadWriter methodsFor: 'private' stamp: 'wdc 2/2/1999 15:20'!
parseByteValue
	"skip over separators and return next bytevalue parsed as a C language number:
		0ddd is an octal digit.
		0xddd is a hex digit.
		ddd is decimal."
	| source mybase |
	stream skipSeparators.
	source _ ReadWriteStream on: String new.
	[stream atEnd or: [ stream peek isSeparator ]]
		whileFalse: [source nextPut: self next asUppercase].
	mybase _ 10. "Base 10 default"
	source reset.
	(source peek = $0) ifTrue: [
		mybase _ 8. "Octal or Hex, say its Octal unless overridden."
		source next.
		(source peek = $X) ifTrue: [
			mybase _ 16. "Ah.  It's Hex."
			source next.
			]
		].
	^ Integer readFrom: source base: mybase! !

!XBMReadWriter methodsFor: 'private' stamp: 'nk 7/16/2003 18:17'!
readHeader
	"Set width and height, and position stream at start of bytes"
	| number setwidth setheight fieldName |
	setwidth _ setheight _ false.
		[((stream atEnd) or: [setwidth and: [setheight]])]
		whileFalse: [
	  	self skipCComments.
		(stream nextMatchAll: '#define ') ifFalse: [^ false].
		(stream skipTo: $_) ifFalse: [^ false].
		fieldName _ String streamContents:
			[:source |
			[(stream atEnd) or: [ stream peek isSeparator ]]
				whileFalse: [ source nextPut: stream next]].
	  	(fieldName = 'width') ifTrue: [
			stream skipSeparators.
			number _ Integer readFrom: stream.
			(number > 0) ifTrue: [setwidth _true].
	  		width _ number.].
		(fieldName = 'height') ifTrue: [
			stream skipSeparators.
			number _ Integer readFrom: stream.
			(number > 0) ifTrue: [setheight _ true].
			height _ number.
			].
		].
	(setwidth & setheight) ifFalse: [^ false].
	^ stream skipTo: ${
! !

!XBMReadWriter methodsFor: 'private' stamp: 'nk 7/16/2003 18:15'!
skipCComments
	[ stream skipSeparators.
	stream peekFor: $/ ] whileTrue: [
		stream next.		"skip next *"
		[ (stream skipTo: $*) ifFalse: [ ^false ].
			stream peekFor: $/ ] whileFalse ]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

XBMReadWriter class
	instanceVariableNames: ''!

!XBMReadWriter class methodsFor: 'class initialization' stamp: 'wdc 2/2/1999 15:28'!
initialize
	"XBMReadWriter initialize"
	| flippedByte |
	Flipbits _ (0 to: 255) collect:
     [:n |  "Compute the bit-reversal of the 8-bit value, n"
     flippedByte _ 0.
     0 to: 7 do: 
         [:i | 
         flippedByte _ flippedByte bitOr: ((n >> i bitAnd: 1) << (7-i))].
         flippedByte]! !

!XBMReadWriter class methodsFor: 'class initialization' stamp: 'nk 7/16/2003 17:57'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('xbm')! !
Object subclass: #XTableForFixedFont
	instanceVariableNames: 'width maxCode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:14'!
at: anInteger

	(anInteger < 1 or: [maxCode + 2 < anInteger]) ifTrue: [
		self error: 'subscript out of bounds'.
	].
	^(anInteger - 1) * width.
! !

!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:14'!
maxAscii: anInteger

	maxCode _ anInteger.
! !

!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:14'!
maxCode

	^ maxCode.
! !

!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:14'!
size

	^ maxCode.
! !

!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:15'!
width

	^ width.
! !

!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:15'!
width: anInteger

	width _ anInteger.
! !
Object subclass: #XTableForUnicodeFont
	instanceVariableNames: 'ranges xTables'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Multilingual-Display'!

!XTableForUnicodeFont methodsFor: 'as yet unclassified' stamp: 'yo 12/28/2002 22:39'!
at: indexPlusOne

	| index |
	index _ indexPlusOne.
	ranges with: xTables do: [:range :xTable |
		(range first <= index and: [index <= range last]) ifTrue: [
			^ xTable at: index - range first + 1.
		].
	].
	^ 0.
! !

!XTableForUnicodeFont methodsFor: 'as yet unclassified' stamp: 'yo 12/28/2002 21:40'!
at: index put: value

	ranges with: xTables do: [:range :xTable |
		(range first <= index and: [index <= range last]) ifTrue: [
			^ xTable at: index - range first + 1 put: value.
		].
	].
	^ 0.
! !

!XTableForUnicodeFont methodsFor: 'as yet unclassified' stamp: 'yo 12/29/2002 00:19'!
ranges: pairArray

	xTables _ Array new: 0.
	pairArray do: [:range |
		xTables _ xTables copyWith: (Array new: range last - range first + 1 withAll: 0).
	].
	ranges _ pairArray.
! !

!XTableForUnicodeFont methodsFor: 'as yet unclassified' stamp: 'yo 12/29/2002 00:04'!
size

	^ ranges last last - ranges first first + 1.
! !
Timespan subclass: #Year
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Chronology'!
!Year commentStamp: '<historical>' prior: 0!
I represent a year.
!


!Year methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:01'!
asYear


	^ self
! !

!Year methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:01'!
daysInMonth


	self shouldNotImplement 
! !

!Year methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:01'!
daysInYear

	^ self duration days.! !

!Year methodsFor: 'squeak protocol' stamp: 'brp 5/21/2003 08:38'!
printOn: aStream

	aStream nextPutAll: 'a Year ('.
	self start year printOn: aStream.

	aStream nextPutAll: ')'.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Year class
	instanceVariableNames: ''!

!Year class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:52'!
daysInYear: yearInteger

	^ 365 + ((self isLeapYear: yearInteger) ifTrue: [1] ifFalse: [0]).
! !

!Year class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:55'!
leapYear: yearInteger 

	^ (self isLeapYear: yearInteger)
		ifTrue: [1]
		ifFalse: [0]! !


!Year class methodsFor: 'squeak protocol' stamp: 'brp 9/11/2003 14:05'!
current
 
	^ self year: (DateAndTime now year)
! !

!Year class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:00'!
isLeapYear: aYearInteger


	| adjustedYear |
	adjustedYear _ aYearInteger > 0
		ifTrue: [aYearInteger]
		ifFalse: [(aYearInteger + 1) negated].

	"There was no year 0"
	^ ((adjustedYear \\ 4 ~= 0) or: [(adjustedYear \\ 100 = 0) and: [adjustedYear \\ 400 ~= 0]]) not.! !

!Year class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 13:53'!
starting: aDateAndTime duration: aDuration 
	"Override - start from midnight"
	| midnight |
	midnight _ aDateAndTime asDateAndTime midnight.

	^ super
		starting: midnight
		duration: (Duration days: (self daysInYear: midnight year)).! !

!Year class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:00'!
year: aYear

	^ self starting: (DateAndTime year: aYear month: 1 day: 1).! !
TestCase subclass: #YearMonthWeekTest
	instanceVariableNames: 'restoredStartDay restoredTimeZone'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!
!YearMonthWeekTest commentStamp: 'tlk 1/6/2004 17:55' prior: 0!
I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndEpochTestCase for a complete list.  tlk.
I have no fixtures but do make sure to restore anything I change.!


!YearMonthWeekTest methodsFor: 'running' stamp: 'brp 9/26/2004 19:26'!
setUp
	restoredStartDay _ Week startDay.
	restoredTimeZone _ DateAndTime localTimeZone.

	Week startDay: #Sunday.
	DateAndTime localTimeZone: (TimeZone timeZones detect: [:tz | tz abbreviation = 'GMT']).! !

!YearMonthWeekTest methodsFor: 'running' stamp: 'brp 9/26/2004 19:27'!
tearDown
	Week startDay: restoredStartDay.
	DateAndTime localTimeZone: restoredTimeZone.! !


!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 12:51'!
testDaysInMonth
	self assert: (Month daysInMonth: 2 forYear: 2000) = 29.
	self assert: (Month daysInMonth: 2 forYear: 2001) = 28.
	self assert: (Month  daysInMonth: 2 forYear: 2004) = 29.
	self assert: (Month  daysInMonth: 2 forYear: 2100) = 28.
	
	self assert: (Month  daysInMonth: 'January' forYear: 2003) = 31.
	self assert: (Month  daysInMonth: 'February' forYear: 2003) = 28.
	self assert: (Month  daysInMonth: 'March' forYear: 2003) = 31.
	self assert: (Month  daysInMonth: 'April' forYear: 2003) = 30.
	self assert: (Month  daysInMonth: 'May' forYear: 2003) = 31.
	self assert: (Month  daysInMonth: 'June' forYear: 2003) = 30.
	self assert: (Month  daysInMonth: 'July' forYear: 2003) = 31.
	self assert: (Month  daysInMonth: 'August' forYear: 2003) = 31.
	self assert: (Month  daysInMonth: 'September' forYear: 2003) = 30.
	self assert: (Month  daysInMonth: 'October' forYear: 2003) = 31.
	self assert: (Month  daysInMonth: 'November' forYear: 2003) = 30.
	self assert: (Month  daysInMonth: 'December' forYear: 2003) = 31.! !

!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 12:37'!
testDaysInYear
	self assert: (Year daysInYear: 2000) = 366.
	self assert: (Year daysInYear: 2001) = 365.
	self assert: (Year daysInYear: 2004) = 366.
	self assert: (Year daysInYear: 2100) = 365.
	self assert: (Year daysInYear: 2003) = 365.! !

!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 13:37'!
testIndexOfDay
	self assert: (Week indexOfDay: 'Friday') = 6.

! !

!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 12:33'!
testIsLeapYear
	self assert: (Year isLeapYear: 2000).
	self deny: (Year isLeapYear: 2001).
	self assert: (Year isLeapYear: 2004).
	self deny: (Year isLeapYear: 2100).
	self deny: (Year isLeapYear: 2002).! !

!YearMonthWeekTest methodsFor: 'testing' stamp: 'brp 9/26/2004 18:31'!
testMonthPrintOn
    	| aMonth cs rw |
	aMonth _ Month starting: DateAndTime new duration: 31 days.  
	cs _ ReadStream on: 'January 1901'.
	rw _ ReadWriteStream on: ''.
     aMonth printOn: rw.
     self assert: rw contents = cs contents.! !

!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 13:34'!
testStartDay
	Week startDay: 'Wednesday'.
	self assert: Week startDay = 'Wednesday'.
	Week startDay: 'Thursday'.
	self assert: Week startDay = 'Thursday'.

! !

!YearMonthWeekTest methodsFor: 'testing' stamp: 'brp 9/26/2004 18:49'!
testWeekPrintOn
	| aWeek cs rw |
	aWeek := Week starting: (DateAndTime year: 1900 month: 12 day: 31).
	cs := 'a Week starting: 1900-12-30T00:00:00+00:00'.
	rw := WriteStream on: ''.
	aWeek printOn: rw.
	self assert: rw contents = cs! !

!YearMonthWeekTest methodsFor: 'testing' stamp: 'brp 9/26/2004 18:32'!
testYearPrintOn
    	| aYear cs rw |
	aYear _ Year starting: DateAndTime new duration: 365 days. 
	cs _ ReadStream on: 'a Year (1901)'.
	rw _ ReadWriteStream on: ''.
     aYear printOn: rw.
     self assert: rw contents = cs contents.! !
ClassTestCase subclass: #YearTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Chronology'!

!YearTest methodsFor: 'Coverage' stamp: 'brp 9/11/2003 14:31'!
classToBeTested

	^ Year! !


!YearTest methodsFor: 'Tests' stamp: 'brp 9/11/2003 14:30'!
testCurrent

	| yyyy |

	yyyy _ DateAndTime now year.
	
	self assert: Year current start = (DateAndTime year: yyyy month: 1 day: 1)! !
SmallLandColorTheme subclass: #YellowSmallLandColorTheme
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!YellowSmallLandColorTheme methodsFor: 'initialization' stamp: 'dgd 3/12/2006 13:21'!
baseColors
	" 
	YellowSmallLandColorTheme apply.
	"
	^ Array
		with: (Color fromArray: #(0.6 0.6 0.0 ))
		with: (Color fromArray: #(0.9 0.9 0.3 ))
		with: (Color fromArray: #(1.0 1.0 0.9 ))! !
AbstractMediaEventMorph subclass: #ZASMCameraMarkMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/6/2000 13:46'!
cameraController

	^(self valueOfProperty: #cameraController)! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 10:09'!
cameraPoint: aPoint cameraScale: aNumber controller: aController

	self setProperty: #cameraPoint toValue: aPoint.
	self setProperty: #cameraScale toValue: aNumber.
	self setProperty: #cameraController toValue: aController.
	self addMorph: (
		StringMorph contents: aPoint printString,'  ',(aNumber roundTo: 0.001) printString
	) lock.! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/12/2000 13:57'!
cameraPoint: aPoint cameraScale: aNumber controller: aController page: aBookPage
 
	self setProperty: #cameraPoint toValue: aPoint.
	self setProperty: #cameraScale toValue: aNumber.
	self setProperty: #cameraController toValue: aController.
	self setProperty: #bookPage toValue: aBookPage.
	self addMorphBack: (ImageMorph new image: (aBookPage imageForm scaledToSize: 80@80)) lock.
	self setBalloonText: aPoint rounded printString,'  ',(aNumber roundTo: 0.001) printString! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 15:56'!
gotoMark

	self cameraController 
		turnToPage: (self valueOfProperty: #bookPage)
		position: (self valueOfProperty: #cameraPoint) 
		scale: (self valueOfProperty: #cameraScale)
		transition: (self valueOfProperty: #transitionSpec).
	self setCameraValues.


! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 15:53'!
menuPageVisualFor: target event: evt

	| tSpec menu subMenu directionChoices |

	tSpec _ self 
		valueOfProperty: #transitionSpec
		ifAbsent: [
			(self valueOfProperty: #bookPage) 
				valueOfProperty: #transitionSpec
				ifAbsent: [{ 'silence' . #none. #none}]
		].
	menu _ (MenuMorph entitled: 'Choose an effect
(it is now ' , tSpec second , ')') defaultTarget: self.
	TransitionMorph allEffects do: [:effect |
		directionChoices _ TransitionMorph directionsForEffect: effect.
		directionChoices isEmpty
		ifTrue: [menu add: effect target: self
					selector: #setProperty:toValue:
					argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: #none))]
		ifFalse: [subMenu _ MenuMorph new.
				directionChoices do:
					[:dir |
					subMenu add: dir target: self
						selector: #setProperty:toValue:
						argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: dir))].
				menu add: effect subMenu: subMenu]].

	menu popUpEvent: evt in: self world! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 23:26'!
setCameraValues

	| camera |
	camera _ self cameraController.

	"ick... since one may fail to fully take due to constraints, retry"
	2 timesRepeat: [
		camera cameraPoint: (self valueOfProperty: #cameraPoint).
		camera cameraScale: (self valueOfProperty: #cameraScale).
	].

! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 15:54'!
setTransition: evt

	| tSpec menu subMenu directionChoices |

	tSpec _ self 
		valueOfProperty: #transitionSpec
		ifAbsent: [
			(self valueOfProperty: #bookPage) 
				valueOfProperty: #transitionSpec
				ifAbsent: [{ 'silence' . #none. #none}]
		].
	menu _ (MenuMorph entitled: 'Choose an effect
(it is now ' , tSpec second , ')') defaultTarget: self.
	TransitionMorph allEffects do: [:effect |
		directionChoices _ TransitionMorph directionsForEffect: effect.
		directionChoices isEmpty
		ifTrue: [menu add: effect target: self
					selector: #setProperty:toValue:
					argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: #none))]
		ifFalse: [subMenu _ MenuMorph new.
				directionChoices do:
					[:dir |
					subMenu add: dir target: self
						selector: #setProperty:toValue:
						argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: dir))].
				menu add: effect subMenu: subMenu]].

	menu popUpEvent: evt in: self world! !


!ZASMCameraMarkMorph methodsFor: 'copying' stamp: 'RAA 12/11/2000 15:34'!
veryDeepCopyWith: deepCopier
	| camera page |
	"Keep the same camera???"
 
	(camera _ self cameraController) ifNotNil: [
		(deepCopier references includesKey: camera) ifFalse: [
			"not recorded, outside our tree, use same camera"
			deepCopier references at: camera put: camera]].
	(page _ self valueOfProperty: #bookPage) ifNotNil: [
		(deepCopier references includesKey: page) ifFalse: [
			deepCopier references at: page put: page]].

	^ super veryDeepCopyWith: deepCopier

! !


!ZASMCameraMarkMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 12/11/2000 23:26'!
justDroppedInto: newOwner event: anEvent

	| holder |

	newOwner isWorldMorph ifTrue: [
		holder _ ZASMScriptMorph new.
		holder 
			position: self position;
			setProperty: #cameraController toValue: self cameraController.
		self world addMorph: holder.
		holder addMorph: self.
		holder startStepping.
	].
	super justDroppedInto: newOwner event: anEvent! !


!ZASMCameraMarkMorph methodsFor: 'event handling' stamp: 'RAA 12/18/2000 15:39'!
handlesMouseDown: evt

	^true
! !

!ZASMCameraMarkMorph methodsFor: 'event handling' stamp: 'RAA 12/18/2000 15:43'!
mouseDown: evt

	evt shiftPressed ifTrue: [^self].
	self isSticky ifTrue: [^self].
	evt hand grabMorph: self.! !

!ZASMCameraMarkMorph methodsFor: 'event handling' stamp: 'RAA 12/18/2000 15:43'!
mouseUp: evt

	evt shiftPressed ifTrue: [^self gotoMark].
! !


!ZASMCameraMarkMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:32'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add custom halo menu items"

	aMenu add: 'Go to this mark' translated target: self action: #gotoMark.
	aMenu add: 'Set transition' translated target: self action: #setTransition.

	super addCustomMenuItems: aMenu hand: aHandMorph
! !

!ZASMCameraMarkMorph methodsFor: 'menu' stamp: 'sw 11/27/2001 14:58'!
setTransition
	"Set the transition"

	^ self setTransition: ActiveEvent! !


!ZASMCameraMarkMorph methodsFor: '*sound-piano rolls' stamp: 'stephaneducasse 2/4/2006 20:40'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	| startX pseudoEndTime |

	startX := pianoRoll xForTime: startTimeInScore.
	pseudoEndTime := pianoRoll timeForX: startX + self width.
	startTimeInScore > rightTime ifTrue: [^ self].  
	pseudoEndTime < leftTime ifTrue: [^ self].

	morphList add: 
		(self align: self bottomLeft
			with: startX @ self bottom).

! !

!ZASMCameraMarkMorph methodsFor: '*sound-piano rolls' stamp: 'stephaneducasse 2/4/2006 20:40'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	| nextAmbient m nextDurationInMs program now finalMark thisPage nextPage |

	self gotoMark.
	nextAmbient := nil.
	index to: track size do: [ :i |
		(nextAmbient isNil and: [((m := track at: i) morph) isKindOf: self class]) ifTrue: [
			nextAmbient := m.
		].
	].
	nextAmbient ifNil: [^self].
	nextDurationInMs := (nextAmbient time - ticks * secsPerTick * 1000) rounded.
	finalMark := nextAmbient morph.
	thisPage := self valueOfProperty: #bookPage.
	nextPage := finalMark valueOfProperty: #bookPage.
	(thisPage = nextPage or: [thisPage isNil | nextPage isNil]) ifFalse: [^finalMark gotoMark].
	now := Time millisecondClockValue.
	program := Dictionary new.
	program
		at: #startTime put: now;
		at: #endTime put: now + nextDurationInMs;
		at: #startPoint put: (self valueOfProperty: #cameraPoint);
		at: #endPoint put: (finalMark valueOfProperty: #cameraPoint);
		at: #startZoom put: (self valueOfProperty: #cameraScale);
		at: #endZoom put: (finalMark valueOfProperty: #cameraScale).

	self cameraController setProgrammedMoves: {program}.

! !

!ZASMCameraMarkMorph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/18/2000 14:56'!
pauseFrom: scorePlayer

	self cameraController pauseProgrammedMoves.! !

!ZASMCameraMarkMorph methodsFor: '*sound-piano rolls' stamp: 'RAA 12/18/2000 15:04'!
resumeFrom: scorePlayer

	self cameraController resumeProgrammedMoves! !
PasteUpMorph subclass: #ZASMScriptMorph
	instanceVariableNames: 'somethingChanged'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:18'!
compileScript

	| newScript prevMark prevSteps data |

	self fixup.
	newScript _ OrderedCollection new.
	prevMark _ prevSteps _ nil.
	submorphs do: [ :each |
		(each isKindOf: ZASMCameraMarkMorph) ifTrue: [
			prevMark ifNotNil: [
				data _ Dictionary new.
				data 
					at: #steps put: prevSteps;
					at: #startPoint put: (prevMark valueOfProperty: #cameraPoint);
					at: #endPoint put: (each valueOfProperty: #cameraPoint);
					at: #startZoom put: (prevMark valueOfProperty: #cameraScale);
					at: #endZoom put: (each valueOfProperty: #cameraScale).
				newScript add: data.
			].
			prevMark _ each.
		].
		(each isKindOf: ZASMStepsMorph) ifTrue: [
			prevSteps _ each getStepCount.
		].
	].
	^newScript
! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 12:03'!
decompileScript: aScript named: aString for: aController

	| newMorphs prevPt prevScale cameraPoint cameraScale mark |

	self removeAllMorphs.
	self setProperty: #cameraController toValue: aController.
	self setProperty: #cameraScriptName toValue: aString.

	newMorphs _ OrderedCollection new.
	prevPt _ prevScale _ nil.
	aScript do: [ :each |
		cameraPoint _ each at: #startPoint ifAbsent: [nil].
		cameraScale _ each at: #startZoom ifAbsent: [nil].
		(prevPt = cameraPoint and: [prevScale = cameraScale]) ifFalse: [
			mark _ ZASMCameraMarkMorph new.
			mark cameraPoint: cameraPoint cameraScale: cameraScale controller: aController.
			newMorphs add: mark.
		].
		newMorphs add: (ZASMStepsMorph new setStepCount: (each at: #steps ifAbsent: [10])).
		cameraPoint _ each at: #endPoint ifAbsent: [nil].
		cameraScale _ each at: #endZoom ifAbsent: [nil].
		mark _ ZASMCameraMarkMorph new.
		mark cameraPoint: cameraPoint cameraScale: cameraScale controller: aController.
		newMorphs add: mark.
		prevPt _ cameraPoint.
		prevScale _ cameraScale.
	].
	self addAllMorphs: newMorphs.
! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:16'!
fixup

	| newMorphs state fixed |

	somethingChanged _ false.
	newMorphs _ OrderedCollection new.
	state _ #new.
	fixed _ false.
	submorphs do: [ :each |
		(each isKindOf: ZASMCameraMarkMorph) ifTrue: [
			state == #mark ifTrue: [
				newMorphs add: (
					ZASMStepsMorph new setStepCount: 10
				).
				fixed _ true.
			].
			newMorphs add: each.
			state _ #mark.
		].
		(each isKindOf: ZASMStepsMorph) ifTrue: [
			state == #steps ifTrue: [
				fixed _ true.
			] ifFalse: [
				newMorphs add: each.
				state _ #steps.
			].
		].
	].
	fixed ifTrue: [
		self removeAllMorphs.
		self addAllMorphs: newMorphs.
	].! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 12:02'!
saveScript

	| newScript scriptName |
	newScript _ self compileScript.
	scriptName _ FillInTheBlank 
		request: 'Name this script' 
		initialAnswer: (self valueOfProperty: #cameraScriptName ifAbsent: ['']).
	scriptName isEmptyOrNil ifTrue: [^self].
	(self valueOfProperty: #cameraController)
		saveScript: newScript
		as: scriptName.
	self delete.! !


!ZASMScriptMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 12/3/2000 09:02'!
wantsDroppedMorph: aMorph event: evt

	^aMorph isKindOf: ZASMCameraMarkMorph! !


!ZASMScriptMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color blue! !

!ZASMScriptMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 2! !

!ZASMScriptMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:32'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightBlue! !

!ZASMScriptMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:46'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	somethingChanged _ true.
	self dragEnabled: true;
		 layoutPolicy: TableLayout new;
		 listDirection: #topToBottom;
		 wrapCentering: #topLeft;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 layoutInset: 6;
		
		 rubberBandCells: true! !


!ZASMScriptMorph methodsFor: 'layout' stamp: 'RAA 12/3/2000 09:56'!
acceptDroppingMorph: aMorph event: evt

	super acceptDroppingMorph: aMorph event: evt.
	somethingChanged _ true.
	! !

!ZASMScriptMorph methodsFor: 'layout' stamp: 'RAA 12/3/2000 09:33'!
layoutChanged

	super layoutChanged.
	somethingChanged _ true.

	! !


!ZASMScriptMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 22:32'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'save script' translated action: #saveScript.

! !


!ZASMScriptMorph methodsFor: 'stepping and presenter' stamp: 'RAA 12/3/2000 10:36'!
step

	super step.
	somethingChanged ifFalse: [^self].
	self fixup.
! !


!ZASMScriptMorph methodsFor: 'testing' stamp: 'RAA 12/3/2000 09:53'!
stepTime

	^500! !

!ZASMScriptMorph methodsFor: 'testing' stamp: 'RAA 12/3/2000 09:49'!
wantsSteps

	^true! !
StringMorph subclass: #ZASMStepsMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!ZASMStepsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:24'!
getStepCount

	^[self contents asNumber] ifError: [ :a :b | 10]
	
! !

!ZASMStepsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:24'!
setStepCount: n

	self contents: n printString.

! !


!ZASMStepsMorph methodsFor: 'event handling' stamp: 'RAA 12/3/2000 11:29'!
handlesMouseDown: evt

	^ true! !

!ZASMStepsMorph methodsFor: 'event handling' stamp: 'RAA 12/3/2000 11:28'!
mouseDown: evt
	"If the shift key is pressed, make this string the keyboard input focus."

	self launchMiniEditor: evt
! !
FastInflateStream subclass: #ZLibReadStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Streams'!

!ZLibReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:30'!
updateCrc: oldCrc from: start to: stop in: aCollection
	"Answer an updated CRC for the range of bytes in aCollection"
	^ZLibWriteStream updateAdler32: oldCrc from: start to: stop in: aCollection.! !

!ZLibReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:21'!
verifyCrc
	| stored |
	stored := 0.
	24 to: 0 by: -8 do: [ :i |
		sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ].
		stored := stored + (self nextByte bitShift: i) ].
	stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ].
	^stored! !


!ZLibReadStream methodsFor: 'initialize' stamp: 'ar 2/29/2004 03:31'!
on: aCollection from: firstIndex to: lastIndex
	"Check the header of the ZLib stream."
	| method byte |
	super on: aCollection from: firstIndex to: lastIndex.
	crc := 1.
	method := self nextBits: 8.
	(method bitAnd: 15) = 8 ifFalse:[^self error:'Unknown compression method'].
	(method bitShift: -4) + 8 > 15 ifTrue:[^self error:'Invalid window size'].
	byte := self nextBits: 8.
	(method bitShift: 8) + byte \\ 31 = 0 ifFalse:[^self error:'Incorrect header'].
	(byte anyMask: 32) ifTrue:[^self error:'Need preset dictionary'].
! !
ZipWriteStream subclass: #ZLibWriteStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Streams'!

!ZLibWriteStream methodsFor: 'initialize-release' stamp: 'nk 2/17/2004 16:28'!
on: aCollectionOrStream
	super on: aCollectionOrStream.
	crc := 1.! !

!ZLibWriteStream methodsFor: 'initialize-release' stamp: 'nk 2/17/2004 16:53'!
updateCrc: adler from: start to: stop in: aCollection
	"Update crc using the Adler32 checksum technique from RFC1950"
	^self class updateAdler32: adler from:  start to:  stop in: aCollection! !

!ZLibWriteStream methodsFor: 'initialize-release' stamp: 'ar 2/29/2004 04:40'!
writeFooter
	"Store the Adler32 checksum as the last 4 bytes."
	3 to: 0 by: -1 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)].! !

!ZLibWriteStream methodsFor: 'initialize-release' stamp: 'nk 2/17/2004 18:23'!
writeHeader
	"Write header information"
	encoder nextBits: 8 put: 120. "deflate method with 15bit window size"
	encoder nextBits: 8 put: 94. "checksum; no preset; fast (flevel=1) compression"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZLibWriteStream class
	instanceVariableNames: ''!

!ZLibWriteStream class methodsFor: 'crc' stamp: 'ar 2/29/2004 04:40'!
updateAdler32: adler from: start to: stop in: aCollection
	"Update crc using the Adler32 checksum technique from RFC1950"
"
        unsigned long s1 = adler & 0xffff;
        unsigned long s2 = (adler >> 16) & 0xffff;
        int n;

        for (n = 0; n < len; n++) {
          s1 = (s1 + buf[n]) % BASE;
          s2 = (s2 + s1)     % BASE;
        }
        return (s2 << 16) + s1;
"
	| s1 s2 |
	s1 := adler bitAnd: 16rFFFF.
	s2 := (adler bitShift: -16) bitAnd: 16rFFFF.
	start to: stop do: [ :n | | b |
		b := aCollection byteAt: n.
		s1 := (s1 + b) \\ 65521.
		s2 := (s2 + s1) \\ 65521. ].
	^(s2 bitShift: 16) + s1! !
ArithmeticError subclass: #ZeroDivide
	instanceVariableNames: 'dividend'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!ZeroDivide commentStamp: '<historical>' prior: 0!
ZeroDivide may be signaled when a mathematical division by 0 is attempted.!


!ZeroDivide methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:05'!
dividend: argument
	"Specify the number that was being divided by zero."

	dividend := argument! !


!ZeroDivide methodsFor: 'exceptionDescription' stamp: 'tfei 6/5/1999 17:29'!
dividend
	"Answer the number that was being divided by zero."

	^dividend! !

!ZeroDivide methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 15:05'!
isResumable
	"Determine whether an exception is resumable."

	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZeroDivide class
	instanceVariableNames: ''!

!ZeroDivide class methodsFor: 'exceptionInstantiator' stamp: 'bf 9/27/1999 17:26'!
dividend: argument
	^self new dividend: argument; yourself! !
Archive subclass: #ZipArchive
	instanceVariableNames: 'centralDirectorySize centralDirectoryOffsetWRTStartingDiskNumber zipFileComment writeCentralDirectoryOffset writeEOCDOffset'
	classVariableNames: ''
	poolDictionaries: 'ZipFileConstants'
	category: 'Compression-Archives'!
!ZipArchive commentStamp: '<historical>' prior: 0!
A ZipArchive represents an archive that is read and/or written using the PKZIP file format.

ZipArchive instances know how to read and write such archives; their members are subinstances of ZipArchiveMember.!


!ZipArchive methodsFor: 'accessing' stamp: 'ar 3/1/2006 23:21'!
hasMemberSuchThat: aBlock
	"Answer whether we have a member satisfying the given condition"
	^self members anySatisfy: aBlock! !

!ZipArchive methodsFor: 'accessing' stamp: 'nk 3/27/2002 11:23'!
prependedDataSize
	"Answer the size of whatever data exists before my first member.
	Assumes that I was read from a file or stream (i.e. the first member is a ZipFileMember)"
	^members isEmpty
		ifFalse: [ members first localHeaderRelativeOffset ]
		ifTrue: [ centralDirectoryOffsetWRTStartingDiskNumber ]! !

!ZipArchive methodsFor: 'accessing' stamp: 'nk 2/24/2001 13:44'!
zipFileComment
	^zipFileComment asString! !

!ZipArchive methodsFor: 'accessing' stamp: 'nk 2/24/2001 13:43'!
zipFileComment: aString
	zipFileComment := aString! !


!ZipArchive methodsFor: 'archive operations' stamp: 'ar 3/1/2006 23:21'!
addDeflateString: aString as: aFileName
	"Add a verbatim string under the given file name"
	| mbr |
	mbr := self addString: aString as: aFileName.
	mbr desiredCompressionMethod: CompressionDeflated.
	^mbr! !

!ZipArchive methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20'!
extractAllTo: aDirectory
	"Extract all elements to the given directory"
	Utilities informUserDuring:[:bar|self extractAllTo: aDirectory informing: bar].! !

!ZipArchive methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20'!
extractAllTo: aDirectory informing: bar
	"Extract all elements to the given directory"
	^self extractAllTo: aDirectory informing: bar overwrite: false! !

!ZipArchive methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20'!
extractAllTo: aDirectory informing: bar overwrite: allOverwrite
	"Extract all elements to the given directory"
	| dir overwriteAll response |
	overwriteAll := allOverwrite.
	self members do:[:entry|
		entry isDirectory ifTrue:[
			bar ifNotNil:[bar value: 'Creating ', entry fileName].
			dir := (entry fileName findTokens:'/') 
					inject: aDirectory into:[:base :part| base directoryNamed: part].
			dir assureExistence.
		].
	].
	self members do:[:entry|
		entry isDirectory ifFalse:[
			bar ifNotNil:[bar value: 'Extracting ', entry fileName].
			response := entry extractInDirectory: aDirectory overwrite: overwriteAll.
			response == #retryWithOverwrite ifTrue:[
				overwriteAll := true.
				response := entry extractInDirectory: aDirectory overwrite: overwriteAll.
			].
			response == #abort ifTrue:[^self].
			response == #failed ifTrue:[
				(self confirm: 'Failed to extract ', entry fileName, '. Proceed?') ifFalse:[^self].
			].
		].
	].
! !


!ZipArchive methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:47'!
close
	self members do:[:m| m close].! !

!ZipArchive methodsFor: 'initialization' stamp: 'nk 2/22/2001 17:20'!
initialize
	super initialize.
	writeEOCDOffset := writeCentralDirectoryOffset := 0.
	zipFileComment := ''.
! !


!ZipArchive methodsFor: 'reading' stamp: 'nk 12/16/2002 17:09'!
readFrom: aStreamOrFileName
	| stream name eocdPosition |
	stream := aStreamOrFileName isStream
		ifTrue: [name := aStreamOrFileName name. aStreamOrFileName]
		ifFalse: [StandardFileStream readOnlyFileNamed: (name := aStreamOrFileName)].
	stream binary.
	eocdPosition := self class findEndOfCentralDirectoryFrom: stream.
	eocdPosition <= 0 ifTrue: [self error: 'can''t find EOCD position'].
	self readEndOfCentralDirectoryFrom: stream.
	stream position: eocdPosition - centralDirectorySize.
	self readMembersFrom: stream named: name! !


!ZipArchive methodsFor: 'writing' stamp: 'nk 2/23/2001 10:29'!
writeTo: stream
	stream binary.
	members do: [ :member |
		member writeTo: stream.
		member endRead.
	].
	writeCentralDirectoryOffset := stream position.
	self writeCentralDirectoryTo: stream.
	! !

!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 10:42'!
writeTo: stream prepending: aString
	stream binary.
	stream nextPutAll: aString.
	members do: [ :member |
		member writeTo: stream.
		member endRead.
	].
	writeCentralDirectoryOffset := stream position.
	self writeCentralDirectoryTo: stream.
	! !

!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 12:41'!
writeTo: stream prependingFileNamed: aFileName
	| prepended buffer |
	stream binary.
	prepended := StandardFileStream readOnlyFileNamed: aFileName.
	prepended binary.
	buffer := ByteArray new: (prepended size min: 32768).
	[ prepended atEnd ] whileFalse: [ | bytesRead |
		bytesRead := prepended readInto: buffer startingAt: 1 count: buffer size.
		stream next: bytesRead putAll: buffer startingAt: 1
	].
	members do: [ :member |
		member writeTo: stream.
		member endRead.
	].
	writeCentralDirectoryOffset := stream position.
	self writeCentralDirectoryTo: stream.
	! !

!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 12:45'!
writeToFileNamed: aFileName prepending: aString
	| 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 prepending: aString.
	stream close.! !

!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 12:58'!
writeToFileNamed: aFileName prependingFileNamed: anotherFileName
	| 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 prependingFileNamed: anotherFileName.
	stream close.! !


!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 18:26'!
memberClass
	^ZipArchiveMember! !

!ZipArchive methodsFor: 'private' stamp: 'nk 2/22/2001 17:19'!
readEndOfCentralDirectoryFrom: aStream
	"Read EOCD, starting from position before signature."
	| signature zipFileCommentLength |
	signature := self readSignatureFrom: aStream.
	signature = EndOfCentralDirectorySignature ifFalse: [ ^self error: 'bad signature at ', aStream position printString ].

	aStream nextLittleEndianNumber: 2. "# of this disk"
	aStream nextLittleEndianNumber: 2. "# of disk with central dir start"
	aStream nextLittleEndianNumber: 2. "# of entries in central dir on this disk"
	aStream nextLittleEndianNumber: 2. "total # of entries in central dir"
	centralDirectorySize := aStream nextLittleEndianNumber: 4. "size of central directory"
	centralDirectoryOffsetWRTStartingDiskNumber := aStream nextLittleEndianNumber: 4. "offset of start of central directory"
	zipFileCommentLength := aStream nextLittleEndianNumber: 2. "zip file comment"
	zipFileComment := aStream next: zipFileCommentLength.
! !

!ZipArchive methodsFor: 'private' stamp: 'BG 3/16/2005 08:28'!
readMembersFrom: stream named: fileName
	| newMember signature |
	[
		newMember := self memberClass newFromZipFile: stream named: fileName.
		signature := self readSignatureFrom: stream.
		signature = EndOfCentralDirectorySignature ifTrue: [ ^self ].
		signature = CentralDirectoryFileHeaderSignature
			ifFalse: [ self error: 'bad CD signature at ', (stream position - 4) printStringHex ].
		newMember readFrom: stream.
		newMember looksLikeDirectory ifTrue: [ newMember := newMember asDirectory ].
		self addMember: newMember.
	] repeat.! !

!ZipArchive methodsFor: 'private' stamp: 'nk 8/21/2004 15:22'!
readSignatureFrom: stream
	"Returns next signature from given stream, leaves stream positioned afterwards."

	| signatureData | 
	signatureData := ByteArray new: 4.
	stream next: 4 into: signatureData.
	({ CentralDirectoryFileHeaderSignature . LocalFileHeaderSignature . EndOfCentralDirectorySignature }
		includes: signatureData)
			ifFalse: [ ^self error: 'bad signature ', signatureData asString asHex, ' at position ', (stream position - 4) asString ].
	^signatureData
! !

!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 20:19'!
writeCentralDirectoryTo: aStream
	| offset |
	offset := writeCentralDirectoryOffset.
	members do: [ :member |
		member writeCentralDirectoryFileHeaderTo: aStream.
		offset := offset + member centralDirectoryHeaderSize.
	].
	writeEOCDOffset := offset.
	self writeEndOfCentralDirectoryTo: aStream.

! !

!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 21:02'!
writeEndOfCentralDirectoryTo: aStream

	aStream nextPutAll: EndOfCentralDirectorySignature.
	aStream nextLittleEndianNumber: 2 put: 0. "diskNumber"
	aStream nextLittleEndianNumber: 2 put: 0. "diskNumberWithStartOfCentralDirectory"
	aStream nextLittleEndianNumber: 2 put: members size. "numberOfCentralDirectoriesOnThisDisk"
	aStream nextLittleEndianNumber: 2 put: members size. "numberOfCentralDirectories"
	aStream nextLittleEndianNumber: 4 put: writeEOCDOffset - writeCentralDirectoryOffset. "size of central dir"
	aStream nextLittleEndianNumber: 4 put: writeCentralDirectoryOffset. "offset of central dir"
	aStream nextLittleEndianNumber: 2 put: zipFileComment size. "zip file comment"
	zipFileComment isEmpty ifFalse: [ aStream nextPutAll: zipFileComment ].

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipArchive class
	instanceVariableNames: ''!

!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:13'!
compressionDeflated
	^CompressionDeflated! !

!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:12'!
compressionLevelDefault
	^CompressionLevelDefault! !

!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:12'!
compressionLevelNone
	^CompressionLevelNone ! !

!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:13'!
compressionStored
	^CompressionStored! !

!ZipArchive class methodsFor: 'constants' stamp: 'nk 8/21/2004 15:19'!
findEndOfCentralDirectoryFrom: stream
	"Seek in the given stream to the end, then read backwards until we find the
	signature of the central directory record. Leave the file positioned right
	before the signature.

	Answers the file position of the EOCD, or 0 if not found."

	| data fileLength seekOffset pos maxOffset |
	stream setToEnd.
	fileLength := stream position.
	"If the file length is less than 18 for the EOCD length plus 4 for the signature, we have a problem"
	fileLength < 22 ifTrue: [^ self error: 'file is too short'].
	
	seekOffset := 0.
	pos := 0.
	data := ByteArray new: 4100.
	maxOffset := 40960 min: fileLength.	"limit search range to 40K"

	[
		seekOffset := (seekOffset + 4096) min: fileLength.
		stream position: fileLength - seekOffset.
		data := stream next: (4100 min: seekOffset) into: data startingAt: 1.
		pos := data lastIndexOfPKSignature: EndOfCentralDirectorySignature.
		pos = 0 and: [seekOffset < maxOffset]
	] whileTrue.

	^ pos > 0
		ifTrue: [ | newPos | stream position: (newPos := (stream position + pos - seekOffset - 1)). newPos]
		ifFalse: [0]! !

!ZipArchive class methodsFor: 'constants' stamp: 'ar 2/27/2001 13:38'!
validSignatures
	"Return the valid signatures for a zip file"
	^Array 
		with: LocalFileHeaderSignature
		with: CentralDirectoryFileHeaderSignature
		with: EndOfCentralDirectorySignature! !


!ZipArchive class methodsFor: 'file format' stamp: 'di 3/6/2002 21:20'!
isZipArchive: aStreamOrFileName
	"Answer whether the given filename represents a valid zip file."

	| stream eocdPosition |
	stream := aStreamOrFileName isStream
		ifTrue: [aStreamOrFileName]
		ifFalse: [StandardFileStream oldFileNamed: aStreamOrFileName].
	stream ifNil: [^ false].
	"nil happens sometimes somehow"
	stream size < 22 ifTrue: [^ false].
	stream binary.
	eocdPosition := self findEndOfCentralDirectoryFrom: stream.
	stream ~= aStreamOrFileName ifTrue: [stream close].
	^ eocdPosition > 0! !
ArchiveMember subclass: #ZipArchiveMember
	instanceVariableNames: 'lastModFileDateTime fileAttributeFormat versionMadeBy versionNeededToExtract bitFlag compressionMethod desiredCompressionMethod desiredCompressionLevel internalFileAttributes externalFileAttributes cdExtraField localExtraField fileComment crc32 compressedSize uncompressedSize writeLocalHeaderRelativeOffset readDataRemaining'
	classVariableNames: ''
	poolDictionaries: 'ZipFileConstants'
	category: 'Compression-Archives'!
!ZipArchiveMember commentStamp: '<historical>' prior: 0!
Subinstances of me are members in a ZipArchive.
They represent different data sources:
	* ZipDirectoryMember -- a directory to be added to a zip file
	* ZipFileMember -- a file or directory that is already in a zip file
	* ZipNewFilemember -- a file that is to be added to a zip file
	* ZipStringMember -- a string that is to be added to a zip file

They can write their data to another stream either copying, compressing,
or decompressing as desired.!


!ZipArchiveMember methodsFor: 'accessing' stamp: 'yo 2/24/2005 18:34'!
centralDirectoryHeaderSize

	| systemFileName systemFileComment systemCdExtraField |
	systemFileName := fileName asVmPathName.
	systemFileComment := fileComment convertToSystemString.
	systemCdExtraField := cdExtraField.
	^ 46 + systemFileName size + systemCdExtraField size + systemFileComment size
! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 08:00'!
clearExtraFields
	cdExtraField := ''.
	localExtraField := ''.! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:38'!
compressedSize
	"Return the compressed size for this member.
	This will not be set for members that were constructed from strings
	or external files until after the member has been written."
	^compressedSize! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:02'!
compressionMethod
	"Returns my compression method. This is the method that is
	currently being used to compress my data.

	This will be CompressionStored for added string or file members,
	or CompressionStored or CompressionDeflated (others are possible but not handled)"

	^compressionMethod! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'mir 8/5/2004 11:00'!
contentStream
	"Answer my contents as a text stream.
	Default is no conversion, since we don't know what the bytes mean."

	| s |
	s := MultiByteBinaryOrTextStream on: (String new: self uncompressedSize).
	s converter: Latin1TextConverter new.
	self extractTo: s.
	s reset.
	^ s.
! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:28'!
crc32
	^crc32! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'BG 3/16/2005 08:19'!
crc32String
	| hexString |
	hexString := crc32 storeStringHex.
	^('00000000' copyFrom: 1 to: 11 - (hexString size)) , (hexString copyFrom: 4 to: hexString size)! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:10'!
desiredCompressionLevel
	^desiredCompressionLevel! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:14'!
desiredCompressionLevel: aNumber
	"Set my desiredCompressionLevel
	This is the method that will be used to write.
	Returns prior desiredCompressionLevel.

	Valid arguments are 0 (CompressionLevelNone) through 9,
	including 6 (CompressionLevelDefault).

	0 (CompressionLevelNone) will change the desiredCompressionMethod
	to CompressionStored. All other arguments will change the
	desiredCompressionMethod to CompressionDeflated."

	| old |
	old := desiredCompressionLevel.
	desiredCompressionLevel := aNumber.
	desiredCompressionMethod := (aNumber > 0)
		ifTrue: [ CompressionDeflated ]
		ifFalse: [ CompressionStored ].
	^old! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:03'!
desiredCompressionMethod
	"Get my desiredCompressionMethod.
	This is the method that will be used to write"

	^desiredCompressionMethod! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 11:25'!
desiredCompressionMethod: aNumber
	"Set my desiredCompressionMethod
	This is the method that will be used to write.
	Answers prior desiredCompressionMethod.

	Only CompressionDeflated or CompressionStored are valid arguments.

	Changing to CompressionStored will change my desiredCompressionLevel
	to CompressionLevelNone; changing to CompressionDeflated will change my
	desiredCompressionLevel to CompressionLevelDefault."

	| old |
	old := desiredCompressionMethod.
	desiredCompressionMethod := aNumber.
	desiredCompressionLevel := (aNumber = CompressionDeflated)
			ifTrue: [ CompressionLevelDefault ]
			ifFalse: [ CompressionLevelNone ].
	compressionMethod = CompressionStored ifTrue: [ compressedSize := uncompressedSize ].
	^old.! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/26/2003 13:06'!
extractToFileNamed: aLocalFileName inDirectory: dir
	| stream fullName fullDir |
	self isEncrypted ifTrue: [ ^self error: 'encryption unsupported' ].
	fullName := dir fullNameFor: aLocalFileName.
	fullDir := FileDirectory forFileName: fullName.
	fullDir assureExistence.
	self isDirectory ifFalse: [
		stream := fullDir forceNewFileNamed: (FileDirectory localNameFor: fullName).
		self extractTo: stream.
		stream close.
	] ifTrue: [ fullDir assureExistence ]
! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:25'!
fileComment
	^fileComment! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:25'!
fileComment: aString
	fileComment := aString! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/24/2001 14:34'!
lastModTime
	"Return my last modification date/time stamp,
	converted to Squeak seconds"

	^self unixToSqueakTime: (self dosToUnixTime: lastModFileDateTime)! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 3/13/2003 09:23'!
localFileName
	"Answer my fileName in terms of the local directory naming convention"
	| localName |
	localName := fileName copyReplaceAll: '/' with: FileDirectory slash.
	^(fileName first = $/)
		ifTrue: [ FileDirectory default class makeAbsolute: localName ]
		ifFalse: [ FileDirectory default class makeRelative: localName ]! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 23:39'!
setLastModFileDateTimeFrom: aSmalltalkTime
	| unixTime |
	unixTime := aSmalltalkTime -  2177424000.		"PST?"
	lastModFileDateTime := self unixToDosTime: unixTime! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 11/11/2002 21:03'!
splitFileName
	"Answer my name split on slash boundaries. A directory will have a trailing empty string."
	^ fileName findTokens: '/'.! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:38'!
uncompressedSize
	"Return the uncompressed size for this member."
	^uncompressedSize! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:18'!
unixFileAttributes
	^self mapPermissionsToUnix: externalFileAttributes.! !

!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:24'!
unixFileAttributes: perms
	| oldPerms newPerms |
	oldPerms := self mapPermissionsToUnix: externalFileAttributes.
	newPerms :=  self isDirectory
			ifTrue: [ (perms bitAnd: FileAttrib bitInvert) bitOr: DirectoryAttrib ]
			ifFalse: [ (perms bitAnd: DirectoryAttrib bitInvert) bitOr: FileAttrib ].
	externalFileAttributes := self mapPermissionsFromUnix: newPerms.
	^oldPerms.! !


!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 12/20/2002 14:49'!
extractInDirectory: dir
	self extractToFileNamed: self localFileName inDirectory: dir
! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'rbb 2/18/2005 14:42'!
extractInDirectory: aDirectory overwrite: overwriteAll
	"Extract this entry into the given directory. Answer #okay, #failed, #abort, or #retryWithOverwrite."
	| path fileDir file index localName |
	path := fileName findTokens:'/'.
	localName := path last.
	fileDir := path allButLast inject: aDirectory into:[:base :part| base directoryNamed: part].
	fileDir assureExistence.
	file := [fileDir newFileNamed: localName] on: FileExistsException do:[:ex| ex return: nil].
	file ifNil:[
		overwriteAll ifFalse:[
			[index := UIManager default chooseFrom: {
						'Yes, overwrite'. 
						'No, don''t overwrite'. 
						'Overwrite ALL files'.
						'Cancel operation'
					} lines: #(2) title: fileName, ' already exists. Overwrite?'.
			index == nil] whileTrue.
			index = 4 ifTrue:[^#abort].
			index = 3 ifTrue:[^#retryWithOverwrite].
			index = 2 ifTrue:[^#okay].
		].
		file := [fileDir forceNewFileNamed: localName] on: Error do:[:ex| ex return].
		file ifNil:[^#failed].
	].
	self extractTo: file.
	file close.
	^#okay! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 2/22/2001 18:03'!
extractTo: aStream
	| oldCompression |
	self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ].
	aStream binary.
	oldCompression := self desiredCompressionMethod: CompressionStored.
	self rewindData.
	self writeDataTo: aStream.
	self desiredCompressionMethod: oldCompression.
	self endRead.! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 2/24/2001 18:03'!
extractTo: aStream from: start to: finish
	| oldCompression |
	self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ].
	aStream binary.
	oldCompression := self desiredCompressionMethod: CompressionStored.
	self rewindData.
	self writeDataTo: aStream from: start to: finish.
	self desiredCompressionMethod: oldCompression.
	self endRead.! !

!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 11/11/2002 14:08'!
extractToFileNamed: aFileName
	self extractToFileNamed: aFileName inDirectory: FileDirectory default.! !


!ZipArchiveMember methodsFor: 'initialization' stamp: 'nk 2/24/2001 16:16'!
initialize
	super initialize.
	lastModFileDateTime := 0.
	fileAttributeFormat := FaUnix.
	versionMadeBy := 20.
	versionNeededToExtract := 20.
	bitFlag := 0.
	compressionMethod := CompressionStored.
	desiredCompressionMethod := CompressionDeflated.
	desiredCompressionLevel := CompressionLevelDefault.
	internalFileAttributes := 0.
	externalFileAttributes := 0.
	fileName := ''.
	cdExtraField := ''.
	localExtraField := ''.
	fileComment := ''.
	crc32 := 0.
	compressedSize := 0.
	uncompressedSize := 0.
	self unixFileAttributes: DefaultFilePermissions.! !


!ZipArchiveMember methodsFor: 'reading' stamp: 'nk 2/24/2001 22:28'!
contents
	"Answer my contents as a string."
	| s |
	s := RWBinaryOrTextStream on: (String new: self uncompressedSize).
	self extractTo: s.
	s text.
	^s contents! !

!ZipArchiveMember methodsFor: 'reading' stamp: 'nk 2/24/2001 23:53'!
contentsFrom: start to: finish
	"Answer my contents as a string."
	| s |
	s := RWBinaryOrTextStream on: (String new: finish - start + 1).
	self extractTo: s from: start to: finish.
	s text.
	^s contents! !


!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:40'!
hasDataDescriptor
	^ (bitFlag bitAnd: 8)	~= 0 "GPBF:=HAS:=DATA:=DESCRIPTOR:=MASK"! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:00'!
isDirectory
	^false! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:39'!
isEncrypted
	"Return true if this member is encrypted (this is unsupported)"
	^ (bitFlag bitAnd: 1) ~= 0! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:41'!
isTextFile
	"Returns true if I am a text file.
	Note that this module does not currently do anything with this flag
	upon extraction or storage.
	That is, bytes are stored in native format whether or not they came
	from a text file."
	^ (internalFileAttributes bitAnd: 1) ~= 0
! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:43'!
isTextFile: aBoolean
	"Set whether I am a text file.
	Note that this module does not currently do anything with this flag
	upon extraction or storage.
	That is, bytes are stored in native format whether or not they came
	from a text file."
	internalFileAttributes := aBoolean
		ifTrue: [ internalFileAttributes bitOr: 1 ]
		ifFalse: [ internalFileAttributes bitAnd: 1 bitInvert ]
! !

!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 20:38'!
looksLikeDirectory
	^false! !


!ZipArchiveMember methodsFor: 'writing' stamp: 'nk 2/23/2001 11:28'!
writeTo: aStream
	self rewindData.
	writeLocalHeaderRelativeOffset := aStream position.
	self writeLocalFileHeaderTo: aStream.
	self writeDataTo: aStream.
	self refreshLocalFileHeaderTo: aStream.! !


!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 21:55'!
asDirectory
	^ZipDirectoryMember new copyFrom: self! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 23:54'!
dosToUnixTime: dt
	"DOS years start at 1980, Unix at 1970, and Smalltalk at 1901.
	So the Smalltalk seconds will be high by 69 years when used as Unix time:=t values.
	So shift 1980 back to 1911..."
	| year mon mday hour min sec date time |

	year := (( dt bitShift: -25 ) bitAnd: 16r7F ) + 1911.
	mon := (( dt bitShift: -21 ) bitAnd: 16r0F ).
	mday := (( dt bitShift: -16 ) bitAnd: 16r1F ).
	date := Date newDay: mday month: mon year: year.

	hour := (( dt bitShift: -11 ) bitAnd: 16r1F ).
	min := (( dt bitShift: -5 ) bitAnd: 16r3F ).
	sec := (( dt bitShift: 1 ) bitAnd: 16r3E ).
	time := ((( hour * 60 ) + min ) * 60 ) + sec.

	^date asSeconds + time

	! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/23/2001 08:24'!
endRead
	readDataRemaining := 0.! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 23:57'!
mapPermissionsFromUnix: unixPerms
	^ unixPerms bitShift: 16.! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 23:58'!
mapPermissionsToUnix: dosPerms
	^ dosPerms bitShift: -16.! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:42'!
readRawChunk: n
	self subclassResponsibility! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nk 4/28/2002 21:53'!
rewindData
	readDataRemaining :=  (desiredCompressionMethod = CompressionDeflated
		and: [ compressionMethod = CompressionDeflated ])
			ifTrue: [ compressedSize ]
			ifFalse: [ uncompressedSize ].
! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/22/2001 17:13'!
unixToDosTime: unixTime
	| dosTime dateTime secs |
	secs := self unixToSqueakTime: unixTime.	"Squeak time (PST?)"
	dateTime := Time dateAndTimeFromSeconds: secs.
	dosTime := (dateTime second seconds) bitShift: -1.
	dosTime := dosTime + ((dateTime second minutes) bitShift: 5).
	dosTime := dosTime + ((dateTime second hours) bitShift: 11).
	dosTime := dosTime + ((dateTime first dayOfMonth) bitShift: 16).
	dosTime := dosTime + ((dateTime first monthIndex) bitShift: 21).
	dosTime := dosTime + (((dateTime first year) - 1980) bitShift: 25).
	^dosTime
! !

!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/22/2001 13:22'!
unixToSqueakTime: unixTime
	^unixTime +  2177424000.		"Squeak time (PST?)"! !


!ZipArchiveMember methodsFor: 'private-writing' stamp: 'ar 2/28/2001 14:01'!
compressDataTo: aStream
	"Copy my deflated data to the given stream."
	| encoder startPos endPos |

	encoder := ZipWriteStream on: aStream.
	startPos := aStream position.

	[ readDataRemaining > 0 ] whileTrue: [ | data |
		data := self readRawChunk: (4096 min: readDataRemaining).
		encoder nextPutAll: data asByteArray.
		readDataRemaining := readDataRemaining - data size.
	].
	encoder finish. "not close!!"
	endPos := aStream position.
	compressedSize := endPos - startPos.
	crc32 := encoder crc.
! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'!
copyDataTo: aStream

	compressionMethod = CompressionStored ifTrue: [ ^self copyDataWithCRCTo: aStream ].

	self copyRawDataTo: aStream.! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 3/7/2004 15:42'!
copyDataWithCRCTo: aStream
	"Copy my data to aStream. Also set the CRC-32.
	Only used when compressionMethod = desiredCompressionMethod = CompressionStored"

	uncompressedSize := compressedSize := readDataRemaining.

	crc32 := 16rFFFFFFFF.

	[ readDataRemaining > 0 ] whileTrue: [ | data |
		data := self readRawChunk: (4096 min: readDataRemaining).
		aStream nextPutAll: data.
		crc32 := ZipWriteStream updateCrc: crc32 from: 1 to: data size in: data.
		readDataRemaining := readDataRemaining - data size.
	].

	crc32 := crc32 bitXor: 16rFFFFFFFF.
! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'!
copyRawDataTo: aStream

	[ readDataRemaining > 0 ] whileTrue: [ | data |
		data := self readRawChunk: (4096 min: readDataRemaining).
		aStream nextPutAll: data.
		readDataRemaining := readDataRemaining - data size.
	].
! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 17:57'!
copyRawDataTo: aStream from: start to: finish

	readDataRemaining := readDataRemaining min: finish - start + 1.

	self readRawChunk: start - 1.

	[ readDataRemaining > 0 ] whileTrue: [ | data |
		data := self readRawChunk: (32768 min: readDataRemaining).
		aStream nextPutAll: data.
		readDataRemaining := readDataRemaining - data size.
	].
! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'yo 2/24/2005 18:34'!
refreshLocalFileHeaderTo: aStream
	"Re-writes my local header to the given stream.
	To be called after writing the data stream.
	Assumes that fileName and localExtraField sizes didn't change since last written."

	| here systemFileName |
	here := aStream position.
	systemFileName := fileName asVmPathName.
	aStream position: writeLocalHeaderRelativeOffset.

	aStream nextPutAll: LocalFileHeaderSignature.
	aStream nextLittleEndianNumber: 2 put: versionNeededToExtract.
	aStream nextLittleEndianNumber: 2 put: bitFlag.
	aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod.
	aStream nextLittleEndianNumber: 4 put: lastModFileDateTime.
	aStream nextLittleEndianNumber: 4 put: crc32.
	aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored
												ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]).
	aStream nextLittleEndianNumber: 4 put: uncompressedSize.
	aStream nextLittleEndianNumber: 2 put: systemFileName size.
	aStream nextLittleEndianNumber: 2 put: localExtraField size.

	aStream position: here.
! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'yo 2/24/2005 18:34'!
writeCentralDirectoryFileHeaderTo: aStream
	"C2 v3 V4 v5 V2"

	| systemFileName systemFileComment systemCdExtraField |
	systemFileName := fileName asVmPathName.
	systemFileComment := fileComment convertToSystemString.
	systemCdExtraField := cdExtraField.
	aStream nextPutAll: CentralDirectoryFileHeaderSignature.
	aStream nextLittleEndianNumber: 1 put: versionMadeBy.
	aStream nextLittleEndianNumber: 1 put: fileAttributeFormat.

	aStream nextLittleEndianNumber: 2 put: versionNeededToExtract.
	aStream nextLittleEndianNumber: 2 put: bitFlag.
	aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod.

	aStream nextLittleEndianNumber: 4 put: lastModFileDateTime.

	"These next 3 should have been updated during the write of the data"
	aStream nextLittleEndianNumber: 4 put: crc32.
	aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored
												ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]).
	aStream nextLittleEndianNumber: 4 put: uncompressedSize.

	aStream nextLittleEndianNumber: 2 put: systemFileName size.
	aStream nextLittleEndianNumber: 2 put: systemCdExtraField size.
	aStream nextLittleEndianNumber: 2 put: systemFileComment size.
	aStream nextLittleEndianNumber: 2 put: 0.		"diskNumberStart"
	aStream nextLittleEndianNumber: 2 put: internalFileAttributes.

	aStream nextLittleEndianNumber: 4 put: externalFileAttributes.
	aStream nextLittleEndianNumber: 4 put: writeLocalHeaderRelativeOffset.

	aStream nextPutAll: systemFileName asByteArray.
	aStream nextPutAll: systemCdExtraField asByteArray.
	aStream nextPutAll: systemFileComment asByteArray.! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/22/2001 21:53'!
writeDataDescriptorTo: aStream
	"This writes a data descriptor to the given stream.
	Assumes that crc32, writeOffset, and uncompressedSize are
	set correctly (they should be after a write).
	Further, the local file header should have the
	GPBF:=HAS:=DATA:=DESCRIPTOR:=MASK (8) bit set."

	aStream nextLittleEndianNumber: 4 put: crc32.
	aStream nextLittleEndianNumber: 4 put: compressedSize.
	aStream nextLittleEndianNumber: 4 put: uncompressedSize.! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/22/2001 20:41'!
writeDataTo: aStream
	"Copy my (possibly inflated or deflated) data to the given stream.
	This might do compression, decompression, or straight copying, depending
	on the values of compressionMethod and desiredCompressionMethod"

	uncompressedSize = 0 ifTrue: [ ^self ].	"nothing to do because no data"

	(compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ])
		ifTrue: [ ^self compressDataTo: aStream ].

	(compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ])
		ifTrue: [ ^self uncompressDataTo: aStream ].

	self copyDataTo: aStream.! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 18:01'!
writeDataTo: aStream from: start to: finish
	"Copy my (possibly inflated or deflated) data to the given stream.
	But only the specified byte range.
	This might do decompression, or straight copying, depending
	on the values of compressionMethod and desiredCompressionMethod"

	uncompressedSize = 0 ifTrue: [ ^self ].	"nothing to do because no data"
	start > finish ifTrue: [ ^self ].
	start > uncompressedSize ifTrue: [ ^self ].

	(compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ])
		ifTrue: [ ^self error: 'only supports uncompression or copying right now' ].

	(compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ])
		ifTrue: [ ^self uncompressDataTo: aStream from: start to: finish ].

	self copyRawDataTo: aStream from: start to: finish.! !

!ZipArchiveMember methodsFor: 'private-writing' stamp: 'yo 2/24/2005 18:34'!
writeLocalFileHeaderTo: aStream
	"Write my local header to a file handle.
	Stores the offset to the start of the header in my
	writeLocalHeaderRelativeOffset member."

	| systemFileName |
	systemFileName := fileName asVmPathName.
	aStream nextPutAll: LocalFileHeaderSignature.
	aStream nextLittleEndianNumber: 2 put: versionNeededToExtract.
	aStream nextLittleEndianNumber: 2 put: bitFlag.
	aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod.

	aStream nextLittleEndianNumber: 4 put: lastModFileDateTime.
	aStream nextLittleEndianNumber: 4 put: crc32.
	aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored
												ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]).
	aStream nextLittleEndianNumber: 4 put: uncompressedSize.

	aStream nextLittleEndianNumber: 2 put: systemFileName size.
	aStream nextLittleEndianNumber: 2 put: localExtraField size.

	aStream nextPutAll: systemFileName asByteArray.
	aStream nextPutAll: localExtraField asByteArray.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipArchiveMember class
	instanceVariableNames: ''!

!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'!
newFromDirectory: aFileName
	^ZipDirectoryMember newNamed: aFileName! !

!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'!
newFromFile: aFileName
	^ZipNewFileMember newNamed: aFileName! !

!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:25'!
newFromString: aString named: aFileName
	^ZipStringMember newFrom: aString named: aFileName! !

!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/21/2001 20:40'!
newFromZipFile: stream named: fileName
	^ZipFileMember newFrom: stream named: fileName! !
SharedPool subclass: #ZipConstants
	instanceVariableNames: ''
	classVariableNames: 'BaseDistance BaseLength BitLengthOrder DistanceCodes DynamicBlock EndBlock ExtraBitLengthBits ExtraDistanceBits ExtraLengthBits FixedBlock FixedDistanceTree FixedLiteralTree HashBits HashMask HashShift MatchLengthCodes MaxBitLengthBits MaxBitLengthCodes MaxBits MaxDistCodes MaxDistance MaxLengthCodes MaxLiteralCodes MaxMatch MinMatch NumLiterals Repeat11To138 Repeat3To10 Repeat3To6 StoredBlock WindowMask WindowSize'
	poolDictionaries: ''
	category: 'Compression-Streams'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipConstants class
	instanceVariableNames: ''!

!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:09'!
initialize
	"ZipConstants initialize"
	self initializeDeflateConstants.
	self initializeWriteStreamConstants.! !

!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:06'!
initializeDeflateConstants

	WindowSize := 16r8000.
	WindowMask := WindowSize - 1.
	MaxDistance := WindowSize.

	MinMatch := 3.
	MaxMatch := 258.

	HashBits := 15.
	HashMask := (1 << HashBits) - 1.
	HashShift := (HashBits + MinMatch - 1) // MinMatch.
! !

!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:08'!
initializeDistanceCodes
	| dist |
	BaseDistance := WordArray new: MaxDistCodes.
	DistanceCodes := WordArray new: 512.
	dist := 0.
	1 to: 16 do:[:code|
		BaseDistance at: code put: dist.
		1 to: (1 bitShift: (ExtraDistanceBits at: code)) do:[:n|
			dist := dist + 1.
			DistanceCodes at: dist put: code-1]].
	dist = 256 ifFalse:[self error:'Whoops?!!'].
	dist := dist >> 7.
	17 to: MaxDistCodes do:[:code|
		BaseDistance at: code put: dist << 7.
		1 to: (1 bitShift: (ExtraDistanceBits at: code)-7) do:[:n|
			dist := dist + 1.
			DistanceCodes at: 256 + dist put: code-1]].
! !

!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:07'!
initializeExtraBits
	ExtraLengthBits := 
		WordArray withAll: #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0).
	ExtraDistanceBits := 
		WordArray withAll: #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13).
	ExtraBitLengthBits := 
		WordArray withAll: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7).
	BitLengthOrder :=
		WordArray withAll: #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15).
! !

!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:08'!
initializeFixedTrees
	"ZipWriteStream initializeFixedTrees"
	| counts nodes |
	FixedLiteralTree := ZipEncoderTree new.
	FixedLiteralTree maxCode: 287.
	counts := WordArray new: MaxBits+1.
	counts at: 7+1 put: 24.
	counts at: 8+1 put: 144+8.
	counts at: 9+1 put: 112.
	nodes := Array new: 288.
	1 to: 288 do:[:i| nodes at: i put: (ZipEncoderNode value: i-1 frequency: 0 height: 0)].
	0 to: 143 do:[:i| (nodes at: i+1) setBitLengthTo: 8].
	144 to: 255 do:[:i| (nodes at: i+1) setBitLengthTo: 9].
	256 to: 279 do:[:i| (nodes at: i+1) setBitLengthTo: 7].
	280 to: 287 do:[:i| (nodes at: i+1) setBitLengthTo: 8].
	FixedLiteralTree buildCodes: nodes counts: counts maxDepth: MaxBits.
	FixedLiteralTree setValuesFrom: nodes.

	FixedDistanceTree := ZipEncoderTree new.
	FixedDistanceTree maxCode: MaxDistCodes.
	FixedDistanceTree
		bitLengths: ((WordArray new: MaxDistCodes+1) atAllPut: 5)
		codes: ((0 to: MaxDistCodes) collect:[:i| FixedDistanceTree reverseBits: i length: 5]).! !

!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:07'!
initializeLengthCodes
	| length |
	BaseLength := WordArray new: MaxLengthCodes.
	MatchLengthCodes := WordArray new: MaxMatch - MinMatch + 1.
	length := 0.
	1 to: MaxLengthCodes - 1 do:[:code|
		BaseLength at: code put: length.
		1 to: (1 bitShift: (ExtraLengthBits at: code)) do:[:n|
			length := length + 1.
			MatchLengthCodes at: length put: NumLiterals + code]].
! !

!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:09'!
initializeWriteStreamConstants

	MaxBits := 15.
	MaxBitLengthBits := 7.
	EndBlock := 256.

	StoredBlock := 0.
	FixedBlock := 1.
	DynamicBlock := 2.

	NumLiterals := 256.
	MaxLengthCodes := 29.
	MaxDistCodes := 30.
	MaxBitLengthCodes := 19.
	MaxLiteralCodes := NumLiterals + MaxLengthCodes + 1. "+ End of Block"

	Repeat3To6 := 16. "Repeat previous bit length 3-6 times (2 bits repeat count)"
	Repeat3To10 := 17. "Repeat previous bit length 3-10 times (3 bits repeat count)"
	Repeat11To138 := 18. "Repeat previous bit length 11-138 times (7 bits repeat count)"

	self initializeExtraBits.
	self initializeLengthCodes.
	self initializeDistanceCodes.
	self initializeFixedTrees.
! !
TestCase subclass: #ZipCrcTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Streams'!

!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:43'!
testInvalidGZipCrc
	"See that a wrong CRC raises an appropriate error"
	| reader writer bytes crcByte |
	writer := GZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	crcByte := bytes byteAt: bytes size-5. "before the length"
	bytes byteAt: bytes size-5 put: (crcByte + 1 bitAnd: 255).

	reader := GZipReadStream on: bytes.
	self should:[reader upToEnd] raise: CRCError.

	reader := GZipReadStream on: bytes.
	self should:[reader contents] raise: CRCError.

	reader := GZipReadStream on: bytes.
	self should:[reader next: 100] raise: CRCError.
! !

!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:43'!
testInvalidZLibCrc
	"See that a wrong CRC raises an appropriate error"
	| reader writer bytes crcByte |
	writer := ZLibWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	crcByte := bytes byteAt: bytes size-2.
	bytes byteAt: bytes size-2 put: (crcByte + 1 bitAnd: 255).

	reader := ZLibReadStream on: bytes.
	self should:[reader upToEnd] raise: CRCError.

	reader := ZLibReadStream on: bytes.
	self should:[reader contents] raise: CRCError.

	reader := ZLibReadStream on: bytes.
	self should:[reader next: 100] raise: CRCError.
! !

!ZipCrcTests methodsFor: 'tests' stamp: 'nk 3/7/2004 18:37'!
testInvalidZipCrc
	"See that a wrong CRC raises an appropriate error"
	| reader writer bytes |
	writer := ZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc - 1.
	self should:[reader upToEnd] raise: CRCError.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc - 1.
	self should:[reader contents] raise: CRCError.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc - 1.
	self should:[reader next: 100] raise: CRCError.
! !

!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:42'!
testMissingGZipCrc
	"See that the lack of a CRC raises an appropriate error"
	| reader writer bytes |
	writer := GZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	bytes := bytes copyFrom: 1 to: bytes size-6.

	reader := GZipReadStream on: bytes.
	self should:[reader upToEnd] raise: CRCError.

	reader := GZipReadStream on: bytes.
	self should:[reader contents] raise: CRCError.

	reader := GZipReadStream on: bytes.
	self should:[reader next: 100] raise: CRCError.
! !

!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:42'!
testMissingZLibCrc
	"See that the lack of a CRC raises an appropriate error"
	| reader writer bytes |
	writer := ZLibWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	bytes := bytes copyFrom: 1 to: bytes size-2.

	reader := ZLibReadStream on: bytes.
	self should:[reader upToEnd] raise: CRCError.

	reader := ZLibReadStream on: bytes.
	self should:[reader contents] raise: CRCError.

	reader := ZLibReadStream on: bytes.
	self should:[reader next: 100] raise: CRCError.
! !

!ZipCrcTests methodsFor: 'tests' stamp: 'nk 3/7/2004 18:49'!
testMissingZipCrc
	"See that the lack of a CRC does not raise an error"
	| reader writer bytes readBytes |
	writer := ZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.

	reader := ZipReadStream on: bytes.
	self shouldnt:[readBytes := reader upToEnd] raise: CRCError.
	self assert: readBytes = 'Hello World'.

	reader := ZipReadStream on: bytes.
	self shouldnt:[reader contents] raise: CRCError.

	reader := ZipReadStream on: bytes.
	self shouldnt:[reader next: 100] raise: CRCError.
! !

!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:42'!
testValidGZipCrc
	| reader writer bytes |
	writer := GZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	reader := GZipReadStream on: bytes.
	self assert: reader upToEnd = 'Hello World'.! !

!ZipCrcTests methodsFor: 'tests' stamp: 'nk 3/7/2004 18:46'!
testValidZLibCrc
	| reader writer bytes |
	writer := ZLibWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.
	reader := ZLibReadStream on: bytes.
	self assert: reader upToEnd = 'Hello World'.
	
	bytes := writer encodedStream contents.
	reader := ZLibReadStream on: bytes.
	self assert: (reader next: 100) = 'Hello World'.! !

!ZipCrcTests methodsFor: 'tests' stamp: 'nk 3/7/2004 18:43'!
testValidZipCrc
	"See that a correct CRC does not raise an error and that we can read what we wrote."
	| reader writer bytes readBytes |
	writer := ZipWriteStream on: String new.
	writer nextPutAll: 'Hello World'.
	writer close.

	bytes := writer encodedStream contents.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc.
	self shouldnt:[ readBytes := reader upToEnd] raise: CRCError.
	self assert: readBytes = 'Hello World'.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc.
	self shouldnt:[ readBytes := reader contents] raise: CRCError.
	self assert: readBytes = 'Hello World'.

	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc.
	self shouldnt:[ readBytes := reader next: 11 ] raise: CRCError.
	self assert: readBytes = 'Hello World'.
	
	reader := ZipReadStream on: bytes.
	reader expectedCrc: writer crc.
	self shouldnt:[ readBytes := reader next: 100 ] raise: CRCError.
	self assert: readBytes = 'Hello World'.! !
ZipFileMember subclass: #ZipDirectoryMember
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Archives'!
!ZipDirectoryMember commentStamp: '<historical>' prior: 0!
ZipFileMember instances represent directories inside ZipArchives.
They don't do much other than hold names and permissions (and extra fields).

You can add files in subdirectories to a ZipArchive without using any ZipDirectoryMembers.!


!ZipDirectoryMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 10:00'!
desiredCompressionMethod: aNumber! !

!ZipDirectoryMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 14:45'!
localFileName: aString
	| dir entry parent |
	super localFileName: aString.
	fileName last = $/ ifFalse: [ fileName := fileName, '/' ].
	parent := FileDirectory default.
	(parent directoryExists: fileName) ifTrue: [
		dir := FileDirectory on: (parent fullNameFor: fileName).
		entry := dir directoryEntry.
		self setLastModFileDateTimeFrom: entry modificationTime
	]
! !


!ZipDirectoryMember methodsFor: 'initialization' stamp: 'nk 2/23/2001 10:01'!
initialize
	super initialize.
	super desiredCompressionMethod: CompressionStored.! !


!ZipDirectoryMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:00'!
isDirectory
	^true! !

!ZipDirectoryMember methodsFor: 'testing' stamp: 'nk 3/27/2002 11:29'!
usesFileNamed: aName
	^false! !


!ZipDirectoryMember methodsFor: 'private' stamp: 'nk 2/21/2001 21:55'!
asDirectory
	^self! !

!ZipDirectoryMember methodsFor: 'private' stamp: 'nk 3/27/2002 11:30'!
rewindData! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipDirectoryMember class
	instanceVariableNames: ''!

!ZipDirectoryMember class methodsFor: 'as yet unclassified' stamp: 'nk 12/20/2002 14:57'!
newNamed: aFileName
	^(self new) localFileName: aFileName; yourself! !
WriteStream subclass: #ZipEncoder
	instanceVariableNames: 'bitBuffer bitPosition encodedStream'
	classVariableNames: ''
	poolDictionaries: 'ZipConstants'
	category: 'Compression-Streams'!

!ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:45'!
bitPosition
	^encodedStream position + position * 8 + bitPosition.! !

!ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'!
encodedStream
	^encodedStream! !

!ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'!
nextBits: nBits put: value
	"Store a value of nBits"
	"self assert:[value >= 0 and:[(1 bitShift: nBits) > value]]."
	bitBuffer := bitBuffer bitOr: (value bitShift: bitPosition).
	bitPosition := bitPosition + nBits.
	[bitPosition >= 8] whileTrue:[
		self nextBytePut: (bitBuffer bitAnd: 255).
		bitBuffer := bitBuffer bitShift: -8.
		bitPosition := bitPosition - 8].! !

!ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'!
nextBytePut: anObject 
	"Primitive. Insert the argument at the next position in the Stream
	represented by the receiver. Fail if the collection of this stream is not an
	Array or a String. Fail if the stream is positioned at its end, or if the
	position is out of bounds in the collection. Fail if the argument is not
	of the right type for the collection. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 66>
	position >= writeLimit
		ifTrue: [^ self pastEndPut: anObject]
		ifFalse: 
			[position := position + 1.
			^collection byteAt: position put: anObject]! !


!ZipEncoder methodsFor: 'block encoding' stamp: 'ar 12/30/1999 18:39'!
sendBlock: literalStream with: distanceStream with: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| result |
	result := 0.
	[literalStream atEnd] whileFalse:[
		result := result + (self privateSendBlock: literalStream
						with: distanceStream with: litTree with: distTree).
		self commit.
	].
	self nextBits: (litTree bitLengthAt: EndBlock) put: (litTree codeAt: EndBlock).
	^result! !


!ZipEncoder methodsFor: 'initialize-release' stamp: 'sd 1/30/2004 15:24'!
close
	self flush.
	encodedStream close.! !

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 15:51'!
commit
	encodedStream next: position putAll: collection.
	position := readLimit := 0.! !

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 15:51'!
flush
	self flushBits.
	self commit.! !

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 16:35'!
flushBits
	"Flush currently unsent bits"
	[bitPosition > 0] whileTrue:[
		self nextBytePut: (bitBuffer bitAnd: 255).
		bitBuffer := bitBuffer bitShift: -8.
		bitPosition := bitPosition - 8].
	bitPosition := 0.! !

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 17:22'!
on: aCollectionOrStream
	aCollectionOrStream isStream 
		ifTrue:[encodedStream := aCollectionOrStream]
		ifFalse:[	encodedStream := WriteStream on: aCollectionOrStream].
	encodedStream isBinary
		ifTrue:[super on: (ByteArray new: 4096)]
		ifFalse:[super on: (String new: 4096)].
	bitPosition := bitBuffer := 0.! !


!ZipEncoder methodsFor: 'private' stamp: 'ar 1/2/2000 16:38'!
pastEndPut: anObject
	"Flush the current buffer and store the new object at the beginning"
	self commit.
	^self nextBytePut: anObject asInteger! !

!ZipEncoder methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'!
privateSendBlock: literalStream with: distanceStream with: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| lit dist code extra sum |
	<primitive: 'primitiveZipSendBlock' module: 'ZipPlugin'>
	sum := 0.
	[lit := literalStream next.
	dist := distanceStream next.
	lit == nil] whileFalse:[
		dist = 0 ifTrue:["lit is a literal"
			sum := sum + 1.
			self nextBits: (litTree bitLengthAt: lit)
				put: (litTree codeAt: lit).
		] ifFalse:["lit is match length"
			sum := sum + lit + MinMatch.
			code := (MatchLengthCodes at: lit + 1).
			self nextBits: (litTree bitLengthAt: code)
				put: (litTree codeAt: code).
			extra := ExtraLengthBits at: code-NumLiterals.
			extra = 0 ifFalse:[
				lit := lit - (BaseLength at: code-NumLiterals).
				self nextBits: extra put: lit.
			].
			dist := dist - 1.
			dist < 256
				ifTrue:[code := DistanceCodes at: dist + 1]
				ifFalse:[code := DistanceCodes at: 257 + (dist bitShift: -7)].
			"self assert:[code < MaxDistCodes]."
			self nextBits: (distTree bitLengthAt: code)
				put: (distTree codeAt: code).
			extra := ExtraDistanceBits at: code+1.
			extra = 0 ifFalse:[
				dist := dist - (BaseDistance at: code+1).
				self nextBits: extra put: dist.
			].
		].
	].
	^sum! !
Object subclass: #ZipEncoderNode
	instanceVariableNames: 'value frequency height bitLength code parent left right'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Streams'!
!ZipEncoderNode commentStamp: '<historical>' prior: 0!
ZipEncoderNode represents a node in a huffman tree for encoding ZipStreams.

Instance variables:
	value 		<Integer>	- Encoded value
	frequency	<Integer>	- Number of occurences of the encoded value
	height 		<Integer>	- Height of the node in the tree
	bitLength 	<Integer>	- bit length of the code
	code		<Integer>	- Assigned code for this node
	parent		<ZipEncoderNode>		- Parent of this node
	left			<ZipEncoderNode>		- First child of this node
	right		<ZipEncoderNode>		- Second child of this node
!


!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 19:41'!
bitLength
	^bitLength ifNil:[0]! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/30/1999 14:28'!
code
	^code ifNil:[0]! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:51'!
code: aCode
	self assert:[aCode >= 0 and:[(1 bitShift: bitLength) > aCode]].
	code := aCode.! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:36'!
frequency
	^frequency! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/28/1999 00:56'!
frequency: aNumber
	frequency := aNumber! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/26/1999 10:44'!
height
	^height! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
left
	^left! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'!
left: aNode
	aNode parent: self.
	left := aNode.! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
parent
	^parent! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
parent: aNode
	parent := aNode! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
right
	^right! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'!
right: aNode
	aNode parent: self.
	right := aNode.! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
value
	^value! !


!ZipEncoderNode methodsFor: 'encoding' stamp: 'ar 12/26/1999 11:49'!
encodeBitLength: blCounts from: aTree
	| index |
	"Note: If bitLength is not nil then the tree must be broken"
	bitLength == nil ifFalse:[self error:'Huffman tree is broken'].
	parent = nil 
		ifTrue:[bitLength := 0]
		ifFalse:[bitLength := parent bitLength + 1].
	self isLeaf ifTrue:[
		index := bitLength + 1.
		blCounts at: index put: (blCounts at: index) + 1.
	] ifFalse:[
		left encodeBitLength: blCounts from: aTree.
		right encodeBitLength: blCounts from: aTree.
	].! !

!ZipEncoderNode methodsFor: 'encoding' stamp: 'ar 12/27/1999 14:27'!
rotateToHeight: maxHeight
	"Rotate the tree to achieve maxHeight depth"
	| newParent |
	height < 4 ifTrue:[^self].
	self left: (left rotateToHeight: maxHeight-1).
	self right: (right rotateToHeight: maxHeight-1).
	height := (left height max: right height) + 1.
	height <= maxHeight ifTrue:[^self].
	(left height - right height) abs <= 2 ifTrue:[^self].
	left height < right height ifTrue:[
		right right height >= right left height ifTrue:[
			newParent := right.
			self right: newParent left.
			newParent left: self.
		] ifFalse:[
			newParent := right left.
			right left: newParent right.
			newParent right: right.
			self right: newParent left.
			newParent left: self.
		].
	] ifFalse:[
		left left height >= left right height ifTrue:[
			newParent := left.
			self left: newParent right.
			newParent right: self.
		] ifFalse:[
			newParent := left right.
			left right: newParent left.
			newParent left: left.
			self left: newParent right.
			newParent right: self.
		].
	].
	parent computeHeight.
	^parent! !


!ZipEncoderNode methodsFor: 'printing' stamp: 'ar 12/26/1999 10:46'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(;
		nextPutAll:'value = '; print: value;
		nextPutAll:', freq = '; print: frequency;
		nextPutAll:', bitLength = '; print: bitLength;
		nextPutAll:', code = '; print: code;
		nextPutAll:', height = '; print: height; 
	nextPut:$).! !


!ZipEncoderNode methodsFor: 'testing' stamp: 'ar 12/24/1999 23:17'!
isLeaf
	^left == nil! !


!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:45'!
computeHeight
	^self isLeaf
		ifTrue:[height := 0]
		ifFalse:[height := (left computeHeight max: right computeHeight) + 1].! !

!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/25/1999 18:14'!
leafNodes
	self isLeaf
		ifTrue:[^Array with: self]
		ifFalse:[^left leafNodes, right leafNodes]! !

!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 12:05'!
setBitLengthTo: bl
	bitLength := bl! !

!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:46'!
setValue: v frequency: f height: h
	value := v.
	frequency := f.
	height := h.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipEncoderNode class
	instanceVariableNames: ''!

!ZipEncoderNode class methodsFor: 'instance creation' stamp: 'ar 12/26/1999 10:47'!
value: v frequency: f height: h
	^self new setValue: v frequency: f height: h! !
Object subclass: #ZipEncoderTree
	instanceVariableNames: 'bitLengths codes maxCode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Streams'!
!ZipEncoderTree commentStamp: '<historical>' prior: 0!
ZipEncoderTree represents a huffman tree for encoding ZipStreams.

Instance variables:
	bitLengths	<WordArray>	 - Bit lengths of each generated code
	codes		<WordArray>	 - Codes for each value
	maxCode		<Integer>	- Maximum value with non-zero frequency!


!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:43'!
bitLengthAt: index
	^bitLengths at: index+1! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:32'!
bitLengths
	"Return an array of all bitLength values for valid codes"
	^bitLengths! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:04'!
codeAt: index
	^codes at: index+1! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:24'!
codes
	"Return an array of all valid codes"
	^codes! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 17:15'!
maxCode
	^maxCode! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:45'!
maxCode: aNumber
	maxCode := aNumber.! !


!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:34'!
buildCodes: nodeList counts: blCounts maxDepth: depth
	"Build the codes for all nodes"
	| nextCode code node length |
	nextCode := WordArray new: depth+1.
	code := 0.
	1 to: depth do:[:bits|
		code := (code + (blCounts at: bits)) << 1.
		nextCode at: bits+1 put: code].
	self assert:[(code + (blCounts at: depth+1) - 1) = (1 << depth - 1)].
	0 to: maxCode do:[:n|
		node := nodeList at: n+1.
		length := node bitLength.
		length = 0 ifFalse:[
			code := nextCode at: length+1.
			node code: (self reverseBits: code length: length).
			nextCode at: length+1 put: code+1.
		].
	].! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'!
buildHierarchyFrom: aHeap
	"Build the node hierarchy based on the leafs in aHeap"
	| left right parent |
	[aHeap size > 1] whileTrue:[
		left := aHeap removeFirst.
		right := aHeap removeFirst.
		parent := ZipEncoderNode value: -1 
			frequency: (left frequency + right frequency)
			height: (left height max: right height) + 1.
		left parent: parent.
		right parent: parent.
		parent left: left.
		parent right: right.
		aHeap add: parent].
	^aHeap removeFirst
! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 14:19'!
buildTree: nodeList maxDepth: depth
	"Build either the literal or the distance tree"
	| heap rootNode blCounts |
	heap := Heap new: nodeList size // 3.
	heap sortBlock: self nodeSortBlock.
	"Find all nodes with non-zero frequency and add to heap"
	maxCode := 0.
	nodeList do:[:dNode|
		dNode frequency = 0 ifFalse:[
			maxCode := dNode value.
			heap add: dNode]].
	"The pkzip format requires that at least one distance code exists,
	and that at least one bit should be sent even if there is only one
	possible code. So to avoid special checks later on we force at least
	two codes of non zero frequency."
	heap size = 0 ifTrue:[
		self assert:[maxCode = 0].
		heap add: nodeList first.
		heap add: nodeList second.
		maxCode := 1].
	heap size = 1 ifTrue:[
		nodeList first frequency = 0
			ifTrue:[heap add: nodeList first]
			ifFalse:[heap add: nodeList second].
		maxCode := maxCode max: 1].
	rootNode := self buildHierarchyFrom: heap.
	rootNode height > depth ifTrue:[
		rootNode := rootNode rotateToHeight: depth.
		rootNode height > depth ifTrue:[self error:'Cannot encode tree']].
	blCounts := WordArray new: depth+1.
	rootNode encodeBitLength: blCounts from: self.
	self buildCodes: nodeList counts: blCounts maxDepth: depth.
	self setValuesFrom: nodeList.! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:24'!
buildTreeFrom: frequencies maxDepth: depth
	"Build the receiver from the given frequency values"
	| nodeList |
	nodeList := Array new: frequencies size.
	1 to: frequencies size do:[:i|
		nodeList at: i put: (ZipEncoderNode value: i-1 frequency: (frequencies at: i) height: 0)
	].
	self buildTree: nodeList maxDepth: depth.! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'!
nodeSortBlock
	^[:n1 :n2|
		n1 frequency = n2 frequency
			ifTrue:[n1 height <= n2 height]
			ifFalse:[n1 frequency <= n2 frequency]].! !


!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/30/1999 14:26'!
bitLengths: blArray codes: codeArray
	bitLengths := blArray as: WordArray.
	codes := codeArray as: WordArray.
	self assert:[(self bitLengthAt: maxCode) > 0].! !

!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/26/1999 11:02'!
reverseBits: code length: length
	"Bit reverse the given code"
	| result bit bits |
	result := 0.
	bits := code.
	1 to: length do:[:i|
		bit := bits bitAnd: 1.
		result := result << 1 bitOr: bit.
		bits := bits >> 1].
	^result! !

!ZipEncoderTree methodsFor: 'private' stamp: 'sma 6/1/2000 11:52'!
setValuesFrom: nodeList
	self bitLengths: (nodeList
			collect: [:n | n bitLength]
			from: 1
			to: maxCode + 1)
		codes: (nodeList
				collect: [:n | n code]
				from: 1
				to: maxCode + 1)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipEncoderTree class
	instanceVariableNames: ''!

!ZipEncoderTree class methodsFor: 'instance creation' stamp: 'ar 12/30/1999 01:25'!
buildTreeFrom: frequencies maxDepth: depth
	^self new buildTreeFrom: frequencies maxDepth: depth! !
SharedPool subclass: #ZipFileConstants
	instanceVariableNames: ''
	classVariableNames: 'CentralDirectoryFileHeaderSignature CompressionDeflated CompressionLevelDefault CompressionLevelNone CompressionStored DataDescriptorLength DefaultDirectoryPermissions DefaultFilePermissions DeflatingCompressionFast DeflatingCompressionMaximum DeflatingCompressionNormal DeflatingCompressionSuperFast DirectoryAttrib EndOfCentralDirectorySignature FaMsdos FaUnix FileAttrib IfaBinaryFile IfaTextFile LocalFileHeaderSignature'
	poolDictionaries: ''
	category: 'Compression-Archives'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipFileConstants class
	instanceVariableNames: ''!

!ZipFileConstants class methodsFor: 'pool initialization' stamp: 'nk 8/21/2004 15:50'!
initialize
	"ZipFileConstants initialize"
	FaMsdos		:= 0.
	FaUnix 		:= 3.
	DeflatingCompressionNormal		:= 0.
	DeflatingCompressionMaximum	:= 2.
	DeflatingCompressionFast		:= 4.
	DeflatingCompressionSuperFast	:= 6.
	CompressionStored				:= 0.
	CompressionDeflated				:= 8.
	CompressionLevelNone			:= 0.
	CompressionLevelDefault			:= 6.
	IfaTextFile						:= 1.
	IfaBinaryFile					:= 0.
	DataDescriptorLength 				:= 12.

	"Unix permission bits"
	DefaultDirectoryPermissions		:= 8r040755.
	DefaultFilePermissions			:= 8r0100666.
	DirectoryAttrib 					:= 8r040000.
	FileAttrib 						:= 8r0100000.

	CentralDirectoryFileHeaderSignature := 
		(ByteArray with: 16r50 with: 16r4B with: 16r01 with: 16r02).
	LocalFileHeaderSignature :=
		(ByteArray with: 16r50 with: 16r4B with: 16r03 with: 16r04).
	EndOfCentralDirectorySignature :=
		(ByteArray with: 16r50 with: 16r4B with: 16r05 with: 16r06).! !
ZipArchiveMember subclass: #ZipFileMember
	instanceVariableNames: 'externalFileName stream localHeaderRelativeOffset dataOffset'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Archives'!
!ZipFileMember commentStamp: '<historical>' prior: 0!
ZipNewFileMember instances are used to represent files that have been read from a ZipArchive.
Their data stays in the file on disk, so the original Zip file cannot be directly overwritten.!


!ZipFileMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'!
close
	stream ifNotNil:[stream close].! !

!ZipFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:52'!
initialize
	super initialize.
	crc32 := 0.
	localHeaderRelativeOffset := 0.
	dataOffset := 0.! !

!ZipFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:51'!
stream: aStream externalFileName: aFileName
	stream := aStream.
	externalFileName := aFileName.! !


!ZipFileMember methodsFor: 'testing' stamp: 'nk 2/21/2001 21:52'!
looksLikeDirectory
	^fileName last = $/
		and: [ uncompressedSize = 0 ]! !

!ZipFileMember methodsFor: 'testing' stamp: 'nk 2/24/2001 14:07'!
usesFileNamed: aFileName
	"Do I require aFileName? That is, do I care if it's clobbered?"
	^(FileDirectory default fullNameFor: externalFileName) = (FileDirectory default fullNameFor: aFileName)! !


!ZipFileMember methodsFor: 'private' stamp: 'nk 2/21/2001 21:55'!
asDirectory
	^ZipDirectoryMember new copyFrom: self! !


!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 11/11/2002 21:46'!
canonicalizeFileName
	"For security reasons, make all paths relative and remove any ../ portions"

	[fileName beginsWith: '/'] whileTrue: [fileName := fileName allButFirst].
	fileName := fileName copyReplaceAll: '../' with: ''! !

!ZipFileMember methodsFor: 'private-reading' stamp: 'yo 12/19/2003 21:15'!
readCentralDirectoryFileHeaderFrom: aStream
	"Assumes aStream positioned after signature"

	| fileNameLength extraFieldLength fileCommentLength |

	versionMadeBy := aStream nextLittleEndianNumber: 1.
	fileAttributeFormat := aStream nextLittleEndianNumber: 1.

	versionNeededToExtract := aStream nextLittleEndianNumber: 2.
	bitFlag := aStream nextLittleEndianNumber: 2.
	compressionMethod := aStream nextLittleEndianNumber: 2.

	lastModFileDateTime := aStream nextLittleEndianNumber: 4.
	crc32 := aStream nextLittleEndianNumber: 4.
	compressedSize := aStream nextLittleEndianNumber: 4.
	uncompressedSize := aStream nextLittleEndianNumber: 4.

	fileNameLength := aStream nextLittleEndianNumber: 2.
	extraFieldLength := aStream nextLittleEndianNumber: 2.
	fileCommentLength := aStream nextLittleEndianNumber: 2.
	aStream nextLittleEndianNumber: 2. 	"disk number start"
	internalFileAttributes := aStream nextLittleEndianNumber: 2.

	externalFileAttributes := aStream nextLittleEndianNumber: 4.
	localHeaderRelativeOffset := aStream nextLittleEndianNumber: 4.

	fileName := (aStream next: fileNameLength) asString asSqueakPathName.
	cdExtraField := (aStream next: extraFieldLength) asByteArray asString.
	fileComment := (aStream next: fileCommentLength) asString convertFromSystemString.

	self desiredCompressionMethod: compressionMethod! !

!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 11/11/2002 21:48'!
readFrom: aStream 
	"assumes aStream positioned after CD header; leaves stream positioned after my CD entry"

	self readCentralDirectoryFileHeaderFrom: aStream.
	self readLocalDirectoryFileHeaderFrom: aStream.
	self endRead.
	self canonicalizeFileName.
! !

!ZipFileMember methodsFor: 'private-reading' stamp: 'BG 3/16/2005 08:28'!
readLocalDirectoryFileHeaderFrom: aStream 
	"Positions stream as necessary. Will return stream to its original position"

	| fileNameLength extraFieldLength xcrc32 xcompressedSize xuncompressedSize sig oldPos |

	oldPos := aStream position.

	aStream position: localHeaderRelativeOffset.

	sig := aStream next: 4.
	sig = LocalFileHeaderSignature asByteArray
		ifFalse: [ aStream position: oldPos.
				^self error: 'bad LH signature at ', localHeaderRelativeOffset printStringHex ].

	versionNeededToExtract := aStream nextLittleEndianNumber: 2.
	bitFlag := aStream nextLittleEndianNumber: 2.
	compressionMethod := aStream nextLittleEndianNumber: 2.

	lastModFileDateTime := aStream nextLittleEndianNumber: 4.
	xcrc32 := aStream nextLittleEndianNumber: 4.
	xcompressedSize := aStream nextLittleEndianNumber: 4.
	xuncompressedSize := aStream nextLittleEndianNumber: 4.

	fileNameLength := aStream nextLittleEndianNumber: 2.
	extraFieldLength := aStream nextLittleEndianNumber: 2.

	fileName := (aStream next: fileNameLength) asString asSqueakPathName.
	localExtraField := (aStream next: extraFieldLength) asByteArray.

	dataOffset := aStream position.

	"Don't trash these fields if we already got them from the central directory"
	self hasDataDescriptor ifFalse: [
		crc32 := xcrc32.
		compressedSize := xcompressedSize.
		uncompressedSize := xuncompressedSize.
	].

	aStream position: oldPos.! !

!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 2/22/2001 20:46'!
readRawChunk: n
	^stream next: n! !

!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 2/23/2001 09:56'!
rewindData
	super rewindData.
	(stream isNil or: [ stream closed ])
		ifTrue: [ self error: 'stream missing or closed' ].
	stream position: (localHeaderRelativeOffset + 4).
	self skipLocalDirectoryFileHeaderFrom: stream.! !

!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 2/23/2001 09:56'!
skipLocalDirectoryFileHeaderFrom: aStream 
	"Assumes that stream is positioned after signature."

	|  extraFieldLength fileNameLength |
	aStream next: 22.
	fileNameLength := aStream nextLittleEndianNumber: 2.
	extraFieldLength := aStream nextLittleEndianNumber: 2.
	aStream next: fileNameLength.
	aStream next: extraFieldLength.
	dataOffset := aStream position.
! !


!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'!
copyDataTo: aStream

	self copyRawDataTo: aStream.! !

!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 3/27/2002 11:20'!
localHeaderRelativeOffset
	^localHeaderRelativeOffset! !

!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 3/7/2004 16:08'!
uncompressDataTo: aStream

	| decoder buffer chunkSize crcErrorMessage |
	decoder := ZipReadStream on: stream.
	decoder expectedCrc: self crc32.
	buffer := ByteArray new: (32768 min: readDataRemaining).
	crcErrorMessage := nil.

	[[ readDataRemaining > 0 ] whileTrue: [
		chunkSize := 32768 min: readDataRemaining.
		buffer := decoder next: chunkSize into: buffer startingAt: 1.
		aStream next: chunkSize putAll: buffer startingAt: 1.
		readDataRemaining := readDataRemaining - chunkSize.
	]] on: CRCError do: [ :ex | crcErrorMessage := ex messageText. ex proceed ].

	crcErrorMessage ifNotNil: [ self isCorrupt: true. CRCError signal: crcErrorMessage ]

! !

!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 17:52'!
uncompressDataTo: aStream from: start to: finish

	| decoder buffer chunkSize |
	decoder := FastInflateStream on: stream.
	readDataRemaining := readDataRemaining min: finish - start + 1.
	buffer := ByteArray new: (32768 min: readDataRemaining).
	decoder next: start - 1.

	[ readDataRemaining > 0 ] whileTrue: [
		chunkSize := 32768 min: readDataRemaining.
		buffer := decoder next: chunkSize into: buffer startingAt: 1.
		aStream next: chunkSize putAll: buffer startingAt: 1.
		readDataRemaining := readDataRemaining - chunkSize.
	].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipFileMember class
	instanceVariableNames: ''!

!ZipFileMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/22/2001 17:31'!
newFrom: stream named: fileName
	^(self new) stream: stream externalFileName: fileName! !
ZipArchiveMember subclass: #ZipNewFileMember
	instanceVariableNames: 'externalFileName stream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Archives'!
!ZipNewFileMember commentStamp: '<historical>' prior: 0!
ZipNewFileMember instances are used to represent files that are going to be written to a ZipArchive.
Their data comes from external file streams.!


!ZipNewFileMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:50'!
close
	stream ifNotNil:[stream close].! !

!ZipNewFileMember methodsFor: 'initialization' stamp: 'nk 12/20/2002 15:01'!
from: aFileName
	| entry |
	compressionMethod := CompressionStored.
	"Now get the size, attributes, and timestamps, and see if the file exists"
	stream := StandardFileStream readOnlyFileNamed: aFileName.
	self localFileName: (externalFileName := stream name).
	entry := stream directoryEntry.
	compressedSize := uncompressedSize := entry fileSize.
	desiredCompressionMethod := compressedSize > 0 ifTrue: [ CompressionDeflated ] ifFalse: [ CompressionStored ].
	self setLastModFileDateTimeFrom: entry modificationTime
! !

!ZipNewFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:56'!
initialize
	super initialize.
	externalFileName := ''.! !


!ZipNewFileMember methodsFor: 'testing' stamp: 'nk 2/24/2001 15:03'!
usesFileNamed: aFileName
	"Do I require aFileName? That is, do I care if it's clobbered?"
	^(FileDirectory default fullNameFor: externalFileName) = (FileDirectory default fullNameFor: aFileName)! !


!ZipNewFileMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:48'!
readRawChunk: n
	^stream next: n! !


!ZipNewFileMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 09:58'!
rewindData
	super rewindData.
	readDataRemaining := stream size.
	stream position: 0.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipNewFileMember class
	instanceVariableNames: ''!

!ZipNewFileMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'!
newNamed: aFileName
	^(self new) from: aFileName! !
FastInflateStream subclass: #ZipReadStream
	instanceVariableNames: 'expectedCrc'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Streams'!
!ZipReadStream commentStamp: 'nk 3/7/2004 18:54' prior: 0!
ZipReadStream is intended for uncompressing the compressed contents of Zip archive members.

Since Zip archive members keep their expected CRC value separately in Zip headers, this class does not attempt to read the CRC from its input stream.

Instead, if you want the CRC verification to work you have to call #expectedCrc: with the expected CRC-32 value from the Zip member header.!


!ZipReadStream methodsFor: 'crc' stamp: 'nk 3/7/2004 18:55'!
expectedCrc: aNumberOrNil
	"If expectedCrc is set, it will be compared against the calculated CRC32 in verifyCrc.
	This number should be the number read from the Zip header (which is the bitwise complement of my crc if all is working correctly)"
	expectedCrc := aNumberOrNil! !

!ZipReadStream methodsFor: 'crc' stamp: 'nk 3/7/2004 15:32'!
updateCrc: oldCrc from: start to: stop in: aCollection
	^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! !

!ZipReadStream methodsFor: 'crc' stamp: 'BG 3/16/2005 08:28'!
verifyCrc
	"Verify the CRC-32 checksum calculated from the input against the expected CRC-32, if any.
	Answer the calculated CRC-32 in any case.
	Note that the CRC-32 used in Zip files is actually the bit inverse of the calculated value, so that is what is returned."

	| invertedCrc |
	invertedCrc := crc bitXor: 16rFFFFFFFF.
	(expectedCrc notNil and: [ expectedCrc ~= invertedCrc ])
		ifTrue: [ ^ self crcError: ('Wrong CRC-32 (expected {1} got {2}) (proceed to ignore)' translated format: { expectedCrc printStringHex. invertedCrc printStringHex }) ].
	^invertedCrc! !


!ZipReadStream methodsFor: 'initialize' stamp: 'nk 3/7/2004 15:31'!
on: aCollection from: firstIndex to: lastIndex
	super on: aCollection from: firstIndex to: lastIndex.
	crc := 16rFFFFFFFF.
	expectedCrc := nil.! !
ZipArchiveMember subclass: #ZipStringMember
	instanceVariableNames: 'contents stream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Archives'!
!ZipStringMember commentStamp: '<historical>' prior: 0!
ZipStringMember instances are used to represent files that are going to be written to a ZipArchive.
Their data comes from in-image strings, though.!


!ZipStringMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:47'!
contents
	^contents! !

!ZipStringMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 20:50'!
contents: aString
	contents := aString.
	compressedSize := uncompressedSize := aString size.
	"set the file date to now"
	self setLastModFileDateTimeFrom: Time totalSeconds! !

!ZipStringMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 20:50'!
initialize
	super initialize.
	self contents: ''.
	compressionMethod := desiredCompressionMethod := CompressionStored.
! !


!ZipStringMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:51'!
readRawChunk: n
	^stream next: n! !


!ZipStringMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 10:28'!
rewindData
	super rewindData.
	stream := ReadStream on: contents.
	readDataRemaining := contents size.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipStringMember class
	instanceVariableNames: ''!

!ZipStringMember class methodsFor: 'as yet unclassified' stamp: 'nk 12/20/2002 15:06'!
newFrom: aString named: aFileName
	^(self new) contents: aString; localFileName: aFileName; yourself! !
DeflateStream subclass: #ZipWriteStream
	instanceVariableNames: 'literals distances literalFreq distanceFreq litCount matchCount encoder crc crcPosition bytesWritten'
	classVariableNames: 'CrcTable VerboseLevel'
	poolDictionaries: 'ZipConstants'
	category: 'Compression-Streams'!

!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 2/24/2001 19:46'!
crc
	^crc! !

!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'!
encodedStream
	^encoder encodedStream! !

!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 18:32'!
forcedMethod
	"Return a symbol describing an enforced method or nil if the method should
	be chosen adaptively. Valid symbols are
		#stored	- store blocks (do not compress)
		#fixed	- use fixed huffman trees
		#dynamic	- use dynamic huffman trees."
	^nil! !


!ZipWriteStream methodsFor: 'deflating' stamp: 'ar 2/2/2001 15:47'!
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
	"^DeflatePlugin doPrimitive:#primitiveDeflateBlock"
	<primitive: 'primitiveDeflateBlock' module: 'ZipPlugin'>
	^super deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch! !


!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 01:55'!
dynamicBlockSizeFor: lTree and: dTree using: blTree and: blFreq
	"Compute the length for the current block using dynamic huffman trees"
	| bits index extra treeBits freq |
	bits := 3 "block type" + 5 "literal codes length" + 5 "distance codes length".

	"Compute the # of bits for sending the bit length tree"
	treeBits := 4. "Max index for bit length tree"
	index := MaxBitLengthCodes.
	[index >= 4] whileTrue:[
		(index = 4 or:[(blFreq at: (BitLengthOrder at: index)+1) > 0])
			ifTrue:[treeBits := treeBits + (index * 3).
					index := -1]
			ifFalse:[index := index - 1]].

	"Compute the # of bits for sending the literal/distance tree.
	Note: The frequency are already stored in the blTree"
	0 to: 15 do:[:i| "First, the non-repeating values"
		freq := blFreq at: i+1.
		freq > 0 ifTrue:[treeBits := treeBits + (freq * (blTree bitLengthAt: i))]].
	"Now the repeating values"
	(Repeat3To6 to: Repeat11To138) with: #(2 3 7) do:[:i :addl|
		freq := blFreq at: i+1.
		freq > 0 ifTrue:[
			treeBits := treeBits + (freq * ((blTree bitLengthAt: i) + addl "addl bits"))]].
	VerboseLevel > 1 ifTrue:[
		Transcript show:'['; print: treeBits; show:' bits for dynamic tree]'].
	bits := bits + treeBits.

	"Compute the size of the compressed block"
	0 to: NumLiterals do:[:i| "encoding of literals"
		freq := literalFreq at: i+1.
		freq > 0 ifTrue:[bits := bits + (freq * (lTree bitLengthAt: i))]].
	NumLiterals+1 to: lTree maxCode do:[:i| "encoding of match lengths"
		freq := literalFreq at: i+1.
		extra := ExtraLengthBits at: i-NumLiterals.
		freq > 0 ifTrue:[bits := bits + (freq * ((lTree bitLengthAt: i) + extra))]].
	0 to: dTree maxCode do:[:i| "encoding of distances"
		freq := distanceFreq at: i+1.
		extra := ExtraDistanceBits at: i+1.
		freq > 0 ifTrue:[bits := bits + (freq * ((dTree bitLengthAt: i) + extra))]].

	^bits! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'!
scanBitLength: bitLength repeatCount: repeatCount into: anArray
	"Update the frequency for the aTree based on the given values"
	| count |
	count := repeatCount.
	bitLength = 0 ifTrue:[
		[count >= 11] whileTrue:[
			anArray at: Repeat11To138+1 put: (anArray at: Repeat11To138+1) + 1.
			count := (count - 138) max: 0].
		[count >= 3] whileTrue:[
			anArray at: Repeat3To10+1 put: (anArray at: Repeat3To10+1) + 1.
			count := (count - 10) max: 0].
		count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count].
	] ifFalse:[
		anArray at: bitLength+1 put: (anArray at: bitLength+1) + 1.
		count := count - 1.
		[count >= 3] whileTrue:[
			anArray at: Repeat3To6+1 put: (anArray at: Repeat3To6+1) + 1.
			count := (count - 6) max: 0].
		count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count].
	].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'!
scanBitLengths: bits into: anArray
	"Scan the trees and determine the frequency of the bit lengths.
	For repeating codes, emit a repeat count."
	| lastValue lastCount value |
	bits size = 0 ifTrue:[^self].
	lastValue := bits at: 1.
	lastCount := 1.
	2 to: bits size do:[:i|
		value := bits at: i.
		value = lastValue 
			ifTrue:[lastCount := lastCount + 1]
			ifFalse:[self scanBitLength: lastValue repeatCount: lastCount into: anArray.
					lastValue := value.
					lastCount := 1]].
	self scanBitLength: lastValue repeatCount: lastCount into: anArray.! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'!
sendBitLength: bitLength repeatCount: repeatCount tree: aTree
	"Send the given bitLength, repeating repeatCount times"
	| count |
	count := repeatCount.
	bitLength = 0 ifTrue:[
		[count >= 11] whileTrue:[
			self sendBitLength: Repeat11To138 tree: aTree.
			encoder nextBits: 7 put: (count min: 138) - 11.
			count := (count - 138) max: 0].
		[count >= 3] whileTrue:[
			self sendBitLength: Repeat3To10 tree: aTree.
			encoder nextBits: 3 put: (count min: 10) - 3.
			count := (count - 10) max: 0].
		count timesRepeat:[self sendBitLength: bitLength tree: aTree].
	] ifFalse:[
		self sendBitLength: bitLength tree: aTree.
		count := count - 1.
		[count >= 3] whileTrue:[
			self sendBitLength: Repeat3To6 tree: aTree.
			encoder nextBits: 2 put: (count min: 6) - 3.
			count := (count - 6) max: 0].
		count timesRepeat:[self sendBitLength: bitLength tree: aTree].
	].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'!
sendBitLength: bitLength tree: aTree
	"Send the given bitLength"
	encoder nextBits: (aTree bitLengthAt: bitLength) 
		put: (aTree codeAt: bitLength).! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'!
sendBitLengthTree: blTree
	"Send the bit length tree"
	| blIndex bitLength |
	MaxBitLengthCodes to: 4 by: -1 do:[:maxIndex|
		blIndex := BitLengthOrder at: maxIndex.
		bitLength := blIndex <= blTree maxCode 
			ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0].
		(maxIndex = 4 or:[bitLength > 0]) ifTrue:[
			encoder nextBits: 4 put: maxIndex - 4.
			1 to: maxIndex do:[:j|
				blIndex := BitLengthOrder at: j.
				bitLength := blIndex <= blTree maxCode 
					ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0].
				encoder nextBits: 3 put: bitLength].
			^self]].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 00:48'!
sendCompressedBlock: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| sum |
	sum := encoder
			sendBlock: (ReadStream on: literals from: 1 to: litCount)
			with: (ReadStream on: distances from: 1 to: litCount)
			with: litTree
			with: distTree.
	sum = (blockPosition - blockStart) ifFalse:[self error:'Wrong number of bytes'].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/29/1999 18:19'!
sendDynamicBlock: blTree literalTree: lTree distanceTree: dTree bitLengths: bits
	"Send a block using dynamic huffman trees"
	self sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits.
	self sendCompressedBlock: lTree with: dTree.! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'!
sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits
	"Send all the trees needed for dynamic huffman tree encoding"
	| lastValue lastCount value |
	encoder nextBits: 5 put: (lTree maxCode - 256).
	encoder nextBits: 5 put: (dTree maxCode).
	self sendBitLengthTree: blTree.
	bits size = 0 ifTrue:[^self].
	lastValue := bits at: 1.
	lastCount := 1.
	2 to: bits size do:[:i|
		value := bits at: i.
		value = lastValue 
			ifTrue:[lastCount := lastCount + 1]
			ifFalse:[self sendBitLength: lastValue repeatCount: lastCount tree: blTree.
					lastValue := value.
					lastCount := 1]].
	self sendBitLength: lastValue repeatCount: lastCount tree: blTree.! !


!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'!
encodeLiteral: lit
	"Encode the given literal"
	litCount := litCount + 1.
	literals at: litCount put: lit.
	distances at: litCount put: 0.
	literalFreq at: lit+1 put: (literalFreq at: lit+1) + 1.
	^self shouldFlush! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'!
encodeMatch: length distance: dist
	"Encode the given match of length length starting at dist bytes ahead"
	| literal distance |
	dist > 0 
		ifFalse:[^self error:'Distance must be positive'].
	length < MinMatch 
		ifTrue:[^self error:'Match length must be at least ', MinMatch printString].
	litCount := litCount + 1.
	matchCount := matchCount + 1.
	literals at: litCount put: length - MinMatch.
	distances at: litCount put: dist.
	literal := (MatchLengthCodes at: length - MinMatch + 1).
	literalFreq at: literal+1 put: (literalFreq at: literal+1) + 1.
	dist < 257
		ifTrue:[distance := DistanceCodes at: dist]
		ifFalse:[distance := DistanceCodes at: 257 + (dist - 1 bitShift: -7)].
	distanceFreq at: distance+1 put: (distanceFreq at: distance+1) + 1.
	^self shouldFlush! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'!
flushBlock
	^self flushBlock: false! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/30/1999 11:54'!
flushBlock: lastBlock
	"Send the current block"
	| lastFlag bitsRequired method bitsSent
	storedLength fixedLength dynamicLength 
	blTree lTree dTree blBits blFreq |

	lastFlag := lastBlock ifTrue:[1] ifFalse:[0].

	"Compute the literal/length and distance tree"
	lTree := ZipEncoderTree buildTreeFrom: literalFreq maxDepth: MaxBits.
	dTree := ZipEncoderTree buildTreeFrom: distanceFreq maxDepth: MaxBits.

	"Compute the bit length tree"
	blBits := lTree bitLengths, dTree bitLengths.
	blFreq := WordArray new: MaxBitLengthCodes.
	self scanBitLengths: blBits into: blFreq.
	blTree := ZipEncoderTree buildTreeFrom: blFreq maxDepth: MaxBitLengthBits.

	"Compute the bit length for the current block.
	Note: Most of this could be computed on the fly but it's getting
	really ugly in this case so we do it afterwards."
	storedLength := self storedBlockSize.
	fixedLength := self fixedBlockSizeFor: lTree and: dTree.
	dynamicLength := self dynamicBlockSizeFor: lTree and: dTree 
							using: blTree and: blFreq.
	VerboseLevel > 1 ifTrue:[
		Transcript cr; show:'Block sizes (S/F/D):';
			space; print: storedLength // 8; 
			nextPut:$/; print: fixedLength // 8; 
			nextPut:$/; print: dynamicLength // 8; space; endEntry].

	"Check which method to use"
	method := self forcedMethod.
	method == nil ifTrue:[
		method := (storedLength < fixedLength and:[storedLength < dynamicLength]) 
			ifTrue:[#stored]
			ifFalse:[fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]].
	(method == #stored and:[blockStart < 0]) ifTrue:[
		"Cannot use #stored if the block is not available"
		method := fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]].

	bitsSent := encoder bitPosition. "# of bits sent before this block"
	bitsRequired := nil.

	(method == #stored) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'S'].
		bitsRequired := storedLength.
		encoder nextBits: 3 put: StoredBlock << 1 + lastFlag.
		self sendStoredBlock].

	(method == #fixed) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'F'].
		bitsRequired := fixedLength.
		encoder nextBits: 3 put: FixedBlock << 1 + lastFlag.
		self sendFixedBlock].

	(method == #dynamic) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'D'].
		bitsRequired := dynamicLength.
		encoder nextBits: 3 put: DynamicBlock << 1 + lastFlag.
		self sendDynamicBlock: blTree 
			literalTree: lTree 
			distanceTree: dTree 
			bitLengths: blBits].

	bitsRequired = (encoder bitPosition - bitsSent)
		ifFalse:[self error:'Bits size mismatch'].

	lastBlock 
		ifTrue:[self release]
		ifFalse:[self initializeNewBlock].! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'!
shouldFlush
	"Check if we should flush the current block.
	Flushing can be useful if the input characteristics change."
	| nLits |
	litCount = literals size ifTrue:[^true]. "We *must* flush"
	(litCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes"
	matchCount * 10 <= litCount ifTrue:[
		"This is basically random data. 
		There is no need to flush early since the overhead
		for encoding the trees will add to the overall size"
		^false].
	"Try to adapt to the input data.
	We flush if the ratio between matches and literals
	changes beyound a certain threshold"
	nLits := litCount - matchCount.
	nLits <= matchCount ifTrue:[^false]. "whow!! so many matches"
	^nLits * 4 <= matchCount! !


!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'!
fixedBlockSizeFor: lTree and: dTree
	"Compute the length for the current block using fixed huffman trees"
	| bits extra |
	bits := 3 "block type".
	"Compute the size of the compressed block"
	0 to: NumLiterals do:[:i| "encoding of literals"
		bits := bits + ((literalFreq at: i+1) * (FixedLiteralTree bitLengthAt: i))].
	NumLiterals+1 to: lTree maxCode+1 do:[:i| "Encoding of match lengths"
		extra := ExtraLengthBits at: i-NumLiterals.
		bits := bits + ((literalFreq at: i+1) * ((FixedLiteralTree bitLengthAt: i) + extra))].
	0 to: dTree maxCode do:[:i| "encoding of distances"
		extra := ExtraDistanceBits at: i+1.
		bits := bits + ((distanceFreq at: i+1) * ((FixedDistanceTree bitLengthAt: i) + extra))].

	^bits! !

!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'!
sendFixedBlock
	"Send a block using fixed huffman trees"
	self sendCompressedBlock: FixedLiteralTree with: FixedDistanceTree.! !


!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 2/28/2001 13:39'!
close
	self deflateBlock.
	self flushBlock: true.
	encoder close.! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 2/27/2001 13:23'!
finish
	"Finish pending operation. Do not close output stream."
	self deflateBlock.
	self flushBlock: true.
	encoder flush.! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:40'!
initialize
	super initialize.
	literals := ByteArray new: WindowSize.
	distances := WordArray new: WindowSize.
	literalFreq := WordArray new: MaxLiteralCodes.
	distanceFreq := WordArray new: MaxDistCodes.
	self initializeNewBlock.
! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 18:29'!
initializeNewBlock
	"Initialize the encoder for a new block of data"
	literalFreq atAllPut: 0.
	distanceFreq atAllPut: 0.
	literalFreq at: EndBlock+1 put: 1.
	litCount := 0.
	matchCount := 0.! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 2/24/2001 19:43'!
on: aCollectionOrStream
	crc := 16rFFFFFFFF.
	crcPosition := 1.
	bytesWritten := 0.
	encoder := ZipEncoder on: aCollectionOrStream.
	encoder isBinary
		ifTrue:[super on: ByteArray new]
		ifFalse:[super on: String new].
	self writeHeader.
! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'nk 2/17/2004 16:31'!
release
	"We're done with compression. Do some cleanup."
	literals := distances := literalFreq := distanceFreq := nil.
	self updateCrc.
	encoder flushBits.
	self writeFooter.! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'nk 2/17/2004 16:30'!
writeFooter
	"Write footer information if necessary"
	crc := crc bitXor: 16rFFFFFFFF.! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 2/24/2001 19:44'!
writeHeader
	"Write header information if necessary"! !


!ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 1/2/2000 16:36'!
sendStoredBlock
	"Send an uncompressed block"
	| inBytes |
	inBytes := blockPosition - blockStart.
	encoder flushBits. "Skip to byte boundary"
	encoder nextBits: 16 put: inBytes.
	encoder nextBits: 16 put: (inBytes bitXor: 16rFFFF).
	encoder flushBits.
	1 to: inBytes do:[:i|
		encoder nextBytePut: (collection byteAt: blockStart+i)].! !

!ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 12/30/1999 00:42'!
storedBlockSize
	"Compute the length for the current block when stored as is"
	^3 "block type bits" 
		+ (8 - (encoder bitPosition + 3 bitAnd: 7) bitAnd: 7)"skipped bits to byte boundary"
			+ 32 "byte length + chksum" 
				+ (blockPosition - blockStart * 8) "actual data bits".! !


!ZipWriteStream methodsFor: 'private' stamp: 'ar 2/24/2001 19:45'!
moveContentsToFront
	"Need to update crc here"
	self updateCrc.
	super moveContentsToFront.
	crcPosition := position + 1.! !

!ZipWriteStream methodsFor: 'private' stamp: 'ar 2/24/2001 19:45'!
updateCrc
	crcPosition <= position ifTrue:[
		bytesWritten := bytesWritten + position - crcPosition + 1.
		crc := self updateCrc: crc from: crcPosition to: position in: collection.
		crcPosition := position + 1].! !

!ZipWriteStream methodsFor: 'private' stamp: 'nk 2/17/2004 16:51'!
updateCrc: oldCrc from: start to: stop in: aCollection
	^self class updateCrc: oldCrc from: start to: stop in: aCollection! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipWriteStream class
	instanceVariableNames: ''!

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'!
baseDistance
	^BaseDistance! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'!
baseLength
	^BaseLength! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 2/24/2001 19:42'!
crcTable
	^CrcTable! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'!
distanceCodes
	^DistanceCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'!
extraDistanceBits
	^ExtraDistanceBits! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'!
extraLengthBits
	^ExtraLengthBits! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'!
matchLengthCodes
	^MatchLengthCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'!
maxDistanceCodes
	^MaxDistCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'!
maxLiteralCodes
	^MaxLiteralCodes! !


!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 19:10'!
initialize
	"ZipWriteStream initialize"
	VerboseLevel := 0.
	self initializeCrcTable.! !

!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 2/24/2001 19:42'!
initializeCrcTable
	"ZipWriteStream initialize"
	CrcTable := #(16r00000000 16r77073096 16rEE0E612C 16r990951BA 16r076DC419
  16r706AF48F 16rE963A535 16r9E6495A3 16r0EDB8832 16r79DCB8A4
  16rE0D5E91E 16r97D2D988 16r09B64C2B 16r7EB17CBD 16rE7B82D07
  16r90BF1D91 16r1DB71064 16r6AB020F2 16rF3B97148 16r84BE41DE
  16r1ADAD47D 16r6DDDE4EB 16rF4D4B551 16r83D385C7 16r136C9856
  16r646BA8C0 16rFD62F97A 16r8A65C9EC 16r14015C4F 16r63066CD9
  16rFA0F3D63 16r8D080DF5 16r3B6E20C8 16r4C69105E 16rD56041E4
  16rA2677172 16r3C03E4D1 16r4B04D447 16rD20D85FD 16rA50AB56B
  16r35B5A8FA 16r42B2986C 16rDBBBC9D6 16rACBCF940 16r32D86CE3
  16r45DF5C75 16rDCD60DCF 16rABD13D59 16r26D930AC 16r51DE003A
  16rC8D75180 16rBFD06116 16r21B4F4B5 16r56B3C423 16rCFBA9599
  16rB8BDA50F 16r2802B89E 16r5F058808 16rC60CD9B2 16rB10BE924
  16r2F6F7C87 16r58684C11 16rC1611DAB 16rB6662D3D 16r76DC4190
  16r01DB7106 16r98D220BC 16rEFD5102A 16r71B18589 16r06B6B51F
  16r9FBFE4A5 16rE8B8D433 16r7807C9A2 16r0F00F934 16r9609A88E
  16rE10E9818 16r7F6A0DBB 16r086D3D2D 16r91646C97 16rE6635C01
  16r6B6B51F4 16r1C6C6162 16r856530D8 16rF262004E 16r6C0695ED
  16r1B01A57B 16r8208F4C1 16rF50FC457 16r65B0D9C6 16r12B7E950
  16r8BBEB8EA 16rFCB9887C 16r62DD1DDF 16r15DA2D49 16r8CD37CF3
  16rFBD44C65 16r4DB26158 16r3AB551CE 16rA3BC0074 16rD4BB30E2
  16r4ADFA541 16r3DD895D7 16rA4D1C46D 16rD3D6F4FB 16r4369E96A
  16r346ED9FC 16rAD678846 16rDA60B8D0 16r44042D73 16r33031DE5
  16rAA0A4C5F 16rDD0D7CC9 16r5005713C 16r270241AA 16rBE0B1010
  16rC90C2086 16r5768B525 16r206F85B3 16rB966D409 16rCE61E49F
  16r5EDEF90E 16r29D9C998 16rB0D09822 16rC7D7A8B4 16r59B33D17
  16r2EB40D81 16rB7BD5C3B 16rC0BA6CAD 16rEDB88320 16r9ABFB3B6
  16r03B6E20C 16r74B1D29A 16rEAD54739 16r9DD277AF 16r04DB2615
  16r73DC1683 16rE3630B12 16r94643B84 16r0D6D6A3E 16r7A6A5AA8
  16rE40ECF0B 16r9309FF9D 16r0A00AE27 16r7D079EB1 16rF00F9344
  16r8708A3D2 16r1E01F268 16r6906C2FE 16rF762575D 16r806567CB
  16r196C3671 16r6E6B06E7 16rFED41B76 16r89D32BE0 16r10DA7A5A
  16r67DD4ACC 16rF9B9DF6F 16r8EBEEFF9 16r17B7BE43 16r60B08ED5
  16rD6D6A3E8 16rA1D1937E 16r38D8C2C4 16r4FDFF252 16rD1BB67F1
  16rA6BC5767 16r3FB506DD 16r48B2364B 16rD80D2BDA 16rAF0A1B4C
  16r36034AF6 16r41047A60 16rDF60EFC3 16rA867DF55 16r316E8EEF
  16r4669BE79 16rCB61B38C 16rBC66831A 16r256FD2A0 16r5268E236
  16rCC0C7795 16rBB0B4703 16r220216B9 16r5505262F 16rC5BA3BBE
  16rB2BD0B28 16r2BB45A92 16r5CB36A04 16rC2D7FFA7 16rB5D0CF31
  16r2CD99E8B 16r5BDEAE1D 16r9B64C2B0 16rEC63F226 16r756AA39C
  16r026D930A 16r9C0906A9 16rEB0E363F 16r72076785 16r05005713
  16r95BF4A82 16rE2B87A14 16r7BB12BAE 16r0CB61B38 16r92D28E9B
  16rE5D5BE0D 16r7CDCEFB7 16r0BDBDF21 16r86D3D2D4 16rF1D4E242
  16r68DDB3F8 16r1FDA836E 16r81BE16CD 16rF6B9265B 16r6FB077E1
  16r18B74777 16r88085AE6 16rFF0F6A70 16r66063BCA 16r11010B5C
  16r8F659EFF 16rF862AE69 16r616BFFD3 16r166CCF45 16rA00AE278
  16rD70DD2EE 16r4E048354 16r3903B3C2 16rA7672661 16rD06016F7
  16r4969474D 16r3E6E77DB 16rAED16A4A 16rD9D65ADC 16r40DF0B66
  16r37D83BF0 16rA9BCAE53 16rDEBB9EC5 16r47B2CF7F 16r30B5FFE9
  16rBDBDF21C 16rCABAC28A 16r53B39330 16r24B4A3A6 16rBAD03605
  16rCDD70693 16r54DE5729 16r23D967BF 16rB3667A2E 16rC4614AB8
  16r5D681B02 16r2A6F2B94 16rB40BBE37 16rC30C8EA1 16r5A05DF1B
  16r2D02EF8D
).! !


!ZipWriteStream class methodsFor: 'crc' stamp: 'nk 2/17/2004 16:50'!
updateCrc: oldCrc from: start to: stop in: aCollection
	| newCrc |
	<primitive: 'primitiveUpdateGZipCrc32' module: 'ZipPlugin'>
	newCrc := oldCrc.
	start to: stop do:[:i|
		newCrc := (CrcTable at: ((newCrc bitXor: (aCollection byteAt: i)) 
				bitAnd: 255) + 1) bitXor: (newCrc bitShift: -8).
	].
	^newCrc! !


!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:48'!
compressAndDecompress: aFile using: tempName stats: stats
	| fileSize tempFile result |
	aFile == nil ifTrue:[^nil].
	fileSize := aFile size.
	(fileSize < 1"00000" "or:[fileSize > 1000000]") ifTrue:[aFile close. ^nil].
	Transcript cr; show:'Testing ', aFile name,' ... '.
	tempFile := StandardFileStream new open: tempName forWrite: true.
	'Compressing ', aFile name,'...' displayProgressAt: Sensor cursorPoint
		from: 1 to: aFile size during:[:bar|
			result := self regressionCompress: aFile into: tempFile notifiying: bar stats: stats].
	result ifTrue:[
		'Validating ', aFile name,'...' displayProgressAt: Sensor cursorPoint
			from: 0 to: aFile size during:[:bar|
				result := self regressionDecompress: aFile from: tempFile notifying: bar stats: stats]].
	aFile close.
	tempFile close.
	FileDirectory default deleteFileNamed: tempName ifAbsent:[].
	result ~~ false ifTrue:[
		Transcript show:' ok (', (result * 100 truncateTo: 0.01) printString,')'].
	^result! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 21:11'!
logProblem: reason for: aFile
	| errFile |
	errFile := FileStream fileNamed:'problems.log'.
	errFile position: errFile size.
	errFile cr; nextPutAll: aFile name;
			cr; nextPutAll: reason.
	errFile close.
	Transcript show:' failed (', reason,')'.
	aFile close.
	^false! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:48'!
printRegressionStats: stats from: fd
	| raw compressed numFiles |
	raw := stats at: #rawSize ifAbsent:[0].
	raw = 0 ifTrue:[^self].
	compressed := stats at: #compressedSize ifAbsent:[0].
	numFiles := stats at: #numFiles ifAbsent:[0].
	Transcript cr; nextPutAll: fd pathName.
	Transcript crtab; nextPutAll:'Files compressed: ', numFiles asStringWithCommas.
	Transcript crtab; nextPutAll:'Bytes compressed: ', raw asStringWithCommas.
	Transcript crtab; nextPutAll:'Avg. compression ratio: ';
		print: ((compressed / raw asFloat * 100.0) truncateTo: 0.01).
	Transcript endEntry.! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:44'!
regressionCompress: aFile into: tempFile notifiying: progressBar stats: stats
	"Compress aFile into tempFile"
	| zip encoded buffer |
	aFile binary.
	aFile position: 0.
	tempFile binary.
	buffer := ByteArray new: 4096.
	zip := self on: (ByteArray new: 10000).
	encoded := zip encodedStream.
	[aFile atEnd] whileFalse:[
		progressBar value: aFile position.
		zip nextPutAll: (aFile nextInto: buffer).
		encoded position > 0 ifTrue:[
			tempFile nextPutAll: encoded contents.
			encoded position: 0]].
	zip close.
	tempFile nextPutAll: encoded contents.
	^true! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:45'!
regressionDecompress: aFile from: tempFile notifying: progressBar stats: stats
	"Validate aFile as decompressed from tempFile"
	| unzip rawSize compressedSize buffer1 buffer2 |
	rawSize := aFile size.
	compressedSize := tempFile size.
	aFile ascii.
	aFile position: 0.
	tempFile ascii.
	tempFile position: 0.
	buffer1 := String new: 4096.
	buffer2 := buffer1 copy.
	unzip := FastInflateStream on: tempFile.
	[aFile atEnd] whileFalse:[
		progressBar value: aFile position.
		buffer1 := aFile nextInto: buffer1.
		buffer2 := unzip nextInto: buffer2.
		buffer1 = buffer2
			ifFalse:[^self logProblem: 'contents ' for: aFile].
	].
	unzip next = nil ifFalse:[^self logProblem: 'EOF' for: aFile].
	stats at: #rawSize put:
		(stats at: #rawSize ifAbsent:[0]) + rawSize.
	stats at: #compressedSize put:
		(stats at: #compressedSize ifAbsent:[0]) + compressedSize.
	^compressedSize asFloat / rawSize asFloat.! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:48'!
regressionTest "ZipWriteStream regressionTest"
	"Compress and decompress everything we can 
	find to validate that compression works as expected."
	self regressionTestFrom: (FileDirectory default).! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:46'!
regressionTestFrom: fd
	"ZipWriteStream regressionTestFrom: FileDirectory default"
	"ZipWriteStream regressionTestFrom: (FileDirectory on:'')"
	"ZipWriteStream regressionTestFrom: (FileDirectory on:'C:')"
	| tempName stats |
	Transcript clear.
	stats := Dictionary new.
	tempName := FileDirectory default fullNameFor: '$$sqcompress$$'.
	FileDirectory default deleteFileNamed: tempName.
	self regressionTestFrom: fd using: tempName stats: stats.! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:47'!
regressionTestFrom: fd using: tempName stats: stats
	| files file fullName |
	files := fd fileNames asSortedCollection.
	files do:[:fName|
		file := nil.
		fullName := fd fullNameFor: fName.
		fullName = tempName ifFalse:[
			file := StandardFileStream new open: fullName forWrite: false].
		self compressAndDecompress: file using: tempName stats: stats].
	stats at: #numFiles put: (stats at: #numFiles ifAbsent:[0]) + files size.
	files := nil.
	self printRegressionStats: stats from: fd.
	fd directoryNames asSortedCollection do:[:dName|
		self regressionTestFrom: (fd directoryNamed: dName) using: tempName stats: stats.
	].! !
RectangleMorph subclass: #ZoomAndScrollControllerMorph
	instanceVariableNames: 'mouseDownPoint mouseMovePoint panAndTiltFactor zoomFactor target hasFocus currentKeyDown upDownCodes changeKeysState programmedMoves'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 15:45'!
cameraPoint

	target ifNil: [^0@0].
	^target cameraPoint
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 15:48'!
cameraPoint: aPoint

	target ifNil: [^self].
	target cameraPoint: aPoint! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 17:07'!
cameraPointRounded

	^self cameraPoint rounded! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 16:27'!
cameraScale

	target ifNil: [^1.0].
	^target scale
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/6/2000 11:43'!
cameraScale: aNumber

	target ifNil: [^self].
	target changeScaleTo: aNumber! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 14:14'!
changeKeys

	upDownCodes _ Dictionary new.
	changeKeysState _ #(up down in out).
	self changed.! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 14:54'!
currentCameraVersion

	^2! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 16:06'!
deadZoneWidth

	^8
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:30'!
doProgrammedMoves

	| thisMove startPoint endPoint startZoom endZoom newScale newPoint fractionLeft |

	programmedMoves isEmptyOrNil ifTrue: [
		^programmedMoves _ nil
	].
	thisMove _ programmedMoves first.
	thisMove at: #pauseTime ifPresent: [ :ignore | ^self].

	fractionLeft _ self fractionLeftInMove: thisMove.
	fractionLeft ifNil: [^programmedMoves _ programmedMoves allButFirst].

	startPoint _ thisMove at: #startPoint ifAbsentPut: [self cameraPoint].
	endPoint _ thisMove at: #endPoint ifAbsentPut: [self cameraPoint].

	startZoom _ thisMove at: #startZoom ifAbsentPut: [self cameraScale].
	endZoom _ thisMove at: #endZoom ifAbsentPut: [self cameraScale].
	newScale _ endZoom - (endZoom - startZoom * fractionLeft).
	newPoint _ (endPoint - (endPoint - startPoint * fractionLeft)) "rounded".
	target changeScaleTo: newScale.
	target cameraPoint: newPoint.

	fractionLeft <= 0 ifTrue: [^programmedMoves _ programmedMoves allButFirst].

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 12:03'!
editAScript

	| d names reply s |
	d _ self targetScriptDictionary.
	names _ d keys asSortedCollection.
	reply _ (SelectionMenu labelList: names selections: names) startUpWithCaption: 'Script to edit?'.
	reply ifNil: [^ self].
	(s _ ZASMScriptMorph new)
		decompileScript: (d at: reply) named: reply for: self;
		fullBounds;
		align: s center with: self center;
		openInWorld
	! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/6/2000 13:08'!
fractionLeftInMove: thisMove

	| steps stepsRemaining fractionLeft endTime startTime |

	(thisMove includesKey: #steps) ifTrue: [
		steps _ thisMove at: #steps ifAbsentPut: [1].
		stepsRemaining _ thisMove at: #stepsRemaining ifAbsentPut: [steps].
		stepsRemaining < 1 ifTrue: [^nil].
		stepsRemaining _ stepsRemaining - 1.
		fractionLeft _ stepsRemaining / steps. 
		thisMove at: #stepsRemaining put: stepsRemaining.
	] ifFalse: [
		endTime _ thisMove at: #endTime ifAbsent: [^nil].
		startTime _ thisMove at: #startTime ifAbsent: [^nil].
		fractionLeft _ (endTime - Time millisecondClockValue) / (endTime - startTime).
	].
	^fractionLeft max: 0
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 15:35'!
grabCameraPositionEvent: anEvent morph: aMorph
 
	| mark |
	mark _ ZASMCameraMarkMorph new.
	mark 
		cameraPoint: self cameraPoint
		cameraScale: self cameraScale
		controller: self
		page: target.
	anEvent hand attachMorph: mark.! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/12/2000 13:55'!
patchOldVersion1

	"hack.. use this as an opportunity to fix old versions"
	self allMorphsDo: [:m |
		((m isKindOf: UpdatingStringMorph) and: [m getSelector == #cameraPoint]) ifTrue: [
			m getSelector: #cameraPointRounded
		].
	].

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:30'!
pauseProgrammedMoves

	programmedMoves isEmptyOrNil ifTrue: [^self].
	programmedMoves first
		at: #pauseTime
		put: Time millisecondClockValue
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:38'!
resumeProgrammedMoves

	| thisStep |

	programmedMoves isEmptyOrNil ifTrue: [^self].
	(thisStep _ programmedMoves first)
		at: #pauseTime
		ifPresent: [ :pauseTime |
			thisStep 
				at: #startTime 
				put: (thisStep at: #startTime) + Time millisecondClockValue - pauseTime.
			thisStep removeKey: #pauseTime ifAbsent: [].
		].
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:45'!
runAScript

	| d names reply |
	d _ self targetScriptDictionary.
	names _ d keys asSortedCollection.
	reply _ (SelectionMenu labelList: names selections: names) startUpWithCaption: 'Script to run?'.
	reply ifNil: [^ self].
	programmedMoves _ (d at: reply) veryDeepCopy.! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:34'!
saveScript: newScript as: scriptName

	self targetScriptDictionary at: scriptName put: newScript.

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:38'!
setProgrammedMoves: aCollection

	programmedMoves _ aCollection
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 17:53'!
target: x

	target _ x.
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:34'!
targetScriptDictionary

	| scriptDict |
	target ifNil: [^Dictionary new].
	^target 
		valueOfProperty: #namedCameraScripts 
		ifAbsent: [
			scriptDict _ Dictionary new.
			target setProperty: #namedCameraScripts toValue: scriptDict.
			scriptDict
		].

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 17:53'!
turnToPage: page position: aPoint scale: aNumber transition: aSpec
 
	| myBook |

	target == page ifTrue: [^false].
	page ifNil: [^false].
	myBook _ (self ownerThatIsA: StoryboardBookMorph) ifNil: [^ false].
	2 timesRepeat: [
		page
			cameraPoint: aPoint;
			changeScaleTo: aNumber
	].
	BookMorph turnOffSoundWhile: [
		myBook 
			goToPageMorph: page 
			transitionSpec: aSpec.
	].
	^true! !


!ZoomAndScrollControllerMorph methodsFor: 'drawing' stamp: 'RAA 12/2/2000 14:24'!
drawOn: aCanvas

	| dw bullsEye f |

	super drawOn: aCanvas.
	changeKeysState ifNotNil: [
		f _ (
			StringMorph contents: 'Press the key to be used for "',changeKeysState first,'"'
		) imageForm.
		aCanvas paintImage: f at: self center - (f extent // 2).
		^self
	].
	mouseDownPoint ifNil: [^self].
	dw _ self deadZoneWidth.
	bullsEye _ mouseDownPoint - (dw@dw//2) extent: dw@dw.
	aCanvas 
		fillRectangle: (bullsEye left @ self top corner: bullsEye right @ self bottom) 
		color: (Color red alpha: 0.3).
	aCanvas 
		fillRectangle: (self left @ bullsEye top corner: self right @ bullsEye bottom) 
		color: (Color red alpha: 0.3).
	aCanvas 
		fillRectangle: bullsEye 
		color: (Color red alpha: 0.4).
! !


!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/1/2000 16:21'!
handlesKeyboard: evt

	^true! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/1/2000 15:22'!
handlesMouseDown: evt

	^true! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/1/2000 16:21'!
handlesMouseOver: evt

	^true! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/1/2000 16:24'!
hasFocus

	^ hasFocus! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/2/2000 14:22'!
keyDown: anEvent

	changeKeysState ifNotNil: [
		upDownCodes at: anEvent keyValue put: changeKeysState first.
		changeKeysState _ changeKeysState allButFirst.
		changeKeysState isEmpty ifTrue: [changeKeysState _ nil].
		currentKeyDown _ Set new.
		^self changed
	].
	currentKeyDown add: anEvent keyValue.
! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/18/2000 14:55'!
keyStroke: anEvent

! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/2/2000 14:21'!
keyUp: anEvent

	currentKeyDown remove: anEvent keyValue ifAbsent: [].! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/1/2000 15:23'!
mouseDown: evt

	mouseDownPoint _ evt cursorPoint.
	self changed.! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/1/2000 18:23'!
mouseEnter: evt

	evt hand newKeyboardFocus: self.
	currentKeyDown _ Set new.
	hasFocus _ true.

! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'di 11/30/2001 10:54'!
mouseLeave: evt

	currentKeyDown _ Set new.
	hasFocus _ false.
	mouseMovePoint _ mouseDownPoint _ nil.
! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/1/2000 15:23'!
mouseMove: evt

	mouseMovePoint _ evt cursorPoint.

! !

!ZoomAndScrollControllerMorph methodsFor: 'event handling' stamp: 'RAA 12/1/2000 15:23'!
mouseUp: evt

	mouseMovePoint _ mouseDownPoint _ nil.
	self changed.! !


!ZoomAndScrollControllerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color transparent! !

!ZoomAndScrollControllerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 0! !

!ZoomAndScrollControllerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:32'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightBlue! !

!ZoomAndScrollControllerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:36'!
initialize
	"initialize the state of the receiver"
	| displayer dataMorph |
	super initialize.
	""
	hasFocus _ true.
	currentKeyDown _ Set new.
	upDownCodes _ Dictionary new.
	upDownCodes at: 126 put: #up;
		 at: 125 put: #down;
		 at: 123 put: #out;
		 at: 124 put: #in.
	"arrow keys on the mac"
	self extent: 40 @ 40;
		 vResizing: #rigid;
		 hResizing: #spaceFill;
		 setBalloonText: 'Drag in here to zoom, tilt and pan the page above'.
	dataMorph _ AlignmentMorph newColumn.
	dataMorph color: Color yellow;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap.
	dataMorph
		on: #mouseDown
		send: #grabCameraPositionEvent:morph:
		to: self.
	displayer _ UpdatingStringMorph new getSelector: #cameraPointRounded;
				 target: self;
				 growable: true;
				 putSelector: nil.
	dataMorph addMorph: displayer lock.
	displayer _ UpdatingStringMorph new getSelector: #cameraScale;
				 target: self;
				 growable: true;
				 floatPrecision: 0.001;
				 putSelector: nil.
	dataMorph addMorph: displayer lock.
	self addMorph: dataMorph! !


!ZoomAndScrollControllerMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 22:32'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'change tilt and zoom keys' translated action: #changeKeys.
	aCustomMenu add: 'run an existing camera script' translated action: #runAScript.
	aCustomMenu add: 'edit an existing camera script' translated action: #editAScript.

! !


!ZoomAndScrollControllerMorph methodsFor: 'stepping and presenter' stamp: 'RAA 12/18/2000 14:55'!
step

	| delta halfDW action |

	(self valueOfProperty: #currentCameraVersion ifAbsent: [0]) = 
							self currentCameraVersion ifFalse: [
		self patchOldVersion1.
		self setProperty: #currentCameraVersion toValue: self currentCameraVersion.
	].
	super step.
	self doProgrammedMoves.

	(currentKeyDown ifNil: [#()]) do: [ :each |
		action _ upDownCodes at: each ifAbsent: [#fugeddaboutit].
		action == #in ifTrue: [
			target scaleImageBy: -10.
		].
		action == #out ifTrue: [
			target scaleImageBy: 10.
		].
		action == #up ifTrue: [
			target tiltImageBy: -20.
		].
		action == #down ifTrue: [
			target tiltImageBy: 20.
		].
	].
	mouseMovePoint ifNil: [^self].
	mouseDownPoint ifNil: [^self].
	target ifNil: [^self].
	halfDW _ self deadZoneWidth // 2.
	delta _ mouseMovePoint - mouseDownPoint.
	delta x abs <= halfDW ifTrue: [delta _ 0@delta y].
	delta y abs <= halfDW ifTrue: [delta _ delta x@0].
	
	target panImageBy: delta x.



! !


!ZoomAndScrollControllerMorph methodsFor: 'testing' stamp: 'RAA 12/1/2000 15:28'!
stepTime

	^10

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZoomAndScrollControllerMorph class
	instanceVariableNames: ''!

!ZoomAndScrollControllerMorph class methodsFor: '*eToys-scripting' stamp: 'sw 9/26/2001 04:28'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((#storyboard
			(
	(slot cameraPoint 'the camera point' Point readWrite Player cameraPoint Player cameraPoint:)
			)
	))! !
PasteUpMorph subclass: #ZoomAndScrollMorph
	instanceVariableNames: 'sourceRectangle usingBalloon panAndTiltFactor zoomFactor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!ZoomAndScrollMorph commentStamp: '<historical>' prior: 0!
I am the outer part of a transformed view of another pasteup. I know how to translate requests to pan, tilt and zoom into appropriate changes to the transformation!


!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/8/2000 12:27'!
changeOffsetBy: aPoint

	| transform rounder roundPt |

	"improve behavior at high magnification by rounding change to whole source pixels"
	transform _ self myTransformMorph.
	rounder _ [ :val |
		"(val abs + (transform scale * 0.99) roundTo: transform scale) * val sign"
		"looks like rounding wasn't a good solution"
		val
	].
	roundPt _ (rounder value: aPoint x) @ (rounder value: aPoint y).

	self changeOffsetTo: transform offset + roundPt.
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2000 18:31'!
changeOffsetTo: aPoint

	| transform trialOffset innerPasteup keepWidth keepHeight |

	transform _ self myTransformMorph.
	keepWidth _ transform width "// 4".
	keepHeight _ transform height "// 4".
	innerPasteup _ transform firstSubmorph.
	trialOffset _ aPoint.
	trialOffset _ 
		(trialOffset x 
			min: (innerPasteup width * transform scale) - keepWidth 
			max: keepWidth - transform width) @ 
		(trialOffset y 
			min: (innerPasteup height * transform scale) - keepHeight 
			max: keepHeight - transform height).
	transform offset: trialOffset.

! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 17:51'!
changeScaleTo: aNumber

	| transform innerPasteup min1 min2 newScale oldPoint |

	transform _ self myTransformMorph.
	"oldScale _ transform scale."
	innerPasteup _ transform firstSubmorph.

	min1 _ transform width / innerPasteup width asFloat.
	min2 _ transform height / innerPasteup height asFloat.
	newScale _ (aNumber max: min1) max: min2.

	oldPoint _ self cameraPoint.
	transform scale: newScale.
	self cameraPoint: oldPoint.

	"scaleR _ newScale / oldScale.
	half _ transform extent // 2.
	half _ 0@0.
	self changeOffsetBy: scaleR * (transform offset + half) - half - transform offset."

"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:12'!
changeTiltFactor: x

	panAndTiltFactor _ x! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:13'!
changeZoomFactor: x

	zoomFactor _ x! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:15'!
getTiltFactor

	^panAndTiltFactor ifNil: [panAndTiltFactor _ 0.5].
	
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:16'!
getZoomFactor

	^zoomFactor ifNil: [zoomFactor _ 0.5].
	
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 22:49'!
panImageBy: pixels

	self changeOffsetBy: (pixels * self getTiltFactor * 0.1) @ 0.

	"steps _ (pixels abs / 6) exp rounded * pixels sign."
"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="

! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2000 18:31'!
scaleImageBy: pixels

	| scalePerPixel steps transform factor |

	transform _ self myTransformMorph.
	(steps _ (pixels * self getZoomFactor * 0.2) rounded) = 0 ifTrue: [^self].
	scalePerPixel _ 1.01.
	factor _ scalePerPixel raisedTo: steps abs.
	steps > 0 ifTrue: [
		factor _ 1.0 / factor.
	].
	self changeScaleTo: (transform scale * factor min: 10.0 max: 0.1).
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 22:50'!
tiltImageBy: pixels

	self changeOffsetBy: 0 @ (pixels * self getTiltFactor * 0.1)

"	steps _ (pixels abs / 6) exp rounded * pixels sign.
"
"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="
! !


!ZoomAndScrollMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 11/22/2000 15:40'!
wantsDroppedMorph: aMorph event: evt

	"we don't, really, but it avoids problem of outer pasteup rejecting a drop for inner pasteup"
	^true! !


!ZoomAndScrollMorph methodsFor: 'geometry' stamp: 'RAA 12/5/2000 18:31'!
extent: extentPoint

	super extent: extentPoint.
	self myTransformMorph bounds: self innerBounds.
! !


!ZoomAndScrollMorph methodsFor: 'initialization' stamp: 'RAA 11/30/2000 16:45'!
createInteriorTransform

	| innerPasteUp tm |
	innerPasteUp _ PasteUpMorph new.
	innerPasteUp 
		borderWidth: 0;
		minHeight: 100;
		minWidth: 100;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		position: 0@0;
		extent: 100@100.
	tm _ TransformationB2Morph new.
	tm setProperty: #rotationCenter toValue: 0@0.
	tm useRegularWarpBlt: usingBalloon not.
	self addMorph: tm.
	tm addMorph: innerPasteUp.
	tm beSticky.
	innerPasteUp beSticky.
	tm
		scale: 1.0;
		offset: 0@0.
	! !

!ZoomAndScrollMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color red! !

!ZoomAndScrollMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:32'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!ZoomAndScrollMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:32'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	usingBalloon _ true.
	self createInteriorTransform ! !


!ZoomAndScrollMorph methodsFor: 'layout' stamp: 'RAA 11/21/2000 12:37'!
acceptDroppingMorph: morphToDrop event: evt

	^morphToDrop rejectDropMorphEvent: evt.		"put it back where it came from"

! !


!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/11/2000 17:05'!
cameraPoint

	^self myTransformMorph transform globalPointToLocal: self innerBounds center

! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:31'!
cameraPoint: newPt

	| transform |

	transform _ self myTransformMorph.
	self changeOffsetTo: newPt * transform scale - (transform innerBounds extent // 2) 

! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:30'!
myTransformMorph

	^self firstSubmorph
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:33'!
offsetX

	^self myTransformMorph offset x
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:31'!
offsetX: aNumber

	| transform |

	transform _ self myTransformMorph.
	transform offset: aNumber @ transform offset y
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:33'!
offsetY

	^self myTransformMorph offset y
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:31'!
offsetY: aNumber

	| transform |

	transform _ self myTransformMorph.
	transform offset: transform offset x @ aNumber
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:33'!
scale

	^self myTransformMorph scale
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/16/2000 17:51'!
scale: aValue

	self myTransformMorph scale: aValue.
! !


!ZoomAndScrollMorph methodsFor: 'stepping and presenter' stamp: 'RAA 12/5/2000 18:31'!
step

	| innerPasteUp overlap |

	innerPasteUp _ self myTransformMorph firstSubmorph.
	overlap _ (innerPasteUp submorphs 
		inject: 0@0 
		into: [ :min :each | min min: each position]) rounded.
	overlap = (0@0) ifFalse: [
		innerPasteUp submorphs do: [ :each | each position: each position - overlap].
		innerPasteUp layoutChanged.
	].



! !


!ZoomAndScrollMorph methodsFor: 'testing' stamp: 'RAA 12/1/2000 08:04'!
stepTime

	^10		"ms"! !
TransformMorph subclass: #ZoomMorph
	instanceVariableNames: 'fromMorph toMorph boundsSeq finalAction'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!ZoomMorph methodsFor: 'as yet unclassified'!
zoomFromMorph: m1 toMorph: m2 andThen: actionBlock
	| nSteps topLeft r2 r1 extent ratio r mouthDeltas |
	fromMorph _ m1.
	toMorph _ m2.
	r1 _ fromMorph fullBounds.
	r2 _ toMorph fullBounds.
	finalAction _ actionBlock.
	nSteps _ 8.
	boundsSeq _ OrderedCollection new.
	r _ (1/nSteps) asFloat.
	ratio _ r.
r1 _ 105@326 corner: 130@348.
mouthDeltas _ {-7@24. -6@21. -6@18. -4@14. -4@10. -3@8. -3@3. 0@0}.
	1 to: nSteps do:
		[:i | topLeft _ ((r2 topLeft - r1 topLeft) * ratio) asIntegerPoint + r1 topLeft.
		extent _ ((r2 extent - r1 extent) * ratio) asIntegerPoint + r1 extent.
		boundsSeq addLast: (topLeft + (mouthDeltas at: i) extent: extent).
		ratio _ ratio + r].
	self addMorph: toMorph.
	self step! !

!ZoomMorph methodsFor: 'as yet unclassified'!
zoomTo: newBounds
	| scale |
	self bounds: newBounds.
	scale _ newBounds extent / toMorph fullBounds extent.
	self setOffset: toMorph position - self position angle: 0.0 scale: scale! !


!ZoomMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:32'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color transparent! !


!ZoomMorph methodsFor: 'stepping and presenter'!
step

	boundsSeq isEmpty ifTrue:
		["If all done, then grant one final request and vanish"
		finalAction value.
		^ self delete].

	"Otherwise, zoom to the next rectangle"
	self zoomTo: boundsSeq removeFirst! !


!ZoomMorph methodsFor: 'testing'!
stepTime

	^ 40! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZoomMorph class
	instanceVariableNames: ''!

!ZoomMorph class methodsFor: 'new-morph participation' stamp: 'di 10/6/1998 13:15'!
includeInNewMorphMenu
	"Zooms aren't meaningful without initializations"
	^ false! !